Index: branches/LMDZ_WRFmeas/README
===================================================================
--- branches/LMDZ_WRFmeas/README	(revision 17)
+++ branches/LMDZ_WRFmeas/README	(revision 17)
@@ -0,0 +1,67 @@
+**** Coupling WRF and LMDZ
+* L.Fita, Laboratoire de Meteorologie Dynamique, CNRS, UPMC-Jussieu, Paris, FRANCE
+* July 2014
+
+* More information in:
+*   http://www.lmd.jussieu.fr/~lflmd/WRF_LMDZ/index.html
+*   http://web.lmd.jussieu.fr/trac-LMDZ_WRF
+
+*** Compilation instructions ***
+
+1.- Extraction of the source code:
+  $ svn co http://svn.lmd.jussieu.fr/LMDZ_WRF LMDZ_WRF
+
+2.- Copy (not int the repository folder...) folder 'WRFV3' to the desired spatial resolution (F77 legacy). As example one for 80x90x39
+  $ cp -R WRFV3 ${WORKDIR}/WRFV3_80x90x39 
+
+3.- Go to the ${WORKDIR} and compile there
+  $ cd ${WORKDIR}/WRFV3_80x90x39
+
+4.- Define domain size for LMDZ editing file lmdz/dimensions.h (see documentation for more details)
+  $ cat lmdz/dimensions.h
+       INTEGER iim,jjm,llm,ndm,wiim,wjjm,wbdym
+
+       PARAMETER (iim= 1, jjm=7031, llm=38,ndm=1,wiim=79,wjjm=89,wbdym=5)
+
+    jjm = (dimx-1) * (dimy -1)
+    llm = (dimz - 1)
+    wiim = dimx - 1
+    wjjm = dimy - 1
+    wbdym = 5 (up to now, mandatory to run WRF with 5 grid points in the sponge zone)
+
+5.- run script 'tools/prepare_compilation.bash' ('-h', for help. copy netCDF libraries and other staff not automatized)
+  $ ./prepare_compilation.bash [WRF_LMDZsrc] [NETCDFhome] ${WORKDIR}/WRFV3_80x90x39
+
+6.1- prepare compilation (ready for 'lmd' machines in serial) if not, edit
+  6.1.a: $ ./configure 
+  6.1.b: add pre-compiler flag' -DLMDZ after -DNETCDF (inside configure.wrf)
+  6.1.c: modify 'lmdz/Makefile with that values from the 'configure.wrf'
+6.2- prepare compilation modifying Registry files (already done, have a look just in case):
+  6.2.a $ ls -lrta Registry/Registry.EM
+    Registry/Registry.EM -> Registry.EM.LMDZ
+  6.2.b $ ls -lrta Registry/registry.dimspec -> registry.dimspec.lmdz
+
+7.- Compile as usual
+  $ compile em_real >& compile.log
+
+8.- Compile manually a lmdz subroutine (not working, not  knowing why). Example with gfortran serial in lmdz machines
+  $ cd lmdz
+  $ gfortran -O3 -ftree-vectorize -ftree-loop-linear -funroll-loops -w -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4   -fconvert=big-endian -frecord-marker=4 -O3 -ftree-vectorize -ftree-loop-linear -funroll-loops  -w -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 -g -O0 -fbacktrace -Wall -fbounds-check -c -L/u/lflmd/bin/gcc_netcdf-4.3.0/lib  -lnetcdf -lnetcdff  -I/u/lflmd/bin/gcc_netcdf-4.3.0/include lmdz_wrf_variables_mod.f90
+  $ cd ..
+
+9.- run script for second time 'tools/prepare_compilation.bash'
+  $ ./prepare_compilation.bash [WRF_LMDZsrc] [NETCDFhome] ${WORKDIR}/WRFV3_80x90x39
+
+10.- Recompile as usual
+  $ compile em_real >& compile.log
+
+11.- Checking compilation (empty outputs)
+  $ cat -n compile.log | grep Error
+  $ cat -n compile.log | grep Erreur (just in case you are in a French speaking computer)
+
+12.- Running simulation
+  11.a: Run all the steps 'WPS' and 'real.exe' as usual
+  11.b: folder 'WRFV3/run' is not completed (no binaries in repository!), thus get a copy of the right WRF version and use the original source
+  11.c: Edit and modify 'namelist.input' and all the LMDZ *def files provided in 'run' folder: 'config.def', 'gcm.def', 'physiq.def', 'run.def', 'traceur.def'
+
+12.- You're done, Have fun!
Index: branches/LMDZ_WRFmeas/WRFV3/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Makefile	(revision 17)
@@ -0,0 +1,598 @@
+#	Top level Makefile for wrf system
+
+LN      =       ln -s
+MAKE    =       make -i -r
+MV	=	/bin/mv
+RM      =       /bin/rm -f
+CHEM_FILES =	../chem/module_aerosols_sorgam.o \
+		../chem/module_gocart_aerosols.o \
+		../chem/module_mosaic_driver.o \
+		../chem/module_input_tracer.o
+
+deflt :
+		@ echo Please compile the code using ./compile
+
+include ./configure.wrf
+
+EM_MODULE_DIR = -I../dyn_em
+EM_MODULES =  $(EM_MODULE_DIR)
+
+DA_WRFVAR_MODULES = $(INCLUDE_MODULES)
+DA_WRFVAR_MODULES_2 = $(INC_MOD_WRFVAR)
+
+DA_CONVERTOR_MOD_DIR = -I../var/convertor -p../var/convertor
+DA_CONVERTOR_MODULES = $(DA_CONVERTOR_MOD_DIR) $(INCLUDE_MODULES)
+
+
+#### 3.d.   add macros to specify the modules for this core
+
+#EXP_MODULE_DIR = -I../dyn_exp
+#EXP_MODULES =  $(EXP_MODULE_DIR)
+
+# set this in the compile script now
+#J = -j 6
+
+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 main/libwrflib.lib
+	$(MAKE) MODULE_DIRS="$(ALL_MODULES)" framework
+	$(MAKE) MODULE_DIRS="$(ALL_MODULES)" shared
+
+wrf : framework_only
+	( cd $(WRF_SRC_ROOT_DIR)/lmdz ; make CC="$(CC) $(CFLAGS)" \
+          FC="$(FC) $(FCFLAGS) $(PROMOTION) $(BYTESWAPIO)" \
+          CPP="$(CPP) $(CPPFLAGS) -I. $(ARCHFLAGS) $(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ;\
+          $(RANLIB) $(WRF_SRC_ROOT_DIR)/lmdz/lmdz.a )
+	$(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_SST_ESMF ) ; \
+	fi
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+all_wrfvar : 
+	$(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" ext
+	$(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" toolsdir
+	if [ $(CRTM) ] ; then \
+	  (cd var/external/crtm; \
+	   export ABI_CRTM="${ABI_CRTM}"; . configure/$(SFC_CRTM).setup; $(MAKE) $(J) ) ; \
+	fi
+	if [ $(BUFR) ] ; then \
+	  (cd var/external/bufr;  \
+	  $(MAKE) $(J) FC="$(SFC)" CC="$(SCC)" CPP="$(CPP)" CPPFLAGS="$(CPPFLAGS)" CFLAGS="$(CFLAGS)" FFLAGS="$(FCDEBUG) $(FORMAT_FIXED)" RANLIB="$(RANLIB)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ) ; \
+	fi
+### Use 'make' to avoid '-i -r' above:
+	if [ $(WAVELET) ] ; then \
+	  ( cd var/external/wavelet; \
+		make CC="$(SC99) -DNOUNDERSCORE" RM="$(RM)" libWavelet.a; \
+		make FC="$(FC)" RM="$(RM)" lib_wavelet.a ) ; \
+	fi
+#	( cd var/build; touch depend.txt; make links; make depend; $(MAKE) $(J) all_wrfvar )
+	( cd var/build; make depend; $(MAKE) $(J) all_wrfvar )
+	( cd var/obsproc; $(MAKE) $(J) BUFR_CPP="$(BUFR_CPP)" )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+### 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 test/em_fire ; /bin/sh create_links.sh )
+	( 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 . )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+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 . )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+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 . )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+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 . )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+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 . )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+em_les : wrf
+	@ echo '--------------------------------------'
+	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=les em_ideal )
+	( cd test/em_les ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
+	( cd test/em_les ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
+	( cd test/em_les ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
+	( cd test/em_les ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . )
+	( cd test/em_les ; /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_les/namelist.input . )
+	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_les/input_sounding . )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+em_seabreeze2d_x : wrf
+	@ echo '--------------------------------------'
+	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=seabreeze2d_x em_ideal )
+	( cd test/em_seabreeze2d_x ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
+	( cd test/em_seabreeze2d_x ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
+	( cd test/em_seabreeze2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
+	( cd test/em_seabreeze2d_x ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . )
+	( cd test/em_seabreeze2d_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_seabreeze2d_x/namelist.input . )
+	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_seabreeze2d_x/input_sounding . )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+em_tropical_cyclone : wrf
+	@ echo '--------------------------------------'
+	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=tropical_cyclone em_ideal )
+	( cd test/em_tropical_cyclone ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
+	( cd test/em_tropical_cyclone ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
+	( cd test/em_tropical_cyclone ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
+	( 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_tropical_cyclone/namelist.input . )
+	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_tropical_cyclone/input_sounding . )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+em_scm_xy : wrf
+	@ echo '--------------------------------------'
+	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=scm_xy em_ideal )
+	( cd test/em_scm_xy ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
+	( cd test/em_scm_xy ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
+	( cd test/em_scm_xy ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
+	( 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_scm_xy/namelist.input . )
+	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_scm_xy/input_sounding . )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+convert_em : framework_only
+	if [ $(WRF_CONVERT) -eq 1 ] ; then \
+            ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" convert_em ) ; \
+        fi
+
+# Link wrf.exe and wrf_SST_ESMF.exe into 
+# test/em_esmf_exp when ESMF_COUPLING is set.  wrf.exe 
+# can be used for stand-alone testing in this case.  
+# wrf_SST_ESMF.exe is a coupled application.  Note that make 
+# target $(SOLVER)_wrf_SST_ESMF builds wrf_SST_ESMF.exe.  
+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_SST_ESMF ) ; \
+	  ( cd test/em_esmf_exp ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.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 RRTMG_LW_DATA RRTMG_SW_DATA ; \
+               ln -sf ../../run/ETAMPNEW_DATA . ;                      \
+               ln -sf ../../run/RRTM_DATA . ;                          \
+               ln -sf ../../run/RRTMG_LW_DATA . ;                      \
+               ln -sf ../../run/RRTMG_SW_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         ;   \
+                  ln -sf ../../run/RRTMG_LW_DATA_DBL RRTMG_LW_DATA ;   \
+                  ln -sf ../../run/RRTMG_SW_DATA_DBL RRTMG_SW_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 URBPARM.TBL ; ln -s ../../run/URBPARM.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 tc.exe ; ln -s ../../main/tc.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 RRTMG_LW_DATA RRTMG_SW_DATA ;    \
+             ln -sf ../../run/ETAMPNEW_DATA . ;                     \
+             ln -sf ../../run/RRTM_DATA . ;                         \
+             ln -sf ../../run/RRTMG_LW_DATA . ;                      \
+             ln -sf ../../run/RRTMG_SW_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 ;          \
+                ln -sf ../../run/RRTMG_LW_DATA_DBL RRTMG_LW_DATA ;  \
+                ln -sf ../../run/RRTMG_SW_DATA_DBL RRTMG_SW_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 URBPARM.TBL ; ln -s ../../run/URBPARM.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 tc.exe ; ln -s ../main/tc.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 . )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+
+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 . )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+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 . )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+em_heldsuarez : wrf
+	@ echo '--------------------------------------'
+	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=heldsuarez em_ideal )
+	( cd test/em_heldsuarez ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
+	( cd test/em_heldsuarez ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
+	( cd test/em_heldsuarez ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
+	( cd test/em_heldsuarez ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . )
+	( cd test/em_heldsuarez ; /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_heldsuarez/namelist.input . )
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+
+#### 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 . )
+
+#### emissions opt 3 converter
+
+opt3_conv : wrf
+	@ echo '--------------------------------------'
+	( cd chem ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real convert_fireemiss )
+	( cd test/em_real ; /bin/rm -f convert_fireemiss.exe ; ln -s ../../chem/convert_fireemiss.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 . )
+
+bioemiss_conv_megan2 : wrf
+	@ echo '--------------------------------------'
+	( cd chem ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real convert_bioemiss_megan2 )
+	( cd test/em_real ; /bin/rm -f convert_bioemiss_megan2.exe ; ln -s ../../chem/convert_bioemiss_megan2.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 . )
+
+#### DMS emissions converter
+
+dms_conv : wrf
+	@ echo '--------------------------------------'
+	( cd chem ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real convert_dms )
+	( cd test/em_real ; /bin/rm -f convert_dms.exe ; ln -s ../../chem/convert_dms.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 . )
+
+
+#### Dust errosion factor emissions converter
+
+dust_conv : wrf
+	@ echo '--------------------------------------'
+	( cd chem ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real convert_dust )
+	( cd test/em_real ; /bin/rm -f convert_dust.exe ; ln -s ../../chem/convert_dust.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 . )
+
+#### GOCART background state for oh, no3 and h2o2 converter
+
+gocart_conv : wrf
+	@ echo '--------------------------------------'
+	( cd chem ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real convert_gocart )
+	( cd test/em_real ; /bin/rm -f convert_gocart.exe ; ln -s ../../chem/convert_gocart.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.tbl ; ln -s ../../run/grib2map.tbl . )
+	( cd test/nmm_real ; /bin/rm -f co2_trans ; ln -s ../../run/co2_trans . )
+	( 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) $(J) framework; \
+          cd ../external/io_netcdf ; \
+          $(MAKE) NETCDFPATH="$(NETCDFPATH)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \
+               CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+               ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR" diffwrf; \
+          cd ../io_int ; \
+          $(MAKE) SFC="$(SFC) $(FCBASEOPTS)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+               TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+               ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR" diffwrf ; \
+          cd ../../frame )
+
+#          cd ../external/io_netcdf ; \
+#          $(MAKE) NETCDFPATH="$(NETCDFPATH)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \
+#               CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+#               ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="$(AR)" ARFLAGS+"$(ARFLAGS)" diffwrf; \
+#          cd ../io_int ; \
+#          $(MAKE) SFC="$(SFC) $(FCBASEOPTS)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+#               TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+#               ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="$(AR)" "$(ARFLAGS)" diffwrf ; \
+
+shared :
+	@ echo '--------------------------------------'
+	( cd share ; $(MAKE) $(J) )
+
+chemics :
+	@ echo '--------------------------------------'
+	if [ $(WRF_KPP) -eq 1 ] ; then ( cd chem ; $(MAKE) ) ; fi
+	if [ $(WRF_KPP) -eq 0 ] ; then ( cd chem ; $(MAKE) $(J) ) ; fi
+#	( cd chem ; $(MAKE) )
+#	( cd chem ; $(MAKE) $(J) )
+
+physics :
+	@ echo '--------------------------------------'
+	( cd phys ; $(MAKE)  $(J) )
+
+em_core :
+	@ echo '--------------------------------------'
+	if [ $(WRF_CHEM) -eq 0 ] ; then \
+		CF= ; \
+	else \
+		CF=$(CHEM_FILES) ; \
+	fi
+	( cd dyn_em ; $(MAKE) $(J) CF="$(CF)" )
+
+# 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 this will compile with MPI 2 calls MPI_Init_thread
+mpi2_thread_test :
+	@ cd tools ; /bin/rm -f mpi2_thread_test ; $(CC) -c mpi2_thread_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_TOOLS="$(CC_TOOLS) -DIWORDSIZE=$(IWORDSIZE) -DMAX_HISTORY=$(MAX_HISTORY)" )
+
+
+#	( cd tools ; $(MAKE) CC_TOOLS="$(CC_TOOLS) -DIO_MASK_SIZE=$(IO_MASK_SIZE)" )
+
+# 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
Index: branches/LMDZ_WRFmeas/WRFV3/README
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/README	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/README	(revision 17)
@@ -0,0 +1,317 @@
+WRF Model Version 3.3 (April 6, 2011)
+http://wrf-model.org/users/users.php
+
+------------------------
+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 3 source code release.
+======================================
+
+V3.3 Release Notes:
+-------------------
+
+Version 3.3 is released on April 6, 2011 (rev 4896).
+
+- For more information on WRF V3.3 release, visit WRF User's home pages
+  http://www.mmm.ucar.edu/wrf/users/, and
+  http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide.
+
+
+======================================
+
+V3.2.1 Release Notes (8/18/10):
+------------------
+
+This is a bug fix release. The detailed updates for WRF-ARW can be found at
+http://www.mmm.ucar.edu/wrf/users/wrfv3.2/updates-3.2.1.html, and
+for WRF-NMM at
+http://www.dtcenter.org/wrf-nmm/users/model/wrfv3/updates.php
+
+See online User's Guides for latest information.
+
+======================================
+
+V3.2 Release Notes:
+-------------------
+
+Version 3.2 is released on March 31, 2010.
+
+- For more information on WRF V3.2 release, visit WRF User's home pages
+  http://www.mmm.ucar.edu/wrf/users/, and 
+  http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide.
+
+
+======================================
+
+V3.1.1 Release Notes (7/31/09):
+------------------
+
+This is a bug fix release. The detailed updates for WRF-ARW can be found at
+http://www.mmm.ucar.edu/wrf/users/wrfv3.1/updates-3.1.1.html, and
+for WRF-NMM at
+http://www.dtcenter.org/wrf-nmm/users/model/wrfv3/updates.php
+
+See online User's Guides for latest information.
+
+======================================
+
+V3.1 Release Notes:
+-------------------
+
+Version 3.1 is released on April 9, 2009.
+
+- For more information on WRF V3.1 release, visit WRF Users home page
+  http://www.mmm.ucar.edu/wrf/users/, and read the online User's Guide.
+- WRF V3 executable will work with V3.0 wrfinput/wrfbdy (but requires 
+  inserting a new namelist variable use_baseparam_fr_nml in &dynamics). As
+  always, rerunning the new programs is recommended.
+- WRF V3.1 has changed a number of namelists. For example, ucmcall has
+  become sf_urban_physics, pd_moist(scalar/tke/chem) has become 
+  moist_adv_opt (scalar/tke/chem_adv_opt). Helpful messages will be printed
+  to aid you.
+
+
+V3.0.1.1 Release Notes:
+-----------------------
+
+Version 3.0.1.1 has only limited bug fixes compared to version 3.0.1.
+The detailed updates for WRF-ARW can be found at
+http://www.mmm.ucar.edu/wrf/users/wrfv3/updates-3.0.1.1.html.
+
+
+V3.0.1 Release Notes:
+---------------------
+
+This is a bug fix release. The detailed updates for WRF-ARW can be found at
+http://www.mmm.ucar.edu/wrf/users/wrfv3/updates-3.0.1.html.
+
+Online User's Guides have also been updated.
+
+======================================
+
+V3.0 Release Notes:
+------------------
+
+- For directions on compiling WRF, see below or Users Web page.
+- For more information on WRF V3 release, visit WRF Users home page
+  http://www.mmm.ucar.edu/wrf/users/
+- WRF V3 works with WPS, and SI is no longer supported. 
+  Please see User' Guide for WPS.
+- WRF V3 executable does not work with wrfinput/wrfbdy produced by previous versions.
+- WRF V3 has removed one obsolete namelist variable, dyn_opt. Edit with caution.
+
+======================================
+
+WRF 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
+- V2.2.1: Nov 1, 2007
+- V3.0: April 4, 2008
+- V3.0.1: August 5, 2008
+- V3.0.1.1: August 22, 2008
+- V3.1: April 9, 2009
+- V3.1.1: July 31, 2009
+- V3.2: March 31, 2010
+- V3.2.1: August 18, 2010
+- V3.3: April 6, 2011
+
+======================================
+
+How to compile and run?
+-----------------------
+
+- In WRFV3 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/netcdf-pgi
+
+- 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_grav2d_x
+      compile em_heldsuarez
+      compile em_hill2d_x
+      compile em_les
+      compile em_quarter_ss
+      compile em_real
+      compile em_seabreeze2d_x
+      compile em_squall2d_x
+      compile em_squall2d_y
+      compile em_scm_xy
+      compile em_tropical_cyclone
+
+- If sucessful, 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 directory to run ideal/real/wrf.
+
+- If it is one of the idealized cases (b_wave, hill2d_x, grav2d_x, quarter_ss,
+  squall2d_x, squall2d_y, em_les or em_heldsuarez), 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 WPS (met_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 V3?
+
+- 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 and monotonic advection for moisture, scalar, tke and chemical tracers
+  * global modeling capability on latitude-longitude grid
+  * digital filter initialization
+
+- Two-way nesting:
+  * multiple domains and multiple nest levels
+  * supports integer nest grid ratio
+  * feedback option for both odd and even nest grid ratios 
+  * smoothing options
+
+- One-way nesting 
+
+- Moving nest 
+  * Specified move
+  * Automatic move using a mid-level vortex-following algorithm
+
+- Physics options:
+  * microphysics (Kessler/ WRF Single Moment 3, 5 and 6 classes / Lin et al./ Mibrandt 2-moment /
+    Eta Ferrier / Thompson / Goddard / 2-moment Morrison / WRF Double Moment 5 and 6 classes /
+    SBU-Lin 5-classes )
+  * cumulus parameterization (Kain-Fritsch with shallow convection / 
+    Betts-Miller-Janjic / Grell-Devenyi ensemble / New Grell (with shallow convection option) /
+    Tiedtke (with shallow conv and momentum transport) / NSAS (with shallow conv and momentum transport) /
+    SAS (with shallow conv for ARW) / Zhang-McFarlane (with momentum transport) )
+  * UW shallow convection
+  * planetary boundary layer (Yosei University / Mellor-Yamada-Janjic / ACM2 / QNSE / MYNN / BouLac /
+    UW / TEMF )
+  * slab soil model (5-layer thermal diffusion / Noah land-surface model (4 levels) /
+    RUC LSM (6 levels) / Pleim-Xu (2 levels)
+  * Urban canopy model, BEP multi-layer and BEM  (works with Noah LSM, BEP and 
+    BEM also requires MYJ or BouLac)
+  * longwave radiation (RRTM / CAM / RRTMG / new Goddard )
+  * shortwave radiation (simple MM5 scheme / old Goddard / CAM / RRTMG / new Goddard), 
+    terrain slope and shading effect
+  * sub-grid turbulence (constant K diffusion/ 2-D Smagorinsky/ predicted TKE /
+    2-D, 6th order diffusion / Nonlinear Backscatter Anisotropic (NBA) sub-grid turbulence stress for LES )
+  * Rayleigh damping for w at the upper boundary layer
+  * gravity wave drag
+  * land-use categories determine surface properties; support for 24 category USGS and 
+    20 category MODIS (Noah LSM only in V3.1)
+  * Options for modifying SST, sea ice, vegetation fraction, albedo, and deep soil temp
+    for long simulations
+  * fractional sea ice option for polar regions; modified snow/ice physics
+  * single-column ocean mixed layer model
+  * drag and enthalpy flux formulation for hurricane applications
+
+- Nudging:
+  * three-dimensional and surface analysis nudging 
+  * observation nudging 
+  * spectral nudging
+
+- 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
+      Nine auxiliary input and history output streams separately controllable through the namelist
+      Special input streams for analysis and observation nudging
+      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 "bluevista","blueice","bluefire" Power5-based system)
+      IBM Blue Gene
+      SGI Origin and Altix
+      Linux/Intel
+         IA64 MPP (HP Superdome, SGI Altix, NCSA Teragrid systems)
+         IA64 SMP
+         x86_64 (e.g. TACC's "Ranger", NOAA/GSD "wJet" )
+	 PGI, Intel, Pathscale, gfortran, g95 compilers supported
+      Sun Solaris (single threaded and SMP)
+      Cray X1, X1e (vector), XT3/4 (Opteron)
+      Mac Intel/ppc, PGI/ifort/g95
+      NEC SX/8
+      HP-UX
+      Fujitsu VPP 5000
+  * RSL_LITE: communication layer, scalable to very large domains, supports nesting.
+  * I/O: NetCDF, parallel NetCDF (Argonne), HDF5, GRIB, raw binary, Quilting (asynchronous I/O), MCEL (coupling)
+  * 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
+
Index: branches/LMDZ_WRFmeas/WRFV3/README.DA
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/README.DA	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/README.DA	(revision 17)
@@ -0,0 +1,181 @@
+------------------------
+WRFDA PUBLIC DOMAIN NOTICE
+------------------------
+
+WRF Data Assimilation System (WRFDA) 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 WRFDA and consider WRFDA 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 WRFDA user include
+this notice on any partial or full copies of WRFDA. WRFDA 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 
+WRFDA, including infringement actions.
+
+======================================
+This is the main directory for the WRFDA Version 3 source code release.
+======================================
+
+V3.3 Release Notes:
+-----------------------
+
+Version 3.3 is released on April 5, 2011.
+
+- RTTOV interfaces has been upgraded to version 10.0
+  Please download RTTOV v10.0 and install it in appropriate location 
+  if you want to use RTTOV to assimilate radiance observation with bufr format
+
+- crtm_atmosphere is removed from the namelist. 
+  Now the CRTM reference climatology is determined inside WRFDA based on 
+  latitude and month.
+
+- New WRF 4D-Var
+  The WRFPLUS (WRF adjoint and tangent linear model) has been upgraded to V3.3 
+  and it is consistent with the released WRFV version 3.3. However, only dry dynamic 
+  processes are included in WRFPLUS version 3.3 and only serial run is supported
+  at this release.
+  WRFDA is also upgraded to consistent with WRFPLUS version 3.3 and the new 4D-Var 
+  system is a single executable application. Please refer to Users' guide for the
+  details.
+
+- Lots of bug fixes.
+
+V3.2.1 Release Notes:
+-----------------------
+
+Version 3.2.1 is released on August 18, 2010.
+
+- CRTM interface for radiance assimilation has been upgraded to version 2.0.2.
+
+- CRTM V2.0.2 has been included as an internal library in WRFDA codes.
+  Setting environmental variable CRTM to ANYTHING to activate the CRTM installation 
+  during WRFDA compilation.
+
+- Multivariate gen_be method which considers the correlations between moisture and 
+  other variables is included, but the support for the new capability will be very
+  limited.
+
+- Lots of bug fixes.
+
+V3.2 Release Notes:
+-----------------------
+
+Version 3.2 is released on March 31, 2010.
+
+- Improvements on  multiple outer loop which handling nonlinearity issue
+
+- Adjoint sensitivity tool
+
+- Improved software performance
+
+- Improved WRF adjoint codes.
+
+V3.1.1 Release Notes:
+-----------------------
+
+Version 3.1.1 is released on July 31, 2009.
+
+- Radiance data assimilation using K Matrix capability is completed in V3.1.1 release, 
+  which dramatically speedup the analysis. To use K Matrix , please 
+  set USE_CRTM_KMATRIX=true in wrfvar14@namelist.input. 
+  Note: it only applied on CRTM in V3.1.1.
+
+- Improved software portability; only NETCDF library is mandatory 
+  if only LITTLE_R formated conventional observational data to be used. 
+  To use Prepbufr observational files, just set environmental variable 
+  BUFR equal to 1 before the code is compiled. To use radiance BUFR 
+  format data, CRTM or RTTOV is needed.
+
+
+V3.1 Release Notes:
+-----------------------
+
+Version 3.1 is released on April 9, 2009.
+
+- For more information on WRFDA, visit the new WRFDA Users home page
+  http://www.mmm.ucar.edu/wrf/users/wrfda/index.html
+  and read the online User's Gudie.
+
+- 4DVAR and radiance data assimilation capabilities are included in V3.1.
+
+- New README files under WRFDA/var (README.namelist, README.basics, 
+  README.radiance)
+
+- WRFDA V3.1 executable will work with V3.0 wrfinput/wrfbdy (but requires 
+  inserting a new namelist variable use_baseparam_fr_nml in &dynamics).
+  However, rerunning V3.1 WPS/real.exe is recommended.
+
+- Changes to namelist variables.
+    * Some obsolete or unused namelist variables are removed, some new namelist 
+      variables are added, purposes of some namelist variables are changed.
+      See WRFDA/var/README.namelist for descriptions of supported namelist 
+      variables.
+
+- Changes to obsproc:
+    * the executable is renamed to be obsproc.exe from 3dvar_obs.exe and
+      namelist.3dvar_obs is renamed to be namelist.obsproc to reflect
+      its capabilitiy of producing WRFDA-ready observations for 3DVAR, FGAT,
+      or 4DVAR applications.
+      See WRFDA/var/obsproc/README.
+    * compilation of obsproc.exe is included in "compile all_wrfvar"
+
+- Changes to diagnostic output files
+    * gts_omb_oma becomes gts_omb_oma_01 (01 indicates outer loop index)
+    * observations that fail check_max_iv are listed in rej_obs_conv_01.000
+      ( 01 is outer loop index, 000 is processor id)
+    * qcstat_conv_01 (01 indicates outer loop index) contains observation 
+      number counts
+
+- Most of the scripts under WRFDA/var/scripts are removed from the main source
+  code tar file. They can still be downloaded separately.
+  See http://www.mmm.ucar.edu/wrf/users/wrfda/download/tools.html
+
+For questions, send mail to wrfhelp@ucar.edu
+
+======================================
+
+WRFDA update history:
+
+- V3.0:     Apr  4, 2008
+- V3.0.1:   Aug  6, 2008
+- V3.0.1.1: Aug 29, 2008
+- V3.1:     Apr  9, 2009
+- V3.1.1:   Jul 31, 2009
+- V3.2:     Mar 31, 2010
+- V3.2.1:   Aug 18, 2010
+
+======================================
+
+How to compile and run?
+-----------------------
+
+- In WRFDA directory, type 'configure wrfda - this will create a configure.wrf
+  file that has appropriate compile options for the supported computers.
+
+  Note: WRFDA only requires netCDF library starting with V3.1.1.
+        Install netCDF library with the same compiler that will be used to compile WRFDA.
+        NCEP BUFR and CRTM 2.0.2 libs are included in the WRFDA tar file. 
+        Set environment variables properly according to your applications
+        before you type 'configure wrfda'. For example, 
+
+        setenv NETCDF /usr/local/netcdf-pgi
+        setenv BUFR 1 (optional, set to compile WRFDA with NCEP BUFR capability)
+        setenv CRTM 1 (optional, set to compile WRFDA with CRTM capability)
+        setenv RTTOV /usr/local/rttov10 (optional, set to compile WRFDA with RTTOV capability)
+
+- Type 'compile all_wrfvar' when your are ready:
+
+- If sucessful, this will create da_wrfvar.exe and a set of utilities
+  in directory WRFDA/var/build/. 
+
+- cd to the appropriate test or run directory to run WRFDA.
+
+     Some basic instruction/namelist.input are available in sub-directories
+     of WRFDA/var/test.
+
Index: branches/LMDZ_WRFmeas/WRFV3/README.NMM
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/README.NMM	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/README.NMM	(revision 17)
@@ -0,0 +1,292 @@
+
+WRF-NMM Model Version 3.2 (March 31, 2010)
+
+----------------------------
+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.
+
+================================================
+
+V3 Release Notes:
+-----------------
+
+This is the main directory for the WRF Version 3 source code release.
+
+- For directions on compiling WRF for NMM, see below or the 
+  WRF-NMM Users' Web page (http://www.dtcenter.org/wrf-nmm/users/)
+- 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
+
+Release Notes:
+-------------------
+
+Version 3.2 is released on March 31, 2010.
+
+- For more information on WRF V3.2 release, visit WRF-NMM Users home page
+  http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide.
+- WRF V3 executable will work with V3.1 wrfinput/wrfbdy.  As 
+  always, rerunning the new programs is recommended.
+
+The Online User's Guide has also been updated.
+================================================
+
+The ./compile script at the top level allows 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
+           setenv WRF_NMM_NEST 1 (if nesting capability is desired)
+         setenv HWRF 1 (if HWRF coupling/physics are desired)
+
+   - The Registry files for NMM and ARW are not integrated
+     yet. There are separate versions:
+
+         Registry/Registry.NMM         <-- for NMM
+	   Registry/Registry.NMM_NEST    <-- for NMM with nesting
+         Registry/Registry.EM          <-- for ARW (formerly known as Eulerian Mass)
+
+
+How to configure, compile and run?
+----------------------------------
+
+- In WRFV3 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 run directories under test/nmm_real, or run/.
+
+- cd to the appropriate test or run directory to run "nmm_real.exe" and "wrf.exe".
+
+- Place files from WPS (met_nmm.*, geo_nmm_nest*)
+  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 V3.2?
+
+* Dynamics:
+
+  - The WRF-NMM model is a fully compressible, non-hydrostatic model with a
+    hydrostatic option.
+
+  - Supports One-way and two-way static and moving nests.
+
+  - 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)/Eulerian, Adams-Bashforth
+     and Crank-Nicholson with monotonization.
+
+  - Advection (space):
+     T,U,V:
+      - Horizontal: Energy and enstrophy conserving,
+        quadratic conservative,second order
+
+      - Vertical: Quadratic conservative,second order, implicit
+
+      - Tracers (water species and TKE): upstream, positive definite, conservative antifiltering
+        gradient restoration, optional, see next bullet.
+
+      - Tracers (water species, TKE, and test tracer rrw): Eulerian with monotonization, coupled with
+        continuity equation, conservative, positive definite, monotone, optional.  To turn on/off, set
+        the logical switch "euler" in solve_nmm.F to .true./.false.  The monotonization parameter
+        steep in subroutine mono should be in the range 0.96-1.0.  For most natural tracers steep=1.
+        should be adequate.  Smaller values of steep are recommended for idealizaed tests with very
+        steep gradients.  This option is available only with Ferrier microphysics.
+
+  - Horizontal diffusion: Forward, second order "Smagorinsky-type"
+
+  - Vertical Diffusion:
+     See "Free atmosphere turbulence above surface layer" section
+     in "Physics" section given in below.
+
+  - Added a new highly-conservative passive advection scheme to v3.2
+
+Added Operational Hurricane WRF (HWRF) components to v3.2. These enhancements include:
+     - Vortex following moving nest for NMM
+     - Ocean coupling (with POM)
+     - Changes in diffusion coefficients
+     - Modifications/additions to physics schemes (tuned for the tropics)
+         - Updated existing SAS cumulus scheme
+         - Updated existing GFS boundary layer scheme
+         - Added new HWRF microphysics scheme         - Added new HWRF radiation scheme
+     Please see the WRF for Hurricanes webpage for more details:
+         http://www.dtcenter.org/HurrWRF/users
+
+
+* Physics:
+
+  - Explicit Microphysics: WRF Single Moment 5 and 6 class /
+    Ferrier (Used operationally at NCEP.) / Thompson [a new version in 3.1] 
+    / HWRF microphysics: (Used operationally at NCEP for HWRF)
+
+  - Cumulus parameterization: Kain-Fritsch with shallow convection /
+    Betts-Miller-Janjic (Used operationally at NCEP.)/ Grell-Devenyi ensemble
+    / Simplified Arakawa-Schubert (Used operationally at NCEP for HWRF)
+
+  - Free atmosphere turbulence above surface layer: Mellor-Yamada-Janjic (Used operationally at NCEP.)
+
+  - Planetary boundary layer: YSU /  Mellor-Yamada-Janjic (Used operationally at NCEP.) 
+    / NCEP Global Forecast System scheme (Used operationally at NCEP for HWRF)
+    / GFS / Quasi-Normal Scale Elimination
+
+  - Surface layer: Similarity theory scheme with viscous sublayers
+    over both solid surfaces and water points (Janjic - Used operatinally at NCEP).
+    / GFS / YSU / Quasi-Normal Scale Elimination / GFDL surface layer (Used operationally at NCEP for HWRF)
+
+  - Soil model: Noah land-surface model (4-level - Used operationally at NCEP) /
+    RUC LSM (6-level) / GFDL slab model (Used operationally at NCEP for HWRF)
+
+  - Radiation:
+    - Longwave radiation: GFDL Scheme  (Fels-Schwarzkopf) (Used 
+      operationally at NCEP.) / Modified GFDL scheme (Used operationally 
+      at NCEP for HWRF) / RRTM
+    - Shortwave radiation: GFDL-scheme (Lacis-Hansen) (Used operationally 
+      at NCEP.) / Modified GFDL shortwave (Used operationally at NCEP 
+      for HWRF)/ Dudhia
+
+  - Gravity wave drag with mountain wave blocking (Alpert; Kim and Arakawa)
+  
+  - Sea Surface temperature updates during long simulations
+
+* WRF Software:
+
+  - Hierarchical software architecture that insulates scientific code
+    (Model Layer) from computer architecture (Driver Layer)
+  -  Multi-level parallelism supporting distributed-memory (MPI)
+  -  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
+  - Enhanced I/O options:
+      NetCDF and Parallel HDF5 formats
+      Nine auxiliary input and history output streams separately controllable through the
+       namelist
+      Output file names and time-stamps specifiable through namelist
+  -  Efficient execution on a range of computing platforms:
+      IBM SP systems, (e.g. NCAR "bluevista","blueice","bluefire" Power5-based system)
+      IBM Blue Gene
+      SGI Origin and Altix
+      Linux/Intel
+         IA64 MPP (HP Superdome, SGI Altix, NCSA Teragrid systems)
+         IA64 SMP
+         x86_64 (e.g. TACC's "Ranger", NOAA/GSD "wJet" )
+         PGI, Intel, Pathscale, gfortran, g95 compilers supported
+      Sun Solaris (single threaded and SMP)
+      Cray X1, X1e (vector), XT3/4 (Opteron)
+      Mac Intel/ppc, PGI/ifort/g95
+      NEC SX/8
+      HP-UX
+      Fujitsu VPP 5000
+  - RSL_LITE: communication layer, scalable to very large domains, supports nesting.
+  - I/O: NetCDF, parallel NetCDF (Argonne), HDF5, GRIB, raw binary, Quilting (asynchronous I/O)
+, MCEL (coupling)
+  - 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
+ 
+    (Model Layer) from computer architecture (Driver Layer)
+  - Multi-level parallelism supporting shared-memory (OpenMP), distributed-memory (MPI), 
+    and hybrid share/distributed modes of execution
+  - Serial compilation can be used for single-domain runs but not for runs with
+    nesting at this time.
+  - 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 "bluevista","blueice" 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: communication layer, scalable to very
+    large domains 
+  - 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 
+  - Improved documentation, both on-line (web based browsing tools) and in-line
+
+--------------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/README.io_config
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/README.io_config	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/README.io_config	(revision 17)
@@ -0,0 +1,67 @@
+Run time control of IO stream variable sets
+
+For WRF releases prior to V3.2, state variables were associated with I/O
+streams at compile time via their entries in the Registry.  That will
+still work, and should still be considered the primary method for defining
+stream variable sets in WRF. This new capability allows users to add or
+exclude state variables from a history or input stream at run-time without
+recompiling.  Also, this can be done on a per-domain basis as well.
+
+Here's a quick sketch of how it is used:
+
+a) There are two new namelist variables in the time_control section
+of the namelist.input file.  The first is iofields_filename. This is a
+character variable, settable separately for each domain and defaulting
+to "NONE_SPECIFIED".  This is where a user can list the names of text
+files containing lists of variables to added/removed from history and
+input streams for that domain.  As with other namelist variables that
+have max_domains in their rconfig definitions, each domain does have
+to have an entry in the namelist.input file. You can set each entry to
+the name of separate definitions file for each domain, or some or all
+of them can be the name of the same file.
+
+The second namelist variable is a logical, ignore_iofields_warning,
+which tells the program what to do if it encounters an error in these
+user-specified files.  The default value, .TRUE., is to print a warning
+message but continue the run.  If set to .FALSE., the program will
+abort if there are errors in these user-specified files.
+
+b) The user-specified files, named as settings to the iofields_filename
+   in the namelist.input file.  The files contain lines associating
+   variables with streams.  Each line has the form:
+
+  op:streamtype:streamid:variables
+
+    op:          either + (plus) or - (minus) for adding or removing
+                 a variable
+    streamtype:  either i (input) or h (history) indicating which type
+                 of stream is being affected
+    streamid:    an integer between 0 and the number of streams (0 
+                 represents main input or history)
+    variables:   comma separated list of variables
+
+Example.  The line:
+
+    +:i:5:u,v,w
+
+will add the U, V, and W variables to auxinput5.  Note for this example,
+these are 2 time-level variables so that, as with Registry-defined
+stream-associations, the designations apply to variables representing
+the highest numbered time level (U_2). See the file test/em_real/sample.txt
+
+These lines cannot be longer than 256 characters, but you can associate
+long lists of variables using multiple lines with the same op, streamtype,
+and streamid. You can have comments in these files by putting # on the
+line, causing the entire line to be a comment (even characters before
+the #).
+
+An implementation note: the mechanism is not very efficient at this
+point. Each variable listed involves a search through all the state
+variables in the grid.  That is still relatively quick - even a very
+long list shouldn't take more than a couple seconds -- and the lists are
+processed only once when a grid is allocated.  Even so, super-long lists
+of these run-time stream associations are mildly discouraged. In other
+words, use this as a mechanism to tweak the Registry I/O definitions or to
+get domain by domain specific behavior, but don't use it as a substitute
+for defining I/O definitions with state variables in the Registry.
+
Index: branches/LMDZ_WRFmeas/WRFV3/README.rsl_output
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/README.rsl_output	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/README.rsl_output	(revision 17)
@@ -0,0 +1,25 @@
+
+When the WRF model runs, the contents of the rsl.output and rsl.error files have all been placed in individual
+files (whose names are subtended with the task ID) in the run directory.  The user now has another option in
+which the contents of the files may be written together in single files.  See below for directions.
+
+
+******************
+For RSL_LITE:
+******************
+
+Include -DNCEP_DEBUG_MULTIDIR in CFLAGS of configure.wrf to have the rsl.output and rsl.error data written to separate
+files in separate task numbered directories.  All of these directories will be in a single TASKOUTPUT directory under
+the run directory, i.e.,  <rundirectory>/TASKOUTPUT/0000/rsl.error.0000 .
+
+Include -DNCEP_DEBUG_GLOBALSTDOUT in CFLAGS of configure.wrf to have all rsl.error and rsl.out information written to
+the global stderr and stdout for the job (2 files).
+
+If you do not include either flag, the default is to have the rsl output/error data written to separate files in the
+run directory.
+
+To alter your option after everything has been compiled do the following from the top level source directory:
+
+rm external/RSL_LITE/*.o external/RSL_LITE/*.a  (or cd external/RSL_LITE followed by rm *.o *.a)
+./compile nmm_real
+
Index: branches/LMDZ_WRFmeas/WRFV3/README.windturbine
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/README.windturbine	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/README.windturbine	(revision 17)
@@ -0,0 +1,85 @@
+README for wind turbine drag parameterization schemes, added 20101220.  JM
+
+*Compiling the code.* no different from normal
+
+*Running the code.*  There are new variables added to the phys block of
+the namelist.input file.  The string valued variable windturbines_spec
+controls the overall operation of the scheme.  If it's set to "none"
+(quotes included) the wind turbine scheme is off.  If it's set to
+"ideal",  the turbine drag scheme is in idealized mode and other namelist
+variables in the block control the geometry and characteristics of the
+wind farm.  If it's set to the name of a file in the run directory --
+for example, "windspec.in" -- then the scheme is on and the location and
+characteristics of each turbine is set individually from the contents of
+that file.  Which scheme is active will be controlled by another variable
+TBD (not yet implemented, since there's only one scheme right now).
+
+*Idealized configuration.* If windturbines_spec is set to "ideal", the
+geometry and characteristics of the farm are controlled by the following
+additional variables in the phys block of the namelist.input file:
+
+ name        type     sample description
+                      value
+ turbgridid  integer   1     id of the WRF domain containing the farm
+ hubheight   real     100.   height in meters of all turbine hubs in farm
+ diameter    real     100.   diameter in meters of all turbine rotors in farm
+ stdthrcoef  real     0.158  standing thrust coefficient of all turbines in farm
+ cutinspeed  real     3.5    cut in speed (m/s) of all turbines in farm
+ cutoutspeed real     30.    cut out speed (m/s) of all turbines in farm
+ power       real     5.0    nominal power (MW) of all turbines in farm
+ turbpercell real     1.0    number of turbines per grid cell
+ ewfx        integer  10     x-extent of rectangular wind farm in grid cells
+ ewfy        integer  10     y-extent of rectangular wind farm in grid cells
+ pwfx        integer  45     x-coordinate of grid cell in sw corner of farm
+ pwfy        integer  45     y-coordinate of grid cell in sw corner of farm
+
+
+*Real-world configuration.*  The location and characteristics of each
+turbine is specified individually in the file named by the variable
+windturbines_spec.  Each line of the file specifies one turbine.
+The entries of a line are separated by spaces.  The entries are listed
+in order on the line and specify the following, by position on the line:
+
+     1. The WRF grid id into which the turbine is placed [integer]
+     2. True latitude of the wind turbine in degrees   [real]
+     3. True longitude of the wind turbine in degrees  [real]
+     4. Height in meters of the turbine hub [real]
+     5. Diameter in meters of the rotor     [real]
+     6. Standing thrust coefficient         [real]
+     7. Nominal power of turbine (MW)       [real]
+     8. Cutin speed (m/s) [real]
+     9. Cutout speed (m/s) [real]
+
+The location of each turbine is specified using the lat and lon elements
+for the turbine's entry in the windspec file.  That is, the i,j index
+in the grid is computed from the true latitude (entry 2) and the true
+longitude (entry 3).  The coordinate in the j dimension is computed by
+checking true latitude against the LAT_V field in the wrfinput initial
+conditions file.  The i dimension is computed by checking the true
+longitude against LONG_U field in the wrfinput file.
+
+*Pseudo-real configuration.*  This mode is only for testing the real-world
+specification mechanism.  The contents of the windspec.in file in the
+em_seabreeze2d_x directory contains a specification that is identical
+to the ideal specification shown above.  However, instead of true
+latitude and true longitude, elements 2 and 3 of each entry specify
+the i,j grid coordinates of the turbine.  The code knows to treat
+these as grid coordinates instead of latitude and longitude because
+for idealized WRF cases, the LAT and LONG fields in wrfinput files are
+set to all zero.  When the model reads a wrfinput file for an idealized
+case, it checks to see if the lat and lon fields of the case have data
+in them or if they are just zeros.  If they do not have data in them
+(just have zeros) fields 2 and 3 of the windspec file are treated as i,j
+coordinates are used.  A sample windspec file for a pseudo-real run is
+in test/em_seabreeze2d_x/windspec.in).
+
+*Specific note for the Fitch scheme.*  The Fitch scheme is based on
+Blahak et al, 2010, of Wetter Jetzt GbR.  The specific implementation
+comes from Anna Fitch, Alok Gupta, and Idar Barstad at Uni Bergen,
+Norway.  It was added to this release of WRF by Jimy Dudhia, Joe Olson
+(NOAA), Julie Lundquist (U. Colorado/NREL), and John Michalakes (NREL).
+It works with the MYNN PBL and modifies the QKE field representing 2xTKE
+to include the TKE produced by wind turbines. QKE is advected as a part
+of the scalar 4D tracer array in WRF.
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/README_test_cases
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/README_test_cases	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/README_test_cases	(revision 17)
@@ -0,0 +1,120 @@
+WRFV3 (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.
+
+7) 3D large-eddy simulation (test/em_les)
+
+   A large-eddy simulation (LES) of a free convective boundary 
+   layer (CBL) with 0 environmental wind at the initial time, and
+   the turbulence of the free CBL driven/maintained by the 
+   specified surface heat flux.
+
+8) 2D full physics seabreeze (test/em_seabreeze2d_x)
+
+   The case is more set up now to demonstrate how to set all land
+   variables so that full physics options may be used. Tuning is
+   needed to produce real sea-breeze simulation at this point.
+
+9) 3D global case (test/em_heldsuarez)
+
+   A coarse-resolution global forecast case that is described in
+   "A proposal for the intercomparison of the dynamical cores of 
+   atmospheric general circulation models" by Held and Suarez 
+   (Bulletin of the American Meteorological Society; 1994, Vol 
+   75, 1825-1830).  This test of the global solver is dry, and
+   produces  midlatitude jets, breaking midlatitude baroclinic 
+   waves, etc.
+
+10) Single column model (test/em_scm_xy)
+
+11) 3D tropical cyclone (test/em_tropical_cyclone)
+
+   Idealized tropical cyclone on an f-plane with constant SST in a 
+   specified environment.  Uses capped Newtonian relaxation to mimic 
+   longwave radiation.  The default setup uses the Jordan (1958) mean 
+   hurricane sounding with 28 C SST and no background winds.  The 
+   analytic initial vortex is from Rotunno and Emanuel (1987).  This 
+   case is useful for testing the effects of new model code (e.g., 
+   new physics options) on tropical cyclones in an idealized framework. 
+
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.CONVERT
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.CONVERT	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.CONVERT	(revision 17)
@@ -0,0 +1,514 @@
+# 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=<variable name>".  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.
+#
+
+#<Table>  <Dim>  <Order> <How defined>         <Coord-axis>  <Dimname in Datasets>
+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                                         
+#<Table> <Type> <Sym>         <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>   
+#
+
+#
+# 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)                                              
+#                                               
+#<Table>  <Type>  <Sym>                   <How set>          <Nentries>   <Default>                                             
+
+
+# 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<domain>"          -     "name of input   infile"   ""      ""
+rconfig   character  input_outname     namelist,time_control		1  "wrfinput_d<domain>"          -     "name of input   outfile"  ""      ""
+rconfig   character  bdy_inname        namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary infile"  ""      ""
+rconfig   character  bdy_outname       namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary outfile" ""      ""
+rconfig   character  rst_inname        namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "name of restrt infile"    ""      ""
+rconfig   character  rst_outname       namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "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   logical grid_allowed            namelist,domains      max_domains    .true.  irh    "allowed"       ""      ""
+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 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    tke_upper_bound         namelist,dynamics	max_domains    1000.   h    "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 islake                  derived                  max_domains    0       -        "islake"               "land use index of inland lake"      "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"
+
+#
+# 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     -     i012rdu "TOPOSLPX"      "ELEVATION X SLOPE"  ""
+state   real   toposlpy            ij    misc          1     -     i012rdu "TOPOSLPY"      "ELEVATION Y SLOPE"  ""
+state   real   slope               ij    misc          1     -     rdu     "SLOPE"         "ELEVATION SLOPE"  ""
+state   real   slp_azi             ij    misc          1     -     rdu     "SLP_AZI"       "ELEVATION SLOPE AZIMUTH"  "rad"
+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" ""
+
+
+
+
+
+#
+#---------------------------------------------------------------------------------------------------------------------------------------
+# Package Declarations
+#                                               
+
+#key      package       associated                package          associated 4d scalars
+#         name          namelist choice           state vars
+
+#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   thompson       mp_physics==8               -             moist:qv,qc,qr,qi,qs,qg;scalar:qni
+package   sbu_ylinscheme    mp_physics==13           -             moist:qv,qc,qr,qi,qs
+
+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                     -             -
+                                                
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM	(revision 17)
@@ -0,0 +1,1 @@
+link Registry.EM.LMDZ
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM.LMDZ
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM.LMDZ	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM.LMDZ	(revision 17)
@@ -0,0 +1,2345 @@
+#  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=<variable name>".  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.
+#
+
+include registry.dimspec
+
+################################################################################
+################################################################################
+################################################################################
+
+#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
+#<Table> <Type> <Sym>         <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>
+#
+
+# 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         -     i012rh01d=(interp_fcnm)u=(copy_fcnm)   "LU_INDEX"              "LAND USE CATEGORY"         ""
+state    real  LU_MASK          ij      misc        1         -     i3h1     "LU_MASK"              "0 land 1 water"         ""
+
+# znw, znu, dzs, and zs must be listed before any 3-d fields
+# in order for the grib output module to work correctly.  The grib output
+# module retrieves the vertical levels from these parameters.  If znw, znu
+# dzs, and zs are not listed first, vertical level will not be encoded at 
+# time 0.
+
+state    real    znu            k       dyn_em      1         -     irh       "znu"  "eta values on half (mass) levels"  ""
+state    real    znw            k       dyn_em      1         Z     i0rh     "znw"  "eta values on full (w) levels"  ""
+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"
+
+#
+# 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   prho_gc        igj      dyn_em      1        Z     i1  "PTHETA" "for UM data, from metgrid this is ptheta, but swapped to prho in real" "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   sct_dom_gc     ij       dyn_em      1        -     i1  "SCT_DOM"  "Dominant soil (top) category from GEOGRID"  "cat"
+state    real   scb_dom_gc     ij       dyn_em      1        -     i1  "SCB_DOM"  "Dominant soil (bottom) category from GEOGRID"  "cat"
+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   pdrho_gc       igj      dyn_em      1        Z     -   "PDRHO"    "dry pressure for UM data for the variables U and V"   "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   sh_gc          igj      dyn_em      1        Z     i1  "SPECHUMD"  "Specific humidity"        "kg kg-1"
+state    real   icefrac_gc     ij       dyn_em      1        -     i1  "ICEFRAC"  "Sea ice fraction"  "0 - 1 fraction"
+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"
+state    real   qh_gc          igj      dyn_em      1        Z     i1  "QH"    "hail mixing ratio"   "kg kg-1"
+state    real   qni_gc         igj      dyn_em      1        Z     i1  "QNI"   "ice no concentration"   "m-3"
+
+#-----------------------------------------------------------------------------------------------------------------------------------------------------------------
+#                                               
+# Variables for Eulerian mass coordinate dynamics                                            
+#                                               
+
+
+# Velocities
+#
+# U Vel
+state    real   u              ikjb     dyn_em      2         X     \
+     i0rhusdf=(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      h        "ru_tend"        ""   ""                                   
+i1       real   ru_tendf       ikj     dyn_em      1         X                                          
+state    real   u_save         ikj     dyn_em      1         X      -        "u_save"
+state    real   z_force        |       dyn_em      1         -      i3rh     "Z_FORCE" "height of forcing input" "m"
+state    real   z_force_tend   |       dyn_em      1         -      i3rh     "Z_FORCE_TEND" "tendency height of forcing input" "m"
+state    real   u_g            |       dyn_em      1         -      i3rh     "U_G" "x-direction geostrophic wind" "m s-1"
+state    real   u_g_tend       |       dyn_em      1         -      i3rh     "U_G_TEND" "tendency x-direction geostrophic wind" "m s-1"
+#                                               
+# V Vel
+state    real   v              ikjb     dyn_em      2         Y     \
+     i0rhusdf=(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      h        "rv_tend"
+i1       real   rv_tendf       ikj     dyn_em      1         Y                                          
+state    real   v_save         ikj     dyn_em      1         Y      -        "v_save"                   
+state    real   v_g            |       dyn_em      1         -      i3rh     "V_G" "y-direction geostrophic wind" "m s-1"
+state    real   v_g_tend       |       dyn_em      1         -      i3rh     "V_G_TEND" "tendency y-direction geostrophic wind" "m s-1"
+#                                               
+# 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                                          
+
+state    real   w_subs         |       dyn_em      1         -      i3rh      "W_SUBS" "large-scale vertical velocity" "m s-1"
+state    real   w_subs_tend    |       dyn_em      1         -      i3rh      "W_SUBS_TEND" "tendency large-scale vertical velocity" "m s-1"
+
+# 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         -      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         -     \
+       i0rhusdf=(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         -  
+i1       real   t_2save        ikj     dyn_em      1         -   
+state    real   t_save         ikj     dyn_em      1         -      -        "t_save"
+
+state    real   th_upstream_x       |     dyn_em      1      -      i3rh     "TH_UPSTREAM_X" "upstream theta x-advection" "K s-1"
+state    real   th_upstream_x_tend  |     dyn_em      1      -      i3rh     "TH_UPSTREAM_X_TEND" "tendency upstream theta x-advection" "K s-2"
+state    real   th_upstream_y       |     dyn_em      1      -      i3rh     "TH_UPSTREAM_Y" "upstream theta y-advection" "K s-1"
+state    real   th_upstream_y_tend  |     dyn_em      1      -      i3rh     "TH_UPSTREAM_Y_TEND" "tendency upstream theta y-advection" "K s-2"
+
+state    real   qv_upstream_x       |     dyn_em      1      -      i3rh     "QV_UPSTREAM_X" "upstream qv x-advection" "kg kg-1 s-1"
+state    real   qv_upstream_x_tend  |     dyn_em      1      -      i3rh     "QV_UPSTREAM_X_TEND" "tendency upstream qv x-advection" "kg kg-1 s-2"
+state    real   qv_upstream_y       |     dyn_em      1      -      i3rh     "QV_UPSTREAM_Y" "upstream qv y-advection" "kg kg-1 s-1"
+state    real   qv_upstream_y_tend  |     dyn_em      1      -      i3rh     "QV_UPSTREAM_Y_TEND" "tendency upstream qv y-advection" "kg kg-1 s-2"
+
+state    real   ql_upstream_x       |     dyn_em      1      -      i3rh     "QL_UPSTREAM_X" "upstream ql x-advection" "kg kg-1 s-1"
+state    real   ql_upstream_x_tend  |     dyn_em      1      -      i3rh     "QL_UPSTREAM_X_TEND" "tendency upstream ql x-advection" "kg kg-1 s-2"
+state    real   ql_upstream_y       |     dyn_em      1      -      i3rh     "QL_UPSTREAM_Y" "upstream ql y-advection" "kg kg-1 s-1"
+state    real   ql_upstream_y_tend  |     dyn_em      1      -      i3rh     "QL_UPSTREAM_Y_TEND" "tendency upstream ql y-advection" "kg kg-1 s-2"
+
+state    real   u_upstream_x        |     dyn_em      1      -      i3rh     "U_UPSTREAM_X" "upstream u x-advection" "m s-2"
+state    real   u_upstream_x_tend   |     dyn_em      1      -      i3rh     "U_UPSTREAM_X_TEND" "tendency upstream u x-advection" "m s-3"
+state    real   u_upstream_y        |     dyn_em      1      -      i3rh     "U_UPSTREAM_Y" "upstream u y-advection" "m s-2"
+state    real   u_upstream_y_tend   |     dyn_em      1      -      i3rh     "U_UPSTREAM_Y_TEND" "tendency upstream u y-advection" "m s-3"
+
+state    real   v_upstream_x        |     dyn_em      1      -      i3rh     "V_UPSTREAM_X" "upstream v x-advection" "m s-2"
+state    real   v_upstream_x_tend   |     dyn_em      1      -      i3rh     "V_UPSTREAM_X_TEND" "tendency upstream v x-advection" "m s-3"
+state    real   v_upstream_y        |     dyn_em      1      -      i3rh     "V_UPSTREAM_Y" "upstream v y-advection" "m s-2"
+state    real   v_upstream_y_tend   |     dyn_em      1      -      i3rh     "V_UPSTREAM_Y_TEND" "tendency upstream v y-advection" "m s-3"
+
+state    real   th_largescale       |     dyn_em      1      -      i3rh     "TH_LARGESCALE" "SCM largescale theta" "K"
+state    real   th_largescale_tend  |     dyn_em      1      -      i3rh     "TH_LARGESCALE_TEND" "SCM tendency largescale theta" "K s-1"
+
+state    real   qv_largescale       |     dyn_em      1      -      i3rh     "QV_LARGESCALE" "SCM largescale qv" "kg kg-1 s-1"
+state    real   qv_largescale_tend  |     dyn_em      1      -      i3rh     "QV_LARGESCALE_TEND" "SCM tendency largescale qv" "kg kg-1 s-2"
+
+state    real   ql_largescale       |     dyn_em      1      -      i3rh     "QL_LARGESCALE" "SCM largescale ql" "kg kg-1 s-1"
+state    real   ql_largescale_tend  |     dyn_em      1      -      i3rh     "QL_LARGESCALE_TEND" "SCM tendency largescale ql" "kg kg-1 s-2"
+
+state    real   u_largescale        |     dyn_em      1      -      i3rh     "U_LARGESCALE" "SCM largescale u" "m s-2"
+state    real   u_largescale_tend   |     dyn_em      1      -      i3rh     "U_LARGESCALE_TEND" "SCM tendency largescale u" "m s-3"
+
+state    real   v_largescale        |     dyn_em      1      -      i3rh     "V_LARGESCALE" "SCM largescale v" "m s-2"
+state    real   v_largescale_tend   |     dyn_em      1      -      i3rh     "V_LARGESCALE_TEND" "SCM tendency largescale v" "m s-3"
+
+state    real   tau_largescale       |     dyn_em      1      -      i3rh     "TAU_LARGESCALE" "SCM largescale timescale" "s"
+state    real   tau_largescale_tend  |     dyn_em      1      -      i3rh     "TAU_LARGESCALE_TEND" "SCM tendency largescale timescale" ""
+
+state    real   tau_x               |     dyn_em      1      -      i3rh     "TAU_X" "X-direction advective timescale" "s"
+state    real   tau_x_tend          |     dyn_em      1      -      i3rh     "TAU_X_TEND" "tendency X-direction advective timescale" ""
+state    real   tau_y               |     dyn_em      1      -      i3rh     "TAU_Y" "Y-direction advective timescale" "s"
+state    real   tau_y_tend          |     dyn_em      1      -      i3rh     "TAU_Y_TEND" "tendency Y-direction advective timescale" ""
+
+dimspec  fslay  2     namelist=num_force_soil_layers    z     force_soil_layers
+state    real   t_soil_forcing_val  {fslay}     dyn_em      1      -      i3rh     "T_SOIL_FORCING_VAL" "Soil temp value for SCM forcing" "K"
+state    real   t_soil_forcing_tend {fslay}     dyn_em      1      -      i3rh     "T_SOIL_FORCING_TEND" "tendency soil temp for SCM forcing" "K s-1"
+state    real   q_soil_forcing_val  {fslay}     dyn_em      1      -      i3rh     "Q_SOIL_FORCING_VAL" "Soil moisture value for SCM forcing" "1"
+state    real   q_soil_forcing_tend {fslay}     dyn_em      1      -      i3rh     "Q_SOIL_FORCING_TEND" "tendency soil moisture for SCM forcing" "s-1"
+state    real   tau_soil            {fslay}     dyn_em      1      -      i3rh     "TAU_SOIL" "SCM soil forcing timescale" "s"
+state    real   soil_depth_force    {fslay}     dyn_em      1      -      i3rh     "SOIL_DEPTH_FORCE" "SCM depth at center of soil layers in forcing file" "1"
+
+state    real   hfx_force           -     dyn_em      1      -      i3rh     "HFX_FORCE" "SCM ideal surface sensible heat flux" "W m-2"
+state    real   lh_force            -     dyn_em      1      -      i3rh     "LH_FORCE" "SCM ideal surface latent heat flux" "W m-2"
+state    real   tsk_force           -     dyn_em      1      -      i3rh     "TSK_FORCE" "SCM ideal surface skin temperature" "W m-2"
+state    real   hfx_force_tend      -     dyn_em      1      -      i3rh     "HFX_FORCE_TEND" "SCM ideal surface sensible heat flux tendency" "W m-2 s-1"
+state    real   lh_force_tend       -     dyn_em      1      -      i3rh     "LH_FORCE_TEND" "SCM ideal surface latent heat flux tendency" "W m-2 s-1"
+state    real   tsk_force_tend      -     dyn_em      1      -      i3rh     "TSK_FORCE_TEND" "SCM ideal surface skin temperature tendency" "W m-2 s-1"
+# 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   mub_save        ij     dyn_em      1         -      -           "mub_save" "nest temp, holds orig fine grid mub" "Pa"
+state    real   mu0             ij     dyn_em      1         -      i1          "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         -      irh       "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         -      irhdus    "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    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    t_base         k       dyn_em      1         -     ir        "t_base"               "BASE STATE T IN IDEALIZED CASES"         "K"      
+state    real    z              ikj     dyn_em      1         -     -         " " " " " "
+state    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"  ""
+
+# For the adaptive timestep restart
+state    logical stepping_to_time       - misc    -         -      r     "stepping_to_time"         ""
+state    integer last_step_updated      - misc    -         -      r     "last_step_updated"        ""
+state    logical adapt_step_using_child - misc    -         -      r     "adapt_step_using_child"   ""
+state    integer last_dt_sec            - misc    -         -      r     "last_dt_sec"              "Whole seconds for last timestep"  "sec"
+state    integer last_dt_sec_num        - misc    -         -      r     "last_dt_sec_num"          "Fractional secs, numerator"       "sec"
+state    integer last_dt_sec_den        - misc    -         -      r     "last_dt_sec_den"          "Fractional secs, denominator"     "sec"
+state    integer last_dt_yr             - misc    -         -      r     "last_dt_yr"               "Relative year"                    "years"
+state    integer last_dt_mm             - misc    -         -      r     "last_dt_mm"               "Relative month"                   "months"
+
+# hydrostatic pressure vars
+state    real   p_hyd           ikj     dyn_em      1         -      irh       "p_hyd"       "hydrostatic pressure"         "Pa"
+state    real   p_hyd_w         ikj     dyn_em      1         Z       r        "p_hyd_w"     "hydrostatic pressure at full levels"         "Pa"
+
+# 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         -     i01rhd    "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         -     i01rhd    "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         -      r          "URATX"            "Ratio of U over U10 on mass points "         "dimensionless"
+state    real   vratx           ij      misc        1         -      r          "VRATX"            "Ratio of V over V10 on mass points "         "dimensionless"   
+state    real   tratx           ij      misc        1         -      r          "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"         ""         ""    
+# indicates whether to recompute mu                                                             
+state   logical press_adj      -        -          -         -     -         "press_adj"         "T/F flag adjust mu"         ""    
+
+# 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         -     \
+   i0rhusdf=(bdy_interp:dt)  "QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    qc             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    qr             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    qi             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    qs             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    qg             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+state   real    qh             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QHAIL"            "Hail mixing ratio"             "kg kg-1"
+state   real    -              ikjftb   dfi_moist       1         -     -    -
+state   real    dfi_qv         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QVAPOR"       "Water vapor mixing ratio"      "kg kg-1"
+state   real    dfi_qc         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QCLOUD"       "Cloud water mixing ratio"      "kg kg-1"
+state   real    dfi_qr         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QRAIN"        "Rain water mixing ratio"       "kg kg-1"
+state   real    dfi_qi         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QICE"         "Ice mixing ratio"              "kg kg-1"
+state   real    dfi_qs         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QSNOW"        "Snow mixing ratio"             "kg kg-1"
+state   real    dfi_qg         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QGRAUP"       "Graupel mixing ratio"          "kg kg-1"
+state   real    dfi_qh         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QHAIL"        "Hail mixing ratio"             "kg kg-1"
+state    real   rimi             ikj    misc        1         -     irh         "RIMI"           "riming intensity"  "fraction"
+
+
+# LES---------------!JDM
+
+include registry.les
+
+#-------------------
+
+# CAM physics (UW PBL, UW SHCU, ZM CU)
+include registry.cam
+
+# Chem Scalars
+state   real    -              ikjftb   chem        1         -     -    -                                       
+#
+# Tracer Scalars: If you want full resolved and non-resolved dispersion, compile WRF-Chem
+#
+state   real    -          ikjftb  tracer        1         -     -    -                                       
+state   real    tr17_1     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_1"         "tr17_1"          -
+state   real    tr17_2     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_2"         "tr17_2"          -
+state   real    tr17_3     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_3"         "tr17_3"          -
+state   real    tr17_4     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_4"         "tr17_4"          -
+state   real    tr17_5     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_5"         "tr17_5"          -
+state   real    tr17_6     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_6"         "tr17_6"          -
+state   real    tr17_7     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_7"         "tr17_7"          -
+state   real    tr17_8     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_8"         "tr17_8"
+
+# Other Scalars
+state   real    -              ikjftb  scalar      1         -     -   -
+state   real    qndrop         ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNDROP"        "Droplet number mixing ratio"        "# kg-1"
+state   real    qni            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNICE"         "Ice Number concentration" "# kg-1"
+state   real    qt             ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "CWM"           "Total condensate mixing ratio"      "kg kg-1"
+state   real    qns            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNSNOW"         "Snow Number concentration"   "# kg(-1)"
+state   real    qnr            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNRAIN"        "Rain Number concentration"   "# kg(-1)"
+state   real    qng            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNGRAUPEL"     "Graupel Number concentration" "# kg(-1)"
+state   real    qnh            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNHAIL"        "Hail Number concentration" "# kg(-1)"
+
+#state   real    qzr            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZRAIN"        "Rain reflectivity" "# m(6) kg(-1)"
+#state   real    qzi            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZICE"        "Ice reflectivity" "# m(6) kg(-1)"
+#state   real    qzs            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZSNOW"        "Snow reflectivity" "# m(6) kg(-1)"
+#state   real    qzg            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZGRPL"        "Graupel reflectivity" "# m(6) kg(-1)"
+#state   real    qzh            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZHAIL"        "Hail reflectivity" "# m(6) kg(-1)"
+
+state   real    qnn            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNCCN"         "CCN Number concentration" "# kg(-1)"
+state   real    qnc            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNCLOUD"       "cloud water Number concentration" "# kg(-1)"
+state   real    -              ikjftb  dfi_scalar      1         -     -   -
+state   real    dfi_qndrop     ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNDROP"    "Droplet number mixing ratio"        "# kg-1"
+state   real    dfi_qni        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNICE"     "Ice Number concentration" "# kg-1"
+state   real    dfi_qt         ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_CWM"       "Total condensate mixing ratio"      "kg kg-1"
+state   real    dfi_qns        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNSNOW"    "Snow Number concentration"   "# kg(-1)"
+state   real    dfi_qnr        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNRAIN"    "Rain Number concentration"   "# kg(-1)"
+state   real    dfi_qng        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)"
+state   real    dfi_qnh        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNHAIL" "Hail Number concentration" "# kg(-1)"
+
+#state   real    dfi_qzr        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZRAIN" "Rain reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzi        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZICE" "Ice reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzs        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZSNOW" "Snow reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzg        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZGRPL" "Graupel reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzh        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZHAIL" "Hail reflectivity" "m(6) kg(-1)"
+
+state   real    dfi_qnn        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCC"      "CNN Number concentration"   "# kg(-1)"
+state   real    dfi_qnc        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCLOUD"   "Cloud Number concentration" "# 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   soil_layers    i{lin}j    misc          1     Z     i01r    "SOIL_LAYERS"   "SOIL LAYERS"         "cm"
+state   real   soil_levels    i{lin}j    misc          1     Z     i1      "SOIL_LEVELS"   "SOIL LEVELS"         "cm"
+state   real   st             i{lin}j    misc          1     Z     i01r    "ST"            "SOIL TEMPERATURES"   "K"
+state   real   sm             i{lin}j    misc          1     Z     i01r    "SM"            "SOIL MOISTURES"      "m3 m-3"
+state   real   sw             i{lin}j    misc          1     Z     i01r    "SW"            "SOIL LIQUIDS"        "m3 m-3"
+state   real   soilt          i{lin}j    misc          1     Z     i1      "SOILT"         "RUC SOIL TEMPERATURES"  "K"
+state   real   soilm          i{lin}j    misc          1     Z     i1      "SOILM"         "RUC SOIL MOISTURES"  "m3 m-3"
+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     -     i12rh   "TOPOSTDV"      "ELEVATION STD DEV"  "m"
+state   real   toposlpx            ij    misc          1     -     i012rdu "TOPOSLPX"      "ELEVATION X SLOPE"  ""
+state   real   toposlpy            ij    misc          1     -     i012rdu "TOPOSLPY"      "ELEVATION Y SLOPE"  ""
+state   real   slope               ij    misc          1     -     rdu     "SLOPE"         "ELEVATION SLOPE"  ""
+state   real   slp_azi             ij    misc          1     -     rdu     "SLP_AZI"       "ELEVATION SLOPE AZIMUTH"  "rad"
+state   real   shdmax              ij    misc          1     -     i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)   "SHDMAX"        "ANNUAL MAX VEG FRACTION" ""
+state   real   shdmin              ij    misc          1     -     i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)   "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     i012r   "LANDUSEF"      "LANDUSE FRACTION BY CATEGORY"  ""
+state   real   soilctop            isj   misc          1     Z     i012r   "SOILCTOP"      "SOIL CAT FRACTION (TOP)"  ""
+state   real   soilcbot            isj   misc          1     Z     i012r   "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"
+
+# Time series variables
+state    real   ts_hour         ?!       misc      -         -      -        "TS_HOUR"        "Model integration time, hours"
+state    real   ts_u            ?!       misc      -         -      -        "TS_U"           "Surface wind U-component, earth-relative"
+state    real   ts_v            ?!       misc      -         -      -        "TS_V"           "Surface wind V-component, earth-relative"
+state    real   ts_q            ?!       misc      -         -      -        "TS_Q"           "Surface mixing ratio"
+state    real   ts_t            ?!       misc      -         -      -        "TS_T"           "Surface temperature"
+state    real   ts_psfc         ?!       misc      -         -      -        "TS_PSFC"        "Surface pressure"
+state    real   ts_glw          ?!       misc      -         -      -        "TS_GLW"         "Downward long wave flux at surface"
+state    real   ts_gsw          ?!       misc      -         -      -        "TS_GSW"         "Net short wave flux at surface"
+state    real   ts_hfx          ?!       misc      -         -      -        "TS_HFX"         "Upward heat flux at surface"
+state    real   ts_lh           ?!       misc      -         -      -        "TS_LH"          "Upward moisture flux at surface"
+state    real   ts_tsk          ?!       misc      -         -      -        "TS_TSK"         "Skin temperature"
+state    real   ts_tslb         ?!       misc      -         -      -        "TS_TSLB"        "Soil temperature"
+state    real   ts_clw          ?!       misc      -         -      -        "TS_CLW"         "Column integrated cloud water"
+state    real   ts_rainc        ?!       misc      -         -      -        "TS_RAINC"       "Cumulus precip"
+state    real   ts_rainnc       ?!       misc      -         -      -        "TS_RAINNC"      "Grid-scale precip"
+
+# 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   SMCREL           ilj     -          1         Z     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SMCREL"           "RELATIVE SOIL MOISTURE" ""
+state    real   XICE             ij     misc        1         -     i0124rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm)  "SEAICE"             "SEA ICE FLAG"  ""
+state    real   XICEM            ij     misc        1         -     rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm)  "XICEM"             "SEA ICE FLAG (PREVIOUS STEP)"  ""
+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         -     i024rhd=(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   ACGRDFLX         ij     misc        1         -      rhdu                                       "ACGRDFLX"         "ACCUMULATED GROUND HEAT FLUX" "J 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         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SNOW"             "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real   SNOWH            ij     misc        1         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SNOWH"            "PHYSICAL SNOW DEPTH"      "m"
+#state    real   RHOSN            ij     misc        1         -     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "RHOSN"            " SNOW DENSITY"      "kg m-3" 
+state    real   CANWAT           ij     misc        1         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "CANWAT"           "CANOPY WATER"             "kg m-2"
+state    real   SST              ij     misc        1         -     i0124rhd=(interp_mask_water_field:lu_index,iswater)   "SST"              "SEA SURFACE TEMPERATURE" "K"
+state  integer  IFNDSNOWH        -      misc        1         -     i         "FNDSNOWH" "SNOWH_LOGICAL"
+state  integer  IFNDSOILW        -      misc        1         -     i         "FNDSOILW" "SOILW_LOGICAL"
+# SKIN SST
+state    real   SSTSK            ij     misc        1         -     rhd=(interp_mask_water_field:lu_index,iswater)   "SSTSK"              "SKIN SEA SURFACE TEMPERATURE" "K"
+state    real   DTW              ij     misc        1         -     r   "DTW"              "WARM LAYER TEMP DIFF" "C"
+
+# DFI variables
+state   real   hcoeff         {ndfi} misc        1         -     -    "HCOEFF"               "initialization weights"
+state   real   hcoeff_tot       -    misc        1         -     -    "HCOEFF_TOT"               "initialization weights"
+state   real   dfi_p           ikj   misc        1         -     r    "P_DFI"           "perturbation pressure"         "Pa"
+state   real   dfi_al          ikj   misc        1         -     r    "AL_DFI"          "inverse perturbation density"  "m3 kg-1"
+state   real   dfi_mu          ij    misc        1         -     r    "MU_DFI"  "perturbation dry air mass in column" "Pa"
+state   real   dfi_phb         ikj   misc        1         Z     r    "PHB_DFI"  "base-state geopotential"  "m2 s-2"
+state   real   dfi_ph0         ikj   misc        1         Z     r    "PH0_DFI"  "initial geopotential"     "m2 s-2"
+state   real   dfi_php         ikj   misc        1         Z     r    "PHP_DFI"  "geopotential"             "m2 s-2"
+state   real   dfi_u           ikj   misc        1         -     r    "U_DFI"               "u accumulation array"          "   "
+state   real   dfi_v           ikj   misc        1         -     r    "V_DFI"               "v accumulation array"          "   "
+state   real   dfi_w           ikj   misc        1         -     r    "W_DFI"               "w accumulation array"          "   "
+state   real   dfi_ww          ikj   misc        1         Z     r    "WW_DFI"              "mu-coupled eta-dot"    "Pa s-1"
+state   real   dfi_t           ikj   misc        1         -     r    "TT_DFI"               "t accumulation array"          "   "
+state   real   dfi_rh          ikj   misc        1         -     r    "RH_DFI"               "initial relative humidity"     "   "
+state   real   dfi_ph          ikj   misc        1         -     r    "PH_DFI"               "p accumulation array"          "   "
+state   real   dfi_pb          ikj   misc        1         -     r    "PB_DFI"               "pb accumulation array"          "   "
+state   real   dfi_alt         ikj   misc        1         -     r    "ALT_DFI"             "1/rho accumulation array"          "   "
+state   real   dfi_tke         ikj   misc        1         -     r    "TKE_DFI"          "TURBULENCE KINETIC ENERGY"     "m2 s-2"
+state   real   dfi_tten_rad    ikj   misc        1         -     irh  "RAD_TTEN_DFI"     "RADAR POT. TEMP. TENDENCY"     "K s-1"
+state    real  dfi_TSLB        ilj   misc        1         Z     r    "TSLB_dfi"         "SOIL TEMPERATURE"   "K"
+state    real  dfi_SMOIS       ilj    -          1         Z     r    "SMOIS_dfi"        "SOIL MOISTURE"     "m3 m-3"
+state    real  dfi_SNOW        ij    misc        1         -     r    "SNOW_dfi"         "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real  dfi_SNOWH       ij    misc        1         -     r    "SNOWH_dfi"        "PHYSICAL SNOW DEPTH"      "m"
+state    real  dfi_CANWAT      ij    misc        1         -     r    "CANWAT_dfi"       "CANOPY WATER"             "kg m-2"
+state    real  dfi_SMFR3D      ilj   misc        1         Z     r    "SMFR3D_dfi"           "SOIL ICE" ""
+state    real  dfi_KEEPFR3DFLAG ilj  misc        1         Z     r    "KEEPFR3DFLAG_dfi"     "FLAG - 1. FROZEN SOIL YES, 0 - NO"             ""
+
+# 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"
+state    real   TRB_URB4D       i{ulay}j    misc       1         Z     r      "TRB_URB4D" "ROOF LAYER TEMPERATURE"          "K"
+state    real   TW1_URB4D       i{ulay}j    misc       1         Z     r      "TW1_URB4D" "WALL LAYER TEMPERATURE"          "K"
+state    real   TW2_URB4D       i{ulay}j    misc       1         Z     r      "TW2_URB4D" "WALL LAYER TEMPERATURE"          "K"
+state    real   TGB_URB4D       i{ulay}j    misc       1         Z     r      "TGB_URB4D" "ROAD LAYER TEMPERATURE"          "K"
+state    real   TLEV_URB3D      i{ulay}j    misc       1         Z     r      "TLEV_URB3D" "INDOOR TEMPERATURE"             "K"
+state    real   QLEV_URB3D      i{ulay}j    misc       1         Z     r      "QLEV_URB3D" "SPECIFIC HUMIDITY"              "dimensionless"
+state    real   TW1LEV_URB3D    i{ulay}j    misc       1         Z     r      "TW1LEV_URB3D" "WINDOW TEMPERATURE"           "K"
+state    real   TW2LEV_URB3D    i{ulay}j    misc       1         Z     r      "TW2LEV_URB3D" "WINDOW TEMPERATURE"           "K"
+state    real   TGLEV_URB3D     i{ulay}j    misc       1         Z     r      "TGLEV_URB3D" "GROUND TEMPERATURE BELOW A BUILDING"     "K"
+state    real   TFLEV_URB3D     i{ulay}j    misc       1         Z     r      "TFLEV_URB3D" "FLOOR TEMPERATURE"                       "K"
+state    real   SF_AC_URB3D     ij          misc       1         -     r      "SF_AC_URB3D"  "SENSIBLE HEAT FLUX FROM THE AIR COND." "W m{-2}"
+state    real   LF_AC_URB3D     ij          misc       1         -     r      "LF_AC_URB3D"  "LATENT HEAT FLUX FROM THE AIR COND." "W m{-2}"
+state    real   CM_AC_URB3D     ij          misc       1         -     r      "CM_AC_URB3D"  "CONSUMPTION OF THE AIR COND." "W m{-2}"
+state    real   SFVENT_URB3D    ij          misc       1         -     r      "SFVENT_URB3D" "SENSIBLE HEAT FLUX FROM URBAN VENTILATION" "W m{-2}"
+state    real   LFVENT_URB3D    ij          misc       1         -     r      "LFVENT_URB3D" "LATENT HEAT FLUX FROM URBAN VENTILATION" "W m{-2}"
+state    real   SFWIN1_URB3D    i{ulay}j    misc       1         Z     r      "SFWIN1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW"  "W m{-2}"
+state    real   SFWIN2_URB3D    i{ulay}j    misc       1         Z     r      "SFWIN2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW"  "W m{-2}"
+state    real   SFW1_URB3D      i{ulay}j    misc       1         Z     r      "SFW1_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFW2_URB3D      i{ulay}j    misc       1         Z     r      "SFW2_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFR_URB3D       i{ulay}j    misc       1         Z     r      "SFR_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFG_URB3D       i{ulay}j    misc       1         Z     r      "SFG_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   CMR_SFCDIF      ij          misc       1         -     r      "CMR_SFCDIF" "" ""
+state    real   CHR_SFCDIF      ij          misc       1         -     r      "CHR_SFCDIF" "" ""
+state    real   CMC_SFCDIF      ij          misc       1         -     r      "CMC_SFCDIF" "" ""
+state    real   CHC_SFCDIF      ij          misc       1         -     r      "CHC_SFCDIF" "" ""
+
+
+# solar location variables from radiation driver
+state    real   COSZEN           ij     misc        1         -      r       "COSZEN"  "COS of SOLAR ZENITH ANGLE"     "dimensionless"
+state    real   HRANG            ij     misc        1         -      r       "HRANG"   "SOLAR HOUR ANGLE"          "radians"
+state    real   DECLIN            -     misc        1         -      r       "DECLIN"  "SOLAR DECLINATION"         "radians"
+state    real   SOLCON            -     misc        1         -      r       "SOLCON"  "SOLAR CONSTANT"         "W m-2"
+
+
+# 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"             ""
+
+# Additional for P-X PBL and LSM
+state    real   RA               ij     misc        1         -      r        "RA"           "AERODYNAMIC RESISTANCE"   "s m-1"
+state    real   RS               ij     misc        1         -      r        "RS"           "SURFACE RESISTANCE"       "s m-1"
+state    real   LAI              ij     misc        1         -      i0124rh       "LAI"          "Leaf area index"          "area/area"
+state    real   VEGF_PX          ij     misc        1         -      r        "VEGF_PX"      "Vegetation Fraction for PX LSM"    "area/area"
+state    real   T2OBS            ij     misc        1         -      r        "T2OBS"        "2-m temperature from analysis "          "K"
+state    real   Q2OBS            ij     misc        1         -      r        "Q2OBS"        "2-m mixing ratio from analysis "         "kg/kg"
+
+# 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   EXCH_H          ikj     misc        1         -     r          "EXCH_H"               "SCALAR EXCHANGE COEFFICIENTS "
+state    real   EXCH_M          ikj     misc        1         -     r          "EXCH_M"               "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"                             ""
+state   real   TSHLTR           ij     misc        1         -      r        "TSHLTR"                "SHELTER THETA FROM MYJ"                       "K"
+state   real   QSHLTR           ij     misc        1         -      r        "QSHLTR"                "SHELTER SPECIFIC HUMIDITY FROM MYJ"           "kg kg-1"
+state   real   PSHLTR           ij     misc        1         -      r        "PSHLTR"                "SHELTER PRESSURE FROM MYJ"           "Pa"
+state   real   TH10             ij     misc        1         -      r        "TH10"                  "10-M THETA FROM MYJ"                          "K"
+state   real   Q10              ij     misc        1         -      r        "Q10"                   "10-M SPECIFIC HUMIDITY FROM MYJ"              "kg kg-1"
+i1      real   CHKLOWQ          ij     misc        1         -     -         "CHKLOWQ"               "SURFACE SATURATION FLAG"        ""
+
+# TEMF PBL variables
+state    real   te_temf        ikj     misc        1         -      rh        "te_temf"               "Total energy from TEMF PBL scheme"      "m2 s-2"
+state    real   kh_temf        ikj     misc        1         -     rh          "kh_temf"               "Diffusion coefficient for heat from TEMF PBL"
+state    real   km_temf        ikj     misc        1         -     rh          "km_temf"               "Diffusion coefficient for momentum from TEMF PBL"
+state    real   shf_temf       ikj     misc        1         -     rh          "shf_temf"              "Sensible heat flux from TEMF PBL"      "K m s-1"
+state    real   qf_temf        ikj     misc        1         -     rh          "qf_temf"              "Sensible heat flux from TEMF PBL"       "kg/kg m s-1"
+state    real   uw_temf        ikj     misc        1         -     rh          "uw_temf"              "U momentum flux from TEMF PBL"       "m2 s-2"
+state    real   vw_temf        ikj     misc        1         -     rh          "vw_temf"              "V momentum flux from TEMF PBL"       "m2 s-2"
+state    real   wupd_temf      ikj     misc        1         -     rh          "wupd_temf"            "Updraft velocity from TEMF PBL"      "m s-1"
+state    real   mf_temf        ikj     misc        1         -     rh          "mf_temf"              "Mass flux from TEMF PBL"             "m s-1"
+state    real   thup_temf      ikj     misc        1         -     rh          "thup_temf"            "Updraft thetal from TEMF PBL"        "K"
+state    real   qtup_temf      ikj     misc        1         -     rh          "qtup_temf"            "Updraft qt from TEMF PBL"        "1"
+state    real   qlup_temf      ikj     misc        1         -     rh          "qlup_temf"            "Updraft ql (liquid water) from TEMF PBL"        "1"
+state    real   cf3d_temf      ikj     misc        1         -     rh          "cf3d_temf"            "3D Cloud fraction from TEMF PBL"        "1"
+state    real   hd_temf        ij      misc        1         -     rh          "hd_temf"              "Dry thermal top height from TEMF PBL"       "m"
+state    real   lcl_temf       ij      misc        1         -     rh          "lcl_temf"             "Lifting condensation level from TEMF PBL"       "m"
+state    real   hct_temf       ij      misc        1         -     rh          "hct_temf"             "Cloud top height from TEMF PBL"       "m"
+state    real   cfm_temf       ij      misc        1         -     rh          "cfm_temf"            "Column cloud fraction from TEMF PBL"        "1"
+state    real   wm_temf        ij      misc        1         -     rh        "wm_temf"               "Velocity scale in TEMF surface layer scheme"      "m s-1"
+
+# MYNN PBL variables
+state   real   qke             ikjftb  scalar      1         -      i0rhusdf=(bdy_interp:dt) "qke"               "twice TKE FROM MYNN"      "m2 s-2"
+state   real   tsq             ikj     misc        1         -      r        "tsq"               "liquid water pottemp variance"      "K2"
+state   real   qsq             ikj     misc        1         -      r        "qsq"               "liquid water variance"      "(kg/kg)**2"
+state   real   cov             ikj     misc        1         -      r        "cov"               "liquid water-liquid water pottemp covaria\
+nce"      "K kg/kg"
+state   real   ch               ij     misc        1         -      -        "ch"                "drag coeff for heat"    ""
+#state   real   K_m             ikj     misc        1         -     -          "K_m"               "EXCHANGE COEFFICIENT for momentum "
+#state   real   K_h             ikj     misc        1         -     -          "K_h"               "EXCHANGE COEFFICIENT for heat "
+#state   real   K_q             ikj     misc        1         -     -          "K_q"               "EXCHANGE COEFFICIENT for qke "
+
+# Additional for gravity wave drag
+state   real   DTAUX3D         ikj     misc        1         -     rh        "DTAUX3D"               "LOCAL U GWDO STRESS"   "m s-1"
+state   real   DTAUY3D         ikj     misc        1         -     rh        "DTAUY3D"               "LOCAL V GWDO STRESS"   "m s-1"
+state   real   DUSFCG           ij     misc        1         -     rh        "DUSFCG"                "COLUMN-INTEGRATED U GWDO STRESS"   "Pa m s-1"
+state   real   DVSFCG           ij     misc        1         -     rh        "DVSFCG"                "COLUMN-INTEGRATED V GWDO STRESS"   "Pa m s-1"
+state   real   VAR2D            ij     misc        1         -     i012rhdus "VAR"                   "OROGRAPHIC VARIANCE"   ""   ""
+state   real   OC12D            ij     misc        1         -     i012rhdus "CON"                   "OROGRAPHIC CONVEXITY"   ""   ""
+state   real   OA1              ij     misc        1         -     i012rhdus "OA1"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA2              ij     misc        1         -     i012rhdus "OA2"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA3              ij     misc        1         -     i012rhdus "OA3"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA4              ij     misc        1         -     i012rhdus "OA4"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL1              ij     misc        1         -     i012rhdus "OL1"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL2              ij     misc        1         -     i012rhdus "OL2"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL3              ij     misc        1         -     i012rhdus "OL3"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL4              ij     misc        1         -     i012rhdus "OL4"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+
+# BEP urban scheme  variables
+state    real    a_u_bep       ikj     misc        1         Z      -        "a_u_bep"               "IMPLICIT FOR X-COMP."      "s-1"
+state    real    a_v_bep       ikj     misc        1         Z      -        "a_v_bep"               "IMPLICIT FOR Y-COMP."      "s-1"
+state    real    a_t_bep       ikj     misc        1         Z      -        "a_t_bep"               "IMPLICIT FOR Pot. Temp"    "s-1"
+state    real    a_q_bep       ikj     misc        1         Z      -        "a_q_bep"               "IMPLICIT FOR Moisture"     "s-1"
+state    real    a_e_bep       ikj     misc        1         Z      -        "a_e_bep"               "IMPLICIT FOR TKE"          "s-1"
+state    real    b_u_bep       ikj     misc        1         Z      -        "b_u_bep"               "EXPLICIT FOR X-COMP."      "m s-2"
+state    real    b_v_bep       ikj     misc        1         Z      -        "b_v_bep"               "EXPLICIT FOR Y-COMP."      "m s-2"
+state    real    b_t_bep       ikj     misc        1         Z      -        "b_t_bep"               "EXPLICIT FOR Pot. Temp"    "K s-1"
+state    real    b_q_bep       ikj     misc        1         Z      -        "b_q_bep"               "EXPLICIT FOR Moisture"     "kg s-1"
+state    real    b_e_bep       ikj     misc        1         Z      -        "b_e_bep"               "EXPLICIT FOR TKE"          "m2 s-3"
+state    real    dlg_bep       ikj     misc        1         Z      -        "dlg_bep"               "length scale 1"            "m"
+state    real    dl_u_bep      ikj     misc        1         Z      -        "dl_u_bep"              "urban length scale"        "m"
+state    real    sf_bep        ikj     misc        1         Z      -        "sf_bep"                "surface grid"              "-"
+state    real    vl_bep        ikj     misc        1         Z      -        "vl_bep"                "volume grid"               "-"
+# BOULAC PBL variables
+state    real   tke_pbl        ikj     misc        1         -      rh        "tke_pbl"               "TKE FROM Bougeault and Lacarrere"      "m2 s-2"
+state    real   el_pbl        ikj     misc        1         -       h        "el_pbl"               "Length scale FROM Bougeault and Lacarrere"      "m"
+# Diagnostic PBL variables
+state    real   wu_tur         ikj     misc        1         -      r        "wu_tur"               "Turbulent flux of momentum(x)"      "m2 s-2"
+state    real   wv_tur         ikj     misc        1         -      r        "wv_tur"               "Turbulent flux of momentum(y)"      "m2 s-2"
+state    real   wt_tur         ikj     misc        1         -      r        "wt_tur"               "Turbulent flux of temperature"      "K m s-1"
+state    real   wq_tur         ikj     misc        1         -      r        "wq_tur"               "Turbulent flux of water vapor"      "- m s-1"
+
+# 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         -      -
+state    real   rlwtoa           ij     misc        1         -      -
+state    real   czmean           ij     misc        1         -      -
+state    real   cfracl           ij     misc        1         -      -
+state    real   cfracm           ij     misc        1         -      -
+state    real   cfrach           ij     misc        1         -      -
+state    real   acfrst           ij     misc        1         -      -
+state integer   ncfrst           ij     misc        1         -      -
+state    real   acfrcv           ij     misc        1         -      -
+state integer   ncfrcv           ij     misc        1         -      -
+
+# cam radiation variables
+state  real    -       i{ls}jf ozmixm      1    -   -     -
+state  real   mth01    i{ls}jf ozmixm      1    -   -     -
+state  real   mth02    i{ls}jf ozmixm      1    -   -     -
+state  real   mth03    i{ls}jf ozmixm      1    -   -     -
+state  real   mth04    i{ls}jf ozmixm      1    -   -     -
+state  real   mth05    i{ls}jf ozmixm      1    -   -     -
+state  real   mth06    i{ls}jf ozmixm      1    -   -     -
+state  real   mth07    i{ls}jf ozmixm      1    -   -     -
+state  real   mth08    i{ls}jf ozmixm      1    -   -     -
+state  real   mth09    i{ls}jf ozmixm      1    -   -     -
+state  real   mth10    i{ls}jf ozmixm      1    -   -     -
+state  real   mth11    i{ls}jf ozmixm      1    -   -     -
+state  real   mth12    i{ls}jf ozmixm      1    -   -     -
+state  real   pin       {ls}     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 microphysics State Variables
+state   real    F_ICE_PHY      ikj     misc         1         -      rhdu     "F_ICE_PHY"            "FRACTION OF ICE"         ""
+state   real    F_RAIN_PHY     ikj     misc         1         -      rhdu     "F_RAIN_PHY"           "FRACTION OF RAIN "         ""
+state   real    F_RIMEF_PHY    ikj     misc         1         -      rhdu     "F_RIMEF_PHY"          "MASS RATIO OF RIMED ICE "         ""
+state   real    qndropsource   ikj     misc         1         -      -        "qndropsource"         "Droplet number source"   "#/kg/s"
+
+# Other Misc State Variables                                            
+state   real    h_diabatic     ikj     misc         1         -      rhdu     "h_diabatic"            "MICROPHYSICS LATENT HEATING"         "K s-1"      
+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    msftx          ij      misc         1         -     i012rhdu=(copy_fcnm)    "MAPFAC_MX"         "Map scale factor on mass grid, x direction" ""
+state   real    msfty          ij      misc         1         -     i012rhdu=(copy_fcnm)    "MAPFAC_MY"         "Map scale factor on mass grid, y direction" ""
+state   real    msfux          ij      misc         1         X     i012rhdu=(copy_fcnm)    "MAPFAC_UX"         "Map scale factor on u-grid, x direction" ""
+state   real    msfuy          ij      misc         1         X     i012rhdu=(copy_fcnm)    "MAPFAC_UY"         "Map scale factor on u-grid, y direction" ""
+state   real    msfvx          ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MAPFAC_VX"         "Map scale factor on v-grid, x direction" ""
+state   real    msfvx_inv      ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MF_VX_INV"         "Inverse map scale factor on v-grid, x direction" ""
+state   real    msfvy          ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MAPFAC_VY"         "Map scale factor on v-grid, y direction" ""
+
+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    ht_shad        ijb     misc         1         -     df=(bdy_interp:dt)         "HGT_SHAD"        "Height of orographic shadow"   "m"
+i1      real    ht_loc         ij      misc         1         -     - 
+state   integer  shadowmask    ij      misc         1         -     - 
+state   integer min_ptchsz     -       misc         1         -     r
+
+state   real    TSK            ij      misc         1         -     i012rhdu=(copy_fcnm)    "TSK"                   "SURFACE SKIN TEMPERATURE"                  "K"
+state   real    dfi_TSK        ij      misc         1         -     r                       "TSK_dfi"               "saved SURFACE SKIN TEMPERATURE"
+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    t00            -       misc         -         -     i02rh     "t00"                   "BASE STATE TEMPERATURE   "  "K"
+state   real    p00            -       misc         -         -     i02rh     "p00"                   "BASE STATE PRESURE"         "Pa"
+state   real    tlp            -       misc         -         -     i02rh     "tlp"                   "BASE STATE LAPSE RATE    "  ""
+state   real    tiso           -       misc         -         -     i02rh     "tiso"                  "TEMP AT WHICH THE BASE T TURNS CONST"  "K"
+state   real    max_msftx      -       misc         -         -      rh       "max_mstfx"             "Max map factor in domain"  ""
+state   real    max_msfty      -       misc         -         -      rh       "max_mstfy"             "Max map factor in domain"  ""
+
+# State variables for Goddard LW and SW radiation  
+state    real  TLWDN           ij      misc        1         -      h         "TLWDN"                 "TOA LW downwelling flux"           "W m-2"
+state    real  TLWUP           ij      misc        1         -      h         "TLWUP"                 "TOA LW upwelling flux"             "W m-2"
+state    real  SLWDN           ij      misc        1         -      h         "SLWDN"                 "Surface LW downwelling flux"       "W m-2"
+state    real  SLWUP           ij      misc        1         -      h         "SLWUP"                 "Surface LW upwelling flux"         "W m-2"
+state    real  TSWDN           ij      misc        1         -      h         "TSWDN"                 "TOA SW downwelling flux"           "W m-2"
+state    real  TSWUP           ij      misc        1         -      h         "TSWUP"                 "TOA SW upwelling flux"             "W m-2"
+state    real  SSWDN           ij      misc        1         -      h         "SSWDN"                 "Surface SW downwelling flux"       "W m-2"
+state    real  SSWUP           ij      misc        1         -      h         "SSWUP"                 "Surface SW upwelling flux"         "W m-2"
+
+# Other physics variables
+
+state    real  RUSHTEN         ikj      misc        1         -      r        "RUSHTEN"               "COUPLED X WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME"   "Pa m s-2"
+state    real  RVSHTEN         ikj      misc        1         -      r        "RVSHTEN"               "COUPLED Y WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME"   "Pa m s-2"
+state    real  RTHSHTEN        ikj      misc        1         -      r        "RTHSHTEN"              "COUPLED THETA TENDENCY DUE TO SHALLOW CUMULUS SCHEME"    "Pa K s-1"
+state    real  RQVSHTEN        ikj      misc        1         -      r        "RQVSHTEN"              "COUPLED Q_V TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQRSHTEN        ikj      misc        1         -      r        "RQRSHTEN"              "COUPLED Q_R TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQCSHTEN        ikj      misc        1         -      r        "RQCSHTEN"              "COUPLED Q_C TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQSSHTEN        ikj      misc        1         -      r        "RQSSHTEN"              "COUPLED Q_S TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQISHTEN        ikj      misc        1         -      r        "RQISHTEN"              "COUPLED Q_I TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQGSHTEN        ikj      misc        1         -      r        "RQGSHTEN"              "COUPLED Q_G TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+
+state    real  RUCUTEN         ikj      misc        1         -      r        "RUCUTEN"               "COUPLED X WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION"  "Pa m s-2"
+state    real  RVCUTEN         ikj      misc        1         -      r        "RVCUTEN"               "COUPLED Y WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION"  "Pa m s-2"
+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  RAINSH           ij      misc        1         -      rhdu     "RAINSH"                "ACCUMULATED SHALLOW CUMULUS PRECIPITATION"               "mm"
+state    real  RAINNC           ij      misc        1         -      rhdu     "RAINNC"                "ACCUMULATED TOTAL GRID SCALE PRECIPITATION"              "mm"
+state  integer I_RAINC          ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_RAINC"            "BUCKET FOR RAINC"                    ""
+state  integer I_RAINNC         ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_RAINNC"           "BUCKET FOR RAINNC"                   ""
+state    real  PRATEC           ij      misc        1         -      r        "PRATEC"                "PRECIP RATE FROM CUMULUS SCHEME"                         "mm s-1"
+state    real  PRATESH          ij      misc        1         -      r        "PRATESH"               "PRECIP RATE FROM SHALLOW CUMULUS SCHEME"                 "mm s-1"
+state    real  RAINCV           ij      misc        1         -      r        "RAINCV"                "TIME-STEP CUMULUS PRECIPITATION"                         "mm"
+state    real  RAINSHV          ij      misc        1         -      r        "RAINSHV"               "TIME-STEP SHALLOW 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  HAILNC           ij      misc        1         -      rhdu     "HAILNC"                "ACCUMULATED TOTAL GRID SCALE HAIL"                       "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  HAILNCV          ij      misc        1         -      r        "HAILNCV"               "TIME-STEP NONCONVECTIVE HAIL"                            "mm"
+state    real    refl_10cm      ikj     dyn_em      1         -     hdu     "refl_10cm" "Radar reflectivity (lamda = 10 cm)"  "dBZ"
+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  edt_out          ij      misc        1         -      -        "EDT_OUT"             "EDT FROM GD SCHEME"             ""
+state    real  xmb_shallow      ij      misc        1         -      rh       "XMB_SHALLOW"             "MASSFLUX FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  k22_shallow   ij      misc        1         -      rh       "K22_SHALLOW"             "K22 LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  kbcon_shallow   ij      misc        1         -    rh       "KBCON_SHALLOW"             "KBCON LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  ktop_shallow   ij      misc        1         -     rh       "KTOP_SHALLOW"             "KTOP LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  k22_deep     ij      misc        1         -      h       "K22_DEEP"             "K22 LEVEL FROM DEEPCONVECTION (G3 only)"             ""
+state    integer  kbcon_deep     ij      misc        1         -    h       "KBCON_DEEP"             "KBCON LEVEL FROM DEEP CONVECTION (G3 only)"             ""
+state    integer  ktop_deep     ij      misc        1         -     h       "KTOP_DEEP"             "KTOP LEVEL FROM DEEP CONVECTION (G3 only)"             ""
+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  cugd_tten        ikj     misc        1         -      r        "CUGD_TTEN"             "INITIAL TTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qvten       ikj     misc        1         -      r        "CUGD_QVTEN"            "INITIAL QTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_ttens       ikj     misc        1         -      r        "CUGD_TTENS"            "INITIAL SUBSIDENCE TTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qvtens      ikj     misc        1         -      r        "CUGD_QVTENS"           "INITIAL SUBSIDNCE QTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qcten       ikj     misc        1         -      r        "CUGD_QCTEN"            "INITIAL TEMPERATURE TENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-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"
+state    real  GD_CLDFR         ikj      misc        1         -      rh     "GD_CLDFR"              "GD CLOUD Fraction"         " ? "
+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 integer  STEPAVE_COUNT     -        misc        1         -      rh      "STEPAVE_COUNT"        "time steps contained in averages for convective transport" ""
+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"              "UNCOUPLED THETA TENDENCY DUE TO LONG WAVE RADIATION"    "K s-1"
+state    real  RTHRATENSW      ikj      misc        1         -      r        "RTHRATSW"              "UNCOUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION"   "K s-1"
+state    real  CLDFRA          ikj      misc        1         -      rh       "CLDFRA"                "CLOUD FRACTION"                                       ""
+state    real  CLDFRA_OLD      ikj      misc        1         -      r        "CLDFRA_OLD"            "previous time level cldfra"                           ""
+
+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"      
+state    real  SWNORM           ij      misc        1         -      rhd      "SWNORM"                "NORMAL SHORT WAVE FLUX AT GROUND SURFACE (SLOPE-DEPENDENT)"           "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 integer  I_ACSWUPT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPT"     "BUCKET FOR UPWELLING SHORTWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACSWUPTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPTC"    "BUCKET FOR UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACSWDNT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNT"     "BUCKET FOR DOWNWELLING SHORTWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACSWDNTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNTC"    "BUCKET FOR DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACSWUPB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPB"     "BUCKET FOR UPWELLING SHORTWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACSWUPBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPBC"    "BUCKET FOR UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACSWDNB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNB"     "BUCKET FOR DOWNWELLING SHORTWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACSWDNBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNBC"    "BUCKET FOR DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACLWUPT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPT"     "BUCKET FOR UPWELLING LONGWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACLWUPTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPTC"    "BUCKET FOR UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACLWDNT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNT"     "BUCKET FOR DOWNWELLING LONGWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACLWDNTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNTC"    "BUCKET FOR DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACLWUPB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPB"     "BUCKET FOR UPWELLING LONGWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACLWUPBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPBC"    "BUCKET FOR UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACLWDNB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNB"     "BUCKET FOR DOWNWELLING LONGWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACLWDNBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNBC"    "BUCKET FOR DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2"
+state    real  SWUPT            ij      misc        1         -      rhdu     "SWUPT"                 "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP"          "W m-2"
+state    real  SWUPTC           ij      misc        1         -      rhdu     "SWUPTC"                "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2"
+state    real  SWDNT            ij      misc        1         -      rhdu     "SWDNT"                 "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP"          "W m-2"
+state    real  SWDNTC           ij      misc        1         -      rhdu     "SWDNTC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2"
+state    real  SWUPB            ij      misc        1         -      rhdu     "SWUPB"                 "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  SWUPBC           ij      misc        1         -      rhdu     "SWUPBC"                "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2"
+state    real  SWDNB            ij      misc        1         -      rhdu     "SWDNB"                 "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  SWDNBC           ij      misc        1         -      rhdu     "SWDNBC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2"
+state    real  LWUPT            ij      misc        1         -      rhdu     "LWUPT"                 "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP"          "W m-2"
+state    real  LWUPTC           ij      misc        1         -      rhdu     "LWUPTC"                "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2"
+state    real  LWDNT            ij      misc        1         -      rhdu     "LWDNT"                 "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP"          "W m-2"
+state    real  LWDNTC           ij      misc        1         -      rhdu     "LWDNTC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2"
+state    real  LWUPB            ij      misc        1         -      rhdu     "LWUPB"                 "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  LWUPBC           ij      misc        1         -      rhdu     "LWUPBC"                "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W m-2"
+state    real  LWDNB            ij      misc        1         -      rhdu     "LWDNB"                 "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  LWDNBC           ij      misc        1         -      rhdu     "LWDNBC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W 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  CLAT             ij      misc        1         -     i012rdu=(copy_fcnm)          "CLAT"                "COMPUTATIONAL GRID LATITUDE, SOUTH IS NEGATIVE"                       "degree_north"
+state    real  CLONG            ij      misc        1         -     i012rdu=(copy_fcnm)          "CLONG"               "COMPUTATIONAL GRID LONGITUDE, WEST IS NEGATIVE"                       "degree_east"
+state    real  ALBBCK           ij      misc        1         -     i0124rh   "ALBBCK"                "BACKGROUND ALBEDO"        ""
+state    real  EMBCK            ij      misc        1         -      r        "EMBCK"                 "BACKGROUND EMISSIVITY"         ""
+state    real  EMISS            ij      misc        1         -      rh       "EMISS"                 "SURFACE EMISSIVITY"         "" 
+state    real  SNOTIME          ij      misc        1         -      r        "SNOTIME"               "SNOTIME"         "" 
+state    real  NOAHRES          ij      misc        1         -      h        "NOAHRES"               "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}"
+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         -                                          
+state    real  t_phy           ikj      misc        1         -      r      "T_PHY"                        "Temperature"         "K"           
+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  TYR              ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TYR"        "ANNUAL MEAN SFC TEMPERATURE"           "K"
+state    real  TYRA             ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TYRA"   "ACCUMULATED YEARLY SFC TEMPERATURE FOR CURRENT YEAR"  "K"
+state    real  TDLY             ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TDLY"     "ACCUMULATED DAILY SFC TEMPERATURE FOR CURRENT DAY"  "K"
+state    real  TLAG             i&j     misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TLAG"         "DAILY MEAN SFC TEMPERATURE OF PRIOR DAYS"       "K"
+state    integer NYEAR          -       misc        1         -     r        "NYEAR"                  "ACCUM DAYS IN A YEAR"                         ""
+state    real    NDAY           -       misc        1         -     r        "NDAY"                  "ACCUM TIMESTEPS IN A DAY"                      ""
+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         -      i3rh     "ZNT"                   "TIME-VARYING ROUGHNESS LENGTH"                "m"      
+state    real  CK               ij      misc        1         -      r        "CK"                    "ENTHALPY EXCHANGE COEFF AT 10 m"                      ""
+state    real  CKA              ij      misc        1         -      r        "CKA"                   "ENTHALPY EXCHANGE COEFF AT LOWEST MODEL LVL"          ""
+state    real  CD               ij      misc        1         -      r        "CD"                    "DRAG COEFF AT 10m"                      ""
+state    real  CDA              ij      misc        1         -      r        "CDA"                   "DRAG COEFF AT LOWEST MODEL LVL"                      ""
+state    real  UST              ij      misc        1         -      rh       "UST"                   "U* IN SIMILARITY THEORY"                      "m s-1"      
+state    real  USTM             ij      misc        1         -      r        "USTM"                  "U* IN SIMILARITY THEORY WITHOUT VCONV"        "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  ACHFX            ij      misc        1         -      rhdu     "ACHFX"                 "ACCUMULATED UPWARD HEAT FLUX AT THE SURFACE"  "J m-2"
+state    real  ACLHF            ij      misc        1         -      rhdu     "ACLHF"                 "ACCUMULATED UPWARD LATENT HEAT FLUX AT THE SURFACE"  "J 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  dfi_QVG          ij      misc        1         -      r        "QVG_dfi"               "WATER VAPOR MIXING RATIO AT THE SURFACE"      "kg kg-1"
+state    real  QCG              ij      misc        1         -      r        "QCG"                   "CLOUD WATER MIXING RATIO AT THE GROUND SURFACE"      "kg kg-1"
+state    real  DEW              ij      misc        1         -      r        "DEW"                   "DEW MIXING RATIO AT THE SURFACE"              "kg kg-1"
+state    real  SOILT1           ij      misc        1         -      i012rh   "SOILT1"                "TEMPERATURE INSIDE SNOW "    "K"
+state    real  dfi_SOILT1       ij      misc        1         -      r        "SOILT1_dfi"            "TEMPERATURE INSIDE SNOW "    "K"
+state    real  TSNAV            ij      misc        1         -      r        "TSNAV"                 "AVERAGE SNOW TEMPERATURE "                    "C"
+state    real  dfi_TSNAV        ij      misc        1         -      r        "TSNAV_dfi"             "AVERAGE SNOW TEMPERATURE "                    "C"
+state    real  REGIME           ij      misc        1         -      r        "REGIME"  "FLAGS: 1=Night/Stable, 2=Mechanical Turbulent, 3=Forced Conv, 4=Free Conv" ""
+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  dfi_SNOWC        ij      misc        1         -      r        "SNOWC_dfi"             "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    real   sr             ij      dyn_em      1         -      irh         "sr" "fraction of frozen precipitation"
+state    real   potevp         ij      dyn_em      1         -       rh         "potevp" "accumulated potential evaporation" "W m-2"
+state    real   snopcx         ij      dyn_em      1         -       rh         "snopcx" "snow phase change heat flux" "W m-2"
+state    real   soiltb         ij      dyn_em      1         -        h         "soiltb" "bottom soil temperature" "K"
+                                                
+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   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"
+state  integer save_topo_from_real -    dyn_em	    1         -    irh        "save_topo_from_real"    "1=original topo from real/0=topo modified by WRF"      "flag"
+
+## 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  RPHNDGDTEN        ikj      misc     1         -      r        "RPHNDGDTEN"              "COUPLED GEOPOTENTIAL TENDENCY DUE TO FDDA GRID NUDGING"   "Pa m2 s-3"
+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      i{10}r   "U_NDG_NEW"               "NEW X WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  V_NDG_NEW         ikjf     fdda3d   1         Y      i{10}r   "V_NDG_NEW"               "NEW Y WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  T_NDG_NEW         ikjf     fdda3d   1         -      i{10}r   "T_NDG_NEW"               "NEW PERT POT TEMP FOR FDDA GRID NUDGING"  "K"
+state    real  Q_NDG_NEW         ikjf     fdda3d   1         -      i{10}r   "Q_NDG_NEW"               "NEW WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  PH_NDG_NEW        ikjf     fdda3d   1         Z      i{10}r   "PH_NDG_NEW"              "NEW PERT GEOPOTENTIAL FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  U_NDG_OLD         ikjf     fdda3d   1         X      i{10}r   "U_NDG_OLD"               "OLD X WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  V_NDG_OLD         ikjf     fdda3d   1         Y      i{10}r   "V_NDG_OLD"               "OLD Y WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  T_NDG_OLD         ikjf     fdda3d   1         -      i{10}r   "T_NDG_OLD"               "OLD PERT POT TEMP FOR FDDA GRID NUDGING"  "K"
+state    real  Q_NDG_OLD         ikjf     fdda3d   1         -      i{10}r   "Q_NDG_OLD"               "OLD WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  PH_NDG_OLD        ikjf     fdda3d   1         Z      i{10}r   "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         -      i{10}r      "MU_NDG_NEW"              "NEW PERT COLUMN DRY MASS FOR FDDA GRID NUDGING"  "Pa"
+state    real  MU_NDG_OLD        ivjf     fdda2d   1         -      i{10}r      "MU_NDG_OLD"              "OLD PERT COLUMN DRY MASS FOR FDDA GRID NUDGING"  "Pa"
+state    real  U10_NDG_OLD       ij         misc      1         X      i9r      "U10_NDG_OLD"             "OLD U10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  U10_NDG_NEW       ij         misc      1         X      i9r      "U10_NDG_NEW"             "NEW U10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  V10_NDG_OLD       ij         misc      1         Y      i9r      "V10_NDG_OLD"             "OLD V10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  V10_NDG_NEW       ij         misc      1         Y      i9r      "V10_NDG_NEW"             "NEW V10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  T2_NDG_OLD        ij         misc      1         -      i9r      "T2_NDG_OLD"              "OLD T2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  T2_NDG_NEW        ij         misc      1         -      i9r      "T2_NDG_NEW"              "NEW T2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  TH2_NDG_OLD       ij         misc      1         -      i9r      "TH2_NDG_OLD"             "OLD TH2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  TH2_NDG_NEW       ij         misc      1         -      i9r      "TH2_NDG_NEW"             "NEW TH2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  Q2_NDG_OLD        ij         misc      1         -      i9r      "Q2_NDG_OLD"              "OLD Q2 FOR SURFACE FDDA GRID NUDGING"  "kg kg-1"
+state    real  Q2_NDG_NEW        ij         misc      1         -      i9r      "Q2_NDG_NEW"              "NEW Q2 FOR SURFACE FDDA GRID NUDGING"  "kg kg-1"
+state    real  RH_NDG_OLD        ij         misc      1         -      i9r      "RH_NDG_OLD"              "OLD RH FOR SURFACE FDDA GRID NUDGING"  "%"
+state    real  RH_NDG_NEW        ij         misc      1         -      i9r      "RH_NDG_NEW"              "NEW RH FOR SURFACE FDDA GRID NUDGING"  "%"
+state    real  PSL_NDG_OLD       ij         misc      1         -      i9r      "PSL_NDG_OLD"             "OLD PSL FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PSL_NDG_NEW       ij         misc      1         -      i9r      "PSL_NDG_NEW"             "NEW PSL FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PS_NDG_OLD        ij         misc      1         -      i9r      "PS_NDG_OLD"              "OLD PS FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PS_NDG_NEW        ij         misc      1         -      i9r      "PS_NDG_NEW"              "NEW PS FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  TOB_NDG_OLD       ij         misc      1         -      i9r      "TOB_NDG_OLD"             "OLD TOB FOR SURFACE FDDA GRID NUDGING"  ""
+state    real  ODIS_NDG_OLD      ij         misc      1         -      i9r      "ODIS_NDG_OLD"            "OLD ODIS FOR SURFACE FDDA GRID NUDGING"  "km"
+state    real  TOB_NDG_NEW       ij         misc      1         -      i9r      "TOB_NDG_NEW"             "NEW TOB FOR SURFACE FDDA GRID NUDGING"  ""
+state    real  ODIS_NDG_NEW      ij         misc      1         -      i9r      "ODIS_NDG_NEW"            "NEW ODIS FOR SURFACE FDDA GRID NUDGING"  "km"
+state    real  SN_NDG_NEW        ij         misc      1         -      i9r      "SN_NDG_NEW"              "NEW Snow Water Equivalent"  "mm"
+state    real  SN_NDG_OLD        ij         misc      1         -      i9r      "SN_NDG_OLD"              "OLD Snow Water Equivalent"  "mm"
+
+
+# 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"
+
+state   real    max_cfl         -       misc        1         -     -       "max_cfl"           "maximum CFL value in grid at a time" "-"
+
+state   real  prec_acc_c       ij       misc        1         -     rh       "prec_acc_c"       "ACCUMULATED CUMULUS PRECIPITATION OVER prec_acc_dt PERIODS OF TIME"       "mm"
+state   real  prec_acc_nc      ij       misc        1         -     rh       "prec_acc_nc"      "ACCUMULATED GRID SCALE  PRECIPITATION OVER prec_acc_dt PERIODS OF TIME"   "mm"
+state   real  snow_acc_nc      ij       misc        1         -     rh       "snow_acc_nc"      "ACCUMULATED SNOW WATER EQUIVALENT OVER prec_acc_dt PERIODS OF TIME"       "mm"
+
+# Placeholder for decoupled advective tendency diagnostics for non-chem
+state   real  -               ikjf      advh_t      1         -     -         -
+state   real  advh_qv         ikjf      advh_t      1         -     -         "advh_qv"    "ACCUMULATED HORIZONTAL TENDENCY FOR WATER VAPOR"        "kg kg-1"
+
+state   real  -               ikjf      advz_t      1         -     -         -
+state   real  advz_qv         ikjf      advz_t      1         -     -         "advz_qv"    "ACCUMULATED VERTICAL TENDENCY FOR WATER VAPOR"          "kg kg-1"
+
+# Ocean Mixed-Layer State Variables
+state   real    TML            ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "TML"    "OCEAN MIXED-LAYER TEMPERATURE"   "K"
+state   real    T0ML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "T0ML"   "INITIAL OCEAN MIXED-LAYER TEMPERATURE"   "K"
+state   real    HML            ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HML"    "OCEAN MIXED-LAYER DEPTH"   "m"
+state   real    H0ML           ij      misc         1         -     i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "H0ML"   "INITIAL OCEAN MIXED-LAYER DEPTH"   "m"
+state   real    HUML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HUML"   "OCEAN MIXED-LAYER DEPTH * U-CURRENT"  " m2s-1 "
+state   real    HVML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HVML"   "OCEAN MIXED-LAYER DEPTH * V-CURRENT"  " m2s-1 " 
+state   real    TMOML          ij      misc         1         -     i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm) "TMOML"  "OCEAN LAYER MEAN TEMPERATURE   "   "K"
+
+# LMDZ output. L. Fita, LMD. December 2013
+
+include Registry_out.LMDZ
+
+state    real   qv_2            ikj     misc        1         -      -                                      "QV_2"             "WATER VAPOR"                                   "kg kg-1"
+# LMDZ physics variables
+state    real   LCONTROL         {lind} misc        1         -      rh                                          "LCONTROL"             "LMDZ CONTROL indices"                             "-"
+state    real   LMSK             ij     misc        1         -      rh                                          "LMSK"             "LMDZ LAND-SEA MASK"                            "1"
+state    real   LTER             ij     misc        1         -      rh                                          "LTER"             "LMDZ fraction of continent (KSIOL=1)"               "1"
+state    real   LLIC             ij     misc        1         -      rh                                          "LLIC"             "LMDZ fraction of continental ice (KSOIL=2)"        "1"
+state    real   LOCE             ij     misc        1         -      rh                                          "LOCE"             "LMDZ fraction of ocean (KSOIL=3)"                        "1"
+state    real   LSIC             ij     misc        1         -      rh                                          "LSIC"             "LMDZ fraction of oceanic ice (KSOIL=4)"                  "1"
+state    real   LTKSOIL     i{lksoil}j  misc        1         -      rh                                          "LTKSOIL"          "LMDZ temperature at each kind of soil"         "K"
+##state    real   LTTER            ij     misc        1         -      rh                                          "LTTER"            "LMDZ temperature at the TER surface"           "K"
+##state    real   LTLIC            ij     misc        1         -      rh                                         "LTLIC"            "LMDZ temperature at the LIC surface"           "K"
+##state    real   LTOCE            ij     misc        1         -      rh                                         "LTOCE"            "LMDZ temperature at the OCE surface"           "K"
+##state    real   LTSIC            ij     misc        1         -      rh                                          "LTSIC"            "LMDZ temperature at the SIC surface"           "K"
+state    real   LOTTER     i{olay}j     misc        1         -      rh                                          "LOTTER"        "LMDZ-ORCHIDEE temperature at the TER surface"     "K"
+state    real   LOTLIC     i{olay}j     misc        1         -      rh                                          "LOTLIC"        "LMDZ-ORCHIDEE temperature at the LIC surface"     "K"
+state    real   LOTOCE     i{olay}j     misc        1         -      rh                                          "LOTOCE"        "LMDZ-ORCHIDEE temperature at the OCE surface"     "K"
+state    real   LOTSIC     i{olay}j     misc        1         -      rh                                          "LOTSIC"        "LMDZ-ORCHIDEE temperature at the SIC surface"     "K"
+state    real   LQKSOIL    i{lksoil}j   misc        1         -      rh                                          "LQKSOIL"       "LMDZ humidity at each kind of soil"              "kgkg-1"
+##state    real   LQTER            ij     misc        1         -    rh                                          "LQTER"         "LMDZ humidity at the TER surface"              "kgkg-1"
+##state    real   LQLIC            ij     misc        1         -      rh                                          "LQLIC"         "LMDZ humidity at the LIC surface"              "kgkg-1"
+##state    real   LQOCE            ij     misc        1         -      rh                                          "LQOCE"         "LMDZ humidity at the OCE surface"              "kgkg-1"
+##state    real   LQSIC            ij     misc        1         -      rh                                          "LQSIC"         "LMDZ humidity at the SIC surface"              "kgkg-1"
+state    real   LWSOL            ij     misc        1         -      rh                                          "LWSOL"         "LMDZ TOTAL soil water content"                 "mm"
+state    real   LALBKSOIL   i{lksoil}j    misc        1         -      rh                                          "LALBKSOIL"       "LMDZ albedo at each kind of soil"                "1"
+##state    real   LALBTER          ij     misc        1         -      rh                                          "LALBTER"       "LMDZ albedo at the TER surface"                "1"
+##state    real   LALBLIC          ij     misc        1         -      rh                                          "LALBLIC"       "LMDZ albedo at the LIC surface"                "1"
+##state    real   LALBOCE          ij     misc        1         -      rh                                          "LALBOCE"       "LMDZ albedo at the OCE surface"                "1"
+##state    real   LALBSIC          ij     misc        1         -      rh                                          "LALBSIC"       "LMDZ albedo at the SIC surface"                "1"
+state    real   LLWALBKSOIL  i{lksoil}j   misc        1         -      rh                                          "LLWALBKSOIL"   "LMDZ LW albedo at each kind of soil"             "1"
+##state    real   LLWALBTER        ij     misc        1         -      rh                                          "LLWALBTER"     "LMDZ LW albedo at the TER surface"             "1"
+##state    real   LLWALBLIC        ij     misc        1         -      rh                                          "LLWALBLIC"     "LMDZ LW albedo at the LIC surface"             "1"
+##state    real   LLWALBOCE        ij     misc        1         -      rh                                          "LLWALBOCE"     "LMDZ LW albedo at the OCE surface"             "1"
+##state    real   LLWALBSIC        ij     misc        1         -      rh                                          "LLWALBSIC"     "LMDZ LW albedo at the SIC surface"             "1"
+state    real   LEVAPKSOIL  i{lksoil}j  misc        1         -      rh                                          "LEVAPKSOIL"    "LMDZ evaporation  at each kind of soil"          "mm"
+##state    real   LEVAPTER         ij     misc        1         -      rh                                          "LEVAPTER"      "LMDZ evaporation at the TER surface"          "mm"
+##state    real   LEVAPLIC         ij     misc        1         -      rh                                          "LEVAPLIC"      "LMDZ evaporation at the LIC surface"          "mm"
+##state    real   LEVAPOCE         ij     misc        1         -      rh                                          "LEVAPOCE"      "LMDZ evaporation at the OCE surface"          "mm"
+##state    real   LEVAPSIC         ij     misc        1         -      rh                                          "LEVAPSIC"      "LMDZ evaporation at the SIC surface"          "mm"
+state      real   LSNOWKSOIL i{lksoil}j   misc        1         -      rh                                          "LSNOWKSOIL"    "LMDZ snow at each kind of soil"                 "mm"
+##state    real   LSNOWTER         ij     misc        1         -      rh                                          "LSNOWTER"      "LMDZ snow at the TER surface"                 "mm"
+##state    real   LSNOWLIC         ij     misc        1         -      rh                                          "LSNOWLIC"      "LMDZ snow at the LIC surface"                 "mm"
+##state    real   LSNOWOCE         ij     misc        1         -      rh                                          "LSNOWOCE"      "LMDZ snow at the OCE surface"                 "mm"
+##state    real   LSNOWSIC         ij     misc        1         -      rh                                          "LSNOWSIC"      "LMDZ snow at the SIC surface"                 "mm"
+state    real   LRADS            ij     misc        1         -      rh                                          "LRADS"         "LMDZ net radiation at the surface"                 "Wm-2"
+state    real   LSOLSW           ij     misc        1         -      rh                                          "LSOLSW"        "LMDZ short-wave radiation at the surface"                 "Wm-2"
+state    real   LSOLLW           ij     misc        1         -      rh                                          "LSOLLW"        "LMDZ long-wave radiation at the surface"                 "Wm-2"
+##state    real   LFDER            ij     misc        1         -      rh                                          ##"LFDER"         "LMDZ flux derivative (coupling variable)"     "???????"
+state    real   LRAIN            ij     misc        1         -      rh                                          "LRAIN"         "LMDZ liquid precipitation"                   "mm"
+# Already in LMDZ output. L. Fita, LMD. December 2013
+##state    real   LSNOW            ij     misc        1         -      rh                                          "LSNOW"         "LMDZ solid precipitation"                    "mm"
+state    real   LRUGKSOIL i{lksoil}j    misc        1         -      rh                                          "LRUGKSOIL"     "LMDZ rugosity at each kind of soil"             "m"
+##state    real   LRUGTER          ij     misc        1         -      rh                                          "LRUGTER"       "LMDZ rugosity at the TER surface"             "m"
+##state    real   LRUGLIC          ij     misc        1         -      rh                                          "LRUGLIC"       "LMDZ rugosity at the LIC surface"             "m"
+##state    real   LRUGOCE          ij     misc        1         -      rh                                          "LRUGOCE"       "LMDZ rugosity at the OCE surface"             "m"
+##state    real   LRUGSIC          ij     misc        1         -      rh                                          "LRUGSIC"       "LMDZ rugosity at the SIC surface"             "m"
+state    real   LAGESNOKSOIL i{lksoil}j   misc        1         -      rh                                          "LAGESNOKSOIL"  "LMDZ age of the snow at each kind of soil"      "minutes"
+##state    real   LAGESNTER        ij     misc        1         -      rh                                          "LAGESNTER"     "LMDZ age of the snow at the TER surface"      "minutes"
+##state    real   LAGESNLIC        ij     misc        1         -      rh                                          "LAGESNLIC"     "LMDZ age of the snow at the LIC surface"      "minutes"
+##state    real   LAGESNOCE        ij     misc        1         -      rh                                          "LAGESNOCE"     "LMDZ age of the snow at the OCE surface"      "minutes"
+##state    real   LAGESNSIC        ij     misc        1         -      rh                                          "LAGESNSIC"     "LMDZ age of the snow at the SIC surface"      "minutes"
+state    real   LZMEA            ij     misc        1         -      rh                                          "LZMEA"         "LMDZ mean orography"                          "m"
+state    real   LZSTD            ij     misc        1         -      rh                                          "LZSTD"         "LMDZ standard deviation of orography"         "m"
+state    real   LZSIG            ij     misc        1         -      rh                                          "LZSIG"         "LMDZ orographic slope"                        "-"
+state    real   LZGAM            ij     misc        1         -      rh                                          "LZGAM"         "LMDZ orographic anisotropy"                   "-"
+state    real   LZTHE            ij     misc        1         -      rh                                          "LZTHE"         "LMDZ orographic angle"                        "-"
+state    real   LZPIC            ij     misc        1         -      rh                                          "LZPIC"         "LMDZ orographic elevation of peaks"           "m"
+state    real   LZVAL            ij     misc        1         -      rh                                          "LZVAL"         "LMDZ orographic elevation of valleys"         "m"
+state    real   LZRUGSREL        ij     misc        1         -      rh                                          "LZRUGSREL"     "LMDZ orographic rugosity"                     "m"
+state    real   LRUGSEA          ij     misc        1         -      rh                                          "LRUGSEA"       "LMDZ oceanic rugosity"                        "m"
+# Al ready in LMDZ output. L. Fita, LMD. December 2013
+##state    real   LCLWCON          ikj    misc        1         -      rh                                          "LCLWCON"       "LMDZ convective liquid water"                 "mm"
+##state    real   LRNEBCON         ikj    misc        1         -      rh                                          "LRNEBCON"      "LMDZ convective clouds"                       "mm"
+##state    real   LRATQS           ikj    misc        1         -      rh                                          "LRATQS"        "LMDZ proportion of condensed water from total"                 "1"
+state    real   LRUNOFFLIC       ij     misc        1         -      rh                                          "LRUNOFFLIC"    "LMDZ runoff at land-ice a time-step earlier"  "mms-1"
+state    real   LZMAX0           ij     misc        1         -      rh                                          "LZMAX0"        "LMDZ previous time-step of the characteristic length at the top of the thermals" "m"
+state    real   LF0              ij     misc        1         -      rh                                          "LF0"           "LMDZ previous time-step closure term of the thermals" "-"
+state    real   LEMA_WORK1       ikj    misc        1         -      rh                                          "LEMA_WORK1"    "LMDZ fraction of adiabatic updraft in Emanuel s CU" "1"
+state    real   LEMA_WORK2       ikj    misc        1         -      rh                                          "LEMA_WORK2"    "LMDZ Speed adiabatic updraft in Emmanuel s CU" "ms-1"
+##state    real   LWAKE_DELTAT     ikj    misc        1         -      rh                                          "LWAKE_DELTAT"  "LMDZ Thermal differences between inside/outside wake" "K"
+##state    real   LWAKE_DELTAQ     ikj    misc        1         -      rh                                          "LWAKE_DELTAQ"  "LMDZ moisture differences between inside/outside wake" "kgkg-1"
+##state    real   LWAKE_S          ij     misc        1         -      rh                                          "LWAKE_S"       "LMDZ fraction covered by the wake(cold pool)" "1"
+state    real   LWAKE_CSTAR      ij     misc        1         -      rh                                          "LWAKE_CSTAR"   "LMDZ velocity of the wake gust front"         "ms-1"
+state    real   LWAKE_PE         ij     misc        1         -      rh                                          "LWAKE_PE"      "LMDZ total vertical wake potential energy"    "Jkg-1"
+state    real   LWAKE_FIP        ij     misc        1         -      rh                                          "LWAKE_FIP"     "LMDZ Wake power given to the environment"     "Wm-2"
+state    real   LFM_THERM   i{kplus1}j  misc        1         -      rh                                          "LFM_THERM"     "LMDZ vertical mass flux within the thermal"   "kgs-1"
+state    real   LENTR_THERM     ikj     misc        1         -      rh                                          "LENTR_THERM"   "LMDZ entrainment within the thermal"          "???????"
+state    real   LDETR_THERM     ikj     misc        1         -      rh                                          "LDETR_THERM"   "LMDZ detrainment within the thermal"          "???????"
+state    real   LNAT            ij      misc        1         -      rh                                          "LNAT"          "LMDZ kind of soil"                      "-"
+##state    real   LBILS           ij      misc        1         -      rh                                          "LBILS"         "LMDZ heat flux reference at land"             "-"
+state    real   LRUG            ij     misc        1         -      rh                                          "LRUG"          "LMDZ total rugosity"             "m"
+
+#
+#---------------------------------------------------------------------------------------------------------------------------------------
+#                                               
+
+######                                          
+#                                               
+# Variables that are set at run-time to control configuration  (namelist-settable)                                              
+#                                               
+#<Table>  <Type>  <Sym>                   <How set>          <Nentries>   <Default>                                             
+
+# 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"      ""  ""
+rconfig   logical all_ic_times            namelist,time_control		1              .false. irh    "all_ic_times"     "T/F WRITE ALL IC TIME PERIODS"  ""
+
+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<domain>"          -     "name of input   infile"   ""      ""
+rconfig   character  input_outname     namelist,time_control		1  "wrfinput_d<domain>"          -     "name of input   outfile"  ""      ""
+rconfig   character  bdy_inname        namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary infile"  ""      ""
+rconfig   character  bdy_outname       namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary outfile" ""      ""
+rconfig   character  rst_inname        namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "name of restrt infile"    ""      ""
+rconfig   character  rst_outname       namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "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 write_hist_at_0h_rst    namelist,time_control		1             .false. h    "write_hist_at_0h_rst" "T/F write hist at 0 h of restarted forecast"
+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"
+rconfig   logical cycling                 namelist,time_control         1             .false. -    "true for cycling (using wrfout file as input data)"
+
+# DFI namelist
+rconfig   integer dfi_opt                namelist,dfi_control   1       0     rh   "dfi_opt"                  ""      ""
+rconfig   integer dfi_radar              namelist,dfi_control   1       0     rh   "dfi_radar"                "DFI radar switch"      ""
+rconfig   integer dfi_nfilter            namelist,dfi_control   1       7     rh   "dfi_nfilter"              "Digital filter type"      ""
+rconfig   logical dfi_write_filtered_input  namelist,dfi_control  1  .true.   rh   "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?"      ""
+rconfig   logical dfi_write_dfi_history  namelist,dfi_control   1   .false.   rh   "dfi_write_dfi_history"    "Write history files during filtering?"      ""
+rconfig   integer dfi_cutoff_seconds     namelist,dfi_control   1    3600     rh   "dfi_cutoff_seconds"       "Digital filter cutoff time"      ""
+rconfig   integer dfi_time_dim           namelist,dfi_control   1    1000     rh   "dfi_time_dim"             "MAX DIMENSION FOR HCOEFF"
+rconfig   integer dfi_fwdstop_year       namelist,dfi_control   1    2004     rh   "dfi_fwdstop_year"         "4 DIGIT YEAR OF START OF DFI" "YEARS"
+rconfig   integer dfi_fwdstop_month      namelist,dfi_control   1      03     rh   "dfi_fwdstop_month"        "2 DIGIT MONTH OF THE YEAR OF START OF DFI" "MONTHS"
+rconfig   integer dfi_fwdstop_day        namelist,dfi_control   1      13     rh   "dfi_fwdstop_day"          "2 DIGIT DAY OF THE MONTH OF START OF DFI" "DAYS"
+rconfig   integer dfi_fwdstop_hour       namelist,dfi_control   1      12     rh   "dfi_fwdstop_hour"         "2 DIGIT HOUR OF THE DAY OF START OF DFI" "HOURS"
+rconfig   integer dfi_fwdstop_minute     namelist,dfi_control   1      00     rh   "dfi_fwdstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF START OF DFI" "MINUTES"
+rconfig   integer dfi_fwdstop_second     namelist,dfi_control   1      00     rh   "dfi_fwdstop_second"       "2 DIGIT SECOND OF THE MINUTE OF START OF DFI" "SECONDS"
+rconfig   integer dfi_bckstop_year       namelist,dfi_control   1    2004     rh   "dfi_bckstop_year"         "4 DIGIT YEAR OF END OF DFI" "YEARS"
+rconfig   integer dfi_bckstop_month      namelist,dfi_control   1      03     rh   "dfi_bckstop_month"        "2 DIGIT MONTH OF THE YEAR OF END OF DFI" "MONTHS"
+rconfig   integer dfi_bckstop_day        namelist,dfi_control   1      14     rh   "dfi_bckstop_day"          "2 DIGIT DAY OF THE MONTH OF END OF DFI" "DAYS"
+rconfig   integer dfi_bckstop_hour       namelist,dfi_control   1      12     rh   "dfi_bckstop_hour"         "2 DIGIT HOUR OF THE DAY OF END OF DFI" "HOURS"
+rconfig   integer dfi_bckstop_minute     namelist,dfi_control   1      00     rh   "dfi_bckstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF END OF DFI" "MINUTES"
+rconfig   integer dfi_bckstop_second     namelist,dfi_control   1      00     rh   "dfi_bckstop_second"       "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS"
+
+# 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 time_step_dfi           namelist,domains      1             -       ih   "time_step_dfi"
+
+rconfig   integer min_time_step           namelist,domains      max_domains   -1      h    "min_time_step"
+rconfig   integer max_time_step           namelist,domains      max_domains   -1      h    "max_time_step"
+rconfig   real    target_cfl              namelist,domains      max_domains  1.2      h    "target_cfl"
+rconfig   real    target_hcfl             namelist,domains      max_domains  0.84     h    "target_hcfl"
+
+rconfig   integer max_step_increase_pct   namelist,domains      max_domains    5      h    "max_step_increase_pct"
+rconfig   integer starting_time_step      namelist,domains      max_domains   -1      h    "starting_time_step"
+rconfig   logical step_to_output_time     namelist,domains      1         .true.      h    "step_to_output_time"
+rconfig   integer adaptation_domain       namelist,domains      1              1      h    "adaptation_domain"
+rconfig   logical use_adaptive_time_step  namelist,domains      1         .false.     h    "use_adaptive_time_step"
+
+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 num_metgrid_soil_levels namelist,domains	1             4        irh    "num_metgrid_soil_levels"               "number of input levels or layers in 3D sm, st, sw arrays"      ""
+rconfig   real    p_top_requested         namelist,domains      1              5000    irh    "p_top_requested" "Pa"      ""
+rconfig   integer interp_type             namelist,domains	1              2       irh    "interp_type"  "1=interp in pressure, 2=interp in LOG pressure"  ""
+rconfig   integer vert_refine_fact        namelist,domains      1              1       irh    "vertical refinment factor for ndown"  ""
+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              2       irh    "t_extrap_type"  "1=isothermal, 2=6.5 K/km, 3=adiabatic"   ""
+rconfig   logical lowest_lev_from_sfc     namelist,domains	1             .false.  irh    "lowest_lev_from_sfc"                ""      ""
+rconfig   logical use_levels_below_ground namelist,domains	1             .true.   irh    "use_levels_below_ground"   "T/F: use input data levels below input sfc pres" ""
+rconfig   logical use_tavg_for_tsk        namelist,domains	1             .false.  irh    "use_tavg_for_tsk"   "T/F: use diurnal avg sfc temp for tsk" ""
+rconfig   logical use_surface             namelist,domains	1             .true.   irh    "use_surface"   "T/F: use input surface level in interpolation" ""
+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    "sfcp_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   logical smooth_cg_topo          namelist,domains	1              .false. irh    "smooth_cg_topo"   "T/F smooth CG topo on boundarries" "flag"
+rconfig   logical aggregate_lu            namelist,domains	1              .false. irh    "aggregate_lu"   "T/F aggregate the grass, shrubs, trees in LU"
+rconfig   logical rh2qv_wrt_liquid        namelist,domains	1              .true.  irh    "rh2qv_wrt_liquid" "T = rh=>Qv assumes RH wrt liquid water, F = allows ice"
+rconfig   integer rh2qv_method            namelist,domains	1              1       irh    "rh2qv_method" "1=old MM5 method, 2=new WMO method"
+rconfig   real    qv_max_p_safe           namelist,domains      1              10000   irh    "qv_max_p_safe" "Threshhold pressure, Qv > flag set to value"      "Pa"
+rconfig   real    qv_max_flag             namelist,domains      1              1.E-5   irh    "qv_max_flag" "Qv flag for max"  "kg kg{-1}"
+rconfig   real    qv_max_value            namelist,domains      1              3.E-6   irh    "qv_max_value" "Qv value for max"  "kg kg{-1}"
+rconfig   real    qv_min_p_safe           namelist,domains      1              110000  irh    "qv_min_p_safe" "Threshhold pressure, Qv < flag set to value"      "Pa"
+rconfig   real    qv_min_flag             namelist,domains      1              1.E-6   irh    "qv_min_flag" "Qv flag for min"  "kg kg{-1}"
+rconfig   real    qv_min_value            namelist,domains      1              1.E-6   irh    "qv_min_value" "Qv value for min"  "kg kg{-1}"
+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   logical grid_allowed            namelist,domains	max_domains    .true.  irh    "allowed"            ""      ""
+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   ts_buf_size     namelist,domains    1                200          -       "ts_buf_size"   "Size of time series buffer"
+rconfig   integer   max_ts_locs     namelist,domains    1                5            -       "max_ts_locs"   "Maximum number of time series locations"
+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   track_level     namelist,domains    1                50000
+rconfig   real      time_to_move    namelist,domains    max_domains      0.  -  "" "" "minutes"
+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.
+
+# TC (tropical cyclone bogusing)
+rconfig   logical insert_bogus_storm   namelist,tc     	1              .false. irh    "insert_bogus_storm"   "T/F for inserting a bogus typhoon"    "flag"
+rconfig   logical remove_storm         namelist,tc     	1              .false. irh    "remove_storm"  "T/F for only removing the original typhoon"  "flag"
+rconfig   integer num_storm            namelist,tc     	1              1       irh    "num_storm"     "Number of bogus typhoons"  ""
+rconfig   real    latc_loc             namelist,tc     	max_bogus      -999.   irh    "latc_loc"      "center latitude of the bogus tyhoon"  "DEGREES"
+rconfig   real    lonc_loc             namelist,tc     	max_bogus      -999.   irh    "lonc_loc"      "center longitude of the bogus tyhoon"  "DEGREES"
+rconfig   real    vmax_meters_per_second   namelist,tc  max_bogus      -999.   irh    "vmax_meters_per_second"  "vmax of bogus storm in meters per second"  ""
+rconfig   real    rmax                 namelist,tc     	max_bogus      -999.   irh    "rmax"  "maximum radius outward from storm center"  ""
+rconfig   real    vmax_ratio           namelist,tc      max_bogus      -999.   irh    "vmax_ratio"  ""  ""
+rconfig   real    rankine_lid          namelist,tc      1              -999.   irh    "top pressure limit for the tc bogus scheme"
+
+
+# Physics
+rconfig   integer     mp_physics          namelist,physics	max_domains    0       rh       "mp_physics"            ""      ""
+#rconfig   integer     milbrandt_ccntype   namelist,physics      max_domains    0       rh       "milbrandt select maritime(1)/continental(2)"  ""      ""
+rconfig   integer     gsfcgce_hail        namelist,physics      1              0       rh       "gsfcgce select hail/graupel"  ""      ""
+rconfig   integer     gsfcgce_2ice        namelist,physics      1              0       rh       "gsfcgce select 2ice/3ice"  ""      ""
+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   integer     sf_urban_physics    namelist,physics      max_domains    0       rh       "sf_urban_physics"     "activate urban model  0=no, 1=Noah_UCM 2=BEP_UCM"   ""
+rconfig   real    BLDT                    namelist,physics      max_domains    0       h    "BLDT"          ""      ""
+rconfig   integer cu_physics              namelist,physics      max_domains    0       rh   "cu_physics"    ""      ""
+rconfig   integer shcu_physics            namelist,physics      max_domains    0       rh   "shcu_physics"  ""      ""
+rconfig   integer     cu_diag             namelist,physics      max_domains    0       rh       "cu_diag"            " additional t-averaged stuff for cuphys"      ""
+rconfig   integer     kfeta_trigger       namelist,physics	1              1       rh       "KFETA Trigger function"    ""    ""
+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_urban_layers        namelist,physics	1            400       irh    "num_urban_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 cugd_avedx              namelist,physics      1            1      irh    "cugd_avedx"                    ""      ""
+rconfig   integer clos_choice             namelist,physics      1             0       rh    "clos_choice"                    ""      ""
+rconfig   integer imomentum               namelist,physics      1             0       rh    "imomentum"                    "momentum transport in G3 scheme"      ""
+rconfig   integer ishallow                namelist,physics      1             0       rh    "ishallow"  "shallow convection in G3 scheme"      ""
+rconfig   real    convtrans_avglen_m      namelist,physics      1             30      rh    "convtrans_avglen_m"  "averaging time for convective transport output variables (minutes)"      ""
+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 sst_skin                namelist,physics      1            0         h    "sst_skin" "calculate sst skin temperature 0=no, 1=yes"   ""
+rconfig   integer tmn_update              namelist,physics      1            0         h    "tmn_update" "update tmn from calculation  0=no, 1=yes"   ""
+rconfig   logical usemonalb               namelist,physics      1            .false.   h    "usemonalb"   "use 2d field vs table values  false=table, True=2d"   ""
+rconfig   logical rdmaxalb                namelist,physics      1            .true.    h     "rdmaxalb"    "false set it to table values"   ""
+rconfig   logical rdlai2d                 namelist,physics      1            .false.   h     "rdlai2d"     "false set it to table values"   ""
+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   integer lagday                  namelist,physics      1             1       -      "lagday"         ""      ""
+rconfig   logical cu_rad_feedback         namelist,physics      max_domains   .false.  -     "feedback cumulus to radiation"  ""
+rconfig   integer pxlsm_smois_init        namelist,physics      max_domains   1       irh    "PXLSM_SMOIS_INIT"    "Soil moisture initialization option 0-From analysis 1-From MAVAIL"   ""
+rconfig   integer omlcall                 namelist,physics      1            0         h     "omlcall"     "activate simple ocean mixed layer model  0=no, 1=yes"   ""
+rconfig   real    oml_hml0                namelist,physics      1            50        h     "oml_hml0"    "oml initial mixed layer depth value"   "m"
+rconfig   real    oml_gamma               namelist,physics      1            0.14      h     "oml_gamma"   "oml deep water lapse rate"   "K m-1"
+rconfig   integer isftcflx                namelist,physics      1            0         h     "isftcflx"    "switch to control sfc fluxes"   ""
+rconfig   integer iz0tlnd                 namelist,physics      1            0         h     "iz0tlnd"    "switch to control land thermal roughness length"   ""
+rconfig   real    shadlen                 namelist,physics      1            25000.    -     "shadow_length" "maximum length of orographic shadow" "m"
+rconfig   integer slope_rad               namelist,physics      max_domains    0       -     "slope_rad"  "1: use slope-dependent radiation, 0:not" ""
+rconfig   integer topo_shading            namelist,physics      max_domains    0       -     "topo_shading" "1: apply topographic shading to radiation, 0:not" ""
+rconfig   integer no_mp_heating           namelist,physics      1              0       -     "no_mp_heating" "switch to turn of latent heating in mp schemes"   ""
+rconfig   integer fractional_seaice       namelist,physics      1              0       -     "fractional_seaice" "Fractional sea-ice option"
+rconfig   logical tice2tsk_if2cold        namelist,physics      1              .false. -     "tice2tsk_if2cold" "Avoid low ice temps when ice frac and Tsk are inconsistent"
+rconfig   real    bucket_mm               namelist,physics      1             -1.      h     "bucket_mm" "bucket reset value for water accumulations -1: inactive"   ""
+rconfig   real    bucket_J                namelist,physics      1             -1.      h     "bucket_J"  "bucket reset value for energy accumulations -1: inactive"   ""
+rconfig   real    mp_tend_lim             namelist,physics      1             10.      -     "mp_tend_lim" "limit on temp tendency from mp latent heating"   "K/s"
+rconfig   real    prec_acc_dt             namelist,physics      max_domains    0.      h     "prec_acc_dt" "bucket reset time interval between outputs for cumulus or grid scale precipitation"   "minutes"
+rconfig   integer prec_acc_opt            derived               1              0       -     "prec_acc_opt" "option to output precip in a time window"          ""
+rconfig   integer bucketr_opt             derived               1              0       -     "bucketr_opt"  "option to output water accum based on bucket_mm"          ""
+
+rconfig   integer grav_settling           namelist,physics      max_domains  0         h    "grav_settling"     "activate gravitationalsettling of fog  0=no, 1=yes"
+
+#FDDA namelist parameters
+rconfig   real    FGDT                    namelist,fdda         max_domains    0       h        "FGDT"          ""      ""
+rconfig   integer  FGDTZERO               namelist,fdda         max_domains    0       rh       "FGDTZERO"             ""      ""
+rconfig   integer  grid_fdda              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   integer  grid_sfdda             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_ph   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_ph             namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   integer   k_zfac_ph             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   integer  dk_zfac_uv             namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   integer  dk_zfac_t              namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   integer  dk_zfac_ph             namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   real        guv                 namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        guv_sfc             namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gt                  namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gt_sfc              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gq                  namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gq_sfc              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gph                 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"            ""      ""
+rconfig   real    rinblw                  namelist,fdda         1              0       h        "grid_fdda"            ""      ""
+rconfig   integer xwavenum                namelist,fdda         max_domains    0       rh       "grid_fdda"            "top wave number to nudge in x direction"      "" 
+rconfig   integer ywavenum                namelist,fdda         max_domains    0       rh       "grid_fdda"            "top wave number to nudge in y direction"      ""
+rconfig   integer pxlsm_soil_nudge        namelist,fdda         max_domains    0       rh       "pxlsm_soil_nudge"     "nudge pxlsm soil"      ""
+
+#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   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   integer     obs_no_pbl_nudge_uv namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_uv" "1=no wind-nudging within pbl"          ""
+rconfig   integer     obs_no_pbl_nudge_t  namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_t"  "1=no temperature-nudging within pbl"   ""
+rconfig   integer     obs_no_pbl_nudge_q  namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_q"  "1=no moisture-nudging within pbl"      ""
+rconfig   integer     obs_sfc_scheme_horiz namelist,fdda           1              0       rh       "obs_sfcscheme_horiz" "0=wrf scheme, 1=original mm5 scheme" ""
+rconfig   integer     obs_sfc_scheme_vert  namelist,fdda           1              0       rh       "obs_sfcscheme_vert"  "0=regime vif scheme, 1=original simple scheme" ""
+rconfig   real        obs_max_sndng_gap   namelist,fdda            1              20      rh       "obs_max_sndng_gap"   "Max press gap between soundings" "centibars"
+rconfig   real        obs_nudgezfullr1_uv namelist,fdda            1              50      rh       "obs_nudgezfullr1_uv" "Vert infl full weight  height for LML obs, regime 1, winds"        ""
+rconfig   real        obs_nudgezrampr1_uv namelist,fdda            1              50      rh       "obs_nudgezrampr1_uv" "Vert infl ramp-to-zero height for LML obs, regime 1, winds"        ""
+rconfig   real        obs_nudgezfullr2_uv namelist,fdda            1              50      rh       "obs_nudgezfullr2_uv" "Vert infl full weight  height for LML obs, regime 2, winds"        ""
+rconfig   real        obs_nudgezrampr2_uv namelist,fdda            1              50      rh       "obs_nudgezrampr2_uv" "Vert infl ramp-to-zero height for LML obs, regime 2, winds"        ""
+rconfig   real        obs_nudgezfullr4_uv namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_uv" "Vert infl full weight  height for LML obs, regime 4, winds"        ""
+rconfig   real        obs_nudgezrampr4_uv namelist,fdda            1              50      rh       "obs_nudgezrampr4_uv" "Vert infl ramp-to-zero height for LML obs, regime 4, winds"        ""
+rconfig   real        obs_nudgezfullr1_t  namelist,fdda            1              50      rh       "obs_nudgezfullr1_t" "Vert infl full weight  height for LML obs, regime 1, temperature"  ""
+rconfig   real        obs_nudgezrampr1_t  namelist,fdda            1              50      rh       "obs_nudgezrampr1_t" "Vert infl ramp-to-zero height for LML obs, regime 1, temperature"  ""
+rconfig   real        obs_nudgezfullr2_t  namelist,fdda            1              50      rh       "obs_nudgezfullr2_t" "Vert infl full weight  height for LML obs, regime 2, temperature"  ""
+rconfig   real        obs_nudgezrampr2_t  namelist,fdda            1              50      rh       "obs_nudgezrampr2_t" "Vert infl ramp-to-zero height for LML obs, regime 2, temperature"  ""
+rconfig   real        obs_nudgezfullr4_t  namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_t" "Vert infl full weight  height for LML obs, regime 4, temperature"  ""
+rconfig   real        obs_nudgezrampr4_t  namelist,fdda            1              50      rh       "obs_nudgezrampr4_t" "Vert infl ramp-to-zero height for LML obs, regime 4, temperature"  ""
+rconfig   real        obs_nudgezfullr1_q  namelist,fdda            1              50      rh       "obs_nudgezfullr1_q" "Vert infl full weight  height for LML obs, regime 1, moisture"     ""
+rconfig   real        obs_nudgezrampr1_q  namelist,fdda            1              50      rh       "obs_nudgezrampr1_q" "Vert infl ramp-to-zero height for LML obs, regime 1, moisture"     ""
+rconfig   real        obs_nudgezfullr2_q  namelist,fdda            1              50      rh       "obs_nudgezfullr2_q" "Vert infl full weight  height for LML obs, regime 2, moisture"     ""
+rconfig   real        obs_nudgezrampr2_q  namelist,fdda            1              50      rh       "obs_nudgezrampr2_q" "Vert infl ramp-to-zero height for LML obs, regime 2, moisture"     ""
+rconfig   real        obs_nudgezfullr4_q  namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_q" "Vert infl full weight  height for LML obs, regime 4, moisture"     ""
+rconfig   real        obs_nudgezrampr4_q  namelist,fdda            1              50      rh       "obs_nudgezrampr4_q" "Vert infl ramp-to-zero height for LML obs, regime 4, moisture"     ""
+rconfig   real        obs_nudgezfullmin   namelist,fdda            1                 50   rh       "obs_nudgezfullmin" "Minimum depth through which vertical influence fcn remains 1.0"     "m"
+rconfig   real        obs_nudgezrampmin   namelist,fdda            1                 50   rh       "obs_nudgezrampmin" "Minimum depth through which vertical influence fcn decreases from 1.0 to 0.0" "m"
+rconfig   real        obs_nudgezmax       namelist,fdda            1               3000   rh       "obs_nudgezmax" "Maximum depth in which vertical influence function is nonzero" "m"
+rconfig   real        obs_sfcfact         namelist,fdda            1              1.0     h        "obs_sfcfact"       "Scale factor applied to time window for surface obs"     ""
+rconfig   real        obs_sfcfacr         namelist,fdda            1              1.0     h        "obs_sfcfacr"       "Scale factor applied to horiz radius of influence for surface obs"     ""
+rconfig   real        obs_dpsmx           namelist,fdda            1              7.5     h        "obs_dpsmx"         "Max pressure change allowed within horiz radius of influence"     "centibars"
+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            max_domains    0       rh       "obs_twindo"        "Half-period time window for nudging"  "hrs"
+rconfig   integer     obs_npfi            namelist,fdda            1              0       h        "obs_npfi"          "Freq in cg timesteps for diag print"  ""
+rconfig   integer     obs_ionf            namelist,fdda            max_domains    1       rh       "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   integer     obs_prt_max         namelist,fdda            1              1000    rh       "obs_prt_max"       "Maximum allowed obs entries in diagnostic printout"      ""
+rconfig   integer     obs_prt_freq        namelist,fdda            max_domains    1000    rh       "obs_prt_freq"      "Frequency in obs index for diagnostic printout."   ""
+rconfig   logical     obs_ipf_in4dob      namelist,fdda            1              .false. h        "obs_ipf_in4dob"    "Print obs input diagnostics"   ""
+rconfig   logical     obs_ipf_errob       namelist,fdda            1              .false. h        "obs_ipf_errob"     "Print obs error diagnostics"   ""
+rconfig   logical     obs_ipf_nudob       namelist,fdda            1              .false. h        "obs_ipf_nudob"     "Print obs nudge diagnostics"   ""
+rconfig   logical     obs_ipf_init        namelist,fdda            1              .true.  h        "obs_ipf_init"      "Enable obs init warning messages"   ""
+
+# Single-column model (SCM)
+rconfig   integer scm_force               namelist,scm  1       0           rh   "scm_force"            "SCM forcing switch" ""
+rconfig   real    scm_force_dx            namelist,scm  1       4000.       rh   "scm_force_dx"         "DX for SCM forcing" "m"
+rconfig   integer num_force_layers        namelist,scm  1       8           rh   "num_force_layers"     "Number of SCM forcing layers" ""
+rconfig   integer scm_lu_index            namelist,scm  1       2           rh   "scm_lu_index"         "SCM landuse index" ""
+rconfig   integer scm_isltyp              namelist,scm  1       4           rh   "scm_isltyp"           "SCM soil category" ""
+rconfig   real    scm_vegfra              namelist,scm  1       0.5         rh   "scm_vegfra"           "SCM vegetation fraction" ""
+rconfig   integer scm_canwat              namelist,scm  1       0.0         rh   "scm_canwat"           "SCM canopy water" "kg m-2"
+rconfig   real    scm_lat                 namelist,scm  1        36.605     rh   "scm_lat"              "SCM latitude" "degrees"
+rconfig   real    scm_lon                 namelist,scm  1       -97.485     rh   "scm_lon"              "SCM longitude" "degrees"
+rconfig   logical scm_th_adv              namelist,scm  1       .true.      rh   "scm_th_adv"           "Turn on theta advection in SCM"      ""
+rconfig   logical scm_wind_adv            namelist,scm  1       .true.      rh   "scm_wind_adv"         "Turn on wind advection in SCM"      ""
+rconfig   logical scm_qv_adv              namelist,scm  1       .true.      rh   "scm_qv_adv"           "Turn on qv advection in SCM"      ""
+rconfig   logical scm_ql_adv              namelist,scm  1       .false.     rh   "scm_ql_adv"           "Turn on ql advection in SCM"      ""
+rconfig   logical scm_vert_adv            namelist,scm  1       .true.      rh   "scm_vert_adv"         "Turn on vertical advection in SCM"      ""
+rconfig   integer num_force_soil_layers   namelist,scm  1       5           rh   "num_force_soil_layers" "Number of SCM soil forcing layers" ""
+rconfig   logical scm_soilT_force         namelist,scm  1       .false.     rh   "scm_soilT_force"      "Turn on soil temp forcing in SCM"      ""
+rconfig   logical scm_soilq_force         namelist,scm  1       .false.     rh   "scm_soilq_force"      "Turn on soil moisture forcing in SCM"      ""
+rconfig   logical scm_force_th_largescale namelist,scm  1       .false.     rh   "scm_force_th_largescale" "Turn on large scale theta forcing in SCM"      ""
+rconfig   logical scm_force_qv_largescale namelist,scm  1       .false.     rh   "scm_force_qv_largescale" "Turn on large scale qv forcing in SCM"      ""
+rconfig   logical scm_force_ql_largescale namelist,scm  1       .false.     rh   "scm_force_ql_largescale" "Turn on large scale ql forcing in SCM"      ""
+rconfig   logical scm_force_wind_largescale namelist,scm  1     .false.     rh   "scm_force_wind_largescale" "Turn on large scale wind forcing in SCM"      ""
+
+# Dynamics
+# dynamics option (see package definitions, below)
+rconfig   integer dyn_opt                 namelist,dynamics	1             2 
+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"                ""      ""
+# km_opt_dfi is needed for backward integration in dfi
+rconfig   integer km_opt_dfi              namelist,dynamics	1             1       irh    "km_opt_dfi"                ""      ""
+rconfig   integer damp_opt                namelist,dynamics	1             0       irh    "damp_opt"              ""      ""
+rconfig   integer rad_nudge               namelist,dynamics	1             0       irh    "rad_nudge"             ""      ""
+rconfig   integer gwd_opt                 namelist,dynamics     1             0       irh    "gwd_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    c_s                     namelist,dynamics	max_domains    0.25    h    "c_s"         "Smagorinsky coeff"      ""
+rconfig   real    c_k                     namelist,dynamics	max_domains    0.15    h    "c_k"         "TKE coeff"      ""
+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   integer  moist_adv_opt          namelist,dynamics	max_domains    1       rh    "moist_adv_opt"         "positive-definite RK3 transport switch"      ""
+rconfig   integer  moist_adv_dfi_opt      namelist,dynamics	max_domains    0       rh    "moist_adv_dfi_opt"    "positive-definite RK3 transport switch"      ""
+rconfig   integer  chem_adv_opt           namelist,dynamics	max_domains    1       rh    "chem_adv_opt"          "positive-definite RK3 transport switch"      ""
+rconfig   integer  tracer_adv_opt         namelist,dynamics	max_domains    1       rh    "tracer_adv_opt"        "positive-definite RK3 transport switch"      ""
+rconfig   integer  scalar_adv_opt         namelist,dynamics	max_domains    1       rh    "scalar_adv_opt"        "positive-definite RK3 transport switch"      ""
+rconfig   integer  tke_adv_opt            namelist,dynamics	max_domains    1       rh    "tke_adv_opt"           "positive-definite RK3 transport switch"      ""
+rconfig   logical top_radiation           namelist,dynamics	max_domains    .false. rh    "top_radiation"         ""      ""
+rconfig   integer mix_isotropic           namelist,dynamics	max_domains    0       h    "mix_isotropic"            "0=anistropic, 1=isotropic"      ""
+rconfig   real    mix_upper_bound         namelist,dynamics	max_domains    0.1     h    "mix_upper_bound"          "non-dimensional limit"      ""
+rconfig   logical top_lid                 namelist,dynamics     max_domains    .false. rh    "top_lid"               ""      ""
+rconfig   real    tke_upper_bound         namelist,dynamics	max_domains    1000.   h    "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 coriolis2d              namelist,dynamics	max_domains  .false.  irh  "coriolis2d"    ""   ""
+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"
+rconfig   real    iso_temp                namelist,dynamics	1               0.     h    "iso_temp"   "Isothermal temperature in stratosphere, real only"      "K"
+rconfig   logical use_baseparam_fr_nml    namelist,dynamics	1            .false.  irh   "use_baseparam_fr_nml"    ""   ""
+rconfig   real    fft_filter_lat          namelist,dynamics     1              91.     h    "fft_filter_lat"   ""   "grid latitude to start polar filter"
+rconfig   logical rotated_pole            namelist,dynamics     1            .false.  irh   "rotated_pole"    ""   ""
+rconfig   logical do_coriolis             namelist,dynamics	max_domains  .true.   irh  "do_coriolis"    ""   ""
+rconfig   logical do_curvature            namelist,dynamics	max_domains  .true.   irh  "do_curvature"   ""   ""
+rconfig   logical do_gradp                namelist,dynamics	max_domains  .true.   irh  "do_gradp"    ""   ""
+rconfig   integer     tracer_opt          namelist,dynamics     max_domains    0       rh    "tracer_opt"          ""      ""
+# Placeholder for decoupled advective tendency diagnostics
+rconfig   integer tenddiag                namelist,dynamics     max_domains    0       -     "Decoupled tendency diagnostics"   ""    ""
+
+# 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 constant_bc             namelist,bdy_control          1      .false. rh    "constant_bc"           ""      ""
+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 polar                   namelist,bdy_control	max_domains    .false. rh    "polar"                 ""      ""
+rconfig   logical nested                  namelist,bdy_control	max_domains    .false. rh    "nested"                ""      ""
+rconfig   real    spec_exp                namelist,bdy_control          1     0.      irh    "spec_exp"              ""      ""
+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   integer nobs_ndg_vars           derived                       1         6       -        "num_ndg_vars"         "Number of nudging variables"          ""
+rconfig   integer nobs_err_flds           derived                       1         9       -        "num_err_flds"         "Number of error fields"               ""
+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    pole_lat                derived                  max_domains    0       -        "pole_lat"              "projection info: latitude of pole" "degrees, positive north"
+rconfig   real    pole_lon                derived                  max_domains    0       -        "pole_lon"              "projection info: longitude of pole" "degrees, positive east"
+rconfig   integer  FLAG_METGRID           derived                      1          0       -        "FLAG_METGRID"         "Flag in global attributes for metgrid data"
+rconfig   integer  FLAG_SNOW              derived                      1          0       -        "FLAG_SNOW"             "Flag for snow in the global attributes for metgrid data"
+rconfig   integer  FLAG_PSFC              derived                      1          0       -        "FLAG_PSFC"             "Flag for surface pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM000010          derived                      1          0       -        "FLAG_SM000010"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM010040          derived                      1          0       -        "FLAG_SM010040"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM040100          derived                      1          0       -        "FLAG_SM040100"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM100200          derived                      1          0       -        "FLAG_SM100200"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST000010          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST010040          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST040100          derived                      1          0       -        "FLAG_ST010040"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST100200          derived                      1          0       -        "FLAG_ST100200"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_SLP               derived                      1          0       -        "FLAG_SLP"              "Flag for sea level pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SOILHGT           derived                      1          0       -        "FLAG_SOILHGT"          "Flag for soil height in the global attributes for metgrid data"
+rconfig   integer  FLAG_MF_XY             derived                      1          0       -        "FLAG_MF_XY"            "Flag for MF_XYin the global attributes for metgrid data"
+rconfig   real    bdyfrq                  derived                  max_domains    0       -        "bdyfrq"               "lateral boundary input frequency"      "seconds"
+rconfig   character mminlu                derived                  max_domains    " "     -        "mminlu"               "land use dataset"             ""
+rconfig   integer iswater                 derived                  max_domains    0       -        "iswater"              "land use index of water"      "index category"
+rconfig   integer islake                  derived                  max_domains    0       -        "islake"               "land use index of inland lake"      "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 (Cylindrical), 1=Lambert, 2=polar, 3=Mercator"
+rconfig   integer use_wps_input           derived                       1         0       -        "use_wps_input"        "0/1 flag, using wps input"      "0=no, 1=yes"
+rconfig   integer dfi_stage               derived                  max_domains    3       -        "dfi_stage"            "current stage of DFI processing"      "0=DFI setup, 1=DFI backward integration, 2=DFI forward integration, 3=WRF forecast"
+rconfig   integer mp_physics_dfi          derived                  max_domains   -1       -        "mp_physics_dfi"       ""      "-1 = no DFI and so no need to allocate DFI moist and scalar variables, >0 = running with DFI, so allocate DFI moist and scalar variables appropriate for selected microphysics package"
+
+#
+# Single dummy declaration to define a nodyn dyn option
+state integer nodyn_dummy - dyn_nodyn -  -  -  "" "" ""      
+
+# Turbine drag (td) physics
+# Turbine positions and characteristics for real-data cases are specified in a file 
+# whose name is given in the windturbines_spec variable.  If the setting is "ideal",
+# the td_ variables specify idealized wind farm geometries and turbine characteristics.
+# If the setting is "none" then wind turbine drag physics is turned off.
+rconfig character windturbines_spec namelist,physics 1 "none" - - "" "none, ideal, or a file name"
+rconfig integer td_turbgridid  namelist,physics 1 -1     - - ""  "which grid id has turbines in it"
+rconfig  real   td_hubheight   namelist,physics 1 100.   - - ""  "hub height (m)"
+rconfig  real   td_diameter    namelist,physics 1 60.    - - ""  "turbine diameter (m)"
+rconfig  real   td_stdthrcoef  namelist,physics 1 .158   - - ""  "standing thrust coefficient"
+rconfig  real   td_cutinspeed  namelist,physics 1 4.     - - ""  "cut-in speed (m/s)"
+rconfig  real   td_cutoutspeed namelist,physics 1 27.    - - ""  "cut-out speed (m/s)"
+rconfig  real   td_power       namelist,physics 1 2.     - - ""  "turbine power (MW)"
+rconfig  real   td_turbpercell namelist,physics 1 1.     - - ""  "number of turbines per cell"
+rconfig integer td_ewfx        namelist,physics 1 0      - - ""  "extent of wind farm in x-cells"
+rconfig integer td_ewfy        namelist,physics 1 0      - - ""  "extent of wind farm in y-cells"
+rconfig integer td_pwfx        namelist,physics 1 1      - - ""  "southwest corner of wind farm in x-cells"
+rconfig integer td_pwfy        namelist,physics 1 1      - - ""  "southwest corner of wind farm in y-cells"
+
+# LMDZ physic config add
+rconfig   integer lmdz_ksoil_types          namelist,domains   1         4
+rconfig   integer bottom_top_plus1          namelist,domains   1         1
+rconfig   integer num_orchidee_soil_levels  namelist,physics   1        11      irh          "num_orchidee_layers"     "Number of soil layers used in ORCHIDEE"
+rconfig   integer lmdz_ind_control          namelist,physics   1       100
+rconfig   integer lmdz_iflag_pbl            namelist,physics   1         1
+rconfig   integer lmdz_iflag_con            namelist,physics   1        30
+rconfig   integer lmdz_iflag_thermals       namelist,physics   1         0
+rconfig   integer lmdz_iflag_wake           namelist,physics   1         0
+rconfig   integer i_check_point             namelist,domains   1        15
+rconfig   integer j_check_point             namelist,domains   1        15
+rconfig   integer k_check_point             namelist,domains   1         1
+rconfig   logical lmdz_physics              namelist,physics   1        .true.
+
+#
+#---------------------------------------------------------------------------------------------------------------------------------------
+# Package Declarations
+#                                               
+
+#key      package       associated                package          associated 4d scalars
+#         name          namelist choice           state vars
+
+#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;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy
+package   wsm6scheme    mp_physics==6                -             moist:qv,qc,qr,qi,qs,qg
+package   gsfcgcescheme mp_physics==7                -             moist:qv,qc,qr,qi,qs,qg
+package   thompson      mp_physics==8                -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr
+package   milbrandt2mom mp_physics==9                -             state:refl_10cm;moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh
+package   morr_two_moment  mp_physics==10            -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng
+#package   milbrandt3mom mp_physics==12               -             moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qzr,qzi,qzs,qzg,qzh
+package   sbu_ylinscheme    mp_physics==13           -             moist:qv,qc,qr,qi,qs;state:rimi
+package   wdm5scheme    mp_physics==14               -             moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr
+package   wdm6scheme    mp_physics==16               -             moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr
+
+package   nodfimoist        mp_physics_dfi==-1       -             -
+package   passiveqv_dfi     mp_physics_dfi==0        -             dfi_moist:dfi_qv
+package   kesslerscheme_dfi mp_physics_dfi==1        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   linscheme_dfi     mp_physics_dfi==2        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   wsm3scheme_dfi    mp_physics_dfi==3        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   wsm5scheme_dfi    mp_physics_dfi==4        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs
+package   etampnew_dfi      mp_physics_dfi==5        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt
+package   wsm6scheme_dfi    mp_physics_dfi==6        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   gsfcgcescheme_dfi mp_physics_dfi==7        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   thompson_dfi      mp_physics_dfi==8        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr
+package   milbrandt2mom_dfi mp_physics_dfi==9        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh
+package   morr_two_moment_dfi  mp_physics_dfi==10    -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng
+#package   milbrandt3mom_dfi mp_physics_dfi==12       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qzr,dfi_qzi,dfi_qzs,dfi_qzg,dfi_qzh
+package   wdm5scheme_dfi    mp_physics_dfi==14       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+package   wdm6scheme_dfi    mp_physics_dfi==16       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+
+package   noprogn       progn==0                     -             -
+package   progndrop     progn==1                     -             scalar:qndrop;dfi_scalar:dfi_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;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   rrtmg_lwscheme  ra_lw_physics==4           -             state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   goddardlwscheme  ra_lw_physics==5          -             state:tlwdn,tlwup,slwdn,slwup
+package   gfdllwscheme  ra_lw_physics==99            -             -
+package   heldsuarez    ra_lw_physics==31            -             -
+
+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;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   rrtmg_swscheme  ra_sw_physics==4           -             state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc
+package   goddardswscheme  ra_sw_physics==5          -             state:tswdn,tswup,sswdn,sswup
+package   gfdlswscheme  ra_sw_physics==99            -             -
+
+package   sfclayscheme   sf_sfclay_physics==1        -             -
+package   myjsfcscheme   sf_sfclay_physics==2        -             state:tke_pbl
+package   gfssfcscheme   sf_sfclay_physics==3        -             -
+package   qnsesfcscheme  sf_sfclay_physics==4        -             -
+package   mynnsfcscheme  sf_sfclay_physics==5        -             scalar:qke;state:tsq,qsq,cov
+package   pxsfcscheme    sf_sfclay_physics==7        -             -
+
+package   noahucmscheme  sf_urban_physics==1         -             state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep
+package   bepscheme      sf_urban_physics==2         -             state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d
+package   bep_bemscheme  sf_urban_physics==3         -             state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,sfwin1_urb3d,sfwin2_urb3d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d
+
+package   slabscheme     sf_surface_physics==1       -             -
+package   lsmscheme      sf_surface_physics==2       -             -
+package   ruclsmscheme   sf_surface_physics==3       -             state:smfr3d,keepfr3dflag,soilt1
+package   pxlsmscheme    sf_surface_physics==7       -             state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old
+package   temfsfcscheme  sf_sfclay_physics==10       -             state:wm_temf
+package   idealscmsfcscheme  sf_sfclay_physics==89   -             -
+
+package   ysuscheme      bl_pbl_physics==1           -             -
+package   myjpblscheme   bl_pbl_physics==2           -             state:tke_pbl,el_pbl
+package   gfsscheme      bl_pbl_physics==3           -             -
+package   qnsepblscheme  bl_pbl_physics==4           -             state:tke_pbl,el_pbl
+package   mynnpblscheme2 bl_pbl_physics==5           -             scalar:qke;state:tsq,qsq,cov
+package   mynnpblscheme3 bl_pbl_physics==6           -             scalar:qke;state:tsq,qsq,cov
+package   acmpblscheme   bl_pbl_physics==7           -             -
+package   boulacscheme   bl_pbl_physics==8           -             state:el_pbl,tke_pbl,wu_tur,wv_tur,wt_tur,wq_tur
+package   camuwpblscheme bl_pbl_physics==9           -             state:tauresx2d,tauresy2d,qpert2d,wpert2d,tke_pbl
+package   mrfscheme      bl_pbl_physics==99          -             -
+package   temfpblscheme  bl_pbl_physics==10          -             state:te_temf,kh_temf,km_temf,shf_temf,qf_temf,uw_temf,vw_temf,wupd_temf,mf_temf,thup_temf,qlup_temf,qtup_temf,cf3d_temf,hd_temf,lcl_temf,hct_temf,cfm_temf
+
+package   kfetascheme    cu_physics==1               -             -
+package   bmjscheme      cu_physics==2               -             -
+package   gdscheme       cu_physics==3               -             -
+package   sasscheme      cu_physics==4               -             -
+package   g3scheme       cu_physics==5               -             state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow
+package   camzmscheme    cu_physics==7               -             state:precz,zmdt,zmdq,zmdice,zmdliq,evaptzm,fzsntzm,evsntzm,evapqzm,zmflxprc,zmflxsnw,zmntprpd,zmntsnpd,zmeiheat,cmfmc,cmfmcdzm,preccdzm,pconvb,pconvt,cape,zmmtu,zmmtv,zmmu,zmmd,zmupgu,zmupgd,zmvpgu,zmvpgd,zmicuu,zmicud,zmicvu,zmicvd
+package   g3tave         cu_diag==1                  -             state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,RAINCV_A,RAINCV_B,GD_CLOUD_A,GD_CLOUD_B,GD_CLOUD2_A,GD_CLOUD2_B,kbcon_deep,ktop_deep,k22_deep
+package   tiedtkescheme  cu_physics==6               -             -
+package   nsasscheme     cu_physics==14              -             -
+package   kfscheme       cu_physics==99              -             -
+
+package   g3shcuscheme   shcu_physics==1             -             -
+package   camuwshcuscheme shcu_physics==2            -             state:cmfmc,cmfmc2,qtflx_cu,slflx_cu,uflx_cu,vflx_cu,qtten_cu,slten_cu,uten_cu,vten_cu,qvten_cu,qlten_cu,qiten_cu,cbmf_cu,ufrcinvbase_cu,ufrclcl_cu,winvbase_cu,wlcl_cu,plcl_cu,pinv_cu,plfc_cu,pbup_cu,ppen_cu,qtsrc_cu,thlsrc_cu,thvlsrc_cu,emkfbup_cu,cin_cu,cinlcl_cu,cbmflimit_cu,tkeavg_cu,zinv_cu,rcwp_cu,rlwp_cu,riwp_cu,tophgt_cu,wu_cu,ufrc_cu,qtu_cu,thlu_cu,thvu_cu,uu_cu,vu_cu,qtu_emf_cu,thlu_emf_cu,uu_emf_cu,vu_emf_cu,umf_cu,uemf_cu,qcu_cu,qlu_cu,qiu_cu,cufrc_cu,fer_cu,fdr_cu,dwten_cu,diten_cu,qrten_cu,qsten_cu,flxrain_cu,flxsnow_cu,ntraprd_cu,ntsnprd_cu,excessu_cu,excessu0_cu,xc_cu,aquad_cu,bquad_cu,cquad_cu,bogbot_cu,bogtop_cu,exit_uwcu_cu,exit_conden_cu,exit_klclmkx_cu,exit_klfcmkx_cu,exit_ufrc_cu,exit_wtw_cu,exit_drycore_cu,exit_wu_cu,exit_cufliter_cu,exit_kinv1_cu,exit_rei_cu,limit_shcu_cu,limit_negcon_cu,limit_ufrc_cu,limit_ppen_cu,limit_emf_cu,limit_cinlcl_cu,limit_cin_cu,limit_cbmf_cu,limit_rei_cu,ind_delcin_cu,evapcsh,cmfsl,cmflq,cldfrash,cush,icwmrsh,snowsh,rprdsh,rliq2
+
+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;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten
+package   psusfddagd     grid_sfdda==1               -             state:u10_ndg_old,v10_ndg_old,t2_ndg_old,th2_ndg_old,q2_ndg_old,rh_ndg_old,psl_ndg_old,ps_ndg_old,u10_ndg_new,v10_ndg_new,t2_ndg_new,th2_ndg_new,q2_ndg_new,rh_ndg_new,psl_ndg_new,ps_ndg_new,tob_ndg_old,odis_ndg_old,tob_ndg_new,odis_ndg_new
+
+package   spnudging      grid_fdda==2               -              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;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten
+
+package   slopeopt       slope_rad==1               -              -
+package   gwdopt         gwd_opt==1                 -              state:var2d,oc12d,oa1,oa2,oa3,oa4,ol1,ol2,ol3,ol4,dtaux3d,dtauy3d,dusfcg,dvsfcg
+package   omlopt         omlcall==1                 -              state:tml,t0ml,hml,h0ml,huml,hvml,tmoml
+package   scmopt         scm_force==1               -              state:z_force,z_force_tend,u_g,u_g_tend,v_g,v_g_tend,w_subs,w_subs_tend,th_upstream_x,th_upstream_x_tend,th_upstream_y,th_upstream_y_tend,qv_upstream_x,qv_upstream_x_tend,qv_upstream_y,qv_upstream_y_tend,u_upstream_x,u_upstream_x_tend,u_upstream_y,u_upstream_y_tend,v_upstream_x,v_upstream_x_tend,v_upstream_y,v_upstream_y_tend,tau_x,tau_x_tend,tau_y,tau_y_tend,th_largescale,th_largescale_tend,qv_largescale,qv_largescale_tend,ql_largescale,ql_largescale_tend,u_largescale,u_largescale_tend,v_largescale,v_largescale_tend,tau_largescale,tau_largescale_tend,ql_upstream_x,ql_upstream_x_tend,ql_upstream_y,ql_upstream_y_tend,t_soil_forcing_val,t_soil_forcing_tend,q_soil_forcing_val,q_soil_forcing_tend,tau_soil,soil_depth_force
+
+package   prec_acc       prec_acc_opt==1            -              state:prec_acc_c,prec_acc_nc,snow_acc_nc
+package   bucketropt     bucketr_opt==1             -              state:i_rainc,i_rainnc
+
+package   restofwrf      use_wps_input==0            -             -
+
+package   original         moist_adv_opt==0            -             -
+package   positivedef    moist_adv_opt==1            -             -
+package   monotonic      moist_adv_opt==2            -             -
+package   tracer_test1  tracer_opt==2       -             tracer:tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8
+
+package   dfi_setup      dfi_stage==0                -             -
+package   dfi_bck        dfi_stage==1                -             -
+package   dfi_fwd        dfi_stage==2                -             -
+package   dfi_fst        dfi_stage==3                -             -
+package   dfi_startfwd   dfi_stage==4                -             -
+package   dfi_startbck   dfi_stage==5                -             -
+
+#package   digifilter     dfi_opt==1                  -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_rh,dfi_tten_rad
+package   dfi_nodfi     dfi_opt==0                  -             -
+package   dfi_dfl       dfi_opt==1                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   dfi_ddfi      dfi_opt==2                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   dfi_tdfi      dfi_opt==3                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   realonly       use_wps_input==1            -             state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc
+
+
+# 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                     -             -
+             
+# Tendency diagnostics for non-chemistry
+#
+# Placeholders for decoupled advective tendency arrays
+package   notenddiag    tenddiag==0                     -             -
+package   usetenddiag   tenddiag==1                     -             -
+                                   
+#---------------------------------------------------------------------------------------------------------------------------------------
+## 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,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,f,e,sina,cosa,ht,potevp,snopcx,soiltb,xlat,xlong,xlat_u,xlat_v,xlong_u,xlong_v,clat,clong
+halo      HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar,tracer
+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_PHYS_CU dyn_em         4:rucuten,rvcuten
+halo      HALO_EM_PHYS_SHCU dyn_em       4:rushten,rvshten
+halo      HALO_EM_FDDA dyn_em            4:rundgdten,rvndgdten
+halo      HALO_EM_FDDA_SFC dyn_em 48:z,z_at_w,pblh,regime,znt,odis_ndg_old,odis_ndg_new
+halo      HALO_EM_PHYS_DIFFUSION dyn_em  4:defor11,defor22,defor12,defor13,defor23,div,xkmv,xkmh,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,ustm
+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,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,muts
+halo      HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,tracer,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,tracer,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,tracer,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,tracer,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_CUP_G3_IN dyn_em 24:RTHFTEN,RQVFTEN,w_2,t_phy
+halo      HALO_CUP_G3_OUT dyn_em 48:cugd_tten,cugd_qvten,cugd_ttens,cugd_qvtens,raincv
+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_TRACER_E_3 dyn_em 24:tracer
+halo      HALO_EM_TRACER_E_5 dyn_em 48:tracer
+halo      HALO_EM_TRACER_E_7 dyn_em 80:tracer
+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_TOPOSHAD phys 24:ht_shad
+
+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_TRACER_OLD_E_3 dyn_em 24:tracer_old
+halo      HALO_EM_TRACER_OLD_E_5 dyn_em 48:tracer_old
+halo      HALO_EM_TRACER_OLD_E_7 dyn_em 80:tracer_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_HYDRO_UV   dyn_em 8:u_2,v_2
+
+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,tracer,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,tracer,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:ph_2,p,uratx,vratx,tratx,kpbl
+
+# 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,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,sina,cosa,e,f
+
+# Monotonic, positive definite advection requires 4 values for moist, chem, tke, and scalar for periodic lateral boundaries
+
+period    PERIOD_BDY_EM_MOIST dyn_em 4:moist
+period    PERIOD_BDY_EM_CHEM dyn_em 4:chem
+period    PERIOD_BDY_EM_TRACER dyn_em 4:tracer
+period    PERIOD_BDY_EM_SCALAR dyn_em 4:scalar
+period    PERIOD_BDY_EM_TKE dyn_em 4:tke_2
+period    PERIOD_BDY_EM_MOIST2 dyn_em 4:moist
+period    PERIOD_BDY_EM_CHEM2 dyn_em 4:chem
+period    PERIOD_BDY_EM_TRACER2 dyn_em 4:tracer
+period    PERIOD_BDY_EM_SCALAR2 dyn_em 4:scalar
+period    PERIOD_BDY_EM_MOIST_OLD dyn_em 4:moist_old
+period    PERIOD_BDY_EM_CHEM_OLD dyn_em 4:chem_old
+period    PERIOD_BDY_EM_TRACER_OLD dyn_em 4:tracer_old
+period    PERIOD_BDY_EM_SCALAR_OLD dyn_em 4:scalar_old
+period    PERIOD_BDY_EM_TKE_OLD dyn_em 4:tke_1
+
+period    PERIOD_BDY_EM_E dyn_em 2:u_2,v_2,ht
+period    PERIOD_EM_HYDRO_UV dyn_em 1:u_2,v_2
+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,ustm
+period    PERIOD_BDY_EM_PHY_BC dyn_em 2:rublten,rvblten,rucuten,rvcuten,xkmh,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,msfvx,msfvy,muu,msfux,msfuy,msfvx_inv
+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
+period    PERIOD_EM_DA dyn_em 2:ru_m,rv_m,ww_m,mut,muts
+
+#
+#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 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 NSTAW        # number of obs stations within current time window
+typedef fdob_type integer KTAUR        # restart model step
+typedef fdob_type integer LEVIDN(max_domains)   # level of nest
+typedef fdob_type integer REFPRT(max_domains)   # reference obs index for diagnostic printout
+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 logical NUDGE_UV_PBL # Flag for wind nudging within the PBL
+typedef fdob_type logical NUDGE_T_PBL  # Flag for temperature nudging within the PBL
+typedef fdob_type logical NUDGE_Q_PBL  # Flag for moisture nudging within the PBL
+typedef fdob_type integer SFC_SCHEME_HORIZ # Flag for horizontal spreading scheme for surface obs
+typedef fdob_type integer SFC_SCHEME_VERT  # Flag for vertical   spreading scheme for surface obs
+typedef fdob_type real    MAX_SNDNG_GAP # Maximum pressure gap allowed for interpolating between soundings (centibars)
+typedef fdob_type real    SFCFACT      # scale factor applied to time window for surface obs
+typedef fdob_type real    SFCFACR      # scale factor applied to horiz radius of influence for surface obs
+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    KNOWN_LAT    # Latitude  of origin point (i,j)=(1,1)
+typedef fdob_type real    KNOWN_LON    # Longitude of origin point (i,j)=(1,1)
+typedef fdob_type character SDATE      # domain starting date (YYYY-MM-DD_hh:mm:ss)
+typedef fdob_type real    XTIME_AT_REST # xtime at restart time
+typedef fdob_type real    VIF_UV(6)    # Vertical influence function parameters for wind nudging
+typedef fdob_type real    VIF_T(6)     # Vertical influence function parameters for temperature nudging
+typedef fdob_type real    VIF_Q(6)     # Vertical influence function parameters for moisture nudging
+typedef fdob_type real    VIF_FULLMIN  # Minimum depth through which vert infl fcn remains 1.0 (m)
+typedef fdob_type real    VIF_RAMPMIN  # Minimum depth through which vif decreases 1.0 to 0.0 (m)
+typedef fdob_type real    VIF_MAX      # Maximum depth in which vif is nonzero (m)
+
+# table entries are of the form
+#      <Table>  <Type>  <Sym>                <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>
+#Grid variables
+typedef fdob_type real    varobs         {nndgvar}{obs} -         1        -       -       "varobs"          "observational values in each variable"
+typedef fdob_type real    errf              h{obs}      -         1        -       -       "errf"            "errors between model and obs values"
+typedef fdob_type real    timeob             {obs}      -         1        -       -       "timeob"          "model times for each observation"          "hours"
+typedef fdob_type real    nlevs_ob           {obs}      -         1        -       -       "nlevs_ob"        "numbers of levels in sounding obs"
+typedef fdob_type real    lev_in_ob          {obs}      -         1        -       -       "lev_in_ob"       "level in sounding-type obs"
+typedef fdob_type real    plfo               {obs}      -         1        -       -       "plfo"            "index for type of obs-platform"
+typedef fdob_type real    elevob             {obs}      -         1        -       -       "elevob"          "elevation of observation"                  "meters"
+typedef fdob_type real    rio                {obs}      -         1        -       -       "rio"             "west-east grid coordinate"
+typedef fdob_type real    rjo                {obs}      -         1        -       -       "rjo"             "south-north grid coordinate"
+typedef fdob_type real    rko                {obs}      -         1        -       -       "rko"             "vertical grid coordinate"
+typedef fdob_type integer obsprt               [        -         1        -       -       "obsprt"          "obs index for diagnostic printout"
+typedef fdob_type real    latprt               [        -         1        -       -       "latprt"          "obs latitude for diagnostic printout"
+typedef fdob_type real    lonprt               [        -         1        -       -       "lonprt"          "obs longitude for diagnostic printout"
+typedef fdob_type real    mlatprt              [        -         1        -       -       "mlatprt"         "model latitude at obs location"
+typedef fdob_type real    mlonprt              [        -         1        -       -       "mlonprt"         "model longitude at obs location"
+typedef fdob_type integer stnidprt       {obsstid}{[}   -         1        -       -       "stnidprt"        "obs station id for diagnostic printout"
+typedef fdob_type real    base_state           k        -         1        -       -       "base_state"      "base-state height on half (mass) levels"   "meters"
+
+state fdob_type fdob - -
+
+# xpose variables for polar fft
+state    real   t_xxx          ikjx    -           1        -
+state    real   u_xxx          ikjx    -           1        X
+state    real   ru_xxx         ikjx    -           1        X
+state    real   v_xxx          ikjx    -           1        Y
+state    real   rv_xxx         ikjx    -           1        Y
+state    real   w_xxx          ikjx    -           1        Z
+state    real   ww_xxx         ikjx    -           1        Z
+state    real   ph_xxx         ikjx    -           1        Z
+state    real   dum_yyy        ikjy    -           1        -
+state    real   fourd_xxx      ikjx    -           1        -
+state    real   clat_xxx       ijx     -           1        -
+state    real   ht_xxx         ijx     -           1        -
+state    real   mf_xxx         ijx     -           1        -
+
+xpose XPOSE_POLAR_FILTER_TOPO dyn_em t_init,t_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_T  dyn_em t_2,t_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_U  dyn_em u_2,u_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_RU dyn_em ru_m,ru_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_V  dyn_em v_2,v_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_RV dyn_em rv_m,rv_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_W  dyn_em w_2,w_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_WW dyn_em ww_m,ww_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_PH dyn_em ph_2,ph_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_MOIST dyn_em moist,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_CHEM dyn_em chem,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_TRACER dyn_em tracer,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_SCALAR dyn_em scalar,fourd_xxx,dum_yyy
+
+# xpose variables for spectral nudging
+state    real   dif_analysis     ikj     -           1
+state    real   dif_xxx          ikjx    -           1     
+state    real   dif_yyy          ikjy    -           1     
+
+xpose XPOSE_SPECTRAL_NUDGING dyn_em dif_analysis,dif_xxx,dif_yyy
+##
+
+include registry.fire
+include registry.avgflx
+include registry.stoch
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM.orig
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM.orig	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM.orig	(revision 17)
@@ -0,0 +1,2235 @@
+#  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=<variable name>".  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.
+#
+
+include registry.dimspec
+
+################################################################################
+################################################################################
+################################################################################
+
+#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
+#<Table> <Type> <Sym>         <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>
+#
+
+# 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         -     i012rh01d=(interp_fcnm)u=(copy_fcnm)   "LU_INDEX"              "LAND USE CATEGORY"         ""
+state    real  LU_MASK          ij      misc        1         -     i3h1     "LU_MASK"              "0 land 1 water"         ""
+
+# znw, znu, dzs, and zs must be listed before any 3-d fields
+# in order for the grib output module to work correctly.  The grib output
+# module retrieves the vertical levels from these parameters.  If znw, znu
+# dzs, and zs are not listed first, vertical level will not be encoded at 
+# time 0.
+
+state    real    znu            k       dyn_em      1         -     irh       "znu"  "eta values on half (mass) levels"  ""
+state    real    znw            k       dyn_em      1         Z     i0rh     "znw"  "eta values on full (w) levels"  ""
+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"
+
+#
+# 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   prho_gc        igj      dyn_em      1        Z     i1  "PTHETA" "for UM data, from metgrid this is ptheta, but swapped to prho in real" "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   sct_dom_gc     ij       dyn_em      1        -     i1  "SCT_DOM"  "Dominant soil (top) category from GEOGRID"  "cat"
+state    real   scb_dom_gc     ij       dyn_em      1        -     i1  "SCB_DOM"  "Dominant soil (bottom) category from GEOGRID"  "cat"
+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   pdrho_gc       igj      dyn_em      1        Z     -   "PDRHO"    "dry pressure for UM data for the variables U and V"   "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   sh_gc          igj      dyn_em      1        Z     i1  "SPECHUMD"  "Specific humidity"        "kg kg-1"
+state    real   icefrac_gc     ij       dyn_em      1        -     i1  "ICEFRAC"  "Sea ice fraction"  "0 - 1 fraction"
+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"
+state    real   qh_gc          igj      dyn_em      1        Z     i1  "QH"    "hail mixing ratio"   "kg kg-1"
+state    real   qni_gc         igj      dyn_em      1        Z     i1  "QNI"   "ice no concentration"   "m-3"
+
+#-----------------------------------------------------------------------------------------------------------------------------------------------------------------
+#                                               
+# Variables for Eulerian mass coordinate dynamics                                            
+#                                               
+
+
+# Velocities
+#
+# U Vel
+state    real   u              ikjb     dyn_em      2         X     \
+     i0rhusdf=(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"
+state    real   z_force        |       dyn_em      1         -      i3rh     "Z_FORCE" "height of forcing input" "m"
+state    real   z_force_tend   |       dyn_em      1         -      i3rh     "Z_FORCE_TEND" "tendency height of forcing input" "m"
+state    real   u_g            |       dyn_em      1         -      i3rh     "U_G" "x-direction geostrophic wind" "m s-1"
+state    real   u_g_tend       |       dyn_em      1         -      i3rh     "U_G_TEND" "tendency x-direction geostrophic wind" "m s-1"
+#                                               
+# V Vel
+state    real   v              ikjb     dyn_em      2         Y     \
+     i0rhusdf=(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"                   
+state    real   v_g            |       dyn_em      1         -      i3rh     "V_G" "y-direction geostrophic wind" "m s-1"
+state    real   v_g_tend       |       dyn_em      1         -      i3rh     "V_G_TEND" "tendency y-direction geostrophic wind" "m s-1"
+#                                               
+# 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                                          
+
+state    real   w_subs         |       dyn_em      1         -      i3rh      "W_SUBS" "large-scale vertical velocity" "m s-1"
+state    real   w_subs_tend    |       dyn_em      1         -      i3rh      "W_SUBS_TEND" "tendency large-scale vertical velocity" "m s-1"
+
+# 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         -      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         -     \
+       i0rhusdf=(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         -  
+i1       real   t_2save        ikj     dyn_em      1         -   
+state    real   t_save         ikj     dyn_em      1         -      -        "t_save"
+
+state    real   th_upstream_x       |     dyn_em      1      -      i3rh     "TH_UPSTREAM_X" "upstream theta x-advection" "K s-1"
+state    real   th_upstream_x_tend  |     dyn_em      1      -      i3rh     "TH_UPSTREAM_X_TEND" "tendency upstream theta x-advection" "K s-2"
+state    real   th_upstream_y       |     dyn_em      1      -      i3rh     "TH_UPSTREAM_Y" "upstream theta y-advection" "K s-1"
+state    real   th_upstream_y_tend  |     dyn_em      1      -      i3rh     "TH_UPSTREAM_Y_TEND" "tendency upstream theta y-advection" "K s-2"
+
+state    real   qv_upstream_x       |     dyn_em      1      -      i3rh     "QV_UPSTREAM_X" "upstream qv x-advection" "kg kg-1 s-1"
+state    real   qv_upstream_x_tend  |     dyn_em      1      -      i3rh     "QV_UPSTREAM_X_TEND" "tendency upstream qv x-advection" "kg kg-1 s-2"
+state    real   qv_upstream_y       |     dyn_em      1      -      i3rh     "QV_UPSTREAM_Y" "upstream qv y-advection" "kg kg-1 s-1"
+state    real   qv_upstream_y_tend  |     dyn_em      1      -      i3rh     "QV_UPSTREAM_Y_TEND" "tendency upstream qv y-advection" "kg kg-1 s-2"
+
+state    real   ql_upstream_x       |     dyn_em      1      -      i3rh     "QL_UPSTREAM_X" "upstream ql x-advection" "kg kg-1 s-1"
+state    real   ql_upstream_x_tend  |     dyn_em      1      -      i3rh     "QL_UPSTREAM_X_TEND" "tendency upstream ql x-advection" "kg kg-1 s-2"
+state    real   ql_upstream_y       |     dyn_em      1      -      i3rh     "QL_UPSTREAM_Y" "upstream ql y-advection" "kg kg-1 s-1"
+state    real   ql_upstream_y_tend  |     dyn_em      1      -      i3rh     "QL_UPSTREAM_Y_TEND" "tendency upstream ql y-advection" "kg kg-1 s-2"
+
+state    real   u_upstream_x        |     dyn_em      1      -      i3rh     "U_UPSTREAM_X" "upstream u x-advection" "m s-2"
+state    real   u_upstream_x_tend   |     dyn_em      1      -      i3rh     "U_UPSTREAM_X_TEND" "tendency upstream u x-advection" "m s-3"
+state    real   u_upstream_y        |     dyn_em      1      -      i3rh     "U_UPSTREAM_Y" "upstream u y-advection" "m s-2"
+state    real   u_upstream_y_tend   |     dyn_em      1      -      i3rh     "U_UPSTREAM_Y_TEND" "tendency upstream u y-advection" "m s-3"
+
+state    real   v_upstream_x        |     dyn_em      1      -      i3rh     "V_UPSTREAM_X" "upstream v x-advection" "m s-2"
+state    real   v_upstream_x_tend   |     dyn_em      1      -      i3rh     "V_UPSTREAM_X_TEND" "tendency upstream v x-advection" "m s-3"
+state    real   v_upstream_y        |     dyn_em      1      -      i3rh     "V_UPSTREAM_Y" "upstream v y-advection" "m s-2"
+state    real   v_upstream_y_tend   |     dyn_em      1      -      i3rh     "V_UPSTREAM_Y_TEND" "tendency upstream v y-advection" "m s-3"
+
+state    real   th_largescale       |     dyn_em      1      -      i3rh     "TH_LARGESCALE" "SCM largescale theta" "K"
+state    real   th_largescale_tend  |     dyn_em      1      -      i3rh     "TH_LARGESCALE_TEND" "SCM tendency largescale theta" "K s-1"
+
+state    real   qv_largescale       |     dyn_em      1      -      i3rh     "QV_LARGESCALE" "SCM largescale qv" "kg kg-1 s-1"
+state    real   qv_largescale_tend  |     dyn_em      1      -      i3rh     "QV_LARGESCALE_TEND" "SCM tendency largescale qv" "kg kg-1 s-2"
+
+state    real   ql_largescale       |     dyn_em      1      -      i3rh     "QL_LARGESCALE" "SCM largescale ql" "kg kg-1 s-1"
+state    real   ql_largescale_tend  |     dyn_em      1      -      i3rh     "QL_LARGESCALE_TEND" "SCM tendency largescale ql" "kg kg-1 s-2"
+
+state    real   u_largescale        |     dyn_em      1      -      i3rh     "U_LARGESCALE" "SCM largescale u" "m s-2"
+state    real   u_largescale_tend   |     dyn_em      1      -      i3rh     "U_LARGESCALE_TEND" "SCM tendency largescale u" "m s-3"
+
+state    real   v_largescale        |     dyn_em      1      -      i3rh     "V_LARGESCALE" "SCM largescale v" "m s-2"
+state    real   v_largescale_tend   |     dyn_em      1      -      i3rh     "V_LARGESCALE_TEND" "SCM tendency largescale v" "m s-3"
+
+state    real   tau_largescale       |     dyn_em      1      -      i3rh     "TAU_LARGESCALE" "SCM largescale timescale" "s"
+state    real   tau_largescale_tend  |     dyn_em      1      -      i3rh     "TAU_LARGESCALE_TEND" "SCM tendency largescale timescale" ""
+
+state    real   tau_x               |     dyn_em      1      -      i3rh     "TAU_X" "X-direction advective timescale" "s"
+state    real   tau_x_tend          |     dyn_em      1      -      i3rh     "TAU_X_TEND" "tendency X-direction advective timescale" ""
+state    real   tau_y               |     dyn_em      1      -      i3rh     "TAU_Y" "Y-direction advective timescale" "s"
+state    real   tau_y_tend          |     dyn_em      1      -      i3rh     "TAU_Y_TEND" "tendency Y-direction advective timescale" ""
+
+dimspec  fslay  2     namelist=num_force_soil_layers    z     force_soil_layers
+state    real   t_soil_forcing_val  {fslay}     dyn_em      1      -      i3rh     "T_SOIL_FORCING_VAL" "Soil temp value for SCM forcing" "K"
+state    real   t_soil_forcing_tend {fslay}     dyn_em      1      -      i3rh     "T_SOIL_FORCING_TEND" "tendency soil temp for SCM forcing" "K s-1"
+state    real   q_soil_forcing_val  {fslay}     dyn_em      1      -      i3rh     "Q_SOIL_FORCING_VAL" "Soil moisture value for SCM forcing" "1"
+state    real   q_soil_forcing_tend {fslay}     dyn_em      1      -      i3rh     "Q_SOIL_FORCING_TEND" "tendency soil moisture for SCM forcing" "s-1"
+state    real   tau_soil            {fslay}     dyn_em      1      -      i3rh     "TAU_SOIL" "SCM soil forcing timescale" "s"
+state    real   soil_depth_force    {fslay}     dyn_em      1      -      i3rh     "SOIL_DEPTH_FORCE" "SCM depth at center of soil layers in forcing file" "1"
+
+state    real   hfx_force           -     dyn_em      1      -      i3rh     "HFX_FORCE" "SCM ideal surface sensible heat flux" "W m-2"
+state    real   lh_force            -     dyn_em      1      -      i3rh     "LH_FORCE" "SCM ideal surface latent heat flux" "W m-2"
+state    real   tsk_force           -     dyn_em      1      -      i3rh     "TSK_FORCE" "SCM ideal surface skin temperature" "W m-2"
+state    real   hfx_force_tend      -     dyn_em      1      -      i3rh     "HFX_FORCE_TEND" "SCM ideal surface sensible heat flux tendency" "W m-2 s-1"
+state    real   lh_force_tend       -     dyn_em      1      -      i3rh     "LH_FORCE_TEND" "SCM ideal surface latent heat flux tendency" "W m-2 s-1"
+state    real   tsk_force_tend      -     dyn_em      1      -      i3rh     "TSK_FORCE_TEND" "SCM ideal surface skin temperature tendency" "W m-2 s-1"
+# 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   mub_save        ij     dyn_em      1         -      -           "mub_save" "nest temp, holds orig fine grid mub" "Pa"
+state    real   mu0             ij     dyn_em      1         -      i1          "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         -      irh       "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         -      irhdus    "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    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    t_base         k       dyn_em      1         -     ir        "t_base"               "BASE STATE T IN IDEALIZED CASES"         "K"      
+state    real    z              ikj     dyn_em      1         -     -         " " " " " "
+state    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"  ""
+
+# For the adaptive timestep restart
+state    logical stepping_to_time       - misc    -         -      r     "stepping_to_time"         ""
+state    integer last_step_updated      - misc    -         -      r     "last_step_updated"        ""
+state    logical adapt_step_using_child - misc    -         -      r     "adapt_step_using_child"   ""
+state    integer last_dt_sec            - misc    -         -      r     "last_dt_sec"              "Whole seconds for last timestep"  "sec"
+state    integer last_dt_sec_num        - misc    -         -      r     "last_dt_sec_num"          "Fractional secs, numerator"       "sec"
+state    integer last_dt_sec_den        - misc    -         -      r     "last_dt_sec_den"          "Fractional secs, denominator"     "sec"
+state    integer last_dt_yr             - misc    -         -      r     "last_dt_yr"               "Relative year"                    "years"
+state    integer last_dt_mm             - misc    -         -      r     "last_dt_mm"               "Relative month"                   "months"
+
+# hydrostatic pressure vars
+state    real   p_hyd           ikj     dyn_em      1         -      irh       "p_hyd"       "hydrostatic pressure"         "Pa"
+state    real   p_hyd_w         ikj     dyn_em      1         Z       r        "p_hyd_w"     "hydrostatic pressure at full levels"         "Pa"
+
+# 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         -     i01rhd    "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         -     i01rhd    "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         -      r          "URATX"            "Ratio of U over U10 on mass points "         "dimensionless"
+state    real   vratx           ij      misc        1         -      r          "VRATX"            "Ratio of V over V10 on mass points "         "dimensionless"   
+state    real   tratx           ij      misc        1         -      r          "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"         ""         ""    
+# indicates whether to recompute mu                                                             
+state   logical press_adj      -        -          -         -     -         "press_adj"         "T/F flag adjust mu"         ""    
+
+# 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         -     \
+   i0rhusdf=(bdy_interp:dt)  "QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    qc             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    qr             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    qi             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    qs             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    qg             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+state   real    qh             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QHAIL"            "Hail mixing ratio"             "kg kg-1"
+state   real    -              ikjftb   dfi_moist       1         -     -    -
+state   real    dfi_qv         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QVAPOR"       "Water vapor mixing ratio"      "kg kg-1"
+state   real    dfi_qc         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QCLOUD"       "Cloud water mixing ratio"      "kg kg-1"
+state   real    dfi_qr         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QRAIN"        "Rain water mixing ratio"       "kg kg-1"
+state   real    dfi_qi         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QICE"         "Ice mixing ratio"              "kg kg-1"
+state   real    dfi_qs         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QSNOW"        "Snow mixing ratio"             "kg kg-1"
+state   real    dfi_qg         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QGRAUP"       "Graupel mixing ratio"          "kg kg-1"
+state   real    dfi_qh         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QHAIL"        "Hail mixing ratio"             "kg kg-1"
+state    real   rimi             ikj    misc        1         -     irh         "RIMI"           "riming intensity"  "fraction"
+
+
+# LES---------------!JDM
+
+include registry.les
+
+#-------------------
+
+# CAM physics (UW PBL, UW SHCU, ZM CU)
+include registry.cam
+
+# Chem Scalars
+state   real    -              ikjftb   chem        1         -     -    -                                       
+#
+# Tracer Scalars: If you want full resolved and non-resolved dispersion, compile WRF-Chem
+#
+state   real    -          ikjftb  tracer        1         -     -    -                                       
+state   real    tr17_1     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_1"         "tr17_1"          -
+state   real    tr17_2     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_2"         "tr17_2"          -
+state   real    tr17_3     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_3"         "tr17_3"          -
+state   real    tr17_4     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_4"         "tr17_4"          -
+state   real    tr17_5     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_5"         "tr17_5"          -
+state   real    tr17_6     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_6"         "tr17_6"          -
+state   real    tr17_7     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_7"         "tr17_7"          -
+state   real    tr17_8     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_8"         "tr17_8"
+
+# Other Scalars
+state   real    -              ikjftb  scalar      1         -     -   -
+state   real    qndrop         ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNDROP"        "Droplet number mixing ratio"        "# kg-1"
+state   real    qni            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNICE"         "Ice Number concentration" "# kg-1"
+state   real    qt             ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "CWM"           "Total condensate mixing ratio"      "kg kg-1"
+state   real    qns            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNSNOW"         "Snow Number concentration"   "# kg(-1)"
+state   real    qnr            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNRAIN"        "Rain Number concentration"   "# kg(-1)"
+state   real    qng            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNGRAUPEL"     "Graupel Number concentration" "# kg(-1)"
+state   real    qnh            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNHAIL"        "Hail Number concentration" "# kg(-1)"
+
+#state   real    qzr            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZRAIN"        "Rain reflectivity" "# m(6) kg(-1)"
+#state   real    qzi            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZICE"        "Ice reflectivity" "# m(6) kg(-1)"
+#state   real    qzs            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZSNOW"        "Snow reflectivity" "# m(6) kg(-1)"
+#state   real    qzg            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZGRPL"        "Graupel reflectivity" "# m(6) kg(-1)"
+#state   real    qzh            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZHAIL"        "Hail reflectivity" "# m(6) kg(-1)"
+
+state   real    qnn            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNCCN"         "CCN Number concentration" "# kg(-1)"
+state   real    qnc            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNCLOUD"       "cloud water Number concentration" "# kg(-1)"
+state   real    -              ikjftb  dfi_scalar      1         -     -   -
+state   real    dfi_qndrop     ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNDROP"    "Droplet number mixing ratio"        "# kg-1"
+state   real    dfi_qni        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNICE"     "Ice Number concentration" "# kg-1"
+state   real    dfi_qt         ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_CWM"       "Total condensate mixing ratio"      "kg kg-1"
+state   real    dfi_qns        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNSNOW"    "Snow Number concentration"   "# kg(-1)"
+state   real    dfi_qnr        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNRAIN"    "Rain Number concentration"   "# kg(-1)"
+state   real    dfi_qng        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)"
+state   real    dfi_qnh        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNHAIL" "Hail Number concentration" "# kg(-1)"
+
+#state   real    dfi_qzr        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZRAIN" "Rain reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzi        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZICE" "Ice reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzs        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZSNOW" "Snow reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzg        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZGRPL" "Graupel reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzh        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZHAIL" "Hail reflectivity" "m(6) kg(-1)"
+
+state   real    dfi_qnn        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCC"      "CNN Number concentration"   "# kg(-1)"
+state   real    dfi_qnc        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCLOUD"   "Cloud Number concentration" "# 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   soil_layers    i{lin}j    misc          1     Z     i1      "SOIL_LAYERS"   "SOIL LAYERS"         "cm"
+state   real   soil_levels    i{lin}j    misc          1     Z     i1      "SOIL_LEVELS"   "SOIL LEVELS"         "cm"
+state   real   st             i{lin}j    misc          1     Z     i1      "ST"            "SOIL TEMPERATURES"   "K"
+state   real   sm             i{lin}j    misc          1     Z     i1      "SM"            "SOIL MOISTURES"      "m3 m-3"
+state   real   sw             i{lin}j    misc          1     Z     i1      "SW"            "SOIL LIQUIDS"        "m3 m-3"
+state   real   soilt          i{lin}j    misc          1     Z     i1      "SOILT"         "RUC SOIL TEMPERATURES"  "K"
+state   real   soilm          i{lin}j    misc          1     Z     i1      "SOILM"         "RUC SOIL MOISTURES"  "m3 m-3"
+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     -     i012rdu "TOPOSLPX"      "ELEVATION X SLOPE"  ""
+state   real   toposlpy            ij    misc          1     -     i012rdu "TOPOSLPY"      "ELEVATION Y SLOPE"  ""
+state   real   slope               ij    misc          1     -     rdu     "SLOPE"         "ELEVATION SLOPE"  ""
+state   real   slp_azi             ij    misc          1     -     rdu     "SLP_AZI"       "ELEVATION SLOPE AZIMUTH"  "rad"
+state   real   shdmax              ij    misc          1     -     i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)   "SHDMAX"        "ANNUAL MAX VEG FRACTION" ""
+state   real   shdmin              ij    misc          1     -     i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)   "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     i012r   "LANDUSEF"      "LANDUSE FRACTION BY CATEGORY"  ""
+state   real   soilctop            isj   misc          1     Z     i012r   "SOILCTOP"      "SOIL CAT FRACTION (TOP)"  ""
+state   real   soilcbot            isj   misc          1     Z     i012r   "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"
+
+# Time series variables
+state    real   ts_hour         ?!       misc      -         -      -        "TS_HOUR"        "Model integration time, hours"
+state    real   ts_u            ?!       misc      -         -      -        "TS_U"           "Surface wind U-component, earth-relative"
+state    real   ts_v            ?!       misc      -         -      -        "TS_V"           "Surface wind V-component, earth-relative"
+state    real   ts_q            ?!       misc      -         -      -        "TS_Q"           "Surface mixing ratio"
+state    real   ts_t            ?!       misc      -         -      -        "TS_T"           "Surface temperature"
+state    real   ts_psfc         ?!       misc      -         -      -        "TS_PSFC"        "Surface pressure"
+state    real   ts_glw          ?!       misc      -         -      -        "TS_GLW"         "Downward long wave flux at surface"
+state    real   ts_gsw          ?!       misc      -         -      -        "TS_GSW"         "Net short wave flux at surface"
+state    real   ts_hfx          ?!       misc      -         -      -        "TS_HFX"         "Upward heat flux at surface"
+state    real   ts_lh           ?!       misc      -         -      -        "TS_LH"          "Upward moisture flux at surface"
+state    real   ts_tsk          ?!       misc      -         -      -        "TS_TSK"         "Skin temperature"
+state    real   ts_tslb         ?!       misc      -         -      -        "TS_TSLB"        "Soil temperature"
+state    real   ts_clw          ?!       misc      -         -      -        "TS_CLW"         "Column integrated cloud water"
+state    real   ts_rainc        ?!       misc      -         -      -        "TS_RAINC"       "Cumulus precip"
+state    real   ts_rainnc       ?!       misc      -         -      -        "TS_RAINNC"      "Grid-scale precip"
+
+# 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   SMCREL           ilj     -          1         Z     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SMCREL"           "RELATIVE SOIL MOISTURE" ""
+state    real   XICE             ij     misc        1         -     i0124rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm)  "SEAICE"             "SEA ICE FLAG"  ""
+state    real   XICEM            ij     misc        1         -     rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm)  "XICEM"             "SEA ICE FLAG (PREVIOUS STEP)"  ""
+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         -     i024rhd=(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   ACGRDFLX         ij     misc        1         -      rhdu                                       "ACGRDFLX"         "ACCUMULATED GROUND HEAT FLUX" "J 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         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SNOW"             "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real   SNOWH            ij     misc        1         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SNOWH"            "PHYSICAL SNOW DEPTH"      "m"
+#state    real   RHOSN            ij     misc        1         -     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "RHOSN"            " SNOW DENSITY"      "kg m-3" 
+state    real   CANWAT           ij     misc        1         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "CANWAT"           "CANOPY WATER"             "kg m-2"
+state    real   SST              ij     misc        1         -     i0124rhd=(interp_mask_water_field:lu_index,iswater)   "SST"              "SEA SURFACE TEMPERATURE" "K"
+state  integer  IFNDSNOWH        -      misc        1         -     i         "FNDSNOWH" "SNOWH_LOGICAL"
+state  integer  IFNDSOILW        -      misc        1         -     i         "FNDSOILW" "SOILW_LOGICAL"
+# SKIN SST
+state    real   SSTSK            ij     misc        1         -     rhd=(interp_mask_water_field:lu_index,iswater)   "SSTSK"              "SKIN SEA SURFACE TEMPERATURE" "K"
+state    real   DTW              ij     misc        1         -     r   "DTW"              "WARM LAYER TEMP DIFF" "C"
+
+# DFI variables
+state   real   hcoeff         {ndfi} misc        1         -     -    "HCOEFF"               "initialization weights"
+state   real   hcoeff_tot       -    misc        1         -     -    "HCOEFF_TOT"               "initialization weights"
+state   real   dfi_p           ikj   misc        1         -     r    "P_DFI"           "perturbation pressure"         "Pa"
+state   real   dfi_al          ikj   misc        1         -     r    "AL_DFI"          "inverse perturbation density"  "m3 kg-1"
+state   real   dfi_mu          ij    misc        1         -     r    "MU_DFI"  "perturbation dry air mass in column" "Pa"
+state   real   dfi_phb         ikj   misc        1         Z     r    "PHB_DFI"  "base-state geopotential"  "m2 s-2"
+state   real   dfi_ph0         ikj   misc        1         Z     r    "PH0_DFI"  "initial geopotential"     "m2 s-2"
+state   real   dfi_php         ikj   misc        1         Z     r    "PHP_DFI"  "geopotential"             "m2 s-2"
+state   real   dfi_u           ikj   misc        1         -     r    "U_DFI"               "u accumulation array"          "   "
+state   real   dfi_v           ikj   misc        1         -     r    "V_DFI"               "v accumulation array"          "   "
+state   real   dfi_w           ikj   misc        1         -     r    "W_DFI"               "w accumulation array"          "   "
+state   real   dfi_ww          ikj   misc        1         Z     r    "WW_DFI"              "mu-coupled eta-dot"    "Pa s-1"
+state   real   dfi_t           ikj   misc        1         -     r    "TT_DFI"               "t accumulation array"          "   "
+state   real   dfi_rh          ikj   misc        1         -     r    "RH_DFI"               "initial relative humidity"     "   "
+state   real   dfi_ph          ikj   misc        1         -     r    "PH_DFI"               "p accumulation array"          "   "
+state   real   dfi_pb          ikj   misc        1         -     r    "PB_DFI"               "pb accumulation array"          "   "
+state   real   dfi_alt         ikj   misc        1         -     r    "ALT_DFI"             "1/rho accumulation array"          "   "
+state   real   dfi_tke         ikj   misc        1         -     r    "TKE_DFI"          "TURBULENCE KINETIC ENERGY"     "m2 s-2"
+state   real   dfi_tten_rad    ikj   misc        1         -     irh  "RAD_TTEN_DFI"     "RADAR POT. TEMP. TENDENCY"     "K s-1"
+state    real  dfi_TSLB        ilj   misc        1         Z     r    "TSLB_dfi"         "SOIL TEMPERATURE"   "K"
+state    real  dfi_SMOIS       ilj    -          1         Z     r    "SMOIS_dfi"        "SOIL MOISTURE"     "m3 m-3"
+state    real  dfi_SNOW        ij    misc        1         -     r    "SNOW_dfi"         "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real  dfi_SNOWH       ij    misc        1         -     r    "SNOWH_dfi"        "PHYSICAL SNOW DEPTH"      "m"
+state    real  dfi_CANWAT      ij    misc        1         -     r    "CANWAT_dfi"       "CANOPY WATER"             "kg m-2"
+state    real  dfi_SMFR3D      ilj   misc        1         Z     r    "SMFR3D_dfi"           "SOIL ICE" ""
+state    real  dfi_KEEPFR3DFLAG ilj  misc        1         Z     r    "KEEPFR3DFLAG_dfi"     "FLAG - 1. FROZEN SOIL YES, 0 - NO"             ""
+
+# 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"
+state    real   TRB_URB4D       i{ulay}j    misc       1         Z     r      "TRB_URB4D" "ROOF LAYER TEMPERATURE"          "K"
+state    real   TW1_URB4D       i{ulay}j    misc       1         Z     r      "TW1_URB4D" "WALL LAYER TEMPERATURE"          "K"
+state    real   TW2_URB4D       i{ulay}j    misc       1         Z     r      "TW2_URB4D" "WALL LAYER TEMPERATURE"          "K"
+state    real   TGB_URB4D       i{ulay}j    misc       1         Z     r      "TGB_URB4D" "ROAD LAYER TEMPERATURE"          "K"
+state    real   TLEV_URB3D      i{ulay}j    misc       1         Z     r      "TLEV_URB3D" "INDOOR TEMPERATURE"             "K"
+state    real   QLEV_URB3D      i{ulay}j    misc       1         Z     r      "QLEV_URB3D" "SPECIFIC HUMIDITY"              "dimensionless"
+state    real   TW1LEV_URB3D    i{ulay}j    misc       1         Z     r      "TW1LEV_URB3D" "WINDOW TEMPERATURE"           "K"
+state    real   TW2LEV_URB3D    i{ulay}j    misc       1         Z     r      "TW2LEV_URB3D" "WINDOW TEMPERATURE"           "K"
+state    real   TGLEV_URB3D     i{ulay}j    misc       1         Z     r      "TGLEV_URB3D" "GROUND TEMPERATURE BELOW A BUILDING"     "K"
+state    real   TFLEV_URB3D     i{ulay}j    misc       1         Z     r      "TFLEV_URB3D" "FLOOR TEMPERATURE"                       "K"
+state    real   SF_AC_URB3D     ij          misc       1         -     r      "SF_AC_URB3D"  "SENSIBLE HEAT FLUX FROM THE AIR COND." "W m{-2}"
+state    real   LF_AC_URB3D     ij          misc       1         -     r      "LF_AC_URB3D"  "LATENT HEAT FLUX FROM THE AIR COND." "W m{-2}"
+state    real   CM_AC_URB3D     ij          misc       1         -     r      "CM_AC_URB3D"  "CONSUMPTION OF THE AIR COND." "W m{-2}"
+state    real   SFVENT_URB3D    ij          misc       1         -     r      "SFVENT_URB3D" "SENSIBLE HEAT FLUX FROM URBAN VENTILATION" "W m{-2}"
+state    real   LFVENT_URB3D    ij          misc       1         -     r      "LFVENT_URB3D" "LATENT HEAT FLUX FROM URBAN VENTILATION" "W m{-2}"
+state    real   SFWIN1_URB3D    i{ulay}j    misc       1         Z     r      "SFWIN1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW"  "W m{-2}"
+state    real   SFWIN2_URB3D    i{ulay}j    misc       1         Z     r      "SFWIN2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW"  "W m{-2}"
+state    real   SFW1_URB3D      i{ulay}j    misc       1         Z     r      "SFW1_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFW2_URB3D      i{ulay}j    misc       1         Z     r      "SFW2_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFR_URB3D       i{ulay}j    misc       1         Z     r      "SFR_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFG_URB3D       i{ulay}j    misc       1         Z     r      "SFG_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   CMR_SFCDIF      ij          misc       1         -     r      "CMR_SFCDIF" "" ""
+state    real   CHR_SFCDIF      ij          misc       1         -     r      "CHR_SFCDIF" "" ""
+state    real   CMC_SFCDIF      ij          misc       1         -     r      "CMC_SFCDIF" "" ""
+state    real   CHC_SFCDIF      ij          misc       1         -     r      "CHC_SFCDIF" "" ""
+
+
+# solar location variables from radiation driver
+state    real   COSZEN           ij     misc        1         -      r       "COSZEN"  "COS of SOLAR ZENITH ANGLE"     "dimensionless"
+state    real   HRANG            ij     misc        1         -      r       "HRANG"   "SOLAR HOUR ANGLE"          "radians"
+state    real   DECLIN            -     misc        1         -      r       "DECLIN"  "SOLAR DECLINATION"         "radians"
+state    real   SOLCON            -     misc        1         -      r       "SOLCON"  "SOLAR CONSTANT"         "W m-2"
+
+
+# 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"             ""
+
+# Additional for P-X PBL and LSM
+state    real   RA               ij     misc        1         -      r        "RA"           "AERODYNAMIC RESISTANCE"   "s m-1"
+state    real   RS               ij     misc        1         -      r        "RS"           "SURFACE RESISTANCE"       "s m-1"
+state    real   LAI              ij     misc        1         -      i0124rh       "LAI"          "Leaf area index"          "area/area"
+state    real   VEGF_PX          ij     misc        1         -      r        "VEGF_PX"      "Vegetation Fraction for PX LSM"    "area/area"
+state    real   T2OBS            ij     misc        1         -      r        "T2OBS"        "2-m temperature from analysis "          "K"
+state    real   Q2OBS            ij     misc        1         -      r        "Q2OBS"        "2-m mixing ratio from analysis "         "kg/kg"
+
+# 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   EXCH_H          ikj     misc        1         -     r          "EXCH_H"               "SCALAR EXCHANGE COEFFICIENTS "
+state    real   EXCH_M          ikj     misc        1         -     r          "EXCH_M"               "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"                             ""
+state   real   TSHLTR           ij     misc        1         -      r        "TSHLTR"                "SHELTER THETA FROM MYJ"                       "K"
+state   real   QSHLTR           ij     misc        1         -      r        "QSHLTR"                "SHELTER SPECIFIC HUMIDITY FROM MYJ"           "kg kg-1"
+state   real   PSHLTR           ij     misc        1         -      r        "PSHLTR"                "SHELTER PRESSURE FROM MYJ"           "Pa"
+state   real   TH10             ij     misc        1         -      r        "TH10"                  "10-M THETA FROM MYJ"                          "K"
+state   real   Q10              ij     misc        1         -      r        "Q10"                   "10-M SPECIFIC HUMIDITY FROM MYJ"              "kg kg-1"
+i1      real   CHKLOWQ          ij     misc        1         -     -         "CHKLOWQ"               "SURFACE SATURATION FLAG"        ""
+
+# TEMF PBL variables
+state    real   te_temf        ikj     misc        1         -      rh        "te_temf"               "Total energy from TEMF PBL scheme"      "m2 s-2"
+state    real   kh_temf        ikj     misc        1         -     rh          "kh_temf"               "Diffusion coefficient for heat from TEMF PBL"
+state    real   km_temf        ikj     misc        1         -     rh          "km_temf"               "Diffusion coefficient for momentum from TEMF PBL"
+state    real   shf_temf       ikj     misc        1         -     rh          "shf_temf"              "Sensible heat flux from TEMF PBL"      "K m s-1"
+state    real   qf_temf        ikj     misc        1         -     rh          "qf_temf"              "Sensible heat flux from TEMF PBL"       "kg/kg m s-1"
+state    real   uw_temf        ikj     misc        1         -     rh          "uw_temf"              "U momentum flux from TEMF PBL"       "m2 s-2"
+state    real   vw_temf        ikj     misc        1         -     rh          "vw_temf"              "V momentum flux from TEMF PBL"       "m2 s-2"
+state    real   wupd_temf      ikj     misc        1         -     rh          "wupd_temf"            "Updraft velocity from TEMF PBL"      "m s-1"
+state    real   mf_temf        ikj     misc        1         -     rh          "mf_temf"              "Mass flux from TEMF PBL"             "m s-1"
+state    real   thup_temf      ikj     misc        1         -     rh          "thup_temf"            "Updraft thetal from TEMF PBL"        "K"
+state    real   qtup_temf      ikj     misc        1         -     rh          "qtup_temf"            "Updraft qt from TEMF PBL"        "1"
+state    real   qlup_temf      ikj     misc        1         -     rh          "qlup_temf"            "Updraft ql (liquid water) from TEMF PBL"        "1"
+state    real   cf3d_temf      ikj     misc        1         -     rh          "cf3d_temf"            "3D Cloud fraction from TEMF PBL"        "1"
+state    real   hd_temf        ij      misc        1         -     rh          "hd_temf"              "Dry thermal top height from TEMF PBL"       "m"
+state    real   lcl_temf       ij      misc        1         -     rh          "lcl_temf"             "Lifting condensation level from TEMF PBL"       "m"
+state    real   hct_temf       ij      misc        1         -     rh          "hct_temf"             "Cloud top height from TEMF PBL"       "m"
+state    real   cfm_temf       ij      misc        1         -     rh          "cfm_temf"            "Column cloud fraction from TEMF PBL"        "1"
+state    real   wm_temf        ij      misc        1         -     rh        "wm_temf"               "Velocity scale in TEMF surface layer scheme"      "m s-1"
+
+# MYNN PBL variables
+state   real   qke             ikjftb  scalar      1         -      i0rhusdf=(bdy_interp:dt) "qke"               "twice TKE FROM MYNN"      "m2 s-2"
+state   real   tsq             ikj     misc        1         -      r        "tsq"               "liquid water pottemp variance"      "K2"
+state   real   qsq             ikj     misc        1         -      r        "qsq"               "liquid water variance"      "(kg/kg)**2"
+state   real   cov             ikj     misc        1         -      r        "cov"               "liquid water-liquid water pottemp covaria\
+nce"      "K kg/kg"
+state   real   ch               ij     misc        1         -      -        "ch"                "drag coeff for heat"    ""
+#state   real   K_m             ikj     misc        1         -     -          "K_m"               "EXCHANGE COEFFICIENT for momentum "
+#state   real   K_h             ikj     misc        1         -     -          "K_h"               "EXCHANGE COEFFICIENT for heat "
+#state   real   K_q             ikj     misc        1         -     -          "K_q"               "EXCHANGE COEFFICIENT for qke "
+
+# Additional for gravity wave drag
+state   real   DTAUX3D         ikj     misc        1         -     rh        "DTAUX3D"               "LOCAL U GWDO STRESS"   "m s-1"
+state   real   DTAUY3D         ikj     misc        1         -     rh        "DTAUY3D"               "LOCAL V GWDO STRESS"   "m s-1"
+state   real   DUSFCG           ij     misc        1         -     rh        "DUSFCG"                "COLUMN-INTEGRATED U GWDO STRESS"   "Pa m s-1"
+state   real   DVSFCG           ij     misc        1         -     rh        "DVSFCG"                "COLUMN-INTEGRATED V GWDO STRESS"   "Pa m s-1"
+state   real   VAR2D            ij     misc        1         -     i012rhdus "VAR"                   "OROGRAPHIC VARIANCE"   ""   ""
+state   real   OC12D            ij     misc        1         -     i012rhdus "CON"                   "OROGRAPHIC CONVEXITY"   ""   ""
+state   real   OA1              ij     misc        1         -     i012rhdus "OA1"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA2              ij     misc        1         -     i012rhdus "OA2"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA3              ij     misc        1         -     i012rhdus "OA3"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA4              ij     misc        1         -     i012rhdus "OA4"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL1              ij     misc        1         -     i012rhdus "OL1"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL2              ij     misc        1         -     i012rhdus "OL2"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL3              ij     misc        1         -     i012rhdus "OL3"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL4              ij     misc        1         -     i012rhdus "OL4"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+
+# BEP urban scheme  variables
+state    real    a_u_bep       ikj     misc        1         Z      -        "a_u_bep"               "IMPLICIT FOR X-COMP."      "s-1"
+state    real    a_v_bep       ikj     misc        1         Z      -        "a_v_bep"               "IMPLICIT FOR Y-COMP."      "s-1"
+state    real    a_t_bep       ikj     misc        1         Z      -        "a_t_bep"               "IMPLICIT FOR Pot. Temp"    "s-1"
+state    real    a_q_bep       ikj     misc        1         Z      -        "a_q_bep"               "IMPLICIT FOR Moisture"     "s-1"
+state    real    a_e_bep       ikj     misc        1         Z      -        "a_e_bep"               "IMPLICIT FOR TKE"          "s-1"
+state    real    b_u_bep       ikj     misc        1         Z      -        "b_u_bep"               "EXPLICIT FOR X-COMP."      "m s-2"
+state    real    b_v_bep       ikj     misc        1         Z      -        "b_v_bep"               "EXPLICIT FOR Y-COMP."      "m s-2"
+state    real    b_t_bep       ikj     misc        1         Z      -        "b_t_bep"               "EXPLICIT FOR Pot. Temp"    "K s-1"
+state    real    b_q_bep       ikj     misc        1         Z      -        "b_q_bep"               "EXPLICIT FOR Moisture"     "kg s-1"
+state    real    b_e_bep       ikj     misc        1         Z      -        "b_e_bep"               "EXPLICIT FOR TKE"          "m2 s-3"
+state    real    dlg_bep       ikj     misc        1         Z      -        "dlg_bep"               "length scale 1"            "m"
+state    real    dl_u_bep      ikj     misc        1         Z      -        "dl_u_bep"              "urban length scale"        "m"
+state    real    sf_bep        ikj     misc        1         Z      -        "sf_bep"                "surface grid"              "-"
+state    real    vl_bep        ikj     misc        1         Z      -        "vl_bep"                "volume grid"               "-"
+# BOULAC PBL variables
+state    real   tke_pbl        ikj     misc        1         -      rh        "tke_pbl"               "TKE FROM Bougeault and Lacarrere"      "m2 s-2"
+state    real   el_pbl        ikj     misc        1         -       h        "el_pbl"               "Length scale FROM Bougeault and Lacarrere"      "m"
+# Diagnostic PBL variables
+state    real   wu_tur         ikj     misc        1         -      r        "wu_tur"               "Turbulent flux of momentum(x)"      "m2 s-2"
+state    real   wv_tur         ikj     misc        1         -      r        "wv_tur"               "Turbulent flux of momentum(y)"      "m2 s-2"
+state    real   wt_tur         ikj     misc        1         -      r        "wt_tur"               "Turbulent flux of temperature"      "K m s-1"
+state    real   wq_tur         ikj     misc        1         -      r        "wq_tur"               "Turbulent flux of water vapor"      "- m s-1"
+
+# 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         -      -
+state    real   rlwtoa           ij     misc        1         -      -
+state    real   czmean           ij     misc        1         -      -
+state    real   cfracl           ij     misc        1         -      -
+state    real   cfracm           ij     misc        1         -      -
+state    real   cfrach           ij     misc        1         -      -
+state    real   acfrst           ij     misc        1         -      -
+state integer   ncfrst           ij     misc        1         -      -
+state    real   acfrcv           ij     misc        1         -      -
+state integer   ncfrcv           ij     misc        1         -      -
+
+# cam radiation variables
+state  real    -       i{ls}jf ozmixm      1    -   -     -
+state  real   mth01    i{ls}jf ozmixm      1    -   -     -
+state  real   mth02    i{ls}jf ozmixm      1    -   -     -
+state  real   mth03    i{ls}jf ozmixm      1    -   -     -
+state  real   mth04    i{ls}jf ozmixm      1    -   -     -
+state  real   mth05    i{ls}jf ozmixm      1    -   -     -
+state  real   mth06    i{ls}jf ozmixm      1    -   -     -
+state  real   mth07    i{ls}jf ozmixm      1    -   -     -
+state  real   mth08    i{ls}jf ozmixm      1    -   -     -
+state  real   mth09    i{ls}jf ozmixm      1    -   -     -
+state  real   mth10    i{ls}jf ozmixm      1    -   -     -
+state  real   mth11    i{ls}jf ozmixm      1    -   -     -
+state  real   mth12    i{ls}jf ozmixm      1    -   -     -
+state  real   pin       {ls}     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 microphysics State Variables
+state   real    F_ICE_PHY      ikj     misc         1         -      rhdu     "F_ICE_PHY"            "FRACTION OF ICE"         ""
+state   real    F_RAIN_PHY     ikj     misc         1         -      rhdu     "F_RAIN_PHY"           "FRACTION OF RAIN "         ""
+state   real    F_RIMEF_PHY    ikj     misc         1         -      rhdu     "F_RIMEF_PHY"          "MASS RATIO OF RIMED ICE "         ""
+state   real    qndropsource   ikj     misc         1         -      -        "qndropsource"         "Droplet number source"   "#/kg/s"
+
+# Other Misc State Variables                                            
+state   real    h_diabatic     ikj     misc         1         -      rhdu     "h_diabatic"            "MICROPHYSICS LATENT HEATING"         "K s-1"      
+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    msftx          ij      misc         1         -     i012rhdu=(copy_fcnm)    "MAPFAC_MX"         "Map scale factor on mass grid, x direction" ""
+state   real    msfty          ij      misc         1         -     i012rhdu=(copy_fcnm)    "MAPFAC_MY"         "Map scale factor on mass grid, y direction" ""
+state   real    msfux          ij      misc         1         X     i012rhdu=(copy_fcnm)    "MAPFAC_UX"         "Map scale factor on u-grid, x direction" ""
+state   real    msfuy          ij      misc         1         X     i012rhdu=(copy_fcnm)    "MAPFAC_UY"         "Map scale factor on u-grid, y direction" ""
+state   real    msfvx          ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MAPFAC_VX"         "Map scale factor on v-grid, x direction" ""
+state   real    msfvx_inv      ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MF_VX_INV"         "Inverse map scale factor on v-grid, x direction" ""
+state   real    msfvy          ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MAPFAC_VY"         "Map scale factor on v-grid, y direction" ""
+
+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    ht_shad        ijb     misc         1         -     df=(bdy_interp:dt)         "HGT_SHAD"        "Height of orographic shadow"   "m"
+i1      real    ht_loc         ij      misc         1         -     - 
+state   integer  shadowmask    ij      misc         1         -     - 
+state   integer min_ptchsz     -       misc         1         -     r
+
+state   real    TSK            ij      misc         1         -     i012rhdu=(copy_fcnm)    "TSK"                   "SURFACE SKIN TEMPERATURE"                  "K"
+state   real    dfi_TSK        ij      misc         1         -     r                       "TSK_dfi"               "saved SURFACE SKIN TEMPERATURE"
+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    t00            -       misc         -         -     i02rh     "t00"                   "BASE STATE TEMPERATURE   "  "K"
+state   real    p00            -       misc         -         -     i02rh     "p00"                   "BASE STATE PRESURE"         "Pa"
+state   real    tlp            -       misc         -         -     i02rh     "tlp"                   "BASE STATE LAPSE RATE    "  ""
+state   real    tiso           -       misc         -         -     i02rh     "tiso"                  "TEMP AT WHICH THE BASE T TURNS CONST"  "K"
+state   real    max_msftx      -       misc         -         -      rh       "max_mstfx"             "Max map factor in domain"  ""
+state   real    max_msfty      -       misc         -         -      rh       "max_mstfy"             "Max map factor in domain"  ""
+
+# State variables for Goddard LW and SW radiation  
+state    real  TLWDN           ij      misc        1         -      h         "TLWDN"                 "TOA LW downwelling flux"           "W m-2"
+state    real  TLWUP           ij      misc        1         -      h         "TLWUP"                 "TOA LW upwelling flux"             "W m-2"
+state    real  SLWDN           ij      misc        1         -      h         "SLWDN"                 "Surface LW downwelling flux"       "W m-2"
+state    real  SLWUP           ij      misc        1         -      h         "SLWUP"                 "Surface LW upwelling flux"         "W m-2"
+state    real  TSWDN           ij      misc        1         -      h         "TSWDN"                 "TOA SW downwelling flux"           "W m-2"
+state    real  TSWUP           ij      misc        1         -      h         "TSWUP"                 "TOA SW upwelling flux"             "W m-2"
+state    real  SSWDN           ij      misc        1         -      h         "SSWDN"                 "Surface SW downwelling flux"       "W m-2"
+state    real  SSWUP           ij      misc        1         -      h         "SSWUP"                 "Surface SW upwelling flux"         "W m-2"
+
+# Other physics variables
+
+state    real  RUSHTEN         ikj      misc        1         -      r        "RUSHTEN"               "COUPLED X WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME"   "Pa m s-2"
+state    real  RVSHTEN         ikj      misc        1         -      r        "RVSHTEN"               "COUPLED Y WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME"   "Pa m s-2"
+state    real  RTHSHTEN        ikj      misc        1         -      r        "RTHSHTEN"              "COUPLED THETA TENDENCY DUE TO SHALLOW CUMULUS SCHEME"    "Pa K s-1"
+state    real  RQVSHTEN        ikj      misc        1         -      r        "RQVSHTEN"              "COUPLED Q_V TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQRSHTEN        ikj      misc        1         -      r        "RQRSHTEN"              "COUPLED Q_R TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQCSHTEN        ikj      misc        1         -      r        "RQCSHTEN"              "COUPLED Q_C TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQSSHTEN        ikj      misc        1         -      r        "RQSSHTEN"              "COUPLED Q_S TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQISHTEN        ikj      misc        1         -      r        "RQISHTEN"              "COUPLED Q_I TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQGSHTEN        ikj      misc        1         -      r        "RQGSHTEN"              "COUPLED Q_G TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+
+state    real  RUCUTEN         ikj      misc        1         -      r        "RUCUTEN"               "COUPLED X WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION"  "Pa m s-2"
+state    real  RVCUTEN         ikj      misc        1         -      r        "RVCUTEN"               "COUPLED Y WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION"  "Pa m s-2"
+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  RAINSH           ij      misc        1         -      rhdu     "RAINSH"                "ACCUMULATED SHALLOW CUMULUS PRECIPITATION"               "mm"
+state    real  RAINNC           ij      misc        1         -      rhdu     "RAINNC"                "ACCUMULATED TOTAL GRID SCALE PRECIPITATION"              "mm"
+state  integer I_RAINC          ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_RAINC"            "BUCKET FOR RAINC"                    ""
+state  integer I_RAINNC         ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_RAINNC"           "BUCKET FOR RAINNC"                   ""
+state    real  PRATEC           ij      misc        1         -      r        "PRATEC"                "PRECIP RATE FROM CUMULUS SCHEME"                         "mm s-1"
+state    real  PRATESH          ij      misc        1         -      r        "PRATESH"               "PRECIP RATE FROM SHALLOW CUMULUS SCHEME"                 "mm s-1"
+state    real  RAINCV           ij      misc        1         -      r        "RAINCV"                "TIME-STEP CUMULUS PRECIPITATION"                         "mm"
+state    real  RAINSHV          ij      misc        1         -      r        "RAINSHV"               "TIME-STEP SHALLOW 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  HAILNC           ij      misc        1         -      rhdu     "HAILNC"                "ACCUMULATED TOTAL GRID SCALE HAIL"                       "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  HAILNCV          ij      misc        1         -      r        "HAILNCV"               "TIME-STEP NONCONVECTIVE HAIL"                            "mm"
+state    real    refl_10cm      ikj     dyn_em      1         -     hdu     "refl_10cm" "Radar reflectivity (lamda = 10 cm)"  "dBZ"
+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  edt_out          ij      misc        1         -      -        "EDT_OUT"             "EDT FROM GD SCHEME"             ""
+state    real  xmb_shallow      ij      misc        1         -      rh       "XMB_SHALLOW"             "MASSFLUX FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  k22_shallow   ij      misc        1         -      rh       "K22_SHALLOW"             "K22 LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  kbcon_shallow   ij      misc        1         -    rh       "KBCON_SHALLOW"             "KBCON LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  ktop_shallow   ij      misc        1         -     rh       "KTOP_SHALLOW"             "KTOP LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  k22_deep     ij      misc        1         -      h       "K22_DEEP"             "K22 LEVEL FROM DEEPCONVECTION (G3 only)"             ""
+state    integer  kbcon_deep     ij      misc        1         -    h       "KBCON_DEEP"             "KBCON LEVEL FROM DEEP CONVECTION (G3 only)"             ""
+state    integer  ktop_deep     ij      misc        1         -     h       "KTOP_DEEP"             "KTOP LEVEL FROM DEEP CONVECTION (G3 only)"             ""
+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  cugd_tten        ikj     misc        1         -      r        "CUGD_TTEN"             "INITIAL TTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qvten       ikj     misc        1         -      r        "CUGD_QVTEN"            "INITIAL QTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_ttens       ikj     misc        1         -      r        "CUGD_TTENS"            "INITIAL SUBSIDENCE TTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qvtens      ikj     misc        1         -      r        "CUGD_QVTENS"           "INITIAL SUBSIDNCE QTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qcten       ikj     misc        1         -      r        "CUGD_QCTEN"            "INITIAL TEMPERATURE TENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-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"
+state    real  GD_CLDFR         ikj      misc        1         -      rh     "GD_CLDFR"              "GD CLOUD Fraction"         " ? "
+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 integer  STEPAVE_COUNT     -        misc        1         -      rh      "STEPAVE_COUNT"        "time steps contained in averages for convective transport" ""
+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"              "UNCOUPLED THETA TENDENCY DUE TO LONG WAVE RADIATION"    "K s-1"
+state    real  RTHRATENSW      ikj      misc        1         -      r        "RTHRATSW"              "UNCOUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION"   "K s-1"
+state    real  CLDFRA          ikj      misc        1         -      rh       "CLDFRA"                "CLOUD FRACTION"                                       ""
+state    real  CLDFRA_OLD      ikj      misc        1         -      r        "CLDFRA_OLD"            "previous time level cldfra"                           ""
+
+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"      
+state    real  SWNORM           ij      misc        1         -      rhd      "SWNORM"                "NORMAL SHORT WAVE FLUX AT GROUND SURFACE (SLOPE-DEPENDENT)"           "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 integer  I_ACSWUPT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPT"     "BUCKET FOR UPWELLING SHORTWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACSWUPTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPTC"    "BUCKET FOR UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACSWDNT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNT"     "BUCKET FOR DOWNWELLING SHORTWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACSWDNTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNTC"    "BUCKET FOR DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACSWUPB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPB"     "BUCKET FOR UPWELLING SHORTWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACSWUPBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPBC"    "BUCKET FOR UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACSWDNB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNB"     "BUCKET FOR DOWNWELLING SHORTWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACSWDNBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNBC"    "BUCKET FOR DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACLWUPT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPT"     "BUCKET FOR UPWELLING LONGWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACLWUPTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPTC"    "BUCKET FOR UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACLWDNT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNT"     "BUCKET FOR DOWNWELLING LONGWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACLWDNTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNTC"    "BUCKET FOR DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACLWUPB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPB"     "BUCKET FOR UPWELLING LONGWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACLWUPBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPBC"    "BUCKET FOR UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACLWDNB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNB"     "BUCKET FOR DOWNWELLING LONGWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACLWDNBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNBC"    "BUCKET FOR DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2"
+state    real  SWUPT            ij      misc        1         -      rhdu     "SWUPT"                 "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP"          "W m-2"
+state    real  SWUPTC           ij      misc        1         -      rhdu     "SWUPTC"                "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2"
+state    real  SWDNT            ij      misc        1         -      rhdu     "SWDNT"                 "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP"          "W m-2"
+state    real  SWDNTC           ij      misc        1         -      rhdu     "SWDNTC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2"
+state    real  SWUPB            ij      misc        1         -      rhdu     "SWUPB"                 "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  SWUPBC           ij      misc        1         -      rhdu     "SWUPBC"                "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2"
+state    real  SWDNB            ij      misc        1         -      rhdu     "SWDNB"                 "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  SWDNBC           ij      misc        1         -      rhdu     "SWDNBC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2"
+state    real  LWUPT            ij      misc        1         -      rhdu     "LWUPT"                 "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP"          "W m-2"
+state    real  LWUPTC           ij      misc        1         -      rhdu     "LWUPTC"                "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2"
+state    real  LWDNT            ij      misc        1         -      rhdu     "LWDNT"                 "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP"          "W m-2"
+state    real  LWDNTC           ij      misc        1         -      rhdu     "LWDNTC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2"
+state    real  LWUPB            ij      misc        1         -      rhdu     "LWUPB"                 "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  LWUPBC           ij      misc        1         -      rhdu     "LWUPBC"                "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W m-2"
+state    real  LWDNB            ij      misc        1         -      rhdu     "LWDNB"                 "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  LWDNBC           ij      misc        1         -      rhdu     "LWDNBC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W 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  CLAT             ij      misc        1         -     i012rdu=(copy_fcnm)          "CLAT"                "COMPUTATIONAL GRID LATITUDE, SOUTH IS NEGATIVE"                       "degree_north"
+state    real  CLONG            ij      misc        1         -     i012rdu=(copy_fcnm)          "CLONG"               "COMPUTATIONAL GRID LONGITUDE, WEST IS NEGATIVE"                       "degree_east"
+state    real  ALBBCK           ij      misc        1         -     i0124rh   "ALBBCK"                "BACKGROUND ALBEDO"        ""
+state    real  EMBCK            ij      misc        1         -      r        "EMBCK"                 "BACKGROUND EMISSIVITY"         ""
+state    real  EMISS            ij      misc        1         -      rh       "EMISS"                 "SURFACE EMISSIVITY"         "" 
+state    real  SNOTIME          ij      misc        1         -      r        "SNOTIME"               "SNOTIME"         "" 
+state    real  NOAHRES          ij      misc        1         -      h        "NOAHRES"               "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}"
+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         -                                          
+state    real  t_phy           ikj      misc        1         -      r      "T_PHY"                        "Temperature"         "K"           
+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  TYR              ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TYR"        "ANNUAL MEAN SFC TEMPERATURE"           "K"
+state    real  TYRA             ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TYRA"   "ACCUMULATED YEARLY SFC TEMPERATURE FOR CURRENT YEAR"  "K"
+state    real  TDLY             ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TDLY"     "ACCUMULATED DAILY SFC TEMPERATURE FOR CURRENT DAY"  "K"
+state    real  TLAG             i&j     misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TLAG"         "DAILY MEAN SFC TEMPERATURE OF PRIOR DAYS"       "K"
+state    integer NYEAR          -       misc        1         -     r        "NYEAR"                  "ACCUM DAYS IN A YEAR"                         ""
+state    real    NDAY           -       misc        1         -     r        "NDAY"                  "ACCUM TIMESTEPS IN A DAY"                      ""
+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  CK               ij      misc        1         -      r        "CK"                    "ENTHALPY EXCHANGE COEFF AT 10 m"                      ""
+state    real  CKA              ij      misc        1         -      r        "CKA"                   "ENTHALPY EXCHANGE COEFF AT LOWEST MODEL LVL"          ""
+state    real  CD               ij      misc        1         -      r        "CD"                    "DRAG COEFF AT 10m"                      ""
+state    real  CDA              ij      misc        1         -      r        "CDA"                   "DRAG COEFF AT LOWEST MODEL LVL"                      ""
+state    real  UST              ij      misc        1         -      rh       "UST"                   "U* IN SIMILARITY THEORY"                      "m s-1"      
+state    real  USTM             ij      misc        1         -      r        "USTM"                  "U* IN SIMILARITY THEORY WITHOUT VCONV"        "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  ACHFX            ij      misc        1         -      rhdu     "ACHFX"                 "ACCUMULATED UPWARD HEAT FLUX AT THE SURFACE"  "J m-2"
+state    real  ACLHF            ij      misc        1         -      rhdu     "ACLHF"                 "ACCUMULATED UPWARD LATENT HEAT FLUX AT THE SURFACE"  "J 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  dfi_QVG          ij      misc        1         -      r        "QVG_dfi"               "WATER VAPOR MIXING RATIO AT THE SURFACE"      "kg kg-1"
+state    real  QCG              ij      misc        1         -      r        "QCG"                   "CLOUD WATER MIXING RATIO AT THE GROUND SURFACE"      "kg kg-1"
+state    real  DEW              ij      misc        1         -      r        "DEW"                   "DEW MIXING RATIO AT THE SURFACE"              "kg kg-1"
+state    real  SOILT1           ij      misc        1         -      i012rh   "SOILT1"                "TEMPERATURE INSIDE SNOW "    "K"
+state    real  dfi_SOILT1       ij      misc        1         -      r        "SOILT1_dfi"            "TEMPERATURE INSIDE SNOW "    "K"
+state    real  TSNAV            ij      misc        1         -      r        "TSNAV"                 "AVERAGE SNOW TEMPERATURE "                    "C"
+state    real  dfi_TSNAV        ij      misc        1         -      r        "TSNAV_dfi"             "AVERAGE SNOW TEMPERATURE "                    "C"
+state    real  REGIME           ij      misc        1         -      r        "REGIME"  "FLAGS: 1=Night/Stable, 2=Mechanical Turbulent, 3=Forced Conv, 4=Free Conv" ""
+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  dfi_SNOWC        ij      misc        1         -      r        "SNOWC_dfi"             "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    real   sr             ij      dyn_em      1         -      irh         "sr" "fraction of frozen precipitation"
+state    real   potevp         ij      dyn_em      1         -       rh         "potevp" "accumulated potential evaporation" "W m-2"
+state    real   snopcx         ij      dyn_em      1         -       rh         "snopcx" "snow phase change heat flux" "W m-2"
+state    real   soiltb         ij      dyn_em      1         -        h         "soiltb" "bottom soil temperature" "K"
+                                                
+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   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"
+state  integer save_topo_from_real -    dyn_em	    1         -    irh        "save_topo_from_real"    "1=original topo from real/0=topo modified by WRF"      "flag"
+
+## 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  RPHNDGDTEN        ikj      misc     1         -      r        "RPHNDGDTEN"              "COUPLED GEOPOTENTIAL TENDENCY DUE TO FDDA GRID NUDGING"   "Pa m2 s-3"
+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      i{10}r   "U_NDG_NEW"               "NEW X WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  V_NDG_NEW         ikjf     fdda3d   1         Y      i{10}r   "V_NDG_NEW"               "NEW Y WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  T_NDG_NEW         ikjf     fdda3d   1         -      i{10}r   "T_NDG_NEW"               "NEW PERT POT TEMP FOR FDDA GRID NUDGING"  "K"
+state    real  Q_NDG_NEW         ikjf     fdda3d   1         -      i{10}r   "Q_NDG_NEW"               "NEW WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  PH_NDG_NEW        ikjf     fdda3d   1         Z      i{10}r   "PH_NDG_NEW"              "NEW PERT GEOPOTENTIAL FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  U_NDG_OLD         ikjf     fdda3d   1         X      i{10}r   "U_NDG_OLD"               "OLD X WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  V_NDG_OLD         ikjf     fdda3d   1         Y      i{10}r   "V_NDG_OLD"               "OLD Y WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  T_NDG_OLD         ikjf     fdda3d   1         -      i{10}r   "T_NDG_OLD"               "OLD PERT POT TEMP FOR FDDA GRID NUDGING"  "K"
+state    real  Q_NDG_OLD         ikjf     fdda3d   1         -      i{10}r   "Q_NDG_OLD"               "OLD WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  PH_NDG_OLD        ikjf     fdda3d   1         Z      i{10}r   "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         -      i{10}r      "MU_NDG_NEW"              "NEW PERT COLUMN DRY MASS FOR FDDA GRID NUDGING"  "Pa"
+state    real  MU_NDG_OLD        ivjf     fdda2d   1         -      i{10}r      "MU_NDG_OLD"              "OLD PERT COLUMN DRY MASS FOR FDDA GRID NUDGING"  "Pa"
+state    real  U10_NDG_OLD       ij         misc      1         X      i9r      "U10_NDG_OLD"             "OLD U10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  U10_NDG_NEW       ij         misc      1         X      i9r      "U10_NDG_NEW"             "NEW U10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  V10_NDG_OLD       ij         misc      1         Y      i9r      "V10_NDG_OLD"             "OLD V10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  V10_NDG_NEW       ij         misc      1         Y      i9r      "V10_NDG_NEW"             "NEW V10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  T2_NDG_OLD        ij         misc      1         -      i9r      "T2_NDG_OLD"              "OLD T2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  T2_NDG_NEW        ij         misc      1         -      i9r      "T2_NDG_NEW"              "NEW T2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  TH2_NDG_OLD       ij         misc      1         -      i9r      "TH2_NDG_OLD"             "OLD TH2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  TH2_NDG_NEW       ij         misc      1         -      i9r      "TH2_NDG_NEW"             "NEW TH2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  Q2_NDG_OLD        ij         misc      1         -      i9r      "Q2_NDG_OLD"              "OLD Q2 FOR SURFACE FDDA GRID NUDGING"  "kg kg-1"
+state    real  Q2_NDG_NEW        ij         misc      1         -      i9r      "Q2_NDG_NEW"              "NEW Q2 FOR SURFACE FDDA GRID NUDGING"  "kg kg-1"
+state    real  RH_NDG_OLD        ij         misc      1         -      i9r      "RH_NDG_OLD"              "OLD RH FOR SURFACE FDDA GRID NUDGING"  "%"
+state    real  RH_NDG_NEW        ij         misc      1         -      i9r      "RH_NDG_NEW"              "NEW RH FOR SURFACE FDDA GRID NUDGING"  "%"
+state    real  PSL_NDG_OLD       ij         misc      1         -      i9r      "PSL_NDG_OLD"             "OLD PSL FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PSL_NDG_NEW       ij         misc      1         -      i9r      "PSL_NDG_NEW"             "NEW PSL FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PS_NDG_OLD        ij         misc      1         -      i9r      "PS_NDG_OLD"              "OLD PS FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PS_NDG_NEW        ij         misc      1         -      i9r      "PS_NDG_NEW"              "NEW PS FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  TOB_NDG_OLD       ij         misc      1         -      i9r      "TOB_NDG_OLD"             "OLD TOB FOR SURFACE FDDA GRID NUDGING"  ""
+state    real  ODIS_NDG_OLD      ij         misc      1         -      i9r      "ODIS_NDG_OLD"            "OLD ODIS FOR SURFACE FDDA GRID NUDGING"  "km"
+state    real  TOB_NDG_NEW       ij         misc      1         -      i9r      "TOB_NDG_NEW"             "NEW TOB FOR SURFACE FDDA GRID NUDGING"  ""
+state    real  ODIS_NDG_NEW      ij         misc      1         -      i9r      "ODIS_NDG_NEW"            "NEW ODIS FOR SURFACE FDDA GRID NUDGING"  "km"
+state    real  SN_NDG_NEW        ij         misc      1         -      i9r      "SN_NDG_NEW"              "NEW Snow Water Equivalent"  "mm"
+state    real  SN_NDG_OLD        ij         misc      1         -      i9r      "SN_NDG_OLD"              "OLD Snow Water Equivalent"  "mm"
+
+
+# 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"
+
+state   real    max_cfl         -       misc        1         -     -       "max_cfl"           "maximum CFL value in grid at a time" "-"
+
+state   real  prec_acc_c       ij       misc        1         -     rh       "prec_acc_c"       "ACCUMULATED CUMULUS PRECIPITATION OVER prec_acc_dt PERIODS OF TIME"       "mm"
+state   real  prec_acc_nc      ij       misc        1         -     rh       "prec_acc_nc"      "ACCUMULATED GRID SCALE  PRECIPITATION OVER prec_acc_dt PERIODS OF TIME"   "mm"
+state   real  snow_acc_nc      ij       misc        1         -     rh       "snow_acc_nc"      "ACCUMULATED SNOW WATER EQUIVALENT OVER prec_acc_dt PERIODS OF TIME"       "mm"
+
+# Placeholder for decoupled advective tendency diagnostics for non-chem
+state   real  -               ikjf      advh_t      1         -     -         -
+state   real  advh_qv         ikjf      advh_t      1         -     -         "advh_qv"    "ACCUMULATED HORIZONTAL TENDENCY FOR WATER VAPOR"        "kg kg-1"
+
+state   real  -               ikjf      advz_t      1         -     -         -
+state   real  advz_qv         ikjf      advz_t      1         -     -         "advz_qv"    "ACCUMULATED VERTICAL TENDENCY FOR WATER VAPOR"          "kg kg-1"
+
+# Ocean Mixed-Layer State Variables
+state   real    TML            ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "TML"    "OCEAN MIXED-LAYER TEMPERATURE"   "K"
+state   real    T0ML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "T0ML"   "INITIAL OCEAN MIXED-LAYER TEMPERATURE"   "K"
+state   real    HML            ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HML"    "OCEAN MIXED-LAYER DEPTH"   "m"
+state   real    H0ML           ij      misc         1         -     i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "H0ML"   "INITIAL OCEAN MIXED-LAYER DEPTH"   "m"
+state   real    HUML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HUML"   "OCEAN MIXED-LAYER DEPTH * U-CURRENT"  " m2s-1 "
+state   real    HVML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HVML"   "OCEAN MIXED-LAYER DEPTH * V-CURRENT"  " m2s-1 " 
+state   real    TMOML          ij      misc         1         -     i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm) "TMOML"  "OCEAN LAYER MEAN TEMPERATURE   "   "K"
+#
+#---------------------------------------------------------------------------------------------------------------------------------------
+#                                               
+
+######                                          
+#                                               
+# Variables that are set at run-time to control configuration  (namelist-settable)                                              
+#                                               
+#<Table>  <Type>  <Sym>                   <How set>          <Nentries>   <Default>                                             
+
+# 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"      ""  ""
+rconfig   logical all_ic_times            namelist,time_control		1              .false. irh    "all_ic_times"     "T/F WRITE ALL IC TIME PERIODS"  ""
+
+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<domain>"          -     "name of input   infile"   ""      ""
+rconfig   character  input_outname     namelist,time_control		1  "wrfinput_d<domain>"          -     "name of input   outfile"  ""      ""
+rconfig   character  bdy_inname        namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary infile"  ""      ""
+rconfig   character  bdy_outname       namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary outfile" ""      ""
+rconfig   character  rst_inname        namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "name of restrt infile"    ""      ""
+rconfig   character  rst_outname       namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "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 write_hist_at_0h_rst    namelist,time_control		1             .false. h    "write_hist_at_0h_rst" "T/F write hist at 0 h of restarted forecast"
+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"
+rconfig   logical cycling                 namelist,time_control         1             .false. -    "true for cycling (using wrfout file as input data)"
+
+# DFI namelist
+rconfig   integer dfi_opt                namelist,dfi_control   1       0     rh   "dfi_opt"                  ""      ""
+rconfig   integer dfi_radar              namelist,dfi_control   1       0     rh   "dfi_radar"                "DFI radar switch"      ""
+rconfig   integer dfi_nfilter            namelist,dfi_control   1       7     rh   "dfi_nfilter"              "Digital filter type"      ""
+rconfig   logical dfi_write_filtered_input  namelist,dfi_control  1  .true.   rh   "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?"      ""
+rconfig   logical dfi_write_dfi_history  namelist,dfi_control   1   .false.   rh   "dfi_write_dfi_history"    "Write history files during filtering?"      ""
+rconfig   integer dfi_cutoff_seconds     namelist,dfi_control   1    3600     rh   "dfi_cutoff_seconds"       "Digital filter cutoff time"      ""
+rconfig   integer dfi_time_dim           namelist,dfi_control   1    1000     rh   "dfi_time_dim"             "MAX DIMENSION FOR HCOEFF"
+rconfig   integer dfi_fwdstop_year       namelist,dfi_control   1    2004     rh   "dfi_fwdstop_year"         "4 DIGIT YEAR OF START OF DFI" "YEARS"
+rconfig   integer dfi_fwdstop_month      namelist,dfi_control   1      03     rh   "dfi_fwdstop_month"        "2 DIGIT MONTH OF THE YEAR OF START OF DFI" "MONTHS"
+rconfig   integer dfi_fwdstop_day        namelist,dfi_control   1      13     rh   "dfi_fwdstop_day"          "2 DIGIT DAY OF THE MONTH OF START OF DFI" "DAYS"
+rconfig   integer dfi_fwdstop_hour       namelist,dfi_control   1      12     rh   "dfi_fwdstop_hour"         "2 DIGIT HOUR OF THE DAY OF START OF DFI" "HOURS"
+rconfig   integer dfi_fwdstop_minute     namelist,dfi_control   1      00     rh   "dfi_fwdstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF START OF DFI" "MINUTES"
+rconfig   integer dfi_fwdstop_second     namelist,dfi_control   1      00     rh   "dfi_fwdstop_second"       "2 DIGIT SECOND OF THE MINUTE OF START OF DFI" "SECONDS"
+rconfig   integer dfi_bckstop_year       namelist,dfi_control   1    2004     rh   "dfi_bckstop_year"         "4 DIGIT YEAR OF END OF DFI" "YEARS"
+rconfig   integer dfi_bckstop_month      namelist,dfi_control   1      03     rh   "dfi_bckstop_month"        "2 DIGIT MONTH OF THE YEAR OF END OF DFI" "MONTHS"
+rconfig   integer dfi_bckstop_day        namelist,dfi_control   1      14     rh   "dfi_bckstop_day"          "2 DIGIT DAY OF THE MONTH OF END OF DFI" "DAYS"
+rconfig   integer dfi_bckstop_hour       namelist,dfi_control   1      12     rh   "dfi_bckstop_hour"         "2 DIGIT HOUR OF THE DAY OF END OF DFI" "HOURS"
+rconfig   integer dfi_bckstop_minute     namelist,dfi_control   1      00     rh   "dfi_bckstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF END OF DFI" "MINUTES"
+rconfig   integer dfi_bckstop_second     namelist,dfi_control   1      00     rh   "dfi_bckstop_second"       "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS"
+
+# 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 time_step_dfi           namelist,domains      1             -       ih   "time_step_dfi"
+
+rconfig   integer min_time_step           namelist,domains      max_domains   -1      h    "min_time_step"
+rconfig   integer max_time_step           namelist,domains      max_domains   -1      h    "max_time_step"
+rconfig   real    target_cfl              namelist,domains      max_domains  1.2      h    "target_cfl"
+rconfig   real    target_hcfl             namelist,domains      max_domains  0.84     h    "target_hcfl"
+
+rconfig   integer max_step_increase_pct   namelist,domains      max_domains    5      h    "max_step_increase_pct"
+rconfig   integer starting_time_step      namelist,domains      max_domains   -1      h    "starting_time_step"
+rconfig   logical step_to_output_time     namelist,domains      1         .true.      h    "step_to_output_time"
+rconfig   integer adaptation_domain       namelist,domains      1              1      h    "adaptation_domain"
+rconfig   logical use_adaptive_time_step  namelist,domains      1         .false.     h    "use_adaptive_time_step"
+
+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 num_metgrid_soil_levels namelist,domains	1             4        irh    "num_metgrid_soil_levels"               "number of input levels or layers in 3D sm, st, sw arrays"      ""
+rconfig   real    p_top_requested         namelist,domains      1              5000    irh    "p_top_requested" "Pa"      ""
+rconfig   integer interp_type             namelist,domains	1              2       irh    "interp_type"  "1=interp in pressure, 2=interp in LOG pressure"  ""
+rconfig   integer vert_refine_fact        namelist,domains      1              1       irh    "vertical refinment factor for ndown"  ""
+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              2       irh    "t_extrap_type"  "1=isothermal, 2=6.5 K/km, 3=adiabatic"   ""
+rconfig   logical lowest_lev_from_sfc     namelist,domains	1             .false.  irh    "lowest_lev_from_sfc"                ""      ""
+rconfig   logical use_levels_below_ground namelist,domains	1             .true.   irh    "use_levels_below_ground"   "T/F: use input data levels below input sfc pres" ""
+rconfig   logical use_tavg_for_tsk        namelist,domains	1             .false.  irh    "use_tavg_for_tsk"   "T/F: use diurnal avg sfc temp for tsk" ""
+rconfig   logical use_surface             namelist,domains	1             .true.   irh    "use_surface"   "T/F: use input surface level in interpolation" ""
+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    "sfcp_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   logical smooth_cg_topo          namelist,domains	1              .false. irh    "smooth_cg_topo"   "T/F smooth CG topo on boundarries" "flag"
+rconfig   logical aggregate_lu            namelist,domains	1              .false. irh    "aggregate_lu"   "T/F aggregate the grass, shrubs, trees in LU"
+rconfig   logical rh2qv_wrt_liquid        namelist,domains	1              .true.  irh    "rh2qv_wrt_liquid" "T = rh=>Qv assumes RH wrt liquid water, F = allows ice"
+rconfig   integer rh2qv_method            namelist,domains	1              1       irh    "rh2qv_method" "1=old MM5 method, 2=new WMO method"
+rconfig   real    qv_max_p_safe           namelist,domains      1              10000   irh    "qv_max_p_safe" "Threshhold pressure, Qv > flag set to value"      "Pa"
+rconfig   real    qv_max_flag             namelist,domains      1              1.E-5   irh    "qv_max_flag" "Qv flag for max"  "kg kg{-1}"
+rconfig   real    qv_max_value            namelist,domains      1              3.E-6   irh    "qv_max_value" "Qv value for max"  "kg kg{-1}"
+rconfig   real    qv_min_p_safe           namelist,domains      1              110000  irh    "qv_min_p_safe" "Threshhold pressure, Qv < flag set to value"      "Pa"
+rconfig   real    qv_min_flag             namelist,domains      1              1.E-6   irh    "qv_min_flag" "Qv flag for min"  "kg kg{-1}"
+rconfig   real    qv_min_value            namelist,domains      1              1.E-6   irh    "qv_min_value" "Qv value for min"  "kg kg{-1}"
+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   logical grid_allowed            namelist,domains	max_domains    .true.  irh    "allowed"            ""      ""
+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   ts_buf_size     namelist,domains    1                200          -       "ts_buf_size"   "Size of time series buffer"
+rconfig   integer   max_ts_locs     namelist,domains    1                5            -       "max_ts_locs"   "Maximum number of time series locations"
+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   track_level     namelist,domains    1                50000
+rconfig   real      time_to_move    namelist,domains    max_domains      0.  -  "" "" "minutes"
+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.
+
+# TC (tropical cyclone bogusing)
+rconfig   logical insert_bogus_storm   namelist,tc     	1              .false. irh    "insert_bogus_storm"   "T/F for inserting a bogus typhoon"    "flag"
+rconfig   logical remove_storm         namelist,tc     	1              .false. irh    "remove_storm"  "T/F for only removing the original typhoon"  "flag"
+rconfig   integer num_storm            namelist,tc     	1              1       irh    "num_storm"     "Number of bogus typhoons"  ""
+rconfig   real    latc_loc             namelist,tc     	max_bogus      -999.   irh    "latc_loc"      "center latitude of the bogus tyhoon"  "DEGREES"
+rconfig   real    lonc_loc             namelist,tc     	max_bogus      -999.   irh    "lonc_loc"      "center longitude of the bogus tyhoon"  "DEGREES"
+rconfig   real    vmax_meters_per_second   namelist,tc  max_bogus      -999.   irh    "vmax_meters_per_second"  "vmax of bogus storm in meters per second"  ""
+rconfig   real    rmax                 namelist,tc     	max_bogus      -999.   irh    "rmax"  "maximum radius outward from storm center"  ""
+rconfig   real    vmax_ratio           namelist,tc      max_bogus      -999.   irh    "vmax_ratio"  ""  ""
+rconfig   real    rankine_lid          namelist,tc      1              -999.   irh    "top pressure limit for the tc bogus scheme"
+
+
+# Physics
+rconfig   integer     mp_physics          namelist,physics	max_domains    0       rh       "mp_physics"            ""      ""
+#rconfig   integer     milbrandt_ccntype   namelist,physics      max_domains    0       rh       "milbrandt select maritime(1)/continental(2)"  ""      ""
+rconfig   integer     gsfcgce_hail        namelist,physics      1              0       rh       "gsfcgce select hail/graupel"  ""      ""
+rconfig   integer     gsfcgce_2ice        namelist,physics      1              0       rh       "gsfcgce select 2ice/3ice"  ""      ""
+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   integer     sf_urban_physics    namelist,physics      max_domains    0       rh       "sf_urban_physics"     "activate urban model  0=no, 1=Noah_UCM 2=BEP_UCM"   ""
+rconfig   real    BLDT                    namelist,physics      max_domains    0       h    "BLDT"          ""      ""
+rconfig   integer cu_physics              namelist,physics      max_domains    0       rh   "cu_physics"    ""      ""
+rconfig   integer shcu_physics            namelist,physics      max_domains    0       rh   "shcu_physics"  ""      ""
+rconfig   integer     cu_diag             namelist,physics      max_domains    0       rh       "cu_diag"            " additional t-averaged stuff for cuphys"      ""
+rconfig   integer     kfeta_trigger       namelist,physics	1              1       rh       "KFETA Trigger function"    ""    ""
+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_urban_layers        namelist,physics	1            400       irh    "num_urban_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 cugd_avedx              namelist,physics      1            1      irh    "cugd_avedx"                    ""      ""
+rconfig   integer clos_choice             namelist,physics      1             0       rh    "clos_choice"                    ""      ""
+rconfig   integer imomentum               namelist,physics      1             0       rh    "imomentum"                    "momentum transport in G3 scheme"      ""
+rconfig   integer ishallow                namelist,physics      1             0       rh    "ishallow"  "shallow convection in G3 scheme"      ""
+rconfig   real    convtrans_avglen_m      namelist,physics      1             30      rh    "convtrans_avglen_m"  "averaging time for convective transport output variables (minutes)"      ""
+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 sst_skin                namelist,physics      1            0         h    "sst_skin" "calculate sst skin temperature 0=no, 1=yes"   ""
+rconfig   integer tmn_update              namelist,physics      1            0         h    "tmn_update" "update tmn from calculation  0=no, 1=yes"   ""
+rconfig   logical usemonalb               namelist,physics      1            .false.   h    "usemonalb"   "use 2d field vs table values  false=table, True=2d"   ""
+rconfig   logical rdmaxalb                namelist,physics      1            .true.    h     "rdmaxalb"    "false set it to table values"   ""
+rconfig   logical rdlai2d                 namelist,physics      1            .false.   h     "rdlai2d"     "false set it to table values"   ""
+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   integer lagday                  namelist,physics      1             1       -      "lagday"         ""      ""
+rconfig   logical cu_rad_feedback         namelist,physics      max_domains   .false.  -     "feedback cumulus to radiation"  ""
+rconfig   integer pxlsm_smois_init        namelist,physics      max_domains   1       irh    "PXLSM_SMOIS_INIT"    "Soil moisture initialization option 0-From analysis 1-From MAVAIL"   ""
+rconfig   integer omlcall                 namelist,physics      1            0         h     "omlcall"     "activate simple ocean mixed layer model  0=no, 1=yes"   ""
+rconfig   real    oml_hml0                namelist,physics      1            50        h     "oml_hml0"    "oml initial mixed layer depth value"   "m"
+rconfig   real    oml_gamma               namelist,physics      1            0.14      h     "oml_gamma"   "oml deep water lapse rate"   "K m-1"
+rconfig   integer isftcflx                namelist,physics      1            0         h     "isftcflx"    "switch to control sfc fluxes"   ""
+rconfig   integer iz0tlnd                 namelist,physics      1            0         h     "iz0tlnd"    "switch to control land thermal roughness length"   ""
+rconfig   real    shadlen                 namelist,physics      1            25000.    -     "shadow_length" "maximum length of orographic shadow" "m"
+rconfig   integer slope_rad               namelist,physics      max_domains    0       -     "slope_rad"  "1: use slope-dependent radiation, 0:not" ""
+rconfig   integer topo_shading            namelist,physics      max_domains    0       -     "topo_shading" "1: apply topographic shading to radiation, 0:not" ""
+rconfig   integer no_mp_heating           namelist,physics      1              0       -     "no_mp_heating" "switch to turn of latent heating in mp schemes"   ""
+rconfig   integer fractional_seaice       namelist,physics      1              0       -     "fractional_seaice" "Fractional sea-ice option"
+rconfig   logical tice2tsk_if2cold        namelist,physics      1              .false. -     "tice2tsk_if2cold" "Avoid low ice temps when ice frac and Tsk are inconsistent"
+rconfig   real    bucket_mm               namelist,physics      1             -1.      h     "bucket_mm" "bucket reset value for water accumulations -1: inactive"   ""
+rconfig   real    bucket_J                namelist,physics      1             -1.      h     "bucket_J"  "bucket reset value for energy accumulations -1: inactive"   ""
+rconfig   real    mp_tend_lim             namelist,physics      1             10.      -     "mp_tend_lim" "limit on temp tendency from mp latent heating"   "K/s"
+rconfig   real    prec_acc_dt             namelist,physics      max_domains    0.      h     "prec_acc_dt" "bucket reset time interval between outputs for cumulus or grid scale precipitation"   "minutes"
+rconfig   integer prec_acc_opt            derived               1              0       -     "prec_acc_opt" "option to output precip in a time window"          ""
+rconfig   integer bucketr_opt             derived               1              0       -     "bucketr_opt"  "option to output water accum based on bucket_mm"          ""
+
+rconfig   integer grav_settling           namelist,physics      max_domains  0         h    "grav_settling"     "activate gravitationalsettling of fog  0=no, 1=yes"
+
+#FDDA namelist parameters
+rconfig   real    FGDT                    namelist,fdda         max_domains    0       h        "FGDT"          ""      ""
+rconfig   integer  FGDTZERO               namelist,fdda         max_domains    0       rh       "FGDTZERO"             ""      ""
+rconfig   integer  grid_fdda              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   integer  grid_sfdda             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_ph   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_ph             namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   integer   k_zfac_ph             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   integer  dk_zfac_uv             namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   integer  dk_zfac_t              namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   integer  dk_zfac_ph             namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   real        guv                 namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        guv_sfc             namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gt                  namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gt_sfc              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gq                  namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gq_sfc              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gph                 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"            ""      ""
+rconfig   real    rinblw                  namelist,fdda         1              0       h        "grid_fdda"            ""      ""
+rconfig   integer xwavenum                namelist,fdda         max_domains    0       rh       "grid_fdda"            "top wave number to nudge in x direction"      "" 
+rconfig   integer ywavenum                namelist,fdda         max_domains    0       rh       "grid_fdda"            "top wave number to nudge in y direction"      ""
+rconfig   integer pxlsm_soil_nudge        namelist,fdda         max_domains    0       rh       "pxlsm_soil_nudge"     "nudge pxlsm soil"      ""
+
+#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   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   integer     obs_no_pbl_nudge_uv namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_uv" "1=no wind-nudging within pbl"          ""
+rconfig   integer     obs_no_pbl_nudge_t  namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_t"  "1=no temperature-nudging within pbl"   ""
+rconfig   integer     obs_no_pbl_nudge_q  namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_q"  "1=no moisture-nudging within pbl"      ""
+rconfig   integer     obs_sfc_scheme_horiz namelist,fdda           1              0       rh       "obs_sfcscheme_horiz" "0=wrf scheme, 1=original mm5 scheme" ""
+rconfig   integer     obs_sfc_scheme_vert  namelist,fdda           1              0       rh       "obs_sfcscheme_vert"  "0=regime vif scheme, 1=original simple scheme" ""
+rconfig   real        obs_max_sndng_gap   namelist,fdda            1              20      rh       "obs_max_sndng_gap"   "Max press gap between soundings" "centibars"
+rconfig   real        obs_nudgezfullr1_uv namelist,fdda            1              50      rh       "obs_nudgezfullr1_uv" "Vert infl full weight  height for LML obs, regime 1, winds"        ""
+rconfig   real        obs_nudgezrampr1_uv namelist,fdda            1              50      rh       "obs_nudgezrampr1_uv" "Vert infl ramp-to-zero height for LML obs, regime 1, winds"        ""
+rconfig   real        obs_nudgezfullr2_uv namelist,fdda            1              50      rh       "obs_nudgezfullr2_uv" "Vert infl full weight  height for LML obs, regime 2, winds"        ""
+rconfig   real        obs_nudgezrampr2_uv namelist,fdda            1              50      rh       "obs_nudgezrampr2_uv" "Vert infl ramp-to-zero height for LML obs, regime 2, winds"        ""
+rconfig   real        obs_nudgezfullr4_uv namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_uv" "Vert infl full weight  height for LML obs, regime 4, winds"        ""
+rconfig   real        obs_nudgezrampr4_uv namelist,fdda            1              50      rh       "obs_nudgezrampr4_uv" "Vert infl ramp-to-zero height for LML obs, regime 4, winds"        ""
+rconfig   real        obs_nudgezfullr1_t  namelist,fdda            1              50      rh       "obs_nudgezfullr1_t" "Vert infl full weight  height for LML obs, regime 1, temperature"  ""
+rconfig   real        obs_nudgezrampr1_t  namelist,fdda            1              50      rh       "obs_nudgezrampr1_t" "Vert infl ramp-to-zero height for LML obs, regime 1, temperature"  ""
+rconfig   real        obs_nudgezfullr2_t  namelist,fdda            1              50      rh       "obs_nudgezfullr2_t" "Vert infl full weight  height for LML obs, regime 2, temperature"  ""
+rconfig   real        obs_nudgezrampr2_t  namelist,fdda            1              50      rh       "obs_nudgezrampr2_t" "Vert infl ramp-to-zero height for LML obs, regime 2, temperature"  ""
+rconfig   real        obs_nudgezfullr4_t  namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_t" "Vert infl full weight  height for LML obs, regime 4, temperature"  ""
+rconfig   real        obs_nudgezrampr4_t  namelist,fdda            1              50      rh       "obs_nudgezrampr4_t" "Vert infl ramp-to-zero height for LML obs, regime 4, temperature"  ""
+rconfig   real        obs_nudgezfullr1_q  namelist,fdda            1              50      rh       "obs_nudgezfullr1_q" "Vert infl full weight  height for LML obs, regime 1, moisture"     ""
+rconfig   real        obs_nudgezrampr1_q  namelist,fdda            1              50      rh       "obs_nudgezrampr1_q" "Vert infl ramp-to-zero height for LML obs, regime 1, moisture"     ""
+rconfig   real        obs_nudgezfullr2_q  namelist,fdda            1              50      rh       "obs_nudgezfullr2_q" "Vert infl full weight  height for LML obs, regime 2, moisture"     ""
+rconfig   real        obs_nudgezrampr2_q  namelist,fdda            1              50      rh       "obs_nudgezrampr2_q" "Vert infl ramp-to-zero height for LML obs, regime 2, moisture"     ""
+rconfig   real        obs_nudgezfullr4_q  namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_q" "Vert infl full weight  height for LML obs, regime 4, moisture"     ""
+rconfig   real        obs_nudgezrampr4_q  namelist,fdda            1              50      rh       "obs_nudgezrampr4_q" "Vert infl ramp-to-zero height for LML obs, regime 4, moisture"     ""
+rconfig   real        obs_nudgezfullmin   namelist,fdda            1                 50   rh       "obs_nudgezfullmin" "Minimum depth through which vertical influence fcn remains 1.0"     "m"
+rconfig   real        obs_nudgezrampmin   namelist,fdda            1                 50   rh       "obs_nudgezrampmin" "Minimum depth through which vertical influence fcn decreases from 1.0 to 0.0" "m"
+rconfig   real        obs_nudgezmax       namelist,fdda            1               3000   rh       "obs_nudgezmax" "Maximum depth in which vertical influence function is nonzero" "m"
+rconfig   real        obs_sfcfact         namelist,fdda            1              1.0     h        "obs_sfcfact"       "Scale factor applied to time window for surface obs"     ""
+rconfig   real        obs_sfcfacr         namelist,fdda            1              1.0     h        "obs_sfcfacr"       "Scale factor applied to horiz radius of influence for surface obs"     ""
+rconfig   real        obs_dpsmx           namelist,fdda            1              7.5     h        "obs_dpsmx"         "Max pressure change allowed within horiz radius of influence"     "centibars"
+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            max_domains    0       rh       "obs_twindo"        "Half-period time window for nudging"  "hrs"
+rconfig   integer     obs_npfi            namelist,fdda            1              0       h        "obs_npfi"          "Freq in cg timesteps for diag print"  ""
+rconfig   integer     obs_ionf            namelist,fdda            max_domains    1       rh       "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   integer     obs_prt_max         namelist,fdda            1              1000    rh       "obs_prt_max"       "Maximum allowed obs entries in diagnostic printout"      ""
+rconfig   integer     obs_prt_freq        namelist,fdda            max_domains    1000    rh       "obs_prt_freq"      "Frequency in obs index for diagnostic printout."   ""
+rconfig   logical     obs_ipf_in4dob      namelist,fdda            1              .false. h        "obs_ipf_in4dob"    "Print obs input diagnostics"   ""
+rconfig   logical     obs_ipf_errob       namelist,fdda            1              .false. h        "obs_ipf_errob"     "Print obs error diagnostics"   ""
+rconfig   logical     obs_ipf_nudob       namelist,fdda            1              .false. h        "obs_ipf_nudob"     "Print obs nudge diagnostics"   ""
+rconfig   logical     obs_ipf_init        namelist,fdda            1              .true.  h        "obs_ipf_init"      "Enable obs init warning messages"   ""
+
+# Single-column model (SCM)
+rconfig   integer scm_force               namelist,scm  1       0           rh   "scm_force"            "SCM forcing switch" ""
+rconfig   real    scm_force_dx            namelist,scm  1       4000.       rh   "scm_force_dx"         "DX for SCM forcing" "m"
+rconfig   integer num_force_layers        namelist,scm  1       8           rh   "num_force_layers"     "Number of SCM forcing layers" ""
+rconfig   integer scm_lu_index            namelist,scm  1       2           rh   "scm_lu_index"         "SCM landuse index" ""
+rconfig   integer scm_isltyp              namelist,scm  1       4           rh   "scm_isltyp"           "SCM soil category" ""
+rconfig   real    scm_vegfra              namelist,scm  1       0.5         rh   "scm_vegfra"           "SCM vegetation fraction" ""
+rconfig   integer scm_canwat              namelist,scm  1       0.0         rh   "scm_canwat"           "SCM canopy water" "kg m-2"
+rconfig   real    scm_lat                 namelist,scm  1        36.605     rh   "scm_lat"              "SCM latitude" "degrees"
+rconfig   real    scm_lon                 namelist,scm  1       -97.485     rh   "scm_lon"              "SCM longitude" "degrees"
+rconfig   logical scm_th_adv              namelist,scm  1       .true.      rh   "scm_th_adv"           "Turn on theta advection in SCM"      ""
+rconfig   logical scm_wind_adv            namelist,scm  1       .true.      rh   "scm_wind_adv"         "Turn on wind advection in SCM"      ""
+rconfig   logical scm_qv_adv              namelist,scm  1       .true.      rh   "scm_qv_adv"           "Turn on qv advection in SCM"      ""
+rconfig   logical scm_ql_adv              namelist,scm  1       .false.     rh   "scm_ql_adv"           "Turn on ql advection in SCM"      ""
+rconfig   logical scm_vert_adv            namelist,scm  1       .true.      rh   "scm_vert_adv"         "Turn on vertical advection in SCM"      ""
+rconfig   integer num_force_soil_layers   namelist,scm  1       5           rh   "num_force_soil_layers" "Number of SCM soil forcing layers" ""
+rconfig   logical scm_soilT_force         namelist,scm  1       .false.     rh   "scm_soilT_force"      "Turn on soil temp forcing in SCM"      ""
+rconfig   logical scm_soilq_force         namelist,scm  1       .false.     rh   "scm_soilq_force"      "Turn on soil moisture forcing in SCM"      ""
+rconfig   logical scm_force_th_largescale namelist,scm  1       .false.     rh   "scm_force_th_largescale" "Turn on large scale theta forcing in SCM"      ""
+rconfig   logical scm_force_qv_largescale namelist,scm  1       .false.     rh   "scm_force_qv_largescale" "Turn on large scale qv forcing in SCM"      ""
+rconfig   logical scm_force_ql_largescale namelist,scm  1       .false.     rh   "scm_force_ql_largescale" "Turn on large scale ql forcing in SCM"      ""
+rconfig   logical scm_force_wind_largescale namelist,scm  1     .false.     rh   "scm_force_wind_largescale" "Turn on large scale wind forcing in SCM"      ""
+
+# Dynamics
+# dynamics option (see package definitions, below)
+rconfig   integer dyn_opt                 namelist,dynamics	1             2 
+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"                ""      ""
+# km_opt_dfi is needed for backward integration in dfi
+rconfig   integer km_opt_dfi              namelist,dynamics	1             1       irh    "km_opt_dfi"                ""      ""
+rconfig   integer damp_opt                namelist,dynamics	1             0       irh    "damp_opt"              ""      ""
+rconfig   integer rad_nudge               namelist,dynamics	1             0       irh    "rad_nudge"             ""      ""
+rconfig   integer gwd_opt                 namelist,dynamics     1             0       irh    "gwd_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    c_s                     namelist,dynamics	max_domains    0.25    h    "c_s"         "Smagorinsky coeff"      ""
+rconfig   real    c_k                     namelist,dynamics	max_domains    0.15    h    "c_k"         "TKE coeff"      ""
+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   integer  moist_adv_opt          namelist,dynamics	max_domains    1       rh    "moist_adv_opt"         "positive-definite RK3 transport switch"      ""
+rconfig   integer  moist_adv_dfi_opt      namelist,dynamics	max_domains    0       rh    "moist_adv_dfi_opt"    "positive-definite RK3 transport switch"      ""
+rconfig   integer  chem_adv_opt           namelist,dynamics	max_domains    1       rh    "chem_adv_opt"          "positive-definite RK3 transport switch"      ""
+rconfig   integer  tracer_adv_opt         namelist,dynamics	max_domains    1       rh    "tracer_adv_opt"        "positive-definite RK3 transport switch"      ""
+rconfig   integer  scalar_adv_opt         namelist,dynamics	max_domains    1       rh    "scalar_adv_opt"        "positive-definite RK3 transport switch"      ""
+rconfig   integer  tke_adv_opt            namelist,dynamics	max_domains    1       rh    "tke_adv_opt"           "positive-definite RK3 transport switch"      ""
+rconfig   logical top_radiation           namelist,dynamics	max_domains    .false. rh    "top_radiation"         ""      ""
+rconfig   integer mix_isotropic           namelist,dynamics	max_domains    0       h    "mix_isotropic"            "0=anistropic, 1=isotropic"      ""
+rconfig   real    mix_upper_bound         namelist,dynamics	max_domains    0.1     h    "mix_upper_bound"          "non-dimensional limit"      ""
+rconfig   logical top_lid                 namelist,dynamics     max_domains    .false. rh    "top_lid"               ""      ""
+rconfig   real    tke_upper_bound         namelist,dynamics	max_domains    1000.   h    "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 coriolis2d              namelist,dynamics	max_domains  .false.  irh  "coriolis2d"    ""   ""
+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"
+rconfig   real    iso_temp                namelist,dynamics	1               0.     h    "iso_temp"   "Isothermal temperature in stratosphere, real only"      "K"
+rconfig   logical use_baseparam_fr_nml    namelist,dynamics	1            .false.  irh   "use_baseparam_fr_nml"    ""   ""
+rconfig   real    fft_filter_lat          namelist,dynamics     1              91.     h    "fft_filter_lat"   ""   "grid latitude to start polar filter"
+rconfig   logical rotated_pole            namelist,dynamics     1            .false.  irh   "rotated_pole"    ""   ""
+rconfig   logical do_coriolis             namelist,dynamics	max_domains  .true.   irh  "do_coriolis"    ""   ""
+rconfig   logical do_curvature            namelist,dynamics	max_domains  .true.   irh  "do_curvature"   ""   ""
+rconfig   logical do_gradp                namelist,dynamics	max_domains  .true.   irh  "do_gradp"    ""   ""
+rconfig   integer     tracer_opt          namelist,dynamics     max_domains    0       rh    "tracer_opt"          ""      ""
+# Placeholder for decoupled advective tendency diagnostics
+rconfig   integer tenddiag                namelist,dynamics     max_domains    0       -     "Decoupled tendency diagnostics"   ""    ""
+
+# 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 constant_bc             namelist,bdy_control          1      .false. rh    "constant_bc"           ""      ""
+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 polar                   namelist,bdy_control	max_domains    .false. rh    "polar"                 ""      ""
+rconfig   logical nested                  namelist,bdy_control	max_domains    .false. rh    "nested"                ""      ""
+rconfig   real    spec_exp                namelist,bdy_control          1     0.      irh    "spec_exp"              ""      ""
+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   integer nobs_ndg_vars           derived                       1         6       -        "num_ndg_vars"         "Number of nudging variables"          ""
+rconfig   integer nobs_err_flds           derived                       1         9       -        "num_err_flds"         "Number of error fields"               ""
+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    pole_lat                derived                  max_domains    0       -        "pole_lat"              "projection info: latitude of pole" "degrees, positive north"
+rconfig   real    pole_lon                derived                  max_domains    0       -        "pole_lon"              "projection info: longitude of pole" "degrees, positive east"
+rconfig   integer  FLAG_METGRID           derived                      1          0       -        "FLAG_METGRID"         "Flag in global attributes for metgrid data"
+rconfig   integer  FLAG_SNOW              derived                      1          0       -        "FLAG_SNOW"             "Flag for snow in the global attributes for metgrid data"
+rconfig   integer  FLAG_PSFC              derived                      1          0       -        "FLAG_PSFC"             "Flag for surface pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM000010          derived                      1          0       -        "FLAG_SM000010"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM010040          derived                      1          0       -        "FLAG_SM010040"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM040100          derived                      1          0       -        "FLAG_SM040100"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM100200          derived                      1          0       -        "FLAG_SM100200"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST000010          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST010040          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST040100          derived                      1          0       -        "FLAG_ST010040"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST100200          derived                      1          0       -        "FLAG_ST100200"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_SLP               derived                      1          0       -        "FLAG_SLP"              "Flag for sea level pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SOILHGT           derived                      1          0       -        "FLAG_SOILHGT"          "Flag for soil height in the global attributes for metgrid data"
+rconfig   integer  FLAG_MF_XY             derived                      1          0       -        "FLAG_MF_XY"            "Flag for MF_XYin the global attributes for metgrid data"
+rconfig   real    bdyfrq                  derived                  max_domains    0       -        "bdyfrq"               "lateral boundary input frequency"      "seconds"
+rconfig   character mminlu                derived                  max_domains    " "     -        "mminlu"               "land use dataset"             ""
+rconfig   integer iswater                 derived                  max_domains    0       -        "iswater"              "land use index of water"      "index category"
+rconfig   integer islake                  derived                  max_domains    0       -        "islake"               "land use index of inland lake"      "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 (Cylindrical), 1=Lambert, 2=polar, 3=Mercator"
+rconfig   integer use_wps_input           derived                       1         0       -        "use_wps_input"        "0/1 flag, using wps input"      "0=no, 1=yes"
+rconfig   integer dfi_stage               derived                  max_domains    3       -        "dfi_stage"            "current stage of DFI processing"      "0=DFI setup, 1=DFI backward integration, 2=DFI forward integration, 3=WRF forecast"
+rconfig   integer mp_physics_dfi          derived                  max_domains   -1       -        "mp_physics_dfi"       ""      "-1 = no DFI and so no need to allocate DFI moist and scalar variables, >0 = running with DFI, so allocate DFI moist and scalar variables appropriate for selected microphysics package"
+
+#
+# Single dummy declaration to define a nodyn dyn option
+state integer nodyn_dummy - dyn_nodyn -  -  -  "" "" ""      
+
+# Turbine drag (td) physics
+# Turbine positions and characteristics for real-data cases are specified in a file 
+# whose name is given in the windturbines_spec variable.  If the setting is "ideal",
+# the td_ variables specify idealized wind farm geometries and turbine characteristics.
+# If the setting is "none" then wind turbine drag physics is turned off.
+rconfig character windturbines_spec namelist,physics 1 "none" - - "" "none, ideal, or a file name"
+rconfig integer td_turbgridid  namelist,physics 1 -1     - - ""  "which grid id has turbines in it"
+rconfig  real   td_hubheight   namelist,physics 1 100.   - - ""  "hub height (m)"
+rconfig  real   td_diameter    namelist,physics 1 60.    - - ""  "turbine diameter (m)"
+rconfig  real   td_stdthrcoef  namelist,physics 1 .158   - - ""  "standing thrust coefficient"
+rconfig  real   td_cutinspeed  namelist,physics 1 4.     - - ""  "cut-in speed (m/s)"
+rconfig  real   td_cutoutspeed namelist,physics 1 27.    - - ""  "cut-out speed (m/s)"
+rconfig  real   td_power       namelist,physics 1 2.     - - ""  "turbine power (MW)"
+rconfig  real   td_turbpercell namelist,physics 1 1.     - - ""  "number of turbines per cell"
+rconfig integer td_ewfx        namelist,physics 1 0      - - ""  "extent of wind farm in x-cells"
+rconfig integer td_ewfy        namelist,physics 1 0      - - ""  "extent of wind farm in y-cells"
+rconfig integer td_pwfx        namelist,physics 1 1      - - ""  "southwest corner of wind farm in x-cells"
+rconfig integer td_pwfy        namelist,physics 1 1      - - ""  "southwest corner of wind farm in y-cells"
+
+#
+#---------------------------------------------------------------------------------------------------------------------------------------
+# Package Declarations
+#                                               
+
+#key      package       associated                package          associated 4d scalars
+#         name          namelist choice           state vars
+
+#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;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy
+package   wsm6scheme    mp_physics==6                -             moist:qv,qc,qr,qi,qs,qg
+package   gsfcgcescheme mp_physics==7                -             moist:qv,qc,qr,qi,qs,qg
+package   thompson      mp_physics==8                -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr
+package   milbrandt2mom mp_physics==9                -             state:refl_10cm;moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh
+package   morr_two_moment  mp_physics==10            -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng
+#package   milbrandt3mom mp_physics==12               -             moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qzr,qzi,qzs,qzg,qzh
+package   sbu_ylinscheme    mp_physics==13           -             moist:qv,qc,qr,qi,qs;state:rimi
+package   wdm5scheme    mp_physics==14               -             moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr
+package   wdm6scheme    mp_physics==16               -             moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr
+
+package   nodfimoist        mp_physics_dfi==-1       -             -
+package   passiveqv_dfi     mp_physics_dfi==0        -             dfi_moist:dfi_qv
+package   kesslerscheme_dfi mp_physics_dfi==1        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   linscheme_dfi     mp_physics_dfi==2        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   wsm3scheme_dfi    mp_physics_dfi==3        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   wsm5scheme_dfi    mp_physics_dfi==4        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs
+package   etampnew_dfi      mp_physics_dfi==5        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt
+package   wsm6scheme_dfi    mp_physics_dfi==6        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   gsfcgcescheme_dfi mp_physics_dfi==7        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   thompson_dfi      mp_physics_dfi==8        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr
+package   milbrandt2mom_dfi mp_physics_dfi==9        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh
+package   morr_two_moment_dfi  mp_physics_dfi==10    -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng
+#package   milbrandt3mom_dfi mp_physics_dfi==12       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qzr,dfi_qzi,dfi_qzs,dfi_qzg,dfi_qzh
+package   wdm5scheme_dfi    mp_physics_dfi==14       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+package   wdm6scheme_dfi    mp_physics_dfi==16       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+
+package   noprogn       progn==0                     -             -
+package   progndrop     progn==1                     -             scalar:qndrop;dfi_scalar:dfi_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;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   rrtmg_lwscheme  ra_lw_physics==4           -             state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   goddardlwscheme  ra_lw_physics==5          -             state:tlwdn,tlwup,slwdn,slwup
+package   gfdllwscheme  ra_lw_physics==99            -             -
+package   heldsuarez    ra_lw_physics==31            -             -
+
+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;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   rrtmg_swscheme  ra_sw_physics==4           -             state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc
+package   goddardswscheme  ra_sw_physics==5          -             state:tswdn,tswup,sswdn,sswup
+package   gfdlswscheme  ra_sw_physics==99            -             -
+
+package   sfclayscheme   sf_sfclay_physics==1        -             -
+package   myjsfcscheme   sf_sfclay_physics==2        -             state:tke_pbl
+package   gfssfcscheme   sf_sfclay_physics==3        -             -
+package   qnsesfcscheme  sf_sfclay_physics==4        -             -
+package   mynnsfcscheme  sf_sfclay_physics==5        -             scalar:qke;state:tsq,qsq,cov
+package   pxsfcscheme    sf_sfclay_physics==7        -             -
+
+package   noahucmscheme  sf_urban_physics==1         -             state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep
+package   bepscheme      sf_urban_physics==2         -             state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d
+package   bep_bemscheme  sf_urban_physics==3         -             state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,sfwin1_urb3d,sfwin2_urb3d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d
+
+package   slabscheme     sf_surface_physics==1       -             -
+package   lsmscheme      sf_surface_physics==2       -             -
+package   ruclsmscheme   sf_surface_physics==3       -             state:smfr3d,keepfr3dflag,soilt1
+package   pxlsmscheme    sf_surface_physics==7       -             state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old
+package   temfsfcscheme  sf_sfclay_physics==10       -             state:wm_temf
+package   idealscmsfcscheme  sf_sfclay_physics==89   -             -
+
+package   ysuscheme      bl_pbl_physics==1           -             -
+package   myjpblscheme   bl_pbl_physics==2           -             state:tke_pbl,el_pbl
+package   gfsscheme      bl_pbl_physics==3           -             -
+package   qnsepblscheme  bl_pbl_physics==4           -             state:tke_pbl,el_pbl
+package   mynnpblscheme2 bl_pbl_physics==5           -             scalar:qke;state:tsq,qsq,cov
+package   mynnpblscheme3 bl_pbl_physics==6           -             scalar:qke;state:tsq,qsq,cov
+package   acmpblscheme   bl_pbl_physics==7           -             -
+package   boulacscheme   bl_pbl_physics==8           -             state:el_pbl,tke_pbl,wu_tur,wv_tur,wt_tur,wq_tur
+package   camuwpblscheme bl_pbl_physics==9           -             state:tauresx2d,tauresy2d,qpert2d,wpert2d,tke_pbl
+package   mrfscheme      bl_pbl_physics==99          -             -
+package   temfpblscheme  bl_pbl_physics==10          -             state:te_temf,kh_temf,km_temf,shf_temf,qf_temf,uw_temf,vw_temf,wupd_temf,mf_temf,thup_temf,qlup_temf,qtup_temf,cf3d_temf,hd_temf,lcl_temf,hct_temf,cfm_temf
+
+package   kfetascheme    cu_physics==1               -             -
+package   bmjscheme      cu_physics==2               -             -
+package   gdscheme       cu_physics==3               -             -
+package   sasscheme      cu_physics==4               -             -
+package   g3scheme       cu_physics==5               -             state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow
+package   camzmscheme    cu_physics==7               -             state:precz,zmdt,zmdq,zmdice,zmdliq,evaptzm,fzsntzm,evsntzm,evapqzm,zmflxprc,zmflxsnw,zmntprpd,zmntsnpd,zmeiheat,cmfmc,cmfmcdzm,preccdzm,pconvb,pconvt,cape,zmmtu,zmmtv,zmmu,zmmd,zmupgu,zmupgd,zmvpgu,zmvpgd,zmicuu,zmicud,zmicvu,zmicvd
+package   g3tave         cu_diag==1                  -             state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,RAINCV_A,RAINCV_B,GD_CLOUD_A,GD_CLOUD_B,GD_CLOUD2_A,GD_CLOUD2_B,kbcon_deep,ktop_deep,k22_deep
+package   tiedtkescheme  cu_physics==6               -             -
+package   nsasscheme     cu_physics==14              -             -
+package   kfscheme       cu_physics==99              -             -
+
+package   g3shcuscheme   shcu_physics==1             -             -
+package   camuwshcuscheme shcu_physics==2            -             state:cmfmc,cmfmc2,qtflx_cu,slflx_cu,uflx_cu,vflx_cu,qtten_cu,slten_cu,uten_cu,vten_cu,qvten_cu,qlten_cu,qiten_cu,cbmf_cu,ufrcinvbase_cu,ufrclcl_cu,winvbase_cu,wlcl_cu,plcl_cu,pinv_cu,plfc_cu,pbup_cu,ppen_cu,qtsrc_cu,thlsrc_cu,thvlsrc_cu,emkfbup_cu,cin_cu,cinlcl_cu,cbmflimit_cu,tkeavg_cu,zinv_cu,rcwp_cu,rlwp_cu,riwp_cu,tophgt_cu,wu_cu,ufrc_cu,qtu_cu,thlu_cu,thvu_cu,uu_cu,vu_cu,qtu_emf_cu,thlu_emf_cu,uu_emf_cu,vu_emf_cu,umf_cu,uemf_cu,qcu_cu,qlu_cu,qiu_cu,cufrc_cu,fer_cu,fdr_cu,dwten_cu,diten_cu,qrten_cu,qsten_cu,flxrain_cu,flxsnow_cu,ntraprd_cu,ntsnprd_cu,excessu_cu,excessu0_cu,xc_cu,aquad_cu,bquad_cu,cquad_cu,bogbot_cu,bogtop_cu,exit_uwcu_cu,exit_conden_cu,exit_klclmkx_cu,exit_klfcmkx_cu,exit_ufrc_cu,exit_wtw_cu,exit_drycore_cu,exit_wu_cu,exit_cufliter_cu,exit_kinv1_cu,exit_rei_cu,limit_shcu_cu,limit_negcon_cu,limit_ufrc_cu,limit_ppen_cu,limit_emf_cu,limit_cinlcl_cu,limit_cin_cu,limit_cbmf_cu,limit_rei_cu,ind_delcin_cu,evapcsh,cmfsl,cmflq,cldfrash,cush,icwmrsh,snowsh,rprdsh,rliq2
+
+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;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten
+package   psusfddagd     grid_sfdda==1               -             state:u10_ndg_old,v10_ndg_old,t2_ndg_old,th2_ndg_old,q2_ndg_old,rh_ndg_old,psl_ndg_old,ps_ndg_old,u10_ndg_new,v10_ndg_new,t2_ndg_new,th2_ndg_new,q2_ndg_new,rh_ndg_new,psl_ndg_new,ps_ndg_new,tob_ndg_old,odis_ndg_old,tob_ndg_new,odis_ndg_new
+
+package   spnudging      grid_fdda==2               -              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;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten
+
+package   slopeopt       slope_rad==1               -              -
+package   gwdopt         gwd_opt==1                 -              state:var2d,oc12d,oa1,oa2,oa3,oa4,ol1,ol2,ol3,ol4,dtaux3d,dtauy3d,dusfcg,dvsfcg
+package   omlopt         omlcall==1                 -              state:tml,t0ml,hml,h0ml,huml,hvml,tmoml
+package   scmopt         scm_force==1               -              state:z_force,z_force_tend,u_g,u_g_tend,v_g,v_g_tend,w_subs,w_subs_tend,th_upstream_x,th_upstream_x_tend,th_upstream_y,th_upstream_y_tend,qv_upstream_x,qv_upstream_x_tend,qv_upstream_y,qv_upstream_y_tend,u_upstream_x,u_upstream_x_tend,u_upstream_y,u_upstream_y_tend,v_upstream_x,v_upstream_x_tend,v_upstream_y,v_upstream_y_tend,tau_x,tau_x_tend,tau_y,tau_y_tend,th_largescale,th_largescale_tend,qv_largescale,qv_largescale_tend,ql_largescale,ql_largescale_tend,u_largescale,u_largescale_tend,v_largescale,v_largescale_tend,tau_largescale,tau_largescale_tend,ql_upstream_x,ql_upstream_x_tend,ql_upstream_y,ql_upstream_y_tend,t_soil_forcing_val,t_soil_forcing_tend,q_soil_forcing_val,q_soil_forcing_tend,tau_soil,soil_depth_force
+
+package   prec_acc       prec_acc_opt==1            -              state:prec_acc_c,prec_acc_nc,snow_acc_nc
+package   bucketropt     bucketr_opt==1             -              state:i_rainc,i_rainnc
+
+package   restofwrf      use_wps_input==0            -             -
+
+package   original         moist_adv_opt==0            -             -
+package   positivedef    moist_adv_opt==1            -             -
+package   monotonic      moist_adv_opt==2            -             -
+package   tracer_test1  tracer_opt==2       -             tracer:tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8
+
+package   dfi_setup      dfi_stage==0                -             -
+package   dfi_bck        dfi_stage==1                -             -
+package   dfi_fwd        dfi_stage==2                -             -
+package   dfi_fst        dfi_stage==3                -             -
+package   dfi_startfwd   dfi_stage==4                -             -
+package   dfi_startbck   dfi_stage==5                -             -
+
+#package   digifilter     dfi_opt==1                  -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_rh,dfi_tten_rad
+package   dfi_nodfi     dfi_opt==0                  -             -
+package   dfi_dfl       dfi_opt==1                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   dfi_ddfi      dfi_opt==2                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   dfi_tdfi      dfi_opt==3                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   realonly       use_wps_input==1            -             state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc
+
+
+# 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                     -             -
+             
+# Tendency diagnostics for non-chemistry
+#
+# Placeholders for decoupled advective tendency arrays
+package   notenddiag    tenddiag==0                     -             -
+package   usetenddiag   tenddiag==1                     -             -
+                                   
+#---------------------------------------------------------------------------------------------------------------------------------------
+## 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,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,f,e,sina,cosa,ht,potevp,snopcx,soiltb,xlat,xlong,xlat_u,xlat_v,xlong_u,xlong_v,clat,clong
+halo      HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar,tracer
+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_PHYS_CU dyn_em         4:rucuten,rvcuten
+halo      HALO_EM_PHYS_SHCU dyn_em       4:rushten,rvshten
+halo      HALO_EM_FDDA dyn_em            4:rundgdten,rvndgdten
+halo      HALO_EM_FDDA_SFC dyn_em 48:z,z_at_w,pblh,regime,znt,odis_ndg_old,odis_ndg_new
+halo      HALO_EM_PHYS_DIFFUSION dyn_em  4:defor11,defor22,defor12,defor13,defor23,div,xkmv,xkmh,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,ustm
+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,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,muts
+halo      HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,tracer,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,tracer,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,tracer,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,tracer,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_CUP_G3_IN dyn_em 24:RTHFTEN,RQVFTEN,w_2,t_phy
+halo      HALO_CUP_G3_OUT dyn_em 48:cugd_tten,cugd_qvten,cugd_ttens,cugd_qvtens,raincv
+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_TRACER_E_3 dyn_em 24:tracer
+halo      HALO_EM_TRACER_E_5 dyn_em 48:tracer
+halo      HALO_EM_TRACER_E_7 dyn_em 80:tracer
+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_TOPOSHAD phys 24:ht_shad
+
+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_TRACER_OLD_E_3 dyn_em 24:tracer_old
+halo      HALO_EM_TRACER_OLD_E_5 dyn_em 48:tracer_old
+halo      HALO_EM_TRACER_OLD_E_7 dyn_em 80:tracer_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_HYDRO_UV   dyn_em 8:u_2,v_2
+
+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,tracer,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,tracer,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:ph_2,p,uratx,vratx,tratx,kpbl
+
+# 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,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,sina,cosa,e,f
+
+# Monotonic, positive definite advection requires 4 values for moist, chem, tke, and scalar for periodic lateral boundaries
+
+period    PERIOD_BDY_EM_MOIST dyn_em 4:moist
+period    PERIOD_BDY_EM_CHEM dyn_em 4:chem
+period    PERIOD_BDY_EM_TRACER dyn_em 4:tracer
+period    PERIOD_BDY_EM_SCALAR dyn_em 4:scalar
+period    PERIOD_BDY_EM_TKE dyn_em 4:tke_2
+period    PERIOD_BDY_EM_MOIST2 dyn_em 4:moist
+period    PERIOD_BDY_EM_CHEM2 dyn_em 4:chem
+period    PERIOD_BDY_EM_TRACER2 dyn_em 4:tracer
+period    PERIOD_BDY_EM_SCALAR2 dyn_em 4:scalar
+period    PERIOD_BDY_EM_MOIST_OLD dyn_em 4:moist_old
+period    PERIOD_BDY_EM_CHEM_OLD dyn_em 4:chem_old
+period    PERIOD_BDY_EM_TRACER_OLD dyn_em 4:tracer_old
+period    PERIOD_BDY_EM_SCALAR_OLD dyn_em 4:scalar_old
+period    PERIOD_BDY_EM_TKE_OLD dyn_em 4:tke_1
+
+period    PERIOD_BDY_EM_E dyn_em 2:u_2,v_2,ht
+period    PERIOD_EM_HYDRO_UV dyn_em 1:u_2,v_2
+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,ustm
+period    PERIOD_BDY_EM_PHY_BC dyn_em 2:rublten,rvblten,rucuten,rvcuten,xkmh,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,msfvx,msfvy,muu,msfux,msfuy,msfvx_inv
+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
+period    PERIOD_EM_DA dyn_em 2:ru_m,rv_m,ww_m,mut,muts
+
+#
+#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 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 NSTAW        # number of obs stations within current time window
+typedef fdob_type integer KTAUR        # restart model step
+typedef fdob_type integer LEVIDN(max_domains)   # level of nest
+typedef fdob_type integer REFPRT(max_domains)   # reference obs index for diagnostic printout
+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 logical NUDGE_UV_PBL # Flag for wind nudging within the PBL
+typedef fdob_type logical NUDGE_T_PBL  # Flag for temperature nudging within the PBL
+typedef fdob_type logical NUDGE_Q_PBL  # Flag for moisture nudging within the PBL
+typedef fdob_type integer SFC_SCHEME_HORIZ # Flag for horizontal spreading scheme for surface obs
+typedef fdob_type integer SFC_SCHEME_VERT  # Flag for vertical   spreading scheme for surface obs
+typedef fdob_type real    MAX_SNDNG_GAP # Maximum pressure gap allowed for interpolating between soundings (centibars)
+typedef fdob_type real    SFCFACT      # scale factor applied to time window for surface obs
+typedef fdob_type real    SFCFACR      # scale factor applied to horiz radius of influence for surface obs
+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    KNOWN_LAT    # Latitude  of origin point (i,j)=(1,1)
+typedef fdob_type real    KNOWN_LON    # Longitude of origin point (i,j)=(1,1)
+typedef fdob_type character SDATE      # domain starting date (YYYY-MM-DD_hh:mm:ss)
+typedef fdob_type real    XTIME_AT_REST # xtime at restart time
+typedef fdob_type real    VIF_UV(6)    # Vertical influence function parameters for wind nudging
+typedef fdob_type real    VIF_T(6)     # Vertical influence function parameters for temperature nudging
+typedef fdob_type real    VIF_Q(6)     # Vertical influence function parameters for moisture nudging
+typedef fdob_type real    VIF_FULLMIN  # Minimum depth through which vert infl fcn remains 1.0 (m)
+typedef fdob_type real    VIF_RAMPMIN  # Minimum depth through which vif decreases 1.0 to 0.0 (m)
+typedef fdob_type real    VIF_MAX      # Maximum depth in which vif is nonzero (m)
+
+# table entries are of the form
+#      <Table>  <Type>  <Sym>                <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>
+#Grid variables
+typedef fdob_type real    varobs         {nndgvar}{obs} -         1        -       -       "varobs"          "observational values in each variable"
+typedef fdob_type real    errf              h{obs}      -         1        -       -       "errf"            "errors between model and obs values"
+typedef fdob_type real    timeob             {obs}      -         1        -       -       "timeob"          "model times for each observation"          "hours"
+typedef fdob_type real    nlevs_ob           {obs}      -         1        -       -       "nlevs_ob"        "numbers of levels in sounding obs"
+typedef fdob_type real    lev_in_ob          {obs}      -         1        -       -       "lev_in_ob"       "level in sounding-type obs"
+typedef fdob_type real    plfo               {obs}      -         1        -       -       "plfo"            "index for type of obs-platform"
+typedef fdob_type real    elevob             {obs}      -         1        -       -       "elevob"          "elevation of observation"                  "meters"
+typedef fdob_type real    rio                {obs}      -         1        -       -       "rio"             "west-east grid coordinate"
+typedef fdob_type real    rjo                {obs}      -         1        -       -       "rjo"             "south-north grid coordinate"
+typedef fdob_type real    rko                {obs}      -         1        -       -       "rko"             "vertical grid coordinate"
+typedef fdob_type integer obsprt               [        -         1        -       -       "obsprt"          "obs index for diagnostic printout"
+typedef fdob_type real    latprt               [        -         1        -       -       "latprt"          "obs latitude for diagnostic printout"
+typedef fdob_type real    lonprt               [        -         1        -       -       "lonprt"          "obs longitude for diagnostic printout"
+typedef fdob_type real    mlatprt              [        -         1        -       -       "mlatprt"         "model latitude at obs location"
+typedef fdob_type real    mlonprt              [        -         1        -       -       "mlonprt"         "model longitude at obs location"
+typedef fdob_type integer stnidprt       {obsstid}{[}   -         1        -       -       "stnidprt"        "obs station id for diagnostic printout"
+typedef fdob_type real    base_state           k        -         1        -       -       "base_state"      "base-state height on half (mass) levels"   "meters"
+
+state fdob_type fdob - -
+
+# xpose variables for polar fft
+state    real   t_xxx          ikjx    -           1        -
+state    real   u_xxx          ikjx    -           1        X
+state    real   ru_xxx         ikjx    -           1        X
+state    real   v_xxx          ikjx    -           1        Y
+state    real   rv_xxx         ikjx    -           1        Y
+state    real   w_xxx          ikjx    -           1        Z
+state    real   ww_xxx         ikjx    -           1        Z
+state    real   ph_xxx         ikjx    -           1        Z
+state    real   dum_yyy        ikjy    -           1        -
+state    real   fourd_xxx      ikjx    -           1        -
+state    real   clat_xxx       ijx     -           1        -
+state    real   ht_xxx         ijx     -           1        -
+state    real   mf_xxx         ijx     -           1        -
+
+xpose XPOSE_POLAR_FILTER_TOPO dyn_em t_init,t_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_T  dyn_em t_2,t_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_U  dyn_em u_2,u_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_RU dyn_em ru_m,ru_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_V  dyn_em v_2,v_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_RV dyn_em rv_m,rv_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_W  dyn_em w_2,w_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_WW dyn_em ww_m,ww_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_PH dyn_em ph_2,ph_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_MOIST dyn_em moist,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_CHEM dyn_em chem,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_TRACER dyn_em tracer,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_SCALAR dyn_em scalar,fourd_xxx,dum_yyy
+
+# xpose variables for spectral nudging
+state    real   dif_analysis     ikj     -           1
+state    real   dif_xxx          ikjx    -           1     
+state    real   dif_yyy          ikjy    -           1     
+
+xpose XPOSE_SPECTRAL_NUDGING dyn_em dif_analysis,dif_xxx,dif_yyy
+##
+
+include registry.fire
+include registry.avgflx
+include registry.stoch
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM_CHEM
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM_CHEM	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM_CHEM	(revision 17)
@@ -0,0 +1,2210 @@
+# 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=<variable name>".  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.
+#
+
+include registry.dimspec
+
+################################################################################
+################################################################################
+################################################################################
+
+# 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
+#<Table> <Type> <Sym>         <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>
+#
+
+# 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         -     i012rh01d=(interp_fcnm)u=(copy_fcnm)   "LU_INDEX"              "LAND USE CATEGORY"         ""
+state    real  LU_MASK          ij      misc        1         -     i3h1     "LU_MASK"              "0 land 1 water"         ""
+
+# znw, znu, dzs, and zs must be listed before any 3-d fields
+# in order for the grib output module to work correctly.  The grib output
+# module retrieves the vertical levels from these parameters.  If znw, znu
+# dzs, and zs are not listed first, vertical level will not be encoded at 
+# time 0.
+
+state    real    znu            k       dyn_em      1         -     irh      "znu"  "eta values on half (mass) levels"  ""
+state    real    znw            k       dyn_em      1         Z     i0rh     "znw"  "eta values on full (w) levels"  ""
+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"
+
+#
+# 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   prho_gc        igj      dyn_em      1        Z     i1  "PTHETA" "for UM data, from metgrid this is ptheta, but swapped to prho in real" "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   sct_dom_gc     ij       dyn_em      1        -     i1  "SCT_DOM"  "Dominant soil (top) category from GEOGRID"  "cat"
+state    real   scb_dom_gc     ij       dyn_em      1        -     i1  "SCB_DOM"  "Dominant soil (bottom) category from GEOGRID"  "cat"
+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   pdrho_gc       igj      dyn_em      1        Z     -   "PDRHO"    "dry pressure for UM data for the variables U and V"   "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   sh_gc          igj      dyn_em      1        Z     i1  "SPECHUMD"  "Specific humidity"        "kg kg-1"
+state    real   icefrac_gc     ij       dyn_em      1        -     i1  "ICEFRAC"  "Sea ice fraction"  "0 - 1 fraction"
+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"
+state    real   qh_gc          igj      dyn_em      1        Z     i1  "QH"    "hail mixing ratio"   "kg kg-1"
+state    real   qni_gc         igj      dyn_em      1        Z     i1  "QNI"   "ice no concentration"   "m-3"
+
+#-----------------------------------------------------------------------------------------------------------------------------------------------------------------
+#                                               
+# Variables for Eulerian mass coordinate dynamics                                            
+#                                               
+
+# Velocities
+#
+# U Vel
+state    real   u              ikjb     dyn_em      2         X     \
+     i0rhusdf=(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"
+state    real   z_force        |       dyn_em      1         -      i3rh     "Z_FORCE" "height of forcing input" "m"
+state    real   z_force_tend   |       dyn_em      1         -      i3rh     "Z_FORCE_TEND" "tendency height of forcing input" "m"
+state    real   u_g            |       dyn_em      1         -      i3rh     "U_G" "x-direction geostrophic wind" "m s-1"
+state    real   u_g_tend       |       dyn_em      1         -      i3rh     "U_G_TEND" "tendency x-direction geostrophic wind" "m s-1"
+#                                               
+# V Vel
+state    real   v              ikjb     dyn_em      2         Y     \
+     i0rhusdf=(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"                   
+state    real   v_g            |       dyn_em      1         -      i3rh     "V_G" "y-direction geostrophic wind" "m s-1"
+state    real   v_g_tend       |       dyn_em      1         -      i3rh     "V_G_TEND" "tendency y-direction geostrophic wind" "m s-1"
+#                                               
+# 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                                          
+state    real   w_subs         |       dyn_em      1         -      i3rh      "W_SUBS" "large-scale vertical velocity" "m s-1"
+state    real   w_subs_tend    |       dyn_em      1         -      i3rh      "W_SUBS_TEND" "tendency large-scale vertical velocity" "m s-1"
+
+# 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         -      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         -     \
+       i0rhusdf=(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         -  
+i1       real   t_2save        ikj     dyn_em      1         -   
+state    real   t_save         ikj     dyn_em      1         -      -        "t_save"
+
+state    real   th_upstream_x       |     dyn_em      1      -      i3rh     "TH_UPSTREAM_X" "upstream theta x-advection" "K s-1"
+state    real   th_upstream_x_tend  |     dyn_em      1      -      i3rh     "TH_UPSTREAM_X_TEND" "tendency upstream theta x-advection" "K s-2"
+state    real   th_upstream_y       |     dyn_em      1      -      i3rh     "TH_UPSTREAM_Y" "upstream theta y-advection" "K s-1"
+state    real   th_upstream_y_tend  |     dyn_em      1      -      i3rh     "TH_UPSTREAM_Y_TEND" "tendency upstream theta y-advection" "K s-2"
+
+state    real   qv_upstream_x       |     dyn_em      1      -      i3rh     "QV_UPSTREAM_X" "upstream qv x-advection" "kg kg-1 s-1"
+state    real   qv_upstream_x_tend  |     dyn_em      1      -      i3rh     "QV_UPSTREAM_X_TEND" "tendency upstream qv x-advection" "kg kg-1 s-2"
+state    real   qv_upstream_y       |     dyn_em      1      -      i3rh     "QV_UPSTREAM_Y" "upstream qv y-advection" "kg kg-1 s-1"
+state    real   qv_upstream_y_tend  |     dyn_em      1      -      i3rh     "QV_UPSTREAM_Y_TEND" "tendency upstream qv y-advection" "kg kg-1 s-2"
+
+state    real   ql_upstream_x       |     dyn_em      1      -      i3rh     "QL_UPSTREAM_X" "upstream ql x-advection" "kg kg-1 s-1"
+state    real   ql_upstream_x_tend  |     dyn_em      1      -      i3rh     "QL_UPSTREAM_X_TEND" "tendency upstream ql x-advection" "kg kg-1 s-2"
+state    real   ql_upstream_y       |     dyn_em      1      -      i3rh     "QL_UPSTREAM_Y" "upstream ql y-advection" "kg kg-1 s-1"
+state    real   ql_upstream_y_tend  |     dyn_em      1      -      i3rh     "QL_UPSTREAM_Y_TEND" "tendency upstream ql y-advection" "kg kg-1 s-2"
+
+state    real   u_upstream_x        |     dyn_em      1      -      i3rh     "U_UPSTREAM_X" "upstream u x-advection" "m s-2"
+state    real   u_upstream_x_tend   |     dyn_em      1      -      i3rh     "U_UPSTREAM_X_TEND" "tendency upstream u x-advection" "m s-3"
+state    real   u_upstream_y        |     dyn_em      1      -      i3rh     "U_UPSTREAM_Y" "upstream u y-advection" "m s-2"
+state    real   u_upstream_y_tend   |     dyn_em      1      -      i3rh     "U_UPSTREAM_Y_TEND" "tendency upstream u y-advection" "m s-3"
+
+state    real   v_upstream_x        |     dyn_em      1      -      i3rh     "V_UPSTREAM_X" "upstream v x-advection" "m s-2"
+state    real   v_upstream_x_tend   |     dyn_em      1      -      i3rh     "V_UPSTREAM_X_TEND" "tendency upstream v x-advection" "m s-3"
+state    real   v_upstream_y        |     dyn_em      1      -      i3rh     "V_UPSTREAM_Y" "upstream v y-advection" "m s-2"
+state    real   v_upstream_y_tend   |     dyn_em      1      -      i3rh     "V_UPSTREAM_Y_TEND" "tendency upstream v y-advection" "m s-3"
+
+state    real   th_largescale       |     dyn_em      1      -      i3rh     "TH_LARGESCALE" "SCM largescale theta" "K"
+state    real   th_largescale_tend  |     dyn_em      1      -      i3rh     "TH_LARGESCALE_TEND" "SCM tendency largescale theta" "K s-1"
+
+state    real   qv_largescale       |     dyn_em      1      -      i3rh     "QV_LARGESCALE" "SCM largescale qv" "kg kg-1 s-1"
+state    real   qv_largescale_tend  |     dyn_em      1      -      i3rh     "QV_LARGESCALE_TEND" "SCM tendency largescale qv" "kg kg-1 s-2"
+
+state    real   ql_largescale       |     dyn_em      1      -      i3rh     "QL_LARGESCALE" "SCM largescale ql" "kg kg-1 s-1"
+state    real   ql_largescale_tend  |     dyn_em      1      -      i3rh     "QL_LARGESCALE_TEND" "SCM tendency largescale ql" "kg kg-1 s-2"
+
+state    real   u_largescale        |     dyn_em      1      -      i3rh     "U_LARGESCALE" "SCM largescale u" "m s-2"
+state    real   u_largescale_tend   |     dyn_em      1      -      i3rh     "U_LARGESCALE_TEND" "SCM tendency largescale u" "m s-3"
+
+state    real   v_largescale        |     dyn_em      1      -      i3rh     "V_LARGESCALE" "SCM largescale v" "m s-2"
+state    real   v_largescale_tend   |     dyn_em      1      -      i3rh     "V_LARGESCALE_TEND" "SCM tendency largescale v" "m s-3"
+
+state    real   tau_largescale       |     dyn_em      1      -      i3rh     "TAU_LARGESCALE" "SCM largescale timescale" "s"
+state    real   tau_largescale_tend  |     dyn_em      1      -      i3rh     "TAU_LARGESCALE_TEND" "SCM tendency largescale timescale" ""
+
+state    real   tau_x               |     dyn_em      1      -      i3rh     "TAU_X" "X-direction advective timescale" "s"
+state    real   tau_x_tend          |     dyn_em      1      -      i3rh     "TAU_X_TEND" "tendency X-direction advective timescale" ""
+state    real   tau_y               |     dyn_em      1      -      i3rh     "TAU_Y" "Y-direction advective timescale" "s"
+state    real   tau_y_tend          |     dyn_em      1      -      i3rh     "TAU_Y_TEND" "tendency Y-direction advective timescale" ""
+
+dimspec  fslay  2     namelist=num_force_soil_layers    z     force_soil_layers
+state    real   t_soil_forcing_val  {fslay}     dyn_em      1      -      i3rh     "T_SOIL_FORCING_VAL" "Soil temp value for SCM forcing" "K"
+state    real   t_soil_forcing_tend {fslay}     dyn_em      1      -      i3rh     "T_SOIL_FORCING_TEND" "tendency soil temp for SCM forcing" "K s-1"
+state    real   q_soil_forcing_val  {fslay}     dyn_em      1      -      i3rh     "Q_SOIL_FORCING_VAL" "Soil moisture value for SCM forcing" "1"
+state    real   q_soil_forcing_tend {fslay}     dyn_em      1      -      i3rh     "Q_SOIL_FORCING_TEND" "tendency soil moisture for SCM forcing" "s-1"
+state    real   tau_soil            {fslay}     dyn_em      1      -      i3rh     "TAU_SOIL" "SCM soil forcing timescale" "s"
+state    real   soil_depth_force    {fslay}     dyn_em      1      -      i3rh     "SOIL_DEPTH_FORCE" "SCM depth at center of soil layers in forcing file" "1"
+
+state    real   hfx_force           -     dyn_em      1      -      i3rh     "HFX_FORCE" "SCM ideal surface sensible heat flux" "W m-2"
+state    real   lh_force            -     dyn_em      1      -      i3rh     "LH_FORCE" "SCM ideal surface latent heat flux" "W m-2"
+state    real   tsk_force           -     dyn_em      1      -      i3rh     "TSK_FORCE" "SCM ideal surface skin temperature" "W m-2"
+state    real   hfx_force_tend      -     dyn_em      1      -      i3rh     "HFX_FORCE_TEND" "SCM ideal surface sensible heat flux tendency" "W m-2 s-1"
+state    real   lh_force_tend       -     dyn_em      1      -      i3rh     "LH_FORCE_TEND" "SCM ideal surface latent heat flux tendency" "W m-2 s-1"
+state    real   tsk_force_tend      -     dyn_em      1      -      i3rh     "TSK_FORCE_TEND" "SCM ideal surface skin temperature tendency" "W m-2 s-1"
+state    real   erod                ij.   dyn_em       1      -      i012rhdu "EROD" "fraction of erodible surface in each grid cell (0-1)"       "none"
+
+
+# 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   mub_save        ij     dyn_em      1         -      -           "mub_save" "nest temp, holds orig fine grid mub" "Pa"
+state    real   mu0             ij     dyn_em      1         -      i1          "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         -      irh       "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         -      irhdus    "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         -       rh         "potevp" "accumulated potential evaporation" "W m-2"
+state    real   snopcx         ij      dyn_em      1         -       rh         "snopcx" "snow phase change heat flux" "W m-2"
+state    real   soiltb         ij      dyn_em      1         -        h         "soiltb" "bottom soil temperature" "K"
+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    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         -                                          
+state    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"  ""
+
+# For the adaptive timestep restart
+state    logical stepping_to_time       - misc    -         -      r     "stepping_to_time"         ""
+state    integer last_step_updated      - misc    -         -      r     "last_step_updated"        ""
+state    logical adapt_step_using_child - misc    -         -      r     "adapt_step_using_child"   ""
+state    integer last_dt_sec            - misc    -         -      r     "last_dt_sec"              "Whole seconds for last timestep"  "sec"
+state    integer last_dt_sec_num        - misc    -         -      r     "last_dt_sec_num"          "Fractional secs, numerator"       "sec"
+state    integer last_dt_sec_den        - misc    -         -      r     "last_dt_sec_den"          "Fractional secs, denominator"     "sec"
+state    integer last_dt_yr             - misc    -         -      r     "last_dt_yr"               "Relative year"                    "years"
+state    integer last_dt_mm             - misc    -         -      r     "last_dt_mm"               "Relative month"                   "months"
+
+# hydrostatic pressure vars
+state    real   p_hyd           ikj     dyn_em      1         -      irh       "p_hyd"       "hydrostatic pressure"         "Pa"
+state    real   p_hyd_w         ikj     dyn_em      1         Z       r        "p_hyd_w"     "hydrostatic pressure at full levels"         "Pa"
+
+# 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         -     i01rhd    "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         -     i01rhd    "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         -      r          "URATX"            "Ratio of U over U10 on mass points "         "dimensionless"
+state    real   vratx           ij      misc        1         -      r          "VRATX"            "Ratio of V over V10 on mass points "         "dimensionless"   
+state    real   tratx           ij      misc        1         -      r          "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"         ""         ""    
+# indicates whether to recompute mu                                                             
+state   logical press_adj      -        -          -         -     -         "press_adj"         "T/F flag adjust mu"         ""    
+
+# 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         -     \
+   i0rhusdf=(bdy_interp:dt)  "QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    qc             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    qr             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    qi             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    qs             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    qg             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+state   real    qh             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QHAIL"            "Hail mixing ratio"             "kg kg-1"
+state   real    -              ikjftb   dfi_moist       1         -     -    -
+state   real    dfi_qv         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QVAPOR"       "Water vapor mixing ratio"      "kg kg-1"
+state   real    dfi_qc         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QCLOUD"       "Cloud water mixing ratio"      "kg kg-1"
+state   real    dfi_qr         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QRAIN"        "Rain water mixing ratio"       "kg kg-1"
+state   real    dfi_qi         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QICE"         "Ice mixing ratio"              "kg kg-1"
+state   real    dfi_qs         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QSNOW"        "Snow mixing ratio"             "kg kg-1"
+state   real    dfi_qg         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QGRAUP"       "Graupel mixing ratio"          "kg kg-1"
+state   real    dfi_qh         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QHAIL"        "Hail mixing ratio"             "kg kg-1"
+state    real   rimi             ikj    misc        1         -     irh         "RIMI"           "riming intensity"  "fraction"
+
+# LES---------------!JDM
+
+include registry.les
+
+#-------------------
+
+# CAM physics (UW PBL, UW SHCU, ZM CU)
+include registry.cam
+
+# Other Tracers in registry.chem
+# Other Scalars
+state   real    -              ikjftb  scalar      1         -     -   -
+state   real    qndrop         ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNDROP"        "Droplet number mixing ratio"        "# kg-1"
+state   real    qni            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNICE"         "Ice Number concentration" "# kg-1"
+state   real    qt             ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "CWM"           "Total condensate mixing ratio"      "kg kg-1"
+state   real    qns            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNSNOW"         "Snow Number concentration"   "# kg(-1)"
+state   real    qnr            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNRAIN"        "Rain Number concentration"   "# kg(-1)"
+state   real    qng            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNGRAUPEL"     "Graupel Number concentration" "# kg(-1)"
+state   real    qnh            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNHAIL"        "Hail Number concentration" "# kg(-1)"
+state   real    qnn            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNCCN"         "CCN Number concentration" "# kg(-1)"
+state   real    qnc            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNCLOUD"       "cloud water Number concentration" "# kg(-1)"
+state   real    -              ikjftb  dfi_scalar      1         -     -   -
+state   real    dfi_qndrop     ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNDROP"    "Droplet number mixing ratio"        "# kg-1"
+state   real    dfi_qni        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNICE"     "Ice Number concentration" "# kg-1"
+state   real    dfi_qt         ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_CWM"       "Total condensate mixing ratio"      "kg kg-1"
+state   real    dfi_qns        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNSNOW"    "Snow Number concentration"   "# kg(-1)"
+state   real    dfi_qnr        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNRAIN"    "Rain Number concentration"   "# kg(-1)"
+state   real    dfi_qng        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)"
+state   real    dfi_qnh        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNHAIL" "Hail Number concentration" "# kg(-1)"
+state   real    dfi_qnn        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCC"      "CNN Number concentration"   "# kg(-1)"
+state   real    dfi_qnc        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCLOUD"   "Cloud Number concentration" "# kg(-1)"
+
+include registry.chem
+
+#-----------------------------------------------------------------------------------------------------------------------------------------------------------------
+
+# 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   soil_layers    i{lin}j    misc          1     Z     i1      "SOIL_LAYERS"   "SOIL LAYERS"         "cm"
+state   real   soil_levels    i{lin}j    misc          1     Z     i1      "SOIL_LEVELS"   "SOIL LEVELS"         "cm"
+state   real   st             i{lin}j    misc          1     Z     i1      "ST"            "SOIL TEMPERATURES"   "K"
+state   real   sm             i{lin}j    misc          1     Z     i1      "SM"            "SOIL MOISTURES"      "m3 m-3"
+state   real   sw             i{lin}j    misc          1     Z     i1      "SW"            "SOIL LIQUIDS"        "m3 m-3"
+state   real   soilt          i{lin}j    misc          1     Z     i1      "SOILT"         "RUC SOIL TEMPERATURES"  "K"
+state   real   soilm          i{lin}j    misc          1     Z     i1      "SOILM"         "RUC SOIL MOISTURES"  "m3 m-3"
+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     -     i012rdu "TOPOSLPX"      "ELEVATION X SLOPE"  ""
+state   real   toposlpy            ij    misc          1     -     i012rdu "TOPOSLPY"      "ELEVATION Y SLOPE"  ""
+state   real   slope               ij    misc          1     -     rdu     "SLOPE"         "ELEVATION SLOPE"  ""
+state   real   slp_azi             ij    misc          1     -     rdu     "SLP_AZI"       "ELEVATION SLOPE AZIMUTH"  "rad"
+state   real   shdmax              ij    misc          1     -     i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)   "SHDMAX"        "ANNUAL MAX VEG FRACTION" ""
+state   real   shdmin              ij    misc          1     -     i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)   "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     i012r   "LANDUSEF"      "LANDUSE FRACTION BY CATEGORY"  ""
+state   real   soilctop            isj   misc          1     Z     i012r   "SOILCTOP"      "SOIL CAT FRACTION (TOP)"  ""
+state   real   soilcbot            isj   misc          1     Z     i012r   "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"
+
+# Time series variables
+state    real   ts_hour         ?!       misc      -         -      -        "TS_HOUR"        "Model integration time, hours"
+state    real   ts_u            ?!       misc      -         -      -        "TS_U"           "Surface wind U-component, earth-relative"
+state    real   ts_v            ?!       misc      -         -      -        "TS_V"           "Surface wind V-component, earth-relative"
+state    real   ts_q            ?!       misc      -         -      -        "TS_Q"           "Surface mixing ratio"
+state    real   ts_t            ?!       misc      -         -      -        "TS_T"           "Surface temperature"
+state    real   ts_psfc         ?!       misc      -         -      -        "TS_PSFC"        "Surface pressure"
+state    real   ts_glw          ?!       misc      -         -      -        "TS_GLW"         "Downward long wave flux at surface"
+state    real   ts_gsw          ?!       misc      -         -      -        "TS_GSW"         "Net short wave flux at surface"
+state    real   ts_hfx          ?!       misc      -         -      -        "TS_HFX"         "Upward heat flux at surface"
+state    real   ts_lh           ?!       misc      -         -      -        "TS_LH"          "Upward moisture flux at surface"
+state    real   ts_tsk          ?!       misc      -         -      -        "TS_TSK"         "Skin temperature"
+state    real   ts_tslb         ?!       misc      -         -      -        "TS_TSLB"        "Soil temperature"
+state    real   ts_clw          ?!       misc      -         -      -        "TS_CLW"         "Column integrated cloud water"
+state    real   ts_rainc        ?!       misc      -         -      -        "TS_RAINC"       "Cumulus precip"
+state    real   ts_rainnc       ?!       misc      -         -      -        "TS_RAINNC"      "Grid-scale precip"
+
+# 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   SMCREL           ilj     -          1         Z     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SMCREL"           "RELATIVE SOIL MOISTURE" ""
+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         -     i0124rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm)  "SEAICE"             "SEA ICE FLAG"  ""
+state    real   XICEM            ij     misc        1         -     rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm)  "XICEM"             "SEA ICE FLAG (PREVIOUS STEP)"  ""
+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         -     i024rhd=(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   ACGRDFLX         ij     misc        1         -      rhdu                                       "ACGRDFLX"         "ACCUMULATED GROUND HEAT FLUX" "J 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         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SNOW"             "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real   SNOWH            ij     misc        1         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SNOWH"            "PHYSICAL SNOW DEPTH"      "m"
+#state    real   RHOSN            ij     misc        1         -    i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "RHOSN"            " SNOW DENSITY"      "kg m-3" 
+state    real   CANWAT           ij     misc        1         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "CANWAT"           "CANOPY WATER"             "kg m-2"
+state    real   SST              ij     misc        1         -     i0124rhd=(interp_mask_water_field:lu_index,iswater)   "SST"              "SEA SURFACE TEMPERATURE" "K"
+state  integer  IFNDSNOWH        -      misc        1         -     i         "FNDSNOWH" "SNOWH_LOGICAL"
+state  integer  IFNDSOILW        -      misc        1         -     i         "FNDSOILW" "SOILW_LOGICAL"
+# SKIN SST
+state    real   SSTSK            ij     misc        1         -     rhd=(interp_mask_water_field:lu_index,iswater)   "SSTSK"              "SKIN SEA SURFACE TEMPERATURE" "K"
+state    real   DTW              ij     misc        1         -     r   "DTW"              "WARM LAYER TEMP DIFF" "C"
+
+# DFI variables
+state   real   hcoeff      {ndfi}    misc        1         -     -    "HCOEFF"               "initialization weights"
+state   real   hcoeff_tot       -    misc        1         -     -    "HCOEFF_TOT"               "initialization weights"
+state   real   dfi_p           ikj   misc        1         -     r    "P_DFI"           "perturbation pressure"         "Pa"
+state   real   dfi_al          ikj   misc        1         -     r    "AL_DFI"          "inverse perturbation density"  "m3 kg-1"
+state   real   dfi_mu          ij    misc        1         -     r    "MU_DFI"  "perturbation dry air mass in column" "Pa"
+state   real   dfi_phb         ikj   misc        1         Z     r    "PHB_DFI"  "base-state geopotential"  "m2 s-2"
+state   real   dfi_ph0         ikj   misc        1         Z     r    "PH0_DFI"  "initial geopotential"     "m2 s-2"
+state   real   dfi_php         ikj   misc        1         Z     r    "PHP_DFI"  "geopotential"             "m2 s-2"
+state   real   dfi_u           ikj   misc        1         -     r    "U_DFI"               "u accumulation array"          "   "
+state   real   dfi_v           ikj   misc        1         -     r    "V_DFI"               "v accumulation array"          "   "
+state   real   dfi_w           ikj   misc        1         -     r    "W_DFI"               "w accumulation array"          "   "
+state   real   dfi_ww          ikj   misc        1         Z     r    "WW_DFI"              "mu-coupled eta-dot"    "Pa s-1"
+state   real   dfi_t           ikj   misc        1         -     r    "TT_DFI"               "t accumulation array"          "   "
+state   real   dfi_rh          ikj   misc        1         -     r    "RH_DFI"               "initial relative humidity"     "   "
+state   real   dfi_ph          ikj   misc        1         -     r    "PH_DFI"               "p accumulation array"          "   "
+state   real   dfi_pb          ikj   misc        1         -     r    "PB_DFI"               "pb accumulation array"          "   "
+state   real   dfi_alt         ikj   misc        1         -     r    "ALT_DFI"             "1/rho accumulation array"          "   "
+state   real   dfi_tke         ikj   misc        1         -     r    "TKE_DFI"          "TURBULENCE KINETIC ENERGY"     "m2 s-2"
+state   real   dfi_tten_rad    ikj   misc        1         -     irh  "RAD_TTEN_DFI"     "RADAR POT. TEMP. TENDENCY"     "K s-1"
+
+state    real  dfi_TSLB        ilj   misc        1         Z     r    "TSLB_dfi"         "SOIL TEMPERATURE"   "K"
+state    real  dfi_SMOIS       ilj    -          1         Z     r    "SMOIS_dfi"        "SOIL MOISTURE"     "m3 m-3"
+state    real  dfi_SNOW        ij    misc        1         -     r    "SNOW_dfi"         "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real  dfi_SNOWH       ij    misc        1         -     r    "SNOWH_dfi"        "PHYSICAL SNOW DEPTH"      "m"
+state    real  dfi_CANWAT      ij    misc        1         -     r    "CANWAT_dfi"       "CANOPY WATER"             "kg m-2"
+state    real  dfi_SMFR3D      ilj   misc        1         Z     r    "SMFR3D_dfi"           "SOIL ICE" ""
+state    real  dfi_KEEPFR3DFLAG ilj  misc        1         Z     r    "KEEPFR3DFLAG_dfi"     "FLAG - 1. FROZEN SOIL YES, 0 - NO"             ""
+
+# 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"
+state    real   TRB_URB4D       i{ulay}j    misc       1         Z     r      "TRB_URB4D" "ROOF LAYER TEMPERATURE"          "K"
+state    real   TW1_URB4D       i{ulay}j    misc       1         Z     r      "TW1_URB4D" "WALL LAYER TEMPERATURE"          "K"
+state    real   TW2_URB4D       i{ulay}j    misc       1         Z     r      "TW2_URB4D" "WALL LAYER TEMPERATURE"          "K"
+state    real   TGB_URB4D       i{ulay}j    misc       1         Z     r      "TGB_URB4D" "ROAD LAYER TEMPERATURE"          "K"
+state    real   TLEV_URB3D      i{ulay}j    misc       1         Z     r      "TLEV_URB3D" "INDOOR TEMPERATURE"             "K"
+state    real   QLEV_URB3D      i{ulay}j    misc       1         Z     r      "QLEV_URB3D" "SPECIFIC HUMIDITY"              "dimensionless"
+state    real   TW1LEV_URB3D    i{ulay}j    misc       1         Z     r      "TW1LEV_URB3D" "WINDOW TEMPERATURE"           "K"
+state    real   TW2LEV_URB3D    i{ulay}j    misc       1         Z     r      "TW2LEV_URB3D" "WINDOW TEMPERATURE"           "K"
+state    real   TGLEV_URB3D     i{ulay}j    misc       1         Z     r      "TGLEV_URB3D" "GROUND TEMPERATURE BELOW A BUILDING"     "K"
+state    real   TFLEV_URB3D     i{ulay}j    misc       1         Z     r      "TFLEV_URB3D" "FLOOR TEMPERATURE"                       "K"
+state    real   SF_AC_URB3D     ij          misc       1         -     r      "SF_AC_URB3D"  "SENSIBLE HEAT FLUX FROM THE AIR COND." "W m{-2}"
+state    real   LF_AC_URB3D     ij          misc       1         -     r      "LF_AC_URB3D"  "LATENT HEAT FLUX FROM THE AIR COND." "W m{-2}"
+state    real   CM_AC_URB3D     ij          misc       1         -     r      "CM_AC_URB3D"  "CONSUMPTION OF THE AIR COND." "W m{-2}"
+state    real   SFVENT_URB3D    ij          misc       1         -     r      "SFVENT_URB3D" "SENSIBLE HEAT FLUX FROM URBAN VENTILATION" "W m{-2}"
+state    real   LFVENT_URB3D    ij          misc       1         -     r      "LFVENT_URB3D" "LATENT HEAT FLUX FROM URBAN VENTILATION" "W m{-2}"
+state    real   SFWIN1_URB3D    i{ulay}j    misc       1         Z     r      "SFWIN1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW"  "W m{-2}"
+state    real   SFWIN2_URB3D    i{ulay}j    misc       1         Z     r      "SFWIN2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW"  "W m{-2}"
+state    real   SFW1_URB3D      i{ulay}j    misc       1         Z     r      "SFW1_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFW2_URB3D      i{ulay}j    misc       1         Z     r      "SFW2_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFR_URB3D       i{ulay}j    misc       1         Z     r      "SFR_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFG_URB3D       i{ulay}j    misc       1         Z     r      "SFG_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   CMR_SFCDIF      ij          misc       1         -     r      "CMR_SFCDIF" "" ""
+state    real   CHR_SFCDIF      ij          misc       1         -     r      "CHR_SFCDIF" "" ""
+state    real   CMC_SFCDIF      ij          misc       1         -     r      "CMC_SFCDIF" "" ""
+state    real   CHC_SFCDIF      ij          misc       1         -     r      "CHC_SFCDIF" "" ""
+
+
+# solar location variables from radiation driver
+state    real   COSZEN           ij     misc        1         -      r       "COSZEN"  "COS of SOLAR ZENITH ANGLE"     "dimensionless"
+state    real   HRANG            ij     misc        1         -      r       "HRANG"   "SOLAR HOUR ANGLE"          "radians"
+state    real   DECLIN            -     misc        1         -      r       "DECLIN"  "SOLAR DECLINATION"         "radians"
+state    real   SOLCON            -     misc        1         -      r       "SOLCON"  "SOLAR CONSTANT"         "W m-2"
+
+# 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"             ""
+
+# Additional for P-X PBL and LSM
+state    real   RA               ij     misc        1         -      r        "RA"           "AERODYNAMIC RESISTANCE"   "s m-1"
+state    real   RS               ij     misc        1         -      r        "RS"           "SURFACE RESISTANCE"       "s m-1"
+state    real   LAI              ij     misc        1         -      i0124rh       "LAI"          "Leaf area index"          "area/area"
+state    real   VEGF_PX          ij     misc        1         -      r        "VEGF_PX"      "Vegetation Fraction for PX LSM"    "area/area"
+state    real   T2OBS            ij     misc        1         -      r        "T2OBS"        "2-m temperature from analysis "          "K"
+state    real   Q2OBS            ij     misc        1         -      r        "Q2OBS"        "2-m mixing ratio from analysis "         "kg/kg"
+
+# 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   EXCH_H          ikj     misc        1         -     r          "EXCH_H"               "SCALAR EXCHANGE COEFFICIENTS "
+state    real   EXCH_M          ikj     misc        1         -     r          "EXCH_M"               "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"                             ""
+state   real   TSHLTR           ij     misc        1         -      r        "TSHLTR"                "SHELTER THETA FROM MYJ"                       "K"
+state   real   QSHLTR           ij     misc        1         -      r        "QSHLTR"                "SHELTER SPECIFIC HUMIDITY FROM MYJ"           "kg kg-1"
+state   real   PSHLTR           ij     misc        1         -      r        "PSHLTR"                "SHELTER PRESSURE FROM MYJ"           "Pa"
+state   real   TH10             ij     misc        1         -      r        "TH10"                  "10-M THETA FROM MYJ"                          "K"
+state   real   Q10              ij     misc        1         -      r        "Q10"                   "10-M SPECIFIC HUMIDITY FROM MYJ"              "kg kg-1"
+i1      real   CHKLOWQ          ij     misc        1         -     -         "CHKLOWQ"               "SURFACE SATURATION FLAG"        ""
+# TEMF PBL variables
+state    real   te_temf        ikj     misc        1         -      rh        "te_temf"               "Total energy from TEMF PBL scheme"      "m2 s-2"
+state    real   kh_temf        ikj     misc        1         -     rh          "kh_temf"               "Diffusion coefficient for heat from TEMF PBL"
+state    real   km_temf        ikj     misc        1         -     rh          "km_temf"               "Diffusion coefficient for momentum from TEMF PBL"
+state    real   shf_temf       ikj     misc        1         -     rh          "shf_temf"              "Sensible heat flux from TEMF PBL"      "K m s-1"
+state    real   qf_temf        ikj     misc        1         -     rh          "qf_temf"              "Sensible heat flux from TEMF PBL"       "kg/kg m s-1"
+state    real   uw_temf        ikj     misc        1         -     rh          "uw_temf"              "U momentum flux from TEMF PBL"       "m2 s-2"
+state    real   vw_temf        ikj     misc        1         -     rh          "vw_temf"              "V momentum flux from TEMF PBL"       "m2 s-2"
+state    real   wupd_temf      ikj     misc        1         -     rh          "wupd_temf"            "Updraft velocity from TEMF PBL"      "m s-1"
+state    real   mf_temf        ikj     misc        1         -     rh          "mf_temf"              "Mass flux from TEMF PBL"             "m s-1"
+state    real   thup_temf      ikj     misc        1         -     rh          "thup_temf"            "Updraft thetal from TEMF PBL"        "K"
+state    real   qtup_temf      ikj     misc        1         -     rh          "qtup_temf"            "Updraft qt from TEMF PBL"        "1"
+state    real   qlup_temf      ikj     misc        1         -     rh          "qlup_temf"            "Updraft ql (liquid water) from TEMF PBL"        "1"
+state    real   cf3d_temf      ikj     misc        1         -     rh          "cf3d_temf"            "3D Cloud fraction from TEMF PBL"        "1"
+state    real   hd_temf        ij      misc        1         -     rh          "hd_temf"              "Dry thermal top height from TEMF PBL"       "m"
+state    real   lcl_temf       ij      misc        1         -     rh          "lcl_temf"             "Lifting condensation level from TEMF PBL"       "m"
+state    real   hct_temf       ij      misc        1         -     rh          "hct_temf"             "Cloud top height from TEMF PBL"       "m"
+state    real   cfm_temf       ij      misc        1         -     rh          "cfm_temf"            "Column cloud fraction from TEMF PBL"        "1"
+state    real   wm_temf        ij      misc        1         -     rh        "wm_temf"               "Velocity scale in TEMF surface layer scheme"      "m s-1"
+
+# MYNN PBL variables
+state   real   qke             ikjftb  scalar      1         -      i0rhusdf=(bdy_interp:dt) "qke"               "twice TKE FROM MYNN"      "m2 s-2"
+state   real   tsq             ikj     misc        1         -      r        "tsq"               "liquid water pottemp variance"      "K2"
+state   real   qsq             ikj     misc        1         -      r        "qsq"               "liquid water variance"      "(kg/kg)**2"
+state   real   cov             ikj     misc        1         -      r        "cov"               "liquid water-liquid water pottemp covaria\
+nce"      "K kg/kg"
+state   real   ch               ij     misc        1         -      -        "ch"                "drag coeff for heat"    ""
+#state   real   K_m             ikj     misc        1         -     -          "K_m"               "EXCHANGE COEFFICIENT for momentum "
+#state   real   K_h             ikj     misc        1         -     -          "K_h"               "EXCHANGE COEFFICIENT for heat "
+#state   real   K_q             ikj     misc        1         -     -          "K_q"               "EXCHANGE COEFFICIENT for qke "
+
+# Additional for gravity wave drag
+state   real   DTAUX3D         ikj     misc        1         -     rh        "DTAUX3D"               "LOCAL U GWDO STRESS"   "m s-1"
+state   real   DTAUY3D         ikj     misc        1         -     rh        "DTAUY3D"               "LOCAL V GWDO STRESS"   "m s-1"  
+state   real   DUSFCG           ij     misc        1         -     rh        "DUSFCG"                "COLUMN-INTEGRATED U GWDO STRESS"   "Pa m s-1"
+state   real   DVSFCG           ij     misc        1         -     rh        "DVSFCG"                "COLUMN-INTEGRATED V GWDO STRESS"   "Pa m s-1"
+state   real   VAR2D            ij     misc        1         -     i012rhdus "VAR"                   "OROGRAPHIC VARIANCE"   ""   ""
+state   real   OC12D            ij     misc        1         -     i012rhdus "CON"                   "OROGRAPHIC CONVEXITY"   ""   ""
+state   real   OA1              ij     misc        1         -     i012rhdus "OA1"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA2              ij     misc        1         -     i012rhdus "OA2"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA3              ij     misc        1         -     i012rhdus "OA3"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA4              ij     misc        1         -     i012rhdus "OA4"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL1              ij     misc        1         -     i012rhdus "OL1"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL2              ij     misc        1         -     i012rhdus "OL2"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL3              ij     misc        1         -     i012rhdus "OL3"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL4              ij     misc        1         -     i012rhdus "OL4"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+
+# BEP urban scheme  variables
+state    real    a_u_bep       ikj     misc        1         Z      -        "a_u_bep"               "IMPLICIT FOR X-COMP."      "s-1"
+state    real    a_v_bep       ikj     misc        1         Z      -        "a_v_bep"               "IMPLICIT FOR Y-COMP."      "s-1"
+state    real    a_t_bep       ikj     misc        1         Z      -        "a_t_bep"               "IMPLICIT FOR Pot. Temp"    "s-1"
+state    real    a_q_bep       ikj     misc        1         Z      -        "a_q_bep"               "IMPLICIT FOR Moisture"     "s-1"
+state    real    a_e_bep       ikj     misc        1         Z      -        "a_e_bep"               "IMPLICIT FOR TKE"          "s-1"
+state    real    b_u_bep       ikj     misc        1         Z      -        "b_u_bep"               "EXPLICIT FOR X-COMP."      "m s-2"
+state    real    b_v_bep       ikj     misc        1         Z      -        "b_v_bep"               "EXPLICIT FOR Y-COMP."      "m s-2"
+state    real    b_t_bep       ikj     misc        1         Z      -        "b_t_bep"               "EXPLICIT FOR Pot. Temp"    "K s-1"
+state    real    b_q_bep       ikj     misc        1         Z      -        "b_q_bep"               "EXPLICIT FOR Moisture"     "kg s-1"
+state    real    b_e_bep       ikj     misc        1         Z      -        "b_e_bep"               "EXPLICIT FOR TKE"          "m2 s-3"
+state    real    dlg_bep       ikj     misc        1         Z      -        "dlg_bep"               "length scale 1"            "m"
+state    real    dl_u_bep      ikj     misc        1         Z      -        "dl_u_bep"              "urban length scale"        "m"
+state    real    sf_bep        ikj     misc        1         Z      -        "sf_bep"                "surface grid"              "-"
+state    real    vl_bep        ikj     misc        1         Z      -        "vl_bep"                "volume grid"               "-"
+# BOULAC PBL variables
+state    real   tke_pbl        ikj     misc        1         -      rh        "tke_pbl"               "TKE FROM Bougeault and Lacarrere"      "m2 s-2"
+state    real   el_pbl        ikj     misc        1         -       h        "el_pbl"               "Length scale FROM Bougeault and Lacarrere"      "m"
+# Diagnostic PBL variables
+state    real   wu_tur         ikj     misc        1         -      r        "wu_tur"               "Turbulent flux of momentum(x)"      "m2 s-2"
+state    real   wv_tur         ikj     misc        1         -      r        "wv_tur"               "Turbulent flux of momentum(y)"      "m2 s-2"
+state    real   wt_tur         ikj     misc        1         -      r        "wt_tur"               "Turbulent flux of temperature"      "K m s-1"
+state    real   wq_tur         ikj     misc        1         -      r        "wq_tur"               "Turbulent flux of water vapor"      "- m s-1"
+
+# 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         -      -
+state    real   rlwtoa           ij     misc        1         -      -
+state    real   czmean           ij     misc        1         -      -
+state    real   cfracl           ij     misc        1         -      -
+state    real   cfracm           ij     misc        1         -      -
+state    real   cfrach           ij     misc        1         -      -
+state    real   acfrst           ij     misc        1         -      -
+state integer   ncfrst           ij     misc        1         -      -
+state    real   acfrcv           ij     misc        1         -      -
+state integer   ncfrcv           ij     misc        1         -      -
+
+# cam radiation variables
+state  real    -       i{ls}jf ozmixm      1    -   -     -
+state  real   mth01    i{ls}jf ozmixm      1    -   -     -
+state  real   mth02    i{ls}jf ozmixm      1    -   -     -
+state  real   mth03    i{ls}jf ozmixm      1    -   -     -
+state  real   mth04    i{ls}jf ozmixm      1    -   -     -
+state  real   mth05    i{ls}jf ozmixm      1    -   -     -
+state  real   mth06    i{ls}jf ozmixm      1    -   -     -
+state  real   mth07    i{ls}jf ozmixm      1    -   -     -
+state  real   mth08    i{ls}jf ozmixm      1    -   -     -
+state  real   mth09    i{ls}jf ozmixm      1    -   -     -
+state  real   mth10    i{ls}jf ozmixm      1    -   -     -
+state  real   mth11    i{ls}jf ozmixm      1    -   -     -
+state  real   mth12    i{ls}jf ozmixm      1    -   -     -
+state  real   pin       {ls}     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 microphysics State Variables
+state    real    F_ICE_PHY       ikj    misc        1         -      rhdu     "F_ICE_PHY"            "FRACTION OF ICE"         ""
+state    real    F_RAIN_PHY      ikj    misc        1         -      rhdu     "F_RAIN_PHY"           "FRACTION OF RAIN "         ""
+state    real    F_RIMEF_PHY     ikj    misc        1         -      rhdu     "F_RIMEF_PHY"          "MASS RATIO OF RIMED ICE "         ""
+
+state    real    ccn1            ikj    misc        1         -      r        "ccn1"                 "CCN concentration at S=0.02%"  "#/cm3"
+state    real    ccn2            ikj    misc        1         -      r        "ccn2"                 "CCN concentration at S=0.05%"  "#/cm3"
+state    real    ccn3            ikj    misc        1         -      r        "ccn3"                 "CCN concentration at S=0.1%"   "#/cm3"
+state    real    ccn4            ikj    misc        1         -      r        "ccn4"                 "CCN concentration at S=0.2%"   "#/cm3"
+state    real    ccn5            ikj    misc        1         -      r        "ccn5"                 "CCN concentration at S=0.5%"   "#/cm3"
+state    real    ccn6            ikj    misc        1         -      r        "ccn6"                 "CCN concentration at S=1.0%"   "#/cm3"
+state    real    qndropsource    ikj    misc        1         -      r        "qndropsource"         "Droplet number source"   "#/kg/s"
+# cloud water fractional removal rate needed for wet scavenging
+state    real    qlsink          ikj    misc        1         -      rdu      "qlsink"              "CLOUD WATER SINK"               "/S"
+state    real    precr           ikj    misc        1         -      rdu      "precr"               "RAIN PRECIPITATION RATE"        "KG/M2/S"
+state    real    preci           ikj    misc        1         -      rdu      "preci"               "ICE PRECIPITATION RATE"         "KG/M2/S"
+state    real    precs           ikj    misc        1         -      rdu      "precs"               "SNOW PRECIPITATION RATE"        "KG/M2/S"
+state    real    precg           ikj    misc        1         -      rdu      "precg"               "GRAUPEL PRECIPITATION RATE"     "KG/M2/S"
+
+# Other Misc State Variables                                            
+state   real    h_diabatic     ikj     misc         1         -      rdu      "h_diabatic"            "MICROPHYSICS LATENT HEATING"         "K s-1"      
+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    msftx          ij      misc         1         -     i012rhdu=(copy_fcnm)    "MAPFAC_MX"         "Map scale factor on mass grid, x direction" ""
+state   real    msfty          ij      misc         1         -     i012rhdu=(copy_fcnm)    "MAPFAC_MY"         "Map scale factor on mass grid, y direction" ""
+state   real    msfux          ij      misc         1         X     i012rhdu=(copy_fcnm)    "MAPFAC_UX"         "Map scale factor on u-grid, x direction" ""
+state   real    msfuy          ij      misc         1         X     i012rhdu=(copy_fcnm)    "MAPFAC_UY"         "Map scale factor on u-grid, y direction" ""
+state   real    msfvx          ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MAPFAC_VX"         "Map scale factor on v-grid, x direction" ""
+state   real    msfvx_inv      ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MF_VX_INV"         "Inverse map scale factor on v-grid, x direction" ""
+state   real    msfvy          ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MAPFAC_VY"         "Map scale factor on v-grid, y direction" ""
+
+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    ht_shad        ijb     misc         1         -     df=(bdy_interp:dt)         "HGT_SHAD"        "Height of orographic shadow"   "m"
+i1      real    ht_loc         ij      misc         1         -     - 
+state   integer  shadowmask    ij      misc         1         -     - 
+state   integer min_ptchsz     -       misc         1         -     r
+
+state   real    TSK            ij      misc         1         -     i012rhdu=(copy_fcnm)    "TSK"                   "SURFACE SKIN TEMPERATURE"                  "K"
+state   real    dfi_TSK        ij      misc         1         -     r                       "TSK_dfi"               "saved SURFACE SKIN TEMPERATURE"
+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    t00            -       misc         -         -     i02rh     "t00"                   "BASE STATE TEMPERATURE   "  "K"
+state   real    p00            -       misc         -         -     i02rh     "p00"                   "BASE STATE PRESURE"         "Pa"
+state   real    tlp            -       misc         -         -     i02rh     "tlp"                   "BASE STATE LAPSE RATE    "  ""
+state   real    tiso           -       misc         -         -     i02rh     "tiso"                  "TEMP AT WHICH THE BASE T TURNS CONST"  "K"
+state   real    max_msftx      -       misc         -         -      rh       "max_mstfx"             "Max map factor in domain"  ""
+state   real    max_msfty      -       misc         -         -      rh       "max_mstfy"             "Max map factor in domain"  ""
+
+# State variables for Goddard LW and SW radiation
+state    real  TLWDN           ij      misc        1         -      h         "TLWDN"                 "TOA LW downwelling flux"           "W m-2"
+state    real  TLWUP           ij      misc        1         -      h         "TLWUP"                 "TOA LW upwelling flux"             "W m-2"
+state    real  SLWDN           ij      misc        1         -      h         "SLWDN"                 "Surface LW downwelling flux"       "W m-2"
+state    real  SLWUP           ij      misc        1         -      h         "SLWUP"                 "Surface LW upwelling flux"         "W m-2"
+state    real  TSWDN           ij      misc        1         -      h         "TSWDN"                 "TOA SW downwelling flux"           "W m-2"
+state    real  TSWUP           ij      misc        1         -      h         "TSWUP"                 "TOA SW upwelling flux"             "W m-2"
+state    real  SSWDN           ij      misc        1         -      h         "SSWDN"                 "Surface SW downwelling flux"       "W m-2"
+state    real  SSWUP           ij      misc        1         -      h         "SSWUP"                 "Surface SW upwelling flux"         "W m-2"
+                                                
+# Other physics variables
+
+state    real  RUSHTEN         ikj      misc        1         -      r        "RUSHTEN"               "COUPLED X WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME"   "Pa m s-2"
+state    real  RVSHTEN         ikj      misc        1         -      r        "RVSHTEN"               "COUPLED Y WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME"   "Pa m s-2"
+state    real  RTHSHTEN        ikj      misc        1         -      r        "RTHSHTEN"              "COUPLED THETA TENDENCY DUE TO SHALLOW CUMULUS SCHEME"    "Pa K s-1"
+state    real  RQVSHTEN        ikj      misc        1         -      r        "RQVSHTEN"              "COUPLED Q_V TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQRSHTEN        ikj      misc        1         -      r        "RQRSHTEN"              "COUPLED Q_R TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQCSHTEN        ikj      misc        1         -      r        "RQCSHTEN"              "COUPLED Q_C TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQSSHTEN        ikj      misc        1         -      r        "RQSSHTEN"              "COUPLED Q_S TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQISHTEN        ikj      misc        1         -      r        "RQISHTEN"              "COUPLED Q_I TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQGSHTEN        ikj      misc        1         -      r        "RQGSHTEN"              "COUPLED Q_G TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+
+state    real  RUCUTEN         ikj      misc        1         -      r        "RUCUTEN"               "COUPLED X WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION"  "Pa m s-2"
+state    real  RVCUTEN         ikj      misc        1         -      r        "RVCUTEN"               "COUPLED Y WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION"  "Pa m s-2"
+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  RAINSH           ij      misc        1         -      rhdu     "RAINSH"                "ACCUMULATED SHALLOW CUMULUS PRECIPITATION"               "mm"
+state    real  RAINNC           ij      misc        1         -      rhdu     "RAINNC"                "ACCUMULATED TOTAL GRID SCALE PRECIPITATION"              "mm"      
+state  integer I_RAINC          ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_RAINC"            "BUCKET FOR RAINC"                    ""
+state  integer I_RAINNC         ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_RAINNC"           "BUCKET FOR RAINNC"                   ""
+state    real  PRATEC           ij      misc        1         -      r        "PRATEC"                "PRECIP RATE FROM CUMULUS SCHEME"                         "mm s-1"
+state    real  PRATESH          ij      misc        1         -      r        "PRATESH"               "PRECIP RATE FROM SHALLOW CUMULUS SCHEME"                 "mm s-1"
+state    real  RAINCV           ij      misc        1         -      r        "RAINCV"                "TIME-STEP CUMULUS PRECIPITATION"                         "mm"
+state    real  RAINSHV          ij      misc        1         -      r        "RAINSHV"               "TIME-STEP SHALLOW 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  HAILNC           ij      misc        1         -      rhdu     "HAILNC"                "ACCUMULATED TOTAL GRID SCALE HAIL"                       "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  HAILNCV          ij      misc        1         -      r        "HAILNCV"               "TIME-STEP NONCONVECTIVE HAIL"                            "mm"
+state    real    refl_10cm      ikj     dyn_em      1         -     hdu     "refl_10cm" "Radar reflectivity (lamda = 10 cm)"  "dBZ"
+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         -      -      "APR_GR"                "PRECIP FROM CLOSURE OLD_GRELL"   "mm hour-1"
+state    real  apr_w            ij      misc         1         -      -      "APR_W"                 "PRECIP FROM CLOSURE W"           "mm hour-1"
+state    real  apr_mc           ij      misc         1         -      -      "APR_MC"                "PRECIP FROM CLOSURE KRISH MV"    "mm hour-1"
+state    real  apr_st           ij      misc         1         -      -      "APR_ST"                "PRECIP FROM CLOSURE STABILITY"   "mm hour-1"
+state    real  apr_as           ij      misc         1         -      -      "APR_AS"                "PRECIP FROM CLOSURE AS-TYPE"     "mm hour-1"
+state    real  apr_capma        ij      misc         1         -      -      "APR_CAPMA"             "PRECIP FROM MAX CAP"             "mm hour-1"
+state    real  apr_capme        ij      misc         1         -      -      "APR_CAPME"             "PRECIP FROM MEAN CAP"            "mm hour-1"
+state    real  apr_capmi        ij      misc         1         -      -      "APR_CAPMI"             "PRECIP FROM MIN CAP"             "mm hour-1"
+state    real  edt_out          ij      misc         1         -      -      "EDT_OUT"               "EDT FROM GD SCHEME"             ""
+state    real  xmb_shallow      ij      misc        1         -      hr       "XMB_SHALLOW"             "MASSFLUX FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  k22_shallow   ij      misc        1         -      r       "K22_SHALLOW"             "K22 LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  kbcon_shallow   ij      misc        1         -    r       "KBCON_SHALLOW"             "KBCON LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  ktop_shallow   ij      misc        1         -     r       "KTOP_SHALLOW"             "KTOP LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  k22_deep     ij      misc        1         -      -       "K22_DEEP"             "K22 LEVEL FROM DEEPCONVECTION (G3 only)"             ""
+state    integer  kbcon_deep     ij      misc        1         -    -       "KBCON_DEEP"             "KBCON LEVEL FROM DEEP CONVECTION (G3 only)"             ""
+state    integer  ktop_deep     ij      misc        1         -     -       "KTOP_DEEP"             "KTOP LEVEL FROM DEEP CONVECTION (G3 only)"             ""
+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  cugd_tten        ikj     misc        1         -      r        "CUGD_TTEN"             "INITIAL TTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qvten       ikj     misc        1         -      r        "CUGD_QVTEN"            "INITIAL QTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_ttens       ikj     misc        1         -      r        "CUGD_TTENS"            "INITIAL SUBSIDENCE TTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qvtens      ikj     misc        1         -      r        "CUGD_QVTENS"           "INITIAL SUBSIDNCE QTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qcten       ikj     misc        1         -      r        "CUGD_QCTEN"            "INITIAL TEMPERATURE TENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-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  GD_CLDFR         ikj      misc        1         -      r     "GD_CLDFR"              "GD CLOUD Fraction"         " ? "
+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         -      r      "GD_CLOUD_B"           "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD"         "kg kg-1"
+state    real  GD_CLOUD2_B       ikj      misc        1         -      r      "GD_CLOUD2_B"          "taveragd cloud ice mix ratio in GD"         "kg kg-1"
+state integer  STEPAVE_COUNT     -        misc        1         -      r      "STEPAVE_COUNT"        "time steps contained in averages for convective transport" ""
+
+#
+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"              "UNCOUPLED THETA TENDENCY DUE TO LONG WAVE RADIATION"    "K s-1"
+state    real  RTHRATENSW      ikj      misc        1         -      r        "RTHRATSW"              "UNCOUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION"   "K s-1"
+state    real  CLDFRA          ikj      misc        1         -      rh       "CLDFRA"                "CLOUD FRACTION"                                       ""
+state    real  CLDFRA_OLD      ikj      misc        1         -      r        "CLDFRA_OLD"            "previous time level cldfra"                           ""
+
+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"      
+state    real  SWNORM           ij      misc        1         -      rhd      "SWNORM"                "NORMAL SHORT WAVE FLUX AT GROUND SURFACE (SLOPE-DEPENDENT)"           "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 integer  I_ACSWUPT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPT"     "BUCKET FOR UPWELLING SHORTWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACSWUPTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPTC"    "BUCKET FOR UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACSWDNT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNT"     "BUCKET FOR DOWNWELLING SHORTWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACSWDNTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNTC"    "BUCKET FOR DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACSWUPB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPB"     "BUCKET FOR UPWELLING SHORTWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACSWUPBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPBC"    "BUCKET FOR UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACSWDNB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNB"     "BUCKET FOR DOWNWELLING SHORTWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACSWDNBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNBC"    "BUCKET FOR DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACLWUPT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPT"     "BUCKET FOR UPWELLING LONGWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACLWUPTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPTC"    "BUCKET FOR UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACLWDNT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNT"     "BUCKET FOR DOWNWELLING LONGWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACLWDNTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNTC"    "BUCKET FOR DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACLWUPB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPB"     "BUCKET FOR UPWELLING LONGWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACLWUPBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPBC"    "BUCKET FOR UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACLWDNB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNB"     "BUCKET FOR DOWNWELLING LONGWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACLWDNBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNBC"    "BUCKET FOR DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2"
+state    real  SWUPT            ij      misc        1         -      rhdu     "SWUPT"                 "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP"          "W m-2"
+state    real  SWUPTC           ij      misc        1         -      rhdu     "SWUPTC"                "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2"
+state    real  SWDNT            ij      misc        1         -      rhdu     "SWDNT"                 "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP"          "W m-2"
+state    real  SWDNTC           ij      misc        1         -      rhdu     "SWDNTC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2"
+state    real  SWUPB            ij      misc        1         -      rhdu     "SWUPB"                 "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  SWUPBC           ij      misc        1         -      rhdu     "SWUPBC"                "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2"
+state    real  SWDNB            ij      misc        1         -      rhdu     "SWDNB"                 "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  SWDNBC           ij      misc        1         -      rhdu     "SWDNBC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2"
+state    real  LWUPT            ij      misc        1         -      rhdu     "LWUPT"                 "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP"          "W m-2"
+state    real  LWUPTC           ij      misc        1         -      rhdu     "LWUPTC"                "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2"
+state    real  LWDNT            ij      misc        1         -      rhdu     "LWDNT"                 "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP"          "W m-2"
+state    real  LWDNTC           ij      misc        1         -      rhdu     "LWDNTC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2"
+state    real  LWUPB            ij      misc        1         -      rhdu     "LWUPB"                 "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  LWUPBC           ij      misc        1         -      rhdu     "LWUPBC"                "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W m-2"
+state    real  LWDNB            ij      misc        1         -      rhdu     "LWDNB"                 "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  LWDNBC           ij      misc        1         -      rhdu     "LWDNBC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W 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  CLAT             ij      misc        1         -     i012rdu=(copy_fcnm)          "CLAT"                "COMPUTATIONAL GRID LATITUDE, SOUTH IS NEGATIVE"                       "degree_north"
+state    real  CLONG            ij      misc        1         -     i012rdu=(copy_fcnm)          "CLONG"               "COMPUTATIONAL GRID LONGITUDE, WEST IS NEGATIVE"                       "degree_east"
+state    real  ALBBCK           ij      misc        1         -     i0124rh   "ALBBCK"                "BACKGROUND ALBEDO"        ""
+state    real  EMBCK            ij      misc        1         -      r        "EMBCK"                 "BACKGROUND EMISSIVITY"         ""
+state    real  EMISS            ij      misc        1         -      r        "EMISS"                 "SURFACE EMISSIVITY"         "" 
+state    real  SNOTIME          ij      misc        1         -      r        "SNOTIME"               "SNOTIME"         "" 
+state    real  NOAHRES          ij      misc        1         -      h        "NOAHRES"               "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}"
+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         -                                          
+state    real  t_phy           ikj      misc        1         -      r      "T_PHY"                        "Temperature"         "K"
+
+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  TYR              ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TYR"        "ANNUAL MEAN SFC TEMPERATURE"           "K"
+state    real  TYRA             ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TYRA"   "ACCUMULATED YEARLY SFC TEMPERATURE FOR CURRENT YEAR"  "K"
+state    real  TDLY             ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TDLY"     "ACCUMULATED DAILY SFC TEMPERATURE FOR CURRENT DAY"  "K"
+state    real  TLAG             i&j     misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TLAG"         "DAILY MEAN SFC TEMPERATURE OF PRIOR DAYS"       "K"
+state    integer NYEAR          -       misc        1         -     r        "NYEAR"                  "ACCUM DAYS IN A YEAR"                         ""
+state    real    NDAY           -       misc        1         -     r        "NDAY"                  "ACCUM TIMESTEPS IN A DAY"                      ""
+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  CK               ij      misc        1         -      r        "CK"                    "ENTHALPY EXCHANGE COEFF AT 10 m"                      ""
+state    real  CKA              ij      misc        1         -      r        "CKA"                   "ENTHALPY EXCHANGE COEFF AT LOWEST MODEL LVL"          ""
+state    real  CD               ij      misc        1         -      r        "CD"                    "DRAG COEFF AT 10m"                      ""
+state    real  CDA              ij      misc        1         -      r        "CDA"                   "DRAG COEFF AT LOWEST MODEL LVL"         ""
+state    real  UST              ij      misc        1         -      rh       "UST"                   "U* IN SIMILARITY THEORY"                      "m s-1"      
+state    real  USTM             ij      misc        1         -      r        "USTM"                  "U* IN SIMILARITY THEORY WITHOUT VCONV"        "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  ACHFX            ij      misc        1         -      rhdu     "ACHFX"                 "ACCUMULATED UPWARD HEAT FLUX AT THE SURFACE"  "J m-2"
+state    real  ACLHF            ij      misc        1         -      rhdu     "ACLHF"                 "ACCUMULATED UPWARD LATENT HEAT FLUX AT THE SURFACE"  "J 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  dfi_QVG          ij      misc        1         -      r        "QVG_dfi"               "WATER VAPOR MIXING RATIO AT THE SURFACE"      "kg kg-1"
+state    real  QCG              ij      misc        1         -      r        "QCG"                   "CLOUD WATER MIXING RATIO AT THE GROUND SURFACE"      "kg kg-1"
+state    real  DEW              ij      misc        1         -      r        "DEW"                   "DEW MIXING RATIO AT THE SURFACE"              "kg kg-1"
+state    real  SOILT1           ij      misc        1         -      i012rh   "SOILT1"                "TEMPERATURE INSIDE SNOW "    "K"
+state    real  dfi_SOILT1       ij      misc        1         -      r        "SOILT1_dfi"            "TEMPERATURE INSIDE SNOW "    "K"
+state    real  TSNAV            ij      misc        1         -      r        "TSNAV"                 "AVERAGE SNOW TEMPERATURE "                    "C"
+state    real  dfi_TSNAV        ij      misc        1         -      r        "TSNAV_dfi"             "AVERAGE SNOW TEMPERATURE "                    "C"
+state    real  REGIME           ij      misc        1         -      r        "REGIME"  "FLAGS: 1=Night/Stable, 2=Mechanical Turbulent, 3=Forced Conv, 4=Free Conv" ""
+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  dfi_SNOWC        ij      misc        1         -      r        "SNOWC_dfi"             "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   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"
+state  integer save_topo_from_real -    dyn_em	    1         -    irh        "save_topo_from_real"    "1=original topo from real/0=topo modified by WRF"      "flag"
+
+## 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  RPHNDGDTEN        ikj      misc        1         -      r        "RPHNDGDTEN"              "COUPLED GEOPOTENTIAL TENDENCY DUE TO FDDA GRID NUDGING"   "Pa m2 s-3"
+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      i{10}r   "U_NDG_NEW"               "NEW X WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  V_NDG_NEW         ikjf     fdda3d      1         Y      i{10}r   "V_NDG_NEW"               "NEW Y WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  T_NDG_NEW         ikjf     fdda3d      1         -      i{10}r   "T_NDG_NEW"               "NEW PERT POT TEMP FOR FDDA GRID NUDGING"  "K"
+state    real  Q_NDG_NEW         ikjf     fdda3d      1         -      i{10}r   "Q_NDG_NEW"               "NEW WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  PH_NDG_NEW        ikjf     fdda3d      1         Z      i{10}r   "PH_NDG_NEW"              "NEW PERT GEOPOTENTIAL FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  U_NDG_OLD         ikjf     fdda3d      1         X      i{10}r   "U_NDG_OLD"               "OLD X WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  V_NDG_OLD         ikjf     fdda3d      1         Y      i{10}r   "V_NDG_OLD"               "OLD Y WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  T_NDG_OLD         ikjf     fdda3d      1         -      i{10}r   "T_NDG_OLD"               "OLD PERT POT TEMP FOR FDDA GRID NUDGING"  "K"
+state    real  Q_NDG_OLD         ikjf     fdda3d      1         -      i{10}r   "Q_NDG_OLD"               "OLD WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  PH_NDG_OLD        ikjf     fdda3d      1         Z      i{10}r   "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         -      i{10}r   "MU_NDG_NEW"              "NEW PERT COLUMN DRY MASS FOR FDDA GRID NUDGING"  "Pa"
+state    real  MU_NDG_OLD        ivjf     fdda2d      1         -      i{10}r   "MU_NDG_OLD"              "OLD PERT COLUMN DRY MASS FOR FDDA GRID NUDGING"  "Pa"
+state    real  U10_NDG_OLD       ij         misc      1         X      i9r      "U10_NDG_OLD"             "OLD U10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  U10_NDG_NEW       ij         misc      1         X      i9r      "U10_NDG_NEW"             "NEW U10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  V10_NDG_OLD       ij         misc      1         Y      i9r      "V10_NDG_OLD"             "OLD V10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  V10_NDG_NEW       ij         misc      1         Y      i9r      "V10_NDG_NEW"             "NEW V10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  T2_NDG_OLD        ij         misc      1         -      i9r      "T2_NDG_OLD"              "OLD T2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  T2_NDG_NEW        ij         misc      1         -      i9r      "T2_NDG_NEW"              "NEW T2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  TH2_NDG_OLD       ij         misc      1         -      i9r      "TH2_NDG_OLD"             "OLD TH2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  TH2_NDG_NEW       ij         misc      1         -      i9r      "TH2_NDG_NEW"             "NEW TH2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  Q2_NDG_OLD        ij         misc      1         -      i9r      "Q2_NDG_OLD"              "OLD Q2 FOR SURFACE FDDA GRID NUDGING"  "kg kg-1"
+state    real  Q2_NDG_NEW        ij         misc      1         -      i9r      "Q2_NDG_NEW"              "NEW Q2 FOR SURFACE FDDA GRID NUDGING"  "kg kg-1"
+state    real  RH_NDG_OLD        ij         misc      1         -      i9r      "RH_NDG_OLD"              "OLD RH FOR SURFACE FDDA GRID NUDGING"  "%"
+state    real  RH_NDG_NEW        ij         misc      1         -      i9r      "RH_NDG_NEW"              "NEW RH FOR SURFACE FDDA GRID NUDGING"  "%"
+state    real  PSL_NDG_OLD       ij         misc      1         -      i9r      "PSL_NDG_OLD"             "OLD PSL FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PSL_NDG_NEW       ij         misc      1         -      i9r      "PSL_NDG_NEW"             "NEW PSL FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PS_NDG_OLD        ij         misc      1         -      i9r      "PS_NDG_OLD"              "OLD PS FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PS_NDG_NEW        ij         misc      1         -      i9r      "PS_NDG_NEW"              "NEW PS FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  TOB_NDG_OLD       ij         misc      1         -      i9r      "TOB_NDG_OLD"             "OLD TOB FOR SURFACE FDDA GRID NUDGING"  ""
+state    real  ODIS_NDG_OLD      ij         misc      1         -      i9r      "ODIS_NDG_OLD"            "OLD ODIS FOR SURFACE FDDA GRID NUDGING"  "km"
+state    real  TOB_NDG_NEW       ij         misc      1         -      i9r      "TOB_NDG_NEW"             "NEW TOB FOR SURFACE FDDA GRID NUDGING"  ""
+state    real  ODIS_NDG_NEW      ij         misc      1         -      i9r      "ODIS_NDG_NEW"            "NEW ODIS FOR SURFACE FDDA GRID NUDGING"  "km"
+state    real  SN_NDG_NEW        ij         misc      1         -      i9r      "SN_NDG_NEW"              "NEW Snow Water Equivalent"  "mm"
+state    real  SN_NDG_OLD        ij         misc      1         -      i9r      "SN_NDG_OLD"              "OLD Snow Water Equivalent"  "mm"
+
+# 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"
+
+state   real    max_cfl         -       misc        1         -     -       "max_cfl"           "maximum CFL value in grid at a time" "-"
+
+state   real  prec_acc_c       ij       misc        1         -     rh       "prec_acc_c"       "ACCUMULATED CUMULUS PRECIPITATION OVER prec_acc_dt PERIODS OF TIME"       "mm"
+state   real  prec_acc_nc      ij       misc        1         -     rh       "prec_acc_nc"      "ACCUMULATED GRID SCALE  PRECIPITATION OVER prec_acc_dt PERIODS OF TIME"   "mm"
+state   real  snow_acc_nc      ij       misc        1         -     rh       "snow_acc_nc"      "ACCUMULATED SNOW WATER EQUIVALENT OVER prec_acc_dt PERIODS OF TIME"       "mm"
+
+# Placeholder for decoupled advective tendency diagnostics for non-chem
+state   real  -               ikjf      advh_t      1         -     -         -
+state   real  advh_qv         ikjf      advh_t      1         -     -         "advh_qv"    "ACCUMULATED HORIZONTAL TENDENCY FOR WATER VAPOR"        "kg kg-1"
+
+state   real  -               ikjf      advz_t      1         -     -         -
+state   real  advz_qv         ikjf      advz_t      1         -     -         "advz_qv"    "ACCUMULATED VERTICAL TENDENCY FOR WATER VAPOR"          "kg kg-1"
+
+# Ocean Mixed-Layer State Variables
+state   real    TML            ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "TML"    "OCEAN MIXED-LAYER TEMPERATURE"   "K"
+state   real    T0ML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "T0ML"   "INITIAL OCEAN MIXED-LAYER TEMPERATURE"   "K"
+state   real    HML            ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HML"    "OCEAN MIXED-LAYER DEPTH"   "m"
+state   real    H0ML           ij      misc         1         -     i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "H0ML"   "INITIAL OCEAN MIXED-LAYER DEPTH"   "m"
+state   real    HUML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HUML"   "OCEAN MIXED-LAYER DEPTH * U-CURRENT"  " m2s-1 "
+state   real    HVML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HVML"   "OCEAN MIXED-LAYER DEPTH * V-CURRENT"  " m2s-1 "
+state   real    TMOML          ij      misc         1         -     i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm) "TMOML"  "OCEAN LAYER MEAN TEMPERATURE   "   "K"
+#
+#---------------------------------------------------------------------------------------------------------------------------------------
+#                                               
+
+######                                          
+#                                               
+# Variables that are set at run-time to control configuration  (namelist-settable)                                              
+#                                               
+#<Table>  <Type>  <Sym>                   <How set>          <Nentries>   <Default>                                             
+
+
+# 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"      ""  ""
+rconfig   logical all_ic_times            namelist,time_control		1              .false. irh    "all_ic_times"     "T/F WRITE ALL IC TIME PERIODS"  ""
+
+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<domain>"          -     "name of input   infile"   ""      ""
+rconfig   character  input_outname     namelist,time_control		1  "wrfinput_d<domain>"          -     "name of input   outfile"  ""      ""
+rconfig   character  bdy_inname        namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary infile"  ""      ""
+rconfig   character  bdy_outname       namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary outfile" ""      ""
+rconfig   character  rst_inname        namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "name of restrt infile"    ""      ""
+rconfig   character  rst_outname       namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "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 write_hist_at_0h_rst    namelist,time_control		1             .false. h    "write_hist_at_0h_rst" "T/F write hist at 0 h of restarted forecast"
+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"
+rconfig   logical cycling                 namelist,time_control         1             .false. -    "true for cycling (using wrfout file as input data)"
+
+# DFI namelist
+rconfig   integer dfi_opt                namelist,dfi_control   1       0     rh   "dfi_opt"                ""      ""
+rconfig   integer dfi_radar              namelist,dfi_control   1       0     rh   "dfi_radar"                "DFI radar switch"      ""
+rconfig   integer dfi_nfilter            namelist,dfi_control   1       7     rh   "dfi_nfilter"                "Digital filter type"      ""
+rconfig   logical dfi_write_filtered_input  namelist,dfi_control  1  .true.   rh   "dfi_write_filtered_input"                "Write a wrfinput_filtered_d0n file?"      ""
+rconfig   logical dfi_write_dfi_history  namelist,dfi_control   1   .false.   rh   "dfi_write_dfi_history"    "Write history files during filtering?"      ""
+rconfig   integer dfi_cutoff_seconds     namelist,dfi_control   1    3600     rh   "dfi_cutoff_seconds"       "Digital filter cutoff time"      ""
+rconfig   integer dfi_time_dim           namelist,dfi_control   1    1000     rh   "dfi_time_dim"             "MAX DIMENSION FOR HCOEFF"
+rconfig   integer dfi_fwdstop_year       namelist,dfi_control   1    2004     rh   "dfi_fwdstop_year"         "4 DIGIT YEAR OF START OF DFI" "YEARS"
+rconfig   integer dfi_fwdstop_month      namelist,dfi_control   1      03     rh   "dfi_fwdstop_month"        "2 DIGIT MONTH OF THE YEAR OF START OF DFI" "MONTHS"
+rconfig   integer dfi_fwdstop_day        namelist,dfi_control   1      13     rh   "dfi_fwdstop_day"          "2 DIGIT DAY OF THE MONTH OF START OF DFI" "DAYS"
+rconfig   integer dfi_fwdstop_hour       namelist,dfi_control   1      12     rh   "dfi_fwdstop_hour"         "2 DIGIT HOUR OF THE DAY OF START OF DFI" "HOURS"
+rconfig   integer dfi_fwdstop_minute     namelist,dfi_control   1      00     rh   "dfi_fwdstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF START OF DFI" "MINUTES"
+rconfig   integer dfi_fwdstop_second     namelist,dfi_control   1      00     rh   "dfi_fwdstop_second"       "2 DIGIT SECOND OF THE MINUTE OF START OF DFI" "SECONDS"
+rconfig   integer dfi_bckstop_year       namelist,dfi_control   1    2004     rh   "dfi_bckstop_year"         "4 DIGIT YEAR OF END OF DFI" "YEARS"
+rconfig   integer dfi_bckstop_month      namelist,dfi_control   1      03     rh   "dfi_bckstop_month"        "2 DIGIT MONTH OF THE YEAR OF END OF DFI" "MONTHS"
+rconfig   integer dfi_bckstop_day        namelist,dfi_control   1      14     rh   "dfi_bckstop_day"          "2 DIGIT DAY OF THE MONTH OF END OF DFI" "DAYS"
+rconfig   integer dfi_bckstop_hour       namelist,dfi_control   1      12     rh   "dfi_bckstop_hour"         "2 DIGIT HOUR OF THE DAY OF END OF DFI" "HOURS"
+rconfig   integer dfi_bckstop_minute     namelist,dfi_control   1      00     rh   "dfi_bckstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF END OF DFI" "MINUTES"
+rconfig   integer dfi_bckstop_second     namelist,dfi_control   1      00     rh   "dfi_bckstop_second"       "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS"
+
+# 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 time_step_dfi           namelist,domains      1             -       ih   "time_step_dfi"
+
+rconfig   integer min_time_step           namelist,domains      max_domains   -1      h    "min_time_step"
+rconfig   integer max_time_step           namelist,domains      max_domains   -1      h    "max_time_step"
+rconfig   real    target_cfl              namelist,domains      max_domains  1.2      h    "target_cfl"
+rconfig   real    target_hcfl             namelist,domains      max_domains  0.84     h    "target_hcfl"
+rconfig   integer max_step_increase_pct   namelist,domains      max_domains    5      h    "max_step_increase_pct"
+rconfig   integer starting_time_step      namelist,domains      max_domains   -1      h    "starting_time_step"
+rconfig   logical step_to_output_time     namelist,domains      1         .true.      h    "step_to_output_time"
+rconfig   integer adaptation_domain       namelist,domains      1              1      h    "adaptation_domain"
+rconfig   logical use_adaptive_time_step  namelist,domains      1         .false.     h    "use_adaptive_time_step"
+
+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 num_metgrid_soil_levels namelist,domains	1             4        irh    "num_metgrid_soil_levels"               "number of input levels or layers in 3D sm, st, sw arrays"      ""
+rconfig   real    p_top_requested         namelist,domains      1              5000    irh    "p_top_requested" "Pa"      ""
+rconfig   integer interp_type             namelist,domains	1              2       irh    "interp_type"  "1=interp in pressure, 2=interp in LOG pressure"  ""
+rconfig   integer vert_refine_fact        namelist,domains      1              1       irh    "vertical refinment factor for ndown"  ""
+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              2       irh    "t_extrap_type"  "1=isothermal, 2=6.5 K/km, 3=adiabatic"   ""
+rconfig   logical lowest_lev_from_sfc     namelist,domains	1             .false.  irh    "lowest_lev_from_sfc"                ""      ""
+rconfig   logical use_levels_below_ground namelist,domains	1             .true.   irh    "use_levels_below_ground"   "T/F: use input data levels below input sfc pres" ""
+rconfig   logical use_tavg_for_tsk        namelist,domains	1             .false.  irh    "use_tavg_for_tsk"   "T/F: use diurnal avg sfc temp for tsk" ""
+rconfig   logical use_surface             namelist,domains	1             .true.   irh    "use_surface"   "T/F: use input surface level in interpolation" ""
+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    "sfcp_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   logical smooth_cg_topo          namelist,domains	1              .false. irh    "smooth_cg_topo"   "T/F smooth CG topo on boundarries" "flag"
+rconfig   logical aggregate_lu            namelist,domains	1              .false. irh    "aggregate_lu"   "T/F aggregate the grass, shrubs, trees in LU"
+rconfig   logical rh2qv_wrt_liquid        namelist,domains	1              .true.  irh    "rh2qv_wrt_liquid" "T = rh=>Qv assumes RH wrt liquid water, F = allows ice"
+rconfig   integer rh2qv_method            namelist,domains	1              1       irh    "rh2qv_method" "1=old MM5 method, 2=new WMO method"
+rconfig   real    qv_max_p_safe           namelist,domains      1              10000   irh    "qv_max_p_safe" "Threshhold pressure, Qv > flag set to value"      "Pa"
+rconfig   real    qv_max_flag             namelist,domains      1              1.E-5   irh    "qv_max_flag" "Qv flag for max"  "kg kg{-1}"
+rconfig   real    qv_max_value            namelist,domains      1              3.E-6   irh    "qv_max_value" "Qv value for max"  "kg kg{-1}"
+rconfig   real    qv_min_p_safe           namelist,domains      1              110000  irh    "qv_min_p_safe" "Threshhold pressure, Qv < flag set to value"      "Pa"
+rconfig   real    qv_min_flag             namelist,domains      1              1.E-6   irh    "qv_min_flag" "Qv flag for min"  "kg kg{-1}"
+rconfig   real    qv_min_value            namelist,domains      1              1.E-6   irh    "qv_min_value" "Qv value for min"  "kg kg{-1}"
+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   logical grid_allowed            namelist,domains      max_domains    .true.  irh    "allowed"       ""      ""
+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   ts_buf_size     namelist,domains    1                200          -       "ts_buf_size"   "Size of time series buffer"
+rconfig   integer   max_ts_locs     namelist,domains    1                5            -       "max_ts_locs"   "Maximum number of time series locations"
+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   track_level     namelist,domains    1                50000
+rconfig   real      time_to_move    namelist,domains    max_domains      0.  -  "" "" "minutes"
+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.
+
+# TC (tropical cyclone bogusing)
+rconfig   logical insert_bogus_storm   namelist,tc     	1              .false. irh    "insert_bogus_storm"   "T/F for inserting a bogus typhoon"      "flag"
+rconfig   logical remove_storm         namelist,tc     	1              .false. irh    "remove_storm"  "T/F for only removing the original typhoon"  "flag"
+rconfig   integer num_storm            namelist,tc     	1              1       irh    "num_storm"     "Number of bogus typhoons"  ""
+rconfig   real    latc_loc             namelist,tc     	max_bogus      -999.   irh    "latc_loc"      "center latitude of the bogus tyhoon"  "DEGREES"
+rconfig   real    lonc_loc             namelist,tc     	max_bogus      -999.   irh    "lonc_loc"      "center longitude of the bogus tyhoon"  "DEGREES"
+rconfig   real    vmax_meters_per_second   namelist,tc  max_bogus      -999.   irh    "vmax_meters_per_second"  "vmax of bogus storm in meters per second"  ""
+rconfig   real    rmax                 namelist,tc     	max_bogus      -999.   irh    "rmax"  "maximum radius outward from storm center"  ""
+rconfig   real    vmax_ratio           namelist,tc      max_bogus      -999.   irh    "vmax_ratio"  ""  ""
+rconfig   real    rankine_lid          namelist,tc      1              -999.   irh    "top pressure limit for the tc bogus scheme"
+
+# Physics
+rconfig   integer     mp_physics          namelist,physics	max_domains    0       rh       "mp_physics"            ""      ""
+rconfig   integer     gsfcgce_hail        namelist,physics      1              0       rh       "gsfcgce select hail/graupel"  ""      ""
+rconfig   integer     gsfcgce_2ice        namelist,physics      1              0       rh       "gsfcgce select 2ice/3ice"  ""      ""
+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   integer     sf_urban_physics    namelist,physics      max_domains    0       rh       "sf_urban_physics"     "activate urban model  0=no, 1=Noah_UCM 2=BEP_UCM"   ""
+rconfig   real    BLDT                    namelist,physics      max_domains    0       h    "BLDT"          ""      ""
+rconfig   integer cu_physics              namelist,physics      max_domains    0       rh   "cu_physics"    ""      ""
+rconfig   integer shcu_physics            namelist,physics      max_domains    0       rh   "shcu_physics"  ""      ""
+rconfig   integer     cu_diag             namelist,physics      max_domains    0       rh       "cu_diag"            " additional t-averaged stuff for cuphys"      ""
+rconfig   integer     kfeta_trigger       namelist,physics	1              1       rh       "KFETA Trigger function"    ""    ""
+rconfig   real    CUDT                    namelist,physics	max_domains    1       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_dust_layers         namelist,physics	1             3       irh    "num_dust_layers"               ""      ""
+rconfig   integer num_urban_layers        namelist,physics	1            400       irh    "num_urban_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 cugd_avedx              namelist,physics      1            1      irh    "cugd_avedx"                    ""      ""
+rconfig   integer clos_choice             namelist,physics      1             0       rh    "clos_choice"                    ""      ""
+rconfig   integer imomentum               namelist,physics      1             0       rh    "imomentum"                    "momentum transport in G3 scheme"      ""
+rconfig   integer ishallow                namelist,physics      1             0       rh    "ishallow"  "shallow convection in G3 scheme"      ""
+rconfig   integer     chem_opt            namelist,physics	max_domains    0       rh       "chem_opt"              ""      ""
+rconfig   real    convtrans_avglen_m      namelist,physics      1             30      rh    "convtrans_avglen_m"  "averaging time for convective transport output variables (minutes)"      ""
+rconfig   integer clos_choice             namelist,physics      1             0       rh    "clos_choice"                    ""      ""
+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 sst_skin                namelist,physics      1            0         h    "sst_skin" "calculate sst skin temperature 0=no, 1=yes"   ""
+rconfig   integer tmn_update              namelist,physics      1            0         h    "tmn_update" "update tmn from calculation  0=no, 1=yes"   ""
+rconfig   logical usemonalb               namelist,physics      1            .false.   h    "usemonalb"   "use 2d field vs table values  false=table, True=2d"   ""
+rconfig   logical rdmaxalb                namelist,physics      1            .true.    h     "rdmaxalb"    "false set it to table values"   ""
+rconfig   logical rdlai2d                 namelist,physics      1            .false.   h     "rdlai2d"     "false set it to table values"   ""
+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   integer lagday                  namelist,physics      1             1       -      "lagday"         ""      ""
+rconfig   logical cu_rad_feedback         namelist,physics      max_domains   .false.  -     "feedback cumulus to radiation"  ""
+rconfig   integer pxlsm_smois_init        namelist,physics      max_domains   1       irh    "PXLSM_SMOIS_INIT"    "Soil moisture initialization option 0-From analysis 1-From MAVAIL"   ""
+rconfig   integer omlcall                 namelist,physics      1            0         h     "omlcall"     "activate simple ocean mixed layer model  0=no, 1=yes"   ""
+rconfig   real    oml_hml0                namelist,physics      1            50        h     "oml_hml0"    "oml initial mixed layer depth value"   "m"
+rconfig   real    oml_gamma               namelist,physics      1            0.14      h     "oml_gamma"   "oml deep water lapse rate"   "K m-1"
+rconfig   integer isftcflx                namelist,physics      1            0         h     "isftcflx"    "switch to control sfc fluxes"   ""
+rconfig   integer iz0tlnd                 namelist,physics      1            0         h     "iz0tlnd"    "switch to control land thermal roughness length"   ""
+rconfig   real    shadlen                 namelist,physics      1            25000.    -     "shadow_length" "maximum length of orographic shadow" "m"
+rconfig   integer slope_rad               namelist,physics      max_domains    0       -     "slope_rad"  "1: use slope-dependent radiation, 0:not" ""
+rconfig   integer topo_shading            namelist,physics      max_domains    0       -     "topo_shading" "1: apply topographic shading to radiation, 0:not" ""
+rconfig   integer no_mp_heating           namelist,physics      1              0       -     "no_mp_heating" "switch to turn of latent heating in mp schemes"   ""
+rconfig   integer fractional_seaice       namelist,physics      1              0       -     "fractional_seaice" "Fractional sea-ice option"
+rconfig   logical tice2tsk_if2cold        namelist,physics      1              .false. -     "tice2tsk_if2cold" "Avoid low ice temps when ice frac and Tsk are inconsistent"
+rconfig   real    bucket_mm               namelist,physics      1             -1.      h     "bucket_mm" "bucket reset value for water accumulations -1: inactive"   ""
+rconfig   real    bucket_J                namelist,physics      1             -1.      h     "bucket_J"  "bucket reset value for energy accumulations -1: inactive"   ""
+rconfig   real    mp_tend_lim             namelist,physics      1             10.      -     "mp_tend_lim" "limit on temp tendency from mp latent heating"   "K/s"
+rconfig   real    prec_acc_dt             namelist,physics      max_domains    0.      h     "prec_acc_dt" "bucket reset time interval between outputs for cumulus or grid scale precipitation"   "minutes"
+rconfig   integer prec_acc_opt            derived               1              0       -     "prec_acc_opt" "option to output precip in a time window"          ""
+rconfig   integer bucketr_opt             derived               1              0       -     "bucketr_opt"  "option to output water accum based on bucket_mm "          ""
+
+rconfig   integer grav_settling           namelist,physics      max_domains  0         h    "grav_settling"     "activate gravitationalsettling of fog  0=no, 1=yes"
+
+#FDDA namelist parameters
+rconfig   real    FGDT                    namelist,fdda         max_domains    0       h        "FGDT"          ""      ""
+rconfig   integer  FGDTZERO               namelist,fdda         max_domains    0       rh       "FGDTZERO"             ""      ""
+rconfig   integer  grid_fdda              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   integer  grid_sfdda             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_ph   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_ph             namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   integer   k_zfac_ph             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   integer  dk_zfac_uv             namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   integer  dk_zfac_t              namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   integer  dk_zfac_ph             namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   real        guv                 namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        guv_sfc             namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gt                  namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gt_sfc              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gq                  namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gq_sfc              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gph                 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"            ""      ""
+rconfig   real    rinblw                  namelist,fdda         1              0       h        "grid_fdda"            ""      ""
+rconfig   integer xwavenum                namelist,fdda         max_domains    0       rh       "grid_fdda"            "top wave number to nudge in x direction"      ""
+rconfig   integer ywavenum                namelist,fdda         max_domains    0       rh       "grid_fdda"            "top wave number to nudge in y direction"      ""
+rconfig   integer pxlsm_soil_nudge        namelist,fdda         max_domains    0       rh       "pxlsm_soil_nudge"     "nudge pxlsm soil"      ""
+
+#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   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   integer     obs_no_pbl_nudge_uv namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_uv" "1=no wind-nudging within pbl"          ""
+rconfig   integer     obs_no_pbl_nudge_t  namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_t"  "1=no temperature-nudging within pbl"   ""
+rconfig   integer     obs_no_pbl_nudge_q  namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_q"  "1=no moisture-nudging within pbl"      ""
+rconfig   integer     obs_sfc_scheme_horiz namelist,fdda           1              0       rh       "obs_sfcscheme_horiz" "0=wrf scheme, 1=original mm5 scheme" ""
+rconfig   integer     obs_sfc_scheme_vert  namelist,fdda           1              0       rh       "obs_sfcscheme_vert"  "0=regime vif scheme, 1=original simple scheme" ""
+rconfig   real        obs_max_sndng_gap   namelist,fdda            1              20      rh       "obs_max_sndng_gap"   "Max press gap between soundings" "centibars"
+rconfig   real        obs_nudgezfullr1_uv namelist,fdda            1              50      rh       "obs_nudgezfullr1_uv" "Vert infl full weight  height for LML obs, regime 1, winds"        ""
+rconfig   real        obs_nudgezrampr1_uv namelist,fdda            1              50      rh       "obs_nudgezrampr1_uv" "Vert infl ramp-to-zero height for LML obs, regime 1, winds"        ""
+rconfig   real        obs_nudgezfullr2_uv namelist,fdda            1              50      rh       "obs_nudgezfullr2_uv" "Vert infl full weight  height for LML obs, regime 2, winds"        ""
+rconfig   real        obs_nudgezrampr2_uv namelist,fdda            1              50      rh       "obs_nudgezrampr2_uv" "Vert infl ramp-to-zero height for LML obs, regime 2, winds"        ""
+rconfig   real        obs_nudgezfullr4_uv namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_uv" "Vert infl full weight  height for LML obs, regime 4, winds"        ""
+rconfig   real        obs_nudgezrampr4_uv namelist,fdda            1              50      rh       "obs_nudgezrampr4_uv" "Vert infl ramp-to-zero height for LML obs, regime 4, winds"        ""
+rconfig   real        obs_nudgezfullr1_t  namelist,fdda            1              50      rh       "obs_nudgezfullr1_t" "Vert infl full weight  height for LML obs, regime 1, temperature"  ""
+rconfig   real        obs_nudgezrampr1_t  namelist,fdda            1              50      rh       "obs_nudgezrampr1_t" "Vert infl ramp-to-zero height for LML obs, regime 1, temperature"  ""
+rconfig   real        obs_nudgezfullr2_t  namelist,fdda            1              50      rh       "obs_nudgezfullr2_t" "Vert infl full weight  height for LML obs, regime 2, temperature"  ""
+rconfig   real        obs_nudgezrampr2_t  namelist,fdda            1              50      rh       "obs_nudgezrampr2_t" "Vert infl ramp-to-zero height for LML obs, regime 2, temperature"  ""
+rconfig   real        obs_nudgezfullr4_t  namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_t" "Vert infl full weight  height for LML obs, regime 4, temperature"  ""
+rconfig   real        obs_nudgezrampr4_t  namelist,fdda            1              50      rh       "obs_nudgezrampr4_t" "Vert infl ramp-to-zero height for LML obs, regime 4, temperature"  ""
+rconfig   real        obs_nudgezfullr1_q  namelist,fdda            1              50      rh       "obs_nudgezfullr1_q" "Vert infl full weight  height for LML obs, regime 1, moisture"     ""
+rconfig   real        obs_nudgezrampr1_q  namelist,fdda            1              50      rh       "obs_nudgezrampr1_q" "Vert infl ramp-to-zero height for LML obs, regime 1, moisture"     ""
+rconfig   real        obs_nudgezfullr2_q  namelist,fdda            1              50      rh       "obs_nudgezfullr2_q" "Vert infl full weight  height for LML obs, regime 2, moisture"     ""
+rconfig   real        obs_nudgezrampr2_q  namelist,fdda            1              50      rh       "obs_nudgezrampr2_q" "Vert infl ramp-to-zero height for LML obs, regime 2, moisture"     ""
+rconfig   real        obs_nudgezfullr4_q  namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_q" "Vert infl full weight  height for LML obs, regime 4, moisture"     ""
+rconfig   real        obs_nudgezrampr4_q  namelist,fdda            1              50      rh       "obs_nudgezrampr4_q" "Vert infl ramp-to-zero height for LML obs, regime 4, moisture"     ""
+rconfig   real        obs_nudgezfullmin   namelist,fdda            1                 50   rh       "obs_nudgezfullmin" "Minimum depth through which vertical influence fcn remains 1.0"     "m"
+rconfig   real        obs_nudgezrampmin   namelist,fdda            1                 50   rh       "obs_nudgezrampmin" "Minimum depth through which vertical influence fcn decreases from 1.0 to 0.0" "m"
+rconfig   real        obs_nudgezmax       namelist,fdda            1               3000   rh       "obs_nudgezmax" "Maximum depth in which vertical influence function is nonzero" "m"
+rconfig   real        obs_sfcfact         namelist,fdda            1              1.0     h        "obs_sfcfact"       "Scale factor applied to time window for surface obs"     ""
+rconfig   real        obs_sfcfacr         namelist,fdda            1              1.0     h        "obs_sfcfacr"       "Scale factor applied to horiz radius of influence for surface obs"     ""
+rconfig   real        obs_dpsmx           namelist,fdda            1              7.5     h        "obs_dpsmx"         "Max pressure change allowed within horiz radius of influence"     "centibars"
+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            max_domains    0       rh       "obs_twindo"        "Half-period time window for nudging"  "hrs"
+rconfig   integer     obs_npfi            namelist,fdda            1              0       h        "obs_npfi"          "Freq in cg timesteps for diag print"  ""
+rconfig   integer     obs_ionf            namelist,fdda            max_domains    1       rh       "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   integer     obs_prt_max         namelist,fdda            1              1000    rh       "obs_prt_max"       "Maximum allowed obs entries in diagnostic printout"      ""
+rconfig   integer     obs_prt_freq        namelist,fdda            max_domains    1000    rh       "obs_prt_freq"      "Frequency in obs index for diagnostic printout."   ""
+rconfig   logical     obs_ipf_in4dob      namelist,fdda            1              .false. h        "obs_ipf_in4dob"    "Print obs input diagnostics"   ""
+rconfig   logical     obs_ipf_errob       namelist,fdda            1              .false. h        "obs_ipf_errob"     "Print obs error diagnostics"   ""
+rconfig   logical     obs_ipf_nudob       namelist,fdda            1              .false. h        "obs_ipf_nudob"     "Print obs nudge diagnostics"   ""
+rconfig   logical     obs_ipf_init        namelist,fdda            1              .true.  h        "obs_ipf_init"      "Enable obs init warning messages"   ""
+
+# Single-column model (SCM)
+rconfig   integer scm_force               namelist,scm  1       0           rh   "scm_force"            "SCM forcing switch" ""
+rconfig   real    scm_force_dx            namelist,scm  1       4000.       rh   "scm_force_dx"         "DX for SCM forcing" "m"
+rconfig   integer num_force_layers        namelist,scm  1       8           rh   "num_force_layers"     "Number of SCM forcing layers" ""
+rconfig   integer scm_lu_index            namelist,scm  1       2           rh   "scm_lu_index"         "SCM landuse index" ""
+rconfig   integer scm_isltyp              namelist,scm  1       4           rh   "scm_isltyp"           "SCM soil category" ""
+rconfig   real    scm_vegfra              namelist,scm  1       0.5         rh   "scm_vegfra"           "SCM vegetation fraction" ""
+rconfig   integer scm_canwat              namelist,scm  1       0.0         rh   "scm_canwat"           "SCM canopy water" "kg m-2"
+rconfig   real    scm_lat                 namelist,scm  1        36.605     rh   "scm_lat"              "SCM latitude" "degrees"
+rconfig   real    scm_lon                 namelist,scm  1       -97.485     rh   "scm_lon"              "SCM longitude" "degrees"
+rconfig   logical scm_th_adv              namelist,scm  1       .true.      rh   "scm_th_adv"           "Turn on theta advection in SCM"      ""
+rconfig   logical scm_wind_adv            namelist,scm  1       .true.      rh   "scm_wind_adv"         "Turn on wind advection in SCM"      ""
+rconfig   logical scm_qv_adv              namelist,scm  1       .true.      rh   "scm_qv_adv"           "Turn on qv advection in SCM"      ""
+rconfig   logical scm_ql_adv              namelist,scm  1       .false.     rh   "scm_ql_adv"           "Turn on ql advection in SCM"      ""
+rconfig   logical scm_vert_adv            namelist,scm  1       .true.      rh   "scm_vert_adv"         "Turn on vertical advection in SCM"      ""
+rconfig   integer num_force_soil_layers   namelist,scm  1       5           rh   "num_force_soil_layers" "Number of SCM soil forcing layers" ""
+rconfig   logical scm_soilT_force         namelist,scm  1       .false.     rh   "scm_soilT_force"      "Turn on soil temp forcing in SCM"      ""
+rconfig   logical scm_soilq_force         namelist,scm  1       .false.     rh   "scm_soilq_force"      "Turn on soil moisture forcing in SCM"      ""
+rconfig   logical scm_force_th_largescale namelist,scm  1       .false.     rh   "scm_force_th_largescale" "Turn on large scale theta forcing in SCM"      ""
+rconfig   logical scm_force_qv_largescale namelist,scm  1       .false.     rh   "scm_force_qv_largescale" "Turn on large scale qv forcing in SCM"      ""
+rconfig   logical scm_force_ql_largescale namelist,scm  1       .false.     rh   "scm_force_ql_largescale" "Turn on large scale ql forcing in SCM"      ""
+rconfig   logical scm_force_wind_largescale namelist,scm  1     .false.     rh   "scm_force_wind_largescale" "Turn on large scale wind forcing in SCM"      ""
+
+# Dynamics
+# dynamics option (see package definitions, below)
+rconfig   integer dyn_opt                 namelist,dynamics	1             2 
+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"                ""      ""
+# km_opt_dfi is needed for backward integration in dfi
+rconfig   integer km_opt_dfi              namelist,dynamics	1             1       irh    "km_opt_dfi"                ""      ""
+rconfig   integer damp_opt                namelist,dynamics	1             0       irh    "damp_opt"              ""      ""
+rconfig   integer rad_nudge               namelist,dynamics	1             0       irh    "rad_nudge"             ""      ""
+rconfig   integer gwd_opt                 namelist,dynamics    1             0       irh    "gwd_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    c_s                     namelist,dynamics     max_domains    0.25    h    "c_s"         "Smagorinsky coeff"      ""
+rconfig   real    c_k                     namelist,dynamics     max_domains    0.15    h    "c_k"         "TKE coeff"      ""
+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   integer  moist_adv_opt          namelist,dynamics	max_domains    1       rh    "moist_adv_opt"         "positive-definite RK3 transport switch"      ""
+rconfig   integer  moist_adv_dfi_opt      namelist,dynamics	max_domains    0       rh    "moist_adv_dfi_opt"    "positive-definite RK3 transport switch"      ""
+rconfig   integer  chem_adv_opt           namelist,dynamics	max_domains    1       rh    "chem_adv_opt"          "positive-definite RK3 transport switch"      ""
+rconfig   integer  tracer_adv_opt         namelist,dynamics     max_domains    1       rh    "tracer_adv_opt"        "positive-definite RK3 transport switch"      ""
+rconfig   integer  scalar_adv_opt         namelist,dynamics	max_domains    1       rh    "scalar_adv_opt"        "positive-definite RK3 transport switch"      ""
+rconfig   integer  tke_adv_opt            namelist,dynamics	max_domains    1       rh    "tke_adv_opt"           "positive-definite RK3 transport switch"      ""
+rconfig   logical top_radiation           namelist,dynamics	max_domains    .false. rh    "top_radiation"         ""      ""
+rconfig   integer mix_isotropic           namelist,dynamics     max_domains    0       h    "mix_isotropic"            "0=anistropic, 1=isotropic"      ""
+rconfig   real    mix_upper_bound         namelist,dynamics     max_domains    0.1     h    "mix_upper_bound"          "non-dimensional limit"      ""
+rconfig   logical top_lid                 namelist,dynamics     max_domains    .false. rh    "top_lid"               ""      ""
+rconfig   real    tke_upper_bound         namelist,dynamics	max_domains    1000.   h    "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 coriolis2d              namelist,dynamics	max_domains  .false.  irh  "coriolis2d"    ""   ""
+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"
+rconfig   real    iso_temp                namelist,dynamics     1               0.     h    "iso_temp"   "Isothermal temperature in stratosphere, real only"      "K"
+rconfig   logical use_baseparam_fr_nml    namelist,dynamics     1            .false.  irh   "use_baseparam_fr_nml"    ""   ""
+rconfig   real    fft_filter_lat          namelist,dynamics     1              91.     h    "fft_filter_lat"   ""   "grid latitude to start polar filter"
+rconfig   logical rotated_pole            namelist,dynamics     1            .false.  irh   "rotated_pole"    ""   ""
+rconfig   logical do_coriolis             namelist,dynamics	max_domains  .true.   irh  "do_coriolis"    ""   ""
+rconfig   logical do_curvature            namelist,dynamics	max_domains  .true.   irh  "do_curvature"   ""   ""
+rconfig   logical do_gradp                namelist,dynamics	max_domains  .true.   irh  "do_gradp"    ""   ""
+rconfig   integer tracer_opt              namelist,dynamics     max_domains    0       rh    "tracer_opt"          ""      ""
+# Placeholder for decoupled advective tendency diagnostics
+rconfig   integer tenddiag                namelist,dynamics     max_domains    0       -     "Decoupled tendency diagnostics"   ""    ""
+
+
+# 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 constant_bc             namelist,bdy_control          1      .false. rh    "constant_bc"           ""      ""
+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 polar                   namelist,bdy_control	max_domains    .false. rh    "polar"                 ""      ""
+rconfig   logical nested                  namelist,bdy_control	max_domains    .false. rh    "nested"                ""      ""
+rconfig   real    spec_exp                namelist,bdy_control          1     0.      irh    "spec_exp"              ""      ""
+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   integer nobs_ndg_vars           derived                       1         6       -        "num_ndg_vars"         "Number of nudging variables"          ""
+rconfig   integer nobs_err_flds           derived                       1         9       -        "num_err_flds"         "Number of error fields"               ""
+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    pole_lat                derived                  max_domains    0       -        "pole_lat"              "projection info: latitude of pole" "degrees, positive north"
+rconfig   real    pole_lon                derived                  max_domains    0       -        "pole_lon"              "projection info: longitude of pole" "degrees, positive east"
+rconfig   integer  FLAG_METGRID           derived                      1          0       -        "FLAG_METGRID"         "Flag in global attributes for metgrid data"
+rconfig   integer  FLAG_SNOW              derived                      1          0       -        "FLAG_SNOW"             "Flag for snow in the global attributes for metgrid data"
+rconfig   integer  FLAG_PSFC              derived                      1          0       -        "FLAG_PSFC"             "Flag for surface pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM000010          derived                      1          0       -        "FLAG_SM000010"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM010040          derived                      1          0       -        "FLAG_SM010040"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM040100          derived                      1          0       -        "FLAG_SM040100"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM100200          derived                      1          0       -        "FLAG_SM100200"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST000010          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST010040          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST040100          derived                      1          0       -        "FLAG_ST010040"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST100200          derived                      1          0       -        "FLAG_ST100200"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_SLP               derived                      1          0       -        "FLAG_SLP"              "Flag for sea level pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SOILHGT           derived                      1          0       -        "FLAG_SOILHGT"          "Flag for soil height in the global attributes for metgrid data"
+rconfig   integer  FLAG_MF_XY             derived                      1          0       -        "FLAG_MF_XY"            "Flag for MF_XYin the global attributes for metgrid data"
+rconfig   real    bdyfrq                  derived                  max_domains    0       -        "bdyfrq"               "lateral boundary input frequency"      "seconds"
+rconfig   character mminlu                derived                  max_domains    " "     -        "mminlu"               "land use dataset"             ""
+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 islake                  derived                  max_domains    0       -        "islake"               "land use index of inland lake"      "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 (Cylindrical), 1=Lambert, 2=polar, 3=Mercator"
+rconfig   integer use_wps_input           derived                       1         0       -        "use_wps_input"        "0/1 flag, using wps input"      "0=no, 1=yes"
+rconfig   integer dfi_stage               derived                  max_domains    3       -        "dfi_stage"            "current stage of DFI processing"      "0=DFI setup, 1=DFI backward integration, 2=DFI forward integration, 3=WRF forecast"
+rconfig   integer mp_physics_dfi          derived                  max_domains   -1       -        "mp_physics_dfi"       ""      "-1 = no DFI and so no need to allocate DFI moist and scalar variables, >0 = running with DFI, so allocate DFI moist and scalar variables appropriate for selected microphysics package"
+
+#
+# Single dummy declaration to define a nodyn dyn option
+state integer nodyn_dummy - dyn_nodyn -  -  -  "" "" ""      
+
+# Turbine drag (td) physics
+# Turbine positions and characteristics for real-data cases are specified in a file 
+# whose name is given in the windturbines_spec variable.  If the setting is "ideal",
+# the td_ variables specify idealized wind farm geometries and turbine characteristics.
+# If the setting is "none" then wind turbine drag physics is turned off.
+rconfig character windturbines_spec namelist,physics 1 "none" - - "" "none, ideal, or a file name"
+rconfig integer td_turbgridid  namelist,physics 1 -1     - - ""  "which grid id has turbines in it"
+rconfig  real   td_hubheight   namelist,physics 1 100.   - - ""  "hub height (m)"
+rconfig  real   td_diameter    namelist,physics 1 60.    - - ""  "turbine diameter (m)"
+rconfig  real   td_stdthrcoef  namelist,physics 1 .158   - - ""  "standing thrust coefficient"
+rconfig  real   td_cutinspeed  namelist,physics 1 4.     - - ""  "cut-in speed (m/s)"
+rconfig  real   td_cutoutspeed namelist,physics 1 27.    - - ""  "cut-out speed (m/s)"
+rconfig  real   td_power       namelist,physics 1 2.     - - ""  "turbine power (MW)"
+rconfig  real   td_turbpercell namelist,physics 1 1.     - - ""  "number of turbines per cell"
+rconfig integer td_ewfx        namelist,physics 1 0      - - ""  "extent of wind farm in x-cells"
+rconfig integer td_ewfy        namelist,physics 1 0      - - ""  "extent of wind farm in y-cells"
+rconfig integer td_pwfx        namelist,physics 1 1      - - ""  "southwest corner of wind farm in x-cells"
+rconfig integer td_pwfy        namelist,physics 1 1      - - ""  "southwest corner of wind farm in y-cells"
+
+
+#
+#---------------------------------------------------------------------------------------------------------------------------------------
+# Package Declarations
+#                                               
+
+#key      package       associated                package          associated 4d scalars
+#         name          namelist choice           state vars
+
+#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;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy
+package   wsm6scheme    mp_physics==6                -             moist:qv,qc,qr,qi,qs,qg
+package   gsfcgcescheme mp_physics==7                -             moist:qv,qc,qr,qi,qs,qg
+package   thompson      mp_physics==8                -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr
+package   milbrandt2mom mp_physics==9                -             state:refl_10cm;moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh
+package   morr_two_moment  mp_physics==10            -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng
+package   sbu_ylinscheme    mp_physics==13           -             moist:qv,qc,qr,qi,qs;state:rimi
+package   wdm5scheme    mp_physics==14               -             moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr
+package   wdm6scheme    mp_physics==16               -             moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr
+
+package   passiveqv_dfi     mp_physics_dfi==0        -             dfi_moist:dfi_qv
+package   kesslerscheme_dfi mp_physics_dfi==1        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   linscheme_dfi     mp_physics_dfi==2        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   wsm3scheme_dfi    mp_physics_dfi==3        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   wsm5scheme_dfi    mp_physics_dfi==4        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs
+package   etampnew_dfi      mp_physics_dfi==5        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt
+package   wsm6scheme_dfi    mp_physics_dfi==6        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   gsfcgcescheme_dfi mp_physics_dfi==7        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   thompson_dfi      mp_physics_dfi==8        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr
+package   milbrandt2mom_dfi mp_physics_dfi==9        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh
+package   morr_two_moment_dfi  mp_physics_dfi==10    -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng
+package   sbu_ylinscheme_dfi    mp_physics==13           -         dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;state:rimi
+package   wdm5scheme_dfi    mp_physics_dfi==14       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+package   wdm6scheme_dfi    mp_physics_dfi==16       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+
+package   noprogn       progn==0                     -             -
+package   progndrop     progn==1                     -             scalar:qndrop;dfi_scalar:dfi_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;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   rrtmg_lwscheme  ra_lw_physics==4           -             state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   goddardlwscheme  ra_lw_physics==5          -             state:tlwdn,tlwup,slwdn,slwup
+package   gfdllwscheme  ra_lw_physics==99            -             -
+package   heldsuarez    ra_lw_physics==31            -             -
+
+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;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   rrtmg_swscheme  ra_sw_physics==4           -             state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc
+package   goddardswscheme  ra_sw_physics==5          -             state:tswdn,tswup,sswdn,sswup
+package   gfdlswscheme  ra_sw_physics==99            -             -
+
+package   sfclayscheme   sf_sfclay_physics==1        -             -
+package   myjsfcscheme   sf_sfclay_physics==2        -             state:tke_pbl
+package   gfssfcscheme   sf_sfclay_physics==3        -             -
+package   qnsesfcscheme  sf_sfclay_physics==4        -             -
+package   mynnsfcscheme  sf_sfclay_physics==5        -             scalar:qke;state:tsq,qsq,cov
+package   pxsfcscheme    sf_sfclay_physics==7        -             -
+
+package   noahucmscheme  sf_urban_physics==1         -             state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep
+package   bepscheme      sf_urban_physics==2         -             state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d
+package   bep_bemscheme  sf_urban_physics==3         -             state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,sfwin1_urb3d,sfwin2_urb3d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d
+
+package   slabscheme     sf_surface_physics==1       -             -
+package   lsmscheme      sf_surface_physics==2       -             -
+package   ruclsmscheme   sf_surface_physics==3       -             state:smfr3d,keepfr3dflag,soilt1
+package   pxlsmscheme    sf_surface_physics==7       -             state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old
+package   temfsfcscheme  sf_sfclay_physics==10       -             state:wm_temf
+package   idealscmsfcscheme  sf_sfclay_physics==89   -             -
+
+package   ysuscheme      bl_pbl_physics==1           -             -
+package   myjpblscheme   bl_pbl_physics==2           -             state:tke_pbl,el_pbl
+package   gfsscheme      bl_pbl_physics==3           -             -
+package   qnsepblscheme  bl_pbl_physics==4           -             state:tke_pbl,el_pbl
+package   mynnpblscheme2 bl_pbl_physics==5           -             scalar:qke;state:tsq,qsq,cov
+package   mynnpblscheme3 bl_pbl_physics==6           -             scalar:qke;state:tsq,qsq,cov
+package   acmpblscheme   bl_pbl_physics==7           -             -
+package   boulacscheme   bl_pbl_physics==8           -             state:el_pbl,tke_pbl,wu_tur,wv_tur,wt_tur,wq_tur
+package   camuwpblscheme bl_pbl_physics==9           -             state:tauresx2d,tauresy2d,qpert2d,wpert2d,tke_pbl
+package   mrfscheme      bl_pbl_physics==99          -             -
+package   temfpblscheme  bl_pbl_physics==10          -             state:te_temf,kh_temf,km_temf,shf_temf,qf_temf,uw_temf,vw_temf,wupd_temf,mf_temf,thup_temf,qlup_temf,qtup_temf,cf3d_temf,hd_temf,lcl_temf,hct_temf,cfm_temf
+
+
+package   kfetascheme    cu_physics==1               -             -
+package   bmjscheme      cu_physics==2               -             -
+package   gdscheme       cu_physics==3               -             -
+package   sasscheme      cu_physics==4               -             -
+package   g3scheme       cu_physics==5               -             state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow
+package   camzmscheme    cu_physics==7               -             state:precz,zmdt,zmdq,zmdice,zmdliq,evaptzm,fzsntzm,evsntzm,evapqzm,zmflxprc,zmflxsnw,zmntprpd,zmntsnpd,zmeiheat,cmfmc,cmfmcdzm,preccdzm,pconvb,pconvt,cape,zmmtu,zmmtv,zmmu,zmmd,zmupgu,zmupgd,zmvpgu,zmvpgd,zmicuu,zmicud,zmicvu,zmicvd
+package   g3tave         cu_diag==1                  -             state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,RAINCV_A,RAINCV_B,GD_CLOUD_A,GD_CLOUD_B,GD_CLOUD2_A,GD_CLOUD2_B,kbcon_deep,ktop_deep,k22_deep
+package   tiedtkescheme  cu_physics==6               -             -
+package   nsasscheme     cu_physics==14              -             -
+package   kfscheme       cu_physics==99              -             -
+
+package   g3shcuscheme   shcu_physics==1             -             -
+package   camuwshcuscheme shcu_physics==2            -             state:cmfmc2,qtflx_cu,slflx_cu,uflx_cu,vflx_cu,qtten_cu,slten_cu,uten_cu,vten_cu,qvten_cu,qlten_cu,qiten_cu,cbmf_cu,ufrcinvbase_cu,ufrclcl_cu,winvbase_cu,wlcl_cu,plcl_cu,pinv_cu,plfc_cu,pbup_cu,ppen_cu,qtsrc_cu,thlsrc_cu,thvlsrc_cu,emkfbup_cu,cin_cu,cinlcl_cu,cbmflimit_cu,tkeavg_cu,zinv_cu,rcwp_cu,rlwp_cu,riwp_cu,tophgt_cu,wu_cu,ufrc_cu,qtu_cu,thlu_cu,thvu_cu,uu_cu,vu_cu,qtu_emf_cu,thlu_emf_cu,uu_emf_cu,vu_emf_cu,umf_cu,uemf_cu,qcu_cu,qlu_cu,qiu_cu,cufrc_cu,fer_cu,fdr_cu,dwten_cu,diten_cu,qrten_cu,qsten_cu,flxrain_cu,flxsnow_cu,ntraprd_cu,ntsnprd_cu,excessu_cu,excessu0_cu,xc_cu,aquad_cu,bquad_cu,cquad_cu,bogbot_cu,bogtop_cu,exit_uwcu_cu,exit_conden_cu,exit_klclmkx_cu,exit_klfcmkx_cu,exit_ufrc_cu,exit_wtw_cu,exit_drycore_cu,exit_wu_cu,exit_cufliter_cu,exit_kinv1_cu,exit_rei_cu,limit_shcu_cu,limit_negcon_cu,limit_ufrc_cu,limit_ppen_cu,limit_emf_cu,limit_cinlcl_cu,limit_cin_cu,limit_cbmf_cu,limit_rei_cu,ind_delcin_cu,evapcsh,cmfsl,cmflq,cldfrash,cush,icwmrsh,snowsh,rprdsh,rliq2
+
+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;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten
+package   psusfddagd     grid_sfdda==1               -             state:u10_ndg_old,v10_ndg_old,t2_ndg_old,th2_ndg_old,q2_ndg_old,rh_ndg_old,psl_ndg_old,ps_ndg_old,u10_ndg_new,v10_ndg_new,t2_ndg_new,th2_ndg_new,q2_ndg_new,rh_ndg_new,psl_ndg_new,ps_ndg_new,tob_ndg_old,odis_ndg_old,tob_ndg_new,odis_ndg_new
+
+package   spnudging      grid_fdda==2               -              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;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten
+
+package   slopeopt       slope_rad==1               -              -
+package   gwdopt         gwd_opt==1                 -              state:var2d,oc12d,oa1,oa2,oa3,oa4,ol1,ol2,ol3,ol4,dtaux3d,dtauy3d,dusfcg,dvsfcg
+package   omlopt         omlcall==1                 -              state:tml,t0ml,hml,h0ml,huml,hvml,tmoml
+package   scmopt         scm_force==1               -              state:z_force,z_force_tend,u_g,u_g_tend,v_g,v_g_tend,w_subs,w_subs_tend,th_upstream_x,th_upstream_x_tend,th_upstream_y,th_upstream_y_tend,qv_upstream_x,qv_upstream_x_tend,qv_upstream_y,qv_upstream_y_tend,u_upstream_x,u_upstream_x_tend,u_upstream_y,u_upstream_y_tend,v_upstream_x,v_upstream_x_tend,v_upstream_y,v_upstream_y_tend,tau_x,tau_x_tend,tau_y,tau_y_tend,th_largescale,th_largescale_tend,qv_largescale,qv_largescale_tend,ql_largescale,ql_largescale_tend,u_largescale,u_largescale_tend,v_largescale,v_largescale_tend,tau_largescale,tau_largescale_tend,ql_upstream_x,ql_upstream_x_tend,ql_upstream_y,ql_upstream_y_tend,t_soil_forcing_val,t_soil_forcing_tend,q_soil_forcing_val,q_soil_forcing_tend,tau_soil,soil_depth_force
+
+package   prec_acc       prec_acc_opt==1            -              state:prec_acc_c,prec_acc_nc,snow_acc_nc
+package   bucketropt     bucketr_opt==1             -              state:i_rainc,i_rainnc
+
+package   restofwrf      use_wps_input==0            -             -
+
+package   original       moist_adv_opt==0            -             -
+package   positivedef    moist_adv_opt==1            -             -
+package   monotonic      moist_adv_opt==2            -             -
+
+package   dfi_setup      dfi_stage==0                -             -
+package   dfi_bck        dfi_stage==1                -             -
+package   dfi_fwd        dfi_stage==2                -             -
+package   dfi_fst        dfi_stage==3                -             -
+package   dfi_startfwd   dfi_stage==4                -             -
+package   dfi_startbck   dfi_stage==5                -             -
+
+#package   digifilter     dfi_opt==1                  -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_rh,dfi_tten_rad
+package   dfi_nodfi     dfi_opt==0                  -             -
+package   dfi_dfl       dfi_opt==1                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   dfi_ddfi      dfi_opt==2                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   dfi_tdfi      dfi_opt==3                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   realonly       use_wps_input==1            -             state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc
+                                                
+# 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                     -             -
+             
+# Tendency diagnostics for non-chemistry
+#
+# Placeholders for decoupled advective tendency arrays
+package   notenddiag    tenddiag==0                     -             -
+package   usetenddiag   tenddiag==1                     -             -
+                                   
+#---------------------------------------------------------------------------------------------------------------------------------------
+## 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,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,f,e,sina,cosa,ht,potevp,snopcx,soiltb,xlat,xlong,xlat_u,xlat_v,xlong_u,xlong_v,clat,clong
+halo      HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar,tracer
+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_PHYS_CU dyn_em         4:rucuten,rvcuten
+halo      HALO_EM_PHYS_SHCU dyn_em       4:rushten,rvshten
+halo      HALO_EM_FDDA dyn_em            4:rundgdten,rvndgdten
+halo      HALO_EM_FDDA_SFC dyn_em 48:z,z_at_w,pblh,regime,znt,odis_ndg_old,odis_ndg_new
+halo      HALO_EM_PHYS_DIFFUSION dyn_em  4:defor11,defor22,defor12,defor13,defor23,div,xkmv,xkmh,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,ustm
+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,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,muts
+halo      HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,tracer,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,tracer,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,tracer,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,tracer,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_CUP_G3_IN dyn_em 24:RTHFTEN,RQVFTEN,w_2,t_phy
+halo      HALO_CUP_G3_OUT dyn_em 48:cugd_tten,cugd_qvten,cugd_ttens,cugd_qvtens,raincv
+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_TRACER_E_3 dyn_em 24:tracer
+halo      HALO_EM_TRACER_E_5 dyn_em 48:tracer
+halo      HALO_EM_TRACER_E_7 dyn_em 80:tracer
+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_TOPOSHAD phys 24:ht_shad
+
+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_TRACER_OLD_E_3 dyn_em 24:tracer_old
+halo      HALO_EM_TRACER_OLD_E_5 dyn_em 48:tracer_old
+halo      HALO_EM_TRACER_OLD_E_7 dyn_em 80:tracer_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_HYDRO_UV   dyn_em 8:u_2,v_2
+
+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,tracer,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,tracer,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:ph_2,p,uratx,vratx,tratx,kpbl
+
+# 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,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,sina,cosa,e,f
+
+# Monotonic, positive definite advection requires 4 values for moist, chem, tke, and scalar for periodic lateral boundaries
+
+period    PERIOD_BDY_EM_MOIST dyn_em 4:moist
+period    PERIOD_BDY_EM_CHEM dyn_em 4:chem
+period    PERIOD_BDY_EM_TRACER dyn_em 4:tracer
+period    PERIOD_BDY_EM_SCALAR dyn_em 4:scalar
+period    PERIOD_BDY_EM_TKE dyn_em 4:tke_2
+period    PERIOD_BDY_EM_MOIST2 dyn_em 4:moist
+period    PERIOD_BDY_EM_CHEM2 dyn_em 4:chem
+period    PERIOD_BDY_EM_TRACER2 dyn_em 4:tracer
+period    PERIOD_BDY_EM_SCALAR2 dyn_em 4:scalar
+period    PERIOD_BDY_EM_MOIST_OLD dyn_em 4:moist_old
+period    PERIOD_BDY_EM_CHEM_OLD dyn_em 4:chem_old
+period    PERIOD_BDY_EM_TRACER_OLD dyn_em 4:tracer_old
+period    PERIOD_BDY_EM_SCALAR_OLD dyn_em 4:scalar_old
+period    PERIOD_BDY_EM_TKE_OLD dyn_em 4:tke_1
+
+period    PERIOD_BDY_EM_E dyn_em 2:u_2,v_2,ht
+period    PERIOD_EM_HYDRO_UV dyn_em 1:u_2,v_2
+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,ustm
+period    PERIOD_BDY_EM_PHY_BC dyn_em 2:rublten,rvblten,rucuten,rvcuten,xkmh,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,msfvx,msfvy,muu,msfux,msfuy,msfvx_inv
+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
+period    PERIOD_EM_DA dyn_em 2:ru_m,rv_m,ww_m,mut,muts
+
+#
+#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 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 NSTAW        # number of obs stations within current time window
+typedef fdob_type integer KTAUR        # restart model step
+typedef fdob_type integer LEVIDN(max_domains)   # level of nest
+typedef fdob_type integer REFPRT(max_domains)   # reference obs index for diagnostic printout
+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 logical NUDGE_UV_PBL # Flag for wind nudging within the PBL
+typedef fdob_type logical NUDGE_T_PBL  # Flag for temperature nudging within the PBL
+typedef fdob_type logical NUDGE_Q_PBL  # Flag for moisture nudging within the PBL
+typedef fdob_type integer SFC_SCHEME_HORIZ # Flag for horizontal spreading scheme for surface obs
+typedef fdob_type integer SFC_SCHEME_VERT  # Flag for vertical   spreading scheme for surface obs
+typedef fdob_type real    MAX_SNDNG_GAP # Maximum pressure gap allowed for interpolating between soundings (centibars)
+typedef fdob_type real    SFCFACT      # scale factor applied to time window for surface obs
+typedef fdob_type real    SFCFACR      # scale factor applied to horiz radius of influence for surface obs
+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    KNOWN_LAT    # Latitude  of origin point (i,j)=(1,1)
+typedef fdob_type real    KNOWN_LON    # Longitude of origin point (i,j)=(1,1)
+typedef fdob_type character SDATE      # domain starting date (YYYY-MM-DD_hh:mm:ss)
+typedef fdob_type real    XTIME_AT_REST # xtime at restart time
+typedef fdob_type real    VIF_UV(6)    # Vertical influence function parameters for wind nudging
+typedef fdob_type real    VIF_T(6)     # Vertical influence function parameters for temperature nudging
+typedef fdob_type real    VIF_Q(6)     # Vertical influence function parameters for moisture nudging
+typedef fdob_type real    VIF_FULLMIN  # Minimum depth through which vert infl fcn remains 1.0 (m)
+typedef fdob_type real    VIF_RAMPMIN  # Minimum depth through which vif decreases 1.0 to 0.0 (m)
+typedef fdob_type real    VIF_MAX      # Maximum depth in which vif is nonzero (m)
+
+# table entries are of the form
+#      <Table>  <Type>  <Sym>                <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>
+#Grid variables
+typedef fdob_type real    varobs       {nndgvar}{obs}   -         1        -       -       "varobs"          "observational values in each variable"
+typedef fdob_type real    errf                 h{obs}   -         1        -       -       "errf"            "errors between model and obs values"
+typedef fdob_type real    timeob               {obs}    -         1        -       -       "timeob"          "model times for each observation"          "hours"
+typedef fdob_type real    nlevs_ob             {obs}    -         1        -       -       "nlevs_ob"        "numbers of levels in sounding obs"
+typedef fdob_type real    lev_in_ob            {obs}    -         1        -       -       "lev_in_ob"       "level in sounding-type obs"
+typedef fdob_type real    plfo                 {obs}    -         1        -       -       "plfo"            "index for type of obs-platform"
+typedef fdob_type real    elevob               {obs}    -         1        -       -       "elevob"          "elevation of observation"                  "meters"
+typedef fdob_type real    rio                  {obs}    -         1        -       -       "rio"             "west-east grid coordinate"
+typedef fdob_type real    rjo                  {obs}    -         1        -       -       "rjo"             "south-north grid coordinate"
+typedef fdob_type real    rko                  {obs}    -         1        -       -       "rko"             "vertical grid coordinate"
+typedef fdob_type integer obsprt               [        -         1        -       -       "obsprt"          "obs index for diagnostic printout"
+typedef fdob_type real    latprt               [        -         1        -       -       "latprt"          "obs latitude for diagnostic printout"
+typedef fdob_type real    lonprt               [        -         1        -       -       "lonprt"          "obs longitude for diagnostic printout"
+typedef fdob_type real    mlatprt              [        -         1        -       -       "mlatprt"         "model latitude at obs location"
+typedef fdob_type real    mlonprt              [        -         1        -       -       "mlonprt"         "model longitude at obs location"
+typedef fdob_type integer stnidprt       {obsstid}{[}   -         1        -       -       "stnidprt"        "obs station id for diagnostic printout"
+typedef fdob_type real    base_state           k        -         1        -       -       "base_state"      "base-state height on half (mass) levels"   "meters"
+
+state fdob_type fdob - -
+
+# xpose variables for polar fft
+state    real   t_xxx          ikjx    -           1        -
+state    real   u_xxx          ikjx    -           1        X
+state    real   ru_xxx         ikjx    -           1        X
+state    real   v_xxx          ikjx    -           1        Y
+state    real   rv_xxx         ikjx    -           1        Y
+state    real   w_xxx          ikjx    -           1        Z
+state    real   ww_xxx         ikjx    -           1        Z
+state    real   ph_xxx         ikjx    -           1        Z
+state    real   dum_yyy        ikjy    -           1        -
+state    real   fourd_xxx      ikjx    -           1        -
+state    real   clat_xxx       ijx     -           1        -
+state    real   ht_xxx         ijx     -           1        -
+state    real   mf_xxx         ijx     -           1        -
+
+xpose XPOSE_POLAR_FILTER_TOPO dyn_em t_init,t_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_T  dyn_em t_2,t_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_U  dyn_em u_2,u_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_RU dyn_em ru_m,ru_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_V  dyn_em v_2,v_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_RV dyn_em rv_m,rv_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_W  dyn_em w_2,w_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_WW dyn_em ww_m,ww_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_PH dyn_em ph_2,ph_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_MOIST dyn_em moist,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_CHEM dyn_em chem,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_TRACER dyn_em tracer,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_SCALAR dyn_em scalar,fourd_xxx,dum_yyy
+
+# xpose variables for spectral nudging
+state    real   dif_analysis     ikj     -           1
+state    real   dif_xxx          ikjx    -           1
+state    real   dif_yyy          ikjy    -           1
+
+xpose XPOSE_SPECTRAL_NUDGING dyn_em dif_analysis,dif_xxx,dif_yyy
+##
+
+include registry.fire
+include registry.avgflx
+include registry.stoch
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM_SST
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM_SST	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.EM_SST	(revision 17)
@@ -0,0 +1,2226 @@
+#  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=<variable name>".  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.
+#
+
+include registry.dimspec
+
+################################################################################
+################################################################################
+################################################################################
+
+#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                                         
+#<Table> <Type> <Sym>         <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>   
+#
+
+# 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         -     i012rh01d=(interp_fcnm)u=(copy_fcnm)   "LU_INDEX"              "LAND USE CATEGORY"         ""
+state    real  LU_MASK          ij      misc        1         -     i3h1     "LU_MASK"              "0 land 1 water"         ""
+
+# znw, znu, dzs, and zs must be listed before any 3-d fields
+# in order for the grib output module to work correctly.  The grib output
+# module retrieves the vertical levels from these parameters.  If znw, znu
+# dzs, and zs are not listed first, vertical level will not be encoded at 
+# time 0.
+
+state    real    znu            k       dyn_em      1         -     irh       "znu"  "eta values on half (mass) levels"  ""
+state    real    znw            k       dyn_em      1         Z     i0rh     "znw"  "eta values on full (w) levels"  ""
+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"
+
+#
+# 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   prho_gc        igj      dyn_em      1        Z     i1  "PTHETA" "for UM data, from metgrid this is ptheta, but swapped to prho in real" "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   sct_dom_gc     ij       dyn_em      1        -     i1  "SCT_DOM"  "Dominant soil (top) category from GEOGRID"  "cat"
+state    real   scb_dom_gc     ij       dyn_em      1        -     i1  "SCB_DOM"  "Dominant soil (bottom) category from GEOGRID"  "cat"
+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   pdrho_gc       igj      dyn_em      1        Z     -   "PDRHO"    "dry pressure for UM data for the variables U and V"   "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   sh_gc          igj      dyn_em      1        Z     i1  "SPECHUMD"  "Specific humidity"        "kg kg-1"
+state    real   icefrac_gc     ij       dyn_em      1        -     i1  "ICEFRAC"  "Sea ice fraction"  "0 - 1 fraction"
+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"
+state    real   qh_gc          igj      dyn_em      1        Z     i1  "QH"    "hail mixing ratio"   "kg kg-1"
+state    real   qni_gc         igj      dyn_em      1        Z     i1  "QNI"   "ice no concentration"   "m-3"
+
+#-----------------------------------------------------------------------------------------------------------------------------------------------------------------
+#                                               
+# Variables for Eulerian mass coordinate dynamics                                            
+#                                               
+
+
+# Velocities
+#
+# U Vel
+state    real   u              ikjb     dyn_em      2         X     \
+     i0rhusdf=(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"
+state    real   z_force        |       dyn_em      1         -      i3rh     "Z_FORCE" "height of forcing input" "m"
+state    real   z_force_tend   |       dyn_em      1         -      i3rh     "Z_FORCE_TEND" "tendency height of forcing input" "m"
+state    real   u_g            |       dyn_em      1         -      i3rh     "U_G" "x-direction geostrophic wind" "m s-1"
+state    real   u_g_tend       |       dyn_em      1         -      i3rh     "U_G_TEND" "tendency x-direction geostrophic wind" "m s-1"
+#                                               
+# V Vel
+state    real   v              ikjb     dyn_em      2         Y     \
+     i0rhusdf=(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"                   
+state    real   v_g            |       dyn_em      1         -      i3rh     "V_G" "y-direction geostrophic wind" "m s-1"
+state    real   v_g_tend       |       dyn_em      1         -      i3rh     "V_G_TEND" "tendency y-direction geostrophic wind" "m s-1"
+#                                               
+# 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                                          
+
+state    real   w_subs         |       dyn_em      1         -      i3rh      "W_SUBS" "large-scale vertical velocity" "m s-1"
+state    real   w_subs_tend    |       dyn_em      1         -      i3rh      "W_SUBS_TEND" "tendency large-scale vertical velocity" "m s-1"
+
+# 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         -      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         -     \
+       i0rhusdf=(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         -  
+i1       real   t_2save        ikj     dyn_em      1         -   
+state    real   t_save         ikj     dyn_em      1         -      -        "t_save"
+
+state    real   th_upstream_x       |     dyn_em      1      -      i3rh     "TH_UPSTREAM_X" "upstream theta x-advection" "K s-1"
+state    real   th_upstream_x_tend  |     dyn_em      1      -      i3rh     "TH_UPSTREAM_X_TEND" "tendency upstream theta x-advection" "K s-2"
+state    real   th_upstream_y       |     dyn_em      1      -      i3rh     "TH_UPSTREAM_Y" "upstream theta y-advection" "K s-1"
+state    real   th_upstream_y_tend  |     dyn_em      1      -      i3rh     "TH_UPSTREAM_Y_TEND" "tendency upstream theta y-advection" "K s-2"
+
+state    real   qv_upstream_x       |     dyn_em      1      -      i3rh     "QV_UPSTREAM_X" "upstream qv x-advection" "kg kg-1 s-1"
+state    real   qv_upstream_x_tend  |     dyn_em      1      -      i3rh     "QV_UPSTREAM_X_TEND" "tendency upstream qv x-advection" "kg kg-1 s-2"
+state    real   qv_upstream_y       |     dyn_em      1      -      i3rh     "QV_UPSTREAM_Y" "upstream qv y-advection" "kg kg-1 s-1"
+state    real   qv_upstream_y_tend  |     dyn_em      1      -      i3rh     "QV_UPSTREAM_Y_TEND" "tendency upstream qv y-advection" "kg kg-1 s-2"
+
+state    real   ql_upstream_x       |     dyn_em      1      -      i3rh     "QL_UPSTREAM_X" "upstream ql x-advection" "kg kg-1 s-1"
+state    real   ql_upstream_x_tend  |     dyn_em      1      -      i3rh     "QL_UPSTREAM_X_TEND" "tendency upstream ql x-advection" "kg kg-1 s-2"
+state    real   ql_upstream_y       |     dyn_em      1      -      i3rh     "QL_UPSTREAM_Y" "upstream ql y-advection" "kg kg-1 s-1"
+state    real   ql_upstream_y_tend  |     dyn_em      1      -      i3rh     "QL_UPSTREAM_Y_TEND" "tendency upstream ql y-advection" "kg kg-1 s-2"
+
+state    real   u_upstream_x        |     dyn_em      1      -      i3rh     "U_UPSTREAM_X" "upstream u x-advection" "m s-2"
+state    real   u_upstream_x_tend   |     dyn_em      1      -      i3rh     "U_UPSTREAM_X_TEND" "tendency upstream u x-advection" "m s-3"
+state    real   u_upstream_y        |     dyn_em      1      -      i3rh     "U_UPSTREAM_Y" "upstream u y-advection" "m s-2"
+state    real   u_upstream_y_tend   |     dyn_em      1      -      i3rh     "U_UPSTREAM_Y_TEND" "tendency upstream u y-advection" "m s-3"
+
+state    real   v_upstream_x        |     dyn_em      1      -      i3rh     "V_UPSTREAM_X" "upstream v x-advection" "m s-2"
+state    real   v_upstream_x_tend   |     dyn_em      1      -      i3rh     "V_UPSTREAM_X_TEND" "tendency upstream v x-advection" "m s-3"
+state    real   v_upstream_y        |     dyn_em      1      -      i3rh     "V_UPSTREAM_Y" "upstream v y-advection" "m s-2"
+state    real   v_upstream_y_tend   |     dyn_em      1      -      i3rh     "V_UPSTREAM_Y_TEND" "tendency upstream v y-advection" "m s-3"
+state    real   th_largescale       |     dyn_em      1      -      i3rh     "TH_LARGESCALE" "SCM largescale theta" "K"
+state    real   th_largescale_tend  |     dyn_em      1      -      i3rh     "TH_LARGESCALE_TEND" "SCM tendency largescale theta" "K s-1"
+
+state    real   qv_largescale       |     dyn_em      1      -      i3rh     "QV_LARGESCALE" "SCM largescale qv" "kg kg-1 s-1"
+state    real   qv_largescale_tend  |     dyn_em      1      -      i3rh     "QV_LARGESCALE_TEND" "SCM tendency largescale qv" "kg kg-1 s-2"
+
+state    real   ql_largescale       |     dyn_em      1      -      i3rh     "QL_LARGESCALE" "SCM largescale ql" "kg kg-1 s-1"
+state    real   ql_largescale_tend  |     dyn_em      1      -      i3rh     "QL_LARGESCALE_TEND" "SCM tendency largescale ql" "kg kg-1 s-2"
+
+state    real   u_largescale        |     dyn_em      1      -      i3rh     "U_LARGESCALE" "SCM largescale u" "m s-2"
+state    real   u_largescale_tend   |     dyn_em      1      -      i3rh     "U_LARGESCALE_TEND" "SCM tendency largescale u" "m s-3"
+
+state    real   v_largescale        |     dyn_em      1      -      i3rh     "V_LARGESCALE" "SCM largescale v" "m s-2"
+state    real   v_largescale_tend   |     dyn_em      1      -      i3rh     "V_LARGESCALE_TEND" "SCM tendency largescale v" "m s-3"
+
+state    real   tau_largescale       |     dyn_em      1      -      i3rh     "TAU_LARGESCALE" "SCM largescale timescale" "s"
+state    real   tau_largescale_tend  |     dyn_em      1      -      i3rh     "TAU_LARGESCALE_TEND" "SCM tendency largescale timescale" ""
+
+state    real   tau_x               |     dyn_em      1      -      i3rh     "TAU_X" "X-direction advective timescale" "s"
+state    real   tau_x_tend          |     dyn_em      1      -      i3rh     "TAU_X_TEND" "tendency X-direction advective timescale" ""
+state    real   tau_y               |     dyn_em      1      -      i3rh     "TAU_Y" "Y-direction advective timescale" "s"
+state    real   tau_y_tend          |     dyn_em      1      -      i3rh     "TAU_Y_TEND" "tendency Y-direction advective timescale" ""
+
+dimspec  fslay  2     namelist=num_force_soil_layers    z     force_soil_layers
+state    real   t_soil_forcing_val  {fslay}     dyn_em      1      -      i3rh     "T_SOIL_FORCING_VAL" "Soil temp value for SCM forcing" "K"
+state    real   t_soil_forcing_tend {fslay}     dyn_em      1      -      i3rh     "T_SOIL_FORCING_TEND" "tendency soil temp for SCM forcing" "K s-1"
+state    real   q_soil_forcing_val  {fslay}     dyn_em      1      -      i3rh     "Q_SOIL_FORCING_VAL" "Soil moisture value for SCM forcing" "1"
+state    real   q_soil_forcing_tend {fslay}     dyn_em      1      -      i3rh     "Q_SOIL_FORCING_TEND" "tendency soil moisture for SCM forcing" "s-1"
+state    real   tau_soil            {fslay}     dyn_em      1      -      i3rh     "TAU_SOIL" "SCM soil forcing timescale" "s"
+state    real   soil_depth_force    {fslay}     dyn_em      1      -      i3rh     "SOIL_DEPTH_FORCE" "SCM depth at center of soil layers in forcing file" "1"
+
+state    real   hfx_force           -     dyn_em      1      -      i3rh     "HFX_FORCE" "SCM ideal surface sensible heat flux" "W m-2"
+state    real   lh_force            -     dyn_em      1      -      i3rh     "LH_FORCE" "SCM ideal surface latent heat flux" "W m-2"
+state    real   tsk_force           -     dyn_em      1      -      i3rh     "TSK_FORCE" "SCM ideal surface skin temperature" "W m-2"
+state    real   hfx_force_tend      -     dyn_em      1      -      i3rh     "HFX_FORCE_TEND" "SCM ideal surface sensible heat flux tendency" "W m-2 s-1"
+state    real   lh_force_tend       -     dyn_em      1      -      i3rh     "LH_FORCE_TEND" "SCM ideal surface latent heat flux tendency" "W m-2 s-1"
+state    real   tsk_force_tend      -     dyn_em      1      -      i3rh     "TSK_FORCE_TEND" "SCM ideal surface skin temperature tendency" "W m-2 s-1"
+# 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   mub_save        ij     dyn_em      1         -      -           "mub_save" "nest temp, holds orig fine grid mub" "Pa"
+state    real   mu0             ij     dyn_em      1         -      i1          "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         -      irh       "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         -      irhdus    "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    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    t_base         k       dyn_em      1         -     ir        "t_base"               "BASE STATE T IN IDEALIZED CASES"         "K"      
+state    real    z              ikj     dyn_em      1         -     -         " " " " " "
+state    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"  ""
+
+# For the adaptive timestep restart
+state    logical stepping_to_time       - misc    -         -      r     "stepping_to_time"         ""
+state    integer last_step_updated      - misc    -         -      r     "last_step_updated"        ""
+state    logical adapt_step_using_child - misc    -         -      r     "adapt_step_using_child"   ""
+state    integer last_dt_sec            - misc    -         -      r     "last_dt_sec"              "Whole seconds for last timestep"  "sec"
+state    integer last_dt_sec_num        - misc    -         -      r     "last_dt_sec_num"          "Fractional secs, numerator"       "sec"
+state    integer last_dt_sec_den        - misc    -         -      r     "last_dt_sec_den"          "Fractional secs, denominator"     "sec"
+state    integer last_dt_yr             - misc    -         -      r     "last_dt_yr"               "Relative year"                    "years"
+state    integer last_dt_mm             - misc    -         -      r     "last_dt_mm"               "Relative month"                   "months"
+
+# hydrostatic pressure vars
+state    real   p_hyd           ikj     dyn_em      1         -      irh       "p_hyd"       "hydrostatic pressure"         "Pa"
+state    real   p_hyd_w         ikj     dyn_em      1         Z       r        "p_hyd_w"     "hydrostatic pressure at full levels"         "Pa"
+
+# 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         -     i01rhd    "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         -     i01rhd    "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         -      r          "URATX"            "Ratio of U over U10 on mass points "         "dimensionless"
+state    real   vratx           ij      misc        1         -      r          "VRATX"            "Ratio of V over V10 on mass points "         "dimensionless"   
+state    real   tratx           ij      misc        1         -      r          "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"         ""         ""    
+# indicates whether to recompute mu                                                             
+state   logical press_adj      -        -          -         -     -         "press_adj"         "T/F flag adjust mu"         ""    
+
+# 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         -     \
+   i0rhusdf=(bdy_interp:dt)  "QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    qc             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    qr             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    qi             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    qs             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    qg             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+state   real    qh             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QHAIL"            "Hail mixing ratio"             "kg kg-1"
+state   real    -              ikjftb   dfi_moist       1         -     -    -
+state   real    dfi_qv         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QVAPOR"       "Water vapor mixing ratio"      "kg kg-1"
+state   real    dfi_qc         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QCLOUD"       "Cloud water mixing ratio"      "kg kg-1"
+state   real    dfi_qr         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QRAIN"        "Rain water mixing ratio"       "kg kg-1"
+state   real    dfi_qi         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QICE"         "Ice mixing ratio"              "kg kg-1"
+state   real    dfi_qs         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QSNOW"        "Snow mixing ratio"             "kg kg-1"
+state   real    dfi_qg         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QGRAUP"       "Graupel mixing ratio"          "kg kg-1"
+state   real    dfi_qh         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QHAIL"        "Hail mixing ratio"             "kg kg-1"
+state    real   rimi             ikj    misc        1         -     irh         "RIMI"           "riming intensity"  "fraction"
+
+
+# LES---------------!JDM
+
+include registry.les
+
+#-------------------
+
+# CAM physics (UW PBL, UW SHCU, ZM CU)
+include registry.cam
+
+# Chem Scalars
+state   real    -              ikjftb   chem        1         -     -    -                                       
+# Tracer Scalars
+state   real    -              ikjftb   tracer      1         -     -    -                                       
+
+#
+# Tracer Scalars: If you want full resolved and non-resolved dispersion, compile WRF-Chem
+#
+state   real    -          ikjftb  tracer        1         -     -    -                                       
+state   real    tr17_1     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_1"         "tr17_1"          -
+state   real    tr17_2     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_2"         "tr17_2"          -
+state   real    tr17_3     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_3"         "tr17_3"          -
+state   real    tr17_4     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_4"         "tr17_4"          -
+state   real    tr17_5     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_5"         "tr17_5"          -
+state   real    tr17_6     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_6"         "tr17_6"          -
+state   real    tr17_7     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_7"         "tr17_7"          -
+state   real    tr17_8     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_8"         "tr17_8"
+ 
+# Other Scalars
+state   real    -              ikjftb  scalar      1         -     -   -
+state   real    qndrop         ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNDROP"        "Droplet number mixing ratio"        "# kg-1"
+state   real    qni            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNICE"         "Ice Number concentration" "# kg-1"
+state   real    qt             ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "CWM"           "Total condensate mixing ratio"      "kg kg-1"
+state   real    qns            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNSNOW"         "Snow Number concentration"   "# kg(-1)"
+state   real    qnr            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNRAIN"        "Rain Number concentration"   "# kg(-1)"
+state   real    qng            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNGRAUPEL"     "Graupel Number concentration" "# kg(-1)"
+state   real    qnh            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNHAIL"        "Hail Number concentration" "# kg(-1)"
+
+#state   real    qzr            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZRAIN"        "Rain reflectivity" "# m(6) kg(-1)"
+#state   real    qzi            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZICE"        "Ice reflectivity" "# m(6) kg(-1)"
+#state   real    qzs            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZSNOW"        "Snow reflectivity" "# m(6) kg(-1)"
+#state   real    qzg            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZGRPL"        "Graupel reflectivity" "# m(6) kg(-1)"
+#state   real    qzh            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZHAIL"        "Hail reflectivity" "# m(6) kg(-1)"
+
+state   real    qnn            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNCCN"         "CCN Number concentration" "# kg(-1)"
+state   real    qnc            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNCLOUD"       "cloud water Number concentration" "# kg(-1)"
+state   real    -              ikjftb  dfi_scalar      1         -     -   -
+state   real    dfi_qndrop     ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNDROP"    "Droplet number mixing ratio"        "# kg-1"
+state   real    dfi_qni        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNICE"     "Ice Number concentration" "# kg-1"
+state   real    dfi_qt         ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_CWM"       "Total condensate mixing ratio"      "kg kg-1"
+state   real    dfi_qns        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNSNOW"    "Snow Number concentration"   "# kg(-1)"
+state   real    dfi_qnr        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNRAIN"    "Rain Number concentration"   "# kg(-1)"
+state   real    dfi_qng        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)"
+state   real    dfi_qnh        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNHAIL" "Hail Number concentration" "# kg(-1)"
+
+#state   real    dfi_qzr        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZRAIN" "Rain reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzi        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZICE" "Ice reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzs        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZSNOW" "Snow reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzg        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZGRPL" "Graupel reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzh        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZHAIL" "Hail reflectivity" "m(6) kg(-1)"
+
+state   real    dfi_qnn        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCC"      "CNN Number concentration"   "# kg(-1)"
+state   real    dfi_qnc        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCLOUD"   "Cloud Number concentration" "# 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   soil_layers    i{lin}j    misc          1     Z     i1      "SOIL_LAYERS"   "SOIL LAYERS"         "cm"
+state   real   soil_levels    i{lin}j    misc          1     Z     i1      "SOIL_LEVELS"   "SOIL LEVELS"         "cm"
+state   real   st             i{lin}j    misc          1     Z     i1      "ST"            "SOIL TEMPERATURES"   "K"
+state   real   sm             i{lin}j    misc          1     Z     i1      "SM"            "SOIL MOISTURES"      "m3 m-3"
+state   real   sw             i{lin}j    misc          1     Z     i1      "SW"            "SOIL LIQUIDS"        "m3 m-3"
+state   real   soilt          i{lin}j    misc          1     Z     i1      "SOILT"         "RUC SOIL TEMPERATURES"  "K"
+state   real   soilm          i{lin}j    misc          1     Z     i1      "SOILM"         "RUC SOIL MOISTURES"  "m3 m-3"
+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"
+# added to output 5 for ESMF
+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     -     i012rdu "TOPOSLPX"      "ELEVATION X SLOPE"  ""
+state   real   toposlpy            ij    misc          1     -     i012rdu "TOPOSLPY"      "ELEVATION Y SLOPE"  ""
+state   real   slope               ij    misc          1     -     rdu     "SLOPE"         "ELEVATION SLOPE"  ""
+state   real   slp_azi             ij    misc          1     -     rdu     "SLP_AZI"       "ELEVATION SLOPE AZIMUTH"  "rad"
+state   real   shdmax              ij    misc          1     -     i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)   "SHDMAX"        "ANNUAL MAX VEG FRACTION" ""
+state   real   shdmin              ij    misc          1     -     i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)   "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     i012r   "LANDUSEF"      "LANDUSE FRACTION BY CATEGORY"  ""
+state   real   soilctop            isj   misc          1     Z     i012r   "SOILCTOP"      "SOIL CAT FRACTION (TOP)"  ""
+state   real   soilcbot            isj   misc          1     Z     i012r   "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"
+
+# Time series variables
+state    real   ts_hour         ?!       misc      -         -      -        "TS_HOUR"        "Model integration time, hours"
+state    real   ts_u            ?!       misc      -         -      -        "TS_U"           "Surface wind U-component, earth-relative"
+state    real   ts_v            ?!       misc      -         -      -        "TS_V"           "Surface wind V-component, earth-relative"
+state    real   ts_q            ?!       misc      -         -      -        "TS_Q"           "Surface mixing ratio"
+state    real   ts_t            ?!       misc      -         -      -        "TS_T"           "Surface temperature"
+state    real   ts_psfc         ?!       misc      -         -      -        "TS_PSFC"        "Surface pressure"
+state    real   ts_glw          ?!       misc      -         -      -        "TS_GLW"         "Downward long wave flux at surface"
+state    real   ts_gsw          ?!       misc      -         -      -        "TS_GSW"         "Net short wave flux at surface"
+state    real   ts_hfx          ?!       misc      -         -      -        "TS_HFX"         "Upward heat flux at surface"
+state    real   ts_lh           ?!       misc      -         -      -        "TS_LH"          "Upward moisture flux at surface"
+state    real   ts_tsk          ?!       misc      -         -      -        "TS_TSK"         "Skin temperature"
+state    real   ts_tslb         ?!       misc      -         -      -        "TS_TSLB"        "Soil temperature"
+state    real   ts_clw          ?!       misc      -         -      -        "TS_CLW"         "Column integrated cloud water"
+state    real   ts_rainc        ?!       misc      -         -      -        "TS_RAINC"       "Cumulus precip"
+state    real   ts_rainnc       ?!       misc      -         -      -        "TS_RAINNC"      "Grid-scale precip"
+
+# 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   SMCREL           ilj     -          1         Z     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SMCREL"           "RELATIVE SOIL MOISTURE" ""
+state    real   XICE             ij     misc        1         -     i0124rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm)  "SEAICE"             "SEA ICE FLAG"  ""
+state    real   XICEM            ij     misc        1         -     rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm)  "XICEM"             "SEA ICE FLAG (PREVIOUS STEP)"  ""
+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         -     i024rhd=(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   ACGRDFLX         ij     misc        1         -      rhdu                                       "ACGRDFLX"         "ACCUMULATED GROUND HEAT FLUX" "J 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         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SNOW"             "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real   SNOWH            ij     misc        1         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SNOWH"            "PHYSICAL SNOW DEPTH"      "m"
+#state    real   RHOSN            ij     misc        1         -     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "RHOSN"            " SNOW DENSITY"      "kg m-3" 
+state    real   CANWAT           ij     misc        1         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "CANWAT"           "CANOPY WATER"             "kg m-2"
+# added to output 5 for ESMF
+state    real   SST              ij     misc        1         -     i01245rh05d=(interp_mask_water_field:lu_index,iswater)   "SST"              "SEA SURFACE TEMPERATURE" "K"
+state  integer  IFNDSNOWH        -      misc        1         -     i         "FNDSNOWH" "SNOWH_LOGICAL"
+state  integer  IFNDSOILW        -      misc        1         -     i         "FNDSOILW" "SOILW_LOGICAL"
+# SKIN SST
+state    real   SSTSK            ij     misc        1         -     rhd=(interp_mask_water_field:lu_index,iswater)   "SSTSK"              "SKIN SEA SURFACE TEMPERATURE" "K"
+state    real   DTW              ij     misc        1         -     r   "DTW"              "WARM LAYER TEMP DIFF" "C"
+
+# DFI variables
+state   real   hcoeff         {ndfi} misc        1         -     -    "HCOEFF"               "initialization weights"
+state   real   hcoeff_tot       -    misc        1         -     -    "HCOEFF_TOT"               "initialization weights"
+state   real   dfi_p           ikj   misc        1         -     r    "P_DFI"           "perturbation pressure"         "Pa"
+state   real   dfi_al          ikj   misc        1         -     r    "AL_DFI"          "inverse perturbation density"  "m3 kg-1"
+state   real   dfi_mu          ij    misc        1         -     r    "MU_DFI"  "perturbation dry air mass in column" "Pa"
+state   real   dfi_phb         ikj   misc        1         Z     r    "PHB_DFI"  "base-state geopotential"  "m2 s-2"
+state   real   dfi_ph0         ikj   misc        1         Z     r    "PH0_DFI"  "initial geopotential"     "m2 s-2"
+state   real   dfi_php         ikj   misc        1         Z     r    "PHP_DFI"  "geopotential"             "m2 s-2"
+state   real   dfi_u           ikj   misc        1         -     r    "U_DFI"               "u accumulation array"          "   "
+state   real   dfi_v           ikj   misc        1         -     r    "V_DFI"               "v accumulation array"          "   "
+state   real   dfi_w           ikj   misc        1         -     r    "W_DFI"               "w accumulation array"          "   "
+state   real   dfi_ww          ikj   misc        1         Z     r    "WW_DFI"              "mu-coupled eta-dot"    "Pa s-1"
+state   real   dfi_t           ikj   misc        1         -     r    "TT_DFI"               "t accumulation array"          "   "
+state   real   dfi_rh          ikj   misc        1         -     r    "RH_DFI"               "initial relative humidity"     "   "
+state   real   dfi_ph          ikj   misc        1         -     r    "PH_DFI"               "p accumulation array"          "   "
+state   real   dfi_pb          ikj   misc        1         -     r    "PB_DFI"               "pb accumulation array"          "   "
+state   real   dfi_alt         ikj   misc        1         -     r    "ALT_DFI"             "1/rho accumulation array"          "   "
+state   real   dfi_tke         ikj   misc        1         -     r    "TKE_DFI"          "TURBULENCE KINETIC ENERGY"     "m2 s-2"
+state   real   dfi_tten_rad    ikj   misc        1         -     irh  "RAD_TTEN_DFI"     "RADAR POT. TEMP. TENDENCY"     "K s-1"
+state    real  dfi_TSLB        ilj   misc        1         Z     r    "TSLB_dfi"         "SOIL TEMPERATURE"   "K"
+state    real  dfi_SMOIS       ilj    -          1         Z     r    "SMOIS_dfi"        "SOIL MOISTURE"     "m3 m-3"
+state    real  dfi_SNOW        ij    misc        1         -     r    "SNOW_dfi"         "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real  dfi_SNOWH       ij    misc        1         -     r    "SNOWH_dfi"        "PHYSICAL SNOW DEPTH"      "m"
+state    real  dfi_CANWAT      ij    misc        1         -     r    "CANWAT_dfi"       "CANOPY WATER"             "kg m-2"
+state    real  dfi_SMFR3D      ilj   misc        1         Z     r    "SMFR3D_dfi"           "SOIL ICE" ""
+state    real  dfi_KEEPFR3DFLAG ilj  misc        1         Z     r    "KEEPFR3DFLAG_dfi"     "FLAG - 1. FROZEN SOIL YES, 0 - NO"             ""
+
+# 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"
+state    real   TRB_URB4D       i{ulay}j    misc       1         Z     r      "TRB_URB4D" "ROOF LAYER TEMPERATURE"          "K"
+state    real   TW1_URB4D       i{ulay}j    misc       1         Z     r      "TW1_URB4D" "WALL LAYER TEMPERATURE"          "K"
+state    real   TW2_URB4D       i{ulay}j    misc       1         Z     r      "TW2_URB4D" "WALL LAYER TEMPERATURE"          "K"
+state    real   TGB_URB4D       i{ulay}j    misc       1         Z     r      "TGB_URB4D" "ROAD LAYER TEMPERATURE"          "K"
+state    real   TLEV_URB3D      i{ulay}j    misc       1         Z     r      "TLEV_URB3D" "INDOOR TEMPERATURE"             "K"
+state    real   QLEV_URB3D      i{ulay}j    misc       1         Z     r      "QLEV_URB3D" "SPECIFIC HUMIDITY"              "dimensionless"
+state    real   TW1LEV_URB3D    i{ulay}j    misc       1         Z     r      "TW1LEV_URB3D" "WINDOW TEMPERATURE"           "K"
+state    real   TW2LEV_URB3D    i{ulay}j    misc       1         Z     r      "TW2LEV_URB3D" "WINDOW TEMPERATURE"           "K"
+state    real   TGLEV_URB3D     i{ulay}j    misc       1         Z     r      "TGLEV_URB3D" "GROUND TEMPERATURE BELOW A BUILDING"     "K"
+state    real   TFLEV_URB3D     i{ulay}j    misc       1         Z     r      "TFLEV_URB3D" "FLOOR TEMPERATURE"                       "K"
+state    real   SF_AC_URB3D     ij          misc       1         -     r      "SF_AC_URB3D"  "SENSIBLE HEAT FLUX FROM THE AIR COND." "W m{-2}"
+state    real   LF_AC_URB3D     ij          misc       1         -     r      "LF_AC_URB3D"  "LATENT HEAT FLUX FROM THE AIR COND." "W m{-2}"
+state    real   CM_AC_URB3D     ij          misc       1         -     r      "CM_AC_URB3D"  "CONSUMPTION OF THE AIR COND." "W m{-2}"
+state    real   SFVENT_URB3D    ij          misc       1         -     r      "SFVENT_URB3D" "SENSIBLE HEAT FLUX FROM URBAN VENTILATION" "W m{-2}"
+state    real   LFVENT_URB3D    ij          misc       1         -     r      "LFVENT_URB3D" "LATENT HEAT FLUX FROM URBAN VENTILATION" "W m{-2}"
+state    real   SFWIN1_URB3D    i{ulay}j    misc       1         Z     r      "SFWIN1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW"  "W m{-2}"
+state    real   SFWIN2_URB3D    i{ulay}j    misc       1         Z     r      "SFWIN2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW"  "W m{-2}"
+state    real   SFW1_URB3D      i{ulay}j    misc       1         Z     r      "SFW1_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFW2_URB3D      i{ulay}j    misc       1         Z     r      "SFW2_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFR_URB3D       i{ulay}j    misc       1         Z     r      "SFR_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFG_URB3D       i{ulay}j    misc       1         Z     r      "SFG_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   CMR_SFCDIF      ij          misc       1         -     r      "CMR_SFCDIF" "" ""
+state    real   CHR_SFCDIF      ij          misc       1         -     r      "CHR_SFCDIF" "" ""
+state    real   CMC_SFCDIF      ij          misc       1         -     r      "CMC_SFCDIF" "" ""
+state    real   CHC_SFCDIF      ij          misc       1         -     r      "CHC_SFCDIF" "" ""
+
+
+# solar location variables from radiation driver
+state    real   COSZEN           ij     misc        1         -      r       "COSZEN"  "COS of SOLAR ZENITH ANGLE"     "dimensionless"
+state    real   HRANG            ij     misc        1         -      r       "HRANG"   "SOLAR HOUR ANGLE"          "radians"
+state    real   DECLIN            -     misc        1         -      r       "DECLIN"  "SOLAR DECLINATION"         "radians"
+state    real   SOLCON            -     misc        1         -      r       "SOLCON"  "SOLAR CONSTANT"         "W m-2"
+
+
+# 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"             ""
+
+# Additional for P-X PBL and LSM
+state    real   RA               ij     misc        1         -      r        "RA"           "AERODYNAMIC RESISTANCE"   "s m-1"
+state    real   RS               ij     misc        1         -      r        "RS"           "SURFACE RESISTANCE"       "s m-1"
+state    real   LAI              ij     misc        1         -      i0124rh       "LAI"          "Leaf area index"          "area/area"
+state    real   VEGF_PX          ij     misc        1         -      r        "VEGF_PX"      "Vegetation Fraction for PX LSM"    "area/area"
+state    real   T2OBS            ij     misc        1         -      r        "T2OBS"        "2-m temperature from analysis "          "K"
+state    real   Q2OBS            ij     misc        1         -      r        "Q2OBS"        "2-m mixing ratio from analysis "         "kg/kg"
+
+# 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   EXCH_H          ikj     misc        1         -     r          "EXCH_H"               "SCALAR EXCHANGE COEFFICIENTS "
+state    real   EXCH_M          ikj     misc        1         -     r          "EXCH_M"               "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"                             ""
+state   real   TSHLTR           ij     misc        1         -      r        "TSHLTR"                "SHELTER THETA FROM MYJ"                       "K"
+state   real   QSHLTR           ij     misc        1         -      r        "QSHLTR"                "SHELTER SPECIFIC HUMIDITY FROM MYJ"           "kg kg-1"
+state   real   PSHLTR           ij     misc        1         -      r        "PSHLTR"                "SHELTER PRESSURE FROM MYJ"           "Pa"
+state   real   TH10             ij     misc        1         -      r        "TH10"                  "10-M THETA FROM MYJ"                          "K"
+state   real   Q10              ij     misc        1         -      r        "Q10"                   "10-M SPECIFIC HUMIDITY FROM MYJ"              "kg kg-1"
+i1      real   CHKLOWQ          ij     misc        1         -     -         "CHKLOWQ"               "SURFACE SATURATION FLAG"        ""
+
+# TEMF PBL variables
+state    real   te_temf        ikj     misc        1         -      rh        "te_temf"               "Total energy from TEMF PBL scheme"      "m2 s-2"
+state    real   kh_temf        ikj     misc        1         -     rh          "kh_temf"               "Diffusion coefficient for heat from TEMF PBL"
+state    real   km_temf        ikj     misc        1         -     rh          "km_temf"               "Diffusion coefficient for momentum from TEMF PBL"
+state    real   shf_temf       ikj     misc        1         -     rh          "shf_temf"              "Sensible heat flux from TEMF PBL"      "K m s-1"
+state    real   qf_temf        ikj     misc        1         -     rh          "qf_temf"              "Sensible heat flux from TEMF PBL"       "kg/kg m s-1"
+state    real   uw_temf        ikj     misc        1         -     rh          "uw_temf"              "U momentum flux from TEMF PBL"       "m2 s-2"
+state    real   vw_temf        ikj     misc        1         -     rh          "vw_temf"              "V momentum flux from TEMF PBL"       "m2 s-2"
+state    real   wupd_temf      ikj     misc        1         -     rh          "wupd_temf"            "Updraft velocity from TEMF PBL"      "m s-1"
+state    real   mf_temf        ikj     misc        1         -     rh          "mf_temf"              "Mass flux from TEMF PBL"             "m s-1"
+state    real   thup_temf      ikj     misc        1         -     rh          "thup_temf"            "Updraft thetal from TEMF PBL"        "K"
+state    real   qtup_temf      ikj     misc        1         -     rh          "qtup_temf"            "Updraft qt from TEMF PBL"        "1"
+state    real   qlup_temf      ikj     misc        1         -     rh          "qlup_temf"            "Updraft ql (liquid water) from TEMF PBL"        "1"
+state    real   cf3d_temf      ikj     misc        1         -     rh          "cf3d_temf"            "3D Cloud fraction from TEMF PBL"        "1"
+state    real   hd_temf        ij      misc        1         -     rh          "hd_temf"              "Dry thermal top height from TEMF PBL"       "m"
+state    real   lcl_temf       ij      misc        1         -     rh          "lcl_temf"             "Lifting condensation level from TEMF PBL"       "m"
+state    real   hct_temf       ij      misc        1         -     rh          "hct_temf"             "Cloud top height from TEMF PBL"       "m"
+state    real   cfm_temf       ij      misc        1         -     rh          "cfm_temf"            "Column cloud fraction from TEMF PBL"        "1"
+state    real   wm_temf        ij      misc        1         -     rh        "wm_temf"               "Velocity scale in TEMF surface layer scheme"      "m s-1"
+
+# MYNN PBL variables
+state   real   qke             ikjftb  scalar      1         -      i0rhusdf=(bdy_interp:dt) "qke"               "twice TKE FROM MYNN"      "m2 s-2"
+state   real   tsq             ikj     misc        1         -      r        "tsq"               "liquid water pottemp variance"      "K2"
+state   real   qsq             ikj     misc        1         -      r        "qsq"               "liquid water variance"      "(kg/kg)**2"
+state   real   cov             ikj     misc        1         -      r        "cov"               "liquid water-liquid water pottemp covaria\
+nce"      "K kg/kg"
+state   real   ch               ij     misc        1         -      -        "ch"                "drag coeff for heat"    ""
+#state   real   K_m             ikj     misc        1         -     -          "K_m"               "EXCHANGE COEFFICIENT for momentum "
+#state   real   K_h             ikj     misc        1         -     -          "K_h"               "EXCHANGE COEFFICIENT for heat "
+#state   real   K_q             ikj     misc        1         -     -          "K_q"               "EXCHANGE COEFFICIENT for qke "
+
+# Additional for gravity wave drag
+state   real   DTAUX3D         ikj     misc        1         -     rh        "DTAUX3D"               "LOCAL U GWDO STRESS"   "m s-1"
+state   real   DTAUY3D         ikj     misc        1         -     rh        "DTAUY3D"               "LOCAL V GWDO STRESS"   "m s-1"  
+state   real   DUSFCG           ij     misc        1         -     rh        "DUSFCG"                "COLUMN-INTEGRATED U GWDO STRESS"   "Pa m s-1"
+state   real   DVSFCG           ij     misc        1         -     rh        "DVSFCG"                "COLUMN-INTEGRATED V GWDO STRESS"   "Pa m s-1"
+state   real   VAR2D            ij     misc        1         -     i012rhdus "VAR"                   "OROGRAPHIC VARIANCE"   ""   ""
+state   real   OC12D            ij     misc        1         -     i012rhdus "CON"                   "OROGRAPHIC CONVEXITY"   ""   ""
+state   real   OA1              ij     misc        1         -     i012rhdus "OA1"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA2              ij     misc        1         -     i012rhdus "OA2"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA3              ij     misc        1         -     i012rhdus "OA3"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA4              ij     misc        1         -     i012rhdus "OA4"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL1              ij     misc        1         -     i012rhdus "OL1"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL2              ij     misc        1         -     i012rhdus "OL2"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL3              ij     misc        1         -     i012rhdus "OL3"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL4              ij     misc        1         -     i012rhdus "OL4"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+
+# BEP urban scheme  variables
+state    real    a_u_bep       ikj     misc        1         Z      -        "a_u_bep"               "IMPLICIT FOR X-COMP."      "s-1"
+state    real    a_v_bep       ikj     misc        1         Z      -        "a_v_bep"               "IMPLICIT FOR Y-COMP."      "s-1"
+state    real    a_t_bep       ikj     misc        1         Z      -        "a_t_bep"               "IMPLICIT FOR Pot. Temp"    "s-1"
+state    real    a_q_bep       ikj     misc        1         Z      -        "a_q_bep"               "IMPLICIT FOR Moisture"     "s-1"
+state    real    a_e_bep       ikj     misc        1         Z      -        "a_e_bep"               "IMPLICIT FOR TKE"          "s-1"
+state    real    b_u_bep       ikj     misc        1         Z      -        "b_u_bep"               "EXPLICIT FOR X-COMP."      "m s-2"
+state    real    b_v_bep       ikj     misc        1         Z      -        "b_v_bep"               "EXPLICIT FOR Y-COMP."      "m s-2"
+state    real    b_t_bep       ikj     misc        1         Z      -        "b_t_bep"               "EXPLICIT FOR Pot. Temp"    "K s-1"
+state    real    b_q_bep       ikj     misc        1         Z      -        "b_q_bep"               "EXPLICIT FOR Moisture"     "kg s-1"
+state    real    b_e_bep       ikj     misc        1         Z      -        "b_e_bep"               "EXPLICIT FOR TKE"          "m2 s-3"
+state    real    dlg_bep       ikj     misc        1         Z      -        "dlg_bep"               "length scale 1"            "m"
+state    real    dl_u_bep      ikj     misc        1         Z      -        "dl_u_bep"              "urban length scale"        "m"
+state    real    sf_bep        ikj     misc        1         Z      -        "sf_bep"                "surface grid"              "-"
+state    real    vl_bep        ikj     misc        1         Z      -        "vl_bep"                "volume grid"               "-"
+# BOULAC PBL variables
+state    real   tke_pbl        ikj     misc        1         -      rh        "tke_pbl"               "TKE FROM Bougeault and Lacarrere"      "m2 s-2"
+state    real   el_pbl        ikj     misc        1         -       h        "el_pbl"               "Length scale FROM Bougeault and Lacarrere"      "m"
+# Diagnostic PBL variables
+state    real   wu_tur         ikj     misc        1         -      r        "wu_tur"               "Turbulent flux of momentum(x)"      "m2 s-2"
+state    real   wv_tur         ikj     misc        1         -      r        "wv_tur"               "Turbulent flux of momentum(y)"      "m2 s-2"
+state    real   wt_tur         ikj     misc        1         -      r        "wt_tur"               "Turbulent flux of temperature"      "K m s-1"
+state    real   wq_tur         ikj     misc        1         -      r        "wq_tur"               "Turbulent flux of water vapor"      "- m s-1"
+
+# 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         -      -
+state    real   rlwtoa           ij     misc        1         -      -
+state    real   czmean           ij     misc        1         -      -
+state    real   cfracl           ij     misc        1         -      -
+state    real   cfracm           ij     misc        1         -      -
+state    real   cfrach           ij     misc        1         -      -
+state    real   acfrst           ij     misc        1         -      -
+state integer   ncfrst           ij     misc        1         -      -
+state    real   acfrcv           ij     misc        1         -      -
+state integer   ncfrcv           ij     misc        1         -      -
+
+# cam radiation variables
+state  real    -       i{ls}jf ozmixm      1    -   -     -
+state  real   mth01    i{ls}jf ozmixm      1    -   -     -
+state  real   mth02    i{ls}jf ozmixm      1    -   -     -
+state  real   mth03    i{ls}jf ozmixm      1    -   -     -
+state  real   mth04    i{ls}jf ozmixm      1    -   -     -
+state  real   mth05    i{ls}jf ozmixm      1    -   -     -
+state  real   mth06    i{ls}jf ozmixm      1    -   -     -
+state  real   mth07    i{ls}jf ozmixm      1    -   -     -
+state  real   mth08    i{ls}jf ozmixm      1    -   -     -
+state  real   mth09    i{ls}jf ozmixm      1    -   -     -
+state  real   mth10    i{ls}jf ozmixm      1    -   -     -
+state  real   mth11    i{ls}jf ozmixm      1    -   -     -
+state  real   mth12    i{ls}jf ozmixm      1    -   -     -
+state  real   pin       {ls}     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 microphysics State Variables
+state   real    F_ICE_PHY      ikj     misc         1         -      rhdu     "F_ICE_PHY"            "FRACTION OF ICE"         ""
+state   real    F_RAIN_PHY     ikj     misc         1         -      rhdu     "F_RAIN_PHY"           "FRACTION OF RAIN "         ""
+state   real    F_RIMEF_PHY    ikj     misc         1         -      rhdu     "F_RIMEF_PHY"          "MASS RATIO OF RIMED ICE "         ""
+state   real    qndropsource   ikj     misc         1         -      -        "qndropsource"         "Droplet number source"   "#/kg/s"
+
+# Other Misc State Variables                                            
+state   real    h_diabatic     ikj     misc         1         -      rdu      "h_diabatic"            "MICROPHYSICS LATENT HEATING"         "K s-1"      
+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    msftx          ij      misc         1         -     i012rhdu=(copy_fcnm)    "MAPFAC_MX"         "Map scale factor on mass grid, x direction" ""
+state   real    msfty          ij      misc         1         -     i012rhdu=(copy_fcnm)    "MAPFAC_MY"         "Map scale factor on mass grid, y direction" ""
+state   real    msfux          ij      misc         1         X     i012rhdu=(copy_fcnm)    "MAPFAC_UX"         "Map scale factor on u-grid, x direction" ""
+state   real    msfuy          ij      misc         1         X     i012rhdu=(copy_fcnm)    "MAPFAC_UY"         "Map scale factor on u-grid, y direction" ""
+state   real    msfvx          ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MAPFAC_VX"         "Map scale factor on v-grid, x direction" ""
+state   real    msfvx_inv      ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MF_VX_INV"         "Inverse map scale factor on v-grid, x direction" ""
+state   real    msfvy          ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MAPFAC_VY"         "Map scale factor on v-grid, y direction" ""
+
+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    ht_shad        ijb     misc         1         -     df=(bdy_interp:dt)         "HGT_SHAD"        "Height of orographic shadow"   "m"
+i1      real    ht_loc         ij      misc         1         -     - 
+state   integer  shadowmask    ij      misc         1         -     - 
+state   integer min_ptchsz     -       misc         1         -     r
+
+state   real    TSK            ij      misc         1         -     i012rhdu=(copy_fcnm)    "TSK"                   "SURFACE SKIN TEMPERATURE"                  "K"
+state   real    dfi_TSK        ij      misc         1         -     r                       "TSK_dfi"               "saved SURFACE SKIN TEMPERATURE"
+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    t00            -       misc         -         -     i02rh     "t00"                   "BASE STATE TEMPERATURE   "  "K"
+state   real    p00            -       misc         -         -     i02rh     "p00"                   "BASE STATE PRESURE"         "Pa"
+state   real    tlp            -       misc         -         -     i02rh     "tlp"                   "BASE STATE LAPSE RATE    "  ""
+state   real    tiso           -       misc         -         -     i02rh     "tiso"                  "TEMP AT WHICH THE BASE T TURNS CONST"  "K"
+state   real    max_msftx      -       misc         -         -      rh       "max_mstfx"             "Max map factor in domain"  ""
+state   real    max_msfty      -       misc         -         -      rh       "max_mstfy"             "Max map factor in domain"  ""
+
+# State variables for Goddard LW and SW radiation
+state    real  TLWDN           ij      misc        1         -      h         "TLWDN"                 "TOA LW downwelling flux"           "W m-2"
+state    real  TLWUP           ij      misc        1         -      h         "TLWUP"                 "TOA LW upwelling flux"             "W m-2"
+state    real  SLWDN           ij      misc        1         -      h         "SLWDN"                 "Surface LW downwelling flux"       "W m-2"
+state    real  SLWUP           ij      misc        1         -      h         "SLWUP"                 "Surface LW upwelling flux"         "W m-2"
+state    real  TSWDN           ij      misc        1         -      h         "TSWDN"                 "TOA SW downwelling flux"           "W m-2"
+state    real  TSWUP           ij      misc        1         -      h         "TSWUP"                 "TOA SW upwelling flux"             "W m-2"
+state    real  SSWDN           ij      misc        1         -      h         "SSWDN"                 "Surface SW downwelling flux"       "W m-2"
+state    real  SSWUP           ij      misc        1         -      h         "SSWUP"                 "Surface SW upwelling flux"         "W m-2"
+
+# Other physics variables
+                                                
+state    real  RUSHTEN         ikj      misc        1         -      r        "RUSHTEN"               "COUPLED X WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME"   "Pa m s-2"
+state    real  RVSHTEN         ikj      misc        1         -      r        "RVSHTEN"               "COUPLED Y WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME"   "Pa m s-2"
+state    real  RTHSHTEN        ikj      misc        1         -      r        "RTHSHTEN"              "COUPLED THETA TENDENCY DUE TO SHALLOW CUMULUS SCHEME"    "Pa K s-1"
+state    real  RQVSHTEN        ikj      misc        1         -      r        "RQVSHTEN"              "COUPLED Q_V TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQRSHTEN        ikj      misc        1         -      r        "RQRSHTEN"              "COUPLED Q_R TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQCSHTEN        ikj      misc        1         -      r        "RQCSHTEN"              "COUPLED Q_C TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQSSHTEN        ikj      misc        1         -      r        "RQSSHTEN"              "COUPLED Q_S TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQISHTEN        ikj      misc        1         -      r        "RQISHTEN"              "COUPLED Q_I TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQGSHTEN        ikj      misc        1         -      r        "RQGSHTEN"              "COUPLED Q_G TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+
+state    real  RUCUTEN         ikj      misc        1         -      r        "RUCUTEN"               "COUPLED X WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION"  "Pa m s-2"
+state    real  RVCUTEN         ikj      misc        1         -      r        "RVCUTEN"               "COUPLED Y WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION"  "Pa m s-2"
+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  RAINSH           ij      misc        1         -      rhdu     "RAINSH"                "ACCUMULATED SHALLOW CUMULUS PRECIPITATION"               "mm"
+state    real  RAINNC           ij      misc        1         -      rhdu     "RAINNC"                "ACCUMULATED TOTAL GRID SCALE PRECIPITATION"              "mm"      
+state  integer I_RAINC          ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_RAINC"            "BUCKET FOR RAINC"                    ""
+state  integer I_RAINNC         ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_RAINNC"           "BUCKET FOR RAINNC"                   ""
+state    real  PRATEC           ij      misc        1         -      r        "PRATEC"                "PRECIP RATE FROM CUMULUS SCHEME"                         "mm s-1"
+state    real  PRATESH          ij      misc        1         -      r        "PRATESH"               "PRECIP RATE FROM SHALLOW CUMULUS SCHEME"                 "mm s-1"
+state    real  RAINCV           ij      misc        1         -      r        "RAINCV"                "TIME-STEP CUMULUS PRECIPITATION"                         "mm"      
+state    real  RAINSHV          ij      misc        1         -      r        "RAINSHV"               "TIME-STEP SHALLOW 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  HAILNC           ij      misc        1         -      rhdu     "HAILNC"                "ACCUMULATED TOTAL GRID SCALE HAIL"                       "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  HAILNCV          ij      misc        1         -      r        "HAILNCV"               "TIME-STEP NONCONVECTIVE HAIL"                            "mm"
+state    real    refl_10cm      ikj     dyn_em      1         -     hdu     "refl_10cm" "Radar reflectivity (lamda = 10 cm)"  "dBZ"
+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  edt_out          ij      misc        1         -      -        "EDT_OUT"             "EDT FROM GD SCHEME"             ""
+state    real  xmb_shallow      ij      misc        1         -      rh       "XMB_SHALLOW"             "MASSFLUX FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  k22_shallow   ij      misc        1         -      rh       "K22_SHALLOW"             "K22 LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  kbcon_shallow   ij      misc        1         -    rh       "KBCON_SHALLOW"             "KBCON LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  ktop_shallow   ij      misc        1         -     rh       "KTOP_SHALLOW"             "KTOP LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+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  cugd_tten        ikj     misc        1         -      r        "CUGD_TTEN"             "INITIAL TTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qvten       ikj     misc        1         -      r        "CUGD_QVTEN"            "INITIAL QTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_ttens       ikj     misc        1         -      r        "CUGD_TTENS"            "INITIAL SUBSIDENCE TTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qvtens      ikj     misc        1         -      r        "CUGD_QVTENS"           "INITIAL SUBSIDNCE QTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qcten       ikj     misc        1         -      r        "CUGD_QCTEN"            "INITIAL TEMPERATURE TENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-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"              "UNCOUPLED THETA TENDENCY DUE TO LONG WAVE RADIATION"    "K s-1"
+state    real  RTHRATENSW      ikj      misc        1         -      r        "RTHRATSW"              "UNCOUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION"   "K s-1"
+state    real  CLDFRA          ikj      misc        1         -      r        "CLDFRA"                "CLOUD FRACTION"                                       ""
+state    real  CLDFRA_OLD      ikj      misc        1         -      r        "CLDFRA_OLD"            "previous time level cldfra"                           ""
+
+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"      
+state    real  SWNORM           ij      misc        1         -      rhd      "SWNORM"                "NORMAL SHORT WAVE FLUX AT GROUND SURFACE (SLOPE-DEPENDENT)"           "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 integer  I_ACSWUPT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPT"     "BUCKET FOR UPWELLING SHORTWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACSWUPTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPTC"    "BUCKET FOR UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACSWDNT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNT"     "BUCKET FOR DOWNWELLING SHORTWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACSWDNTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNTC"    "BUCKET FOR DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACSWUPB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPB"     "BUCKET FOR UPWELLING SHORTWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACSWUPBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPBC"    "BUCKET FOR UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACSWDNB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNB"     "BUCKET FOR DOWNWELLING SHORTWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACSWDNBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNBC"    "BUCKET FOR DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACLWUPT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPT"     "BUCKET FOR UPWELLING LONGWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACLWUPTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPTC"    "BUCKET FOR UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACLWDNT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNT"     "BUCKET FOR DOWNWELLING LONGWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACLWDNTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNTC"    "BUCKET FOR DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACLWUPB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPB"     "BUCKET FOR UPWELLING LONGWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACLWUPBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPBC"    "BUCKET FOR UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACLWDNB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNB"     "BUCKET FOR DOWNWELLING LONGWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACLWDNBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNBC"    "BUCKET FOR DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2"
+state    real  SWUPT            ij      misc        1         -      rhdu     "SWUPT"                 "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP"          "W m-2"
+state    real  SWUPTC           ij      misc        1         -      rhdu     "SWUPTC"                "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2"
+state    real  SWDNT            ij      misc        1         -      rhdu     "SWDNT"                 "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP"          "W m-2"
+state    real  SWDNTC           ij      misc        1         -      rhdu     "SWDNTC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2"
+state    real  SWUPB            ij      misc        1         -      rhdu     "SWUPB"                 "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  SWUPBC           ij      misc        1         -      rhdu     "SWUPBC"                "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2"
+state    real  SWDNB            ij      misc        1         -      rhdu     "SWDNB"                 "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  SWDNBC           ij      misc        1         -      rhdu     "SWDNBC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2"
+state    real  LWUPT            ij      misc        1         -      rhdu     "LWUPT"                 "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP"          "W m-2"
+state    real  LWUPTC           ij      misc        1         -      rhdu     "LWUPTC"                "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2"
+state    real  LWDNT            ij      misc        1         -      rhdu     "LWDNT"                 "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP"          "W m-2"
+state    real  LWDNTC           ij      misc        1         -      rhdu     "LWDNTC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2"
+state    real  LWUPB            ij      misc        1         -      rhdu     "LWUPB"                 "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  LWUPBC           ij      misc        1         -      rhdu     "LWUPBC"                "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W m-2"
+state    real  LWDNB            ij      misc        1         -      rhdu     "LWDNB"                 "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  LWDNBC           ij      misc        1         -      rhdu     "LWDNBC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W 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  CLAT             ij      misc        1         -     i012rdu=(copy_fcnm)          "CLAT"                "COMPUTATIONAL GRID LATITUDE, SOUTH IS NEGATIVE"                       "degree_north"
+state    real  CLONG            ij      misc        1         -     i012rdu=(copy_fcnm)          "CLONG"               "COMPUTATIONAL GRID LONGITUDE, WEST IS NEGATIVE"                       "degree_east"
+state    real  ALBBCK           ij      misc        1         -     i0124rh   "ALBBCK"                "BACKGROUND ALBEDO"        ""
+state    real  EMBCK            ij      misc        1         -      r        "EMBCK"                 "BACKGROUND EMISSIVITY"         ""
+state    real  EMISS            ij      misc        1         -      rh       "EMISS"                 "SURFACE EMISSIVITY"         "" 
+state    real  SNOTIME          ij      misc        1         -      r        "SNOTIME"               "SNOTIME"         "" 
+state    real  NOAHRES          ij      misc        1         -      h        "NOAHRES"               "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}"
+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         -                                          
+state    real  t_phy           ikj      misc        1         -      r      "T_PHY"                        "Temperature"         "K"
+
+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  TYR              ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TYR"        "ANNUAL MEAN SFC TEMPERATURE"           "K"
+state    real  TYRA             ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TYRA"   "ACCUMULATED YEARLY SFC TEMPERATURE FOR CURRENT YEAR"  "K"
+state    real  TDLY             ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TDLY"     "ACCUMULATED DAILY SFC TEMPERATURE FOR CURRENT DAY"  "K"
+state    real  TLAG             i&j     misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TLAG"         "DAILY MEAN SFC TEMPERATURE OF PRIOR DAYS"       "K"
+state    integer NYEAR          -       misc        1         -     r        "NYEAR"                  "ACCUM DAYS IN A YEAR"                         ""
+state    real    NDAY           -       misc        1         -     r        "NDAY"                  "ACCUM TIMESTEPS IN A DAY"                      ""
+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  CK               ij      misc        1         -      r        "CK"                    "ENTHALPY EXCHANGE COEFF AT 10 m"                      ""
+state    real  CKA              ij      misc        1         -      r        "CKA"                   "ENTHALPY EXCHANGE COEFF AT LOWEST MODEL LVL"          ""
+state    real  CD               ij      misc        1         -      r        "CD"                    "DRAG COEFF AT 10m"                      ""
+state    real  CDA              ij      misc        1         -      r        "CDA"                   "DRAG COEFF AT LOWEST MODEL LVL"                      ""
+state    real  UST              ij      misc        1         -      rh       "UST"                   "U* IN SIMILARITY THEORY"                      "m s-1"      
+state    real  USTM             ij      misc        1         -      r        "USTM"                  "U* IN SIMILARITY THEORY WITHOUT VCONV"        "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  ACHFX            ij      misc        1         -      rhdu     "ACHFX"                 "ACCUMULATED UPWARD HEAT FLUX AT THE SURFACE"  "J m-2"
+state    real  ACLHF            ij      misc        1         -      rhdu     "ACLHF"                 "ACCUMULATED UPWARD LATENT HEAT FLUX AT THE SURFACE"  "J 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  dfi_QVG          ij      misc        1         -      r        "QVG_dfi"               "WATER VAPOR MIXING RATIO AT THE SURFACE"      "kg kg-1"
+state    real  QCG              ij      misc        1         -      r        "QCG"                   "CLOUD WATER MIXING RATIO AT THE GROUND SURFACE"      "kg kg-1"
+state    real  DEW              ij      misc        1         -      r        "DEW"                   "DEW MIXING RATIO AT THE SURFACE"              "kg kg-1"
+state    real  SOILT1           ij      misc        1         -      i012rh   "SOILT1"                "TEMPERATURE INSIDE SNOW "    "K"
+state    real  dfi_SOILT1       ij      misc        1         -      r        "SOILT1_dfi"            "TEMPERATURE INSIDE SNOW "    "K"
+state    real  TSNAV            ij      misc        1         -      r        "TSNAV"                 "AVERAGE SNOW TEMPERATURE "                    "C"
+state    real  dfi_TSNAV        ij      misc        1         -      r        "TSNAV_dfi"             "AVERAGE SNOW TEMPERATURE "                    "C"
+state    real  REGIME           ij      misc        1         -      r        "REGIME"  "FLAGS: 1=Night/Stable, 2=Mechanical Turbulent, 3=Forced Conv, 4=Free Conv" ""
+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  dfi_SNOWC        ij      misc        1         -      r        "SNOWC_dfi"             "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    real   sr             ij      dyn_em      1         -      irh         "sr" "fraction of frozen precipitation"
+state    real   potevp         ij      dyn_em      1         -       rh         "potevp" "accumulated potential evaporation" "W m-2"
+state    real   snopcx         ij      dyn_em      1         -       rh         "snopcx" "snow phase change heat flux" "W m-2"
+state    real   soiltb         ij      dyn_em      1         -        h         "soiltb" "bottom soil temperature" "K"
+                                                
+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   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"
+state  integer save_topo_from_real -    dyn_em	    1         -    irh        "save_topo_from_real"    "1=original topo from real/0=topo modified by WRF"      "flag"
+
+## 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  RPHNDGDTEN        ikj      misc     1         -      r        "RPHNDGDTEN"              "COUPLED GEOPOTENTIAL TENDENCY DUE TO FDDA GRID NUDGING"   "Pa m2 s-3"
+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      i{10}r   "U_NDG_NEW"               "NEW X WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  V_NDG_NEW         ikjf     fdda3d   1         Y      i{10}r   "V_NDG_NEW"               "NEW Y WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  T_NDG_NEW         ikjf     fdda3d   1         -      i{10}r   "T_NDG_NEW"               "NEW PERT POT TEMP FOR FDDA GRID NUDGING"  "K"
+state    real  Q_NDG_NEW         ikjf     fdda3d   1         -      i{10}r   "Q_NDG_NEW"               "NEW WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  PH_NDG_NEW        ikjf     fdda3d   1         Z      i{10}r   "PH_NDG_NEW"              "NEW PERT GEOPOTENTIAL FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  U_NDG_OLD         ikjf     fdda3d   1         X      i{10}r   "U_NDG_OLD"               "OLD X WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  V_NDG_OLD         ikjf     fdda3d   1         Y      i{10}r   "V_NDG_OLD"               "OLD Y WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  T_NDG_OLD         ikjf     fdda3d   1         -      i{10}r   "T_NDG_OLD"               "OLD PERT POT TEMP FOR FDDA GRID NUDGING"  "K"
+state    real  Q_NDG_OLD         ikjf     fdda3d   1         -      i{10}r   "Q_NDG_OLD"               "OLD WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  PH_NDG_OLD        ikjf     fdda3d   1         Z      i{10}r   "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         -      i{10}r      "MU_NDG_NEW"              "NEW PERT COLUMN DRY MASS FOR FDDA GRID NUDGING"  "Pa"
+state    real  MU_NDG_OLD        ivjf     fdda2d   1         -      i{10}r      "MU_NDG_OLD"              "OLD PERT COLUMN DRY MASS FOR FDDA GRID NUDGING"  "Pa"
+state    real  U10_NDG_OLD       ij         misc      1         X      i9r      "U10_NDG_OLD"             "OLD U10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  U10_NDG_NEW       ij         misc      1         X      i9r      "U10_NDG_NEW"             "NEW U10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  V10_NDG_OLD       ij         misc      1         Y      i9r      "V10_NDG_OLD"             "OLD V10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  V10_NDG_NEW       ij         misc      1         Y      i9r      "V10_NDG_NEW"             "NEW V10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  T2_NDG_OLD        ij         misc      1         -      i9r      "T2_NDG_OLD"              "OLD T2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  T2_NDG_NEW        ij         misc      1         -      i9r      "T2_NDG_NEW"              "NEW T2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  TH2_NDG_OLD       ij         misc      1         -      i9r      "TH2_NDG_OLD"             "OLD TH2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  TH2_NDG_NEW       ij         misc      1         -      i9r      "TH2_NDG_NEW"             "NEW TH2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  Q2_NDG_OLD        ij         misc      1         -      i9r      "Q2_NDG_OLD"              "OLD Q2 FOR SURFACE FDDA GRID NUDGING"  "kg kg-1"
+state    real  Q2_NDG_NEW        ij         misc      1         -      i9r      "Q2_NDG_NEW"              "NEW Q2 FOR SURFACE FDDA GRID NUDGING"  "kg kg-1"
+state    real  RH_NDG_OLD        ij         misc      1         -      i9r      "RH_NDG_OLD"              "OLD RH FOR SURFACE FDDA GRID NUDGING"  "%"
+state    real  RH_NDG_NEW        ij         misc      1         -      i9r      "RH_NDG_NEW"              "NEW RH FOR SURFACE FDDA GRID NUDGING"  "%"
+state    real  PSL_NDG_OLD       ij         misc      1         -      i9r      "PSL_NDG_OLD"             "OLD PSL FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PSL_NDG_NEW       ij         misc      1         -      i9r      "PSL_NDG_NEW"             "NEW PSL FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PS_NDG_OLD        ij         misc      1         -      i9r      "PS_NDG_OLD"              "OLD PS FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PS_NDG_NEW        ij         misc      1         -      i9r      "PS_NDG_NEW"              "NEW PS FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  TOB_NDG_OLD       ij         misc      1         -      i9r      "TOB_NDG_OLD"             "OLD TOB FOR SURFACE FDDA GRID NUDGING"  ""
+state    real  ODIS_NDG_OLD      ij         misc      1         -      i9r      "ODIS_NDG_OLD"            "OLD ODIS FOR SURFACE FDDA GRID NUDGING"  "km"
+state    real  TOB_NDG_NEW       ij         misc      1         -      i9r      "TOB_NDG_NEW"             "NEW TOB FOR SURFACE FDDA GRID NUDGING"  ""
+state    real  ODIS_NDG_NEW      ij         misc      1         -      i9r      "ODIS_NDG_NEW"            "NEW ODIS FOR SURFACE FDDA GRID NUDGING"  "km"
+state    real  SN_NDG_NEW        ij         misc      1         -      i9r      "SN_NDG_NEW"              "NEW Snow Water Equivalent"  "mm"
+state    real  SN_NDG_OLD        ij         misc      1         -      i9r      "SN_NDG_OLD"              "OLD Snow Water Equivalent"  "mm"
+
+
+# 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"
+
+state   real    max_cfl         -       misc        1         -     -       "max_cfl"           "maximum CFL value in grid at a time" "-"
+
+state   real  prec_acc_c       ij       misc        1         -     rh       "prec_acc_c"       "ACCUMULATED CUMULUS PRECIPITATION OVER prec_acc_dt PERIODS OF TIME"       "mm"
+state   real  prec_acc_nc      ij       misc        1         -     rh       "prec_acc_nc"      "ACCUMULATED GRID SCALE  PRECIPITATION OVER prec_acc_dt PERIODS OF TIME"   "mm"
+state   real  snow_acc_nc      ij       misc        1         -     rh       "snow_acc_nc"      "ACCUMULATED SNOW WATER EQUIVALENT OVER prec_acc_dt PERIODS OF TIME"       "mm"
+
+# Placeholder for decoupled advective tendency diagnostics for non-chem
+state   real  -               ikjf      advh_t      1         -     -         -
+state   real  advh_qv         ikjf      advh_t      1         -     -         "advh_qv"    "ACCUMULATED HORIZONTAL TENDENCY FOR WATER VAPOR"        "kg kg-1"
+
+state   real  -               ikjf      advz_t      1         -     -         -
+state   real  advz_qv         ikjf      advz_t      1         -     -         "advz_qv"    "ACCUMULATED VERTICAL TENDENCY FOR WATER VAPOR"          "kg kg-1"
+
+# Ocean Mixed-Layer State Variables
+state   real    TML            ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "TML"    "OCEAN MIXED-LAYER TEMPERATURE"   "K"
+state   real    T0ML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "T0ML"   "INITIAL OCEAN MIXED-LAYER TEMPERATURE"   "K"
+state   real    HML            ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HML"    "OCEAN MIXED-LAYER DEPTH"   "m"
+state   real    H0ML           ij      misc         1         -     i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "H0ML"   "INITIAL OCEAN MIXED-LAYER DEPTH"   "m"
+state   real    HUML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HUML"   "OCEAN MIXED-LAYER DEPTH * U-CURRENT"  " m2s-1 "
+state   real    HVML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HVML"   "OCEAN MIXED-LAYER DEPTH * V-CURRENT"  " m2s-1 " 
+state   real    TMOML          ij      misc         1         -     i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm) "TMOML"  "OCEAN LAYER MEAN TEMPERATURE   "   "K"
+#
+#---------------------------------------------------------------------------------------------------------------------------------------
+#                                               
+
+######                                          
+#                                               
+# Variables that are set at run-time to control configuration  (namelist-settable)                                              
+#                                               
+#<Table>  <Type>  <Sym>                   <How set>          <Nentries>   <Default>                                             
+
+# 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"      ""  ""
+rconfig   logical all_ic_times            namelist,time_control		1              .false. irh    "all_ic_times"     "T/F WRITE ALL IC TIME PERIODS"  ""
+
+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<domain>"          -     "name of input   infile"   ""      ""
+rconfig   character  input_outname     namelist,time_control		1  "wrfinput_d<domain>"          -     "name of input   outfile"  ""      ""
+rconfig   character  bdy_inname        namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary infile"  ""      ""
+rconfig   character  bdy_outname       namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary outfile" ""      ""
+rconfig   character  rst_inname        namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "name of restrt infile"    ""      ""
+rconfig   character  rst_outname       namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "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 write_hist_at_0h_rst    namelist,time_control		1             .false. h    "write_hist_at_0h_rst" "T/F write hist at 0 h of restarted forecast"
+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"
+rconfig   logical cycling                 namelist,time_control         1             .false. -    "true for cycling (using wrfout file as input data)"
+
+# DFI namelist
+rconfig   integer dfi_opt                namelist,dfi_control   1       0     rh   "dfi_opt"                  ""      ""
+rconfig   integer dfi_radar              namelist,dfi_control   1       0     rh   "dfi_radar"                "DFI radar switch"      ""
+rconfig   integer dfi_nfilter            namelist,dfi_control   1       7     rh   "dfi_nfilter"              "Digital filter type"      ""
+rconfig   logical dfi_write_filtered_input  namelist,dfi_control  1  .true.   rh   "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?"      ""
+rconfig   logical dfi_write_dfi_history  namelist,dfi_control   1   .false.   rh   "dfi_write_dfi_history"    "Write history files during filtering?"      ""
+rconfig   integer dfi_cutoff_seconds     namelist,dfi_control   1    3600     rh   "dfi_cutoff_seconds"       "Digital filter cutoff time"      ""
+rconfig   integer dfi_time_dim           namelist,dfi_control   1    1000     rh   "dfi_time_dim"             "MAX DIMENSION FOR HCOEFF"
+rconfig   integer dfi_fwdstop_year       namelist,dfi_control   1    2004     rh   "dfi_fwdstop_year"         "4 DIGIT YEAR OF START OF DFI" "YEARS"
+rconfig   integer dfi_fwdstop_month      namelist,dfi_control   1      03     rh   "dfi_fwdstop_month"        "2 DIGIT MONTH OF THE YEAR OF START OF DFI" "MONTHS"
+rconfig   integer dfi_fwdstop_day        namelist,dfi_control   1      13     rh   "dfi_fwdstop_day"          "2 DIGIT DAY OF THE MONTH OF START OF DFI" "DAYS"
+rconfig   integer dfi_fwdstop_hour       namelist,dfi_control   1      12     rh   "dfi_fwdstop_hour"         "2 DIGIT HOUR OF THE DAY OF START OF DFI" "HOURS"
+rconfig   integer dfi_fwdstop_minute     namelist,dfi_control   1      00     rh   "dfi_fwdstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF START OF DFI" "MINUTES"
+rconfig   integer dfi_fwdstop_second     namelist,dfi_control   1      00     rh   "dfi_fwdstop_second"       "2 DIGIT SECOND OF THE MINUTE OF START OF DFI" "SECONDS"
+rconfig   integer dfi_bckstop_year       namelist,dfi_control   1    2004     rh   "dfi_bckstop_year"         "4 DIGIT YEAR OF END OF DFI" "YEARS"
+rconfig   integer dfi_bckstop_month      namelist,dfi_control   1      03     rh   "dfi_bckstop_month"        "2 DIGIT MONTH OF THE YEAR OF END OF DFI" "MONTHS"
+rconfig   integer dfi_bckstop_day        namelist,dfi_control   1      14     rh   "dfi_bckstop_day"          "2 DIGIT DAY OF THE MONTH OF END OF DFI" "DAYS"
+rconfig   integer dfi_bckstop_hour       namelist,dfi_control   1      12     rh   "dfi_bckstop_hour"         "2 DIGIT HOUR OF THE DAY OF END OF DFI" "HOURS"
+rconfig   integer dfi_bckstop_minute     namelist,dfi_control   1      00     rh   "dfi_bckstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF END OF DFI" "MINUTES"
+rconfig   integer dfi_bckstop_second     namelist,dfi_control   1      00     rh   "dfi_bckstop_second"       "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS"
+
+# 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 time_step_dfi           namelist,domains      1             -       ih   "time_step_dfi"
+
+rconfig   integer min_time_step           namelist,domains      max_domains   -1      h    "min_time_step"
+rconfig   integer max_time_step           namelist,domains      max_domains   -1      h    "max_time_step"
+rconfig   real    target_cfl              namelist,domains      max_domains  1.2      h    "target_cfl"
+rconfig   real    target_hcfl             namelist,domains      max_domains  0.84     h    "target_hcfl"
+rconfig   integer max_step_increase_pct   namelist,domains      max_domains    5      h    "max_step_increase_pct"
+rconfig   integer starting_time_step      namelist,domains      max_domains   -1      h    "starting_time_step"
+rconfig   logical step_to_output_time     namelist,domains      1         .true.      h    "step_to_output_time"
+rconfig   integer adaptation_domain       namelist,domains      1              1      h    "adaptation_domain"
+rconfig   logical use_adaptive_time_step  namelist,domains      1         .false.     h    "use_adaptive_time_step"
+
+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 num_metgrid_soil_levels namelist,domains	1             4        irh    "num_metgrid_soil_levels"               "number of input levels or layers in 3D sm, st, sw arrays"      ""
+rconfig   real    p_top_requested         namelist,domains      1              5000    irh    "p_top_requested" "Pa"      ""
+rconfig   integer interp_type             namelist,domains	1              2       irh    "interp_type"  "1=interp in pressure, 2=interp in LOG pressure"  ""
+rconfig   integer vert_refine_fact        namelist,domains      1              1       irh    "vertical refinment factor for ndown"  ""
+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              2       irh    "t_extrap_type"  "1=isothermal, 2=6.5 K/km, 3=adiabatic"   ""
+rconfig   logical lowest_lev_from_sfc     namelist,domains	1             .false.  irh    "lowest_lev_from_sfc"                ""      ""
+rconfig   logical use_levels_below_ground namelist,domains	1             .true.   irh    "use_levels_below_ground"   "T/F: use input data levels below input sfc pres" ""
+rconfig   logical use_tavg_for_tsk        namelist,domains	1             .false.  irh    "use_tavg_for_tsk"   "T/F: use diurnal avg sfc temp for tsk" ""
+rconfig   logical use_surface             namelist,domains	1             .true.   irh    "use_surface"   "T/F: use input surface level in interpolation" ""
+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    "sfcp_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   logical smooth_cg_topo          namelist,domains	1              .false. irh    "smooth_cg_topo"   "T/F smooth CG topo on boundarries" "flag"
+rconfig   logical aggregate_lu            namelist,domains	1              .false. irh    "aggregate_lu"   "T/F aggregate the grass, shrubs, trees in LU"
+rconfig   logical rh2qv_wrt_liquid        namelist,domains	1              .true.  irh    "rh2qv_wrt_liquid" "T = rh=>Qv assumes RH wrt liquid water, F = allows ice"
+rconfig   integer rh2qv_method            namelist,domains	1              1       irh    "rh2qv_method" "1=old MM5 method, 2=new WMO method"
+rconfig   real    qv_max_p_safe           namelist,domains      1              10000   irh    "qv_max_p_safe" "Threshhold pressure, Qv > flag set to value"      "Pa"
+rconfig   real    qv_max_flag             namelist,domains      1              1.E-5   irh    "qv_max_flag" "Qv flag for max"  "kg kg{-1}"
+rconfig   real    qv_max_value            namelist,domains      1              3.E-6   irh    "qv_max_value" "Qv value for max"  "kg kg{-1}"
+rconfig   real    qv_min_p_safe           namelist,domains      1              110000  irh    "qv_min_p_safe" "Threshhold pressure, Qv < flag set to value"      "Pa"
+rconfig   real    qv_min_flag             namelist,domains      1              1.E-6   irh    "qv_min_flag" "Qv flag for min"  "kg kg{-1}"
+rconfig   real    qv_min_value            namelist,domains      1              1.E-6   irh    "qv_min_value" "Qv value for min"  "kg kg{-1}"
+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   logical grid_allowed            namelist,domains	max_domains    .true.  irh    "allowed"            ""      ""
+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   ts_buf_size     namelist,domains    1                200          -       "ts_buf_size"   "Size of time series buffer"
+rconfig   integer   max_ts_locs     namelist,domains    1                5            -       "max_ts_locs"   "Maximum number of time series locations"
+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   track_level     namelist,domains    1                50000
+rconfig   real      time_to_move    namelist,domains    max_domains      0.  -  "" "" "minutes"
+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.
+
+# TC (tropical cyclone bogusing)
+rconfig   logical insert_bogus_storm   namelist,tc     	1              .false. irh    "insert_bogus_storm"   "T/F for inserting a bogus typhoon"    "flag"
+rconfig   logical remove_storm         namelist,tc     	1              .false. irh    "remove_storm"  "T/F for only removing the original typhoon"  "flag"
+rconfig   integer num_storm            namelist,tc     	1              1       irh    "num_storm"     "Number of bogus typhoons"  ""
+rconfig   real    latc_loc             namelist,tc     	max_bogus      -999.   irh    "latc_loc"      "center latitude of the bogus tyhoon"  "DEGREES"
+rconfig   real    lonc_loc             namelist,tc     	max_bogus      -999.   irh    "lonc_loc"      "center longitude of the bogus tyhoon"  "DEGREES"
+rconfig   real    vmax_meters_per_second   namelist,tc  max_bogus      -999.   irh    "vmax_meters_per_second"  "vmax of bogus storm in meters per second"  ""
+rconfig   real    rmax                 namelist,tc     	max_bogus      -999.   irh    "rmax"  "maximum radius outward from storm center"  ""
+rconfig   real    vmax_ratio           namelist,tc      max_bogus      -999.   irh    "vmax_ratio"  ""  ""
+rconfig   real    rankine_lid          namelist,tc      1              -999.   irh    "top pressure limit for the tc bogus scheme"
+
+
+# Physics
+rconfig   integer     mp_physics          namelist,physics	max_domains    0       rh       "mp_physics"            ""      ""
+#rconfig   integer     milbrandt_ccntype   namelist,physics      max_domains    0       rh       "milbrandt select maritime(1)/continental(2)"  ""      ""
+rconfig   integer     gsfcgce_hail        namelist,physics      1              0       rh       "gsfcgce select hail/graupel"  ""      ""
+rconfig   integer     gsfcgce_2ice        namelist,physics      1              0       rh       "gsfcgce select 2ice/3ice"  ""      ""
+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   integer     sf_urban_physics    namelist,physics      max_domains    0       rh       "sf_urban_physics"     "activate urban model  0=no, 1=Noah_UCM 2=BEP_UCM"   ""
+rconfig   real    BLDT                    namelist,physics	max_domains    0       h    "BLDT"          ""      ""
+rconfig   integer     cu_physics          namelist,physics	max_domains    0       rh       "cu_physics"            ""      ""
+rconfig   integer shcu_physics            namelist,physics      max_domains    0       rh   "shcu_physics"  ""      ""
+rconfig   integer     kfeta_trigger       namelist,physics	1              1       rh       "KFETA Trigger function"    ""    ""
+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_urban_layers        namelist,physics	1            400       irh    "num_urban_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 cugd_avedx              namelist,physics      1            1      irh    "cugd_avedx"                    ""      ""
+rconfig   integer clos_choice             namelist,physics      1             0       rh    "clos_choice"                    ""      ""
+rconfig   integer imomentum               namelist,physics      1             0       rh    "imomentum"                    "momentum transport in G3 scheme"      ""
+rconfig   integer ishallow                namelist,physics      1             0       rh    "ishallow"  "shallow convection in G3 scheme"      ""
+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 sst_skin                namelist,physics      1            0         h    "sst_skin" "calculate sst skin temperature 0=no, 1=yes"   ""
+rconfig   integer tmn_update              namelist,physics      1            0         h    "tmn_update" "update tmn from calculation  0=no, 1=yes"   ""
+rconfig   logical usemonalb               namelist,physics      1            .false.   h    "usemonalb"   "use 2d field vs table values  false=table, True=2d"   ""
+rconfig   logical rdmaxalb                namelist,physics      1            .true.    h     "rdmaxalb"    "false set it to table values"   ""
+rconfig   logical rdlai2d                 namelist,physics      1            .false.   h     "rdlai2d"     "false set it to table values"   ""
+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   integer lagday                  namelist,physics      1             1       -      "lagday"         ""      ""
+rconfig   logical cu_rad_feedback         namelist,physics      max_domains   .false.  -     "feedback cumulus to radiation"  ""
+rconfig   integer pxlsm_smois_init        namelist,physics      max_domains   1       irh    "PXLSM_SMOIS_INIT"    "Soil moisture initialization option 0-From analysis 1-From MAVAIL"   ""
+rconfig   integer omlcall                 namelist,physics      1            0         h     "omlcall"     "activate simple ocean mixed layer model  0=no, 1=yes"   ""
+rconfig   real    oml_hml0                namelist,physics      1            50        h     "oml_hml0"    "oml initial mixed layer depth value"   "m"
+rconfig   real    oml_gamma               namelist,physics      1            0.14      h     "oml_gamma"   "oml deep water lapse rate"   "K m-1"
+rconfig   integer isftcflx                namelist,physics      1            0         h     "isftcflx"    "switch to control sfc fluxes"   ""
+rconfig   integer iz0tlnd                 namelist,physics      1            0         h     "iz0tlnd"    "switch to control land thermal roughness length"   ""
+rconfig   real    shadlen                 namelist,physics      1            25000.    -     "shadow_length" "maximum length of orographic shadow" "m"
+rconfig   integer slope_rad               namelist,physics      max_domains    0       -     "slope_rad"  "1: use slope-dependent radiation, 0:not" ""
+rconfig   integer topo_shading            namelist,physics      max_domains    0       -     "topo_shading" "1: apply topographic shading to radiation, 0:not" ""
+rconfig   integer no_mp_heating           namelist,physics      1              0       -     "no_mp_heating" "switch to turn of latent heating in mp schemes"   ""
+rconfig   integer fractional_seaice       namelist,physics      1              0       -     "fractional_seaice" "Fractional sea-ice option"
+rconfig   logical tice2tsk_if2cold        namelist,physics      1              .false. -     "tice2tsk_if2cold" "Avoid low ice temps when ice frac and Tsk are inconsistent"
+rconfig   real    bucket_mm               namelist,physics      1             -1.      h     "bucket_mm" "bucket reset value for water accumulations -1: inactive"   ""
+rconfig   real    bucket_J                namelist,physics      1             -1.      h     "bucket_J"  "bucket reset value for energy accumulations -1: inactive"   ""
+rconfig   real    mp_tend_lim             namelist,physics      1             10.      -     "mp_tend_lim" "limit on temp tendency from mp latent heating"   "K/s"
+rconfig   real    prec_acc_dt             namelist,physics      max_domains    0.      h     "prec_acc_dt" "bucket reset time interval between outputs for cumulus or grid scale precipitation"   "minutes"
+rconfig   integer prec_acc_opt            derived               1              0       -     "prec_acc_opt" "option to output precip in a time window"          ""
+rconfig   integer bucketr_opt             derived               1              0       -     "bucketr_opt"  "option to output water accum based on bucket_mm"          ""
+
+rconfig   integer grav_settling           namelist,physics      max_domains  0         h    "grav_settling"     "activate gravitationalsettling of fog  0=no, 1=yes"
+
+#FDDA namelist parameters
+rconfig   real    FGDT                    namelist,fdda         max_domains    0       h        "FGDT"          ""      ""
+rconfig   integer  FGDTZERO               namelist,fdda         max_domains    0       rh       "FGDTZERO"             ""      ""
+rconfig   integer  grid_fdda              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   integer  grid_sfdda             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_ph   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_ph             namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   integer   k_zfac_ph             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   integer  dk_zfac_uv             namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   integer  dk_zfac_t              namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   integer  dk_zfac_ph             namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   real        guv                 namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        guv_sfc             namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gt                  namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gt_sfc              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gq                  namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gq_sfc              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gph                 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"            ""      ""
+rconfig   real    rinblw                  namelist,fdda         1              0       h        "grid_fdda"            ""      ""
+rconfig   integer xwavenum                namelist,fdda         max_domains    0       rh       "grid_fdda"            "top wave number to nudge in x direction"      "" 
+rconfig   integer ywavenum                namelist,fdda         max_domains    0       rh       "grid_fdda"            "top wave number to nudge in y direction"      ""
+rconfig   integer pxlsm_soil_nudge        namelist,fdda         max_domains    0       rh       "pxlsm_soil_nudge"     "nudge pxlsm soil"      ""
+
+#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   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   integer     obs_no_pbl_nudge_uv namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_uv" "1=no wind-nudging within pbl"          ""
+rconfig   integer     obs_no_pbl_nudge_t  namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_t"  "1=no temperature-nudging within pbl"   ""
+rconfig   integer     obs_no_pbl_nudge_q  namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_q"  "1=no moisture-nudging within pbl"      ""
+rconfig   integer     obs_sfc_scheme_horiz namelist,fdda           1              0       rh       "obs_sfcscheme_horiz" "0=wrf scheme, 1=original mm5 scheme" ""
+rconfig   integer     obs_sfc_scheme_vert  namelist,fdda           1              0       rh       "obs_sfcscheme_vert"  "0=regime vif scheme, 1=original simple scheme" ""
+rconfig   real        obs_max_sndng_gap   namelist,fdda            1              20      rh       "obs_max_sndng_gap"   "Max press gap between soundings" "centibars"
+rconfig   real        obs_nudgezfullr1_uv namelist,fdda            1              50      rh       "obs_nudgezfullr1_uv" "Vert infl full weight  height for LML obs, regime 1, winds"        ""
+rconfig   real        obs_nudgezrampr1_uv namelist,fdda            1              50      rh       "obs_nudgezrampr1_uv" "Vert infl ramp-to-zero height for LML obs, regime 1, winds"        ""
+rconfig   real        obs_nudgezfullr2_uv namelist,fdda            1              50      rh       "obs_nudgezfullr2_uv" "Vert infl full weight  height for LML obs, regime 2, winds"        ""
+rconfig   real        obs_nudgezrampr2_uv namelist,fdda            1              50      rh       "obs_nudgezrampr2_uv" "Vert infl ramp-to-zero height for LML obs, regime 2, winds"        ""
+rconfig   real        obs_nudgezfullr4_uv namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_uv" "Vert infl full weight  height for LML obs, regime 4, winds"        ""
+rconfig   real        obs_nudgezrampr4_uv namelist,fdda            1              50      rh       "obs_nudgezrampr4_uv" "Vert infl ramp-to-zero height for LML obs, regime 4, winds"        ""
+rconfig   real        obs_nudgezfullr1_t  namelist,fdda            1              50      rh       "obs_nudgezfullr1_t" "Vert infl full weight  height for LML obs, regime 1, temperature"  ""
+rconfig   real        obs_nudgezrampr1_t  namelist,fdda            1              50      rh       "obs_nudgezrampr1_t" "Vert infl ramp-to-zero height for LML obs, regime 1, temperature"  ""
+rconfig   real        obs_nudgezfullr2_t  namelist,fdda            1              50      rh       "obs_nudgezfullr2_t" "Vert infl full weight  height for LML obs, regime 2, temperature"  ""
+rconfig   real        obs_nudgezrampr2_t  namelist,fdda            1              50      rh       "obs_nudgezrampr2_t" "Vert infl ramp-to-zero height for LML obs, regime 2, temperature"  ""
+rconfig   real        obs_nudgezfullr4_t  namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_t" "Vert infl full weight  height for LML obs, regime 4, temperature"  ""
+rconfig   real        obs_nudgezrampr4_t  namelist,fdda            1              50      rh       "obs_nudgezrampr4_t" "Vert infl ramp-to-zero height for LML obs, regime 4, temperature"  ""
+rconfig   real        obs_nudgezfullr1_q  namelist,fdda            1              50      rh       "obs_nudgezfullr1_q" "Vert infl full weight  height for LML obs, regime 1, moisture"     ""
+rconfig   real        obs_nudgezrampr1_q  namelist,fdda            1              50      rh       "obs_nudgezrampr1_q" "Vert infl ramp-to-zero height for LML obs, regime 1, moisture"     ""
+rconfig   real        obs_nudgezfullr2_q  namelist,fdda            1              50      rh       "obs_nudgezfullr2_q" "Vert infl full weight  height for LML obs, regime 2, moisture"     ""
+rconfig   real        obs_nudgezrampr2_q  namelist,fdda            1              50      rh       "obs_nudgezrampr2_q" "Vert infl ramp-to-zero height for LML obs, regime 2, moisture"     ""
+rconfig   real        obs_nudgezfullr4_q  namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_q" "Vert infl full weight  height for LML obs, regime 4, moisture"     ""
+rconfig   real        obs_nudgezrampr4_q  namelist,fdda            1              50      rh       "obs_nudgezrampr4_q" "Vert infl ramp-to-zero height for LML obs, regime 4, moisture"     ""
+rconfig   real        obs_nudgezfullmin   namelist,fdda            1                 50   rh       "obs_nudgezfullmin" "Minimum depth through which vertical influence fcn remains 1.0"     "m"
+rconfig   real        obs_nudgezrampmin   namelist,fdda            1                 50   rh       "obs_nudgezrampmin" "Minimum depth through which vertical influence fcn decreases from 1.0 to 0.0" "m"
+rconfig   real        obs_nudgezmax       namelist,fdda            1               3000   rh       "obs_nudgezmax" "Maximum depth in which vertical influence function is nonzero" "m"
+rconfig   real        obs_sfcfact         namelist,fdda            1              1.0     h        "obs_sfcfact"       "Scale factor applied to time window for surface obs"     ""
+rconfig   real        obs_sfcfacr         namelist,fdda            1              1.0     h        "obs_sfcfacr"       "Scale factor applied to horiz radius of influence for surface obs"     ""
+rconfig   real        obs_dpsmx           namelist,fdda            1              7.5     h        "obs_dpsmx"         "Max pressure change allowed within horiz radius of influence"     "centibars"
+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            max_domains    0       rh       "obs_twindo"        "Half-period time window for nudging"  "hrs"
+rconfig   integer     obs_npfi            namelist,fdda            1              0       h        "obs_npfi"          "Freq in cg timesteps for diag print"  ""
+rconfig   integer     obs_ionf            namelist,fdda            max_domains    1       rh       "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   integer     obs_prt_max         namelist,fdda            1              1000    rh       "obs_prt_max"       "Maximum allowed obs entries in diagnostic printout"      ""
+rconfig   integer     obs_prt_freq        namelist,fdda            max_domains    1000    rh       "obs_prt_freq"      "Frequency in obs index for diagnostic printout."   ""
+rconfig   logical     obs_ipf_in4dob      namelist,fdda            1              .false. h        "obs_ipf_in4dob"    "Print obs input diagnostics"   ""
+rconfig   logical     obs_ipf_errob       namelist,fdda            1              .false. h        "obs_ipf_errob"     "Print obs error diagnostics"   ""
+rconfig   logical     obs_ipf_nudob       namelist,fdda            1              .false. h        "obs_ipf_nudob"     "Print obs nudge diagnostics"   ""
+rconfig   logical     obs_ipf_init        namelist,fdda            1              .true.  h        "obs_ipf_init"      "Enable obs init warning messages"   ""
+
+# Single-column model (SCM)
+rconfig   integer scm_force               namelist,scm  1       0           rh   "scm_force"            "SCM forcing switch" ""
+rconfig   real    scm_force_dx            namelist,scm  1       4000.       rh   "scm_force_dx"         "DX for SCM forcing" "m"
+rconfig   integer num_force_layers        namelist,scm  1       8           rh   "num_force_layers"     "Number of SCM forcing layers" ""
+rconfig   integer scm_lu_index            namelist,scm  1       2           rh   "scm_lu_index"         "SCM landuse index" ""
+rconfig   integer scm_isltyp              namelist,scm  1       4           rh   "scm_isltyp"           "SCM soil category" ""
+rconfig   real    scm_vegfra              namelist,scm  1       0.5         rh   "scm_vegfra"           "SCM vegetation fraction" ""
+rconfig   integer scm_canwat              namelist,scm  1       0.0         rh   "scm_canwat"           "SCM canopy water" "kg m-2"
+rconfig   real    scm_lat                 namelist,scm  1        36.605     rh   "scm_lat"              "SCM latitude" "degrees"
+rconfig   real    scm_lon                 namelist,scm  1       -97.485     rh   "scm_lon"              "SCM longitude" "degrees"
+rconfig   logical scm_th_adv              namelist,scm  1       .true.      rh   "scm_th_adv"           "Turn on theta advection in SCM"      ""
+rconfig   logical scm_wind_adv            namelist,scm  1       .true.      rh   "scm_wind_adv"         "Turn on wind advection in SCM"      ""
+rconfig   logical scm_qv_adv              namelist,scm  1       .true.      rh   "scm_qv_adv"           "Turn on qv advection in SCM"      ""
+rconfig   logical scm_ql_adv              namelist,scm  1       .false.     rh   "scm_ql_adv"           "Turn on ql advection in SCM"      ""
+rconfig   logical scm_vert_adv            namelist,scm  1       .true.      rh   "scm_vert_adv"         "Turn on vertical advection in SCM"      ""
+rconfig   integer num_force_soil_layers   namelist,scm  1       5           rh   "num_force_soil_layers" "Number of SCM soil forcing layers" ""
+rconfig   logical scm_soilT_force         namelist,scm  1       .false.     rh   "scm_soilT_force"      "Turn on soil temp forcing in SCM"      ""
+rconfig   logical scm_soilq_force         namelist,scm  1       .false.     rh   "scm_soilq_force"      "Turn on soil moisture forcing in SCM"      ""
+rconfig   logical scm_force_th_largescale namelist,scm  1       .false.     rh   "scm_force_th_largescale" "Turn on large scale theta forcing in SCM"      ""
+rconfig   logical scm_force_qv_largescale namelist,scm  1       .false.     rh   "scm_force_qv_largescale" "Turn on large scale qv forcing in SCM"      ""
+rconfig   logical scm_force_ql_largescale namelist,scm  1       .false.     rh   "scm_force_ql_largescale" "Turn on large scale ql forcing in SCM"      ""
+rconfig   logical scm_force_wind_largescale namelist,scm  1     .false.     rh   "scm_force_wind_largescale" "Turn on large scale wind forcing in SCM"      ""
+
+# Dynamics
+# dynamics option (see package definitions, below)
+rconfig   integer dyn_opt                 namelist,dynamics	1             2 
+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"                ""      ""
+# km_opt_dfi is needed for backward integration in dfi
+rconfig   integer km_opt_dfi              namelist,dynamics	1             1       irh    "km_opt_dfi"                ""      ""
+rconfig   integer damp_opt                namelist,dynamics	1             0       irh    "damp_opt"              ""      ""
+rconfig   integer rad_nudge               namelist,dynamics	1             0       irh    "rad_nudge"             ""      ""
+rconfig   integer gwd_opt                 namelist,dynamics     1             0       irh    "gwd_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    c_s                     namelist,dynamics	max_domains    0.25    h    "c_s"         "Smagorinsky coeff"      ""
+rconfig   real    c_k                     namelist,dynamics	max_domains    0.15    h    "c_k"         "TKE coeff"      ""
+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   integer  moist_adv_opt          namelist,dynamics	max_domains    1       rh    "moist_adv_opt"         "positive-definite RK3 transport switch"      ""
+rconfig   integer  moist_adv_dfi_opt      namelist,dynamics	max_domains    0       rh    "moist_adv_dfi_opt"    "positive-definite RK3 transport switch"      ""
+rconfig   integer  chem_adv_opt           namelist,dynamics	max_domains    1       rh    "chem_adv_opt"          "positive-definite RK3 transport switch"      ""
+rconfig   integer  tracer_adv_opt         namelist,dynamics	max_domains    1       rh    "tracer_adv_opt"        "positive-definite RK3 transport switch"      ""
+rconfig   integer  scalar_adv_opt         namelist,dynamics	max_domains    1       rh    "scalar_adv_opt"        "positive-definite RK3 transport switch"      ""
+rconfig   integer  tke_adv_opt            namelist,dynamics	max_domains    1       rh    "tke_adv_opt"           "positive-definite RK3 transport switch"      ""
+rconfig   logical top_radiation           namelist,dynamics	max_domains    .false. rh    "top_radiation"         ""      ""
+rconfig   integer mix_isotropic           namelist,dynamics	max_domains    0       h    "mix_isotropic"            "0=anistropic, 1=isotropic"      ""
+rconfig   real    mix_upper_bound         namelist,dynamics	max_domains    0.1     h    "mix_upper_bound"          "non-dimensional limit"      ""
+rconfig   logical top_lid                 namelist,dynamics     max_domains    .false. rh    "top_lid"               ""      ""
+rconfig   real    tke_upper_bound         namelist,dynamics	max_domains    1000.   h    "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 coriolis2d              namelist,dynamics	max_domains  .false.  irh  "coriolis2d"    ""   ""
+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"
+rconfig   real    iso_temp                namelist,dynamics	1               0.     h    "iso_temp"   "Isothermal temperature in stratosphere, real only"      "K"
+rconfig   logical use_baseparam_fr_nml    namelist,dynamics	1            .false.  irh   "use_baseparam_fr_nml"    ""   ""
+rconfig   real    fft_filter_lat          namelist,dynamics     1              91.     h    "fft_filter_lat"   ""   "grid latitude to start polar filter"
+rconfig   logical rotated_pole            namelist,dynamics     1            .false.  irh   "rotated_pole"    ""   ""
+rconfig   logical do_coriolis             namelist,dynamics	max_domains  .true.   irh  "do_coriolis"    ""   ""
+rconfig   logical do_curvature            namelist,dynamics	max_domains  .true.   irh  "do_curvature"   ""   ""
+rconfig   logical do_gradp                namelist,dynamics	max_domains  .true.   irh  "do_gradp"    ""   ""
+rconfig   integer     tracer_opt          namelist,dynamics     max_domains    0       rh    "tracer_opt"          ""      ""
+# Placeholder for decoupled advective tendency diagnostics
+rconfig   integer tenddiag                namelist,dynamics     max_domains    0       -     "Decoupled tendency diagnostics"   ""    ""
+
+# 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 constant_bc             namelist,bdy_control          1      .false. rh    "constant_bc"           ""      ""
+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 polar                   namelist,bdy_control	max_domains    .false. rh    "polar"                 ""      ""
+rconfig   logical nested                  namelist,bdy_control	max_domains    .false. rh    "nested"                ""      ""
+rconfig   real    spec_exp                namelist,bdy_control          1     0.      irh    "spec_exp"              ""      ""
+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   integer nobs_ndg_vars           derived                       1         6       -        "num_ndg_vars"         "Number of nudging variables"          ""
+rconfig   integer nobs_err_flds           derived                       1         9       -        "num_err_flds"         "Number of error fields"               ""
+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    pole_lat                derived                  max_domains    0       -        "pole_lat"              "projection info: latitude of pole" "degrees, positive north"
+rconfig   real    pole_lon                derived                  max_domains    0       -        "pole_lon"              "projection info: longitude of pole" "degrees, positive east"
+rconfig   integer  FLAG_METGRID           derived                      1          0       -        "FLAG_METGRID"         "Flag in global attributes for metgrid data"
+rconfig   integer  FLAG_SNOW              derived                      1          0       -        "FLAG_SNOW"             "Flag for snow in the global attributes for metgrid data"
+rconfig   integer  FLAG_PSFC              derived                      1          0       -        "FLAG_PSFC"             "Flag for surface pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM000010          derived                      1          0       -        "FLAG_SM000010"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM010040          derived                      1          0       -        "FLAG_SM010040"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM040100          derived                      1          0       -        "FLAG_SM040100"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM100200          derived                      1          0       -        "FLAG_SM100200"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST000010          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST010040          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST040100          derived                      1          0       -        "FLAG_ST010040"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST100200          derived                      1          0       -        "FLAG_ST100200"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_SLP               derived                      1          0       -        "FLAG_SLP"              "Flag for sea level pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SOILHGT           derived                      1          0       -        "FLAG_SOILHGT"          "Flag for soil height in the global attributes for metgrid data"
+rconfig   integer  FLAG_MF_XY             derived                      1          0       -        "FLAG_MF_XY"            "Flag for MF_XYin the global attributes for metgrid data"
+rconfig   real    bdyfrq                  derived                  max_domains    0       -        "bdyfrq"               "lateral boundary input frequency"      "seconds"
+rconfig   character mminlu                derived                  max_domains    " "     -        "mminlu"               "land use dataset"             ""
+rconfig   integer iswater                 derived                  max_domains    0       -        "iswater"              "land use index of water"      "index category"
+rconfig   integer islake                  derived                  max_domains    0       -        "islake"               "land use index of inland lake"      "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 (Cylindrical), 1=Lambert, 2=polar, 3=Mercator"
+rconfig   integer use_wps_input           derived                       1         0       -        "use_wps_input"        "0/1 flag, using wps input"      "0=no, 1=yes"
+rconfig   integer dfi_stage               derived                  max_domains    3       -        "dfi_stage"            "current stage of DFI processing"      "0=DFI setup, 1=DFI backward integration, 2=DFI forward integration, 3=WRF forecast"
+rconfig   integer mp_physics_dfi          derived                  max_domains   -1       -        "mp_physics_dfi"       ""      "-1 = no DFI and so no need to allocate DFI moist and scalar variables, >0 = running with DFI, so allocate DFI moist and scalar variables appropriate for selected microphysics package"
+
+#
+# Single dummy declaration to define a nodyn dyn option
+state integer nodyn_dummy - dyn_nodyn -  -  -  "" "" ""      
+
+# Turbine drag (td) physics
+# Turbine positions and characteristics for real-data cases are specified in a file 
+# whose name is given in the windturbines_spec variable.  If the setting is "ideal",
+# the td_ variables specify idealized wind farm geometries and turbine characteristics.
+# If the setting is "none" then wind turbine drag physics is turned off.
+rconfig character windturbines_spec namelist,physics 1 "none" - - "" "none, ideal, or a file name"
+rconfig integer td_turbgridid  namelist,physics 1 -1     - - ""  "which grid id has turbines in it"
+rconfig  real   td_hubheight   namelist,physics 1 100.   - - ""  "hub height (m)"
+rconfig  real   td_diameter    namelist,physics 1 60.    - - ""  "turbine diameter (m)"
+rconfig  real   td_stdthrcoef  namelist,physics 1 .158   - - ""  "standing thrust coefficient"
+rconfig  real   td_cutinspeed  namelist,physics 1 4.     - - ""  "cut-in speed (m/s)"
+rconfig  real   td_cutoutspeed namelist,physics 1 27.    - - ""  "cut-out speed (m/s)"
+rconfig  real   td_power       namelist,physics 1 2.     - - ""  "turbine power (MW)"
+rconfig  real   td_turbpercell namelist,physics 1 1.     - - ""  "number of turbines per cell"
+rconfig integer td_ewfx        namelist,physics 1 0      - - ""  "extent of wind farm in x-cells"
+rconfig integer td_ewfy        namelist,physics 1 0      - - ""  "extent of wind farm in y-cells"
+rconfig integer td_pwfx        namelist,physics 1 1      - - ""  "southwest corner of wind farm in x-cells"
+rconfig integer td_pwfy        namelist,physics 1 1      - - ""  "southwest corner of wind farm in y-cells"
+
+
+#
+#---------------------------------------------------------------------------------------------------------------------------------------
+# Package Declarations
+#                                               
+
+#key      package       associated                package          associated 4d scalars
+#         name          namelist choice           state vars
+
+#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;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy
+package   wsm6scheme    mp_physics==6                -             moist:qv,qc,qr,qi,qs,qg
+package   gsfcgcescheme mp_physics==7                -             moist:qv,qc,qr,qi,qs,qg
+package   thompson      mp_physics==8                -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr
+package   milbrandt2mom mp_physics==9                -             state:refl_10cm;moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh
+package   morr_two_moment  mp_physics==10            -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng
+#package   milbrandt3mom mp_physics==12               -             moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qzr,qzi,qzs,qzg,qzh
+package   sbu_ylinscheme    mp_physics==13           -             moist:qv,qc,qr,qi,qs;state:rimi
+package   wdm5scheme    mp_physics==14               -             moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr
+package   wdm6scheme    mp_physics==16               -             moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr
+
+package   nodfimoist        mp_physics_dfi==-1       -             -
+package   passiveqv_dfi     mp_physics_dfi==0        -             dfi_moist:dfi_qv
+package   kesslerscheme_dfi mp_physics_dfi==1        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   linscheme_dfi     mp_physics_dfi==2        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   wsm3scheme_dfi    mp_physics_dfi==3        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   wsm5scheme_dfi    mp_physics_dfi==4        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs
+package   etampnew_dfi      mp_physics_dfi==5        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt
+package   wsm6scheme_dfi    mp_physics_dfi==6        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   gsfcgcescheme_dfi mp_physics_dfi==7        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   thompson_dfi      mp_physics_dfi==8        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr
+package   milbrandt2mom_dfi mp_physics_dfi==9        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh
+package   morr_two_moment_dfi  mp_physics_dfi==10    -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng
+#package   milbrandt3mom_dfi mp_physics_dfi==12       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qzr,dfi_qzi,dfi_qzs,dfi_qzg,dfi_qzh
+package   sbu_ylinscheme_dfi    mp_physics==13           -         dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;state:rimi
+package   wdm5scheme_dfi    mp_physics_dfi==14       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+package   wdm6scheme_dfi    mp_physics_dfi==16       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+
+package   noprogn       progn==0                     -             -
+package   progndrop     progn==1                     -             scalar:qndrop;dfi_scalar:dfi_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;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   rrtmg_lwscheme  ra_lw_physics==4           -             state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   goddardlwscheme  ra_lw_physics==5          -             state:tlwdn,tlwup,slwdn,slwup
+package   gfdllwscheme  ra_lw_physics==99            -             -
+package   heldsuarez    ra_lw_physics==31            -             -
+
+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;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   rrtmg_swscheme  ra_sw_physics==4           -             state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc
+package   goddardswscheme  ra_sw_physics==5          -             state:tswdn,tswup,sswdn,sswup
+package   gfdlswscheme  ra_sw_physics==99            -             -
+
+package   sfclayscheme   sf_sfclay_physics==1        -             -
+package   myjsfcscheme   sf_sfclay_physics==2        -             state:tke_pbl
+package   gfssfcscheme   sf_sfclay_physics==3        -             -
+package   qnsesfcscheme  sf_sfclay_physics==4        -             -
+package   mynnsfcscheme  sf_sfclay_physics==5        -             scalar:qke;state:tsq,qsq,cov
+package   pxsfcscheme    sf_sfclay_physics==7        -             -
+
+package   noahucmscheme  sf_urban_physics==1         -             state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep
+package   bepscheme      sf_urban_physics==2         -             state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d
+package   bep_bemscheme  sf_urban_physics==3         -             state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,sfwin1_urb3d,sfwin2_urb3d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d
+
+package   slabscheme     sf_surface_physics==1       -             -
+package   lsmscheme      sf_surface_physics==2       -             -
+package   ruclsmscheme   sf_surface_physics==3       -             state:smfr3d,keepfr3dflag,soilt1
+package   pxlsmscheme    sf_surface_physics==7       -             state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old
+package   temfsfcscheme  sf_sfclay_physics==10       -             state:wm_temf
+package   idealscmsfcscheme  sf_sfclay_physics==89   -             -
+
+package   ysuscheme      bl_pbl_physics==1           -             -
+package   myjpblscheme   bl_pbl_physics==2           -             state:tke_pbl,el_pbl
+package   gfsscheme      bl_pbl_physics==3           -             -
+package   qnsepblscheme  bl_pbl_physics==4           -             state:tke_pbl,el_pbl
+package   mynnpblscheme2 bl_pbl_physics==5           -             scalar:qke;state:tsq,qsq,cov
+package   mynnpblscheme3 bl_pbl_physics==6           -             scalar:qke;state:tsq,qsq,cov
+package   acmpblscheme   bl_pbl_physics==7           -             -
+package   boulacscheme   bl_pbl_physics==8           -             state:el_pbl,tke_pbl,wu_tur,wv_tur,wt_tur,wq_tur
+package   camuwpblscheme bl_pbl_physics==9           -             state:tauresx2d,tauresy2d,qpert2d,wpert2d,tke_pbl
+package   mrfscheme      bl_pbl_physics==99          -             -
+package   temfpblscheme  bl_pbl_physics==10          -             state:te_temf,kh_temf,km_temf,shf_temf,qf_temf,uw_temf,vw_temf,wupd_temf,mf_temf,thup_temf,qlup_temf,qtup_temf,cf3d_temf,hd_temf,lcl_temf,hct_temf,cfm_temf
+
+package   kfetascheme    cu_physics==1               -             -
+package   bmjscheme      cu_physics==2               -             -
+package   gdscheme       cu_physics==3               -             -
+package   sasscheme      cu_physics==4               -             -
+package   g3scheme       cu_physics==5               -             state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow
+package   tiedtkescheme  cu_physics==6
+package   camzmscheme    cu_physics==7               -             state:precz,zmdt,zmdq,zmdice,zmdliq,evaptzm,fzsntzm,evsntzm,evapqzm,zmflxprc,zmflxsnw,zmntprpd,zmntsnpd,zmeiheat,cmfmc,cmfmcdzm,preccdzm,pconvb,pconvt,cape,zmmtu,zmmtv,zmmu,zmmd,zmupgu,zmupgd,zmvpgu,zmvpgd,zmicuu,zmicud,zmicvu,zmicvd
+package   nsasscheme     cu_physics==14              -             -
+package   kfscheme       cu_physics==99              -             -
+
+package   g3shcuscheme   shcu_physics==1             -             -
+package   camuwshcuscheme shcu_physics==2            -             state:cmfmc,cmfmc2,qtflx_cu,slflx_cu,uflx_cu,vflx_cu,qtten_cu,slten_cu,uten_cu,vten_cu,qvten_cu,qlten_cu,qiten_cu,cbmf_cu,ufrcinvbase_cu,ufrclcl_cu,winvbase_cu,wlcl_cu,plcl_cu,pinv_cu,plfc_cu,pbup_cu,ppen_cu,qtsrc_cu,thlsrc_cu,thvlsrc_cu,emkfbup_cu,cin_cu,cinlcl_cu,cbmflimit_cu,tkeavg_cu,zinv_cu,rcwp_cu,rlwp_cu,riwp_cu,tophgt_cu,wu_cu,ufrc_cu,qtu_cu,thlu_cu,thvu_cu,uu_cu,vu_cu,qtu_emf_cu,thlu_emf_cu,uu_emf_cu,vu_emf_cu,umf_cu,uemf_cu,qcu_cu,qlu_cu,qiu_cu,cufrc_cu,fer_cu,fdr_cu,dwten_cu,diten_cu,qrten_cu,qsten_cu,flxrain_cu,flxsnow_cu,ntraprd_cu,ntsnprd_cu,excessu_cu,excessu0_cu,xc_cu,aquad_cu,bquad_cu,cquad_cu,bogbot_cu,bogtop_cu,exit_uwcu_cu,exit_conden_cu,exit_klclmkx_cu,exit_klfcmkx_cu,exit_ufrc_cu,exit_wtw_cu,exit_drycore_cu,exit_wu_cu,exit_cufliter_cu,exit_kinv1_cu,exit_rei_cu,limit_shcu_cu,limit_negcon_cu,limit_ufrc_cu,limit_ppen_cu,limit_emf_cu,limit_cinlcl_cu,limit_cin_cu,limit_cbmf_cu,limit_rei_cu,ind_delcin_cu,evapcsh,cmfsl,cmflq,cldfrash,cush,icwmrsh,snowsh,rprdsh,rliq2
+
+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;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten
+package   psusfddagd     grid_sfdda==1               -             state:u10_ndg_old,v10_ndg_old,t2_ndg_old,th2_ndg_old,q2_ndg_old,rh_ndg_old,psl_ndg_old,ps_ndg_old,u10_ndg_new,v10_ndg_new,t2_ndg_new,th2_ndg_new,q2_ndg_new,rh_ndg_new,psl_ndg_new,ps_ndg_new,tob_ndg_old,odis_ndg_old,tob_ndg_new,odis_ndg_new
+
+package   spnudging      grid_fdda==2               -              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;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten
+
+package   slopeopt       slope_rad==1               -              -
+package   gwdopt         gwd_opt==1                 -              state:var2d,oc12d,oa1,oa2,oa3,oa4,ol1,ol2,ol3,ol4,dtaux3d,dtauy3d,dusfcg,dvsfcg
+package   omlopt         omlcall==1                 -              state:tml,t0ml,hml,h0ml,huml,hvml,tmoml
+package   scmopt         scm_force==1               -              state:z_force,z_force_tend,u_g,u_g_tend,v_g,v_g_tend,w_subs,w_subs_tend,th_upstream_x,th_upstream_x_tend,th_upstream_y,th_upstream_y_tend,qv_upstream_x,qv_upstream_x_tend,qv_upstream_y,qv_upstream_y_tend,u_upstream_x,u_upstream_x_tend,u_upstream_y,u_upstream_y_tend,v_upstream_x,v_upstream_x_tend,v_upstream_y,v_upstream_y_tend,tau_x,tau_x_tend,tau_y,tau_y_tend,th_largescale,th_largescale_tend,qv_largescale,qv_largescale_tend,ql_largescale,ql_largescale_tend,u_largescale,u_largescale_tend,v_largescale,v_largescale_tend,tau_largescale,tau_largescale_tend,ql_upstream_x,ql_upstream_x_tend,ql_upstream_y,ql_upstream_y_tend,t_soil_forcing_val,t_soil_forcing_tend,q_soil_forcing_val,q_soil_forcing_tend,tau_soil,soil_depth_force
+
+package   prec_acc       prec_acc_opt==1            -              state:prec_acc_c,prec_acc_nc,snow_acc_nc
+package   bucketropt     bucketr_opt==1             -              state:i_rainc,i_rainnc
+
+package   restofwrf      use_wps_input==0            -             -
+
+package   original         moist_adv_opt==0            -             -
+package   positivedef    moist_adv_opt==1            -             -
+package   monotonic      moist_adv_opt==2            -             -
+package   tracer_test1  tracer_opt==2       -             tracer:tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8
+
+package   dfi_setup      dfi_stage==0                -             -
+package   dfi_bck        dfi_stage==1                -             -
+package   dfi_fwd        dfi_stage==2                -             -
+package   dfi_fst        dfi_stage==3                -             -
+package   dfi_startfwd   dfi_stage==4                -             -
+package   dfi_startbck   dfi_stage==5                -             -
+
+#package   digifilter     dfi_opt==1                  -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_rh,dfi_tten_rad
+package   dfi_nodfi     dfi_opt==0                  -             -
+package   dfi_dfl       dfi_opt==1                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   dfi_ddfi      dfi_opt==2                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   dfi_tdfi      dfi_opt==3                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   realonly       use_wps_input==1            -             state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc
+
+
+# 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                     -             -
+             
+# Tendency diagnostics for non-chemistry
+#
+# Placeholders for decoupled advective tendency arrays
+package   notenddiag    tenddiag==0                     -             -
+package   usetenddiag   tenddiag==1                     -             -
+                                   
+#---------------------------------------------------------------------------------------------------------------------------------------
+## 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,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,f,e,sina,cosa,ht,potevp,snopcx,soiltb,xlat,xlong,xlat_u,xlat_v,xlong_u,xlong_v,clat,clong
+halo      HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar,tracer
+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_PHYS_CU dyn_em         4:rucuten,rvcuten
+halo      HALO_EM_PHYS_SHCU dyn_em       4:rushten,rvshten
+halo      HALO_EM_FDDA dyn_em            4:rundgdten,rvndgdten
+halo      HALO_EM_FDDA_SFC dyn_em 48:z,z_at_w,pblh,regime,znt,odis_ndg_old,odis_ndg_new
+halo      HALO_EM_PHYS_DIFFUSION dyn_em  4:defor11,defor22,defor12,defor13,defor23,div,xkmv,xkmh,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,ustm
+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,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,muts
+halo      HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,tracer,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,tracer,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,tracer,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,tracer,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_CUP_G3_IN dyn_em 24:RTHFTEN,RQVFTEN,w_2,t_phy
+halo      HALO_CUP_G3_OUT dyn_em 48:cugd_tten,cugd_qvten,cugd_ttens,cugd_qvtens,raincv
+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_TRACER_E_3 dyn_em 24:tracer
+halo      HALO_EM_TRACER_E_5 dyn_em 48:tracer
+halo      HALO_EM_TRACER_E_7 dyn_em 80:tracer
+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_TOPOSHAD phys 24:ht_shad
+
+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_TRACER_OLD_E_3 dyn_em 24:tracer_old
+halo      HALO_EM_TRACER_OLD_E_5 dyn_em 48:tracer_old
+halo      HALO_EM_TRACER_OLD_E_7 dyn_em 80:tracer_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_HYDRO_UV   dyn_em 8:u_2,v_2
+
+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,tracer,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,tracer,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:ph_2,p,uratx,vratx,tratx,kpbl
+
+# 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,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,sina,cosa,e,f
+
+# Monotonic, positive definite advection requires 4 values for moist, chem, tke, and scalar for periodic lateral boundaries
+
+period    PERIOD_BDY_EM_MOIST dyn_em 4:moist
+period    PERIOD_BDY_EM_CHEM dyn_em 4:chem
+period    PERIOD_BDY_EM_TRACER dyn_em 4:tracer
+period    PERIOD_BDY_EM_SCALAR dyn_em 4:scalar
+period    PERIOD_BDY_EM_TKE dyn_em 4:tke_2
+period    PERIOD_BDY_EM_MOIST2 dyn_em 4:moist
+period    PERIOD_BDY_EM_CHEM2 dyn_em 4:chem
+period    PERIOD_BDY_EM_TRACER2 dyn_em 4:tracer
+period    PERIOD_BDY_EM_SCALAR2 dyn_em 4:scalar
+period    PERIOD_BDY_EM_MOIST_OLD dyn_em 4:moist_old
+period    PERIOD_BDY_EM_CHEM_OLD dyn_em 4:chem_old
+period    PERIOD_BDY_EM_TRACER_OLD dyn_em 4:tracer_old
+period    PERIOD_BDY_EM_SCALAR_OLD dyn_em 4:scalar_old
+period    PERIOD_BDY_EM_TKE_OLD dyn_em 4:tke_1
+
+period    PERIOD_BDY_EM_E dyn_em 2:u_2,v_2,ht
+period    PERIOD_EM_HYDRO_UV dyn_em 1:u_2,v_2
+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,ustm
+period    PERIOD_BDY_EM_PHY_BC dyn_em 2:rublten,rvblten,rucuten,rvcuten,xkmh,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,msfvx,msfvy,muu,msfux,msfuy,msfvx_inv
+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
+period    PERIOD_EM_DA dyn_em 2:ru_m,rv_m,ww_m,mut,muts
+
+#
+#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 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 NSTAW        # number of obs stations within current time window
+typedef fdob_type integer KTAUR        # restart model step
+typedef fdob_type integer LEVIDN(max_domains)   # level of nest
+typedef fdob_type integer REFPRT(max_domains)   # reference obs index for diagnostic printout
+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 logical NUDGE_UV_PBL # Flag for wind nudging within the PBL
+typedef fdob_type logical NUDGE_T_PBL  # Flag for temperature nudging within the PBL
+typedef fdob_type logical NUDGE_Q_PBL  # Flag for moisture nudging within the PBL
+typedef fdob_type integer SFC_SCHEME_HORIZ # Flag for horizontal spreading scheme for surface obs
+typedef fdob_type integer SFC_SCHEME_VERT  # Flag for vertical   spreading scheme for surface obs
+typedef fdob_type real    MAX_SNDNG_GAP # Maximum pressure gap allowed for interpolating between soundings (centibars)
+typedef fdob_type real    SFCFACT      # scale factor applied to time window for surface obs
+typedef fdob_type real    SFCFACR      # scale factor applied to horiz radius of influence for surface obs
+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    KNOWN_LAT    # Latitude  of origin point (i,j)=(1,1)
+typedef fdob_type real    KNOWN_LON    # Longitude of origin point (i,j)=(1,1)
+typedef fdob_type character SDATE      # domain starting date (YYYY-MM-DD_hh:mm:ss)
+typedef fdob_type real    XTIME_AT_REST # xtime at restart time
+typedef fdob_type real    VIF_UV(6)    # Vertical influence function parameters for wind nudging
+typedef fdob_type real    VIF_T(6)     # Vertical influence function parameters for temperature nudging
+typedef fdob_type real    VIF_Q(6)     # Vertical influence function parameters for moisture nudging
+typedef fdob_type real    VIF_FULLMIN  # Minimum depth through which vert infl fcn remains 1.0 (m)
+typedef fdob_type real    VIF_RAMPMIN  # Minimum depth through which vif decreases 1.0 to 0.0 (m)
+typedef fdob_type real    VIF_MAX      # Maximum depth in which vif is nonzero (m)
+
+# table entries are of the form
+#      <Table>  <Type>  <Sym>                <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>
+#Grid variables
+typedef fdob_type real    varobs         {nndgvar}{obs} -         1        -       -       "varobs"          "observational values in each variable"
+typedef fdob_type real    errf              h{obs}      -         1        -       -       "errf"            "errors between model and obs values"
+typedef fdob_type real    timeob             {obs}      -         1        -       -       "timeob"          "model times for each observation"          "hours"
+typedef fdob_type real    nlevs_ob           {obs}      -         1        -       -       "nlevs_ob"        "numbers of levels in sounding obs"
+typedef fdob_type real    lev_in_ob          {obs}      -         1        -       -       "lev_in_ob"       "level in sounding-type obs"
+typedef fdob_type real    plfo               {obs}      -         1        -       -       "plfo"            "index for type of obs-platform"
+typedef fdob_type real    elevob             {obs}      -         1        -       -       "elevob"          "elevation of observation"                  "meters"
+typedef fdob_type real    rio                {obs}      -         1        -       -       "rio"             "west-east grid coordinate"
+typedef fdob_type real    rjo                {obs}      -         1        -       -       "rjo"             "south-north grid coordinate"
+typedef fdob_type real    rko                {obs}      -         1        -       -       "rko"             "vertical grid coordinate"
+typedef fdob_type integer obsprt               [        -         1        -       -       "obsprt"          "obs index for diagnostic printout"
+typedef fdob_type real    latprt               [        -         1        -       -       "latprt"          "obs latitude for diagnostic printout"
+typedef fdob_type real    lonprt               [        -         1        -       -       "lonprt"          "obs longitude for diagnostic printout"
+typedef fdob_type real    mlatprt              [        -         1        -       -       "mlatprt"         "model latitude at obs location"
+typedef fdob_type real    mlonprt              [        -         1        -       -       "mlonprt"         "model longitude at obs location"
+typedef fdob_type integer stnidprt       {obsstid}{[}   -         1        -       -       "stnidprt"        "obs station id for diagnostic printout"
+typedef fdob_type real    base_state           k        -         1        -       -       "base_state"      "base-state height on half (mass) levels"   "meters"
+
+state fdob_type fdob - -
+
+# xpose variables for polar fft
+state    real   t_xxx          ikjx    -           1        -
+state    real   u_xxx          ikjx    -           1        X
+state    real   ru_xxx         ikjx    -           1        X
+state    real   v_xxx          ikjx    -           1        Y
+state    real   rv_xxx         ikjx    -           1        Y
+state    real   w_xxx          ikjx    -           1        Z
+state    real   ww_xxx         ikjx    -           1        Z
+state    real   ph_xxx         ikjx    -           1        Z
+state    real   dum_yyy        ikjy    -           1        -
+state    real   fourd_xxx      ikjx    -           1        -
+state    real   clat_xxx       ijx     -           1        -
+state    real   ht_xxx         ijx     -           1        -
+state    real   mf_xxx         ijx     -           1        -
+
+xpose XPOSE_POLAR_FILTER_TOPO dyn_em t_init,t_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_T  dyn_em t_2,t_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_U  dyn_em u_2,u_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_RU dyn_em ru_m,ru_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_V  dyn_em v_2,v_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_RV dyn_em rv_m,rv_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_W  dyn_em w_2,w_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_WW dyn_em ww_m,ww_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_PH dyn_em ph_2,ph_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_MOIST dyn_em moist,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_CHEM dyn_em chem,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_TRACER dyn_em tracer,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_SCALAR dyn_em scalar,fourd_xxx,dum_yyy
+
+# xpose variables for spectral nudging
+state    real   dif_analysis     ikj     -           1
+state    real   dif_xxx          ikjx    -           1     
+state    real   dif_yyy          ikjy    -           1     
+
+xpose XPOSE_SPECTRAL_NUDGING dyn_em dif_analysis,dif_xxx,dif_yyy
+##
+
+include registry.fire
+include registry.avgflx
+include registry.stoch
+
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.NMM
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.NMM	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.NMM	(revision 17)
@@ -0,0 +1,1329 @@
+# 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=<variable name>".  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.
+#
+
+include registry.dimspec
+
+#### 7. Edit the Registry file and create the state data assocaited with this
+####    solver.  Single entry:
+state real x ikj dyn_exp 2 - ir "TOYVAR"
+####
+
+#############
+rconfig   integer ntracers                namelist,physics     1              4       -
+
+# option 1
+#dimspec ntracevars   -     constant=4             c       number of 4d tracer variables
+#state   real    -   ijk{ntracevars}f  tracers   1  -  - - -
+#state   real    t1  ijk{ntracevars}f  tracers   1  -  r - -
+#state   real    t2  ijk{ntracevars}f  tracers   1  -  r - -
+#state   real    t3  ijk{ntracevars}f  tracers   1  -  r - -
+#state   real    t4  ijk{ntracevars}f  tracers   1  -  r - -
+#package   tracer_option_1     ntracers==4                -             tracers:t1,t2,t3,t4
+
+# option 2
+state   real    -     ijkf  szj   1  -  - - - 
+state   real    szj1  ijkf  szj   1  -  - "szj1" "szj" "units"
+state   real    szj2  ijkf  szj   1  -  - "szj2" "szj" "units"
+state   real    szj3  ijkf  szj   1  -  - "szj3" "szj" "units"
+state   real    szj4  ijkf  szj   1  -  - "szj4" "szj" "units"
+
+state   real    -     ijkf  s1z   1  -  - - -
+state   real    s1z1  ijkf  s1z   1  -  - "s1z1" "s1z" "units"
+state   real    s1z2  ijkf  s1z   1  -  - "s1z2" "s1z" "units"
+state   real    s1z3  ijkf  s1z   1  -  - "s1z3" "s1z" "units"
+state   real    s1z4  ijkf  s1z   1  -  - "s1z4" "s1z" "units"
+
+state   real    -     ijkf  spz   1  -  - - - 
+state   real    spz1  ijkf  spz   1  -  - "spz1" "spz" "units"
+state   real    spz2  ijkf  spz   1  -  - "spz2" "spz" "units"
+state   real    spz3  ijkf  spz   1  -  - "spz3" "spz" "units"
+state   real    spz4  ijkf  spz   1  -  - "spz4" "spz" "units"
+
+state   real    -     ijkf  tcs   1  -  - - - 
+state   real    tcs1  ijkf  tcs   1  -  - "tcs1" "tcs" "units"
+state   real    tcs2  ijkf  tcs   1  -  - "tcs2" "tcs" "units"
+state   real    tcs3  ijkf  tcs   1  -  - "tcs3" "tcs" "units"
+state   real    tcs4  ijkf  tcs   1  -  - "tcs4" "tcs" "units"
+
+package tracer_option_2 ntracers==4 - szj:szj1,szj2,szj3,szj4;s1z:s1z1,s1z2,s1z3,s1z4;spz:spz1,spz2,spz3,spz4;tcs:tcs1,tcs2,tcs3,tcs4
+
+################################################################################
+################################################################################
+################################################################################
+
+# 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   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     -     i014r    "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...
+
+state integer julyr_rst      -     dyn_nmm     1      -    r  "JULYR_RST" "JULYR for restart moving nest "
+state integer julday_rst     -     dyn_nmm     1      -    r  "JULDAY_RST" "JULDAY for restart moving nest "
+state real    gmt_rst        -     dyn_nmm     1      -    r  "GMT_RST" "GMT for restart moving nest "
+state integer NTIME0         -     dyn_nmm     1      -    r  "NTIME0" "COUNT FOR PREVIOUS MOVING NEST"
+
+# flag for nest movement
+state  logical moved       -     misc       1      -     -
+
+state   real   ducudt       ijk     misc        1         -    rh  "UMMIX" "U TENDENCY  MOMENTUM MIXING IN SAS"
+state   real   dvcudt       ijk     misc        1         -    rh  "VMMIX" "V TENDENCY  MOMENTUM MIXING IN SAS"
+# For random number in SAS convection in HWRF
+
+state  real    store_rand  ij    dyn_nmm   1      -      rh      "RANDOM"  "RANDOM NUMBER FOR SAS"                       ""
+state  integer nrnd1        k    dyn_nmm   1      -      r       "NRND1"   "Receives seed for random number generator"   ""
+
+#
+# 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"         ""
+#
+# 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         ijkb    dyn_nmm    1      -      i01rh   "T"       "Sensible temperature"                          "K"
+state  real   q         ijkb    dyn_nmm    1      -      i01rh   "Q"       "Specific humidity"                             "kg kg-1"
+state  real   u         ijkb    dyn_nmm    1      -      i01rh   "U"       "U component of wind"                           "m s-1"
+state  real   v         ijkb    dyn_nmm    1      -      i01rh   "V"       "V component of wind"                           "m s-1"
+state  real   told      ijk     dyn_nmm    1      -      r       "TOLD"    "T from previous timestep"                      "K"
+state  real   uold      ijk     dyn_nmm    1      -      r       "UOLD"    "U from previous timestep"                      "m s-1"
+state  real   vold      ijk     dyn_nmm    1      -      r       "VOLD"    "V from previous timestep"                      "m s-1"
+#
+# NMM DFI
+#
+# state   real   hcoeff         {ndfi} misc        1         -     -    "HCOEFF"               "initialization weights"
+# state   real   hcoeff_tot       -    misc        1         -     -    "HCOEFF_TOT"               "initialization weights"
+
+state  real   dfi_pd        ij     misc    1      -      r   "DFI_PD"      "Mass at I,J in the sigma domain"               "Pa"
+state  real   dfi_pint      ijk    misc    1      Z      r   "DFI_PINT"      "Model layer interface pressure"   "Pa"
+state  real   dfi_dwdt      ijk    misc    1      -     r    "DFI_DWDT"      "dwdt and 1+(dwdt)/g"              "m s-2"
+state  real   dfi_t         ijk    misc    1      -      r   "DFI_T"       "Sensible temperature"                          "K"
+state  real   dfi_q         ijk    misc    1      -      r   "DFI_Q"       "Specific humidity"                             "kg kg-1"
+state  real   dfi_u         ijk    misc    1      -      r   "DFI_U"       "U component of wind"                           "m s-1"
+state  real   dfi_v         ijk    misc    1      -      r   "DFI_V"       "V component of wind"                           "m s-1"
+state  real   dfi_q2        ijk    misc    1      -      r   "DFI_Q2"      "2 * Turbulence kinetic energy"                 "m2 s-2"
+state  real   dfi_cwm       ijk    misc    1      -      r   "DFI_CWM"     "Total condensate"                              "kg kg-1"
+state  real   dfi_rrw       ijk    misc    1      -      r   "DFI_RRW"     "Tracer"                                        "kg kg-1"
+#
+### remaining simply set aside, and restored to original values after filtering.
+#
+state    real  dfi_STC        ilj   misc          1         Z     r    "DFI_STC"         "SOIL TEMPERATURE"   "K"
+state    real  dfi_SMC        ilj   misc          1         Z     r    "DFI_SMC"       "SOIL MOISTURE"     "m3 m-3"
+state    real  dfi_SH2O       ilj   misc          1         Z     r    "DFI_SH2O"      "UNFROZEN SOIL MOISTURE"     "m3 m-3"
+
+state    real  dfi_SNOW        ij    misc        1         -     r    "dfi_SNOW"         "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real  dfi_SNOWH       ij    misc        1         -     r    "dfi_SNOWH"        "PHYSICAL SNOW DEPTH"      "m"
+state    real  dfi_CANWAT      ij    misc        1         -     r    "dfi_CANWAT"       "CANOPY WATER"             "kg m-2"
+state    real  dfi_NMM_TSK      ij      misc        1       -     r   "dfi_NMM_TSK"               "saved SURFACE SKIN TEMPERATURE"
+state    real  dfi_SNOWC        ij      misc        1       -      r  "dfi_SNOWC"             "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)"         ""
+#
+# 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      Z      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      Z      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       ij     dyn_nmm     1      -      -       "ADT"     "Change of T due to advection"                  "K"
+state  real   adu       ij     dyn_nmm     1      -      -       "ADU"     "Change of U due to advection"                  "m s-1"
+state  real   adv       ij     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       ijk    dyn_nmm     1      -      r       "DIV"     "Divergence"                                 "Pa s-1"
+state  real   few       ijk    dyn_nmm     1      -      -       "FEW"     "Integrated east-west mass flux"             "Pa m2 s-1"
+state  real   fne       ijk    dyn_nmm     1      -      -       "FNE"     "Integrated northeast-southwest mass flux"   "Pa m2 s-1"
+state  real   fns       ijk    dyn_nmm     1      -      -       "FNS"     "Integrated north-south mass flux"           "Pa m2 s-1"
+state  real   fse       ijk    dyn_nmm     1      -      -       "FSE"     "Integrated southeast-northwest mass flux"   "Pa m2 s-1"
+state  real   omgalf    ijk    dyn_nmm     1      -      r       "OMGALF"  "Omega-alpha"                                "K"
+state  real   petdt     ijk    dyn_nmm     1      -      -       "PETDT"   "Vertical mass flux"                         "Pa s-1"
+state  real   rtop      ijk    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   mixht     ij    dyn_nmm   1    -     rh       "MIXHT"                 "MXL HEIGHT"              "m"
+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   taux      ij    dyn_nmm   1    -     irh      "TAUX"     "Instantaneous stress along X direction in KG/M/S^2" 
+state  real   tauy      ij    dyn_nmm   1    -     irh      "TAUY"     "Instantaneous stress along Y direction in KG/M/S^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 eqiv of snow on ground"  "kg m-2"
+state  real   si        ij    dyn_nmm   1    -     irh      "SI"       "Depth of snow on ground"              "mm"
+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    -     rh       "TH10"     "10-m potential temperature from MYJ"  "K"
+state  real   q10       ij    dyn_nmm   1    -     rh       "Q10"      "10-m specific humidity from MYJ"      "kg kg-1"
+state  real   pshltr    ij    dyn_nmm   1    -     rh       "PSHLTR"   "2-m pressure from MYJ"                "Pa"
+state  real   tshltr    ij    dyn_nmm   1    -     rh       "TSHLTR"   "2-m potential temperature from MYJ"   "K"
+state  real   qshltr    ij    dyn_nmm   1    -     rh       "QSHLTR"   "2-m specific humidity from MYJ"       "kg kg-1"
+state  real   q2        ijkb  dyn_nmm   1    -     irh      "Q2"       "2 * Turbulence kinetic energy"        "m2 s-2"
+state  real   t_adj     ijk   dyn_nmm   1    -     r        "T_ADJ"    "T change due to precip in phys step"  "K"
+state  real   t_old     ijk   dyn_nmm   1    -     r        "T_OLD"    "T before last call to precip"         "K"
+state  real   zero_3d   ijk   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    -     rh       "AKHS_OUT"  "Output sfc exch coeff for heat"               "m2 s-1"
+state  real   AKMS_OUT  ij    dyn_nmm   1    -     rh       "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   embck     ij    dyn_nmm   1    -     ir       "EMBCK"     "Background radiative emissivity"                 ""
+state  real   epsr      ij    dyn_nmm   1    -     irh      "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   def3d     ijk   dyn_nmm   1    -     r        "DEF3D"     "Deformation term from horizontal diffusion"      ""
+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       ijkb  dyn_nmm   1    -     rh       "CWM"       "Total condensate"                     "kg kg-1"
+state  real   rrw       ijkb  dyn_nmm   1    -     rh       "RRW"       "Tracer"                               "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    ijk   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    -     irh      "DZSOIL"    "Thickness of soil layers"         "m"
+state  real   rtdpth    k     dyn_nmm   1    -     i01r 
+state  real   sldpth    k     dyn_nmm   1    -     i01rh    "SLDPTH"    "Depths of centers 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    -     i014rh    "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_GWD.F
+#
+state  real   hstdv     ij    dyn_nmm   1    -     i01rh      "HSTDV"     "Standard deviation of height"     "m"
+state  real   hcnvx     ij    dyn_nmm   1    -     i01rh      "HCNVX"     "Normalized 4th moment of orographic convexity"     ""
+state  real   hasyw     ij    dyn_nmm   1    -     i01rh      "HASYW"     "Orographic asymmetry in W-E plane"  ""
+state  real   hasys     ij    dyn_nmm   1    -     i01rh      "HASYS"     "Orographic asymmetry in S-N plane"  ""
+state  real   hasysw    ij    dyn_nmm   1    -     i01rh      "HASYSW"    "Orographic asymmetry in SW-NE plane"  ""
+state  real   hasynw    ij    dyn_nmm   1    -     i01rh      "HASYNW"    "Orographic asymmetry in NW-SE plane"  ""
+state  real   hlenw     ij    dyn_nmm   1    -     i01rh      "HLENW"     "Orographic length scale in W-E plane"  ""
+state  real   hlens     ij    dyn_nmm   1    -     i01rh      "HLENS"     "Orographic length scale in S-N plane"  ""
+state  real   hlensw    ij    dyn_nmm   1    -     i01rh      "HLENSW"    "Orographic length scale in SW-NE plane"  ""
+state  real   hlennw    ij    dyn_nmm   1    -     i01rh      "HLENNW"    "Orographic length scale in NW-SE plane"  ""
+state  real   hangl     ij    dyn_nmm   1    -     i01rh      "HANGL"     "Angle of the mountain range w/r/t east"  "deg"
+state  real   hanis     ij    dyn_nmm   1    -     i01rh      "HANIS"     "Anisotropy/aspect ratio of orography"   ""
+state  real   hslop     ij    dyn_nmm   1    -     i01rh      "HSLOP"     "Slope of orography"             ""
+state  real   hzmax     ij    dyn_nmm   1    -     i01rh      "HZMAX"     "Maximum height above mean orography"    "m"
+state  real   crot      ij    dyn_nmm   1    -      -       "CROT"      "Cosine of angle between model and earth coordinates"    ""
+state  real   srot      ij    dyn_nmm   1    -      -       "SROT"      "Sine of angle between model and earth coordinates"    ""
+state  real   UGWDsfc   ij    dyn_nmm   1    -      h       "UGWDsfc"   "Surface zonal wind stress due to gravity wave drag"    "N m-2"
+state  real   VGWDsfc   ij    dyn_nmm   1    -      h       "VGWDsfc"   "Surface meridional wind stress due to gravity wave drag"    "N m-2"
+#
+# 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      ijk   dyn_nmm   1    -     r        "DWDT"      "dwdt and 1+(dwdt)/g"              "m s-2"
+state  real   pdwdt     ijk   dyn_nmm   1    -     r   
+state  real   pint      ijk   dyn_nmm   1    Z     rh       "PINT"      "Model layer interface pressure"   "Pa"
+state  real   w         ijk   dyn_nmm   1    Z     rh       "W"         "Vertical velocity"                "m s-1"
+state  real   z         ijk   dyn_nmm   1    Z     -        "Z"         "Distance from ground"             "m"
+#
+# module_ACCUM.F
+#
+state  real   acfrcv    ij    dyn_nmm     1    -    rh    "ACFRCV"    "Accum convective cloud fraction"   ""
+state  real   acfrst    ij    dyn_nmm     1    -    rh    "ACFRST"    "Accum stratiform cloud fraction"   ""
+state  real   ssroff    ij    dyn_nmm     1    -    rh    "SSROFF"    "Surface runoff"                    "mm"
+state  real   bgroff    ij    dyn_nmm     1    -    rh    "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    -    rh    "ALWIN"     "Accum LW down at surface"          "W m-2"
+state  real   alwout    ij    dyn_nmm     1    -    rh    "ALWOUT"    "Accum RADOT (see above)"           "W m-2"
+state  real   alwtoa    ij    dyn_nmm     1    -    rh    "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    -    rh    "ASWIN"     "Accum SW down at surface"          "W m-2"
+state  real   aswout    ij    dyn_nmm     1    -    rh    "ASWOUT"    "Accum RSWOUT"                      "W m-2"
+state  real   aswtoa    ij    dyn_nmm     1    -    rh    "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    -    rh
+state  real   tlmax     ij    dyn_nmm     1    -    rh
+state  real   t02_min   ij    dyn_nmm     1    -    rh    "T02_MIN"  "Hourly Min Shelter Temperature"    "K"
+state  real   t02_max   ij    dyn_nmm     1    -    rh    "T02_MAX"  "Hourly Max Shelter Temperature"    "K"
+state  real   rh02_min  ij    dyn_nmm     1    -    rh    "RH02_MIN" "Hourly Min Relative Humidity"    ""
+state  real   rh02_max  ij    dyn_nmm     1    -    rh    "RH02_MAX" "Hourly Max Relative Humidity"    ""
+state  real   rlwtt     ijk   dyn_nmm     1    -    r     "RLWTT"     "Longwave temperature tendency"     "K s-1"
+state  real   rswtt     ijk   dyn_nmm     1    -    r     "RSWTT"     "Shortwave temperature tendency"    "K s-1"
+state  real   tcucn     ijk   dyn_nmm     1    -    -     "TCUCN"     "Accum convec temperature tendency" "K s-1"
+state  real   train     ijk   dyn_nmm     1    -    -     "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    -    -
+state integer iradg     r    dyn_nmm     1    -    -
+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                                         
+#<Table> <Type> <Sym>         <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>   
+#
+# 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
+#-------------------------------------------------------------------------------------------------------------------------------
+
+# Time series variables
+state    real   ts_hour         ?!       misc      -         -      -        "TS_HOUR"        "Model integration time, hours"
+state    real   ts_u            ?!       misc      -         -      -        "TS_U"           "Surface wind U-component, earth-relative"
+state    real   ts_v            ?!       misc      -         -      -        "TS_V"           "Surface wind V-component, earth-relative"
+state    real   ts_q            ?!       misc      -         -      -        "TS_Q"           "Surface mixing ratio"
+state    real   ts_t            ?!       misc      -         -      -        "TS_T"           "Surface temperature"
+state    real   ts_psfc         ?!       misc      -         -      -        "TS_PSFC"        "Surface pressure"
+state    real   ts_tsk          ?!       misc      -         -      -        "TS_TSK"         "Skin temperature"
+state    real   ts_tslb         ?!       misc      -         -      -        "TS_TSLB"        "Soil temperature"
+state    real   ts_clw          ?!       misc      -         -      -        "TS_CLW"         "Column integrated cloud water"
+
+#-----------------------------------------------------------------------------------------------------------------------------------------------------------------
+
+
+# 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    -              ijkft   moist       1         -     -    -                                       
+state   real    qv             ijkft   moist       1         -     rh      "QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    qc             ijkft   moist       1         -     rh      "QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    qr             ijkft   moist       1         -     rh      "QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    qi             ijkft   moist       1         -     rh      "QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    qs             ijkft   moist       1         -     rh      "QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    qg             ijkft   moist       1         -     rh      "QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+state   real    qh             ijkft   moist       1         -     rh      "QHAIL"            "Hail mixing ratio"             "kg kg-1" 
+
+state   real    -              ijkft   dfi_moist       1         -     -    -
+state   real    dfi_qv         ijkft   dfi_moist       1         -     r      "QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    dfi_qc         ijkft   dfi_moist       1         -     r      "QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    dfi_qr         ijkft   dfi_moist       1         -     r      "QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    dfi_qi         ijkft   dfi_moist       1         -     r      "QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    dfi_qs         ijkft   dfi_moist       1         -     r      "QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    dfi_qg         ijkft   dfi_moist       1         -     r      "QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+state   real    dfi_qh         ijkft   dfi_moist       1         -     r      "QHAIL"             "Hail mixing ratio"              "kg kg-1"
+state   real    dfi_qnh        ijkft   dfi_moist       1         -     r      "QNHAIL"           "Hail Number concentration"        "# kg(-1)"   
+
+#                                               
+# Other Scalars
+state   real    -              ijkftb  scalar      1         -     -    -
+state   real    qni            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNI"              "Ice Number concentration" "# kg(-1)"
+state   real    qns            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNS"              "Snow Number concentration" "# kg(-1)"
+state   real    qnr            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNR"              "Rain Number concentration" "# kg(-1)"
+state   real    qng            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNG"              "Graupel Number concentration" "# kg(-1)"
+state   real    qnh            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNHAIL"            "Hail Number concentration" "# kg(-1)" 
+
+state   real    qnn            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNCCN"            "CCN Number concentration" "# kg(-1)"
+state   real    qnc            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNCLOUD"          "cloud water Number concentration" "# kg(-1)"
+
+state   real    -              ijkftb  dfi_scalar      1         -     -   -
+state   real    dfi_qndrop     ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNDROP"    "Droplet number mixing ratio"        "# kg-1"
+state   real    dfi_qni        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNICE"     "Ice Number concentration" "# kg-1"
+state   real    dfi_qt         ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_CWM"       "Total condensate mixing ratio"      "kg kg-1"
+state   real    dfi_qns        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNSNOW"    "Snow Number concentration"   "# kg(-1)"
+state   real    dfi_qnr        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNRAIN"    "Rain Number concentration"   "# kg(-1)"
+state   real    dfi_qng        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)"
+state   real    dfi_qnn        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCC"      "CNN Number concentration"   "# kg(-1)"
+state   real    dfi_qnc        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCLOUD"   "Cloud 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   SMCREL           ilj     -          1         Z     r        "SMCREL"               "RELATIVE 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   LAI              ij     misc        1         -     i0124rh   "LAI"                  "Leaf area index"          "area/area"
+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         -     i014rh       "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         -     i0124r   "ALBBCK"          "BACKGROUND ALBEDO"        "NA"
+state    real   SFCEXC           ij     misc        1         -     irh     "SFCEXC "              "SURFACE EXCHANGE COEFFICIENT"         ""
+state    real   SNOTIME          ij     misc        1         -     r        "SNOTIME"              "SNOTIME"                             ""
+state    real   ACSNOW           ij     misc        1         -     irh       "ACSNOW"               "ACCUMULATED SNOW"      "kg m-2"
+state    real   ACSNOM           ij     misc        1         -     irh       "ACSNOM"               "ACCUMULATED MELTED SNOW"         "kg m-2"
+state    real   RMOL             ij     misc        1         -     ir       "RMOL"               ""         ""
+state    real   SNOW             ij     misc        1         -     i01rh       "SNOW"                 "SNOW WATER EQUIVALENT"         "kg m-2"
+state    real   CANWAT           ij     misc        1         -     i01rh       "CANWAT"               "CANOPY WATER" ""
+state    real   SST              ij     misc        1         -     i014rh       "SST"                  "SEA SURFACE TEMPERATURE" "K"
+state    real   WEASD            ij     misc        1         -     i01rh       "WEASD"                "WATER EQUIVALENT OF ACCUMULATED SNOW" "kg m-2"
+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  NOAHRES          ij      misc        1         -     rh        "NOAHRES"               "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}"
+
+state    real   tke_pbl         ijk     misc        1         -     r         "TKE_PBL"               "TKE FROM PBL SCHEME"     "m2 s-2"
+state    real   el_pbl          ikj     misc        1         -     -         "EL_PBL"                "MIXING LENGTH FROM PBL SCHEME"     "m"
+state    real   EXCH_H         ikj     misc        1         -      r         "EXCH_H"               "EXCHANGE COEFFICIENTS FOR HEAT"               "m2 s-1"
+state    real   EXCH_M         ikj     misc        1         -      r         "EXCH_M"               "EXCHANGE COEFFICIENTS FOR MOMENTUM"           "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  DEW              ij      misc        1         -      r        "DEW"                   "DEW 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              ijk     misc        1         -     -      
+state   real   dvdt              ijk     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   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"  "m"
+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"         ""         ""    
+
+
+state   real   hcoeff       {ndfi}   misc        1         -     -    "HCOEFF"               "initialization weights"
+state   real   hcoeff_tot     -      misc        1         -     -    "HCOEFF_TOT"               "initialization weights"
+
+######                                          
+
+#                                               
+# Variables that are set at run-time to control configuration  (namelist-settable)                                              
+#                                               
+#<Table>  <Type>  <Sym>                   <How set>          <Nentries>   <Default>                                             
+
+
+# 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
+
+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<domain>"          -     "name of input   infile"   ""      ""
+rconfig   character  input_outname     namelist,time_control		1  "wrfinput_d<domain>"          -     "name of input   outfile"  ""      ""
+rconfig   character  bdy_inname        namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary infile"  ""      ""
+rconfig   character  bdy_outname       namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary outfile" ""      ""
+rconfig   character  rst_inname        namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "name of restrt infile"    ""      ""
+rconfig   character  rst_outname       namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "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"
+rconfig   logical cycling                 namelist,time_control         1             .false. -    "true for cycling (using wrfout file as input data)"
+
+# DFI namelist
+rconfig   integer dfi_opt                namelist,dfi_control   1       0     rh   "dfi_opt"                ""      ""
+rconfig   integer dfi_nfilter            namelist,dfi_control   1       7     rh   "dfi_nfilter"                "Digital filter type"      ""
+rconfig   logical dfi_write_filtered_input  namelist,dfi_control  1  .true.   rh   "dfi_write_filtered_input"                "Write a wrfinput_filtered_d0n file?"      ""
+rconfig   logical dfi_write_dfi_history  namelist,dfi_control   1   .false.   rh   "dfi_write_dfi_history"    "Write history files during filtering?"      ""
+rconfig   integer dfi_cutoff_seconds     namelist,dfi_control   1    3600     rh   "dfi_cutoff_seconds"       "Digital filter cutoff time"      ""
+rconfig   integer dfi_time_dim           namelist,dfi_control   1    1000     rh   "dfi_time_dim"             "MAX DIMENSION FOR HCOEFF"
+rconfig   integer dfi_fwdstop_year       namelist,dfi_control   1    2004     rh   "dfi_fwdstop_year"         "4 DIGIT YEAR OF START OF DFI" "YEARS"
+rconfig   integer dfi_fwdstop_month      namelist,dfi_control   1      03     rh   "dfi_fwdstop_month"        "2 DIGIT MONTH OF THE YEAR OF START OF DFI" "MONTHS"
+rconfig   integer dfi_fwdstop_day        namelist,dfi_control   1      13     rh   "dfi_fwdstop_day"          "2 DIGIT DAY OF THE MONTH OF START OF DFI" "DAYS"
+rconfig   integer dfi_fwdstop_hour       namelist,dfi_control   1      12     rh   "dfi_fwdstop_hour"         "2 DIGIT HOUR OF THE DAY OF START OF DFI" "HOURS"
+rconfig   integer dfi_fwdstop_minute     namelist,dfi_control   1      00     rh   "dfi_fwdstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF START OF DFI" "MINUTES"
+rconfig   integer dfi_fwdstop_second     namelist,dfi_control   1      00     rh   "dfi_fwdstop_second"       "2 DIGIT SECOND OF THE MINUTE OF START OF DFI" "SECONDS"
+rconfig   integer dfi_bckstop_year       namelist,dfi_control   1    2004     rh   "dfi_bckstop_year"         "4 DIGIT YEAR OF END OF DFI" "YEARS"
+rconfig   integer dfi_bckstop_month      namelist,dfi_control   1      03     rh   "dfi_bckstop_month"        "2 DIGIT MONTH OF THE YEAR OF END OF DFI" "MONTHS"
+rconfig   integer dfi_bckstop_day        namelist,dfi_control   1      14     rh   "dfi_bckstop_day"          "2 DIGIT DAY OF THE MONTH OF END OF DFI" "DAYS"
+rconfig   integer dfi_bckstop_hour       namelist,dfi_control   1      12     rh   "dfi_bckstop_hour"         "2 DIGIT HOUR OF THE DAY OF END OF DFI" "HOURS"
+rconfig   integer dfi_bckstop_minute     namelist,dfi_control   1      00     rh   "dfi_bckstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF END OF DFI" "MINUTES"
+rconfig   integer dfi_bckstop_second     namelist,dfi_control   1      00     rh   "dfi_bckstop_second"       "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS"
+
+# 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 time_step_dfi           namelist,domains      1             -       ih   "time_step_dfi"
+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_soil_levels namelist,domains	1             4        irh    "num_metgrid_soil_levels"               "number of input levels or layers in 3D sm, st, sw arrays"      ""
+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   logical grid_allowed            namelist,domains      max_domains    .true.  irh    "allowed"       ""      ""
+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   ts_buf_size     namelist,domains    1                200          -       "ts_buf_size"   "Size of time series buffer"
+rconfig   integer   max_ts_locs     namelist,domains    1                5            -       "max_ts_locs"   "Maximum number of time series locations"
+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   real        mommix              namelist,physics     max_domains  0.7       irh    "MOMENTUM MIXING FOR SAS CONVECTION SCHEME"
+rconfig   logical     disheat             namelist,physics      max_domains  .true.    irh    "nmm input 7"
+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   integer     sf_urban_physics    namelist,physics      max_domains    0       rh       "sf_urban_physics"     ""       ""
+rconfig   real    BLDT                    namelist,physics	max_domains    0       h    "BLDT"          ""      ""
+rconfig   integer     cu_physics          namelist,physics	max_domains    0       rh       "cu_physics"            ""      ""
+rconfig   integer shcu_physics            namelist,physics      max_domains    0       rh   "shcu_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_urban_layers        namelist,physics      1            400       irh    "num_urban_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 fractional_seaice       namelist,physics      1            0        -     "fractional_seiace" "Fractional sea-ice option"
+rconfig   logical tice2tsk_if2cold        namelist,physics      1              .false. -     "tice2tsk_if2cold" "Avoid low ice temps when ice frac and Tsk are inconsistent"
+rconfig   integer sst_update              namelist,physics      1            0        i01rh    "sst_update"  "update sst from wrflowinp file  0=no, 1=yes"   ""
+rconfig   logical usemonalb               namelist,physics      1            .true.    h    "usemonalb"    "use 2d field vs table values  false=table, True=2d"   ""
+rconfig   logical rdmaxalb                namelist,physics      1            .true.    h     "rdmaxalb"    "false set it to table values"   ""
+rconfig   logical rdlai2d                 namelist,physics      1            .false.   h     "rdlai2d"     "false set it to table values"   ""
+rconfig   integer  gwd_opt                namelist,physics    max_domains    0       irh    "gwd_opt"      "activate gravity wave drag: 0=off, 1=ARW, 2=NMM"   ""
+rconfig   integer iz0tlnd                 namelist,physics      1            0         h     "iz0tlnd"    "switch to control land thermal roughness length"   ""
+
+# 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   real    sfenth                  namelist,physics     max_domains    1.0       irh     "sea spray parameter"
+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             - 
+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    iso_temp                namelist,dynamics     1               0.     h    "iso_temp" "Isothermal temperature in stratosphere, 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    c_s                     namelist,dynamics     max_domains    0.25    h    "c_s"         "Smagorinsky coeff"      ""
+rconfig   real    c_k                     namelist,dynamics     max_domains    0.15    h    "c_k"         "TKE coeff"      ""
+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    tke_upper_bound         namelist,dynamics	max_domains    1000.   h    "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 euler_adv               namelist,dynamics     1            .true.  irh  "euler_adv"   "logical flag to turn on/off Eulerian passive advection"   ""
+rconfig   integer idtadt                  namelist,dynamics     1              2      irh  "idtadt"  "fundamental timesteps between calls to Eulerian advection for dynamics"      ""
+rconfig   integer idtadc                  namelist,dynamics     1              2      irh  "idtadc"  "fundamental timesteps between calls to Eulerian advection for chemistry"     ""
+rconfig   real    codamp                  namelist,dynamics     max_domains   6.4     irh  "codamp"  "divergence damping weighting factor (larger = more damping) " ""
+rconfig   real    coac                    namelist,dynamics     max_domains   1.6     irh  "coac"  "horizontal diffusion weighting factor (larger = more diffusion) " ""
+rconfig   real    slophc                  namelist,dynamics     max_domains   6.363961e-3     irh  "slophc"  "Maximum model level slope(dZ/dy) for which hor diffusion is applied" ""
+rconfig   real    wp                      namelist,dynamics     max_domains   0.    irh  "wp"  "Off-centering weight in the updating ofnonhyrostatic eps"
+
+# 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 polar                   namelist,bdy_control  max_domains    .false. rh    "polar"                 ""      ""
+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   integer  FLAG_METGRID           derived                      1          0       -        "FLAG_METGRID"         "Flag in global attributes for metgrid data"
+rconfig   integer  FLAG_SNOW              derived                      1          0       -        "FLAG_SNOW"             "Flag for snow in the global attributes for metgrid data"
+rconfig   integer  FLAG_PSFC              derived                      1          0       -        "FLAG_PSFC"             "Flag for surface pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM000010          derived                      1          0       -        "FLAG_SM000010"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM010040          derived                      1          0       -        "FLAG_SM010040"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM040100          derived                      1          0       -        "FLAG_SM040100"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM100200          derived                      1          0       -        "FLAG_SM100200"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST000010          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST010040          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST040100          derived                      1          0       -        "FLAG_ST010040"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST100200          derived                      1          0       -        "FLAG_ST100200"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_SLP               derived                      1          0       -        "FLAG_SLP"              "Flag for sea level pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SOILHGT           derived                      1          0       -        "FLAG_SOILHGT"          "Flag for soil height in the global attributes for metgrid data"
+rconfig   integer  FLAG_MF_XY             derived                      1          0       -        "FLAG_MF_XY"            "Flag for MF_XYin the global attributes for metgrid data"
+rconfig   real    bdyfrq                  derived                  max_domains    0       -        "bdyfrq"               "lateral boundary input frequency"      "seconds"
+rconfig   character mminlu                derived                  max_domains    " "     -        "mminlu"               "land use dataset"             ""
+rconfig   integer iswater                 derived                  max_domains    0       -        "iswater"              "land use index of water"      "index category"
+rconfig   integer islake                  derived                  max_domains    0       -        "islake"               "land use index of inland lake"      "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 dfi_stage               derived                       1         3       -        "dfi_stage"            "current stage of DFI processing"      "0=DFI setup, 1=DFI backward integration, 2=DFI forward integration, 3=WRF forecast"
+rconfig   integer mp_physics_dfi          derived                  max_domains   -1       -        "mp_physics_dfi"       ""      "-1 = no DFI and so no need to allocate DFI moistnd scalar variables, >0 = running with DFI, so allocate DFI moist and scalar variables appropriate for selected microphysics package"
+
+#
+# Single dummy declaration to define a nodyn dyn option
+state integer nodyn_dummy - dyn_nodyn -  -  -  "" "" ""
+
+# Turbine drag (td) physics
+# Turbine positions and characteristics for real-data cases are specified in a file
+# whose name is given in the windturbines_spec variable.  If the setting is "ideal",
+# the td_ variables specify idealized wind farm geometries and turbine characteristics.
+# If the setting is "none" then wind turbine drag physics is turned off.
+rconfig character windturbines_spec namelist,physics 1 "none" - - "" "none, ideal, or a file name"
+rconfig integer td_turbgridid  namelist,physics 1 -1     - - ""  "which grid id has turbines in it"
+rconfig  real   td_hubheight   namelist,physics 1 100.   - - ""  "hub height (m)"
+rconfig  real   td_diameter    namelist,physics 1 60.    - - ""  "turbine diameter (m)"
+rconfig  real   td_stdthrcoef  namelist,physics 1 .158   - - ""  "standing thrust coefficient"
+rconfig  real   td_cutinspeed  namelist,physics 1 4.     - - ""  "cut-in speed (m/s)"
+rconfig  real   td_cutoutspeed namelist,physics 1 27.    - - ""  "cut-out speed (m/s)"
+rconfig  real   td_power       namelist,physics 1 2.     - - ""  "turbine power (MW)"
+rconfig  real   td_turbpercell namelist,physics 1 1.     - - ""  "number of turbines per cell"
+rconfig integer td_ewfx        namelist,physics 1 0      - - ""  "extent of wind farm in x-cells"
+rconfig integer td_ewfy        namelist,physics 1 0      - - ""  "extent of wind farm in y-cells"
+rconfig integer td_pwfx        namelist,physics 1 1      - - ""  "southwest corner of wind farm in x-cells"
+rconfig integer td_pwfy        namelist,physics 1 1      - - ""  "southwest corner of wind farm in y-cells"
+
+#key      package       associated                package          associated 4d scalars
+#         name          namelist choice           state vars
+
+#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   gsfcgcescheme mp_physics==7                -             moist:qv,qc,qr,qi,qs,qg
+package   thompson      mp_physics==8                -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr
+package   milbrandt2mom mp_physics==9                -             moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh
+package   morr_two_moment  mp_physics==10            -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng
+package   sbu_ylinscheme    mp_physics==13           -             moist:qv,qc,qr,qi,qs
+package   wdm5scheme    mp_physics==14               -             moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr
+package   wdm6scheme    mp_physics==16               -             moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr
+package   etamp_hwrf    mp_physics==85               -             moist:qv,qc,qr,qi,qs
+
+package   nodfimoist        mp_physics_dfi==-1       -             -
+package   passiveqv_dfi     mp_physics_dfi==0        -             dfi_moist:dfi_qv
+package   kesslerscheme_dfi mp_physics_dfi==1        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   linscheme_dfi     mp_physics_dfi==2        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   wsm3scheme_dfi    mp_physics_dfi==3        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   wsm5scheme_dfi    mp_physics_dfi==4        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs
+package   etampnew_dfi      mp_physics_dfi==5        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs
+package   wsm6scheme_dfi    mp_physics_dfi==6        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   gsfcgcescheme_dfi mp_physics_dfi==7        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   thompson_dfi      mp_physics_dfi==8        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr
+package   milbrandt2mom_dfi mp_physics_dfi==9        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh
+package   morr_two_moment_dfi  mp_physics_dfi==10    -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng
+#package   milbrandt3mom_dfi mp_physics_dfi==12       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_q_qzr,dfi_qzi,dfi_qzs,dfi_qzg,dfi_qzh
+package   sbu_ylinscheme_dfi    mp_physics==13           -         dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs
+package   wdm5scheme_dfi    mp_physics_dfi==14       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+package   wdm6scheme_dfi    mp_physics_dfi==16       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+
+# package   noprogn       progn==0                     -             -
+# package   progndrop     progn==1                     -             scalar:qndrop;dfi_scalar:dfi_qndrop
+
+
+
+package   rrtmscheme    ra_lw_physics==1             -             -
+package   camlwscheme   ra_lw_physics==3             -             -
+package   rrtmg_lwscheme  ra_lw_physics==4           -             -
+package   goddardlwscheme  ra_lw_physics==5          -             -
+package   gfdllwscheme  ra_lw_physics==99            -             -
+package   hwrflwscheme  ra_lw_physics==98
+package   heldsuarez    ra_lw_physics==31            -             -
+
+package   swradscheme   ra_sw_physics==1             -             -
+package   gsfcswscheme  ra_sw_physics==2             -             -
+package   camswscheme   ra_sw_physics==3             -             -
+package   rrtmg_swscheme  ra_sw_physics==4           -             -
+package   goddardswscheme  ra_sw_physics==5          -             -
+package   gfdlswscheme  ra_sw_physics==99            -             -
+package   hwrfswscheme  ra_sw_physics==98
+
+package   sfclayscheme   sf_sfclay_physics==1        -             -
+package   myjsfcscheme   sf_sfclay_physics==2        -             -
+package   gfssfcscheme   sf_sfclay_physics==3        -             -
+package   gfdlsfcscheme  sf_sfclay_physics==88       -             -
+package   qnsesfcscheme  sf_sfclay_physics==4        -             -
+package   pxsfcscheme    sf_sfclay_physics==7        -             -
+package   temfsfcscheme  sf_sfclay_physics==10       -             -
+package   idealscmsfcscheme  sf_sfclay_physics==89   -             -
+package   slabscheme     sf_surface_physics==1       -             -
+package   lsmscheme      sf_surface_physics==2       -             -
+package   ruclsmscheme   sf_surface_physics==3       -             -
+package   gfdlslab       sf_surface_physics==88      -             -
+package   pxlsmscheme    sf_surface_physics==7       -             -
+package   ysuscheme      bl_pbl_physics==1           -             -
+package   myjpblscheme   bl_pbl_physics==2           -             -
+package   gfsscheme      bl_pbl_physics==3           -             -
+package   qnsepblscheme  bl_pbl_physics==4           -             -
+package   acmpblscheme   bl_pbl_physics==7           -             -
+package   boulacscheme   bl_pbl_physics==8           -             - 
+package   camuwpblscheme bl_pbl_physics==9           -             -
+package   mrfscheme      bl_pbl_physics==99          -             -
+package   temfpblscheme  bl_pbl_physics==10          -             -
+
+package   kfetascheme    cu_physics==1               -             -
+package   bmjscheme      cu_physics==2               -             -
+package   gdscheme       cu_physics==3               -             -
+package   sasscheme      cu_physics==4               -             -
+package   g3scheme       cu_physics==5               -             -
+package   camzmscheme    cu_physics==7               -             -
+package   tiedtkescheme  cu_physics==6               -             -
+package   nsasscheme     cu_physics==14              -             -
+package   kfscheme       cu_physics==99              -             -
+
+package   g3shcuscheme   shcu_physics==1             -             -
+package   camuwshcuscheme shcu_physics==2            -             -
+
+package   dfi_setup      dfi_stage==0                -             -
+package   dfi_bck        dfi_stage==1                -             -
+package   dfi_fwd        dfi_stage==2                -             -
+package   dfi_fst        dfi_stage==3                -             -
+package   dfi_startfwd   dfi_stage==4                -             -
+package   dfi_startbck   dfi_stage==5                -             -
+package   dfi_nodfi     dfi_opt==0                  -             -
+package   dfi_dfl       dfi_opt==1                  -            \
+ state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC
+package   dfi_ddfi      dfi_opt==2                  -            \
+ state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC
+package   dfi_tdfi      dfi_opt==3                  -            \
+ state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC
+
+
+# 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:HBM2
+halo HALO_NMM_INIT_2	dyn_nmm 120:HBM3,VBM2,VBM3
+halo HALO_NMM_INIT_3	dyn_nmm 120:SM,SICE
+halo HALO_NMM_INIT_4	dyn_nmm 120: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
+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
+
+halo      HALO_NMM_TURBL_A  dyn_nmm 8:uz0h,vz0h,hbm2
+halo      HALO_NMM_TURBL_B  dyn_nmm 8:dudt,dvdt
+
+halo      HALO_NMM_SAS_A  dyn_nmm 24:uz0h,vz0h,hbm2
+halo      HALO_NMM_SAS_B  dyn_nmm 24:ducudt,dvcudt
+halo      HALO_TRACERS dyn_nmm 48:szj,s1z,spz,tcs
+
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.NMM_CHEM
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.NMM_CHEM	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.NMM_CHEM	(revision 17)
@@ -0,0 +1,1380 @@
+# 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=<variable name>".  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.
+#
+
+include registry.dimspec
+
+################################################################################
+################################################################################
+################################################################################
+
+# 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   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     -     i014r    "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...
+
+# The following arrays were added to avoid using _b and _bt arrays for nesting.
+# This is gopal' doing:
+
+state  integer    nrnd1    z    dyn_nmm     1      -      r    "NRND1"
+
+#for HWRF: zhang's doing: added a 'r' at end to store these variables in restart file
+state  real    pdnest_b     ij      dyn_nmm     1      -      r
+state  real    pdnest_bt    ij      dyn_nmm     1      -      r
+state  real    tnest_b      ijk     dyn_nmm     1      -      r
+state  real    tnest_bt     ijk     dyn_nmm     1      -      r
+state  real    qnest_b      ijk     dyn_nmm     1      -      r
+state  real    qnest_bt     ijk     dyn_nmm     1      -      r
+state  real    unest_b      ijk     dyn_nmm     1      -      r
+state  real    unest_bt     ijk     dyn_nmm     1      -      r
+state  real    vnest_b      ijk     dyn_nmm     1      -      r
+state  real    vnest_bt     ijk     dyn_nmm     1      -      r
+state  real    q2nest_b     ijk     dyn_nmm     1      -      r
+state  real    q2nest_bt    ijk     dyn_nmm     1      -      r
+state  real    cwmnest_b    ijk     dyn_nmm     1      -      r
+state  real    cwmnest_bt   ijk     dyn_nmm     1      -      r
+
+#
+# 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" 
+#for HWRF: zhang's doing added to calculate radiation constant for moving nest for restart
+state integer julyr_rst      -     dyn_nmm     1      -    r  "JULYR_RST" "JULYR for restart moving nest "
+state integer julday_rst     -     dyn_nmm     1      -    r  "JULDAY_RST" "JULDAY for restart moving nest "
+state real    gmt_rst        -     dyn_nmm     1      -    r  "GMT_RST" "GMT for restart moving nest "
+state integer NTIME0         -     dyn_nmm     1      -    r  "NTIME0" "COUNT FOR PREVIOUS MOVING NEST"
+
+#for HWRF: 
+# flag for nest movement
+state  logical moved       -     misc       1      -     r
+
+state   real   ducudt       ijk     misc        1         -    rh  "UMMIX" "U TENDENCY  MOMENTUM MIXING IN SAS"
+state   real   dvcudt       ijk     misc        1         -    rh  "VMMIX" "V TENDENCY  MOMENTUM MIXING IN SAS"
+# For random number in SAS convection in HWRF
+
+state real store_rand        ij     dyn_nmm     1      -    rh  "RANDOM" "RANDOM NUMBER FOR SAS"
+
+# Location of the SOUTH-WEST nested pointed in terms of parent grid
+
+state integer  IIH      ij     dyn_nmm     1      -      r
+state integer  JJH      ij     dyn_nmm     1      -      r
+state integer  IIV      ij     dyn_nmm     1      -      r
+state integer  JJV      ij     dyn_nmm     1      -      r
+
+# Bi-linear weights
+
+state  real   HBWGT1       ij     dyn_nmm     1      -      r
+state  real   HBWGT2       ij     dyn_nmm     1      -      r
+state  real   HBWGT3       ij     dyn_nmm     1      -      r
+state  real   HBWGT4       ij     dyn_nmm     1      -      r
+state  real   VBWGT1       ij     dyn_nmm     1      -      r
+state  real   VBWGT2       ij     dyn_nmm     1      -      r
+state  real   VBWGT3       ij     dyn_nmm     1      -      r
+state  real   VBWGT4       ij     dyn_nmm     1      -      r
+#end of HWRF: 
+
+#
+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      -      irh
+state  real   VLAT        ij     dyn_nmm     1      -      irh
+
+#
+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"
+#for HWRF: 
+rconfig   logical analysis               namelist,time_control    max_domains        .false.      irh   "days"     "analysis control for the nested domain"
+
+state  real   PSTD      k      dyn_nmm     1      Z      r
+state  integer KZMAX    -      dyn_nmm     -      -      r
+state  real   Z3D       ijk    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       ijk    dyn_nmm     1      -      rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "T3D" "TEMPERATURE ARRAY ON STANDARD PRESSURE LEVELS"
+state  real   Q3D       ijk    dyn_nmm     1      -      rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "Q3D" "SP HUMIDITY ARRAY ON STANDARD PRESSURE LEVELS"
+#end of HWRF: 
+
+state  real HRES_FIS    ij     dyn_nmm     1      -      r  "HRES_FIS" "HIGH RESOLUTION TERRAIN DATA FOR NESTED DOMAIN"
+
+#
+# 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      -      irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)     "SICE"    "Sea ice mask; =1 for sea ice, =0 for no sea ice"         ""
+#
+# 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: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   t         ijkb    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         ijkb    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         ijkb    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:unest_b,unest_bt,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)   "U"       "U component of wind"                           "m s-1"
+state  real   v         ijkb    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:vnest_b,vnest_bt,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)   "V"       "V component of wind"                           "m s-1"
+state  real   told      ijk    dyn_nmm     1      -      r       "TOLD"    "T from previous timestep"                      "K"
+state  real   uold      ijk    dyn_nmm     1      -      r       "UOLD"    "U from previous timestep"                      "m s-1"
+state  real   vold      ijk    dyn_nmm     1      -      r       "VOLD"    "V from previous timestep"                      "m s-1"
+#
+# NMM DFI
+#
+state   real   hcoeff         {ndfi} misc        1         -     -    "HCOEFF"               "initialization weights"
+state   real   hcoeff_tot       -    misc        1         -     -    "HCOEFF_TOT"               "initialization weights"
+
+state  real   dfi_pd        ij     misc    1      -      r   "DFI_PD"      "Mass at I,J in the sigma domain"               "Pa"
+state  real   dfi_pint      ijk    misc    1      Z      r   "DFI_PINT"      "Model layer interface pressure"   "Pa"
+state  real   dfi_dwdt      ijk    misc    1      -     r    "DFI_DWDT"      "dwdt and 1+(dwdt)/g"              "m s-2"
+state  real   dfi_t         ijk    misc    1      -      r   "DFI_T"       "Sensible temperature"                          "K"
+state  real   dfi_q         ijk    misc    1      -      r   "DFI_Q"       "Specific humidity"                             "kg kg-1"
+state  real   dfi_u         ijk    misc    1      -      r   "DFI_U"       "U component of wind"                           "m s-1"
+state  real   dfi_v         ijk    misc    1      -      r   "DFI_V"       "V component of wind"                           "m s-1"
+state  real   dfi_q2        ijk    misc    1      -      r   "DFI_Q2"      "2 * Turbulence kinetic energy"                 "m2 s-2"
+state  real   dfi_cwm       ijk    misc    1      -      r   "DFI_CWM"     "Total condensate"                              "kg kg-1"
+state  real   dfi_rrw       ijk    misc    1      -      r   "DFI_RRW"     "Tracer"                                        "kg kg-1"
+### remaining simply set aside, and restored to original values after filtering.
+### If a two-hour window, do the 00h fields get placed when restarting at f01?
+###
+state    real  dfi_STC        ilj   misc          1         Z     r    "DFI_STC"         "SOIL TEMPERATURE"   "K"
+state    real  dfi_SMC        ilj   misc          1         Z     r    "DFI_SMC"       "SOIL MOISTURE"     "m3 m-3"
+state    real  dfi_SH2O       ilj   misc          1         Z     r    "DFI_SH2O"      "UNFROZEN SOIL MOISTURE"     "m3 m-3"
+
+state    real  dfi_SNOW        ij    misc        1         -     r    "dfi_SNOW"         "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real  dfi_SNOWH       ij    misc        1         -     r    "dfi_SNOWH"        "PHYSICAL SNOW DEPTH"      "m"
+state    real  dfi_CANWAT      ij    misc        1         -     r    "dfi_CANWAT"       "CANOPY WATER"             "kg m-2"
+state    real  dfi_NMM_TSK      ij      misc        1       -     r   "dfi_NMM_TSK"               "saved SURFACE SKIN TEMPERATURE"
+state    real  dfi_SNOWC        ij      misc        1       -      r  "dfi_SNOWC"             "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)"         ""
+#
+# 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      -      i01rh    "DETA1"   "Delta sigma in pressure domain"                ""
+state  real   aeta1     k      dyn_nmm     1      -      i01rh    "AETA1"   "Midlayer sigma value in pressure domain"       ""
+state  real   eta1      k      dyn_nmm     1      Z      i01rh   "ETA1"    "Interface sigma value in pressure domain"      ""
+state  real   deta2     k      dyn_nmm     1      -      i01rh    "DETA2"   "Delta sigma in sigma domain"                   ""
+state  real   aeta2     k      dyn_nmm     1      -      i01rh    "AETA2"   "Midlayer sigma value in sigma domain"          ""
+state  real   eta2      k      dyn_nmm     1      Z      i01rh   "ETA2"    "Interface sigma value in sigma domain"         ""
+state  real   em        q      dyn_nmm     1      -      ir
+state  real   emt       q      dyn_nmm     1      -      ir
+#for HWRF: add to restart
+state  real   adt       ij     dyn_nmm     1      -      r       "ADT"     "Change of T due to advection"                  "K"
+state  real   adu       ij     dyn_nmm     1      -      r       "ADU"     "Change of U due to advection"                  "m s-1"
+state  real   adv       ij     dyn_nmm     1      -      r       "ADV"     "Change of V due to advection"                  "m s-1"
+#end HWRF:
+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"    ""
+#end HWRF:
+state  real   dlmd      -      dyn_nmm     -      -      irh      "DLMD"    "East-west angular distance H-to-V points"      "degrees"
+state  real   dphd      -      dyn_nmm     -      -      irh      "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
+#
+#for HWRF: add to restart
+state  real   pdsl      ij     dyn_nmm     1      -      r       "PDSL"    "Sigma-domain pressure at sigma=1"           "Pa"
+state  real   pdslo     ij     dyn_nmm     1      -      r       "PDSLO"   "PDSL from previous timestep"                "Pa"
+#end HWRF:
+state  real   psdt      ij     dyn_nmm     1      -      r       "PSDT"    "Surface pressure tendency"                  "Pa s-1"
+state  real   div       ijk    dyn_nmm     1      -      r       "DIV"     "Divergence"                                 "Pa s-1"
+state  real   def3d     ijk    dyn_nmm     1      -      r       "DEF3D"   "Deformation term from horizontal diffusion"      ""
+#for HWRF: add to restart
+state  real   few       ijk    dyn_nmm     1      -      r       "FEW"     "Integrated east-west mass flux"             "Pa m2 s-1"
+state  real   fne       ijk    dyn_nmm     1      -      r       "FNE"     "Integrated northeast-southwest mass flux"   "Pa m2 s-1"
+state  real   fns       ijk    dyn_nmm     1      -      r       "FNS"     "Integrated north-south mass flux"           "Pa m2 s-1"
+state  real   fse       ijk    dyn_nmm     1      -      r       "FSE"     "Integrated southeast-northwest mass flux"   "Pa m2 s-1"
+#end HWRF:
+state  real   omgalf    ijk    dyn_nmm     1      -      r       "OMGALF"  "Omega-alpha"                                "K"
+#for HWRF: add to restart
+state  real   petdt     ijk    dyn_nmm     1      -      r       "PETDT"   "Vertical mass flux"                         "Pa s-1"
+#end HWRF:
+state  real   rtop      ijk    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   mixht     ij    dyn_nmm   1    -     rh        "MIXHT"                 "MXL HEIGHT"              "m"
+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   taux      ij    dyn_nmm   1    -     irh      "TAUX"     "Instantaneous stress along X direction in KG/M/S^2" 
+state  real   tauy      ij    dyn_nmm   1    -     irh      "TAUY"     "Instantaneous stress along Y direction in KG/M/S^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 eqiv of snow on ground"  "kg m-2"
+state  real   si        ij    dyn_nmm   1    -     irh      "SI"       "Depth of snow on ground"              "mm"
+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    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "TH10"     "10-m potential temperature from MYJ"  "K"
+state  real   q10       ij    dyn_nmm   1    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "Q10"      "10-m specific humidity from MYJ"      "kg kg-1"
+state  real   pshltr    ij    dyn_nmm   1    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "PSHLTR"   "2-m pressure from MYJ"                "Pa"
+state  real   tshltr    ij    dyn_nmm   1    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "TSHLTR"   "2-m potential temperature from MYJ"    "K"
+state  real   qshltr    ij    dyn_nmm   1    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "QSHLTR"   "2-m specific humidity from MYJ"       "kg kg-1"
+state  real   q2        ijkb   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:q2nest_b,q2nest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)   "Q2"       "2 * Turbulence kinetic energy"        "m2 s-2"
+state  real   t_adj     ijk   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     ijk   dyn_nmm   1    -     r        "T_OLD"    "T before last call to precip"         "K"
+state  real   zero_3d   ijk   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    -     rh       "AKHS_OUT"  "Output sfc exch coeff for heat"               "m2 s-1"
+state  real   AKMS_OUT  ij    dyn_nmm   1    -     rh       "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   embck     ij    dyn_nmm   1    -     ir       "EMBCK"     "Background radiative emissivity"                 ""
+state  real   epsr      ij    dyn_nmm   1    -     irh      "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    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "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       ijkb   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:cwmnest_b,cwmnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)  "CWM"       "Total condensate"                     "kg kg-1"
+state  real   rrw       ijkb  dyn_nmm   1    -     rh       "RRW"       "Tracer"                               "kg kg-1"
+state  real   f_ice     ikj   dyn_nmm   1    -     rhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)  "F_ICE"     "Frozen fraction of CWM"               ""
+state  real   f_rain    ikj   dyn_nmm   1    -     rhd=(interp_hnear_ikj_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_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)  "F_RIMEF"   "Rime factor"                          ""
+state  real   cldfra    ijk   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    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "CFRACH"    "High cloud fraction"                  ""
+state  real   cfracl    ij    dyn_nmm   1    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "CFRACL"    "Low cloud fraction"                   ""
+state  real   cfracm    ij    dyn_nmm   1    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "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    -     irh      "DZSOIL"    "Thickness of soil layers"         "m"
+state  real   rtdpth    k     dyn_nmm   1    -     i01r 
+state  real   sldpth    k     dyn_nmm   1    -     i01rh    "SLDPTH"    "Depths of centers 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    -     i014rhd=(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_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)   "SH2O"      "Unfrozen soil moisture volume fraction"  ""
+state  real   smc       ilj   dyn_nmm   1    Z     irhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)   "SMC"       "Soil moisture volume fraction"    ""
+state  real   stc       ilj   dyn_nmm   1    Z     irhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)   "STC"       "Soil temperature"                 "K"
+#
+# module_GWD.F
+#
+state  real   hstdv     ij    dyn_nmm   1    -     i01rh      "HSTDV"     "Standard deviation of height"     "m"
+state  real   hcnvx     ij    dyn_nmm   1    -     i01rh      "HCNVX"     "Normalized 4th moment of orographic convexity"     ""
+state  real   hasyw     ij    dyn_nmm   1    -     i01rh      "HASYW"     "Orographic asymmetry in W-E plane"  ""
+state  real   hasys     ij    dyn_nmm   1    -     i01rh      "HASYS"     "Orographic asymmetry in S-N plane"  ""
+state  real   hasysw    ij    dyn_nmm   1    -     i01rh      "HASYSW"    "Orographic asymmetry in SW-NE plane"  ""
+state  real   hasynw    ij    dyn_nmm   1    -     i01rh      "HASYNW"    "Orographic asymmetry in NW-SE plane"  ""
+state  real   hlenw     ij    dyn_nmm   1    -     i01rh      "HLENW"     "Orographic length scale in W-E plane"  ""
+state  real   hlens     ij    dyn_nmm   1    -     i01rh      "HLENS"     "Orographic length scale in S-N plane"  ""
+state  real   hlensw    ij    dyn_nmm   1    -     i01rh      "HLENSW"    "Orographic length scale in SW-NE plane"  ""
+state  real   hlennw    ij    dyn_nmm   1    -     i01rh      "HLENNW"    "Orographic length scale in NW-SE plane"  ""
+state  real   hangl     ij    dyn_nmm   1    -     i01rh      "HANGL"     "Angle of the mountain range w/r/t east"  "deg"
+state  real   hanis     ij    dyn_nmm   1    -     i01rh      "HANIS"     "Anisotropy/aspect ratio of orography"   ""
+state  real   hslop     ij    dyn_nmm   1    -     i01rh      "HSLOP"     "Slope of orography"             ""
+state  real   hzmax     ij    dyn_nmm   1    -     i01rh      "HZMAX"     "Maximum height above mean orography"    "m"
+state  real   crot      ij    dyn_nmm   1    -      -       "CROT"      "Cosine of angle between model and earth coordinates"    ""
+state  real   srot      ij    dyn_nmm   1    -      -       "SROT"      "Sine of angle between model and earth coordinates"    ""
+state  real   UGWDsfc   ij    dyn_nmm   1    -      h       "UGWDsfc"   "Surface zonal wind stress due to gravity wave drag"    "N m-2"
+state  real   VGWDsfc   ij    dyn_nmm   1    -      h       "VGWDsfc"   "Surface meridional wind stress due to gravity wave drag"    "N m-2"
+#
+# 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      ijk   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     ijk   dyn_nmm   1    -     r
+state  real   pint      ijk   dyn_nmm   1    Z     irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "PINT"      "Model layer interface pressure"   "Pa"
+state  real   w         ijk   dyn_nmm   1    Z     rh       "W"         "Vertical velocity"                "m s-1"
+state  real   z         ijk   dyn_nmm   1    Z     -        "Z"         "Distance from ground"             "m"
+#
+# module_ACCUM.F
+#
+state  real   acfrcv    ij    dyn_nmm     1    -    rh    "ACFRCV"    "Accum convective cloud fraction"   ""
+state  real   acfrst    ij    dyn_nmm     1    -    rh    "ACFRST"    "Accum stratiform cloud fraction"   ""
+state  real   ssroff    ij    dyn_nmm     1    -    rh    "SSROFF"    "Surface runoff"                    "mm"                  
+state  real   bgroff    ij    dyn_nmm     1    -    rh    "BGROFF"    "Subsurface runoff"                 "mm"
+state  real   rlwin     ij    dyn_nmm     1    -    rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)    "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    -    rh    "ALWIN"     "Accum LW down at surface"          "W m-2"
+state  real   alwout    ij    dyn_nmm     1    -    rh    "ALWOUT"    "Accum RADOT (see above)"           "W m-2"
+state  real   alwtoa    ij    dyn_nmm     1    -    rh    "ALWTOA"    "Accum RLWTOA"                      "W m-2"
+state  real   rswin     ij    dyn_nmm     1    -    rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)    "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"
+#for HWRF: add to restart
+state  real   rswtoa    ij    dyn_nmm     1    -    r     "RSWTOA"    "Outgoing SW flux at top of atmos"  "W m-2"
+#end HWRF
+state  real   aswin     ij    dyn_nmm     1    -    rh    "ASWIN"     "Accum SW down at surface"          "W m-2"
+state  real   aswout    ij    dyn_nmm     1    -    rh    "ASWOUT"    "Accum RSWOUT"                      "W m-2"
+state  real   aswtoa    ij    dyn_nmm     1    -    rh    "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    -    rh    "TLMIN"      ""
+state  real   tlmax     ij    dyn_nmm     1    -    rh    "TLMAX"      ""
+state  real   t02_min   ij    dyn_nmm     1    -    rh    "T02_MIN"  "Hourly Min Shelter Temperature"    "K"
+state  real   t02_max   ij    dyn_nmm     1    -    rh    "T02_MAX"  "Hourly Max Shelter Temperature"    "K"
+state  real   rh02_min  ij    dyn_nmm     1    -    rh    "RH02_MIN" "Hourly Min Relative Humidity"    ""
+state  real   rh02_max  ij    dyn_nmm     1    -    rh    "RH02_MAX" "Hourly Max Relative Humidity"    ""
+state  real   rlwtt     ijk   dyn_nmm     1    -    rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)  "RLWTT"     "Longwave temperature tendency"     "K s-1"
+state  real   rswtt     ijk   dyn_nmm     1    -    rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)  "RSWTT"     "Shortwave temperature tendency"    "K s-1"
+#for HWRF: add to restart
+state  real   tcucn     ijk   dyn_nmm     1    -    r     "TCUCN"     "Accum convec temperature tendency" "K s-1"
+state  real   train     ijk   dyn_nmm     1    -    r     "TRAIN"     "Accum stratiform temp tendency"    "K s-1"
+#end HWRF
+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 ncnvc0     -     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    -    -
+state integer iradg     r    dyn_nmm     1    -    -
+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                                         
+#<Table> <Type> <Sym>         <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>   
+#
+# 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      "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
+#-------------------------------------------------------------------------------------------------------------------------------
+
+# Time series variables
+state    real   ts_hour         ?!       misc      -         -      -        "TS_HOUR"        "Model integration time, hours"
+state    real   ts_u            ?!       misc      -         -      -        "TS_U"           "Surface wind U-component, earth-relative"
+state    real   ts_v            ?!       misc      -         -      -        "TS_V"           "Surface wind V-component, earth-relative"
+state    real   ts_q            ?!       misc      -         -      -        "TS_Q"           "Surface mixing ratio"
+state    real   ts_t            ?!       misc      -         -      -        "TS_T"           "Surface temperature"
+state    real   ts_psfc         ?!       misc      -         -      -        "TS_PSFC"        "Surface pressure"
+state    real   ts_tsk          ?!       misc      -         -      -        "TS_TSK"         "Skin temperature"
+state    real   ts_tslb         ?!       misc      -         -      -        "TS_TSLB"        "Soil temperature"
+state    real   ts_clw          ?!       misc      -         -      -        "TS_CLW"         "Column integrated cloud water"
+
+#-----------------------------------------------------------------------------------------------------------------------------------------------------------------
+
+
+# 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    -              ijkft   moist       1         -     -    -                                       
+state   real    qv             ijkft   moist       1         -     rh       "QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    qc             ijkft   moist       1         -     rh       "QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    qr             ijkft   moist       1         -     rh       "QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    qi             ijkft   moist       1         -     rh       "QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    qs             ijkft   moist       1         -     rh       "QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    qg             ijkft   moist       1         -     rh       "QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+
+state   real    -              ijkft   dfi_moist       1         -     -    -
+state   real    dfi_qv         ijkft   dfi_moist       1         -     r      "QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    dfi_qc         ijkft   dfi_moist       1         -     r      "QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    dfi_qr         ijkft   dfi_moist       1         -     r      "QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    dfi_qi         ijkft   dfi_moist       1         -     r      "QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    dfi_qs         ijkft   dfi_moist       1         -     r      "QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    dfi_qg         ijkft   dfi_moist       1         -     r      "QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+
+#                                               
+# Other Scalars
+state   real    -              ijkftb  scalar      1         -     -    -
+state   real    qni            ijkftb  scalar      1         -     i01rhusdf=(bdy_interp:dt)       "QNI"              "Ice Number concentration" "# kg(-1)"
+state   real    qns            ijkftb  scalar      1         -     i01rhusdf=(bdy_interp:dt)       "QNS"              "Snow Number concentration" "# kg(-1)"
+state   real    qnr            ijkftb  scalar      1         -     i01rhusdf=(bdy_interp:dt)       "QNR"              "Rain Number concentration" "# kg(-1)"
+state   real    qng            ijkftb  scalar      1         -     i01rhusdf=(bdy_interp:dt)       "QNG"              "Graupel Number concentration" "# kg(-1)"
+state   real    qndrop         ijkftb  scalar      1         -     i01rhusdf=(bdy_interp:dt)       "QNDROP"           "Droplet number mixing ratio"        "# kg-1"
+state   real    qnn            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNCCN"            "CCN Number concentration" "# kg(-1)"
+state   real    qnc            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNCLOUD"          "cloud water Number concentration" "# kg(-1)"
+
+state   real    -              ijkftb  dfi_scalar      1         -     -   -
+state   real    dfi_qndrop     ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNDROP"    "Droplet number mixing ratio"        "# kg-1"
+state   real    dfi_qni        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNICE"     "Ice Number concentration" "# kg-1"
+state   real    dfi_qt         ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_CWM"       "Total condensate mixing ratio"      "kg kg-1"
+state   real    dfi_qns        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNSNOW"    "Snow Number concentration"   "# kg(-1)"
+state   real    dfi_qnr        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNRAIN"    "Rain Number concentration"   "# kg(-1)"
+state   real    dfi_qng        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)"
+state   real    dfi_qnn        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCC"      "CNN Number concentration"   "# kg(-1)"
+state   real    dfi_qnc        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCLOUD"   "Cloud Number concentration" "# 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   SMCREL           ilj     -          1         Z     r        "SMCREL"               "RELATIVE 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         -     ir        "T2"                  "TEMP at 2 M" ""
+state    real   U10              ij     misc        1         -     irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "U10"                  "U at 10 M"         " "
+state    real   V10              ij     misc        1         -     irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "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   LAI              ij     misc        1         -     i0124rh   "LAI"                  "Leaf area index"          "area/area"
+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         -     i014rhd=(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         -     i0124r   "ALBBCK"          "BACKGROUND ALBEDO"        "NA"
+state    real   SFCEXC           ij     misc        1         -     irh     "SFCEXC "              "SURFACE EXCHANGE COEFFICIENT"         ""
+state    real   SNOTIME          ij     misc        1         -     r        "SNOTIME"              "SNOTIME"                             ""
+state    real   ACSNOW           ij     misc        1         -     irh       "ACSNOW"               "ACCUMULATED SNOW"      "kg m-2"
+state    real   ACSNOM           ij     misc        1         -     irh       "ACSNOM"               "ACCUMULATED MELTED SNOW"         "kg m-2"
+state    real   RMOL             ij     misc        1         -     irh      "RMOL"               ""         ""
+state    real   SNOW             ij     misc        1         -     i01rh       "SNOW"                 "SNOW WATER EQUIVALENT"         "kg m-2"
+state    real   CANWAT           ij     misc        1         -     i01rh       "CANWAT"               "CANOPY WATER" ""
+state    real   SST              ij     misc        1         -     i014rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4       "SST"                  "SEA SURFACE TEM
+PERATURE" "K"
+state    real   WEASD            ij     misc        1         -     i01rh       "WEASD"                "WATER EQUIVALENT OF ACCUMULATED SNOW" "kg m-2"
+state    real  ZNT              ij      misc        1         -     irh        "ZNT"                   "TIME-VARYING ROUGHNESS LENGTH"
+state    real  MOL              ij      misc        1         -     ir        "MOL"                   "T* IN SIMILARITY THEORY"                      "K"
+state    real  NOAHRES          ij      misc        1         -     rh        "NOAHRES"               "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}"
+
+state    real   tke_pbl         ijk     misc        1         -     r         "TKE_PBL"               "TKE FROM PBL SCHEME"     "m2 s-2"
+state    real   el_pbl          ikj     misc        1         -     -         "EL_PBL"                "MIXING LENGTH FROM PBL SCHEME"     "m"
+state    real   EXCH_H         ikj     misc        1         -     r         "EXCH_H"               "EXCHANGE COEFFICIENTS FOR HEAT"               "m2 s-1"
+state    real   EXCH_M         ikj     misc        1         -     r         "EXCH_M"               "EXCHANGE COEFFICIENTS FOR MOMENTUM"           "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  DEW              ij      misc        1         -      r        "DEW"                   "DEW 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              ijk     misc        1         -     -      
+state   real   dvdt              ijk     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   CHKLOWQ          ij     misc        1         -     -         "CHKLOWQ"               "SURFACE SATURATION FLAG"        ""
+state    real    HTOP            ij     misc        1         -     irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "HTOP"                 "TOP OF CONVECTION LEVEL"         ""
+state    real    HBOT            ij     misc        1         -     irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "HBOT"                 "BOT OF CONVECTION LEVEL"         ""
+state    real    HTOPR           ij     misc        1         -     ird=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "HTOPR"                 "TOP OF CONVECTION LEVEL FOR RADIATION"         ""
+state    real    HBOTR           ij     misc        1         -     ird=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "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         -     rhd=(interp_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    ccn1            ijk    misc        1         -      h        "ccn1"                 "CCN concentration at S=0.02%"  "#/cm3"
+state    real    ccn2            ijk    misc        1         -      h        "ccn2"                 "CCN concentration at S=0.05%"  "#/cm3"
+state    real    ccn3            ijk    misc        1         -      h        "ccn3"                 "CCN concentration at S=0.1%"   "#/cm3"
+state    real    ccn4            ijk    misc        1         -      h        "ccn4"                 "CCN concentration at S=0.2%"   "#/cm3"
+state    real    ccn5            ijk    misc        1         -      h        "ccn5"                 "CCN concentration at S=0.5%"   "#/cm3"
+state    real    ccn6            ijk    misc        1         -      h        "ccn6"                 "CCN concentration at S=1.0%"   "#/cm3"
+state    real    qndropsource    ijk    misc        1         -      h        "qndropsource"         "Droplet number source"   "#/kg/s"
+# cloud water fractional removal rate needed for wet scavenging
+state    real    qlsink          ijk    misc        1         -      rduh      "qlsink"              "CLOUD WATER SINK"               "/S"
+state    real    precr           ijk    misc        1         -      rduh      "precr"               "RAIN PRECIPITATION RATE"        "KG/M2/S"
+state    real    preci           ijk    misc        1         -      rduh      "preci"               "ICE PRECIPITATION RATE"         "KG/M2/S"
+state    real    precs           ijk    misc        1         -      rduh      "precs"               "SNOW PRECIPITATION RATE"        "KG/M2/S"
+state    real    precg           ijk    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        ijk      misc        1         -      rh      "GD_CLOUD"              "CLOUD WATER/ICE MIXING RAIO IN GD CLOUD"         "kg kg-1"
+state    real  GD_CLOUD2        ijk      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_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)      "SNOWH"                 "PHYSICAL SNOW DEPTH"  "m"
+state    real   RHOSN            ij     misc        1         -     i01rd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)    "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.  
+#for HWRF: add to restart
+state   integer itimestep      -        -          -         -     rh         "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                                               
+        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"         ""         ""    
+
+# 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
+
+######                                          
+#                                               
+# Variables that are set at run-time to control configuration  (namelist-settable)                                              
+#                                               
+#<Table>  <Type>  <Sym>                   <How set>          <Nentries>   <Default>                                             
+
+
+# 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
+
+#for HWRF: added a 'r' for restart
+rconfig   integer JULYR                   namelist,time_control         max_domains    0       hr    "JULYR"                 ""      ""
+rconfig   integer JULDAY                  namelist,time_control         max_domains    1       hr    "JULDAY"                ""      ""
+rconfig   real    GMT                     namelist,time_control         max_domains    0.      hr    "GMT"           ""      ""
+#for HWRF: end 
+rconfig   character  input_inname      namelist,time_control		1  "wrfinput_d<domain>"          -     "name of input   infile"   ""      ""
+rconfig   character  input_outname     namelist,time_control		1  "wrfinput_d<domain>"          -     "name of input   outfile"  ""      ""
+rconfig   character  bdy_inname        namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary infile"  ""      ""
+rconfig   character  bdy_outname       namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary outfile" ""      ""
+rconfig   character  rst_inname        namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "name of restrt infile"    ""      ""
+rconfig   character  rst_outname       namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "name of restrt outfile"   ""      ""
+#for HWRF:
+rconfig   character  anl_outname         namelist,time_control    max_domains  "wrfanl_d<domain>_<date>"     -     "name of analysis 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"
+rconfig   logical cycling                 namelist,time_control         1             .false. -    "true for cycling (using wrfout file as input data)"
+
+# DFI namelist
+rconfig   integer dfi_opt                namelist,dfi_control   1       0     rh   "dfi_opt"                ""      ""
+rconfig   integer dfi_nfilter            namelist,dfi_control   1       7     rh   "dfi_nfilter"                "Digital filter type"      ""
+rconfig   logical dfi_write_filtered_input  namelist,dfi_control  1  .true.   rh   "dfi_write_filtered_input"                "Write a wrfinput_filtered_d0n file?"      ""
+rconfig   logical dfi_write_dfi_history  namelist,dfi_control   1   .false.   rh   "dfi_write_dfi_history"    "Write history files during filtering?"      ""
+rconfig   integer dfi_cutoff_seconds     namelist,dfi_control   1    3600     rh   "dfi_cutoff_seconds"       "Digital filter cutoff time"      ""
+rconfig   integer dfi_time_dim           namelist,dfi_control   1    1000     rh   "dfi_time_dim"             "MAX DIMENSION FOR HCOEFF"
+rconfig   integer dfi_fwdstop_year       namelist,dfi_control   1    2004     rh   "dfi_fwdstop_year"         "4 DIGIT YEAR OF START OF DFI" "YEARS"
+rconfig   integer dfi_fwdstop_month      namelist,dfi_control   1      03     rh   "dfi_fwdstop_month"        "2 DIGIT MONTH OF THE YEAR OF START OF DFI" "MONTHS"
+rconfig   integer dfi_fwdstop_day        namelist,dfi_control   1      13     rh   "dfi_fwdstop_day"          "2 DIGIT DAY OF THE MONTH OF START OF DFI" "DAYS"
+rconfig   integer dfi_fwdstop_hour       namelist,dfi_control   1      12     rh   "dfi_fwdstop_hour"         "2 DIGIT HOUR OF THE DAY OF START OF DFI" "HOURS"
+rconfig   integer dfi_fwdstop_minute     namelist,dfi_control   1      00     rh   "dfi_fwdstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF START OF DFI" "MINUTES"
+rconfig   integer dfi_fwdstop_second     namelist,dfi_control   1      00     rh   "dfi_fwdstop_second"       "2 DIGIT SECOND OF THE MINUTE OF START OF DFI" "SECONDS"
+rconfig   integer dfi_bckstop_year       namelist,dfi_control   1    2004     rh   "dfi_bckstop_year"         "4 DIGIT YEAR OF END OF DFI" "YEARS"
+rconfig   integer dfi_bckstop_month      namelist,dfi_control   1      03     rh   "dfi_bckstop_month"        "2 DIGIT MONTH OF THE YEAR OF END OF DFI" "MONTHS"
+rconfig   integer dfi_bckstop_day        namelist,dfi_control   1      14     rh   "dfi_bckstop_day"          "2 DIGIT DAY OF THE MONTH OF END OF DFI" "DAYS"
+rconfig   integer dfi_bckstop_hour       namelist,dfi_control   1      12     rh   "dfi_bckstop_hour"         "2 DIGIT HOUR OF THE DAY OF END OF DFI" "HOURS"
+rconfig   integer dfi_bckstop_minute     namelist,dfi_control   1      00     rh   "dfi_bckstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF END OF DFI" "MINUTES"
+rconfig   integer dfi_bckstop_second     namelist,dfi_control   1      00     rh   "dfi_bckstop_second"       "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS"
+
+
+# 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 time_step_dfi           namelist,domains      1             -       ih   "time_step_dfi"
+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_soil_levels namelist,domains	1             4        irh    "num_metgrid_soil_levels"               "number of input levels or layers in 3D sm, st, sw arrays"      ""
+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   logical grid_allowed            namelist,domains      max_domains    .true.  irh    "allowed"       ""      ""
+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   ts_buf_size     namelist,domains    1                200          -       "ts_buf_size"   "Size of time series buffer"
+rconfig   integer   max_ts_locs     namelist,domains    1                5            -       "max_ts_locs"   "Maximum number of time series locations"
+rconfig   integer   num_moves       namelist,domains    1                0
+rconfig   integer   vortex_interval namelist,domains    max_domains      15  -  "" "" "minutes"
+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     "" "" ""
+# 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"            ""      ""
+#for HWRF:
+rconfig   real        mommix              namelist,physics     max_domains  0.7       irh    "MOMENTUM MIXING FOR SAS CONVECTION SCHEME"
+rconfig   logical     disheat             namelist,physics      max_domains  .true.    irh    "nmm input 7"
+#end HWRF:
+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   integer shcu_physics            namelist,physics      max_domains    0       rh   "shcu_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 num_urban_layers        namelist,physics      1            400       irh    "num_urban_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 fractional_seaice       namelist,physics      1            0        -     "fractional_seiace" "Fractional sea-ice option"
+rconfig   logical tice2tsk_if2cold        namelist,physics      1              .false. -     "tice2tsk_if2cold" "Avoid low ice temps when ice frac and Tsk are inconsistent"
+rconfig   integer sst_update              namelist,physics      1            0        i01rh    "sst_update"  "update sst from wrflowinp file  0=no, 1=yes"   ""
+rconfig   integer sf_urban_physics        namelist,physics      max_domains  0         h    "sf_urban_physics"     "activate urban model  0=no, 1=Noah_UCM, 2=BEP_UCM"   ""
+rconfig   logical usemonalb               namelist,physics      1            .true.    h    "usemonalb"   "use 2d field vs table values  false=table, True=2d"   ""
+rconfig   logical rdmaxalb                namelist,physics      1            .true.    h     "rdmaxalb"    "false set it to table values"   ""
+rconfig   logical rdlai2d                 namelist,physics      1            .false.   h     "rdlai2d"     "false set it to table values"   ""
+rconfig   integer  gwd_opt                namelist,physics    max_domains    0       irh    "gwd_opt"      "activate gravity wave drag: 0=off, 1=ARW, 2=NMM"   ""
+rconfig   integer iz0tlnd                 namelist,physics      1            0         h     "iz0tlnd"    "switch to control land thermal roughness length"   ""
+
+
+# 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   real    sfenth                  namelist,physics     max_domains    1.0       irh     "sea spray parameter"
+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"  ""
+rconfig   real h_diff                     namelist,physics      max_domains  0.1      irh    "nmm input 9"
+rconfig   integer movemin                 namelist,physics      max_domains  10       irh    "nmm input 12"
+
+
+# Dynamics
+# dynamics option (see package definitions, below)
+rconfig   integer dyn_opt                 namelist,dynamics	1             - 
+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    iso_temp                namelist,dynamics     1               0.     h    "iso_temp" "Isothermal temperature in stratosphere, 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    c_s                     namelist,dynamics     max_domains    0.25    h    "c_s"         "Smagorinsky coeff"      ""
+rconfig   real    c_k                     namelist,dynamics     max_domains    0.15    h    "c_k"         "TKE coeff"      ""
+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    tke_upper_bound         namelist,dynamics	max_domains    1000.   h    "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 euler_adv               namelist,dynamics     1            .true.  irh  "euler_adv"        "Logical flag to turn on/off Eulerian pasive advection"   ""
+rconfig   integer idtadt                  namelist,dynamics     1              1      irh  "idtadt"           "Fundamental timesteps between calls to Eulerian advection for dynamics"   ""
+rconfig   integer idtadc                  namelist,dynamics     1              1      irh  "idtadc"           "Fundamental timesteps between calls to Eulerian advection for chemistry"   ""
+rconfig   real    codamp                  namelist,dynamics     max_domains   6.4     irh  "codamp"  "divergence damping weighting factor (larger = more damping) " ""
+rconfig   real    coac                    namelist,dynamics     max_domains   1.6     irh  "coac"  "horizontal diffusion weighting factor (larger = more diffusion) " ""
+rconfig   real    slophc                  namelist,dynamics     max_domains   6.363961e-3     irh  "slophc"  "Maximum model level slope (dZ/dy) for which hor diffusion is applied" ""
+rconfig   real    wp                      namelist,dynamics     max_domains   0.    irh  "wp"  "Off-centering weight in the updating of nonhyrostatic eps"
+
+
+# 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 polar                   namelist,bdy_control  max_domains    .false. rh    "polar"                 ""      ""
+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   integer  FLAG_METGRID           derived                      1          0       -        "FLAG_METGRID"         "Flag in global attributes for metgrid data"
+rconfig   integer  FLAG_SNOW              derived                      1          0       -        "FLAG_SNOW"             "Flag for snow in the global attributes for metgrid data"
+rconfig   integer  FLAG_PSFC              derived                      1          0       -        "FLAG_PSFC"             "Flag for surface pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM000010          derived                      1          0       -        "FLAG_SM000010"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM010040          derived                      1          0       -        "FLAG_SM010040"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM040100          derived                      1          0       -        "FLAG_SM040100"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM100200          derived                      1          0       -        "FLAG_SM100200"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST000010          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST010040          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST040100          derived                      1          0       -        "FLAG_ST010040"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST100200          derived                      1          0       -        "FLAG_ST100200"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_SLP               derived                      1          0       -        "FLAG_SLP"              "Flag for sea level pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SOILHGT           derived                      1          0       -        "FLAG_SOILHGT"          "Flag for soil height in the global attributes for metgrid data"
+rconfig   integer  FLAG_MF_XY             derived                      1          0       -        "FLAG_MF_XY"            "Flag for MF_XYin the global attributes for metgrid data"
+rconfig   real    bdyfrq                  derived                  max_domains    0       -        "bdyfrq"               "lateral boundary input frequency"      "seconds"
+rconfig   character mminlu                derived                  max_domains    " "     -        "mminlu"               "land use dataset"             ""
+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 islake                  derived                  max_domains    0       -        "islake"               "land use index of inland lake"      "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
+
+#### 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,qs
+package   wsm6scheme    mp_physics==6                -             moist:qv,qc,qr,qi,qs,qg
+package   gsfcgcescheme mp_physics==7                -             moist:qv,qc,qr,qi,qs,qg
+package   thompson      mp_physics==8                -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr
+package   milbrandt2mom mp_physics==9                -             moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh
+package   morr_two_moment  mp_physics==10            -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng
+package   sbu_ylinscheme    mp_physics==13           -             moist:qv,qc,qr,qi,qs
+package   wdm5scheme    mp_physics==14               -             moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr
+package   wdm6scheme    mp_physics==16               -             moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr
+package   etamp_hwrf    mp_physics==85               -             moist:qv,qc,qr,qi,qs
+
+package   rrtmscheme    ra_lw_physics==1             -             -
+package   camlwscheme   ra_lw_physics==3             -             -
+package   rrtmg_lwscheme  ra_lw_physics==4           -             -
+package   goddardlwscheme  ra_lw_physics==5          -             -
+package   gfdllwscheme  ra_lw_physics==99            -             moist:qv,qc,qr,qi
+package   hwrflwscheme  ra_lw_physics==98
+
+package   swradscheme   ra_sw_physics==1             -             -
+package   gsfcswscheme  ra_sw_physics==2             -             -
+package   camswscheme   ra_sw_physics==3             -             -
+package   rrtmg_swscheme  ra_sw_physics==4           -             -
+package   goddardswscheme  ra_sw_physics==5          -             -
+package   gfdlswscheme  ra_sw_physics==99            -             -
+package   hwrfswscheme  ra_sw_physics==98
+package   heldsuarez    ra_lw_physics==31            -             -
+
+package   sfclayscheme   sf_sfclay_physics==1        -             -
+package   myjsfcscheme   sf_sfclay_physics==2        -             -
+package   gfssfcscheme   sf_sfclay_physics==3        -             -
+package   gfdlsfcscheme  sf_sfclay_physics==88       -             -
+package   qnsesfcscheme  sf_sfclay_physics==4        -             -
+package   pxsfcscheme    sf_sfclay_physics==7        -             -
+package   temfsfcscheme  sf_sfclay_physics==10       -             -
+package   idealscmsfcscheme  sf_sfclay_physics==89   -             -
+
+package   slabscheme     sf_surface_physics==1       -             -
+package   lsmscheme      sf_surface_physics==2       -             -
+package   ruclsmscheme   sf_surface_physics==3       -             -
+package   gfdlslab       sf_surface_physics==88      -             -
+package   pxlsmscheme    sf_surface_physics==7       -             -
+package   ysuscheme      bl_pbl_physics==1           -             -
+package   myjpblscheme   bl_pbl_physics==2           -             -
+package   gfsscheme      bl_pbl_physics==3           -             -
+package   qnsepblscheme  bl_pbl_physics==4           -             -
+package   acmpblscheme   bl_pbl_physics==7           -             -
+package   boulacscheme   bl_pbl_physics==8           -             - 
+package   camuwpblscheme bl_pbl_physics==9           -             -
+package   mrfscheme      bl_pbl_physics==99          -             -
+package   temfpblscheme  bl_pbl_physics==10          -             -
+
+package   kfetascheme    cu_physics==1               -             -
+package   bmjscheme      cu_physics==2               -             -
+package   gdscheme       cu_physics==3               -             -
+package   sasscheme      cu_physics==4               -             -
+package   g3scheme       cu_physics==5               -             -
+package   tiedtkescheme  cu_physics==6               -             -
+package   camzmscheme    cu_physics==7               -             -
+package   nsasscheme     cu_physics==14              -             -
+package   kfscheme       cu_physics==99              -             -
+
+package   g3shcuscheme   shcu_physics==1             -             -
+package   camuwshcuscheme shcu_physics==2            -             -
+
+package   dfi_setup      dfi_stage==0                -             -
+package   dfi_bck        dfi_stage==1                -             -
+package   dfi_fwd        dfi_stage==2                -             -
+package   dfi_fst        dfi_stage==3                -             -
+package   dfi_startfwd   dfi_stage==4                -             -
+package   dfi_startbck   dfi_stage==5                -             -
+package   dfi_nodfi     dfi_opt==0                  -             -
+package   dfi_dfl       dfi_opt==1                  -            \
+ state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC
+package   dfi_ddfi      dfi_opt==2                  -            \
+ state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC
+package   dfi_tdfi      dfi_opt==3                  -            \
+ state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC
+
+# 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:HBM2
+halo HALO_NMM_INIT_2	dyn_nmm 120:HBM3,VBM2,VBM3
+halo HALO_NMM_INIT_3	dyn_nmm 120:SM,SICE
+halo HALO_NMM_INIT_4	dyn_nmm 120: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
+
+#for HWRF: zhang increase halo width to fix feedback bug for HALO_NMM_A (24 => 48)
+#for HWRF: zhang HALO_NMM_C (24 => 48), HALO_NMM_G (24 => 48), HALO_NMM_K (8 => 24)
+halo      HALO_NMM_A  dyn_nmm 48: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 48:u,v                    
+halo      HALO_NMM_D  dyn_nmm 48: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 48:u,v;24:z  
+halo      HALO_NMM_H  dyn_nmm 24:w                  
+halo      HALO_NMM_I  dyn_nmm 48:q,q2,cwm,rrw
+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 24: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
+
+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
+
+halo      HALO_NMM_SAS_A  dyn_nmm 24:uz0h,vz0h,hbm2
+halo      HALO_NMM_SAS_B  dyn_nmm 24:ducudt,dvcudt
+halo      HALO_TRACERS dyn_nmm 48:szj,s1z,spz,tcs
+
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.NMM_NEST
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.NMM_NEST	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.NMM_NEST	(revision 17)
@@ -0,0 +1,1449 @@
+# 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=<variable name>".  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.
+#
+
+include registry.dimspec
+
+#############
+rconfig   integer ntracers                namelist,physics     1              4       -
+
+# option 1
+#dimspec ntracevars   -     constant=4             c       number of 4d tracer variables
+#state   real    -   ijk{ntracevars}f  tracers   1  -  - - -
+#state   real    t1  ijk{ntracevars}f  tracers   1  -  r - -
+#state   real    t2  ijk{ntracevars}f  tracers   1  -  r - -
+#state   real    t3  ijk{ntracevars}f  tracers   1  -  r - -
+#state   real    t4  ijk{ntracevars}f  tracers   1  -  r - -
+#package   tracer_option_1     ntracers==4                -             tracers:t1,t2,t3,t4
+
+# option 2
+state   real    -     ijkf  szj   1  -  - - -
+state   real    szj1  ijkf  szj   1  -  r "szj1" "szj" "units"
+state   real    szj2  ijkf  szj   1  -  r "szj2" "szj" "units"
+state   real    szj3  ijkf  szj   1  -  r "szj3" "szj" "units"
+state   real    szj4  ijkf  szj   1  -  r "szj4" "szj" "units"
+
+state   real    -     ijkf  s1z   1  -  - - -
+state   real    s1z1  ijkf  s1z   1  -  r "s1z1" "s1z" "units"
+state   real    s1z2  ijkf  s1z   1  -  r "s1z2" "s1z" "units"
+state   real    s1z3  ijkf  s1z   1  -  r "s1z3" "s1z" "units"
+state   real    s1z4  ijkf  s1z   1  -  r "s1z4" "s1z" "units"
+
+state   real    -     ijkf  spz   1  -  - - -
+state   real    spz1  ijkf  spz   1  -  r "spz1" "spz" "units"
+state   real    spz2  ijkf  spz   1  -  r "spz2" "spz" "units"
+state   real    spz3  ijkf  spz   1  -  r "spz3" "spz" "units"
+state   real    spz4  ijkf  spz   1  -  r "spz4" "spz" "units"
+
+state   real    -     ijkf  tcs   1  -  - - -
+state   real    tcs1  ijkf  tcs   1  -  r "tcs1" "tcs" "units"
+state   real    tcs2  ijkf  tcs   1  -  r "tcs2" "tcs" "units"
+state   real    tcs3  ijkf  tcs   1  -  r "tcs3" "tcs" "units"
+state   real    tcs4  ijkf  tcs   1  -  r "tcs4" "tcs" "units"
+
+package tracer_option_2 ntracers==4 - szj:szj1,szj2,szj3,szj4;s1z:s1z1,s1z2,s1z3,s1z4;spz:spz1,spz2,spz3,spz4;tcs:tcs1,tcs2,tcs3,tcs4
+
+################################################################################
+################################################################################
+################################################################################
+
+# 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   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     -     i014r    "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...
+
+# The following arrays were added to avoid using _b and _bt arrays for nesting.
+# This is gopal' doing:
+
+state  integer    nrnd1    k    dyn_nmm     1      -      r    "NRND1"
+
+#for HWRF: zhang's doing: added a 'r' at end to store these variables in restart file
+state  real    pdnest_b     ij      dyn_nmm     1      -      r
+state  real    pdnest_bt    ij      dyn_nmm     1      -      r
+state  real    tnest_b      ijk     dyn_nmm     1      -      r
+state  real    tnest_bt     ijk     dyn_nmm     1      -      r
+state  real    qnest_b      ijk     dyn_nmm     1      -      r
+state  real    qnest_bt     ijk     dyn_nmm     1      -      r
+state  real    unest_b      ijk     dyn_nmm     1      -      r
+state  real    unest_bt     ijk     dyn_nmm     1      -      r
+state  real    vnest_b      ijk     dyn_nmm     1      -      r
+state  real    vnest_bt     ijk     dyn_nmm     1      -      r
+state  real    q2nest_b     ijk     dyn_nmm     1      -      r
+state  real    q2nest_bt    ijk     dyn_nmm     1      -      r
+state  real    cwmnest_b    ijk     dyn_nmm     1      -      r
+state  real    cwmnest_bt   ijk     dyn_nmm     1      -      r
+
+#
+# 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      -    rh  "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      -    r  "MVNEST" "LOGICAL SWITCH FOR NMM GRID MOTION"
+#for HWRF: zhang's doing added to calculate radiation constant for moving nest for restart
+state integer julyr_rst      -     dyn_nmm     1      -    r  "JULYR_RST" "JULYR for restart moving nest "
+state integer julday_rst     -     dyn_nmm     1      -    r  "JULDAY_RST" "JULDAY for restart moving nest "
+state real    gmt_rst        -     dyn_nmm     1      -    r  "GMT_RST" "GMT for restart moving nest "
+state integer NTIME0         -     dyn_nmm     1      -    r  "NTIME0" "COUNT FOR PREVIOUS MOVING NEST"
+
+#for HWRF: 
+# flag for nest movement
+state  logical moved       -     misc       1      -     r
+
+state   real   ducudt       ijk     misc        1         -    rh  "UMMIX" "U TENDENCY  MOMENTUM MIXING IN SAS"
+state   real   dvcudt       ijk     misc        1         -    rh  "VMMIX" "V TENDENCY  MOMENTUM MIXING IN SAS"
+# For random number in SAS convection in HWRF
+
+state real store_rand        ij     dyn_nmm     1      -    rh  "RANDOM" "RANDOM NUMBER FOR SAS"
+
+# Location of the SOUTH-WEST nested pointed in terms of parent grid
+
+state integer  IIH      ij     dyn_nmm     1      -      rh
+state integer  JJH      ij     dyn_nmm     1      -      rh
+state integer  IIV      ij     dyn_nmm     1      -      rh
+state integer  JJV      ij     dyn_nmm     1      -      rh
+
+# Bi-linear weights
+
+state  real   HBWGT1       ij     dyn_nmm     1      -      rh
+state  real   HBWGT2       ij     dyn_nmm     1      -      rh
+state  real   HBWGT3       ij     dyn_nmm     1      -      rh
+state  real   HBWGT4       ij     dyn_nmm     1      -      rh
+state  real   VBWGT1       ij     dyn_nmm     1      -      rh
+state  real   VBWGT2       ij     dyn_nmm     1      -      rh
+state  real   VBWGT3       ij     dyn_nmm     1      -      rh
+state  real   VBWGT4       ij     dyn_nmm     1      -      rh
+#end of HWRF: 
+
+#
+state  real   HLON        ij     dyn_nmm     1      -      h01d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)
+state  real   HLAT        ij     dyn_nmm     1      -      h01d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)
+state  real   VLON        ij     dyn_nmm     1      -      irh
+state  real   VLAT        ij     dyn_nmm     1      -      irh
+
+#
+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"
+#for HWRF: 
+rconfig   logical analysis               namelist,time_control    max_domains        .false.      irh   "days"     "analysis control for the nested domain"
+
+state  real   PSTD      k      dyn_nmm     1      Z      r
+state  integer KZMAX    -      dyn_nmm     -      -      r
+state  real   Z3D       ijk    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       ijk    dyn_nmm     1      -      rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "T3D" "TEMPERATURE ARRAY ON STANDARD PRESSURE LEVELS"
+state  real   Q3D       ijk    dyn_nmm     1      -      rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "Q3D" "SP HUMIDITY ARRAY ON STANDARD PRESSURE LEVELS"
+#end of HWRF: 
+
+state  real HRES_FIS    ij     dyn_nmm     1      -      r  "HRES_FIS" "HIGH RESOLUTION TERRAIN DATA FOR NESTED DOMAIN"
+
+#
+# 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      -      irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)     "SICE"    "Sea ice mask; =1 for sea ice, =0 for no sea ice"         ""
+#
+# 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: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   t         ijkb    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         ijkb    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         ijkb    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:unest_b,unest_bt,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)   "U"       "U component of wind"                           "m s-1"
+state  real   v         ijkb    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:vnest_b,vnest_bt,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)   "V"       "V component of wind"                           "m s-1"
+state  real   told      ijk    dyn_nmm     1      -      r       "TOLD"    "T from previous timestep"                      "K"
+state  real   uold      ijk    dyn_nmm     1      -      r       "UOLD"    "U from previous timestep"                      "m s-1"
+state  real   vold      ijk    dyn_nmm     1      -      r       "VOLD"    "V from previous timestep"                      "m s-1"
+#
+# NMM DFI
+#
+state   real   hcoeff         {ndfi} misc        1         -     -    "HCOEFF"               "initialization weights"
+state   real   hcoeff_tot       -    misc        1         -     -    "HCOEFF_TOT"               "initialization weights"
+
+state  real   dfi_pd        ij     misc    1      -      r   "DFI_PD"      "Mass at I,J in the sigma domain"               "Pa"
+state  real   dfi_pint      ijk    misc    1      Z      r   "DFI_PINT"      "Model layer interface pressure"   "Pa"
+state  real   dfi_dwdt      ijk    misc    1      -     r    "DFI_DWDT"      "dwdt and 1+(dwdt)/g"              "m s-2"
+state  real   dfi_t         ijk    misc    1      -      r   "DFI_T"       "Sensible temperature"                          "K"
+state  real   dfi_q         ijk    misc    1      -      r   "DFI_Q"       "Specific humidity"                             "kg kg-1"
+state  real   dfi_u         ijk    misc    1      -      r   "DFI_U"       "U component of wind"                           "m s-1"
+state  real   dfi_v         ijk    misc    1      -      r   "DFI_V"       "V component of wind"                           "m s-1"
+state  real   dfi_q2        ijk    misc    1      -      r   "DFI_Q2"      "2 * Turbulence kinetic energy"                 "m2 s-2"
+state  real   dfi_cwm       ijk    misc    1      -      r   "DFI_CWM"     "Total condensate"                              "kg kg-1"
+state  real   dfi_rrw       ijk    misc    1      -      r   "DFI_RRW"     "Tracer"                                        "kg kg-1"
+### remaining simply set aside, and restored to original values after filtering.
+###
+state    real  dfi_STC        ilj   misc          1         Z     r    "DFI_STC"         "SOIL TEMPERATURE"   "K"
+state    real  dfi_SMC        ilj   misc          1         Z     r    "DFI_SMC"       "SOIL MOISTURE"     "m3 m-3"
+state    real  dfi_SH2O       ilj   misc          1         Z     r    "DFI_SH2O"      "UNFROZEN SOIL MOISTURE"     "m3 m-3"
+
+state    real  dfi_SNOW        ij    misc        1         -     r    "dfi_SNOW"         "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real  dfi_SNOWH       ij    misc        1         -     r    "dfi_SNOWH"        "PHYSICAL SNOW DEPTH"      "m"
+state    real  dfi_CANWAT      ij    misc        1         -     r    "dfi_CANWAT"       "CANOPY WATER"             "kg m-2"
+state    real  dfi_NMM_TSK      ij      misc        1       -     r   "dfi_NMM_TSK"               "saved SURFACE SKIN TEMPERATURE"
+state    real  dfi_SNOWC        ij      misc        1       -      r  "dfi_SNOWC"             "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)"         ""
+
+#
+# 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      -      i01rh    "DETA1"   "Delta sigma in pressure domain"                ""
+state  real   aeta1     k      dyn_nmm     1      -      i01rh    "AETA1"   "Midlayer sigma value in pressure domain"       ""
+state  real   eta1      k      dyn_nmm     1      Z      i01rh   "ETA1"    "Interface sigma value in pressure domain"      ""
+state  real   deta2     k      dyn_nmm     1      -      i01rh    "DETA2"   "Delta sigma in sigma domain"                   ""
+state  real   aeta2     k      dyn_nmm     1      -      i01rh    "AETA2"   "Midlayer sigma value in sigma domain"          ""
+state  real   eta2      k      dyn_nmm     1      Z      i01rh   "ETA2"    "Interface sigma value in sigma domain"         ""
+state  real   em        q      dyn_nmm     1      -      ir
+state  real   emt       q      dyn_nmm     1      -      ir
+#for HWRF: add to restart
+state  real   adt       ij     dyn_nmm     1      -      r       "ADT"     "Change of T due to advection"                  "K"
+state  real   adu       ij     dyn_nmm     1      -      r       "ADU"     "Change of U due to advection"                  "m s-1"
+state  real   adv       ij     dyn_nmm     1      -      r       "ADV"     "Change of V due to advection"                  "m s-1"
+#end HWRF:
+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
+#for HWRF: add to restart
+state  logical upstrm   -      dyn_nmm     -      -      -       "UPSTRM"  ".TRUE. => In upstream advec region of grid"    ""
+#end HWRF:
+state  real   dlmd      -      dyn_nmm     -      -      irh      "DLMD"    "East-west angular distance H-to-V points"      "degrees"
+state  real   dphd      -      dyn_nmm     -      -      irh      "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
+#
+#for HWRF: add to restart
+state  real   pdsl      ij     dyn_nmm     1      -      r       "PDSL"    "Sigma-domain pressure at sigma=1"           "Pa"
+state  real   pdslo     ij     dyn_nmm     1      -      r       "PDSLO"   "PDSL from previous timestep"                "Pa"
+#end HWRF:
+state  real   psdt      ij     dyn_nmm     1      -      r       "PSDT"    "Surface pressure tendency"                  "Pa s-1"
+state  real   div       ijk    dyn_nmm     1      -      r       "DIV"     "Divergence"                                 "Pa s-1"
+state  real   def3d     ijk    dyn_nmm     1      -      r       "DEF3D"   "Deformation term from horizontal diffusion"      ""
+#for HWRF: add to restart
+state  real   few       ijk    dyn_nmm     1      -      r       "FEW"     "Integrated east-west mass flux"             "Pa m2 s-1"
+state  real   fne       ijk    dyn_nmm     1      -      r       "FNE"     "Integrated northeast-southwest mass flux"   "Pa m2 s-1"
+state  real   fns       ijk    dyn_nmm     1      -      r       "FNS"     "Integrated north-south mass flux"           "Pa m2 s-1"
+state  real   fse       ijk    dyn_nmm     1      -      r       "FSE"     "Integrated southeast-northwest mass flux"   "Pa m2 s-1"
+#end HWRF:
+state  real   omgalf    ijk    dyn_nmm     1      -      r       "OMGALF"  "Omega-alpha"                                "K"
+#for HWRF: add to restart
+state  real   petdt     ijk    dyn_nmm     1      -      r       "PETDT"   "Vertical mass flux"                         "Pa s-1"
+#end HWRF:
+state  real   rtop      ijk    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   mixht     ij    dyn_nmm   1    -     rh        "MIXHT"                 "MXL HEIGHT"              "m"
+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   taux      ij    dyn_nmm   1    -     irh      "TAUX"     "Instantaneous stress along X direction in KG/M/S^2" 
+state  real   tauy      ij    dyn_nmm   1    -     irh      "TAUY"     "Instantaneous stress along Y direction in KG/M/S^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    -     rh01d=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ACPREC"   "Accumulatedtotal 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 eqiv of snow on ground"  "kg m-2"
+state  real   si        ij    dyn_nmm   1    -     irh      "SI"       "Depth of snow on ground"              "mm"
+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    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "TH10"     "10-m potential temperature from MYJ"  "K"
+state  real   q10       ij    dyn_nmm   1    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "Q10"      "10-m specific humidity from MYJ"      "kg kg-1"
+state  real   pshltr    ij    dyn_nmm   1    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "PSHLTR"   "2-m pressure from MYJ"                "Pa"
+state  real   tshltr    ij    dyn_nmm   1    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "TSHLTR"   "2-m potential temperature from MYJ"    "K"
+state  real   qshltr    ij    dyn_nmm   1    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "QSHLTR"   "2-m specific humidity from MYJ"       "kg kg-1"
+state  real   q2        ijkb   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:q2nest_b,q2nest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)   "Q2"       "2 * Turbulence kinetic energy"        "m2 s-2"
+state  real   t_adj     ijk   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     ijk   dyn_nmm   1    -     r        "T_OLD"    "T before last call to precip"         "K"
+state  real   zero_3d   ijk   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    -     rh       "AKHS_OUT"  "Output sfc exch coeff for heat"               "m2 s-1"
+state  real   AKMS_OUT  ij    dyn_nmm   1    -     rh       "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   embck     ij    dyn_nmm   1    -     ir       "EMBCK"     "Background radiative emissivity"                 ""
+state  real   epsr      ij    dyn_nmm   1    -     irh      "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    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "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       ijkb   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:cwmnest_b,cwmnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)  "CWM"       "Total condensate"                     "kg kg-1"
+state  real   rrw       ijkb  dyn_nmm   1    -     rh       "RRW"       "Tracer"                               "kg kg-1"
+state  real   f_ice     ikj   dyn_nmm   1    -     rhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)  "F_ICE"     "Frozen fraction of CWM"               ""
+state  real   f_rain    ikj   dyn_nmm   1    -     rhd=(interp_hnear_ikj_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_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)  "F_RIMEF"   "Rime factor"                          ""
+state  real   cldfra    ijk   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    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "CFRACH"    "High cloud fraction"                  ""
+state  real   cfracl    ij    dyn_nmm   1    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "CFRACL"    "Low cloud fraction"                   ""
+state  real   cfracm    ij    dyn_nmm   1    -     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "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    -     irh      "DZSOIL"    "Thickness of soil layers"         "m"
+state  real   rtdpth    k     dyn_nmm   1    -     i01r
+state  real   sldpth    k     dyn_nmm   1    -     i01rh    "SLDPTH"    "Depths of centers 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    -     i014rhd=(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_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)   "SH2O"      "Unfrozen soil moisture volume fraction"  ""
+state  real   smc       ilj   dyn_nmm   1    Z     irhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)   "SMC"       "Soil moisture volume fraction"    ""
+state  real   stc       ilj   dyn_nmm   1    Z     irhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)   "STC"       "Soil temperature"                 "K"
+#
+# module_GWD.F
+#
+state  real   hstdv     ij    dyn_nmm   1    -     i01rh      "HSTDV"     "Standard deviation of height"     "m"
+state  real   hcnvx     ij    dyn_nmm   1    -     i01rh      "HCNVX"     "Normalized 4th moment of orographic convexity"     ""
+state  real   hasyw     ij    dyn_nmm   1    -     i01rh      "HASYW"     "Orographic asymmetry in W-E plane"  ""
+state  real   hasys     ij    dyn_nmm   1    -     i01rh      "HASYS"     "Orographic asymmetry in S-N plane"  ""
+state  real   hasysw    ij    dyn_nmm   1    -     i01rh      "HASYSW"    "Orographic asymmetry in SW-NE plane"  ""
+state  real   hasynw    ij    dyn_nmm   1    -     i01rh      "HASYNW"    "Orographic asymmetry in NW-SE plane"  ""
+state  real   hlenw     ij    dyn_nmm   1    -     i01rh      "HLENW"     "Orographic length scale in W-E plane"  ""
+state  real   hlens     ij    dyn_nmm   1    -     i01rh      "HLENS"     "Orographic length scale in S-N plane"  ""
+state  real   hlensw    ij    dyn_nmm   1    -     i01rh      "HLENSW"    "Orographic length scale in SW-NE plane"  ""
+state  real   hlennw    ij    dyn_nmm   1    -     i01rh      "HLENNW"    "Orographic length scale in NW-SE plane"  ""
+state  real   hangl     ij    dyn_nmm   1    -     i01rh      "HANGL"     "Angle of the mountain range w/r/t east"  "deg"
+state  real   hanis     ij    dyn_nmm   1    -     i01rh      "HANIS"     "Anisotropy/aspect ratio of orography"   ""
+state  real   hslop     ij    dyn_nmm   1    -     i01rh      "HSLOP"     "Slope of orography"             ""
+state  real   hzmax     ij    dyn_nmm   1    -     i01rh      "HZMAX"     "Maximum height above mean orography"    "m"
+state  real   crot      ij    dyn_nmm   1    -      -       "CROT"      "Cosine of angle between model and earth coordinates"    ""
+state  real   srot      ij    dyn_nmm   1    -      -       "SROT"      "Sine of angle between model and earth coordinates"    ""
+state  real   UGWDsfc   ij    dyn_nmm   1    -      h       "UGWDsfc"   "Surface zonal wind stress due to gravity wave drag"    "N m-2"
+state  real   VGWDsfc   ij    dyn_nmm   1    -      h       "VGWDsfc"   "Surface meridional wind stress due to gravity wave drag"    "N m-2"
+#
+# 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      ijk   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     ijk   dyn_nmm   1    -     r
+state  real   pint      ijk   dyn_nmm   1    Z     irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "PINT"      "Model layer interface pressure"   "Pa"
+state  real   w         ijk   dyn_nmm   1    Z     rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "W"         "Vertical velocity"                "m s-1"
+state  real   z         ijk   dyn_nmm   1    Z     -        "Z"         "Distance from ground"             "m"
+#
+# module_ACCUM.F
+#
+state  real   acfrcv    ij    dyn_nmm     1    -    rh    "ACFRCV"    "Accum convective cloud fraction"   ""
+state  real   acfrst    ij    dyn_nmm     1    -    rh    "ACFRST"    "Accum stratiform cloud fraction"   ""
+state  real   ssroff    ij    dyn_nmm     1    -    rh    "SSROFF"    "Surface runoff"                    "mm"
+state  real   bgroff    ij    dyn_nmm     1    -    rh    "BGROFF"    "Subsurface runoff"                 "mm"
+state  real   rlwin     ij    dyn_nmm     1    -    rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)    "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    -    rh    "ALWIN"     "Accum LW down at surface"          "W m-2"
+state  real   alwout    ij    dyn_nmm     1    -    rh    "ALWOUT"    "Accum RADOT (see above)"           "W m-2"
+state  real   alwtoa    ij    dyn_nmm     1    -    rh    "ALWTOA"    "Accum RLWTOA"                      "W m-2"
+state  real   rswin     ij    dyn_nmm     1    -    rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)    "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"
+#for HWRF: add to restart
+state  real   rswtoa    ij    dyn_nmm     1    -    r     "RSWTOA"    "Outgoing SW flux at top of atmos"  "W m-2"
+#end HWRF
+state  real   aswin     ij    dyn_nmm     1    -    rh    "ASWIN"     "Accum SW down at surface"          "W m-2"
+state  real   aswout    ij    dyn_nmm     1    -    rh    "ASWOUT"    "Accum RSWOUT"                      "W m-2"
+state  real   aswtoa    ij    dyn_nmm     1    -    rh    "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    -    rh
+state  real   tlmax     ij    dyn_nmm     1    -    rh
+state  real   t02_min   ij    dyn_nmm     1    -    rh    "T02_MIN"  "Hourly Min Shelter Temperature"    "K"
+state  real   t02_max   ij    dyn_nmm     1    -    rh    "T02_MAX"  "Hourly Max Shelter Temperature"    "K"
+state  real   rh02_min  ij    dyn_nmm     1    -    rh    "RH02_MIN" "Hourly Min Relative Humidity"    ""
+state  real   rh02_max  ij    dyn_nmm     1    -    rh    "RH02_MAX" "Hourly Max Relative Humidity"    ""
+state  real   rlwtt     ijk   dyn_nmm     1    -    rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)  "RLWTT"     "Longwave temperature tendency"     "K s-1"
+state  real   rswtt     ijk   dyn_nmm     1    -    rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)  "RSWTT"     "Shortwave temperature tendency"    "K s-1"
+#for HWRF: add to restart
+state  real   tcucn     ijk   dyn_nmm     1    -    r     "TCUCN"     "Accum convec temperature tendency" "K s-1"
+state  real   train     ijk   dyn_nmm     1    -    r     "TRAIN"     "Accum stratiform temp tendency"    "K s-1"
+#end HWRF
+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 ncnvc0     -     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    -    -
+state integer iradg     r    dyn_nmm     1    -    -
+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                                         
+#<Table> <Type> <Sym>         <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>   
+#
+# 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
+#-------------------------------------------------------------------------------------------------------------------------------
+
+# Time series variables
+state    real   ts_hour         ?!       misc      -         -      -        "TS_HOUR"        "Model integration time, hours"
+state    real   ts_u            ?!       misc      -         -      -        "TS_U"           "Surface wind U-component, earth-relative"
+state    real   ts_v            ?!       misc      -         -      -        "TS_V"           "Surface wind V-component, earth-relative"
+state    real   ts_q            ?!       misc      -         -      -        "TS_Q"           "Surface mixing ratio"
+state    real   ts_t            ?!       misc      -         -      -        "TS_T"           "Surface temperature"
+state    real   ts_psfc         ?!       misc      -         -      -        "TS_PSFC"        "Surface pressure"
+state    real   ts_tsk          ?!       misc      -         -      -        "TS_TSK"         "Skin temperature"
+state    real   ts_tslb         ?!       misc      -         -      -        "TS_TSLB"        "Soil temperature"
+state    real   ts_clw          ?!       misc      -         -      -        "TS_CLW"         "Column integrated cloud water"
+
+#-----------------------------------------------------------------------------------------------------------------------------------------------------------------
+
+
+# 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    -              ijkft   moist       1         -     -    -                                       
+state   real    qv             ijkft   moist       1         -     rh      "QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    qc             ijkft   moist       1         -     rh      "QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    qr             ijkft   moist       1         -     rh      "QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    qi             ijkft   moist       1         -     rh      "QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    qs             ijkft   moist       1         -     rh      "QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    qg             ijkft   moist       1         -     rh      "QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+state   real    qh             ijkft   moist       1         -     rh      "QHAIL"            "Hail mixing ratio"             "kg kg-1"
+
+
+state   real    -              ijkft   dfi_moist       1         -     -    -
+state   real    dfi_qv         ijkft   dfi_moist       1         -     r      "QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    dfi_qc         ijkft   dfi_moist       1         -     r      "QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    dfi_qr         ijkft   dfi_moist       1         -     r      "QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    dfi_qi         ijkft   dfi_moist       1         -     r      "QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    dfi_qs         ijkft   dfi_moist       1         -     r      "QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    dfi_qg         ijkft   dfi_moist       1         -     r      "QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+state   real    dfi_qh         ijkft   dfi_moist       1         -     r      "QHAIL"             "Hail mixing ratio"              "kg kg-1"
+state   real    dfi_qnh        ijkft   dfi_moist       1         -     r      "QNHAIL"           "Hail Number concentration"        "# kg(-1)"
+
+
+#                                               
+# Other Scalars
+state   real    -              ijkftb  scalar      1         -     -    -
+state   real    qni            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNI"              "Ice Number concentration" "# kg(-1)"
+state   real    qns            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNS"              "Snow Number concentration" "# kg(-1)"
+state   real    qnr            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNR"              "Rain Number concentration" "# kg(-1)"
+state   real    qng            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNG"              "Graupel Number concentration" "# kg(-1)"
+state   real    qnh            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNHAIL"            "Hail Number concentration" "# kg(-1)"
+state   real    qnn            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNCCN"            "CCN Number concentration" "# kg(-1)"
+state   real    qnc            ijkftb  scalar      1         -     i01rusdf=(bdy_interp:dt)       "QNCLOUD"          "cloud water Number concentration" "# kg(-1)"
+
+
+state   real    -              ijkftb  dfi_scalar      1         -     -   -
+state   real    dfi_qndrop     ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNDROP"    "Droplet number mixing ratio"        "# kg-1"
+state   real    dfi_qni        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNICE"     "Ice Number concentration" "# kg-1"
+state   real    dfi_qt         ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_CWM"       "Total condensate mixing ratio"      "kg kg-1"
+state   real    dfi_qns        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNSNOW"    "Snow Number concentration"   "# kg(-1)"
+state   real    dfi_qnr        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNRAIN"    "Rain Number concentration"   "# kg(-1)"
+state   real    dfi_qng        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)"
+state   real    dfi_qnn        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCC"      "CNN Number concentration"   "# kg(-1)"
+state   real    dfi_qnc        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCLOUD"   "Cloud 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         -     irh01d=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "U10"                  "U at 10 M"         " "
+state    real   V10              ij     misc        1         -     irh01d=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "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   LAI              ij     misc        1         -     i0124rh   "LAI"                  "Leaf area index"          "area/area"
+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         -     i014rhd=(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         -     i0124r   "ALBBCK"          "BACKGROUND ALBEDO"        "NA"
+state    real   SFCEXC           ij     misc        1         -     irh     "SFCEXC "              "SURFACE EXCHANGE COEFFICIENT"         ""
+state    real   SNOTIME          ij     misc        1         -     r        "SNOTIME"              "SNOTIME"                             ""
+state    real   ACSNOW           ij     misc        1         -     irh       "ACSNOW"               "ACCUMULATED SNOW"       "kg m-2"
+state    real   ACSNOM           ij     misc        1         -     irh       "ACSNOM"               "ACCUMULATED MELTED SNOW"         "kg m-2"
+state    real   RMOL             ij     misc        1         -     ir       "RMOL"               ""         ""
+state    real   SNOW             ij     misc        1         -     i01rh       "SNOW"                 "SNOW WATER EQUIVALENT"         "kg m-2"
+state    real   CANWAT           ij     misc        1         -     i01rh       "CANWAT"               "CANOPY WATER" ""
+state    real   SST              ij     misc        1         -     i014rhd=(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" "kg m-2"
+state    real  ZNT              ij      misc        1         -     irh        "ZNT"                   "TIME-VARYING ROUGHNESS LENGTH"
+state    real  MOL              ij      misc        1         -     ir        "MOL"                   "T* IN SIMILARITY THEORY"                      "K"
+state    real  NOAHRES          ij      misc        1         -     rh        "NOAHRES"               "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}"
+
+state    real   tke_pbl         ijk     misc        1         -     r         "TKE_PBL"               "TKE FROM PBL SCHEME"     "m2 s-2"
+state    real   el_pbl          ikj     misc        1         -     -         "EL_PBL"                "MIXING LENGTH FROM PBL SCHEME"     "m"
+state    real   EXCH_H         ikj     misc        1         -     r         "EXCH_H"               "EXCHANGE COEFFICIENTS FOR HEAT"               "m2 s-1"
+state    real   EXCH_M         ikj     misc        1         -     r         "EXCH_M"               "EXCHANGE COEFFICIENTS FOR MOMENTUM"           "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  DEW              ij      misc        1         -      r        "DEW"                   "DEW 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              ijk     misc        1         -     -      
+state   real   dvdt              ijk     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   CHKLOWQ          ij     misc        1         -     -         "CHKLOWQ"               "SURFACE SATURATION FLAG"        ""
+state    real    HTOP            ij     misc        1         -     irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "HTOP"                 "TOP OF CONVECTION LEVEL"         ""
+state    real    HBOT            ij     misc        1         -     irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "HBOT"                 "BOT OF CONVECTION LEVEL"         ""
+state    real    HTOPR           ij     misc        1         -     ird=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "HTOPR"                 "TOP OF CONVECTION LEVEL FOR RADIATION"         ""
+state    real    HBOTR           ij     misc        1         -     ird=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)       "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         -     rhd=(interp_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"  "m"
+state    real   RHOSN            ij     misc        1         -     i01rd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)    "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.  
+#for HWRF: add to restart
+state   integer itimestep      -        -          -         -     rh         "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"         ""         ""    
+
+# 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
+
+######                                          
+#                                               
+# Variables that are set at run-time to control configuration  (namelist-settable)                                              
+#                                               
+#<Table>  <Type>  <Sym>                   <How set>          <Nentries>   <Default>                                             
+
+
+# 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
+
+#for HWRF: added a 'r' for restart
+rconfig   integer JULYR                   namelist,time_control         max_domains    0       hr    "JULYR"                 ""      ""
+rconfig   integer JULDAY                  namelist,time_control         max_domains    1       hr    "JULDAY"                ""      ""
+rconfig   real    GMT                     namelist,time_control         max_domains    0.      hr    "GMT"           ""      ""
+#for HWRF: end 
+rconfig   character  input_inname      namelist,time_control		1  "wrfinput_d<domain>"          -     "name of input   infile"   ""      ""
+rconfig   character  input_outname     namelist,time_control		1  "wrfinput_d<domain>"          -     "name of input   outfile"  ""      ""
+rconfig   character  bdy_inname        namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary infile"  ""      ""
+rconfig   character  bdy_outname       namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary outfile" ""      ""
+rconfig   character  rst_inname        namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "name of restrt infile"    ""      ""
+rconfig   character  rst_outname       namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "name of restrt outfile"   ""      ""
+#for HWRF:
+rconfig   character  anl_outname         namelist,time_control    max_domains  "wrfanl_d<domain>_<date>"     -     "name of analysis 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"
+rconfig   logical cycling                 namelist,time_control         1             .false. -    "true for cycling (using wrfout file as input data)"
+
+# DFI namelist
+rconfig   integer dfi_opt                namelist,dfi_control   1       0     rh   "dfi_opt"                ""      ""
+rconfig   integer dfi_nfilter            namelist,dfi_control   1       7     rh   "dfi_nfilter"                "Digital filter type"      ""
+rconfig   logical dfi_write_filtered_input  namelist,dfi_control  1  .true.   rh   "dfi_write_filtered_input"                "Write a wrfinput_filtered_d0n file?"      ""
+rconfig   logical dfi_write_dfi_history  namelist,dfi_control   1   .false.   rh   "dfi_write_dfi_history"    "Write history files during filtering?"      ""
+rconfig   integer dfi_cutoff_seconds     namelist,dfi_control   1    3600     rh   "dfi_cutoff_seconds"       "Digital filter cutoff time"      ""
+rconfig   integer dfi_time_dim           namelist,dfi_control   1    1000     rh   "dfi_time_dim"             "MAX DIMENSION FOR HCOEFF"
+rconfig   integer dfi_fwdstop_year       namelist,dfi_control   1    2004     rh   "dfi_fwdstop_year"         "4 DIGIT YEAR OF START OF DFI" "YEARS"
+rconfig   integer dfi_fwdstop_month      namelist,dfi_control   1      03     rh   "dfi_fwdstop_month"        "2 DIGIT MONTH OF THE YEAR OF START OF DFI" "MONTHS"
+rconfig   integer dfi_fwdstop_day        namelist,dfi_control   1      13     rh   "dfi_fwdstop_day"          "2 DIGIT DAY OF THE MONTH OF START OF DFI" "DAYS"
+rconfig   integer dfi_fwdstop_hour       namelist,dfi_control   1      12     rh   "dfi_fwdstop_hour"         "2 DIGIT HOUR OF THE DAY OF START OF DFI" "HOURS"
+rconfig   integer dfi_fwdstop_minute     namelist,dfi_control   1      00     rh   "dfi_fwdstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF START OF DFI" "MINUTES"
+rconfig   integer dfi_fwdstop_second     namelist,dfi_control   1      00     rh   "dfi_fwdstop_second"       "2 DIGIT SECOND OF THE MINUTE OF START OF DFI" "SECONDS"
+rconfig   integer dfi_bckstop_year       namelist,dfi_control   1    2004     rh   "dfi_bckstop_year"         "4 DIGIT YEAR OF END OF DFI" "YEARS"
+rconfig   integer dfi_bckstop_month      namelist,dfi_control   1      03     rh   "dfi_bckstop_month"        "2 DIGIT MONTH OF THE YEAR OF END OF DFI" "MONTHS"
+rconfig   integer dfi_bckstop_day        namelist,dfi_control   1      14     rh   "dfi_bckstop_day"          "2 DIGIT DAY OF THE MONTH OF END OF DFI" "DAYS"
+rconfig   integer dfi_bckstop_hour       namelist,dfi_control   1      12     rh   "dfi_bckstop_hour"         "2 DIGIT HOUR OF THE DAY OF END OF DFI" "HOURS"
+rconfig   integer dfi_bckstop_minute     namelist,dfi_control   1      00     rh   "dfi_bckstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF END OF DFI" "MINUTES"
+rconfig   integer dfi_bckstop_second     namelist,dfi_control   1      00     rh   "dfi_bckstop_second"       "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS"
+
+# 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 time_step_dfi           namelist,domains      1             -       ih   "time_step_dfi"
+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_soil_levels namelist,domains	1             4        irh    "num_metgrid_soil_levels"               "number of input levels or layers in 3D sm, st, sw arrays"      ""
+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   logical grid_allowed            namelist,domains      max_domains    .true.  irh    "allowed"       ""      ""
+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   ts_buf_size     namelist,domains    1                200          -       "ts_buf_size"   "Size of time series buffer"
+rconfig   integer   max_ts_locs     namelist,domains    1                5            -       "max_ts_locs"   "Maximum number of time series locations"
+rconfig   integer   num_moves       namelist,domains    1                0
+rconfig   integer   vortex_interval namelist,domains    max_domains      15  -  "" "" "minutes"
+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     "" "" ""
+# 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"      ""
+rconfig   logical   use_prep_hybrid namelist,domains    1              .false.     irh      "T=GFS spectral sigma files were used" "" ""
+
+# Physics
+rconfig   integer     mp_physics          namelist,physics	max_domains    0       rh       "mp_physics"            ""      ""
+#for HWRF:
+rconfig   real        mommix              namelist,physics     max_domains  0.7       irh    "MOMENTUM MIXING FOR SAS CONVECTION SCHEME"
+rconfig   logical     disheat             namelist,physics      max_domains  .true.    irh    "nmm input 7"
+#end HWRF:
+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   integer shcu_physics            namelist,physics      max_domains    0       rh   "shcu_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_urban_layers        namelist,physics      1            400       irh    "num_urban_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 fractional_seaice       namelist,physics      1            0        -     "fractional_seiace" "Fractional sea-ice option"
+rconfig   logical tice2tsk_if2cold        namelist,physics      1              .false. -     "tice2tsk_if2cold" "Avoid low ice temps when ice frac and Tsk are inconsistent"
+rconfig   integer sst_update              namelist,physics      1            0        i01rh    "sst_update"  "update sst from wrflowinp file  0=no, 1=yes"   ""
+rconfig   integer sf_urban_physics        namelist,physics      max_domains  0         h    "sf_urban_physics"   "activate urban model  0=no, 1=Noah_UCM 2=BEP_UCM"   ""
+rconfig   logical usemonalb               namelist,physics      1            .true.    h    "usemonalb"   "use 2d field vs table values  false=table, True=2d"   ""
+rconfig   logical rdmaxalb                namelist,physics      1            .true.    h     "rdmaxalb"    "false set it to table values"   ""
+rconfig   logical rdlai2d                 namelist,physics      1            .false.   h     "rdlai2d"     "false set it to table values"   ""
+rconfig   integer  gwd_opt                namelist,physics    max_domains    0       irh    "gwd_opt"      "activate gravity wave drag: 0=off, 1=ARW, 2=NMM"   ""
+rconfig   integer iz0tlnd                 namelist,physics      1            0         h     "iz0tlnd"    "switch to control land thermal roughness length"   ""
+
+
+# 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   real    sfenth                  namelist,physics     max_domains    1.0       irh     "sea spray parameter"
+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"  ""
+rconfig   real h_diff                     namelist,physics      max_domains  0.1      irh    "nmm input 9"
+rconfig   integer movemin                 namelist,physics      max_domains  10       irh    "nmm input 12"
+
+
+# Dynamics
+# dynamics option (see package definitions, below)
+rconfig   integer dyn_opt                 namelist,dynamics	1             - 
+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    iso_temp                namelist,dynamics     1               0.     h    "iso_temp" "Isothermal temperature in stratosphere, 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    c_s                     namelist,dynamics     max_domains    0.25    h    "c_s"         "Smagorinsky coeff"      ""
+rconfig   real    c_k                     namelist,dynamics     max_domains    0.15    h    "c_k"         "TKE coeff"      ""
+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    tke_upper_bound         namelist,dynamics	max_domains    1000.   h    "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 euler_adv               namelist,dynamics     1            .true.  irh  "euler_adv"    "logical flag to turn on/off Eulerian passive advection"   ""
+rconfig   integer idtadt                  namelist,dynamics     1              2      irh  "idtadt"   "fundamental timesteps between calls to Eulerian advection for dynamics"      ""
+rconfig   integer idtadc                  namelist,dynamics     1              2      irh  "idtadc"   "fundamental timesteps between calls to Eulerian advection for chemistry"      ""
+rconfig   real    codamp                  namelist,dynamics     max_domains   6.4     irh  "codamp"  "divergence damping weighting factor (larger = more damping) " ""
+rconfig   real    coac                    namelist,dynamics     max_domains   1.6     irh  "coac"  "horizontal diffusion weighting factor (larger = more diffusion) " ""
+rconfig   real    slophc                  namelist,dynamics     max_domains   6.363961e-3     irh  "slophc"  "Maximum model level slope (dZ/dy) for which hor diffusion is applied" ""
+rconfig   real    wp                      namelist,dynamics     max_domains   0.    irh  "wp"  "Off-centering weight in the updating of nonhyrostatic eps"
+
+
+
+# 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 polar                   namelist,bdy_control  max_domains    .false. rh    "polar"                 ""      ""
+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   integer  FLAG_METGRID           derived                      1          0       -        "FLAG_METGRID"         "Flag in global attributes for metgrid data"
+rconfig   integer  FLAG_SNOW              derived                      1          0       -        "FLAG_SNOW"             "Flag for snow in the global attributes for metgrid data"
+rconfig   integer  FLAG_PSFC              derived                      1          0       -        "FLAG_PSFC"             "Flag for surface pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM000010          derived                      1          0       -        "FLAG_SM000010"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM010040          derived                      1          0       -        "FLAG_SM010040"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM040100          derived                      1          0       -        "FLAG_SM040100"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM100200          derived                      1          0       -        "FLAG_SM100200"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST000010          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST010040          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST040100          derived                      1          0       -        "FLAG_ST010040"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST100200          derived                      1          0       -        "FLAG_ST100200"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_SLP               derived                      1          0       -        "FLAG_SLP"              "Flag for sea level pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SOILHGT           derived                      1          0       -        "FLAG_SOILHGT"          "Flag for soil height in the global attributes for metgrid data"
+rconfig   integer  FLAG_MF_XY             derived                      1          0       -        "FLAG_MF_XY"            "Flag for MF_XYin the global attributes for metgrid data"
+rconfig   real    bdyfrq                  derived                  max_domains    0       -        "bdyfrq"               "lateral boundary input frequency"      "seconds"
+rconfig   character mminlu                derived                  max_domains    " "     -        "mminlu"               "land use dataset"
+           ""
+rconfig   integer iswater                 derived                  max_domains    0       -        "iswater"              "land use index of water"      "index category"
+rconfig   integer islake                  derived                  max_domains    0       -        "islake"               "land use index of inland lake"      "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 dfi_stage               derived                       1         3       -        "dfi_stage"            "current stage of DFI processing"      "0=DFI setup, 1=DFI backward integration, 2=DFI forward integration, 3=WRF forecast"
+rconfig   integer mp_physics_dfi          derived                  max_domains   -1       -        "mp_physics_dfi"       ""      "-1 = no DFI and so no need to allocate DFI moistnd scalar variables, >0 = running with DFI, so allocate DFI moist and scalar variables appropriate for selected microphysics package"
+
+#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 -  -  -  "" "" ""
+
+# Turbine drag (td) physics
+# Turbine positions and characteristics for real-data cases are specified in a file
+# whose name is given in the windturbines_spec variable.  If the setting is "ideal",
+# the td_ variables specify idealized wind farm geometries and turbine characteristics.
+# If the setting is "none" then wind turbine drag physics is turned off.
+rconfig character windturbines_spec namelist,physics 1 "none" - - "" "none, ideal, or a file name"
+rconfig integer td_turbgridid  namelist,physics 1 -1     - - ""  "which grid id has turbines in it"
+rconfig  real   td_hubheight   namelist,physics 1 100.   - - ""  "hub height (m)"
+rconfig  real   td_diameter    namelist,physics 1 60.    - - ""  "turbine diameter (m)"
+rconfig  real   td_stdthrcoef  namelist,physics 1 .158   - - ""  "standing thrust coefficient"
+rconfig  real   td_cutinspeed  namelist,physics 1 4.     - - ""  "cut-in speed (m/s)"
+rconfig  real   td_cutoutspeed namelist,physics 1 27.    - - ""  "cut-out speed (m/s)"
+rconfig  real   td_power       namelist,physics 1 2.     - - ""  "turbine power (MW)"
+rconfig  real   td_turbpercell namelist,physics 1 1.     - - ""  "number of turbines per cell"
+rconfig integer td_ewfx        namelist,physics 1 0      - - ""  "extent of wind farm in x-cells"
+rconfig integer td_ewfy        namelist,physics 1 0      - - ""  "extent of wind farm in y-cells"
+rconfig integer td_pwfx        namelist,physics 1 1      - - ""  "southwest corner of wind farm in x-cells"
+rconfig integer td_pwfy        namelist,physics 1 1      - - ""  "southwest corner of wind farm in y-cells"
+
+#key      package       associated                package          associated 4d scalars
+#         name          namelist choice           state vars
+
+#### 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   gsfcgcescheme mp_physics==7                -             moist:qv,qc,qr,qi,qs,qg
+package   thompson      mp_physics==8                -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr
+package   milbrandt2mom mp_physics==9                -             moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh
+package   morr_two_moment  mp_physics==10            -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng
+package   sbu_ylinscheme    mp_physics==13           -             moist:qv,qc,qr,qi,qs
+package   wdm5scheme    mp_physics==14               -             moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr
+package   wdm6scheme    mp_physics==16               -             moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr
+package   etamp_hwrf    mp_physics==85               -             moist:qv,qc,qr,qi,qs
+
+package   nodfimoist        mp_physics_dfi==-1       -             -
+package   passiveqv_dfi     mp_physics_dfi==0        -             dfi_moist:dfi_qv
+package   kesslerscheme_dfi mp_physics_dfi==1        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   linscheme_dfi     mp_physics_dfi==2        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   wsm3scheme_dfi    mp_physics_dfi==3        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   wsm5scheme_dfi    mp_physics_dfi==4        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs
+package   etampnew_dfi      mp_physics_dfi==5        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs
+package   wsm6scheme_dfi    mp_physics_dfi==6        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   gsfcgcescheme_dfi mp_physics_dfi==7        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   thompson_dfi      mp_physics_dfi==8        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr
+package   milbrandt2mom_dfi mp_physics_dfi==9        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh
+package   morr_two_moment_dfi  mp_physics_dfi==10    -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng
+package   sbu_ylinscheme_dfi    mp_physics==13           -         dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs
+package   wdm5scheme_dfi    mp_physics_dfi==14       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+package   wdm6scheme_dfi    mp_physics_dfi==16       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+
+# package   noprogn       progn==0                     -             -
+# package   progndrop     progn==1                     -             scalar:qndrop;dfi_scalar:dfi_qndrop
+
+package   rrtmscheme    ra_lw_physics==1             -             -
+package   camlwscheme   ra_lw_physics==3             -             -
+package   rrtmg_lwscheme  ra_lw_physics==4           -             -
+package   goddardlwscheme  ra_lw_physics==5          -             -
+package   gfdllwscheme  ra_lw_physics==99            -             -
+package   hwrflwscheme  ra_lw_physics==98
+
+package   swradscheme   ra_sw_physics==1             -             -
+package   gsfcswscheme  ra_sw_physics==2             -             -
+package   camswscheme   ra_sw_physics==3             -             -
+package   rrtmg_swscheme  ra_sw_physics==4           -             -
+package   goddardswscheme  ra_sw_physics==5          -             -
+package   gfdlswscheme  ra_sw_physics==99            -             -
+package   hwrfswscheme  ra_sw_physics==98
+package   heldsuarez    ra_lw_physics==31            -             -
+
+package   sfclayscheme   sf_sfclay_physics==1        -             -
+package   myjsfcscheme   sf_sfclay_physics==2        -             -
+package   gfssfcscheme   sf_sfclay_physics==3        -             -
+package   gfdlsfcscheme  sf_sfclay_physics==88       -             -
+package   qnsesfcscheme  sf_sfclay_physics==4        -             -
+package   pxsfcscheme    sf_sfclay_physics==7        -             -
+package   temfsfcscheme  sf_sfclay_physics==10       -             -
+package   idealscmsfcscheme  sf_sfclay_physics==89   -             -
+
+package   slabscheme     sf_surface_physics==1       -             -
+package   lsmscheme      sf_surface_physics==2       -             -
+package   ruclsmscheme   sf_surface_physics==3       -             -
+package   gfdlslab       sf_surface_physics==88      -             -
+package   pxlsmscheme    sf_surface_physics==7       -             -
+package   ysuscheme      bl_pbl_physics==1           -             -
+package   myjpblscheme   bl_pbl_physics==2           -             -
+package   gfsscheme      bl_pbl_physics==3           -             -
+package   qnsepblscheme  bl_pbl_physics==4           -             -
+package   acmpblscheme   bl_pbl_physics==7           -             -
+package   boulacscheme   bl_pbl_physics==8           -             - 
+package   camuwpblscheme bl_pbl_physics==9           -             -
+package   mrfscheme      bl_pbl_physics==99          -             -
+package   temfpblscheme  bl_pbl_physics==10          -             -
+
+package   kfetascheme    cu_physics==1               -             -
+package   bmjscheme      cu_physics==2               -             -
+package   gdscheme       cu_physics==3               -             -
+package   sasscheme      cu_physics==4               -             -
+package   g3scheme       cu_physics==5               -             -
+package   camzmscheme    cu_physics==7               -             -
+package   tiedtkescheme  cu_physics==6               -             -
+package   nsasscheme     cu_physics==14              -             -
+package   kfscheme       cu_physics==99              -             -
+
+package   g3shcuscheme   shcu_physics==1             -             -
+package   camuwshcuscheme shcu_physics==2            -             -
+
+package   dfi_setup      dfi_stage==0                -             -
+package   dfi_bck        dfi_stage==1                -             -
+package   dfi_fwd        dfi_stage==2                -             -
+package   dfi_fst        dfi_stage==3                -             -
+package   dfi_startfwd   dfi_stage==4                -             -
+package   dfi_startbck   dfi_stage==5                -             -
+package   dfi_nodfi     dfi_opt==0                  -             -
+package   dfi_dfl       dfi_opt==1                  -            \
+ state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC
+package   dfi_ddfi      dfi_opt==2                  -            \
+ state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC
+package   dfi_tdfi      dfi_opt==3                  -            \
+ state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC
+
+
+# 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:HBM2
+halo HALO_NMM_INIT_2	dyn_nmm 120:HBM3,VBM2,VBM3
+halo HALO_NMM_INIT_3	dyn_nmm 120:SM,SICE
+halo HALO_NMM_INIT_4	dyn_nmm 120: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
+
+#for HWRF: zhang increase halo width to fix feedback bug for HALO_NMM_A (24 => 48)
+#for HWRF: zhang HALO_NMM_C (24 => 48), HALO_NMM_G (24 => 48), HALO_NMM_K (8 => 24)
+halo      HALO_NMM_A  dyn_nmm 48:pd,t,u,v,q,cwm,dwdt,div;48: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 48:u,v                    
+halo      HALO_NMM_D  dyn_nmm 48: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 48:u,v;24:z  
+halo      HALO_NMM_H  dyn_nmm 24:w                  
+halo      HALO_NMM_I  dyn_nmm 48:q,q2,cwm,rrw
+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 24: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
+
+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
+
+halo      HALO_NMM_SAS_A  dyn_nmm 24:uz0h,vz0h,hbm2
+halo      HALO_NMM_SAS_B  dyn_nmm 24:ducudt,dvcudt
+halo      HALO_TRACERS dyn_nmm 48:szj,s1z,spz,tcs
+
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.backup
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.backup	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.backup	(revision 17)
@@ -0,0 +1,2346 @@
+## 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=<variable name>".  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.
+#
+
+include registry.dimspec
+
+################################################################################
+################################################################################
+################################################################################
+
+#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
+#<Table> <Type> <Sym>         <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>
+#
+
+# 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         -     i012rh01d=(interp_fcnm)u=(copy_fcnm)   "LU_INDEX"              "LAND USE CATEGORY"         ""
+state    real  LU_MASK          ij      misc        1         -     i3h1     "LU_MASK"              "0 land 1 water"         ""
+
+# znw, znu, dzs, and zs must be listed before any 3-d fields
+# in order for the grib output module to work correctly.  The grib output
+# module retrieves the vertical levels from these parameters.  If znw, znu
+# dzs, and zs are not listed first, vertical level will not be encoded at 
+# time 0.
+
+state    real    znu            k       dyn_em      1         -     irh       "znu"  "eta values on half (mass) levels"  ""
+state    real    znw            k       dyn_em      1         Z     i0rh     "znw"  "eta values on full (w) levels"  ""
+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"
+
+#
+# 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   prho_gc        igj      dyn_em      1        Z     i1  "PTHETA" "for UM data, from metgrid this is ptheta, but swapped to prho in real" "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   sct_dom_gc     ij       dyn_em      1        -     i1  "SCT_DOM"  "Dominant soil (top) category from GEOGRID"  "cat"
+state    real   scb_dom_gc     ij       dyn_em      1        -     i1  "SCB_DOM"  "Dominant soil (bottom) category from GEOGRID"  "cat"
+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   pdrho_gc       igj      dyn_em      1        Z     -   "PDRHO"    "dry pressure for UM data for the variables U and V"   "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   sh_gc          igj      dyn_em      1        Z     i1  "SPECHUMD"  "Specific humidity"        "kg kg-1"
+state    real   icefrac_gc     ij       dyn_em      1        -     i1  "ICEFRAC"  "Sea ice fraction"  "0 - 1 fraction"
+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"
+state    real   qh_gc          igj      dyn_em      1        Z     i1  "QH"    "hail mixing ratio"   "kg kg-1"
+state    real   qni_gc         igj      dyn_em      1        Z     i1  "QNI"   "ice no concentration"   "m-3"
+
+#-----------------------------------------------------------------------------------------------------------------------------------------------------------------
+#                                               
+# Variables for Eulerian mass coordinate dynamics                                            
+#                                               
+
+
+# Velocities
+#
+# U Vel
+state    real   u              ikjb     dyn_em      2         X     \
+     i0rhusdf=(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      h        "ru_tend"        ""   ""                                   
+i1       real   ru_tendf       ikj     dyn_em      1         X                                          
+state    real   u_save         ikj     dyn_em      1         X      -        "u_save"
+state    real   z_force        |       dyn_em      1         -      i3rh     "Z_FORCE" "height of forcing input" "m"
+state    real   z_force_tend   |       dyn_em      1         -      i3rh     "Z_FORCE_TEND" "tendency height of forcing input" "m"
+state    real   u_g            |       dyn_em      1         -      i3rh     "U_G" "x-direction geostrophic wind" "m s-1"
+state    real   u_g_tend       |       dyn_em      1         -      i3rh     "U_G_TEND" "tendency x-direction geostrophic wind" "m s-1"
+#                                               
+# V Vel
+state    real   v              ikjb     dyn_em      2         Y     \
+     i0rhusdf=(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      h        "rv_tend"
+i1       real   rv_tendf       ikj     dyn_em      1         Y                                          
+state    real   v_save         ikj     dyn_em      1         Y      -        "v_save"                   
+state    real   v_g            |       dyn_em      1         -      i3rh     "V_G" "y-direction geostrophic wind" "m s-1"
+state    real   v_g_tend       |       dyn_em      1         -      i3rh     "V_G_TEND" "tendency y-direction geostrophic wind" "m s-1"
+#                                               
+# 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                                          
+
+state    real   w_subs         |       dyn_em      1         -      i3rh      "W_SUBS" "large-scale vertical velocity" "m s-1"
+state    real   w_subs_tend    |       dyn_em      1         -      i3rh      "W_SUBS_TEND" "tendency large-scale vertical velocity" "m s-1"
+
+# 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         -      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         -     \
+       i0rhusdf=(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         -  
+i1       real   t_2save        ikj     dyn_em      1         -   
+state    real   t_save         ikj     dyn_em      1         -      -        "t_save"
+
+state    real   th_upstream_x       |     dyn_em      1      -      i3rh     "TH_UPSTREAM_X" "upstream theta x-advection" "K s-1"
+state    real   th_upstream_x_tend  |     dyn_em      1      -      i3rh     "TH_UPSTREAM_X_TEND" "tendency upstream theta x-advection" "K s-2"
+state    real   th_upstream_y       |     dyn_em      1      -      i3rh     "TH_UPSTREAM_Y" "upstream theta y-advection" "K s-1"
+state    real   th_upstream_y_tend  |     dyn_em      1      -      i3rh     "TH_UPSTREAM_Y_TEND" "tendency upstream theta y-advection" "K s-2"
+
+state    real   qv_upstream_x       |     dyn_em      1      -      i3rh     "QV_UPSTREAM_X" "upstream qv x-advection" "kg kg-1 s-1"
+state    real   qv_upstream_x_tend  |     dyn_em      1      -      i3rh     "QV_UPSTREAM_X_TEND" "tendency upstream qv x-advection" "kg kg-1 s-2"
+state    real   qv_upstream_y       |     dyn_em      1      -      i3rh     "QV_UPSTREAM_Y" "upstream qv y-advection" "kg kg-1 s-1"
+state    real   qv_upstream_y_tend  |     dyn_em      1      -      i3rh     "QV_UPSTREAM_Y_TEND" "tendency upstream qv y-advection" "kg kg-1 s-2"
+
+state    real   ql_upstream_x       |     dyn_em      1      -      i3rh     "QL_UPSTREAM_X" "upstream ql x-advection" "kg kg-1 s-1"
+state    real   ql_upstream_x_tend  |     dyn_em      1      -      i3rh     "QL_UPSTREAM_X_TEND" "tendency upstream ql x-advection" "kg kg-1 s-2"
+state    real   ql_upstream_y       |     dyn_em      1      -      i3rh     "QL_UPSTREAM_Y" "upstream ql y-advection" "kg kg-1 s-1"
+state    real   ql_upstream_y_tend  |     dyn_em      1      -      i3rh     "QL_UPSTREAM_Y_TEND" "tendency upstream ql y-advection" "kg kg-1 s-2"
+
+state    real   u_upstream_x        |     dyn_em      1      -      i3rh     "U_UPSTREAM_X" "upstream u x-advection" "m s-2"
+state    real   u_upstream_x_tend   |     dyn_em      1      -      i3rh     "U_UPSTREAM_X_TEND" "tendency upstream u x-advection" "m s-3"
+state    real   u_upstream_y        |     dyn_em      1      -      i3rh     "U_UPSTREAM_Y" "upstream u y-advection" "m s-2"
+state    real   u_upstream_y_tend   |     dyn_em      1      -      i3rh     "U_UPSTREAM_Y_TEND" "tendency upstream u y-advection" "m s-3"
+
+state    real   v_upstream_x        |     dyn_em      1      -      i3rh     "V_UPSTREAM_X" "upstream v x-advection" "m s-2"
+state    real   v_upstream_x_tend   |     dyn_em      1      -      i3rh     "V_UPSTREAM_X_TEND" "tendency upstream v x-advection" "m s-3"
+state    real   v_upstream_y        |     dyn_em      1      -      i3rh     "V_UPSTREAM_Y" "upstream v y-advection" "m s-2"
+state    real   v_upstream_y_tend   |     dyn_em      1      -      i3rh     "V_UPSTREAM_Y_TEND" "tendency upstream v y-advection" "m s-3"
+
+state    real   th_largescale       |     dyn_em      1      -      i3rh     "TH_LARGESCALE" "SCM largescale theta" "K"
+state    real   th_largescale_tend  |     dyn_em      1      -      i3rh     "TH_LARGESCALE_TEND" "SCM tendency largescale theta" "K s-1"
+
+state    real   qv_largescale       |     dyn_em      1      -      i3rh     "QV_LARGESCALE" "SCM largescale qv" "kg kg-1 s-1"
+state    real   qv_largescale_tend  |     dyn_em      1      -      i3rh     "QV_LARGESCALE_TEND" "SCM tendency largescale qv" "kg kg-1 s-2"
+
+state    real   ql_largescale       |     dyn_em      1      -      i3rh     "QL_LARGESCALE" "SCM largescale ql" "kg kg-1 s-1"
+state    real   ql_largescale_tend  |     dyn_em      1      -      i3rh     "QL_LARGESCALE_TEND" "SCM tendency largescale ql" "kg kg-1 s-2"
+
+state    real   u_largescale        |     dyn_em      1      -      i3rh     "U_LARGESCALE" "SCM largescale u" "m s-2"
+state    real   u_largescale_tend   |     dyn_em      1      -      i3rh     "U_LARGESCALE_TEND" "SCM tendency largescale u" "m s-3"
+
+state    real   v_largescale        |     dyn_em      1      -      i3rh     "V_LARGESCALE" "SCM largescale v" "m s-2"
+state    real   v_largescale_tend   |     dyn_em      1      -      i3rh     "V_LARGESCALE_TEND" "SCM tendency largescale v" "m s-3"
+
+state    real   tau_largescale       |     dyn_em      1      -      i3rh     "TAU_LARGESCALE" "SCM largescale timescale" "s"
+state    real   tau_largescale_tend  |     dyn_em      1      -      i3rh     "TAU_LARGESCALE_TEND" "SCM tendency largescale timescale" ""
+
+state    real   tau_x               |     dyn_em      1      -      i3rh     "TAU_X" "X-direction advective timescale" "s"
+state    real   tau_x_tend          |     dyn_em      1      -      i3rh     "TAU_X_TEND" "tendency X-direction advective timescale" ""
+state    real   tau_y               |     dyn_em      1      -      i3rh     "TAU_Y" "Y-direction advective timescale" "s"
+state    real   tau_y_tend          |     dyn_em      1      -      i3rh     "TAU_Y_TEND" "tendency Y-direction advective timescale" ""
+
+dimspec  fslay  2     namelist=num_force_soil_layers    z     force_soil_layers
+state    real   t_soil_forcing_val  {fslay}     dyn_em      1      -      i3rh     "T_SOIL_FORCING_VAL" "Soil temp value for SCM forcing" "K"
+state    real   t_soil_forcing_tend {fslay}     dyn_em      1      -      i3rh     "T_SOIL_FORCING_TEND" "tendency soil temp for SCM forcing" "K s-1"
+state    real   q_soil_forcing_val  {fslay}     dyn_em      1      -      i3rh     "Q_SOIL_FORCING_VAL" "Soil moisture value for SCM forcing" "1"
+state    real   q_soil_forcing_tend {fslay}     dyn_em      1      -      i3rh     "Q_SOIL_FORCING_TEND" "tendency soil moisture for SCM forcing" "s-1"
+state    real   tau_soil            {fslay}     dyn_em      1      -      i3rh     "TAU_SOIL" "SCM soil forcing timescale" "s"
+state    real   soil_depth_force    {fslay}     dyn_em      1      -      i3rh     "SOIL_DEPTH_FORCE" "SCM depth at center of soil layers in forcing file" "1"
+
+state    real   hfx_force           -     dyn_em      1      -      i3rh     "HFX_FORCE" "SCM ideal surface sensible heat flux" "W m-2"
+state    real   lh_force            -     dyn_em      1      -      i3rh     "LH_FORCE" "SCM ideal surface latent heat flux" "W m-2"
+state    real   tsk_force           -     dyn_em      1      -      i3rh     "TSK_FORCE" "SCM ideal surface skin temperature" "W m-2"
+state    real   hfx_force_tend      -     dyn_em      1      -      i3rh     "HFX_FORCE_TEND" "SCM ideal surface sensible heat flux tendency" "W m-2 s-1"
+state    real   lh_force_tend       -     dyn_em      1      -      i3rh     "LH_FORCE_TEND" "SCM ideal surface latent heat flux tendency" "W m-2 s-1"
+state    real   tsk_force_tend      -     dyn_em      1      -      i3rh     "TSK_FORCE_TEND" "SCM ideal surface skin temperature tendency" "W m-2 s-1"
+# 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   mub_save        ij     dyn_em      1         -      -           "mub_save" "nest temp, holds orig fine grid mub" "Pa"
+state    real   mu0             ij     dyn_em      1         -      i1          "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         -      irh       "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         -      irhdus    "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    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    t_base         k       dyn_em      1         -     ir        "t_base"               "BASE STATE T IN IDEALIZED CASES"         "K"      
+state    real    z              ikj     dyn_em      1         -     -         " " " " " "
+state    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"  ""
+
+# For the adaptive timestep restart
+state    logical stepping_to_time       - misc    -         -      r     "stepping_to_time"         ""
+state    integer last_step_updated      - misc    -         -      r     "last_step_updated"        ""
+state    logical adapt_step_using_child - misc    -         -      r     "adapt_step_using_child"   ""
+state    integer last_dt_sec            - misc    -         -      r     "last_dt_sec"              "Whole seconds for last timestep"  "sec"
+state    integer last_dt_sec_num        - misc    -         -      r     "last_dt_sec_num"          "Fractional secs, numerator"       "sec"
+state    integer last_dt_sec_den        - misc    -         -      r     "last_dt_sec_den"          "Fractional secs, denominator"     "sec"
+state    integer last_dt_yr             - misc    -         -      r     "last_dt_yr"               "Relative year"                    "years"
+state    integer last_dt_mm             - misc    -         -      r     "last_dt_mm"               "Relative month"                   "months"
+
+# hydrostatic pressure vars
+state    real   p_hyd           ikj     dyn_em      1         -      irh       "p_hyd"       "hydrostatic pressure"         "Pa"
+state    real   p_hyd_w         ikj     dyn_em      1         Z       r        "p_hyd_w"     "hydrostatic pressure at full levels"         "Pa"
+
+# 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         -     i01rhd    "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         -     i01rhd    "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         -      r          "URATX"            "Ratio of U over U10 on mass points "         "dimensionless"
+state    real   vratx           ij      misc        1         -      r          "VRATX"            "Ratio of V over V10 on mass points "         "dimensionless"   
+state    real   tratx           ij      misc        1         -      r          "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"         ""         ""    
+# indicates whether to recompute mu                                                             
+state   logical press_adj      -        -          -         -     -         "press_adj"         "T/F flag adjust mu"         ""    
+
+# 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         -     \
+   i0rhusdf=(bdy_interp:dt)  "QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    qc             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    qr             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    qi             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    qs             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    qg             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+state   real    qh             ikjftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QHAIL"            "Hail mixing ratio"             "kg kg-1"
+state   real    -              ikjftb   dfi_moist       1         -     -    -
+state   real    dfi_qv         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QVAPOR"       "Water vapor mixing ratio"      "kg kg-1"
+state   real    dfi_qc         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QCLOUD"       "Cloud water mixing ratio"      "kg kg-1"
+state   real    dfi_qr         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QRAIN"        "Rain water mixing ratio"       "kg kg-1"
+state   real    dfi_qi         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QICE"         "Ice mixing ratio"              "kg kg-1"
+state   real    dfi_qs         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QSNOW"        "Snow mixing ratio"             "kg kg-1"
+state   real    dfi_qg         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QGRAUP"       "Graupel mixing ratio"          "kg kg-1"
+state   real    dfi_qh         ikjftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QHAIL"        "Hail mixing ratio"             "kg kg-1"
+state    real   rimi             ikj    misc        1         -     irh         "RIMI"           "riming intensity"  "fraction"
+
+
+# LES---------------!JDM
+
+include registry.les
+
+#-------------------
+
+# CAM physics (UW PBL, UW SHCU, ZM CU)
+include registry.cam
+
+# Chem Scalars
+state   real    -              ikjftb   chem        1         -     -    -                                       
+#
+# Tracer Scalars: If you want full resolved and non-resolved dispersion, compile WRF-Chem
+#
+state   real    -          ikjftb  tracer        1         -     -    -                                       
+state   real    tr17_1     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_1"         "tr17_1"          -
+state   real    tr17_2     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_2"         "tr17_2"          -
+state   real    tr17_3     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_3"         "tr17_3"          -
+state   real    tr17_4     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_4"         "tr17_4"          -
+state   real    tr17_5     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_5"         "tr17_5"          -
+state   real    tr17_6     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_6"         "tr17_6"          -
+state   real    tr17_7     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_7"         "tr17_7"          -
+state   real    tr17_8     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_8"         "tr17_8"
+
+# Other Scalars
+state   real    -              ikjftb  scalar      1         -     -   -
+state   real    qndrop         ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNDROP"        "Droplet number mixing ratio"        "# kg-1"
+state   real    qni            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNICE"         "Ice Number concentration" "# kg-1"
+state   real    qt             ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "CWM"           "Total condensate mixing ratio"      "kg kg-1"
+state   real    qns            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNSNOW"         "Snow Number concentration"   "# kg(-1)"
+state   real    qnr            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNRAIN"        "Rain Number concentration"   "# kg(-1)"
+state   real    qng            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNGRAUPEL"     "Graupel Number concentration" "# kg(-1)"
+state   real    qnh            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNHAIL"        "Hail Number concentration" "# kg(-1)"
+
+#state   real    qzr            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZRAIN"        "Rain reflectivity" "# m(6) kg(-1)"
+#state   real    qzi            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZICE"        "Ice reflectivity" "# m(6) kg(-1)"
+#state   real    qzs            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZSNOW"        "Snow reflectivity" "# m(6) kg(-1)"
+#state   real    qzg            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZGRPL"        "Graupel reflectivity" "# m(6) kg(-1)"
+#state   real    qzh            ikjftb  scalar      1         -     \
+#   i0rhusdf=(bdy_interp:dt)    "QZHAIL"        "Hail reflectivity" "# m(6) kg(-1)"
+
+state   real    qnn            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNCCN"         "CCN Number concentration" "# kg(-1)"
+state   real    qnc            ikjftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNCLOUD"       "cloud water Number concentration" "# kg(-1)"
+state   real    -              ikjftb  dfi_scalar      1         -     -   -
+state   real    dfi_qndrop     ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNDROP"    "Droplet number mixing ratio"        "# kg-1"
+state   real    dfi_qni        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNICE"     "Ice Number concentration" "# kg-1"
+state   real    dfi_qt         ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_CWM"       "Total condensate mixing ratio"      "kg kg-1"
+state   real    dfi_qns        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNSNOW"    "Snow Number concentration"   "# kg(-1)"
+state   real    dfi_qnr        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNRAIN"    "Rain Number concentration"   "# kg(-1)"
+state   real    dfi_qng        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)"
+state   real    dfi_qnh        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNHAIL" "Hail Number concentration" "# kg(-1)"
+
+#state   real    dfi_qzr        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZRAIN" "Rain reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzi        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZICE" "Ice reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzs        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZSNOW" "Snow reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzg        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZGRPL" "Graupel reflectivity" "m(6) kg(-1)"
+#state   real    dfi_qzh        ikjftb  dfi_scalar      1         -     \
+#   rusdf=(bdy_interp:dt)    "DFI_QZHAIL" "Hail reflectivity" "m(6) kg(-1)"
+
+state   real    dfi_qnn        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCC"      "CNN Number concentration"   "# kg(-1)"
+state   real    dfi_qnc        ikjftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCLOUD"   "Cloud Number concentration" "# 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   soil_layers    i{lin}j    misc          1     Z     i01r    "SOIL_LAYERS"   "SOIL LAYERS"         "cm"
+state   real   soil_levels    i{lin}j    misc          1     Z     i1      "SOIL_LEVELS"   "SOIL LEVELS"         "cm"
+state   real   st             i{lin}j    misc          1     Z     i01r    "ST"            "SOIL TEMPERATURES"   "K"
+state   real   sm             i{lin}j    misc          1     Z     i01r    "SM"            "SOIL MOISTURES"      "m3 m-3"
+state   real   sw             i{lin}j    misc          1     Z     i01r    "SW"            "SOIL LIQUIDS"        "m3 m-3"
+state   real   soilt          i{lin}j    misc          1     Z     i1      "SOILT"         "RUC SOIL TEMPERATURES"  "K"
+state   real   soilm          i{lin}j    misc          1     Z     i1      "SOILM"         "RUC SOIL MOISTURES"  "m3 m-3"
+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     -     i12rh   "TOPOSTDV"      "ELEVATION STD DEV"  "m"
+state   real   toposlpx            ij    misc          1     -     i012rdu "TOPOSLPX"      "ELEVATION X SLOPE"  ""
+state   real   toposlpy            ij    misc          1     -     i012rdu "TOPOSLPY"      "ELEVATION Y SLOPE"  ""
+state   real   slope               ij    misc          1     -     rdu     "SLOPE"         "ELEVATION SLOPE"  ""
+state   real   slp_azi             ij    misc          1     -     rdu     "SLP_AZI"       "ELEVATION SLOPE AZIMUTH"  "rad"
+state   real   shdmax              ij    misc          1     -     i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)   "SHDMAX"        "ANNUAL MAX VEG FRACTION" ""
+state   real   shdmin              ij    misc          1     -     i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)   "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     i012r   "LANDUSEF"      "LANDUSE FRACTION BY CATEGORY"  ""
+state   real   soilctop            isj   misc          1     Z     i012r   "SOILCTOP"      "SOIL CAT FRACTION (TOP)"  ""
+state   real   soilcbot            isj   misc          1     Z     i012r   "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"
+
+# Time series variables
+state    real   ts_hour         ?!       misc      -         -      -        "TS_HOUR"        "Model integration time, hours"
+state    real   ts_u            ?!       misc      -         -      -        "TS_U"           "Surface wind U-component, earth-relative"
+state    real   ts_v            ?!       misc      -         -      -        "TS_V"           "Surface wind V-component, earth-relative"
+state    real   ts_q            ?!       misc      -         -      -        "TS_Q"           "Surface mixing ratio"
+state    real   ts_t            ?!       misc      -         -      -        "TS_T"           "Surface temperature"
+state    real   ts_psfc         ?!       misc      -         -      -        "TS_PSFC"        "Surface pressure"
+state    real   ts_glw          ?!       misc      -         -      -        "TS_GLW"         "Downward long wave flux at surface"
+state    real   ts_gsw          ?!       misc      -         -      -        "TS_GSW"         "Net short wave flux at surface"
+state    real   ts_hfx          ?!       misc      -         -      -        "TS_HFX"         "Upward heat flux at surface"
+state    real   ts_lh           ?!       misc      -         -      -        "TS_LH"          "Upward moisture flux at surface"
+state    real   ts_tsk          ?!       misc      -         -      -        "TS_TSK"         "Skin temperature"
+state    real   ts_tslb         ?!       misc      -         -      -        "TS_TSLB"        "Soil temperature"
+state    real   ts_clw          ?!       misc      -         -      -        "TS_CLW"         "Column integrated cloud water"
+state    real   ts_rainc        ?!       misc      -         -      -        "TS_RAINC"       "Cumulus precip"
+state    real   ts_rainnc       ?!       misc      -         -      -        "TS_RAINNC"      "Grid-scale precip"
+
+# 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   SMCREL           ilj     -          1         Z     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SMCREL"           "RELATIVE SOIL MOISTURE" ""
+state    real   XICE             ij     misc        1         -     i0124rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm)  "SEAICE"             "SEA ICE FLAG"  ""
+state    real   XICEM            ij     misc        1         -     rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm)  "XICEM"             "SEA ICE FLAG (PREVIOUS STEP)"  ""
+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         -     i024rhd=(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   ACGRDFLX         ij     misc        1         -      rhdu                                       "ACGRDFLX"         "ACCUMULATED GROUND HEAT FLUX" "J 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         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SNOW"             "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real   SNOWH            ij     misc        1         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SNOWH"            "PHYSICAL SNOW DEPTH"      "m"
+#state    real   RHOSN            ij     misc        1         -     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "RHOSN"            " SNOW DENSITY"      "kg m-3" 
+state    real   CANWAT           ij     misc        1         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "CANWAT"           "CANOPY WATER"             "kg m-2"
+state    real   SST              ij     misc        1         -     i0124rhd=(interp_mask_water_field:lu_index,iswater)   "SST"              "SEA SURFACE TEMPERATURE" "K"
+state  integer  IFNDSNOWH        -      misc        1         -     i         "FNDSNOWH" "SNOWH_LOGICAL"
+state  integer  IFNDSOILW        -      misc        1         -     i         "FNDSOILW" "SOILW_LOGICAL"
+# SKIN SST
+state    real   SSTSK            ij     misc        1         -     rhd=(interp_mask_water_field:lu_index,iswater)   "SSTSK"              "SKIN SEA SURFACE TEMPERATURE" "K"
+state    real   DTW              ij     misc        1         -     r   "DTW"              "WARM LAYER TEMP DIFF" "C"
+
+# DFI variables
+state   real   hcoeff         {ndfi} misc        1         -     -    "HCOEFF"               "initialization weights"
+state   real   hcoeff_tot       -    misc        1         -     -    "HCOEFF_TOT"               "initialization weights"
+state   real   dfi_p           ikj   misc        1         -     r    "P_DFI"           "perturbation pressure"         "Pa"
+state   real   dfi_al          ikj   misc        1         -     r    "AL_DFI"          "inverse perturbation density"  "m3 kg-1"
+state   real   dfi_mu          ij    misc        1         -     r    "MU_DFI"  "perturbation dry air mass in column" "Pa"
+state   real   dfi_phb         ikj   misc        1         Z     r    "PHB_DFI"  "base-state geopotential"  "m2 s-2"
+state   real   dfi_ph0         ikj   misc        1         Z     r    "PH0_DFI"  "initial geopotential"     "m2 s-2"
+state   real   dfi_php         ikj   misc        1         Z     r    "PHP_DFI"  "geopotential"             "m2 s-2"
+state   real   dfi_u           ikj   misc        1         -     r    "U_DFI"               "u accumulation array"          "   "
+state   real   dfi_v           ikj   misc        1         -     r    "V_DFI"               "v accumulation array"          "   "
+state   real   dfi_w           ikj   misc        1         -     r    "W_DFI"               "w accumulation array"          "   "
+state   real   dfi_ww          ikj   misc        1         Z     r    "WW_DFI"              "mu-coupled eta-dot"    "Pa s-1"
+state   real   dfi_t           ikj   misc        1         -     r    "TT_DFI"               "t accumulation array"          "   "
+state   real   dfi_rh          ikj   misc        1         -     r    "RH_DFI"               "initial relative humidity"     "   "
+state   real   dfi_ph          ikj   misc        1         -     r    "PH_DFI"               "p accumulation array"          "   "
+state   real   dfi_pb          ikj   misc        1         -     r    "PB_DFI"               "pb accumulation array"          "   "
+state   real   dfi_alt         ikj   misc        1         -     r    "ALT_DFI"             "1/rho accumulation array"          "   "
+state   real   dfi_tke         ikj   misc        1         -     r    "TKE_DFI"          "TURBULENCE KINETIC ENERGY"     "m2 s-2"
+state   real   dfi_tten_rad    ikj   misc        1         -     irh  "RAD_TTEN_DFI"     "RADAR POT. TEMP. TENDENCY"     "K s-1"
+state    real  dfi_TSLB        ilj   misc        1         Z     r    "TSLB_dfi"         "SOIL TEMPERATURE"   "K"
+state    real  dfi_SMOIS       ilj    -          1         Z     r    "SMOIS_dfi"        "SOIL MOISTURE"     "m3 m-3"
+state    real  dfi_SNOW        ij    misc        1         -     r    "SNOW_dfi"         "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real  dfi_SNOWH       ij    misc        1         -     r    "SNOWH_dfi"        "PHYSICAL SNOW DEPTH"      "m"
+state    real  dfi_CANWAT      ij    misc        1         -     r    "CANWAT_dfi"       "CANOPY WATER"             "kg m-2"
+state    real  dfi_SMFR3D      ilj   misc        1         Z     r    "SMFR3D_dfi"           "SOIL ICE" ""
+state    real  dfi_KEEPFR3DFLAG ilj  misc        1         Z     r    "KEEPFR3DFLAG_dfi"     "FLAG - 1. FROZEN SOIL YES, 0 - NO"             ""
+
+# 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"
+state    real   TRB_URB4D       i{ulay}j    misc       1         Z     r      "TRB_URB4D" "ROOF LAYER TEMPERATURE"          "K"
+state    real   TW1_URB4D       i{ulay}j    misc       1         Z     r      "TW1_URB4D" "WALL LAYER TEMPERATURE"          "K"
+state    real   TW2_URB4D       i{ulay}j    misc       1         Z     r      "TW2_URB4D" "WALL LAYER TEMPERATURE"          "K"
+state    real   TGB_URB4D       i{ulay}j    misc       1         Z     r      "TGB_URB4D" "ROAD LAYER TEMPERATURE"          "K"
+state    real   TLEV_URB3D      i{ulay}j    misc       1         Z     r      "TLEV_URB3D" "INDOOR TEMPERATURE"             "K"
+state    real   QLEV_URB3D      i{ulay}j    misc       1         Z     r      "QLEV_URB3D" "SPECIFIC HUMIDITY"              "dimensionless"
+state    real   TW1LEV_URB3D    i{ulay}j    misc       1         Z     r      "TW1LEV_URB3D" "WINDOW TEMPERATURE"           "K"
+state    real   TW2LEV_URB3D    i{ulay}j    misc       1         Z     r      "TW2LEV_URB3D" "WINDOW TEMPERATURE"           "K"
+state    real   TGLEV_URB3D     i{ulay}j    misc       1         Z     r      "TGLEV_URB3D" "GROUND TEMPERATURE BELOW A BUILDING"     "K"
+state    real   TFLEV_URB3D     i{ulay}j    misc       1         Z     r      "TFLEV_URB3D" "FLOOR TEMPERATURE"                       "K"
+state    real   SF_AC_URB3D     ij          misc       1         -     r      "SF_AC_URB3D"  "SENSIBLE HEAT FLUX FROM THE AIR COND." "W m{-2}"
+state    real   LF_AC_URB3D     ij          misc       1         -     r      "LF_AC_URB3D"  "LATENT HEAT FLUX FROM THE AIR COND." "W m{-2}"
+state    real   CM_AC_URB3D     ij          misc       1         -     r      "CM_AC_URB3D"  "CONSUMPTION OF THE AIR COND." "W m{-2}"
+state    real   SFVENT_URB3D    ij          misc       1         -     r      "SFVENT_URB3D" "SENSIBLE HEAT FLUX FROM URBAN VENTILATION" "W m{-2}"
+state    real   LFVENT_URB3D    ij          misc       1         -     r      "LFVENT_URB3D" "LATENT HEAT FLUX FROM URBAN VENTILATION" "W m{-2}"
+state    real   SFWIN1_URB3D    i{ulay}j    misc       1         Z     r      "SFWIN1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW"  "W m{-2}"
+state    real   SFWIN2_URB3D    i{ulay}j    misc       1         Z     r      "SFWIN2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW"  "W m{-2}"
+state    real   SFW1_URB3D      i{ulay}j    misc       1         Z     r      "SFW1_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFW2_URB3D      i{ulay}j    misc       1         Z     r      "SFW2_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFR_URB3D       i{ulay}j    misc       1         Z     r      "SFR_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFG_URB3D       i{ulay}j    misc       1         Z     r      "SFG_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   CMR_SFCDIF      ij          misc       1         -     r      "CMR_SFCDIF" "" ""
+state    real   CHR_SFCDIF      ij          misc       1         -     r      "CHR_SFCDIF" "" ""
+state    real   CMC_SFCDIF      ij          misc       1         -     r      "CMC_SFCDIF" "" ""
+state    real   CHC_SFCDIF      ij          misc       1         -     r      "CHC_SFCDIF" "" ""
+
+
+# solar location variables from radiation driver
+state    real   COSZEN           ij     misc        1         -      r       "COSZEN"  "COS of SOLAR ZENITH ANGLE"     "dimensionless"
+state    real   HRANG            ij     misc        1         -      r       "HRANG"   "SOLAR HOUR ANGLE"          "radians"
+state    real   DECLIN            -     misc        1         -      r       "DECLIN"  "SOLAR DECLINATION"         "radians"
+state    real   SOLCON            -     misc        1         -      r       "SOLCON"  "SOLAR CONSTANT"         "W m-2"
+
+
+# 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"             ""
+
+# Additional for P-X PBL and LSM
+state    real   RA               ij     misc        1         -      r        "RA"           "AERODYNAMIC RESISTANCE"   "s m-1"
+state    real   RS               ij     misc        1         -      r        "RS"           "SURFACE RESISTANCE"       "s m-1"
+state    real   LAI              ij     misc        1         -      i0124rh       "LAI"          "Leaf area index"          "area/area"
+state    real   VEGF_PX          ij     misc        1         -      r        "VEGF_PX"      "Vegetation Fraction for PX LSM"    "area/area"
+state    real   T2OBS            ij     misc        1         -      r        "T2OBS"        "2-m temperature from analysis "          "K"
+state    real   Q2OBS            ij     misc        1         -      r        "Q2OBS"        "2-m mixing ratio from analysis "         "kg/kg"
+
+# 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   EXCH_H          ikj     misc        1         -     r          "EXCH_H"               "SCALAR EXCHANGE COEFFICIENTS "
+state    real   EXCH_M          ikj     misc        1         -     r          "EXCH_M"               "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"                             ""
+state   real   TSHLTR           ij     misc        1         -      r        "TSHLTR"                "SHELTER THETA FROM MYJ"                       "K"
+state   real   QSHLTR           ij     misc        1         -      r        "QSHLTR"                "SHELTER SPECIFIC HUMIDITY FROM MYJ"           "kg kg-1"
+state   real   PSHLTR           ij     misc        1         -      r        "PSHLTR"                "SHELTER PRESSURE FROM MYJ"           "Pa"
+state   real   TH10             ij     misc        1         -      r        "TH10"                  "10-M THETA FROM MYJ"                          "K"
+state   real   Q10              ij     misc        1         -      r        "Q10"                   "10-M SPECIFIC HUMIDITY FROM MYJ"              "kg kg-1"
+i1      real   CHKLOWQ          ij     misc        1         -     -         "CHKLOWQ"               "SURFACE SATURATION FLAG"        ""
+
+# TEMF PBL variables
+state    real   te_temf        ikj     misc        1         -      rh        "te_temf"               "Total energy from TEMF PBL scheme"      "m2 s-2"
+state    real   kh_temf        ikj     misc        1         -     rh          "kh_temf"               "Diffusion coefficient for heat from TEMF PBL"
+state    real   km_temf        ikj     misc        1         -     rh          "km_temf"               "Diffusion coefficient for momentum from TEMF PBL"
+state    real   shf_temf       ikj     misc        1         -     rh          "shf_temf"              "Sensible heat flux from TEMF PBL"      "K m s-1"
+state    real   qf_temf        ikj     misc        1         -     rh          "qf_temf"              "Sensible heat flux from TEMF PBL"       "kg/kg m s-1"
+state    real   uw_temf        ikj     misc        1         -     rh          "uw_temf"              "U momentum flux from TEMF PBL"       "m2 s-2"
+state    real   vw_temf        ikj     misc        1         -     rh          "vw_temf"              "V momentum flux from TEMF PBL"       "m2 s-2"
+state    real   wupd_temf      ikj     misc        1         -     rh          "wupd_temf"            "Updraft velocity from TEMF PBL"      "m s-1"
+state    real   mf_temf        ikj     misc        1         -     rh          "mf_temf"              "Mass flux from TEMF PBL"             "m s-1"
+state    real   thup_temf      ikj     misc        1         -     rh          "thup_temf"            "Updraft thetal from TEMF PBL"        "K"
+state    real   qtup_temf      ikj     misc        1         -     rh          "qtup_temf"            "Updraft qt from TEMF PBL"        "1"
+state    real   qlup_temf      ikj     misc        1         -     rh          "qlup_temf"            "Updraft ql (liquid water) from TEMF PBL"        "1"
+state    real   cf3d_temf      ikj     misc        1         -     rh          "cf3d_temf"            "3D Cloud fraction from TEMF PBL"        "1"
+state    real   hd_temf        ij      misc        1         -     rh          "hd_temf"              "Dry thermal top height from TEMF PBL"       "m"
+state    real   lcl_temf       ij      misc        1         -     rh          "lcl_temf"             "Lifting condensation level from TEMF PBL"       "m"
+state    real   hct_temf       ij      misc        1         -     rh          "hct_temf"             "Cloud top height from TEMF PBL"       "m"
+state    real   cfm_temf       ij      misc        1         -     rh          "cfm_temf"            "Column cloud fraction from TEMF PBL"        "1"
+state    real   wm_temf        ij      misc        1         -     rh        "wm_temf"               "Velocity scale in TEMF surface layer scheme"      "m s-1"
+
+# MYNN PBL variables
+state   real   qke             ikjftb  scalar      1         -      i0rhusdf=(bdy_interp:dt) "qke"               "twice TKE FROM MYNN"      "m2 s-2"
+state   real   tsq             ikj     misc        1         -      r        "tsq"               "liquid water pottemp variance"      "K2"
+state   real   qsq             ikj     misc        1         -      r        "qsq"               "liquid water variance"      "(kg/kg)**2"
+state   real   cov             ikj     misc        1         -      r        "cov"               "liquid water-liquid water pottemp covaria\
+nce"      "K kg/kg"
+state   real   ch               ij     misc        1         -      -        "ch"                "drag coeff for heat"    ""
+#state   real   K_m             ikj     misc        1         -     -          "K_m"               "EXCHANGE COEFFICIENT for momentum "
+#state   real   K_h             ikj     misc        1         -     -          "K_h"               "EXCHANGE COEFFICIENT for heat "
+#state   real   K_q             ikj     misc        1         -     -          "K_q"               "EXCHANGE COEFFICIENT for qke "
+
+# Additional for gravity wave drag
+state   real   DTAUX3D         ikj     misc        1         -     rh        "DTAUX3D"               "LOCAL U GWDO STRESS"   "m s-1"
+state   real   DTAUY3D         ikj     misc        1         -     rh        "DTAUY3D"               "LOCAL V GWDO STRESS"   "m s-1"
+state   real   DUSFCG           ij     misc        1         -     rh        "DUSFCG"                "COLUMN-INTEGRATED U GWDO STRESS"   "Pa m s-1"
+state   real   DVSFCG           ij     misc        1         -     rh        "DVSFCG"                "COLUMN-INTEGRATED V GWDO STRESS"   "Pa m s-1"
+state   real   VAR2D            ij     misc        1         -     i012rhdus "VAR"                   "OROGRAPHIC VARIANCE"   ""   ""
+state   real   OC12D            ij     misc        1         -     i012rhdus "CON"                   "OROGRAPHIC CONVEXITY"   ""   ""
+state   real   OA1              ij     misc        1         -     i012rhdus "OA1"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA2              ij     misc        1         -     i012rhdus "OA2"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA3              ij     misc        1         -     i012rhdus "OA3"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA4              ij     misc        1         -     i012rhdus "OA4"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL1              ij     misc        1         -     i012rhdus "OL1"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL2              ij     misc        1         -     i012rhdus "OL2"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL3              ij     misc        1         -     i012rhdus "OL3"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL4              ij     misc        1         -     i012rhdus "OL4"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+
+# BEP urban scheme  variables
+state    real    a_u_bep       ikj     misc        1         Z      -        "a_u_bep"               "IMPLICIT FOR X-COMP."      "s-1"
+state    real    a_v_bep       ikj     misc        1         Z      -        "a_v_bep"               "IMPLICIT FOR Y-COMP."      "s-1"
+state    real    a_t_bep       ikj     misc        1         Z      -        "a_t_bep"               "IMPLICIT FOR Pot. Temp"    "s-1"
+state    real    a_q_bep       ikj     misc        1         Z      -        "a_q_bep"               "IMPLICIT FOR Moisture"     "s-1"
+state    real    a_e_bep       ikj     misc        1         Z      -        "a_e_bep"               "IMPLICIT FOR TKE"          "s-1"
+state    real    b_u_bep       ikj     misc        1         Z      -        "b_u_bep"               "EXPLICIT FOR X-COMP."      "m s-2"
+state    real    b_v_bep       ikj     misc        1         Z      -        "b_v_bep"               "EXPLICIT FOR Y-COMP."      "m s-2"
+state    real    b_t_bep       ikj     misc        1         Z      -        "b_t_bep"               "EXPLICIT FOR Pot. Temp"    "K s-1"
+state    real    b_q_bep       ikj     misc        1         Z      -        "b_q_bep"               "EXPLICIT FOR Moisture"     "kg s-1"
+state    real    b_e_bep       ikj     misc        1         Z      -        "b_e_bep"               "EXPLICIT FOR TKE"          "m2 s-3"
+state    real    dlg_bep       ikj     misc        1         Z      -        "dlg_bep"               "length scale 1"            "m"
+state    real    dl_u_bep      ikj     misc        1         Z      -        "dl_u_bep"              "urban length scale"        "m"
+state    real    sf_bep        ikj     misc        1         Z      -        "sf_bep"                "surface grid"              "-"
+state    real    vl_bep        ikj     misc        1         Z      -        "vl_bep"                "volume grid"               "-"
+# BOULAC PBL variables
+state    real   tke_pbl        ikj     misc        1         -      rh        "tke_pbl"               "TKE FROM Bougeault and Lacarrere"      "m2 s-2"
+state    real   el_pbl        ikj     misc        1         -       h        "el_pbl"               "Length scale FROM Bougeault and Lacarrere"      "m"
+# Diagnostic PBL variables
+state    real   wu_tur         ikj     misc        1         -      r        "wu_tur"               "Turbulent flux of momentum(x)"      "m2 s-2"
+state    real   wv_tur         ikj     misc        1         -      r        "wv_tur"               "Turbulent flux of momentum(y)"      "m2 s-2"
+state    real   wt_tur         ikj     misc        1         -      r        "wt_tur"               "Turbulent flux of temperature"      "K m s-1"
+state    real   wq_tur         ikj     misc        1         -      r        "wq_tur"               "Turbulent flux of water vapor"      "- m s-1"
+
+# 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         -      -
+state    real   rlwtoa           ij     misc        1         -      -
+state    real   czmean           ij     misc        1         -      -
+state    real   cfracl           ij     misc        1         -      -
+state    real   cfracm           ij     misc        1         -      -
+state    real   cfrach           ij     misc        1         -      -
+state    real   acfrst           ij     misc        1         -      -
+state integer   ncfrst           ij     misc        1         -      -
+state    real   acfrcv           ij     misc        1         -      -
+state integer   ncfrcv           ij     misc        1         -      -
+
+# cam radiation variables
+state  real    -       i{ls}jf ozmixm      1    -   -     -
+state  real   mth01    i{ls}jf ozmixm      1    -   -     -
+state  real   mth02    i{ls}jf ozmixm      1    -   -     -
+state  real   mth03    i{ls}jf ozmixm      1    -   -     -
+state  real   mth04    i{ls}jf ozmixm      1    -   -     -
+state  real   mth05    i{ls}jf ozmixm      1    -   -     -
+state  real   mth06    i{ls}jf ozmixm      1    -   -     -
+state  real   mth07    i{ls}jf ozmixm      1    -   -     -
+state  real   mth08    i{ls}jf ozmixm      1    -   -     -
+state  real   mth09    i{ls}jf ozmixm      1    -   -     -
+state  real   mth10    i{ls}jf ozmixm      1    -   -     -
+state  real   mth11    i{ls}jf ozmixm      1    -   -     -
+state  real   mth12    i{ls}jf ozmixm      1    -   -     -
+state  real   pin       {ls}     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 microphysics State Variables
+state   real    F_ICE_PHY      ikj     misc         1         -      rhdu     "F_ICE_PHY"            "FRACTION OF ICE"         ""
+state   real    F_RAIN_PHY     ikj     misc         1         -      rhdu     "F_RAIN_PHY"           "FRACTION OF RAIN "         ""
+state   real    F_RIMEF_PHY    ikj     misc         1         -      rhdu     "F_RIMEF_PHY"          "MASS RATIO OF RIMED ICE "         ""
+state   real    qndropsource   ikj     misc         1         -      -        "qndropsource"         "Droplet number source"   "#/kg/s"
+
+# Other Misc State Variables                                            
+state   real    h_diabatic     ikj     misc         1         -      rhdu     "h_diabatic"            "MICROPHYSICS LATENT HEATING"         "K s-1"      
+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    msftx          ij      misc         1         -     i012rhdu=(copy_fcnm)    "MAPFAC_MX"         "Map scale factor on mass grid, x direction" ""
+state   real    msfty          ij      misc         1         -     i012rhdu=(copy_fcnm)    "MAPFAC_MY"         "Map scale factor on mass grid, y direction" ""
+state   real    msfux          ij      misc         1         X     i012rhdu=(copy_fcnm)    "MAPFAC_UX"         "Map scale factor on u-grid, x direction" ""
+state   real    msfuy          ij      misc         1         X     i012rhdu=(copy_fcnm)    "MAPFAC_UY"         "Map scale factor on u-grid, y direction" ""
+state   real    msfvx          ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MAPFAC_VX"         "Map scale factor on v-grid, x direction" ""
+state   real    msfvx_inv      ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MF_VX_INV"         "Inverse map scale factor on v-grid, x direction" ""
+state   real    msfvy          ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MAPFAC_VY"         "Map scale factor on v-grid, y direction" ""
+
+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    ht_shad        ijb     misc         1         -     df=(bdy_interp:dt)         "HGT_SHAD"        "Height of orographic shadow"   "m"
+i1      real    ht_loc         ij      misc         1         -     - 
+state   integer  shadowmask    ij      misc         1         -     - 
+state   integer min_ptchsz     -       misc         1         -     r
+
+state   real    TSK            ij      misc         1         -     i012rhdu=(copy_fcnm)    "TSK"                   "SURFACE SKIN TEMPERATURE"                  "K"
+state   real    dfi_TSK        ij      misc         1         -     r                       "TSK_dfi"               "saved SURFACE SKIN TEMPERATURE"
+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    t00            -       misc         -         -     i02rh     "t00"                   "BASE STATE TEMPERATURE   "  "K"
+state   real    p00            -       misc         -         -     i02rh     "p00"                   "BASE STATE PRESURE"         "Pa"
+state   real    tlp            -       misc         -         -     i02rh     "tlp"                   "BASE STATE LAPSE RATE    "  ""
+state   real    tiso           -       misc         -         -     i02rh     "tiso"                  "TEMP AT WHICH THE BASE T TURNS CONST"  "K"
+state   real    max_msftx      -       misc         -         -      rh       "max_mstfx"             "Max map factor in domain"  ""
+state   real    max_msfty      -       misc         -         -      rh       "max_mstfy"             "Max map factor in domain"  ""
+
+# State variables for Goddard LW and SW radiation  
+state    real  TLWDN           ij      misc        1         -      h         "TLWDN"                 "TOA LW downwelling flux"           "W m-2"
+state    real  TLWUP           ij      misc        1         -      h         "TLWUP"                 "TOA LW upwelling flux"             "W m-2"
+state    real  SLWDN           ij      misc        1         -      h         "SLWDN"                 "Surface LW downwelling flux"       "W m-2"
+state    real  SLWUP           ij      misc        1         -      h         "SLWUP"                 "Surface LW upwelling flux"         "W m-2"
+state    real  TSWDN           ij      misc        1         -      h         "TSWDN"                 "TOA SW downwelling flux"           "W m-2"
+state    real  TSWUP           ij      misc        1         -      h         "TSWUP"                 "TOA SW upwelling flux"             "W m-2"
+state    real  SSWDN           ij      misc        1         -      h         "SSWDN"                 "Surface SW downwelling flux"       "W m-2"
+state    real  SSWUP           ij      misc        1         -      h         "SSWUP"                 "Surface SW upwelling flux"         "W m-2"
+
+# Other physics variables
+
+state    real  RUSHTEN         ikj      misc        1         -      r        "RUSHTEN"               "COUPLED X WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME"   "Pa m s-2"
+state    real  RVSHTEN         ikj      misc        1         -      r        "RVSHTEN"               "COUPLED Y WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME"   "Pa m s-2"
+state    real  RTHSHTEN        ikj      misc        1         -      r        "RTHSHTEN"              "COUPLED THETA TENDENCY DUE TO SHALLOW CUMULUS SCHEME"    "Pa K s-1"
+state    real  RQVSHTEN        ikj      misc        1         -      r        "RQVSHTEN"              "COUPLED Q_V TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQRSHTEN        ikj      misc        1         -      r        "RQRSHTEN"              "COUPLED Q_R TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQCSHTEN        ikj      misc        1         -      r        "RQCSHTEN"              "COUPLED Q_C TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQSSHTEN        ikj      misc        1         -      r        "RQSSHTEN"              "COUPLED Q_S TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQISHTEN        ikj      misc        1         -      r        "RQISHTEN"              "COUPLED Q_I TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQGSHTEN        ikj      misc        1         -      r        "RQGSHTEN"              "COUPLED Q_G TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+
+state    real  RUCUTEN         ikj      misc        1         -      r        "RUCUTEN"               "COUPLED X WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION"  "Pa m s-2"
+state    real  RVCUTEN         ikj      misc        1         -      r        "RVCUTEN"               "COUPLED Y WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION"  "Pa m s-2"
+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  RAINSH           ij      misc        1         -      rhdu     "RAINSH"                "ACCUMULATED SHALLOW CUMULUS PRECIPITATION"               "mm"
+state    real  RAINNC           ij      misc        1         -      rhdu     "RAINNC"                "ACCUMULATED TOTAL GRID SCALE PRECIPITATION"              "mm"
+state  integer I_RAINC          ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_RAINC"            "BUCKET FOR RAINC"                    ""
+state  integer I_RAINNC         ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_RAINNC"           "BUCKET FOR RAINNC"                   ""
+state    real  PRATEC           ij      misc        1         -      r        "PRATEC"                "PRECIP RATE FROM CUMULUS SCHEME"                         "mm s-1"
+state    real  PRATESH          ij      misc        1         -      r        "PRATESH"               "PRECIP RATE FROM SHALLOW CUMULUS SCHEME"                 "mm s-1"
+state    real  RAINCV           ij      misc        1         -      r        "RAINCV"                "TIME-STEP CUMULUS PRECIPITATION"                         "mm"
+state    real  RAINSHV          ij      misc        1         -      r        "RAINSHV"               "TIME-STEP SHALLOW 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  HAILNC           ij      misc        1         -      rhdu     "HAILNC"                "ACCUMULATED TOTAL GRID SCALE HAIL"                       "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  HAILNCV          ij      misc        1         -      r        "HAILNCV"               "TIME-STEP NONCONVECTIVE HAIL"                            "mm"
+state    real    refl_10cm      ikj     dyn_em      1         -     hdu     "refl_10cm" "Radar reflectivity (lamda = 10 cm)"  "dBZ"
+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  edt_out          ij      misc        1         -      -        "EDT_OUT"             "EDT FROM GD SCHEME"             ""
+state    real  xmb_shallow      ij      misc        1         -      rh       "XMB_SHALLOW"             "MASSFLUX FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  k22_shallow   ij      misc        1         -      rh       "K22_SHALLOW"             "K22 LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  kbcon_shallow   ij      misc        1         -    rh       "KBCON_SHALLOW"             "KBCON LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  ktop_shallow   ij      misc        1         -     rh       "KTOP_SHALLOW"             "KTOP LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  k22_deep     ij      misc        1         -      h       "K22_DEEP"             "K22 LEVEL FROM DEEPCONVECTION (G3 only)"             ""
+state    integer  kbcon_deep     ij      misc        1         -    h       "KBCON_DEEP"             "KBCON LEVEL FROM DEEP CONVECTION (G3 only)"             ""
+state    integer  ktop_deep     ij      misc        1         -     h       "KTOP_DEEP"             "KTOP LEVEL FROM DEEP CONVECTION (G3 only)"             ""
+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  cugd_tten        ikj     misc        1         -      r        "CUGD_TTEN"             "INITIAL TTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qvten       ikj     misc        1         -      r        "CUGD_QVTEN"            "INITIAL QTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_ttens       ikj     misc        1         -      r        "CUGD_TTENS"            "INITIAL SUBSIDENCE TTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qvtens      ikj     misc        1         -      r        "CUGD_QVTENS"           "INITIAL SUBSIDNCE QTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qcten       ikj     misc        1         -      r        "CUGD_QCTEN"            "INITIAL TEMPERATURE TENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-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"
+state    real  GD_CLDFR         ikj      misc        1         -      rh     "GD_CLDFR"              "GD CLOUD Fraction"         " ? "
+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 integer  STEPAVE_COUNT     -        misc        1         -      rh      "STEPAVE_COUNT"        "time steps contained in averages for convective transport" ""
+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"              "UNCOUPLED THETA TENDENCY DUE TO LONG WAVE RADIATION"    "K s-1"
+state    real  RTHRATENSW      ikj      misc        1         -      r        "RTHRATSW"              "UNCOUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION"   "K s-1"
+state    real  CLDFRA          ikj      misc        1         -      rh       "CLDFRA"                "CLOUD FRACTION"                                       ""
+state    real  CLDFRA_OLD      ikj      misc        1         -      r        "CLDFRA_OLD"            "previous time level cldfra"                           ""
+
+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"      
+state    real  SWNORM           ij      misc        1         -      rhd      "SWNORM"                "NORMAL SHORT WAVE FLUX AT GROUND SURFACE (SLOPE-DEPENDENT)"           "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 integer  I_ACSWUPT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPT"     "BUCKET FOR UPWELLING SHORTWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACSWUPTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPTC"    "BUCKET FOR UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACSWDNT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNT"     "BUCKET FOR DOWNWELLING SHORTWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACSWDNTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNTC"    "BUCKET FOR DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACSWUPB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPB"     "BUCKET FOR UPWELLING SHORTWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACSWUPBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPBC"    "BUCKET FOR UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACSWDNB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNB"     "BUCKET FOR DOWNWELLING SHORTWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACSWDNBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNBC"    "BUCKET FOR DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACLWUPT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPT"     "BUCKET FOR UPWELLING LONGWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACLWUPTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPTC"    "BUCKET FOR UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACLWDNT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNT"     "BUCKET FOR DOWNWELLING LONGWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACLWDNTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNTC"    "BUCKET FOR DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACLWUPB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPB"     "BUCKET FOR UPWELLING LONGWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACLWUPBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPBC"    "BUCKET FOR UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACLWDNB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNB"     "BUCKET FOR DOWNWELLING LONGWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACLWDNBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNBC"    "BUCKET FOR DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2"
+state    real  SWUPT            ij      misc        1         -      rhdu     "SWUPT"                 "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP"          "W m-2"
+state    real  SWUPTC           ij      misc        1         -      rhdu     "SWUPTC"                "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2"
+state    real  SWDNT            ij      misc        1         -      rhdu     "SWDNT"                 "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP"          "W m-2"
+state    real  SWDNTC           ij      misc        1         -      rhdu     "SWDNTC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2"
+state    real  SWUPB            ij      misc        1         -      rhdu     "SWUPB"                 "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  SWUPBC           ij      misc        1         -      rhdu     "SWUPBC"                "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2"
+state    real  SWDNB            ij      misc        1         -      rhdu     "SWDNB"                 "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  SWDNBC           ij      misc        1         -      rhdu     "SWDNBC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2"
+state    real  LWUPT            ij      misc        1         -      rhdu     "LWUPT"                 "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP"          "W m-2"
+state    real  LWUPTC           ij      misc        1         -      rhdu     "LWUPTC"                "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2"
+state    real  LWDNT            ij      misc        1         -      rhdu     "LWDNT"                 "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP"          "W m-2"
+state    real  LWDNTC           ij      misc        1         -      rhdu     "LWDNTC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2"
+state    real  LWUPB            ij      misc        1         -      rhdu     "LWUPB"                 "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  LWUPBC           ij      misc        1         -      rhdu     "LWUPBC"                "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W m-2"
+state    real  LWDNB            ij      misc        1         -      rhdu     "LWDNB"                 "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  LWDNBC           ij      misc        1         -      rhdu     "LWDNBC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W 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  CLAT             ij      misc        1         -     i012rdu=(copy_fcnm)          "CLAT"                "COMPUTATIONAL GRID LATITUDE, SOUTH IS NEGATIVE"                       "degree_north"
+state    real  CLONG            ij      misc        1         -     i012rdu=(copy_fcnm)          "CLONG"               "COMPUTATIONAL GRID LONGITUDE, WEST IS NEGATIVE"                       "degree_east"
+state    real  ALBBCK           ij      misc        1         -     i0124rh   "ALBBCK"                "BACKGROUND ALBEDO"        ""
+state    real  EMBCK            ij      misc        1         -      r        "EMBCK"                 "BACKGROUND EMISSIVITY"         ""
+state    real  EMISS            ij      misc        1         -      rh       "EMISS"                 "SURFACE EMISSIVITY"         "" 
+state    real  SNOTIME          ij      misc        1         -      r        "SNOTIME"               "SNOTIME"         "" 
+state    real  NOAHRES          ij      misc        1         -      h        "NOAHRES"               "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}"
+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         -                                          
+state    real  t_phy           ikj      misc        1         -      r      "T_PHY"                        "Temperature"         "K"           
+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  TYR              ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TYR"        "ANNUAL MEAN SFC TEMPERATURE"           "K"
+state    real  TYRA             ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TYRA"   "ACCUMULATED YEARLY SFC TEMPERATURE FOR CURRENT YEAR"  "K"
+state    real  TDLY             ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TDLY"     "ACCUMULATED DAILY SFC TEMPERATURE FOR CURRENT DAY"  "K"
+state    real  TLAG             i&j     misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TLAG"         "DAILY MEAN SFC TEMPERATURE OF PRIOR DAYS"       "K"
+state    integer NYEAR          -       misc        1         -     r        "NYEAR"                  "ACCUM DAYS IN A YEAR"                         ""
+state    real    NDAY           -       misc        1         -     r        "NDAY"                  "ACCUM TIMESTEPS IN A DAY"                      ""
+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         -      i3rh     "ZNT"                   "TIME-VARYING ROUGHNESS LENGTH"                "m"      
+state    real  CK               ij      misc        1         -      r        "CK"                    "ENTHALPY EXCHANGE COEFF AT 10 m"                      ""
+state    real  CKA              ij      misc        1         -      r        "CKA"                   "ENTHALPY EXCHANGE COEFF AT LOWEST MODEL LVL"          ""
+state    real  CD               ij      misc        1         -      r        "CD"                    "DRAG COEFF AT 10m"                      ""
+state    real  CDA              ij      misc        1         -      r        "CDA"                   "DRAG COEFF AT LOWEST MODEL LVL"                      ""
+state    real  UST              ij      misc        1         -      rh       "UST"                   "U* IN SIMILARITY THEORY"                      "m s-1"      
+state    real  USTM             ij      misc        1         -      r        "USTM"                  "U* IN SIMILARITY THEORY WITHOUT VCONV"        "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  ACHFX            ij      misc        1         -      rhdu     "ACHFX"                 "ACCUMULATED UPWARD HEAT FLUX AT THE SURFACE"  "J m-2"
+state    real  ACLHF            ij      misc        1         -      rhdu     "ACLHF"                 "ACCUMULATED UPWARD LATENT HEAT FLUX AT THE SURFACE"  "J 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  dfi_QVG          ij      misc        1         -      r        "QVG_dfi"               "WATER VAPOR MIXING RATIO AT THE SURFACE"      "kg kg-1"
+state    real  QCG              ij      misc        1         -      r        "QCG"                   "CLOUD WATER MIXING RATIO AT THE GROUND SURFACE"      "kg kg-1"
+state    real  DEW              ij      misc        1         -      r        "DEW"                   "DEW MIXING RATIO AT THE SURFACE"              "kg kg-1"
+state    real  SOILT1           ij      misc        1         -      i012rh   "SOILT1"                "TEMPERATURE INSIDE SNOW "    "K"
+state    real  dfi_SOILT1       ij      misc        1         -      r        "SOILT1_dfi"            "TEMPERATURE INSIDE SNOW "    "K"
+state    real  TSNAV            ij      misc        1         -      r        "TSNAV"                 "AVERAGE SNOW TEMPERATURE "                    "C"
+state    real  dfi_TSNAV        ij      misc        1         -      r        "TSNAV_dfi"             "AVERAGE SNOW TEMPERATURE "                    "C"
+state    real  REGIME           ij      misc        1         -      r        "REGIME"  "FLAGS: 1=Night/Stable, 2=Mechanical Turbulent, 3=Forced Conv, 4=Free Conv" ""
+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  dfi_SNOWC        ij      misc        1         -      r        "SNOWC_dfi"             "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    real   sr             ij      dyn_em      1         -      irh         "sr" "fraction of frozen precipitation"
+state    real   potevp         ij      dyn_em      1         -       rh         "potevp" "accumulated potential evaporation" "W m-2"
+state    real   snopcx         ij      dyn_em      1         -       rh         "snopcx" "snow phase change heat flux" "W m-2"
+state    real   soiltb         ij      dyn_em      1         -        h         "soiltb" "bottom soil temperature" "K"
+                                                
+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   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"
+state  integer save_topo_from_real -    dyn_em	    1         -    irh        "save_topo_from_real"    "1=original topo from real/0=topo modified by WRF"      "flag"
+
+## 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  RPHNDGDTEN        ikj      misc     1         -      r        "RPHNDGDTEN"              "COUPLED GEOPOTENTIAL TENDENCY DUE TO FDDA GRID NUDGING"   "Pa m2 s-3"
+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      i{10}r   "U_NDG_NEW"               "NEW X WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  V_NDG_NEW         ikjf     fdda3d   1         Y      i{10}r   "V_NDG_NEW"               "NEW Y WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  T_NDG_NEW         ikjf     fdda3d   1         -      i{10}r   "T_NDG_NEW"               "NEW PERT POT TEMP FOR FDDA GRID NUDGING"  "K"
+state    real  Q_NDG_NEW         ikjf     fdda3d   1         -      i{10}r   "Q_NDG_NEW"               "NEW WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  PH_NDG_NEW        ikjf     fdda3d   1         Z      i{10}r   "PH_NDG_NEW"              "NEW PERT GEOPOTENTIAL FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  U_NDG_OLD         ikjf     fdda3d   1         X      i{10}r   "U_NDG_OLD"               "OLD X WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  V_NDG_OLD         ikjf     fdda3d   1         Y      i{10}r   "V_NDG_OLD"               "OLD Y WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  T_NDG_OLD         ikjf     fdda3d   1         -      i{10}r   "T_NDG_OLD"               "OLD PERT POT TEMP FOR FDDA GRID NUDGING"  "K"
+state    real  Q_NDG_OLD         ikjf     fdda3d   1         -      i{10}r   "Q_NDG_OLD"               "OLD WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  PH_NDG_OLD        ikjf     fdda3d   1         Z      i{10}r   "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         -      i{10}r      "MU_NDG_NEW"              "NEW PERT COLUMN DRY MASS FOR FDDA GRID NUDGING"  "Pa"
+state    real  MU_NDG_OLD        ivjf     fdda2d   1         -      i{10}r      "MU_NDG_OLD"              "OLD PERT COLUMN DRY MASS FOR FDDA GRID NUDGING"  "Pa"
+state    real  U10_NDG_OLD       ij         misc      1         X      i9r      "U10_NDG_OLD"             "OLD U10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  U10_NDG_NEW       ij         misc      1         X      i9r      "U10_NDG_NEW"             "NEW U10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  V10_NDG_OLD       ij         misc      1         Y      i9r      "V10_NDG_OLD"             "OLD V10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  V10_NDG_NEW       ij         misc      1         Y      i9r      "V10_NDG_NEW"             "NEW V10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  T2_NDG_OLD        ij         misc      1         -      i9r      "T2_NDG_OLD"              "OLD T2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  T2_NDG_NEW        ij         misc      1         -      i9r      "T2_NDG_NEW"              "NEW T2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  TH2_NDG_OLD       ij         misc      1         -      i9r      "TH2_NDG_OLD"             "OLD TH2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  TH2_NDG_NEW       ij         misc      1         -      i9r      "TH2_NDG_NEW"             "NEW TH2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  Q2_NDG_OLD        ij         misc      1         -      i9r      "Q2_NDG_OLD"              "OLD Q2 FOR SURFACE FDDA GRID NUDGING"  "kg kg-1"
+state    real  Q2_NDG_NEW        ij         misc      1         -      i9r      "Q2_NDG_NEW"              "NEW Q2 FOR SURFACE FDDA GRID NUDGING"  "kg kg-1"
+state    real  RH_NDG_OLD        ij         misc      1         -      i9r      "RH_NDG_OLD"              "OLD RH FOR SURFACE FDDA GRID NUDGING"  "%"
+state    real  RH_NDG_NEW        ij         misc      1         -      i9r      "RH_NDG_NEW"              "NEW RH FOR SURFACE FDDA GRID NUDGING"  "%"
+state    real  PSL_NDG_OLD       ij         misc      1         -      i9r      "PSL_NDG_OLD"             "OLD PSL FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PSL_NDG_NEW       ij         misc      1         -      i9r      "PSL_NDG_NEW"             "NEW PSL FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PS_NDG_OLD        ij         misc      1         -      i9r      "PS_NDG_OLD"              "OLD PS FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PS_NDG_NEW        ij         misc      1         -      i9r      "PS_NDG_NEW"              "NEW PS FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  TOB_NDG_OLD       ij         misc      1         -      i9r      "TOB_NDG_OLD"             "OLD TOB FOR SURFACE FDDA GRID NUDGING"  ""
+state    real  ODIS_NDG_OLD      ij         misc      1         -      i9r      "ODIS_NDG_OLD"            "OLD ODIS FOR SURFACE FDDA GRID NUDGING"  "km"
+state    real  TOB_NDG_NEW       ij         misc      1         -      i9r      "TOB_NDG_NEW"             "NEW TOB FOR SURFACE FDDA GRID NUDGING"  ""
+state    real  ODIS_NDG_NEW      ij         misc      1         -      i9r      "ODIS_NDG_NEW"            "NEW ODIS FOR SURFACE FDDA GRID NUDGING"  "km"
+state    real  SN_NDG_NEW        ij         misc      1         -      i9r      "SN_NDG_NEW"              "NEW Snow Water Equivalent"  "mm"
+state    real  SN_NDG_OLD        ij         misc      1         -      i9r      "SN_NDG_OLD"              "OLD Snow Water Equivalent"  "mm"
+
+
+# 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"
+
+state   real    max_cfl         -       misc        1         -     -       "max_cfl"           "maximum CFL value in grid at a time" "-"
+
+state   real  prec_acc_c       ij       misc        1         -     rh       "prec_acc_c"       "ACCUMULATED CUMULUS PRECIPITATION OVER prec_acc_dt PERIODS OF TIME"       "mm"
+state   real  prec_acc_nc      ij       misc        1         -     rh       "prec_acc_nc"      "ACCUMULATED GRID SCALE  PRECIPITATION OVER prec_acc_dt PERIODS OF TIME"   "mm"
+state   real  snow_acc_nc      ij       misc        1         -     rh       "snow_acc_nc"      "ACCUMULATED SNOW WATER EQUIVALENT OVER prec_acc_dt PERIODS OF TIME"       "mm"
+
+# Placeholder for decoupled advective tendency diagnostics for non-chem
+state   real  -               ikjf      advh_t      1         -     -         -
+state   real  advh_qv         ikjf      advh_t      1         -     -         "advh_qv"    "ACCUMULATED HORIZONTAL TENDENCY FOR WATER VAPOR"        "kg kg-1"
+
+state   real  -               ikjf      advz_t      1         -     -         -
+state   real  advz_qv         ikjf      advz_t      1         -     -         "advz_qv"    "ACCUMULATED VERTICAL TENDENCY FOR WATER VAPOR"          "kg kg-1"
+
+# Ocean Mixed-Layer State Variables
+state   real    TML            ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "TML"    "OCEAN MIXED-LAYER TEMPERATURE"   "K"
+state   real    T0ML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "T0ML"   "INITIAL OCEAN MIXED-LAYER TEMPERATURE"   "K"
+state   real    HML            ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HML"    "OCEAN MIXED-LAYER DEPTH"   "m"
+state   real    H0ML           ij      misc         1         -     i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "H0ML"   "INITIAL OCEAN MIXED-LAYER DEPTH"   "m"
+state   real    HUML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HUML"   "OCEAN MIXED-LAYER DEPTH * U-CURRENT"  " m2s-1 "
+state   real    HVML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HVML"   "OCEAN MIXED-LAYER DEPTH * V-CURRENT"  " m2s-1 " 
+state   real    TMOML          ij      misc         1         -     i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm) "TMOML"  "OCEAN LAYER MEAN TEMPERATURE   "   "K"
+
+# LMDZ output. L. Fita, LMD. December 2013
+
+include Registry_out.LMDZ
+
+state    real   qv_2            ikj     misc        1         -      -                                      "QV_2"             "WATER VAPOR"                                   "kg kg-1"
+# LMDZ physics variables
+state    real   LCONTROL         {lind} misc        1         -      rh                                          "LCONTROL"             "LMDZ CONTROL indices"                             "-"
+state    real   LMSK             ij     misc        1         -      rh                                          "LMSK"             "LMDZ LAND-SEA MASK"                            "1"
+state    real   LTER             ij     misc        1         -      rh                                          "LTER"             "LMDZ fraction of continent (KSIOL=1)"               "1"
+state    real   LLIC             ij     misc        1         -      rh                                          "LLIC"             "LMDZ fraction of continental ice (KSOIL=2)"        "1"
+state    real   LOCE             ij     misc        1         -      rh                                          "LOCE"             "LMDZ fraction of ocean (KSOIL=3)"                        "1"
+state    real   LSIC             ij     misc        1         -      rh                                          "LSIC"             "LMDZ fraction of oceanic ice (KSOIL=4)"                  "1"
+state    real   LTKSOIL     i{lksoil}j  misc        1         -      rh                                          "LTKSOIL"          "LMDZ temperature at each kind of soil"         "K"
+##state    real   LTTER            ij     misc        1         -      rh                                          "LTTER"            "LMDZ temperature at the TER surface"           "K"
+##state    real   LTLIC            ij     misc        1         -      rh                                         "LTLIC"            "LMDZ temperature at the LIC surface"           "K"
+##state    real   LTOCE            ij     misc        1         -      rh                                         "LTOCE"            "LMDZ temperature at the OCE surface"           "K"
+##state    real   LTSIC            ij     misc        1         -      rh                                          "LTSIC"            "LMDZ temperature at the SIC surface"           "K"
+state    real   LOTTER     i{olay}j     misc        1         -      rh                                          "LOTTER"        "LMDZ-ORCHIDEE temperature at the TER surface"     "K"
+state    real   LOTLIC     i{olay}j     misc        1         -      rh                                          "LOTLIC"        "LMDZ-ORCHIDEE temperature at the LIC surface"     "K"
+state    real   LOTOCE     i{olay}j     misc        1         -      rh                                          "LOTOCE"        "LMDZ-ORCHIDEE temperature at the OCE surface"     "K"
+state    real   LOTSIC     i{olay}j     misc        1         -      rh                                          "LOTSIC"        "LMDZ-ORCHIDEE temperature at the SIC surface"     "K"
+state    real   LQKSOIL    i{lksoil}j   misc        1         -      rh                                          "LQKSOIL"       "LMDZ humidity at each kind of soil"              "kgkg-1"
+##state    real   LQTER            ij     misc        1         -    rh                                          "LQTER"         "LMDZ humidity at the TER surface"              "kgkg-1"
+##state    real   LQLIC            ij     misc        1         -      rh                                          "LQLIC"         "LMDZ humidity at the LIC surface"              "kgkg-1"
+##state    real   LQOCE            ij     misc        1         -      rh                                          "LQOCE"         "LMDZ humidity at the OCE surface"              "kgkg-1"
+##state    real   LQSIC            ij     misc        1         -      rh                                          "LQSIC"         "LMDZ humidity at the SIC surface"              "kgkg-1"
+state    real   LWSOL            ij     misc        1         -      rh                                          "LWSOL"         "LMDZ TOTAL soil water content"                 "mm"
+state    real   LALBKSOIL   i{lksoil}j    misc        1         -      rh                                          "LALBKSOIL"       "LMDZ albedo at each kind of soil"                "1"
+##state    real   LALBTER          ij     misc        1         -      rh                                          "LALBTER"       "LMDZ albedo at the TER surface"                "1"
+##state    real   LALBLIC          ij     misc        1         -      rh                                          "LALBLIC"       "LMDZ albedo at the LIC surface"                "1"
+##state    real   LALBOCE          ij     misc        1         -      rh                                          "LALBOCE"       "LMDZ albedo at the OCE surface"                "1"
+##state    real   LALBSIC          ij     misc        1         -      rh                                          "LALBSIC"       "LMDZ albedo at the SIC surface"                "1"
+state    real   LLWALBKSOIL  i{lksoil}j   misc        1         -      rh                                          "LLWALBKSOIL"   "LMDZ LW albedo at each kind of soil"             "1"
+##state    real   LLWALBTER        ij     misc        1         -      rh                                          "LLWALBTER"     "LMDZ LW albedo at the TER surface"             "1"
+##state    real   LLWALBLIC        ij     misc        1         -      rh                                          "LLWALBLIC"     "LMDZ LW albedo at the LIC surface"             "1"
+##state    real   LLWALBOCE        ij     misc        1         -      rh                                          "LLWALBOCE"     "LMDZ LW albedo at the OCE surface"             "1"
+##state    real   LLWALBSIC        ij     misc        1         -      rh                                          "LLWALBSIC"     "LMDZ LW albedo at the SIC surface"             "1"
+state    real   LEVAPKSOIL  i{lksoil}j  misc        1         -      rh                                          "LEVAPKSOIL"    "LMDZ evaporation  at each kind of soil"          "mm"
+##state    real   LEVAPTER         ij     misc        1         -      rh                                          "LEVAPTER"      "LMDZ evaporation at the TER surface"          "mm"
+##state    real   LEVAPLIC         ij     misc        1         -      rh                                          "LEVAPLIC"      "LMDZ evaporation at the LIC surface"          "mm"
+##state    real   LEVAPOCE         ij     misc        1         -      rh                                          "LEVAPOCE"      "LMDZ evaporation at the OCE surface"          "mm"
+##state    real   LEVAPSIC         ij     misc        1         -      rh                                          "LEVAPSIC"      "LMDZ evaporation at the SIC surface"          "mm"
+state      real   LSNOWKSOIL i{lksoil}j   misc        1         -      rh                                          "LSNOWKSOIL"    "LMDZ snow at each kind of soil"                 "mm"
+##state    real   LSNOWTER         ij     misc        1         -      rh                                          "LSNOWTER"      "LMDZ snow at the TER surface"                 "mm"
+##state    real   LSNOWLIC         ij     misc        1         -      rh                                          "LSNOWLIC"      "LMDZ snow at the LIC surface"                 "mm"
+##state    real   LSNOWOCE         ij     misc        1         -      rh                                          "LSNOWOCE"      "LMDZ snow at the OCE surface"                 "mm"
+##state    real   LSNOWSIC         ij     misc        1         -      rh                                          "LSNOWSIC"      "LMDZ snow at the SIC surface"                 "mm"
+state    real   LRADS            ij     misc        1         -      rh                                          "LRADS"         "LMDZ net radiation at the surface"                 "Wm-2"
+state    real   LSOLSW           ij     misc        1         -      rh                                          "LSOLSW"        "LMDZ short-wave radiation at the surface"                 "Wm-2"
+state    real   LSOLLW           ij     misc        1         -      rh                                          "LSOLLW"        "LMDZ long-wave radiation at the surface"                 "Wm-2"
+##state    real   LFDER            ij     misc        1         -      rh                                          ##"LFDER"         "LMDZ flux derivative (coupling variable)"     "???????"
+state    real   LRAIN            ij     misc        1         -      rh                                          "LRAIN"         "LMDZ liquid precipitation"                   "mm"
+# Already in LMDZ output. L. Fita, LMD. December 2013
+##state    real   LSNOW            ij     misc        1         -      rh                                          "LSNOW"         "LMDZ solid precipitation"                    "mm"
+state    real   LRUGKSOIL i{lksoil}j    misc        1         -      rh                                          "LRUGKSOIL"     "LMDZ rugosity at each kind of soil"             "m"
+##state    real   LRUGTER          ij     misc        1         -      rh                                          "LRUGTER"       "LMDZ rugosity at the TER surface"             "m"
+##state    real   LRUGLIC          ij     misc        1         -      rh                                          "LRUGLIC"       "LMDZ rugosity at the LIC surface"             "m"
+##state    real   LRUGOCE          ij     misc        1         -      rh                                          "LRUGOCE"       "LMDZ rugosity at the OCE surface"             "m"
+##state    real   LRUGSIC          ij     misc        1         -      rh                                          "LRUGSIC"       "LMDZ rugosity at the SIC surface"             "m"
+state    real   LAGESNOKSOIL i{lksoil}j   misc        1         -      rh                                          "LAGESNOKSOIL"  "LMDZ age of the snow at each kind of soil"      "minutes"
+##state    real   LAGESNTER        ij     misc        1         -      rh                                          "LAGESNTER"     "LMDZ age of the snow at the TER surface"      "minutes"
+##state    real   LAGESNLIC        ij     misc        1         -      rh                                          "LAGESNLIC"     "LMDZ age of the snow at the LIC surface"      "minutes"
+##state    real   LAGESNOCE        ij     misc        1         -      rh                                          "LAGESNOCE"     "LMDZ age of the snow at the OCE surface"      "minutes"
+##state    real   LAGESNSIC        ij     misc        1         -      rh                                          "LAGESNSIC"     "LMDZ age of the snow at the SIC surface"      "minutes"
+state    real   LZMEA            ij     misc        1         -      rh                                          "LZMEA"         "LMDZ mean orography"                          "m"
+state    real   LZSTD            ij     misc        1         -      rh                                          "LZSTD"         "LMDZ standard deviation of orography"         "m"
+state    real   LZSIG            ij     misc        1         -      rh                                          "LZSIG"         "LMDZ orographic slope"                        "-"
+state    real   LZGAM            ij     misc        1         -      rh                                          "LZGAM"         "LMDZ orographic anisotropy"                   "-"
+state    real   LZTHE            ij     misc        1         -      rh                                          "LZTHE"         "LMDZ orographic angle"                        "-"
+state    real   LZPIC            ij     misc        1         -      rh                                          "LZPIC"         "LMDZ orographic elevation of peaks"           "m"
+state    real   LZVAL            ij     misc        1         -      rh                                          "LZVAL"         "LMDZ orographic elevation of valleys"         "m"
+state    real   LZRUGSREL        ij     misc        1         -      rh                                          "LZRUGSREL"     "LMDZ orographic rugosity"                     "m"
+state    real   LRUGSEA          ij     misc        1         -      rh                                          "LRUGSEA"       "LMDZ oceanic rugosity"                        "m"
+# Al ready in LMDZ output. L. Fita, LMD. December 2013
+##state    real   LCLWCON          ikj    misc        1         -      rh                                          "LCLWCON"       "LMDZ convective liquid water"                 "mm"
+##state    real   LRNEBCON         ikj    misc        1         -      rh                                          "LRNEBCON"      "LMDZ convective clouds"                       "mm"
+##state    real   LRATQS           ikj    misc        1         -      rh                                          "LRATQS"        "LMDZ proportion of condensed water from total"                 "1"
+state    real   LRUNOFFLIC       ij     misc        1         -      rh                                          "LRUNOFFLIC"    "LMDZ runoff at land-ice a time-step earlier"  "mms-1"
+state    real   LZMAX0           ij     misc        1         -      rh                                          "LZMAX0"        "LMDZ previous time-step of the characteristic length at the top of the thermals" "m"
+state    real   LF0              ij     misc        1         -      rh                                          "LF0"           "LMDZ previous time-step closure term of the thermals" "-"
+state    real   LEMA_WORK1       ikj    misc        1         -      rh                                          "LEMA_WORK1"    "LMDZ fraction of adiabatic updraft in Emanuel s CU" "1"
+state    real   LEMA_WORK2       ikj    misc        1         -      rh                                          "LEMA_WORK2"    "LMDZ Speed adiabatic updraft in Emmanuel s CU" "ms-1"
+##state    real   LWAKE_DELTAT     ikj    misc        1         -      rh                                          "LWAKE_DELTAT"  "LMDZ Thermal differences between inside/outside wake" "K"
+##state    real   LWAKE_DELTAQ     ikj    misc        1         -      rh                                          "LWAKE_DELTAQ"  "LMDZ moisture differences between inside/outside wake" "kgkg-1"
+##state    real   LWAKE_S          ij     misc        1         -      rh                                          "LWAKE_S"       "LMDZ fraction covered by the wake(cold pool)" "1"
+state    real   LWAKE_CSTAR      ij     misc        1         -      rh                                          "LWAKE_CSTAR"   "LMDZ velocity of the wake gust front"         "ms-1"
+state    real   LWAKE_PE         ij     misc        1         -      rh                                          "LWAKE_PE"      "LMDZ total vertical wake potential energy"    "Jkg-1"
+state    real   LWAKE_FIP        ij     misc        1         -      rh                                          "LWAKE_FIP"     "LMDZ Wake power given to the environment"     "Wm-2"
+state    real   LFM_THERM   i{kplus1}j  misc        1         -      rh                                          "LFM_THERM"     "LMDZ vertical mass flux within the thermal"   "kgs-1"
+state    real   LENTR_THERM     ikj     misc        1         -      rh                                          "LENTR_THERM"   "LMDZ entrainment within the thermal"          "???????"
+state    real   LDETR_THERM     ikj     misc        1         -      rh                                          "LDETR_THERM"   "LMDZ detrainment within the thermal"          "???????"
+state    real   LNAT            ij      misc        1         -      rh                                          "LNAT"          "LMDZ kind of soil"                      "-"
+##state    real   LBILS           ij      misc        1         -      rh                                          "LBILS"         "LMDZ heat flux reference at land"             "-"
+state    real   LRUG            ij     misc        1         -      rh                                          "LRUG"          "LMDZ total rugosity"             "m"
+
+#
+#---------------------------------------------------------------------------------------------------------------------------------------
+#                                               
+
+######                                          
+#                                               
+# Variables that are set at run-time to control configuration  (namelist-settable)                                              
+#                                               
+#<Table>  <Type>  <Sym>                   <How set>          <Nentries>   <Default>                                             
+
+# 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"      ""  ""
+rconfig   logical all_ic_times            namelist,time_control		1              .false. irh    "all_ic_times"     "T/F WRITE ALL IC TIME PERIODS"  ""
+
+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<domain>"          -     "name of input   infile"   ""      ""
+rconfig   character  input_outname     namelist,time_control		1  "wrfinput_d<domain>"          -     "name of input   outfile"  ""      ""
+rconfig   character  bdy_inname        namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary infile"  ""      ""
+rconfig   character  bdy_outname       namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary outfile" ""      ""
+rconfig   character  rst_inname        namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "name of restrt infile"    ""      ""
+rconfig   character  rst_outname       namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "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 write_hist_at_0h_rst    namelist,time_control		1             .false. h    "write_hist_at_0h_rst" "T/F write hist at 0 h of restarted forecast"
+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"
+rconfig   logical cycling                 namelist,time_control         1             .false. -    "true for cycling (using wrfout file as input data)"
+
+# DFI namelist
+rconfig   integer dfi_opt                namelist,dfi_control   1       0     rh   "dfi_opt"                  ""      ""
+rconfig   integer dfi_radar              namelist,dfi_control   1       0     rh   "dfi_radar"                "DFI radar switch"      ""
+rconfig   integer dfi_nfilter            namelist,dfi_control   1       7     rh   "dfi_nfilter"              "Digital filter type"      ""
+rconfig   logical dfi_write_filtered_input  namelist,dfi_control  1  .true.   rh   "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?"      ""
+rconfig   logical dfi_write_dfi_history  namelist,dfi_control   1   .false.   rh   "dfi_write_dfi_history"    "Write history files during filtering?"      ""
+rconfig   integer dfi_cutoff_seconds     namelist,dfi_control   1    3600     rh   "dfi_cutoff_seconds"       "Digital filter cutoff time"      ""
+rconfig   integer dfi_time_dim           namelist,dfi_control   1    1000     rh   "dfi_time_dim"             "MAX DIMENSION FOR HCOEFF"
+rconfig   integer dfi_fwdstop_year       namelist,dfi_control   1    2004     rh   "dfi_fwdstop_year"         "4 DIGIT YEAR OF START OF DFI" "YEARS"
+rconfig   integer dfi_fwdstop_month      namelist,dfi_control   1      03     rh   "dfi_fwdstop_month"        "2 DIGIT MONTH OF THE YEAR OF START OF DFI" "MONTHS"
+rconfig   integer dfi_fwdstop_day        namelist,dfi_control   1      13     rh   "dfi_fwdstop_day"          "2 DIGIT DAY OF THE MONTH OF START OF DFI" "DAYS"
+rconfig   integer dfi_fwdstop_hour       namelist,dfi_control   1      12     rh   "dfi_fwdstop_hour"         "2 DIGIT HOUR OF THE DAY OF START OF DFI" "HOURS"
+rconfig   integer dfi_fwdstop_minute     namelist,dfi_control   1      00     rh   "dfi_fwdstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF START OF DFI" "MINUTES"
+rconfig   integer dfi_fwdstop_second     namelist,dfi_control   1      00     rh   "dfi_fwdstop_second"       "2 DIGIT SECOND OF THE MINUTE OF START OF DFI" "SECONDS"
+rconfig   integer dfi_bckstop_year       namelist,dfi_control   1    2004     rh   "dfi_bckstop_year"         "4 DIGIT YEAR OF END OF DFI" "YEARS"
+rconfig   integer dfi_bckstop_month      namelist,dfi_control   1      03     rh   "dfi_bckstop_month"        "2 DIGIT MONTH OF THE YEAR OF END OF DFI" "MONTHS"
+rconfig   integer dfi_bckstop_day        namelist,dfi_control   1      14     rh   "dfi_bckstop_day"          "2 DIGIT DAY OF THE MONTH OF END OF DFI" "DAYS"
+rconfig   integer dfi_bckstop_hour       namelist,dfi_control   1      12     rh   "dfi_bckstop_hour"         "2 DIGIT HOUR OF THE DAY OF END OF DFI" "HOURS"
+rconfig   integer dfi_bckstop_minute     namelist,dfi_control   1      00     rh   "dfi_bckstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF END OF DFI" "MINUTES"
+rconfig   integer dfi_bckstop_second     namelist,dfi_control   1      00     rh   "dfi_bckstop_second"       "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS"
+
+# 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 time_step_dfi           namelist,domains      1             -       ih   "time_step_dfi"
+
+rconfig   integer min_time_step           namelist,domains      max_domains   -1      h    "min_time_step"
+rconfig   integer max_time_step           namelist,domains      max_domains   -1      h    "max_time_step"
+rconfig   real    target_cfl              namelist,domains      max_domains  1.2      h    "target_cfl"
+rconfig   real    target_hcfl             namelist,domains      max_domains  0.84     h    "target_hcfl"
+
+rconfig   integer max_step_increase_pct   namelist,domains      max_domains    5      h    "max_step_increase_pct"
+rconfig   integer starting_time_step      namelist,domains      max_domains   -1      h    "starting_time_step"
+rconfig   logical step_to_output_time     namelist,domains      1         .true.      h    "step_to_output_time"
+rconfig   integer adaptation_domain       namelist,domains      1              1      h    "adaptation_domain"
+rconfig   logical use_adaptive_time_step  namelist,domains      1         .false.     h    "use_adaptive_time_step"
+
+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 num_metgrid_soil_levels namelist,domains	1             4        irh    "num_metgrid_soil_levels"               "number of input levels or layers in 3D sm, st, sw arrays"      ""
+rconfig   real    p_top_requested         namelist,domains      1              5000    irh    "p_top_requested" "Pa"      ""
+rconfig   integer interp_type             namelist,domains	1              2       irh    "interp_type"  "1=interp in pressure, 2=interp in LOG pressure"  ""
+rconfig   integer vert_refine_fact        namelist,domains      1              1       irh    "vertical refinment factor for ndown"  ""
+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              2       irh    "t_extrap_type"  "1=isothermal, 2=6.5 K/km, 3=adiabatic"   ""
+rconfig   logical lowest_lev_from_sfc     namelist,domains	1             .false.  irh    "lowest_lev_from_sfc"                ""      ""
+rconfig   logical use_levels_below_ground namelist,domains	1             .true.   irh    "use_levels_below_ground"   "T/F: use input data levels below input sfc pres" ""
+rconfig   logical use_tavg_for_tsk        namelist,domains	1             .false.  irh    "use_tavg_for_tsk"   "T/F: use diurnal avg sfc temp for tsk" ""
+rconfig   logical use_surface             namelist,domains	1             .true.   irh    "use_surface"   "T/F: use input surface level in interpolation" ""
+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    "sfcp_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   logical smooth_cg_topo          namelist,domains	1              .false. irh    "smooth_cg_topo"   "T/F smooth CG topo on boundarries" "flag"
+rconfig   logical aggregate_lu            namelist,domains	1              .false. irh    "aggregate_lu"   "T/F aggregate the grass, shrubs, trees in LU"
+rconfig   logical rh2qv_wrt_liquid        namelist,domains	1              .true.  irh    "rh2qv_wrt_liquid" "T = rh=>Qv assumes RH wrt liquid water, F = allows ice"
+rconfig   integer rh2qv_method            namelist,domains	1              1       irh    "rh2qv_method" "1=old MM5 method, 2=new WMO method"
+rconfig   real    qv_max_p_safe           namelist,domains      1              10000   irh    "qv_max_p_safe" "Threshhold pressure, Qv > flag set to value"      "Pa"
+rconfig   real    qv_max_flag             namelist,domains      1              1.E-5   irh    "qv_max_flag" "Qv flag for max"  "kg kg{-1}"
+rconfig   real    qv_max_value            namelist,domains      1              3.E-6   irh    "qv_max_value" "Qv value for max"  "kg kg{-1}"
+rconfig   real    qv_min_p_safe           namelist,domains      1              110000  irh    "qv_min_p_safe" "Threshhold pressure, Qv < flag set to value"      "Pa"
+rconfig   real    qv_min_flag             namelist,domains      1              1.E-6   irh    "qv_min_flag" "Qv flag for min"  "kg kg{-1}"
+rconfig   real    qv_min_value            namelist,domains      1              1.E-6   irh    "qv_min_value" "Qv value for min"  "kg kg{-1}"
+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   logical grid_allowed            namelist,domains	max_domains    .true.  irh    "allowed"            ""      ""
+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   ts_buf_size     namelist,domains    1                200          -       "ts_buf_size"   "Size of time series buffer"
+rconfig   integer   max_ts_locs     namelist,domains    1                5            -       "max_ts_locs"   "Maximum number of time series locations"
+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   track_level     namelist,domains    1                50000
+rconfig   real      time_to_move    namelist,domains    max_domains      0.  -  "" "" "minutes"
+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.
+
+# TC (tropical cyclone bogusing)
+rconfig   logical insert_bogus_storm   namelist,tc     	1              .false. irh    "insert_bogus_storm"   "T/F for inserting a bogus typhoon"    "flag"
+rconfig   logical remove_storm         namelist,tc     	1              .false. irh    "remove_storm"  "T/F for only removing the original typhoon"  "flag"
+rconfig   integer num_storm            namelist,tc     	1              1       irh    "num_storm"     "Number of bogus typhoons"  ""
+rconfig   real    latc_loc             namelist,tc     	max_bogus      -999.   irh    "latc_loc"      "center latitude of the bogus tyhoon"  "DEGREES"
+rconfig   real    lonc_loc             namelist,tc     	max_bogus      -999.   irh    "lonc_loc"      "center longitude of the bogus tyhoon"  "DEGREES"
+rconfig   real    vmax_meters_per_second   namelist,tc  max_bogus      -999.   irh    "vmax_meters_per_second"  "vmax of bogus storm in meters per second"  ""
+rconfig   real    rmax                 namelist,tc     	max_bogus      -999.   irh    "rmax"  "maximum radius outward from storm center"  ""
+rconfig   real    vmax_ratio           namelist,tc      max_bogus      -999.   irh    "vmax_ratio"  ""  ""
+rconfig   real    rankine_lid          namelist,tc      1              -999.   irh    "top pressure limit for the tc bogus scheme"
+
+
+# Physics
+rconfig   integer     mp_physics          namelist,physics	max_domains    0       rh       "mp_physics"            ""      ""
+#rconfig   integer     milbrandt_ccntype   namelist,physics      max_domains    0       rh       "milbrandt select maritime(1)/continental(2)"  ""      ""
+rconfig   integer     gsfcgce_hail        namelist,physics      1              0       rh       "gsfcgce select hail/graupel"  ""      ""
+rconfig   integer     gsfcgce_2ice        namelist,physics      1              0       rh       "gsfcgce select 2ice/3ice"  ""      ""
+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   integer     sf_urban_physics    namelist,physics      max_domains    0       rh       "sf_urban_physics"     "activate urban model  0=no, 1=Noah_UCM 2=BEP_UCM"   ""
+rconfig   real    BLDT                    namelist,physics      max_domains    0       h    "BLDT"          ""      ""
+rconfig   integer cu_physics              namelist,physics      max_domains    0       rh   "cu_physics"    ""      ""
+rconfig   integer shcu_physics            namelist,physics      max_domains    0       rh   "shcu_physics"  ""      ""
+rconfig   integer     cu_diag             namelist,physics      max_domains    0       rh       "cu_diag"            " additional t-averaged stuff for cuphys"      ""
+rconfig   integer     kfeta_trigger       namelist,physics	1              1       rh       "KFETA Trigger function"    ""    ""
+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_urban_layers        namelist,physics	1            400       irh    "num_urban_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 cugd_avedx              namelist,physics      1            1      irh    "cugd_avedx"                    ""      ""
+rconfig   integer clos_choice             namelist,physics      1             0       rh    "clos_choice"                    ""      ""
+rconfig   integer imomentum               namelist,physics      1             0       rh    "imomentum"                    "momentum transport in G3 scheme"      ""
+rconfig   integer ishallow                namelist,physics      1             0       rh    "ishallow"  "shallow convection in G3 scheme"      ""
+rconfig   real    convtrans_avglen_m      namelist,physics      1             30      rh    "convtrans_avglen_m"  "averaging time for convective transport output variables (minutes)"      ""
+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 sst_skin                namelist,physics      1            0         h    "sst_skin" "calculate sst skin temperature 0=no, 1=yes"   ""
+rconfig   integer tmn_update              namelist,physics      1            0         h    "tmn_update" "update tmn from calculation  0=no, 1=yes"   ""
+rconfig   logical usemonalb               namelist,physics      1            .false.   h    "usemonalb"   "use 2d field vs table values  false=table, True=2d"   ""
+rconfig   logical rdmaxalb                namelist,physics      1            .true.    h     "rdmaxalb"    "false set it to table values"   ""
+rconfig   logical rdlai2d                 namelist,physics      1            .false.   h     "rdlai2d"     "false set it to table values"   ""
+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   integer lagday                  namelist,physics      1             1       -      "lagday"         ""      ""
+rconfig   logical cu_rad_feedback         namelist,physics      max_domains   .false.  -     "feedback cumulus to radiation"  ""
+rconfig   integer pxlsm_smois_init        namelist,physics      max_domains   1       irh    "PXLSM_SMOIS_INIT"    "Soil moisture initialization option 0-From analysis 1-From MAVAIL"   ""
+rconfig   integer omlcall                 namelist,physics      1            0         h     "omlcall"     "activate simple ocean mixed layer model  0=no, 1=yes"   ""
+rconfig   real    oml_hml0                namelist,physics      1            50        h     "oml_hml0"    "oml initial mixed layer depth value"   "m"
+rconfig   real    oml_gamma               namelist,physics      1            0.14      h     "oml_gamma"   "oml deep water lapse rate"   "K m-1"
+rconfig   integer isftcflx                namelist,physics      1            0         h     "isftcflx"    "switch to control sfc fluxes"   ""
+rconfig   integer iz0tlnd                 namelist,physics      1            0         h     "iz0tlnd"    "switch to control land thermal roughness length"   ""
+rconfig   real    shadlen                 namelist,physics      1            25000.    -     "shadow_length" "maximum length of orographic shadow" "m"
+rconfig   integer slope_rad               namelist,physics      max_domains    0       -     "slope_rad"  "1: use slope-dependent radiation, 0:not" ""
+rconfig   integer topo_shading            namelist,physics      max_domains    0       -     "topo_shading" "1: apply topographic shading to radiation, 0:not" ""
+rconfig   integer no_mp_heating           namelist,physics      1              0       -     "no_mp_heating" "switch to turn of latent heating in mp schemes"   ""
+rconfig   integer fractional_seaice       namelist,physics      1              0       -     "fractional_seaice" "Fractional sea-ice option"
+rconfig   logical tice2tsk_if2cold        namelist,physics      1              .false. -     "tice2tsk_if2cold" "Avoid low ice temps when ice frac and Tsk are inconsistent"
+rconfig   real    bucket_mm               namelist,physics      1             -1.      h     "bucket_mm" "bucket reset value for water accumulations -1: inactive"   ""
+rconfig   real    bucket_J                namelist,physics      1             -1.      h     "bucket_J"  "bucket reset value for energy accumulations -1: inactive"   ""
+rconfig   real    mp_tend_lim             namelist,physics      1             10.      -     "mp_tend_lim" "limit on temp tendency from mp latent heating"   "K/s"
+rconfig   real    prec_acc_dt             namelist,physics      max_domains    0.      h     "prec_acc_dt" "bucket reset time interval between outputs for cumulus or grid scale precipitation"   "minutes"
+rconfig   integer prec_acc_opt            derived               1              0       -     "prec_acc_opt" "option to output precip in a time window"          ""
+rconfig   integer bucketr_opt             derived               1              0       -     "bucketr_opt"  "option to output water accum based on bucket_mm"          ""
+
+rconfig   integer grav_settling           namelist,physics      max_domains  0         h    "grav_settling"     "activate gravitationalsettling of fog  0=no, 1=yes"
+
+#FDDA namelist parameters
+rconfig   real    FGDT                    namelist,fdda         max_domains    0       h        "FGDT"          ""      ""
+rconfig   integer  FGDTZERO               namelist,fdda         max_domains    0       rh       "FGDTZERO"             ""      ""
+rconfig   integer  grid_fdda              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   integer  grid_sfdda             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_ph   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_ph             namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   integer   k_zfac_ph             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   integer  dk_zfac_uv             namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   integer  dk_zfac_t              namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   integer  dk_zfac_ph             namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   real        guv                 namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        guv_sfc             namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gt                  namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gt_sfc              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gq                  namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gq_sfc              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gph                 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"            ""      ""
+rconfig   real    rinblw                  namelist,fdda         1              0       h        "grid_fdda"            ""      ""
+rconfig   integer xwavenum                namelist,fdda         max_domains    0       rh       "grid_fdda"            "top wave number to nudge in x direction"      "" 
+rconfig   integer ywavenum                namelist,fdda         max_domains    0       rh       "grid_fdda"            "top wave number to nudge in y direction"      ""
+rconfig   integer pxlsm_soil_nudge        namelist,fdda         max_domains    0       rh       "pxlsm_soil_nudge"     "nudge pxlsm soil"      ""
+
+#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   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   integer     obs_no_pbl_nudge_uv namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_uv" "1=no wind-nudging within pbl"          ""
+rconfig   integer     obs_no_pbl_nudge_t  namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_t"  "1=no temperature-nudging within pbl"   ""
+rconfig   integer     obs_no_pbl_nudge_q  namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_q"  "1=no moisture-nudging within pbl"      ""
+rconfig   integer     obs_sfc_scheme_horiz namelist,fdda           1              0       rh       "obs_sfcscheme_horiz" "0=wrf scheme, 1=original mm5 scheme" ""
+rconfig   integer     obs_sfc_scheme_vert  namelist,fdda           1              0       rh       "obs_sfcscheme_vert"  "0=regime vif scheme, 1=original simple scheme" ""
+rconfig   real        obs_max_sndng_gap   namelist,fdda            1              20      rh       "obs_max_sndng_gap"   "Max press gap between soundings" "centibars"
+rconfig   real        obs_nudgezfullr1_uv namelist,fdda            1              50      rh       "obs_nudgezfullr1_uv" "Vert infl full weight  height for LML obs, regime 1, winds"        ""
+rconfig   real        obs_nudgezrampr1_uv namelist,fdda            1              50      rh       "obs_nudgezrampr1_uv" "Vert infl ramp-to-zero height for LML obs, regime 1, winds"        ""
+rconfig   real        obs_nudgezfullr2_uv namelist,fdda            1              50      rh       "obs_nudgezfullr2_uv" "Vert infl full weight  height for LML obs, regime 2, winds"        ""
+rconfig   real        obs_nudgezrampr2_uv namelist,fdda            1              50      rh       "obs_nudgezrampr2_uv" "Vert infl ramp-to-zero height for LML obs, regime 2, winds"        ""
+rconfig   real        obs_nudgezfullr4_uv namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_uv" "Vert infl full weight  height for LML obs, regime 4, winds"        ""
+rconfig   real        obs_nudgezrampr4_uv namelist,fdda            1              50      rh       "obs_nudgezrampr4_uv" "Vert infl ramp-to-zero height for LML obs, regime 4, winds"        ""
+rconfig   real        obs_nudgezfullr1_t  namelist,fdda            1              50      rh       "obs_nudgezfullr1_t" "Vert infl full weight  height for LML obs, regime 1, temperature"  ""
+rconfig   real        obs_nudgezrampr1_t  namelist,fdda            1              50      rh       "obs_nudgezrampr1_t" "Vert infl ramp-to-zero height for LML obs, regime 1, temperature"  ""
+rconfig   real        obs_nudgezfullr2_t  namelist,fdda            1              50      rh       "obs_nudgezfullr2_t" "Vert infl full weight  height for LML obs, regime 2, temperature"  ""
+rconfig   real        obs_nudgezrampr2_t  namelist,fdda            1              50      rh       "obs_nudgezrampr2_t" "Vert infl ramp-to-zero height for LML obs, regime 2, temperature"  ""
+rconfig   real        obs_nudgezfullr4_t  namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_t" "Vert infl full weight  height for LML obs, regime 4, temperature"  ""
+rconfig   real        obs_nudgezrampr4_t  namelist,fdda            1              50      rh       "obs_nudgezrampr4_t" "Vert infl ramp-to-zero height for LML obs, regime 4, temperature"  ""
+rconfig   real        obs_nudgezfullr1_q  namelist,fdda            1              50      rh       "obs_nudgezfullr1_q" "Vert infl full weight  height for LML obs, regime 1, moisture"     ""
+rconfig   real        obs_nudgezrampr1_q  namelist,fdda            1              50      rh       "obs_nudgezrampr1_q" "Vert infl ramp-to-zero height for LML obs, regime 1, moisture"     ""
+rconfig   real        obs_nudgezfullr2_q  namelist,fdda            1              50      rh       "obs_nudgezfullr2_q" "Vert infl full weight  height for LML obs, regime 2, moisture"     ""
+rconfig   real        obs_nudgezrampr2_q  namelist,fdda            1              50      rh       "obs_nudgezrampr2_q" "Vert infl ramp-to-zero height for LML obs, regime 2, moisture"     ""
+rconfig   real        obs_nudgezfullr4_q  namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_q" "Vert infl full weight  height for LML obs, regime 4, moisture"     ""
+rconfig   real        obs_nudgezrampr4_q  namelist,fdda            1              50      rh       "obs_nudgezrampr4_q" "Vert infl ramp-to-zero height for LML obs, regime 4, moisture"     ""
+rconfig   real        obs_nudgezfullmin   namelist,fdda            1                 50   rh       "obs_nudgezfullmin" "Minimum depth through which vertical influence fcn remains 1.0"     "m"
+rconfig   real        obs_nudgezrampmin   namelist,fdda            1                 50   rh       "obs_nudgezrampmin" "Minimum depth through which vertical influence fcn decreases from 1.0 to 0.0" "m"
+rconfig   real        obs_nudgezmax       namelist,fdda            1               3000   rh       "obs_nudgezmax" "Maximum depth in which vertical influence function is nonzero" "m"
+rconfig   real        obs_sfcfact         namelist,fdda            1              1.0     h        "obs_sfcfact"       "Scale factor applied to time window for surface obs"     ""
+rconfig   real        obs_sfcfacr         namelist,fdda            1              1.0     h        "obs_sfcfacr"       "Scale factor applied to horiz radius of influence for surface obs"     ""
+rconfig   real        obs_dpsmx           namelist,fdda            1              7.5     h        "obs_dpsmx"         "Max pressure change allowed within horiz radius of influence"     "centibars"
+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            max_domains    0       rh       "obs_twindo"        "Half-period time window for nudging"  "hrs"
+rconfig   integer     obs_npfi            namelist,fdda            1              0       h        "obs_npfi"          "Freq in cg timesteps for diag print"  ""
+rconfig   integer     obs_ionf            namelist,fdda            max_domains    1       rh       "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   integer     obs_prt_max         namelist,fdda            1              1000    rh       "obs_prt_max"       "Maximum allowed obs entries in diagnostic printout"      ""
+rconfig   integer     obs_prt_freq        namelist,fdda            max_domains    1000    rh       "obs_prt_freq"      "Frequency in obs index for diagnostic printout."   ""
+rconfig   logical     obs_ipf_in4dob      namelist,fdda            1              .false. h        "obs_ipf_in4dob"    "Print obs input diagnostics"   ""
+rconfig   logical     obs_ipf_errob       namelist,fdda            1              .false. h        "obs_ipf_errob"     "Print obs error diagnostics"   ""
+rconfig   logical     obs_ipf_nudob       namelist,fdda            1              .false. h        "obs_ipf_nudob"     "Print obs nudge diagnostics"   ""
+rconfig   logical     obs_ipf_init        namelist,fdda            1              .true.  h        "obs_ipf_init"      "Enable obs init warning messages"   ""
+
+# Single-column model (SCM)
+rconfig   integer scm_force               namelist,scm  1       0           rh   "scm_force"            "SCM forcing switch" ""
+rconfig   real    scm_force_dx            namelist,scm  1       4000.       rh   "scm_force_dx"         "DX for SCM forcing" "m"
+rconfig   integer num_force_layers        namelist,scm  1       8           rh   "num_force_layers"     "Number of SCM forcing layers" ""
+rconfig   integer scm_lu_index            namelist,scm  1       2           rh   "scm_lu_index"         "SCM landuse index" ""
+rconfig   integer scm_isltyp              namelist,scm  1       4           rh   "scm_isltyp"           "SCM soil category" ""
+rconfig   real    scm_vegfra              namelist,scm  1       0.5         rh   "scm_vegfra"           "SCM vegetation fraction" ""
+rconfig   integer scm_canwat              namelist,scm  1       0.0         rh   "scm_canwat"           "SCM canopy water" "kg m-2"
+rconfig   real    scm_lat                 namelist,scm  1        36.605     rh   "scm_lat"              "SCM latitude" "degrees"
+rconfig   real    scm_lon                 namelist,scm  1       -97.485     rh   "scm_lon"              "SCM longitude" "degrees"
+rconfig   logical scm_th_adv              namelist,scm  1       .true.      rh   "scm_th_adv"           "Turn on theta advection in SCM"      ""
+rconfig   logical scm_wind_adv            namelist,scm  1       .true.      rh   "scm_wind_adv"         "Turn on wind advection in SCM"      ""
+rconfig   logical scm_qv_adv              namelist,scm  1       .true.      rh   "scm_qv_adv"           "Turn on qv advection in SCM"      ""
+rconfig   logical scm_ql_adv              namelist,scm  1       .false.     rh   "scm_ql_adv"           "Turn on ql advection in SCM"      ""
+rconfig   logical scm_vert_adv            namelist,scm  1       .true.      rh   "scm_vert_adv"         "Turn on vertical advection in SCM"      ""
+rconfig   integer num_force_soil_layers   namelist,scm  1       5           rh   "num_force_soil_layers" "Number of SCM soil forcing layers" ""
+rconfig   logical scm_soilT_force         namelist,scm  1       .false.     rh   "scm_soilT_force"      "Turn on soil temp forcing in SCM"      ""
+rconfig   logical scm_soilq_force         namelist,scm  1       .false.     rh   "scm_soilq_force"      "Turn on soil moisture forcing in SCM"      ""
+rconfig   logical scm_force_th_largescale namelist,scm  1       .false.     rh   "scm_force_th_largescale" "Turn on large scale theta forcing in SCM"      ""
+rconfig   logical scm_force_qv_largescale namelist,scm  1       .false.     rh   "scm_force_qv_largescale" "Turn on large scale qv forcing in SCM"      ""
+rconfig   logical scm_force_ql_largescale namelist,scm  1       .false.     rh   "scm_force_ql_largescale" "Turn on large scale ql forcing in SCM"      ""
+rconfig   logical scm_force_wind_largescale namelist,scm  1     .false.     rh   "scm_force_wind_largescale" "Turn on large scale wind forcing in SCM"      ""
+
+# Dynamics
+# dynamics option (see package definitions, below)
+rconfig   integer dyn_opt                 namelist,dynamics	1             2 
+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"                ""      ""
+# km_opt_dfi is needed for backward integration in dfi
+rconfig   integer km_opt_dfi              namelist,dynamics	1             1       irh    "km_opt_dfi"                ""      ""
+rconfig   integer damp_opt                namelist,dynamics	1             0       irh    "damp_opt"              ""      ""
+rconfig   integer rad_nudge               namelist,dynamics	1             0       irh    "rad_nudge"             ""      ""
+rconfig   integer gwd_opt                 namelist,dynamics     1             0       irh    "gwd_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    c_s                     namelist,dynamics	max_domains    0.25    h    "c_s"         "Smagorinsky coeff"      ""
+rconfig   real    c_k                     namelist,dynamics	max_domains    0.15    h    "c_k"         "TKE coeff"      ""
+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   integer  moist_adv_opt          namelist,dynamics	max_domains    1       rh    "moist_adv_opt"         "positive-definite RK3 transport switch"      ""
+rconfig   integer  moist_adv_dfi_opt      namelist,dynamics	max_domains    0       rh    "moist_adv_dfi_opt"    "positive-definite RK3 transport switch"      ""
+rconfig   integer  chem_adv_opt           namelist,dynamics	max_domains    1       rh    "chem_adv_opt"          "positive-definite RK3 transport switch"      ""
+rconfig   integer  tracer_adv_opt         namelist,dynamics	max_domains    1       rh    "tracer_adv_opt"        "positive-definite RK3 transport switch"      ""
+rconfig   integer  scalar_adv_opt         namelist,dynamics	max_domains    1       rh    "scalar_adv_opt"        "positive-definite RK3 transport switch"      ""
+rconfig   integer  tke_adv_opt            namelist,dynamics	max_domains    1       rh    "tke_adv_opt"           "positive-definite RK3 transport switch"      ""
+rconfig   logical top_radiation           namelist,dynamics	max_domains    .false. rh    "top_radiation"         ""      ""
+rconfig   integer mix_isotropic           namelist,dynamics	max_domains    0       h    "mix_isotropic"            "0=anistropic, 1=isotropic"      ""
+rconfig   real    mix_upper_bound         namelist,dynamics	max_domains    0.1     h    "mix_upper_bound"          "non-dimensional limit"      ""
+rconfig   logical top_lid                 namelist,dynamics     max_domains    .false. rh    "top_lid"               ""      ""
+rconfig   real    tke_upper_bound         namelist,dynamics	max_domains    1000.   h    "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 coriolis2d              namelist,dynamics	max_domains  .false.  irh  "coriolis2d"    ""   ""
+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"
+rconfig   real    iso_temp                namelist,dynamics	1               0.     h    "iso_temp"   "Isothermal temperature in stratosphere, real only"      "K"
+rconfig   logical use_baseparam_fr_nml    namelist,dynamics	1            .false.  irh   "use_baseparam_fr_nml"    ""   ""
+rconfig   real    fft_filter_lat          namelist,dynamics     1              91.     h    "fft_filter_lat"   ""   "grid latitude to start polar filter"
+rconfig   logical rotated_pole            namelist,dynamics     1            .false.  irh   "rotated_pole"    ""   ""
+rconfig   logical do_coriolis             namelist,dynamics	max_domains  .true.   irh  "do_coriolis"    ""   ""
+rconfig   logical do_curvature            namelist,dynamics	max_domains  .true.   irh  "do_curvature"   ""   ""
+rconfig   logical do_gradp                namelist,dynamics	max_domains  .true.   irh  "do_gradp"    ""   ""
+rconfig   integer     tracer_opt          namelist,dynamics     max_domains    0       rh    "tracer_opt"          ""      ""
+# Placeholder for decoupled advective tendency diagnostics
+rconfig   integer tenddiag                namelist,dynamics     max_domains    0       -     "Decoupled tendency diagnostics"   ""    ""
+
+# 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 constant_bc             namelist,bdy_control          1      .false. rh    "constant_bc"           ""      ""
+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 polar                   namelist,bdy_control	max_domains    .false. rh    "polar"                 ""      ""
+rconfig   logical nested                  namelist,bdy_control	max_domains    .false. rh    "nested"                ""      ""
+rconfig   real    spec_exp                namelist,bdy_control          1     0.      irh    "spec_exp"              ""      ""
+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   integer nobs_ndg_vars           derived                       1         6       -        "num_ndg_vars"         "Number of nudging variables"          ""
+rconfig   integer nobs_err_flds           derived                       1         9       -        "num_err_flds"         "Number of error fields"               ""
+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    pole_lat                derived                  max_domains    0       -        "pole_lat"              "projection info: latitude of pole" "degrees, positive north"
+rconfig   real    pole_lon                derived                  max_domains    0       -        "pole_lon"              "projection info: longitude of pole" "degrees, positive east"
+rconfig   integer  FLAG_METGRID           derived                      1          0       -        "FLAG_METGRID"         "Flag in global attributes for metgrid data"
+rconfig   integer  FLAG_SNOW              derived                      1          0       -        "FLAG_SNOW"             "Flag for snow in the global attributes for metgrid data"
+rconfig   integer  FLAG_PSFC              derived                      1          0       -        "FLAG_PSFC"             "Flag for surface pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM000010          derived                      1          0       -        "FLAG_SM000010"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM010040          derived                      1          0       -        "FLAG_SM010040"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM040100          derived                      1          0       -        "FLAG_SM040100"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM100200          derived                      1          0       -        "FLAG_SM100200"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST000010          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST010040          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST040100          derived                      1          0       -        "FLAG_ST010040"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST100200          derived                      1          0       -        "FLAG_ST100200"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_SLP               derived                      1          0       -        "FLAG_SLP"              "Flag for sea level pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SOILHGT           derived                      1          0       -        "FLAG_SOILHGT"          "Flag for soil height in the global attributes for metgrid data"
+rconfig   integer  FLAG_MF_XY             derived                      1          0       -        "FLAG_MF_XY"            "Flag for MF_XYin the global attributes for metgrid data"
+rconfig   real    bdyfrq                  derived                  max_domains    0       -        "bdyfrq"               "lateral boundary input frequency"      "seconds"
+rconfig   character mminlu                derived                  max_domains    " "     -        "mminlu"               "land use dataset"             ""
+rconfig   integer iswater                 derived                  max_domains    0       -        "iswater"              "land use index of water"      "index category"
+rconfig   integer islake                  derived                  max_domains    0       -        "islake"               "land use index of inland lake"      "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 (Cylindrical), 1=Lambert, 2=polar, 3=Mercator"
+rconfig   integer use_wps_input           derived                       1         0       -        "use_wps_input"        "0/1 flag, using wps input"      "0=no, 1=yes"
+rconfig   integer dfi_stage               derived                  max_domains    3       -        "dfi_stage"            "current stage of DFI processing"      "0=DFI setup, 1=DFI backward integration, 2=DFI forward integration, 3=WRF forecast"
+rconfig   integer mp_physics_dfi          derived                  max_domains   -1       -        "mp_physics_dfi"       ""      "-1 = no DFI and so no need to allocate DFI moist and scalar variables, >0 = running with DFI, so allocate DFI moist and scalar variables appropriate for selected microphysics package"
+
+#
+# Single dummy declaration to define a nodyn dyn option
+state integer nodyn_dummy - dyn_nodyn -  -  -  "" "" ""      
+
+# Turbine drag (td) physics
+# Turbine positions and characteristics for real-data cases are specified in a file 
+# whose name is given in the windturbines_spec variable.  If the setting is "ideal",
+# the td_ variables specify idealized wind farm geometries and turbine characteristics.
+# If the setting is "none" then wind turbine drag physics is turned off.
+rconfig character windturbines_spec namelist,physics 1 "none" - - "" "none, ideal, or a file name"
+rconfig integer td_turbgridid  namelist,physics 1 -1     - - ""  "which grid id has turbines in it"
+rconfig  real   td_hubheight   namelist,physics 1 100.   - - ""  "hub height (m)"
+rconfig  real   td_diameter    namelist,physics 1 60.    - - ""  "turbine diameter (m)"
+rconfig  real   td_stdthrcoef  namelist,physics 1 .158   - - ""  "standing thrust coefficient"
+rconfig  real   td_cutinspeed  namelist,physics 1 4.     - - ""  "cut-in speed (m/s)"
+rconfig  real   td_cutoutspeed namelist,physics 1 27.    - - ""  "cut-out speed (m/s)"
+rconfig  real   td_power       namelist,physics 1 2.     - - ""  "turbine power (MW)"
+rconfig  real   td_turbpercell namelist,physics 1 1.     - - ""  "number of turbines per cell"
+rconfig integer td_ewfx        namelist,physics 1 0      - - ""  "extent of wind farm in x-cells"
+rconfig integer td_ewfy        namelist,physics 1 0      - - ""  "extent of wind farm in y-cells"
+rconfig integer td_pwfx        namelist,physics 1 1      - - ""  "southwest corner of wind farm in x-cells"
+rconfig integer td_pwfy        namelist,physics 1 1      - - ""  "southwest corner of wind farm in y-cells"
+
+# LMDZ physic config add
+rconfig   integer lmdz_ksoil_types          namelist,domains   1         4
+rconfig   integer bottom_top_plus1          namelist,domains   1         1
+rconfig   integer num_orchidee_soil_levels  namelist,physics   1        11      irh          "num_orchidee_layers"     "Number of soil layers used in ORCHIDEE"
+rconfig   integer lmdz_ind_control          namelist,physics   1       100
+rconfig   integer lmdz_iflag_pbl            namelist,physics   1         1
+rconfig   integer lmdz_iflag_con            namelist,physics   1        30
+rconfig   integer lmdz_iflag_thermals       namelist,physics   1         0
+rconfig   integer lmdz_iflag_wake           namelist,physics   1         0
+rconfig   integer i_check_point             namelist,domains   1        15
+rconfig   integer j_check_point             namelist,domains   1        15
+rconfig   integer k_check_point             namelist,domains   1         1
+rconfig   logical lmdz_physics              namelist,physics   1        .true.
+
+#
+#---------------------------------------------------------------------------------------------------------------------------------------
+# Package Declarations
+#                                               
+
+#key      package       associated                package          associated 4d scalars
+#         name          namelist choice           state vars
+
+#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;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy
+package   wsm6scheme    mp_physics==6                -             moist:qv,qc,qr,qi,qs,qg
+package   gsfcgcescheme mp_physics==7                -             moist:qv,qc,qr,qi,qs,qg
+package   thompson      mp_physics==8                -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr
+package   milbrandt2mom mp_physics==9                -             state:refl_10cm;moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh
+package   morr_two_moment  mp_physics==10            -             moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng
+#package   milbrandt3mom mp_physics==12               -             moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qzr,qzi,qzs,qzg,qzh
+package   sbu_ylinscheme    mp_physics==13           -             moist:qv,qc,qr,qi,qs;state:rimi
+package   wdm5scheme    mp_physics==14               -             moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr
+package   wdm6scheme    mp_physics==16               -             moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr
+
+package   nodfimoist        mp_physics_dfi==-1       -             -
+package   passiveqv_dfi     mp_physics_dfi==0        -             dfi_moist:dfi_qv
+package   kesslerscheme_dfi mp_physics_dfi==1        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   linscheme_dfi     mp_physics_dfi==2        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   wsm3scheme_dfi    mp_physics_dfi==3        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   wsm5scheme_dfi    mp_physics_dfi==4        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs
+package   etampnew_dfi      mp_physics_dfi==5        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt
+package   wsm6scheme_dfi    mp_physics_dfi==6        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   gsfcgcescheme_dfi mp_physics_dfi==7        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   thompson_dfi      mp_physics_dfi==8        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr
+package   milbrandt2mom_dfi mp_physics_dfi==9        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh
+package   morr_two_moment_dfi  mp_physics_dfi==10    -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng
+#package   milbrandt3mom_dfi mp_physics_dfi==12       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qzr,dfi_qzi,dfi_qzs,dfi_qzg,dfi_qzh
+package   wdm5scheme_dfi    mp_physics_dfi==14       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+package   wdm6scheme_dfi    mp_physics_dfi==16       -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+
+package   noprogn       progn==0                     -             -
+package   progndrop     progn==1                     -             scalar:qndrop;dfi_scalar:dfi_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;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   rrtmg_lwscheme  ra_lw_physics==4           -             state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   goddardlwscheme  ra_lw_physics==5          -             state:tlwdn,tlwup,slwdn,slwup
+package   gfdllwscheme  ra_lw_physics==99            -             -
+package   heldsuarez    ra_lw_physics==31            -             -
+
+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;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   rrtmg_swscheme  ra_sw_physics==4           -             state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc
+package   goddardswscheme  ra_sw_physics==5          -             state:tswdn,tswup,sswdn,sswup
+package   gfdlswscheme  ra_sw_physics==99            -             -
+
+package   sfclayscheme   sf_sfclay_physics==1        -             -
+package   myjsfcscheme   sf_sfclay_physics==2        -             state:tke_pbl
+package   gfssfcscheme   sf_sfclay_physics==3        -             -
+package   qnsesfcscheme  sf_sfclay_physics==4        -             -
+package   mynnsfcscheme  sf_sfclay_physics==5        -             scalar:qke;state:tsq,qsq,cov
+package   pxsfcscheme    sf_sfclay_physics==7        -             -
+
+package   noahucmscheme  sf_urban_physics==1         -             state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep
+package   bepscheme      sf_urban_physics==2         -             state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d
+package   bep_bemscheme  sf_urban_physics==3         -             state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,sfwin1_urb3d,sfwin2_urb3d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d
+
+package   slabscheme     sf_surface_physics==1       -             -
+package   lsmscheme      sf_surface_physics==2       -             -
+package   ruclsmscheme   sf_surface_physics==3       -             state:smfr3d,keepfr3dflag,soilt1
+package   pxlsmscheme    sf_surface_physics==7       -             state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old
+package   temfsfcscheme  sf_sfclay_physics==10       -             state:wm_temf
+package   idealscmsfcscheme  sf_sfclay_physics==89   -             -
+
+package   ysuscheme      bl_pbl_physics==1           -             -
+package   myjpblscheme   bl_pbl_physics==2           -             state:tke_pbl,el_pbl
+package   gfsscheme      bl_pbl_physics==3           -             -
+package   qnsepblscheme  bl_pbl_physics==4           -             state:tke_pbl,el_pbl
+package   mynnpblscheme2 bl_pbl_physics==5           -             scalar:qke;state:tsq,qsq,cov
+package   mynnpblscheme3 bl_pbl_physics==6           -             scalar:qke;state:tsq,qsq,cov
+package   acmpblscheme   bl_pbl_physics==7           -             -
+package   boulacscheme   bl_pbl_physics==8           -             state:el_pbl,tke_pbl,wu_tur,wv_tur,wt_tur,wq_tur
+package   camuwpblscheme bl_pbl_physics==9           -             state:tauresx2d,tauresy2d,qpert2d,wpert2d,tke_pbl
+package   mrfscheme      bl_pbl_physics==99          -             -
+package   temfpblscheme  bl_pbl_physics==10          -             state:te_temf,kh_temf,km_temf,shf_temf,qf_temf,uw_temf,vw_temf,wupd_temf,mf_temf,thup_temf,qlup_temf,qtup_temf,cf3d_temf,hd_temf,lcl_temf,hct_temf,cfm_temf
+
+package   kfetascheme    cu_physics==1               -             -
+package   bmjscheme      cu_physics==2               -             -
+package   gdscheme       cu_physics==3               -             -
+package   sasscheme      cu_physics==4               -             -
+package   g3scheme       cu_physics==5               -             state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow
+package   camzmscheme    cu_physics==7               -             state:precz,zmdt,zmdq,zmdice,zmdliq,evaptzm,fzsntzm,evsntzm,evapqzm,zmflxprc,zmflxsnw,zmntprpd,zmntsnpd,zmeiheat,cmfmc,cmfmcdzm,preccdzm,pconvb,pconvt,cape,zmmtu,zmmtv,zmmu,zmmd,zmupgu,zmupgd,zmvpgu,zmvpgd,zmicuu,zmicud,zmicvu,zmicvd
+package   g3tave         cu_diag==1                  -             state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,RAINCV_A,RAINCV_B,GD_CLOUD_A,GD_CLOUD_B,GD_CLOUD2_A,GD_CLOUD2_B,kbcon_deep,ktop_deep,k22_deep
+package   tiedtkescheme  cu_physics==6               -             -
+package   nsasscheme     cu_physics==14              -             -
+package   kfscheme       cu_physics==99              -             -
+
+package   g3shcuscheme   shcu_physics==1             -             -
+package   camuwshcuscheme shcu_physics==2            -             state:cmfmc,cmfmc2,qtflx_cu,slflx_cu,uflx_cu,vflx_cu,qtten_cu,slten_cu,uten_cu,vten_cu,qvten_cu,qlten_cu,qiten_cu,cbmf_cu,ufrcinvbase_cu,ufrclcl_cu,winvbase_cu,wlcl_cu,plcl_cu,pinv_cu,plfc_cu,pbup_cu,ppen_cu,qtsrc_cu,thlsrc_cu,thvlsrc_cu,emkfbup_cu,cin_cu,cinlcl_cu,cbmflimit_cu,tkeavg_cu,zinv_cu,rcwp_cu,rlwp_cu,riwp_cu,tophgt_cu,wu_cu,ufrc_cu,qtu_cu,thlu_cu,thvu_cu,uu_cu,vu_cu,qtu_emf_cu,thlu_emf_cu,uu_emf_cu,vu_emf_cu,umf_cu,uemf_cu,qcu_cu,qlu_cu,qiu_cu,cufrc_cu,fer_cu,fdr_cu,dwten_cu,diten_cu,qrten_cu,qsten_cu,flxrain_cu,flxsnow_cu,ntraprd_cu,ntsnprd_cu,excessu_cu,excessu0_cu,xc_cu,aquad_cu,bquad_cu,cquad_cu,bogbot_cu,bogtop_cu,exit_uwcu_cu,exit_conden_cu,exit_klclmkx_cu,exit_klfcmkx_cu,exit_ufrc_cu,exit_wtw_cu,exit_drycore_cu,exit_wu_cu,exit_cufliter_cu,exit_kinv1_cu,exit_rei_cu,limit_shcu_cu,limit_negcon_cu,limit_ufrc_cu,limit_ppen_cu,limit_emf_cu,limit_cinlcl_cu,limit_cin_cu,limit_cbmf_cu,limit_rei_cu,ind_delcin_cu,evapcsh,cmfsl,cmflq,cldfrash,cush,icwmrsh,snowsh,rprdsh,rliq2
+
+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;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten
+package   psusfddagd     grid_sfdda==1               -             state:u10_ndg_old,v10_ndg_old,t2_ndg_old,th2_ndg_old,q2_ndg_old,rh_ndg_old,psl_ndg_old,ps_ndg_old,u10_ndg_new,v10_ndg_new,t2_ndg_new,th2_ndg_new,q2_ndg_new,rh_ndg_new,psl_ndg_new,ps_ndg_new,tob_ndg_old,odis_ndg_old,tob_ndg_new,odis_ndg_new
+
+package   spnudging      grid_fdda==2               -              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;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten
+
+package   slopeopt       slope_rad==1               -              -
+package   gwdopt         gwd_opt==1                 -              state:var2d,oc12d,oa1,oa2,oa3,oa4,ol1,ol2,ol3,ol4,dtaux3d,dtauy3d,dusfcg,dvsfcg
+package   omlopt         omlcall==1                 -              state:tml,t0ml,hml,h0ml,huml,hvml,tmoml
+package   scmopt         scm_force==1               -              state:z_force,z_force_tend,u_g,u_g_tend,v_g,v_g_tend,w_subs,w_subs_tend,th_upstream_x,th_upstream_x_tend,th_upstream_y,th_upstream_y_tend,qv_upstream_x,qv_upstream_x_tend,qv_upstream_y,qv_upstream_y_tend,u_upstream_x,u_upstream_x_tend,u_upstream_y,u_upstream_y_tend,v_upstream_x,v_upstream_x_tend,v_upstream_y,v_upstream_y_tend,tau_x,tau_x_tend,tau_y,tau_y_tend,th_largescale,th_largescale_tend,qv_largescale,qv_largescale_tend,ql_largescale,ql_largescale_tend,u_largescale,u_largescale_tend,v_largescale,v_largescale_tend,tau_largescale,tau_largescale_tend,ql_upstream_x,ql_upstream_x_tend,ql_upstream_y,ql_upstream_y_tend,t_soil_forcing_val,t_soil_forcing_tend,q_soil_forcing_val,q_soil_forcing_tend,tau_soil,soil_depth_force
+
+package   prec_acc       prec_acc_opt==1            -              state:prec_acc_c,prec_acc_nc,snow_acc_nc
+package   bucketropt     bucketr_opt==1             -              state:i_rainc,i_rainnc
+
+package   restofwrf      use_wps_input==0            -             -
+
+package   original         moist_adv_opt==0            -             -
+package   positivedef    moist_adv_opt==1            -             -
+package   monotonic      moist_adv_opt==2            -             -
+package   tracer_test1  tracer_opt==2       -             tracer:tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8
+
+package   dfi_setup      dfi_stage==0                -             -
+package   dfi_bck        dfi_stage==1                -             -
+package   dfi_fwd        dfi_stage==2                -             -
+package   dfi_fst        dfi_stage==3                -             -
+package   dfi_startfwd   dfi_stage==4                -             -
+package   dfi_startbck   dfi_stage==5                -             -
+
+#package   digifilter     dfi_opt==1                  -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_rh,dfi_tten_rad
+package   dfi_nodfi     dfi_opt==0                  -             -
+package   dfi_dfl       dfi_opt==1                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   dfi_ddfi      dfi_opt==2                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   dfi_tdfi      dfi_opt==3                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   realonly       use_wps_input==1            -             state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc
+
+
+# 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                     -             -
+             
+# Tendency diagnostics for non-chemistry
+#
+# Placeholders for decoupled advective tendency arrays
+package   notenddiag    tenddiag==0                     -             -
+package   usetenddiag   tenddiag==1                     -             -
+                                   
+#---------------------------------------------------------------------------------------------------------------------------------------
+## 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,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,f,e,sina,cosa,ht,potevp,snopcx,soiltb,xlat,xlong,xlat_u,xlat_v,xlong_u,xlong_v,clat,clong
+halo      HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar,tracer
+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_PHYS_CU dyn_em         4:rucuten,rvcuten
+halo      HALO_EM_PHYS_SHCU dyn_em       4:rushten,rvshten
+halo      HALO_EM_FDDA dyn_em            4:rundgdten,rvndgdten
+halo      HALO_EM_FDDA_SFC dyn_em 48:z,z_at_w,pblh,regime,znt,odis_ndg_old,odis_ndg_new
+halo      HALO_EM_PHYS_DIFFUSION dyn_em  4:defor11,defor22,defor12,defor13,defor23,div,xkmv,xkmh,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,ustm
+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,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,muts
+halo      HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,tracer,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,tracer,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,tracer,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,tracer,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_CUP_G3_IN dyn_em 24:RTHFTEN,RQVFTEN,w_2,t_phy
+halo      HALO_CUP_G3_OUT dyn_em 48:cugd_tten,cugd_qvten,cugd_ttens,cugd_qvtens,raincv
+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_TRACER_E_3 dyn_em 24:tracer
+halo      HALO_EM_TRACER_E_5 dyn_em 48:tracer
+halo      HALO_EM_TRACER_E_7 dyn_em 80:tracer
+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_TOPOSHAD phys 24:ht_shad
+
+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_TRACER_OLD_E_3 dyn_em 24:tracer_old
+halo      HALO_EM_TRACER_OLD_E_5 dyn_em 48:tracer_old
+halo      HALO_EM_TRACER_OLD_E_7 dyn_em 80:tracer_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_HYDRO_UV   dyn_em 8:u_2,v_2
+
+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,tracer,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,tracer,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:ph_2,p,uratx,vratx,tratx,kpbl
+
+# 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,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,sina,cosa,e,f
+
+# Monotonic, positive definite advection requires 4 values for moist, chem, tke, and scalar for periodic lateral boundaries
+
+period    PERIOD_BDY_EM_MOIST dyn_em 4:moist
+period    PERIOD_BDY_EM_CHEM dyn_em 4:chem
+period    PERIOD_BDY_EM_TRACER dyn_em 4:tracer
+period    PERIOD_BDY_EM_SCALAR dyn_em 4:scalar
+period    PERIOD_BDY_EM_TKE dyn_em 4:tke_2
+period    PERIOD_BDY_EM_MOIST2 dyn_em 4:moist
+period    PERIOD_BDY_EM_CHEM2 dyn_em 4:chem
+period    PERIOD_BDY_EM_TRACER2 dyn_em 4:tracer
+period    PERIOD_BDY_EM_SCALAR2 dyn_em 4:scalar
+period    PERIOD_BDY_EM_MOIST_OLD dyn_em 4:moist_old
+period    PERIOD_BDY_EM_CHEM_OLD dyn_em 4:chem_old
+period    PERIOD_BDY_EM_TRACER_OLD dyn_em 4:tracer_old
+period    PERIOD_BDY_EM_SCALAR_OLD dyn_em 4:scalar_old
+period    PERIOD_BDY_EM_TKE_OLD dyn_em 4:tke_1
+
+period    PERIOD_BDY_EM_E dyn_em 2:u_2,v_2,ht
+period    PERIOD_EM_HYDRO_UV dyn_em 1:u_2,v_2
+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,ustm
+period    PERIOD_BDY_EM_PHY_BC dyn_em 2:rublten,rvblten,rucuten,rvcuten,xkmh,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,msfvx,msfvy,muu,msfux,msfuy,msfvx_inv
+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
+period    PERIOD_EM_DA dyn_em 2:ru_m,rv_m,ww_m,mut,muts
+
+#
+#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 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 NSTAW        # number of obs stations within current time window
+typedef fdob_type integer KTAUR        # restart model step
+typedef fdob_type integer LEVIDN(max_domains)   # level of nest
+typedef fdob_type integer REFPRT(max_domains)   # reference obs index for diagnostic printout
+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 logical NUDGE_UV_PBL # Flag for wind nudging within the PBL
+typedef fdob_type logical NUDGE_T_PBL  # Flag for temperature nudging within the PBL
+typedef fdob_type logical NUDGE_Q_PBL  # Flag for moisture nudging within the PBL
+typedef fdob_type integer SFC_SCHEME_HORIZ # Flag for horizontal spreading scheme for surface obs
+typedef fdob_type integer SFC_SCHEME_VERT  # Flag for vertical   spreading scheme for surface obs
+typedef fdob_type real    MAX_SNDNG_GAP # Maximum pressure gap allowed for interpolating between soundings (centibars)
+typedef fdob_type real    SFCFACT      # scale factor applied to time window for surface obs
+typedef fdob_type real    SFCFACR      # scale factor applied to horiz radius of influence for surface obs
+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    KNOWN_LAT    # Latitude  of origin point (i,j)=(1,1)
+typedef fdob_type real    KNOWN_LON    # Longitude of origin point (i,j)=(1,1)
+typedef fdob_type character SDATE      # domain starting date (YYYY-MM-DD_hh:mm:ss)
+typedef fdob_type real    XTIME_AT_REST # xtime at restart time
+typedef fdob_type real    VIF_UV(6)    # Vertical influence function parameters for wind nudging
+typedef fdob_type real    VIF_T(6)     # Vertical influence function parameters for temperature nudging
+typedef fdob_type real    VIF_Q(6)     # Vertical influence function parameters for moisture nudging
+typedef fdob_type real    VIF_FULLMIN  # Minimum depth through which vert infl fcn remains 1.0 (m)
+typedef fdob_type real    VIF_RAMPMIN  # Minimum depth through which vif decreases 1.0 to 0.0 (m)
+typedef fdob_type real    VIF_MAX      # Maximum depth in which vif is nonzero (m)
+
+# table entries are of the form
+#      <Table>  <Type>  <Sym>                <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>
+#Grid variables
+typedef fdob_type real    varobs         {nndgvar}{obs} -         1        -       -       "varobs"          "observational values in each variable"
+typedef fdob_type real    errf              h{obs}      -         1        -       -       "errf"            "errors between model and obs values"
+typedef fdob_type real    timeob             {obs}      -         1        -       -       "timeob"          "model times for each observation"          "hours"
+typedef fdob_type real    nlevs_ob           {obs}      -         1        -       -       "nlevs_ob"        "numbers of levels in sounding obs"
+typedef fdob_type real    lev_in_ob          {obs}      -         1        -       -       "lev_in_ob"       "level in sounding-type obs"
+typedef fdob_type real    plfo               {obs}      -         1        -       -       "plfo"            "index for type of obs-platform"
+typedef fdob_type real    elevob             {obs}      -         1        -       -       "elevob"          "elevation of observation"                  "meters"
+typedef fdob_type real    rio                {obs}      -         1        -       -       "rio"             "west-east grid coordinate"
+typedef fdob_type real    rjo                {obs}      -         1        -       -       "rjo"             "south-north grid coordinate"
+typedef fdob_type real    rko                {obs}      -         1        -       -       "rko"             "vertical grid coordinate"
+typedef fdob_type integer obsprt               [        -         1        -       -       "obsprt"          "obs index for diagnostic printout"
+typedef fdob_type real    latprt               [        -         1        -       -       "latprt"          "obs latitude for diagnostic printout"
+typedef fdob_type real    lonprt               [        -         1        -       -       "lonprt"          "obs longitude for diagnostic printout"
+typedef fdob_type real    mlatprt              [        -         1        -       -       "mlatprt"         "model latitude at obs location"
+typedef fdob_type real    mlonprt              [        -         1        -       -       "mlonprt"         "model longitude at obs location"
+typedef fdob_type integer stnidprt       {obsstid}{[}   -         1        -       -       "stnidprt"        "obs station id for diagnostic printout"
+typedef fdob_type real    base_state           k        -         1        -       -       "base_state"      "base-state height on half (mass) levels"   "meters"
+
+state fdob_type fdob - -
+
+# xpose variables for polar fft
+state    real   t_xxx          ikjx    -           1        -
+state    real   u_xxx          ikjx    -           1        X
+state    real   ru_xxx         ikjx    -           1        X
+state    real   v_xxx          ikjx    -           1        Y
+state    real   rv_xxx         ikjx    -           1        Y
+state    real   w_xxx          ikjx    -           1        Z
+state    real   ww_xxx         ikjx    -           1        Z
+state    real   ph_xxx         ikjx    -           1        Z
+state    real   dum_yyy        ikjy    -           1        -
+state    real   fourd_xxx      ikjx    -           1        -
+state    real   clat_xxx       ijx     -           1        -
+state    real   ht_xxx         ijx     -           1        -
+state    real   mf_xxx         ijx     -           1        -
+
+xpose XPOSE_POLAR_FILTER_TOPO dyn_em t_init,t_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_T  dyn_em t_2,t_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_U  dyn_em u_2,u_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_RU dyn_em ru_m,ru_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_V  dyn_em v_2,v_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_RV dyn_em rv_m,rv_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_W  dyn_em w_2,w_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_WW dyn_em ww_m,ww_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_PH dyn_em ph_2,ph_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_MOIST dyn_em moist,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_CHEM dyn_em chem,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_TRACER dyn_em tracer,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_SCALAR dyn_em scalar,fourd_xxx,dum_yyy
+
+# xpose variables for spectral nudging
+state    real   dif_analysis     ikj     -           1
+state    real   dif_xxx          ikjx    -           1     
+state    real   dif_yyy          ikjy    -           1     
+
+xpose XPOSE_SPECTRAL_NUDGING dyn_em dif_analysis,dif_xxx,dif_yyy
+##
+
+include registry.fire
+include registry.avgflx
+include registry.stoch
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.wrfvar
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.wrfvar	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/Registry.wrfvar	(revision 17)
@@ -0,0 +1,2882 @@
+# Registry file, WRFVAR
+#                                               
+# 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=<variable name>".  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.
+#
+
+include registry.dimspec
+
+################################################################################
+################################################################################
+################################################################################
+
+#state    real   floob       ijkb     dyn_em      1         -    
+#state    real   floob_x     ijkx     dyn_em      1         -     
+#state    real   floob_y     ijky     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                                         
+#<Table> <Type> <Sym>         <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>   
+#
+
+# 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         -     i012rh01d=(interp_fcnm)u=(copy_fcnm)   "LU_INDEX"              "LAND USE CATEGORY"         ""
+state    real  LU_MASK          ij      misc        1         -     i3h1     "LU_MASK"              "0 land 1 water"         ""
+
+# znw, znu, dzs, and zs must be listed before any 3-d fields
+# in order for the grib output module to work correctly.  The grib output
+# module retrieves the vertical levels from these parameters.  If znw, znu
+# dzs, and zs are not listed first, vertical level will not be encoded at 
+# time 0.
+
+state    real    znu            k       dyn_em      1         -     irh       "znu"  "eta values on half (mass) levels"  ""
+state    real    znw            k       dyn_em      1         Z     i0rh     "znw"  "eta values on full (w) levels"  ""
+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"
+
+#
+# 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   prho_gc        igj      dyn_em      1        Z     i1  "PTHETA" "for UM data, from metgrid this is ptheta, but swapped to prho in real" "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   sct_dom_gc     ij       dyn_em      1        -     i1  "SCT_DOM"  "Dominant soil (top) category from GEOGRID"  "cat"
+state    real   scb_dom_gc     ij       dyn_em      1        -     i1  "SCB_DOM"  "Dominant soil (bottom) category from GEOGRID"  "cat"
+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   pdrho_gc       igj      dyn_em      1        Z     -   "PDRHO"    "dry pressure for UM data for the variables U and V"   "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   sh_gc          igj      dyn_em      1        Z     i1  "SPECHUMD"  "Specific humidity"        "kg kg-1"
+state    real   icefrac_gc     ij       dyn_em      1        -     i1  "ICEFRAC"  "Sea ice fraction"  "0 - 1 fraction"
+ifdef RUC_CLOUD
+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"
+state    real   qh_gc          igj      dyn_em      1        Z     i1  "QH"    "hail mixing ratio"   "kg kg-1"
+state    real   qni_gc         igj      dyn_em      1        Z     i1  "QNI"   "ice no concentration"   "m-3"
+endif
+
+#-----------------------------------------------------------------------------------------------------------------------------------------------------------------
+#                                               
+# Variables for Eulerian mass coordinate dynamics                                            
+#                                               
+
+
+# Velocities
+#
+# U Vel
+state    real   u              ijkb     dyn_em      2         X     \
+     i01rhusdf=(bdy_interp:dt)       "U"                      "x-wind component"   "m s-1"
+state    real   ru             ijk     dyn_em      1         X      -        "MU_U"        "mu-coupled u"   "Pa m s-1"
+state    real   ru_m           ijk     dyn_em      1         X      -        "ru_m"        ""   ""
+state    real   ru_tend        ijk     dyn_em      1         X      -        "ru_tend"        ""   ""                                   
+i1       real   ru_tendf       ijk     dyn_em      1         X                                          
+state    real   u_save         ijk     dyn_em      1         X      -        "u_save"
+state    real   z_force        |       dyn_em      1         -      i3rh     "Z_FORCE" "height of forcing input" "m"
+state    real   z_force_tend   |       dyn_em      1         -      i3rh     "Z_FORCE_TEND" "tendency height of forcing input" "m"
+state    real   u_g            |       dyn_em      1         -      i3rh     "U_G" "x-direction geostrophic wind" "m s-1"
+state    real   u_g_tend       |       dyn_em      1         -      i3rh     "U_G_TEND" "tendency x-direction geostrophic wind" "m s-1"
+state    real   a_u            ijk     misc        2         X      rh       "A_U"                    "x-wind component"   "m s-1"
+state    real   g_u            ijk     misc        2         X      rh       "G_U"                    "x-wind component"   "m s-1"
+#                                               
+# V Vel
+state    real   v              ijkb     dyn_em      2         Y     \
+     i01rhusdf=(bdy_interp:dt)        "V"                     "y-wind component"   "m s-1"
+state    real   rv             ijk     dyn_em      1         Y      -        "MU_V"        "mu-coupled v"   "Pa m s-1"
+state    real   rv_m           ijk     dyn_em      1         Y      -        "rv_m"
+state    real   rv_tend        ijk     dyn_em      1         Y      -        "rv_tend"
+i1       real   rv_tendf       ijk     dyn_em      1         Y                                          
+state    real   v_save         ijk     dyn_em      1         Y      -        "v_save"                   
+state    real   v_g            |       dyn_em      1         -      i3rh     "V_G" "y-direction geostrophic wind" "m s-1"
+state    real   v_g_tend       |       dyn_em      1         -      i3rh     "V_G_TEND" "tendency y-direction geostrophic wind" "m s-1"
+state    real   a_v            ijk     misc        2         Y      rh       "A_V"                     "y-wind component"   "m s-1"
+state    real   g_v            ijk     misc        2         Y      rh       "G_V"                     "y-wind component"   "m s-1"
+#                                               
+# Vertical Vel                                          
+state    real   w              ijkb     dyn_em      2         Z     \
+        irhusdf=(bdy_interp:dt)  "w"                          "z-wind component"   "m s-1"
+state    real   ww             ijk     dyn_em      1         Z      r         "ww"   "mu-coupled eta-dot"    "Pa s-1"
+state    real   rw             ijk     dyn_em      1         Z      -         "rw"   "mu-coupled w"          "Pa m s-1"
+i1       real   ww1            ijk     dyn_em      1         Z                                          
+state    real   ww_m           ijk     dyn_em      1         Z      r         "ww_m"   "time-avg mu-coupled eta-dot"    "Pa s-1"
+i1       real   wwp            ijk     dyn_em      1         Z                                          
+i1       real   rw_tend        ijk     dyn_em      1         Z                                          
+i1       real   rw_tendf       ijk     dyn_em      1         Z                                          
+i1       real   w_save         ijk     dyn_em      1         Z                                          
+state    real   w_subs         |       dyn_em      1         -      i3rh      "W_SUBS" "large-scale vertical velocity" "m s-1"
+state    real   w_subs_tend    |       dyn_em      1         -      i3rh      "W_SUBS_TEND" "tendency large-scale vertical velocity" "m s-1"
+state    real   a_w            ijk     misc        2         Z      rh        "A_W"                        "z-wind component"   "m s-1"
+state    real   g_w            ijk     misc        2         Z      rh        "A_W"                        "z-wind component"   "m s-1"
+
+# Geopotential
+state    real   ph             ijkb     dyn_em      2         Z     \
+       irhusdf=(bdy_interp:dt)   "ph"   "perturbation geopotential"  "m2 s-2"
+state    real   phb            ijk     dyn_em      1         Z     irhdus "phb"  "base-state geopotential"  "m2 s-2"
+state    real   phb_fine       ijk     dyn_em      1         Z      -     "phb_fine"  "for nesting, temp holding interpolated coarse grid phb"  "m2 s-2"
+state    real   ph0            ijk     dyn_em      1         Z      r     "ph0"  "initial geopotential"     "m2 s-2"
+state    real   php            ijk     dyn_em      1         -      r     "php"  "geopotential"             "m2 s-2"
+i1       real   ph_tend        ijk     dyn_em      1         Z 
+i1       real   ph_tendf       ijk     dyn_em      1         Z 
+i1       real   ph_save        ijk     dyn_em      1         Z 
+state    real   a_ph           ijk     misc        2         Z      rh    "A_PH"   "perturbation geopotential"  "m2 s-2"
+state    real   g_ph           ijk     misc        2         Z      rh    "G_PH"   "perturbation geopotential"  "m2 s-2"
+
+# Potential Temperature
+state    real   t              ijkb     dyn_em      2         -     \
+       i01rhusdf=(bdy_interp:dt)   "t"      "perturbation potential temperature (theta-t0)" "K"
+state    real   t_init         ijk     dyn_em      1         -      ir       "t_init" "initial potential temperature" "K"
+i1       real   t_tend         ijk     dyn_em      1         -  
+i1       real   t_tendf        ijk     dyn_em      1         -  
+i1       real   t_2save        ijk     dyn_em      1         -   
+state    real   t_save         ijk     dyn_em      1         -      -        "t_save"
+state    real   a_t            ijk     misc        2         -      rh       "A_T"      "perturbation potential temperature (theta-t0)" "K"
+state    real   g_t            ijk     misc        2         -      rh       "G_T"      "perturbation potential temperature (theta-t0)" "K"
+
+state    real   th_upstream_x       |     dyn_em      1      -      i3rh     "TH_UPSTREAM_X" "upstream theta x-advection" "K s-1"
+state    real   th_upstream_x_tend  |     dyn_em      1      -      i3rh     "TH_UPSTREAM_X_TEND" "tendency upstream theta x-advection" "K s-2"
+state    real   th_upstream_y       |     dyn_em      1      -      i3rh     "TH_UPSTREAM_Y" "upstream theta y-advection" "K s-1"
+state    real   th_upstream_y_tend  |     dyn_em      1      -      i3rh     "TH_UPSTREAM_Y_TEND" "tendency upstream theta y-advection" "K s-2"
+
+state    real   qv_upstream_x       |     dyn_em      1      -      i3rh     "QV_UPSTREAM_X" "upstream qv x-advection" "kg kg-1 s-1"
+state    real   qv_upstream_x_tend  |     dyn_em      1      -      i3rh     "QV_UPSTREAM_X_TEND" "tendency upstream qv x-advection" "kg kg-1 s-2"
+state    real   qv_upstream_y       |     dyn_em      1      -      i3rh     "QV_UPSTREAM_Y" "upstream qv y-advection" "kg kg-1 s-1"
+state    real   qv_upstream_y_tend  |     dyn_em      1      -      i3rh     "QV_UPSTREAM_Y_TEND" "tendency upstream qv y-advection" "kg kg-1 s-2"
+
+state    real   ql_upstream_x       |     dyn_em      1      -      i3rh     "QL_UPSTREAM_X" "upstream ql x-advection" "kg kg-1 s-1"
+state    real   ql_upstream_x_tend  |     dyn_em      1      -      i3rh     "QL_UPSTREAM_X_TEND" "tendency upstream ql x-advection" "kg kg-1 s-2"
+state    real   ql_upstream_y       |     dyn_em      1      -      i3rh     "QL_UPSTREAM_Y" "upstream ql y-advection" "kg kg-1 s-1"
+state    real   ql_upstream_y_tend  |     dyn_em      1      -      i3rh     "QL_UPSTREAM_Y_TEND" "tendency upstream ql y-advection" "kg kg-1 s-2"
+
+state    real   u_upstream_x        |     dyn_em      1      -      i3rh     "U_UPSTREAM_X" "upstream u x-advection" "m s-2"
+state    real   u_upstream_x_tend   |     dyn_em      1      -      i3rh     "U_UPSTREAM_X_TEND" "tendency upstream u x-advection" "m s-3"
+state    real   u_upstream_y        |     dyn_em      1      -      i3rh     "U_UPSTREAM_Y" "upstream u y-advection" "m s-2"
+state    real   u_upstream_y_tend   |     dyn_em      1      -      i3rh     "U_UPSTREAM_Y_TEND" "tendency upstream u y-advection" "m s-3"
+
+state    real   v_upstream_x        |     dyn_em      1      -      i3rh     "V_UPSTREAM_X" "upstream v x-advection" "m s-2"
+state    real   v_upstream_x_tend   |     dyn_em      1      -      i3rh     "V_UPSTREAM_X_TEND" "tendency upstream v x-advection" "m s-3"
+state    real   v_upstream_y        |     dyn_em      1      -      i3rh     "V_UPSTREAM_Y" "upstream v y-advection" "m s-2"
+state    real   v_upstream_y_tend   |     dyn_em      1      -      i3rh     "V_UPSTREAM_Y_TEND" "tendency upstream v y-advection" "m s-3"
+
+state    real   th_largescale       |     dyn_em      1      -      i3rh     "TH_LARGESCALE" "SCM largescale theta" "K"
+state    real   th_largescale_tend  |     dyn_em      1      -      i3rh     "TH_LARGESCALE_TEND" "SCM tendency largescale theta" "K s-1"
+
+state    real   qv_largescale       |     dyn_em      1      -      i3rh     "QV_LARGESCALE" "SCM largescale qv" "kg kg-1 s-1"
+state    real   qv_largescale_tend  |     dyn_em      1      -      i3rh     "QV_LARGESCALE_TEND" "SCM tendency largescale qv" "kg kg-1 s-2"
+
+state    real   ql_largescale       |     dyn_em      1      -      i3rh     "QL_LARGESCALE" "SCM largescale ql" "kg kg-1 s-1"
+state    real   ql_largescale_tend  |     dyn_em      1      -      i3rh     "QL_LARGESCALE_TEND" "SCM tendency largescale ql" "kg kg-1 s-2"
+
+state    real   u_largescale        |     dyn_em      1      -      i3rh     "U_LARGESCALE" "SCM largescale u" "m s-2"
+state    real   u_largescale_tend   |     dyn_em      1      -      i3rh     "U_LARGESCALE_TEND" "SCM tendency largescale u" "m s-3"
+
+state    real   v_largescale        |     dyn_em      1      -      i3rh     "V_LARGESCALE" "SCM largescale v" "m s-2"
+state    real   v_largescale_tend   |     dyn_em      1      -      i3rh     "V_LARGESCALE_TEND" "SCM tendency largescale v" "m s-3"
+
+state    real   tau_largescale       |     dyn_em      1      -      i3rh     "TAU_LARGESCALE" "SCM largescale timescale" "s"
+state    real   tau_largescale_tend  |     dyn_em      1      -      i3rh     "TAU_LARGESCALE_TEND" "SCM tendency largescale timescale" ""
+
+state    real   tau_x               |     dyn_em      1      -      i3rh     "TAU_X" "X-direction advective timescale" "s"
+state    real   tau_x_tend          |     dyn_em      1      -      i3rh     "TAU_X_TEND" "tendency X-direction advective timescale" ""
+state    real   tau_y               |     dyn_em      1      -      i3rh     "TAU_Y" "Y-direction advective timescale" "s"
+state    real   tau_y_tend          |     dyn_em      1      -      i3rh     "TAU_Y_TEND" "tendency Y-direction advective timescale" ""
+
+dimspec  fslay  2     namelist=num_force_soil_layers    z     force_soil_layers
+state    real   t_soil_forcing_val  {fslay}     dyn_em      1      -      i3rh     "T_SOIL_FORCING_VAL" "Soil temp value for SCM forcing" "K"
+state    real   t_soil_forcing_tend {fslay}     dyn_em      1      -      i3rh     "T_SOIL_FORCING_TEND" "tendency soil temp for SCM forcing" "K s-1"
+state    real   q_soil_forcing_val  {fslay}     dyn_em      1      -      i3rh     "Q_SOIL_FORCING_VAL" "Soil moisture value for SCM forcing" "1"
+state    real   q_soil_forcing_tend {fslay}     dyn_em      1      -      i3rh     "Q_SOIL_FORCING_TEND" "tendency soil moisture for SCM forcing" "s-1"
+state    real   tau_soil            {fslay}     dyn_em      1      -      i3rh     "TAU_SOIL" "SCM soil forcing timescale" "s"
+state    real   soil_depth_force    {fslay}     dyn_em      1      -      i3rh     "SOIL_DEPTH_FORCE" "SCM depth at center of soil layers in forcing file" "1"
+
+state    real   hfx_force           -     dyn_em      1      -      i3rh     "HFX_FORCE" "SCM ideal surface sensible heat flux" "W m-2"
+state    real   lh_force            -     dyn_em      1      -      i3rh     "LH_FORCE" "SCM ideal surface latent heat flux" "W m-2"
+state    real   tsk_force           -     dyn_em      1      -      i3rh     "TSK_FORCE" "SCM ideal surface skin temperature" "W m-2"
+state    real   hfx_force_tend      -     dyn_em      1      -      i3rh     "HFX_FORCE_TEND" "SCM ideal surface sensible heat flux tendency" "W m-2 s-1"
+state    real   lh_force_tend       -     dyn_em      1      -      i3rh     "LH_FORCE_TEND" "SCM ideal surface latent heat flux tendency" "W m-2 s-1"
+state    real   tsk_force_tend      -     dyn_em      1      -      i3rh     "TSK_FORCE_TEND" "SCM ideal surface skin temperature tendency" "W m-2 s-1"
+# 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   mub_save        ij     dyn_em      1         -      -           "mub_save" "nest temp, holds orig fine grid mub" "Pa"
+state    real   mu0             ij     dyn_em      1         -      i1          "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          -     
+state    real   a_mu            ij     misc        2          -     rh          "A_MU"  "perturbation dry air mass in column" "Pa"
+state    real   g_mu            ij     misc        2          -     rh          "G_MU"  "perturbation dry air mass in column" "Pa"
+
+#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            ijk     dyn_em      2         -       r        "tke"          "TURBULENCE KINETIC ENERGY"     "m2 s-2"
+i1       real   tke_tend       ijk     dyn_em      1         -      
+
+# Pressure and Density
+state    real   p              ijk     dyn_em      1         -      irh       "p"           "perturbation pressure"         "Pa"
+state    real   al             ijk     dyn_em      1         -      r         "al"          "inverse perturbation density"  "m3 kg-1"
+state    real   alt            ijk     dyn_em      1         -      r         "alt"         "inverse density"               "m3 kg-1"
+state    real   alb            ijk     dyn_em      1         -      rdus      "alb"         "inverse base density"          "m3 kg-1"
+state    real   zx             ijk     dyn_em      1         X      -         " "  " "  " "    
+state    real   zy             ijk     dyn_em      1         Y      -         " "  " "  " "   
+state    real   rdz            ijk     dyn_em      1         Z      -         " "  " "  " "   
+state    real   rdzw           ijk     dyn_em      1         Z      -         " "  " "  " "   
+state    real   pb             ijk     dyn_em      1         -      irhdus    "pb"          "BASE STATE PRESSURE "          "Pa"
+
+#                                               
+# Other dyn                                             
+#                                               
+i1       real   advect_tend    ijk     dyn_em      1         -                                          
+i1       real   alpha          ijk     dyn_em      1         -                                                  
+i1       real   a              ijk     dyn_em      1         -                                                  
+i1       real   gamma          ijk     dyn_em      1         -                                                  
+i1       real   c2a            ijk     dyn_em      1         -     -
+i1       real   rho            ijk     dyn_em      1         -     -
+i1       real   phm            ijk     dyn_em      1         -     -
+i1       real   cqu            ijk     dyn_em      1         -     -
+i1       real   cqv            ijk     dyn_em      1         -     -
+i1       real   cqw            ijk     dyn_em      1         -     -
+i1       real   pm1            ijk     dyn_em      1         -     -
+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    t_base         k       dyn_em      1         -     ir        "t_base"               "BASE STATE T IN IDEALIZED CASES"         "K"      
+state    real    z              ijk     dyn_em      1         -     -         " " " " " "
+state    real    z_at_w         ijk     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"  ""
+state    real    a_z            ijk     misc        1         Z     -         " " " " " "
+state    real    g_z            ijk     misc        1         Z     -         " " " " " "
+
+# For the adaptive timestep restart
+state    logical stepping_to_time       - misc    -         -      r     "stepping_to_time"         ""
+state    integer last_step_updated      - misc    -         -      r     "last_step_updated"        ""
+state    logical adapt_step_using_child - misc    -         -      r     "adapt_step_using_child"   ""
+state    integer last_dt_sec            - misc    -         -      r     "last_dt_sec"              "Whole seconds for last timestep"  "sec"
+state    integer last_dt_sec_num        - misc    -         -      r     "last_dt_sec_num"          "Fractional secs, numerator"       "sec"
+state    integer last_dt_sec_den        - misc    -         -      r     "last_dt_sec_den"          "Fractional secs, denominator"     "sec"
+state    integer last_dt_yr             - misc    -         -      r     "last_dt_yr"               "Relative year"                    "years"
+state    integer last_dt_mm             - misc    -         -      r     "last_dt_mm"               "Relative month"                   "months"
+
+# hydrostatic pressure vars
+state    real   p_hyd           ijk     dyn_em      1         -      irh       "p_hyd"       "hydrostatic pressure"         "Pa"
+state    real   p_hyd_w         ijk     dyn_em      1         Z       r        "p_hyd_w"     "hydrostatic pressure at full levels"         "Pa"
+
+# For KMA, pressure coefficient.
+state    real    kma_a          k       misc        1         Z     -         "A"  "KMA Constants A to convert surface presure to full level pressure" "dimensionless"
+state    real    kma_b          k       misc        1         Z     -         "B"  "KMA Constants B to convert surface presure to full level pressure" "dimensionless"
+
+# 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         -     i01rhd    "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         -     i01rhd    "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         -      r          "URATX"            "Ratio of U over U10 on mass points "         "dimensionless"
+state    real   vratx           ij      misc        1         -      r          "VRATX"            "Ratio of V over V10 on mass points "         "dimensionless"   
+state    real   tratx           ij      misc        1         -      r          "TRATX"            "Ratio of T over TH2 on mass points "         "dimensionless"   
+state    real   obs_savwt      hijk     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"         ""         ""    
+# indicates whether to recompute mu                                                             
+state   logical press_adj      -        -          -         -     -         "press_adj"         "T/F flag adjust mu"         ""    
+
+# 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    -              ijkftb   moist       1         -     -    -
+state   real    qv             ijkftb   moist       1         -     \
+   i01rhusdf=(bdy_interp:dt)  "QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    qc             ijkftb   moist       1         -     \
+   i01rhusdf=(bdy_interp:dt)  "QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    qr             ijkftb   moist       1         -     \
+   i01rhusdf=(bdy_interp:dt)  "QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    qi             ijkftb   moist       1         -     \
+   i01rhusdf=(bdy_interp:dt)  "QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    qs             ijkftb   moist       1         -     \
+   i01rhusdf=(bdy_interp:dt)  "QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    qg             ijkftb   moist       1         -     \
+   i01rhusdf=(bdy_interp:dt)  "QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+state   real    qh             ijkftb   moist       1         -     \
+   i0rhusdf=(bdy_interp:dt)  "QHAIL"            "Hail mixing ratio"             "kg kg-1"
+state   real    -              ijkftb   dfi_moist       1         -     -    -
+state   real    dfi_qv         ijkftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QVAPOR"       "Water vapor mixing ratio"      "kg kg-1"
+state   real    dfi_qc         ijkftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QCLOUD"       "Cloud water mixing ratio"      "kg kg-1"
+state   real    dfi_qr         ijkftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QRAIN"        "Rain water mixing ratio"       "kg kg-1"
+state   real    dfi_qi         ijkftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QICE"         "Ice mixing ratio"              "kg kg-1"
+state   real    dfi_qs         ijkftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QSNOW"        "Snow mixing ratio"             "kg kg-1"
+state   real    dfi_qg         ijkftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QGRAUP"       "Graupel mixing ratio"          "kg kg-1"
+state   real    dfi_qh         ijkftb   dfi_moist       1         -     \
+   rusdf=(bdy_interp:dt)  "DFI_QHAIL"        "Hail mixing ratio"             "kg kg-1"
+state    real   rimi             ijk    misc        1         -     irh         "RIMI"           "riming intensity"  "fraction"
+state   real    -              ijkft   a_moist     1         -     -    -
+state   real    -              ijkft   g_moist     1         -     -    -
+state   real    a_qv           ijkft   a_moist     1         -     rh   "A_QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    g_qv           ijkft   g_moist     1         -     rh   "G_QVAPOR"           "Water vapor mixing ratio"      "kg kg-1"
+state   real    a_qc           ijkft   a_moist     1         -     rh   "A_QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    g_qc           ijkft   g_moist     1         -     rh   "G_QCLOUD"           "Cloud water mixing ratio"      "kg kg-1"
+state   real    a_qr           ijkft   a_moist     1         -     rh   "A_QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    g_qr           ijkft   g_moist     1         -     rh   "G_QRAIN"            "Rain water mixing ratio"       "kg kg-1"
+state   real    a_qi           ijkft   a_moist     1         -     rh   "A_QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    g_qi           ijkft   g_moist     1         -     rh   "G_QICE"             "Ice mixing ratio"              "kg kg-1"
+state   real    a_qs           ijkft   a_moist     1         -     rh   "A_QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    g_qs           ijkft   g_moist     1         -     rh   "G_QSNOW"            "Snow mixing ratio"             "kg kg-1"
+state   real    a_qg           ijkft   a_moist     1         -     rh   "A_QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+state   real    g_qg           ijkft   g_moist     1         -     rh   "G_QGRAUP"           "Graupel mixing ratio"          "kg kg-1"
+state   real    a_qh           ijkft   a_moist     1         -     rh   "A_QHAIL"            "Hail mixing ratio"             "kg kg-1"
+state   real    g_qh           ijkft   g_moist     1         -     rh   "G_QHAIL"            "Hail mixing ratio"             "kg kg-1"
+
+# LES---------------!JDM
+
+#include registry.les
+
+#-------------------
+
+# CAM physics (UW PBL, UW SHCU, ZM CU)
+include registry.cam
+
+# Chem Scalars
+#state   real    -              ijkftb   chem        1         -     -    -                                       
+#
+# Tracer Scalars: If you want full resolved and non-resolved dispersion, compile WRF-Chem
+#
+#state   real    -          ijkftb  tracer        1         -     -    -                                       
+#state   real    tr17_1     ijkftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_1"         "tr17_1"          -
+#state   real    tr17_2     ijkftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_2"         "tr17_2"          -
+#state   real    tr17_3     ijkftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_3"         "tr17_3"          -
+#state   real    tr17_4     ijkftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_4"         "tr17_4"          -
+#state   real    tr17_5     ijkftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_5"         "tr17_5"          -
+#state   real    tr17_6     ijkftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_6"         "tr17_6"          -
+#state   real    tr17_7     ijkftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_7"         "tr17_7"          -
+#state   real    tr17_8     ijkftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_8"         "tr17_8"
+
+# Other Scalars
+state   real    -              ijkftb  scalar      1         -     -   -
+state   real    qndrop         ijkftb  scalar      1         -     \
+   i01rhusdf=(bdy_interp:dt)    "QNDROP"        "Droplet number mixing ratio"        "# kg-1"
+state   real    qni            ijkftb  scalar      1         -     \
+   i01rhusdf=(bdy_interp:dt)    "QNICE"         "Ice Number concentration" "# kg-1"
+state   real    qt             ijkftb  scalar      1         -     \
+   i01rhusdf=(bdy_interp:dt)    "CWM"           "Total condensate mixing ratio"      "kg kg-1"
+state   real    qns            ijkftb  scalar      1         -     \
+   i01rhusdf=(bdy_interp:dt)    "QNSNOW"         "Snow Number concentration"   "# kg(-1)"
+state   real    qnr            ijkftb  scalar      1         -     \
+   i01rhusdf=(bdy_interp:dt)    "QNRAIN"        "Rain Number concentration"   "# kg(-1)"
+state   real    qng            ijkftb  scalar      1         -     \
+   i01rhusdf=(bdy_interp:dt)    "QNGRAUPEL"     "Graupel Number concentration" "# kg(-1)"
+state   real    qnh            ijkftb  scalar      1         -     \
+   i0rhusdf=(bdy_interp:dt)    "QNHAIL"        "Hail Number concentration" "# kg(-1)"
+state   real    qnn            ijkftb  scalar      1         -     \
+   i01rhusdf=(bdy_interp:dt)    "QNCCN"         "CCN Number concentration" "# kg(-1)"
+state   real    qnc            ijkftb  scalar      1         -     \
+   i01rhusdf=(bdy_interp:dt)    "QNCLOUD"       "cloud water Number concentration" "# kg(-1)"
+state   real    -              ijkftb  dfi_scalar      1         -     -   -
+state   real    dfi_qndrop     ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNDROP"    "Droplet number mixing ratio"        "# kg-1"
+state   real    dfi_qni        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNICE"     "Ice Number concentration" "# kg-1"
+state   real    dfi_qt         ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_CWM"       "Total condensate mixing ratio"      "kg kg-1"
+state   real    dfi_qns        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNSNOW"    "Snow Number concentration"   "# kg(-1)"
+state   real    dfi_qnr        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNRAIN"    "Rain Number concentration"   "# kg(-1)"
+state   real    dfi_qng        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)"
+state   real    dfi_qnh        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNHAIL" "Hail Number concentration" "# kg(-1)"
+state   real    dfi_qnn        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCC"      "CNN Number concentration"   "# kg(-1)"
+state   real    dfi_qnc        ijkftb  dfi_scalar      1         -     \
+   rusdf=(bdy_interp:dt)    "DFI_QNCLOUD"   "Cloud Number concentration" "# kg(-1)"
+state   real    -              ijkft   a_scalar    1         -     -    -                                       
+state   real    -              ijkft   g_scalar    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   soil_layers    i{lin}j    misc          1     Z     i1      "SOIL_LAYERS"   "SOIL LAYERS"         "cm"
+state   real   soil_levels    i{lin}j    misc          1     Z     i1      "SOIL_LEVELS"   "SOIL LEVELS"         "cm"
+state   real   st             i{lin}j    misc          1     Z     i1      "ST"            "SOIL TEMPERATURES"   "K"
+state   real   sm             i{lin}j    misc          1     Z     i1      "SM"            "SOIL MOISTURES"      "m3 m-3"
+state   real   sw             i{lin}j    misc          1     Z     i1      "SW"            "SOIL LIQUIDS"        "m3 m-3"
+state   real   soilt          i{lin}j    misc          1     Z     i1      "SOILT"         "RUC SOIL TEMPERATURES"  "K"
+state   real   soilm          i{lin}j    misc          1     Z     i1      "SOILM"         "RUC SOIL MOISTURES"  "m3 m-3"
+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     -     i012rdu "TOPOSLPX"      "ELEVATION X SLOPE"  ""
+state   real   toposlpy            ij    misc          1     -     i012rdu "TOPOSLPY"      "ELEVATION Y SLOPE"  ""
+state   real   slope               ij    misc          1     -     rdu     "SLOPE"         "ELEVATION SLOPE"  ""
+state   real   slp_azi             ij    misc          1     -     rdu     "SLP_AZI"       "ELEVATION SLOPE AZIMUTH"  "rad"
+state   real   shdmax              ij    misc          1     -     i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)   "SHDMAX"        "ANNUAL MAX VEG FRACTION" ""
+state   real   shdmin              ij    misc          1     -     i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)   "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            iju   misc          1     Z     i012r   "LANDUSEF"      "LANDUSE FRACTION BY CATEGORY"  ""
+state   real   soilctop            ijs   misc          1     Z     i012r   "SOILCTOP"      "SOIL CAT FRACTION (TOP)"  ""
+state   real   soilcbot            ijs   misc          1     Z     i012r   "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           ijl       misc      1         Z     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)           "TSLB"     "SOIL TEMPERATURE"   "K"
+
+# Time series variables
+state    real   ts_hour         ?!       misc      -         -      -        "TS_HOUR"        "Model integration time, hours"
+state    real   ts_u            ?!       misc      -         -      -        "TS_U"           "Surface wind U-component, earth-relative"
+state    real   ts_v            ?!       misc      -         -      -        "TS_V"           "Surface wind V-component, earth-relative"
+state    real   ts_q            ?!       misc      -         -      -        "TS_Q"           "Surface mixing ratio"
+state    real   ts_t            ?!       misc      -         -      -        "TS_T"           "Surface temperature"
+state    real   ts_psfc         ?!       misc      -         -      -        "TS_PSFC"        "Surface pressure"
+state    real   ts_glw          ?!       misc      -         -      -        "TS_GLW"         "Downward long wave flux at surface"
+state    real   ts_gsw          ?!       misc      -         -      -        "TS_GSW"         "Net short wave flux at surface"
+state    real   ts_hfx          ?!       misc      -         -      -        "TS_HFX"         "Upward heat flux at surface"
+state    real   ts_lh           ?!       misc      -         -      -        "TS_LH"          "Upward moisture flux at surface"
+state    real   ts_tsk          ?!       misc      -         -      -        "TS_TSK"         "Skin temperature"
+state    real   ts_tslb         ?!       misc      -         -      -        "TS_TSLB"        "Soil temperature"
+state    real   ts_clw          ?!       misc      -         -      -        "TS_CLW"         "Column integrated cloud water"
+state    real   ts_rainc        ?!       misc      -         -      -        "TS_RAINC"       "Cumulus precip"
+state    real   ts_rainnc       ?!       misc      -         -      -        "TS_RAINNC"      "Grid-scale precip"
+
+# 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            ijl     -          1         Z     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SMOIS"            "SOIL MOISTURE"     "m3 m-3"
+state    real   SH2O             ijl     -          1         Z     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SH2O"             "SOIL LIQUID WATER" "m3 m-3"
+state    real   SMCREL           ilj     -          1         Z     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SMCREL"           "RELATIVE SOIL MOISTURE" ""
+state    real   XICE             ij     misc        1         -     i0124rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm)  "SEAICE"             "SEA ICE FLAG"  ""
+state    real   XICEM            ij     misc        1         -     rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm)  "XICEM"             "SEA ICE FLAG (PREVIOUS STEP)"  ""
+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         -     i024rhd=(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   ACGRDFLX         ij     misc        1         -      rhdu                                       "ACGRDFLX"         "ACCUMULATED GROUND HEAT FLUX" "J 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         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SNOW"             "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real   SNOWH            ij     misc        1         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "SNOWH"            "PHYSICAL SNOW DEPTH"      "m"
+#state    real   RHOSN            ij     misc        1         -     i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "RHOSN"            " SNOW DENSITY"      "kg m-3" 
+state    real   CANWAT           ij     misc        1         -     i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm)    "CANWAT"           "CANOPY WATER"             "kg m-2"
+state    real   SST              ij     misc        1         -     i0124rhd=(interp_mask_water_field:lu_index,iswater)   "SST"              "SEA SURFACE TEMPERATURE" "K"
+state  integer  IFNDSNOWH        -      misc        1         -     i         "FNDSNOWH" "SNOWH_LOGICAL"
+state  integer  IFNDSOILW        -      misc        1         -     i         "FNDSOILW" "SOILW_LOGICAL"
+# SKIN SST
+state    real   SSTSK            ij     misc        1         -     rhd=(interp_mask_water_field:lu_index,iswater)   "SSTSK"              "SKIN SEA SURFACE TEMPERATURE" "K"
+state    real   DTW              ij     misc        1         -     r   "DTW"              "WARM LAYER TEMP DIFF" "C"
+
+# DFI variables
+state   real   hcoeff         {ndfi} misc        1         -     -    "HCOEFF"               "initialization weights"
+state   real   hcoeff_tot       -    misc        1         -     -    "HCOEFF_TOT"               "initialization weights"
+state   real   dfi_p           ijk   misc        1         -     r    "P_DFI"           "perturbation pressure"         "Pa"
+state   real   dfi_al          ijk   misc        1         -     r    "AL_DFI"          "inverse perturbation density"  "m3 kg-1"
+state   real   dfi_mu          ij    misc        1         -     r    "MU_DFI"  "perturbation dry air mass in column" "Pa"
+state   real   dfi_phb         ijk   misc        1         Z     r    "PHB_DFI"  "base-state geopotential"  "m2 s-2"
+state   real   dfi_ph0         ijk   misc        1         Z     r    "PH0_DFI"  "initial geopotential"     "m2 s-2"
+state   real   dfi_php         ijk   misc        1         Z     r    "PHP_DFI"  "geopotential"             "m2 s-2"
+state   real   dfi_u           ijk   misc        1         -     r    "U_DFI"               "u accumulation array"          "   "
+state   real   dfi_v           ijk   misc        1         -     r    "V_DFI"               "v accumulation array"          "   "
+state   real   dfi_w           ijk   misc        1         -     r    "W_DFI"               "w accumulation array"          "   "
+state   real   dfi_ww          ijk   misc        1         Z     r    "WW_DFI"              "mu-coupled eta-dot"    "Pa s-1"
+state   real   dfi_t           ijk   misc        1         -     r    "TT_DFI"               "t accumulation array"          "   "
+state   real   dfi_rh          ijk   misc        1         -     r    "RH_DFI"               "initial relative humidity"     "   "
+state   real   dfi_ph          ijk   misc        1         -     r    "PH_DFI"               "p accumulation array"          "   "
+state   real   dfi_pb          ijk   misc        1         -     r    "PB_DFI"               "pb accumulation array"          "   "
+state   real   dfi_alt         ijk   misc        1         -     r    "ALT_DFI"             "1/rho accumulation array"          "   "
+state   real   dfi_tke         ijk   misc        1         -     r    "TKE_DFI"          "TURBULENCE KINETIC ENERGY"     "m2 s-2"
+state   real   dfi_tten_rad    ijk   misc        1         -     irh  "RAD_TTEN_DFI"     "RADAR POT. TEMP. TENDENCY"     "K s-1"
+state    real  dfi_TSLB        ijl   misc        1         Z     r    "TSLB_dfi"         "SOIL TEMPERATURE"   "K"
+state    real  dfi_SMOIS       ijl    -          1         Z     r    "SMOIS_dfi"        "SOIL MOISTURE"     "m3 m-3"
+state    real  dfi_SNOW        ij    misc        1         -     r    "SNOW_dfi"         "SNOW WATER EQUIVALENT"    "kg m-2"
+state    real  dfi_SNOWH       ij    misc        1         -     r    "SNOWH_dfi"        "PHYSICAL SNOW DEPTH"      "m"
+state    real  dfi_CANWAT      ij    misc        1         -     r    "CANWAT_dfi"       "CANOPY WATER"             "kg m-2"
+state    real  dfi_SMFR3D      ijl   misc        1         Z     r    "SMFR3D_dfi"           "SOIL ICE" ""
+state    real  dfi_KEEPFR3DFLAG ijl  misc        1         Z     r    "KEEPFR3DFLAG_dfi"     "FLAG - 1. FROZEN SOIL YES, 0 - NO"             ""
+
+# 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        ijl    misc        1         Z     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)      "TRL_URB" "ROOF LAYER TEMPERATURE"          "K"
+state    real   TBL_URB3D        ijl    misc        1         Z     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)      "TBL_URB" "WALL LAYER TEMPERATURE"          "K"
+state    real   TGL_URB3D        ijl    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"
+state    real   TRB_URB4D       i{ulay}j    misc       1         Z     r      "TRB_URB4D" "ROOF LAYER TEMPERATURE"          "K"
+state    real   TW1_URB4D       i{ulay}j    misc       1         Z     r      "TW1_URB4D" "WALL LAYER TEMPERATURE"          "K"
+state    real   TW2_URB4D       i{ulay}j    misc       1         Z     r      "TW2_URB4D" "WALL LAYER TEMPERATURE"          "K"
+state    real   TGB_URB4D       i{ulay}j    misc       1         Z     r      "TGB_URB4D" "ROAD LAYER TEMPERATURE"          "K"
+state    real   TLEV_URB3D      i{ulay}j    misc       1         Z     r      "TLEV_URB3D" "INDOOR TEMPERATURE"             "K"
+state    real   QLEV_URB3D      i{ulay}j    misc       1         Z     r      "QLEV_URB3D" "SPECIFIC HUMIDITY"              "dimensionless"
+state    real   TW1LEV_URB3D    i{ulay}j    misc       1         Z     r      "TW1LEV_URB3D" "WINDOW TEMPERATURE"           "K"
+state    real   TW2LEV_URB3D    i{ulay}j    misc       1         Z     r      "TW2LEV_URB3D" "WINDOW TEMPERATURE"           "K"
+state    real   TGLEV_URB3D     i{ulay}j    misc       1         Z     r      "TGLEV_URB3D" "GROUND TEMPERATURE BELOW A BUILDING"     "K"
+state    real   TFLEV_URB3D     i{ulay}j    misc       1         Z     r      "TFLEV_URB3D" "FLOOR TEMPERATURE"                       "K"
+state    real   SF_AC_URB3D     ij          misc       1         -     r      "SF_AC_URB3D"  "SENSIBLE HEAT FLUX FROM THE AIR COND." "W m{-2}"
+state    real   LF_AC_URB3D     ij          misc       1         -     r      "LF_AC_URB3D"  "LATENT HEAT FLUX FROM THE AIR COND." "W m{-2}"
+state    real   CM_AC_URB3D     ij          misc       1         -     r      "CM_AC_URB3D"  "CONSUMPTION OF THE AIR COND." "W m{-2}"
+state    real   SFVENT_URB3D    ij          misc       1         -     r      "SFVENT_URB3D" "SENSIBLE HEAT FLUX FROM URBAN VENTILATION" "W m{-2}"
+state    real   LFVENT_URB3D    ij          misc       1         -     r      "LFVENT_URB3D" "LATENT HEAT FLUX FROM URBAN VENTILATION" "W m{-2}"
+state    real   SFWIN1_URB3D    i{ulay}j    misc       1         Z     r      "SFWIN1_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW"  "W m{-2}"
+state    real   SFWIN2_URB3D    i{ulay}j    misc       1         Z     r      "SFWIN2_URB3D" "SENSIBLE HEAT FLUX FROM URBAN SFC WINDOW"  "W m{-2}"
+state    real   SFW1_URB3D      i{ulay}j    misc       1         Z     r      "SFW1_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFW2_URB3D      i{ulay}j    misc       1         Z     r      "SFW2_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFR_URB3D       i{ulay}j    misc       1         Z     r      "SFR_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   SFG_URB3D       i{ulay}j    misc       1         Z     r      "SFG_URB3D"  "SENSIBLE HEAT FLUX FROM URBAN SFC"  "W m{-2}"
+state    real   CMR_SFCDIF      ij          misc       1         -     r      "CMR_SFCDIF" "" ""
+state    real   CHR_SFCDIF      ij          misc       1         -     r      "CHR_SFCDIF" "" ""
+state    real   CMC_SFCDIF      ij          misc       1         -     r      "CMC_SFCDIF" "" ""
+state    real   CHC_SFCDIF      ij          misc       1         -     r      "CHC_SFCDIF" "" ""
+
+
+# solar location variables from radiation driver
+state    real   COSZEN           ij     misc        1         -      r       "COSZEN"  "COS of SOLAR ZENITH ANGLE"     "dimensionless"
+state    real   HRANG            ij     misc        1         -      r       "HRANG"   "SOLAR HOUR ANGLE"          "radians"
+state    real   DECLIN            -     misc        1         -      r       "DECLIN"  "SOLAR DECLINATION"         "radians"
+state    real   SOLCON            -     misc        1         -      r       "SOLCON"  "SOLAR CONSTANT"         "W m-2"
+
+
+# RUC LSM
+state    real   SMFR3D           ijl    misc        1         Z      r        "SMFR3D"               "SOIL ICE" ""
+state    real   KEEPFR3DFLAG     ijl    misc        1         Z      r        "KEEPFR3DFLAG"          "FLAG - 1. FROZEN SOIL YES, 0 - NO"             ""
+
+# Additional for P-X PBL and LSM
+state    real   RA               ij     misc        1         -      r        "RA"           "AERODYNAMIC RESISTANCE"   "s m-1"
+state    real   RS               ij     misc        1         -      r        "RS"           "SURFACE RESISTANCE"       "s m-1"
+state    real   LAI              ij     misc        1         -      i0124rh       "LAI"          "Leaf area index"          "area/area"
+state    real   VEGF_PX          ij     misc        1         -      r        "VEGF_PX"      "Vegetation Fraction for PX LSM"    "area/area"
+state    real   T2OBS            ij     misc        1         -      r        "T2OBS"        "2-m temperature from analysis "          "K"
+state    real   Q2OBS            ij     misc        1         -      r        "Q2OBS"        "2-m mixing ratio from analysis "         "kg/kg"
+
+# 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   EXCH_H          ijk     misc        1         -     r          "EXCH_H"               "SCALAR EXCHANGE COEFFICIENTS "
+state    real   EXCH_M          ijk     misc        1         -     r          "EXCH_M"               "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"                             ""
+state   real   TSHLTR           ij     misc        1         -      r        "TSHLTR"                "SHELTER THETA FROM MYJ"                       "K"
+state   real   QSHLTR           ij     misc        1         -      r        "QSHLTR"                "SHELTER SPECIFIC HUMIDITY FROM MYJ"           "kg kg-1"
+state   real   PSHLTR           ij     misc        1         -      r        "PSHLTR"                "SHELTER PRESSURE FROM MYJ"           "Pa"
+state   real   TH10             ij     misc        1         -      r        "TH10"                  "10-M THETA FROM MYJ"                          "K"
+state   real   Q10              ij     misc        1         -      r        "Q10"                   "10-M SPECIFIC HUMIDITY FROM MYJ"              "kg kg-1"
+i1      real   CHKLOWQ          ij     misc        1         -     -         "CHKLOWQ"               "SURFACE SATURATION FLAG"        ""
+
+# TEMF PBL variables
+state    real   te_temf        ijk     misc        1         -      rh        "te_temf"               "Total energy from TEMF PBL scheme"      "m2 s-2"
+state    real   kh_temf        ijk     misc        1         -     rh          "kh_temf"               "Diffusion coefficient for heat from TEMF PBL"
+state    real   km_temf        ijk     misc        1         -     rh          "km_temf"               "Diffusion coefficient for momentum from TEMF PBL"
+state    real   shf_temf       ijk     misc        1         -     rh          "shf_temf"              "Sensible heat flux from TEMF PBL"      "K m s-1"
+state    real   qf_temf        ijk     misc        1         -     rh          "qf_temf"              "Sensible heat flux from TEMF PBL"       "kg/kg m s-1"
+state    real   uw_temf        ijk     misc        1         -     rh          "uw_temf"              "U momentum flux from TEMF PBL"       "m2 s-2"
+state    real   vw_temf        ijk     misc        1         -     rh          "vw_temf"              "V momentum flux from TEMF PBL"       "m2 s-2"
+state    real   wupd_temf      ijk     misc        1         -     rh          "wupd_temf"            "Updraft velocity from TEMF PBL"      "m s-1"
+state    real   mf_temf        ijk     misc        1         -     rh          "mf_temf"              "Mass flux from TEMF PBL"             "m s-1"
+state    real   thup_temf      ijk     misc        1         -     rh          "thup_temf"            "Updraft thetal from TEMF PBL"        "K"
+state    real   qtup_temf      ijk     misc        1         -     rh          "qtup_temf"            "Updraft qt from TEMF PBL"        "1"
+state    real   qlup_temf      ijk     misc        1         -     rh          "qlup_temf"            "Updraft ql (liquid water) from TEMF PBL"        "1"
+state    real   cf3d_temf      ijk     misc        1         -     rh          "cf3d_temf"            "3D Cloud fraction from TEMF PBL"        "1"
+state    real   hd_temf        ij      misc        1         -     rh          "hd_temf"              "Dry thermal top height from TEMF PBL"       "m"
+state    real   lcl_temf       ij      misc        1         -     rh          "lcl_temf"             "Lifting condensation level from TEMF PBL"       "m"
+state    real   hct_temf       ij      misc        1         -     rh          "hct_temf"             "Cloud top height from TEMF PBL"       "m"
+state    real   cfm_temf       ij      misc        1         -     rh          "cfm_temf"            "Column cloud fraction from TEMF PBL"        "1"
+state    real   wm_temf        ij      misc        1         -     rh        "wm_temf"               "Velocity scale in TEMF surface layer scheme"      "m s-1"
+
+# MYNN PBL variables
+state   real   qke             ikjftb  scalar      1         -      i0rhusdf=(bdy_interp:dt) "qke"               "twice TKE FROM MYNN"      "m2 s-2"
+state   real   tsq             ijk     misc        1         -      r        "tsq"               "liquid water pottemp variance"      "K2"
+state   real   qsq             ijk     misc        1         -      r        "qsq"               "liquid water variance"      "(kg/kg)**2"
+state   real   cov             ijk     misc        1         -      r        "cov"               "liquid water-liquid water pottemp covaria\
+nce"      "K kg/kg"
+state   real   ch               ij      misc        1         -     -         "ch"                    "drag coeff for heat"    ""
+#state   real   K_m             ijk     misc        1         -     -          "K_m"               "EXCHANGE COEFFICIENT for momentum "
+#state   real   K_h             ijk     misc        1         -     -          "K_h"               "EXCHANGE COEFFICIENT for heat "
+#state   real   K_q             ijk     misc        1         -     -          "K_q"               "EXCHANGE COEFFICIENT for qke "
+
+# Additional for gravity wave drag
+state   real   DTAUX3D         ikj     misc        1         -     rh        "DTAUX3D"               "LOCAL U GWDO STRESS"   "m s-1"
+state   real   DTAUY3D         ikj     misc        1         -     rh        "DTAUY3D"               "LOCAL V GWDO STRESS"   "m s-1"  
+state   real   DUSFCG           ij     misc        1         -     rh        "DUSFCG"                "COLUMN-INTEGRATED U GWDO STRESS"   "Pa m s-1"
+state   real   DVSFCG           ij     misc        1         -     rh        "DVSFCG"                "COLUMN-INTEGRATED V GWDO STRESS"   "Pa m s-1"
+state   real   VAR2D            ij     misc        1         -     i012rhdus "VAR"                   "OROGRAPHIC VARIANCE"   ""   ""
+state   real   OC12D            ij     misc        1         -     i012rhdus "CON"                   "OROGRAPHIC CONVEXITY"   ""   ""
+state   real   OA1              ij     misc        1         -     i012rhdus "OA1"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA2              ij     misc        1         -     i012rhdus "OA2"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA3              ij     misc        1         -     i012rhdus "OA3"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OA4              ij     misc        1         -     i012rhdus "OA4"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL1              ij     misc        1         -     i012rhdus "OL1"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL2              ij     misc        1         -     i012rhdus "OL2"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL3              ij     misc        1         -     i012rhdus "OL3"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+state   real   OL4              ij     misc        1         -     i012rhdus "OL4"                   "OROGRAPHIC DIRECTION ASYMMETRY FUNCTION"   ""   ""
+
+# BEP urban scheme  variables
+state    real    a_u_bep       ijk     misc        1         Z      -        "a_u_bep"               "IMPLICIT FOR X-COMP."      "s-1"
+state    real    a_v_bep       ijk     misc        1         Z      -        "a_v_bep"               "IMPLICIT FOR Y-COMP."      "s-1"
+state    real    a_t_bep       ijk     misc        1         Z      -        "a_t_bep"               "IMPLICIT FOR Pot. Temp"    "s-1"
+state    real    a_q_bep       ijk     misc        1         Z      -        "a_q_bep"               "IMPLICIT FOR Moisture"     "s-1"
+state    real    a_e_bep       ijk     misc        1         Z      -        "a_e_bep"               "IMPLICIT FOR TKE"          "s-1"
+state    real    b_u_bep       ijk     misc        1         Z      -        "b_u_bep"               "EXPLICIT FOR X-COMP."      "m s-2"
+state    real    b_v_bep       ijk     misc        1         Z      -        "b_v_bep"               "EXPLICIT FOR Y-COMP."      "m s-2"
+state    real    b_t_bep       ijk     misc        1         Z      -        "b_t_bep"               "EXPLICIT FOR Pot. Temp"    "K s-1"
+state    real    b_q_bep       ijk     misc        1         Z      -        "b_q_bep"               "EXPLICIT FOR Moisture"     "kg s-1"
+state    real    b_e_bep       ijk     misc        1         Z      -        "b_e_bep"               "EXPLICIT FOR TKE"          "m2 s-3"
+state    real    dlg_bep       ijk     misc        1         Z      -        "dlg_bep"               "length scale 1"            "m"
+state    real    dl_u_bep      ijk     misc        1         Z      -        "dl_u_bep"              "urban length scale"        "m"
+state    real    sf_bep        ijk     misc        1         Z      -        "sf_bep"                "surface grid"              "-"
+state    real    vl_bep        ijk     misc        1         Z      -        "vl_bep"                "volume grid"               "-"
+# BOULAC PBL variables
+state    real   tke_pbl        ijk     misc        1         -      rh        "tke_pbl"               "TKE FROM Bougeault and Lacarrere"      "m2 s-2"
+state    real   el_pbl        ijk     misc        1         -       h        "el_pbl"               "Length scale FROM Bougeault and Lacarrere"      "m"
+# Diagnostic PBL variables
+state    real   wu_tur         ijk     misc        1         -      r        "wu_tur"               "Turbulent flux of momentum(x)"      "m2 s-2"
+state    real   wv_tur         ijk     misc        1         -      r        "wv_tur"               "Turbulent flux of momentum(y)"      "m2 s-2"
+state    real   wt_tur         ijk     misc        1         -      r        "wt_tur"               "Turbulent flux of temperature"      "K m s-1"
+state    real   wq_tur         ijk     misc        1         -      r        "wq_tur"               "Turbulent flux of water vapor"      "- m s-1"
+
+# 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         -      -
+state    real   rlwtoa           ij     misc        1         -      -
+state    real   czmean           ij     misc        1         -      -
+state    real   cfracl           ij     misc        1         -      -
+state    real   cfracm           ij     misc        1         -      -
+state    real   cfrach           ij     misc        1         -      -
+state    real   acfrst           ij     misc        1         -      -
+state integer   ncfrst           ij     misc        1         -      -
+state    real   acfrcv           ij     misc        1         -      -
+state integer   ncfrcv           ij     misc        1         -      -
+
+# cam radiation variables
+state  real    -       i{ls}jf ozmixm      1    -   -     -
+state  real   mth01    i{ls}jf ozmixm      1    -   -     -
+state  real   mth02    i{ls}jf ozmixm      1    -   -     -
+state  real   mth03    i{ls}jf ozmixm      1    -   -     -
+state  real   mth04    i{ls}jf ozmixm      1    -   -     -
+state  real   mth05    i{ls}jf ozmixm      1    -   -     -
+state  real   mth06    i{ls}jf ozmixm      1    -   -     -
+state  real   mth07    i{ls}jf ozmixm      1    -   -     -
+state  real   mth08    i{ls}jf ozmixm      1    -   -     -
+state  real   mth09    i{ls}jf ozmixm      1    -   -     -
+state  real   mth10    i{ls}jf ozmixm      1    -   -     -
+state  real   mth11    i{ls}jf ozmixm      1    -   -     -
+state  real   mth12    i{ls}jf ozmixm      1    -   -     -
+state  real   pin       {ls}     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 microphysics State Variables
+state    real    F_ICE_PHY     ijk    misc        1         -      rhdu      "F_ICE_PHY"            "FRACTION OF ICE"         ""
+state    real    F_RAIN_PHY    ijk    misc        1         -      rhdu      "F_RAIN_PHY"           "FRACTION OF RAIN "         ""
+state    real    F_RIMEF_PHY   ijk    misc        1         -      rhdu      "F_RIMEF_PHY"          "MASS RATIO OF RIMED ICE "         ""
+state    real    qndropsource  ijk    misc        1         -      -        "qndropsource"         "Droplet number source"   "#/kg/s"
+
+# Other Misc State Variables                                            
+state   real    h_diabatic     ijk     misc         1         -      rdu      "h_diabatic"            "MICROPHYSICS LATENT HEATING"         "K s-1"      
+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    msftx          ij      misc         1         -     i012rhdu=(copy_fcnm)    "MAPFAC_MX"         "Map scale factor on mass grid, x direction" ""
+state   real    msfty          ij      misc         1         -     i012rhdu=(copy_fcnm)    "MAPFAC_MY"         "Map scale factor on mass grid, y direction" ""
+state   real    msfux          ij      misc         1         X     i012rhdu=(copy_fcnm)    "MAPFAC_UX"         "Map scale factor on u-grid, x direction" ""
+state   real    msfuy          ij      misc         1         X     i012rhdu=(copy_fcnm)    "MAPFAC_UY"         "Map scale factor on u-grid, y direction" ""
+state   real    msfvx          ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MAPFAC_VX"         "Map scale factor on v-grid, x direction" ""
+state   real    msfvx_inv      ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MF_VX_INV"         "Inverse map scale factor on v-grid, x direction" ""
+state   real    msfvy          ij      misc         1         Y     i012rhdu=(copy_fcnm)    "MAPFAC_VY"         "Map scale factor on v-grid, y direction" ""
+
+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    ht_shad        ijb     misc         1         -     df=(bdy_interp:dt)         "HGT_SHAD"        "Height of orographic shadow"   "m"
+i1      real    ht_loc         ij      misc         1         -     - 
+state   integer  shadowmask    ij      misc         1         -     - 
+state   integer min_ptchsz     -       misc         1         -     r
+
+state   real    TSK            ij      misc         1         -     i012rhdu=(copy_fcnm)    "TSK"                   "SURFACE SKIN TEMPERATURE"                  "K"
+state   real    dfi_TSK        ij      misc         1         -     r                       "TSK_dfi"               "saved SURFACE SKIN TEMPERATURE"
+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    t00            -       misc         -         -     i02rh     "t00"                   "BASE STATE TEMPERATURE   "  "K"
+state   real    p00            -       misc         -         -     i02rh     "p00"                   "BASE STATE PRESURE"         "Pa"
+state   real    tlp            -       misc         -         -     i02rh     "tlp"                   "BASE STATE LAPSE RATE    "  ""
+state   real    tiso           -       misc         -         -     i02rh     "tiso"                  "TEMP AT WHICH THE BASE T TURNS CONST"  "K"
+state   real    max_msftx      -       misc         -         -      rh       "max_mstfx"             "Max map factor in domain"  ""
+state   real    max_msfty      -       misc         -         -      rh       "max_mstfy"             "Max map factor in domain"  ""
+
+# State variables for Goddard LW and SW radiation
+state    real  TLWDN           ij      misc        1         -      h         "TLWDN"                 "TOA LW downwelling flux"           "W m-2"
+state    real  TLWUP           ij      misc        1         -      h         "TLWUP"                 "TOA LW upwelling flux"             "W m-2"
+state    real  SLWDN           ij      misc        1         -      h         "SLWDN"                 "Surface LW downwelling flux"       "W m-2"
+state    real  SLWUP           ij      misc        1         -      h         "SLWUP"                 "Surface LW upwelling flux"         "W m-2"
+state    real  TSWDN           ij      misc        1         -      h         "TSWDN"                 "TOA SW downwelling flux"           "W m-2"
+state    real  TSWUP           ij      misc        1         -      h         "TSWUP"                 "TOA SW upwelling flux"             "W m-2"
+state    real  SSWDN           ij      misc        1         -      h         "SSWDN"                 "Surface SW downwelling flux"       "W m-2"
+state    real  SSWUP           ij      misc        1         -      h         "SSWUP"                 "Surface SW upwelling flux"         "W m-2"
+
+# Other physics variables
+                                                
+state    real  RUSHTEN         ijk      misc        1         -      r        "RUSHTEN"               "COUPLED X WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME"   "Pa m s-2"
+state    real  RVSHTEN         ijk      misc        1         -      r        "RVSHTEN"               "COUPLED Y WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME"   "Pa m s-2"
+state    real  RTHSHTEN        ijk      misc        1         -      r        "RTHSHTEN"              "COUPLED THETA TENDENCY DUE TO SHALLOW CUMULUS SCHEME"    "Pa K s-1"
+state    real  RQVSHTEN        ijk      misc        1         -      r        "RQVSHTEN"              "COUPLED Q_V TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQRSHTEN        ijk      misc        1         -      r        "RQRSHTEN"              "COUPLED Q_R TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQCSHTEN        ijk      misc        1         -      r        "RQCSHTEN"              "COUPLED Q_C TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQSSHTEN        ijk      misc        1         -      r        "RQSSHTEN"              "COUPLED Q_S TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQISHTEN        ijk      misc        1         -      r        "RQISHTEN"              "COUPLED Q_I TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+state    real  RQGSHTEN        ijk      misc        1         -      r        "RQGSHTEN"              "COUPLED Q_G TENDENCY DUE TO SHALLOW CUMULUS SCHEME"      "Pa kg kg-1 s-1"
+
+state    real  RUCUTEN         ijk      misc        1         -      r        "RUCUTEN"               "COUPLED X WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION"  "Pa m s-2"
+state    real  RVCUTEN         ijk      misc        1         -      r        "RVCUTEN"               "COUPLED Y WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION"  "Pa m s-2"
+state    real  RTHCUTEN        ijk      misc        1         -      r        "RTHCUTEN"              "COUPLED THETA TENDENCY DUE TO CUMULUS SCHEME"     "Pa K s-1"
+state    real  RQVCUTEN        ijk      misc        1         -      r        "RQVCUTEN"              "COUPLED Q_V TENDENCY DUE TO CUMULUS SCHEME"       "Pa kg kg-1 s-1"
+state    real  RQRCUTEN        ijk      misc        1         -      r        "RQRCUTEN"              "COUPLED Q_R TENDENCY DUE TO CUMULUS SCHEME"       "Pa kg kg-1 s-1"
+state    real  RQCCUTEN        ijk      misc        1         -      r        "RQCCUTEN"              "COUPLED Q_C TENDENCY DUE TO CUMULUS SCHEME"       "Pa kg kg-1 s-1"
+state    real  RQSCUTEN        ijk      misc        1         -      r        "RQSCUTEN"              "COUPLED Q_S TENDENCY DUE TO CUMULUS SCHEME"       "Pa kg kg-1 s-1"
+state    real  RQICUTEN        ijk      misc        1         -      r        "RQICUTEN"              "COUPLED Q_I TENDENCY DUE TO CUMULUS SCHEME"       "Pa kg kg-1 s-1"
+state    real  W0AVG           ijk      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  RAINSH           ij      misc        1         -      rhdu     "RAINSH"                "ACCUMULATED SHALLOW CUMULUS PRECIPITATION"               "mm"
+state    real  RAINNC           ij      misc        1         -      rhdu     "RAINNC"                "ACCUMULATED TOTAL GRID SCALE PRECIPITATION"              "mm"      
+state  integer I_RAINC          ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_RAINC"            "BUCKET FOR RAINC"                    ""
+state  integer I_RAINNC         ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_RAINNC"           "BUCKET FOR RAINNC"                   ""
+state    real  PRATEC           ij      misc        1         -      r        "PRATEC"                "PRECIP RATE FROM CUMULUS SCHEME"                         "mm s-1"
+state    real  PRATESH          ij      misc        1         -      r        "PRATESH"               "PRECIP RATE FROM SHALLOW CUMULUS SCHEME"                 "mm s-1"
+state    real  RAINCV           ij      misc        1         -      r        "RAINCV"                "TIME-STEP CUMULUS PRECIPITATION"                         "mm"      
+state    real  RAINSHV          ij      misc        1         -      r        "RAINSHV"               "TIME-STEP SHALLOW 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  HAILNC           ij      misc        1         -      rhdu     "HAILNC"                "ACCUMULATED TOTAL GRID SCALE HAIL"                       "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  HAILNCV          ij      misc        1         -      r        "HAILNCV"               "TIME-STEP NONCONVECTIVE HAIL"                            "mm"
+state    real    refl_10cm      ijk     dyn_em      1         -     hdu     "refl_10cm" "Radar reflectivity (lamda = 10 cm)"  "dBZ"
+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  edt_out          ij      misc        1         -      -        "EDT_OUT"             "EDT FROM GD SCHEME"             ""
+state    real  xmb_shallow      ij      misc        1         -      rh       "XMB_SHALLOW"             "MASSFLUX FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  k22_shallow   ij      misc        1         -      rh       "K22_SHALLOW"             "K22 LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  kbcon_shallow   ij      misc        1         -    rh       "KBCON_SHALLOW"             "KBCON LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+state    integer  ktop_shallow   ij      misc        1         -     rh       "KTOP_SHALLOW"             "KTOP LEVEL FROM SHALLOW CONVECTION (G3 only)"             ""
+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  cugd_tten        ijk     misc        1         -      r        "CUGD_TTEN"             "INITIAL TTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qvten       ijk     misc        1         -      r        "CUGD_QVTEN"            "INITIAL QTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_ttens       ijk     misc        1         -      r        "CUGD_TTENS"            "INITIAL SUBSIDENCE TTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qvtens      ijk     misc        1         -      r        "CUGD_QVTENS"           "INITIAL SUBSIDNCE QTENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  cugd_qcten       ijk     misc        1         -      r        "CUGD_QCTEN"            "INITIAL TEMPERATURE TENDENCY OUT OFF GRELL CUMULUS SCHEME"  "K s-1"
+state    real  RTHFTEN          ijk     misc        1         -      r        "RTHFTEN"               "TEMPERATURE TENDENCY USED IN GRELL CUMULUS SCHEME"  "K s-1"      
+state    real  RQVFTEN          ijk     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        ijk      misc        1         -      rd       "RTHRATEN"              "COUPLED THETA TENDENCY DUE TO RADIATION"              "Pa K s-1"
+state    real  RTHRATENLW      ijk      misc        1         -      r        "RTHRATLW"              "UNCOUPLED THETA TENDENCY DUE TO LONG WAVE RADIATION"    "K s-1"
+state    real  RTHRATENSW      ijk      misc        1         -      r        "RTHRATSW"              "UNCOUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION"   "K s-1"
+state    real  CLDFRA          ijk      misc        1         -      r        "CLDFRA"                "CLOUD FRACTION"                                       ""
+state    real  CLDFRA_OLD      ijk      misc        1         -      r        "CLDFRA_OLD"            "previous time level cldfra"                           ""
+
+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"      
+state    real  SWNORM           ij      misc        1         -      rhd      "SWNORM"                "NORMAL SHORT WAVE FLUX AT GROUND SURFACE (SLOPE-DEPENDENT)"           "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 integer  I_ACSWUPT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPT"     "BUCKET FOR UPWELLING SHORTWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACSWUPTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPTC"    "BUCKET FOR UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACSWDNT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNT"     "BUCKET FOR DOWNWELLING SHORTWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACSWDNTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNTC"    "BUCKET FOR DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACSWUPB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPB"     "BUCKET FOR UPWELLING SHORTWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACSWUPBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWUPBC"    "BUCKET FOR UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACSWDNB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNB"     "BUCKET FOR DOWNWELLING SHORTWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACSWDNBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACSWDNBC"    "BUCKET FOR DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACLWUPT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPT"     "BUCKET FOR UPWELLING LONGWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACLWUPTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPTC"    "BUCKET FOR UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACLWDNT        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNT"     "BUCKET FOR DOWNWELLING LONGWAVE FLUX AT TOP"          "J m-2"
+state integer  I_ACLWDNTC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNTC"    "BUCKET FOR DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2"
+state integer  I_ACLWUPB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPB"     "BUCKET FOR UPWELLING LONGWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACLWUPBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWUPBC"    "BUCKET FOR UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2"
+state integer  I_ACLWDNB        ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNB"     "BUCKET FOR DOWNWELLING LONGWAVE FLUX AT BOTTOM"          "J m-2"
+state integer  I_ACLWDNBC       ij      misc        1         -      rhd=(interp_fcni)u=(copy_fcni)     "I_ACLWDNBC"    "BUCKET FOR DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2"
+state    real  SWUPT            ij      misc        1         -      rhdu     "SWUPT"                 "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP"          "W m-2"
+state    real  SWUPTC           ij      misc        1         -      rhdu     "SWUPTC"                "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2"
+state    real  SWDNT            ij      misc        1         -      rhdu     "SWDNT"                 "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP"          "W m-2"
+state    real  SWDNTC           ij      misc        1         -      rhdu     "SWDNTC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2"
+state    real  SWUPB            ij      misc        1         -      rhdu     "SWUPB"                 "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  SWUPBC           ij      misc        1         -      rhdu     "SWUPBC"                "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2"
+state    real  SWDNB            ij      misc        1         -      rhdu     "SWDNB"                 "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  SWDNBC           ij      misc        1         -      rhdu     "SWDNBC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2"
+state    real  LWUPT            ij      misc        1         -      rhdu     "LWUPT"                 "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP"          "W m-2"
+state    real  LWUPTC           ij      misc        1         -      rhdu     "LWUPTC"                "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2"
+state    real  LWDNT            ij      misc        1         -      rhdu     "LWDNT"                 "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP"          "W m-2"
+state    real  LWDNTC           ij      misc        1         -      rhdu     "LWDNTC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2"
+state    real  LWUPB            ij      misc        1         -      rhdu     "LWUPB"                 "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  LWUPBC           ij      misc        1         -      rhdu     "LWUPBC"                "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W m-2"
+state    real  LWDNB            ij      misc        1         -      rhdu     "LWDNB"                 "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM"          "W m-2"
+state    real  LWDNBC           ij      misc        1         -      rhdu     "LWDNBC"                "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W 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  CLAT             ij      misc        1         -     i012rdu=(copy_fcnm)          "CLAT"                "COMPUTATIONAL GRID LATITUDE, SOUTH IS NEGATIVE"                       "degree_north"
+state    real  CLONG            ij      misc        1         -     i012rdu=(copy_fcnm)          "CLONG"               "COMPUTATIONAL GRID LONGITUDE, WEST IS NEGATIVE"                       "degree_east"
+state    real  ALBBCK           ij      misc        1         -     i0124rh   "ALBBCK"                "BACKGROUND ALBEDO"        ""
+state    real  EMBCK            ij      misc        1         -      r        "EMBCK"                 "BACKGROUND EMISSIVITY"         ""
+state    real  EMISS            ij      misc        1         -      rh       "EMISS"                 "SURFACE EMISSIVITY"         "" 
+state    real  SNOTIME          ij      misc        1         -      r        "SNOTIME"               "SNOTIME"         "" 
+state    real  NOAHRES          ij      misc        1         -      h        "NOAHRES"               "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}"
+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         ijk      misc        1         -      r        "RUBLTEN"               "COUPLED X WIND TENDENCY DUE TO PBL PARAMETERIZATION"  "Pa m s-2"
+state    real  RVBLTEN         ijk      misc        1         -      r        "RVBLTEN"               "COUPLED Y WIND TENDENCY DUE TO PBL PARAMETERIZATION"  "Pa m s-2"
+state    real  RTHBLTEN        ijk      misc        1         -      r        "RTHBLTEN"              "COUPLED THETA TENDENCY DUE TO PBL PARAMETERIZATION"   "Pa K s-1"
+state    real  RQVBLTEN        ijk      misc        1         -      r        "RQVBLTEN"              "COUPLED Q_V TENDENCY DUE TO PBL PARAMETERIZATION"     "Pa kg kg-1 s-1"
+state    real  RQCBLTEN        ijk      misc        1         -      r        "RQCBLTEN"              "COUPLED Q_C TENDENCY DUE TO PBL PARAMETERIZATION"     "Pa kg kg-1 s-1"
+state    real  RQIBLTEN        ijk      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          ijk      misc        1         -                                          
+i1       real  pi_phy          ijk      misc        1         -                                          
+i1       real  p_phy           ijk      misc        1         -                                          
+state    real  t_phy           ikj      misc        1         -      r      "T_PHY"                        "Temperature"         "K"
+
+i1       real  u_phy           ijk      misc        1         -                                          
+i1       real  v_phy           ijk      misc        1         -                                          
+i1       real  dz8w            ijk      misc        1         Z                                          
+i1       real  p8w             ijk      misc        1         Z                                          
+i1       real  t8w             ijk      misc        1         Z                                          
+i1       real  rho_phy         ijk      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  TYR              ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TYR"        "ANNUAL MEAN SFC TEMPERATURE"           "K"
+state    real  TYRA             ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TYRA"   "ACCUMULATED YEARLY SFC TEMPERATURE FOR CURRENT YEAR"  "K"
+state    real  TDLY             ij      misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TDLY"     "ACCUMULATED DAILY SFC TEMPERATURE FOR CURRENT DAY"  "K"
+state    real  TLAG             i&j     misc        1         -     rd=(interp_mask_land_field:lu_index)u=(copy_fcnm)     "TLAG"         "DAILY MEAN SFC TEMPERATURE OF PRIOR DAYS"       "K"
+state    integer NYEAR          -       misc        1         -     r        "NYEAR"                  "ACCUM DAYS IN A YEAR"                         ""
+state    real    NDAY           -       misc        1         -     r        "NDAY"                  "ACCUM TIMESTEPS IN A DAY"                      ""
+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  CK               ij      misc        1         -      r        "CK"                    "ENTHALPY EXCHANGE COEFF AT 10 m"                      ""
+state    real  CKA              ij      misc        1         -      r        "CKA"                   "ENTHALPY EXCHANGE COEFF AT LOWEST MODEL LVL"          ""
+state    real  CD               ij      misc        1         -      r        "CD"                    "DRAG COEFF AT 10m"                      ""
+state    real  CDA              ij      misc        1         -      r        "CDA"                   "DRAG COEFF AT LOWEST MODEL LVL"                      ""
+state    real  UST              ij      misc        1         -      rh       "UST"                   "U* IN SIMILARITY THEORY"                      "m s-1"      
+state    real  USTM             ij      misc        1         -      r        "USTM"                  "U* IN SIMILARITY THEORY WITHOUT VCONV"        "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  ACHFX            ij      misc        1         -      rhdu     "ACHFX"                 "ACCUMULATED UPWARD HEAT FLUX AT THE SURFACE"  "J m-2"
+state    real  ACLHF            ij      misc        1         -      rhdu     "ACLHF"                 "ACCUMULATED UPWARD LATENT HEAT FLUX AT THE SURFACE"  "J 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  dfi_QVG          ij      misc        1         -      r        "QVG_dfi"               "WATER VAPOR MIXING RATIO AT THE SURFACE"      "kg kg-1"
+state    real  QCG              ij      misc        1         -      r        "QCG"                   "CLOUD WATER MIXING RATIO AT THE GROUND SURFACE"      "kg kg-1"
+state    real  DEW              ij      misc        1         -      r        "DEW"                   "DEW MIXING RATIO AT THE SURFACE"              "kg kg-1"
+state    real  SOILT1           ij      misc        1         -      i012rh   "SOILT1"                "TEMPERATURE INSIDE SNOW "    "K"
+state    real  dfi_SOILT1       ij      misc        1         -      r        "SOILT1_dfi"            "TEMPERATURE INSIDE SNOW "    "K"
+state    real  TSNAV            ij      misc        1         -      r        "TSNAV"                 "AVERAGE SNOW TEMPERATURE "                    "C"
+state    real  dfi_TSNAV        ij      misc        1         -      r        "TSNAV_dfi"             "AVERAGE SNOW TEMPERATURE "                    "C"
+state    real  REGIME           ij      misc        1         -      r        "REGIME"  "FLAGS: 1=Night/Stable, 2=Mechanical Turbulent, 3=Forced Conv, 4=Free Conv" ""
+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  dfi_SNOWC        ij      misc        1         -      r        "SNOWC_dfi"             "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    real   sr             ij      dyn_em      1         -      irh         "sr" "fraction of frozen precipitation"
+state    real   potevp         ij      dyn_em      1         -       rh         "potevp" "accumulated potential evaporation" "W m-2"
+state    real   snopcx         ij      dyn_em      1         -       rh         "snopcx" "snow phase change heat flux" "W m-2"
+state    real   soiltb         ij      dyn_em      1         -        h         "soiltb" "bottom soil temperature" "K"
+                                                
+state integer  STEPBL          -        misc        1         -      r        "STEPBL"                "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN PBL CALLS" ""      
+state    real  taucldi         ijk      misc        1         -      r        "TAUCLDI"               "CLOUD OPTICAL THICKNESS FOR ICE"              ""
+state    real  taucldc         ijk      misc        1         -      r        "TAUCLDC"               "CLOUD OPTICAL THICKNESS FOR WATER"            ""
+                                                
+state   real  defor11          ijk      misc        1         -     r         "defor11"               "DEFORMATION 11"              "s-1"      
+state   real  defor22          ijk      misc        1         -     r         "defor22"               "DEFORMATION 22"              "s-1"      
+state   real  defor12          ijk      misc        1         -     r         "defor12"               "DEFORMATION 12"              "s-1"      
+state   real  defor33          ijk      misc        1         z     r         "defor33"               "DEFORMATION 33"              "s-1"      
+state   real  defor13          ijk      misc        1         z     r         "defor13"               "DEFORMATION 13"              "s-1"      
+state   real  defor23          ijk      misc        1         z     r         "defor23"               "DEFORMATION 23"              "s-1"      
+state   real   xkmv            ijk      misc        1         -     r         "xkmv"                  "VERTICAL EDDY VISCOSITY"     "m2 s-1"      
+state   real   xkmh            ijk      misc        1         -     r         "xkmh"                  "HORIZONTAL EDDY VISCOSITY"   "m2 s-1"      
+state   real   xkhv            ijk      misc        1         -     r         "xkhv"                  "VERTICAL EDDY DIFFUSIVITY OF HEAT"                               "m2 s-1"      
+state   real   xkhh            ijk      misc        1         -     r         "xkhh"                  "HORIZONTAL EDDY DIFFUSIVITY OF HEAT"                             "m2 s-1"      
+state   real    div            ijk      misc        1         -     r         "div"                   "DIVERGENCE"                                                      "s-1"
+state   real    BN2            ijk      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"
+state  integer save_topo_from_real -    dyn_em	    1         -    irh        "save_topo_from_real"    "1=original topo from real/0=topo modified by WRF"      "flag"
+
+## FDDA variables
+
+state integer  STEPFG            -        misc        1         -      r        "STEPFG"                "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN FDDA GRID CALLS" ""
+state    real  RUNDGDTEN         ijk      misc        1         X      r        "RUNDGDTEN"               "COUPLED X WIND TENDENCY DUE TO FDDA GRID NUDGING"  "Pa m s-2"
+state    real  RVNDGDTEN         ijk      misc        1         Y      r        "RVNDGDTEN"               "COUPLED Y WIND TENDENCY DUE TO FDDA GRID NUDGING"  "Pa m s-2"
+state    real  RTHNDGDTEN        ijk      misc        1         -      r        "RTHNDGDTEN"              "COUPLED THETA TENDENCY DUE TO FDDA GRID NUDGING"   "Pa K s-1"
+state    real  RPHNDGDTEN        ijk      misc        1         -      r        "RPHNDGDTEN"              "COUPLED GEOPOTENTIAL TENDENCY DUE TO FDDA GRID NUDGING"   "Pa m2 s-3"
+state    real  RQVNDGDTEN        ijk      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    -               ijkf     fdda3d      1         -     -    -
+state    real  U_NDG_NEW         ijkf     fdda3d      1         X      i{10}r   "U_NDG_NEW"               "NEW X WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  V_NDG_NEW         ijkf     fdda3d      1         Y      i{10}r   "V_NDG_NEW"               "NEW Y WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  T_NDG_NEW         ijkf     fdda3d      1         -      i{10}r   "T_NDG_NEW"               "NEW PERT POT TEMP FOR FDDA GRID NUDGING"  "K"
+state    real  Q_NDG_NEW         ijkf     fdda3d      1         -      i{10}r   "Q_NDG_NEW"               "NEW WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  PH_NDG_NEW        ijkf     fdda3d      1         Z      i{10}r   "PH_NDG_NEW"              "NEW PERT GEOPOTENTIAL FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  U_NDG_OLD         ijkf     fdda3d      1         X      i{10}r   "U_NDG_OLD"               "OLD X WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  V_NDG_OLD         ijkf     fdda3d      1         Y      i{10}r   "V_NDG_OLD"               "OLD Y WIND FOR FDDA GRID NUDGING"  "m s-1"
+state    real  T_NDG_OLD         ijkf     fdda3d      1         -      i{10}r   "T_NDG_OLD"               "OLD PERT POT TEMP FOR FDDA GRID NUDGING"  "K"
+state    real  Q_NDG_OLD         ijkf     fdda3d      1         -      i{10}r   "Q_NDG_OLD"               "OLD WATER VAPOR MIX RATIO FOR FDDA GRID NUDGING"  "kg/kg"
+state    real  PH_NDG_OLD        ijkf     fdda3d      1         Z      i{10}r   "PH_NDG_OLD"              "OLD PERT GEOPOTENTIAL FOR FDDA GRID NUDGING"  "kg/kg"
+state    real    -               ijvf     fdda2d      1         Z     -    -
+state    real  MU_NDG_NEW        ijvf     fdda2d      1         -      i{10}r   "MU_NDG_NEW"              "NEW PERT COLUMN DRY MASS FOR FDDA GRID NUDGING"  "Pa"
+state    real  MU_NDG_OLD        ijvf     fdda2d      1         -      i{10}r   "MU_NDG_OLD"              "OLD PERT COLUMN DRY MASS FOR FDDA GRID NUDGING"  "Pa"
+state    real  U10_NDG_OLD       ij         misc      1         X      i9r      "U10_NDG_OLD"             "OLD U10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  U10_NDG_NEW       ij         misc      1         X      i9r      "U10_NDG_NEW"             "NEW U10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  V10_NDG_OLD       ij         misc      1         Y      i9r      "V10_NDG_OLD"             "OLD V10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  V10_NDG_NEW       ij         misc      1         Y      i9r      "V10_NDG_NEW"             "NEW V10 FOR SURFACE FDDA GRID NUDGING"  "m s-1"
+state    real  T2_NDG_OLD        ij         misc      1         -      i9r      "T2_NDG_OLD"              "OLD T2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  T2_NDG_NEW        ij         misc      1         -      i9r      "T2_NDG_NEW"              "NEW T2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  TH2_NDG_OLD       ij         misc      1         -      i9r      "TH2_NDG_OLD"             "OLD TH2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  TH2_NDG_NEW       ij         misc      1         -      i9r      "TH2_NDG_NEW"             "NEW TH2 FOR SURFACE FDDA GRID NUDGING"  "K"
+state    real  Q2_NDG_OLD        ij         misc      1         -      i9r      "Q2_NDG_OLD"              "OLD Q2 FOR SURFACE FDDA GRID NUDGING"  "kg kg-1"
+state    real  Q2_NDG_NEW        ij         misc      1         -      i9r      "Q2_NDG_NEW"              "NEW Q2 FOR SURFACE FDDA GRID NUDGING"  "kg kg-1"
+state    real  RH_NDG_OLD        ij         misc      1         -      i9r      "RH_NDG_OLD"              "OLD RH FOR SURFACE FDDA GRID NUDGING"  "%"
+state    real  RH_NDG_NEW        ij         misc      1         -      i9r      "RH_NDG_NEW"              "NEW RH FOR SURFACE FDDA GRID NUDGING"  "%"
+state    real  PSL_NDG_OLD       ij         misc      1         -      i9r      "PSL_NDG_OLD"             "OLD PSL FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PSL_NDG_NEW       ij         misc      1         -      i9r      "PSL_NDG_NEW"             "NEW PSL FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PS_NDG_OLD        ij         misc      1         -      i9r      "PS_NDG_OLD"              "OLD PS FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  PS_NDG_NEW        ij         misc      1         -      i9r      "PS_NDG_NEW"              "NEW PS FOR SURFACE FDDA GRID NUDGING"  "Pa"
+state    real  TOB_NDG_OLD       ij         misc      1         -      i9r      "TOB_NDG_OLD"             "OLD TOB FOR SURFACE FDDA GRID NUDGING"  ""
+state    real  ODIS_NDG_OLD      ij         misc      1         -      i9r      "ODIS_NDG_OLD"            "OLD ODIS FOR SURFACE FDDA GRID NUDGING"  "km"
+state    real  TOB_NDG_NEW       ij         misc      1         -      i9r      "TOB_NDG_NEW"             "NEW TOB FOR SURFACE FDDA GRID NUDGING"  ""
+state    real  ODIS_NDG_NEW      ij         misc      1         -      i9r      "ODIS_NDG_NEW"            "NEW ODIS FOR SURFACE FDDA GRID NUDGING"  "km"
+state    real  SN_NDG_NEW        ij         misc      1         -      i9r      "SN_NDG_NEW"              "NEW Snow Water Equivalent"  "mm"
+state    real  SN_NDG_OLD        ij         misc      1         -      i9r      "SN_NDG_OLD"              "OLD Snow Water Equivalent"  "mm"
+
+# flag for nest movement
+state  logical moved            -       misc        1         -     -          
+
+# special cam radiation restart arrays
+state  real   abstot   ijkc   misc      1    Z   -     ""   ""  " "
+state  real   absnxt   ijka   misc      1    -   -     ""   ""  " "
+state  real   emstot   ijk    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"
+
+state   real    max_cfl         -       misc        1         -     -       "max_cfl"           "maximum CFL value in grid at a time" "-"
+
+state   real  prec_acc_c       ij       misc        1         -     rh       "prec_acc_c"       "ACCUMULATED CUMULUS PRECIPITATION OVER prec_acc_dt PERIODS OF TIME"       "mm"
+state   real  prec_acc_nc      ij       misc        1         -     rh       "prec_acc_nc"      "ACCUMULATED GRID SCALE  PRECIPITATION OVER prec_acc_dt PERIODS OF TIME"   "mm"
+state   real  snow_acc_nc      ij       misc        1         -     rh       "snow_acc_nc"      "ACCUMULATED SNOW WATER EQUIVALENT OVER prec_acc_dt PERIODS OF TIME"       "mm"
+
+# Ocean Mixed-Layer State Variables
+state   real    TML            ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "TML"    "OCEAN MIXED-LAYER TEMPERATURE"   "K"
+state   real    T0ML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "T0ML"   "INITIAL OCEAN MIXED-LAYER TEMPERATURE"   "K"
+state   real    HML            ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HML"    "OCEAN MIXED-LAYER DEPTH"   "m"
+state   real    H0ML           ij      misc         1         -     i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "H0ML"   "INITIAL OCEAN MIXED-LAYER DEPTH"   "m"
+state   real    HUML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HUML"   "OCEAN MIXED-LAYER DEPTH * U-CURRENT"  " m2s-1 "
+state   real    HVML           ij      misc         1         -     rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm)    "HVML"   "OCEAN MIXED-LAYER DEPTH * V-CURRENT"  " m2s-1 " 
+state   real    TMOML          ij      misc         1         -     i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm) "TMOML"  "OCEAN LAYER MEAN TEMPERATURE   "   "K"
+
+#
+#---------------------------------------------------------------------------------------------------------------------------------------
+#                                               
+
+######                                          
+#                                               
+# Variables that are set at run-time to control configuration  (namelist-settable)                                              
+#                                               
+#<Table>  <Type>  <Sym>                   <How set>          <Nentries>   <Default>                                             
+
+rconfig   logical   use_background_errors   namelist,wrfvar1  1  .true.   -  "use_background_errors"   ""  ""
+rconfig   logical   write_increments        namelist,wrfvar1  1  .false.  -  "write_increments"        ""  ""
+rconfig   logical   var4d                   namelist,wrfvar1  1  .false.  -  "var4d"                   ""  ""
+rconfig   integer   var4d_bin               namelist,wrfvar1  1  3600     -  "var4d_bin"               ""  ""
+rconfig   logical   var4d_lbc               namelist,wrfvar1  1  .true.   -  "var4d_lbc"               ""  ""
+rconfig   integer   multi_inc               namelist,wrfvar1  1  0        -  "multi_incremental flag"  ""  ""
+rconfig   logical   print_detail_radar      namelist,wrfvar1  1  .false.  -  "print_detail_radar"      ""  ""
+rconfig   logical   print_detail_rad        namelist,wrfvar1  1  .false.  -  "print_detail_rad"        ""  ""
+rconfig   logical   print_detail_xa         namelist,wrfvar1  1  .false.  -  "print_detail_xa"         ""  ""
+rconfig   logical   print_detail_xb         namelist,wrfvar1  1  .false.  -  "print_detail_xb"         ""  ""
+rconfig   logical   print_detail_obs        namelist,wrfvar1  1  .false.  -  "print_detail_obs"        ""  ""
+rconfig   logical   print_detail_f_obs      namelist,wrfvar1  1  .false.  -  "print_detail_f_obs"      ""  ""
+rconfig   logical   print_detail_map        namelist,wrfvar1  1  .false.  -  "print_detail_map"        ""  ""
+rconfig   logical   print_detail_grad       namelist,wrfvar1  1  .false.  -  "print_detail_grad"       ""  ""
+rconfig   logical   print_detail_regression namelist,wrfvar1  1  .false.  -  "print_detail_regression" ""  ""
+rconfig   logical   print_detail_spectral   namelist,wrfvar1  1  .false.  -  "print_detail_spectral"   ""  ""
+rconfig   logical   print_detail_testing    namelist,wrfvar1  1  .false.  -  "print_detail_testing"    ""  ""
+rconfig   logical   print_detail_parallel   namelist,wrfvar1  1  .false.  -  "print_detail_parallel"   ""  ""
+rconfig   logical   print_detail_be         namelist,wrfvar1  1  .false.  -  "print_detail_be"         ""  ""
+rconfig   logical   print_detail_outerloop  namelist,wrfvar1  1  .false.  -  "print_detail_outerloop"  ""  ""
+rconfig   logical   check_max_iv_print      namelist,wrfvar1  1  .true.   -  "check_max_iv_print"      ""  ""
+rconfig   logical   check_buddy_print       namelist,wrfvar1  1  .false.  -  "check_buddy_print"       ""  ""
+
+rconfig   integer   analysis_accu           namelist,wrfvar2  1  900      -  "analysis_accu"           ""  ""
+rconfig   logical   calc_w_increment        namelist,wrfvar2  1  .false.  -  "calc_w_increment"        ""  ""
+rconfig   logical   dt_cloud_model          namelist,wrfvar2  1  .false.  -  "dt_cloud_model"          ""  ""
+rconfig   logical   write_mod_filtered_obs  namelist,wrfvar2  1  .false.  -  "write_mod_filtered_obs"  ""  ""
+
+rconfig   integer   fg_format               namelist,wrfvar3  1  1        - "fg_format"                ""  "1=WRF, 3=KMA"
+rconfig   integer   ob_format               namelist,wrfvar3  1  2        - "ob_format"                ""  "1=BUFR,2=ASCII"
+rconfig   integer   num_fgat_time           namelist,wrfvar3  1  1        - "num_fgat_time"            ""  ""
+rconfig   logical   thin_conv               namelist,wrfvar4  1  .true.   - "thin_conv"                ""  ""
+rconfig   real      thin_mesh_conv          namelist,wrfvar4  max_instruments  20.0   - "thin_mesh_conv"            ""  ""
+rconfig   logical   use_synopobs            namelist,wrfvar4  1  .true.   - "use_synopobs"             ""  ""
+rconfig   logical   use_shipsobs            namelist,wrfvar4  1  .true.   - "use_shipsobs"             ""  ""
+rconfig   logical   use_metarobs            namelist,wrfvar4  1  .true.   - "use_metarobs"             ""  ""
+rconfig   logical   use_soundobs            namelist,wrfvar4  1  .true.   - "use_soundobs"             ""  ""
+rconfig   logical   use_mtgirsobs           namelist,wrfvar4  1  .true.   - "use_mtgirsobs"            ""  ""
+rconfig   logical   use_tamdarobs           namelist,wrfvar4  1  .true.   - "use_tamdarobs"            ""  ""
+rconfig   logical   use_pilotobs            namelist,wrfvar4  1  .true.   - "use_pilotobs"             ""  ""
+rconfig   logical   use_airepobs            namelist,wrfvar4  1  .true.   - "use_airepobs"             ""  ""
+rconfig   logical   use_geoamvobs           namelist,wrfvar4  1  .true.   - "use_geoamvobs"            ""  ""
+rconfig   logical   use_polaramvobs         namelist,wrfvar4  1  .true.   - "use_polaramvobs"          ""  ""
+rconfig   logical   use_bogusobs            namelist,wrfvar4  1  .true.   - "use_bogusobs"             ""  ""
+rconfig   logical   use_buoyobs             namelist,wrfvar4  1  .true.   - "use_buoyobs"              ""  ""
+rconfig   logical   use_profilerobs         namelist,wrfvar4  1  .true.   - "use_profilerobs"          ""  ""
+rconfig   logical   use_satemobs            namelist,wrfvar4  1  .true.   - "use_satemobs"             ""  ""
+rconfig   logical   use_gpsztdobs           namelist,wrfvar4  1  .false.  - "use_gpsztdobs"            ""  ""
+rconfig   logical   use_gpspwobs            namelist,wrfvar4  1  .true.   - "use_gpspwobs"             ""  ""
+rconfig   logical   use_gpsrefobs           namelist,wrfvar4  1  .true.   - "use_gpsrefobs"            ""  ""
+rconfig   real      top_km_gpsro            namelist,wrfvar4  1  30.0     - "top_km_gpsro"             ""  ""
+rconfig   real      bot_km_gpsro            namelist,wrfvar4  1   0.0     - "bot_km_gpsro"             ""  ""
+rconfig   logical   use_ssmiretrievalobs    namelist,wrfvar4  1  .false.  - "use_ssmiretrievalobs"     ""  ""
+rconfig   logical   use_ssmitbobs           namelist,wrfvar4  1  .false.  - "use_ssmitbobs"            ""  ""
+rconfig   logical   use_ssmt1obs            namelist,wrfvar4  1  .false.  - "use_ssmt1obs"             ""  ""
+rconfig   logical   use_ssmt2obs            namelist,wrfvar4  1  .false.  - "use_ssmt2obs"             ""  ""
+rconfig   logical   use_qscatobs            namelist,wrfvar4  1  .true.   - "use_qscatobs"             ""  ""
+rconfig   logical   use_radarobs            namelist,wrfvar4  1  .false.  - "use_radarobs"             ""  ""
+rconfig   logical   use_radar_rv            namelist,wrfvar4  1  .false.  - "use_radar_rv"             ""  ""
+rconfig   logical   use_radar_rf            namelist,wrfvar4  1  .false.  - "use_radar_rf"             ""  ""
+rconfig   logical   use_radar_rle           namelist,wrfvar4  1  .false.  - "use_radar_rle"             ""  ""
+rconfig   logical   use_radar_rr            namelist,wrfvar4  1  .false.  - "use_radar_rr"             ""  ""
+rconfig   logical   use_hirs2obs            namelist,wrfvar4  1  .false.  - "use_hirs2obs"             ""  ""
+rconfig   logical   use_hirs3obs            namelist,wrfvar4  1  .false.  - "use_hirs3obs"             ""  ""
+rconfig   logical   use_hirs4obs            namelist,wrfvar4  1  .false.  - "use_hirs4obs"             ""  ""
+rconfig   logical   use_mhsobs              namelist,wrfvar4  1  .false.  - "use_mhsobs"               ""  ""
+rconfig   logical   use_msuobs              namelist,wrfvar4  1  .false.  - "use_msuobs"               ""  ""
+rconfig   logical   use_amsuaobs            namelist,wrfvar4  1  .false.  - "use_amsuaobs"             ""  ""
+rconfig   logical   use_amsubobs            namelist,wrfvar4  1  .false.  - "use_amsubobs"             ""  ""
+rconfig   logical   use_airsobs             namelist,wrfvar4  1  .false.  - "use_airsobs"              ""  ""
+rconfig   logical   use_airsretobs          namelist,wrfvar4  1  .true.   - "use_airsretobs"           ""  ""
+rconfig   logical   use_eos_amsuaobs        namelist,wrfvar4  1  .false.  - "use_eos_amsuaobs"         ""  ""
+rconfig   logical   use_hsbobs              namelist,wrfvar4  1  .false.  - "use_hsbobs"               ""  ""
+rconfig   logical   use_ssmisobs            namelist,wrfvar4  1  .false.  - "use_ssmisobs"             ""  ""
+rconfig   logical   use_kma1dvar            namelist,wrfvar4  1  .false.  - "use_kma1dvar"             ""  ""
+rconfig   logical   use_filtered_rad        namelist,wrfvar4  1  .false.  - "use_filtered_rad"         ""  ""
+rconfig   logical   use_obs_errfac          namelist,wrfvar4  1  .false.  - "use_obs_errfac"           ""  ""
+
+rconfig   logical   check_max_iv            namelist,wrfvar5  1  .true.   - "check_max_iv"             ""  ""
+rconfig   real      max_error_t             namelist,wrfvar5  1   5.0     - "max_error_t"              ""  ""
+rconfig   real      max_error_uv            namelist,wrfvar5  1   5.0     - "max_error_uv"             ""  ""
+rconfig   real      max_error_pw            namelist,wrfvar5  1   5.0     - "max_error_pw"             ""  ""
+rconfig   real      max_error_ref           namelist,wrfvar5  1   5.0     - "max_error_ref"            ""  ""
+rconfig   real      max_error_rh            namelist,wrfvar5  1   5.0     - "max_error_rh"             ""  ""
+rconfig   real      max_error_q             namelist,wrfvar5  1   5.0     - "max_error_q"              ""  ""
+rconfig   real      max_error_p             namelist,wrfvar5  1   5.0     - "max_error_p"              ""  ""
+rconfig   real      max_error_tb            namelist,wrfvar5  1   5.0     - "max_error_tb"             ""  ""
+rconfig   real      max_error_thickness     namelist,wrfvar5  1   5.0     - "max_error_thickness"      ""  ""
+rconfig   real      max_error_rv            namelist,wrfvar5  1   5.0     - "max_error_rv"             ""  ""
+rconfig   real      max_error_rf            namelist,wrfvar5  1   5.0     - "max_error_rf"             ""  ""
+rconfig   real      max_error_buv           namelist,wrfvar5  1   500.0   - "max_error_buv"            ""  ""
+rconfig   real      max_error_bt            namelist,wrfvar5  1   500.0   - "max_error_bt"             ""  ""
+rconfig   real      max_error_bq            namelist,wrfvar5  1   500.0   - "max_error_bq"             ""  ""
+rconfig   real      max_error_slp           namelist,wrfvar5  1   500.0   - "max_error_slp"            ""  ""
+rconfig   logical   check_buddy             namelist,wrfvar5  1  .false.  - "check_buddy"              ""  ""
+rconfig   logical   put_rand_seed           namelist,wrfvar5  1  .false.  - "put_rand_seed"            ""  ""
+rconfig   logical   omb_set_rand            namelist,wrfvar5  1  .false.  - "omb_set_rand"             ""  ""
+rconfig   logical   omb_add_noise           namelist,wrfvar5  1  .false.  - "omb_add_noise"            ""  ""
+rconfig   logical   position_lev_dependant  namelist,wrfvar5  1  .false.  - "position_lev_dependant"   ""  ""
+rconfig   integer   obs_qc_pointer          namelist,wrfvar5  1  0        - "obs_qc_pointer"           ""  ""
+rconfig   integer   qmarker_retain          namelist,wrfvar5  1  3        - "qmarker_retain"           ""  ""
+rconfig   integer   max_sound_input         namelist,wrfvar5  1  50000000 - "max_sound_input"          ""  ""
+rconfig   integer   max_mtgirs_input        namelist,wrfvar5  1  50000000 - "max_mtgirs_input"         ""  ""
+rconfig   integer   max_tamdar_input        namelist,wrfvar5  1  50000000 - "max_tamdar_input"         ""  ""
+rconfig   integer   max_synop_input         namelist,wrfvar5  1  50000000 - "max_synop_input"          ""  ""
+rconfig   integer   max_geoamv_input        namelist,wrfvar5  1  30000000 - "max_geoamv_input"         ""  ""
+rconfig   integer   max_polaramv_input      namelist,wrfvar5  1  30000000 - "max_polaramv_input"       ""  ""
+rconfig   integer   max_airep_input         namelist,wrfvar5  1  20000000 - "max_airep_input"          ""  ""
+rconfig   integer   max_satem_input         namelist,wrfvar5  1  50000000 - "max_satem_input"          ""  ""
+rconfig   integer   max_pilot_input         namelist,wrfvar5  1  30000000 - "max_pilot_input"          ""  ""
+rconfig   integer   max_radar_input         namelist,wrfvar5  1  10000000 - "max_radar_input"          ""  ""
+rconfig   integer   max_metar_input         namelist,wrfvar5  1  30000000 - "max_metar_input"          ""  ""
+rconfig   integer   max_gpspw_input         namelist,wrfvar5  1  40000000 - "max_gpspw_input"          ""  ""
+rconfig   integer   max_ships_input         namelist,wrfvar5  1  20000000 - "max_ships_input"          ""  ""
+rconfig   integer   max_profiler_input      namelist,wrfvar5  1  30000000 - "max_profiler_input"       ""  ""
+rconfig   integer   max_bogus_input         namelist,wrfvar5  1  50000000 - "max_bogus_input"          ""  ""
+rconfig   integer   max_buoy_input          namelist,wrfvar5  1  30000000 - "max_buoy_input"           ""  ""
+rconfig   integer   max_ssmi_rv_input       namelist,wrfvar5  1  30000000 - "max_ssmi_rv_input"        ""  ""
+rconfig   integer   max_ssmi_tb_input       namelist,wrfvar5  1  30000000 - "max_ssmi_tb_input"        ""  ""
+rconfig   integer   max_ssmt1_input         namelist,wrfvar5  1  30000000 - "max_ssmt1_input"          ""  ""
+rconfig   integer   max_ssmt2_input         namelist,wrfvar5  1  30000000 - "max_ssmt2_input"          ""  ""
+rconfig   integer   max_qscat_input         namelist,wrfvar5  1  50000000 - "max_qscat_input"          ""  ""
+rconfig   integer   max_gpsref_input        namelist,wrfvar5  1  80000000 - "max_gpsref_input"         ""  ""
+rconfig   integer   max_airsr_input         namelist,wrfvar5  1  10000000 - "max_airsr_input"          ""  ""
+rconfig   integer   max_tovs_input          namelist,wrfvar5  1  10000000 - "max_tovs_input"           ""  ""
+rconfig   integer   max_ssmis_input         namelist,wrfvar5  1  10000000 - "max_ssmis_input"          ""  ""
+rconfig   integer   report_start            namelist,wrfvar5  1  1        - "report_start"             ""  ""
+rconfig   integer   report_end              namelist,wrfvar5  1  10000000 - "report_end"               ""  ""
+rconfig   integer   tovs_start              namelist,wrfvar5  1  1        - "tovs_start"               ""  ""
+rconfig   integer   tovs_end                namelist,wrfvar5  1  10000000 - "tovs_end"                 ""  ""
+rconfig   logical   gpsref_thinning         namelist,wrfvar5  1  .false.  - "gpsref_thinning"          ""  ""
+
+rconfig   integer   max_ext_its             namelist,wrfvar6  1  1        - "max_ext_its"              ""  ""
+rconfig   integer   ntmax                   namelist,wrfvar6  1  200      - "ntmax"                    ""  ""
+rconfig   integer   nsave                   namelist,wrfvar6  1  4        - "nsave"                    ""  ""
+rconfig   integer   write_interval          namelist,wrfvar6  1  5        - "write_interval"           ""  ""
+rconfig   real      eps                     namelist,wrfvar6  max_outer_iterations 0.01     - "eps"                      ""  ""
+rconfig   logical   precondition_cg         namelist,wrfvar6  1  .false.  -  "precondition_cg"         ""  ""
+rconfig   real      precondition_factor     namelist,wrfvar6  1  1.0      -  "precondition_factor"     ""  ""
+rconfig   logical   use_lanczos             namelist,wrfvar6  1  .false.  - "use_lanczos"              ""  ""
+rconfig   logical   orthonorm_gradient      namelist,wrfvar6  1  .false.  - "orthonorm_gradient"       ""  ""
+
+rconfig   integer   cv_options              namelist,wrfvar7  1  5        - "cv_options"               ""  ""
+rconfig   integer   cloud_cv_options        namelist,wrfvar7  1  1        - "cloud_cv_options"         ""  ""
+rconfig   real      as1                     namelist,wrfvar7  3 -1.0      - "as1"                      ""  ""
+rconfig   real      as2                     namelist,wrfvar7  3 -1.0      - "as2"                      ""  ""
+rconfig   real      as3                     namelist,wrfvar7  3 -1.0      - "as3"                      ""  ""
+rconfig   real      as4                     namelist,wrfvar7  3 -1.0      - "as4"                      ""  ""
+rconfig   real      as5                     namelist,wrfvar7  3 -1.0      - "as5"                      ""  ""
+rconfig   logical   do_normalize            namelist,wrfvar7  1  .false.  - "do_normalize" "Do normalize"  ""
+rconfig   logical   use_rf                  namelist,wrfvar7  1  .true.   - "use_rf" "Use recursive filters" ""
+rconfig   integer   rf_passes               namelist,wrfvar7  1  6        - "rf_passes"                ""  ""
+rconfig   real      var_scaling1            namelist,wrfvar7  max_outer_iterations  1.0      - "var_scaling1"             ""  ""
+rconfig   real      var_scaling2            namelist,wrfvar7  max_outer_iterations  1.0      - "var_scaling2"             ""  ""
+rconfig   real      var_scaling3            namelist,wrfvar7  max_outer_iterations  1.0      - "var_scaling3"             ""  ""
+rconfig   real      var_scaling4            namelist,wrfvar7  max_outer_iterations  1.0      - "var_scaling4"             ""  ""
+rconfig   real      var_scaling5            namelist,wrfvar7  max_outer_iterations  1.0      - "var_scaling5"             ""  ""
+rconfig   real      var_scaling6            namelist,wrfvar7  max_outer_iterations  1.0      - "var_scaling6"             ""  ""
+rconfig   real      var_scaling7            namelist,wrfvar7  max_outer_iterations  1.0      - "var_scaling7"             ""  ""
+rconfig   real      var_scaling8            namelist,wrfvar7  max_outer_iterations  1.0      - "var_scaling8"             ""  ""
+rconfig   real      len_scaling1            namelist,wrfvar7  max_outer_iterations  1.0      - "len_scaling1"             ""  ""
+rconfig   real      len_scaling2            namelist,wrfvar7  max_outer_iterations  1.0      - "len_scaling2"             ""  ""
+rconfig   real      len_scaling3            namelist,wrfvar7  max_outer_iterations  1.0      - "len_scaling3"             ""  ""
+rconfig   real      len_scaling4            namelist,wrfvar7  max_outer_iterations  1.0      - "len_scaling4"             ""  ""
+rconfig   real      len_scaling5            namelist,wrfvar7  max_outer_iterations  1.0      - "len_scaling5"             ""  ""
+rconfig   real      len_scaling6            namelist,wrfvar7  max_outer_iterations  1.0      - "len_scaling6"             ""  ""
+rconfig   real      len_scaling7            namelist,wrfvar7  max_outer_iterations  1.0      - "len_scaling7"             ""  ""
+rconfig   real      len_scaling8            namelist,wrfvar7  max_outer_iterations  1.0      - "len_scaling8"             ""  ""
+rconfig   real      je_factor               namelist,wrfvar7  1  1.0      - "je_factor"                ""  ""
+rconfig   real      power_truncation        namelist,wrfvar7  1  1.0      - "power_truncation"         ""  ""
+
+rconfig   logical   def_sub_domain          namelist,wrfvar8  1  .false.  - "def_sub_domain"           ""  ""
+rconfig   real      x_start_sub_domain      namelist,wrfvar8  1  1.0      - "x_start_sub_domain"       ""  ""
+rconfig   real      y_start_sub_domain      namelist,wrfvar8  1  1.0      - "y_start_sub_domain"       ""  ""
+rconfig   real      x_end_sub_domain        namelist,wrfvar8  1  1.0e10   - "x_end_sub_domain"         ""  ""
+rconfig   real      y_end_sub_domain        namelist,wrfvar8  1  1.0e10   - "y_end_sub_domain"         ""  ""
+
+rconfig   integer   stdout                  namelist,wrfvar9  1  6         - "stdout"                  ""  ""
+rconfig   integer   stderr                  namelist,wrfvar9  1  0         - "stderr"                  ""  ""
+rconfig   integer   trace_unit              namelist,wrfvar9  1  7         - "trace_unit"              ""  ""
+rconfig   integer   trace_pe                namelist,wrfvar9  1  0         - "trace_pe"                ""  ""
+rconfig   integer   trace_repeat_head       namelist,wrfvar9  1  10        - "trace_repeat_head"       ""  ""
+rconfig   integer   trace_repeat_body       namelist,wrfvar9  1  10        - "trace_repeat_body"       ""  ""
+rconfig   integer   trace_max_depth         namelist,wrfvar9  1  30        - "trace_max_depth"         ""  ""
+rconfig   logical   trace_use               namelist,wrfvar9  1  .false.   - "trace_use"               ""  ""
+rconfig   logical   trace_use_frequent      namelist,wrfvar9  1  .false.   - "trace_use_frequent"      ""  ""
+rconfig   logical   trace_use_dull          namelist,wrfvar9  1  .false.    - "trace_use_dull"          ""  ""
+rconfig   logical   trace_memory            namelist,wrfvar9  1  .true.    - "trace_memory"            ""  ""
+rconfig   logical   trace_all_pes           namelist,wrfvar9  1  .false.   - "trace_all_pes"           ""  ""
+rconfig   logical   trace_csv               namelist,wrfvar9  1  .true.    - "trace_csv"               ""  ""
+rconfig   logical   use_html                namelist,wrfvar9  1  .true.    - "use_html"                ""  ""
+rconfig   logical   warnings_are_fatal      namelist,wrfvar9  1  .false.   - "warnings_are_fatal"      ""  ""
+
+rconfig   logical   test_transforms         namelist,wrfvar10  1  .false.  - "test_transforms"         ""  ""  
+rconfig   logical   test_statistics         namelist,wrfvar10  1  .false.  - "test_statistics"         ""  ""  
+rconfig   logical   interpolate_stats       namelist,wrfvar10  1  .true.   - "interpolate_stats"       ""  ""  
+rconfig   real      be_eta                  namelist,wrfvar10 99  0.0      - "interpolate_stats"       ""  ""
+rconfig   logical   test_dm_exact           namelist,wrfvar10  1  .false.  - "test_dm_exact"           ""  ""  
+
+rconfig   integer   cv_options_hum          namelist,wrfvar11  1  1        - "cv_options_hum"          ""  ""  
+rconfig   integer   check_rh                namelist,wrfvar11  1  0        - "check_rh"                ""  ""  
+rconfig   real      set_omb_rand_fac        namelist,wrfvar11  1  1.0      - "set_omb_rand_fac"        ""  ""  
+rconfig   integer   seed_array1             namelist,wrfvar11  1  0        - "seed_array1"             ""  ""  
+rconfig   integer   seed_array2             namelist,wrfvar11  1  0        - "seed_array2"             ""  ""  
+rconfig   integer   sfc_assi_options        namelist,wrfvar11  1  1        - "sfc_assi_options"        ""  ""  
+rconfig   logical   calculate_cg_cost_fn    namelist,wrfvar11  1  .false.  - "calculate_cg_cost_fn"    ""  ""  
+rconfig   logical   lat_stats_option        namelist,wrfvar11  1  .false.  - "lat_stats_option"        ""  ""  
+rconfig   integer   interp_option           namelist,wrfvar11  1  1        - "interp_option"           ""  ""
+
+rconfig   integer   balance_type            namelist,wrfvar12  1  1        - "balance_type"            ""  ""  
+                                                                                          
+rconfig   integer   vert_corr               namelist,wrfvar13  1  2        - "vert_corr"               ""  ""  
+rconfig   integer   vertical_ip             namelist,wrfvar13  1  0        - "vertical_ip"             ""  ""  
+rconfig   integer   vert_evalue             namelist,wrfvar13  1  1        - "vert_evalue"             ""  ""  
+rconfig   real      max_vert_var1           namelist,wrfvar13  1  99.0     - "max_vert_var1"           ""  ""  
+rconfig   real      max_vert_var2           namelist,wrfvar13  1  99.0     - "max_vert_var2"           ""  ""  
+rconfig   real      max_vert_var3           namelist,wrfvar13  1  99.0     - "max_vert_var3"           ""  ""  
+rconfig   real      max_vert_var4           namelist,wrfvar13  1  99.0     - "max_vert_var4"           ""  ""  
+rconfig   real      max_vert_var5           namelist,wrfvar13  1  99.0     - "max_vert_var5"           ""  ""  
+rconfig   real      max_vert_var6           namelist,wrfvar13  1  99.0     - "max_vert_var6"           ""  ""
+rconfig   real      max_vert_var7           namelist,wrfvar13  1  99.0     - "max_vert_var7"           ""  ""
+rconfig   real      max_vert_var8           namelist,wrfvar13  1  99.0     - "max_vert_var8"           ""  ""
+rconfig   real      max_vert_var_alpha      namelist,wrfvar13  1  99.0     - "max_vert_var_alpha"      ""  ""
+rconfig   real      psi_chi_factor          namelist,wrfvar13  1  1.0      - "psi_chi_factor"          ""  ""
+rconfig   real      psi_t_factor            namelist,wrfvar13  1  1.0      - "psi_t_factor"            ""  ""
+rconfig   real      psi_ps_factor           namelist,wrfvar13  1  1.0      - "psi_ps_factor"           ""  ""
+rconfig   real      psi_rh_factor           namelist,wrfvar13  1  1.0      - "psi_rh_factor"           ""  ""
+rconfig   real      chi_u_t_factor          namelist,wrfvar13  1  1.0      - "chi_u_t_factor"          ""  ""
+rconfig   real      chi_u_ps_factor         namelist,wrfvar13  1  1.0      - "chi_u_ps_factor"         ""  ""
+rconfig   real      chi_u_rh_factor         namelist,wrfvar13  1  1.0      - "chi_u_rh_factor"         ""  ""
+rconfig   real      t_u_rh_factor           namelist,wrfvar13  1  1.0      - "t_u_rh_factor"           ""  ""
+rconfig   real      ps_u_rh_factor          namelist,wrfvar13  1  1.0      - "ps_u_rh_factor"          ""  ""
+
+rconfig   integer   rttov_emis_atlas_ir     namelist,wrfvar14  1  0        - "rttov_emis_atlas_ir"     ""  ""  
+rconfig   integer   rttov_emis_atlas_mw     namelist,wrfvar14  1  0        - "rttov_emis_atlas_mw"     ""  ""  
+rconfig   integer   rtminit_print           namelist,wrfvar14  1  1        - "rtminit_print"           ""  ""  
+rconfig   integer   rtminit_nsensor         namelist,wrfvar14  1  1        - "rtminit_nsensor"         ""  ""  
+rconfig   integer   rtminit_platform        namelist,wrfvar14  max_instruments -1       - "rtminit_platform"        ""  ""  
+rconfig   integer   rtminit_satid           namelist,wrfvar14  max_instruments -1.0     - "rtminit_satid"           ""  ""  
+rconfig   integer   rtminit_sensor          namelist,wrfvar14  max_instruments -1.0     - "rtminit_sensor"          ""  ""  
+rconfig   integer   rad_monitoring          namelist,wrfvar14  max_instruments 0        - "rad_monitoring"          ""  ""
+rconfig   real      thinning_mesh           namelist,wrfvar14  max_instruments 60.0     - "thinning_mesh"           ""  ""
+rconfig   logical   thinning                namelist,wrfvar14  1  .false.  - "thinning "               ""  ""
+rconfig   logical   read_biascoef           namelist,wrfvar14  1  .false.  - "read_biascoef"           ""  ""   
+rconfig   logical   biascorr                namelist,wrfvar14  1  .false.  - "biascorr"                ""  ""   
+rconfig   logical   biasprep                namelist,wrfvar14  1  .false.  - "biasprep"                ""  ""   
+rconfig   logical   rttov_scatt             namelist,wrfvar14  1  .false.  - "rttov_scatt"             ""  ""   
+rconfig   logical   write_profile           namelist,wrfvar14  1  .false.  - "write_profile"           ""  ""   
+rconfig   logical   write_jacobian          namelist,wrfvar14  1  .false.  - "write_jacobian"          ""  ""
+rconfig   logical   qc_rad                  namelist,wrfvar14  1  .true.   - "qc_rad"                  ""  ""   
+rconfig   logical   write_iv_rad_ascii      namelist,wrfvar14  1  .false.  - "write_iv_rad_ascii"      ""  ""   
+rconfig   logical   write_oa_rad_ascii      namelist,wrfvar14  1  .false.  - "write_oa_rad_ascii"      ""  ""   
+rconfig   logical   write_filtered_rad      namelist,wrfvar14  1  .false.  - "write_filtered_rad"      ""  ""   
+rconfig   logical   use_error_factor_rad    namelist,wrfvar14  1  .false.  - "use_error_factor_rad"    ""  ""   
+rconfig   logical   use_landem              namelist,wrfvar14  1  .false.  - "use_landem"              ""  ""   
+rconfig   logical   use_antcorr             namelist,wrfvar14  max_instruments .false.  - "use_antcorr"           ""  ""
+rconfig   logical   use_mspps_emis          namelist,wrfvar14  max_instruments .false.  - "use_mspps_emis"        ""  ""
+rconfig   logical   use_mspps_ts            namelist,wrfvar14  max_instruments .false.  - "use_mspps_ts"          ""  ""
+rconfig   integer   mw_emis_sea             namelist,wrfvar14  1  1        - "mw_emis_sea"             ""  ""   
+rconfig   integer   tovs_min_transfer       namelist,wrfvar14  1  10       - "tovs_min_transfer"       ""  ""     
+rconfig   logical   tovs_batch              namelist,wrfvar14  1  .false.  - "tovs_batch"              ""  "" 
+rconfig   integer   rtm_option              namelist,wrfvar14  1  1        - "rtm_option"              ""  ""
+rconfig   logical   use_crtm_kmatrix        namelist,wrfvar14  1  .false.  - "use_crtm_kmatrix"        ""  ""
+rconfig   logical   use_rttov_kmatrix       namelist,wrfvar14  1  .false.  - "use_rttov_kmatrix"       ""  ""
+rconfig   logical   crtm_cloud              namelist,wrfvar14  1  .false.  - "crtm_cloud"              ""  ""
+rconfig   logical   only_sea_rad            namelist,wrfvar14  1  .false.  - "only_sea_rad"            ""  ""
+rconfig   logical   use_pseudo_rad          namelist,wrfvar14  1  .false.  - "use_pseudo_rad"          ""  ""
+rconfig   integer   pseudo_rad_platid       namelist,wrfvar14  1  1        - "pseudo_rad_platid"       ""  ""
+rconfig   integer   pseudo_rad_satid        namelist,wrfvar14  1 16        - "pseudo_rad_satid"        ""  ""
+rconfig   integer   pseudo_rad_senid        namelist,wrfvar14  1  3        - "pseudo_rad_senid"        ""  ""
+rconfig   integer   pseudo_rad_ichan        namelist,wrfvar14  1  6        - "pseudo_rad_ichan"        ""  ""
+rconfig   real      pseudo_rad_lat          namelist,wrfvar14  1  35.0     - "pseudo_rad_lat"          ""  ""
+rconfig   real      pseudo_rad_lon          namelist,wrfvar14  1 130.0     - "pseudo_rad_lon"          ""  ""
+rconfig   real      pseudo_rad_inv          namelist,wrfvar14  1 1.0       - "pseudo_rad_inv"          ""  ""
+rconfig   real      pseudo_rad_err          namelist,wrfvar14  1 1.0       - "pseudo_rad_err"          ""  ""
+rconfig   logical   use_simulated_rad       namelist,wrfvar14  1  .false.  - "use_simulated_rad"       ""  ""
+rconfig   logical   simulated_rad_io        namelist,wrfvar14  1  .false.  - "simulated_rad_io"        ""  ""
+rconfig   integer   simulated_rad_ngrid     namelist,wrfvar14  1  0        - "simulated_rad_ngrid"     ""  ""
+rconfig   logical   use_varbc               namelist,wrfvar14  1  .false.  - "use_varbc"               ""  ""
+rconfig   logical   freeze_varbc            namelist,wrfvar14  1  .false.  - "freeze_varbc"            ""  ""
+rconfig   real      varbc_factor            namelist,wrfvar14  1  1.0      - "varbc_factor"            ""  ""
+rconfig   integer   varbc_nbgerr            namelist,wrfvar14  1  1        - "varbc_nbgerr"            ""  ""
+rconfig   integer   varbc_nobsmin           namelist,wrfvar14  1  10       - "varbc_nobsmin"           ""  ""
+rconfig   logical   use_airs_mmr            namelist,wrfvar14  1  .false.  - "use_airs_mmr"            ""  ""
+rconfig   logical   airs_warmest_fov        namelist,wrfvar14  1  .false.  - "airs_warmest_fov"        ""  ""
+rconfig   logical   use_satcv               namelist,wrfvar14  2  .false.  - "use_satcv"               ""  ""
+
+rconfig   integer   num_pseudo              namelist,wrfvar15  1  0        - "num_pseudo"              ""  ""   
+rconfig   real      pseudo_x                namelist,wrfvar15  1  1.0      - "pseudo_x"                ""  ""   
+rconfig   real      pseudo_y                namelist,wrfvar15  1  1.0      - "pseudo_y"                ""  ""   
+rconfig   real      pseudo_z                namelist,wrfvar15  1  1.0      - "pseudo_z"                ""  ""   
+rconfig   real      pseudo_val              namelist,wrfvar15  1  1.0      - "pseudo_val"              ""  ""   
+rconfig   real      pseudo_err              namelist,wrfvar15  1  1.0      - "pseudo_err"              ""  ""   
+
+rconfig   integer   alphacv_method          namelist,wrfvar16  1  2        - "alphacv_method"          ""  ""   
+rconfig   integer   ensdim_alpha            namelist,wrfvar16  1  0        - "ensdim_alpha"            ""  ""   
+rconfig   integer   alpha_truncation        namelist,wrfvar16  1  0        - "alpha_truncation"        ""  ""   
+rconfig   integer   alpha_corr_type         namelist,wrfvar16  1  3        - "alpha_corr_type"         ""  ""   
+rconfig   real      alpha_corr_scale        namelist,wrfvar16  1  1500.0   - "alpha_corr_scale"        ""  "km" 
+rconfig   real      alpha_std_dev           namelist,wrfvar16  1  1.0      - "alpha_std_dev"           ""  ""
+rconfig   logical   alpha_vertloc           namelist,wrfvar16  1  .false.  - "alpha_vertloc"           ""  ""
+rconfig   logical   alpha_hydrometeors      namelist,wrfvar16  1  .false.  - "alpha_hydrometeors"      ""  ""
+
+rconfig   character analysis_type           namelist,wrfvar17  1  "3D-VAR" - "analysis_type"           ""  ""
+rconfig   integer   sensitivity_option      namelist,wrfvar17  1  -1       - "sensitivity_option"      ""  ""
+rconfig   logical   adj_sens                namelist,wrfvar17  1  .false.  - "adj_sens"                ""  ""
+
+rconfig   character analysis_date           namelist,wrfvar18  1  "2002-08-03_00:00:00.0000" -  "analysis_date"      ""  "" 
+
+rconfig   character pseudo_var              namelist,wrfvar19  1  "t"                        -  "pseudo_var"         ""  ""   
+
+rconfig   character documentation_url       namelist,wrfvar20  1  "http://www.mmm.ucar.edu/people/wrfhelp/wrfvar/code/trunk" -  "documentation_url"  ""  ""  
+
+rconfig   character time_window_min         namelist,wrfvar21  1  "2002-08-02_21:00:00.0000" -  "time_window_min"    ""  ""
+
+rconfig   character time_window_max         namelist,wrfvar22  1  "2002-08-03_03:00:00.0000" -  "time_window_max"    ""  ""
+
+rconfig   logical jcdfi_use                 namelist,perturbation  1  .true.   -   "jcdfi_use"   "JcDFI on/off"      ""
+rconfig   integer jcdfi_diag                namelist,perturbation  1  1        -   "jcdfi_diag"  "JcDFI diag. on/off"      ""
+rconfig   real    jcdfi_penalty             namelist,perturbation  1  10.      -   "jcdfi_penalty"    "Penalty parameter for JcDF"      ""
+rconfig   logical enable_identity           namelist,perturbation  1  .false.  -   "enable identity AD/TL model"        ""      ""
+rconfig   logical   trajectory_io           namelist,perturbation  1  .true.   -  "0:disk IO;1:memory IO"   ""  ""
+
+# 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"      ""  ""
+rconfig   logical all_ic_times            namelist,time_control		1              .false. irh    "all_ic_times"     "T/F WRITE ALL IC TIME PERIODS"  ""
+
+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<domain>"          -     "name of input   infile"   ""      ""
+rconfig   character  input_outname     namelist,time_control		1  "wrfinput_d<domain>"          -     "name of input   outfile"  ""      ""
+rconfig   character  bdy_inname        namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary infile"  ""      ""
+rconfig   character  bdy_outname       namelist,time_control		1  "wrfbdy_d<domain>"            -     "name of boundary outfile" ""      ""
+rconfig   character  rst_inname        namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "name of restrt infile"    ""      ""
+rconfig   character  rst_outname       namelist,time_control		1  "wrfrst_d<domain>_<date>"     -     "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 write_hist_at_0h_rst    namelist,time_control		1             .false. h    "write_hist_at_0h_rst" "T/F write hist at 0 h of restarted forecast"
+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"
+rconfig   logical cycling                 namelist,time_control         1             .false. -    "true for cycling (using wrfout file as input data)"
+
+# DFI namelist
+rconfig   integer dfi_opt                namelist,dfi_control   1       0     rh   "dfi_opt"                ""      ""
+rconfig   integer dfi_radar              namelist,dfi_control   1       0     rh   "dfi_radar"                "DFI radar switch"      ""
+rconfig   integer dfi_nfilter            namelist,dfi_control   1       7     rh   "dfi_nfilter"              : "Digital filter type"      ""
+rconfig   logical dfi_write_filtered_input  namelist,dfi_control  1  .true.   rh   "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?"      ""
+rconfig   logical dfi_write_dfi_history  namelist,dfi_control   1   .false.   rh   "dfi_write_dfi_history"    "Write history files during filtering?"      ""
+rconfig   integer dfi_cutoff_seconds     namelist,dfi_control   1    3600     rh   "dfi_cutoff_seconds"       "Digital filter cutoff time"      ""
+rconfig   integer dfi_time_dim           namelist,dfi_control   1    1000     rh   "dfi_time_dim"             "MAX DIMENSION FOR HCOEFF"
+rconfig   integer dfi_fwdstop_year       namelist,dfi_control   1    2004     rh   "dfi_fwdstop_year"         "4 DIGIT YEAR OF START OF DFI" "YEARS"
+rconfig   integer dfi_fwdstop_month      namelist,dfi_control   1      03     rh   "dfi_fwdstop_month"        "2 DIGIT MONTH OF THE YEAR OF START OF DFI" "MONTHS"
+rconfig   integer dfi_fwdstop_day        namelist,dfi_control   1      13     rh   "dfi_fwdstop_day"          "2 DIGIT DAY OF THE MONTH OF START OF DFI" "DAYS"
+rconfig   integer dfi_fwdstop_hour       namelist,dfi_control   1      12     rh   "dfi_fwdstop_hour"         "2 DIGIT HOUR OF THE DAY OF START OF DFI" "HOURS"
+rconfig   integer dfi_fwdstop_minute     namelist,dfi_control   1      00     rh   "dfi_fwdstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF START OF DFI" "MINUTES"
+rconfig   integer dfi_fwdstop_second     namelist,dfi_control   1      00     rh   "dfi_fwdstop_second"       "2 DIGIT SECOND OF THE MINUTE OF START OF DFI" "SECONDS"
+rconfig   integer dfi_bckstop_year       namelist,dfi_control   1    2004     rh   "dfi_bckstop_year"         "4 DIGIT YEAR OF END OF DFI" "YEARS"
+rconfig   integer dfi_bckstop_month      namelist,dfi_control   1      03     rh   "dfi_bckstop_month"        "2 DIGIT MONTH OF THE YEAR OF END OF DFI" "MONTHS"
+rconfig   integer dfi_bckstop_day        namelist,dfi_control   1      14     rh   "dfi_bckstop_day"          "2 DIGIT DAY OF THE MONTH OF END OF DFI" "DAYS"
+rconfig   integer dfi_bckstop_hour       namelist,dfi_control   1      12     rh   "dfi_bckstop_hour"         "2 DIGIT HOUR OF THE DAY OF END OF DFI" "HOURS"
+rconfig   integer dfi_bckstop_minute     namelist,dfi_control   1      00     rh   "dfi_bckstop_minute"       "2 DIGIT MINUTE OF THE HOUR OF END OF DFI" "MINUTES"
+rconfig   integer dfi_bckstop_second     namelist,dfi_control   1      00     rh   "dfi_bckstop_second"       "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS"
+
+# 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 time_step_dfi           namelist,domains      1             -       ih   "time_step_dfi"
+rconfig   integer min_time_step           namelist,domains      max_domains   -1      h    "min_time_step"
+rconfig   integer max_time_step           namelist,domains      max_domains   -1      h    "max_time_step"
+rconfig   real    target_cfl              namelist,domains      max_domains  1.2      h    "target_cfl"
+rconfig   real    target_hcfl             namelist,domains      max_domains  0.84     h    "target_hcfl"
+rconfig   integer max_step_increase_pct   namelist,domains      max_domains    5      h    "max_step_increase_pct"
+rconfig   integer starting_time_step      namelist,domains      max_domains   -1      h    "starting_time_step"
+rconfig   logical step_to_output_time     namelist,domains      1         .true.      h    "step_to_output_time"
+rconfig   integer adaptation_domain       namelist,domains      1              1      h    "adaptation_domain"
+rconfig   logical use_adaptive_time_step  namelist,domains      1         .false.     h    "use_adaptive_time_step"
+
+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 num_metgrid_soil_levels namelist,domains	1             4        irh    "num_metgrid_soil_levels"               "number of input levels or layers in 3D sm, st, sw arrays"      ""
+rconfig   real    p_top_requested         namelist,domains      1              5000    irh    "p_top_requested" "Pa"      ""
+rconfig   integer interp_type             namelist,domains	1              2       irh    "interp_type"  "1=interp in pressure, 2=interp in LOG pressure"  ""
+rconfig   integer vert_refine_fact        namelist,domains      1              1       irh    "vertical refinment factor for ndown"  ""
+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              2       irh    "t_extrap_type"  "1=isothermal, 2=6.5 K/km, 3=adiabatic"   ""
+rconfig   logical lowest_lev_from_sfc     namelist,domains	1             .false.  irh    "lowest_lev_from_sfc"                ""      ""
+rconfig   logical use_levels_below_ground namelist,domains	1             .true.   irh    "use_levels_below_ground"   "T/F: use input data levels below input sfc pres" ""
+rconfig   logical use_tavg_for_tsk        namelist,domains	1             .false.  irh    "use_tavg_for_tsk"   "T/F: use diurnal avg sfc temp for tsk" ""
+rconfig   logical use_surface             namelist,domains	1             .true.   irh    "use_surface"   "T/F: use input surface level in interpolation" ""
+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    "sfcp_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   logical smooth_cg_topo          namelist,domains	1              .false. irh    "smooth_cg_topo"   "T/F smooth CG topo on boundarries" "flag"
+rconfig   logical aggregate_lu            namelist,domains	1              .false. irh    "aggregate_lu"   "T/F aggregate the grass, shrubs, trees in LU"
+rconfig   logical rh2qv_wrt_liquid        namelist,domains	1              .true.  irh    "rh2qv_wrt_liquid" "T = rh=>Qv assumes RH wrt liquid water, F = allows ice"
+rconfig   integer rh2qv_method            namelist,domains	1              1       irh    "rh2qv_method" "1=old MM5 method, 2=new WMO method"
+rconfig   real    qv_max_p_safe           namelist,domains      1              10000   irh    "qv_max_p_safe" "Threshhold pressure, Qv > flag set to value"      "Pa"
+rconfig   real    qv_max_flag             namelist,domains      1              1.E-5   irh    "qv_max_flag" "Qv flag for max"  "kg kg{-1}"
+rconfig   real    qv_max_value            namelist,domains      1              3.E-6   irh    "qv_max_value" "Qv value for max"  "kg kg{-1}"
+rconfig   real    qv_min_p_safe           namelist,domains      1              110000  irh    "qv_min_p_safe" "Threshhold pressure, Qv < flag set to value"      "Pa"
+rconfig   real    qv_min_flag             namelist,domains      1              1.E-6   irh    "qv_min_flag" "Qv flag for min"  "kg kg{-1}"
+rconfig   real    qv_min_value            namelist,domains      1              1.E-6   irh    "qv_min_value" "Qv value for min"  "kg kg{-1}"
+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   logical grid_allowed            namelist,domains	max_domains    .true.  irh    "allowed"            ""      ""
+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   ts_buf_size     namelist,domains    1                200          -       "ts_buf_size"   "Size of time series buffer"
+rconfig   integer   max_ts_locs     namelist,domains    1                5            -       "max_ts_locs"   "Maximum number of time series locations"
+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   track_level     namelist,domains    1                50000
+rconfig   real      time_to_move    namelist,domains    max_domains      0.  -  "" "" "minutes"
+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.
+
+# TC (tropical cyclone bogusing)
+rconfig   logical insert_bogus_storm   namelist,tc     	1              .false. irh    "insert_bogus_storm"   "T/F for inserting a bogus typhoon"      "flag"
+rconfig   logical remove_storm         namelist,tc     	1              .false. irh    "remove_storm"  "T/F for only removing the original typhoon"  "flag"
+rconfig   integer num_storm            namelist,tc     	1              1       irh    "num_storm"     "Number of bogus typhoons"  ""
+rconfig   real    latc_loc             namelist,tc     	max_bogus      -999.   irh    "latc_loc"      "center latitude of the bogus tyhoon"  "DEGREES"
+rconfig   real    lonc_loc             namelist,tc     	max_bogus      -999.   irh    "lonc_loc"      "center longitude of the bogus tyhoon"  "DEGREES"
+rconfig   real    vmax_meters_per_second   namelist,tc  max_bogus      -999.   irh    "vmax_meters_per_second"  "vmax of bogus storm in meters per second"  ""
+rconfig   real    rmax                 namelist,tc     	max_bogus      -999.   irh    "rmax"  "maximum radius outward from storm center"  ""
+rconfig   real    vmax_ratio           namelist,tc      max_bogus      -999.   irh    "vmax_ratio"  ""  ""
+rconfig   real    rankine_lid          namelist,tc      1              -999.   irh    "top pressure limit for the tc bogus scheme"
+
+# Physics
+rconfig   integer     mp_physics          namelist,physics	max_domains    0       rh       "mp_physics"            ""      ""
+rconfig   integer     gsfcgce_hail        namelist,physics      1              0       rh       "gsfcgce select hail/graupel"  ""      ""
+rconfig   integer     gsfcgce_2ice        namelist,physics      1              0       rh       "gsfcgce select 2ice/3ice"  ""      ""
+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   integer     sf_urban_physics    namelist,physics      max_domains    0       rh       "sf_urban_physics"     "activate urban model  0=no, 1=Noah_UCM 2=BEP_UCM"   ""
+rconfig   real    BLDT                    namelist,physics	max_domains    0       h    "BLDT"          ""      ""
+rconfig   integer     cu_physics          namelist,physics	max_domains    0       rh       "cu_physics"            ""      ""
+rconfig   integer shcu_physics            namelist,physics      max_domains    0       rh   "shcu_physics"  ""      ""
+rconfig   integer     kfeta_trigger       namelist,physics	1              1       rh       "KFETA Trigger function"    ""    ""
+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_urban_layers        namelist,physics      1            400       irh    "num_urban_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 cugd_avedx              namelist,physics      1            1      irh    "cugd_avedx"                    ""      ""
+rconfig   integer clos_choice             namelist,physics      1             0       rh    "clos_choice"                    ""      ""
+rconfig   integer imomentum               namelist,physics      1             0       rh    "imomentum"                    "momentum transport in G3 scheme"      ""
+rconfig   integer ishallow                namelist,physics      1             0       rh    "ishallow"  "shallow convection in G3 scheme"      ""
+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 sst_skin                namelist,physics      1            0         h    "sst_skin" "calculate sst skin temperature 0=no, 1=yes"   ""
+rconfig   integer tmn_update              namelist,physics      1            0         h    "tmn_update" "update tmn from calculation  0=no, 1=yes"   ""
+rconfig   logical usemonalb               namelist,physics      1            .false.   h    "usemonalb"   "use 2d field vs table values  false=table, True=2d"   ""
+rconfig   logical rdmaxalb                namelist,physics      1            .true.    h     "rdmaxalb"    "false set it to table values"   ""
+rconfig   logical rdlai2d                 namelist,physics      1            .false.   h     "rdlai2d"     "false set it to table values"   ""
+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   integer lagday                  namelist,physics      1             1       -      "lagday"         ""      ""
+rconfig   logical cu_rad_feedback         namelist,physics      max_domains   .false.  -     "feedback cumulus to radiation"  ""
+rconfig   integer pxlsm_smois_init        namelist,physics      max_domains   1       irh    "PXLSM_SMOIS_INIT"    "Soil moisture initialization option 0-From analysis 1-From MAVAIL"      ""
+rconfig   integer omlcall                 namelist,physics      1            0         h     "omlcall"     "activate simple ocean mixed layer model  0=no, 1=yes"   ""
+rconfig   real    oml_hml0                namelist,physics      1            50        h     "oml_hml0"    "oml initial mixed layer depth value"   "m"
+rconfig   real    oml_gamma               namelist,physics      1            0.14      h     "oml_gamma"   "oml deep water lapse rate"   "K m-1"
+rconfig   integer isftcflx                namelist,physics      1            0         h     "isftcflx"    "switch to control sfc fluxes"   ""
+rconfig   integer iz0tlnd                 namelist,physics      1            0         h     "iz0tlnd"    "switch to control land thermal roughness length"   ""
+rconfig   real    shadlen                 namelist,physics      1            25000.    -     "shadow_length" "maximum length of orographic shadow" "m"
+rconfig   integer slope_rad               namelist,physics      max_domains    0       -     "slope_rad"  "1: use slope-dependent radiation, 0:not" ""
+rconfig   integer topo_shading            namelist,physics      max_domains    0       -     "topo_shading" "1: apply topographic shading to radiation, 0:not" ""
+rconfig   integer no_mp_heating           namelist,physics      1              0       -     "no_mp_heating" "switch to turn of latent heating in mp schemes"   ""
+rconfig   integer fractional_seaice       namelist,physics      1              0       -     "fractional_seaice" "Fractional sea-ice option"
+rconfig   logical tice2tsk_if2cold        namelist,physics      1              .false. -     "tice2tsk_if2cold" "Avoid low ice temps when ice frac and Tsk are inconsistent"
+rconfig   real    bucket_mm               namelist,physics      1             -1.      h     "bucket_mm" "bucket reset value for water accumulations -1: inactive"   ""
+rconfig   real    bucket_J                namelist,physics      1             -1.      h     "bucket_J"  "bucket reset value for energy accumulations -1: inactive"   ""
+rconfig   real    mp_tend_lim             namelist,physics      1             10.      -     "mp_tend_lim" "limit on temp tendency from mp latent heating"   "K/s"
+rconfig   real    prec_acc_dt             namelist,physics      max_domains    0.      h     "prec_acc_dt" "bucket reset time interval between outputs for cumulus or grid scale precipitation"   "minutes"
+rconfig   integer prec_acc_opt            derived               1              0       -     "prec_acc_opt" "option to output precip in a time window"          ""
+rconfig   integer bucketr_opt             derived               1              0       -     "bucketr_opt"  "option to output water accum based on bucket_mm"          ""
+
+rconfig   integer grav_settling           namelist,physics      max_domains  0         h    "grav_settling"     "activate gravitationalsettling of fog  0=no, 1=yes"
+
+#FDDA namelist parameters
+rconfig   real    FGDT                    namelist,fdda         max_domains    0       h        "FGDT"          ""      ""
+rconfig   integer  FGDTZERO               namelist,fdda         max_domains    0       rh       "FGDTZERO"             ""      ""
+rconfig   integer  grid_fdda              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   integer  grid_sfdda             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_ph   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_ph             namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   integer   k_zfac_ph             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   integer  dk_zfac_uv             namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   integer  dk_zfac_t              namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   integer  dk_zfac_ph             namelist,fdda         max_domains    1       rh       "grid_fdda"            ""      ""
+rconfig   real        guv                 namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        guv_sfc             namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gt                  namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gt_sfc              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gq                  namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gq_sfc              namelist,fdda         max_domains    0       rh       "grid_fdda"            ""      ""
+rconfig   real        gph                 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"            ""      ""
+rconfig   real    rinblw                  namelist,fdda         1              0       h        "grid_fdda"            ""      ""
+rconfig   integer xwavenum                namelist,fdda         max_domains    0       rh       "grid_fdda"            "top wave number to nudge in x direction"      ""
+rconfig   integer ywavenum                namelist,fdda         max_domains    0       rh       "grid_fdda"            "top wave number to nudge in y direction"      ""
+rconfig   integer pxlsm_soil_nudge        namelist,fdda         max_domains    0       rh       "pxlsm_soil_nudge"     "nudge pxlsm soil"      ""
+
+#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   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   integer     obs_no_pbl_nudge_uv namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_uv" "1=no wind-nudging within pbl"          ""
+rconfig   integer     obs_no_pbl_nudge_t  namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_t"  "1=no temperature-nudging within pbl"   ""
+rconfig   integer     obs_no_pbl_nudge_q  namelist,fdda            max_domains    0       rh       "obs_no_pbl_nudge_q"  "1=no moisture-nudging within pbl"      ""
+rconfig   integer     obs_sfc_scheme_horiz namelist,fdda           1              0       rh       "obs_sfcscheme_horiz" "0=wrf scheme, 1=original mm5 scheme" ""
+rconfig   integer     obs_sfc_scheme_vert  namelist,fdda           1              0       rh       "obs_sfcscheme_vert"  "0=regime vif scheme, 1=original simple scheme" ""
+rconfig   real        obs_max_sndng_gap   namelist,fdda            1              20      rh       "obs_max_sndng_gap"   "Max press gap between soundings" "centibars"
+rconfig   real        obs_nudgezfullr1_uv namelist,fdda            1              50      rh       "obs_nudgezfullr1_uv" "Vert infl full weight  height for LML obs, regime 1, winds"        ""
+rconfig   real        obs_nudgezrampr1_uv namelist,fdda            1              50      rh       "obs_nudgezrampr1_uv" "Vert infl ramp-to-zero height for LML obs, regime 1, winds"        ""
+rconfig   real        obs_nudgezfullr2_uv namelist,fdda            1              50      rh       "obs_nudgezfullr2_uv" "Vert infl full weight  height for LML obs, regime 2, winds"        ""
+rconfig   real        obs_nudgezrampr2_uv namelist,fdda            1              50      rh       "obs_nudgezrampr2_uv" "Vert infl ramp-to-zero height for LML obs, regime 2, winds"        ""
+rconfig   real        obs_nudgezfullr4_uv namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_uv" "Vert infl full weight  height for LML obs, regime 4, winds"        ""
+rconfig   real        obs_nudgezrampr4_uv namelist,fdda            1              50      rh       "obs_nudgezrampr4_uv" "Vert infl ramp-to-zero height for LML obs, regime 4, winds"        ""
+rconfig   real        obs_nudgezfullr1_t  namelist,fdda            1              50      rh       "obs_nudgezfullr1_t" "Vert infl full weight  height for LML obs, regime 1, temperature"  ""
+rconfig   real        obs_nudgezrampr1_t  namelist,fdda            1              50      rh       "obs_nudgezrampr1_t" "Vert infl ramp-to-zero height for LML obs, regime 1, temperature"  ""
+rconfig   real        obs_nudgezfullr2_t  namelist,fdda            1              50      rh       "obs_nudgezfullr2_t" "Vert infl full weight  height for LML obs, regime 2, temperature"  ""
+rconfig   real        obs_nudgezrampr2_t  namelist,fdda            1              50      rh       "obs_nudgezrampr2_t" "Vert infl ramp-to-zero height for LML obs, regime 2, temperature"  ""
+rconfig   real        obs_nudgezfullr4_t  namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_t" "Vert infl full weight  height for LML obs, regime 4, temperature"  ""
+rconfig   real        obs_nudgezrampr4_t  namelist,fdda            1              50      rh       "obs_nudgezrampr4_t" "Vert infl ramp-to-zero height for LML obs, regime 4, temperature"  ""
+rconfig   real        obs_nudgezfullr1_q  namelist,fdda            1              50      rh       "obs_nudgezfullr1_q" "Vert infl full weight  height for LML obs, regime 1, moisture"     ""
+rconfig   real        obs_nudgezrampr1_q  namelist,fdda            1              50      rh       "obs_nudgezrampr1_q" "Vert infl ramp-to-zero height for LML obs, regime 1, moisture"     ""
+rconfig   real        obs_nudgezfullr2_q  namelist,fdda            1              50      rh       "obs_nudgezfullr2_q" "Vert infl full weight  height for LML obs, regime 2, moisture"     ""
+rconfig   real        obs_nudgezrampr2_q  namelist,fdda            1              50      rh       "obs_nudgezrampr2_q" "Vert infl ramp-to-zero height for LML obs, regime 2, moisture"     ""
+rconfig   real        obs_nudgezfullr4_q  namelist,fdda            1              -5000   rh       "obs_nudgezfullr4_q" "Vert infl full weight  height for LML obs, regime 4, moisture"     ""
+rconfig   real        obs_nudgezrampr4_q  namelist,fdda            1              50      rh       "obs_nudgezrampr4_q" "Vert infl ramp-to-zero height for LML obs, regime 4, moisture"     ""
+rconfig   real        obs_nudgezfullmin   namelist,fdda            1                 50   rh       "obs_nudgezfullmin" "Minimum depth through which vertical influence fcn remains 1.0"     "m"
+rconfig   real        obs_nudgezrampmin   namelist,fdda            1                 50   rh       "obs_nudgezrampmin" "Minimum depth through which vertical influence fcn decreases from 1.0 to 0.0" "m"
+rconfig   real        obs_nudgezmax       namelist,fdda            1               3000   rh       "obs_nudgezmax" "Maximum depth in which vertical influence function is nonzero" "m"
+rconfig   real        obs_sfcfact         namelist,fdda            1              1.0     h        "obs_sfcfact"       "Scale factor applied to time window for surface obs"     ""
+rconfig   real        obs_sfcfacr         namelist,fdda            1              1.0     h        "obs_sfcfacr"       "Scale factor applied to horiz radius of influence for surface obs"     ""
+rconfig   real        obs_dpsmx           namelist,fdda            1              7.5     h        "obs_dpsmx"         "Max pressure change allowed within horiz radius of influence"     "centibars"
+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            max_domains    0       rh       "obs_twindo"        "Half-period time window for nudging"  "hrs"
+rconfig   integer     obs_npfi            namelist,fdda            1              0       h        "obs_npfi"          "Freq in cg timesteps for diag print"  ""
+rconfig   integer     obs_ionf            namelist,fdda            max_domains    1       rh       "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   integer     obs_prt_max         namelist,fdda            1              1000    rh       "obs_prt_max"       "Maximum allowed obs entries in diagnostic printout"      ""
+rconfig   integer     obs_prt_freq        namelist,fdda            max_domains    1000    rh       "obs_prt_freq"      "Frequency in obs index for diagnostic printout."   ""
+rconfig   logical     obs_ipf_in4dob      namelist,fdda            1              .false. h        "obs_ipf_in4dob"    "Print obs input diagnostics"   ""
+rconfig   logical     obs_ipf_errob       namelist,fdda            1              .false. h        "obs_ipf_errob"     "Print obs error diagnostics"   ""
+rconfig   logical     obs_ipf_nudob       namelist,fdda            1              .false. h        "obs_ipf_nudob"     "Print obs nudge diagnostics"   ""
+rconfig   logical     obs_ipf_init        namelist,fdda            1              .true.  h        "obs_ipf_init"      "Enable obs init warning messages"   ""
+
+# Single-column model (SCM)
+rconfig   integer scm_force               namelist,scm  1       0           rh   "scm_force"            "SCM forcing switch" ""
+rconfig   real    scm_force_dx            namelist,scm  1       4000.       rh   "scm_force_dx"         "DX for SCM forcing" "m"
+rconfig   integer num_force_layers        namelist,scm  1       8           rh   "num_force_layers"     "Number of SCM forcing layers" ""
+rconfig   integer scm_lu_index            namelist,scm  1       2           rh   "scm_lu_index"         "SCM landuse index" ""
+rconfig   integer scm_isltyp              namelist,scm  1       4           rh   "scm_isltyp"           "SCM soil category" ""
+rconfig   real    scm_vegfra              namelist,scm  1       0.5         rh   "scm_vegfra"           "SCM vegetation fraction" ""
+rconfig   integer scm_canwat              namelist,scm  1       0.0         rh   "scm_canwat"           "SCM canopy water" "kg m-2"
+rconfig   real    scm_lat                 namelist,scm  1        36.605     rh   "scm_lat"              "SCM latitude" "degrees"
+rconfig   real    scm_lon                 namelist,scm  1       -97.485     rh   "scm_lon"              "SCM longitude" "degrees"
+rconfig   logical scm_th_adv              namelist,scm  1       .true.      rh   "scm_th_adv"           "Turn on theta advection in SCM"      ""
+rconfig   logical scm_wind_adv            namelist,scm  1       .true.      rh   "scm_wind_adv"         "Turn on wind advection in SCM"      ""
+rconfig   logical scm_qv_adv              namelist,scm  1       .true.      rh   "scm_qv_adv"           "Turn on qv advection in SCM"      ""
+rconfig   logical scm_ql_adv              namelist,scm  1       .false.     rh   "scm_ql_adv"           "Turn on ql advection in SCM"      ""
+rconfig   logical scm_vert_adv            namelist,scm  1       .true.      rh   "scm_vert_adv"         "Turn on vertical advection in SCM"      ""
+rconfig   integer num_force_soil_layers   namelist,scm  1       5           rh   "num_force_soil_layers" "Number of SCM soil forcing layers" ""
+rconfig   logical scm_soilT_force         namelist,scm  1       .false.     rh   "scm_soilT_force"      "Turn on soil temp forcing in SCM"      ""
+rconfig   logical scm_soilq_force         namelist,scm  1       .false.     rh   "scm_soilq_force"      "Turn on soil moisture forcing in SCM"      ""
+rconfig   logical scm_force_th_largescale namelist,scm  1       .false.     rh   "scm_force_th_largescale" "Turn on large scale theta forcing in SCM"      ""
+rconfig   logical scm_force_qv_largescale namelist,scm  1       .false.     rh   "scm_force_qv_largescale" "Turn on large scale qv forcing in SCM"      ""
+rconfig   logical scm_force_ql_largescale namelist,scm  1       .false.     rh   "scm_force_ql_largescale" "Turn on large scale ql forcing in SCM"      ""
+rconfig   logical scm_force_wind_largescale namelist,scm  1     .false.     rh   "scm_force_wind_largescale" "Turn on large scale wind forcing in SCM"      ""
+
+# Dynamics
+# dynamics option (see package definitions, below)
+rconfig   integer dyn_opt                 namelist,dynamics     1             2
+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"                ""      ""
+# km_opt_dfi is needed for backward integration in dfi
+rconfig   integer km_opt_dfi              namelist,dynamics	1             1       irh    "km_opt_dfi"                ""      ""
+rconfig   integer damp_opt                namelist,dynamics	1             0       irh    "damp_opt"              ""      ""
+rconfig   integer rad_nudge               namelist,dynamics	1             0       irh    "rad_nudge"             ""      ""
+rconfig   integer gwd_opt                 namelist,dynamics    1             0       irh    "gwd_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    c_s                     namelist,dynamics	max_domains    0.25    h    "c_s"         "Smagorinsky coeff"      ""
+rconfig   real    c_k                     namelist,dynamics	max_domains    0.15    h    "c_k"         "TKE coeff"      ""
+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   integer  moist_adv_opt          namelist,dynamics	max_domains    1       rh    "moist_adv_opt"         "positive-definite RK3 transport switch"      ""
+rconfig   integer  moist_adv_dfi_opt      namelist,dynamics	max_domains    0       rh    "moist_adv_dfi_opt"    "positive-definite RK3 transport switch"      ""
+rconfig   integer  chem_adv_opt           namelist,dynamics	max_domains    1       rh    "chem_adv_opt"          "positive-definite RK3 transport switch"      ""
+rconfig   integer  tracer_adv_opt         namelist,dynamics	max_domains    1       rh    "tracer_adv_opt"        "positive-definite RK3 transport switch"      ""
+rconfig   integer  scalar_adv_opt         namelist,dynamics	max_domains    1       rh    "scalar_adv_opt"        "positive-definite RK3 transport switch"      ""
+rconfig   integer  tke_adv_opt            namelist,dynamics	max_domains    1       rh    "tke_adv_opt"           "positive-definite RK3 transport switch"      ""
+rconfig   logical top_radiation           namelist,dynamics	max_domains    .false. rh    "top_radiation"         ""      ""
+rconfig   integer mix_isotropic           namelist,dynamics	max_domains    0       h    "mix_isotropic"            "0=anistropic, 1=isotropic"      ""
+rconfig   real    mix_upper_bound         namelist,dynamics	max_domains    0.1     h    "mix_upper_bound"          "non-dimensional limit"      ""
+rconfig   logical top_lid                 namelist,dynamics     max_domains    .false. rh    "top_lid"               ""      ""
+rconfig   real    tke_upper_bound         namelist,dynamics	max_domains    1000.   h    "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 coriolis2d              namelist,dynamics	max_domains  .false.  irh  "coriolis2d"    ""   ""
+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"
+rconfig   real    iso_temp                namelist,dynamics     1               0.     h    "iso_temp"   "Isothermal temperature in stratosphere, real only"      "K"
+rconfig   logical use_baseparam_fr_nml    namelist,dynamics     1            .false.  irh   "use_baseparam_fr_nml"    ""   ""
+rconfig   real    fft_filter_lat          namelist,dynamics     1              91.     h    "fft_filter_lat"   ""   "grid latitude to start polar filter"
+rconfig   logical rotated_pole            namelist,dynamics     1            .false.  irh   "rotated_pole"    ""   ""
+rconfig   logical do_coriolis             namelist,dynamics	max_domains  .true.   irh  "do_coriolis"    ""   ""
+rconfig   logical do_curvature            namelist,dynamics	max_domains  .true.   irh  "do_curvature"   ""   ""
+rconfig   logical do_gradp                namelist,dynamics	max_domains  .true.   irh  "do_gradp"    ""   ""
+#rconfig   integer     tracer_opt          namelist,dynamics     max_domains    0       rh    "tracer_opt"          ""      ""
+
+
+# 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 constant_bc             namelist,bdy_control          1      .false. rh    "constant_bc"           ""      ""
+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 polar                   namelist,bdy_control	max_domains    .false. rh    "polar"                 ""      ""
+rconfig   logical nested                  namelist,bdy_control	max_domains    .false. rh    "nested"                ""      ""
+rconfig   real    spec_exp                namelist,bdy_control          1     0.      irh    "spec_exp"              ""      ""
+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"  ""
+
+rconfig   logical trajectory_io           namelist,perturbation         1     .true.  -    "false: disk IO; true: memory IO"  ""      ""
+
+# NAMELIST DERIVED
+rconfig   integer nobs_ndg_vars           derived                       1         6       -        "num_ndg_vars"         "Number of nudging variables"          ""
+rconfig   integer nobs_err_flds           derived                       1         9       -        "num_err_flds"         "Number of error fields"               ""
+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    pole_lat                derived                  max_domains    0       -        "pole_lat"              "projection info: latitude of pole" "degrees, positive north"
+rconfig   real    pole_lon                derived                  max_domains    0       -        "pole_lon"              "projection info: longitude of pole" "degrees, positive east"
+rconfig   integer  FLAG_METGRID           derived                      1          0       -        "FLAG_METGRID"         "Flag in global attributes for metgrid data"
+rconfig   integer  FLAG_SNOW              derived                      1          0       -        "FLAG_SNOW"             "Flag for snow in the global attributes for metgrid data"
+rconfig   integer  FLAG_PSFC              derived                      1          0       -        "FLAG_PSFC"             "Flag for surface pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM000010          derived                      1          0       -        "FLAG_SM000010"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM010040          derived                      1          0       -        "FLAG_SM010040"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM040100          derived                      1          0       -        "FLAG_SM040100"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_SM100200          derived                      1          0       -        "FLAG_SM100200"         "Flag for soil moisture in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST000010          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST010040          derived                      1          0       -        "FLAG_ST000010"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST040100          derived                      1          0       -        "FLAG_ST010040"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_ST100200          derived                      1          0       -        "FLAG_ST100200"         "Flag for soil temperature  in the global attributes for metgrid data"
+rconfig   integer  FLAG_SLP               derived                      1          0       -        "FLAG_SLP"              "Flag for sea level pressure in the global attributes for metgrid data"
+rconfig   integer  FLAG_SOILHGT           derived                      1          0       -        "FLAG_SOILHGT"          "Flag for soil height in the global attributes for metgrid data"
+rconfig   integer  FLAG_MF_XY             derived                      1          0       -        "FLAG_MF_XY"            "Flag for MF_XYin the global attributes for metgrid data"
+rconfig   real    bdyfrq                  derived                  max_domains    0       -        "bdyfrq"               "lateral boundary input frequency"      "seconds"
+rconfig   character mminlu                derived                  max_domains    " "     -        "mminlu"               "land use dataset"             ""
+rconfig   integer iswater                 derived                  max_domains    0       -        "iswater"              "land use index of water"      "index category"
+rconfig   integer islake                  derived                  max_domains    0       -        "islake"               "land use index of inland lake"      "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 (Cylindrical), 1=Lambert, 2=polar, 3=Mercator"
+rconfig   integer use_wps_input           derived                       1         0       -        "use_wps_input"        "0/1 flag, using wps input"      "0=no, 1=yes"
+rconfig   integer dfi_stage               derived                  max_domains    3       -        "dfi_stage"            "current stage of DFI processing"      "0=DFI setup, 1=DFI backward integration, 2=DFI forward integration, 3=WRF forecast"
+rconfig   integer mp_physics_dfi          derived                  max_domains   -1       -        "mp_physics_dfi"       ""      "-1 = no DFI and so no need to allocate DFI moist and scalar variables, >0 = running with DFI, so allocate DFI moist and scalar variables appropriate for selected microphysics package"
+rconfig   integer mp_physics_4dvar        derived                  max_domains   -1       -        "mp_physics_4dvar"     ""      "-1 = no 4dvar and so no need to allocate a_ and g_ moist and scalar variables, >0 = running 4dvar, so allocate a_ and g_ moist and scalar variables appropriate for selected microphysics package"
+
+#
+# Single dummy declaration to define a nodyn dyn option
+state integer nodyn_dummy - dyn_nodyn -  -  -  "" "" ""      
+
+# Turbine drag (td) physics
+# Turbine positions and characteristics for real-data cases are specified in a file 
+# whose name is given in the windturbines_spec variable.  If the setting is "ideal",
+# the td_ variables specify idealized wind farm geometries and turbine characteristics.
+# If the setting is "none" then wind turbine drag physics is turned off.
+rconfig character windturbines_spec namelist,physics 1 "none" - - "" "none, ideal, or a file name"
+rconfig integer td_turbgridid  namelist,physics 1 -1     - - ""  "which grid id has turbines in it"
+rconfig  real   td_hubheight   namelist,physics 1 100.   - - ""  "hub height (m)"
+rconfig  real   td_diameter    namelist,physics 1 60.    - - ""  "turbine diameter (m)"
+rconfig  real   td_stdthrcoef  namelist,physics 1 .158   - - ""  "standing thrust coefficient"
+rconfig  real   td_cutinspeed  namelist,physics 1 4.     - - ""  "cut-in speed (m/s)"
+rconfig  real   td_cutoutspeed namelist,physics 1 27.    - - ""  "cut-out speed (m/s)"
+rconfig  real   td_power       namelist,physics 1 2.     - - ""  "turbine power (MW)"
+rconfig  real   td_turbpercell namelist,physics 1 1.     - - ""  "number of turbines per cell"
+rconfig integer td_ewfx        namelist,physics 1 0      - - ""  "extent of wind farm in x-cells"
+rconfig integer td_ewfy        namelist,physics 1 0      - - ""  "extent of wind farm in y-cells"
+rconfig integer td_pwfx        namelist,physics 1 1      - - ""  "southwest corner of wind farm in x-cells"
+rconfig integer td_pwfy        namelist,physics 1 1      - - ""  "southwest corner of wind farm in y-cells"
+
+
+#
+#---------------------------------------------------------------------------------------------------------------------------------------
+# 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   dyn_em_sn    dyn_opt==102                 -             -
+package   dyn_em_tl    dyn_opt==202                 -             -
+package   dyn_em_ad    dyn_opt==302                 -             -
+package   dyn_em_tst   dyn_opt==402                 -             -
+package   dyn_em_var   dyn_opt==502                 -             -
+
+package   passivec1     chem_opt==0                  -             
+package   passiveqv     mp_physics==0                -             moist:qv;g_moist:g_qv;a_moist:a_qv
+package   kesslerscheme mp_physics==1                -             moist:qv,qc,qr;g_moist:g_qv,g_qc,g_qr;a_moist:a_qv,a_qc,a_qr
+package   linscheme     mp_physics==2                -             moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg
+package   sbu_ylinscheme    mp_physics==13           -             moist:qv,qc,qr,qi,qs;state:rimi
+package   wsm3scheme    mp_physics==3                -             moist:qv,qc,qr;g_moist:g_qv,g_qc,g_qr;a_moist:a_qv,a_qc,a_qr
+package   wsm5scheme    mp_physics==4                -             moist:qv,qc,qr,qi,qs;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs
+package   etampnew      mp_physics==5                -             moist:qv,qc,qr,qs;g_moist:g_qv,g_qc,g_qr,g_qs;a_moist:a_qv,a_qc,a_qr,a_qs;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy
+package   wsm6scheme    mp_physics==6                -             moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg
+package   gsfcgcescheme mp_physics==7                -             moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg
+package   thompson      mp_physics==8                -             moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg;scalar:qni,qnr
+package   milbrandt2mom mp_physics==9                -             state:refl_10cm;moist:qv,qc,qr,qi,qs,qg,qh;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh;scalar:qnc,qnr,qni,qns,qng,qnh
+package   morr_two_moment  mp_physics==10            -             moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg;scalar:qni,qns,qnr,qng
+#package   milbrandt3mom mp_physics==12               -             moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qzr,qzi,qzs,qzg,qzh
+package   wdm5scheme    mp_physics==14               -             moist:qv,qc,qr,qi,qs;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs;scalar:qnn,qnc,qnr
+package   wdm6scheme    mp_physics==16               -             moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg;scalar:qnn,qnc,qnr
+
+package   nodfimoist        mp_physics_dfi==-1       -             -
+package   passiveqv_dfi     mp_physics_dfi==0        -             dfi_moist:dfi_qv
+package   kesslerscheme_dfi mp_physics_dfi==1        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   linscheme_dfi     mp_physics_dfi==2        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   sbu_ylinscheme_dfi    mp_physics==13           -         dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;state:rimi
+package   wsm3scheme_dfi    mp_physics_dfi==3        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr
+package   wsm5scheme_dfi    mp_physics_dfi==4        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs
+package   etampnew_dfi      mp_physics_dfi==5        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt
+package   wsm6scheme_dfi    mp_physics_dfi==6        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   gsfcgcescheme_dfi mp_physics_dfi==7        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg
+package   thompson_dfi      mp_physics_dfi==8        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr
+package   milbrandt2mom_dfi mp_physics_dfi==9        -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh
+package   morr_two_moment_dfi  mp_physics_dfi==10    -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng
+package   wdm5scheme_dfi    mp_physics_dfi==14       -                 dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+package   wdm6scheme_dfi    mp_physics_dfi==16       -                 dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr
+
+package   no4dvarmoist        mp_physics_4dvar==-1       -             -
+package   passiveqv_4dvar     mp_physics_4dvar==0        -             g_moist:g_qv;a_moist:a_qv
+package   kesslerscheme_4dvar mp_physics_4dvar==1        -             g_moist:g_qv,g_qc,g_qr;a_moist:a_qv,a_qc,a_qr
+package   linscheme_4dvar     mp_physics_4dvar==2        -             g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg
+package   sbu_ylinscheme_4dvar    mp_physics==13           -           g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;state:rimi
+package   wsm3scheme_4dvar    mp_physics_4dvar==3        -             g_moist:g_qv,g_qc,g_qr;a_moist:a_qv,a_qc,a_qr
+package   wsm5scheme_4dvar    mp_physics_4dvar==4        -             g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs
+package   etampnew_4dvar      mp_physics_4dvar==5        -             g_moist:g_qv,g_qc,g_qr,g_qs;a_moist:a_qv,a_qc,a_qr,a_qs
+package   wsm6scheme_4dvar    mp_physics_4dvar==6        -             g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg
+package   gsfcgcescheme_4dvar mp_physics_4dvar==7        -             g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg
+package   thompson_4dvar      mp_physics_4dvar==8        -             g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg
+package   milbrandt2mom_4dvar mp_physics_4dvar==9        -             g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh
+package   morr_two_moment_4dvar  mp_physics_4dvar==10    -             g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg
+package   wdm5scheme_4dvar    mp_physics_4dvar==14       -             g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs
+package   wdm6scheme_4dvar    mp_physics_4dvar==16       -             g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg
+
+
+package   noprogn       progn==0                     -             -
+package   progndrop     progn==1                     -             scalar:qndrop;dfi_scalar:dfi_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;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   rrtmg_lwscheme  ra_lw_physics==4           -             state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   goddardlwscheme  ra_lw_physics==5          -             state:tlwdn,tlwup,slwdn,slwup
+package   gfdllwscheme  ra_lw_physics==99            -             -
+package   heldsuarez    ra_lw_physics==31            -             -
+
+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;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc
+package   rrtmg_swscheme  ra_sw_physics==4           -             state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc
+package   goddardswscheme  ra_sw_physics==5          -             state:tswdn,tswup,sswdn,sswup
+package   gfdlswscheme  ra_sw_physics==99            -             -
+
+package   sfclayscheme   sf_sfclay_physics==1        -             -
+package   myjsfcscheme   sf_sfclay_physics==2        -             state:tke_pbl
+package   gfssfcscheme   sf_sfclay_physics==3        -             -
+package   qnsesfcscheme  sf_sfclay_physics==4        -             -
+package   mynnsfcscheme  sf_sfclay_physics==5        -             scalar:qke;state:tsq,qsq,cov
+package   pxsfcscheme    sf_sfclay_physics==7        -             -
+
+package   noahucmscheme  sf_urban_physics==1         -             state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep
+package   bepscheme      sf_urban_physics==2         -             state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d
+package   bep_bemscheme  sf_urban_physics==3         -             state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,sfwin1_urb3d,sfwin2_urb3d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d
+
+package   slabscheme     sf_surface_physics==1       -             -
+package   lsmscheme      sf_surface_physics==2       -             -
+package   ruclsmscheme   sf_surface_physics==3       -             state:smfr3d,keepfr3dflag,soilt1
+package   pxlsmscheme    sf_surface_physics==7       -             state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old
+package   temfsfcscheme  sf_sfclay_physics==88       -             state:wm_temf
+package   idealscmsfcscheme  sf_sfclay_physics==89   -             -
+
+package   ysuscheme      bl_pbl_physics==1           -             -
+package   myjpblscheme   bl_pbl_physics==2           -             state:tke_pbl,el_pbl
+package   gfsscheme      bl_pbl_physics==3           -             -
+package   qnsepblscheme  bl_pbl_physics==4           -             state:tke_pbl,el_pbl
+package   mynnpblscheme2 bl_pbl_physics==5           -             scalar:qke;state:tsq,qsq,cov
+package   mynnpblscheme3 bl_pbl_physics==6           -             scalar:qke;state:tsq,qsq,cov
+package   acmpblscheme   bl_pbl_physics==7           -             -
+package   boulacscheme   bl_pbl_physics==8           -             state:el_pbl,tke_pbl,wu_tur,wv_tur,wt_tur,wq_tur
+package   camuwpblscheme bl_pbl_physics==9           -             state:tauresx2d,tauresy2d,qpert2d,wpert2d,tke_pbl
+package   mrfscheme      bl_pbl_physics==99          -             -
+package   temfpblscheme  bl_pbl_physics==88          -             state:te_temf,kh_temf,km_temf,shf_temf,qf_temf,uw_temf,vw_temf,wupd_temf,mf_temf,thup_temf,qlup_temf,qtup_temf,cf3d_temf,hd_temf,lcl_temf,hct_temf,cfm_temf
+
+package   kfetascheme    cu_physics==1               -             -
+package   bmjscheme      cu_physics==2               -             -
+package   gdscheme       cu_physics==3               -             -
+package   sasscheme      cu_physics==4               -             -
+package   g3scheme       cu_physics==5               -             state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow
+package   tiedtkescheme  cu_physics==6
+package   camzmscheme    cu_physics==7               -             state:precz,zmdt,zmdq,zmdice,zmdliq,evaptzm,fzsntzm,evsntzm,evapqzm,zmflxprc,zmflxsnw,zmntprpd,zmntsnpd,zmeiheat,cmfmc,cmfmcdzm,preccdzm,pconvb,pconvt,cape,zmmtu,zmmtv,zmmu,zmmd,zmupgu,zmupgd,zmvpgu,zmvpgd,zmicuu,zmicud,zmicvu,zmicvd
+package   nsasscheme     cu_physics==14              -             -
+package   kfscheme       cu_physics==99              -             -
+
+package   g3shcuscheme   shcu_physics==1             -             -
+package   camuwshcuscheme shcu_physics==2            -             state:cmfmc,cmfmc2,qtflx_cu,slflx_cu,uflx_cu,vflx_cu,qtten_cu,slten_cu,uten_cu,vten_cu,qvten_cu,qlten_cu,qiten_cu,cbmf_cu,ufrcinvbase_cu,ufrclcl_cu,winvbase_cu,wlcl_cu,plcl_cu,pinv_cu,plfc_cu,pbup_cu,ppen_cu,qtsrc_cu,thlsrc_cu,thvlsrc_cu,emkfbup_cu,cin_cu,cinlcl_cu,cbmflimit_cu,tkeavg_cu,zinv_cu,rcwp_cu,rlwp_cu,riwp_cu,tophgt_cu,wu_cu,ufrc_cu,qtu_cu,thlu_cu,thvu_cu,uu_cu,vu_cu,qtu_emf_cu,thlu_emf_cu,uu_emf_cu,vu_emf_cu,umf_cu,uemf_cu,qcu_cu,qlu_cu,qiu_cu,cufrc_cu,fer_cu,fdr_cu,dwten_cu,diten_cu,qrten_cu,qsten_cu,flxrain_cu,flxsnow_cu,ntraprd_cu,ntsnprd_cu,excessu_cu,excessu0_cu,xc_cu,aquad_cu,bquad_cu,cquad_cu,bogbot_cu,bogtop_cu,exit_uwcu_cu,exit_conden_cu,exit_klclmkx_cu,exit_klfcmkx_cu,exit_ufrc_cu,exit_wtw_cu,exit_drycore_cu,exit_wu_cu,exit_cufliter_cu,exit_kinv1_cu,exit_rei_cu,limit_shcu_cu,limit_negcon_cu,limit_ufrc_cu,limit_ppen_cu,limit_emf_cu,limit_cinlcl_cu,limit_cin_cu,limit_cbmf_cu,limit_rei_cu,ind_delcin_cu,evapcsh,cmfsl,cmflq,cldfrash,cush,icwmrsh,snowsh,rprdsh,rliq2
+
+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;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten
+package   psusfddagd     grid_sfdda==1               -             state:u10_ndg_old,v10_ndg_old,t2_ndg_old,th2_ndg_old,q2_ndg_old,rh_ndg_old,psl_ndg_old,ps_ndg_old,u10_ndg_new,v10_ndg_new,t2_ndg_new,th2_ndg_new,q2_ndg_new,rh_ndg_new,psl_ndg_new,ps_ndg_new,tob_ndg_old,odis_ndg_old,tob_ndg_new,odis_ndg_new
+package   spnudging      grid_fdda==2               -              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;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten
+
+package   slopeopt       slope_rad==1               -              -
+package   gwdopt         gwd_opt==1                 -              state:var2d,oc12d,oa1,oa2,oa3,oa4,ol1,ol2,ol3,ol4,dtaux3d,dtauy3d,dusfcg,dvsfcg
+package   omlopt         omlcall==1                 -              state:tml,t0ml,hml,h0ml,huml,hvml,tmoml
+package   scmopt         scm_force==1               -              state:z_force,z_force_tend,u_g,u_g_tend,v_g,v_g_tend,w_subs,w_subs_tend,th_upstream_x,th_upstream_x_tend,th_upstream_y,th_upstream_y_tend,qv_upstream_x,qv_upstream_x_tend,qv_upstream_y,qv_upstream_y_tend,u_upstream_x,u_upstream_x_tend,u_upstream_y,u_upstream_y_tend,v_upstream_x,v_upstream_x_tend,v_upstream_y,v_upstream_y_tend,tau_x,tau_x_tend,tau_y,tau_y_tend,th_largescale,th_largescale_tend,qv_largescale,qv_largescale_tend,ql_largescale,ql_largescale_tend,u_largescale,u_largescale_tend,v_largescale,v_largescale_tend,tau_largescale,tau_largescale_tend,ql_upstream_x,ql_upstream_x_tend,ql_upstream_y,ql_upstream_y_tend,t_soil_forcing_val,t_soil_forcing_tend,q_soil_forcing_val,q_soil_forcing_tend,tau_soil,soil_depth_force
+
+package   prec_acc       prec_acc_opt==1            -              state:prec_acc_c,prec_acc_nc,snow_acc_nc
+package   bucketropt     bucketr_opt==1             -              state:i_rainc,i_rainnc
+
+package   restofwrf      use_wps_input==0            -             -
+
+package   original       moist_adv_opt==0            -             -
+package   positivedef    moist_adv_opt==1            -             -
+package   monotonic      moist_adv_opt==2            -             -
+#package   tracer_test1  tracer_opt==2       -             tracer:tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8
+
+package   dfi_setup      dfi_stage==0                -             -
+package   dfi_bck        dfi_stage==1                -             -
+package   dfi_fwd        dfi_stage==2                -             -
+package   dfi_fst        dfi_stage==3                -             -
+package   dfi_startfwd   dfi_stage==4                -             -
+package   dfi_startbck   dfi_stage==5                -             -
+
+#package   digifilter     dfi_opt==1                  -             dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_rh,dfi_tten_rad
+package   dfi_nodfi     dfi_opt==0                  -             -
+package   dfi_dfl       dfi_opt==1                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   dfi_ddfi      dfi_opt==2                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+package   dfi_tdfi      dfi_opt==3                  -             state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad
+ifdef RUC_CLOUD
+package   realonly       use_wps_input==1            -             state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qni_gc,icefrac_gc
+endif
+ifndef RUC_CLOUD
+package   realonly       use_wps_input==1            -             state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,icefrac_gc
+endif
+
+# 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,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,f,e,sina,cosa,ht,potevp,snopcx,soiltb,xlat,xlong,xlat_u,xlat_v,xlong_u,xlong_v,clat,clong
+halo      HALO_EM_INIT_5 dyn_em 48:moist,scalar #,chem
+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_PHYS_CU dyn_em         4:rucuten,rvcuten
+halo      HALO_EM_PHYS_SHCU dyn_em       4:rushten,rvshten
+halo      HALO_EM_FDDA dyn_em            4:rundgdten,rvndgdten
+halo      HALO_EM_FDDA_SFC dyn_em 48:z,z_at_w,pblh,regime,znt,odis_ndg_old,odis_ndg_new
+halo      HALO_EM_PHYS_DIFFUSION dyn_em  4:defor11,defor22,defor12,defor13,defor23,div,xkmv,xkmh,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,ustm
+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,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,muts
+halo      HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,scalar;4:mu_2,al #,chem
+halo      HALO_EM_D2_5 dyn_em 48:u_2,v_2,w_2,t_2,ph_2;24:moist,scalar;4:mu_2,al #,chem
+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,scalar;4:mu_1,mu_2 #,chem
+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,scalar;4:mu_1,mu_2 #,chem
+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_CUP_G3_IN dyn_em 24:RTHFTEN,RQVFTEN,w_2,t_phy
+halo      HALO_CUP_G3_OUT dyn_em 48:cugd_tten,cugd_qvten,cugd_ttens,cugd_qvtens,raincv
+#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_TOPOSHAD phys 24:ht_shad
+
+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_HYDRO_UV   dyn_em 8:u_2,v_2
+
+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,scalar #,chem
+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,scalar #,chem
+
+# 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:ph_2,p,uratx,vratx,tratx,kpbl
+
+# 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,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,sina,cosa,e,f
+
+# Monotonic, positive definite advection requires 4 values for moist, chem, tke, and scalar for periodic lateral boundaries
+
+period    PERIOD_BDY_EM_MOIST dyn_em 4:moist
+#period    PERIOD_BDY_EM_CHEM dyn_em 4:chem
+period    PERIOD_BDY_EM_SCALAR dyn_em 4:scalar
+period    PERIOD_BDY_EM_TKE dyn_em 4:tke_2
+period    PERIOD_BDY_EM_MOIST2 dyn_em 4:moist
+#period    PERIOD_BDY_EM_CHEM2 dyn_em 4:chem
+period    PERIOD_BDY_EM_SCALAR2 dyn_em 4:scalar
+period    PERIOD_BDY_EM_MOIST_OLD dyn_em 4:moist_old
+#period    PERIOD_BDY_EM_CHEM_OLD dyn_em 4:chem_old
+period    PERIOD_BDY_EM_SCALAR_OLD dyn_em 4:scalar_old
+period    PERIOD_BDY_EM_TKE_OLD dyn_em 4:tke_1
+
+period    PERIOD_BDY_EM_E dyn_em 2:u_2,v_2,ht
+period    PERIOD_EM_HYDRO_UV dyn_em 1:u_2,v_2
+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,ustm
+period    PERIOD_BDY_EM_PHY_BC dyn_em 2:rublten,rvblten,rucuten,rvcuten,xkmh,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,msfvx,msfvy,muu,msfux,msfuy,msfvx_inv
+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
+period    PERIOD_EM_DA dyn_em 2:ru_m,rv_m,ww_m,mut,muts
+
+#
+#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
+
+##
+#### WRFVAR Portion
+##                                                
+
+halo      HALO_INIT          dyn_em 24:xb%map_factor,xb%psac,xb%rough,xb%xland,xb%landmask,xb%tgrn,xb%u,xb%v,xb%w,xb%wh,xb%t,xb%p,xb%q,xb%qrn,xb%qcw,xb%qci,xb%qt,xb%rho,xb%rh,xb%h,xb%hf,xb%u10,xb%v10,xb%t2,xb%q2,xb%terr,xb%psfc,xb%regime,xb%ztd,xb%tpw,xb%speed,xb%tb19v,xb%tb19h,xb%tb22v,xb%tb37v,xb%tb37h,xb%tb85v,xb%tb85h,xb%ref,xb%delt,xb%slp,xb%coefx,xb%coefy,xb%coefz,xb%tsk,xb%smois,xb%tslb,xb%xice,xb%ivgtyp,xb%isltyp,xb%vegfra,xb%snowh,xb%snow
+halo      HALO_PSICHI_UV     dyn_em 24:vp%v1,vp%v2,xb%cori,xb%rho,xa%u,xa%v,xa%psfc
+halo      HALO_BAL_EQN_ADJ   dyn_em 24:xp%v1z
+halo      HALO_PSICHI_UV_ADJ dyn_em 24:xa%u,xa%v,xa%psfc
+halo      HALO_XA_A          dyn_em 4:xa%u,xa%v
+halo      HALO_X6A_A         dyn_em 4:x6a%u,x6a%v
+halo      HALO_EM_C_TL       dyn_em 4:g_u_2,g_v_2
+halo      HALO_XB        dyn_em 24:xb%psac,xb%rough,xb%u,xb%v,xb%w,xb%wh,xb%t,xb%p,xb%q,xb%qrn,xb%qcw,xb%qci,xb%qt,xb%rho,xb%rh,xb%h,xb%hf,xb%u10,xb%v10,xb%t2,xb%q2,xb%psfc,xb%regime,xb%ztd,xb%tpw,xb%speed,xb%tb19v,xb%tb19h,xb%tb22v,xb%tb37v,xb%tb37h,xb%tb85v,xb%tb85h,xb%ref,xb%delt,xb%slp
+halo      HALO_XA            dyn_em 24:xa%u,xa%v,xa%q,xa%p,xa%t,xa%rho,xa%rh,xa%psfc,xa%qcw,xa%qrn,xa%qci,xa%qt
+halo      HALO_XA_CLOUD      dyn_em 24:xa%q,xa%t,xa%qcw,xa%qrn,xa%qci
+halo      HALO_SFC_XA        dyn_em 24:xa%u10,xa%v10,xa%t2,xa%q2
+halo      HALO_SSMI_XA       dyn_em 24:xa%ztd,xa%tpw,xa%speed,xa%tb19v,xa%tb19h,xa%tb22v,xa%tb37v,xa%tb37h,xa%tb85v,xa%tb85h,xa%ref
+halo      HALO_2D_WORK       dyn_em 24:xp%vxy
+halo      HALO_RADAR_XA_W    dyn_em 24:xa%w,xa%wh
+halo      HALO_XB_UV         dyn_em 24:xb%u,xb%v
+
+##### Derived types for WRFVAR
+# BEGIN VP_TYPE DEFINITION:
+#      <Table>  <Type>  <Sym>                <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>
+typedef vp_type real    v1                      ijk      -         1        -       -
+typedef vp_type real    v2                      ijk      -         1        -       -
+typedef vp_type real    v3                      ijk      -         1        -       -
+typedef vp_type real    v4                      ijk      -         1        -       -
+typedef vp_type real    v5                      ijk      -         1        -       -
+typedef vp_type real    v6                      ijk      -         1        -       -
+typedef vp_type real    v7                      ijk      -         1        -       -
+typedef vp_type real    v8                      ijk      -         1        -       -
+typedef vp_type real    alpha                   ijk9     -         1        -       -
+# END VP_TYPE DEFINITION
+
+# BEGIN EP_TYPE DEFINITION:
+#      <Table>  <Type>  <Sym>                <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>
+typedef ep_type integer ne
+typedef ep_type real    v1                      ijk9     -         1        -       -
+typedef ep_type real    v2                      ijk9     -         1        -       -
+typedef ep_type real    v3                      ijk9     -         1        -       -
+typedef ep_type real    v4                      ijk9     -         1        -       -
+typedef ep_type real    v5                      ijk9     -         1        -       -
+# END EP_TYPE DEFINITION
+
+# BEGIN XB_TYPE DEFINITION:
+typedef xb_type integer      map
+typedef xb_type real         ptop
+typedef xb_type real         ztop
+typedef xb_type real         ds
+typedef xb_type real         sigmaf_0
+typedef xb_type integer      mix
+typedef xb_type integer      mjy 
+typedef xb_type integer      mkz
+typedef xb_type integer      num_of_var
+#
+typedef xb_type integer    ids
+typedef xb_type integer    ide
+typedef xb_type integer    jds
+typedef xb_type integer    jde
+typedef xb_type integer    kds
+typedef xb_type integer    kde
+typedef xb_type integer    ims
+typedef xb_type integer    ime
+typedef xb_type integer    jms
+typedef xb_type integer    jme
+typedef xb_type integer    kms
+typedef xb_type integer    kme
+typedef xb_type integer    its
+typedef xb_type integer    ite
+typedef xb_type integer    jts
+typedef xb_type integer    jte
+typedef xb_type integer    kts
+typedef xb_type integer    kte
+#
+# table entries are of the form                                         
+#      <Table>  <Type>  <Sym>                <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>
+#Grid variables	       			   
+typedef xb_type real    grid_box_area          ij       -         1        -       -  
+typedef xb_type real    map_factor             ij       -         1        -       -
+typedef xb_type real    u                      ijk      -         1        X       -
+typedef xb_type real    v                      ijk      -         1        Y       -
+typedef xb_type real    w                      ijk      -         1        -       -
+typedef xb_type real    t                      ijk      -         1        -       -
+typedef xb_type real    p                      ijk      -         1        -       -
+typedef xb_type real    q                      ijk      -         1        -       -
+typedef xb_type real    qrn                    ijk      -         1        -       -
+typedef xb_type real    qcw                    ijk      -         1        -       -
+typedef xb_type real    qci                    ijk      -         1        -       -
+typedef xb_type real    qsn                    ijk      -         1        -       -
+typedef xb_type real    qgr                    ijk      -         1        -       -
+typedef xb_type real    qt                     ijk      -         1        -       -
+typedef xb_type real    delt                   ijk      -         1        -       -
+
+typedef xb_type real    h                      ijk      -         1        -       -
+typedef xb_type real    hf                     ijk      -         1        -       -
+typedef xb_type real    wh                     ijk      -         1        -       -
+
+typedef xb_type real    rho                    ijk      -         1        -       -
+typedef xb_type real    rh                     ijk      -         1        -       -
+typedef xb_type real    es                     ijk      -         1        -       -
+typedef xb_type real    qs                     ijk      -         1        -       -
+typedef xb_type real    td                     ijk      -         1        -       -
+typedef xb_type real    vertical_inner_product ijk      -         1        -       -
+
+typedef xb_type real    ref                    ijk      -         1        -       -
+
+typedef xb_type real    rough                  ij       -         1        -       -
+typedef xb_type real    ztd                    ij       -         1        -       -
+typedef xb_type real    tpw                    ij       -         1        -       -
+typedef xb_type real    slp                    ij       -         1        -       -
+typedef xb_type real    speed                  ij       -         1        -       -
+typedef xb_type real    tb19v                  ij       -         1        -       -
+typedef xb_type real    tb19h                  ij       -         1        -       -
+typedef xb_type real    tb22v                  ij       -         1        -       -
+typedef xb_type real    tb37v                  ij       -         1        -       -
+typedef xb_type real    tb37h                  ij       -         1        -       -
+typedef xb_type real    tb85v                  ij       -         1        -       -
+typedef xb_type real    tb85h                  ij       -         1        -       -
+
+typedef xb_type real    cori                   ij       -         1        -       -
+typedef xb_type real    tgrn                   ij       -         1        -       -
+typedef xb_type real    lat                    ij       -         1        -       -
+typedef xb_type real    lon                    ij       -         1        -       -
+typedef xb_type real    terr                   ij       -         1        -       -
+typedef xb_type real    psac                   ij       -         1        -       -
+typedef xb_type real    lanu                   ij       -         1        -       -
+typedef xb_type real    snow                   ij       -         1        -       -
+typedef xb_type real    xland                  ij       -         1        -       -
+typedef xb_type real    landmask               ij       -         1        -       -
+
+typedef xb_type real    u10                    ij       -         1        -       -
+typedef xb_type real    v10                    ij       -         1        -       -
+typedef xb_type real    t2                     ij       -         1        -       -
+typedef xb_type real    q2                     ij       -         1        -       -
+typedef xb_type real    psfc                   ij       -         1        -       -
+typedef xb_type real    tsk                    ij       -         1        -       -
+typedef xb_type real    smois                  ij       -         1        -       -
+typedef xb_type real    tslb                   ij       -         1        -       -
+typedef xb_type real    xice                   ij       -         1        -       -
+typedef xb_type integer ivgtyp                 ij       -         1        -       -
+typedef xb_type integer isltyp                 ij       -         1        -       -
+typedef xb_type real    vegfra                 ij       -         1        -       -
+typedef xb_type real    snowh                  ij       -         1        -       -
+
+typedef xb_type real    regime                 ij       -         1        -       -
+
+typedef xb_type real    znu                    k        -         1        -       -
+typedef xb_type real    znw                    k        -         1        -       -
+typedef xb_type real    dn                     k        -         1        -       -
+typedef xb_type real    dnw                    k        -         1        -       -
+
+typedef xb_type real    sigmah                 k        -         1        -       -
+typedef xb_type real    sigmaf                 k        -         1        -       -
+
+typedef xb_type real    coefx                  ij       -         1        -       -
+typedef xb_type real    coefy                  ij       -         1        -       -
+typedef xb_type real    coefz                  ij       -         1        -       -
+
+typedef xb_type real    kma_a                  k        -         1        -       -
+typedef xb_type real    kma_b                  k        -         1        -       -
+
+# END XB_TYPE DEFINITION
+
+# BEGIN X_TYPE DEFINITION
+typedef x_type real    u                      ijk      -         1        X       -
+typedef x_type real    v                      ijk      -         1        Y       -
+typedef x_type real    w                      ijk      -         1        -       -
+typedef x_type real    t                      ijk      -         1        -       -
+typedef x_type real    q                      ijk      -         1        -       -
+typedef x_type real    p                      ijk      -         1        -       -
+typedef x_type real    rh                     ijk      -         1        -       -
+typedef x_type real    rho                    ijk      -         1        -       -
+typedef x_type real    wh                     ijk      -         1        -       -
+
+typedef x_type real    qrn                    ijk      -         1        -       -
+typedef x_type real    qcw                    ijk      -         1        -       -
+typedef x_type real    qci                    ijk      -         1        -       -
+typedef x_type real    qsn                    ijk      -         1        -       -
+typedef x_type real    qgr                    ijk      -         1        -       -
+typedef x_type real    qt                     ijk      -         1        -       -
+
+typedef x_type real    tgrn                   ij       -         1        -       -
+typedef x_type real    psfc                   ij       -         1        -       -
+typedef x_type real    u10                    ij       -         1        -       -
+typedef x_type real    v10                    ij       -         1        -       -
+typedef x_type real    t2                     ij       -         1        -       -
+typedef x_type real    q2                     ij       -         1        -       -
+
+typedef x_type real    ref                    ijk      -         1        -       -
+
+typedef x_type real    ztd                    ij       -         1        -       -
+typedef x_type real    tpw                    ij       -         1        -       -
+typedef x_type real    speed                  ij       -         1        -       -
+typedef x_type real    tb19v                  ij       -         1        -       -
+typedef x_type real    tb19h                  ij       -         1        -       -
+typedef x_type real    tb22v                  ij       -         1        -       -
+typedef x_type real    tb37v                  ij       -         1        -       -
+typedef x_type real    tb37h                  ij       -         1        -       -
+typedef x_type real    tb85v                  ij       -         1        -       -
+typedef x_type real    tb85h                  ij       -         1        -       -
+
+#  END TYPE x_type
+
+# BEGIN XPOSE_TYPE DEFINITION:
+#
+typedef xpose_type integer    domdesc
+typedef xpose_type integer    comms(max_comms)
+#
+# For standard MN decomposition:
+typedef xpose_type integer    ids
+typedef xpose_type integer    ide
+typedef xpose_type integer    jds
+typedef xpose_type integer    jde
+typedef xpose_type integer    kds
+typedef xpose_type integer    kde
+
+typedef xpose_type integer    ims
+typedef xpose_type integer    ime
+typedef xpose_type integer    jms
+typedef xpose_type integer    jme
+typedef xpose_type integer    kms
+typedef xpose_type integer    kme
+
+typedef xpose_type integer    its
+typedef xpose_type integer    ite
+typedef xpose_type integer    jts
+typedef xpose_type integer    jte
+typedef xpose_type integer    kts
+typedef xpose_type integer    kte
+
+typedef xpose_type integer    ips
+typedef xpose_type integer    ipe
+typedef xpose_type integer    jps
+typedef xpose_type integer    jpe
+typedef xpose_type integer    kps
+typedef xpose_type integer    kpe
+#
+# For xpose-ing to NZ decomposition:
+typedef xpose_type integer    idsx
+typedef xpose_type integer    idex
+typedef xpose_type integer    jdsx
+typedef xpose_type integer    jdex
+typedef xpose_type integer    kdsx
+typedef xpose_type integer    kdex
+
+typedef xpose_type integer    imsx
+typedef xpose_type integer    imex
+typedef xpose_type integer    jmsx
+typedef xpose_type integer    jmex
+typedef xpose_type integer    kmsx
+typedef xpose_type integer    kmex
+
+typedef xpose_type integer    itsx
+typedef xpose_type integer    itex
+typedef xpose_type integer    jtsx
+typedef xpose_type integer    jtex
+typedef xpose_type integer    ktsx
+typedef xpose_type integer    ktex
+
+typedef xpose_type integer    ipsx
+typedef xpose_type integer    ipex
+typedef xpose_type integer    jpsx
+typedef xpose_type integer    jpex
+typedef xpose_type integer    kpsx
+typedef xpose_type integer    kpex
+#
+# For xpose-ing to MZ decomposition:
+typedef xpose_type integer    idsy
+typedef xpose_type integer    idey
+typedef xpose_type integer    jdsy
+typedef xpose_type integer    jdey
+typedef xpose_type integer    kdsy
+typedef xpose_type integer    kdey
+
+typedef xpose_type integer    imsy
+typedef xpose_type integer    imey
+typedef xpose_type integer    jmsy
+typedef xpose_type integer    jmey
+typedef xpose_type integer    kmsy
+typedef xpose_type integer    kmey
+
+typedef xpose_type integer    itsy
+typedef xpose_type integer    itey
+typedef xpose_type integer    jtsy
+typedef xpose_type integer    jtey
+typedef xpose_type integer    ktsy
+typedef xpose_type integer    ktey
+
+typedef xpose_type integer    ipsy
+typedef xpose_type integer    ipey
+typedef xpose_type integer    jpsy
+typedef xpose_type integer    jpey
+typedef xpose_type integer    kpsy
+typedef xpose_type integer    kpey
+#
+typedef xpose_type real  vxy          ij       -         1        -       -
+
+typedef xpose_type real  v1z          ijk      -         1        -       -
+typedef xpose_type real  v1x          ijkx     -         1        -       -
+typedef xpose_type real  v1y          ijky     -         1        -       -
+
+typedef xpose_type real  v2z          ijk      -         1        -       -
+typedef xpose_type real  v2x          ijkx     -         1        -       -
+typedef xpose_type real  v2y          ijky     -         1        -       -
+
+xpose    XPOSE_V1  dyn_em xp%v1z,xp%v1x,xp%v1y
+xpose    XPOSE_V2  dyn_em xp%v2z,xp%v2x,xp%v2y
+
+# END XPOSE_TYPE DEFINITION
+#
+#Need this next line to set dyncores[0] to "v3d"
+state real dummy i dyn_em 1
+#
+#Set state
+state vp_type vv - -
+state vp_type vv6 - -
+state vp_type vp - -
+state vp_type vp6 - -
+state ep_type ep - -
+state xb_type xb - -
+state x_type xa - -
+state x_type x6a - -
+state xpose_type xp - -
+
+
+# FDDA (Observational-nudging) Variables
+typedef fdob_type integer domain_tot   # total number of domains to apply obs-nudging
+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 NSTAW        # number of obs stations within current time window
+typedef fdob_type integer KTAUR        # restart model step
+typedef fdob_type integer LEVIDN(max_domains)   # level of nest
+typedef fdob_type integer REFPRT(max_domains)   # reference obs index for diagnostic printout
+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 logical NUDGE_UV_PBL # Flag for wind nudging within the PBL
+typedef fdob_type logical NUDGE_T_PBL  # Flag for temperature nudging within the PBL
+typedef fdob_type logical NUDGE_Q_PBL  # Flag for moisture nudging within the PBL
+typedef fdob_type integer SFC_SCHEME_HORIZ # Flag for horizontal spreading scheme for surface obs
+typedef fdob_type integer SFC_SCHEME_VERT  # Flag for vertical   spreading scheme for surface obs
+typedef fdob_type real    MAX_SNDNG_GAP # Maximum pressure gap allowed for interpolating between soundings (centibars)
+typedef fdob_type real    SFCFACT      # scale factor applied to time window for surface obs
+typedef fdob_type real    SFCFACR      # scale factor applied to horiz radius of influence for surface obs
+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    KNOWN_LAT    # Latitude  of origin point (i,j)=(1,1)
+typedef fdob_type real    KNOWN_LON    # Longitude of origin point (i,j)=(1,1)
+typedef fdob_type character SDATE      # domain starting date (YYYY-MM-DD_hh:mm:ss)
+typedef fdob_type real    XTIME_AT_REST # xtime at restart time
+typedef fdob_type real    VIF_UV(6)    # Vertical influence function parameters for wind nudging
+typedef fdob_type real    VIF_T(6)     # Vertical influence function parameters for temperature nudging
+typedef fdob_type real    VIF_Q(6)     # Vertical influence function parameters for moisture nudging
+typedef fdob_type real    VIF_FULLMIN  # Minimum depth through which vert infl fcn remains 1.0 (m)
+typedef fdob_type real    VIF_RAMPMIN  # Minimum depth through which vif decreases 1.0 to 0.0 (m)
+typedef fdob_type real    VIF_MAX      # Maximum depth in which vif is nonzero (m)
+
+# table entries are of the form
+#      <Table>  <Type>  <Sym>                <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>
+#Grid variables
+typedef fdob_type real    varobs         {nndgvar}{obs} -         1        -       -       "varobs"          "observational values in each variable"
+typedef fdob_type real    errf              h{obs}      -         1        -       -       "errf"            "errors between model and obs values"
+typedef fdob_type real    timeob             {obs}      -         1        -       -       "timeob"          "model times for each observation"          "hours"
+typedef fdob_type real    nlevs_ob           {obs}      -         1        -       -       "nlevs_ob"        "numbers of levels in sounding obs"
+typedef fdob_type real    lev_in_ob          {obs}      -         1        -       -       "lev_in_ob"       "level in sounding-type obs"
+typedef fdob_type real    plfo               {obs}      -         1        -       -       "plfo"            "index for type of obs-platform"
+typedef fdob_type real    elevob             {obs}      -         1        -       -       "elevob"          "elevation of observation"                  "meters"
+typedef fdob_type real    rio                {obs}      -         1        -       -       "rio"             "west-east grid coordinate"
+typedef fdob_type real    rjo                {obs}      -         1        -       -       "rjo"             "south-north grid coordinate"
+typedef fdob_type real    rko                {obs}      -         1        -       -       "rko"             "vertical grid coordinate"
+typedef fdob_type integer obsprt               [        -         1        -       -       "obsprt"          "obs index for diagnostic printout"
+typedef fdob_type real    latprt               [        -         1        -       -       "latprt"          "obs latitude for diagnostic printout"
+typedef fdob_type real    lonprt               [        -         1        -       -       "lonprt"          "obs longitude for diagnostic printout"
+typedef fdob_type real    mlatprt              [        -         1        -       -       "mlatprt"         "model latitude at obs location"
+typedef fdob_type real    mlonprt              [        -         1        -       -       "mlonprt"         "model longitude at obs location"
+typedef fdob_type integer stnidprt       {obsstid}{[}   -         1        -       -       "stnidprt"        "obs station id for diagnostic printout"
+typedef fdob_type real    base_state           k        -         1        -       -       "base_state"      "base-state height on half (mass) levels"   "meters"
+
+state fdob_type fdob - -
+
+# xpose variables for polar fft
+state    real   t_xxx          ijkx    -           1        -
+state    real   u_xxx          ijkx    -           1        X
+state    real   ru_xxx         ijkx    -           1        X
+state    real   v_xxx          ijkx    -           1        Y
+state    real   rv_xxx         ijkx    -           1        Y
+state    real   w_xxx          ijkx    -           1        Z
+state    real   ww_xxx         ijkx    -           1        Z
+state    real   ph_xxx         ijkx    -           1        Z
+state    real   dum_yyy        ijky    -           1        -
+state    real   fourd_xxx      ijkx    -           1        -
+state    real   clat_xxx       ijx     -           1        -
+state    real   ht_xxx         ijx     -           1        -
+state    real   mf_xxx         ijx     -           1        -
+
+xpose XPOSE_POLAR_FILTER_TOPO dyn_em t_init,t_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_T  dyn_em t_2,t_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_U  dyn_em u_2,u_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_RU dyn_em ru_m,ru_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_V  dyn_em v_2,v_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_RV dyn_em rv_m,rv_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_W  dyn_em w_2,w_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_WW dyn_em ww_m,ww_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_PH dyn_em ph_2,ph_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_MOIST dyn_em moist,fourd_xxx,dum_yyy
+#xpose XPOSE_POLAR_FILTER_CHEM dyn_em chem,fourd_xxx,dum_yyy
+xpose XPOSE_POLAR_FILTER_SCALAR dyn_em scalar,fourd_xxx,dum_yyy
+
+# xpose variables for spectral nudging
+state    real   dif_analysis     ijk     -           1
+state    real   dif_xxx          ijkx    -           1
+state    real   dif_yyy          ijky    -           1
+
+xpose XPOSE_SPECTRAL_NUDGING dyn_em dif_analysis,dif_xxx,dif_yyy
+##
+
+#include registry.fire
+#include registry.avgflx
+#include registry.stoch
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/Registry_out.LMDZ
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/Registry_out.LMDZ	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/Registry_out.LMDZ	(revision 17)
@@ -0,0 +1,396 @@
+state    real   LAGES_LIC       ij            misc        1         -      rh                                        "LAGES_LIC"       "LMDZ Snow age on frozen land kind soil"                       "day"
+state    real   LAGES_OCE       ij            misc        1         -      rh                                        "LAGES_OCE"       "LMDZ Snow age on ocean kind soil"                             "day"
+state    real   LAGES_SIC       ij            misc        1         -      rh                                        "LAGES_SIC"       "LMDZ Snow age on frozen ocean kind soil"                      "day"
+state    real   LAGES_TER       ij            misc        1         -      rh                                        "LAGES_TER"       "LMDZ Snow age on land kind soil"                              "day"
+##state    real   LAHYB                         misc        1         -      rh                                        "LAHYB"           "LMDZ model_level_number"                                      "Pa"
+state    real   LAIRE           ij            misc        1         -      rh                                        "LAIRE"           "LMDZ Grid area"                                               "-"
+state    real   LAIRETER        ij            misc        1         -      rh                                        "LAIRETER"        "LMDZ Grid area CONT"                                          "-"
+state    real   LALB1           ij            misc        1         -      rh                                        "LALB1"           "LMDZ Surface VIS albedo"                                      "-"
+state    real   LALB2           ij            misc        1         -      rh                                        "LALB2"           "LMDZ Surface Near IR albedo"                                  "-"
+state    real   LALBE_LIC       ij            misc        1         -      rh                                        "LALBE_LIC"       "LMDZ Albedo VIS surf. lic"                                    "m2/s2"
+state    real   LALBE_OCE       ij            misc        1         -      rh                                        "LALBE_OCE"       "LMDZ Albedo VIS surf. oce"                                    "m2/s2"
+state    real   LALBE_SIC       ij            misc        1         -      rh                                        "LALBE_SIC"       "LMDZ Albedo VIS surf. sic"                                    "m2/s2"
+state    real   LALBE_TER       ij            misc        1         -      rh                                        "LALBE_TER"       "LMDZ Albedo VIS surf. ter"                                    "m2/s2"
+state    real   LALE            ij            misc        1         -      rh                                        "LALE"            "LMDZ ALE"                                                     "m2/s2"
+state    real   LALE_BL         ij            misc        1         -      rh                                        "LALE_BL"         "LMDZ ALE BL"                                                  "m2/s2"
+state    real   LALE_WK         ij            misc        1         -      rh                                        "LALE_WK"         "LMDZ ALE WK"                                                  "m2/s2"
+state    real   LALP            ij            misc        1         -      rh                                        "LALP"            "LMDZ ALP"                                                     "W/m2"
+state    real   LALP_BL         ij            misc        1         -      rh                                        "LALP_BL"         "LMDZ ALP BL"                                                  "m2/s2"
+state    real   LALP_WK         ij            misc        1         -      rh                                        "LALP_WK"         "LMDZ ALP WK"                                                  "m2/s2"
+##state    real   LALT                          misc        1         -      rh                                        "LALT"            "LMDZ model_level_number"                                      "Km"
+state    real   LA_TH           ikj           misc        1         -      rh                                        "LA_TH"           "LMDZ Thermal plume fraction"                                  "-"
+state    real   LBETA_PREC      ikj           misc        1         -      rh                                        "LBETA_PREC"      "LMDZ LS Conversion rate to prec"                              "(kg/kg)/s"
+##state    real   LBHYB                         misc        1         -      rh                                        "LBHYB"           "LMDZ model_level_number"                                      " "
+state    real   LBILS           ij            misc        1         -      rh                                        "LBILS"           "LMDZ Surf. total heat flux"                                   "W/m2"
+state    real   LBILS_DISS      ij            misc        1         -      rh                                        "LBILS_DISS"      "LMDZ Surf. total heat flux"                                   "W/m2"
+state    real   LBILS_EC        ij            misc        1         -      rh                                        "LBILS_EC"        "LMDZ Surf. total heat flux"                                   "W/m2"
+state    real   LBILS_ENTHALP   ij            misc        1         -      rh                                        "LBILS_ENTHALP"   "LMDZ Surf. total heat flux"                                   "W/m2"
+state    real   LBILS_KINETIC   ij            misc        1         -      rh                                        "LBILS_KINETIC"   "LMDZ Surf. total heat flux"                                   "W/m2"
+state    real   LBILS_LATENT    ij            misc        1         -      rh                                        "LBILS_LATENT"    "LMDZ Surf. total heat flux"                                   "W/m2"
+state    real   LBILS_TKE       ij            misc        1         -      rh                                        "LBILS_TKE"       "LMDZ Surf. total heat flux"                                   "W/m2"
+state    real   LCAPE           ij            misc        1         -      rh                                        "LCAPE"           "LMDZ Conv avlbl pot ener"                                     "J/kg"
+state    real   LCAPE_MAX       ij            misc        1         -      rh                                        "LCAPE_MAX"       "LMDZ CAPE max."                                               "J/kg"
+state    real   LCDRH           ij            misc        1         -      rh                                        "LCDRH"           "LMDZ Heat drag coef."                                         "-"
+state    real   LCDRM           ij            misc        1         -      rh                                        "LCDRM"           "LMDZ Momentum drag coef."                                     "-"
+state    real   LCLDEMI         ikj           misc        1         -      rh                                        "LCLDEMI"         "LMDZ Cloud optical emissivity"                                "1"
+state    real   LCLDH           ij            misc        1         -      rh                                        "LCLDH"           "LMDZ High-level cloudiness"                                   "-"
+state    real   LCLDL           ij            misc        1         -      rh                                        "LCLDL"           "LMDZ Low-level cloudiness"                                    "-"
+state    real   LCLDM           ij            misc        1         -      rh                                        "LCLDM"           "LMDZ Mid-level cloudiness"                                    "-"
+state    real   LCLDQ           ij            misc        1         -      rh                                        "LCLDQ"           "LMDZ Cloud liquid water path"                                 "kg/m2"
+state    real   LCLDT           ij            misc        1         -      rh                                        "LCLDT"           "LMDZ Total cloudiness"                                        "-"
+state    real   LCLDTAU         ikj           misc        1         -      rh                                        "LCLDTAU"         "LMDZ Cloud optical thickness"                                 "1"
+state    real   LCLWCON         ikj           misc        1         -      rh                                        "LCLWCON"         "LMDZ Convective Cloud Liquid water content"                   "kg/kg"
+state    real   LCONTFRACATM    ij            misc        1         -      rh                                        "LCONTFRACATM"    "LMDZ % sfce ter+lic"                                          "-"
+state    real   LCONTFRACOR     ij            misc        1         -      rh                                        "LCONTFRACOR"     "LMDZ % sfce terre OR"                                         "-"
+state    real   LCUMPB          ij            misc        1         -      rh                                        "LCUMPB"          "LMDZ Cumulated tracer PBVL1"                                  "-"
+state    real   LCUMRN          ij            misc        1         -      rh                                        "LCUMRN"          "LMDZ Cumulated tracer RNVL1"                                  "-"
+state    real   LDMC            ikj           misc        1         -      rh                                        "LDMC"            "LMDZ Deep COnvective Mass Flux"                               "kg/(m2*s)"
+state    real   LDNWD           ikj           misc        1         -      rh                                        "LDNWD"           "LMDZ saturated downdraft"                                     "kg/m2/s"
+state    real   LDNWD0          ikj           misc        1         -      rh                                        "LDNWD0"          "LMDZ unsat. downdraft"                                        "kg/m2/s"
+state    real   LDQAJS          ikj           misc        1         -      rh                                        "LDQAJS"          "LMDZ Dry adjust. dQ"                                          "(kg/kg)/s"
+state    real   LDQCON          ikj           misc        1         -      rh                                        "LDQCON"          "LMDZ Convection dQ"                                           "(kg/kg)/s"
+state    real   LDQDYN          ikj           misc        1         -      rh                                        "LDQDYN"          "LMDZ Dynamics dQ"                                             "(kg/kg)/s"
+state    real   LDQEVA          ikj           misc        1         -      rh                                        "LDQEVA"          "LMDZ Reevaporation dQ"                                        "(kg/kg)/s"
+state    real   LDQLSC          ikj           misc        1         -      rh                                        "LDQLSC"          "LMDZ Condensation dQ"                                         "(kg/kg)/s"
+state    real   LDQLSCST        ikj           misc        1         -      rh                                        "LDQLSCST"        "LMDZ dQ strat."                                               "(kg/kg)/s"
+state    real   LDQLSCTH        ikj           misc        1         -      rh                                        "LDQLSCTH"        "LMDZ dQ therm."                                               "(kg/kg)/s"
+state    real   LDQPHY          ikj           misc        1         -      rh                                        "LDQPHY"          "LMDZ Physics dQ"                                              "(kg/kg)/s"
+state    real   LDQTHE          ikj           misc        1         -      rh                                        "LDQTHE"          "LMDZ Thermal dQ"                                              "(kg/kg)/s"
+state    real   LDQVDF          ikj           misc        1         -      rh                                        "LDQVDF"          "LMDZ Boundary-layer dQ"                                       "(kg/kg)/s"
+state    real   LDQWAK          ikj           misc        1         -      rh                                        "LDQWAK"          "LMDZ Wake dQ"                                                 "(kg/kg)/s"
+state    real   LDTAJS          ikj           misc        1         -      rh                                        "LDTAJS"          "LMDZ Dry adjust. dT"                                          "K/s"
+state    real   LDTCON          ikj           misc        1         -      rh                                        "LDTCON"          "LMDZ Convection dT"                                           "K/s"
+state    real   LDTDIS          ikj           misc        1         -      rh                                        "LDTDIS"          "LMDZ TKE dissipation dT"                                      "K/s"
+state    real   LDTDYN          ikj           misc        1         -      rh                                        "LDTDYN"          "LMDZ Dynamics dT"                                             "K/s"
+state    real   LDTEC           ikj           misc        1         -      rh                                        "LDTEC"           "LMDZ Cinetic dissip dT"                                       "K/s"
+state    real   LDTEVA          ikj           misc        1         -      rh                                        "LDTEVA"          "LMDZ Reevaporation dT"                                        "K/s"
+state    real   LD_TH           ikj           misc        1         -      rh                                        "LD_TH"           "LMDZ Thermal plume detrainment"                               "K/s"
+state    real   LDTHMIN         ij            misc        1         -      rh                                        "LDTHMIN"         "LMDZ dTheta mini"                                             "K/m"
+state    real   LDTLIF          ikj           misc        1         -      rh                                        "LDTLIF"          "LMDZ Orography dT"                                            "K/s"
+state    real   LDTLSC          ikj           misc        1         -      rh                                        "LDTLSC"          "LMDZ Condensation dT"                                         "K/s"
+state    real   LDTLSCHR        ikj           misc        1         -      rh                                        "LDTLSCHR"        "LMDZ Large-scale condensational heating rate"                 "K/s"
+state    real   LDTLSCST        ikj           misc        1         -      rh                                        "LDTLSCST"        "LMDZ dT strat."                                               "K/s"
+state    real   LDTLSCTH        ikj           misc        1         -      rh                                        "LDTLSCTH"        "LMDZ dT therm."                                               "K/s"
+state    real   LDTLW0          ikj           misc        1         -      rh                                        "LDTLW0"          "LMDZ CS LW radiation dT"                                      "K/s"
+state    real   LDTLWR          ikj           misc        1         -      rh                                        "LDTLWR"          "LMDZ LW radiation dT"                                         "K/s"
+state    real   LDTORO          ikj           misc        1         -      rh                                        "LDTORO"          "LMDZ Orography dT"                                            "K/s"
+state    real   LDTPHY          ikj           misc        1         -      rh                                        "LDTPHY"          "LMDZ Physics dT"                                              "K/s"
+state    real   LDTSVDFG        ij            misc        1         -      rh                                        "LDTSVDFG"        "LMDZ Boundary-layer dTs(g)"                                   "K/s"
+state    real   LDTSVDFI        ij            misc        1         -      rh                                        "LDTSVDFI"        "LMDZ Boundary-layer dTs(g)"                                   "K/s"
+state    real   LDTSVDFO        ij            misc        1         -      rh                                        "LDTSVDFO"        "LMDZ Boundary-layer dTs(o)"                                   "K/s"
+state    real   LDTSVDFT        ij            misc        1         -      rh                                        "LDTSVDFT"        "LMDZ Boundary-layer dTs(t)"                                   "K/s"
+state    real   LDTSW0          ikj           misc        1         -      rh                                        "LDTSW0"          "LMDZ CS SW radiation dT"                                      "K/s"
+state    real   LDTSWR          ikj           misc        1         -      rh                                        "LDTSWR"          "LMDZ SW radiation dT"                                         "K/s"
+state    real   LDTTHE          ikj           misc        1         -      rh                                        "LDTTHE"          "LMDZ Thermal dT"                                              "K/s"
+state    real   LDTVDF          ikj           misc        1         -      rh                                        "LDTVDF"          "LMDZ Boundary-layer dT"                                       "K/s"
+state    real   LDTWAK          ikj           misc        1         -      rh                                        "LDTWAK"          "LMDZ Wake dT"                                                 "K/s"
+state    real   LDUCON          ikj           misc        1         -      rh                                        "LDUCON"          "LMDZ Convection du"                                           "m/s2"
+state    real   LDUDYN          ikj           misc        1         -      rh                                        "LDUDYN"          "LMDZ Dynamics dU"                                             "m/s2"
+state    real   LDULIF          ikj           misc        1         -      rh                                        "LDULIF"          "LMDZ Orography dU"                                            "m/s2"
+state    real   LDUORO          ikj           misc        1         -      rh                                        "LDUORO"          "LMDZ Orography dU"                                            "m/s2"
+state    real   LDUVDF          ikj           misc        1         -      rh                                        "LDUVDF"          "LMDZ Boundary-layer dU"                                       "m/s2"
+state    real   LDVCON          ikj           misc        1         -      rh                                        "LDVCON"          "LMDZ Convection dv"                                           "m/s2"
+state    real   LDVDYN          ikj           misc        1         -      rh                                        "LDVDYN"          "LMDZ Dynamics dV"                                             "m/s2"
+state    real   LDVLIF          ikj           misc        1         -      rh                                        "LDVLIF"          "LMDZ Orography dV"                                            "m/s2"
+state    real   LDVORO          ikj           misc        1         -      rh                                        "LDVORO"          "LMDZ Orography dV"                                            "m/s2"
+state    real   LDVVDF          ikj           misc        1         -      rh                                        "LDVVDF"          "LMDZ Boundary-layer dV"                                       "m/s2"
+state    real   LEC550AER       ikj           misc        1         -      rh                                        "LEC550AER"       "LMDZ Extinction at 550nm"                                     "m^-1"
+state    real   LE_TH           ikj           misc        1         -      rh                                        "LE_TH"           "LMDZ Thermal plume entrainment"                               "K/s"
+state    real   LEVAP           ij            misc        1         -      rh                                        "LEVAP"           "LMDZ Evaporat"                                                "kg/(s*m2)"
+state    real   LEVAP_LIC       ij            misc        1         -      rh                                        "LEVAP_LIC"       "LMDZ evaporation at surface lic"                              "kg/(s*m2)"
+state    real   LEVAP_OCE       ij            misc        1         -      rh                                        "LEVAP_OCE"       "LMDZ evaporation at surface oce"                              "kg/(s*m2)"
+state    real   LEVAPPOT_LIC    ij            misc        1         -      rh                                        "LEVAPPOT_LIC"    "LMDZ Temperature lic"                                         "K"
+state    real   LEVAPPOT_OCE    ij            misc        1         -      rh                                        "LEVAPPOT_OCE"    "LMDZ Temperature oce"                                         "K"
+state    real   LEVAPPOT_SIC    ij            misc        1         -      rh                                        "LEVAPPOT_SIC"    "LMDZ Temperature sic"                                         "K"
+state    real   LEVAPPOT_TER    ij            misc        1         -      rh                                        "LEVAPPOT_TER"    "LMDZ Temperature ter"                                         "K"
+state    real   LEVAP_SIC       ij            misc        1         -      rh                                        "LEVAP_SIC"       "LMDZ evaporation at surface sic"                              "kg/(s*m2)"
+state    real   LEVAP_TER       ij            misc        1         -      rh                                        "LEVAP_TER"       "LMDZ evaporation at surface ter"                              "kg/(s*m2)"
+state    real   LEVU            ikj           misc        1         -      rh                                        "LEVU"            "LMDZ Eddy viscosity coefficient for Momentum Variables"       "m2 s-1"
+state    real   LFBASE          ij            misc        1         -      rh                                        "LFBASE"          "LMDZ Cld base mass flux"                                      "kg/m2/s"
+state    real   LFDER           ij            misc        1         -      rh                                        "LFDER"           "LMDZ Heat flux derivation"                                    "W/m2"
+state    real   LFFONTE         ij            misc        1         -      rh                                        "LFFONTE"         "LMDZ Thermal flux for snow melting"                           "W/m2"
+state    real   LFL             ikj           misc        1         -      rh                                        "LFL"             "LMDZ Denominator of Cloud droplet effective radius"           " "
+state    real   LFLAT           ij            misc        1         -      rh                                        "LFLAT"           "LMDZ Latent heat flux"                                        "W/m2"
+state    real   LFLW_LIC        ij            misc        1         -      rh                                        "LFLW_LIC"        "LMDZ LW lic"                                                  "W/m2"
+state    real   LFLW_OCE        ij            misc        1         -      rh                                        "LFLW_OCE"        "LMDZ LW oce"                                                  "W/m2"
+state    real   LFLW_SIC        ij            misc        1         -      rh                                        "LFLW_SIC"        "LMDZ LW sic"                                                  "W/m2"
+state    real   LFLW_TER        ij            misc        1         -      rh                                        "LFLW_TER"        "LMDZ LW ter"                                                  "W/m2"
+state    real   LFQCALVING      ij            misc        1         -      rh                                        "LFQCALVING"      "LMDZ Ice Calving"                                             "kg/m2/s"
+state    real   LFQFONTE        ij            misc        1         -      rh                                        "LFQFONTE"        "LMDZ Land ice melt"                                           "kg/m2/s"
+state    real   LFRACT_LIC      ij            misc        1         -      rh                                        "LFRACT_LIC"      "LMDZ Fraction lic"                                            "1"
+state    real   LFRACT_OCE      ij            misc        1         -      rh                                        "LFRACT_OCE"      "LMDZ Fraction oce"                                            "1"
+state    real   LFRACT_SIC      ij            misc        1         -      rh                                        "LFRACT_SIC"      "LMDZ Fraction sic"                                            "1"
+state    real   LFRACT_TER      ij            misc        1         -      rh                                        "LFRACT_TER"      "LMDZ Fraction ter"                                            "1"
+state    real   LFSNOW          ij            misc        1         -      rh                                        "LFSNOW"          "LMDZ Surface snow area fraction"                              "-"
+state    real   LFSW_LIC        ij            misc        1         -      rh                                        "LFSW_LIC"        "LMDZ SW lic"                                                  "W/m2"
+state    real   LFSW_OCE        ij            misc        1         -      rh                                        "LFSW_OCE"        "LMDZ SW oce"                                                  "W/m2"
+state    real   LFSW_SIC        ij            misc        1         -      rh                                        "LFSW_SIC"        "LMDZ SW sic"                                                  "W/m2"
+state    real   LFSW_TER        ij            misc        1         -      rh                                        "LFSW_TER"        "LMDZ SW ter"                                                  "W/m2"
+state    real   LFTIME_CON      ij            misc        1         -      rh                                        "LFTIME_CON"      "LMDZ Fraction of time convection Occurs"                      " "
+state    real   LFTIME_TH       ij            misc        1         -      rh                                        "LFTIME_TH"       "LMDZ Fraction of time Shallow convection occurs"              " "
+state    real   LGEOP           ikj           misc        1         -      rh                                        "LGEOP"           "LMDZ Geopotential height"                                     "m2/s2"
+state    real   LH2O            ikj           misc        1         -      rh                                        "LH2O"            "LMDZ Mass Fraction of Water"                                  "1"
+state    real   LIWCON          ikj           misc        1         -      rh                                        "LIWCON"          "LMDZ Cloud ice water content"                                 "kg/kg"
+state    real   LIWP            ij            misc        1         -      rh                                        "LIWP"            "LMDZ Cloud ice water path"                                    "kg/m2"
+state    real   LKZ             ikj           misc        1         -      rh                                        "LKZ"             "LMDZ Kz melange"                                              "m2/s"
+state    real   LKZ_MAX         ikj           misc        1         -      rh                                        "LKZ_MAX"         "LMDZ Kz melange max"                                          "m2/s"
+state    real   LLAMBDA_TH      ikj           misc        1         -      rh                                        "LLAMBDA_TH"      "LMDZ Thermal plume vertical velocity"                         "m/s"
+state    real   LLAT            j             misc        1         -      rh                                        "LLAT"            "LMDZ latitude"                                                "degrees_north"
+state    real   LLAT_LIC        ij            misc        1         -      rh                                        "LLAT_LIC"        "LMDZ Latent heat flux lic"                                    "W/m2"
+state    real   LLAT_OCE        ij            misc        1         -      rh                                        "LLAT_OCE"        "LMDZ Latent heat flux oce"                                    "W/m2"
+state    real   LLAT_SIC        ij            misc        1         -      rh                                        "LLAT_SIC"        "LMDZ Latent heat flux sic"                                    "W/m2"
+state    real   LLAT_TER        ij            misc        1         -      rh                                        "LLAT_TER"        "LMDZ Latent heat flux ter"                                    "W/m2"
+state    real   LLMAXTH         ij            misc        1         -      rh                                        "LLMAXTH"         "LMDZ Upper level thermals"                                    " "
+state    real   LLON            i             misc        1         -      rh                                        "LLON"            "LMDZ longitude"                                               "degrees_east"
+state    real   LLWCON          ikj           misc        1         -      rh                                        "LLWCON"          "LMDZ Cloud liquid water content"                              "kg/kg"
+state    real   LLWDN200        ij            misc        1         -      rh                                        "LLWDN200"        "LMDZ LWdn at 200mb"                                           "W/m2"
+state    real   LLWDN200CLR     ij            misc        1         -      rh                                        "LLWDN200CLR"     "LMDZ LWdn clear sky at 200mb"                                 "W/m2"
+state    real   LLWDNSFC        ij            misc        1         -      rh                                        "LLWDNSFC"        "LMDZ Down. IR rad. at surface"                                "W/m2"
+state    real   LLWDNSFCCLR     ij            misc        1         -      rh                                        "LLWDNSFCCLR"     "LMDZ Down. CS IR rad. at surface"                             "W/m2"
+state    real   LLWDOWNOR       ij            misc        1         -      rh                                        "LLWDOWNOR"       "LMDZ Sfce incident LW radiation OR"                           "W/m2"
+state    real   LLWP            ij            misc        1         -      rh                                        "LLWP"            "LMDZ Cloud water path"                                        "kg/m2"
+state    real   LLWUP200        ij            misc        1         -      rh                                        "LLWUP200"        "LMDZ LWup at 200mb"                                           "W/m2"
+state    real   LLWUP200CLR     ij            misc        1         -      rh                                        "LLWUP200CLR"     "LMDZ LWup clear sky at 200mb"                                 "W/m2"
+state    real   LLWUPSFC        ij            misc        1         -      rh                                        "LLWUPSFC"        "LMDZ Upwd. IR rad. at surface"                                "W/m2"
+state    real   LLWUPSFCCLR     ij            misc        1         -      rh                                        "LLWUPSFCCLR"     "LMDZ CS Upwd. IR rad. at surface"                             "W/m2"
+state    real   LMA             ikj           misc        1         -      rh                                        "LMA"             "LMDZ undilute adiab updraft"                                  "kg/m2/s"
+state    real   LMASS           ikj           misc        1         -      rh                                        "LMASS"           "LMDZ Masse Couches"                                           "kg/m2"
+state    real   LMC             ikj           misc        1         -      rh                                        "LMC"             "LMDZ Convective mass flux"                                    "kg/m2/s"
+state    real   LMCD            ikj           misc        1         -      rh                                        "LMCD"            "LMDZ Downdraft COnvective Mass Flux"                          "kg/(m2*s)"
+state    real   LMSNOW          ij            misc        1         -      rh                                        "LMSNOW"          "LMDZ Surface snow amount"                                     "kg/m2"
+state    real   LNDAYRAIN       ij            misc        1         -      rh                                        "LNDAYRAIN"       "LMDZ Number of dayrain(liq+sol)"                              "-"
+state    real   LNETTOP         ij            misc        1         -      rh                                        "LNETTOP"         "LMDZ Net dn radiatif flux at TOA"                             "W/m2"
+state    real   LOLIQ           ikj           misc        1         -      rh                                        "LOLIQ"           "LMDZ Condensed water"                                         "kg/kg"
+state    real   LOVAP           ikj           misc        1         -      rh                                        "LOVAP"           "LMDZ Specific humidity"                                       "kg/kg"
+state    real   LOVAPINIT       ikj           misc        1         -      rh                                        "LOVAPINIT"       "LMDZ Specific humidity (begin of timestep)"                   "kg/kg"
+state    real   LOZONE          ikj           misc        1         -      rh                                        "LOZONE"          "LMDZ Ozone mole fraction"                                     "-"
+state    real   LPAPRS          ikj           misc        1         -      rh                                        "LPAPRS"          "LMDZ Air pressure Inter-Couches"                              "Pa"
+state    real   LPB             ikj           misc        1         -      rh                                        "LPB"             "LMDZ Tracer PBVL1"                                            "-"
+state    real   LPBASE          ij            misc        1         -      rh                                        "LPBASE"          "LMDZ Cld base pressure"                                       "Pa"
+state    real   LPHIS           ij            misc        1         -      rh                                        "LPHIS"           "LMDZ Surface geop.height"                                     "m2/s2"
+state    real   LPLCL           ij            misc        1         -      rh                                        "LPLCL"           "LMDZ Lifting Condensation Level"                              "hPa"
+state    real   LPLFC           ij            misc        1         -      rh                                        "LPLFC"           "LMDZ Level of Free Convection"                                "hPa"
+state    real   LPLUC           ij            misc        1         -      rh                                        "LPLUC"           "LMDZ Convective Precip."                                      "kg/(s*m2)"
+state    real   LPLUL           ij            misc        1         -      rh                                        "LPLUL"           "LMDZ Large-scale Precip."                                     "kg/(s*m2)"
+state    real   LPLULST         ij            misc        1         -      rh                                        "LPLULST"         "LMDZ Rainfall strat."                                         "K/s"
+state    real   LPLULTH         ij            misc        1         -      rh                                        "LPLULTH"         "LMDZ Rainfall therm."                                         "K/s"
+state    real   LPOURC_LIC      ij            misc        1         -      rh                                        "LPOURC_LIC"      "LMDZ % lic"                                                   "%"
+state    real   LPOURC_OCE      ij            misc        1         -      rh                                        "LPOURC_OCE"      "LMDZ % oce"                                                   "%"
+state    real   LPOURC_SIC      ij            misc        1         -      rh                                        "LPOURC_SIC"      "LMDZ % sic"                                                   "%"
+state    real   LPOURC_TER      ij            misc        1         -      rh                                        "LPOURC_TER"      "LMDZ % ter"                                                   "%"
+state    real   LPR_CON_I       ikj           misc        1         -      rh                                        "LPR_CON_I"       "LMDZ Convective precipitation ice"                            " "
+state    real   LPR_CON_L       ikj           misc        1         -      rh                                        "LPR_CON_L"       "LMDZ Convective precipitation lic"                            " "
+state    real   LPRECIP         ij            misc        1         -      rh                                        "LPRECIP"         "LMDZ Precip Totale liq+sol"                                   "kg/(s*m2)"
+state    real   LPRES           ikj           misc        1         -      rh                                        "LPRES"           "LMDZ Air pressure"                                            "Pa"
+state    real   LPRESNIVS       k             misc        1         -      rh                                        "LPRESNIVS"       "LMDZ model_level_number"                                      "Pa"
+state    real   LPR_LSC_I       ikj           misc        1         -      rh                                        "LPR_LSC_I"       "LMDZ Large scale precipitation ice"                           " "
+state    real   LPR_LSC_L       ikj           misc        1         -      rh                                        "LPR_LSC_L"       "LMDZ Large scale precipitation lic"                           " "
+state    real   LPRW            ij            misc        1         -      rh                                        "LPRW"            "LMDZ Precipitable water"                                      "kg/m2"
+state    real   LPSOL           ij            misc        1         -      rh                                        "LPSOL"           "LMDZ Surface Pressure"                                        "Pa"
+state    real   LPTCONV         ikj           misc        1         -      rh                                        "LPTCONV"         "LMDZ POINTS CONVECTIFS"                                       " "
+state    real   LPTOP           ij            misc        1         -      rh                                        "LPTOP"           "LMDZ Cld top pressure"                                        "Pa"
+state    real   LQ10            ij            misc        1         -      rh                                        "LQ10"            "LMDZ Specific humidity 7hPa"                                  "kg/kg"
+state    real   LQ100           ij            misc        1         -      rh                                        "LQ100"           "LMDZ Specific humidity 5hPa"                                  "kg/kg"
+state    real   LQ200           ij            misc        1         -      rh                                        "LQ200"           "LMDZ Specific humidity 4hPa"                                  "kg/kg"
+state    real   LQ2M            ij            misc        1         -      rh                                        "LQ2M"            "LMDZ Specific humidity 2m"                                    "kg/kg"
+state    real   LQ50            ij            misc        1         -      rh                                        "LQ50"            "LMDZ Specific humidity 6hPa"                                  "kg/kg"
+state    real   LQ500           ij            misc        1         -      rh                                        "LQ500"           "LMDZ Specific humidity 3hPa"                                  "kg/kg"
+state    real   LQ700           ij            misc        1         -      rh                                        "LQ700"           "LMDZ Specific humidity 2hPa"                                  "kg/kg"
+state    real   LQ850           ij            misc        1         -      rh                                        "LQ850"           "LMDZ Specific humidity 1hPa"                                  "kg/kg"
+state    real   LQSAT2M         ij            misc        1         -      rh                                        "LQSAT2M"         "LMDZ Saturant humidity at 2m"                                 "%"
+state    real   LQSOL           ij            misc        1         -      rh                                        "LQSOL"           "LMDZ Soil watter content"                                     "mm"
+state    real   LQSURF          ij            misc        1         -      rh                                        "LQSURF"          "LMDZ Surface Air humidity"                                    "kg/kg"
+state    real   LQ_TH           ikj           misc        1         -      rh                                        "LQ_TH"           "LMDZ Thermal plume total humidity"                            "kg/kg"
+state    real   LRADSOL         ij            misc        1         -      rh                                        "LRADSOL"         "LMDZ Rayonnement au sol"                                      "W/m2"
+state    real   LRATQS          ikj           misc        1         -      rh                                        "LRATQS"          "LMDZ RATQS"                                                   " "
+state    real   LRE             ikj           misc        1         -      rh                                        "LRE"             "LMDZ Cloud droplet effective radius"                          "um"
+state    real   LREF_ICE        ikj           misc        1         -      rh                                        "LREF_ICE"        "LMDZ Effective radius of startiform cloud ice particle"       "m"
+state    real   LREF_LIQ        ikj           misc        1         -      rh                                        "LREF_LIQ"        "LMDZ Effective radius of convective cloud liquid water particle" "m"
+state    real   LRH2M           ij            misc        1         -      rh                                        "LRH2M"           "LMDZ Relative humidity at 2m"                                 "%"
+state    real   LRH2M_MAX       ij            misc        1         -      rh                                        "LRH2M_MAX"       "LMDZ Max Relative humidity at 2m"                             "%"
+state    real   LRH2M_MIN       ij            misc        1         -      rh                                        "LRH2M_MIN"       "LMDZ Min Relative humidity at 2m"                             "%"
+state    real   LRHUM           ikj           misc        1         -      rh                                        "LRHUM"           "LMDZ Relative humidity"                                       "-"
+state    real   LRLD            ikj           misc        1         -      rh                                        "LRLD"            "LMDZ LW downward radiation"                                   "W m-2"
+state    real   LRLDCS          ikj           misc        1         -      rh                                        "LRLDCS"          "LMDZ LW CS downward radiation"                                "W m-2"
+state    real   LRLU            ikj           misc        1         -      rh                                        "LRLU"            "LMDZ LW upward radiation"                                     "W m-2"
+state    real   LRLUCS          ikj           misc        1         -      rh                                        "LRLUCS"          "LMDZ LW CS upward radiation"                                  "W m-2"
+state    real   LRN             ikj           misc        1         -      rh                                        "LRN"             "LMDZ Tracer RNVL1"                                            "-"
+state    real   LRNEB           ikj           misc        1         -      rh                                        "LRNEB"           "LMDZ Cloud fraction"                                          "-"
+state    real   LRNEBCON        ikj           misc        1         -      rh                                        "LRNEBCON"        "LMDZ Convective Cloud Fraction"                               "-"
+state    real   LRNEBLS         ikj           misc        1         -      rh                                        "LRNEBLS"         "LMDZ LS Cloud fraction"                                       "-"
+state    real   LRSD            ikj           misc        1         -      rh                                        "LRSD"            "LMDZ SW downward radiation"                                   "W m-2"
+state    real   LRSDCS          ikj           misc        1         -      rh                                        "LRSDCS"          "LMDZ SW CS downward radiation"                                "W m-2"
+state    real   LRSU            ikj           misc        1         -      rh                                        "LRSU"            "LMDZ SW upward radiation"                                     "W m-2"
+state    real   LRSUCS          ikj           misc        1         -      rh                                        "LRSUCS"          "LMDZ SW CS upward radiation"                                  "W m-2"
+state    real   LRUGS           ij            misc        1         -      rh                                        "LRUGS"           "LMDZ rugosity"                                                "-"
+state    real   LRUGS_LIC       ij            misc        1         -      rh                                        "LRUGS_LIC"       "LMDZ Surface roughness lic"                                   "m"
+state    real   LRUGS_OCE       ij            misc        1         -      rh                                        "LRUGS_OCE"       "LMDZ Surface roughness oce"                                   "m"
+state    real   LRUGS_SIC       ij            misc        1         -      rh                                        "LRUGS_SIC"       "LMDZ Surface roughness sic"                                   "m"
+state    real   LRUGS_TER       ij            misc        1         -      rh                                        "LRUGS_TER"       "LMDZ Surface roughness ter"                                   "m"
+state    real   LSENS           ij            misc        1         -      rh                                        "LSENS"           "LMDZ Sensible heat flux"                                      "W/m2"
+state    real   LSENS_LIC       ikj           misc        1         -      rh                                        "LSENS_LIC"       "LMDZ Sensible heat flux lic"                                  "W/m2"
+state    real   LSENS_OCE       ikj           misc        1         -      rh                                        "LSENS_OCE"       "LMDZ Sensible heat flux oce"                                  "W/m2"
+state    real   LSENS_SIC       ikj           misc        1         -      rh                                        "LSENS_SIC"       "LMDZ Sensible heat flux sic"                                  "W/m2"
+state    real   LSENS_TER       ikj           misc        1         -      rh                                        "LSENS_TER"       "LMDZ Sensible heat flux ter"                                  "W/m2"
+state    real   LSICF           ij            misc        1         -      rh                                        "LSICF"           "LMDZ Sea-ice fraction"                                        "-"
+state    real   LS_LCL          ij            misc        1         -      rh                                        "LS_LCL"          "LMDZ Condensation level"                                      "m"
+state    real   LSLP            ij            misc        1         -      rh                                        "LSLP"            "LMDZ Sea Level Pressure"                                      "Pa"
+state    real   LSNOW           ij            misc        1         -      rh                                        "LSNOW"           "LMDZ Snow fall"                                               "kg/(s*m2)"
+state    real   LSNOWL          ij            misc        1         -      rh                                        "LSNOWL"          "LMDZ Solid Large-scale Precip."                               "kg/(m2*s)"
+state    real   LSOLL           ij            misc        1         -      rh                                        "LSOLL"           "LMDZ IR rad. at surface"                                      "W/m2"
+state    real   LSOLL0          ij            misc        1         -      rh                                        "LSOLL0"          "LMDZ IR rad. at surface"                                      "W/m2"
+state    real   LSOLLWDOWN      ij            misc        1         -      rh                                        "LSOLLWDOWN"      "LMDZ Down. IR rad. at surface"                                "W/m2"
+state    real   LSOLS           ij            misc        1         -      rh                                        "LSOLS"           "LMDZ Solar rad. at surf."                                     "W/m2"
+state    real   LSOLS0          ij            misc        1         -      rh                                        "LSOLS0"          "LMDZ Solar rad. at surf."                                     "W/m2"
+state    real   LS_PBLH         ij            misc        1         -      rh                                        "LS_PBLH"         "LMDZ Boundary Layer Height"                                   "m"
+state    real   LS_PBLT         ij            misc        1         -      rh                                        "LS_PBLT"         "LMDZ t at Boundary Layer Height"                              "K"
+state    real   LS_THERM        ij            misc        1         -      rh                                        "LS_THERM"        "LMDZ Exces du thermique"                                      "K"
+state    real   LSWDN200        ij            misc        1         -      rh                                        "LSWDN200"        "LMDZ SWdn at 200mb"                                           "W/m2"
+state    real   LSWDN200CLR     ij            misc        1         -      rh                                        "LSWDN200CLR"     "LMDZ SWdn clear sky at 200mb"                                 "W/m2"
+state    real   LSWDNSFC        ij            misc        1         -      rh                                        "LSWDNSFC"        "LMDZ SWdn at surface"                                         "W/m2"
+state    real   LSWDNSFCCLR     ij            misc        1         -      rh                                        "LSWDNSFCCLR"     "LMDZ SWdn clear sky at surface"                               "W/m2"
+state    real   LSWDNTOA        ij            misc        1         -      rh                                        "LSWDNTOA"        "LMDZ SWdn at TOA"                                             "W/m2"
+state    real   LSWDNTOACLR     ij            misc        1         -      rh                                        "LSWDNTOACLR"     "LMDZ SWdn clear sky at TOA"                                   "W/m2"
+state    real   LSWDOWNOR       ij            misc        1         -      rh                                        "LSWDOWNOR"       "LMDZ Sfce incident SW radiation OR"                           "W/m2"
+state    real   LSWNETOR        ij            misc        1         -      rh                                        "LSWNETOR"        "LMDZ Sfce net SW radiation OR"                                "W/m2"
+state    real   LSWUP200        ij            misc        1         -      rh                                        "LSWUP200"        "LMDZ SWup at 200mb"                                           "W/m2"
+state    real   LSWUP200CLR     ij            misc        1         -      rh                                        "LSWUP200CLR"     "LMDZ SWup clear sky at 200mb"                                 "W/m2"
+state    real   LSWUPSFC        ij            misc        1         -      rh                                        "LSWUPSFC"        "LMDZ SWup at surface"                                         "W/m2"
+state    real   LSWUPSFCCLR     ij            misc        1         -      rh                                        "LSWUPSFCCLR"     "LMDZ SWup clear sky at surface"                               "W/m2"
+state    real   LSWUPTOA        ij            misc        1         -      rh                                        "LSWUPTOA"        "LMDZ SWup at TOA"                                             "W/m2"
+state    real   LSWUPTOACLR     ij            misc        1         -      rh                                        "LSWUPTOACLR"     "LMDZ SWup clear sky at TOA"                                   "W/m2"
+state    real   LT10            ij            misc        1         -      rh                                        "LT10"            "LMDZ Temperature 7hPa"                                        "K"
+state    real   LT100           ij            misc        1         -      rh                                        "LT100"           "LMDZ Temperature 5hPa"                                        "K"
+state    real   LT200           ij            misc        1         -      rh                                        "LT200"           "LMDZ Temperature 4hPa"                                        "K"
+state    real   LT2M            ij            misc        1         -      rh                                        "LT2M"            "LMDZ Temperature 2m"                                          "K"
+state    real   LT2M_LIC        ij            misc        1         -      rh                                        "LT2M_LIC"        "LMDZ Temp 2m lic"                                             "K"
+state    real   LT2M_MAX        ij            misc        1         -      rh                                        "LT2M_MAX"        "LMDZ Temp 2m max"                                             "K"
+state    real   LT2M_MIN        ij            misc        1         -      rh                                        "LT2M_MIN"        "LMDZ Temp 2m min"                                             "K"
+state    real   LT2M_OCE        ij            misc        1         -      rh                                        "LT2M_OCE"        "LMDZ Temp 2m oce"                                             "K"
+state    real   LT2M_SIC        ij            misc        1         -      rh                                        "LT2M_SIC"        "LMDZ Temp 2m sic"                                             "K"
+state    real   LT2M_TER        ij            misc        1         -      rh                                        "LT2M_TER"        "LMDZ Temp 2m ter"                                             "K"
+state    real   LT50            ij            misc        1         -      rh                                        "LT50"            "LMDZ Temperature 6hPa"                                        "K"
+state    real   LT500           ij            misc        1         -      rh                                        "LT500"           "LMDZ Temperature 3hPa"                                        "K"
+state    real   LT700           ij            misc        1         -      rh                                        "LT700"           "LMDZ Temperature 2hPa"                                        "K"
+state    real   LT850           ij            misc        1         -      rh                                        "LT850"           "LMDZ Temperature 1hPa"                                        "K"
+state    real   LTAUX           ij            misc        1         -      rh                                        "LTAUX"           "LMDZ Zonal wind stress"                                       "Pa"
+state    real   LTAUX_LIC       ij            misc        1         -      rh                                        "LTAUX_LIC"       "LMDZ Zonal wind stresslic"                                    "Pa"
+state    real   LTAUX_OCE       ij            misc        1         -      rh                                        "LTAUX_OCE"       "LMDZ Zonal wind stressoce"                                    "Pa"
+state    real   LTAUX_SIC       ij            misc        1         -      rh                                        "LTAUX_SIC"       "LMDZ Zonal wind stresssic"                                    "Pa"
+state    real   LTAUX_TER       ij            misc        1         -      rh                                        "LTAUX_TER"       "LMDZ Zonal wind stresster"                                    "Pa"
+state    real   LTAUY           ij            misc        1         -      rh                                        "LTAUY"           "LMDZ Meridional wind stress"                                  "Pa"
+state    real   LTAUY_LIC       ij            misc        1         -      rh                                        "LTAUY_LIC"       "LMDZ Meridional wind stress lic"                              "Pa"
+state    real   LTAUY_OCE       ij            misc        1         -      rh                                        "LTAUY_OCE"       "LMDZ Meridional wind stress oce"                              "Pa"
+state    real   LTAUY_SIC       ij            misc        1         -      rh                                        "LTAUY_SIC"       "LMDZ Meridional wind stress sic"                              "Pa"
+state    real   LTAUY_TER       ij            misc        1         -      rh                                        "LTAUY_TER"       "LMDZ Meridional wind stress ter"                              "Pa"
+state    real   LTEMP           ikj           misc        1         -      rh                                        "LTEMP"           "LMDZ Air temperature"                                         "K"
+state    real   LTHETA          ikj           misc        1         -      rh                                        "LTHETA"          "LMDZ Potential air temperature"                               "K"
+##state    real   LTIME           -             misc        1         -      rh                                        "LTIME"           "LMDZ time"                                                    "seconds since 1999-12-31 00:00:00"
+##state    real   LTIME_BOUNDS    {lbnds}       misc        1         -      rh                                        "LTIME_BOUNDS"    "LMDZ time bounds"                                             "seconds since 1999-12-31 00:00:00"
+##state    real   LTI86400        -             misc        1         -      rh                                        "LTI86400"        "LMDZ time"                                                    "seconds since 1999-12-31 00:00:00"
+state    real   LTKE            ikj           misc        1         -      rh                                        "LTKE"            "LMDZ TKE"                                                     "m2/s2"
+state    real   LTKE_LIC        ikj           misc        1         -      rh                                        "LTKE_LIC"        "LMDZ Max Turb. Kinetic Energy lic"                            "-"
+state    real   LTKE_MAX        ikj           misc        1         -      rh                                        "LTKE_MAX"        "LMDZ TKE max"                                                 "m2/s2"
+state    real   LTKE_MAX_LIC    ij            misc        1         -      rh                                        "LTKE_MAX_LIC"    "LMDZ Max Turb. Kinetic Energy lic"                            "-"
+state    real   LTKE_MAX_OCE    ij            misc        1         -      rh                                        "LTKE_MAX_OCE"    "LMDZ Max Turb. Kinetic Energy oce"                            "-"
+state    real   LTKE_MAX_SIC    ij            misc        1         -      rh                                        "LTKE_MAX_SIC"    "LMDZ Max Turb. Kinetic Energy sic"                            "-"
+state    real   LTKE_MAX_TER    ij            misc        1         -      rh                                        "LTKE_MAX_TER"    "LMDZ Max Turb. Kinetic Energy ter"                            "-"
+state    real   LTKE_OCE        ikj            misc       1         -      rh                                        "LTKE_OCE"        "LMDZ Max Turb. Kinetic Energy oce"                            "-"
+state    real   LTKE_SIC        ikj            misc       1         -      rh                                        "LTKE_SIC"        "LMDZ Max Turb. Kinetic Energy sic"                            "-"
+state    real   LTKE_TER        ikj            misc       1         -      rh                                        "LTKE_TER"        "LMDZ Max Turb. Kinetic Energy ter"                            "-"
+state    real   LTNHUS          ikj           misc        1         -      rh                                        "LTNHUS"          "LMDZ Tendency of specific humidity"                           "s-1"
+state    real   LTNHUSC         ikj           misc        1         -      rh                                        "LTNHUSC"         "LMDZ Tendency of specific humidity due to convection"         "s-1"
+state    real   LTNHUSSCPBL     ikj           misc        1         -      rh                                        "LTNHUSSCPBL"     "LMDZ Tendency of Specific humidity due to ST cl, precip and BL mixing" "s-1"
+state    real   LTNT            ikj           misc        1         -      rh                                        "LTNT"            "LMDZ Tendency of air temperature"                             "K s-1"
+state    real   LTNTC           ikj           misc        1         -      rh                                        "LTNTC"           "LMDZ Tendency of air temperature due to Moist Convection"     "K s-1"
+state    real   LTNTR           ikj           misc        1         -      rh                                        "LTNTR"           "LMDZ Air temperature tendency due to Radiative heating"       "K s-1"
+state    real   LTNTSCPBL       ikj           misc        1         -      rh                                        "LTNTSCPBL"       "LMDZ Air temperature tendency due to St cloud and precipitation and BL mixing" "K s-1"
+state    real   LT_OCE_SIC      ij            misc        1         -      rh                                        "LT_OCE_SIC"      "LMDZ Temp mixte oce-sic"                                      "K"
+##state    real   LT_OP_00001800                misc        1         -      rh                                        "LT_OP_00001800"  "LMDZ time"                                                    "seconds since 1979-01-01 00:00:00"
+##state    real   LT_OP_00001800_BNDS              misc        1         -      rh                                        "LT_OP_00001800_BNDS""LMDZ "                                                        " "
+state    real   LTOPL           ij            misc        1         -      rh                                        "LTOPL"           "LMDZ IR rad. at TOA"                                          "W/m2"
+state    real   LTOPL0          ij            misc        1         -      rh                                        "LTOPL0"          "LMDZ IR rad. at TOA"                                          "W/m2"
+state    real   LTOPS           ij            misc        1         -      rh                                        "LTOPS"           "LMDZ Solar rad. at TOA"                                       "W/m2"
+state    real   LTOPS0          ij            misc        1         -      rh                                        "LTOPS0"          "LMDZ CS Solar rad. at TOA"                                    "W/m2"
+state    real   LTPOT           ij            misc        1         -      rh                                        "LTPOT"           "LMDZ Surface air potential temperature"                       "K"
+state    real   LTPOTE          ij            misc        1         -      rh                                        "LTPOTE"          "LMDZ Surface air equivalent potential temperature"            "K"
+state    real   LTSOL           ij            misc        1         -      rh                                        "LTSOL"           "LMDZ Surface Temperature"                                     "K"
+state    real   LTSOL_LIC       ij            misc        1         -      rh                                        "LTSOL_LIC"       "LMDZ Temperature lic"                                         "K"
+state    real   LTSOL_OCE       ij            misc        1         -      rh                                        "LTSOL_OCE"       "LMDZ Temperature oce"                                         "K"
+state    real   LTSOL_SIC       ij            misc        1         -      rh                                        "LTSOL_SIC"       "LMDZ Temperature sic"                                         "K"
+state    real   LTSOL_TER       ij            misc        1         -      rh                                        "LTSOL_TER"       "LMDZ Temperature ter"                                         "K"
+state    real   LU10            ij            misc        1         -      rh                                        "LU10"            "LMDZ Zonal wind 7hPa"                                         "m/s"
+state    real   LU100           ij            misc        1         -      rh                                        "LU100"           "LMDZ Zonal wind 5hPa"                                         "m/s"
+state    real   LU10M           ij            misc        1         -      rh                                        "LU10M"           "LMDZ Vent zonal 10m"                                          "m/s"
+state    real   LU10M_LIC       ij            misc        1         -      rh                                        "LU10M_LIC"       "LMDZ Vent Zonal 10m lic"                                      "m/s"
+state    real   LU10M_OCE       ij            misc        1         -      rh                                        "LU10M_OCE"       "LMDZ Vent Zonal 10m oce"                                      "m/s"
+state    real   LU10M_SIC       ij            misc        1         -      rh                                        "LU10M_SIC"       "LMDZ Vent Zonal 10m sic"                                      "m/s"
+state    real   LU10M_TER       ij            misc        1         -      rh                                        "LU10M_TER"       "LMDZ Vent Zonal 10m ter"                                      "m/s"
+state    real   LU200           ij            misc        1         -      rh                                        "LU200"           "LMDZ Zonal wind 4hPa"                                         "m/s"
+state    real   LU50            ij            misc        1         -      rh                                        "LU50"            "LMDZ Zonal wind 6hPa"                                         "m/s"
+state    real   LU500           ij            misc        1         -      rh                                        "LU500"           "LMDZ Zonal wind 3hPa"                                         "m/s"
+state    real   LU700           ij            misc        1         -      rh                                        "LU700"           "LMDZ Zonal wind 2hPa"                                         "m/s"
+state    real   LU850           ij            misc        1         -      rh                                        "LU850"           "LMDZ Zonal wind 1hPa"                                         "m/s"
+state    real   LUE             ij            misc        1         -      rh                                        "LUE"             "LMDZ Zonal energy transport"                                  "-"
+state    real   LUPWD           ikj           misc        1         -      rh                                        "LUPWD"           "LMDZ saturated updraft"                                       "kg/m2/s"
+state    real   LUQ             ij            misc        1         -      rh                                        "LUQ"             "LMDZ Zonal humidity transport"                                "-"
+state    real   LUSTAR          ij            misc        1         -      rh                                        "LUSTAR"          "LMDZ Friction velocity"                                       "m/s"
+state    real   LUSTAR_LIC      ij            misc        1         -      rh                                        "LUSTAR_LIC"      "LMDZ Friction velocity lic"                                   "m/s"
+state    real   LUSTAR_OCE      ij            misc        1         -      rh                                        "LUSTAR_OCE"      "LMDZ Friction velocity oce"                                   "m/s"
+state    real   LUSTAR_SIC      ij            misc        1         -      rh                                        "LUSTAR_SIC"      "LMDZ Friction velocity sic"                                   "m/s"
+state    real   LUSTAR_TER      ij            misc        1         -      rh                                        "LUSTAR_TER"      "LMDZ Friction velocity ter"                                   "m/s"
+state    real   LV10            ij            misc        1         -      rh                                        "LV10"            "LMDZ Meridional wind 7hPa"                                    "m/s"
+state    real   LV100           ij            misc        1         -      rh                                        "LV100"           "LMDZ Meridional wind 5hPa"                                    "m/s"
+state    real   LV10M           ij            misc        1         -      rh                                        "LV10M"           "LMDZ Vent meridien 10m"                                       "m/s"
+state    real   LV10M_LIC       ij            misc        1         -      rh                                        "LV10M_LIC"       "LMDZ Vent meredien 10m lic"                                   "m/s"
+state    real   LV10M_OCE       ij            misc        1         -      rh                                        "LV10M_OCE"       "LMDZ Vent meredien 10m oce"                                   "m/s"
+state    real   LV10M_SIC       ij            misc        1         -      rh                                        "LV10M_SIC"       "LMDZ Vent meredien 10m sic"                                   "m/s"
+state    real   LV10M_TER       ij            misc        1         -      rh                                        "LV10M_TER"       "LMDZ Vent meredien 10m ter"                                   "m/s"
+state    real   LV200           ij            misc        1         -      rh                                        "LV200"           "LMDZ Meridional wind 4hPa"                                    "m/s"
+state    real   LV50            ij            misc        1         -      rh                                        "LV50"            "LMDZ Meridional wind 6hPa"                                    "m/s"
+state    real   LV500           ij            misc        1         -      rh                                        "LV500"           "LMDZ Meridional wind 3hPa"                                    "m/s"
+state    real   LV700           ij            misc        1         -      rh                                        "LV700"           "LMDZ Meridional wind 2hPa"                                    "m/s"
+state    real   LV850           ij            misc        1         -      rh                                        "LV850"           "LMDZ Meridional wind 1hPa"                                    "m/s"
+state    real   LVE             ij            misc        1         -      rh                                        "LVE"             "LMDZ Merid energy transport"                                  "-"
+state    real   LVITU           ikj           misc        1         -      rh                                        "LVITU"           "LMDZ Zonal wind"                                              "m/s"
+state    real   LVITV           ikj           misc        1         -      rh                                        "LVITV"           "LMDZ Meridional wind"                                         "m/s"
+state    real   LVITW           ikj           misc        1         -      rh                                        "LVITW"           "LMDZ Vertical wind"                                           "Pa/s"
+state    real   LVPRECIP        ikj           misc        1         -      rh                                        "LVPRECIP"        "LMDZ precipitation vertical profile"                          "-"
+state    real   LVQ             ij            misc        1         -      rh                                        "LVQ"             "LMDZ Merid humidity transport"                                "-"
+state    real   LW10            ij            misc        1         -      rh                                        "LW10"            "LMDZ Vertical wind 7hPa"                                      "Pa/s"
+state    real   LW100           ij            misc        1         -      rh                                        "LW100"           "LMDZ Vertical wind 5hPa"                                      "Pa/s"
+state    real   LW200           ij            misc        1         -      rh                                        "LW200"           "LMDZ Vertical wind 4hPa"                                      "Pa/s"
+state    real   LW50            ij            misc        1         -      rh                                        "LW50"            "LMDZ Vertical wind 6hPa"                                      "Pa/s"
+state    real   LW500           ij            misc        1         -      rh                                        "LW500"           "LMDZ Vertical wind 3hPa"                                      "Pa/s"
+state    real   LW700           ij            misc        1         -      rh                                        "LW700"           "LMDZ Vertical wind 2hPa"                                      "Pa/s"
+state    real   LW850           ij            misc        1         -      rh                                        "LW850"           "LMDZ Vertical wind 1hPa"                                      "Pa/s"
+state    real   LWAKE_DELTAQ    ikj           misc        1         -      rh                                        "LWAKE_DELTAQ"    "LMDZ wake_deltaq"                                             " "
+state    real   LWAKE_DELTAT    ikj           misc        1         -      rh                                        "LWAKE_DELTAT"    "LMDZ wake_deltat"                                             " "
+state    real   LWAKE_H         ij            misc        1         -      rh                                        "LWAKE_H"         "LMDZ wake_h"                                                  "-"
+state    real   LWAKE_OMG       ikj           misc        1         -      rh                                        "LWAKE_OMG"       "LMDZ wake_omg"                                                " "
+state    real   LWAKE_S         ij            misc        1         -      rh                                        "LWAKE_S"         "LMDZ wake_s"                                                  "-"
+state    real   LWAPE           ij            misc        1         -      rh                                        "LWAPE"           "LMDZ "                                                        " "
+state    real   LWBEFF          ij            misc        1         -      rh                                        "LWBEFF"          "LMDZ Conv. updraft velocity at LFC (<100)"                    "m/s"
+state    real   LWBILO_LIC      ij            misc        1         -      rh                                        "LWBILO_LIC"      "LMDZ Bilan eau lic"                                           "kg/(m2*s)"
+state    real   LWBILO_OCE      ij            misc        1         -      rh                                        "LWBILO_OCE"      "LMDZ Bilan eau oce"                                           "kg/(m2*s)"
+state    real   LWBILO_SIC      ij            misc        1         -      rh                                        "LWBILO_SIC"      "LMDZ Bilan eau sic"                                           "kg/(m2*s)"
+state    real   LWBILO_TER      ij            misc        1         -      rh                                        "LWBILO_TER"      "LMDZ Bilan eau ter"                                           "kg/(m2*s)"
+state    real   LWBILS_LIC      ij            misc        1         -      rh                                        "LWBILS_LIC"      "LMDZ Bilan sol lic"                                           "W/m2"
+state    real   LWBILS_OCE      ij            misc        1         -      rh                                        "LWBILS_OCE"      "LMDZ Bilan sol oce"                                           "W/m2"
+state    real   LWBILS_SIC      ij            misc        1         -      rh                                        "LWBILS_SIC"      "LMDZ Bilan sol sic"                                           "W/m2"
+state    real   LWBILS_TER      ij            misc        1         -      rh                                        "LWBILS_TER"      "LMDZ Bilan sol ter"                                           "W/m2"
+state    real   LWDTRAINA       ikj           misc        1         -      rh                                        "LWDTRAINA"       "LMDZ precipitation from AA"                                   "-"
+state    real   LWDTRAINM       ikj           misc        1         -      rh                                        "LWDTRAINM"       "LMDZ precipitation from mixture"                              "-"
+state    real   LWEAKINV        ij            misc        1         -      rh                                        "LWEAKINV"        "LMDZ Weak inversion"                                          "-"
+state    real   LWIND10M        ij            misc        1         -      rh                                        "LWIND10M"        "LMDZ 10-m wind speed"                                         "m/s"
+state    real   LWIND10MAX      ij            misc        1         -      rh                                        "LWIND10MAX"      "LMDZ 10m wind speed max"                                      "m/s"
+state    real   LZ10            ij            misc        1         -      rh                                        "LZ10"            "LMDZ Geopotential height 7hPa"                                "m"
+state    real   LZ100           ij            misc        1         -      rh                                        "LZ100"           "LMDZ Geopotential height 5hPa"                                "m"
+state    real   LZ200           ij            misc        1         -      rh                                        "LZ200"           "LMDZ Geopotential height 4hPa"                                "m"
+state    real   LZ50            ij            misc        1         -      rh                                        "LZ50"            "LMDZ Geopotential height 6hPa"                                "m"
+state    real   LZ500           ij            misc        1         -      rh                                        "LZ500"           "LMDZ Geopotential height 3hPa"                                "m"
+state    real   LZ700           ij            misc        1         -      rh                                        "LZ700"           "LMDZ Geopotential height 2hPa"                                "m"
+state    real   LZ850           ij            misc        1         -      rh                                        "LZ850"           "LMDZ Geopotential height 1hPa"                                "m"
+state    real   LZFULL          ikj           misc        1         -      rh                                        "LZFULL"          "LMDZ Altitude of full pressure levels"                        "m"
+state    real   LZHALF          ikj           misc        1         -      rh                                        "LZHALF"          "LMDZ Altitude of half pressure levels"                        "m"
+state    real   LZMAX_TH        ij            misc        1         -      rh                                        "LZMAX_TH"        "LMDZ Thermal plume height"                                    "K/s"
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/io_boilerplate_temporary.inc
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/io_boilerplate_temporary.inc	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/io_boilerplate_temporary.inc	(revision 17)
@@ -0,0 +1,1112 @@
+!STARTOFREGISTRYGENERATEDINCLUDE 'Registry/io_boilerplate_temporary.inc'
+!
+! WARNING This file is generated automatically by use_registry
+! using the data base in the file named Registry.
+! Do not edit.  Your changes to this file will be lost.
+!
+rconfig logical override_restart_timers namelist,time_control 1 .false.
+state integer auxhist1_oid         - - - - - "" "" ""
+rconfig character auxhist1_inname namelist,time_control 1 "auxhist1_d<domain>_<date>"
+rconfig character auxhist1_outname namelist,time_control 1 "auxhist1_d<domain>_<date>"
+rconfig integer auxhist1_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist1_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist1_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist1_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist1_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist1_interval   namelist,time_control max_domains 0
+rconfig integer auxhist1_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist1_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist1_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist1_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist1_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist1_begin   namelist,time_control max_domains 0
+rconfig integer auxhist1_end_y namelist,time_control max_domains 0
+rconfig integer auxhist1_end_d namelist,time_control max_domains 0
+rconfig integer auxhist1_end_h namelist,time_control max_domains 0
+rconfig integer auxhist1_end_m namelist,time_control max_domains 0
+rconfig integer auxhist1_end_s namelist,time_control max_domains 0
+rconfig integer auxhist1_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist1 namelist,time_control 1 0
+rconfig integer frames_per_auxhist1 namelist,time_control max_domains 999999
+state integer auxhist2_oid         - - - - - "" "" ""
+rconfig character auxhist2_inname namelist,time_control 1 "auxhist2_d<domain>_<date>"
+rconfig character auxhist2_outname namelist,time_control 1 "auxhist2_d<domain>_<date>"
+rconfig integer auxhist2_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist2_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist2_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist2_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist2_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist2_interval   namelist,time_control max_domains 0
+rconfig integer auxhist2_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist2_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist2_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist2_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist2_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist2_begin   namelist,time_control max_domains 0
+rconfig integer auxhist2_end_y namelist,time_control max_domains 0
+rconfig integer auxhist2_end_d namelist,time_control max_domains 0
+rconfig integer auxhist2_end_h namelist,time_control max_domains 0
+rconfig integer auxhist2_end_m namelist,time_control max_domains 0
+rconfig integer auxhist2_end_s namelist,time_control max_domains 0
+rconfig integer auxhist2_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist2 namelist,time_control 1 0
+rconfig integer frames_per_auxhist2 namelist,time_control max_domains 999999
+state integer auxhist3_oid         - - - - - "" "" ""
+rconfig character auxhist3_inname namelist,time_control 1 "auxhist3_d<domain>_<date>"
+rconfig character auxhist3_outname namelist,time_control 1 "auxhist3_d<domain>_<date>"
+rconfig integer auxhist3_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist3_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist3_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist3_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist3_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist3_interval   namelist,time_control max_domains 0
+rconfig integer auxhist3_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist3_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist3_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist3_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist3_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist3_begin   namelist,time_control max_domains 0
+rconfig integer auxhist3_end_y namelist,time_control max_domains 0
+rconfig integer auxhist3_end_d namelist,time_control max_domains 0
+rconfig integer auxhist3_end_h namelist,time_control max_domains 0
+rconfig integer auxhist3_end_m namelist,time_control max_domains 0
+rconfig integer auxhist3_end_s namelist,time_control max_domains 0
+rconfig integer auxhist3_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist3 namelist,time_control 1 0
+rconfig integer frames_per_auxhist3 namelist,time_control max_domains 999999
+state integer auxhist4_oid         - - - - - "" "" ""
+rconfig character auxhist4_inname namelist,time_control 1 "auxhist4_d<domain>_<date>"
+rconfig character auxhist4_outname namelist,time_control 1 "auxhist4_d<domain>_<date>"
+rconfig integer auxhist4_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist4_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist4_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist4_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist4_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist4_interval   namelist,time_control max_domains 0
+rconfig integer auxhist4_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist4_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist4_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist4_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist4_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist4_begin   namelist,time_control max_domains 0
+rconfig integer auxhist4_end_y namelist,time_control max_domains 0
+rconfig integer auxhist4_end_d namelist,time_control max_domains 0
+rconfig integer auxhist4_end_h namelist,time_control max_domains 0
+rconfig integer auxhist4_end_m namelist,time_control max_domains 0
+rconfig integer auxhist4_end_s namelist,time_control max_domains 0
+rconfig integer auxhist4_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist4 namelist,time_control 1 0
+rconfig integer frames_per_auxhist4 namelist,time_control max_domains 999999
+state integer auxhist5_oid         - - - - - "" "" ""
+rconfig character auxhist5_inname namelist,time_control 1 "auxhist5_d<domain>_<date>"
+rconfig character auxhist5_outname namelist,time_control 1 "auxhist5_d<domain>_<date>"
+rconfig integer auxhist5_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist5_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist5_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist5_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist5_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist5_interval   namelist,time_control max_domains 0
+rconfig integer auxhist5_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist5_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist5_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist5_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist5_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist5_begin   namelist,time_control max_domains 0
+rconfig integer auxhist5_end_y namelist,time_control max_domains 0
+rconfig integer auxhist5_end_d namelist,time_control max_domains 0
+rconfig integer auxhist5_end_h namelist,time_control max_domains 0
+rconfig integer auxhist5_end_m namelist,time_control max_domains 0
+rconfig integer auxhist5_end_s namelist,time_control max_domains 0
+rconfig integer auxhist5_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist5 namelist,time_control 1 0
+rconfig integer frames_per_auxhist5 namelist,time_control max_domains 999999
+state integer auxhist6_oid         - - - - - "" "" ""
+rconfig character auxhist6_inname namelist,time_control 1 "auxhist6_d<domain>_<date>"
+rconfig character auxhist6_outname namelist,time_control 1 "auxhist6_d<domain>_<date>"
+rconfig integer auxhist6_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist6_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist6_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist6_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist6_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist6_interval   namelist,time_control max_domains 0
+rconfig integer auxhist6_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist6_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist6_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist6_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist6_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist6_begin   namelist,time_control max_domains 0
+rconfig integer auxhist6_end_y namelist,time_control max_domains 0
+rconfig integer auxhist6_end_d namelist,time_control max_domains 0
+rconfig integer auxhist6_end_h namelist,time_control max_domains 0
+rconfig integer auxhist6_end_m namelist,time_control max_domains 0
+rconfig integer auxhist6_end_s namelist,time_control max_domains 0
+rconfig integer auxhist6_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist6 namelist,time_control 1 0
+rconfig integer frames_per_auxhist6 namelist,time_control max_domains 999999
+state integer auxhist7_oid         - - - - - "" "" ""
+rconfig character auxhist7_inname namelist,time_control 1 "auxhist7_d<domain>_<date>"
+rconfig character auxhist7_outname namelist,time_control 1 "auxhist7_d<domain>_<date>"
+rconfig integer auxhist7_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist7_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist7_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist7_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist7_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist7_interval   namelist,time_control max_domains 0
+rconfig integer auxhist7_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist7_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist7_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist7_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist7_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist7_begin   namelist,time_control max_domains 0
+rconfig integer auxhist7_end_y namelist,time_control max_domains 0
+rconfig integer auxhist7_end_d namelist,time_control max_domains 0
+rconfig integer auxhist7_end_h namelist,time_control max_domains 0
+rconfig integer auxhist7_end_m namelist,time_control max_domains 0
+rconfig integer auxhist7_end_s namelist,time_control max_domains 0
+rconfig integer auxhist7_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist7 namelist,time_control 1 0
+rconfig integer frames_per_auxhist7 namelist,time_control max_domains 999999
+state integer auxhist8_oid         - - - - - "" "" ""
+rconfig character auxhist8_inname namelist,time_control 1 "auxhist8_d<domain>_<date>"
+rconfig character auxhist8_outname namelist,time_control 1 "auxhist8_d<domain>_<date>"
+rconfig integer auxhist8_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist8_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist8_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist8_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist8_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist8_interval   namelist,time_control max_domains 0
+rconfig integer auxhist8_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist8_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist8_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist8_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist8_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist8_begin   namelist,time_control max_domains 0
+rconfig integer auxhist8_end_y namelist,time_control max_domains 0
+rconfig integer auxhist8_end_d namelist,time_control max_domains 0
+rconfig integer auxhist8_end_h namelist,time_control max_domains 0
+rconfig integer auxhist8_end_m namelist,time_control max_domains 0
+rconfig integer auxhist8_end_s namelist,time_control max_domains 0
+rconfig integer auxhist8_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist8 namelist,time_control 1 0
+rconfig integer frames_per_auxhist8 namelist,time_control max_domains 999999
+state integer auxhist9_oid         - - - - - "" "" ""
+rconfig character auxhist9_inname namelist,time_control 1 "auxhist9_d<domain>_<date>"
+rconfig character auxhist9_outname namelist,time_control 1 "auxhist9_d<domain>_<date>"
+rconfig integer auxhist9_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist9_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist9_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist9_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist9_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist9_interval   namelist,time_control max_domains 0
+rconfig integer auxhist9_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist9_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist9_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist9_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist9_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist9_begin   namelist,time_control max_domains 0
+rconfig integer auxhist9_end_y namelist,time_control max_domains 0
+rconfig integer auxhist9_end_d namelist,time_control max_domains 0
+rconfig integer auxhist9_end_h namelist,time_control max_domains 0
+rconfig integer auxhist9_end_m namelist,time_control max_domains 0
+rconfig integer auxhist9_end_s namelist,time_control max_domains 0
+rconfig integer auxhist9_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist9 namelist,time_control 1 0
+rconfig integer frames_per_auxhist9 namelist,time_control max_domains 999999
+state integer auxhist10_oid         - - - - - "" "" ""
+rconfig character auxhist10_inname namelist,time_control 1 "auxhist10_d<domain>_<date>"
+rconfig character auxhist10_outname namelist,time_control 1 "auxhist10_d<domain>_<date>"
+rconfig integer auxhist10_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist10_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist10_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist10_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist10_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist10_interval   namelist,time_control max_domains 0
+rconfig integer auxhist10_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist10_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist10_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist10_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist10_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist10_begin   namelist,time_control max_domains 0
+rconfig integer auxhist10_end_y namelist,time_control max_domains 0
+rconfig integer auxhist10_end_d namelist,time_control max_domains 0
+rconfig integer auxhist10_end_h namelist,time_control max_domains 0
+rconfig integer auxhist10_end_m namelist,time_control max_domains 0
+rconfig integer auxhist10_end_s namelist,time_control max_domains 0
+rconfig integer auxhist10_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist10 namelist,time_control 1 0
+rconfig integer frames_per_auxhist10 namelist,time_control max_domains 999999
+state integer auxhist11_oid         - - - - - "" "" ""
+rconfig character auxhist11_inname namelist,time_control 1 "auxhist11_d<domain>_<date>"
+rconfig character auxhist11_outname namelist,time_control 1 "auxhist11_d<domain>_<date>"
+rconfig integer auxhist11_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist11_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist11_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist11_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist11_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist11_interval   namelist,time_control max_domains 0
+rconfig integer auxhist11_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist11_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist11_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist11_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist11_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist11_begin   namelist,time_control max_domains 0
+rconfig integer auxhist11_end_y namelist,time_control max_domains 0
+rconfig integer auxhist11_end_d namelist,time_control max_domains 0
+rconfig integer auxhist11_end_h namelist,time_control max_domains 0
+rconfig integer auxhist11_end_m namelist,time_control max_domains 0
+rconfig integer auxhist11_end_s namelist,time_control max_domains 0
+rconfig integer auxhist11_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist11 namelist,time_control 1 0
+rconfig integer frames_per_auxhist11 namelist,time_control max_domains 999999
+state integer auxhist12_oid         - - - - - "" "" ""
+rconfig character auxhist12_inname namelist,time_control 1 "auxhist12_d<domain>_<date>"
+rconfig character auxhist12_outname namelist,time_control 1 "auxhist12_d<domain>_<date>"
+rconfig integer auxhist12_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist12_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist12_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist12_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist12_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist12_interval   namelist,time_control max_domains 0
+rconfig integer auxhist12_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist12_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist12_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist12_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist12_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist12_begin   namelist,time_control max_domains 0
+rconfig integer auxhist12_end_y namelist,time_control max_domains 0
+rconfig integer auxhist12_end_d namelist,time_control max_domains 0
+rconfig integer auxhist12_end_h namelist,time_control max_domains 0
+rconfig integer auxhist12_end_m namelist,time_control max_domains 0
+rconfig integer auxhist12_end_s namelist,time_control max_domains 0
+rconfig integer auxhist12_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist12 namelist,time_control 1 0
+rconfig integer frames_per_auxhist12 namelist,time_control max_domains 999999
+state integer auxhist13_oid         - - - - - "" "" ""
+rconfig character auxhist13_inname namelist,time_control 1 "auxhist13_d<domain>_<date>"
+rconfig character auxhist13_outname namelist,time_control 1 "auxhist13_d<domain>_<date>"
+rconfig integer auxhist13_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist13_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist13_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist13_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist13_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist13_interval   namelist,time_control max_domains 0
+rconfig integer auxhist13_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist13_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist13_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist13_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist13_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist13_begin   namelist,time_control max_domains 0
+rconfig integer auxhist13_end_y namelist,time_control max_domains 0
+rconfig integer auxhist13_end_d namelist,time_control max_domains 0
+rconfig integer auxhist13_end_h namelist,time_control max_domains 0
+rconfig integer auxhist13_end_m namelist,time_control max_domains 0
+rconfig integer auxhist13_end_s namelist,time_control max_domains 0
+rconfig integer auxhist13_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist13 namelist,time_control 1 0
+rconfig integer frames_per_auxhist13 namelist,time_control max_domains 999999
+state integer auxhist14_oid         - - - - - "" "" ""
+rconfig character auxhist14_inname namelist,time_control 1 "auxhist14_d<domain>_<date>"
+rconfig character auxhist14_outname namelist,time_control 1 "auxhist14_d<domain>_<date>"
+rconfig integer auxhist14_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist14_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist14_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist14_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist14_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist14_interval   namelist,time_control max_domains 0
+rconfig integer auxhist14_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist14_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist14_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist14_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist14_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist14_begin   namelist,time_control max_domains 0
+rconfig integer auxhist14_end_y namelist,time_control max_domains 0
+rconfig integer auxhist14_end_d namelist,time_control max_domains 0
+rconfig integer auxhist14_end_h namelist,time_control max_domains 0
+rconfig integer auxhist14_end_m namelist,time_control max_domains 0
+rconfig integer auxhist14_end_s namelist,time_control max_domains 0
+rconfig integer auxhist14_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist14 namelist,time_control 1 0
+rconfig integer frames_per_auxhist14 namelist,time_control max_domains 999999
+state integer auxhist15_oid         - - - - - "" "" ""
+rconfig character auxhist15_inname namelist,time_control 1 "auxhist15_d<domain>_<date>"
+rconfig character auxhist15_outname namelist,time_control 1 "auxhist15_d<domain>_<date>"
+rconfig integer auxhist15_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist15_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist15_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist15_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist15_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist15_interval   namelist,time_control max_domains 0
+rconfig integer auxhist15_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist15_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist15_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist15_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist15_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist15_begin   namelist,time_control max_domains 0
+rconfig integer auxhist15_end_y namelist,time_control max_domains 0
+rconfig integer auxhist15_end_d namelist,time_control max_domains 0
+rconfig integer auxhist15_end_h namelist,time_control max_domains 0
+rconfig integer auxhist15_end_m namelist,time_control max_domains 0
+rconfig integer auxhist15_end_s namelist,time_control max_domains 0
+rconfig integer auxhist15_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist15 namelist,time_control 1 0
+rconfig integer frames_per_auxhist15 namelist,time_control max_domains 999999
+state integer auxhist16_oid         - - - - - "" "" ""
+rconfig character auxhist16_inname namelist,time_control 1 "auxhist16_d<domain>_<date>"
+rconfig character auxhist16_outname namelist,time_control 1 "auxhist16_d<domain>_<date>"
+rconfig integer auxhist16_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist16_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist16_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist16_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist16_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist16_interval   namelist,time_control max_domains 0
+rconfig integer auxhist16_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist16_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist16_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist16_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist16_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist16_begin   namelist,time_control max_domains 0
+rconfig integer auxhist16_end_y namelist,time_control max_domains 0
+rconfig integer auxhist16_end_d namelist,time_control max_domains 0
+rconfig integer auxhist16_end_h namelist,time_control max_domains 0
+rconfig integer auxhist16_end_m namelist,time_control max_domains 0
+rconfig integer auxhist16_end_s namelist,time_control max_domains 0
+rconfig integer auxhist16_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist16 namelist,time_control 1 0
+rconfig integer frames_per_auxhist16 namelist,time_control max_domains 999999
+state integer auxhist17_oid         - - - - - "" "" ""
+rconfig character auxhist17_inname namelist,time_control 1 "auxhist17_d<domain>_<date>"
+rconfig character auxhist17_outname namelist,time_control 1 "auxhist17_d<domain>_<date>"
+rconfig integer auxhist17_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist17_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist17_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist17_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist17_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist17_interval   namelist,time_control max_domains 0
+rconfig integer auxhist17_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist17_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist17_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist17_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist17_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist17_begin   namelist,time_control max_domains 0
+rconfig integer auxhist17_end_y namelist,time_control max_domains 0
+rconfig integer auxhist17_end_d namelist,time_control max_domains 0
+rconfig integer auxhist17_end_h namelist,time_control max_domains 0
+rconfig integer auxhist17_end_m namelist,time_control max_domains 0
+rconfig integer auxhist17_end_s namelist,time_control max_domains 0
+rconfig integer auxhist17_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist17 namelist,time_control 1 0
+rconfig integer frames_per_auxhist17 namelist,time_control max_domains 999999
+state integer auxhist18_oid         - - - - - "" "" ""
+rconfig character auxhist18_inname namelist,time_control 1 "auxhist18_d<domain>_<date>"
+rconfig character auxhist18_outname namelist,time_control 1 "auxhist18_d<domain>_<date>"
+rconfig integer auxhist18_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist18_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist18_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist18_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist18_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist18_interval   namelist,time_control max_domains 0
+rconfig integer auxhist18_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist18_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist18_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist18_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist18_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist18_begin   namelist,time_control max_domains 0
+rconfig integer auxhist18_end_y namelist,time_control max_domains 0
+rconfig integer auxhist18_end_d namelist,time_control max_domains 0
+rconfig integer auxhist18_end_h namelist,time_control max_domains 0
+rconfig integer auxhist18_end_m namelist,time_control max_domains 0
+rconfig integer auxhist18_end_s namelist,time_control max_domains 0
+rconfig integer auxhist18_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist18 namelist,time_control 1 0
+rconfig integer frames_per_auxhist18 namelist,time_control max_domains 999999
+state integer auxhist19_oid         - - - - - "" "" ""
+rconfig character auxhist19_inname namelist,time_control 1 "auxhist19_d<domain>_<date>"
+rconfig character auxhist19_outname namelist,time_control 1 "auxhist19_d<domain>_<date>"
+rconfig integer auxhist19_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist19_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist19_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist19_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist19_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist19_interval   namelist,time_control max_domains 0
+rconfig integer auxhist19_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist19_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist19_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist19_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist19_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist19_begin   namelist,time_control max_domains 0
+rconfig integer auxhist19_end_y namelist,time_control max_domains 0
+rconfig integer auxhist19_end_d namelist,time_control max_domains 0
+rconfig integer auxhist19_end_h namelist,time_control max_domains 0
+rconfig integer auxhist19_end_m namelist,time_control max_domains 0
+rconfig integer auxhist19_end_s namelist,time_control max_domains 0
+rconfig integer auxhist19_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist19 namelist,time_control 1 0
+rconfig integer frames_per_auxhist19 namelist,time_control max_domains 999999
+state integer auxhist20_oid         - - - - - "" "" ""
+rconfig character auxhist20_inname namelist,time_control 1 "auxhist20_d<domain>_<date>"
+rconfig character auxhist20_outname namelist,time_control 1 "auxhist20_d<domain>_<date>"
+rconfig integer auxhist20_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist20_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist20_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist20_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist20_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist20_interval   namelist,time_control max_domains 0
+rconfig integer auxhist20_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist20_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist20_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist20_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist20_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist20_begin   namelist,time_control max_domains 0
+rconfig integer auxhist20_end_y namelist,time_control max_domains 0
+rconfig integer auxhist20_end_d namelist,time_control max_domains 0
+rconfig integer auxhist20_end_h namelist,time_control max_domains 0
+rconfig integer auxhist20_end_m namelist,time_control max_domains 0
+rconfig integer auxhist20_end_s namelist,time_control max_domains 0
+rconfig integer auxhist20_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist20 namelist,time_control 1 0
+rconfig integer frames_per_auxhist20 namelist,time_control max_domains 999999
+state integer auxhist21_oid         - - - - - "" "" ""
+rconfig character auxhist21_inname namelist,time_control 1 "auxhist21_d<domain>_<date>"
+rconfig character auxhist21_outname namelist,time_control 1 "auxhist21_d<domain>_<date>"
+rconfig integer auxhist21_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist21_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist21_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist21_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist21_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist21_interval   namelist,time_control max_domains 0
+rconfig integer auxhist21_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist21_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist21_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist21_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist21_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist21_begin   namelist,time_control max_domains 0
+rconfig integer auxhist21_end_y namelist,time_control max_domains 0
+rconfig integer auxhist21_end_d namelist,time_control max_domains 0
+rconfig integer auxhist21_end_h namelist,time_control max_domains 0
+rconfig integer auxhist21_end_m namelist,time_control max_domains 0
+rconfig integer auxhist21_end_s namelist,time_control max_domains 0
+rconfig integer auxhist21_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist21 namelist,time_control 1 0
+rconfig integer frames_per_auxhist21 namelist,time_control max_domains 999999
+state integer auxhist22_oid         - - - - - "" "" ""
+rconfig character auxhist22_inname namelist,time_control 1 "auxhist22_d<domain>_<date>"
+rconfig character auxhist22_outname namelist,time_control 1 "auxhist22_d<domain>_<date>"
+rconfig integer auxhist22_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist22_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist22_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist22_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist22_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist22_interval   namelist,time_control max_domains 0
+rconfig integer auxhist22_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist22_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist22_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist22_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist22_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist22_begin   namelist,time_control max_domains 0
+rconfig integer auxhist22_end_y namelist,time_control max_domains 0
+rconfig integer auxhist22_end_d namelist,time_control max_domains 0
+rconfig integer auxhist22_end_h namelist,time_control max_domains 0
+rconfig integer auxhist22_end_m namelist,time_control max_domains 0
+rconfig integer auxhist22_end_s namelist,time_control max_domains 0
+rconfig integer auxhist22_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist22 namelist,time_control 1 0
+rconfig integer frames_per_auxhist22 namelist,time_control max_domains 999999
+state integer auxhist23_oid         - - - - - "" "" ""
+rconfig character auxhist23_inname namelist,time_control 1 "auxhist23_d<domain>_<date>"
+rconfig character auxhist23_outname namelist,time_control 1 "auxhist23_d<domain>_<date>"
+rconfig integer auxhist23_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist23_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist23_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist23_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist23_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist23_interval   namelist,time_control max_domains 0
+rconfig integer auxhist23_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist23_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist23_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist23_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist23_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist23_begin   namelist,time_control max_domains 0
+rconfig integer auxhist23_end_y namelist,time_control max_domains 0
+rconfig integer auxhist23_end_d namelist,time_control max_domains 0
+rconfig integer auxhist23_end_h namelist,time_control max_domains 0
+rconfig integer auxhist23_end_m namelist,time_control max_domains 0
+rconfig integer auxhist23_end_s namelist,time_control max_domains 0
+rconfig integer auxhist23_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist23 namelist,time_control 1 0
+rconfig integer frames_per_auxhist23 namelist,time_control max_domains 999999
+state integer auxhist24_oid         - - - - - "" "" ""
+rconfig character auxhist24_inname namelist,time_control 1 "auxhist24_d<domain>_<date>"
+rconfig character auxhist24_outname namelist,time_control 1 "auxhist24_d<domain>_<date>"
+rconfig integer auxhist24_interval_y namelist,time_control max_domains 0
+rconfig integer auxhist24_interval_d namelist,time_control max_domains 0
+rconfig integer auxhist24_interval_h namelist,time_control max_domains 0
+rconfig integer auxhist24_interval_m namelist,time_control max_domains 0
+rconfig integer auxhist24_interval_s namelist,time_control max_domains 0
+rconfig integer auxhist24_interval   namelist,time_control max_domains 0
+rconfig integer auxhist24_begin_y namelist,time_control max_domains 0
+rconfig integer auxhist24_begin_d namelist,time_control max_domains 0
+rconfig integer auxhist24_begin_h namelist,time_control max_domains 0
+rconfig integer auxhist24_begin_m namelist,time_control max_domains 0
+rconfig integer auxhist24_begin_s namelist,time_control max_domains 0
+rconfig integer auxhist24_begin   namelist,time_control max_domains 0
+rconfig integer auxhist24_end_y namelist,time_control max_domains 0
+rconfig integer auxhist24_end_d namelist,time_control max_domains 0
+rconfig integer auxhist24_end_h namelist,time_control max_domains 0
+rconfig integer auxhist24_end_m namelist,time_control max_domains 0
+rconfig integer auxhist24_end_s namelist,time_control max_domains 0
+rconfig integer auxhist24_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxhist24 namelist,time_control 1 0
+rconfig integer frames_per_auxhist24 namelist,time_control max_domains 999999
+state integer auxinput1_oid         - - - - - "" "" ""
+rconfig character auxinput1_inname namelist,time_control 1 "auxinput1_d<domain>_<date>"
+rconfig character auxinput1_outname namelist,time_control 1 "auxinput1_d<domain>_<date>"
+rconfig integer auxinput1_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput1_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput1_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput1_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput1_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput1_interval   namelist,time_control max_domains 0
+rconfig integer auxinput1_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput1_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput1_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput1_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput1_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput1_begin   namelist,time_control max_domains 0
+rconfig integer auxinput1_end_y namelist,time_control max_domains 0
+rconfig integer auxinput1_end_d namelist,time_control max_domains 0
+rconfig integer auxinput1_end_h namelist,time_control max_domains 0
+rconfig integer auxinput1_end_m namelist,time_control max_domains 0
+rconfig integer auxinput1_end_s namelist,time_control max_domains 0
+rconfig integer auxinput1_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput1 namelist,time_control 1 0
+rconfig integer frames_per_auxinput1 namelist,time_control max_domains 999999
+state integer auxinput2_oid         - - - - - "" "" ""
+rconfig character auxinput2_inname namelist,time_control 1 "auxinput2_d<domain>_<date>"
+rconfig character auxinput2_outname namelist,time_control 1 "auxinput2_d<domain>_<date>"
+rconfig integer auxinput2_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput2_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput2_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput2_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput2_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput2_interval   namelist,time_control max_domains 0
+rconfig integer auxinput2_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput2_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput2_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput2_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput2_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput2_begin   namelist,time_control max_domains 0
+rconfig integer auxinput2_end_y namelist,time_control max_domains 0
+rconfig integer auxinput2_end_d namelist,time_control max_domains 0
+rconfig integer auxinput2_end_h namelist,time_control max_domains 0
+rconfig integer auxinput2_end_m namelist,time_control max_domains 0
+rconfig integer auxinput2_end_s namelist,time_control max_domains 0
+rconfig integer auxinput2_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput2 namelist,time_control 1 0
+rconfig integer frames_per_auxinput2 namelist,time_control max_domains 999999
+state integer auxinput3_oid         - - - - - "" "" ""
+rconfig character auxinput3_inname namelist,time_control 1 "auxinput3_d<domain>_<date>"
+rconfig character auxinput3_outname namelist,time_control 1 "auxinput3_d<domain>_<date>"
+rconfig integer auxinput3_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput3_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput3_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput3_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput3_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput3_interval   namelist,time_control max_domains 0
+rconfig integer auxinput3_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput3_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput3_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput3_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput3_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput3_begin   namelist,time_control max_domains 0
+rconfig integer auxinput3_end_y namelist,time_control max_domains 0
+rconfig integer auxinput3_end_d namelist,time_control max_domains 0
+rconfig integer auxinput3_end_h namelist,time_control max_domains 0
+rconfig integer auxinput3_end_m namelist,time_control max_domains 0
+rconfig integer auxinput3_end_s namelist,time_control max_domains 0
+rconfig integer auxinput3_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput3 namelist,time_control 1 0
+rconfig integer frames_per_auxinput3 namelist,time_control max_domains 999999
+state integer auxinput4_oid         - - - - - "" "" ""
+rconfig character auxinput4_inname namelist,time_control 1 "auxinput4_d<domain>_<date>"
+rconfig character auxinput4_outname namelist,time_control 1 "auxinput4_d<domain>_<date>"
+rconfig integer auxinput4_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput4_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput4_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput4_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput4_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput4_interval   namelist,time_control max_domains 0
+rconfig integer auxinput4_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput4_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput4_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput4_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput4_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput4_begin   namelist,time_control max_domains 0
+rconfig integer auxinput4_end_y namelist,time_control max_domains 0
+rconfig integer auxinput4_end_d namelist,time_control max_domains 0
+rconfig integer auxinput4_end_h namelist,time_control max_domains 0
+rconfig integer auxinput4_end_m namelist,time_control max_domains 0
+rconfig integer auxinput4_end_s namelist,time_control max_domains 0
+rconfig integer auxinput4_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput4 namelist,time_control 1 0
+rconfig integer frames_per_auxinput4 namelist,time_control max_domains 999999
+state integer auxinput5_oid         - - - - - "" "" ""
+rconfig character auxinput5_inname namelist,time_control 1 "auxinput5_d<domain>_<date>"
+rconfig character auxinput5_outname namelist,time_control 1 "auxinput5_d<domain>_<date>"
+rconfig integer auxinput5_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput5_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput5_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput5_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput5_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput5_interval   namelist,time_control max_domains 0
+rconfig integer auxinput5_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput5_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput5_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput5_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput5_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput5_begin   namelist,time_control max_domains 0
+rconfig integer auxinput5_end_y namelist,time_control max_domains 0
+rconfig integer auxinput5_end_d namelist,time_control max_domains 0
+rconfig integer auxinput5_end_h namelist,time_control max_domains 0
+rconfig integer auxinput5_end_m namelist,time_control max_domains 0
+rconfig integer auxinput5_end_s namelist,time_control max_domains 0
+rconfig integer auxinput5_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput5 namelist,time_control 1 0
+rconfig integer frames_per_auxinput5 namelist,time_control max_domains 999999
+state integer auxinput6_oid         - - - - - "" "" ""
+rconfig character auxinput6_inname namelist,time_control 1 "auxinput6_d<domain>_<date>"
+rconfig character auxinput6_outname namelist,time_control 1 "auxinput6_d<domain>_<date>"
+rconfig integer auxinput6_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput6_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput6_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput6_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput6_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput6_interval   namelist,time_control max_domains 0
+rconfig integer auxinput6_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput6_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput6_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput6_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput6_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput6_begin   namelist,time_control max_domains 0
+rconfig integer auxinput6_end_y namelist,time_control max_domains 0
+rconfig integer auxinput6_end_d namelist,time_control max_domains 0
+rconfig integer auxinput6_end_h namelist,time_control max_domains 0
+rconfig integer auxinput6_end_m namelist,time_control max_domains 0
+rconfig integer auxinput6_end_s namelist,time_control max_domains 0
+rconfig integer auxinput6_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput6 namelist,time_control 1 0
+rconfig integer frames_per_auxinput6 namelist,time_control max_domains 999999
+state integer auxinput7_oid         - - - - - "" "" ""
+rconfig character auxinput7_inname namelist,time_control 1 "auxinput7_d<domain>_<date>"
+rconfig character auxinput7_outname namelist,time_control 1 "auxinput7_d<domain>_<date>"
+rconfig integer auxinput7_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput7_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput7_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput7_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput7_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput7_interval   namelist,time_control max_domains 0
+rconfig integer auxinput7_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput7_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput7_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput7_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput7_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput7_begin   namelist,time_control max_domains 0
+rconfig integer auxinput7_end_y namelist,time_control max_domains 0
+rconfig integer auxinput7_end_d namelist,time_control max_domains 0
+rconfig integer auxinput7_end_h namelist,time_control max_domains 0
+rconfig integer auxinput7_end_m namelist,time_control max_domains 0
+rconfig integer auxinput7_end_s namelist,time_control max_domains 0
+rconfig integer auxinput7_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput7 namelist,time_control 1 0
+rconfig integer frames_per_auxinput7 namelist,time_control max_domains 999999
+state integer auxinput8_oid         - - - - - "" "" ""
+rconfig character auxinput8_inname namelist,time_control 1 "auxinput8_d<domain>_<date>"
+rconfig character auxinput8_outname namelist,time_control 1 "auxinput8_d<domain>_<date>"
+rconfig integer auxinput8_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput8_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput8_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput8_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput8_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput8_interval   namelist,time_control max_domains 0
+rconfig integer auxinput8_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput8_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput8_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput8_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput8_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput8_begin   namelist,time_control max_domains 0
+rconfig integer auxinput8_end_y namelist,time_control max_domains 0
+rconfig integer auxinput8_end_d namelist,time_control max_domains 0
+rconfig integer auxinput8_end_h namelist,time_control max_domains 0
+rconfig integer auxinput8_end_m namelist,time_control max_domains 0
+rconfig integer auxinput8_end_s namelist,time_control max_domains 0
+rconfig integer auxinput8_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput8 namelist,time_control 1 0
+rconfig integer frames_per_auxinput8 namelist,time_control max_domains 999999
+state integer auxinput9_oid         - - - - - "" "" ""
+rconfig character auxinput9_inname namelist,time_control 1 "auxinput9_d<domain>_<date>"
+rconfig character auxinput9_outname namelist,time_control 1 "auxinput9_d<domain>_<date>"
+rconfig integer auxinput9_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput9_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput9_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput9_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput9_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput9_interval   namelist,time_control max_domains 0
+rconfig integer auxinput9_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput9_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput9_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput9_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput9_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput9_begin   namelist,time_control max_domains 0
+rconfig integer auxinput9_end_y namelist,time_control max_domains 0
+rconfig integer auxinput9_end_d namelist,time_control max_domains 0
+rconfig integer auxinput9_end_h namelist,time_control max_domains 0
+rconfig integer auxinput9_end_m namelist,time_control max_domains 0
+rconfig integer auxinput9_end_s namelist,time_control max_domains 0
+rconfig integer auxinput9_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput9 namelist,time_control 1 0
+rconfig integer frames_per_auxinput9 namelist,time_control max_domains 999999
+state integer auxinput10_oid         - - - - - "" "" ""
+rconfig character auxinput10_inname namelist,time_control 1 "auxinput10_d<domain>_<date>"
+rconfig character auxinput10_outname namelist,time_control 1 "auxinput10_d<domain>_<date>"
+rconfig integer auxinput10_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput10_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput10_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput10_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput10_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput10_interval   namelist,time_control max_domains 0
+rconfig integer auxinput10_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput10_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput10_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput10_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput10_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput10_begin   namelist,time_control max_domains 0
+rconfig integer auxinput10_end_y namelist,time_control max_domains 0
+rconfig integer auxinput10_end_d namelist,time_control max_domains 0
+rconfig integer auxinput10_end_h namelist,time_control max_domains 0
+rconfig integer auxinput10_end_m namelist,time_control max_domains 0
+rconfig integer auxinput10_end_s namelist,time_control max_domains 0
+rconfig integer auxinput10_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput10 namelist,time_control 1 0
+rconfig integer frames_per_auxinput10 namelist,time_control max_domains 999999
+state integer auxinput11_oid         - - - - - "" "" ""
+rconfig character auxinput11_inname namelist,time_control 1 "auxinput11_d<domain>_<date>"
+rconfig character auxinput11_outname namelist,time_control 1 "auxinput11_d<domain>_<date>"
+rconfig integer auxinput11_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput11_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput11_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput11_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput11_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput11_interval   namelist,time_control max_domains 0
+rconfig integer auxinput11_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput11_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput11_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput11_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput11_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput11_begin   namelist,time_control max_domains 0
+rconfig integer auxinput11_end_y namelist,time_control max_domains 0
+rconfig integer auxinput11_end_d namelist,time_control max_domains 0
+rconfig integer auxinput11_end_h namelist,time_control max_domains 0
+rconfig integer auxinput11_end_m namelist,time_control max_domains 0
+rconfig integer auxinput11_end_s namelist,time_control max_domains 0
+rconfig integer auxinput11_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput11 namelist,time_control 1 0
+rconfig integer frames_per_auxinput11 namelist,time_control max_domains 999999
+state integer auxinput12_oid         - - - - - "" "" ""
+rconfig character auxinput12_inname namelist,time_control 1 "auxinput12_d<domain>_<date>"
+rconfig character auxinput12_outname namelist,time_control 1 "auxinput12_d<domain>_<date>"
+rconfig integer auxinput12_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput12_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput12_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput12_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput12_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput12_interval   namelist,time_control max_domains 0
+rconfig integer auxinput12_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput12_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput12_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput12_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput12_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput12_begin   namelist,time_control max_domains 0
+rconfig integer auxinput12_end_y namelist,time_control max_domains 0
+rconfig integer auxinput12_end_d namelist,time_control max_domains 0
+rconfig integer auxinput12_end_h namelist,time_control max_domains 0
+rconfig integer auxinput12_end_m namelist,time_control max_domains 0
+rconfig integer auxinput12_end_s namelist,time_control max_domains 0
+rconfig integer auxinput12_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput12 namelist,time_control 1 0
+rconfig integer frames_per_auxinput12 namelist,time_control max_domains 999999
+state integer auxinput13_oid         - - - - - "" "" ""
+rconfig character auxinput13_inname namelist,time_control 1 "auxinput13_d<domain>_<date>"
+rconfig character auxinput13_outname namelist,time_control 1 "auxinput13_d<domain>_<date>"
+rconfig integer auxinput13_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput13_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput13_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput13_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput13_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput13_interval   namelist,time_control max_domains 0
+rconfig integer auxinput13_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput13_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput13_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput13_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput13_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput13_begin   namelist,time_control max_domains 0
+rconfig integer auxinput13_end_y namelist,time_control max_domains 0
+rconfig integer auxinput13_end_d namelist,time_control max_domains 0
+rconfig integer auxinput13_end_h namelist,time_control max_domains 0
+rconfig integer auxinput13_end_m namelist,time_control max_domains 0
+rconfig integer auxinput13_end_s namelist,time_control max_domains 0
+rconfig integer auxinput13_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput13 namelist,time_control 1 0
+rconfig integer frames_per_auxinput13 namelist,time_control max_domains 999999
+state integer auxinput14_oid         - - - - - "" "" ""
+rconfig character auxinput14_inname namelist,time_control 1 "auxinput14_d<domain>_<date>"
+rconfig character auxinput14_outname namelist,time_control 1 "auxinput14_d<domain>_<date>"
+rconfig integer auxinput14_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput14_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput14_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput14_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput14_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput14_interval   namelist,time_control max_domains 0
+rconfig integer auxinput14_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput14_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput14_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput14_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput14_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput14_begin   namelist,time_control max_domains 0
+rconfig integer auxinput14_end_y namelist,time_control max_domains 0
+rconfig integer auxinput14_end_d namelist,time_control max_domains 0
+rconfig integer auxinput14_end_h namelist,time_control max_domains 0
+rconfig integer auxinput14_end_m namelist,time_control max_domains 0
+rconfig integer auxinput14_end_s namelist,time_control max_domains 0
+rconfig integer auxinput14_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput14 namelist,time_control 1 0
+rconfig integer frames_per_auxinput14 namelist,time_control max_domains 999999
+state integer auxinput15_oid         - - - - - "" "" ""
+rconfig character auxinput15_inname namelist,time_control 1 "auxinput15_d<domain>_<date>"
+rconfig character auxinput15_outname namelist,time_control 1 "auxinput15_d<domain>_<date>"
+rconfig integer auxinput15_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput15_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput15_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput15_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput15_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput15_interval   namelist,time_control max_domains 0
+rconfig integer auxinput15_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput15_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput15_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput15_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput15_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput15_begin   namelist,time_control max_domains 0
+rconfig integer auxinput15_end_y namelist,time_control max_domains 0
+rconfig integer auxinput15_end_d namelist,time_control max_domains 0
+rconfig integer auxinput15_end_h namelist,time_control max_domains 0
+rconfig integer auxinput15_end_m namelist,time_control max_domains 0
+rconfig integer auxinput15_end_s namelist,time_control max_domains 0
+rconfig integer auxinput15_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput15 namelist,time_control 1 0
+rconfig integer frames_per_auxinput15 namelist,time_control max_domains 999999
+state integer auxinput16_oid         - - - - - "" "" ""
+rconfig character auxinput16_inname namelist,time_control 1 "auxinput16_d<domain>_<date>"
+rconfig character auxinput16_outname namelist,time_control 1 "auxinput16_d<domain>_<date>"
+rconfig integer auxinput16_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput16_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput16_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput16_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput16_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput16_interval   namelist,time_control max_domains 0
+rconfig integer auxinput16_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput16_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput16_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput16_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput16_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput16_begin   namelist,time_control max_domains 0
+rconfig integer auxinput16_end_y namelist,time_control max_domains 0
+rconfig integer auxinput16_end_d namelist,time_control max_domains 0
+rconfig integer auxinput16_end_h namelist,time_control max_domains 0
+rconfig integer auxinput16_end_m namelist,time_control max_domains 0
+rconfig integer auxinput16_end_s namelist,time_control max_domains 0
+rconfig integer auxinput16_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput16 namelist,time_control 1 0
+rconfig integer frames_per_auxinput16 namelist,time_control max_domains 999999
+state integer auxinput17_oid         - - - - - "" "" ""
+rconfig character auxinput17_inname namelist,time_control 1 "auxinput17_d<domain>_<date>"
+rconfig character auxinput17_outname namelist,time_control 1 "auxinput17_d<domain>_<date>"
+rconfig integer auxinput17_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput17_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput17_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput17_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput17_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput17_interval   namelist,time_control max_domains 0
+rconfig integer auxinput17_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput17_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput17_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput17_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput17_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput17_begin   namelist,time_control max_domains 0
+rconfig integer auxinput17_end_y namelist,time_control max_domains 0
+rconfig integer auxinput17_end_d namelist,time_control max_domains 0
+rconfig integer auxinput17_end_h namelist,time_control max_domains 0
+rconfig integer auxinput17_end_m namelist,time_control max_domains 0
+rconfig integer auxinput17_end_s namelist,time_control max_domains 0
+rconfig integer auxinput17_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput17 namelist,time_control 1 0
+rconfig integer frames_per_auxinput17 namelist,time_control max_domains 999999
+state integer auxinput18_oid         - - - - - "" "" ""
+rconfig character auxinput18_inname namelist,time_control 1 "auxinput18_d<domain>_<date>"
+rconfig character auxinput18_outname namelist,time_control 1 "auxinput18_d<domain>_<date>"
+rconfig integer auxinput18_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput18_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput18_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput18_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput18_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput18_interval   namelist,time_control max_domains 0
+rconfig integer auxinput18_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput18_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput18_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput18_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput18_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput18_begin   namelist,time_control max_domains 0
+rconfig integer auxinput18_end_y namelist,time_control max_domains 0
+rconfig integer auxinput18_end_d namelist,time_control max_domains 0
+rconfig integer auxinput18_end_h namelist,time_control max_domains 0
+rconfig integer auxinput18_end_m namelist,time_control max_domains 0
+rconfig integer auxinput18_end_s namelist,time_control max_domains 0
+rconfig integer auxinput18_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput18 namelist,time_control 1 0
+rconfig integer frames_per_auxinput18 namelist,time_control max_domains 999999
+state integer auxinput19_oid         - - - - - "" "" ""
+rconfig character auxinput19_inname namelist,time_control 1 "auxinput19_d<domain>_<date>"
+rconfig character auxinput19_outname namelist,time_control 1 "auxinput19_d<domain>_<date>"
+rconfig integer auxinput19_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput19_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput19_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput19_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput19_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput19_interval   namelist,time_control max_domains 0
+rconfig integer auxinput19_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput19_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput19_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput19_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput19_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput19_begin   namelist,time_control max_domains 0
+rconfig integer auxinput19_end_y namelist,time_control max_domains 0
+rconfig integer auxinput19_end_d namelist,time_control max_domains 0
+rconfig integer auxinput19_end_h namelist,time_control max_domains 0
+rconfig integer auxinput19_end_m namelist,time_control max_domains 0
+rconfig integer auxinput19_end_s namelist,time_control max_domains 0
+rconfig integer auxinput19_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput19 namelist,time_control 1 0
+rconfig integer frames_per_auxinput19 namelist,time_control max_domains 999999
+state integer auxinput20_oid         - - - - - "" "" ""
+rconfig character auxinput20_inname namelist,time_control 1 "auxinput20_d<domain>_<date>"
+rconfig character auxinput20_outname namelist,time_control 1 "auxinput20_d<domain>_<date>"
+rconfig integer auxinput20_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput20_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput20_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput20_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput20_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput20_interval   namelist,time_control max_domains 0
+rconfig integer auxinput20_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput20_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput20_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput20_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput20_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput20_begin   namelist,time_control max_domains 0
+rconfig integer auxinput20_end_y namelist,time_control max_domains 0
+rconfig integer auxinput20_end_d namelist,time_control max_domains 0
+rconfig integer auxinput20_end_h namelist,time_control max_domains 0
+rconfig integer auxinput20_end_m namelist,time_control max_domains 0
+rconfig integer auxinput20_end_s namelist,time_control max_domains 0
+rconfig integer auxinput20_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput20 namelist,time_control 1 0
+rconfig integer frames_per_auxinput20 namelist,time_control max_domains 999999
+state integer auxinput21_oid         - - - - - "" "" ""
+rconfig character auxinput21_inname namelist,time_control 1 "auxinput21_d<domain>_<date>"
+rconfig character auxinput21_outname namelist,time_control 1 "auxinput21_d<domain>_<date>"
+rconfig integer auxinput21_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput21_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput21_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput21_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput21_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput21_interval   namelist,time_control max_domains 0
+rconfig integer auxinput21_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput21_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput21_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput21_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput21_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput21_begin   namelist,time_control max_domains 0
+rconfig integer auxinput21_end_y namelist,time_control max_domains 0
+rconfig integer auxinput21_end_d namelist,time_control max_domains 0
+rconfig integer auxinput21_end_h namelist,time_control max_domains 0
+rconfig integer auxinput21_end_m namelist,time_control max_domains 0
+rconfig integer auxinput21_end_s namelist,time_control max_domains 0
+rconfig integer auxinput21_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput21 namelist,time_control 1 0
+rconfig integer frames_per_auxinput21 namelist,time_control max_domains 999999
+state integer auxinput22_oid         - - - - - "" "" ""
+rconfig character auxinput22_inname namelist,time_control 1 "auxinput22_d<domain>_<date>"
+rconfig character auxinput22_outname namelist,time_control 1 "auxinput22_d<domain>_<date>"
+rconfig integer auxinput22_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput22_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput22_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput22_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput22_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput22_interval   namelist,time_control max_domains 0
+rconfig integer auxinput22_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput22_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput22_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput22_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput22_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput22_begin   namelist,time_control max_domains 0
+rconfig integer auxinput22_end_y namelist,time_control max_domains 0
+rconfig integer auxinput22_end_d namelist,time_control max_domains 0
+rconfig integer auxinput22_end_h namelist,time_control max_domains 0
+rconfig integer auxinput22_end_m namelist,time_control max_domains 0
+rconfig integer auxinput22_end_s namelist,time_control max_domains 0
+rconfig integer auxinput22_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput22 namelist,time_control 1 0
+rconfig integer frames_per_auxinput22 namelist,time_control max_domains 999999
+state integer auxinput23_oid         - - - - - "" "" ""
+rconfig character auxinput23_inname namelist,time_control 1 "auxinput23_d<domain>_<date>"
+rconfig character auxinput23_outname namelist,time_control 1 "auxinput23_d<domain>_<date>"
+rconfig integer auxinput23_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput23_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput23_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput23_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput23_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput23_interval   namelist,time_control max_domains 0
+rconfig integer auxinput23_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput23_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput23_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput23_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput23_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput23_begin   namelist,time_control max_domains 0
+rconfig integer auxinput23_end_y namelist,time_control max_domains 0
+rconfig integer auxinput23_end_d namelist,time_control max_domains 0
+rconfig integer auxinput23_end_h namelist,time_control max_domains 0
+rconfig integer auxinput23_end_m namelist,time_control max_domains 0
+rconfig integer auxinput23_end_s namelist,time_control max_domains 0
+rconfig integer auxinput23_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput23 namelist,time_control 1 0
+rconfig integer frames_per_auxinput23 namelist,time_control max_domains 999999
+state integer auxinput24_oid         - - - - - "" "" ""
+rconfig character auxinput24_inname namelist,time_control 1 "auxinput24_d<domain>_<date>"
+rconfig character auxinput24_outname namelist,time_control 1 "auxinput24_d<domain>_<date>"
+rconfig integer auxinput24_interval_y namelist,time_control max_domains 0
+rconfig integer auxinput24_interval_d namelist,time_control max_domains 0
+rconfig integer auxinput24_interval_h namelist,time_control max_domains 0
+rconfig integer auxinput24_interval_m namelist,time_control max_domains 0
+rconfig integer auxinput24_interval_s namelist,time_control max_domains 0
+rconfig integer auxinput24_interval   namelist,time_control max_domains 0
+rconfig integer auxinput24_begin_y namelist,time_control max_domains 0
+rconfig integer auxinput24_begin_d namelist,time_control max_domains 0
+rconfig integer auxinput24_begin_h namelist,time_control max_domains 0
+rconfig integer auxinput24_begin_m namelist,time_control max_domains 0
+rconfig integer auxinput24_begin_s namelist,time_control max_domains 0
+rconfig integer auxinput24_begin   namelist,time_control max_domains 0
+rconfig integer auxinput24_end_y namelist,time_control max_domains 0
+rconfig integer auxinput24_end_d namelist,time_control max_domains 0
+rconfig integer auxinput24_end_h namelist,time_control max_domains 0
+rconfig integer auxinput24_end_m namelist,time_control max_domains 0
+rconfig integer auxinput24_end_s namelist,time_control max_domains 0
+rconfig integer auxinput24_end   namelist,time_control max_domains 0
+rconfig integer io_form_auxinput24 namelist,time_control 1 0
+rconfig integer frames_per_auxinput24 namelist,time_control max_domains 999999
+!ENDOFREGISTRYGENERATEDINCLUDE
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/registry.avgflx
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/registry.avgflx	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/registry.avgflx	(revision 17)
@@ -0,0 +1,25 @@
+state    real   avgflx_rum     ikj     dyn_em      1         X      rh      "avgflx_rum"        "hist-time-averaged mu-coupled u"   "Pa m s-1"
+state    real   avgflx_rvm     ikj     dyn_em      1         Y      rh       "avgflx_rvm"        "hist-time-averaged mu-coupled v"   "Pa m s-1"
+state    real   avgflx_wwm     ikj     dyn_em      1         Z      rh        "avgflx_wwm"   "hist-time-averaged mu-coupled eta-dot"          "Pa s-1"
+state    integer   avgflx_count    -      dyn_em      -         -       r     "avgflx_count"    "Counter for time-averaged mu-coupled velocities"  ""
+state    real  avgflx_cfu1     ikj      misc        1         Z     rh        "CFU1"                  "AVERAGE updraft mass flux from GD-scheme"         "kg m-2 s-1"
+state    real  avgflx_cfd1     ikj      misc        1         Z     rh        "CFD1"                  "AVERAGE downdraft mass flux from GD-scheme"         "kg m-2 s-1"
+state    real  avgflx_dfu1     ikj      misc        1         -     rh        "DFU1"                  "AVERAGE detrainment from updraft from GD-scheme"         "kg m-2 s-1"
+state    real  avgflx_efu1     ikj      misc        1         -     rh        "EFU1"                  "AVERAGE entrainment into updraft  from GD-scheme"         "kg m-2 s-1"
+state    real  avgflx_dfd1     ikj      misc        1         -     rh        "DFD1"                  "AVERAGE detrainment from downdraft from GD-scheme"         "kg m-2 s-1"
+state    real  avgflx_efd1     ikj      misc        1         -     rh        "EFD1"                  "AVERAGE entrainment into downdraft  from GD-scheme"         "kg m-2 s-1"
+state    real  cfu1            ikj      misc        1         Z      -        ""                  "instantaneous updraft mass flux from GD-scheme"         "kg m-2 s-1"
+state    real  cfd1            ikj      misc        1         Z      -        ""                  "instantaneous downdraft mass flux from GD-scheme"         "kg m-2 s-1"
+state    real  dfu1            ikj      misc        1         -      -        ""                  "instantaneous detrainment from updraft from GD-scheme"         "kg m-2 s-1"
+state    real  efu1            ikj      misc        1         -      -        ""                  "instantaneous entrainment into updraft  from GD-scheme"         "kg m-2 s-1"
+state    real  dfd1            ikj      misc        1         -      -        ""                  "instantaneous detrainment from downdraft from GD-scheme"         "kg m-2 s-1"
+state    real  efd1            ikj      misc        1         -      -        ""                  "instantaneous entrainment into downdraft  from GD-scheme"         "kg m-2 s-1"
+rconfig   integer do_avgflx_em            namelist,dynamics     max_domains     0     irh  "do_avgflx_em"     "activate output ofhist-time-averaged mu-coupled winds"   ""
+rconfig   integer do_avgflx_cugd          namelist,dynamics     max_domains     0     irh  "do_avgflx_cugd"   "activate output of hist-time-averaged cugd fluxes"   ""
+# Is the following line really needed?
+package   noavgflxem     do_avgflx_em==0             -             -
+package   avgflxem       do_avgflx_em==1             -             state:avgflx_rum,avgflx_rvm,avgflx_wwm
+# Is the following line really needed?
+package   noavgflxcugd   do_avgflx_cugd==0           -             -
+package   avgflxcugd     do_avgflx_cugd==1           -             state:avgflx_cfu1,avgflx_cfd1,avgflx_dfu1,avgflx_efu1,avgflx_dfd1,avgflx_efd1,cfu1,cfd1,dfu1,efu1,dfd1,efd1
+
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/registry.cam
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/registry.cam	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/registry.cam	(revision 17)
@@ -0,0 +1,146 @@
+# CAMUW PBL Variables
+state    real   tauresx2d      ij      misc        1         -      r        "tauresx2d"            "X-COMP OF RESIDUAL STRESS"                 "m2 s-2"
+state    real   tauresy2d      ij      misc        1         -      r        "tauresy2d"            "Y-COMP OF RESIDUAL STRESS"                 "m2 s-2"
+state    real   tpert2d        ij      misc        1         -      r        "tpert2d"              "Convective temperature excess "            "K"
+state    real   qpert2d        ij      misc        1         -      r        "qpert2d"              "Convective humidity excess "               "kg/kg"
+state    real   wpert2d        ij      misc        1         -      r        "wpert2d"              "Turbulent velocity excess "                "m/s"
+
+# CAM Zhang-McFarlane variables
+state  real   rliq     ij     misc      1    -   r     "RLIQ"         "vertically-integrated reserved cloud condensate"                 "m s-1"
+state  real   dlf      ikj    misc      1    -   -     "DLF"          "detraining cloud water tendency from convection"                 "~?"
+state  real   precz    ij     misc      1    -   h     "PRECZ"        "total precipitation from ZM convection"                          "m s-1"
+state  real   zmdt     ikj    misc      1    -   h     "ZMDT"         "temp. tendency - Zhang-McFarlane moist convection"               "K s-1"
+state  real   zmdq     ikj    misc      1    -   h     "ZMDQ"         "specific humidity tendency - Zhang-McFarlane moist convection"   "kg kg_wet-1 s-1"
+state  real   zmdice   ikj    misc      1    -   h     "ZMDICE"       "cloud ice tendency - Zhang-McFarlane moist convection"           "kg kg_wet-1 s-1"
+state  real   zmdliq   ikj    misc      1    -   h     "ZMDLIQ"       "cloud liquid tendency - Zhang-McFarlane moist convection"        "kg kg_wet-1 s-1"
+state  real   evaptzm  ikj    misc      1    -   h     "EVAPTZM"      "T tendency - evaporation/snow prod from Zhang convection"        "K s-1"
+state  real   fzsntzm  ikj    misc      1    -   h     "FZSNTZM"      "T tendency - rain to snow conversion from Zhang convection"      "K s-1"
+state  real   evsntzm  ikj    misc      1    -   h     "EVSNTZM"      "T tendency - snow to rain prod from Zhang convection"            "K s-1"
+state  real   evapqzm  ikj    misc      1    -   h     "EVAPQZM"      "Q tendency - evaporation from Zhang-McFarlane moist convection"  "kg kg_wet-1 s-1"
+state  real   zmflxprc ikj    misc      1    Z   h     "ZMFLXPRC"     "flux of precipitation from ZM convection"                        "kg m-2 s-1"
+state  real   zmflxsnw ikj    misc      1    Z   h     "ZMFLXSNW"     "flux of snow from ZM convection"                                 "kg m-2 s-1"
+state  real   zmntprpd ikj    misc      1    -   h     "ZMNTPRPD"     "net precipitation production from ZM convection"                 "kg kg_wet-1 s-1"
+state  real   zmntsnpd ikj    misc      1    -   h     "ZMNTSNPD"     "net snow production from ZM convection"                          "kg kg_wet-1 s-1"
+state  real   zmeiheat ikj    misc      1    -   h     "ZMEIHEAT"     "heating by ice and evaporation in ZM convection"                 "W kg-1"
+state  real   cmfmcdzm ikj    misc      1    Z   h     "CMFMCDZM"     "convection mass flux from ZM deep"                               "kg m-2 s-1"
+state  real   preccdzm ij     misc      1    -   h     "preccdzm"     "convection precipitation rate from ZM deep"                      "m s-1"
+state  real   pconvb   ij     misc      1    -   h     "PCONVB"       "convection base pressure"                                        "Pa"
+state  real   pconvt   ij     misc      1    -   h     "PCONVT"       "convection top pressure"                                         "Pa"
+state  real   cape     ij     misc      1    -   h     "CAPE"         "convectively available potential energy"                         "J kg-1"
+state  real   zmmtu    ikj    misc      1    -   h     "ZMMTU"        "U tendency - ZM convective momentum transport"                   "m s-2"
+state  real   zmmtv    ikj    misc      1    -   h     "ZMMTV"        "V tendency - ZM convective momentum transport"                   "m s-2"
+state  real   zmmu     ikj    misc      1    -   h     "ZMMU"         "ZM convection updraft mass flux"                                 "kg m-2 s-1"
+state  real   zmmd     ikj    misc      1    -   h     "ZMMD"         "ZM convection downdraft mass flux"                               "kg m-2 s-1"
+state  real   zmupgu   ikj    misc      1    -   h     "ZMUPGU"       "zonal force from ZM updraft pressure gradient term"              "m s-2"
+state  real   zmupgd   ikj    misc      1    -   h     "ZMUPGD"       "zonal force from ZM downdraft pressure gradient term"            "m s-2"
+state  real   zmvpgu   ikj    misc      1    -   h     "ZMVPGU"       "meridional force from ZM updraft pressure gradient term"         "m s-2"
+state  real   zmvpgd   ikj    misc      1    -   h     "ZMVPGD"       "meridional force from ZM downdraft pressure gradient term"       "m s-2"
+state  real   zmicuu   ikj    misc      1    -   h     "ZMICUU"       "ZM in-cloud U updrafts"                                          "m s-1"
+state  real   zmicud   ikj    misc      1    -   h     "ZMICUD"       "ZM in-cloud U downdrafts"                                        "m s-1"
+state  real   zmicvu   ikj    misc      1    -   h     "ZMICVU"       "ZM in-cloud V updrafts"                                          "m s-1"
+state  real   zmicvd   ikj    misc      1    -   h     "ZMICVD"       "ZM in-cloud V downdrafts"                                        "m s-1"
+
+# CAM UW Shallow Convection variables
+state  real   cmfsl    ikj    misc      1    Z   rh    "CMFSL "       "moist shallow convection liquid water static energy flux"        "W m-2"
+state  real   cmflq    ikj    misc      1    Z   rh    "CMFLQ "       "moist shallow convection total water flux"                       "W m-2"
+state  real   cmfmc    ikj    misc      1    Z   rh    "CMFMC "       "updraft mass flux for shallow+deep convection"                   "~?"
+state  real   cmfmc2   ikj    misc      1    Z   rh    "CMFMC2"       "updraft mass flux for shallow convection"                        "~?"
+state  real   cldfrash ikj    misc      1    -   r     "CLDFRASH"     "shallow convective cloud fraction"                               ""
+state  real   cush     ij     misc      1    -   rh    "CUSH"         "convective scale height"                                         "~?"
+state  real   evapcsh  ikj    misc      1    -   rh    "EVAPCSH"      "evaporation of shallow Cu precipitation"                         "kg kg-1 s-1"
+state  real   icwmrsh  ikj    misc      1    -   rh    "ICWMRSH"      "shallow cumulus in-cloud water mixing ratio"                     "kg m-2"
+state  real   snowsh   ij     misc      1    -   r     "SNOWSH"       "convective snow at surface from shallow Cu"                      "m s-1"
+#state  real   rprddp   ikj    misc      1    -   r     "RPRDDP"       "dq/dt due to deep convective rainout"                            "~?"
+state  real   rprdsh   ikj    misc      1    -   rh    "RPRDSH"       "dq/dt due to deep(~?) and shallow convective rainout"            "~?"
+state  real   rliq2    ij     misc      1    -   r     "RLIQ2"        "vertically-integrated reserved cloud condensate for shallow Cu"  "m s-1"
+state  real   qtflx_cu ikj    misc      1    Z   h     "QTFLX_CU"     "cumulus qt flux"                                                 "kg m-2 s-1"
+state  real   slflx_cu ikj    misc      1    Z   h     "SLFLX_CU"     "cumulus sl flux"                                                 "J m-2 s-1"
+state  real   uflx_cu  ikj    misc      1    Z   h     "UFLX_CU"      "cumulus u flux"                                                  "kg m s-2"
+state  real   vflx_cu  ikj    misc      1    Z   h     "VFLX_CU"      "cumulus v flux"                                                  "kg m s-2"
+state  real   qtten_cu ikj    misc      1    -   h     "QTTEN_CU"     "qt tendency by cumulus convection"                               "kg kg-1 s-1"
+state  real   slten_cu ikj    misc      1    -   h     "SLTEN_CU"     "sl tendency by cumulus convection"                               "J kg-1 s-1"
+state  real   uten_cu  ikj    misc      1    -   h     "UTEN_CU"      "u tendency by cumulus convection"                                "m s-2"
+state  real   vten_cu  ikj    misc      1    -   h     "VTEN_CU"      "v tendency by cumulus convection"                                "m s-2"
+state  real   qvten_cu ikj    misc      1    -   h     "QVTEN_CU"     "qv tendency by cumulus convection"                               "kg kg-1 s-1"
+state  real   qlten_cu ikj    misc      1    -   h     "QLTEN_CU"     "ql tendency by cumulus convection"                               "kg kg-1 s-1"
+state  real   qiten_cu ikj    misc      1    -   h     "QITEN_CU"     "qi tendency by cumulus convection"                               "kg kg-1 s-1"
+state  real   cbmf_cu  ij     misc      1    -   h     "CBMF_CU"      "cumulus base mass flux"                                          "kg m-2 s-1"
+state  real ufrcinvbase_cu ij misc      1    -   h     "UFRCINVBASE_CU" "cumulus fraction at PBL top"                                   ""
+state  real ufrclcl_cu     ij misc      1    -   h     "UFRCLCL_CU"   "cumulus fraction at LCL"                                         ""
+state  real winvbase_cu    ij misc      1    -   h     "WINVBASE_CU"  "cumulus vertical velocity at PBL top"                            "m s-1"
+state  real   wlcl_cu  ij     misc      1    -   h     "WLCL_CU"      "cumulus vertical velocity at LCL"                                "m s-1"
+state  real   plcl_cu  ij     misc      1    -   h     "PLCL_CU"      "LCL of source air"                                               "Pa"
+state  real   pinv_cu  ij     misc      1    -   h     "PINV_CU"      "PBL top pressure"                                                "Pa"
+state  real   plfc_cu  ij     misc      1    -   h     "PLFC_CU"      "LFC of source air"                                               "Pa"
+state  real   pbup_cu  ij     misc      1    -   h     "PBUP_CU"      "highest level of positive Cu buoyancy"                           "Pa"
+state  real   ppen_cu  ij     misc      1    -   h     "PPEN_CU"      "highest level where Cu W is 0"                                   "Pa"
+state  real   qtsrc_cu ij     misc      1    -   h     "QTSRC_CU"     "source air qt"                                                   "kg/kg"
+state  real   thlsrc_cu    ij misc      1    -   h     "THLSRC_CU"    "source air thl"                                                  "K"
+state  real   thvlsrc_cu   ij misc      1    -   h     "THVLSRC_CU"   "source air thvl"                                                 "K"
+state  real   emkfbup_cu   ij misc      1    -   h     "EMFKBUP_CU"   "penetrative mass flux at kbup"                                   "kg m-2 s-1"
+state  real   cin_cu   ij     misc      1    -   h     "CIN_CU"       "CIN up to LFC"                                                   "J kg-1"
+state  real   cinlcl_cu    ij misc      1    -   h     "CINLCL_CU"    "CIN up to LCL"                                                   "J kg-1"
+state  real   cbmflimit_cu ij misc      1    -   h     "CBMFLIMIT_CU" "cbmf limiter"                                                    "kg m-2 s-1"
+state  real   tkeavg_cu    ij misc      1    -   h     "TKEAVG_CU"    "tkeavg_Cu"                                                       "m-2 s-2"
+state  real   zinv_cu  ij     misc      1    -   h     "ZINV_CU"      "PBL top height"                                                  "m"
+state  real   rcwp_cu  ij     misc      1    -   h     "RCWP_CU"      "cumulus LWP+IWP"                                                 "kg m-2"
+state  real   rlwp_cu  ij     misc      1    -   h     "RLWP_CU"      "cumulus LWP"                                                     "kg m-2"
+state  real   riwp_cu  ij     misc      1    -   h     "RIWP_CU"      "cumulus IWP"                                                     "kg m-2"
+state  real   tophgt_cu    ij misc      1    -   h     "TOPHGT_CU"    "cumulus top height"                                              "m"
+state  real   wu_cu    ikj    misc      1    Z   h     "WU_CU"        "cumulus updraft vertical velocity"                               "m s-1"
+state  real   ufrc_cu  ikj    misc      1    Z   h     "UFRC_CU"      "updraft factional area"                                          ""
+state  real   qtu_cu   ikj    misc      1    Z   h     "QTU_CU"       "cumulus updraft qt"                                              "kg kg-1"
+state  real   thlu_cu  ikj    misc      1    Z   h     "THLU_CU"      "cumulus updraft thl"                                             "K"
+state  real   thvu_cu  ikj    misc      1    Z   h     "THVU_CU"      "cumulus updraft thv"                                             "K"
+state  real   uu_cu    ikj    misc      1    Z   h     "UU_CU"        "cumulus updraft uwnd"                                            "m s-1"
+state  real   vu_cu    ikj    misc      1    Z   h     "VU_CU"        "cumulus updraft vwnd"                                            "m s-1"
+state  real   qtu_emf_cu  ikj misc      1    Z   h     "QTU_EMF_CU"   "qt of penatratively entrained air"                               "kg kg-1"
+state  real   thlu_emf_cu ikj misc      1    Z   h     "THLU_EMF_CU"  "thl of penatratively entrained air"                              "K"
+state  real   uu_emf_cu   ikj misc      1    Z   h     "UU_EMF_CU"    "uwnd of penatratively entrained air"                             "m s-1"
+state  real   vu_emf_cu   ikj misc      1    Z   h     "VU_EMF_CU"    "vwnd of penatratively entrained air"                             "m s-1"
+state  real   umf_cu   ikj    misc      1    Z   h     "UMF_CU"       "cumulus updraft mass flux"                                       "kg m-2 s-1"
+state  real   uemf_cu  ikj    misc      1    Z   h     "UMEF_CU"      "cumulus net mass flux"                                           "kg m-2 s-1"
+state  real   qcu_cu   ikj    misc      1    -   h     "QCU_CU"       "cumulus updraft LWC+IWC"                                         "kg kg-1"
+state  real   qlu_cu   ikj    misc      1    -   h     "QLU_CU"       "cumulus updraft LWC"                                             "kg kg-1"
+state  real   qiu_cu   ikj    misc      1    -   h     "QIU_CU"       "cumulus updraft IWC"                                             "kg kg-1"
+state  real   cufrc_cu ikj    misc      1    -   h     "CUFRC_CU"     "cumulus cloud fraction"                                          ""
+state  real   fer_cu   ikj    misc      1    -   h     "FER_CU"       "cumulus lateral fractional entrainment rate"                     "m-1"
+state  real   fdr_cu   ikj    misc      1    -   h     "FDR_CU"       "cumulus lateral fractional detrainment rate"                     "m-1"
+state  real   dwten_cu ikj    misc      1    -   h     "DWTEN_CU"     "expellsion rate of cumulus cloud water to env."                  "kg kg-1 s-1"
+state  real   diten_cu ikj    misc      1    -   h     "DITEN_CU"     "expellsion rate of cumulus ice water to env."                    "kg kg-1 s-1"
+state  real   qrten_cu ikj    misc      1    -   h     "QRTEN_CU"     "production rate of rain by cumulus"                              "kg kg-1 s-1"
+state  real   qsten_cu ikj    misc      1    -   h     "QSTEN_CU"     "production rate of snow by cumulus"                              "kg kg-1 s-1"
+state  real   flxrain_cu  ikj misc      1    -   h     "FLXRAIN_CU"   "rain flux induced by cumulus"                                    "kg m-2 s-1"
+state  real   flxsnow_cu  ikj misc      1    -   h     "FLXSNOW_CU"   "snow flux induced by cumulus"                                    "kg m-2 s-1"
+state  real   ntraprd_cu  ikj misc      1    -   h     "NTRAPRD_CU"   "net production rate of rain by cumulus"                          "kg kg-1 s-1"
+state  real   ntsnprd_cu  ikj misc      1    -   h     "NTSNPRD_CU"   "net production rate of snow by cumulus"                          "kg kg-1 s-1"
+state  real   excessu_cu  ikj misc      1    -   h     "EXCESSU_CU"   "updraft saturation excess"                                       ""
+state  real   excessu0_cu ikj misc      1    -   h     "EXCESSU0_CU"  "environmental saturation excess"                                 ""
+state  real   xc_cu    ikj    misc      1    -   h     "XC_CU"        "critical mixing ratio"                                           ""
+state  real   aquad_cu ikj    misc      1    -   h     "AQUAD_CU"     "aquad"                                                           ""
+state  real   bquad_cu ikj    misc      1    -   h     "BQUAD_CU"     "bquad"                                                           ""
+state  real   cquad_cu ikj    misc      1    -   h     "CQUAD_CU"     "cquad"                                                           ""
+state  real   bogbot_cu   ikj misc      1    -   h     "BOGBOT_CU"    "cloud buoyancy at the bottom interface"                          ""
+state  real   bogtop_cu   ikj misc      1    -   h     "BOGTOP_CU"    "cloud buoyancy at the top interface"                             ""
+state  real exit_uwcu_cu   ij misc      1    -   h     "EXIT_UWCU_CU" "exit_UWCu_cu"                                                    ""
+state  real exit_conden_cu ij misc      1    -   h     "EXIT_CONDEN_CU"  "exit_conden_cu"                                               ""
+state  real exit_klclmkx_cu ij misc     1    -   h     "EXIT_KLCLMKX_CU" "exit_klclmkx_cu"                                              ""
+state  real exit_klfcmkx_cu ij misc     1    -   h     "EXIT_KLFCMKX_CU" "exit_klfcmkx_cu"                                              ""
+state  real exit_ufrc_cu   ij misc      1    -   h     "EXIT_UFRC_CU" "exit_ufrc_cu"                                                    ""
+state  real exit_wtw_cu    ij misc      1    -   h     "EXIT_WTW_CU"  "exit_wtw_cu"                                                     ""
+state  real exit_drycore_cu ij misc     1    -   h     "EXIT_DRYCORE_CU" "exit_drycore_cu"                                              ""
+state  real exit_wu_cu     ij misc      1    -   h     "EXIT_WU_CU"   "exit_wu_cu"                                                      ""
+state  real exit_cufliter_cu ij misc    1    -   h     "EXIT_CUFILTER_CU" "exit_cufilter_cu"                                            ""
+state  real exit_kinv1_cu  ij misc      1    -   h     "EXIT_KINV1_CU" "exit_kinv1_cu"                                                  ""
+state  real exit_rei_cu    ij misc      1    -   h     "EXIT_REI_CU"   "exit_rei_cu"                                                    ""
+state  real limit_shcu_cu  ij misc      1    -   h     "LIMIT_SHCU_CU" "limit_shcu_cu"                                                  ""
+state  real limit_negcon_cu ij misc     1    -   h     "LIMIT_NEGCON_CU" "limit_negcon_cu"                                              ""
+state  real limit_ufrc_cu  ij misc      1    -   h     "LIMIT_UFRC_CU" "limit_ufrc_cu"                                                  ""
+state  real limit_ppen_cu  ij misc      1    -   h     "LIMIT_PPEN_CU" "limit_ppen_cu"                                                  ""
+state  real limit_emf_cu   ij misc      1    -   h     "LIMIT_EMF_CU"  "limit_emf_cu"                                                   ""
+state  real limit_cinlcl_cu ij misc     1    -   h     "LIMIT_CINLCL_CU" "limit_cinlcl_cu"                                              ""
+state  real limit_cin_cu   ij misc      1    -   h     "LIMIT_CIN_CU"  "limit_cin_cu"                                                   ""
+state  real limit_cbmf_cu  ij misc      1    -   h     "LIMIT_CBMF_CU" "limit_cbmf_cu"                                                  ""
+state  real limit_rei_cu   ij misc      1    -   h     "LIMIT_REI_CU"  "limit_rei_cu"                                                   ""
+state  real ind_delcin_cu  ij misc      1    -   h     "IND_DELCIN_CU" "ind_delcin_cu"                                                  ""
+
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/registry.chem
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/registry.chem	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/registry.chem	(revision 17)
@@ -0,0 +1,2354 @@
+
+# Chemistry Variables  (all shared at this point)
+#-----------------------------------------------------------------------------------------------------------------------------------------------------------------
+rconfig   character  auxinput12_inname   namelist,time_control            1  "wrf_chem_input"   -     "name of auxinput12 infile" ""      ""
+rconfig   integer     io_form_auxinput12   namelist,time_control         1              2
+
+#
+# Timing variables for chemistry
+#
+state   integer ktauc                    -  misc    -         -      r       "ktauc"                 "Number of chemistry time steps"               ""
+state   integer last_chem_time_year      -  misc    -         -      r       "last_chem_time_year"   "last call to chem mechanism through restarts" "4-digit year"
+state   integer last_chem_time_month     -  misc    -         -      r       "last_chem_time_month"  "last call to chem mechanism through restarts" "2-digit month"
+state   integer last_chem_time_day       -  misc    -         -      r       "last_chem_time_day"    "last call to chem mechanism through restarts" "2-digit day"
+state   integer last_chem_time_hour      -  misc    -         -      r       "last_chem_time_hour"   "last call to chem mechanism through restarts" "2-digit hour"
+state   integer last_chem_time_minute    -  misc    -         -      r       "last_chem_time_minute" "last call to chem mechanism through restarts" "2-digit minute"
+state   integer last_chem_time_second    -  misc    -         -      r       "last_chem_time_second" "last call to chem mechanism through restarts" "2-digit second"
+#
+# Emissions variables
+#
+state   integer emissframes      -          -          -         -      -       "emissframes"           ""         ""
+state   integer fireemissframes  -        -          -        -        -      "fireemissframes"       ""         ""
+state   real     -            i+jf     emis_ant     -         -      -       -                     "Anthropogenic Emissions"         ""
+state    real  e_iso          i+jf     emis_ant     1         Z      i5r    "E_ISO"               "Isoprene EMISSIONS (Anth. for RADM/RACM, Anth+Bio for CBMZ)"  "mol km^-2 hr^-1"
+state    real  e_so2          i+jf     emis_ant     1         Z      i5r    "E_SO2"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_no           i+jf     emis_ant     1         Z      i5r     "E_NO"                "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_co           i+jf     emis_ant     1         Z      i5rh     "E_CO"                "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_eth          i+jf     emis_ant     1         Z      i5r     "E_ETH"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_hc3          i+jf     emis_ant     1         Z      i5r     "E_HC3"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_hc5          i+jf     emis_ant     1         Z      i5r     "E_HC5"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_hc8          i+jf     emis_ant     1         Z      i5r     "E_HC8"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_xyl          i+jf     emis_ant     1         Z      i5r     "E_XYL"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_ol2          i+jf     emis_ant     1         Z      i5r     "E_OL2"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_olt          i+jf     emis_ant     1         Z      i5r     "E_OLT"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_oli          i+jf     emis_ant     1         Z      i5r     "E_OLI"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_tol          i+jf     emis_ant     1         Z      i5r     "E_TOL"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_csl          i+jf     emis_ant     1         Z      i5r     "E_CSL"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_hcho         i+jf     emis_ant     1         Z      i5r     "E_HCHO"              "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_ald          i+jf     emis_ant     1         Z      i5r     "E_ALD"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_ket          i+jf     emis_ant     1         Z      i5r     "E_KET"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_ora2         i+jf     emis_ant     1         Z      i5r     "E_ORA2"              "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_nh3          i+jf     emis_ant     1         Z      i5r     "E_NH3"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_pm_25        i+jf     emis_ant     1         Z      i5r     "E_PM_25"              "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_pm_10        i+jf     emis_ant     1         Z      i5r     "E_PM_10"              "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  e_pm25i        i+jf     emis_ant     1         Z      i5r     "E_PM25I"             "EMISSION RATE OF UNIDEN. PM2.5 MASS"  "ug/m3 m/s"
+state    real  e_pm25j        i+jf     emis_ant     1         Z      i5r     "E_PM25J"             "EMISSION RATE OF J-MODE UNIDEN. PM2.5 MASS"   "ug/m3 m/s"
+state    real  e_eci          i+jf     emis_ant     1         Z      i5r     "E_ECI"               "EMISSION RATE OF I-MODE EC"          "ug/m3 m/s"
+state    real  e_ecj          i+jf     emis_ant     1         Z      i5r     "E_ECJ"               "EMISSION RATE OF J-MODE EC"          "ug/m3 m/s"
+state    real  e_naai          i+jf     emis_ant     1         Z      i5r     "E_NAAI"               "EMISSION RATE OF I-MODE EC"          "ug/m3 m/s"
+state    real  e_naaj          i+jf     emis_ant     1         Z      i5r     "E_NAAJ"               "EMISSION RATE OF J-MODE EC"          "ug/m3 m/s"
+state    real  e_orgi         i+jf     emis_ant     1         Z      i5r     "E_ORGI"              "EMISSION RATE OF I-MODE ORG. AER."   "ug/m3 m/s"
+state    real  e_orgj         i+jf     emis_ant     1         Z      i5r     "E_ORGJ"              "EMISSION RATE OF J-MODE ORG. AER."   "ug/m3 m/s"
+state    real  e_so4i         i+jf     emis_ant     1         Z      i5r     "E_SO4I"              "EMISSION RATE OF I-MODE ORG. AER."   "ug/m3 m/s"
+state    real  e_so4j         i+jf     emis_ant     1         Z      i5r     "E_SO4J"              "EMISSION RATE OF J-MODE ORG. AER."   "ug/m3 m/s"
+state    real  e_no3i         i+jf     emis_ant     1         Z      i5r     "E_NO3I"              "EMISSION RATE OF I-MODE ORG. AER."   "ug/m3 m/s"
+state    real  e_no3j         i+jf     emis_ant     1         Z      i5r     "E_NO3J"              "EMISSION RATE OF J-MODE ORG. AER."   "ug/m3 m/s"
+# Additional MOZART emission variables...
+state    real  e_bigalk       i+jf     emis_ant     1         Z      i5h    "E_BIGALK"     "EMISSIONS BIGALK"            "mol km^-2 hr^-1"
+state    real  e_bigene       i+jf     emis_ant     1         Z      i5h    "E_BIGENE"     "EMISSIONS BIGENE"            "mol km^-2 hr^-1"
+state    real  e_c2h4         i+jf     emis_ant     1         Z      i5h    "E_C2H4"       "EMISSIONS C2H4"              "mol km^-2 hr^-1"
+state    real  e_c2h6         i+jf     emis_ant     1         Z      i5h    "E_C2H6"       "EMISSIONS C2H6"              "mol km^-2 hr^-1"
+state    real  e_c3h6         i+jf     emis_ant     1         Z      i5h    "E_C3H6"       "EMISSIONS C3H6"              "mol km^-2 hr^-1"
+state    real  e_c3h8         i+jf     emis_ant     1         Z      i5h    "E_C3H8"       "EMISSIONS C3H8"              "mol km^-2 hr^-1"
+state    real  e_ch2o         i+jf     emis_ant     1         Z      i5h    "E_CH2O"       "EMISSIONS CH2O"              "mol km^-2 hr^-1"
+state    real  e_ch3cho       i+jf     emis_ant     1         Z      i5h    "E_CH3CHO"     "EMISSIONS CH3CHO"            "mol km^-2 hr^-1"
+state    real  e_ch3coch3     i+jf     emis_ant     1         Z      i5h    "E_CH3COCH3"   "EMISSIONS CH3COCH3"          "mol km^-2 hr^-1"
+state    real  e_mek          i+jf     emis_ant     1         Z      i5h    "E_MEK"        "EMISSIONS MEK"               "mol km^-2 hr^-1"
+state    real  e_toluene      i+jf     emis_ant     1         Z      i5h    "E_TOLUENE"    "EMISSIONS TOLUENE"           "mol km^-2 hr^-1"
+state    real  e_isop         i+jf     emis_ant     1         Z      i5h    "E_ISOP"       "EMISSIONS ISOP"              "mol km^-2 hr^-1"
+state    real  e_c10h16       i+jf     emis_ant     1         Z      i5h    "E_C10H16"     "EMISSIONS C10H16"            "mol km^-2 hr^-1"
+
+# Additional CBMZ and MOSAIC emission variables...
+state    real  e_no2          i+jf     emis_ant     1         Z      i5     "E_NO2"                "EMISSIONS NO2"                 "mol km^-2 hr^-1"
+state    real  e_ch3oh        i+jf     emis_ant     1         Z      i5     "E_CH3OH"              "EMISSIONS CH3OH"               "mol km^-2 hr^-1"
+state    real  e_c2h5oh       i+jf     emis_ant     1         Z      i5     "E_C2H5OH"             "EMISSIONS C2H5OH"              "mol km^-2 hr^-1"
+state    real  e_so4c         i+jf     emis_ant     1         Z      i5     "E_SO4C"               "EMISSIONS COARSE SO4 AER"      "ug/m3 m/s"
+state    real  e_no3c         i+jf     emis_ant     1         Z      i5     "E_NO3C"               "EMISSIONS COARSE NO3 AER"      "ug/m3 m/s"
+state    real  e_orgc         i+jf     emis_ant     1         Z      i5     "E_ORGC"               "EMISSIONS COARSE ORG AER"      "ug/m3 m/s"
+state    real  e_ecc          i+jf     emis_ant     1         Z      i5     "E_ECC"                "EMISSIONS COARSE EC AER"       "ug/m3 m/s"
+state    real  e_orgi_a          i+jf     emis_ant     1         Z      i5     "E_ORGI_A"                "EMISSIONS ORGI_A AER"       "ug/m3 m/s"
+state    real  e_orgj_a          i+jf     emis_ant     1         Z      i5     "E_ORGJ_A"                "EMISSIONS ORGJ_A AER"       "ug/m3 m/s"
+state    real  e_orgi_bb          i+jf     emis_ant     1         Z      i5     "E_ORGI_BB"                "EMISSIONS ORGI_BB AER"       "ug/m3 m/s"
+state    real  e_orgj_bb          i+jf     emis_ant     1         Z      i5     "E_ORGJ_BB"                "EMISSIONS ORGJ_BB AER"       "ug/m3 m/s"
+
+# GOCART
+state    real  e_bc          i+jf     emis_ant     1         Z      i5     "E_BC"                "EMISSIONS BC AER"       "ug/m3 m/s"
+state    real  e_oc          i+jf     emis_ant     1         Z      i5     "E_OC"                "EMISSIONS BC AER"       "ug/m3 m/s"
+state    real  e_sulf          i+jf     emis_ant     1         Z      i5     "E_sulf"                "EMISSIONS NO2"                 "mol km^-2 hr^-1"
+# volcanic ash emissions
+state    real  e_vash1          i+jf     emis_ant     1         Z      i5h    "E_VASH1"                "EMISSIONS VOLCANIC ASH BIN 1"                 "ug/m3 m/s"
+state    real  e_vash2          i+jf     emis_ant     1         Z      i5     "E_VASH2"                "EMISSIONS VOLCANIC ASH BIN 2"                 "ug/m3 m/s"
+state    real  e_vash3          i+jf     emis_ant     1         Z      i5     "E_VASH3"                "EMISSIONS VOLCANIC ASH BIN 3"                 "ug/m3 m/s"
+state    real  e_vash4          i+jf     emis_ant     1         Z      i5     "E_VASH4"                "EMISSIONS VOLCANIC ASH BIN 4"                 "ug/m3 m/s"
+state    real  e_vash5          i+jf     emis_ant     1         Z      i5     "E_VASH5"                "EMISSIONS VOLCANIC ASH BIN 5"                 "ug/m3 m/s"
+state    real  e_vash6          i+jf     emis_ant     1         Z      i5     "E_VASH6"                "EMISSIONS VOLCANIC ASH BIN 6"                 "ug/m3 m/s"
+state    real  e_vash7          i+jf     emis_ant     1         Z      i5     "E_VASH7"                "EMISSIONS VOLCANIC ASH BIN 7"                 "ug/m3 m/s"
+state    real  e_vash8          i+jf     emis_ant     1         Z      i5     "E_VASH8"                "EMISSIONS VOLCANIC ASH BIN 8"                 "ug/m3 m/s"
+state    real  e_vash9          i+jf     emis_ant     1         Z      i5     "E_VASH9"                "EMISSIONS VOLCANIC ASH BIN 9"                 "ug/m3 m/s"
+state    real  e_vash10         i+jf     emis_ant     1         Z      i5     "E_VASH10"               "EMISSIONS VOLCANIC ASH BIN 10"                 "ug/m3 m/s"
+
+#SAPRCNOV additional emissions, automatically created using diff_mechEmiss_wrfRegistry.m script (pablo-saide@uiowa.edu)
+state   real    e_c2h2          i+jf    emis_ant        1       Z       i5      "E_C2H2"        "C2H2 emissions"        "mol km^-2 hr^-1"
+state   real    e_alk3          i+jf    emis_ant        1       Z       i5      "E_ALK3"        "ALK3 emissions"        "mol km^-2 hr^-1"
+state   real    e_alk4          i+jf    emis_ant        1       Z       i5      "E_ALK4"        "ALK4 emissions"        "mol km^-2 hr^-1"
+state   real    e_alk5          i+jf    emis_ant        1       Z       i5      "E_ALK5"        "ALK5 emissions"        "mol km^-2 hr^-1"
+state   real    e_ethene        i+jf    emis_ant        1       Z       i5      "E_ETHENE"      "ETHENE emissions"      "mol km^-2 hr^-1"
+state   real    e_ole1          i+jf    emis_ant        1       Z       i5      "E_OLE1"        "OLE1 emissions"        "mol km^-2 hr^-1"
+state   real    e_ole2          i+jf    emis_ant        1       Z       i5      "E_OLE2"        "OLE2 emissions"        "mol km^-2 hr^-1"
+state   real    e_aro1          i+jf    emis_ant        1       Z       i5      "E_ARO1"        "ARO1 emissions"        "mol km^-2 hr^-1"
+state   real    e_aro2          i+jf    emis_ant        1       Z       i5      "E_ARO2"        "ARO2 emissions"        "mol km^-2 hr^-1"
+state   real    e_ccho          i+jf    emis_ant        1       Z       i5      "E_CCHO"        "CCHO emissions"        "mol km^-2 hr^-1"
+state   real    e_rcho          i+jf    emis_ant        1       Z       i5      "E_RCHO"        "RCHO emissions"        "mol km^-2 hr^-1"
+state   real    e_acet          i+jf    emis_ant        1       Z       i5      "E_ACET"        "ACET emissions"        "mol km^-2 hr^-1"
+state   real    e_isoprene      i+jf    emis_ant        1       Z       i5      "E_ISOPRENE"    "ISOPRENE emissions"    "mol km^-2 hr^-1"
+state   real    e_terp          i+jf    emis_ant        1       Z       i5      "E_TERP"        "TERP emissions"        "mol km^-2 hr^-1"
+state   real    e_sesq          i+jf    emis_ant        1       Z       i5      "E_SESQ"        "SESQUITERPENE emissions"        "mol km^-2 hr^-1"
+state   real    e_phen          i+jf    emis_ant        1       Z       i5      "E_PHEN"        "PHEN emissions"        "mol km^-2 hr^-1"
+state   real    e_cres          i+jf    emis_ant        1       Z       i5      "E_CRES"        "CRES emissions"        "mol km^-2 hr^-1"
+state   real    e_meoh          i+jf    emis_ant        1       Z       i5      "E_MEOH"        "MEOH emissions"        "mol km^-2 hr^-1"
+state   real    e_gly           i+jf    emis_ant        1       Z       i5      "E_GLY" "GLY emissions" "mol km^-2 hr^-1"
+state   real    e_mgly          i+jf    emis_ant        1       Z       i5      "E_MGLY"        "MGLY emissions"        "mol km^-2 hr^-1"
+state   real    e_bacl          i+jf    emis_ant        1       Z       i5      "E_BACL"        "BACL emissions"        "mol km^-2 hr^-1"
+state   real    e_isoprod       i+jf    emis_ant        1       Z       i5      "E_ISOPROD"     "ISOPROD emissions"     "mol km^-2 hr^-1"
+state   real    e_methacro      i+jf    emis_ant        1       Z       i5      "E_METHACRO"    "METHACRO emissions"    "mol km^-2 hr^-1"
+state   real    e_mvk           i+jf    emis_ant        1       Z       i5      "E_MVK" "MVK emissions" "mol km^-2 hr^-1"
+state   real    e_prod2         i+jf    emis_ant        1       Z       i5      "E_PROD2"       "PROD2 emissions"       "mol km^-2 hr^-1"
+state   real    e_ch4           i+jf    emis_ant        1       Z       i5      "E_CH4" "CH4 emissions" "mol km^-2 hr^-1"
+state   real    e_bald          i+jf    emis_ant        1       Z       i5      "E_BALD"        "BALD emissions"        "mol km^-2 hr^-1"
+state   real    e_hcooh         i+jf    emis_ant        1       Z       i5      "E_HCOOH"       "HCOOH emissions"       "mol km^-2 hr^-1"
+state   real    e_cco_oh        i+jf    emis_ant        1       Z       i5      "E_CCO_OH"      "CCO_OH emissions"      "mol km^-2 hr^-1"
+state   real    e_rco_oh        i+jf    emis_ant        1       Z       i5      "E_RCO_OH"      "RCO_OH emissions"      "mol km^-2 hr^-1"
+
+
+# dust and seas emission arrays
+state   real     -          i{dust}jf      emis_dust      -        -        -         -                    "Dust Emissions"         ""
+state    real  edust1       i{dust}jf      emis_dust      1         Z      -     "EDUST1"         "DUST emissions bin1"  ""
+state    real  edust2       i{dust}jf      emis_dust      1         Z      -     "EDUST2"         "DUST emissions bin2"  ""
+state    real  edust3       i{dust}jf      emis_dust      1         Z      -     "EDUST3"         "DUST emissions bin3"  ""
+state    real  edust4       i{dust}jf      emis_dust      1         Z      -     "EDUST4"         "DUST emissions bin4"  ""
+state    real  edust5       i{dust}jf      emis_dust      1         Z      -     "EDUST5"         "DUST emissions bin5"  ""
+state   real     -          i{dust}jf      emis_seas      -        -        -         -                    "Sea-Salt Emissions"         ""
+state    real  eseas1       i{dust}jf      emis_seas      1         Z      -     "ESEAS1"         "Sea-Salt emissions bin1 "  ""
+state    real  eseas2       i{dust}jf      emis_seas      1         Z      -     "ESEAS2"         "Sea-Salt emissions bin2 "  ""
+state    real  eseas3       i{dust}jf      emis_seas      1         Z      -     "ESEAS3"         "Sea-Salt emissions bin3 "  ""
+state    real  eseas4       i{dust}jf      emis_seas      1         Z      -     "ESEAS4"         "Sea-Salt emissions bin4 "  ""
+# biomassburning emission arrays (used by fire plume rise)
+state   real     -          ikjf    ebu      -        -        -         -                    "Biomass burnung Emissions"         ""
+state    real  ebu_no       ikjf     ebu           1         Z        -      "ebu_no"        "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_co       ikjf     ebu           1         Z        -      "ebu_co"        "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_co2      ikjf     ebu           1         Z        -      "ebu_co2"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_eth      ikjf     ebu           1         Z        -      "ebu_eth"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_hc3      ikjf     ebu           1         Z        -      "ebu_hc3"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_hc5      ikjf     ebu           1         Z        -      "ebu_hc5"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_hc8      ikjf     ebu           1         Z        -      "ebu_hc8"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_ete      ikjf     ebu           1         Z        -      "ebu_ete"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_olt      ikjf     ebu           1         Z        -      "ebu_olt"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_oli      ikjf     ebu           1         Z        -      "ebu_oli"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_pm25     ikjf     ebu           1         Z        -      "ebu_pm25"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_pm10     ikjf     ebu           1         Z        -      "ebu_pm10"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_dien     ikjf     ebu           1         Z        -      "ebu_dien"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_iso      ikjf     ebu           1         Z        -      "ebu_iso"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_api      ikjf     ebu           1         Z        -      "ebu_api"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_lim      ikjf     ebu           1         Z        -      "ebu_lim"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_tol      ikjf     ebu           1         Z        -      "ebu_tol"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_xyl      ikjf     ebu           1         Z        -      "ebu_xyl"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_csl      ikjf     ebu           1         Z        -      "ebu_csl"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_hcho     ikjf     ebu           1         Z        -      "ebu_hcho"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_ald      ikjf     ebu           1         Z        -      "ebu_ald"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_ket      ikjf     ebu           1         Z        -      "ebu_ket"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_macr     ikjf     ebu           1         Z        -      "ebu_macr"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_ora1     ikjf     ebu           1         Z        -      "ebu_ora1"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_ora2     ikjf     ebu           1         Z        -      "ebu_ora2"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_nh3      ikjf     ebu           1         Z        -      "ebu_nh3"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_so2      ikjf     ebu           1         Z        -      "ebu_so2"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_dms      ikjf     ebu           1         Z        -      "ebu_dms"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_oc       ikjf     ebu           1         Z        h      "ebu_oc"        "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_bc       ikjf     ebu           1         Z        -      "ebu_bc"        "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_sulf     ikjf     ebu           1         Z        -      "ebu_sulf"      "biomass burning emiss"  "mol km^-2 hr^-1"
+# additional arrays for mozcart biomass burning
+state    real  ebu_bigalk   ikjf     ebu           1         Z        h      "ebu_bigalk"    "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_bigene   ikjf     ebu           1         Z        h      "ebu_bigene"    "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_c2h4     ikjf     ebu           1         Z        h      "ebu_c2h4"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_c2h5oh   ikjf     ebu           1         Z        h      "ebu_c2h5oh"    "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_c2h6     ikjf     ebu           1         Z        h      "ebu_c2h6"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_c3h6     ikjf     ebu           1         Z        h      "ebu_c3h6"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_c3h8     ikjf     ebu           1         Z        h      "ebu_c3h8"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_ch2o     ikjf     ebu           1         Z        h      "ebu_ch2o"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_ch3cho   ikjf     ebu           1         Z        h      "ebu_ch3cho"    "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_ch3coch3 ikjf     ebu           1         Z        h      "ebu_ch3coch3"  "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_ch3oh    ikjf     ebu           1         Z        h      "ebu_ch3oh"     "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_mek      ikjf     ebu           1         Z        h      "ebu_mek"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_toluene  ikjf     ebu           1         Z        h      "ebu_toluene"   "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_no2      ikjf     ebu           1         Z        h      "ebu_no2"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_open     ikjf     ebu           1         Z        h      "ebu_open"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_c10h16   ikjf     ebu           1         Z        h      "ebu_c10h16"    "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_mgly     ikjf     ebu           1         Z        h      "ebu_mgly"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_ch3cooh  ikjf     ebu           1         Z        h      "ebu_ch3cooh"   "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_cres     ikjf     ebu           1         Z        h      "ebu_cres"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_glyald   ikjf     ebu           1         Z        h      "ebu_glyald"    "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_gly      ikjf     ebu           1         Z        h      "ebu_gly"       "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_acetol   ikjf     ebu           1         Z        h      "ebu_acetol"    "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_isop     ikjf     ebu           1         Z        h      "ebu_isop"      "biomass burning emiss"  "mol km^-2 hr^-1"
+state    real  ebu_mvk      ikjf     ebu           1         Z        h      "ebu_mvk"       "biomass burning emiss"  "mol km^-2 hr^-1"
+
+# additional arrays needed for biomass burning emissions input
+state    real     -               i]jf      ebu_in      -         -        -         -                    "Biomass burnung input "         ""
+state    real  ebu_in_no          i]jf      ebu_in      1         -        i07        "ebu_in_no"             "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_co          i]jf      ebu_in      1         -        i07        "ebu_in_co"             "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_co2         i]jf      ebu_in      1         -        i07        "ebu_in_co2"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_eth         i]jf      ebu_in      1         -        i07        "ebu_in_eth"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_hc3         i]jf      ebu_in      1         -        i07        "ebu_in_hc3"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_hc5         i]jf      ebu_in      1         -        i07        "ebu_in_hc5"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_hc8         i]jf      ebu_in      1         -        i07        "ebu_in_hc8"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_ete         i]jf      ebu_in      1         -        i07        "ebu_in_ete"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_olt         i]jf      ebu_in      1         -        i07        "ebu_in_olt"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_oli         i]jf      ebu_in      1         -        i07        "ebu_in_oli"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_pm25        i]jf      ebu_in      1         -        i07        "ebu_in_pm25"           "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_pm10        i]jf      ebu_in      1         -        i07        "ebu_in_pm10"           "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_dien        i]jf      ebu_in      1         -        i07        "ebu_in_dien"           "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_iso         i]jf      ebu_in      1         -        i07        "ebu_in_iso"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_api         i]jf      ebu_in      1         -        i07        "ebu_in_api"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_lim         i]jf      ebu_in      1         -        i07        "ebu_in_lim"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_tol         i]jf      ebu_in      1         -        i07        "ebu_in_tol"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_xyl         i]jf      ebu_in      1         -        i07        "ebu_in_xyl"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_csl         i]jf      ebu_in      1         -        i07        "ebu_in_csl"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_hcho        i]jf      ebu_in      1         -        i07        "ebu_in_hcho"           "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_ald         i]jf      ebu_in      1         -        i07        "ebu_in_ald"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_ket         i]jf      ebu_in      1         -        i07        "ebu_in_ket"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_macr        i]jf      ebu_in      1         -        i07        "ebu_in_macr"           "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_ora1        i]jf      ebu_in      1         -        i07        "ebu_in_ora1"           "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_ora2        i]jf      ebu_in      1         -        i07        "ebu_in_ora2"           "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_nh3         i]jf      ebu_in      1         -        i07        "ebu_in_nh3"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_so2         i]jf      ebu_in      1         -        i07        "ebu_in_so2"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_dms         i]jf      ebu_in      1         -        i07        "ebu_in_dms"            "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_oc          i]jf      ebu_in      1         -        i07        "ebu_in_oc"             "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_bc          i]jf      ebu_in      1         -        i07        "ebu_in_bc"             "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_sulf        i]jf      ebu_in      1         -        i07        "ebu_in_sulf"           "EMISSIONS"          "mol km^-2 hr^-1"
+# additional arrays for mozcart biomass burning
+state    real  ebu_in_bigalk      i]jf      ebu_in      1         -        i07        "ebu_in_bigalk"     "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_bigene      i]jf      ebu_in      1         -        i07        "ebu_in_bigene"     "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_c2h4        i]jf      ebu_in      1         -        i07        "ebu_in_c2h4"       "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_c2h5oh      i]jf      ebu_in      1         -        i07        "ebu_in_c2h5oh"     "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_c2h6        i]jf      ebu_in      1         -        i07        "ebu_in_c2h6"       "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_c3h6        i]jf      ebu_in      1         -        i07        "ebu_in_c3h6"       "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_c3h8        i]jf      ebu_in      1         -        i07        "ebu_in_c3h8"       "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_ch2o        i]jf      ebu_in      1         -        i07        "ebu_in_ch2o"       "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_ch3cho      i]jf      ebu_in      1         -        i07        "ebu_in_ch3cho"     "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_ch3coch3    i]jf      ebu_in      1         -        i07        "ebu_in_ch3coch3"   "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_ch3oh       i]jf      ebu_in      1         -        i07        "ebu_in_ch3oh"      "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_mek         i]jf      ebu_in      1         -        i07        "ebu_in_mek"        "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_toluene     i]jf      ebu_in      1         -        i07        "ebu_in_toluene"    "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_no2         i]jf      ebu_in      1         -        i07        "ebu_in_no2"        "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_open        i]jf      ebu_in      1         -        i07        "ebu_in_open"       "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_c10h16      i]jf      ebu_in      1         -        i07        "ebu_in_c10h16"     "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_mgly        i]jf      ebu_in      1         -        i07        "ebu_in_mgly"       "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_ch3cooh     i]jf      ebu_in      1         -        i07        "ebu_in_ch3cooh"    "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_cres        i]jf      ebu_in      1         -        i07        "ebu_in_cres"       "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_glyald      i]jf      ebu_in      1         -        i07        "ebu_in_glyald"     "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_gly         i]jf      ebu_in      1         -        i07        "ebu_in_gly"        "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_acetol      i]jf      ebu_in      1         -        i07        "ebu_in_acetol"     "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_isop        i]jf      ebu_in      1         -        i07        "ebu_in_isop"       "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  ebu_in_mvk         i]jf      ebu_in      1         -        i07        "ebu_in_mvk"        "EMISSIONS"          "mol km^-2 hr^-1"
+#
+state    real  mean_fct_agtf      ij      misc      1         -        i07h       "mean_fct_agtf"         "mean fraction of tropical forest"  "?"
+state    real  mean_fct_agef      ij      misc      1         -        i07h       "mean_fct_agef"         "mean fraction of extra tropical forest"  "?"
+state    real  mean_fct_agsv      ij      misc      1         -        i07h       "mean_fct_agsv"         "mean fraction of savanna"  "?"
+state    real  mean_fct_aggr      ij      misc      1         -        i07h       "mean_fct_aggr"         "mean fraction of grassland"  "?"
+state    real  firesize_agtf      ij      misc      1         -        i07h       "firesize_agtf"         "mean firesize for tropical forest"  "?"
+state    real  firesize_agef      ij      misc      1         -        i07h       "firesize_agef"         "mean firesize for extratropical forest"  "?"
+state    real  firesize_agsv      ij      misc      1         -        i07h       "firesize_agsv"         "mean firesize for savanna"  "?"
+state    real  firesize_aggr      ij      misc      1         -        i07h       "firesize_aggr"         "mean firesize for grassland"  "?"
+
+# Lightning
+state    real  ic_flshrate    ij      misc        1         -      rh      "IC_FR"                 "Cuml. IC Flash rate"                 "number"
+state    real  cg_flshrate    ij      misc        1         -      rh      "CG_FR"                 "Cuml. CG Flash rate"                 "number"
+#
+# aircraft emissions
+state   integer aircraftemissframes -        -           -         -      -     "aircraftemissframes"   ""                   ""
+state    real     -             i{airc}jf    emis_aircraft    -         -      -     -                       "Aircraft Emissions" ""
+state    real  eac_so2          i{airc}jf    emis_aircraft    1         Z      i{13}    "EAC_SO2"               "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  eac_no           i{airc}jf    emis_aircraft    1         Z      i{13}    "EAC_NO"                "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  eac_co           i{airc}jf    emis_aircraft    1         Z      i{13}    "EAC_CO"                "EMISSIONS"          "mol km^-2 hr^-1"
+state    real  eac_ch4          i{airc}jf    emis_aircraft    1         Z      i{13}    "EAC_CH4"               "EMISSIONS"          "mol km^-2 hr^-1"
+
+#
+state   real     -            ikjf     ext_coef     -         -      -       -                       "Extinction coefficients"         ""
+state   real  extcof3         ikjf     ext_coef     1         Z      -     "EXTCOF3"                 "Extinction coefficients for .3um"  "km^-1"
+state   real  extcof55        ikjf     ext_coef     1         Z      h     "EXTCOF55"                "Extinction coefficients for .55um"  "km^-1"
+state   real  extcof106       ikjf     ext_coef     1         Z      -     "EXTCOF106"               "Extinction coefficients for 1.06um"  "km^-1"
+state   real  extcof3_5       ikjf     ext_coef     1         Z      -     "EXTCOF3_5"               "Band averaged extinction coefficients for 3-5um"  "km^-1"
+state   real  extcof8_12      ikjf     ext_coef     1         Z      -     "EXTCOF8_12"              "Band averaged extinction coefficients for 8-12um"  "km^-1"
+state   real     -            ikjf     bscat_coef   -         -      -       -                       "Scatter coefficients"         ""
+state   real  bscof3          ikjf     bscat_coef   1         Z      -     "BSCOF3"                  "Scatter coefficients for .3um"  "km^-1"
+state   real  bscof55         ikjf     bscat_coef   1         Z      -     "BSCOF5"                  "Scatter coefficients for .5um"  "km^-1"
+state   real  bscof106        ikjf     bscat_coef   1         Z      -     "BSCOF106"                "Scatter coefficients for 1.06um"  "km^-1"
+state   real     -            ikjf     asym_par     -         -      -       -                       "assymetry parameter"         ""
+state   real  asympar3        ikjf     asym_par     1         Z      -     "ASYMPAR3"                "assymetry parameter for .3um"  "?"
+state   real  asympar55       ikjf     asym_par     1         Z      -     "ASYMPAR55"               "assymetry parameter for .55um"  "?"
+state   real  asympar106      ikjf     asym_par     1         Z      -     "ASYMPAR106"              "assymetry parameter for 1.06um"  "?"
+#
+state    real  e_bio          ijo     misc        1         Z      r        "E_BIO"             "EMISSIONS"             "ppm m/min"
+state    real  sebio_iso      ij      misc        1         -      i06r     "sebio_iso"         "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_oli      ij      misc        1         -      i06r     "sebio_oli"         "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_api      ij      misc        1         -      i06r     "sebio_api"         "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_lim      ij      misc        1         -      i06r     "sebio_lim"         "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_xyl      ij      misc        1         -      i06r     "sebio_xyl"         "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_hc3      ij      misc        1         -      i06r     "sebio_hc3"         "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_ete      ij      misc        1         -      i06r     "sebio_ete"         "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_olt      ij      misc        1         -      i06r     "sebio_olt"         "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_ket      ij      misc        1         -      i06r     "sebio_ket"         "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_ald      ij      misc        1         -      i06r     "sebio_ald"         "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_hcho     ij      misc        1         -      i06r     "sebio_hcho"        "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_eth      ij      misc        1         -      i06r     "sebio_eth"         "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_ora2     ij      misc        1         -      i06r     "sebio_ora2"        "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_co       ij      misc        1         -      i06r     "sebio_co"          "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  sebio_nr       ij      misc        1         -      i06r     "sebio_nr"          "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  noag_grow      ij      misc        1         -      i06r     "noag_grow"         "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  noag_nongrow   ij      misc        1         -      i06r     "noag_nongrow"      "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  nononag        ij      misc        1         -      i06r     "nononag"           "Reference biog emiss"  "mol km^-2 hr^-1"
+state    real  slai           ij      misc        1         -      i06r     "slai"              "Leaf area index isop"  ""
+state    real  ebio_iso       ij      misc        1         -      -        "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"
+# mozcart megan2 bio emission species 
+state    real  ebio_c10h16    ij      misc        1         -      -        "ebio_c10h16"      "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_tol       ij      misc        1         -      -        "ebio_tol"         "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_bigalk    ij      misc        1         -      -        "ebio_bigalk"      "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_bigene    ij      misc        1         -      -        "ebio_bigene"      "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_ch3oh     ij      misc        1         -      -        "ebio_ch3oh"       "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_acet      ij      misc        1         -      -        "ebio_acet"        "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_nh3       ij      misc        1         -      -        "ebio_nh3"         "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_no2       ij      misc        1         -      -        "ebio_no2"         "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_c2h5oh    ij      misc        1         -      -        "ebio_c2h5oh"      "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_ch3cooh   ij      misc        1         -      -        "ebio_ch3cooh"     "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_mek       ij      misc        1         -      -        "ebio_mek"         "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_c2h6      ij      misc        1         -      -        "ebio_c2h6"        "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_c2h4      ij      misc        1         -      -        "ebio_c2h4"        "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_c3h6      ij      misc        1         -      -        "ebio_c3h6"        "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_c3h8      ij      misc        1         -      -        "ebio_c3h8"        "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_so2       ij      misc        1         -      -        "ebio_so2"         "Actual biog emiss"  "mol km^-2 hr^-1"
+state    real  ebio_dms       ij      misc        1         -      -        "ebio_dms"         "Actual biog emiss"  "mol km^-2 hr^-1"
+# Output of selected biogenic emissions from model MEGAN v2
+state    real  mebio_isop     ij      misc        1         -      -        "MEBIO_ISOP"       "MEGAN2 isoprene emiss" "mol km^-2 hr^-1"
+state    real  mebio_apin     ij      misc        1         -      -        "MEBIO_APIN"       "MEGAN2 a-pinene emiss" "mol km^-2 hr^-1"
+state    real  mebio_bpin     ij      misc        1         -      -        "MEBIO_BPIN"       "MEGAN2 b-pinene emiss" "mol km^-2 hr^-1"
+state    real  mebio_bcar     ij      misc        1         -      -        "MEBIO_BCAR"       "MEGAN2 b-caryop emiss" "mol km^-2 hr^-2"
+state    real  mebio_acet     ij      misc        1         -      -        "MEBIO_ACET"       "MEGAN2 acetone emiss"  "mol km^-2 hr^-2"
+state    real  mebio_mbo      ij      misc        1         -      -        "MEBIO_MBO"        "MEGAN2 MBO emiss"      "mol km^-2 hr^-2"
+state    real  mebio_no       ij      misc        1         -      -        "MEBIO_NO"         "MEGAN2 NO emiss"       "mol km^-2 hr^-2"
+# Input for biogenic emissions model MEGAN v2
+state    real  msebio_isop    ij      misc        1         -      i06r     "msebio_isop"      "MEGAN2 isoprone emis fac"  "mol km^-2 hr^-1"
+state    real  mlai           ijm     misc        1         Z      i06r     "mlai"             "Monthly Leaf area index for MEGAN2"  ""
+state    real  pftp_bt        ij      misc        1         -      i06r     "pftp_bt"          "MEGAN2 PFT Broadleaf %"  "%"
+state    real  pftp_nt        ij      misc        1         -      i06r     "pftp_nt"          "MEGAN2 PFT Needleleaf %"  "%"
+state    real  pftp_sb        ij      misc        1         -      i06r     "pftp_sb"          "MEGAN2 PFT Shrub and Bush %"  "%"
+state    real  pftp_hb        ij      misc        1         -      i06r     "pftp_hb"          "MEGAN2 PFT Herbs %"  "%"
+state    real  mtsa           ijm     misc        1         Z      i06r     "mtsa"             "Monthly surface air temp"  "K"
+state    real  mswdown        ijm     misc        1         Z      i06r     "mswdown"          "Monthly SWdown"  "W/m2"
+state    real  EFmegan        ij{nm}     misc        1         -      -        "EFmegan"          "MEGAN2 Emis Factor"       "ug m^-2 hr^-1"
+# Input for GOCART: Background chemistry, erodible surface emissions map
+#state    real  erod           ij.     misc        1         -      ihr     "EROD"          "fraction of erodible surface in each grid cell (0-1)"       "none"
+state    real  backg_oh       ikj     misc        1         -      i08r    "BACKG_OH"       "Background OH for Aerosol-GOcart option"       "volume mixing ratio"
+state    real  backg_h2o2     ikj     misc        1         -      i08r    "BACKG_H2O2"     "Background H2O2 for Aerosol-GOcart option"     "volume mixing ratio"
+state    real  backg_no3      ikj     misc        1         -      i08r    "BACKG_NO3"      "Background NO3 for Aerosol-GOcart option"      "volume mixing ratio"
+
+#
+# following used for volcanic eruptions only
+#
+state    real  ash_fall     ij      misc        1         -      h        "ASH_FALL"               "VOLCANIC ASH FALL"                 "kg/m2"
+state    real  erup_beg     ij      misc        1         -      i5       "ERUP_BEG"               "START TIME OF ERUPTION"        "?"
+state    real  erup_end     ij      misc        1         -      i5       "ERUP_END"               "END TIME OF ERUPTION"        "?"
+#
+# 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"              "?"
+
+#
+# Tendency diagnostics for chemistry (chemdiag)
+#
+# Currently index references to chem array is done within the code and requires
+# code-level modification to add or remove diagnostics. Rearranging is OK, but
+# order among conv_ct,chem_ct,vmix_ct and advh_ct,advz_ct must be consistent within
+# the two groups. The two files need to be modified are:
+# Search for "modify tendncy list here"
+#-------------------------------------------------------------------------------
+state  real  -          ikjf    conv_ct    1    -   -     - 
+state  real  conv_co    ikjf    conv_ct    1    -   rh   "conv_co"      "ACCUMULATED CONV TRANSPORT FOR CO"    "ppmv"
+state  real  conv_o3    ikjf    conv_ct    1    -   rh   "conv_o3"      "ACCUMULATED CONV TRANSPORT FOR O3"    "ppmv"
+state  real  conv_no    ikjf    conv_ct    1    -   rh   "conv_no"      "ACCUMULATED CONV TRANSPORT FOR NO"    "ppmv"
+state  real  conv_no2   ikjf    conv_ct    1    -   rh   "conv_no2"     "ACCUMULATED CONV TRANSPORT FOR NO2"   "ppmv"
+state  real  conv_hno3  ikjf    conv_ct    1    -   rh   "conv_hno3"    "ACCUMULATED CONV TRANSPORT FOR HNO3"  "ppmv"
+state  real  conv_iso   ikjf    conv_ct    1    -   rh   "conv_iso"     "ACCUMULATED CONV TRANSPORT FOR ISO"   "ppmv"
+state  real  conv_ho    ikjf    conv_ct    1    -   rh   "conv_ho"      "ACCUMULATED CONV TRANSPORT FOR HO"    "ppmv"
+state  real  conv_ho2   ikjf    conv_ct    1    -   rh   "conv_ho2"     "ACCUMULATED CONV TRANSPORT FOR HO2"   "ppmv"
+
+state  real  -          ikjf    chem_ct    1    -   -    -
+state  real  chem_co    ikjf    chem_ct    1    -   rh   "chem_co"    "ACCUMULATED CHEM TENDENCY FOR CO"     "ppmv"
+state  real  chem_o3    ikjf    chem_ct    1    -   rh   "chem_o3"    "ACCUMULATED CHEM TENDENCY FOR O3"     "ppmv"
+state  real  chem_no    ikjf    chem_ct    1    -   rh   "chem_no"    "ACCUMULATED CHEM TENDENCY FOR NO"     "ppmv"
+state  real  chem_no2   ikjf    chem_ct    1    -   rh   "chem_no2"   "ACCUMULATED CHEM TENDENCY FOR NO2"    "ppmv"
+state  real  chem_hno3  ikjf    chem_ct    1    -   rh   "chem_hno3"  "ACCUMULATED CHEM TENDENCY FOR HNO3"   "ppmv"
+state  real  chem_iso   ikjf    chem_ct    1    -   rh   "chem_iso"   "ACCUMULATED CHEM TENDENCY FOR ISO"    "ppmv"
+state  real  chem_ho    ikjf    chem_ct    1    -   rh   "chem_ho"    "ACCUMULATED CHEM TENDENCY FOR HO"     "ppmv"
+state  real  chem_ho2   ikjf    chem_ct    1    -   rh   "chem_ho2"   "ACCUMULATED CHEM TENDENCY FOR HO2"    "ppmv"
+
+state  real  -          ikjf    vmix_ct    1    -   -    -
+state  real  vmix_co    ikjf    vmix_ct    1    -   rh   "vmix_co"    "ACCUMULATED TENDENCY FOR CO BY VERTICAL MIXING"               "ppmv"
+state  real  vmix_o3    ikjf    vmix_ct    1    -   rh   "vmix_o3"    "ACCUMULATED TENDENCY FOR O3 BY VERTICAL MIXING"               "ppmv"
+state  real  vmix_no    ikjf    vmix_ct    1    -   rh   "vmix_no"    "ACCUMULATED TENDENCY FOR NO BY VERTICAL MIXING"               "ppmv"
+state  real  vmix_no2   ikjf    vmix_ct    1    -   rh   "vmix_no2"   "ACCUMULATED TENDENCY FOR NO2 BY VERTICAL MIXING"              "ppmv"
+state  real  vmix_hno3  ikjf    vmix_ct    1    -   rh   "vmix_hno3"  "ACCUMULATED TENDENCY FOR HNO3 BY VERTICAL MIXING"             "ppmv"
+state  real  vmix_iso   ikjf    vmix_ct    1    -   rh   "vmix_iso"   "ACCUMULATED TENDENCY FOR ISO BY VERTICAL MIXING"              "ppmv"
+state  real  vmix_ho    ikjf    vmix_ct    1    -   rh   "vmix_ho"    "ACCUMULATED TENDENCY FOR HO BY VERTICAL MIXING"               "ppmv"
+state  real  vmix_ho2   ikjf    vmix_ct    1    -   rh   "vmix_ho2"   "ACCUMULATED TENDENCY FOR HO2 BY VERTICAL MIXING"              "ppmv"
+
+state  real  -          ikjf    advh_ct    1    -   -    -
+state  real  advh_co    ikjf    advh_ct    1    -   rh   "advh_co"    "ACCUMULATED TENDENCY FOR CO BY HORIZONTAL ADVECTION"          "ppmv"
+state  real  advh_o3    ikjf    advh_ct    1    -   rh   "advh_o3"    "ACCUMULATED TENDENCY FOR O3 BY HORIZONTAL ADVECTION"          "ppmv"
+state  real  advh_no    ikjf    advh_ct    1    -   rh   "advh_no"    "ACCUMULATED TENDENCY FOR NO BY HORIZONTAL ADVECTION"          "ppmv"
+state  real  advh_no2   ikjf    advh_ct    1    -   rh   "advh_no2"   "ACCUMULATED TENDENCY FOR NO2 BY HORIZONTAL ADVECTION"         "ppmv"
+state  real  advh_hno3  ikjf    advh_ct    1    -   rh   "advh_hno3"  "ACCUMULATED TENDENCY FOR HNO3 BY HORIZONTAL ADVECTION"        "ppmv"
+state  real  advh_iso   ikjf    advh_ct    1    -   rh   "advh_iso"   "ACCUMULATED TENDENCY FOR ISO BY HORIZONTAL ADVECTION"         "ppmv"
+state  real  advh_ho    ikjf    advh_ct    1    -   rh   "advh_ho"    "ACCUMULATED TENDENCY FOR HO BY HORIZONTAL ADVECTION"          "ppmv"
+state  real  advh_ho2   ikjf    advh_ct    1    -   rh   "advh_ho2"   "ACCUMULATED TENDENCY FOR HO2 BY HORIZONTAL ADVECTION"         "ppmv"
+
+state  real  -          ikjf    advz_ct    1    -   -    -
+state  real  advz_co    ikjf    advz_ct    1    -   rh   "advz_co"    "ACCUMULATED TENDENCY FOR CO BY VERTICAL ADVECTION"            "ppmv"
+state  real  advz_o3    ikjf    advz_ct    1    -   rh   "advz_o3"    "ACCUMULATED TENDENCY FOR O3 BY VERTICAL ADVECTION"            "ppmv"
+state  real  advz_no    ikjf    advz_ct    1    -   rh   "advz_no"    "ACCUMULATED TENDENCY FOR NO BY VERTICAL ADVECTION"            "ppmv"
+state  real  advz_no2   ikjf    advz_ct    1    -   rh   "advz_no2"   "ACCUMULATED TENDENCY FOR NO2 BY VERTICAL ADVECTION"           "ppmv"
+state  real  advz_hno3  ikjf    advz_ct    1    -   rh   "advz_hno3"  "ACCUMULATED TENDENCY FOR HNO3 BY VERTICAL ADVECTION"          "ppmv"
+state  real  advz_iso   ikjf    advz_ct    1    -   rh   "advz_iso"   "ACCUMULATED TENDENCY FOR ISO BY VERTICAL ADVECTION"           "ppmv"
+state  real  advz_ho    ikjf    advz_ct    1    -   rh   "advz_ho"    "ACCUMULATED TENDENCY FOR HO BY VERTICAL ADVECTION"            "ppmv"
+state  real  advz_ho2   ikjf    advz_ct    1    -   rh   "advz_ho2"   "ACCUMULATED TENDENCY FOR HO2 BY VERTICAL ADVECTION"           "ppmv"
+
+# deposition velocities for diagnostic package, feel free to add if you like!
+#
+state    real    -           i%jf      dvel           -         -     -    -      "deposition velocities"           ""                                       
+state    real  dvel_o3       i%jf      dvel           1         -      -      "dvel_o3"        "O3 deposition velocity  "  "cm/s"
+state    real  dvel_no       i%jf      dvel           1         -      -      "dvel_no"        "NO deposition velocity  "  "cm/s"
+state    real  dvel_no2      i%jf      dvel           1         -      -      "dvel_no2"       "NO2 deposition velocity "  "cm/s"
+state    real  dvel_nh3      i%jf      dvel           1         -      -      "dvel_nh3"       "NH3 deposition velocity "  "cm/s"
+state    real  dvel_hno3     i%jf      dvel           1         -      -      "dvel_hno3"      "HNO3 deposition velocity "  "cm/s"
+state    real  dvel_hno4     i%jf      dvel           1         -      -      "dvel_hno4"      "HNO4 deposition velocity "  "cm/s"
+state    real  dvel_h2o2     i%jf      dvel           1         -      -      "dvel_h2o2"      "H2O2 deposition velocity "  "cm/s"
+state    real  dvel_co       i%jf      dvel           1         -      -      "dvel_co"        "CO deposition velocity  "  "cm/s"
+state    real  dvel_ch3ooh   i%jf      dvel           1         -      -      "dvel_ch3ooh"    "CH3OOH deposition velocity  "  "cm/s"
+state    real  dvel_hcho     i%jf      dvel           1         -      -      "dvel_hcho"      "HCHO deposition velocity "  "cm/s"
+state    real  dvel_ch3oh    i%jf      dvel           1         -      -      "dvel_ch3oh"     "CH3OH deposition velocity  "  "cm/s"
+state    real  dvel_eo2      i%jf      dvel           1         -      -      "dvel_eo2"       "EO2 deposition velocity "  "cm/s"
+state    real  dvel_ald      i%jf      dvel           1         -      -      "dvel_ald"       "ALD deposition velocity "  "cm/s"
+state    real  dvel_ch3cooh  i%jf      dvel           1         -      -      "dvel_ch3cooh"   "CH3COOH deposition velocity  "  "cm/s"
+state    real  dvel_acet     i%jf      dvel           1         -      -      "dvel_acet"      "ACET deposition velocity "  "cm/s"
+state    real  dvel_mgly     i%jf      dvel           1         -      -      "dvel_mgly"      "MGLY deposition velocity "  "cm/s"
+state    real  dvel_paa      i%jf      dvel           1         -      -      "dvel_paa"       "PAA deposition velocity "  "cm/s"
+state    real  dvel_pooh     i%jf      dvel           1         -      -      "dvel_pooh"      "POOH deposition velocity "  "cm/s"
+state    real  dvel_pan      i%jf      dvel           1         -      -      "dvel_pan"       "PAN deposition velocity "  "cm/s"
+state    real  dvel_mpan     i%jf      dvel           1         -      -      "dvel_mpan"      "MPAN deposition velocity "  "cm/s"
+state    real  dvel_mco3     i%jf      dvel           1         -      -      "dvel_mco3"      "MCO3 deposition velocity "  "cm/s"
+state    real  dvel_mvkooh   i%jf      dvel           1         -      -      "dvel_mvkooh"    "MVKOOH deposition velocity  "  "cm/s"
+state    real  dvel_c2h5oh   i%jf      dvel           1         -      -      "dvel_c2h5oh"    "C2H5OH deposition velocity  "  "cm/s"
+state    real  dvel_etooh    i%jf      dvel           1         -      -      "dvel_etooh"     "ETOOH deposition velocity  "  "cm/s"
+state    real  dvel_prooh    i%jf      dvel           1         -      -      "dvel_prooh"     "PROOH deposition velocity  "  "cm/s"
+state    real  dvel_acetp    i%jf      dvel           1         -      -      "dvel_acetp"     "ACETP deposition velocity  "  "cm/s"
+state    real  dvel_onit     i%jf      dvel           1         -      -      "dvel_onit"      "ONIT deposition velocity "  "cm/s"
+state    real  dvel_onitr    i%jf      dvel           1         -      -      "dvel_onitr"     "ONITR deposition velocity  "  "cm/s"
+state    real  dvel_isooh    i%jf      dvel           1         -      -      "dvel_isooh"     "ISOOH deposition velocity  "  "cm/s"
+state    real  dvel_acetol   i%jf      dvel           1         -      -      "dvel_acetol"    "ACETOL deposition velocity  "  "cm/s"
+state    real  dvel_glyald   i%jf      dvel           1         -      -      "dvel_glyald"    "GLYALD deposition velocity  "  "cm/s"
+state    real  dvel_hydrald  i%jf      dvel           1         -      -      "dvel_hydrald"   "HYDRALD deposition velocity  "  "cm/s"
+state    real  dvel_alkooh   i%jf      dvel           1         -      -      "dvel_alkooh"    "ALKOOH deposition velocity  "  "cm/s"
+state    real  dvel_mekooh   i%jf      dvel           1         -      -      "dvel_mekooh"    "MEKOOH deposition velocity  "  "cm/s"
+state    real  dvel_tolooh   i%jf      dvel           1         -      -      "dvel_tolooh"    "TOLOOH deposition velocity  "  "cm/s"
+state    real  dvel_xooh     i%jf      dvel           1         -      -      "dvel_xooh"      "XOOH deposition velocity "  "cm/s"
+state    real  dvel_so2      i%jf      dvel           1         -      -      "dvel_so2"       "SO2 deposition velocity "  "cm/s"
+state    real  dvel_so4      i%jf      dvel           1         -      -      "dvel_so4"       "SO4 deposition velocity "  "cm/s"
+state    real  dvel_terpooh  i%jf      dvel           1         -      -      "dvel_terpooh"    "TERPOOH deposition velocity "  "cm/s"
+
+# aerosol stuff
+state    real  aerwrf         ikj     misc        1         -      r        "AERWRF"                "STANDARD AEROSOL PROFILE"            "?"
+
+state    real  pm2_5_dry      ikj     misc        1         -      rh       "PM2_5_DRY"             "pm2.5 aerosol dry mass"              "ug m^-3"
+state    real  pm2_5_dry_ec   ikj     misc        1         -      -        "PM2_5_EC_DRY"          "dry ec aerosol mass"                 "ug m^-3"
+state    real  pm2_5_water    ikj     misc        1         -      -        "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"
+state    real  tcosz          ij      misc        1         -      -        "TCOSZ "               "daily average cossza"                   "?"
+state    real  ttday          ij      misc        1         -      -        "TTDAY "               ""                   "?"
+# dms_0 is the dms concentration in the ocean (aqueous phase) and it should be in the unit of nM/L (1.e-9mol/L) 
+state    real  dms_0          ij      misc        1         -      i08rh    "DMS_0 "               "dms oceanic concentrations"           "nM/L"
+
+#Diagnostic Aerosol species
+state    real  hoa_a01      ikj     misc          1         -      rh        "hoa_a01"             "hoa_a01"                              "ug m^-3"
+state    real  hoa_a02      ikj     misc          1         -      rh        "hoa_a02"             "hoa_a02"                              "ug m^-3"
+state    real  hoa_a03      ikj     misc          1         -      rh        "hoa_a03"             "hoa_a03"                              "ug m^-3"
+state    real  hoa_a04      ikj     misc          1         -      rh        "hoa_a04"             "hoa_a04"                              "ug m^-3"
+state    real  soa_a01      ikj     misc          1         -      rh        "soa_a01"             "soa_a01"                              "ug m^-3"
+state    real  soa_a02      ikj     misc          1         -      rh        "soa_a02"             "soa_a02"                              "ug m^-3"
+state    real  soa_a03      ikj     misc          1         -      rh        "soa_a03"             "soa_a03"                              "ug m^-3"
+state    real  soa_a04      ikj     misc          1         -      rh        "soa_a04"             "soa_a04"                              "ug m^-3"
+state    real  bboa_a01      ikj     misc          1         -      rh        "bboa_a01"             "bboa_a01"                              "ug m^-3"
+state    real  bboa_a02      ikj     misc          1         -      rh        "bboa_a02"             "bboa_a02"                              "ug m^-3"
+state    real  bboa_a03      ikj     misc          1         -      rh        "bboa_a03"             "bboa_a03"                              "ug m^-3"
+state    real  bboa_a04      ikj     misc          1         -      rh        "bboa_a04"             "bboa_a04"                              "ug m^-3"
+state    real  bbsoa_a01      ikj     misc          1         -      rh        "bbsoa_a01"             "bbsoa_a01"                              "ug m^-3"
+state    real  bbsoa_a02      ikj     misc          1         -      rh        "bbsoa_a02"             "bbsoa_a02"                              "ug m^-3"
+state    real  bbsoa_a03      ikj     misc          1         -      rh        "bbsoa_a03"             "bbsoa_a03"                              "ug m^-3"
+state    real  bbsoa_a04      ikj     misc          1         -      rh        "bbsoa_a04"             "bbsoa_a04"                              "ug m^-3"
+state    real  hsoa_a01      ikj     misc          1         -      rh        "hsoa_a01"             "hsoa_a01"                              "ug m^-3"
+state    real  hsoa_a02      ikj     misc          1         -      rh        "hsoa_a02"             "hsoa_a02"                              "ug m^-3"
+state    real  hsoa_a03      ikj     misc          1         -      rh        "hsoa_a03"             "hsoa_a03"                              "ug m^-3"
+state    real  hsoa_a04      ikj     misc          1         -      rh        "hsoa_a04"             "hsoa_a04"                              "ug m^-3"
+state    real  biog_a01      ikj     misc          1         -      rh        "biog_a01"             "biog_a01"                              "ug m^-3"
+state    real  biog_a02      ikj     misc          1         -      rh        "biog_a02"             "biog_a02"                              "ug m^-3"
+state    real  biog_a03      ikj     misc          1         -      rh        "biog_a03"             "biog_a03"                              "ug m^-3"
+state    real  biog_a04      ikj     misc          1         -      rh        "biog_a04"             "biog_a04"                              "ug m^-3"
+state    real  arosoa_a01      ikj     misc          1         -      rh        "arosoa_a01"             "arosoa_a01"                              "ug m^-3"
+state    real  arosoa_a02      ikj     misc          1         -      rh        "arosoa_a02"             "arosoa_a02"                              "ug m^-3"
+state    real  arosoa_a03      ikj     misc          1         -      rh        "arosoa_a03"             "arosoa_a03"                              "ug m^-3"
+state    real  arosoa_a04      ikj     misc          1         -      rh        "arosoa_a04"             "arosoa_a04"                              "ug m^-3"
+state    real  totoa_a01      ikj     misc          1         -      rh        "totoa_a01"             "totoa_a01"                              "ug m^-3"
+state    real  totoa_a02      ikj     misc          1         -      rh        "totoa_a02"             "totoa_a02"                              "ug m^-3"
+state    real  totoa_a03      ikj     misc          1         -      rh        "totoa_a03"             "totoa_a03"                              "ug m^-3"
+state    real  totoa_a04      ikj     misc          1         -      rh        "totoa_a04"             "totoa_a04"                              "ug m^-3"
+state    real  hsoa_c          ikj     misc          1         -      rh        "hsoa_c"                  "hsoa_c"                                "ug m^-3"
+state    real  hsoa_o          ikj     misc          1         -      rh        "hsoa_o"                  "hsoa_o"                                "ug m^-3"
+state    real  bbsoa_c          ikj     misc          1         -      rh        "bbsoa_c"                  "bbsoa_c"                                "ug m^-3"
+state    real  bbsoa_o          ikj     misc          1         -      rh        "bbsoa_o"                  "bbsoa_o"                                "ug m^-3"
+state    real  biog_v1          ikj     misc          1         -      rh        "biog_v1"                  "biog_v1"                                "ug m^-3"
+state    real  biog_v2          ikj     misc          1         -      rh        "biog_v2"                  "biog_v2"                                "ug m^-3"
+state    real  biog_v3          ikj     misc          1         -      rh        "biog_v3"                  "biog_v3"                                "ug m^-3"
+state    real  biog_v4          ikj     misc          1         -      rh        "biog_v4"                  "biog_v4"                                "ug m^-3"
+state    real  ant_v1          ikj     misc          1         -      rh        "ant_v1"                  "ant_v1"                                "ug m^-3"
+state    real  ant_v2          ikj     misc          1         -      rh        "ant_v2"                  "ant_v2"                                "ug m^-3"
+state    real  ant_v3          ikj     misc          1         -      rh        "ant_v3"                  "ant_v3"                                "ug m^-3"
+state    real  ant_v4          ikj     misc          1         -      rh        "ant_v4"                  "ant_v4"                                "ug m^-3"
+state    integer  vbs_nbin      v         misc          1         -      r        "vbs_nbin"                  "vbs_nbin"                                ""
+
+
+# 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         -      r        "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}"
+state    real  ph_pan          ikj     misc        1         -      r        "PHOTR101"              "pan photolysis rate" "min{-1}"
+state    real  ph_acet         ikj     misc        1         -      r        "PHOTR102"              "acetone photolysis rate" "min{-1}"
+state    real  ph_mglo         ikj     misc        1         -      r        "PHOTR103"              "mglo photolysis rate" "min{-1}"
+state    real  ph_hno4_2       ikj     misc        1         -      r        "PHOTR104"              "mglo photolysis rate" "min{-1}"
+# mozart photolysis rates
+state    real  ph_n2o          ikj     misc        1         -      -        "PHOTR114"              "n2o photolysis rate" "min{-1}"
+state    real  ph_pooh         ikj     misc        1         -      -        "PHOTR118"              "pooh photolysis rate" "min{-1}"
+state    real  ph_mpan         ikj     misc        1         -      -        "PHOTR119"              "mpan photolysis rate" "min{-1}"
+state    real  ph_mvk          ikj     misc        1         -      -        "PHOTR135"              "mvk photolysis rate" "min{-1}"
+state    real  ph_etooh        ikj     misc        1         -      -        "PHOTR120"              "c2h5ooh photolysis rate" "min{-1}"
+state    real  ph_prooh        ikj     misc        1         -      -        "PHOTR121"              "c3h7ooh photolysis rate" "min{-1}"
+state    real  ph_onitr        ikj     misc        1         -      -        "PHOTR122"              "onitr photolysis rate" "min{-1}"
+state    real  ph_acetol       ikj     misc        1         -      -        "PHOTR123"              "hyac photolysis rate" "min{-1}"
+state    real  ph_glyald       ikj     misc        1         -      -        "PHOTR124"              "glyald photolysis rate" "min{-1}"
+state    real  ph_hyac         ikj     misc        1         -      -        "PHOTR140"              "hyac photolysis rate" "min{-1}"
+state    real  ph_mek          ikj     misc        1         -      -        "PHOTR125"              "mek photolysis rate" "min{-1}"
+state    real  ph_open         ikj     misc        1         -      -        "PHOTR126"              "bigald photolysis rate" "min{-1}"
+state    real  ph_gly          ikj     misc        1         -      -        "PHOTR127"              "glyoxal photolysis rate" "min{-1}"
+state    real  ph_acetp        ikj     misc        1         -      -        "PHOTR128"              "rooh photolysis rate" "min{-1}"
+state    real  ph_xooh         ikj     misc        1         -      -        "PHOTR129"              "xooh photolysis rate" "min{-1}"
+state    real  ph_isooh        ikj     misc        1         -      -        "PHOTR130"              "isopooh photolysis rate" "min{-1}"
+state    real  ph_alkooh       ikj     misc        1         -      -        "PHOTR131"              "alkooh photolysis rate" "min{-1}"
+state    real  ph_mekooh       ikj     misc        1         -      -        "PHOTR132"              "mekooh photolysis rate" "min{-1}"
+state    real  ph_tolooh       ikj     misc        1         -      -        "PHOTR133"              "tolooh photolysis rate" "min{-1}"
+state    real  ph_terpooh      ikj     misc        1         -      -        "PHOTR134"              "terpooh photolysis rate" "min{-1}"
+#
+# Aerosol optical properties from Mie code for rrtmg radiation
+state    real  extaerlw1         ikj     misc        1         -      hr      "LWEXTAER1"          "layer extinction coef"  "1/km"
+state    real  extaerlw2         ikj     misc        1         -      hr      "LWEXTAER2"          "layer extinction coef"  "1/km"
+state    real  extaerlw3         ikj     misc        1         -      hr      "LWEXTAER3"          "layer extinction coef"  "1/km"
+state    real  extaerlw4         ikj     misc        1         -      hr      "LWEXTAER4"          "layer extinction coef"  "1/km"
+state    real  extaerlw5         ikj     misc        1         -      hr      "LWEXTAER5"          "layer extinction coef"  "1/km"
+state    real  extaerlw6         ikj     misc        1         -      hr      "LWEXTAER6"          "layer extinction coef"  "1/km"
+state    real  extaerlw7         ikj     misc        1         -      hr      "LWEXTAER7"          "layer extinction coef"  "1/km"
+state    real  extaerlw8         ikj     misc        1         -      hr      "LWEXTAER8"          "layer extinction coef"  "1/km"
+state    real  extaerlw9         ikj     misc        1         -      hr      "LWEXTAER9"          "layer extinction coef"  "1/km"
+state    real  extaerlw10        ikj     misc        1         -      hr     "LWEXTAER10"          "layer extinction coef"  "1/km"
+state    real  extaerlw11        ikj     misc        1         -      hr     "LWEXTAER11"          "layer extinction coef"  "1/km"
+state    real  extaerlw12        ikj     misc        1         -      hr     "LWEXTAER12"          "layer extinction coef"  "1/km"
+state    real  extaerlw13        ikj     misc        1         -      hr     "LWEXTAER13"          "layer extinction coef"  "1/km"
+state    real  extaerlw14        ikj     misc        1         -      hr     "LWEXTAER14"          "layer extinction coef"  "1/km"
+state    real  extaerlw15        ikj     misc        1         -      hr     "LWEXTAER15"          "layer extinction coef"  "1/km"
+state    real  extaerlw16        ikj     misc        1         -      hr     "LWEXTAER16"          "layer extinction coef"  "1/km"
+state    real  tauaerlw1         ikj     misc        1         -      hr      "LWTAUAER1"          "layer optical thickness" " "
+state    real  tauaerlw2         ikj     misc        1         -      hr      "LWTAUAER2"          "layer optical thickness" " "
+state    real  tauaerlw3         ikj     misc        1         -      hr      "LWTAUAER3"          "layer optical thickness" " "
+state    real  tauaerlw4         ikj     misc        1         -      hr      "LWTAUAER4"          "layer optical thickness" " "
+state    real  tauaerlw5         ikj     misc        1         -      hr      "LWTAUAER5"          "layer optical thickness" " "
+state    real  tauaerlw6         ikj     misc        1         -      hr      "LWTAUAER6"          "layer optical thickness" " "
+state    real  tauaerlw7         ikj     misc        1         -      hr      "LWTAUAER7"          "layer optical thickness" " "
+state    real  tauaerlw8         ikj     misc        1         -      hr      "LWTAUAER8"          "layer optical thickness" " "
+state    real  tauaerlw9         ikj     misc        1         -      hr      "LWTAUAER9"          "layer optical thickness" " "
+state    real  tauaerlw10         ikj     misc        1         -     hr     "LWTAUAER10"          "layer optical thickness" " "
+state    real  tauaerlw11         ikj     misc        1         -     hr     "LWTAUAER11"          "layer optical thickness" " "
+state    real  tauaerlw12         ikj     misc        1         -     hr     "LWTAUAER12"          "layer optical thickness" " "
+state    real  tauaerlw13         ikj     misc        1         -     hr     "LWTAUAER13"          "layer optical thickness" " "
+state    real  tauaerlw14         ikj     misc        1         -     hr     "LWTAUAER14"          "layer optical thickness" " "
+state    real  tauaerlw15         ikj     misc        1         -     hr     "LWTAUAER15"          "layer optical thickness" " "
+state    real  tauaerlw16         ikj     misc        1         -     hr     "LWTAUAER16"          "layer optical thickness" " "
+# Aerosol optical properties from Mie code
+state    real  extaer1         ikj     misc        1         -      -        "EXTAER1"               "bin 1 layer extinction coef" "1/km"
+state    real  extaer2         ikj     misc        1         -      -        "EXTAER2"               "bin 2 layer extinction coef" "1/km"
+state    real  extaer3         ikj     misc        1         -      -        "EXTAER3"               "bin 3 layer extinction coef" "1/km"
+state    real  extaer4         ikj     misc        1         -      -        "EXTAER4"               "bin 4 layer extinction coef" "1/km"
+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" "?"
+state    real  bscoef1         ikj     misc        1         -      r       "BSCOEF1"               "bin 1 layer backscatter" "?"
+state    real  bscoef2         ikj     misc        1         -      r       "BSCOEF2"               "bin 2 layer backscatter" "?"
+state    real  bscoef3         ikj     misc        1         -      r       "BSCOEF3"               "bin 3 layer backscatter" "?"
+state    real  bscoef4         ikj     misc        1         -      r       "BSCOEF4"               "bin 4 layer backscatter" "?"
+state    real  l2aer          ikj=     misc        1         -      r       "L2AER"                 "legendre polynomial 2" "?"
+state    real  l3aer          ikj=     misc        1         -      r        "L3AER"                 "legendre polynomial 3" "?"
+state    real  l4aer          ikj=     misc        1         -      r        "L4AER"                 "legendre polynomial 4" "?"
+state    real  l5aer          ikj=     misc        1         -      r        "L5AER"                 "legendre polynomial 5" "?"
+state    real  l6aer          ikj=     misc        1         -      r        "L6AER"                 "legendre polynomial 6" "?"
+state    real  l7aer          ikj=     misc        1         -      r        "L7AER"                 "legendre polynomial 7" "?"
+
+# 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"
+
+#Additional SAPRCNOV non transported radicals
+state   real   hocoo       ikj     misc    1       -       r       "hocoo" "Radicals"      "ppm"
+state   real   bzno2_o     ikj     misc    1       -       r       "bzno2_o"       "Radicals"      "ppm"
+state   real   bz_o        ikj     misc    1       -       r       "bz_o"  "Radicals"      "ppm"
+state   real   tbu_o       ikj     misc    1       -       r       "tbu_o" "Radicals"      "ppm"
+
+# Chem Scalars
+state   real    -              ikjftb   chem        1         -     -    -                                       
+state   real   so2         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "so2"           "SO2 concentration"         "ppmv"
+state   real   sulf        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "sulf"          "SULF concentration"        "ppmv"
+state   real   no2         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no2"           "NO2 concentration"         "ppmv"
+state   real   no          ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no"            "NO concentration"          "ppmv"
+state   real   o3          ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "o3"            "O3 concentration"          "ppmv"
+state   real   hno3        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hno3"          "HNO3 concentration"        "ppmv"
+state   real   h2o2        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "h2o2"          "H2O2 concentration"        "ppmv"
+state   real   ald         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ald"           "ALD concentration"         "ppmv"
+state   real   hcho        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hcho"          "HCHO concentration"        "ppmv"
+state   real   op1         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "op1"           "OP1 concentration"         "ppmv"
+state   real   op2         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "op2"           "OP2 concentration"         "ppmv"
+state   real   paa         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "paa"           "PAA concentration"         "ppmv"
+state   real   ora1        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ora1"          "ORA1 concentration"        "ppmv"
+state   real   ora2        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ora2"          "ORA2 concentration"        "ppmv"
+state   real   nh3         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh3"           "NH3 concentration"         "ppmv"
+state   real   n2o5        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "n2o5"          "N2O5 concentration"        "ppmv"
+state   real   no3         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3"           "NO3 concentration"         "ppmv"
+state   real   pan         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pan"           "PAN concentration"         "ppmv"
+state   real   hc3         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hc3"           "HC3 concentration"         "ppmv"
+state   real   hc5         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hc5"           "HC5 concentration"         "ppmv"
+state   real   hc8         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hc8"           "HC8 concentration"         "ppmv"
+state   real   eth         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "eth"           "ETH concentration"         "ppmv"
+state   real   co          ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "co"            "CO concentration"          "ppmv"
+state   real   ol2         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ol2"           "OL2 concentration"         "ppmv"
+state   real   olt         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "olt"           "OLT concentration"         "ppmv"
+state   real   oli         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oli"           "OLI concentration"         "ppmv"
+state   real   tol         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tol"           "TOL concentration"         "ppmv"
+state   real   xyl         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "xyl"           "XYL concentration"         "ppmv"
+state   real   aco3        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aco3"          "ACO3 concentration"        "ppmv"
+state   real   tpan        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tpan"          "TPAN concentration"        "ppmv"
+state   real   hono        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hono"          "HONO concentration"        "ppmv"
+state   real   hno4        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hno4"          "HNO4 concentration"        "ppmv"
+state   real   ket         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ket"           "KET concentration"         "ppmv"
+state   real   gly         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "gly"           "GLY concentration"         "ppmv"
+state   real   mgly        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "mgly"          "MGLY concentration"        "ppmv"
+state   real   dcb         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "dcb"           "DCB concentration"         "ppmv"
+state   real   onit        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "onit"          "ONIT concentration"        "ppmv"
+state   real   csl         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "csl"           "CSL concentration"         "ppmv"
+state   real   iso         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "iso"           "ISO concentration"         "ppmv"
+state   real   ho          ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ho"            "HO concentration"          "ppmv"
+state   real   ho2         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ho2"           "HO2 concentration"         "ppmv"
+state   real   aro1        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro1"          "ARO1 concentration"        "ppmv"
+state   real   aro2        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro2"          "ARO2 concentration"        "ppmv"
+state   real   alk1        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "alk1"          "ALK1 concentration"        "ppmv"
+state   real   ole1        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ole1"          "OLE1 concentration"        "ppmv"
+state   real   api1        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api1"          "API1 concentration"        "ppmv"
+state   real   api2        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api2"          "API2 concentration"        "ppmv"
+state   real   lim1        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim1"          "LIM1 concentration"        "ppmv"
+state   real   lim2        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim2"          "LIM2 concentration"        "ppmv"
+state   real   psd1        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "psd1"          "LIM2 concentration"        "ppmv"
+state   real   psd2        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "psd2"          "LIM2 concentration"        "ppmv"
+state   real   nume        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nume"          "LIM2 concentration"        "ppmv"
+state   real   den         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "den"           "LIM2 concentration"        "ppmv"
+state   real   pcg1_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_c"      "pcg1_b_c concentration"     "ppmv"
+state   real   pcg2_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_c"      "pcg2_b_c concentration"     "ppmv"
+state   real   pcg3_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_c"      "pcg3_b_c concentration"     "ppmv"
+state   real   pcg4_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_c"      "pcg4_b_c concentration"     "ppmv"
+state   real   pcg5_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_c"      "pcg5_b_c concentration"     "ppmv"
+state   real   pcg6_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_c"      "pcg6_b_c concentration"     "ppmv"
+state   real   pcg7_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_c"      "pcg7_b_c concentration"     "ppmv"
+state   real   pcg8_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_c"      "pcg8_b_c concentration"     "ppmv"
+state   real   pcg9_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_c"      "pcg9_b_c concentration"     "ppmv"
+state   real   pcg1_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_o"      "pcg1_b_o concentration"     "ppmv"
+state   real   pcg2_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_o"      "pcg2_b_o concentration"     "ppmv"
+state   real   pcg3_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_o"      "pcg3_b_o concentration"     "ppmv"
+state   real   pcg4_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_o"      "pcg4_b_o concentration"     "ppmv"
+state   real   pcg5_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_o"      "pcg5_b_o concentration"     "ppmv"
+state   real   pcg6_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_o"      "pcg6_b_o concentration"     "ppmv"
+state   real   pcg7_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_o"      "pcg7_b_o concentration"     "ppmv"
+state   real   pcg8_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_o"      "pcg8_b_o concentration"     "ppmv"
+state   real   pcg9_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_o"      "pcg9_b_o concentration"     "ppmv"
+state   real   pcg1_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_c"      "pcg1_f_c concentration"     "ppmv"
+state   real   pcg2_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_c"      "pcg2_f_c concentration"     "ppmv"
+state   real   pcg3_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_c"      "pcg3_f_c concentration"     "ppmv"
+state   real   pcg4_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_c"      "pcg4_f_c concentration"     "ppmv"
+state   real   pcg5_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_c"      "pcg5_f_c concentration"     "ppmv"
+state   real   pcg6_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_c"      "pcg6_f_c concentration"     "ppmv"
+state   real   pcg7_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_c"      "pcg7_f_c concentration"     "ppmv"
+state   real   pcg8_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_c"      "pcg8_f_c concentration"     "ppmv"
+state   real   pcg9_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_c"      "pcg9_f_c concentration"     "ppmv"
+state   real   pcg1_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_o"      "pcg1_f_o concentration"     "ppmv"
+state   real   pcg2_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_o"      "pcg2_f_o concentration"     "ppmv"
+state   real   pcg3_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_o"      "pcg3_f_o concentration"     "ppmv"
+state   real   pcg4_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_o"      "pcg4_f_o concentration"     "ppmv"
+state   real   pcg5_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_o"      "pcg5_f_o concentration"     "ppmv"
+state   real   pcg6_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_o"      "pcg6_f_o concentration"     "ppmv"
+state   real   pcg7_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_o"      "pcg7_f_o concentration"     "ppmv"
+state   real   pcg8_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_o"      "pcg8_f_o concentration"     "ppmv"
+state   real   pcg9_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_o"      "pcg9_f_o concentration"     "ppmv"
+state   real   opcg1_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_c"      "opcg1_b_c concentration"     "ppmv"
+state   real   opcg2_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_c"      "opcg2_b_c concentration"     "ppmv"
+state   real   opcg3_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_c"      "opcg3_b_c concentration"     "ppmv"
+state   real   opcg4_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_c"      "opcg4_b_c concentration"     "ppmv"
+state   real   opcg5_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_c"      "opcg5_b_c concentration"     "ppmv"
+state   real   opcg6_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_c"      "opcg6_b_c concentration"     "ppmv"
+state   real   opcg7_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_c"      "opcg7_b_c concentration"     "ppmv"
+state   real   opcg8_b_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_c"      "opcg8_b_c concentration"     "ppmv"
+state   real   opcg1_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_o"      "opcg1_b_o concentration"     "ppmv"
+state   real   opcg2_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_o"      "opcg2_b_o concentration"     "ppmv"
+state   real   opcg3_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_o"      "opcg3_b_o concentration"     "ppmv"
+state   real   opcg4_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_o"      "opcg4_b_o concentration"     "ppmv"
+state   real   opcg5_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_o"      "opcg5_b_o concentration"     "ppmv"
+state   real   opcg6_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_o"      "opcg6_b_o concentration"     "ppmv"
+state   real   opcg7_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_o"      "opcg7_b_o concentration"     "ppmv"
+state   real   opcg8_b_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_o"      "opcg8_b_o concentration"     "ppmv"
+state   real   opcg1_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_c"      "opcg1_f_c concentration"     "ppmv"
+state   real   opcg2_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_c"      "opcg2_f_c concentration"     "ppmv"
+state   real   opcg3_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_c"      "opcg3_f_c concentration"     "ppmv"
+state   real   opcg4_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_c"      "opcg4_f_c concentration"     "ppmv"
+state   real   opcg5_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_c"      "opcg5_f_c concentration"     "ppmv"
+state   real   opcg6_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_c"      "opcg6_f_c concentration"     "ppmv"
+state   real   opcg7_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_c"      "opcg7_f_c concentration"     "ppmv"
+state   real   opcg8_f_c    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_c"      "opcg8_f_c concentration"     "ppmv"
+state   real   opcg1_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_o"      "opcg1_f_o concentration"     "ppmv"
+state   real   opcg2_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_o"      "opcg2_f_o concentration"     "ppmv"
+state   real   opcg3_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_o"      "opcg3_f_o concentration"     "ppmv"
+state   real   opcg4_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_o"      "opcg4_f_o concentration"     "ppmv"
+state   real   opcg5_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_o"      "opcg5_f_o concentration"     "ppmv"
+state   real   opcg6_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_o"      "opcg6_f_o concentration"     "ppmv"
+state   real   opcg7_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_o"      "opcg7_f_o concentration"     "ppmv"
+state   real   opcg8_f_o    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_o"      "opcg8_f_o concentration"     "ppmv"
+state   real   ant1_c       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant1_c"         "ant1_c concentration"        "ppmv"
+state   real   ant2_c       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant2_c"         "ant2_c concentration"        "ppmv"
+state   real   ant3_c       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant3_c"         "ant3_c concentration"        "ppmv"
+state   real   ant4_c       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant4_c"         "ant4_c concentration"        "ppmv"
+state   real   ant1_o       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant1_o"         "ant1_o concentration"        "ppmv"
+state   real   ant2_o       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant2_o"         "ant2_o concentration"        "ppmv"
+state   real   ant3_o       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant3_o"         "ant3_o concentration"        "ppmv"
+state   real   ant4_o       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant4_o"         "ant4_o concentration"        "ppmv"
+state   real   biog1_c       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog1_c"         "biog1_c concentration"        "ppmv"
+state   real   biog2_c       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog2_c"         "biog2_c concentration"        "ppmv"
+state   real   biog3_c       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog3_c"         "biog3_c concentration"        "ppmv"
+state   real   biog4_c       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog4_c"         "biog4_c concentration"        "ppmv"
+state   real   biog1_o       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog1_o"         "biog1_o concentration"        "ppmv"
+state   real   biog2_o       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog2_o"         "biog2_o concentration"        "ppmv"
+state   real   biog3_o       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog3_o"         "biog3_o concentration"        "ppmv"
+state   real   biog4_o       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog4_o"         "biog4_o 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         -   i0{12}rhusdf=(bdy_interp:dt)   "ete"           "ETE concentration"         "ppmv"
+state   real   co2         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)   "co2"           "CO2 concentration"         "ppmv"
+state   real   ch4         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)   "ch4"           "CH4 concentration"         "ppmv"
+state   real   udd         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)   "udd"           "UDD concentration"         "ppmv"
+state   real   hket        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)   "hket"          "HKET concentration"        "ppmv"
+state   real   api         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)   "api"           "API concentration"         "ppmv"
+state   real   lim         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)   "lim"           "LIM concentration"         "ppmv"
+state   real   dien        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)   "dien"          "DIEN concentration"        "ppmv"
+state   real   macr        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)   "macr"          "MACR concentration"        "ppmv"
+
+#Additional CBMZ gas variables inside the chem array...
+
+state   real   hcl         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hcl"           "HCL concentration"         "ppmv"
+state   real   ch3o2       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ch3o2"         "CH3O2 concentration"       "ppmv"
+state   real   ethp        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ethp"          "ETHP concentration"        "ppmv"
+state   real   ch3oh       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ch3oh"         "CH3OH concentration"       "ppmv"
+state   real   c2h5oh      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "c2h5oh"        "C2H5OH concentration"      "ppmv"
+state   real   par         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "par"           "PAR concentration"         "ppmv"
+state   real   to2         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "to2"           "TO2 concentration"         "ppmv"
+state   real   cro         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "cro"           "CRO concentration"         "ppmv"
+state   real   open        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "open"          "OPEN concentration"        "ppmv"
+state   real   op3         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "op3"           "OP3 concentration"         "ppmv"
+state   real   c2o3        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "c2o3"          "C2O3 concentration"        "ppmv"
+state   real   ro2         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ro2"           "RO2 concentration"         "ppmv"
+state   real   ano2        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ano2"          "ANO2 concentration"        "ppmv"
+state   real   nap         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nap"           "NAP concentration"         "ppmv"
+state   real   xo2         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "xo2"           "XO2 concentration"         "ppmv"
+state   real   xpar        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "xpar"          "XPAR concentration"        "ppmv"
+state   real   isoprd      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "isoprd"        "ISOPRD concentration"      "ppmv"
+state   real   isopp       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "isopp"         "ISOPP concentration"       "ppmv"
+state   real   isopn       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "isopn"         "ISOPN concentration"       "ppmv"
+state   real   isopo2      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "isopo2"        "ISOPO2 concentration"      "ppmv"
+state   real   dms         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "dms"           "DMS concentration"         "ppmv"
+state   real   msa         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa"           "MSA concentration"         "ppmv"
+state   real   dmso        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "dmso"          "DMSO concentration"        "ppmv"
+state   real   dmso2       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "dmso2"         "DMSO2 concentration"       "ppmv"
+state   real   ch3so2h     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ch3so2h"       "CH3SO2H concentration"     "ppmv"
+state   real   ch3sch2oo   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ch3sch2oo"     "CH3SCH2OO concentration"   "ppmv"
+state   real   ch3so2      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ch3so2"        "CH3SO2 concentration"      "ppmv"
+state   real   ch3so3      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ch3so3"        "CH3SO3 concentration"      "ppmv"
+state   real   ch3so2oo    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ch3so2oo"      "CH3SO2OO concentration"    "ppmv"
+state   real   ch3so2ch2oo ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ch3so2ch2oo"   "CH3SO2CH2OO concentration" "ppmv"
+state   real   mtf         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "mtf"           "MTF concentration"         "ppmv"
+
+#Additional CBM4 gas variables inside the chem array...
+
+state   real   ald2        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ald2"          "ALD2 concentration"        "ppmv"
+state   real   ror         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ror"           "ROR concentration"         "ppmv"
+state   real   ole         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ole"           "OLE concentration"         "ppmv"
+state   real   cres        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "cres"          "CRES concentration"        "ppmv"
+state   real   xo2n        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "xo2n"          "XO2N concentration"        "ppmv"
+state   real   pna         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pna"           "PNA  concentration"        "ppmv"
+state   real   o           ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "o"             "o    concentration"        "ppmv"
+state   real   o1d_cb4     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "o1d_cb4"       "o1d_cb4 concentration"     "ppmv"
+#Additional MOZART gas variables inside the chem array...
+state   real   n2o         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "n2o"           "N2O  concentration"        "ppmv"
+state   real   ch3ooh      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ch3ooh"        "CH3OOH  concentration"        "ppmv"
+state   real   h2          ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "h2"            "H2  concentration"        "ppmv"
+state   real   so4         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4"           "SO4  concentration"        "ppmv"
+state   real   eo2         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "eo2"           "EO2  concentration"        "ppmv"
+state   real   mco3        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "mco3"          "MCO3 concentration"        "ppmv"
+state   real   xooh        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "xooh"          "XOOH concentration"        "ppmv"
+state   real   onitr       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "onitr"         "ONITR concentration"        "ppmv"
+state   real   glyald      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "glyald"        "GLYALD concentration"        "ppmv"
+state   real   alkooh      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "alkooh"        "ALKOOH concentration"        "ppmv"
+state   real   tolooh      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tolooh"        "TOLOOH concentration"        "ppmv"
+state   real   terpooh     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "terpooh"       "TERPOOH concentration"        "ppmv"
+state   real   nh4         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4"           "NH4 concentration"        "ppmv"
+state   real   eo          ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "eo"            "EO concentration"        "ppmv"
+state   real   po2         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "po2"           "PO2 concentration"        "ppmv"
+state   real   bigene      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "bigene"        "BIGENE concentration"        "ppmv"
+state   real   bigalk      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "bigalk"        "BIGALK concentration"        "ppmv"
+state   real   eneo2       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "eneo2"         "ENEO2 concentration"        "ppmv"
+state   real   alko2       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "alko2"         "ALKO2 concentration"        "ppmv"
+state   real   hydrald     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hydrald"       "HYDRALD concentration"        "ppmv"
+state   real   c10h16      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "c10h16"        "C10H16 concentration"        "ppmv"
+state   real   terpo2      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "terpo2"        "TERPO2 concentration"        "ppmv"
+state   real   tolo2       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tolo2"         "TOLO2 concentration"        "ppmv"
+state   real   xoh         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "xoh"           "XOH concentration"        "ppmv"
+#volcanic ash variables inside the chem array...
+#
+state   real   vash_1    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "vash_1"             "vash1    concentration"        "ug/m3"
+state   real   vash_2    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "vash_2"             "vash2  concentration  "        "ug/m3"
+state   real   vash_3    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "vash_3"             "vash3    concentration"        "ug/m3"
+state   real   vash_4    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "vash_4"             "vash4    concentration"        "ug/m3"
+state   real   vash_5    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "vash_5"             "vash5    concentration"        "ug/m3"
+state   real   vash_6    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "vash_6"             "vash6    concentration"        "ug/m3"
+state   real   vash_7    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "vash_7"             "vash7    concentration"        "ug/m3"
+state   real   vash_8    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "vash_8"             "vash8    concentration"        "ug/m3"
+state   real   vash_9    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "vash_9"             "vash9    concentration"        "ug/m3"
+state   real   vash_10    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "vash_10"             "vash10    concentration"        "ug/m3"
+
+
+#tracer variables inside the chem array...for ensemble run or not
+#
+state   real   tracer_1    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_1"             "tracer1    mix ratio"        "ppmv"
+state   real   tracer_2    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_2"             "tracer2    mix ratio"        "ppmv"
+state   real   tracer_3    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_3"             "tracer3    mix ratio"        "ppmv"
+state   real   tracer_4    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_4"             "tracer4    mix ratio"        "ppmv"
+state   real   tracer_5    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_5"             "tracer5    mix ratio"        "ppmv"
+state   real   tracer_6    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_6"             "tracer6    mix ratio"        "ppmv"
+state   real   tracer_7    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_7"             "tracer7    mix ratio"        "ppmv"
+state   real   tracer_8    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_8"             "tracer8    mix ratio"        "ppmv"
+state   real   tracer_9    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_9"             "tracer9    mix ratio"        "ppmv"
+state   real   tracer_10    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_10"             "tracer10    mix ratio"        "ppmv"
+state   real   tracer_11    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_11"             "tracer11    mix ratio"        "ppmv"
+state   real   tracer_12    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_12"             "tracer12    mix ratio"        "ppmv"
+state   real   tracer_13    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_13"             "tracer13    mix ratio"        "ppmv"
+state   real   tracer_14    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_14"             "tracer14    mix ratio"        "ppmv"
+state   real   tracer_15    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_15"             "tracer15    mix ratio"        "ppmv"
+state   real   tracer_16    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_16"             "tracer16    mix ratio"        "ppmv"
+state   real   tracer_17    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_17"             "tracer17    mix ratio"        "ppmv"
+state   real   tracer_18    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_18"             "tracer18    mix ratio"        "ppmv"
+state   real   tracer_19    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_19"             "tracer19    mix ratio"        "ppmv"
+state   real   tracer_20    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_20"             "tracer20    mix ratio"        "ppmv"
+state   real   tracer_ens    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "tracer_ens"             "tracer- ensemble average    mix ratio"        "ppmv"
+
+state   real    -          ikjftb  tracer        1         -     -    -                                       
+state   real    smoke      ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "smoke"         "tracing smoke"          -
+#state   real    tr17_0     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr17_0"         "tr17_0"          -
+state   real    tr17_1     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr17_1"         "tr17_1"          -
+state   real    tr17_2     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr17_2"         "tr17_2"          -
+state   real    tr17_3     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr17_3"         "tr17_3"          -
+state   real    tr17_4     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr17_4"         "tr17_4"          -
+state   real    tr17_5     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr17_5"         "tr17_5"          -
+state   real    tr17_6     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr17_6"         "tr17_6"          -
+state   real    tr17_7     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr17_7"         "tr17_7"          -
+state   real    tr17_8     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr17_8"         "tr17_8"          -
+#state   real    tr17_9     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr17_9"         "tr17_9"          -
+state   real    tr18_0     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr18_0"         "tr18_0"          -
+state   real    tr18_1     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr18_1"         "tr18_1"          -
+state   real    tr18_2     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr18_2"         "tr18_2"          -
+state   real    tr18_3     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr18_3"         "tr18_3"          -
+state   real    tr18_4     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr18_4"         "tr18_4"          -
+state   real    tr18_5     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr18_5"         "tr18_5"          -
+state   real    tr18_6     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr18_6"         "tr18_6"          -
+state   real    tr18_7     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr18_7"         "tr18_7"          -
+state   real    tr18_8     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr18_8"         "tr18_8"          -
+state   real    tr18_9     ikjftb  tracer        1         -     i8rhusdf=(bdy_interp:dt)    "tr18_9"         "tr18_9"          -
+
+#SAPRCNOV additional variables, automatically created using diff_mechanisSpc_wrfRegistry.m script (pablo-saide@uiowa.edu)
+state   real    h2so4           ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "h2so4" "H2SO4 concentration"   "ppmv"
+state   real    ccho            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "ccho"  "CCHO concentration"    "ppmv"
+state   real    rcho            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "rcho"  "RCHO concentration"    "ppmv"
+state   real    etoh            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "etoh"  "ETOH concentration"    "ppmv"
+state   real    cco_oh          ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "cco_oh"        "CCO_OH concentration"  "ppmv"
+state   real    rco_oh          ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "rco_oh"        "RCO_OH concentration"  "ppmv"
+state   real    bacl            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "bacl"  "BACL concentration"    "ppmv"
+state   real    bald            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "bald"  "BALD concentration"    "ppmv"
+state   real    isoprod         ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "isoprod"       "ISOPROD concentration" "ppmv"
+state   real    methacro        ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "methacro"      "METHACRO concentration"        "ppmv"
+state   real    prod2           ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "prod2" "PROD2 concentration"   "ppmv"
+state   real    dcb1            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "dcb1"  "DCB1 concentration"    "ppmv"
+state   real    dcb2            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "dcb2"  "DCB2 concentration"    "ppmv"
+state   real    dcb3            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "dcb3"  "DCB3 concentration"    "ppmv"
+state   real    ethene          ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "ethene"        "ETHENE concentration"  "ppmv"
+state   real    isoprene        ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "isoprene"      "ISOPRENE concentration"        "ppmv"
+state   real    c2h2            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "c2h2"  "C2H2 concentration"    "ppmv"
+state   real    alk3            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "alk3"  "ALK3 concentration"    "ppmv"
+state   real    alk4            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "alk4"  "ALK4 concentration"    "ppmv"
+state   real    alk5            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "alk5"  "ALK5 concentration"    "ppmv"
+state   real    ole2            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "ole2"  "OLE2 concentration"    "ppmv"
+state   real    terp            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "terp"  "TERP concentration"    "ppmv"
+state   real    sesq            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_insesq:dt) "sesq"  "SESQ concentration"    "ppmv"
+state   real    rno3            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "rno3"  "RNO3 concentration"    "ppmv"
+state   real    nphe            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "nphe"  "NPHE concentration"    "ppmv"
+state   real    phen            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "phen"  "PHEN concentration"    "ppmv"
+state   real    pan2            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "pan2"  "PAN2 concentration"    "ppmv"
+state   real    pbzn            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "pbzn"  "PBZN concentration"    "ppmv"
+state   real    ma_pan          ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "ma_pan"        "MA_PAN concentration"  "ppmv"
+state   real    bc_spr          ikjftb  chem    1       -       i1{12}rusdf=(bdy_interp:dt)  "bc_spr"        "BC_SPR concentration"  "ppmv"
+state   real    oc_spr          ikjftb  chem    1       -       i1{12}rusdf=(bdy_interp:dt)  "oc_spr"        "OC_SPR concentration"  "ppmv"
+state   real    ssf             ikjftb  chem    1       -       i1{12}rusdf=(bdy_interp:dt)  "ssf"   "SSF concentration"     "ppmv"
+state   real    ssc             ikjftb  chem    1       -       i1{12}rusdf=(bdy_interp:dt)  "ssc"   "SSC concentration"     "ppmv"
+state   real    pm10_spr        ikjftb  chem    1       -       i1{12}rusdf=(bdy_interp:dt)  "pm10_spr"      "PM10_SPR concentration"        "ppmv"
+state   real    pm25_spr        ikjftb  chem    1       -       i1{12}rusdf=(bdy_interp:dt)  "pm25_spr"      "PM25_SPR concentration"        "ppmv"
+state   real    dst1            ikjftb  chem    1       -       i1{12}rusdf=(bdy_interp:dt)  "dst1"  "DST1 concentration"    "ppmv"
+state   real    dst2            ikjftb  chem    1       -       i1{12}rusdf=(bdy_interp:dt)  "dst2"  "DST2 concentration"    "ppmv"
+state   real    dst3            ikjftb  chem    1       -       i1{12}rusdf=(bdy_interp:dt)  "dst3"  "DST3 concentration"    "ppmv"
+state   real    cco_ooh         ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "cco_ooh"       "CCO_OOH concentration" "ppmv"
+state   real    rco_o2          ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "rco_o2"        "RCO_O2 concentration"  "ppmv"
+state   real    rco_ooh         ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "rco_ooh"       "RCO_OOH concentration" "ppmv"
+state   real    xn              ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "xn"    "XN concentration"      "ppmv"
+state   real    xc              ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "xc"    "XC concentration"      "ppmv"
+state   real    c_o2            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "c_o2"  "C_O2 concentration"    "ppmv"
+state   real    cooh            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "cooh"  "COOH concentration"    "ppmv"
+state   real    rooh            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "rooh"  "ROOH concentration"    "ppmv"
+state   real    ro2_r           ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "ro2_r" "RO2_R concentration"   "ppmv"
+state   real    r2o2            ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "r2o2"  "R2O2 concentration"    "ppmv"
+state   real    ro2_n           ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "ro2_n" "RO2_N concentration"   "ppmv"
+state   real    cco_o2          ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "cco_o2"        "CCO_O2 concentration"  "ppmv"
+state   real    bzco_o2         ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "bzco_o2"       "BZCO_O2 concentration" "ppmv"
+state   real    ma_rco3         ikjftb  chem    1       -       i0{12}rhusdf=(bdy_interp:dt) "ma_rco3"       "MA_RCO3 concentration" "ppmv"
+
+
+#Aerosol variables inside the chem array...
+# the first two are for simple advection of total pm25 and pm10 mass
+#
+state   real   pm_25         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pm_25"           "pm2.5 concentration"         "ug/kg-dryair"
+state   real   pm_10         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "pm_10"           "pm10 concentration"         "ug/kg-dryair"
+# aerosol variables for MADE/SORGAM
+state   real   so4aj       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4aj"         "Sulfate conc. Acc. mode"       "ug/kg-dryair"
+state   real   so4ai       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4ai"         "Sulfate conc. Aitken mode"       "ug/kg-dryair"
+state   real   nh4aj       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4aj"         "Ammonium conc. Acc. mode"       "ug/kg-dryair"
+state   real   nh4ai       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4ai"         "Ammonium  conc. Aitken mode"       "ug/kg-dryair"
+state   real   no3aj       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3aj"         "Nitrate  conc. Acc. mode"       "ug/kg-dryair"
+state   real   no3ai       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3ai"         "Nitrate  conc. Aitken mode"       "ug/kg-dryair"
+state   real   naaj        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "naaj"          "Sodium   conc. Acc. mode"       "ug/kg-dryair"
+state   real   naai        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "naai"          "Sodium   conc. Aitken mode"       "ug/kg-dryair"
+state   real   claj        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "claj"          "Chloride conc. Acc. mode"       "ug/kg-dryair"
+state   real   clai        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "clai"          "Chloride conc. Aitken mode"       "ug/kg-dryair"
+state   real   orgaro1j    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgaro1j"      "SOA Anth. org. conc. from aromatics Acc. mode"    "ug/kg-dryair"
+state   real   orgaro1i    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgaro1i"      "SOA Anth. org. conc. from aromatics Aitken mode"    "ug/kg-dryair"
+state   real   orgaro2j    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgaro2j"      "SOA Anth. org. conc. from aromatics Acc. mode"    "ug/kg-dryair"
+state   real   orgaro2i    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgaro2i"      "SOA Anth. org. conc. from aromatics Aitken mode"    "ug/kg-dryair"
+state   real   orgalk1j    ikjftb   chem        1         -   i0{12}rhusdf=(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         -   i0{12}rhusdf=(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         -   i0{12}rhusdf=(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         -   i0{12}rhusdf=(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         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba1j"       "SOA Biog. org. conc. from aromatics Acc. mode"     "ug/kg-dryair"
+state   real   orgba1i     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba1i"       "SOA Biog. org. conc. from aromatics Aitken mode"     "ug/kg-dryair"
+state   real   orgba2j     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba2j"       "SOA Biog. org. conc. from aromatics Acc. mode"     "ug/kg-dryair"
+state   real   orgba2i     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba2i"       "SOA Biog. org. conc. from aromatics Aitken mode"     "ug/kg-dryair"
+state   real   orgba3j     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba3j"       "SOA Biog. org. conc. from aromatics Acc. mode"     "ug/kg-dryair"
+state   real   orgba3i     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba3i"       "SOA Biog. org. conc. from aromatics Aitken mode"     "ug/kg-dryair"
+state   real   orgba4j     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba4j"       "SOA Biog. org. conc. from aromatics Acc. mode"     "ug/kg-dryair"
+state   real   orgba4i     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba4i"       "SOA Biog. org. conc. from aromatics Aitken mode"     "ug/kg-dryair"
+state   real   orgpaj      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgpaj"        "Prim. anth. org. conc. from aromatics Acc. mode"      "ug/kg-dryair"
+state   real   orgpai      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgpai"        "Prim. anth. org. conc. from aromatics Aitken mode"      "ug/kg-dryair"
+state   real   ecj         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ecj"           "Elemental carbon Acc. mode"         "ug/kg-dryair"
+state   real   eci         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "eci"           "Elemental carbon Aitken mode"         "ug/kg-dryair"
+state   real   p25j        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "p25j"          "Primary PM2.5 Acc. mode"        "ug/kg-dryair"
+state   real   p25i        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "p25i"          "Primary PM2.5 Aitken mode"        "ug/kg-dryair"
+state   real   antha       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "antha"         "Coarse anthropogenic aerosols"       "ug/kg-dryair"
+state   real   seas        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "seas"          "Coarse marine aerosols"        "ug/kg-dryair"
+state   real   soila       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "soila"         "Coarse soil-derived aerosols"       "ug/kg-dryair"
+state   real   nu0         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nu0"           "Aitken mode number"         "#/kg-dryair"
+state   real   ac0         ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ac0"           "Accumulation mode number"         "#/kg-dryair"
+state   real   corn        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "corn"          "Coarse mode number"        "#/kg-dryair"
+#cloud-phase aerosol
+state   real   so4cwj      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4cwj"         "Sulfate conc. Acc. mode in cloud"       "ug/kg-dryair"
+state   real   so4cwi      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4cwi"         "Sulfate conc. Aitken mode in cloud"       "ug/kg-dryair"
+state   real   nh4cwj      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4cwj"         "Ammonium conc. Acc. mode in cloud"       "ug/kg-dryair"
+state   real   nh4cwi      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4cwi"         "Ammonium  conc. Aitken mode in cloud"       "ug/kg-dryair"
+state   real   no3cwj      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3cwj"         "Nitrate  conc. Acc. mode in cloud"       "ug/kg-dryair"
+state   real   no3cwi      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3cwi"         "Nitrate  conc. Aitken mode in cloud"       "ug/kg-dryair"
+state   real   nacwj       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nacwj"          "Sodium  conc. Acc. mode in cloud"       "ug/kg-dryair"
+state   real   nacwi       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nacwi"          "Sodium  conc. Aitken mode in cloud"       "ug/kg-dryair"
+state   real   clcwj       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "clcwj"          "Chloride  conc. Acc. mode in cloud"       "ug/kg-dryair"
+state   real   clcwi       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "clcwi"          "Chloride  conc. Aitken mode in cloud"       "ug/kg-dryair"
+state   real   orgaro1cwj  ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgaro1cwj"     "SOA Anth. org. conc. from aromatics Acc. mode in cloud"    "ug/kg-dryair"
+state   real   orgaro1cwi  ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgaro1cwi"     "SOA Anth. org. conc. from aromatics Aitken mode in cloud"    "ug/kg-dryair"
+state   real   orgaro2cwj  ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgaro2cwj"     "SOA Anth. org. conc. from aromatics Acc. mode in cloud"    "ug/kg-dryair"
+state   real   orgaro2cwi  ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgaro2cwi"     "SOA Anth. org. conc. from aromatics Aitken mode in cloud"    "ug/kg-dryair"
+state   real   orgalk1cwj  ikjftb   chem        1         -   i0{12}rhusdf=(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         -   i0{12}rhusdf=(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         -   i0{12}rhusdf=(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         -   i0{12}rhusdf=(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         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba1cwj"      "SOA Biog. org. conc. from aromatics Acc. mode in cloud"     "ug/kg-dryair"
+state   real   orgba1cwi   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba1cwi"      "SOA Biog. org. conc. from aromatics Aitken mode in cloud"     "ug/kg-dryair"
+state   real   orgba2cwj   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba2cwj"      "SOA Biog. org. conc. from aromatics Acc. mode in cloud"     "ug/kg-dryair"
+state   real   orgba2cwi   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba2cwi"      "SOA Biog. org. conc. from aromatics Aitken mode in cloud"     "ug/kg-dryair"
+state   real   orgba3cwj   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba3cwj"      "SOA Biog. org. conc. from aromatics Acc. mode in cloud"     "ug/kg-dryair"
+state   real   orgba3cwi   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba3cwi"      "SOA Biog. org. conc. from aromatics Aitken mode in cloud"     "ug/kg-dryair"
+state   real   orgba4cwj   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba4cwj"      "SOA Biog. org. conc. from aromatics Acc. mode in cloud"     "ug/kg-dryair"
+state   real   orgba4cwi   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgba4cwi"      "SOA Biog. org. conc. from aromatics Aitken mode in cloud"     "ug/kg-dryair"
+state   real   orgpacwj    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgpacwj"       "Prim. anth. org. conc. from aromatics Acc. mode in cloud"      "ug/kg-dryair"
+state   real   orgpacwi    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "orgpacwi"       "Prim. anth. org. conc. from aromatics Aitken mode in cloud"      "ug/kg-dryair"
+state   real   eccwj       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "eccwj"          "Elemental carbon Acc. mode in cloud"         "ug/kg-dryair"
+state   real   eccwi       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "eccwi"          "Elemental carbon Aitken mode in cloud"         "ug/kg-dryair"
+state   real   p25cwj      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "p25cwj"         "Primary PM2.5 Acc. mode in cloud"        "ug/kg-dryair"
+state   real   p25cwi      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "p25cwi"         "Primary PM2.5 Aitken mode in cloud"        "ug/kg-dryair"
+state   real   anthcw      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "anthcw"         "Coarse anthropogenic aerosols in cloud"       "ug/kg-dryair"
+state   real   seascw      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "seascw"         "Coarse marine aerosols in cloud"        "ug/kg-dryair"
+state   real   soilcw      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "soilcw"         "Coarse soil-derived aerosols in cloud"       "ug/kg-dryair"
+state   real   nu0cw       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nu0cw"          "Aitken mode number in cloud"         "#/kg-dryair"
+state   real   ac0cw       ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ac0cw"          "Accumulation mode number in cloud"         "#/kg-dryair"
+state   real   corncw      ikjftb   chem        1         -   i0{12}rhusdf=(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         -   i0{12}rhusdf=(bdy_interp:dt)        "hace"              "HACE concentration"      "ppm"
+state   real   ishp        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)        "ishp"              "ISHP concentration"      "ppm"
+state   real   ison        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)        "ison"              "ISON concentration"      "ppm"
+state   real   mahp        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)        "mahp"              "MAHP concentration"      "ppm"
+state   real   mpan        ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)        "mpan"              "MPAN concentration"      "ppm"
+state   real   nald        ikjftb   chem        1         -   i0{12}rhusdf=(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         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_a01"       "Sulfate, aerosol bin 01"     "ug/kg-dryair"
+state   real   no3_a01     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_a01"       "Nitrate, aerosol bin 01"     "ug/kg-dryair"
+state   real   aro1_a01    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro1_a01"       "ARO1, aerosol bin 01"     "ug/kg-dryair"
+state   real   aro2_a01    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro2_a01"       "ARO2, aerosol bin 01"     "ug/kg-dryair"
+state   real   alk1_a01    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "alk1_a01"       "ALK1, aerosol bin 01"     "ug/kg-dryair"
+state   real   ole1_a01    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ole1_a01"       "OLE1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api1_a01    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api1_a01"       "API1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api2_a01    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api2_a01"       "API2, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim1_a01    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim1_a01"       "LIM1, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim2_a01    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim2_a01"       "LIM2, aerosol bin 01"     "ug/kg-dryair"
+state   real   pcg1_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_c_a01"    "pcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_c_a01"    "pcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_c_a01"    "pcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_c_a01"    "pcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_c_a01"    "pcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_c_a01"    "pcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_c_a01"    "pcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_c_a01"    "pcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_c_a01"    "pcg9_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_o_a01"    "pcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_o_a01"    "pcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_o_a01"    "pcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_o_a01"    "pcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_o_a01"    "pcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_o_a01"    "pcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_o_a01"    "pcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_o_a01"    "pcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_o_a01"    "pcg9_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_c_a01"    "pcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_c_a01"    "pcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_c_a01"    "pcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_c_a01"    "pcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_c_a01"    "pcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_c_a01"    "pcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_c_a01"    "pcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_c_a01"    "pcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_c_a01"    "pcg9_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_o_a01"    "pcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_o_a01"    "pcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_o_a01"    "pcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_o_a01"    "pcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_o_a01"    "pcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_o_a01"    "pcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_o_a01"    "pcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_o_a01"    "pcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_o_a01"    "pcg9_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_c_a01"    "opcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_c_a01"    "opcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_c_a01"    "opcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_c_a01"    "opcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_c_a01"    "opcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_c_a01"    "opcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_c_a01"    "opcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_c_a01"    "opcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_o_a01"    "opcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_o_a01"    "opcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_o_a01"    "opcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_o_a01"    "opcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_o_a01"    "opcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_o_a01"    "opcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_o_a01"    "opcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_o_a01"    "opcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_c_a01"    "opcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_c_a01"    "opcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_c_a01"    "opcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_c_a01"    "opcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_c_a01"    "opcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_c_a01"    "opcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_c_a01"    "opcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_c_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_c_a01"    "opcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_o_a01"    "opcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_o_a01"    "opcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_o_a01"    "opcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_o_a01"    "opcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_o_a01"    "opcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_o_a01"    "opcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_o_a01"    "opcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_o_a01  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_o_a01"    "opcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant1_c_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant1_c_a01"       "ant1_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant2_c_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant2_c_a01"       "ant2_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant3_c_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant3_c_a01"       "ant3_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant4_c_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant4_c_a01"       "ant4_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant1_o_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant1_o_a01"       "ant1_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant2_o_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant2_o_a01"       "ant2_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant3_o_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant3_o_a01"       "ant3_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant4_o_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant4_o_a01"       "ant4_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog1_c_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog1_c_a01"       "biog1_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog2_c_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog2_c_a01"       "biog2_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog3_c_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog3_c_a01"       "biog3_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog4_c_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog4_c_a01"       "biog4_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog1_o_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog1_o_a01"       "biog1_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog2_o_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog2_o_a01"       "biog2_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog3_o_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog3_o_a01"       "biog3_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog4_o_a01     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog4_o_a01"       "biog4_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   cl_a01      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_a01"        "Chloride, aerosol bin 01"      "ug/kg-dryair"
+state   real   msa_a01     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_a01"       "MSA, aerosol bin 01"     "ug/kg-dryair"
+state   real   co3_a01     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_a01"       "Carbonate, aerosol bin 01"     "ug/kg-dryair"
+state   real   nh4_a01     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_a01"       "Ammonium, aerosol bin 01"     "ug/kg-dryair"
+state   real   na_a01      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_a01"        "Sodium, aerosol bin 01"      "ug/kg-dryair"
+state   real   ca_a01      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_a01"        "Calcium, aerosol bin 01"      "ug/kg-dryair"
+state   real   oin_a01     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_a01"       "Other inorganics, aerosol bin 01"     "ug/kg-dryair"
+state   real   oc_a01      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_a01"        "Organic carbon, aerosol bin 01"      "ug/kg-dryair"
+state   real   bc_a01      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_a01"        "Black carbon, aerosol bin 01"      "ug/kg-dryair"
+state   real   hysw_a01    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hysw_a01"      "Hysteresis water, aerosol bin 01"    "ug/kg-dryair"
+state   real   water_a01   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "water_a01"     "Water, aerosol bin 01"   "ug/kg-dryair"
+state   real   num_a01     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_a01"       "Number, aerosol bin 01"     "#/kg-dryair"
+state   real   so4_a02     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_a02"       "Sulfate, aerosol bin 02"     "ug/kg-dryair"
+state   real   no3_a02     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_a02"       "Nitrate, aerosol bin 02"     "ug/kg-dryair"
+state   real   aro1_a02    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro1_a02"       "ARO1, aerosol bin 01"     "ug/kg-dryair"
+state   real   aro2_a02    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro2_a02"       "ARO2, aerosol bin 01"     "ug/kg-dryair"
+state   real   alk1_a02    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "alk1_a02"       "ALK1, aerosol bin 01"     "ug/kg-dryair"
+state   real   ole1_a02    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ole1_a02"       "OLE1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api1_a02    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api1_a02"       "API1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api2_a02    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api2_a02"       "API2, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim1_a02    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim1_a02"       "LIM1, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim2_a02    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim2_a02"       "LIM2, aerosol bin 01"     "ug/kg-dryair"
+state   real   pcg1_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_c_a02"    "pcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_c_a02"    "pcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_c_a02"    "pcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_c_a02"    "pcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_c_a02"    "pcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_c_a02"    "pcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_c_a02"    "pcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_c_a02"    "pcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_c_a02"    "pcg9_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_o_a02"    "pcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_o_a02"    "pcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_o_a02"    "pcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_o_a02"    "pcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_o_a02"    "pcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_o_a02"    "pcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_o_a02"    "pcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_o_a02"    "pcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_o_a02"    "pcg9_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_c_a02"    "pcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_c_a02"    "pcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_c_a02"    "pcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_c_a02"    "pcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_c_a02"    "pcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_c_a02"    "pcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_c_a02"    "pcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_c_a02"    "pcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_c_a02"    "pcg9_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_o_a02"    "pcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_o_a02"    "pcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_o_a02"    "pcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_o_a02"    "pcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_o_a02"    "pcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_o_a02"    "pcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_o_a02"    "pcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_o_a02"    "pcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_o_a02"    "pcg9_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_c_a02"    "opcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_c_a02"    "opcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_c_a02"    "opcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_c_a02"    "opcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_c_a02"    "opcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_c_a02"    "opcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_c_a02"    "opcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_c_a02"    "opcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_o_a02"    "opcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_o_a02"    "opcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_o_a02"    "opcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_o_a02"    "opcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_o_a02"    "opcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_o_a02"    "opcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_o_a02"    "opcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_o_a02"    "opcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_c_a02"    "opcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_c_a02"    "opcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_c_a02"    "opcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_c_a02"    "opcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_c_a02"    "opcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_c_a02"    "opcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_c_a02"    "opcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_c_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_c_a02"    "opcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_o_a02"    "opcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_o_a02"    "opcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_o_a02"    "opcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_o_a02"    "opcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_o_a02"    "opcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_o_a02"    "opcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_o_a02"    "opcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_o_a02  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_o_a02"    "opcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant1_c_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant1_c_a02"       "ant1_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant2_c_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant2_c_a02"       "ant2_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant3_c_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant3_c_a02"       "ant3_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant4_c_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant4_c_a02"       "ant4_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant1_o_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant1_o_a02"       "ant1_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant2_o_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant2_o_a02"       "ant2_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant3_o_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant3_o_a02"       "ant3_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant4_o_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant4_o_a02"       "ant4_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog1_c_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog1_c_a02"       "biog1_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog2_c_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog2_c_a02"       "biog2_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog3_c_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog3_c_a02"       "biog3_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog4_c_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog4_c_a02"       "biog4_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog1_o_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog1_o_a02"       "biog1_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog2_o_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog2_o_a02"       "biog2_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog3_o_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog3_o_a02"       "biog3_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog4_o_a02     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog4_o_a02"       "biog4_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   cl_a02      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_a02"        "Chloride, aerosol bin 02"      "ug/kg-dryair"
+state   real   msa_a02     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_a02"       "MSA, aerosol bin 02"     "ug/kg-dryair"
+state   real   co3_a02     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_a02"       "Carbonate, aerosol bin 02"     "ug/kg-dryair"
+state   real   nh4_a02     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_a02"       "Ammonium, aerosol bin 02"     "ug/kg-dryair"
+state   real   na_a02      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_a02"        "Sodium, aerosol bin 02"      "ug/kg-dryair"
+state   real   ca_a02      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_a02"        "Calcium, aerosol bin 02"      "ug/kg-dryair"
+state   real   oin_a02     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_a02"       "Other inorganics, aerosol bin 02"     "ug/kg-dryair"
+state   real   oc_a02      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_a02"        "Organic carbon, aerosol bin 02"      "ug/kg-dryair"
+state   real   bc_a02      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_a02"        "Black carbon, aerosol bin 02"      "ug/kg-dryair"
+state   real   hysw_a02    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hysw_a02"      "Hysteresis water, aerosol bin 02"    "ug/kg-dryair"
+state   real   water_a02   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "water_a02"     "Water, aerosol bin 02"   "ug/kg-dryair"
+state   real   num_a02     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_a02"       "Number, aerosol bin 02"     "#/kg-dryair"
+state   real   so4_a03     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_a03"       "Sulfate, aerosol bin 03"     "ug/kg-dryair"
+state   real   no3_a03     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_a03"       "Nitrate, aerosol bin 03"     "ug/kg-dryair"
+state   real   aro1_a03    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro1_a03"       "ARO1, aerosol bin 01"     "ug/kg-dryair"
+state   real   aro2_a03    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro2_a03"       "ARO2, aerosol bin 01"     "ug/kg-dryair"
+state   real   alk1_a03    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "alk1_a03"       "ALK1, aerosol bin 01"     "ug/kg-dryair"
+state   real   ole1_a03    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ole1_a03"       "OLE1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api1_a03    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api1_a03"       "API1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api2_a03    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api2_a03"       "API2, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim1_a03    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim1_a03"       "LIM1, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim2_a03    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim2_a03"       "LIM2, aerosol bin 01"     "ug/kg-dryair"
+state   real   pcg1_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_c_a03"    "pcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_c_a03"    "pcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_c_a03"    "pcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_c_a03"    "pcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_c_a03"    "pcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_c_a03"    "pcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_c_a03"    "pcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_c_a03"    "pcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_c_a03"    "pcg9_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_o_a03"    "pcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_o_a03"    "pcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_o_a03"    "pcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_o_a03"    "pcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_o_a03"    "pcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_o_a03"    "pcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_o_a03"    "pcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_o_a03"    "pcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_o_a03"    "pcg9_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_c_a03"    "pcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_c_a03"    "pcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_c_a03"    "pcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_c_a03"    "pcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_c_a03"    "pcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_c_a03"    "pcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_c_a03"    "pcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_c_a03"    "pcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_c_a03"    "pcg9_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_o_a03"    "pcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_o_a03"    "pcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_o_a03"    "pcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_o_a03"    "pcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_o_a03"    "pcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_o_a03"    "pcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_o_a03"    "pcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_o_a03"    "pcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_o_a03"    "pcg9_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_c_a03"    "opcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_c_a03"    "opcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_c_a03"    "opcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_c_a03"    "opcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_c_a03"    "opcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_c_a03"    "opcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_c_a03"    "opcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_c_a03"    "opcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_o_a03"    "opcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_o_a03"    "opcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_o_a03"    "opcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_o_a03"    "opcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_o_a03"    "opcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_o_a03"    "opcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_o_a03"    "opcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_o_a03"    "opcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_c_a03"    "opcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_c_a03"    "opcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_c_a03"    "opcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_c_a03"    "opcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_c_a03"    "opcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_c_a03"    "opcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_c_a03"    "opcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_c_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_c_a03"    "opcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_o_a03"    "opcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_o_a03"    "opcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_o_a03"    "opcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_o_a03"    "opcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_o_a03"    "opcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_o_a03"    "opcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_o_a03"    "opcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_o_a03  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_o_a03"    "opcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant1_c_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant1_c_a03"       "ant1_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant2_c_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant2_c_a03"       "ant2_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant3_c_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant3_c_a03"       "ant3_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant4_c_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant4_c_a03"       "ant4_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant1_o_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant1_o_a03"       "ant1_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant2_o_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant2_o_a03"       "ant2_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant3_o_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant3_o_a03"       "ant3_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant4_o_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant4_o_a03"       "ant4_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog1_c_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog1_c_a03"       "biog1_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog2_c_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog2_c_a03"       "biog2_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog3_c_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog3_c_a03"       "biog3_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog4_c_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog4_c_a03"       "biog4_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog1_o_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog1_o_a03"       "biog1_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog2_o_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog2_o_a03"       "biog2_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog3_o_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog3_o_a03"       "biog3_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog4_o_a03     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog4_o_a03"       "biog4_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   cl_a03      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_a03"        "Chloride, aerosol bin 03"      "ug/kg-dryair"
+state   real   msa_a03     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_a03"       "MSA, aerosol bin 03"     "ug/kg-dryair"
+state   real   co3_a03     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_a03"       "Carbonate, aerosol bin 03"     "ug/kg-dryair"
+state   real   nh4_a03     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_a03"       "Ammonium, aerosol bin 03"     "ug/kg-dryair"
+state   real   na_a03      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_a03"        "Sodium, aerosol bin 03"      "ug/kg-dryair"
+state   real   ca_a03      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_a03"        "Calcium, aerosol bin 03"      "ug/kg-dryair"
+state   real   oin_a03     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_a03"       "Other inorganics, aerosol bin 03"     "ug/kg-dryair"
+state   real   oc_a03      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_a03"        "Organic carbon, aerosol bin 03"      "ug/kg-dryair"
+state   real   bc_a03      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_a03"        "Black carbon, aerosol bin 03"      "ug/kg-dryair"
+state   real   hysw_a03    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hysw_a03"      "Hysteresis water, aerosol bin 03"    "ug/kg-dryair"
+state   real   water_a03   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "water_a03"     "Water, aerosol bin 03"   "ug/kg-dryair"
+state   real   num_a03     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_a03"       "Number, aerosol bin 03"     "#/kg-dryair"
+state   real   so4_a04     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_a04"       "Sulfate, aerosol bin 04"     "ug/kg-dryair"
+state   real   no3_a04     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_a04"       "Nitrate, aerosol bin 04"     "ug/kg-dryair"
+state   real   aro1_a04    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro1_a04"       "ARO1, aerosol bin 01"     "ug/kg-dryair"
+state   real   aro2_a04    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro2_a04"       "ARO2, aerosol bin 01"     "ug/kg-dryair"
+state   real   alk1_a04    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "alk1_a04"       "ALK1, aerosol bin 01"     "ug/kg-dryair"
+state   real   ole1_a04    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ole1_a04"       "OLE1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api1_a04    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api1_a04"       "API1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api2_a04    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api2_a04"       "API2, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim1_a04    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim1_a04"       "LIM1, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim2_a04    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim2_a04"       "LIM2, aerosol bin 01"     "ug/kg-dryair"
+state   real   pcg1_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_c_a04"    "pcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_c_a04"    "pcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_c_a04"    "pcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_c_a04"    "pcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_c_a04"    "pcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_c_a04"    "pcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_c_a04"    "pcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_c_a04"    "pcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_c_a04"    "pcg9_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_o_a04"    "pcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_o_a04"    "pcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_o_a04"    "pcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_o_a04"    "pcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_o_a04"    "pcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_o_a04"    "pcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_o_a04"    "pcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_o_a04"    "pcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_o_a04"    "pcg9_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_c_a04"    "pcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_c_a04"    "pcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_c_a04"    "pcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_c_a04"    "pcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_c_a04"    "pcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_c_a04"    "pcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_c_a04"    "pcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_c_a04"    "pcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_c_a04"    "pcg9_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_o_a04"    "pcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_o_a04"    "pcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_o_a04"    "pcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_o_a04"    "pcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_o_a04"    "pcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_o_a04"    "pcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_o_a04"    "pcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_o_a04"    "pcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_o_a04"    "pcg9_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_c_a04"    "opcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_c_a04"    "opcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_c_a04"    "opcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_c_a04"    "opcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_c_a04"    "opcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_c_a04"    "opcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_c_a04"    "opcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_c_a04"    "opcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_o_a04"    "opcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_o_a04"    "opcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_o_a04"    "opcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_o_a04"    "opcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_o_a04"    "opcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_o_a04"    "opcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_o_a04"    "opcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_o_a04"    "opcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_c_a04"    "opcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_c_a04"    "opcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_c_a04"    "opcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_c_a04"    "opcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_c_a04"    "opcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_c_a04"    "opcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_c_a04"    "opcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_c_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_c_a04"    "opcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_o_a04"    "opcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_o_a04"    "opcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_o_a04"    "opcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_o_a04"    "opcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_o_a04"    "opcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_o_a04"    "opcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_o_a04"    "opcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_o_a04  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_o_a04"    "opcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant1_c_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant1_c_a04"       "ant1_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant2_c_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant2_c_a04"       "ant2_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant3_c_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant3_c_a04"       "ant3_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant4_c_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant4_c_a04"       "ant4_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant1_o_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant1_o_a04"       "ant1_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant2_o_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant2_o_a04"       "ant2_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant3_o_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant3_o_a04"       "ant3_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   ant4_o_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "ant4_o_a04"       "ant4_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog1_c_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog1_c_a04"       "biog1_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog2_c_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog2_c_a04"       "biog2_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog3_c_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog3_c_a04"       "biog3_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog4_c_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog4_c_a04"       "biog4_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog1_o_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog1_o_a04"       "biog1_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog2_o_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog2_o_a04"       "biog2_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog3_o_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog3_o_a04"       "biog3_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   biog4_o_a04     ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "biog4_o_a04"       "biog4_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   cl_a04      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_a04"        "Chloride, aerosol bin 04"      "ug/kg-dryair"
+state   real   msa_a04     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_a04"       "MSA, aerosol bin 04"     "ug/kg-dryair"
+state   real   co3_a04     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_a04"       "Carbonate, aerosol bin 04"     "ug/kg-dryair"
+state   real   nh4_a04     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_a04"       "Ammonium, aerosol bin 04"     "ug/kg-dryair"
+state   real   na_a04      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_a04"        "Sodium, aerosol bin 04"      "ug/kg-dryair"
+state   real   ca_a04      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_a04"        "Calcium, aerosol bin 04"      "ug/kg-dryair"
+state   real   oin_a04     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_a04"       "Other inorganics, aerosol bin 04"     "ug/kg-dryair"
+state   real   oc_a04      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_a04"        "Organic carbon, aerosol bin 04"      "ug/kg-dryair"
+state   real   bc_a04      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_a04"        "Black carbon, aerosol bin 04"      "ug/kg-dryair"
+state   real   hysw_a04    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hysw_a04"      "Hysteresis water, aerosol bin 04"    "ug/kg-dryair"
+state   real   water_a04   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "water_a04"     "Water, aerosol bin 04"   "ug/kg-dryair"
+state   real   num_a04     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_a04"       "Number, aerosol bin 04"     "#/kg-dryair"
+state   real   so4_a05     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_a05"       "Sulfate, aerosol bin 05"     "ug/kg-dryair"
+state   real   no3_a05     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_a05"       "Nitrate, aerosol bin 05"     "ug/kg-dryair"
+state   real   aro1_a05    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro1_a05"       "ARO1, aerosol bin 01"     "ug/kg-dryair"
+state   real   aro2_a05    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro2_a05"       "ARO2, aerosol bin 01"     "ug/kg-dryair"
+state   real   alk1_a05    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "alk1_a05"       "ALK1, aerosol bin 01"     "ug/kg-dryair"
+state   real   ole1_a05    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ole1_a05"       "OLE1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api1_a05    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api1_a05"       "API1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api2_a05    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api2_a05"       "API2, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim1_a05    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim1_a05"       "LIM1, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim2_a05    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim2_a05"       "LIM2, aerosol bin 01"     "ug/kg-dryair"
+state   real   pcg1_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_c_a05"    "pcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_c_a05"    "pcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_c_a05"    "pcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_c_a05"    "pcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_c_a05"    "pcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_c_a05"    "pcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_c_a05"    "pcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_c_a05"    "pcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_c_a05"    "pcg9_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_o_a05"    "pcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_o_a05"    "pcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_o_a05"    "pcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_o_a05"    "pcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_o_a05"    "pcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_o_a05"    "pcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_o_a05"    "pcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_o_a05"    "pcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_o_a05"    "pcg9_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_c_a05"    "pcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_c_a05"    "pcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_c_a05"    "pcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_c_a05"    "pcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_c_a05"    "pcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_c_a05"    "pcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_c_a05"    "pcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_c_a05"    "pcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_c_a05"    "pcg9_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_o_a05"    "pcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_o_a05"    "pcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_o_a05"    "pcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_o_a05"    "pcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_o_a05"    "pcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_o_a05"    "pcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_o_a05"    "pcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_o_a05"    "pcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_o_a05"    "pcg9_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_c_a05"    "opcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_c_a05"    "opcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_c_a05"    "opcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_c_a05"    "opcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_c_a05"    "opcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_c_a05"    "opcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_c_a05"    "opcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_c_a05"    "opcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_o_a05"    "opcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_o_a05"    "opcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_o_a05"    "opcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_o_a05"    "opcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_o_a05"    "opcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_o_a05"    "opcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_o_a05"    "opcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_o_a05"    "opcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_c_a05"    "opcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_c_a05"    "opcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_c_a05"    "opcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_c_a05"    "opcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_c_a05"    "opcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_c_a05"    "opcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_c_a05"    "opcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_c_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_c_a05"    "opcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_o_a05"    "opcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_o_a05"    "opcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_o_a05"    "opcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_o_a05"    "opcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_o_a05"    "opcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_o_a05"    "opcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_o_a05"    "opcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_o_a05  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_o_a05"    "opcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   cl_a05      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_a05"        "Chloride, aerosol bin 05"      "ug/kg-dryair"
+state   real   msa_a05     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_a05"       "MSA, aerosol bin 05"     "ug/kg-dryair"
+state   real   co3_a05     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_a05"       "Carbonate, aerosol bin 05"     "ug/kg-dryair"
+state   real   nh4_a05     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_a05"       "Ammonium, aerosol bin 05"     "ug/kg-dryair"
+state   real   na_a05      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_a05"        "Sodium, aerosol bin 05"      "ug/kg-dryair"
+state   real   ca_a05      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_a05"        "Calcium, aerosol bin 05"      "ug/kg-dryair"
+state   real   oin_a05     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_a05"       "Other inorganics, aerosol bin 05"     "ug/kg-dryair"
+state   real   oc_a05      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_a05"        "Organic carbon, aerosol bin 05"      "ug/kg-dryair"
+state   real   bc_a05      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_a05"        "Black carbon, aerosol bin 05"      "ug/kg-dryair"
+state   real   hysw_a05    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hysw_a05"      "Hysteresis water, aerosol bin 05"    "ug/kg-dryair"
+state   real   water_a05   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "water_a05"     "Water, aerosol bin 05"   "ug/kg-dryair"
+state   real   num_a05     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_a05"       "Number, aerosol bin 05"     "#/kg-dryair"
+state   real   so4_a06     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_a06"       "Sulfate, aerosol bin 06"     "ug/kg-dryair"
+state   real   no3_a06     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_a06"       "Nitrate, aerosol bin 06"     "ug/kg-dryair"
+state   real   aro1_a06    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro1_a06"       "ARO1, aerosol bin 01"     "ug/kg-dryair"
+state   real   aro2_a06    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro2_a06"       "ARO2, aerosol bin 01"     "ug/kg-dryair"
+state   real   alk1_a06    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "alk1_a06"       "ALK1, aerosol bin 01"     "ug/kg-dryair"
+state   real   ole1_a06    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ole1_a06"       "OLE1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api1_a06    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api1_a06"       "API1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api2_a06    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api2_a06"       "API2, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim1_a06    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim1_a06"       "LIM1, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim2_a06    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim2_a06"       "LIM2, aerosol bin 01"     "ug/kg-dryair"
+state   real   pcg1_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_c_a06"    "pcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_c_a06"    "pcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_c_a06"    "pcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_c_a06"    "pcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_c_a06"    "pcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_c_a06"    "pcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_c_a06"    "pcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_c_a06"    "pcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_c_a06"    "pcg9_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_o_a06"    "pcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_o_a06"    "pcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_o_a06"    "pcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_o_a06"    "pcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_o_a06"    "pcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_o_a06"    "pcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_o_a06"    "pcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_o_a06"    "pcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_o_a06"    "pcg9_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_c_a06"    "pcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_c_a06"    "pcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_c_a06"    "pcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_c_a06"    "pcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_c_a06"    "pcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_c_a06"    "pcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_c_a06"    "pcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_c_a06"    "pcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_c_a06"    "pcg9_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_o_a06"    "pcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_o_a06"    "pcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_o_a06"    "pcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_o_a06"    "pcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_o_a06"    "pcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_o_a06"    "pcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_o_a06"    "pcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_o_a06"    "pcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_o_a06"    "pcg9_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_c_a06"    "opcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_c_a06"    "opcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_c_a06"    "opcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_c_a06"    "opcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_c_a06"    "opcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_c_a06"    "opcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_c_a06"    "opcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_c_a06"    "opcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_o_a06"    "opcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_o_a06"    "opcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_o_a06"    "opcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_o_a06"    "opcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_o_a06"    "opcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_o_a06"    "opcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_o_a06"    "opcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_o_a06"    "opcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_c_a06"    "opcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_c_a06"    "opcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_c_a06"    "opcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_c_a06"    "opcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_c_a06"    "opcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_c_a06"    "opcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_c_a06"    "opcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_c_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_c_a06"    "opcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_o_a06"    "opcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_o_a06"    "opcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_o_a06"    "opcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_o_a06"    "opcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_o_a06"    "opcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_o_a06"    "opcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_o_a06"    "opcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_o_a06  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_o_a06"    "opcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   cl_a06      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_a06"        "Chloride, aerosol bin 06"      "ug/kg-dryair"
+state   real   msa_a06     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_a06"       "MSA, aerosol bin 06"     "ug/kg-dryair"
+state   real   co3_a06     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_a06"       "Carbonate, aerosol bin 06"     "ug/kg-dryair"
+state   real   nh4_a06     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_a06"       "Ammonium, aerosol bin 06"     "ug/kg-dryair"
+state   real   na_a06      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_a06"        "Sodium, aerosol bin 06"      "ug/kg-dryair"
+state   real   ca_a06      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_a06"        "Calcium, aerosol bin 06"      "ug/kg-dryair"
+state   real   oin_a06     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_a06"       "Other inorganics, aerosol bin 06"     "ug/kg-dryair"
+state   real   oc_a06      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_a06"        "Organic carbon, aerosol bin 06"      "ug/kg-dryair"
+state   real   bc_a06      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_a06"        "Black carbon, aerosol bin 06"      "ug/kg-dryair"
+state   real   hysw_a06    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hysw_a06"      "Hysteresis water, aerosol bin 06"    "ug/kg-dryair"
+state   real   water_a06   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "water_a06"     "Water, aerosol bin 06"   "ug/kg-dryair"
+state   real   num_a06     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_a06"       "Number, aerosol bin 06"     "#/kg-dryair"
+state   real   so4_a07     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_a07"       "Sulfate, aerosol bin 07"     "ug/kg-dryair"
+state   real   no3_a07     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_a07"       "Nitrate, aerosol bin 07"     "ug/kg-dryair"
+state   real   aro1_a07    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro1_a07"       "ARO1, aerosol bin 01"     "ug/kg-dryair"
+state   real   aro2_a07    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro2_a07"       "ARO2, aerosol bin 01"     "ug/kg-dryair"
+state   real   alk1_a07    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "alk1_a07"       "ALK1, aerosol bin 01"     "ug/kg-dryair"
+state   real   ole1_a07    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ole1_a07"       "OLE1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api1_a07    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api1_a07"       "API1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api2_a07    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api2_a07"       "API2, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim1_a07    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim1_a07"       "LIM1, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim2_a07    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim2_a07"       "LIM2, aerosol bin 01"     "ug/kg-dryair"
+state   real   pcg1_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_c_a07"    "pcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_c_a07"    "pcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_c_a07"    "pcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_c_a07"    "pcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_c_a07"    "pcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_c_a07"    "pcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_c_a07"    "pcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_c_a07"    "pcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_c_a07"    "pcg9_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_o_a07"    "pcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_o_a07"    "pcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_o_a07"    "pcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_o_a07"    "pcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_o_a07"    "pcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_o_a07"    "pcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_o_a07"    "pcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_o_a07"    "pcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_o_a07"    "pcg9_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_c_a07"    "pcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_c_a07"    "pcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_c_a07"    "pcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_c_a07"    "pcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_c_a07"    "pcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_c_a07"    "pcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_c_a07"    "pcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_c_a07"    "pcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_c_a07"    "pcg9_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_o_a07"    "pcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_o_a07"    "pcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_o_a07"    "pcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_o_a07"    "pcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_o_a07"    "pcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_o_a07"    "pcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_o_a07"    "pcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_o_a07"    "pcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_o_a07"    "pcg9_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_c_a07"    "opcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_c_a07"    "opcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_c_a07"    "opcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_c_a07"    "opcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_c_a07"    "opcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_c_a07"    "opcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_c_a07"    "opcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_c_a07"    "opcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_o_a07"    "opcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_o_a07"    "opcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_o_a07"    "opcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_o_a07"    "opcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_o_a07"    "opcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_o_a07"    "opcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_o_a07"    "opcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_o_a07"    "opcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_c_a07"    "opcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_c_a07"    "opcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_c_a07"    "opcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_c_a07"    "opcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_c_a07"    "opcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_c_a07"    "opcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_c_a07"    "opcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_c_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_c_a07"    "opcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_o_a07"    "opcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_o_a07"    "opcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_o_a07"    "opcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_o_a07"    "opcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_o_a07"    "opcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_o_a07"    "opcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_o_a07"    "opcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_o_a07  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_o_a07"    "opcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   cl_a07      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_a07"        "Chloride, aerosol bin 07"      "ug/kg-dryair"
+state   real   msa_a07     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_a07"       "MSA, aerosol bin 07"     "ug/kg-dryair"
+state   real   co3_a07     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_a07"       "Carbonate, aerosol bin 07"     "ug/kg-dryair"
+state   real   nh4_a07     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_a07"       "Ammonium, aerosol bin 07"     "ug/kg-dryair"
+state   real   na_a07      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_a07"        "Sodium, aerosol bin 07"      "ug/kg-dryair"
+state   real   ca_a07      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_a07"        "Calcium, aerosol bin 07"      "ug/kg-dryair"
+state   real   oin_a07     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_a07"       "Other inorganics, aerosol bin 07"     "ug/kg-dryair"
+state   real   oc_a07      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_a07"        "Organic carbon, aerosol bin 07"      "ug/kg-dryair"
+state   real   bc_a07      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_a07"        "Black carbon, aerosol bin 07"      "ug/kg-dryair"
+state   real   hysw_a07    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hysw_a07"      "Hysteresis water, aerosol bin 07"    "ug/kg-dryair"
+state   real   water_a07   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "water_a07"     "Water, aerosol bin 07"   "ug/kg-dryair"
+state   real   num_a07     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_a07"       "Number, aerosol bin 07"     "#/kg-dryair"
+state   real   so4_a08     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_a08"       "Sulfate, aerosol bin 08"     "ug/kg-dryair"
+state   real   no3_a08     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_a08"       "Nitrate, aerosol bin 08"     "ug/kg-dryair"
+state   real   aro1_a08    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro1_a08"       "ARO1, aerosol bin 01"     "ug/kg-dryair"
+state   real   aro2_a08    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "aro2_a08"       "ARO2, aerosol bin 01"     "ug/kg-dryair"
+state   real   alk1_a08    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "alk1_a08"       "ALK1, aerosol bin 01"     "ug/kg-dryair"
+state   real   ole1_a08    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ole1_a08"       "OLE1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api1_a08    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api1_a08"       "API1, aerosol bin 01"     "ug/kg-dryair"
+state   real   api2_a08    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "api2_a08"       "API2, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim1_a08    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim1_a08"       "LIM1, aerosol bin 01"     "ug/kg-dryair"
+state   real   lim2_a08    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "lim2_a08"       "LIM2, aerosol bin 01"     "ug/kg-dryair"
+state   real   pcg1_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_c_a08"    "pcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_c_a08"    "pcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_c_a08"    "pcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_c_a08"    "pcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_c_a08"    "pcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_c_a08"    "pcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_c_a08"    "pcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_c_a08"    "pcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_c_a08"    "pcg9_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_b_o_a08"    "pcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_b_o_a08"    "pcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_b_o_a08"    "pcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_b_o_a08"    "pcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_b_o_a08"    "pcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_b_o_a08"    "pcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_b_o_a08"    "pcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_b_o_a08"    "pcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_b_o_a08"    "pcg9_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_c_a08"    "pcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_c_a08"    "pcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_c_a08"    "pcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_c_a08"    "pcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_c_a08"    "pcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_c_a08"    "pcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_c_a08"    "pcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_c_a08"    "pcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_c_a08"    "pcg9_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg1_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg1_f_o_a08"    "pcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg2_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg2_f_o_a08"    "pcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg3_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg3_f_o_a08"    "pcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg4_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg4_f_o_a08"    "pcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg5_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg5_f_o_a08"    "pcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg6_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg6_f_o_a08"    "pcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg7_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg7_f_o_a08"    "pcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg8_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg8_f_o_a08"    "pcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   pcg9_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "pcg9_f_o_a08"    "pcg9_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_c_a08"    "opcg1_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_c_a08"    "opcg2_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_c_a08"    "opcg3_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_c_a08"    "opcg4_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_c_a08"    "opcg5_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_c_a08"    "opcg6_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_c_a08"    "opcg7_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_c_a08"    "opcg8_b_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_b_o_a08"    "opcg1_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_b_o_a08"    "opcg2_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_b_o_a08"    "opcg3_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_b_o_a08"    "opcg4_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_b_o_a08"    "opcg5_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_b_o_a08"    "opcg6_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_b_o_a08"    "opcg7_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_b_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_b_o_a08"    "opcg8_b_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_c_a08"    "opcg1_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_c_a08"    "opcg2_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_c_a08"    "opcg3_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_c_a08"    "opcg4_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_c_a08"    "opcg5_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_c_a08"    "opcg6_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_c_a08"    "opcg7_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_c_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_c_a08"    "opcg8_f_c, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg1_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg1_f_o_a08"    "opcg1_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg2_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg2_f_o_a08"    "opcg2_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg3_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg3_f_o_a08"    "opcg3_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg4_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg4_f_o_a08"    "opcg4_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg5_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg5_f_o_a08"    "opcg5_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg6_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg6_f_o_a08"    "opcg6_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg7_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg7_f_o_a08"    "opcg7_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   opcg8_f_o_a08  ikjftb   chem      1         -   i0{12}rhusdf=(bdy_interp:dt)  "opcg8_f_o_a08"    "opcg8_f_o, aerosol bin 01"  "ug/kg-dryair"
+state   real   cl_a08      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_a08"        "Chloride, aerosol bin 08"      "ug/kg-dryair"
+state   real   msa_a08     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_a08"       "MSA, aerosol bin 08"     "ug/kg-dryair"
+state   real   co3_a08     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_a08"       "Carbonate, aerosol bin 08"     "ug/kg-dryair"
+state   real   nh4_a08     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_a08"       "Ammonium, aerosol bin 08"     "ug/kg-dryair"
+state   real   na_a08      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_a08"        "Sodium, aerosol bin 08"      "ug/kg-dryair"
+state   real   ca_a08      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_a08"        "Calcium, aerosol bin 08"      "ug/kg-dryair"
+state   real   oin_a08     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_a08"       "Other inorganics, aerosol bin 08"     "ug/kg-dryair"
+state   real   oc_a08      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_a08"        "Organic carbon, aerosol bin 08"      "ug/kg-dryair"
+state   real   bc_a08      ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_a08"        "Black carbon, aerosol bin 08"      "ug/kg-dryair"
+state   real   hysw_a08    ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "hysw_a08"      "Hysteresis water, aerosol bin 08"    "ug/kg-dryair"
+state   real   water_a08   ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "water_a08"     "Water, aerosol bin 08"   "ug/kg-dryair"
+state   real   num_a08     ikjftb   chem        1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_a08"       "Number, aerosol bin 08"     "#/kg-dryair"
+# Aerosol in cloud water phase
+state   real   so4_cw01     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_cw01"       "Sulfate, aerosol in cloud bin 01"     "ug/kg-dryair"
+state   real   no3_cw01     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_cw01"       "Nitrate, aerosol in cloud bin 01"     "ug/kg-dryair"
+state   real   cl_cw01      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_cw01"        "Chloride, aerosol in cloud bin 01"      "ug/kg-dryair"
+state   real   msa_cw01     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_cw01"       "MSA, aerosol in cloud bin 01"     "ug/kg-dryair"
+state   real   co3_cw01     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_cw01"       "Carbonate, aerosol in cloud bin 01"     "ug/kg-dryair"
+state   real   nh4_cw01     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_cw01"       "Ammonium, aerosol in cloud bin 01"     "ug/kg-dryair"
+state   real   na_cw01      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_cw01"        "Sodium, aerosol in cloud bin 01"      "ug/kg-dryair"
+state   real   ca_cw01      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_cw01"        "Calcium, aerosol in cloud bin 01"      "ug/kg-dryair"
+state   real   oin_cw01     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_cw01"       "Other inorganics, aerosol in cloud bin 01"     "ug/kg-dryair"
+state   real   oc_cw01      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_cw01"        "Organic carbon, aerosol in cloud bin 01"      "ug/kg-dryair"
+state   real   bc_cw01      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_cw01"        "Black carbon, aerosol in cloud bin 01"      "ug/kg-dryair"
+state   real   num_cw01     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_cw01"       "Number, aerosol in cloud bin 01"     "#/kg-dryair"
+state   real   so4_cw02     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_cw02"       "Sulfate, aerosol in cloud bin 02"     "ug/kg-dryair"
+state   real   no3_cw02     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_cw02"       "Nitrate, aerosol in cloud bin 02"     "ug/kg-dryair"
+state   real   cl_cw02      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_cw02"        "Chloride, aerosol in cloud bin 02"      "ug/kg-dryair"
+state   real   msa_cw02     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_cw02"       "MSA, aerosol in cloud bin 02"     "ug/kg-dryair"
+state   real   co3_cw02     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_cw02"       "Carbonate, aerosol in cloud bin 02"     "ug/kg-dryair"
+state   real   nh4_cw02     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_cw02"       "Ammonium, aerosol in cloud bin 02"     "ug/kg-dryair"
+state   real   na_cw02      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_cw02"        "Sodium, aerosol in cloud bin 02"      "ug/kg-dryair"
+state   real   ca_cw02      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_cw02"        "Calcium, aerosol in cloud bin 02"      "ug/kg-dryair"
+state   real   oin_cw02     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_cw02"       "Other inorganics, aerosol in cloud bin 02"     "ug/kg-dryair"
+state   real   oc_cw02      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_cw02"        "Organic carbon, aerosol in cloud bin 02"      "ug/kg-dryair"
+state   real   bc_cw02      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_cw02"        "Black carbon, aerosol in cloud bin 02"      "ug/kg-dryair"
+state   real   num_cw02     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_cw02"       "Number, aerosol in cloud bin 02"     "#/kg-dryair"
+state   real   so4_cw03     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_cw03"       "Sulfate, aerosol in cloud bin 03"     "ug/kg-dryair"
+state   real   no3_cw03     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_cw03"       "Nitrate, aerosol in cloud bin 03"     "ug/kg-dryair"
+state   real   cl_cw03      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_cw03"        "Chloride, aerosol in cloud bin 03"      "ug/kg-dryair"
+state   real   msa_cw03     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_cw03"       "MSA, aerosol in cloud bin 03"     "ug/kg-dryair"
+state   real   co3_cw03     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_cw03"       "Carbonate, aerosol in cloud bin 03"     "ug/kg-dryair"
+state   real   nh4_cw03     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_cw03"       "Ammonium, aerosol in cloud bin 03"     "ug/kg-dryair"
+state   real   na_cw03      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_cw03"        "Sodium, aerosol in cloud bin 03"      "ug/kg-dryair"
+state   real   ca_cw03      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_cw03"        "Calcium, aerosol in cloud bin 03"      "ug/kg-dryair"
+state   real   oin_cw03     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_cw03"       "Other inorganics, aerosol in cloud bin 03"     "ug/kg-dryair"
+state   real   oc_cw03      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_cw03"        "Organic carbon, aerosol in cloud bin 03"      "ug/kg-dryair"
+state   real   bc_cw03      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_cw03"        "Black carbon, aerosol in cloud bin 03"      "ug/kg-dryair"
+state   real   num_cw03     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_cw03"       "Number, aerosol in cloud bin 03"     "#/kg-dryair"
+state   real   so4_cw04     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_cw04"       "Sulfate, aerosol in cloud bin 04"     "ug/kg-dryair"
+state   real   no3_cw04     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_cw04"       "Nitrate, aerosol in cloud bin 04"     "ug/kg-dryair"
+state   real   cl_cw04      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_cw04"        "Chloride, aerosol in cloud bin 04"      "ug/kg-dryair"
+state   real   msa_cw04     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_cw04"       "MSA, aerosol in cloud bin 04"     "ug/kg-dryair"
+state   real   co3_cw04     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_cw04"       "Carbonate, aerosol in cloud bin 04"     "ug/kg-dryair"
+state   real   nh4_cw04     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_cw04"       "Ammonium, aerosol in cloud bin 04"     "ug/kg-dryair"
+state   real   na_cw04      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_cw04"        "Sodium, aerosol in cloud bin 04"      "ug/kg-dryair"
+state   real   ca_cw04      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_cw04"        "Calcium, aerosol in cloud bin 04"      "ug/kg-dryair"
+state   real   oin_cw04     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_cw04"       "Other inorganics, aerosol in cloud bin 04"     "ug/kg-dryair"
+state   real   oc_cw04      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_cw04"        "Organic carbon, aerosol in cloud bin 04"      "ug/kg-dryair"
+state   real   bc_cw04      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_cw04"        "Black carbon, aerosol in cloud bin 04"      "ug/kg-dryair"
+state   real   num_cw04     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_cw04"       "Number, aerosol in cloud bin 04"     "#/kg-dryair"
+state   real   so4_cw05     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_cw05"       "Sulfate, aerosol in cloud bin 05"     "ug/kg-dryair"
+state   real   no3_cw05     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_cw05"       "Nitrate, aerosol in cloud bin 05"     "ug/kg-dryair"
+state   real   cl_cw05      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_cw05"        "Chloride, aerosol in cloud bin 05"      "ug/kg-dryair"
+state   real   msa_cw05     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_cw05"       "MSA, aerosol in cloud bin 05"     "ug/kg-dryair"
+state   real   co3_cw05     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_cw05"       "Carbonate, aerosol in cloud bin 05"     "ug/kg-dryair"
+state   real   nh4_cw05     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_cw05"       "Ammonium, aerosol in cloud bin 05"     "ug/kg-dryair"
+state   real   na_cw05      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_cw05"        "Sodium, aerosol in cloud bin 05"      "ug/kg-dryair"
+state   real   ca_cw05      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_cw05"        "Calcium, aerosol in cloud bin 05"      "ug/kg-dryair"
+state   real   oin_cw05     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_cw05"       "Other inorganics, aerosol in cloud bin 05"     "ug/kg-dryair"
+state   real   oc_cw05      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_cw05"        "Organic carbon, aerosol in cloud bin 05"      "ug/kg-dryair"
+state   real   bc_cw05      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_cw05"        "Black carbon, aerosol in cloud bin 05"      "ug/kg-dryair"
+state   real   num_cw05     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_cw05"       "Number, aerosol in cloud bin 05"     "#/kg-dryair"
+state   real   so4_cw06     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_cw06"       "Sulfate, aerosol in cloud bin 06"     "ug/kg-dryair"
+state   real   no3_cw06     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_cw06"       "Nitrate, aerosol in cloud bin 06"     "ug/kg-dryair"
+state   real   cl_cw06      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_cw06"        "Chloride, aerosol in cloud bin 06"      "ug/kg-dryair"
+state   real   msa_cw06     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_cw06"       "MSA, aerosol in cloud bin 06"     "ug/kg-dryair"
+state   real   co3_cw06     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_cw06"       "Carbonate, aerosol in cloud bin 06"     "ug/kg-dryair"
+state   real   nh4_cw06     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_cw06"       "Ammonium, aerosol in cloud bin 06"     "ug/kg-dryair"
+state   real   na_cw06      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_cw06"        "Sodium, aerosol in cloud bin 06"      "ug/kg-dryair"
+state   real   ca_cw06      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_cw06"        "Calcium, aerosol in cloud bin 06"      "ug/kg-dryair"
+state   real   oin_cw06     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_cw06"       "Other inorganics, aerosol in cloud bin 06"     "ug/kg-dryair"
+state   real   oc_cw06      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_cw06"        "Organic carbon, aerosol in cloud bin 06"      "ug/kg-dryair"
+state   real   bc_cw06      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_cw06"        "Black carbon, aerosol in cloud bin 06"      "ug/kg-dryair"
+state   real   num_cw06     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_cw06"       "Number, aerosol in cloud bin 06"     "#/kg-dryair"
+state   real   so4_cw07     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_cw07"       "Sulfate, aerosol in cloud bin 07"     "ug/kg-dryair"
+state   real   no3_cw07     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_cw07"       "Nitrate, aerosol in cloud bin 07"     "ug/kg-dryair"
+state   real   cl_cw07      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_cw07"        "Chloride, aerosol in cloud bin 07"      "ug/kg-dryair"
+state   real   msa_cw07     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_cw07"       "MSA, aerosol in cloud bin 07"     "ug/kg-dryair"
+state   real   co3_cw07     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_cw07"       "Carbonate, aerosol in cloud bin 07"     "ug/kg-dryair"
+state   real   nh4_cw07     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_cw07"       "Ammonium, aerosol in cloud bin 07"     "ug/kg-dryair"
+state   real   na_cw07      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_cw07"        "Sodium, aerosol in cloud bin 07"      "ug/kg-dryair"
+state   real   ca_cw07      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_cw07"        "Calcium, aerosol in cloud bin 07"      "ug/kg-dryair"
+state   real   oin_cw07     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_cw07"       "Other inorganics, aerosol in cloud bin 07"     "ug/kg-dryair"
+state   real   oc_cw07      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_cw07"        "Organic carbon, aerosol in cloud bin 07"      "ug/kg-dryair"
+state   real   bc_cw07      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_cw07"        "Black carbon, aerosol in cloud bin 07"      "ug/kg-dryair"
+state   real   num_cw07     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_cw07"       "Number, aerosol in cloud bin 07"     "#/kg-dryair"
+state   real   so4_cw08     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "so4_cw08"       "Sulfate, aerosol in cloud bin 08"     "ug/kg-dryair"
+state   real   no3_cw08     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "no3_cw08"       "Nitrate, aerosol in cloud bin 08"     "ug/kg-dryair"
+state   real   cl_cw08      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "cl_cw08"        "Chloride, aerosol in cloud bin 08"      "ug/kg-dryair"
+state   real   msa_cw08     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "msa_cw08"       "MSA, aerosol in cloud bin 08"     "ug/kg-dryair"
+state   real   co3_cw08     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "co3_cw08"       "Carbonate, aerosol in cloud bin 08"     "ug/kg-dryair"
+state   real   nh4_cw08     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "nh4_cw08"       "Ammonium, aerosol in cloud bin 08"     "ug/kg-dryair"
+state   real   na_cw08      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "na_cw08"        "Sodium, aerosol in cloud bin 08"      "ug/kg-dryair"
+state   real   ca_cw08      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "ca_cw08"        "Calcium, aerosol in cloud bin 08"      "ug/kg-dryair"
+state   real   oin_cw08     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oin_cw08"       "Other inorganics, aerosol in cloud bin 08"     "ug/kg-dryair"
+state   real   oc_cw08      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "oc_cw08"        "Organic carbon, aerosol in cloud bin 08"      "ug/kg-dryair"
+state   real   bc_cw08      ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "bc_cw08"        "Black carbon, aerosol in cloud bin 08"      "ug/kg-dryair"
+state   real   num_cw08     ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "num_cw08"       "Number, aerosol in cloud bin 08"     "#/kg-dryair"
+
+# GOCART Aerosols
+state   real   bc1          ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "BC1"       "Hydrophobic Black Carbon"     "ug/kg-dryair"
+state   real   bc2          ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "BC2"       "Hydrophilic Black Carbon"     "ug/kg-dryair"
+state   real   oc1          ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "OC1"       "Hydrophobic Black Carbon"     "ug/kg-dryair"
+state   real   oc2          ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "OC2"       "Hydrophilic Black Carbon"     "ug/kg-dryair"
+state   real   p25        ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "P25"       "other gocart primary pm25"     "ug/kg-dryair"
+state   real   p10        ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "P10"       "other gocart primary pm10"     "ug/kg-dryair"
+state   real   dust_1       ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "DUST_1"    "dust size bin 1: 0.5um effective radius"     "ug/kg-dryair"
+state   real   dust_2       ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "DUST_2"    "dust size bin 2: 1.4um effective radius"     "ug/kg-dryair "
+state   real   dust_3       ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "DUST_3"    "dust size bin 3: 2.4um effective radius"     "ug/kg-dryair "
+state   real   dust_4       ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "DUST_4"    "dust size bin 4: 4.5um effective radius"     "ug/kg-dryair "
+state   real   dust_5       ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "DUST_5"    "dust size bin 5: 8.0um effective radius"     "ug/kg-dryair"
+state   real   seas_1       ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "SEAS_1"    "sea-salt size bin 1: 0.3um effective radius"     "ug/kg-dryair"
+state   real   seas_2       ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "SEAS_2"    "sea-salt size bin 2: 1.0um effective radius"     "ug/kg-dryair"
+state   real   seas_3       ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "SEAS_3"    "sea-salt size bin 3: 3.2um effective radius"     "ug/kg-dryair"
+state   real   seas_4       ikjftb   chem       1         -   i0{12}rhusdf=(bdy_interp:dt)  "SEAS_4"    "sea-salt size bin 4: 7.5um effective radius"     "ug/kg-dryair"
+
+# KPP Mechanism from MATCH-MPI MAINZ global chemistry
+state   real    pa       ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "pa"          ""         "" 
+state   real    aca      ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "aca"        ""         "" 
+state   real    acet     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "acet"        ""         ""
+state   real    isopr    ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "isopr"        "isoprene"         "" 
+state   real    mvk      ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "mvk"         " "         "" 
+state   real    iso2     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "iso2"        ""         "" 
+state   real    isooh    ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "isooh"       ""         ""
+state   real    mvko2    ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "mvko2"       ""         "" 
+state   real    mvkooh   ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "mvkooh"      ""         "" 
+state   real    acol     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "acol"        ""         ""
+state   real    hcooh    ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "hcooh"       ""         ""
+state   real    naca     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "naca"        ""         "" 
+state   real    mglo     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "mglo"        ""         "" 
+state   real    c2h6     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "c2h6"        ""         "" 
+state   real    etooh    ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "etooh"       ""         "" 
+state   real    c3h8     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "c3h8"        ""         "" 
+state   real    prooh    ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "prooh"       ""         ""
+state   real    acooh    ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "acooh"       ""         ""
+state   real    eto2     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "eto2"        ""         ""
+state   real    pro2     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "pro2"        ""         ""
+state   real    aco2     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "aco2"        ""         ""
+state   real    c3h6     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "c3h6"        ""         ""
+state   real    c3h6ooh  ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "c3h6ooh"     ""         ""
+state   real    c2h4     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "c2h4"        ""         ""
+state   real    c4h10    ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "c4h10"       ""         ""
+state   real    buooh    ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "c4h9ooh"     ""         ""
+state   real    mek      ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "mek"         ""         "" 
+state   real    mekooh   ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "mekooh"      ""         ""
+state   real    mecoco   ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "mecoco"      ""         ""
+state   real    c3h6o2   ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "c3h6o2"      ""         ""
+state   real    c4h9o2   ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "c4h9o2"      ""         ""
+state   real    meko2    ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "meko2"       ""         ""
+state   real    prono2   ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "prono2"      ""         ""
+state   real    acetol   ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "acetol"      ""         ""
+state   real    acetp    ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "acetp"      ""         ""
+state   real    aceto2   ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "aceto2"      ""         ""
+state   real    ch3cooh  ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "ch3cooh"      ""      ""
+state   real    c4h9ooh  ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "c4h9ooh"      ""     "" 
+state   real    meo2     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "meo2"      ""         ""
+state   real    meoh     ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "meoh"  ""  ""
+state   real    meo2no2  ikjftb   chem        1         -     i0{12}rhusdf=(bdy_interp:dt)         "meo2no2"  ""  ""
+
+#End MATCH-MPI MAINZ global chemistry
+
+# time averaged stuff
+#state integer  STEPAVE_COUNT     -        misc        1         -      r      "STEPAVE_COUNT"        "time steps contained in averages for convective transport" ""
+#state    real  RAINCV_A           ij      misc        1         -      r      "RAINCV_A"             "taveragd TIME-STEP CUMULUS PRECIPITATION"                         "mm"
+#state    real  RAINCV_B           ij      misc        1         -      r      "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         -      r      "GD_CLOUD_B"           "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD"         "kg kg-1"
+#state    real  GD_CLOUD2_B       ikj      misc        1         -      r      "GD_CLOUD2_B"          "taveragd cloud ice mix ratio in GD"         "kg kg-1"
+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"
+state integer  STEPFIREPL        -        misc     1         -      r        "STEPFIREPL"            "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN CALLSTO PLUMERISE FIRE ROUTINE"             "NA"
+
+                                                
+#
+rconfig   character  emi_inname            namelist,chem        1       "wrfchemi_d<domain>_<date>"   -     "name of chem emissions infile"  ""    ""
+rconfig   character  fireemi_inname        namelist,chem        1       "wrffirechemi_d<domain>_<date>"   -     "name of chem fire emissions infile"  ""    ""
+rconfig   character  input_chem_inname     namelist,chem        1       "wrf_chem_input_d<domain>_<date>"   -     "name of chem infile"  ""    ""
+rconfig   character  emi_outname           namelist,chem        1       "wrfchemi_d<domain>_<date>"   -     "name of chem emissions outfile" ""    ""
+rconfig   character  fireemi_outname       namelist,chem        1       "wrffirechemi_out_d<domain>_<date>"   -     "name of chem fire emissions outfile" ""    ""
+rconfig   character  input_chem_outname    namelist,chem        1       "wrf_chem_input_d<domain>_<date>"   -     "name of chem outfile" ""    ""
+rconfig   integer   io_style_emissions     namelist,chem        1              1       -       "io_style_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"                 ""      ""
+rconfig   integer nmegan                   namelist,chem        1              138     irh     "nmegan"                ""      ""
+rconfig   integer kfuture                  namelist,chem        1              1       -       "kfuture"                ""      ""
+rconfig   integer kfire                    namelist,chem        1              1       -       "kfire"                ""      ""
+rconfig   integer kemit_aircraft           namelist,chem        1              1       -       "kemit_aircraft"                ""      ""
+rconfig   integer kdvel                    namelist,chem        1              1       -       "kdvel"                ""      ""
+rconfig   integer erosion_dim              namelist,chem        1              3       -       "erosion_dim"          ""      ""
+rconfig   integer    biomass_emiss_opt     namelist,chem        max_domains    0       rh      "biomass_emiss_opt"                   ""    ""
+# Lightning
+rconfig   integer     lightning_opt       namelist,chem        max_domains        0       rh      "lightning_opt"     ""      ""
+rconfig   integer     lightning_time_step namelist,chem        max_domains        0       rh     "lightning_time_step"  ""      ""
+rconfig   integer     lightning_start_seconds namelist,chem    max_domains        0       rh     "lightning_start_seconds"    ""      ""
+rconfig   real        temp_upper          namelist,chem        max_domains      -45.      rh     "temp_upper"         ""      ""
+rconfig   real        temp_lower          namelist,chem        max_domains      -15.      rh     "temp_lower"         ""      ""
+rconfig   real        N_IC                namelist,chem        max_domains        0.      rh     "N_IC"               ""    ""
+rconfig   real        N_CG                namelist,chem        max_domains        0.      rh     "N_CG"               ""    ""
+rconfig   integer     passive_ltng        namelist,chem        max_domains        1       rh     "passive_ltng"     ""      ""
+rconfig   integer     lflash_data         namelist,chem        1                  1       rh     "lflash_data"     ""      ""
+rconfig   real        flashrate_factor    namelist,chem        max_domains        1.      rh     "flashrate_factor"   ""    ""
+rconfig   integer     flashrate_method    namelist,chem        max_domains        1       rh      "flashrate_method"   ""    ""
+rconfig   integer     iccg_method         namelist,chem        max_domains        1       rh      "iccg_method"        ""    ""
+rconfig   integer     cellcount_method    namelist,chem        max_domains        1       rh      "cellcount_method"   ""    ""            
+
+
+# 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     gas_drydep_opt      namelist,chem          max_domains    1       rh    "gas_drydep_opt"      ""      ""
+rconfig   integer     aer_drydep_opt      namelist,chem          max_domains    1       rh    "aer_drydep_opt"      ""      ""
+rconfig   integer     diagnostic_chem     namelist,chem          max_domains    1       rh    "diagnostic_chem"     ""      ""
+rconfig   integer     aer_aerodynres_opt  namelist,chem          max_domains    1       rh    "aer_aerodynres_opt"  ""      ""
+rconfig   integer     emiss_opt           namelist,chem          max_domains    4       rh    "emiss_opt"           ""      ""
+rconfig   integer     dust_opt            namelist,chem          1              0       rh    "dust_opt"            ""      ""
+rconfig   integer     dmsemis_opt         namelist,chem          1              0       rh    "dmsemis_opt"         ""      ""
+rconfig   integer     seas_opt            namelist,chem          1              0       rh    "seas_opt"            ""      ""
+rconfig   integer     bio_emiss_opt       namelist,chem          max_domains    0       rh    "bio_emiss_opt"       ""      ""
+rconfig   integer     biomass_burn_opt    namelist,chem          max_domains    0       rh    "biomass_burn_opt"    ""      ""
+rconfig   integer     plumerisefire_frq   namelist,chem          max_domains    180     rh    "plumerisefire_frq"   ""      ""
+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   logical     have_bcs_tracer     namelist,chem          max_domains    .false. rh    "have_bcs_tracer"     ""      ""
+rconfig   integer     aer_ra_feedback     namelist,chem          max_domains    0       rh    "aer_ra_feedback"     ""      ""
+rconfig   integer     aer_op_opt          namelist,chem          max_domains    1       rh    "aer_op_opt"          ""      ""
+rconfig   integer     opt_pars_out        namelist,chem          1    0       h    "opt_pars_out"          ""      ""
+# aircraft emissions
+rconfig   integer    aircraft_emiss_opt           namelist,chem    max_domains  0                                     rh    "aircraft_emiss_opt"                      ""    ""
+rconfig   integer    kemit_aircraft               namelist,chem       1         1                                     irh   "kemit_aircraft"                          ""    ""
+
+rconfig   integer        chemdiag        namelist,chem        max_domains        0      -     "Chemical tendency diagnostics"   ""    ""
+
+# 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,hcl,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,hcl,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,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,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,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,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,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,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,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
+#Normal cbmz_mosaic_8bin package
+#package   cbmz_mosaic_8bin chem_opt==8               -             chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,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
+#Alternative cbmz_mosaic_8bin with dust chemistry (ca & co aerosol)
+package   cbmz_mosaic_8bin chem_opt==8               -             chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,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,ca_a01,ca_a02,ca_a03,ca_a04,ca_a05,ca_a06,ca_a07,ca_a08,co3_a01,co3_a02,co3_a03,co3_a04,co3_a05,co3_a06,co3_a07,co3_a08
+package   cbmz_mosaic_4bin_aq  chem_opt==9           -             chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,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,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,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,hcl,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,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,nacwj,nacwi,clcwj,clcwi,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,naaj,naai,claj,clai,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,nacwj,nacwi,clcwj,clcwi,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
+package   chem_trace2   chem_opt==14                 -             chem:tracer_1
+package   chem_trace_ens   chem_opt==15              -             chem:tracer_1,tracer_2,tracer_3,tracer_4,tracer_5,tracer_6,tracer_7,tracer_8,tracer_9,tracer_10,tracer_11,tracer_12,tracer_13,tracer_14,tracer_15,tracer_16,tracer_17,tracer_18,tracer_19,tracer_20,tracer_ens
+
+package   cbmzsorg chem_opt==30                      -             chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,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,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,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_mosaic_dms_4bin chem_opt==31          -             chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,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,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,ca_a01,ca_a02,ca_a03,ca_a04,co3_a01,co3_a02,co3_a03,co3_a04,msa_a01,msa_a02,msa_a03,msa_a04
+package   cbmz_mosaic_dms_4bin_aq  chem_opt==32      -             chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,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,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,ca_a01,ca_a02,ca_a03,ca_a04,co3_a01,co3_a02,co3_a03,co3_a04,msa_a01,msa_a02,msa_a03,msa_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,ca_cw01,ca_cw02,ca_cw03,ca_cw04,co3_cw01,co3_cw02,co3_cw03,co3_cw04,msa_cw01,msa_cw02,msa_cw03,msa_cw04
+package   cbmz_mosaic_dms_8bin chem_opt==33          -             chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,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,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,ca_a01,ca_a02,ca_a03,ca_a04,ca_a05,ca_a06,ca_a07,ca_a08,co3_a01,co3_a02,co3_a03,co3_a04,co3_a05,co3_a06,co3_a07,co3_a08,msa_a01,msa_a02,msa_a03,msa_a04,msa_a05,msa_a06,msa_a07,msa_a08
+package   cbmz_mosaic_dms_8bin_aq  chem_opt==34      -             chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,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,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,ca_a01,ca_a02,ca_a03,ca_a04,ca_a05,ca_a06,ca_a07,ca_a08,co3_a01,co3_a02,co3_a03,co3_a04,co3_a05,co3_a06,co3_a07,co3_a08,msa_a01,msa_a02,msa_a03,msa_a04,msa_a05,msa_a06,msa_a07,msa_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,ca_cw01,ca_cw02,ca_cw03,ca_cw04,ca_cw05,ca_cw06,ca_cw07,ca_cw08,co3_cw01,co3_cw02,co3_cw03,co3_cw04,co3_cw05,co3_cw06,co3_cw07,co3_cw08,msa_cw01,msa_cw02,msa_cw03,msa_cw04,msa_cw05,msa_cw06,msa_cw07,msa_cw08
+package   cbmzsorg_aq chem_opt==35                   -             chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,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,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,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,nacwj,nacwi,clcwj,clcwi,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
+
+#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,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,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   racmpm_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,pm_25,pm_10
+
+package   racmsorg_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,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,naaj,naai,claj,clai,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==106                  -             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,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,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_esrlsorg_kpp      chem_opt==107                  -            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,hace,ishp,ison,mahp,mpan,nald,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,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   cbm4_kpp          chem_opt==110                  -          chem:no,no2,no3,n2o5,hono,hno3,pna,nh3,so2,sulf,o1d_cb4,o,ho,o3,h2o2,hcho,ald2,c2o3,pan,par,ror,ole,eth,tol,cres,to2,cro,open,xyl,mgly,iso,xo2,xo2n,co,ho2
+# KPP mechanism from mozart
+package   mozart_kpp        chem_opt==111                  -          chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,so4,co,hcho,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,c10h16,terpo2,tol,cres,to2,xoh,onit,isopn,dms,nh3,meko2
+
+# KPP mechanism from mozart + gocart
+package   mozcart_kpp       chem_opt==112                  -          chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,so4,co,hcho,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,c10h16,terpo2,tol,cres,to2,xoh,onit,isopn,dms,nh3,meko2,p10,p25,bc1,bc2,oc1,oc2,dust_1,dust_2,dust_3,dust_4,dust_5,seas_1,seas_2,seas_3,seas_4
+
+# KPP mechanism from CBMZ
+package   cbmz_bb_kpp       chem_opt==120                -             chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,ch4,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2
+
+
+#cbmz_mosaic_kpp (chem_opt=170) is for mosaic runs with sorgam soa species: coded by Manish Shrivastava on 12/8/2009
+package   cbmz_mosaic_kpp chem_opt==170               -             chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,ch4,aro1,aro2,alk1,ole1,api1,api2,lim1,lim2,api,lim,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,aro1_a01,aro2_a01,alk1_a01,ole1_a01,api1_a01,api2_a01,lim1_a01,lim2_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,aro1_a02,aro2_a02,alk1_a02,ole1_a02,api1_a02,api2_a02,lim1_a02,lim2_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,aro1_a03,aro2_a03,alk1_a03,ole1_a03,api1_a03,api2_a03,lim1_a03,lim2_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,aro1_a04,aro2_a04,alk1_a04,ole1_a04,api1_a04,api2_a04,lim1_a04,lim2_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,aro1_a05,aro2_a05,alk1_a05,ole1_a05,api1_a05,api2_a05,lim1_a05,lim2_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,aro1_a06,aro2_a06,alk1_a06,ole1_a06,api1_a06,api2_a06,lim1_a06,lim2_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,aro1_a07,aro2_a07,alk1_a07,ole1_a07,api1_a07,api2_a07,lim1_a07,lim2_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,aro1_a08,aro2_a08,alk1_a08,ole1_a08,api1_a08,api2_a08,lim1_a08,lim2_a08,num_a08,ca_a01,ca_a02,ca_a03,ca_a04,ca_a05,ca_a06,ca_a07,ca_a08,co3_a01,co3_a02,co3_a03,co3_a04,co3_a05,co3_a06,co3_a07,co3_a08
+
+
+
+#SAPRCNOV new package, automatically created using diff_mechanisSpc_wrfRegistry.m script (pablo-saide@uiowa.edu)
+package saprc99_kpp    chem_opt==195   -       chem:o3,h2o2,no,no2,no3,n2o5,hono,hno3,hno4,so2,h2so4,co,hcho,ccho,rcho,acet,mek,hcooh,meoh,etoh,cco_oh,rco_oh,gly,mgly,bacl,cres,bald,isoprod,methacro,mvk,prod2,dcb1,dcb2,dcb3,ethene,isoprene,c2h6,c3h8,c2h2,c3h6,alk3,alk4,alk5,aro1,aro2,ole1,ole2,terp,rno3,nphe,phen,pan,pan2,pbzn,ma_pan,co2,cco_ooh,rco_o2,rco_ooh,xn,xc,ho,ho2,c_o2,cooh,rooh,ro2_r,r2o2,ro2_n,cco_o2,bzco_o2,ma_rco3,nh3,hcl,ch4
+
+package saprc99_mosaic_4bin_vbs2_kpp    chem_opt==198   -       chem:o3,h2o2,no,no2,no3,n2o5,hono,hno3,hno4,so2,h2so4,co,hcho,ccho,rcho,acet,mek,hcooh,meoh,etoh,cco_oh,rco_oh,gly,mgly,bacl,cres,bald,isoprod,methacro,mvk,prod2,dcb1,dcb2,dcb3,ethene,isoprene,c2h6,c3h8,c2h2,c3h6,alk3,alk4,alk5,aro1,aro2,ole1,ole2,terp,rno3,nphe,phen,pan,pan2,pbzn,ma_pan,co2,cco_ooh,rco_o2,rco_ooh,xn,xc,ho,ho2,c_o2,cooh,rooh,ro2_r,r2o2,ro2_n,cco_o2,bzco_o2,ma_rco3,sesq,pcg1_b_c,pcg2_b_c,pcg1_b_o,pcg2_b_o,opcg1_b_c,opcg1_b_o,pcg1_f_c,pcg2_f_c,pcg1_f_o,pcg2_f_o,opcg1_f_c,opcg1_f_o,psd1,psd2,nh3,hcl,nume,den,ant1_c,ant1_o,biog1_c,biog1_o,ch4,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,pcg1_b_c_a01,pcg2_b_c_a01,pcg1_b_o_a01,pcg2_b_o_a01,opcg1_b_c_a01,opcg1_b_o_a01,pcg1_f_c_a01,pcg2_f_c_a01,pcg1_f_o_a01,pcg2_f_o_a01,opcg1_f_c_a01,opcg1_f_o_a01,ant1_c_a01,ant1_o_a01,biog1_c_a01,biog1_o_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,pcg1_b_c_a02,pcg2_b_c_a02,pcg1_b_o_a02,pcg2_b_o_a02,opcg1_b_c_a02,opcg1_b_o_a02,pcg1_f_c_a02,pcg2_f_c_a02,pcg1_f_o_a02,pcg2_f_o_a02,opcg1_f_c_a02,opcg1_f_o_a02,ant1_c_a02,ant1_o_a02,biog1_c_a02,biog1_o_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,pcg1_b_c_a03,pcg2_b_c_a03,pcg1_b_o_a03,pcg2_b_o_a03,opcg1_b_c_a03,opcg1_b_o_a03,pcg1_f_c_a03,pcg2_f_c_a03,pcg1_f_o_a03,pcg2_f_o_a03,opcg1_f_c_a03,opcg1_f_o_a03,ant1_c_a03,ant1_o_a03,biog1_c_a03,biog1_o_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,pcg1_b_c_a04,pcg2_b_c_a04,pcg1_b_o_a04,pcg2_b_o_a04,opcg1_b_c_a04,opcg1_b_o_a04,pcg1_f_c_a04,pcg2_f_c_a04,pcg1_f_o_a04,pcg2_f_o_a04,opcg1_f_c_a04,opcg1_f_o_a04,ant1_c_a04,ant1_o_a04,biog1_c_a04,biog1_o_a04,num_a04,ca_a01,ca_a02,ca_a03,ca_a04,co3_a01,co3_a02,co3_a03,co3_a04
+
+
+# KPP mechanism from MATCH-MPI Mainz used for global chemistry
+package   nmhc9_kpp     chem_opt==200                   -             chem:o3,h2o2,ch4,op1,hcho,ch3oh,co,hno3,no3,n2o5,hno4,no,no2,isopr,mvk,iso2,isooh,mvko2,mvkooh,ison,aca,acol,hcooh,mpan,naca,pan,pa,paa,mglo,c2h6,eTooh,ald,c3h8,pRooh,acet,acooh,eTo2,pRo2,aco2,c3h6,c3h6ooh,c2h4,c4h10,buooh,mek,mekooh,mEcoco,c3h6o2,c4h9o2,meko2,onit,pRono2,ch3o2,acetol,acetp,aceto2,ch3cooh,c4h9ooh,mEoh,ho,ho2,mEo2,mEo2no2
+
+# GOCART Packages (no Ozone chemistry in this choice)
+package   gocart_simple     chem_opt==300                   -             chem:so2,sulf,dms,msa,p25,bc1,bc2,oc1,oc2,dust_1,dust_2,dust_3,dust_4,dust_5,seas_1,seas_2,seas_3,seas_4,p10
+
+package   gocartracm_kpp     chem_opt==301                   -             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,dms,msa,p25,bc1,bc2,oc1,oc2,dust_1,dust_2,dust_3,dust_4,dust_5,seas_1,seas_2,seas_3,seas_4,p10
+
+package   gocartradm2_kpp     chem_opt==302                   -             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,dms,msa,p25,bc1,bc2,oc1,oc2,dust_1,dust_2,dust_3,dust_4,dust_5,seas_1,seas_2,seas_3,seas_4,p10
+
+package   gocartradm2     chem_opt==303                   -             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,hcl,ho,ho2,dms,msa,p25,bc1,bc2,oc1,oc2,dust_1,dust_2,dust_3,dust_4,dust_5,seas_1,seas_2,seas_3,seas_4,p10
+
+# volcanic ash for ash-fall and conc prediction, not other aerosols in this option (so for other "400" options)
+package   chem_vash   chem_opt==400              -             chem:vash_1,vash_2,vash_3,vash_4,vash_5,vash_6,vash_7,vash_8,vash_9,vash_10
+# dust only (per AFWA request)
+package   dust   chem_opt==401              -             chem:dust_1,dust_2,dust_3,dust_4,dust_5
+#emission package definitions
+#
+package   eradm           emiss_opt==2                   -             emis_ant: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_nh3
+package   eradmsorg       emiss_opt==3                   -             emis_ant:e_iso,e_so2,e_no,e_no2,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_pm25i,e_pm25j,e_pm_10,e_eci,e_ecj,e_orgi,e_orgj,e_so4i,e_so4j,e_no3i,e_no3j,e_naaj,e_naai,e_orgi_a,e_orgj_a,e_orgi_bb,e_orgj_bb
+package   ecbmz_mosaic    emiss_opt==4                   -             emis_ant: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_nh3,e_no2,e_ch3oh,e_c2h5oh,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_so4i,e_so4j,e_no3i,e_no3j,e_so4c,e_no3c,e_orgc,e_ecc
+package   ecptec          emiss_opt==5                   -             emis_ant: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_nh3,e_pm_25,e_pm_10,e_oc,e_sulf,e_bc
+package   gocart_ecptec   emiss_opt==6                   -             emis_ant:e_so2,e_sulf,e_bc,e_oc,e_pm_25,e_pm_10
+package   mozem           emiss_opt==7                   -             emis_ant:e_co,e_no,e_no2,e_bigalk,e_bigene,e_c2h4,e_c2h5oh,e_c2h6,e_c3h6,e_c3h8,e_ch2o,e_ch3cho,e_ch3coch3,e_ch3oh,e_mek,e_so2,e_toluene,e_nh3,e_isop,e_c10h16
+package   mozcem          emiss_opt==8                   -             emis_ant:e_co,e_no,e_no2,e_bigalk,e_bigene,e_c2h4,e_c2h5oh,e_c2h6,e_c3h6,e_c3h8,e_ch2o,e_ch3cho,e_ch3coch3,e_ch3oh,e_mek,e_so2,e_toluene,e_nh3,e_isop,e_c10h16,e_pm_10,e_pm_25,e_bc,e_oc,e_sulf
+package   vash    emiss_opt==9                   -             emis_ant:e_vash1,e_vash2,e_vash3,e_vash4,e_vash5,e_vash6,e_vash7,e_vash8,e_vash9,e_vash10
+package   esaprcnov       emiss_opt==13                  -             emis_ant:e_so2,e_c2h6,e_c3h8,e_c2h2,e_alk3,e_alk4,e_alk5,e_ethene,e_c3h6,e_ole1,e_ole2,e_aro1,e_aro2,e_hcho,e_ccho,e_rcho,e_acet,e_mek,e_isoprene,e_terp,e_sesq,e_co,e_no,e_no2,e_phen,e_cres,e_meoh,e_gly,e_mgly,e_bacl,e_isoprod,e_methacro,e_mvk,e_prod2,e_ch4,e_bald,e_hcooh,e_cco_oh,e_rco_oh,e_nh3,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_so4i,e_so4j,e_no3i,e_no3j,e_orgi_a,e_orgj_a,e_orgi_bb,e_orgj_bb
+
+
+#
+#package   seasalt_pnnl    emiss_ssalt_opt==1                   -             -
+#package   monahan         emiss_ssalt_opt==2                   -             -
+
+#cms--
+
+package   photmad       phot_opt==1                  -             -
+package   photfastj     phot_opt==2                  -             -
+package   ftuv          phot_opt==3                  -             -
+package   wesely        gas_drydep_opt==1            -             -
+#
+# diagnostic packages, first for deposition velocities (original package for Mozart)
+#
+package   depvel1  diagnostic_chem==1                -             dvel:dvel_o3,dvel_no,dvel_no2,dvel_nh3,dvel_hno3,dvel_hno4,dvel_h2o2,dvel_co,dvel_ch3ooh,dvel_hcho,dvel_ch3oh,dvel_eo2,dvel_ald,dvel_ch3cooh,dvel_acet,dvel_mgly,dvel_paa,dvel_pooh,dvel_pan,dvel_mpan,dvel_mco3,dvel_mvkooh,dvel_c2h5oh,dvel_etooh,dvel_prooh,dvel_acetp,dvel_onit,dvel_onitr,dvel_isooh,dvel_acetol,dvel_glyald,dvel_hydrald,dvel_alkooh,dvel_mekooh,dvel_tolooh,dvel_xooh,dvel_so2,dvel_so4,dvel_terpooh
+#
+package   gunther1      bio_emiss_opt==1             -             -
+package   beis313       bio_emiss_opt==2             -             -
+package   megan2        bio_emiss_opt==3             -             state:mebio_isop,mebio_apin,mebio_bcar,mebio_acet,mebio_mbo,mebio_no,msebio_isop,mlai,pftp_bt,pftp_nt,pftp_sb,pftp_hb,mtsa,mswdown,EFmegan
+# the following arrays only needed for burn options
+package   biomassb      biomass_burn_opt==1             -          state:mean_fct_agtf,mean_fct_agef,mean_fct_agsv,mean_fct_aggr,firesize_agtf,firesize_agef,firesize_agsv,firesize_aggr;ebu:ebu_no,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5,ebu_hc8,ebu_ete,ebu_olt,ebu_oli,ebu_pm25,ebu_pm10,ebu_dien,ebu_iso,ebu_api,ebu_lim,ebu_tol,ebu_csl,ebu_hcho,ebu_ald,ebu_ket,ebu_macr,ebu_ora1,ebu_ora2,ebu_so2,ebu_nh3,ebu_oc,ebu_bc,ebu_sulf,ebu_dms;ebu_in:ebu_in_no,ebu_in_co,ebu_in_co2,ebu_in_eth,ebu_in_hc3,ebu_in_hc5,ebu_in_hc8,ebu_in_ete,ebu_in_olt,ebu_in_oli,ebu_in_pm25,ebu_in_pm10,ebu_in_dien,ebu_in_iso,ebu_in_api,ebu_in_lim,ebu_in_tol,ebu_in_csl,ebu_in_hcho,ebu_in_ald,ebu_in_ket,ebu_in_macr,ebu_in_ora1,ebu_in_ora2,ebu_in_so2,ebu_in_nh3,ebu_in_oc,ebu_in_bc,ebu_in_sulf,ebu_in_dms
+package   biomassb_mozc      biomass_burn_opt==2             -          state:mean_fct_agtf,mean_fct_agef,mean_fct_agsv,mean_fct_aggr,firesize_agtf,firesize_agef,firesize_agsv,firesize_aggr;ebu:ebu_co,ebu_no,ebu_bigalk,ebu_bigene,ebu_c2h4,ebu_c2h5oh,ebu_c2h6,ebu_c3h6,ebu_c3h8,ebu_ch2o,ebu_ch3cho,ebu_ch3coch3,ebu_ch3oh,ebu_mek,ebu_so2,ebu_toluene,ebu_nh3,ebu_oc,ebu_bc,ebu_pm25,ebu_pm10,ebu_no2,ebu_open,ebu_c10h16,ebu_mgly,ebu_ch3cooh,ebu_cres,ebu_glyald,ebu_gly,ebu_acetol,ebu_isop,ebu_macr,ebu_mvk;ebu_in:ebu_in_co,ebu_in_no,ebu_in_bigalk,ebu_in_bigene,ebu_in_c2h4,ebu_in_c2h5oh,ebu_in_c2h6,ebu_in_c3h6,ebu_in_c3h8,ebu_in_ch2o,ebu_in_ch3cho,ebu_in_ch3coch3,ebu_in_ch3oh,ebu_in_mek,ebu_in_so2,ebu_in_toluene,ebu_in_nh3,ebu_in_no2,ebu_in_open,ebu_in_c10h16,ebu_in_mgly,ebu_in_ch3cooh,ebu_in_cres,ebu_in_glyald,ebu_in_gly,ebu_in_acetol,ebu_in_isop,ebu_in_macr,ebu_in_mvk,ebu_in_pm25,ebu_in_pm10,ebu_in_oc,ebu_in_bc
+package   opt_out      opt_pars_out==1             -          ext_coef:extcof3,extcof55,extcof106,extcof3_5,extcof8_12;bscat_coef:bscof3,bscof55,bscof106;asym_par:asympar3,asympar55,asympar106
+
+# dust and sea salt packages
+package   dustgocart    dust_opt==1                  -              emis_dust:edust1,edust2,edust3,edust4,edust5 
+package   seasgocart    seas_opt==1                  -              emis_seas:eseas1,eseas2,eseas3,eseas4
+package   dmsgocart    dmsemis_opt==1                  -              -
+package   volume_approx    aer_op_opt==1                -             -
+package   maxwell_approx   aer_op_opt==2                -             -
+package   volume_exact     aer_op_opt==3                -             -
+package   maxwell_exact    aer_op_opt==4                -             -
+package   shell_exact      aer_op_opt==5                -             -
+
+# 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_cptec            emiss_inpt_opt==3            -             -
+package   emiss_inpt_pnnl_cm          emiss_inpt_opt==101          -             -
+package   emiss_inpt_pnnl_rs          emiss_inpt_opt==102          -             -
+package   emiss_inpt_cb4              emiss_inpt_opt==103          -             -
+package   emiss_inpt_mozcem           emiss_inpt_opt==111          -             -
+
+# 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_bc_cbm4                 gas_bc_opt==102              -             -
+package   gas_ic_default              gas_ic_opt==1                -             -
+package   gas_ic_pnnl                 gas_ic_opt==101              -             -
+package   gas_ic_cbm4                 gas_ic_opt==102              -             -
+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              -             -
+#
+# tracer options. (smoke) only has one tracer for smoke (has to run with biomassburning).
+#                 (test1) has lateral boundary tracer(1,2), stratospheric tracer(5,6), 
+#                     boundary layer tracer(7,8), surface tracer (3,4)
+#                 (test2) has surface tracer replaced by smoke tracer
+package   tracer_smoke  tracer_opt==1       -             tracer:smoke
+package   tracer_test1  tracer_opt==2       -             tracer:tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8
+package   tracer_test2  tracer_opt==3       -             tracer:tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8
+package   tracer_test3  tracer_opt==4       -             tracer:tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8,tr18_1,tr18_2
+
+# Lightning
+package   crmpickering  lightning_opt==1   -   state:ic_flshrate,cg_flshrate
+
+# the following arrays only needed for aircraft emissions options
+package   aircraft1      aircraft_emiss_opt==1             -       emis_aircraft:eac_no,eac_co,eac_so2,eac_ch4
+
+package   nochemdiag     chemdiag==0         -                -
+package   usechemdiag    chemdiag==1         -                conv_ct:conv_co,conv_o3,conv_no,conv_no2,conv_hno3,conv_iso,conv_ho,conv_ho2;chem_ct:chem_co,chem_o3,chem_no,chem_no2,chem_hno3,chem_iso,chem_ho,chem_ho2;vmix_ct:vmix_co,vmix_o3,vmix_no,vmix_no2,vmix_hno3,vmix_iso,vmix_ho,vmix_ho2;advh_ct:advh_co,advh_o3,advh_no,advh_no2,advh_hno3,advh_iso,advh_ho,advh_ho2;advz_ct:advz_co,advz_o3,advz_no,advz_no2,advz_hno3,advz_iso,advz_ho,advz_ho2
+
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/registry.dimspec
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/registry.dimspec	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/registry.dimspec	(revision 17)
@@ -0,0 +1,1 @@
+link registry.dimspec.lmdz
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/registry.dimspec.lmdz
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/registry.dimspec.lmdz	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/registry.dimspec.lmdz	(revision 17)
@@ -0,0 +1,81 @@
+
+#<Table>  <Dim> <Order> <How defined>                <Coord-axis>  <Dimname in Datasets>
+
+dimspec    i       1     standard_domain                   x          west_east
+
+# Specific dimensional order for EM and NMM
+
+ifdef EM_CORE=1
+
+ifdef DA_CORE=0
+dimspec    j       3     standard_domain                   y     south_north
+dimspec    k       2     standard_domain                   z     bottom_top
+endif
+
+ifdef DA_CORE=1
+dimspec    j       2     standard_domain                   y     south_north
+dimspec    k       3     standard_domain                   z     bottom_top
+dimspec    9       4     namelist=ensdim_alpha             c     alpha ensemble dimension
+endif
+
+dimspec    lin     2     namelist=num_metgrid_soil_levels  z     num_metgrid_soil_levels
+dimspec    |       2     namelist=num_force_layers         z     force_layers
+dimspec    ndfi    1     namelist=dfi_time_dim             c     dfi time dimension
+dimspec    obs     -     namelist=max_obs                  c     max_obs
+dimspec    h       -     namelist=nobs_err_flds            c     nobs_err_flds
+dimspec    nndgvar -     namelist=nobs_ndg_vars            c     nobs_ndg_vars
+dimspec    [       -     namelist=obs_prt_max              c     obs_prt_max
+dimspec    obsstid -     constant=40                       c     obs station id names
+dimspec    &       2     namelist=lagday                   z     lagday
+
+endif
+
+ifdef NMM_CORE=1
+dimspec    ndfi    1     namelist=dfi_time_dim             c     dfi time dimension
+dimspec    j       2     standard_domain                   y     south_north
+dimspec    k       3     standard_domain                   z     bottom_top
+#definitions for NMM slab arrays
+dimspec    q       -     constant=2600                     c     # a little crude right now
+dimspec    r       -     constant=2000                     c     # a little crude right now
+dimspec    z       -     constant=(-3:3)                   c
+dimspec    n       -     constant=(0:6)                    c
+endif
+
+dimspec    l       2     namelist=num_soil_layers          z     soil_layers
+dimspec    ulay    2     namelist=num_urban_layers         z     urban_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
+dimspec    a       -     namelist=cam_abs_dim1             c     cam_abs_dim1
+dimspec    c       -     namelist=cam_abs_dim2             z     cam_abs_dim2
+dimspec    ls      2     namelist=levsiz                   z     levsiz
+dimspec    d       2     namelist=paerlev                  z     paerlev
+dimspec    ?       -     namelist=ts_buf_size              c     ts_buf_size
+dimspec    !       -     namelist=max_ts_locs              c     max_ts_locs
+dimspec    v       -     constant=1                        z     one
+dimspec    =       -     constant=4                        c     num_bands
+
+# Dimensions required only for Chemistry
+
+ifdef BUILD_CHEM=1
+dimspec    o       3     namelist=ne_area                  z     bio_emissions_dimension
+dimspec    +       2     namelist=kemit                    z     emissions_zdim
+dimspec    nm      2     namelist=nmegan                   z     megan_species
+dimspec    dust    2     namelist=kfuture                  z     klevs_for_dust
+dimspec    ]       2     namelist=kfire                    z     klevs_for_fire
+dimspec    %       2     namelist=kdvel                    z     klevs_for_dvel
+dimspec    airc    2     namelist=kemit_aircraft           z     ac_emissions_zdim
+dimspec    .       3     namelist=erosion_dim              z     dust_erosion_dimension
+endif
+
+# Dimensions required by LMDZ physics
+##
+dimspec    lksoil     2     namelist=lmdz_ksoil_types         z     lmdz_ksoil_types
+dimspec    olay       2     namelist=num_orchidee_soil_levels z     num_orchidee_soil_levels
+dimspec    kplus1     2     namelist=bottom_top_plus1         z     bottom_top_plus1
+dimspec    lind       1     namelist=lmdz_ind_control         z     lmdz_ind_control
+dimspec    lbnds      2     constant=2                        z     time_bounds
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/registry.dimspec.orig
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/registry.dimspec.orig	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/registry.dimspec.orig	(revision 17)
@@ -0,0 +1,73 @@
+
+#<Table>  <Dim> <Order> <How defined>                <Coord-axis>  <Dimname in Datasets>
+
+dimspec    i       1     standard_domain                   x          west_east
+
+# Specific dimensional order for EM and NMM
+
+ifdef EM_CORE=1
+
+ifdef DA_CORE=0
+dimspec    j       3     standard_domain                   y     south_north
+dimspec    k       2     standard_domain                   z     bottom_top
+endif
+
+ifdef DA_CORE=1
+dimspec    j       2     standard_domain                   y     south_north
+dimspec    k       3     standard_domain                   z     bottom_top
+dimspec    9       4     namelist=ensdim_alpha             c     alpha ensemble dimension
+endif
+
+dimspec    lin     2     namelist=num_metgrid_soil_levels  z     num_metgrid_soil_levels
+dimspec    |       2     namelist=num_force_layers         z     force_layers
+dimspec    ndfi    1     namelist=dfi_time_dim             c     dfi time dimension
+dimspec    obs     -     namelist=max_obs                  c     max_obs
+dimspec    h       -     namelist=nobs_err_flds            c     nobs_err_flds
+dimspec    nndgvar -     namelist=nobs_ndg_vars            c     nobs_ndg_vars
+dimspec    [       -     namelist=obs_prt_max              c     obs_prt_max
+dimspec    obsstid -     constant=40                       c     obs station id names
+dimspec    &       2     namelist=lagday                   z     lagday
+
+endif
+
+ifdef NMM_CORE=1
+dimspec    ndfi    1     namelist=dfi_time_dim             c     dfi time dimension
+dimspec    j       2     standard_domain                   y     south_north
+dimspec    k       3     standard_domain                   z     bottom_top
+#definitions for NMM slab arrays
+dimspec    q       -     constant=2600                     c     # a little crude right now
+dimspec    r       -     constant=2000                     c     # a little crude right now
+dimspec    z       -     constant=(-3:3)                   c
+dimspec    n       -     constant=(0:6)                    c
+endif
+
+dimspec    l       2     namelist=num_soil_layers          z     soil_layers
+dimspec    ulay    2     namelist=num_urban_layers         z     urban_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
+dimspec    a       -     namelist=cam_abs_dim1             c     cam_abs_dim1
+dimspec    c       -     namelist=cam_abs_dim2             z     cam_abs_dim2
+dimspec    ls      2     namelist=levsiz                   z     levsiz
+dimspec    d       2     namelist=paerlev                  z     paerlev
+dimspec    ?       -     namelist=ts_buf_size              c     ts_buf_size
+dimspec    !       -     namelist=max_ts_locs              c     max_ts_locs
+dimspec    v       -     constant=1                        z     one
+dimspec    =       -     constant=4                        c     num_bands
+
+# Dimensions required only for Chemistry
+
+ifdef BUILD_CHEM=1
+dimspec    o       3     namelist=ne_area                  z     bio_emissions_dimension
+dimspec    +       2     namelist=kemit                    z     emissions_zdim
+dimspec    nm      2     namelist=nmegan                   z     megan_species
+dimspec    dust    2     namelist=kfuture                  z     klevs_for_dust
+dimspec    ]       2     namelist=kfire                    z     klevs_for_fire
+dimspec    %       2     namelist=kdvel                    z     klevs_for_dvel
+dimspec    airc    2     namelist=kemit_aircraft           z     ac_emissions_zdim
+dimspec    .       3     namelist=erosion_dim              z     dust_erosion_dimension
+endif
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/registry.fire
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/registry.fire	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/registry.fire	(revision 17)
@@ -0,0 +1,222 @@
+#
+# ----------------------------------------
+#  begin fire variables and configuration
+# ----------------------------------------
+#
+# declare fire package and choose which fire scheme
+#
+#<key>   <package       <associated               <package        <associated 4d scalars>
+#         name>          namelist choice>          state vars>
+# 
+package   fire_sfire    ifire==2                    -             state:nfuel_cat,zsf,tign_g,rthfrten,rqvfrten,grnhfx,grnqfx,canhfx,canqfx,lfn,fuel_frac,fire_area,uf,vf,fgrnhfx,fgrnqfx,fcanhfx,fcanhfx,fcanqfx,ros,fxlong,fxlat,fuel_time,bbb,betafl,phiwc,r_0,fgip,ischap,lfn_hist,lfn_time
+
+# level function history support
+dimspec   ign   2           constant=1      z    i_lfn_history
+state     real  lfn_hist    *i{ign}*j   fire   1    Z   i012hr     "LFN_HIST"    "level function history" "1"
+state     real  lfn_time    {ign}       fire   1    -   i012hr     "LFN_TIME"    "level function history time" "s"
+
+
+# fire variables on fire grid
+#
+#<Table> <Type> <Sym>       <Dims>   <Use>   <NumTLev> <Stagger> <IO>     <DNAME>             <DESCRIP>     <UNITS>   
+state    real  nfuel_cat *i*j     fire        1         z     i012hr        "NFUEL_CAT"        "fuel data"   
+state    real     zsf       *i*j     fire        1         z   i012hr   "ZSF"      "height of surface above sea level" "m"
+state    real     dzdxf     *i*j     fire        1         z   i012hr   "DZDXF"    "surface gradient x" "1"
+state    real     dzdyf     *i*j     fire        1         z   i012hr   "DZDYF"    "surface gradient y" "1"
+state    real     tign_g    *i*j     fire        1         z     hr   "TIGN_G"   "ignition time on ground" "s"
+
+# fire variables on atm grid
+#
+# outputs to atm model
+state    real     rthfrten  ikj      fire        1         z     hr   "RTHFRTEN" "temperature tendency" "K/s"
+state    real     rqvfrten  ikj      fire        1         z     hr   "RQVFRTEN" "humidity tendency" 
+
+# diagnostics only
+state    real     avg_fuel_frac ij   fire        1         z     hr   "AVG_FUEL_FRAC" "fuel remaining averaged to atmospheric grid" "1"
+state    real     grnhfx    ij       fire        1         z     hr   "GRNHFX"   "heat flux from ground fire" "W/m^2"
+state    real     grnqfx    ij       fire        1         z     hr   "GRNQFX"   "moisture flux from ground fire" "W/m^2"
+state    real     canhfx    ij       fire        1         z     hr   "CANHFX"   "heat flux from crown fire" "W/m^2"
+state    real     canqfx    ij       fire        1         z     hr   "CANQFX"   "moisture flux from crown fire" "W/m^2"
+state    real     uah       ij       fire        1         X     hr   "UAH"      "wind at fire_wind_height" "m/s"
+state    real     vah       ij       fire        1         Y     hr   "VAH"      "wind at fire_wind_height" "m/s"
+
+# sfire variables on fire grid
+# (also using tign_g,zs,z_at_w,dz8w,nfuel_cat,fluxes,zsf)
+#
+state    real     lfn       *i*j      fire        1         z    hr    "LFN" "level function" "1"
+state    real     fuel_frac *i*j      fire        1         z    hr    "FUEL_FRAC" "fuel remaining" "1"
+state    real     fire_area *i*j      fire        1         z    hr    "FIRE_AREA" "fraction of cell area on fire" "1"
+state    real     uf        *i*j      fire        1         z    hr    "UF"        "fire wind" "m/s"
+state    real     vf        *i*j      fire        1         z    hr    "VF"        "fire wind" "m/s"
+state    real     fgrnhfx   *i*j      fire        1         z    hr    "FGRNHFX"   "heat flux from ground fire" "W/m^2"
+state    real     fgrnqfx   *i*j      fire        1         z    hr    "FGRNQFX"   "moisture flux from ground fire" "W/m^2"
+state    real     fcanhfx   *i*j      fire        1         z    hr    "FCANHFX"   "heat flux from crown fire" "W/m^2"
+state    real     fcanqfx   *i*j      fire        1         z    hr    "FCANQFX"   "moisture flux from crown fire" "W/m^2"
+state    real     ros       *i*j      fire        1         z    hr    "ROS" "rate of spread" "m/s"
+
+# constant data arrays
+state    real     fxlong    *i*j      fire        1         z   ihr    "FXLONG"    "longitude of midpoints of fire cells" "degrees"
+state    real     fxlat     *i*j      fire        1         z   ihr    "FXLAT"     "latitude of midpoints of fire cells" "degrees"
+state    real     fuel_time *i*j      fire        1         z    hr    "FUEL_TIME" "fuel"
+state    real     bbb       *i*j      fire        1         z    hr    "BBB"       "fuel"
+state    real     betafl    *i*j      fire        1         z    hr    "BETAFL"    "fuel"
+state    real     phiwc     *i*j      fire        1         z    hr    "PHIWC"     "fuel"
+state    real     r_0       *i*j      fire        1         z    hr    "R_0"       "fuel"
+state    real     fgip      *i*j      fire        1         z    hr    "FGIP"      "fuel"
+state    real     ischap    *i*j      fire        1         z    hr    "ISCHAP"    "fuel"
+
+#
+# fire configure namelist variables
+#
+#<Table>  <Type>  <Sym>                   <How set>          <Nentries>   <Default>
+rconfig   integer ifire                  namelist,fire         max_domains           0
+rconfig   integer fire_boundary_guard    namelist,fire         max_domains           2       -      "fire_boundary_guard" "cells to stop when fire close to domain boundary"
+# ignition for sfire
+rconfig   integer fire_num_ignitions     namelist,fire         max_domains           0.      -      "fire_num_ignitions" "number of ignition lines" 
+rconfig   real    fire_ignition_ros1        namelist,fire      max_domains           0.01    -      "fire_ignition_ros1" "rate of spread during ignition" "m/s"
+rconfig   real    fire_ignition_start_lon1  namelist,fire      max_domains           0.      -      "fire_ignition_start_long1" "long coord of start of ignition line" "deg"
+rconfig   real    fire_ignition_start_lat1  namelist,fire      max_domains           0.      -      "fire_ignition_start_lat1" "lat coord of start of ignition line" "deg"
+rconfig   real    fire_ignition_end_lon1    namelist,fire      max_domains           0.      -      "fire_ignition_end_long1"   "long coord of end of ignition line" "deg"
+rconfig   real    fire_ignition_end_lat1    namelist,fire      max_domains           0.      -      "fire_ignition_end_lat1"   "lat coord of end of ignition line" "deg"
+rconfig   real    fire_ignition_radius1   namelist,fire        max_domains           0.      -      "fire_ignition_radius1"   "ignite all within the radius" "m"
+rconfig   real    fire_ignition_start_time1     namelist,fire  max_domains           0.      -      "fire_ignition_start_time1"    "ignition line start time" "s"
+rconfig   real    fire_ignition_end_time1     namelist,fire    max_domains           0.      -      "fire_ignition_end_time1"    "ignition line end time" "s"
+rconfig   real    fire_ignition_ros2        namelist,fire      max_domains           0.01    -      "fire_ignition_ros1" "rate of spread during ignition" "m/s"
+rconfig   real    fire_ignition_start_lon2  namelist,fire      max_domains           0.      -      "fire_ignition_start_long2" "long coord of start of ignition line" "deg"
+rconfig   real    fire_ignition_start_lat2  namelist,fire      max_domains           0.      -      "fire_ignition_start_lat2" "lat coord of start of ignition line" "deg"
+rconfig   real    fire_ignition_end_lon2    namelist,fire      max_domains           0.      -      "fire_ignition_end_long2"   "long coord of end of ignition line" "deg"
+rconfig   real    fire_ignition_end_lat2    namelist,fire      max_domains           0.      -      "fire_ignition_end_lat2"   "lat coord of end of ignition line" "deg"
+rconfig   real    fire_ignition_radius2   namelist,fire        max_domains           0.      -      "fire_ignition_radius2"   "ignite all within the radius" "m"
+rconfig   real    fire_ignition_start_time2     namelist,fire  max_domains           0.      -      "fire_ignition_start_time2"    "ignition line start time" "s"
+rconfig   real    fire_ignition_end_time2     namelist,fire    max_domains           0.      -      "fire_ignition_end_time2"    "ignition line end time" "s"
+rconfig   real    fire_ignition_ros3        namelist,fire      max_domains           0.01    -      "fire_ignition_ros1" "rate of spread during ignition" "m/s"
+rconfig   real    fire_ignition_start_lon3  namelist,fire      max_domains           0.      -      "fire_ignition_start_long3" "long coord of start of ignition line" "deg"
+rconfig   real    fire_ignition_start_lat3  namelist,fire      max_domains           0.      -      "fire_ignition_start_lat3" "lat coord of start of ignition line" "deg"
+rconfig   real    fire_ignition_end_lon3    namelist,fire      max_domains           0.      -      "fire_ignition_end_long3"   "long coord of end of ignition line" "deg"
+rconfig   real    fire_ignition_end_lat3    namelist,fire      max_domains           0.      -      "fire_ignition_end_lat3"   "lat coord of end of ignition line" "deg"
+rconfig   real    fire_ignition_radius3   namelist,fire        max_domains           0.      -      "fire_ignition_radius3"   "ignite all within the radius" "m"
+rconfig   real    fire_ignition_start_time3     namelist,fire  max_domains           0.      -      "fire_ignition_start_time3"    "ignition line start time" "s"
+rconfig   real    fire_ignition_end_time3     namelist,fire    max_domains           0.      -      "fire_ignition_end_time3"    "ignition line end time" "s"
+rconfig   real    fire_ignition_ros4        namelist,fire      max_domains           0.01    -      "fire_ignition_ros1" "rate of spread during ignition" "m/s"
+rconfig   real    fire_ignition_start_lon4  namelist,fire      max_domains           0.      -      "fire_ignition_start_long4" "long coord of start of ignition line" "deg"
+rconfig   real    fire_ignition_start_lat4  namelist,fire      max_domains           0.      -      "fire_ignition_start_lat4" "lat coord of start of ignition line" "deg"
+rconfig   real    fire_ignition_end_lon4    namelist,fire      max_domains           0.      -      "fire_ignition_end_long4"   "long coord of end of ignition line" "deg"
+rconfig   real    fire_ignition_end_lat4    namelist,fire      max_domains           0.      -      "fire_ignition_end_lat4"   "lat coord of end of ignition line" "deg"
+rconfig   real    fire_ignition_radius4   namelist,fire        max_domains           0.      -      "fire_ignition_radius4"   "ignite all within the radius" "m"
+rconfig   real    fire_ignition_start_time4     namelist,fire  max_domains           0.      -      "fire_ignition_start_time4"    "ignition line start time" "s"
+rconfig   real    fire_ignition_end_time4     namelist,fire    max_domains           0.      -      "fire_ignition_end_time4"    "ignition line end time" "s"
+rconfig   real    fire_ignition_ros5        namelist,fire      max_domains           0.01    -      "fire_ignition_ros1" "rate of spread during ignition" "m/s"
+rconfig   real    fire_ignition_start_lon5  namelist,fire      max_domains           0.      -      "fire_ignition_start_long5" "long coord of start of ignition line" "deg"
+rconfig   real    fire_ignition_start_lat5  namelist,fire      max_domains           0.      -      "fire_ignition_start_lat5" "lat coord of start of ignition line" "deg"
+rconfig   real    fire_ignition_end_lon5    namelist,fire      max_domains           0.      -      "fire_ignition_end_long5"   "long coord of end of ignition line" "deg"
+rconfig   real    fire_ignition_end_lat5    namelist,fire      max_domains           0.      -      "fire_ignition_end_lat5"   "lat coord of end of ignition line" "deg"
+rconfig   real    fire_ignition_radius5   namelist,fire        max_domains           0.      -      "fire_ignition_radius5"   "ignite all within the radius" "m"
+rconfig   real    fire_ignition_start_time5     namelist,fire  max_domains           0.      -      "fire_ignition_start_time5"    "ignition line start time" "s"
+rconfig   real    fire_ignition_end_time5     namelist,fire    max_domains           0.      -      "fire_ignition_end_time5"    "ignition line end time" "s"
+rconfig   real    fire_ignition_start_x1  namelist,fire        max_domains           0.      -      "fire_ignition_start_x1" "x coord of start of ignition line" "m"
+rconfig   real    fire_ignition_start_y1  namelist,fire        max_domains           0.      -      "fire_ignition_start_y1" "y coord of start of ignition line" "m"
+rconfig   real    fire_ignition_end_x1    namelist,fire        max_domains           0.      -      "fire_ignition_end_x1"   "x coord of end of ignition line" "m"
+rconfig   real    fire_ignition_end_y1    namelist,fire        max_domains           0.      -      "fire_ignition_end_y1"   "y coord of end of ignition line" "m"
+rconfig   real    fire_ignition_start_x2  namelist,fire        max_domains           0.      -      "fire_ignition_start_x2" "x coord of start of ignition line" "m"
+rconfig   real    fire_ignition_start_y2  namelist,fire        max_domains           0.      -      "fire_ignition_start_y2" "y coord of start of ignition line" "m"
+rconfig   real    fire_ignition_end_x2    namelist,fire        max_domains           0.      -      "fire_ignition_end_x2"   "x coord of end of ignition line" "m"
+rconfig   real    fire_ignition_end_y2    namelist,fire        max_domains           0.      -      "fire_ignition_end_y2"   "y coord of end of ignition line" "m"
+rconfig   real    fire_ignition_start_x3  namelist,fire        max_domains           0.      -      "fire_ignition_start_x3" "x coord of start of ignition line" "m"
+rconfig   real    fire_ignition_start_y3  namelist,fire        max_domains           0.      -      "fire_ignition_start_y3" "y coord of start of ignition line" "m"
+rconfig   real    fire_ignition_end_x3    namelist,fire        max_domains           0.      -      "fire_ignition_end_x3"   "x coord of end of ignition line" "m"
+rconfig   real    fire_ignition_end_y3    namelist,fire        max_domains           0.      -      "fire_ignition_end_y3"   "y coord of end of ignition line" "m"
+rconfig   real    fire_ignition_start_x4  namelist,fire        max_domains           0.      -      "fire_ignition_start_x4" "x coord of start of ignition line" "m"
+rconfig   real    fire_ignition_start_y4  namelist,fire        max_domains           0.      -      "fire_ignition_start_y4" "y coord of start of ignition line" "m"
+rconfig   real    fire_ignition_end_x4    namelist,fire        max_domains           0.      -      "fire_ignition_end_x4"   "x coord of end of ignition line" "m"
+rconfig   real    fire_ignition_end_y4    namelist,fire        max_domains           0.      -      "fire_ignition_end_y4"   "y coord of end of ignition line" "m"
+rconfig   real    fire_ignition_start_x5  namelist,fire        max_domains           0.      -      "fire_ignition_start_x5" "x coord of start of ignition line" "m"
+rconfig   real    fire_ignition_start_y5  namelist,fire        max_domains           0.      -      "fire_ignition_start_y5" "y coord of start of ignition line" "m"
+rconfig   real    fire_ignition_end_x5    namelist,fire        max_domains           0.      -      "fire_ignition_end_x5"   "x coord of end of ignition line" "m"
+rconfig   real    fire_ignition_end_y5    namelist,fire        max_domains           0.      -      "fire_ignition_end_y5"   "y coord of end of ignition line" "m"
+# variables from old cawfe code
+rconfig   real    fire_lat_init          namelist,fire         max_domains           0.      -      "fire_lat_init"    "latitude to start fire"           "degrees"
+rconfig   real    fire_lon_init          namelist,fire         max_domains           0.      -      "fire_lon_init"    "longitude to start fire"          "degrees"
+rconfig   real    fire_ign_time          namelist,fire         max_domains           0.      -      "fire_ign_time"    "time when fire should be ignited" "min"
+rconfig   integer fire_shape             namelist,fire         max_domains           0       -      "fire_shape"       "fire shape"   ""
+rconfig   integer fire_sprd_mdl          namelist,fire         max_domains           1       -      "fire_sprd_mdl"    "which spread rate formula: if 0, Macarthur; if 1, BEHAVE" ""   
+rconfig   real    fire_crwn_hgt          namelist,fire         max_domains           15.     -      "fire_crwn_hgt"    "height that heat from crown fire is released" "m"
+rconfig   real    fire_ext_grnd          namelist,fire         max_domains           50.     -      "fire_ext_grnd"    "extinction depth of sfc fire heat"   "m"
+rconfig   real    fire_ext_crwn          namelist,fire         max_domains           50.     -      "fire_ext_crwn"    "extinction depth of crown fire heat" "m"
+rconfig   real    fire_wind_height       namelist,fire         max_domains           6.096   -      "fire_wind_height" "height of uah,vah wind in fire spread formula" "m"
+rconfig   integer fire_fuel_read         namelist,fire         max_domains           -1      -      "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         max_domains           1       -      "fire_fuel_cat"     "fuel category if ifuelread=0"              ""
+# sfire switches
+rconfig   integer fire_print_msg         namelist,fire         max_domains           0       -      "fire_write_msg"    "write fire statistics, 0 no writes, 1+ for more"  ""
+rconfig   integer fire_print_file        namelist,fire         max_domains           0       -      "fire_write_file"   "write fire output text files, 0 no writes, 1+ for more" ""
+# method selection`
+rconfig   integer fire_fuel_left_method  namelist,fire         max_domains           1       -      "fire_fuel_left_method"   "1 or 2, compute fuel_left" ""
+rconfig   integer fire_fuel_left_irl     namelist,fire         max_domains           2       -      "fire_fuel_left_irl"   "submesh to compute fuel lwft, even, at least 2" ""
+rconfig   integer fire_fuel_left_jrl     namelist,fire         max_domains           2       -      "fire_fuel_left_jrl"   "submesh to compute fuel lwft, even, at least 2" ""
+rconfig   real    fire_back_weight       namelist,fire         max_domains           0.5     -      "fire_back_weight"   "RK timestepping coefficient, 0=forward, 0.5=Heun" "1"
+rconfig   integer fire_grows_only        namelist,fire         max_domains            1       -     "fire_grows_only" "if >0 level set function cannot increase = fire can only grow" "1"
+rconfig   integer fire_upwinding         namelist,fire         max_domains            3       -     "fire_upwinding" "upwind normal spread: 1=standard, 2=godunov, 3=eno, 4=sethian" "1"
+rconfig   integer fire_upwind_split      namelist,fire         max_domains            0       -     "fire_upwind_split" "1=upwind advection separately from normal direction spread" "1"
+rconfig   real    fire_viscosity         namelist,fire         max_domains           0.4     -      "fire_viscosity"   "artificial viscosity in level set method" "1"
+rconfig   real    fire_lfn_ext_up        namelist,fire         max_domains           1.0     -      "fire_lfn_ext_up"   "0.=extend level set function at boundary by reflection, 1.=always up" "1"
+rconfig   integer fire_topo_from_atm     namelist,fire         max_domains            1      -      "fire_topo_from_atm" "0 = do nothing, 1 = populate ZSF by interpolating from atmosphere" "1"
+rconfig   integer fire_advection         namelist,fire         max_domains            1      -      "fire_advection" "0 = fire spread computed from normal wind speed/slope, 1 = fireline particle speed projected on normal" "0"
+# experiments
+rconfig   integer fire_test_steps        namelist,fire         max_domains            0      -      "fire_test_steps" ">0 = on first call, do specified number of steps and terminate (testing only)" "1"
+rconfig   real    fire_const_time        namelist,fire         max_domains          -1.      -      "fire_const_time"   "time from ignition to freeze fire, <0 never" "s"
+rconfig   real    fire_const_grnhfx      namelist,fire         max_domains           0.      -      "fire_const_grnhfx"   "if both >=0, the amount of constant heat flux" "1"
+rconfig   real    fire_const_grnqfx      namelist,fire         max_domains           0.      -      "fire_const_grnqfx"   "if both >=0, the amount of constant heat flux" "1"
+rconfig   real    fire_atm_feedback      namelist,fire         max_domains           1.      -      "fire_atm_feedback"   "the heat fluxes to the atmosphere are multiplied by this" "1"
+rconfig   integer fire_mountain_type     namelist,fire         max_domains            0      -      "fire_mountain_type" "in ideal: 0=none, 1=COS hill, 2=EW ridge, 3=NS ridge" "1"
+rconfig   real    fire_mountain_height   namelist,fire         max_domains         500.      -      "fire_mountain_height" "ideal mountain height" "m"
+rconfig   real    fire_mountain_start_x  namelist,fire         max_domains         100.      -      "fire_mountain_start_x" "x coord of start of the mountain" "m"
+rconfig   real    fire_mountain_start_y  namelist,fire         max_domains         100.      -      "fire_mountain_start_y" "y coord of start of the mountain" "m"
+rconfig   real    fire_mountain_end_x    namelist,fire         max_domains         100.      -      "fire_mountain_end_x" "x coord of end of the mountain" "m"
+rconfig   real    fire_mountain_end_y    namelist,fire         max_domains         100.      -      "fire_mountain_end_y" "y coord of end of the mountain" "m"
+rconfig   real    delt_perturbation      namelist,fire         max_domains           0.      -      "delt_perturbation" "temperature perturbation for cold (-) /warm (+) bubble" "K"
+rconfig   real    xrad_perturbation      namelist,fire         max_domains           0.      -      "xrad_perturbation" "horizontal radius of the perturbation in E-W direction" "m"
+rconfig   real    yrad_perturbation      namelist,fire         max_domains           0.      -      "yrad_perturbation" "horizontal radius of the perturbation in N-S direction" "m"
+rconfig   real    zrad_perturbation      namelist,fire         max_domains           0.      -      "zrad_perturbation" "vertical radius of the perturbation (bubble) direction" "m"
+rconfig   real    hght_perturbation      namelist,fire         max_domains           0.      -      "hght_perturbation" "height at which the perturbation (bubble) will be suspended" "m"
+# grid stretching
+rconfig   logical stretch_grd            namelist,fire         max_domains           .true.  -      "stretch_grd" "vertical grid stretching (on/off)" ""
+rconfig   logical stretch_hyp            namelist,fire         max_domains           .false. -      "stretch_hyp" "hyperbolic tang grid stretching (more levels at the surface)" ""
+rconfig   real    z_grd_scale            namelist,fire         max_domains           0.40    -      "z_grd_scale" "zscale parameter for hyperbolic grid streching" "m"
+# surface initialization
+rconfig   logical sfc_full_init          namelist,fire         max_domains           .false. -      "sfc_full_init" "full surface initialization  (on/off)" ""
+rconfig   integer sfc_lu_index           namelist,fire         max_domains             28    -      "sfc_lu_index" "USGS landuse index definig sfc record from LANDUSE.TBL" ""
+rconfig   real    sfc_tsk                namelist,fire         max_domains          285.0    -      "sfc_tsk" "surface skin temperature (TSK)" "K"
+rconfig   real    sfc_tmn                namelist,fire         max_domains          285.0    -      "sfc_tmn" "soil temperature at lower boundary (TMN)" "K"
+# landuse data from files - overwrite constants
+rconfig   logical fire_read_lu           namelist,fire         max_domains           .false. -      "fire_read_lu" "read land use data from file input_lu" ""
+rconfig   logical fire_read_tsk          namelist,fire         max_domains           .false. -      "fire_read_tsk" "read file input_tsk" ""
+rconfig   logical fire_read_tmn          namelist,fire         max_domains           .false. -      "fire_read_tmn" "read file input_tmn" ""
+# topography data from files 
+rconfig   logical fire_read_atm_ht       namelist,fire         max_domains           .false. -      "fire_read_atm_ht" "read terrain height on atm mesh from file" ""
+rconfig   logical fire_read_fire_ht      namelist,fire         max_domains           .false. -      "fire_read_fire_ht" "read terrain height on fire mesh from file" ""
+rconfig   logical fire_read_atm_grad     namelist,fire         max_domains           .false. -      "fire_read_atm_grad" "read terrain gradient on atm mesh from file" ""
+rconfig   logical fire_read_fire_grad    namelist,fire         max_domains           .false. -      "fire_read_fire_grad" "read terrain gradient on fire mesh from file" ""
+# additional data required by Noah LSM scheme
+rconfig   real    sfc_vegfra             namelist,fire         max_domains            0.5    -      "sfc_vegfra" "vegetation fraction" ""
+rconfig   real    sfc_canwat             namelist,fire         max_domains              0    -      "sfc_canwat" "canopy water" ""
+rconfig   integer sfc_ivgtyp             namelist,fire         max_domains             18    -      "sfc_ivgtyp" "dominant vegetation category in the LSM scheme" ""
+rconfig   integer sfc_isltyp             namelist,fire         max_domains              7    -      "sfc_isltyp" "dominant soil category in the LSM scheme" ""
+#
+# Fire halo descriptions
+#
+halo      HALO_FIRE_LFN dyn_em 24:lfn
+halo      HALO_FIRE_TIGN dyn_em 8:tign_g
+halo      HALO_FIRE_HT dyn_em 8:ht
+halo      HALO_FIRE_PHB dyn_em 8:phb
+halo      HALO_FIRE_Z0 dyn_em 8:z0
+halo      HALO_FIRE_PH dyn_em 8:ph_2
+halo      HALO_FIRE_WIND_F dyn_em 12:uf,vf
+halo      HALO_FIRE_LONGLAT dyn_em 24:xlong,xlat
+halo      HALO_FIRE_WIND_A dyn_em 8:u_2,v_2
+halo      HALO_FIRE_ZSF dyn_em 24:zsf
+halo      HALO_FIRE_FUEL dyn_em 8:fuel_frac,fuel_time,bbb,betafl,phiwc,r_0,fgip,ischap,nfuel_cat,dzdxf,dzdyf
+#
+# ----------------------------------------
+#  end fire variables and configuration
+# ----------------------------------------
+
+##
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/registry.io_boilerplate
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/registry.io_boilerplate	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/registry.io_boilerplate	(revision 17)
@@ -0,0 +1,142 @@
+
+#  registry.io_boilerplate
+#
+#  Included by registry program 
+#
+#  Contains a number of standard state variables associated with I/O
+#
+#
+
+
+# these definitions supercede the definitions in the io_boilerplate_temporary.inc file that follows
+ifdef EM_CORE=1
+rconfig   character  auxinput1_inname   namelist,time_control            1  "met_em.d<domain>.<date>"   -     "name of auxinput1 infile" ""      ""
+rconfig   integer     io_form_auxinput1   namelist,time_control         1              2
+endif
+ifdef NMM_CORE=1
+rconfig   character  auxinput1_inname   namelist,time_control            1  "met_nmm.d<domain>.<date>"   -     "name of auxinput1 infile" ""      ""
+rconfig   integer     io_form_auxinput1   namelist,time_control         1              2
+endif
+
+# the following file is automatically generated by the registry before reading the registry file.
+# see comment above about how to supercede these automatically generated definitions
+include io_boilerplate_temporary.inc
+
+# Output file descriptor for a domain                                           
+state   integer oid            -        -          -         -     -         "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   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<domain>_<date>"     -     "name of history outfile"  ""      ""
+rconfig   character  history_inname    namelist,time_control		1  "wrfhist_d<domain>_<date>"    -     "name of history infile"  ""      ""
+
+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_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 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_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 history_begin     namelist,time_control	max_domains    0     h   "history_begin"      ""   "MINUTES 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_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 restart_begin_y   namelist,time_control	1              0     h   "restart_begin_y"    ""   "YEARS 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 restart_begin     namelist,time_control	1              0     h   "restart_begin"      ""   "MINUTES 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_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 history_end        namelist,time_control	max_domains    0    h  "history_end"         ""      "MINUTES 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_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 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"
+rconfig   logical reset_simulation_start  namelist,time_control    1              .false. h        "reset_simulation_start" "set simulation start date equal to start date of this run" "logical"
+
+rconfig   integer   sr_x              namelist,domains    max_domains    0
+rconfig   integer   sr_y              namelist,domains    max_domains    0
+
+ifdef EM_CORE=1
+rconfig character sgfdda_inname   namelist,fdda 1  "sgfdda_d<domain>" - "name of sgfdda infile" ""      ""
+rconfig character gfdda_inname    namelist,fdda 1  "gfdda_d<domain>"  - "name of gfdda infile" ""      ""
+rconfig integer sgfdda_interval_d namelist,fdda	max_domains    0 h  "sgfdda_interval_d"  ""      "DAYS"
+rconfig integer sgfdda_interval_h namelist,fdda	max_domains    0 h  "sgfdda_interval_h"  ""      "HOURS"
+rconfig integer sgfdda_interval_m namelist,fdda	max_domains    0 h  "sgfdda_interval_m"  ""      "MINUTES"
+rconfig integer sgfdda_interval_s namelist,fdda	max_domains    0 h  "sgfdda_interval_s"  ""      "SECONDS"
+rconfig integer sgfdda_interval_y namelist,fdda	max_domains    0 h  "sgfdda_interval_y"  ""      "YEARS"
+rconfig integer sgfdda_interval   namelist,fdda	max_domains    0 h  "sgfdda_interval"    ""      "MINUTES"
+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_y  namelist,fdda	max_domains    0 h  "gfdda_interval_y"   ""      "YEARS"
+rconfig integer gfdda_interval    namelist,fdda	max_domains    0 h  "gfdda_interval"     ""      "MINUTES"
+rconfig integer sgfdda_begin_y    namelist,fdda	max_domains    0 h  "sgfdda_begin_y"     ""   "YEARS from start of run"
+rconfig integer sgfdda_begin_d    namelist,fdda	max_domains    0 h  "sgfdda_begin_d"     ""   "DAYS from start of run"
+rconfig integer sgfdda_begin_h    namelist,fdda	max_domains    0 h  "sgfdda_begin_h"     ""   "HOURS from start of run"
+rconfig integer sgfdda_begin_m    namelist,fdda	max_domains    0 h  "sgfdda_begin_m"     ""   "MINUTES from start of run"
+rconfig integer sgfdda_begin_s    namelist,fdda	max_domains    0 h  "sgfdda_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_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 sgfdda_end_y      namelist,fdda max_domains    0 h  "sgfdda_end_y"       ""      "YEARS from start of run"
+rconfig integer sgfdda_end_d      namelist,fdda max_domains    0 h  "sgfdda_end_d"       ""      "DAYS from start of run"
+rconfig integer sgfdda_end_h      namelist,fdda max_domains    0 h  "sgfdda_end_h"       ""      "HOURS from start of run"
+rconfig integer sgfdda_end_m      namelist,fdda max_domains    0 h  "sgfdda_end_m"       ""      "MINUTES from start of run"
+rconfig integer sgfdda_end_s      namelist,fdda max_domains    0 h  "sgfdda_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_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 io_form_sgfdda    namelist,fdda 1              2 h  "io_form_sgfdda"     ""      ""
+rconfig integer io_form_gfdda     namelist,fdda 1              2 h  "io_form_gfdda"      ""      ""
+endif
+
+# for reading in stream variable-set reconfiguration information at run time
+rconfig character iofields_filename       namelist,time_control   max_domains  "NONE_SPECIFIED"
+rconfig logical   ignore_iofields_warning namelist,time_control   1            .true.
+
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/registry.les
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/registry.les	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/registry.les	(revision 17)
@@ -0,0 +1,29 @@
+state	real	-	ikjf	nba_mij		1       -       -       -
+state   real    m11     ikjf    nba_mij		1       -	h	"m11"   	"11 component of NBA subgrid stress tensor"     "m2 s-2"
+state   real    m22     ikjf    nba_mij		1       -       h       "m22"   	"22 component of NBA subgrid stress tensor"     "m2 s-2"
+state   real    m33     ikjf    nba_mij		1       -       h       "m33"   	"33 component of NBA subgrid stress tensor"     "m2 s-2"
+state   real    m12     ikjf    nba_mij		1       -       h       "m12"   	"12 component of NBA subgrid stress tensor"     "m2 s-2"
+state   real    m13     ikjf    nba_mij		1       -       h       "m13"   	"13 component of NBA subgrid stress tensor"     "m2 s-2"
+state   real    m23     ikjf    nba_mij		1       -       h       "m23"  		"23 component of NBA subgrid stress tensor"     "m2 s-2"
+
+state   real    -       ikjf    nba_rij		1       -       -       -	
+state   real    r12     ikjf    nba_rij		1       -       -       "r12"   	"12 component of rotation tensor"               "s-1"
+state   real    r13     ikjf    nba_rij		1       -       -       "r13"   	"13 component of rotation tensor"               "s-1"
+state   real    r23     ikjf    nba_rij		1       -       -       "r23"   	"23 component of rotation tensor"               "s-1"
+state   real    smnsmn  ikjf    nba_rij		1       -       -       "smnsmn"   	"Smn*Smn"               			"s-2"
+
+rconfig	integer sfs_opt 	namelist,dynamics	max_domains     0       -	"1 or 2 to use NBA models"
+rconfig	integer m_opt    	namelist,dynamics       max_domains     0       -       "1 to output sgs stresses if not using NBA"
+
+package	nosfs	sfs_opt==0      	-       -
+package	nba1	sfs_opt==1      	-       nba_mij:m11,m22,m33,m12,m13,m23;nba_rij:r12,r13,r23,smnsmn
+package	nba2	sfs_opt==2      	-       nba_mij:m11,m22,m33,m12,m13,m23;nba_rij:r12,r13,r23,smnsmn
+
+package mout	m_opt==1		-	nba_mij:m11,m22,m33,m12,m13,m23
+
+halo      HALO_EM_NBA_MIJ	dyn_em 8:nba_mij
+period    PERIOD_EM_NBA_MIJ   	dyn_em 3:nba_mij
+
+halo      HALO_EM_NBA_RIJ       dyn_em 8:nba_rij
+period    PERIOD_EM_NBA_RIJ     dyn_em 3:nba_rij
+
Index: branches/LMDZ_WRFmeas/WRFV3/Registry/registry.stoch
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/Registry/registry.stoch	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/Registry/registry.stoch	(revision 17)
@@ -0,0 +1,60 @@
+# Stochastic forcing option, for ARW only
+
+# 3D arrays
+state    real   VERTSTRUCC         ikj dyn_em  1  -  rhd  "VERTSTRUCC    "  "vertical structure for stoch. forcing " ""
+state    real   VERTSTRUCS         ikj dyn_em  1  -  rhd  "VERTSTRUCS    "  "vertical structure for stoch. forcing " ""
+
+state real ru_tendf_stoch     ikjb dyn_em 1 X rhdf=(p2c:dt) "ru_tendf_stoch" "stochastic forcing, U " ""
+state real rv_tendf_stoch     ikjb dyn_em 1 Y rhdf=(p2c:dt) "rv_tendf_stoch" "stochastic forcing, V " ""
+state real rt_tendf_stoch     ikjb dyn_em 1 - rhdf=(p2c:dt) "rt_tendf_stoch" "stochastic forcing, T " ""
+
+# 2d arrays
+state    real  SPSTREAMFORCC  ij  misc    1  -   r    "SPSTREAMFORCC" "real  spect. coeff. of stoch. streamfunction perturb." ""
+state    real  SPSTREAMFORCS  ij  misc    1  -   r    "SPSTREAMFORCS" "imag. spect. coeff. of stoch. streamfunction perturb." ""
+state    real  SPTFORCC       ij  misc    1  -   r    "SPTFORCC"      "real  spect. coeff. of stoch. temperature perturb." "" ""
+state    real  SPTFORCS       ij  misc    1  -   r    "SPTFORCS"      "imag. spect. coeff. of stoch. temperature perturb." "" ""
+state    real  SPSTREAM_AMP   ij  misc    1  -   r    "SPSTREAM_AMP"  "amplitude of stoch. streamfunction perturb." "" ""
+state    real  SPT_AMP        ij  misc    1  -   r    "SPT_AMP"       "amplitude of stoch. temperature perturb." "" ""
+
+# 1d arrays for FFT transpose
+state    real   RU_REAL          ikj    dyn_em       1        XYZ
+state    real   RU_IMAG          ikj    dyn_em       1        XYZ
+state    real   RU_REAL_xxx      ikjx   dyn_em       1        XYZ
+state    real   RU_REAL_yyy      ikjy   dyn_em       1        XYZ
+state    real   RU_IMAG_xxx      ikjx   dyn_em       1        XYZ
+state    real   RU_IMAG_yyy      ikjy   dyn_em       1        XYZ
+state    real   RV_REAL          ikj    dyn_em       1        XYZ
+state    real   RV_IMAG          ikj    dyn_em       1        XYZ
+state    real   RV_REAL_xxx      ikjx   dyn_em       1        XYZ
+state    real   RV_REAL_yyy      ikjy   dyn_em       1        XYZ
+state    real   RV_IMAG_xxx      ikjx   dyn_em       1        XYZ
+state    real   RV_IMAG_yyy      ikjy   dyn_em       1        XYZ
+state    real   RT_REAL          ikj    dyn_em       1        XYZ
+state    real   RT_IMAG          ikj    dyn_em       1        XYZ
+state    real   RT_REAL_xxx      ikjx   dyn_em       1        XYZ
+state    real   RT_REAL_yyy      ikjy   dyn_em       1        XYZ
+state    real   RT_IMAG_xxx      ikjx   dyn_em       1        XYZ
+state    real   RT_IMAG_yyy      ikjy   dyn_em       1        XYZ
+
+xpose XPOSE_STOCH_BACK_U_REAL dyn_em RU_REAL,RU_REAL_xxx,RU_REAL_yyy
+xpose XPOSE_STOCH_BACK_U_IMAG dyn_em RU_IMAG,RU_IMAG_xxx,RU_IMAG_yyy
+xpose XPOSE_STOCH_BACK_V_REAL dyn_em RV_REAL,RV_REAL_xxx,RV_REAL_yyy
+xpose XPOSE_STOCH_BACK_V_IMAG dyn_em RV_IMAG,RV_IMAG_xxx,RV_IMAG_yyy
+xpose XPOSE_STOCH_BACK_T_REAL dyn_em RT_REAL,RT_REAL_xxx,RT_REAL_yyy
+xpose XPOSE_STOCH_BACK_T_IMAG dyn_em RT_IMAG,RT_IMAG_xxx,RT_IMAG_yyy
+
+# Variables 
+state integer   SEED1            -      misc        1         -     rh        "SEED1"                "RANDOM SEED NUMBER 1"  ""
+state integer   SEED2            -      misc        1         -     rh        "SEED2"                "RANDOM SEED NUMBER 2"  ""
+state logical   did_stoch        -      misc        1         -     r         "DID_STOCH"            "Logical to tell us that we already did the initialization for dom 1"  ""
+
+# Namelist parameters
+rconfig   integer     stoch_force_opt     namelist,physics	max_domains    0   -     "stochastic forcing option: 0=none, 1=backscatter"
+rconfig   integer     stoch_vertstruc_opt namelist,physics	max_domains    0   -     "vertical structure for stochastic forcing: 0=constant, 1=random phase"
+rconfig   integer     nens                namelist,physics      1              1   -     "ensemble member"    ""   ""
+rconfig   real        tot_backscat_psi    namelist,physics      max_domains    115200   -     "total backscattered energy 240*240*2"    "m2 s-3"   ""
+rconfig   real        tot_backscat_t      namelist,physics      max_domains    2.0E-06   - "total backscattered temperature"    "Cp m2 s-3" ""
+
+# Package declarations
+package   no_stoch_force      stoch_force_opt==0                  -             -
+package   stoch_backscatter   stoch_force_opt==1                  -             state:ru_tendf_stoch,rv_tendf_stoch,rt_tendf_stoch,SPSTREAMFORCC,SPSTREAMFORCS,SPTFORCC,SPTFORCS,SPSTREAM_AMP,SPT_AMP,VERTSTRUCC,VERTSTRUCS,RU_IMAG,RU_REAL_xxx,RU_REAL_yyy,RU_IMAG_xxx,RU_IMAG_yyy,RV_IMAG,RV_REAL_xxx,RV_REAL_yyy,RV_IMAG_xxx,RV_IMAG_yyy,RT_IMAG,RT_REAL_xxx,RT_REAL_yyy,RT_IMAG_xxx,RT_IMAG_yyy,RU_REAL,RV_REAL,RT_REAL
Index: branches/LMDZ_WRFmeas/WRFV3/arch/Config.pl
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/Config.pl	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/Config.pl	(revision 17)
@@ -0,0 +1,329 @@
+#!/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=""; 
+$sw_rwordsize="\$\(NATIVE_RWORDSIZE\)";
+$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" ;
+   }
+
+# When compiling DA code, we need to always use 8-byte reals.
+ if ( $ENV{WRF_DA_CORE} == "1" )
+   {
+     $sw_rwordsize = "8";  
+   }
+
+# 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 ( <CONFIGURE_DEFAULTS> )
+  {
+    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 = <STDIN> ;
+
+  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 ( <CONFIGURE_DEFAULTS> )
+{
+  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 ;
+    $_ =~ s/CONFIGURE_RWORDSIZE/$sw_rwordsize/g ;
+    if ( $sw_netcdf_path ) 
+      { $_ =~ s/CONFIGURE_WRFIO_NF/wrfio_nf/g ;
+	$_ =~ s:CONFIGURE_NETCDF_FLAG:-DNETCDF: ;
+        if ( $sw_os == Interix ) {
+	  $_ =~ s:CONFIGURE_NETCDF_LIB_PATH:\$\(WRF_SRC_ROOT_DIR\)/external/io_netcdf/libwrfio_nf.a -L$sw_netcdf_path/lib -lnetcdf: ;
+        } else {
+	  $_ =~ s:CONFIGURE_NETCDF_LIB_PATH:-L\$\(WRF_SRC_ROOT_DIR\)/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: ;
+        if ( $sw_os == Interix ) {
+	  $_ =~ s:CONFIGURE_PNETCDF_LIB_PATH:\$\(WRF_SRC_ROOT_DIR\)/external/io_pnetcdf/libwrfio_pnf.a -L$sw_pnetcdf_path/lib -lpnetcdf: ;
+        } else {
+	  $_ =~ s:CONFIGURE_PNETCDF_LIB_PATH:-L\$\(WRF_SRC_ROOT_DIR\)/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\$\(WRF_SRC_ROOT_DIR\)/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\$\(WRF_SRC_ROOT_DIR\)/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\$\(WRF_SRC_ROOT_DIR\)/external/io_esmf -lwrfio_esmf \$\(ESMF_LIB_FLAGS\):g ;
+      $_ =~ s:ESMFIOEXTLIB:-L$sw_esmflib_path -lesmf -L\$\(WRF_SRC_ROOT_DIR\)/external/io_esmf -lwrfio_esmf \$\(ESMF_LIB_FLAGS\):g ;
+      }
+    else
+      {
+        if ( $sw_os == Interix ) {
+           $_ =~ s:ESMFIOLIB:\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90/libesmf_time.a:g ;
+           $_ =~ s:ESMFIOEXTLIB:-L\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90/libesmf_time.a:g ;
+        } else {
+           $_ =~ s:ESMFIOLIB:-L\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90 -lesmf_time:g ;
+           $_ =~ s:ESMFIOEXTLIB:-L\$\(WRF_SRC_ROOT_DIR\)/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 ( <ARCH_PREAMBLE> )
+  {
+  # ESMF substitutions in preamble
+  if ( $sw_esmflib_path && $sw_esmfinc_path )
+    {
+    $_ =~ s/ESMFCOUPLING/1/g ;
+    $_ =~ s:ESMFMODDEPENDENCE:\$\(WRF_SRC_ROOT_DIR\)/external/io_esmf/module_utility.o:g ;
+    $_ =~ s:ESMFMODINC:-I$sw_esmfinc_path -I\$\(WRF_SRC_ROOT_DIR\)/main:g ;
+    $_ =~ s:ESMFIOINC:-I\$\(WRF_SRC_ROOT_DIR\)/external/io_esmf:g ;
+    $_ =~ s:ESMFIODEFS:-DESMFIO:g ;
+    $_ =~ s:ESMFTARGET:wrfio_esmf:g ;
+    }
+  else
+    {
+    $_ =~ s/ESMFCOUPLING/0/g ;
+    $_ =~ s:ESMFMODDEPENDENCE:\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90/module_utility.o:g ;
+    $_ =~ s:ESMFMODINC::g ;
+    $_ =~ s:ESMFIOINC:-I\$\(WRF_SRC_ROOT_DIR\)/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  ;
+print "$ENV{WRF_MARS}" ;
+if ( $ENV{WRF_MARS} || $ENV{WRF_TITAN} || $ENV{WRF_VENUS} )
+{
+    open ARCH_PLANETAMBLE, "< arch/planetamble" or die "cannot open arch/planetamble" ;
+    while ( <ARCH_PLANETAMBLE> ) { print CONFIGURE_WRF } ;
+    close ARCH_PLANETAMBLE ;
+}
+
+open ARCH_POSTAMBLE, "< arch/postamble" or die "cannot open arch/postamble" ;
+while ( <ARCH_POSTAMBLE> ) { print CONFIGURE_WRF } ;
+close ARCH_POSTAMBLE ;
+close CONFIGURE_WRF ;
+
+printf "Configuration successful. To build the model type compile . \n" ;
+printf "------------------------------------------------------------------------\n" ;
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/arch/Config_new.pl
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/Config_new.pl	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/Config_new.pl	(revision 17)
@@ -0,0 +1,601 @@
+#!/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=""; 
+$sw_opt_level=""; 
+$sw_rwordsize="\$\(NATIVE_RWORDSIZE\)";
+$sw_rttov_flag = "" ;
+$sw_rttov_inc = "" ;
+$sw_crtm_flag = "" ;
+$sw_4dvar_flag = "" ;
+$sw_wavelet_flag = "" ;
+$WRFCHEM = 0 ;
+$sw_os = "ARCH" ;           # ARCH will match any
+$sw_mach = "ARCH" ;         # ARCH will match any
+$sw_wrf_core = "" ;
+$sw_da_core = "-DDA_CORE=\$\(WRF_DA_CORE\)" ;
+$sw_nmm_core = "-DNMM_CORE=\$\(WRF_NMM_CORE\)" ;
+$sw_em_core = "-DEM_CORE=\$\(WRF_EM_CORE\)" ;
+$sw_exp_core = "-DEXP_CORE=\$\(WRF_EXP_CORE\)" ;
+$sw_coamps_core = "-DCOAMPS_CORE=\$\(WRF_COAMPS_CORE\)" ;
+$sw_dmparallel = "" ;
+$sw_ompparallel = "" ;
+$sw_stubmpi = "" ;
+$sw_usenetcdff = "" ;    # for 3.6.2 and greater, the fortran bindings might be in a separate lib file
+$sw_time = "" ;          # name of a timer to time fortran compiles, e.g. timex or time
+$sw_ifort_r8 = 0 ;
+
+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, 10 ) eq "opt_level=" )
+  {
+    $sw_opt_level = substr( $ARGV[0], 11 ) ;
+  }
+  if ( substr( $ARGV[0], 1, 11 ) eq "USENETCDFF=" )
+  {
+    $sw_usenetcdff = substr( $ARGV[0], 12 ) ;
+  }
+  if ( substr( $ARGV[0], 1, 5 ) eq "time=" )
+  {
+    $sw_time = 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, 9 ) eq "wrf_core=" )
+  {
+    $sw_wrf_core = substr( $ARGV[0], 10 ) ;
+    if ( index ( $sw_wrf_core , "EM_CORE" ) > -1 ) 
+    {
+      $sw_em_core = "-DEM_CORE=1" ;
+      $sw_da_core = "-DDA_CORE=0" ;
+      $sw_nmm_core = "-DNMM_CORE=0" ;
+      $sw_exp_core = "-DEXP_CORE=0" ;
+      $sw_coamps_core = "-DCOAMPS_CORE=0" ;
+    }
+    if ( index ( $sw_wrf_core , "DA_CORE" ) > -1 ) 
+    {
+      $sw_em_core = "-DEM_CORE=1" ;
+      $sw_da_core = "-DDA_CORE=1" ;
+      $sw_nmm_core = "-DNMM_CORE=0" ;
+      $sw_exp_core = "-DEXP_CORE=0" ;
+      $sw_coamps_core = "-DCOAMPS_CORE=0" ;
+    }
+    if ( index ( $sw_wrf_core , "4D_DA_CORE" ) > -1 ) 
+    {
+      $sw_em_core = "-DEM_CORE=1" ;
+      $sw_da_core = "-DDA_CORE=1" ;
+      $sw_nmm_core = "-DNMM_CORE=0" ;
+      $sw_exp_core = "-DEXP_CORE=0" ;
+      $sw_coamps_core = "-DCOAMPS_CORE=0" ;
+    }
+    if ( index ( $sw_wrf_core , "NMM_CORE" ) > -1 ) 
+    {
+      $sw_em_core = "-DEM_CORE=0" ;
+      $sw_da_core = "-DDA_CORE=0" ;
+      $sw_nmm_core = "-DNMM_CORE=1" ;
+      $sw_exp_core = "-DEXP_CORE=0" ;
+      $sw_coamps_core = "-DCOAMPS_CORE=0" ;
+    }
+    if ( index ( $sw_wrf_core , "EXP_CORE" ) > -1 ) 
+    {
+      $sw_em_core = "-DEM_CORE=0" ;
+      $sw_da_core = "-DDA_CORE=0" ;
+      $sw_nmm_core = "-DNMM_CORE=0" ;
+      $sw_exp_core = "-DEXP_CORE=1" ;
+      $sw_coamps_core = "-DCOAMPS_CORE=0" ;
+    }
+    if ( index ( $sw_wrf_core , "COAMPS_CORE" ) > -1 ) 
+    {
+      $sw_em_core = "-DEM_CORE=0" ;
+      $sw_da_core = "-DDA_CORE=0" ;
+      $sw_nmm_core = "-DNMM_CORE=0" ;
+      $sw_exp_core = "-DEXP_CORE=0" ;
+      $sw_coamps_core = "-DCOAMPS_CORE=1" ;
+    }
+  }
+  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 ;
+    } 
+  }
+  if ( substr( $ARGV[0], 1, 11 ) eq "dmparallel=" )
+  {
+    $sw_dmparallel=substr( $ARGV[0], 12 ) ;
+  }
+  if ( substr( $ARGV[0], 1, 12 ) eq "ompparallel=" )
+  {
+    $sw_ompparallel=substr( $ARGV[0], 13 ) ;
+  }
+  shift @ARGV ;
+ }
+
+ $sw_fc = "\$(SFC)" ;
+ $sw_cc = "\$(SCC)" ;
+ $sw_comms_lib = "" ;
+ $sw_comms_include = "" ;
+ $sw_dmparallelflag = "" ;
+ $sw_nest_opt = "" ; 
+ $sw_comms_external = "gen_comms_serial module_dm_serial" ;
+
+
+ if ( $sw_dmparallel eq "RSL_LITE" ) 
+ {
+  $sw_fc = "\$(DM_FC)" ;
+  $sw_cc = "\$(DM_CC)" ;
+  $sw_dmparallelflag = "-DDM_PARALLEL" ;
+  $sw_comms_lib = "\$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a" ;
+  $sw_comms_external = "\$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms_rsllite module_dm_rsllite" ;
+  $sw_comms_include = "-I\$(WRF_SRC_ROOT_DIR)/external/RSL_LITE" ;
+ }
+
+# 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" ;
+   }
+
+# When compiling DA code, we need to always use 8-byte reals.
+ if ( $ENV{WRF_DA_CORE} eq "1" || $sw_da_core eq "-DDA_CORE=1" )
+   {
+     $sw_rwordsize = "8";  
+     if ( $ENV{CRTM} )
+       {
+       $sw_crtm_flag = "-DCRTM";
+       }
+     if ( $ENV{RTTOV} )
+       {
+       $sw_rttov_flag = "-DRTTOV";
+       $sw_rttov_inc = "-I$ENV{RTTOV}/include -I$ENV{RTTOV}/mod";
+       }
+     if ( $sw_wrf_core eq "4D_DA_CORE" )
+       {
+       $sw_4dvar_flag = "-DVAR4D";
+       }
+     if ( $ENV{WAVELET} )
+       {
+       $sw_wavelet_flag = "-DWAVELET";
+       }
+   }
+
+# 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};
+   $sw_esmf_ldflag = "yes" ;
+   }
+
+# parse the configure.wrf file
+
+$validresponse = 0 ;
+
+@platforms = qw ( serial smpar dmpar dm+sm ) ;
+
+# 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_new.defaults" 
+      or die "Cannot open ./arch/configure_new.defaults for reading" ;
+  while ( <CONFIGURE_DEFAULTS> )
+  {
+    for $paropt ( @platforms )
+    {
+      if ( substr( $_, 0, 5 ) eq "#ARCH"
+          && ( index( $_, $sw_os ) >= 0 ) && ( index( $_, $sw_mach ) >= 0 ) 
+          && ( index($_, $paropt) >= 0 ) )
+      {
+        $optstr[$opt] = substr($_,6) ;
+        $optstr[$opt] =~ s/^[ 	]*// ;
+        $optstr[$opt] =~ s/#.*$//g ;
+        chomp($optstr[$opt]) ;
+        $optstr[$opt] = $optstr[$opt]." (".$paropt.")" ;
+        if ( substr( $optstr[$opt], 0,4 ) ne "NULL" )
+        {
+          printf "  %2d.  %s\n",$opt,$optstr[$opt] ;
+          $opt++ ;
+        }
+      }
+    }
+  }
+  close CONFIGURE_DEFAULTS ;
+
+  $opt -- ;
+
+  printf "\nEnter selection [%d-%d] : ",1,$opt ;
+  $response = <STDIN> ;
+
+  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, "cat ./arch/configure_new.defaults |"  ;
+$latchon = 0 ;
+while ( <CONFIGURE_DEFAULTS> )
+{
+  if ( substr( $_, 0, 5 ) eq "#ARCH" && $latchon == 1 )
+  {
+    close CONFIGURE_DEFAULTS ;
+    if ( $sw_opt_level eq "-f" ) {
+      open CONFIGURE_DEFAULTS, "cat ./arch/postamble_new ./arch/noopt_exceptions_f |"  or die "horribly" ;
+    } else {
+      open CONFIGURE_DEFAULTS, "cat ./arch/postamble_new ./arch/noopt_exceptions |"  or die "horribly" ;
+    }
+  }
+  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 ;
+    $_ =~ s/CONFIGURE_RWORDSIZE/$sw_rwordsize/g ;
+    $_ =~ s/CONFIGURE_FC/$sw_time $sw_fc/g ;
+    $_ =~ s/CONFIGURE_CC/$sw_cc/g ;
+    $_ =~ s/CONFIGURE_COMMS_LIB/$sw_comms_lib/g ;
+    $_ =~ s/CONFIGURE_COMMS_INCLUDE/$sw_comms_include/g ;
+    $_ =~ s/CONFIGURE_COMMS_EXTERNAL/$sw_comms_external/g ;
+    if ( $sw_os ne "CYGWIN_NT" ) {
+      $_ =~ s/#NOWIN// ;
+    }
+    $_ =~ s/CONFIGURE_DMPARALLEL/$sw_dmparallelflag/g ;
+    $_ =~ s/CONFIGURE_STUBMPI/$sw_stubmpi/g ;
+    $_ =~ s/CONFIGURE_NESTOPT/$sw_nest_opt/g ;
+    $_ =~ s/CONFIGURE_4DVAR_FLAG/$sw_4dvar_flag/g ;
+    $_ =~ s/CONFIGURE_CRTM_FLAG/$sw_crtm_flag/g ;
+    $_ =~ s/CONFIGURE_RTTOV_FLAG/$sw_rttov_flag/g ;
+    $_ =~ s/CONFIGURE_RTTOV_INC/$sw_rttov_inc/g ;
+    $_ =~ s/CONFIGURE_WAVELET_FLAG/$sw_wavelet_flag/g ;
+    if ( $sw_ifort_r8 ) {
+      $_ =~ s/^PROMOTION.*=/PROMOTION       =       -r8 /g ;
+    }
+    if ( $sw_dmparallel ne "" && ($_ =~ /^DMPARALLEL[=\t ]/) ) {
+       $_ =~ s/#// ;
+    }
+    if ( $sw_ompparallel ne "" && ( $_ =~ /^OMPCPP[=\t ]/ || $_ =~ /^OMPCC[=\t ]/ || $_ =~ /^OMP[=\t ]/ ) ) {
+       $_ =~ s/#// ;
+       $_ =~ s/#// ;
+       $_ =~ s/#// ;
+    }
+    if ( $sw_netcdf_path ) 
+      { $_ =~ s/CONFIGURE_WRFIO_NF/wrfio_nf/g ;
+	$_ =~ s:CONFIGURE_NETCDF_FLAG:-DNETCDF: ;
+        if ( $sw_os eq "Interix" ) {
+	  $_ =~ s:CONFIGURE_NETCDF_LIB_PATH:\$\(WRF_SRC_ROOT_DIR\)/external/io_netcdf/libwrfio_nf.a -L$sw_netcdf_path/lib $sw_usenetcdff -lnetcdf : ;
+        } else {
+	  $_ =~ s:CONFIGURE_NETCDF_LIB_PATH:-L\$\(WRF_SRC_ROOT_DIR\)/external/io_netcdf -lwrfio_nf -L$sw_netcdf_path/lib $sw_usenetcdff -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: ;
+        if ( $sw_os eq "Interix" ) {
+	  $_ =~ s:CONFIGURE_PNETCDF_LIB_PATH:\$\(WRF_SRC_ROOT_DIR\)/external/io_pnetcdf/libwrfio_pnf.a -L$sw_pnetcdf_path/lib -lpnetcdf: ;
+        } else {
+	  $_ =~ s:CONFIGURE_PNETCDF_LIB_PATH:-L\$\(WRF_SRC_ROOT_DIR\)/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\$\(WRF_SRC_ROOT_DIR\)/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\$\(WRF_SRC_ROOT_DIR\)/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:CONFIGURE_ESMF_FLAG:-DESMFIO:g ;
+      $_ =~ s:ESMFIOLIB:-L$sw_esmflib_path -lesmf -L\$\(WRF_SRC_ROOT_DIR\)/external/io_esmf -lwrfio_esmf \$\(ESMF_LIB_FLAGS\):g ;
+      $_ =~ s:ESMFIOEXTLIB:-L$sw_esmflib_path -lesmf -L\$\(WRF_SRC_ROOT_DIR\)/external/io_esmf -lwrfio_esmf \$\(ESMF_LIB_FLAGS\):g ;
+      $_ =~ s:ESMFLIBFLAG:\$\(ESMF_LDFLAG\):g ;
+      }
+    else
+      {
+        $_ =~ s:CONFIGURE_ESMF_FLAG::g ;
+        $_ =~ s:ESMFLIBFLAG::g ;
+        if ( $sw_os eq "Interix" ) {
+           $_ =~ s:ESMFIOLIB:\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90/libesmf_time.a:g ;
+           $_ =~ s:ESMFIOEXTLIB:-L\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90/libesmf_time.a:g ;
+        } else {
+           $_ =~ s:ESMFIOLIB:-L\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90 -lesmf_time:g ;
+           $_ =~ s:ESMFIOEXTLIB:-L\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90 -lesmf_time:g ;
+        }
+      }
+     if ( $ENV{HWRF} )
+       {
+        $_ =~ s:CONFIGURE_ATMOCN_LIB:-L\$\(WRF_SRC_ROOT_DIR\)/external/atm_ocn  -latm_ocn:g ;
+        $_ =~ s:CONFIGURE_ATMOCN_INC:-I\$\(WRF_SRC_ROOT_DIR\)/external/atm_ocn:g;
+        $_ =~ s/CONFIGURE_ATMOCN/atm_ocn/g ;
+       }
+     else
+       {
+        $_ =~ s:CONFIGURE_ATMOCN_LIB::g ;
+        $_ =~ s/CONFIGURE_ATMOCN//g ;
+        $_ =~ s:CONFIGURE_ATMOCN_INC::g;
+       }
+
+    if ( ! (substr( $_, 0, 5 ) eq "#ARCH") ) { @machopts = ( @machopts, $_ ) ; }
+    if ( substr( $_, 0, 10 ) eq "ENVCOMPDEF" )
+    {
+      @machopts = ( @machopts, "WRF_CHEM\t=\t$WRFCHEM \n" ) ;
+    }
+  }
+
+# nesting support 
+# 0 = no nesting (only selectable for serial and smpar)
+# 1 = basic nesting (serial and smpar compile with RSL_LITE and STUBMPI; dmpar and dm+sm use RSL_LITE and MPI)
+# 2 = nesting with prescribed moves  (add -DMOVE_NESTS to ARCHFLAGS)
+# 3 = nesting with prescribed moves  (add -DMOVE_NESTS and -DVORTEX_CENTER to ARCHFLAGS) 
+
+  for $paropt ( @platforms )
+  {
+    if ( substr( $_, 0, 5 ) eq "#ARCH" && $latchon == 0 
+          && ( index( $_, $sw_os ) >= 0 ) && ( index( $_, $sw_mach ) >= 0 ) 
+          && ( index($_, $paropt) >= 0 ) )
+    {
+      $x=substr($_,6) ;
+      $x=~s/^[     ]*// ;
+      $x =~ s/#.*$//g ;
+      chomp($x) ;
+      $x = $x." (".$paropt.")" ;
+      if ( $x eq $optstr[$optchoice] )
+      {
+        $latchon = 1 ;
+        $sw_ompparallel = "" ;
+        $sw_dmparallel = "" ;
+        $validresponse = 0 ;
+        #only allow parallel netcdf if the user has chosen parallel option
+        if ( $paropt ne 'dmpar' && $paropt ne 'dm+sm' ) { $sw_pnetcdf_path = "" ; }
+        #
+        until ( $validresponse ) {
+          if ( $paropt eq 'serial' || $paropt eq 'smpar' ) {
+            printf "Compile for nesting? (0=no nesting, 1=basic, 2=preset moves, 3=vortex following) [default 0]: " ;
+          } else {
+            printf "Compile for nesting? (1=basic, 2=preset moves, 3=vortex following) [default 1]: " ;
+          }
+          if ( $ENV{WRF_DA_CORE} eq "1" || $sw_da_core eq "-DDA_CORE=1" ) {
+             $response = 1 ;
+          } elsif ( $ENV{HWRF} ) {
+             printf "HWRF requires moving nests";
+             $response = "2\n";
+          } else {
+             $response = <STDIN> ;
+          } 
+          printf "\n" ;
+          lc $response ;
+          chop $response ;
+          if ( $response == "" || ($response >= 0 && $response <= 3) )
+            { $validresponse = 1 ; }
+          else
+            { printf("\nInvalid response (%d)\n",$response);}
+        }
+        if ( $response == "" ) { 
+          if ( ( $paropt eq 'serial' || $paropt eq 'smpar' ) ) { $response = 0 ; }
+          else                                                 { $response = 1 ; }
+        }
+        if ( $response == 0 ) {
+          if ( ! ( $paropt eq 'serial' || $paropt eq 'smpar' ) ) { $response = 1 ; }
+        } 
+        if ( ( $response == 1 ) || ( $response == 2 ) || ( $response == 3 ) ) {
+          if ( ( $paropt eq 'serial' || $paropt eq 'smpar' ) ) {   # nesting without MPI
+            $sw_stubmpi = "-DSTUBMPI" ;
+            if ( $sw_os ne "CYGWIN_NT" ) {
+              $sw_comms_lib = "\$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a" ;
+            } else {
+              $sw_comms_lib = "../external/RSL_LITE/librsl_lite.a" ;
+            }
+            $sw_comms_external = "\$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms_rsllite module_dm_rsllite" ;
+            $sw_dmparallel = "RSL_LITE" ;
+            $sw_dmparallelflag = "-DDM_PARALLEL" ;
+          }
+        } 
+        if ( $response == 2 ) {
+          $sw_nest_opt = "-DMOVE_NESTS" ; 
+        } elsif ( $response == 3 ) {
+          $sw_nest_opt = "-DMOVE_NESTS -DVORTEX_CENTER" ; 
+        }
+        if ( $paropt eq 'smpar' || $paropt eq 'dm+sm' ) { $sw_ompparallel = "OMP" ; }
+        if ( $paropt eq 'dmpar' || $paropt eq 'dm+sm' ) { 
+          if ( $sw_os ne "CYGWIN_NT" ) {
+            $sw_comms_lib = "\$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a" ;
+          } else {
+            $sw_comms_lib = "../external/RSL_LITE/librsl_lite.a" ;
+          }
+          $sw_comms_external = "\$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms_rsllite module_dm_rsllite" ;
+          $sw_dmparallel = "RSL_LITE" ;
+          $sw_dmparallelflag = "-DDM_PARALLEL" ;
+          $sw_fc = "\$(DM_FC)" ;
+          $sw_cc = "\$(DM_CC)" ;
+        }  # only one option in v3.0
+
+        $sw_ifort_r8 = 0 ;
+        if ( index ( $x, "ifort" ) > -1 || index ( $x, "intel compiler" ) > -1 ) {
+          if ( $sw_rwordsize == 8 ) {
+            $sw_ifort_r8 = 1 ;
+          }
+        }
+      }
+    }
+  }
+}
+close CONFIGURE_DEFAULTS ;
+close POSTAMBLE ;
+close ARCH_NOOPT_EXCEPTIONS ;
+
+open CONFIGURE_WRF, "> configure.wrf" or die "cannot append configure.wrf" ;
+open ARCH_PREAMBLE, "< arch/preamble_new" or die "cannot open arch/preamble_new" ;
+my @preamble;
+# apply substitutions to the preamble...
+while ( <ARCH_PREAMBLE> )
+  {
+  # ESMF substitutions in preamble
+  if ( $sw_esmflib_path && $sw_esmfinc_path )
+    {
+    $_ =~ s/ESMFCOUPLING/1/g ;
+    $_ =~ s:ESMFMODDEPENDENCE:\$\(WRF_SRC_ROOT_DIR\)/external/io_esmf/module_utility.o:g ;
+    $_ =~ s:ESMFMODINC:-I$sw_esmfinc_path -I\$\(WRF_SRC_ROOT_DIR\)/main:g ;
+    $_ =~ s:ESMFIOINC:-I\$\(WRF_SRC_ROOT_DIR\)/external/io_esmf:g ;
+    $_ =~ s:ESMFIODEFS:-DESMFIO:g ;
+    $_ =~ s:ESMFTARGET:wrfio_esmf:g ;
+    }
+  else
+    {
+    $_ =~ s/ESMFCOUPLING/0/g ;
+    $_ =~ s:ESMFMODDEPENDENCE:\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90/module_utility.o:g ;
+    $_ =~ s:ESMFMODINC::g ;
+    $_ =~ s:ESMFIOINC:-I\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90:g ;
+    $_ =~ s:ESMFIODEFS::g ;
+    $_ =~ s:ESMFTARGET:esmf_time:g ;
+    }
+  if ( $ENV{HWRF} )
+    {
+    $_ =~ s:CONFIGURE_ATMOCN_LIB:-L\$\(WRF_SRC_ROOT_DIR\)/external/atm_ocn  -latm_ocn:g ;
+    $_ =~ s/CONFIGURE_ATMOCN/atm_ocn/g ;
+    }
+  else
+    {
+    $_ =~ s:CONFIGURE_ATMOCN_LIB::g ;
+    $_ =~ s/CONFIGURE_ATMOCN//g ;
+    }
+  $_ =~ s:CONFIGURE_EM_CORE:$sw_em_core:g ;
+  $_ =~ s:CONFIGURE_DA_CORE:$sw_da_core:g ;
+  $_ =~ s:CONFIGURE_NMM_CORE:$sw_nmm_core:g ;
+  $_ =~ s:CONFIGURE_COAMPS_CORE:$sw_coamps_core:g ;
+  $_ =~ s:CONFIGURE_EXP_CORE:$sw_exp_core:g ;
+
+  @preamble = ( @preamble, $_ ) ;
+  }
+close ARCH_PREAMBLE ;
+print CONFIGURE_WRF @preamble  ;
+close ARCH_PREAMBLE ;
+printf CONFIGURE_WRF "# Settings for %s\n", $optstr[$optchoice] ;
+print CONFIGURE_WRF @machopts  ;
+print "$ENV{WRF_MARS}" ;
+if ( $ENV{WRF_MARS} || $ENV{WRF_TITAN} || $ENV{WRF_VENUS} )
+{
+    open ARCH_PLANETAMBLE, "< arch/planetamble" or die "cannot open arch/planetamble" ;
+    while ( <ARCH_PLANETAMBLE> ) { print CONFIGURE_WRF } ;
+    close ARCH_PLANETAMBLE ;
+}
+
+close CONFIGURE_WRF ;
+
+printf "Configuration successful. To build the model type compile . \n" ;
+printf "------------------------------------------------------------------------\n" ;
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/arch/Config_old.pl
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/Config_old.pl	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/Config_old.pl	(revision 17)
@@ -0,0 +1,329 @@
+#!/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=""; 
+$sw_rwordsize="\$\(NATIVE_RWORDSIZE\)";
+$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" ;
+   }
+
+# When compiling DA code, we need to always use 8-byte reals.
+ if ( $ENV{WRF_DA_CORE} == "1" )
+   {
+     $sw_rwordsize = "8";  
+   }
+
+# 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_old.defaults" 
+      or die "Cannot open ./arch/configure_old.defaults for reading" ;
+  while ( <CONFIGURE_DEFAULTS> )
+  {
+    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 = <STDIN> ;
+
+  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_old.defaults" 
+      or die "Cannot open ./arch/configure_old.defaults for reading" ;
+$latchon = 0 ;
+while ( <CONFIGURE_DEFAULTS> )
+{
+  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 ;
+    $_ =~ s/CONFIGURE_RWORDSIZE/$sw_rwordsize/g ;
+    if ( $sw_netcdf_path ) 
+      { $_ =~ s/CONFIGURE_WRFIO_NF/wrfio_nf/g ;
+	$_ =~ s:CONFIGURE_NETCDF_FLAG:-DNETCDF: ;
+        if ( $sw_os == Interix ) {
+	  $_ =~ s:CONFIGURE_NETCDF_LIB_PATH:\$\(WRF_SRC_ROOT_DIR\)/external/io_netcdf/libwrfio_nf.a -L$sw_netcdf_path/lib -lnetcdf: ;
+        } else {
+	  $_ =~ s:CONFIGURE_NETCDF_LIB_PATH:-L\$\(WRF_SRC_ROOT_DIR\)/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: ;
+        if ( $sw_os == Interix ) {
+	  $_ =~ s:CONFIGURE_PNETCDF_LIB_PATH:\$\(WRF_SRC_ROOT_DIR\)/external/io_pnetcdf/libwrfio_pnf.a -L$sw_pnetcdf_path/lib -lpnetcdf: ;
+        } else {
+	  $_ =~ s:CONFIGURE_PNETCDF_LIB_PATH:-L\$\(WRF_SRC_ROOT_DIR\)/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\$\(WRF_SRC_ROOT_DIR\)/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\$\(WRF_SRC_ROOT_DIR\)/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_old.defaults
+    if ( $sw_esmflib_path && $sw_esmfinc_path )
+      {
+      $_ =~ s:ESMFIOLIB:-L$sw_esmflib_path -lesmf -L\$\(WRF_SRC_ROOT_DIR\)/external/io_esmf -lwrfio_esmf \$\(ESMF_LIB_FLAGS\):g ;
+      $_ =~ s:ESMFIOEXTLIB:-L$sw_esmflib_path -lesmf -L\$\(WRF_SRC_ROOT_DIR\)/external/io_esmf -lwrfio_esmf \$\(ESMF_LIB_FLAGS\):g ;
+      }
+    else
+      {
+        if ( $sw_os == Interix ) {
+           $_ =~ s:ESMFIOLIB:\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90/libesmf_time.a:g ;
+           $_ =~ s:ESMFIOEXTLIB:-L\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90/libesmf_time.a:g ;
+        } else {
+           $_ =~ s:ESMFIOLIB:-L\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90 -lesmf_time:g ;
+           $_ =~ s:ESMFIOEXTLIB:-L\$\(WRF_SRC_ROOT_DIR\)/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_old.defaults\n" ;
+#printf "\n" ;
+
+open CONFIGURE_WRF, "> configure.wrf" or die "cannot append configure.wrf" ;
+open ARCH_PREAMBLE, "< arch/preamble_old" or die "cannot open arch/preamble_old" ;
+my @preamble;
+# apply substitutions to the preamble...
+while ( <ARCH_PREAMBLE> )
+  {
+  # ESMF substitutions in preamble
+  if ( $sw_esmflib_path && $sw_esmfinc_path )
+    {
+    $_ =~ s/ESMFCOUPLING/1/g ;
+    $_ =~ s:ESMFMODDEPENDENCE:\$\(WRF_SRC_ROOT_DIR\)/external/io_esmf/module_utility.o:g ;
+    $_ =~ s:ESMFMODINC:-I$sw_esmfinc_path -I\$\(WRF_SRC_ROOT_DIR\)/main:g ;
+    $_ =~ s:ESMFIOINC:-I\$\(WRF_SRC_ROOT_DIR\)/external/io_esmf:g ;
+    $_ =~ s:ESMFIODEFS:-DESMFIO:g ;
+    $_ =~ s:ESMFTARGET:wrfio_esmf:g ;
+    }
+  else
+    {
+    $_ =~ s/ESMFCOUPLING/0/g ;
+    $_ =~ s:ESMFMODDEPENDENCE:\$\(WRF_SRC_ROOT_DIR\)/external/esmf_time_f90/module_utility.o:g ;
+    $_ =~ s:ESMFMODINC::g ;
+    $_ =~ s:ESMFIOINC:-I\$\(WRF_SRC_ROOT_DIR\)/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  ;
+print "$ENV{WRF_MARS}" ;
+if ( $ENV{WRF_MARS} || $ENV{WRF_TITAN} || $ENV{WRF_VENUS} )
+{
+    open ARCH_PLANETAMBLE, "< arch/planetamble" or die "cannot open arch/planetamble" ;
+    while ( <ARCH_PLANETAMBLE> ) { print CONFIGURE_WRF } ;
+    close ARCH_PLANETAMBLE ;
+}
+
+open ARCH_POSTAMBLE, "< arch/postamble_old" or die "cannot open arch/postamble_old" ;
+while ( <ARCH_POSTAMBLE> ) { print CONFIGURE_WRF } ;
+close ARCH_POSTAMBLE ;
+close CONFIGURE_WRF ;
+
+printf "Configuration successful. To build the model type compile . \n" ;
+printf "------------------------------------------------------------------------\n" ;
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/arch/README.canonical_stanza
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/README.canonical_stanza	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/README.canonical_stanza	(revision 17)
@@ -0,0 +1,89 @@
+###########################################################
+#ARCH    <os> (fortran) compiler with (C) compiler # serial smpar dmpar dm+sm
+#
+# (The last four words on the line above indicate what parallel modes are supported for this build.
+#  Presence of serial indicates the code can be built single-threaded and an option will be presented
+#  by the configure script for this.  Likewise, presence of smpar indicates shared-memory parallel (OpenMP),
+#  dmpar indicates distributed memory parallel (MPI), and dm+sm indicates both.  The comment character
+#  before the first word is not necessary but it makes the choices neater when the configure script 
+#  displays them to the user)
+#
+# (The settings below should be all that are needed per architecture/installation. The rest of the 
+#  configuration settings are based on these and are done in the postamble (arch/postamble) )
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # (compiler dependent option for openmp, e.g. -mp for pgi; leave commented out)
+SFC             =       (serial fortran compiler)
+SCC             =       (serial C compiler)
+DM_FC           =       (Fortran compile command for mpi, eg: mpif90 -f90=$(SFC))
+DM_CC           =       (C compile comand for mpi, eg: mpicc -cc=$(SCC))
+FC              =       CONFIGURE_FC    (leave as is: to be filled in by configure depending on parallel option)
+CC              =       CONFIGURE_CC    (leave as is: to be filled in by configure depending on parallel option
+LD              =       $(FC)		(usually leave as is)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE   # filled in by configure or hard coded to 8 (for var)
+PROMOTION       =       (compiler specific option for promotion: e.g. -r$(RWORDSIZE) -i4)
+ARCH_LOCAL      =       (local additions to ARCHFLAGS)
+CFLAGS_LOCAL    =       (local additions to CFLAGS)
+LDFLAGS_LOCAL   =       (local additions to LDFLAGS)
+FCOPTIM         =       (optimization options to Fortran compiler)
+FCREDUCEOPT     =       (optional: used by noop_exceptsions for certain routines that won't work with full opt on certain compilers)
+FCNOOPT         =       (flag that turns off optimization)
+FCDEBUG         =       (debug and no optimization options to Fortran compiler)
+FORMAT_FIXED    =       (fortran compiler option for fixed format)
+FORMAT_FREE     =       (fortran compiler option for free format)
+FCSUFFIX        =       (tell the compiler what a fortran file's suffix looks like -- AIX needs)
+BYTESWAPIO      =       (option to give bigendian unformatted fortran output, if needed)
+FCBASEOPTS      =       $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) (basic options to fortran compiler, but not optim.)
+MODULE_SRCH_FLAG =      (flag to compiler to tell it where to search for modules -- PGI needs)
+TRADFLAG        =       (flag to cpp to tell it to act like it did before script kiddies got hold of it)
+CPP             =       (cpp command)
+AR              =       (ar command)
+ARFLAGS         =       (flags to ar command, want ru capability)
+M4              =       (m4 command)
+RANLIB          =       (ranlib command if needed)
+CC_TOOLS        =       (the cc command that should be used for compiling in the tools directory. Often just cc or $(SCC) )
+
+#optional (used for BG/L, for example, where the mpi args and paths have to be specified explicitly)
+MPI_INC         =       (e.g. -I/bgl/BlueLight/ppcfloor/bglsys/include)
+MPI_LIB         =       (e.g. -L/bgl/BlueLight/ppcfloor/bglsys/lib -lmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts)
+
+---
+Here is an example:
+
+###########################################################
+#ARCH    Linux x86_64, PGI compiler with gcc # serial smpar dmpar dm+sm
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -mp -Minfo=mp
+SFC             =       pgf90
+SCC             =       gcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       -r$(RWORDSIZE) -i4
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR # but for ifort compiler, it is -DNONSTANDARD_SYSTEM_FUNC
+CFLAGS_LOCAL    =       -w -O3
+LDFLAGS_LOCAL   =      
+FCOPTIM         =       -fastsse -Mvect=noaltcode -Msmartalloc -Mprefetch=distance:8 -Mfprelaxed # -Minfo=all =Mneginfo=all
+FCREDUCEDOPT    =       $(FCOPTIM)
+FCNOOPT         =       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -Mfixed
+FORMAT_FREE     =       -Mfree
+FCSUFFIX        =
+BYTESWAPIO      =       -byteswapio
+FCBASEOPTS      =       -w $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO)
+MODULE_SRCH_FLAG =     -module $(WRF_SRC_ROOT_DIR)/main
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -B 14000
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC)
+
Index: branches/LMDZ_WRFmeas/WRFV3/arch/SOURCEME_WINCCS_WRF
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/SOURCEME_WINCCS_WRF	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/SOURCEME_WINCCS_WRF	(revision 17)
@@ -0,0 +1,34 @@
+#setenv PGI "/dev/fs/C/Program Files/PGI"
+#setenv INCLUDE "/dev/fs/C/Program Files/Microsoft Platform SDK for Windows Server 2003 R2/Include/crt;/dev
+
+setenv TMPDIR /tmp
+setenv PGI "c:\Program Files\PGI"
+setenv INCLUDE "c:\Program Files\Microsoft Platform SDK for Windows Server 2003 R2\Include\crt;c:\Program Files\Microsoft Platform SDK\Include"
+setenv LIB "c:\Program Files\Microsoft Platform SDK for Windows Server 2003 R2\Lib\AMD64"
+set path=(/dev/fs/C/Program\ Files/PGI/win64/7.0-5/bin /dev/fs/C/Program\ Files/Microsoft\ Platform\ SDK\ for\ Windows\ Server\ 2003\ R2/Bin/win64/x86/AMD64 /dev/fs/C/Program\ Files/PGI/Microsoft\ Open\ Tools\ 8/bin/amd64 $path .)
+
+setenv FC pgf90.exe
+setenv F77 pgf90.exe
+setenv CC pgcc.exe
+
+setenv NETCDFMASTER '/dev/fs/C/Documents and Settings/michalak/netcdf'
+setenv SCRATCHDIR "/dev/fs/C/scratch/$USER"
+setenv NETCDF "c:/scratch/$USER/netcdf"
+
+if ( ! -d $SCRATCHDIR ) then
+   mkdir -p $SCRATCHDIR
+endif
+
+( cd "$NETCDFMASTER/.." ; tar cf - ./netcdf | ( cd "$SCRATCHDIR" ; tar xvf - ; cp netcdf/lib/libnetcdf.a netcdf/lib/libnetcdf.lib ) )
+
+exit
+
+echo "   "
+echo " SOURCEME_WINCCS_WRF"
+echo "   "
+echo " To build NetCDF on WinCCS x86-64..."
+echo "   Untar WINCCS_WRF.tar in this directory."
+echo "   ./candlink.csh"
+echo "   "
+echo "   "
+
Index: branches/LMDZ_WRFmeas/WRFV3/arch/archive_configure.defaults
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/archive_configure.defaults	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/archive_configure.defaults	(revision 17)
@@ -0,0 +1,11294 @@
+#
+#  WARNING
+#
+#  THIS IS THE OLD V2 CONFIGURE DEFAULTS FILE, KEPT AROUND FOR REFERENCE
+#  BUT IS NOT USED OR MAINTAINED AT ALL IN V3.  MOST OF THE COMMON SETTINGS
+#  HAVE BEEN MOVED TO THE NEW V3 CONFIGURATION MECHANISM AND 
+#  FILE: configure_new.defaults
+#  SEVERAL OTHER SETS OF OPTIONS HAVE BEEN PRESERVED BUT MOVED INTO THE
+#  FILE: configure_old.defaults.  
+#
+##########################################################
+#ARCH	SGI 32 bit machine IRIX
+
+FC		=	f90
+SFC		=	$(FC)
+LD		=	f90
+CC              =       cc
+SCC		=	$(CC)
+RWORDSIZE       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+ARCHFLAGS       =       $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DLIMIT_ARGS $(DA_ARCHFLAGS)
+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             =	$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	make NETCDFPATH=CONFIGURE_NETCDF_PATH FC="$(FC) $(PROMOTION) -freeform -I." RANLIB="$(RANLIB)" CPP="$(CPP)" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RANLIB="$(RANLIB)" CPP="$(CPP)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o  start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem  \
+                       	-I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -I$(WRF_SRC_ROOT_DIR)/inc
+ARCHFLAGS       =       $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \
+			$(DA_ARCHFLAGS) \
+                        -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             =	$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH FC="$(FC) $(PROMOTION) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+ARCHFLAGS       =       $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG \
+                        -DINTIO -DLIMIT_ARGS -DLANDREAD_STUB
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH FC="$(FC) $(PROMOTION) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RANLIB="$(RANLIB)" CPP="$(CPP)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o  start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share \
+                        -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+ARCHFLAGS       =       $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        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$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RANLIB="$(RANLIB)" CPP="$(CPP)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o  start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem \
+			-M$(WRF_SRC_ROOT_DIR)/external/io_netcdf -M$(WRF_SRC_ROOT_DIR)/external/io_int -M$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+			-M$(WRF_SRC_ROOT_DIR)/frame -M$(WRF_SRC_ROOT_DIR)/share -M$(WRF_SRC_ROOT_DIR)/phys -M$(WRF_SRC_ROOT_DIR)/inc -M$(WRF_SRC_ROOT_DIR)/chem \
+			-M$(WRF_SRC_ROOT_DIR)/dyn_em 
+ARCHFLAGS       =       $(COREDEFS) -DINTIO -DGRIB1 CONFIGURE_GRIB2_FLAG -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG \
+			-DLIMIT_ARGS
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS) " )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+solve_interface.o : solve_interface.F
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.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       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem \
+			-M$(WRF_SRC_ROOT_DIR)/external/io_netcdf -M$(WRF_SRC_ROOT_DIR)/external/io_int -M$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+			-M$(WRF_SRC_ROOT_DIR)/frame -M$(WRF_SRC_ROOT_DIR)/share -M$(WRF_SRC_ROOT_DIR)/phys -M$(WRF_SRC_ROOT_DIR)/inc -M$(WRF_SRC_ROOT_DIR)/chem \
+			-M$(WRF_SRC_ROOT_DIR)/dyn_em 
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG \
+			-DLIMIT_ARGS
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS) " )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+solve_interface.o : solve_interface.F
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+###########################################################
+#ARCH   AIX                      (single-threaded, no nesting)
+#
+FC              =       xlf90_r
+SFC		=	$(FC)
+LD              =       xlf90_r
+CC              =       cc_r
+SCC		=	$(CC)
+RWORDSIZE       =       CONFIGURE_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
+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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG \
+			-DLIMIT_ARGS  -DNATIVE_MASSV
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -lmass -lmassv \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c -g $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90
+
+###########################################################
+#ARCH   AIX                      (single-threaded, nesting, RSL_LITE w/o MPI)
+#
+FC              =       xlf90_r
+SFC		=	$(FC)
+LD              =       xlf90_r
+CC              =       cc_r
+SCC		=	$(CC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-qrealsize=$(RWORDSIZE) -qintsize=4
+CFLAGS          =       -DNOUNDERSCORE -DNCARIBM_NOC99 -DSTUBMPI
+FCOPTIM         =       -O2 -qarch=auto
+#FCOPTIM         =       -O3 -qhot
+FCDEBUG         =       # -qnoopt -qfullpath
+FCBASEOPTS      =       -qspill=20000 $(FCDEBUG) -qmaxmem=32767 -w -DSTUBMPI #-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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG \
+			-DLIMIT_ARGS -DNATIVE_MASSV
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -lmass -lmassv \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC="$(CC) $(CFLAGS)" FC="$(FC) $(FCFLAGS) $(PROMOTION) " MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG \
+			-DLIMIT_ARGS  -DNATIVE_MASSV
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -lmass -lmassv -lxlsmp \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_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 module_comm_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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90
+
+###########################################################
+#ARCH   AIX SM                   (OpenMP, nesting, RSL_LITE w/o MPI)
+#
+OMP             =       -qsmp=noauto:noopt
+OMPCPP          =       -D_OPENMP
+FC              =       xlf90_r
+SFC		=	$(FC)
+LD              =       xlf90_r
+CC              =       cc_r
+SCC		=	$(CC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-qrealsize=$(RWORDSIZE) -qintsize=4
+CFLAGS          =       -DNOUNDERSCORE -DNCARIBM_NOC99 -DSTUBMPI
+FCOPTIM         =       -O2 -qarch=auto
+#FCOPTIM         =       -O3 -qhot
+FCDEBUG         =       # -qnoopt -qfullpath
+FCBASEOPTS      =       -w -qspill=20000 $(FCDEBUG) -qmaxmem=32767 -DSTUBMPI #-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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG \
+			-DLIMIT_ARGS -DNATIVE_MASSV
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -lmass -lmassv -lxlsmp \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+module_dm.F :  $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC="$(CC) $(CFLAGS)" FC="$(FC) $(FCFLAGS) $(PROMOTION) " MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST )
+
+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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_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 module_comm_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$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-qrealsize=$(RWORDSIZE) -qintsize=4
+CFLAGS          =       -DNOUNDERSCORE  -I$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_pnetcdf \
+                        -I$(WRF_SRC_ROOT_DIR)/external/io_int $(ESMF_IO_INC) \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc $(ESMF_MOD_INC)
+ARCHFLAGS       =       $(COREDEFS) -DRSL_LITE -DDM_PARALLEL -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \
+			$(DA_ARCHFLAGS) \
+                        -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG CONFIGURE_PNETCDF_FLAG \
+                        -DTRIEDNTRUE -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \
+			-DLIMIT_ARGS  -DNATIVE_MASSV -DNMM_NEST=$(WRF_NMM_NEST) $(ESMF_IO_DEFS)
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PNETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite -lmass -lmassv \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int  \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F $(ESMF_TARGET) fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_pnf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_pnetcdf ; make NETCDFPATH=CONFIGURE_PNETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" 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_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
+module_comm_dm.o : module_comm_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_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 module_comm_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$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-qrealsize=$(RWORDSIZE) -qintsize=4
+CFLAGS          =       -DNOUNDERSCORE  -I$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/io_netcdf  -I$(WRF_SRC_ROOT_DIR)/external/io_phdf5 -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+ARCHFLAGS       =       $(COREDEFS) -DRSL_LITE -DDM_PARALLEL -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \
+			$(DA_ARCHFLAGS) \
+                        -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG CONFIGURE_PHDF5_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \
+			-DLIMIT_ARGS  -DNATIVE_MASSV
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PHDF5_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite -lmass -lmassv \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int  \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_phdf5 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/inc )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" 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_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
+module_comm_dm.o : module_comm_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_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 module_comm_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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt $*.f90
+
+###########################################################
+#ARCH	AIX DM-Parallel          (RSL_LITE, 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       =       CONFIGURE_RWORDSIZE
+MCELHOME        =       /home/bluesky/bettenc/disttest
+PROMOTION	=	-qrealsize=$(RWORDSIZE) -qintsize=4
+CFLAGS          =       -DNOUNDERSCORE  -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -DDM_PARALLEL  \
+                        -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -DNCARIBM_NOC99
+FCOPTIM         =       -O2 -qarch=auto
+FCDEBUG         =       # -qnoopt -qfullpath
+FCBASEOPTS      =       -w -qspill=20000 $(FCDEBUG) -qmaxmem=32767 #-qflttrap=zerodivide:invalid:enable -qsigtrap
+FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS)
+# 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$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+ARCHFLAGS       =       -DRSL_LITE -DDM_PARALLEL -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \
+			$(DA_ARCHFLAGS) \
+                        -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG -DTRIEDNTRUE   -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DMCELIO -DLIMIT_ARGS \
+                         -DNATIVE_MASSV
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                        -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite -lmass -lmassv -lxlsmp \
+                        -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int  \
+                        $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int wrfio_mcel gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( cat $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c > $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( cat module_dm_warning $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F > module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+wrfio_mcel : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_mcel ; \
+          make CC="$(CC)" FC="$(SFC) $(PROMOTION) $(FCDEBUG) -I$(WRF_SRC_ROOT_DIR)/inc -I../io_netcdf -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share \
+               -I$(MCELHOME)/MCELSystem/MCEL -qfree=f90" all )
+
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC="$(CC)" CFLAGS="$(CFLAGS)" FC="$(SFC) $(PROMOTION) $(FCFLAGS)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST )
+
+# compile these without high optimization
+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
+module_comm_dm.o : module_comm_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
+
+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 module_comm_dm.o start_domain.o \
+module_configure.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                                              \
+convert_nmm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) -qnoopt $*.f
+
+###########################################################
+#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       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-qrealsize=$(RWORDSIZE) -qintsize=4
+CFLAGS          =       -DNOUNDERSCORE -DNCARIBM_NOC99 $(MPI_INC) -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -DLANDREAD_STUB -DDM_PARALLEL
+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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_pnetcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc 
+
+ARCHFLAGS       =       $(COREDEFS) -DDM_PARALLEL -DRSL_LITE -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG CONFIGURE_PNETCDF_FLAG \
+			-DLIMIT_ARGS  -DNATIVE_MASSV -DLANDREAD_STUB
+
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PNETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite -L/bgl/local/lib -lmass -lmassv \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+			-L/home/michalak/fftpack5 -lfftpack \
+			$(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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a CONFIGURE_WRFIO_NF CONFIGURE_WRFIO_PNF wrfio_int module_dm.F esmf_time gen_comms.c fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH="$(NETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_pnf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_pnetcdf ; make NETCDFPATH=CONFIGURE_PNETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(MPI_INC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+esmf_time : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" 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$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_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 module_comm_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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+RSIZEBITS	=	`expr $(RWORDSIZE) \* 8`
+ARCHFLAGS       =       $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time  \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_dm.F
+mediation_wrfmain.o : mediation_wrfmain.F
+solve_em.o : solve_em.F
+
+mediation_integrate.o module_dm.o module_comm_dm.o mediation_wrfmain.o solve_em.o : 
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+RSIZEBITS	=	`expr $(RWORDSIZE) \* 8`
+ARCHFLAGS       =       $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_dm.F
+mediation_wrfmain.o : mediation_wrfmain.F
+solve_em.o : solve_em.F
+
+mediation_integrate.o module_dm.o module_comm_dm.o mediation_wrfmain.o solve_em.o : 
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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 ARW and NMM 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       =       CONFIGURE_RWORDSIZE
+RSIZEBITS	=	`expr $(RWORDSIZE) \* 8`
+ARCHFLAGS       =       $(COREDEFS) -DNETCDF -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite  \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; \
+          make CPP="$(CPP) $(CPPFLAGS)" 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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_dm.F
+mediation_wrfmain.o : mediation_wrfmain.F
+solve_em.o : solve_em.F
+
+mediation_integrate.o module_dm.o module_comm_dm.o mediation_wrfmain.o solve_em.o : 
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+RSIZEBITS	=	`expr $(RWORDSIZE) \* 8`
+ARCHFLAGS       =       $(COREDEFS) -DAUTODOC_BUILD CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO \
+			$(DA_ARCHFLAGS) \
+                        -DDM_PARALLEL="'<b>DM_PARALLEL</b>'" -DRSL_LITE="'<b>RSL_LITE</b>'" \
+                        -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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL/librsl_lite.a gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL/RSL/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; \
+          make CC="$(CC)" FC="$(FC) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) all )
+
+# 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$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_dm.F
+mediation_wrfmain.o : mediation_wrfmain.F
+solve_em.o : solve_em.F
+
+mediation_integrate.o module_dm.o module_comm_dm.o mediation_wrfmain.o solve_em.o : 
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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 ARW and NMM 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       =       CONFIGURE_RWORDSIZE
+RSIZEBITS	=	`expr $(RWORDSIZE) \* 8`
+ARCHFLAGS       =       $(COREDEFS) -DNETCDF -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite  \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; \
+          make CPP="$(CPP) $(CPPFLAGS)" 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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_dm.F
+mediation_wrfmain.o : mediation_wrfmain.F
+solve_em.o : solve_em.F
+
+mediation_integrate.o module_dm.o module_comm_dm.o mediation_wrfmain.o solve_em.o : 
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+                        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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o  -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; \
+	  cat  module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASENOINL) -w" TRADFLAG="-traditional" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \
+          TRADFLAG="-traditional" archive )
+
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+                        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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o  -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          /bin/cp module_dm_warning module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASENOINL) -w" TRADFLAG="-traditional" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \
+          TRADFLAG="-traditional" archive )
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+			-DLIMIT_ARGS
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             = 	$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -Free -X9" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -Free -X9" archive)
+
+wrfio_grib1 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -Free -X9" archive )
+
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+			-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             = 	$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time  \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" archive)
+
+wrfio_grib1 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" archive )
+
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+SFC             =       $(FC)
+PROMOTION	=	-r$(RWORDSIZE) -i4
+CFLAGS          =
+FCOPTIM		=	-O2 # -fast
+FCDEBUG		=	#-g
+FCBASEOPTS      =       -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG)
+#FCBASEOPTS      =       -w -byteswapio -Mfree -Mipa=fast,inline,safe  $(FCDEBUG) # -Mlfs
+FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS)
+ARCHFLAGS       =       $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                         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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+                         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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-r$(RWORDSIZE) -i4
+CFLAGS          =       -DDM_PARALLEL \
+                        -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I$(WRF_SRC_ROOT_DIR)/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 \
+			$(DA_ARCHFLAGS) \
+			-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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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 x86_64 (IA64 and Opteron), gfortran compiler 4.3.0 or higher  (single threaded)
+#
+#
+OMP               =
+OMPCPP            =
+FC                = gfortran
+LD                = $(FC)
+CC                = gcc
+SCC               = gcc
+CC_TOOLS          = $(SCC)
+SFC               = gfortran
+RWORDSIZE         = $(NATIVE_RWORDSIZE)
+FCOPTIM           = -O3
+CFLAGS            = -w -O3 -c -DLANDREAD_STUB
+FCDEBUG           = # -O0 -g
+FCBASEOPTS        = -fconvert=big-endian -frecord-marker=4 -I. $(FCDEBUG) -ffree-form
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+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   = -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
+PERL              = perl
+REGISTRY          = Registry
+LIB               = CONFIGURE_NETCDF_LIB_PATH $(OMP) \
+                    -L../external/fftpack/fftpack5 -lfftpack \
+                    -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           =  $(OMP)
+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 -G
+RANLIB            =  ranlib
+NETCDFPATH        =  CONFIGURE_NETCDF_PATH
+
+externals :  wrfio_nf wrfio_int module_dm.F wrfio_grib_share wrfio_grib1  esmf_time fftpack
+
+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=/home/michalak/netcdf 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)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -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="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd ../external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd ../external/io_grib2 ; \
+          make CC="$(CC) " CPP="$(CPP) " RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd ../external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd ../external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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
+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_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) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+# Force even lower optimization level for these files to decrease
+# compilation time and lower memory demands
+module_dm.o : module_dm.F
+solve_em.o : solve_em.F
+start_em.o : start_em.F
+
+solve_em.o \
+start_em.o \
+module_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(FCBASEOPTS) $(FCDEBUG) -O0 $(MODULE_DIRS) $*.f90
+
+###########################################################
+#ARCH    PC Linux x86_64 (IA64 and Opteron), gfortran compiler 4.3.0 or higher  (MPICH, RSL_LITE)
+#
+# 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            =
+MAX_PROC          = 1024
+MPI_HOME          = $(MPICH)
+FC                = $(MPI_HOME)/bin/mpif90 -f90=gfortran
+LD                = $(FC)
+CC                = $(MPI_HOME)/bin/mpicc -cc=gcc
+SCC               = gcc
+CC_TOOLS          = $(SCC)
+SFC               = gfortran
+RWORDSIZE         = $(NATIVE_RWORDSIZE)
+FCOPTIM           = -O3
+CFLAGS            = -w -O3 -c -DDM_PARALLEL  -I../external/RSL_LITE -DLANDREAD_STUB
+FCDEBUG           = # -O0 -g
+FCBASEOPTS        = -fconvert=big-endian -frecord-marker=4 -I. $(FCDEBUG) -ffree-form
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DDM_PARALLEL \
+                    -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   = -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
+PERL              = perl
+REGISTRY          = Registry
+LIB               = CONFIGURE_NETCDF_LIB_PATH -L../external/RSL_LITE -lrsl_lite $(OMP) \
+                    -L../external/fftpack/fftpack5 -lfftpack \
+                    -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           =  $(OMP)
+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 -G
+RANLIB            =  ranlib
+NETCDFPATH        =  CONFIGURE_NETCDF_PATH
+
+externals :  wrfio_nf ../external/RSL_LITE/librsl_lite.a gen_comms.c wrfio_int module_dm.F wrfio_grib_share wrfio_grib1  esmf_time fftpack
+
+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 )
+
+../external/RSL_LITE/librsl_lite.a :
+	( cd ../external/RSL_LITE ; make CC='$(CC) -I. $(CFLAGS) -DMPI2_SUPPORT -I$(MPI_HOME)/include '\
+	 FC='$(FC) $(FCFLAGS) -I../../.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) )
+
+wrfio_nf :
+	( cd ../external/io_netcdf ; \
+          make NETCDFPATH=/home/michalak/netcdf 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)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -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="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd ../external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd ../external/io_grib2 ; \
+          make CC="$(CC) " CPP="$(CPP) " RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd ../external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I../../inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd ../external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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
+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_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) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+# Force even lower optimization level for these files to decrease
+# compilation time and lower memory demands
+module_dm.o : module_dm.F
+solve_em.o : solve_em.F
+start_em.o : start_em.F
+
+solve_em.o \
+start_em.o \
+module_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I../inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(FCBASEOPTS) $(FCDEBUG) -O0 $(MODULE_DIRS) $*.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) -o $@ -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) -o $@ -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) -o $@ -c $(CFLAGS) $*.c
+
+###########################################################
+#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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+                         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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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)
+#        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       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-r$(RWORDSIZE) -i4
+CFLAGS          =       -DDM_PARALLEL \
+                        -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE \
+                        -DLANDREAD_STUB
+FCOPTIM         =       -fastsse #-Mipa=fast
+FCDEBUG		=	#-g
+FCBASEOPTS      =       -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG)
+FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS)
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DDM_PARALLEL \
+			$(DA_ARCHFLAGS) \
+                        -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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+###########################################################
+#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       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-r$(RWORDSIZE) -i4
+CFLAGS     = -DDM_PARALLEL -w -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) \
+             -I$(WRF_SRC_ROOT_DIR)/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 \
+            $(DA_ARCHFLAGS) \
+            -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 = $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                  -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc  -I$(WRF_SRC_ROOT_DIR)/chem \
+                  -I/usr/lib/mpi/mpi_intel/include
+PERL = perl
+REGISTRY = Registry
+LIB = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) -LCONFIGURE_NETCDF_PATH/lib -lnetcdf -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+      $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -EP `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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_LITE, VMI, allows ARW and NMM 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 = $(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-r$(RWORDSIZE) -i4
+CFLAGS = -DDM_PARALLEL -I$(WRF_SRC_ROOT_DIR)/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 \
+$(DA_ARCHFLAGS) \
+-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 = $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+-I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL = perl
+REGISTRY = Registry
+LIB = -Vaxlib -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) -L/u/ncsa/straka/AUGUST.test/WRFV1/netcdfintel7/lib -lnetcdf -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L/usr/local/vmi/mpich/lib/ecc6 -lmpich -lfmpich -lvmi -ldl -lpthread -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -Vaxlib -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS) -w" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC='ecc -Vaxlib -I. -cm -w -I/usr/local/vmi/mpich/include' \
+	FC="$(FC) $(PROMOTION) $(FCFLAGS) -cm -w -Vaxlib -I$(WRF_SRC_ROOT_DIR)/.. " 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+ARCHFLAGS       =       $(COREDEFS)  -DLIMIT_ARGS -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) \
+			$(DA_ARCHFLAGS) \
+                        -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 $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -FR -I. -w" )
+
+wrfio_grib_share : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive)
+
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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 module_comm_dm.o  start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $*.f90
+
+module_dm.o : module_dm.F
+module_comm_dm.o : module_comm_dm.F
+module_configure.o : module_configure.F
+
+module_configure.o \
+module_dm.o module_comm_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) -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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+                         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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive)
+
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# compile these without high optimization to speed compile
+solve_interface.o : solve_interface.F
+solve_em.o : solve_em.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                                              \
+solve_em.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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(OMP) $(MODULE_DIRS) $*.f90
+
+module_dm.o : module_dm.F
+module_comm_dm.o : module_comm_dm.F
+module_configure.o : module_configure.F
+
+module_configure.o \
+module_dm.o module_comm_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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_LITE, MPICH)
+#
+# 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       =       CONFIGURE_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 -DRSL_LITE -DDM_PARALLEL \
+                        -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \
+			$(DA_ARCHFLAGS) \
+                        -DMPI  \
+			-DLIMIT_ARGS 
+CFLAGS          =       -w -DDM_PARALLEL $(ARCHFLAGS) \
+                        -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE
+# 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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCFLAGS) -w" archive)
+
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; \
+          make CPP="$(CPP) $(CPPFLAGS)" CC="$(CC)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" 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
+start_domain.o : start_domain.F
+solve_em.o : solve_em.F
+start_em.o : start_em.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 solve_em.o start_em.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+module_dm.o : module_dm.F
+module_comm_dm.o : module_comm_dm.F
+module_configure.o : module_configure.F
+
+module_configure.o \
+module_dm.o module_comm_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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) $(DA_ARCHFLAGS)
+PROMOTION	=	
+CFLAGS		=	$(ARCHFLAGS)
+
+FCFLAGS		=	-w -Ep -C ssafe \
+			-sx6 -USX -ew -D$(RUNTIME_SYSTEM) -I$(LIBINCLUDE) -I$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  \
+                        -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf -L/usr/local/netcdf/current/lib -lnetcdf -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			-L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/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)
+
+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 fftpack
+
+module_dm.F:
+	( /sbin/cp module_dm_warning module_dm.F ; \
+	  cat module_dm_stubs.F  >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=/usr/local/netcdf/current FC="$(FC) $(PROMOTION) $(FCFLAGS)"  )
+
+
+wrfio_int :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+	  make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ;\
+ 	make FC="$(FC) $(PROMOTION) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) $(CPPFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o  start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCFLAGS) $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    SGI Altix, Intel Itanium2 ia64 Linux, ifort+icc 9.x,10.x DM-Parallel (SGI MPI, OpenMP, 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#
+#        Hybrid OpenMP+MPI configurations might be helpfull to improve  scaling for multicore architecures
+#        and  reasonably large workloads (i.e. for CONUT12km hybrid configurations are not likely to give any
+#        performance improvements).
+#
+#        To improve performance on Itanium2 architecture you might want to use '-IPF-fp-relaxed' flag, which enables
+#        use of faster but slightly less accurate code sequences for math functions, such as divide and sqrt,
+#        and enables the performance of more aggressive floating-point transformations, which may affect accuracy.
+#
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin/mpiicc -nocompchk
+
+DMPARALLEL        = 1
+OMP               = -openmp -fpp -auto
+OMPCPP            = -D_OPENMP
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          = /usr
+FC                = ifort
+LD                = $(FC)
+CC                = icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c -DDM_PARALLEL  -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -openmp
+FCOPTIM           = -O3
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -ftz -align all -FR -convert big_endian \
+                    -fno-alias -tpp2 \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DRSL_LITE -DDM_PARALLEL \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                    -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                    -L/usr/lib -lmpi -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/inc/dm_comm_cpp_flags` \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals :  CONFIGURE_WRFIO_NF $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC='$(CC) -I. $(CFLAGS) -DMPI2_SUPPORT -I$(MPI_HOME)/include '\
+	 FC='$(FC) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    SGI Altix, Intel Itanium2 ia64 Linux, ifort+icc 9.x,10.x DM-Parallel (SGI MPI, 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#
+#        To improve performance on Itanium2 architecture you might want to use '-IPF-fp-relaxed' flag, which enables
+#        use of faster but slightly less accurate code sequences for math functions, such as divide and sqrt,
+#        and enables the performance of more aggressive floating-point transformations, which may affect accuracy.
+#
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin/mpiicc -nocompchk
+
+DMPARALLEL        = 1
+OMP               =
+OMPCPP            =
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          = /usr
+FC                = ifort
+LD                = $(FC)
+CC                = icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c -DDM_PARALLEL  -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE
+FCOPTIM           = -O3
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -ftz -align all -FR -convert big_endian \
+                    -fno-alias -tpp2 \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DRSL_LITE -DDM_PARALLEL \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                    -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                    -L/usr/lib -lmpi -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/inc/dm_comm_cpp_flags` \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals :  CONFIGURE_WRFIO_NF $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC='$(CC) -I. $(CFLAGS) -DMPI2_SUPPORT -I$(MPI_HOME)/include '\
+	 FC='$(FC) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    SGI Altix/Generic Intel Itanium2 ia64 Linux, ifort+icc 9.x,10.x SM-Parallel (OpenMP, no 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#
+#        Hybrid OpenMP+MPI configurations might be helpfull to improve  scaling for multicore architecures
+#        and  reasonably large workloads (i.e. for CONUT12km hybrid configurations are not likely to give any
+#        performance improvements).
+#
+#        To improve performance on Itanium2 architecture you might want to use '-IPF-fp-relaxed' flag, which enables
+#        use of faster but slightly less accurate code sequences for math functions, such as divide and sqrt,
+#        and enables the performance of more aggressive floating-point transformations, which may affect accuracy.
+#
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin/mpiicc -nocompchk
+
+DMPARALLEL        =
+OMP               = -openmp -fpp -auto
+OMPCPP            = -D_OPENMP
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          =
+FC                = ifort
+LD                = $(FC)
+CC                = icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c    -openmp
+FCOPTIM           = -O3
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -ftz -align all -FR -convert big_endian \
+                    -fno-alias -tpp2 \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO   \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                     \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                     -L$(WRF_SRC_ROOT_DIR)/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  \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF  wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    SGI Altix/Generic Intel Itanium2 ia64 Linux, ifort+icc 9.x,10.x Sequential (no 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#
+#        To improve performance on Itanium2 architecture you might want to use '-IPF-fp-relaxed' flag, which enables
+#        use of faster but slightly less accurate code sequences for math functions, such as divide and sqrt,
+#        and enables the performance of more aggressive floating-point transformations, which may affect accuracy.
+#
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin/mpiicc -nocompchk
+
+DMPARALLEL        =
+OMP               =
+OMPCPP            =
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          =
+FC                = ifort
+LD                = $(FC)
+CC                = icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c
+FCOPTIM           = -O3
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -ftz -align all -FR -convert big_endian \
+                    -fno-alias -tpp2 \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO   \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                     \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                     -L$(WRF_SRC_ROOT_DIR)/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  \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF  wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    SGI Altix, Dual-Core Intel Itanium2 Processor 9000 Sequence ia64 Linux, ifort+icc 9.x,10.x DM-Parallel (SGI MPI, OpenMP, 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#
+#        Hybrid OpenMP+MPI configurations might be helpfull to improve  scaling for multicore architecures
+#        and  reasonably large workloads (i.e. for CONUT12km hybrid configurations are not likely to give any
+#        performance improvements).
+#
+#        To improve performance on Itanium2 architecture you might want to use '-IPF-fp-relaxed' flag, which enables
+#        use of faster but slightly less accurate code sequences for math functions, such as divide and sqrt,
+#        and enables the performance of more aggressive floating-point transformations, which may affect accuracy.
+#
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin/mpiicc -nocompchk
+
+DMPARALLEL        = 1
+OMP               = -openmp -fpp -auto
+OMPCPP            = -D_OPENMP
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          = /usr
+FC                = ifort
+LD                = $(FC)
+CC                = icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c -DDM_PARALLEL  -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -openmp
+FCOPTIM           = -O3
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -ftz -align all -FR -convert big_endian \
+                    -fno-alias -mtune=itanium2-p9000 \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DRSL_LITE -DDM_PARALLEL \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                    -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                    -L/usr/lib -lmpi -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/inc/dm_comm_cpp_flags` \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals :  CONFIGURE_WRFIO_NF $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC='$(CC) -I. $(CFLAGS) -DMPI2_SUPPORT -I$(MPI_HOME)/include '\
+	 FC='$(FC) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+# OpenMP workaround for solve_em.F
+# This should be fixed in newer versions of Intel Fortran Compiler (somewhere after 9.1.041).
+# You can check if you really need this workaround by building without the following rule
+# and making sure that output of "nm solve_em.o | grep kmp" contains kmpc_fork_call.
+solve_em.o : solve_em.F
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC)  -c $(FCBASEOPTS) $(FCDEBUG) $(OMP) -O0 -override-limits $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    SGI Altix, Dual-Core Intel Itanium2 Processor 9000 Sequence ia64 Linux, ifort+icc 9.x,10.x DM-Parallel (SGI MPI, 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#
+#        To improve performance on Itanium2 architecture you might want to use '-IPF-fp-relaxed' flag, which enables
+#        use of faster but slightly less accurate code sequences for math functions, such as divide and sqrt,
+#        and enables the performance of more aggressive floating-point transformations, which may affect accuracy.
+#
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin/mpiicc -nocompchk
+
+DMPARALLEL        = 1
+OMP               =
+OMPCPP            =
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          = /usr
+FC                = ifort
+LD                = $(FC)
+CC                = icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c -DDM_PARALLEL  -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE
+FCOPTIM           = -O3
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -ftz -align all -FR -convert big_endian \
+                    -fno-alias -mtune=itanium2-p9000 \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DRSL_LITE -DDM_PARALLEL \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                    -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                    -L/usr/lib -lmpi -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/inc/dm_comm_cpp_flags` \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals :  CONFIGURE_WRFIO_NF $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC='$(CC) -I. $(CFLAGS) -DMPI2_SUPPORT -I$(MPI_HOME)/include '\
+	 FC='$(FC) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    SGI Altix/Generic Dual-Core Intel Itanium2 Processor 9000 Sequence ia64 Linux, ifort+icc 9.x,10.x SM-Parallel (OpenMP, no 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#
+#        Hybrid OpenMP+MPI configurations might be helpfull to improve  scaling for multicore architecures
+#        and  reasonably large workloads (i.e. for CONUT12km hybrid configurations are not likely to give any
+#        performance improvements).
+#
+#        To improve performance on Itanium2 architecture you might want to use '-IPF-fp-relaxed' flag, which enables
+#        use of faster but slightly less accurate code sequences for math functions, such as divide and sqrt,
+#        and enables the performance of more aggressive floating-point transformations, which may affect accuracy.
+#
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin/mpiicc -nocompchk
+
+DMPARALLEL        =
+OMP               = -openmp -fpp -auto
+OMPCPP            = -D_OPENMP
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          =
+FC                = ifort
+LD                = $(FC)
+CC                = icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c    -openmp
+FCOPTIM           = -O3
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -ftz -align all -FR -convert big_endian \
+                    -fno-alias -mtune=itanium2-p9000 \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO   \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                     \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                     -L$(WRF_SRC_ROOT_DIR)/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  \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF  wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+# OpenMP workaround for solve_em.F
+# This should be fixed in newer versions of Intel Fortran Compiler (somewhere after 9.1.041).
+# You can check if you really need this workaround by building without the following rule
+# and making sure that output of "nm solve_em.o | grep kmp" contains kmpc_fork_call.
+solve_em.o : solve_em.F
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC)  -c $(FCBASEOPTS) $(FCDEBUG) $(OMP) -O0 -override-limits $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    SGI Altix/Generic Dual-Core Intel Itanium2 Processor 9000 Sequence ia64 Linux, ifort+icc 9.x,10.x Sequential (no 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#
+#        To improve performance on Itanium2 architecture you might want to use '-IPF-fp-relaxed' flag, which enables
+#        use of faster but slightly less accurate code sequences for math functions, such as divide and sqrt,
+#        and enables the performance of more aggressive floating-point transformations, which may affect accuracy.
+#
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin/mpiicc -nocompchk
+
+DMPARALLEL        =
+OMP               =
+OMPCPP            =
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          =
+FC                = ifort
+LD                = $(FC)
+CC                = icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c
+FCOPTIM           = -O3
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -ftz -align all -FR -convert big_endian \
+                    -fno-alias -mtune=itanium2-p9000 \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO   \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                     \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                     -L$(WRF_SRC_ROOT_DIR)/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  \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF  wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(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 $(WRF_SRC_ROOT_DIR)/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         = CONFIGURE_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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/inc \
+			-p./ -p$(WRF_SRC_ROOT_DIR)/external/io_netcdf -p$(WRF_SRC_ROOT_DIR)/external/io_int -p$(WRF_SRC_ROOT_DIR)/frame \
+                        -p$(WRF_SRC_ROOT_DIR)/frame -p$(WRF_SRC_ROOT_DIR)/share -p$(WRF_SRC_ROOT_DIR)/phys -p$(WRF_SRC_ROOT_DIR)/chem \
+                        -p$(WRF_SRC_ROOT_DIR)/dyn_em -p $(WRF_SRC_ROOT_DIR)/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 \
+			$(DA_ARCHFLAGS) \
+			-DLIMIT_ARGS -Dcrayx1
+
+PERL            =       perl
+REGISTRY        =       Registry
+
+LIB             =       -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			-L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int  \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+			-L$(WRF_SRC_ROOT_DIR)/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) # 
+CPPFLAGS	=	-I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP) -Dcrayx1" FC="$(FC) $(PROMOTION) -f free -N 255 " )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC) -UCRAY" CPP="$(CPP) -Dcrayx1" RANLIB="$(RANLIB)" \
+          FC="$(FC) $(PROMOTION) -f free -N 255" archive )
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) -f free -N 255" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" 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
+module_comm_dm.o : module_comm_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 module_comm_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$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+ARCHFLAGS       =       $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DLIMIT_ARGS -DFLOATSAFE \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) " )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive)
+
+wrfio_grib1 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" RANLIB="$(RANLIB)" \
+          FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive )
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \
+          FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive )
+
+esmf_time : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o mediation_integrate.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+ARCHFLAGS       =       $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DLIMIT_ARGS -DFLOATSAFE \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) " )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive)
+
+wrfio_grib1 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" RANLIB="$(RANLIB)" \
+          FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive )
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \
+          FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive )
+
+esmf_time : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o mediation_integrate.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+ARCHFLAGS       =       $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DLIMIT_ARGS -DFLOATSAFE \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) " )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive)
+
+wrfio_grib1 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" RANLIB="$(RANLIB)" \
+          FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive )
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \
+          FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive )
+
+esmf_time : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o mediation_integrate.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCFLAGS) $(MODULE_DIRS) $*.f90
+
+###########################################################
+#ARCH Darwin		(single-threaded, xlf, 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       = CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG \
+			-DLIMIT_ARGS  -DLANDREAD_STUB -DMAC_KLUDGE
+#			-DLIMIT_ARGS  -DNATIVE_MASSV -DMACOS
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+#LIB             =       CONFIGURE_NETCDF_LIB_PATH -lmass -lmassv 
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+solve_interface.o : solve_interface.F
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_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 module_comm_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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90
+
+###########################################################
+#ARCH Darwin		(OpenMP, xlf, 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       = CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG \
+			-DLIMIT_ARGS  -DLANDREAD_STUB -DMACOS -DMAC_KLUDGE
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -lxlsmp \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+
+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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c -g $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt -qnohot $*.f90
+
+###########################################################
+#ARCH Darwin		(OpenMP, pgf90, 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             =       -mp
+OMPCPP          =       -D_OPENMP
+FC              =       pgf90
+LD              =       pgf90
+CC              =       pgcc
+SCC		=	$(CC)
+SFC             =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-r$(RWORDSIZE) -i4
+CFLAGS          =       -DMACOS
+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 \
+			$(DA_ARCHFLAGS) \
+                         CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DMACOS \
+			-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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time 
+LDFLAGS         =	$(FCFLAGS) $(OMP) CONFIGURE_LDFLAGS
+ENVCOMPDEFS	=	CONFIGURE_COMPILEFLAGS
+CPP             =       /usr/bin/cpp  -C -P -xassembler-with-cpp
+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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $*.f90
+
+###########################################################
+#ARCH Darwin		(ifort, 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
+#
+OMP             =       
+OMPCPP          =       
+FC              =       ifort
+LD              =       ifort
+CC              =       gcc
+SCC		=	$(CC)
+SFC             =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+RSIZEBITS       =       `expr $(RWORDSIZE) \* 8`
+PROMOTION       =       -real_size $(RSIZEBITS)
+CFLAGS          =       -DMACOS
+FCOPTIM		=	-O3 # -fast
+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 \
+			$(DA_ARCHFLAGS) \
+                         CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DMACOS \
+			-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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time 
+LDFLAGS         =	$(FCFLAGS) $(OMP) CONFIGURE_LDFLAGS -i-static -static-libcxa
+ENVCOMPDEFS	=	CONFIGURE_COMPILEFLAGS
+CPP             =       /usr/bin/cpp  -C -P -xassembler-with-cpp
+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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $*.f90
+
+
+###########################################################
+#ARCH Darwin		(ifort, single-threaded, nesting, RSL_LITE w/o MPI)
+#     
+#     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             =       
+OMPCPP          =       
+FC              =       ifort
+LD              =       ifort
+CC              =       gcc
+SCC		=	$(CC)
+SFC             =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+RSIZEBITS       =       `expr $(RWORDSIZE) \* 8`
+PROMOTION       =       -real_size $(RSIZEBITS)
+CFLAGS          =       -DMACOS -DSTUBMPI
+FCOPTIM		=	-O3 # -fast
+FCDEBUG		=	#-g
+FCBASEOPTS      =       -FR -cm -w -I. $(FCDEBUG) -convert big_endian -mp -DSTUBMPI
+FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS       =       $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                         CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DMACOS \
+			-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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time 
+LDFLAGS         =	$(FCFLAGS) $(OMP) CONFIGURE_LDFLAGS -i-static -static-libcxa
+ENVCOMPDEFS	=	CONFIGURE_COMPILEFLAGS
+CPP             =       /usr/bin/cpp  -C -P -xassembler-with-cpp
+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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC="$(CC) $(CFLAGS)" 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $*.f90
+
+###########################################################
+#ARCH Darwin		(OpenMP, ifort, 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             =       -openmp -fpp -auto
+OMPCPP          =       -D_OPENMP
+FC              =       ifort
+LD              =       ifort
+CC              =       gcc
+SCC		=	$(CC)
+SFC             =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+RSIZEBITS       =       `expr $(RWORDSIZE) \* 8`
+PROMOTION       =       -real_size $(RSIZEBITS)
+CFLAGS          =       -DMACOS
+FCOPTIM		=	-O3 # -fast
+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 \
+			$(DA_ARCHFLAGS) \
+                         CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DMACOS \
+			-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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time 
+LDFLAGS         =	$(FCFLAGS) $(OMP) CONFIGURE_LDFLAGS -i-static -static-libcxa
+ENVCOMPDEFS	=	CONFIGURE_COMPILEFLAGS
+CPP             =       /usr/bin/cpp  -C -P -xassembler-with-cpp
+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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $*.f90
+
+###########################################################
+#ARCH Darwin		(RSL_LITE, pgf90, 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
+#
+OMP             =       -mp
+OMPCPP          =       -D_OPENMP
+DMPARALLEL      =       1
+MAX_PROC        =       1024
+FC              =       mpif90 -f90=pgf90
+LD              =       mpif90 -f90=pgf90
+CC              =       mpicc -cc=pgcc
+SCC		=	pgcc
+SFC             =       pgf90
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-r$(RWORDSIZE) -i4
+CFLAGS          =       -DDM_PARALLEL \
+                        -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -DMACOS
+#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) $(OMP)
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DDM_PARALLEL -DMACOS \
+                        -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \
+			$(DA_ARCHFLAGS) \
+			-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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite $(OMP) \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time 
+LDFLAGS         =       -byteswapio $(FCFLAGS) CONFIGURE_LDFLAGS
+ENVCOMPDEFS	=	CONFIGURE_COMPILEFLAGS
+CPP             =       /usr/bin/cpp  -C -P -xassembler-with-cpp
+POUND_DEF	=	$(OMPCPP) -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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC="$(CC) $(CFLAGS)" 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $*.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 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       = CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG \
+			-DLIMIT_ARGS  -DLANDREAD_STUB -DMAC_KLUDGE
+#			-DLIMIT_ARGS  -DNATIVE_MASSV -DMACOS
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+#LIB             =       CONFIGURE_NETCDF_LIB_PATH -lmass -lmassv 
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+solve_interface.o : solve_interface.F
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_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 module_comm_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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90
+
+###########################################################
+#ARCH	Darwin g95	(Single-threaded, no nesting)
+#
+FC              =       g95
+LD              =       g95
+CC              =       gcc -DMACOS -DF2CSTYLE
+SCC		=	$(CC)
+RWORDSIZE       =       CONFIGURE_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 -fendian=big -ffree-form -ffree-line-length-huge $(FCDEBUG) # -Mlfs
+FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS)
+ARCHFLAGS       =       -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                         -DNETCDF -DGRIB1 -DLIMIT_ARGS -DG95 -DMACOS -DF2CSTYLE
+# 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=$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time 
+LDFLAGS         =       $(FCFLAGS) 
+ENVCOMPDEFS	=	
+WRF_CHEM	=	0 
+CPP             =       /usr/bin/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 $(WRF_SRC_ROOT_DIR)/arch/no_file_line.sed
+
+externals : wrf_ioapi_includes wrfio_nf wrfio_grib_share wrfio_grib1  wrfio_int module_dm.F esmf_time fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS) " RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" FIXED="-ffixed-form" archive )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+###########################################################
+#ARCH     Darwin 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 -DMACOS -DF2CSTYLE
+SCC		=	gcc -DMACOS -DF2CSTYLE
+SFC             =       g95
+RWORDSIZE       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE
+FCOPTIM		=	-O2 # -fast
+FCDEBUG		=	#-g -O0
+FCBASEOPTS      =       -Wno=101,139,155,158 -ffree-line-length-huge -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 \
+			$(DA_ARCHFLAGS) \
+			-DLIMIT_ARGS -DNMM_NEST=$(WRF_NMM_NEST) -DG95 -DMACOS -DF2CSTYLE
+# 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=$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			-L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time 
+LDFLAGS         =       $(FCFLAGS) CONFIGURE_LDFLAGS
+ENVCOMPDEFS	=	CONFIGURE_COMPILEFLAGS
+CPP             =       /usr/bin/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/arch/no_file_line.sed
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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="-ffixed-form" archive)
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" 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_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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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 (Single-threaded, no nesting)
+#
+FC              =       pathf90
+LD              =       pathf90
+CC              =       pathcc
+SCC             =       $(CC)
+NATIVE_RWORDSIZE=       4
+RWORDSIZE       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+                         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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                        $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+                                                                                
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+                                                                                
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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	=	CONFIGURE_RWORDSIZE
+CFLAGS          =       -DDM_PARALLEL \
+                        -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I$(WRF_SRC_ROOT_DIR)/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 \
+			$(DA_ARCHFLAGS) \
+                        -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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+EXTRAMODULES    =
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+                                                                                
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+	cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+                                                                                
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+                                                                                
+#io_flags:
+#	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make flags_only ; \
+#	/bin/cp wrf_io_flags.h wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/inc ; \
+#	/bin/cp wrf_io_flags.h wrf_status_codes.h ../io_phdf5 )
+                                                                                
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC)" TRADFLAG="-traditional" \
+	FFLAGS='$(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc -ICONFIGURE_NETCDF_PATH/include -w -fno-second-underscore' RANLIB=$(RANLIB) )
+                                                                                
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+	make CC="$(CC)" CPP="$(CPP)" FC="$(SFC) -I. $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" RANLIB=$(RANLIB) archive )
+                                                                                
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+	make CC="$(CC)" CPP="$(CPP)" FC="$(SFC) $(FCDEBUG) $(FCBASEOPTS) -w" TRADFLAG="-traditional" RANLIB=$(RANLIB) all )
+                                                                                
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	make FC="$(FC) $(FCDEBUG) $(FCBASEOPTS) " CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+                                                                                
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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)
+#        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       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-r$(RWORDSIZE) -i4
+CFLAGS          =       -DDM_PARALLEL \
+                        -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I$(WRF_SRC_ROOT_DIR)/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 \
+			$(DA_ARCHFLAGS) \
+			-DLIMIT_ARGS -DLANDREAD_STUB  -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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+###########################################################
+#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       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	
+CFLAGS          =       -DNCARIBM_NOC99 -DDM_PARALLEL \
+                        -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I$(WRF_SRC_ROOT_DIR)/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 \
+			$(DA_ARCHFLAGS) \
+			-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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/arch/no_file_line.sed
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib1 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" AR="$(AR_BASE)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+                         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=$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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="-ffixed-form" archive )
+
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 -ffree-line-length-huge $(FCDEBUG) # -Mlfs
+FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS)
+ARCHFLAGS       =       $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                         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=$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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="-ffixed-form" archive )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE
+FCOPTIM		=	-O2 # -fast
+FCDEBUG		=	#-g -O0
+FCBASEOPTS      =       -Wno=101,139,155,158 -fno-second-underscore -fendian=big -ffree-form -ffree-line-length-huge $(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 \
+			$(DA_ARCHFLAGS) \
+			-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=$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/arch/no_file_line.sed
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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="-ffixed-form" archive)
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" 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_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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+
+###########################################################
+#ARCH    PC Interix x86_64 (IA64 and Opteron), PGI 5.2 or higher DM-Parallel   (RSL_LITE, MPICH, 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.exe
+LD              =       $(FC)
+CC              =       pgcc.exe
+CC              =       cc
+SCC		=	$(CC)
+SFC             =       $(FC)
+
+MPdir           =       /dev/fs/C/Program Files/Microsoft Compute Cluster Pack
+MPinc           =       -I'$(MPdir)'/Include
+MSMPdir         =       'C:\Program Files\Microsoft Compute Cluster Pack'
+MSMPinc         =       /I'C:\Program Files\Microsoft Compute Cluster Pack\Include'
+MSMPlib         =       'C:\Program Files\Microsoft Compute Cluster Pack\Lib\AMD64\msmpi.lib'
+
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-r$(RWORDSIZE) -i4
+
+CFLAGS          =       -DLANDREAD_STUB -DMEMCPY_FOR_BCOPY -DMS_SUA -DDM_PARALLEL \
+                        -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE $(MPinc) #-X /MD
+FCOPTIM         =       -fastsse #-Mipa=fast
+FCDEBUG		=	#-g
+#FCBASEOPTS      =       -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG)
+FCBASEOPTS      =       -w -byteswapio -Mfree $(FCDEBUG)
+FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS) $(MPinc)
+
+ARCHFLAGS       =       $(COREDEFS) \
+                        -DDM_PARALLEL \
+                        -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        -DNETCDF -DINTIO \
+                        -DNO_NAMELIST_PRINT  \
+                        -DLIMIT_ARGS -DLANDREAD_STUB -DNMM_NEST=$(WRF_NMM_NEST) -DMEMCPY_FOR_BCOPY
+
+# 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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       perl
+REGISTRY        =       Registry
+
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5/libfftpack.a \
+			$(WRF_SRC_ROOT_DIR)/external/io_int/libwrfio_int.a \
+                        $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90/libesmf_time.a \
+                        $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a $(MSMPlib) \
+                        "c:\Program Files\Microsoft Platform SDK for Windows Server 2003 R2\Lib\AMD64\bufferoverflowu.lib"
+
+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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P $(ENVCOMPDEFS) $(POUND_DEF)
+AR              =       ar r
+M4              =       NA
+RANLIB          =       ranlib
+NETCDFPATH	=	CONFIGURE_NETCDF_PATH
+CC_TOOLS        =       cc
+LIBWRFLIB       =       libwrflib.a
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make LIBS="libwrfio_nf.a 'CONFIGURE_NETCDF_PATH' 'c:\Program Files\Microsoft Platform SDK\Lib\AMD64\bufferoverflowu.lib'" \
+              NETCDFPATH=CONFIGURE_NETCDF_PATH \
+              RANLIB="$(RANLIB)" CPP="$(CPP) -DMS_SUA" \
+              CPP1="$(CPP) -DMS_SUA"  \
+              FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+
+wrfio_grib1 :
+
+wrfio_grib2 :
+
+wrfio_int :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; \
+          /bin/sed -e '/MPI_ADDRESS_KIND=4/d' -e '/DEC\$$/d' '$(MPdir)'/Include/mpif.h > mpif.h ; \
+          make CPP="$(CPP) $(CPPFLAGS)" CC="$(CC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -byteswapio" 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -o $*.o -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+module_io.o : module_io.F
+module_dm.o : module_dm.F
+
+module_io.o module_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	/bin/sed -e '/MPI_ADDRESS_KIND=4/d' -e '/DEC\$$/d' '$(MPdir)'/Include/mpif.h > mpif.h
+	$(FC) -o $*.o -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    Generic Intel Itanium2 ia64 Linux, ifort+icc 9.x,10.x DM-Parallel (MPICH, OpenMP, RSL_LITE)
+#
+# 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#        Another option is to add '-ftz' flag, which flushes denormal results to zero when the application is in
+#        the gradual underflow mode. It may improve performance if the denormal values are not critical to the
+#        behavior of your workload.
+#        To improve performance on Itanium2 architecture you might want to use '-IPF-fp-relaxed' flag, which enables
+#        use of faster but slightly less accurate code sequences for math functions, such as divide and sqrt,
+#        and enables the performance of more aggressive floating-point transformations, which may affect accuracy.
+
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin/mpiicc -nocompchk
+
+DMPARALLEL        = 1
+OMP               = -openmp -fpp -auto
+OMPCPP            = -D_OPENMP
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          = $(MPICH)
+FC                = $(MPI_HOME)/bin/mpif90 -f90=ifort
+LD                = $(FC)
+CC                = $(MPI_HOME)/bin/mpicc -cc=icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c -DDM_PARALLEL  -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -openmp
+FCOPTIM           = -O3 -unroll0
+FCDEBUG           = # -O0 -g -traceback
+FCBASEOPTS        = -align all -FR -convert big_endian \
+                    -fno-alias -fno-fnalias -tpp2 \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DRSL_LITE -DDM_PARALLEL \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                    -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                     -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/inc/dm_comm_cpp_flags` \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+ENVCOMPDEFS     =       CONFIGURE_COMPILEFLAGS
+
+externals :  CONFIGURE_WRFIO_NF $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC='$(CC) -I. $(CFLAGS) -DMPI2_SUPPORT -I$(MPI_HOME)/include '\
+	 FC='$(FC) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -O0 -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    Generic Intel Itanium2 ia64 Linux, ifort+icc 9.x,10.x DM-Parallel (MPICH, RSL_LITE)
+#
+# 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#        Another option is to add '-ftz' flag, which flushes denormal results to zero when the application is in
+#        the gradual underflow mode. It may improve performance if the denormal values are not critical to the
+#        behavior of your workload.
+#        To improve performance on Itanium2 architecture you might want to use '-IPF-fp-relaxed' flag, which enables
+#        use of faster but slightly less accurate code sequences for math functions, such as divide and sqrt,
+#        and enables the performance of more aggressive floating-point transformations, which may affect accuracy.
+
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin/mpiicc -nocompchk
+
+DMPARALLEL        = 1
+OMP               =
+OMPCPP            =
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          = $(MPICH)
+FC                = $(MPI_HOME)/bin/mpif90 -f90=ifort
+LD                = $(FC)
+CC                = $(MPI_HOME)/bin/mpicc -cc=icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c -DDM_PARALLEL  -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE
+FCOPTIM           = -O3 -unroll0
+FCDEBUG           = # -O0 -g -traceback
+FCBASEOPTS        = -align all -FR -convert big_endian \
+                    -fno-alias -fno-fnalias -tpp2 \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DRSL_LITE -DDM_PARALLEL \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                    -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                     -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/inc/dm_comm_cpp_flags` \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals :  CONFIGURE_WRFIO_NF $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC='$(CC) -I. $(CFLAGS) -DMPI2_SUPPORT -I$(MPI_HOME)/include '\
+	 FC='$(FC) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip -O0 $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    Dual-Core Intel Itanium2 Processor 9000 Sequence ia64 Linux, ifort+icc 9.x,10.x DM-Parallel (MPICH, OpenMP, RSL_LITE)
+#
+# 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#        Another option is to add '-ftz' flag, which flushes denormal results to zero when the application is in
+#        the gradual underflow mode. It may improve performance if the denormal values are not critical to the
+#        behavior of your workload.
+#        To improve performance on Itanium2 architecture you might want to use '-IPF-fp-relaxed' flag, which enables
+#        use of faster but slightly less accurate code sequences for math functions, such as divide and sqrt,
+#        and enables the performance of more aggressive floating-point transformations, which may affect accuracy.
+
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin/mpiicc -nocompchk
+
+DMPARALLEL        = 1
+OMP               = -openmp -fpp -auto
+OMPCPP            = -D_OPENMP
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          = $(MPICH)
+FC                = $(MPI_HOME)/bin/mpif90 -f90=ifort
+LD                = $(FC)
+CC                = $(MPI_HOME)/bin/mpicc -cc=icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c -DDM_PARALLEL  -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -openmp
+FCOPTIM           = -O3 -unroll0
+FCDEBUG           = # -O0 -g -traceback
+FCBASEOPTS        = -align all -FR -convert big_endian \
+                    -fno-alias -fno-fnalias -mtune=itanium2-p9000 \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DRSL_LITE -DDM_PARALLEL \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                    -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                     -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/inc/dm_comm_cpp_flags` \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals :  CONFIGURE_WRFIO_NF $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC='$(CC) -I. $(CFLAGS) -DMPI2_SUPPORT -I$(MPI_HOME)/include '\
+	 FC='$(FC) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+# OpenMP workaround for solve_em.F
+# This should be fixed in newer versions of Intel Fortran Compiler (somewhere after 9.1.041).
+# You can check if you really need this workaround by building without the following rule
+# and making sure that output of "nm solve_em.o | grep kmp" contains kmpc_fork_call.
+solve_em.o : solve_em.F
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC)  -c $(FCBASEOPTS) $(FCDEBUG) $(OMP) -O0 -override-limits $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    Dual-Core Intel Itanium2 Processor 9000 Sequence ia64 Linux, ifort+icc 9.x,10.x DM-Parallel (MPICH, RSL_LITE)
+#
+# 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#        Another option is to add '-ftz' flag, which flushes denormal results to zero when the application is in
+#        the gradual underflow mode. It may improve performance if the denormal values are not critical to the
+#        behavior of your workload.
+#        To improve performance on Itanium2 architecture you might want to use '-IPF-fp-relaxed' flag, which enables
+#        use of faster but slightly less accurate code sequences for math functions, such as divide and sqrt,
+#        and enables the performance of more aggressive floating-point transformations, which may affect accuracy.
+
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin/mpiicc -nocompchk
+
+DMPARALLEL        = 1
+OMP               =
+OMPCPP            =
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          = $(MPICH)
+FC                = $(MPI_HOME)/bin/mpif90 -f90=ifort
+LD                = $(FC)
+CC                = $(MPI_HOME)/bin/mpicc -cc=icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c -DDM_PARALLEL  -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE
+FCOPTIM           = -O3 -unroll0
+FCDEBUG           = # -O0 -g -traceback
+FCBASEOPTS        = -align all -FR -convert big_endian \
+                    -fno-alias -fno-fnalias -mtune=itanium2-p9000 \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DRSL_LITE -DDM_PARALLEL \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                    -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                     -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/inc/dm_comm_cpp_flags` \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals :  CONFIGURE_WRFIO_NF $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC='$(CC) -I. $(CFLAGS) -DMPI2_SUPPORT -I$(MPI_HOME)/include '\
+	 FC='$(FC) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    Generic Intel 64 x86_64 Linux, ifort+icc 9.x,10.x DM-Parallel (MPICH, OpenMP, RSL_LITE)
+#
+# 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#        Another option is to add '-ftz' flag, which flushes denormal results to zero when the application is in
+#        the gradual underflow mode. It may improve performance if the denormal values are not critical to the
+#        behavior of your workload.
+
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin64/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin64/mpiicc -nocompchk
+
+DMPARALLEL        = 1
+OMP               = -openmp -fpp -auto
+OMPCPP            = -D_OPENMP
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          = $(MPICH)
+FC                = $(MPI_HOME)/bin/mpif90 -f90=ifort
+LD                = $(FC)
+CC                = $(MPI_HOME)/bin/mpicc -cc=icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c -DDM_PARALLEL  -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -openmp
+FCOPTIM           = -O3
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -align all -FR -convert big_endian \
+                    -fno-alias -fno-fnalias  \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DRSL_LITE -DDM_PARALLEL \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                    -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                     -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/inc/dm_comm_cpp_flags` \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals :  CONFIGURE_WRFIO_NF $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC='$(CC) -I. $(CFLAGS) -DMPI2_SUPPORT -I$(MPI_HOME)/include '\
+	 FC='$(FC) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+# Force even lower optimization level for these files to decrease
+# compilation time and lower memory demands
+solve_em.o : solve_em.F
+module_dm.o : module_dm.F
+
+solve_em.o \
+module_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(FCBASEOPTS) $(FCDEBUG) $(OMP) -O0 $(MODULE_DIRS) -mP2OPT_vec_xform_level=103 $*.f90
+
+############################################################
+#ARCH  Z  Generic Intel 64 x86_64 Linux, ifort+icc 9.x,10.x DM-Parallel (MPICH, RSL_LITE)
+#
+# 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#        Another option is to add '-ftz' flag, which flushes denormal results to zero when the application is in
+#        the gradual underflow mode. It may improve performance if the denormal values are not critical to the
+#        behavior of your workload.
+
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin64/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin64/mpiicc -nocompchk
+
+DMPARALLEL        = 1
+OMP               =
+OMPCPP            =
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          = $(MPICH)
+FC                = $(MPI_HOME)/bin/mpif90 -f90=ifort
+LD                = $(FC)
+CC                = $(MPI_HOME)/bin/mpicc -cc=icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c -DDM_PARALLEL  -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE
+FCOPTIM           = -O3
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -align all -FR -convert big_endian \
+                    -fno-alias -fno-fnalias  \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DRSL_LITE -DDM_PARALLEL \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                    -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                     -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/inc/dm_comm_cpp_flags` \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+ENVCOMPDEFS	=	CONFIGURE_COMPILEFLAGS
+
+externals :  CONFIGURE_WRFIO_NF $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC='$(CC) -I. $(CFLAGS) -DMPI2_SUPPORT -I$(MPI_HOME)/include '\
+	 FC='$(FC) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+# Force even lower optimization level for these files to decrease
+# compilation time and lower memory demands
+module_dm.o : module_dm.F
+solve_em.o : solve_em.F
+
+solve_em.o \
+module_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(FCBASEOPTS) $(FCDEBUG) -O0 $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    Generic Intel 64 x86_64 Linux, ifort+icc 9.x,10.x SM-Parallel (OpenMP, no 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#        Another option is to add '-ftz' flag, which flushes denormal results to zero when the application is in
+#        the gradual underflow mode. It may improve performance if the denormal values are not critical to the
+#        behavior of your workload.
+
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin64/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin64/mpiicc -nocompchk
+
+DMPARALLEL        =
+OMP               = -openmp -fpp -auto
+OMPCPP            = -D_OPENMP
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          =
+FC                = ifort
+LD                = $(FC)
+CC                = icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c    -openmp
+FCOPTIM           = -O3
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -align all -FR -convert big_endian \
+                    -fno-alias -fno-fnalias  \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO   \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                     \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                     -L$(WRF_SRC_ROOT_DIR)/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  \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF  wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+# Force even lower optimization level for these files to decrease
+# compilation time and lower memory demands
+solve_em.o : solve_em.F
+module_dm.o : module_dm.F
+
+solve_em.o \
+module_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(FCBASEOPTS) $(FCDEBUG) $(OMP) -O0 $(MODULE_DIRS) -mP2OPT_vec_xform_level=103 $*.f90
+
+############################################################
+#ARCH    Generic Intel 64 x86_64 Linux, ifort+icc 9.x,10.x Sequential (no 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#        Another option is to add '-ftz' flag, which flushes denormal results to zero when the application is in
+#        the gradual underflow mode. It may improve performance if the denormal values are not critical to the
+#        behavior of your workload.
+
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin64/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin64/mpiicc -nocompchk
+
+DMPARALLEL        =
+OMP               =
+OMPCPP            =
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          =
+FC                = ifort
+LD                = $(FC)
+CC                = icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c
+FCOPTIM           = -O3
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -align all -FR -convert big_endian \
+                    -fno-alias -fno-fnalias  \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO   \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                     \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                     -L$(WRF_SRC_ROOT_DIR)/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  \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF  wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+# Force even lower optimization level for these files to decrease
+# compilation time and lower memory demands
+module_dm.o : module_dm.F
+solve_em.o : solve_em.F
+
+solve_em.o \
+module_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(FCBASEOPTS) $(FCDEBUG) -O0 $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    Intel Core 2 Duo/Quad (Intel 64) x86_64 Linux, ifort+icc 9.x,10.x DM-Parallel (MPICH, OpenMP, RSL_LITE)
+#
+# 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#        Another option is to add '-ftz' flag, which flushes denormal results to zero when the application is in
+#        the gradual underflow mode. It may improve performance if the denormal values are not critical to the
+#        behavior of your workload.
+
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin64/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin64/mpiicc -nocompchk
+
+DMPARALLEL        = 1
+OMP               = -openmp -fpp -auto
+OMPCPP            = -D_OPENMP
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          = $(MPICH)
+FC                = $(MPI_HOME)/bin/mpif90 -f90=ifort
+LD                = $(FC)
+CC                = $(MPI_HOME)/bin/mpicc -cc=icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c -DDM_PARALLEL  -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -openmp
+FCOPTIM           = -O3 -xT
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -align all -FR -convert big_endian \
+                    -fno-alias -fno-fnalias  \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DRSL_LITE -DDM_PARALLEL \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                    -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                     -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/inc/dm_comm_cpp_flags` \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals :  CONFIGURE_WRFIO_NF $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC='$(CC) -I. $(CFLAGS) -DMPI2_SUPPORT -I$(MPI_HOME)/include '\
+	 FC='$(FC) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+# Force even lower optimization level for these files to decrease
+# compilation time and lower memory demands
+solve_em.o : solve_em.F
+module_dm.o : module_dm.F
+
+solve_em.o \
+module_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(FCBASEOPTS) $(FCDEBUG) $(OMP) -O0 $(MODULE_DIRS) -mP2OPT_vec_xform_level=103 $*.f90
+
+############################################################
+#ARCH    Intel Core 2 Duo/Quad (Intel 64) x86_64 Linux, ifort+icc 9.x,10.x DM-Parallel (MPICH, RSL_LITE)
+#
+# 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#        Another option is to add '-ftz' flag, which flushes denormal results to zero when the application is in
+#        the gradual underflow mode. It may improve performance if the denormal values are not critical to the
+#        behavior of your workload.
+
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin64/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin64/mpiicc -nocompchk
+
+DMPARALLEL        = 1
+OMP               =
+OMPCPP            =
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          = $(MPICH)
+FC                = $(MPI_HOME)/bin/mpif90 -f90=ifort
+LD                = $(FC)
+CC                = $(MPI_HOME)/bin/mpicc -cc=icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c -DDM_PARALLEL  -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE
+FCOPTIM           = -O3 -xT
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -align all -FR -convert big_endian \
+                    -fno-alias -fno-fnalias  \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DRSL_LITE -DDM_PARALLEL \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                    -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                     -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/inc/dm_comm_cpp_flags` \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals :  CONFIGURE_WRFIO_NF $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC='$(CC) -I. $(CFLAGS) -DMPI2_SUPPORT -I$(MPI_HOME)/include '\
+	 FC='$(FC) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/.. ' MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+# Force even lower optimization level for these files to decrease
+# compilation time and lower memory demands
+module_dm.o : module_dm.F
+solve_em.o : solve_em.F
+
+solve_em.o \
+module_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(FCBASEOPTS) $(FCDEBUG) -O0 $(MODULE_DIRS) $*.f90
+
+############################################################
+#ARCH    Intel Core 2 Duo/Quad (Intel 64) x86_64 Linux, ifort+icc 9.x,10.x SM-Parallel (OpenMP, no 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#        Another option is to add '-ftz' flag, which flushes denormal results to zero when the application is in
+#        the gradual underflow mode. It may improve performance if the denormal values are not critical to the
+#        behavior of your workload.
+
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin64/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin64/mpiicc -nocompchk
+
+DMPARALLEL        =
+OMP               = -openmp -fpp -auto
+OMPCPP            = -D_OPENMP
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          =
+FC                = ifort
+LD                = $(FC)
+CC                = icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c    -openmp
+FCOPTIM           = -O3 -xT
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -align all -FR -convert big_endian \
+                    -fno-alias -fno-fnalias  \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO   \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                     \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                     -L$(WRF_SRC_ROOT_DIR)/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  \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF  wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+# Force even lower optimization level for these files to decrease
+# compilation time and lower memory demands
+solve_em.o : solve_em.F
+module_dm.o : module_dm.F
+
+solve_em.o \
+module_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(FCBASEOPTS) $(FCDEBUG) $(OMP) -O0 $(MODULE_DIRS) -mP2OPT_vec_xform_level=103 $*.f90
+
+############################################################
+#ARCH    Intel Core 2 Duo/Quad (Intel 64) x86_64 Linux, ifort+icc 9.x,10.x Sequential (no 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
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        If you got Out Of Memory message, there are several options:
+#        	1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#        	2. Remove any debugging flags (-g, -check, -traceback).
+#        	3. Force the problematic file to be compiled with less optimizations (see examples at the end of this file), try
+#        	   -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#        Another option is to add '-ftz' flag, which flushes denormal results to zero when the application is in
+#        the gradual underflow mode. It may improve performance if the denormal values are not critical to the
+#        behavior of your workload.
+
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        FC                = $(MPI_HOME)/bin64/mpiifort -nocompchk
+#        CC                = $(MPI_HOME)/bin64/mpiicc -nocompchk
+
+DMPARALLEL        =
+OMP               =
+OMPCPP            =
+INCLUDE           = $(WRF_SRC_ROOT_DIR)/external/io_netcdf/
+MAX_PROC          = 1024
+MPI_HOME          =
+FC                = ifort
+LD                = $(FC)
+CC                = icc
+SCC               = icc
+CC_TOOLS          = $(SCC)
+SFC               = ifort
+CFLAGS            = -w -O3 -ip  -c
+FCOPTIM           = -O3 -xT
+FCDEBUG           = # -g -traceback
+FCBASEOPTS        = -align all -FR -convert big_endian \
+                    -fno-alias -fno-fnalias  \
+                    -I$(INCLUDE) -I. -fp-model precise $(FCDEBUG)
+FCFLAGS           = $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS         = $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO   \
+                    -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=4 -DLWORDSIZE=4 -DNETCDF \
+                    $(DA_ARCHFLAGS) \
+                    -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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                    -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc
+PERL              = perl
+REGISTRY          = Registry
+LIB               = -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf $(OMP) \
+                    CONFIGURE_NETCDF_LIB_PATH \
+                     \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                    CONFIGURE_GRIB2_LIB \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                    -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                    $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                     -L$(WRF_SRC_ROOT_DIR)/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  \
+                    $(POUND_DEF) $(COREDEFS)
+AR                = ar ru
+M4                = m4
+RANLIB            = ranlib
+NETCDFPATH	      = CONFIGURE_NETCDF_PATH
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF  wrfio_int module_dm.F wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 esmf_time fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH=CONFIGURE_NETCDF_PATH CPP="$(CPP)" FC="$(FC) -I$(WRF_SRC_ROOT_DIR) $(FCFLAGS)" \
+          TRADFLAG="-traditional" RANLIB="$(RANLIB)" ; \
+	/bin/cp ../ioapi_share/wrf_io_flags.h ../ioapi_share/wrf_status_codes.h $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  SFC="$(SFC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" \
+		  ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC) CONFIGURE_GRIB2_INC" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" TRADFLAG="-traditional" RANLIB="$(RANLIB)" \
+		  FREE="-FR" FIXED="-FI" \
+          FC="$(FC) -I$(MPI_HOME)/include $(FCDEBUG) $(FCFLAGS)" archive )
+
+esmf_time :
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(FCDEBUG) $(FCFLAGS)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# Compile these without high optimization and no interprocedural
+# optimizations to speed compile. Commenting them out may result
+# in longer compilation time, but might produce substantialy faster
+# binaries.
+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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c -no-ip $(FCBASEOPTS) $(FCDEBUG) $(MODULE_DIRS) $*.f90
+
+# Force even lower optimization level for these files to decrease
+# compilation time and lower memory demands
+module_dm.o : module_dm.F
+solve_em.o : solve_em.F
+
+solve_em.o \
+module_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(FCBASEOPTS) $(FCDEBUG) -O0 $(MODULE_DIRS) $*.f90
+
+##################################################################
+#ARCH  NULL
Index: branches/LMDZ_WRFmeas/WRFV3/arch/conf_tokens
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/conf_tokens	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/conf_tokens	(revision 17)
@@ -0,0 +1,16 @@
+       CONFIGURE_FC
+       CONFIGURE_CC
+       CONFIGURE_COMMS_LIB
+       CONFIGURE_COMMS_INCLUDE
+       CONFIGURE_DMPARALLEL
+CONFIGURE_RWORDSIZE
+CONFIGURE_NETCDF_FLAG
+CONFIGURE_GRIB2_FLAG
+CONFIGURE_NETCDF_LIB_PATH
+CONFIGURE_GRIB2_LIB
+CONFIGURE_LDFLAGS
+CONFIGURE_COMPILEFLAGS
+CONFIGURE_WRFIO_NF 
+CONFIGURE_WRFIO_GRIB2 
+CONFIGURE_NETCDF_PATH
+CONFIGURE_GRIB2_INC
Index: branches/LMDZ_WRFmeas/WRFV3/arch/config_old
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/config_old	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/config_old	(revision 17)
@@ -0,0 +1,406 @@
+#!/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" -o "$os" = "Interix" ] ; 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_old.pl
+if [ -n "$WRF_MARS" ] ; then
+  if [ $WRF_MARS = 1 ] ; then
+    echo building WRF for Mars
+    compileflags="${compileflags}!-DPLANET!-DMARS"
+    echo $compileflags
+  fi
+fi
+
+if [ -n "$WRF_TITAN" ] ; then
+  if [ $WRF_TITAN = 1 ] ; then
+    echo building WRF for Mars
+    compileflags="${compileflags}!-DPLANET!-DTITAN"
+  fi
+fi
+
+if [ -n "$WRF_VENUS" ] ; then
+  if [ $WRF_VENUS = 1 ] ; then
+    echo building WRF for Mars
+    compileflags="${compileflags}!-DPLANET!-DVENUS"
+  fi
+fi
+if [ -n "$WRF_CHEM" ] ; then
+  if [ $WRF_CHEM = 1 ] ; then
+    echo building WRF with chemistry option
+    compileflags="${compileflags}!-DWRF_CHEM"
+    if [ -n "$WRF_KPP" ] ; then
+      if [ $WRF_KPP = 1 ] ; then
+        echo building WRF with KPP chemistry option
+        compileflags="${compileflags}!-DWRF_KPP"
+      fi
+    fi
+  else
+    compileflags="${compileflags} "
+  fi
+else
+  compileflags="${compileflags} "
+fi
+
+# Found perl, so proceed with configuration
+if test -n "$PERL" ; then
+   $PERL arch/Config_old.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 [ "$os" = "Darwin" ] ; then
+    # fseeko64 does not exist under Darwin fseeko does. Remove the 0 length executable
+    # file that might get generated anyway, even though the compiler complains about missing reference.
+    /bin/rm -f tools/fseeko64_test 
+  fi
+  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 " "
+
Index: branches/LMDZ_WRFmeas/WRFV3/arch/configure_new.defaults
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/configure_new.defaults	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/configure_new.defaults	(revision 17)
@@ -0,0 +1,1112 @@
+
+###########################################################
+#ARCH    Linux i486 i586 i686, gfortran compiler with gcc #serial smpar dmpar dm+sm
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -fopenmp
+OMPCC           =       # -fopenmp
+SFC             =       gfortran
+SCC             =       gcc
+CCOMP           =       gcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       # -fdefault-real-8  # uncomment manually
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -w -O3 -c -DLANDREAD_STUB
+LDFLAGS_LOCAL   =
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3 -ftree-vectorize -ftree-loop-linear -funroll-loops
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT         =       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -ffixed-form
+FORMAT_FREE     =       -ffree-form -ffree-line-length-none
+FCSUFFIX        =       
+BYTESWAPIO      =       -fconvert=big-endian -frecord-marker=4
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -B 14000
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    Linux i486 i586 i686, g95 compiler with gcc #serial dmpar
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # not supported
+OMP             =       # not supported
+OMPCC           =       # not supported
+SFC             =       g95
+SCC             =       gcc
+CCOMP           =       gcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       -r$(RWORDSIZE) -i4
+ARCH_LOCAL      =       -DF2CSTYLE -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -DF2CSTYLE
+LDFLAGS_LOCAL   =
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O2 #-fast
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT         =       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -ffixed-form
+FORMAT_FREE     =       -ffree-form -ffree-line-length-huge
+FCSUFFIX        =
+BYTESWAPIO      =       -fendian=big
+FCBASEOPTS_NO_G =       -Wno=101,139,155,158 $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     -fmod=$(WRF_SRC_ROOT_DIR)/main
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -B 14000
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    Linux x86_64, PGI compiler with gcc # serial smpar dmpar dm+sm
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -mp -Minfo=mp -Mrecursive
+OMPCC           =       # -mp
+SFC             =       pgf90
+SCC             =       gcc
+CCOMP           =       pgcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       -r$(RWORDSIZE) -i4
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -w -O3
+LDFLAGS_LOCAL   =       
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -fastsse -Mvect=noaltcode -Msmartalloc -Mprefetch=distance:8 -Mfprelaxed # -Minfo=all =Mneginfo=all
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT		=       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -Mfixed
+FORMAT_FREE     =       -Mfree
+FCSUFFIX        =
+BYTESWAPIO      =       -byteswapio
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     -module $(WRF_SRC_ROOT_DIR)/main
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -B 14000
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    Linux x86_64, PGI accelerator compiler with gcc # serial smpar dmpar dm+sm
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -mp -Minfo=mp -Mrecursive
+OMPCC           =       # -mp
+SFC             =       pgf90
+SCC             =       gcc
+CCOMP           =       pgcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       -r$(RWORDSIZE) -i4
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR -D_ACCEL
+CFLAGS_LOCAL    =       -w -O3
+LDFLAGS_LOCAL   =
+CPLUSPLUSLIB    =
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -fastsse -Mvect=noaltcode -Msmartalloc -Mprefetch=distance:8 -ta=nvidia:fastmath,host # -Minfo=all =Mneginfo=all
+FCREDUCEDOPT    =       $(FCOPTIM)
+FCNOOPT         =       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -Mfixed
+FORMAT_FREE     =       -Mfree
+FCSUFFIX        =
+BYTESWAPIO      =       -byteswapio
+FCBASEOPTS      =       -w $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) $(OMP)
+MODULE_SRCH_FLAG =     -module $(WRF_SRC_ROOT_DIR)/main
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -B 14000
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    Linux i486 i586 i686, PGI compiler with gcc #serial smpar dmpar dm+sm
+#
+DMPARALLEL      =       # 1
+OMPCPP		=	# -D_OPENMP
+OMP		=	# -mp -Minfo=mp -Mrecursive
+OMPCC		=	# -mp
+SFC		=       pgf90
+SCC		=       gcc
+CCOMP		=       pgcc
+DM_FC		=	mpif90 -f90=$(SFC)
+DM_CC		=       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD		=	$(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       -r$(RWORDSIZE) -i4
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       
+LDFLAGS_LOCAL   =       
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM		=       -O2 -fast
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT		=       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -Mfixed
+FORMAT_FREE     =       -Mfree
+FCSUFFIX        =       
+BYTESWAPIO      =       -byteswapio
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     -module $(WRF_SRC_ROOT_DIR)/main
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4 		=      m4 -B 14000
+RANLIB 		=      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    Linux x86_64 i486 i586 i686, ifort compiler with icc #serial smpar dmpar dm+sm
+#
+#        By default, some files are compiled without optimizations to speed up compilation. Removing
+#        respective makefile rules in the end of this file will result in longer compilation time, and, possibly
+#        Out Of Memory messages, but might produce binaries which are substantially faster.
+#
+#        Please visit http://www.intel.com/support/performancetools/sb/cs-028607.htm 
+#        for latest info on how to build WRF with Intel compilers.
+#
+#        If you got Out Of Memory message, there are several options:
+#          1. Check your memory limits (ulimit -a), possibly increasing swap partitions size.
+#          2. Remove any debugging flags (-g, -check, -traceback).
+#          3. Force the problematic file to be compiled with less optimizations (see examples at the 
+#             end of this file), try -no-ip compiler flag.
+#
+#        This configuration is aimed at accuracy. To improve performance (at the expence of accuracy) you might
+#        consider removing '-fp-model precise' flag from FCBASEOPTS. This enables non value-safe optimizations.
+#        Another option is to add '-ftz' flag, which flushes denormal results to zero when the application is in
+#        the gradual underflow mode. It may improve performance if the denormal values are not critical to the
+#        behavior of your workload. To further improve performance, add suitable vectorization options for your
+#        processor to FCOPTIM (see ifort manpage).
+#
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        DM_FC  = mpiifort
+#        DM_CC  = mpiicc
+#        and source bin64/mpivars.sh file from your Intel MPI installation
+#        before the build.
+
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -openmp -fpp -auto
+OMPCC           =       # -openmp -fpp -auto
+SFC             =       ifort
+SCC             =       icc
+CCOMP           =       icc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       -i4
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_FUNC
+CFLAGS_LOCAL    =       -w -O3 -ip
+LDFLAGS_LOCAL   =       -ip
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT		=       -O0 -fno-inline -fno-ip
+FCDEBUG         =       # -g $(FCNOOPT) -traceback
+FORMAT_FIXED    =       -FI
+FORMAT_FREE     =       -FR
+FCSUFFIX        =
+BYTESWAPIO      =       -convert big_endian
+FCBASEOPTS_NO_G =       -w -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    ia64 Linux ifort compiler with icc 9.x,10.x #serial smpar dmpar dm+sm
+#
+#        By default, some files are compiled without optimizations to
+#        speed up compilation. Removing respective makefile rules in the
+#        end of this file will result in longer compilation time, and,
+#        possibly Out Of Memory messages, but might produce binaries
+#        which are substantially faster.
+#
+#        Please visit http://www.intel.com/support/performancetools/sb/cs-028607.htm 
+#        for latest info on how to build WRF with Intel compilers.
+#
+#        If you get Out Of Memory messages, there are several options:
+#          1. Check your memory limits (ulimit -a), possibly increasing
+#             swap partitions size.
+#          2. Remove any debugging flags (-g, -check, -traceback).
+#          3. Force the problematic file to be compiled with lower
+#             optimization (see examples at the end of this file),
+#             try the -no-ip compiler flag.
+#
+#        The default configuration is aimed at accuracy. To improve speed
+#        with only negligible effect on floating point accuracy,
+#        consider removing "-fp-model precise" from FCBASEOPTS. If
+#        you are using ifort 9.1.x compiler or earlier, consider
+#        uncommenting the version of the FCBASEOPTS settings that uses
+#        the -IPF-fp-relaxed option.
+#
+#        If you can tolerate a longer build, change the setting of
+#        FCNOOPT to -O1, for slightly faster performance.
+#
+#        If you have Intel MPI installed and wish to use instead, make the
+#        following changes to settings below:
+#        DM_FC  = mpiifort
+#        DM_CC  = mpiicc
+#        and source bin/mpivars.sh file from your Intel MPI installation
+#        before the build.
+#
+
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -openmp -fpp -auto
+OMPCC           =       # -openmp -fpp -auto
+SFC             =       ifort
+SCC             =       icc
+CCOMP           =       icc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =        -i4
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_FUNC
+CFLAGS_LOCAL    =       -w -O3 -ip
+LDFLAGS_LOCAL   =       -ip
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT		=       -O0 -fno-inline -fno-ip
+FCDEBUG         =       # -g $(FCNOOPT) -traceback
+FORMAT_FIXED    =       -FI
+FORMAT_FREE     =       -FR
+FCSUFFIX        =
+BYTESWAPIO      =       -convert big_endian
+FCBASEOPTS_NO_G =       -w -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO)
+#FCBASEOPTS_NO_G =       -w -ftz -align all -fno-alias -IPF-fp-relaxed $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+LIB_LOCAL       =       -L/usr/lib -lmpi 
+MODULE_SRCH_FLAG =     
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    Linux SGI Altix, ifort compiler with icc 9.x,10.x #serial smpar dmpar dm+sm
+#
+#        By default, some files are compiled without optimizations to
+#        speed up compilation. Removing respective makefile rules in the
+#        end of this file will result in longer compilation time, and,
+#        possibly Out Of Memory messages, but might produce binaries
+#        which are substantially faster.
+#
+#        If you get Out Of Memory messages, there are several options:
+#          1. Check your memory limits (ulimit -a), possibly increasing
+#             swap partitions size.
+#          2. Remove any debugging flags (-g, -check, -traceback).
+#          3. Force the problematic file to be compiled with lower
+#             optimization (see examples at the end of this file),
+#             try the -no-ip compiler flag.
+#
+#        Please visit http://www.intel.com/support/performancetools/sb/cs-028607.htm 
+#        for latest info on how to build WRF with Intel compilers.
+#
+#        The default configuration is aimed at accuracy. To improve speed
+#        with only negligible effect on floating point accuracy,
+#        consider removing "-fp-model precise" from FCBASEOPTS.  If
+#        you are using an ifort 9.1.x compiler or earlier, consider
+#        uncommenting the version of the FCBASEOPTS settings that uses
+#        the -IPF-fp-relaxed option.  To further improve performance,
+#        add processor-specific options to FCOPTIM (see ifort manpage).
+#
+#        If you can tolerate a longer build, change the setting of
+#        FCNOOPT to -O1, for slightly faster performance.
+#
+#        If your SGI MPI library is not installed in the default
+#        locations (/usr/bin, /usr/include, /usr/lib), set MPI_HOME
+#        to be the path to the directory where the SGI MPI bin,
+#        include and lib directories are, and change the DM_FC,
+#        DM_CC and LIB_LOCAL settings as follows:
+#        DM_FC = $(SFC) -I$(MPI_HOME)/include
+#        DM_CC = $(SFC) -I$(MPI_HOME)/include
+#        LIB_LOCAL = -L$(MPI_HOME)/lib -lmpi 
+
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -openmp -fpp -auto
+OMPCC           =       # -openmp -fpp -auto
+SFC             =       ifort
+SCC             =       icc
+CCOMP           =       icc
+DM_FC           =       $(SFC)
+DM_CC           =       $(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =        -i4
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_FUNC
+CFLAGS_LOCAL    =       -w -O3 -ip
+LDFLAGS_LOCAL   =       -ip
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT		=       -O0 -fno-inline -fno-ip
+FCDEBUG         =       # -g $(FCNOOPT) -traceback
+FORMAT_FIXED    =       -FI
+FORMAT_FREE     =       -FR
+FCSUFFIX        =
+BYTESWAPIO      =       -convert big_endian
+FCBASEOPTS_NO_G =       -w -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO)
+#FCBASEOPTS_NO_G =       -w -ftz -align all -fno-alias -IPF-fp-relaxed $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+LIB_LOCAL       =       -L/usr/lib -lmpi 
+MODULE_SRCH_FLAG =     
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    Linux i486 i586 i686 x86_64, PathScale compiler with pathcc #serial dmpar
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # not supported
+OMP             =       # not supported
+OMPCC           =       # not supported
+SFC             =       pathf90
+SCC             =       pathcc
+CCOMP           =       pathcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       -r$(RWORDSIZE) -i4
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       
+LDFLAGS_LOCAL   =
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O -OPT:Ofast:Olimit=5000
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT         =       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -fixedform
+FORMAT_FREE     =       -freeform
+FCSUFFIX        =
+BYTESWAPIO      =       -byteswapio
+FCBASEOPTS_NO_G =       -w -fno-second-underscore $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     -module $(WRF_SRC_ROOT_DIR)/main
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -B 14000
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    x86_64 Linux, gfortran compiler with gcc  #serial smpar dmpar dm+sm
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -fopenmp
+OMPCC           =       # -fopenmp
+SFC             =       gfortran
+SCC             =       gcc
+CCOMP           =       gcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       # -fdefault-real-8  # uncomment manually
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -w -O3 -c -DLANDREAD_STUB
+LDFLAGS_LOCAL   =       
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3 -ftree-vectorize -ftree-loop-linear -funroll-loops
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT		=       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -ffixed-form
+FORMAT_FREE     =       -ffree-form -ffree-line-length-none
+FCSUFFIX        =       
+BYTESWAPIO      =       -fconvert=big-endian -frecord-marker=4
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -G
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    Darwin (MACOS) PGI compiler with pgcc #serial smpar dmpar dm+sm
+#
+DMPARALLEL      =       # 1
+OMPCPP		=	# -D_OPENMP
+OMP		=	# -mp -Minfo=mp -Mrecursive
+OMPCC		=	# -mp
+SFC		=       pgf90 
+SCC		=       pgcc 
+CCOMP		=       pgcc 
+DM_FC		=	mpif90 -f90=$(SFC)
+DM_CC		=       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD		=	$(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       -r$(RWORDSIZE) -i4
+ARCH_LOCAL      =       -DMACOS -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -DMACOS
+LDFLAGS_LOCAL   =       
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM		=       -O2 -fast
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT		=       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -Mfixed
+FORMAT_FREE     =       -Mfree
+FCSUFFIX        =       
+BYTESWAPIO      =       -byteswapio
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     -module $(WRF_SRC_ROOT_DIR)/main
+TRADFLAG        =      -traditional
+CPP             =      cpp -C -P -xassembler-with-cpp
+AR              =      ar
+ARFLAGS         =      ru
+M4 		=      m4 -B 14000
+RANLIB 		=      ranlib
+CC_TOOLS        =      cc
+
+###########################################################
+#ARCH    Darwin (MACOS) intel compiler with icc #serial smpar dmpar dm+sm
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -openmp -fpp -auto
+OMPCC           =       # -openmp -fpp -auto
+SFC             =       ifort
+SCC             =       icc
+CCOMP           =       icc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =        -i4
+ARCH_LOCAL      =       -DMACOS -DNONSTANDARD_SYSTEM_FUNC
+CFLAGS_LOCAL    =       -w -O3 -ip -DMACOS
+# increase stack size; also note that for OpenMP, set environment OMP_STACKSIZE 4G or greater
+LDFLAGS_LOCAL   =       -ip -Wl,-stack_addr,0xF10000000 -Wl,-stack_size,0x64000000
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT         =       -O0 -fno-inline -fno-ip
+FCDEBUG         =       # -g $(FCNOOPT) -traceback
+FORMAT_FIXED    =       -FI
+FORMAT_FREE     =       -FR
+FCSUFFIX        =
+BYTESWAPIO      =       -convert big_endian
+# added -fno-common at suggestion of R. Dubtsov as workaround for failing to link program_name
+FCBASEOPTS_NO_G =       -w -ftz -align all -fno-alias -fp-model precise -fno-common $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =
+TRADFLAG        =      -traditional
+CPP             =      cpp -C -P -xassembler-with-cpp
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -B 14000
+RANLIB          =      ranlib
+CC_TOOLS        =      cc
+
+###########################################################
+#ARCH    Darwin (MACOS) intel compiler with cc #serial smpar dmpar dm+sm
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -openmp -fpp -auto
+OMPCC           =       # -openmp
+SFC             =       ifort
+SCC             =       cc
+CCOMP           =       cc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =        -i4
+ARCH_LOCAL      =       -DMACOS -DNONSTANDARD_SYSTEM_FUNC
+CFLAGS_LOCAL    =       -w -O3 -DMACOS
+# increase stack size; also note that for OpenMP, set environment OMP_STACKSIZE 4G or greater
+LDFLAGS_LOCAL   =       -ip -Wl,-stack_addr,0xF10000000 -Wl,-stack_size,0x64000000
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT         =       -O0 -fno-inline -fno-ip
+FCDEBUG         =       # -g $(FCNOOPT) -traceback
+FORMAT_FIXED    =       -FI
+FORMAT_FREE     =       -FR
+FCSUFFIX        =
+BYTESWAPIO      =       -convert big_endian
+# added -fno-common at suggestion of R. Dubtsov as workaround for failing to link program_name
+FCBASEOPTS_NO_G =       -w -ftz -align all -fno-alias -fp-model precise -fno-common $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =
+TRADFLAG        =      -traditional
+CPP             =      cpp -C -P -xassembler-with-cpp
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -B 14000
+RANLIB          =      ranlib
+CC_TOOLS        =      cc
+
+###########################################################
+#ARCH    Darwin (MACOS) g95 with gcc #serial dmpar
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # not supported
+OMP             =       # not supported
+OMPCC           =       # not supported
+SFC             =       g95
+SCC             =       gcc
+CCOMP           =       gcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       -r$(RWORDSIZE) -i4
+ARCH_LOCAL      =       -DG95 -DMACOS -DF2CSTYLE -DNONSTANDARD_SYSTEM_SUBR -DRCONFIG_CHARLEN=64
+CFLAGS_LOCAL    =       -DMACOS -DF2CSTYLE
+LDFLAGS_LOCAL   =
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O2 # -fast
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT		=       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -ffixed-form
+FORMAT_FREE     =       -ffree-form -ffree-line-length-huge
+FCSUFFIX        =
+BYTESWAPIO      =       -fendian=big
+FCBASEOPTS_NO_G =       -Wno=101,139,155,158 $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+LIB_LOCAL       =    -L/usr/lib -lSystemStubs
+MODULE_SRCH_FLAG =     -fmod=$(WRF_SRC_ROOT_DIR)/main
+TRADFLAG        =      -traditional
+CPP             =      cpp -C -P -xassembler-with-cpp
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -B 14000
+RANLIB          =      ranlib -c
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    Darwin (MACOS) gfortran with gcc #serial smpar dmpar dm+sm
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -fopenmp
+OMPCC           =       # -fopenmp
+SFC             =       gfortran
+SCC             =       gcc
+CCOMP           =       gcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       # -fdefault-real-8  # uncomment manually
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR -DMACOS
+CFLAGS_LOCAL    =       -w -O3 -c -DLANDREAD_STUB -DMACOS
+LDFLAGS_LOCAL   =
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3 -ftree-vectorize -ftree-loop-linear -funroll-loops
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT         =       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -ffixed-form
+FORMAT_FREE     =       -ffree-form -ffree-line-length-none
+FCSUFFIX        =       
+BYTESWAPIO      =       -fconvert=big-endian -frecord-marker=4
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =
+TRADFLAG        =      -traditional
+CPP             =      cpp -C -P -xassembler-with-cpp
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -B 14000
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    Darwin (MACOS) xlf  #serial dmpar
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # not supported
+OMP             =       # not supported
+OMPCC           =       # not supported
+SFC             =       xlf90_r
+SCC             =       cc
+CCOMP           =       cc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =        -qrealsize=$(RWORDSIZE) -qintsize=4
+ARCH_LOCAL      =       -DMAC_KLUDGE -DF2CSTYLE -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -DMACOS -DF2CSTYLE
+LDFLAGS_LOCAL   =
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3 -qarch=auto
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT		=       -qnoopt
+FCDEBUG         =       # -g $(FCNOOPT) -qfullpath
+FORMAT_FIXED    =       -qfixed
+FORMAT_FREE     =       -qfree=f90
+FCSUFFIX        =       -qsuffix=f=f90
+BYTESWAPIO      =       
+FCBASEOPTS_NO_G =       -qsave -qmaxmem=32767 -qspillsize=32767 -w
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     -fmod=$(WRF_SRC_ROOT_DIR)/main
+TRADFLAG        =      
+CPP             =      cpp -C -P 
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -B 14000
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    AIX xlf compiler with xlc #serial smpar dmpar dm+sm
+#
+DMPARALLEL      =       # 1
+OMPCPP		=	# -D_OPENMP
+OMP		=	# -qsmp=noauto
+OMPCC		=	# -qsmp=noauto
+SFC		=       xlf90_r
+SCC		=       cc_r
+SC99		=	c99_r
+CCOMP		=       cc_r
+DM_FC		=	mpxlf90_r
+DM_CC		=       mpcc_r
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD		=	$(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =        -qrealsize=$(RWORDSIZE) -qintsize=4
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR -DNATIVE_MASSV
+CFLAGS_LOCAL    =       -DNOUNDERSCORE
+LDFLAGS_LOCAL   =       -lmass -lmassv
+CPLUSPLUSLIB    =       -lC
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+# -qhot commented out in 3.0.1.1 release because of reported problems with 
+# model results under certain configurations. Use at your own risk.
+FCOPTIM		=       -O3 # -qhot
+FCREDUCEDOPT	=       -O2
+FCNOOPT		=       -qnoopt
+FCDEBUG         =       # -g $(FCNOOPT) -qfullpath
+FORMAT_FIXED    =       -qfixed
+FORMAT_FREE     =       -qfree=f90
+FCSUFFIX        =       -qsuffix=f=f90
+BYTESWAPIO      =       
+FCBASEOPTS_NO_G =       -w -qspill=20000 -qmaxmem=32767 $(FORMAT_FREE) $(BYTESWAPIO)  #-qflttrap=zerodivide:invalid:enable -qsigtrap -C # -qinitauto=7FF7FFFF
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     
+TRADFLAG        =       
+CPP             =       /lib/cpp -C -P
+AR              =       ar
+ARFLAGS         =       ru
+M4 		=       m4 -B 14000
+RANLIB 		=       ranlib
+CC_TOOLS        =       cc
+
+###########################################################
+#ARCH    Cray XT CLE/Linux x86_64, PGI compiler with gcc # serial dmpar smpar dm+sm
+#
+# Recommended CLE/Linux memory allocation settings at run time:
+# export MALLOC_MMAP_MAX_=0
+# export MALLOC_TRIM_THRESHOLD_=536870912
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -mp -Mrecursive
+OMPCC           =       # -mp
+SFC             =       ftn
+SCC             =       gcc
+CCOMP           =       pgcc
+DM_FC           =       ftn
+DM_CC           =       gcc -I$(MPICH_DIR)/include
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       -r$(RWORDSIZE) -i4
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -w -O3
+LDFLAGS_LOCAL   =
+# module load libfast to use Cray XT fast math library
+#LIB_LOCAL       =       -lfast_mv
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+# PGI recommended
+FCOPTIM         =       -O3 -fast -Mvect=noaltcode -Mprefetch=distance:8 -Mfprelaxed 
+# For Pathscale compiler
+#FCOPTIM        =       -O3 -OPT:Ofast
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT         =       -O0
+OPTERON_TYPE    =
+# Use this for AMD Opteron quad-core
+#OPTERON_TYPE    =      -tp barcelona-64
+#OPTERON_TYPE    =      -tp shanghai-64
+# Use this for AMD Opteron six-way Istanbul
+#OPTERON_TYPE    =      -tp istanbul
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -Mfixed
+FORMAT_FREE     =       -Mfree
+# For Pathscale compiler
+#OPTERON_TYPE    =       -march=barcelona -msse4a
+#FORMAT_FIXED    =       -fixedform
+#FORMAT_FREE     =       -freeform
+FCSUFFIX        =
+BYTESWAPIO      =       -byteswapio
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO) $(OPTERON_TYPE) $(OMP)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =    
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P $(TRADFLAG)
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -B 14000
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+#ARCH    Cray XT CLE/Linux x86_64, Cray CCE compiler with gcc # serial dmpar smpar dm+sm
+#
+# Recommended CLE/Linux memory allocation settings at run time:
+# export MALLOC_MMAP_MAX_=0
+# export MALLOC_TRIM_THRESHOLD_=536870912
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -Oomp
+OMPCC           =       # -fopenmp
+SFC             =       ftn
+SCC             =       gcc
+CCOMP           =       gcc
+DM_FC           =       ftn
+DM_CC           =       gcc -I$(MPICH_DIR)/include
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       -s integer32 -s real32
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -w -O3 
+LDFLAGS_LOCAL   =
+# module load libfast
+#LIB_LOCAL       =       -lfast_mv
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT         =       -O1 -Oipa0
+OPTERON_TYPE    =
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -f fixed
+FORMAT_FREE     =       -f free
+FCSUFFIX        =
+BYTESWAPIO      =       -h byteswapio
+FCBASEOPTS_NO_G =       -N255 -Onomodinline -em -Onoomp $(FORMAT_FREE) $(BYTESWAPIO) $(OPTERON_TYPE) $(OMP)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =    
+TRADFLAG        =       -traditional
+CPP             =       /lib/cpp -C -P $(TRADFLAG)
+AR              =       ar
+ARFLAGS         =       ru
+M4              =       m4 -B 14000
+RANLIB          =       ranlib
+CC_TOOLS        =       $(SCC) 
+
+###########################################################
+#ARCH    Linux ppc64 BG /L blxlf compiler with blxlc # dmpar
+#
+DMPARALLEL      =       # 1
+OMPCPP		=	# not supported
+OMP		=	# not supported
+OMPCC		=	# not supported
+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
+SFC		=       blrts_xlf90
+SCC		=       blrts_xlc
+CCOMP		=       blrts_xlc
+DM_FC		=	$(SFC)
+DM_CC		=       $(SCC)
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD		=	$(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =        -qrealsize=$(RWORDSIZE) -qintsize=4
+# If system has even more processors, set VERY_LARGE_MAXPROC to that number
+ARCH_LOCAL      =       -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DLANDREAD_STUB -DVERY_LARGE_MAXPROC=36768 -DBLUEGENE
+CFLAGS_LOCAL    =       -DNOUNDERSCORE -DNCARIBM_NOC99 $(MPI_INC)  -DLANDREAD_STUB
+LIB_LOCAL       =       $(MPI_LIB)
+LDFLAGS_LOCAL   =       -Wl,--allow-multiple-definition -qstatic
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM		=       -O2 -qarch=440
+FCNOOPT		=       -qnoopt
+FCDEBUG         =       # $(FCNOOPT) -qfullpath
+FORMAT_FIXED    =       -qfixed
+FORMAT_FREE     =       -qfree=f90
+FCSUFFIX        =       -qsuffix=f=f90
+BYTESWAPIO      =       
+FCBASEOPTS_NO_G =       -w -qspill=20000 -qmaxmem=64000 $(FORMAT_FREE) $(BYTESWAPIO) $(MPI_INC) #-qflttrap=zerodivide:invalid:enable -qsigtrap
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     
+TRADFLAG        =       
+# this might be different on different systems but we want the xlf version of cpp, not Linux's
+# NYBlue
+CPP             =       /opt/ibmcmp/xlf/bg/10.1/exe/cpp -C -P
+# frost.ucar.edu
+CPP             =       /opt/ibmcmp/xlf/9.1/exe/cpp -C -P
+AR              =       ar
+ARFLAGS         =       ru
+M4 		=       m4 -B 14000
+RANLIB 		=       ranlib
+CC_TOOLS        =       cc
+###########################################################
+#ARCH    Linux ppc64 BG /P xlf compiler with xlc # smpar dmpar dm+sm
+#     developed on surveyor.alcf.anl.gov (thanks to ANL/ALCF)
+#
+DMPARALLEL      =       # 1
+OMPCPP		=	# -D_OPENMP
+OMP		=	# -qsmp=noauto
+OMPCC		=	# -qsmp=noauto
+# these have to be the same as DM_FC on surveyor or it fails with weird errors in time manager
+SFC             =       time mpixlf90_r
+SCC             =       time mpixlc_r
+CCOMP           =       time mpixlc_r
+DM_FC           =       time mpixlf90_r
+DM_CC           =       time mpixlc_r -DMPI2_SUPPORT
+FC              =        $(DM_FC)
+CC              =       $(DM_CC) -DFSEEKO64_OK
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =        -qrealsize=$(RWORDSIZE) -qintsize=4
+# If system has even more processors, set VERY_LARGE_MAXPROC to that number
+ARCH_LOCAL      =       -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DLANDREAD_STUB -DVERY_LARGE_MAXPROC=36768 -DBLUEGENE
+CFLAGS_LOCAL    =       -DNOUNDERSCORE -DLANDREAD_STUB
+LIB_LOCAL       =
+LDFLAGS_LOCAL   =       -Wl,--allow-multiple-definition,--relax -qstatic
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM		=       -O3 -qnoipa -qarch=auto -qcache=auto -qtune=auto
+FCNOOPT		=       -qnoopt
+FCDEBUG         =       # $(FCNOOPT) -g -qfullpath
+FORMAT_FIXED    =       -qfixed
+FORMAT_FREE     =       -qfree=f90
+FCSUFFIX        =       -qsuffix=f=f90
+BYTESWAPIO      =       
+FCBASEOPTS_NO_G =       -w -qspill=20000 -qmaxmem=64000 $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     
+TRADFLAG        =       
+# this might be different on different systems but we want the xlf version of cpp, not Linux's
+# surveyor.alcf.anl.gov
+CPP             =       /opt/ibmcmp/xlf/bg/11.1/exe/cpp -C -P
+AR              =       ar
+ARFLAGS         =       ru
+M4 		=       m4 -B 14000
+RANLIB 		=       ranlib
+CC_TOOLS        =       cc
+###########################################################
+#ARCH    Linux ppc64 IBM Blade Server xlf compiler with xlc # dmpar
+#    provided by Luis C. Cana Cascallar for IBM JS21 blade server, May 2009
+#
+DMPARALLEL      =       # 1
+OMPCPP		=	# not supported
+OMP		=	# not supported
+OMPCC		=	# not supported
+SFC		=       xlf90_r -q64
+SCC		=       xlc_r -q64
+CCOMP		=       xlc_r -q64
+DM_FC		=	mpif90 -q64
+DM_CC		=       mpicc -q64 -DMPI2_SUPPORT  -DFSEEKO64_OK
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD		=	$(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =        -qrealsize=$(RWORDSIZE) -qintsize=4
+# If system has even more processors, set VERY_LARGE_MAXPROC to that number
+ARCH_LOCAL      =       -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DLANDREAD_STUB -DVERY_LARGE_MAXPROC=36768
+CFLAGS_LOCAL    =       -DNOUNDERSCORE -DLANDREAD_STUB
+LDFLAGS_LOCAL   =       
+CPLUSPLUSLIB    =       -lC
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM		=       -O3 -qtune=ppc970 -qarch=ppc970 
+FCNOOPT		=       -qnoopt
+FCDEBUG         =       # -g $(FCNOOPT) -qfullpath
+FORMAT_FIXED    =       -qfixed
+FORMAT_FREE     =       -qfree=f90
+FCSUFFIX        =       -qsuffix=f=f90
+BYTESWAPIO      =       
+FCBASEOPTS_NO_G =       -w -qspill=20000 -qmaxmem=32767 $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     
+TRADFLAG        =       
+# this might be different on different systems but we want the xlf version of cpp, not Linux
+CPP             =       /opt/ibmcmp/xlf/11.1/exe/cpp -C -P
+AR              =       ar
+ARFLAGS         =       ru
+M4 		=       m4 -B 14000
+RANLIB 		=       ranlib
+CC_TOOLS        =       xlc -q64
+###########################################################
+#ARCH    CYGWIN_NT i686, PGI compiler on Windows # serial smpar dmpar dm+sm
+#
+DMPARALLEL      =       # 1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -mp -Minfo=mp
+OMPCC           =       # -mp
+SFC             =       pgf90
+SCC             =       pgcc
+CCOMP           =       pgcc
+DM_FC           =       pgf90 -Mmpi=msmpi
+DM_CC           =       pgcc -Mmpi=msmpi
+FC              =       CONFIGURE_FC
+CC              =       CONFIGURE_CC
+LD              =       $(FC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION       =       -r$(RWORDSIZE) -i4
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR -D_WIN32
+CFLAGS_LOCAL    =       -w -O3 -DMEMCPY_FOR_BCOPY -DLANDREAD_STUB
+LDFLAGS_LOCAL   =       Ws2_32.lib # -lnetcdff
+CPLUSPLUSLIB    =
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -fastsse -Mvect=noaltcode -Mprefetch=distance:8 -Mfprelaxed -tp core2-64 # -Minfo=all 
+FCREDUCEDOPT    =       $(FCOPTIM)
+FCNOOPT         =       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -Mfixed
+FORMAT_FREE     =       -Mfree
+FCSUFFIX        =
+BYTESWAPIO      =       -byteswapio 
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG=       -module $(WRF_SRC_ROOT_DIR)/main
+TRADFLAG        =
+CPP             =       pgprepro
+AR              =       ar
+ARFLAGS         =       cr
+M4              =       NA
+RANLIB          =       ranlib
+CC_TOOLS        =       $(SCC) 
+
+LIB_EXTERNAL    = \
+                     ../external/io_netcdf/libwrfio_nf.a CONFIGURE_NETCDF_PATH/lib/libnetcdf.lib \
+                     ../external/wavelet/libWavelet.a ../external/wavelet/lib_wavelet.a
+ESMF_IO_LIB     =    ../external/esmf_time_f90/libesmf_time.a
+LIB_BUNDLED     = \
+                     ../external/fftpack/fftpack5/libfftpack.a \
+                     ../external/io_grib1/libio_grib1.a \
+                     ../external/io_grib_share/libio_grib_share.a \
+                     ../external/io_int/libwrfio_int.a \
+                     $(ESMF_IO_LIB) \
+                     CONFIGURE_COMMS_LIB \
+                     ../frame/module_internal_header_util.o \
+                     ../frame/pack_utils.o
+
+
+###########################################################
+#ARCH  NULL
+
Index: branches/LMDZ_WRFmeas/WRFV3/arch/configure_old.defaults
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/configure_old.defaults	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/configure_old.defaults	(revision 17)
@@ -0,0 +1,3558 @@
+##########################################################
+#ARCH	SGI 32 bit machine IRIX
+
+FC		=	f90
+SFC		=	$(FC)
+LD		=	f90
+CC              =       cc
+SCC		=	$(CC)
+RWORDSIZE       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+ARCHFLAGS       =       $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DLIMIT_ARGS $(DA_ARCHFLAGS)
+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             =	$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	make NETCDFPATH=CONFIGURE_NETCDF_PATH FC="$(FC) $(PROMOTION) -freeform -I." RANLIB="$(RANLIB)" CPP="$(CPP)" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RANLIB="$(RANLIB)" CPP="$(CPP)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o  start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem  \
+                       	-I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -I$(WRF_SRC_ROOT_DIR)/inc
+ARCHFLAGS       =       $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \
+			$(DA_ARCHFLAGS) \
+                        -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             =	$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH FC="$(FC) $(PROMOTION) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+ARCHFLAGS       =       $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG \
+                        -DINTIO -DLIMIT_ARGS -DLANDREAD_STUB
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH FC="$(FC) $(PROMOTION) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RANLIB="$(RANLIB)" CPP="$(CPP)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o  start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share \
+                        -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+ARCHFLAGS       =       $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        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$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -w" RANLIB="$(RANLIB)" CPP="$(CPP)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o  start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem \
+			-M$(WRF_SRC_ROOT_DIR)/external/io_netcdf -M$(WRF_SRC_ROOT_DIR)/external/io_int -M$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+			-M$(WRF_SRC_ROOT_DIR)/frame -M$(WRF_SRC_ROOT_DIR)/share -M$(WRF_SRC_ROOT_DIR)/phys -M$(WRF_SRC_ROOT_DIR)/inc -M$(WRF_SRC_ROOT_DIR)/chem \
+			-M$(WRF_SRC_ROOT_DIR)/dyn_em 
+ARCHFLAGS       =       $(COREDEFS) -DINTIO -DGRIB1 CONFIGURE_GRIB2_FLAG -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG \
+			-DLIMIT_ARGS
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS) " )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+solve_interface.o : solve_interface.F
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.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       =       CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem \
+			-M$(WRF_SRC_ROOT_DIR)/external/io_netcdf -M$(WRF_SRC_ROOT_DIR)/external/io_int -M$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+			-M$(WRF_SRC_ROOT_DIR)/frame -M$(WRF_SRC_ROOT_DIR)/share -M$(WRF_SRC_ROOT_DIR)/phys -M$(WRF_SRC_ROOT_DIR)/inc -M$(WRF_SRC_ROOT_DIR)/chem \
+			-M$(WRF_SRC_ROOT_DIR)/dyn_em 
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG \
+			-DLIMIT_ARGS
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS) " )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" archive )
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+solve_interface.o : solve_interface.F
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+###########################################################
+#ARCH       Compaq OSF1 alpha          (single-threaded, no nesting)
+#
+OMP             =       
+OMPCPP          =       
+FC              =       f90
+SFC		=	$(FC)
+LD              =       f90
+CC              =       cc
+SCC		=	$(CC)
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+RSIZEBITS	=	`expr $(RWORDSIZE) \* 8`
+ARCHFLAGS       =       $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time  \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_dm.F
+mediation_wrfmain.o : mediation_wrfmain.F
+solve_em.o : solve_em.F
+
+mediation_integrate.o module_dm.o module_comm_dm.o mediation_wrfmain.o solve_em.o : 
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+RSIZEBITS	=	`expr $(RWORDSIZE) \* 8`
+ARCHFLAGS       =       $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_dm.F
+mediation_wrfmain.o : mediation_wrfmain.F
+solve_em.o : solve_em.F
+
+mediation_integrate.o module_dm.o module_comm_dm.o mediation_wrfmain.o solve_em.o : 
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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 ARW and NMM 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       =       CONFIGURE_RWORDSIZE
+RSIZEBITS	=	`expr $(RWORDSIZE) \* 8`
+ARCHFLAGS       =       $(COREDEFS) -DNETCDF -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite  \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; \
+          make CPP="$(CPP) $(CPPFLAGS)" 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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_dm.F
+mediation_wrfmain.o : mediation_wrfmain.F
+solve_em.o : solve_em.F
+
+mediation_integrate.o module_dm.o module_comm_dm.o mediation_wrfmain.o solve_em.o : 
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+RSIZEBITS	=	`expr $(RWORDSIZE) \* 8`
+ARCHFLAGS       =       $(COREDEFS) -DAUTODOC_BUILD CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DWRF_RSL_IO \
+			$(DA_ARCHFLAGS) \
+                        -DDM_PARALLEL="'<b>DM_PARALLEL</b>'" -DRSL_LITE="'<b>RSL_LITE</b>'" \
+                        -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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL/librsl_lite.a gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL/RSL/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; \
+          make CC="$(CC)" FC="$(FC) $(PROMOTION)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) all )
+
+# 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$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_dm.F
+mediation_wrfmain.o : mediation_wrfmain.F
+solve_em.o : solve_em.F
+
+mediation_integrate.o module_dm.o module_comm_dm.o mediation_wrfmain.o solve_em.o : 
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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 ARW and NMM 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       =       CONFIGURE_RWORDSIZE
+RSIZEBITS	=	`expr $(RWORDSIZE) \* 8`
+ARCHFLAGS       =       $(COREDEFS) -DNETCDF -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite  \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCFLAGS_ESMF)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; \
+          make CPP="$(CPP) $(CPPFLAGS)" 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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_dm.F
+mediation_wrfmain.o : mediation_wrfmain.F
+solve_em.o : solve_em.F
+
+mediation_integrate.o module_dm.o module_comm_dm.o mediation_wrfmain.o solve_em.o : 
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+                        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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o  -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; \
+	  cat  module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASENOINL) -w" TRADFLAG="-traditional" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \
+          TRADFLAG="-traditional" archive )
+
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+                        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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o  -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          /bin/cp module_dm_warning module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCBASENOINL) -w" TRADFLAG="-traditional" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASENOINL) -w" \
+          TRADFLAG="-traditional" archive )
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+			-DLIMIT_ARGS
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             = 	$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -Free -X9" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -Free -X9" archive)
+
+wrfio_grib1 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) -Free -X9" archive )
+
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+			-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             = 	$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time  \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" archive)
+
+wrfio_grib1 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" archive )
+
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.F > $*.f90
+	$(FC) -c -O 0 $(PROMOTION) $(FCFLAGS) $*.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 $(WRF_SRC_ROOT_DIR)/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         = CONFIGURE_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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/inc \
+			-p./ -p$(WRF_SRC_ROOT_DIR)/external/io_netcdf -p$(WRF_SRC_ROOT_DIR)/external/io_int -p$(WRF_SRC_ROOT_DIR)/frame \
+                        -p$(WRF_SRC_ROOT_DIR)/frame -p$(WRF_SRC_ROOT_DIR)/share -p$(WRF_SRC_ROOT_DIR)/phys -p$(WRF_SRC_ROOT_DIR)/chem \
+                        -p$(WRF_SRC_ROOT_DIR)/dyn_em -p $(WRF_SRC_ROOT_DIR)/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 \
+			$(DA_ARCHFLAGS) \
+			-DLIMIT_ARGS -Dcrayx1
+
+PERL            =       perl
+REGISTRY        =       Registry
+
+LIB             =       -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+			-L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int  \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+			-L$(WRF_SRC_ROOT_DIR)/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) # 
+CPPFLAGS	=	-I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP) -Dcrayx1" FC="$(FC) $(PROMOTION) -f free -N 255 " )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC) -UCRAY" CPP="$(CPP) -Dcrayx1" RANLIB="$(RANLIB)" \
+          FC="$(FC) $(PROMOTION) -f free -N 255" archive )
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) -f free -N 255" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; \
+          make CPP="$(CPP) $(CPPFLAGS)" CFLAGS="$(CFLAGS)" CC="$(CC)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" OPTS="$(FCBASEOPTS)" \
+                                     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
+module_comm_dm.o : module_comm_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 module_comm_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$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+ARCHFLAGS       =       $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DLIMIT_ARGS -DFLOATSAFE \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) " )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive)
+
+wrfio_grib1 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" RANLIB="$(RANLIB)" \
+          FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive )
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \
+          FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive )
+
+esmf_time : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o mediation_integrate.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+ARCHFLAGS       =       $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DLIMIT_ARGS -DFLOATSAFE \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) " )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive)
+
+wrfio_grib1 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" RANLIB="$(RANLIB)" \
+          FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive )
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \
+          FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive )
+
+esmf_time : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o mediation_integrate.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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       =       CONFIGURE_RWORDSIZE
+ARCHFLAGS       =       $(COREDEFS) CONFIGURE_NETCDF_FLAG -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DLIMIT_ARGS -DFLOATSAFE \
+			$(DA_ARCHFLAGS) \
+                        -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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) " )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" RANLIB="$(RANLIB)" CPP="$(CPP)" SFC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " all )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive)
+
+wrfio_grib1 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CPP="$(CPP)" RANLIB="$(RANLIB)" \
+          FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive )
+wrfio_grib2 : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC)" CPP="$(CPP) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \
+          FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS) -I$(WRF_SRC_ROOT_DIR)/inc " archive )
+
+esmf_time : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o mediation_integrate.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCFLAGS) $(MODULE_DIRS) $*.f90
+
+###########################################################
+#ARCH Darwin		(single-threaded, xlf, 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       = CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG \
+			-DLIMIT_ARGS  -DLANDREAD_STUB -DMAC_KLUDGE
+#			-DLIMIT_ARGS  -DNATIVE_MASSV -DMACOS
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+#LIB             =       CONFIGURE_NETCDF_LIB_PATH -lmass -lmassv 
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCSUFFIX) -qarch=auto -qzerosize" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+solve_interface.o : solve_interface.F
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/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
+module_comm_dm.o : module_comm_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 module_comm_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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90
+
+###########################################################
+#ARCH Darwin		(OpenMP, xlf, 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       = CONFIGURE_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$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int  -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 CONFIGURE_GRIB2_FLAG -DINTIO -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        CONFIGURE_NETCDF_FLAG \
+			-DLIMIT_ARGS  -DLANDREAD_STUB -DMACOS -DMAC_KLUDGE
+PERL            =       CONFIGURE_PERL_PATH
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -lxlsmp \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCDEBUG) -qarch=auto -qzerosize" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+
+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$(WRF_SRC_ROOT_DIR)/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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c -g $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) -qnoopt -qnohot $*.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
+
+DMPARALLEL      =       1
+MAX_PROC        =       1024
+FC              =       sxmpif90
+LD              =       sxmpif90
+CC              =       sxmpic++ -DMPI2_SUPPORT
+SCC		=	sxmpic++
+SFC             =       sxmpif90
+RWORDSIZE       =       $(NATIVE_RWORDSIZE)
+PROMOTION	=	
+CFLAGS          =       -DNCARIBM_NOC99 -DDM_PARALLEL \
+                        -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) \
+                        -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE \
+                        -Xa -Kc99
+FCNOOPT         = -Cssafe
+FCOPTIM		=	
+FCDEBUG		=	#-g
+#FCBASEOPTS      =       -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG)
+FCBASEOPTS      =       -ftrace -Wf,-L fmtlist transform,-pvctl fullmsg loopcnt=1000000 -f4 -Wf,-P i \
+FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS)
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 -DINTIO -DDM_PARALLEL \
+                        -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 -DNETCDF \
+			$(DA_ARCHFLAGS) \
+			-DLIMIT_ARGS
+# machine-specific flags needed to link in ESMF library (C++ run-time-library, etc.)
+ESMF_LIB_FLAGS  =       
+ESMF_IO_LIB     =       $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90/libesmf_time.a
+ESMF_IO_LIB_EXT =       -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90/libesmf_time.a
+INCLUDE_MODULES =       -I$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       $(WRF_SRC_ROOT_DIR)/external/io_netcdf/libwrfio_nf.a -L/pool/SX-6/netcdf/netcdf-3.6.2/lib -lnetcdf -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time -L$(SX_BASE_CPLUS)/lib -lcpp
+LDFLAGS         =       $(FCFLAGS) -Wl,-h nodefs 
+ENVCOMPDEFS	=	
+WRF_CHEM	=	0 
+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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/arch/no_file_line.sed
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 wrfio_int  esmf_time  module_dm.F fftpack
+
+module_dm.F:
+	( /sbin/cp module_dm_warning module_dm.F ; \
+	  cat module_dm_stubs.F  >> module_dm.F )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" AR="$(AR_BASE)" archive)
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS)" AR="$(AR_BASE)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(CC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(SFC) $(PROMOTION) $(FCFLAGS)" AR="$(AR_BASE)" archive)
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH="$(NETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" AR="$(AR_BASE)" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" AR="$(AR_BASE)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" AR="$(AR_BASE)" )
+
+# compile these without high optimization to speed compile
+convert_nmm.o : convert_nmm.F
+init_modules_em.o : init_modules_em.F
+input_wrf.o : input_wrf.F
+module_io.o : module_io.F
+module_comm_dm.o : module_comm_dm.F
+module_configure.o : module_configure.F
+module_dm.o : module_dm.F
+module_domain.o : module_domain.F
+module_domain_type.o : module_domain_type.F
+module_alloc_space.o : module_alloc_space.F
+module_tiles.o : module_tiles.F
+module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F
+module_initialize.o : module_initialize.F
+module_physics_init.o : module_physics_init.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_real.o : module_initialize_real.F
+module_initialize_real.o: module_initialize_real.F
+module_initialize_squall2d_x.o : module_initialize_squall2d_x.F
+module_initialize_squall2d_y.o : module_initialize_squall2d_y.F
+module_integrate.o : module_integrate.F
+module_io_mm5.o : module_io_mm5.F
+module_io_wrf.o : module_io_wrf.F
+module_si_io.o : module_si_io.F
+module_state_description.o : module_state_description.F 
+output_wrf.o : output_wrf.F
+solve_interface.o : solve_interface.F
+start_domain.o : start_domain.F
+start_domain_nmm.o : start_domain_nmm.F
+start_em.o : start_em.F
+wrf_auxhist10in.o : wrf_auxhist10in.F
+wrf_auxhist10out.o : wrf_auxhist10out.F
+wrf_auxhist11in.o : wrf_auxhist11in.F
+wrf_auxhist11out.o : wrf_auxhist11out.F
+wrf_auxhist1in.o : wrf_auxhist1in.F
+wrf_auxhist1out.o : wrf_auxhist1out.F
+wrf_auxhist2in.o : wrf_auxhist2in.F
+wrf_auxhist2out.o : wrf_auxhist2out.F
+wrf_auxhist3in.o : wrf_auxhist3in.F
+wrf_auxhist3out.o : wrf_auxhist3out.F
+wrf_auxhist4in.o : wrf_auxhist4in.F
+wrf_auxhist4out.o : wrf_auxhist4out.F
+wrf_auxhist5in.o : wrf_auxhist5in.F
+wrf_auxhist5out.o : wrf_auxhist5out.F
+wrf_auxhist6in.o : wrf_auxhist6in.F
+wrf_auxhist6out.o : wrf_auxhist6out.F
+wrf_auxhist7in.o : wrf_auxhist7in.F
+wrf_auxhist7out.o : wrf_auxhist7out.F
+wrf_auxhist8in.o : wrf_auxhist8in.F
+wrf_auxhist8out.o : wrf_auxhist8out.F
+wrf_auxhist9in.o : wrf_auxhist9in.F
+wrf_auxhist9out.o : wrf_auxhist9out.F
+wrf_auxinput10in.o : wrf_auxinput10in.F
+wrf_auxinput10out.o : wrf_auxinput10out.F
+wrf_auxinput11in.o : wrf_auxinput11in.F
+wrf_auxinput11out.o : wrf_auxinput11out.F
+wrf_auxinput1in.o : wrf_auxinput1in.F
+wrf_auxinput1out.o : wrf_auxinput1out.F
+wrf_auxinput2in.o : wrf_auxinput2in.F
+wrf_auxinput2out.o : wrf_auxinput2out.F
+wrf_auxinput3in.o : wrf_auxinput3in.F
+wrf_auxinput3out.o : wrf_auxinput3out.F
+wrf_auxinput4in.o : wrf_auxinput4in.F
+wrf_auxinput4out.o : wrf_auxinput4out.F
+wrf_auxinput5in.o : wrf_auxinput5in.F
+wrf_auxinput5out.o : wrf_auxinput5out.F
+wrf_auxinput6in.o : wrf_auxinput6in.F
+wrf_auxinput6out.o : wrf_auxinput6out.F
+wrf_auxinput7in.o : wrf_auxinput7in.F
+wrf_auxinput7out.o : wrf_auxinput7out.F
+wrf_auxinput8in.o : wrf_auxinput8in.F
+wrf_auxinput8out.o : wrf_auxinput8out.F
+wrf_auxinput9in.o : wrf_auxinput9in.F
+wrf_auxinput9out.o : wrf_auxinput9out.F
+wrf_bdyin.o : wrf_bdyin.F
+wrf_bdyout.o : wrf_bdyout.F
+wrf_ext_read_field.o : wrf_ext_read_field.F
+wrf_ext_write_field.o : wrf_ext_write_field.F
+wrf_fddaobs_in.o : wrf_fddaobs_in.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_tsin.o : wrf_tsin.F
+nl_get_0_routines.o : nl_get_0_routines.F
+nl_get_1_routines.o : nl_get_1_routines.F
+nl_set_0_routines.o : nl_set_0_routines.F
+nl_set_1_routines.o : nl_set_1_routines.F
+
+convert_nmm.o \
+init_modules_em.o \
+module_comm_dm.o \
+module_dm.o \
+module_alloc_space.o \
+module_fddaobs_rtfdda.o \
+module_initialize.o \
+module_initialize_b_wave.o \
+module_initialize_hill2d_x.o \
+module_initialize_quarter_ss.o \
+module_initialize_real.o \
+module_initialize_squall2d_x.o \
+module_initialize_squall2d_y.o \
+module_integrate.o \
+module_io_mm5.o \
+module_io_wrf.o \
+module_si_io.o \
+module_tiles.o \
+output_wrf.o \
+solve_interface.o \
+start_domain.o \
+start_domain_nmm.o \
+start_em.o \
+wrf_fddaobs_in.o \
+wrf_tsin.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $*.f90
+
+# compile without OMP
+input_wrf.o \
+module_domain.o \
+module_domain_type.o \
+module_physics_init.o \
+module_io.o \
+wrf_auxhist10in.o \
+wrf_auxhist10out.o \
+wrf_auxhist11in.o \
+wrf_auxhist11out.o \
+wrf_auxhist1in.o \
+wrf_auxhist1out.o \
+wrf_auxhist2in.o \
+wrf_auxhist2out.o \
+wrf_auxhist3in.o \
+wrf_auxhist3out.o \
+wrf_auxhist4in.o \
+wrf_auxhist4out.o \
+wrf_auxhist5in.o \
+wrf_auxhist5out.o \
+wrf_auxhist6in.o \
+wrf_auxhist6out.o \
+wrf_auxhist7in.o \
+wrf_auxhist7out.o \
+wrf_auxhist8in.o \
+wrf_auxhist8out.o \
+wrf_auxhist9in.o \
+wrf_auxhist9out.o \
+wrf_auxinput10in.o \
+wrf_auxinput10out.o \
+wrf_auxinput11in.o \
+wrf_auxinput11out.o \
+wrf_auxinput1in.o \
+wrf_auxinput1out.o \
+wrf_auxinput2in.o \
+wrf_auxinput2out.o \
+wrf_auxinput3in.o \
+wrf_auxinput3out.o \
+wrf_auxinput4in.o \
+wrf_auxinput4out.o \
+wrf_auxinput5in.o \
+wrf_auxinput5out.o \
+wrf_auxinput6in.o \
+wrf_auxinput6out.o \
+wrf_auxinput7in.o \
+wrf_auxinput7out.o \
+wrf_auxinput8in.o \
+wrf_auxinput8out.o \
+wrf_auxinput9in.o \
+wrf_auxinput9out.o \
+wrf_bdyin.o \
+wrf_bdyout.o \
+wrf_ext_read_field.o \
+wrf_ext_write_field.o \
+wrf_histin.o \
+wrf_histout.o \
+wrf_inputin.o \
+wrf_inputout.o \
+wrf_restartin.o \
+wrf_restartout.o \
+module_state_description.o \
+nl_set_0_routines.o \
+nl_set_1_routines.o \
+nl_get_0_routines.o \
+nl_get_1_routines.o \
+module_configure.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCSUFFIX) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+
+###########################################################
+#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
+OMP             =       -Popenmp
+FC              =       sxmpif90
+LD              =       sxmpif90
+CC              =       sxmpic++
+SCC		=	sxmpic++
+SFC             =       sxmpif90
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	
+CFLAGS          =       -DNCARIBM_NOC99 -DDM_PARALLEL \
+                        -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC) -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE \
+                        -Xa -Kc99
+FCNOOPT         = -Cssafe
+FCOPTIM		=	
+FCDEBUG		=	#-g
+FCBASEOPTS      =       -Wf,-L fmtlist transform,-pvctl fullmsg loopcnt=1000000 -f4 -Wf,-P i
+FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ARCHFLAGS       =       $(COREDEFS) -DGRIB1 -DINTIO -DDM_PARALLEL \
+                        -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG \
+			$(DA_ARCHFLAGS) \
+			-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$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			-L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time
+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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P `cat $(WRF_SRC_ROOT_DIR)/inc/dm_comm_cpp_flags` $(ENVCOMPDEFS) $(POUND_DEF) -DNEC
+AR_BASE         =       sxar
+# it may be necessary to uncomment out the ru if ARFLAGS is not automatically defined to ru or rv in your installation's version of make
+AR              =       $(AR_BASE) # ru
+M4              =       m4 -B 14000
+RANLIB          =       sxar rs
+NETCDFPATH	=	CONFIGURE_NETCDF_PATH
+CC_TOOLS        =       cc
+SED_FTN = $(WRF_SRC_ROOT_DIR)/tools/standard.exe
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib1 wrfio_grib_share $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          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_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH="$(NETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" AR="$(AR_BASE)" )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" AR="$(AR_BASE)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" AR="$(AR_BASE)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CPP="$(CPP) $(CPPFLAGS)" CC="$(CC)" FC="$(FC) $(PROMOTION) $(FCBASEOPTS)" MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST AR="$(AR_BASE)" )
+
+# compile these without high optimization to speed compile
+convert_nmm.o : convert_nmm.F
+init_modules_em.o : init_modules_em.F
+input_wrf.o : input_wrf.F
+module_io.o : module_io.F
+module_comm_dm.o : module_comm_dm.F
+module_configure.o : module_configure.F
+module_dm.o : module_dm.F
+module_domain.o : module_domain.F
+module_domain_type.o : module_domain_type.F
+module_alloc_space.o : module_alloc_space.F
+module_tiles.o : module_tiles.F
+module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F
+module_initialize.o : module_initialize.F
+module_physics_init.o : module_physics_init.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_real.o : module_initialize_real.F
+module_initialize_real.o: module_initialize_real.F
+module_initialize_squall2d_x.o : module_initialize_squall2d_x.F
+module_initialize_squall2d_y.o : module_initialize_squall2d_y.F
+module_integrate.o : module_integrate.F
+module_io_mm5.o : module_io_mm5.F
+module_io_wrf.o : module_io_wrf.F
+module_si_io.o : module_si_io.F
+module_state_description.o : module_state_description.F 
+output_wrf.o : output_wrf.F
+solve_interface.o : solve_interface.F
+start_domain.o : start_domain.F
+start_domain_nmm.o : start_domain_nmm.F
+start_em.o : start_em.F
+wrf_auxhist10in.o : wrf_auxhist10in.F
+wrf_auxhist10out.o : wrf_auxhist10out.F
+wrf_auxhist11in.o : wrf_auxhist11in.F
+wrf_auxhist11out.o : wrf_auxhist11out.F
+wrf_auxhist1in.o : wrf_auxhist1in.F
+wrf_auxhist1out.o : wrf_auxhist1out.F
+wrf_auxhist2in.o : wrf_auxhist2in.F
+wrf_auxhist2out.o : wrf_auxhist2out.F
+wrf_auxhist3in.o : wrf_auxhist3in.F
+wrf_auxhist3out.o : wrf_auxhist3out.F
+wrf_auxhist4in.o : wrf_auxhist4in.F
+wrf_auxhist4out.o : wrf_auxhist4out.F
+wrf_auxhist5in.o : wrf_auxhist5in.F
+wrf_auxhist5out.o : wrf_auxhist5out.F
+wrf_auxhist6in.o : wrf_auxhist6in.F
+wrf_auxhist6out.o : wrf_auxhist6out.F
+wrf_auxhist7in.o : wrf_auxhist7in.F
+wrf_auxhist7out.o : wrf_auxhist7out.F
+wrf_auxhist8in.o : wrf_auxhist8in.F
+wrf_auxhist8out.o : wrf_auxhist8out.F
+wrf_auxhist9in.o : wrf_auxhist9in.F
+wrf_auxhist9out.o : wrf_auxhist9out.F
+wrf_auxinput10in.o : wrf_auxinput10in.F
+wrf_auxinput10out.o : wrf_auxinput10out.F
+wrf_auxinput11in.o : wrf_auxinput11in.F
+wrf_auxinput11out.o : wrf_auxinput11out.F
+wrf_auxinput1in.o : wrf_auxinput1in.F
+wrf_auxinput1out.o : wrf_auxinput1out.F
+wrf_auxinput2in.o : wrf_auxinput2in.F
+wrf_auxinput2out.o : wrf_auxinput2out.F
+wrf_auxinput3in.o : wrf_auxinput3in.F
+wrf_auxinput3out.o : wrf_auxinput3out.F
+wrf_auxinput4in.o : wrf_auxinput4in.F
+wrf_auxinput4out.o : wrf_auxinput4out.F
+wrf_auxinput5in.o : wrf_auxinput5in.F
+wrf_auxinput5out.o : wrf_auxinput5out.F
+wrf_auxinput6in.o : wrf_auxinput6in.F
+wrf_auxinput6out.o : wrf_auxinput6out.F
+wrf_auxinput7in.o : wrf_auxinput7in.F
+wrf_auxinput7out.o : wrf_auxinput7out.F
+wrf_auxinput8in.o : wrf_auxinput8in.F
+wrf_auxinput8out.o : wrf_auxinput8out.F
+wrf_auxinput9in.o : wrf_auxinput9in.F
+wrf_auxinput9out.o : wrf_auxinput9out.F
+wrf_bdyin.o : wrf_bdyin.F
+wrf_bdyout.o : wrf_bdyout.F
+wrf_ext_read_field.o : wrf_ext_read_field.F
+wrf_ext_write_field.o : wrf_ext_write_field.F
+wrf_fddaobs_in.o : wrf_fddaobs_in.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_tsin.o : wrf_tsin.F
+nl_get_0_routines.o : nl_get_0_routines.F
+nl_get_1_routines.o : nl_get_1_routines.F
+nl_set_0_routines.o : nl_set_0_routines.F
+nl_set_1_routines.o : nl_set_1_routines.F
+
+convert_nmm.o \
+init_modules_em.o \
+module_comm_dm.o \
+module_dm.o \
+module_alloc_space.o \
+module_fddaobs_rtfdda.o \
+module_initialize.o \
+module_initialize_b_wave.o \
+module_initialize_hill2d_x.o \
+module_initialize_quarter_ss.o \
+module_initialize_real.o \
+module_initialize_squall2d_x.o \
+module_initialize_squall2d_y.o \
+module_integrate.o \
+module_io_mm5.o \
+module_io_wrf.o \
+module_si_io.o \
+module_tiles.o \
+output_wrf.o \
+solve_interface.o \
+start_domain.o \
+start_domain_nmm.o \
+start_em.o \
+wrf_fddaobs_in.o \
+wrf_tsin.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $*.f90
+
+# compile without OMP
+input_wrf.o \
+module_domain.o \
+module_domain_type.o \
+module_physics_init.o \
+module_io.o \
+wrf_auxhist10in.o \
+wrf_auxhist10out.o \
+wrf_auxhist11in.o \
+wrf_auxhist11out.o \
+wrf_auxhist1in.o \
+wrf_auxhist1out.o \
+wrf_auxhist2in.o \
+wrf_auxhist2out.o \
+wrf_auxhist3in.o \
+wrf_auxhist3out.o \
+wrf_auxhist4in.o \
+wrf_auxhist4out.o \
+wrf_auxhist5in.o \
+wrf_auxhist5out.o \
+wrf_auxhist6in.o \
+wrf_auxhist6out.o \
+wrf_auxhist7in.o \
+wrf_auxhist7out.o \
+wrf_auxhist8in.o \
+wrf_auxhist8out.o \
+wrf_auxhist9in.o \
+wrf_auxhist9out.o \
+wrf_auxinput10in.o \
+wrf_auxinput10out.o \
+wrf_auxinput11in.o \
+wrf_auxinput11out.o \
+wrf_auxinput1in.o \
+wrf_auxinput1out.o \
+wrf_auxinput2in.o \
+wrf_auxinput2out.o \
+wrf_auxinput3in.o \
+wrf_auxinput3out.o \
+wrf_auxinput4in.o \
+wrf_auxinput4out.o \
+wrf_auxinput5in.o \
+wrf_auxinput5out.o \
+wrf_auxinput6in.o \
+wrf_auxinput6out.o \
+wrf_auxinput7in.o \
+wrf_auxinput7out.o \
+wrf_auxinput8in.o \
+wrf_auxinput8out.o \
+wrf_auxinput9in.o \
+wrf_auxinput9out.o \
+wrf_bdyin.o \
+wrf_bdyout.o \
+wrf_ext_read_field.o \
+wrf_ext_write_field.o \
+wrf_histin.o \
+wrf_histout.o \
+wrf_inputin.o \
+wrf_inputout.o \
+wrf_restartin.o \
+wrf_restartout.o \
+module_state_description.o \
+nl_set_0_routines.o \
+nl_set_1_routines.o \
+nl_get_0_routines.o \
+nl_get_1_routines.o \
+module_configure.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCSUFFIX) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+
+
+###########################################################
+#ARCH    CYGWIN_NT-5.1 Cygwin i486 i586 i686, g95 compiler  (Single-threaded, no nesting)
+#
+FC              =       g95
+LD              =       g95
+CC              =       gcc
+SCC		=	$(CC)
+RWORDSIZE       =       CONFIGURE_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 \
+			$(DA_ARCHFLAGS) \
+                         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=$(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc
+PERL            =       perl
+REGISTRY        =       Registry
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                        CONFIGURE_GRIB2_LIB \
+                        -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+			$(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o -L$(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 fftpack
+
+module_dm.F :
+	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make NETCDFPATH=CONFIGURE_NETCDF_PATH RANLIB="$(RANLIB)" CPP="$(CPP)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/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="-ffixed-form" archive )
+
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+# 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+
+###########################################################
+#ARCH    PC Interix x86_64 (IA64 and Opteron), PGI 5.2 or higher DM-Parallel   (RSL_LITE, MPICH, 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.exe
+LD              =       $(FC)
+CC              =       pgcc.exe
+CC              =       cc
+SCC		=	$(CC)
+SFC             =       $(FC)
+
+MPdir           =       /dev/fs/C/Program Files/Microsoft Compute Cluster Pack
+MPinc           =       -I'$(MPdir)'/Include
+MSMPdir         =       'C:\Program Files\Microsoft Compute Cluster Pack'
+MSMPinc         =       /I'C:\Program Files\Microsoft Compute Cluster Pack\Include'
+MSMPlib         =       'C:\Program Files\Microsoft Compute Cluster Pack\Lib\AMD64\msmpi.lib'
+
+RWORDSIZE       =       CONFIGURE_RWORDSIZE
+PROMOTION	=	-r$(RWORDSIZE) -i4
+
+CFLAGS          =       -DLANDREAD_STUB -DMEMCPY_FOR_BCOPY -DMS_SUA -DDM_PARALLEL \
+                        -I$(WRF_SRC_ROOT_DIR)/external/RSL_LITE $(MPinc) #-X /MD
+FCOPTIM         =       -fastsse #-Mipa=fast
+FCDEBUG		=	#-g
+#FCBASEOPTS      =       -w -byteswapio -Ktrap=fp -Mfree $(FCDEBUG)
+FCBASEOPTS      =       -w -byteswapio -Mfree $(FCDEBUG)
+FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS) $(MPinc)
+
+ARCHFLAGS       =       $(COREDEFS) \
+                        -DDM_PARALLEL \
+                        -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+			$(DA_ARCHFLAGS) \
+                        -DNETCDF -DINTIO \
+                        -DNO_NAMELIST_PRINT  \
+                        -DLIMIT_ARGS -DLANDREAD_STUB -DNMM_NEST=$(WRF_NMM_NEST) -DMEMCPY_FOR_BCOPY
+
+# 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 $(WRF_SRC_ROOT_DIR)/main -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf -I$(WRF_SRC_ROOT_DIR)/external/io_int -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                        -I$(WRF_SRC_ROOT_DIR)/external -I$(WRF_SRC_ROOT_DIR)/frame -I$(WRF_SRC_ROOT_DIR)/share -I$(WRF_SRC_ROOT_DIR)/phys -I$(WRF_SRC_ROOT_DIR)/inc -I$(WRF_SRC_ROOT_DIR)/chem
+PERL            =       perl
+REGISTRY        =       Registry
+
+LIB             =       CONFIGURE_NETCDF_LIB_PATH \
+                        $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5/libfftpack.a \
+			$(WRF_SRC_ROOT_DIR)/external/io_int/libwrfio_int.a \
+                        $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o \
+                        $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90/libesmf_time.a \
+                        $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a $(MSMPlib) \
+                        "c:\Program Files\Microsoft Platform SDK for Windows Server 2003 R2\Lib\AMD64\bufferoverflowu.lib"
+
+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$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -C -P $(ENVCOMPDEFS) $(POUND_DEF)
+AR              =       ar r
+M4              =       NA
+RANLIB          =       ranlib
+NETCDFPATH	=	CONFIGURE_NETCDF_PATH
+CC_TOOLS        =       cc
+LIBWRFLIB       =       libwrflib.a
+
+externals : wrf_ioapi_includes CONFIGURE_WRFIO_NF wrfio_grib_share wrfio_grib1 CONFIGURE_WRFIO_GRIB2 $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a wrfio_int gen_comms.c module_dm.F esmf_time fftpack
+
+gen_comms.c : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c
+	( /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm.F : $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F
+	( /bin/cp module_dm_warning module_dm.F ; cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F )
+
+wrfio_nf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+	  make LIBS="libwrfio_nf.a 'CONFIGURE_NETCDF_PATH' 'c:\Program Files\Microsoft Platform SDK\Lib\AMD64\bufferoverflowu.lib'" \
+              NETCDFPATH=CONFIGURE_NETCDF_PATH \
+              RANLIB="$(RANLIB)" CPP="$(CPP) -DMS_SUA" \
+              CPP1="$(CPP) -DMS_SUA"  \
+              FC="$(FC) $(PROMOTION) $(FCFLAGS) -w" TRADFLAG="-traditional" )
+
+wrfio_grib_share :
+
+wrfio_grib1 :
+
+wrfio_grib2 :
+
+wrfio_int :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+	  make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(POUND_DEF)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; \
+          /bin/sed -e '/MPI_ADDRESS_KIND=4/d' -e '/DEC\$$/d' '$(MPdir)'/Include/mpif.h > mpif.h ; \
+          make CPP="$(CPP) $(CPPFLAGS)" CC="$(CC)" CFLAGS="$(CFLAGS)" FC="$(FC) $(PROMOTION) $(FCFLAGS) -byteswapio" 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
+module_comm_dm.o : module_comm_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 module_comm_dm.o start_domain.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -o $*.o -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+module_io.o : module_io.F
+module_dm.o : module_dm.F
+
+module_io.o module_dm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	/bin/sed -e '/MPI_ADDRESS_KIND=4/d' -e '/DEC\$$/d' '$(MPdir)'/Include/mpif.h > mpif.h
+	$(FC) -o $*.o -c $(PROMOTION) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
+
+
+##################################################################
+#ARCH  NULL
Index: branches/LMDZ_WRFmeas/WRFV3/arch/cray_csd.sed
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/cray_csd.sed	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/cray_csd.sed	(revision 17)
@@ -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)
Index: branches/LMDZ_WRFmeas/WRFV3/arch/md_calls.inc
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/md_calls.inc	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/md_calls.inc	(revision 17)
@@ -0,0 +1,12389 @@
+! This is a non-autogenerated version of md_calls.inc for Windows and other
+! versions of OS's that either dont have M4 or whose M4s dont work right.
+
+INTERFACE wrf_get_dom_ti_real
+  MODULE PROCEDURE wrf_get_dom_ti_real_arr, wrf_get_dom_ti_real_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_dom_ti_real
+  MODULE PROCEDURE wrf_put_dom_ti_real_arr, wrf_put_dom_ti_real_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_dom_ti_double
+  MODULE PROCEDURE wrf_get_dom_ti_double_arr, wrf_get_dom_ti_double_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_dom_ti_double
+  MODULE PROCEDURE wrf_put_dom_ti_double_arr, wrf_put_dom_ti_double_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_dom_ti_integer
+  MODULE PROCEDURE wrf_get_dom_ti_integer_arr, wrf_get_dom_ti_integer_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_dom_ti_integer
+  MODULE PROCEDURE wrf_put_dom_ti_integer_arr, wrf_put_dom_ti_integer_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_dom_ti_logical
+  MODULE PROCEDURE wrf_get_dom_ti_logical_arr, wrf_get_dom_ti_logical_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_dom_ti_logical
+  MODULE PROCEDURE wrf_put_dom_ti_logical_arr, wrf_put_dom_ti_logical_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_dom_ti_char
+  MODULE PROCEDURE wrf_get_dom_ti_char_arr
+END INTERFACE
+
+
+INTERFACE wrf_put_dom_ti_char
+  MODULE PROCEDURE wrf_put_dom_ti_char_arr
+END INTERFACE
+
+
+
+INTERFACE wrf_get_dom_td_real
+  MODULE PROCEDURE wrf_get_dom_td_real_arr, wrf_get_dom_td_real_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_dom_td_real
+  MODULE PROCEDURE wrf_put_dom_td_real_arr, wrf_put_dom_td_real_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_dom_td_double
+  MODULE PROCEDURE wrf_get_dom_td_double_arr, wrf_get_dom_td_double_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_dom_td_double
+  MODULE PROCEDURE wrf_put_dom_td_double_arr, wrf_put_dom_td_double_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_dom_td_integer
+  MODULE PROCEDURE wrf_get_dom_td_integer_arr, wrf_get_dom_td_integer_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_dom_td_integer
+  MODULE PROCEDURE wrf_put_dom_td_integer_arr, wrf_put_dom_td_integer_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_dom_td_logical
+  MODULE PROCEDURE wrf_get_dom_td_logical_arr, wrf_get_dom_td_logical_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_dom_td_logical
+  MODULE PROCEDURE wrf_put_dom_td_logical_arr, wrf_put_dom_td_logical_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_dom_td_char
+  MODULE PROCEDURE wrf_get_dom_td_char_arr
+END INTERFACE
+
+
+INTERFACE wrf_put_dom_td_char
+  MODULE PROCEDURE wrf_put_dom_td_char_arr
+END INTERFACE
+
+
+
+INTERFACE wrf_get_var_ti_real
+  MODULE PROCEDURE wrf_get_var_ti_real_arr, wrf_get_var_ti_real_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_var_ti_real
+  MODULE PROCEDURE wrf_put_var_ti_real_arr, wrf_put_var_ti_real_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_var_ti_double
+  MODULE PROCEDURE wrf_get_var_ti_double_arr, wrf_get_var_ti_double_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_var_ti_double
+  MODULE PROCEDURE wrf_put_var_ti_double_arr, wrf_put_var_ti_double_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_var_ti_integer
+  MODULE PROCEDURE wrf_get_var_ti_integer_arr, wrf_get_var_ti_integer_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_var_ti_integer
+  MODULE PROCEDURE wrf_put_var_ti_integer_arr, wrf_put_var_ti_integer_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_var_ti_logical
+  MODULE PROCEDURE wrf_get_var_ti_logical_arr, wrf_get_var_ti_logical_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_var_ti_logical
+  MODULE PROCEDURE wrf_put_var_ti_logical_arr, wrf_put_var_ti_logical_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_var_ti_char
+  MODULE PROCEDURE wrf_get_var_ti_char_arr
+END INTERFACE
+
+
+INTERFACE wrf_put_var_ti_char
+  MODULE PROCEDURE wrf_put_var_ti_char_arr
+END INTERFACE
+
+
+
+INTERFACE wrf_get_var_td_real
+  MODULE PROCEDURE wrf_get_var_td_real_arr, wrf_get_var_td_real_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_var_td_real
+  MODULE PROCEDURE wrf_put_var_td_real_arr, wrf_put_var_td_real_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_var_td_double
+  MODULE PROCEDURE wrf_get_var_td_double_arr, wrf_get_var_td_double_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_var_td_double
+  MODULE PROCEDURE wrf_put_var_td_double_arr, wrf_put_var_td_double_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_var_td_integer
+  MODULE PROCEDURE wrf_get_var_td_integer_arr, wrf_get_var_td_integer_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_var_td_integer
+  MODULE PROCEDURE wrf_put_var_td_integer_arr, wrf_put_var_td_integer_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_var_td_logical
+  MODULE PROCEDURE wrf_get_var_td_logical_arr, wrf_get_var_td_logical_sca
+END INTERFACE
+
+
+INTERFACE wrf_put_var_td_logical
+  MODULE PROCEDURE wrf_put_var_td_logical_arr, wrf_put_var_td_logical_sca
+END INTERFACE
+
+
+INTERFACE wrf_get_var_td_char
+  MODULE PROCEDURE wrf_get_var_td_char_arr
+END INTERFACE
+
+
+INTERFACE wrf_put_var_td_char
+  MODULE PROCEDURE wrf_put_var_td_char_arr
+END INTERFACE
+
+
+
+CONTAINS
+
+!--- get_dom_ti_real
+
+SUBROUTINE wrf_get_dom_ti_real_arr ( DataHandle,Element,   Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ real  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_ti_real_arr " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_ncd_get_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_pnc_get_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_phdf5_get_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_esmf_get_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_xxx_get_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_yyy_get_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr1_get_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr2_get_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_int_get_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+           
+           
+           
+           
+           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_get_dom_ti_real ( Hndl, Element,   Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_ti_real_arr 
+!--- get_dom_ti_real
+
+SUBROUTINE wrf_get_dom_ti_real_sca ( DataHandle,Element,   Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read time independent
+! domain metadata named "Element"  
+! from the open dataset described by DataHandle.  
+! Metadata of type real are
+! stored in scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ real  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_ti_real_sca " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_ncd_get_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_pnc_get_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_phdf5_get_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_esmf_get_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_xxx_get_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_yyy_get_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr1_get_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr2_get_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_int_get_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+           
+           
+           
+           
+           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_get_dom_ti_real ( Hndl, Element,   Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_ti_real_sca 
+
+
+!--- put_dom_ti_real
+
+SUBROUTINE wrf_put_dom_ti_real_arr ( DataHandle,Element,   Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ real  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_ti_real_arr " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_ncd_put_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_pnc_put_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_phdf5_put_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_esmf_put_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_xxx_put_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_yyy_put_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr1_put_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr2_put_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_int_put_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_ti_real ( Hndl, Element,   Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_ti_real_arr 
+!--- put_dom_ti_real
+
+SUBROUTINE wrf_put_dom_ti_real_sca ( DataHandle,Element,   Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time independent
+! domain metadata named "Element"  
+! to the open dataset described by DataHandle.  
+! Metadata of type real are
+! copied from scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ real  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_ti_real_sca " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_ncd_put_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_pnc_put_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_phdf5_put_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_esmf_put_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_xxx_put_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_yyy_put_dom_ti_real ( Hndl, Element,   Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr1_put_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr2_put_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_int_put_dom_ti_real ( Hndl, Element,   Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_ti_real ( Hndl, Element,   Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_ti_real_sca 
+
+
+!--- get_dom_ti_double
+
+SUBROUTINE wrf_get_dom_ti_double_arr ( DataHandle,Element,   Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ real*8  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_ti_double_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_get_dom_ti_double ( Hndl, Element,   Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_ti_double_arr 
+!--- get_dom_ti_double
+
+SUBROUTINE wrf_get_dom_ti_double_sca ( DataHandle,Element,   Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read time independent
+! domain metadata named "Element"  
+! from the open dataset described by DataHandle.  
+! Metadata of type double are
+! stored in scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ real*8  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_ti_double_sca " )
+
+
+
+
+
+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
+           CALL ext_ncd_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_get_dom_ti_double ( Hndl, Element,   Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_ti_double_sca 
+
+
+!--- put_dom_ti_double
+
+SUBROUTINE wrf_put_dom_ti_double_arr ( DataHandle,Element,   Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ real*8  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_ti_double_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_ti_double ( Hndl, Element,   Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_ti_double_arr 
+!--- put_dom_ti_double
+
+SUBROUTINE wrf_put_dom_ti_double_sca ( DataHandle,Element,   Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time independent
+! domain metadata named "Element"  
+! to the open dataset described by DataHandle.  
+! Metadata of type double are
+! copied from scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ real*8  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_ti_double_sca " )
+
+
+
+
+
+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
+           CALL ext_ncd_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_ti_double ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_ti_double ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_ti_double ( Hndl, Element,   Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_ti_double_sca 
+
+
+!--- get_dom_ti_integer
+
+SUBROUTINE wrf_get_dom_ti_integer_arr ( DataHandle,Element,   Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ integer  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_ti_integer_arr " )
+
+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
+           CALL ext_ncd_get_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+           
+           
+           
+           
+           
+           
+           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_get_dom_ti_integer ( Hndl, Element,   Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_ti_integer_arr 
+!--- get_dom_ti_integer
+
+SUBROUTINE wrf_get_dom_ti_integer_sca ( DataHandle,Element,   Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read time independent
+! domain metadata named "Element"  
+! from the open dataset described by DataHandle.  
+! Metadata of type integer are
+! stored in scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ integer  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_ti_integer_sca " )
+
+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
+           CALL ext_ncd_get_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+           
+           
+           
+           
+           
+           
+           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_get_dom_ti_integer ( Hndl, Element,   Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_ti_integer_sca 
+
+
+!--- put_dom_ti_integer
+
+SUBROUTINE wrf_put_dom_ti_integer_arr ( DataHandle,Element,   Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ integer  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_ti_integer_arr " )
+
+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
+           CALL ext_ncd_put_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_ti_integer ( Hndl, Element,   Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_ti_integer_arr 
+!--- put_dom_ti_integer
+
+SUBROUTINE wrf_put_dom_ti_integer_sca ( DataHandle,Element,   Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time independent
+! domain metadata named "Element"  
+! to the open dataset described by DataHandle.  
+! Metadata of type integer are
+! copied from scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ integer  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_ti_integer_sca " )
+
+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
+           CALL ext_ncd_put_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_ti_integer ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_ti_integer ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_ti_integer ( Hndl, Element,   Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_ti_integer_sca 
+
+
+!--- get_dom_ti_logical
+
+SUBROUTINE wrf_get_dom_ti_logical_arr ( DataHandle,Element,   Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ logical  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_ti_logical_arr " )
+
+
+
+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
+           CALL ext_ncd_get_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_gr2_get_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_int_get_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+           
+           
+           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_get_dom_ti_logical ( Hndl, Element,   Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_ti_logical_arr 
+!--- get_dom_ti_logical
+
+SUBROUTINE wrf_get_dom_ti_logical_sca ( DataHandle,Element,   Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read time independent
+! domain metadata named "Element"  
+! from the open dataset described by DataHandle.  
+! Metadata of type logical are
+! stored in scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ logical  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_ti_logical_sca " )
+
+
+
+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
+           CALL ext_ncd_get_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_gr2_get_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_int_get_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+           
+           
+           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_get_dom_ti_logical ( Hndl, Element,   Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_ti_logical_sca 
+
+
+!--- put_dom_ti_logical
+
+SUBROUTINE wrf_put_dom_ti_logical_arr ( DataHandle,Element,   Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ logical  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_ti_logical_arr " )
+
+
+
+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
+           CALL ext_ncd_put_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_ti_logical ( Hndl, Element,   Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_ti_logical_arr 
+!--- put_dom_ti_logical
+
+SUBROUTINE wrf_put_dom_ti_logical_sca ( DataHandle,Element,   Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time independent
+! domain metadata named "Element"  
+! to the open dataset described by DataHandle.  
+! Metadata of type logical are
+! copied from scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ logical  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_ti_logical_sca " )
+
+
+
+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
+           CALL ext_ncd_put_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_ti_logical ( Hndl, Element,   Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_ti_logical ( Hndl, Element,   Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_ti_logical ( Hndl, Element,   Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_ti_logical_sca 
+
+
+!--- get_dom_ti_char
+
+SUBROUTINE wrf_get_dom_ti_char_arr ( DataHandle,Element,   Data,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ CHARACTER*(*)  :: Data
+
+
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_ti_char_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_get_dom_ti_char ( Hndl, Element,   Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          len_of_str = LEN(Data)
+          CALL wrf_dm_bcast_string( Data, len_of_str )
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_ti_char ( Hndl, Element,   Data, &
+                               Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_ti_char ( Hndl, Element,   Data, &
+                               Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_ti_char ( Hndl, Element,   Data, &
+                               Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_ti_char ( Hndl, Element,   Data, &
+                               Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_ti_char ( Hndl, Element,   Data, &
+                               Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_ti_char ( Hndl, Element,   Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          len_of_str = LEN(Data)
+          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
+           CALL ext_gr2_get_dom_ti_char ( Hndl, Element,   Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          len_of_str = LEN(Data)
+          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
+           CALL ext_int_get_dom_ti_char ( Hndl, Element,   Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           len_of_str = LEN(Data)
+           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_get_dom_ti_char ( Hndl, Element,   Data, &
+                           Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_ti_char_arr 
+
+
+!--- put_dom_ti_char
+
+SUBROUTINE wrf_put_dom_ti_char_arr ( DataHandle,Element,   Data,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time independent
+! domain metadata named "Element"  
+! to the open dataset described by DataHandle.  
+! Metadata of type char are
+! copied from string Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+ 
+
+ CHARACTER*(*)  :: Data
+
+
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_ti_char_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_put_dom_ti_char ( Hndl, Element,   Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_ti_char ( Hndl, Element,   Data, &
+                               Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_ti_char ( Hndl, Element,   Data, &
+                               Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_ti_char ( Hndl, Element,   Data, &
+                               Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_ti_char ( Hndl, Element,   Data, &
+                               Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_ti_char ( Hndl, Element,   Data, &
+                               Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_ti_char ( Hndl, Element,   Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_ti_char ( Hndl, Element,   Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_ti_char ( Hndl, Element,   Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_ti_char ( Hndl, Element,   Data, &
+                           Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_ti_char_arr 
+
+
+
+!--- get_dom_td_real
+
+SUBROUTINE wrf_get_dom_td_real_arr ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ real  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_td_real_arr " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_ncd_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_pnc_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_phdf5_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_esmf_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_xxx_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_yyy_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr1_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr2_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_int_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+           
+           
+           
+           
+           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_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_td_real_arr 
+!--- get_dom_td_real
+
+SUBROUTINE wrf_get_dom_td_real_sca ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read time dependent
+! domain metadata named "Element" valid at time DateStr 
+! from the open dataset described by DataHandle.  
+! Metadata of type real are
+! stored in scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ real  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_td_real_sca " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_ncd_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_pnc_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_phdf5_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_esmf_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_xxx_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_yyy_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr1_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr2_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_int_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+           
+           
+           
+           
+           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_get_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_td_real_sca 
+
+
+!--- put_dom_td_real
+
+SUBROUTINE wrf_put_dom_td_real_arr ( DataHandle,Element, DateStr,  Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ real  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_td_real_arr " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_ncd_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_pnc_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_phdf5_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_esmf_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_xxx_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_yyy_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr1_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr2_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_int_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_td_real_arr 
+!--- put_dom_td_real
+
+SUBROUTINE wrf_put_dom_td_real_sca ( DataHandle,Element, DateStr,  Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time dependent
+! domain metadata named "Element" valid at time DateStr 
+! to the open dataset described by DataHandle.  
+! Metadata of type real are
+! copied from scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ real  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_td_real_sca " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_ncd_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_pnc_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_phdf5_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_esmf_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_xxx_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_yyy_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr1_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr2_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_int_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_td_real ( Hndl, Element, DateStr,  Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_td_real_sca 
+
+
+!--- get_dom_td_double
+
+SUBROUTINE wrf_get_dom_td_double_arr ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ real*8  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_td_double_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_td_double_arr 
+!--- get_dom_td_double
+
+SUBROUTINE wrf_get_dom_td_double_sca ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read time dependent
+! domain metadata named "Element" valid at time DateStr 
+! from the open dataset described by DataHandle.  
+! Metadata of type double are
+! stored in scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ real*8  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_td_double_sca " )
+
+
+
+
+
+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
+           CALL ext_ncd_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_get_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_td_double_sca 
+
+
+!--- put_dom_td_double
+
+SUBROUTINE wrf_put_dom_td_double_arr ( DataHandle,Element, DateStr,  Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ real*8  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_td_double_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_td_double_arr 
+!--- put_dom_td_double
+
+SUBROUTINE wrf_put_dom_td_double_sca ( DataHandle,Element, DateStr,  Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time dependent
+! domain metadata named "Element" valid at time DateStr 
+! to the open dataset described by DataHandle.  
+! Metadata of type double are
+! copied from scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ real*8  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_td_double_sca " )
+
+
+
+
+
+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
+           CALL ext_ncd_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_td_double ( Hndl, Element, DateStr,  Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_td_double_sca 
+
+
+!--- get_dom_td_integer
+
+SUBROUTINE wrf_get_dom_td_integer_arr ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ integer  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_td_integer_arr " )
+
+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
+           CALL ext_ncd_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+           
+           
+           
+           
+           
+           
+           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_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_td_integer_arr 
+!--- get_dom_td_integer
+
+SUBROUTINE wrf_get_dom_td_integer_sca ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read time dependent
+! domain metadata named "Element" valid at time DateStr 
+! from the open dataset described by DataHandle.  
+! Metadata of type integer are
+! stored in scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ integer  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_td_integer_sca " )
+
+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
+           CALL ext_ncd_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+           
+           
+           
+           
+           
+           
+           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_get_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_td_integer_sca 
+
+
+!--- put_dom_td_integer
+
+SUBROUTINE wrf_put_dom_td_integer_arr ( DataHandle,Element, DateStr,  Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ integer  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_td_integer_arr " )
+
+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
+           CALL ext_ncd_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_td_integer_arr 
+!--- put_dom_td_integer
+
+SUBROUTINE wrf_put_dom_td_integer_sca ( DataHandle,Element, DateStr,  Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time dependent
+! domain metadata named "Element" valid at time DateStr 
+! to the open dataset described by DataHandle.  
+! Metadata of type integer are
+! copied from scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ integer  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_td_integer_sca " )
+
+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
+           CALL ext_ncd_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_td_integer ( Hndl, Element, DateStr,  Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_td_integer_sca 
+
+
+!--- get_dom_td_logical
+
+SUBROUTINE wrf_get_dom_td_logical_arr ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ logical  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_td_logical_arr " )
+
+
+
+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
+           CALL ext_ncd_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_gr2_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_int_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+           
+           
+           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_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_td_logical_arr 
+!--- get_dom_td_logical
+
+SUBROUTINE wrf_get_dom_td_logical_sca ( DataHandle,Element, DateStr,  Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read time dependent
+! domain metadata named "Element" valid at time DateStr 
+! from the open dataset described by DataHandle.  
+! Metadata of type logical are
+! stored in scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ logical  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_td_logical_sca " )
+
+
+
+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
+           CALL ext_ncd_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_gr2_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_int_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+           
+           
+           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_get_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_td_logical_sca 
+
+
+!--- put_dom_td_logical
+
+SUBROUTINE wrf_put_dom_td_logical_arr ( DataHandle,Element, DateStr,  Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ logical  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_td_logical_arr " )
+
+
+
+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
+           CALL ext_ncd_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_td_logical_arr 
+!--- put_dom_td_logical
+
+SUBROUTINE wrf_put_dom_td_logical_sca ( DataHandle,Element, DateStr,  Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time dependent
+! domain metadata named "Element" valid at time DateStr 
+! to the open dataset described by DataHandle.  
+! Metadata of type logical are
+! copied from scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ logical  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_td_logical_sca " )
+
+
+
+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
+           CALL ext_ncd_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_td_logical ( Hndl, Element, DateStr,  Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_td_logical_sca 
+
+
+!--- get_dom_td_char
+
+SUBROUTINE wrf_get_dom_td_char_arr ( DataHandle,Element, DateStr,  Data,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ CHARACTER*(*)  :: Data
+
+
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_dom_td_char_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_get_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          len_of_str = LEN(Data)
+          CALL wrf_dm_bcast_string( Data, len_of_str )
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                               Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                               Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                               Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                               Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                               Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          len_of_str = LEN(Data)
+          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
+           CALL ext_gr2_get_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          len_of_str = LEN(Data)
+          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
+           CALL ext_int_get_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           len_of_str = LEN(Data)
+           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_get_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                           Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_dom_td_char_arr 
+
+
+!--- put_dom_td_char
+
+SUBROUTINE wrf_put_dom_td_char_arr ( DataHandle,Element, DateStr,  Data,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+ 
+
+ CHARACTER*(*)  :: Data
+
+
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_dom_td_char_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_put_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                               Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                               Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                               Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                               Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                               Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_dom_td_char ( Hndl, Element, DateStr,  Data, &
+                           Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_dom_td_char_arr 
+
+
+
+!--- get_var_ti_real
+
+SUBROUTINE wrf_get_var_ti_real_arr ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ real  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_ti_real_arr " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_ncd_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_pnc_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_phdf5_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_esmf_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_xxx_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_yyy_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr1_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr2_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_int_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+           
+           
+           
+           
+           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_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_ti_real_arr 
+!--- get_var_ti_real
+
+SUBROUTINE wrf_get_var_ti_real_sca ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read time independent
+! attribute "Element" of variable "Varname"  
+! from the open dataset described by DataHandle.  
+! Attribute of type real is
+! stored in scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ real  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_ti_real_sca " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_ncd_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_pnc_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_phdf5_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_esmf_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_xxx_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_yyy_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr1_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr2_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_int_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+           
+           
+           
+           
+           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_get_var_ti_real ( Hndl, Element,  Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_ti_real_sca 
+
+
+!--- put_var_ti_real
+
+SUBROUTINE wrf_put_var_ti_real_arr ( DataHandle,Element,  Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ real  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_ti_real_arr " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_ncd_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_pnc_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_phdf5_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_esmf_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_xxx_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_yyy_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr1_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr2_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_int_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_ti_real_arr 
+!--- put_var_ti_real
+
+SUBROUTINE wrf_put_var_ti_real_sca ( DataHandle,Element,  Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time independent
+! attribute "Element" of variable "Varname"  
+! to the open dataset described by DataHandle.  
+! Attribute of type real is
+! copied from scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ real  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_ti_real_sca " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_ncd_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_pnc_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_phdf5_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_esmf_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_xxx_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_yyy_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr1_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr2_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_int_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_ti_real ( Hndl, Element,  Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_ti_real_sca 
+
+
+!--- get_var_ti_double
+
+SUBROUTINE wrf_get_var_ti_double_arr ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ real*8  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_ti_double_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_ti_double_arr 
+!--- get_var_ti_double
+
+SUBROUTINE wrf_get_var_ti_double_sca ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read time independent
+! attribute "Element" of variable "Varname"  
+! from the open dataset described by DataHandle.  
+! Attribute of type double is
+! stored in scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ real*8  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_ti_double_sca " )
+
+
+
+
+
+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
+           CALL ext_ncd_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_get_var_ti_double ( Hndl, Element,  Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_ti_double_sca 
+
+
+!--- put_var_ti_double
+
+SUBROUTINE wrf_put_var_ti_double_arr ( DataHandle,Element,  Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ real*8  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_ti_double_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_ti_double_arr 
+!--- put_var_ti_double
+
+SUBROUTINE wrf_put_var_ti_double_sca ( DataHandle,Element,  Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time independent
+! attribute "Element" of variable "Varname"  
+! to the open dataset described by DataHandle.  
+! Attribute of type double is
+! copied from scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ real*8  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_ti_double_sca " )
+
+
+
+
+
+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
+           CALL ext_ncd_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_ti_double ( Hndl, Element,  Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_ti_double_sca 
+
+
+!--- get_var_ti_integer
+
+SUBROUTINE wrf_get_var_ti_integer_arr ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ integer  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_ti_integer_arr " )
+
+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
+           CALL ext_ncd_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+           
+           
+           
+           
+           
+           
+           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_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_ti_integer_arr 
+!--- get_var_ti_integer
+
+SUBROUTINE wrf_get_var_ti_integer_sca ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read time independent
+! attribute "Element" of variable "Varname"  
+! from the open dataset described by DataHandle.  
+! Attribute of type integer is
+! stored in scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ integer  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_ti_integer_sca " )
+
+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
+           CALL ext_ncd_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+           
+           
+           
+           
+           
+           
+           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_get_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_ti_integer_sca 
+
+
+!--- put_var_ti_integer
+
+SUBROUTINE wrf_put_var_ti_integer_arr ( DataHandle,Element,  Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ integer  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_ti_integer_arr " )
+
+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
+           CALL ext_ncd_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_ti_integer_arr 
+!--- put_var_ti_integer
+
+SUBROUTINE wrf_put_var_ti_integer_sca ( DataHandle,Element,  Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time independent
+! attribute "Element" of variable "Varname"  
+! to the open dataset described by DataHandle.  
+! Attribute of type integer is
+! copied from scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ integer  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_ti_integer_sca " )
+
+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
+           CALL ext_ncd_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_ti_integer ( Hndl, Element,  Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_ti_integer_sca 
+
+
+!--- get_var_ti_logical
+
+SUBROUTINE wrf_get_var_ti_logical_arr ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ logical  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_ti_logical_arr " )
+
+
+
+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
+           CALL ext_ncd_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_gr2_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_int_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+           
+           
+           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_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_ti_logical_arr 
+!--- get_var_ti_logical
+
+SUBROUTINE wrf_get_var_ti_logical_sca ( DataHandle,Element,  Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read time independent
+! attribute "Element" of variable "Varname"  
+! from the open dataset described by DataHandle.  
+! Attribute of type logical is
+! stored in scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ logical  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+INTEGER ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_ti_logical_sca " )
+
+
+
+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
+           CALL ext_ncd_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_gr2_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_int_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+           
+           
+           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_get_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_ti_logical_sca 
+
+
+!--- put_var_ti_logical
+
+SUBROUTINE wrf_put_var_ti_logical_arr ( DataHandle,Element,  Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ logical  :: Data (*)
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_ti_logical_arr " )
+
+
+
+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
+           CALL ext_ncd_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_ti_logical_arr 
+!--- put_var_ti_logical
+
+SUBROUTINE wrf_put_var_ti_logical_sca ( DataHandle,Element,  Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time independent
+! attribute "Element" of variable "Varname"  
+! to the open dataset described by DataHandle.  
+! Attribute of type logical is
+! copied from scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ logical  :: Data 
+
+INTEGER ,       INTENT(IN)  :: Count
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_ti_logical_sca " )
+
+
+
+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
+           CALL ext_ncd_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_ti_logical ( Hndl, Element,  Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_ti_logical_sca 
+
+
+!--- get_var_ti_char
+
+SUBROUTINE wrf_get_var_ti_char_arr ( DataHandle,Element,  Varname, Data,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ CHARACTER*(*)  :: Data
+
+
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_ti_char_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_get_var_ti_char ( Hndl, Element,  Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          len_of_str = LEN(Data)
+          CALL wrf_dm_bcast_string( Data, len_of_str )
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_ti_char ( Hndl, Element,  Varname, Data, &
+                               Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_ti_char ( Hndl, Element,  Varname, Data, &
+                               Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_ti_char ( Hndl, Element,  Varname, Data, &
+                               Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_ti_char ( Hndl, Element,  Varname, Data, &
+                               Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_ti_char ( Hndl, Element,  Varname, Data, &
+                               Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_ti_char ( Hndl, Element,  Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          len_of_str = LEN(Data)
+          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
+           CALL ext_gr2_get_var_ti_char ( Hndl, Element,  Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          len_of_str = LEN(Data)
+          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
+           CALL ext_int_get_var_ti_char ( Hndl, Element,  Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           len_of_str = LEN(Data)
+           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_get_var_ti_char ( Hndl, Element,  Varname, Data, &
+                           Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_ti_char_arr 
+
+
+!--- put_var_ti_char
+
+SUBROUTINE wrf_put_var_ti_char_arr ( DataHandle,Element,  Varname, Data,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write time independent
+! attribute "Element" of variable "Varname"  
+! to the open dataset described by DataHandle.  
+! Attribute of type char is
+! copied from string Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ CHARACTER*(*)  :: Data
+
+
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_ti_char_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_put_var_ti_char ( Hndl, Element,  Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_ti_char ( Hndl, Element,  Varname, Data, &
+                               Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_ti_char ( Hndl, Element,  Varname, Data, &
+                               Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_ti_char ( Hndl, Element,  Varname, Data, &
+                               Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_ti_char ( Hndl, Element,  Varname, Data, &
+                               Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_ti_char ( Hndl, Element,  Varname, Data, &
+                               Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_ti_char ( Hndl, Element,  Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_ti_char ( Hndl, Element,  Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_ti_char ( Hndl, Element,  Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_ti_char ( Hndl, Element,  Varname, Data, &
+                           Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_ti_char_arr 
+
+
+
+!--- get_var_td_real
+
+SUBROUTINE wrf_get_var_td_real_arr ( DataHandle,Element, DateStr, Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_td_real_arr " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_ncd_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_pnc_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_phdf5_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_esmf_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_xxx_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_yyy_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr1_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr2_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_int_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+           
+           
+           
+           
+           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_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_td_real_arr 
+!--- get_var_td_real
+
+SUBROUTINE wrf_get_var_td_real_sca ( DataHandle,Element, DateStr, Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read 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 scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_td_real_sca " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_ncd_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_pnc_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_phdf5_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_esmf_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_xxx_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  else
+        CALL ext_yyy_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr1_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_gr2_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  else
+           CALL ext_int_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )
+           
+           
+           
+           
+           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_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_td_real_sca 
+
+
+!--- put_var_td_real
+
+SUBROUTINE wrf_put_var_td_real_arr ( DataHandle,Element, DateStr, Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_td_real_arr " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_ncd_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_pnc_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_phdf5_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_esmf_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_xxx_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_yyy_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr1_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr2_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_int_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_td_real_arr 
+!--- put_var_td_real
+
+SUBROUTINE wrf_put_var_td_real_sca ( DataHandle,Element, DateStr, Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write 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 scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_td_real_sca " )
+
+
+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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_ncd_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_ncd_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_pnc_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_pnc_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_phdf5_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_phdf5_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_esmf_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_esmf_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_xxx_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_xxx_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+#  if ( RWORDSIZE == DWORDSIZE )
+        CALL ext_yyy_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  else
+        CALL ext_yyy_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status )
+#  endif
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr1_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr1_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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 ( RWORDSIZE == DWORDSIZE )
+           CALL ext_gr2_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_gr2_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+#  if ( RWORDSIZE == DWORDSIZE )
+           CALL ext_int_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  else
+           CALL ext_int_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status )
+#  endif
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_td_real_sca 
+
+
+!--- get_var_td_double
+
+SUBROUTINE wrf_get_var_td_double_arr ( DataHandle,Element, DateStr, Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_td_double_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_td_double_arr 
+!--- get_var_td_double
+
+SUBROUTINE wrf_get_var_td_double_sca ( DataHandle,Element, DateStr, Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read 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 scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_td_double_sca " )
+
+
+
+
+
+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
+           CALL ext_ncd_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_td_double_sca 
+
+
+!--- put_var_td_double
+
+SUBROUTINE wrf_put_var_td_double_arr ( DataHandle,Element, DateStr, Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_td_double_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_td_double_arr 
+!--- put_var_td_double
+
+SUBROUTINE wrf_put_var_td_double_sca ( DataHandle,Element, DateStr, Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write 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 scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_td_double_sca " )
+
+
+
+
+
+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
+           CALL ext_ncd_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_td_double_sca 
+
+
+!--- get_var_td_integer
+
+SUBROUTINE wrf_get_var_td_integer_arr ( DataHandle,Element, DateStr, Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_td_integer_arr " )
+
+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
+           CALL ext_ncd_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+           
+           
+           
+           
+           
+           
+           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_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_td_integer_arr 
+!--- get_var_td_integer
+
+SUBROUTINE wrf_get_var_td_integer_sca ( DataHandle,Element, DateStr, Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read 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 scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_td_integer_sca " )
+
+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
+           CALL ext_ncd_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )
+           
+           
+           
+           
+           
+           
+           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_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_td_integer_sca 
+
+
+!--- put_var_td_integer
+
+SUBROUTINE wrf_put_var_td_integer_arr ( DataHandle,Element, DateStr, Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_td_integer_arr " )
+
+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
+           CALL ext_ncd_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_td_integer_arr 
+!--- put_var_td_integer
+
+SUBROUTINE wrf_put_var_td_integer_sca ( DataHandle,Element, DateStr, Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write 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 scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_td_integer_sca " )
+
+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
+           CALL ext_ncd_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_td_integer_sca 
+
+
+!--- get_var_td_logical
+
+SUBROUTINE wrf_get_var_td_logical_arr ( DataHandle,Element, DateStr, Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_td_logical_arr " )
+
+
+
+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
+           CALL ext_ncd_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_gr2_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_int_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+           
+           
+           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_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_td_logical_arr 
+!--- get_var_td_logical
+
+SUBROUTINE wrf_get_var_td_logical_sca ( DataHandle,Element, DateStr, Varname, Data, Count, Outcount, Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Attempt to read 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 scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT)  :: OutCount
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_td_logical_sca " )
+
+
+
+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
+           CALL ext_ncd_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount, Outcount, Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_gr2_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+          CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+          
+          
+          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
+           CALL ext_int_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount, Outcount, Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )
+           CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )
+           
+           
+           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_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount, Outcount, Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_td_logical_sca 
+
+
+!--- put_var_td_logical
+
+SUBROUTINE wrf_put_var_td_logical_arr ( DataHandle,Element, DateStr, Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_td_logical_arr " )
+
+
+
+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
+           CALL ext_ncd_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_td_logical_arr 
+!--- put_var_td_logical
+
+SUBROUTINE wrf_put_var_td_logical_sca ( DataHandle,Element, DateStr, Varname, Data, Count,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! Write 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 scalar Data.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+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 ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_td_logical_sca " )
+
+
+
+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
+           CALL ext_ncd_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                              locCount,  Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                                 locCount,  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, &
+                          locCount,  Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_td_logical_sca 
+
+
+!--- get_var_td_char
+
+SUBROUTINE wrf_get_var_td_char_arr ( DataHandle,Element, DateStr, Varname, Data,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ CHARACTER*(*)  :: Data
+
+
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_get_var_td_char_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_get_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          len_of_str = LEN(Data)
+          CALL wrf_dm_bcast_string( Data, len_of_str )
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_get_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                               Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_get_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                               Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_get_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                               Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_get_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                               Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_get_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                               Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_get_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          len_of_str = LEN(Data)
+          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
+           CALL ext_gr2_get_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          len_of_str = LEN(Data)
+          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
+           CALL ext_int_get_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           len_of_str = LEN(Data)
+           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_get_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                           Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_get_var_td_char_arr 
+
+
+!--- put_var_td_char
+
+SUBROUTINE wrf_put_var_td_char_arr ( DataHandle,Element, DateStr, Varname, Data,  Status )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.
+! 
+!
+!</PRE>
+!</DESCRIPTION>
+USE module_state_description
+IMPLICIT NONE
+INTEGER ,       INTENT(IN)  :: DataHandle
+CHARACTER*(*) , INTENT(IN)  :: Element
+CHARACTER*(*) , INTENT(IN)  :: DateStr
+CHARACTER*(*) , INTENT(IN)  :: VarName 
+
+ CHARACTER*(*)  :: Data
+
+
+
+INTEGER ,       INTENT(OUT) :: Status
+
+#include <wrf_status_codes.h>
+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_put_var_td_char_arr " )
+
+
+
+
+
+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
+           CALL ext_ncd_put_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
+        ENDIF
+#endif
+#ifdef PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_put_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                               Status ) 
+#endif
+#ifdef PHDF5
+      CASE ( IO_PHDF5   )
+        CALL ext_phdf5_put_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                               Status ) 
+#endif
+#ifdef ESMFIO
+      CASE ( IO_ESMF )
+        CALL ext_esmf_put_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                               Status ) 
+#endif
+#ifdef XXX
+      CASE ( IO_XXX   )
+        CALL ext_xxx_put_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                               Status ) 
+#endif
+#ifdef YYY
+      CASE ( IO_YYY   )
+        CALL ext_yyy_put_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                               Status ) 
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1   )
+        IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
+           CALL ext_gr1_put_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_gr2_put_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+          
+          
+          
+          
+          
+          
+          
+          
+          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
+           CALL ext_int_put_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                                  Status ) 
+        ENDIF
+        IF ( .NOT. multi_files(io_form) ) THEN
+           
+           
+           
+           
+           
+           
+           
+           
+           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_put_var_td_char ( Hndl, Element, DateStr, Varname, Data, &
+                           Status )
+  ELSE
+    Status = 0
+ENDIF
+ELSE
+  Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+ENDIF
+RETURN
+END SUBROUTINE wrf_put_var_td_char_arr 
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/arch/no_file_line.sed
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/no_file_line.sed	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/no_file_line.sed	(revision 17)
@@ -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__ , /
Index: branches/LMDZ_WRFmeas/WRFV3/arch/noopt_exceptions
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/noopt_exceptions	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/noopt_exceptions	(revision 17)
@@ -0,0 +1,270 @@
+# compile these without high optimization to speed compile
+
+convert_nmm.o : convert_nmm.F
+init_modules_em.o : init_modules_em.F
+input_wrf.o : input_wrf.F
+module_io.o : module_io.F
+mediation_feedback_domain.o : mediation_feedback_domain.F
+mediation_force_domain.o : mediation_force_domain.F
+mediation_integrate.o : mediation_integrate.F
+mediation_interp_domain.o : mediation_interp_domain.F
+module_comm_dm.o : module_comm_dm.F
+module_comm_dm_0.o : module_comm_dm_0.F
+module_comm_dm_1.o : module_comm_dm_1.F
+module_comm_dm_2.o : module_comm_dm_2.F
+module_comm_dm_3.o : module_comm_dm_3.F
+module_comm_nesting_dm.o : module_comm_nesting_dm.F
+module_configure.o : module_configure.F
+module_dm.o : module_dm.F
+module_domain.o : module_domain.F
+module_domain_type.o : module_domain_type.F
+module_alloc_space_0.o : module_alloc_space_0.F
+module_alloc_space_1.o : module_alloc_space_1.F
+module_alloc_space_2.o : module_alloc_space_2.F
+module_alloc_space_3.o : module_alloc_space_3.F
+module_alloc_space_4.o : module_alloc_space_4.F
+module_alloc_space_5.o : module_alloc_space_5.F
+module_alloc_space_6.o : module_alloc_space_6.F
+module_alloc_space_7.o : module_alloc_space_7.F
+module_alloc_space_8.o : module_alloc_space_8.F
+module_alloc_space_9.o : module_alloc_space_9.F
+module_tiles.o : module_tiles.F
+module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F
+module_initialize.o : module_initialize.F
+module_physics_init.o : module_physics_init.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_real.o : module_initialize_real.F
+module_initialize_real.o: module_initialize_real.F
+module_initialize_squall2d_x.o : module_initialize_squall2d_x.F
+module_initialize_squall2d_y.o : module_initialize_squall2d_y.F
+module_integrate.o : module_integrate.F
+module_io_mm5.o : module_io_mm5.F
+module_io_wrf.o : module_io_wrf.F
+module_si_io.o : module_si_io.F
+module_state_description.o : module_state_description.F 
+output_wrf.o : output_wrf.F
+shift_domain_em.o : shift_domain_em.F
+solve_em.o : solve_em.F
+solve_interface.o : solve_interface.F
+start_domain.o : start_domain.F
+start_domain_nmm.o : start_domain_nmm.F
+start_em.o : start_em.F
+wrf_auxhist10in.o : wrf_auxhist10in.F
+wrf_auxhist10out.o : wrf_auxhist10out.F
+wrf_auxhist11in.o : wrf_auxhist11in.F
+wrf_auxhist11out.o : wrf_auxhist11out.F
+wrf_auxhist1in.o : wrf_auxhist1in.F
+wrf_auxhist1out.o : wrf_auxhist1out.F
+wrf_auxhist2in.o : wrf_auxhist2in.F
+wrf_auxhist2out.o : wrf_auxhist2out.F
+wrf_auxhist3in.o : wrf_auxhist3in.F
+wrf_auxhist3out.o : wrf_auxhist3out.F
+wrf_auxhist4in.o : wrf_auxhist4in.F
+wrf_auxhist4out.o : wrf_auxhist4out.F
+wrf_auxhist5in.o : wrf_auxhist5in.F
+wrf_auxhist5out.o : wrf_auxhist5out.F
+wrf_auxhist6in.o : wrf_auxhist6in.F
+wrf_auxhist6out.o : wrf_auxhist6out.F
+wrf_auxhist7in.o : wrf_auxhist7in.F
+wrf_auxhist7out.o : wrf_auxhist7out.F
+wrf_auxhist8in.o : wrf_auxhist8in.F
+wrf_auxhist8out.o : wrf_auxhist8out.F
+wrf_auxhist9in.o : wrf_auxhist9in.F
+wrf_auxhist9out.o : wrf_auxhist9out.F
+wrf_auxinput10in.o : wrf_auxinput10in.F
+wrf_auxinput10out.o : wrf_auxinput10out.F
+wrf_auxinput11in.o : wrf_auxinput11in.F
+wrf_auxinput11out.o : wrf_auxinput11out.F
+wrf_auxinput1in.o : wrf_auxinput1in.F
+wrf_auxinput1out.o : wrf_auxinput1out.F
+wrf_auxinput2in.o : wrf_auxinput2in.F
+wrf_auxinput2out.o : wrf_auxinput2out.F
+wrf_auxinput3in.o : wrf_auxinput3in.F
+wrf_auxinput3out.o : wrf_auxinput3out.F
+wrf_auxinput4in.o : wrf_auxinput4in.F
+wrf_auxinput4out.o : wrf_auxinput4out.F
+wrf_auxinput5in.o : wrf_auxinput5in.F
+wrf_auxinput5out.o : wrf_auxinput5out.F
+wrf_auxinput6in.o : wrf_auxinput6in.F
+wrf_auxinput6out.o : wrf_auxinput6out.F
+wrf_auxinput7in.o : wrf_auxinput7in.F
+wrf_auxinput7out.o : wrf_auxinput7out.F
+wrf_auxinput8in.o : wrf_auxinput8in.F
+wrf_auxinput8out.o : wrf_auxinput8out.F
+wrf_auxinput9in.o : wrf_auxinput9in.F
+wrf_auxinput9out.o : wrf_auxinput9out.F
+wrf_bdyin.o : wrf_bdyin.F
+wrf_bdyout.o : wrf_bdyout.F
+wrf_ext_read_field.o : wrf_ext_read_field.F
+wrf_ext_write_field.o : wrf_ext_write_field.F
+wrf_fddaobs_in.o : wrf_fddaobs_in.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_tsin.o : wrf_tsin.F
+nl_get_0_routines.o : nl_get_0_routines.F
+nl_get_1_routines.o : nl_get_1_routines.F
+nl_set_0_routines.o : nl_set_0_routines.F
+nl_set_1_routines.o : nl_set_1_routines.F
+
+convert_nmm.o \
+init_modules_em.o \
+mediation_feedback_domain.o \
+mediation_force_domain.o \
+mediation_integrate.o \
+mediation_interp_domain.o \
+module_dm.o \
+module_fddaobs_rtfdda.o \
+module_initialize.o \
+module_initialize_b_wave.o \
+module_initialize_hill2d_x.o \
+module_initialize_quarter_ss.o \
+module_initialize_real.o \
+module_initialize_squall2d_x.o \
+module_initialize_squall2d_y.o \
+module_integrate.o \
+module_io_mm5.o \
+module_io_wrf.o \
+module_si_io.o \
+module_tiles.o \
+output_wrf.o \
+shift_domain_em.o \
+solve_interface.o \
+start_domain.o \
+start_domain_nmm.o \
+start_em.o \
+wrf_fddaobs_in.o \
+wrf_tsin.o :
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F  > $*.bb
+	$(SED_FTN) $*.bb | $(CPP) > $*.f90
+	$(RM) $*.b $*.bb
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $(FCSUFFIX) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 ; \
+        fi
+
+solve_em.o :
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F  > $*.bb
+	$(SED_FTN) $*.bb | $(CPP) > $*.f90
+	$(RM) $*.b $*.bb
+	$(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $(SOLVE_EM_SPECIAL) $(FCSUFFIX) $*.f90
+
+module_sf_ruclsm.o : module_sf_ruclsm.F
+
+module_sf_ruclsm.o :
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F  > $*.bb
+	$(SED_FTN) $*.bb | $(CPP) > $*.f90
+	$(RM) $*.b $*.bb
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCREDUCEDOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $(FCSUFFIX) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCREDUCEDOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 ; \
+        fi
+
+# compile without OMP
+input_wrf.o \
+module_io.o \
+module_domain.o \
+module_domain_type.o \
+module_physics_init.o \
+wrf_auxhist10in.o \
+wrf_auxhist10out.o \
+wrf_auxhist11in.o \
+wrf_auxhist11out.o \
+wrf_auxhist1in.o \
+wrf_auxhist1out.o \
+wrf_auxhist2in.o \
+wrf_auxhist2out.o \
+wrf_auxhist3in.o \
+wrf_auxhist3out.o \
+wrf_auxhist4in.o \
+wrf_auxhist4out.o \
+wrf_auxhist5in.o \
+wrf_auxhist5out.o \
+wrf_auxhist6in.o \
+wrf_auxhist6out.o \
+wrf_auxhist7in.o \
+wrf_auxhist7out.o \
+wrf_auxhist8in.o \
+wrf_auxhist8out.o \
+wrf_auxhist9in.o \
+wrf_auxhist9out.o \
+wrf_auxinput10in.o \
+wrf_auxinput10out.o \
+wrf_auxinput11in.o \
+wrf_auxinput11out.o \
+wrf_auxinput1in.o \
+wrf_auxinput1out.o \
+wrf_auxinput2in.o \
+wrf_auxinput2out.o \
+wrf_auxinput3in.o \
+wrf_auxinput3out.o \
+wrf_auxinput4in.o \
+wrf_auxinput4out.o \
+wrf_auxinput5in.o \
+wrf_auxinput5out.o \
+wrf_auxinput6in.o \
+wrf_auxinput6out.o \
+wrf_auxinput7in.o \
+wrf_auxinput7out.o \
+wrf_auxinput8in.o \
+wrf_auxinput8out.o \
+wrf_auxinput9in.o \
+wrf_auxinput9out.o \
+wrf_bdyin.o \
+wrf_bdyout.o \
+wrf_ext_read_field.o \
+wrf_ext_write_field.o \
+wrf_histin.o \
+wrf_histout.o \
+wrf_inputin.o \
+wrf_inputout.o \
+wrf_restartin.o \
+wrf_restartout.o \
+module_state_description.o \
+module_alloc_space.o \
+module_alloc_space_0.o \
+module_alloc_space_1.o \
+module_alloc_space_2.o \
+module_alloc_space_3.o \
+module_alloc_space_4.o \
+module_alloc_space_5.o \
+module_alloc_space_6.o \
+module_alloc_space_7.o \
+module_alloc_space_8.o \
+module_alloc_space_9.o \
+module_comm_dm.o \
+module_comm_dm_0.o \
+module_comm_dm_1.o \
+module_comm_dm_2.o \
+module_comm_dm_3.o \
+module_comm_nesting_dm.o \
+module_configure.o :
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F  > $*.bb
+	$(SED_FTN) $*.bb | $(CPP) > $*.f90
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	$(RM) $*.b $*.bb
+	$(FC) -c $(PROMOTION) $(FCSUFFIX) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
Index: branches/LMDZ_WRFmeas/WRFV3/arch/noopt_exceptions_f
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/noopt_exceptions_f	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/noopt_exceptions_f	(revision 17)
@@ -0,0 +1,180 @@
+# A little more adventurous.  Allow full opt on 
+# mediation_integrate.o \
+# shift_domain_em.o \
+# solve_em.o  <-- gets a little kick from SOLVE_EM_SPECIAL too, if defined
+# mediation_feedback_domain.o : mediation_feedback_domain.F
+# mediation_force_domain.o : mediation_force_domain.F
+# mediation_interp_domain.o : mediation_interp_domain.F
+
+# compile these without high optimization to speed compile
+convert_nmm.o : convert_nmm.F
+init_modules_em.o : init_modules_em.F
+input_wrf.o : input_wrf.F
+module_io.o : module_io.F
+module_comm_dm.o : module_comm_dm.F
+module_comm_dm_0.o : module_comm_dm_0.F
+module_comm_dm_1.o : module_comm_dm_1.F
+module_comm_dm_2.o : module_comm_dm_2.F
+module_comm_dm_3.o : module_comm_dm_3.F
+module_comm_nesting_dm.o : module_comm_nesting_dm.F
+module_configure.o : module_configure.F
+module_dm.o : module_dm.F
+module_domain.o : module_domain.F
+module_domain_type.o : module_domain_type.F
+module_alloc_space_0.o : module_alloc_space_0.F
+module_alloc_space_1.o : module_alloc_space_1.F
+module_alloc_space_2.o : module_alloc_space_2.F
+module_alloc_space_3.o : module_alloc_space_3.F
+module_alloc_space_4.o : module_alloc_space_4.F
+module_alloc_space_5.o : module_alloc_space_5.F
+module_alloc_space_6.o : module_alloc_space_6.F
+module_alloc_space_7.o : module_alloc_space_7.F
+module_alloc_space_8.o : module_alloc_space_8.F
+module_alloc_space_9.o : module_alloc_space_9.F
+module_tiles.o : module_tiles.F
+module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F
+module_initialize.o : module_initialize.F
+module_physics_init.o : module_physics_init.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_real.o : module_initialize_real.F
+module_initialize_real.o: module_initialize_real.F
+module_initialize_squall2d_x.o : module_initialize_squall2d_x.F
+module_initialize_squall2d_y.o : module_initialize_squall2d_y.F
+module_integrate.o : module_integrate.F
+module_io_mm5.o : module_io_mm5.F
+module_io_wrf.o : module_io_wrf.F
+module_si_io.o : module_si_io.F
+module_state_description.o : module_state_description.F 
+output_wrf.o : output_wrf.F
+solve_interface.o : solve_interface.F
+start_domain.o : start_domain.F
+start_domain_nmm.o : start_domain_nmm.F
+start_em.o : start_em.F
+wrf_bdyin.o : wrf_bdyin.F
+wrf_bdyout.o : wrf_bdyout.F
+wrf_ext_read_field.o : wrf_ext_read_field.F
+wrf_ext_write_field.o : wrf_ext_write_field.F
+wrf_fddaobs_in.o : wrf_fddaobs_in.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_tsin.o : wrf_tsin.F
+nl_get_0_routines.o : nl_get_0_routines.F
+nl_get_1_routines.o : nl_get_1_routines.F
+nl_set_0_routines.o : nl_set_0_routines.F
+nl_set_1_routines.o : nl_set_1_routines.F
+
+convert_nmm.o \
+init_modules_em.o \
+module_dm.o \
+module_fddaobs_rtfdda.o \
+module_initialize.o \
+module_initialize_b_wave.o \
+module_initialize_hill2d_x.o \
+module_initialize_quarter_ss.o \
+module_initialize_real.o \
+module_initialize_squall2d_x.o \
+module_initialize_squall2d_y.o \
+module_integrate.o \
+module_io_mm5.o \
+module_io_wrf.o \
+module_si_io.o \
+module_tiles.o \
+output_wrf.o \
+solve_interface.o \
+start_domain.o \
+start_domain_nmm.o \
+shift_domain_nmm.o \
+start_em.o \
+wrf_fddaobs_in.o \
+wrf_tsin.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $(OMP) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 ; \
+        fi
+
+#solve_em.o :
+#	$(RM) $@
+#	$(SED_FTN) $*.F > $*.b 
+#	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+#	$(RM) $*.b
+#	$(FC) -o $@ -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $(SOLVE_EM_SPECIAL) $(OMP) $*.f90
+
+module_sf_ruclsm.o : module_sf_ruclsm.F
+
+module_sf_ruclsm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          echo COMPILING $*.F WITH OMP ; \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCREDUCEDOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $(OMP) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCREDUCEDOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 ; \
+        fi
+
+# compile without OMP
+input_wrf.o \
+module_domain.o \
+module_domain_type.o \
+module_physics_init.o \
+module_io.o \
+wrf_bdyin.o \
+wrf_bdyout.o \
+wrf_ext_read_field.o \
+wrf_ext_write_field.o \
+wrf_histin.o \
+wrf_histout.o \
+wrf_inputin.o \
+wrf_inputout.o \
+wrf_restartin.o \
+wrf_restartout.o \
+module_state_description.o \
+module_alloc_space.o \
+module_alloc_space_0.o \
+module_alloc_space_1.o \
+module_alloc_space_2.o \
+module_alloc_space_3.o \
+module_alloc_space_4.o \
+module_alloc_space_5.o \
+module_alloc_space_6.o \
+module_alloc_space_7.o \
+module_alloc_space_8.o \
+module_alloc_space_9.o \
+module_comm_dm.o \
+module_comm_dm_0.o \
+module_comm_dm_1.o \
+module_comm_dm_2.o \
+module_comm_dm_3.o \
+module_comm_nesting_dm.o \
+module_configure.o :
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F  > $*.bb
+	$(SED_FTN) $*.bb | $(CPP) > $*.f90
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	$(RM) $*.b $*.bb
+	$(FC) -c $(PROMOTION) $(FCSUFFIX) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
Index: branches/LMDZ_WRFmeas/WRFV3/arch/postamble_new
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/postamble_new	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/postamble_new	(revision 17)
@@ -0,0 +1,207 @@
+######################
+# POSTAMBLE
+
+FGREP = fgrep -iq
+
+ARCHFLAGS       =    $(COREDEFS) -DIWORDSIZE=$(IWORDSIZE) -DDWORDSIZE=$(DWORDSIZE) -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=$(LWORDSIZE) \
+                     $(ARCH_LOCAL) \
+                     $(DA_ARCHFLAGS) \
+                      CONFIGURE_DMPARALLEL \
+                      CONFIGURE_STUBMPI \
+                      CONFIGURE_NETCDF_FLAG \
+                      CONFIGURE_PNETCDF_FLAG \
+                      CONFIGURE_ESMF_FLAG \
+                      CONFIGURE_GRIB2_FLAG \
+                      CONFIGURE_RTTOV_FLAG \
+                      CONFIGURE_CRTM_FLAG \
+                      CONFIGURE_4DVAR_FLAG \
+                      CONFIGURE_WAVELET_FLAG \
+                      CONFIGURE_NESTOPT \
+                      -DUSE_ALLOCATABLES \
+                      -DGRIB1 \
+                      -DINTIO \
+                      -DLIMIT_ARGS \
+                      -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) \
+                      -DMAX_DOMAINS_F=$(MAX_DOMAINS) \
+                      -DMAX_HISTORY=$(MAX_HISTORY) \
+		      -DNMM_NEST=$(WRF_NMM_NEST)
+CFLAGS          =    $(CFLAGS_LOCAL) CONFIGURE_DMPARALLEL CONFIGURE_STUBMPI \
+                      -DMAX_HISTORY=$(MAX_HISTORY)
+FCFLAGS         =    $(FCOPTIM) $(FCBASEOPTS)
+ESMF_LIB_FLAGS  =    ESMFLIBFLAG
+#NOWIN ESMF_IO_LIB     =    ESMFIOLIB
+ESMF_IO_LIB_EXT =    ESMFIOEXTLIB
+INCLUDE_MODULES =    $(MODULE_SRCH_FLAG) \
+                     $(ESMF_MOD_INC) $(ESMF_LIB_FLAGS) \
+                      -I$(WRF_SRC_ROOT_DIR)/main \
+                      -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf \
+                      -I$(WRF_SRC_ROOT_DIR)/external/io_int \
+                      -I$(WRF_SRC_ROOT_DIR)/frame \
+                      -I$(WRF_SRC_ROOT_DIR)/share \
+                      -I$(WRF_SRC_ROOT_DIR)/phys \
+                      -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc \
+                      -I$(NETCDFPATH)/include \
+                      CONFIGURE_RTTOV_INC
+REGISTRY        =    Registry
+
+#NOWIN LIB_BUNDLED     = \
+#NOWIN                      $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5/libfftpack.a \
+#NOWIN                      $(WRF_SRC_ROOT_DIR)/external/io_grib1/libio_grib1.a \
+#NOWIN                      $(WRF_SRC_ROOT_DIR)/external/io_grib_share/libio_grib_share.a \
+#NOWIN                      $(WRF_SRC_ROOT_DIR)/external/io_int/libwrfio_int.a \
+#NOWIN                      $(ESMF_IO_LIB) \
+#NOWIN                      CONFIGURE_COMMS_LIB \
+#NOWIN                      $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o \
+#NOWIN                      $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o 
+
+#NOWIN LIB_EXTERNAL    = \
+#NOWIN                      CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PNETCDF_LIB_PATH CONFIGURE_GRIB2_LIB CONFIGURE_ATMOCN_LIB
+
+LIB             =    $(LIB_BUNDLED) $(LIB_EXTERNAL) $(LIB_LOCAL)
+LDFLAGS         =    $(OMP) $(FCFLAGS) $(LDFLAGS_LOCAL) CONFIGURE_LDFLAGS
+ENVCOMPDEFS     =    CONFIGURE_COMPILEFLAGS
+CPPFLAGS        =    $(ARCHFLAGS) $(ENVCOMPDEFS) -I$(LIBINCLUDE) $(TRADFLAG) CONFIGURE_COMMS_INCLUDE
+NETCDFPATH      =    CONFIGURE_NETCDF_PATH
+PNETCDFPATH     =    CONFIGURE_PNETCDF_PATH
+
+bundled:  wrf_ioapi_includes wrfio_grib_share wrfio_grib1 wrfio_int esmf_time fftpack CONFIGURE_ATMOCN
+external:  CONFIGURE_WRFIO_NF CONFIGURE_WRFIO_PNF CONFIGURE_WRFIO_GRIB2 CONFIGURE_COMMS_EXTERNAL $(ESMF_TARGET)
+
+######################
+externals: bundled external
+
+gen_comms_serial :
+	( /bin/rm -f $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm_serial :
+	( if [ ! -e module_dm.F ] ; then /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ; fi )
+
+gen_comms_rsllite :
+	( if [ ! -e $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ] ; then \
+          /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; fi )
+
+module_dm_rsllite :
+	( if [ ! -e module_dm.F ] ; then /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F ; fi )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH="$(NETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          CC="$(SCC)" CFLAGS="$(CFLAGS)" \
+          FC="$(SFC) $(PROMOTION) $(FCFLAGS)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_pnf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_pnetcdf ; \
+          make NETCDFPATH="$(PNETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP) $(ARCHFLAGS)" \
+          FC="$(FC) $(PROMOTION) $(FCFLAGS)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" archive) 
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS) CONFIGURE_GRIB2_INC" RM="$(RM)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="-traditional" AR="$(AR)" ARFLAGS="$(ARFLAGS)" \
+          FIXED="$(FORMAT_FIXED)" archive)
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FGREP="$(FGREP)" \
+          TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ARCHFLAGS="$(ARCHFLAGS)" all )
+
+esmf_time : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+          make FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(ARCHFLAGS) $(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+atm_ocn :
+	( cd $(WRF_SRC_ROOT_DIR)/external/atm_ocn ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS) " RM="$(RM)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP)" \
+          FC="$(DM_FC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="-traditional" AR="$(AR)" ARFLAGS="$(ARFLAGS)" \
+          FIXED="$(FORMAT_FIXED)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CC="$(CC) $(CFLAGS)" \
+          FC="$(FC) $(FCFLAGS) $(PROMOTION) $(BYTESWAPIO)" \
+          CPP="$(CPP) -I. $(ARCHFLAGS) $(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ;\
+          $(RANLIB) $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a )
+
+######################
+#	Macros, these should be generic for all machines
+
+LN	=	ln -sf
+MAKE	=	make -i -r
+RM	= 	rm -f
+
+
+# These sub-directory builds are identical across all architectures
+
+wrf_ioapi_includes :
+	( cd $(WRF_SRC_ROOT_DIR)/external/ioapi_share ; \
+          $(MAKE) NATIVE_RWORDSIZE="$(NATIVE_RWORDSIZE)" RWORDSIZE="$(RWORDSIZE)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_esmf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_esmf ; \
+          make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) $(ESMF_MOD_INC)" \
+          RANLIB="$(RANLIB)" CPP="$(CPP) $(POUND_DEF) " AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+#	There is probably no reason to modify these rules
+
+.F.i:
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.F > $@
+	mv $*.i $(DEVTOP)/pick/$*.f90
+	cp $*.F $(DEVTOP)/pick
+
+.F.o:
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F  > $*.bb
+	$(SED_FTN) $*.bb | $(CPP) > $*.f90
+	$(RM) $*.b $*.bb
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -o $@ -c $(FCFLAGS) $(OMP) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -o $@ -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \
+        fi
+        
+
+.F.f90:
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $@
+	$(RM) $*.b
+
+.f90.o:
+	$(RM) $@
+	$(FC) -o $@ -c $(FCFLAGS) $(PROMOTION) $(FCSUFFIX) $*.f90
+
+setfeenv.o : setfeenv.c
+	$(RM) $@
+	$(CCOMP) -o $@ -c $(CFLAGS) $(OMPCC) $*.c
+
+.c.o:
+	$(RM) $@
+	$(CC) -o $@ -c $(CFLAGS) $*.c
+
Index: branches/LMDZ_WRFmeas/WRFV3/arch/postamble_old
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/postamble_old	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/postamble_old	(revision 17)
@@ -0,0 +1,59 @@
+
+# These sub-directory builds are identical across all architectures
+wrfio_esmf :
+	( cd $(WRF_SRC_ROOT_DIR)/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 $(WRF_SRC_ROOT_DIR)/external/ioapi_share ; \
+	$(MAKE) NATIVE_RWORDSIZE="$(NATIVE_RWORDSIZE)" RWORDSIZE="$(RWORDSIZE)" )
+
+.F.i:
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.F > $@
+	mv $*.i $(DEVTOP)/pick/$*.f90
+	cp $*.F $(DEVTOP)/pick
+
+.F.o:
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -o $@ -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$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $@
+	$(RM) $*.b
+
+.f90.o:
+	$(RM) $@
+	$(FC) -o $@ -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) -o $@ -c $(CFLAGS) $*.c
+
Index: branches/LMDZ_WRFmeas/WRFV3/arch/preamble_new
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/preamble_new	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/preamble_new	(revision 17)
@@ -0,0 +1,90 @@
+# 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 = CONFIGURE_EM_CORE \
+           CONFIGURE_NMM_CORE -DNMM_MAX_DIM=2600 \
+	   CONFIGURE_COAMPS_CORE \
+	   CONFIGURE_DA_CORE \
+           CONFIGURE_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	=	32768
+
+#### Size of bitmasks (in 4byte integers) of stream masks for WRF I/O
+
+MAX_HISTORY = 25
+
+IWORDSIZE = 4
+DWORDSIZE = 8
+LWORDSIZE = 4
+
+##############################################################################
+#### 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 $(WRF_SRC_ROOT_DIR)/arch/standard.sed
+SED_FTN = $(WRF_SRC_ROOT_DIR)/tools/standard.exe
+
+# 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 external/io_esmf vs. external/esmf_time_f90
+ESMF_IO_INC         = ESMFIOINC
+# select -I options for separately installed ESMF library, if present
+ESMF_MOD_INC        = ESMFMODINC $(ESMF_IO_INC)
+# 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
+
+##############################################################################
+
+LIBWRFLIB = libwrflib.a
+
+
+#### Architecture specific settings ####
+
Index: branches/LMDZ_WRFmeas/WRFV3/arch/preamble_old
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/preamble_old	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/preamble_old	(revision 17)
@@ -0,0 +1,82 @@
+# 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) \
+	   -DDA_CORE=$(WRF_DA_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 $(WRF_SRC_ROOT_DIR)/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
+
+##############################################################################
+
+LIBWRFLIB = libwrflib.a
+
+
+#### Architecture specific settings ####
+
Index: branches/LMDZ_WRFmeas/WRFV3/arch/standard.sed
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/standard.sed	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/standard.sed	(revision 17)
@@ -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__ , /
Index: branches/LMDZ_WRFmeas/WRFV3/arch/win_mpif.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/arch/win_mpif.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/arch/win_mpif.h	(revision 17)
@@ -0,0 +1,427 @@
+!      /* -*- Mode: Fortran; -*- */
+!      
+!      (C) 2001 by Argonne National Laboratory.
+!      See COPYRIGHT in top-level directory.
+!      
+!      DO NOT EDIT
+!      This file created by buildiface 
+!      
+       INTEGER MPI_SOURCE, MPI_TAG, MPI_ERROR
+       PARAMETER (MPI_SOURCE=3,MPI_TAG=4,MPI_ERROR=5)
+       INTEGER MPI_STATUS_SIZE
+       PARAMETER (MPI_STATUS_SIZE=5)
+       INTEGER MPI_STATUS_IGNORE(MPI_STATUS_SIZE)
+       INTEGER MPI_STATUSES_IGNORE(MPI_STATUS_SIZE,1)
+       INTEGER MPI_ERRCODES_IGNORE(1)
+       CHARACTER*1 MPI_ARGVS_NULL(1,1)
+       CHARACTER*1 MPI_ARGV_NULL(1)
+       INTEGER MPI_SUCCESS
+       PARAMETER (MPI_SUCCESS=0)
+       INTEGER MPI_ERR_IN_STATUS
+       PARAMETER (MPI_ERR_IN_STATUS=17)
+       INTEGER MPI_ERR_GROUP
+       PARAMETER (MPI_ERR_GROUP=8)
+       INTEGER MPI_ERR_COUNT
+       PARAMETER (MPI_ERR_COUNT=2)
+       INTEGER MPI_ERR_LOCKTYPE
+       PARAMETER (MPI_ERR_LOCKTYPE=47)
+       INTEGER MPI_ERR_BASE
+       PARAMETER (MPI_ERR_BASE=46)
+       INTEGER MPI_ERR_SIZE
+       PARAMETER (MPI_ERR_SIZE=51)
+       INTEGER MPI_ERR_FILE_EXISTS
+       PARAMETER (MPI_ERR_FILE_EXISTS=25)
+       INTEGER MPI_ERR_PORT
+       PARAMETER (MPI_ERR_PORT=38)
+       INTEGER MPI_ERR_ACCESS
+       PARAMETER (MPI_ERR_ACCESS=20)
+       INTEGER MPI_ERR_READ_ONLY
+       PARAMETER (MPI_ERR_READ_ONLY=40)
+       INTEGER MPI_ERR_INTERN
+       PARAMETER (MPI_ERR_INTERN=16)
+       INTEGER MPI_ERR_OP
+       PARAMETER (MPI_ERR_OP=9)
+       INTEGER MPI_ERR_INFO_KEY
+       PARAMETER (MPI_ERR_INFO_KEY=29)
+       INTEGER MPI_ERR_UNSUPPORTED_OPERATION
+       PARAMETER (MPI_ERR_UNSUPPORTED_OPERATION=44)
+       INTEGER MPI_ERR_ARG
+       PARAMETER (MPI_ERR_ARG=12)
+       INTEGER MPI_ERR_LASTCODE
+       PARAMETER (MPI_ERR_LASTCODE=1073741823)
+       INTEGER MPI_ERR_AMODE
+       PARAMETER (MPI_ERR_AMODE=21)
+       INTEGER MPI_ERR_ROOT
+       PARAMETER (MPI_ERR_ROOT=7)
+       INTEGER MPI_ERR_UNKNOWN
+       PARAMETER (MPI_ERR_UNKNOWN=13)
+       INTEGER MPI_ERR_FILE
+       PARAMETER (MPI_ERR_FILE=27)
+       INTEGER MPI_ERR_TAG
+       PARAMETER (MPI_ERR_TAG=4)
+       INTEGER MPI_ERR_CONVERSION
+       PARAMETER (MPI_ERR_CONVERSION=23)
+       INTEGER MPI_ERR_NOT_SAME
+       PARAMETER (MPI_ERR_NOT_SAME=35)
+       INTEGER MPI_ERR_NO_SPACE
+       PARAMETER (MPI_ERR_NO_SPACE=36)
+       INTEGER MPI_ERR_IO
+       PARAMETER (MPI_ERR_IO=32)
+       INTEGER MPI_ERR_DUP_DATAREP
+       PARAMETER (MPI_ERR_DUP_DATAREP=24)
+       INTEGER MPI_ERR_BAD_FILE
+       PARAMETER (MPI_ERR_BAD_FILE=22)
+       INTEGER MPI_ERR_FILE_IN_USE
+       PARAMETER (MPI_ERR_FILE_IN_USE=26)
+       INTEGER MPI_ERR_NAME
+       PARAMETER (MPI_ERR_NAME=33)
+       INTEGER MPI_ERR_TRUNCATE
+       PARAMETER (MPI_ERR_TRUNCATE=14)
+       INTEGER MPI_ERR_COMM
+       PARAMETER (MPI_ERR_COMM=5)
+       INTEGER MPI_ERR_RMA_SYNC
+       PARAMETER (MPI_ERR_RMA_SYNC=50)
+       INTEGER MPI_ERR_INFO_VALUE
+       PARAMETER (MPI_ERR_INFO_VALUE=30)
+       INTEGER MPI_ERR_SPAWN
+       PARAMETER (MPI_ERR_SPAWN=42)
+       INTEGER MPI_ERR_PENDING
+       PARAMETER (MPI_ERR_PENDING=18)
+       INTEGER MPI_ERR_WIN
+       PARAMETER (MPI_ERR_WIN=45)
+       INTEGER MPI_ERR_ASSERT
+       PARAMETER (MPI_ERR_ASSERT=53)
+       INTEGER MPI_ERR_NO_SUCH_FILE
+       PARAMETER (MPI_ERR_NO_SUCH_FILE=37)
+       INTEGER MPI_ERR_KEYVAL
+       PARAMETER (MPI_ERR_KEYVAL=48)
+       INTEGER MPI_ERR_INFO_NOKEY
+       PARAMETER (MPI_ERR_INFO_NOKEY=31)
+       INTEGER MPI_ERR_RANK
+       PARAMETER (MPI_ERR_RANK=6)
+       INTEGER MPI_ERR_NO_MEM
+       PARAMETER (MPI_ERR_NO_MEM=34)
+       INTEGER MPI_ERR_BUFFER
+       PARAMETER (MPI_ERR_BUFFER=1)
+       INTEGER MPI_ERR_DISP
+       PARAMETER (MPI_ERR_DISP=52)
+       INTEGER MPI_ERR_TYPE
+       PARAMETER (MPI_ERR_TYPE=3)
+       INTEGER MPI_ERR_INFO
+       PARAMETER (MPI_ERR_INFO=28)
+       INTEGER MPI_ERR_QUOTA
+       PARAMETER (MPI_ERR_QUOTA=39)
+       INTEGER MPI_ERR_RMA_CONFLICT
+       PARAMETER (MPI_ERR_RMA_CONFLICT=49)
+       INTEGER MPI_ERR_REQUEST
+       PARAMETER (MPI_ERR_REQUEST=19)
+       INTEGER MPI_ERR_OTHER
+       PARAMETER (MPI_ERR_OTHER=15)
+       INTEGER MPI_ERR_SERVICE
+       PARAMETER (MPI_ERR_SERVICE=41)
+       INTEGER MPI_ERR_UNSUPPORTED_DATAREP
+       PARAMETER (MPI_ERR_UNSUPPORTED_DATAREP=43)
+       INTEGER MPI_ERR_TOPOLOGY
+       PARAMETER (MPI_ERR_TOPOLOGY=10)
+       INTEGER MPI_ERR_DIMS
+       PARAMETER (MPI_ERR_DIMS=11)
+       INTEGER MPI_ERRORS_ARE_FATAL
+       PARAMETER (MPI_ERRORS_ARE_FATAL=1409286144)
+       INTEGER MPI_ERRORS_RETURN
+       PARAMETER (MPI_ERRORS_RETURN=1409286145)
+       INTEGER MPI_IDENT
+       PARAMETER (MPI_IDENT=0)
+       INTEGER MPI_CONGRUENT
+       PARAMETER (MPI_CONGRUENT=1)
+       INTEGER MPI_SIMILAR
+       PARAMETER (MPI_SIMILAR=2)
+       INTEGER MPI_UNEQUAL
+       PARAMETER (MPI_UNEQUAL=3)
+       INTEGER MPI_MAX
+       PARAMETER (MPI_MAX=1476395009)
+       INTEGER MPI_MIN
+       PARAMETER (MPI_MIN=1476395010)
+       INTEGER MPI_SUM
+       PARAMETER (MPI_SUM=1476395011)
+       INTEGER MPI_PROD
+       PARAMETER (MPI_PROD=1476395012)
+       INTEGER MPI_LAND
+       PARAMETER (MPI_LAND=1476395013)
+       INTEGER MPI_BAND
+       PARAMETER (MPI_BAND=1476395014)
+       INTEGER MPI_LOR
+       PARAMETER (MPI_LOR=1476395015)
+       INTEGER MPI_BOR
+       PARAMETER (MPI_BOR=1476395016)
+       INTEGER MPI_LXOR
+       PARAMETER (MPI_LXOR=1476395017)
+       INTEGER MPI_BXOR
+       PARAMETER (MPI_BXOR=1476395018)
+       INTEGER MPI_MINLOC
+       PARAMETER (MPI_MINLOC=1476395019)
+       INTEGER MPI_MAXLOC
+       PARAMETER (MPI_MAXLOC=1476395020)
+       INTEGER MPI_REPLACE
+       PARAMETER (MPI_REPLACE=1476395021)
+       INTEGER MPI_COMM_WORLD
+       PARAMETER (MPI_COMM_WORLD=1140850688)
+       INTEGER MPI_COMM_SELF
+       PARAMETER (MPI_COMM_SELF=1140850689)
+       INTEGER MPI_GROUP_EMPTY
+       PARAMETER (MPI_GROUP_EMPTY=1207959552)
+       INTEGER MPI_COMM_NULL
+       PARAMETER (MPI_COMM_NULL=67108864)
+       INTEGER MPI_WIN_NULL
+       PARAMETER (MPI_WIN_NULL=536870912)
+       INTEGER MPI_FILE_NULL
+       PARAMETER (MPI_FILE_NULL=0)
+       INTEGER MPI_GROUP_NULL
+       PARAMETER (MPI_GROUP_NULL=134217728)
+       INTEGER MPI_OP_NULL
+       PARAMETER (MPI_OP_NULL=402653184)
+       INTEGER MPI_DATATYPE_NULL
+       PARAMETER (MPI_DATATYPE_NULL=201326592)
+       INTEGER MPI_REQUEST_NULL
+       PARAMETER (MPI_REQUEST_NULL=738197504)
+       INTEGER MPI_ERRHANDLER_NULL
+       PARAMETER (MPI_ERRHANDLER_NULL=335544320)
+       INTEGER MPI_INFO_NULL
+       PARAMETER (MPI_INFO_NULL=469762048)
+       INTEGER MPI_TAG_UB
+       PARAMETER (MPI_TAG_UB=1681915906)
+       INTEGER MPI_HOST
+       PARAMETER (MPI_HOST=1681915908)
+       INTEGER MPI_IO
+       PARAMETER (MPI_IO=1681915910)
+       INTEGER MPI_WTIME_IS_GLOBAL
+       PARAMETER (MPI_WTIME_IS_GLOBAL=1681915912)
+       INTEGER MPI_UNIVERSE_SIZE
+       PARAMETER (MPI_UNIVERSE_SIZE=1681915914)
+       INTEGER MPI_LASTUSEDCODE
+       PARAMETER (MPI_LASTUSEDCODE=1681915916)
+       INTEGER MPI_APPNUM
+       PARAMETER (MPI_APPNUM=1681915918)
+       INTEGER MPI_WIN_BASE
+       PARAMETER (MPI_WIN_BASE=1711276034)
+       INTEGER MPI_WIN_SIZE
+       PARAMETER (MPI_WIN_SIZE=1711276036)
+       INTEGER MPI_WIN_DISP_UNIT
+       PARAMETER (MPI_WIN_DISP_UNIT=1711276038)
+       INTEGER MPI_MAX_ERROR_STRING
+       PARAMETER (MPI_MAX_ERROR_STRING=511)
+       INTEGER MPI_MAX_NAME_STRING
+       PARAMETER (MPI_MAX_NAME_STRING=62)
+       INTEGER MPI_MAX_PORT_NAME
+       PARAMETER (MPI_MAX_PORT_NAME=255)
+       INTEGER MPI_MAX_OBJECT_NAME
+       PARAMETER (MPI_MAX_OBJECT_NAME=127)
+       INTEGER MPI_MAX_INFO_KEY
+       PARAMETER (MPI_MAX_INFO_KEY=254)
+       INTEGER MPI_MAX_INFO_VAL
+       PARAMETER (MPI_MAX_INFO_VAL=1023)
+       INTEGER MPI_MAX_PROCESSOR_NAME
+       PARAMETER (MPI_MAX_PROCESSOR_NAME=128-1)
+       INTEGER MPI_MAX_DATAREP_STRING
+       PARAMETER (MPI_MAX_DATAREP_STRING=127)
+       INTEGER MPI_UNDEFINED, MPI_UNDEFINED_RANK
+       PARAMETER (MPI_UNDEFINED=(-32766))
+       PARAMETER (MPI_UNDEFINED_RANK=(-32766))
+       INTEGER MPI_KEYVAL_INVALID
+       PARAMETER (MPI_KEYVAL_INVALID=603979776)
+       INTEGER MPI_BSEND_OVERHEAD
+       PARAMETER (MPI_BSEND_OVERHEAD=(95))
+       INTEGER MPI_PROC_NULL
+       PARAMETER (MPI_PROC_NULL=-1)
+       INTEGER MPI_ANY_SOURCE
+       PARAMETER (MPI_ANY_SOURCE=-2)
+       INTEGER MPI_ANY_TAG
+       PARAMETER (MPI_ANY_TAG=-1)
+       INTEGER MPI_ROOT
+       PARAMETER (MPI_ROOT=-3)
+       INTEGER MPI_GRAPH
+       PARAMETER (MPI_GRAPH=1)
+       INTEGER MPI_CART
+       PARAMETER (MPI_CART=2)
+       INTEGER MPI_VERSION
+       PARAMETER (MPI_VERSION=2)
+       INTEGER MPI_SUBVERSION
+       PARAMETER (MPI_SUBVERSION=0)
+       INTEGER MPI_LOCK_EXCLUSIVE
+       PARAMETER (MPI_LOCK_EXCLUSIVE=234)
+       INTEGER MPI_LOCK_SHARED
+       PARAMETER (MPI_LOCK_SHARED=235)
+       INTEGER MPI_COMPLEX
+       PARAMETER (MPI_COMPLEX=1275070494)
+       INTEGER MPI_DOUBLE_COMPLEX
+       PARAMETER (MPI_DOUBLE_COMPLEX=1275072546)
+       INTEGER MPI_LOGICAL
+       PARAMETER (MPI_LOGICAL=1275069469)
+       INTEGER MPI_REAL
+       PARAMETER (MPI_REAL=1275069468)
+       INTEGER MPI_DOUBLE_PRECISION
+       PARAMETER (MPI_DOUBLE_PRECISION=1275070495)
+       INTEGER MPI_INTEGER
+       PARAMETER (MPI_INTEGER=1275069467)
+       INTEGER MPI_2INTEGER
+       PARAMETER (MPI_2INTEGER=1275070496)
+       INTEGER MPI_2COMPLEX
+       PARAMETER (MPI_2COMPLEX=1275072548)
+       INTEGER MPI_2DOUBLE_PRECISION
+       PARAMETER (MPI_2DOUBLE_PRECISION=1275072547)
+       INTEGER MPI_2REAL
+       PARAMETER (MPI_2REAL=1275070497)
+       INTEGER MPI_2DOUBLE_COMPLEX
+       PARAMETER (MPI_2DOUBLE_COMPLEX=1275076645)
+       INTEGER MPI_CHARACTER
+       PARAMETER (MPI_CHARACTER=1275068698)
+       INTEGER MPI_BYTE
+       PARAMETER (MPI_BYTE=1275068685)
+       INTEGER MPI_UB
+       PARAMETER (MPI_UB=1275068433)
+       INTEGER MPI_LB
+       PARAMETER (MPI_LB=1275068432)
+       INTEGER MPI_PACKED
+       PARAMETER (MPI_PACKED=1275068687)
+       INTEGER MPI_INTEGER1
+       PARAMETER (MPI_INTEGER1=1275068717)
+       INTEGER MPI_INTEGER2
+       PARAMETER (MPI_INTEGER2=1275068975)
+       INTEGER MPI_INTEGER4
+       PARAMETER (MPI_INTEGER4=1275069488)
+       INTEGER MPI_INTEGER8
+       PARAMETER (MPI_INTEGER8=1275070513)
+       INTEGER MPI_INTEGER16
+       PARAMETER (MPI_INTEGER16=1275072562)
+       INTEGER MPI_REAL4
+       PARAMETER (MPI_REAL4=1275069479)
+       INTEGER MPI_REAL8
+       PARAMETER (MPI_REAL8=1275070505)
+       INTEGER MPI_REAL16
+       PARAMETER (MPI_REAL16=1275072555)
+       INTEGER MPI_COMPLEX8
+       PARAMETER (MPI_COMPLEX8=1275070504)
+       INTEGER MPI_COMPLEX16
+       PARAMETER (MPI_COMPLEX16=1275072554)
+       INTEGER MPI_COMPLEX32
+       PARAMETER (MPI_COMPLEX32=1275076652)
+       INTEGER MPI_ADDRESS_KIND
+!DEC$ IF DEFINED (_WIN64)
+       PARAMETER (MPI_ADDRESS_KIND=8)
+!DEC$ ELSE
+!DEC$ ENDIF
+       INTEGER MPI_OFFSET_KIND
+       PARAMETER (MPI_OFFSET_KIND=8)
+       INTEGER MPI_COMBINER_NAMED
+       PARAMETER (MPI_COMBINER_NAMED=1)
+       INTEGER MPI_COMBINER_DUP
+       PARAMETER (MPI_COMBINER_DUP=2)
+       INTEGER MPI_COMBINER_CONTIGUOUS
+       PARAMETER (MPI_COMBINER_CONTIGUOUS=3)
+       INTEGER MPI_COMBINER_VECTOR
+       PARAMETER (MPI_COMBINER_VECTOR=4)
+       INTEGER MPI_COMBINER_HVECTOR_INTEGER
+       PARAMETER (MPI_COMBINER_HVECTOR_INTEGER=5)
+       INTEGER MPI_COMBINER_HVECTOR
+       PARAMETER (MPI_COMBINER_HVECTOR=6)
+       INTEGER MPI_COMBINER_INDEXED
+       PARAMETER (MPI_COMBINER_INDEXED=7)
+       INTEGER MPI_COMBINER_HINDEXED_INTEGER
+       PARAMETER (MPI_COMBINER_HINDEXED_INTEGER=8)
+       INTEGER MPI_COMBINER_HINDEXED
+       PARAMETER (MPI_COMBINER_HINDEXED=9)
+       INTEGER MPI_COMBINER_INDEXED_BLOCK
+       PARAMETER (MPI_COMBINER_INDEXED_BLOCK=10)
+       INTEGER MPI_COMBINER_STRUCT_INTEGER
+       PARAMETER (MPI_COMBINER_STRUCT_INTEGER=11)
+       INTEGER MPI_COMBINER_STRUCT
+       PARAMETER (MPI_COMBINER_STRUCT=12)
+       INTEGER MPI_COMBINER_SUBARRAY
+       PARAMETER (MPI_COMBINER_SUBARRAY=13)
+       INTEGER MPI_COMBINER_DARRAY
+       PARAMETER (MPI_COMBINER_DARRAY=14)
+       INTEGER MPI_COMBINER_F90_REAL
+       PARAMETER (MPI_COMBINER_F90_REAL=15)
+       INTEGER MPI_COMBINER_F90_COMPLEX
+       PARAMETER (MPI_COMBINER_F90_COMPLEX=16)
+       INTEGER MPI_COMBINER_F90_INTEGER
+       PARAMETER (MPI_COMBINER_F90_INTEGER=17)
+       INTEGER MPI_COMBINER_RESIZED
+       PARAMETER (MPI_COMBINER_RESIZED=18)
+       INTEGER MPI_MODE_NOCHECK
+       PARAMETER (MPI_MODE_NOCHECK=1024)
+       INTEGER MPI_MODE_NOSTORE
+       PARAMETER (MPI_MODE_NOSTORE=2048)
+       INTEGER MPI_MODE_NOPUT
+       PARAMETER (MPI_MODE_NOPUT=4096)
+       INTEGER MPI_MODE_NOPRECEDE
+       PARAMETER (MPI_MODE_NOPRECEDE=8192)
+       INTEGER MPI_MODE_NOSUCCEED
+       PARAMETER (MPI_MODE_NOSUCCEED=16384)
+       INTEGER MPI_THREAD_SINGLE
+       PARAMETER (MPI_THREAD_SINGLE=0)
+       INTEGER MPI_THREAD_FUNNELED
+       PARAMETER (MPI_THREAD_FUNNELED=1)
+       INTEGER MPI_THREAD_SERIALIZED
+       PARAMETER (MPI_THREAD_SERIALIZED=2)
+       INTEGER MPI_THREAD_MULTIPLE
+       PARAMETER (MPI_THREAD_MULTIPLE=3)
+       INTEGER MPI_MODE_RDONLY
+       PARAMETER (MPI_MODE_RDONLY=2)
+       INTEGER MPI_MODE_RDWR
+       PARAMETER (MPI_MODE_RDWR=8)
+       INTEGER MPI_MODE_WRONLY
+       PARAMETER (MPI_MODE_WRONLY=4)
+       INTEGER MPI_MODE_DELETE_ON_CLOSE
+       PARAMETER (MPI_MODE_DELETE_ON_CLOSE=16)
+       INTEGER MPI_MODE_UNIQUE_OPEN
+       PARAMETER (MPI_MODE_UNIQUE_OPEN=32)
+       INTEGER MPI_MODE_CREATE
+       PARAMETER (MPI_MODE_CREATE=1)
+       INTEGER MPI_MODE_EXCL
+       PARAMETER (MPI_MODE_EXCL=64)
+       INTEGER MPI_MODE_APPEND
+       PARAMETER (MPI_MODE_APPEND=128)
+       INTEGER MPI_MODE_SEQUENTIAL
+       PARAMETER (MPI_MODE_SEQUENTIAL=256)
+       INTEGER MPI_SEEK_SET
+       PARAMETER (MPI_SEEK_SET=600)
+       INTEGER MPI_SEEK_CUR
+       PARAMETER (MPI_SEEK_CUR=602)
+       INTEGER MPI_SEEK_END
+       PARAMETER (MPI_SEEK_END=604)
+       INTEGER MPI_ORDER_C
+       PARAMETER (MPI_ORDER_C=56)
+       INTEGER MPI_ORDER_FORTRAN
+       PARAMETER (MPI_ORDER_FORTRAN=57)
+       INTEGER MPI_DISTRIBUTE_BLOCK
+       PARAMETER (MPI_DISTRIBUTE_BLOCK=121)
+       INTEGER MPI_DISTRIBUTE_CYCLIC
+       PARAMETER (MPI_DISTRIBUTE_CYCLIC=122)
+       INTEGER MPI_DISTRIBUTE_NONE
+       PARAMETER (MPI_DISTRIBUTE_NONE=123)
+       INTEGER MPI_DISTRIBUTE_DFLT_DARG
+       PARAMETER (MPI_DISTRIBUTE_DFLT_DARG=-49767)
+       INTEGER MPI_DISPLACEMENT_CURRENT
+       PARAMETER (MPI_DISPLACEMENT_CURRENT=-54278278)
+       INTEGER MPI_BOTTOM, MPI_IN_PLACE
+       EXTERNAL MPI_DUP_FN, MPI_NULL_DELETE_FN, MPI_NULL_COPY_FN
+       EXTERNAL MPI_WTIME, MPI_WTICK
+       EXTERNAL PMPI_WTIME, PMPI_WTICK
+       EXTERNAL MPI_COMM_DUP_FN, MPI_COMM_NULL_DELETE_FN
+       EXTERNAL MPI_COMM_NULL_COPY_FN
+       EXTERNAL MPI_WIN_DUP_FN, MPI_WIN_NULL_DELETE_FN
+       EXTERNAL MPI_WIN_NULL_COPY_FN
+       EXTERNAL MPI_TYPE_DUP_FN, MPI_TYPE_NULL_DELETE_FN
+       EXTERNAL MPI_TYPE_NULL_COPY_FN
+       EXTERNAL MPI_CONVERSION_FN_NULL
+       DOUBLE PRECISION MPI_WTIME, MPI_WTICK
+       DOUBLE PRECISION PMPI_WTIME, PMPI_WTICK
+
+
+       COMMON /MPIPRIV1/ MPI_BOTTOM, MPI_IN_PLACE, MPI_STATUS_IGNORE
+
+       COMMON /MPIPRIV2/ MPI_STATUSES_IGNORE, MPI_ERRCODES_IGNORE
+       SAVE /MPIPRIV1/,/MPIPRIV2/
+
+       COMMON /MPIPRIVC/ MPI_ARGVS_NULL, MPI_ARGV_NULL
+       SAVE   /MPIPRIVC/
Index: branches/LMDZ_WRFmeas/WRFV3/clean
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/clean	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/clean	(revision 17)
@@ -0,0 +1,66 @@
+#!/bin/csh -f
+
+set nonomatch
+
+
+foreach dir ( frame chem share dyn_em dyn_exp dyn_nmm phys main tools )
+  if ( -d $dir ) then
+    ( cd $dir ; echo $dir ; /bin/rm -f core wrf *.f90 *.exe *.kmo *.mod *.o *.obj *.inc *.F90 *.a \
+                      db_* Warnings module_state_description.F module_dm.F gmeta \
+                      wrfdata whatiread rsl.* show_domain* )
+  endif
+end
+
+if ( -d var ) then
+  ( cd var ; make clean )
+endif
+
+( cd tools/CodeBase ; make clean )
+
+( cd inc ; /bin/rm -f *.inc namelist.default )
+
+
+set echo
+set arg="$1"
+if ( "$arg" == '-a' || "$arg" == '-aa' ) then
+  if ( -d var ) then
+    ( cd var ; make superclean )
+    ( cd var/obsproc ; make clean )
+  endif
+  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 external/atm_ocn ; 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 )
+  if ( "$arg" != '-aa' ) then
+    ( 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 */URBPARM.TBL */grib2map.tbl \
+	  */CAM_ABS_DATA */CAM_AEROPT_DATA */RRTMG_LW_DATA */RRTMG_SW_DATA \
+	  */ozone.formatted */ozone_lat.formatted */ozone_plev.formatted \
+	  */gribmap.txt */tr??t?? */co2_trans) >& /dev/null
+  ( cd lmdz ; make clean )
+  endif
+endif
+
+#cms++
+
+if ( -d chem ) then
+  if ( -e chem/KPP )then
+    ( cd chem/KPP; ./clean_kpp ) 
+  endif
+endif
+#cms--
Index: branches/LMDZ_WRFmeas/WRFV3/compile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/compile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/compile	(revision 17)
@@ -0,0 +1,412 @@
+#!/bin/csh -f
+
+setenv START_OF_COMPILE "`date`"
+
+cont1:
+
+if ( !  -e configure.wrf  ) then
+   if ( $1 == "all_wrfvar" ) then
+      ./configure wrfda
+      set dontask
+   else
+      ./configure $1
+      set dontask
+   endif
+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
+    if ( "$a" == "all_wrfvar" ) then
+      grep "DA_CORE=1" configure.wrf > /dev/null
+      if ( ! $status ) then 
+         # If configuration file has DA_CORE=1 hardwired, ok to set WRF_DA_CORE to 1
+         setenv WRF_DA_CORE 1
+      endif
+    endif
+    if ( "$a" == "nmm_real" ) then
+      grep "NMM_CORE=1" configure.wrf > /dev/null
+      if ( ! $status ) then 
+         # If configuration file has NMM_CORE=1 hardwired, ok to set WRF_NMM_CORE to 1
+         if ( ! $?WRF_NMM_CORE ) setenv WRF_NMM_CORE 1
+      endif
+    endif
+    if ( "$a" == "-j" ) then
+      shift argv
+      setenv J "-j $argv[1]"
+    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_DA_CORE )     setenv WRF_DA_CORE 0
+  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_DFI_RADAR )   setenv WRF_DFI_RADAR 0
+  if ( ! $?HWRF )            setenv HWRF 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
+
+  if ( ! $?DA_ARCHFLAGS )     setenv DA_ARCHFLAGS ""
+
+  if ( ( $WRF_DA_CORE == 1 )  && ( ! -d var ) ) then
+    echo "  "
+    echo "You need to download and untar the Var code, or"
+    echo "unset the WRF_DA_CORE env variable."
+    echo "  "
+    exit
+  endif
+
+  if ( ( $WRF_CHEM == 1 )  && ( ! -d chem ) ) then
+    echo "  "
+    echo "You need to download and untar the chem code, or"
+    echo "unset the WRF_CHEM env variable."
+    echo "  "
+    exit
+  endif
+
+  set overwrite=0
+  if ($WRF_NMM_CORE == 1 && $WRF_DFI_RADAR == 1 ) then
+    echo "radar dfi not yet supported in NMM core, set WRF_DFI_RADAR to 0 "
+  endif
+
+  if ($WRF_NMM_CORE == 1 && $WRF_CHEM == 1 ) then
+    echo "Chemistry not yet supported in NMM core, set WRF_CHEM to 0 "
+    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 ("$arglist" == 'nmm_real' && $WRF_NMM_CORE == 0) then
+    echo WRF_NMM_CORE must be set to 1 in order to compile nmm_real
+    exit 2
+  endif
+  if (($WRF_EM_CORE == 1)&&($WRF_DA_CORE == 0 ) &&($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 == 1)&&($WRF_DFI_RADAR == 1 ))  then
+    if ( ! -f Registry/Registry ) then
+      set overwrite=1
+    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 == 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
+  else if ( $WRF_DA_CORE == 1 )  then
+    if ( ! -f Registry/Registry ) then
+      set overwrite=1
+    else
+      head -2 Registry/Registry | tail -1 | grep WRFVAR > /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
+      echo copying Registry/Registry.wrfvar to Registry/Registry
+      echo '## WARNING: this file is autogenerated from Registry/Registry.wrfvar. Changes may be lost' > Registry/Registry
+      /bin/cat Registry/Registry.wrfvar >> Registry/Registry
+    endif
+    if ( $?CRTM ) then
+       if ( ! $?BUFR ) then
+          echo "  "
+          echo "BUFR library will be compiled for radiance data ingest."
+          echo "  "
+          setenv BUFR 1
+       endif
+       setenv CRTM_CPP "-DCRTM"
+       setenv CRTM_LIB "-L../external/crtm/libsrc -lCRTM"
+       setenv CRTM_SRC "-I../external/crtm/libsrc"
+       setenv SFC_CRTM `grep '^SFC' configure.wrf | awk '{print $3}' | sed -e 's/\// /g' | awk '{print $NF}'`
+       setenv ABI_CRTM `grep '^SFC' configure.wrf | grep -o -E "\-m[0-9]{2}"`
+    else
+       setenv CRTM_CPP " "
+       setenv CRTM_LIB " "
+       setenv CRTM_SRC " "
+    endif
+    if ( $?RTTOV ) then
+       if ( ! $?BUFR ) then
+          echo "  "
+          echo "BUFR library is needed for radiance data ingest."
+          echo "  "
+          setenv BUFR 1
+       endif
+       setenv RTTOV_CPP "-DRTTOV"
+       setenv RTTOV_LIB "-L${RTTOV}/lib -lrttov10.1.0_coef_io -lrttov10.1.0_emis_atlas -lrttov10.1.0_main"
+       setenv RTTOV_SRC "-I${RTTOV}/include -I${RTTOV}/mod"
+    else
+       setenv RTTOV_CPP " "
+       setenv RTTOV_LIB " "
+       setenv RTTOV_SRC " "
+    endif
+    if ( $?BUFR ) then
+       setenv BUFR_CPP "-DBUFR"
+       setenv BUFR_LIB "-L../external/bufr -lbufr"
+    else
+       setenv BUFR_CPP " "
+       setenv BUFR_LIB " "
+    endif
+    if ( $?WAVELET ) then
+       setenv WAVELET_LIB "../external/wavelet/libWavelet.a ../external/wavelet/lib_wavelet.a"
+    else
+       setenv WAVELET_LIB " "
+    endif
+    if ( $?MADIS ) then
+       setenv MADIS_CPP "-DMADIS"
+       setenv MADIS_STATIC ${MADIS}/static
+       setenv MADIS_LIB "-L${MADIS} -lmadis"
+    else
+       setenv MADIS_CPP " "
+       setenv MADIS_LIB " "
+    endif
+    setenv DA_ARCHFLAGS "${BUFR_CPP} ${MADIS_CPP} -DFFTPACK -DNORESHAPE"
+  endif
+  if (($WRF_NMM_CORE == 1)&&($WRF_CHEM == 0 )) then
+    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_new
+    set registryvalue=`grep 'dimspec.* q ' Registry/registry.dimspec | sed -e 's/..*constant=//' -e 's/ ..*$//'`
+    set preamblevalue=`grep 'DNMM_MAX_DIM=.*' arch/preamble_new | 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_new ($preamblevalue)"
+      echo "Please fix and try again."
+      exit 2
+    endif
+  endif
+
+  echo " "
+  echo -n "Compiling: "
+  if ( $WRF_DA_CORE ) echo -n "WRF_DA_CORE "
+  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 " "
+
+  if ( ! $?WRF_SRC_ROOT_DIR ) setenv WRF_SRC_ROOT_DIR `pwd`
+
+# new dec 2009.  check to see if make supports parallel -j option
+  make -j 2 >& /dev/null
+  if ( $status == 0 ) then              # Parallel make ok
+    if ( ! $?J ) then                   # J not defined
+      echo setting parallel make -j 2   # Set default to 2
+      setenv J "-j 2"
+    else
+#     J is defined, check that it is a correctly formed variable
+      set first2chars = `echo $J | cut -c 1-2`         # Are 1st two chars are -j?
+      set second_word = `echo $J | cut -d" " -f2`      # Is second word a number?
+      if    ( "$first2chars" == "-j" ) then
+         if ( ( "$second_word" >= "2"  )  && \
+              ( "$second_word" <= "20" ) ) then
+            echo setting parallel make $J
+         else if ( "$second_word" == "1" ) then
+            echo setting serial make $J
+         else
+            echo "badly formed -j option for parallel make: $J"
+            echo "or you set the number of processors above 20 "
+            echo setting parallel make -j 2            # Set default to 2
+            setenv J "-j 2"
+         endif
+      else
+         if ( "$J" == "" ) then     # J blank is OK
+            echo setting serial make $J
+         else
+            echo "parallel option for make is -j, you entered: $first2chars"
+            echo setting parallel make -j 2               # Set default to 2
+            setenv J "-j 2"
+         endif
+      endif
+    endif
+  else
+    echo not setting parallel make
+  endif
+
+  make $arglist A2DCASE="$A2DCASE" WRF_SRC_ROOT_DIR="$WRF_SRC_ROOT_DIR"
+
+endif
+
+exit 0
+
+hlp:
+
+echo ' '
+echo 'Usage:'
+echo ' '
+echo '   compile [-d] [-j n] 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 -d                 compile without optimization and with debugging'
+echo '  compile -j n               parallel make using n tasks if supported (default 2)'
+echo '  compile -h                 help message'
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/configure
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/configure	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/configure	(revision 17)
@@ -0,0 +1,749 @@
+#!/bin/sh
+
+# parse argument list
+
+thiscmd=$0
+
+FORTRAN_COMPILER_TIMER=""
+opt_level="-f"
+print_usage=""
+chemistry=""
+wrf_core=""
+while [ $# -ge 1 ]; do
+    case $1 in
+      -d) opt_level="-d" ;;
+      -s) opt_level="-s" ;;
+      -f) opt_level="-f" ;;
+      -h) print_usage="yes" ;;
+      -help) print_usage="yes" ;;
+      -os) shift ; WRF_OS=$1 ;;
+      -mach) shift ; WRF_MACH=$1 ;;
+      -time) shift ; FORTRAN_COMPILER_TIMER=$1 ;;
+      chem) WRF_CHEM=1  ;;
+      kpp) WRF_KPP=1  ;;
+      radardfi) WRF_DFI_RADAR=1  ;;
+      wrfda) wrf_core=DA_CORE ;;
+      4dvar) wrf_core=4D_DA_CORE ;;
+      arw) wrf_core=EM_CORE  ;;
+      nmm) wrf_core=NMM_CORE  ;;
+      coamps) wrf_core=COAMPS_CORE  ;;
+      exp) wrf_core=EXP_CORE  ;;
+      titan) WRF_TITAN=1 ; break ;;
+      mars) WRF_MARS=1 ; break ;;
+      venus) WRF_VENUS=1 ; break ;;
+    esac
+    shift
+done
+if [ -n "$print_usage" ] ; then
+  echo usage: $thiscmd '[-d|-s|-f|-os os|-mach mach|-time timecommand] [chem] [kpp]'
+  exit 
+fi
+
+if `pwd | grep ' ' > /dev/null ` ; then
+  echo '************************** W A R N I N G ************************************'
+  echo The current working directory has spaces in some components of its path name
+  echo and this may cause problems for your build.  This can occur, for example, on
+  echo Windows systems.  It is strongly recommended that you install WRF and other
+  echo related software such as NetCDF in directories whose path names contain no
+  echo white space.  On Win, for example, create and install in a directory under C:.
+  echo '*****************************************************************************'
+fi
+
+
+# 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
+
+USENETCDFF=""  # see below
+if [ -n "$NETCDF" ] ; then
+  echo "Will use NETCDF in dir: $NETCDF"
+# for 3.6.2 and greater there might be a second library, libnetcdff.a .  Check for this and use 
+# if available
+  if [ -f "$NETCDF/lib/libnetcdff.a" ] ; then
+    USENETCDFF="-lnetcdff"
+  fi
+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
+
+if [ "$wrf_core" = "DA_CORE" ]; then
+   if [ -n "$WRFPLUS_DIR" ] ; then
+      echo "To compile WRFDA without 4DVAR, please remove \$WRFPLUS_DIR from environment. "
+      exit
+   fi
+fi
+
+if [ "$wrf_core" = "4D_DA_CORE" ]; then
+   if [ -n "$WRFPLUS_DIR" ] ; then
+      echo "Will use WRFPLUS in dir: $WRFPLUS_DIR"
+   else
+      echo "WRFPLUS_DIR not set in environment. Please compile WRFPLUS and set WRFPLUS_DIR."
+      exit
+   fi
+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" -o "$os" = "Interix" ] ; then
+      mach="ARCH"
+    else
+      xxx=`expr "$os" : '\(.........\).*'`
+      if [ "$xxx"  = "CYGWIN_NT" ] ; then
+        os=$xxx
+      fi
+      if [ "$os" = "OSF1" -o "$os" = "Linux" -o "$os" = "UNICOS/mp" -o "$os" = "UNIX_System_V" -o  "$os" = "CYGWIN_NT" ] ; then
+        mach=`uname -m`
+        if [ "$mach" = "ia64" -a -f /etc/sgi-release ] ; then
+          mach="Altix"
+        fi
+      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_new.pl
+if [ -n "$WRF_MARS" ] ; then
+  if [ $WRF_MARS = 1 ] ; then
+    echo building WRF for Mars
+    compileflags="${compileflags}!-DPLANET!-DMARS"
+    echo $compileflags
+  fi
+fi
+
+if [ -n "$WRF_TITAN" ] ; then
+  if [ $WRF_TITAN = 1 ] ; then
+    echo building WRF for Mars
+    compileflags="${compileflags}!-DPLANET!-DTITAN"
+  fi
+fi
+
+if [ -n "$WRF_VENUS" ] ; then
+  if [ $WRF_VENUS = 1 ] ; then
+    echo building WRF for Mars
+    compileflags="${compileflags}!-DPLANET!-DVENUS"
+  fi
+fi
+if [ -n "$WRF_NMM_CORE" ]; then
+  if [ $WRF_NMM_CORE = 1 ]; then
+    if [ -n "$HWRF" ]; then
+      if [ $HWRF = 1 ]; then
+        echo building WRF with HWRF option
+        compileflags="${compileflags}!-DHWRF=1"
+        if [ -n "$HWRFX" ]; then
+          if [ $HWRFX = 1 ]; then
+            compileflags="${compileflags}!-DHWRFX=1"
+          fi
+        fi
+      fi
+    fi
+  fi
+fi
+if [ -n "$WRF_DFI_RADAR" ] ; then
+  if [ $WRF_DFI_RADAR = 1 ] ; then
+    echo building WRF with radar dfi option
+    compileflags="${compileflags}!-DWRF_DFI_RADAR=1"
+  fi
+fi
+if [ -n "$WRF_CHEM" ] ; then
+  if [ $WRF_CHEM = 1 ] ; then
+    echo building WRF with chemistry option
+    compileflags="${compileflags}!-DWRF_CHEM!-DBUILD_CHEM=1"
+    if [ -n "$WRF_KPP" ] ; then
+      if [ $WRF_KPP = 1 ] ; then    
+        echo building WRF with KPP chemistry option
+        compileflags="${compileflags}!-DWRF_KPP"
+      fi
+    fi 
+  else
+    compileflags="${compileflags} "
+  fi
+else
+  compileflags="${compileflags} "
+fi
+
+if [ `which timex` ] ; then
+  FORTRAN_COMPILER_TIMER=timex
+fi
+
+# Found perl, so proceed with configuration
+if test -n "$PERL" ; then
+   srch=`grep -i "^#ARCH.*$os" arch/configure_new.defaults | grep -i "$mach"`
+   if [ -n "$srch" ] ; then
+     $PERL arch/Config_new.pl -dmparallel=$COMMLIB -ompparallel=$OMP -perl=$PERL \
+          -netcdf=$NETCDF -pnetcdf=$PNETCDF -phdf5=$PHDF5 -os=$os -mach=$mach -ldflags=$ldflags \
+          -compileflags=$compileflags -opt_level=$opt_level -USENETCDFF=$USENETCDFF -time=$FORTRAN_COMPILER_TIMER \
+          -wrf_core=$wrf_core
+     if test ! -f configure.wrf ; then
+       exit 1
+     fi
+     if [ "$opt_level" = "-d" ] ; then
+        sed -e 's/FCOPTIM[	 ]*=/& # /' -e '/FCDEBUG[	 ]*=/s/#//g' configure.wrf > configure.wrf.edit
+        /bin/mv configure.wrf.edit configure.wrf
+     fi
+   else
+     WRF_OS=$os ; export WRF_OS
+     WRF_MACH=$mach ; export WRF_MACH
+     echo '*** Configuration not found in configure_new.defaults; checking configure_old.defaults ***'
+
+     # see if we still have an old setting laying around from v2
+     if [ "$opt_level" = "-d" ] ; then
+       arch/config_old $opt_level 
+     else
+       arch/config_old
+     fi
+
+   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 '/^DM_CC.*=/s/$/ -DMPI2_SUPPORT/' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf
+      if [ `hostname | cut -c 1-2` = "be" ] ; then
+         sed '/^ARCH_LOCAL.*=/s/$/ -DUSE_MPI_IN_PLACE/' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf
+      fi
+    else
+      echo "  " MPI_Comm_f2c and MPI_Comm_c2f are not supported
+    fi
+    grep 'OMPCPP *= *-D_OPENMP' configure.wrf > /dev/null
+    if [ $? = 0 ] ; then
+      echo testing for MPI_Init_thread
+      /bin/rm -f tools/mpi2_thread_test
+      ( make mpi2_thread_test 2> /dev/null ) 1> /dev/null
+      if test -e tools/mpi2_thread_test.o ; then
+        echo "  " MPI_Init_thread is supported
+        sed '/^DM_CC.*=/s/$/ -DMPI2_THREAD_SUPPORT/' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf
+      else 
+        echo "  " MPI_Init_thread is not supported
+      fi
+    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 [ "$os" = "Darwin" ] ; then
+    # fseeko64 does not exist under Darwin fseeko does. Remove the 0 length executable
+    # file that might get generated anyway, even though the compiler complains about missing reference.
+    /bin/rm -f tools/fseeko64_test 
+  fi
+  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_new.defaults"
+
+if test -n $NETCDF ; then
+  grep nf_format_64bit $NETCDF/include/netcdf.inc > /dev/null
+  configure_aaaa=$? ; export configure_aaaa
+  if [ $configure_aaaa -a -z "$WRFIO_NCD_LARGE_FILE_SUPPORT" ] ; then
+    echo "NetCDF users note:"
+    echo " This installation of NetCDF supports large file support.  To enable large file" 
+    echo " support in NetCDF, set the environment variable WRFIO_NCD_LARGE_FILE_SUPPORT"
+    echo " to 1 and run configure again. Set to any other value to avoid this message."
+  fi
+fi
+echo "  "
+
+if [ "$wrf_core" = "DA_CORE" ]; then
+  if [ "`grep '^SFC' configure.wrf | grep -i 'gfortran'`" != "" ]; then
+    echo "WRFDA using gfortran needs realsize=8"
+    sed -e '/^PROMOTION.*=/s/#//' configure.wrf > configure.wrf.edit
+    /bin/mv configure.wrf.edit configure.wrf
+  fi
+fi
+
+#Checking cross-compiling capability for some particular environment 
+#on Linux and Mac box
+
+if [ $os = "Linux" -o $os = "Darwin" ]; then
+
+  SFC=`grep '^SFC' configure.wrf | awk '{print $3}'`
+  SCC=`grep '^SCC' configure.wrf | awk '{print $3}'`
+  CCOMP=`grep '^CCOMP' configure.wrf | awk '{print $3}'`
+
+  SFC="`type $SFC 2>/dev/null | awk '{print $NF}' | sed -e 's/(//g;s/)//g'`"
+  SCC="`type $SCC 2>/dev/null | awk '{print $NF}' | sed -e 's/(//g;s/)//g'`"
+  CCOMP="`type $CCOMP 2>/dev/null | awk '{print $NF}' | sed -e 's/(//g;s/)//g'`"
+
+  if [ -e $NETCDF/lib/libnetcdf.a -a "$SFC" != "" -a "$SCC" != "" -a "$CCOMP" != "" ]; then
+
+    SFC_MULTI_ABI=0
+    SCC_MULTI_ABI=0
+    CCOMP_MULTI_ABI=0
+    CROSS_COMPILING=0
+
+    foo=`mktemp foo_$$`
+
+    echo
+    echo Testing for NetCDF, C and Fortran compiler
+    echo
+
+cat > ${foo}.c <<EOF 
+ int main(int argc, char ** argv)
+ {
+     return (0);
+ }
+EOF
+
+cat > ${foo}.f <<EOF
+          program test_exit
+            integer :: STATUS = 0
+            call EXIT(STATUS)
+          end program test_exit
+EOF
+
+    ar p $NETCDF/lib/libnetcdf.a netcdf.o > ${foo}.o
+    netcdf_arch="`file ${foo}.o | grep -o -E '[0-9]{2}-bit|i386'`"
+    rm ${foo}.o
+
+    $SFC -o ${foo} ${foo}.f > /dev/null 2>&1 
+    SFC_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`"
+    rm ${foo} 2> /dev/null
+
+    $SCC -o ${foo} ${foo}.c > /dev/null 2>&1
+    SCC_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`"
+    CCOMP_arch=$SCC_arch
+    rm ${foo} 2> /dev/null
+
+    if [ "$SCC" != "$CCOMP" ]; then
+      $CCOMP -o ${foo} ${foo}.c > /dev/null 2>&1
+      CCOMP_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`"
+      rm ${foo} 2> /dev/null
+    fi
+
+    if [ "$SFC_arch" = "" -o "$SCC_arch" = "" -o "$CCOMP_arch" = "" ]; then
+      echo "  One of compilers testing failed!"
+      echo "  Please check your compiler"
+      echo 
+      rm ${foo}* 2> /dev/null
+      exit
+    else
+      cp configure.wrf configure.wrf.edit
+    fi
+
+    case $netcdf_arch in
+
+      32-bit|i386 )
+
+      if [ "$SFC_arch" = "64-bit" ] ; then
+        CROSS_COMPILING=1
+        $SFC -m32 -o ${foo} ${foo}.f > /dev/null 2>&1
+        if [ $? = 0 ]; then
+          SFC_MULTI_ABI=1
+          sed '/^SFC.*=/s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp
+          mv configure.wrf.tmp configure.wrf.edit
+        fi
+      fi
+      if [ "$SCC_arch" = "64-bit" ] ; then
+        CROSS_COMPILING=1
+        $SCC -m32 -o ${foo} ${foo}.c > /dev/null 2>&1
+        if [ $? = 0 ]; then
+          SCC_MULTI_ABI=1
+          sed '/^SCC.*=/s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp
+          mv configure.wrf.tmp  configure.wrf.edit
+        fi
+      fi
+
+      if [ "$CCOMP_arch" = "64-bit" ] ; then
+        CROSS_COMPILING=1
+        if [ "$CCOMP" != "$SCC" ]; then
+          $CCOMP -m32 -o ${foo} ${foo}.c > /dev/null 2>&1
+          if [ $? = 0 ]; then
+            CCOMP_MULTI_ABI=1
+            sed '/^CCOMP/ s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp
+            mv configure.wrf.tmp  configure.wrf.edit
+          fi
+        else
+          CCOMP_MULTI_ABI=1
+          sed '/^CCOMP/ s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp
+          mv configure.wrf.tmp  configure.wrf.edit
+        fi
+      fi
+
+      if [ $CROSS_COMPILING -eq 1 ] ; then
+        echo NOTE:
+        echo This installation NetCDF is 32-bit
+        if [ \( $SFC_MULTI_ABI -ne 1 -a "$SFC_arch" = "64-bit" \) \
+             -o \( $SCC_MULTI_ABI -ne 1 -a "$SCC_arch" = "64-bit" \) \
+             -o \( $CCOMP_MULTI_ABI -ne 1 -a "$CCOMP_arch" = "64-bit" \) ] ; then
+             rm configure.wrf.edit
+             echo One of compilers is 64-bit and doesn\'t support cross-compiling.
+             echo Please check your NETCDF lib and compiler
+        else
+          echo -m32 is appended to configure.wrf
+          echo It will be forced to build in 32-bit.
+          echo If you don\'t want 32-bit binaries, please use 64-bit NetCDF, and re-run the configure script.
+        fi
+      fi
+      ;;
+
+      64-bit )
+
+      if [ "$SFC_arch" = "32-bit" -o "$SFC_arch" = "i386" ] ; then
+        CROSS_COMPILING=1
+        $SFC -m64 -o ${foo} ${foo}.f > /dev/null 2>&1
+        if [ $? = 0 ]; then
+          SFC_MULTI_ABI=1
+          sed '/^SFC.*=/s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp
+          mv configure.wrf.tmp configure.wrf.edit
+        fi
+      fi
+      if [ "$SCC_arch" = "32-bit" -o "$SCC_arch" = "i386" ] ; then
+        CROSS_COMPILING=1
+        $SCC -m64 -o ${foo} ${foo}.c > /dev/null 2>&1
+        if [ $? = 0 ]; then
+          SCC_MULTI_ABI=1
+          sed '/^SCC.*=/s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp
+          mv configure.wrf.tmp configure.wrf.edit
+        fi
+      fi
+
+      if [ "$CCOMP_arch" = "32-bit" -o "$CCOMP_arch" = "i386" ] ; then
+        CROSS_COMPILING=1
+        if [ "$CCOMP" != "$SCC" ]; then
+          $CCOMP -m64 -o ${foo} ${foo}.c > /dev/null 2>&1
+          if [ $? = 0 ]; then
+            CCOMP_MULTI_ABI=1
+            sed '/^CCOMP/ s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp
+            mv configure.wrf.tmp  configure.wrf.edit
+          fi
+        else
+          CCOMP_MULTI_ABI=1
+          sed '/^CCOMP/ s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp
+          mv configure.wrf.tmp  configure.wrf.edit
+        fi
+      fi
+
+      if [ $CROSS_COMPILING -eq 1 ] ; then
+        echo NOTE:
+        echo This installation NetCDF is 64-bit
+        if [ \( $SFC_MULTI_ABI -ne 1 -a "$SFC_arch" != "64-bit" \) \
+            -o \( $SCC_MULTI_ABI -ne 1 -a "$SCC_arch" != "64-bit" \) \
+            -o \( $CCOMP_MULTI_ABI -ne 1 -a "CCOMP_arch" != "64-bit" \) ]; then
+            rm configure.wrf.edit
+            echo One of Compilers is 32-bit and doesn\'t support cross-compiling.
+            echo Please check your NetCDF lib and compiler
+        else
+          echo -m64 is appended to configure.wrf
+          echo It will be forced to build in 64-bit. 
+          echo If you don\'t want 64-bit binaries, please use 32-bit NetCDF, and re-run the configure script.
+        fi
+      fi
+      ;;
+    esac
+
+    if [ -e configure.wrf.edit ]; then 
+      mv configure.wrf.edit configure.wrf
+    fi
+
+    rm ${foo}* 2> /dev/null
+
+    if [ $CROSS_COMPILING -eq 0 ] ; then
+      echo This installation NetCDF is $netcdf_arch
+      echo C compiler is $SCC_arch
+      echo Fortran compiler is $SFC_arch
+      echo It will build in $netcdf_arch
+    fi
+    echo
+  fi
+fi
Index: branches/LMDZ_WRFmeas/WRFV3/configure.serial_lmdz2wrf.lmd.wrf
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/configure.serial_lmdz2wrf.lmd.wrf	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/configure.serial_lmdz2wrf.lmd.wrf	(revision 17)
@@ -0,0 +1,522 @@
+# 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) \
+	   -DDA_CORE=$(WRF_DA_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	=	32768
+
+#### Size of bitmasks (in 4byte integers) of stream masks for WRF I/O
+
+MAX_HISTORY = 25
+
+IWORDSIZE = 4
+DWORDSIZE = 8
+LWORDSIZE = 4
+
+##############################################################################
+#### 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 $(WRF_SRC_ROOT_DIR)/arch/standard.sed
+SED_FTN = $(WRF_SRC_ROOT_DIR)/tools/standard.exe
+
+# 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 = $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90/module_utility.o
+# select -I options for external/io_esmf vs. external/esmf_time_f90
+ESMF_IO_INC         = -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90
+# select -I options for separately installed ESMF library, if present
+ESMF_MOD_INC        =  $(ESMF_IO_INC)
+# 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
+
+##############################################################################
+
+LIBWRFLIB = libwrflib.a
+
+
+#### Architecture specific settings ####
+
+# Settings for x86_64 Linux, gfortran compiler with gcc   (serial)
+#
+DMPARALLEL      =        1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -fopenmp
+OMPCC           =       # -fopenmp
+SFC             =       gfortran
+SCC             =       gcc
+CCOMP           =       gcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =        $(SFC)
+CC              =       $(SCC) -DFSEEKO64_OK 
+LD              =       $(FC)
+RWORDSIZE       =       $(NATIVE_RWORDSIZE)
+PROMOTION       =       # -fdefault-real-8  # uncomment manually
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -w -O3 -c -DLANDREAD_STUB
+LDFLAGS_LOCAL   =       
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3 -ftree-vectorize -ftree-loop-linear -funroll-loops
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT		=       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -ffixed-form
+FORMAT_FREE     =       -ffree-form -ffree-line-length-none
+FCSUFFIX        =       
+BYTESWAPIO      =       -fconvert=big-endian -frecord-marker=4
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -G
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+######################
+# POSTAMBLE
+
+FGREP = fgrep -iq
+
+ARCHFLAGS       =    $(COREDEFS) -DIWORDSIZE=$(IWORDSIZE) -DDWORDSIZE=$(DWORDSIZE) -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=$(LWORDSIZE) \
+                     $(ARCH_LOCAL) \
+                     $(DA_ARCHFLAGS) \
+                      -DDM_PARALLEL \
+                      -DSTUBMPI \
+                      -DNETCDF \
+                      -DLMDZ \
+                       \
+                       \
+                       \
+                       \
+                       \
+                       \
+                       \
+                      -DUSE_ALLOCATABLES \
+                      -DGRIB1 \
+                      -DINTIO \
+                      -DLIMIT_ARGS \
+                      -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) \
+                      -DMAX_DOMAINS_F=$(MAX_DOMAINS) \
+                      -DMAX_HISTORY=$(MAX_HISTORY) \
+		      -DNMM_NEST=$(WRF_NMM_NEST)
+CFLAGS          =    $(CFLAGS_LOCAL) -DDM_PARALLEL -DSTUBMPI \
+                      -DMAX_HISTORY=$(MAX_HISTORY)
+FCFLAGS         =    $(FCOPTIM) $(FCBASEOPTS)
+ESMF_LIB_FLAGS  =    
+ ESMF_IO_LIB     =    -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time
+ESMF_IO_LIB_EXT =    -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time
+INCLUDE_MODULES =    $(MODULE_SRCH_FLAG) \
+                     $(ESMF_MOD_INC) $(ESMF_LIB_FLAGS) \
+                      -I$(WRF_SRC_ROOT_DIR)/main \
+                      -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf \
+                      -I$(WRF_SRC_ROOT_DIR)/external/io_int \
+                      -I$(WRF_SRC_ROOT_DIR)/frame \
+                      -I$(WRF_SRC_ROOT_DIR)/share \
+                      -I$(WRF_SRC_ROOT_DIR)/phys \
+                      -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc \
+                      -I$(NETCDFPATH)/include \
+                      -I$(WRF_SRC_ROOT_DIR)/lmdz
+                      
+REGISTRY        =    Registry
+
+ LIB_BUNDLED     = \
+                      $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5/libfftpack.a \
+                      $(WRF_SRC_ROOT_DIR)/external/io_grib1/libio_grib1.a \
+                      $(WRF_SRC_ROOT_DIR)/external/io_grib_share/libio_grib_share.a \
+                      $(WRF_SRC_ROOT_DIR)/external/io_int/libwrfio_int.a \
+                      $(ESMF_IO_LIB) \
+                      $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a \
+                      $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o \
+                      $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o 
+
+ LIB_EXTERNAL    = \
+                      -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf -L${HOME}/bin/gcc_netcdf-4.3.0/lib  -lnetcdf -lnetcdff $(WRF_SRC_ROOT_DIR)/lmdz/lmdz.a 
+
+LIB             =    $(LIB_BUNDLED) $(LIB_EXTERNAL) $(LIB_LOCAL)
+LDFLAGS         =    $(OMP) $(FCFLAGS) $(LDFLAGS_LOCAL) 
+ENVCOMPDEFS     =    
+WRF_CHEM	=	0 
+CPPFLAGS        =    $(ARCHFLAGS) $(ENVCOMPDEFS) -I$(LIBINCLUDE) $(TRADFLAG) 
+NETCDFPATH      =    ${HOME}/bin/gcc_netcdf-4.3.0
+PNETCDFPATH     =    
+
+bundled:  wrf_ioapi_includes wrfio_grib_share wrfio_grib1 wrfio_int esmf_time fftpack 
+external:  wrfio_nf   $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms_rsllite module_dm_rsllite $(ESMF_TARGET)
+
+lmdza: $(WRF_SRC_ROOT_DIR)/lmdz/lmdz.a
+
+######################
+externals: bundled external
+
+gen_comms_serial :
+	( /bin/rm -f $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm_serial :
+	( if [ ! -e module_dm.F ] ; then /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ; fi )
+
+gen_comms_rsllite :
+	( if [ ! -e $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ] ; then \
+          /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; fi )
+
+module_dm_rsllite :
+	( if [ ! -e module_dm.F ] ; then /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F ; fi )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH="$(NETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          CC="$(SCC)" CFLAGS="$(CFLAGS)" \
+          FC="$(SFC) $(PROMOTION) $(FCFLAGS)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_pnf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_pnetcdf ; \
+          make NETCDFPATH="$(PNETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP) $(ARCHFLAGS)" \
+          FC="$(FC) $(PROMOTION) $(FCFLAGS)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" archive) 
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS) " RM="$(RM)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="-traditional" AR="$(AR)" ARFLAGS="$(ARFLAGS)" \
+          FIXED="$(FORMAT_FIXED)" archive)
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FGREP="$(FGREP)" \
+          TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ARCHFLAGS="$(ARCHFLAGS)" all )
+
+esmf_time : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+          make FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(ARCHFLAGS) $(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+atm_ocn :
+	( cd $(WRF_SRC_ROOT_DIR)/external/atm_ocn ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS) " RM="$(RM)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP)" \
+          FC="$(DM_FC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="-traditional" AR="$(AR)" ARFLAGS="$(ARFLAGS)" \
+          FIXED="$(FORMAT_FIXED)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CC="$(CC) $(CFLAGS)" \
+          FC="$(FC) $(FCFLAGS) $(PROMOTION) $(BYTESWAPIO)" \
+          CPP="$(CPP) -I. $(ARCHFLAGS) $(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ;\
+          $(RANLIB) $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a )
+
+######################
+#	Macros, these should be generic for all machines
+
+LN	=	ln -sf
+MAKE	=	make -i -r
+RM	= 	rm -f
+
+
+# These sub-directory builds are identical across all architectures
+
+wrf_ioapi_includes :
+	( cd $(WRF_SRC_ROOT_DIR)/external/ioapi_share ; \
+          $(MAKE) NATIVE_RWORDSIZE="$(NATIVE_RWORDSIZE)" RWORDSIZE="$(RWORDSIZE)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_esmf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_esmf ; \
+          make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) $(ESMF_MOD_INC)" \
+          RANLIB="$(RANLIB)" CPP="$(CPP) $(POUND_DEF) " AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+#	There is probably no reason to modify these rules
+
+.F.i:
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.F > $@
+	mv $*.i $(DEVTOP)/pick/$*.f90
+	cp $*.F $(DEVTOP)/pick
+
+.F.o:
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F  > $*.bb
+	$(SED_FTN) $*.bb | $(CPP) > $*.f90
+	$(RM) $*.b $*.bb
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -o $@ -c $(FCFLAGS) $(OMP) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -o $@ -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \
+        fi
+        
+
+.F.f90:
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $@
+	$(RM) $*.b
+
+.f90.o:
+	$(RM) $@
+	$(FC) -o $@ -c $(FCFLAGS) $(PROMOTION) $(FCSUFFIX) $*.f90
+
+setfeenv.o : setfeenv.c
+	$(RM) $@
+	$(CCOMP) -o $@ -c $(CFLAGS) $(OMPCC) $*.c
+
+.c.o:
+	$(RM) $@
+	$(CC) -o $@ -c $(CFLAGS) $*.c
+
+# A little more adventurous.  Allow full opt on 
+# mediation_integrate.o \
+# shift_domain_em.o \
+# solve_em.o  <-- gets a little kick from SOLVE_EM_SPECIAL too, if defined
+# mediation_feedback_domain.o : mediation_feedback_domain.F
+# mediation_force_domain.o : mediation_force_domain.F
+# mediation_interp_domain.o : mediation_interp_domain.F
+
+# compile these without high optimization to speed compile
+convert_nmm.o : convert_nmm.F
+init_modules_em.o : init_modules_em.F
+input_wrf.o : input_wrf.F
+module_io.o : module_io.F
+module_comm_dm.o : module_comm_dm.F
+module_comm_dm_0.o : module_comm_dm_0.F
+module_comm_dm_1.o : module_comm_dm_1.F
+module_comm_dm_2.o : module_comm_dm_2.F
+module_comm_dm_3.o : module_comm_dm_3.F
+module_comm_nesting_dm.o : module_comm_nesting_dm.F
+module_configure.o : module_configure.F
+module_dm.o : module_dm.F
+module_domain.o : module_domain.F
+module_domain_type.o : module_domain_type.F
+module_alloc_space_0.o : module_alloc_space_0.F
+module_alloc_space_1.o : module_alloc_space_1.F
+module_alloc_space_2.o : module_alloc_space_2.F
+module_alloc_space_3.o : module_alloc_space_3.F
+module_alloc_space_4.o : module_alloc_space_4.F
+module_alloc_space_5.o : module_alloc_space_5.F
+module_alloc_space_6.o : module_alloc_space_6.F
+module_alloc_space_7.o : module_alloc_space_7.F
+module_alloc_space_8.o : module_alloc_space_8.F
+module_alloc_space_9.o : module_alloc_space_9.F
+module_tiles.o : module_tiles.F
+module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F
+module_initialize.o : module_initialize.F
+module_physics_init.o : module_physics_init.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_real.o : module_initialize_real.F
+module_initialize_real.o: module_initialize_real.F
+module_initialize_squall2d_x.o : module_initialize_squall2d_x.F
+module_initialize_squall2d_y.o : module_initialize_squall2d_y.F
+module_integrate.o : module_integrate.F
+module_io_mm5.o : module_io_mm5.F
+module_io_wrf.o : module_io_wrf.F
+module_si_io.o : module_si_io.F
+module_state_description.o : module_state_description.F 
+output_wrf.o : output_wrf.F
+solve_interface.o : solve_interface.F
+start_domain.o : start_domain.F
+start_domain_nmm.o : start_domain_nmm.F
+start_em.o : start_em.F
+wrf_bdyin.o : wrf_bdyin.F
+wrf_bdyout.o : wrf_bdyout.F
+wrf_ext_read_field.o : wrf_ext_read_field.F
+wrf_ext_write_field.o : wrf_ext_write_field.F
+wrf_fddaobs_in.o : wrf_fddaobs_in.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_tsin.o : wrf_tsin.F
+nl_get_0_routines.o : nl_get_0_routines.F
+nl_get_1_routines.o : nl_get_1_routines.F
+nl_set_0_routines.o : nl_set_0_routines.F
+nl_set_1_routines.o : nl_set_1_routines.F
+
+convert_nmm.o \
+init_modules_em.o \
+module_dm.o \
+module_fddaobs_rtfdda.o \
+module_initialize.o \
+module_initialize_b_wave.o \
+module_initialize_hill2d_x.o \
+module_initialize_quarter_ss.o \
+module_initialize_real.o \
+module_initialize_squall2d_x.o \
+module_initialize_squall2d_y.o \
+module_integrate.o \
+module_io_mm5.o \
+module_io_wrf.o \
+module_si_io.o \
+module_tiles.o \
+output_wrf.o \
+solve_interface.o \
+start_domain.o \
+start_domain_nmm.o \
+shift_domain_nmm.o \
+start_em.o \
+wrf_fddaobs_in.o \
+wrf_tsin.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $(OMP) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 ; \
+        fi
+
+#solve_em.o :
+#	$(RM) $@
+#	$(SED_FTN) $*.F > $*.b 
+#	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+#	$(RM) $*.b
+#	$(FC) -o $@ -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $(SOLVE_EM_SPECIAL) $(OMP) $*.f90
+
+module_sf_ruclsm.o : module_sf_ruclsm.F
+
+module_sf_ruclsm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          echo COMPILING $*.F WITH OMP ; \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCREDUCEDOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $(OMP) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCREDUCEDOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 ; \
+        fi
+
+# compile without OMP
+input_wrf.o \
+module_domain.o \
+module_domain_type.o \
+module_physics_init.o \
+module_io.o \
+wrf_bdyin.o \
+wrf_bdyout.o \
+wrf_ext_read_field.o \
+wrf_ext_write_field.o \
+wrf_histin.o \
+wrf_histout.o \
+wrf_inputin.o \
+wrf_inputout.o \
+wrf_restartin.o \
+wrf_restartout.o \
+module_state_description.o \
+module_alloc_space.o \
+module_alloc_space_0.o \
+module_alloc_space_1.o \
+module_alloc_space_2.o \
+module_alloc_space_3.o \
+module_alloc_space_4.o \
+module_alloc_space_5.o \
+module_alloc_space_6.o \
+module_alloc_space_7.o \
+module_alloc_space_8.o \
+module_alloc_space_9.o \
+module_comm_dm.o \
+module_comm_dm_0.o \
+module_comm_dm_1.o \
+module_comm_dm_2.o \
+module_comm_dm_3.o \
+module_comm_nesting_dm.o \
+module_configure.o :
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F  > $*.bb
+	$(SED_FTN) $*.bb | $(CPP) > $*.f90
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	$(RM) $*.b $*.bb
+	$(FC) -c $(PROMOTION) $(FCSUFFIX) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
Index: branches/LMDZ_WRFmeas/WRFV3/configure.serial_lmdz2wrf_dbg.lmd.wrf
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/configure.serial_lmdz2wrf_dbg.lmd.wrf	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/configure.serial_lmdz2wrf_dbg.lmd.wrf	(revision 17)
@@ -0,0 +1,522 @@
+# 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) \
+	   -DDA_CORE=$(WRF_DA_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	=	32768
+
+#### Size of bitmasks (in 4byte integers) of stream masks for WRF I/O
+
+MAX_HISTORY = 25
+
+IWORDSIZE = 4
+DWORDSIZE = 8
+LWORDSIZE = 4
+
+##############################################################################
+#### 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 $(WRF_SRC_ROOT_DIR)/arch/standard.sed
+SED_FTN = $(WRF_SRC_ROOT_DIR)/tools/standard.exe
+
+# 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 = $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90/module_utility.o
+# select -I options for external/io_esmf vs. external/esmf_time_f90
+ESMF_IO_INC         = -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90
+# select -I options for separately installed ESMF library, if present
+ESMF_MOD_INC        =  $(ESMF_IO_INC)
+# 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
+
+##############################################################################
+
+LIBWRFLIB = libwrflib.a
+
+
+#### Architecture specific settings ####
+
+# Settings for x86_64 Linux, gfortran compiler with gcc   (serial)
+#
+DMPARALLEL      =        1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -fopenmp
+OMPCC           =       # -fopenmp
+SFC             =       gfortran
+SCC             =       gcc
+CCOMP           =       gcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =        $(SFC)
+CC              =       $(SCC) -DFSEEKO64_OK 
+LD              =       $(FC)
+RWORDSIZE       =       $(NATIVE_RWORDSIZE)
+PROMOTION       =       # -fdefault-real-8  # uncomment manually
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -w -O3 -c -DLANDREAD_STUB
+LDFLAGS_LOCAL   =       
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3 -ftree-vectorize -ftree-loop-linear -funroll-loops
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT		=       -O0
+FCDEBUG         =       -g $(FCNOOPT) -fbacktrace -Wall -fbounds-check 
+FORMAT_FIXED    =       -ffixed-form
+FORMAT_FREE     =       -ffree-form -ffree-line-length-none
+FCSUFFIX        =       
+BYTESWAPIO      =       -fconvert=big-endian -frecord-marker=4
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -G
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+######################
+# POSTAMBLE
+
+FGREP = fgrep -iq
+
+ARCHFLAGS       =    $(COREDEFS) -DIWORDSIZE=$(IWORDSIZE) -DDWORDSIZE=$(DWORDSIZE) -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=$(LWORDSIZE) \
+                     $(ARCH_LOCAL) \
+                     $(DA_ARCHFLAGS) \
+                      -DDM_PARALLEL \
+                      -DSTUBMPI \
+                      -DNETCDF \
+                      -DLMDZ \
+                       \
+                       \
+                       \
+                       \
+                       \
+                       \
+                       \
+                      -DUSE_ALLOCATABLES \
+                      -DGRIB1 \
+                      -DINTIO \
+                      -DLIMIT_ARGS \
+                      -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) \
+                      -DMAX_DOMAINS_F=$(MAX_DOMAINS) \
+                      -DMAX_HISTORY=$(MAX_HISTORY) \
+		      -DNMM_NEST=$(WRF_NMM_NEST)
+CFLAGS          =    $(CFLAGS_LOCAL) -DDM_PARALLEL -DSTUBMPI \
+                      -DMAX_HISTORY=$(MAX_HISTORY)
+FCFLAGS         =    $(FCOPTIM) $(FCBASEOPTS)
+ESMF_LIB_FLAGS  =    
+ ESMF_IO_LIB     =    -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time
+ESMF_IO_LIB_EXT =    -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time
+INCLUDE_MODULES =    $(MODULE_SRCH_FLAG) \
+                     $(ESMF_MOD_INC) $(ESMF_LIB_FLAGS) \
+                      -I$(WRF_SRC_ROOT_DIR)/main \
+                      -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf \
+                      -I$(WRF_SRC_ROOT_DIR)/external/io_int \
+                      -I$(WRF_SRC_ROOT_DIR)/frame \
+                      -I$(WRF_SRC_ROOT_DIR)/share \
+                      -I$(WRF_SRC_ROOT_DIR)/phys \
+                      -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc \
+                      -I$(NETCDFPATH)/include \
+                      -I$(WRF_SRC_ROOT_DIR)/lmdz
+                      
+REGISTRY        =    Registry
+
+ LIB_BUNDLED     = \
+                      $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5/libfftpack.a \
+                      $(WRF_SRC_ROOT_DIR)/external/io_grib1/libio_grib1.a \
+                      $(WRF_SRC_ROOT_DIR)/external/io_grib_share/libio_grib_share.a \
+                      $(WRF_SRC_ROOT_DIR)/external/io_int/libwrfio_int.a \
+                      $(ESMF_IO_LIB) \
+                      $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a \
+                      $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o \
+                      $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o 
+
+ LIB_EXTERNAL    = \
+                      -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf -L${HOME}/bin/gcc_netcdf-4.3.0/lib  -lnetcdf -lnetcdff $(WRF_SRC_ROOT_DIR)/lmdz/lmdz.a 
+
+LIB             =    $(LIB_BUNDLED) $(LIB_EXTERNAL) $(LIB_LOCAL)
+LDFLAGS         =    $(OMP) $(FCFLAGS) $(LDFLAGS_LOCAL) 
+ENVCOMPDEFS     =    
+WRF_CHEM	=	0 
+CPPFLAGS        =    $(ARCHFLAGS) $(ENVCOMPDEFS) -I$(LIBINCLUDE) $(TRADFLAG) 
+NETCDFPATH      =    ${HOME}/bin/gcc_netcdf-4.3.0
+PNETCDFPATH     =    
+
+bundled:  wrf_ioapi_includes wrfio_grib_share wrfio_grib1 wrfio_int esmf_time fftpack 
+external:  wrfio_nf   $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms_rsllite module_dm_rsllite $(ESMF_TARGET)
+
+lmdza: $(WRF_SRC_ROOT_DIR)/lmdz/lmdz.a
+
+######################
+externals: bundled external
+
+gen_comms_serial :
+	( /bin/rm -f $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm_serial :
+	( if [ ! -e module_dm.F ] ; then /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ; fi )
+
+gen_comms_rsllite :
+	( if [ ! -e $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ] ; then \
+          /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; fi )
+
+module_dm_rsllite :
+	( if [ ! -e module_dm.F ] ; then /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F ; fi )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH="$(NETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          CC="$(SCC)" CFLAGS="$(CFLAGS)" \
+          FC="$(SFC) $(PROMOTION) $(FCFLAGS)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_pnf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_pnetcdf ; \
+          make NETCDFPATH="$(PNETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP) $(ARCHFLAGS)" \
+          FC="$(FC) $(PROMOTION) $(FCFLAGS)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" archive) 
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS) " RM="$(RM)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="-traditional" AR="$(AR)" ARFLAGS="$(ARFLAGS)" \
+          FIXED="$(FORMAT_FIXED)" archive)
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FGREP="$(FGREP)" \
+          TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ARCHFLAGS="$(ARCHFLAGS)" all )
+
+esmf_time : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+          make FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(ARCHFLAGS) $(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+atm_ocn :
+	( cd $(WRF_SRC_ROOT_DIR)/external/atm_ocn ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS) " RM="$(RM)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP)" \
+          FC="$(DM_FC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="-traditional" AR="$(AR)" ARFLAGS="$(ARFLAGS)" \
+          FIXED="$(FORMAT_FIXED)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CC="$(CC) $(CFLAGS)" \
+          FC="$(FC) $(FCFLAGS) $(PROMOTION) $(BYTESWAPIO)" \
+          CPP="$(CPP) -I. $(ARCHFLAGS) $(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ;\
+          $(RANLIB) $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a )
+
+######################
+#	Macros, these should be generic for all machines
+
+LN	=	ln -sf
+MAKE	=	make -i -r
+RM	= 	rm -f
+
+
+# These sub-directory builds are identical across all architectures
+
+wrf_ioapi_includes :
+	( cd $(WRF_SRC_ROOT_DIR)/external/ioapi_share ; \
+          $(MAKE) NATIVE_RWORDSIZE="$(NATIVE_RWORDSIZE)" RWORDSIZE="$(RWORDSIZE)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_esmf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_esmf ; \
+          make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) $(ESMF_MOD_INC)" \
+          RANLIB="$(RANLIB)" CPP="$(CPP) $(POUND_DEF) " AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+#	There is probably no reason to modify these rules
+
+.F.i:
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.F > $@
+	mv $*.i $(DEVTOP)/pick/$*.f90
+	cp $*.F $(DEVTOP)/pick
+
+.F.o:
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F  > $*.bb
+	$(SED_FTN) $*.bb | $(CPP) > $*.f90
+	$(RM) $*.b $*.bb
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -o $@ -c $(FCFLAGS) $(OMP) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -o $@ -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \
+        fi
+        
+
+.F.f90:
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $@
+	$(RM) $*.b
+
+.f90.o:
+	$(RM) $@
+	$(FC) -o $@ -c $(FCFLAGS) $(PROMOTION) $(FCSUFFIX) $*.f90
+
+setfeenv.o : setfeenv.c
+	$(RM) $@
+	$(CCOMP) -o $@ -c $(CFLAGS) $(OMPCC) $*.c
+
+.c.o:
+	$(RM) $@
+	$(CC) -o $@ -c $(CFLAGS) $*.c
+
+# A little more adventurous.  Allow full opt on 
+# mediation_integrate.o \
+# shift_domain_em.o \
+# solve_em.o  <-- gets a little kick from SOLVE_EM_SPECIAL too, if defined
+# mediation_feedback_domain.o : mediation_feedback_domain.F
+# mediation_force_domain.o : mediation_force_domain.F
+# mediation_interp_domain.o : mediation_interp_domain.F
+
+# compile these without high optimization to speed compile
+convert_nmm.o : convert_nmm.F
+init_modules_em.o : init_modules_em.F
+input_wrf.o : input_wrf.F
+module_io.o : module_io.F
+module_comm_dm.o : module_comm_dm.F
+module_comm_dm_0.o : module_comm_dm_0.F
+module_comm_dm_1.o : module_comm_dm_1.F
+module_comm_dm_2.o : module_comm_dm_2.F
+module_comm_dm_3.o : module_comm_dm_3.F
+module_comm_nesting_dm.o : module_comm_nesting_dm.F
+module_configure.o : module_configure.F
+module_dm.o : module_dm.F
+module_domain.o : module_domain.F
+module_domain_type.o : module_domain_type.F
+module_alloc_space_0.o : module_alloc_space_0.F
+module_alloc_space_1.o : module_alloc_space_1.F
+module_alloc_space_2.o : module_alloc_space_2.F
+module_alloc_space_3.o : module_alloc_space_3.F
+module_alloc_space_4.o : module_alloc_space_4.F
+module_alloc_space_5.o : module_alloc_space_5.F
+module_alloc_space_6.o : module_alloc_space_6.F
+module_alloc_space_7.o : module_alloc_space_7.F
+module_alloc_space_8.o : module_alloc_space_8.F
+module_alloc_space_9.o : module_alloc_space_9.F
+module_tiles.o : module_tiles.F
+module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F
+module_initialize.o : module_initialize.F
+module_physics_init.o : module_physics_init.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_real.o : module_initialize_real.F
+module_initialize_real.o: module_initialize_real.F
+module_initialize_squall2d_x.o : module_initialize_squall2d_x.F
+module_initialize_squall2d_y.o : module_initialize_squall2d_y.F
+module_integrate.o : module_integrate.F
+module_io_mm5.o : module_io_mm5.F
+module_io_wrf.o : module_io_wrf.F
+module_si_io.o : module_si_io.F
+module_state_description.o : module_state_description.F 
+output_wrf.o : output_wrf.F
+solve_interface.o : solve_interface.F
+start_domain.o : start_domain.F
+start_domain_nmm.o : start_domain_nmm.F
+start_em.o : start_em.F
+wrf_bdyin.o : wrf_bdyin.F
+wrf_bdyout.o : wrf_bdyout.F
+wrf_ext_read_field.o : wrf_ext_read_field.F
+wrf_ext_write_field.o : wrf_ext_write_field.F
+wrf_fddaobs_in.o : wrf_fddaobs_in.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_tsin.o : wrf_tsin.F
+nl_get_0_routines.o : nl_get_0_routines.F
+nl_get_1_routines.o : nl_get_1_routines.F
+nl_set_0_routines.o : nl_set_0_routines.F
+nl_set_1_routines.o : nl_set_1_routines.F
+
+convert_nmm.o \
+init_modules_em.o \
+module_dm.o \
+module_fddaobs_rtfdda.o \
+module_initialize.o \
+module_initialize_b_wave.o \
+module_initialize_hill2d_x.o \
+module_initialize_quarter_ss.o \
+module_initialize_real.o \
+module_initialize_squall2d_x.o \
+module_initialize_squall2d_y.o \
+module_integrate.o \
+module_io_mm5.o \
+module_io_wrf.o \
+module_si_io.o \
+module_tiles.o \
+output_wrf.o \
+solve_interface.o \
+start_domain.o \
+start_domain_nmm.o \
+shift_domain_nmm.o \
+start_em.o \
+wrf_fddaobs_in.o \
+wrf_tsin.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $(OMP) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 ; \
+        fi
+
+#solve_em.o :
+#	$(RM) $@
+#	$(SED_FTN) $*.F > $*.b 
+#	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+#	$(RM) $*.b
+#	$(FC) -o $@ -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $(SOLVE_EM_SPECIAL) $(OMP) $*.f90
+
+module_sf_ruclsm.o : module_sf_ruclsm.F
+
+module_sf_ruclsm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          echo COMPILING $*.F WITH OMP ; \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCREDUCEDOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $(OMP) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCREDUCEDOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 ; \
+        fi
+
+# compile without OMP
+input_wrf.o \
+module_domain.o \
+module_domain_type.o \
+module_physics_init.o \
+module_io.o \
+wrf_bdyin.o \
+wrf_bdyout.o \
+wrf_ext_read_field.o \
+wrf_ext_write_field.o \
+wrf_histin.o \
+wrf_histout.o \
+wrf_inputin.o \
+wrf_inputout.o \
+wrf_restartin.o \
+wrf_restartout.o \
+module_state_description.o \
+module_alloc_space.o \
+module_alloc_space_0.o \
+module_alloc_space_1.o \
+module_alloc_space_2.o \
+module_alloc_space_3.o \
+module_alloc_space_4.o \
+module_alloc_space_5.o \
+module_alloc_space_6.o \
+module_alloc_space_7.o \
+module_alloc_space_8.o \
+module_alloc_space_9.o \
+module_comm_dm.o \
+module_comm_dm_0.o \
+module_comm_dm_1.o \
+module_comm_dm_2.o \
+module_comm_dm_3.o \
+module_comm_nesting_dm.o \
+module_configure.o :
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F  > $*.bb
+	$(SED_FTN) $*.bb | $(CPP) > $*.f90
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	$(RM) $*.b $*.bb
+	$(FC) -c $(PROMOTION) $(FCSUFFIX) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
Index: branches/LMDZ_WRFmeas/WRFV3/configure.wrf.backup
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/configure.wrf.backup	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/configure.wrf.backup	(revision 17)
@@ -0,0 +1,522 @@
+# 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) \
+	   -DDA_CORE=$(WRF_DA_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	=	32768
+
+#### Size of bitmasks (in 4byte integers) of stream masks for WRF I/O
+
+MAX_HISTORY = 25
+
+IWORDSIZE = 4
+DWORDSIZE = 8
+LWORDSIZE = 4
+
+##############################################################################
+#### 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 $(WRF_SRC_ROOT_DIR)/arch/standard.sed
+SED_FTN = $(WRF_SRC_ROOT_DIR)/tools/standard.exe
+
+# 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 = $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90/module_utility.o
+# select -I options for external/io_esmf vs. external/esmf_time_f90
+ESMF_IO_INC         = -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90
+# select -I options for separately installed ESMF library, if present
+ESMF_MOD_INC        =  $(ESMF_IO_INC)
+# 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
+
+##############################################################################
+
+LIBWRFLIB = libwrflib.a
+
+
+#### Architecture specific settings ####
+
+# Settings for x86_64 Linux, gfortran compiler with gcc   (serial)
+#
+DMPARALLEL      =        1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -fopenmp
+OMPCC           =       # -fopenmp
+SFC             =       gfortran
+SCC             =       gcc
+CCOMP           =       gcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =        $(SFC)
+CC              =       $(SCC) -DFSEEKO64_OK 
+LD              =       $(FC)
+RWORDSIZE       =       $(NATIVE_RWORDSIZE)
+PROMOTION       =       # -fdefault-real-8  # uncomment manually
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -w -O3 -c -DLANDREAD_STUB
+LDFLAGS_LOCAL   =       
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3 -ftree-vectorize -ftree-loop-linear -funroll-loops
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT		=       -O0
+FCDEBUG         =       # -g $(FCNOOPT)
+FORMAT_FIXED    =       -ffixed-form
+FORMAT_FREE     =       -ffree-form -ffree-line-length-none
+FCSUFFIX        =       
+BYTESWAPIO      =       -fconvert=big-endian -frecord-marker=4
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =     
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -G
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC) 
+
+###########################################################
+######################
+# POSTAMBLE
+
+FGREP = fgrep -iq
+
+ARCHFLAGS       =    $(COREDEFS) -DIWORDSIZE=$(IWORDSIZE) -DDWORDSIZE=$(DWORDSIZE) -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=$(LWORDSIZE) \
+                     $(ARCH_LOCAL) \
+                     $(DA_ARCHFLAGS) \
+                      -DDM_PARALLEL \
+                      -DSTUBMPI \
+                      -DNETCDF \
+                      -DLMDZ \
+                       \
+                       \
+                       \
+                       \
+                       \
+                       \
+                       \
+                      -DUSE_ALLOCATABLES \
+                      -DGRIB1 \
+                      -DINTIO \
+                      -DLIMIT_ARGS \
+                      -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) \
+                      -DMAX_DOMAINS_F=$(MAX_DOMAINS) \
+                      -DMAX_HISTORY=$(MAX_HISTORY) \
+		      -DNMM_NEST=$(WRF_NMM_NEST)
+CFLAGS          =    $(CFLAGS_LOCAL) -DDM_PARALLEL -DSTUBMPI \
+                      -DMAX_HISTORY=$(MAX_HISTORY)
+FCFLAGS         =    $(FCOPTIM) $(FCBASEOPTS)
+ESMF_LIB_FLAGS  =    
+ ESMF_IO_LIB     =    -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time
+ESMF_IO_LIB_EXT =    -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time
+INCLUDE_MODULES =    $(MODULE_SRCH_FLAG) \
+                     $(ESMF_MOD_INC) $(ESMF_LIB_FLAGS) \
+                      -I$(WRF_SRC_ROOT_DIR)/main \
+                      -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf \
+                      -I$(WRF_SRC_ROOT_DIR)/external/io_int \
+                      -I$(WRF_SRC_ROOT_DIR)/frame \
+                      -I$(WRF_SRC_ROOT_DIR)/share \
+                      -I$(WRF_SRC_ROOT_DIR)/phys \
+                      -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc \
+                      -I$(NETCDFPATH)/include \
+                      -I$(WRF_SRC_ROOT_DIR)/lmdz
+                      
+REGISTRY        =    Registry
+
+ LIB_BUNDLED     = \
+                      $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5/libfftpack.a \
+                      $(WRF_SRC_ROOT_DIR)/external/io_grib1/libio_grib1.a \
+                      $(WRF_SRC_ROOT_DIR)/external/io_grib_share/libio_grib_share.a \
+                      $(WRF_SRC_ROOT_DIR)/external/io_int/libwrfio_int.a \
+                      $(ESMF_IO_LIB) \
+                      $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a \
+                      $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o \
+                      $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o 
+
+ LIB_EXTERNAL    = \
+                      -L$(WRF_SRC_ROOT_DIR)/external/io_netcdf -lwrfio_nf -L${HOME}/bin/gcc_netcdf-4.3.0/lib  -lnetcdf -lnetcdff $(WRF_SRC_ROOT_DIR)/lmdz/lmdz.a 
+
+LIB             =    $(LIB_BUNDLED) $(LIB_EXTERNAL) $(LIB_LOCAL)
+LDFLAGS         =    $(OMP) $(FCFLAGS) $(LDFLAGS_LOCAL) 
+ENVCOMPDEFS     =    
+WRF_CHEM	=	0 
+CPPFLAGS        =    $(ARCHFLAGS) $(ENVCOMPDEFS) -I$(LIBINCLUDE) $(TRADFLAG) 
+NETCDFPATH      =    ${HOME}/bin/gcc_netcdf-4.3.0
+PNETCDFPATH     =    
+
+bundled:  wrf_ioapi_includes wrfio_grib_share wrfio_grib1 wrfio_int esmf_time fftpack 
+external:  wrfio_nf   $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms_rsllite module_dm_rsllite $(ESMF_TARGET)
+
+lmdza: $(WRF_SRC_ROOT_DIR)/lmdz/lmdz.a
+
+######################
+externals: bundled external
+
+gen_comms_serial :
+	( /bin/rm -f $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm_serial :
+	( if [ ! -e module_dm.F ] ; then /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ; fi )
+
+gen_comms_rsllite :
+	( if [ ! -e $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ] ; then \
+          /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; fi )
+
+module_dm_rsllite :
+	( if [ ! -e module_dm.F ] ; then /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F ; fi )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH="$(NETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          CC="$(SCC)" CFLAGS="$(CFLAGS)" \
+          FC="$(SFC) $(PROMOTION) $(FCFLAGS)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_pnf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_pnetcdf ; \
+          make NETCDFPATH="$(PNETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP) $(ARCHFLAGS)" \
+          FC="$(FC) $(PROMOTION) $(FCFLAGS)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" archive) 
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS) " RM="$(RM)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="-traditional" AR="$(AR)" ARFLAGS="$(ARFLAGS)" \
+          FIXED="$(FORMAT_FIXED)" archive)
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" FGREP="$(FGREP)" \
+          TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ARCHFLAGS="$(ARCHFLAGS)" all )
+
+esmf_time : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+          make FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(ARCHFLAGS) $(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+atm_ocn :
+	( cd $(WRF_SRC_ROOT_DIR)/external/atm_ocn ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS) " RM="$(RM)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP)" \
+          FC="$(DM_FC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="-traditional" AR="$(AR)" ARFLAGS="$(ARFLAGS)" \
+          FIXED="$(FORMAT_FIXED)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CC="$(CC) $(CFLAGS)" \
+          FC="$(FC) $(FCFLAGS) $(PROMOTION) $(BYTESWAPIO)" \
+          CPP="$(CPP) -I. $(ARCHFLAGS) $(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ;\
+          $(RANLIB) $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a )
+
+######################
+#	Macros, these should be generic for all machines
+
+LN	=	ln -sf
+MAKE	=	make -i -r
+RM	= 	rm -f
+
+
+# These sub-directory builds are identical across all architectures
+
+wrf_ioapi_includes :
+	( cd $(WRF_SRC_ROOT_DIR)/external/ioapi_share ; \
+          $(MAKE) NATIVE_RWORDSIZE="$(NATIVE_RWORDSIZE)" RWORDSIZE="$(RWORDSIZE)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_esmf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_esmf ; \
+          make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) $(ESMF_MOD_INC)" \
+          RANLIB="$(RANLIB)" CPP="$(CPP) $(POUND_DEF) " AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+#	There is probably no reason to modify these rules
+
+.F.i:
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.F > $@
+	mv $*.i $(DEVTOP)/pick/$*.f90
+	cp $*.F $(DEVTOP)/pick
+
+.F.o:
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F  > $*.bb
+	$(SED_FTN) $*.bb | $(CPP) > $*.f90
+	$(RM) $*.b $*.bb
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -o $@ -c $(FCFLAGS) $(OMP) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -o $@ -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90 ; \
+        fi
+        
+
+.F.f90:
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $@
+	$(RM) $*.b
+
+.f90.o:
+	$(RM) $@
+	$(FC) -o $@ -c $(FCFLAGS) $(PROMOTION) $(FCSUFFIX) $*.f90
+
+setfeenv.o : setfeenv.c
+	$(RM) $@
+	$(CCOMP) -o $@ -c $(CFLAGS) $(OMPCC) $*.c
+
+.c.o:
+	$(RM) $@
+	$(CC) -o $@ -c $(CFLAGS) $*.c
+
+# A little more adventurous.  Allow full opt on 
+# mediation_integrate.o \
+# shift_domain_em.o \
+# solve_em.o  <-- gets a little kick from SOLVE_EM_SPECIAL too, if defined
+# mediation_feedback_domain.o : mediation_feedback_domain.F
+# mediation_force_domain.o : mediation_force_domain.F
+# mediation_interp_domain.o : mediation_interp_domain.F
+
+# compile these without high optimization to speed compile
+convert_nmm.o : convert_nmm.F
+init_modules_em.o : init_modules_em.F
+input_wrf.o : input_wrf.F
+module_io.o : module_io.F
+module_comm_dm.o : module_comm_dm.F
+module_comm_dm_0.o : module_comm_dm_0.F
+module_comm_dm_1.o : module_comm_dm_1.F
+module_comm_dm_2.o : module_comm_dm_2.F
+module_comm_dm_3.o : module_comm_dm_3.F
+module_comm_nesting_dm.o : module_comm_nesting_dm.F
+module_configure.o : module_configure.F
+module_dm.o : module_dm.F
+module_domain.o : module_domain.F
+module_domain_type.o : module_domain_type.F
+module_alloc_space_0.o : module_alloc_space_0.F
+module_alloc_space_1.o : module_alloc_space_1.F
+module_alloc_space_2.o : module_alloc_space_2.F
+module_alloc_space_3.o : module_alloc_space_3.F
+module_alloc_space_4.o : module_alloc_space_4.F
+module_alloc_space_5.o : module_alloc_space_5.F
+module_alloc_space_6.o : module_alloc_space_6.F
+module_alloc_space_7.o : module_alloc_space_7.F
+module_alloc_space_8.o : module_alloc_space_8.F
+module_alloc_space_9.o : module_alloc_space_9.F
+module_tiles.o : module_tiles.F
+module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F
+module_initialize.o : module_initialize.F
+module_physics_init.o : module_physics_init.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_real.o : module_initialize_real.F
+module_initialize_real.o: module_initialize_real.F
+module_initialize_squall2d_x.o : module_initialize_squall2d_x.F
+module_initialize_squall2d_y.o : module_initialize_squall2d_y.F
+module_integrate.o : module_integrate.F
+module_io_mm5.o : module_io_mm5.F
+module_io_wrf.o : module_io_wrf.F
+module_si_io.o : module_si_io.F
+module_state_description.o : module_state_description.F 
+output_wrf.o : output_wrf.F
+solve_interface.o : solve_interface.F
+start_domain.o : start_domain.F
+start_domain_nmm.o : start_domain_nmm.F
+start_em.o : start_em.F
+wrf_bdyin.o : wrf_bdyin.F
+wrf_bdyout.o : wrf_bdyout.F
+wrf_ext_read_field.o : wrf_ext_read_field.F
+wrf_ext_write_field.o : wrf_ext_write_field.F
+wrf_fddaobs_in.o : wrf_fddaobs_in.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_tsin.o : wrf_tsin.F
+nl_get_0_routines.o : nl_get_0_routines.F
+nl_get_1_routines.o : nl_get_1_routines.F
+nl_set_0_routines.o : nl_set_0_routines.F
+nl_set_1_routines.o : nl_set_1_routines.F
+
+convert_nmm.o \
+init_modules_em.o \
+module_dm.o \
+module_fddaobs_rtfdda.o \
+module_initialize.o \
+module_initialize_b_wave.o \
+module_initialize_hill2d_x.o \
+module_initialize_quarter_ss.o \
+module_initialize_real.o \
+module_initialize_squall2d_x.o \
+module_initialize_squall2d_y.o \
+module_integrate.o \
+module_io_mm5.o \
+module_io_wrf.o \
+module_si_io.o \
+module_tiles.o \
+output_wrf.o \
+solve_interface.o \
+start_domain.o \
+start_domain_nmm.o \
+shift_domain_nmm.o \
+start_em.o \
+wrf_fddaobs_in.o \
+wrf_tsin.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $(OMP) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 ; \
+        fi
+
+#solve_em.o :
+#	$(RM) $@
+#	$(SED_FTN) $*.F > $*.b 
+#	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+#	$(RM) $*.b
+#	$(FC) -o $@ -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $(SOLVE_EM_SPECIAL) $(OMP) $*.f90
+
+module_sf_ruclsm.o : module_sf_ruclsm.F
+
+module_sf_ruclsm.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	if $(FGREP) '!$$OMP' $*.f90 ; then \
+          echo COMPILING $*.F WITH OMP ; \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCREDUCEDOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $(OMP) $*.f90 ; \
+        else \
+          if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITHOUT OMP ; fi ; \
+	  $(FC) -c $(PROMOTION) $(FCREDUCEDOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 ; \
+        fi
+
+# compile without OMP
+input_wrf.o \
+module_domain.o \
+module_domain_type.o \
+module_physics_init.o \
+module_io.o \
+wrf_bdyin.o \
+wrf_bdyout.o \
+wrf_ext_read_field.o \
+wrf_ext_write_field.o \
+wrf_histin.o \
+wrf_histout.o \
+wrf_inputin.o \
+wrf_inputout.o \
+wrf_restartin.o \
+wrf_restartout.o \
+module_state_description.o \
+module_alloc_space.o \
+module_alloc_space_0.o \
+module_alloc_space_1.o \
+module_alloc_space_2.o \
+module_alloc_space_3.o \
+module_alloc_space_4.o \
+module_alloc_space_5.o \
+module_alloc_space_6.o \
+module_alloc_space_7.o \
+module_alloc_space_8.o \
+module_alloc_space_9.o \
+module_comm_dm.o \
+module_comm_dm_0.o \
+module_comm_dm_1.o \
+module_comm_dm_2.o \
+module_comm_dm_3.o \
+module_comm_nesting_dm.o \
+module_configure.o :
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F  > $*.bb
+	$(SED_FTN) $*.bb | $(CPP) > $*.f90
+	@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \
+          mv $*.f90.tmp $*.f90 ; \
+        fi
+	$(RM) $*.b $*.bb
+	$(FC) -c $(PROMOTION) $(FCSUFFIX) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/Makefile	(revision 17)
@@ -0,0 +1,362 @@
+#
+
+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         \
+	module_damping_em.o		\
+	module_polarfft.o		\
+        module_force_scm.o              \
+        module_first_rk_step_part1.o    \
+        module_first_rk_step_part2.o    \
+        module_avgflx_em.o              \
+	module_sfs_nba.o		\
+        module_convtrans_prep.o         \
+	module_sfs_driver.o		\
+	module_stoch.o		\
+	$(CASE_MODULE)
+
+# possible CASE_MODULE settings
+#	module_initialize_b_wave.o      \
+#	module_initialize_grav2d_x.o    \
+#	module_initialize_heldsuarez.o  \
+#	module_initialize_hill2d_x.o    \
+#	module_initialize_quarter_ss.o  \
+#	module_initialize_real.o        \
+#	module_initialize_lsm_x.o       \
+#	module_initialize_les.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	\
+        adapt_timestep_em.o     \
+        interp_domain_em.o
+ 
+
+LIBTARGET    =  dyn_em
+TARGETDIR    =  ./
+$(LIBTARGET) :  $(MODULES) $(OBJS)
+		$(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(OBJS)
+
+include ../configure.wrf
+
+cio.o :
+	$(CC) -c $(CFLAGS) cio.c
+
+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
+
+shift_domain_em.o : \
+		../frame/loop_based_x_shift_code.h \
+		../frame/loop_based_y_shift_code.h
+
+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: \
+		../share/module_llxy.o	\
+		../frame/module_domain.o \
+		../frame/module_configure.o  \
+		../frame/module_state_description.o \
+		../share/module_model_constants.o 
+
+module_damping_em.o: ../frame/module_wrf_error.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 \
+		module_damping_em.o \
+		../frame/module_state_description.o \
+		../share/module_model_constants.o 
+
+module_polarfft.o: ../share/module_model_constants.o \
+		../frame/module_wrf_error.o
+
+module_sfs_driver.o:  \
+		module_sfs_nba.o \
+		../frame/module_state_description.o \
+		../frame/module_domain.o \
+		../frame/module_configure.o \
+		../frame/module_tiles.o \
+		../frame/module_dm.o \
+		../frame/module_machine.o \
+		../share/module_bc.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_force_scm.o: module_init_utilities.o
+module_convtrans_prep.o: module_convtrans_prep.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_heldsuarez.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 \
+                ../phys/module_fr_sfire_util.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_les.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_seabreeze2d_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_tropical_cyclone.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_scm_xy.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 :  \
+		nest_init_utils.o	\
+		../share/module_llxy.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_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 \
+                module_avgflx_em.o              \
+                module_stoch.o              \
+		../frame/module_domain.o \
+		../frame/module_configure.o  \
+		../frame/module_state_description.o \
+		../frame/module_timing.o \
+		../frame/module_dm.o \
+		../frame/module_comm_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 \
+		$(CF)
+
+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 \
+                module_first_rk_step_part1.o \
+                module_first_rk_step_part2.o \
+                module_avgflx_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 \
+		../frame/module_comm_dm.o \
+		../share/module_llxy.o	\
+		../share/module_model_constants.o \
+		../share/module_bc.o \
+		../phys/module_microphysics_driver.o \
+		../phys/module_microphysics_zero_out.o \
+		../phys/module_physics_addtendc.o
+
+module_first_rk_step_part1.o : \
+                module_force_scm.o \
+		module_big_step_utilities_em.o \
+                module_convtrans_prep.o \
+                module_em.o \
+		../phys/module_radiation_driver.o \
+		../phys/module_surface_driver.o \
+		../phys/module_cumulus_driver.o \
+		../phys/module_shallowcu_driver.o \
+		../phys/module_pbl_driver.o \
+		../frame/module_comm_dm.o \
+		../phys/module_fddagd_driver.o
+
+module_first_rk_step_part2.o : \
+                module_em.o \
+		module_diffusion_em.o  \
+                module_bc_em.o         \
+                module_stoch.o         \
+		module_sfs_driver.o \
+		../frame/module_domain.o \
+		../frame/module_state_description.o \
+		../frame/module_driver_constants.o \
+		../frame/module_configure.o \
+		../frame/module_dm.o \
+		../frame/module_driver_constants.o \
+		../share/module_bc.o \
+		../frame/module_comm_dm.o \
+		../phys/module_fddaobs_driver.o \
+		../phys/module_fddaobs_driver.o
+
+adapt_timestep_em.o: \
+                module_bc_em.o         \
+		../frame/module_domain.o \
+		../frame/module_configure.o  \
+		../frame/module_dm.o
+
+#		../chem/module_chem_utilities.o \
+# 		../chem/module_input_chem_data.o
+
+# DO NOT DELETE
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/README.tenddec
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/README.tenddec	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/README.tenddec	(revision 17)
@@ -0,0 +1,50 @@
+2010 12 21, JM
+
+Description of code in solve_em.F that allows computation of decoupled
+horizontal and vertical advective tendencies.  This is a feature that
+was added John Wong and the WRF_CHEM developers and involves threading
+additional arrays through the RK advection routines.  The developers
+also worked with the WRF Dynamics Working Group to add placeholders
+so that this capability could be used to compute decoupled horizontal
+and vertical advective tendencies for fields in other 4D tracer arrays
+(e.g. moist, scalar, etc.).  However, these are only placeholders for
+the other tracer arrays and users wishing to make this modification to
+solve_em should read this file carefully.  THIS IS AN ADVANCED TOPIC.
+
+The logical variable tenddec defined at the top of the solve_em routine
+is set within each loops over tracers for the 4D tracer arrays in WRF.
+The variable is passed into the RK advection routines and controls whether
+or not those routines do the necessary extra computations and store or
+accumulate the results into the 3D arrays h_tendency and z_tendency, also
+defined at the top of solve_em. Currently, and with the exception of the
+loops over chemical species, tenddec is always set to false.  The chemical
+loops and the statement to declare h_tendency and z_tendency as fully
+3D are guarded by #ifdef WRF_CHEM.  Otherwise, h_tendency and z_tendency
+are allocated only minimal storage to save memory.  As long as tenddec is
+false, the RK routines will not attempt to access or modify these arrays.
+
+To enable computational of decoupled horizontal and vertical advective
+tendencies for other 4D tracer arrays, first modify the declaration
+of h_tendency and z_tendency so they are fully dimensioned (as they are
+with WRF_CHEM).  Then, in the Registry, add definitions for the fields for
+which you wish to have these decoupled tendencies computed to the 4D array
+advh_t and advz_t .  Set up an index array similar to the adv_ct_indices
+array that is defined in solve_em when WRF_CHEM is defined and then
+set up assignments to that array similar to the assignments use to set
+adv_ct_indices in the routine setup_ct_indices(), which is defined in
+chem/chemics_init.F .  This will cause the rk_update_scalar routine to
+update the fields you have specified in the advh_t and advz_t arrays.
+Note that you must use your adv_*_indices array as the last index of
+the advh_t and advz_t arrays in the arguments to rk_update_scalar (see
+the call to rk_update_scalar for the chemistry species as an example).
+
+Additional note: currently advh_t and advz_t are the only 4D arrays
+defined in the Registry for this purpose. Therefore, you can only compute
+decoupled horizontal and vertical tendencies for only one non-chemistry
+4D tracer array.  If you need to do this for more than one, add another
+advh_* and advz_* array to the Registry and management them separately.
+
+Only after you have done this should you modify how tenddec is set in
+the scalar loop you are working with.  Use the assignement at the top
+of the chemistry tracer loop as an example.
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/adapt_timestep_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/adapt_timestep_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/adapt_timestep_em.F	(revision 17)
@@ -0,0 +1,544 @@
+RECURSIVE SUBROUTINE adapt_timestep(grid, config_flags)
+
+!--------------------------------------------------------------------------
+!<DESCRIPTION>
+!<pre>
+!
+! This routine sets the time step based on the cfl condition.  It's used to
+!   dynamically adapt the timestep as the model runs.
+!
+! T. Hutchinson, WSI
+! March 2007
+!
+!</pre>
+!</DESCRIPTION>
+!--------------------------------------------------------------------------
+
+! Driver layer modules
+  USE module_domain
+  USE module_configure
+  USE module_dm, ONLY : wrf_dm_maxval, wrf_dm_minval, wrf_dm_mintile_double, wrf_dm_tile_val_int, wrf_dm_maxtile_real
+  USE module_bc_em
+
+  IMPLICIT NONE
+
+  TYPE(domain) , TARGET , INTENT(INOUT)      :: grid
+  TYPE (grid_config_rec_type) , INTENT(IN)   :: config_flags
+
+  LOGICAL                                    :: use_last2
+  REAL                                       :: curr_secs
+  REAL                                       :: max_increase_factor
+  REAL                                       :: time_to_output, &
+                                                time_to_bc
+  INTEGER                                    :: idex=0, jdex=0
+  INTEGER                                    :: rc
+  TYPE(WRFU_TimeInterval)                    :: tmpTimeInterval, dtInterval
+  TYPE(WRFU_TimeInterval)                    :: dtInterval_horiz
+  TYPE(WRFU_TimeInterval)                    :: dtInterval_vert  
+  TYPE(WRFU_TimeInterval)                    :: parent_dtInterval
+  INTEGER                                    :: num_small_steps
+  integer                                    :: tile
+  LOGICAL                                    :: stepping_to_bc
+  INTEGER                                    :: bc_time, output_time
+  double precision                           :: dt = 0
+  INTEGER, PARAMETER                         :: precision = 100
+  INTEGER                                    :: dt_num, dt_den, dt_whole
+  INTEGER                                    :: num, den, history_interval_sec
+  TYPE(WRFU_TimeInterval)                    :: last_dtInterval
+  REAL                                       :: real_time
+  REAL                                       :: max_vert_cfl, max_horiz_cfl
+
+  !
+  ! If use_last2 is true, this routine will use the time step
+  !   from 2 steps ago to compute the next time step.  This
+  !   is used along with step_to_output and step_to_bc
+
+  use_last2 = .FALSE.
+
+  !
+  ! Assign last_dtInterval type values from restart file
+  !
+
+  CALL WRFU_TimeIntervalSet(grid%last_dtInterval,  S=grid%last_dt_sec, &
+                         Sn=grid%last_dt_sec_num, Sd=grid%last_dt_sec_den)
+
+  !
+  ! If this step has already been adapted, no need to do it again.
+  ! time step can already be adapted when adaptation_domain is
+  ! enabled.
+  !
+
+  if (grid%last_step_updated == grid%itimestep) then
+     return
+  else
+     grid%last_step_updated = grid%itimestep
+  endif
+
+  !
+  ! For nests, set adapt_step_using_child to parent's value
+  !
+  if (grid%id .ne. 1) then
+     grid%adapt_step_using_child = grid%parents(1)%ptr%adapt_step_using_child;
+  endif
+
+  !
+  ! For nests, if we're not adapting using child nest, we only want to change 
+  !    nests' time steps when the time is conincident with the parent's time.  
+  !    So, if dtbc is not zero, simply return and leave the last time step in 
+  !    place.
+  !
+
+!  if ((grid%id .ne. 1) .and. (.not. grid%adapt_step_using_child)) then
+!     if (abs(grid%dtbc) > 0.0001) then
+!        return
+!     endif
+!  endif
+
+  last_dtInterval = grid%last_dtInterval
+
+  !
+  ! Get time since beginning of simulation start
+  !
+
+  tmpTimeInterval = domain_get_current_time ( grid ) - &
+                    domain_get_sim_start_time ( grid )
+
+  !
+  ! Calculate current time in seconds since beginning of model run.
+  !   Unfortunately, ESMF does not seem to have a way to return
+  !   floating point seconds based on a TimeInterval.  So, we will
+  !   calculate it here--but, this is not clean!!
+  !
+  curr_secs = real_time(tmpTimeInterval)
+
+  !
+  ! Calculate the maximum allowable increase in the time step given
+  !   the user input max_step_increase_pct value and the nest ratio.
+  !
+  max_increase_factor = 1. + grid%max_step_increase_pct / 100.
+
+  !
+  ! If this is the first time step of the model run (indicated by current_time 
+  !    eq start_time), then set the time step to the input starting_time_step.
+  !
+  ! Else, calculate the time step based on cfl.
+  !
+  if ( (domain_get_current_time ( grid ) .eq. domain_get_start_time ( grid )) .AND. &
+       .NOT. config_flags%restart ) then
+     CALL WRFU_TimeIntervalSet(dtInterval, Sn=grid%starting_time_step, Sd=1)
+     curr_secs = 0
+     CALL WRFU_TimeIntervalSet(last_dtInterval, Sn=0, Sd=1)
+
+  else
+
+     if (grid%stepping_to_time) then
+        max_vert_cfl = grid%last_max_vert_cfl
+        max_horiz_cfl = grid%last_max_horiz_cfl
+     else
+        max_vert_cfl = grid%max_vert_cfl
+        max_horiz_cfl = grid%max_horiz_cfl
+     endif
+
+     CALL calc_dt(dtInterval_vert, max_vert_cfl, max_increase_factor, &
+          precision, last_dtInterval, grid%target_cfl)
+
+     CALL calc_dt(dtInterval_horiz, max_horiz_cfl, max_increase_factor, &
+          precision, last_dtInterval, grid%target_hcfl)
+
+     if (dtInterval_vert < dtInterval_horiz) then
+        dtInterval = dtInterval_vert
+     else
+        dtInterval = dtInterval_horiz
+     endif
+
+  endif
+
+  ! Limit the increase of dtInterval to the specified input limit
+
+  num = NINT( max_increase_factor * precision )
+  den = precision
+  tmpTimeInterval = last_dtInterval * num / den
+  if ( (domain_get_current_time ( grid ) .ne. domain_get_start_time ( grid )) &
+       .and. (dtInterval .gt. tmpTimeInterval ) ) then
+     dtInterval = tmpTimeInterval
+  endif
+
+  !
+  ! Here, we round off dtInterval to nearest 1/100.  This prevents
+  !    the denominator from getting too large and causing overflow.
+  !
+  dt = real_time(dtInterval)
+  num = NINT(dt * precision)
+  den = precision
+  CALL WRFU_TimeIntervalSet(dtInterval, Sn=num, Sd=den)
+
+  ! Limit the maximum dtInterval based on user input
+
+  CALL WRFU_TimeIntervalSet(tmpTimeInterval, Sn=grid%max_time_step, Sd=1)
+  if (dtInterval .gt. tmpTimeInterval ) then
+     dtInterval = tmpTimeInterval
+  endif
+
+  ! Limit the minimum dtInterval based on user input.
+
+  CALL WRFU_TimeIntervalSet(tmpTimeInterval, Sn=grid%min_time_step, Sd=1)
+  if (dtInterval .lt. tmpTimeInterval ) then
+     dtInterval = tmpTimeInterval
+  endif
+
+  !
+  ! Now, if this is a nest, and we are adapting based upon parent, 
+  !   we round down the time step to the nearest 
+  !   value that divides evenly into the parent time step.
+  ! If this is a nest, and we are adapting based upon the child (i.e., the 
+  !   nest), we update the parent timestep to the next smallest multiple
+  !   timestep.
+  !
+  if (grid%nested) then
+
+     dt = real_time(dtInterval)
+        
+     if (.not. grid%adapt_step_using_child) then 
+
+        ! We'll calculate real numbers to get the number of small steps:
+     
+        num_small_steps = CEILING( grid%parents(1)%ptr%dt / dt )
+
+#ifdef DM_PARALLEL
+        call wrf_dm_maxval(num_small_steps, idex, jdex)
+#endif
+        dtInterval = domain_get_time_step(grid%parents(1)%ptr) / &
+             num_small_steps
+     else
+
+        num_small_steps = FLOOR( grid%parents(1)%ptr%dt / dt )
+
+#ifdef DM_PARALLEL
+        call wrf_dm_minval(num_small_steps, idex, jdex)
+#endif
+        if (num_small_steps < 1) then
+           num_small_steps = 1
+        endif
+
+     endif
+  endif
+
+
+  !
+  ! Setup the values for several variables from the tile with the
+  !   minimum dt.
+  !
+  dt = real_time(dtInterval)
+
+#ifdef DM_PARALLEL
+  call wrf_dm_mintile_double(dt, tile)
+  CALL WRFU_TimeIntervalGet(dtInterval,Sn=dt_num,Sd=dt_den,S=dt_whole)
+  call wrf_dm_tile_val_int(dt_num, tile)
+  call wrf_dm_tile_val_int(dt_den, tile)
+  call wrf_dm_tile_val_int(dt_whole, tile)
+  CALL WRFU_TimeIntervalSet(dtInterval, Sn = dt_whole*dt_den + dt_num, Sd = dt_den)
+
+  call wrf_dm_maxtile_real(grid%max_vert_cfl, tile)
+  call wrf_dm_maxtile_real(grid%max_horiz_cfl, tile)
+#endif
+
+  if ((grid%nested) .and. (grid%adapt_step_using_child)) then 
+
+     grid%dt = real_time(dtInterval)
+
+     ! Set parent step here.
+     grid%parents(1)%ptr%dt = grid%dt * num_small_steps
+     parent_dtInterval = dtInterval * num_small_steps
+
+     !
+     ! Update the parent clock based on the new time step
+     !
+     CALL WRFU_ClockSet ( grid%parents(1)%ptr%domain_clock,        &
+          timeStep=parent_dtInterval, &
+          rc=rc )
+     
+  endif
+
+
+  !
+  ! Assure that we fall on a BC time.  Due to a bug in WRF, the time
+  !   step must fall on the boundary times.  Only modify the dtInterval
+  !   when this is not the first time step on this domain.
+  !
+
+  grid%stepping_to_time = .FALSE.
+  time_to_bc = grid%interval_seconds - grid%dtbc
+  num = INT(time_to_bc * precision + 0.5)
+  den = precision
+  CALL WRFU_TimeIntervalSet(tmpTimeInterval, Sn=num, Sd=den)
+  
+  if ( ( tmpTimeInterval .LT. dtInterval * 2 ) .and. &
+       ( tmpTimeInterval .GT. dtInterval ) ) then
+     dtInterval = tmpTimeInterval / 2
+     
+     use_last2 = .TRUE.
+     stepping_to_bc = .true.
+     grid%stepping_to_time = .TRUE.
+     
+  elseif (tmpTimeInterval .LE. dtInterval) then
+     
+     bc_time = NINT ( (curr_secs + time_to_bc) / ( grid%interval_seconds ) ) &
+          * ( grid%interval_seconds )
+     CALL WRFU_TimeIntervalSet(tmpTimeInterval, S=bc_time)
+     dtInterval = tmpTimeInterval - &
+          (domain_get_current_time(grid) - domain_get_sim_start_time(grid))
+     
+     use_last2 = .TRUE.
+     stepping_to_bc = .true.
+     grid%stepping_to_time = .TRUE.
+  else
+     stepping_to_bc = .false.
+  endif
+
+  !
+  ! If the user has requested that we step to output, then
+  !   assure that we fall on an output time.  We look out two time steps to
+  !   avoid having a very short time step.  Very short time steps can cause model
+  !   instability.
+  !
+
+  if ((grid%step_to_output_time) .and. (.not. stepping_to_bc) .and. &
+       (.not. grid%nested)) then
+
+     IF ( grid%history_interval_m .EQ. 0 ) grid%history_interval_m = grid%history_interval
+     history_interval_sec = grid%history_interval_s + grid%history_interval_m*60 + &
+                            grid%history_interval_h*3600 + grid%history_interval_d*86400
+
+     time_to_output = history_interval_sec - &
+          mod( curr_secs, REAL(history_interval_sec) )
+     num = INT(time_to_output * precision + 0.5)
+     den = precision
+     call WRFU_TimeIntervalSet(tmpTimeInterval, Sn=num, Sd=den)
+
+     if ( ( tmpTimeInterval .LT. dtInterval * 2 ) .and. &
+          ( tmpTimeInterval .GT. dtInterval ) ) then
+        dtInterval = tmpTimeInterval / 2
+        use_last2 = .TRUE.
+        grid%stepping_to_time = .TRUE.
+
+     elseif (tmpTimeInterval .LE. dtInterval) then
+        !
+        ! We will do some tricks here to assure that we fall exactly on an 
+        !   output time.  Without the tricks, round-off error causes problems!
+        !
+
+        !
+        ! Calculate output time.  We round to nearest history time to assure 
+        !    we don't have any rounding error.
+        !
+        output_time = NINT ( (curr_secs + time_to_output) /  &
+             (history_interval_sec) ) * (history_interval_sec)
+        CALL WRFU_TimeIntervalSet(tmpTimeInterval, S=output_time)
+        dtInterval = tmpTimeInterval - &
+             (domain_get_current_time(grid) - domain_get_sim_start_time(grid))
+
+        use_last2 = .TRUE.
+        grid%stepping_to_time = .TRUE.
+     endif
+  endif
+
+  !
+  ! Now, set adapt_step_using_child only if we are not stepping to an
+  !   output time, or, it's not the start of the model run.
+  ! Note:  adapt_step_using_child is updated just before recursive call to
+  !    adapt_timestep--see end of this function.
+  !
+
+  if (grid%id == 1) then
+     if ((grid%adaptation_domain > 1) .and. &
+          (grid%max_dom == 2) .and. &
+          (.not. grid%stepping_to_time) .and. &
+          (domain_get_current_time(grid) .ne. &
+          domain_get_start_time(grid)) &
+          ) then
+        
+        grid%adapt_step_using_child = .TRUE.
+     else
+        grid%adapt_step_using_child = .FALSE.
+     endif
+  endif
+
+
+  if (use_last2) then
+     grid%last_dtInterval = last_dtInterval
+     grid%last_max_vert_cfl = grid%last_max_vert_cfl
+     grid%last_max_horiz_cfl = grid%last_max_horiz_cfl
+  else
+     grid%last_dtInterval = dtInterval
+     grid%last_max_vert_cfl = grid%max_vert_cfl
+     grid%last_max_horiz_cfl = grid%max_horiz_cfl
+  endif
+
+  grid%dt = real_time(dtInterval)
+
+  grid%last_max_vert_cfl = grid%max_vert_cfl
+
+  !
+  ! Update the clock based on the new time step
+  !
+  CALL WRFU_ClockSet ( grid%domain_clock,        &
+       timeStep=dtInterval, &
+       rc=rc )
+
+  !
+  ! If we're are adapting based on the child time step, 
+  !    we call the child from here.  This assures that 
+  !    child and parent are updated in sync.
+  ! Note: This is not necessary when we are adapting based
+  !    upon parent.
+  !
+  if ((grid%id == 1) .and. (grid%adapt_step_using_child)) then
+     !
+     ! Finally, check if we can adapt using child.  If we are
+     !   stepping to an output time, we cannot adapt based upon
+     !   child.  So, we reset the variable before calling the child.  
+     ! This covers the case that, within this parent time-step that
+     !   we just calculated, we are stepping to an output time.
+     !
+     if (grid%stepping_to_time) then
+        grid%adapt_step_using_child = .FALSE.
+     endif
+     call adapt_timestep(grid%nests(1)%ptr, config_flags)
+  endif
+
+  !
+  ! Lateral boundary weight recomputation based on time step.
+  !
+  if (grid%id == 1) then
+     CALL lbc_fcx_gcx ( grid%fcx , grid%gcx , grid%spec_bdy_width , &
+          grid%spec_zone , grid%relax_zone , grid%dt , config_flags%spec_exp , &
+          config_flags%specified , config_flags%nested )
+  endif
+
+! Update last timestep info for restart file
+
+  CALL WRFU_TimeIntervalGet(grid%last_dtInterval,  S=grid%last_dt_sec, &
+                         Sn=grid%last_dt_sec_num, Sd=grid%last_dt_sec_den)
+
+END SUBROUTINE adapt_timestep
+
+SUBROUTINE calc_dt(dtInterval, max_cfl, max_increase_factor, precision, &
+     last_dtInterval, target_cfl)
+
+  USE module_domain
+
+  TYPE(WRFU_TimeInterval) ,INTENT(OUT)      :: dtInterval
+  REAL                    ,INTENT(IN)       :: max_cfl
+  REAL                    ,INTENT(IN)       :: max_increase_factor
+  INTEGER                 ,INTENT(IN)       :: precision
+  REAL                    ,INTENT(IN)       :: target_cfl
+  TYPE(WRFU_TimeInterval) ,INTENT(IN)       :: last_dtInterval
+  REAL                                      :: factor
+  INTEGER                                   :: num, den
+  
+
+  if (max_cfl < 0.001) then 
+     !
+     ! If the max_cfl is small, then we increase dtInterval the maximum
+     !    amount allowable.
+     !
+     num = INT(max_increase_factor * precision + 0.5)
+     den = precision
+     dtInterval = last_dtInterval * num / den
+
+  else
+     !
+     ! If the max_cfl is greater than the user input target cfl, we 
+     !    reduce the time step, 
+     ! else, we increase it.
+     !
+     if (max_cfl .gt. target_cfl) then
+        !
+        ! If we are reducing the time step, we go below target cfl by half
+        !   the difference between max and target.
+        !   This tends to keep the model more stable.
+        !
+        
+        factor = ( target_cfl - 0.5 * (max_cfl - target_cfl) ) / max_cfl
+        num = INT(factor * precision + 0.5)
+        den = precision
+
+        dtInterval = last_dtInterval * num / den
+
+     else
+        !
+        ! Linearly increase dtInterval (we'll limit below)
+        !
+        
+        factor = target_cfl / max_cfl
+        num = INT(factor * precision + 0.5)
+        den = precision
+        dtInterval = last_dtInterval * num / den
+     endif
+  endif
+
+END SUBROUTINE calc_dt
+
+
+FUNCTION real_time( timeinterval ) RESULT ( out_time )
+
+  USE module_domain
+
+  IMPLICIT NONE 
+
+! This function returns a floating point time from an input time interval
+!  
+! Unfortunately, the ESMF did not provide this functionality.
+!
+! Be careful with the output because, due to rounding, the time is only
+!   approximate.
+!
+! Todd Hutchinson, WSI
+! 4/17/2007
+
+! !RETURN VALUE:
+      REAL :: out_time
+      INTEGER :: dt_num, dt_den, dt_whole
+
+! !ARGUMENTS:
+      TYPE(WRFU_TimeInterval), intent(INOUT) :: timeinterval
+
+      CALL WRFU_TimeIntervalGet(timeinterval,Sn=dt_num,Sd=dt_den,S=dt_whole)
+      if (ABS(dt_den) < 1) then
+         out_time = dt_whole
+      else
+         out_time = dt_whole + dt_num / REAL(dt_den)
+      endif
+END FUNCTION 
+
+FUNCTION real_time_r8( timeinterval ) RESULT ( out_time )
+
+  USE module_domain
+
+  IMPLICIT NONE 
+
+! This function returns a double precision floating point time from an input time interval
+!  
+! Unfortunately, the ESMF did not provide this functionality.
+!
+! Be careful with the output because, due to rounding, the time is only
+!   approximate.
+!
+! Todd Hutchinson, WSI 4/17/2007
+! Converted to r8, William.Gustafson@pnl.gov; 8-May-2008
+
+! !RETURN VALUE:
+      REAL(KIND=8) :: out_time
+      INTEGER(KIND=8) :: dt_whole
+      INTEGER :: dt_num, dt_den
+
+! !ARGUMENTS:
+      TYPE(WRFU_TimeInterval), intent(INOUT) :: timeinterval
+
+      CALL WRFU_TimeIntervalGet(timeinterval,Sn=dt_num,Sd=dt_den,S_i8=dt_whole)
+      if (ABS(dt_den) < 1) then
+         out_time = REAL(dt_whole)
+      else
+         out_time = REAL(dt_whole) + REAL(dt_num,8)/REAL(dt_den,8)
+      endif
+END FUNCTION real_time_r8
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/couple_or_uncouple_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/couple_or_uncouple_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/couple_or_uncouple_em.F	(revision 17)
@@ -0,0 +1,447 @@
+!WRF:MEDIATION_LAYER:couple_uncouple_utility
+
+SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple &
+!
+#include "dummy_new_args.inc"
+!
+                 )
+
+
+!  #undef DM_PARALLEL
+
+! Driver layer modules
+   USE module_domain, ONLY : domain, get_ijk_from_grid
+   USE module_configure, ONLY : grid_config_rec_type
+   USE module_driver_constants
+   USE module_machine
+   USE module_tiles
+#ifdef DM_PARALLEL
+   USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic
+   USE module_comm_dm, ONLY : halo_em_couple_a_sub,halo_em_couple_b_sub,period_em_couple_a_sub,period_em_couple_b_sub
+#else
+   USE module_dm
+#endif
+   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 <dummy_new_decl.inc>
+
+   !  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
+
+
+   IF ( config_flags%periodic_x .OR. config_flags%periodic_y ) THEN
+     CALL set_physical_bc2d( grid%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%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%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%mub(i,j) + grid%mu_2(i,j)
+       muwt_2(i,j) = (grid%mub(i,j) + grid%mu_2(i,j))/grid%msfty(i,j) ! w coupled with y
+     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%mub(i,j)+grid%mub(i-1,j) + grid%mu_2(i,j) + grid%mu_2(i-1,j))/grid%msfuy(i,j) ! u coupled with y
+       muvt_2(i,j) = 0.5*(grid%mub(i,j)+grid%mub(i,j-1) + grid%mu_2(i,j) + grid%mu_2(i,j-1))/grid%msfvx(i,j) ! v coupled with x
+     ENDDO
+     ENDDO
+
+     IF ( config_flags%nested .or. config_flags%specified .or. config_flags%polar ) THEN
+
+       IF ( jpe .eq. jde ) THEN
+         j = jde
+         DO i = max(ids,ips),min(ide-1,ipe)
+           muvt_2(i,j) = (grid%mub(i,j-1) + grid%mu_2(i,j-1))/grid%msfvx(i,j) ! v coupled with x
+         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%mub(i-1,j) + grid%mu_2(i-1,j))/grid%msfuy(i,j) ! u coupled with y
+         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%mub(i,j)+grid%mub(i,j-1) + grid%mu_2(i,j) + grid%mu_2(i,j-1))/grid%msfvx(i,j) ! v coupled with x
+         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%mub(i,j)+grid%mub(i-1,j) + grid%mu_2(i,j) + grid%mu_2(i-1,j))/grid%msfuy(i,j) ! u coupled with y
+         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%mub(i,j) + grid%mu_2(i,j))
+       muwt_2(i,j) = grid%msfty(i,j)/(grid%mub(i,j) + grid%mu_2(i,j)) ! w coupled with y
+     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%msfuy(i,j)/(grid%mub(i,j)+grid%mub(i-1,j) + grid%mu_2(i,j) + grid%mu_2(i-1,j)) ! u coupled with y
+     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%msfvx(i,j)/(grid%mub(i,j)+grid%mub(i,j-1) + grid%mu_2(i,j) + grid%mu_2(i,j-1)) ! v coupled with x
+     ENDDO
+     ENDDO
+
+     IF ( config_flags%nested .or. config_flags%specified .or. config_flags%polar ) THEN
+
+       IF ( jpe .eq. jde ) THEN
+         j = jde 
+         DO i = max(ids,ips),min(ide-1,ipe)
+           muvt_2(i,j) = grid%msfvx(i,j)/(grid%mub(i,j-1) + grid%mu_2(i,j-1)) ! v coupled with x
+         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%msfuy(i,j)/(grid%mub(i-1,j) + grid%mu_2(i-1,j)) ! u coupled with y
+         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%msfvx(i,j)/(grid%mub(i,j)+grid%mub(i,j-1) + grid%mu_2(i,j) + grid%mu_2(i,j-1)) ! v coupled with x
+         ENDDO
+       ENDIF
+       IF ( ipe .eq. ide ) THEN
+         i = ide       
+         DO j = max(jds,jps),min(jde-1,jpe)
+           muut_2(i,j) = 2.*grid%msfuy(i,j)/(grid%mub(i,j)+grid%mub(i-1,j) + grid%mu_2(i,j) + grid%mu_2(i-1,j)) ! u coupled with y
+         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%ph_2(i,k,j) = grid%ph_2(i,k,j)*mut_2(i,j)
+       grid%w_2(i,k,j)  =  grid%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%t_2(i,k,j)  =  grid%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
+
+     IF (num_tracer >= PARAM_FIRST_SCALAR )  THEN
+       DO im = PARAM_FIRST_SCALAR, num_tracer
+         DO k = kps,kpe-1
+         DO i = max(ids,ips),min(ide-1,ipe)
+           tracer(i,k,j,im)  =  tracer(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%u_2(i,k,j)  =  grid%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%v_2(i,k,j)  =  grid%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%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%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%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%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%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%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%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%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%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%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
+
+     IF (num_tracer >= PARAM_FIRST_SCALAR) THEN
+       DO im = PARAM_FIRST_SCALAR , num_tracer
+ 
+     CALL set_physical_bc3d( tracer(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 cd_feedback_mask( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, xstag, ystag )
+   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
+
+   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 cd_feedback_mask
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/init_modules_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/init_modules_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/init_modules_em.F	(revision 17)
@@ -0,0 +1,5 @@
+!WRF:MEDIATION_LAYER
+!
+SUBROUTINE init_modules_em
+END SUBROUTINE init_modules_em
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/interp_domain_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/interp_domain_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/interp_domain_em.F	(revision 17)
@@ -0,0 +1,60 @@
+#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 "dummy_new_args.inc"
+!
+                 )
+         USE module_state_description
+         USE module_domain, ONLY : domain, get_ijk_from_grid
+         USE module_configure, ONLY : grid_config_rec_type
+         TYPE(domain), POINTER :: grid , ngrid
+#include <dummy_new_decl.inc>
+
+      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 "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
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_advect_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_advect_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_advect_em.F	(revision 17)
@@ -0,0 +1,8661 @@
+!WRF:MODEL_LAYER:DYNAMICS
+!
+MODULE module_advect_em
+
+  USE module_bc
+  USE module_model_constants
+  USE module_wrf_error
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+
+SUBROUTINE advect_u   ( u, u_old, tendency,            &
+                        ru, rv, rom,                   &
+                        mut, time_step, config_flags,  &
+                        msfux, msfuy, msfvx, msfvy,    &
+                        msftx, msfty,                  &
+                        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   ) :: msfux,  &
+                                                                    msfuy,  &
+                                                                    msfvx,  &
+                                                                    msfvy,  &
+                                                                    msftx,  &
+                                                                    msfty
+
+   REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
+                                                                  fzp,  &
+                                                                  rdzw
+
+   REAL ,                                        INTENT(IN   ) :: rdx,  &
+                                                                  rdy
+   INTEGER ,                                     INTENT(IN   ) :: time_step
+
+   ! 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,time_step)*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,time_step)*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+3)                ) 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+3)                ) degrade_ys = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ye .or. &
+       (jte < jde-4)                ) 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
+
+      IF(config_flags%polar) j_end = MIN(jte,jde-1)
+
+!  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 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
+
+!  y flux-divergence into tendency
+
+        ! (j > j_start) will miss the u(,,jds) tendency
+        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
+          END DO
+          END DO
+        ! This would be seen by (j > j_start) but we need to zero out the NP tendency
+        ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
+          END DO
+          END DO
+        ELSE  ! normal code
+
+        IF(j > j_start) THEN
+
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+          ENDDO
+          ENDDO
+
+        ENDIF
+
+        END IF
+
+
+        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=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
+            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+3)                ) 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+3)                ) degrade_ys = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ye .or. &
+       (jte < jde-4)                ) 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
+
+      IF(config_flags%polar) j_end = MIN(jte,jde-1)
+
+!  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 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
+
+        ! (j > j_start) will miss the u(,,jds) tendency
+        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
+          END DO
+          END DO
+        ! This would be seen by (j > j_start) but we need to zero out the NP tendency
+        ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
+          END DO
+          END DO
+        ELSE  ! normal code
+
+        IF(j > j_start) THEN
+
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+          ENDDO
+          ENDDO
+
+        ENDIF
+
+        END IF
+
+
+        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=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
+            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+2)                ) 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+2)                ) degrade_ys = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ye .or. &
+       (jte < jde-3)                ) 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=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
+            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
+
+      IF(config_flags%polar) j_end = MIN(jte,jde-1)
+
+!  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
+         ! Assumes j>j_end_f is ONLY j_end+1 ...
+!         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))
+         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
+!  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
+
+!  y flux-divergence into tendency
+
+     ! (j > j_start) will miss the u(,,jds) tendency
+     IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+       DO k=kts,ktf
+       DO i = i_start, i_end
+         mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
+         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
+       END DO
+       END DO
+       ! This would be seen by (j > j_start) but we need to zero out the NP tendency
+     ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
+       DO k=kts,ktf
+       DO i = i_start, i_end
+         mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
+         tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
+       END DO
+       END DO
+     ELSE  ! normal code
+
+     IF (j > j_start) THEN
+
+       DO k=kts,ktf
+       DO i = i_start, i_end
+          mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS
+          tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+       ENDDO
+       ENDDO
+
+     END IF
+
+     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+2)                ) 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+2)                ) degrade_ys = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ye .or. &
+       (jte < jde-3)                ) 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=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS
+            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
+
+      IF(config_flags%polar) j_end = MIN(jte,jde-1)
+
+!  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
+         ! Assumes j>j_end_f is ONLY j_end+1 ...
+!         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))
+         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
+!  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
+
+!  y flux-divergence into tendency
+
+     ! (j > j_start) will miss the u(,,jds) tendency
+     IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+       DO k=kts,ktf
+       DO i = i_start, i_end
+         mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
+         tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
+       END DO
+       END DO
+       ! This would be seen by (j > j_start) but we need to zero out the NP tendency
+     ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
+       DO k=kts,ktf
+       DO i = i_start, i_end
+         mrdy=msfux(i,j-1)*rdy   ! ADT eqn 44, 2nd term on RHS
+         tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
+       END DO
+       END DO
+     ELSE  ! normal code
+
+     IF (j > j_start) THEN
+
+       DO k=kts,ktf
+       DO i = i_start, i_end
+          mrdy=msfux(i,j-1)*rdy      ! ADT eqn 44, 2nd term on RHS
+          tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+       ENDDO
+       ENDDO
+
+     END IF
+
+     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=msfux(i,j)*rdx         ! ADT eqn 44, 1st term on RHS
+         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=msfux(i,j)*rdx       ! ADT eqn 44, 1st term on RHS
+           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=msfux(i,j)*rdx       ! ADT eqn 44, 1st term on RHS
+           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=msfux(i,j)*rdy         ! ADT eqn 44, 1st term on RHS
+         ! Comments for polar boundary condition
+         ! Flow is only from one side for points next to poles
+         IF ( (config_flags%polar) .AND. (j == jds) ) THEN
+            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))
+         ELSE IF ( (config_flags%polar) .AND. (j == jde-1) ) THEN
+            tendency(i,k,j)=tendency(i,k,j)+mrdy*0.25 &
+                           *(rv(i,k,j)+rv(i-1,k,j))*(u(i,k,j)+u(i,k,j-1))
+         ELSE  ! Normal code
+            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)))
+         ENDIF
+      ENDDO
+      ENDDO
+      ENDDO
+
+   ELSE IF ( horz_order == 0 ) THEN
+
+      ! Just in case we want to turn horizontal advection off, we can do it
+
+   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=msfux(i,jts)*rdy       ! ADT eqn 44, 2nd term on RHS
+         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=msfux(i,jte-1)*rdy     ! ADT eqn 44, 2nd term on RHS
+         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
+!  ADT eqn 44 has 3rd term on RHS = -(1/my) partial d/dz (rho u w)
+!  Here we have:  - partial d/dz (u*rom) = - partial d/dz (u rho w / my)
+!  Since 'my' (map scale factor in y-direction) isn't a function of z,
+!  this is what we need, so leave unchanged in advect_u
+
+   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, time_step, config_flags,  &
+                        msfux, msfuy, msfvx, msfvy,    &
+                        msftx, msfty,                  &
+                        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   ) :: msfux,  &
+                                                                    msfuy,  &
+                                                                    msfvx,  &
+                                                                    msfvy,  &
+                                                                    msftx,  &
+                                                                    msfty
+
+   REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
+                                                                  fzp,  &
+                                                                  rdzw
+
+   REAL ,                                        INTENT(IN   ) :: rdx,  &
+                                                                  rdy
+   INTEGER ,                                     INTENT(IN   ) :: time_step
+
+
+   ! 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,time_step)*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,time_step)*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+3)                ) 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+3)                ) 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   = 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
+
+        ! Comments on polar boundary conditions
+        ! No advection over the poles means tendencies (held from jds [S. pole]
+        ! to jde [N pole], i.e., on v grid) must be zero at poles
+        ! [tendency(jds) and tendency(jde)=0]
+        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            tendency(i,k,j-1) = 0.
+          END DO
+          END DO
+        ! If j_end were set to jde in a special if statement apart from
+        ! degrade_ye, then we would hit the next conditional.  But since
+        ! we want the tendency to be zero anyway, not looping to jde+1
+        ! will produce the same effect.
+        ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            tendency(i,k,j-1) = 0.
+          END DO
+          END DO
+        ELSE  ! Normal code
+
+        IF(j > j_start) THEN
+
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msfvy(i,j-1)*rdy    ! ADT eqn 45, 2nd term on RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+          ENDDO
+          ENDDO
+
+        ENDIF
+
+        END IF
+
+        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
+      ! Polar boundary conditions are like open or specified
+      IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
+      IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) 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
+        i_start_f = MIN(i_start+2,ids+3)
+      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
+
+          DO i=i_start,i_start_f-1
+
+            IF(i == ids+1) THEN ! second order
+              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
+
+            IF(i == ids+2) THEN  ! third order
+              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
+
+          ENDDO
+
+        ENDIF
+
+        IF( degrade_xe ) THEN
+
+          DO i = i_end_f+1, i_end+1
+
+            IF( i == ide-1 ) THEN ! second order flux next to the boundary
+              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
+
+            IF( i == ide-2 ) THEN ! third order flux one in from the boundary
+              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
+
+          ENDDO
+
+        ENDIF
+
+!  x flux-divergence into tendency
+
+        DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
+            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+3)                ) 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+3)                ) 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   = 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
+
+        ! Comments on polar boundary conditions
+        ! No advection over the poles means tendencies (held from jds [S. pole]
+        ! to jde [N pole], i.e., on v grid) must be zero at poles
+        ! [tendency(jds) and tendency(jde)=0]
+        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            tendency(i,k,j-1) = 0.
+          END DO
+          END DO
+        ! If j_end were set to jde in a special if statement apart from
+        ! degrade_ye, then we would hit the next conditional.  But since
+        ! we want the tendency to be zero anyway, not looping to jde+1
+        ! will produce the same effect.
+        ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            tendency(i,k,j-1) = 0.
+          END DO
+          END DO
+        ELSE  ! Normal code
+
+        IF(j > j_start) THEN
+
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msfvy(i,j-1)*rdy    ! ADT eqn 45, 2nd term on RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+          ENDDO
+          ENDDO
+
+        ENDIF
+
+        END IF
+
+        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
+      ! Polar boundary conditions are like open or specified
+      IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
+      IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) 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
+        i_start_f = MIN(i_start+2,ids+3)
+      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
+
+          DO i=i_start,i_start_f-1
+
+            IF(i == ids+1) THEN ! second order
+              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
+
+            IF(i == ids+2) THEN  ! third order
+              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
+
+          ENDDO
+
+        ENDIF
+
+        IF( degrade_xe ) THEN
+
+          DO i = i_end_f+1, i_end+1
+
+            IF( i == ide-1 ) THEN ! second order flux next to the boundary
+              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
+
+            IF( i == ide-2 ) THEN ! third order flux one in from the boundary
+              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
+
+          ENDDO
+
+        ENDIF
+
+!  x flux-divergence into tendency
+
+        DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdx=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
+            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+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-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
+
+!  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
+
+      ! Comments on polar boundary conditions
+      ! No advection over the poles means tendencies (held from jds [S. pole]
+      ! to jde [N pole], i.e., on v grid) must be zero at poles
+      ! [tendency(jds) and tendency(jde)=0]
+      IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+        DO k=kts,ktf
+        DO i = i_start, i_end
+          tendency(i,k,j-1) = 0.
+        END DO
+        END DO
+      ! If j_end were set to jde in a special if statement apart from
+      ! degrade_ye, then we would hit the next conditional.  But since
+      ! we want the tendency to be zero anyway, not looping to jde+1
+      ! will produce the same effect.
+      ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
+        DO k=kts,ktf
+        DO i = i_start, i_end
+          tendency(i,k,j-1) = 0.
+        END DO
+        END DO
+      ELSE  ! Normal code
+
+      IF( j > j_start) THEN
+        DO k = kts, ktf
+        DO i = i_start, i_end
+            mrdy=msfvy(i,j-1)*rdy     ! ADT eqn 45, 2nd term on RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+        ENDDO
+        ENDDO
+
+      END IF
+
+      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
+      ! Polar boundary conditions are like open or specified
+      IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
+      IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) 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=msfvy(i,j)*rdx       ! ADT eqn 45, 1st term on RHS
+            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+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-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
+
+!  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
+
+      ! Comments on polar boundary conditions
+      ! No advection over the poles means tendencies (held from jds [S. pole]
+      ! to jde [N pole], i.e., on v grid) must be zero at poles
+      ! [tendency(jds) and tendency(jde)=0]
+      IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+        DO k=kts,ktf
+        DO i = i_start, i_end
+          tendency(i,k,j-1) = 0.
+        END DO
+        END DO
+      ! If j_end were set to jde in a special if statement apart from
+      ! degrade_ye, then we would hit the next conditional.  But since
+      ! we want the tendency to be zero anyway, not looping to jde+1
+      ! will produce the same effect.
+      ELSE IF( config_flags%polar .AND. (j == jde+1) ) THEN
+        DO k=kts,ktf
+        DO i = i_start, i_end
+          tendency(i,k,j-1) = 0.
+        END DO
+        END DO
+      ELSE  ! Normal code
+
+      IF( j > j_start) THEN
+        DO k = kts, ktf
+        DO i = i_start, i_end
+            mrdy=msfvy(i,j-1)*rdy     ! ADT eqn 45, 2nd term on RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+        ENDDO
+        ENDDO
+
+      END IF
+
+      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
+      ! Polar boundary conditions are like open or specified
+      IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
+      IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) 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=msfvy(i,j)*rdx      ! ADT eqn 45, 1st term on RHS
+            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)
+      IF ( config_flags%polar ) j_start = MAX(jds+1,jts)
+      IF ( config_flags%polar ) j_end   = MIN(jde-1,jte)
+
+      DO j = j_start, j_end
+      DO k=kts,ktf
+      DO i = i_start, i_end
+
+         mrdy=msfvy(i,j)*rdy          ! ADT eqn 45, 2nd term on RHS
+
+            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
+
+      ! Comments on polar boundary conditions
+      ! tendencies = 0 at poles, and polar points do not contribute at points
+      ! next to poles
+      IF (config_flags%polar) THEN
+         IF (jts == jds) THEN
+            DO k=kts,ktf
+            DO i = i_start, i_end
+               tendency(i,k,jds) = 0.
+            END DO
+            END DO
+         END IF
+         IF (jte == jde) THEN
+            DO k=kts,ktf
+            DO i = i_start, i_end
+               tendency(i,k,jde) = 0.
+            END DO
+            END DO
+         END IF
+      END IF
+
+!  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=msfvy(i,j)*rdy       ! ADT eqn 45, 2nd term on RHS
+           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=msfvy(i,j)*rdy       ! ADT eqn 45, 2nd term on RHS
+           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
+      IF ( config_flags%polar ) j_start = MAX(jds+1,jts)
+      IF ( config_flags%polar ) j_end   = MIN(jde-1,jte)
+
+      DO j = j_start, j_end
+      DO k=kts,ktf
+      DO i = i_start, i_end
+
+         mrdx=msfvy(i,j)*rdx         ! ADT eqn 45, 1st term on RHS
+
+            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 IF ( horz_order == 0 ) THEN
+
+      ! Just in case we want to turn horizontal advection off, we can do it
+
+  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
+
+   !  Comments on polar boundary condition
+   !  Force tendency=0 at NP and SP
+   !  We keep setting this everywhere, but it can't hurt...
+   IF ( config_flags%polar .AND. (jts == jds) ) THEN
+      DO i=its,ite
+      DO k=kts,ktf
+         tendency(i,k,jts)=0.
+      END DO
+      END DO
+   END IF
+   IF ( config_flags%polar .AND. (jte == jde) ) THEN
+      DO i=its,ite
+      DO k=kts,ktf
+         tendency(i,k,jte)=0.
+      END DO
+      END DO
+   END IF
+
+!  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=msfvy(its,j)*rdx       ! ADT eqn 45, 1st term on RHS
+         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=msfvy(ite-1,j)*rdx     ! ADT eqn 45, 1st term on RHS
+         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
+!     ADT eqn 45 has 3rd term on RHS = -(1/mx) partial d/dz (rho v w)
+!     Here we have: - partial d/dz (v*rom) = - partial d/dz (v rho w / my)
+!     We therefore need to make a correction for advect_v
+!     since 'my' (map scale factor in y direction) isn't a function of z,
+!     we can do this using *(my/mx) (see eqn. 45 for example)
+
+
+      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
+
+      ! Polar boundary conditions are like open or specified
+      ! We don't want to calculate vertical v tendencies at the N or S pole
+      IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
+      IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) 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
+            ! We are calculating vertical fluxes on v points,
+            ! so we must mean msf_v_x/y variables
+            tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
+         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
+            ! We are calculating vertical fluxes on v points,
+            ! so we must mean msf_v_x/y variables
+            tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
+         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
+            ! We are calculating vertical fluxes on v points,
+            ! so we must mean msf_v_x/y variables
+            tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
+         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
+            ! We are calculating vertical fluxes on v points,
+            ! so we must mean msf_v_x/y variables
+            tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
+         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
+            ! We are calculating vertical fluxes on v points,
+            ! so we must mean msf_v_x/y variables
+            tendency(i,k,j)=tendency(i,k,j)-(msfvy(i,j)/msfvx(i,j))*rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ! ADT eqn 45, 3rd term on RHS
+      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, time_step, config_flags,  &
+                             msfux, msfuy, msfvx, msfvy,    &
+                             msftx, msfty,                  &
+                             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   ) :: msfux,  &
+                                                                    msfuy,  &
+                                                                    msfvx,  &
+                                                                    msfvy,  &
+                                                                    msftx,  &
+                                                                    msfty
+
+   REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
+                                                                  fzp,  &
+                                                                  rdzw
+
+   REAL ,                                        INTENT(IN   ) :: rdx,  &
+                                                                  rdy
+   INTEGER ,                                     INTENT(IN   ) :: time_step
+
+
+   ! 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,time_step)*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,time_step)*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+3)                ) 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+3)                ) degrade_ys = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ye .or. &
+       (jte < jde-4)                ) 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
+
+      IF(config_flags%polar) j_end = MIN(jte,jde-1)
+
+!  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  ! 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
+
+        ! Comments on polar boundary conditions
+        ! Same process as for advect_u - tendencies run from jds to jde-1 
+        ! (latitudes are as for u grid, longitudes are displaced)
+        ! Therefore: flow is only from one side for points next to poles
+        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
+          END DO
+          END DO
+        ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
+          END DO
+          END DO
+        ELSE  ! normal code
+
+        IF(j > j_start) THEN
+
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+          ENDDO
+          ENDDO
+
+        ENDIF
+
+        END IF
+
+        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
+        i_start_f = MIN(i_start+2,ids+3)
+      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
+
+          DO i=i_start,i_start_f-1
+
+            IF(i == ids+1) THEN ! second order
+              DO k=kts,ktf
+                fqx(i,k) = 0.5*(ru(i,k,j)) &
+                       *(field(i,k,j)+field(i-1,k,j))
+              ENDDO
+            ENDIF
+
+            IF(i == ids+2) THEN  ! third order
+              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
+            END IF
+
+          ENDDO
+
+        ENDIF
+
+        IF( degrade_xe ) THEN
+
+          DO i = i_end_f+1, i_end+1
+
+            IF( i == ide-1 ) THEN ! second order flux next to the boundary
+              DO k=kts,ktf
+                fqx(i,k) = 0.5*(ru(i,k,j))      &
+                       *(field(i,k,j)+field(i-1,k,j))
+              ENDDO
+           ENDIF
+
+           IF( i == ide-2 ) THEN ! third order flux one in from the boundary
+             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
+
+         ENDDO
+
+       ENDIF
+
+!  x flux-divergence into tendency
+
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdx=msftx(i,j)*rdx      ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
+            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+3)                ) 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+3)                ) degrade_ys = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ye .or. &
+       (jte < jde-4)                ) 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
+
+      IF(config_flags%polar) j_end = MIN(jte,jde-1)
+
+!  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
+
+        ! Comments on polar boundary conditions
+        ! Same process as for advect_u - tendencies run from jds to jde-1 
+        ! (latitudes are as for u grid, longitudes are displaced)
+        ! Therefore: flow is only from one side for points next to poles
+        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
+          END DO
+          END DO
+        ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
+          END DO
+          END DO
+        ELSE  ! normal code
+
+        IF(j > j_start) THEN
+
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+          ENDDO
+          ENDDO
+
+        ENDIF
+
+        END IF
+
+        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
+        i_start_f = MIN(i_start+2,ids+3)
+      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
+
+          DO i=i_start,i_start_f-1
+
+            IF(i == ids+1) THEN ! second order
+              DO k=kts,ktf
+                fqx(i,k) = 0.5*(ru(i,k,j)) &
+                       *(field(i,k,j)+field(i-1,k,j))
+              ENDDO
+            ENDIF
+
+            IF(i == ids+2) THEN  ! third order
+              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
+            END IF
+
+          ENDDO
+
+        ENDIF
+
+        IF( degrade_xe ) THEN
+
+          DO i = i_end_f+1, i_end+1
+
+            IF( i == ide-1 ) THEN ! second order flux next to the boundary
+              DO k=kts,ktf
+                fqx(i,k) = 0.5*(ru(i,k,j))      &
+                       *(field(i,k,j)+field(i-1,k,j))
+              ENDDO
+           ENDIF
+
+           IF( i == ide-2 ) THEN ! third order flux one in from the boundary
+             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
+
+         ENDDO
+
+       ENDIF
+
+!  x flux-divergence into tendency
+
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdx=msftx(i,j)*rdx      ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
+            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+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.
+
+!  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=msftx(i,j)*rdx        ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
+          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
+
+      IF(config_flags%polar) j_end = MIN(jte,jde-1)
+
+    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
+         ! Assumes j>j_end_f is ONLY j_end+1 ...
+!         fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1)          &
+!                *(field(i,k,j_end+1)+field(i,k,j_end))
+         fqy(i,k,jp1) = 0.5*rv(i,k,j)          &
+                *(field(i,k,j)+field(i,k,j-1))
+      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
+
+!  y flux-divergence into tendency
+
+    ! Comments on polar boundary conditions
+    ! Same process as for advect_u - tendencies run from jds to jde-1 
+    ! (latitudes are as for u grid, longitudes are displaced)
+    ! Therefore: flow is only from one side for points next to poles
+    IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+      DO k=kts,ktf
+      DO i = i_start, i_end
+        mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+        tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
+      END DO
+      END DO
+    ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
+      DO k=kts,ktf
+      DO i = i_start, i_end
+        mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+        tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
+      END DO
+      END DO
+    ELSE  ! normal code
+
+    IF ( j > j_start ) THEN
+
+      DO k=kts,ktf
+      DO i = i_start, i_end
+        mrdy=msftx(i,j-1)*rdy        ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+        tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+      ENDDO
+      ENDDO
+
+    END IF
+
+    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+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.
+
+!  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=msftx(i,j)*rdx        ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
+          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
+
+      IF(config_flags%polar) j_end = MIN(jte,jde-1)
+
+    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
+         ! Assumes j>j_end_f is ONLY j_end+1 ...
+!         fqy(i,k,jp1) = 0.5*rv(i,k,j_end+1)          &
+!                *(field(i,k,j_end+1)+field(i,k,j_end))
+         fqy(i,k,jp1) = 0.5*rv(i,k,j)          &
+                *(field(i,k,j)+field(i,k,j-1))
+      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
+
+!  y flux-divergence into tendency
+
+    ! Comments on polar boundary conditions
+    ! Same process as for advect_u - tendencies run from jds to jde-1 
+    ! (latitudes are as for u grid, longitudes are displaced)
+    ! Therefore: flow is only from one side for points next to poles
+    IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+      DO k=kts,ktf
+      DO i = i_start, i_end
+        mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+        tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
+      END DO
+      END DO
+    ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
+      DO k=kts,ktf
+      DO i = i_start, i_end
+        mrdy=msftx(i,j-1)*rdy     ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+        tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
+      END DO
+      END DO
+    ELSE  ! normal code
+
+    IF ( j > j_start ) THEN
+
+      DO k=kts,ktf
+      DO i = i_start, i_end
+        mrdy=msftx(i,j-1)*rdy        ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+        tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+      ENDDO
+      ENDDO
+
+    END IF
+
+    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=msftx(i,j)*rdx         ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS
+         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)
+
+      ! Polar boundary conditions are like open or specified
+      IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
+      IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-2,jte)
+
+      DO j = j_start, j_end
+      DO k = kts, ktf
+      DO i = i_start, i_end
+         mrdy=msftx(i,j)*rdy         ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+         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
+   
+      ! Polar boundary condtions
+      ! These won't be covered in the loop above...
+      IF (config_flags%polar) THEN
+         IF (jts == jds) THEN
+            DO k=kts,ktf
+            DO i = i_start, i_end
+               mrdy=msftx(i,jds)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+               tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 &
+                                *rv(i,k,jds+1)*(field(i,k,jds+1)+field(i,k,jds))
+            END DO
+            END DO
+         END IF
+         IF (jte == jde) THEN
+            DO k=kts,ktf
+            DO i = i_start, i_end
+               mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS
+               tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 &
+                                  *rv(i,k,jde-1)*(field(i,k,jde-1)+field(i,k,jde-2))
+            END DO
+            END DO
+         END IF
+      END IF
+
+   ELSE IF ( horz_order == 0 ) THEN
+
+      ! Just in case we want to turn horizontal advection off, we can do it
+
+   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
+!     Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my)
+!     Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my)
+!     So we don't need to make a correction for advect_scalar
+
+      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, time_step, config_flags,  &
+                         msfux, msfuy, msfvx, msfvy,    &
+                         msftx, msfty,                  &
+                         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   ) :: msfux,  &
+                                                                    msfuy,  &
+                                                                    msfvx,  &
+                                                                    msfvy,  &
+                                                                    msftx,  &
+                                                                    msfty
+
+   REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
+                                                                  fzp,  &
+                                                                  rdzu
+
+   REAL ,                                        INTENT(IN   ) :: rdx,  &
+                                                                  rdy
+   INTEGER ,                                     INTENT(IN   ) :: time_step
+
+
+   ! 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,time_step)*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,time_step)*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+3)                ) 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+3)                ) degrade_ys = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ye .or. &
+       (jte < jde-4)                ) 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
+
+      IF(config_flags%polar) j_end = MIN(jte,jde-1)
+
+!  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
+
+        ! Comments for polar boundary conditions
+        ! Same process as for advect_u - tendencies run from jds to jde-1 
+        ! (latitudes are as for u grid, longitudes are displaced)
+        ! Therefore: flow is only from one side for points next to poles
+        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
+          END DO
+          END DO
+        ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
+          END DO
+          END DO
+        ELSE  ! normal code
+
+        IF(j > j_start) THEN
+
+          DO k=kts+1,ktf+1
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+          ENDDO
+          ENDDO
+
+       ENDIF
+
+        END IF
+
+        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
+        i_start_f = MIN(i_start+2,ids+3)
+      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
+
+          DO i=i_start,i_start_f-1
+
+            IF(i == ids+1) THEN ! second order
+              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
+
+            IF(i == ids+2) THEN  ! third order
+              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                     )
+            END IF
+
+          ENDDO
+
+        ENDIF
+
+        IF( degrade_xe ) THEN
+
+          DO i = i_end_f+1, i_end+1
+
+            IF( i == ide-1 ) THEN ! second order flux next to the boundary
+              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
+
+            IF( i == ide-2 ) THEN ! third order flux one in from the boundary
+              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
+
+          ENDDO
+
+        ENDIF
+
+!  x flux-divergence into tendency
+
+        DO k=kts+1,ktf+1
+          DO i = i_start, i_end
+            mrdx=msftx(i,j)*rdx      ! see ADT eqn 46 dividing by my, 1st term RHS
+            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+3)                ) 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+3)                ) degrade_ys = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ye .or. &
+       (jte < jde-4)                ) 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
+
+      IF(config_flags%polar) j_end = MIN(jte,jde-1)
+
+!  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
+
+        ! Comments for polar boundary conditions
+        ! Same process as for advect_u - tendencies run from jds to jde-1 
+        ! (latitudes are as for u grid, longitudes are displaced)
+        ! Therefore: flow is only from one side for points next to poles
+        IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
+          END DO
+          END DO
+        ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
+          DO k=kts,ktf
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
+          END DO
+          END DO
+        ELSE  ! normal code
+
+        IF(j > j_start) THEN
+
+          DO k=kts+1,ktf+1
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+          ENDDO
+          ENDDO
+
+       ENDIF
+
+        END IF
+
+        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
+        i_start_f = MIN(i_start+2,ids+3)
+      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
+
+          DO i=i_start,i_start_f-1
+
+            IF(i == ids+1) THEN ! second order
+              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
+
+            IF(i == ids+2) THEN  ! third order
+              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                     )
+            END IF
+
+          ENDDO
+
+        ENDIF
+
+        IF( degrade_xe ) THEN
+
+          DO i = i_end_f+1, i_end+1
+
+            IF( i == ide-1 ) THEN ! second order flux next to the boundary
+              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
+
+            IF( i == ide-2 ) THEN ! third order flux one in from the boundary
+              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
+
+          ENDDO
+
+        ENDIF
+
+!  x flux-divergence into tendency
+
+        DO k=kts+1,ktf+1
+          DO i = i_start, i_end
+            mrdx=msftx(i,j)*rdx      ! see ADT eqn 46 dividing by my, 1st term RHS
+            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+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.
+
+!  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=msftx(i,j)*rdx        ! see ADT eqn 46 dividing by my, 1st term RHS
+          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
+
+      IF(config_flags%polar) j_end = MIN(jte,jde-1)
+
+        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
+            ! Assumes j>j_end_f is ONLY j_end+1 ...
+!            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))
+            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
+            ! Assumes j>j_end_f is ONLY j_end+1 ...
+!            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))
+            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
+!  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
+
+!  y flux-divergence into tendency
+
+       ! Comments for polar boundary conditions
+       ! Same process as for advect_u - tendencies run from jds to jde-1 
+       ! (latitudes are as for u grid, longitudes are displaced)
+       ! Therefore: flow is only from one side for points next to poles
+       IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+         DO k=kts,ktf
+         DO i = i_start, i_end
+           mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
+           tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
+         END DO
+         END DO
+       ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
+         DO k=kts,ktf
+         DO i = i_start, i_end
+           mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
+           tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
+         END DO
+         END DO
+       ELSE  ! normal code
+
+       IF( j > j_start ) THEN
+
+          DO k = kts+1, ktf+1
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+          ENDDO
+          ENDDO
+
+       END IF
+
+       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+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.
+
+!  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=msftx(i,j)*rdx        ! see ADT eqn 46 dividing by my, 1st term RHS
+          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
+
+      IF(config_flags%polar) j_end = MIN(jte,jde-1)
+
+        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
+            ! Assumes j>j_end_f is ONLY j_end+1 ...
+!            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))
+            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
+            ! Assumes j>j_end_f is ONLY j_end+1 ...
+!            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))
+            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
+!  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
+
+!  y flux-divergence into tendency
+
+       ! Comments for polar boundary conditions
+       ! Same process as for advect_u - tendencies run from jds to jde-1 
+       ! (latitudes are as for u grid, longitudes are displaced)
+       ! Therefore: flow is only from one side for points next to poles
+       IF ( config_flags%polar .AND. (j == jds+1) ) THEN
+         DO k=kts,ktf
+         DO i = i_start, i_end
+           mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
+           tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1)
+         END DO
+         END DO
+       ELSE IF( config_flags%polar .AND. (j == jde) ) THEN
+         DO k=kts,ktf
+         DO i = i_start, i_end
+           mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
+           tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0)
+         END DO
+         END DO
+       ELSE  ! normal code
+
+       IF( j > j_start ) THEN
+
+          DO k = kts+1, ktf+1
+          DO i = i_start, i_end
+            mrdy=msftx(i,j-1)*rdy    ! see ADT eqn 46 dividing by my, 2nd term RHS
+            tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0))
+          ENDDO
+          ENDDO
+
+       END IF
+
+       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=msftx(i,j)*rdx         ! see ADT eqn 46 dividing by my, 1st term RHS
+
+            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=msftx(i,j)*rdx         ! see ADT eqn 46 dividing by my, 1st term RHS
+
+            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)
+      ! Polar boundary conditions are like open or specified
+      IF ( config_flags%open_ys .or. specified .or. config_flags%polar ) j_start = MAX(jds+1,jts)
+      IF ( config_flags%open_ye .or. specified .or. config_flags%polar ) j_end   = MIN(jde-2,jte)
+
+      DO j = j_start, j_end
+      DO k=kts+1,ktf
+      DO i = i_start, i_end
+
+         mrdy=msftx(i,j)*rdy         !  see ADT eqn 46 dividing by my, 2nd term RHS
+
+            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=msftx(i,j)*rdy         ! see ADT eqn 46 dividing by my, 2nd term RHS
+
+            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
+
+      ! Polar boundary condition ... not covered in above j-loop
+      IF (config_flags%polar) THEN
+         IF (jts == jds) THEN
+            DO k=kts+1,ktf
+            DO i = i_start, i_end
+               mrdy=msftx(i,jds)*rdy   ! see ADT eqn 46 dividing by my, 2nd term RHS
+               tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5 &
+                          *((fzm(k)*rv(i,k,jds+1)+fzp(k)*rv(i,k-1,jds+1))* &
+                            (w(i,k,jds+1)+w(i,k,jds)))
+            END DO
+            END DO
+            k = ktf+1
+            DO i = i_start, i_end
+               mrdy=msftx(i,jds)*rdy   ! see ADT eqn 46 dividing by my, 2nd term RHS
+               tendency(i,k,jds)=tendency(i,k,jds) -mrdy*0.5       &
+                   *((2.-fzm(k-1))*rv(i,k-1,jds+1)-fzp(k-1)*rv(i,k-2,jds+1))* &
+                                 (w(i,k,jds+1)+w(i,k,jds))
+            ENDDO
+         END IF
+         IF (jte == jde) THEN
+            DO k=kts+1,ktf
+            DO i = i_start, i_end
+               mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
+               tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5 &
+                          *((fzm(k)*rv(i,k,jde-1)+fzp(k)*rv(i,k-1,jde-1))* &
+                            (w(i,k,jde-1)+w(i,k,jde-2)))
+            END DO
+            END DO
+            k = ktf+1
+            DO i = i_start, i_end
+               mrdy=msftx(i,jde-1)*rdy ! see ADT eqn 46 dividing by my, 2nd term RHS
+               tendency(i,k,jde-1)=tendency(i,k,jde-1) +mrdy*0.5       &
+                    *((2.-fzm(k-1))*rv(i,k-1,jde-1)-fzp(k-1)*rv(i,k-2,jde-1)) &
+                                 *(w(i,k,jde-1)+w(i,k,jde-2))
+            ENDDO
+         END IF
+      END IF
+
+   ELSE IF ( horz_order == 0 ) THEN
+
+      ! Just in case we want to turn horizontal advection off, we can do it
+
+   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
+!     ADT eqn 46 has 3rd term on RHS (dividing through by my) = - partial d/dz (w rho w /my)
+!     Here we have:  - partial d/dz (w*rom) = - partial d/dz (w rho w / my)
+!     Therefore we don't need to make a correction for advect_w
+
+      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,    &
+                                h_tendency, z_tendency,        & 
+                                ru, rv, rom,                   &
+                                mut, mub, mu_old,              &
+                                time_step, config_flags,       &
+                                tenddec,                       & 
+                                msfux, msfuy, msfvx, msfvy,    &
+                                msftx, msfty,                  &
+                                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
+
+   LOGICAL ,                 INTENT(IN   ) :: tenddec  ! tendency flag
+
+   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 , kms:kme , jms:jme ) , INTENT(  OUT) :: h_tendency, z_tendency 
+
+   REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
+                                                                    msfuy,  &
+                                                                    msfvx,  &
+                                                                    msfvy,  &
+                                                                    msftx,  &
+                                                                    msfty
+
+   REAL , DIMENSION( kms:kme ) ,                 INTENT(IN   ) :: fzm,  &
+                                                                  fzp,  &
+                                                                  rdzw
+
+   REAL ,                                        INTENT(IN   ) :: rdx,  &
+                                                                  rdy,  &
+                                                                  dt
+   INTEGER ,                                     INTENT(IN   ) :: time_step
+
+   ! 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,time_step)*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,time_step)*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.5*(1.+sign(1.,cr))*q_im1 &
+!                                    +0.5*(1.-sign(1.,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 '
+
+    ! Empty arrays just in case:
+    IF (config_flags%polar) THEN
+       fqx(:,:,:)  = 0.
+       fqy(:,:,:)  = 0.
+       fqz(:,:,:)  = 0.
+       fqxl(:,:,:) = 0.
+       fqyl(:,:,:) = 0.
+       fqzl(:,:,:) = 0.
+    END IF
+
+  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+3)                ) degrade_xs = .false.
+   IF( config_flags%periodic_x   .or. &
+       config_flags%symmetric_xe .or. &
+       (ite < ide-4)                ) degrade_xe = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ys .or. &
+       (jts > jds+3)                ) degrade_ys = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ye .or. &
+       (jte < jde-4)                ) 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 = MAX(its-1,ids-1)
+!      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
+      IF(degrade_xs) i_start = MAX(its-1,ids)
+      IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
+
+      IF(degrade_ys) then
+        j_start = MAX(jts-1,jds+1)
+        j_start_f = jds+3
+      ENDIF
+
+      IF(degrade_ye) then
+        j_end = MIN(jte+1,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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+          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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+              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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+              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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+              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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+              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 = MAX(jts-1,jds+1)
+!      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
+      IF(degrade_ys) j_start = MAX(jts-1,jds)
+      IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
+
+      IF(degrade_xs) then
+        i_start = MAX(ids+1,its-1)
+        i_start_f = ids+3
+      ENDIF
+
+      IF(degrade_xe) then
+        i_end = MIN(ide-2,ite+1)
+        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./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+          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
+
+          DO i=i_start,i_start_f-1
+
+            IF(i == ids+1) THEN ! second order
+              DO k=kts,ktf
+                dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+                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
+
+            IF(i == ids+2) THEN  ! fourth order
+              DO k=kts,ktf
+                dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+                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
+
+        ENDIF
+
+        IF( degrade_xe ) THEN
+
+          DO i = i_end_f+1, i_end+1
+
+            IF( i == ide-1 ) THEN ! second order flux next to the boundary
+              DO k=kts,ktf
+                dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+                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
+
+
+            IF( i == ide-2 ) THEN ! fourth order flux one in from the boundary
+              DO k=kts,ktf
+                dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+                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
+
+        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+3)                ) degrade_xs = .false.
+   IF( config_flags%periodic_x   .or. &
+       config_flags%symmetric_xe .or. &
+       (ite < ide-4)                ) degrade_xe = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ys .or. &
+       (jts > jds+3)                ) degrade_ys = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ye .or. &
+       (jte < jde-4)                ) 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 = MAX(its-1,ids-1)
+!      IF(degrade_xe) i_end   = MIN(ite+1,ide-2)
+      IF(degrade_xs) i_start = MAX(its-1,ids)
+      IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
+
+      IF(degrade_ys) then
+        j_start = MAX(jts-1,jds+1)
+        j_start_f = jds+3
+      ENDIF
+
+      IF(degrade_ye) then
+        j_end = MIN(jte+1,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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+          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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+              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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+              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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+              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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+              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 = MAX(jts-1,jds+1)
+!      IF(degrade_ye) j_end   = MIN(jte+1,jde-2)
+      IF(degrade_ys) j_start = MAX(jts-1,jds)
+      IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
+
+      IF(degrade_xs) then
+        i_start = MAX(ids+1,its-1)
+        i_start_f = ids+3
+      ENDIF
+
+      IF(degrade_xe) then
+        i_end = MIN(ide-2,ite+1)
+        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./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+          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
+
+          DO i=i_start,i_start_f-1
+
+            IF(i == ids+1) THEN ! second order
+              DO k=kts,ktf
+                dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+                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
+
+            IF(i == ids+2) THEN  ! third order
+              DO k=kts,ktf
+                dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+                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
+
+        ENDIF
+
+        IF( degrade_xe ) THEN
+
+          DO i = i_end_f+1, i_end+1
+
+            IF( i == ide-1 ) THEN ! second order flux next to the boundary
+              DO k=kts,ktf
+                dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+                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
+
+
+            IF( i == ide-2 ) THEN ! third order flux one in from the boundary
+              DO k=kts,ktf
+                dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+                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
+
+        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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+          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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+              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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+              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./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+          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./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+              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./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+              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+2)                ) 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+2)                ) degrade_ys = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ye .or. &
+       (jte < jde-1)                ) 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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+          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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+              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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+              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./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+          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./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+              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./(msfty(i,j)+msfty(i-1,j))/rdx  ! ADT eqn 48 d/dx
+              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+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 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./(msftx(i,j)+msftx(i,j-1))/rdy  ! ADT eqn 48 d/dy
+           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./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx
+            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
+        ENDDO
+      ENDDO
+
+!--- end of 2nd 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
+
+   IF( (config_flags%polar) .and. (jts == jds) ) THEN
+
+       ! Assuming rv(i,k,jds) = 0.
+       DO i = i_start, i_end
+       DO k = kts, ktf
+         vb = MIN( 0.5*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)                &
+                                                                )
+       ENDDO
+       ENDDO
+
+   ENDIF
+
+   IF( (config_flags%polar) .and. (jte == jde)) THEN
+
+       ! Assuming rv(i,k,jde) = 0.
+       DO i = i_start, i_end
+       DO k = kts, ktf
+         vb = MAX( 0.5*rv(i,k,jte-1), 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-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 = MAX(its-1,ids)
+    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
+    IF(degrade_ys) j_start = MAX(jts-1,jds)
+    IF(degrade_ye) j_end   = MIN(jte+1,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 = MAX(its-1,ids)
+   IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
+   IF(degrade_ys) j_start = MAX(jts-1,jds)
+   IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
+
+   IF(config_flags%specified .or. config_flags%nested) THEN
+     IF (degrade_xs) i_start = MAX(its-1,ids+1)
+     IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
+     IF (degrade_ys) j_start = MAX(jts-1,jds+1)
+     IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
+   END IF
+
+   IF(config_flags%open_xs) THEN
+     IF (degrade_xs) i_start = MAX(its-1,ids+1)
+   END IF
+   IF(config_flags%open_xe) THEN
+     IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
+   END IF
+   IF(config_flags%open_ys) THEN
+     IF (degrade_ys) j_start = MAX(jts-1,jds+1)
+   END IF
+   IF(config_flags%open_ye) THEN
+     IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
+   END IF
+   ! ADT note:
+   ! We don't want to change j_start and j_end
+   ! for polar BC's since we want to calculate
+   ! fluxes for directions other than y at the
+   ! edge
+
+!-- 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*( msftx(i,j)*msfty(i,j)*(               &
+                       rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) +     &
+                       rdy*(fqyl(i,k,j+1)-fqyl(i,k,j))  )    &
+                      +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
+
+     flux_out = dt*( (msftx(i,j)*msfty(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  )) ) )  &
+                +msfty(i,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
+
+  IF(tenddec) THEN
+  DO j = j_start, j_end
+  DO k = kts, ktf
+  DO i = i_start, i_end
+
+     z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
+                                      +fqzl(i,k+1,j)-fqzl(i,k,j))
+
+  ENDDO
+  ENDDO
+  ENDDO
+  END IF
+
+! x flux divergence
+!
+  IF(degrade_xs) i_start = MAX(its,ids+1)
+  IF(degrade_xe) i_end   = MIN(ite,ide-2)
+
+  DO j = j_start, j_end
+  DO k = kts, ktf
+  DO i = i_start, i_end
+
+     ! Un-"canceled" map scale factor, ADT Eq. 48
+     tendency (i,k,j) = tendency(i,k,j)                           &
+               - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
+                                   +fqxl(i+1,k,j)-fqxl(i,k,j))   )
+
+  ENDDO
+  ENDDO
+  ENDDO
+
+  IF(tenddec) THEN
+  DO j = j_start, j_end
+  DO k = kts, ktf
+  DO i = i_start, i_end
+
+     h_tendency (i,k,j) = 0.                                      &
+               - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
+                                   +fqxl(i+1,k,j)-fqxl(i,k,j))   )
+
+  ENDDO
+  ENDDO
+  ENDDO
+  END IF
+
+! y flux divergence
+!
+  i_start = its
+  i_end   = MIN(ite,ide-1)
+  IF(degrade_ys) j_start = MAX(jts,jds+1)
+  IF(degrade_ye) j_end   = MIN(jte,jde-2)
+
+  DO j = j_start, j_end
+  DO k = kts, ktf
+  DO i = i_start, i_end
+
+     ! Un-"canceled" map scale factor, ADT Eq. 48
+     ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606
+     tendency (i,k,j) = tendency(i,k,j)                           &
+               - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
+                                   +fqyl(i,k,j+1)-fqyl(i,k,j))   )
+
+  ENDDO
+  ENDDO
+  ENDDO
+
+  IF(tenddec) THEN
+  DO j = j_start, j_end
+  DO k = kts, ktf
+  DO i = i_start, i_end
+
+     h_tendency (i,k,j) = h_tendency (i,k,j)                      &
+               - msftx(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 IF
+
+END SUBROUTINE advect_scalar_pd
+
+!----------------------------------------------------------------
+
+SUBROUTINE advect_scalar_mono   ( field, field_old, tendency,    &
+                                  h_tendency, z_tendency,        & 
+                                  ru, rv, rom,                   &
+                                  mut, mub, mu_old,              &
+                                  config_flags,                  &
+                                  tenddec,                       & 
+                                  msfux, msfuy, msfvx, msfvy,    &
+                                  msftx, msfty,                  &
+                                  fzm, fzp,                      &
+                                  rdx, rdy, rdzw, dt,            &
+                                  ids, ide, jds, jde, kds, kde,  &
+                                  ims, ime, jms, jme, kms, kme,  &
+                                  its, ite, jts, jte, kts, kte  )
+
+!  monotonic advection option
+!  for scalars in WRF RK3 advection.  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
+
+   IMPLICIT NONE
+   
+   ! Input data
+   
+   TYPE(grid_config_rec_type), INTENT(IN   ) :: config_flags
+
+   LOGICAL ,                 INTENT(IN   ) :: tenddec ! tendency flag
+
+   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 , kms:kme , jms:jme ) , INTENT(  OUT) :: h_tendency, z_tendency 
+
+   REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux,  &
+                                                                    msfuy,  &
+                                                                    msfvx,  &
+                                                                    msfvy,  &
+                                                                    msftx,  &
+                                                                    msfty
+
+   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
+   REAL , DIMENSION(its:ite, kts:kte) :: vflux
+
+
+!  storage for high and low order fluxes
+
+   REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: fqx, fqy, fqz
+   REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: fqxl, fqyl, fqzl
+   REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: qmin, qmax
+   REAL,  DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2  ) :: scale_in, scale_out
+   REAL :: ph_upwind
+
+   INTEGER :: horz_order, vert_order
+   
+   LOGICAL :: degrade_xs, degrade_ys
+   LOGICAL :: degrade_xe, degrade_ye
+
+   INTEGER :: jp1, jp0, jtmp
+
+   REAL :: flux_out, ph_low, flux_in, ph_hi, scale
+   REAL, PARAMETER :: eps=1.e-20
+
+
+! definition of flux operators, 3rd, 4rth, 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.
+      flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 &
+                                    +0.5*(1.-sign(1.,cr))*q_i
+
+    LOGICAL, PARAMETER :: mono_limit = .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
+
+  do j=jts-2,jte+2
+  do k=kts,kte
+  do i=its-2,ite+2
+    qmin(i,k,j) = field_old(i,k,j)
+    qmax(i,k,j) = field_old(i,k,j)
+    scale_in(i,k,j) = 1.
+    scale_out(i,k,j) = 1.
+    fqx(i,k,j) = 0.
+    fqy(i,k,j) = 0.
+    fqz(i,k,j) = 0.
+    fqxl(i,k,j) = 0.
+    fqyl(i,k,j) = 0.
+    fqzl(i,k,j) = 0.
+  enddo
+  enddo
+  enddo
+
+!  begin with horizontal flux divergence
+!  here is the choice of flux operators
+
+
+  horizontal_order_test : IF( horz_order == 5 ) THEN
+
+!  determine boundary mods for flux operators
+!  We degrade the flux operators from 3rd/4rth 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+3)                ) degrade_xs = .false.
+   IF( config_flags%periodic_x   .or. &
+       config_flags%symmetric_xe .or. &
+       (ite < ide-4)                ) degrade_xe = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ys .or. &
+       (jts > jds+3)                ) degrade_ys = .false.
+   IF( config_flags%periodic_y   .or. &
+       config_flags%symmetric_ye .or. &
+       (jte < jde-4)                ) 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
+
+!  WCS 20090218
+!      IF(degrade_xs) i_start = its
+!      IF(degrade_xe) i_end   = MIN(ite,ide-1)
+      IF(degrade_xs) i_start = MAX(its-1,ids)
+      IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
+
+!  WCS 20090218
+!      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
+
+      IF(degrade_ys) then
+        j_start = MAX(jts-1,jds+1)
+        j_start_f = jds+3
+      ENDIF
+
+      IF(degrade_ye) then
+        j_end = MIN(jte+1,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
+
+          vel = rv(i,k,j)
+          cr = vel
+          fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j  ), vel)
+
+          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)
+
+          if(cr.gt. 0) then
+             qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
+             qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
+          else
+             qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
+             qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
+          end if
+
+        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
+
+              vel = rv(i,k,j)
+              cr = vel
+              fqyl(i,k,j) = vel*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)
+
+          if(cr.gt. 0) then
+             qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
+             qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
+          else
+             qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
+             qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
+          end if
+
+            ENDDO
+            ENDDO
+
+      ELSE IF  ( j == jds+2 ) THEN  ! third of 4rth order flux 2 in from south boundary
+
+            DO k=kts,ktf
+            DO i = i_start, i_end
+
+              vel = rv(i,k,j)
+              cr = vel
+              fqyl(i,k,j) = vel*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)
+
+          if(cr.gt. 0) then
+             qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
+             qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
+          else
+             qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
+             qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
+          end if
+
+            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
+
+              vel = rv(i,k,j)
+              cr = vel
+              fqyl(i,k,j) = vel*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)
+
+          if(cr.gt. 0) then
+             qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
+             qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
+          else
+             qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
+             qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
+          end if
+
+            ENDDO
+            ENDDO
+
+      ELSE IF ( j == jde-2 ) THEN  ! 3rd or 4rth order flux 2 in from north boundary
+
+            DO k=kts,ktf
+            DO i = i_start, i_end
+
+              vel = rv(i,k,j)
+              cr = vel
+              fqyl(i,k,j) = vel*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)
+
+          if(cr.gt. 0) then
+             qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k,j-1))
+             qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k,j-1))
+          else
+             qmax(i,k,j-1)  = amax1(qmax(i,k,j-1),field_old(i,k,j))
+             qmin(i,k,j-1)  = amin1(qmin(i,k,j-1),field_old(i,k,j))
+          end if
+
+            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
+
+!  WCS 20090218
+!      IF(degrade_ys) j_start = jts
+!      IF(degrade_ye) j_end   = MIN(jte,jde-1)
+      IF(degrade_ys) j_start = MAX(jts-1,jds)
+      IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
+
+!  WCS 20090218
+!      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
+
+      IF(degrade_xs) then
+        i_start = MAX(ids+1,its-1)
+        i_start_f = ids+3
+      ENDIF
+
+      IF(degrade_xe) then
+        i_end = MIN(ide-2,ite+1)
+        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)
+          cr = vel
+          fqxl(i,k,j) = vel*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)
+
+          if(cr.gt. 0) then
+             qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
+             qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
+          else
+             qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
+             qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
+          end if
+
+        ENDDO
+        ENDDO
+
+!  lower order fluxes close to boundaries (if not periodic or symmetric)
+
+!  WCS 20090218 degrade_xs and xe recoded
+
+        IF( degrade_xs ) THEN
+
+          DO i=i_start,i_start_f-1
+
+            IF(i == ids+1) THEN ! second order
+              DO k=kts,ktf
+                vel = ru(i,k,j)
+                cr = vel
+                fqxl(i,k,j) = vel*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)
+
+                if(cr.gt. 0) then
+                  qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
+                  qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
+                else
+                  qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
+                  qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
+                end if
+              ENDDO
+            ENDIF
+
+            IF(i == ids+2) THEN  ! third order
+              DO k=kts,ktf
+                vel = ru(i,k,j)
+                cr = vel
+                fqxl(i,k,j) = vel*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)
+
+                if(cr.gt. 0) then
+                  qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
+                  qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
+                else
+                  qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
+                  qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
+                end if
+              ENDDO
+            ENDIF
+
+          ENDDO
+
+        ENDIF
+
+        IF( degrade_xe ) THEN
+
+          DO i = i_end_f+1, i_end+1
+
+            IF( i == ide-1 ) THEN ! second order flux next to the boundary
+              DO k=kts,ktf
+                vel = ru(i,k,j)
+                cr = vel
+                fqxl(i,k,j) = vel*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)
+
+                if(cr.gt. 0) then
+                  qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
+                  qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
+                else
+                  qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
+                  qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
+                end if
+              ENDDO
+            ENDIF
+
+            IF( i == ide-2 ) THEN ! third order flux one in from the boundary
+              DO k=kts,ktf
+                vel = ru(i,k,j)
+                cr = vel
+                fqxl(i,k,j) = vel*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)
+
+                if(cr.gt. 0) then
+                  qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i-1,k,j))
+                  qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i-1,k,j))
+                else
+                  qmax(i-1,k,j)  = amax1(qmax(i-1,k,j),field_old(i,k,j))
+                  qmin(i-1,k,j)  = amin1(qmin(i-1,k,j),field_old(i,k,j))
+                end if
+              ENDDO
+            ENDIF
+          ENDDO
+        ENDIF
+
+      ENDDO  ! enddo for outer J loop
+
+   ELSE
+
+      WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_mono, 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
+
+!  WCS 20090218
+!    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(degrade_xs) i_start = MAX(its-1,ids)
+    IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
+    IF(degrade_ys) j_start = MAX(jts-1,jds)
+    IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
+
+
+    vert_order_test : 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
+
+           vel = rom(i,k,j)
+           cr = -vel
+           fqzl(i,k,j) = vel*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)
+
+          if(cr.gt. 0) then
+             qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
+             qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
+          else
+             qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
+             qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
+          end if
+
+         ENDDO
+         ENDDO
+
+         DO i = i_start, i_end
+
+           k=kts+1
+           vel = rom(i,k,j)
+           cr = -vel
+           fqzl(i,k,j) = vel*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)
+
+          if(cr.gt. 0) then
+             qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
+             qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
+          else
+             qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
+             qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
+          end if
+
+           k=ktf
+           vel = rom(i,k,j)
+           cr = -vel
+           fqzl(i,k,j) = vel*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)
+
+          if(cr.gt. 0) then
+             qmax(i,k,j)  = amax1(qmax(i,k,j),field_old(i,k-1,j))
+             qmin(i,k,j)  = amin1(qmin(i,k,j),field_old(i,k-1,j))
+          else
+             qmax(i,k-1,j)  = amax1(qmax(i,k-1,j),field_old(i,k,j))
+             qmin(i,k-1,j)  = amin1(qmin(i,k-1,j),field_old(i,k,j))
+          end if
+         ENDDO
+
+      ENDDO
+
+   ELSE
+
+      WRITE (wrf_err_message,*) ' advect_scalar_mono, v_order not known ',vert_order
+      CALL wrf_error_fatal ( wrf_err_message )
+
+   ENDIF vert_order_test
+
+   IF (mono_limit) THEN
+
+! montonic filter
+
+   i_start = its-1
+   i_end   = MIN(ite,ide-1)+1
+   j_start = jts-1
+   j_end   = MIN(jte,jde-1)+1
+
+! WCS 20090218
+
+!-- 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
+
+   IF(degrade_xs) i_start = MAX(its-1,ids)
+   IF(degrade_xe) i_end   = MIN(ite+1,ide-1)
+   IF(degrade_ys) j_start = MAX(jts-1,jds)
+   IF(degrade_ye) j_end   = MIN(jte+1,jde-1)
+
+   IF(config_flags%specified .or. config_flags%nested) THEN
+     IF (degrade_xs) i_start = MAX(its-1,ids+1)
+     IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
+     IF (degrade_ys) j_start = MAX(jts-1,jds+1)
+     IF (degrade_ye) j_end   = MIN(jte+1,jde-2)
+   END IF
+
+   IF(config_flags%open_xs) THEN
+     IF (degrade_xs) i_start = MAX(its-1,ids+1)
+   END IF
+   IF(config_flags%open_xe) THEN
+     IF (degrade_xe) i_end   = MIN(ite+1,ide-2)
+   END IF
+   IF(config_flags%open_ys) THEN
+     IF (degrade_ys) j_start = MAX(jts-1,jds+1)
+   END IF
+   IF(config_flags%open_ye) THEN
+     IF (degrade_ye) j_end   = MIN(jte+1,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_upwind = (mub(i,j)+mu_old(i,j))*field_old(i,k,j)        &
+                   - dt*( msftx(i,j)*msfty(i,j)*(               &
+                          rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) +     &
+                          rdy*(fqyl(i,k,j+1)-fqyl(i,k,j))  )    &
+                         +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) )
+
+     flux_in = -dt*( (msftx(i,j)*msfty(i,j))*(                   &
+                               rdx*(  min(0.,fqx (i+1,k,j))      &
+                                     -max(0.,fqx (i  ,k,j)) )    &
+                              +rdy*(  min(0.,fqy (i,k,j+1))      &
+                                     -max(0.,fqy (i,k,j  )) ) )  &
+               +msfty(i,j)*rdzw(k)*(  max(0.,fqz (i,k+1,j))      &
+                                     -min(0.,fqz (i,k  ,j)) )   )
+
+     ph_hi = mut(i,j)*qmax(i,k,j) - ph_upwind
+     IF( flux_in .gt. ph_hi ) scale_in(i,k,j) = max(0.,ph_hi/(flux_in+eps))
+
+
+     flux_out = dt*( (msftx(i,j)*msfty(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  )) ) )  &
+                +msfty(i,j)*rdzw(k)*(  min(0.,fqz (i,k+1,j))      &
+                                      -max(0.,fqz (i,k  ,j)) )   )
+
+     ph_low = ph_upwind - mut(i,j)*qmin(i,k,j)
+     IF( flux_out .gt. ph_low ) scale_out(i,k,j) = max(0.,ph_low/(flux_out+eps))
+
+   ENDDO
+   ENDDO
+   ENDDO
+
+   DO j=j_start, j_end
+   DO k=kts, ktf
+   DO i=i_start, i_end+1
+       IF( fqx (i,k,j) .gt. 0.) then
+         fqx(i,k,j) = min(scale_in(i,k,j),scale_out(i-1,k,j))*fqx(i,k,j)
+       ELSE
+         fqx(i,k,j) = min(scale_out(i,k,j),scale_in(i-1,k,j))*fqx(i,k,j)
+       ENDIF
+   ENDDO
+   ENDDO
+   ENDDO
+
+   DO j=j_start, j_end+1
+   DO k=kts, ktf
+   DO i=i_start, i_end
+       IF( fqy (i,k,j) .gt. 0.) then
+         fqy(i,k,j) = min(scale_in(i,k,j),scale_out(i,k,j-1))*fqy(i,k,j)
+       ELSE
+         fqy(i,k,j) = min(scale_out(i,k,j),scale_in(i,k,j-1))*fqy(i,k,j)
+       ENDIF
+   ENDDO
+   ENDDO
+   ENDDO
+
+   DO j=j_start, j_end
+   DO k=kts+1, ktf
+   DO i=i_start, i_end
+       IF( fqz (i,k,j) .lt. 0.) then
+         fqz(i,k,j) = min(scale_in(i,k,j),scale_out(i,k-1,j))*fqz(i,k,j)
+       ELSE
+         fqz(i,k,j) = min(scale_out(i,k,j),scale_in(i,k-1,j))*fqz(i,k,j)
+       ENDIF
+   ENDDO
+   ENDDO
+   ENDDO
+
+   END IF
+
+! add in the mono-limited flux divergence
+! we need to fix this for open b.c set ***********
+
+  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
+
+  IF(tenddec) THEN
+  DO j = j_start, j_end
+  DO k = kts, ktf
+  DO i = i_start, i_end
+
+     z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j)  &
+                                      +fqzl(i,k+1,j)-fqzl(i,k,j))
+
+  ENDDO
+  ENDDO
+  ENDDO
+  END IF
+
+! x flux divergence
+!
+
+! WCS 20090218
+!  IF(degrade_xs) i_start = i_start + 1
+!  IF(degrade_xe) i_end   = i_end   - 1
+
+  IF(degrade_xs) i_start = MAX(its,ids+1)
+  IF(degrade_xe) i_end   = MIN(ite,ide-2)
+
+  DO j = j_start, j_end
+  DO k = kts, ktf
+  DO i = i_start, i_end
+
+     ! Un-"canceled" map scale factor, ADT Eq. 48
+     tendency (i,k,j) = tendency(i,k,j)                           &
+               - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
+                                   +fqxl(i+1,k,j)-fqxl(i,k,j))   )
+
+  ENDDO
+  ENDDO
+  ENDDO
+
+  IF(tenddec) THEN
+  DO j = j_start, j_end
+  DO k = kts, ktf
+  DO i = i_start, i_end
+
+     h_tendency (i,k,j) = 0.                                      &
+               - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j)     &
+                                   +fqxl(i+1,k,j)-fqxl(i,k,j))   )
+
+  ENDDO
+  ENDDO
+  ENDDO
+  END IF
+
+! y flux divergence
+!
+  i_start = its
+  i_end   = MIN(ite,ide-1)
+
+! WCS 20090218
+!  IF(degrade_ys) j_start = j_start + 1
+!  IF(degrade_ye) j_end   = j_end   - 1
+
+  IF(degrade_ys) j_start = MAX(jts,jds+1)
+  IF(degrade_ye) j_end   = MIN(jte,jde-2)
+
+  DO j = j_start, j_end
+  DO k = kts, ktf
+  DO i = i_start, i_end
+
+     ! Un-"canceled" map scale factor, ADT Eq. 48
+     tendency (i,k,j) = tendency(i,k,j)                           &
+               - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j)     &
+                                   +fqyl(i,k,j+1)-fqyl(i,k,j))   )
+
+  ENDDO
+  ENDDO
+  ENDDO
+
+  IF(tenddec) THEN
+  DO j = j_start, j_end
+  DO k = kts, ktf
+  DO i = i_start, i_end
+
+     h_tendency (i,k,j) = h_tendency (i,k,j)                      &
+               - msftx(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 IF
+
+END SUBROUTINE advect_scalar_mono
+
+!-----------------------------------------------------------
+
+END MODULE module_advect_em
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_avgflx_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_avgflx_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_avgflx_em.F	(revision 17)
@@ -0,0 +1,135 @@
+!WRF:MODEL_LAYER:DYNAMICS
+!
+MODULE module_avgflx_em
+
+  USE module_bc
+  USE module_model_constants
+  USE module_wrf_error
+
+CONTAINS
+
+!-------------------------------------------------------------------------------
+
+
+  subroutine zero_avgflx(avgflx_rum,avgflx_rvm,avgflx_wwm, &
+       & ids, ide, jds, jde, kds, kde,           &
+       & ims, ime, jms, jme, kms, kme,           &
+       & its, ite, jts, jte, kts, kte, do_cu,    &
+       & avgflx_cfu1,avgflx_cfd1,avgflx_dfu1,avgflx_efu1,avgflx_dfd1,avgflx_efd1 )
+
+    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) :: do_cu
+
+    REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) ::    &
+         avgflx_rum,avgflx_rvm,avgflx_wwm
+
+    REAL,     OPTIONAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) ::    &
+         avgflx_cfu1,avgflx_cfd1,avgflx_dfu1,avgflx_efu1,avgflx_dfd1,avgflx_efd1
+
+    INTEGER :: i,j,k
+
+    DO j=jts,jte
+       DO k=kts,kte
+          DO i=its,ite
+             avgflx_rum(i,k,j) = 0.
+             avgflx_rvm(i,k,j) = 0.
+             avgflx_wwm(i,k,j) = 0.
+          end DO
+       end DO
+    end DO
+
+    if (do_cu .and. &
+         & present(avgflx_cfu1) .and. present(avgflx_cfd1) .and. present(avgflx_dfu1) &
+         & .and. present(avgflx_efu1) .and. present(avgflx_dfd1) .and. present(avgflx_efd1) ) then
+       DO j=jts,jte
+          DO k=kts,kte
+             DO i=its,ite
+                avgflx_cfu1(i,k,j) = 0.
+                avgflx_cfd1(i,k,j) = 0.
+                avgflx_dfu1(i,k,j) = 0.
+                avgflx_efu1(i,k,j) = 0.
+                avgflx_dfd1(i,k,j) = 0.
+                avgflx_efd1(i,k,j) = 0.
+             end DO
+          end DO
+       end DO
+    end if
+
+    return
+  end subroutine zero_avgflx
+
+  subroutine upd_avgflx(avgflx_count,avgflx_rum,avgflx_rvm,avgflx_wwm, &
+       &   ru_m, rv_m, ww_m, &
+       & ids, ide, jds, jde, kds, kde,           &
+       & ims, ime, jms, jme, kms, kme,           &
+       & its, ite, jts, jte, kts, kte, do_cu,    &
+       & cfu1,cfd1,dfu1,efu1,dfd1,efd1,          &
+       & avgflx_cfu1,avgflx_cfd1,avgflx_dfu1,avgflx_efu1,avgflx_dfd1,avgflx_efd1 )
+
+    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)        :: avgflx_count
+    LOGICAL, INTENT(IN) :: do_cu
+    REAL, DIMENSION(ims:ime, kms:kme, jms:jme) , INTENT(IN) :: ru_m, &
+         rv_m, &
+         ww_m
+
+    REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) ::    &
+         avgflx_rum,avgflx_rvm,avgflx_wwm
+
+    REAL,     OPTIONAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN) ::    &
+         cfu1,cfd1,dfu1,efu1,dfd1,efd1
+    REAL,     OPTIONAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) ::    &
+         avgflx_cfu1,avgflx_cfd1,avgflx_dfu1,avgflx_efu1,avgflx_dfd1,avgflx_efd1
+
+    INTEGER :: i,j,k
+    REAL :: local_count
+
+    local_count = real(avgflx_count)
+    DO j=jts,jte
+       DO k=kts,kte
+          DO i=its,ite
+             avgflx_rum(i,k,j) = (local_count*avgflx_rum(i,k,j) + ru_m(i,k,j))/(local_count+1.)
+             avgflx_rvm(i,k,j) = (local_count*avgflx_rvm(i,k,j) + rv_m(i,k,j))/(local_count+1.)
+             avgflx_wwm(i,k,j) = (local_count*avgflx_wwm(i,k,j) + ww_m(i,k,j))/(local_count+1.)
+          end DO
+       end DO
+    end DO
+
+    if (do_cu .and. &
+         & present(avgflx_cfu1) .and. present(avgflx_cfd1) .and. present(avgflx_dfu1) &
+         & .and. present(avgflx_efu1) .and. present(avgflx_dfd1) .and. present(avgflx_efd1) &
+         & .and. present(cfu1) .and. present(cfd1) .and. present(dfu1) &
+         & .and. present(efu1) .and. present(dfd1) .and. present(efd1) ) then
+       DO j=jts,jte
+          DO k=kts,kte
+             DO i=its,ite
+                avgflx_cfu1(i,k,j) = (local_count*avgflx_cfu1(i,k,j) + &
+                     & cfu1(i,k,j)) / (local_count+1.)
+                avgflx_cfd1(i,k,j) = (local_count*avgflx_cfd1(i,k,j) + &
+                     & cfd1(i,k,j)) / (local_count+1.)
+                avgflx_dfu1(i,k,j) = (local_count*avgflx_dfu1(i,k,j) + &
+                     & dfu1(i,k,j)) / (local_count+1.)
+                avgflx_efu1(i,k,j) = (local_count*avgflx_efu1(i,k,j) + &
+                     & efu1(i,k,j)) / (local_count+1.)
+                avgflx_dfd1(i,k,j) = (local_count*avgflx_dfd1(i,k,j) + &
+                     & dfd1(i,k,j)) / (local_count+1.)
+                avgflx_efd1(i,k,j) = (local_count*avgflx_efd1(i,k,j) + &
+                     & efd1(i,k,j)) / (local_count+1.)
+             end DO
+          end DO
+       end DO
+    end if
+
+    return
+  end subroutine upd_avgflx
+end MODULE module_avgflx_em
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_bc_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_bc_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_bc_em.F	(revision 17)
@@ -0,0 +1,1239 @@
+!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
+#ifdef LMDZ1
+      INTEGER                                            :: im2,km2,jm2
+  
+      im2 = config_flags%i_check_point
+      jm2 = config_flags%j_check_point
+      km2 = config_flags%k_check_point
+
+      PRINT *,'  module_bc_em: inside' 
+      PRINT *,'    variable in: ',variable_in
+      PRINT *,'    save: ',ph_save(im2,km2,jm2), ' field: ', field(im2,1,jm2),       &
+        ' field_tend: ',field_tend(im2,1,jm2),' mu_tend: ',mu_tend(im2,jm2),         &
+        ' muts: ',muts(im2,jm2),' dt: ',dt,' spec_zone: ',spec_zone
+#endif
+
+      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 
+#ifdef LMDZ1
+      PRINT *,'  module_bc_em: after Y-start boundary' 
+      PRINT *,'    variable in: ',variable_in
+      PRINT *,'    save: ',ph_save(im2,km2,jm2), ' field: ', field(im2,1,jm2),       &
+        ' field_tend: ',field_tend(im2,1,jm2),' mu_tend: ',mu_tend(im2,jm2),         &
+        ' muts: ',muts(im2,jm2),' dt: ',dt,' spec_zone: ',spec_zone
+#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 
+#ifdef LMDZ1
+      PRINT *,'  module_bc_em: after Y-end boundary' 
+      PRINT *,'    variable in: ',variable_in
+      PRINT *,'    save: ',ph_save(im2,km2,jm2), ' field: ', field(im2,1,jm2),       &
+        ' field_tend: ',field_tend(im2,1,jm2),' mu_tend: ',mu_tend(im2,jm2),         &
+        ' muts: ',muts(im2,jm2),' dt: ',dt,' spec_zone: ',spec_zone
+#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 
+#ifdef LMDZ1
+      PRINT *,'  module_bc_em: after NOT periodic_x' 
+      PRINT *,'    variable in: ',variable_in
+      PRINT *,'    save: ',ph_save(im2,km2,jm2), ' field: ', field(im2,1,jm2),       &
+        ' field_tend: ',field_tend(im2,1,jm2),' mu_tend: ',mu_tend(im2,jm2),         &
+        ' muts: ',muts(im2,jm2),' dt: ',dt,' spec_zone: ',spec_zone
+#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
+#ifdef LMDZ1
+      PRINT *,'  module_bc_em: after X-end boundary' 
+      PRINT *,'    variable in: ',variable_in
+      PRINT *,'    save: ',ph_save(im2,km2,jm2), ' field: ', field(im2,1,jm2),       &
+        ' field_tend: ',field_tend(im2,1,jm2),' mu_tend: ',mu_tend(im2,jm2),         &
+        ' muts: ',muts(im2,jm2),' dt: ',dt,' spec_zone: ',spec_zone
+#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    ), 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    ), 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    ), INTENT(IN   ) :: mu_bxs,mu_bxe, &
+                                                                               mu_btxs,mu_btxe
+
+   REAL,  DIMENSION( ims:ime , 1:1     , spec_bdy_width    ), INTENT(IN   ) :: mu_bys,mu_bye, &
+                                                                               mu_btys,mu_btye
+   REAL, INTENT(IN   ) :: dtbc
+
+! changed to tile dimensions, 20090923, JM
+   REAL , DIMENSION( its-1:ite+1 , kts:kte, jts-1:jte+1  ) :: 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_tile ( 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,  &
+                               its-1, ite+1, jts-1,jte+1,kts,kte )  ! dims of first argument
+           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_tile ( 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,  &
+                               its-1, ite+1, jts-1,jte+1,kts,kte )  ! dims of first argument
+           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_tile ( 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,  &
+                               its-1, ite+1, jts-1,jte+1,kts,kte )  ! dims of first argument
+
+        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    ), INTENT(IN   ) :: scalar_bxs,scalar_bxe, &
+                                                                               scalar_btxs,scalar_btxe
+   REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width    ), 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    ), 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    ), 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    ), INTENT(IN   ) :: mu_bxs,mu_bxe, &
+                                                                               mu_btxs,mu_btxe
+
+   REAL,  DIMENSION( ims:ime , 1:1 ,     spec_bdy_width    ), 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    ), INTENT(IN   ) :: scalar_bxs,scalar_bxe, &
+                                                                               scalar_btxs,scalar_btxe
+
+   REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width    ), 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 zero_bdytend  (                                                  &
+                              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,                 &
+                              moist_btxs,moist_btxe,   &
+                              moist_btys,moist_btye,   &
+                              spec_bdy_width,n_moist,                          &
+                              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.
+
+   INTEGER ,               INTENT(IN   ) :: spec_bdy_width, n_moist
+
+   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( jms:jme , kds:kde , spec_bdy_width    ), INTENT(INOUT) :: 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    ), INTENT(INOUT) :: 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    ), INTENT(INOUT) :: mu_btxs,mu_btxe
+   REAL,  DIMENSION( ims:ime , 1:1     , spec_bdy_width    ), INTENT(INOUT) :: mu_btys,mu_btye
+
+   REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width , n_moist ), INTENT(INOUT) :: moist_btxs,moist_btxe
+   REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width , n_moist ), INTENT(INOUT) :: moist_btys,moist_btye
+
+! setting bdy tendencies to zero during DFI
+
+       CALL wrf_debug( 10, 'In zero_bdytend, setting bdy tendencies to 0 during DFI' )
+       u_btxs = 0.
+       u_btxe = 0.
+       u_btys = 0.
+       u_btye = 0.
+       v_btxs = 0.
+       v_btxe = 0.
+       v_btys = 0.
+       v_btye = 0.
+       t_btxs = 0.
+       t_btxe = 0.
+       t_btys = 0.
+       t_btye = 0.
+       ph_btxs = 0.
+       ph_btxe = 0.
+       ph_btys = 0.
+       ph_btye = 0.
+       mu_btxs = 0.
+       mu_btxe = 0.
+       mu_btys = 0.
+       mu_btye = 0.
+       moist_btxs = 0.
+       moist_btxe = 0.
+       moist_btys = 0.
+       moist_btye = 0.
+
+!  ENDIF
+
+   END SUBROUTINE zero_bdytend
+
+!---------------------------------------------------------------------
+
+  SUBROUTINE set_w_surface( config_flags, znw, fill_w_flag,              &
+                            w, ht, u, v, cf1, cf2, cf3, rdx, rdy,        &
+                            msftx, msfty,                                &
+                            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
+
+     REAL :: rdx, rdy, cf1, cf2, cf3
+
+     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,         &
+                                                                msftx,      &
+                                                                msfty
+     REAL , DIMENSION( kms:kme ) , INTENT(IN   ) ::  znw
+  
+     LOGICAL, INTENT(IN   ) :: fill_w_flag
+
+
+     INTEGER :: i,j,k
+     INTEGER :: ip1,im1,jp1,jm1
+     INTEGER :: ip1_limit,im1_limit,jp1_limit,jm1_limit
+
+!  set kinematic lower boundary condition on W
+
+!  Comments on directional map scale factors:
+!  Chain rule: if Z=Z(X,Y) [true at the surface] then
+!  dZ/dt = dZ/dX * dX/dt + dZ/dY * dY/dt, U=dX/dt, V=dY/dt
+!  using capitals to denote actual values
+!  in mapped values, u=U, v=V, z=Z, 1/dX=mx/dx, 1/dY=my/dy
+!     => w = dz/dt = mx u dz/dx + my v dz/dy
+!  [where dz/dx is just the surface height change between x
+!   gridpoints, and dz/dy is the change between y gridpoints]
+!  [NB - cf1, cf2 and cf3 do vertical weighting of u or v values
+!   nearest the surface]
+
+! get indices for points next to edge of domain 
+
+     jm1_limit = jds        ! No periodic BC's
+     jp1_limit = jde-1
+     im1_limit = ids
+     ip1_limit = ide-1
+
+     IF ( config_flags%periodic_x ) THEN
+       im1_limit = ids-1
+       ip1_limit = ide
+     ENDIF
+
+     IF ( config_flags%periodic_y ) THEN
+       jm1_limit = jds-1
+       jp1_limit = jde
+     ENDIF
+
+     DO j = jts,min(jte,jde-1)
+       jm1 = max(j-1, jm1_limit)
+       jp1 = min(j+1, jp1_limit)
+     DO i = its,min(ite,ide-1)
+       im1 = max(i-1, im1_limit)
+       ip1 = min(i+1, ip1_limit)
+
+         w(i,1,j)=  msfty(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  ))  ) &
+                    +msftx(i,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
+
+! Fill the atmospheric w field with smoothly decaying values
+      IF (fill_w_flag) THEN
+        DO j = jts,min(jte,jde-1)
+        DO k = kts+1,kte
+        DO i = its,min(ite,ide-1)
+          w(i,k,j) = w(i,1,j)*znw(k)*znw(k)
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDIF
+
+  END SUBROUTINE set_w_surface
+
+  SUBROUTINE lbc_fcx_gcx ( fcx , gcx , spec_bdy_width , &
+                           spec_zone , relax_zone , dt , spec_exp , &
+                           specified , nested )
+  
+     IMPLICIT NONE
+  
+     INTEGER , INTENT(IN) :: spec_bdy_width , spec_zone , relax_zone
+     REAL , INTENT(IN) :: dt , spec_exp
+     LOGICAL , INTENT(IN) :: specified , nested
+     REAL , DIMENSION(spec_bdy_width) :: fcx , gcx
+  
+     ! Local variables.
+  
+     INTEGER :: loop 
+     REAL :: spongeweight
+  
+     IF (specified) THEN
+       
+       ! Arrays for specified boundary conditions
+       
+       DO loop = spec_zone + 1, spec_zone + relax_zone
+         fcx(loop) = 0.1 / dt * (spec_zone + relax_zone - loop) / (relax_zone - 1)
+         gcx(loop) = 1.0 / dt / 50. * (spec_zone + relax_zone - loop) / (relax_zone - 1)
+         spongeweight=exp(-(loop-(spec_zone + 1))*spec_exp)
+         fcx(loop) = fcx(loop)*spongeweight
+         gcx(loop) = gcx(loop)*spongeweight
+       ENDDO   
+       
+     ELSE IF (nested) THEN
+       
+       ! Arrays for specified boundary conditions
+       
+       DO loop = spec_zone + 1, spec_zone + relax_zone
+         fcx(loop) = 0.1 / dt * (spec_zone + relax_zone - loop) / (relax_zone - 1)
+         gcx(loop) = 1.0 / dt / 50. * (spec_zone + relax_zone - loop) / (relax_zone - 1)
+!        spongeweight=EXP(-(loop-2)/3.)
+!        fcx(loop) = fcx(loop)*spongeweight
+!        gcx(loop) = gcx(loop)*spongeweight
+!        fcx(loop) = 0.
+!        gcx(loop) = 0.
+       ENDDO
+       
+     ENDIF
+  
+  END SUBROUTINE lbc_fcx_gcx
+  
+END MODULE module_bc_em
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_big_step_utilities_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_big_step_utilities_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_big_step_utilities_em.F	(revision 17)
@@ -0,0 +1,6229 @@
+!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, ONLY : domain
+   USE module_model_constants
+   USE module_state_description
+   USE module_configure, ONLY : grid_config_rec_type
+   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
+
+!<DESCRIPTION>
+!
+!  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)
+!
+!</DESCRIPTION>
+
+
+      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
+
+!<DESCRIPTION>
+!
+!  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)
+!
+!</DESCRIPTION>
+   
+      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
+
+!-------------------------------------------------------------------------------
+
+! Map scale factor comments for this routine:
+! Locally not changed, but sent the correct map scale factors
+! from module_em (msfuy, msfvx, msfty)
+
+SUBROUTINE couple_momentum ( muu, ru, u, msfu,              &
+                             muv, rv, v, msfv, msfv_inv,    &
+                             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, msfv_inv
+   
+   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) :: u, v, w
+   
+   ! Local data
+   
+   INTEGER :: i, j, k, itf, jtf, ktf
+   
+!<DESCRIPTION>
+!
+! couple_momentum couples the velocities to the full column mass and
+! the map factors.
+!
+!</DESCRIPTION>
+
+   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_inv(i,j)
+!           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
+
+!<DESCRIPTION>
+!
+! calc_mu_staggered calculates the full dry air mass at the staggered
+! velocity points (u,v).
+!
+!</DESCRIPTION>
+   
+      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
+
+!<DESCRIPTION>
+!
+! subroutine couple couples the input variable with the dry-air 
+! column mass (mu).  
+!
+!</DESCRIPTION>
+
+   
+   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_cp ( u, v, mup, mub, ww,              &
+                        rdx, rdy, msftx, msfty,          &
+                        msfux, msfuy, msfvx, msfvx_inv,  &
+                        msfvy, 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, &
+                                                            msftx, msfty, &
+                                                            msfux, msfuy, &
+                                                            msfvx, msfvy, &
+                                                            msfvx_inv
+   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
+
+!<DESCRIPTION>
+!
+!  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.
+!
+!</DESCRIPTION>
+
+!<DESCRIPTION>
+!
+!  calc_ww_cp calculates omega using the velocities (u,v) and the 
+!  column mass mu.
+!
+!</DESCRIPTION>
+
+    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)
+        ! u is always coupled with my
+        muu(i,j) = 0.5*(mup(i,j)+mub(i,j)+mup(i-1,j)+mub(i-1,j))/msfuy(i,j)
+      ENDDO
+      ENDDO
+
+      DO j=jts,min(jte+1,jde)
+      DO i=its,itf
+       ! v is always coupled with mx
+!        muv(i,j) = 0.5*(mup(i,j)+mub(i,j)+mup(i,j-1)+mub(i,j-1))/msfvx(i,j)
+        muv(i,j) = 0.5*(mup(i,j)+mub(i,j)+mup(i,j-1)+mub(i,j-1))*msfvx_inv(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
+
+!       Comments on the modifications for map scale factors
+!       ADT eqn 47 / my (putting rho -> 'mu') is:
+!       (1/my) partial d mu/dt = -mx partial d/dx(mu u/my) 
+!                                -mx partial d/dy(mu v/mx)
+!                                -partial d/dz(mu w/my)
+!
+!       Using nu instead of z the last term becomes:
+!                                -partial d/dnu(mu (dnu/dt)/my)
+!
+!       Integrating with respect to nu over ALL levels, with dnu/dt=0 at top
+!       and bottom, the last term becomes = 0
+!
+!       Integral|bot->top[(1/my) partial d mu/dt]dnu = 
+!       Integral|bot->top[-mx partial d/dx(mu u/my) 
+!                         -mx partial d/dy(mu v/mx)]dnu
+!
+!       muu='mu'[on u]/my, muv='mu'[on v]/mx
+!       (1/my) partial d mu/dt is independent of nu
+!         => LHS = Integral|bot->top[con]dnu = conservation*(-1) = -dmdt
+!
+!         => dmdt = mx*Integral|bot->top[partial d/dx(mu u/my) +
+!                                        partial d/dy(mu v/mx)]dnu
+!         => dmdt = sum_bot->top[divv]
+!       where
+!         divv=mx*[partial d/dx(mu u/my) + partial d/dy(mu v/mx)]*delta nu
+
+        DO k=kts,ktf
+        DO i=its,itf
+
+          divv(i,k) = msftx(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
+
+!       Further map scale factor notes:
+!       Now integrate from bottom to top, level by level:
+!       mu dnu/dt/my [k+1] = mu dnu/dt/my [k] + [-(1/my) partial d mu/dt 
+!                           -mx partial d/dx(mu u/my)
+!                           -mx partial d/dy(mu v/mx)]*dnu[k->k+1]
+!       ww [k+1] = ww [k] -(1/my) partial d mu/dt * dnu[k->k+1] - divv[k]
+!                = ww [k] -dmdt * dnw[k] - divv[k]
+
+        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
+
+!<DESCRIPTION>
+!
+!  calc_cq calculates moist coefficients for the momentum equations.
+!
+!</DESCRIPTION>
+
+      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
+
+!<DESCRIPTION>
+!
+! calc_alt computes the full inverse density
+!
+!</DESCRIPTION>
+
+      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
+
+
+!<DESCRIPTION>
+!
+! 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.
+!
+!</DESCRIPTION>
+#ifdef LMDZ1
+   INTEGER                                               :: ix,im2,km2,jm2
+  
+   im2=24
+   jm2=21
+   km2=38
+
+   PRINT *,'  calc_p_rho_phi inside: ',im2,km2,jm2
+   PRINT *,'    al: ',al(im2,km2,jm2), ' p: ', p(im2,km2,jm2),                 &
+     ' ph: ',ph(im2,km2,jm2), ' mu: ', mu(im2,jm2), ' muts: ', muts(im2,jm2),  &
+     ' t: ',t(im2,km2,jm2), ' p0: ',p0, ' t0: ', t0, 'znu: ',znu(km2),         &
+     ' dnw: ',dnw(km2), ' rdnw: ',rdnw(km2), ' rdn: ', rdn(km2), ' moist: ',   &
+     moist(im2,km2,jm2,:)
+#endif
+
+  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)))
+#ifdef LMDZ1
+        IF (i == im2 .AND. k==km2 .AND. j==jm2) THEN
+        PRINT *,'  calc_p_rho_phi after non_hydrostatic: ',im2,km2,jm2
+        PRINT *,'    al: ',al(im2,km2,jm2), ' p: ', p(im2,km2,jm2),                 &
+          ' ph: ',ph(im2,km2,jm2), ' mu: ', mu(im2,jm2), ' muts: ', muts(im2,jm2),  &
+          ' t: ',t(im2,km2,jm2), ' p0: ',p0, ' t0: ', t0, 'znu: ',znu(km2),         &
+          ' dnw: ',dnw(km2), ' rdnw: ',rdnw(km2), ' rdn: ', rdn(km2), ' qvf: ',     &
+          moist(im2,km2,jm2,p_qv)
+        END IF
+#endif
+        ENDDO
+#ifdef LMDZ1
+        IF (k==km2 .AND. j==jm2) THEN
+          PRINT *,'  calc_p_rho_phi before VPOW: ',im2,km2,jm2
+          PRINT *,'     p sfc: ', p(its,km2,jm2), ' temp: ',temp(its), ' cpovcv_v: ',&
+            cpovcv_v(its),' p: ', p(im2,km2,jm2)
+        END IF
+#endif
+#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
+! L. Fita, LMD April 2014. On the writting of a wrfout, this gives a NaN value at a 
+!   certain vertical level not at the its !!!!
+        CALL VPOW  ( p(its,k,j), temp(its), cpovcv_v(its), itf-its+1 )
+!        DO ix=its,itf-its+1
+!          p(ix,k,j) = temp(ix)**cpovcv_v(ix)
+!          IF (k==km2 .AND. j==jm2) PRINT *,ix, ': ',  p(ix,k,j), temp(ix), cpovcv_v(ix)
+!        END DO
+#endif
+#ifdef LMDZ1
+        IF (k==km2 .AND. j==jm2) THEN
+          PRINT *,'  calc_p_rho_phi after VPOW: ',im2,km2,jm2
+          PRINT *,'     p sfc: ', p(its,km2,jm2), ' temp: ',temp(its), ' cpovcv_v: ',   &
+            cpovcv_v(its), ' pow: ',itf-its+1,' p: ', p(im2,km2,jm2)
+          PRINT *,'  calc_p_rho_phi before p_compute: ',im2,km2,jm2
+          PRINT *,'     p: ', p(im2,km2,jm2), ' p0: ',p0, ' pb: ', pb(im2,km2,jm2)
+        END IF
+#endif
+        DO i=its,itf
+           p(i,k,j)= p(i,k,j)*p0-pb(i,k,j)
+#ifdef LMDZ1
+        IF (i == im2 .AND. k==km2 .AND. j==jm2) THEN
+        PRINT *,'  calc_p_rho_phi after p_compute: ',im2,km2,jm2
+        PRINT *,'     p: ', p(im2,km2,jm2), ' p0: ',p0, ' pb: ', pb(im2,km2,jm2)
+        END IF
+#endif
+        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)
+#ifdef LMDZ1
+        IF (i == im2 .AND. k==km2 .AND. j==jm2) THEN
+        PRINT *,'  calc_p_rho_phi after al_p_compute 2: ',im2,km2,jm2
+        PRINT *,'     p: ', p(im2,km2,jm2), ' al: ',al(im2,km2,jm2)
+        END IF
+#endif
+        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.
+            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.
+            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.
+            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)
+
+#ifdef LMDZ1
+        IF (i == im2 .AND. j==jm2) THEN
+        PRINT *,'  calc_p_rho_phi after top_layer: ',im2,jm2
+        PRINT *,'     p: ', p(im2,k,jm2), ' al: ',al(im2,k,jm2)
+        END IF
+#endif
+          ENDDO
+
+          DO k=ktf-1,kts,-1  ! remaining layers, integrate down
+            DO i=its,itf
+
+            qtot = 0.
+            qf2 = 1.
+            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)
+#ifdef LMDZ1
+        IF (i == im2 .AND. k==km2 .AND. j==jm2) THEN
+        PRINT *,'  calc_p_rho_phi after other_layers: ',im2,km2,jm2
+        PRINT *,'     p: ', p(im2,km2,jm2), ' al: ',al(im2,km2,jm2)
+        END IF
+#endif
+            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
+
+!<DESCRIPTION>
+!
+!  calc_php calculates the full geopotential from the reference state
+!  geopotential and the perturbation geopotential (phb_ph).
+!
+!</DESCRIPTION>
+
+      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,             &
+                       msftx, msfty,                        &
+                       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, msftx, msfty
+
+   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)
+
+!<DESCRIPTION>
+!
+! diagnose_w diagnoses the vertical velocity from the geopoential equation.
+! Used with the hydrostatic option.
+!
+!</DESCRIPTION>
+
+   DO j = jts, jtf
+
+!  lower b.c. on w
+
+!  Notes on map scale factors:
+!  Chain rule: if Z=Z(X,Y) [true at the surface] then
+!  dZ/dt = dZ/dX * dX/dt + dZ/dY * dY/dt, U=dX/dt, V=dY/dt
+!  Using capitals to denote actual values
+!  In mapped values, u=U, v=V, z=Z, 1/dX=mx/dx, 1/dY=my/dy
+!    => w = dz/dt = mx u dz/dx + my v dz/dy
+!  [where dz/dx is just the surface height change between x
+!   gridpoints, and dz/dy is the change between y gridpoints]
+!  [NB: cf1, cf2 and cf3 do vertical weighting of u or v values
+!   nearest the surface]
+
+!  Previously msft multiplied by rdy and rdx terms.
+!  Now msfty multiplies rdy term, and msftx multiplies msftx term
+     DO i = its, itf
+         w(i,1,j)=  msfty(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  ))  ) &
+                 +msftx(i,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
+
+!  Further notes on map scale factors
+!  If ph_tend contains:  -mx partial d/dx(mu rho u/my) 
+!                        -mx partial d/dy(phi mu v/mx)
+!                        -partial d/dz(phi mu w/my)
+!  then phi eqn is: partial d/dt(mu phi/my) = ph_tend + mu g w/my
+!    => w = [my/(mu*g)]*[partial d/dt(mu phi/my) - ph_tend]
+
+     DO k = 2, kte
+     DO i = its, itf
+       w(i,k,j) =  msfty(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,       &
+                   msfux, msfuy, msfvx,             &
+                   msfvx_inv, msfvy,                &
+                   msftx, msfty,                    &
+                   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
+
+   REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) :: ph_tend
+
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   ) :: muu, muv, mut,   &
+                                                            msfux, msfuy, &
+                                                            msfvx, msfvy, &
+                                                            msftx, msfty, &
+                                                            msfvx_inv
+
+   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
+
+!<DESCRIPTION>
+!
+! 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.
+!
+!</DESCRIPTION>
+
+   specified = .false.
+   if(config_flags%specified .or. config_flags%nested) specified = .true.
+
+   advective_order = config_flags%h_sca_adv_order 
+
+   itf=MIN(ite,ide-1)
+   jtf=MIN(jte,jde-1)
+   ktf=MIN(kte,kde-1)
+
+!  Notes on map scale factors (WCS, 2 march 2008)
+!  phi equation is:   mu/my d/dt(phi) = -(1/my) mx mu u  d/dx(phi)
+!                                       -(1/my) my mu v d/dy(phi)
+!                                       - omega d/d_eta(phi)
+!                                               +mu g w/my
+!
+!  A little further explanation...
+!  The tendency term we are computing here is for mu/my d/dt(phi).  It is advective form 
+!  but it is multiplied be mu/my.  It will be decoupled from (mu/my) when the implicit w-phi
+!  solution is computed in subourine advance_w.  The formulation dates from the early 
+!  days of the mass coordinate model when we were testing both a flux and an advective formulation
+!  for the geopotential equation and different forms of the vertical momentum equation and the 
+!  vertically implicit solver.
+
+! 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
+
+!  RHS term 3 is: - omega partial d/dnu(phi)
+
+     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
+        ! phi equation RHS term 4
+        ph_tend(i,k,j) = ph_tend(i,k,j) + mut(i,j)*g*w(i,k,j)/msfty(i,j)
+     ENDDO
+     ENDDO
+
+   ENDDO
+
+   END IF
+
+!  Notes on map scale factors:
+!  RHS terms 1 and 2 are: -(1/my) mx u mu partial d/dx(phi)
+!                         -(1/my) my v mu partial d/dy(phi)
+
+   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 .or. specified) .and. jts == jds ) j_start = jts+1
+   IF ( (config_flags%open_ye .or. specified) .and. jte == jde ) jtf = jtf-2
+
+   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) - (0.25*rdy/msfty(i,j))*          &
+                 ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,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  ))*msfvy(i,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) - (0.5*rdy/msfty(i,j))*                        &
+                  ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,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  ))*msfvy(i,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 .or. specified) .and. its == ids ) i_start = its+1
+   IF ( (config_flags%open_xe .or. specified) .and. ite == ide ) itf = itf-2
+
+   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) - (0.25*rdx/msfty(i,j))*         &
+                 ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+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))*msfux(i  ,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) - (0.5*rdx/msfty(i,j))*                        &
+                  ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,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))*msfux(  i,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 .or. specified) .and. jts == jds ) j_start = jts+2
+   IF ( (config_flags%open_ye .or. specified) .and. jte == jde ) jtf = jtf-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) - (0.25*rdy/msfty(i,j))*(                     &
+                 ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)                &
+                  +muv(i,j  )*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,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) - (0.5*rdy/msfty(i,j))*(                                 &
+                 ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)                &
+                  +muv(i,j  )*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,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
+
+!  pick up near boundary rows using 2nd order stencil for open and specified conditions
+
+   IF ( (config_flags%open_ys .or. specified) .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) - (0.25*rdy/msfty(i,j))*          &
+                 ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,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  ))*msfvy(i,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) - (0.5*rdy/msfty(i,j))*                        &
+                  ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,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  ))*msfvy(i,j  )*    &
+                   (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
+     ENDDO
+
+   END IF
+
+   IF ( (config_flags%open_ye .or. specified) .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) - (0.25*rdy/msfty(i,j))*          &
+                 ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,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  ))*msfvy(i,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) - (0.5*rdy/msfty(i,j))*                        &
+                  ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,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  ))*msfvy(i,j  )*    &
+                   (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
+     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) .and. its == ids ) i_start = its+2
+   IF ( (config_flags%open_xe) .and. ite == ide ) itf = itf-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) - (0.25*rdx/msfty(i,j))*(                    &
+                 ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)               &
+                  +muu(i,j  )*(u(i  ,k,j)+u(i  ,k-1,j))*msfux(i  ,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) - (0.5*rdx/msfty(i,j))*(                                 &
+                 ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)                &
+                  +muu(i,j  )*(cfn*u(i  ,k-1,j)+cfn1*u(i  ,k-2,j))*msfux(i  ,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
+
+!  pick up near boundary rows using 2nd order stencil for open and specified conditions
+
+   IF ( (config_flags%open_xs .or. specified) .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) - (0.25*rdx/msfty(i,j))*         &
+                 ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+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))*msfux(i  ,j)*  &
+                  (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
+     ENDDO
+     ENDDO
+ 
+     k = kte
+     DO j = j_start, jtf
+        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                        &
+                  ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,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))*msfux(  i,j)*    &
+                   (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
+     ENDDO
+
+   END IF
+
+   IF ( (config_flags%open_xe .or. specified) .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) - (0.25*rdx/msfty(i,j))*         &
+                 ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+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))*msfux(i  ,j)*  &
+                  (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
+     ENDDO
+     ENDDO
+ 
+     k = kte
+     DO j = j_start, jtf
+        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                        &
+                  ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,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))*msfux(  i,j)*    &
+                   (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
+     ENDDO
+
+   END IF
+
+!--------------------------
+
+   ELSE IF (advective_order <= 6) THEN
+
+!!! NOTE: this branch has been looked at and fixed with changes for overdecomposition
+!!!       the branches covering the other advective_order cases have not.  20090923. JM
+
+!  y (v) advection
+
+   i_start = its
+   j_start = jts
+   itf=MIN(ite,ide-1)
+   jtf=MIN(jte,jde-1)
+
+   IF (config_flags%open_ys .or. specified ) j_start = max(jts,jds+3)
+   IF (config_flags%open_ye .or. specified ) jtf     = min(jtf,jde-4)
+
+   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) - (0.25*rdy/msfty(i,j))* (                    &
+                 ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)                &
+                  +muv(i,j  )*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,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) - (0.5*rdy/msfty(i,j))* (                                &
+                 ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)                &
+                  +muv(i,j  )*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,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
+
+!  4th order stencil for open or specified conditions two in form the boundary
+
+   IF ( (config_flags%open_ys .or. specified) .and. jts <= jds+2 .and. jds+2 <= jte )  THEN
+
+     j = jds+2
+     DO k = 2, kte-1
+     DO i = i_start, itf
+        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* (                     &
+                 ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)                &
+                  +muv(i,j  )*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,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) - (0.5*rdy/msfty(i,j))* (                              &
+                 ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)              &
+                  +muv(i,j  )*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,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 .or. specified) .and. jts <= jde-3 .and. jde-3 <= jte )  THEN
+     j = jde-3
+     DO k = 2, kte-1
+     DO i = i_start, itf
+        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* (                  &
+                 ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)              &
+                  +muv(i,j  )*(v(i,k,j  )+v(i,k-1,j  ))*msfvy(i,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) - (0.5*rdy/msfty(i,j))* (                              &
+                 ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)              &
+                  +muv(i,j  )*(cfn*v(i,k-1,j  )+cfn1*v(i,k-2,j  ))*msfvy(i,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
+
+!  2nd order stencil for open and specified conditions one row in from boundary
+
+   IF ( (config_flags%open_ys .or. specified) .and. jts <= jds+1 .and. jds+1 <= jte )  THEN
+
+     j = jds+1
+     DO k = 2, kte-1
+     DO i = i_start, itf
+        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*          &
+                 ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,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  ))*msfvy(i,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) - (0.5*rdy/msfty(i,j))*                        &
+                  ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,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  ))*msfvy(i,j  )*    &
+                   (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
+     ENDDO
+
+   END IF
+
+   IF ( (config_flags%open_ye .or. specified) .and. jts <= jde-2 .and. jde-2 <= jte )  THEN
+
+     j = jde-2
+     DO k = 2, kte-1
+     DO i = i_start, itf
+        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*          &
+                 ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,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  ))*msfvy(i,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) - (0.5*rdy/msfty(i,j))*                        &
+                  ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,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  ))*msfvy(i,j  )*    &
+                   (phb(i,k,j  )-phb(i,k,j-1)+ph(i,k,j  )-ph(i,k,j-1))              )
+     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+3)
+   IF (config_flags%open_xe .or. specified ) itf     = min(itf,ide-4)
+
+   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) - (0.25*rdx/msfty(i,j))*(                   &
+                 ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)              &
+                  +muu(i,j  )*(u(i,k,j  )+u(i,k-1,j  ))*msfux(i,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) - (0.5*rdx/msfty(i,j))*(                             &
+                 ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)            &
+                  +muu(i,j  )*(cfn*u(i  ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,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
+
+!  4th order stencil two in from the boundary for open and specified conditions
+
+   IF ( (config_flags%open_xs) .and. its <= ids+2 .and. ids+2 <= ite ) THEN
+     i = ids + 2
+     DO j = j_start, jtf
+       DO k = 2, kte-1
+        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*(                   &
+                 ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)              &
+                  +muu(i,j  )*(u(i,k,j  )+u(i,k-1,j  ))*msfux(i,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) - (0.5*rdx/msfty(i,j))*(                             &
+                ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)            &
+                 +muu(i,j  )*(cfn*u(i  ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,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. its <= ide-3 .and. ide-3 <= ite ) THEN
+     i = ide-3
+     DO j = j_start, jtf
+       DO k = 2, kte-1
+        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*(                   &
+                 ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)              &
+                  +muu(i,j  )*(u(i,k,j  )+u(i,k-1,j  ))*msfux(i,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) - (0.5*rdx/msfty(i,j))*(                             &
+                ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)            &
+                 +muu(i,j  )*(cfn*u(i  ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,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
+
+!  2nd order stencil for open and specified conditions one in from the boundary
+
+   IF ( (config_flags%open_xs .or. specified) .and. its <= ids+1 .and. ids+1 <= ite ) THEN
+
+     i = ids + 1
+
+     DO j = j_start, jtf
+     DO k = 2, kte-1
+        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*         &
+                 ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+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))*msfux(i  ,j)*  &
+                  (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
+     ENDDO
+     ENDDO
+ 
+     k = kte
+     DO j = j_start, jtf
+        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                        &
+                  ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,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))*msfux(  i,j)*    &
+                   (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
+     ENDDO
+
+   END IF
+
+   IF ( (config_flags%open_xe .or. specified) .and. its <= ide-2 .and. ide-2 <= ite ) THEN
+
+     i = ide-2
+     DO j = j_start, jtf
+     DO k = 2, kte-1
+        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*         &
+                 ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+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))*msfux(i  ,j)*  &
+                  (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))  )
+     ENDDO
+     ENDDO
+ 
+     k = kte
+     DO j = j_start, jtf
+        ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*                        &
+                  ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,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))*msfux(  i,j)*    &
+                   (phb(i  ,k,j)-phb(i-1,k,j)+ph(i  ,k,j)-ph(i-1,k,j))             )
+     ENDDO
+
+   END IF
+
+   END IF  ! 6th order advection
+
+!  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)-(msftx(i,j)/msfty(i,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)-(msftx(i,j)/msfty(i,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)-(msftx(i,j)/msfty(i,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)-(msftx(i,j)/msfty(i,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,msfux,msfuy,&
+                                         msfvx,msfvy,msftx,msfty,        &
+                                         config_flags, non_hydrostatic,  &
+                                         top_lid,                        &
+                                         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, top_lid
+
+   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,    &
+                                                            msfux, msfuy, &
+                                                            msfvx, msfvy, &
+                                                            msftx, msfty
+
+   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
+
+!<DESCRIPTION>
+!
+!  horizontal_pressure_gradient calculates the 
+!  horizontal pressure gradient terms for the large-timestep tendency 
+!  in the horizontal momentum equations (u,v).
+!
+!</DESCRIPTION>
+
+   specified = .false.
+   if(config_flags%specified .or. config_flags%nested) specified = .true.
+
+!  Notes on map scale factors:
+!  Calculates the pressure gradient terms in ADT eqns 44 and 45
+!  With upper rho -> 'mu', these are:
+!  Eqn 30: -mu*(mx/my)*(1/rho)*partial dp/dx
+!  Eqn 31: -mu*(my/mx)*(1/rho)*partial dp/dy
+!
+!  As we are on nu, rather than height, surfaces:
+!
+!  mu dp/dx = mu alpha partial dp'/dx + (nu mu partial dmubar/dx) alpha'
+!           + mu partial dphi'/dx + (partial dphi/dx)*(partial dp'/dnu - mu')
+!
+!  mu dp/dy = mu alpha partial dp'/dy + (nu mu partial dmubar/dy) alpha'
+!           + mu partial dphi'/dy + (partial dphi/dy)*(partial dp'/dnu - mu')
+
+! 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 .or. config_flags%polar ) .and. jts == jds ) j_start = jts+1
+   IF ( (config_flags%open_ye .or. specified .or. &
+         config_flags%nested .or. config_flags%polar ) .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
+        IF (top_lid) THEN
+          DO i = i_start, itf
+            dpn(i,kde) = .5*( cf1*(p(i,kde-1,j-1)+p(i,kde-1,j))   &
+                             +cf2*(p(i,kde-2,j-1)+p(i,kde-2,j))   &
+                             +cf3*(p(i,kde-3,j-1)+p(i,kde-3,j))  )
+          ENDDO
+        ENDIF
+               
+        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
+
+!       ADT eqn 45: -mu*(my/mx)*(1/rho)*partial dp/dy
+!       [alt, al are 1/rho terms; muv, mu are NOT coupled]
+        DO K=1,ktf
+          DO i = i_start, itf
+            ! Here are mu dp/dy terms 1-3 
+            dpy = (msfvy(i,j)/msfvx(i,j))*.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)) )
+            ! Here is mu dp/dy term 4 
+            dpy = dpy + (msfvy(i,j)/msfvx(i,j))*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
+
+!       ADT eqn 45: -mu*(my/mx)*(1/rho)*partial dp/dy
+!       [alt, al are 1/rho terms; muv, mu are NOT coupled]
+        DO K=1,ktf
+          DO i = i_start, itf
+            ! Here are mu dp/dy terms 1-3; term 4 not needed if hydrostatic
+            dpy = (msfvy(i,j)/msfvx(i,j))*.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
+        IF (top_lid) THEN
+          DO i = i_start, itf
+            dpn(i,kde) = .5*( cf1*(p(i-1,kde-1,j)+p(i,kde-1,j))   &
+                             +cf2*(p(i-1,kde-2,j)+p(i,kde-2,j))   &
+                             +cf3*(p(i-1,kde-3,j)+p(i,kde-3,j))  )
+          ENDDO
+        ENDIF
+               
+        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
+
+! ADT eqn 44: -mu*(mx/my)*(1/rho)*partial dp/dx
+! [alt, al are 1/rho terms; muu, mu are NOT coupled]
+        DO K=1,ktf
+          DO i = i_start, itf
+            ! Here are mu dp/dy terms 1-3
+            dpx = (msfux(i,j)/msfuy(i,j))*.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)) )
+            ! Here is mu dp/dy term 4
+            dpx = dpx + (msfux(i,j)/msfuy(i,j))*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
+
+!       ADT eqn 44: -mu*(mx/my)*(1/rho)*partial dp/dx
+!       [alt, al are 1/rho terms; muu, mu are NOT coupled]
+        DO K=1,ktf
+          DO i = i_start, itf
+            ! Here are mu dp/dy terms 1-3; term 4 not needed if hydrostatic
+            dpx = (msfux(i,j)/msfuy(i,j))*.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, msftx, msfty,     &
+                      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, msftx, msfty
+
+   REAL, DIMENSION( kms:kme ), INTENT(IN   ) :: rdnw, rdn
+
+   REAL,  INTENT(IN   ) :: g
+
+   INTEGER :: itf, jtf, i, j, k
+   REAL    :: cq1, cq2
+
+
+!<DESCRIPTION>
+!
+!  pg_buoy_w calculates the 
+!  vertical pressure gradient and buoyancy terms for the large-timestep 
+!  tendency in the vertical momentum equation.
+!
+!</DESCRIPTION>
+
+!  BUOYANCY AND PRESSURE GRADIENT TERM IN W EQUATION AT TIME T
+
+!  Map scale factor notes
+!  ADT eqn 46 RHS terms 6 and 7 (where 7 is "-rho g")
+!  Dividing by my, and using mu and nu (see Klemp et al. eqns 32, 40)
+!  term 6: +(g/my) partial dp'/dnu
+!  term 7: -(g/my) mu'
+!
+!  For moisture-free atmosphere, cq1=1, cq2=0
+!  => (1./msft(i,j)) * g * [rdn(k)*{p(i,k,j)-p(i,k-1,j)}-mu(i,j)]
+
+   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./msfty(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./msfty(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, max_vert_cfl,max_horiz_cfl, &
+                      u, v, ww, w, mut, rdnw,         &
+                      rdx, rdy, msfux, msfuy,         &
+                      msfvx, msfvy, dt,               &
+                      config_flags,                   &
+                      ids, ide, jds, jde, kds, kde,   &
+                      ims, ime, jms, jme, kms, kme,   &
+                      its, ite, jts, jte, kts, kte   )
+
+   USE module_llxy
+   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, v, ww, w
+
+   REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) ::  rw_tend
+
+   REAL, INTENT(OUT) ::  max_vert_cfl
+   REAL, INTENT(OUT) ::  max_horiz_cfl
+   REAL              ::  horiz_cfl
+
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   ) :: mut
+
+   REAL, DIMENSION( kms:kme ), INTENT(IN   ) :: rdnw
+
+   REAL, INTENT(IN)    :: dt
+   REAL, INTENT(IN)    :: rdx, rdy
+   REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfux, msfuy
+   REAL , DIMENSION( ims:ime , jms:jme ) ,         INTENT(IN   ) :: msfvx, msfvy
+
+   REAL                :: vert_cfl, cf_n, cf_d, 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
+
+   integer :: total
+   REAL :: msfuxt , msfxffl
+   
+!<DESCRIPTION>
+!
+!  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).
+!
+!  Additionally, w_damp returns the maximum cfl values due to vertical motion and
+!  horizontal motion.  These values are returned via the max_vert_cfl and 
+!  max_horiz_cfl variables.  (Added by T. Hutchinson, WSI, 3/5/2007)
+!
+!</DESCRIPTION>
+
+   itf=MIN(ite,ide-1)
+   jtf=MIN(jte,jde-1)
+
+   some = 0
+   max_vert_cfl = 0.
+   max_horiz_cfl = 0.
+   total = 0
+
+   IF(config_flags%map_proj == PROJ_CASSINI ) then
+     msfxffl = 1.0/COS(config_flags%fft_filter_lat*degrad) 
+   END IF
+
+   IF ( config_flags%w_damping == 1 ) THEN
+     DO j = jts,jtf
+
+     DO k = 2, kde-1
+     DO i = its,itf
+#if 1
+        IF(config_flags%map_proj == PROJ_CASSINI ) then
+           msfuxt = MIN(msfux(i,j), msfxffl)
+        ELSE
+           msfuxt = msfux(i,j)
+        END IF
+        vert_cfl = abs(ww(i,k,j)/mut(i,j)*rdnw(k)*dt)
+
+        IF ( vert_cfl > max_vert_cfl ) THEN
+           max_vert_cfl = vert_cfl ; maxi = i ; maxj = j ; maxk = k 
+           maxdub = w(i,k,j) ; maxdeta = -1./rdnw(k)
+        ENDIF
+        
+        horiz_cfl = max( abs(u(i,k,j) * rdx * msfuxt * dt),                          &
+             abs(v(i,k,j) * rdy * msfvy(i,j) * dt) )
+        if (horiz_cfl > max_horiz_cfl) then
+           max_horiz_cfl = horiz_cfl
+        endif
+        
+        if(vert_cfl .gt. w_beta)then
+#else
+! restructure to get rid of divide
+!
+! This had been used for efficiency, but with the addition of returning the cfl values, 
+!   the old version (above) was reinstated.  (T. Hutchinson, 3/5/2007)
+!
+        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
+
+           WRITE(temp,*)i,j,k,' vert_cfl,w,d(eta)=',vert_cfl,w(i,k,j),-1./rdnw(k)
+           CALL wrf_debug ( 100 , TRIM(temp) )
+           if ( vert_cfl > 2. ) some = some + 1
+           rw_tend(i,k,j) = rw_tend(i,k,j)-sign(1.,w(i,k,j))*w_alpha*(vert_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
+
+#if 1
+        IF(config_flags%map_proj == PROJ_CASSINI ) then
+           msfuxt = MIN(msfux(i,j), msfxffl)
+        ELSE
+           msfuxt = msfux(i,j)
+        END IF
+        vert_cfl = abs(ww(i,k,j)/mut(i,j)*rdnw(k)*dt)
+        
+        IF ( vert_cfl > max_vert_cfl ) THEN
+           max_vert_cfl = vert_cfl ; maxi = i ; maxj = j ; maxk = k 
+           maxdub = w(i,k,j) ; maxdeta = -1./rdnw(k)
+        ENDIF
+        
+        horiz_cfl = max( abs(u(i,k,j) * rdx * msfuxt * dt),                          &
+             abs(v(i,k,j) * rdy * msfvy(i,j) * dt) )
+
+        if (horiz_cfl > max_horiz_cfl) then
+           max_horiz_cfl = horiz_cfl
+        endif
+        
+        if(vert_cfl .gt. w_beta)then
+#else
+! restructure to get rid of divide
+!
+! This had been used for efficiency, but with the addition of returning the cfl values, 
+!   the old version (above) was reinstated.  (T. Hutchinson, 3/5/2007)
+!
+        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
+           WRITE(temp,*)i,j,k,' vert_cfl,w,d(eta)=',vert_cfl,w(i,k,j),-1./rdnw(k)
+           CALL wrf_debug ( 100 , TRIM(temp) )
+           if ( vert_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(temp,*)some,                                            &
+            ' points exceeded cfl=2 in domain '//TRIM(grid_str)//' at time '//TRIM(time_str)//' hours'
+     CALL wrf_debug ( 0 , TRIM(temp) )
+     WRITE(temp,*)'MAX AT i,j,k: ',maxi,maxj,maxk,' vert_cfl,w,d(eta)=',max_vert_cfl, &
+                             maxdub,maxdeta
+     CALL wrf_debug ( 0 , TRIM(temp) )
+   ENDIF
+
+END SUBROUTINE w_damp
+
+!-------------------------------------------------------------------------------
+
+SUBROUTINE horizontal_diffusion ( name, field, tendency, mu,           &
+                                  config_flags,                        &
+                                  msfux, msfuy, msfvx, msfvx_inv,      &
+                                  msfvy, msftx, msfty,                 &
+                                  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   ) :: msfux,      &
+                                                                    msfuy,      &
+                                                                    msfvx,      &
+                                                                    msfvx_inv,  &
+                                                                    msfvy,      &
+                                                                    msftx,      &
+                                                                    msfty
+
+   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
+
+   LOGICAL :: specified
+
+!<DESCRIPTION>
+!
+!  horizontal_diffusion computes the horizontal diffusion tendency
+!  on model horizontal coordinate surfaces.
+!
+!</DESCRIPTION>
+
+   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
+
+         ! The interior is grad: (m_x*d/dx), the exterior is div: (m_x*m_y*d/dx(/m_y))
+         ! setting up different averagings of m^2 partial d/dX and m^2 partial d/dY
+
+         mkrdxm=(msftx(i-1,j)/msfty(i-1,j))*mu(i-1,j)*xkmhd(i-1,k,j)*rdx
+         mkrdxp=(msftx(i,j)/msfty(i,j))*mu(i,j)*xkmhd(i,k,j)*rdx
+         mrdx=msfux(i,j)*msfuy(i,j)*rdx 
+         mkrdym=( (msfuy(i,j)+msfuy(i,j-1))/(msfux(i,j)+msfux(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=( (msfuy(i,j)+msfuy(i,j+1))/(msfux(i,j)+msfux(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
+         ! need to do four-corners (t) for diffusion coefficient as there are
+         ! no values at u,v points
+         ! msfuy - has to be y as part of d/dY
+         !         has to be u as we're at a u point
+         mrdy=msfux(i,j)*msfuy(i,j)*rdy 
+
+         ! correctly averaged version of rho~ * m^2 * 
+         !    [partial d/dX(partial du^/dX) + partial d/dY(partial du^/dY)]
+            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)
+      IF ( config_flags%polar ) j_start = MAX(jds+1,jts)
+      IF ( config_flags%polar ) j_end   = MIN(jde-1,jte)
+
+      DO j = j_start, j_end
+      DO k=kts,ktf
+      DO i = i_start, i_end
+
+         mkrdxm=( (msfvx(i,j)+msfvx(i-1,j))/(msfvy(i,j)+msfvy(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=( (msfvx(i,j)+msfvx(i+1,j))/(msfvy(i,j)+msfvy(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=msfvx(i,j)*msfvy(i,j)*rdx
+         mkrdym=(msfty(i,j-1)/msftx(i,j-1))*xkmhd(i,k,j-1)*rdy
+         mkrdyp=(msfty(i,j)/msftx(i,j))*xkmhd(i,k,j)*rdy
+         mrdy=msfvx(i,j)*msfvy(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=(msfux(i,j)/msfuy(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=(msfux(i+1,j)/msfuy(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=msftx(i,j)*msfty(i,j)*rdx
+!         mkrdym=(msfvy(i,j)/msfvx(i,j))*   &
+         mkrdym=(msfvy(i,j)*msfvx_inv(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=(msfvy(i,j+1)/msfvx(i,j+1))*   &
+         mkrdyp=(msfvy(i,j+1)*msfvx_inv(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=msftx(i,j)*msfty(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=(msfux(i,j)/msfuy(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i-1,k,j))*0.5*(mu(i,j)+mu(i-1,j))*rdx
+         mkrdxp=(msfux(i+1,j)/msfuy(i+1,j))*0.5*(xkmhd(i+1,k,j)+xkmhd(i,k,j))*0.5*(mu(i+1,j)+mu(i,j))*rdx
+         mrdx=msftx(i,j)*msfty(i,j)*rdx
+!         mkrdym=(msfvy(i,j)/msfvx(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(mu(i,j)+mu(i,j-1))*rdy
+         mkrdym=(msfvy(i,j)*msfvx_inv(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(mu(i,j)+mu(i,j-1))*rdy
+!         mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(mu(i,j+1)+mu(i,j))*rdy
+         mkrdyp=(msfvy(i,j+1)*msfvx_inv(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(mu(i,j+1)+mu(i,j))*rdy
+         mrdy=msftx(i,j)*msfty(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,               &
+                                       msfux, msfuy, msfvx, msfvx_inv,      &
+                                       msfvy, msftx, msfty,                 &
+                                       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   ) :: msfux,      &
+                                                                    msfuy,      &
+                                                                    msfvx,      &
+                                                                    msfvx_inv,  &
+                                                                    msfvy,      &
+                                                                    msftx,      &
+                                                                    msfty
+
+   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
+
+   LOGICAL :: specified
+
+!<DESCRIPTION>
+!
+!  horizontal_diffusion_3dmp computes the horizontal diffusion tendency
+!  on model horizontal coordinate surfaces.  This routine computes diffusion
+!  a perturbation scalar (field-base_3d).
+!
+!</DESCRIPTION>
+
+   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=(msfux(i,j)/msfuy(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i-1,k,j))*0.5*(mu(i,j)+mu(i-1,j))*rdx
+         mkrdxp=(msfux(i+1,j)/msfuy(i+1,j))*0.5*(xkmhd(i+1,k,j)+xkmhd(i,k,j))*0.5*(mu(i+1,j)+mu(i,j))*rdx
+         mrdx=msftx(i,j)*msfty(i,j)*rdx
+!         mkrdym=(msfvy(i,j)/msfvx(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(mu(i,j)+mu(i,j-1))*rdy
+!         mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(mu(i,j+1)+mu(i,j))*rdy
+         mkrdym=(msfvy(i,j)*msfvx_inv(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(mu(i,j)+mu(i,j-1))*rdy
+         mkrdyp=(msfvy(i,j+1)*msfvx_inv(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(mu(i,j+1)+mu(i,j))*rdy
+         mrdy=msftx(i,j)*msfty(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
+
+!<DESCRIPTION>
+!
+!  vertical_diffusion
+!  computes vertical diffusion tendency.
+!
+!</DESCRIPTION>
+
+   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
+
+!<DESCRIPTION>
+!
+!  vertical_diffusion_mp
+!  computes vertical diffusion tendency of a perturbation variable
+!  (field-base).  Note that base as a 1D (k) field.
+!
+!</DESCRIPTION>
+
+   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
+
+!<DESCRIPTION>
+!
+!  vertical_diffusion_3dmp
+!  computes vertical diffusion tendency of a perturbation variable
+!  (field-base_3d).  
+!
+!</DESCRIPTION>
+
+   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
+
+!<DESCRIPTION>
+!
+!  vertical_diffusion_u computes vertical diffusion tendency for 
+!  the u momentum equation.  This routine assumes a constant eddy
+!  viscosity kvdif.
+!
+!</DESCRIPTION>
+
+   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
+
+!<DESCRIPTION>
+!
+!  vertical_diffusion_v computes vertical diffusion tendency for 
+!  the v momentum equation.  This routine assumes a constant eddy
+!  viscosity kvdif.
+!
+!</DESCRIPTION>
+
+   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
+   
+!<DESCRIPTION>
+!
+!  calculate_full
+!  calculates full 3D field from pertubation and base field.
+!
+!</DESCRIPTION>
+
+   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,                          &
+                      msftx, msfty, msfux, msfuy,            &
+                      msfvx, msfvy,                          &
+                      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   ) :: msfux,      &
+                                                                msfuy,      &
+                                                                msfvx,      &
+                                                                msfvy,      &
+                                                                msftx,      &
+                                                                msfty
+
+   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
+
+!<DESCRIPTION>
+!
+!  coriolis calculates the large timestep tendency terms in the 
+!  u, v, and w momentum equations arise from the coriolis force.
+!
+!</DESCRIPTION>
+
+   specified = .false.
+   if(config_flags%specified .or. config_flags%nested) specified = .true.
+
+   ktf=MIN(kte,kde-1)
+
+! coriolis for u-momentum equation
+
+!  Notes on map scale factor
+!  cosa, sina are related to rotating the coordinate frame if desired
+!  generally sina=0, cosa=1
+!  ADT eqn 44, RHS terms 6 and 7: -2 mu w omega cos(lat)/my
+!                                + 2 mu v omega sin(lat)/my
+!  Define f=2 omega sin(lat), e=2 omega cos(lat)
+!   => terms are: -e mu w / my + f mu v / my
+!  rv = mu v / mx ; rw = mu w / my
+!   => terms are: -e rw + f rv *mx / my
+
+   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) + (msfux(i,j)/msfuy(i,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
+
+! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
+!  IF ( (config_flags%open_xs) .and. (its == ids) ) THEN
+
+!    DO k=kts,ktf
+!  
+!      ru_tend(its,k,j)=ru_tend(its,k,j) + (msfux(its,j)/msfuy(its,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) + (msfux(ite,j)/msfuy(ite,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
+
+!  Notes on map scale factors
+!  ADT eqn 45, RHS terms 6 and 6b [0 for sina=0]: -2 mu u omega sin(lat)/mx + ?
+!  Define f=2 omega sin(lat), e=2 omega cos(lat)
+!   => terms are: -f mu u / mx
+!  ru = mu u / my ; rw = mu w / my
+!   => terms are: -f ru *my / mx + ?
+
+   j_start = jts
+   j_end   = jte
+
+   IF ( config_flags%open_ys .or. specified .or. &
+        config_flags%nested .or. config_flags%polar) j_start = MAX(jds+1,jts)
+   IF ( config_flags%open_ye .or. specified .or. &
+        config_flags%nested .or. config_flags%polar) j_end   = MIN(jde-1,jte)
+
+! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
+!  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) - (msfvy(i,jts)/msfvx(i,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))   &
+!            + (msfvy(i,jts)/msfvx(i,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) - (msfvy(i,j)/msfvx(i,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)) &
+           + (msfvy(i,j)/msfvx(i,j))*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
+
+
+! boundary loops for coriolis not needed for open bdy  (commented out 20100611 JD)
+!  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) - (msfvy(i,jte)/msfvx(i,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))   &
+!            + (msfvy(i,jte)/msfvx(i,jte))*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 
+
+! Notes on map scale factors
+! ADT eqn 46/my, RHS terms 5 and 5b [0 for sina=0]: 2 mu u omega cos(lat)/my +?
+! Define e=2 omega cos(lat)
+!  => terms are: e mu u / my + ???
+! ru = mu u / my ; ru = mu v / mx
+!  => terms are: e ru + ???
+
+   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)))           &
+          -(msftx(i,j)/msfty(i,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,                           &
+                                   msftx, msfty, msfux, msfuy, msfvx, msfvy,    &
+                                   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   ) :: msfux,      &
+                                                                msfuy,      &
+                                                                msfvx,      &
+                                                                msfvy,      &
+                                                                msftx,      &
+                                                                msfty
+
+   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
+
+!<DESCRIPTION>
+!
+!  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.
+!
+!</DESCRIPTION>
+
+   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
+
+!  Map scale factors: see comments above for Coriolis
+
+   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) + (msfux(i,j)/msfuy(i,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
+
+! boundary loops for perturbation coriolis is needed for open bdy  (20110225 JD)
+   IF ( (config_flags%open_xs) .and. (its == ids) ) THEN
+
+     DO k=kts,ktf
+   
+       ru_tend(its,k,j)=ru_tend(its,k,j) + (msfux(its,j)/msfuy(its,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) + (msfux(ite,j)/msfuy(ite,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
+!  Map scale factors: see comments above for Coriolis
+
+   j_start = jts
+   j_end   = jte
+
+   IF ( config_flags%open_ys .or. specified .or. &
+        config_flags%nested .or. config_flags%polar) j_start = MAX(jds+1,jts)
+   IF ( config_flags%open_ye .or. specified .or. &
+        config_flags%nested .or. config_flags%polar) 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
+!  Map scale factors: see comments above for Coriolis
+
+! boundary loops for perturbation coriolis is needed for open bdy  (20110225 JD)
+   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) - (msfvy(i,jts)/msfvx(i,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))   &
+             + (msfvy(i,jts)/msfvx(i,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) - (msfvy(i,j)/msfvx(i,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)) &
+           + (msfvy(i,j)/msfvx(i,j))*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
+
+
+! boundary loops for perturbation coriolis is needed for open bdy  (20110225 JD)
+   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) - (msfvy(i,jte)/msfvx(i,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))   &
+             + (msfvy(i,jte)/msfvx(i,jte))*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 
+!  Map scale factors: see comments above for Coriolis
+
+   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)))           &
+          -(msftx(i,j)/msfty(i,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,                                       &
+                        msfux, msfuy, msfvx, msfvy, msftx, msfty,       &
+                        xlat, 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   ) :: msfux,    &
+                                                                msfuy,    &
+                                                                msfvx,    &
+                                                                msfvy,    &
+                                                                msftx,    &
+                                                                msfty,    &
+                                                                xlat
+
+   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
+
+!<DESCRIPTION>
+!
+!  curvature calculates the large timestep tendency terms in the 
+!  u, v, and w momentum equations arise from the curvature terms.  
+!
+!</DESCRIPTION>
+
+   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 .or. config_flags%polar) .and. (jts == jds) ) j_start = jts
+   IF ( ( config_flags%open_ye .or. specified .or. &
+        config_flags%nested .or. config_flags%polar) .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
+!     Map scale factor notes:
+!     msf...y is constant everywhere for cylindrical map projection
+!     msf...x varies with y only
+!     But we know that this is not = 0 for cylindrical,
+!     therefore use msfvX in 1st line
+!     which => by symmetry use msfuY in 2nd line - ???  
+      vxgm(i,k,j)=0.5*(u(i,k,j)+u(i+1,k,j))*(msfvx(i,j+1)-msfvx(i,j))*rdy - &
+                  0.5*(v(i,k,j)+v(i,k,j+1))*(msfuy(i+1,j)-msfuy(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
+
+!  Polar boundary condition:
+!  The following change is needed in case one tries using the vxgm route with
+!  polar B.C.'s in the future, but not needed if 'tan' used
+   IF ( ( config_flags%open_ys .or. specified .or. &
+        config_flags%nested .or. config_flags%polar) .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
+
+!  Polar boundary condition:
+!  The following change is needed in case one tries using the vxgm route with
+!  polar B.C.'s in the future, but not needed if 'tan' used
+   IF ( ( config_flags%open_ye .or. specified .or. &
+        config_flags%nested .or. config_flags%polar) .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.
+
+!  Map scale factor notes:
+!  ADT eqn 44, RHS terms 4 and 5, in cylindrical: mu u v tan(lat)/(a my)
+!                                               - mu u w /(a my)
+!  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
+!   => terms are:
+!  (mx/my)*u rv tan(lat) / a - u rw / a = (u/a)*[(mx/my) rv tan(lat) - rw]
+!  ru v tan(lat) / a - u rw / a
+!  xlat defined with end points half grid space from pole,
+!  hence are on u latitude points
+
+   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
+
+!  Polar boundary condition
+   IF ((config_flags%map_proj == 6) .OR. (config_flags%polar)) THEN
+
+      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) + u(i,k,j)*reradius*                 ( &
+                        (msfux(i,j)/msfuy(i,j))*0.25*(rv(i-1,k,j+1)+rv(i,k,j+1)+ &
+                                    rv(i-1,k,j)+rv(i,k,j))*tan(xlat(i,j)*degrad) &
+                        - 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
+
+   ELSE  ! normal code
+
+
+      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
+
+   END IF
+
+!  curvature term for v momentum eqn.
+
+!  Map scale factor notes
+!  ADT eqn 45, RHS terms 4 and 5, in cylindrical:  - mu u*u tan(lat)/(a mx)
+!                                               - mu v w /(a mx)
+!  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
+!  terms are:
+!  - (my/mx)*u ru tan(lat) / a - (my/mx)*v rw / a 
+!  = - [my/(mx*a)]*[u ru tan(lat) + v rw]
+!  - (1/a)*[(my/mx)*u ru tan(lat) + w rv]
+!  xlat defined with end points half grid space from pole, hence are on
+!  u latitude points => av here
+!
+!  in original wrf, there was a sign error for the rw contribution
+
+   j_start = jts
+   IF ( config_flags%open_ys .or. specified .or. &
+        config_flags%nested .or. config_flags%polar) j_start = MAX ( jds+1 , jts )
+   IF ( config_flags%open_ye .or. specified .or. &
+        config_flags%nested .or. config_flags%polar) j_end   = MIN ( jde-1 , jte )
+
+   IF ((config_flags%map_proj == 6) .OR. (config_flags%polar)) THEN
+
+      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) - (msfvy(i,j)/msfvx(i,j))*reradius*   (  &
+                        0.25*(u(i,k,j)+u(i+1,k,j)+u(i,k,j-1)+u(i+1,k,j-1))*     &
+                        tan((xlat(i,j)+xlat(i,j-1))*0.5*degrad)*                &
+                        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)*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
+
+   ELSE  ! normal code
+
+      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)) &
+                       - (msfvy(i,j)/msfvx(i,j))*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
+
+   END IF
+
+!  curvature term for vertical momentum eqn.
+
+!  Notes on map scale factors:
+!  ADT eqn 46, RHS term 4: [mu/(a my)]*[u*u + v*v]
+!  ru = mu u / my ; rw = mu w / my ; rv = mu v / mx
+!  terms are: u ru / a + (mx/my)v rv / a
+
+   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)))     &
+    +(msftx(i,j)/msfty(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))) &
+    *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
+   
+!<DESCRIPTION>
+!
+!  decouple decouples a variable from the column dry-air mass.
+!
+!</DESCRIPTION>
+
+   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
+
+!<DESCRIPTION>
+!
+!  zero_tend sets the input tendency array to zero.
+!
+!</DESCRIPTION>
+
+      DO j = jts, jte
+      DO k = kts, kte
+      DO i = its, ite
+        tendency(i,k,j) = 0.
+      ENDDO
+      ENDDO
+      ENDDO
+
+      END SUBROUTINE zero_tend
+
+!-------------------------------------------------------------------------------
+! Sets the an array on the polar v point(s) to zero
+SUBROUTINE zero_pole ( field,                        &
+                       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) :: field
+
+  ! Local data
+
+  INTEGER :: i, k
+
+  IF (jts == jds) THEN
+     DO k = kts, kte
+     DO i = its-1, ite+1
+        field(i,k,jts) = 0.
+     END DO
+     END DO
+  END IF
+  IF (jte == jde) THEN
+     DO k = kts, kte
+     DO i = its-1, ite+1
+        field(i,k,jte) = 0.
+     END DO
+     END DO
+  END IF
+
+END SUBROUTINE zero_pole
+
+!-------------------------------------------------------------------------------
+! Sets the an array on the polar v point(s)
+SUBROUTINE pole_point_bc ( field,                        &
+                       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) :: field
+
+  ! Local data
+
+  INTEGER :: i, k
+
+  IF (jts == jds) THEN
+     DO k = kts, kte
+     DO i = its, ite
+!        field(i,k,jts) = 2*field(i,k,jts+1) - field(i,k,jts+2)
+        field(i,k,jts) = field(i,k,jts+1)
+     END DO
+     END DO
+  END IF
+  IF (jte == jde) THEN
+     DO k = kts, kte
+     DO i = its, ite
+!        field(i,k,jte) = 2*field(i,k,jte-1) - field(i,k,jte-2)
+        field(i,k,jte) = field(i,k,jte-1)
+     END DO
+     END DO
+  END IF
+
+END SUBROUTINE pole_point_bc
+
+!======================================================================
+!   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
+                         rho, th_phy, p_phy , pi_phy ,                &  ! output
+                         u_phy, v_phy, p8w, t_phy, t8w,               &  ! output
+                         z, z_at_w, dz8w,                             &  ! output
+                         p_hyd, p_hyd_w,                              &  ! output
+                         fzm, fzp, znw, p_top,                        &  ! params
+                         RTHRATEN,                                    &
+                         RTHBLTEN, RUBLTEN, RVBLTEN,                  &
+                         RQVBLTEN, RQCBLTEN, RQIBLTEN,                &
+                         RUCUTEN,  RVCUTEN,  RTHCUTEN,                &
+                         RQVCUTEN, RQCCUTEN, RQRCUTEN,                &
+                         RQICUTEN, RQSCUTEN,                          &
+                         RUSHTEN,  RVSHTEN,  RTHSHTEN,                &
+                         RQVSHTEN, RQCSHTEN, RQRSHTEN,                &
+                         RQISHTEN, RQSSHTEN, RQGSHTEN,                &
+                         RTHFTEN,  RQVFTEN,                           &
+                         RUNDGDTEN, RVNDGDTEN, RTHNDGDTEN,            &
+                         RPHNDGDTEN,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, &
+                                                                rho, &
+                                                                  z, &
+                                                               dz8w, &
+                                                              z_at_w 
+
+   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) ,                 &
+          INTENT(  OUT)                                  ::   p_hyd, &
+                                                              p_hyd_w
+
+   REAL , INTENT(IN   )                                  ::   p_top
+
+   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( kms:kme ) ,           INTENT(IN   ) ::     znw
+
+   REAL,  DIMENSION( ims:ime , kms:kme, jms:jme ),                   &
+          INTENT(INOUT)   ::                               RTHRATEN  
+
+   REAL,  DIMENSION( ims:ime , kms:kme, jms:jme ),                   &
+          INTENT(INOUT)   ::                                RUCUTEN, &
+                                                            RVCUTEN, &
+                                                           RTHCUTEN, &
+                                                           RQVCUTEN, &
+                                                           RQCCUTEN, &
+                                                           RQRCUTEN, &
+                                                           RQICUTEN, &
+                                                           RQSCUTEN, &
+                                                            RUSHTEN, &
+                                                            RVSHTEN, &
+                                                           RTHSHTEN, &
+                                                           RQVSHTEN, &
+                                                           RQCSHTEN, &
+                                                           RQRSHTEN, &
+                                                           RQISHTEN, &
+                                                           RQSSHTEN, &
+                                                           RQGSHTEN
+
+   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, &
+                                                           RPHNDGDTEN, &
+                                                           RQVNDGDTEN
+
+   REAL,  DIMENSION( ims:ime, jms:jme )                            , &
+          INTENT(INOUT)   ::                               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
+   REAL    :: e_vapor
+
+#ifdef LMDZ1
+   CHARACTER*256                              :: message
+   INTEGER                                    :: im2, jm2, km2
+   INTEGER                                    :: ix,iy,iz
+   CHARACTER(LEN=50)                          :: errmsg
+
+   errmsg = 'ERROR -- error -- ERROR -- error'
+
+   im2 = config_flags%i_check_point
+   jm2 = config_flags%j_check_point
+   km2 = config_flags%k_check_point
+#endif
+
+#ifdef LMDZ1
+   WRITE(message, *)'  phy_prep: inside' 
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' psfc_tend:    0.00000000     p sfc: ', &
+     p8w(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+#endif
+
+!-----------------------------------------------------------------------
+
+!<DESCRIPTION>
+!
+!  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).
+!
+!</DESCRIPTION>
+
+!  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 (or half levels)
+
+    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))
+      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 or half levels (average of z at full levels)
+
+    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 to full levels
+
+    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
+
+#ifdef LMDZ1
+   WRITE(message, *)'  phy_prep: z-levels' 
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' psfc_tend:    0.00000000     p sfc: ', &
+     p8w(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+#endif
+
+!  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
+
+#ifdef LMDZ1
+   WRITE(message, *)'  phy_prep: after p-top/bottom' 
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' psfc_tend:    0.00000000     p sfc: ', &
+     p8w(im2,kde,jm2)
+   CALL wrf_debug(200, message)
+   z0 = z_at_w(im2,1,jm2)
+   z1 = z(im2,1,jm2)
+   z2 = z(im2,2,jm2)
+   w1 = (z0 - z2)/(z1 - z2)
+   w2 = 1. - w1
+   WRITE(message,*)' z0: ',z0,' z1: ',z1,' z2: ',z2,' w1: ',w1,' w2: ',w2
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' phb: ', phb(im2,1,jm2),' ph: ',ph(im2,1,jm2),' phb 2: ', &
+     phb(im2,2,jm2),' ph 2: ',ph(im2,2,jm2),' pb: ', pb(im2,1,jm2),' p: ',p(im2,1,jm2),' pb 2: ', &
+     pb(im2,2,jm2),' p 2: ',p(im2,2,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' p_phy: ',p_phy(im2,1,jm2),' p_phy 2: ',p_phy(im2,2,jm2) 
+   CALL wrf_debug(200, message)
+#endif
+
+! calculate hydrostatic pressure at both full and half levels
+! first, full level p: assuming dry over model top
+
+    do j = j_start,j_end
+    do i = i_start, i_end
+       p_hyd_w(i,kte,j) = p_top
+    enddo
+    enddo
+
+    e_vapor = 0.
+    do j = j_start,j_end
+    do k = kte-1, k_start, -1
+    do i = i_start, i_end
+!      e_vapor = 1./alt(i,k,j)*moist(i,k,j,P_QV)*g*dz8w(i,k,j) 
+!      p_hyd_w(i,k,j) = p_hyd_w(i,k+1,j)+e_vapor
+       p_hyd_w(i,k,j) = p_hyd_w(i,k+1,j)+1./alt(i,k,j)*(1.+moist(i,k,j,P_QV))*g*dz8w(i,k,j)
+    enddo
+    enddo
+    enddo
+
+! now calculate hydrostatic pressure at half levels
+
+    do j = j_start,j_end
+    do k = k_start, k_end
+    do i = i_start, i_end
+       p_hyd(i,k,j) = 0.5*(p_hyd_w(i,k,j)+p_hyd_w(i,k+1,j))
+    enddo
+    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
+         RUCUTEN(I,K,J) =RUCUTEN(I,K,J)/mu(I,J)
+         RVCUTEN(I,K,J) =RVCUTEN(I,K,J)/mu(I,J)
+         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%shcu_physics .gt. 0) THEN
+
+      DO J=j_start,j_end
+      DO I=i_start,i_end
+      DO K=k_start,k_end
+         RUSHTEN(I,K,J) =RUSHTEN(I,K,J)/mu(I,J)
+         RVSHTEN(I,K,J) =RVSHTEN(I,K,J)/mu(I,J)
+         RTHSHTEN(I,K,J)=RTHSHTEN(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
+            RQVSHTEN(I,K,J)=RQVSHTEN(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
+            RQCSHTEN(I,K,J)=RQCSHTEN(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
+            RQRSHTEN(I,K,J)=RQRSHTEN(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
+            RQISHTEN(I,K,J)=RQISHTEN(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
+            RQSSHTEN(I,K,J)=RQSSHTEN(I,K,J)/mu(I,J)
+         ENDDO
+         ENDDO
+         ENDDO
+      ENDIF
+
+      IF(P_QG .ge. PARAM_FIRST_SCALAR)THEN
+         DO J=j_start,j_end
+         DO I=i_start,i_end
+         DO K=k_start,k_end
+            RQGSHTEN(I,K,J)=RQGSHTEN(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 ) .OR.    &
+      ( config_flags%cu_physics == G3SCHEME ) .OR.    &
+      ( config_flags%cu_physics == KFETASCHEME ) .OR. &
+      ( config_flags%cu_physics == TIEDTKESCHEME ) ) then  ! Tiedtke ZCX&YQW
+
+      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 (config_flags%grid_fdda .EQ. 2) THEN
+      DO J=j_start,j_end
+      DO K=k_start,kte
+      DO I=i_start,i_end
+         RPHNDGDTEN(I,K,J)=RPHNDGDTEN(I,K,J)/mu(I,J)
+      ENDDO
+      ENDDO
+      ENDDO
+
+      ELSE IF (config_flags%grid_fdda .EQ. 1) THEN
+      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
+
+    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
+
+   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
+
+!--------------------------------------------------------------------
+
+!<DESCRIPTION>
+!
+!  moist_phys_prep_em calculates a number of diagnostic quantities needed by
+!  the microphysics routines.
+!
+!</DESCRIPTION>
+
+!  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,              &
+#if ( WRF_DFI_RADAR == 1 )
+                                       dfi_tten_rad,dfi_stage,    &
+#endif
+                                       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
+#if ( WRF_DFI_RADAR == 1 )
+   REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),        &
+         INTENT(IN), OPTIONAL ::               dfi_tten_rad
+   INTEGER,      INTENT(IN   ) ,OPTIONAL   :: dfi_stage
+   REAL :: dfi_tten_max, old_max
+#endif
+
+   REAL mpten, mptenmax, mptenmin
+
+   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, imax, jmax, imin, jmin
+
+!--------------------------------------------------------------------
+
+!<DESCRIPTION>
+!
+!  moist_phys_finish_em resets theta to its perturbation value and
+!  computes and stores the microphysics diabatic heating term.
+!
+!</DESCRIPTION>
+
+!  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 )
+!      i_start=max(its,ids+4)
+!      i_end=min(ite,ide-5)
+!      j_start=max(jts,jds+4)
+!      j_end=min(jte,jde-5)
+
+    k_start = kts
+    k_end = min( kte, kde-1 )
+
+#if ( WRF_DFI_RADAR == 1 )
+         IF ( PRESENT(dfi_stage) .and.  PRESENT(dfi_tten_rad) ) THEN
+            IF ( dfi_stage ==DFI_FWD ) THEN
+               WRITE(wrf_err_message,*)'Add radar tendency: i_start,j_start: ', i_start, j_start
+               CALL wrf_debug ( 100 , TRIM(wrf_err_message) )
+            ENDIF
+         ENDIF
+     dfi_tten_max=-999
+     old_max=-999
+#endif
+
+!  add microphysics theta diff to perturbation theta, set h_diabatic
+
+     IF ( config_flags%no_mp_heating .eq. 0 ) THEN
+       mptenmax = 0.
+       mptenmin = 999.
+     DO j = j_start, j_end
+     DO k = k_start, k_end
+     DO i = i_start, i_end
+          mpten = th_phy(i,k,j)-h_diabatic(i,k,j)
+#if ( WRF_DFI_RADAR == 1 )
+       if(mpten.gt.mptenmax) then
+          mptenmax=mpten
+          imax=i
+          jmax=j
+       endif
+       if(mpten.lt.mptenmin) then
+          mptenmin=mpten
+          imin=i
+          jmin=j
+       endif
+          mpten=min(config_flags%mp_tend_lim*dt, mpten)
+          mpten=max(-config_flags%mp_tend_lim*dt, mpten)
+
+       if(k < k_end ) then
+         if(dfi_tten_max < dfi_tten_rad(i,k,j) ) dfi_tten_max = dfi_tten_rad(i,k,j)
+         if(old_max < (th_phy(i,k,j)-h_diabatic(i,k,j)) ) old_max=th_phy(i,k,j)-h_diabatic(i,k,j)
+       endif
+
+       IF ( PRESENT(dfi_stage) .and. PRESENT(dfi_tten_rad) ) THEN
+          IF ( dfi_stage == DFI_FWD .and. dfi_tten_rad(i,k,j) >= -0.1 .and. &
+               dfi_tten_rad(i,k,j) <= 0.1 .and. k < k_end ) THEN
+! add radar temp tendency
+! there is radar coverage
+               t_new(i,k,j) = t_new(i,k,j) + (dfi_tten_rad(i,k,j))*dt
+          ELSE
+! no radar coverage
+               t_new(i,k,j) = t_new(i,k,j) + mpten
+          ENDIF
+       ENDIF
+#else
+         t_new(i,k,j) = t_new(i,k,j) + mpten
+#endif
+         h_diabatic(i,k,j) =  mpten/dt
+     ENDDO
+     ENDDO
+     ENDDO
+
+     ELSE
+
+     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)
+         h_diabatic(i,k,j) = 0.
+     ENDDO
+     ENDDO
+     ENDDO
+     ENDIF
+
+   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
+
+!<DESCRIPTION>
+!
+!  set_tend copies the advective tendency array into the tendency array.
+!
+!</DESCRIPTION>
+
+      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 theta_relaxation( t_tendf, t, t_init,              &
+                              mut, ph, phb,                    &
+                              t_base, z_base,                  &
+                              ids, ide, jds, jde, kds, kde,    &
+                              ims, ime, jms, jme, kms, kme,    &
+                              its, ite, jts, jte, kts, kte   )
+
+! Purpose:  Newtonian relaxation on potential temperature.  Serves two 
+!           purposes:  1) to mimic atmospheric radiation in a simple 
+!           manner, and 2) to keep the vertical profile of temperature 
+!           close to the initial (base-state) profile, which is useful 
+!           for certain idealized applications. 
+
+! Reference:  Rotunno and Emanuel, 1987, JAS, p. 546
+
+!-----------------------------------------------------------------------
+! 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 )  &
+    :: t_tendf
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN )  &
+    :: t, t_init, ph, phb
+
+    REAL, DIMENSION( ims:ime, jms:jme ),  INTENT( IN )  &
+    :: mut
+
+    REAL, DIMENSION( kms:kme ) ,  INTENT(IN   )  &
+    :: t_base, z_base
+
+! Local variables.
+
+    INTEGER :: i, j, k, ktf, k2
+    REAL :: tau_r , rmax , rmin , inv_tau_r , inv_g , rterm
+    REAL, DIMENSION( kms:kme ) :: z00,t00
+
+! End declarations.
+!-----------------------------------------------------------------------
+
+    ! set tau_r to 12 h, following RE87
+    tau_r = 12.0*3600.0
+
+    ! limit rterm to +/- 2 K/day
+    rmax =  2.0/86400.0
+    rmin = -rmax
+
+    ktf = MIN( kte,   kde-1 )
+    inv_tau_r = 1.0/tau_r
+    inv_g = 1.0/g
+
+!-----------------------------------------------------------------------
+! Adjust potential temperature to base state.
+
+    DO j = jts, MIN( jte,   jde-1 )
+    DO i = its, MIN( ite,   ide-1 )
+
+      ! Get height of model levels:
+      DO k = kts, ktf
+        z00(k) = 0.5 * ( phb(i,k,j) + phb(i,k+1,j) +  &
+                          ph(i,k,j) +  ph(i,k+1,j) ) * inv_g
+      ENDDO
+
+      ! Get reference state:
+      DO k = kts, ktf
+        k2 = ktf
+        DO WHILE( z_base(k2) .gt. z00(k)  .and.  k2 .gt. 1 )
+          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 RE87 R term:
+      DO k = kts, ktf
+        rterm = -( t(i,k,j) - t00(k) )*inv_tau_r
+        ! limit rterm:
+        rterm = min( rterm , rmax )
+        rterm = max( rterm , rmin )
+        t_tendf(i,k,j) = t_tendf(i,k,j) + mut(i,j)*rterm
+      END DO
+
+    END DO
+    END DO
+
+ END SUBROUTINE theta_relaxation
+
+!==============================================================================
+!==============================================================================
+                                                                                
+      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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_convtrans_prep.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_convtrans_prep.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_convtrans_prep.F	(revision 17)
@@ -0,0 +1,200 @@
+!------------------------------------------------------------------------
+! original routinte by Georg Grell, adaptive timestepping by William Gustafson Jr. (PNNL), cloud fraction by Georg Grell (based on Stu's previous work wih so2so4 routine
+!------------------------------------------------------------------------
+
+Module module_convtrans_prep
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+CONTAINS
+subroutine convtrans_prep(gd_cloud,gd_cloud2,gd_cloud_a,         &
+     gd_cloud_b,raincv,raincv_a,raincv_b,                        &
+     cldfr,moist,p_QV,p_QC,p_qi,T_PHY,P_PHY,num_moist,                 &
+     gd_cloud2_a,gd_cloud2_b,convtrans_avglen_m,         &
+     adapt_step_flag,curr_secs,                    &
+     ktau,dt,cu_phys,  &
+     ids,ide, jds,jde, kds,kde,                                  &
+     ims,ime, jms,jme, kms,kme,                                  &
+     its,ite, jts,jte,kts,kte                                    )
+    REAL, PARAMETER  ::  coef_p = 0.25, coef_gamm = 0.49, coef_alph = 100.
+
+  INTEGER,      INTENT(IN   ) :: ids,ide, jds,jde, kds,kde,      &
+                                 ims,ime, jms,jme, kms,kme,      &
+                                 its,ite, jts,jte, kts,kte,      &
+                                 p_QV,p_QC,p_qi,num_moist
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
+       OPTIONAL,                                                 &
+       INTENT(IN ) :: gd_cloud,gd_cloud2
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
+       INTENT(IN ) :: t_phy,p_phy
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ),       &
+       INTENT(IN ) :: moist
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
+       OPTIONAL,                                                 &
+       INTENT(INOUT ) :: gd_cloud_a,gd_cloud_b,gd_cloud2_a,      &
+                         cldfr,gd_cloud2_b
+  REAL, DIMENSION( ims:ime, jms:jme ),                           &
+       INTENT(IN ) :: raincv
+  REAL, DIMENSION( ims:ime, jms:jme ),                           &
+       INTENT(INOUT ) :: raincv_a,raincv_b
+  INTEGER, INTENT(IN) :: ktau,cu_phys
+  INTEGER  :: stepave, stepave_count
+  REAL, INTENT(IN) :: curr_secs
+  REAL, INTENT(IN) :: convtrans_avglen_m, dt
+  LOGICAL, INTENT(IN) :: adapt_step_flag
+
+  LOGICAL :: avg_end_flag, first_period_flag
+  REAL :: satvp,rhgrid,h2oliq
+  real :: pmax,pmin
+!
+! Determine where we are in relation to the averaging period...
+!
+!  convtrans_avglen_m = 30.  !Averaging time for convective transport in min.
+
+  stepave=convtrans_avglen_m*60./dt
+  avg_end_flag = .false.      !Initially assume we are not at the end
+  first_period_flag = .false. !Nor at the beginning
+  if( adapt_step_flag ) then
+     !If end of period...
+     if( curr_secs+real(dt,8)+0.01 >= &
+          ( int( curr_secs/real(convtrans_avglen_m*60.,8) + 1_8, 8) &
+            *real(convtrans_avglen_m*60.,8) ) ) &
+          avg_end_flag = .true.
+     if( curr_secs <= real(convtrans_avglen_m*60.,8) ) first_period_flag = .true.
+  else
+     if( mod(ktau,stepave)==0 ) avg_end_flag = .true.
+     if( ktau <= stepave ) first_period_flag = .true.
+  end if
+!
+! Initialize the averaging arrays at the simulation start
+!
+  if(ktau.le.1)then
+     stepave_count             = 0
+     raincv_a(its:ite,jts:jte) = 0.
+     raincv_b(its:ite,jts:jte) = 0.
+  end if
+  if(present(gd_cloud2_a))then
+     if(ktau.le.1) gd_cloud2_a(its:ite,kts:kte,jts:jte)=0.
+  end if
+  if(present(cldfr))then
+     if(ktau.le.1) cldfr(its:ite,kts:kte,jts:jte)=0.
+  end if
+!
+! no time average available in first half hour
+!
+  if( first_period_flag )then
+     do j=jts,jte
+        do i=its,ite
+           raincv_b(i,j)=raincv(i,j)
+        enddo
+     enddo
+  end if
+!
+! build time average, and stored in raincv_b to be used by convective transport routine
+!
+  stepave_count = stepave_count+1
+  do j=jts,jte
+     do i=its,ite
+        raincv_a(i,j)=raincv_a(i,j)+raincv(i,j)
+     enddo
+  enddo
+  if( avg_end_flag )then
+     do j=jts,jte
+        do i=its,ite
+           raincv_b(i,j)=raincv_a(i,j)/real(stepave_count)
+           raincv_a(i,j)=0.
+        enddo
+     enddo
+  end if
+!
+! do the same for convective parameterization cloud water mix ratio,
+! currently only for cu_physics=3,5, used by both photolysis and atmospheric radiation
+!
+  if(cu_phys.eq.3.or.cu_phys.eq.5)then
+!    pmax=maxval(gd_cloud)
+!    pmin=maxval(gd_cloud2)
+!    print *,pmax,pmin
+     if( first_period_flag )then
+        do j=jts,jte
+           do k=kts,kte
+              do i=its,ite
+                 gd_cloud_b(i,k,j)=gd_cloud(i,k,j)
+                 gd_cloud2_b(i,k,j)=gd_cloud2(i,k,j)
+              enddo
+           enddo
+        enddo
+     end if   ! stepave
+!
+!
+!
+     do j=jts,jte
+
+        do k=kts,kte
+           do i=its,ite
+              gd_cloud_a(i,k,j)=gd_cloud_a(i,k,j)+gd_cloud(i,k,j)
+              gd_cloud2_a(i,k,j)=gd_cloud2_a(i,k,j)+gd_cloud2(i,k,j)
+           enddo
+        enddo
+     enddo
+     if( avg_end_flag )then
+        do j=jts,jte
+           do k=kts,kte
+              do i=its,ite
+                 gd_cloud_b(i,k,j)=.1*gd_cloud_a(i,k,j)/real(stepave_count)
+                 gd_cloud_a(i,k,j)=0.
+                 gd_cloud2_b(i,k,j)=.1*gd_cloud2_a(i,k,j)/real(stepave_count)
+                 gd_cloud2_a(i,k,j)=0.
+              enddo
+           enddo
+        enddo
+!    pmax=maxval(gd_cloud_b)
+!    pmin=maxval(gd_cloud2_b)
+!    print *,'avg_end_flag ',pmax,pmin
+     end if !stepave
+  end if ! cu_rad_feedback
+!
+! Clear the accumulator counter if we just finished an average...
+!
+if( avg_end_flag ) stepave_count = 0
+! Siebesma et al., JAS, Vol. 60, no. 10, 1201-1219, 2003 (based on LES comparisons with trade-wind cumulus from BOMEX)
+! SAM: Note units of liquid water and saturation vapor pressure must be in g/kg
+    ! within the Siebesma et al. cloud fraction scheme
+if( first_period_flag .or. avg_end_flag )then
+
+        do j=jts,jte
+           do k=kts,kte
+              do i=its,ite
+                cldfr(i,k,j)=0.
+!               if(gd_cloud_b(i,k,j).gt.0  .or. gd_cloud2_b(i,k,j).gt.0)then
+
+                   if(p_qc.gt.1 .and. p_qi.le.1)then
+
+                      satvp = 3.80*exp(17.27*(t_phy(i,k,j)-273.)/ &
+                            (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j))
+                      rhgrid = max(.1,MIN( .95, moist(i,k,j,p_qv) /satvp))
+                       h2oliq=1000.*(gd_cloud_b(i,k,j) + moist(i,k,j,p_qc))
+                       satvp=1000.*satvp
+                       cldfr(i,k,j)=(1.-exp(-coef_alph*h2oliq/((1.-rhgrid)*satvp)**coef_gamm))*(rhgrid**coef_p)
+                       cldfr(i,k,j)=max(0.,MIN(1.,cldfr(i,k,j)))
+                       if(moist(i,k,j,p_qc).eq.0)cldfr(i,k,j)=cldfr(i,k,j)*.2
+                     endif
+                   if(p_qc.gt.1 .and. p_qi.gt.1)then
+                      satvp = 3.80*exp(17.27*(t_phy(i,k,j)-273.)/ &
+                            (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j))
+                      rhgrid = max(.1,MIN( .95, moist(i,k,j,p_qv) /satvp))
+                       h2oliq=1000.*(gd_cloud_b(i,k,j) + moist(i,k,j,p_qc) + &
+                                     gd_cloud2_b(i,k,j) + moist(i,k,j,p_qi))
+                       satvp=1000.*satvp
+                       cldfr(i,k,j)=(1.-exp(-coef_alph*h2oliq/((1.-rhgrid)*satvp)**coef_gamm))*(rhgrid**coef_p)
+                       cldfr(i,k,j)=max(0.,MIN(1.,cldfr(i,k,j)))
+                       if(moist(i,k,j,p_qc).eq.0 .and. moist(i,k,j,p_qi).eq.0)cldfr(i,k,j)=cldfr(i,k,j)*.2
+                     endif
+!                  endif
+              enddo
+           enddo
+        enddo
+   endif
+
+END subroutine convtrans_prep
+
+END MODULE MODULE_CONVTRANS_prep
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_damping_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_damping_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_damping_em.F	(revision 17)
@@ -0,0 +1,72 @@
+!WRF:MODEL_LAYER:DYNAMICS
+!
+MODULE module_damping_em
+
+  USE module_wrf_error
+
+CONTAINS
+
+!------------------------------------------------------------------------------
+
+  SUBROUTINE held_suarez_damp( ru_tend, rv_tend, ru, rv, p, pb,  &
+                               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, DIMENSION( ims:ime , kms:kme, jms:jme ),          &
+          INTENT(INOUT) ::                         ru_tend, &
+                                                   rv_tend
+
+    REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),          &
+          INTENT(IN) ::                            ru, rv, p, pb
+
+    integer :: i,j,k
+
+    REAL :: delty,delthez,sigb,kka,kkf
+    REAL :: sig,sigterm,kkt,kkv,daylensec
+
+    sigb=0.7
+    daylensec=60.0*60.0*24.0
+    kkf=1.0/daylensec
+
+!  fixed limits so no divide by zero, WCS 070509
+
+    DO j=max(jds+1,jts),min(jde-1,jte)
+    DO k=kts,MIN(kte,kde-1)
+    DO i=its,ite
+
+       sig=    (p(i,k,j-1)+pb(i,k,j-1)+p(i,k,j)+pb(i,k,j))/     &
+               (p(i,1,j-1)+pb(i,1,j-1)+p(i,1,j)+pb(i,1,j))
+       sigterm=max(0.0,(sig-sigb)/(1.0-sigb))
+       kkv=kkf*sigterm
+       rv_tend(i,k,j)=rv_tend(i,k,j)-kkv*rv(i,k,j)
+ 
+    END DO
+    END DO
+    END DO
+
+    DO j=jts,min(jde-1,jte)
+    DO k=kts,MIN(kte,kde-1)
+    DO i=its,ite
+
+       sig=    (p(i-1,k,j)+pb(i-1,k,j)+p(i,k,j)+pb(i,k,j))/     &
+               (p(i-1,1,j)+pb(i-1,1,j)+p(i,1,j)+pb(i,1,j))
+       sigterm=max(0.0,(sig-sigb)/(1.0-sigb))
+       kkv=kkf*sigterm
+       ru_tend(i,k,j)=ru_tend(i,k,j)-kkv*ru(i,k,j)
+ 
+    END DO
+    END DO
+    END DO
+
+  END SUBROUTINE held_suarez_damp
+
+!------------------------------------------------------------------------------
+
+END MODULE module_damping_em
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_diffusion_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_diffusion_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_diffusion_em.F	(revision 17)
@@ -0,0 +1,6017 @@
+! 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,        &
+                                   nba_rij, n_nba_rij,               & !JDM
+                                   u_base, v_base, msfux, msfuy,     &
+                                   msfvx, msfvy, msftx, msfty,       &
+                                   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)
+
+!-----------------------------------------------------------------------
+! Comments 10-MAR-05
+! Equations 13a-f, Chen and Dudhia 2000, Appendix A:
+! Eqn 13a: D11=defor11= 2m^2 * (partial du^/dX + partial dpsi/dx * partial du^/dpsi)
+! Eqn 13b: D22=defor22= 2m^2 * (partial dv^/dY + partial dpsi/dy * partial dv^/dpsi)
+! Eqn 13c: D33=defor33= 2 * partial dw/dz [SIMPLER FORM]
+! Eqn 13d: D12=defor12= m^2 * (partial dv^/dX + partial du^/dY +
+!                              partial dpsi/dx * partial dv^/dpsi +
+!                              partial dpsi/dy * partial du^/dpsi)
+! Eqn 13e: D13=defor13= m^2 * (partial dw^/dX + partial dpsi/dx * partial dw^/dpsi)
+!                           + partial du/dz [SIMPLER FORM]
+! Eqn 13f: D23=defor23= m^2 * (partial dw^/dY + partial dpsi/dy * partial dw^/dpsi)
+!                           + partial dv/dz [SIMPLER FORM]
+!-----------------------------------------------------------------------
+! 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 )  &
+    :: msfux, msfuy, msfvx, msfvy, msftx, msfty
+
+    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 
+
+   INTEGER, INTENT(  IN ) :: n_nba_rij !JDM
+
+   REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_rij), INTENT(INOUT) & !JDM
+   :: nba_rij
+
+
+! 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.
+!-----------------------------------------------------------------------
+
+! Comments 10-MAR-2005
+! Treat all differentials as 'div-style' [or 'curl-style'],
+! i.e., du/dX becomes (in map coordinate space) mx*my * d(u/my)/dx,
+! NB - all equations referred to here are from Chen and Dudhia 2002, from the
+! WRF physics documents web pages:
+! http://www.mmm.ucar.edu/wrf/users/docs/wrf-doc-physics.pdf
+
+!=======================================================================
+! 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) = msftx(i,j) * msfty(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) / msfuy(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
+
+    ! Comments 10-MAR-05
+    ! Eqn 13a: D11=defor11= 2m^2 * (partial du^/dX + partial dpsi/dx * partial du^/dpsi)
+    ! Below, D11 is set = 2*tmp1
+    ! => tmp1 = m^2 * (partial du^/dX + partial dpsi/dx * partial du^/dpsi)
+    ! tmpzx = averaged value of dpsi/dx (=zx)
+
+    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)
+      ! tmp1 to here = partial dpsi/dx * partial du^/dpsi:
+    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).
+! Comments 10-MAR-05
+! Eqn 13a: D11=defor11= 2 m^2 * (partial du^/dX + partial dpsi/dx * partial du^/dpsi)
+!                     = 2*tmp1
+
+    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
+      ! Because msfvx at the poles will be undefined (1./0.), we will have
+      ! trouble.  But we are OK since v at the poles is 0., and that takes
+      ! precedence in this case.
+      IF ((config_flags%polar) .AND. ((j == jds) .OR. (j == jde))) THEN
+         hat(i,k,j) = 0.
+      ELSE ! normal code
+      hat(i,k,j) = v(i,k,j) / msfvx(i,j)
+      ENDIF
+    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
+
+    ! Comments 10-MAR-05
+    ! Eqn 13b: D22=defor22= 2m^2 * (partial dv^/dY + partial dpsi/dy * partial dv^/dpsi)
+    ! Below, D22 is set = 2*tmp1
+    ! => tmp1 = m^2 * (partial dv^/dY + partial dpsi/dy * partial dv^/dpsi)
+    ! tmpzy = averaged value of dpsi/dy (=zy)
+
+    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)
+      ! tmp1 to here = partial dpsi/dy * partial dv^/dpsi:
+    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).
+! Comments 10-MAR-05
+! Eqn 13b: D22=defor22= 2 m^2 * (partial dv^/dY + partial dpsi/dy * partial dv^/dpsi)
+!                     = 2*tmp1
+
+    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.
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+! Comments 10-MAR-05
+! Eqn 13c: D33=defor33= 2 * partial dw/dz
+! Below, D33 is set = 2*tmp1
+! => tmp1 = partial dw/dz
+
+! 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.
+!=======================================================================
+
+! Comments 10-MAR-2005
+! Treat all differentials as 'div-style' [or 'curl-style'],
+! i.e., du/dY becomes (in map coordinate space) mx*my * d(u/mx)/dy,
+!       dv/dX becomes (in map coordinate space) mx*my * d(v/my)/dx,
+! (see e.g. Haltiner and Williams p. 441)
+
+!=======================================================================
+! 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.
+
+! Comments 10-MAR-05
+! du/dy => need u map scale factor in x (which is defined at u points)
+! averaged over j and j-1
+! dv/dx => need v map scale factor in y (which is defined at v points)
+! averaged over i and i-1
+
+    DO j = j_start, j_end
+    DO i = i_start, i_end
+      mm(i,j) = 0.25 * ( msfux(i,j-1) + msfux(i,j) ) * ( msfvy(i-1,j) + msfvy(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
+      ! Fixes to set_physical_bc2/3d for polar boundary conditions 
+      ! remove issues with loop over j
+      hat(i,k,j) = u(i,k,j) / msfux(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
+
+    ! tmpzy = averaged value of dpsi/dy (=zy) on vorticity grid
+    ! tmp1  = partial dpsi/dy * partial du^/dpsi
+    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.25 * tmpzy * ( rdzw(i,k,j) + rdzw(i-1,k,j) + &
+                                     rdzw(i-1,k,j-1) + rdzw(i,k,j-1) )
+    END DO
+    END DO
+    END DO
+
+! End calculation of du/dy.
+!---------------------------------------------------------------------- 
+
+!-----------------------------------------------------------------------
+! Add the first term to defor12 (du/dy+dv/dx) at vorticity points.
+
+! Comments 10-MAR-05
+! Eqn 13d: D12=defor12= m^2 * (partial dv^/dX + partial du^/dY +
+!                              partial dpsi/dx * partial dv^/dpsi +
+!                              partial dpsi/dy * partial du^/dpsi)
+! Here deal with m^2 * (partial du^/dY + partial dpsi/dy * partial du^/dpsi)
+! Still need to add v^ terms: 
+!   m^2 * (partial dv^/dX + partial dpsi/dx * partial dv^/dpsi)
+
+    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) / msfvy(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
+
+    ! Fixes to set_physical_bc2/3d have made any check for polar B.C.'s
+    ! unnecessary in this place.  zx, rdzw, and hatavg are all defined
+    ! in places they need to be and the values at the poles are replications
+    ! of the values one grid point in, so the averaging over j and j-1 works
+    ! to act as just using the value at j or j-1 (with out extra code).
+    !
+    ! tmpzx = averaged value of dpsi/dx (=zx) on vorticity grid
+    ! tmp1  = partial dpsi/dx * partial dv^/dpsi
+    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.25 * tmpzx * ( rdzw(i,k,j) + rdzw(i,k,j-1) + &
+                                     rdzw(i-1,k,j-1) + rdzw(i-1,k,j) )
+    END DO
+    END DO
+    END DO
+
+! End calculation of dv/dx.
+!-----------------------------------------------------------------------
+
+!-----------------------------------------------------------------------
+! Add the second term to defor12 (du/dy+dv/dx) at vorticity points.
+
+! Comments 10-MAR-05
+! Eqn 13d: D12=defor12= m^2 * (partial dv^/dX + partial du^/dY +
+!                              partial dpsi/dx * partial dv^/dpsi +
+!                              partial dpsi/dy * partial du^/dpsi)
+! Here adding v^ terms:
+!    m^2 * (partial dv^/dX + partial dpsi/dx * partial dv^/dpsi)
+
+  IF ( config_flags%sfs_opt .GT. 0 ) THEN ! NBA--
+
+!JDM____________________________________________________________________
+!
+!     s12 =  du/dy + dv/dx 
+!         = (du/dy - dz/dy*du/dz) + (dv/dx - dz/dx*dv/dz)
+!            ______defor12______             ___tmp1___
+!
+!     r12 =  du/dy - dv/dx 
+!         = (du/dy - dz/dy*du/dz) - (dv/dx - dz/dx*dv/dz)
+!            ______defor12______             ___tmp1___
+!_______________________________________________________________________
+
+
+    DO j = j_start, j_end
+    DO k = kts, ktf
+    DO i = i_start, i_end
+
+      nba_rij(i,k,j,P_r12) = defor12(i,k,j) -  &    
+                             mm(i,j) * (   &                            
+                             rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) ) 
+
+      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)
+        nba_rij(ids,k,j,P_r12) = nba_rij(ids+1,k,j,P_r12) 
+      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)
+        nba_rij(i,k,jds,P_r12) = nba_rij(i,k,jds+1,P_r12) 
+      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)
+        nba_rij(ide,k,j,P_r12) = nba_rij(ide-1,k,j,P_r12) 
+      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)
+        nba_rij(i,k,jde,P_r12) = nba_rij(i,k,jde-1,P_r12) 
+      END DO
+      END DO
+    END IF
+
+  ELSE ! NOT NBA--------------------------------------------------------
+
+    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
+
+  ENDIF ! NBA-----------------------------------------------------------
+
+! End update of boundary for defor12.
+!-----------------------------------------------------------------------
+
+! Comments 10-MAR-05
+! Further deformation terms not needed for 2-dimensional Smagorinsky diffusion,
+! so those terms have not been dealt with yet.
+! A "y" has simply been added to all map scale factors to allow the model to
+! compile without errors.
+
+!-----------------------------------------------------------------------
+! 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) = msfux(i,j) * msfuy(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) / msfty(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) / msfty(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) / msfty(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.
+
+
+  IF ( config_flags%sfs_opt .GT. 0 ) THEN ! NBA--
+
+!JDM____________________________________________________________________
+!
+!     s13 = du/dz +  dw/dx  
+!         = du/dz + (dw/dx - dz/dx*dw/dz)
+!         = tmp1  +  ______defor13______
+!
+!     r13 = du/dz -  dw/dx 
+!         = du/dz - (dw/dx - dz/dx*dw/dz) 
+!         = tmp1  -  ______defor13______  
+!_______________________________________________________________________
+
+    DO j = j_start, j_end
+    DO k = kts+1, ktf
+    DO i = i_start, i_end
+      nba_rij(i,k,j,P_r13) =  tmp1(i,k,j) - defor13(i,k,j)   
+      defor13(i,k,j) = defor13(i,k,j) + tmp1(i,k,j)
+    END DO
+    END DO
+    END DO
+
+    DO j = j_start, j_end !change for different surface B. C. 
+    DO i = i_start, i_end
+      nba_rij(i,kts  ,j,P_r13) = 0.0
+      nba_rij(i,ktf+1,j,P_r13) = 0.0
+    END DO
+    END DO
+
+  ELSE ! NOT NBA--------------------------------------------------------
+
+    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
+
+  ENDIF ! NBA-----------------------------------------------------------
+
+! 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) = msfvx(i,j) * msfvy(i,j)
+    END DO
+    END DO
+
+! Apply a coordinate transformation to vertical velocity, w.  Added by CW 7/19/07
+
+    DO j = j_start, j_end
+    DO k = kts, kte
+    DO i = i_start, i_end
+      hat(i,k,j) = w(i,k,j) / msftx(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) / msftx(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) / msftx(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.
+
+  IF ( config_flags%sfs_opt .GT. 0 ) THEN ! NBA--
+
+!JDM___________________________________________________________________
+!
+!     s23 = dv/dz +  dw/dy  
+!         = dv/dz + (dw/dy - dz/dy*dw/dz)
+!           tmp1  +  ______defor23______
+!
+!     r23 = dv/dz -  dw/dy 
+!         = dv/dz - (dw/dy - dz/dy*dw/dz) 
+!         = tmp1  -  ______defor23______  
+
+! Add tmp1 to defor23.
+
+    DO j = j_start, j_end
+    DO k = kts+1, ktf
+    DO i = i_start, i_end
+      nba_rij(i,k,j,P_r23) = tmp1(i,k,j) - defor23(i,k,j)  
+      defor23(i,k,j) = defor23(i,k,j) + tmp1(i,k,j)
+    END DO
+    END DO
+    END DO
+
+    DO j = j_start, j_end
+      DO i = i_start, i_end
+        nba_rij(i,kts  ,j,P_r23) = 0.0
+        nba_rij(i,ktf+1,j,P_r23) = 0.0
+      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)
+        nba_rij(ids,k,j,P_r13) = nba_rij(ids+1,k,j,P_r13) 
+        nba_rij(ids,k,j,P_r23) = nba_rij(ids+1,k,j,P_r23) 
+      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)
+        nba_rij(i,k,jds,P_r13) = nba_rij(i,k,jds+1,P_r13) 
+        nba_rij(i,k,jds,P_r23) = nba_rij(i,k,jds+1,P_r23) 
+      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)
+        nba_rij(ide,k,j,P_r13) = nba_rij(ide-1,k,j,P_r13) 
+        nba_rij(ide,k,j,P_r23) = nba_rij(ide-1,k,j,P_r23) 
+      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)
+        nba_rij(i,k,jde,P_r13) = nba_rij(i,k,jde-1,P_r13) 
+        nba_rij(i,k,jde,P_r23) = nba_rij(i,k,jde-1,P_r23) 
+      END DO
+      END DO
+    END IF
+
+  ELSE ! NOT NBA--------------------------------------------------------
+
+! 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
+
+  ENDIF ! NBA-----------------------------------------------------------
+
+! 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, 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, isotropic,   &
+                                n_moist, cf1, cf2, cf3, warm_rain,       &
+                                mix_upper_bound,                         &
+                                msftx, msfty,                            &
+                                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, isotropic,  & 
+       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 )  &
+    :: 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, 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 )  &
+    :: mix_upper_bound
+
+    REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN )  &
+    :: msftx, msfty
+
+! 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, 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, xkmv,                &
+                               xkhh, xkhv, BN2, tke, p8w, t8w, theta,   &
+                               rdz, rdzw, dx, dy, dt, isotropic,        &
+                               mix_upper_bound, msftx, msfty,           &
+                               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, xkmv,                &
+                               xkhh, xkhv, BN2, div,                    &
+                               defor11, defor22, defor33,               &
+                               defor12, defor13, defor23,               &
+                               rdzw, dx, dy, dt, isotropic,             &
+                               mix_upper_bound, msftx, msfty,           &
+                               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, xkmv,                &
+                               xkhh, xkhv, defor11, defor22, defor12,   &
+                               rdzw, dx, dy, msftx, msfty,              &
+                               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, xkmh, xkhh, xkmv, xkhv,    &
+                       dx, dy, dt, dampcoef, rdz, rdzw, zdamp,  &
+                       msftx, msfty,                            &
+                       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,xkmh,xkhh,xkmv,xkhv,                       &
+                       dx,dy,dt,dampcoef,                                      &
+                       rdz, rdzw ,zdamp,                                       &
+                       msftx, msfty,                                           &
+                       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)    ::     xkmh , &
+                                                                         xkhh , &
+                                                                         xkmv , &
+                                                                         xkhv 
+
+   REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   )    ::     rdz,   &
+                                                                         rdzw
+
+   REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN   )             ::     msftx, &
+                                                                         msfty
+! LOCAL VARS
+
+   INTEGER :: i_start, i_end, j_start, j_end, ktf, ktfm1, i, j, k
+   REAL    :: kmmax,kmmvmax,degrad90,dz,tmp
+   REAL    :: ds
+   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
+         ! Unmodified dx used above may produce very large diffusivities
+         ! when msftx is very large.  And the above formula ignores the fact
+         ! that dy may now be different from dx as well.  Let's fix that by
+         ! defining a "ds" as the minimum of the "real-space" (physical
+         ! distance) values of dx and dy, and then using that smallest value
+         ! to calculate a point-by-point kmmax
+         ds = MIN(dx/msftx(i,j),dy/msfty(i,j))
+         kmmax=ds*ds/dt
+
+!         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)*cos(degrad90*tmp)*kmmax*dampcoef
+         dampkv(i,k,j)=cos(degrad90*tmp)*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
+         ! Unmodified dx used above may produce very large diffusivities
+         ! when msftx is very large.  And the above formula ignores the fact
+         ! that dy may now be different from dx as well.  Let's fix that by
+         ! defining a "ds" as the minimum of the "real-space" (physical
+         ! distance) values of dx and dy, and then using that smallest value
+         ! to calculate a point-by-point kmmax
+         ds = MIN(dx/msftx(i,j),dy/msfty(i,j))
+         kmmax=ds*ds/dt
+
+!         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)*cos(degrad90*tmp)*kmmax*dampcoef
+         dampkv(i,k,j)=cos(degrad90*tmp)*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
+      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,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, &
+                                                                         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
+      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,xkmv,xkhh,xkhv,BN2,                      &
+                    div,defor11,defor22,defor33,defor12,                       &
+                    defor13,defor23,                                           &
+                    rdzw,dx,dy,dt,isotropic,                                   &
+                    mix_upper_bound, msftx, msfty,                             &
+                    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   )           :: isotropic
+   REAL    ,          INTENT(IN   )           :: dx, dy, dt, mix_upper_bound
+
+
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN   ) ::      BN2, &
+                                                                         rdzw
+
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) ::     xkmh, &
+                                                                         xkmv, &
+                                                                         xkhh, &
+                                                                         xkhv
+
+   REAL , DIMENSION( ims:ime , kms:kme, jms:jme ),  INTENT(IN   )      ::      &    
+                                                                      defor11, &
+                                                                      defor22, &
+                                                                      defor33, &
+                                                                      defor12, &
+                                                                      defor13, &
+                                                                      defor23, &
+                                                                          div
+   REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN   ) ::                msftx, &
+                                                                        msfty
+! LOCAL VARS
+
+   INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k
+   REAL    :: deltas, tmp, pr, mlen_h, mlen_v, c_s
+
+   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
+   c_s = config_flags%c_s
+
+   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
+!
+   IF (isotropic .EQ. 0) THEN
+      DO j = j_start, j_end
+      DO k = kts, ktf
+      DO i = i_start, i_end
+         mlen_h=sqrt(dx/msftx(i,j) * dy/msfty(i,j))
+         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), mix_upper_bound * mlen_h * mlen_h / dt )
+         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), mix_upper_bound * mlen_v * mlen_v / dt )
+         xkhh(i,k,j)=xkmh(i,k,j)/pr
+         xkhh(i,k,j)=min(xkhh(i,k,j), mix_upper_bound * mlen_h * mlen_h / dt )
+         xkhv(i,k,j)=xkmv(i,k,j)/pr
+         xkhv(i,k,j)=min(xkhv(i,k,j), mix_upper_bound * mlen_v * mlen_v / dt )
+      ENDDO
+      ENDDO
+      ENDDO
+   ELSE
+      DO j = j_start, j_end
+      DO k = kts, ktf
+      DO i = i_start, i_end
+         deltas=(dx/msftx(i,j) * dy/msfty(i,j)/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), mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt )
+         xkmv(i,k,j)=xkmh(i,k,j)
+         xkmv(i,k,j)=min(xkmv(i,k,j), mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt )
+         xkhh(i,k,j)=xkmh(i,k,j)/pr
+         xkhh(i,k,j)=min(xkhh(i,k,j), mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt )
+         xkhv(i,k,j)=xkmv(i,k,j)/pr
+         xkhv(i,k,j)=min(xkhv(i,k,j), mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt )
+      ENDDO
+      ENDDO
+      ENDDO
+   ENDIF
+
+END SUBROUTINE smag_km
+
+!=======================================================================
+!=======================================================================
+
+SUBROUTINE smag2d_km( config_flags,xkmh,xkmv,xkhh,xkhv,                        &
+                    defor11,defor22,defor12,                                   &
+                    rdzw,dx,dy,msftx, msfty,                                   &
+                    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, &
+                                                                         xkmv, &
+                                                                         xkhh, &
+                                                                         xkhv
+
+   REAL , DIMENSION( ims:ime , kms:kme, jms:jme ),  INTENT(IN   )      ::      &    
+                                                                      defor11, &
+                                                                      defor22, &
+                                                                      defor12
+
+   REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN   ) ::                msftx, &
+                                                                        msfty
+! LOCAL VARS
+
+   INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k
+   REAL    :: deltas, tmp, pr, mlen_h, c_s
+
+   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
+   c_s = config_flags%c_s
+
+   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
+!
+      DO j = j_start, j_end
+      DO k = kts, ktf
+      DO i = i_start, i_end
+         mlen_h=sqrt(dx/msftx(i,j) * dy/msfty(i,j))
+         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 )
+         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, xkmv, xkhh, xkhv,         &
+                       bn2, tke, p8w, t8w, theta,                    &
+                       rdz, rdzw, dx,dy, dt, isotropic,              &
+                       mix_upper_bound, msftx, msfty,                &
+                       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
+
+    INTEGER, INTENT( IN )  :: isotropic
+    REAL, INTENT( IN )  &
+    :: dx, dy, dt
+
+    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, xkmv, xkhh, xkhv
+
+    REAL, INTENT( IN )  &
+    :: mix_upper_bound
+
+   REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN   ) ::     msftx, &
+                                                             msfty
+! 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, c_k
+
+    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.
+
+    c_k = config_flags%c_k
+    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
+
+    IF ( isotropic .EQ. 0 ) THEN
+      DO j = j_start, j_end
+      DO k = kts, ktf
+      DO i = i_start, i_end
+        mlen_h = SQRT( dx/msftx(i,j) * dy/msfty(i,j) )
+        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), mix_upper_bound * mlen_h *mlen_h / dt )
+        xkmv(i,k,j)  = MAX( c_k * tmp * mlen_v, 1.0E-6 * deltas * deltas )
+        xkmv(i,k,j)  = MIN( xkmv(i,k,j), mix_upper_bound * deltas *deltas / dt )
+        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, msftx, msfty,           &
+                         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/msftx(i,j) * dy/msfty(i,j) / rdzw(i,k,j) )**0.33333333
+        xkmh(i,k,j)  = c_k * tmp * l_scale(i,k,j)
+        xkmh(i,k,j)  = MIN( mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt,  xkmh(i,k,j) )
+        xkmv(i,k,j)  = c_k * tmp * l_scale(i,k,j)
+        xkmv(i,k,j)  = MIN( mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt ,  xkmv(i,k,j) )
+        pr_inv       = 1.0 + 2.0 * l_scale(i,k,j) / deltas
+        xkhh(i,k,j)  = MIN( mix_upper_bound * dx/msftx(i,j) * dy/msfty(i,j) / dt, xkmh(i,k,j) * pr_inv )
+        xkhv(i,k,j)  = MIN( mix_upper_bound / rdzw(i,k,j) / rdzw(i,k,j) / dt, 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, msftx, msfty,           &
+                             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
+
+    REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN   ) ::     msftx, &
+                                                              msfty
+! 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/msftx(i,j) * dy/msfty(i,j) / 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,                    &
+                                    tracer_tendf, n_tracer,                    &
+                                    thp, theta, mu, tke, config_flags,         &
+                                    defor11, defor22, defor12,                 &
+                                    defor13, defor23,                          &
+                                    nba_mij, n_nba_mij,                        & !JDM
+                                    div,                                       &
+                                    moist, chem, scalar,tracer,                &
+                                    msfux, msfuy, msfvx, msfvy,                &
+                                    msftx, msfty, 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,n_tracer,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   ) ::   msfux, &
+                                                                    msfuy, &
+                                                                    msfvx, &
+                                                                    msfvy, &
+                                                                    msftx, &
+                                                                    msfty, &
+                                                                      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_tracer),                &
+          INTENT(INOUT) ::                                   tracer_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, n_tracer) ,               &
+          INTENT(IN   ) ::                                         tracer 
+
+   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
+   INTEGER, INTENT(  IN ) :: n_nba_mij !JDM 
+
+   REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) &   !JDM 
+   :: nba_mij
+
+! 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,                  &
+                                   nba_mij, n_nba_mij,                     & !JDM
+                                   tke(ims,kms,jms),                       &
+                                   msfux, msfuy, 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,                  &
+                                   nba_mij, n_nba_mij,                     & !JDM
+                                   tke(ims,kms,jms),                       &
+                                   msfvx, msfvy, 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,                  &
+                                   nba_mij, n_nba_mij,                     & !JDM
+                                   tke(ims,kms,jms),                       &
+                                   msftx, msfty, 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,        &
+                                   msftx, msfty, msfux, msfuy,             &
+                                   msfvx, msfvy, 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),                       &
+                                   msftx, msfty, msfux, msfuy,             &
+                                   msfvx, msfvy, 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),             &
+                                       msftx, msfty, msfux, msfuy,        &
+                                       msfvx, msfvy, 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),           &
+                                     msftx, msfty, msfux, msfuy,       &
+                                     msfvx, msfvy, 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_tracer .ge. PARAM_FIRST_SCALAR) THEN 
+
+      tracer_loop: do ic = PARAM_FIRST_SCALAR, n_tracer
+
+        CALL horizontal_diffusion_s( tracer_tendf(ims,kms,jms,ic),     &
+                                     mu, config_flags,                 &
+                                     tracer(ims,kms,jms,ic),           &
+                                     msftx, msfty, msfux, msfuy,       &
+                                     msfvx, msfvy, 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 tracer_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),           &
+                                     msftx, msfty, msfux, msfuy,       &
+                                     msfvx, msfvy, 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,               &
+                                     nba_mij, n_nba_mij,                  & !JDM
+                                     tke,                                 &
+                                     msfux, msfuy,                        &
+                                     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   ) ::  msfux, &
+                                                                   msfuy, &
+                                                                      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
+
+   INTEGER, INTENT(  IN ) :: n_nba_mij !JDM
+
+   REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij),  INTENT(INOUT) &  !JDM     
+   :: nba_mij
+
+   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,          &
+                            nba_mij(ims,kms,jms,P_m11),      & !JDM
+                            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,               &
+                         nba_mij(ims,kms,jms,P_m12),      & !JDM
+                         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=msfux(i,j)*rdx
+      mrdy=msfuy(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  ))-                       &
+            msfuy(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,               &
+                                     nba_mij, n_nba_mij,                  & !JDM
+                                     tke,                                 &
+                                     msfvx, msfvy,                        &
+                                     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   ) ::  msfvx, &
+                                                                   msfvy, &
+                                                                      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
+
+   INTEGER,  INTENT(  IN ) :: n_nba_mij !JDM
+
+   REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij),  INTENT(INOUT) &  !JDM     
+   :: nba_mij
+
+   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,             &
+                         nba_mij(ims,kms,jms,P_m12),    & !JDM
+                         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,         &
+                            nba_mij(ims,kms,jms,P_m22),     & !JDM
+                            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=msfvx(i,j)*rdx
+      mrdy=msfvy(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  ))-                       &
+           msfvy(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,               &
+                                     nba_mij, n_nba_mij,                  & !JDM
+                                     tke,                                 &
+                                     msftx, msfty,                        &
+                                     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   ) ::  msftx, &
+                                                                   msfty, &
+                                                                      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
+
+   INTEGER,  INTENT(  IN ) :: n_nba_mij !JDM
+
+   REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij),  INTENT(INOUT) &   !JDM    
+   :: nba_mij
+
+   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,   &
+                         nba_mij(ims,kms,jms,P_m13),      & !JDM
+                         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,   &
+                         nba_mij(ims,kms,jms,P_m23),      & !JDM
+                         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,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=msftx(i,j)*rdx
+      mrdy=msfty(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))-                      &
+           msfty(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,       &
+                                   msftx, msfty, msfux, msfuy,            &
+                                   msfvx, msfvy, xkhh, rdx, rdy,          &
+                                   fnm, fnp, cf1, cf2, cf3,               &
+                                   zx, zy, rdz, rdzw, dnw, dn,            &
+                                   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   ) ::   msfux
+   REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::   msfuy
+   REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::   msfvx
+   REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::   msfvy
+   REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::   msftx
+   REAL , DIMENSION( ims:ime, jms:jme) ,         INTENT(IN   ) ::   msfty
+
+   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, rdzu, rdzv
+   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))
+      rdzu = 2./(1./rdzw(i,k,j) + 1./rdzw(i-1,k,j))
+      H1(i,k,j)=-msfuy(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))*rdzu )
+
+!      tmpzeta_z = 0.5*(zeta_z(i,j)+zeta_z(i-1,j))
+!      H1(i,k,j)=-msfuy(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))
+      rdzv = 2./(1./rdzw(i,k,j) + 1./rdzw(i,k,j-1))
+      H2(i,k,j)=-msfvy(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))*rdzv)
+
+!      tmpzeta_z = 0.5*(zeta_z(i,j)+zeta_z(i,j-1))
+!      H2(i,k,j)=-msfvy(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=msftx(i,j)*rdx
+      mrdy=msfty(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  ))-     &
+           msfty(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,                   &
+                                    tracer_tendf, n_tracer,                   &
+                                    u_2, v_2,                                 &
+                                    thp,u_base,v_base,t_base,qv_base,mu,tke,  &
+                                    config_flags,defor13,defor23,defor33,     &
+                                    nba_mij, n_nba_mij,                       & !JDM
+                                    div,                                      &
+                                    moist,chem,scalar,tracer,xkmv,xkhv,km_opt,&
+                                    fnm, fnp, dn, dnw, rdz, rdzw,             &
+                                    hfx, qfx, ust, rho,                       &
+                                    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,n_tracer,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_tracer) ,               &
+          INTENT(INOUT) ::                                   tracer_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, n_tracer) ,               &
+          INTENT(IN   ) ::                                         tracer
+
+   REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   ) ::defor13, &
+                                                                 defor23, &
+                                                                 defor33, &
+                                                                     div, &
+                                                                    xkmv, &
+                                                                    xkhv, &
+                                                                     tke, &
+                                                                     rdz, &
+                                                                     u_2, &
+                                                                     v_2, &
+                                                                    rdzw
+
+   INTEGER, INTENT(  IN ) :: n_nba_mij !JDM
+
+   REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) &  !JDM     
+   :: nba_mij
+
+   REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN   )   :: rho  
+   REAL , DIMENSION( ims:ime, jms:jme), INTENT(INOUT)            :: hfx,  &
+                                                                    qfx
+   REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN   )            :: ust
+   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 :: V0_u,V0_v,tao_xz,tao_yz,ustar,cd0
+    REAL :: xsfc,psi1,vk2,zrough,lnz
+    REAL :: heat_flux, moist_flux, heat_flux0
+    REAL :: cpm
+!
+!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,                 &
+                                   nba_mij, n_nba_mij,            & !JDM
+                                   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,                 &
+                                   nba_mij, n_nba_mij,            & !JDM
+                                   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),     &
+                                   nba_mij, n_nba_mij,            & !JDM
+                                   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
+!
+  vflux: SELECT CASE( config_flags%isfflx )
+  CASE (0) ! Assume cd a constant, specified in namelist
+    cd0 = config_flags%tke_drag_coefficient  ! constant drag coefficient
+                                             ! set in namelist.input
+!
+!calcolo del modulo della velocita
+    DO j = j_start, j_end
+    DO i = i_start, ite
+       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=cd0*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, jte
+    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=cd0*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
+
+  CASE (1,2) ! ustar computed from surface routine
+    DO j = j_start, j_end
+    DO i = i_start, ite
+       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
+       ustar=0.5*(ust(i,j)+ust(i-1,j))
+       tao_xz=ustar*ustar*u_2(i,kts,j)/V0_u
+       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, jte
+    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
+       ustar=0.5*(ust(i,j)+ust(i,j-1))
+       tao_yz=ustar*ustar*v_2(i,kts,j)/V0_v
+       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
+
+  CASE DEFAULT
+    CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
+  END SELECT vflux
+
+!
+!  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
+!
+!
+  hflux: SELECT CASE( config_flags%isfflx )
+  CASE (0,2) ! with fixed surface heat flux given in the namelist
+    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
+       cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV)) 
+       hfx(i,j)=heat_flux*cp*rho(i,1,j)         ! provided for output only
+       rt_tendf(i,kts,j)=rt_tendf(i,kts,j)  &
+            +mu(i,j)*heat_flux*rdzw(i,kts,j)
+    ENDDO
+    ENDDO
+
+  CASE (1) ! use surface heat flux computed from surface routine
+    DO j = j_start, j_end
+    DO i = i_start, i_end
+
+       cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV))
+       heat_flux = hfx(i,j)/cpm/rho(i,1,j)
+       rt_tendf(i,kts,j)=rt_tendf(i,kts,j)  &
+            +mu(i,j)*heat_flux*rdzw(i,kts,j)
+
+    ENDDO
+    ENDDO
+
+  CASE DEFAULT
+    CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
+  END SELECT hflux
+
+!
+! 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        )
+
+!*****************************************
+!*****************************************
+!MODIFICATIONS for water vapor flux
+!
+!
+  qflux: SELECT CASE( config_flags%isfflx )
+  CASE (0)
+! do nothing
+  CASE (1,2) ! with surface moisture flux 
+    IF ( im == P_QV ) THEN
+       DO j = j_start, j_end
+       DO i = i_start, i_end
+          moist_flux = qfx(i,j)/rho(i,1,j)/(1.+moist(i,kts,j,P_QV))
+          moist_tendf(i,kts,j,im)=moist_tendf(i,kts,j,im)  &
+               +mu(i,j)*moist_flux*rdzw(i,kts,j)
+       ENDDO
+       ENDDO
+    ENDIF
+
+  CASE DEFAULT
+    CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
+  END SELECT qflux
+!
+! END MODIFICATIONS for water vapor flux
+!*****************************************
+!*****************************************
+     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_tracer .ge. PARAM_FIRST_SCALAR) THEN 
+
+     tracer_loop: do im = PARAM_FIRST_SCALAR, n_tracer
+
+          CALL vertical_diffusion_s( tracer_tendf(ims,kms,jms,im),         &
+                                     config_flags, tracer(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 tracer_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,                         &
+                                   nba_mij, n_nba_mij,                    & !JDM
+                                   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
+
+   INTEGER, INTENT(  IN ) :: n_nba_mij !JDM
+
+   REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) &   !JDM    
+   :: nba_mij
+
+   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,   &
+                         nba_mij(ims,kms,jms,P_m13),      & !JDM
+                         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,                         &
+                                   nba_mij, n_nba_mij,                    & !JDM
+                                   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
+
+   INTEGER, INTENT(  IN ) :: n_nba_mij !JDM
+
+   REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij),  INTENT(INOUT) &     !JDM  
+   :: nba_mij
+
+   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,   &
+                         nba_mij(ims,kms,jms,P_m23),      & !JDM
+                         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,                             &
+                                nba_mij, n_nba_mij,                       & !JDM
+                                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
+
+   INTEGER, INTENT(  IN ) :: n_nba_mij !JDM  
+
+   REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij),  INTENT(INOUT) &   !JDM      
+   :: nba_mij
+
+   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,          &
+                            nba_mij(ims,kms,jms,P_m33),      & !JDM
+                            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,              &
+                                   mtau,                             & !JDM
+                                   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, kms:kme, jms:jme ), INTENT( INOUT )  &  !JDM
+    :: mtau                            
+
+    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%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES
+
+      DO j = j_start, j_end
+      DO k = kts, ktf
+      DO i = i_start, i_end
+
+        titau(i,k,j) = mu(i,j) * mtau(i,k,j)
+
+      END DO
+      END DO
+      END DO  
+
+    ELSE !NOT NBA 
+
+      IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT
+
+        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)
+          mtau(i,k,j) = - xkx(i,k,j) * defor(i,k,j) 
+ 
+        END DO
+        END DO
+        END DO
+
+      ELSE !NO STRESS OUTPUT 
+
+        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
+
+      ENDIF 
+
+    ENDIF 
+
+    END SUBROUTINE cal_titau_11_22_33
+
+!=======================================================================
+!=======================================================================
+
+    SUBROUTINE cal_titau_12_21( config_flags, titau,             &
+                                mu, xkx, defor,                  &
+                                mtau,                            & !JDM
+                                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, kms:kme, jms:jme ), INTENT( INOUT )  & !JDM
+    :: mtau                              
+
+    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
+
+    IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES
+ 
+      DO j = j_start, j_end
+      DO k = kts, ktf
+      DO i = i_start, i_end
+
+        titau(i,k,j) = muavg(i,j)  * mtau(i,k,j) 
+
+      END DO
+      END DO
+      END DO
+
+    ELSE ! NOT NBA
+  
+      IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT
+
+        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)
+          mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) 
+
+        END DO
+        END DO
+        END DO
+
+      ELSE ! NO STRESS OUTPUT
+
+        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
+
+      ENDIF
+
+    ENDIF 
+
+    END SUBROUTINE cal_titau_12_21
+
+!=======================================================================
+
+    SUBROUTINE cal_titau_13_31( config_flags, titau,             &
+                                defor,                           & 
+                                mtau,                            & !JDM
+                                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, kms:kme, jms:jme ), INTENT( INOUT )  & !JDM
+    :: mtau                                      
+
+    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
+
+    IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES
+ 
+      DO j = j_start, j_end
+      DO k = kts+1, ktf
+      DO i = i_start, i_end
+         titau(i,k,j) = muavg(i,j) * mtau(i,k,j) 
+      ENDDO
+      ENDDO
+      ENDDO
+
+    ELSE ! NOT NBA
+ 
+      IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT
+
+        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)
+          mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j)
+ 
+        ENDDO
+        ENDDO
+        ENDDO
+
+      ELSE ! NO STRESS OUTPUT
+
+        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
+
+      ENDIF  
+
+    ENDIF 
+
+    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,      &
+                                mtau,                            & !JDM 
+                                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, kms:kme, jms:jme ), INTENT( INOUT )  & !JDM
+    :: mtau                                             
+
+    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
+ 
+    IF ( config_flags%sfs_opt .EQ. 1 ) THEN ! USE NBA MODEL SFS STRESSES
+
+      DO j = j_start, j_end
+      DO k = kts+1, ktf
+      DO i = i_start, i_end
+
+        titau(i,k,j) = muavg(i,j) * mtau(i,k,j)
+
+      END DO
+      END DO
+      END DO
+
+    ELSE ! NOT NBA
+
+      IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT
+
+        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)
+          mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) 
+
+        END DO
+        END DO
+        END DO
+
+      ELSE ! NO STRESS OUTPUT
+
+        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
+
+      ENDIF 
+
+    ENDIF 
+
+    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,xkmv,xkhh,xkhv,tke,       &
+                    RUBLTEN, RVBLTEN,                                      &
+                    RUCUTEN, RVCUTEN,                                      &
+                    RUSHTEN, RVSHTEN,                                      &
+                    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, &
+                                                                 RUCUTEN, &
+                                                                 RVCUTEN, &
+                                                                 RUSHTEN, &
+                                                                 RVSHTEN, &
+                                                                 defor11, &
+                                                                 defor22, &
+                                                                 defor33, &
+                                                                 defor12, &
+                                                                 defor13, &
+                                                                 defor23, &
+                                                                    xkmh, &
+                                                                    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
+
+   IF(config_flags%cu_physics .GT. 0) THEN
+
+        CALL set_physical_bc3d( RUCUTEN , '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( RVCUTEN , '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
+
+   IF(config_flags%shcu_physics .GT. 0) THEN
+
+        CALL set_physical_bc3d( RUSHTEN , '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( RVSHTEN , '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; horiz coeffs needed for 
+   ! all diff_opt cases.  JM
+
+   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( 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              )
+
+   IF(config_flags%diff_opt .eq. 2) THEN
+
+   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( 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( 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, msftx, msfty,            &
+                        xkmh, xkmv, xkhv,                       &
+                        rdx, rdy, dx, dy, dt, zx, zy,           &
+                        rdz, rdzw, dn, dnw, isotropic,          &
+                        hfx, qfx, qv, ust, rho,                 &
+                        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 )  :: isotropic
+    REAL, INTENT( IN )  &
+    :: cf1, cf2, cf3, dt, rdx, rdy, dx, dy
+
+    REAL, DIMENSION( kms:kme ), INTENT( IN )  &
+    :: fnm, fnp, dnw, dn
+
+    REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN )  &
+    :: msftx, msfty
+
+    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
+
+    REAL, DIMENSION ( ims:ime, jms:jme ), INTENT( IN )   &
+    :: hfx, ust, qfx
+    REAL, DIMENSION ( ims:ime, kms:kme, jms:jme ), INTENT ( IN ) &
+    :: qv, rho
+
+! 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, ust, mu, fnm, fnp,       &
+                       cf1, cf2, cf3, msftx, msfty,           &
+                       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,             &
+                       hfx, qfx, qv,  rho,                    &
+                       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, isotropic,           &
+                       msftx, msfty,                          &
+                       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,     &
+                             hfx, qfx, qv,  rho,            &
+                             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
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT ( IN ) &
+    :: qv, rho
+
+    REAL, DIMENSION(ims:ime, jms:jme ), INTENT ( IN ) :: hfx, qfx
+ 
+! Local variables.
+
+    INTEGER  &
+    :: i, j, k, ktf
+
+    INTEGER  &
+    :: i_start, i_end, j_start, j_end
+
+    REAL :: heat_flux, heat_flux0
+
+    REAL :: cpm
+
+! 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
+
+  hflux: SELECT CASE( config_flags%isfflx )
+  CASE (0,2) ! with fixed surface heat flux given in the namelist
+   heat_flux0 = config_flags%tke_heat_flux  ! constant heat flux value
+                                            ! set in namelist.input
+! LES mods
+   K=KTS
+   DO j = j_start, j_end
+   DO i = i_start, i_end 
+      heat_flux = heat_flux0 
+      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   
+
+  CASE (1) ! use surface heat flux computed from surface routine
+   K=KTS
+   DO j = j_start, j_end
+   DO i = i_start, i_end 
+      cpm = cp * (1. + 0.8*qv(i,k,j))
+      heat_flux = (hfx(i,j)/cpm)/rho(i,k,j)
+
+      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   
+
+  CASE DEFAULT
+    CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
+  END SELECT hflux
+
+! 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, isotropic,      &
+                           msftx, msfty,                      &
+                           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
+
+    INTEGER, INTENT( IN )  :: isotropic
+    REAL, INTENT( IN )  &
+    :: dx, dy
+ 
+    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
+
+    REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN )  &
+    :: msftx, msfty
+! 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, ce1, ce2, c_k
+
+! End declarations.
+!-----------------------------------------------------------------------
+    c_k = config_flags%c_k
+
+    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 )
+
+      CALL calc_l_scale( config_flags, tke, BN2, l_scale,      &
+                         i_start, i_end, ktf, j_start, j_end,  &
+                         dx, dy, rdzw, msftx, msfty,           &
+                         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/msftx(i,j) * dy/msfty(i,j) / 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. 
+! For LES with fine grid, no need for this wall effect!
+
+        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
+
+    END SUBROUTINE tke_dissip
+
+!=======================================================================
+!=======================================================================
+
+    SUBROUTINE tke_shear( tendency, config_flags,                &
+                          defor11, defor22, defor33,             &
+                          defor12, defor13, defor23,             &
+                          u, v, w, tke, ust, mu, fnm, fnp,       &
+                          cf1, cf2, cf3, msftx, msfty,           &
+                          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
+! msftx
+! msfty
+! 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 )  &
+    :: msftx, msfty
+
+    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
+
+    REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN )  &
+    :: ust
+
+! 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, Cd
+
+! 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
+
+  uflux: SELECT CASE( config_flags%isfflx )
+  CASE (0) ! Assume cd a constant, specified in namelist
+
+    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)
+      Cd = cd0
+      tendency(i,k,j) = tendency(i,k,j) +       &
+           mu(i,j)*( (u(i,k,j)+u(i+1,k,j))*0.5* &
+                     Cd*absU*(defor13(i,kts+1,j)+defor13(i+1,kts+1,j))*0.5 )
+
+    END DO
+    END DO
+
+  CASE (1,2) ! ustar computed from surface routine
+
+    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)+epsilon
+      Cd = (ust(i,j)**2)/(absU**2)
+      tendency(i,k,j) = tendency(i,k,j) +       &
+           mu(i,j)*( (u(i,k,j)+u(i+1,k,j))*0.5* &
+                     Cd*absU*(defor13(i,kts+1,j)+defor13(i+1,kts+1,j))*0.5 )
+
+    END DO
+    END DO
+
+  CASE DEFAULT
+    CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
+  END SELECT uflux
+! 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
+
+  vflux: SELECT CASE( config_flags%isfflx )
+  CASE (0) ! Assume cd a constant, specified in namelist
+
+    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)
+      Cd = cd0
+      tendency(i,k,j) = tendency(i,k,j) +       &
+           mu(i,j)*( (v(i,k,j)+v(i,k,j+1))*0.5* &
+                     Cd*absU*(defor23(i,kts+1,j)+defor23(i,kts+1,j+1))*0.5 )
+
+    END DO
+    END DO
+
+  CASE (1,2) ! ustar computed from surface routine
+
+    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)+epsilon
+      Cd = (ust(i,j)**2)/(absU**2)
+      tendency(i,k,j) = tendency(i,k,j) +       &
+           mu(i,j)*( (v(i,k,j)+v(i,k,j+1))*0.5* &
+                     Cd*absU*(defor23(i,kts+1,j)+defor23(i,kts+1,j+1))*0.5 )
+
+    END DO
+    END DO
+
+  CASE DEFAULT
+    CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' )
+  END SELECT vflux
+! 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
+
+!=======================================================================
+!=======================================================================
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_em.F	(revision 17)
@@ -0,0 +1,1936 @@
+!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
+   USE module_damping_em
+
+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,                   &
+                           msfux, msfuy,                    &
+                           msfvx, msfvx_inv, msfvy,         &
+                           msftx, msfty,                    &
+                           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   ) :: msftx,     &
+                                                               msfty,     &
+                                                               msfux,     &
+                                                               msfuy,     &
+                                                               msfvx,     &
+                                                               msfvx_inv, &
+                                                               msfvy,     &
+                                                               mu,        &
+                                                               mub
+
+   REAL , DIMENSION( ims:ime , jms:jme ) ,    INTENT(  OUT) :: muu,    &
+                                                               muv,    &
+                                                               mut
+
+   REAL , DIMENSION( kms:kme ) ,    INTENT(IN   ) :: fnm, fnp, dnw
+
+   integer :: k
+
+
+!<DESCRIPTION>
+!
+!  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)
+!
+!</DESCRIPTION>
+
+   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, msfuy,             &
+                         muv, rv, v, msfvx, msfvx_inv,  &
+                         mut, rw, w, msfty,             &
+                         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, msftx, msfty,          &
+                     msfux, msfuy, msfvx, msfvx_inv,  &
+                     msfvy, 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,         &
+                         msfux, msfuy, msfvx, msfvx_inv,                  &
+                         msfvy, msftx, msfty,                             &
+                         clat, f, e, sina, cosa,                          &
+                         fnm, fnp, rdn, rdnw,                             &
+                         dt, rdx, rdy, khdif, kvdif, xkmhd, xkhh,         &
+                         diff_6th_opt, diff_6th_factor,                   &
+                         dampcoef,zdamp,damp_opt,rad_nudge,               &
+                         cf1, cf2, cf3, cfn, cfn1, n_moist,               &
+                         non_hydrostatic, top_lid,                        &
+                         u_frame, v_frame,                                &
+                         ids, ide, jds, jde, kds, kde,                    &
+                         ims, ime, jms, jme, kms, kme,                    &
+                         its, ite, jts, jte, kts, kte,                    &
+                         max_vert_cfl, max_horiz_cfl)
+
+   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, top_lid
+
+   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,   &
+                                                         xkhh,    &
+                                                         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   ) :: msfux,   &
+                                                                    msfuy,   &
+                                                                    msfvx,   &
+                                                                    msfvx_inv,   &
+                                                                    msfvy,   &
+                                                                    msftx,   &
+                                                                    msfty,   &
+                                                                    clat,    & 
+                                                                    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,      &
+                                                                u_frame, &
+                                                                v_frame, &
+                                                                khdif,   &
+                                                                kvdif
+   INTEGER, INTENT( IN ) :: diff_6th_opt
+   REAL,    INTENT( IN ) :: diff_6th_factor
+
+   INTEGER, INTENT( IN ) :: damp_opt, rad_nudge
+
+   REAL, INTENT( IN ) :: zdamp, dampcoef
+
+   REAL, INTENT( OUT ) :: max_horiz_cfl
+   REAL, INTENT( OUT ) :: max_vert_cfl
+
+   REAL    :: kdift, khdq, kvdq, cfn, cfn1, cf1, cf2, cf3
+   INTEGER :: i,j,k
+   INTEGER :: time_step
+
+!<DESCRIPTION>
+!
+!  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.
+!
+!</DESCRIPTION>
+
+   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 nl_get_time_step ( 1, time_step )
+
+   CALL advect_u ( u, u , ru_tend, ru, rv, ww,   &
+                   mut, time_step, config_flags, &
+                   msfux, msfuy, msfvx, msfvy,   &
+                   msftx, msfty,                 &
+                   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, time_step, config_flags, &
+                   msfux, msfuy, msfvx, msfvy,   &
+                   msftx, msfty,                 &
+                   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, time_step, config_flags, &
+                     msfux, msfuy, msfvx, msfvy,   &
+                     msftx, msfty,                 &
+                     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, time_step, config_flags, &
+                          msfux, msfuy, msfvx, msfvy,   &
+                          msftx, msfty, 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  .OR.     &
+          config_flags%cu_physics == G3SCHEME ) THEN
+
+     ! theta advection only:
+
+         CALL set_tend( RTHFTEN, t_tend, msfty,          &
+                        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,         &
+                  msfux, msfuy, msfvx,               &
+                  msfvx_inv, msfvy,                  &
+                  msftx, msfty,                      &
+                  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,msfux,msfuy,&
+                                         msfvx,msfvy,msftx,msfty,        &
+                                         config_flags, non_hydrostatic,  &
+                                         top_lid,                        &
+                                         ids, ide, jds, jde, kds, kde,   &
+                                         ims, ime, jms, jme, kms, kme,   &
+                                         its, ite, jts, jte, kts, kte   )
+
+     IF (non_hydrostatic) THEN
+          CALL pg_buoy_w( rw_tend, p, cqw, mu, mub,       &
+                          rdnw, rdn, g, msftx, msfty,     &
+                          ids, ide, jds, jde, kds, kde,   &
+                          ims, ime, jms, jme, kms, kme,   &
+                          its, ite, jts, jte, kts, kte   )
+     ENDIF
+
+     CALL w_damp   ( rw_tend, max_vert_cfl,            &
+                      max_horiz_cfl,                  &
+                      u, v, ww, w, mut, rdnw,         &
+                      rdx, rdy, msfux, msfuy, msfvx,  &
+                      msfvy, dt, config_flags,        &
+                      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,            &
+                                       msftx, msfty, msfux, msfuy,   &
+                                       msfvx, msfvy,                 &
+                                       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,                 &
+                          msftx, msfty, msfux, msfuy,   &
+                          msfvx, msfvy,                 &
+                          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,                   &
+                       msfux, msfuy, msfvx, msfvy,     &
+                       msftx, msfty,                   &
+                       clat, fnm, fnp, rdx, rdy,       &
+                       ids, ide, jds, jde, kds, kde,   &
+                       ims, ime, jms, jme, kms, kme,   &
+                       its, ite, jts, jte, kts, kte   )
+
+! Damping option added for Held-Suarez test (also uses lw option HELDSUAREZ)
+      IF (config_flags%ra_lw_physics == HELDSUAREZ) THEN
+         CALL held_suarez_damp ( ru_tend, rv_tend,               &   
+                                 ru,rv,p,pb,                     &
+                                 ids, ide, jds, jde, kds, kde,   &
+                                 ims, ime, jms, jme, kms, kme,   &
+                                 its, ite, jts, jte, kts, kte   )
+      END IF
+
+!**************************************************************
+!
+!  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, &
+                                        msfux, msfuy, msfvx, msfvx_inv, &
+                                        msfvy,msftx, msfty,             &
+                                        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, &
+                                        msfux, msfuy, msfvx, msfvx_inv, &
+                                        msfvy,msftx, msfty,             &
+                                        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, &
+                                        msfux, msfuy, msfvx, msfvx_inv, &
+                                        msfvy,msftx, msfty,             &
+                                        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,            &
+                                         msfux, msfuy, msfvx, msfvx_inv,  &
+                                         msfvy, msftx, msfty,             &
+                                         khdq , xkhh, 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   )
+
+    IF( rad_nudge .eq. 1 )                                     &
+       CALL theta_relaxation( t_tendf, t, t_init,              &
+                              mut, ph, phb,                    &
+                              t_base, z_base,                  &
+                              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, msftx, msfty, msfux, msfuy,     &
+                            msfvx, msfvx_inv, msfvy,                         &
+                            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,       &
+                                                                    msftx,     &
+                                                                    msfty,     &
+                                                                    msfux,     &
+                                                                    msfuy,     &
+                                                                    msfvx,     &
+                                                                    msfvx_inv, &
+                                                                    msfvy
+
+
+! Local
+   INTEGER :: i, j, k
+
+!<DESCRIPTION>
+!
+! 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.
+!
+!</DESCRIPTION>
+
+!  Finally, add the forward-step tendency to the rk_tendency
+
+! u/v/w/save contain bc tendency that needs to be multiplied by msf
+! (u by msfuy, v by msfvx)
+!  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 (msfty)
+! 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
+     ! multiply by my to uncouple u
+     IF(rk_step == 1)ru_tendf(i,k,j) = ru_tendf(i,k,j) +  u_save(i,k,j)*msfuy(i,j)
+     ! divide by my to couple u
+     ru_tend(i,k,j) = ru_tend(i,k,j) + ru_tendf(i,k,j)/msfuy(i,j)
+   ENDDO
+   ENDDO
+   ENDDO
+
+   DO j = jts,jte
+   DO k = kts,kte-1
+   DO i = its,MIN(ite,ide-1)
+     ! multiply by mx to uncouple v
+     IF(rk_step == 1)rv_tendf(i,k,j) = rv_tendf(i,k,j) +  v_save(i,k,j)*msfvx(i,j)
+     ! divide by mx to couple v
+     rv_tend(i,k,j) = rv_tend(i,k,j) + rv_tendf(i,k,j)*msfvx_inv(i,j)
+   ENDDO
+   ENDDO
+   ENDDO
+
+   DO j = jts,MIN(jte,jde-1)
+   DO k = kts,kte
+   DO i = its,MIN(ite,ide-1)
+     ! multiply by my to uncouple w
+     IF(rk_step == 1)rw_tendf(i,k,j) = rw_tendf(i,k,j) +  w_save(i,k,j)*msfty(i,j)
+     ! divide by my to couple w
+     rw_tend(i,k,j) = rw_tend(i,k,j) + rw_tendf(i,k,j)/msfty(i,j)
+     IF(rk_step == 1)ph_tendf(i,k,j) = ph_tendf(i,k,j) +  ph_save(i,k,j)
+     ! divide by my to couple scalar
+     ph_tend(i,k,j) = ph_tend(i,k,j) + ph_tendf(i,k,j)/msfty(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)
+     ! divide by my to couple theta
+      t_tend(i,k,j) =  t_tend(i,k,j) +  t_tendf(i,k,j)/msfty(i,j)  &
+                                     +  mut(i,j)*h_diabatic(i,k,j)/msfty(i,j)
+     ! divide by my to couple heating
+   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,          &
+                            tenddec,                        & 
+                            rk_step, dt,                     &
+                            ru, rv, ww, mut, mub, mu_old,    &
+                            alt,                             &
+                            scalar_old, scalar,              &
+                            scalar_tends, advect_tend,       &
+                            h_tendency, z_tendency,          & 
+                            RQVFTEN,                         &
+                            base, moist_step, fnm, fnp,      &
+                            msfux, msfuy, msfvx, msfvx_inv,  &
+                            msfvy, msftx, msfty,             &
+                            rdx, rdy, rdn, rdnw,             &
+                            khdif, kvdif, xkmhd,             &
+                            diff_6th_opt, diff_6th_factor,   &
+                            adv_opt,                         &
+                            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   ) :: tenddec ! tendency term
+
+   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(IN   )  :: 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  ), INTENT(INOUT) :: advect_tend
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme  ), INTENT(  OUT) :: h_tendency, z_tendency 
+
+   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   ) :: msfux,    &
+                                                                  msfuy,    &
+                                                                  msfvx,    &
+                                                                  msfvx_inv,    &
+                                                                  msfvy,    &
+                                                                  msftx,    &
+                                                                  msfty,    &
+                                                                  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
+
+   INTEGER, INTENT(IN   ) :: adv_opt          
+
+   ! Local data
+  
+   INTEGER :: im, i,j,k
+   INTEGER :: time_step
+
+   REAL    :: khdq, kvdq, tendency
+
+!<DESCRIPTION>
+!
+! rk_scalar_tend calls routines that computes scalar tendency from advection 
+! and 3D mixing (TKE or fixed eddy viscosities).
+!
+!</DESCRIPTION>
+
+
+   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 )
+
+     CALL zero_tend ( h_tendency(ims,kms,jms),      &
+                      ids, ide, jds, jde, kds, kde, &
+                      ims, ime, jms, jme, kms, kme, &
+                      its, ite, jts, jte, kts, kte )
+
+     CALL zero_tend ( z_tendency(ims,kms,jms),      &
+                      ids, ide, jds, jde, kds, kde, &
+                      ims, ime, jms, jme, kms, kme, &
+                      its, ite, jts, jte, kts, kte )
+
+     CALL nl_get_time_step ( 1, time_step )
+
+      IF( (rk_step == 3) .and. (adv_opt == POSITIVEDEF) ) THEN
+
+        CALL advect_scalar_pd       ( scalar(ims,kms,jms,im),             &
+                                      scalar_old(ims,kms,jms,im),         &
+                                      advect_tend(ims,kms,jms),           &
+                                      h_tendency(ims,kms,jms),            & 
+                                      z_tendency(ims,kms,jms),            & 
+                                      ru, rv, ww, mut, mub, mu_old,       &
+                                      time_step, config_flags, tenddec,   & 
+                                      msfux, msfuy, msfvx, msfvy,         &
+                                      msftx, msfty, 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 IF( (rk_step == 3) .and. (adv_opt == MONOTONIC) ) THEN
+
+        CALL advect_scalar_mono       ( scalar(ims,kms,jms,im),             &
+                                        scalar_old(ims,kms,jms,im),         &
+                                        advect_tend(ims,kms,jms),           &
+                                        h_tendency(ims,kms,jms),            & 
+                                        z_tendency(ims,kms,jms),            & 
+                                        ru, rv, ww, mut, mub, mu_old,       &
+                                        config_flags, tenddec,              & 
+                                        msfux, msfuy, msfvx, msfvy,         &
+                                        msftx, msfty, 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, time_step,    &
+                                 config_flags,                  &
+                                 msfux, msfuy, msfvx, msfvy,    &
+                                 msftx, msfty, 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 .OR. config_flags%cu_physics == G3SCHEME .OR. &
+         config_flags%cu_physics == KFETASCHEME .OR. &      ! new trigger in KF
+         config_flags%cu_physics == TIEDTKESCHEME  ) &      ! Tiedtke
+                     .and. moist_step .and. ( im == P_QV) ) THEN
+
+        CALL set_tend( RQVFTEN, advect_tend, msfty,    &
+                       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,                      &
+                                        msfux, msfuy, msfvx, msfvx_inv,    &
+                                        msfvy, msftx, msfty,               &
+                                        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,   &
+                             advh_t, advz_t,                & 
+                             advect_tend,                   &
+                             h_tendency, z_tendency,        & 
+                             msftx, msfty,                  &
+                             mu_old, mu_new, mu_base,       &
+                             rk_step, dt, spec_zone,        &
+                             config_flags,                  &
+                             tenddec,                      & 
+                             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   ) :: tenddec 
+
+   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
+
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme , scs:sce),                &
+         INTENT(IN)                                     :: sc_tend
+
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme ),                &
+         INTENT(IN)                                  :: advect_tend
+
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), INTENT(INOUT) , OPTIONAL :: advh_t,  advz_t ! accumulating for output
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), INTENT(IN   ) :: h_tendency, z_tendency ! from rk_scalar_tend
+
+   REAL, DIMENSION(ims:ime, jms:jme  ), INTENT(IN   ) ::  mu_old,  &
+                                                          mu_new,  &
+                                                          mu_base, &
+                                                          msftx,   &
+                                                          msfty
+
+   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
+
+!<DESCRIPTION>
+!
+!  rk_scalar_update advances the scalar equation given the time t value
+!  of the scalar and the scalar tendency.  
+!
+!</DESCRIPTION>
+
+
+!
+!  set loop limits.
+
+      i_start = its
+      i_end   = min(ite,ide-1)
+      j_start = jts
+      j_end   = min(jte,jde-1)
+      k_start = kts
+      k_end   = kte-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
+          ! scalar was coupled with my
+           tendency(i,k,j) = advect_tend(i,k,j) * msfty(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
+           ! scalar was coupled with my
+           tendency(i,k,j) = advect_tend(i,k,j) * msfty(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
+
+      ! This is separated from the k/i-loop above for better performance
+      IF ( PRESENT(advh_t) .AND. PRESENT(advz_t) ) THEN
+        IF(tenddec.and.rk_step.eq.config_flags%rk_ord) THEN
+          DO  k = kts, min(kte,kde-1)
+          DO  i = its, min(ite,ide-1)
+
+            advh_t(i,k,j) = advh_t(i,k,j) + (dt*h_tendency(i,k,j)* msfty(i,j))*r_munew(i)
+            advz_t(i,k,j) = advz_t(i,k,j) + (dt*z_tendency(i,k,j)* msfty(i,j))*r_munew(i)
+
+          ENDDO
+          ENDDO
+        END IF
+      END IF
+      
+      ENDDO
+
+      ENDDO
+
+    END IF
+
+END SUBROUTINE rk_update_scalar
+
+!-------------------------------------------------------------------------------
+
+SUBROUTINE rk_update_scalar_pd( scs, sce,                      &
+                                scalar, sc_tend,               &
+                                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
+
+   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
+
+!<DESCRIPTION>
+!
+!  rk_scalar_update advances the scalar equation given the time t value
+!  of the scalar and the scalar tendency.  
+!
+!</DESCRIPTION>
+
+
+!
+!  set loop limits.
+
+      i_start = its
+      i_end   = min(ite,ide-1)
+      j_start = jts
+      j_end   = min(jte,jde-1)
+      k_start = kts
+      k_end   = kte-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,     &
+                              tracer_tendf,n_tracer,                   &
+                              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,n_tracer,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_tracer ),INTENT(INOUT)::&
+                                                          tracer_tendf
+
+   REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_scalar ),INTENT(INOUT)::&
+                                                          scalar_tendf
+
+! LOCAL VARS
+
+   INTEGER :: im, ic, is
+
+!<DESCRIPTION>
+!
+! init_zero_tendency 
+! sets tendency arrays to zero for all prognostic variables.
+!
+!</DESCRIPTION>
+
+
+   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_tracer
+   DO ic=1,n_tracer                     ! make sure first one is zero too
+      CALL zero_tend ( tracer_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
+
+!<DESCRIPTION
+!
+! quick and dirty debug io utility
+!
+!</DESCRIPTION
+
+is = ids
+ie = ide-1
+js = jds
+je = jde-1
+ks = kds
+ke = kde-1
+
+if(field == 'u') ie = ide
+if(field == 'v') je = jde
+if(field == 'w') ke = kde
+
+write(io_unit) is,ie,ks,ke,js,je
+write(io_unit) a(is:ie, ks:ke, js:je)
+
+end subroutine dump_data
+
+!-----------------------------------------------------------------------
+
+SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d,           &
+                     RTHRATEN,                                         &
+                     RUBLTEN,RVBLTEN,RTHBLTEN,                         &
+                     RQVBLTEN,RQCBLTEN,RQIBLTEN,                       &
+                     RUCUTEN,RVCUTEN,RTHCUTEN,                         &
+                     RQVCUTEN,RQCCUTEN,RQRCUTEN,                       &
+                     RQICUTEN,RQSCUTEN,                                &
+                     RUSHTEN,RVSHTEN,RTHSHTEN,                         &
+                     RQVSHTEN,RQCSHTEN,RQRSHTEN,                       &
+                     RQISHTEN,RQSSHTEN,RQGSHTEN,                       &
+                     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
+
+      REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )               , &
+                INTENT(IN   )   ::                               pi3d
+                                                                 
+      REAL,     DIMENSION( ims:ime, jms:jme )                        , &
+                INTENT(IN   )   ::                                 mu, &
+                                                                  muu, &
+                                                                  muv
+      
+                                                           
+! radiation
+
+      REAL,     DIMENSION( ims:ime, kms:kme, jms:jme ),                &
+                INTENT(INOUT)   ::                           RTHRATEN
+
+! cumulus
+
+      REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+                INTENT(INOUT)   ::                                     &
+                                                              RUCUTEN, &
+                                                              RVCUTEN, &
+                                                             RTHCUTEN, &
+                                                             RQVCUTEN, &
+                                                             RQCCUTEN, &
+                                                             RQRCUTEN, &
+                                                             RQICUTEN, &
+                                                             RQSCUTEN, &
+                                                              RUSHTEN, &
+                                                              RVSHTEN, &
+                                                             RTHSHTEN, &
+                                                             RQVSHTEN, &
+                                                             RQCSHTEN, &
+                                                             RQRSHTEN, &
+                                                             RQISHTEN, &
+                                                             RQSSHTEN, &
+                                                             RQGSHTEN
+
+! pbl
+
+      REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )               , &
+                INTENT(INOUT)   ::                            RUBLTEN, &
+                                                              RVBLTEN, &
+                                                             RTHBLTEN, &
+                                                             RQVBLTEN, &
+                                                             RQCBLTEN, &
+                                                             RQIBLTEN
+
+! fdda
+
+      REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )               , &
+                INTENT(INOUT)   ::                            RUNDGDTEN, &
+                                                              RVNDGDTEN, &
+                                                             RTHNDGDTEN, &
+                                                             RQVNDGDTEN
+      REAL,     DIMENSION( ims:ime, jms:jme )               , &
+                INTENT(INOUT)   ::                           RMUNDGDTEN
+
+      INTEGER :: i,k,j
+      INTEGER :: itf,ktf,jtf,itsu,jtsv
+
+!-----------------------------------------------------------------------
+
+!<DESCRIPTION>
+!
+!  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.
+!
+!</DESCRIPTION>
+
+      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
+         RUCUTEN(I,K,J) =mu(I,J)*RUCUTEN(I,K,J)
+         RVCUTEN(I,K,J) =mu(I,J)*RVCUTEN(I,K,J)
+         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
+
+! shallow cumulus
+
+   IF (config_flags%shcu_physics .gt. 0) THEN
+
+      DO J=jts,jtf
+      DO I=its,itf
+      DO K=kts,ktf
+         RUSHTEN(I,K,J) =mu(I,J)*RUSHTEN(I,K,J)
+         RVSHTEN(I,K,J) =mu(I,J)*RVSHTEN(I,K,J)
+         RTHSHTEN(I,K,J)=mu(I,J)*RTHSHTEN(I,K,J)
+         RQVSHTEN(I,K,J)=mu(I,J)*RQVSHTEN(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
+            RQCSHTEN(I,K,J)=mu(I,J)*RQCSHTEN(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
+            RQRSHTEN(I,K,J)=mu(I,J)*RQRSHTEN(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
+            RQISHTEN(I,K,J)=mu(I,J)*RQISHTEN(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
+            RQSSHTEN(I,K,J)=mu(I,J)*RQSSHTEN(I,K,J)
+         ENDDO
+         ENDDO
+         ENDDO
+      ENDIF
+
+      IF(P_QG .ge. PARAM_FIRST_SCALAR)THEN
+         DO J=jts,jtf
+         DO I=its,itf
+         DO K=kts,ktf
+            RQGSHTEN(I,K,J)=mu(I,J)*RQGSHTEN(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
+
+!<DESCRIPTION>
+!
+! debug and testing code for bounding a variable
+!
+!</DESCRIPTION>
+
+  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
+
+!<DESCRIPTION>
+!
+! bounds tke between zero and tke_upper_bound.
+!
+!</DESCRIPTION>
+
+  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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_first_rk_step_part1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_first_rk_step_part1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_first_rk_step_part1.F	(revision 17)
@@ -0,0 +1,1138 @@
+!WRF:MEDIATION_LAYER:SOLVER
+
+#define BENCH_START(A)
+#define BENCH_END(A)
+
+MODULE module_first_rk_step_part1
+
+CONTAINS
+
+  SUBROUTINE first_rk_step_part1 (   grid , config_flags              &
+                             , moist , moist_tend               &
+                             , chem  , chem_tend                &
+                             , tracer, tracer_tend              &
+                             , scalar , scalar_tend             &
+                             , fdda3d, fdda2d                   &
+                             , ru_tendf, rv_tendf               &
+                             , rw_tendf, t_tendf                &
+                             , ph_tendf, mu_tendf               &
+                             , tke_tend                         &
+                             , adapt_step_flag , curr_secs      &
+                             , psim , psih , wspd , gz1oz0 , br , chklowq &
+                             , cu_act_flag , hol , th_phy        &
+                             , pi_phy , p_phy , t_phy , u_phy , v_phy     &
+                             , dz8w , p8w , t8w , rho_phy , rho           &
+                             , 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    &
+                             , k_start , k_end                  &
+                             , f_flux                           &
+                            )
+    USE module_state_description
+    USE module_model_constants
+    USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_subgrid
+    USE module_configure, ONLY : grid_config_rec_type, model_config_rec
+    USE module_radiation_driver, ONLY : pre_radiation_driver, radiation_driver
+    USE module_surface_driver, ONLY : surface_driver
+    USE module_cumulus_driver, ONLY : cumulus_driver
+    USE module_shallowcu_driver, ONLY : shallowcu_driver
+    USE module_pbl_driver, ONLY : pbl_driver
+    USE module_fr_sfire_driver_wrf, ONLY : sfire_driver_em_step
+    USE module_fddagd_driver, ONLY : fddagd_driver
+    USE module_em, ONLY : init_zero_tendency
+    USE module_force_scm
+    USE module_convtrans_prep
+    USE module_big_step_utilities_em, ONLY : phy_prep
+use module_scalar_tables
+#ifdef DM_PARALLEL
+    USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, wrf_dm_maxval
+    USE module_comm_dm, ONLY : halo_em_phys_a_sub,halo_em_fdda_sfc_sub
+#endif
+    USE module_utility
+    IMPLICIT NONE
+
+    TYPE ( domain ), INTENT(INOUT) :: grid
+    TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags
+    TYPE(WRFU_Time)                :: currentTime
+
+    INTEGER, INTENT(IN) :: 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
+
+
+    LOGICAL ,INTENT(IN)                        :: adapt_step_flag
+    REAL, INTENT(IN)                           :: curr_secs
+
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_moist),INTENT(INOUT)   :: moist
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_moist),INTENT(INOUT)   :: moist_tend
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_chem),INTENT(INOUT)   :: chem
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_chem),INTENT(INOUT)   :: chem_tend
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer),INTENT(INOUT)   :: tracer
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer),INTENT(INOUT)   :: tracer_tend
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT)   :: scalar
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT)   :: scalar_tend
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_fdda3d),INTENT(INOUT)  :: fdda3d
+    REAL    ,DIMENSION(ims:ime,1:1,jms:jme,num_fdda2d),INTENT(INOUT)      :: fdda2d
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: psim
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: psih
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: wspd
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: gz1oz0
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: br
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: chklowq
+    LOGICAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: cu_act_flag
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: hol
+
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: th_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: pi_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: p_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: u_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: v_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: dz8w
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: p8w
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t8w
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rho_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rho
+
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: ru_tendf
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rv_tendf
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rw_tendf
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: ph_tendf
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t_tendf
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: tke_tend
+
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: mu_tendf
+
+    INTEGER, INTENT(IN)                           ::  k_start, k_end
+    LOGICAL, INTENT(IN), OPTIONAL                 ::  f_flux
+
+! Local
+    REAL, DIMENSION( ims:ime, jms:jme ) :: exch_temf  ! 1/7/09 WA
+
+    REAL, DIMENSION( ims:ime, jms:jme ) :: ht_loc, mixht
+    INTEGER                             :: ij
+    INTEGER  num_roof_layers
+    INTEGER  num_wall_layers
+    INTEGER  num_road_layers
+    INTEGER  iswater
+    LOGICAL  :: l_flux
+    INTEGER  :: isurban
+    INTEGER  rk_step
+    INTEGER                         :: yr, month, day, hr, minute, sec, rc
+    CHARACTER*80                    :: mesg
+
+   INTEGER                         :: sids , side , sjds , sjde , skds , skde , &
+                                      sims , sime , sjms , sjme , skms , skme , &
+                                      sips , sipe , sjps , sjpe , skps , skpe
+
+   CHARACTER (LEN=256) :: mminlu
+
+#if ( WRF_DFI_RADAR == 1 )
+    INTEGER  do_capsupress   ! =1 do CAP supress, other = don't
+#endif
+
+#ifdef LMDZ1
+   CHARACTER*256                              :: message
+   INTEGER                                    :: im2, jm2, km2
+   INTEGER                                    :: ix,iy,iz
+   CHARACTER(LEN=50)                          :: errmsg
+
+   errmsg = 'ERROR -- error -- ERROR -- error'
+
+   im2 = config_flags%i_check_point
+   jm2 = config_flags%j_check_point
+   km2 = config_flags%k_check_point
+#endif
+
+#ifdef LMDZ1
+   WRITE(message, *)'  module_first_rk_step_part1: inside' 
+   CALL wrf_debug(200, message)
+   WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+     ' u_tend: ', ru_tendf(im2,1,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+     'p sfc: ',p8w(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)'  Lluis checking variables k t u v p ph alt _________________'
+   CALL wrf_debug(200, message)
+   DO iz=kms,kme
+     PRINT *,iz, grid%t_2(im2,iz,jm2), grid%u_2(im2,iz,jm2), grid%v_2(im2,iz,jm2),    &
+       grid%p(im2,iz,jm2), grid%ph_2(im2,iz,jm2), grid%alt(im2,iz,jm2)
+   END DO
+#endif
+
+  CALL get_ijk_from_subgrid (  grid ,                   &
+                            sids, side, sjds, sjde, skds, skde,    &
+                            sims, sime, sjms, sjme, skms, skme,    &
+                            sips, sipe, sjps, sjpe, skps, skpe    )
+
+ ! initialize all tendencies to zero in order to update physics
+ ! tendencies first (separate from dry dynamics).
+
+   l_flux=.FALSE.
+   if (present(f_flux)) l_flux=f_flux
+
+    rk_step = 1
+
+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, &
+                                   tracer_tend,num_tracer,           &
+                                   num_moist,num_chem,num_scalar,    &
+                                   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
+
+      !$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%mut, grid%muu, grid%muv, grid%u_2,          &
+                        grid%v_2, grid%p, grid%pb, grid%alt,             &
+                        grid%ph_2, grid%phb, grid%t_2, grid%tsk, moist, num_moist,   &
+                        rho,th_phy, p_phy, pi_phy, u_phy, v_phy,         &
+                        p8w, t_phy, t8w, grid%z, grid%z_at_w, dz8w,      &
+                        grid%p_hyd, grid%p_hyd_w,                        &
+                        grid%fnm, grid%fnp, grid%znw, grid%p_top,        &
+                        grid%rthraten,                                   &
+                        grid%rthblten, grid%rublten, grid%rvblten,       &
+                        grid%rqvblten, grid%rqcblten, grid%rqiblten,     &
+                        grid%rucuten,  grid%rvcuten,  grid%rthcuten,     &
+                        grid%rqvcuten, grid%rqccuten, grid%rqrcuten,     &
+                        grid%rqicuten, grid%rqscuten,                    &
+                        grid%rushten,  grid%rvshten,  grid%rthshten,     &
+                        grid%rqvshten, grid%rqcshten, grid%rqrshten,     &
+                        grid%rqishten, grid%rqsshten, grid%rqgshten,     &
+                        grid%rthften,  grid%rqvften,                     &
+                        grid%RUNDGDTEN, grid%RVNDGDTEN, grid%RTHNDGDTEN, &
+                        grid%RPHNDGDTEN,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)
+#ifdef LMDZ1
+   WRITE(message, *)'  module_first_rk_step_part1: after phy_prep' 
+   CALL wrf_debug(200, message)
+   WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+     ' u_tend: ', ru_tendf(im2,1,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+     'p sfc: ',p8w(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+#endif
+
+! radiation
+     CALL domain_clock_get( grid, current_time=currentTime, &
+                            current_timestr=mesg )
+     CALL WRFU_TimeGet( currentTime, YY=yr, dayOfYear=day, H=hr, M=minute, S=sec, rc=rc)
+         IF( rc/= WRFU_SUCCESS)THEN
+         CALL wrf_error_fatal('WRFU_TimeGet failed')
+         ENDIF
+
+! this driver is only needed to handle non-local shadowing effects
+      CALL pre_radiation_driver ( grid, config_flags                        &
+     &        ,itimestep=grid%itimestep, ra_call_offset=grid%ra_call_offset    &
+     &        ,XLAT=grid%xlat, XLONG=grid%xlong, GMT=grid%gmt                  &
+     &        ,julian=grid%julian, xtime=grid%xtime, RADT=grid%radt            &
+     &        ,STEPRA=grid%stepra                                              &
+     &        ,ht=grid%ht,dx=grid%dx,dy=grid%dy,sina=grid%sina,cosa=grid%cosa  &
+     &        ,shadowmask=grid%shadowmask,slope_rad=config_flags%slope_rad     &
+     &        ,topo_shading=config_flags%topo_shading                          &
+     &        ,shadlen=config_flags%shadlen,ht_shad=grid%ht_shad,ht_loc=ht_loc &
+     &        ,ht_shad_bxs=grid%ht_shad_bxs, ht_shad_bxe=grid%ht_shad_bxe      &
+     &        ,ht_shad_bys=grid%ht_shad_bys, ht_shad_bye=grid%ht_shad_bye      &
+     &        ,nested=config_flags%nested, min_ptchsz=grid%min_ptchsz          &
+     &        ,spec_bdy_width=config_flags%spec_bdy_width                      &
+            ! 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          &
+     &        ,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                                   )
+
+      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=grid%p_hyd_w        ,P=grid%p_hyd            ,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=grid%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        ,YR=yr               &
+!Optional solar variables
+     &        ,DECLINX=grid%declin ,SOLCONX=grid%solcon ,COSZEN=grid%coszen ,HRANG=grid%hrang    &
+     &        , CEN_LAT=grid%cen_lat                                      &
+     &        ,Z=grid%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                                                &
+              ,CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag       &
+            ! 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
+!JJS 20101020 vvvvv
+     &        , TLWDN=grid%tlwdn, TLWUP=grid%tlwup                        & ! goddard schemes
+     &        , SLWDN=grid%slwdn, SLWUP=grid%slwup                        & ! goddard schemes
+     &        , TSWDN=grid%tswdn, TSWUP=grid%tswup                        & ! goddard schemes
+     &        , SSWDN=grid%sswdn, SSWUP=grid%sswup                        & ! goddard schemes
+!JJS 20101020 ^^^^^
+
+     &        , CLDFRA=grid%cldfra                                        &
+     &        , PB=grid%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    &
+     &        ,ACSWUPT=grid%acswupt    ,ACSWUPTC=grid%acswuptc            &
+     &        ,ACSWDNT=grid%acswdnt    ,ACSWDNTC=grid%acswdntc            &
+     &        ,ACSWUPB=grid%acswupb    ,ACSWUPBC=grid%acswupbc            &
+     &        ,ACSWDNB=grid%acswdnb    ,ACSWDNBC=grid%acswdnbc            &
+     &        ,ACLWUPT=grid%aclwupt    ,ACLWUPTC=grid%aclwuptc            &
+     &        ,ACLWDNT=grid%aclwdnt    ,ACLWDNTC=grid%aclwdntc            &
+     &        ,ACLWUPB=grid%aclwupb    ,ACLWUPBC=grid%aclwupbc            &
+     &        ,ACLWDNB=grid%aclwdnb    ,ACLWDNBC=grid%aclwdnbc            &
+     &        ,SWUPT=grid%swupt    ,SWUPTC=grid%swuptc                    &
+     &        ,SWDNT=grid%swdnt    ,SWDNTC=grid%swdntc                    &
+     &        ,SWUPB=grid%swupb    ,SWUPBC=grid%swupbc                    &
+     &        ,SWDNB=grid%swdnb    ,SWDNBC=grid%swdnbc                    &
+     &        ,LWUPT=grid%lwupt    ,LWUPTC=grid%lwuptc                    &
+     &        ,LWDNT=grid%lwdnt    ,LWDNTC=grid%lwdntc                    &
+     &        ,LWUPB=grid%lwupb    ,LWUPBC=grid%lwupbc                    &
+     &        ,LWDNB=grid%lwdnb    ,LWDNBC=grid%lwdnbc                    &
+     &        ,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
+     &        ,TAUAERlw1  =grid%tauaerlw1,  TAUAERlw2=grid%tauaerlw2    & 
+     &        ,TAUAERlw3  =grid%tauaerlw3,  TAUAERlw4=grid%tauaerlw4    & 
+     &        ,TAUAERlw5  =grid%tauaerlw5,  TAUAERlw6=grid%tauaerlw6    & 
+     &        ,TAUAERlw7  =grid%tauaerlw7,  TAUAERlw8=grid%tauaerlw8    & 
+     &        ,TAUAERlw9  =grid%tauaerlw9,  TAUAERlw10=grid%tauaerlw10    & 
+     &        ,TAUAERlw11 =grid%tauaerlw11, TAUAERlw12=grid%tauaerlw12    & 
+     &        ,TAUAERlw13 =grid%tauaerlw13, TAUAERlw14=grid%tauaerlw14    & 
+     &        ,TAUAERlw15 =grid%tauaerlw15, TAUAERlw16=grid%tauaerlw16   & 
+     &        ,progn=config_flags%progn                                            &
+#endif
+     &         ,slope_rad=config_flags%slope_rad,topo_shading=config_flags%topo_shading     &
+     &         ,shadowmask=grid%shadowmask,ht=grid%ht,dx=grid%dx,dy=grid%dy    )
+
+BENCH_END(rad_driver_tim)
+
+#ifdef LMDZ1
+   WRITE(message, *)'  module_first_rk_step_part1: after radiation' 
+   CALL wrf_debug(200, message)
+   WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+     ' u_tend: ', ru_tendf(im2,1,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+     'p sfc: ',p8w(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+#endif
+
+!********* 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 nl_get_iswater(grid%id, iswater)
+      CALL nl_get_isurban(grid%id, isurban)
+      call nl_get_mminlu(grid%id, mminlu)
+
+      CALL wrf_debug ( 200 , ' call surface_driver' )
+
+      CALL surface_driver(                                                &
+     &         ACGRDFLX=grid%acgrdflx  ,ACHFX=grid%achfx        ,ACLHF=grid%aclhf        &
+     &        ,ACSNOM=grid%acsnom      ,ACSNOW=grid%acsnow      ,AKHS=grid%akhs          &
+     &        ,AKMS=grid%akms          ,ALBBCK=grid%albbck      ,ALBEDO=grid%albedo      &
+     &        ,EMBCK=grid%embck                                                          &
+     &        ,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      &
+     &        ,FRACTIONAL_SEAICE=config_flags%fractional_seaice           &
+     &        ,TICE2TSK_IF2COLD=config_flags%tice2tsk_if2cold             &
+     &        ,ISLTYP=grid%isltyp      ,ITIMESTEP=grid%itimestep, JULIAN_IN=grid%julian                  &
+     &        ,IVGTYP=grid%ivgtyp      ,LH=grid%lh              ,LOWLYR=grid%lowlyr      &
+     &        ,MAVAIL=grid%mavail      ,NUM_SOIL_LAYERS=config_flags%num_soil_layers        &
+     &        ,P8W=grid%p_hyd_w            ,PBLH=grid%pblh          ,PI_PHY=pi_phy      &
+     &        ,PSFC=grid%psfc          ,PSHLTR=grid%pshltr      ,PSIH=psih          &
+     &        ,BLDT=grid%bldt     ,CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag  &
+     &        ,PSIM=psim          ,P_PHY=grid%p_hyd        ,Q10=grid%q10            &
+     &        ,Q2=grid%q2              ,QFX=grid%qfx            ,QSFC=grid%qsfc          &
+     &        ,QSHLTR=grid%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        &
+     &        ,SMCREL=grid%smcrel                                                        &
+     &        ,SST=grid%sst            ,SST_UPDATE=grid%sst_update                  &
+     &        ,SSTSK=grid%sstsk        ,DTW=grid%dtw            ,SST_SKIN=grid%sst_skin  &
+     &        ,STEPBL=grid%stepbl      ,TH10=grid%th10          ,TH2=grid%th2            &
+     &        ,THZ0=grid%thz0          ,TH_PHY=th_phy      ,TKE_PBL=grid%tke_pbl    &
+     &        ,TMN=grid%tmn            ,TSHLTR=grid%tshltr      ,TSK=grid%tsk            &
+     &        ,TYR=grid%tyr            ,TYRA=grid%tyra          ,TDLY=grid%tdly          &
+     &        ,TLAG=grid%tlag          ,LAGDAY=config_flags%lagday      ,NYEAR=grid%nyear        &
+     &        ,NDAY=grid%nday          ,TMN_UPDATE=grid%tmn_update      ,YR=yr            &
+     &        ,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%z        ,ZNT=grid%znt            &
+     &        ,ZS=grid%zs              ,XICEM=grid%xicem   ,ISICE=grid%landuse_isice&
+     &        ,USTM=grid%ustm          ,CK=grid%ck         ,CKA=grid%cka            &
+     &                                 ,CD=grid%cd         ,CDA=grid%cda            &
+     &        ,ISFTCFLX=config_flags%isftcflx, IZ0TLND=config_flags%iz0tlnd         &
+     &        ,OMLCALL=config_flags%omlcall ,OML_HML0=config_flags%oml_hml0 ,OML_GAMMA=config_flags%oml_gamma &
+     &        ,TML=grid%tml, T0ML=grid%t0ml, HML=grid%hml, H0ML=grid%h0ml, HUML=grid%huml, HVML=grid%hvml, F=grid%f &
+     &        ,TMOML=grid%TMOML,ISWATER=iswater &
+     &        ,SLOPE_RAD=config_flags%slope_rad,TOPO_SHADING=config_flags%topo_shading & ! solar
+     &        ,SHADOWMASK=grid%shadowmask                                              & ! solar
+     &        ,SLOPE=grid%slope, SLP_AZI=grid%slp_azi, SWNORM=grid%swnorm              & ! solar
+     &        ,DECLIN=grid%declin ,SOLCON=grid%solcon ,COSZEN=grid%coszen ,HRANG=grid%hrang    &
+     &        ,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
+         ! Optional urban for BEP scheme
+     &        ,SF_URBAN_PHYSICS=config_flags%sf_urban_physics             &
+     &        ,NUM_URBAN_LAYERS=config_flags%num_urban_layers             & !multi-layer urban
+     &        ,TRB_URB4D=grid%trb_urb4d,TW1_URB4D=grid%tw1_urb4d          & !multi-layer urban
+     &        ,TW2_URB4D=grid%tw2_urb4d,TGB_URB4D=grid%tgb_urb4d          & !multi-layer urban
+     &        ,TLEV_URB3D=grid%tlev_urb3d                               & !multi-layer urban
+     &        ,QLEV_URB3D=grid%qlev_urb3d                               & !multi-layer urban
+     &        ,TW1LEV_URB3D=grid%tw1lev_urb3d                           & !multi-layer urban
+     &        ,TW2LEV_URB3D=grid%tw2lev_urb3d                           & !multi-layer urban
+     &        ,TGLEV_URB3D=grid%tglev_urb3d                             & !multi-layer urban
+     &        ,TFLEV_URB3D=grid%tflev_urb3d                             & !multi-layer urban
+     &        ,SF_AC_URB3D=grid%sf_ac_urb3d                             & !multi-layer urban
+     &        ,LF_AC_URB3D=grid%lf_ac_urb3d                             & !multi-layer urban
+     &        ,CM_AC_URB3D=grid%cm_ac_urb3d                             & !multi-layer urban
+     &        ,SFVENT_URB3D=grid%sfvent_urb3d                           & !multi-layer urban
+     &        ,LFVENT_URB3D=grid%lfvent_urb3d                           & !multi-layer urban
+     &        ,SFWIN1_URB3D=grid%sfwin1_urb3d                           & !multi-layer urban
+     &        ,SFWIN2_URB3D=grid%sfwin2_urb3d                           & !multi-layer urban
+     &        ,SFW1_URB3D=grid%sfw1_urb3d,SFW2_URB3D=grid%sfw2_urb3d      & !multi-layer urban
+     &        ,SFR_URB3D=grid%sfr_urb3d,SFG_URB3D=grid%sfg_urb3d          & !multi-layer urban
+     &        ,GMT=grid%gmt,XLAT=grid%xlat,XLONG=grid%xlong,JULDAY=grid%julday  &
+     &        ,A_U_BEP=grid%a_u_bep,A_V_BEP=grid%a_v_bep,A_T_BEP=grid%a_t_bep   &
+     &        ,A_Q_BEP=grid%a_q_bep                                             &
+     &        ,B_U_BEP=grid%b_u_bep,B_V_BEP=grid%b_v_bep,B_T_BEP=grid%b_t_bep   &
+     &        ,B_Q_BEP=grid%b_q_bep                                             &
+     &        ,SF_BEP=grid%sf_bep,VL_BEP=grid%vl_bep                            &
+     &        ,A_E_BEP=grid%a_e_bep,B_E_BEP=grid%b_e_bep,DLG_BEP=grid%dlg_bep   &
+     &        ,DL_U_BEP=grid%dl_u_bep                                           &
+     &        ,CMR_SFCDIF=grid%cmr_sfcdif, CHR_SFCDIF=grid%chr_sfcdif     & !I/O urban
+     &        ,CMC_SFCDIF=grid%cmc_sfcdif, CHC_SFCDIF=grid%chc_sfcdif     & !I/O urban
+           ! P-X LSM Variables
+     &        ,LANDUSEF=grid%landusef, SOILCTOP=grid%soilctop             &   ! P-X LSM
+     &        ,SOILCBOT=grid%soilcbot                                     &   ! P-X LSM
+     &        ,RA=grid%ra, RS=grid%rs, LAI=grid%lai                       &   ! P-X LSM
+     &        ,NLCAT=grid%num_land_cat,  NSCAT=grid%num_soil_cat          &   ! P-X LSM
+     &        ,VEGF_PX=grid%vegf_px, SNOWNCV=grid%snowncv                 &   ! P-X LSM
+     &        ,ANAL_INTERVAL=config_flags%auxinput9_interval_s+config_flags%auxinput9_interval_m*60  &   ! P-X LSM
+     &        ,PXLSM_SMOIS_INIT=config_flags%pxlsm_smois_init             &   ! P-X LSM
+     &        ,PXLSM_SOIL_NUDGE=config_flags%pxlsm_soil_nudge             &   ! P-X LSM
+           ! Optional PX LSM nudging
+     &        ,t2_ndg_old=grid%t2_ndg_old                  &
+     &        ,q2_ndg_old=grid%q2_ndg_old                  &
+     &        ,t2_ndg_new=grid%t2_ndg_new                  &
+     &        ,q2_ndg_new=grid%q2_ndg_new                  &
+     &        ,sn_ndg_old=grid%sn_ndg_old                  &
+     &        ,sn_ndg_new=grid%sn_ndg_new                  &
+           ! 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                                  &
+          ! Variables required by TEMF PBL - WA 1/7/09
+              ,te_temf=grid%te_temf,hd_temf=grid%hd_temf                  &
+              ,fCor=grid%f,exch_temf=exch_temf,wm_temf=grid%wm_temf       &
+          ! Variables required by IDEAL SCM sfc scheme - WA 1/6/10
+              ,hfx_force=grid%hfx_force,lh_force=grid%lh_force            &
+              ,tsk_force=grid%tsk_force                                   &
+              ,hfx_force_tend=grid%hfx_force_tend                         &
+              ,lh_force_tend=grid%lh_force_tend                           &
+              ,tsk_force_tend=grid%tsk_force_tend                         &
+           ! 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     &
+     &        ,T2OBS=grid%t2obs, Q2OBS=grid%q2obs                         &
+     &        ,RAINBL=grid%rainbl,SR=grid%sr,RAINSHV=grid%rainshv         &
+     &        ,RAINNCV=grid%rainncv,REGIME=grid%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,DEW=grid%dew             & ! ruc lsm
+     &        ,POTEVP=grid%POTEVP, SNOPCX=grid%SNOPCX, SOILTB=grid%SOILTB                 & ! ruc lsm
+     &        ,ISURBAN=isurban, MMINLU=TRIM(mminlu)                       &
+     &        ,SNOTIME = grid%SNOTIME                                     &
+     &        ,RDLAI2D=config_flags%rdlai2d                               &
+     &        ,usemonalb=config_flags%usemonalb                           &
+     &        ,NOAHRES=grid%noahres                                       &
+!mynn mp@
+     &         ,ch=grid%ch,tsq=grid%tsq,qsq=grid%qsq,cov=grid%cov &
+     &                                                              )
+BENCH_END(surf_driver_tim)
+
+#ifdef LMDZ1
+   WRITE(message, *)'  module_first_rk_step_part1: after surface' 
+   CALL wrf_debug(200, message)
+   WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+     ' u_tend: ', ru_tendf(im2,1,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+     'p sfc: ',p8w(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+#endif
+
+!*********
+! 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                           &
+     &        ,BLDT=grid%bldt, CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag &
+     &        ,BR=br              ,CHKLOWQ=chklowq    ,CT=grid%ct                   &
+     &        ,DT=grid%dt              ,DX=grid%dx              ,DZ8W=dz8w          &
+     &        ,EXCH_H=grid%exch_h     ,EXCH_M=grid%exch_m                           &
+     &        ,F=grid%f  ,GRDFLX=grid%grdflx      &
+     &        ,GZ1OZ0=gz1oz0      ,HFX=grid%hfx            ,HT=grid%ht              &
+     &        ,ID=grid%id         ,ITIMESTEP=grid%itimestep     ,KPBL=grid%kpbl          &
+     &        ,LH=grid%lh              ,LOWLYR=grid%lowlyr      ,P8W=grid%p_hyd_w   &
+     &        ,PBLH=grid%pblh          ,PI_PHY=pi_phy      ,PSIH=psih          &
+     &        ,PSIM=psim          ,P_PHY=grid%p_hyd        ,QFX=grid%qfx            &
+     &        ,QSFC=grid%qsfc          ,QZ0=grid%qz0  ,MIXHT=mixht                  &
+     &        ,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                               &
+     &        ,TSK=grid%tsk            ,T_PHY=grid%t_phy        ,UST=grid%ust       &
+     &        ,U10=grid%u10 ,UZ0=grid%uz0      ,U_FRAME=grid%u_frame    ,U_PHY=u_phy        &
+     &        ,V10=grid%v10 ,VZ0=grid%vz0      ,V_FRAME=grid%v_frame    ,V_PHY=v_phy        &
+              ,T2=grid%t2 &
+     &        ,WARM_RAIN=grid%warm_rain                    ,WSPD=wspd          &
+     &        ,XICE=grid%xice          ,XLAND=grid%xland        ,Z=grid%z                &
+     &        ,ZNT=grid%znt                                                    &
+! variables added for BEP
+     &          ,FRC_URB2D=grid%frc_urb2d                                                  &
+     &          ,A_U_BEP=grid%a_u_bep,A_V_BEP=grid%a_v_bep,A_T_BEP=grid%a_t_bep          &
+     &          ,A_Q_BEP=grid%a_q_bep                                                    &
+     &          ,B_U_BEP=grid%b_u_bep,B_V_BEP=grid%b_v_bep,B_T_BEP=grid%b_t_bep          &
+     &          ,B_Q_BEP=grid%b_q_bep                                                    &
+     &          ,SF_BEP=grid%sf_bep,VL_BEP=grid%vl_bep                                   &
+     &          ,A_E_BEP=grid%a_e_bep,B_E_BEP=grid%b_e_bep,DLG_BEP=grid%dlg_bep          &
+     &          ,DL_U_BEP=grid%dl_u_bep                                                  &
+     &          ,SF_SFCLAY_PHYSICS=config_flags%sf_sfclay_physics                        &
+     &          ,SF_URBAN_PHYSICS=config_flags%sf_urban_physics                          &
+! Bep changes end
+! add tke_pbl, and turbulent fluxes
+     &          ,TKE_PBL=grid%tke_pbl,EL_PBL=grid%el_pbl,WU_TUR=grid%wu_tur,WV_tur=grid%wv_tur,WT_tur=grid%wt_tur,WQ_tur=grid%wq_tur   &
+! end add tke_pbl, and turbulent fluxes
+     &        ,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                                   &
+          ! Variables Required by ACM PBL  - jp
+     &        ,ZNU=grid%znu,ZNW=grid%znw,MUT=grid%mut,P_TOP=grid%p_top    &
+          ! Variables required by TEMF PBL - WA 9/9/08
+              ,te_temf=grid%te_temf                                 &
+              ,kh_temf=grid%kh_temf,km_temf=grid%km_temf            &
+              ,shf_temf=grid%shf_temf,qf_temf=grid%qf_temf          &
+              ,uw_temf=grid%uw_temf,vw_temf=grid%vw_temf            &
+              ,hd_temf=grid%hd_temf,lcl_temf=grid%lcl_temf          &
+              ,wupd_temf=grid%wupd_temf,mf_temf=grid%mf_temf          &
+              ,thup_temf=grid%thup_temf,qtup_temf=grid%qtup_temf          &
+              ,qlup_temf=grid%qlup_temf          &
+              ,cf3d_temf=grid%cf3d_temf,cfm_temf=grid%cfm_temf          &
+              ,hct_temf=grid%hct_temf                               &
+              ,flhc=grid%flhc,flqc=grid%flqc                        &
+              ,exch_temf=exch_temf                      &
+          ! 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=grid%REGIME                  &
+!mynn mp@
+     &        ,QKE=scalar(ims,kms,jms,P_qke), tsq=grid%tsq, qsq=grid%qsq, cov=grid%cov     &
+     &        ,rmol=grid%rmol, ch=grid%ch                                 &
+     &        ,qcg=grid%qcg, grav_settling=grid%grav_settling             &
+!    &        ,K_m=grid%K_m, K_h=grid%K_h, K_q=grid%K_q                   &
+!GWD for ARW
+     &        ,GWD_OPT=config_flags%gwd_opt &
+     &        ,DTAUX3D=grid%dtaux3d,DTAUY3D=grid%dtauy3d &
+     &        ,DUSFCG=grid%dusfcg,DVSFCG=grid%dvsfcg &
+     &        ,VAR2D=grid%var2d,OC12D=grid%oc12d     &
+     &        ,OA1=grid%oa1,OA2=grid%oa2,OA3=grid%oa3,OA4=grid%oa4        &
+     &        ,OL1=grid%ol1,OL2=grid%ol2,OL3=grid%ol3,OL4=grid%ol4        &
+! For Wind Turbine Drag Parameterizations
+     &        ,phb=grid%phb                                               &
+     &        ,XLAT_U=grid%xlat_u,XLONG_U=grid%xlong_u                    &
+!Variables required for camuwpbl scheme
+     &        ,Z_AT_W=grid%z_at_w,CLDFRA=grid%cldfra                      &
+     &        ,RTHRATENLW=grid%rthratenlw,TAURESX2D=grid%tauresx2d        &
+     &        ,TAURESY2D=grid%tauresy2d                                   &
+     &        ,TPERT2D=grid%tpert2d,QPERT2D=grid%qpert2d                  &
+     &        ,WPERT2D=grid%wpert2d                                       &
+     &        ,XLAT_V=grid%xlat_v,XLONG_V=grid%xlong_v                    &
+     &        )
+                                                         
+
+BENCH_END(pbl_driver_tim)
+#ifdef LMDZ1
+   WRITE(message, *)'  module_first_rk_step_part1: after pbl' 
+   CALL wrf_debug(200, message)
+   WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+     ' u_tend: ', ru_tendf(im2,1,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+     'p sfc: ',p8w(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+#endif
+
+!*****
+! fire 
+
+! Jan Mandel's call to SFIRE
+
+      IF ((grid%sr_x > 0 .OR. grid%sr_y > 0) .AND. config_flags%ifire == 2) THEN
+
+BENCH_START(fire_driver_tim)
+        if(config_flags%ifire.eq.2)then 
+            ! initialization moved to start_em:start_domain_em
+!            if(grid%initestep.eq.1) &
+!            call sfire_driver_em_init (  grid , config_flags    &
+!            ,ids,ide, kds,kde, jds,jde                              &
+!            ,ims,ime, kms,kme, jms,jme                              &
+!            ,ips,ipe, kps,kpe, jps,jpe  )
+            ! one timestep of the fire model
+            call sfire_driver_em_step (  grid , config_flags    &
+            ,ids,ide, kds,kde, jds,jde                              &
+            ,ims,ime, kms,kme, jms,jme                              &
+            ,ips,ipe, kps,kpe, jps,jpe                              &
+            ,rho,grid%z_at_w,dz8w)
+        endif
+
+BENCH_END(fire_driver_tim)
+       ENDIF
+
+#ifdef LMDZ1
+   WRITE(message, *)'  module_first_rk_step_part1: after fire' 
+   CALL wrf_debug(200, message)
+   WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+     ' u_tend: ', ru_tendf(im2,1,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+     'p sfc: ',p8w(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+#endif
+
+! cumulus para.
+
+      CALL wrf_debug ( 200 , ' call cumulus_driver' )
+
+#if ( WRF_DFI_RADAR == 1 )
+      do_capsupress=0
+      if (config_flags%dfi_radar == 1) then
+         if(grid%dfi_stage == DFI_FWD ) do_capsupress=1
+         if(grid%itimestep <= 31 .and. grid%dfi_stage == DFI_FST ) do_capsupress=1
+      endif
+#endif
+
+BENCH_START(cu_driver_tim)
+      CALL cumulus_driver(grid                                             &
+                 ! Prognostic variables
+     &             ,U=u_phy   ,V=v_phy   ,TH=th_phy  ,T=grid%t_phy                  &
+     &             ,W=grid%w_2     ,P=grid%p_hyd   ,PI=pi_phy  ,RHO=rho             &
+                 ! Other arguments
+     &             ,ITIMESTEP=grid%itimestep ,DT=grid%dt      ,DX=grid%dx              &
+     &             ,CUDT=grid%cudt,CURR_SECS=curr_secs,ADAPT_STEP_FLAG=adapt_step_flag &
+     &             ,RAINC=grid%rainc   ,RAINCV=grid%raincv   ,PRATEC=grid%pratec       &
+     &             ,NCA=grid%nca                                                       &
+     &             ,HTOP=grid%cutop     ,HBOT=grid%cubot       ,KPBL=grid%kpbl         &
+     &             ,Z=grid%z ,Z_AT_W=grid%z_at_w ,MAVAIL=grid%mavail ,PBLH=grid%pblh   &
+     &             ,DZ8W=dz8w     ,P8W=grid%p_hyd_w, PSFC=grid%psfc, TSK=grid%tsk      &
+     &             ,TKE_PBL=grid%tke_pbl, UST=grid%ust                                 &
+     &             ,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,EDT_OUT=grid%edt_out             &
+     &             ,imomentum=grid%imomentum,clos_choice=grid%clos_choice           &
+     &             ,ishallow=config_flags%ishallow                                  &
+     &             ,cugd_tten=grid%cugd_tten,cugd_qvten=grid%cugd_qvten,cugd_qcten=grid%cugd_qcten   &
+     &             ,cugd_ttens=grid%cugd_ttens,cugd_qvtens=grid%cugd_qvtens   &
+     &             ,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   &
+     &             ,HFX=grid%hfx, QFX=grid%qfx                            &
+     &             ,CLDFRA=grid%cldfra, TPERT2D=grid%tpert2d              &
+     &             ,GSW=grid%gsw,cugd_avedx=config_flags%cugd_avedx       &
+     &             ,k22_shallow=grid%k22_shallow,kbcon_shallow=grid%kbcon_shallow &
+     &             ,ktop_shallow=grid%ktop_shallow,xmb_shallow=grid%xmb_shallow   &
+     &             ,PERIODIC_X=(config_flags%polar .OR. config_flags%periodic_x)  &
+     &             ,PERIODIC_Y=config_flags%periodic_y                    &
+                 ! Zhang-McFarlane outputs
+     &             ,CAPE=grid%cape ,ZMMU=grid%zmmu ,ZMMD=grid%zmmd        &
+     &             ,ZMDT=grid%zmdt ,ZMDQ=grid%zmdq                        &
+     &             ,DLF=grid%dlf, RLIQ=grid%rliq                          &
+     &             ,PCONVB=grid%pconvb, PCONVT=grid%pconvt                &
+     &             ,EVAPTZM=grid%evaptzm, FZSNTZM=grid%fzsntzm, EVSNTZM=grid%evsntzm     &
+     &             ,EVAPQZM=grid%evapqzm, ZMFLXPRC=grid%zmflxprc          &
+     &             ,ZMFLXSNW=grid%zmflxsnw, ZMNTPRPD=grid%zmntprpd        &
+     &             ,ZMNTSNPD=grid%zmntsnpd, ZMEIHEAT=grid%zmeiheat        &
+     &             ,CMFMC=grid%cmfmc, CMFMCDZM=grid%cmfmcdzm              &
+     &             ,PRECCDZM=grid%preccdzm, PRECZ=grid%precz              &
+     &             ,ZMMTU=grid%zmmtu, ZMMTV=grid%zmmtv  &
+     &             ,ZMUPGU=grid%zmupgu, ZMUPGD=grid%zmupgd                &
+     &             ,ZMVPGU=grid%zmvpgu, ZMVPGD=grid%zmvpgd                &
+     &             ,ZMICUU=grid%zmicuu, ZMICUD=grid%zmicud                &
+     &             ,ZMICVU=grid%zmicvu, ZMICVD=grid%zmicvd                &
+     &             ,ZMDICE=grid%zmdice, ZMDLIQ=grid%zmdliq                &
+                 ! Selection flag
+     &             ,CU_PHYSICS=config_flags%cu_physics                    &
+     &             ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics            &
+     &             ,SF_SFCLAY_PHYSICS=config_flags%sf_sfclay_physics      &
+     &             ,KFETA_TRIGGER=config_flags%kfeta_trigger              &
+                 ! 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                              &
+                 ! 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       &
+     &             ,RUCUTEN=grid%rucuten   , RVCUTEN=grid%rvcuten         &
+     &             ,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            &
+! Variables for Tiedtke and NSAS schemes
+     &             ,ZNU=grid%znu                                          &
+     &             ,MP_PHYSICS=config_flags%mp_physics                    &
+#ifdef WRF_CHEM
+     &             ,GD_CLOUD=grid%GD_CLOUD,GD_CLOUD2=grid%GD_CLOUD2       &
+#endif
+#if ( WRF_DFI_RADAR == 1 )
+     &             ,DO_CAPSUPPRESS=do_capsupress                          &
+#endif
+     &             ,cfu1=grid%cfu1,cfd1=grid%cfd1,dfu1=grid%dfu1,efu1=grid%efu1,dfd1=grid%dfd1,efd1=grid%efd1,f_flux=l_flux)
+BENCH_END(cu_driver_tim)
+!
+! this for calculating (G3 scheme only)  time averaged variables for online (WRF-CHem) or offline (other models) chem runs
+!
+     if(config_flags%cu_diag.eq.1)then
+      !$OMP PARALLEL DO   &
+      !$OMP PRIVATE ( ij )
+      DO ij = 1 , grid%num_tiles
+           call convtrans_prep(grid%gd_cloud,grid%gd_cloud2,grid%gd_cloud_a,&
+     &          grid%gd_cloud_b,grid%raincv,grid%raincv_a,grid%raincv_b,     &
+     &          grid%gd_cldfr,moist,p_QV,p_QC,p_qi,T_PHY,P_PHY,num_moist,    &
+     &          grid%gd_cloud2_a,grid%gd_cloud2_b,grid%convtrans_avglen_m,&
+     &          adapt_step_flag,curr_secs,                &
+     &          grid%itimestep,grid%dt,                                      &
+     &          config_flags%cu_physics,                                     &
+     &          ids,ide, jds,jde, kds,kde,                                   &
+     &          ims,ime, jms,jme, kms,kme                                    &
+     &          ,ITS=grid%i_start(ij),ITE=min(grid%i_end(ij), ide-1)                 &
+     &          ,JTS=grid%j_start(ij),JTE=min(grid%j_end(ij), jde-1)                 &
+     &          ,KTS=k_start, KTE=min(k_end,kde-1))
+      ENDDO
+      !$OMP END PARALLEL DO
+     endif
+#ifdef LMDZ1
+   WRITE(message, *)'  module_first_rk_step_part1: after cumulus' 
+   CALL wrf_debug(200, message)
+   WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+     ' u_tend: ', ru_tendf(im2,1,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+     'p sfc: ',p8w(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+#endif
+
+! shallow cumulus parameterization
+      CALL wrf_debug ( 200 , ' call shallow_cumulus_driver' )
+
+BENCH_START(shcu_driver_tim)
+      CALL shallowcu_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     &
+     &             ,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                              &
+     &             ,U=u_phy, V=v_phy, TH=th_phy, T=t_phy                  &
+     &             ,P=grid%p_hyd, PI=pi_phy, RHO=rho, MOIST=moist         &
+     &             ,NUM_MOIST=num_moist                                   &
+     &             ,ITIMESTEP=grid%itimestep, DT=grid%dt, DX=grid%dx      &
+     &             ,CUDT=grid%cudt                                        &
+     &             ,CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag  &
+     &             ,RAINSH=grid%rainsh, PRATESH=grid%pratesh, NCA=grid%nca&
+     &             ,RAINSHV=grid%rainshv                                  &
+     &             ,Z=grid%z, Z_AT_W=grid%z_at_w, DZ8W=dz8w               &
+     &             ,MAVAIL=grid%mavail, PBLH=grid%pblh, P8W=grid%p_hyd_w  &
+     &             ,TKE_PBL=grid%tke_pbl                                  &
+     &             ,CLDFRA=grid%cldfra, CLDFRA_OLD=grid%cldfra_old        &
+     &             ,CLDFRASH=grid%cldfrash, HTOP=grid%htop, HBOT=grid%hbot&
+     &             ,SHCU_PHYSICS=grid%shcu_physics                        &
+     &             ,QV_CURR=moist(ims,kms,jms,P_QV)                       &
+     &             ,QC_CURR=moist(ims,kms,jms,P_QC)                       &
+     &             ,QR_CURR=moist(ims,kms,jms,P_QR)                       &
+     &             ,QI_CURR=moist(ims,kms,jms,P_QI)                       &
+     &             ,QS_CURR=moist(ims,kms,jms,P_QI)                       &
+     &             ,QG_CURR=moist(ims,kms,jms,P_QG)                       &
+     &             ,DLF=grid%dlf, RLIQ=grid%rliq, RLIQ2=grid%rliq2        &
+     &             ,CMFMC=grid%cmfmc, CMFMC2=grid%cmfmc2                  &
+     &             ,CUSH=grid%cush, SNOWSH=grid%snowsh                    &
+     &             ,ICWMRSH=grid%icwmrsh, RPRDSH=grid%rprdsh              &
+     &             ,CBMF=grid%cbmf_cu, CMFSL=grid%cmfsl, CMFLQ=grid%cmflq &
+     &             ,EVAPCSH=grid%evapcsh                                  &
+     &             ,RQVSHTEN=grid%rqvshten, RQCSHTEN=grid%rqcshten        &
+     &             ,RQRSHTEN=grid%rqrshten, RQISHTEN=grid%rqishten        &
+     &             ,RQSSHTEN=grid%rqsshten, RQGSHTEN=grid%rqgshten        &
+     &             ,RQVBLTEN=grid%rqvblten, RQVFTEN=grid%rqvften          &
+     &             ,RUSHTEN=grid%rushten, RVSHTEN=grid%rvshten            &
+     &             ,RTHSHTEN=grid%rthshten, RTHRATEN=grid%rthraten        &
+     &             ,RTHBLTEN=grid%rthblten, RTHFTEN=grid%rthften          &
+     &             ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr                         &
+     &             ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg                         &
+     &             ,HT=grid%ht                                            &
+     &                                                                    )
+BENCH_END(shcu_driver_tim)
+#ifdef LMDZ1
+   WRITE(message, *)'  module_first_rk_step_part1: after shallow cumulus' 
+   CALL wrf_debug(200, message)
+   WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+     ' u_tend: ', ru_tendf(im2,1,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+     'p sfc: ',p8w(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+#endif
+
+! JPH call force_scm to update bl tendencies
+      CALL force_scm(itimestep=grid%itimestep,dt=grid%dt                  &
+     &             ,scm_force=config_flags%scm_force                      &
+     &             ,dx=config_flags%scm_force_dx                          &
+     &             ,num_force_layers=grid%num_force_layers                &
+     &             ,scm_th_adv=config_flags%scm_th_adv                    &
+     &             ,scm_qv_adv=config_flags%scm_qv_adv                    &
+     &             ,scm_ql_adv=config_flags%scm_ql_adv                    &
+     &             ,scm_wind_adv=config_flags%scm_wind_adv                &
+     &             ,scm_vert_adv=config_flags%scm_vert_adv                &
+     &             ,scm_soilT_force=config_flags%scm_soilT_force          &
+     &             ,scm_soilQ_force=config_flags%scm_soilQ_force          &
+     &      ,scm_force_th_largescale=config_flags%scm_force_th_largescale &
+     &      ,scm_force_qv_largescale=config_flags%scm_force_qv_largescale &
+     &      ,scm_force_ql_largescale=config_flags%scm_force_ql_largescale &
+     &      ,scm_force_wind_largescale=config_flags%scm_force_wind_largescale &
+     &             ,u_base=grid%u_base,v_base=grid%v_base                 &
+     &             ,z_base=grid%z_base                                    &
+     &             ,z_force=grid%z_force,z_force_tend=grid%z_force_tend   &
+     &             ,u_g=grid%u_g,v_g=grid%v_g                             &
+     &             ,u_g_tend=grid%u_g_tend,v_g_tend=grid%v_g_tend         &
+     &             ,w_subs=grid%w_subs, w_subs_tend=grid%w_subs_tend      &
+     &             ,th_upstream_x=grid%th_upstream_x                      &
+     &             ,th_upstream_x_tend=grid%th_upstream_x_tend            &
+     &             ,th_upstream_y=grid%th_upstream_y                      &
+     &             ,th_upstream_y_tend=grid%th_upstream_y_tend            &
+     &             ,qv_upstream_x=grid%qv_upstream_x                      &
+     &             ,qv_upstream_x_tend=grid%qv_upstream_x_tend            &
+     &             ,qv_upstream_y=grid%qv_upstream_y                      &
+     &             ,qv_upstream_y_tend=grid%qv_upstream_y_tend            &
+     &             ,ql_upstream_x=grid%ql_upstream_x                      &
+     &             ,ql_upstream_x_tend=grid%ql_upstream_x_tend            &
+     &             ,ql_upstream_y=grid%ql_upstream_y                      &
+     &             ,ql_upstream_y_tend=grid%ql_upstream_y_tend            &
+     &             ,u_upstream_x=grid%u_upstream_x                        &
+     &             ,u_upstream_x_tend=grid%u_upstream_x_tend              &
+     &             ,u_upstream_y=grid%u_upstream_y                        &
+     &             ,u_upstream_y_tend=grid%u_upstream_y_tend              &
+     &             ,v_upstream_x=grid%v_upstream_x                        &
+     &             ,v_upstream_x_tend=grid%v_upstream_x_tend              &
+     &             ,v_upstream_y=grid%v_upstream_y                        &
+     &             ,v_upstream_y_tend=grid%v_upstream_y_tend              &
+     &             ,tau_x=grid%tau_x                                      &
+     &             ,tau_x_tend=grid%tau_x_tend                            &
+     &             ,tau_y=grid%tau_y                                      &
+     &             ,tau_y_tend=grid%tau_y_tend                            &
+     &             ,th_largescale=grid%th_largescale                      &
+     &             ,th_largescale_tend=grid%th_largescale_tend            &
+     &             ,qv_largescale=grid%qv_largescale                      &
+     &             ,qv_largescale_tend=grid%qv_largescale_tend            &
+     &             ,ql_largescale=grid%ql_largescale                      &
+     &             ,ql_largescale_tend=grid%ql_largescale_tend            &
+     &             ,u_largescale=grid%u_largescale                      &
+     &             ,u_largescale_tend=grid%u_largescale_tend            &
+     &             ,v_largescale=grid%v_largescale                      &
+     &             ,v_largescale_tend=grid%v_largescale_tend            &
+     &             ,tau_largescale=grid%tau_largescale                    &
+     &             ,tau_largescale_tend=grid%tau_largescale_tend          &
+     &             ,num_force_soil_layers=config_flags%num_force_soil_layers &
+     &             ,num_soil_layers=config_flags%num_soil_layers          &
+     &             ,soil_depth_force=grid%soil_depth_force                &
+     &             ,zs=grid%zs                                            &
+     &             ,tslb=grid%tslb,smois=grid%smois                       &
+     &             ,t_soil_forcing_val=grid%t_soil_forcing_val            &
+     &             ,t_soil_forcing_tend=grid%t_soil_forcing_tend          &
+     &             ,q_soil_forcing_val=grid%q_soil_forcing_val            &
+     &             ,q_soil_forcing_tend=grid%q_soil_forcing_tend          &
+     &             ,tau_soil=grid%tau_soil                                &
+     &             ,z=grid%z,z_at_w=grid%z_at_w                           &
+     &             ,th=th_phy, qv=moist(ims,kms,jms,P_QV)                 &
+     &             ,ql=moist(ims,kms,jms,P_QC)                            &
+     &             ,u=u_phy, v=v_phy                                      &
+     &             ,thten=grid%rthblten, qvten=grid%rqvblten              &
+     &             ,qlten=grid%rqcblten                                   &
+     &             ,uten=grid%rublten, vten=grid%rvblten                  &
+     &             ,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     &
+     &             ,KTS=k_start, KTE=min(k_end,kde-1)                     &
+     &              )
+
+#ifdef LMDZ1
+   WRITE(message, *)'  module_first_rk_step_part1: after scm update' 
+   CALL wrf_debug(200, message)
+   WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+     ' u_tend: ', ru_tendf(im2,1,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+     'p sfc: ',p8w(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+#endif
+
+#ifdef DM_PARALLEL
+#     include "HALO_EM_FDDA_SFC.inc"
+#endif
+      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,RPHNDGDTEN=grid%rphndgdten,            &
+                  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),                        &
+                  ph_ndg_old=fdda3d(ims,kms,jms,P_ph_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),                        &
+                  ph_ndg_new=fdda3d(ims,kms,jms,P_ph_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%u_2,v3d=grid%v_2,th_phy=th_phy,                          &
+                  ph=grid%ph_2,rho=rho,moist=moist,                                 &
+                  p_phy=p_phy,pi_phy=pi_phy,p8w=p8w,t_phy=grid%t_phy,               &
+                  dz8w=dz8w,z=grid%z,z_at_w=grid%z_at_w,                            &
+                  grid=grid,config_flags=config_flags,dx=grid%DX,n_moist=num_moist, &
+                  STEPFG=grid%STEPFG,                                               &
+                  pblh=grid%pblh,ht=grid%ht,REGIME=grid%regime,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,                                      &
+                   u10=grid%u10, v10=grid%v10, th2=grid%th2, q2=grid%q2,            &
+                   u10_ndg_old=grid%u10_ndg_old,                    &
+                   v10_ndg_old=grid%v10_ndg_old,                    &
+                   t2_ndg_old=grid%t2_ndg_old,                      &
+                   th2_ndg_old=grid%th2_ndg_old,                    &
+                   q2_ndg_old=grid%q2_ndg_old,                      &
+                   rh_ndg_old=grid%rh_ndg_old,                      &
+                   psl_ndg_old=grid%psl_ndg_old,                    &
+                   ps_ndg_old=grid%ps_ndg_old,                      &
+                   tob_ndg_old=grid%tob_ndg_old,                                    &
+                   odis_ndg_old=grid%odis_ndg_old,                                  &
+                   u10_ndg_new=grid%u10_ndg_new,                    &
+                   v10_ndg_new=grid%v10_ndg_new,                    &
+                   t2_ndg_new=grid%t2_ndg_new,                      &
+                   th2_ndg_new=grid%th2_ndg_new,                    &
+                   q2_ndg_new=grid%q2_ndg_new,                      &
+                   rh_ndg_new=grid%rh_ndg_new,                      &
+                   psl_ndg_new=grid%psl_ndg_new,                    &
+                   ps_ndg_new=grid%ps_ndg_new,                      &
+                   tob_ndg_new=grid%tob_ndg_new,                                    &
+                   odis_ndg_new=grid%odis_ndg_new                                   &
+                   ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe               &
+                   ,IMSX=imsx,IMEX=imex,JMSX=jmsx,JMEX=jmex,KMSX=kmsx,KMEX=kmex     &
+                   ,IPSX=ipsx,IPEX=ipex,JPSX=jpsx,JPEX=jpex,KPSX=kpsx,KPEX=kpex     &
+                   ,IMSY=imsy,IMEY=imey,JMSY=jmsy,JMEY=jmey,KMSY=kmsy,KMEY=kmey     &
+                   ,IPSY=ipsy,IPEY=ipey,JPSY=jpsy,JPEY=jpey,KPSY=kpsy,KPEY=kpey     )
+
+BENCH_END(fdda_driver_tim)
+
+#ifdef LMDZ1
+   WRITE(message, *)'  module_first_rk_step_part1: after fdda' 
+   CALL wrf_debug(200, message)
+   WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+     ' u_tend: ', ru_tendf(im2,1,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+     'p sfc: ',p8w(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+   WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+   CALL wrf_debug(200, message)
+#endif
+
+  END SUBROUTINE first_rk_step_part1
+
+END MODULE module_first_rk_step_part1
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_first_rk_step_part2.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_first_rk_step_part2.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_first_rk_step_part2.F	(revision 17)
@@ -0,0 +1,911 @@
+!WRF:MEDIATION_LAYER:SOLVER
+
+#define BENCH_START(A)
+#define BENCH_END(A)
+
+MODULE module_first_rk_step_part2
+
+CONTAINS
+
+  SUBROUTINE first_rk_step_part2 (   grid , config_flags              &
+                             , moist , moist_tend               &
+                             , chem  , chem_tend                &
+                             , tracer, tracer_tend              &
+                             , scalar , scalar_tend             &
+                             , fdda3d, fdda2d                   &
+                             , ru_tendf, rv_tendf               &
+                             , rw_tendf, t_tendf                &
+                             , ph_tendf, mu_tendf               &
+                             , tke_tend                         &
+                             , adapt_step_flag , curr_secs      &
+                             , psim , psih , wspd , gz1oz0 , br , chklowq &
+                             , cu_act_flag , hol , th_phy        &
+                             , pi_phy , p_phy , t_phy , u_phy , v_phy     &
+                             , dz8w , p8w , t8w , rho_phy , rho           &
+                             , nba_mij, n_nba_mij         & !JDM
+                             , nba_rij, n_nba_rij         & !JDM
+                             , 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    &
+                             , k_start , k_end                  &
+                            )
+    USE module_state_description
+    USE module_model_constants
+    USE module_domain, ONLY : domain
+    USE module_configure, ONLY : grid_config_rec_type, model_config_rec
+#ifdef DM_PARALLEL
+    USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, wrf_dm_maxval, wrf_err_message, local_communicator_x, local_communicator_y
+    USE module_comm_dm, ONLY : halo_em_tke_c_sub,halo_em_tke_d_sub,halo_em_tke_e_sub            &
+            ,halo_em_phys_pbl_sub,halo_em_phys_shcu_sub &
+            ,halo_em_fdda_sub,halo_em_phys_diffusion_sub,halo_em_tke_3_sub &
+            ,halo_em_tke_5_sub,halo_obs_nudge_sub,period_bdy_em_a1_sub,period_bdy_em_phy_bc_sub &
+            ,period_bdy_em_fdda_bc_sub,period_bdy_em_chem_sub,halo_em_phys_cu_sub
+#endif
+
+    USE module_driver_constants
+    USE module_diffusion_em, ONLY : phy_bc, cal_deform_and_div, compute_diff_metrics, &
+                                    vertical_diffusion_2, horizontal_diffusion_2, calculate_km_kh, &
+                                    tke_rhs
+    USE module_em, ONLY : calculate_phy_tend
+    USE module_fddaobs_driver, ONLY : fddaobs_driver
+    USE module_bc, ONLY : set_physical_bc3d, set_physical_bc2d
+    USE module_physics_addtendc, ONLY : update_phy_ten
+
+    USE module_sfs_driver !JDM
+    USE module_stoch, ONLY : update_stoch_ten, update_stoch , update_stoch_ten_subdomains,  & 
+                             do_fftback_along_x,do_fftback_along_y,sp2gp_prep
+
+
+    IMPLICIT NONE
+
+    TYPE ( domain ), INTENT(INOUT) :: grid
+    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,     &
+                           imsx,imex,jmsx,jmex,kmsx,kmex,    &
+                           ipsx,ipex,jpsx,jpex,kpsx,kpex,    &
+                           imsy,imey,jmsy,jmey,kmsy,kmey,    &
+                           ipsy,ipey,jpsy,jpey,kpsy,kpey
+
+
+
+    LOGICAL ,INTENT(IN)                        :: adapt_step_flag
+    REAL, INTENT(IN)                           :: curr_secs
+
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_moist),INTENT(INOUT)   :: moist
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_moist),INTENT(INOUT)   :: moist_tend
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_chem),INTENT(INOUT)   :: chem
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_chem),INTENT(INOUT)   :: chem_tend
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer),INTENT(INOUT)   :: tracer
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer),INTENT(INOUT)   :: tracer_tend
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT)   :: scalar
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT)   :: scalar_tend
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,num_fdda3d),INTENT(INOUT)  :: fdda3d
+    REAL    ,DIMENSION(ims:ime,1:1,jms:jme,num_fdda2d),INTENT(INOUT)      :: fdda2d
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: psim
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: psih
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: wspd
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: gz1oz0
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: br
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: chklowq
+    LOGICAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: cu_act_flag
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT)         :: hol
+
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: th_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: pi_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: p_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: u_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: v_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: dz8w
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: p8w
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t8w
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rho_phy
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rho
+
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: ru_tendf
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rv_tendf
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rw_tendf
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: ph_tendf
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t_tendf
+    REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: tke_tend
+
+    REAL    ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: mu_tendf
+
+    INTEGER , INTENT(IN)                          ::  k_start, k_end
+
+!JDM
+  INTEGER, INTENT(  IN ) :: n_nba_mij, n_nba_rij
+
+  REAL ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,n_nba_mij) &
+  :: nba_mij
+
+  REAL ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,n_nba_rij) &
+  :: nba_rij
+
+! Local
+
+    REAL, DIMENSION( ims:ime, jms:jme ) :: ht_loc
+    REAL :: scale_factor
+    INTEGER, DIMENSION( ims:ime, jms:jme ) :: shadowmask 
+    INTEGER                             :: ij
+    INTEGER  num_roof_layers
+    INTEGER  num_wall_layers
+    INTEGER  num_road_layers
+    INTEGER  iswater
+    INTEGER  rk_step 
+#if ( WRF_DFI_RADAR == 1 )
+    INTEGER  i_start,i_end,j_start,j_end,i,j,k
+#endif
+#ifdef LMDZ1
+   INTEGER                                               :: iz,im2,km2,jm2
+  
+   im2=24
+   jm2=21
+   km2=38
+
+   PRINT *,'  module_first_rk_step_part2: ',im2,km2,jm2
+   PRINT  *,'    al: ',grid%al(im2,km2,jm2), ' p: ', grid%p(im2,km2,jm2),   &
+     ' ph: ',grid%ph_2(im2,km2,jm2), ' p8w: ', p8w(im2,km2,jm2)
+   PRINT *,'  Lluis checking variables k t u v p ph alt inside rk_step2 ________'
+   DO iz=kms,kme
+     PRINT *,'in0_rk_step2 ', iz, grid%t_2(im2,iz,jm2), grid%u_2(im2,iz,jm2), grid%v_2(im2,iz,jm2), &
+       grid%p(im2,iz,jm2), grid%ph_2(im2,iz,jm2), grid%alt(im2,iz,jm2), p8w(im2,iz,jm2)
+   END DO
+#endif
+
+ ! initialize all tendencies to zero in order to update physics
+ ! tendencies first (separate from dry dynamics).
+
+   rk_step = 1
+
+   stoch_force_select: SELECT CASE(config_flags%stoch_force_opt)
+
+      CASE (STOCH_BACKSCATTER)
+
+         IF ( grid%id .EQ. 1 ) THEN
+
+          !$OMP PARALLEL DO   &
+          !$OMP PRIVATE ( ij )
+          DO ij = 1 , grid%num_tiles
+
+          CALL UPDATE_STOCH(grid%SPSTREAMFORCS,grid%SPSTREAMFORCC,           &
+                         grid%SPTFORCS,grid%SPTFORCC,                        &
+                         grid%SPT_AMP,grid%SPSTREAM_AMP,                     &
+                         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 sp2gp_prep( &
+                         grid%SPSTREAMFORCS,grid%SPSTREAMFORCC,              &
+                         grid%SPTFORCS,grid%SPTFORCC,                        &
+                         grid%VERTSTRUCC,grid%VERTSTRUCS,                    &
+                         grid%RU_REAL,grid%RV_REAL,grid%RT_REAL,            & 
+                         grid%RU_IMAG,grid%RV_IMAG,grid%RT_IMAG,            & 
+                         grid%DX,grid%DY,grid%stoch_vertstruc_opt,           & 
+                         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
+
+!          Roll out into latitude bands and perform FFT along latitude bands 
+#ifdef DM_PARALLEL
+#include "XPOSE_STOCH_BACK_U_REAL_z2x.inc"
+#include "XPOSE_STOCH_BACK_U_IMAG_z2x.inc"
+#include "XPOSE_STOCH_BACK_V_REAL_z2x.inc"
+#include "XPOSE_STOCH_BACK_V_IMAG_z2x.inc"
+#include "XPOSE_STOCH_BACK_T_REAL_z2x.inc"
+#include "XPOSE_STOCH_BACK_T_IMAG_z2x.inc"
+
+           call do_fftback_along_x(                             & 
+                              grid%RU_REAL_xxx,grid%RU_IMAG_xxx,& 
+                              grid%RV_REAL_xxx,grid%RV_IMAG_xxx,& 
+                              grid%RT_REAL_xxx,grid%RT_IMAG_xxx,& 
+                              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,    &
+                              k_start , k_end                   &
+                             )
+
+!          Reassemble fields from latitude bands into 3D arrays
+! reassemble field  X_REAL and X_IMAG
+#include "XPOSE_STOCH_BACK_U_REAL_x2z.inc"
+#include "XPOSE_STOCH_BACK_U_IMAG_x2z.inc"
+#include "XPOSE_STOCH_BACK_V_REAL_x2z.inc"
+#include "XPOSE_STOCH_BACK_V_IMAG_x2z.inc"
+#include "XPOSE_STOCH_BACK_T_REAL_x2z.inc"
+#include "XPOSE_STOCH_BACK_T_IMAG_x2z.inc"
+
+!          Roll out into longitude bands and perform FFT along longitude bands 
+#include "XPOSE_STOCH_BACK_U_REAL_z2y.inc"
+#include "XPOSE_STOCH_BACK_U_IMAG_z2y.inc"
+#include "XPOSE_STOCH_BACK_V_REAL_z2y.inc"
+#include "XPOSE_STOCH_BACK_V_IMAG_z2y.inc"
+#include "XPOSE_STOCH_BACK_T_REAL_z2y.inc"
+#include "XPOSE_STOCH_BACK_T_IMAG_z2y.inc"
+
+            call do_fftback_along_y(                            & 
+                              grid%RU_REAL_yyy,grid%RU_IMAG_yyy,& 
+                              grid%RV_REAL_yyy,grid%RV_IMAG_yyy,& 
+                              grid%RT_REAL_yyy,grid%RT_IMAG_yyy,& 
+                              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,    &
+                              k_start , k_end                   &
+                             )
+
+!          Reassemble fields from longitude bands into 3D arrays
+#include "XPOSE_STOCH_BACK_U_REAL_y2z.inc"
+#include "XPOSE_STOCH_BACK_U_IMAG_y2z.inc"
+#include "XPOSE_STOCH_BACK_V_REAL_y2z.inc"
+#include "XPOSE_STOCH_BACK_V_IMAG_y2z.inc"
+#include "XPOSE_STOCH_BACK_T_REAL_y2z.inc"
+#include "XPOSE_STOCH_BACK_T_IMAG_y2z.inc"
+
+#else
+           call do_fftback_along_x(                             & 
+                              grid%RU_REAL,grid%RU_IMAG,& 
+                              grid%RV_REAL,grid%RV_IMAG,& 
+                              grid%RT_REAL,grid%RT_IMAG,& 
+                              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,    &
+                              k_start , k_end                   &
+                             )
+            call do_fftback_along_y(                            & 
+                              grid%RU_REAL,grid%RU_IMAG,& 
+                              grid%RV_REAL,grid%RV_IMAG,& 
+                              grid%RT_REAL,grid%RT_IMAG,& 
+                              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,    &
+                              k_start , k_end                   &
+                             )
+#endif
+ 
+             !$OMP PARALLEL DO   &
+             !$OMP PRIVATE ( ij )
+             DO ij = 1 , grid%num_tiles
+               CALL wrf_debug ( 200 , ' call update_stoch_ten' )
+               CALL update_stoch_ten(ru_tendf, rv_tendf, t_tendf,           &
+                               grid%ru_tendf_stoch,                          &
+                               grid%rv_tendf_stoch,                          &
+                               grid%rt_tendf_stoch,                          &
+                               grid%RU_REAL,grid%RV_REAL,grid%RT_REAL,       & 
+                               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,                               &
+                               grid%dt)
+
+             ENDDO
+             !$OMP END PARALLEL DO
+         ELSE ! (grid%id .NE> 1)
+
+          !$OMP PARALLEL DO   &
+          !$OMP PRIVATE ( ij )
+          DO ij = 1 , grid%num_tiles
+               CALL wrf_debug ( 200 , ' call update_stoch_ten_subdomains' )
+                CALL update_stoch_ten_subdomains(ru_tendf, rv_tendf, t_tendf,&
+                               grid%ru_tendf_stoch,                          &
+                               grid%rv_tendf_stoch,                          &
+                               grid%rt_tendf_stoch,                          &
+                               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,                               & 
+                               grid%dt                                       )
+
+           ENDDO
+           !$OMP END PARALLEL DO
+         END IF
+
+   END SELECT stoch_force_select
+
+#ifdef LMDZ1
+   PRINT *,'  Lluis checking variables k t u v p ph alt p8w inside in1_rk_step2 ________'
+   DO iz=kms,kme
+     PRINT *,'in1_rk_step2 ', iz, grid%t_2(im2,iz,jm2), grid%u_2(im2,iz,jm2), grid%v_2(im2,iz,jm2), &
+       grid%p(im2,iz,jm2), grid%ph_2(im2,iz,jm2), grid%alt(im2,iz,jm2), p8w(im2,iz,jm2)
+   END DO
+#endif
+
+
+! 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%mut,grid%muu,grid%muv,pi_phy, &
+                     grid%rthraten,                                    &
+                     grid%rublten,grid%rvblten,grid%rthblten,          &
+                     grid%rqvblten,grid%rqcblten,grid%rqiblten,        &
+                     grid%rucuten,grid%rvcuten,grid%rthcuten,          &
+                     grid%rqvcuten,grid%rqccuten,grid%rqrcuten,        &
+                     grid%rqicuten,grid%rqscuten,                      &
+                     grid%rushten,grid%rvshten,grid%rthshten,          &
+                     grid%rqvshten,grid%rqcshten,grid%rqrshten,        &
+                     grid%rqishten,grid%rqsshten,grid%rqgshten,        &
+                     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)
+#ifdef LMDZ1
+   PRINT *,'  Lluis checking variables k t u v p ph alt p8w inside in2_rk_step2 ________'
+   DO iz=kms,kme
+     PRINT *,'in2_rk_step2 ', iz, grid%t_2(im2,iz,jm2), grid%u_2(im2,iz,jm2), grid%v_2(im2,iz,jm2), &
+       grid%p(im2,iz,jm2), grid%ph_2(im2,iz,jm2), grid%alt(im2,iz,jm2), p8w(im2,iz,jm2)
+   END DO
+#endif
+
+! 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%ph_2, grid%phb, grid%z, grid%rdz, grid%rdzw, &
+                                       grid%zx, grid%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 "HALO_EM_TKE_C.inc"
+#  include "PERIOD_BDY_EM_A1.inc"
+#endif
+
+BENCH_START(tke_diff_bc_tim)
+         !$OMP PARALLEL DO   &
+         !$OMP PRIVATE ( ij )
+
+         DO ij = 1 , grid%num_tiles
+
+           CALL wrf_debug ( 200 , ' call bc for diffusion_metrics ' )
+           CALL set_physical_bc3d( grid%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%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%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%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%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                 )
+           CALL set_physical_bc2d( grid%ustm, '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)   )
+
+         ENDDO
+         !$OMP END PARALLEL DO
+BENCH_END(tke_diff_bc_tim)
+
+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%u_2,grid%v_2,grid%w_2,grid%div,  &
+                                     grid%defor11,grid%defor22,grid%defor33,            &
+                                     grid%defor12,grid%defor13,grid%defor23,            &
+                                     nba_rij, n_nba_rij,                                & !JDM
+                                     grid%u_base, grid%v_base,grid%msfux,grid%msfuy,    &
+                                     grid%msfvx,grid%msfvy,grid%msftx,grid%msfty,       &
+                                     grid%rdx, grid%rdy, grid%dn, grid%dnw, grid%rdz,   &
+                                     grid%rdzw,grid%fnm,grid%fnp,grid%cf1,grid%cf2,     &
+                                     grid%cf3,grid%zx,grid%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%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%tke_2,p8w,t8w,th_phy,                             &
+                                 t_phy,p_phy,moist,grid%dn,grid%dnw,                    &
+                                 grid%dx,grid%dy,grid%rdz,grid%rdzw,                    &
+                                 config_flags%mix_isotropic,num_moist,                  &
+                                 grid%cf1, grid%cf2, grid%cf3, grid%warm_rain,          &
+                                 grid%mix_upper_bound,                                  &
+                                 grid%msftx, grid%msfty,                                &
+                                 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 LMDZ1
+   PRINT *,'  Lluis checking variables k t u v p ph alt p8w inside in3_rk_step2 ________'
+   DO iz=kms,kme
+     PRINT *,'in3_rk_step2 ', iz, grid%t_2(im2,iz,jm2), grid%u_2(im2,iz,jm2), grid%v_2(im2,iz,jm2), &
+       grid%p(im2,iz,jm2), grid%ph_2(im2,iz,jm2), grid%alt(im2,iz,jm2), p8w(im2,iz,jm2)
+   END DO
+#endif
+
+#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%xkmv,grid%xkhh,grid%xkhv,     &
+                      grid%tke_2,                                  &
+                      grid%rublten, grid%rvblten,                  &
+                      grid%rucuten, grid%rvcuten,                  &
+                      grid%rushten, grid%rvshten,                  &
+                      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)
+
+!JDM
+IF ( ( config_flags%sfs_opt .GT. 0 ) .AND. ( config_flags%diff_opt .eq. 2 ) ) THEN
+
+ CALL sfs_driver( grid, config_flags,     &
+                  nba_mij, n_nba_mij,     & 
+                  nba_rij, n_nba_rij      ) 
+
+ENDIF
+
+#ifdef DM_PARALLEL
+!-----------------------------------------------------------------------
+!
+! MPP for some physics tendency, km, kh, deformation, and divergence
+!
+!                                                         * * * * * * *
+!                                            * * * * *    * * * * * * *
+!               *                     *      * * * * *    * * * * * * *
+!             * + *      * + *        +      * * + * *    * * * + * * *
+!               *                     *      * * * * *    * * * * * * *
+!                                            * * * * *    * * * * * * *
+!                                                         * * * * * * *
+!
+! (for PBL)
+! rublten                  x
+! rvblten                             x
+!
+! (for Cumulus)
+! rucuten                  x
+! rvcuten                             x
+!
+! (for Shallow Cumulus)
+! rushten                  x
+! rvshten                             x
+!
+! (for FDDA)
+! rundgdten     x
+! rvndgdten     x
+!
+! (for TKE3)
+! tke_2                                          x               
+! (for TKE5)
+! tke_2                                                         x
+!
+! (for diff_opt >= 1)
+! defor11                  x
+! defor22                             x
+! defor12       x
+! defor13                  x
+! defor23                             x
+! div           x
+! xkmv          x
+! xkmh          x
+! xkhv          x
+! xkhh          x
+! tke           x
+!
+!-----------------------------------------------------------------------
+       IF ( config_flags%bl_pbl_physics .ge. 1 ) THEN
+#      include "HALO_EM_PHYS_PBL.inc"
+       ENDIF
+       IF ( config_flags%shcu_physics .gt. 1 ) THEN
+#      include "HALO_EM_PHYS_SHCU.inc"
+       ENDIF
+       IF ( config_flags%cu_physics == SASSCHEME      .or.   &
+            config_flags%cu_physics == TIEDTKESCHEME  .or.   &
+            config_flags%cu_physics == CAMZMSCHEME    .or.   &
+            config_flags%cu_physics == NSASSCHEME ) THEN
+#      include "HALO_EM_PHYS_CU.inc"
+       ENDIF
+       IF ( config_flags%grid_fdda .ge. 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' )
+#if ( WRF_DFI_RADAR == 1 )
+         if (config_flags%cu_physics .gt. 0) then
+           i_start = grid%i_start(ij)
+           i_end   = min( grid%i_end(ij),ide-1 )
+           j_start = grid%j_start(ij)
+           j_end   = min( grid%j_end(ij),jde-1 )
+           if (config_flags%dfi_radar == 1 .and. grid%dfi_stage == DFI_FWD ) &
+                 CALL wrf_debug ( 200 , ' Zero out cu_physics' )
+           DO j = j_start, j_end
+           DO k = k_start, min( k_end,kde-1 ) - 1
+           DO i = i_start, i_end
+             if (config_flags%dfi_radar == 1 .and. grid%dfi_stage ==DFI_FWD  &
+             .and. grid%dfi_tten_rad(i,k,j) >= 1.0e-7 .and.  &
+                   grid%dfi_tten_rad(i,k,j) <= 10.) then
+! zero out cu-param temp tendency
+                grid%rthcuten(i,k,j) = 0.0
+             endif
+           ENDDO
+           ENDDO
+           ENDDO
+         ENDIF
+#endif
+         CALL update_phy_ten(ph_tendf,t_tendf, ru_tendf, rv_tendf,moist_tend ,&
+                           scalar_tend, mu_tendf,                           &
+                           grid%rthraten,grid%rthblten,grid%rthcuten,grid%rthshten, &
+                           grid%rublten,grid%rucuten,grid%rushten,          &
+                           grid%rvblten,grid%rvcuten,grid%rvshten,          &
+                           grid%rqvblten,grid%rqcblten,grid%rqiblten,       &
+                           grid%rqvcuten,grid%rqccuten,grid%rqrcuten,       &
+                           grid%rqicuten,grid%rqscuten,                     &
+                           grid%rqvshten,grid%rqcshten,grid%rqrshten,       &
+                           grid%rqishten,grid%rqsshten,grid%rqgshten,       &
+                           grid%RUNDGDTEN,                                  &
+                           grid%RVNDGDTEN,grid%RTHNDGDTEN,grid%RPHNDGDTEN,  &
+                           grid%RQVNDGDTEN,grid%RMUNDGDTEN,                 &
+                           grid%rthfrten,grid%rqvfrten,                     &  ! fire
+                           num_moist,num_scalar,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)
+
+#ifdef PLANET
+       ! do rayleigh (and zonal-average newtonian) damping during
+       ! first iteration of RK loop only
+
+       IF ( (config_flags%damp_opt == 101) .OR. &
+            (config_flags%damp_opt == 103)      ) THEN
+         !$OMP PARALLEL DO   &
+         !$OMP PRIVATE ( ij )
+         DO ij = 1 , grid%num_tiles
+           CALL damptop( grid%u_2, grid%v_2, grid%t_2, &
+                         grid%mut, grid%muu, grid%muv, &
+                         pi_phy,                                &
+                         t_tendf, ru_tendf, rv_tendf, P2SI,     &
+                         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
+       END IF
+#endif
+
+       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%u_2,grid%v_2,grid%w_2,grid%div,         &
+                         grid%tke_2,grid%mut,                         &
+                         th_phy,p_phy,p8w,t8w,grid%z,grid%fnm,        & 
+                         grid%fnp,grid%cf1,grid%cf2,grid%cf3,         &     
+                         grid%msftx,grid%msfty,grid%xkmh,             &
+                         grid%xkmv,grid%xkhv,grid%rdx,grid%rdy,       &
+                         grid%dx,grid%dy,grid%dt,grid%zx,grid%zy,     &
+                         grid%rdz,grid%rdzw,grid%dn,                  &
+                         grid%dnw,config_flags%mix_isotropic,         &
+                         grid%hfx, grid%qfx, moist(ims,kms,jms,P_QV), &
+                         grid%ustm, rho,                              &
+                         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_moist,                      &
+                                      chem_tend, num_chem,                       &
+                                      scalar_tend, num_scalar,                     &
+                                      tracer_tend, num_tracer,                     &
+                                      grid%u_2, grid%v_2,                                  &
+                                      grid%t_2,grid%u_base,grid%v_base,grid%t_base,grid%qv_base,          &
+                                      grid%mut,grid%tke_2,config_flags, &
+                                      grid%defor13,grid%defor23,grid%defor33,                   &
+                                      nba_mij, num_nba_mij,          & !JDM
+                                      grid%div, moist, chem, scalar,tracer,         &
+                                      grid%xkmv, grid%xkhv, config_flags%km_opt,                        &
+                                      grid%fnm, grid%fnp, grid%dn, grid%dnw, grid%rdz, grid%rdzw, &
+                                      grid%hfx, grid%qfx, grid%ustm, rho,        &
+                                      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_moist,                  &
+                                      chem_tend, num_chem,                   &
+                                      scalar_tend, num_scalar,                 &
+                                      tracer_tend, num_tracer,                 &
+                                      grid%t_2, th_phy,                           &
+                                      grid%mut, grid%tke_2, config_flags,              &
+                                      grid%defor11, grid%defor22, grid%defor12,             &
+                                      grid%defor13, grid%defor23,   &
+                                      nba_mij, num_nba_mij,         & !JDM
+                                      grid%div,                     &
+                                      moist, chem, scalar,tracer,               &
+                                      grid%msfux,grid%msfuy, grid%msfvx,grid%msfvy, grid%msftx,  &
+                                      grid%msfty, grid%xkmh, grid%xkhh, config_flags%km_opt,     &
+                                      grid%rdx, grid%rdy, grid%rdz, grid%rdzw,                   &
+                                      grid%fnm, grid%fnp, grid%cf1, grid%cf2, grid%cf3,          &
+                                      grid%zx, grid%zy, grid%dn, grid%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
+
+       IF ( grid%obs_nudge_opt .EQ. 1 ) THEN
+# ifdef DM_PARALLEL
+#       include "HALO_OBS_NUDGE.inc"
+#endif
+#ifdef LMDZ1
+   PRINT *,'  Lluis checking variables k t u v p ph alt p8w inside in4_rk_step2 ________'
+   DO iz=kms,kme
+     PRINT *,'in4_rk_step2 ', iz, grid%t_2(im2,iz,jm2), grid%u_2(im2,iz,jm2), grid%v_2(im2,iz,jm2), &
+       grid%p(im2,iz,jm2), grid%ph_2(im2,iz,jm2), grid%alt(im2,iz,jm2), p8w(im2,iz,jm2)
+   END DO
+#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,    &
+                   config_flags,                                        &
+                   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_npfi,                                       &
+                   grid%obs_ionf,                                       &
+                   grid%obs_prt_max,                                    &
+                   grid%obs_prt_freq,                                   &
+                   grid%obs_idynin,                                     &
+                   grid%obs_dtramp,                                     &
+                   grid%parent_grid_ratio,                              &
+                   grid%max_dom, grid%itimestep,                        &
+                   grid%xtime,                                          &
+                   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%mut, grid%muu, grid%muv,                        &
+                   grid%msftx, grid%msfty, grid%msfux, grid%msfuy, grid%msfvx, grid%msfvy, &
+                   p_phy, t_tendf, t0,                                  &
+                   grid%u_2, grid%v_2, grid%t_2,                        &
+                   moist(ims,kms,jms,P_QV),                             &
+                   grid%pb, grid%p_top, grid%p, grid%phb, grid%ph_2,    &
+                   grid%uratx, grid%vratx, grid%tratx,                  &
+                   ru_tendf, rv_tendf,                                  &
+                   moist_tend(ims,kms,jms,P_QV), grid%obs_savwt,        &
+                   grid%regime, grid%pblh, grid%z_at_w, grid%z,         &
+                   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
+       ENDIF  ! obs_nudge_opt .eq. 1
+! 
+!***********************************************************************
+
+  END SUBROUTINE first_rk_step_part2
+
+END MODULE module_first_rk_step_part2
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_force_scm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_force_scm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_force_scm.F	(revision 17)
@@ -0,0 +1,530 @@
+MODULE module_force_scm
+
+! AUTHOR: Josh Hacker (NCAR/RAL)
+! Forces a single-column (3x3) version of WRF
+
+CONTAINS
+
+   SUBROUTINE force_scm(itimestep, dt, scm_force, dx, num_force_layers       &
+                             , scm_th_adv, scm_qv_adv                        &
+                             , scm_ql_adv                                    &
+                             , scm_wind_adv, scm_vert_adv                    &
+                             , scm_soilT_force, scm_soilQ_force              &
+                             , scm_force_th_largescale                       &
+                             , scm_force_qv_largescale                       &
+                             , scm_force_ql_largescale                       &
+                             , scm_force_wind_largescale                     &
+                             , u_base, v_base, z_base                        &
+                             , z_force, z_force_tend                         &
+                             , u_g, v_g                                      &
+                             , u_g_tend, v_g_tend                            &
+                             , w_subs, w_subs_tend                           &
+                             , th_upstream_x, th_upstream_x_tend             &
+                             , th_upstream_y, th_upstream_y_tend             &
+                             , qv_upstream_x, qv_upstream_x_tend             &
+                             , qv_upstream_y, qv_upstream_y_tend             &
+                             , ql_upstream_x, ql_upstream_x_tend             &
+                             , ql_upstream_y, ql_upstream_y_tend             &
+                             , u_upstream_x, u_upstream_x_tend               &
+                             , u_upstream_y, u_upstream_y_tend               &
+                             , v_upstream_x, v_upstream_x_tend               &
+                             , v_upstream_y, v_upstream_y_tend               &
+                             , tau_x, tau_x_tend                             &
+                             , tau_y, tau_y_tend                             &
+                             ,th_largescale                                  &
+                             ,th_largescale_tend                             &
+                             ,qv_largescale                                  &
+                             ,qv_largescale_tend                             &
+                             ,ql_largescale                                  &
+                             ,ql_largescale_tend                             &
+                             ,u_largescale                                   &
+                             ,u_largescale_tend                              &
+                             ,v_largescale                                   &
+                             ,v_largescale_tend                              &
+                             ,tau_largescale                                 &
+                             ,tau_largescale_tend                            &
+                             , num_force_soil_layers, num_soil_layers        &
+                             , soil_depth_force, zs                          &
+                             , tslb, smois                                   &
+                             , t_soil_forcing_val, t_soil_forcing_tend       &
+                             , q_soil_forcing_val, q_soil_forcing_tend       &
+                             , tau_soil                                      &
+                             , z, z_at_w, th, qv, ql, u, v                   &
+                             , thten, qvten, qlten, uten, vten               &
+                             , ids, ide, jds, jde, kds, kde                  &
+                             , ims, ime, jms, jme, kms, kme                  &
+                             , ips, ipe, jps, jpe, kps, kpe                  &
+                             , kts, kte                                      &
+                            )
+
+! adds forcing to bl tendencies and also to base state/geostrophic winds.
+
+   USE module_init_utilities, ONLY : interp_0
+   IMPLICIT NONE
+
+
+   INTEGER,    INTENT(IN   )                 :: itimestep
+   INTEGER,    INTENT(IN   )                 :: num_force_layers, scm_force
+   REAL,       INTENT(IN   )                 :: dt,dx
+   LOGICAL,    INTENT(IN   )                 :: scm_th_adv, &
+                                                scm_qv_adv, &
+                                                scm_ql_adv, &
+                                                scm_wind_adv, &
+                                                scm_vert_adv, &
+                                                scm_soilT_force, &
+                                                scm_soilQ_force, &
+                                                scm_force_th_largescale, &
+                                                scm_force_qv_largescale, &
+                                                scm_force_ql_largescale, &
+                                                scm_force_wind_largescale
+
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN   ) :: z, th, qv, ql
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN   ) :: u, v
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN   ) :: z_at_w
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: thten, qvten
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: qlten
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: uten, vten
+   REAL, DIMENSION( kms:kme ), INTENT(INOUT)               :: u_base, v_base
+   REAL, DIMENSION( kms:kme ), INTENT(INOUT)               :: z_base
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT)       :: z_force
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT)       :: u_g,v_g
+
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: z_force_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: u_g_tend,v_g_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: w_subs_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: th_upstream_x_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: th_upstream_y_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: qv_upstream_x_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: qv_upstream_y_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: ql_upstream_x_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: ql_upstream_y_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: u_upstream_x_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: u_upstream_y_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: v_upstream_x_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: v_upstream_y_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: tau_x_tend
+   REAL, DIMENSION(num_force_layers), INTENT (IN) :: tau_y_tend
+
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: th_upstream_x
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: th_upstream_y
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: u_upstream_x
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: u_upstream_y
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: v_upstream_x
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: v_upstream_y
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: qv_upstream_x
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: qv_upstream_y
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: ql_upstream_x
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: ql_upstream_y
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: w_subs
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: tau_x
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: tau_y
+
+! WA 1/8/10 for large-scale forcing
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: th_largescale
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: th_largescale_tend
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: u_largescale
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: u_largescale_tend
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: v_largescale
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: v_largescale_tend
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: qv_largescale
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: qv_largescale_tend
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: ql_largescale
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: ql_largescale_tend
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: tau_largescale
+   REAL, DIMENSION(num_force_layers), INTENT (INOUT) :: tau_largescale_tend
+
+! WA 1/3/10 For soil forcing
+   INTEGER,    INTENT(IN   )         :: num_force_soil_layers, num_soil_layers
+   REAL, DIMENSION(ims:ime,num_soil_layers,jms:jme),INTENT(INOUT) :: tslb, smois
+   REAL, DIMENSION(num_force_soil_layers), INTENT (INOUT) :: t_soil_forcing_val
+   REAL, DIMENSION(num_force_soil_layers), INTENT (INOUT) :: t_soil_forcing_tend
+   REAL, DIMENSION(num_force_soil_layers), INTENT (INOUT) :: q_soil_forcing_val
+   REAL, DIMENSION(num_force_soil_layers), INTENT (INOUT) :: q_soil_forcing_tend
+   REAL, DIMENSION(num_force_soil_layers), INTENT (INOUT) :: tau_soil
+   REAL, DIMENSION(num_force_soil_layers), INTENT (IN   ) :: soil_depth_force
+   REAL, DIMENSION(num_soil_layers),       INTENT (IN   ) :: zs        
+
+   INTEGER,    INTENT(IN   )    ::     ids,ide, jds,jde, kds,kde, &
+                                       ims,ime, jms,jme, kms,kme, &
+                                       ips,ipe, jps,jpe, kps,kpe, &
+                                       kts,kte
+   
+! Local
+   INTEGER                      :: i,j,k
+   LOGICAL                      :: debug = .false.
+   REAL                         :: t_x, t_y, qv_x, qv_y, ql_x, ql_y
+   REAL                         :: u_x, u_y, v_x, v_y
+   REAL, DIMENSION(kms:kme)     :: th_adv_tend, qv_adv_tend, ql_adv_tend
+   REAL, DIMENSION(kms:kme)     :: u_adv_tend, v_adv_tend
+   REAL, DIMENSION(kms:kme)     :: dthdz, dudz, dvdz, dqvdz, dqldz
+   REAL                         :: w
+   REAL, DIMENSION(kms:kme)     :: w_dthdz, w_dudz, w_dvdz, w_dqvdz, w_dqldz
+   REAL, DIMENSION(kms:kme)     :: adv_timescale_x, adv_timescale_y
+   CHARACTER*256                :: message
+! Large-scale forcing WA 1/8/10
+   REAL                         :: t_ls, qv_ls, ql_ls
+   REAL                         :: u_ls, v_ls
+   REAL, DIMENSION(kms:kme)     :: th_ls_tend, qv_ls_tend, ql_ls_tend
+   REAL, DIMENSION(kms:kme)     :: u_ls_tend, v_ls_tend
+   REAL, DIMENSION(kms:kme)     :: ls_timescale
+! Soil forcing WA 1/3/10
+   INTEGER                      :: ks
+   REAL                         :: t_soil, q_soil
+   REAL, DIMENSION(num_soil_layers) :: t_soil_tend, q_soil_tend
+   REAL, DIMENSION(num_soil_layers) :: timescale_soil
+
+   IF ( scm_force .EQ. 0 ) return
+ 
+! NOTES
+! z is kts:kte
+! z_at_w is kms:kme
+
+     ! this is a good place for checks on the configuration
+     if ( z_force(1) > z(ids,1,jds) ) then
+        CALL wrf_message("First forcing level must be lower than first WRF half-level")
+        WRITE( message , * ) 'z forcing = ',z_force(1), 'z = ',z(ids,1,jds)
+!       print*,"z forcing = ",z_force(1), "z = ",z(ids,1,jds)
+        CALL wrf_error_fatal( message )
+     endif
+
+     z_force = z_force + dt*z_force_tend 
+     u_g = u_g + dt*u_g_tend 
+     v_g = v_g + dt*v_g_tend 
+     tau_x = tau_x + dt*tau_x_tend 
+     tau_y = tau_y + dt*tau_y_tend 
+     tau_largescale = tau_largescale + dt*tau_largescale_tend 
+
+     if ( scm_th_adv .AND. th_upstream_x(1) > 0.) then
+       th_upstream_x = th_upstream_x + dt*th_upstream_x_tend
+       th_upstream_y = th_upstream_y + dt*th_upstream_y_tend
+     endif
+     if ( scm_qv_adv .AND. qv_upstream_x(1) > 0.) then
+       qv_upstream_x = qv_upstream_x + dt*qv_upstream_x_tend
+       qv_upstream_y = qv_upstream_y + dt*qv_upstream_y_tend
+     endif
+     if ( scm_ql_adv .AND. ql_upstream_x(1) > 0.) then
+       ql_upstream_x = ql_upstream_x + dt*ql_upstream_x_tend
+       ql_upstream_y = ql_upstream_y + dt*ql_upstream_y_tend
+     endif
+     if ( scm_wind_adv .AND. u_upstream_x(1) > -900.) then
+       u_upstream_x = u_upstream_x + dt*u_upstream_x_tend
+       u_upstream_y = u_upstream_y + dt*u_upstream_y_tend
+       v_upstream_x = v_upstream_x + dt*v_upstream_x_tend
+       v_upstream_y = v_upstream_y + dt*v_upstream_y_tend
+     endif
+     if ( scm_vert_adv ) then
+       w_subs = w_subs + dt*w_subs_tend
+     endif
+
+     if ( scm_force_th_largescale .AND. th_largescale(1) > 0.) then
+       th_largescale = th_largescale + dt*th_largescale_tend
+     endif
+     if ( scm_force_qv_largescale .AND. qv_largescale(1) > 0.) then
+       qv_largescale = qv_largescale + dt*qv_largescale_tend
+     endif
+     if ( scm_force_ql_largescale.AND. ql_largescale(1) > 0.) then
+       ql_largescale = ql_largescale + dt*ql_largescale_tend
+     endif
+     if ( scm_force_wind_largescale .AND. u_largescale(1) > -900.) then
+       u_largescale = u_largescale + dt*u_largescale_tend
+       v_largescale = v_largescale + dt*v_largescale_tend
+     endif
+
+     if ( scm_soilT_force ) then
+       t_soil_forcing_val = t_soil_forcing_val + dt*t_soil_forcing_tend
+     endif
+     if ( scm_soilQ_force ) then
+       q_soil_forcing_val = q_soil_forcing_val + dt*q_soil_forcing_tend
+     endif
+
+! 0 everything in case we don't set it later
+     th_adv_tend = 0.0
+     qv_adv_tend = 0.0
+     ql_adv_tend = 0.0
+     u_adv_tend  = 0.0
+     v_adv_tend  = 0.0
+     th_ls_tend = 0.0
+     qv_ls_tend = 0.0
+     ql_ls_tend = 0.0
+     u_ls_tend  = 0.0
+     v_ls_tend  = 0.0
+     w_dthdz     = 0.0
+     w_dqvdz     = 0.0
+     w_dqldz     = 0.0
+     w_dudz      = 0.0
+     w_dvdz      = 0.0
+     adv_timescale_x = 0.0
+     adv_timescale_y = 0.0
+     
+! now interpolate forcing to model vertical grid
+
+!    if ( debug ) print*,' z u_base v_base '
+     CALL wrf_debug(100,'k z_base  u_base  v_base')
+     do k = kms,kme-1
+       z_base(k) = z(ids,k,jds)
+       u_base(k) = interp_0(u_g,z_force,z_base(k),num_force_layers)
+       v_base(k) = interp_0(v_g,z_force,z_base(k),num_force_layers)
+!      if ( debug ) print*,z_base(k),u_base(k),v_base(k)
+       WRITE( message, '(i4,3f12.4)' ) k,z_base(k),u_base(k),v_base(k)
+       CALL wrf_debug ( 100, message )
+    enddo
+
+    if ( scm_th_adv .or. scm_qv_adv .or. scm_ql_adv .or. scm_wind_adv ) then
+       if ( scm_th_adv ) CALL wrf_debug ( 100, 'k  tau_x  tau_y t_ups_x t_ups_y t_m ' )
+       do k = kms,kme-1
+          adv_timescale_x(k) = interp_0(tau_x,z_force,z(ids,k,jds),num_force_layers)
+          adv_timescale_y(k) = interp_0(tau_y,z_force,z(ids,k,jds),num_force_layers)
+       enddo
+    endif
+
+    if ( scm_th_adv ) then
+       if ( th_upstream_x(1) > 0.) then
+          do k = kms,kme-1
+             t_x = interp_0(th_upstream_x,z_force,z(ids,k,jds),num_force_layers)
+             t_y = interp_0(th_upstream_y,z_force,z(ids,k,jds),num_force_layers)
+
+             th_adv_tend(k) = (t_x-th(ids,k,jds))/adv_timescale_x(k) + (t_y-th(ids,k,jds))/adv_timescale_y(k)
+             WRITE( message, '(i4,5f12.4)' ) k,adv_timescale_x(k), adv_timescale_y(k), t_x, t_y, th(ids,k,jds)
+             CALL wrf_debug ( 100, message )
+          enddo
+       else ! WA if upstream is empty, use tendency only not value+tend
+          do k = kms,kme-1
+             t_x = interp_0(dt*th_upstream_x_tend,z_force,z(ids,k,jds),num_force_layers)
+             t_y = interp_0(dt*th_upstream_y_tend,z_force,z(ids,k,jds),num_force_layers)
+
+             th_adv_tend(k) = t_x/adv_timescale_x(k) + t_y/adv_timescale_y(k)
+             WRITE( message, '(i4,5f12.4)' ) k,adv_timescale_x(k), adv_timescale_y(k), t_x, t_y, th(ids,k,jds)
+             CALL wrf_debug ( 100, message )
+          enddo
+       endif
+    endif
+     if (minval(tau_x) < 0) then
+       print*,tau_x
+       stop 'TAU_X'
+     endif
+     if (minval(tau_y) < 0) then
+       print*,z_force
+       print*,tau_y
+       stop 'TAU_Y'
+     endif
+
+    if ( scm_qv_adv ) then
+       if ( qv_upstream_x(1) > 0.) then
+          do k = kms,kme-1
+             qv_x = interp_0(qv_upstream_x,z_force,z(ids,k,jds),num_force_layers)
+             qv_y = interp_0(qv_upstream_y,z_force,z(ids,k,jds),num_force_layers)
+
+             qv_adv_tend(k) = (qv_x-qv(ids,k,jds))/adv_timescale_x(k) + (qv_y-qv(ids,k,jds))/adv_timescale_y(k)
+             WRITE( message, * ) 'qv_adv_tend branch 1',k,adv_timescale_x(k), qv_upstream_x(k), adv_timescale_y(k), qv_x, qv_y, qv(ids,k,jds), qv_adv_tend(k)
+             CALL wrf_debug ( 100, message )
+          enddo
+       else ! WA if upstream is empty, use tendency only not value+tend
+          do k = kms,kme-1
+             qv_x = interp_0(dt*qv_upstream_x_tend,z_force,z(ids,k,jds),num_force_layers)
+             qv_y = interp_0(dt*qv_upstream_y_tend,z_force,z(ids,k,jds),num_force_layers)
+
+             qv_adv_tend(k) = qv_x/adv_timescale_x(k) + qv_y/adv_timescale_y(k)
+             WRITE( message, * ) 'qv_adv_tend branch 2',k,adv_timescale_x(k), adv_timescale_y(k), qv_upstream_x(k), qv_x, qv_y, qv(ids,k,jds), qv_adv_tend(k)
+             CALL wrf_debug ( 100, message )
+          enddo
+       endif
+    endif
+
+    if ( scm_ql_adv ) then
+       if ( ql_upstream_x(1) > 0.) then
+          do k = kms,kme-1
+             ql_x = interp_0(ql_upstream_x,z_force,z(ids,k,jds),num_force_layers)
+             ql_y = interp_0(ql_upstream_y,z_force,z(ids,k,jds),num_force_layers)
+
+             ql_adv_tend(k) = (ql_x-ql(ids,k,jds))/adv_timescale_x(k) + (ql_y-ql(ids,k,jds))/adv_timescale_y(k)
+          enddo
+       else ! WA if upstream is empty, use tendency only not value+tend
+          do k = kms,kme-1
+             ql_x = interp_0(dt*ql_upstream_x_tend,z_force,z(ids,k,jds),num_force_layers)
+             ql_y = interp_0(dt*ql_upstream_y_tend,z_force,z(ids,k,jds),num_force_layers)
+
+             ql_adv_tend(k) = ql_x/adv_timescale_x(k) + ql_y/adv_timescale_y(k)
+          enddo
+       endif
+    endif
+
+    if ( scm_wind_adv ) then
+       if ( u_upstream_x(1) > -900.) then
+          do k = kms,kme-1
+             u_x = interp_0(u_upstream_x,z_force,z(ids,k,jds),num_force_layers)
+             u_y = interp_0(u_upstream_y,z_force,z(ids,k,jds),num_force_layers)
+
+             v_x = interp_0(v_upstream_x,z_force,z(ids,k,jds),num_force_layers)
+             v_y = interp_0(v_upstream_y,z_force,z(ids,k,jds),num_force_layers)
+
+             u_adv_tend(k) = (u_x-u(ids,k,jds))/adv_timescale_x(k) + (u_y-u(ids,k,jds))/adv_timescale_y(k)
+             v_adv_tend(k) = (v_x-v(ids,k,jds))/adv_timescale_x(k) + (v_y-v(ids,k,jds))/adv_timescale_y(k)
+          enddo
+       else ! WA if upstream is empty, use tendency only not value+tend
+          do k = kms,kme-1
+             u_x = interp_0(dt*u_upstream_x_tend,z_force,z(ids,k,jds),num_force_layers)
+             u_y = interp_0(dt*u_upstream_y_tend,z_force,z(ids,k,jds),num_force_layers)
+
+             v_x = interp_0(dt*v_upstream_x_tend,z_force,z(ids,k,jds),num_force_layers)
+             v_y = interp_0(dt*v_upstream_y_tend,z_force,z(ids,k,jds),num_force_layers)
+
+             u_adv_tend(k) = u_x/adv_timescale_x(k) + u_y/adv_timescale_y(k)
+             v_adv_tend(k) = v_x/adv_timescale_x(k) + v_y/adv_timescale_y(k)
+          enddo
+       endif
+    endif
+
+! Large scale forcing starts here 1/8/10 WA
+
+    if ( scm_force_th_largescale .or. scm_force_qv_largescale .or. scm_force_ql_largescale .or. scm_force_wind_largescale ) then
+       do k = kms,kme-1
+          ls_timescale(k) = interp_0(tau_largescale,z_force,z(ids,k,jds),num_force_layers)
+       enddo
+    endif
+
+    if ( scm_force_th_largescale ) then
+       if ( th_largescale(1) > 0.) then
+          do k = kms,kme-1
+             t_ls = interp_0(th_largescale,z_force,z(ids,k,jds),num_force_layers)
+             th_ls_tend(k) = (t_ls-th(ids,k,jds))/ls_timescale(k)
+          enddo
+       else ! WA if upstream is empty, use tendency only not value+tend
+          do k = kms,kme-1
+             t_ls = interp_0(dt*th_largescale_tend,z_force,z(ids,k,jds),num_force_layers)
+             th_ls_tend(k) = t_ls/ls_timescale(k)
+          enddo
+       endif
+    endif
+
+    if ( scm_force_qv_largescale ) then
+       if ( qv_largescale(1) > 0.) then
+          do k = kms,kme-1
+             qv_ls = interp_0(qv_largescale,z_force,z(ids,k,jds),num_force_layers)
+             qv_ls_tend(k) = (qv_ls-qv(ids,k,jds))/ls_timescale(k)
+          enddo
+       else ! WA if upstream is empty, use tendency only not value+tend
+          do k = kms,kme-1
+             qv_ls = interp_0(dt*qv_largescale_tend,z_force,z(ids,k,jds),num_force_layers)
+             qv_ls_tend(k) = qv_ls/ls_timescale(k)
+          enddo
+       endif
+    endif
+
+    if ( scm_force_ql_largescale ) then
+       if ( ql_largescale(1) > 0.) then
+          do k = kms,kme-1
+             ql_ls = interp_0(ql_largescale,z_force,z(ids,k,jds),num_force_layers)
+             ql_ls_tend(k) = (ql_ls-ql(ids,k,jds))/ls_timescale(k)
+          enddo
+       else ! WA if upstream is empty, use tendency only not value+tend
+          do k = kms,kme-1
+             ql_ls = interp_0(dt*ql_largescale_tend,z_force,z(ids,k,jds),num_force_layers)
+             ql_ls_tend(k) = ql_ls/ls_timescale(k)
+          enddo
+       endif
+    endif
+
+    if ( scm_force_wind_largescale ) then
+       if ( u_largescale(1) > -900.) then
+          do k = kms,kme-1
+             u_ls = interp_0(u_largescale,z_force,z(ids,k,jds),num_force_layers)
+             v_ls = interp_0(v_largescale,z_force,z(ids,k,jds),num_force_layers)
+             u_ls_tend(k) = (u_ls-u(ids,k,jds))/ls_timescale(k)
+             v_ls_tend(k) = (v_ls-v(ids,k,jds))/ls_timescale(k)
+          enddo
+       else ! WA if upstream is empty, use tendency only not value+tend
+          do k = kms,kme-1
+             u_ls = interp_0(dt*u_largescale_tend,z_force,z(ids,k,jds),num_force_layers)
+             v_ls = interp_0(dt*v_largescale_tend,z_force,z(ids,k,jds),num_force_layers)
+             u_ls_tend(k) = u_ls/ls_timescale(k)
+             v_ls_tend(k) = v_ls/ls_timescale(k)
+          enddo
+       endif
+    endif
+
+! Now do vertical advection.  Note that no large-scale vertical advection
+! is implemented at this time, may not make sense anyway (WA).
+! loops are set so that the top and bottom (w=0) are handled correctly
+! vertical derivatives
+    do k = kms+1,kme-1
+       dthdz(k) = (th(2,k,2)-th(2,k-1,2))/(z(2,k,2)-z(2,k-1,2))
+       dqvdz(k) = (qv(2,k,2)-qv(2,k-1,2))/(z(2,k,2)-z(2,k-1,2))
+       dqldz(k) = (ql(2,k,2)-ql(2,k-1,2))/(z(2,k,2)-z(2,k-1,2))
+       dudz(k)  = (u(2,k,2)-u(2,k-1,2))/(z(2,k,2)-z(2,k-1,2))
+       dvdz(k)  = (v(2,k,2)-v(2,k-1,2))/(z(2,k,2)-z(2,k-1,2))
+    enddo
+
+! w on full levels, then advect
+    if ( scm_vert_adv ) then
+       do k = kms+1,kme-1
+          w = interp_0(w_subs,z_force,z_at_w(ids,k,jds),num_force_layers)
+          w_dthdz(k) = w*dthdz(k)
+          w_dqvdz(k) = w*dqvdz(k)
+          w_dqldz(k) = w*dqldz(k)
+          w_dudz(k)  = w*dudz(k)
+          w_dvdz(k)  = w*dvdz(k)
+       enddo
+    endif
+
+! set tendencies for return
+! vertical advection tendencies need to be interpolated back to half levels
+    CALL wrf_debug ( 100, 'j, k, th_adv_ten, qv_adv_ten, ql_adv_ten, u_adv_ten, v_adv_ten')
+    do j = jms,jme
+    do k = kms,kme-1
+    if(j==1) WRITE( message, * ) k,th_adv_tend(k),qv_adv_tend(k),ql_adv_tend(k), u_adv_tend(k),v_adv_tend(k)
+    if(j==1) CALL wrf_debug ( 100, message )
+    do i = ims,ime
+       thten(i,k,j) = thten(i,k,j) + th_adv_tend(k) +              &
+                      0.5*(w_dthdz(k) + w_dthdz(k+1))              &
+                      + th_ls_tend(k)
+       qvten(i,k,j) = qvten(i,k,j) + qv_adv_tend(k) +              &
+                      0.5*(w_dqvdz(k) + w_dqvdz(k+1))              &
+                      + qv_ls_tend(k)
+       qlten(i,k,j) = qlten(i,k,j) + ql_adv_tend(k) +              &
+                      0.5*(w_dqldz(k) + w_dqldz(k+1))              &
+                      + ql_ls_tend(k)
+       uten(i,k,j)  = uten(i,k,j) + u_adv_tend(k) +                &
+                      0.5*(w_dudz(k) + w_dudz(k+1))                &
+                      + u_ls_tend(k)
+       vten(i,k,j)  = vten(i,k,j) + v_adv_tend(k) +                &
+                      0.5*(w_dvdz(k) + w_dvdz(k+1))                &
+                      + v_ls_tend(k)
+    enddo
+    enddo
+    enddo
+
+! soil forcing 1/3/10 WA
+    if ( scm_soilT_force ) then
+       do ks = 1,num_soil_layers
+          t_soil = interp_0(t_soil_forcing_val,soil_depth_force,zs(ks),num_force_soil_layers)
+          timescale_soil(ks) = interp_0(tau_soil,soil_depth_force,zs(ks),num_force_soil_layers)
+          t_soil_tend(ks) = (t_soil-tslb(ids,ks,jds))/timescale_soil(ks)
+       enddo
+       do j = jms,jme
+          do ks = 1,num_soil_layers
+             do i = ims,ime
+                tslb(ids,ks,jds) = tslb(ids,ks,jds) + t_soil_tend(ks)
+             enddo
+          enddo
+       enddo
+    endif
+    if ( scm_soilQ_force ) then
+       do ks = 1,num_soil_layers
+          q_soil = interp_0(q_soil_forcing_val,soil_depth_force,zs(ks),num_force_soil_layers)
+          timescale_soil(ks) = interp_0(tau_soil,soil_depth_force,zs(ks),num_force_soil_layers)
+          q_soil_tend(ks) = (q_soil-smois(ids,ks,jds))/timescale_soil(ks)
+       enddo
+       do j = jms,jme
+          do ks = 1,num_soil_layers
+             do i = ims,ime
+                smois(ids,ks,jds) = smois(ids,ks,jds) + q_soil_tend(ks)
+             enddo
+          enddo
+       enddo
+    endif
+
+    RETURN
+
+   END SUBROUTINE force_scm
+
+END MODULE module_force_scm
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_init_utilities.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_init_utilities.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_init_utilities.F	(revision 17)
@@ -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
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_b_wave.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_b_wave.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_b_wave.F	(revision 17)
@@ -0,0 +1,941 @@
+!IDEAL:MODEL_LAYER:INITIALIZATION
+
+!  This MODULE holds the routines which are used to perform various initializations
+!  for the individual domains.  
+
+!-----------------------------------------------------------------------
+
+MODULE module_initialize_ideal
+
+   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 :: idum1, idum2
+
+   CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+     CALL init_domain_rk( grid &
+!
+#include <actual_new_args.inc>
+!
+                        )
+
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain_rk ( grid &
+!
+# include <dummy_new_args.inc>
+!
+)
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include <dummy_decl.inc>
+
+   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)
+
+   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_pole_lon (1,0.)
+    CALL nl_set_pole_lat (1,90.)
+    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%msftx(i,j)    = 1.
+         grid%msfty(i,j)    = 1.
+         grid%msfux(i,j)    = 1.
+         grid%msfuy(i,j)    = 1.
+         grid%msfvx(i,j)    = 1.
+         grid%msfvx_inv(i,j)= 1.
+         grid%msfvy(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%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%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%znw(k) = 1. - float(k-1)/float(kde-1)
+     ENDDO
+   ENDIF
+
+   DO k=1, kde-1
+    grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
+    grid%rdnw(k) = 1./grid%dnw(k)
+    grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
+   ENDDO
+   DO k=2, kde-1
+    grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
+    grid%rdn(k) = 1./grid%dn(k)
+    grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
+    grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
+   ENDDO
+
+   cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) 
+   cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) 
+   grid%cf1  = grid%fnp(2) + cof1
+   grid%cf2  = grid%fnm(2) - cof1 - cof2
+   grid%cf3  = cof2       
+
+   grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
+   grid%cfn1 = -.5*grid%dnw(kde-1)/grid%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%phb(i,1,j) = 0.
+    grid%php(i,1,j) = 0.
+    grid%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%phb(i,1,j)/g, nl_in )
+    grid%mub(i,j) = p_surf-grid%p_top
+
+!  this is dry hydrostatic sounding (base state), so given grid%p (coordinate),
+!  interp theta (from interp) and compute 1/rho from eqn. of state
+
+    DO K = 1, kte-1
+      p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%pb(i,k,j) = p_level
+      grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0
+      grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%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%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j)
+    ENDDO
+
+  ENDDO
+  ENDDO
+
+  write(6,*) ' ptop is ',grid%p_top
+  write(6,*) ' base state grid%mub(1,1), p_surf is ',grid%mub(1,1),grid%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%phb(i,1,j)/g, nl_in )
+
+!   compute the perturbation mass and the full mass
+
+    grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j)
+    grid%mu_2(i,j) = grid%mu_1(i,j)
+    grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j)
+
+!   given the dry pressure and coordinate system, interp the potential
+!   temperature and qv
+
+    do k=1,kde-1
+
+      p_level = grid%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%t_1(i,k,j)          = interp_0( theta, pd_in, p_level, nl_in ) - t0
+      grid%t_2(i,k,j)          = grid%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%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%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k)
+    grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+    qvf = 1. + rvovrd*grid%moist(i,k,j,P_QV)
+    grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+    grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+      qvf = 1. + rvovrd*grid%moist(i,k,j,P_QV)
+      grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                  (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+      grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+    enddo
+
+!  this is the hydrostatic equation used in the model after the
+!  small timesteps.  In the model, grid%al (inverse density)
+!  is computed from the geopotential.
+
+
+    grid%ph_1(i,1,j) = 0.
+    DO k  = 2,kte
+      grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                   (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                    grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+      grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+      grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+    ENDDO
+
+! interp u
+
+    DO K = 1, kte
+      p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in )
+      grid%u_2(i,k,j) = grid%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%ph_1(i,k,j)+grid%ph_1(i,k+1,j)  &
+                   +grid%phb(i,k,j)+grid%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%t_1(i,k,j)=grid%t_1(i,k,j)+tp
+           grid%t_2(i,k,j)=grid%t_1(i,k,j)
+           qvf = 1. + rvovrd*grid%moist(i,k,j,P_QV)
+           grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                        (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+           grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+        ENDIF
+      ENDDO
+
+!  rebalance hydrostatically
+
+      DO k  = 2,kte
+        grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                     (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                      grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+        grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+        grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+      ENDDO
+
+    ENDDO
+  ENDDO
+
+!#endif
+
+   write(6,*) ' grid%mu_1 from comp ', grid%mu_1(1,1)
+   write(6,*) ' pert state sounding from comp, grid%ph_1, pp, grid%al, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1),grid%p(1,k,1), grid%al(1,k,1), &
+                     grid%t_1(1,k,1), grid%moist(1,k,1,P_QV)
+   enddo
+
+   write(6,*) ' grid%mu_1 from comp ', grid%mu_1(1,1)
+   write(6,*) ' full state sounding from comp, ph, grid%p, grid%al, grid%t_1, qv '
+   write(6,*) ' at j = 1 '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1)+grid%phb(1,k,1), &
+                     grid%p(1,k,1)+grid%pb(1,k,1), grid%al(1,k,1)+grid%alb(1,k,1), &
+                     grid%t_1(1,k,1)+t0, grid%moist(1,k,1,P_QV)
+   enddo
+
+
+   write(6,*) ' full state sounding from comp, ph, grid%p, grid%al, grid%t_1, qv '
+   write(6,*) ' at j = jde/2 '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,jde/2)+grid%phb(1,k,jde/2), &
+                     grid%p(1,k,jde/2)+grid%pb(1,k,jde/2), grid%al(1,k,jde/2)+grid%alb(1,k,jde/2), &
+                     grid%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%p, grid%al, grid%t_1, qv '
+   write(6,*) ' at j = jde-1 '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,jde-1)+grid%phb(1,k,jde-1), &
+                     grid%p(1,k,jde-1)+grid%pb(1,k,jde-1), grid%al(1,k,jde-1)+grid%alb(1,k,jde-1), &
+                     grid%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%v_1(i,k,j) = 0.
+      grid%v_2(i,k,j) = grid%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%u_1(i,k,j) = grid%u_1(its,k,j)
+      grid%u_2(i,k,j) = grid%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%w_1(i,k,j) = 0.
+    grid%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%t_base(k) = grid%t_1(1,k,1)
+    grid%qv_base(k) = grid%moist(1,k,1,P_QV)
+    grid%u_base(k) = grid%u_1(1,k,1)
+    grid%v_base(k) = grid%v_1(1,k,1)
+  ENDDO
+
+  DO J = jts, min(jde-1,jte)
+  DO I = its, min(ide-1,ite)
+     thtmp   = grid%t_2(i,1,j)+t0
+     ptmp    = grid%p(i,1,j)+grid%pb(i,1,j)
+     temp(1) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,2,j)+t0
+     ptmp    = grid%p(i,2,j)+grid%pb(i,2,j)
+     temp(2) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,3,j)+t0
+     ptmp    = grid%p(i,3,j)+grid%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 r
+    parameter (r = r_d)
+    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
+
+!  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_ideal
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_fire.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_fire.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_fire.F	(revision 17)
@@ -0,0 +1,1139 @@
+!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_ideal
+
+   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
+   USE module_soil_pre        !AK/ak for full surface initialization
+#ifdef DM_PARALLEL
+   USE module_dm
+#endif
+   USE module_fr_sfire_util, ONLY: continue_at_boundary,crash,read_array_2d_real, &
+     read_array_2d_integer,interpolate_2d,set_ideal_coord 
+
+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 :: idum1, idum2
+
+   CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+     CALL init_domain_rk( grid &
+!
+#include <actual_new_args.inc>
+!
+                        )
+
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain_rk ( grid &
+!
+# include <dummy_new_args.inc>
+!
+)
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include <dummy_new_decl.inc>
+
+   TYPE (grid_config_rec_type)              :: config_flags
+
+   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
+
+   !  Local data
+   INTEGER                             ::                       &
+                                  ids, ide, jds, jde, kds, kde, &
+                                  ims, ime, jms, jme, kms, kme, &
+                                  its, ite, jts, jte, kts, kte, &
+                                  i, j, k
+
+   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    :: x_rad, y_rad, z_rad, hght_pert   !Ak/ak
+   character (len=256) :: mminlu2              !AK/ak land use scheme (USGS)
+!   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_grd, dry_sounding
+   LOGICAL :: stretch_hyp, sfc_init           !AK/ak switches for hyperbolic grid streching and surface initialization
+
+   INTEGER :: xs , xe , ys , ye
+   INTEGER :: mtn_type
+   INTEGER :: &  ! fire mesh sizes
+              iots,iote,jots,jote, &            ! tile dims out
+             ifds,ifde, kfds,kfde, jfds,jfde,                              &
+             ifms,ifme, kfms,kfme, jfms,jfme,                              &
+             ifts,ifte, kfts,kfte, jfts,jfte
+
+   REAL :: mtn_ht, mtn_max, mtn_x, mtn_y, mtn_z, grad_max
+   REAL :: mtn_axs, mtn_ays, mtn_axe, mtn_aye
+   REAL :: mtn_fxs, mtn_fys, mtn_fxe, mtn_fye
+   REAL :: mtn_xs, mtn_ys, mtn_xe, mtn_ye
+   REAL :: fdx,fdy ! fire mesh step
+   INTEGER:: ir,jr ! refinement factors
+
+   logical have_fire_ht,have_fire_grad,have_atm_grad
+
+!*** executable
+
+   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
+
+!   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 )
+ 
+    delt = config_flags%delt_perturbation
+    x_rad = config_flags%xrad_perturbation
+    y_rad = config_flags%yrad_perturbation
+    z_rad = config_flags%zrad_perturbation
+    hght_pert = config_flags%hght_perturbation
+
+    stretch_grd = config_flags%stretch_grd   
+    stretch_hyp = config_flags%stretch_hyp
+        z_scale = config_flags%z_grd_scale
+       sfc_init = config_flags%sfc_full_init
+  
+ moisture_init = .true.   !AK/ak
+
+    grid%itimestep=0
+
+#ifdef DM_PARALLEL
+   CALL wrf_dm_bcast_bytes( icm , IWORDSIZE )
+   CALL wrf_dm_bcast_bytes( jcm , IWORDSIZE )
+#endif
+
+!AK/ak land use initialization (USGS) 
+   IF (sfc_init) THEN  
+    mminlu2=' '
+    mminlu2(1:4) = 'USGS'                !Ak/ak
+    CALL nl_set_mminlu(1, mminlu2)       !Ak/ak
+    CALL nl_get_iswater(1,grid%iswater) ! Ak/ak
+   ENDIF
+
+    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_pole_lon (1,0.)
+    CALL nl_set_pole_lat (1,90.)
+    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%msftx(i,j)    = 1.
+         grid%msfty(i,j)    = 1.
+         grid%msfux(i,j)    = 1.
+         grid%msfuy(i,j)    = 1.
+         grid%msfvx(i,j)    = 1.
+         grid%msfvx_inv(i,j)= 1.
+         grid%msfvy(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     
+
+!AK/ak surface initialization latitude, longitude, landuse index from from LANDUSE.TBL skin temperature and soil temperature
+write(6,*) '*************************************'
+   IF (sfc_init) THEN
+    DO j = jts, jte
+      DO i = its, ite
+          grid%xlat(i,j) = config_flags%fire_lat_init     !Ak/sk (35)
+         grid%xlong(i,j) = config_flags%fire_lon_init     !Ak/ak (-111)
+         grid%xland(i,j) = 1.                             !Ak/ak
+      grid%lu_index(i,j) = config_flags%sfc_lu_index      !AK/ak land use index (28)
+           grid%tsk(i,j) = config_flags%sfc_tsk           !AK/ak  surface skin temperature [K] (285)
+           grid%tmn(i,j) = config_flags%sfc_tmn           !AK/ak  soil temperature at lower boundary [K] (285)
+      END DO
+    END DO
+      ! read land use data from files, overwriting the constant 
+      if(config_flags%fire_read_lu) &
+          call read_array_2d_real('input_lu',grid%lu_index,ids,ide,jds,jde,ims,ime,jms,jme) 
+      if(config_flags%fire_read_tsk) &
+          call read_array_2d_real   ('input_tsk',grid%tsk,    ids,ide,jds,jde,ims,ime,jms,jme) 
+      if(config_flags%fire_read_tmn) &
+          call read_array_2d_real   ('input_tmn',grid%tmn,    ids,ide,jds,jde,ims,ime,jms,jme) 
+
+! for Noah LSM, additional variables need to be initializedi  !AK/ak |
+
+  other_masked_fields : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
+
+      CASE (SLABSCHEME)
+      write(6,*) ' SLAB surface scheme activated'
+
+      CASE (LSMSCHEME)
+      write(6,*) ' Noah unified LSM scheme activated with:'
+      write(6,*) '    vegetation fraction=',config_flags%sfc_vegfra
+      write(6,*) '          canopy  water=',config_flags%sfc_canwat
+      write(6,*) '     dominant veg. type=',config_flags%sfc_ivgtyp
+      write(6,*) '     dominant soil type=',config_flags%sfc_isltyp
+
+        DO j = jts , MIN(jde-1,jte)
+           DO i = its , MIN(ide-1,ite)
+               grid%vegfra(i,j) = config_flags%sfc_vegfra  !0.5
+               grid%canwat(i,j) = config_flags%sfc_canwat  !0.
+               grid%ivgtyp(i,j) = config_flags%sfc_ivgtyp  !18
+               grid%isltyp(i,j) = config_flags%sfc_isltyp  !7
+               grid%xice(i,j) = 0.
+               grid%snow(i,j) = 0.
+           END DO
+        END DO
+
+      CASE (RUCLSMSCHEME)
+       write(6,*) ' RUS surface scheme activated'
+    END SELECT other_masked_fields                         !AK/ak |
+
+    ENDIF
+
+    DO j = jts, jte
+    DO k = kts, kte
+      DO i = its, ite
+         grid%ww(i,k,j)     = 0.
+      END DO
+   END DO
+   END DO
+
+   grid%step_number = 0
+
+   IF (sfc_init) THEN
+
+      write(6,*) ' full surface initialization activated '
+      ! write(6,*) ' land use index =', config_flags%sfc_lu_index
+      ! write(6,*) ' skin temperature=',grid%tsk(10,10),&
+      !         '[K] soil temperature=', grid%tmn(10,10),'[K]'    
+! Process the soil; note that there are some things hard-wired into share/module_soil_pre.F
+      CALL process_soil_ideal(grid%xland,grid%xice,grid%vegfra,grid%snow,grid%canwat, &
+                     grid%ivgtyp,grid%isltyp,grid%tslb,grid%smois, &
+                     grid%tsk,grid%tmn,grid%zs,grid%dzs,model_config_rec%num_soil_layers, &
+                     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 )
+
+
+     ELSE
+      write(6,*) 'full surface initialization is turned off!! '
+    ENDIF    !end of surface initialization
+
+! set up the grid
+   write(6,*) '*************************************'
+
+   IF (stretch_grd) THEN ! exponential or hyperbolic tangential stretch for eta
+
+    IF (stretch_hyp) THEN ! hyperbolic tangential stretch (more levels at the surface)
+     write(6,*) ' hyperbolic tangential stretching activated with z_scale =',z_scale
+     DO k=1, kde          
+      grid%znw(k) = -1.* (tanh(z_scale*(float(k-1) / float(kde-1) -1.)))/ &
+                                 (tanh(z_scale))
+     ENDDO
+    ELSE                 ! exponential stretch for eta (nearly constant dz)
+    write(6,*) ' exponential grid stretching activated with z_scale =',z_scale
+     DO k=1, kde 
+     grid%znw(k) = (exp(-(k-1)/float(kde-1)/z_scale) - exp(-1./z_scale))/ &
+                            (1.-exp(-1./z_scale))
+     ENDDO
+    ENDIF 
+   ELSE
+   write(6,*) ' no grid stretching'
+     DO k=1, kde 
+      grid%znw(k) = 1. - float(k-1)/float(kde-1)
+     ENDDO
+   ENDIF
+   write(6,*) '*************************************'
+
+   DO k=1, kde-1
+    grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
+    grid%rdnw(k) = 1./grid%dnw(k)
+    grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
+   ENDDO
+   DO k=2, kde-1
+    grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
+    grid%rdn(k) = 1./grid%dn(k)
+    grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
+    grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
+   ENDDO
+
+   cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) 
+   cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) 
+   grid%cf1  = grid%fnp(2) + cof1
+   grid%cf2  = grid%fnm(2) - cof1 - cof2
+   grid%cf3  = cof2       
+
+   grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
+   grid%cfn1 = -.5*grid%dnw(kde-1)/grid%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 )
+
+! get fire mesh dimensions
+    CALL get_ijk_from_subgrid (  grid ,                   &
+       ifds,ifde, jfds,jfde,kfds,kfde, & 
+       ifms,ifme, jfms,jfme,kfms,kfme,  & 
+       ifts,ifte, jfts,jfte,kfts,kfte)
+
+  write (6,*)' ******** SFIRE ideal initialization ********'
+
+  ! fire grid step size
+  fdx = grid%dx/grid%sr_x
+  fdy = grid%dy/grid%sr_y
+  ! refinement ratios
+  ir = grid%sr_x
+  jr = grid%sr_y
+
+  write (6,*)' atm  mesh step ',grid%dx,grid%dy
+  write (6,*)' fire mesh step ',fdx,fdy
+  write (6,*)' refinement ratio ',grid%sr_x,grid%sr_y
+  write (6,*)' atm  domain bounds ',ids,ide, jds,jde,kds,kde
+  write (6,*)' atm  memory bounds ',ims,ime, jms,jme,kms,kme
+  write (6,*)' atm  tile   bounds ',its,ite, jts,jte,kts,kte
+  write (6,*)' fire domain bounds ',ifds,ifde, jfds,jfde,kfds,kfde
+  write (6,*)' fire memory bounds ',ifms,ifme, jfms,jfme,kfms,kfme
+  write (6,*)' fire tile   bounds ',ifts,ifte, jfts,jfte,kfts,kfte
+  write (6,*)' Note that atm mesh and fire mesh are cell-centered'
+
+! set ideal coordinates
+  call set_ideal_coord( fdx,fdy, &
+                ifds,ifde,jfds,jfde,  &
+                ifms,ifme,jfms,jfme,  &
+                ifts,ifte,jfts,jfte,  &
+                grid%fxlong,grid%fxlat          )
+  call set_ideal_coord( grid%dx,grid%dy, &
+                ids,ide,jds,jde,  &
+                ims,ime,jms,jme,  &
+                its,ite,jts,jte,  &
+                grid%xlong,grid%xlat          )
+
+! set terrain height
+
+  DO j=jts,jte
+  DO i=its,ite
+    grid%ht(i,j) = 0.
+  ENDDO
+  ENDDO
+
+  if(config_flags%fire_fuel_read.eq.2) &
+      call read_array_2d_real('input_fc',grid%nfuel_cat,ifds,ifde,jfds,jfde,ifms,ifme,jfms,jfme) 
+
+
+  have_fire_grad=.false.
+  have_atm_grad=.false.
+  have_fire_ht=.false.
+
+  !******* set terrain height
+
+  ! copy params from the namelist
+  mtn_type = config_flags%fire_mountain_type
+  mtn_xs   = config_flags%fire_mountain_start_x
+  mtn_ys   = config_flags%fire_mountain_start_y
+  mtn_xe   = config_flags%fire_mountain_end_x
+  mtn_ye   = config_flags%fire_mountain_end_y
+  mtn_ht   = config_flags%fire_mountain_height
+
+  IF(mtn_type .ne. 0)THEN
+
+    ! idealized mountain
+
+    ! atmospheric grid coordinates of the mountain
+    mtn_axs = mtn_xs/grid%dx + ids - 0.5 
+    mtn_axe = mtn_xe/grid%dx + ids - 0.5
+    mtn_ays = mtn_ys/grid%dy + jds - 0.5
+    mtn_aye = mtn_ye/grid%dy + jds - 0.5
+
+    ! fire grid coordinates of the mountain
+    mtn_fxs = mtn_xs/fdx + ifds - 0.5 
+    mtn_fxe = mtn_xe/fdx + ifds - 0.5
+    mtn_fys = mtn_ys/fdy + jfds - 0.5
+    mtn_fye = mtn_ye/fdy + jfds - 0.5
+
+    write(6,*)' Mountain height ',mtn_ht,' type',mtn_type
+    write(6,*)' Mountain (m) LL=(0,0) ',mtn_xs,':',mtn_xe,' ',mtn_ys,':',mtn_ye
+    write(6,*)' Mountain on atm grid  ',mtn_axs,':',mtn_axe,' ',mtn_ays,':',mtn_aye
+    write(6,*)' Mountain on fire grid ',mtn_fxs,':',mtn_fxe,' ',mtn_fys,':',mtn_fye
+
+    mtn_max = 0.
+    DO j=jts,jte
+    DO i=its,ite
+      mtn_x = pi + 2*pi* max(0. , min( (i - mtn_axs)/(mtn_axe - mtn_axs), 1. ))
+      mtn_y = pi + 2*pi* max(0. , min( (j - mtn_ays)/(mtn_aye - mtn_ays), 1. ))
+      SELECT CASE(mtn_type)
+        CASE (1) ! circ/elliptic mountain
+          mtn_z = mtn_ht * 0.25 * (1. + COS(mtn_x))*(1. + COS(mtn_y))
+        CASE (2)  ! EW ridge
+          mtn_z = mtn_ht * 0.5 * (1. + COS(mtn_y))
+        CASE (3)  ! NS ridge
+          mtn_z = mtn_ht * 0.5 * (1. + COS(mtn_x))
+        CASE DEFAULT
+          call wrf_error_fatal ( ' bad fire_mountain_type ' )
+      END SELECT
+      mtn_max = max(mtn_max, mtn_z)
+      grid%ht(i,j) = mtn_z
+    ENDDO
+    ENDDO
+
+    write(6, *)' Atm  tile ',its,':',ite,' ',jts,':',jte,' max terrain height ',mtn_max
+
+    DO j=jfts,jfte
+        DO i=ifts,ifte
+          mtn_x = pi + 2*pi* max(0. , min( (i - mtn_fxs)/(mtn_fxe - mtn_fxs), 1. ))
+          mtn_y = pi + 2*pi* max(0. , min( (j - mtn_fys)/(mtn_fye - mtn_fys), 1. ))
+          SELECT CASE(mtn_type)
+            CASE (1) ! circ/elliptic mountain
+              mtn_z = mtn_ht * 0.25 * (1. + COS(mtn_x))*(1. + COS(mtn_y))
+            CASE (2)  ! EW ridge
+              mtn_z = mtn_ht * 0.5 * (1. + COS(mtn_y))
+            CASE (3)  ! NS ridge
+              mtn_z = mtn_ht * 0.5 * (1. + COS(mtn_x))
+            CASE DEFAULT
+              call wrf_error_fatal ( ' bad fire_mountain_type ' )
+          END SELECT
+          grid%zsf(i,j) = mtn_z
+        ENDDO
+    ENDDO
+ 
+    have_fire_ht=.true.
+
+  ELSE ! mtn_type 
+
+    if(config_flags%fire_read_atm_ht)then !
+      call read_array_2d_real('input_ht',grid%ht,ids,ide,jds,jde,ims,ime,jms,jme) 
+      ! no flag - we always have the terrain height on atm mesh, zero if not set
+    endif
+
+    if(config_flags%fire_read_fire_ht)then !
+      call read_array_2d_real('input_zsf',grid%zsf,ifds,ifde,jfds,jfde,ifms,ifme,jfms,jfme) 
+      have_fire_ht=.true.
+    endif
+
+    if(config_flags%fire_read_atm_grad)then !
+      call crash('Reading terrain gradient on atm mesh from file not supported.')
+      have_atm_grad=.true.
+    endif
+
+    if(config_flags%fire_read_fire_grad)then !
+      call read_array_2d_real('input_dzdxf',grid%dzdxf,ifds,ifde,jfds,jfde,ifms,ifme,jfms,jfme) 
+      call read_array_2d_real('input_dzdyf',grid%dzdyf,ifds,ifde,jfds,jfde,ifms,ifme,jfms,jfme) 
+      have_fire_grad=.true.
+    endif
+  ENDIF  ! mtn_type
+
+  if(have_fire_ht)then 
+      write(6, *)'Fine-resolution terrain height on the fire mesh used.'
+  else
+      write(6,*)'Interpolating the terrain height from the atm mesh to the fire mesh'
+      call interpolate_2d(  &
+        ims,ime,jms,jme, & ! memory dims atm grid tile
+        its,ite,jts,jte, & ! where atm grid values set
+        ifms,ifme,jfms,jfme,    & ! array dims fire grid
+        ifts,ifte,jfts,jfte,  & ! dimensions fire grid tile
+        ir,jr,                & ! refinement ratio
+        real(ids),real(jds),ifds+(ir-1)*0.5,jfds+(jr-1)*0.5, & ! line up by lower left corner of domain
+        grid%ht,                                      & ! atm grid arrays in
+        grid%zsf)                                      ! fire grid arrays out
+      have_fire_ht=.true.
+  endif
+
+
+  if(have_fire_grad)then 
+     write(6, *)'Fine-resolution terrain gradient on the fire mesh used.'
+  else
+
+     write(6,*)'Computing the terrain gradient from fire mesh height'
+     if(.not.have_fire_ht)then
+        write(6,*)'WARNING: Fire mesh terrain height not given, setting to zero'
+        do j=jfts,jfte
+           do i=ifts,ifte
+              grid%zsf(i,j) = 0.
+           enddo
+        enddo
+      endif
+   
+      ! extend the terrain height one beyond the domain
+      call continue_at_boundary(1,1,0., & ! do x direction or y direction
+              ifms,ifme,jfms,jfme, &            ! memory dims
+              ifds,ifde,jfds,jfde, &            ! domain dims
+              ifds,ifde,jfds,jfde, &            ! patch dims = domain, not parallel!
+              ifts,ifte,jfts,jfte, &            ! tile dims
+              iots,iote,jots,jote, &            ! tile dims out
+              grid%zsf)                         ! array
+  
+      ! compute the terrain gradient by differencing
+      do j=jfts,jfte
+         do i=ifts,ifte
+            grid%dzdxf(i,j) = (grid%zsf(i+1,j)-grid%zsf(i-1,j))/(2.*fdx)
+            grid%dzdyf(i,j) = (grid%zsf(i,j+1)-grid%zsf(i,j-1))/(2.*fdy)
+         enddo
+      enddo
+      have_fire_grad=.true.
+   endif ! have_fire_grad
+   
+   if(.not.have_fire_grad)call crash('Fire mesh terrain gradient not set')
+ 
+    mtn_max = 0.
+    DO j=jts,jte
+      DO i=its,ite
+        mtn_max = max(mtn_max, grid%ht(i,j))
+      ENDDO
+    ENDDO
+    write(6, *)' Max terrain height on the atmosphere mesh ',mtn_max
+
+    mtn_max = 0.
+    grad_max =0.
+    DO j=jfts,jfte
+      DO i=ifts,ifte
+        mtn_max = max(mtn_max, grid%zsf(i,j))
+        grad_max = max( grad_max, sqrt(grid%dzdxf(i,j)**2+grid%dzdyf(i,j)**2) )
+      ENDDO
+    ENDDO
+    write(6, *)' Max terrain height on the fire mesh       ',mtn_max
+    write(6, *)' Max terrain gradient on the fire mesh     ',grad_max
+  
+! the rest of initialization dependent on the atmosphere grid terrain height set
+
+  DO j=jts,jte
+  DO i=its,ite
+    grid%phb(i,1,j) = g * grid%ht(i,j)
+    grid%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%phb(i,1,j)/g, nl_in )
+    grid%mub(i,j) = p_surf-grid%p_top
+
+!  this is dry hydrostatic sounding (base state), so given grid%p (coordinate),
+!  interp theta (from interp) and compute 1/rho from eqn. of state
+
+    DO K = 1, kte-1
+      p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%pb(i,k,j) = p_level
+      grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0
+      grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%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%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%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%mub(1,1), p_surf is ',grid%mub(1,1),grid%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%phb(i,1,j)/g, nl_in )
+
+!  compute the perturbation mass and the full mass
+
+    grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j)
+    grid%mu_2(i,j) = grid%mu_1(i,j)
+    grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j)
+
+! given the dry pressure and coordinate system, interp the potential
+! temperature and qv
+
+    do k=1,kde-1
+
+      p_level = grid%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%t_1(i,k,j)          = interp_0( theta, pd_in, p_level, nl_in ) - t0
+      grid%t_2(i,k,j)          = grid%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%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%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k)
+    grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+    qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+    grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+    grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+      qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+      grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                  (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+      grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+    enddo
+
+!  this is the hydrostatic equation used in the model after the
+!  small timesteps.  In the model, grid%al (inverse density)
+!  is computed from the geopotential.
+
+
+    grid%ph_1(i,1,j) = 0.
+    DO k  = 2,kte
+      grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                   (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                    grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+      grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+      grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+    ENDDO
+
+    IF ( wrf_dm_on_monitor() ) THEN
+    if((i==2) .and. (j==2)) then
+     write(6,*) ' grid%ph_1 calc ',grid%ph_1(2,1,2),grid%ph_1(2,2,2),&
+                              grid%mu_1(2,2)+grid%mub(2,2),grid%mu_1(2,2), &
+                              grid%alb(2,1,2),grid%al(1,2,1),grid%rdnw(1)
+    endif
+    ENDIF
+
+  ENDDO
+  ENDDO
+
+! checking if the perturbation (bubble) is to be applied
+  IF ((delt/=0.) .and. (x_rad > 0.) &
+                 .and. (y_rad > 0.) &
+                 .and. (z_rad > 0.)) THEN
+!  thermal perturbation to kick off convection
+
+  write(6,*) ' nxc, nyc for perturbation ',nxc,nyc
+  write(6,'(A23,f18.16)') ' delt for perturbation ',delt
+  write(6,'(A30,f18.12)') ' x radius of the perturbation ' ,x_rad
+  write(6,'(A30,f18.12)') ' y radius of the perturbation ' ,y_rad
+  write(6,'(A30,f18.12)') ' z radius of the perturbation ' ,z_rad
+  write(6,'(A30,f18.12)') ' height of the perturbation   ' ,hght_pert  
+
+  DO J = jts, min(jde-1,jte)
+    yrad = config_flags%dy*float(j-nyc)/y_rad
+!   yrad = 0.
+    DO I = its, min(ide-1,ite)
+      xrad = config_flags%dx*float(i-nxc)/x_rad
+!     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%ph_1(i,k,j)+grid%ph_1(i,k+1,j)  &
+                   +grid%phb(i,k,j)+grid%phb(i,k+1,j))/g
+        zrad = (zrad-hght_pert)/z_rad
+        RAD=SQRT(xrad*xrad+yrad*yrad+zrad*zrad)
+        IF(RAD <= 1.) THEN
+           grid%t_1(i,k,j)=grid%t_1(i,k,j)+delt*COS(.5*PI*RAD)**2
+           grid%t_2(i,k,j)=grid%t_1(i,k,j)
+           qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+           grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                        (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+           grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+        ENDIF
+      ENDDO
+   
+!  rebalance hydrostatically
+
+      DO k  = 2,kte
+        grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                     (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                      grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+        grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+        grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+      ENDDO
+
+    ENDDO
+  ENDDO
+
+!End of setting up the perturbation (bubble)
+ENDIF
+
+   IF ( wrf_dm_on_monitor() ) THEN
+   write(6,*) ' grid%mu_1 from comp ', grid%mu_1(1,1)
+   write(6,*) ' full state sounding from comp, ph, grid%p, grid%al, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1)+grid%phb(1,k,1), &
+                                      grid%p(1,k,1)+grid%pb(1,k,1), grid%alt(1,k,1), &
+                                      grid%t_1(1,k,1)+t0, moist(1,k,1,P_QV)
+   enddo
+
+   write(6,*) ' pert state sounding from comp, grid%ph_1, pp, alp, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1), &
+                                      grid%p(1,k,1), grid%al(1,k,1), &
+                                      grid%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%phb(i,1,j)/g
+    ELSE IF (j == jde) THEN
+      z_at_v = grid%phb(i,1,j-1)/g
+    ELSE
+      z_at_v = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in )
+      grid%v_2(i,k,j) = grid%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%phb(i,1,j)/g
+    ELSE IF (i == ide) THEN
+      z_at_u = grid%phb(i-1,1,j)/g
+    ELSE
+      z_at_u = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in )
+      grid%u_2(i,k,j) = grid%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%w_1(i,k,j) = 0.
+    grid%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%t_base(k) = grid%t_1(1,k,1)
+    grid%qv_base(k) = moist(1,k,1,P_QV)
+    grid%u_base(k) = grid%u_1(1,k,1)
+    grid%v_base(k) = grid%v_1(1,k,1)
+    grid%z_base(k) = 0.5*(grid%phb(1,k,1)+grid%phb(1,k+1,1)+grid%ph_1(1,k,1)+grid%ph_1(1,k+1,1))/g
+  ENDDO
+  ENDIF
+  CALL wrf_dm_bcast_real( grid%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%t_2(i,1,j)+t0
+     ptmp    = grid%p(i,1,j)+grid%pb(i,1,j)
+     temp(1) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,2,j)+t0
+     ptmp    = grid%p(i,2,j)+grid%pb(i,2,j)
+     temp(2) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,3,j)+t0
+     ptmp    = grid%p(i,3,j)+grid%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) !AK/AK it is already declared via namelist.input if sfc_init=.true.
+!     grid%tmn(I,J)=grid%tsk(I,J)-0.5                                  !AK/AK it is already declared via namelist.input if sfc_init=.true.
+  ENDDO
+  ENDDO
+
+  IF (.NOT.sfc_init) THEN
+  write(6,*) ' setting tsk and tmn default'
+    DO J = jts, min(jde-1,jte)
+    DO I = its, min(ide-1,ite)
+     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
+ ENDIF
+
+ 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 r
+      parameter (r = r_d)
+      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_ideal
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_grav2d_x.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_grav2d_x.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_grav2d_x.F	(revision 17)
@@ -0,0 +1,834 @@
+!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_ideal
+
+   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 :: idum1, idum2
+
+   CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+     CALL init_domain_rk( grid &
+!
+#include <actual_new_args.inc>
+!
+                        )
+
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain_rk ( grid &
+!
+# include <dummy_new_args.inc>
+!
+)
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include <dummy_new_decl.inc>
+
+   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 <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
+
+
+   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_pole_lon (1,0.)
+    CALL nl_set_pole_lat (1,90.)
+    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%msftx(i,j)    = 1.
+         grid%msfty(i,j)    = 1.
+         grid%msfux(i,j)    = 1.
+         grid%msfuy(i,j)    = 1.
+         grid%msfvx(i,j)    = 1.
+         grid%msfvx_inv(i,j)= 1.
+         grid%msfvy(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%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%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%znw(k) = 1. - float(k-1)/float(kde-1)
+     ENDDO
+   ENDIF
+
+   DO k=1, kde-1
+    grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
+    grid%rdnw(k) = 1./grid%dnw(k)
+    grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
+   ENDDO
+   DO k=2, kde-1
+    grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
+    grid%rdn(k) = 1./grid%dn(k)
+    grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
+    grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
+   ENDDO
+
+   cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) 
+   cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) 
+   grid%cf1  = grid%fnp(2) + cof1
+   grid%cf2  = grid%fnm(2) - cof1 - cof2
+   grid%cf3  = cof2       
+
+   grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
+   grid%cfn1 = -.5*grid%dnw(kde-1)/grid%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%phb(i,1,j) = g*grid%ht(i,j)
+    grid%php(i,1,j) = 0.
+    grid%ph0(i,1,j) = grid%phb(i,1,j)
+  ENDDO
+  ENDDO
+
+  DO J = jts, jte
+  DO I = its, ite
+
+    p_surf = interp_0( p_in, zk, grid%phb(i,1,j)/g, nl_in )
+    grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%pb(i,k,j) = p_level
+      grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0
+      grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%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%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%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%mub(1,1),grid%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%phb(i,1,j)/g, nl_in )
+
+!  compute the perturbation mass and the full mass
+
+    grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j)
+    grid%mu_2(i,j) = grid%mu_1(i,j)
+    grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j)
+
+! given the dry pressure and coordinate system, interp the potential
+! temperature and qv
+
+    do k=1,kde-1
+
+      p_level = grid%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%t_1(i,k,j)          = interp_0( theta, pd_in, p_level, nl_in ) - t0
+      grid%t_2(i,k,j)          = grid%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%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k)
+    grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+    qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+    grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+    grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+      qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+      grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                  (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+      grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%ph_1(i,1,j) = 0.
+    DO k  = 2,kte
+      grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                   (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                    grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+      grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+      grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+    ENDDO
+
+    if((i==2) .and. (j==2)) then
+     write(6,*) ' ph_1 calc ',grid%ph_1(2,1,2),grid%ph_1(2,2,2),&
+                              grid%mu_1(2,2)+grid%mub(2,2),grid%mu_1(2,2), &
+                              grid%alb(2,1,2),grid%al(1,2,1),grid%rdnw(1)
+    endif
+
+  ENDDO
+  ENDDO
+
+!  cold bubble input  (from straka et al, IJNMF, vol 17, 1993 pp 1-22)
+
+  t_min = grid%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%ph_1(i,k,j)+grid%ph_1(i,k+1,j)  &
+                   +grid%phb(i,k,j)+grid%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%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**rcp
+
+           grid%T_1(i,k,j)=grid%T_1(i,k,j)+delt*(COS(PI*RAD)+1.0)/2.
+           grid%T_2(i,k,j)=grid%T_1(i,k,j)
+           qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+           grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                        (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+           grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+        ENDIF
+
+        t_min = min(t_min, grid%t_1(i,k,j))
+        t_max = max(t_max, grid%t_1(i,k,j))
+      ENDDO
+
+!  rebalance hydrostatically
+
+      DO k  = 2,kte
+        grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                     (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                      grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+        grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+        grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%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%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%ph_1(1,k,1)+grid%phb(1,k,1), &
+                                      grid%p(1,k,1)+grid%pb(1,k,1), grid%alt(1,k,1), &
+                                      grid%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%ph_1(1,k,1), &
+                                      grid%p(1,k,1), grid%al(1,k,1), &
+                                      grid%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%ph_1(1,k,1)+grid%phb(1,k,1)+grid%ph_1(1,k+1,1)+grid%phb(1,k+1,1))/g, &
+      (grid%ph_1(1,k+1,1)+grid%phb(1,k+1,1)-grid%ph_1(1,k,1)-grid%phb(1,k,1))/g
+   enddo
+   write(6,*) ' model top (m) is ', (grid%ph_1(1,kde,1)+grid%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%phb(i,1,j)/g
+    ELSE IF (j == jde) THEN
+      z_at_v = grid%phb(i,1,j-1)/g
+    ELSE
+      z_at_v = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in )
+      grid%v_2(i,k,j) = grid%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%phb(i,1,j)/g
+    ELSE IF (i == ide) THEN
+      z_at_u = grid%phb(i-1,1,j)/g
+    ELSE
+      z_at_u = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in )
+      grid%u_2(i,k,j) = grid%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%w_1(i,k,j) = 0.
+    grid%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%t_base(k) = grid%t_1(1,k,1)
+    grid%qv_base(k) = moist(1,k,1,P_QV)
+    grid%u_base(k) = grid%u_1(1,k,1)
+    grid%v_base(k) = grid%v_1(1,k,1)
+    grid%z_base(k) = 0.5*(grid%phb(1,k,1)+grid%phb(1,k+1,1)+grid%ph_1(1,k,1)+grid%ph_1(1,k+1,1))/g
+  ENDDO
+
+  DO J = jts, min(jde-1,jte)
+  DO I = its, min(ide-1,ite)
+     thtmp   = grid%t_2(i,1,j)+t0
+     ptmp    = grid%p(i,1,j)+grid%pb(i,1,j)
+     temp(1) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,2,j)+t0
+     ptmp    = grid%p(i,2,j)+grid%pb(i,2,j)
+     temp(2) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,3,j)+t0
+     ptmp    = grid%p(i,3,j)+grid%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 r
+      parameter (r = r_d)
+      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_ideal
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_heldsuarez.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_heldsuarez.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_heldsuarez.F	(revision 17)
@@ -0,0 +1,472 @@
+!IDEAL:MODEL_LAYER:INITIALIZATION
+
+!  This MODULE holds the routines which are used to perform various initializations
+!  for the individual domains.  
+
+!-----------------------------------------------------------------------
+
+MODULE module_initialize_ideal
+
+   USE module_domain             ! frame/module_domain.F
+   USE module_io_domain          ! share
+   USE module_state_description  ! frame
+   USE module_model_constants    ! share
+   USE module_bc                 ! share
+   USE module_timing             ! frame
+   USE module_configure          ! frame
+   USE module_init_utilities     ! dyn_em
+#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 :: idum1, idum2
+
+   CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+     CALL init_domain_rk( grid &
+!
+#include <actual_new_args.inc>
+!
+                        )
+
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain_rk ( grid &
+!
+# include <dummy_new_args.inc>
+!
+)
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include <dummy_decl.inc>
+
+   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
+
+   INTEGER :: nxx, nyy, ig, jg, im, error
+
+   REAL :: dlam, dphi, vlat, tperturb
+   REAL :: p_surf, p_level, pd_surf, qvf1, qvf2, qvf
+   REAL :: thtmp, ptmp, temp(3), cof1, cof2
+
+   INTEGER :: icm,jcm
+
+   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 )
+
+! here we check to see if the boundary conditions are set properly
+
+   CALL boundary_condition_check( config_flags, bdyzone, error, grid%id )
+
+    grid%itimestep=0
+   grid%step_number = 0
+
+
+#ifdef DM_PARALLEL
+   CALL wrf_dm_bcast_bytes( icm , IWORDSIZE )
+   CALL wrf_dm_bcast_bytes( jcm , IWORDSIZE )
+#endif
+
+   ! Initialize 2D surface arrays
+
+   nxx = ide-ids ! Don't include u-stagger
+   nyy = jde-jds ! Don't include v-stagger
+   dphi = 180./REAL(nyy)
+   dlam = 360./REAL(nxx)
+
+   DO j = jts, jte
+   DO i = its, ite
+      ! ig is the I index in the global (domain) span of the array.
+      ! jg is the J index in the global (domain) span of the array.
+      ig = i - ids + 1  ! ids is not necessarily 1
+      jg = j - jds + 1  ! jds is not necessarily 1
+
+      grid%xlat(i,j)  = (REAL(jg)-0.5)*dphi-90.
+      grid%xlong(i,j) = (REAL(ig)-0.5)*dlam-180.
+      vlat       = grid%xlat(i,j) - 0.5*dphi
+
+      grid%clat(i,j) = grid%xlat(i,j)
+      grid%clong(i,j) = grid%xlong(i,j)
+
+      grid%msftx(i,j) = 1./COS(grid%xlat(i,j)*degrad)
+      grid%msfty(i,j) = 1.
+      grid%msfux(i,j) = 1./COS(grid%xlat(i,j)*degrad)
+      grid%msfuy(i,j) = 1.
+      grid%e(i,j)     = 2*EOMEG*COS(grid%xlat(i,j)*degrad)
+      grid%f(i,j)     = 2*EOMEG*SIN(grid%xlat(i,j)*degrad)
+
+      ! The following two are the cosine and sine of the rotation
+      ! of projection.  Simple cylindrical is *simple* ... no rotation!
+      grid%sina(i,j) = 0.
+      grid%cosa(i,j) = 1.
+
+   END DO
+   END DO
+
+!   DO j = max(jds+1,jts), min(jde-1,jte)
+   DO j = jts, jte
+   DO i = its, ite
+      vlat       = grid%xlat(i,j) - 0.5*dphi
+      grid%msfvx(i,j) = 1./COS(vlat*degrad)
+      grid%msfvy(i,j) = 1.
+      grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j)
+   END DO
+   END DO
+
+   IF(jts == jds) THEN
+   DO i = its, ite
+      grid%msfvx(i,jts) = 00.
+      grid%msfvx_inv(i,jts) = 0.
+   END DO
+   END IF
+
+   IF(jte == jde) THEN
+   DO i = its, ite
+      grid%msfvx(i,jte) = 00.
+      grid%msfvx_inv(i,jte) = 0.
+   END DO
+   END IF
+
+   DO j=jts,jte
+     vlat       = grid%xlat(its,j) - 0.5*dphi
+     write(6,*) j,vlat,grid%msfvx(its,j),grid%msfvx_inv(its,j)
+   ENDDO
+
+   DO j=jts,jte
+   DO i=its,ite
+      grid%ht(i,j)       = 0.
+
+      grid%albedo(i,j)   = 0.
+      grid%thc(i,j)      = 1000.
+      grid%znt(i,j)      = 0.01
+      grid%emiss(i,j)    = 1.
+      grid%ivgtyp(i,j)   = 1
+      grid%lu_index(i,j) = REAL(ivgtyp(i,j))
+      grid%xland(i,j)    = 1.
+      grid%mavail(i,j)   = 0.
+   END DO
+   END DO
+
+   grid%dx = dlam*degrad/reradius
+   grid%dy = dphi*degrad/reradius
+   grid%rdx = 1./grid%dx
+   grid%rdy = 1./grid%dy
+
+   !WRITE(*,*) ''
+   !WRITE(*,'(A,1PG14.6,A,1PG14.6)') ' For the namelist: dx =',grid%dx,', dy =',grid%dy
+
+   CALL nl_set_mminlu(1,'    ')
+   grid%iswater = 0
+   grid%cen_lat = 0.
+   grid%cen_lon = 0.
+   grid%truelat1 = 0.
+   grid%truelat2 = 0.
+   grid%moad_cen_lat = 0.
+   grid%stand_lon    = 0.
+   grid%pole_lon = 0.
+   grid%pole_lat = 90.
+   ! Apparently, map projection 0 is "none" which actually turns out to be
+   ! a regular grid of latitudes and longitudes, the simple cylindrical projection
+   grid%map_proj = 0
+
+   DO k = kds, kde
+      grid%znw(k) = 1. - REAL(k-kds)/REAL(kde-kds)
+   END DO
+
+   DO k=1, kde-1
+    grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
+    grid%rdnw(k) = 1./grid%dnw(k)
+    grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
+   ENDDO
+   DO k=2, kde-1
+    grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
+    grid%rdn(k) = 1./grid%dn(k)
+    grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
+    grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
+   ENDDO
+
+   cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) 
+   cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) 
+   grid%cf1  = grid%fnp(2) + cof1
+   grid%cf2  = grid%fnm(2) - cof1 - cof2
+   grid%cf3  = cof2       
+
+   grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
+   grid%cfn1 = -.5*grid%dnw(kde-1)/grid%dn(kde-1)
+
+
+   ! Need to add perturbations to initial profile.  Set up random number
+   ! seed here.
+   CALL random_seed
+
+   ! General assumption from here after is that the initial temperature
+   ! profile is isothermal at a value of T0, and the initial winds are
+   ! all 0.
+
+   ! find ptop for the desired ztop (ztop is input from the namelist)
+   grid%p_top =  p0 * EXP(-(g*config_flags%ztop)/(r_d*T0))
+
+
+   ! Values of geopotential (base, perturbation, and at p0) at the surface
+   DO j = jts, jte
+   DO i = its, ite
+      grid%phb(i,1,j) = grid%ht(i,j)*g
+      grid%php(i,1,j) = 0.         ! This is perturbation geopotential
+                              ! Since this is an initial condition, there
+                              ! should be no perturbation!
+      grid%ph0(i,1,j) = grid%ht(i,j)*g
+   ENDDO
+   ENDDO
+
+
+   DO J = jts, jte
+   DO I = its, ite
+
+      p_surf = p0 * EXP(-(g*grid%phb(i,1,j)/g)/(r_d*T0))
+      grid%mub(i,j) = p_surf-grid%p_top
+
+      ! given p (coordinate), calculate theta and compute 1/rho from equation
+      ! of state
+
+      DO K = kts, kte-1
+         p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+         grid%pb(i,k,j) = p_level
+
+         grid%t_init(i,k,j) = T0*(p0/p_level)**rcp
+         grid%t_init(i,k,j) = grid%t_init(i,k,j) - t0
+
+         grid%alb(i,k,j)=(r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm
+      END DO
+
+      ! calculate hydrostatic balance (alternatively we could interpolate
+      ! 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 = kts+1, kte
+         grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j)
+      ENDDO
+
+   ENDDO
+   ENDDO
+
+   DO im = PARAM_FIRST_SCALAR, num_moist
+   DO J = jts, jte
+   DO K = kts, kte-1
+   DO I = its, ite
+      grid%moist(i,k,j,im) = 0.
+   END DO
+   END DO
+   END DO
+   END DO
+
+   ! Now calculate the full (hydrostatically-balanced) state for each column
+   ! We will include moisture
+   DO J = jts, jte
+   DO I = its, ite
+
+      ! At this point p_top is already set. find the DRY mass in the column
+      pd_surf = p0 * EXP(-(g*grid%phb(i,1,j)/g)/(r_d*T0))
+
+      ! compute the perturbation mass (mu/mu_1/mu_2) and the full mass
+      grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j)
+      grid%mu_2(i,j) = grid%mu_1(i,j)
+      grid%mu0(i,j)  = grid%mu_1(i,j) + grid%mub(i,j)
+
+      ! given the dry pressure and coordinate system, calculate the
+      ! perturbation potential temperature (t/t_1/t_2)
+
+      DO k = kds, kde-1
+         p_level = grid%znu(k)*(pd_surf - grid%p_top) + grid%p_top
+         grid%t_1(i,k,j) = T0*(p0/p_level)**rcp
+         ! Add a small perturbation to initial isothermal profile
+         CALL random_number(tperturb)
+         grid%t_1(i,k,j)=grid%t_1(i,k,j)*(1.0+0.004*(tperturb-0.5))
+         grid%t_1(i,k,j) = grid%t_1(i,k,j)-t0
+         grid%t_2(i,k,j) = grid%t_1(i,k,j)
+      END DO
+
+
+      ! 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%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k)
+      grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+      qvf = 1. + rvovrd*grid%moist(i,k,j,P_QV)
+      grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                  (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+      grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+
+      !  down the column
+
+      do k=kte-2,kts,-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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+         qvf = 1. + rvovrd*grid%moist(i,k,j,P_QV)
+         grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                     (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+         grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%ph_1(i,1,j) = 0.
+      DO k  = kts+1,kte
+         grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(  &
+                      (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+  &
+                       grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+
+         grid%ph_2(i,k,j) = grid%ph_1(i,k,j)
+         grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+      ENDDO
+
+   END DO
+   END DO
+
+
+
+   ! Now set U & V
+   DO J = jts, jte
+   DO K = kts, kte-1
+   DO I = its, ite
+      grid%u_1(i,k,j) = 0.
+      grid%u_2(i,k,j) = 0.
+      grid%v_1(i,k,j) = 0.
+      grid%v_2(i,k,j) = 0.
+   END DO
+   END DO
+   END DO
+
+
+   DO j=jts, jte
+   DO k=kds, kde
+   DO i=its, ite
+      grid%ww(i,k,j)  = 0.
+      grid%w_1(i,k,j) = 0.
+      grid%w_2(i,k,j) = 0.
+      grid%h_diabatic(i,k,j) = 0.
+   END DO
+   END DO
+   END DO
+
+  
+   DO k=kts,kte
+      grid%t_base(k)  = grid%t_init(its,k,jts)
+      grid%qv_base(k) = 0.
+      grid%u_base(k)  = 0.
+      grid%v_base(k)  = 0.
+   END DO
+
+   ! One subsurface layer: infinite slab at constant temperature below
+   ! the surface.  Surface temperature is an infinitely thin "skin" on
+   ! top of a half-infinite slab.  The temperature of both the skin and
+   ! the slab are determined from the initial nearest-surface-air-layer
+   ! temperature.
+   DO J = jts, MIN(jte, jde-1)
+   DO I = its, MIN(ite, ide-1)
+      thtmp   = grid%t_2(i,1,j)+t0
+      ptmp    = grid%p(i,1,j)+grid%pb(i,1,j)
+      temp(1) = thtmp * (ptmp/p1000mb)**rcp
+      thtmp   = grid%t_2(i,2,j)+t0
+      ptmp    = grid%p(i,2,j)+grid%pb(i,2,j)
+      temp(2) = thtmp * (ptmp/p1000mb)**rcp
+      thtmp   = grid%t_2(i,3,j)+t0
+      ptmp    = grid%p(i,3,j)+grid%pb(i,3,j)
+      temp(3) = thtmp * (ptmp/p1000mb)**rcp
+      grid%tsk(I,J)=cf1*temp(1)+cf2*temp(2)+cf3*temp(3)
+      grid%tmn(I,J)=grid%tsk(I,J)-0.5
+   END DO
+   END DO
+
+   RETURN
+
+ END SUBROUTINE init_domain_rk
+
+!---------------------------------------------------------------------
+
+ SUBROUTINE init_module_initialize
+ END SUBROUTINE init_module_initialize
+
+!---------------------------------------------------------------------
+
+END MODULE module_initialize_ideal
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_hill2d_x.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_hill2d_x.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_hill2d_x.F	(revision 17)
@@ -0,0 +1,754 @@
+!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_ideal
+
+   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 :: idum1, idum2
+
+   
+   CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+     CALL init_domain_rk( grid &
+!
+#include <actual_new_args.inc>
+!
+                        )
+
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain_rk ( grid &
+!
+# include <dummy_new_args.inc>
+!
+)
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include <dummy_new_decl.inc>
+
+   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
+
+   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_pole_lon (1,0.)
+    CALL nl_set_pole_lat (1,90.)
+    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%msftx(i,j)    = 1.
+         grid%msfty(i,j)    = 1.
+         grid%msfux(i,j)    = 1.
+         grid%msfuy(i,j)    = 1.
+         grid%msfvx(i,j)    = 1.
+         grid%msfvx_inv(i,j)= 1.
+         grid%msfvy(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%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%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%znw(k) = 1. - float(k-1)/float(kde-1)
+     ENDDO
+   ENDIF
+
+   DO k=1, kde-1
+    grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
+    grid%rdnw(k) = 1./grid%dnw(k)
+    grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
+   ENDDO
+   DO k=2, kde-1
+    grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
+    grid%rdn(k) = 1./grid%dn(k)
+    grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
+    grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
+   ENDDO
+
+   cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) 
+   cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) 
+   grid%cf1  = grid%fnp(2) + cof1
+   grid%cf2  = grid%fnm(2) - cof1 - cof2
+   grid%cf3  = cof2       
+
+   grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
+   grid%cfn1 = -.5*grid%dnw(kde-1)/grid%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%phb(i,1,j) = g*grid%ht(i,j)
+    grid%php(i,1,j) = 0.
+    grid%ph0(i,1,j) = grid%phb(i,1,j)
+  ENDDO
+  ENDDO
+
+  DO J = jts, jte
+  DO I = its, ite
+
+    p_surf = interp_0( p_in, zk, grid%phb(i,1,j)/g, nl_in )
+    grid%mub(i,j) = p_surf-grid%p_top
+
+!  this is dry hydrostatic sounding (base state), so given grid%p (coordinate),
+!  interp theta (from interp) and compute 1/rho from eqn. of state
+
+    DO K = 1, kte-1
+      p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%pb(i,k,j) = p_level
+      grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0
+      grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%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%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j)
+    ENDDO
+
+  ENDDO
+  ENDDO
+
+  write(6,*) ' ptop is ',grid%p_top
+  write(6,*) ' base state grid%mub(1,1), p_surf is ',grid%mub(1,1),grid%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%phb(i,1,j)/g, nl_in )
+
+!  compute the perturbation mass and the full mass
+
+    grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j)
+    grid%mu_2(i,j) = grid%mu_1(i,j)
+    grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j)
+
+! given the dry pressure and coordinate system, interp the potential
+! temperature and qv
+
+    do k=1,kde-1
+
+      p_level = grid%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%t_1(i,k,j)          = interp_0( theta, pd_in, p_level, nl_in ) - t0
+      grid%t_2(i,k,j)          = grid%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%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%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k)
+    grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+    qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+    grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+    grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+      qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+      grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                  (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+      grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+    enddo
+
+!  this is the hydrostatic equation used in the model after the
+!  small timesteps.  In the model, grid%al (inverse density)
+!  is computed from the geopotential.
+
+
+    grid%ph_1(i,1,j) = 0.
+    DO k  = 2,kte
+      grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                   (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                    grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+      grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+      grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+    ENDDO
+
+    if((i==2) .and. (j==2)) then
+     write(6,*) ' grid%ph_1 calc ',grid%ph_1(2,1,2),grid%ph_1(2,2,2),&
+                              grid%mu_1(2,2)+grid%mub(2,2),grid%mu_1(2,2), &
+                              grid%alb(2,1,2),grid%al(1,2,1),grid%rdnw(1)
+    endif
+
+  ENDDO
+  ENDDO
+
+   write(6,*) ' grid%mu_1 from comp ', grid%mu_1(1,1)
+   write(6,*) ' full state sounding from comp, ph, grid%p, grid%al, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1)+grid%phb(1,k,1), &
+                                      grid%p(1,k,1)+grid%pb(1,k,1), grid%alt(1,k,1), &
+                                      grid%t_1(1,k,1)+t0, moist(1,k,1,P_QV)
+   enddo
+
+   write(6,*) ' pert state sounding from comp, grid%ph_1, pp, alp, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1), &
+                                      grid%p(1,k,1), grid%al(1,k,1), &
+                                      grid%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%phb(i,1,j)/g
+    ELSE IF (j == jde) THEN
+      z_at_v = grid%phb(i,1,j-1)/g
+    ELSE
+      z_at_v = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in )
+      grid%v_2(i,k,j) = grid%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%phb(i,1,j)/g
+    ELSE IF (i == ide) THEN
+      z_at_u = grid%phb(i-1,1,j)/g
+    ELSE
+      z_at_u = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in )
+      grid%u_2(i,k,j) = grid%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%w_1(i,k,j) = 0.
+    grid%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%t_base(k) = grid%t_1(1,k,1)
+    grid%qv_base(k) = moist(1,k,1,P_QV)
+    grid%u_base(k) = grid%u_1(1,k,1)
+    grid%v_base(k) = grid%v_1(1,k,1)
+    grid%z_base(k) = 0.5*(grid%phb(1,k,1)+grid%phb(1,k+1,1)+grid%ph_1(1,k,1)+grid%ph_1(1,k+1,1))/g
+  ENDDO
+
+  DO J = jts, min(jde-1,jte)
+  DO I = its, min(ide-1,ite)
+     thtmp   = grid%t_2(i,1,j)+t0
+     ptmp    = grid%p(i,1,j)+grid%pb(i,1,j)
+     temp(1) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,2,j)+t0
+     ptmp    = grid%p(i,2,j)+grid%pb(i,2,j)
+     temp(2) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,3,j)+t0
+     ptmp    = grid%p(i,3,j)+grid%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 r
+      parameter (r = r_d)
+      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_ideal
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_les.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_les.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_les.F	(revision 17)
@@ -0,0 +1,841 @@
+!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_ideal
+
+   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 :: idum1, idum2
+
+   CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+     CALL init_domain_rk( grid &
+!
+#include <actual_new_args.inc>
+!
+                        )
+
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain_rk ( grid &
+!
+# include <dummy_new_args.inc>
+!
+)
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include <dummy_new_decl.inc>
+
+   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
+!  For LES, add randx
+   real :: randx
+
+#ifdef DM_PARALLEL
+#    include <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
+
+
+!  stretch_grid = .true.
+!  FOR LES, set stretch to false
+   stretch_grid = .false.
+   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_pole_lon (1,0.)
+    CALL nl_set_pole_lat (1,90.)
+    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%msftx(i,j)    = 1.
+         grid%msfty(i,j)    = 1.
+         grid%msfux(i,j)    = 1.
+         grid%msfuy(i,j)    = 1.
+         grid%msfvx(i,j)    = 1.
+         grid%msfvx_inv(i,j)= 1.
+         grid%msfvy(i,j)    = 1.
+         grid%sina(i,j)     = 0.
+         grid%cosa(i,j)     = 1.
+         grid%e(i,j)        = 0.
+!  for LES, include Coriolis force
+         grid%f(i,j)        = 1.e-4 
+
+      END DO
+   END DO
+
+    DO j = jts, jte
+    DO k = kts, kte
+      DO i = its, ite
+         grid%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%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%znw(k) = 1. - float(k-1)/float(kde-1)
+     ENDDO
+   ENDIF
+
+   DO k=1, kde-1
+    grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
+    grid%rdnw(k) = 1./grid%dnw(k)
+    grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
+   ENDDO
+   DO k=2, kde-1
+    grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
+    grid%rdn(k) = 1./grid%dn(k)
+    grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
+    grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
+   ENDDO
+
+   cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) 
+   cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) 
+   grid%cf1  = grid%fnp(2) + cof1
+   grid%cf2  = grid%fnm(2) - cof1 - cof2
+   grid%cf3  = cof2       
+
+   grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
+   grid%cfn1 = -.5*grid%dnw(kde-1)/grid%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%phb(i,1,j) = g * grid%ht(i,j)
+    grid%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%phb(i,1,j)/g, nl_in )
+    grid%mub(i,j) = p_surf-grid%p_top
+
+!  this is dry hydrostatic sounding (base state), so given grid%p (coordinate),
+!  interp theta (from interp) and compute 1/rho from eqn. of state
+
+    DO K = 1, kte-1
+      p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%pb(i,k,j) = p_level
+      grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0
+      grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%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%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%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%mub(1,1), p_surf is ',grid%mub(1,1),grid%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%phb(i,1,j)/g, nl_in )
+
+!  compute the perturbation mass and the full mass
+
+    grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j)
+    grid%mu_2(i,j) = grid%mu_1(i,j)
+    grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j)
+
+! given the dry pressure and coordinate system, interp the potential
+! temperature and qv
+
+    do k=1,kde-1
+
+      p_level = grid%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%t_1(i,k,j)          = interp_0( theta, pd_in, p_level, nl_in ) - t0
+      grid%t_2(i,k,j)          = grid%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%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%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k)
+    grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+    qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+    grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+    grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+      qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+      grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                  (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+      grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+    enddo
+
+!  this is the hydrostatic equation used in the model after the
+!  small timesteps.  In the model, grid%al (inverse density)
+!  is computed from the geopotential.
+
+
+    grid%ph_1(i,1,j) = 0.
+    DO k  = 2,kte
+      grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                   (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                    grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+      grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+      grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+    ENDDO
+
+    IF ( wrf_dm_on_monitor() ) THEN
+    if((i==2) .and. (j==2)) then
+     write(6,*) ' grid%ph_1 calc ',grid%ph_1(2,1,2),grid%ph_1(2,2,2),&
+                              grid%mu_1(2,2)+grid%mub(2,2),grid%mu_1(2,2), &
+                              grid%alb(2,1,2),grid%al(1,2,1),grid%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
+
+! For LES, change the initial random perturbations
+! For 2D test, call randx outside I-loop
+! For 3D runs, call randx inside both I-J loops
+
+  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.
+      call random_number (randx)
+      randx = randx - 0.5
+!     DO K = 1, kte-1
+      DO K = 1, 4 
+
+!  No bubbles for LES!
+!  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%ph_1(i,k,j)+grid%ph_1(i,k+1,j)  &
+!                  +grid%phb(i,k,j)+grid%phb(i,k+1,j))/g
+!       zrad = (zrad-1500.)/1500.
+        zrad = 0.
+        RAD=SQRT(xrad*xrad+yrad*yrad+zrad*zrad)
+        IF(RAD <= 1.) THEN
+!          grid%t_1(i,k,j)=grid%t_1(i,k,j)+delt*COS(.5*PI*RAD)**2
+           grid%t_1(i,k,j)=grid%t_1(i,k,j)+ 0.1 *randx
+           grid%t_2(i,k,j)=grid%t_1(i,k,j)
+           qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+           grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                        (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+           grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+        ENDIF
+      ENDDO
+
+!  rebalance hydrostatically
+
+      DO k  = 2,kte
+        grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                     (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                      grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+        grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+        grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+      ENDDO
+
+    ENDDO
+  ENDDO
+
+!#endif
+
+   IF ( wrf_dm_on_monitor() ) THEN
+   write(6,*) ' grid%mu_1 from comp ', grid%mu_1(1,1)
+   write(6,*) ' full state sounding from comp, ph, grid%p, grid%al, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1)+grid%phb(1,k,1), &
+                                      grid%p(1,k,1)+grid%pb(1,k,1), grid%alt(1,k,1), &
+                                      grid%t_1(1,k,1)+t0, moist(1,k,1,P_QV)
+   enddo
+
+   write(6,*) ' pert state sounding from comp, grid%ph_1, pp, alp, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1), &
+                                      grid%p(1,k,1), grid%al(1,k,1), &
+                                      grid%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%phb(i,1,j)/g
+    ELSE IF (j == jde) THEN
+      z_at_v = grid%phb(i,1,j-1)/g
+    ELSE
+      z_at_v = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in )
+      grid%v_2(i,k,j) = grid%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%phb(i,1,j)/g
+    ELSE IF (i == ide) THEN
+      z_at_u = grid%phb(i-1,1,j)/g
+    ELSE
+      z_at_u = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in )
+      grid%u_2(i,k,j) = grid%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%w_1(i,k,j) = 0.
+    grid%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%t_base(k) = grid%t_1(1,k,1)
+    grid%qv_base(k) = moist(1,k,1,P_QV)
+    grid%u_base(k) = grid%u_1(1,k,1)
+    grid%v_base(k) = grid%v_1(1,k,1)
+    grid%z_base(k) = 0.5*(grid%phb(1,k,1)+grid%phb(1,k+1,1)+grid%ph_1(1,k,1)+grid%ph_1(1,k+1,1))/g
+  ENDDO
+  ENDIF
+  CALL wrf_dm_bcast_real( grid%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%t_2(i,1,j)+t0
+     ptmp    = grid%p(i,1,j)+grid%pb(i,1,j)
+     temp(1) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,2,j)+t0
+     ptmp    = grid%p(i,2,j)+grid%pb(i,2,j)
+     temp(2) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,3,j)+t0
+     ptmp    = grid%p(i,3,j)+grid%pb(i,3,j)
+     temp(3) = thtmp * (ptmp/p1000mb)**rcp
+
+!    For LES-CBL, add 5 degrees to the surface temperature!
+!
+!    grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3)
+     grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3)+5.
+     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 r
+      parameter (r = r_d)
+      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_ideal
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_quarter_ss.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_quarter_ss.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_quarter_ss.F	(revision 17)
@@ -0,0 +1,818 @@
+!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_ideal
+
+   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 :: idum1, idum2
+
+   CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+     CALL init_domain_rk( grid &
+!
+#include <actual_new_args.inc>
+!
+                        )
+
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain_rk ( grid &
+!
+# include <dummy_new_args.inc>
+!
+)
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include <dummy_new_decl.inc>
+
+   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
+
+   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_pole_lon (1,0.)
+    CALL nl_set_pole_lat (1,90.)
+    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%msftx(i,j)    = 1.
+         grid%msfty(i,j)    = 1.
+         grid%msfux(i,j)    = 1.
+         grid%msfuy(i,j)    = 1.
+         grid%msfvx(i,j)    = 1.
+         grid%msfvx_inv(i,j)= 1.
+         grid%msfvy(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%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%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%znw(k) = 1. - float(k-1)/float(kde-1)
+     ENDDO
+   ENDIF
+
+   DO k=1, kde-1
+    grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
+    grid%rdnw(k) = 1./grid%dnw(k)
+    grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
+   ENDDO
+   DO k=2, kde-1
+    grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
+    grid%rdn(k) = 1./grid%dn(k)
+    grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
+    grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
+   ENDDO
+
+   cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) 
+   cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) 
+   grid%cf1  = grid%fnp(2) + cof1
+   grid%cf2  = grid%fnm(2) - cof1 - cof2
+   grid%cf3  = cof2       
+
+   grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
+   grid%cfn1 = -.5*grid%dnw(kde-1)/grid%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%phb(i,1,j) = g * grid%ht(i,j)
+    grid%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%phb(i,1,j)/g, nl_in )
+    grid%mub(i,j) = p_surf-grid%p_top
+
+!  this is dry hydrostatic sounding (base state), so given grid%p (coordinate),
+!  interp theta (from interp) and compute 1/rho from eqn. of state
+
+    DO K = 1, kte-1
+      p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%pb(i,k,j) = p_level
+      grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0
+      grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%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%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%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%mub(1,1), p_surf is ',grid%mub(1,1),grid%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%phb(i,1,j)/g, nl_in )
+
+!  compute the perturbation mass and the full mass
+
+    grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j)
+    grid%mu_2(i,j) = grid%mu_1(i,j)
+    grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j)
+
+! given the dry pressure and coordinate system, interp the potential
+! temperature and qv
+
+    do k=1,kde-1
+
+      p_level = grid%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%t_1(i,k,j)          = interp_0( theta, pd_in, p_level, nl_in ) - t0
+      grid%t_2(i,k,j)          = grid%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%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%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k)
+    grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+    qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+    grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+    grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+      qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+      grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                  (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+      grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+    enddo
+
+!  this is the hydrostatic equation used in the model after the
+!  small timesteps.  In the model, grid%al (inverse density)
+!  is computed from the geopotential.
+
+
+    grid%ph_1(i,1,j) = 0.
+    DO k  = 2,kte
+      grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                   (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                    grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+      grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+      grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+    ENDDO
+
+    IF ( wrf_dm_on_monitor() ) THEN
+    if((i==2) .and. (j==2)) then
+     write(6,*) ' grid%ph_1 calc ',grid%ph_1(2,1,2),grid%ph_1(2,2,2),&
+                              grid%mu_1(2,2)+grid%mub(2,2),grid%mu_1(2,2), &
+                              grid%alb(2,1,2),grid%al(1,2,1),grid%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%ph_1(i,k,j)+grid%ph_1(i,k+1,j)  &
+                   +grid%phb(i,k,j)+grid%phb(i,k+1,j))/g
+        zrad = (zrad-1500.)/1500.
+        RAD=SQRT(xrad*xrad+yrad*yrad+zrad*zrad)
+        IF(RAD <= 1.) THEN
+           grid%t_1(i,k,j)=grid%t_1(i,k,j)+delt*COS(.5*PI*RAD)**2
+           grid%t_2(i,k,j)=grid%t_1(i,k,j)
+           qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+           grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                        (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+           grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+        ENDIF
+      ENDDO
+
+!  rebalance hydrostatically
+
+      DO k  = 2,kte
+        grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                     (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                      grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+        grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+        grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+      ENDDO
+
+    ENDDO
+  ENDDO
+
+!#endif
+
+   IF ( wrf_dm_on_monitor() ) THEN
+   write(6,*) ' grid%mu_1 from comp ', grid%mu_1(1,1)
+   write(6,*) ' full state sounding from comp, ph, grid%p, grid%al, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1)+grid%phb(1,k,1), &
+                                      grid%p(1,k,1)+grid%pb(1,k,1), grid%alt(1,k,1), &
+                                      grid%t_1(1,k,1)+t0, moist(1,k,1,P_QV)
+   enddo
+
+   write(6,*) ' pert state sounding from comp, grid%ph_1, pp, alp, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1), &
+                                      grid%p(1,k,1), grid%al(1,k,1), &
+                                      grid%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%phb(i,1,j)/g
+    ELSE IF (j == jde) THEN
+      z_at_v = grid%phb(i,1,j-1)/g
+    ELSE
+      z_at_v = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in )
+      grid%v_2(i,k,j) = grid%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%phb(i,1,j)/g
+    ELSE IF (i == ide) THEN
+      z_at_u = grid%phb(i-1,1,j)/g
+    ELSE
+      z_at_u = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in )
+      grid%u_2(i,k,j) = grid%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%w_1(i,k,j) = 0.
+    grid%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%t_base(k) = grid%t_1(1,k,1)
+    grid%qv_base(k) = moist(1,k,1,P_QV)
+    grid%u_base(k) = grid%u_1(1,k,1)
+    grid%v_base(k) = grid%v_1(1,k,1)
+    grid%z_base(k) = 0.5*(grid%phb(1,k,1)+grid%phb(1,k+1,1)+grid%ph_1(1,k,1)+grid%ph_1(1,k+1,1))/g
+  ENDDO
+  ENDIF
+  CALL wrf_dm_bcast_real( grid%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%t_2(i,1,j)+t0
+     ptmp    = grid%p(i,1,j)+grid%pb(i,1,j)
+     temp(1) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,2,j)+t0
+     ptmp    = grid%p(i,2,j)+grid%pb(i,2,j)
+     temp(2) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,3,j)+t0
+     ptmp    = grid%p(i,3,j)+grid%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 r
+      parameter (r = r_d)
+      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_ideal
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_real.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_real.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_real.F	(revision 17)
@@ -0,0 +1,5890 @@
+!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_real
+
+   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
+   USE module_llxy
+#ifdef DM_PARALLEL
+   USE module_dm
+   USE module_comm_dm, ONLY : &
+                           HALO_EM_INIT_1_sub   &
+                          ,HALO_EM_INIT_2_sub   &
+                          ,HALO_EM_INIT_3_sub   &
+                          ,HALO_EM_INIT_4_sub   &
+                          ,HALO_EM_INIT_5_sub   &
+                          ,HALO_EM_VINTERP_UV_1_sub
+#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 :: idum1, idum2
+
+      CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+        CALL init_domain_rk( grid &
+!
+#include "actual_new_args.inc"
+!
+      )
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain_rk ( grid &
+!
+#include "dummy_new_args.inc"
+!
+   )
+
+      USE module_optional_input
+      IMPLICIT NONE
+
+      !  Input space and data.  No gridded meteorological data has been stored, though.
+
+!     TYPE (domain), POINTER :: grid
+      TYPE (domain)          :: grid
+
+#include "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 :: 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 :: ns
+
+      !  Local data
+
+      INTEGER :: error
+      INTEGER :: im, num_3d_m, num_3d_s
+      REAL    :: p_surf, p_level
+      REAL    :: cof1, cof2
+      REAL    :: qvf , qvf1 , qvf2 , pd_surf
+      REAL    :: p00 , t00 , a , tiso
+      REAL    :: hold_znw , ptemp
+      REAL    :: vap_pres_mb , sat_vap_pres_mb
+      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%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 , use_levels_below_ground , use_surface
+      LOGICAL :: we_have_tavgsfc , we_have_tsk
+
+      INTEGER :: lev500 , loop_count
+      REAL    :: zl , zu , pl , pu , z500 , dz500 , tvsfc , dpmu
+
+      LOGICAL , PARAMETER :: want_full_levels = .TRUE.
+      LOGICAL , PARAMETER :: want_half_levels = .FALSE.
+
+      CHARACTER (LEN=80) :: a_message
+      REAL :: max_mf
+    
+      !  Excluded middle.
+
+      LOGICAL :: any_valid_points
+      INTEGER :: i_valid , j_valid
+
+!-- Carsel and Parrish [1988]
+        REAL , DIMENSION(100) :: lqmi
+
+      REAL :: t_start , t_end
+
+      !  Dimension information stored in grid data structure.
+
+      CALL cpu_time(t_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,    &
+                                imsx, imex, jmsx, jmex, kmsx, kmex,    &
+                                ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
+                                imsy, imey, jmsy, jmey, kmsy, kmey,    &
+                                ipsy, ipey, jpsy, jpey, kpsy, kpey )
+      its = ips ; ite = ipe ; jts = jps ; jte = jpe ; kts = kps ; kte = kpe
+
+
+      CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
+
+      !  Send out a quick message about the time steps based on the map scale factors.
+
+      IF ( ( internal_time_loop .EQ. 1 ) .AND. ( grid%id .EQ. 1 ) .AND. ( .NOT. config_flags%map_proj .EQ. PROJ_CASSINI ) ) THEN
+         max_mf = grid%msft(its,jts)
+         DO j=jts,MIN(jde-1,jte)
+            DO i=its,MIN(ide-1,ite)
+               max_mf = MAX ( max_mf , grid%msft(i,j) )
+            END DO
+         END DO
+#if ( defined(DM_PARALLEL)  &&   ! defined(STUBMPI) )
+         max_mf = wrf_dm_max_real ( max_mf )
+#endif
+         WRITE ( a_message , FMT='(A,F5.2,A)' ) 'Max map factor in domain 1 = ',max_mf,'. Scale the dt in the model accordingly.'
+         CALL wrf_message ( a_message ) 
+      END IF
+
+      !  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 , tiso ) 
+
+      !  Save these constants to write out in model output file
+
+      grid%t00  = t00
+      grid%p00  = p00
+      grid%tlp  = a
+      grid%tiso = tiso
+
+      !  Are there any hold-ups to us bypassing the middle of the domain?  These
+      !  holdups would be situations where we need data in the middle of the domain.
+      !  FOr example, if this si the first time period, we need the full domain
+      !  processed for ICs.  Also, if there is some sort of gridded FDDA turned on, or
+      !  if the SST update is activated, then we can't just blow off the middle of the 
+      !  domain all willy-nilly.  Other cases of these hold-ups?  Sure - what if the
+      !  user wants to smooth the CG topo, we need several rows and columns available.
+      !  What if the lat/lon proj is used, then we need to run a spectral filter on
+      !  the topo.  Both are killers when trying to ignore data in the middle of the
+      !  domain.
+
+      !  If hold_ups = .F., then there are no hold-ups to excluding the middle
+      !  domain processing.  If hold_ups = .T., then there are hold-ups, and we 
+      !  must process the middle of the domain.
+
+      hold_ups = ( internal_time_loop .EQ. 1 ) .OR. &
+                 ( config_flags%grid_fdda .NE. 0 ) .OR. &
+                 ( config_flags%sst_update .EQ. 1 ) .OR. &
+                 ( config_flags%all_ic_times ) .OR. &
+                 ( config_flags%smooth_cg_topo ) .OR. &
+                 ( config_flags%map_proj .EQ. PROJ_CASSINI )
+
+      !  There are a few checks that we need to do when the input data comes in with the middle
+      !  excluded by WPS.
+
+      IF      ( flag_excluded_middle .NE. 0 ) THEN
+
+         !  If this time period of data from WPS has the middle excluded, it had better be OK for
+         !  us to have a hole.
+
+         IF ( hold_ups ) THEN
+            WRITE ( a_message,* ) 'None of the following are allowed to be TRUE : '
+            CALL wrf_message ( a_message ) 
+            WRITE ( a_message,* ) ' ( internal_time_loop .EQ. 1 )               ', ( internal_time_loop .EQ. 1 )
+            CALL wrf_message ( a_message ) 
+            WRITE ( a_message,* ) ' ( config_flags%grid_fdda .NE. 0 )           ', ( config_flags%grid_fdda .NE. 0 )
+            CALL wrf_message ( a_message ) 
+            WRITE ( a_message,* ) ' ( config_flags%sst_update .EQ. 1 )          ', ( config_flags%sst_update .EQ. 1 )
+            CALL wrf_message ( a_message ) 
+            WRITE ( a_message,* ) ' ( config_flags%all_ic_times )               ', ( config_flags%all_ic_times )
+            CALL wrf_message ( a_message ) 
+            WRITE ( a_message,* ) ' ( config_flags%smooth_cg_topo )             ', ( config_flags%smooth_cg_topo )
+            CALL wrf_message ( a_message ) 
+            WRITE ( a_message,* ) ' ( config_flags%map_proj .EQ. PROJ_CASSINI ) ', ( config_flags%map_proj .EQ. PROJ_CASSINI )
+            CALL wrf_message ( a_message ) 
+
+            WRITE ( a_message,* ) 'Problems, we cannot have excluded middle data from WPS'
+            CALL wrf_error_fatal ( a_message )
+         END IF
+
+         !  Make sure that the excluded middle data from metgrid is "wide enough".  We only have to check
+         !  when the excluded middle was actually used in WPS.
+
+         IF ( config_flags%spec_bdy_width .GT. flag_excluded_middle ) THEN
+            WRITE ( a_message,* ) 'The WRF &bdy_control namelist.input spec_bdy_width = ', config_flags%spec_bdy_width
+            CALL wrf_message ( a_message ) 
+            WRITE ( a_message,* ) 'The WPS &metgrid namelist.wps process_only_bdy width = ',flag_excluded_middle
+            CALL wrf_message ( a_message ) 
+            WRITE ( a_message,* ) 'WPS process_only_bdy must be >= WRF spec_bdy_width'
+            CALL wrf_error_fatal ( a_message )
+         END IF
+      END IF
+      em_width = config_flags%spec_bdy_width
+
+      !  We need to find if there are any valid non-excluded-middle points in this
+      !  tile.  If so, then we need to hang on to a valid i,j location.
+
+      any_valid_points = .false.
+      find_valid : DO j = jts,jte
+         DO i = its,ite
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            any_valid_points = .true.
+            i_valid = i
+            j_valid = j
+            EXIT find_valid
+         END DO 
+      END DO find_valid
+
+      !  Replace traditional seaice field with optional seaice (AFWA source)
+
+      IF ( flag_icefrac .EQ. 1 ) THEN
+         DO j=jts,MIN(jde-1,jte)
+            DO i=its,MIN(ide-1,ite)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%xice(i,j) = grid%icefrac_gc(i,j)
+            END DO
+         END DO
+      END IF
+
+      !  Fix the snow (water equivalent depth, kg/m^2) and the snowh (physical snow
+      !  depth, m) fields.
+
+      IF      ( ( flag_snow .EQ. 0 ) .AND. ( flag_snowh .EQ. 0 ) ) THEN
+         DO j=jts,MIN(jde-1,jte)
+            DO i=its,MIN(ide-1,ite)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%snow(i,j)  = 0.
+               grid%snowh(i,j) = 0.
+            END DO
+         END DO
+
+      ELSE IF ( ( flag_snow .EQ. 0 ) .AND. ( flag_snowh .EQ. 1 ) ) THEN
+         DO j=jts,MIN(jde-1,jte)
+            DO i=its,MIN(ide-1,ite)
+!              ( m -> kg/m^2 )  & ( reduce to liquid, 5:1 ratio )
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%snow(i,j)  = grid%snowh(i,j) * 1000. / 5.
+            END DO
+         END DO
+
+      ELSE IF ( ( flag_snow .EQ. 1 ) .AND. ( flag_snowh .EQ. 0 ) ) THEN
+         DO j=jts,MIN(jde-1,jte)
+            DO i=its,MIN(ide-1,ite)
+!              ( kg/m^2 -> m)  & ( liquid to snow depth, 5:1 ratio )
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%snowh(i,j) = grid%snow(i,j) / 1000. * 5.
+            END DO
+         END DO
+
+      END IF
+
+      !  For backward compatibility, we might need to assign the map factors from
+      !  what they were, to what they are.
+
+      IF      ( ( config_flags%polar ) .AND. ( flag_mf_xy .EQ. 1 ) ) THEN
+         DO j=max(jds+1,jts),min(jde-1,jte)
+            DO i=its,min(ide-1,ite)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j)
+            END DO
+         END DO
+         IF(jts == jds) THEN
+            DO i=its,ite
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%msfvx(i,jts) = 0.
+               grid%msfvx_inv(i,jts) = 0.
+            END DO
+         END IF
+         IF(jte == jde) THEN
+            DO i=its,ite
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%msfvx(i,jte) = 0.
+               grid%msfvx_inv(i,jte) = 0.
+            END DO
+         END IF
+      ELSE IF ( ( config_flags%map_proj .EQ. PROJ_CASSINI ) .AND. ( flag_mf_xy .EQ. 1 ) ) THEN
+         DO j=jts,jte
+            DO i=its,min(ide-1,ite)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j)
+            END DO
+         END DO
+      ELSE IF ( ( .NOT. config_flags%map_proj .EQ. PROJ_CASSINI ) .AND. ( flag_mf_xy .NE. 1 ) ) THEN
+         DO j=jts,jte
+            DO i=its,ite
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%msfvx(i,j) = grid%msfv(i,j)
+               grid%msfvy(i,j) = grid%msfv(i,j)
+               grid%msfux(i,j) = grid%msfu(i,j)
+               grid%msfuy(i,j) = grid%msfu(i,j)
+               grid%msftx(i,j) = grid%msft(i,j)
+               grid%msfty(i,j) = grid%msft(i,j)
+            ENDDO
+         ENDDO
+         DO j=jts,min(jde,jte)
+            DO i=its,min(ide-1,ite)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j)
+            END DO
+         END DO
+      ELSE IF ( ( .NOT. config_flags%map_proj .EQ. PROJ_CASSINI ) .AND. ( flag_mf_xy .EQ. 1 ) ) THEN
+         IF ( grid%msfvx(its,jts) .EQ. 0 ) THEN
+            CALL wrf_error_fatal ( 'Maybe you do not have the new map factors, try re-running geogrid' )
+         END IF
+         DO j=jts,min(jde,jte)
+            DO i=its,min(ide-1,ite)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j)
+            END DO
+         END DO
+      ELSE IF ( ( config_flags%map_proj .EQ. PROJ_CASSINI ) .AND. ( flag_mf_xy .NE. 1 ) ) THEN
+         CALL wrf_error_fatal ( 'Neither SI data nor older metgrid data can initialize a global domain' )
+      ENDIF
+
+      !  Check to see what available surface temperatures we have.
+
+      IF ( flag_tavgsfc .EQ. 1 ) THEN
+         we_have_tavgsfc = .TRUE.
+      ELSE
+         we_have_tavgsfc = .FALSE.
+      END IF
+
+      IF ( flag_tsk     .EQ. 1 ) THEN
+         we_have_tsk     = .TRUE.
+      ELSE
+         we_have_tsk     = .FALSE.
+      END IF
+   
+      IF ( config_flags%use_tavg_for_tsk ) THEN
+         IF ( we_have_tsk .OR. we_have_tavgsfc ) THEN
+           !  we are OK
+         ELSE
+            CALL wrf_error_fatal ( 'We either need TSK or TAVGSFC, verify these fields are coming from WPS' )
+         END IF
+   
+         !  Since we require a skin temperature in the model, we can use the average 2-m temperature if provided.
+   
+         IF ( we_have_tavgsfc ) THEN
+            DO j=jts,min(jde,jte)
+               DO i=its,min(ide-1,ite)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%tsk(i,j) = grid%tavgsfc(i,j)
+               END DO
+            END DO
+         END IF
+      END IF
+
+      !  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 ---->
+
+         !  If this is data from the PINTERP program, it is emulating METGRID output.
+         !  One of the caveats of this data is the way that the vertical structure is
+         !  handled.  We take the k=1 level and toss it (it is disposable), and we
+         !  swap in the surface data.  This is done for all of the 3d fields about
+         !  which we show some interest: u, v, t, rh, ght, and p.  For u, v, and rh,
+         !  we assume no interesting vertical structure, and just assign the 1000 mb
+         !  data.  We directly use the 2-m temp for surface temp.  We use the surface
+         !  pressure field and the topography elevation for the lowest level of
+         !  pressure and height, respectively.
+
+         IF ( flag_pinterp .EQ. 1 ) THEN
+
+            WRITE ( a_message , * ) 'Data from P_INTERP program, filling k=1 level with artificial surface fields.'
+            CALL wrf_message ( a_message )
+            DO j=jts,jte
+               DO i=its,ite
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%u_gc(i,1,j) = grid%u_gc(i,2,j)
+                  grid%v_gc(i,1,j) = grid%v_gc(i,2,j)
+                  grid%rh_gc(i,1,j) = grid%rh_gc(i,2,j)
+                  grid%t_gc(i,1,j) = grid%t2(i,j)
+                  grid%ght_gc(i,1,j) = grid%ht(i,j)
+                  grid%p_gc(i,1,j) = grid%psfc(i,j)
+               END DO
+            END DO
+            flag_psfc = 0
+
+         END IF
+
+         !  Variables that are named differently between SI and WPS.
+
+         DO j = jts, MIN(jte,jde-1)
+            DO i = its, MIN(ite,ide-1)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%tsk(i,j) = grid%tsk_gc(i,j)
+               grid%tmn(i,j) = grid%tmn_gc(i,j)
+               grid%xlat(i,j) = grid%xlat_gc(i,j)
+               grid%xlong(i,j) = grid%xlong_gc(i,j)
+               grid%ht(i,j) = grid%ht_gc(i,j)
+            END DO
+         END DO
+
+         !  A user could request that the most coarse grid has the
+         !  topography along the outer boundary smoothed.  This smoothing
+         !  is similar to the coarse/nest interface.  The outer rows and
+         !  cols come from the existing large scale topo, and then the
+         !  next several rows/cols are a linear ramp of the large scale
+         !  model and the hi-res topo from WPS.  We only do this for the
+         !  coarse grid since we are going to make the interface consistent
+         !  in the model betwixt the CG and FG domains.
+
+         IF ( ( config_flags%smooth_cg_topo ) .AND. &
+              ( grid%id .EQ. 1 ) .AND. &
+              ( flag_soilhgt .EQ. 1) ) THEN
+            CALL blend_terrain ( grid%toposoil  , grid%ht , &
+                                 ids , ide , jds , jde , 1   , 1   , &
+                                 ims , ime , jms , jme , 1   , 1   , &
+                                 ips , ipe , jps , jpe , 1   , 1   )
+
+         END IF
+
+         !  Filter the input topography if this is a polar projection.
+
+         IF ( ( config_flags%polar ) .AND. ( grid%fft_filter_lat .GT. 90 ) ) THEN
+            CALL wrf_error_fatal ( 'If the polar boundary condition is used, then fft_filter_lat must be set in namelist.input' )
+         END IF
+
+         IF ( config_flags%map_proj .EQ. PROJ_CASSINI ) THEN
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+
+            !  We stick the topo and map fac in an unused 3d array. The map scale
+            !  factor and computational latitude are passed along for the ride
+            !  (part of the transpose process - we only do 3d arrays) to determine
+            !  "how many" values are used to compute the mean.  We want a number
+            !  that is consistent with the original grid resolution.
+
+
+            DO j = jts, MIN(jte,jde-1)
+              DO k = kts, kte
+                 DO i = its, MIN(ite,ide-1)
+                    grid%t_init(i,k,j) = 1.
+                 END DO
+              END DO
+              DO i = its, MIN(ite,ide-1)
+                 grid%t_init(i,1,j) = grid%ht(i,j)
+                 grid%t_init(i,2,j) = grid%msftx(i,j)
+                 grid%t_init(i,3,j) = grid%clat(i,j)
+              END DO
+            END DO
+
+# include "XPOSE_POLAR_FILTER_TOPO_z2x.inc"
+
+            !  Retrieve the 2d arrays for topo, map factors, and the
+            !  computational latitude.
+
+            DO j = jpsx, MIN(jpex,jde-1)
+              DO i = ipsx, MIN(ipex,ide-1)
+                 grid%ht_xxx(i,j)   = grid%t_xxx(i,1,j)
+                 grid%mf_xxx(i,j)   = grid%t_xxx(i,2,j)
+                 grid%clat_xxx(i,j) = grid%t_xxx(i,3,j)
+              END DO
+            END DO
+
+            !  Get a mean topo field that is consistent with the grid
+            !  distance on each computational latitude loop.
+
+            CALL filter_topo ( grid%ht_xxx , grid%clat_xxx , grid%mf_xxx , &
+                               grid%fft_filter_lat , &
+                               ids, ide, jds, jde, 1 , 1 , &
+                               imsx, imex, jmsx, jmex, 1, 1, &
+                               ipsx, ipex, jpsx, jpex, 1, 1 )
+
+            !  Stick the filtered topo back into the dummy 3d array to
+            !  transpose it back to "all z on a patch".
+
+            DO j = jpsx, MIN(jpex,jde-1)
+              DO i = ipsx, MIN(ipex,ide-1)
+                 grid%t_xxx(i,1,j) = grid%ht_xxx(i,j)
+              END DO
+            END DO
+
+# include "XPOSE_POLAR_FILTER_TOPO_x2z.inc"
+
+            !  Get the un-transposed topo data.
+
+            DO j = jts, MIN(jte,jde-1)
+              DO i = its, MIN(ite,ide-1)
+                 grid%ht(i,j) = grid%t_init(i,1,j)
+              END DO
+            END DO
+#else
+            CALL filter_topo ( grid%ht , grid%clat , grid%msftx , &
+                               grid%fft_filter_lat , &
+                               ids, ide, jds, jde, 1,1,           &
+                               ims, ime, jms, jme, 1,1,           &
+                               its, ite, jts, jte, 1,1 )
+#endif
+         END IF
+
+         !  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)
+                 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                 grid%psfc_gc(i,j) = grid%psfc(i,j)
+                 grid%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%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
+                     IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                     grid%ght_gc(i,1,j) = grid%toposoil(i,j)
+                     grid%ht_gc(i,j)= grid%toposoil(i,j)
+!                 END IF
+               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
+
+         !  For UM data, swap incoming extra (theta-based) pressure with the standardly
+         !  named (rho-based) pressure.
+
+         IF ( flag_ptheta .EQ. 1 ) THEN
+            DO j = jts, MIN(jte,jde-1)
+               DO k = 1 , num_metgrid_levels
+                  DO i = its, MIN(ite,ide-1)
+                     IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                     ptemp = grid%p_gc(i,k,j)
+                     grid%p_gc(i,k,j) = grid%prho_gc(i,k,j)
+                     grid%prho_gc(i,k,j) = ptemp
+                  END DO
+               END DO
+            END DO
+
+            !  For UM data, the "surface" and the "first hybrid" level for the theta-level data fields are the same.  
+            !  Average the surface (k=1) and the second hybrid level (k=num_metgrid_levels-1) to get the first hybrid
+            !  layer.  We only do this for the theta-level data: pressure, temperature, specific humidity, and
+            !  geopotential height (i.e. we do not modify u, v, or the rho-based pressure).
+
+            DO j = jts, MIN(jte,jde-1)
+               DO i = its, MIN(ite,ide-1)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%  p_gc(i,num_metgrid_levels,j) = ( grid%  p_gc(i,1,j) + grid%  p_gc(i,num_metgrid_levels-1,j) ) * 0.5
+                  grid%  t_gc(i,num_metgrid_levels,j) = ( grid%  t_gc(i,1,j) + grid%  t_gc(i,num_metgrid_levels-1,j) ) * 0.5
+                  grid% sh_gc(i,num_metgrid_levels,j) = ( grid% sh_gc(i,1,j) + grid% sh_gc(i,num_metgrid_levels-1,j) ) * 0.5
+                  grid%ght_gc(i,num_metgrid_levels,j) = ( grid%ght_gc(i,1,j) + grid%ght_gc(i,num_metgrid_levels-1,j) ) * 0.5
+               END DO
+            END DO
+         END IF
+
+         !  Check for and semi-fix missing surface fields.
+
+         IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN
+            k = 2
+         ELSE
+            k = num_metgrid_levels
+         END IF
+
+         IF ( grid%t_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN
+            DO j = jts, MIN(jte,jde-1)
+               DO i = its, MIN(ite,ide-1)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%t_gc(i,1,j) = grid%t_gc(i,k,j)
+               END DO
+            END DO
+            config_flags%use_surface = .FALSE.
+            grid%use_surface = .FALSE.
+            WRITE ( a_message , * ) 'Missing surface temp, replaced with closest level, use_surface set to false.'
+            CALL wrf_message ( a_message ) 
+         END IF
+
+         IF ( grid%rh_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN
+            DO j = jts, MIN(jte,jde-1)
+               DO i = its, MIN(ite,ide-1)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%rh_gc(i,1,j) = grid%rh_gc(i,k,j)
+               END DO
+            END DO
+            config_flags%use_surface = .FALSE.
+            grid%use_surface = .FALSE.
+            WRITE ( a_message , * ) 'Missing surface RH, replaced with closest level, use_surface set to false.'
+            CALL wrf_message ( a_message ) 
+         END IF
+
+         IF ( grid%u_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN
+            DO j = jts, MIN(jte,jde-1)
+               DO i = its, ite
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%u_gc(i,1,j) = grid%u_gc(i,k,j)
+               END DO
+            END DO
+            config_flags%use_surface = .FALSE.
+            grid%use_surface = .FALSE.
+            WRITE ( a_message , * ) 'Missing surface u wind, replaced with closest level, use_surface set to false.'
+            CALL wrf_message ( a_message ) 
+         END IF
+
+         IF ( grid%v_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN
+            DO j = jts, jte
+               DO i = its, MIN(ite,ide-1)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%v_gc(i,1,j) = grid%v_gc(i,k,j)
+               END DO
+            END DO
+            config_flags%use_surface = .FALSE.
+            grid%use_surface = .FALSE.
+            WRITE ( a_message , * ) 'Missing surface v wind, replaced with closest level, use_surface set to false.'
+            CALL wrf_message ( a_message ) 
+         END IF
+
+
+         !  Compute the mixing ratio from the input relative humidity.
+
+         IF ( ( flag_qv .NE. 1 ) .AND. ( flag_sh .NE. 1 ) ) THEN
+            IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN
+               k = 2
+            ELSE
+               k = num_metgrid_levels
+            END IF
+
+            IF      ( config_flags%rh2qv_method .eq. 1 ) THEN
+               CALL rh_to_mxrat1(grid%rh_gc, grid%t_gc, grid%p_gc, grid%qv_gc ,         &
+                                 config_flags%rh2qv_wrt_liquid ,                        &
+                                 config_flags%qv_max_p_safe ,                           &
+                                 config_flags%qv_max_flag , config_flags%qv_max_value , &
+                                 config_flags%qv_min_p_safe ,                           &
+                                 config_flags%qv_min_flag , config_flags%qv_min_value , &
+                                 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 IF ( config_flags%rh2qv_method .eq. 2 ) THEN
+               CALL rh_to_mxrat2(grid%rh_gc, grid%t_gc, grid%p_gc, grid%qv_gc ,         &
+                                 config_flags%rh2qv_wrt_liquid ,                        &
+                                 config_flags%qv_max_p_safe ,                           &
+                                 config_flags%qv_max_flag , config_flags%qv_max_value , &
+                                 config_flags%qv_min_p_safe ,                           &
+                                 config_flags%qv_min_flag , config_flags%qv_min_value , &
+                                 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
+
+
+         ELSE IF ( flag_sh .EQ. 1 ) THEN
+            IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN
+               k = 2
+            ELSE
+               k = num_metgrid_levels
+            END IF
+            IF ( grid%sh_gc(i_valid,kts,j_valid) .LT. 1.e-6 ) THEN
+               DO j = jts, MIN(jte,jde-1)
+                  DO i = its, MIN(ite,ide-1)
+                     IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                     grid%sh_gc(i,1,j) = grid%sh_gc(i,k,j)
+                  END DO
+               END DO
+            END IF
+
+            DO j = jts, MIN(jte,jde-1)
+               DO k = 1 , num_metgrid_levels
+                  DO i = its, MIN(ite,ide-1)
+                     IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                     grid%qv_gc(i,k,j) = grid%sh_gc(i,k,j) /( 1. - grid%sh_gc(i,k,j) )
+                     sat_vap_pres_mb = 0.6112*10.*EXP(17.67*(grid%t_gc(i,k,j)-273.15)/(grid%t_gc(i,k,j)-29.65))
+                     vap_pres_mb = grid%qv_gc(i,k,j) * grid%p_gc(i,k,j)/100. / (grid%qv_gc(i,k,j) + 0.622 )
+                     IF ( sat_vap_pres_mb .GT. 0 ) THEN
+                        grid%rh_gc(i,k,j) = ( vap_pres_mb / sat_vap_pres_mb ) * 100.
+                     ELSE
+                        grid%rh_gc(i,k,j) = 0.
+                     END IF
+                  END DO
+               END DO
+            END DO
+
+         END IF
+
+         !  Some data sets do not provide a 3d geopotential height field.  
+
+         IF ( grid%ght_gc(i_valid,grid%num_metgrid_levels/2,j_valid) .LT. 1 ) THEN
+            DO j = jts, MIN(jte,jde-1)
+               DO k = kts+1 , grid%num_metgrid_levels
+                  DO i = its, MIN(ite,ide-1)
+                     IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                     grid%ght_gc(i,k,j) = grid%ght_gc(i,k-1,j) - &
+                        R_d / g * 0.5 * ( grid%t_gc(i,k  ,j) * ( 1 + 0.608 * grid%qv_gc(i,k  ,j) ) +   &
+                                          grid%t_gc(i,k-1,j) * ( 1 + 0.608 * grid%qv_gc(i,k-1,j) ) ) * &
+                        LOG ( grid%p_gc(i,k,j) / grid%p_gc(i,k-1,j) )
+                  END DO
+               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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%u10(i,j)=grid%u_gc(i,1,j)
+            END DO
+         END DO
+
+         DO j = jts, min(jde,jte)
+            DO i = its, min(ide-1,ite)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%v10(i,j)=grid%v_gc(i,1,j)
+            END DO
+         END DO
+
+         DO j = jts, min(jde-1,jte)
+            DO i = its, min(ide-1,ite)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%t2(i,j)=grid%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)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%q2(i,j)=grid%qv_gc(i,1,j)
+               END DO
+            END DO
+         END IF
+
+         !  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%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 )
+
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+            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%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 )
+
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+            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%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%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%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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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
+
+         !  If the pressure levels in the middle of the atmosphere are upside down, then
+         !  this is hybrid data.  Computing the new surface pressure should use sfcprs2.
+
+         IF ( grid%p_gc(i_valid,num_metgrid_levels/2,j_valid) .LT. grid%p_gc(i_valid,num_metgrid_levels/2+1,j_valid) ) THEN
+            config_flags%sfcp_to_sfcp = .TRUE.
+         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%psfc is now hi-res.  The low-res surface pressure and
+         !  elevation are grid%psfc_gc and grid%ht_gc (same as grid%ght_gc(k=1)).
+
+         IF      ( ( flag_psfc    .EQ. 1 ) .AND. &
+                   ( flag_soilhgt .EQ. 1 ) .AND. &
+                   ( flag_slp     .EQ. 1 ) .AND. &
+                   ( .NOT. config_flags%sfcp_to_sfcp ) ) THEN
+            CALL sfcprs3(grid%ght_gc, grid%p_gc, grid%ht, &
+                         grid%pslv_gc, grid%psfc, &
+                         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 IF ( ( flag_psfc    .EQ. 1 ) .AND. &
+                   ( flag_soilhgt .EQ. 1 ) .AND. &
+                   ( config_flags%sfcp_to_sfcp ) ) THEN
+            CALL sfcprs2(grid%t_gc, grid%qv_gc, grid%ght_gc, grid%psfc_gc, grid%ht, &
+                         grid%tavgsfc, grid%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 IF ( flag_slp     .EQ. 1 ) THEN
+            CALL sfcprs (grid%t_gc, grid%qv_gc, grid%ght_gc, grid%pslv_gc, grid%ht, &
+                         grid%tavgsfc, grid%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
+            WRITE(a_message,FMT='(3(A,I2),A,L1)') 'ERROR in psfc: flag_psfc = ',flag_psfc, &
+                                               ', flag_soilhgt = ',flag_soilhgt , &
+                                               ', flag_slp = ',flag_slp , & 
+                                               ', sfcp_to_sfcp = ',config_flags%sfcp_to_sfcp 
+            CALL wrf_message ( a_message ) 
+            CALL wrf_error_fatal ( 'not enough info for a p sfc computation' )
+         END IF
+
+         !  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)
+                 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                 grid%psfc_gc(i,j) = grid%psfc(i,j)
+                 grid%p_gc(i,1,j) = grid%psfc(i,j)
+              END DO
+            END DO
+         END IF
+
+         !  Integrate the mixing ratio to get the vapor pressure.
+
+         CALL integ_moist ( grid%qv_gc , grid%p_gc , grid%pd_gc , grid%t_gc , grid%ght_gc , grid%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 )
+
+         !  If this is UM data, the same moisture removed from the "theta" level pressure data can 
+         !  be removed from the "rho" level pressures.  This is an approximation.  We'll revisit to
+         !  see if this is a bad idea.
+
+         IF ( flag_ptheta .EQ. 1 ) THEN
+            DO j = jts, MIN(jte,jde-1)
+               DO k = num_metgrid_levels-1 , 1 , -1
+                  DO i = its, MIN(ite,ide-1)
+                     IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                     ptemp = ((grid%p_gc(i,k,j) - grid%pd_gc(i,k,j)) + (grid%p_gc(i,k+1,j) - grid%pd_gc(i,k+1,j)))/2
+                     grid%pdrho_gc(i,k,j) = grid%prho_gc(i,k,j) - ptemp
+                  END DO
+               END DO
+            END DO
+         END IF
+
+
+         !  Compute the difference between the dry, total surface pressure (input) and the
+         !  dry top pressure (constant).
+
+         CALL p_dts ( grid%mu0 , grid%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%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%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%znw , &
+                               eta_levels , max_eta , max_dz , &
+                               grid%p_top , g , p00 , cvpm , a , r_d , cp , t00 , p1000mb , t0 , tiso , &
+                               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%t_gc , grid%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 )
+
+         IF ( flag_slp .EQ. 1 ) THEN
+
+            !  On the eta surfaces, compute the dry pressure = mu eta, stored in
+            !  grid%pb, since it is a pressure, and we don't need another kms:kme 3d
+            !  array floating around.  The grid%pb array is re-computed as the base pressure
+            !  later after the vertical interpolations are complete.
+
+            CALL p_dry ( grid%mu0 , grid%znw , grid%p_top , grid%pb , want_full_levels , &
+                         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%pd_gc).  The target levels (grid%pb)
+            !  had the vapor pressure removed from the surface pressure, then they were
+            !  scaled by the eta levels.
+
+            interp_type = 2
+            lagrange_order = grid%lagrange_order
+            lowest_lev_from_sfc = .FALSE.
+            use_levels_below_ground = .TRUE.
+            use_surface = .TRUE.
+            zap_close_levels = grid%zap_close_levels
+            force_sfc_in_vinterp = 0
+            t_extrap_type = grid%t_extrap_type
+            extrap_type = 1
+
+            !  For the height field, the lowest level pressure is the slp (approximately "dry").  The
+            !  lowest level of the input height field (to be associated with slp) then is an array
+            !  of zeros.
+
+            DO j = jts, MIN(jte,jde-1)
+               DO i = its, MIN(ite,ide-1)
+                  grid%psfc_gc(i,j) = grid%pd_gc(i,1,j)
+                  grid%pd_gc(i,1,j) = grid%pslv_gc(i,j) - ( grid%p_gc(i,1,j) - grid%pd_gc(i,1,j) )
+                  grid%ht_gc(i,j) = grid%ght_gc(i,1,j)
+                  grid%ght_gc(i,1,j) = 0.
+               END DO
+            END DO
+
+            CALL vert_interp ( grid%ght_gc , grid%pd_gc , grid%ph0 , grid%pb , &
+                               num_metgrid_levels , 'Z' , &
+                               interp_type , lagrange_order , extrap_type , &
+                               lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
+                               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 )
+
+            !  Put things back to normal.
+
+            DO j = jts, MIN(jte,jde-1)
+               DO i = its, MIN(ite,ide-1)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%pd_gc(i,1,j) = grid%psfc_gc(i,j)
+                  grid%ght_gc(i,1,j) = grid%ht_gc(i,j)
+               END DO
+            END DO
+
+         END IF
+
+         !  Now the rest of the variables on half-levels to inteprolate.
+
+         CALL p_dry ( grid%mu0 , grid%znw , grid%p_top , grid%pb , want_half_levels , &
+                      ids , ide , jds , jde , kds , kde , &
+                      ims , ime , jms , jme , kms , kme , &
+                      its , ite , jts , jte , kts , kte )
+
+         interp_type = grid%interp_type
+         lagrange_order = grid%lagrange_order
+         lowest_lev_from_sfc = grid%lowest_lev_from_sfc
+         use_levels_below_ground = grid%use_levels_below_ground
+         use_surface = grid%use_surface
+         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
+
+         !  Interpolate RH, diagnose Qv later when have temp and pressure.  Temporarily
+         !  store this in the u_1 space, for later diagnosis into Qv and stored into moist.
+
+         CALL vert_interp ( grid%rh_gc , grid%pd_gc , grid%u_1 , grid%pb , &
+                            num_metgrid_levels , 'Q' , &
+                            interp_type , lagrange_order , extrap_type , &
+                            lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
+                            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%t_gc , grid%pd_gc , grid%t_2               , grid%pb , &
+                            num_metgrid_levels , 'T' , &
+                            interp_type , lagrange_order , t_extrap_type , &
+                            lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
+                            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%p_gc , grid%pd_gc , grid%p               , grid%pb , &
+                            num_metgrid_levels , 'T' , &
+                            interp_type , lagrange_order , t_extrap_type , &
+                            lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
+                            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 )
+
+         !  Do not have full pressure on eta levels, get a first guess at Qv by using
+         !  dry pressure.  The use of u_1 (rh) and v_1 (temperature) is temporary.
+         !  We fix the approximation to Qv after the total pressure is available on
+         !  eta surfaces.
+
+         grid%v_1 = grid%t_2
+         CALL theta_to_t ( grid%v_1 , grid%p  , p00 , &
+                           ids , ide , jds , jde , kds , kde , &
+                           ims , ime , jms , jme , kms , kme , &
+                           its , ite , jts , jte , kts , kte )
+
+         IF      ( config_flags%rh2qv_method .eq. 1 ) THEN
+            CALL rh_to_mxrat1(grid%u_1, grid%v_1, grid%p , moist(:,:,:,P_QV) ,       &
+                              config_flags%rh2qv_wrt_liquid ,                        &
+                              config_flags%qv_max_p_safe ,                           &
+                              config_flags%qv_max_flag , config_flags%qv_max_value , &
+                              config_flags%qv_min_p_safe ,                           &
+                              config_flags%qv_min_flag , config_flags%qv_min_value , &
+                              ids , ide , jds , jde , kds , kde ,                    &
+                              ims , ime , jms , jme , kms , kme ,                    &
+                              its , ite , jts , jte , kts , kte-1 )
+         ELSE IF ( config_flags%rh2qv_method .eq. 2 ) THEN
+            CALL rh_to_mxrat2(grid%u_1, grid%v_1, grid%p , moist(:,:,:,P_QV) ,       &
+                              config_flags%rh2qv_wrt_liquid ,                        &
+                              config_flags%qv_max_p_safe ,                           &
+                              config_flags%qv_max_flag , config_flags%qv_max_value , &
+                              config_flags%qv_min_p_safe ,                           &
+                              config_flags%qv_min_flag , config_flags%qv_min_value , &
+                              ids , ide , jds , jde , kds , kde ,                    &
+                              ims , ime , jms , jme , kms , kme ,                    &
+                              its , ite , jts , jte , kts , kte-1 )
+         END IF
+
+         num_3d_m = num_moist
+         num_3d_s = num_scalar
+
+         IF ( flag_qr .EQ. 1 ) THEN
+            DO im = PARAM_FIRST_SCALAR, num_3d_m
+               IF ( im .EQ. P_QR ) THEN
+                  CALL vert_interp ( grid%qr_gc , grid%pd_gc , moist(:,:,:,P_QR) , grid%pb , &
+                                     num_metgrid_levels , 'Q' , &
+                                     interp_type , lagrange_order , extrap_type , &
+                                     lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
+                                     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 ( grid%qc_gc , grid%pd_gc , moist(:,:,:,P_QC) , grid%pb , &
+                                     num_metgrid_levels , 'Q' , &
+                                     interp_type , lagrange_order , extrap_type , &
+                                     lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
+                                     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 ( grid%qi_gc , grid%pd_gc , moist(:,:,:,P_QI) , grid%pb , &
+                                     num_metgrid_levels , 'Q' , &
+                                     interp_type , lagrange_order , extrap_type , &
+                                     lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
+                                     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 ( grid%qs_gc , grid%pd_gc , moist(:,:,:,P_QS) , grid%pb , &
+                                     num_metgrid_levels , 'Q' , &
+                                     interp_type , lagrange_order , extrap_type , &
+                                     lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
+                                     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 ( grid%qg_gc , grid%pd_gc , moist(:,:,:,P_QG) , grid%pb , &
+                                     num_metgrid_levels , 'Q' , &
+                                     interp_type , lagrange_order , extrap_type , &
+                                     lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
+                                     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_qh .EQ. 1 ) THEN
+            DO im = PARAM_FIRST_SCALAR, num_3d_m
+               IF ( im .EQ. P_QH ) THEN
+                  CALL vert_interp ( grid%qh_gc , grid%pd_gc , moist(:,:,:,P_QH) , grid%pb , &
+                                     num_metgrid_levels , 'Q' , &
+                                     interp_type , lagrange_order , extrap_type , &
+                                     lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
+                                     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_qni .EQ. 1 ) THEN
+            DO im = PARAM_FIRST_SCALAR, num_3d_s
+               IF ( im .EQ. P_QNI ) THEN
+                  CALL vert_interp ( grid%qni_gc , grid%pd_gc , scalar(:,:,:,P_QNI) , grid%pb , &
+                                     num_metgrid_levels , 'Q' , &
+                                     interp_type , lagrange_order , extrap_type , &
+                                     lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
+                                     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 this is UM data, put the dry rho-based pressure back into the dry pressure array.
+         !  Since the dry pressure is no longer needed, no biggy.
+
+         IF ( flag_ptheta .EQ. 1 ) THEN
+            DO j = jts, MIN(jte,jde-1)
+               DO k = 1 , num_metgrid_levels
+                  DO i = its, MIN(ite,ide-1)
+                     IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                     grid%pd_gc(i,k,j) = grid%prho_gc(i,k,j)
+                  END DO
+               END DO
+            END DO
+         END IF
+
+#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%pd_gc) and the pressure of the new coordinate
+         !  (grid%pb) are both communicated with an 8 stencil.
+
+#   include "HALO_EM_VINTERP_UV_1.inc"
+#endif
+
+         CALL vert_interp ( grid%u_gc , grid%pd_gc , grid%u_2               , grid%pb , &
+                            num_metgrid_levels , 'U' , &
+                            interp_type , lagrange_order , extrap_type , &
+                            lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
+                            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%v_gc , grid%pd_gc , grid%v_2               , grid%pb , &
+                            num_metgrid_levels , 'V' , &
+                            interp_type , lagrange_order , extrap_type , &
+                            lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
+                            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 ---->
+
+      ! Set the temperature of the inland lakes to tavgsfc if the temperature is available
+      ! and islake is > num_veg_cat
+
+      num_veg_cat      = SIZE ( grid%landusef , DIM=2 )
+      CALL nl_get_iswater ( grid%id , grid%iswater )
+      CALL nl_get_islake  ( grid%id , grid%islake )
+
+      IF ( grid%islake < 0 ) THEN
+         CALL wrf_debug ( 0 , 'Old data, no inland lake information')
+      ELSE
+         IF ( we_have_tavgsfc ) THEN
+
+            CALL wrf_debug ( 0 , 'Using inland lakes with average surface temperature')
+            DO j=jts,MIN(jde-1,jte)
+               DO i=its,MIN(ide-1,ite)
+                  IF ( grid%landusef(i,grid%islake,j) >= 0.5 ) THEN
+                     IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                     grid%sst(i,j) = grid%tavgsfc(i,j)
+                     grid%tsk(i,j) = grid%tavgsfc(i,j)
+                  END IF
+               END DO
+            END DO
+
+         ELSE     ! We don't have tavgsfc
+
+            CALL wrf_debug ( 0 , 'No average surface temperature for use with inland lakes')
+
+         END IF
+         DO j=jts,MIN(jde-1,jte)
+            DO i=its,MIN(ide-1,ite)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%landusef(i,grid%iswater,j) = grid%landusef(i,grid%iswater,j) + &
+                                                 grid%landusef(i,grid%islake,j)
+               grid%landusef(i,grid%islake,j) = 0.
+            END DO
+         END DO
+
+      END IF
+
+      !  Save the grid%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)
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            grid%tsk_save(i,j) = grid%tsk(i,j)
+         END DO
+      END DO
+
+      !  Protect against bad grid%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 ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. &
+                 ( grid%sst(i,j) .GT. 170. ) .AND. ( grid%sst(i,j) .LT. 400. ) ) THEN
+               grid%tsk(i,j) = grid%sst(i,j)
+            ENDIF
+         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 ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            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
+
+         CASE (PXLSMSCHEME)
+            IF ( num_st_levels_input .LT. 2 ) THEN
+               CALL wrf_error_fatal ( 'Not enough soil temperature data for P-X LSM scheme.')
+            END IF
+
+      END SELECT enough_data
+
+      interpolate_soil_tmw : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
+
+         CASE ( SLABSCHEME , LSMSCHEME , RUCLSMSCHEME, PXLSMSCHEME )
+            CALL process_soil_real ( grid%tsk , grid%tmn , grid%tavgsfc,  &
+                                  grid%landmask , grid%sst , grid%ht, grid%toposoil, &
+                                  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_tavgsfc, &
+                                  flag_soilhgt, flag_soil_layers, flag_soil_levels, &
+                                  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
+
+      !  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)
+      !  surface_input_source=3 => use dominant data from static file (dominant category as input)
+
+      IF ( config_flags%surface_input_source .EQ. 1 ) THEN
+
+      !  Generate the vegetation and soil category information from the fractional input
+      !  data, or use the existing dominant category fields if they exist.
+
+         grid%vegcat (its,jts) = 0
+         grid%soilcat(its,jts) = 0
+
+         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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%vegcat(i,j)  = grid%ivgtyp(i,j)
+               grid%soilcat(i,j) = grid%isltyp(i,j)
+            END DO
+         END DO
+
+      ELSE IF ( config_flags%surface_input_source .EQ. 2 ) THEN
+
+         !  Do we have dominant soil and veg data from the input already?
+
+         IF ( grid%soilcat(i_valid,j_valid) .GT. 0.5 ) THEN
+            DO j = jts, MIN(jde-1,jte)
+               DO i = its, MIN(ide-1,ite)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%isltyp(i,j) = NINT( grid%soilcat(i,j) )
+               END DO
+            END DO
+         END IF
+         IF ( grid%vegcat(i_valid,j_valid) .GT. 0.5 ) THEN
+            DO j = jts, MIN(jde-1,jte)
+               DO i = its, MIN(ide-1,ite)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%ivgtyp(i,j) = NINT( grid%vegcat(i,j) )
+               END DO
+            END DO
+         END IF
+
+      ELSE IF ( config_flags%surface_input_source .EQ. 3 ) THEN
+
+         !  Do we have dominant soil and veg data from the static input already?
+
+         IF ( grid%sct_dom_gc(i_valid,j_valid) .GT. 0.5 ) THEN
+            DO j = jts, MIN(jde-1,jte)
+               DO i = its, MIN(ide-1,ite)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%isltyp(i,j) = NINT( grid%sct_dom_gc(i,j) )
+                  grid%soilcat(i,j) = grid%isltyp(i,j)
+               END DO
+            END DO
+         ELSE
+            WRITE ( a_message , * ) 'You have set surface_input_source = 3, but your geogrid data does not have valid dominant soil data.'
+            CALL wrf_error_fatal ( a_message ) 
+         END IF
+         IF ( grid%lu_index(i_valid,j_valid) .GT. 0.5 ) THEN
+            DO j = jts, MIN(jde-1,jte)
+               DO i = its, MIN(ide-1,ite)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%ivgtyp(i,j) = NINT( grid%lu_index(i,j) )
+                  grid%vegcat(i,j) = grid%ivgtyp(i,j)
+               END DO
+            END DO
+         ELSE
+            WRITE ( a_message , * ) 'You have set surface_input_source = 3, but your geogrid data does not have valid dominant land use data.'
+            CALL wrf_error_fatal ( a_message ) 
+         END IF
+
+      END IF
+
+      !  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 , &
+                                   config_flags%fractional_seaice, &
+                                   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 )
+
+      !  Land use assignment.
+
+      DO j = jts, MIN(jde-1,jte)
+         DO i = its, MIN(ide-1,ite)
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            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
+
+
+      !  Fix grid%tmn and grid%tsk.
+
+      fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
+
+         CASE ( SLABSCHEME , LSMSCHEME , RUCLSMSCHEME, PXLSMSCHEME )
+            DO j = jts, MIN(jde-1,jte)
+               DO i = its, MIN(ide-1,ite)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. &
+                       ( grid%sst(i,j) .GT. 170. ) .AND. ( grid%sst(i,j) .LT. 400. ) ) 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%tsk reasonable?
+
+      IF ( internal_time_loop .NE. 1 ) THEN
+         DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               IF ( grid%tsk(i,j) .LT. 170 .or. grid%tsk(i,j) .GT. 400. ) THEN
+                  grid%tsk(i,j) = grid%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 ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               IF ( grid%tsk(i,j) .LT. 170 .or. grid%tsk(i,j) .GT. 400. ) THEN
+                  print *,'error in the grid%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%tsk unreasonable' )
+                  end if
+               END IF
+            END DO
+         END DO
+      END IF
+
+      !  Is the grid%tmn reasonable?
+
+      DO j = jts, MIN(jde-1,jte)
+         DO i = its, MIN(ide-1,ite)
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            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%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%tmn unreasonable' )
+               endif
+            END IF
+         END DO
+      END DO
+   
+
+      !  Minimum soil values, residual, from RUC LSM scheme.  For input from Noah or EC, 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_soil_layers == 1 ) THEN
+                  DO j = jts, MIN(jde-1,jte)
+                     DO i = its, MIN(ide-1,ite)
+                        IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                        IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .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_soil_levels == 1 ) THEN
+                  DO j = jts, MIN(jde-1,jte)
+                     DO i = its, MIN(ide-1,ite)
+                        IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                        grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) + lqmi(grid%isltyp(i,j)) , 0.005 )
+                     END DO
+                  END DO
+                  DO j = jts, MIN(jde-1,jte)
+                     DO i = its, MIN(ide-1,ite)
+                        IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                        IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .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_soil_layers == 1 ) THEN
+                  DO j = jts, MIN(jde-1,jte)
+                     DO i = its, MIN(ide-1,ite)
+                        IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                        grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) - lqmi(grid%isltyp(i,j)) , 0.005 )
+                     END DO
+                  END DO
+               ELSE IF ( flag_soil_levels == 1 ) THEN
+                  ! no op
+               END IF
+
+             CASE ( PXLSMSCHEME )
+               iicount = 0
+               IF ( flag_soil_layers == 1 ) THEN
+                  ! no op
+               ELSE IF ( flag_soil_levels == 1 ) THEN
+                  DO j = jts, MIN(jde-1,jte)
+                     DO i = its, MIN(ide-1,ite)
+                        IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                        grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) + lqmi(grid%isltyp(i,j)) , 0.005 )
+                     END DO
+                  END DO
+               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 ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  IF ( grid%tslb(i,ns,j) .LT. 170 .or. grid%tslb(i,ns,j) .GT. 400. ) THEN
+                     grid%tslb(i,ns,j) = grid%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 ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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 ).AND. &
+                          ( model_config_rec%sf_surface_physics(grid%id) .NE. PXLSMSCHEME ) ) 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, PXLSMSCHEME )
+                              CALL wrf_error_fatal ( 'Assigned constant soil moisture to 0.3, stopping')
+                              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 , &
+                                    grid%sst,flag_sst, &
+                                    config_flags%fractional_seaice, &
+                                    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 ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            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%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 ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+           IF ( flag_sst .NE. 1 ) THEN
+             grid%sst(i,j) = grid%tsk(i,j)
+           ENDIF
+         END DO
+      END DO
+!tgs set snoalb to land value if the water point is covered with ice
+      DO j = jts, MIN(jde-1,jte)
+         DO i = its, MIN(ide-1,ite)
+           IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+           IF ( grid%ivgtyp(i,j) .EQ. config_flags%isice) THEN
+             grid%snoalb(i,j) = 0.75
+           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%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%znw(1) is neither 0 nor 1 (within a tolerance of 10**-5)
+
+      were_bad = .false.
+      IF ( ( (grid%znw(1).LT.(1-1.E-5) ) .OR. ( grid%znw(1).GT.(1+1.E-5) ) ).AND. &
+           ( (grid%znw(1).LT.(0-1.E-5) ) .OR. ( grid%znw(1).GT.(0+1.E-5) ) ) ) THEN
+         were_bad = .true.
+         print *,'Your grid%znw input values are probably half-levels. '
+         print *,grid%znw
+         print *,'WRF expects grid%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%znw(1).LT.0) THEN
+            grid%znw(1)=0
+         END IF
+         DO k=2,kde
+            grid%znw(k)=2*grid%znw(k)-grid%znw(k-1)
+         END DO
+      END IF
+
+      !  Let's check our changes
+
+      IF ( ( ( grid%znw(1) .LT. (1-1.E-5) ) .OR. ( grid%znw(1) .GT. (1+1.E-5) ) ).AND. &
+           ( ( grid%znw(1) .LT. (0-1.E-5) ) .OR. ( grid%znw(1) .GT. (0+1.E-5) ) ) ) THEN
+         print *,'The input grid%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%znw values from input files")
+      ELSE IF ( were_bad ) THEN
+         print *,'...adjusted. grid%znw array now contains full eta level values. '
+      ENDIF
+
+      IF ( grid%znw(1) .LT. grid%znw(kde) ) THEN
+         DO k=1, kde/2
+            hold_znw = grid%znw(k)
+            grid%znw(k)=grid%znw(kde+1-k)
+            grid%znw(kde+1-k)=hold_znw
+         END DO
+      END IF
+
+      DO k=1, kde-1
+         grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
+         grid%rdnw(k) = 1./grid%dnw(k)
+         grid%znu(k) = 0.5*(grid%znw(k+1)+grid%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%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
+         grid%rdn(k) = 1./grid%dn(k)
+         grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
+         grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
+      END DO
+
+      !  Scads of vertical coefficients.
+
+      cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2)
+      cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3)
+
+      grid%cf1  = grid%fnp(2) + cof1
+      grid%cf2  = grid%fnm(2) - cof1 - cof2
+      grid%cf3  = cof2
+
+      grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
+      grid%cfn1 = -.5*grid%dnw(kde-1)/grid%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%ph0 is total,
+      !  and grid%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
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            grid%ph0(i,1,j) = grid%ht(i,j) * g
+            grid%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)
+
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+    
+            !  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%php(i,k,j) = grid%znw(k)*(p_surf - grid%p_top) + grid%p_top ! temporary, full lev base pressure
+               grid%pb(i,k,j) = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+               temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) )
+!              temp =             t00 + A*LOG(grid%pb(i,k,j)/p00)
+               grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0
+               grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm
+            END DO
+
+            !  Base state mu is defined as base state surface pressure minus grid%p_top
+
+            grid%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%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%phb(i,1,j) = grid%ht(i,j) * g
+            DO k  = 2,kte
+               grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%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%mub(i,j) = grid%mub(i-1,j)
+         grid%mu_2(i,j) = grid%mu_2(i-1,j)
+         DO k = 1, kte-1
+            grid%pb(i,k,j) = grid%pb(i-1,k,j)
+            grid%t_init(i,k,j) = grid%t_init(i-1,k,j)
+            grid%alb(i,k,j) = grid%alb(i-1,k,j)
+         END DO
+         DO k = 1, kte
+            grid%phb(i,k,j) = grid%phb(i-1,k,j)
+         END DO
+      END DO
+      END IF
+
+      IF ( jte .EQ. jde ) THEN
+      j = jde
+      DO i = its, ite
+         grid%mub(i,j) = grid%mub(i,j-1)
+         grid%mu_2(i,j) = grid%mu_2(i,j-1)
+         DO k = 1, kte-1
+            grid%pb(i,k,j) = grid%pb(i,k,j-1)
+            grid%t_init(i,k,j) = grid%t_init(i,k,j-1)
+            grid%alb(i,k,j) = grid%alb(i,k,j-1)
+         END DO
+         DO k = 1, kte
+            grid%phb(i,k,j) = grid%phb(i,k,j-1)
+         END DO
+      END DO
+      END IF
+
+      !  Compute the perturbation dry pressure (grid%mub + grid%mu_2 + ptop = dry grid%psfc).
+
+      DO j = jts, min(jde-1,jte)
+         DO i = its, min(ide-1,ite)
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            grid%mu_2(i,j) = grid%mu0(i,j) - grid%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%mu_2(i,j) = grid%mu_2(i-1,j)
+      END DO
+      END IF
+
+      IF ( jte .EQ. jde ) THEN
+      j = jde
+      DO i = its, ite
+         grid%mu_2(i,j) = grid%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)
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+
+            !  Assign the potential temperature (perturbation from t0) and qv on all the mass
+            !  point locations.
+
+            DO k =  1 , kde-1
+               grid%t_2(i,k,j)          = grid%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%p(i,k,j) = - 0.5*(grid%mu_2(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+               qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+               grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf&
+                                 *(((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+               grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+               grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_2(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+                  qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+                  grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* &
+                              (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+                  grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+                  grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
+               END DO
+
+#if 1
+               !  This is the hydrostatic equation used in the model after the small timesteps.  In
+               !  the model, grid%al (inverse density) is computed from the geopotential.
+
+               DO k  = 2,kte
+                  grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) - &
+                                grid%dnw(k-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,k-1,j) &
+                              + grid%mu_2(i,j)*grid%alb(i,k-1,j) )
+                  grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j)
+               END DO
+#else
+               !  Get the perturbation geopotential from the 3d height array from WPS.
+
+               DO k  = 2,kte
+                  grid%ph_2(i,k,j) = grid%ph0(i,k,j)*g - grid%phb(i,k,j)
+               END DO
+#endif
+
+               !  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. i_valid ) .AND. ( j .EQ. j_valid ) ) THEN
+                  DO k = 1 , num_metgrid_levels
+                     IF ( ABS ( grid%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. &
+                    ( flag_ptheta  .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%php is defined above as
+                     !  the full-lev base pressure, an easy array to use for 3d space).
+
+                     pl = grid%php(i,k  ,j) + &
+                          ( grid%p(i,k-1  ,j) * ( grid%znw(k    ) - grid%znu(k  ) ) + &
+                            grid%p(i,k    ,j) * ( grid%znu(k-1  ) - grid%znw(k  ) ) ) / &
+                          ( grid%znu(k-1  ) - grid%znu(k  ) )
+                     pu = grid%php(i,k+1,j) + &
+                          ( grid%p(i,k-1+1,j) * ( grid%znw(k  +1) - grid%znu(k+1) ) + &
+                            grid%p(i,k  +1,j) * ( grid%znu(k-1+1) - grid%znw(k+1) ) ) / &
+                          ( grid%znu(k-1+1) - grid%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%ph_2(i,k  ,j) + grid%phb(i,k  ,j) ) / g
+                        zu = ( grid%ph_2(i,k+1,j) + grid%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%mu_2.  The grid%php is still full-levels, base pressure.
+
+                        dz500 = z500 - grid%ght_gc(i,lev500,j)
+                        tvsfc = ((grid%t_2(i,1,j)+t0)*((grid%p(i,1,j)+grid%php(i,1,j))/p1000mb)**(r_d/cp)) * &
+                                (1.+0.6*moist(i,1,j,P_QV))
+                        dpmu = ( grid%php(i,1,j) + grid%p(i,1,j) ) * EXP ( g * dz500 / ( r_d * tvsfc ) )
+                        dpmu = dpmu - ( grid%php(i,1,j) + grid%p(i,1,j) )
+                        grid%mu_2(i,j) = grid%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%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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%u10(i,j)=grid%u_2(i,1,j)
+            END DO
+         END DO
+
+         DO j = jts, min(jde,jte)
+            DO i = its, min(ide-1,ite)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               grid%v10(i,j)=grid%v_2(i,1,j)
+            END DO
+         END DO
+
+         DO j = jts, min(jde-1,jte)
+            DO i = its, min(ide-1,ite)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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%p(i,1,j)
+               grid%q2(i,j)=moist(i,1,j,P_QV)
+               grid%th2(i,j)=grid%t_2(i,1,j)+300.
+               grid%t2(i,j)=grid%th2(i,j)*(((grid%p(i,1,j)+grid%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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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%p(i,1,j)
+               grid%th2(i,j)=grid%t2(i,j)*(p00/(grid%p(i,1,j)+grid%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)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  grid%q2(i,j)=moist(i,1,j,P_QV)
+               END DO
+            END DO
+         END IF
+
+      END IF
+      CALL cpu_time(t_end)
+
+!  Set flag to denote that we are saving original values of HT, MUB, and
+!  PHB for 2-way nesting and cycling.
+
+      grid%save_topo_from_real=1
+
+      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 , tiso ) 
+      USE module_configure
+      IMPLICIT NONE
+      !  For the real-data-cases only.
+      REAL , INTENT(OUT) :: p00 , t00 , a , tiso
+      CALL nl_get_base_pres  ( 1 , p00 )
+      CALL nl_get_base_temp  ( 1 , t00 )
+      CALL nl_get_base_lapse ( 1 , a   )
+      CALL nl_get_iso_temp   ( 1 , tiso )
+   END SUBROUTINE const_module_initialize
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE rebalance_driver ( grid )
+
+      IMPLICIT NONE
+
+      TYPE (domain)          :: grid
+
+      CALL rebalance( grid &
+!
+#include "actual_new_args.inc"
+!
+      )
+
+   END SUBROUTINE rebalance_driver
+
+!---------------------------------------------------------------------
+
+   SUBROUTINE rebalance ( grid  &
+!
+#include "dummy_new_args.inc"
+!
+                        )
+      IMPLICIT NONE
+
+      TYPE (domain)          :: grid
+
+#include "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 , tiso
+      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
+
+      REAL    :: temp, temp_int
+
+      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) )
+
+      !  Fill config_flags the options for a particular domain
+
+      CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
+
+      !  Some of the many weird geopotential initializations that we'll see today: grid%ph0 is total,
+      !  and grid%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%ph0(i,1,j) = grid%ht_fine(i,j) * g
+            grid%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), and constant stratosphere
+      !  temp (tiso, K) either from input file or from namelist (for backward compatibiliy).
+
+      IF ( config_flags%use_baseparam_fr_nml ) then
+      ! get these from namelist
+         CALL wrf_message('ndown: using namelist constants')
+         CALL const_module_initialize ( p00 , t00 , a , tiso ) 
+      ELSE
+      ! get these constants from model data
+         CALL wrf_message('ndown: using constants from file')
+         t00  = grid%t00
+         p00  = grid%p00
+         a    = grid%tlp
+         tiso = grid%tiso
+
+         IF (t00 .LT. 100. .or. p00 .LT. 10000.) THEN
+            WRITE(wrf_err_message,*)&
+      'ndown_em: did not find base state parameters in wrfout. Add use_baseparam_fr_nml = .t. in &dynamics and rerun'
+            CALL wrf_error_fatal(TRIM(wrf_err_message))
+         ENDIF
+      ENDIF
+
+      !  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%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%pb(i,k,j) = grid%znu(k)*(p_surf     - grid%p_top) + grid%p_top
+               pb_int    = grid%znu(k)*(p_surf_int - grid%p_top) + grid%p_top
+               temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) )
+!              temp =             t00 + A*LOG(pb/p00)
+               grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0
+!              grid%t_init(i,k,j)    = (t00 + A*LOG(grid%pb(i,k,j)/p00))*(p00/grid%pb(i,k,j))**(r_d/cp) - t0
+               temp_int = MAX ( tiso, t00 + A*LOG(pb_int   /p00) )
+               t_init_int(i,k,j)= temp_int*(p00/pb_int   )**(r_d/cp) - t0
+!              t_init_int(i,k,j)= (t00 + A*LOG(pb_int   /p00))*(p00/pb_int   )**(r_d/cp) - t0
+               grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm
+            END DO
+
+            !  Base state mu is defined as base state surface pressure minus grid%p_top
+
+            grid%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%mub(i,j) + grid%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%phb(i,1,j) = grid%ht_fine(i,j) * g
+            DO k  = 2,kte
+               grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%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%t_2(i,k,j) = grid%t_2(i,k,j) + ( grid%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%p(i,k,j) = - 0.5*(grid%mu_2(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+            qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+            grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* &
+                                 (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+            grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_2(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+               qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+               grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* &
+                           (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+               grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+            END DO
+
+            !  This is the hydrostatic equation used in the model after the small timesteps.  In
+            !  the model, grid%al (inverse density) is computed from the geopotential.
+
+            DO k  = 2,kte
+               grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) - &
+                             grid%dnw(k-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,k-1,j) &
+                           + grid%mu_2(i,j)*grid%alb(i,k-1,j) )
+               grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%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 )
+
+!  RAR - Modified to correct problem in which the parent of a child domain could
+!  not be found in the namelist. This condition typically occurs while using the
+!  "allow_grid" namelist option when an inactive domain comes before an active
+!  domain in the list, i.e., the domain number of the active domain is greater than
+!  that of an inactive domain at the same level. 
+!      
+      USE module_domain
+
+      TYPE(domain) , POINTER :: grid_ptr_in , grid_ptr_out
+      TYPE(domain) , POINTER :: grid_ptr_sibling
+      INTEGER :: id_wanted , id_i_am
+      INTEGER :: nest                    ! RAR
+      LOGICAL :: found_the_id
+
+      found_the_id = .FALSE.
+      grid_ptr_sibling => grid_ptr_in
+      nest = 0                           ! RAR
+
+      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
+! RAR    ELSE IF ( grid_ptr_sibling%num_nests .GT. 0 ) THEN
+         ELSE IF ( grid_ptr_sibling%num_nests .GT. 0 .AND. nest .LT. grid_ptr_sibling%num_nests ) THEN
+            nest = nest + 1               ! RAR
+            grid_ptr_sibling => grid_ptr_sibling%nests(nest)%ptr ! RAR
+            CALL find_my_parent ( grid_ptr_sibling , grid_ptr_out , id_i_am , id_wanted , found_the_id )
+            IF (.NOT. found_the_id) grid_ptr_sibling => grid_ptr_sibling%parents(1)%ptr   ! RAR
+         ELSE
+            grid_ptr_sibling => grid_ptr_sibling%sibling
+         END IF
+
+      END DO
+
+   END SUBROUTINE find_my_parent
+
+!---------------------------------------------------------------------
+
+   RECURSIVE SUBROUTINE find_my_parent2 ( grid_ptr_in , grid_ptr_out , id_wanted , found_the_id )
+
+      USE module_domain
+
+      TYPE(domain) , POINTER               :: grid_ptr_in
+      TYPE(domain) , POINTER               :: grid_ptr_out
+      INTEGER                , INTENT(IN ) :: id_wanted
+      LOGICAL                , INTENT(OUT) :: found_the_id
+
+      !  Local
+
+      TYPE(domain) , POINTER :: grid_ptr_holder
+      INTEGER :: kid
+
+      !  Initializations 
+
+      found_the_id = .FALSE.
+      grid_ptr_holder => grid_ptr_in
+
+
+      !  Have we found the correct location?  If so, we can just pop back up with
+      !  the pointer to the right location (i.e. the parent), thank you very much.
+
+      IF ( id_wanted .EQ. grid_ptr_in%grid_id ) THEN
+
+         found_the_id = .TRUE.
+         grid_ptr_out => grid_ptr_in
+
+
+      !  We gotta keep looking.
+
+      ELSE
+
+      !  We drill down and process each nest from this domain.  We don't have to 
+      !  worry about siblings, as we are running over all of the kids for this parent, 
+      !  so it amounts to the same set of domains being tested.  
+
+         loop_over_all_kids : DO kid = 1 , grid_ptr_in%num_nests
+
+            IF ( ASSOCIATED ( grid_ptr_in%nests(kid)%ptr ) ) THEN
+
+               CALL find_my_parent2 ( grid_ptr_in%nests(kid)%ptr , grid_ptr_out , id_wanted , found_the_id )
+               IF ( found_the_id ) THEN
+                  EXIT loop_over_all_kids
+               END IF
+
+            END IF
+         END DO loop_over_all_kids
+
+      END IF
+
+   END SUBROUTINE find_my_parent2
+
+#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.
+   logical, parameter :: use_levels_below_ground = .FALSE. ! .TRUE.
+   logical, parameter :: use_surface             = .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 , use_levels_below_ground , use_surface , &
+                         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 , use_levels_below_ground , use_surface , &
+                         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 , use_levels_below_ground , use_surface , &
+                            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 , use_levels_below_ground , use_surface
+      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 , zap_below , zap_above , kst , kcount
+      INTEGER :: kinterp_start , kinterp_end , sfc_level
+
+      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
+    
+      !  Excluded middle.
+
+      LOGICAL :: any_valid_points
+      INTEGER :: i_valid , j_valid
+      LOGICAL :: flip_data_required
+
+      !  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)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  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)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  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)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  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)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  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
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  porig(i,k,j) = po(i,k,j)
+               END DO
+            END DO
+
+            DO k = kstart,kend
+               DO i = istart,iend
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  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
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  porig(i,k,j) = po(i,k,j)
+               END DO
+            END DO
+
+            DO k = kstart,kend
+               DO i = istart,iend
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  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
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  porig(i,k,j) = po(i,k,j)
+               END DO
+            END DO
+
+            DO k = kstart,kend
+               DO i = istart,iend
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  pnew(i,k,j) = pnu(i,k,j)
+               END DO
+            END DO
+         END DO
+      END IF
+
+      !  We need to find if there are any valid non-excluded-middle points in this
+      !  tile.  If so, then we need to hang on to a valid i,j location.
+
+      any_valid_points = .false.
+      find_valid : DO j = jstart , jend
+         DO i = istart , iend
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            any_valid_points = .true.
+            i_valid = i
+            j_valid = j
+            EXIT find_valid
+         END DO 
+      END DO find_valid
+      IF ( .NOT. any_valid_points ) THEN
+         RETURN
+      END IF
+
+      IF ( porig(i_valid,2,j_valid) .LT. porig(i_valid,generic,j_valid) ) THEN
+         flip_data_required = .true.
+      ELSE
+         flip_data_required = .false.
+      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 ( flip_data_required ) THEN
+            DO kn = 2 , ( generic + 1 ) / 2
+               DO i = istart , iend
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  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
+            END DO
+            DO i = istart , iend
+               forig(i,1,j)               = fo   (i,1,j)
+            END DO
+            IF ( MOD(generic,2) .EQ. 0 ) THEN
+               k=generic/2 + 1
+               DO i = istart , iend
+                  forig(i,k,j)            = fo   (i,k,j)
+               END DO
+            END IF
+         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 , generic
+            DO i = istart , iend
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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 ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+
+            !  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.
+
+            !  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.
+
+            !  How many levels have we skipped in the input column.
+
+            zap = 0
+            zap_below = 0
+            zap_above = 0
+
+            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
+                  zap_below = 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
+                        zap_above = zap_above + 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
+                  zap_above = zap_above + 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 make 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
+                        zap_above = zap_above + 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 ) .AND. &
+                       ( ko .LT. generic ) ) THEN
+                     zap = zap + 1
+                     zap_above = zap_above + 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
+
+            !  How many levels (count) are we shipping to the Lagrange interpolator.
+
+            IF      ( ( use_levels_below_ground ) .AND. ( use_surface ) ) THEN
+
+               !  Use all levels, including the input surface, and including the pressure
+               !  levels below ground.  We know to stop when we have reached the top of
+               !  the input pressure data.
+
+               count = 0
+               find_how_many_1 : DO ko = 1 , generic
+                  IF ( porig(i,generic,j) .EQ. ordered_porig(ko) ) THEN
+                     count = count + 1
+                     EXIT find_how_many_1
+                  ELSE
+                     count = count + 1
+                  END IF
+               END DO find_how_many_1
+               kinterp_start = 1
+               kinterp_end = kinterp_start + count - 1
+
+            ELSE IF ( ( use_levels_below_ground ) .AND. ( .NOT. use_surface ) ) THEN
+
+               !  Use all levels (excluding the input surface) and including the pressure
+               !  levels below ground.  We know to stop when we have reached the top of
+               !  the input pressure data.
+
+               count = 0
+               find_sfc_2 : DO ko = 1 , generic
+                  IF ( porig(i,1,j) .EQ. ordered_porig(ko) ) THEN
+                     sfc_level = ko
+                     EXIT find_sfc_2
+                  END IF
+               END DO find_sfc_2
+
+               DO ko = sfc_level , generic-1
+                  ordered_porig(ko) = ordered_porig(ko+1)
+                  ordered_forig(ko) = ordered_forig(ko+1)
+               END DO
+               ordered_porig(generic) = 1.E-5
+               ordered_forig(generic) = 1.E10
+
+               count = 0
+               find_how_many_2 : DO ko = 1 , generic
+                  IF ( porig(i,generic,j) .EQ. ordered_porig(ko) ) THEN
+                     count = count + 1
+                     EXIT find_how_many_2
+                  ELSE
+                     count = count + 1
+                  END IF
+               END DO find_how_many_2
+               kinterp_start = 1
+               kinterp_end = kinterp_start + count - 1
+
+            ELSE IF ( ( .NOT. use_levels_below_ground ) .AND. ( use_surface ) ) THEN
+
+               !  Use all levels above the input surface pressure.
+
+               kcount = ko_above_sfc(i)-1-zap_below
+               count = 0
+               DO ko = 1 , generic
+                  IF ( porig(i,ko,j) .EQ. ordered_porig(kcount) ) THEN
+!  write (6,fmt='(f11.3,f11.3,g11.5)') porig(i,ko,j),ordered_porig(kcount),ordered_forig(kcount)
+                     kcount = kcount + 1
+                     count = count + 1
+                  ELSE
+!  write (6,fmt='(f11.3            )') porig(i,ko,j)
+                  END IF
+               END DO
+               kinterp_start = ko_above_sfc(i)-1-zap_below
+               kinterp_end = kinterp_start + count - 1
+
+            END IF
+
+            !  The polynomials are either in pressure or LOG(pressure).
+
+            IF ( interp_type .EQ. 1 ) THEN
+               CALL lagrange_setup ( var_type , interp_type , &
+                    ordered_porig(kinterp_start:kinterp_end) , &
+                    ordered_forig(kinterp_start:kinterp_end) , &
+                    count , lagrange_order , extrap_type , &
+                    ordered_pnew(kstart:kend)  , ordered_fnew  , kend-kstart+1 ,i,j)
+            ELSE
+               CALL lagrange_setup ( var_type , interp_type , &
+                LOG(ordered_porig(kinterp_start:kinterp_end)) , &
+                    ordered_forig(kinterp_start:kinterp_end) , &
+                    count , 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 , use_levels_below_ground , use_surface , &
+                            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 , use_levels_below_ground , use_surface
+      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 , interp_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) :: interp_type , 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 :: a , b
+      REAL :: target_y_1 , target_y_2
+      LOGICAL :: found_loc
+      INTEGER :: loop , loc_center_left , loc_center_right , ist , iend , target_loop
+      INTEGER :: vboundb , vboundt
+
+      !  Local vars for the problem of extrapolating theta below ground.
+
+      REAL :: temp_1 , temp_2 , temp_3 , temp_y
+      REAL :: depth_of_extrap_in_p , avg_of_extrap_p , temp_extrap_starting_point , dhdp , dh , dt
+      REAL , PARAMETER :: RovCp      = rcp
+      REAL , PARAMETER :: CRC_const1 = 11880.516      ! m
+      REAL , PARAMETER :: CRC_const2 =     0.1902632  !
+      REAL , PARAMETER :: CRC_const3 =     0.0065     ! K/km
+      REAL, DIMENSION(all_dim) :: all_x_full
+      REAL , DIMENSION(target_dim) :: target_x_full
+
+      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
+
+      !  We can pinch in the area of the higher order interpolation with vbound.  If
+      !  vbound = 0, no pinching.  If vbound = m, then we make the lower "m" and upper
+      !  "m" eta levels use a linear interpolation.
+
+      vboundb = 4
+      vboundt = 0
+
+      !  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
+            a = target_x(target_loop) - all_x(loop)
+            b = target_x(target_loop) - all_x(loop+1)
+            IF ( a*b .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
+
+            !  Get full pressure back so that our extrpolations make sense.
+
+            IF ( interp_type .EQ. 1 ) THEN
+               all_x_full    =       all_x
+               target_x_full =       target_x
+            ELSE
+               all_x_full    = EXP ( all_x )
+               target_x_full = EXP ( target_x )
+            END IF
+            !  Isothermal extrapolation.
+
+            IF      ( ( extrap_type .EQ. 1 ) .AND. ( var_type .EQ. 'T' ) ) THEN
+
+               temp_1 = all_y(1) * ( all_x_full(1) / 100000. ) ** RovCp
+               target_y(target_loop) = temp_1 * ( 100000. / target_x_full(target_loop) ) ** RovCp
+
+            !  Standard atmosphere -6.5 K/km lapse rate for the extrapolation.
+
+            ELSE IF ( ( extrap_type .EQ. 2 ) .AND. ( var_type .EQ. 'T' ) ) THEN
+
+               depth_of_extrap_in_p = target_x_full(target_loop) - all_x_full(1)
+               avg_of_extrap_p = ( target_x_full(target_loop) + all_x_full(1) ) * 0.5
+               temp_extrap_starting_point = all_y(1) * ( all_x_full(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_full(target_loop) ) ** RovCp
+
+            !  Adiabatic extrapolation for theta.
+
+            ELSE IF ( ( extrap_type .EQ. 3 ) .AND. ( var_type .EQ. 'T' ) ) THEN
+
+               target_y(target_loop) = all_y(1)
+
+
+            !  Wild extrapolation for non-temperature vars.
+
+            ELSE IF ( extrap_type .EQ. 1 ) THEN
+
+               target_y(target_loop) = ( all_y(2) * ( target_x(target_loop) - all_x(3) ) + &
+                                         all_y(3) * ( all_x(2) - target_x(target_loop) ) ) / &
+                                       ( all_x(2) - all_x(3) )
+
+            !  Use a constant value below ground.
+
+            ELSE IF ( extrap_type .EQ. 2 ) THEN
+
+               target_y(target_loop) = all_y(1)
+
+            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 ) .AND. &
+                   ( ( target_loop .GE. 1 + vboundb ) .AND. ( target_loop .LE. target_dim - vboundt ) ) ) 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
+
+         ELSE IF ( MOD(n,2) .EQ. 0 ) THEN
+               ist  = loc_center_left
+               iend = loc_center_right
+               CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , 1 , target_x(target_loop) , target_y(target_loop) )
+
+         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
+         IF ( denom .NE. 0. ) THEN
+            Ln(i) = y(i) * numer / denom
+            Px = Px + Ln(i)
+         ENDIF
+      END DO
+      target_y = Px
+
+   END SUBROUTINE lagrange_interp
+
+#ifndef VERT_UNIT
+!---------------------------------------------------------------------
+
+   SUBROUTINE p_dry ( mu0 , eta , pdht , pdry , full_levs , &
+                             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
+
+      LOGICAL :: full_levs
+
+      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
+
+      IF ( full_levs ) THEN
+         DO j = jts , MIN ( jde-1 , jte )
+            DO k = kts , kte
+               DO i = its , MIN (ide-1 , ite )
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  pdry(i,k,j) = eta(k) * mu0(i,j) + pdht
+               END DO
+            END DO
+         END DO
+
+      ELSE
+         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 )
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  pdry(i,k,j) = eta_h(k) * mu0(i,j) + pdht
+               END DO
+            END DO
+         END DO
+      END IF
+
+   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 )
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            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 = r_d
+
+      DO j = jts , MIN ( jde-1 , jte )
+         DO i = its , MIN (ide-1 , ite )
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            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 )
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            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 potential temperature from temperature and 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 = r_d
+
+      DO j = jts , MIN ( jde-1 , jte )
+         DO k = kts , kte
+            DO i = its , MIN (ide-1 , ite )
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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 theta_to_t ( t , p , p00 , &
+                      ids , ide , jds , jde , kds , kde , &
+                      ims , ime , jms , jme , kms , kme , &
+                      its , ite , jts , jte , kts , kte )
+
+   !  Compute temperature from potential temp and 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 = r_d
+      CHARACTER (LEN=80) :: mess
+
+      DO j = jts , MIN ( jde-1 , jte )
+         DO k = kts , kte-1
+            DO i = its , MIN (ide-1 , ite )
+             IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+             if ( p(i,k,j) .NE. 0. ) then
+               t(i,k,j) = t(i,k,j) / ( ( p00 / p(i,k,j) ) ** (Rd / Cp) )
+             else
+               WRITE(mess,*) 'Troubles in theta_to_t'
+               CALL wrf_debug(0,mess)
+               WRITE(mess,*) "i,j,k = ", i,j,k
+               CALL wrf_debug(0,mess)
+               WRITE(mess,*) "p(i,k,j) = ", p(i,k,j)
+               CALL wrf_debug(0,mess)
+               WRITE(mess,*) "t(i,k,j) = ", t(i,k,j)
+               CALL wrf_debug(0,mess)
+             endif
+            END DO
+         END DO
+      END DO
+
+   END SUBROUTINE theta_to_t
+
+!---------------------------------------------------------------------
+
+   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 = r_d
+
+      !  Is the data upside down?
+
+
+      find_valid : DO j = jts , MIN ( jde-1 , jte )
+         DO i = its , MIN (ide-1 , ite )
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            IF ( p_in(i,kts+1,j) .LT. p_in(i,kte,j) ) THEN
+               upside_down = .TRUE.
+            ELSE
+               upside_down = .FALSE.
+            END IF
+            EXIT find_valid
+         END DO
+      END DO find_valid
+
+      !  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 )
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            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
+
+      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 )
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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 )
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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 )
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            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 )
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+
+            !  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 )
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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 )
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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_mxrat2(rh, t, p, q , wrt_liquid , &
+                           qv_max_p_safe , &
+                           qv_max_flag , qv_max_value , &
+                           qv_min_p_safe , &
+                           qv_min_flag , qv_min_value , &
+                           ids , ide , jds , jde , kds , kde , &
+                           ims , ime , jms , jme , kms , kme , &
+                           its , ite , jts , jte , kts , kte )
+
+      !  This subroutine computes mixing ratio (q, kg/kg) from basic variables
+      !  pressure (p, Pa), temperature (t, K) and relative humidity (rh, 0-100%).
+      !  Phase transition, liquid water to ice, occurs over (0,-23) temperature range (Celcius). 
+      !  Formulation used here is based on:
+      !  WMO, General meteorological standards and recommended practices,
+      !   Appendix A, WMO Technical Regulations, WMO-No. 49, corrigendum,
+      !   August 2000.    --TKW 03/30/2011
+
+      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 , INTENT(IN)           :: qv_max_p_safe , qv_max_flag , qv_max_value
+      REAL , INTENT(IN)           :: qv_min_p_safe , qv_min_flag , qv_min_value
+
+      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
+
+      REAL,         PARAMETER     :: T0K = 273.16
+      REAL,         PARAMETER     :: Tice = T0K - 23.0
+
+      REAL,         PARAMETER     :: cfe = 1.0/(23.0*23.0)
+      REAL,         PARAMETER     :: eps = 0.622
+
+      ! Coefficients for esat over liquid water
+      REAL,         PARAMETER     :: cw1 = 10.79574
+      REAL,         PARAMETER     :: cw2 = -5.02800
+      REAL,         PARAMETER     :: cw3 = 1.50475E-4
+      REAL,         PARAMETER     :: cw4 = 0.42873E-3
+      REAL,         PARAMETER     :: cw5 = 0.78614
+
+      ! Coefficients for esat over ice 
+      REAL,         PARAMETER     :: ci1 = -9.09685
+      REAL,         PARAMETER     :: ci2 = -3.56654
+      REAL,         PARAMETER     :: ci3 = 0.87682
+      REAL,         PARAMETER     :: ci4 = 0.78614
+
+      REAL,         PARAMETER     :: Tn = 273.16
+
+      ! 1 ppm is a reasonable estimate for minimum QV even for stratospheric altitudes
+      REAL,         PARAMETER     :: QV_MIN = 1.e-6
+
+      ! Maximum allowed QV is computed under the extreme condition:
+      !            Saturated at 40 degree in Celcius and 1000 hPa
+      REAL,         PARAMETER     :: QV_MAX = 0.045 
+
+      ! Need to constrain WVP in the stratosphere where pressure 
+      ! is low but tempearure is hot (warm) 
+      ! Maximum ratio of e/p, = q/(0.622+q)
+      REAL,         PARAMETER     :: EP_MAX = QV_MAX/(eps+QV_MAX)
+
+      INTEGER                     :: i , j , k
+
+      REAL                        :: ew , q1 , t1
+      REAL                        :: ta, tb, pw3, pw4, pwr
+      REAL                        :: es, esw, esi, wvp, pmb, wvpmax
+
+      DO j = jts , MIN ( jde-1 , jte )
+         DO k = kts , kte
+            DO i = its , MIN (ide-1 , ite )
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               rh(i,k,j) = MIN ( MAX ( rh(i,k,j) ,  0. ) , 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 )
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  Ta=Tn/T(i,k,j)
+                  Tb=T(i,k,j)/Tn
+                  pw3 = -8.2969*(Tb-1.0)
+                  pw4 = 4.76955*(1.0-Ta)
+                  pwr = cw1*(1.0-Ta) + cw2*LOG10(Tb) + cw3*(1.0-10.0**pw3) + cw4*(10.0**pw4-1.0) + cw5
+                  es = 10.0**pwr             ! Saturation WVP
+                  wvp = 0.01*rh(i,k,j)*es    ! Actual WVP
+                  pmb = p(i,k,j)/100.
+                  wvpmax = EP_MAX*pmb        ! Prevents unrealistic QV in the stratosphere
+                  wvp = MIN(wvp,wvpmax)
+                  q(i,k,j) = eps*wvp/(pmb-wvp)
+               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 )
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  Ta=Tn/T(i,k,j)
+                  Tb=T(i,k,j)/Tn
+                  IF (t(i,k,j) >= T0K) THEN         ! Over liquid water
+                     pw3 = -8.2969*(Tb-1.0)
+                     pw4 = 4.76955*(1.0-Ta)
+                     pwr = cw1*(1.0-Ta) + cw2*LOG10(Tb) + cw3*(1.0-10.0**pw3) + cw4*(10.0**pw4-1.0) + cw5
+                     es = 10.0**pwr
+                     wvp = 0.01*rh(i,k,j)*es
+                  ELSE IF (t(i,k,j) <= Tice) THEN   ! Over ice
+                     pwr = ci1*(Ta-1.0) + ci2*LOG10(Ta) + ci3*(1.0-Tb) + ci4
+                     es = 10.0**pwr
+                     wvp = 0.01*rh(i,k,j)*es
+                  ELSE                              ! Mixed
+                     pw3 = -8.2969*(Tb-1.0)
+                     pw4 = 4.76955*(1.0-Ta)
+                     pwr = cw1*(1.0-Ta) + cw2*LOG10(Tb) + cw3*(1.0-10.0**pw3) + cw4*(10.0**pw4-1.0) + cw5
+                     esw = 10.0**pwr      ! Over liquid water
+
+                     pwr = ci1*(Ta-1.0) + ci2*LOG10(Ta) + ci3*(1.0-Tb) + ci4
+                     esi = 10.0**pwr      ! Over ice
+
+                     es = esi + (esw-esi)*cfe*(T(i,k,j)-Tice)*(T(i,k,j)-Tice)
+                     wvp = 0.01*rh(i,k,j)*es
+                  END IF
+                  pmb = p(i,k,j)/100.
+                  wvpmax = EP_MAX*pmb     ! Prevents unrealistic QV in the stratosphere
+                  wvp = MIN(wvp,wvpmax)
+                  q(i,k,j) = eps*wvp/(pmb-wvp)
+               END DO
+            END DO
+         END DO
+      END IF
+
+      !  For pressures above a defined level, reasonable Qv values should be
+      !  a certain value or smaller.  If they are larger than this, the input data
+      !  probably had "missing" RH, and we filled in some values.  This is an
+      !  attempt to catch those.  Also, set the minimum value for the entire
+      !  domain that is above the selected pressure level.
+     
+      DO j = jts , MIN ( jde-1 , jte )
+         DO k = kts , kte
+            DO i = its , MIN (ide-1 , ite )
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               IF ( p(i,k,j) .LT. qv_max_p_safe ) THEN
+                  IF ( q(i,k,j) .GT. qv_max_flag ) THEN
+                     q(i,k,j) = qv_max_value
+                  END IF
+               END IF
+               IF ( p(i,k,j) .LT. qv_min_p_safe ) THEN
+                  IF ( q(i,k,j) .LT. qv_min_flag ) THEN
+                     q(i,k,j) = qv_min_value
+                  END IF
+               END IF
+            END DO
+         END DO
+      END DO
+
+   END SUBROUTINE rh_to_mxrat2
+
+!---------------------------------------------------------------------
+
+   SUBROUTINE rh_to_mxrat1(rh, t, p, q , wrt_liquid , &
+                           qv_max_p_safe , &
+                           qv_max_flag , qv_max_value , &
+                           qv_min_p_safe , &
+                           qv_min_flag , qv_min_value , &
+                           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 , INTENT(IN)           :: qv_max_p_safe , qv_max_flag , qv_max_value
+      REAL , INTENT(IN)           :: qv_min_p_safe , qv_min_flag , qv_min_value
+
+      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
+
+      CHARACTER (LEN=80) :: mess
+
+      !  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-1
+            DO i = its , MIN (ide-1 , ite )
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               rh(i,k,j) = MIN ( MAX ( rh(i,k,j) ,  0. ) , 100. )
+            END DO
+         END DO
+      END DO
+
+      IF ( wrt_liquid ) THEN
+         DO j = jts , MIN ( jde-1 , jte )
+            DO k = kts , kte-1
+               DO i = its , MIN (ide-1 , ite )
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+
+! es is reduced by RH here to avoid problems in low-pressure cases
+                  if (t(i,k,j) .ne. 0.) then
+                     es=.01*rh(i,k,j)*svp1*10.*EXP(svp2*(t(i,k,j)-svpt0)/(t(i,k,j)-svp3))
+                     IF (es .ge. p(i,k,j)/100.)THEN
+                       q(i,k,j)=0.0
+                       WRITE(mess,*) 'Warning: vapor pressure exceeds total pressure, setting Qv to 0'
+                       CALL wrf_debug(0,mess)
+                     ELSE
+                       q(i,k,j)=eps*es/(p(i,k,j)/100.-es)
+                     ENDIF
+                  else
+                     q(i,k,j)=0.0
+                     WRITE(mess,*) 't(i,j,k) was 0 at ', i,j,k,', setting Qv to 0'
+                     CALL wrf_debug(0,mess)
+                  endif
+               END DO
+            END DO
+         END DO
+
+      ELSE
+         DO j = jts , MIN ( jde-1 , jte )
+            DO k = kts , kte-1
+               DO i = its , MIN (ide-1 , ite )
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+
+                  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
+
+                     !  Liquid phase t > 0 C
+
+                     IF ( t1 .GE. t_ref ) THEN
+                        ew = a0 + t1 * (a1 + t1 * (a2 + t1 * (a3 + t1 * (a4 + t1 * (a5 + t1 * a6)))))
+
+                     !  Mixed phase -47 C < t < 0 C
+
+                     ELSE IF ( ( t1 .LT. t_ref ) .AND. ( t1 .GE. -47. ) ) THEN
+                        ew = es0 * exp(17.67 * t1 / ( t1 + 243.5))
+
+                     !  Ice phase t < -47 C
+
+                     ELSE IF ( t1 .LT. -47. ) THEN
+                        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
+
+      !  For pressures above a defined level, reasonable Qv values should be
+      !  a certain value or smaller.  If they are larger than this, the input data
+      !  probably had "missing" RH, and we filled in some values.  This is an
+      !  attempt to catch those.  Also, set the minimum value for the entire
+      !  domain that is above the selected pressure level.
+     
+      DO j = jts , MIN ( jde-1 , jte )
+         DO k = kts , kte-1
+            DO i = its , MIN (ide-1 , ite )
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               IF ( p(i,k,j) .LT. qv_max_p_safe ) THEN
+                  IF ( q(i,k,j) .GT. qv_max_flag ) THEN
+                     q(i,k,j) = qv_max_value
+                  END IF
+               END IF
+               IF ( p(i,k,j) .LT. qv_min_p_safe ) THEN
+                  IF ( q(i,k,j) .LT. qv_min_flag ) THEN
+                     q(i,k,j) = qv_min_value
+                  END IF
+               END IF
+            END DO
+         END DO
+      END DO
+
+   END SUBROUTINE rh_to_mxrat1
+
+!---------------------------------------------------------------------
+
+   SUBROUTINE compute_eta ( znw , &
+                           eta_levels , max_eta , max_dz , &
+                           p_top , g , p00 , cvpm , a , r_d , cp , t00 , p1000mb , t0 , tiso , &
+                           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 , tiso
+      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
+
+         !  Check to see if the array is oriented OK, we can easily fix an upside down oops.
+
+         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 IF ( ( ABS(eta_levels(kde)-1.) .LT. 0.0000001 ) .AND. &
+                   ( ABS(eta_levels(1  )-0.) .LT. 0.0000001 ) ) THEN
+            DO k = kds+1 , kde-1
+	       znw(k) = eta_levels(kde+1-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
+
+         !  Check to see if the input full-level eta array is monotonic.
+
+         DO k = kds , kde-1
+            IF ( znw(k) .LE. znw(k+1) ) THEN
+               PRINT *,'eta on full levels is not monotonic'
+               PRINT *,'eta (',k,') = ',znw(k)
+               PRINT *,'eta (',k+1,') = ',znw(k+1)
+               CALL wrf_error_fatal ( 'Fix non-monotonic "eta_levels" in the namelist.input file' )
+            END IF
+         END DO
+
+      !  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 ( tiso, 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-2
+            pb = znw(k) * (p_surf - p_top) + p_top
+            temp = MAX ( tiso, 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-2) = 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-2
+                  pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top
+                  temp = MAX ( tiso, 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 about 0.0 = ',znw(kte-2)
+               END IF
+               znw(kte-2) = 0.000
+            END DO
+
+            !  Here is where we check the eta levels values we just computed.
+
+            DO k = 1, kde-1-2
+               pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top
+               temp = MAX ( tiso, 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-2
+                  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-2)/g
+            ztop_pbl = phb(8)/g
+            dz = ( ztop - ztop_pbl ) / REAL ( (kde-2) - 8 )
+         END DO
+
+         IF ( dz .GT. max_dz ) THEN
+print *,'z (m)            = ',phb(1)/g
+do k = 2 ,kte-2
+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
+
+         !  Add those 2 levels back into the middle, just above the 8 levels
+         !  that semi define a boundary layer.  After we open up the levels,
+         !  then we just linearly interpolate in znw.  So now levels 1-8 are
+         !  specified as the fixed boundary layer levels given in this routine.
+         !  The top levels, 12 through kte are those computed.  The middle
+         !  levels 9, 10, and 11 are equi-spaced in znw, and are each 1/2 the
+         !  the znw thickness of levels 11 through 12.
+
+         DO k = kte-2 , 9 , -1
+            znw(k+2) = znw(k)
+         END DO
+
+         znw( 9) = 0.75 * znw( 8) + 0.25 * znw(12)
+         znw(10) = 0.50 * znw( 8) + 0.50 * znw(12)
+         znw(11) = 0.25 * znw( 8) + 0.75 * znw(12)
+
+      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 )
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  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    :: gamma     = 6.5E-3
+      REAL, PARAMETER    :: pconst    = 10000.0
+      REAL, PARAMETER    :: Rd        = r_d
+      REAL, PARAMETER    :: TC        = svpt0 + 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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  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)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  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 ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  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)
+                  IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+                  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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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 ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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 ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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)
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+            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 ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+!           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    :: Rd        = r_d
+
+      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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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)
+               IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+               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 sfcprs3( height , p , ter , slp , psfc , &
+                       ids , ide , jds , jde , kds , kde , &
+                       ims , ime , jms , jme , kms , kme , &
+                       its , ite , jts , jte , kts , kte )
+
+      !  Computes the surface pressure by vertically interpolating
+      !  linearly (or log) in z the pressure, to the targeted topography.
+
+      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 ):: height, p
+      REAL , DIMENSION (ims:ime,        jms:jme) , INTENT(IN ):: ter , slp
+      REAL , DIMENSION (ims:ime,        jms:jme) , INTENT(OUT):: psfc
+
+      INTEGER                     :: i
+      INTEGER                     :: j
+      INTEGER                     :: k
+
+      LOGICAL                     :: found_loc
+
+      REAL :: zl , zu , pl , pu , zm
+
+      !  Loop over each grid point
+
+      DO j = jts , MIN(jde-1,jte)
+         DO i = its , MIN(ide-1,ite)
+            IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 
+
+            !  Special case where near the ocean level.  Assume that the SLP is a good value.
+
+            IF      ( ter(i,j) .LT. 50 ) THEN
+               psfc(i,j) = slp(i,j) + ( p(i,2,j)-p(i,3,j) ) / ( height(i,2,j)-height(i,3,j) ) * ter(i,j)
+               CYCLE
+            END IF
+
+            !  Find the trapping levels
+
+            found_loc = .FALSE.
+
+            !  Normal sort of scenario - the model topography is somewhere between
+            !  the height values of 1000 mb and the top of the model.
+
+            found_k_loc : DO k = kts+1 , kte-2
+               IF ( ( height(i,k  ,j) .LE. ter(i,j) ) .AND. &
+                    ( height(i,k+1,j) .GT. ter(i,j) ) ) THEN
+                  zl = height(i,k  ,j)
+                  zu = height(i,k+1,j)
+                  zm = ter(i,j)
+                  pl = p(i,k  ,j)
+                  pu = p(i,k+1,j)
+                  psfc(i,j) = EXP ( ( LOG(pl) * ( zm - zu ) + LOG(pu) * ( zl - zm ) ) / ( zl - zu ) )
+                  found_loc = .TRUE.
+                  EXIT found_k_loc
+               END IF
+            END DO found_k_loc
+
+            !  Interpolate betwixt slp and the first isobaric level above - this is probably the
+            !  usual thing over the ocean.
+
+            IF ( .NOT. found_loc ) THEN
+               IF ( slp(i,j) .GE. p(i,2,j) ) THEN
+                  zl = 0.
+                  zu = height(i,3,j)
+                  zm = ter(i,j)
+                  pl = slp(i,j)
+                  pu = p(i,3,j)
+                  psfc(i,j) = EXP ( ( LOG(pl) * ( zm - zu ) + LOG(pu) * ( zl - zm ) ) / ( zl - zu ) )
+                  found_loc = .TRUE.
+               ELSE
+                  found_slp_loc : DO k = kts+1 , kte-3
+                     IF ( ( slp(i,j) .GE. p(i,k+1,j) ) .AND. &
+                          ( slp(i,j) .LT. p(i,k  ,j) ) ) THEN
+                        zl = 0.
+                        zu = height(i,k+1,j)
+                        zm = ter(i,j)
+                        pl = slp(i,j)
+                        pu = p(i,k+1,j)
+                        psfc(i,j) = EXP ( ( LOG(pl) * ( zm - zu ) + LOG(pu) * ( zl - zm ) ) / ( zl - zu ) )
+                        found_loc = .TRUE.
+                        EXIT found_slp_loc
+                     END IF
+                  END DO found_slp_loc
+               END IF
+            END IF
+
+            !  Did we do what we wanted done.
+
+            IF ( .NOT. found_loc ) THEN
+               print *,'i,j = ',i,j
+               print *,'p column = ',p(i,2:,j)
+               print *,'z column = ',height(i,2:,j)
+               print *,'model topo = ',ter(i,j)
+               CALL wrf_error_fatal ( ' probs with sfc p computation ' )
+            END IF
+
+         END DO
+      END DO
+
+   END SUBROUTINE sfcprs3
+!---------------------------------------------------------------------
+
+   SUBROUTINE filter_topo ( ht_in , xlat , msftx , fft_filter_lat , &
+                            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) :: fft_filter_lat
+      REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: ht_in
+      REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: xlat , msftx
+
+
+      !  Local vars
+
+      INTEGER :: i , j , j_lat_pos , j_lat_neg
+      INTEGER :: i_kicker , ik , i1, i2, i3, i4
+      REAL :: length_scale , sum
+      REAL , DIMENSION(its:ite,jts:jte) :: ht_out
+
+      !  The filtering is a simple average on a latitude loop.  Possibly a LONG list of
+      !  numbers.  We assume that ALL of the 2d arrays have been transposed so that
+      !  each patch has the entire domain size of the i-dim local.
+
+      IF ( ( its .NE. ids ) .OR. ( ite .NE. ide ) ) THEN
+         CALL wrf_error_fatal ( 'filtering assumes all values on X' )
+      END IF
+
+      !  Starting at the south pole, we find where the
+      !  grid distance is big enough, then go back a point.  Continuing to the
+      !  north pole, we find the first small grid distance.  These are the
+      !  computational latitude loops and the associated computational poles.
+
+      j_lat_neg = 0
+      j_lat_pos = jde + 1
+      loop_neg : DO j = jts , MIN(jde-1,jte)
+         IF ( xlat(its,j) .LT. 0.0 ) THEN
+            IF ( ABS(xlat(its,j)) .LT. fft_filter_lat ) THEN
+               j_lat_neg = j - 1
+               EXIT loop_neg
+            END IF
+         END IF
+      END DO loop_neg
+
+      loop_pos : DO j = jts , MIN(jde-1,jte)
+         IF ( xlat(its,j) .GT. 0.0 ) THEN
+            IF ( xlat(its,j) .GE. fft_filter_lat ) THEN
+               j_lat_pos = j
+               EXIT loop_pos
+            END IF
+         END IF
+      END DO loop_pos
+
+      !  Set output values to initial input topo values for whole patch.
+
+      DO j = jts , MIN(jde-1,jte)
+         DO i = its , MIN(ide-1,ite)
+            ht_out(i,j) = ht_in(i,j)
+         END DO
+      END DO
+
+      !  Filter the topo at the negative lats.
+
+      DO j = j_lat_neg , jts , -1
+         i_kicker = MIN( MAX ( NINT(msftx(its,j)) , 1 ) , (ide - ids) / 2 )
+         print *,'j = ' , j, ', kicker = ',i_kicker
+         DO i = its , MIN(ide-1,ite)
+            IF      ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN
+               sum = 0.0
+               DO ik = 1 , i_kicker
+                  sum = sum + ht_in(i+ik,j) + ht_in(i-ik,j)
+               END DO
+               ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
+            ELSE IF ( ( i - i_kicker .LT. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN
+               sum = 0.0
+               DO ik = 1 , i_kicker
+                  sum = sum + ht_in(i+ik,j)
+               END DO
+               i1 = i - i_kicker + ide -1
+               i2 = ide-1
+               i3 = ids
+               i4 = i-1
+               DO ik = i1 , i2
+                  sum = sum + ht_in(ik,j)
+               END DO
+               DO ik = i3 , i4
+                  sum = sum + ht_in(ik,j)
+               END DO
+               ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
+            ELSE IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .GT. ide-1 ) ) THEN
+               sum = 0.0
+               DO ik = 1 , i_kicker
+                  sum = sum + ht_in(i-ik,j)
+               END DO
+               i1 = i+1
+               i2 = ide-1
+               i3 = ids
+               i4 = ids + ( i_kicker+i ) - ide
+               DO ik = i1 , i2
+                  sum = sum + ht_in(ik,j)
+               END DO
+               DO ik = i3 , i4
+                  sum = sum + ht_in(ik,j)
+               END DO
+               ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
+            END IF
+         END DO
+      END DO
+
+      !  Filter the topo at the positive lats.
+
+      DO j = j_lat_pos , MIN(jde-1,jte)
+         i_kicker = MIN( MAX ( NINT(msftx(its,j)) , 1 ) , (ide - ids) / 2 )
+         print *,'j = ' , j, ', kicker = ',i_kicker
+         DO i = its , MIN(ide-1,ite)
+            IF      ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN
+               sum = 0.0
+               DO ik = 1 , i_kicker
+                  sum = sum + ht_in(i+ik,j) + ht_in(i-ik,j)
+               END DO
+               ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
+            ELSE IF ( ( i - i_kicker .LT. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN
+               sum = 0.0
+               DO ik = 1 , i_kicker
+                  sum = sum + ht_in(i+ik,j)
+               END DO
+               i1 = i - i_kicker + ide -1
+               i2 = ide-1
+               i3 = ids
+               i4 = i-1
+               DO ik = i1 , i2
+                  sum = sum + ht_in(ik,j)
+               END DO
+               DO ik = i3 , i4
+                  sum = sum + ht_in(ik,j)
+               END DO
+               ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
+            ELSE IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .GT. ide-1 ) ) THEN
+               sum = 0.0
+               DO ik = 1 , i_kicker
+                  sum = sum + ht_in(i-ik,j)
+               END DO
+               i1 = i+1
+               i2 = ide-1
+               i3 = ids
+               i4 = ids + ( i_kicker+i ) - ide
+               DO ik = i1 , i2
+                  sum = sum + ht_in(ik,j)
+               END DO
+               DO ik = i3 , i4
+                  sum = sum + ht_in(ik,j)
+               END DO
+               ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
+            END IF
+         END DO
+      END DO
+
+      !  Set output values to initial input topo values for whole patch.
+
+      DO j = jts , MIN(jde-1,jte)
+         DO i = its , MIN(ide-1,ite)
+            ht_in(i,j) = ht_out(i,j)
+         END DO
+      END DO
+
+   END SUBROUTINE filter_topo
+
+!---------------------------------------------------------------------
+
+   SUBROUTINE init_module_initialize
+   END SUBROUTINE init_module_initialize
+
+!---------------------------------------------------------------------
+
+END MODULE module_initialize_real
+#endif
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_scm_xy.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_scm_xy.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_scm_xy.F	(revision 17)
@@ -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_ideal
+
+   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
+   USE module_soil_pre
+#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 :: idum1, idum2
+
+   CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+     CALL init_domain_rk( grid &
+!
+#include <actual_new_args.inc>
+!
+                        )
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain_rk ( grid &
+!
+# include <dummy_new_args.inc>
+!
+)
+
+   USE module_optional_input
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include <dummy_new_decl.inc>
+
+   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
+
+! JPH should add a read to a config file with:
+! ----- check to make sure everything is initialized from the LU index, etc.
+! ----- need to make a dummy category?
+! cen_lat, cen_lon
+! land-use category
+! soil category
+
+   ! 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 :: ii, im1, jj, jm1, loop, error, fid, lm
+   REAL    :: u_mean,v_mean, f0, p_surf, p_level, qvf, z_at_v, z_at_u
+   REAL    :: xrad, yrad, zrad, rad, cof1, cof2
+   REAL    :: pi, rnd
+
+!  stuff from original initialization that has been dropped from the Registry 
+   REAL    :: vnu, xnu, xnus, dinit0, cbh, p0_temp, t0_temp, zd
+   REAL    :: qvf1, qvf2, pd_surf
+   INTEGER :: it
+   real :: thtmp, ptmp, temp(3)
+   real :: zsfc
+
+   LOGICAL :: moisture_init
+   LOGICAL :: dry_sounding
+   character (len=256) :: mminlu2
+
+! soil input
+   INTEGER :: ns_input
+   REAL    :: tmn_input, tsk_input
+   REAL    :: zs_input(100),tslb_input(100),smois_input(100)
+   LOGICAL :: real_soil = .true.
+
+   REAL    :: zrwa(200), zwa(200)
+
+   
+#ifdef DM_PARALLEL
+#    include <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
+
+
+   pi = 2.*asin(1.0)
+   write(6,*) ' pi is ',pi
+
+   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
+
+    mminlu2 = ' '
+    mminlu2(1:4) = 'USGS'
+    CALL nl_set_mminlu(1, mminlu2)
+!   CALL nl_set_mminlu(1, 'USGS')
+    CALL nl_set_iswater(1,16)
+    CALL nl_set_isice(1,3)
+    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_pole_lon (1,0.)
+    CALL nl_set_pole_lat (1,90.)
+    CALL nl_set_map_proj(1,0)
+!   CALL model_to_grid_config_rec(1,model_config_rec,config_flags)
+    CALL nl_get_iswater(1,grid%iswater)
+
+!  here we initialize data that 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%msftx(i,j)    = 1.
+         grid%msfty(i,j)    = 1.
+         grid%msfux(i,j)    = 1.
+         grid%msfuy(i,j)    = 1.
+         grid%msfvx(i,j)    = 1.
+         grid%msfvx_inv(i,j)    = 1.
+         grid%msfvy(i,j)    = 1.
+         grid%sina(i,j)     = 0.
+         grid%cosa(i,j)     = 1.
+         grid%e(i,j)        = 2.0*EOMEG*cos(config_flags%scm_lat*DEGRAD)
+         grid%f(i,j)        = 2.0*EOMEG*sin(config_flags%scm_lat*DEGRAD)
+         grid%xlat(i,j)     = config_flags%scm_lat
+         grid%xlong(i,j)    = config_flags%scm_lon
+         grid%xland(i,j)     = 1.
+         grid%landmask(i,j)  = 1.
+         grid%lu_index(i,j)  = config_flags%scm_lu_index
+      END DO
+   END DO
+
+! for LSM, additional variables need to be initialized
+
+!  other_masked_fields : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
+
+!     CASE (SLABSCHEME)
+
+!     CASE (LSMSCHEME)
+
+! JPH free of snow and ice, and only valid over land
+        DO j = jts , MIN(jde-1,jte)
+           DO i = its , MIN(ide-1,ite)
+              grid%vegfra(i,j) = config_flags%scm_vegfra
+              grid%canwat(i,j) = config_flags%scm_canwat
+              grid%isltyp(i,j)  = config_flags%scm_isltyp
+              grid%ivgtyp(i,j)  = config_flags%scm_lu_index
+              grid%xice(i,j) = 0.
+              grid%snow(i,j) = 0.
+           END DO
+        END DO
+
+!     CASE (RUCLSMSCHEME)
+
+!  END SELECT other_masked_fields
+
+   grid%step_number = 0
+
+   IF ( real_soil ) THEN ! from input file
+
+      IF (config_flags%sf_surface_physics .NE. 2) WRITE (6, *)   &
+         'If using LSM option other than Noah, must edit input_soil file in test/em_scm_xy/ directory'
+    
+      CALL read_soil(100,ns_input,tmn_input,tsk_input,zs_input,tslb_input,smois_input)
+
+      CALL init_module_optional_input(grid,config_flags)
+      num_st_levels_input = ns_input
+      num_sm_levels_input = ns_input
+      num_sw_levels_input = ns_input
+      DO k = 1,ns_input
+         st_levels_input(k) = zs_input(k)*100.0 ! to cm
+         sm_levels_input(k) = zs_input(k)*100.0 ! to cm
+         sw_levels_input(k) = zs_input(k)*100.0 ! to cm
+         st_input(:,k+1,:) = tslb_input(k)
+         sm_input(:,k+1,:) = smois_input(k)
+         sw_input(:,k+1,:) = smois_input(k)
+      ENDDO
+  
+      grid%tsk = tsk_input
+      grid%sst = tsk_input
+      grid%tmn = tmn_input
+
+      flag_soil_layers  = 0 ! go ahead and put skin temp in
+      flag_soil_levels  = 0 ! go ahead and put skin moisture in
+      flag_sst          = 0 ! don't modify for ocean
+      flag_tavgsfc      = 0 
+      flag_soilhgt      = 0 
+
+      CALL process_soil_real ( grid%tsk , grid%tmn , grid%tavgsfc, &
+                   grid%landmask , grid%sst , grid%ht, grid%toposoil, &
+                   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_tavgsfc, flag_soilhgt, flag_soil_layers, flag_soil_levels,  &
+                   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 )
+
+   ELSE ! ideal soil
+! Process the soil; note that there are some things hard-wired into share/module_soil_pre.F
+      CALL process_soil_ideal(grid%xland,grid%xice,grid%vegfra,grid%snow,grid%canwat, &
+                     grid%ivgtyp,grid%isltyp,grid%tslb,grid%smois, &
+                     grid%tsk,grid%tmn,grid%zs,grid%dzs,model_config_rec%num_soil_layers, &
+                     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 )
+
+    ENDIF
+
+    DO j = jts, jte
+     DO k = kts, kte
+       DO i = its, ite
+          grid%ww(i,k,j)     = 0.
+       END DO
+     END DO
+    END DO
+
+! this is adopted from Wayne Angevine's GABLS case
+    grid%znw(1) = 1.0
+    zrwa(kde) = exp((kde-1)/40.)
+    zwa(kde) = grid%ztop
+    DO k=2, kde-1
+       zrwa(k) = exp((k-1)/40.)
+       zwa(k) = (zrwa(k)-1.) * grid%ztop/(zrwa(kde)-1.)
+       grid%znw(k) = 1. - (zwa(k) / zwa(kde))
+    ENDDO
+    grid%znw(kde) = 0.
+
+   DO k=1, kde-1
+    grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
+    grid%rdnw(k) = 1./grid%dnw(k)
+    grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
+   ENDDO
+   DO k=2, kde-1
+    grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
+    grid%rdn(k) = 1./grid%dn(k)
+    grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
+    grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
+   ENDDO
+
+   cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) 
+   cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) 
+   grid%cf1  = grid%fnp(2) + cof1
+   grid%cf2  = grid%fnm(2) - cof1 - cof2
+   grid%cf3  = cof2       
+
+   grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
+   grid%cfn1 = -.5*grid%dnw(kde-1)/grid%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( zsfc, 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%ht(i,j) = zsfc
+    grid%phb(i,1,j) = grid%ht(i,j) * g
+    grid%ph0(i,1,j) = grid%ht(i,j) * g
+    grid%php(i,1,j) = 0.
+  ENDDO
+  ENDDO
+
+  DO J = jts, jte
+  DO I = its, ite
+
+    p_surf = interp_0( p_in, zk, grid%phb(i,1,j)/g, nl_in )
+    grid%mub(i,j) = p_surf-grid%p_top
+
+!  this is dry hydrostatic sounding (base state), so given grid%p (coordinate),
+!  interp theta (from interp) and compute 1/rho from eqn. of state
+
+    DO K = 1, kte-1
+      p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%pb(i,k,j) = p_level
+      grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0
+      grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%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%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j)
+    ENDDO
+
+  ENDDO
+  ENDDO
+
+  write(6,*) ' ptop is ',grid%p_top
+  write(6,*) ' base state grid%mub(1,1), p_surf is ',grid%mub(1,1),grid%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( zsfc, 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%phb(i,1,j)/g, nl_in )
+
+!  compute the perturbation mass and the full mass
+
+    grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j)
+    grid%mu_2(i,j) = grid%mu_1(i,j)
+    grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j)
+
+! given the dry pressure and coordinate system, interp the potential
+! temperature and qv
+
+    do k=1,kde-1
+
+      p_level = grid%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%t_1(i,k,j)          = interp_0( theta, pd_in, p_level, nl_in ) - t0
+      grid%t_2(i,k,j)          = grid%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%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%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k)
+    grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+    qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+    grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+    grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+      qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+      grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                  (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+      grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+    enddo
+
+!  this is the hydrostatic equation used in the model after the
+!  small timesteps.  In the model, grid%al (inverse density)
+!  is computed from the geopotential.
+
+
+    grid%ph_1(i,1,j) = 0.
+    DO k  = 2,kte
+      grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                   (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                    grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+      grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+      grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+    ENDDO
+
+    if((i==2) .and. (j==2)) then
+     write(6,*) ' grid%ph_1 calc ',grid%ph_1(2,1,2),grid%ph_1(2,2,2),&
+                              grid%mu_1(2,2)+grid%mub(2,2),grid%mu_1(2,2), &
+                              grid%alb(2,1,2),grid%al(1,2,1),grid%rdnw(1)
+    endif
+
+  ENDDO
+  ENDDO
+
+   write(6,*) ' grid%mu_1 from comp ', grid%mu_1(1,1)
+   write(6,*) ' full state sounding from comp, ph, grid%p, grid%al, grid%t_1, qv '
+
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1)+grid%phb(1,k,1), &
+                                      grid%p(1,k,1)+grid%pb(1,k,1), grid%alt(1,k,1), &
+                                      grid%t_1(1,k,1)+t0, moist(1,k,1,P_QV)
+   enddo
+
+   write(6,*) ' pert state sounding from comp, grid%ph_1, pp, alp, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1), &
+                                      grid%p(1,k,1), grid%al(1,k,1), &
+                                      grid%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%phb(i,1,j)/g
+    ELSE IF (j == jde) THEN
+      z_at_v = grid%phb(i,1,j-1)/g
+    ELSE
+      z_at_v = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in )
+      grid%v_2(i,k,j) = grid%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%phb(i,1,j)/g
+    ELSE IF (i == ide) THEN
+      z_at_u = grid%phb(i-1,1,j)/g
+    ELSE
+      z_at_u = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in )
+      grid%u_2(i,k,j) = grid%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%w_1(i,k,j) = 0.
+    grid%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
+
+! Go ahead and initialize these from the sounding.  This will allow a run
+! to actually succeed even if scm_force = 0
+  DO k=1,kte-1
+    grid%t_base(k) = grid%t_1(1,k,1)
+    grid%qv_base(k) = moist(1,k,1,P_QV)
+    grid%u_base(k) = grid%u_1(1,k,1)
+    grid%v_base(k) = grid%v_1(1,k,1)
+    grid%z_base(k) = 0.5*(grid%phb(1,k,1)+grid%phb(1,k+1,1)+grid%ph_1(1,k,1)+grid%ph_1(1,k+1,1))/g
+  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( zsfc, zk, p, p_dry, theta, rho, &
+                               u, v, qv, dry, nl_max, nl_in )
+      implicit none
+
+      integer nl_max, nl_in
+      real zsfc
+      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=3000)
+      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 r
+      parameter (r = r_d)
+      integer k, it, nl
+      real qvf, qvf1, dz
+
+!  first, read the sounding
+
+      call read_sounding( zsfc, 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)-zsfc
+
+! error check here
+          if ( dz < 0.0 ) then
+            write(6,*) "Your first input sounding level is below the WRF terrain elevation, aborting"
+            stop "module_initialize_scm_xy:get_sounding"
+          endif
+          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( zsfc,ps,ts,qvs,h,th,qv,u,v,n,nl,debug )
+      implicit none
+      integer n,nl
+      real zsfc,ps,ts,qvs,h(n),th(n),qv(n),u(n),v(n)
+      real u10,v10,t2,q2
+      logical end_of_file
+      logical debug
+
+      integer k
+
+      open(unit=10,file='input_sounding',form='formatted',status='old')
+      rewind(10)
+
+      read(10,*) zsfc, u10, v10, t2, q2, ps
+      ps = ps/100.0
+      ts = t2
+      qvs = q2*1000
+
+      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), u(k+1), v(k+1), th(k+1), qv(k+1)
+
+        qv(k+1) = qv(k+1)*1000.0
+        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
+
+!-------------------------------------------------------
+
+      subroutine read_soil( n,nl,tmn,tsk,zs,tslb,smois )
+      implicit none
+      integer n,nl
+      real tmn,tsk
+      real zs(n),tslb(n),smois(n)
+      logical end_of_file
+      logical debug 
+
+      integer k
+    
+      debug = .true.
+
+      open(unit=11,file='input_soil',form='formatted',status='old')
+      rewind(11)
+
+      read(11,*) zs(1),tmn,tsk
+
+      if(debug) then
+        write(6,*) ' input deep soil temperature (K) ',tmn
+        write(6,*) ' input skin temperature (K) ',tsk
+      end if
+
+      end_of_file = .false.
+      k = 0
+
+      do while (.not. end_of_file)
+
+        read(11,*,end=100) zs(k+1), tslb(k+1), smois(k+1)
+        k = k+1
+        if(debug) write(6,'(1x,i3,3(1x,f16.7))') k, zs(k), tslb(k), smois(k)
+        go to 110
+ 100    end_of_file = .true.
+ 110    continue
+      enddo
+
+      nl = k
+
+      close(unit=11,status = 'keep')
+
+      end subroutine read_soil
+
+END MODULE module_initialize_ideal
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_seabreeze2d_x.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_seabreeze2d_x.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_seabreeze2d_x.F	(revision 17)
@@ -0,0 +1,832 @@
+!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_ideal
+
+   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
+   USE module_soil_pre
+#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 :: idum1, idum2
+
+   CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+     CALL init_domain_rk( grid &
+!
+#include <actual_new_args.inc>
+!
+                        )
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain_rk ( grid &
+!
+# include <dummy_new_args.inc>
+!
+)
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include <dummy_new_decl.inc>
+
+   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
+
+   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, lm
+   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    :: pi, rnd
+
+!  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
+   character (len=256) :: mminlu2
+   
+#ifdef DM_PARALLEL
+#    include <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
+
+
+   stretch_grid = .true.
+   delt = 6.
+!   z_scale = .50
+   z_scale = .40
+   pi = 2.*asin(1.0)
+   write(6,*) ' pi is ',pi
+   nxc = (ide-ids)/2
+   nyc = jde/2
+   icm = ide/2
+! lm is the half width of the land in terms of grid points
+   lm = 25
+   write(6,*) 'lm,icm-lm,icm+lm = ', lm,icm-lm,icm+lm
+
+   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
+
+    mminlu2 = ' '
+    mminlu2(1:4) = 'USGS'
+    CALL nl_set_mminlu(1, mminlu2)
+!   CALL nl_set_mminlu(1, 'USGS')
+    CALL nl_set_iswater(1,16)
+    CALL nl_set_isice(1,3)
+    CALL nl_set_cen_lat(1,20.)
+    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_pole_lon (1,0.)
+    CALL nl_set_pole_lat (1,90.)
+    CALL nl_set_map_proj(1,0)
+!   CALL model_to_grid_config_rec(1,model_config_rec,config_flags)
+    CALL nl_get_iswater(1,grid%iswater)
+
+!  here we initialize data that 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%msftx(i,j)    = 1.
+         grid%msfty(i,j)    = 1.
+         grid%msfux(i,j)    = 1.
+         grid%msfuy(i,j)    = 1.
+         grid%msfvx(i,j)    = 1.
+         grid%msfvy(i,j)    = 1.
+         grid%msfvx_inv(i,j)= 1.
+         grid%sina(i,j)     = 0.
+         grid%cosa(i,j)     = 1.
+         grid%e(i,j)        = 0.
+         grid%f(i,j)        = 0.
+         grid%xlat(i,j)     = 30.
+         grid%xlong(i,j)     = 0.
+! Hard-wire the ocean-land configuration
+        if (i .ge. (icm-lm) .and. i .lt. (icm+lm)) then
+         grid%xland(i,j)     = 1.
+         grid%lu_index(i,j)  = 18
+         grid%tsk(i,j) = 280.0
+	 grid%tmn(i,j) = 280.0
+	else
+	 grid%xland(i,j)     = 2.
+         grid%lu_index(i,j)  = 16
+         grid%tsk(i,j) = 287.0
+         grid%tmn(i,j) = 280.0
+	end if
+      END DO
+   END DO
+
+! for Noah LSM, additional variables need to be initialized
+
+   other_masked_fields : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
+
+      CASE (SLABSCHEME)
+
+      CASE (LSMSCHEME)
+
+        DO j = jts , MIN(jde-1,jte)
+           DO i = its , MIN(ide-1,ite)
+              IF (grid%xland(i,j) .lt. 1.5) THEN
+                 grid%vegfra(i,j) = 0.5
+                 grid%canwat(i,j) = 0.
+                 grid%ivgtyp(i,j) = 18
+                 grid%isltyp(i,j) = 8
+                 grid%xice(i,j) = 0.
+                 grid%snow(i,j) = 0.
+              ELSE
+                 grid%vegfra(i,j) = 0.
+                 grid%canwat(i,j) = 0.
+                 grid%ivgtyp(i,j) = 16
+                 grid%isltyp(i,j) = 14
+                 grid%xice(i,j) = 0.
+                 grid%snow(i,j) = 0.
+              ENDIF
+           END DO
+        END DO
+
+      CASE (RUCLSMSCHEME)
+
+   END SELECT other_masked_fields
+
+   DO j = jts, jte
+    DO k = kts, kte
+      DO i = its, ite
+         grid%ww(i,k,j)     = 0.
+      END DO
+    END DO
+   END DO
+
+   grid%step_number = 0
+
+! Process the soil; note that there are some things hard-wired into share/module_soil_pre.F
+      CALL process_soil_ideal(grid%xland,grid%xice,grid%vegfra,grid%snow,grid%canwat, &
+                     grid%ivgtyp,grid%isltyp,grid%tslb,grid%smois, &
+                     grid%tsk,grid%tmn,grid%zs,grid%dzs,model_config_rec%num_soil_layers, &
+                     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 )
+
+! set up the grid
+
+   IF (stretch_grid) THEN ! exponential stretch for eta (nearly constant dz)
+     DO k=1, kde
+      grid%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%znw(k) = 1. - float(k-1)/float(kde-1)
+     ENDDO
+   ENDIF
+
+   DO k=1, kde-1
+    grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
+    grid%rdnw(k) = 1./grid%dnw(k)
+    grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
+   ENDDO
+   DO k=2, kde-1
+    grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
+    grid%rdn(k) = 1./grid%dn(k)
+    grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
+    grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
+   ENDDO
+
+   cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) 
+   cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) 
+   grid%cf1  = grid%fnp(2) + cof1
+   grid%cf2  = grid%fnm(2) - cof1 - cof2
+   grid%cf3  = cof2       
+
+   grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
+   grid%cfn1 = -.5*grid%dnw(kde-1)/grid%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%phb(i,1,j) = 0.
+    grid%php(i,1,j) = 0.
+    grid%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%phb(i,1,j)/g, nl_in )
+    grid%mub(i,j) = p_surf-grid%p_top
+
+!  this is dry hydrostatic sounding (base state), so given grid%p (coordinate),
+!  interp theta (from interp) and compute 1/rho from eqn. of state
+
+    DO K = 1, kte-1
+      p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%pb(i,k,j) = p_level
+      grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0
+      grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%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%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j)
+    ENDDO
+
+  ENDDO
+  ENDDO
+
+  write(6,*) ' ptop is ',grid%p_top
+  write(6,*) ' base state grid%mub(1,1), p_surf is ',grid%mub(1,1),grid%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%phb(i,1,j)/g, nl_in )
+
+!  compute the perturbation mass and the full mass
+
+    grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j)
+    grid%mu_2(i,j) = grid%mu_1(i,j)
+    grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j)
+
+! given the dry pressure and coordinate system, interp the potential
+! temperature and qv
+
+    do k=1,kde-1
+
+      p_level = grid%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%t_1(i,k,j)          = interp_0( theta, pd_in, p_level, nl_in ) - t0
+      grid%t_2(i,k,j)          = grid%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%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%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k)
+    grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+    qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+    grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+    grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+      qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+      grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                  (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+      grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+    enddo
+
+!  this is the hydrostatic equation used in the model after the
+!  small timesteps.  In the model, grid%al (inverse density)
+!  is computed from the geopotential.
+
+
+    grid%ph_1(i,1,j) = 0.
+    DO k  = 2,kte
+      grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                   (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                    grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+      grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+      grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+    ENDDO
+
+    if((i==2) .and. (j==2)) then
+     write(6,*) ' grid%ph_1 calc ',grid%ph_1(2,1,2),grid%ph_1(2,2,2),&
+                              grid%mu_1(2,2)+grid%mub(2,2),grid%mu_1(2,2), &
+                              grid%alb(2,1,2),grid%al(1,2,1),grid%rdnw(1)
+    endif
+
+  ENDDO
+  ENDDO
+
+   if (0.gt.1) then
+!#if 0
+!  The seabreeze case is adapted from the squall line case
+!  so we just turn off the thermal perturbation
+
+!  thermal perturbation to kick off convection
+	call random_seed
+  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)/10000.
+!     xrad = 0.
+      DO K = 1, 35
+
+!  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%ph_1(i,k,j)+grid%ph_1(i,k+1,j)  &
+                   +grid%phb(i,k,j)+grid%phb(i,k+1,j))/g
+        zrad = (zrad-1500.)/1500.
+        RAD=SQRT(xrad*xrad+yrad*yrad+zrad*zrad)
+!        IF(RAD <= 1.) THEN
+	call RANDOM_NUMBER(rnd)
+	  grid%t_1(i,k,j)=grid%t_1(i,k,j)+delt*(rnd-0.5)
+         !  grid%t_1(i,k,j)=grid%t_1(i,k,j)+delt*COS(.5*PI*RAD)**2
+           grid%t_2(i,k,j)=grid%t_1(i,k,j)
+           qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+           grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                        (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+           grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+!        ENDIF
+      ENDDO
+
+!  rebalance hydrostatically
+
+      DO k  = 2,kte
+        grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                     (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                      grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+        grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+        grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+      ENDDO
+
+    ENDDO
+  ENDDO
+	endif 
+!#endif
+
+   write(6,*) ' grid%mu_1 from comp ', grid%mu_1(1,1)
+   write(6,*) ' full state sounding from comp, ph, grid%p, grid%al, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1)+grid%phb(1,k,1), &
+                                      grid%p(1,k,1)+grid%pb(1,k,1), grid%alt(1,k,1), &
+                                      grid%t_1(1,k,1)+t0, moist(1,k,1,P_QV)
+   enddo
+
+   write(6,*) ' pert state sounding from comp, grid%ph_1, pp, alp, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1), &
+                                      grid%p(1,k,1), grid%al(1,k,1), &
+                                      grid%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%phb(i,1,j)/g
+    ELSE IF (j == jde) THEN
+      z_at_v = grid%phb(i,1,j-1)/g
+    ELSE
+      z_at_v = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in )
+      grid%v_2(i,k,j) = grid%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%phb(i,1,j)/g
+    ELSE IF (i == ide) THEN
+      z_at_u = grid%phb(i-1,1,j)/g
+    ELSE
+      z_at_u = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in )
+      grid%u_2(i,k,j) = grid%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%w_1(i,k,j) = 0.
+    grid%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%t_base(k) = grid%t_1(1,k,1)
+    grid%qv_base(k) = moist(1,k,1,P_QV)
+    grid%u_base(k) = grid%u_1(1,k,1)
+    grid%v_base(k) = grid%v_1(1,k,1)
+    grid%z_base(k) = 0.5*(grid%phb(1,k,1)+grid%phb(1,k+1,1)+grid%ph_1(1,k,1)+grid%ph_1(1,k+1,1))/g
+  ENDDO
+
+  DO J = jts, min(jde-1,jte)
+  DO I = its, min(ide-1,ite)
+     thtmp   = grid%t_2(i,1,j)+t0
+     ptmp    = grid%p(i,1,j)+grid%pb(i,1,j)
+     temp(1) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,2,j)+t0
+     ptmp    = grid%p(i,2,j)+grid%pb(i,2,j)
+     temp(2) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,3,j)+t0
+     ptmp    = grid%p(i,3,j)+grid%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=3000)
+      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 r
+      parameter (r = r_d)
+      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
+! For the seabreeze case, we can hard-wire the winds and qv fields 
+          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_ideal
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_squall2d_x.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_squall2d_x.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_squall2d_x.F	(revision 17)
@@ -0,0 +1,759 @@
+!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_ideal
+
+   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 :: idum1, idum2
+
+   CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+     CALL init_domain_rk( grid &
+!
+#include <actual_new_args.inc>
+!
+                        )
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain_rk ( grid &
+!
+# include <dummy_new_args.inc>
+!
+)
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include <dummy_new_decl.inc>
+
+   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
+
+   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_pole_lon (1,0.)
+    CALL nl_set_pole_lat (1,90.)
+    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%msftx(i,j)    = 1.
+         grid%msfty(i,j)    = 1.
+         grid%msfux(i,j)    = 1.
+         grid%msfuy(i,j)    = 1.
+         grid%msfvx(i,j)    = 1.
+         grid%msfvx_inv(i,j)= 1.
+         grid%msfvy(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%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%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%znw(k) = 1. - float(k-1)/float(kde-1)
+     ENDDO
+   ENDIF
+
+   DO k=1, kde-1
+    grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
+    grid%rdnw(k) = 1./grid%dnw(k)
+    grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
+   ENDDO
+   DO k=2, kde-1
+    grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
+    grid%rdn(k) = 1./grid%dn(k)
+    grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
+    grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
+   ENDDO
+
+   cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) 
+   cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) 
+   grid%cf1  = grid%fnp(2) + cof1
+   grid%cf2  = grid%fnm(2) - cof1 - cof2
+   grid%cf3  = cof2       
+
+   grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
+   grid%cfn1 = -.5*grid%dnw(kde-1)/grid%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%phb(i,1,j) = 0.
+    grid%php(i,1,j) = 0.
+    grid%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%phb(i,1,j)/g, nl_in )
+    grid%mub(i,j) = p_surf-grid%p_top
+
+!  this is dry hydrostatic sounding (base state), so given grid%p (coordinate),
+!  interp theta (from interp) and compute 1/rho from eqn. of state
+
+    DO K = 1, kte-1
+      p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%pb(i,k,j) = p_level
+      grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0
+      grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%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%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j)
+    ENDDO
+
+  ENDDO
+  ENDDO
+
+  write(6,*) ' ptop is ',grid%p_top
+  write(6,*) ' base state grid%mub(1,1), p_surf is ',grid%mub(1,1),grid%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%phb(i,1,j)/g, nl_in )
+
+!  compute the perturbation mass and the full mass
+
+    grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j)
+    grid%mu_2(i,j) = grid%mu_1(i,j)
+    grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j)
+
+! given the dry pressure and coordinate system, interp the potential
+! temperature and qv
+
+    do k=1,kde-1
+
+      p_level = grid%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%t_1(i,k,j)          = interp_0( theta, pd_in, p_level, nl_in ) - t0
+      grid%t_2(i,k,j)          = grid%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%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%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k)
+    grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+    qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+    grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+    grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+      qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+      grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                  (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+      grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+    enddo
+
+!  this is the hydrostatic equation used in the model after the
+!  small timesteps.  In the model, grid%al (inverse density)
+!  is computed from the geopotential.
+
+
+    grid%ph_1(i,1,j) = 0.
+    DO k  = 2,kte
+      grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                   (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                    grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+      grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+      grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+    ENDDO
+
+    if((i==2) .and. (j==2)) then
+     write(6,*) ' grid%ph_1 calc ',grid%ph_1(2,1,2),grid%ph_1(2,2,2),&
+                              grid%mu_1(2,2)+grid%mub(2,2),grid%mu_1(2,2), &
+                              grid%alb(2,1,2),grid%al(1,2,1),grid%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%ph_1(i,k,j)+grid%ph_1(i,k+1,j)  &
+                   +grid%phb(i,k,j)+grid%phb(i,k+1,j))/g
+        zrad = (zrad-1500.)/1500.
+        RAD=SQRT(xrad*xrad+yrad*yrad+zrad*zrad)
+        IF(RAD <= 1.) THEN
+           grid%t_1(i,k,j)=grid%t_1(i,k,j)+delt*COS(.5*PI*RAD)**2
+           grid%t_2(i,k,j)=grid%t_1(i,k,j)
+           qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+           grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                        (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+           grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+        ENDIF
+      ENDDO
+
+!  rebalance hydrostatically
+
+      DO k  = 2,kte
+        grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                     (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                      grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+        grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+        grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+      ENDDO
+
+    ENDDO
+  ENDDO
+
+!#endif
+
+   write(6,*) ' grid%mu_1 from comp ', grid%mu_1(1,1)
+   write(6,*) ' full state sounding from comp, ph, grid%p, grid%al, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1)+grid%phb(1,k,1), &
+                                      grid%p(1,k,1)+grid%pb(1,k,1), grid%alt(1,k,1), &
+                                      grid%t_1(1,k,1)+t0, moist(1,k,1,P_QV)
+   enddo
+
+   write(6,*) ' pert state sounding from comp, grid%ph_1, pp, alp, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1), &
+                                      grid%p(1,k,1), grid%al(1,k,1), &
+                                      grid%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%phb(i,1,j)/g
+    ELSE IF (j == jde) THEN
+      z_at_v = grid%phb(i,1,j-1)/g
+    ELSE
+      z_at_v = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in )
+      grid%v_2(i,k,j) = grid%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%phb(i,1,j)/g
+    ELSE IF (i == ide) THEN
+      z_at_u = grid%phb(i-1,1,j)/g
+    ELSE
+      z_at_u = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in )
+      grid%u_2(i,k,j) = grid%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%w_1(i,k,j) = 0.
+    grid%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%t_base(k) = grid%t_1(1,k,1)
+    grid%qv_base(k) = moist(1,k,1,P_QV)
+    grid%u_base(k) = grid%u_1(1,k,1)
+    grid%v_base(k) = grid%v_1(1,k,1)
+    grid%z_base(k) = 0.5*(grid%phb(1,k,1)+grid%phb(1,k+1,1)+grid%ph_1(1,k,1)+grid%ph_1(1,k+1,1))/g
+  ENDDO
+
+  DO J = jts, min(jde-1,jte)
+  DO I = its, min(ide-1,ite)
+     thtmp   = grid%t_2(i,1,j)+t0
+     ptmp    = grid%p(i,1,j)+grid%pb(i,1,j)
+     temp(1) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,2,j)+t0
+     ptmp    = grid%p(i,2,j)+grid%pb(i,2,j)
+     temp(2) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,3,j)+t0
+     ptmp    = grid%p(i,3,j)+grid%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 r
+      parameter (r = r_d)
+      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_ideal
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_squall2d_y.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_squall2d_y.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_squall2d_y.F	(revision 17)
@@ -0,0 +1,756 @@
+!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_ideal
+
+   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 :: idum1, idum2
+
+   CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+     CALL init_domain_rk( grid &
+!
+#include <actual_new_args.inc>
+!
+                        )
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain_rk ( grid &
+!
+# include <dummy_new_args.inc>
+!
+)
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include <dummy_new_decl.inc>
+
+   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
+
+   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_pole_lon (1,0.)
+    CALL nl_set_pole_lat (1,90.)
+    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%msftx(i,j)    = 1.
+         grid%msfty(i,j)    = 1.
+         grid%msfux(i,j)    = 1.
+         grid%msfuy(i,j)    = 1.
+         grid%msfvx(i,j)    = 1.
+         grid%msfvx_inv(i,j)= 1.
+         grid%msfvy(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%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%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%znw(k) = 1. - float(k-1)/float(kde-1)
+     ENDDO
+   ENDIF
+
+   DO k=1, kde-1
+    grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
+    grid%rdnw(k) = 1./grid%dnw(k)
+    grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
+   ENDDO
+   DO k=2, kde-1
+    grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
+    grid%rdn(k) = 1./grid%dn(k)
+    grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
+    grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
+   ENDDO
+
+   cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) 
+   cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) 
+   grid%cf1  = grid%fnp(2) + cof1
+   grid%cf2  = grid%fnm(2) - cof1 - cof2
+   grid%cf3  = cof2       
+
+   grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
+   grid%cfn1 = -.5*grid%dnw(kde-1)/grid%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%phb(i,1,j) = 0.
+    grid%php(i,1,j) = 0.
+    grid%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%phb(i,1,j)/g, nl_in )
+    grid%mub(i,j) = p_surf-grid%p_top
+
+!  this is dry hydrostatic sounding (base state), so given grid%p (coordinate),
+!  interp theta (from interp) and compute 1/rho from eqn. of state
+
+    DO K = 1, kte-1
+      p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%pb(i,k,j) = p_level
+      grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0
+      grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%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%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j)
+    ENDDO
+
+  ENDDO
+  ENDDO
+
+  write(6,*) ' ptop is ',grid%p_top
+  write(6,*) ' base state grid%mub(1,1), p_surf is ',grid%mub(1,1),grid%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%phb(i,1,j)/g, nl_in )
+
+!  compute the perturbation mass and the full mass
+
+    grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j)
+    grid%mu_2(i,j) = grid%mu_1(i,j)
+    grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j)
+
+! given the dry pressure and coordinate system, interp the potential
+! temperature and qv
+
+    do k=1,kde-1
+
+      p_level = grid%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%t_1(i,k,j)          = interp_0( theta, pd_in, p_level, nl_in ) - t0
+      grid%t_2(i,k,j)          = grid%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%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%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k)
+    grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+    qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+    grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+    grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+      qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+      grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                  (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+      grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+    enddo
+
+!  this is the hydrostatic equation used in the model after the
+!  small timesteps.  In the model, grid%al (inverse density)
+!  is computed from the geopotential.
+
+
+    grid%ph_1(i,1,j) = 0.
+    DO k  = 2,kte
+      grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                   (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                    grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+      grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+      grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+    ENDDO
+
+    if((i==2) .and. (j==2)) then
+     write(6,*) ' grid%ph_1 calc ',grid%ph_1(2,1,2),grid%ph_1(2,2,2),&
+                              grid%mu_1(2,2)+grid%mub(2,2),grid%mu_1(2,2), &
+                              grid%alb(2,1,2),grid%al(1,2,1),grid%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%ph_1(i,k,j)+grid%ph_1(i,k+1,j)  &
+                   +grid%phb(i,k,j)+grid%phb(i,k+1,j))/g
+        zrad = (zrad-1500.)/1500.
+        RAD=SQRT(xrad*xrad+yrad*yrad+zrad*zrad)
+        IF(RAD <= 1.) THEN
+           grid%t_1(i,k,j)=grid%t_1(i,k,j)+delt*COS(.5*PI*RAD)**2
+           grid%t_2(i,k,j)=grid%t_1(i,k,j)
+           qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+           grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                        (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+           grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+        ENDIF
+      ENDDO
+
+!  rebalance hydrostatically
+
+      DO k  = 2,kte
+        grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                     (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                      grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+        grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+        grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+      ENDDO
+
+    ENDDO
+  ENDDO
+
+!#endif
+
+   write(6,*) ' grid%mu_1 from comp ', grid%mu_1(1,1)
+   write(6,*) ' full state sounding from comp, ph, grid%p, grid%al, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1)+grid%phb(1,k,1), &
+                                      grid%p(1,k,1)+grid%pb(1,k,1), grid%alt(1,k,1), &
+                                      grid%t_1(1,k,1)+t0, moist(1,k,1,P_QV)
+   enddo
+
+   write(6,*) ' pert state sounding from comp, grid%ph_1, pp, alp, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1), &
+                                      grid%p(1,k,1), grid%al(1,k,1), &
+                                      grid%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%phb(i,1,j)/g
+    ELSE IF (j == jde) THEN
+      z_at_v = grid%phb(i,1,j-1)/g
+    ELSE
+      z_at_v = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in )
+      grid%v_2(i,k,j) = grid%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%phb(i,1,j)/g
+    ELSE IF (i == ide) THEN
+      z_at_u = grid%phb(i-1,1,j)/g
+    ELSE
+      z_at_u = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in )
+      grid%u_2(i,k,j) = grid%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%w_1(i,k,j) = 0.
+    grid%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%t_base(k) = grid%t_1(1,k,1)
+    grid%qv_base(k) = moist(1,k,1,P_QV)
+    grid%u_base(k) = grid%u_1(1,k,1)
+    grid%v_base(k) = grid%v_1(1,k,1)
+    grid%z_base(k) = 0.5*(grid%phb(1,k,1)+grid%phb(1,k+1,1)+grid%ph_1(1,k,1)+grid%ph_1(1,k+1,1))/g
+  ENDDO
+
+  DO J = jts, min(jde-1,jte)
+  DO I = its, min(ide-1,ite)
+     thtmp   = grid%t_2(i,1,j)+t0
+     ptmp    = grid%p(i,1,j)+grid%pb(i,1,j)
+     temp(1) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,2,j)+t0
+     ptmp    = grid%p(i,2,j)+grid%pb(i,2,j)
+     temp(2) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,3,j)+t0
+     ptmp    = grid%p(i,3,j)+grid%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 r
+      parameter (r = r_d)
+      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_ideal
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_tropical_cyclone.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_tropical_cyclone.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_initialize_tropical_cyclone.F	(revision 17)
@@ -0,0 +1,1231 @@
+!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_ideal
+
+   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
+   USE module_soil_pre
+#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 :: idum1, idum2
+
+   CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+     CALL init_domain_rk( grid &
+!
+#include <actual_new_args.inc>
+!
+                        )
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE init_domain_rk ( grid &
+!
+# include <dummy_new_args.inc>
+!
+)
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include <dummy_new_decl.inc>
+
+   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
+
+   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, lm
+   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    :: pi, rnd
+
+! variables/arrays for analytic vortex:
+    integer :: nref,kref,nloop,i1,i2
+    real :: r0,zdd,dd1,dd2,xref,vr,fcor,qvs,e1,tx,px,qx,ric,rjc,rr,diff,sst
+    real*8 :: rmax,vmax,frac,angle
+    real, dimension(:), allocatable :: rref,zref,th0,qv0,thv0,prs0,pi0,rh0
+    real, dimension(:,:), allocatable :: vref,piref,pref,thref,thvref,qvref
+
+!  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
+   character (len=256) :: mminlu2
+   
+#ifdef DM_PARALLEL
+#    include <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
+
+!-----------------------------------------------------------------------
+!               USER SETTINGS
+
+!  Parameters for analytic vortex:
+!  Reference:  Rotunno and Emanuel, 1987, JAS, p. 549
+
+    r0     =   412500.0     ! outer radius (m)
+    rmax   =    82500.0     ! approximate radius of max winds (m)
+    vmax   =       15.0     ! approximate value of max wind speed (m/s)
+    zdd    =    20000.0     ! depth of vortex (m)
+
+
+! other settings:
+
+    fcor   =  5.0e-5        ! Coriolis parameter (1/s)
+    sst    =  28.0          ! sea-surface temperature (Celsius)
+
+!-----------------------------------------------------------------------
+
+   stretch_grid = .true.
+   delt = 6.
+!   z_scale = .50
+   z_scale = .40
+   pi = 2.*asin(1.0)
+   write(6,*) ' pi is ',pi
+   nxc = (ide-ids)/2
+   nyc = jde/2
+   icm = ide/2
+! lm is the half width of the land in terms of grid points
+   lm = 25
+   write(6,*) 'lm,icm-lm,icm+lm = ', lm,icm-lm,icm+lm
+
+   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
+
+    mminlu2 = ' '
+    mminlu2(1:4) = 'USGS'
+    CALL nl_set_mminlu(1, mminlu2)
+!   CALL nl_set_mminlu(1, 'USGS')
+    CALL nl_set_iswater(1,16)
+    CALL nl_set_isice(1,3)
+    CALL nl_set_cen_lat(1,20.)
+    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_pole_lon (1,0.)
+    CALL nl_set_pole_lat (1,90.)
+    CALL nl_set_map_proj(1,0)
+!   CALL model_to_grid_config_rec(1,model_config_rec,config_flags)
+    CALL nl_get_iswater(1,grid%iswater)
+
+!  here we initialize data that 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%msftx(i,j)    = 1.
+         grid%msfty(i,j)    = 1.
+         grid%msfux(i,j)    = 1.
+         grid%msfuy(i,j)    = 1.
+         grid%msfvx(i,j)    = 1.
+         grid%msfvy(i,j)    = 1.
+         grid%msfvx_inv(i,j)= 1.
+         grid%sina(i,j)     = 0.
+         grid%cosa(i,j)     = 1.
+         grid%xlong(i,j)    = 0.0
+         grid%e(i,j)        = 0.0
+         grid%f(i,j)        = fcor
+         grid%xlat(i,j)     = asin(0.5*fcor/EOMEG)/DEGRAD
+! Hard-wire the ocean configuration
+	 grid%xland(i,j)     = 2.
+         grid%lu_index(i,j)  = 16
+         grid%tsk(i,j) = 273.15 + sst
+         ! I think tmn is not used for ocean points, but set a value anyway:
+         grid%tmn(i,j) = grid%tsk(i,j) - 10.0
+      END DO
+   END DO
+
+    print *,'   f = ',grid%f(its,jts)
+    print *,'   lat = ',grid%xlat(its,jts)
+
+! for Noah LSM, additional variables need to be initialized
+
+   other_masked_fields : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
+
+      CASE (SLABSCHEME)
+
+      CASE (LSMSCHEME)
+
+        DO j = jts , MIN(jde-1,jte)
+           DO i = its , MIN(ide-1,ite)
+              IF (grid%xland(i,j) .lt. 1.5) THEN
+                 grid%vegfra(i,j) = 0.5
+                 grid%canwat(i,j) = 0.
+                 grid%ivgtyp(i,j) = 18
+                 grid%isltyp(i,j) = 8
+                 grid%xice(i,j) = 0.
+                 grid%snow(i,j) = 0.
+              ELSE
+                 grid%vegfra(i,j) = 0.
+                 grid%canwat(i,j) = 0.
+                 grid%ivgtyp(i,j) = 16
+                 grid%isltyp(i,j) = 14
+                 grid%xice(i,j) = 0.
+                 grid%snow(i,j) = 0.
+              ENDIF
+           END DO
+        END DO
+
+      CASE (RUCLSMSCHEME)
+
+   END SELECT other_masked_fields
+
+   DO j = jts, jte
+    DO k = kts, kte
+      DO i = its, ite
+         grid%ww(i,k,j)     = 0.
+      END DO
+    END DO
+   END DO
+
+   grid%step_number = 0
+
+! Process the soil; note that there are some things hard-wired into share/module_soil_pre.F
+      CALL process_soil_ideal(grid%xland,grid%xice,grid%vegfra,grid%snow,grid%canwat, &
+                     grid%ivgtyp,grid%isltyp,grid%tslb,grid%smois, &
+                     grid%tsk,grid%tmn,grid%zs,grid%dzs,model_config_rec%num_soil_layers, &
+                     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 )
+
+! set up the grid
+
+   IF (stretch_grid) THEN ! exponential stretch for eta (nearly constant dz)
+     DO k=1, kde
+      grid%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%znw(k) = 1. - float(k-1)/float(kde-1)
+     ENDDO
+   ENDIF
+
+   DO k=1, kde-1
+    grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
+    grid%rdnw(k) = 1./grid%dnw(k)
+    grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
+   ENDDO
+   DO k=2, kde-1
+    grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
+    grid%rdn(k) = 1./grid%dn(k)
+    grid%fnp(k) = .5* grid%dnw(k  )/grid%dn(k)
+    grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
+   ENDDO
+
+   cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) 
+   cof2 =     grid%dn(2)        /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) 
+   grid%cf1  = grid%fnp(2) + cof1
+   grid%cf2  = grid%fnm(2) - cof1 - cof2
+   grid%cf3  = cof2       
+
+   grid%cfn  = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
+   grid%cfn1 = -.5*grid%dnw(kde-1)/grid%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%phb(i,1,j) = 0.
+    grid%php(i,1,j) = 0.
+    grid%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%phb(i,1,j)/g, nl_in )
+    grid%mub(i,j) = p_surf-grid%p_top
+
+!  this is dry hydrostatic sounding (base state), so given grid%p (coordinate),
+!  interp theta (from interp) and compute 1/rho from eqn. of state
+
+    DO K = 1, kte-1
+      p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%pb(i,k,j) = p_level
+      grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0
+      grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%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%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j)
+    ENDDO
+
+  ENDDO
+  ENDDO
+
+  write(6,*) ' ptop is ',grid%p_top
+  write(6,*) ' base state grid%mub(1,1), p_surf is ',grid%mub(1,1),grid%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%phb(i,1,j)/g, nl_in )
+
+!  compute the perturbation mass and the full mass
+
+    grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j)
+    grid%mu_2(i,j) = grid%mu_1(i,j)
+    grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j)
+
+! given the dry pressure and coordinate system, interp the potential
+! temperature and qv
+
+    do k=1,kde-1
+
+      p_level = grid%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%t_1(i,k,j)          = interp_0( theta, pd_in, p_level, nl_in ) - t0
+      grid%t_2(i,k,j)          = grid%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%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%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k)
+    grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+    qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+    grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+    grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+      qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+      grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                  (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+      grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+    enddo
+
+!  this is the hydrostatic equation used in the model after the
+!  small timesteps.  In the model, grid%al (inverse density)
+!  is computed from the geopotential.
+
+
+    grid%ph_1(i,1,j) = 0.
+    DO k  = 2,kte
+      grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                   (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                    grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+      grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+      grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+    ENDDO
+
+    if((i==2) .and. (j==2)) then
+     write(6,*) ' grid%ph_1 calc ',grid%ph_1(2,1,2),grid%ph_1(2,2,2),&
+                              grid%mu_1(2,2)+grid%mub(2,2),grid%mu_1(2,2), &
+                              grid%alb(2,1,2),grid%al(1,2,1),grid%rdnw(1)
+    endif
+
+  ENDDO
+  ENDDO
+
+!-----------------------------------------------------------------------
+!  Analytic vortex.
+!  Reference:  Rotunno and Emanuel, 1987, JAS, p. 549
+
+    dd2 = 2.0 * rmax / ( r0 + rmax )
+
+    nref = 1 + int( float(ide-ids+1)/2.0 )
+    kref = kte-1
+
+    print *,'  ids,ide,kds,kds  = ',ids,ide,kds,kde
+    print *,'  its,ite,kts,kts  = ',its,ite,kts,kte
+    print *,'  nref,fcor        = ',nref,fcor
+    print *,'  r0,rmax,vmax,zdd = ',r0,rmax,vmax,zdd
+
+    allocate(  rref(nref)         )
+    allocate(  zref(0:kref+1)     )
+    allocate(   th0(0:kref+1)     )
+    allocate(   qv0(0:kref+1)     )
+    allocate(  thv0(0:kref+1)     )
+    allocate(  prs0(0:kref+1)     )
+    allocate(   pi0(0:kref+1)     )
+    allocate(   rh0(0:kref+1)     )
+    allocate(  vref(nref,0:kref+1))
+    allocate( piref(nref,0:kref+1))
+    allocate(  pref(nref,0:kref+1))
+    allocate( thref(nref,0:kref+1))
+    allocate(thvref(nref,0:kref+1))
+    allocate( qvref(nref,0:kref+1))
+
+    ! get base state:
+    print *,'  zref,th0,qv0,thv0:'
+    do k=1,kref
+      th0(k) = t0+grid%t_1(1,k,1)
+      qv0(k) = moist(1,k,1,P_QV)
+      thv0(k) = th0(k)*(1.0+(r_v/r_d)*qv0(k))/(1.0+qv0(k))
+      zref(k) = 0.5*(grid%phb(1,k,1)+grid%phb(1,k+1,1)+grid%ph_1(1,k,1)+grid%ph_1(1,k+1,1))/g
+      print *,k,zref(k),th0(k),qv0(k),thv0(k)
+    enddo
+
+    print *,'  prs0,pi0,rh0:'
+    do k=1,kref
+      prs0(k) = grid%p(1,k,1)+grid%pb(1,k,1)
+      pi0(k) = (prs0(k)/p0)**(r_d/cp)
+      E1=1000.0*SVP1*EXP(SVP2*(th0(k)*pi0(k)-SVPT0)/(th0(k)*pi0(k)-SVP3))
+      qvs = EP_2*E1/(prs0(k)-E1)
+      rh0(k) = qv0(k)/qvs
+      print *,k,prs0(k),pi0(k),rh0(k)
+    enddo
+
+    zref(0) = -zref(1)
+    zref(kref+1) = zref(kref)+(zref(kref)-zref(kref-1))
+
+      rref=0.0
+      vref=0.0
+     piref=0.0
+      pref=0.0
+     thref=0.0
+    thvref=0.0
+     qvref=0.0
+
+    do i=1,nref
+      rref(i) = config_flags%dx*(float(i-1)+0.5)
+    enddo
+
+    print *,'  zref:'
+    do k=0,kref+1
+      print *,k,zref(k)
+    enddo
+
+    print *,'  vref:'
+    do k=1,kref
+      do i=1,nref
+        if(rref(i).lt.r0)then
+          dd1 = 2.0 * rmax / ( rref(i) + rmax )
+          vr = sqrt( vmax**2 * (rref(i)/rmax)**2     &
+          * ( dd1 ** 3 - dd2 ** 3 ) + 0.25*fcor*fcor*rref(i)*rref(i) )   &
+                  - 0.5 * fcor * rref(i)
+        else 
+          vr = 0.0
+        endif
+        if(zref(k).lt.zdd)then
+          vref(i,k) = vr * (zdd-zref(k))/(zdd-0.0)
+        else
+          vref(i,k) = 0.0
+        endif
+        if(k.eq.1) print *,i,rref(i),vref(i,k)
+      enddo
+    enddo
+
+    print *,'  Iterate:'
+    DO nloop=1,20
+
+      ! get qv and thv from rh and th:
+      do k=1,kref
+      do i=1,nref
+        tx = (pi0(k)+piref(i,k))*(th0(k)+thref(i,k))
+        px = p0*((pi0(k)+piref(i,k))**(cp/r_d))
+        E1 = 1000.0*SVP1*EXP(SVP2*(tx-SVPT0)/(tx-SVP3))
+        qvs = EP_2*E1/(px-E1)
+        qvref(i,k) = rh0(k)*qvs
+        thvref(i,k)=(th0(k)+thref(i,k))*(1.0+(r_v/r_d)*qvref(i,k))   &
+                                           /(1.0+qvref(i,k))
+      enddo
+      enddo
+
+      ! get nondimensional pressure perturbation (piref):
+      do k=1,kref
+        piref(nref,k)=0.0
+        do i=nref,2,-1 
+          piref(i-1,k) = piref(i,k)                                       &
+       + (rref(i-1)-rref(i))/(cp*0.5*(thvref(i-1,k)+thvref(i,k))) * 0.5 * &
+           ( vref(i  ,k)*vref(i  ,k)/rref(i)                              &
+            +vref(i-1,k)*vref(i-1,k)/rref(i-1)                            &
+             + fcor * ( vref(i,k) + vref(i-1,k) ) )
+        enddo
+      enddo
+
+      do i=1,nref
+        piref(i,   0) = piref(i, 1)
+        piref(i,kref+1) = piref(i,kref)
+      enddo
+
+      ! get potential temperature perturbation (thref):
+      do k=2,kref
+      do i=1,nref
+        thref(i,k) = 0.5*( cp*0.5*(thvref(i,k)+thvref(i,k+1))*(piref(i,k+1)-piref(i,k))/(zref(k+1)-zref(k))     &
+                          +cp*0.5*(thvref(i,k)+thvref(i,k-1))*(piref(i,k)-piref(i,k-1))/(zref(k)-zref(k-1)) )   &
+                        *thv0(k)/g
+        thref(i,k)=(thv0(k)+thref(i,k))*(1.0+qvref(i,k))/(1.0+(r_v/r_d)*qvref(i,k))-th0(k)
+      enddo
+      enddo
+
+      k=1
+      do i=1,nref
+        thref(i,k) = ( cp*0.5*(thvref(i,k)+thvref(i,k+1))*(piref(i,k+1)-piref(i,k))/(zref(k+1)-zref(k)) )   &
+                        *thv0(k)/g
+        thref(i,k)=(thv0(k)+thref(i,k))*(1.0+qvref(i,k))/(1.0+(r_v/r_d)*qvref(i,k))-th0(k)
+      enddo
+
+      print *,'  th,qv,pi = ',nloop,thref(1,1),qvref(1,1),piref(1,1)
+
+    ENDDO   ! enddo for iteration
+
+    ! reference (total) pressure:
+    do k=1,kref
+    do i=1,nref
+      pref(i,k) = p0*( ( pi0(k)+piref(i1,k)+(piref(i2,k)-piref(i1,k))*frac )**(cp/r_d) )
+    enddo
+    enddo
+
+    ! analytic axisymmetric vortex is ready ... now interpolate to 3D grid:
+    ! (note:  vortex is placed in center of domain)
+
+    ric = float(ide-ids+1)/2.0
+    rjc = float(jde-jds+1)/2.0
+
+    print *,'  ids,ide,jds,jde = ',ids,ide,jds,jde
+    print *,'  ric,rjc = ',ric,rjc
+
+    print *,'  zk:'
+    do k=1,kte
+      zk(k) = zref(k)
+      print *,k,zk(k)
+    enddo
+
+    nl_in = kte-1
+    print *,'  nl_in = ',nl_in
+
+    DO J = jts, min(jde-1,jte)
+    DO I = its, min(ide-1,ite)
+      rr = sqrt( ( (float(i)-ric)*config_flags%dx )**2 + ( (float(j)-rjc)*config_flags%dy )**2 )
+      rr = min( rr , rref(nref) )
+            diff = -1.0e20
+            ii = 0
+            do while( diff.lt.0.0 )
+              ii = ii + 1
+              diff = rref(ii)-rr
+            enddo
+            i2 = max( ii , 2 )
+            i1 = i2-1
+            frac = (      rr-rref(i1))   &
+                  /(rref(i2)-rref(i1))
+            do k=1,kte
+              px = p0*( ( pi0(k)+piref(i1,k)+(piref(i2,k)-piref(i1,k))*frac )**(cp/r_d) )
+              qx = qvref(i1,k)+(qvref(i2,k)-qvref(i1,k))*frac
+              qv(k) = qx
+              theta(k) = th0(k)+thref(i1,k)+(thref(i2,k)-thref(i1,k))*frac
+              pd_in(k) = px/(1.0+((r_v/r_d)*qx))
+            enddo
+
+!  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%phb(i,1,j)/g, nl_in )
+
+!  compute the perturbation mass and the full mass
+
+    grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j)
+    grid%mu_2(i,j) = grid%mu_1(i,j)
+    grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j)
+
+! given the dry pressure and coordinate system, interp the potential
+! temperature and qv
+
+    do k=1,kde-1
+
+      p_level = grid%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%t_1(i,k,j)          = interp_0( theta, pd_in, p_level, nl_in ) - t0
+      grid%t_2(i,k,j)          = grid%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%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%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k)
+    grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+    qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+    grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+    grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+      qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+      grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                  (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+      grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+    enddo
+
+!  this is the hydrostatic equation used in the model after the
+!  small timesteps.  In the model, grid%al (inverse density)
+!  is computed from the geopotential.
+
+
+    grid%ph_1(i,1,j) = 0.
+    DO k  = 2,kte
+      grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                   (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                    grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+      grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+      grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+    ENDDO
+
+    ENDDO   ! do loop for i
+    ENDDO   ! do loop for j
+
+!-------------------------------------------
+! Done with mass fields, now get winds:
+
+! interp v
+
+  DO J = jts, jte
+  DO I = its, min(ide-1,ite)
+
+      rr = sqrt( ( (float(i)-ric)*config_flags%dx )**2 + ( (float(j)-0.5-rjc)*config_flags%dy )**2 )
+      rr = min( rr , rref(nref) )
+            diff = -1.0e20
+            ii = 0
+            do while( diff.lt.0.0 )
+              ii = ii + 1
+              diff = rref(ii)-rr
+            enddo
+            i2 = max( ii , 2 )
+            i1 = i2-1
+            frac = (      rr-rref(i1))   &
+                  /(rref(i2)-rref(i1))
+            angle = datan2(dble( (float(j)-0.5-rjc)*config_flags%dy ),   &
+                           dble( (float(i)-ric)*config_flags%dx ) )
+            do k=1,kte
+              v(k) = (vref(i1,k)+( vref(i2,k)- vref(i1,k))*frac )*cos(angle)
+              p_in(k) = pref(i1,k)+(pref(i2,k)-pref(i1,k))*frac
+            enddo
+
+    IF (j == jds) THEN
+      z_at_v = grid%phb(i,1,j)/g
+    ELSE IF (j == jde) THEN
+      z_at_v = grid%phb(i,1,j-1)/g
+    ELSE
+      z_at_v = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in )
+      grid%v_2(i,k,j) = grid%v_1(i,k,j)
+    ENDDO
+
+  ENDDO
+  ENDDO
+
+! interp u
+
+  DO J = jts, min(jde-1,jte)
+  DO I = its, ite
+
+      rr = sqrt( ( (float(i)-ric-0.5)*config_flags%dx )**2 + ( (float(j)-rjc)*config_flags%dy )**2 )
+      rr = min( rr , rref(nref) )
+            diff = -1.0e20
+            ii = 0
+            do while( diff.lt.0.0 )
+              ii = ii + 1
+              diff = rref(ii)-rr
+            enddo
+            i2 = max( ii , 2 )
+            i1 = i2-1
+            frac = (      rr-rref(i1))   &
+                  /(rref(i2)-rref(i1))
+            angle = datan2(dble( (float(j)-rjc)*config_flags%dy ),   &
+                           dble( (float(i)-0.5-ric)*config_flags%dx ) )
+            do k=1,kte
+              u(k) = -(vref(i1,k)+( vref(i2,k)- vref(i1,k))*frac )*sin(angle)
+              p_in(k) = pref(i1,k)+(pref(i2,k)-pref(i1,k))*frac
+            enddo
+
+    IF (i == ids) THEN
+      z_at_u = grid%phb(i,1,j)/g
+    ELSE IF (i == ide) THEN
+      z_at_u = grid%phb(i-1,1,j)/g
+    ELSE
+      z_at_u = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+      grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in )
+      grid%u_2(i,k,j) = grid%u_1(i,k,j)
+    ENDDO
+
+  ENDDO
+  ENDDO
+
+    ! All done ... deallocate arrays:
+
+    deallocate(  rref )
+    deallocate(  zref )
+    deallocate(   th0 )
+    deallocate(   qv0 )
+    deallocate(  thv0 )
+    deallocate(  prs0 )
+    deallocate(   pi0 )
+    deallocate(   rh0 )
+    deallocate(  vref )
+    deallocate( piref )
+    deallocate(  pref )
+    deallocate( thref )
+    deallocate(thvref )
+    deallocate( qvref )
+
+    print *,'  completed vortex init successfully '
+
+!-----------------------------------------------------------------------
+
+   if (0.gt.1) then
+!#if 0
+!  The tropical_cyclone case is adapted from the squall line case
+!  so we just turn off the thermal perturbation
+
+!  thermal perturbation to kick off convection
+	call random_seed
+  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)/10000.
+!     xrad = 0.
+      DO K = 1, 35
+
+!  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%ph_1(i,k,j)+grid%ph_1(i,k+1,j)  &
+                   +grid%phb(i,k,j)+grid%phb(i,k+1,j))/g
+        zrad = (zrad-1500.)/1500.
+        RAD=SQRT(xrad*xrad+yrad*yrad+zrad*zrad)
+!        IF(RAD <= 1.) THEN
+	call RANDOM_NUMBER(rnd)
+	  grid%t_1(i,k,j)=grid%t_1(i,k,j)+delt*(rnd-0.5)
+         !  grid%t_1(i,k,j)=grid%t_1(i,k,j)+delt*COS(.5*PI*RAD)**2
+           grid%t_2(i,k,j)=grid%t_1(i,k,j)
+           qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+           grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                        (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+           grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+!        ENDIF
+      ENDDO
+
+!  rebalance hydrostatically
+
+      DO k  = 2,kte
+        grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*(       &
+                     (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ &
+                      grid%mu_1(i,j)*grid%alb(i,k-1,j)  )
+                                                   
+        grid%ph_2(i,k,j) = grid%ph_1(i,k,j) 
+        grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j)
+      ENDDO
+
+    ENDDO
+  ENDDO
+	endif 
+!#endif
+
+   write(6,*) ' grid%mu_1 from comp ', grid%mu_1(1,1)
+   write(6,*) ' full state sounding from comp, ph, grid%p, grid%al, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1)+grid%phb(1,k,1), &
+                                      grid%p(1,k,1)+grid%pb(1,k,1), grid%alt(1,k,1), &
+                                      grid%t_1(1,k,1)+t0, moist(1,k,1,P_QV)
+   enddo
+
+   write(6,*) ' pert state sounding from comp, grid%ph_1, pp, alp, grid%t_1, qv '
+   do k=1,kde-1
+     write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1), &
+                                      grid%p(1,k,1), grid%al(1,k,1), &
+                                      grid%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%phb(i,1,j)/g
+!    ELSE IF (j == jde) THEN
+!      z_at_v = grid%phb(i,1,j-1)/g
+!    ELSE
+!      z_at_v = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+!      grid%v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in )
+!      grid%v_2(i,k,j) = grid%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%phb(i,1,j)/g
+!    ELSE IF (i == ide) THEN
+!      z_at_u = grid%phb(i-1,1,j)/g
+!    ELSE
+!      z_at_u = 0.5*(grid%phb(i,1,j)+grid%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%znu(k)*(p_surf - grid%p_top) + grid%p_top
+!      grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in )
+!      grid%u_2(i,k,j) = grid%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%w_1(i,k,j) = 0.
+    grid%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%t_base(k) = grid%t_1(1,k,1)
+    grid%qv_base(k) = moist(1,k,1,P_QV)
+    grid%u_base(k) = grid%u_1(1,k,1)
+    grid%v_base(k) = grid%v_1(1,k,1)
+    grid%z_base(k) = 0.5*(grid%phb(1,k,1)+grid%phb(1,k+1,1)+grid%ph_1(1,k,1)+grid%ph_1(1,k+1,1))/g
+  ENDDO
+
+  DO J = jts, min(jde-1,jte)
+  DO I = its, min(ide-1,ite)
+     thtmp   = grid%t_2(i,1,j)+t0
+     ptmp    = grid%p(i,1,j)+grid%pb(i,1,j)
+     temp(1) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,2,j)+t0
+     ptmp    = grid%p(i,2,j)+grid%pb(i,2,j)
+     temp(2) = thtmp * (ptmp/p1000mb)**rcp
+     thtmp   = grid%t_2(i,3,j)+t0
+     ptmp    = grid%p(i,3,j)+grid%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)
+     ! I don't know why this is here, so I have commented it out:
+!!!     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=3000)
+      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 r
+      parameter (r = r_d)
+      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_ideal
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_polarfft.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_polarfft.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_polarfft.F	(revision 17)
@@ -0,0 +1,650 @@
+MODULE module_polarfft
+
+  USE module_model_constants
+  USE module_wrf_error
+
+CONTAINS
+
+SUBROUTINE couple_scalars_for_filter ( field    &
+                 ,mu,mub                        &
+                 ,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(INOUT) :: field
+   REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: mu,mub
+
+   INTEGER :: i , j , k
+
+   DO j = jps, MIN(jpe,jde-1)
+   DO k = kps, kpe-1
+   DO i = ips, MIN(ipe,ide-1)
+      field(i,k,j)=field(i,k,j)*(mu(i,j)+mub(i,j))
+   END DO
+   END DO
+   END DO
+
+END SUBROUTINE couple_scalars_for_filter
+
+SUBROUTINE uncouple_scalars_for_filter ( field    &
+                 ,mu,mub                        &
+                 ,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(INOUT) :: field
+   REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: mu,mub
+
+   INTEGER :: i , j , k
+
+   DO j = jps, MIN(jpe,jde-1)
+   DO k = kps, kpe-1
+   DO i = ips, MIN(ipe,ide-1)
+      field(i,k,j)=field(i,k,j)/(mu(i,j)+mub(i,j))
+   END DO
+   END DO
+   END DO
+
+END SUBROUTINE uncouple_scalars_for_filter
+
+SUBROUTINE pxft ( grid                          &
+                 ,lineno       &
+                 ,flag_uv,flag_rurv             &
+                 ,flag_wph,flag_ww              &
+                 ,flag_t                        &
+                 ,flag_mu,flag_mut              &
+                 ,flag_moist                    &
+                 ,flag_chem                     &
+                 ,flag_tracer                   &
+                 ,flag_scalar                   &
+                 ,fft_filter_lat, dclat         &
+                 ,positive_definite             &
+                 ,moist,chem,tracer,scalar      &
+                 ,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 )
+   USE module_state_description
+   USE module_domain, ONLY : domain
+#ifdef DM_PARALLEL
+   USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y &
+                       , local_communicator_periodic, itrace                    &
+                       , local_communicator_x 
+   USE module_driver_constants
+#if 0
+   USE module_comm_dm, ONLY : &
+                 XPOSE_POLAR_FILTER_V_z2x_sub           &
+                ,XPOSE_POLAR_FILTER_V_x2z_sub           &
+                ,XPOSE_POLAR_FILTER_U_z2x_sub           &
+                ,XPOSE_POLAR_FILTER_U_x2z_sub           &
+                ,XPOSE_POLAR_FILTER_T_z2x_sub           &
+                ,XPOSE_POLAR_FILTER_T_x2z_sub           &
+                ,XPOSE_POLAR_FILTER_W_z2x_sub           &
+                ,XPOSE_POLAR_FILTER_W_x2z_sub           &
+                ,XPOSE_POLAR_FILTER_PH_z2x_sub          &
+                ,XPOSE_POLAR_FILTER_PH_x2z_sub          &
+                ,XPOSE_POLAR_FILTER_WW_z2x_sub          &
+                ,XPOSE_POLAR_FILTER_WW_x2z_sub          &
+                ,XPOSE_POLAR_FILTER_RV_z2x_sub          &
+                ,XPOSE_POLAR_FILTER_RV_x2z_sub          &
+                ,XPOSE_POLAR_FILTER_RU_z2x_sub          &
+                ,XPOSE_POLAR_FILTER_RU_x2z_sub          &
+                ,XPOSE_POLAR_FILTER_MOIST_z2x_sub       &
+                ,XPOSE_POLAR_FILTER_MOIST_x2z_sub       &
+                ,XPOSE_POLAR_FILTER_CHEM_z2x_sub        &
+                ,XPOSE_POLAR_FILTER_MOIST_x2z_sub       &
+                ,XPOSE_POLAR_FILTER_TRACER_z2x_sub      &
+                ,XPOSE_POLAR_FILTER_TRACER_x2z_sub      &
+                ,XPOSE_POLAR_FILTER_SCALAR_z2x_sub      &
+                ,XPOSE_POLAR_FILTER_SCALAR_x2z_sub
+#endif
+#else
+   USE module_dm
+#endif
+   IMPLICIT NONE
+   !  Input data.
+   TYPE(domain) , TARGET          :: grid
+integer, intent(in) :: lineno
+integer myproc, i, j, k
+   LOGICAL, INTENT(IN) :: positive_definite
+   INTEGER, INTENT(IN) :: 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
+   REAL  , INTENT(IN) :: fft_filter_lat
+   REAL,    INTENT(IN) :: dclat
+   INTEGER, INTENT(IN) :: flag_uv                       &
+                         ,flag_rurv                     &
+                         ,flag_ww                       &
+                         ,flag_t,flag_wph               &
+                         ,flag_mu,flag_mut              &
+                         ,flag_moist                    &
+                         ,flag_chem                     &
+                         ,flag_tracer                   &
+                         ,flag_scalar
+    REAL, DIMENSION(ims:ime,kms:kme,jms:jme,*) , INTENT(INOUT) :: moist, chem, scalar,tracer
+
+   ! Local
+   LOGICAL piggyback_mu, piggyback_mut
+   INTEGER ij, k_end
+#ifdef DM_PARALLEL
+#else
+   INTEGER itrace
+#endif
+
+
+   piggyback_mu  = flag_mu .EQ. 1
+   piggyback_mut = flag_mut .EQ. 1
+
+!<DESCRIPTION>
+!
+! The idea is that this parallel transpose fft routine can be
+! called at various points in the solver (solve_em) and it will filter
+! the correct fields based on the flag arguments.  There are two 2d
+! fields mu_2 and mut  that may need to be filtered too. Since a two-d
+! parallel transpose would be inefficient and because the fields that are
+! not staggered in z have an extra layer anyway, these can be
+! piggybacked.  This is handled using latches to makes sure that *somebody*
+! carries one or both of these on their back through the filtering and then
+! copies them back afterwards. IMPORTANT NOTE: for simplicity, this routine
+! is not completely general.  It makes the following assumptions:
+! 
+! 1) If both flag_mu and flag_mut are specified then flag_uv is also specified
+! 
+! 2) If flag_uv is not specified, then only flag_mu and not flag_mut can be
+! 
+! 3) If flag_mu is specified than either flag_uv or flag_t must be
+!
+! This is designed to keep the clutter to a minimum in solve_em. 
+! This is not intended to be a general abstraction of the polar filtering
+! calls in in WRF solvers or if the solve_em algorithms change.
+! If the needs of the calling solver change, this logic may have to be
+! rewritten.
+!
+!</DESCRIPTION>
+!write(0,*)__FILE__,__LINE__,' short circuit '
+!return
+
+!write(0,*)'pxft called from ',lineno
+call wrf_get_myproc(myproc)
+!write(20+myproc,*)ipex-ipsx+1,jpex-jpsx+1,' clat_xxx '
+!do j = jpsx, jpex
+!do i = ipsx, ipex
+!write(20+myproc,*)grid%clat_xxx(i,j)
+!enddo
+!enddo
+
+!!!!!!!!!!!!!!!!!!!!!!!
+! U & V
+   IF ( flag_uv .EQ. 1 ) THEN
+     IF ( piggyback_mu ) THEN
+       grid%u_2(ips:ipe,kde,jps:jpe) = grid%mu_2(ips:ipe,jps:jpe) 
+     ENDIF
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+# include "XPOSE_POLAR_FILTER_V_z2x.inc"
+     CALL polar_filter_3d( grid%v_xxx, grid%clat_xxx, .false.,     &
+                                fft_filter_lat, dclat,                 &
+                                ids, ide, jds, jde, kds, kde-1,         &
+                                imsx, imex, jmsx, jmex, kmsx, kmex,     &
+                                ipsx, ipex, jpsx, jpex, kpsx, MIN(kde-1,kpex ) )
+# include "XPOSE_POLAR_FILTER_V_x2z.inc"
+# include "XPOSE_POLAR_FILTER_U_z2x.inc"
+     k_end = MIN(kde-1,kpex)
+     IF ( piggyback_mu ) k_end = MIN(kde,kpex)
+     CALL polar_filter_3d( grid%u_xxx, grid%clat_xxx, piggyback_mu,     &
+                                fft_filter_lat, 0.,                &
+                                ids, ide, jds, jde, kds, kde,       &
+                                imsx, imex, jmsx, jmex, kmsx, kmex, &
+                                ipsx, ipex, jpsx, jpex, kpsx, k_end )
+# include "XPOSE_POLAR_FILTER_U_x2z.inc"
+#else
+     CALL polar_filter_3d( grid%v_2, grid%clat, .false.,     &
+                                fft_filter_lat, dclat,             &
+                                ids, ide, jds, jde, kds, kde,       &
+                                ims, ime, jms, jme, kms, kme,       &
+                                ips, ipe, jps, jpe, kps, MIN(kde-1,kpe) )
+     k_end = MIN(kde-1,kpe)
+     IF ( piggyback_mu ) k_end = MIN(kde,kpe)
+     CALL polar_filter_3d( grid%u_2, grid%clat, piggyback_mu,     &
+                                fft_filter_lat, 0.,                &
+                                ids, ide, jds, jde, kds, kde-1,     &
+                                ims, ime, jms, jme, kms, kme,       &
+                                ips, ipe, jps, jpe, kps, k_end )
+#endif
+
+     IF ( piggyback_mu ) THEN
+       grid%mu_2(ips:ipe,jps:jpe) = grid%u_2(ips:ipe,kde,jps:jpe)
+       piggyback_mu = .FALSE.
+     ENDIF
+   ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!
+! T
+   IF ( flag_t .EQ. 1 ) THEN
+     IF ( piggyback_mu ) THEN
+       grid%t_2(ips:ipe,kde,jps:jpe) = grid%mu_2(ips:ipe,jps:jpe)
+     ENDIF
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+# include "XPOSE_POLAR_FILTER_T_z2x.inc"
+     k_end = MIN(kde-1,kpex)
+     IF ( piggyback_mu ) k_end = MIN(kde,kpex)
+     CALL polar_filter_3d( grid%t_xxx, grid%clat_xxx,piggyback_mu,     &
+                                fft_filter_lat, 0.,                &
+                                ids, ide, jds, jde, kds, kde-1,     &
+                                imsx, imex, jmsx, jmex, kmsx, kmex, &
+                                ipsx, ipex, jpsx, jpex, kpsx, k_end )
+# include "XPOSE_POLAR_FILTER_T_x2z.inc"
+#else
+     k_end = MIN(kde-1,kpe)
+     IF ( piggyback_mu ) k_end = MIN(kde,kpe)
+     CALL polar_filter_3d( grid%t_2, grid%clat, piggyback_mu,     &
+                                fft_filter_lat, 0.,                &
+                                ids, ide, jds, jde, kds, kde-1,     &
+                                ims, ime, jms, jme, kms, kme,       &
+                                ips, ipe, jps, jpe, kps, k_end )
+#endif
+     IF ( piggyback_mu ) THEN
+       grid%mu_2(ips:ipe,jps:jpe) = grid%t_2(ips:ipe,kde,jps:jpe)
+       piggyback_mu = .FALSE.
+     ENDIF
+   ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!
+! W and PH
+   IF ( flag_wph .EQ. 1 ) THEN
+      ! W AND PH USE ALL LEVELS SO NEVER PIGGYBACK, MU IS OUT OF LUCK HERE
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+# include "XPOSE_POLAR_FILTER_W_z2x.inc"
+      CALL polar_filter_3d( grid%w_xxx, grid%clat_xxx, .false.,     &
+                                 fft_filter_lat, 0.,                &
+                                 ids, ide, jds, jde, kds, kde,       &
+                                 imsx, imex, jmsx, jmex, kmsx, kmex, &
+                                 ipsx, ipex, jpsx, jpex, kpsx, kpex )
+# include "XPOSE_POLAR_FILTER_W_x2z.inc"
+# include "XPOSE_POLAR_FILTER_PH_z2x.inc"
+      CALL polar_filter_3d( grid%ph_xxx, grid%clat_xxx, .false.,     &
+                                 fft_filter_lat, 0.,                &
+                                 ids, ide, jds, jde, kds, kde,       &
+                                 imsx, imex, jmsx, jmex, kmsx, kmex, &
+                                 ipsx, ipex, jpsx, jpex, kpsx, kpex )
+# include "XPOSE_POLAR_FILTER_PH_x2z.inc"
+#else
+      CALL polar_filter_3d( grid%w_2, grid%clat,  .false.,     &
+                                 fft_filter_lat, 0.,                &
+                                 ids, ide, jds, jde, kds, kde,       &
+                                 ims, ime, jms, jme, kms, kme, &
+                                 ips, ipe, jps, jpe, kps, kpe )
+      CALL polar_filter_3d( grid%ph_2, grid%clat, .false.,     &
+                                 fft_filter_lat, 0.,                &
+                                 ids, ide, jds, jde, kds, kde,       &
+                                 ims, ime, jms, jme, kms, kme, &
+                                 ips, ipe, jps, jpe, kps, kpe )
+#endif
+   ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!
+! WW
+   IF ( flag_ww .EQ. 1 ) THEN
+      ! WW USES ALL LEVELS SO NEVER PIGGYBACK, MU IS OUT OF LUCK HERE
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+# include "XPOSE_POLAR_FILTER_WW_z2x.inc"
+      CALL polar_filter_3d( grid%ww_xxx, grid%clat_xxx, .false.,     &
+                                 fft_filter_lat, 0.,                &
+                                 ids, ide, jds, jde, kds, kde,       &
+                                 imsx, imex, jmsx, jmex, kmsx, kmex, &
+                                 ipsx, ipex, jpsx, jpex, kpsx, kpex )
+# include "XPOSE_POLAR_FILTER_WW_x2z.inc"
+#else
+      CALL polar_filter_3d( grid%ww_m, grid%clat, .false.,     &
+                                 fft_filter_lat, 0.,                &
+                                 ids, ide, jds, jde, kds, kde,       &
+                                 ims, ime, jms, jme, kms, kme, &
+                                 ips, ipe, jps, jpe, kps, kpe )
+#endif
+   ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!
+! RU AND RV
+   IF ( flag_rurv .EQ. 1 ) THEN
+     IF ( piggyback_mut ) THEN
+       grid%ru_m(ips:ipe,kde,jps:jpe) = grid%mut(ips:ipe,jps:jpe)
+     ENDIF
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+# include "XPOSE_POLAR_FILTER_RV_z2x.inc"
+     CALL polar_filter_3d( grid%rv_xxx, grid%clat_xxx, .false.,     &
+                                fft_filter_lat, dclat,             &
+                                ids, ide, jds, jde, kds, kde,       &
+                                imsx, imex, jmsx, jmex, kmsx, kmex, &
+                                ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1) )
+# include "XPOSE_POLAR_FILTER_RV_x2z.inc"
+# include "XPOSE_POLAR_FILTER_RU_z2x.inc"
+     k_end = MIN(kde-1,kpex)
+     IF ( piggyback_mut ) k_end = MIN(kde,kpex)
+     CALL polar_filter_3d( grid%ru_xxx, grid%clat_xxx, piggyback_mut,     &
+                                fft_filter_lat, 0.,                &
+                                ids, ide, jds, jde, kds, kde,       &
+                                imsx, imex, jmsx, jmex, kmsx, kmex, &
+                                ipsx, ipex, jpsx, jpex, kpsx, k_end )
+#include "XPOSE_POLAR_FILTER_RU_x2z.inc"
+#else
+     CALL polar_filter_3d( grid%rv_m, grid%clat, .false.,     &
+                                fft_filter_lat, dclat,             &
+                                ids, ide, jds, jde, kds, kde,       &
+                                ims, ime, jms, jme, kms, kme, &
+                                ips, ipe, jps, jpe, kps, MIN(kde-1,kpe) )
+     k_end = MIN(kde-1,kpe)
+     IF ( piggyback_mut ) k_end = MIN(kde,kpe)
+     CALL polar_filter_3d( grid%ru_m, grid%clat, piggyback_mut,     &
+                                fft_filter_lat, 0.,                &
+                                ids, ide, jds, jde, kds, kde-1,       &
+                                ims, ime, jms, jme, kms, kme, &
+                                ips, ipe, jps, jpe, kps, k_end )
+#endif
+     IF ( piggyback_mut ) THEN
+       grid%mut(ips:ipe,jps:jpe) = grid%ru_m(ips:ipe,kde,jps:jpe)
+       piggyback_mut = .FALSE.
+     ENDIF
+   ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!
+! MOIST
+   IF ( flag_moist .GE. PARAM_FIRST_SCALAR ) THEN
+     itrace = flag_moist
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+# include "XPOSE_POLAR_FILTER_MOIST_z2x.inc"
+     CALL polar_filter_3d( grid%fourd_xxx, grid%clat_xxx, .false. ,     &
+                           fft_filter_lat, 0.,                &
+                           ids, ide, jds, jde, kds, kde,       &
+                           imsx, imex, jmsx, jmex, kmsx, kmex, &
+                           ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1), &
+                           positive_definite = positive_definite )
+# include "XPOSE_POLAR_FILTER_MOIST_x2z.inc"
+#else
+     CALL polar_filter_3d( moist(ims,kms,jms,itrace), grid%clat, .false.,     &
+                           fft_filter_lat, 0.,                &
+                           ids, ide, jds, jde, kds, kde,       &
+                           ims, ime, jms, jme, kms, kme, &
+                           ips, ipe, jps, jpe, kps, MIN(kpe,kde-1), &
+                           positive_definite = positive_definite )
+#endif
+   ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!
+! CHEM
+   IF ( flag_chem .GE. PARAM_FIRST_SCALAR ) THEN
+     itrace = flag_chem
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+# include "XPOSE_POLAR_FILTER_CHEM_z2x.inc"
+     CALL polar_filter_3d( grid%fourd_xxx, grid%clat_xxx, .false. ,     &
+                           fft_filter_lat, 0.,                &
+                           ids, ide, jds, jde, kds, kde,       &
+                           imsx, imex, jmsx, jmex, kmsx, kmex, &
+                           ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1), &
+                           positive_definite = positive_definite )
+# include "XPOSE_POLAR_FILTER_CHEM_x2z.inc"
+#else
+     CALL polar_filter_3d( chem(ims,kms,jms,itrace), grid%clat, .false. ,     &
+                           fft_filter_lat, 0.,                &
+                           ids, ide, jds, jde, kds, kde,       &
+                           ims, ime, jms, jme, kms, kme, &
+                           ips, ipe, jps, jpe, kps, MIN(kpe,kde-1), &
+                           positive_definite = positive_definite )
+#endif
+   ENDIF
+
+! tracer
+   IF ( flag_tracer .GE. PARAM_FIRST_SCALAR ) THEN
+     itrace = flag_tracer
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+# include "XPOSE_POLAR_FILTER_TRACER_z2x.inc"
+     CALL polar_filter_3d( grid%fourd_xxx, grid%clat_xxx, .false. ,     &
+                           fft_filter_lat, 0.,                &
+                           ids, ide, jds, jde, kds, kde,       &
+                           imsx, imex, jmsx, jmex, kmsx, kmex, &
+                           ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1), &
+                           positive_definite = positive_definite )
+# include "XPOSE_POLAR_FILTER_TRACER_x2z.inc"
+#else
+     CALL polar_filter_3d( tracer(ims,kms,jms,itrace), grid%clat, .false. ,     &
+                           fft_filter_lat, 0.,                &
+                           ids, ide, jds, jde, kds, kde,       &
+                           ims, ime, jms, jme, kms, kme, &
+                           ips, ipe, jps, jpe, kps, MIN(kpe,kde-1), &
+                           positive_definite = positive_definite )
+#endif
+   ENDIF
+
+!!!!!!!!!!!!!!!!!!!!!!!
+! SCALAR
+   IF ( flag_scalar .GE. PARAM_FIRST_SCALAR ) THEN
+     itrace = flag_scalar
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+# include "XPOSE_POLAR_FILTER_SCALAR_z2x.inc"
+     CALL polar_filter_3d( grid%fourd_xxx , grid%clat_xxx, .false. ,     &
+                           fft_filter_lat, 0.,                &
+                           ids, ide, jds, jde, kds, kde,       &
+                           imsx, imex, jmsx, jmex, kmsx, kmex, &
+                           ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1), &
+                           positive_definite = positive_definite )
+# include "XPOSE_POLAR_FILTER_SCALAR_x2z.inc"
+#else
+     CALL polar_filter_3d( scalar(ims,kms,jms,itrace) , grid%clat, .false. ,     &
+                           fft_filter_lat, 0.,                &
+                           ids, ide, jds, jde, kds, kde,       &
+                           ims, ime, jms, jme, kms, kme, &
+                           ips, ipe, jps, jpe, kps, MIN(kpe,kde-1), &
+                           positive_definite = positive_definite )
+#endif
+   ENDIF
+
+   IF ( flag_mu .EQ. 1 .AND. piggyback_mu ) THEN
+      CALL wrf_error_fatal("mu needed to get piggybacked on a transpose and did not")
+   ENDIF
+   IF ( flag_mut .EQ. 1 .AND. piggyback_mut ) THEN
+      CALL wrf_error_fatal("mut needed to get piggybacked on a transpose and did not")
+   ENDIF
+
+!write(0,*)'pxft back to ',lineno
+   RETURN
+END SUBROUTINE pxft
+
+SUBROUTINE polar_filter_3d( f, xlat, piggyback, fft_filter_lat, dvlat, &
+                            ids, ide, jds, jde, kds, kde,    &
+                            ims, ime, jms, jme, kms, kme,    &
+                            its, ite, jts, jte, kts, kte,    &
+                            positive_definite               )
+
+  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   ) :: fft_filter_lat
+
+  REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(INOUT) ::  f
+  REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) ::  xlat
+  REAL , INTENT(IN) ::  dvlat
+  LOGICAL , INTENT(IN), OPTIONAL :: positive_definite
+  LOGICAL , INTENT(IN) :: piggyback
+
+  REAL , DIMENSION(1:ide-ids,1:kte-kts+1) :: sheet
+  REAL , DIMENSION(1:kte-kts+1) :: sheet_total
+  REAL :: lat, avg, rnboxw
+  INTEGER :: ig, jg, i, j, j_end, nx, ny, nmax, kw
+  INTEGER :: k, nboxw, nbox2, istart, iend, overlap
+  INTEGER, DIMENSION(6) :: wavenumber = (/ 1, 3, 7, 10, 13, 16 /)
+
+  ! Variables will stay in domain form since this routine is meaningless
+  ! unless tile extent is the same as domain extent in E/W direction, i.e.,
+  ! the processor has access to all grid points in E/W direction.
+  ! There may be other ways of doing FFTs, but we haven't learned them yet...
+
+  ! Check to make sure we have full access to all E/W points
+  IF ((its /= ids) .OR. (ite /= ide)) THEN
+     WRITE ( wrf_err_message , * ) 'module_polarfft: 3d: (its /= ids) or (ite /= ide)',its,ids,ite,ide
+     CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
+  END IF
+
+
+  nx = ide-ids ! "U" stagger variables will be repeated by periodic BCs
+  ny = kte-kts+1 ! we can filter extra level for variables that are non-Z-staggered
+  lat = 0.
+  j_end = MIN(jte, jde-1)
+  IF (dvlat /= 0. .and. j_end == jde-1) j_end = jde
+  DO j = jts, j_end
+     ! jg is the J index in the global (domain) span of the array.
+     jg = j-jds+1
+
+     ! determine whether or not to filter the data
+
+     lat = xlat(ids,j)-dvlat
+     IF (abs(lat) >= fft_filter_lat) THEN
+        DO k=kts,kte
+        DO i=ids,ide-1
+           sheet(i-ids+1,k-kts+1) = f(i,k,j)
+        END DO
+        END DO
+
+        CALL polar_filter_fft_2d_ncar(nx,ny,sheet,lat,fft_filter_lat,piggyback)
+
+        DO k=kts,kte
+           DO i=ids,ide-1
+              f(i,k,j) = sheet(i-ids+1,k-kts+1)
+           END DO
+           ! setting up ims-ime with x periodicity:
+           ! enforce periodicity as in set_physical_bc3d
+           DO i=1,ids-ims
+              f(ids-i,k,j)=f(ide-i,k,j)
+           END DO
+           DO i=1,ime-ide+1
+              f(ide+i-1,k,j)=f(ids+i-1,k,j)
+           END DO
+        END DO
+     END IF
+  END DO ! outer j (latitude) loop
+
+END SUBROUTINE polar_filter_3d
+
+!------------------------------------------------------------------------------
+
+SUBROUTINE polar_filter_fft_2d_ncar(nx,ny,fin,lat,filter_latitude,piggyback)
+  IMPLICIT NONE
+  INTEGER , INTENT(IN) :: nx, ny
+  REAL , DIMENSION(nx,ny), INTENT(INOUT) :: fin
+  REAL , INTENT(IN) :: lat, filter_latitude
+  LOGICAL, INTENT(IN) :: piggyback
+
+  REAL :: pi, rcosref, freq, c, cf
+  INTEGER :: i, j
+  REAL, dimension(nx,ny) :: fp
+
+  INTEGER :: lensave, ier, nh, n1
+  INTEGER :: lot, jump, n, inc, lenr, lensav, lenwrk
+  REAL, DIMENSION(nx+15) :: wsave
+  REAL, DIMENSION(nx,ny) :: work
+  REAL, PARAMETER :: alpha = 0.0
+  REAL :: factor_k
+
+  INTEGER :: ntop
+
+  pi = ACOS(-1.)
+  rcosref = 1./COS(filter_latitude*pi/180.)
+
+!  we are following the naming convention of the fftpack5 routines
+
+  n = nx
+  lot = ny
+  lensav = n+15
+  inc = 1
+  lenr = nx*ny
+  jump = nx
+  lenwrk = lenr
+  ntop = ny
+  IF(piggyback) ntop = ny-1
+
+!  forward transform
+!  initialize coefficients, place in wsave 
+!   (should place this in init and save wsave at program start)
+
+  call rfftmi(n,wsave,lensav,ier)
+  IF(ier /= 0) THEN
+    write(0,*) ' error in rfftmi ',ier
+  END IF
+
+!  do the forward transform
+
+  call rfftmf( lot, jump, n, inc, fin, lenr, wsave, lensav, work, lenwrk, ier )
+  IF(ier /= 0) THEN
+    write(0,*) ' error in rfftmf ',ier
+  END IF
+
+  if(MOD(n,2) == 0) then
+    nh = n/2 - 1
+  else
+    nh = (n-1)/2
+  end if
+
+  DO j=1,ny
+   fp(1,j) = 1.
+  ENDDO
+
+  DO i=2,nh+1
+    freq=REAL(i-1)/REAL(n)
+    c = (rcosref*COS(lat*pi/180.)/SIN(freq*pi))**2
+!    c = MAX(0.,MIN(1.,c))
+    do j=1,ntop
+      factor_k = (1.-alpha)+alpha*min(1.,float(ntop - j)/10.)
+      cf = c*factor_k*factor_k
+      cf = MAX(0.,MIN(1.,cf))
+      fp(2*(i-1),j) = cf
+      fp(2*(i-1)+1,j) = cf
+    enddo
+    if(piggyback) then
+      cf = MAX(0.,MIN(1.,c))
+      fp(2*(i-1),ny) = cf
+      fp(2*(i-1)+1,ny) = cf
+    endif
+  END DO
+
+  IF(MOD(n,2) == 0) THEN
+    c = (rcosref*COS(lat*pi/180.))**2
+!    c = MAX(0.,MIN(1.,c))
+    do j=1,ntop
+      factor_k = (1.-alpha)+alpha*min(1.,float(ntop - j)/10.)
+      cf = c*factor_k*factor_k
+      cf = MAX(0.,MIN(1.,cf))
+      fp(n,j) = cf
+    enddo
+    if(piggyback) then
+      cf = MAX(0.,MIN(1.,c))
+      fp(n,ny) = cf
+    endif
+  END IF
+
+  DO j=1,ny
+    DO i=1,nx
+      fin(i,j) = fp(i,j)*fin(i,j)
+    ENDDO
+  ENDDO
+
+!  do the backward transform
+
+  call rfftmb( lot, jump, n, inc, fin, lenr, wsave, lensav, work, lenwrk, ier )
+  IF(ier /= 0) THEN
+    write(0,*) ' error in rfftmb ',ier
+  END IF
+
+END SUBROUTINE polar_filter_fft_2d_ncar
+
+!------------------------------------------------------------------------------
+
+END MODULE module_polarfft
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_positive_definite.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_positive_definite.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_positive_definite.F	(revision 17)
@@ -0,0 +1,124 @@
+MODULE module_positive_definite
+
+  USE module_wrf_error      ! frame
+
+CONTAINS
+
+SUBROUTINE positive_definite_slab( f,                            &
+                                   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
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: f
+
+  ! Local variables
+  REAL, DIMENSION(:), ALLOCATABLE :: line
+  INTEGER :: j, k, i_end, j_end, k_end
+  REAL :: fmin, ftotal_pre, rftotal_post
+
+  ! Initialize variables
+  i_end = ide-1
+  j_end = MIN(jte, jde-1)
+  k_end = kte-1
+  ! Only do anything if we have to...
+  IF (ANY(f(ids:i_end,kts:k_end,jts:j_end) < 0.)) THEN
+     ! number of points in the X direction, not including U-stagger
+     ALLOCATE(line(ide-ids))
+     DO j = jts, j_end
+     DO k = kts, kte-1
+        !while_lt_0_loop: DO WHILE (ANY(f(ids:i_end,k,j) < 0.))
+        f_lt_0: IF (ANY(f(ids:i_end,k,j) < 0.)) THEN
+           line(:) = f(ids:i_end,k,j)
+           ! This is actually an integration over x assuming dx is constant
+           ftotal_pre = SUM(line)
+           ! If the total is negative, set everything to 0. and exit
+           IF (ftotal_pre < 0.) THEN
+              line(:) = 0.
+           ELSE
+              ! Value to add to array to make sure every element is > 0.
+              fmin = MINVAL(line)
+              line(:) = line(:) - fmin ! fmin is negative...
+              rftotal_post = 1./SUM(line)
+              line = line*ftotal_pre*rftotal_post
+              ! The following error can naturally occur on 32-bit machines:
+              !IF (SUM(line) /= ftotal_pre) THEN
+              !   write(wrf_err_message,*) 'ERROR: module_positive_definite, ',&
+              !                            'mismatching sums ',j,k,ftotal_pre,&
+              !                            SUM(line),fmin,1./rftotal_post
+              !   write(*,*) line
+              !   CALL wrf_error_fatal( wrf_err_message )
+              !END IF
+           END IF
+           f(ids:i_end,k,j) = line(:)
+        END IF f_lt_0
+        !END DO while_lt_0_loop
+     END DO
+     END DO
+     DEALLOCATE(line)
+  END IF
+
+END SUBROUTINE positive_definite_slab
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE positive_definite_sheet( f, f_total, nx, ny )
+
+  IMPLICIT NONE
+
+  ! Arguments
+  INTEGER, INTENT(IN   ) :: nx, ny
+  REAL, DIMENSION( nx, ny ), INTENT(INOUT) :: f
+  REAL, DIMENSION( ny ), INTENT(IN) :: f_total
+
+  ! Local variables
+  REAL, DIMENSION(:), ALLOCATABLE :: line
+  INTEGER :: iy
+  REAL :: fmin, rftotal_post, sum_line
+  REAL, PARAMETER :: eps = 1.0e-15
+
+  ! Only do anything if we have to...
+  IF (ANY(f < 0.)) THEN
+     ALLOCATE(line(nx))
+     DO iy = 1, ny
+        !while_lt_0_loop: DO WHILE (ANY(f(:,iy) < 0.))
+        f_lt_0: IF (ANY(f(:,iy) < 0.)) THEN
+           line(:) = f(:,iy)
+           ! If the total is negative, set everything to 0. and exit
+           IF (f_total(iy) < 0.) THEN
+              line(:) = 0.
+           ELSE
+              ! Value to add to array to make sure every element is > 0.
+              fmin = MINVAL(line)
+              line(:) = line(:) - fmin ! fmin is negative...
+              sum_line = SUM(line)
+              IF(sum_line > eps) THEN
+                rftotal_post = 1./sum_line
+                line = line*f_total(iy)*rftotal_post
+              ELSE
+                line(:) = 0.
+              END IF
+              ! The following error can naturally occur on 32-bit machines:
+              !IF (SUM(line) /= f_total(iy)) THEN
+              !   write(wrf_err_message,*) 'ERROR: module_positive_definite, ',&
+              !                            'mismatching sums ',iy,f_total(iy),  &
+              !                            SUM(line),fmin,1./rftotal_post
+              !   write(*,*) line
+              !   CALL wrf_error_fatal( wrf_err_message )
+              !END IF
+           END IF
+           f(:,iy) = line(:)
+        END IF f_lt_0
+        !END DO while_lt_0_loop
+     END DO
+     DEALLOCATE(line)
+  END IF
+
+END SUBROUTINE positive_definite_sheet
+
+END MODULE module_positive_definite
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_sfs_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_sfs_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_sfs_driver.F	(revision 17)
@@ -0,0 +1,442 @@
+!WRF:MEDIATION_LAYER:PHYSICS
+
+!==============================================================================
+!
+! © 2009. Lawrence Livermore National Security, LLC. All rights reserved.
+! This work was produced at the Lawrence Livermore National Laboratory (LLNL) under
+! contract no. DE-AC52-07NA27344 (Contract 44) between the U.S. Department of Energy (DOE)
+! and Lawrence Livermore National Security, LLC (LLNS) for the operation of LLNL. Copyright
+! is reserved to Lawrence Livermore National Security, LLC for purposes of controlled
+! dissemination, commercialization through formal licensing, or other disposition under
+! terms of Contract 44; DOE policies, regulations and orders; and U.S. statutes. The rights
+! of the Federal Government are reserved under Contract 44.
+!
+! DISCLAIMER
+! This work was prepared as an account of work sponsored by an agency of the United States
+! Government. Neither the United States Government nor Lawrence Livermore National
+! Security, LLC nor any of their employees, makes any warranty, express or implied, or
+! assumes any 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. Reference herein to any specific commercial
+! products, process, or service by trade name, trademark, manufacturer or otherwise does
+! not necessarily constitute or imply its endorsement, recommendation, or favoring by the
+! United States Government or Lawrence Livermore National Security, LLC. The views and
+! opinions of authors expressed herein do not necessarily state or reflect those of the
+! United States Government or Lawrence Livermore National Security, LLC, and shall not be
+! used for advertising or product endorsement purposes.
+!
+! LICENSING REQUIREMENTS
+! Any use, reproduction, modification, or distribution of this software or documentation
+! for commercial purposes requires a license from Lawrence Livermore National Security,
+! LLC. Contact: Lawrence Livermore National Laboratory, Industrial Partnerships Office,
+! P.O. Box 808, L-795, Livermore, CA 94551
+!
+!=============================================================================
+!
+! Modification History: 
+!
+! Implemented 12/2009 by Jeff Mirocha, jmirocha@llnl.gov
+!
+!=============================================================================
+
+MODULE module_sfs_driver
+
+CONTAINS
+
+!=============================================================================
+
+SUBROUTINE sfs_driver( grid, config_flags, &
+                       nba_mij, n_nba_mij, & 
+                       nba_rij, n_nba_rij  )
+
+!-----------------------------------------------------------------------------
+!
+! PURPOSE: Calls turbulence subfilter stress model subroutines and handles
+!          all MPI and OMP operations
+!
+!-----------------------------------------------------------------------------
+
+
+! Driver layer modules
+  USE module_domain
+  USE module_configure
+  USE module_tiles
+  USE module_machine
+  USE module_state_description
+! Model layer modules
+  USE module_bc
+
+!! *** add new modules of schemes here
+
+  USE module_sfs_nba
+#ifdef DM_PARALLEL
+   USE module_dm
+   USE module_comm_dm, ONLY : &
+                           HALO_EM_NBA_RIJ_sub   &
+                          ,PERIOD_EM_NBA_RIJ_sub   &
+                          ,HALO_EM_NBA_MIJ_sub   &
+                          ,PERIOD_EM_NBA_MIJ_sub
+#endif
+
+  IMPLICIT NONE
+
+! Input data.
+
+  TYPE(domain) , TARGET          :: grid
+
+  TYPE (grid_config_rec_type) , INTENT(IN)          :: config_flags
+
+  INTEGER, INTENT(  IN ) :: n_nba_mij, n_nba_rij
+
+  REAL ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,n_nba_mij) &
+  :: nba_mij
+
+  REAL ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,n_nba_rij) &
+  :: nba_rij
+
+! 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 :: 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, i, j, k
+
+  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  )
+
+  k_start         = kps
+  k_end           = 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 )
+
+  IF ( (config_flags%sfs_opt .EQ. 1) .OR. (config_flags%sfs_opt .EQ. 2) ) THEN
+
+!=======================================================================
+!
+!                                BEGIN NBA
+!
+!=======================================================================
+      
+!  IF ( grid%itimestep .EQ. 1 ) THEN
+!         
+!    IF ( (config_flags%sfs_opt .EQ. 2) .AND. (config_flags%km_opt .NE. 2)) THEN
+!  
+!    CALL wrf_error_fatal( 'Must use km_opt=2 with sfs_opt=2' )
+!    
+!    ENDIF
+!
+!  ENDIF
+
+!_______________________________________________________________________
+!
+! Compute NBA model constants
+!_______________________________________________________________________
+
+
+    !$OMP PARALLEL DO   &
+    !$OMP PRIVATE ( ij )
+    DO ij = 1 , grid%num_tiles !---------------------------------------- 
+
+        CALL calc_mij_constants( )
+
+    ENDDO !-------------------------------------------------------------
+    !$OMP END PARALLEL DO
+
+!_______________________________________________________________________
+!
+! Compute Smn*Smn
+!_______________________________________________________________________
+
+    !$OMP PARALLEL DO   &
+    !$OMP PRIVATE ( ij )
+    DO ij = 1 , grid%num_tiles !---------------------------------------- 
+
+        CALL calc_smnsmn( nba_rij(ims,kms,jms,P_smnsmn),    &
+                          grid%defor11, grid%defor22,       &
+                          grid%defor33, grid%defor12,       &
+                          grid%defor13, grid%defor23,       &
+                          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 !-------------------------------------------------------------
+    !$OMP END PARALLEL DO
+
+!_______________________________________________________________________
+!
+! Update halos for R12, R13, R23 and smnsmn
+!_______________________________________________________________________
+
+#ifdef DM_PARALLEL
+#      include "HALO_EM_NBA_RIJ.inc"
+#      include "PERIOD_EM_NBA_RIJ.inc"
+#endif
+
+    !$OMP PARALLEL DO   &
+    !$OMP PRIVATE ( ij )
+    DO ij = 1 , grid%num_tiles !----------------------------------------
+
+        CALL set_physical_bc3d( nba_rij(ims,kms,jms,P_r12), 'd',  &
+                                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( nba_rij(ims,kms,jms,P_r13), 'e',  &
+                                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( nba_rij(ims,kms,jms,P_r23), 'f',  &
+                                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( nba_rij(ims,kms,jms,P_smnsmn), 'c', &
+                                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 !-------------------------------------------------------------
+    !$OMP END PARALLEL DO
+
+!_______________________________________________________________________
+!
+! Calculate M11, M22 and M33
+!_______________________________________________________________________
+
+    !$OMP PARALLEL DO   &
+    !$OMP PRIVATE ( ij )
+    DO ij = 1 , grid%num_tiles !----------------------------------------
+
+      CALL calc_mii( nba_mij(ims,kms,jms,P_m11),       &
+                     nba_mij(ims,kms,jms,P_m22),       &
+                     nba_mij(ims,kms,jms,P_m33),       &
+                     grid%defor11, grid%defor22,       &
+                     grid%defor33, grid%defor12,       &
+                     grid%defor13, grid%defor23,       &
+                     nba_rij(ims,kms,jms,P_r12),       &
+                     nba_rij(ims,kms,jms,P_r13),       &
+                     nba_rij(ims,kms,jms,P_r23),       &
+                     nba_rij(ims,kms,jms,P_smnsmn),    &
+                     grid%tke_2,                       & 
+                     grid%rdzw, grid%dx, grid%dy,      &
+                     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 !-------------------------------------------------------------
+    !$OMP END PARALLEL DO
+
+!_______________________________________________________________________
+!
+! Calculate M12
+!_______________________________________________________________________
+
+    !$OMP PARALLEL DO   &
+    !$OMP PRIVATE ( ij )
+    DO ij = 1 , grid%num_tiles !----------------------------------------
+
+      CALL calc_m12( nba_mij(ims,kms,jms,P_m12),       &
+                     grid%defor11, grid%defor22,       &
+                     grid%defor12, grid%defor13,       &
+                     grid%defor23,                     &
+                     nba_rij(ims,kms,jms,P_r12),       &
+                     nba_rij(ims,kms,jms,P_r13),       &
+                     nba_rij(ims,kms,jms,P_r23),       &
+                     nba_rij(ims,kms,jms,P_smnsmn),    &
+                     grid%tke_2,                       & 
+                     grid%rdzw, grid%dx, grid%dy,      &
+                     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 !-------------------------------------------------------------
+    !$OMP END PARALLEL DO
+
+!_______________________________________________________________________
+!
+! Calculate M13
+!_______________________________________________________________________
+
+    !$OMP PARALLEL DO   &
+    !$OMP PRIVATE ( ij )
+    DO ij = 1 , grid%num_tiles !----------------------------------------
+
+      CALL calc_m13( nba_mij(ims,kms,jms,P_m13),       &
+                     grid%defor11, grid%defor33,       &
+                     grid%defor12, grid%defor13,       &
+                     grid%defor23,                     &
+                     nba_rij(ims,kms,jms,P_r12),       &
+                     nba_rij(ims,kms,jms,P_r13),       &
+                     nba_rij(ims,kms,jms,P_r23),       &
+                     nba_rij(ims,kms,jms,P_smnsmn),    &
+                     grid%tke_2,                       & 
+                     grid%rdzw, grid%dx, grid%dy,      &
+                     grid%fnm, grid%fnp,               &
+                     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 !-------------------------------------------------------------
+    !$OMP END PARALLEL DO
+!_______________________________________________________________________
+!
+! Calculate M23
+!_______________________________________________________________________
+
+    !$OMP PARALLEL DO   &
+    !$OMP PRIVATE ( ij )
+    DO ij = 1 , grid%num_tiles !----------------------------------------
+
+      CALL calc_m23( nba_mij(ims,kms,jms,P_m23),       &
+                     grid%defor22, grid%defor33,       &
+                     grid%defor12, grid%defor13,       &
+                     grid%defor23,                     &
+                     nba_rij(ims,kms,jms,P_r12),       &
+                     nba_rij(ims,kms,jms,P_r13),       &
+                     nba_rij(ims,kms,jms,P_r23),       &
+                     nba_rij(ims,kms,jms,P_smnsmn),    &
+                     grid%tke_2,                       & 
+                     grid%rdzw, grid%dx, grid%dy,      &
+                     grid%fnm, grid%fnp,               &
+                     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 !-------------------------------------------------------------
+    !$OMP END PARALLEL DO
+!_______________________________________________________________________
+!
+! Update boundary conditions and halos after calculating Mij
+!_______________________________________________________________________
+
+#ifdef DM_PARALLEL
+#      include "HALO_EM_NBA_MIJ.inc"
+#      include "PERIOD_EM_NBA_MIJ.inc"
+#endif
+
+    !$OMP PARALLEL DO   &
+    !$OMP PRIVATE ( ij )
+    DO ij = 1 , grid%num_tiles !----------------------------------------
+
+      CALL set_physical_bc3d( nba_mij(ims,kms,jms,P_m11), '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( nba_mij(ims,kms,jms,P_m22), '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( nba_mij(ims,kms,jms,P_m33), '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( nba_mij(ims,kms,jms,P_m12), 'd',    &
+                              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( nba_mij(ims,kms,jms,P_m13), 'e',    &
+                              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( nba_mij(ims,kms,jms,P_m23), 'f',    &
+                              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 !-------------------------------------------------------------
+    !$OMP END PARALLEL DO
+
+!=======================================================================
+!
+!                                END NBA
+!
+!=======================================================================
+
+  ENDIF !(config_flags%sfs_opt .EQ. 1) .OR. (config_flags%sfs_opt .EQ. 2)
+
+END SUBROUTINE sfs_driver
+
+END MODULE module_sfs_driver
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_sfs_nba.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_sfs_nba.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_sfs_nba.F	(revision 17)
@@ -0,0 +1,1229 @@
+!WRF:MODEL_LAYER:PHYSICS
+
+!==============================================================================
+!
+! © 2009. Lawrence Livermore National Security, LLC. All rights reserved.
+! This work was produced at the Lawrence Livermore National Laboratory (LLNL) under
+! contract no. DE-AC52-07NA27344 (Contract 44) between the U.S. Department of Energy (DOE)
+! and Lawrence Livermore National Security, LLC (LLNS) for the operation of LLNL. Copyright
+! is reserved to Lawrence Livermore National Security, LLC for purposes of controlled
+! dissemination, commercialization through formal licensing, or other disposition under
+! terms of Contract 44; DOE policies, regulations and orders; and U.S. statutes. The rights
+! of the Federal Government are reserved under Contract 44.
+!
+! DISCLAIMER
+! This work was prepared as an account of work sponsored by an agency of the United States
+! Government. Neither the United States Government nor Lawrence Livermore National
+! Security, LLC nor any of their employees, makes any warranty, express or implied, or
+! assumes any 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. Reference herein to any specific commercial
+! products, process, or service by trade name, trademark, manufacturer or otherwise does
+! not necessarily constitute or imply its endorsement, recommendation, or favoring by the
+! United States Government or Lawrence Livermore National Security, LLC. The views and
+! opinions of authors expressed herein do not necessarily state or reflect those of the
+! United States Government or Lawrence Livermore National Security, LLC, and shall not be
+! used for advertising or product endorsement purposes.
+!
+! LICENSING REQUIREMENTS
+! Any use, reproduction, modification, or distribution of this software or documentation
+! for commercial purposes requires a license from Lawrence Livermore National Security,
+! LLC. Contact: Lawrence Livermore National Laboratory, Industrial Partnerships Office,
+! P.O. Box 808, L-795, Livermore, CA 94551
+!
+!=============================================================================
+!
+! Modification History: 
+!
+! Implemented 12/2009 by Jeff Mirocha, jmirocha@llnl.gov
+!
+!=============================================================================
+
+MODULE module_sfs_nba
+
+  USE module_configure, ONLY : grid_config_rec_type
+
+  IMPLICIT NONE
+
+  REAL :: c1, c2, c3, ce, cb, cs ! global model parameters           
+
+CONTAINS
+
+!=============================================================================
+
+SUBROUTINE calc_mij_constants( )
+
+!-----------------------------------------------------------------------------
+!
+! PURPOSE: Compute constants for Mij calculations 
+!
+!-----------------------------------------------------------------------------
+
+  IMPLICIT NONE
+
+  REAL :: sk, pi ! local model parameters           
+
+!-----------------------------------------------------------------------------
+
+  sk = 0.5
+  pi = 3.1415927
+  cb = 0.36
+
+  cs = ( ( 8.0*( 1.0+cb ) )/( 27.0*pi**2 ) )**0.5
+  c1 = ( ( 960.0**0.5 )*cb )/( 7.0*( 1.0+cb )*sk )
+  c2 = c1
+  ce = ( ( 8.0*pi/27.0 )**( 1.0/3.0 ) )*cs**( 4.0/3.0 )
+  c3 = ( ( 27.0/( 8.0*pi ) )**( 1.0/3.0 ) )*cs**( 2.0/3.0 )
+
+  RETURN
+
+END SUBROUTINE calc_mij_constants
+
+!=============================================================================
+
+SUBROUTINE calc_smnsmn( smnsmn,                       &                
+                        s11, s22, s33,                &
+                        s12, s13, s23,                &
+                        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  )
+
+!-----------------------------------------------------------------------------
+!
+! PURPOSE: Compute Smn*Smn = S11^2 + S22^2 + S33^2 + 2*(S12^2 + S13^2 +S23^2) 
+!
+!-----------------------------------------------------------------------------
+
+  IMPLICIT NONE
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( OUT ) &
+  :: smnsmn        ! Smn*Smn                             (s-2)
+ 
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( IN  ) &
+  :: s11         & ! 2*deformation element 11            (s-1)
+   , s22         & ! 2*deformation element 22            (s-1)
+   , s33         & ! 2*deformation element 33            (s-1)
+   , s12         & ! 2*deformation element 12            (s-1)
+   , s13         & ! 2*deformation element 13            (s-1)
+   , s23           ! 2*deformation element 23            (s-1)
+
+  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
+
+! LOCAL VARIABLES ------------------------------------------------------------
+             
+  REAL :: tmp
+
+  INTEGER :: i, j, k, i_start, i_end, j_start, j_end, ktf
+
+!-----------------------------------------------------------------------------
+!
+! Set loop limits,
+! taken from /dyn_em/module_diffusion_em.F SUBROUTINE smag_km   
+!
+!-----------------------------------------------------------------------------
+   
+  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 )
+
+!-----------------------------------------------------------------------------
+
+! Below the 0.25 factor divides the incoming WRF deformations, 
+! which are multiplied by a factor of 2, by 2
+
+  DO j=j_start,j_end
+  DO k=kts,ktf
+  DO i=i_start,i_end
+
+    smnsmn(i,k,j) = 0.25*( s11(i,k,j)*s11(i,k,j) + &
+                           s22(i,k,j)*s22(i,k,j) + &
+                           s33(i,k,j)*s33(i,k,j) )
+
+  END DO
+  END DO
+  END DO
+
+! Below the 0.125 factor accounts for the four-point averaging (0.25)
+! and divides the incoming WRF deformation elements by 2 (0.5) 
+
+  DO j=j_start,j_end
+  DO k=kts,ktf
+  DO i=i_start,i_end
+
+    tmp = 0.125*( s12(i  ,k,j) + s12(i  ,k,j+1) + &
+                  s12(i+1,k,j) + s12(i+1,k,j+1) )
+    smnsmn(i,k,j) = smnsmn(i,k,j) + 2.0*tmp*tmp
+
+  END DO
+  END DO
+  END DO
+
+  DO j=j_start,j_end
+  DO k=kts,ktf
+  DO i=i_start,i_end
+
+    tmp = 0.125*( s13(i  ,k+1,j) + s13(i  ,k,j) + &
+                  s13(i+1,k+1,j) + s13(i+1,k,j) )
+    smnsmn(i,k,j) = smnsmn(i,k,j) + 2.0*tmp*tmp
+
+  END DO
+  END DO
+  END DO
+
+  DO j=j_start,j_end
+  DO k=kts,ktf
+  DO i=i_start,i_end
+
+    tmp = 0.125*( s23(i,k+1,j  ) + s23(i,k,j  ) + &
+                  s23(i,k+1,j+1) + s23(i,k,j+1) )
+    smnsmn(i,k,j) = smnsmn(i,k,j) + 2.0*tmp*tmp
+  
+  END DO
+  END DO
+  END DO
+
+  RETURN
+
+END SUBROUTINE calc_smnsmn
+
+!=============================================================================
+
+SUBROUTINE calc_mii( m11, m22, m33,                &
+                     s11, s22, s33,                &
+                     s12, s13, s23,                &
+                     r12, r13, r23, smnsmn,        &
+                     tke, rdzw, dx, dy,            &
+                     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  )
+
+!-----------------------------------------------------------------------------
+!
+! PURPOSE: Compute Mij for i = j
+!
+!-----------------------------------------------------------------------------
+
+  IMPLICIT NONE
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( OUT ) &
+  :: m11         & ! NBA stress element 11               (m2 s-2)
+   , m22         & ! NBA stress element 22               (m2 s-2)
+   , m33           ! NBA stress element 33               (m2 s-2)
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( IN  ) &
+  :: s11         & ! 2*deformation element 11            (s-1)
+   , s22         & ! 2*deformation element 22            (s-1)
+   , s33         & ! 2*deformation element 33            (s-1)
+   , s12         & ! 2*deformation element 12            (s-1)
+   , s13         & ! 2*deformation element 13            (s-1)
+   , s23         & ! 2*deformation element 23            (s-1)
+   , r12         & ! 2*rotation element 12               (s-1)
+   , r13         & ! 2*rotation element 13               (s-1)
+   , r23         & ! 2*rotation element 23               (s-1)
+   , smnsmn      & ! Smn*Smn                             (s-2)
+   , tke         & ! tke                                 (m2 s-2)
+   , rdzw          ! 1/dz at w-levels                    (m-1)
+
+  REAL,                                                  INTENT( IN  ) &
+  :: dx          & ! grid spacing in x                   (m)
+   , dy            ! grid spacing in y                   (m) 
+
+  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
+
+! LOCAL VARIABLES ------------------------------------------------------------
+
+  REAL, DIMENSION( its-1:ite+1, kms:kme, jts-1:jte+1 ) & ! sij/2, rij/2
+  :: ss11        & 
+   , ss22        & 
+   , ss33        & 
+   , ss12        & 
+   , ss13        & 
+   , ss23        &          
+   , rr12        & 
+   , rr13        & 
+   , rr23  
+
+  REAL, DIMENSION( its-1:ite+1, kms:kme, jts-1:jte+1 ) & ! projected to c
+  :: ss12c       & 
+   , rr12c       & 
+   , ss13c       & 
+   , rr13c       & 
+   , ss23c       & 
+   , rr23c    
+
+  REAL :: delta, a, b
+
+  INTEGER :: i, j, k, i_start, i_end, j_start, j_end, ktf, is_ext, js_ext
+
+!-----------------------------------------------------------------------------
+!
+! Set loop limits,
+! taken from /dyn_em/module_diffusion_em.F SUBROUTINE cal_titau_11_22_33
+!
+!-----------------------------------------------------------------------------
+
+  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
+
+  is_ext = 1
+  js_ext = 1
+
+  i_start = i_start - is_ext  
+  j_start = j_start - js_ext   
+
+!-----------------------------------------------------------------------------
+!
+! Divide WRF deformations, which are multiplied by 2, by 2
+!
+!-----------------------------------------------------------------------------
+
+  DO j=j_start,j_end+1
+  DO k=kts,ktf
+  DO i=i_start,i_end+1
+
+    ss11(i,k,j)=s11(i,k,j)/2.0
+    ss22(i,k,j)=s22(i,k,j)/2.0
+    ss33(i,k,j)=s33(i,k,j)/2.0
+    ss12(i,k,j)=s12(i,k,j)/2.0
+    ss13(i,k,j)=s13(i,k,j)/2.0
+    ss23(i,k,j)=s23(i,k,j)/2.0
+    rr12(i,k,j)=r12(i,k,j)/2.0
+    rr13(i,k,j)=r13(i,k,j)/2.0
+    rr23(i,k,j)=r23(i,k,j)/2.0
+
+  END DO
+  END DO
+  END DO
+
+  DO j=j_start,j_end+1
+  DO i=i_start,i_end+1
+
+    ss13(i,kde,j) = 0.0
+    ss23(i,kde,j) = 0.0
+    rr13(i,kde,j) = 0.0
+    rr23(i,kde,j) = 0.0
+
+  END DO
+  END DO
+
+!-----------------------------------------------------------------------------
+!
+! Project variables to c
+!
+!-----------------------------------------------------------------------------
+
+  DO j = j_start, j_end
+  DO k = kts, ktf
+  DO i = i_start, i_end
+
+    ss12c(i,k,j) = 0.25*( ss12(i  ,k  ,j  ) + ss12(i  ,k  ,j+1) + &
+                          ss12(i+1,k  ,j  ) + ss12(i+1,k  ,j+1) )
+
+    rr12c(i,k,j) = 0.25*( rr12(i  ,k  ,j  ) + rr12(i  ,k  ,j+1) + &
+                          rr12(i+1,k  ,j  ) + rr12(i+1,k  ,j+1) )
+
+    ss13c(i,k,j) = 0.25*( ss13(i  ,k+1,j  ) + ss13(i  ,k  ,j  ) + &
+                          ss13(i+1,k+1,j  ) + ss13(i+1,k  ,j  ) )
+
+    rr13c(i,k,j) = 0.25*( rr13(i  ,k+1,j  ) + rr13(i  ,k  ,j  ) + &
+                          rr13(i+1,k+1,j  ) + rr13(i+1,k  ,j  ) )
+
+    ss23c(i,k,j) = 0.25*( ss23(i  ,k+1,j  ) + ss23(i  ,k  ,j  ) + &
+                          ss23(i  ,k+1,j+1) + ss23(i  ,k  ,j+1) )
+
+    rr23c(i,k,j) = 0.25*( rr23(i  ,k+1,j  ) + rr23(i  ,k  ,j  ) + &
+                          rr23(i  ,k+1,j+1) + rr23(i  ,k  ,j+1) )
+
+  ENDDO
+  ENDDO
+  ENDDO
+
+!-----------------------------------------------------------------------------
+!
+! Calculate M11, M22 and M33
+!
+!-----------------------------------------------------------------------------
+
+  IF ( config_flags%sfs_opt .EQ. 1 ) THEN !Do not use TKE
+
+    DO j=j_start,j_end
+    DO k=kts,ktf
+    DO i=i_start,i_end
+
+      delta = ( dx * dy / rdzw(i,k,j) )**0.33333333
+      a = -1.0*( cs*delta )**2
+
+      m11(i,k,j) = a*(   2.0*sqrt( 2.0*smnsmn(i,k,j) )*ss11(i,k,j) &
+                       + c1*(   ss11(i,k,j) *ss11(i,k,j)           &
+                              + ss12c(i,k,j)*ss12c(i,k,j)          &
+                              + ss13c(i,k,j)*ss13c(i,k,j)          &
+                              - smnsmn(i,k,j)/3.0                  &
+                            )                                      &
+                       + c2*( -2.0*(   ss12c(i,k,j)*rr12c(i,k,j)   &
+                                     + ss13c(i,k,j)*rr13c(i,k,j)   &
+                                   )                               &
+                            )                                      &
+                     )
+
+      m22(i,k,j) = a*(   2.0*sqrt( 2.0*smnsmn(i,k,j) )*ss22(i,k,j) &
+                       + c1*(   ss22(i,k,j) *ss22(i,k,j)           &
+                              + ss12c(i,k,j)*ss12c(i,k,j)          &
+                              + ss23c(i,k,j)*ss23c(i,k,j)          &
+                              - smnsmn(i,k,j)/3.0                  &
+                            )                                      &
+                       + c2*(  2.0*(   ss12c(i,k,j)*rr12c(i,k,j)   &
+                                     - ss23c(i,k,j)*rr23c(i,k,j)   &
+                                   )                               &
+                            )                                      &
+                     )
+
+      m33(i,k,j) = a*(   2.0*sqrt( 2.0*smnsmn(i,k,j) )*ss33(i,k,j) &
+                       + c1*(   ss33(i,k,j) *ss33(i,k,j)            &
+                              + ss13c(i,k,j)*ss13c(i,k,j)          &
+                              + ss23c(i,k,j)*ss23c(i,k,j)          &
+                              - smnsmn(i,k,j)/3.0                  &
+                            )                                      &
+                       + c2*(  2.0*(   ss13c(i,k,j)*rr13c(i,k,j)   &
+                                     + ss23c(i,k,j)*rr23c(i,k,j)   &
+                                   )                               &
+                            )                                      &
+                     )
+
+    ENDDO
+    ENDDO
+    ENDDO
+ 
+  ELSE !(config_flags%sfs_opt .EQ. 2) Use TKE
+
+    DO j=j_start,j_end
+    DO k=kts,ktf
+    DO i=i_start,i_end
+
+      delta = ( dx * dy / rdzw(i,k,j) )**0.33333333
+      a = -1.0*ce*delta
+      b = c3*delta
+
+      m11(i,k,j) = a*(   2.0*sqrt( tke(i,k,j) )*ss11(i,k,j)            &
+                       + b*(                                           &
+                               c1*(   ss11(i,k,j) *ss11(i,k,j)         &
+                                    + ss12c(i,k,j)*ss12c(i,k,j)        &
+                                    + ss13c(i,k,j)*ss13c(i,k,j)        &
+                                    - smnsmn(i,k,j)/3.0                &
+                                          )                            &
+                             + c2*( -2.0*(   ss12c(i,k,j)*rr12c(i,k,j) &
+                                           + ss13c(i,k,j)*rr13c(i,k,j) &
+                                         )                             &
+                                  )                                    &
+                           )                                           &
+                     )
+
+      m22(i,k,j) = a*(   2.0*sqrt( tke(i,k,j) )*ss22(i,k,j)            &
+                       + b*(                                           &
+                               c1*(   ss22(i,k,j) *ss22(i,k,j)         &
+                                    + ss12c(i,k,j)*ss12c(i,k,j)        &
+                                    + ss23c(i,k,j)*ss23c(i,k,j)        &
+                                    - smnsmn(i,k,j)/3.0                &
+                                            )                          &
+                             + c2*(  2.0*(   ss12c(i,k,j)*rr12c(i,k,j) &
+                                           - ss23c(i,k,j)*rr23c(i,k,j) &
+                                         )                             &
+                                  )                                    &
+                           )                                           &
+                     )
+
+      m33(i,k,j) = a*(   2.0*sqrt( tke(i,k,j) )*ss33(i,k,j)            &
+                       + b*(                                           &
+                               c1*(   ss33(i,k,j) *ss33(i,k,j)         &
+                                    + ss13c(i,k,j)*ss13c(i,k,j)        &
+                                    + ss23c(i,k,j)*ss23c(i,k,j)        &
+                                    - smnsmn(i,k,j)/3.0                &
+                                  )                                    &
+                             + c2*(  2.0*(   ss13c(i,k,j)*rr13c(i,k,j) &
+                                           + ss23c(i,k,j)*rr23c(i,k,j) &
+                                         )                             &
+                                  )                                    &
+                           )                                           &
+                     )
+ 
+
+    ENDDO
+    ENDDO
+    ENDDO
+
+  ENDIF
+
+  RETURN
+
+END SUBROUTINE calc_mii
+
+!=============================================================================
+
+SUBROUTINE calc_m12( m12,                          &
+                     s11, s22,                     &
+                     s12, s13, s23,                &
+                     r12, r13, r23, smnsmn,        &
+                     tke, rdzw, dx, dy,            &
+                     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  )
+
+!-----------------------------------------------------------------------------
+!
+! PURPOSE: Compute M12
+!
+!-----------------------------------------------------------------------------
+
+  IMPLICIT NONE
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( OUT ) &
+  :: m12           ! NBA stress element 12               (m2 s-2)
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( IN  ) &
+  :: s11         & ! 2*deformation element 11            (s-1)
+   , s22         & ! 2*deformation element 22            (s-1)   
+   , s12         & ! 2*deformation element 12            (s-1)
+   , s13         & ! 2*deformation element 13            (s-1)
+   , s23         & ! 2*deformation element 23            (s-1)
+   , r12         & ! 2*rotation element 12               (s-1)
+   , r13         & ! 2*rotation element 13               (s-1)
+   , r23         & ! 2*rotation element 23               (s-1)
+   , smnsmn      & ! Smn*Smn                             (s-2)
+   , tke         & ! tke                                 (m2 s-2)
+   , rdzw          ! 1/dz at w-levels                    (m-1)
+
+  REAL,                                                  INTENT( IN  ) &
+  :: dx          & ! grid spacing in x                   (m)
+   , dy            ! grid spacing in y                   (m)
+
+  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
+
+! LOCAL VARIABLES ------------------------------------------------------------
+
+  REAL, DIMENSION( its-1:ite+1, kms:kme, jts-1:jte+1 ) & ! sij/2, rij/2
+  :: ss11        & 
+   , ss22        &  
+   , ss12        &  
+   , ss13        & 
+   , ss23        & 
+   , rr12        & 
+   , rr13        & 
+   , rr23  
+
+
+  REAL, DIMENSION( its-1:ite+1, kms:kme, jts-1:jte+1 ) & ! projected to d
+  :: tked        & 
+   , ss11d       & 
+   , ss22d       & 
+   , ss13d       & 
+   , ss23d       & 
+   , rr13d       & 
+   , rr23d       &          
+   , smnsmnd    
+
+  REAL :: delta, a, b
+
+  INTEGER :: i, j, k, i_start, i_end, j_start, j_end, ktf, je_ext, ie_ext
+
+!-----------------------------------------------------------------------------
+!
+! Set loop limits,
+! taken from /dyn_em/module_diffusion_em.F SUBROUTINE cal_titau_12_21
+!
+!-----------------------------------------------------------------------------
+
+  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
+
+  je_ext = 1
+  ie_ext = 1
+
+  i_end = i_end + ie_ext  
+  j_end = j_end + je_ext   
+
+!-----------------------------------------------------------------------------
+!
+! Divide WRF deformations, which are multiplied by 2, by 2
+!
+!-----------------------------------------------------------------------------
+
+  DO j=j_start-1,j_end
+  DO k=kts,ktf
+  DO i=i_start-1,i_end
+
+    ss11(i,k,j)=s11(i,k,j)/2.0
+    ss22(i,k,j)=s22(i,k,j)/2.0
+    ss12(i,k,j)=s12(i,k,j)/2.0
+    ss13(i,k,j)=s13(i,k,j)/2.0
+    ss23(i,k,j)=s23(i,k,j)/2.0
+    rr12(i,k,j)=r12(i,k,j)/2.0
+    rr13(i,k,j)=r13(i,k,j)/2.0
+    rr23(i,k,j)=r23(i,k,j)/2.0
+
+  END DO
+  END DO
+  END DO
+
+  DO j=j_start-1,j_end
+  DO i=i_start-1,i_end
+
+    ss13(i,kde,j) = 0.0
+    ss23(i,kde,j) = 0.0
+    rr13(i,kde,j) = 0.0
+    rr23(i,kde,j) = 0.0
+
+  END DO
+  END DO
+
+!-----------------------------------------------------------------------------
+!
+! Project variables to d
+!
+!-----------------------------------------------------------------------------
+
+  DO j = j_start, j_end
+  DO k = kts, ktf
+  DO i = i_start, i_end
+
+    tked(i,k,j) = 0.25*( tke(i-1,k  ,j  ) + tke(i  ,k  ,j  ) + &
+                         tke(i-1,k  ,j-1) + tke(i  ,k  ,j-1) )
+
+    smnsmnd(i,k,j) = 0.25*( smnsmn(i-1,k  ,j  ) + smnsmn(i  ,k  ,j  ) + &
+                            smnsmn(i-1,k  ,j-1) + smnsmn(i  ,k  ,j-1) )
+
+    ss11d(i,k,j) = 0.25*( ss11(i-1,k  ,j  ) + ss11(i  ,k  ,j  ) + &
+                          ss11(i-1,k  ,j-1) + ss11(i  ,k  ,j-1) )
+
+    ss22d(i,k,j) = 0.25*( ss22(i-1,k  ,j  ) + ss22(i  ,k  ,j  ) + &
+                          ss22(i-1,k  ,j-1) + ss22(i  ,k  ,j-1) )
+
+    ss13d(i,k,j) = 0.25*( ss13(i  ,k+1,j  ) + ss13(i  ,k+1,j-1) + &
+                          ss13(i  ,k  ,j  ) + ss13(i  ,k  ,j-1) )
+
+    rr13d(i,k,j) = 0.25*( rr13(i  ,k+1,j  ) + rr13(i  ,k+1,j-1) + &
+                          rr13(i  ,k  ,j  ) + rr13(i  ,k  ,j-1) )
+
+    ss23d(i,k,j) = 0.25*( ss23(i  ,k+1,j  ) + ss23(i-1,k+1,j  ) + &
+                          ss23(i  ,k  ,j  ) + ss23(i-1,k  ,j  ) )
+
+    rr23d(i,k,j) = 0.25*( rr23(i  ,k+1,j  ) + rr23(i-1,k+1,j  ) + &
+                          rr23(i  ,k  ,j  ) + rr23(i-1,k  ,j  ) )
+
+  END DO
+  END DO
+  END DO
+
+!-----------------------------------------------------------------------------
+!
+! Calculate M12
+!
+!-----------------------------------------------------------------------------
+
+  IF ( config_flags%sfs_opt .EQ. 1 ) THEN !Do not use TKE
+
+    DO j=j_start,j_end
+    DO k=kts,ktf
+    DO i=i_start,i_end
+
+      delta = ( dx * dy / rdzw(i,k,j) )**0.33333333
+      a = -1.0*( cs*delta )**2
+
+      m12(i,k,j) = a*(   2.0*sqrt( 2.0*smnsmnd(i,k,j) )*ss12(i,k,j) &
+                       + c1*(   ss11d(i,k,j)*ss12(i,k,j)            &
+                              + ss22d(i,k,j)*ss12(i,k,j)            &
+                              + ss13d(i,k,j)*ss23d(i,k,j)           &
+                            )                                       &
+                       + c2*(   ss11d(i,k,j)*rr12(i,k,j)            &
+                              - ss13d(i,k,j)*rr23d(i,k,j)           & 
+                              - ss22d(i,k,j)*rr12(i,k,j)            &
+                              - ss23d(i,k,j)*rr13d(i,k,j)           &
+                            )                                       &
+                      )
+
+    ENDDO
+    ENDDO
+    ENDDO
+
+  ELSE !(config_flags%sfs_opt .EQ. 2) Use TKE
+
+    DO j=j_start,j_end
+    DO k=kts,ktf
+    DO i=i_start,i_end 
+
+      delta = ( dx * dy / rdzw(i,k,j) )**0.33333333
+      a = -1.0*ce*delta
+      b = c3*delta
+
+      m12(i,k,j) = a*(   2.0*sqrt( tked(i,k,j) )*s12(i,k,j)     &
+                       + b*(                                    &
+                               c1*(   ss11d(i,k,j)*ss12(i,k,j)  &
+                                    + ss22d(i,k,j)*ss12(i,k,j)  &
+                                    + ss13d(i,k,j)*ss23d(i,k,j) &
+                                  )                             &
+                             + c2*(   ss11d(i,k,j)*rr12(i,k,j)  &
+                                    - ss13d(i,k,j)*rr23d(i,k,j) &
+                                    - ss22d(i,k,j)*rr12(i,k,j)  &
+                                    - ss23d(i,k,j)*rr13d(i,k,j) &
+                                  )                             &
+                           )                                    &
+                     )
+    ENDDO
+    ENDDO
+    ENDDO
+
+  ENDIF
+
+  RETURN
+
+END SUBROUTINE calc_m12
+
+!=============================================================================
+
+SUBROUTINE calc_m13( m13,                          &
+                     s11, s33,                     &
+                     s12, s13, s23,                &
+                     r12, r13, r23, smnsmn,        &
+                     tke, rdzw, dx, dy,            &
+                     fnm, fnp,                     &
+                     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  )
+
+!-----------------------------------------------------------------------------
+!
+! PURPOSE: Compute M13
+!
+!-----------------------------------------------------------------------------
+
+  IMPLICIT NONE
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( OUT ) &
+  :: m13           !                                     (m2 s-2)
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( IN  ) &
+  :: s11         & ! 2*deformation element 11            (s-1)
+   , s33         & ! 2*deformation element 33            (s-1)
+   , s12         & ! 2*deformation element 12            (s-1)
+   , s13         & ! 2*deformation element 13            (s-1)
+   , s23         & ! 2*deformation element 23            (s-1)
+   , r12         & ! 2*rotation element 12               (s-1)
+   , r13         & ! 2*rotation element 13               (s-1)
+   , r23         & ! 2*rotation element 23               (s-1)
+   , smnsmn      & ! Smn*Smn                             (s-2)
+   , tke         & ! tke                                 (m2 s-2)
+   , rdzw          ! 1/dz at w-levels                    (m-1)
+
+  REAL,                                                  INTENT( IN  ) &
+  :: dx          & ! grid spacing in x                   (m)
+   , dy            ! grid spacing in y                   (m)
+
+  REAL, DIMENSION( kms:kme ),                            INTENT( IN  ) &
+  :: fnm         & ! vertical interpolation coefficients
+   , fnp           !
+
+  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
+
+! LOCAL VARIABLES ------------------------------------------------------------
+
+  REAL, DIMENSION( its-1:ite+1, kms:kme, jts-1:jte+1 ) & ! sij/2, rij/2
+  :: ss11        & 
+   , ss33        &  
+   , ss12        &  
+   , ss13        & 
+   , ss23        & 
+   , rr12        & 
+   , rr13        & 
+   , rr23  
+
+  REAL, DIMENSION( its-1:ite+1, kms:kme, jts-1:jte+1 ) & ! projected to e
+  :: tkee        & 
+   , ss11e       & 
+   , ss33e       & 
+   , ss12e       & 
+   , ss23e       & 
+   , rr12e       & 
+   , rr23e       &          
+   , smnsmne 
+
+  REAL :: delta, a, b
+
+  INTEGER :: i, j, k, i_start, i_end, j_start, j_end, ktf, ie_ext
+
+!-----------------------------------------------------------------------------
+!
+! Set loop limits,
+! taken from /dyn_em/module_diffusion_em.F SUBROUTINE cal_titau_13_31
+!
+!-----------------------------------------------------------------------------
+
+  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
+
+  ie_ext = 1
+  i_end = i_end + ie_ext   
+
+!-----------------------------------------------------------------------------
+!
+! Divide WRF deformations, which are multiplied by 2, by 2
+!
+!-----------------------------------------------------------------------------
+
+  DO j=j_start,j_end+1
+  DO k=kts,ktf
+  DO i=i_start-1,i_end
+
+    ss11(i,k,j)=s11(i,k,j)/2.0
+    ss33(i,k,j)=s33(i,k,j)/2.0
+    ss12(i,k,j)=s12(i,k,j)/2.0
+    ss13(i,k,j)=s13(i,k,j)/2.0
+    ss23(i,k,j)=s23(i,k,j)/2.0
+    rr12(i,k,j)=r12(i,k,j)/2.0
+    rr13(i,k,j)=r13(i,k,j)/2.0
+    rr23(i,k,j)=r23(i,k,j)/2.0
+
+  END DO
+  END DO
+  END DO
+
+!-----------------------------------------------------------------------------
+!
+! Project variables to e
+!
+!-----------------------------------------------------------------------------
+
+  DO j = j_start, j_end
+  DO k = kts+1, ktf
+  DO i = i_start, i_end
+
+    tkee(i,k,j) = 0.5*( fnm(k)*( tke(i,k  ,j) + tke(i-1,k  ,j) ) + &
+                        fnp(k)*( tke(i,k-1,j) + tke(i-1,k-1,j) ) )
+
+    smnsmne(i,k,j) = 0.5*( fnm(k)*( smnsmn(i,k  ,j) + smnsmn(i-1,k  ,j) ) + &
+                           fnp(k)*( smnsmn(i,k-1,j) + smnsmn(i-1,k-1,j) ) )
+
+    ss11e(i,k,j) = 0.5*( fnm(k)*( ss11(i  ,k  ,j  ) + ss11(i-1,k  ,j  ) ) + &
+                         fnp(k)*( ss11(i  ,k-1,j  ) + ss11(i-1,k-1,j  ) ) )
+
+    ss33e(i,k,j) = 0.5*( fnm(k)*( ss33(i  ,k  ,j  ) + ss33(i-1,k  ,j  ) ) + &
+                         fnp(k)*( ss33(i  ,k-1,j  ) + ss33(i-1,k-1,j  ) ) )
+ 
+    ss12e(i,k,j) = 0.5*( fnm(k)*( ss12(i  ,k  ,j  ) + ss12(i  ,k  ,j+1) ) + &
+                         fnp(k)*( ss12(i  ,k-1,j  ) + ss12(i  ,k-1,j+1) ) )
+
+    rr12e(i,k,j) = 0.5*( fnm(k)*( rr12(i  ,k  ,j  ) + rr12(i  ,k  ,j+1) ) + &
+                         fnp(k)*( rr12(i  ,k-1,j  ) + rr12(i  ,k-1,j+1) ) )
+
+    ss23e(i,k,j) = 0.25*( ss23(i  ,k  ,j) + ss23(i  ,k  ,j+1) + &
+                          ss23(i-1,k  ,j) + ss23(i-1,k  ,j+1) )
+
+    rr23e(i,k,j) = 0.25*( rr23(i  ,k  ,j) + rr23(i  ,k  ,j+1) + &
+                          rr23(i-1,k  ,j) + rr23(i-1,k  ,j+1) )
+
+  END DO
+  END DO
+  END DO
+
+!-----------------------------------------------------------------------------
+!
+! Calculate M_13
+!
+!-----------------------------------------------------------------------------
+
+
+  IF ( config_flags%sfs_opt .EQ. 1 ) THEN !Do not use TKE
+
+    DO j=j_start,j_end
+    DO k=kts+1,ktf
+    DO i=i_start,i_end
+
+      delta = ( dx * dy / rdzw(i,k,j) )**0.33333333
+      a = -1.0*( cs*delta )**2
+
+      m13(i,k,j) = a*(   2.0*sqrt( 2.0*smnsmne(i,k,j) )*ss13(i,k,j) &
+                       + c1*(   ss11e(i,k,j)*ss13(i,k,j)            &
+                              + ss12e(i,k,j)*ss23e(i,k,j)           &
+                              + ss13(i,k,j)*ss33e(i,k,j)            &
+                            )                                       &
+                       + c2*(   ss11e(i,k,j)*rr13(i,k,j)            &
+                              + ss12e(i,k,j)*rr23e(i,k,j)           &
+                              - ss23e(i,k,j)*rr12e(i,k,j)           &
+                              - ss33e(i,k,j)*rr13(i,k,j)            &
+                            )                                       &
+                     )
+
+    ENDDO
+    ENDDO
+    ENDDO
+
+  ELSE !(config_flags%sfs_opt .EQ. 2) Use TKE
+
+    DO j=j_start,j_end
+    DO k=kts+1,ktf
+    DO i=i_start,i_end
+
+      delta = ( dx * dy / rdzw(i,k,j) )**0.33333333
+      a = -1.0*ce*delta
+      b = c3*delta
+
+      m13(i,k,j) = a*(   2.0*sqrt( tkee(i,k,j) )*ss13(i,k,j)    &
+                       + b*(                                    &
+                               c1*(   ss11e(i,k,j)*ss13(i,k,j)  &
+                                    + ss12e(i,k,j)*ss23e(i,k,j) &
+                                    + ss13(i,k,j)*ss33e(i,k,j)  &
+                                  )                             &
+                             + c2*(   ss11e(i,k,j)*rr13(i,k,j)  &
+                                    + ss12e(i,k,j)*rr23e(i,k,j) &
+                                    - ss23e(i,k,j)*rr12e(i,k,j) &
+                                    - ss33e(i,k,j)*rr13(i,k,j)  &
+                                  )                             &
+                           )                                    &
+                     )
+
+    ENDDO
+    ENDDO
+    ENDDO
+
+  ENDIF
+
+  RETURN
+
+END SUBROUTINE calc_m13
+
+!=============================================================================
+
+SUBROUTINE calc_m23( m23,                          &
+                     s22, s33,                     &
+                     s12, s13, s23,                &
+                     r12, r13, r23, smnsmn,        &
+                     tke, rdzw, dx, dy,            &
+                     fnm, fnp,                     &
+                     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  )
+
+!-----------------------------------------------------------------------------
+!
+! PURPOSE: Compute M23
+!
+!-----------------------------------------------------------------------------
+
+  IMPLICIT NONE
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT( OUT ) &
+  :: m23           !                                     (m2 s-2)
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),          INTENT(  IN ) &
+  :: s22         & ! 2*deformation element 22            (s-1)
+   , s33         & ! 2*deformation element 33            (s-1)
+   , s12         & ! 2*deformation element 12            (s-1)
+   , s13         & ! 2*deformation element 13            (s-1)
+   , s23         & ! 2*deformation element 23            (s-1)
+   , r12         & ! 2*rotation element 12               (s-1)
+   , r13         & ! 2*rotation element 13               (s-1)
+   , r23         & ! 2*rotation element 23               (s-1)
+   , smnsmn      & ! Smn*Smn                             (s-2)
+   , tke         & ! tke                                 (m2 s-2)
+   , rdzw          ! 1/dz at w-levels                    (m-1)
+
+  REAL,                                                  INTENT( IN  ) &
+  :: dx          & ! grid spacing in x                   (m)
+   , dy            ! grid spacing in y                   (m)
+
+  REAL, DIMENSION( kms:kme ),                            INTENT( IN  ) &
+  :: fnm         & ! vertical interpolation coefficients
+   , fnp           !
+
+  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
+
+! LOCAL VARIABLES ------------------------------------------------------------
+
+  REAL, DIMENSION( its-1:ite+1, kms:kme, jts-1:jte+1 ) & ! sij/2, rij/2
+  :: ss22        & 
+   , ss33        &  
+   , ss12        &  
+   , ss13        & 
+   , ss23        & 
+   , rr12        & 
+   , rr13        & 
+   , rr23  
+
+  REAL, DIMENSION( its-1:ite+1, kms:kme, jts-1:jte+1 ) & ! projected to f
+  :: tkef        & 
+   , ss22f       & 
+   , ss33f       & 
+   , ss12f       & 
+   , ss13f       & 
+   , rr12f       & 
+   , rr13f       &          
+   , smnsmnf    
+
+  REAL :: delta, a, b
+
+  INTEGER :: i, j, k, i_start, i_end, j_start, j_end, ktf, je_ext
+
+!-----------------------------------------------------------------------------
+!
+! Set loop limits,
+! taken from /dyn_em/module_diffusion_em.F SUBROUTINE cal_titau_23_32
+!
+!-----------------------------------------------------------------------------
+
+  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 )
+
+  je_ext = 1
+  j_end = j_end + je_ext   
+
+!-----------------------------------------------------------------------------
+!
+! Divide WRF deformations, which are multiplied by 2, by 2
+!
+!-----------------------------------------------------------------------------
+
+  DO j=j_start-1,j_end
+  DO k=kts,ktf
+  DO i=i_start,i_end+1
+
+    ss22(i,k,j)=s22(i,k,j)/2.0
+    ss33(i,k,j)=s33(i,k,j)/2.0
+    ss12(i,k,j)=s12(i,k,j)/2.0
+    ss13(i,k,j)=s13(i,k,j)/2.0
+    ss23(i,k,j)=s23(i,k,j)/2.0
+    rr12(i,k,j)=r12(i,k,j)/2.0
+    rr13(i,k,j)=r13(i,k,j)/2.0
+    rr23(i,k,j)=r23(i,k,j)/2.0
+
+  END DO
+  END DO
+  END DO
+
+!-----------------------------------------------------------------------------
+!
+! Project variables to f
+!
+!-----------------------------------------------------------------------------
+
+  DO j = j_start, j_end
+  DO k = kts+1, ktf
+  DO i = i_start, i_end
+
+    tkef(i,k,j) = 0.5*( fnm(k)*( tke(i  ,k  ,j  ) + tke(i  ,k  ,j-1) ) + &
+                        fnp(k)*( tke(i  ,k-1,j  ) + tke(i  ,k-1,j-1) ) )
+
+    smnsmnf(i,k,j) = 0.5*( fnm(k)*( smnsmn(i  ,k  ,j  ) + smnsmn(i  ,k  ,j-1) ) + &
+                           fnp(k)*( smnsmn(i  ,k-1,j  ) + smnsmn(i  ,k-1,j-1) ) )
+
+    ss22f(i,k,j) = 0.5*( fnm(k)*( ss22(i  ,k  ,j  ) + ss22(i  ,k  ,j-1) ) + &
+                         fnp(k)*( ss22(i  ,k-1,j  ) + ss22(i  ,k-1,j-1) ) )
+
+    ss33f(i,k,j) = 0.5*( fnm(k)*( ss33(i  ,k  ,j  ) + ss33(i  ,k  ,j-1) ) + &
+                         fnp(k)*( ss33(i  ,k-1,j  ) + ss33(i  ,k-1,j-1) ) )
+
+    ss12f(i,k,j) = 0.5*( fnm(k)*( ss12(i  ,k  ,j  ) + ss12(i+1,k  ,j  ) ) + &
+                         fnp(k)*( ss12(i  ,k-1,j  ) + ss12(i+1,k-1,j  ) ) )
+
+    rr12f(i,k,j) = 0.5*( fnm(k)*( rr12(i  ,k  ,j  ) + rr12(i+1,k  ,j  ) ) + &
+                         fnp(k)*( rr12(i  ,k-1,j  ) + rr12(i+1,k-1,j  ) ) )
+
+    ss13f(i,k,j) = 0.25*( ss13(i  ,k  ,j  ) + ss13(i  ,k  ,j-1) + &
+                          ss13(i+1,k  ,j-1) + ss13(i+1,k  ,j  ) )
+
+    rr13f(i,k,j) = 0.25*( rr13(i  ,k  ,j  ) + rr13(i  ,k  ,j-1) + &
+                          rr13(i+1,k  ,j-1) + rr13(i+1,k  ,j  ) )
+
+  END DO
+  END DO
+  END DO
+ 
+!-----------------------------------------------------------------------------
+!
+! Calculate M23
+!
+!-----------------------------------------------------------------------------
+
+  IF ( config_flags%sfs_opt .EQ. 1 ) THEN !Do not use TKE
+
+    DO j=j_start,j_end
+    DO k=kts+1,ktf
+    DO i=i_start,i_end
+
+      delta = ( dx * dy / rdzw(i,k,j) )**0.33333333
+      a = -1.0*( cs*delta )**2
+
+      m23(i,k,j) = a*(   2.0*sqrt( 2.0*smnsmnf(i,k,j) )*ss23(i,k,j) &
+                       + c1*(   ss12f(i,k,j)*ss13f(i,k,j)           &
+                              + ss22f(i,k,j)*ss23(i,k,j)            &
+                              + ss23(i,k,j) *ss33f(i,k,j)           &
+                             )                                      &
+                       + c2*(   ss12f(i,k,j)*rr13f(i,k,j)           &
+                              + ss22f(i,k,j)*rr23(i,k,j)            &
+                              + ss13f(i,k,j)*rr12f(i,k,j)           &
+                              - ss33f(i,k,j)*rr23(i,k,j)            &
+                            )                                       &
+                     )
+
+    ENDDO
+    ENDDO
+    ENDDO
+
+  ELSE !(config_flags%sfs_opt .EQ. 2) Use TKE
+
+    DO j=j_start,j_end
+    DO k=kts+1,ktf
+    DO i=i_start,i_end
+
+      delta = ( dx * dy / rdzw(i,k,j) )**0.33333333
+      a = -1.0*ce*delta
+      b = c3*delta
+
+      m23(i,k,j) = a*(   2.0*sqrt( tkef(i,k,j) )*ss23(i,k,j)    &
+                       + b*(                                    &
+                               c1*(   ss12f(i,k,j)*ss13f(i,k,j) &
+                                    + ss22f(i,k,j)*ss23(i,k,j)  &
+                                    + ss23(i,k,j) *ss33f(i,k,j) &
+                                  )                             &
+                             + c2*(   ss12f(i,k,j)*rr13f(i,k,j) &
+                                    + ss22f(i,k,j)*rr23(i,k,j)  &
+                                    + ss13f(i,k,j)*rr12f(i,k,j) &
+                                    - ss33f(i,k,j)*rr23(i,k,j)  &
+                                  )                             &
+                           )                                    &
+                     )
+
+    ENDDO
+    ENDDO
+    ENDDO
+
+  ENDIF
+
+  RETURN
+
+END SUBROUTINE calc_m23
+
+!=============================================================================
+
+END MODULE module_sfs_nba
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_small_step_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_small_step_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_small_step_em.F	(revision 17)
@@ -0,0 +1,1860 @@
+!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,         &
+                            msfux, msfuy, msfvx,          &
+                            msfvx_inv,                    &
+                            msfvy, msftx, msfty,          &
+                            rdx, rdy,                     &
+                            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
+
+  REAL, DIMENSION(ims:ime, jms:jme)         , INTENT(INOUT) :: mu_1,mu_2
+
+  REAL, DIMENSION(ims:ime, jms:jme)         , INTENT(IN   ) :: mub,  &
+                                                               muu,  &
+                                                               muv,  &
+                                                               mut,  &
+                                                               msfux,&
+                                                               msfuy,&
+                                                               msfvx,&
+                                                               msfvx_inv,&
+                                                               msfvy,&
+                                                               msftx,&
+                                                               msfty
+
+  REAL, DIMENSION(ims:ime, jms:jme)         , INTENT(  OUT) :: muus, &
+                                                               muvs, &
+                                                               muts, &
+                                                               mudf
+
+  REAL, DIMENSION(ims:ime, jms:jme)         , INTENT(  OUT) :: mu_save
+
+  REAL, DIMENSION(kms:kme, jms:jme)         , INTENT(IN   ) :: dnw
+
+  REAL, INTENT(IN) :: rdx,rdy
+
+! local variables
+
+  INTEGER :: i, j, k
+  INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end
+  INTEGER :: i_endu, j_endv
+
+!<DESCRIPTION>
+!
+!  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
+!
+!</DESCRIPTION>
+
+    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)
+
+    i_endu = ite
+    j_endv = jte
+
+    !  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
+
+      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)=0.
+!       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 coupled with my
+      u_2(i,k,j) = (muus(i,j)*u_1(i,k,j)-muu(i,j)*u_2(i,k,j))/msfuy(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 coupled with mx
+!      v_2(i,k,j) = (muvs(i,j)*v_1(i,k,j)-muv(i,j)*v_2(i,k,j))/msfvx(i,j)
+      v_2(i,k,j) = (muvs(i,j)*v_1(i,k,j)-muv(i,j)*v_2(i,k,j))*msfvx_inv(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 coupled with my
+      w_2(i,k,j)  = (muts(i,j)* w_1(i,k,j)-mut(i,j)* w_2(i,k,j))/msfty(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,        &
+                              msfux, msfuy, msfvx, msfvy,      &
+                              msftx, msfty,                    &
+                              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   ) :: msfux, msfuy, &
+                                                        msfvx, msfvy, &
+                                                        msftx, msfty
+
+
+! local stuff
+
+  INTEGER         :: i,j,k
+  INTEGER :: i_start, i_end, j_start, j_end, i_endu, j_endv
+
+!<DESCRIPTION>
+!
+!  small_step_finish reconstructs the full uncoupled prognostic variables
+!  from the coupled perturbation variables used in the small timesteps.
+!
+!</DESCRIPTION>
+
+  i_start = its
+  i_end   = min(ite,ide-1)
+  j_start = jts
+  j_end   = min(jte,jde-1)
+
+  i_endu = ite
+  j_endv = jte
+
+!    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 coupled with mx
+    v_2(i,k,j) = (msfvx(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 coupled with my
+    u_2(i,k,j) = (msfuy(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 coupled with my
+    w_2(i,k,j) = (msfty(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
+
+  REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(IN   ) :: alt,   &
+                                                              t_2,   &
+                                                              t_1,   &
+                                                              c2a
+
+  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
+
+!<DESCRIPTION>
+!
+!  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.
+!
+!</DESCRIPTION>
+#ifdef LMDZ1
+   INTEGER                                               :: im2,km2,jm2
+  
+   im2=24
+   jm2=21
+   km2=38
+
+   PRINT *,'  calc_p_rho: inside: ',im2,km2,jm2
+   PRINT  *,'    al: ',al(im2,km2,jm2), ' p: ', p(im2,1,jm2),' ph: ',ph(im2,1,jm2)
+#endif
+
+
+   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)
+
+   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
+#ifdef LMDZ1
+   PRINT *,'  calc_p_rho: after nonhydrostatic' 
+   PRINT  *,'   al: ',al(im2,km2,jm2), ' p: ', p(im2,1,jm2),' ph: ',ph(im2,1,jm2)
+   PRINT  *,'   muts: ',muts(im2,jm2), 'alt: ', alt(im2,1,jm2),' mu: ',mu(im2,jm2),     &
+     'rdnw: ', rdnw(1),' ph 1: ',ph(im2,2,jm2)
+   PRINT  *,'   c2a: ',c2a(im2,1,jm2), 't_2: ', t_2(im2,1,jm2),' t_1: ',t_1(im2,1,jm2), &
+     't0: ', t0,' pm1: ',pm1(im2,1,jm2)
+#endif
+
+   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
+#ifdef LMDZ1
+   PRINT *,'  calc_p_rho: after divergence damping' 
+   PRINT  *,'   pm1: ',pm1(im2,km2,jm2), ' smdiv: ', smdiv,' ptmp: ',ptmp
+#endif
+
+END SUBROUTINE calc_p_rho
+
+!----------------------------------------------------------------------
+
+SUBROUTINE calc_coef_w( a,alpha,gamma,              &
+                        mut, cqw,                   &
+                        rdn, rdnw, c2a,             &
+                        dts, g, epssm, top_lid,     &
+                        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
+
+  LOGICAL,      INTENT(IN   )    :: top_lid
+
+  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, lid_flag
+
+!<DESCRIPTION>
+!
+!  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.
+!
+!</DESCRIPTION>
+
+      i_start = its
+      i_end   = min(ite,ide-1)
+      j_start = jts
+      j_end   = min(jte,jde-1)
+      k_start = kts
+      k_end   = kte-1
+
+      lid_flag=1
+      IF(top_lid)lid_flag=0
+
+     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)*lid_flag
+          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,      &
+                        msfux, msfuy, msfvx,           &
+                        msfvx_inv, msfvy,              &
+                        rdx, rdy, dts,                 &
+                        cf1, cf2, cf3, fnm, fnp,       &
+                        emdiv,                         &
+                        rdnw, config_flags, spec_zone, &
+                        non_hydrostatic, top_lid,      &
+                        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, top_lid
+
+      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, DIMENSION( ims:ime , jms:jme ),    INTENT(IN   ) :: msfux,  &
+                                                                msfuy,  &
+                                                                msfvx,  &
+                                                                msfvy,  &
+                                                                msfvx_inv
+
+      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
+
+#ifdef LMDZ1
+      INTEGER                                            :: im2,km2,jm2
+  
+      im2=24
+      jm2=21
+      km2=1
+
+      PRINT *,'  advance_uv: inside' 
+      PRINT  *,'    al: ',al(im2,km2,jm2), ' p: ', p(im2,1,jm2),' ph: ',ph(im2,1,jm2)
+#endif
+
+!<DESCRIPTION>
+!
+!  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.
+!
+!</DESCRIPTION>
+
+!  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   = min(ite,ide-1)
+        i_endu = ite
+      ENDIF
+    ELSE
+      i_start = its
+      i_end   = min(ite,ide-1)
+      j_start = jts
+      j_end   = min(jte,jde-1)
+      k_start = kts
+      k_end   = kte-1
+
+      i_endu = ite
+      j_endv = jte
+      k_endw = k_end
+    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  .or.   &
+            config_flags%polar   )  &
+                     .and. (jts == jds) )  &
+                 j_start_vp = j_start_vp + 1
+
+      IF ( (config_flags%open_ye     .or. &
+            config_flags%symmetric_ye  .or.   &
+            config_flags%polar   )  &
+            .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))/msfuy(i,j)
+   ENDDO
+
+   DO k = k_start, k_end
+   DO i = i_start_up, i_end_up
+
+!     Comments on map scale factors:   
+!     x pressure gradient: ADT eqn 44, penultimate term on RHS
+!        = -(mx/my)*(mu/rho)*partial dp/dx
+!     [i.e., first rho->mu; 2nd still rho; alpha=1/rho]
+!     Klemp et al. splits into 2 terms:
+!        mu alpha partial dp/dx + partial dp/dnu * partial dphi/dx 
+!     then into 4 terms:
+!        mu alpha partial dp'/dx + nu mu alpha' partial dmubar/dx +
+!      + mu partial dphi/dx + partial dphi'/dx * (partial dp'/dnu - mu')
+!
+!     first 3 terms:
+!     ph, alt, p, al, pb not coupled
+!     since we want tendency to fit ADT eqn 44 (coupled) we need to
+!     multiply by (mx/my):
+!
+     dpxy(i,k)= (msfux(i,j)/msfuy(i,j))*.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
+     IF (top_lid) THEN
+       DO i = i_start_up, i_end_up
+         dpn(i,kde) =.5*( cf1*(p(i-1,kde-1,j)+p(i,kde-1,j))   &
+                         +cf2*(p(i-1,kde-2,j)+p(i,kde-2,j))   &
+                         +cf3*(p(i-1,kde-3,j)+p(i,kde-3,j))  )
+       ENDDO
+     ENDIF
+
+     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
+
+!    Comments on map scale factors:
+!    4th term:
+!    php, dpn, mu not coupled
+!    since we want tendency to fit ADT eqn 44 (coupled) we need to
+!    multiply by (mx/my):
+
+     DO k = k_start, k_end
+       DO i = i_start_up, i_end_up
+         dpxy(i,k)=dpxy(i,k) + (msfux(i,j)/msfuy(i,j))*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))*msfvx_inv(i,j)
+   ENDDO
+
+     IF (     ( j >= j_start_vp)  &
+       .and.( j <= j_end_vp  ) )  THEN
+
+         DO k = k_start, k_end
+	 DO i = i_start, i_end
+
+!      Comments on map scale factors:
+!      y pressure gradient: ADT eqn 45, penultimate term on RHS
+!         = -(my/mx)*(mu/rho)*partial dp/dy
+!      [i.e., first rho->mu; 2nd still rho; alpha=1/rho]
+!      Klemp et al. splits into 2 terms:
+!         mu alpha partial dp/dy + partial dp/dnu * partial dphi/dy 
+!      then into 4 terms:
+!         mu alpha partial dp'/dy + nu mu alpha' partial dmubar/dy +
+!       + mu partial dphi/dy + partial dphi'/dy * (partial dp'/dnu - mu')
+!
+!      first 3 terms:
+!      ph, alt, p, al, pb not coupled
+!      since we want tendency to fit ADT eqn 45 (coupled) we need to
+!      multiply by (my/mx):
+!      mudf_xy is NOT a map scale factor coupling
+!      it is some sort of divergence damping
+
+       dpxy(i,k)= (msfvy(i,j)/msfvx(i,j))*.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
+     IF (top_lid) THEN
+       DO i = i_start, i_end
+         dpn(i,kde) =.5*( cf1*(p(i,kde-1,j-1)+p(i,kde-1,j))   &
+                         +cf2*(p(i,kde-2,j-1)+p(i,kde-2,j))   &
+                         +cf3*(p(i,kde-3,j-1)+p(i,kde-3,j))  )
+       ENDDO
+     ENDIF
+
+       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
+
+!      Comments on map scale factors:
+!      4th term:
+!      php, dpn, mu not coupled
+!      since we want tendency to fit ADT eqn 45 (coupled) we need to
+!      multiply by (my/mx):
+
+       DO k = k_start, k_end
+         DO i = i_start, i_end
+           dpxy(i,k)=dpxy(i,k) + (msfvy(i,j)/msfvx(i,j))*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
+
+  ! The check for j_start_vp and j_end_vp makes sure that the edges in v
+  ! are not updated.  Let's add a polar boundary condition check here for
+  ! safety to ensure that v at the poles never gets to be non-zero in the
+  ! small time steps.
+  IF (config_flags%polar) THEN
+     IF (jts == jds) THEN
+        DO k = k_start, k_end
+        DO i = i_start, i_end
+           v(i,k,jds) = 0.
+        ENDDO
+        ENDDO
+     END IF
+     IF (jte == jde) THEN
+        DO k = k_start, k_end
+        DO i = i_start, i_end
+           v(i,k,jde) = 0.
+        ENDDO
+        ENDDO
+     END IF
+  END IF
+
+
+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,                 &
+                         msfux, msfuy, msfvx, msfvx_inv,      &
+                         msfvy, msftx, msfty,                 &
+                         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,  &
+                                                            msfux,&
+                                                            msfuy,&
+                                                            msfvx,&
+                                                            msfvx_inv,&
+                                                            msfvy,&
+                                                            msftx,&
+                                                            msfty,&
+                                                            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 arrays 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
+
+!<DESCRIPTION>
+!
+!  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.
+!
+!</DESCRIPTION>
+
+!  now, the real work.
+!  set the loop bounds taking into account boundary conditions.
+#ifdef LMDZ1
+  INTEGER                                            :: im2,km2,jm2
+  
+  im2 = config_flags%i_check_point
+  jm2 = config_flags%j_check_point
+  km2 = config_flags%k_check_point
+
+  PRINT *,'  advance_mu_t: inside' 
+  PRINT *,'    ww: ',ww(im2,km2,jm2),' ww_1: ', ww_1(im2,km2,jm2), ' u: ',u(im2,km2,jm2), &
+    ' u_1: ',u_1(im2,km2,jm2), ' v: ',v(im2,km2,jm2), ' v_1: ',v_1(im2,km2,jm2), ' mu: ', mu(im2,jm2), &
+    ' mu_t: ',mut(im2,jm2), ' muave: ',muave(im2,jm2), ' muts: ',muts(im2,jm2), &
+    ' muu: ',muu(im2,jm2), ' muv: ',muv(im2,jm2), ' mudf: ', mudf(im2,jm2), &
+    ' uam: ',uam(im2,km2,jm2), ' vam: ',vam(im2,km2,jm2), ' wwam: ',wwam(im2,km2,jm2), ' t: ',t(im2,km2,jm2), &
+    ' t_1: ',t_1(im2,km2,jm2), ' t_ave: ', t_ave(im2,km2,jm2), ' ft: ',ft(im2,km2,jm2), &
+    ' mu_tend: ', mu_tend(im2,jm2), ' rdx: ', rdx, ' rdy: ',rdy, &
+    ' dts: ',dts, ' epssm: ',epssm, ' dnw: ', dnw(km2), &
+    ' fnm: ',fnm(km2), ' fnp: ',fnp(km2), ' rndw: ',rdnw(km2),                 &
+    ' msfux: ',msfux(im2,jm2), ' msfuy: ',msfuy(im2,jm2), 'msfvx: ',msfvx(im2,jm2), &
+    ' msfvx_inv: ',msfvx_inv(im2,jm2), 'msfvy: ',msfvy(im2,jm2), &
+    ' msftx: ',msftx(im2,jm2), 'msfty: ',msfty(im2,jm2), ' step: ', step
+#endif
+
+  i_start = its
+  i_end   = min(ite,ide-1)
+  j_start = jts
+  j_end   = min(jte,jde-1)
+  k_start = kts
+  k_end   = kte-1
+  IF ( .NOT. config_flags%periodic_x )THEN
+     IF ( config_flags%specified .or. config_flags%nested ) then
+       i_start = max(its,ids+1)
+       i_end   = min(ite,ide-2)
+     ENDIF
+  ENDIF
+  IF ( config_flags%specified .or. config_flags%nested ) then
+     j_start = max(jts,jds+1)
+     j_end   = min(jte,jde-2)
+  ENDIF
+
+  i_endu = ite
+  j_endv = jte
+
+!        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.
+
+!  Comments on map scale factors
+!  ADT eqn 47: 
+!  partial drho/dt = -mx*my[partial d/dx(rho u/my) + partial d/dy(rho v/mx)]
+!                    -partial d/dz(rho w)
+!  with rho -> mu, dividing by my, and with partial d/dnu(rho nu/my [=ww])
+!  as the final term (because we're looking for d_nu_/dt)
+!
+!  begin by integrating with respect to nu from bottom to top
+!  BCs are ww=0 at both
+!  final term gives 0
+!  first term gives Integral([1/my]partial d mu/dt) over total column = dm/dt
+!  RHS remaining is Integral(-mx[partial d/dx(mu u/my) + 
+!                                partial d/dy(mu v/mx)]) over column
+!  lines below find RHS terms at each level then set dmdt = sum over all levels
+!
+!  [don't divide the below by msfty until find ww, since dmdt is used in
+!   the meantime]
+
+#ifdef LMDZ1
+     IF (j == jm2) PRINT *,'  Lluis advance_mu_t k msftx msfty rdy v/m muv v_1 ' // &
+       'msfvx_inv rdx u/m muu u_1 msfuy dvdxi dnw ______ ' 
+#endif
+     DO k=k_start, k_end
+     DO i=i_start, i_end
+         dvdxi(i,k) = msftx(i,j)*msfty(i,j)*(                                      &
+                     rdy*( (v(i,k,j+1)+muv(i,j+1)*v_1(i,k,j+1)*msfvx_inv(i,j+1))   &
+                          -(v(i,k,j  )+muv(i,j  )*v_1(i,k,j  )*msfvx_inv(i,j  )) ) &
+                    +rdx*( (u(i+1,k,j)+muu(i+1,j)*u_1(i+1,k,j)/msfuy(i+1,j))       &
+                          -(u(i,k,j  )+muu(i  ,j)*u_1(i,k,j  )/msfuy(i  ,j)) ))
+        dmdt(i)    = dmdt(i) + dnw(k)*dvdxi(i,k)
+#ifdef LMDZ1
+     IF (i == im2 .AND. j == jm2) PRINT *,k, msftx(im2,jm2), msfty(im2,jm2), rdy, v(im2,k,jm2), muv(im2,jm2), &
+        v_1(im2,k,jm2), msfvx_inv(im2,jm2), rdx, u(im2,k,jm2), muu(im2,jm2), u_1(im2,k,jm2), &
+        msfuy(im2,jm2), dvdxi(im2,k), dnw(k)
+#endif
+     ENDDO
+     ENDDO
+#ifdef LMDZ1
+  IF (j == jm2)  THEN
+    PRINT *,'  advance_mu_t: after dvdx/dmdt' 
+    PRINT *,'    dvdxi: ',dvdxi(im2,km2),' dmdt: ', dmdt(im2)
+  END IF
+#endif
+
+     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
+#ifdef LMDZ1
+  IF (j == jm2)  THEN
+  PRINT *,'  advance_mu_t: after muave' 
+  PRINT *,'    muave: ',muave(im2,jm2),' mu: ', mu(im2,jm2), ' mudf: ',mudf(im2,jm2), &
+    ' muts: ',muts(im2,jm2), ' muave: ',muave(im2,jm2)
+  END IF
+#endif
+
+     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))/msfty(i,j)
+     ENDDO
+     END DO
+#ifdef LMDZ1
+  IF (j == jm2)  THEN
+    PRINT *,'  advance_mu_t: after w' 
+    PRINT *,'    ww: ',ww(im2,km2,jm2)
+  END IF
+#endif
+
+!  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
+#ifdef LMDZ1
+  IF (j == jm2)  THEN
+    PRINT *,'  advance_mu_t: after w 1' 
+    PRINT *,'    ww: ',ww(im2,km2,jm2)
+  END IF
+#endif
+   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)
+
+! Comments on map scale factors
+! BUT NOTE THAT both are mass coupled
+! in flux form equations (Klemp et al.) Theta = mu*theta
+!
+! scalar eqn: partial d/dt(rho q/my) = -mx[partial d/dx(q rho u/my) + 
+!                                          partial d/dy(q rho v/mx)]
+!                                      - partial d/dz(q rho w/my)
+! with rho -> mu, and with partial d/dnu(q rho nu/my) as the final term
+!
+! adding previous tendency contribution which was map scale factor coupled
+! (had been divided by msfty)
+! need to uncouple before updating uncoupled Theta (by adding)
+
+   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) + msfty(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
+        ! for scalar eqn RHS term 3
+        wdtn(i,k)= ww(i,k,j)*(fnm(k)*t_1(i,k  ,j)+fnp(k)*t_1(i,k-1,j))
+     ENDDO
+     ENDDO
+
+! scalar eqn, RHS terms 1, 2 and 3
+! multiply by msfty to uncouple result for Theta from map scale factor
+
+     DO k=1,k_end
+     DO i=i_start, i_end
+       ! multiplication by msfty uncouples result for Theta
+       t(i,k,j) = t(i,k,j) - dts*msfty(i,j)*(              &
+                          ! multiplication by mx needed for RHS terms 1 & 2
+                          msftx(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, w_save, 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, msftx, msfty,&
+                      config_flags, top_lid,      &
+                      ids,ide, jds,jde, kds,kde,  & ! domain dims
+                      ims,ime, jms,jme, kms,kme,  & ! memory dims
+                      its,ite, jts,jte, kts,kte  )  ! tile   dims
+
+! We have used msfty for msft_inv but have not thought through w equation
+! pieces properly yet, so we will have to hope that it is okay
+! We think we have found a slight error in surface w calculation
+
+  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
+
+  LOGICAL,      INTENT(IN   )    :: top_lid
+
+      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,      &
+                                             w_save,  &
+                                             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,      &
+                                   msftx,   &
+                                   msfty
+
+      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
+      REAL, DIMENSION (kts:kte) :: dampwt
+      real :: htop,hbot,hdepth,hk
+      real    :: pi,dampmag
+
+!<DESCRIPTION>
+!
+!  advance_w advances the implicit w and geopotential equations.
+!
+!</DESCRIPTION>
+
+!  set loop limits.
+!  Currently set for periodic 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   = kte-1
+      IF ( .NOT. config_flags%periodic_x )THEN
+         IF ( config_flags%specified .or. config_flags%nested ) then
+           i_start = max(its,ids+1)
+           i_end   = min(ite,ide-2)
+         ENDIF
+      ENDIF
+      IF ( config_flags%specified .or. config_flags%nested ) then
+         j_start = max(jts,jds+1)
+         j_end   = min(jte,jde-2)
+      ENDIF
+
+   pi = 4.*atan(1.)
+   dampmag = dts*config_flags%dampcoef
+   hdepth=config_flags%zdamp
+
+! calculation of phi and w equations
+
+!   Comments on map scale factors:
+!   phi equation is:
+!    partial d/dt(rho phi/my) = -mx partial d/dx(phi rho u/my) 
+!                               -mx partial d/dy(phi rho v/mx)
+!                               - partial d/dz(phi rho w/my) + rho g w/my
+!   as with scalar equation, use uncoupled value (here phi) to find the
+!   coupled tendency (rho phi/my)
+!   here as usual rho -> ~'mu'
+!
+!   w eqn [divided by my] is:
+!     partial d/dt(rho w/my) = -mx partial d/dx(w rho u/my)
+!                              -mx partial d/dy(v rho v/mx)
+!                              - partial d/dz(w rho w/my)
+!                              +rho[(u*u+v*v)/a + 2 u omega cos(lat) -
+!                                   (1/rho) partial dp/dz - g + Fz]/my
+!   here as usual rho -> ~'mu'
+!
+!  'u,v,w' sent here must be coupled variables (= rho w/my etc.) by their usage
+
+
+    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./msfty(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) + muave(i,j)*t0) &
+                    /(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
+
+!   building up RHS of phi equation
+!   ph_tend contains terms 1 and 2; now adding 3 and 4 in stages:
+!   here rhs = delta t [ph_tend + ~g*w/2 - ~ww * partial d phi/dz]
+    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
+
+!   Comments on map scale factors:
+!   building up RHS of phi equation
+!   ph_tend contains terms 1 and 2; now adding 3 and 4 in stages:
+!   here rhs = ph_previous + (msft/mu)*[rhs_previous - ~ww * delta t * 
+!                                                      partial d phi/dz]
+!            = ph_previous + (msft*delta t/mu)*[ph_tend + ~g*w/2 - ~ww *
+!                                                         partial d phi/dz]
+    DO k=2,k_end+1
+    DO i=i_start, i_end
+      rhs(i,k) = ph(i,k,j) + msfty(i,j)*rhs(i,k)*mut_inv(i)
+      if(top_lid .and. k.eq.k_end+1)rhs(i,k)=0.
+    ENDDO
+    ENDDO
+
+!  lower boundary condition on w
+
+!   Comments on map scale factors:
+!   Chain rule: if Z=Z(X,Y) [true at the surface] then
+!      dZ/dt = dZ/dX * dX/dt + dZ/dY * dY/dt, U=dX/dt, V=dY/dt
+!   using capitals to denote actual values
+!   In mapped values, u=U, v=V, z=Z, 1/dX=mx/dx, 1/dY=my/dy
+!      w = dz/dt = mx u dz/dx + my v dz/dy
+!   [where dz/dx is just the surface height change between x
+!    gridpoints, and dz/dy is the change between y gridpoints]
+!   [cf1, cf2 and cf3 do vertical weighting of u or v values nearest
+!    the surface]
+
+    DO i=i_start, i_end
+       w(i,1,j)=                                           &
+
+                msfty(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  ))  ) &
+
+               +msftx(i,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)
+!
+!   above surface, begin by adding delta t * previous (coupled) w tendency
+    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))           &
+              - 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)        &
+              + muave(i,j)) )
+       if(top_lid)w(i,k,j) = 0.
+    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)
+    ENDDO
+    ENDDO
+
+    IF (config_flags%damp_opt .eq. 3) THEN
+      DO k=k_end+1,2,-1
+      DO i=i_start, i_end
+          htop=(ph_1(i,k_end+1,j)+phb(i,k_end+1,j))/g
+          hk=(ph_1(i,k,j)+phb(i,k,j))/g
+          hbot=htop-hdepth
+          dampwt(k) = 0.
+          if(hk .ge. hbot)then
+            dampwt(k) = dampmag*sin(0.5*pi*(hk-hbot)/hdepth)*sin(0.5*pi*(hk-hbot)/hdepth)
+          endif
+          w(i,k,j) = (w(i,k,j) - dampwt(k)*mut(i,j)*w_save(i,k,j))/(1.+dampwt(k))
+      ENDDO
+      ENDDO
+    ENDIF
+
+    DO k=k_end+1,2,-1
+    DO i=i_start, i_end
+       ph(i,k,j) = rhs(i,k)+msfty(i,j)*.5*dts*g*(1.+epssm) &
+                      *w(i,k,j)/muts(i,j)
+    ENDDO
+    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,                &
+                     msfux, msfuy, msfvx, msfvx_inv, msfvy,  &
+                     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,      &
+                                                       msfux, msfuy,  &
+                                                       msfvx, msfvy, msfvx_inv
+
+  INTEGER :: mini, minj, mink
+
+
+  REAL, INTENT(IN   )  ::  epssm
+  INTEGER   :: i,j,k
+
+
+!<DESCRIPTION>
+!
+!  update the small-timestep time-averaged mass fluxes;  these
+!  are needed for consistent mass-conserving scalar advection.
+!
+!</DESCRIPTION>
+
+    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)/msfuy(i,j)
+      rv_m(i,k,j)  = rv_m(i,k,j) / number_of_small_timesteps   &
+                     + muv(i,j)*v_lin(i,k,j)*msfvx_inv(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)/msfuy(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)*msfvx_inv(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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_solvedebug_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_solvedebug_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_solvedebug_em.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_stoch.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_stoch.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/module_stoch.F	(revision 17)
@@ -0,0 +1,895 @@
+module module_stoch
+!***********************************************************************
+!
+! Purpose: Stochastic kinetic-energy backscatter scheme (SKEB)
+! Author : Judith Berner, NCAR  (berner@ucar.edu)
+! Date   : Dec 2020
+! Version: 1.0
+!
+!***********************************************************************
+!
+! The scheme introduces stochastic perturbations to the rotational wind 
+! components and to the potential temperature field. The stochastic 
+! perturbations are generated by independent autoregressive processes for 
+! each wavenumber and results in smooth spatially and temporally correlated patterns.
+! Details of the scheme and its performance in a meso-scale WRF-ensemble 
+! system are available in:
+!
+! Berner, J.,  S.-Y. Ha, J. P. Hacker, A. Fournier and C. Snyder 2010:
+! Model uncertainty in a mesoscale ensemble prediction system: Stochastic 
+! versus multi-physics representations,  MWR, accepted 
+! (available through the AMS early online release) 
+!
+! Features: 
+! Version 1.0: 
+!     Dissipation: Dissipation rates are assumed constant in space and time
+!     Vertical structure: Supports two options for vertical structure: 
+!                         0) constant
+!                         1) random phase
+!
+! Optional namelist parameters:
+!     stoch_opt           -   0) No stochastic parameterization
+!                         -   1) Stochastic kinetic-energy backscatter scheme (SKEB)
+!     stoch_vertstruc_opt -   0) Constant vertical structure 
+!                         -   1) Random phase vertical structure
+!     tot_backscat_psi    -   Strength of streamfunction perturbations
+!     tot_backscat-t      -   Strength of potential temperature perturbations
+!                       
+!***********************************************************************
+
+!     ------------------------------------------------------------------
+!************** DECLARE FIELDS AND VARIABLES FOR STOCHASTIC BACKSCATTER
+!     ------------------------------------------------------------------
+      implicit none
+      public :: SETUP_STOCH, UPDATE_STOCH,do_fftback_along_x,do_fftback_along_y,&
+                SP2GP_prep
+
+      INTEGER :: LMINFORC, LMAXFORC, KMINFORC, KMAXFORC, & 
+      &          LMINFORCT, LMAXFORCT, KMINFORCT, KMAXFORCT
+      REAL    :: ALPH, TOT_BACKSCAT_PSI, TOT_BACKSCAT_T,  REXPONENT
+
+!     ----------Fields for spectral transform -----------
+
+      INTEGER :: LENSAV
+      INTEGER,ALLOCATABLE:: wavenumber_k(:), wavenumber_l(:)
+      REAL, ALLOCATABLE :: WSAVE1(:),WSAVE2(:)
+
+!     --------- Others -------------------------------------------------
+      REAL, PARAMETER:: RPI= 3.141592653589793 !4.0*atan(1.0) 
+
+      save
+
+
+!=======================================================================
+contains
+!=======================================================================
+
+!     ------------------------------------------------------------------
+!!******** INITIALIZE STOCHASTIC KINETIC ENERGY BACKSCATTER (SKEB) *****
+!     ------------------------------------------------------------------
+
+      subroutine SETUP_STOCH( &
+                       VERTSTRUCC,VERTSTRUCS,                        & 
+                       SPT_AMP,SPSTREAM_AMP,                         & 
+                       stoch_vertstruc_opt,                          &
+                       ISEED1,ISEED2,itime_step,DX,DY,               &
+                       TOT_BACKSCAT_PSI,TOT_BACKSCAT_T,              &
+                       ids, ide, jds, jde, kds, kde,                 &
+                       ims, ime, jms, jme, kms, kme,                 &
+                       its, ite, jts, jte, kts, kte                  )
+
+      IMPLICIT NONE
+      INTEGER :: IER,IK,IL,iseed1,iseed2,I,J
+      INTEGER :: iseed(18),itime_step,stoch_vertstruc_opt
+      INTEGER :: KMAX,LMAX,LENSAV,ILEV
+      INTEGER , INTENT(IN)     ::  ids, ide, jds, jde, kds, kde,   &
+                                   ims, ime, jms, jme, kms, kme,   &
+                                   its, ite, jts, jte, kts, kte
+      REAL    :: DX,DY,RY,RX,RATIO_BACKSCAT,TOT_BACKSCAT_PSI,TOT_BACKSCAT_T
+      REAL    :: ZGAMMAN,ZTAU,ZCONSTF0,ZCONSTF0T,ZSIGMA2_EPS, RHOKLMAX,ZREF,RHOKL,EPS
+      REAL, DIMENSION (ims:ime,kms:kme,jms:jme) :: VERTSTRUCC,VERTSTRUCS
+      REAL, DIMENSION (ims:ime,jms:jme)         :: SPSTREAM_AMP,SPT_AMP
+      REAL, DIMENSION (ids:ide,jds:jde)         :: ZCHI,ZCHIT
+      LOGICAL :: is_print = .true.
+    
+!     --------- SETUP PARAMETERS ---------------------------------------
+      KMAX=(jde-jds)+1 !NLAT
+      LMAX=(ide-ids)+1 !NLON
+      RY=  KMAX*DY
+      RX=  LMAX*DY
+      LENSAV= 4*(KMAX+LMAX)+INT(LOG(REAL(KMAX))) + INT(LOG(REAL(LMAX))) + 8
+
+!     --------- ALLOCATE FIELDS FOR FFTPACK----------------------------
+      ALLOCATE(WSAVE1(LENSAV),WSAVE2(LENSAV))
+      ALLOCATE (wavenumber_k(jds:jde),wavenumber_l(ids:ide))
+
+!     -------- INITIALIZE FFTPACK ROUTINES -----------------------------
+      call CFFT1I (LMAX, WSAVE1, LENSAV, IER)
+      if(ier.ne. 0) write(*,95) ier
+
+      call CFFT1I (KMAX, WSAVE2, LENSAV, IER)
+      if(ier.ne. 0) write(*,95) ier
+      95 format('error in cFFT2I=  'i5)
+
+      call findindex( wavenumber_k, wavenumber_l,             &
+                      ids, ide, jds, jde, kds, kde,                &
+                      ims, ime, jms, jme, kms, kme,                &
+                      its, ite, jts, jte, kts, kte                 )
+
+!     ---------- INITIAIZE STOCHASTIC KINETIC ENERGY BACKSCATTER PARAMETERS-----------
+      REXPONENT=-1.83 !produces 2(p+1) kinetic energy spectra % p=-11/6=1.83 => k=-5/3 
+!      TOT_BACKSCAT_PSI = 2.0 
+!      TOT_BACKSCAT_T = 4.8E-04 ! 2.E-06/240 
+      KMINFORC=0      
+      KMAXFORC=min0(40,KMAX/2)
+      LMINFORC=KMINFORC 
+      LMAXFORC=KMAXFORC
+      KMINFORCT=0       
+      KMAXFORCT=KMAXFORC
+      LMINFORCT=KMINFORCT 
+      LMAXFORCT=KMAXFORCT
+      ZTAU    =  2.E04/12. 
+      ALPH   =  float(itime_step)/ZTAU ! approximation of 1.-exp(-itime_step/ZTAU)
+      ZSIGMA2_EPS=1./(12.0*ALPH)
+
+!     Sanity checks for forcing wavenumber range
+      IF (LMAXFORC>LMAX/2) then
+        LMAXFORC=min0(40,LMAX/2)-1
+        KMAXFORC=LMAXFORC
+      ENDIF
+      IF (LMAXFORCT>LMAX/2) then
+        LMAXFORCT=min0(40,LMAX/2)-1
+        KMAXFORCT=LMAXFORCT
+      ENDIF
+      IF ((LMINFORC>LMAXFORC).or.(KMINFORC>KMAXFORC)) then
+        WRITE(*,'('' LMINFORC>LMAXFORC IN SETUP_STOCH.F90'')')
+        STOP
+      ENDIF
+      IF ((KMAXFORC>KMAX/2).or.(LMAXFORC>LMAX/2)) then
+        WRITE(*,'('' KMAXFORC>KMAX/2 IN SETUP_STOCH.F90'')')
+        print*,KMAXFORC,KMAX/2
+        STOP
+      ENDIF
+      IF ((KMINFORC.ne.LMINFORC).or.(KMAXFORC.ne.LMAXFORC)) then
+        WRITE(*,'('' Forcing is non-homogenious in latitude and longitude'')')
+        WRITE(*,'('' If this is what you want, comment *stop* IN SETUP_STOCH.F90'')')
+        STOP
+      ENDIF
+
+!     Output of stochastic settings 
+      if (is_print) then
+      WRITE(*,'(''                                               '')')
+      WRITE(*,'('' =============================================='')')
+      WRITE(*,'('' >> Initializing stochastic kinetic-energy backscatter scheme << '')')
+      WRITE(*,'('' Total backscattered energy, TOT_BACKSCAT_PSI '',E12.5)') TOT_BACKSCAT_PSI
+      WRITE(*,'('' Total backscattered temperature, TOT_BACKSCAT_T '',E12.5)') TOT_BACKSCAT_T
+      WRITE(*,'('' Exponent for energy spectra, REXPONENT ='',E12.5)') REXPONENT
+      WRITE(*,'('' Minimal wavenumber of streamfunction forcing, LMINFORC ='',I10)') LMINFORC
+      WRITE(*,'('' Maximal wavenumber of streamfunction forcing, LMAXFORC ='',I10)') LMAXFORC
+      WRITE(*,'('' Minimal wavenumber of streamfunction forcing, KMINFORC ='',I10)') KMINFORC
+      WRITE(*,'('' Maximal wavenumber of streamfunction forcing, KMAXFORC ='',I10)') KMAXFORC
+      WRITE(*,'('' Minimal wavenumber of temperature forcing, LMINFORCT ='',I10)') LMINFORCT
+      WRITE(*,'('' Maximal wavenumber of temperature forcing, LMAXFORCT ='',I10)') LMAXFORCT
+      WRITE(*,'('' stoch_vertstruc_opt                             '',I10)') stoch_vertstruc_opt
+      WRITE(*,'('' Time step: itime_step='',I10)') itime_step 
+      WRITE(*,'('' Decorrelation time of noise, ZTAU ='',E12.5)') ZTAU
+      WRITE(*,'('' Variance of noise, ZSIGMA2_EPS  ='',E12.5)') ZSIGMA2_EPS
+      WRITE(*,'('' Autoregressive parameter 1-ALPH ='',E12.5)') 1.-ALPH
+      WRITE(*,'('' =============================================='')')
+      endif 
+
+!     ---------- INITIALIZE NOISE AMPLITUDES ----------------------------------
+!     Amplitudes for streamfunction and temperature perturbations: SPSTREAM_AMP , SPT_AMP
+!     Unit of SPSTREAM_AMP: sqrt(m^2/s^3 1/s m**2(p+1)) m**-2(p/2) = m^/s^2 * m**[(p+1)-p] = m^2/s^2 m 
+
+!     First the constants:
+      ZCHI    =  0.0
+      ! Fill lower left quadrant of ZCHI. For this range the indeces IK,IL 
+      do IK=KMINFORC,KMAXFORC
+      do IL=LMINFORC,LMAXFORC
+      if ((sqrt(float(IK*IK+IL*IL))).le.(KMAXFORC)) then
+        if ((IK>0).or.(IL>0)) then 
+          ZCHI(IL+1,IK+1)=((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT/2.)
+        endif
+      endif
+      enddo
+      enddo
+      ZGAMMAN  =  0.0
+      DO IK=KMINFORC,KMAXFORC
+      DO IL=LMINFORC,LMAXFORC
+      if (sqrt(float(IK*IK+IL*IL)).le.KMAXFORC) then
+        if ((IK>0).or.(IL>0)) then 
+          ZGAMMAN= ZGAMMAN + ((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT+1)
+        endif
+      endif
+      ENDDO
+      ENDDO
+      ZGAMMAN=4.0*ZGAMMAN !account for all quadrants, although only one is Filled
+      ZCONSTF0=SQRT(ALPH*TOT_BACKSCAT_PSI/(float(itime_step)*ZSIGMA2_EPS*ZGAMMAN))/(2*RPI)
+
+      ZCHIT    =  0.0
+      ! Fill lower left quadrant of ZCHI. For this range the indeces IK,IL 
+      do IK=KMINFORCT,KMAXFORCT
+      do IL=LMINFORCT,LMAXFORCT
+      if ((sqrt(float(IK*IK+IL*IL))).le.(KMAXFORCT)) then
+        if ((IK>0).or.(IL>0)) then 
+          ZCHIT(IL+1,IK+1)=((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT/2.)
+        endif
+      endif
+      enddo
+      enddo
+      ZGAMMAN  =  0.0
+      DO IK=KMINFORCT,KMAXFORCT
+      DO IL=LMINFORCT,LMAXFORCT
+      if (sqrt(float(IK*IK+IL*IL)).le.KMAXFORC) then
+        if ((IK>0).or.(IL>0)) then 
+          ZGAMMAN= ZGAMMAN + ((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT+1)
+        endif
+      endif
+      ENDDO
+      ENDDO
+      ZGAMMAN=4.0*ZGAMMAN !account for all quadrants, although only one is Filled
+      ZCONSTF0T=SQRT(ALPH*TOT_BACKSCAT_T/(float(itime_step)*ZSIGMA2_EPS*ZGAMMAN))/(2*RPI)
+
+!     Now the wavenumber-dependent amplitudes
+!     Note: There are symmetries and anti-symmetries to ensure real-valued back transforms
+!     Fill lower left quadrant of matrix of noise amplitudes for wavenumbers K=0,KMAX/2
+      SPSTREAM_AMP=0.0
+      SPT_AMP=0.0
+      SPT_AMP=0.0
+      DO IK=jts,jte
+      DO IL=its,ite
+      if ((IL .le. (LMAX/2+1)) .and. (IK .le. (KMAX/2+1)) ) then
+        SPSTREAM_AMP(IL,IK) = ZCONSTF0 *ZCHI(IL,IK)
+        SPT_AMP(IL,IK)      = ZCONSTF0T*ZCHIT(IL,IK)
+      endif
+      ENDDO
+      ENDDO
+
+      ! Fill other quadrants:
+      ! Upper left quadrant
+      DO IK=jts,jte
+      DO IL=its,ite
+      if ( (IL .gt. (LMAX/2+1)) .and. (IK .le. (KMAX/2+1)) ) then
+        SPSTREAM_AMP(IL,IK) =  ZCONSTF0 *ZCHI(LMAX-IL+2,IK)
+        SPT_AMP(IL,IK)      =  ZCONSTF0T*ZCHIT(LMAX-IL+2,IK)
+      endif
+      ENDDO
+      ENDDO
+
+!     Lower right quadrant
+      DO IK=jts,jte
+      DO IL=its,ite
+      if ((IK .gt. (KMAX/2+1)) .and. (IL.le.LMAX/2) ) then
+        SPSTREAM_AMP(IL,IK) = ZCONSTF0 *ZCHI(IL,KMAX-IK+2)
+        SPT_AMP(IL,IK)      = ZCONSTF0T*ZCHIT(IL,KMAX-IK+2)
+      endif
+      ENDDO
+      ENDDO
+
+!     Upper right quadrant
+      DO IK=jts,jte
+      DO IL=its,ite
+      if ((IK .gt. (KMAX/2+1)) .and. (IL.gt.LMAX/2) ) then
+        SPSTREAM_AMP(IL,IK) = ZCONSTF0 *ZCHI(LMAX-IL+2,KMAX-IK+2)
+        SPT_AMP(IL,IK)      = ZCONSTF0T*ZCHIT(LMAX-IL+2,KMAX-IK+2)
+      endif
+      ENDDO
+      ENDDO
+
+!     Array for vertical structure if desired
+      IF (stoch_vertstruc_opt==1) then
+      VERTSTRUCC=0.0
+      VERTSTRUCS=0.0
+      RHOKLMAX= sqrt(KMAX**2/DY**2 + LMAX**2/DX**2)
+      ZREF=32.0
+      DO ILEV=kds,kde
+        DO IK=jts,jte
+          DO IL=its,ite
+          if (IK.le.(KMAX/2)) then
+            RHOKL   = sqrt((IK+1)**2/DY**2 + (IL+1)**2/DX**2)
+            EPS     = ((RHOKLMAX - RHOKL)/ RHOKLMAX)  * (ILEV/ZREF) * RPI
+            VERTSTRUCC(IL,ILEV,IK) =  cos ( eps* (IK+1) )
+            VERTSTRUCS(IL,ILEV,IK) =  sin ( eps* (IK+1) )
+          endif
+          ENDDO
+        ENDDO
+        DO IK=jts,jte
+          DO IL=its,ite
+          if  (IK .gt. KMAX/2) then
+            VERTSTRUCC (IL,ILEV,IK) =   cos ( eps* (IK+1) )
+            VERTSTRUCS (IL,ILEV,IK) = - sin ( eps* (IK+1) )
+          endif
+          ENDDO
+        ENDDO
+       ENDDO
+       endif
+             
+!      Set seed for random number generator 
+       iseed=0
+       iseed(1) = iseed1
+       iseed(2) = iseed2
+       call random_seed
+       call random_seed(put=iseed(1:18))   ! set random seed.
+
+       END subroutine SETUP_STOCH
+
+!     ------------------------------------------------------------------
+!!************** UPDATE STOCHASTIC PATTERN IN WAVENUMBER SPACE**********
+!     ------------------------------------------------------------------
+
+      subroutine UPDATE_STOCH(                                         & 
+                       SPSTREAMFORCS,SPSTREAMFORCC,SPTFORCS,SPTFORCC,  &
+                       SPT_AMP,SPSTREAM_AMP,                           &
+                       ids, ide, jds, jde, kds, kde,                   &
+                       ims, ime, jms, jme, kms, kme,                   &
+                       its, ite, jts, jte, kts, kte                    )
+
+      IMPLICIT NONE
+
+      REAL, DIMENSION( ids:ide,jds:jde)      :: ZRANDNOSS1,ZRANDNOSC1,ZRANDNOSS2,ZRANDNOSC2
+      REAL, DIMENSION (ims:ime,jms:jme)      :: SPSTREAMFORCS,SPSTREAMFORCC,SPTFORCS,SPTFORCc,SPSTREAM_AMP,SPT_AMP
+      INTEGER , INTENT(IN)     ::               ids, ide, jds, jde, kds, kde,   &
+                                                ims, ime, jms, jme, kms, kme,   &
+                                                its, ite, jts, jte, kts, kte
+    
+      REAL :: Z
+      INTEGER ::IL, IK,LMAX,KMAX
+      LOGICAL :: LGAUSS
+
+      KMAX=(jde-jds)+1 !NLAT
+      LMAX=(ide-ids)+1 !NATX
+
+!     Pick the distribution of the noise
+!     Random noise uses global indexes to ensure necessary symmetries and anti-symmetries
+!     of random forcing when run on multiple processors
+      LGAUSS=.false.
+      IF (LGAUSS) then
+        DO IK=jds,jde
+          DO IL=ids,ide
+            call gauss_noise(z)
+            ZRANDNOSS1(IL,IK)=z
+            call gauss_noise(z)
+            ZRANDNOSC1(IL,IK)=z
+            call gauss_noise(z)
+            ZRANDNOSS2(IL,IK)=z
+            call gauss_noise(z)
+            ZRANDNOSC2(IL,IK)=z
+          ENDDO
+        ENDDO
+      ELSE
+        CALL RANDOM_NUMBER(ZRANDNOSS1)
+        CALL RANDOM_NUMBER(ZRANDNOSC1)
+        CALL RANDOM_NUMBER(ZRANDNOSS2)
+        CALL RANDOM_NUMBER(ZRANDNOSC2)
+      ENDIF
+
+!     Note: There are symmetries and anti-symmetries to ensure real-valued back transforms
+      DO IK=jts,jte
+      if (IK.le.(KMAX/2)) then
+        DO IL=its,ite
+          SPSTREAMFORCC(IL,IK)  = (1.-ALPH)*SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK)*(ZRANDNOSC1(IL,IK)-0.5)
+          SPSTREAMFORCS(IL,IK)  = (1.-ALPH)*SPSTREAMFORCS(IL,IK) + SPSTREAM_AMP(IL,IK)*(ZRANDNOSS1(IL,IK)-0.5)
+          SPTFORCC(IL,IK)       = (1.-ALPH)*SPTFORCC(IL,IK)      + SPT_AMP(IL,IK)     *(ZRANDNOSC2(IL,IK)-0.5)
+          SPTFORCS(IL,IK)       = (1.-ALPH)*SPTFORCS(IL,IK)      + SPT_AMP(IL,IK)     *(ZRANDNOSS2(IL,IK)-0.5)
+        ENDDO
+      endif
+      ENDDO
+
+      DO IK=jts,jte
+      if (IK.ge.(KMAX/2+1))then
+        DO IL=its,ite
+        if (IL>1) then
+          SPSTREAMFORCC(IL,IK)=   (1.-ALPH)*      SPSTREAMFORCC(IL,IK) + &
+                                                  SPSTREAM_AMP(IL,IK) * (ZRANDNOSC1(LMAX-IL+2,KMAX-IK+2)-0.5)
+          SPSTREAMFORCS(IL,IK)= -((1.-ALPH)*(-1.0*SPSTREAMFORCS(IL,IK))+ & 
+                                                  SPSTREAM_AMP(IL,IK) * (ZRANDNOSS1(LMAX-IL+2,KMAX-IK+2)-0.5))
+          SPTFORCC(IL,IK)=   (1.-ALPH)*      SPTFORCC(IL,IK) + &
+                                                  SPT_AMP(IL,IK) * (ZRANDNOSC2(LMAX-IL+2,KMAX-IK+2)-0.5)
+          SPTFORCS(IL,IK)= -((1.-ALPH)*(-1.0*SPTFORCS(IL,IK))+ & 
+                                                  SPT_AMP(IL,IK) * (ZRANDNOSS2(LMAX-IL+2,KMAX-IK+2)-0.5))
+        else
+          SPSTREAMFORCC(1,IK) =   (1.-ALPH) *     SPSTREAMFORCC(1,IK)  + & 
+                                                  SPSTREAM_AMP(1,IK)  * (ZRANDNOSC1(1,KMAX-IK+2)-0.5)
+          SPSTREAMFORCS(1,IK) = -((1.-ALPH)*(-1.0*SPSTREAMFORCS(1,IK))+ & 
+                                                  SPSTREAM_AMP(1,IK)  * (ZRANDNOSS1(1,KMAX-IK+2)-0.5))
+          SPTFORCC(1,IK) =   (1.-ALPH) *     SPTFORCC(1,IK)  + & 
+                                                  SPT_AMP(1,IK)  * (ZRANDNOSC2(1,KMAX-IK+2)-0.5)
+          SPTFORCS(1,IK) = -((1.-ALPH)*(-1.0*SPTFORCS(1,IK))+ & 
+                                                  SPT_AMP(1,IK)  * (ZRANDNOSS2(1,KMAX-IK+2)-0.5))
+         endif
+       ENDDO
+     endif
+     ENDDO
+     
+
+     END subroutine UPDATE_STOCH
+!     ------------------------------------------------------------------
+!************** ADD STOCHASTIC TENDENCIES TO PHYSICAL TENDENCIES********
+!     ------------------------------------------------------------------
+      SUBROUTINE UPDATE_STOCH_TEN(                                  &
+                       ru_tendf,rv_tendf,t_tendf,                   &
+                       GPUFORC,GPVFORC,GPTFORC,                     &
+                       ru_real,rv_real,rt_real,                     &
+                       ids, ide, jds, jde, kds, kde,                &
+                       ims, ime, jms, jme, kms, kme,                &
+                       its, ite, jts, jte, kts, kte,                &
+                       dt)
+
+       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, t_tendf,   & 
+                                        GPUFORC,GPVFORC,GPTFORC
+
+       REAL , DIMENSION(ims:ime , kms:kme, jms:jme),INTENT(IN) ::   &
+                                        ru_real,rv_real,rt_real
+
+       INTEGER :: I,J,K
+       REAL    :: dt
+    
+       DO j = jts,MIN(jde-1,jte)
+         DO k = kts,kte-1
+           DO i = its,ite 
+             GPUFORC(i,k,j)= ru_real(i,k,j)
+             ru_tendf(i,k,j) = ru_tendf(i,k,j) + GPUFORC(i,k,j)
+           ENDDO
+         ENDDO
+       ENDDO
+
+       DO j = jts,jte
+         DO k = kts,kte-1
+           DO i = its,MIN(ide-1,ite)
+             GPVFORC(i,k,j)= rv_real(i,k,j)
+             rv_tendf(i,k,j) = rv_tendf(i,k,j) +  GPVFORC(i,k,j)
+           ENDDO
+         ENDDO
+       ENDDO
+
+       DO j = jts,MIN(jde-1,jte)
+         DO k = kts,kte-1
+           DO i = its,MIN(ide-1,ite)
+             GPTFORC(i,k,j)= rt_real(i,k,j)
+             t_tendf(i,k,j) = t_tendf(i,k,j) +  GPTFORC(i,k,j)
+           ENDDO
+         ENDDO
+       ENDDO
+
+       END SUBROUTINE UPDATE_STOCH_TEN
+!     ------------------------------------------------------------------
+
+      SUBROUTINE UPDATE_STOCH_TEN_SUBDOMAINS(ru_tendf,rv_tendf,t_tendf, &
+                       GPUFORC,GPVFORC,GPTFORC,                    &
+                       ids, ide, jds, jde, kds, kde,                &
+                       ims, ime, jms, jme, kms, kme,                &
+                       its, ite, jts, jte, kts, kte,                &
+                       dt                                  )
+
+       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, t_tendf
+
+       REAL , DIMENSION(ims:ime , kms:kme, jms:jme),INTENT(IN) :: &
+                                       GPUFORC,GPVFORC,GPTFORC 
+
+       INTEGER :: I,J,K
+       REAL  :: dt
+
+       DO j = jts,MIN(jde-1,jte)
+         DO k = kts,kte-1
+           DO i = its,ite 
+             ru_tendf(i,k,j) = ru_tendf(i,k,j) +  GPUFORC(i,k,j) 
+           ENDDO
+         ENDDO
+       ENDDO
+
+       DO j = jts,jte
+         DO i = its,MIN(ide-1,ite)
+           DO k = kts,kte-1
+             rv_tendf(i,k,j) = rv_tendf(i,k,j) +  GPVFORC(i,k,j) 
+           ENDDO
+         ENDDO
+       ENDDO
+
+       DO j = jts,MIN(jde-1,jte)
+         DO k = kts,kte-1
+           DO i = its,MIN(ide-1,ite)
+             t_tendf(i,k,j) = t_tendf(i,k,j) + GPTFORC(i,k,j) 
+           ENDDO
+         ENDDO
+       ENDDO
+
+       END SUBROUTINE UPDATE_STOCH_TEN_SUBDOMAINS
+!     ------------------------------------------------------------------
+!!************** TRANSFORM FROM SPHERICAL HARMONICS TO GRIDPOILT SPACE**
+!     ------------------------------------------------------------------
+       subroutine SP2GP_prep(                                               & 
+                       SPSTREAMFORCS,SPSTREAMFORCC,SPTFORCS,SPTFORCC,  &             
+                       VERTSTRUCC,VERTSTRUCS,                          &
+                       RU_REAL,RV_REAL,RT_REAL,                        & 
+                       RU_IMAG,RV_IMAG,RT_IMAG,                        & 
+                       dx,dy,stoch_vertstruc_opt,                      & 
+                       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)          :: SPSTREAMFORCS,SPSTREAMFORCC,SPTFORCS,SPTFORCC
+      REAL, DIMENSION    (ims:ime , kms:kme, jms:jme) :: RU_REAL,RV_REAL,RT_REAL,RU_IMAG,RV_IMAG,RT_IMAG, & 
+                                                         VERTSTRUCC,VERTSTRUCS
+      INTEGER :: IK,IL,ILEV,NLAT,NLON,stoch_vertstruc_opt
+      REAL    :: dx,dy,RY,RX
+
+      NLAT=(jde-jds)+1 !KMAX
+      NLON=(ide-ids)+1 !LMAX
+      RY=  NLAT*DY
+      RX=  NLON*DX
+
+
+      DO ILEV=kts,kte
+
+      if (stoch_vertstruc_opt==0) then
+        DO IL=its,ite
+        DO IK=jts,jte
+          rt_real(IL,ILEV,IK)  = SPTFORCC(IL,IK)
+          rt_imag(IL,ILEV,IK)  = SPTFORCS(IL,IK)
+          ru_real(IL,ILEV,IK)  = 2*RPI/RY*  wavenumber_k(IK) * SPSTREAMFORCS(IL,IK)
+          ru_imag(IL,ILEV,IK)  =-2*RPI/RY*  wavenumber_k(IK) * SPSTREAMFORCC(IL,IK)
+          rv_real(IL,ILEV,IK)  =-2*RPI/RX*  wavenumber_l(IL) * SPSTREAMFORCS(IL,IK)
+          rv_imag(IL,ILEV,IK)  = 2*RPI/RX*  wavenumber_l(IL) * SPSTREAMFORCC(IL,IK)
+        ENDDO
+        ENDDO
+
+       elseif (stoch_vertstruc_opt==1) then
+ 
+        DO IL=its,ite
+        DO IK=jts,jte
+          rt_real(IL,ILEV,IK)  = SPTFORCC(IL,IK)*VERTSTRUCC(IL,ILEV,IK)      - SPTFORCS(IL,IK)*VERTSTRUCS(IL,ILEV,IK)
+          rt_imag(IL,ILEV,IK)  = SPTFORCC(IL,IK)*VERTSTRUCS(IL,ILEV,IK)      + SPTFORCS(IL,IK)*VERTSTRUCC(IL,ILEV,IK)
+          ru_real(IL,ILEV,IK)  = 2*RPI/RY*  wavenumber_k(IK) *&
+                            (+SPSTREAMFORCC(IL,IK)*VERTSTRUCS(IL,ILEV,IK) + SPSTREAMFORCS(IL,IK)*VERTSTRUCC(IL,ILEV,IK))
+          ru_imag(IL,ILEV,IK)  = 2*RPI/RY*  wavenumber_k(IK) *&
+                            (-SPSTREAMFORCC(IL,IK)*VERTSTRUCC(IL,ILEV,IK) + SPSTREAMFORCS(IL,IK)*VERTSTRUCS(IL,ILEV,IK))
+          rv_real(IL,ILEV,IK)  = 2*RPI/RX* wavenumber_l(IL) *&
+                             (-SPSTREAMFORCC(IL,IK)*VERTSTRUCS(IL,ILEV,IK) - SPSTREAMFORCS(IL,IK)*VERTSTRUCC(IL,ILEV,IK))
+          rv_imag(IL,ILEV,IK)  = 2*RPI/RX* wavenumber_l(IL) *&
+                             (+SPSTREAMFORCC(IL,IK)*VERTSTRUCC(IL,ILEV,IK) - SPSTREAMFORCS(IL,IK)*VERTSTRUCS(IL,ILEV,IK))
+      
+        ENDDO
+        ENDDO
+
+      endif 
+      ENDDO !ILEV 
+
+     
+      END subroutine SP2GP_prep
+
+!     ------------------------------------------------------------------
+!!************** SUBROUTINE DO_FFTBACK_ALONG_X
+!     ------------------------------------------------------------------
+       subroutine do_fftback_along_x(fieldc_U_xxx,fields_U_xxx,     &
+                                     fieldc_V_xxx,fields_V_xxx,     &
+                                     fieldc_T_xxx,fields_T_xxx,     &
+                               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,    &
+                               k_start , k_end                   &
+                              )
+       IMPLICIT NONE
+ 
+       INTEGER, INTENT(IN) :: 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,    & 
+                             k_start , k_end                   
+  
+       REAL, DIMENSION    (imsx:imex, kmsx:kmex, jmsx:jmex) :: fieldc_U_xxx,fields_U_xxx, & 
+                                                               fieldc_V_xxx,fields_V_xxx, & 
+                                                               fieldc_T_xxx,fields_T_xxx
+
+       COMPLEX, DIMENSION (ipsx:ipex)            :: dummy_complex
+       INTEGER                                   :: IER,LENWRK,KMAX,LMAX,I,J,K
+       REAL, ALLOCATABLE                         :: WORK(:)
+
+       CHARACTER (LEN=160) :: mess
+
+
+       KMAX=(jde-jds)+1
+       LMAX=(ide-ids)+1
+
+       LENWRK=2*KMAX*LMAX
+       ALLOCATE(WORK(LENWRK))
+       LENSAV= 4*(KMAX+LMAX)+INT(LOG(REAL(KMAX))) + INT(LOG(REAL(LMAX))) + 8
+
+       DO k=kpsx,kpex 
+         DO j = jpsx, jpex
+           DO i = ipsx, ipex
+             dummy_complex(i)=cmplx(fieldc_U_xxx(i,k,j),fields_U_xxx(i,k,j))
+           ENDDO
+           CALL cFFT1B (LMAX, 1 ,dummy_complex,LMAX, WSAVE1, LENSAV, WORK, LENWRK, IER)
+           if (ier.ne.0) then 
+              WRITE(mess,FMT='(A)') 'error in cFFT1B in do_fftback_along_x, field U'
+              CALL wrf_debug(0,mess)
+           end if
+           DO i = ipsx, ipex
+             fieldc_U_xxx(i,k,j)=real(dummy_complex(i))
+             fields_U_xxx(i,k,j)=imag(dummy_complex(i))
+           END DO
+         END DO
+       END DO
+
+       DO k=kpsx,kpex 
+         DO j = jpsx, jpex
+           DO i = ipsx, ipex
+             dummy_complex(i)=cmplx(fieldc_V_xxx(i,k,j),fields_V_xxx(i,k,j))
+           ENDDO
+           CALL cFFT1B (LMAX, 1 ,dummy_complex,LMAX, WSAVE1, LENSAV, WORK, LENWRK, IER)
+           if (ier.ne.0) then 
+              WRITE(mess,FMT='(A)') 'error in cFFT1B in do_fftback_along_x, field V'
+              CALL wrf_debug(0,mess)
+           end if
+           DO i = ipsx,ipex
+             fieldc_V_xxx(i,k,j)=real(dummy_complex(i))
+             fields_V_xxx(i,k,j)=imag(dummy_complex(i))
+           END DO
+         END DO
+       END DO 
+
+       DO k=kpsx,kpex 
+         DO j = jpsx, jpex
+           DO i = ipsx, ipex
+             dummy_complex(i)=cmplx(fieldc_T_xxx(i,k,j),fields_T_xxx(i,k,j))
+           ENDDO
+           CALL cFFT1B (LMAX, 1 ,dummy_complex,LMAX, WSAVE1, LENSAV, WORK, LENWRK, IER)
+           if (ier.ne.0) then 
+              WRITE(mess,FMT='(A)') 'error in cFFT1B in do_fftback_along_x, field T'
+              CALL wrf_debug(0,mess)
+           end if
+           DO i = ipsx, ipex
+            fieldc_T_xxx(i,k,j)=real(dummy_complex(i))
+            fields_T_xxx(i,k,j)=imag(dummy_complex(i))
+           END DO
+         END DO
+       END DO !
+
+       DEALLOCATE(WORK)
+       end subroutine do_fftback_along_x
+
+!!     ------------------------------------------------------------------
+!!!************** SUBROUTINE DO_FFTBACK_ALONG_Y
+!!     ------------------------------------------------------------------
+       subroutine do_fftback_along_y(fieldc_U_yyy,fields_U_yyy,     &
+                                     fieldc_V_yyy,fields_V_yyy,     &
+                                     fieldc_T_yyy,fields_T_yyy,     &
+                               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,    &
+                               k_start , k_end                   &
+                              )
+       IMPLICIT NONE
+ 
+       INTEGER :: IER,LENWRK,KMAX,LMAX,I,J,K
+ 
+       INTEGER, INTENT(IN) :: 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,    & 
+                             k_start , k_end                   
+  
+       REAL, DIMENSION    (imsy:imey, kmsy:kmey, jmsy:jmey) :: fieldc_U_yyy,fields_U_yyy, & 
+                                                               fieldc_V_yyy,fields_V_yyy, & 
+                                                               fieldc_T_yyy,fields_T_yyy
+
+       COMPLEX, DIMENSION (jpsy:jpey)            :: dummy_complex
+       REAL, ALLOCATABLE :: WORK(:)
+
+       CHARACTER (LEN=160) :: mess
+
+       KMAX=(jde-jds)+1
+       LMAX=(ide-ids)+1
+       LENWRK=2*KMAX*LMAX
+       ALLOCATE(WORK(LENWRK))
+       LENSAV= 4*(KMAX+LMAX)+INT(LOG(REAL(KMAX))) + INT(LOG(REAL(LMAX))) + 8
+
+        DO k=kpsy,kpey
+          DO i = ipsy, ipey
+            DO j = jpsy,jpey
+            dummy_complex(j)=cmplx(fieldc_U_yyy(i,k,j),fields_U_yyy(i,k,j))
+            ENDDO
+            CALL cFFT1B (KMAX, 1 ,dummy_complex,KMAX, WSAVE2, LENSAV, WORK, LENWRK, IER)
+            if (ier.ne.0) then 
+               WRITE(mess,FMT='(A)') 'error in cFFT1B in do_fftback_along_y, field U'
+               CALL wrf_debug(0,mess)
+            end if
+            DO j = jpsy, jpey
+            fieldc_U_yyy(i,k,j)=real(dummy_complex(j))
+            fields_U_yyy(i,k,j)=imag(dummy_complex(j))
+            END DO
+          END DO
+        END DO ! k_start-k_end
+
+        DO k=kpsy,kpey 
+          DO i = ipsy, ipey
+            DO j = jpsy, jpey
+            dummy_complex(j)=cmplx(fieldc_V_yyy(i,k,j),fields_V_yyy(i,k,j))
+            ENDDO
+            CALL cFFT1B (KMAX, 1 ,dummy_complex,KMAX, WSAVE2, LENSAV, WORK, LENWRK, IER)
+            if (ier.ne.0) then 
+               WRITE(mess,FMT='(A)') 'error in cFFT1B in do_fftback_along_y, field V'
+               CALL wrf_debug(0,mess)
+            end if
+            DO j = jpsy, jpey
+            fieldc_V_yyy(i,k,j)=real(dummy_complex(j))
+            fields_V_yyy(i,k,j)=imag(dummy_complex(j))
+            END DO
+          END DO
+        END DO ! k_start-k_end
+
+        DO k=kpsy,kpey 
+          DO i = ipsy, ipey
+            DO j = jpsy,jpey
+            dummy_complex(j)=cmplx(fieldc_T_yyy(i,k,j),fields_T_yyy(i,k,j))
+            ENDDO
+            CALL cFFT1B (KMAX, 1 ,dummy_complex,KMAX, WSAVE2, LENSAV, WORK, LENWRK, IER)
+            if (ier.ne.0) then 
+               WRITE(mess,FMT='(A)') 'error in cFFT1B in do_fftback_along_y, field T'
+               CALL wrf_debug(0,mess)
+            end if
+            DO j = jpsy,jpey
+            fieldc_T_yyy(i,k,j)=real(dummy_complex(j))
+            fields_T_yyy(i,k,j)=imag(dummy_complex(j))
+            END DO
+          END DO
+        END DO ! k_start-k_end
+
+       DEALLOCATE(WORK)
+       end subroutine do_fftback_along_y
+!     ------------------------------------------------------------------
+!!************** TRANSFORM FROM GRIDPOILT SPACE TO SPHERICAL HARMONICS **
+!     ------------------------------------------------------------------
+      subroutine findindex( wavenumber_k, wavenumber_L,             & 
+                       ids, ide, jds, jde, kds, kde,                &
+                       ims, ime, jms, jme, kms, kme,                &
+                       its, ite, jts, jte, kts, kte                 )
+
+      IMPLICIT NONE
+      INTEGER :: IK,IL,KMAX,LMAX
+      INTEGER, DIMENSION (jds:jde)::  wavenumber_k
+      INTEGER, DIMENSION (ids:ide)::  wavenumber_l
+      INTEGER , INTENT(IN)     ::  ids, ide, jds, jde, kds, kde,   &
+                                   ims, ime, jms, jme, kms, kme,   &
+                                   its, ite, jts, jte, kts, kte
+      KMAX=(jde-jds)+1 
+      LMAX=(ide-ids)+1 
+
+      !map wave numbers K,L to indeces IK, IL
+      DO IK=1,KMAX/2+1 
+        wavenumber_k(IK)=IK-1 
+      ENDDO
+      DO IK=KMAX,KMAX/2+2,-1
+        wavenumber_k(IK)=IK-KMAX-1 
+      ENDDO
+      DO IL=1,LMAX/2+1 
+        wavenumber_l(IL)=IL-1
+      ENDDO
+      DO IL=LMAX,LMAX/2+2,-1
+        wavenumber_l(IL)=IL-LMAX-1 
+      ENDDO
+
+      END subroutine findindex
+       
+!     ------------------------------------------------------------------
+     subroutine gauss_noise(z)
+      real :: z                    ! output
+      real :: x,y,r, coeff         ! INPUT
+
+!  [2.1] Get two uniform variate random numbers IL range 0 to 1:
+
+      do
+
+      call random_number( x )
+      call random_number( y )
+
+!     [2.2] Transform to range -1 to 1 and calculate sum of squares:
+
+      x = 2.0 * x - 1.0
+      y = 2.0 * y - 1.0
+      r = x * x + y * y
+
+      if ( r > 0.0 .and. r < 1.0 ) exit
+
+      end do
+!
+!  [2.3] Use Box-Muller transformation to get normal deviates:
+
+      coeff = sqrt( -2.0 * log(r) / r )
+      z = coeff * x
+
+     end subroutine gauss_noise
+!     ------------------------------------------------------------------
+     SUBROUTINE rand_seed (config_flags, seed1, seed2,nens )
+      USE module_configure
+      IMPLICIT NONE
+!
+!  Structure that contains run-time configuration (namelist) data for domain
+      TYPE (grid_config_rec_type)                       :: config_flags
+!
+! Arguments
+     INTEGER, INTENT(OUT ) :: seed1, seed2, nens
+
+! Local
+      integer            :: date_time(8)
+      integer*8          :: yyyy,mmdd,newtime
+      integer*8          :: ihr,isc,idiv
+      integer*8          :: iphys
+      character (len=10) :: real_clock(3), time
+!
+      LOGICAL :: is_print = .false.
+!
+! Read CPU time
+        call date_and_time(real_clock(1), real_clock(2),&
+                           real_clock(3), date_time)
+        read(real_clock(1),'(i4)') yyyy
+        read(real_clock(1),'(4x,i4)') mmdd
+        read(real_clock(2),'(i6,1x,i3)') ihr,isc        ! ihr = hhmmss , isc - milliseconds of the minute
+        newtime = yyyy*mmdd+ihr+isc
+        if (is_print) then
+        print*,'real_clock: ',real_clock
+        print*,'real_clock(1): ',real_clock(1)
+        print*,'real_clock(2): ',real_clock(2)
+        print*,'real_clock(3): ',real_clock(3)
+        print*,'date_time: ',date_time
+        print*,'newtime: ',newtime
+!
+!  get a seed number (w/ physics options for each ensemble member)
+!
+        print *,'physics_options:',&
+                config_flags%sf_surface_physics,&
+                config_flags%ra_lw_physics, &
+                config_flags%ra_sw_physics, &
+                config_flags%mp_physics, &
+                config_flags%sf_sfclay_physics,&
+                config_flags%bl_pbl_physics,&
+                config_flags%cu_physics
+        endif !isprint
+
+        iphys = config_flags%sf_surface_physics * 1000000  + &
+                config_flags%ra_lw_physics      * 100000   + &
+                config_flags%ra_sw_physics      * 10000    + &
+                config_flags%mp_physics         * 1000     + &
+                config_flags%sf_sfclay_physics  * 100      + &
+                config_flags%bl_pbl_physics     * 10       + &
+                config_flags%cu_physics
+ 
+ 
+        seed1 = newtime+iphys+nens*1000000
+        seed2 = mod(newtime+iphys+nens*1000000,idiv)
+        if(is_print) print *,'Rand_seed (iphys/newtime/idiv):',iphys,newtime,idiv,nens
+
+        end SUBROUTINE rand_seed
+
+        end module module_stoch
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/namelist_remappings_em.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/namelist_remappings_em.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/namelist_remappings_em.h	(revision 17)
@@ -0,0 +1,75 @@
+!WRF:DRIVER_LAYER:CORE_SPECIFIC
+
+! Namelist remappings.  This file is included by the initial_config
+! routine in frame/module_configure.F and provides em_core specific
+! remappings of namelist variables
+
+! allow fdda specific namelist variables to map onto auxinput streams 9 and 10
+      model_config_rec%auxinput10_begin_d     =       model_config_rec%gfdda_begin_d
+      model_config_rec%auxinput10_begin_h     =       model_config_rec%gfdda_begin_h
+      model_config_rec%auxinput10_begin_m     =       model_config_rec%gfdda_begin_m
+      model_config_rec%auxinput10_begin_s     =       model_config_rec%gfdda_begin_s
+      model_config_rec%auxinput10_begin_y     =       model_config_rec%gfdda_begin_y
+      model_config_rec%auxinput10_end_d       =       model_config_rec%gfdda_end_d
+      model_config_rec%auxinput10_end_h       =       model_config_rec%gfdda_end_h
+      model_config_rec%auxinput10_end_m       =       model_config_rec%gfdda_end_m
+      model_config_rec%auxinput10_end_s       =       model_config_rec%gfdda_end_s
+      model_config_rec%auxinput10_end_y       =       model_config_rec%gfdda_end_y
+      model_config_rec%auxinput10_inname      =       model_config_rec%gfdda_inname
+      model_config_rec%auxinput10_interval    =       model_config_rec%gfdda_interval
+      model_config_rec%auxinput10_interval_d  =       model_config_rec%gfdda_interval_d
+      model_config_rec%auxinput10_interval_h  =       model_config_rec%gfdda_interval_h
+      model_config_rec%auxinput10_interval_m  =       model_config_rec%gfdda_interval_m
+      model_config_rec%auxinput10_interval_s  =       model_config_rec%gfdda_interval_s
+      model_config_rec%auxinput10_interval_y  =       model_config_rec%gfdda_interval_y
+      model_config_rec%io_form_auxinput10     =       model_config_rec%io_form_gfdda
+      model_config_rec%auxinput9_begin_d      =       model_config_rec%sgfdda_begin_d
+      model_config_rec%auxinput9_begin_h      =       model_config_rec%sgfdda_begin_h
+      model_config_rec%auxinput9_begin_m      =       model_config_rec%sgfdda_begin_m
+      model_config_rec%auxinput9_begin_s      =       model_config_rec%sgfdda_begin_s
+      model_config_rec%auxinput9_begin_y      =       model_config_rec%sgfdda_begin_y
+      model_config_rec%auxinput9_end_d        =       model_config_rec%sgfdda_end_d
+      model_config_rec%auxinput9_end_h        =       model_config_rec%sgfdda_end_h
+      model_config_rec%auxinput9_end_m        =       model_config_rec%sgfdda_end_m
+      model_config_rec%auxinput9_end_s        =       model_config_rec%sgfdda_end_s
+      model_config_rec%auxinput9_end_y        =       model_config_rec%sgfdda_end_y
+      model_config_rec%auxinput9_inname       =       model_config_rec%sgfdda_inname
+      model_config_rec%auxinput9_interval     =       model_config_rec%sgfdda_interval
+      model_config_rec%auxinput9_interval_d   =       model_config_rec%sgfdda_interval_d
+      model_config_rec%auxinput9_interval_h   =       model_config_rec%sgfdda_interval_h
+      model_config_rec%auxinput9_interval_m   =       model_config_rec%sgfdda_interval_m
+      model_config_rec%auxinput9_interval_s   =       model_config_rec%sgfdda_interval_s
+      model_config_rec%auxinput9_interval_y   =       model_config_rec%sgfdda_interval_y
+      model_config_rec%io_form_auxinput9      =       model_config_rec%io_form_sgfdda
+      IF (model_config_rec%prec_acc_dt(1) .gt. 0.) model_config_rec%prec_acc_opt = 1
+      IF (model_config_rec%bucket_mm .gt. 0.) model_config_rec%bucketr_opt = 1
+#ifdef PLANET
+!***************** special conversion for timesteps *********************
+! 2004-12-07 ADT Notes
+! NB: P2SI needs to defined in multiple places.  Right now this
+! requirement is a kludge, and if I can find something more elegant
+! I will try to implement it later.
+!
+! Beware: dt as the namelist timestep is now obsolete.  The new
+! variable "timestep" (which is an *integer* number of seconds),
+! with the (optional) additional specification of a fraction (to
+! make non-integer timesteps) now acts as the true timestep.
+! In share/set_timekeeping.F the integer(s) are converted to a real
+! number and put back in dt anyway!
+! We will deal with the case of the integer variables in
+! share/set_timekeeping.F itself.  For now, since they left dt in
+! the namelist definition, I will leave this here just in case ...
+      model_config_rec%dt    = dt    * P2SI
+! All of the following variables are told to be input in *MINUTES*
+! These values are converted to units of timesteps in the various
+! init routines in phys/module_physics_init.F by dividing by the
+! formula STEP = (xxDT*60./dt).  So it seems safe to multiply them
+! by P2SI here (with the exception of adding roundoff error later).
+! See notes in phys/module_radiation_driver for the radt example.
+      model_config_rec%radt  = radt  * P2SI
+      model_config_rec%bldt  = bldt  * P2SI
+      model_config_rec%cudt  = cudt  * P2SI
+      model_config_rec%gsmdt = gsmdt * P2SI
+!************************************************************************
+#endif
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/nest_init_utils.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/nest_init_utils.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/nest_init_utils.F	(revision 17)
@@ -0,0 +1,412 @@
+SUBROUTINE init_domain_constants_em ( parent , nest )
+   USE module_domain, ONLY : domain
+   IMPLICIT NONE
+   TYPE(domain)  :: parent , nest
+
+   INTEGER iswater, islake, isice, isurban, isoilwater, map_proj, julyr, julday
+   REAL    truelat1 , truelat2 , gmt , moad_cen_lat , stand_lon, pole_lat, pole_lon
+   CHARACTER (LEN=256) :: char_junk
+
+! single-value constants
+
+   nest%p_top   = parent%p_top
+   nest%save_topo_from_real   = parent%save_topo_from_real
+   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
+   nest%iswater = parent%iswater
+   nest%isice   = parent%isice
+   nest%isurban = parent%isurban
+   nest%islake  = parent%islake
+   nest%isoilwater = parent%isoilwater
+   nest%mminlu  = trim(parent%mminlu)
+
+   CALL nl_get_mminlu ( 1, char_junk )
+   CALL nl_get_iswater( 1, iswater )
+   CALL nl_get_islake ( 1, islake )
+   CALL nl_get_isice  ( 1, isice )
+   CALL nl_get_isurban( 1, isurban )
+   CALL nl_get_isoilwater(1, isoilwater )
+   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_pole_lat ( 1 , pole_lat )
+   CALL nl_get_pole_lon ( 1 , pole_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_islake  ( nest%id, islake )
+     CALL nl_set_isice   ( nest%id, isice )
+     CALL nl_set_isurban ( nest%id, isurban )
+     CALL nl_set_isoilwater ( nest%id, isoilwater )
+     CALL nl_set_mminlu ( nest%id, char_junk )
+     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_pole_lat ( nest%id , pole_lat )
+     CALL nl_set_pole_lon ( nest%id , pole_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%islake  = islake
+   nest%isice   = isice
+   nest%isoilwater = isoilwater
+   nest%mminlu  = trim(char_junk)
+   nest%truelat1= truelat1
+   nest%truelat2= truelat2
+   nest%moad_cen_lat= moad_cen_lat
+   nest%stand_lon= stand_lon
+   nest%pole_lat= pole_lat
+   nest%pole_lon= pole_lon
+   nest%map_proj= map_proj
+
+   nest%step_number  = parent%step_number
+
+! 1D constants (Z)
+
+   nest%fnm    = parent%fnm
+   nest%fnp    = parent%fnp
+   nest%rdnw   = parent%rdnw
+   nest%rdn    = parent%rdn
+   nest%dnw    = parent%dnw
+   nest%dn     = parent%dn
+   nest%znu    = parent%znu
+   nest%znw    = parent%znw
+   nest%t_base = parent%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 copy_3d_field ( 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 copy_3d_field
+
+SUBROUTINE adjust_tempqv ( mub, save_mub, znw, p_top, &
+                           th, pp, qv,  &
+                           ids , ide , jds , jde , kds , kde , &
+                           ims , ime , jms , jme , kms , kme , &
+                           ips , ipe , jps , jpe , kps , kpe )
+
+   !USE module_configure
+   !USE module_domain
+   USE module_model_constants
+
+   !USE module_bc
+   !USE module_io_domain
+   !USE module_state_description
+   !USE module_timing
+   !USE module_soil_pre
+   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,jms:jme) , INTENT(IN)    :: mub, save_mub
+   REAL , DIMENSION(kms:kme) , INTENT(IN)    :: znw
+   REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: th, pp, qv
+
+   REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: p_old, p_new, rh
+   REAL :: es,dth,tc,e,dth1
+   INTEGER :: i , j , k
+
+   real p_top
+
+
+! p_old = full pressure before terrain blending; also compute initial RH
+! which is going to be conserved during terrain blending
+   DO j = jps , MIN(jpe, jde-1)
+      DO k = kps , kpe-1
+         DO i = ips , MIN(ipe, ide-1)
+            p_old(i,k,j) = 0.5*(znw(k+1)+znw(k))*save_mub(i,j) + p_top + pp(i,k,j)
+            tc = (th(i,k,j)+300.)*(p_old(i,k,j)/1.e5)**(2./7.) - 273.15
+            es = 610.78*exp(17.0809*tc/(234.175+tc))
+            e = qv(i,k,j)*p_old(i,k,j)/(0.622+qv(i,k,j))
+            rh(i,k,j) = e/es
+         END DO
+      END DO
+   END DO
+
+! p_new = full pressure after terrain blending; also compute temperature correction and convert RH back to QV
+   DO j = jps , MIN(jpe, jde-1)
+      DO k = kps , kpe-1
+         DO i = ips , MIN(ipe, ide-1)
+            p_new(i,k,j) = 0.5*(znw(k+1)+znw(k))*mub(i,j) + p_top + pp(i,k,j)
+! 2*(g/cp-6.5e-3)*R_dry/g = -191.86e-3
+            dth1 = -191.86e-3*(th(i,k,j)+300.)/(p_new(i,k,j)+p_old(i,k,j))*(p_new(i,k,j)-p_old(i,k,j))
+            dth = -191.86e-3*(th(i,k,j)+0.5*dth1+300.)/(p_new(i,k,j)+p_old(i,k,j))*(p_new(i,k,j)-p_old(i,k,j))
+            th(i,k,j) = th(i,k,j)+dth
+            tc = (th(i,k,j)+300.)*(p_new(i,k,j)/1.e5)**(2./7.) - 273.15
+            es = 610.78*exp(17.0809*tc/(234.175+tc))
+            e = rh(i,k,j)*es
+            qv(i,k,j) = 0.622*e/(p_new(i,k,j)-e)
+         END DO
+      END DO
+   END DO
+
+
+END SUBROUTINE adjust_tempqv
+
+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, ONLY : 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 "dummy_new_args.inc"
+!
+                 )
+!
+! perform core specific updates, exchanges after
+! model feedback  (called from med_feedback_domain) -John
+!
+
+! Driver layer modules
+   USE module_domain, ONLY : domain, get_ijk_from_grid
+   USE module_configure
+   USE module_driver_constants
+   USE module_machine
+   USE module_tiles
+#ifdef DM_PARALLEL
+   USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask
+   USE module_comm_dm, ONLY : HALO_EM_FEEDBACK_sub
+#else
+   USE module_dm
+#endif
+   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 <dummy_new_decl.inc>
+
+   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" )
+
+!  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
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/shift_domain_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/shift_domain_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/shift_domain_em.F	(revision 17)
@@ -0,0 +1,144 @@
+SUBROUTINE shift_domain_em ( grid , disp_x, disp_y &
+!
+# include <dummy_new_args.inc>
+!
+                           )
+   USE module_state_description
+   USE module_domain, ONLY : domain, get_ijk_from_grid
+   USE module_domain_type, ONLY : fieldlist
+   USE module_timing
+   USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec
+#ifdef DM_PARALLEL
+   USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, itrace
+   USE module_comm_dm, ONLY : SHIFT_HALO_sub
+#else
+   USE module_dm
+#endif
+   IMPLICIT NONE
+  ! Arguments
+   INTEGER disp_x, disp_y       ! number of parent domain points to move
+   TYPE(domain) , POINTER                     :: grid
+  ! Local 
+   INTEGER i, j, ii, ipf
+   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 idim1,idim2,idim3,idim4,idim5,idim6,idim7
+   TYPE (grid_config_rec_type)  :: config_flags
+   TYPE( fieldlist ), POINTER :: p
+
+   INTERFACE
+       ! need to split this routine to avoid clobbering certain widely used compilers
+       SUBROUTINE shift_domain_em2 ( grid , disp_x, disp_y &
+!
+# include <dummy_new_args.inc>
+!
+                           )
+          USE module_state_description
+          USE module_domain, ONLY : domain
+          IMPLICIT NONE
+         ! Arguments
+          INTEGER disp_x, disp_y       ! number of parent domain points to move
+          TYPE(domain) , POINTER                     :: grid
+
+          !  Definitions of dummy arguments to solve
+#include <dummy_new_decl.inc>
+       END SUBROUTINE shift_domain_em2
+   END INTERFACE
+
+   !  Definitions of dummy arguments to solve
+#include <dummy_new_decl.inc>
+
+#ifdef MOVE_NESTS
+
+   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 <SHIFT_HALO.inc>
+#include "../frame/loop_based_x_shift_code.h"
+   enddo
+
+   CALL shift_domain_em2 ( grid , disp_x, disp_y &
+!
+# include <dummy_new_args.inc>
+!
+                           )
+
+#endif
+
+END SUBROUTINE shift_domain_em
+
+SUBROUTINE shift_domain_em2 ( grid , disp_x, disp_y &
+!
+# include <dummy_new_args.inc>
+!
+                           )
+   USE module_state_description
+   USE module_domain, ONLY : domain, get_ijk_from_grid
+   USE module_domain_type, ONLY : fieldlist
+   USE module_timing
+   USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec
+#ifdef DM_PARALLEL
+   USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, itrace
+   USE module_comm_dm, ONLY : SHIFT_HALO_sub
+#else
+   USE module_dm
+#endif
+   IMPLICIT NONE
+  ! Arguments
+   INTEGER disp_x, disp_y       ! number of parent domain points to move
+   TYPE(domain) , POINTER                     :: grid
+  ! Local 
+   INTEGER i, j, ii, jpf
+   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 idim1,idim2,idim3,idim4,idim5,idim6,idim7
+   TYPE (grid_config_rec_type)  :: config_flags
+   TYPE( fieldlist ), POINTER :: p
+
+   !  Definitions of dummy arguments to solve
+#include <dummy_new_decl.inc>
+
+#ifdef MOVE_NESTS
+
+   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 <SHIFT_HALO.inc>
+#include "../frame/loop_based_y_shift_code.h"
+   enddo
+
+#endif
+END SUBROUTINE shift_domain_em2
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/solve_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/solve_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/solve_em.F	(revision 17)
@@ -0,0 +1,4478 @@
+!WRF:MEDIATION_LAYER:SOLVER
+
+SUBROUTINE solve_em ( grid , config_flags  &
+! Arguments generated from Registry
+#include "dummy_new_args.inc"
+!
+                    )
+! Driver layer modules
+   USE module_state_description
+   USE module_domain, ONLY : &
+                  domain, get_ijk_from_grid, get_ijk_from_subgrid                          &
+                 ,domain_get_current_time, domain_get_start_time                           &
+                 ,domain_get_sim_start_time, domain_clock_get
+   USE module_domain_type, ONLY : history_alarm
+   USE module_configure, ONLY : grid_config_rec_type
+   USE module_driver_constants
+   USE module_machine
+   USE module_tiles, ONLY : set_tiles
+#ifdef DM_PARALLEL
+   USE module_dm, ONLY : &
+                  local_communicator, mytask, ntasks, ntasks_x, ntasks_y                   &
+                 ,local_communicator_periodic, wrf_dm_maxval
+   USE module_comm_dm, ONLY : &
+                  halo_em_a_sub,halo_em_b_sub,halo_em_c2_sub,halo_em_chem_e_3_sub          &
+                 ,halo_em_chem_e_5_sub,halo_em_chem_e_7_sub,halo_em_chem_old_e_5_sub       &
+                 ,halo_em_chem_old_e_7_sub,halo_em_c_sub,halo_em_d2_3_sub                  &
+                 ,halo_em_d2_5_sub,halo_em_d3_3_sub,halo_em_d3_5_sub,halo_em_d_sub         &
+                 ,halo_em_e_3_sub,halo_em_e_5_sub,halo_em_hydro_uv_sub                     &
+                 ,halo_em_moist_e_3_sub,halo_em_moist_e_5_sub,halo_em_moist_e_7_sub        &
+                 ,halo_em_moist_old_e_5_sub,halo_em_moist_old_e_7_sub                      &
+                 ,halo_em_scalar_e_3_sub,halo_em_scalar_e_5_sub,halo_em_scalar_e_7_sub     &
+                 ,halo_em_scalar_old_e_5_sub,halo_em_scalar_old_e_7_sub,halo_em_tke_3_sub  &
+                 ,halo_em_tke_5_sub,halo_em_tke_7_sub,halo_em_tke_advect_3_sub             &
+                 ,halo_em_tke_advect_5_sub,halo_em_tke_old_e_5_sub                         &
+                 ,halo_em_tke_old_e_7_sub,halo_em_tracer_e_3_sub,halo_em_tracer_e_5_sub    &
+                 ,halo_em_tracer_e_7_sub,halo_em_tracer_old_e_5_sub                        &
+                 ,halo_em_tracer_old_e_7_sub,period_bdy_em_a_sub                           &
+                 ,period_bdy_em_b3_sub,period_bdy_em_b_sub,period_bdy_em_chem2_sub         &
+                 ,period_bdy_em_chem_old_sub,period_bdy_em_chem_sub,period_bdy_em_d3_sub   &
+                 ,period_bdy_em_d_sub,period_bdy_em_e_sub,period_bdy_em_moist2_sub         &
+                 ,period_bdy_em_moist_old_sub,period_bdy_em_moist_sub                      &
+                 ,period_bdy_em_scalar2_sub,period_bdy_em_scalar_old_sub                   &
+                 ,period_bdy_em_scalar_sub,period_bdy_em_tke_old_sub                       &
+                 ,period_bdy_em_tracer2_sub,period_bdy_em_tracer_old_sub                   &
+                 ,period_bdy_em_tracer_sub,period_em_da_sub,period_em_hydro_uv_sub
+#endif
+   USE module_utility
+! 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
+   USE module_polarfft
+   USE module_microphysics_driver
+   USE module_microphysics_zero_out
+   USE module_fddaobs_driver
+   USE module_diagnostics
+#ifdef WRF_CHEM
+   USE module_input_chem_data
+   USE module_input_tracer
+   USE module_chem_utilities
+#endif
+   USE module_first_rk_step_part1
+   USE module_first_rk_step_part2
+   USE module_llxy, ONLY : proj_cassini
+   USE module_avgflx_em, ONLY : zero_avgflx, upd_avgflx
+#ifdef LMDZ
+   USE module_lmdz_phys
+   USE module_domain_type, ONLY: RESTART_ALARM
+   USE module_domain, ONLY: domain_get_time_since_sim_start
+   USE module_streams
+
+#endif
+
+   IMPLICIT NONE
+
+   !  Input data.
+
+   TYPE(domain) , TARGET          :: grid
+
+   !  Definitions of dummy arguments to this routine (generated from Registry).
+#include "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
+   INTEGER                         :: iswater
+
+   LOGICAL                         :: specified_bdy, channel_bdy
+
+   REAL                            :: t_new
+   
+   ! Changes in tendency at this timestep
+   real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33) :: h_tendency, &
+                                                                                   z_tendency
+                                                                                   
+   ! Whether advection should produce decoupled horizontal and vertical advective tendency outputs
+   LOGICAL                        :: tenddec
+   
+#ifdef WRF_CHEM
+   ! Index cross-referencing array for tendency accumulation
+   INTEGER, DIMENSION( num_chem ) :: adv_ct_indices
+#endif
+
+! storage for tendencies and decoupled state (generated from Registry)
+
+#include <i1_decl.inc>
+! 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, dts, dtm, wmax
+   REAL , ALLOCATABLE , DIMENSION(:)  :: max_vert_cfl_tmp, max_horiz_cfl_tmp
+   LOGICAL :: leapfrog
+   INTEGER :: l,kte,kk
+   LOGICAL :: f_flux  ! flag for computing averaged fluxes in cu_gd
+   REAL    :: curr_secs
+   INTEGER :: num_sound_steps
+   INTEGER :: idex, jdex
+   REAL    :: max_msft
+   REAL    :: spacing
+
+   INTEGER :: ii, jj !kk is above after l,kte
+   REAL    :: dclat
+   INTEGER :: debug_level
+
+! urban related variables
+   INTEGER :: NUM_ROOF_LAYERS, NUM_WALL_LAYERS, NUM_ROAD_LAYERS   ! urban
+
+   TYPE(WRFU_TimeInterval)                    :: tmpTimeInterval
+   REAL                                       :: real_time
+   LOGICAL                                    :: adapt_step_flag
+   LOGICAL                                    :: fill_w_flag
+
+! variables for flux-averaging code 20091223
+   CHARACTER*256                              :: message, message2
+   REAL                                       :: old_dt
+   TYPE(WRFU_Time)                            :: temp_time, CurrTime
+   INTEGER, PARAMETER                         :: precision = 100
+   INTEGER                                    :: num, den
+   TYPE(WRFU_TimeInterval)                    :: dtInterval
+
+#ifdef LMDZ
+   INTEGER                                    :: im2, jm2, km2
+   INTEGER                                    :: ix,iy,iz
+   INTEGER                                    :: days, seconds, Sn, Sd
+   TYPE(WRFU_TimeInterval)                    :: timeSinceSimStart
+   TYPE(WRFU_Time)                            :: initime, simtime
+   LOGICAL                                    :: wrftestrst, wrftestin
+   REAL                                       :: minSinceSimStart
+   CHARACTER(LEN=256)                         :: mminlu, mminsl
+   CHARACTER(LEN=50)                          :: errmsg
+   INTEGER                                    :: hr, minute, sec, ms, julyr, &
+     julday
+   REAL                                       :: gmt
+
+
+   errmsg = 'ERROR -- error -- ERROR -- error'
+
+   im2 = config_flags%i_check_point
+   jm2 = config_flags%j_check_point
+   km2 = config_flags%k_check_point
+#endif
+
+! Define benchmarking timers if -DBENCH is compiled
+#include <bench_solve_em_def.h>
+
+!----------------------
+! Executable statements
+!----------------------
+
+!<DESCRIPTION>
+!<pre>
+! 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.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.
+!</pre>
+!</DESCRIPTION>
+
+! Initialize timers if compiled with -DBENCH
+#include <bench_solve_em_init.h>
+
+!  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
+
+   f_flux = config_flags%do_avgflx_cugd .EQ. 1
+
+!  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 )
+
+!  Max values of CFL for adaptive time step scheme
+
+   ALLOCATE (max_vert_cfl_tmp(grid%num_tiles))
+   ALLOCATE (max_horiz_cfl_tmp(grid%num_tiles))
+
+  !
+  ! Calculate current time in seconds since beginning of model run.
+  !   Unfortunately, ESMF does not seem to have a way to return
+  !   floating point seconds based on a TimeInterval.  So, we will
+  !   calculate it here--but, this is not clean!!
+  !
+   tmpTimeInterval = domain_get_current_time ( grid ) - domain_get_sim_start_time ( grid )
+   curr_secs = real_time(tmpTimeInterval)
+
+   old_dt = grid%dt   ! store old time step for flux averaging code at end of RK loop
+!-----------------------------------------------------------------------------
+! Adaptive time step: Added by T. Hutchinson, WSI  3/5/07
+!   In this call, we do the time-step adaptation and set time-dependent lateral
+!   boundary condition nudging weights.
+!
+   IF ( (config_flags%use_adaptive_time_step) .and. &
+        ( (.not. grid%nested) .or. &
+        ( (grid%nested) .and. (abs(grid%dtbc) < 0.0001) ) ) )THEN
+      CALL adapt_timestep(grid, config_flags)
+      adapt_step_flag = .TRUE.
+   ELSE
+      adapt_step_flag = .FALSE.
+   ENDIF
+! End of adaptive time step modifications
+!-----------------------------------------------------------------------------
+
+   grid%itimestep = grid%itimestep + 1
+
+   IF (config_flags%polar) dclat = 90./REAL(jde-jds) !(0.5 * 180/ny)
+
+#ifdef WRF_CHEM
+
+   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"
+       ENDIF
+     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"
+      ENDIF
+     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_tracer >= PARAM_FIRST_SCALAR ) then
+!-----------------------------------------------------------------------
+! see matching halo calls below for stencils
+!--------------------------------------------------------------
+     CALL wrf_debug ( 200 , ' call HALO_RK_tracer' )
+     IF      ( config_flags%h_mom_adv_order <= 4 ) THEN
+#      include "HALO_EM_TRACER_E_3.inc"
+     ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN
+#      include "HALO_EM_TRACER_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
+!--------------------------------------------------------------
+   adv_ct_indices(   :  ) = 1
+   IF ( config_flags%chemdiag == USECHEMDIAG ) THEN
+   ! modify tendency list here
+   ! note that the referencing direction here is opposite of that in chem_driver
+       adv_ct_indices(p_co  ) = p_advh_co
+       adv_ct_indices(p_o3  ) = p_advh_o3
+       adv_ct_indices(p_no  ) = p_advh_no
+       adv_ct_indices(p_no2 ) = p_advh_no2
+       adv_ct_indices(p_hno3) = p_advh_hno3
+       adv_ct_indices(p_iso ) = p_advh_iso
+       adv_ct_indices(p_ho  ) = p_advh_ho
+       adv_ct_indices(p_ho2 ) = p_advh_ho2
+   END IF
+#endif
+
+   rk_order = config_flags%rk_ord
+
+   IF ( grid%time_step_sound == 0 ) THEN
+! This function will give 4 for 6*dx and 6 for 10*dx and returns even numbers only
+     spacing = min(grid%dx, grid%dy)
+     IF ( ( config_flags%use_adaptive_time_step ) .AND. ( config_flags%map_proj == PROJ_CASSINI ) ) THEN
+       max_msft=MIN ( MAX(grid%max_msftx, grid%max_msfty) , &
+                      1.0/COS(config_flags%fft_filter_lat*degrad) )
+       num_sound_steps = max ( 2 * ( INT (300. * grid%dt / (spacing / max_msft) - 0.01 ) + 1 ), 4 )
+     ELSE IF  ( config_flags%use_adaptive_time_step ) THEN
+       max_msft= MAX(grid%max_msftx, grid%max_msfty)
+       num_sound_steps = max ( 2 * ( INT (300. * grid%dt / (spacing / max_msft) - 0.01 ) + 1 ), 4 )
+     ELSE
+       num_sound_steps = max ( 2 * ( INT (300. * grid%dt /  spacing             - 0.01 ) + 1 ), 4 )
+     END IF
+     WRITE(wrf_err_message,*)'grid spacing, dt, time_step_sound=',spacing,grid%dt,num_sound_steps
+     CALL wrf_debug ( 50 , wrf_err_message )
+   ELSE
+     num_sound_steps = grid%time_step_sound
+   ENDIF
+
+   dts = grid%dt/float(num_sound_steps)
+
+   IF (config_flags%use_adaptive_time_step) THEN
+  
+     CALL get_wrf_debug_level( debug_level )
+     IF ((config_flags%time_step < 0) .AND. (debug_level.GE.50)) THEN
+#ifdef DM_PARALLEL
+       CALL wrf_dm_maxval(grid%max_vert_cfl, idex, jdex)
+#endif
+       WRITE(wrf_err_message,*)'variable dt, max horiz cfl, max vert cfl: ',&
+            grid%dt, grid%max_horiz_cfl, grid%max_vert_cfl
+       CALL wrf_debug ( 0 , wrf_err_message )
+     ENDIF
+
+     grid%max_cfl_val = 0
+     grid%max_horiz_cfl = 0
+     grid%max_vert_cfl = 0
+   ENDIF
+
+! setting bdy tendencies to zero for DFI if constant_bc = true
+
+     !$OMP PARALLEL DO   &
+     !$OMP PRIVATE ( ij )
+     DO ij = 1 , grid%num_tiles
+
+!      IF( config_flags%specified .AND. grid%dfi_opt .NE. DFI_NODFI   &
+!          .AND. config_flags%constant_bc .AND. (grid%dfi_stage .EQ. DFI_BCK .OR. grid%dfi_stage .EQ. DFI_FWD) ) THEN
+       IF( config_flags%specified .AND. config_flags%constant_bc ) THEN
+
+       CALL zero_bdytend (grid%u_btxs,grid%u_btxe,grid%u_btys,grid%u_btye,     &
+                          grid%v_btxs,grid%v_btxe,grid%v_btys,grid%v_btye,     &
+                          grid%ph_btxs,grid%ph_btxe,grid%ph_btys,grid%ph_btye, &
+                          grid%t_btxs,grid%t_btxe,grid%t_btys,grid%t_btye,     &
+                          grid%w_btxs,grid%w_btxe,grid%w_btys,grid%w_btye,     &
+                          grid%mu_btxs,grid%mu_btxe,grid%mu_btys,grid%mu_btye, &
+                          moist_btxs,moist_btxe,                               &
+                          moist_btys,moist_btye,                               &
+                          grid%spec_bdy_width,num_3d_m,                &
+                          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
+     ENDDO
+     !$OMP END PARALLEL DO
+
+!**********************************************************************
+!
+!  LET US BEGIN.......
+!
+!<DESCRIPTION>
+!<pre>
+! (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.
+!</pre>
+!</DESCRIPTION>
+!**********************************************************************
+
+   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 = dts
+         number_of_small_timesteps = num_sound_steps/2
+       ELSE
+         dt_rk = grid%dt
+         dts_rk = dts
+         number_of_small_timesteps = num_sound_steps
+       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 = dts
+         number_of_small_timesteps = num_sound_steps/2
+       ELSE
+         dt_rk = grid%dt
+         dts_rk = dts
+         number_of_small_timesteps = num_sound_steps
+       ENDIF
+
+     ELSE
+
+       write(wrf_err_message,*)' unknown solver, error exit for dynamics_option = ',dynamics_option
+       CALL wrf_error_fatal( wrf_err_message )
+
+     END IF
+
+!  Ensure that polar meridional velocity is zero
+     IF (config_flags%polar) THEN 
+       !$OMP PARALLEL DO   &
+       !$OMP PRIVATE ( ij )
+       DO ij = 1 , grid%num_tiles
+         CALL zero_pole ( grid%v_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                   )
+         CALL zero_pole ( grid%v_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
+     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.
+!
+#ifdef LMDZ1
+     WRITE(message, *)'  dyn_em: before rk_step_prep rk_step=', rk_step
+     CALL wrf_debug(200, message)
+     WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+       ' u_tend: ', ru_tendf(im2,1,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+       'p sfc: ',p8w(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+#endif
+
+     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%u_2, grid%v_2, grid%w_2, grid%t_2, grid%ph_2, grid%mu_2,   &
+                            moist,                            &
+                            grid%ru, grid%rv, grid%rw, grid%ww, grid%php, grid%alt, grid%muu, grid%muv,   &
+                            grid%mub, grid%mut, grid%phb, grid%pb, grid%p, grid%al, grid%alb,    &
+                            cqu, cqv, cqw,                    &
+                            grid%msfux, grid%msfuy, grid%msfvx, grid%msfvx_inv,        &
+                            grid%msfvy, grid%msftx, grid%msfty,                        &
+                            grid%fnm, grid%fnp, grid%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 LMDZ1
+     WRITE(message, *)'  dyn_em: after rk_step_prep' 
+     CALL wrf_debug(200, message)
+     WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+       ' u_tend: ', ru_tendf(im2,1,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+       'p sfc: ',p8w(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+#endif
+
+#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!  ru(X), rv(Y), ww(Z), php(Z)
+!
+!  ru     x
+!  rv     x
+!  ww     x
+!  php    x
+!  alt    x
+!  ph_2   x
+!  phb    x
+!
+!  the following are 2D (xy) variables
+!
+!  muu    x
+!  muv    x
+!  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
+
+BENCH_START(set_phys_bc_tim)
+     !$OMP PARALLEL DO   &
+     !$OMP PRIVATE ( ij, ii, jj, kk )
+
+     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%ru, grid%rv, grid%rw, grid%ww,      & 
+                              grid%muu, grid%muv, grid%mut, grid%php, grid%alt, grid%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                )
+       CALL set_physical_bc3d( grid%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%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                )
+
+#ifdef LMDZ1
+     WRITE(message, *)'  dyn_em: before polar' 
+     CALL wrf_debug(200, message)
+     WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+       ' u_tend: ', ru_tendf(im2,1,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+       'p sfc: ',p8w(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+#endif
+
+       IF (config_flags%polar) THEN 
+
+!-------------------------------------------------------
+! lat-lon grid pole-point (v) specification (extrapolate v, rv to the pole)
+!-------------------------------------------------------
+
+         CALL pole_point_bc ( grid%v_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                   )
+ 
+         CALL pole_point_bc ( grid%v_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 lat-lon grid pole-point (v) specification
+!-------------------------------------------------------
+
+       ENDIF
+     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
+
+!<DESCRIPTION>
+!<pre>
+!(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 p points, etc).  This is followed by
+!    calls to the physics drivers:
+!
+!              radiation,
+!              surface,
+!              pbl,
+!              cumulus,
+!              fddagd,
+!              3D TKE and mixing.
+!<pre>
+!</DESCRIPTION>
+
+#ifdef LMDZ
+       WRITE(message, *)'  dyn_em:  pre step1'
+       CALL wrf_debug(200, message)
+       WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+         ' u_tend: ', ru_tendf(im2,1,jm2)
+       CALL wrf_debug(200, message)
+       IF (config_flags%lmdz_physics) THEN
+         IF (config_flags%mp_physics + config_flags%ra_lw_physics +                  &
+           config_flags%ra_sw_physics + config_flags%sf_sfclay_physics +             &
+           config_flags%bl_pbl_physics + config_flags%cu_physics /= 0) THEN
+           PRINT *,TRIM(errmsg)
+           PRINT *,'  LMDZ physics are selected from namelist. lmdz_physics= ',      &
+             config_flags%lmdz_physics
+           PRINT *,'  Which requires no WRF physics schemes [0 value] and tey are not:'
+           PRINT '(2(A12,1x,I2,8x))','    mp =', config_flags%mp_physics,'ra_lw =',  &
+             config_flags%ra_lw_physics
+           PRINT '(2(A12,1x,I2,8x))','    ra_sw =', config_flags%ra_sw_physics,      &
+             'sf_sfclay =',config_flags%sf_sfclay_physics
+           PRINT '(2(A12,1x,I2,8x))','    bl_pbl =', config_flags%bl_pbl_physics,    &
+             'cu =', config_flags%cu_physics
+           message = 'WRONG namelist ste-up'
+           CALL wrf_error_fatal(TRIM(message))
+         END IF
+
+       END IF
+     WRITE(message, *)'  dyn_em: before step1' 
+     CALL wrf_debug(200, message)
+     WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+       ' u_tend: ', ru_tendf(im2,1,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+       'p sfc: ',p8w(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+
+#endif
+
+       CALL first_rk_step_part1 (    grid, config_flags         &
+                             , moist , moist_tend               &
+                             , chem  , chem_tend                &
+                             , tracer, tracer_tend              &
+                             , scalar , scalar_tend             &
+                             , fdda3d, fdda2d                   &
+                             , ru_tendf, rv_tendf               &
+                             , rw_tendf, t_tendf                &
+                             , ph_tendf, mu_tendf               &
+                             , tke_tend                         &
+                             , adapt_step_flag , curr_secs      &
+                             , psim , psih , wspd , gz1oz0      &
+                             , br , chklowq                     &
+                             , cu_act_flag , hol , th_phy       &
+                             , pi_phy , p_phy , grid%t_phy      &
+                             , u_phy , v_phy                    &
+                             , dz8w , p8w , t8w , rho_phy , rho &
+                             , 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    &
+                             , k_start , k_end                  &
+                             , f_flux                           &
+                            )
+
+#ifdef LMDZ1
+       WRITE(message, *)'  dyn_em: post step1 pre lmdz' 
+       CALL wrf_debug(200, message)
+       WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+         ' u_tend: ', ru_tendf(im2,1,jm2)
+       CALL wrf_debug(200, message)
+       WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+         'p sfc: ',p8w(im2,kms,jm2)
+       CALL wrf_debug(200, message)
+     WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+#endif
+
+#ifdef DM_PARALLEL
+       IF ( config_flags%bl_pbl_physics == MYNNPBLSCHEME2 .OR. &
+            config_flags%bl_pbl_physics == MYNNPBLSCHEME3 ) THEN
+#        include "HALO_EM_SCALAR_E_5.inc"
+       ENDIF
+#endif
+
+#ifdef LMDZ
+!!! Using grid%clock & domain_get_sim_start_time
+!!!!
+       initime = domain_get_start_time(grid)
+       CALL domain_clock_get(grid, current_time = simtime)
+!!       timeSinceSimStart = domain_get_time_since_sim_start( grid )
+       timeSinceSimStart = simtime - initime
+       CALL WRFU_TimeIntervalGet( timeSinceSimStart,                &
+         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
+       minSinceSimStart = ( REAL( days ) * 24. * 60. ) + &
+         ( REAL( seconds ) / 60. )
+       IF ( Sd /= 0 ) THEN
+         minSinceSimStart = minSinceSimStart + &
+           ( ( REAL( Sn ) / REAL( Sd ) ) / 60. )
+       ENDIF
+       IF (minSinceSimStart == 0. .AND. grid%id == 1) THEN
+         PRINT *,'  WRF+LMDZ: simulation is starting or comes from a restart!'
+         PRINT *,'    since ', minSinceSimStart,' minutes has passed since it started'
+!!        wrftestrst = .TRUE.
+         wrftestrst = .TRUE.
+       ELSE
+         wrftestrst = .FALSE.
+       END IF
+       PRINT *,'   Lluis: minSinceSimStart: ', minSinceSimStart
+! Checking for time for input from auxiliar input 4
+       IF( WRFU_AlarmIsRinging( grid%alarms( first_auxinput + 3 ), rc=rc ) ) THEN
+         PRINT *,'  WRF lowbdy time-step!!!!!'
+         wrftestin = .TRUE.
+         CALL WRFU_AlarmRingerOff( grid%alarms( first_auxinput + 3 ), rc=rc )
+       ELSE
+         wrftestin = .FALSE.
+       END IF
+
+       PRINT *,'   grid id: ',grid%id
+
+       CALL nl_get_mminlu ( grid%id, mminlu )
+       IF (config_flags%sf_surface_physics == RUCLSMSCHEME) THEN
+         mminsl = 'STAS-RUC'
+       ELSE
+         mminsl = 'STAS'
+       END IF
+
+       grid%qv_2 = moist(:,:,:,P_QV)
+
+! L. Fita, LMD. July 2014. Getting hour of the day
+       CALL domain_clock_get( grid, current_time=CurrTime )
+       CALL WRFU_TimeGet( CurrTime, YY= julyr, dayOfYear=julday, H=hr, M=minute, S=sec, MS=ms, rc=rc)
+! Julian day hour (0, 1) !!
+       gmt=(hr+real(minute)/60.+real(sec)/3600.+real(ms)/(1000*3600))/24.
+
+! Checking for NaNs (should not be necessary but....)
+   im2 = ims + (ime - ims) / 2
+   jm2 = jms + (jme - jms) / 2
+
+   IF (grid%t_2(im2,iz,jm2) /= grid%t_2(im2,iz,jm2) .OR. ABS(grid%t_2(im2,iz,jm2)) > 10000. ) THEN
+     PRINT errmsg
+     WRITE(wrF_err_message,*)'solve_em: wrong T value=',                 &
+       grid%t_2(im2,iz,jm2),' at: ', im2,', ', iz,', ', jm2,' !!!'
+#ifdef DM_PARALLEL
+     CALL wrf_error_fatal(TRIM(wrf_err_message))
+#else
+     PRINT *,TRIM(wrf_err_message)
+     STOP
+#endif
+   END IF
+! Checking for NaNs (should not be necessary but....)
+   IF (grid%psfc(im2,jm2) /= grid%psfc(im2,jm2) .OR. ABS(grid%psfc(im2,jm2)) > 1000000. ) THEN
+     PRINT errmsg
+     WRITE(wrF_err_message,*)'solve_em: wrong PSFC value=',               &
+       grid%psfc(im2,jm2),' at: ', im2 ,', ', jm2, ' !!!'
+#ifdef DM_PARALLEL
+     CALL wrf_error_fatal(TRIM(wrf_err_message))
+#else
+     PRINT *,TRIM(wrf_err_message)
+     STOP
+#endif
+   END IF
+
+       IF (config_flags%lmdz_physics) THEN
+
+         CALL call_lmdz_phys(                                                        &
+        & WRF_GRID=grid, WRF_XTIME=grid%xtime,                                       &
+        & WRF_RESTART_ALARM=WRFU_AlarmIsRinging( grid%alarms( RESTART_ALARM ), rc=rc)&
+        &       ,WRF_LON = grid%xlong, WRF_LAT=grid%xlat,                            &
+        &        WRF_T=grid%t_2, WRF_U=grid%u_2, WRF_V=grid%v_2,                     &
+        &        WRF_PERP=grid%P, WRF_BASEP=grid%PB,                                 &
+        &        WBDYW=config_flags%spec_bdy_width, WRF_ISRESTART=wrftestrst,        &
+        &        WRF_ISLOWBDYIN=wrftestin                                            &
+                  ! Dimension arguments
+        &             ,WIDS=ids,WIDE=ide, WJDS=jds,WJDE=jde, WKDS=kds,WKDE=kde       &
+        &             ,WIMS=ims,WIME=ime, WJMS=jms,WJME=jme, WKMS=kms,WKME=kme       &
+        &             ,WIPS=ips,WIPE=ipe, WJPS=jps,WJPE=jpe, WKPS=kps,WKPE=kpe       &
+        &             ,WI_START=grid%i_start,WI_END=MIN(grid%i_end, ide-1)           &
+        &             ,WJ_START=grid%j_start,WJ_END=MIN(grid%j_end, jde-1)           &
+        &             ,WKTS=k_start, WKTE=MIN(k_end,kde-1)                           &
+        &             ,WNUM_TILES=grid%num_tiles                                     &
+        &             ,WNUM3DM=num_3d_m, WPARFIRSTSCAL=PARAM_FIRST_SCALAR,           &
+        &        WNX=config_flags%e_we, WNY=config_flags%e_sn,                       &
+        &        WNZ=config_flags%e_vert, WJULDAY=FLOAT(julday), WGMT=gmt,           &
+        &        WTIME_STEP=REAL(config_flags%time_step),                            &
+        &        WRF_FULLETA=grid%znw, WRF_HALFETA=grid%znu, WRF_DFULLETA=grid%dnw,  &
+        &        WRF_FULLPRES=p8w, WRF_PERGEOPOT=grid%ph_2,                          &
+        &        WRF_BASEGEOPOT=grid%phb,                                            &
+        &        WRF_MOIST=grid%moist, WRF_W=grid%w_2,                               &
+        &        WRF_PTOP=config_flags%p_top_requested,                              &
+        &        WRF_PERMASS=grid%mu_1, WRF_BASEMASS=grid%mub,                       &
+        &        WRF_MUT=grid%mut, WRF_MUU=grid%muu, WRF_MUV=grid%muv,               &
+!!        &        WRF_UTEND=grid%ru_tend, WRF_VTEND=grid%rv_tend,                     &
+!!        &        WRF_TTEND=t_tend,                                                   &
+        &        WRF_UTEND=ru_tendf, WRF_VTEND=rv_tendf,                     &
+        &        WRF_TTEND=t_tendf,                                                   &
+        &        WRF_MOISTTEND=moist_tend, WRF_PSFCTEND=grid%dpsdt,                  &
+        &        WRF_QVID=P_QV, WRF_QCID=P_QC, WRF_QRID=P_QR,                        &
+        &        WRF_QSID=P_QS, WRF_QIID=P_QI, WRF_QHID=P_QH, WRF_QGID=P_QG,         &
+! L. Fita. July 2013. Now defined as local dummy variables
+!        &        WRF_DUDYN=???????????????, WRF_PVTHETA=????????????????????????,   &
+!        &        WRF_CLESPHY=?????????????, WRF_PRESNIVS=???????????????????????,   &
+        &        WRF_MAPFT=grid%msft, WRF_MAPFU=grid%msfu, WRF_MAPFV=grid%msfv,      &
+        &        WRF_DX=grid%dx, WRF_DY=grid%dy,                &
+        &        WRF_DBG=model_config_rec%debug_level, LANDCAT=mminlu,               &
+        &        SOILCAT=mminsl,                                                     &
+        &        WRF_L_PBL=config_flags%lmdz_iflag_pbl,                              &
+        &        WRF_L_CON=config_flags%lmdz_iflag_con,                              &
+        &        WRF_L_THERMALS=config_flags%lmdz_iflag_thermals,                    &
+        &        WRF_L_WAKE=config_flags%lmdz_iflag_wake,                            &
+        &        wrf_nsoillayers=config_flags%num_soil_layers,                       &
+        &        ICHECK_P=config_flags%i_check_point,                                &
+        &        JCHECK_P=config_flags%j_check_point,                                &
+        &        KCHECK_P=config_flags%k_check_point                                 &
+        &                                                 )
+       END IF
+#endif
+
+#ifdef LMDZ1
+       WRITE(message, *)'  dyn_em: post lmdz pre step2 rk_step:', rk_step
+       CALL wrf_debug(200, message)
+       WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+         ' u_tend: ', ru_tendf(im2,1,jm2)
+       CALL wrf_debug(200, message)
+       WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+         'p sfc: ',p8w(im2,kms,jm2)
+       CALL wrf_debug(200, message)
+     WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+#endif
+
+       CALL first_rk_step_part2 (    grid, config_flags         &
+                             , moist , moist_tend               &
+                             , chem  , chem_tend                &
+                             , tracer, tracer_tend              &
+                             , scalar , scalar_tend             &
+                             , fdda3d, fdda2d                   &
+                             , ru_tendf, rv_tendf               &
+                             , rw_tendf, t_tendf                &
+                             , ph_tendf, mu_tendf               &
+                             , tke_tend                         &
+                             , adapt_step_flag , curr_secs      &
+                             , psim , psih , wspd , gz1oz0      &
+                             , br , chklowq                     &
+                             , cu_act_flag , hol , th_phy       &
+                             , pi_phy , p_phy , grid%t_phy      &
+                             , u_phy , v_phy                    &
+                             , dz8w , p8w , t8w , rho_phy , rho &
+                             , nba_mij, num_nba_mij             & !JDM 
+                             , nba_rij, num_nba_rij             & !JDM  
+                             , 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    &
+                             , k_start , k_end                  &
+                            )
+
+     END IF rk_step_is_one
+
+#ifdef LMDZ1
+     WRITE(message, *)'  dyn_em: post step2 pre rk_tendency rk_step: ',rk_step
+     CALL wrf_debug(200, message)
+     WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+       ' u_tend: ', ru_tendf(im2,1,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+       'p sfc: ',p8w(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+#endif
+
+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%ru_tend, grid%rv_tend, rw_tend, ph_tend, t_tend                                 &
+                         ,ru_tendf, rv_tendf, rw_tendf, ph_tendf, t_tendf                                      &
+                         ,mu_tend, grid%u_save, grid%v_save, w_save, ph_save                                   &
+                         ,grid%t_save, mu_save, grid%rthften                                                   &
+                         ,grid%ru, grid%rv, grid%rw, grid%ww                                                   &
+                         ,grid%u_2, grid%v_2, grid%w_2, grid%t_2, grid%ph_2                                    &
+                         ,grid%u_1, grid%v_1, grid%w_1, grid%t_1, grid%ph_1                                    &
+                         ,grid%h_diabatic, grid%phb, grid%t_init                                               &
+                         ,grid%mu_2, grid%mut, grid%muu, grid%muv, grid%mub                                    &
+                         ,grid%al, grid%alt, grid%p, grid%pb, grid%php, cqu, cqv, cqw                          &
+                         ,grid%u_base, grid%v_base, grid%t_base, grid%qv_base, grid%z_base                     &
+                         ,grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv                                    &
+                         ,grid%msfvy, grid%msftx,grid%msfty, grid%clat, grid%f, grid%e, grid%sina, grid%cosa   &
+                         ,grid%fnm, grid%fnp, grid%rdn, grid%rdnw                                              &
+                         ,grid%dt, grid%rdx, grid%rdy, grid%khdif, grid%kvdif, grid%xkmh, grid%xkhh            &
+                         ,grid%diff_6th_opt, grid%diff_6th_factor                                              &
+                         ,grid%dampcoef,grid%zdamp,config_flags%damp_opt,config_flags%rad_nudge                &
+                         ,grid%cf1, grid%cf2, grid%cf3, grid%cfn, grid%cfn1, num_3d_m                          &
+                         ,config_flags%non_hydrostatic, config_flags%top_lid                                   &
+                         ,grid%u_frame, grid%v_frame                                                           &
+                         ,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                                                                       &
+                         ,max_vert_cfl_tmp(ij), max_horiz_cfl_tmp(ij)                                         )
+
+     END DO
+#ifdef LMDZ1
+     WRITE(message, *)'  dyn_em: post rk_tendency' 
+     CALL wrf_debug(200, message)
+     WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+       ' u_tend: ', ru_tendf(im2,1,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+       'p sfc: ',p8w(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+#endif
+     !$OMP END PARALLEL DO
+BENCH_END(rk_tend_tim)
+
+     IF (config_flags%use_adaptive_time_step) THEN
+       DO ij = 1 , grid%num_tiles
+         IF (max_horiz_cfl_tmp(ij) .GT. grid%max_horiz_cfl) THEN
+           grid%max_horiz_cfl = max_horiz_cfl_tmp(ij)
+         ENDIF
+         IF (max_vert_cfl_tmp(ij) .GT. grid%max_vert_cfl) THEN
+           grid%max_vert_cfl = max_vert_cfl_tmp(ij)
+         ENDIF
+       END DO
+     
+       IF (grid%max_horiz_cfl .GT. grid%max_cfl_val) THEN
+         grid%max_cfl_val = grid%max_horiz_cfl
+       ENDIF
+       IF (grid%max_vert_cfl .GT. grid%max_cfl_val) THEN
+         grid%max_cfl_val = grid%max_vert_cfl
+       ENDIF
+     ENDIF
+
+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%u_save, grid%v_save, ph_save, grid%t_save,             &
+                              w_save, mu_tend,                             & 
+                              grid%ru, grid%rv, grid%ph_2, grid%t_2,                           &
+                              grid%w_2, grid%mu_2, grid%mut,                              &
+                              grid%u_bxs,grid%u_bxe,grid%u_bys,grid%u_bye, &
+                              grid%v_bxs,grid%v_bxe,grid%v_bys,grid%v_bye, &
+                              grid%ph_bxs,grid%ph_bxe,grid%ph_bys,grid%ph_bye, &
+                              grid%t_bxs,grid%t_bxe,grid%t_bys,grid%t_bye, &
+                              grid%w_bxs,grid%w_bxe,grid%w_bys,grid%w_bye, &
+                              grid%mu_bxs,grid%mu_bxe,grid%mu_bys,grid%mu_bye, &
+                              grid%u_btxs,grid%u_btxe,grid%u_btys,grid%u_btye, &
+                              grid%v_btxs,grid%v_btxe,grid%v_btys,grid%v_btye, &
+                              grid%ph_btxs,grid%ph_btxe,grid%ph_btys,grid%ph_btye, &
+                              grid%t_btxs,grid%t_btxe,grid%t_btys,grid%t_btye, &
+                              grid%w_btxs,grid%w_btxe,grid%w_btys,grid%w_btye, &
+                              grid%mu_btxs,grid%mu_btxe,grid%mu_btys,grid%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%ru_tend,  grid%rv_tend,  rw_tend,  ph_tend,  t_tend,  &
+                            ru_tendf, rv_tendf, rw_tendf, ph_tendf, t_tendf, &
+                            grid%u_save, grid%v_save, w_save, ph_save, grid%t_save, &
+                            mu_tend, mu_tendf, rk_step,                      &
+                            grid%h_diabatic, grid%mut, grid%msftx,        &
+                            grid%msfty, grid%msfux,grid%msfuy,               &
+                            grid%msfvx, grid%msfvx_inv, grid%msfvy,          &
+                            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%ru_tend, grid%rv_tend, ph_tend, t_tend,               &
+                             rw_tend, mu_tend,                                &
+                             grid%u_bxs,grid%u_bxe,grid%u_bys,grid%u_bye, &
+                             grid%v_bxs,grid%v_bxe,grid%v_bys,grid%v_bye, &
+                             grid%ph_bxs,grid%ph_bxe,grid%ph_bys,grid%ph_bye, &
+                             grid%t_bxs,grid%t_bxe,grid%t_bys,grid%t_bye, &
+                             grid%w_bxs,grid%w_bxe,grid%w_bys,grid%w_bye, &
+                             grid%mu_bxs,grid%mu_bxe,grid%mu_bys,grid%mu_bye, &
+                             grid%u_btxs,grid%u_btxe,grid%u_btys,grid%u_btye, &
+                             grid%v_btxs,grid%v_btxe,grid%v_btys,grid%v_btye, &
+                             grid%ph_btxs,grid%ph_btxe,grid%ph_btys,grid%ph_btye, &
+                             grid%t_btxs,grid%t_btxe,grid%t_btys,grid%t_btye, &
+                             grid%w_btxs,grid%w_btxe,grid%w_btys,grid%w_btye, &
+                             grid%mu_btxs,grid%mu_btxe,grid%mu_btys,grid%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)
+
+!<DESCRIPTION>
+!<pre>
+! (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).
+!</pre>
+!</DESCRIPTION>
+
+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 small_step_prep ' )
+
+#ifdef LMDZ1
+       WRITE(message, *)'  dyn_em: before small_step_prep' 
+       CALL wrf_debug(200, message)
+       WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+         ' u_tend: ', ru_tendf(im2,1,jm2)
+       CALL wrf_debug(200, message)
+       WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+         'p sfc: ',p8w(im2,kms,jm2)
+       CALL wrf_debug(200, message)
+       WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+       CALL wrf_debug(200, message)
+#endif
+       CALL small_step_prep( grid%u_1,grid%u_2,grid%v_1,grid%v_2,grid%w_1,grid%w_2,   &
+                             grid%t_1,grid%t_2,grid%ph_1,grid%ph_2,                   &
+                             grid%mub, grid%mu_1, grid%mu_2,                          &
+                             grid%muu, muus, grid%muv, muvs,                          &
+                             grid%mut, grid%muts, grid%mudf,                          &
+                             grid%u_save, grid%v_save, w_save,                        &
+                             grid%t_save, ph_save, mu_save,                           &
+                             grid%ww, ww1,                                            &
+                             grid%dnw, c2a, grid%pb, grid%p, grid%alt,                &
+                             grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv,       &
+                             grid%msfvy, grid%msftx,grid%msfty,                       &
+                             grid%rdx, grid%rdy, 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                                       )
+ 
+#ifdef LMDZ1
+       WRITE(message, *)'  dyn_em: post small_step_prep' 
+       CALL wrf_debug(200, message)
+       WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+         ' u_tend: ', ru_tendf(im2,1,jm2)
+       CALL wrf_debug(200, message)
+       WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+         'p sfc: ',p8w(im2,kms,jm2)
+       CALL wrf_debug(200, message)
+       WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+       CALL wrf_debug(200, message)
+#endif
+       CALL calc_p_rho( grid%al, grid%p, grid%ph_2,                 &
+                        grid%alt, grid%t_2, grid%t_save, c2a, pm1,  &
+                        grid%mu_2, grid%muts, grid%znu, t0,         &
+                        grid%rdnw, grid%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                          )
+#ifdef LMDZ1
+       WRITE(message, *)'  dyn_em: post calc_p_rho' 
+       CALL wrf_debug(200, message)
+       WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+         ' u_tend: ', ru_tendf(im2,1,jm2)
+       CALL wrf_debug(200, message)
+       WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+         'p sfc: ',p8w(im2,kms,jm2)
+       CALL wrf_debug(200, message)
+       WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+       CALL wrf_debug(200, message)
+#endif
+
+       IF (config_flags%non_hydrostatic) THEN
+         CALL calc_coef_w( a,alpha,gamma,                    &
+                           grid%mut, cqw,                    &
+                           grid%rdn, grid%rdnw, c2a,         &
+                           dts_rk, g, grid%epssm,            &
+                           config_flags%top_lid,             &
+                           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
+#ifdef LMDZ1
+       WRITE(message, *)'  dyn_em: post calc_coef_w' 
+       CALL wrf_debug(200, message)
+       WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+         ' u_tend: ', ru_tendf(im2,1,jm2)
+       CALL wrf_debug(200, message)
+       WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+         'p sfc: ',p8w(im2,kms,jm2)
+       CALL wrf_debug(200, message)
+       WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+       CALL wrf_debug(200, message)
+       WRITE(message,*)'   al: ',grid%al(im2,km2,jm2), ' p: ', grid%p(im2,1,jm2),     &
+         ' ph: ',grid%ph_2(im2,1,jm2)
+       CALL wrf_debug(200, message)
+       WRITE(message,*)'   mu: ',grid%mu_2(im2,jm2), 'alt: ', grid%alt(im2,1,jm2), &
+         ' mu: ',grid%mu_2(im2,jm2), ' znu: ', grid%znu(1),' ph 1: ',grid%ph_2(im2,2,jm2)
+       CALL wrf_debug(200, message)
+       PRINT  *,'   c2a: ',c2a(im2,1,jm2), 't_2: ', grid%t_2(im2,1,jm2),           &
+         ' t_save: ',grid%t_save(im2,1,jm2),' pm1: ',pm1(im2,1,jm2)
+       CALL wrf_debug(200, message)
+#endif
+     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!  ph_2(Z), u_save(X), v_save(Y)
+!
+!  ph_2      x
+!  al        x
+!  p         x
+!  t_1       x
+!  t_save    x
+!  u_save    x
+!  v_save    x
+!
+!  the following are 2D (xy) variables
+!
+!  mu_1      x
+!  mu_2      x
+!  mudf      x
+!  php       x
+!  alt       x
+!  pb        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%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%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%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%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%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%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%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%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%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%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)
+#ifdef LMDZ1
+         WRITE(message, *)'  dyn_em: before advance_uv' 
+         CALL wrf_debug(200, message)
+         WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+           ' u_tend: ', ru_tendf(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+           'p sfc: ',p8w(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   al: ',grid%al(im2,km2,jm2), ' p: ', grid%p(im2,1,jm2),     &
+           ' ph: ',grid%ph_2(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   mu: ',grid%mu_2(im2,jm2), 'alt: ', grid%alt(im2,1,jm2), &
+           ' mu: ',grid%mu_2(im2,jm2), ' znu: ', grid%znu(1),' ph 1: ',grid%ph_2(im2,2,jm2)
+         CALL wrf_debug(200, message)
+         PRINT  *,'   c2a: ',c2a(im2,1,jm2), 't_2: ', grid%t_2(im2,1,jm2),           &
+           ' t_save: ',grid%t_save(im2,1,jm2),' pm1: ',pm1(im2,1,jm2)
+         CALL wrf_debug(200, message)
+#endif
+
+         CALL advance_uv ( grid%u_2, grid%ru_tend, grid%v_2, grid%rv_tend,        &
+                           grid%p, grid%pb,                                       &
+                           grid%ph_2, grid%php, grid%alt,  grid%al,               &
+                           grid%mu_2,                                             &
+                           grid%muu, cqu, grid%muv, cqv, grid%mudf,               &
+                           grid%msfux, grid%msfuy, grid%msfvx,                    &
+                           grid%msfvx_inv, grid%msfvy,                            &
+                           grid%rdx, grid%rdy, dts_rk,                            &
+                           grid%cf1, grid%cf2, grid%cf3, grid%fnm, grid%fnp,      &
+                           grid%emdiv,                                            &
+                           grid%rdnw, config_flags,grid%spec_zone,                &
+                           config_flags%non_hydrostatic, config_flags%top_lid,    &
+                           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)
+
+       END DO
+       !$OMP END PARALLEL DO
+#ifdef LMDZ1
+         WRITE(message, *)'  dyn_em: after advance_uv' 
+         CALL wrf_debug(200, message)
+         WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+           ' u_tend: ', ru_tendf(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+           'p sfc: ',p8w(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   al: ',grid%al(im2,km2,jm2), ' p: ', grid%p(im2,1,jm2),     &
+           ' ph: ',grid%ph_2(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   mu: ',grid%mu_2(im2,jm2), 'alt: ', grid%alt(im2,1,jm2), &
+           ' mu: ',grid%mu_2(im2,jm2), ' znu: ', grid%znu(1),' ph 1: ',grid%ph_2(im2,2,jm2)
+         CALL wrf_debug(200, message)
+         PRINT  *,'   c2a: ',c2a(im2,1,jm2), 't_2: ', grid%t_2(im2,1,jm2),           &
+           ' t_save: ',grid%t_save(im2,1,jm2),' pm1: ',pm1(im2,1,jm2)
+         CALL wrf_debug(200, message)
+#endif
+
+!-----------------------------------------------------------
+!  acoustic integration polar filter for smallstep u, v
+!-----------------------------------------------------------
+
+       IF (config_flags%polar) THEN
+
+         CALL pxft ( grid=grid                                              &
+               ,lineno=__LINE__                                             &
+               ,flag_uv            = 1                                      &
+               ,flag_rurv          = 0                                      &
+               ,flag_wph           = 0                                      &
+               ,flag_ww            = 0                                      &
+               ,flag_t             = 0                                      &
+               ,flag_mu            = 0                                      &
+               ,flag_mut           = 0                                      &
+               ,flag_moist         = 0                                      &
+               ,flag_chem          = 0                                      &
+               ,flag_tracer        = 0                                      &
+               ,flag_scalar        = 0                                      &
+               ,positive_definite  = .FALSE.                                &
+               ,moist=moist,chem=chem,tracer=tracer,scalar=scalar           &
+               ,fft_filter_lat = config_flags%fft_filter_lat                &
+               ,dclat = dclat                                               &
+               ,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             &
+               ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
+               ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
+
+       END IF
+
+!-----------------------------------------------------------
+!  end acoustic integration polar filter for smallstep u, v
+!-----------------------------------------------------------
+
+       !$OMP PARALLEL DO   &
+       !$OMP PRIVATE ( ij )
+       DO ij = 1 , grid%num_tiles
+
+BENCH_START(spec_bdy_uv_tim)
+         IF( config_flags%specified .or. config_flags%nested ) THEN
+           CALL spec_bdyupdate(grid%u_2, grid%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%v_2, grid%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)
+!
+!         *                     *
+!       * + *      * + *        +
+!         *                     *
+!
+!  u_2               x
+!  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 ww
+
+BENCH_START(advance_mu_t_tim)
+         CALL advance_mu_t( grid%ww, ww1, grid%u_2, grid%u_save, grid%v_2, grid%v_save, &
+                          grid%mu_2, grid%mut, muave, grid%muts, grid%muu, grid%muv,    &
+                          grid%mudf, grid%ru_m, grid%rv_m, grid%ww_m,                   &
+                          grid%t_2, grid%t_save, t_2save, t_tend,                       &
+                          mu_tend,                                                      &
+                          grid%rdx, grid%rdy, dts_rk, grid%epssm,                       &
+                          grid%dnw, grid%fnm, grid%fnp, grid%rdnw,                      &
+                          grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv,            &
+                          grid%msfvy, grid%msftx,grid%msfty,                            &
+                          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)
+       ENDDO
+       !$OMP END PARALLEL DO
+#ifdef LMDZ1
+         WRITE(message, *)'  dyn_em: after advance_mut' 
+         CALL wrf_debug(200, message)
+         WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+           ' u_tend: ', ru_tendf(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+           'p sfc: ',p8w(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   al: ',grid%al(im2,km2,jm2), ' p: ', grid%p(im2,1,jm2),     &
+           ' ph: ',grid%ph_2(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   mu: ',grid%mu_2(im2,jm2), 'alt: ', grid%alt(im2,1,jm2), &
+           ' mu: ',grid%mu_2(im2,jm2), ' znu: ', grid%znu(1),' ph 1: ',grid%ph_2(im2,2,jm2)
+         CALL wrf_debug(200, message)
+         PRINT  *,'   c2a: ',c2a(im2,1,jm2), 't_2: ', grid%t_2(im2,1,jm2),           &
+           ' t_save: ',grid%t_save(im2,1,jm2),' pm1: ',pm1(im2,1,jm2)
+         CALL wrf_debug(200, message)
+#endif
+
+!-----------------------------------------------------------
+!  acoustic integration polar filter for smallstep mu, t
+!-----------------------------------------------------------
+
+       IF ( (config_flags%polar) ) THEN
+
+         CALL pxft ( grid=grid                                               &
+                ,lineno=__LINE__                                             &
+                ,flag_uv            = 0                                      &
+                ,flag_rurv          = 0                                      &
+                ,flag_wph           = 0                                      &
+                ,flag_ww            = 0                                      &
+                ,flag_t             = 1                                      &
+                ,flag_mu            = 1                                      &
+                ,flag_mut           = 0                                      &
+                ,flag_moist         = 0                                      &
+                ,flag_chem          = 0                                      &
+                ,flag_tracer        = 0                                      &
+                ,flag_scalar        = 0                                      &
+                ,positive_definite  = .FALSE.                                &
+                ,moist=moist,chem=chem,tracer=tracer,scalar=scalar           &
+                ,fft_filter_lat = config_flags%fft_filter_lat                &
+                ,dclat = dclat                                               &
+                ,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             &
+                ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
+                ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
+
+         grid%muts = grid%mut + grid%mu_2  ! reset muts using filtered mu_2
+ 
+       END IF
+
+!-----------------------------------------------------------
+!  end acoustic integration polar filter for smallstep mu, t
+!-----------------------------------------------------------
+
+BENCH_START(spec_bdy_t_tim)
+
+       !$OMP PARALLEL DO   &
+       !$OMP PRIVATE ( ij )
+       DO ij = 1 , grid%num_tiles
+
+         IF( config_flags%specified .or. config_flags%nested ) THEN
+
+           CALL spec_bdyupdate(grid%t_2, t_tend, dts_rk,        &
+                               't'         , config_flags,      &
+                               grid%spec_zone,                  &
+                               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 spec_bdyupdate(grid%mu_2, mu_tend, dts_rk,       &
+                               'm'         , config_flags,      &
+                               grid%spec_zone,                  &
+                               ids,ide, jds,jde, 1  ,1  ,       &
+                               ims,ime, jms,jme, 1  ,1  ,       &
+                               ips,ipe, jps,jpe, 1  ,1  ,       &
+                               grid%i_start(ij), grid%i_end(ij),&
+                               grid%j_start(ij), grid%j_end(ij),&
+                               1    , 1             )
+
+           CALL spec_bdyupdate(grid%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)
+
+         ! 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%w_2, rw_tend, grid%ww, w_save,         &
+                           grid%u_2, grid%v_2,                         &
+                           grid%mu_2, grid%mut, muave, grid%muts,      &
+                           t_2save, grid%t_2, grid%t_save,             &
+                           grid%ph_2, ph_save, grid%phb, ph_tend,      &
+                           grid%ht, c2a, cqw, grid%alt, grid%alb,      &
+                           a, alpha, gamma,                            &
+                           grid%rdx, grid%rdy, dts_rk, t0, grid%epssm, &
+                           grid%dnw, grid%fnm, grid%fnp, grid%rdnw,    &
+                           grid%rdn, grid%cf1, grid%cf2, grid%cf3,     &
+                           grid%msftx, grid%msfty,                     &
+                           config_flags,  config_flags%top_lid,        &
+                           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(advance_w_tim)
+
+       ENDDO
+       !$OMP END PARALLEL DO
+#ifdef LMDZ1
+         WRITE(message, *)'  dyn_em: after advance_w' 
+         CALL wrf_debug(200, message)
+         WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+           ' u_tend: ', ru_tendf(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+           'p sfc: ',p8w(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   al: ',grid%al(im2,km2,jm2), ' p: ', grid%p(im2,1,jm2),     &
+           ' ph: ',grid%ph_2(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   mu: ',grid%mu_2(im2,jm2), 'alt: ', grid%alt(im2,1,jm2), &
+           ' mu: ',grid%mu_2(im2,jm2), ' znu: ', grid%znu(1),' ph 1: ',grid%ph_2(im2,2,jm2)
+         CALL wrf_debug(200, message)
+         PRINT  *,'   c2a: ',c2a(im2,1,jm2), 't_2: ', grid%t_2(im2,1,jm2),           &
+           ' t_save: ',grid%t_save(im2,1,jm2),' pm1: ',pm1(im2,1,jm2)
+         CALL wrf_debug(200, message)
+#endif
+
+!-----------------------------------------------------------
+!  acoustic integration polar filter for smallstep w, geopotential
+!-----------------------------------------------------------
+
+       IF ( (config_flags%polar) .AND. (config_flags%non_hydrostatic) ) THEN
+
+         CALL pxft ( grid=grid                                               &
+                ,lineno=__LINE__                                             &
+                ,flag_uv            = 0                                      &
+                ,flag_rurv          = 0                                      &
+                ,flag_wph           = 1                                      &
+                ,flag_ww            = 0                                      &
+                ,flag_t             = 0                                      &
+                ,flag_mu            = 0                                      &
+                ,flag_mut           = 0                                      &
+                ,flag_moist         = 0                                      &
+                ,flag_chem          = 0                                      &
+                ,flag_tracer        = 0                                      &
+                ,flag_scalar        = 0                                      &
+                ,positive_definite  = .FALSE.                                &
+                ,moist=moist,chem=chem,tracer=tracer,scalar=scalar           &
+                ,fft_filter_lat = config_flags%fft_filter_lat                &
+                ,dclat = dclat                                               &
+                ,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             &
+                ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
+                ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
+
+       END IF
+
+!-----------------------------------------------------------
+!  end acoustic integration polar filter for smallstep w, geopotential
+!-----------------------------------------------------------
+
+       !$OMP PARALLEL DO   &
+       !$OMP PRIVATE ( ij )
+       DO ij = 1 , grid%num_tiles
+
+BENCH_START(sumflux_tim)
+         CALL sumflux ( grid%u_2, grid%v_2, grid%ww,          &
+                        grid%u_save, grid%v_save, ww1,        &
+                        grid%muu, grid%muv,                   &
+                        grid%ru_m, grid%rv_m, grid%ww_m, grid%epssm,  &
+                        grid%msfux, grid% msfuy, grid%msfvx,  &
+                        grid%msfvx_inv, grid%msfvy,           &
+                        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)
+#ifdef LMDZ1
+         WRITE(message, *)'  dyn_em: after sumflux' 
+         CALL wrf_debug(200, message)
+         WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+           ' u_tend: ', ru_tendf(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+           'p sfc: ',p8w(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   al: ',grid%al(im2,km2,jm2), ' p: ', grid%p(im2,1,jm2),     &
+           ' ph: ',grid%ph_2(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   mu: ',grid%mu_2(im2,jm2), 'alt: ', grid%alt(im2,1,jm2), &
+           ' mu: ',grid%mu_2(im2,jm2), ' znu: ', grid%znu(1),' ph 1: ',grid%ph_2(im2,2,jm2)
+         CALL wrf_debug(200, message)
+         PRINT  *,'   c2a: ',c2a(im2,1,jm2), 't_2: ', grid%t_2(im2,1,jm2),           &
+           ' t_save: ',grid%t_save(im2,1,jm2),' pm1: ',pm1(im2,1,jm2)
+         CALL wrf_debug(200, message)
+#endif
+
+         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%ph_2, ph_tend,     &
+                                     mu_tend, grid%muts, dts_rk,      &
+                                     'h'         , config_flags,      &
+                                     grid%spec_zone,                  &
+                                     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               )
+#ifdef LMDZ1
+         WRITE(message, *)'  dyn_em: after spec_bdynhyd_ph' 
+         CALL wrf_debug(200, message)
+         WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+           ' u_tend: ', ru_tendf(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+           'p sfc: ',p8w(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   al: ',grid%al(im2,km2,jm2), ' p: ', grid%p(im2,1,jm2),     &
+           ' ph: ',grid%ph_2(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   mu: ',grid%mu_2(im2,jm2), 'alt: ', grid%alt(im2,1,jm2), &
+           ' mu: ',grid%mu_2(im2,jm2), ' znu: ', grid%znu(1),' ph 1: ',grid%ph_2(im2,2,jm2)
+         CALL wrf_debug(200, message)
+         PRINT  *,'   c2a: ',c2a(im2,1,jm2), 't_2: ', grid%t_2(im2,1,jm2),           &
+           ' t_save: ',grid%t_save(im2,1,jm2),' pm1: ',pm1(im2,1,jm2)
+         CALL wrf_debug(200, message)
+#endif
+             IF( config_flags%specified ) THEN
+               CALL zero_grad_bdy ( grid%w_2,                         &
+                                    'w'         , config_flags,       &
+                                    grid%spec_zone,                   &
+                                    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                )
+             ELSE
+               CALL spec_bdyupdate ( grid%w_2, rw_tend, dts_rk,       &
+                                     'h'         , config_flags,      &
+                                     grid%spec_zone,                  &
+                                     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
+           ENDIF
+BENCH_END(spec_bdynhyd_tim)
+         ENDIF
+#ifdef LMDZ1
+         WRITE(message, *)'  dyn_em: after spec_bdynhyd_tim' 
+         CALL wrf_debug(200, message)
+         WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+           ' u_tend: ', ru_tendf(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+           'p sfc: ',p8w(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   al: ',grid%al(im2,km2,jm2), ' p: ', grid%p(im2,1,jm2),     &
+           ' ph: ',grid%ph_2(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)'   mu: ',grid%mu_2(im2,jm2), 'alt: ', grid%alt(im2,1,jm2), &
+           ' mu: ',grid%mu_2(im2,jm2), ' znu: ', grid%znu(1),' ph 1: ',grid%ph_2(im2,2,jm2)
+         CALL wrf_debug(200, message)
+         PRINT  *,'   c2a: ',c2a(im2,1,jm2), 't_2: ', grid%t_2(im2,1,jm2),           &
+           ' t_save: ',grid%t_save(im2,1,jm2),' pm1: ',pm1(im2,1,jm2)
+         CALL wrf_debug(200, message)
+#endif
+
+BENCH_START(cald_p_rho_tim)
+         CALL calc_p_rho( grid%al, grid%p, grid%ph_2,                 &
+                          grid%alt, grid%t_2, grid%t_save, c2a, pm1,  &
+                          grid%mu_2, grid%muts, grid%znu, t0,         &
+                          grid%rdnw, grid%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)
+#ifdef LMDZ1
+         WRITE(message, *)'  dyn_em: after calc_p_rho' 
+         CALL wrf_debug(200, message)
+         WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+           ' u_tend: ', ru_tendf(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+           'p sfc: ',p8w(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+#endif
+
+       ENDDO
+       !$OMP END PARALLEL DO
+#ifdef LMDZ1
+         WRITE(message, *)'  dyn_em: after geopotential' 
+         CALL wrf_debug(200, message)
+         WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+           ' u_tend: ', ru_tendf(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+           'p sfc: ',p8w(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+#endif
+
+#ifdef DM_PARALLEL
+!
+!  Stencils for patch communications  (WCS, 29 June 2001)
+!
+!         *                     *
+!       * + *      * + *        +
+!         *                     *
+!
+!  ph_2   x
+!  al     x
+!  p      x
+!
+!  2D variables (x,y)
+!
+!  mu_2   x
+!  muts   x
+!  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%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%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%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%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%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%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%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%u_2, grid%u_1, grid%v_2, grid%v_1, grid%w_2, grid%w_1,     &
+                               grid%t_2, grid%t_1, grid%ph_2, grid%ph_1, grid%ww, ww1,    &
+                               grid%mu_2, grid%mu_1,                       &
+                               grid%mut, grid%muts, grid%muu, muus, grid%muv, muvs,  & 
+                               grid%u_save, grid%v_save, w_save,           &
+                               grid%t_save, ph_save, mu_save,         &
+                               grid%msfux,grid%msfuy, grid%msfvx,grid%msfvy, grid%msftx,grid%msfty, &
+                               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 == rk_order) THEN
+
+         CALL set_physical_bc3d( grid%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%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%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%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) )
+
+         CALL set_physical_bc2d( grid%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) )
+ 
+       END IF
+
+BENCH_END(small_step_finish_tim)
+
+     END DO
+     !$OMP END PARALLEL DO
+#ifdef LMDZ1
+         WRITE(message, *)'  dyn_em: after rk_small_finish' 
+         CALL wrf_debug(200, message)
+         WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+           ' u_tend: ', ru_tendf(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+           'p sfc: ',p8w(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+#endif
+
+!-----------------------------------------------------------
+!  polar filter for full dynamics variables and time-averaged mass fluxes 
+!-----------------------------------------------------------
+
+     IF (config_flags%polar) THEN
+
+       CALL pxft ( grid=grid                                                   &
+                  ,lineno=__LINE__                                             &
+                  ,flag_uv            = 1                                      &
+                  ,flag_rurv          = 1                                      &
+                  ,flag_wph           = 1                                      &
+                  ,flag_ww            = 1                                      &
+                  ,flag_t             = 1                                      &
+                  ,flag_mu            = 1                                      &
+                  ,flag_mut           = 1                                      &
+                  ,flag_moist         = 0                                      &
+                  ,flag_chem          = 0                                      &
+                  ,flag_tracer        = 0                                      &
+                  ,flag_scalar        = 0                                      &
+                  ,positive_definite  = .FALSE.                                &
+                  ,moist=moist,chem=chem,tracer=tracer,scalar=scalar           &
+                  ,fft_filter_lat = config_flags%fft_filter_lat                &
+                  ,dclat = dclat                                               &
+                  ,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             &
+                  ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
+                  ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
+
+     END IF
+
+!-----------------------------------------------------------
+!  end polar filter for full dynamics variables and time-averaged mass fluxes 
+!-----------------------------------------------------------
+
+!-----------------------------------------------------------------------
+!  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%moist_adv_opt /= ORIGINAL) .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%mu_1, grid%mu_1, grid%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
+#ifdef DM_PARALLEL
+       IF (config_flags%moist_adv_opt /= ORIGINAL) THEN
+         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
+       ENDIF
+#endif
+
+#ifdef DM_PARALLEL
+#  include "PERIOD_BDY_EM_MOIST_OLD.inc"
+#endif
+
+       !$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
+
+     END IF  ! end if for moist_adv_opt
+
+! scalars
+
+     IF ((config_flags%scalar_adv_opt /= ORIGINAL) .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%mu_1, grid%mu_1, grid%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
+#ifdef DM_PARALLEL
+       IF (config_flags%scalar_adv_opt /= ORIGINAL) 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
+
+#ifdef DM_PARALLEL
+#  include "PERIOD_BDY_EM_SCALAR_OLD.inc"
+#endif
+         !$OMP PARALLEL DO   &
+         !$OMP PRIVATE ( ij )
+
+         DO ij = 1 , grid%num_tiles
+           IF (num_3d_s >= 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
+
+       END IF  ! end if for scalar_adv_opt
+
+! chem
+
+       IF ((config_flags%chem_adv_opt /= ORIGINAL) .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_c
+             CALL rk_update_scalar_pd( im, im,                                  &
+                                       chem_old(ims,kms,jms,im),                &
+                                       chem_tend(ims,kms,jms,im),               &
+                                       grid%mu_1, grid%mu_1, grid%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
+#ifdef DM_PARALLEL
+         IF (config_flags%chem_adv_opt /= ORIGINAL) THEN
+           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
+         ENDIF
+#endif
+
+#ifdef DM_PARALLEL
+#  include "PERIOD_BDY_EM_CHEM_OLD.inc"
+#endif
+
+         !$OMP PARALLEL DO   &
+         !$OMP PRIVATE ( ij )
+         DO ij = 1 , grid%num_tiles
+           IF (num_3d_c >= PARAM_FIRST_SCALAR) THEN
+             DO im = PARAM_FIRST_SCALAR , num_3d_c
+               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
+
+       ENDIF  ! end if for chem_adv_opt
+
+! tracer
+
+       IF ((config_flags%tracer_adv_opt /= ORIGINAL) .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_tracer
+             CALL rk_update_scalar_pd( im, im,                                  &
+                                       tracer_old(ims,kms,jms,im),                &
+                                       tracer_tend(ims,kms,jms,im),               &
+                                       grid%mu_1, grid%mu_1, grid%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
+#ifdef DM_PARALLEL
+         IF (config_flags%tracer_adv_opt /= ORIGINAL) THEN
+           IF      ( config_flags%h_sca_adv_order <= 4 ) THEN
+#     include "HALO_EM_TRACER_OLD_E_5.inc"
+           ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
+#     include "HALO_EM_TRACER_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
+#endif
+
+#ifdef DM_PARALLEL
+#  include "PERIOD_BDY_EM_TRACER_OLD.inc"
+#endif
+
+         !$OMP PARALLEL DO   &
+         !$OMP PRIVATE ( ij )
+         DO ij = 1 , grid%num_tiles
+           IF (num_tracer >= PARAM_FIRST_SCALAR) THEN
+             DO im = PARAM_FIRST_SCALAR , num_tracer
+               CALL set_physical_bc3d(  tracer_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
+
+       ENDIF  ! end if for tracer_adv_opt
+
+! tke
+
+       IF ((config_flags%tke_adv_opt /= ORIGINAL) .and. (rk_step == rk_order) &
+           .and. (config_flags%km_opt .eq. 2)                ) THEN
+
+         !$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%tke_1,                              &
+                                     tke_tend(ims,kms,jms),                   &
+                                     grid%mu_1, grid%mu_1, grid%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
+         !$OMP END PARALLEL DO
+
+!---------------------- positive definite bc call
+#ifdef DM_PARALLEL
+         IF (config_flags%tke_adv_opt /= ORIGINAL) THEN
+           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
+#endif
+
+#ifdef DM_PARALLEL
+#  include "PERIOD_BDY_EM_TKE_OLD.inc"
+#endif
+
+         !$OMP PARALLEL DO   &
+         !$OMP PRIVATE ( ij )
+         DO ij = 1 , grid%num_tiles
+           CALL set_physical_bc3d(  grid%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
+
+       END IF  ! end if for tke_adv_opt
+
+#ifdef DM_PARALLEL
+!
+!  Stencils for patch communications  (WCS, 29 June 2001)
+!
+!          * * * * *            
+!          * * * * *            
+!          * * + * *            
+!          * * * * *            
+!          * * * * *            
+!
+! ru_m         x
+! rv_m         x
+! ww_m         x
+! mut          x
+!
+!--------------------------------------------------------------
+
+#  include "HALO_EM_D.inc"
+! WCS addition 11/19/08
+#  include "PERIOD_EM_DA.inc"
+#endif
+
+!<DESCRIPTION>
+!<pre>
+! (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_update_scalar).
+!</pre>
+!</DESCRIPTION>
+
+
+       moist_scalar_advance: IF (num_3d_m >= PARAM_FIRST_SCALAR )  THEN
+
+         moist_variable_loop: DO im = PARAM_FIRST_SCALAR, num_3d_m
+
+! adv_moist_cond is set in module_physics_init based on mp_physics choice
+!       true except for Ferrier scheme
+
+           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' )
+               tenddec = .false.
+
+BENCH_START(rk_scalar_tend_tim)
+               CALL rk_scalar_tend (  im, im, config_flags, tenddec,         & 
+                           rk_step, dt_rk,                                   &
+                           grid%ru_m, grid%rv_m, grid%ww_m,                  &
+                           grid%muts, grid%mub, grid%mu_1,                   &
+                           grid%alt,                                         &
+                           moist_old(ims,kms,jms,im),                        &
+                           moist(ims,kms,jms,im),                            &
+                           moist_tend(ims,kms,jms,im),                       &
+                           advect_tend,h_tendency,z_tendency,grid%rqvften,   & 
+                           grid%qv_base, .true., grid%fnm, grid%fnp,         &
+                           grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv,&
+                           grid%msfvy, grid%msftx,grid%msfty,                & 
+                           grid%rdx, grid%rdy, grid%rdn, grid%rdnw, grid%khdif, &
+                           grid%kvdif, grid%xkhh,                            &
+                           grid%diff_6th_opt, grid%diff_6th_factor,          &
+                           config_flags%moist_adv_opt,                       &
+                           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%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' )
+               tenddec = .false.
+
+BENCH_START(update_scal_tim)
+               CALL rk_update_scalar( scs=im, sce=im,                                  &
+                               scalar_1=moist_old(ims,kms,jms,im),                     &
+                               scalar_2=moist(ims,kms,jms,im),                         &
+                               sc_tend=moist_tend(ims,kms,jms,im),                     &
+!                              advh_t=advh_t(ims,kms,jms,1),                           & 
+!                              advz_t=advz_t(ims,kms,jms,1),                           & 
+                               advect_tend=advect_tend,                                &
+                               h_tendency=h_tendency, z_tendency=z_tendency,           & 
+                               msftx=grid%msftx,msfty=grid%msfty,                      &
+                               mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub,   &
+                               rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone,    &
+                               config_flags=config_flags, tenddec=tenddec,             & 
+                               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=grid%i_start(ij), ite=grid%i_end(ij),               &
+                               jts=grid%j_start(ij), jte=grid%j_end(ij),               &
+                               kts=k_start    , kte=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%ru_m, grid%rv_m, config_flags,             &
+                                grid%spec_zone,                                 &
+                                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
+               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' )
+           tenddec = .false.
+           CALL rk_scalar_tend ( 1, 1, config_flags, tenddec,                      & 
+                            rk_step, dt_rk,                                        &
+                            grid%ru_m, grid%rv_m, grid%ww_m,                       &
+                            grid%muts, grid%mub, grid%mu_1,                        &
+                            grid%alt,                                              &
+                            grid%tke_1,                                            &
+                            grid%tke_2,                                            &
+                            tke_tend(ims,kms,jms),                                 &
+                            advect_tend,h_tendency,z_tendency,grid%rqvften,        & 
+                            grid%qv_base, .false., grid%fnm, grid%fnp,             &
+                            grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv,     &
+                            grid%msfvy, grid%msftx,grid%msfty,                     &
+                            grid%rdx, grid%rdy, grid%rdn, grid%rdnw, grid%khdif,   &
+                            grid%kvdif, grid%xkhh,                                 &
+                            grid%diff_6th_opt, grid%diff_6th_factor,               &
+                            config_flags%tke_adv_opt,                              &
+                            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' )
+           tenddec = .false.
+           CALL rk_update_scalar( scs=1,  sce=1,                                          &
+                                  scalar_1=grid%tke_1,                                    &
+                                  scalar_2=grid%tke_2,                                    &
+                                  sc_tend=tke_tend(ims,kms,jms),                          &
+!                                 advh_t=advh_t(ims,kms,jms,1),                           & 
+!                                 advz_t=advz_t(ims,kms,jms,1),                           & 
+                                  advect_tend=advect_tend,                                &
+                                  h_tendency=h_tendency, z_tendency=z_tendency,           & 
+                                  msftx=grid%msftx,msfty=grid%msfty,                      &
+                                  mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub,   &
+                                  rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone,    &
+                                  config_flags=config_flags, tenddec=tenddec,             & 
+                                  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=grid%i_start(ij), ite=grid%i_end(ij),               &
+                                  jts=grid%j_start(ij), jte=grid%j_end(ij),               &
+                                  kts=k_start    , kte=k_end                              )
+
+! bound the tke (greater than 0, less than tke_upper_bound)
+
+           CALL bound_tke( grid%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%tke_2,                     &
+                                   grid%ru_m, grid%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
+
+       ENDIF 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' )
+             tenddec = (( config_flags%chemdiag == USECHEMDIAG ) .and. &
+                        ( adv_ct_indices(ic) >= PARAM_FIRST_SCALAR ))
+             CALL rk_scalar_tend ( ic, ic, config_flags, tenddec,                & 
+                              rk_step, dt_rk,                                    &
+                              grid%ru_m, grid%rv_m, grid%ww_m,                   &
+                              grid%muts, grid%mub, grid%mu_1,                    &
+                              grid%alt,                                          &
+                              chem_old(ims,kms,jms,ic),                          &
+                              chem(ims,kms,jms,ic),                              &
+                              chem_tend(ims,kms,jms,ic),                         &
+                              advect_tend,h_tendency,z_tendency,grid%rqvften,    & 
+                              grid%qv_base, .false., grid%fnm, grid%fnp,         &
+                              grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv, &
+                              grid%msfvy, grid%msftx,grid%msfty,                 &
+                              grid%rdx, grid%rdy, grid%rdn, grid%rdnw,           &
+                              grid%khdif, grid%kvdif, grid%xkhh,                 &
+                              grid%diff_6th_opt, grid%diff_6th_factor,           &
+                              config_flags%chem_adv_opt,                         &
+                              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%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,                                    &
+                                     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 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,                                    &
+                                     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
+
+         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' )
+           tenddec = (( config_flags%chemdiag == USECHEMDIAG ) .and. &
+                      ( adv_ct_indices(ic) >= PARAM_FIRST_SCALAR ))
+           CALL rk_update_scalar( scs=ic, sce=ic,                                         &
+                                  scalar_1=chem_old(ims,kms,jms,ic),                      &
+                                  scalar_2=chem(ims,kms,jms,ic),                          &
+                                  sc_tend=chem_tend(ims,kms,jms,ic),                      &
+                                  advh_t=advh_ct(ims,kms,jms,adv_ct_indices(ic)),         &
+                                  advz_t=advz_ct(ims,kms,jms,adv_ct_indices(ic)),         &
+                                  advect_tend=advect_tend,                                &
+                                  h_tendency=h_tendency, z_tendency=z_tendency,           & 
+                                  msftx=grid%msftx,msfty=grid%msfty,                      &
+                                  mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub,   &
+                                  rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone,    &
+                                  config_flags=config_flags, tenddec=tenddec,             & 
+                                  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=grid%i_start(ij), ite=grid%i_end(ij),               &
+                                  jts=grid%j_start(ij), jte=grid%j_end(ij),               &
+                                  kts=k_start    , kte=k_end                              )
+
+           IF( config_flags%specified  ) THEN
+             CALL flow_dep_bdy_chem( chem(ims,kms,jms,ic),                          &
+                                     chem_bxs(jms,kms,1,ic), chem_btxs(jms,kms,1,ic),  &
+                                     chem_bxe(jms,kms,1,ic), chem_btxe(jms,kms,1,ic),  &
+                                     chem_bys(ims,kms,1,ic), chem_btys(ims,kms,1,ic),  &
+                                     chem_bye(ims,kms,1,ic), chem_btye(ims,kms,1,ic),  &
+                                     dt_rk+grid%dtbc,                                  &
+                                     config_flags%spec_bdy_width,grid%z,      &
+                                     grid%have_bcs_chem,      &
+                                     grid%ru_m, grid%rv_m, config_flags,grid%alt,       &
+                                     grid%t_1,grid%pb,grid%p,t0,p1000mb,rcp,grid%ph_2,grid%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
+         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 chemical species
+BENCH_START(tracer_adv_tim)
+       tracer_advance: IF (num_tracer >= PARAM_FIRST_SCALAR)  THEN
+
+         tracer_variable_loop: DO ic = PARAM_FIRST_SCALAR, num_tracer
+
+           !$OMP PARALLEL DO   &
+           !$OMP PRIVATE ( ij )
+           tracer_tile_loop_1: DO ij = 1 , grid%num_tiles
+
+             CALL wrf_debug ( 15 , ' call rk_scalar_tend in tracer_tile_loop_1' )
+             tenddec = .false.
+             CALL rk_scalar_tend ( ic, ic, config_flags, tenddec,                & 
+                              rk_step, dt_rk,                                    &
+                              grid%ru_m, grid%rv_m, grid%ww_m,                   &
+                              grid%muts, grid%mub, grid%mu_1,                    &
+                              grid%alt,                                          &
+                              tracer_old(ims,kms,jms,ic),                          &
+                              tracer(ims,kms,jms,ic),                              &
+                              tracer_tend(ims,kms,jms,ic),                         &
+                              advect_tend,h_tendency,z_tendency,grid%rqvften,    & 
+                              grid%qv_base, .false., grid%fnm, grid%fnp,         &
+                              grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv, &
+                              grid%msfvy, grid%msftx,grid%msfty,                 &
+                              grid%rdx, grid%rdy, grid%rdn, grid%rdnw,           &
+                              grid%khdif, grid%kvdif, grid%xkhh,                 &
+                              grid%diff_6th_opt, grid%diff_6th_factor,           &
+                              config_flags%tracer_adv_opt,                         &
+                              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_tracer' )
+             CALL relax_bdy_scalar ( tracer_tend(ims,kms,jms,ic),                                    &
+                                     tracer(ims,kms,jms,ic),  grid%mut,                              &
+                                     tracer_bxs(jms,kms,1,ic),tracer_bxe(jms,kms,1,ic),                &
+                                     tracer_bys(ims,kms,1,ic),tracer_bye(ims,kms,1,ic),                &
+                                     tracer_btxs(jms,kms,1,ic),tracer_btxe(jms,kms,1,ic),              &
+                                     tracer_btys(ims,kms,1,ic),tracer_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,                                    &
+                                     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 spec_bdy_scalar  ( tracer_tend(ims,kms,jms,ic),                 &
+                                     tracer_bxs(jms,kms,1,ic),tracer_bxe(jms,kms,1,ic),                &
+                                     tracer_bys(ims,kms,1,ic),tracer_bye(ims,kms,1,ic),                &
+                                     tracer_btxs(jms,kms,1,ic),tracer_btxe(jms,kms,1,ic),              &
+                                     tracer_btys(ims,kms,1,ic),tracer_btye(ims,kms,1,ic),              &
+                                     config_flags%spec_bdy_width, grid%spec_zone,                  &
+                                     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                                                )
+           ENDIF
+
+         ENDDO tracer_tile_loop_1
+         !$OMP END PARALLEL DO
+
+         !$OMP PARALLEL DO   &
+         !$OMP PRIVATE ( ij )
+
+         tracer_tile_loop_2: DO ij = 1 , grid%num_tiles
+
+           CALL wrf_debug ( 200 , ' call rk_update_scalar' )
+           tenddec = .false.
+           CALL rk_update_scalar( scs=ic, sce=ic,                                         &
+                                  scalar_1=tracer_old(ims,kms,jms,ic),                    &
+                                  scalar_2=tracer(ims,kms,jms,ic),                        &
+                                  sc_tend=tracer_tend(ims,kms,jms,ic),                    &
+!                                 advh_t=advh_t(ims,kms,jms,1),                           & 
+!                                 advz_t=advz_t(ims,kms,jms,1),                           & 
+                                  advect_tend=advect_tend,                                &
+                                  h_tendency=h_tendency, z_tendency=z_tendency,           & 
+                                  msftx=grid%msftx,msfty=grid%msfty,                      &
+                                  mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub,   &
+                                  rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone,    &
+                                  config_flags=config_flags, tenddec=tenddec,             & 
+                                  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=grid%i_start(ij), ite=grid%i_end(ij),               &
+                                  jts=grid%j_start(ij), jte=grid%j_end(ij),               &
+                                  kts=k_start    , kte=k_end                              )
+
+           IF( config_flags%specified  ) THEN
+#ifdef WRF_CHEM
+             CALL flow_dep_bdy_tracer( tracer(ims,kms,jms,ic),                             &
+                                     tracer_bxs(jms,kms,1,ic), tracer_btxs(jms,kms,1,ic),  &
+                                     tracer_bxe(jms,kms,1,ic), tracer_btxe(jms,kms,1,ic),  &
+                                     tracer_bys(ims,kms,1,ic), tracer_btys(ims,kms,1,ic),  &
+                                     tracer_bye(ims,kms,1,ic), tracer_btye(ims,kms,1,ic),  &
+                                     dt_rk+grid%dtbc,                                  &
+                                     config_flags%spec_bdy_width,grid%z,      &
+                                     grid%have_bcs_tracer,      &
+                                     grid%ru_m, grid%rv_m, config_flags%tracer_opt,grid%alt,       &
+                                     grid%t_1,grid%pb,grid%p,t0,p1000mb,rcp,grid%ph_2,grid%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                      )
+#else
+             CALL flow_dep_bdy  ( tracer(ims,kms,jms,ic),     &
+                                  grid%ru_m, grid%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
+         ENDDO tracer_tile_loop_2
+         !$OMP END PARALLEL DO
+
+       ENDDO tracer_variable_loop
+     ENDIF tracer_advance
+BENCH_END(tracer_adv_tim)
+
+!  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' )
+           tenddec = .false.
+           CALL rk_scalar_tend ( is, is, config_flags, tenddec,                   & 
+                                 rk_step, dt_rk,                                  &
+                                 grid%ru_m, grid%rv_m, grid%ww_m,                 &
+                                 grid%muts, grid%mub, grid%mu_1,                  &
+                                 grid%alt,                                        &
+                                 scalar_old(ims,kms,jms,is),                      &
+                                 scalar(ims,kms,jms,is),                          &
+                                 scalar_tend(ims,kms,jms,is),                     &
+                                 advect_tend,h_tendency,z_tendency,grid%rqvften,  & 
+                                 grid%qv_base, .false., grid%fnm, grid%fnp,       &
+                                 grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv, &
+                                 grid%msfvy, grid%msftx,grid%msfty,               &
+                                 grid%rdx, grid%rdy, grid%rdn, grid%rdnw,         &
+                                 grid%khdif, grid%kvdif, grid%xkhh,               &
+                                 grid%diff_6th_opt, grid%diff_6th_factor,         &
+                                 config_flags%scalar_adv_opt,                     &
+                                 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
+
+               CALL relax_bdy_scalar ( scalar_tend(ims,kms,jms,is),                            &
+                                       scalar(ims,kms,jms,is),  grid%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,                              &
+                                       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 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,                              &
+                                       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 ! 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' )
+           tenddec = .false.
+           CALL rk_update_scalar( scs=is, sce=is,                                         &
+                                  scalar_1=scalar_old(ims,kms,jms,is),                    &
+                                  scalar_2=scalar(ims,kms,jms,is),                        &
+                                  sc_tend=scalar_tend(ims,kms,jms,is),                    &
+!                                 advh_t=advh_t(ims,kms,jms,1),                           & 
+!                                 advz_t=advz_t(ims,kms,jms,1),                           & 
+                                  advect_tend=advect_tend,                                &
+                                  h_tendency=h_tendency, z_tendency=z_tendency,           & 
+                                  msftx=grid%msftx,msfty=grid%msfty,                      &
+                                  mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub,   &
+                                  rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone,    &
+                                  config_flags=config_flags, tenddec=tenddec,             & 
+                                  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=grid%i_start(ij), ite=grid%i_end(ij),               &
+                                  jts=grid%j_start(ij), jte=grid%j_end(ij),               &
+                                  kts=k_start    , kte=k_end                              )
+
+           IF( config_flags%specified ) THEN
+
+             CALL flow_dep_bdy  ( scalar(ims,kms,jms,is),     &
+                                  grid%ru_m, grid%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%al, grid%alb, grid%mu_2, grid%muts,              &
+                            grid%ph_2, grid%p, grid%pb, grid%t_2,                 &
+                            p0, t0, grid%znu, grid%dnw, grid%rdnw,           &
+                            grid%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
+
+!-----------------------------------------------------------
+!  rk3 substep polar filter for scalars (moist,chem,scalar)
+!-----------------------------------------------------------
+
+       IF (config_flags%polar) THEN 
+         IF ( num_3d_m >= PARAM_FIRST_SCALAR ) THEN
+           CALL wrf_debug ( 200 , ' call filter moist ' )
+           DO im = PARAM_FIRST_SCALAR, num_3d_m
+             CALL couple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im)              &
+                    ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                    ,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          )
+             CALL pxft ( grid=grid                                               &
+                    ,lineno=__LINE__                                             &
+                    ,flag_uv            = 0                                      &
+                    ,flag_rurv          = 0                                      &
+                    ,flag_wph           = 0                                      &
+                    ,flag_ww            = 0                                      &
+                    ,flag_t             = 0                                      &
+                    ,flag_mu            = 0                                      &
+                    ,flag_mut           = 0                                      &
+                    ,flag_moist         = im                                     &
+                    ,flag_chem          = 0                                      &
+                    ,flag_scalar        = 0                                      &
+                    ,flag_tracer        = 0                                      &
+                    ,positive_definite=.FALSE.                                   &
+                    ,moist=moist,chem=chem,tracer=tracer,scalar=scalar           &
+                    ,fft_filter_lat = config_flags%fft_filter_lat                &
+                    ,dclat = dclat                                               &
+                    ,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             &
+                    ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
+                    ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
+             CALL uncouple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im)            &
+                    ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                    ,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          )
+           END DO
+         END IF
+   
+         IF ( num_3d_c >= PARAM_FIRST_SCALAR ) THEN
+           CALL wrf_debug ( 200 , ' call filter chem ' )
+           DO im = PARAM_FIRST_SCALAR, num_3d_c
+             CALL couple_scalars_for_filter ( FIELD=chem(ims,kms,jms,im)               &
+                    ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                    ,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           )
+             CALL pxft ( grid=grid                                               &
+                    ,lineno=__LINE__                                             &
+                    ,flag_uv            = 0                                      &
+                    ,flag_rurv          = 0                                      &
+                    ,flag_wph           = 0                                      &
+                    ,flag_ww            = 0                                      &
+                    ,flag_t             = 0                                      &
+                    ,flag_mu            = 0                                      &
+                    ,flag_mut           = 0                                      &
+                    ,flag_moist         = 0                                      &
+                    ,flag_chem          = im                                     &
+                    ,flag_tracer        = 0                                      &
+                    ,flag_scalar        = 0                                      &
+                    ,positive_definite=.FALSE.                                   &
+                    ,moist=moist,chem=chem,tracer=tracer,scalar=scalar           &
+                    ,fft_filter_lat = config_flags%fft_filter_lat                &
+                    ,dclat = dclat                                               &
+                    ,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             &
+                    ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
+                    ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
+             CALL uncouple_scalars_for_filter ( FIELD=chem(ims,kms,jms,im)             &
+                    ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                    ,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          )
+           END DO
+         END IF
+         IF ( num_tracer >= PARAM_FIRST_SCALAR ) THEN
+           CALL wrf_debug ( 200 , ' call filter tracer ' )
+           DO im = PARAM_FIRST_SCALAR, num_tracer
+             CALL couple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im)               &
+                    ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                    ,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           )
+             CALL pxft ( grid=grid                                               &
+                    ,lineno=__LINE__                                             &
+                    ,flag_uv            = 0                                      &
+                    ,flag_rurv          = 0                                      &
+                    ,flag_wph           = 0                                      &
+                    ,flag_ww            = 0                                      &
+                    ,flag_t             = 0                                      &
+                    ,flag_mu            = 0                                      &
+                    ,flag_mut           = 0                                      &
+                    ,flag_moist         = 0                                      &
+                    ,flag_chem          = 0                                      &
+                    ,flag_tracer        = im                                      &
+                    ,flag_scalar        = 0                                      &
+                    ,positive_definite=.FALSE.                                   &
+                    ,moist=moist,chem=chem,tracer=tracer,scalar=scalar           &
+                    ,fft_filter_lat = config_flags%fft_filter_lat                &
+                    ,dclat = dclat                                               &
+                    ,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             &
+                    ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
+                    ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
+             CALL uncouple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im)             &
+                    ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                    ,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          )
+           END DO
+         END IF
+   
+         IF ( num_3d_s >= PARAM_FIRST_SCALAR ) THEN
+           CALL wrf_debug ( 200 , ' call filter scalar ' )
+           DO im = PARAM_FIRST_SCALAR, num_3d_s
+             CALL couple_scalars_for_filter ( FIELD=scalar(ims,kms,jms,im)           &
+                  ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                  ,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          )
+             CALL pxft ( grid=grid                                             &
+                  ,lineno=__LINE__                                             &
+                  ,flag_uv            = 0                                      &
+                  ,flag_rurv          = 0                                      &
+                  ,flag_wph           = 0                                      &
+                  ,flag_ww            = 0                                      &
+                  ,flag_t             = 0                                      &
+                  ,flag_mu            = 0                                      &
+                  ,flag_mut           = 0                                      &
+                  ,flag_moist         = 0                                      &
+                  ,flag_chem          = 0                                      &
+                  ,flag_tracer        = 0                                      &
+                  ,flag_scalar        = im                                     &
+                  ,positive_definite=.FALSE.                                   &
+                  ,moist=moist,chem=chem,tracer=tracer,scalar=scalar           &
+                  ,fft_filter_lat = config_flags%fft_filter_lat                &
+                  ,dclat = dclat                                               &
+                  ,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             &
+                  ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
+                  ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
+             CALL uncouple_scalars_for_filter ( FIELD=scalar(ims,kms,jms,im)   &
+                  ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                  ,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          )
+           END DO
+         END IF
+       END IF ! polar filter test
+
+!-----------------------------------------------------------
+!  END rk3 substep polar filter for scalars (moist,chem,scalar)
+!-----------------------------------------------------------
+
+!-----------------------------------------------------------
+!  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.
+!
+!
+!                                  * * * * * * *
+!                     * * * * *    * * * * * * *
+!            *        * * * * *    * * * * * * *
+!          * + *      * * + * *    * * * + * * *
+!            *        * * * * *    * * * * * * *
+!                     * * * * *    * * * * * * *
+!                                  * * * * * * *
+!
+! al        x
+!
+!  2D variable
+! mu_2      x
+!
+! (adv order <=4)
+! u_2                     x
+! v_2                     x
+! w_2                     x
+! t_2                     x
+! ph_2                    x
+!
+! (adv order <=6)
+! u_2                                    x
+! v_2                                    x
+! w_2                                    x
+! t_2                                    x
+! ph_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_TRACER2.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%u_2, grid%v_2, grid%w_2,     &
+                                grid%t_2, grid%ph_2, grid%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%ph_2, grid%ph_1, grid%w_2, grid%muts, dt_rk,  &
+                            grid%u_2, grid%v_2, grid%ht,                           &
+                            grid%cf1, grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msftx, grid%msfty, &
+                            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_tracer >= PARAM_FIRST_SCALAR) THEN
+
+           tracer_species_bdy_loop_1 : DO ic = PARAM_FIRST_SCALAR , num_tracer
+
+             CALL set_physical_bc3d( tracer(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 tracer_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%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%tke_adv_opt /= ORIGINAL) .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%tke_adv_opt /= ORIGINAL) .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 ( num_moist .GE. PARAM_FIRST_SCALAR ) THEN
+         IF      ( config_flags%h_sca_adv_order <= 4 ) THEN
+           IF ( (config_flags%moist_adv_opt /= ORIGINAL) .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%moist_adv_opt /= ORIGINAL) .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%chem_adv_opt /= ORIGINAL) .and. (rk_step == rk_order-1) ) THEN
+#        include "HALO_EM_CHEM_E_5.inc"
+           ELSE
+#        include "HALO_EM_CHEM_E_3.inc"
+           ENDIF
+         ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
+           IF ( (config_flags%chem_adv_opt /= ORIGINAL) .and. (rk_step == rk_order-1) ) THEN
+#        include "HALO_EM_CHEM_E_7.inc"
+           ELSE
+#        include "HALO_EM_CHEM_E_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
+       ENDIF
+       IF ( num_tracer >= PARAM_FIRST_SCALAR ) THEN
+         IF      ( config_flags%h_sca_adv_order <= 4 ) THEN
+           IF ( (config_flags%tracer_adv_opt /= ORIGINAL) .and. (rk_step == rk_order-1) ) THEN
+#        include "HALO_EM_TRACER_E_5.inc"
+           ELSE
+#        include "HALO_EM_TRACER_E_3.inc"
+           ENDIF
+         ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
+           IF ( (config_flags%tracer_adv_opt /= ORIGINAL) .and. (rk_step == rk_order-1) ) THEN
+#        include "HALO_EM_TRACER_E_7.inc"
+           ELSE
+#        include "HALO_EM_TRACER_E_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
+       ENDIF
+       IF ( num_scalar >= PARAM_FIRST_SCALAR ) THEN
+         IF      ( config_flags%h_sca_adv_order <= 4 ) THEN
+           IF ( (config_flags%scalar_adv_opt /= ORIGINAL) .and. (rk_step == rk_order-1) ) THEN
+#        include "HALO_EM_SCALAR_E_5.inc"
+           ELSE
+#        include "HALO_EM_SCALAR_E_3.inc"
+           ENDIF
+         ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN
+           IF ( (config_flags%scalar_adv_opt /= ORIGINAL) .and. (rk_step == rk_order-1) ) THEN
+#        include "HALO_EM_SCALAR_E_7.inc"
+           ELSE
+#        include "HALO_EM_SCALAR_E_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
+       ENDIF
+#endif
+
+     ENDIF rk_step_1_check
+
+
+!**********************************************************
+!
+!  end of RK predictor-corrector loop
+!
+!**********************************************************
+
+   END DO Runge_Kutta_loop
+#ifdef LMDZ1
+         WRITE(message, *)'  dyn_em: after runge_kutta_loop' 
+         CALL wrf_debug(200, message)
+         WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+           ' u_tend: ', ru_tendf(im2,1,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+           'p sfc: ',p8w(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+         WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+         CALL wrf_debug(200, message)
+#endif
+
+   IF (config_flags%do_avgflx_em .EQ. 1) THEN
+! Reinitialize time-averaged fluxes if history output was written after the previous time step:
+      CALL WRFU_ALARMGET(grid%alarms( HISTORY_ALARM ),prevringtime=temp_time)
+      CALL domain_clock_get ( grid, current_time=CurrTime, &
+           current_timestr=message2 )
+! use overloaded -, .LT. operator to check whether to initialize avgflx:
+! reinitialize after each history output (detect this here by comparing current time
+! against last history time and time step - this code follows what's done in adapt_timestep_em):
+      WRITE ( message , FMT = '("solve_em: old_dt =",g15.6,", dt=",g15.6," on domain ",I3)' ) &
+           & old_dt,grid%dt,grid%id
+      CALL wrf_debug(200,message)
+      old_dt=min(old_dt,grid%dt)
+      num = INT(old_dt * precision)
+      den = precision
+      CALL WRFU_TimeIntervalSet(dtInterval, Sn=num, Sd=den)
+      IF (CurrTime .lt. temp_time + dtInterval) THEN
+         WRITE ( message , FMT = '("solve_em: initializing avgflx at time ",A," on domain ",I3)' ) &
+              & TRIM(message2), grid%id
+         CALL wrf_message(trim(message)) 
+         grid%avgflx_count = 0
+!tile-loop for zero_avgflx
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+         DO ij = 1 , grid%num_tiles
+            CALL wrf_debug(200,'In solve_em, before zero_avgflx call')
+            CALL zero_avgflx(grid%avgflx_rum,grid%avgflx_rvm,grid%avgflx_wwm, &
+                 &   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, f_flux, &
+                 &   grid%avgflx_cfu1,grid%avgflx_cfd1,grid%avgflx_dfu1, &
+                 &   grid%avgflx_efu1,grid%avgflx_dfd1,grid%avgflx_efd1 )
+            CALL wrf_debug(200,'In solve_em, after zero_avgflx call')
+         ENDDO
+      ENDIF
+
+! Update avgflx quantities
+!tile-loop for upd_avgflx
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+
+      DO ij = 1 , grid%num_tiles
+         CALL wrf_debug(200,'In solve_em, before upd_avgflx call')
+         CALL upd_avgflx(grid%avgflx_count,grid%avgflx_rum,grid%avgflx_rvm,grid%avgflx_wwm, &
+              &   grid%ru_m, grid%rv_m, grid%ww_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, f_flux, &
+              &   grid%cfu1,grid%cfd1,grid%dfu1,grid%efu1,grid%dfd1,grid%efd1,          &
+              &   grid%avgflx_cfu1,grid%avgflx_cfd1,grid%avgflx_dfu1, &
+              &   grid%avgflx_efu1,grid%avgflx_dfd1,grid%avgflx_efd1 )
+         CALL wrf_debug(200,'In solve_em, after upd_avgflx call')
+         
+      ENDDO
+      grid%avgflx_count = grid%avgflx_count + 1
+   ENDIF
+!
+   !$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%rainsh,grid%pratec,grid%pratesh, &
+                      grid%nca,grid%htop,grid%hbot,grid%cutop,grid%cubot,  &
+                      grid%cuppt, grid%dt, 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
+
+!<DESCRIPTION>
+!<pre>
+! (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.
+!</pre>
+!</DESCRIPTION>
+
+   IF( config_flags%specified .or. config_flags%nested ) THEN
+     sz = grid%spec_zone
+   ELSE
+     sz = 0
+   ENDIF
+
+   IF (config_flags%mp_physics /= 0)  then
+
+     !$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%t_2, grid%t_1, t0, rho,                &
+                                   grid%al, grid%alb, grid%p, p8w, p0, grid%pb,          &
+                                   grid%ph_2, grid%phb, th_phy, pi_phy, p_phy, &
+                                   grid%z, grid%z_at_w, dz8w,                  &
+                                   dtm, grid%h_diabatic,                  &
+                                   config_flags,grid%fnm, grid%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%sr = 0.
+     specified_bdy = config_flags%specified .OR. config_flags%nested
+     channel_bdy = config_flags%specified .AND. config_flags%periodic_x
+
+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%sr              ,TH=th_phy                        &
+      &        ,refl_10cm=grid%refl_10cm                                  & ! hm, 9/22/09 for refl
+      &        ,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 &
+      &        ,CHEM_OPT=config_flags%chem_opt, PROGN=config_flags%progn  &
+#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         &
+#ifdef RUN_ON_GPU
+      &        ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe         &
+#endif
+      &        ,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     & ! for milbrandt2mom
+      &        , HAILNC=grid%hailnc, HAILNCV=grid%hailncv                 &
+      &        , W=grid%w_2, Z=grid%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               &
+      &        , QH_CURR=moist(ims,kms,jms,P_QH), F_QH=F_QH               & ! for milbrandt2mom
+      &        , QNDROP_CURR=scalar(ims,kms,jms,P_QNDROP), F_QNDROP=F_QNDROP &
+      &        , QT_CURR=scalar(ims,kms,jms,P_QT), F_QT=F_QT              &
+      &        , QNN_CURR=scalar(ims,kms,jms,P_QNN), F_QNN=F_QNN          &
+      &        , QNI_CURR=scalar(ims,kms,jms,P_QNI), F_QNI=F_QNI          &
+      &        , QNC_CURR=scalar(ims,kms,jms,P_QNC), F_QNC=F_QNC          &
+      &        , QNR_CURR=scalar(ims,kms,jms,P_QNR), F_QNR=F_QNR          &
+      &        , QNS_CURR=scalar(ims,kms,jms,P_QNS), F_QNS=F_QNS          &
+      &        , QNG_CURR=scalar(ims,kms,jms,P_QNG), F_QNG=F_QNG          &
+      &        , QNH_CURR=scalar(ims,kms,jms,P_QNH), F_QNH=F_QNH          & ! for milbrandt2mom
+!       &        , QZR_CURR=scalar(ims,kms,jms,P_QZR), F_QZR=F_QZR          & ! for milbrandt3mom
+!       &        , QZI_CURR=scalar(ims,kms,jms,P_QZI), F_QZI=F_QZI          & ! "
+!       &        , QZS_CURR=scalar(ims,kms,jms,P_QZS), F_QZS=F_QZS          & ! "
+!       &        , QZG_CURR=scalar(ims,kms,jms,P_QZG), F_QZG=F_QZG          & ! "
+!       &        , QZH_CURR=scalar(ims,kms,jms,P_QZH), F_QZH=F_QZH          & ! "
+      &        , qrcuten=grid%rqrcuten, qscuten=grid%rqscuten             &
+      &        , qicuten=grid%rqicuten,mu=grid%mut                        &
+      &        , HAIL=config_flags%gsfcgce_hail                           & ! for gsfcgce
+      &        , ICE2=config_flags%gsfcgce_2ice                           & ! for gsfcgce
+!     &        , ccntype=config_flags%milbrandt_ccntype                   & ! for milbrandt (2mom)
+! YLIN
+! RI_CURR INPUT
+      &        , RI_CURR=grid%rimi                                          &
+                                                                          )
+BENCH_END(micro_driver_tim)
+
+#ifdef LMDZ
+  grid%h_diabatic = 0.
+#endif
+
+#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, im, ii, jj, kk )
+
+     DO ij = 1 , grid%num_tiles
+
+       its = max(grid%i_start(ij),ids)
+       ite = min(grid%i_end(ij),ide-1)
+       jts = max(grid%j_start(ij),jds)
+       jte = min(grid%j_end(ij),jde-1)
+
+       CALL microphysics_zero_outb (                                    &
+                      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 microphysics_zero_outb (                                    &
+                      scalar , num_scalar , config_flags ,              &
+                      ids, ide, jds, jde, kds, kde,                     &
+                      ims, ime, jms, jme, kms, kme,                     &
+                      its, ite, jts, jte,                               &
+                      k_start    , k_end                                )
+
+       CALL microphysics_zero_outb (                                    &
+                      chem , num_chem , config_flags ,              &
+                      ids, ide, jds, jde, kds, kde,                     &
+                      ims, ime, jms, jme, kms, kme,                     &
+                      its, ite, jts, jte,                               &
+                      k_start    , k_end                                )
+       CALL microphysics_zero_outb (                                    &
+                      tracer , num_tracer , config_flags ,              &
+                      ids, ide, jds, jde, kds, kde,                     &
+                      ims, ime, jms, jme, kms, kme,                     &
+                      its, ite, jts, jte,                               &
+                      k_start    , k_end                                )
+
+       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_outa (                                    &
+                      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 microphysics_zero_outa (                                    &
+                      scalar , num_scalar , config_flags ,              &
+                      ids, ide, jds, jde, kds, kde,                     &
+                      ims, ime, jms, jme, kms, kme,                     &
+                      its, ite, jts, jte,                               &
+                      k_start    , k_end                                )
+
+       CALL microphysics_zero_outa (                                    &
+                      chem , num_chem , config_flags ,                  &
+                      ids, ide, jds, jde, kds, kde,                     &
+                      ims, ime, jms, jme, kms, kme,                     &
+                      its, ite, jts, jte,                               &
+                      k_start    , k_end                                )
+
+       CALL microphysics_zero_outa (                                    &
+                      tracer , num_tracer , 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%t_2, grid%t_1, t0, grid%muts, th_phy,       &
+                                      grid%h_diabatic, dtm, config_flags,    &
+#if ( WRF_DFI_RADAR == 1 )
+                                      grid%dfi_tten_rad,grid%dfi_stage,        &
+#endif
+                                      ids, ide, jds, jde, kds, kde,     &
+                                      ims, ime, jms, jme, kms, kme,     &
+                                      its, ite, jts, jte,               &
+                                      k_start    , k_end               )
+
+     END DO
+     !$OMP END PARALLEL DO
+
+   ENDIF  ! microphysics test
+
+!-----------------------------------------------------------
+!  filter for moist variables post-microphysics and end of timestep
+!-----------------------------------------------------------
+
+   IF (config_flags%polar) THEN
+     IF ( num_3d_m >= PARAM_FIRST_SCALAR ) THEN
+       CALL wrf_debug ( 200 , ' call filter moist' )
+       DO im = PARAM_FIRST_SCALAR, num_3d_m
+         DO jj = jps, MIN(jpe,jde-1)
+           DO kk = kps, MIN(kpe,kde-1)
+             DO ii = ips, MIN(ipe,ide-1)
+               moist(ii,kk,jj,im)=moist(ii,kk,jj,im)*(grid%mu_2(ii,jj)+grid%mub(ii,jj))
+             ENDDO
+           ENDDO
+         ENDDO
+ 
+         CALL pxft ( grid=grid                                                 &
+                  ,lineno=__LINE__                                             &
+                  ,flag_uv            = 0                                      &
+                  ,flag_rurv          = 0                                      &
+                  ,flag_wph           = 0                                      &
+                  ,flag_ww            = 0                                      &
+                  ,flag_t             = 0                                      &
+                  ,flag_mu            = 0                                      &
+                  ,flag_mut           = 0                                      &
+                  ,flag_moist         = im                                     &
+                  ,flag_chem          = 0                                      &
+                  ,flag_tracer        = 0                                      &
+                  ,flag_scalar        = 0                                      &
+                  ,positive_definite=.FALSE.                                   &
+                  ,moist=moist,chem=chem,tracer=tracer,scalar=scalar           &
+                  ,fft_filter_lat = config_flags%fft_filter_lat                &
+                  ,dclat = dclat                                               &
+                  ,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             &
+                  ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
+                  ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
+ 
+         DO jj = jps, MIN(jpe,jde-1)
+           DO kk = kps, MIN(kpe,kde-1)
+             DO ii = ips, MIN(ipe,ide-1)
+               moist(ii,kk,jj,im)=moist(ii,kk,jj,im)/(grid%mu_2(ii,jj)+grid%mub(ii,jj))
+             ENDDO
+           ENDDO
+         ENDDO
+       ENDDO
+     ENDIF
+   ENDIF
+
+!-----------------------------------------------------------
+!  end filter for moist variables post-microphysics and end of timestep
+!-----------------------------------------------------------
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij, its, ite, jts, jte, im, ii, jj, kk )
+   scalar_tile_loop_1ba: 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 calc_p_rho_phi( moist, num_3d_m,                &
+                          grid%al, grid%alb, grid%mu_2, grid%muts,              &
+                          grid%ph_2, grid%p, grid%pb, grid%t_2,                 &
+                          p0, t0, grid%znu, grid%dnw, grid%rdnw,           &
+                          grid%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_1ba
+   !$OMP END PARALLEL DO
+BENCH_END(moist_phys_end_tim)
+
+   IF (.not. config_flags%non_hydrostatic) THEN
+#ifdef DM_PARALLEL
+#    include "HALO_EM_HYDRO_UV.inc"
+#    include "PERIOD_EM_HYDRO_UV.inc"
+#endif
+     !$OMP PARALLEL DO   &
+     !$OMP PRIVATE ( ij )
+     DO ij = 1 , grid%num_tiles
+       CALL diagnose_w( ph_tend, grid%ph_2, grid%ph_1, grid%w_2, grid%muts, dt_rk,  &
+                       grid%u_2, grid%v_2, grid%ht,                           &
+                       grid%cf1, grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msftx, grid%msfty, &
+                       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
+
+   END IF
+
+   CALL wrf_debug ( 200 , ' call chem polar filter ' )
+
+!-----------------------------------------------------------
+!  filter for chem and scalar variables at end of timestep
+!-----------------------------------------------------------
+
+   IF (config_flags%polar) THEN
+
+     IF ( num_3d_c >= PARAM_FIRST_SCALAR ) then
+       chem_filter_loop: DO im = PARAM_FIRST_SCALAR, num_3d_c
+         DO jj = jps, MIN(jpe,jde-1)
+           DO kk = kps, MIN(kpe,kde-1)
+             DO ii = ips, MIN(ipe,ide-1)
+               chem(ii,kk,jj,im)=chem(ii,kk,jj,im)*(grid%mu_2(ii,jj)+grid%mub(ii,jj))
+             ENDDO
+           ENDDO
+         ENDDO
+
+         CALL pxft ( grid=grid                                                 &
+                  ,lineno=__LINE__                                             &
+                  ,flag_uv            = 0                                      &
+                  ,flag_rurv          = 0                                      &
+                  ,flag_wph           = 0                                      &
+                  ,flag_ww            = 0                                      &
+                  ,flag_t             = 0                                      &
+                  ,flag_mu            = 0                                      &
+                  ,flag_mut           = 0                                      &
+                  ,flag_moist         = 0                                      &
+                  ,flag_chem          = im                                     &
+                  ,flag_tracer        = 0                                      &
+                  ,flag_scalar        = 0                                      &
+                  ,positive_definite=.FALSE.                                   &
+                  ,moist=moist,chem=chem,tracer=tracer,scalar=scalar           &
+                  ,fft_filter_lat = config_flags%fft_filter_lat                &
+                  ,dclat = dclat                                               &
+                  ,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             &
+                  ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
+                  ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
+
+         DO jj = jps, MIN(jpe,jde-1)
+           DO kk = kps, MIN(kpe,kde-1)
+             DO ii = ips, MIN(ipe,ide-1)
+               chem(ii,kk,jj,im)=chem(ii,kk,jj,im)/(grid%mu_2(ii,jj)+grid%mub(ii,jj))
+             ENDDO
+           ENDDO
+         ENDDO
+       ENDDO chem_filter_loop
+     ENDIF
+     IF ( num_tracer >= PARAM_FIRST_SCALAR ) then
+       tracer_filter_loop: DO im = PARAM_FIRST_SCALAR, num_tracer
+         DO jj = jps, MIN(jpe,jde-1)
+           DO kk = kps, MIN(kpe,kde-1)
+             DO ii = ips, MIN(ipe,ide-1)
+               tracer(ii,kk,jj,im)=tracer(ii,kk,jj,im)*(grid%mu_2(ii,jj)+grid%mub(ii,jj))
+             ENDDO
+           ENDDO
+         ENDDO
+
+         CALL pxft ( grid=grid                                                 &
+                  ,lineno=__LINE__                                             &
+                  ,flag_uv            = 0                                      &
+                  ,flag_rurv          = 0                                      &
+                  ,flag_wph           = 0                                      &
+                  ,flag_ww            = 0                                      &
+                  ,flag_t             = 0                                      &
+                  ,flag_mu            = 0                                      &
+                  ,flag_mut           = 0                                      &
+                  ,flag_moist         = 0                                      &
+                  ,flag_chem          = 0                                      &
+                  ,flag_tracer        = im                                    &
+                  ,flag_scalar        = 0                                      &
+                  ,positive_definite=.FALSE.                                   &
+                  ,moist=moist,chem=chem,tracer=tracer,scalar=scalar           &
+                  ,fft_filter_lat = config_flags%fft_filter_lat                &
+                  ,dclat = dclat                                               &
+                  ,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             &
+                  ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
+                  ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
+
+         DO jj = jps, MIN(jpe,jde-1)
+           DO kk = kps, MIN(kpe,kde-1)
+             DO ii = ips, MIN(ipe,ide-1)
+               tracer(ii,kk,jj,im)=tracer(ii,kk,jj,im)/(grid%mu_2(ii,jj)+grid%mub(ii,jj))
+             ENDDO
+           ENDDO
+         ENDDO
+       ENDDO tracer_filter_loop
+     ENDIF
+
+     IF ( num_3d_s >= PARAM_FIRST_SCALAR ) then
+       scalar_filter_loop: DO im = PARAM_FIRST_SCALAR, num_3d_s
+         DO jj = jps, MIN(jpe,jde-1)
+           DO kk = kps, MIN(kpe,kde-1)
+             DO ii = ips, MIN(ipe,ide-1)
+               scalar(ii,kk,jj,im)=scalar(ii,kk,jj,im)*(grid%mu_2(ii,jj)+grid%mub(ii,jj))
+             ENDDO
+           ENDDO
+         ENDDO
+
+         CALL pxft ( grid=grid                                                 &
+                  ,lineno=__LINE__                                             &
+                  ,flag_uv            = 0                                      &
+                  ,flag_rurv          = 0                                      &
+                  ,flag_wph           = 0                                      &
+                  ,flag_ww            = 0                                      &
+                  ,flag_t             = 0                                      &
+                  ,flag_mu            = 0                                      &
+                  ,flag_mut           = 0                                      &
+                  ,flag_moist         = 0                                      &
+                  ,flag_chem          = 0                                      &
+                  ,flag_tracer        = 0                                      &
+                  ,flag_scalar        = im                                     &
+                  ,positive_definite=.FALSE.                                   &
+                  ,moist=moist,chem=chem,tracer=tracer,scalar=scalar           &
+                  ,fft_filter_lat = config_flags%fft_filter_lat                &
+                  ,dclat = dclat                                               &
+                  ,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             &
+                  ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
+                  ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
+
+         DO jj = jps, MIN(jpe,jde-1)
+           DO kk = kps, MIN(kpe,kde-1)
+             DO ii = ips, MIN(ipe,ide-1)
+               scalar(ii,kk,jj,im)=scalar(ii,kk,jj,im)/(grid%mu_2(ii,jj)+grid%mub(ii,jj))
+             ENDDO
+           ENDDO
+         ENDDO
+       ENDDO scalar_filter_loop
+     ENDIF
+   ENDIF
+
+!-----------------------------------------------------------
+!  end filter for chem and scalar variables at end of timestep
+!-----------------------------------------------------------
+
+   !  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%u_1                            x
+!   grid%u_2                            x
+!   grid%v_1                            x
+!   grid%v_2                            x
+!   grid%w_1                            x
+!   grid%w_2                            x
+!   grid%t_1                            x
+!   grid%t_2                            x
+!  grid%ph_1                            x
+!  grid%ph_2                            x
+!  grid%tke_1                           x
+!  grid%tke_2                           x
+!
+!    2D variables
+!  grid%mu_1     x
+!  grid%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_TRACER.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%u_1, grid%u_2, grid%v_1, grid%v_2, grid%w_1, grid%w_2,           &
+                             grid%t_1, grid%t_2, grid%ph_1, grid%ph_2, grid%mu_1, grid%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%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%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
+
+     tracer_species_bdy_loop_2 : DO ic = PARAM_FIRST_SCALAR , num_tracer
+
+       CALL set_physical_bc3d( tracer(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 tracer_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
+
+! reset surface w for consistency
+
+#ifdef DM_PARALLEL
+#  include "HALO_EM_C.inc"
+#  include "PERIOD_BDY_EM_E.inc"
+#endif
+
+   CALL wrf_debug ( 10 , ' call set_w_surface' )
+   fill_w_flag = .false.
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij )
+   DO ij = 1 , grid%num_tiles
+      CALL set_w_surface( config_flags, grid%znw, fill_w_flag,              &
+                           grid%w_2, grid%ht,  grid%u_2, grid%v_2,          &
+                           grid%cf1, grid%cf2, grid%cf3, grid%rdx, grid%rdy,&
+                           grid%msftx, grid%msfty,                          &
+                           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                                   )
+!                          its, ite, jts, jte, k_start, min(k_end,kde-1),   &
+
+   END DO
+   !$OMP END PARALLEL DO
+
+! calculate some model diagnostics.
+
+#ifdef LMDZ1
+     WRITE(message, *)'  dyn_em: before diagnostics' 
+     CALL wrf_debug(200, message)
+     WRITE(message, *)' t_tend: ',t_tendf(im2,km2,jm2),       &
+       ' u_tend: ', ru_tendf(im2,1,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' psfc_tend: ',grid%dpsdt(im2,jm2),      &
+       'p sfc: ',p8w(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+     WRITE(message,*)' p 1: ',grid%p(im2,kms,jm2), ' ph 1: ',grid%ph_2(im2,kms,jm2)
+     CALL wrf_debug(200, message)
+#endif
+   CALL wrf_debug ( 200 , ' call diagnostic_driver' )
+   
+   CALL diagnostic_output_calc(                                            &
+      &              DPSDT=grid%dpsdt   ,DMUDT=grid%dmudt                  &
+      &             ,P8W=p8w   ,PK1M=grid%pk1m                             &
+      &             ,MU_2=grid%mu_2  ,MU_2M=grid%mu_2m                     &
+      &             ,U=grid%u_2    ,V=grid%v_2                             &
+      &             ,RAINCV=grid%raincv    ,RAINNCV=grid%rainncv           &
+      &             ,RAINC=grid%rainc    ,RAINNC=grid%rainnc               &
+      &             ,I_RAINC=grid%i_rainc    ,I_RAINNC=grid%i_rainnc       &
+      &             ,HFX=grid%hfx   ,SFCEVP=grid%sfcevp    ,LH=grid%lh     &
+      &             ,DT=grid%dt      ,SBW=config_flags%spec_bdy_width      &
+      &             ,XTIME=grid%xtime   ,T2=grid%t2                        &
+      &        ,ACSWUPT=grid%acswupt    ,ACSWUPTC=grid%acswuptc            &
+      &        ,ACSWDNT=grid%acswdnt    ,ACSWDNTC=grid%acswdntc            &
+      &        ,ACSWUPB=grid%acswupb    ,ACSWUPBC=grid%acswupbc            &
+      &        ,ACSWDNB=grid%acswdnb    ,ACSWDNBC=grid%acswdnbc            &
+      &        ,ACLWUPT=grid%aclwupt    ,ACLWUPTC=grid%aclwuptc            &
+      &        ,ACLWDNT=grid%aclwdnt    ,ACLWDNTC=grid%aclwdntc            &
+      &        ,ACLWUPB=grid%aclwupb    ,ACLWUPBC=grid%aclwupbc            &
+      &        ,ACLWDNB=grid%aclwdnb    ,ACLWDNBC=grid%aclwdnbc            &
+      &      ,I_ACSWUPT=grid%i_acswupt  ,I_ACSWUPTC=grid%i_acswuptc        &
+      &      ,I_ACSWDNT=grid%i_acswdnt  ,I_ACSWDNTC=grid%i_acswdntc        &
+      &      ,I_ACSWUPB=grid%i_acswupb  ,I_ACSWUPBC=grid%i_acswupbc        &
+      &      ,I_ACSWDNB=grid%i_acswdnb  ,I_ACSWDNBC=grid%i_acswdnbc        &
+      &      ,I_ACLWUPT=grid%i_aclwupt  ,I_ACLWUPTC=grid%i_aclwuptc        &
+      &      ,I_ACLWDNT=grid%i_aclwdnt  ,I_ACLWDNTC=grid%i_aclwdntc        &
+      &      ,I_ACLWUPB=grid%i_aclwupb  ,I_ACLWUPBC=grid%i_aclwupbc        &
+      &      ,I_ACLWDNB=grid%i_aclwdnb  ,I_ACLWDNBC=grid%i_aclwdnbc        &
+                  ! Selection flag
+      &             ,DIAG_PRINT=config_flags%diag_print                    &
+      &             ,BUCKET_MM=config_flags%bucket_mm                      &
+      &             ,BUCKET_J =config_flags%bucket_J                       &
+      &             ,SNOWNCV=grid%snowncv, SNOW_ACC_NC=grid%snow_acc_nc    &
+      &             ,PREC_ACC_C=grid%prec_acc_c                            &
+      &             ,PREC_ACC_NC=grid%prec_acc_nc                          &
+      &             ,PREC_ACC_DT=config_flags%prec_acc_dt                  &
+      &             ,CURR_SECS=curr_secs                                   &
+                  ! 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_tracer >= PARAM_FIRST_SCALAR ) THEN
+!-----------------------------------------------------------------------
+! see above
+!--------------------------------------------------------------
+     CALL wrf_debug ( 200 , ' call HALO_RK_TRACER' )
+     IF      ( config_flags%h_mom_adv_order <= 4 ) THEN
+#      include "HALO_EM_TRACER_E_3.inc"
+     ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN
+#      include "HALO_EM_TRACER_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
+
+!  Max values of CFL for adaptive time step scheme
+
+   DEALLOCATE(max_vert_cfl_tmp)
+   DEALLOCATE(max_horiz_cfl_tmp)
+
+   CALL wrf_debug ( 200 , ' call end of solve_em' )
+
+! Finish timers if compiled with -DBENCH.
+#include <bench_solve_em_end.h>
+
+   RETURN
+
+END SUBROUTINE solve_em
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_em/start_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_em/start_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_em/start_em.F	(revision 17)
@@ -0,0 +1,1285 @@
+!-------------------------------------------------------------------
+
+   SUBROUTINE start_domain_em ( grid, allowed_to_read &
+! Actual arguments generated from Registry
+# include "dummy_new_args.inc"
+!
+)
+
+   USE module_domain, ONLY : domain, wrfu_timeinterval, get_ijk_from_grid, &
+        domain_setgmtetc
+   USE module_state_description
+   USE module_model_constants
+   USE module_bc, ONLY : boundary_condition_check, set_physical_bc2d
+   USE module_bc_em
+   USE module_configure, ONLY : grid_config_rec_type
+   USE module_tiles, ONLY : set_tiles
+#ifdef DM_PARALLEL
+   USE module_dm, ONLY : wrf_dm_min_real, wrf_dm_maxval, ntasks_x, ntasks_y, &
+        local_communicator_periodic, local_communicator, mytask, ntasks 
+#else
+   USE module_dm, ONLY : wrf_dm_min_real
+#endif
+   USE module_comm_dm
+
+   USE module_physics_init
+   USE module_fr_sfire_driver_wrf, ONLY : sfire_driver_em_init
+   USE module_stoch, ONLY : SETUP_STOCH,rand_seed, update_stoch
+#ifdef WRF_CHEM
+   USE module_aerosols_sorgam, ONLY: sum_pm_sorgam
+   USE module_gocart_aerosols, ONLY: sum_pm_gocart
+   USE module_mosaic_driver, ONLY: sum_pm_mosaic
+   USE module_input_tracer, ONLY: initialize_tracer
+#endif
+
+!!debug
+!USE module_compute_geop
+
+   USE module_model_constants
+   USE module_avgflx_em, ONLY : zero_avgflx
+
+   IMPLICIT NONE
+   !  Input data.
+   TYPE (domain)          :: grid
+
+   LOGICAL , INTENT(IN)   :: allowed_to_read
+
+   !  Definitions of dummy arguments to this routine (generated from Registry).
+# include "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 ::              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     :: i_m
+
+   REAL        :: p00, t00, a, tiso, p_surf, pd_surf, temp
+#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, fill_w_flag
+   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
+
+#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
+   TYPE(WRFU_TimeInterval) :: stepTime
+   REAL, DIMENSION(:,:), ALLOCATABLE :: clat_glob
+   logical :: f_flux  ! flag for computing averaged fluxes in cu_gd
+
+   INTEGER :: idex, jdex
+   INTEGER :: im1,ip1,jm1,jp1
+   REAL :: hx,hy,pi
+
+   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 )
+
+   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
+
+!   --- SETUP AND INITIALIZE STOCHASTIC KINETIC ENERGY BACKSCATTER SCHEME ---
+
+   IF ( (grid%id.eq.1) .AND. ( .NOT. grid%did_stoch ) ) THEN
+   grid%did_stoch = .TRUE.
+   stoch_force_select: SELECT CASE(config_flags%stoch_force_opt)
+
+   CASE (STOCH_BACKSCATTER)
+
+     IF ( wrf_dm_on_monitor () ) THEN
+       CALL rand_seed ( config_flags, grid%SEED1, grid%SEED2, grid%NENS )
+     ENDIF
+#ifdef DM_PARALLEL
+     CALL wrf_dm_bcast_bytes ( grid%SEED1, IWORDSIZE )
+     CALL wrf_dm_bcast_bytes ( grid%SEED2, IWORDSIZE )
+#endif
+
+     call SETUP_STOCH(grid%VERTSTRUCC,grid%VERTSTRUCS,                   &
+                      grid%SPT_AMP,grid%SPSTREAM_AMP,                    &
+                      grid%stoch_vertstruc_opt,                          & 
+                      grid%SEED1,grid%SEED2,grid%time_step,              &
+                      grid%DX,grid%DY,                                   &
+                      grid%TOT_BACKSCAT_PSI,grid%TOT_BACKSCAT_T,         &
+                      ids, ide, jds, jde, kds, kde,                      &
+                      ims, ime, jms, jme, kms, kme,                      &
+                      its, ite, jts, jte, kts, kte                       )
+    
+    END SELECT stoch_force_select
+    END IF
+!   --- END SETUP STOCHASTIC KINETIC ENERGY BACKSCATTER SCHEME ----------
+
+   IF ( config_flags%polar ) THEN
+!write(0,*)__FILE__,__LINE__,' clat ',ips,ipe,jps,jpe
+!do j = jps,jpe
+!write(0,*)__FILE__,__LINE__,' clat ',ids,j,grid%clat(ips,j)
+!enddo
+
+#ifdef DM_PARALLEL
+! WARNING:  this might present scaling issues on very large numbers of processors
+     ALLOCATE( clat_glob(ids:ide,jds:jde) )
+
+     CALL wrf_patch_to_global_real ( grid%clat, clat_glob, grid%domdesc, 'xy', 'xy', &
+                                     ids, ide, jds, jde, 1, 1, &
+                                     ims, ime, jms, jme, 1, 1, &
+                                     its, ite, jts, jte, 1, 1 )
+
+     CALL wrf_dm_bcast_real ( clat_glob , (ide-ids+1)*(jde-jds+1) )
+
+     grid%clat_xxx(ipsx:ipex,jpsx:jpex) = clat_glob(ipsx:ipex,jpsx:jpex)
+
+     DEALLOCATE( clat_glob )
+#endif
+   ENDIF
+
+! 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
+
+! 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.
+
+   CALL lbc_fcx_gcx ( grid%fcx , grid%gcx , grid%spec_bdy_width , &
+                      grid%spec_zone , grid%relax_zone , grid%dt , config_flags%spec_exp , &
+                      config_flags%specified , config_flags%nested )
+
+   IF ( config_flags%nested ) THEN
+     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
+
+      IF ( config_flags%use_baseparam_fr_nml ) then
+      CALL nl_get_base_pres  ( 1 , p00 )
+      CALL nl_get_base_temp  ( 1 , t00 )
+      CALL nl_get_base_lapse ( 1 , a   )
+      CALL nl_get_iso_temp   ( 1 , tiso )
+
+      ELSE
+      ! get these constants from model data
+
+      t00  = grid%t00
+      p00  = grid%p00
+      a    = grid%tlp
+      tiso = grid%tiso
+
+      IF (t00 .LT. 100. .or. p00 .LT. 10000.) THEN
+      WRITE(wrf_err_message,*)&
+      'start_em: did not find base state parameters in wrfinput. Add use_baseparam_fr_nml = .t. in &dynamics and rerun'
+      CALL wrf_error_fatal(TRIM(wrf_err_message))
+      ENDIF
+
+      ENDIF
+
+      !  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%pb(i,k,j) = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+               temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) )
+               grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0
+!              grid%t_init(i,k,j) = (t00 + A*LOG(grid%pb(i,k,j)/p00))*(p00/grid%pb(i,k,j))**(r_d/cp) - t0
+               grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm
+            END DO
+
+            !  Base state mu is defined as base state surface pressure minus grid%p_top
+
+            grid%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%phb(i,1,j) = grid%ht(i,j) * g
+            DO k  = 2,kte
+               grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%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%t_1(i,k,j)=grid%t_2(i,k,j)
+           ENDIF
+       ENDDO
+       ENDDO
+       ENDDO
+
+       DO j = jts,min(jte,jde-1)
+       DO k = kts,kte
+       DO i = its, min(ite,ide-1)
+          grid%ph_1(i,k,j)=grid%ph_2(i,k,j)
+       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%mu_1(i,j)=grid%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%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%pb(i,k,j) = grid%znu(k)*grid%mub(i,j)+grid%p_top
+         grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm
+       ENDIF
+     ENDDO
+     ENDDO
+     ENDDO
+    ELSE
+! with nests, grid%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%pb(i,k,j) = grid%znu(k)*grid%mub(i,j)+grid%p_top
+         grid%alb(i,k,j) = -grid%rdnw(k)*(grid%phb(i,k+1,j)-grid%phb(i,k,j))/grid%mub(i,j)
+         grid%t_init(i,k,j) = grid%alb(i,k,j)*(p1000mb/r_d)/((grid%pb(i,k,j)/p1000mb)**cvpm) - t0
+       ENDIF
+     ENDDO
+     ENDDO
+     ENDDO
+    ENDIF
+
+! Use equations from calc_p_rho_phi to derive p and al from ph
+
+    DO j=jts,min(jte,jde-1)
+    DO k=kts,kte-1
+    DO i=its,min(ite,ide-1)
+       qvf = 1.+rvovrd*moist(i,k,j,P_QV)
+       grid%al(i,k,j)=-1./(grid%mub(i,j)+grid%mu_1(i,j))*(grid%alb(i,k,j)*grid%mu_1(i,j)  &
+                  +grid%rdnw(k)*(grid%ph_1(i,k+1,j)-grid%ph_1(i,k,j)))
+       grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_1(i,k,j))*qvf)/                     &
+                  (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv  &
+                  -grid%pb(i,k,j)
+       grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
+       grid%alt(i,k,j) = grid%al(i,k,j) + grid%alb(i,k,j)
+    ENDDO
+    ENDDO
+    ENDDO
+
+#if 0
+     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%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
+           grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
+           qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+           grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf*(((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+           grid%al(i,k,j) = grid%alt(i,k,j) - grid%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%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
+           grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
+           qvf = 1. + rvovrd*moist(i,k,j,P_QV)
+           grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* &
+                        (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
+           grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
+         ENDIF
+       ENDDO
+       ENDDO
+
+     ENDDO
+#endif
+
+   ENDIF
+
+   IF ( grid%press_adj .and. ( 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%mu_2(i,j) = grid%mu_2(i,j) + grid%al(i,1,j) / ( grid%alt(i,1,j) * grid%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%mu_1(i,j)=grid%mu_2(i,j)
+       ENDDO
+       ENDDO
+
+   END IF
+
+   IF ( first_trip_for_this_domain ) THEN
+
+   CALL wrf_debug ( 100 , 'start_domain_em: 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 )
+
+!-----------------------------------------------------------------------------
+! Adaptive time step: Added by T. Hutchinson, WSI  11/6/07
+!
+!
+
+   IF ( ( grid%use_adaptive_time_step ) .AND. &
+        ( ( grid%dfi_opt .EQ. DFI_NODFI ) .OR. ( grid%dfi_stage .EQ. DFI_FST ) ) ) THEN
+
+!  Calculate any variables that were not set
+
+      if (grid%starting_time_step == -1) then
+         grid%starting_time_step = NINT(6 * MIN(grid%dx,grid%dy) / 1000)
+      endif
+
+      if (grid%max_time_step == -1) then
+         grid%max_time_step = 3*grid%starting_time_step
+      endif
+
+      if (grid%min_time_step == -1) then
+         grid%min_time_step = 0.5*grid%starting_time_step
+      endif
+
+!     Set a starting timestep.
+
+      grid%dt = grid%starting_time_step
+
+!     Initialize max cfl values
+      
+      grid%last_max_vert_cfl = 0
+      grid%last_max_horiz_cfl = 0
+
+!     Check to assure that time_step_sound is to be dynamically set.
+
+      CALL nl_set_time_step_sound ( 1 , 0 )
+      grid%time_step_sound = 0
+
+      grid%max_msftx=MAXVAL(grid%msftx)
+      grid%max_msfty=MAXVAL(grid%msfty)
+#ifdef DM_PARALLEL
+      CALL wrf_dm_maxval(grid%max_msftx, idex, jdex)
+      CALL wrf_dm_maxval(grid%max_msfty, idex, jdex)
+#endif
+
+!     This first call just initializes variables.
+!     If a restart, get initialized variables from restart file
+
+      IF ( .NOT. ( config_flags%restart ) ) then
+         CALL adapt_timestep(grid, config_flags)
+      END IF
+
+
+   END IF
+
+! End of adaptive time step modifications
+!-----------------------------------------------------------------------------
+
+
+   CALL set_tiles ( grid , grid%imask_nostag, ims, ime, jms, jme, ips, ipe, jps, jpe )
+!
+! Phy init can do reads and broadcasts when initializing physics -- landuse for example. However, if
+! we're running on a reduced mesh (that is, some tasks don't have any work) we have to at least let them
+! pass through this code so the broadcasts don't hang on the other, active tasks.  Set the number of
+! tiles to a minimum of 1 and assume that the backwards patch ranges (ips=0, ipe=-1) will prevent
+! anything else from happening on the blank tasks.  JM 20080605
+!
+   if ( allowed_to_read ) grid%num_tiles = max(1,grid%num_tiles)
+!
+! 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
+
+!tgs do not need physics initialization for backward DFI integration
+     IF ( grid%dfi_opt .NE. DFI_NODFI .and. grid%dfi_stage .EQ. DFI_FST) THEN     !tgs
+        grid%stepra=nint(grid%RADT*60./grid%DT)
+        grid%stepra=max(grid%stepra,1)
+        grid%stepbl=nint(grid%BLDT*60./grid%DT)
+        grid%stepbl=max(grid%stepbl,1)
+        grid%stepcu=nint(grid%CUDT*60./grid%DT)
+        grid%stepcu=max(grid%stepcu,1)
+        grid%stepfg=nint(grid%FGDT*60./grid%DT)
+        grid%stepfg=max(grid%stepfg,1)
+     ENDIF
+     
+    IF ( ( grid%dfi_opt .EQ. DFI_NODFI ) .or. &
+          ( ( grid%dfi_stage .NE. DFI_BCK ) .and. &
+          ( grid%dfi_stage .NE. DFI_STARTBCK ) ) ) THEN    !tgs, mods by tah
+
+     CALL phy_init (  grid%id , config_flags, grid%DT, grid%RESTART, grid%znw, grid%znu,   &
+                      grid%p_top, grid%tsk, grid%RADT,grid%BLDT,grid%CUDT, MPDT, &
+                      grid%rucuten, grid%rvcuten, grid%rthcuten,             &
+                      grid%rqvcuten, grid%rqrcuten, grid%rqccuten,           &
+                      grid%rqscuten, grid%rqicuten,                          &
+                      grid%rushten, grid%rvshten, grid%rthshten,             &
+                      grid%rqvshten, grid%rqrshten, grid%rqcshten,           &
+                      grid%rqsshten, grid%rqishten, grid%rqgshten,           &
+                      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%snownc, grid%snowncv, grid%graupelnc, grid%graupelncv,  &
+                      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%embck,            &
+                      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_pbl,    &
+                      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%xicem,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%snoalb,                 &
+                      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,               &
+                      grid%LAGDAY, &
+                      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, &
+                      config_flags%num_urban_layers,                        & !multi-layer urban
+                      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%rphndgdten,grid%rqvndgdten,grid%rmundgdten,       &     ! Optional
+                      grid%FGDT,grid%stepfg,                        &     ! Optional
+                      grid%cugd_tten,grid%cugd_ttens,grid%cugd_qvten,        &   ! Optional
+                      grid%cugd_qvtens,grid%cugd_qcten,                 &   ! 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
+                      grid%TRB_URB4D,grid%TW1_URB4D,grid%TW2_URB4D,grid%TGB_URB4D,grid%TLEV_URB3D,  & !multi-layer urban
+                      grid%QLEV_URB3D,grid%TW1LEV_URB3D,grid%TW2LEV_URB3D,        & !multi-layer urban
+                      grid%TGLEV_URB3D,grid%TFLEV_URB3D,grid%SF_AC_URB3D,         & !multi-layer urban 
+                      grid%LF_AC_URB3D,grid%CM_AC_URB3D,grid%SFVENT_URB3D,grid%LFVENT_URB3D,   & !multi-layer urban
+                      grid%SFWIN1_URB3D,grid%SFWIN2_URB3D, & !multi-layer urban
+                      grid%SFW1_URB3D,grid%SFW2_URB3D,grid%SFR_URB3D,grid%SFG_URB3D,     & !multi-layer urban
+                      grid%A_U_BEP,grid%A_V_BEP,grid%A_T_BEP,grid%A_Q_BEP,             & !multi-layer urban
+                      grid%A_E_BEP,grid%B_U_BEP,grid%B_V_BEP,grid%B_T_BEP,             & !multi-layer urban
+                      grid%B_Q_BEP,grid%B_E_BEP,grid%DLG_BEP,                          & !multi-layer urban
+                      grid%DL_U_BEP,grid%SF_BEP,grid%VL_BEP,                           & !multi-layer urban
+                      grid%TML,grid%T0ML,grid%HML,grid%H0ML,grid%HUML,grid%HVML,grid%TMOML,     & !Optional oml
+                      grid%itimestep, grid%fdob,            &
+                      t00, p00, a,                      & ! for obs_nudge base state
+                      grid%TYR, grid%TYRA, grid%TDLY, grid%TLAG, grid%NYEAR, grid%NDAY,grid%tmn_update, &
+                      grid%achfx, grid%aclhf, grid%acgrdflx                 &
+                      ,grid%te_temf,grid%cf3d_temf,grid%wm_temf        & ! WA
+                      )
+       ENDIF   !tgs
+
+   ENDDO
+
+   CALL wrf_debug ( 100 , 'start_domain_em: After call to phy_init' )
+
+   IF (config_flags%do_avgflx_em .EQ. 1) THEN
+      WRITE ( message , FMT = '("start_em: initializing avgflx on domain ",I3)' ) &
+           & grid%id
+      CALL wrf_message(trim(message)) 
+      grid%avgflx_count = 0
+      f_flux = config_flags%do_avgflx_cugd .EQ. 1  ! WA 9/24/10
+      DO ij = 1, grid%num_tiles
+         call wrf_debug(200,'In start_em, before zero_avgflx call')
+         if (.not. grid%restart) call zero_avgflx(grid%avgflx_rum,grid%avgflx_rvm,grid%avgflx_wwm, &
+              &   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, f_flux, &
+              &   grid%avgflx_cfu1,grid%avgflx_cfd1,grid%avgflx_dfu1, &
+              &   grid%avgflx_efu1,grid%avgflx_dfd1,grid%avgflx_efd1 )
+         call wrf_debug(200,'In start_em, after zero_avgflx call')
+      ENDDO
+   ENDIF
+
+#ifdef MCELIO
+   grid%LU_MASK = 0.
+   WHERE ( grid%lu_index .EQ. 16 ) grid%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%u_1                          x
+!j  grid%u_2                          x
+!j  grid%v_1                          x
+!j  grid%v_2                          x
+!j  grid%w_1                          x
+!j  grid%w_2                          x
+!j  grid%t_1                          x
+!j  grid%t_2                          x
+!j grid%ph_1                          x
+!j grid%ph_2                          x
+!
+!j  grid%t_init                       x
+!
+!j  grid%phb   x
+!j  grid%ph0   x
+!j  grid%php   x
+!j   grid%pb   x
+!j   grid%al   x
+!j  grid%alt   x
+!j  grid%alb   x
+!
+!  the following are 2D (xy) variables
+!
+!j grid%mu_1                          x
+!j grid%mu_2                          x
+!j grid%mub   x
+!j grid%mu0   x
+!j grid%ht    x
+!j grid%msftx x
+!j grid%msfty x
+!j grid%msfux x
+!j grid%msfuy x
+!j grid%msfvx x
+!j grid%msfvy 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_TKE.inc"
+#  include "PERIOD_BDY_EM_SCALAR.inc"
+#  include "PERIOD_BDY_EM_CHEM.inc"
+#endif
+
+
+   CALL set_physical_bc3d( grid%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%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%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%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   )
+
+! Set the w at the surface.  If this is the start of a forecast, or if this is a cycled run
+! and the start of that forecast, we define the w field.  However, if this a restart, then 
+! we leave w alone.  Initial value is V dot grad(topo) at surface, then smoothly decaying
+! above that.
+
+   IF ( ( start_of_simulation .OR. config_flags%cycling ) .AND. ( .NOT. config_flags%restart ) ) THEN
+   fill_w_flag = .true.
+   CALL set_w_surface(  config_flags, grid%znw, fill_w_flag,             &
+                        grid%w_1, grid%ht, grid%u_1, grid%v_1, grid%cf1, &
+                        grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msftx, grid%msfty, &
+                        ids, ide, jds, jde, kds, kde,                    &
+                        ims, ime, jms, jme, kms, kme,                    &
+                        its, ite, jts, jte, kts, kte                     )
+   CALL set_w_surface(  config_flags, grid%znw, fill_w_flag,             &
+                        grid%w_2, grid%ht, grid%u_2, grid%v_2, grid%cf1, &
+                        grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msftx, grid%msfty, &
+                        ids, ide, jds, jde, kds, kde,                    &
+                        ims, ime, jms, jme, kms, kme,                    &
+                        its, ite, jts, jte, kts, kte                     ) 
+
+! finished setting kinematic condition for w at the surface
+
+! set up slope-radiation constant arrays based on topography
+       DO j = jts,min(jte,jde-1)
+       DO i = its, min(ite,ide-1)
+          im1 = max(i-1,ids)
+          ip1 = min(i+1,ide-1)
+          jm1 = max(j-1,jds)
+          jp1 = min(j+1,jde-1)
+          grid%toposlpx(i,j)=(grid%ht(ip1,j)-grid%ht(im1,j))*grid%msftx(i,j)*grid%rdx/(ip1-im1)
+          grid%toposlpy(i,j)=(grid%ht(i,jp1)-grid%ht(i,jm1))*grid%msfty(i,j)*grid%rdy/(jp1-jm1)
+             hx = grid%toposlpx(i,j)
+             hy = grid%toposlpy(i,j)
+             pi = 4.*atan(1.)
+             grid%slope(i,j) = atan((hx**2+hy**2)**.5)
+             if (grid%slope(i,j).lt.1.e-4) then
+               grid%slope(i,j) = 0.
+               grid%slp_azi(i,j) = 0.
+             else
+               grid%slp_azi(i,j) = atan2(hx,hy)+pi
+
+! Rotate slope azimuth to lat-lon grid
+               if (grid%cosa(i,j).ge.0) then
+                 grid%slp_azi(i,j) = grid%slp_azi(i,j) - asin(grid%sina(i,j))
+               else
+                 grid%slp_azi(i,j) = grid%slp_azi(i,j) - (pi - asin(grid%sina(i,j)))
+               endif
+             endif
+       ENDDO
+       ENDDO
+   END IF
+
+   CALL set_physical_bc3d( grid%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%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%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%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%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%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%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%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%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%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%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%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%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%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%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%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%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%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 )
+   CALL set_physical_bc3d(grid%tke_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 )
+
+   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
+
+   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
+
+
+#ifdef WRF_CHEM
+        if(config_flags%tracer_opt > 0 )then
+           call initialize_tracer (tracer,config_flags%chem_in_opt, &
+                               config_flags%tracer_opt,num_tracer,  &
+                               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 )
+
+        endif
+!
+!   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%ph_2(i,k,j)+grid%phb(i,k,j))/g
+               enddo
+               do k=kts,min(kte,kde-1)
+                 tempfac=(grid%t_1(i,k,j) + t0)*((grid%p(i,k,j) + grid%pb(i,k,j))/p1000mb)**rcp
+                 convfac(i,k,j) = (grid%p(i,k,j)+grid%pb(i,k,j))/rgasuniv/tempfac
+               enddo
+            enddo
+         enddo
+
+         CALL chem_init (grid%id,chem,emis_ant,scalar,grid%dt,grid%bioemdt,grid%photdt,     &
+                         grid%chemdt,                                       &
+                         grid%stepbioe,grid%stepphot,grid%stepchem,grid%stepfirepl,      &
+                         grid%plumerisefire_frq,z_at_w,grid%xlat,grid%xlong,g,           &
+                         grid%aerwrf,config_flags,grid,            &
+                         grid%alt,grid%t_1,grid%p,convfac,grid%ttday,grid%tcosz,         &
+                         grid%julday,grid%gmt,&
+                         grid%gd_cloud, grid%gd_cloud2,grid%raincv_a,grid%raincv_b,     &
+                         grid%gd_cloud_a, grid%gd_cloud2_a,                              &
+                         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%l2aer,grid%l3aer,grid%l4aer,grid%l5aer,grid%l6aer,grid%l7aer,     &
+                         grid%extaerlw1,grid%extaerlw2,grid%extaerlw3,grid%extaerlw4,           &
+                         grid%extaerlw5,grid%extaerlw6,grid%extaerlw7,grid%extaerlw8,           &
+                         grid%extaerlw9,grid%extaerlw10,grid%extaerlw11,grid%extaerlw12,        &
+                         grid%extaerlw13,grid%extaerlw14,grid%extaerlw15,grid%extaerlw16,       &
+                         grid%tauaerlw1,grid%tauaerlw2,grid%tauaerlw3,grid%tauaerlw4,           &
+                         grid%tauaerlw5,grid%tauaerlw6,grid%tauaerlw7,grid%tauaerlw8,           &
+                         grid%tauaerlw9,grid%tauaerlw10,grid%tauaerlw11,grid%tauaerlw12,        &
+                         grid%tauaerlw13,grid%tauaerlw14,grid%tauaerlw15,grid%tauaerlw16,       &
+                         grid%pm2_5_dry,grid%pm2_5_water,grid%pm2_5_dry_ec,                &
+                         grid%last_chem_time_year,grid%last_chem_time_month,               &
+                         grid%last_chem_time_day,grid%last_chem_time_hour,                 &
+                         grid%last_chem_time_minute,grid%last_chem_time_second,            &
+                         grid%chem_in_opt,grid%kemit,                       &
+                         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 (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2,GOCARTRADM2_KPP)
+           call sum_pm_gocart (                                             &
+                grid%alt, chem, grid%pm2_5_dry, 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-1                                 )
+        case (RADM2SORG,RADM2SORG_AQ,RADM2SORG_KPP,RACMSORG_AQ,RACMSORG_KPP)
+           call sum_pm_sorgam (                                             &
+                grid%alt, chem, grid%h2oaj, grid%h2oai,                                    &
+                grid%pm2_5_dry, grid%pm2_5_water, grid%pm2_5_dry_ec, grid%pm10,                 &
+                grid%dust_opt,ids,ide, jds,jde, kds,kde,                    &
+                ims,ime, jms,jme, kms,kme,                                  &
+                its,ite, jts,jte, kts,kte-1                                 )
+
+        case (CBMZ_MOSAIC_4BIN,CBMZ_MOSAIC_8BIN,CBMZ_MOSAIC_4BIN_AQ,CBMZ_MOSAIC_8BIN_AQ, &
+              CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ,       &
+              CBMZ_MOSAIC_DMS_8BIN_AQ)
+           call sum_pm_mosaic (                                             &
+                grid%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-1                                 )
+
+        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
+        
+        ! initialize advective tendency diagnostics for chem
+        if ( grid%itimestep .eq. 0 .and. config_flags%chemdiag .eq. USECHEMDIAG ) then
+          grid%advh_ct(:,:,:,:) = 0.
+          grid%advz_ct(:,:,:,:) = 0.
+        endif
+#endif
+
+        ! initialize advective tendency diagnostics for non-chem
+        if ( grid%itimestep .eq. 0 .and. config_flags%tenddiag .eq. USETENDDIAG ) then
+          grid%advh_t(:,:,:,:) = 0.
+          grid%advz_t(:,:,:,:) = 0.
+        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%msftx , 'r' , config_flags ,              &
+                         ids , ide , jds , jde , &
+                         ims , ime , jms , jme , &
+                         its , ite , jts , jte , &
+                         its , ite , jts , jte   )
+   CALL set_physical_bc2d( grid%msfty , 'r' , config_flags ,              &
+                         ids , ide , jds , jde , &
+                         ims , ime , jms , jme , &
+                         its , ite , jts , jte , &
+                         its , ite , jts , jte   )
+   CALL set_physical_bc2d( grid%msfux , 'x' , config_flags ,              &
+                         ids , ide , jds , jde , &
+                         ims , ime , jms , jme , &
+                         its , ite , jts , jte , &
+                         its , ite , jts , jte   )
+   CALL set_physical_bc2d( grid%msfuy , 'x' , config_flags ,              &
+                         ids , ide , jds , jde , &
+                         ims , ime , jms , jme , &
+                         its , ite , jts , jte , &
+                         its , ite , jts , jte   )
+   CALL set_physical_bc2d( grid%msfvx , 'y' , config_flags ,              &
+                         ids , ide , jds , jde , &
+                         ims , ime , jms , jme , &
+                         its , ite , jts , jte , &
+                         its , ite , jts , jte   )
+   CALL set_physical_bc2d( grid%msfvy , '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_TKE.inc"
+#  include "PERIOD_BDY_EM_SCALAR.inc"
+#  include "PERIOD_BDY_EM_CHEM.inc"
+#endif
+
+!  FIRE
+if(config_flags%ifire.eq.2)then
+
+   call sfire_driver_em_init ( grid , config_flags    &
+            ,ids,ide, kds,kde, jds,jde                &
+            ,ims,ime, kms,kme, jms,jme                &
+            ,ips,ipe, kps,kpe, jps,jpe ) 
+
+   CALL wrf_debug ( 100 , 'start_domain_em: After call to sfire_driver_em_init' )
+endif
+
+
+     CALL wrf_debug ( 100 , 'start_domain_em: Returning' )
+
+     RETURN
+
+   END SUBROUTINE start_domain_em
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_exp/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_exp/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_exp/Makefile	(revision 17)
@@ -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) $(ARFLAGS) ../main/$(LIBWRFLIB) $(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
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_exp/README
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_exp/README	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_exp/README	(revision 17)
@@ -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 <exp_actual_args.inc>
+!
+               )
+
+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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_exp/init_modules_exp.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_exp/init_modules_exp.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_exp/init_modules_exp.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_exp/module_exp.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_exp/module_exp.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_exp/module_exp.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_exp/module_initialize_exp.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_exp/module_initialize_exp.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_exp/module_initialize_exp.F	(revision 17)
@@ -0,0 +1,155 @@
+!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 <exp_dummy_args.inc>
+!
+)
+   IMPLICIT NONE
+
+   !  Input data.
+   TYPE (domain), POINTER :: grid
+
+# include <exp_dummy_decl.inc>
+
+   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 <exp_scalar_derefs.inc>
+
+   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 <exp_scalar_derefs.inc>
+
+   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 :: 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 set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+     CALL init_domain_exp( grid &
+!
+#include <actual_args.inc>
+!
+                        )
+
+   END SUBROUTINE init_domain
+
+   SUBROUTINE init_module_initialize
+   END SUBROUTINE init_module_initialize
+
+
+END MODULE module_initialize
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_exp/solve_exp.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_exp/solve_exp.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_exp/solve_exp.F	(revision 17)
@@ -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 <exp_dummy_decl.inc>
+
+   !  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 <exp_i1_decl.inc>
+
+#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 <exp_scalar_derefs.inc>
+#ifdef DM_PARALLEL
+#    define REGISTER_I1
+#      include <exp_data_calls.inc>
+#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 <exp_scalar_derefs.inc>
+
+   RETURN
+
+END SUBROUTINE solve_exp
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/BUCKETS.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/BUCKETS.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/BUCKETS.F	(revision 17)
@@ -0,0 +1,394 @@
+!-----------------------------------------------------------------------
+!
+!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,TSHLTR,PSHLTR,QSHLTR             &
+     &                  ,T02_MAX,T02_MIN,RH02_MAX,RH02_MIN              &
+     &                  ,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
+!      TSHLTR - SHELTER LEVEL (2m) POTENTIAL TEMPERATURE (K)
+!      PSHLTR - SHELTER LEVEL (2m) PRESSURE (Pa)
+!      QSHLTR - SHELTER LEVEL (2m) SPECIFIC HUMIDITY (kg/kg)
+!     T02_MAX - 2m HOURLY MAX TEMPERATURE (K)
+!     T02_MIN - 2m HOURLY MIN TEMPERATURE (K)
+!    RH02_MAX - 2m HOURLY MAX RELATIVE HUMIDITY (fraction)
+!    RH02_MIN - 2m HOURLY MIN RELATIVE HUMIDITY (fraction)
+!  
+!   OUTPUT ARGUMENT LIST:  THE ACCUMULATED QUANTITIES
+!     
+!   OUTPUT FILES:  NONE
+!     
+!   SUBPROGRAMS CALLED:  NONE
+!  
+!   UNIQUE: NONE
+!  
+!   LIBRARY: NONE
+!  
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM 
+!$$$  
+!-----------------------------------------------------------------------
+!
+      USE MODULE_MODEL_CONSTANTS,ONLY: CP,CPV,R_D,R_V,RCP
+      USE MODULE_MP_ETANEW,ONLY: C1XPVS,C1XPVS0,C2XPVS,C2XPVS0          &
+                                ,FPVS,FPVS0,NX,TBPVS,TBPVS0             &
+                                ,GPVS
+!
+!-----------------------------------------------------------------------
+!
+      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 
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: NCFRST,NCFRCV
+!
+      REAL,INTENT(IN) :: TSPH,TSTART
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: PSHLTR,QSHLTR,TSHLTR
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: T
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: TLMAX,TLMIN
+!
+      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      &
+     &                                              ,RH02_MAX,RH02_MIN  &
+     &                                              ,SFCLHX,SFCSHX      &
+     &                                              ,SFCUVX,SNOPCX      &
+     &                                              ,SSROFF,SUBSHX      &
+     &                                              ,T02_MAX,T02_MIN
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(OUT) :: TCUCN      &
+     &                                                      ,TRAIN
+!
+      LOGICAL,INTENT(IN) :: RESTART
+!
+!-----------------------------------------------------------------------
+!***  LOCAL VARIABLES 
+!-----------------------------------------------------------------------
+!
+      INTEGER :: I,J,K,NTSD_BUCKET,NTSPH
+      LOGICAL ::  FIRST_PASS=.TRUE.
+      LOGICAL ::  WRF_DM_ON_MONITOR
+      EXTERNAL WRF_DM_ON_MONITOR
+!
+      REAL :: CAPPA_MOIST,RH02,SAT_VAPOR_PRESS,VAPOR_PRESS
+      REAL,SAVE :: CP_FACTOR,EPSILON,ONE_MINUS_EPSILON,R_FACTOR
+      REAL,SAVE :: P00_INV=1.E-5
+!
+      REAL,DIMENSION(ITS:ITE,JTS:JTE) :: T02
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!***  COMPUTE AND SAVE THE FACTORS IN R AND CP TO ACCOUNT FOR
+!***  WATER VAPOR IN THE AIR.
+!*** 
+!***  RECALL: R  = Rd * (1. + Q * (1./EPSILON - 1.))
+!***          CP = CPd * (1. + Q * (CPv/CPd - 1.))
+!
+      IF(FIRST_PASS)THEN
+        FIRST_PASS=.FALSE.
+!
+        EPSILON=R_D/R_V
+        ONE_MINUS_EPSILON=1.-EPSILON
+        R_FACTOR=1./EPSILON-1.
+        CP_FACTOR=CPV/CP-1.
+! Make sure saturation vapor pressure lookup table is initialized
+        CALL GPVS 
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!
+      NTSD_BUCKET=NTSD
+!
+!-----------------------------------------------------------------------
+!***  TOTAL AND CONVECTIVE PRECIPITATION ARRAYS.
+!***  TOTAL SNOW AND SNOW MELT ARRAYS.
+!***  STORM SURFACE AND BASE GROUND RUN OFF ARRAYS.
+!***  EVAPORATION ARRAYS.
+!-----------------------------------------------------------------------
+!
+!     IF(MOD(NTSD,NPREC)<NPHS)THEN
+      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,NSRFC)<NPHS)THEN
+      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,NRDSW)<NPHS)THEN
+      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,NRDLW)<NPHS)THEN
+      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,NCLOD)<NPHS)THEN
+      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,NHEAT)<NPHS)THEN
+      IF(MOD(NTSD_BUCKET,NHEAT)==0)THEN
+        AVCNVC=0.
+        AVRAIN=0.
+!
+        DO K=KTS,KTE
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          TRAIN(I,J,K)=0.
+          TCUCN(I,J,K)=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.
+          T02_MAX(I,J)=-999.
+          T02_MIN(I,J)=999.
+        ENDDO
+        ENDDO
+!
+        IF ( WRF_DM_ON_MONITOR() ) THEN
+        CALL WRF_MESSAGE('RESET MAX/MIN TEMPERATURES')
+        ENDIF
+      ENDIF
+!
+      DO J=JTS,JTE
+      DO I=ITS,ITE
+        TLMAX(I,J)=MAX(TLMAX(I,J),T(I,J,1))         !<--- Hourly max lowest layer T
+        TLMIN(I,J)=MIN(TLMIN(I,J),T(I,J,1))         !<--- Hourly min lowest layer T
+!
+        CAPPA_MOIST=RCP*(1.+QSHLTR(I,J)*R_FACTOR)/(1.+QSHLTR(I,J)*CP_FACTOR)
+        T02(I,J)=TSHLTR(I,J)*(P00_INV*PSHLTR(I,J))**CAPPA_MOIST
+!
+        IF(NTSD>0)THEN
+          T02_MAX(I,J)=MAX(T02_MAX(I,J),T02(I,J))     !<--- Hourly max shelter T
+          T02_MIN(I,J)=MIN(T02_MIN(I,J),T02(I,J))     !<--- Hourly min shelter T
+        ENDIF
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  MAX/MIN RELATIVE HUMIDITY
+!-----------------------------------------------------------------------
+!
+      IF(MOD(NTSD_BUCKET,NTSPH)==0.OR.NTSD==1)THEN
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          RH02_MAX(I,J)=-999.
+          RH02_MIN(I,J)=999.
+        ENDDO
+        ENDDO
+!
+        IF ( WRF_DM_ON_MONITOR() ) THEN
+          CALL WRF_MESSAGE('RESET MAX/MIN RH')
+        ENDIF
+      ENDIF
+!
+      IF(NTSD>0)THEN
+!
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          VAPOR_PRESS=PSHLTR(I,J)*QSHLTR(I,J)/                          &
+                     (EPSILON+QSHLTR(I,J)*ONE_MINUS_EPSILON)
+!
+!         IF(T02(I,J)>273.15)THEN
+            SAT_VAPOR_PRESS=1.E3*FPVS0(T02(I,J))
+!         ELSE
+!           SAT_VAPOR_PRESS=1.E3*FPVS(T02(I,J))
+!         ENDIF
+!
+          RH02=MIN(VAPOR_PRESS/SAT_VAPOR_PRESS,0.99)
+!
+          RH02_MAX(I,J)=MAX(RH02_MAX(I,J),RH02)     !<--- Hourly max shelter RH
+          RH02_MIN(I,J)=MIN(RH02_MIN(I,J),RH02)     !<--- Hourly min shelter RH
+        ENDDO
+        ENDDO
+!
+      ELSE                         !<-- If timestep is 0, simply set max/min to zero.
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          RH02_MAX(I,J)=0.
+          RH02_MIN(I,J)=0.
+        ENDDO
+        ENDDO
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE BUCKETS
+!
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/CLTEND.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/CLTEND.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/CLTEND.F	(revision 17)
@@ -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,JMS:JME,KMS:KME),INTENT(INOUT) :: T       &
+                                                              ,T_ADJ   &
+                                                              ,T_OLD
+!
+!***  LOCAL VARIABLES 
+!
+      INTEGER :: I,J,K
+!
+      REAL :: DELTPH
+!
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+!
+      IF(ICLTEND<0)THEN
+        DO K=KTS,KTE
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          T_OLD(I,J,K)=T(I,J,K)
+        ENDDO
+        ENDDO
+        ENDDO
+      ELSEIF(ICLTEND==0)THEN
+        DO K=KTS,KTE
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          T_ADJ(I,J,K)=T(I,J,K)-T_OLD(I,J,K)
+          T(I,J,K)=T_OLD(I,J,K)
+        ENDDO
+        ENDDO
+        ENDDO
+      ELSE
+        DELTPH=1./REAL(NPHS)
+        DO K=KTS,KTE
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          T(I,J,K)=T(I,J,K)+DELTPH*T_ADJ(I,J,K)
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDIF
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE CLTEND
+!
+!----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/DSTRB.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/DSTRB.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/DSTRB.F	(revision 17)
@@ -0,0 +1,188 @@
+!-----------------------------------------------------------------------
+      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
+!-----------------------------------------------------------------------
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      INCLUDE "mpif.h"
+#endif
+!-----------------------------------------------------------------------
+!***
+!***  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,JDS:JDE,LGS:LGE),INTENT(IN) :: ARRAYG
+      REAL,DIMENSION(IMS:IME,JMS:JME,LLS:LLE),INTENT(OUT) :: ARRAYL
+!-----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      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
+#else
+      INTEGER :: I,L,J
+#endif
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+!
+!***  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 L=LLS,LLE
+      DO J=JMS,JME
+      DO I=IMS,IME
+        ARRAYL(I,J,L)=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,J,L1)=ARRAYG(I,J,LGS)
+          ENDDO
+          ENDDO
+!
+        ELSE
+!
+          DO L=LGS,LGE
+            DO J=JTS,JTE
+            DO I=ITS,ITE
+              ARRAYL(I,J,L)=ARRAYG(I,J,L)
+            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 L=LGS,LGE
+            DO J=JSTART,JEND
+            DO I=ISTART,IEND
+              KNT=KNT+1
+              ARRAYX(KNT)=ARRAYG(I,J,L)
+            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,J,L1)=ARRAYX(KNT)
+          ENDDO
+          ENDDO
+        ELSE
+          DO L=LGS,LGE
+            DO J=JTS,JTE
+            DO I=ITS,ITE
+              KNT=KNT+1
+              ARRAYL(I,J,L)=ARRAYX(KNT)
+            ENDDO
+            ENDDO
+          ENDDO
+        ENDIF
+!
+        DEALLOCATE(ARRAYX)
+!
+!-----------------------------------------------------------------------
+!
+      ENDIF tasks
+!
+!-----------------------------------------------------------------------
+      CALL MPI_BARRIER(MPI_COMM_COMP,IRTN)
+!-----------------------------------------------------------------------
+!
+!
+!***  INITIALIZE THE OUTPUT ARRAY
+!
+      ARRAYL=0.0
+
+      DO L=LGS,LGE
+      DO J=JDS,JDE
+      DO I=IDS,IDE
+        ARRAYL(I,J,L)=ARRAYG(I,J,L)
+      ENDDO
+      ENDDO
+      ENDDO
+
+#endif
+      END SUBROUTINE DSTRB
+!
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/Makefile	(revision 17)
@@ -0,0 +1,94 @@
+#
+
+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_GWD.o                    \
+        module_MPPINIT.o        	\
+        module_TIMERS.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    = 		          	\
+	init_modules_nmm.o  		\
+	start_domain_nmm.o  		\
+	shift_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) $(ARFLAGS) ../main/$(LIBWRFLIB) $(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_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  \
+                ./module_GWD.o  \
+		../phys/module_cu_bmj.o  \
+		../phys/module_cumulus_driver.o  \
+		../phys/module_mp_etanew.o  \
+		../phys/module_microphysics_driver.o
+
+module_GWD.o: ../frame/module_dm.o
+
+module_initialize_real.o: ../share/module_model_constants.o
+
+# DO NOT DELETE
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/NMM_NEST_UTILS1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/NMM_NEST_UTILS1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/NMM_NEST_UTILS1.F	(revision 17)
@@ -0,0 +1,4000 @@
+#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
+ CHARACTER(LEN=255)                 :: message
+
+!----------------------------------------------------------------------------
+!  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%ed32,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%ed32,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
+    JDS = parent%sd32
+    JDE = parent%ed32
+    KDS = parent%sd33
+    KDE = parent%ed33
+
+    IMS = parent%sm31
+    IME = parent%em31
+    JMS = parent%sm32
+    JME = parent%em32
+    KMS = parent%sm33
+    KME = parent%em33
+
+    ITS = parent%sp31
+    ITE = parent%ep31
+    JTS = parent%sp32
+    JTE = parent%ep32
+    KTS = parent%sp33
+    KTE = 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(message,*)" - i_parent_start = ",nest%i_parent_start
+    CALL wrf_message(trim(message))
+    write(message,*)" - j_parent_start = ",nest%j_parent_start
+    CALL wrf_message(trim(message))
+    write(message,*)" - parent%wbd0    = ",parent%wbd0
+    CALL wrf_message(trim(message))
+    write(message,*)" - parent%sbd0    = ",parent%sbd0
+    CALL wrf_message(trim(message))
+    write(message,*)" - nest%wbd0      = ",nest%wbd0
+    CALL wrf_message(trim(message))
+    write(message,*)" - nest%sbd0      = ",nest%sbd0
+    CALL wrf_message(trim(message))
+    write(message,*)" - nest%dx        = ",nest%dx
+    CALL wrf_message(trim(message))
+    write(message,*)" - nest%dy        = ",nest%dy
+    CALL wrf_message(trim(message))
+!
+    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(message,*)" - nest%cen_lat   = ",nest%cen_lat
+    CALL wrf_message(trim(message))
+    write(message,*)" - nest%cen_lon   = ",nest%cen_lon
+    CALL wrf_message(trim(message))
+
+
+!   soil configuration
+
+#ifdef HWRF
+!zhang 
+    if ( .not.nest%analysis ) then
+#endif
+    nest%sldpth  = parent%sldpth
+    nest%dzsoil  = parent%dzsoil
+    nest%rtdpth  = parent%rtdpth
+#ifdef HWRF 
+    endif
+#endif
+
+!   numerical set up
+
+    nest%deta        = parent%deta
+    nest%aeta        = parent%aeta
+    nest%etax        = parent%etax
+    nest%dfl         = parent%dfl
+    nest%deta1       = parent%deta1
+    nest%aeta1       = parent%aeta1
+    nest%eta1        = parent%eta1
+    nest%deta2       = parent%deta2
+    nest%aeta2       = parent%aeta2
+    nest%eta2        = parent%eta2
+    nest%pdtop       = parent%pdtop
+    nest%pt          = parent%pt
+    nest%dfrlg       = parent%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%dlmd   = nest%dx
+    nest%dphd   = nest%dy
+    nest%dy_nmm = erad*(nest%dphd*dtr)
+    nest%cpgfv  = -nest%dt/(48.*nest%dy_nmm)
+    nest%en     = nest%dt/( 4.*nest%dy_nmm)*dtad
+    nest%ent    = nest%dt/(16.*nest%dy_nmm)*dtad
+    nest%f4d    = -.5*nest%dt*dtad
+    nest%f4q    = -nest%dt*dtad
+    nest%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 )
+#ifdef HWRF
+! bao : to make the restart output identical at the restart initial time for stand_lon
+   CALL nl_get_stand_lon (parent%id, parent%stand_lon )
+#endif
+   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
+!bao
+   nest%stand_lon=parent%stand_lon
+!bao
+   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)
+!bao
+   CALL nl_set_stand_lon(nest%id, nest%stand_lon)
+!bao
+   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
+    JDS = parent%sd32
+    JDE = parent%ed32
+    KDS = parent%sd33
+    KDE = parent%ed33
+
+    IMS = parent%sm31
+    IME = parent%em31
+    JMS = parent%sm32
+    JME = parent%em32
+    KMS = parent%sm33
+    KME = parent%em33
+
+    ITS  = parent%sp31
+    ITE  = parent%ep31
+    JTS  = parent%sp32
+    JTE  = parent%ep32
+    KTS  = parent%sp33
+    KTE  = 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%HLAT,parent%HLON,parent%VLAT,parent%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
+    JDS = nest%sd32
+    JDE = nest%ed32
+    KDS = nest%sd33
+    KDE = nest%ed33
+
+    IMS = nest%sm31
+    IME = nest%em31
+    JMS = nest%sm32
+    JME = nest%em32
+    KMS = nest%sm33
+    KME = nest%em33
+
+    ITS  = nest%sp31
+    ITE  = nest%ep31
+    JTS  = nest%sp32
+    JTE  = nest%ep32
+    KTS  = nest%sp33
+    KTE  = 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%HLAT,nest%HLON,nest%VLAT,nest%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 
+
+#ifdef HWRFX
+    CALL G2T2H_new(    nest%IIH,nest%JJH,                            & ! output grid index in parent grid
+                       nest%HBWGT1,nest%HBWGT2,                      & ! output weights in terms of parent grid
+                       nest%HBWGT3,nest%HBWGT4,                      &
+                       nest%I_PARENT_START,nest%J_PARENT_START,      & ! nest start I, J in parent domain
+                       3,                              & ! Ratio of parent and child grid ( always = 3 for NMM)
+                       IDS,IDE,JDS,JDE,KDS,KDE,            & ! target (nest) dimensions
+                       IMS,IME,JMS,JME,KMS,KME,            &
+                       ITS,ITE,JTS,JTE,KTS,KTE      )
+#else
+    CALL G2T2H( nest%IIH,nest%JJH,                       & ! output grid index on nested grid
+                nest%HBWGT1,nest%HBWGT2,                 & ! output weights on the nested grid 
+                nest%HBWGT3,nest%HBWGT4,                 &
+                nest%HLAT,nest%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%ed32,                         & ! 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                          ) !
+#endif
+
+
+!   Determine the weights of nested grid v points nearest to V points of parent domain
+
+#ifdef HWRFX
+    CALL G2T2V_new(    nest%IIV,nest%JJV,                            & ! output grid index in parent grid
+                       nest%VBWGT1,nest%VBWGT2,                      & ! output weights in terms of parent grid
+                       nest%VBWGT3,nest%VBWGT4,                      &
+                       nest%I_PARENT_START,nest%J_PARENT_START,      & ! nest start I, J in parent domain
+                       3,                              & ! Ratio of parent and child grid ( always = 3 for NMM)
+                       IDS,IDE,JDS,JDE,KDS,KDE,            & ! target (nest) dimensions
+                       IMS,IME,JMS,JME,KMS,KME,            &
+                       ITS,ITE,JTS,JTE,KTS,KTE      )
+#else
+    CALL G2T2V( nest%IIV,nest%JJV,                       & ! output grid index on nested grid
+                nest%VBWGT1,nest%VBWGT2,                 & ! output weights on the nested grid
+                nest%VBWGT3,nest%VBWGT4,                 &
+                nest%VLAT,nest%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%ed32,                         & ! 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                          ) !
+#endif
+
+!*** CHECK WEIGHTS AT MASS AND VELOCITY POINTS
+
+     CALL WEIGTS_CHECK(nest%HBWGT1,nest%HBWGT2,          & ! output weights on the nested grid
+                       nest%HBWGT3,nest%HBWGT4,          &
+                       nest%VBWGT1,nest%VBWGT2,          & ! output weights on the nested grid
+                       nest%VBWGT3,nest%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%IIH,nest%JJH,nest%IIV,nest%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)
+
+                                                !    .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 
+      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
+      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
+      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
+         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
+         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
+        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
+        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
+        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
+        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
+        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
+        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(message,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)
+!      CALL wrf_message(trim(message))
+! 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
+      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
+
+      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
+       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
+         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
+         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
+        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
+        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
+        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
+        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
+        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
+        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)
+
+    ENDDO
+  ENDDO
+
+ RETURN
+ END SUBROUTINE G2T2V
+
+!-----------------------------------------------------------------------------  
+
+ SUBROUTINE G2T2H_new( IIH,JJH,                            & ! output grid index and weights 
+                       HBWGT1,HBWGT2,                      & ! output weights in terms of parent grid
+                       HBWGT3,HBWGT4,                      &
+                       I_PARENT_START,J_PARENT_START,      & ! nest start I and J in parent domain  
+                       RATIO,                              & ! Ratio of parent and child grid ( always = 3 for NMM)
+                       IDS,IDE,JDS,JDE,KDS,KDE,            & ! target (nest) dimensions
+                       IMS,IME,JMS,JME,KMS,KME,            &
+                       ITS,ITE,JTS,JTE,KTS,KTE      )
+!
+!*** XUEJIN ZHANG --- Initial version (09/08/2008)
+!*** XUEJIN ZHANG --- Modified for parallel purpose (09/10/2009)
+!*** XUEJIN ZHANG --- Modified for parallel purpose (09/29/2009)
+!Function: Bilnear interpolation weight and indexing for E-grid
+!
+ 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   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: JP
+
+
+!*** ARRANGEMENT OF 4 VERTEXES FROM PARENT DOMAIN
+!***
+!***                  4
+!***
+!***                  h
+!***             1         2
+!***
+!***
+!***                  3
+!
+!************************************************************* 
+!***  POINT (i,j) SPANS 9 NESTED POINTS 
+!***  A VERTEX IN THE NEST DOMAIN AND INDEXING FOR PARENT DOMAIN 
+!***
+!***
+!***                  H
+!***                
+!***               h     h
+!***              / \
+!***            h     h     h
+!***           / \   / \
+!***         H     h     h     H  
+!***          \   / \   /   
+!***            h     h     h
+!***             \   /
+!***               h     h
+!***      
+!***                  H
+!***                 
+!***
+!***
+!************************************************************* 
+!*** MOVING NEST ALWAYS STARTING FROM MASS GRID H
+!*** PLEASE REFER TO E-GRID ARRANGEMENT FIGURE FOR MASS POINTS
+
+
+ DO J=JTS,MIN(JTE,JDE-1)
+ DO I=ITS,MIN(ITE,IDE-1)
+    JP = MOD(J,RATIO*2)
+    SELECT CASE(JP)
+    CASE ( 1 )
+      CALL SUB1H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
+                I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                IMS,IME,JMS,JME,KMS,KME,                 &
+                ITS,ITE,JTS,JTE,KTS,KTE      )
+    CASE ( 2 )
+      CALL SUB2H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &    
+                I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                IMS,IME,JMS,JME,KMS,KME,                 &
+                ITS,ITE,JTS,JTE,KTS,KTE      )
+    CASE ( 3 )
+      CALL SUB3H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
+                I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                IMS,IME,JMS,JME,KMS,KME,                 &
+                ITS,ITE,JTS,JTE,KTS,KTE      )
+    CASE ( 4 )
+      CALL SUB4H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &    
+                I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                IMS,IME,JMS,JME,KMS,KME,                 &
+                ITS,ITE,JTS,JTE,KTS,KTE      )
+    CASE ( 5 )
+      CALL SUB5H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
+                I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                IMS,IME,JMS,JME,KMS,KME,                 &
+                ITS,ITE,JTS,JTE,KTS,KTE      )
+    CASE ( 0 )
+      CALL SUB6H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &    
+                I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                IMS,IME,JMS,JME,KMS,KME,                 &
+                ITS,ITE,JTS,JTE,KTS,KTE      )
+    END SELECT
+       write(0,105)"NEW H WEIGHTS:",I,J,IIH(i,j),JJH(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)
+  105  format(a,4i4,5f7.3)
+ END DO
+ END DO
+
+ RETURN
+ END SUBROUTINE G2T2H_new
+ SUBROUTINE SUB1H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
+                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                 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
+ INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: IP
+
+  IP = MOD(I,RATIO)
+  SELECT CASE(IP)
+   CASE ( 1 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    HBWGT1(I,J) = 1.0
+    HBWGT2(I,J) = 0.0
+    HBWGT3(I,J) = 0.0
+    HBWGT4(I,J) = 0.0
+   CASE ( 2 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    HBWGT1(I,J) = 4.0/9.0
+    HBWGT2(I,J) = 1.0/9.0
+    HBWGT3(I,J) = 2.0/9.0
+    HBWGT4(I,J) = 2.0/9.0
+   CASE ( 0 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    HBWGT1(I,J) = 1.0/9.0
+    HBWGT2(I,J) = 4.0/9.0
+    HBWGT3(I,J) = 2.0/9.0
+    HBWGT4(I,J) = 2.0/9.0
+   END SELECT
+ RETURN
+ END SUBROUTINE SUB1H
+ SUBROUTINE SUB2H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
+                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                 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
+ INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: IP
+
+  IP = MOD(I,RATIO)
+  SELECT CASE(IP)
+   CASE ( 1 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    HBWGT1(I,J) = 2.0/3.0
+    HBWGT2(I,J) = 0.0
+    HBWGT3(I,J) = 0.0
+    HBWGT4(I,J) = 1.0/3.0
+   CASE ( 2 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    HBWGT1(I,J) = 2.0/9.0
+    HBWGT2(I,J) = 2.0/9.0
+    HBWGT3(I,J) = 1.0/9.0
+    HBWGT4(I,J) = 4.0/9.0
+   CASE ( 0 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)+1
+    HBWGT1(I,J) = 1.0/3.0
+    HBWGT2(I,J) = 0.0
+    HBWGT3(I,J) = 2.0/3.0
+    HBWGT4(I,J) = 0.0
+   END SELECT
+ RETURN
+ END SUBROUTINE SUB2H
+ SUBROUTINE SUB3H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
+                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                 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
+ INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: IP
+
+  IP = MOD(I,RATIO)
+  SELECT CASE(IP)
+   CASE ( 1 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)-1
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)+1
+    HBWGT1(I,J) = 2.0/9.0
+    HBWGT2(I,J) = 2.0/9.0
+    HBWGT3(I,J) = 4.0/9.0
+    HBWGT4(I,J) = 1.0/9.0
+   CASE ( 2 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    HBWGT1(I,J) = 1.0/3.0
+    HBWGT2(I,J) = 0.0
+    HBWGT3(I,J) = 0.0
+    HBWGT4(I,J) = 2.0/3.0
+   CASE ( 0 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)+1
+    HBWGT1(I,J) = 2.0/3.0
+    HBWGT2(I,J) = 0.0
+    HBWGT3(I,J) = 1.0/3.0
+    HBWGT4(I,J) = 0.0
+   END SELECT
+ RETURN
+ END SUBROUTINE SUB3H
+ SUBROUTINE SUB4H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
+                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                 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
+ INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: IP
+
+  IP = MOD(I,RATIO)
+  SELECT CASE(IP)
+   CASE ( 1 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)-1
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    HBWGT1(I,J) = 1.0/9.0
+    HBWGT2(I,J) = 4.0/9.0
+    HBWGT3(I,J) = 2.0/9.0
+    HBWGT4(I,J) = 2.0/9.0
+   CASE ( 2 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    HBWGT1(I,J) = 1.0
+    HBWGT2(I,J) = 0.0
+    HBWGT3(I,J) = 0.0
+    HBWGT4(I,J) = 0.0
+   CASE ( 0 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    HBWGT1(I,J) = 4.0/9.0
+    HBWGT2(I,J) = 1.0/9.0
+    HBWGT3(I,J) = 2.0/9.0
+    HBWGT4(I,J) = 2.0/9.0
+   END SELECT
+ RETURN
+ END SUBROUTINE SUB4H
+ SUBROUTINE SUB5H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
+                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                 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
+ INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: IP
+
+  IP = MOD(I,RATIO)
+  SELECT CASE(IP)
+   CASE ( 1 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)-1
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    HBWGT1(I,J) = 2.0/9.0
+    HBWGT2(I,J) = 2.0/9.0
+    HBWGT3(I,J) = 1.0/9.0
+    HBWGT4(I,J) = 4.0/9.0
+   CASE ( 2 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)+1
+    HBWGT1(I,J) = 1.0/3.0
+    HBWGT2(I,J) = 0.0
+    HBWGT3(I,J) = 2.0/3.0
+    HBWGT4(I,J) = 0.0
+   CASE ( 0 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    HBWGT1(I,J) = 2.0/3.0
+    HBWGT2(I,J) = 0.0
+    HBWGT3(I,J) = 0.0
+    HBWGT4(I,J) = 1.0/3.0
+   END SELECT
+ RETURN
+ END SUBROUTINE SUB5H
+ SUBROUTINE SUB6H(I,J,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4, &
+                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                 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
+ INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIH,JJH
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: IP
+
+  IP = MOD(I,RATIO)
+  SELECT CASE(IP)
+   CASE ( 1 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
+    HBWGT1(I,J) = 2.0/3.0
+    HBWGT2(I,J) = 0.0
+    HBWGT3(I,J) = 1.0/3.0
+    HBWGT4(I,J) = 0.0
+   CASE ( 2 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
+    HBWGT1(I,J) = 2.0/9.0
+    HBWGT2(I,J) = 2.0/9.0
+    HBWGT3(I,J) = 4.0/9.0
+    HBWGT4(I,J) = 1.0/9.0
+   CASE ( 0 )
+    IIH(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJH(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    HBWGT1(I,J) = 1.0/3.0
+    HBWGT2(I,J) = 0.0
+    HBWGT3(I,J) = 0.0
+    HBWGT4(I,J) = 2.0/3.0
+   END SELECT
+ RETURN
+ END SUBROUTINE SUB6H
+
+!-----------------------------------------------------------------------------  
+
+ SUBROUTINE G2T2V_new( IIV,JJV,                            & ! output grid index and weights 
+                       VBWGT1,VBWGT2,                      & ! output weights in terms of parent grid
+                       VBWGT3,VBWGT4,                      &
+                       I_PARENT_START,J_PARENT_START,      & ! nest start I and J in parent domain  
+                       RATIO,                              & ! Ratio of parent and child grid ( always = 3 for NMM)
+                       IDS,IDE,JDS,JDE,KDS,KDE,            & ! target (nest) dimensions
+                       IMS,IME,JMS,JME,KMS,KME,            &
+                       ITS,ITE,JTS,JTE,KTS,KTE      )
+!
+!*** XUEJIN ZHANG --- Initial version (09/08/2008)
+!*** XUEJIN ZHANG --- Modified for parallel purpose (09/10/2009)
+!*** XUEJIN ZHANG --- Modified for parallel purpose (09/29/2009)
+!Function: Bilnear interpolation weight and indexing for E-grid
+!
+ 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   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: JP
+
+!*** ARRANGEMENT OF 4 VERTEXES FROM PARENT DOMAIN
+!***
+!***                  4
+!***
+!***                  v
+!***             1         2
+!***
+!***
+!***                  3
+!
+!************************************************************* 
+!***  POINT (i,j) SPANS 9 NESTED POINTS 
+!***  A VERTEX IN THE NEST DOMAIN AND INDEXING FOR PARENT DOMAIN
+!***
+!***
+!***                  V
+!***                
+!***               v  h  v
+!***              / \
+!***            v  h  v  h  v
+!***           / \   / \
+!***         V  H  v  h  v  h  V  H
+!***          \   / \   /   
+!***            v  h  v  h  v
+!***             \   /
+!***               v  h  v
+!***      
+!***                  V
+!***                 
+!***
+!***
+!************************************************************* 
+!*** MOVING NEST ALWAYS STARTING FROM MASS GRID H
+!*** PLEASE REFER TO E-GRID ARRANGEMENT FIGURE FOR WIND POINTS
+
+ DO J=JTS,MIN(JTE,JDE-1)
+ DO I=ITS,MIN(ITE,IDE-1)
+    JP = MOD(J,RATIO*2)
+    SELECT CASE(JP)
+    CASE ( 1 )
+      CALL SUB1V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
+                I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                IMS,IME,JMS,JME,KMS,KME,                 &
+                ITS,ITE,JTS,JTE,KTS,KTE      )
+    CASE ( 2 )
+      CALL SUB2V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &    
+                I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                IMS,IME,JMS,JME,KMS,KME,                 &
+                ITS,ITE,JTS,JTE,KTS,KTE      )
+    CASE ( 3 )
+      CALL SUB3V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
+                I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                IMS,IME,JMS,JME,KMS,KME,                 &
+                ITS,ITE,JTS,JTE,KTS,KTE      )
+    CASE ( 4 )
+      CALL SUB4V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &    
+                I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                IMS,IME,JMS,JME,KMS,KME,                 &
+                ITS,ITE,JTS,JTE,KTS,KTE      )
+    CASE ( 5 )
+      CALL SUB5V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
+                I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                IMS,IME,JMS,JME,KMS,KME,                 &
+                ITS,ITE,JTS,JTE,KTS,KTE      )
+    CASE ( 0 )
+      CALL SUB6V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &    
+                I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                IMS,IME,JMS,JME,KMS,KME,                 &
+                ITS,ITE,JTS,JTE,KTS,KTE      )
+    END SELECT
+!      WRITE(0,105)'NEW V WEIGHTS:',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)
+! 105  format(a,2i4,5f7.3,2i4)
+ END DO
+ END DO
+
+ RETURN
+ END SUBROUTINE G2T2V_new
+ SUBROUTINE SUB1V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
+                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                 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
+ INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: IP
+  IP = MOD(I,RATIO)
+  SELECT CASE(IP)
+   CASE ( 1 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO) - 1
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    VBWGT1(I,J) = 1.0/9.0
+    VBWGT2(I,J) = 4.0/9.0
+    VBWGT3(I,J) = 2.0/9.0
+    VBWGT4(I,J) = 2.0/9.0
+   CASE ( 2 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO) 
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    VBWGT1(I,J) = 1.0
+    VBWGT2(I,J) = 0.0
+    VBWGT3(I,J) = 0.0
+    VBWGT4(I,J) = 0.0
+   CASE ( 0 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    VBWGT1(I,J) = 4.0/9.0
+    VBWGT2(I,J) = 1.0/9.0
+    VBWGT3(I,J) = 2.0/9.0
+    VBWGT4(I,J) = 2.0/9.0
+   END SELECT
+ RETURN
+ END SUBROUTINE SUB1V
+ SUBROUTINE SUB2V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
+                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                 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
+ INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: IP
+  IP = MOD(I,RATIO)
+  SELECT CASE(IP)
+   CASE ( 1 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO) - 1
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    VBWGT1(I,J) = 2.0/9.0
+    VBWGT2(I,J) = 2.0/9.0
+    VBWGT3(I,J) = 1.0/9.0
+    VBWGT4(I,J) = 4.0/9.0
+   CASE ( 2 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
+    VBWGT1(I,J) = 1.0/3.0
+    VBWGT2(I,J) = 0.0
+    VBWGT3(I,J) = 2.0/3.0
+    VBWGT4(I,J) = 0.0
+   CASE ( 0 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    VBWGT1(I,J) = 2.0/3.0
+    VBWGT2(I,J) = 0.0
+    VBWGT3(I,J) = 0.0
+    VBWGT4(I,J) = 1.0/3.0
+   END SELECT
+ RETURN
+ END SUBROUTINE SUB2V
+ SUBROUTINE SUB3V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
+                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                 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
+ INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: IP
+  IP = MOD(I,RATIO)
+  SELECT CASE(IP)
+   CASE ( 1 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
+    VBWGT1(I,J) = 2.0/3.0
+    VBWGT2(I,J) = 0.0
+    VBWGT3(I,J) = 1.0/3.0
+    VBWGT4(I,J) = 0.0
+   CASE ( 2 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
+    VBWGT1(I,J) = 2.0/9.0
+    VBWGT2(I,J) = 2.0/9.0
+    VBWGT3(I,J) = 4.0/9.0
+    VBWGT4(I,J) = 1.0/9.0
+   CASE ( 0 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    VBWGT1(I,J) = 1.0/3.0
+    VBWGT2(I,J) = 0.0
+    VBWGT3(I,J) = 0.0
+    VBWGT4(I,J) = 2.0/3.0
+   END SELECT
+ RETURN
+ END SUBROUTINE SUB3V
+ SUBROUTINE SUB4V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
+                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                 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
+ INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: IP
+  IP = MOD(I,RATIO)
+  SELECT CASE(IP)
+   CASE ( 1 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    VBWGT1(I,J) = 1.0
+    VBWGT2(I,J) = 0.0
+    VBWGT3(I,J) = 0.0
+    VBWGT4(I,J) = 0.0
+   CASE ( 2 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    VBWGT1(I,J) = 4.0/9.0
+    VBWGT2(I,J) = 1.0/9.0
+    VBWGT3(I,J) = 2.0/9.0
+    VBWGT4(I,J) = 2.0/9.0
+   CASE ( 0 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    VBWGT1(I,J) = 1.0/9.0
+    VBWGT2(I,J) = 4.0/9.0
+    VBWGT3(I,J) = 2.0/9.0
+    VBWGT4(I,J) = 2.0/9.0
+   END SELECT
+ RETURN
+ END SUBROUTINE SUB4V
+ SUBROUTINE SUB5V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
+                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                 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
+ INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: IP
+  IP = MOD(I,RATIO)
+  SELECT CASE(IP)
+   CASE ( 1 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    VBWGT1(I,J) = 2.0/3.0
+    VBWGT2(I,J) = 0.0
+    VBWGT3(I,J) = 0.0
+    VBWGT4(I,J) = 1.0/3.0
+   CASE ( 2 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO)
+    VBWGT1(I,J) = 2.0/9.0
+    VBWGT2(I,J) = 2.0/9.0
+    VBWGT3(I,J) = 1.0/9.0
+    VBWGT4(I,J) = 4.0/9.0
+   CASE ( 0 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
+    VBWGT1(I,J) = 1.0/3.0
+    VBWGT2(I,J) = 0.0
+    VBWGT3(I,J) = 2.0/3.0
+    VBWGT4(I,J) = 0.0
+   END SELECT
+ RETURN
+ END SUBROUTINE SUB5V
+ SUBROUTINE SUB6V(I,J,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4, &
+                 I_PARENT_START,J_PARENT_START,           & ! nest start I and J in parent domain  
+                 RATIO,                                   & ! Ratio of parent and child grid ( always = 3 for NMM)
+                 IDS,IDE,JDS,JDE,KDS,KDE,                 & ! target (nest) dimensions
+                 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
+ INTEGER,    INTENT(IN   )                            :: I_PARENT_START,J_PARENT_START
+ INTEGER,    INTENT(IN   )                            :: RATIO
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: VBWGT1,VBWGT2,VBWGT3,VBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: IIV,JJV
+!LOCAL VARIABLES
+ INTEGER                                              :: I,J
+ INTEGER                                              :: IP
+  IP = MOD(I,RATIO)
+  SELECT CASE(IP)
+   CASE ( 1 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO) - 1
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
+    VBWGT1(I,J) = 2.0/9.0
+    VBWGT2(I,J) = 2.0/9.0
+    VBWGT3(I,J) = 4.0/9.0
+    VBWGT4(I,J) = 1.0/9.0
+   CASE ( 2 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) 
+    VBWGT1(I,J) = 1.0/3.0
+    VBWGT2(I,J) = 0.0
+    VBWGT3(I,J) = 0.0
+    VBWGT4(I,J) = 2.0/3.0
+   CASE ( 0 )
+    IIV(I,J)    = I_PARENT_START + INT((I-1)/RATIO)
+    JJV(I,J)    = J_PARENT_START + INT((J-1)/RATIO) + 1
+    VBWGT1(I,J) = 2.0/3.0
+    VBWGT2(I,J) = 0.0
+    VBWGT3(I,J) = 1.0/3.0
+    VBWGT4(I,J) = 0.0
+   END SELECT
+ RETURN
+ END SUBROUTINE SUB6V
+
+
+!------------------------------------------------------------------------------
+!
+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
+ CHARACTER(LEN=255):: message
+
+!-------------------------------------------------------------------------------------
+
+! 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(message,*)'ITE-ITS=',ITE-ITS,'JTE-JTS=',JTE-JTS
+   CALL wrf_message(trim(message))
+   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(message,*)'I=',I,'J=',J,'WEIGHTS=',HBWGT1(I,J),HBWGT2(I,J),HBWGT3(I,J),HBWGT4(I,J),1-ADDSUM
+       CALL wrf_message(trim(message))
+       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(message,*)'I=',I,'J=',J,'WEIGHTS=',VBWGT1(I,J),VBWGT2(I,J),VBWGT3(I,J),VBWGT4(I,J),1-ADDSUM
+       CALL wrf_message(trim(message))
+       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
+ CHARACTER(LEN=255)                 :: message
+
+!***  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(message,*)I,J,IIH(I,J),IPOS,JJH(I,J),JPOS,SHW
+         CALL wrf_message(trim(message))
+         WRITE(message,*)I,J,IIV(I,J),IPOS,JJV(I,J),JPOS,SHW
+         CALL wrf_message(trim(message))
+         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,JMS:JME,KMS:KME), INTENT(IN) :: PINT,T,Q,CWM
+ REAL, DIMENSION(KMS:KME),                 INTENT(OUT):: PSTD
+ REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), 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,JMS:JME,KMS:KME)             :: Z3d_IN
+ REAL,DIMENSION(JTB)                                  :: PIN,ZIN,Y2,PIO,ZOUT,DUM1,DUM2
+ REAL,DIMENSION(JTB)                                  :: QIN,QOUT,TIN,TOUT
+!-------------------------------------------------------------------------------------- 
+
+!  CLEAN Z3D ARRAY FIRST
+
+    DO K=KDS,KDE
+     DO J = JTS, MIN(JTE,JDE-1)
+      DO I = ITS, MIN(ITE,IDE-1)
+       Z3d(I,J,K)=0.0
+       T3d(I,J,K)=0.0
+       Q3d(I,J,K)=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,J,1)=FIS(I,J)*GI
+      ENDDO
+    ENDDO 
+
+    DO K = KDS,KDE-1
+     DO J = JTS, MIN(JTE,JDE-1)
+      DO I = ITS, MIN(ITE,IDE-1)
+        APELP    = (PINT(I,J,K+1)+PINT(I,J,K))
+!       RTOPP    = TRG*T(I,J,K)*(1.0+Q(I,J,K)*P608-CWM(I,J,K))/APELP
+        RTOPP    = TRG*T(I,J,K)*(1.0+Q(I,J,K)*P608)/APELP
+        DZ       = RTOPP*(DETA1(K)*PDTOP+DETA2(K)*PD(I,J))   ! (RTv/P_TOT)*D(P_HYDRO)
+        Z3d_IN(I,J,K+1) = Z3d_IN(I,J,K) + DZ
+      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,J,1)*(1.+D608*Q(I,J,1)) + LAPSR*(Z3d_IN(I,J,1)+Z3d_IN(I,J,2))*0.5
+        A         = LAPSR*Z3d_IN(I,J,1)/TSFC(I,J)
+        SLP(I,J)  = PINT(I,J,1)*(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,J,KDE-K+1)
+         ZIN(K) = Z3d_IN(I,J,KDE-K+1)
+       ENDDO
+
+       IF(PINT(I,J,1) .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,J,K)=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,J,KDE-K+1))+ALOG(PINT(I,J,KDE-K+2)))*0.5)
+         TIN(K-1) = T(I,J,KDE-K+1)
+       ENDDO
+
+       IF(PINT(I,J,1) .LE. PSTD(1))THEN
+         PIN(KDE-1) = EXP((ALOG(PSTD(1))+ALOG(PSTD(2)))*0.5)
+         ZMID     = 0.5*(Z3d_IN(I,J,1)+Z3d_IN(I,J,2))
+         TIN(KDE-1) = T(I,J,1) + 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,J,K)=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,J,KDE-K+1))+ALOG(PINT(I,J,KDE-K+2)))*0.5)
+         QIN(K-1) = Q(I,J,KDE-K+1)
+       ENDDO
+
+       IF(PINT(I,J,1) .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,J,K)=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
+      CHARACTER(LEN=255) :: message
+!---------------------------------------------------------------------
+
+!     debug
+
+      II=9999 !67 !35 !50   !4
+      JJ=9999 !31 !73 !115  !192
+      IF(I.eq.II.and.J.eq.JJ)THEN
+        WRITE(message,*)'DEBUG in SPLINE1:HSO= ',xnew(1:nold)
+        CALL wrf_debug(1,trim(message))
+        DO K=1,NOLD
+         WRITE(message,*)'DEBUG in SPLINE1:L,ZETAI,PINTI= ' &
+                        ,K,YOLD(K),XOLD(K)
+         CALL wrf_debug(1,trim(message))
+        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(message,*) 'DEBUG:: k1,xnew(k1),ynew(k1): ', k1,xnew(k1),ynew(k1)
+        CALL wrf_debug(1,trim(message))
+      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(24)  :: name = (/ "XLAT_M    ", &
+                                                "XLONG_M   ", &
+                                                "XLAT_V    ", &
+                                                "XLONG_V   ", &
+                                                "E         ", &
+                                                "F         ", &
+                                                "LANDMASK  ", &
+                                                "LANDUSEF  ", &
+                                                "LU_INDEX  ", &
+                                                "HCNVX     ", &
+                                                "HSTDV     ", &
+                                                "HASYW     ", &
+                                                "HASYS     ", &
+                                                "HASYSW    ", &
+                                                "HASYNW    ", &
+                                                "HLENW     ", &
+                                                "HLENS     ", &
+                                                "HLENSW    ", &
+                                                "HLENNW    ", &
+                                                "HANIS     ", &
+                                                "HSLOP     ", &
+                                                "HANGL     ", &
+                                                "HZMAX     ", &
+                                                "HGT_M     " /)
+
+ integer, parameter :: IO_BIN=1, IO_NET=2
+
+ integer :: io_form_input
+
+ CHARACTER(LEN=512) :: message
+
+ write(message,*)"in NEST_TERRAIN config_flags%io_form_input = ", config_flags%io_form_input
+ CALL wrf_message(trim(message))
+ write(message,*)"in NEST_TERRAIN config_flags%auxinput1_inname = ", config_flags%auxinput1_inname
+ CALL wrf_message(trim(message))
+
+ 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
+      JDS = nest%sd32
+      JDE = nest%ed32
+      KDS = nest%sd33
+      KDE = nest%ed33
+
+      IMS = nest%sm31
+      IME = nest%em31
+      JMS = nest%sm32
+      JME = nest%em32
+      KMS = nest%sm33
+      KME = nest%em33
+
+      ITS = nest%sp31
+      ITE = nest%ep31
+      JTS = nest%sp32
+      JTE = nest%ep32
+      KTS = nest%sp33
+      KTE = 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(message,*)" nest%id =", nest%id , " i_start,j_start,level =", i_start,j_start,level
+       CALL wrf_message(trim(message))
+
+       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,24
+
+             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 *, "cname=", cname
+             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 not 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(message,*)'SOME MATCHING TEST i_parent_start, j_parent_start',i_parent_start,j_parent_start
+       CALL wrf_message(trim(message))
+       CALL wrf_message('WRFSI LAT      COMPUTED LAT')
+        WRITE(message,*)lah_nest(1,1),nest%HLAT(1,1)
+       CALL wrf_message(trim(message))
+       CALL wrf_message('WRFSI LON      COMPUTED LON')
+        WRITE(message,*)loh_nest(1,1),nest%HLON(1,1)
+       CALL wrf_message(trim(message))
+
+        IF(ABS(lah_nest(1,1)-nest%HLAT(1,1)) .GE. 0.5 .OR.  & 
+           ABS(loh_nest(1,1)-nest%HLON(1,1)) .GE. 0.5)THEN 
+            CALL wrf_message('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-1,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%hres_fis(I,J)=DATA1(I,J)
+        ENDIF
+       ENDDO
+      ENDDO
+
+      DEALLOCATE(DATA1)
+      CALL wrf_message('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
+!
+!
+   INTERFACE
+     SUBROUTINE med_initialize_nest_nmm ( grid  &   
+!
+# include <dummy_new_args.inc>
+!
+                           )
+        USE module_domain
+        USE module_configure
+        USE module_timing
+        IMPLICIT NONE
+        TYPE(domain) , POINTER                  :: grid
+#include <dummy_new_decl.inc>
+     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
+
+   CALL med_initialize_nest_nmm( grid &   
+!
+# include <actual_new_args.inc>
+!
+                       )
+
+END SUBROUTINE med_init_domain_constants_nmm
+
+SUBROUTINE med_initialize_nest_nmm( grid &
+!
+# include <dummy_new_args.inc>
+!
+                           )
+
+ 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
+
+ CHARACTER(LEN=255) :: message
+
+   !  Definitions of dummy arguments to solve
+#include <dummy_new_decl.inc>
+
+!#define COPY_IN
+!#include <scalar_derefs.inc>
+#ifdef DM_PARALLEL
+#      include <data_calls.inc>
+#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(message,*)'TIME STEP ON DOMAIN',grid%id,'==',dt
+    CALL wrf_message(trim(message))
+
+    WRITE(message,*)'IDS,IDE ON DOMAIN',grid%id,'==',ids,ide
+    CALL wrf_message(trim(message))
+!
+    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
+
+!   Since SM has been changed on parent domain to be 0 over sea ice it can not be used here
+!   to find where sea ice is. That's why alogirthm here is slightly different than the
+!   one used in module_initalize_real.f
+
+#ifdef HWRF
+!zhang's doing: added to AVOID THIS COMPUTATION IF THE NEST IS STARTED USING ANALYSIS FILE
+   IF(.not. grid%analysis)THEN
+#endif
+    DO J = JTS, MIN(JTE,JDE-1)
+     DO I = ITS, MIN(ITE,IDE-1)
+
+      IF (grid%sm(I,J).GT.0.9) THEN                              ! OVER WATER SURFACE
+         grid%epsr(I,J)= 0.97
+         grid%embck(I,J)= 0.97
+         grid%gffc(I,J)= 0.
+         grid%albedo(I,J)=.06
+         grid%albase(I,J)=.06
+      ENDIF
+
+      IF (grid%sice(I,J).GT.0.9) THEN                            ! OVER SEA-ICE
+         grid%sm(I,J)=0.
+         grid%si(I,J)=0.
+         grid%gffc(I,J)=0.
+         grid%albedo(I,J)=.60
+         grid%albase(I,J)=.60
+      ENDIF
+
+      IF (grid%sm(I,J).LT.0.5.AND.grid%sice(I,J).LT.0.5) THEN         ! OVER LAND SURFACE
+           grid%si(I,J)=5.0*grid%weasd(I,J)/1000. ! SNOW WATER EQ (mm) OBTAINED FROM PARENT (grid%si) IS INTERPOLATED
+           grid%epsr(I,J)=1.0                ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN
+           grid%embck(I,J)=1.0               ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN
+           grid%gffc(I,J)=0.0                ! just leave zero as irrelevant
+           grid%sno(I,J)=grid%si(I,J)*.20         ! LAND-SNOW COVER
+      ENDIF
+
+     ENDDO
+    ENDDO
+
+#if 0
+    DO J = JTS, MIN(JTE,JDE-1)
+     DO I = ITS, MIN(ITE,IDE-1)
+      IF(grid%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
+             grid%si(I,J)=1.0                ! INITIALIZE SI BASED ON XICE FROM INTERPOLATED INPUT
+           ENDIF
+!
+           grid%epsr(I,J)= 0.97              ! VALID OVER SEA SURFACE
+           grid%embck(I,J)= 0.97              ! VALID OVER SEA SURFACE
+           grid%gffc(I,J)= 0.
+           grid%albedo(I,J)=.06
+           grid%albase(I,J)=.06
+!
+              IF(grid%si (I,J) .GT. 0.)THEN  ! VALID OVER SEA-ICE 
+                 grid%sm(I,J)=0.
+                 grid%si(I,J)=0.             ! 
+                 grid%sice(I,J)=1.
+                 grid%gffc(I,J)=0.           ! just leave zero as irrelevant
+                 grid%albedo(I,J)=.60        ! DEFINE grid%albedo 
+                 grid%albase(I,J)=.60
+              ENDIF
+!
+      ELSE                              ! OVER LAND SURFACE
+!
+           grid%si(I,J)=5.0*grid%weasd(I,J)/1000. ! SNOW WATER EQ (mm) OBTAINED FROM PARENT (grid%si) IS INTERPOLATED 
+           grid%epsr(I,J)=1.0                ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN
+           grid%embck(I,J)=1.0                ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN
+           grid%gffc(I,J)=0.0                ! just leave zero as irrelevant
+           grid%sice(I,J)=0.                 ! SEA ICE
+           grid%sno(I,J)=grid%si(I,J)*.20         ! LAND-SNOW COVER 
+!
+      ENDIF
+!
+     ENDDO
+    ENDDO
+#endif
+
+!   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)
+         grid%vegfra(I,J)=grid%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(grid%sm(I,J).LT.0.9.AND.grid%sice(I,J).LT.0.9) THEN
+!
+            IF ( (grid%sno(I,J) .EQ. 0.0) .OR. &            ! SNOWFREE ALBEDO
+                           (grid%albase(I,J) .GE. grid%mxsnal(I,J) ) ) THEN
+              grid%albedo(I,J) = grid%albase(I,J)
+            ELSE
+              IF (grid%sno(I,J) .LT. SNUP) THEN             ! MODIFY ALBEDO IF SNOWCOVER:
+                  RSNOW = grid%sno(I,J)/SNUP                ! BELOW SNOWDEPTH THRESHOLD
+                  SNOFAC = 1. - ( EXP(-SALP*RSNOW) - RSNOW*EXP(-SALP))
+              ELSE
+                  SNOFAC = 1.0                         ! ABOVE SNOWDEPTH THRESHOLD
+              ENDIF
+              grid%albedo(I,J) = grid%albase(I,J) &
+                          + (1.0-grid%vegfra(I,J))*SNOFAC*(grid%mxsnal(I,J)-grid%albase(I,J))
+            ENDIF
+!
+          END IF
+
+          grid%si(I,J)=5.0*grid%weasd(I,J)
+          grid%sno(I,J)=grid%weasd(I,J)
+! this block probably superfluous.  Meant to guarantee land/sea agreement
+
+        IF (grid%sm(I,J) .gt. 0.5)THEN 
+           grid%landmask(I,J)=0.0
+        ELSE 
+           grid%landmask(I,J)=1.0
+        ENDIF 
+
+        IF (grid%sice(I,J) .eq. 1.0) then !!!! change vegtyp and sltyp to fit seaice (desireable??)
+         grid%isltyp(I,J)=16
+         grid%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(grid%sm(I,J).GT.0.9 .AND. grid%vegfra(I,J) .NE. 0) THEN
+        WRITE(message,*)'PROBLEM AT THE LAND-WATER INTERFACE (VEGFRA):', &
+             I,J,grid%sm(I-1,J),grid%vegfra(I-1,j),grid%sm(I,J),grid%vegfra(I,J)
+        CALL wrf_message(trim(message))
+      ENDIF
+!
+#if defined(HWRF)
+      ! HWRF should not perform the check below because the nmm_tsk is
+      ! update with the correct skin temperature every timestep (on both
+      ! land and sea points).
+#else
+      IF(grid%sm(I,J).GT.0.9 .AND. grid%nmm_tsk(I,J) .NE. 0) THEN
+        WRITE(message,*)'PROBLEM AT THE LAND-WATER INTERFACE (NMM_TSK):', &
+             I,J,grid%sm(I-1,J),grid%nmm_tsk(I-1,J),grid%sm(I,J),grid%nmm_tsk(I,J)
+        CALL wrf_message(trim(message))
+      ENDIF
+#endif
+     ENDDO
+    ENDDO
+
+
+!   hardwire root depth for time being
+
+        grid%rtdpth=0.
+        grid%rtdpth(1)=0.1
+        grid%rtdpth(2)=0.3
+        grid%rtdpth(3)=0.6
+
+!   hardwire soil depth for time being
+
+        grid%sldpth=0.
+        grid%sldpth(1)=0.1
+        grid%sldpth(2)=0.3
+        grid%sldpth(3)=0.6
+        grid%sldpth(4)=1.0
+
+#ifdef HWRF
+!zhang's doing: added to AVOID THIS COMPUTATION IF THE NEST IS STARTED USING ANALYSIS FILE
+   ENDIF ! <------ for analysis set to false
+#endif 
+!-----------  END OF LAND SURFACE INITIALIZATION -------------------------------------
+!
+    DO J = JTS, MIN(JTE,JDE-1)
+     DO I = ITS, MIN(ITE,IDE-1)
+       grid%res(I,J)=1.
+     ENDDO
+    ENDDO
+
+!   INITIALIZE 2D BOUNDARY MASKS
+
+!! grid%hbm2:
+ 
+    grid%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
+          grid%hbm2(I,J)=1.
+        ENDIF
+      ENDDO
+    ENDDO   
+
+!! grid%hbm3:
+
+    grid%hbm3=0.
+    DO J=JTS,MIN(JTE,JDE-1)
+     grid%ihwg(J)=mod(J+1,2)-1
+      IF (J .ge. 4 .and. J .le. (JDE-1)-3) THEN
+        IHL=(IDS+1)-grid%ihwg(J) 
+        IHH=(IDE-1)-2
+        DO I=ITS,MIN(ITE,IDE-1)
+           IF (I .ge. IHL  .and. I .le. IHH) grid%hbm3(I,J)=1.
+        ENDDO 
+      ENDIF
+    ENDDO 
+   
+!! grid%vbm2
+
+    grid%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
+           grid%vbm2(I,J)=1.
+       ENDIF
+     ENDDO
+    ENDDO
+
+!! grid%vbm3
+
+    grid%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
+           grid%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    = grid%dlmd*DTR  ! input now from med_nest_egrid_configure
+    DPH    = grid%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= grid%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))
+         grid%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(message,*)'NEW CHANGE',grid%f4d,grid%ef4t,grid%f4q
+     CALL wrf_message(trim(message))
+
+      DO L=KDS,KDE-1
+        grid%rdeta(L)=1./grid%deta(L)
+        grid%f4q2(L)=-.25*grid%DT*DTAD/grid%deta(L)
+      ENDDO
+
+       DO J=JTS,MIN(JTE,JDE-1)
+        DO I=ITS,MIN(ITE,IDE-1)
+          grid%dx_nmm(I,J)=DXJ(J)
+          grid%wpdar(I,J)=WPDARJ(J)*grid%hbm2(I,J)
+          grid%cpgfu(I,J)=CPGFUJ(J)*grid%vbm2(I,J)
+          grid%curv(I,J)=CURVJ(J)*grid%vbm2(I,J)
+          grid%fcp(I,J)=FCPJ(J)*grid%hbm2(I,J)
+          grid%fdiv(I,J)=FDIVJ(J)*grid%hbm2(I,J)
+          grid%fad(I,J)=FADJ(J)
+          grid%hdacv(I,J)=HDACJ(J)*grid%vbm2(I,J)
+          grid%hdac(I,J)=HDACJ(J)*1.25*grid%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
+               grid%hdac(I,J)=grid%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
+               grid%hdac(I,J)=grid%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
+               grid%hdac(I,J)=grid%hdac(I,J)* DFC
+             ENDIF
+          ENDDO
+        ENDIF
+      ENDDO
+
+      DO J=JTS,min(JTE,JDE-1)
+      DO I=ITS,min(ITE,IDE-1)
+        grid%ddmpu(I,J)=DDMPUJ(J)*grid%vbm2(I,J)
+        grid%ddmpv(I,J)=DDMPVJ(J)*grid%vbm2(I,J)
+        grid%hdacv(I,J)=grid%hdacv(I,J)*grid%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
+             grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC
+             grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC
+             grid%hdacv(I,J)=grid%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
+            grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC
+            grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC
+            grid%hdacv(I,J)=grid%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
+            grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC
+            grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC
+            grid%hdacv(I,J)=grid%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)
+          grid%GLAT(I,J)=grid%HLAT(I,J)*DTR
+          grid%GLON(I,J)=grid%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))
+     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      grid%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      grid%emt(JA)=EMTJ(J)
+          DO 163 J=6,(JDE-1)-5
+          JA=JA+1
+          KHLA(JA)=2
+          KHHA(JA)=2+MOD(J,2)
+ 163      grid%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      grid%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      grid%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      grid%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      grid%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      grid%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                        !      | 
+         CALL wrf_message('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                !
+             grid%u(IDE-1,J,K)=0.                                    !  H  [x]    H    V
+             grid%v(IDE-1,J,K)=0.                                    !  ------    ------  
+           ENDIF                                                !   ide-1      ide
+          ENDDO                                                 !   NMM/si     WRF
+         ENDDO                                                  !   domain    domain
+        ENDIF                                                   !             (dummy)   
+
+
+! just a test for gravity waves
+
+!  PD=62000.
+!   grid%u=0.0
+!   grid%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)
+!      grid%sm(I,J)=I
+!       grid%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)
+      character(len=255) :: message
+      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)
+
+!
+          do i=ihl,ihh
+      hbms(i,j)=0.
+          enddo
+              enddo
+!-----------------------------------------------------------------------
+                  do ks=1,nsmud
+
+                write(message,*) 'H(1,1): ', h(1,1)
+                CALL wrf_message(trim(message))
+                write(message,*) 'H(3,1): ', h(1,1)
+                CALL wrf_message(trim(message))
+!-----------------------------------------------------------------------
+              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
+
+
+!-----------------------------------------------------------------------
+      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
+    JDS = parent%sd32
+    JDE = parent%ed32
+    KDS = parent%sd33
+    KDE = parent%ed33
+
+    IMS = parent%sm31
+    IME = parent%em31
+    JMS = parent%sm32
+    JME = parent%em32
+    KMS = parent%sm33
+    KME = parent%em33
+
+    ITS  = parent%sp31
+    ITE  = parent%ep31
+    JTS  = parent%sp32
+    JTE  = parent%ep32
+    KTS  = parent%sp33
+    KTE  = parent%ep33
+
+    NIDE = nest%ed31
+    NJDE = nest%ed32
+
+    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
+
+    CALL EARTH_LATLON ( parent%HLAT,parent%HLON,parent%VLAT,parent%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%HLAT(I,J))
+        DIFF2 = ABS(ALON - parent%HLON(I,J))
+        IF(DIFF1 .LE. ERR .AND. DIFF2 .LE. ERR)THEN
+         ILOC=I
+         JLOC=J
+        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(message,*)'NOTE: I_PARENT_START AND J_PARENT_START FOUND FOR THE NESTED DOMAIN CONFIGURATION AT ITER=',ITER
+       CALL wrf_message(trim(message))
+       WRITE(message,*)'istart=',ILOC
+       CALL wrf_message(trim(message))
+       WRITE(message,*)'jstart=',JLOC
+       CALL wrf_message(trim(message))
+     ELSE
+       ILOC=IDE/3
+       JLOC=JDE/3
+!
+       WRITE(message,*)'WARNING: COULD NOT LOCATE I_PARENT_START AND J_PARENT_START FROM INPUT STORM INFO'
+       CALL wrf_message(trim(message))
+       WRITE(message,*)'ISTART=',IDE/3
+       CALL wrf_message(trim(message))
+       WRITE(message,*)'JSTART=',JDE/3
+       CALL wrf_message(trim(message))
+     ENDIF
+
+     RETURN
+END SUBROUTINE initial_nest_pivot
+
+!============================================================================================
+#endif
+
+LOGICAL FUNCTION cd_feedback_mask_orig( 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
+
+   cd_feedback_mask_orig = ( 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 cd_feedback_mask_orig
+
+LOGICAL FUNCTION 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
+
+   cd_feedback_mask = ( pig .ge. ips_save+1 .and. &
+                            pjg .ge. jps_save+2 .and. &
+                            pig .le. ipe_save-1-mod(pjg-jps_save,2) .and. &
+                            pjg .le. jpe_save-2 )
+
+END FUNCTION cd_feedback_mask
+
+LOGICAL FUNCTION cd_feedback_mask_v( 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
+   
+   cd_feedback_mask_v = ( pig .ge. ips_save+1 .and. &
+                            pjg .ge. jps_save+2 .and. &
+                            pig .le. ipe_save-1-mod(pjg-jps_save+1,2) .and. &
+                            pjg .le. jpe_save-2 )
+
+END FUNCTION cd_feedback_mask_v
+
+
+!----------------------------------------------------------------------------
+#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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/RDTEMP.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/RDTEMP.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/RDTEMP.F	(revision 17)
@@ -0,0 +1,140 @@
+!
+!NCEP_MESO:MODEL_LAYER: PHYSICS
+!
+!***********************************************************************
+      SUBROUTINE RDTEMP(NTSD,DT,JULDAY,JULYR,XTIME,IHRST,GLAT,GLON      &
+     &                 ,CZEN,CZMEAN,T,RSWTT,RLWTT,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
+!   05-12-19  BLACK      - CONVERTED FROM IKJ TO IJK
+!     
+! 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,XTIME
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CZMEAN,GLAT,GLON    &
+     &                                             ,HBM2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: RLWTT       &
+     &                                                     ,RSWTT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),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
+      TIMES=XTIME*60.
+!
+      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)>0.)THEN 
+          FACTR(I,J)=CZEN(I,J)/CZMEAN(I,J)
+        ELSE
+          FACTR(I,J)=0.
+        ENDIF
+      ENDDO
+      ENDDO
+!
+      DO K=KTS,KTE
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+          TTNDKL=RSWTT(I,J,K)*FACTR(I,J)+RLWTT(I,J,K)
+          T(I,J,K)=T(I,J,K)+TTNDKL*DT*HBM2(I,J)
+        ENDDO
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+      END SUBROUTINE RDTEMP
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/adve_optim.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/adve_optim.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/adve_optim.h	(revision 17)
@@ -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<N_IUPADH_J)THEN
+                  IUP_ADH_J=IUP_ADH(IMS+KNTI_ADH,J)
+                  KNTI_ADH=KNTI_ADH+1
+                ENDIF
+!
+              ENDIF  ! End of advection H tendency IF block
+!
+            ENDDO  ! End of II loop
+!
+          ENDDO  ! End of K loop
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***  UPSTREAM ADVECTION OF VELOCITY COMPONENTS
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+          N_IUPADV_J=N_IUP_ADV(J)
+!
+          DO K=KTS,KTE
+!
+            DO II=0,N_IUPADV_J-1
+              I=IUP_ADV(IMS+II,J)
+!
+              TTA=EM_LOC(J)*UST(I,K,J1_00)
+              TTB=EN       *VST(I,K,J1_00)
+              PP=-TTA-TTB
+              QP=TTA-TTB
+!
+              IF(PP<0.)THEN
+                ISP=-1
+              ELSE
+                ISP= 1
+              ENDIF
+!
+              IF(QP<0.)THEN
+                ISQ=-1
+              ELSE
+                ISQ= 1
+              ENDIF
+!
+              IFP=(ISP-1)/2
+              IFQ=(-ISQ-1)/2
+              IPQ=(ISP-ISQ)/2
+              PP=ABS(PP)
+              QP=ABS(QP)
+              F3=PP*QP
+              F0=F3-PP-QP
+              F1=PP-F3
+              F2=QP-F3
+!
+              ADU(I,K,J)=F0*U(I,K,J)                                    &
+     &                  +F1*U(I+IVE(J)+IFP,K,J+ISP)                     &
+     &                  +F2*U(I+IVE(J)+IFQ,K,J+ISQ)                     &
+     &                  +F3*U(I+IPQ,K,J+ISP+ISQ)
+! 
+              ADV(I,K,J)=F0*V(I,K,J)                                    &
+     &                  +F1*V(I+IVE(J)+IFP,K,J+ISP)                     &
+     &                  +F2*V(I+IVE(J)+IFQ,K,J+ISQ)                     &
+     &                  +F3*V(I+IPQ,K,J+ISP+ISQ)
+!
+            ENDDO
+!
+          ENDDO  !  End of K loop
+!
+!-----------------------------------------------------------------------
+!
+        ENDIF upstream
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***  END OF THIS UPSTREAM REGION
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!***  COMPUTE VERTICAL ADVECTION TENDENCIES USING CRANK-NICHOLSON.
+!
+!-----------------------------------------------------------------------
+!***  FIRST THE TEMPERATURE
+!-----------------------------------------------------------------------
+!
+      iloop_for_t:  DO I=MYIS1,MYIE1
+!
+        PDOP=PDSLO(I,J)
+        PVVLO=PETDT(I,KTE-1,J)*DTQ
+        VVLO=PVVLO/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOP)
+        CMT=-VVLO+1.
+        RCMT(KTE)=1./CMT
+        CRT(KTE)=VVLO
+        RSTT(KTE)=-VVLO*(T(I,KTE-1,J)-T(I,KTE,J))+T(I,KTE,J)
+!
+        LMHK=KTE-LMH(I,J)+1
+        DO K=KTE-1,LMHK+1,-1
+          RDP=1./(DETA1_PDTOP(K)+DETA2(K)*PDOP)
+          PVVUP=PVVLO
+          PVVLO=PETDT(I,K-1,J)*DTQ
+          VVUP=PVVUP*RDP
+          VVLO=PVVLO*RDP
+          CFT=-VVUP*RCMT(K+1)
+          CMT=-CRT(K+1)*CFT+(VVUP-VVLO+1.)
+          RCMT(K)=1./CMT
+          CRT(K)=VVLO
+          RSTT(K)=-RSTT(K+1)*CFT+T(I,K,J)                               &
+     &            -(T(I,K,J)-T(I,K+1,J))*VVUP                           &
+     &            -(T(I,K-1,J)-T(I,K,J))*VVLO
+        ENDDO
+!
+        PVVUP=PVVLO
+        VVUP=PVVUP/(DETA1_PDTOP(LMHK)+DETA2(LMHK)*PDOP)
+        CFT=-VVUP*RCMT(LMHK+1)
+        CMT=-CRT(LMHK+1)*CFT+VVUP+1.
+        CRT(LMHK)=0.
+        RSTT(LMHK)=-(T(I,LMHK,J)-T(I,LMHK+1,J))*VVUP                    &
+     &               -RSTT(LMHK+1)*CFT+T(I,LMHK,J)
+        TN(LMHK)=RSTT(LMHK)/CMT
+        VAD_TEND_T(I,LMHK)=TN(LMHK)-T(I,LMHK,J)
+!
+        DO K=LMHK+1,KTE
+          TN(K)=(-CRT(K)*TN(K-1)+RSTT(K))*RCMT(K)
+          VAD_TEND_T(I,K)=TN(K)-T(I,K,J)
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  The following section is only for checking the implicit solution
+!***  using back-substitution.  Remove this section otherwise.
+!-----------------------------------------------------------------------
+!
+!       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
+!
+!-----------------------------------------------------------------------
+!***  End of check.
+!-----------------------------------------------------------------------
+!
+      ENDDO iloop_for_t
+!
+!-----------------------------------------------------------------------
+!***  NOW VERTICAL ADVECTION OF WIND COMPONENTS
+!-----------------------------------------------------------------------
+!
+      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+1.
+        CMV=-VVLOV+1.
+        RCMU(KTE)=1./CMU
+        RCMV(KTE)=1./CMV
+        CRU(KTE)=VVLOU
+        CRV(KTE)=VVLOV
+        RSTU(KTE)=-VVLOU*(U(I,KTE-1,J)-U(I,KTE,J))+U(I,KTE,J)
+        RSTV(KTE)=-VVLOV*(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*RCMU(K+1)
+          CFV=-VVUPV*RCMV(K+1)
+          CMU=-CRU(K+1)*CFU+VVUPU-VVLOU+1.
+          CMV=-CRV(K+1)*CFV+VVUPV-VVLOV+1.
+          RCMU(K)=1./CMU
+          RCMV(K)=1./CMV
+          CRU(K)=VVLOU
+          CRV(K)=VVLOV
+          RSTU(K)=-RSTU(K+1)*CFU+U(I,K,J)                               &
+     &            -(U(I,K,J)-U(I,K+1,J))*VVUPU                          &
+     &            -(U(I,K-1,J)-U(I,K,J))*VVLOU
+          RSTV(K)=-RSTV(K+1)*CFV+V(I,K,J)                               &
+     &            -(V(I,K,J)-V(I,K+1,J))*VVUPV                          &
+     &            -(V(I,K-1,J)-V(I,K,J))*VVLOV
+        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*RCMU(LMVK+1)
+        CFV=-VVUPV*RCMV(LMVK+1)
+        CMU=-CRU(LMVK+1)*CFU+VVUPU+1.
+        CMV=-CRV(LMVK+1)*CFV+VVUPV+1.
+        CRU(LMVK)=0.
+        CRV(LMVK)=0.
+        RSTU(LMVK)=-(U(I,LMVK,J)-U(I,LMVK+1,J))*VVUPU                   &
+     &               -RSTU(LMVK+1)*CFU+U(I,LMVK,J)
+        RSTV(LMVK)=-(V(I,LMVK,J)-V(I,LMVK+1,J))*VVUPV                   &
+     &               -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(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
+!
+!-----------------------------------------------------------------------
+!***  End of check.
+!-----------------------------------------------------------------------
+!
+      ENDDO iloop_for_uv
+!
+!
+!-----------------------------------------------------------------------
+!
+!***  NOW SUM THE VERTICAL AND HORIZONTAL TENDENCIES,
+!***  CURVATURE AND CORIOLIS TERMS
+!
+!-----------------------------------------------------------------------
+!
+      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
+!-----------------------------------------------------------------------
+!
+      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
+!-----------------------------------------------------------------------
+!
+      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
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/adve_orig.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/adve_orig.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/adve_orig.h	(revision 17)
@@ -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<N_IUPADH_J)THEN
+                  IUP_ADH_J=IUP_ADH(IMS+KNTI_ADH,J)
+                  KNTI_ADH=KNTI_ADH+1
+                ENDIF
+!
+              ENDIF  ! End of advection H tendency IF block
+!
+            ENDDO  ! End of II loop
+!
+          ENDDO  ! End of K loop
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***  UPSTREAM ADVECTION OF VELOCITY COMPONENTS
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+          N_IUPADV_J=N_IUP_ADV(J)
+!
+          DO K=KTS,KTE
+!
+            DO II=0,N_IUPADV_J-1
+              I=IUP_ADV(IMS+II,J)
+!
+              TTA=EM_LOC(J)*UST(I,K,J1_00)
+              TTB=EN       *VST(I,K,J1_00)
+              PP=-TTA-TTB
+              QP=TTA-TTB
+!
+              IF(PP<0.)THEN
+                ISP=-1
+              ELSE
+                ISP= 1
+              ENDIF
+!
+              IF(QP<0.)THEN
+                ISQ=-1
+              ELSE
+                ISQ= 1
+              ENDIF
+!
+              IFP=(ISP-1)/2
+              IFQ=(-ISQ-1)/2
+              IPQ=(ISP-ISQ)/2
+              PP=ABS(PP)
+              QP=ABS(QP)
+              F3=PP*QP
+              F0=F3-PP-QP
+              F1=PP-F3
+              F2=QP-F3
+!
+              ADU(I,K,J)=F0*U(I,K,J)                                    &
+     &                  +F1*U(I+IVE(J)+IFP,K,J+ISP)                     &
+     &                  +F2*U(I+IVE(J)+IFQ,K,J+ISQ)                     &
+     &                  +F3*U(I+IPQ,K,J+ISP+ISQ)
+! 
+              ADV(I,K,J)=F0*V(I,K,J)                                    &
+     &                  +F1*V(I+IVE(J)+IFP,K,J+ISP)                     &
+     &                  +F2*V(I+IVE(J)+IFQ,K,J+ISQ)                     &
+     &                  +F3*V(I+IPQ,K,J+ISP+ISQ)
+!
+            ENDDO
+!
+          ENDDO  !  End of K loop
+!
+!-----------------------------------------------------------------------
+!
+        ENDIF upstream
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***  END OF THIS UPSTREAM REGION
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!***  COMPUTE VERTICAL ADVECTION TENDENCIES USING CRANK-NICHOLSON.
+!
+!-----------------------------------------------------------------------
+!***  FIRST THE TEMPERATURE
+!-----------------------------------------------------------------------
+!
+      iloop_for_t:  DO I=MYIS1,MYIE1
+!
+        PDOP=PDSLO(I,J)
+        PVVLO=PETDT(I,KTE-1,J)*DTQ
+        VVLO=PVVLO/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOP)
+        CMT=-VVLO+1.
+        RCMT(KTE)=1./CMT
+        CRT(KTE)=VVLO
+        RSTT(KTE)=-VVLO*(T(I,KTE-1,J)-T(I,KTE,J))+T(I,KTE,J)
+!
+        LMHK=KTE-LMH(I,J)+1
+        DO K=KTE-1,LMHK+1,-1
+          RDP=1./(DETA1_PDTOP(K)+DETA2(K)*PDOP)
+          PVVUP=PVVLO
+          PVVLO=PETDT(I,K-1,J)*DTQ
+          VVUP=PVVUP*RDP
+          VVLO=PVVLO*RDP
+          CFT=-VVUP*RCMT(K+1)
+          CMT=-CRT(K+1)*CFT+(VVUP-VVLO+1.)
+          RCMT(K)=1./CMT
+          CRT(K)=VVLO
+          RSTT(K)=-RSTT(K+1)*CFT+T(I,K,J)                               &
+     &            -(T(I,K,J)-T(I,K+1,J))*VVUP                           &
+     &            -(T(I,K-1,J)-T(I,K,J))*VVLO
+        ENDDO
+!
+        PVVUP=PVVLO
+        VVUP=PVVUP/(DETA1_PDTOP(LMHK)+DETA2(LMHK)*PDOP)
+        CFT=-VVUP*RCMT(LMHK+1)
+        CMT=-CRT(LMHK+1)*CFT+VVUP+1.
+        CRT(LMHK)=0.
+        RSTT(LMHK)=-(T(I,LMHK,J)-T(I,LMHK+1,J))*VVUP                    &
+     &               -RSTT(LMHK+1)*CFT+T(I,LMHK,J)
+        TN(LMHK)=RSTT(LMHK)/CMT
+        VAD_TEND_T(I,LMHK)=TN(LMHK)-T(I,LMHK,J)
+!
+        DO K=LMHK+1,KTE
+          TN(K)=(-CRT(K)*TN(K-1)+RSTT(K))*RCMT(K)
+          VAD_TEND_T(I,K)=TN(K)-T(I,K,J)
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  The following section is only for checking the implicit solution
+!***  using back-substitution.  Remove this section otherwise.
+!-----------------------------------------------------------------------
+!
+!       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
+!
+!-----------------------------------------------------------------------
+!***  End of check.
+!-----------------------------------------------------------------------
+!
+      ENDDO iloop_for_t
+!
+!-----------------------------------------------------------------------
+!***  NOW VERTICAL ADVECTION OF WIND COMPONENTS
+!-----------------------------------------------------------------------
+!
+      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+1.
+        CMV=-VVLOV+1.
+        RCMU(KTE)=1./CMU
+        RCMV(KTE)=1./CMV
+        CRU(KTE)=VVLOU
+        CRV(KTE)=VVLOV
+        RSTU(KTE)=-VVLOU*(U(I,KTE-1,J)-U(I,KTE,J))+U(I,KTE,J)
+        RSTV(KTE)=-VVLOV*(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*RCMU(K+1)
+          CFV=-VVUPV*RCMV(K+1)
+          CMU=-CRU(K+1)*CFU+VVUPU-VVLOU+1.
+          CMV=-CRV(K+1)*CFV+VVUPV-VVLOV+1.
+          RCMU(K)=1./CMU
+          RCMV(K)=1./CMV
+          CRU(K)=VVLOU
+          CRV(K)=VVLOV
+          RSTU(K)=-RSTU(K+1)*CFU+U(I,K,J)                               &
+     &            -(U(I,K,J)-U(I,K+1,J))*VVUPU                          &
+     &            -(U(I,K-1,J)-U(I,K,J))*VVLOU
+          RSTV(K)=-RSTV(K+1)*CFV+V(I,K,J)                               &
+     &            -(V(I,K,J)-V(I,K+1,J))*VVUPV                          &
+     &            -(V(I,K-1,J)-V(I,K,J))*VVLOV
+        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*RCMU(LMVK+1)
+        CFV=-VVUPV*RCMV(LMVK+1)
+        CMU=-CRU(LMVK+1)*CFU+VVUPU+1.
+        CMV=-CRV(LMVK+1)*CFV+VVUPV+1.
+        CRU(LMVK)=0.
+        CRV(LMVK)=0.
+        RSTU(LMVK)=-(U(I,LMVK,J)-U(I,LMVK+1,J))*VVUPU                   &
+     &               -RSTU(LMVK+1)*CFU+U(I,LMVK,J)
+        RSTV(LMVK)=-(V(I,LMVK,J)-V(I,LMVK+1,J))*VVUPV                   &
+     &               -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(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
+!
+!-----------------------------------------------------------------------
+!***  End of check.
+!-----------------------------------------------------------------------
+!
+      ENDDO iloop_for_uv
+!
+!
+!-----------------------------------------------------------------------
+!
+!***  NOW SUM THE VERTICAL AND HORIZONTAL TENDENCIES,
+!***  CURVATURE AND CORIOLIS TERMS
+!
+!-----------------------------------------------------------------------
+!
+      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
+!-----------------------------------------------------------------------
+!
+      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
+!-----------------------------------------------------------------------
+!
+      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
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/init_modules_nmm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/init_modules_nmm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/init_modules_nmm.F	(revision 17)
@@ -0,0 +1,7 @@
+!WRF:MEDIATION_LAYER
+!
+SUBROUTINE init_modules_nmm
+! USE module_indx
+! CALL init_module_indx
+END SUBROUTINE init_modules_nmm
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_ADVECTION.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_ADVECTION.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_ADVECTION.F	(revision 17)
@@ -0,0 +1,3808 @@
+!----------------------------------------------------------------------
+!#define BIT_FOR_BIT
+!----------------------------------------------------------------------
+#include "nmm_loop_basemacros.h"
+#include "nmm_loop_macros.h"
+!----------------------------------------------------------------------
+!
+!NCEP_MESO:MODEL_LAYER: HORIZONTAL AND VERTICAL ADVECTION
+!
+!----------------------------------------------------------------------
+!
+      MODULE MODULE_ADVECTION
+!
+!----------------------------------------------------------------------
+      USE MODULE_MODEL_CONSTANTS
+      USE MODULE_EXT_INTERNAL
+!----------------------------------------------------------------------
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      INCLUDE "mpif.h"
+#endif
+!----------------------------------------------------------------------
+!
+      REAL,PARAMETER :: FF2=-0.64813,FF3=0.24520,FF4=-0.12189
+      REAL,PARAMETER :: FFC=1.533,FBC=1.-FFC
+      REAL :: CONSERVE_MIN=0.9,CONSERVE_MAX=1.1
+!
+!----------------------------------------------------------------------
+!***  CRANK-NICHOLSON OFF-CENTER WEIGHTS FOR CURRENT AND FUTURE
+!***  TIME LEVELS.
+!-----------------------------------------------------------------------
+!
+      REAL,PARAMETER :: WGT1=0.90
+      REAL,PARAMETER :: WGT2=2.-WGT1
+!
+!***  FOR CRANK_NICHOLSON CHECK ONLY.
+!
+      INTEGER :: ITEST=47,JTEST=70
+      REAL :: ADTP,ADUP,ADVP,TTLO,TTUP,TULO,TUUP,TVLO,TVUP
+!
+!----------------------------------------------------------------------
+      CONTAINS
+!
+!*********************************************************************** 
+      SUBROUTINE ADVE(NTSD,DT,DETA1,DETA2,PDTOP                         &
+     &               ,CURV,F,FAD,F4D,EM_LOC,EMT_LOC,EN,ENT,DX,DY        &
+     &               ,HBM2,VBM2                                         &
+     &               ,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                                   &
+     &               ,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
+!   04-11-23  BLACK        - THREADED 
+!   05-12-14  BLACK        - CONVERTED FROM IKJ TO IJK
+!     
+! USAGE: CALL ADVE 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         &
+                                               ,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
+!
+      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,JMS:JME),INTENT(OUT) :: ADT,ADU,ADV
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PETDT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: T,TOLD   &
+     &                                                        ,U,UOLD   &
+     &                                                        ,V,VOLD
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(OUT) :: 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                                &
+     &          ,N,N_IUPH_J,N_IUPADH_J,N_IUPADV_J
+!
+      INTEGER :: MY_IS_GLB,MY_IE_GLB,MY_JS_GLB,MY_JE_GLB
+!
+      INTEGER,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: ISPA,ISQA
+!
+      REAL :: ADPDX,ADPDY,ARRAY3_X,CFL,CFT,CFU,CFV,CMT,CMU,CMV          &
+     &       ,DTE,DTQ,F0,F1,F2,F3,FEWP,FNEP,FNSP,FPP,FSEP,HM            &
+     &       ,PDOP,PDOPU,PDOPV,PP                                       &
+     &       ,PVVLO,PVVLOU,PVVLOV,PVVUP,PVVUPU,PVVUPV                   &
+     &       ,QP,RDP,RDPU,RDPV                                          &
+     &       ,TEMPA,TEMPB,TTA,TTB,UDY                                   &
+     &       ,VDX,VM,VVLO,VVLOU,VVLOV,VVUP,VVUPU,VVUPV
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: ARRAY0,ARRAY1          &
+     &                                          ,ARRAY2,ARRAY3          &
+     &                                          ,DPDE,RDPD,RDPDX,RDPDY  &
+     &                                          ,TEW,TNE,TNS,TSE,TST    &
+     &                                          ,UNE,UNED,UEW,UNS,USE   &
+     &                                          ,USED,UST               &
+     &                                          ,VEW,VNE,VNS,VSE        &
+     &                                          ,VST
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5,KTS:KTE) :: VAD_TEND_T     &
+     &                                                  ,VAD_TEND_U     &
+     &                                                  ,VAD_TEND_V
+!
+      REAL,DIMENSION(KTS:KTE) :: CRT,CRU,CRV,DETA1_PDTOP                &
+     &                          ,RCMT,RCMU,RCMV,RSTT,RSTU,RSTV          &
+     &                          ,T_K,TN,U_K,UN,V_K,VN
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!
+!                         DPDE      -----  3
+!                          |                      J Increasing
+!                          |
+!                          |                            ^
+!                         FNS       -----  2            |
+!                          |                            |
+!                          |                            |
+!                          |                            |
+!                         VNS       -----  1            |
+!                          |
+!                          |
+!                          |
+!                         ADV       -----  0  ------> Current J
+!                          |
+!                          |
+!                          |
+!                         VNS       ----- -1
+!                          |
+!                          |
+!                          |
+!                         FNS       ----- -2
+!                          |
+!                          |
+!                          |
+!                         DPDE      ----- -3
+!
+!***********************************************************************
+!-----------------------------------------------------------------------
+     DO J=JTS-5,JTE+5
+     DO I=ITS-5,ITE+5
+       ARRAY0(I,J)=0.0
+       ARRAY1(I,J)=0.0
+       ARRAY2(I,J)=0.0
+       ARRAY3(I,J)=0.0
+       DPDE(I,J)=0.0
+       RDPD(I,J)=0.0
+       RDPDX(I,J)=0.0
+       RDPDY(I,J)=0.0
+       TEW(I,J)=0.0
+       TNE(I,J)=0.0
+       TNS(I,J)=0.0
+       TSE(I,J)=0.0
+       TST(I,J)=0.0
+       UNE(I,J)=0.0
+       UNED(I,J)=0.0
+       UEW(I,J)=0.0
+       UNS(I,J)=0.0
+       USE(I,J)=0.0
+       USED(I,J)=0.0
+       UST(I,J)=0.0
+       VEW(I,J)=0.0
+       VNE(I,J)=0.0
+       VNS(I,J)=0.0
+       VSE(I,J)=0.0
+       VST(I,J)=0.0
+     ENDDO
+     ENDDO
+!-----------------------------------------------------------------------
+!
+      DTQ=DT*0.25
+      DTE=DT*(0.5*0.25)
+!
+!-----------------------------------------------------------------------
+!***
+!***  PRECOMPUTE DETA1 TIMES PDTOP.
+!***
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+        DETA1_PDTOP(K)=DETA1(K)*PDTOP
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***
+!***  INITIALIZE SOME WORKING ARRAYS TO ZERO
+!***
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!***  COMPUTE VERTICAL ADVECTION TENDENCIES USING CRANK-NICHOLSON.
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***  FIRST THE TEMPERATURE
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(cft,cfu,cfv,cmt,cmu,cmv,crt,cru,crv,i,k                  &
+!$omp&        ,pdop,pdopu,pdopv,pvvlo,pvvlou,pvvlov,pvvup,pvvupu,pvvupv &
+!$omp&        ,rcmt,rcmu,rcmv,rdp,rdpu,rdpv,rstt,rstu,rstv,t_k,tn       &
+!$omp&        ,u_k,un,v_k,vn,vvlo,vvlou,vvlov,vvup,vvupu,vvupv)
+!!$omp& private(adtp,adup,advp,ttlo,ttup,tulo,tuup,tvlo,tvup)
+!-----------------------------------------------------------------------
+!
+      main_vertical: DO J=MYJS2,MYJE2
+!
+!-----------------------------------------------------------------------
+!
+        iloop_for_t: DO I=MYIS1,MYIE1
+!
+!-----------------------------------------------------------------------
+!***  EXTRACT T FROM THE COLUMN
+!-----------------------------------------------------------------------
+!
+          DO K=KTS,KTE
+            T_K(K)=T(I,J,K)
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!
+          PDOP=PDSLO(I,J)
+          PVVLO=PETDT(I,J,KTE-1)*DTQ
+          VVLO=PVVLO/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOP)
+          CMT=-VVLO*WGT2+1.
+          RCMT(KTE)=1./CMT
+          CRT(KTE)=VVLO*WGT2
+          RSTT(KTE)=-VVLO*WGT1*(T_K(KTE-1)-T_K(KTE))+T_K(KTE)
+!
+!-----------------------------------------------------------------------
+!
+          DO K=KTE-1,KTS+1,-1
+            RDP=1./(DETA1_PDTOP(K)+DETA2(K)*PDOP)
+            PVVUP=PVVLO
+            PVVLO=PETDT(I,J,K-1)*DTQ
+            VVUP=PVVUP*RDP
+            VVLO=PVVLO*RDP
+            CFT=-VVUP*WGT2*RCMT(K+1)
+            CMT=-CRT(K+1)*CFT+((VVUP-VVLO)*WGT2+1.)
+            RCMT(K)=1./CMT
+            CRT(K)=VVLO*WGT2
+            RSTT(K)=-RSTT(K+1)*CFT+T_K(K)                               &
+       &            -(T_K(K)-T_K(K+1))*VVUP*WGT1                        &
+       &            -(T_K(K-1)-T_K(K))*VVLO*WGT1
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!
+          PVVUP=PVVLO
+          VVUP=PVVUP/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOP)
+          CFT=-VVUP*WGT2*RCMT(KTS+1)
+          CMT=-CRT(KTS+1)*CFT+VVUP*WGT2+1.
+          CRT(KTS)=0.
+          RSTT(KTS)=-(T_K(KTS)-T_K(KTS+1))*VVUP*WGT1                    &
+      &              -RSTT(KTS+1)*CFT+T_K(KTS)
+          TN(KTS)=RSTT(KTS)/CMT
+          VAD_TEND_T(I,J,KTS)=TN(KTS)-T_K(KTS)
+!
+          DO K=KTS+1,KTE
+            TN(K)=(-CRT(K)*TN(K-1)+RSTT(K))*RCMT(K)
+            VAD_TEND_T(I,J,K)=TN(K)-T_K(K)
+          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
+!!
+!         PVVLO=PETDT(I,J,KTE-1)*DT*0.25
+!         VVLO=PVVLO/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOP)
+!         TTLO=VVLO*(T(I,J,KTE-1)-T(I,J,KTE)                            &
+!    &              +TN(KTE-1)-TN(KTE))
+!         ADTP=TTLO+TN(KTE)-T(I,J,KTE)
+!         WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',KTE     &
+!    &,             ' ADTP=',ADTP
+!         WRITE(0,*)' T=',T(I,J,KTE),' TN=',TN(KTE)                     &
+!    &,               ' VAD_TEND_T=',VAD_TEND_T(I,J,KTE)
+!         WRITE(0,*)' '
+!!
+!         DO K=KTE-1,KTS+1,-1
+!           RDP=1./(DETA1_PDTOP(K)+DETA2(K)*PDOP)
+!           PVVUP=PVVLO
+!           PVVLO=PETDT(I,J,K-1)*DT*0.25
+!           VVUP=PVVUP*RDP
+!           VVLO=PVVLO*RDP
+!           TTUP=VVUP*(T(I,J,K)-T(I,J,K+1)+TN(K)-TN(K+1))
+!           TTLO=VVLO*(T(I,J,K-1)-T(I,J,K)+TN(K-1)-TN(K))
+!           ADTP=TTLO+TTUP+TN(K)-T(I,J,K)
+!           WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',K             &
+!    &,               ' ADTP=',ADTP
+!           WRITE(0,*)' T=',T(I,J,K),' TN=',TN(K)                       &
+!    &,               ' VAD_TEND_T=',VAD_TEND_T(I,J,K)
+!           WRITE(0,*)' '
+!         ENDDO
+!!
+!         PVVUP=PVVLO
+!         VVUP=PVVUP/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOP)
+!         TTUP=VVUP*(T(I,J,KTS)-T(I,J,KTS+1)+TN(KTS)-TN(KTS+1))
+!         ADTP=TTUP+TN(KTS)-T(I,J,KTS)
+!         WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',KTS             &
+!    &,             ' ADTP=',ADTP
+!         WRITE(0,*)' T=',T(I,J,KTS),' TN=',TN(KTS)                     &
+!    &,             ' VAD_TEND_T=',VAD_TEND_T(I,J,KTS)
+!         WRITE(0,*)' '
+!       ENDIF
+!       endif
+!
+!-----------------------------------------------------------------------
+!***  End of check.
+!-----------------------------------------------------------------------
+!
+        ENDDO iloop_for_t
+!
+!-----------------------------------------------------------------------
+!
+!***  NOW VERTICAL ADVECTION OF WIND COMPONENTS
+!
+!-----------------------------------------------------------------------
+!
+        iloop_for_uv:  DO I=MYIS1,MYIE1
+!
+!-----------------------------------------------------------------------
+!***  EXTRACT U AND V FROM THE COLUMN
+!-----------------------------------------------------------------------
+!
+          DO K=KTS,KTE
+            U_K(K)=U(I,J,K)
+            V_K(K)=V(I,J,K)
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!
+          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),J,KTE-1)+PETDT(I+IVE(J),J,KTE-1))*DTE
+          PVVLOV=(PETDT(I,J-1,KTE-1)+PETDT(I,J+1,KTE-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_K(KTE-1)-U_K(KTE))+U_K(KTE)
+          RSTV(KTE)=-VVLOV*WGT1*(V_K(KTE-1)-V_K(KTE))+V_K(KTE)
+!
+!-----------------------------------------------------------------------
+!
+          DO K=KTE-1,KTS+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),J,K-1)+PETDT(I+IVE(J),J,K-1))*DTE
+            PVVLOV=(PETDT(I,J-1,K-1)+PETDT(I,J+1,K-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_K(K)                               &
+     &              -(U_K(K)-U_K(K+1))*VVUPU*WGT1                       &
+     &              -(U_K(K-1)-U_K(K))*VVLOU*WGT1
+            RSTV(K)=-RSTV(K+1)*CFV+V_K(K)                               &
+     &              -(V_K(K)-V_K(K+1))*VVUPV*WGT1                       &
+     &              -(V_K(K-1)-V_K(K))*VVLOV*WGT1
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!
+          RDPU=1./(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPU)
+          RDPV=1./(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPV)
+          PVVUPU=PVVLOU
+          PVVUPV=PVVLOV
+          VVUPU=PVVUPU*RDPU
+          VVUPV=PVVUPV*RDPV
+          CFU=-VVUPU*WGT2*RCMU(KTS+1)
+          CFV=-VVUPV*WGT2*RCMV(KTS+1)
+          CMU=-CRU(KTS+1)*CFU+VVUPU*WGT2+1.
+          CMV=-CRV(KTS+1)*CFV+VVUPV*WGT2+1.
+          CRU(KTS)=0.
+          CRV(KTS)=0.
+          RSTU(KTS)=-(U_K(KTS)-U_K(KTS+1))*VVUPU*WGT1                   &
+       &               -RSTU(KTS+1)*CFU+U_K(KTS)
+          RSTV(KTS)=-(V_K(KTS)-V_K(KTS+1))*VVUPV*WGT1                   &
+       &               -RSTV(KTS+1)*CFV+V_K(KTS)
+          UN(KTS)=RSTU(KTS)/CMU
+          VN(KTS)=RSTV(KTS)/CMV
+          VAD_TEND_U(I,J,KTS)=UN(KTS)-U_K(KTS)
+          VAD_TEND_V(I,J,KTS)=VN(KTS)-V_K(KTS)
+!
+          DO K=KTS+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,J,K)=UN(K)-U_K(K)
+            VAD_TEND_V(I,J,K)=VN(K)-V_K(K)
+          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),J,KTE-1)                               &
+!    &           +PETDT(I+IVE(J),J,KTE-1))*DTE
+!         PVVLOV=(PETDT(I,J-1,KTE-1)                                    &
+!    &           +PETDT(I,J+1,KTE-1))*DTE
+!         VVLOU=PVVLOU/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPU)
+!         VVLOV=PVVLOV/(DETA1_PDTOP(KTE)+DETA2(KTE)*PDOPV)
+!         TULO=VVLOU*(U(I,J,KTE-1)-U(I,J,KTE)+UN(KTE-1)-UN(KTE))
+!         TVLO=VVLOV*(V(I,J,KTE-1)-V(I,J,KTE)+VN(KTE-1)-VN(KTE))
+!         ADUP=TULO+UN(KTE)-U(I,J,KTE)
+!         ADVP=TVLO+VN(KTE)-V(I,J,KTE)
+!         WRITE(0,*)' NTSD=',NTSD,' I=',I,' J=',J,' K=',KTE             &
+!    &,             ' ADUP=',ADUP,' ADVP=',ADVP
+!         WRITE(0,*)' U=',U(I,J,KTE),' UN=',UN(KTE)                     &
+!    &,             ' VAD_TEND_U=',VAD_TEND_U(I,KTE)                    &
+!    &,             ' V=',V(I,J,KTE),' VN=',VN(KTE)                     &
+!    &,             ' VAD_TEND_V=',VAD_TEND_V(I,KTE)
+!         WRITE(0,*)' '
+!!
+!         DO K=KTE-1,KTS+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),J,K-1)                               &
+!    &            +PETDT(I+IVE(J),J,K-1))*DTE
+!           PVVLOV=(PETDT(I,J-1,K-1)+PETDT(I,J+1,K-1))*DTE
+!           VVUPU=PVVUPU*RDPU
+!           VVUPV=PVVUPV*RDPV
+!           VVLOU=PVVLOU*RDPU
+!           VVLOV=PVVLOV*RDPV
+!           TUUP=VVUPU*(U(I,J,K)-U(I,J,K+1)+UN(K)-UN(K+1))
+!           TVUP=VVUPV*(V(I,J,K)-V(I,J,K+1)+VN(K)-VN(K+1))
+!           TULO=VVLOU*(U(I,J,K-1)-U(I,J,K)+UN(K-1)-UN(K))
+!           TVLO=VVLOV*(V(I,J,K-1)-V(I,J,K)+VN(K-1)-VN(K))
+!           ADUP=TUUP+TULO+UN(K)-U(I,J,K)
+!           ADVP=TVUP+TVLO+VN(K)-V(I,J,K)
+!           WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',K     &
+!    &,               ' ADUP=',ADUP,' ADVP=',ADVP
+!           WRITE(0,*)' U=',U(I,J,K),' UN=',UN(K)                       &
+!    &,               ' VAD_TEND_U=',VAD_TEND_U(I,K)                    &
+!    &,               ' V=',V(I,J,K),' VN=',VN(K)                       &
+!    &,               ' VAD_TEND_V=',VAD_TEND_V(I,K)
+!           WRITE(0,*)' '
+!         ENDDO
+!!
+!         PVVUPU=PVVLOU
+!         PVVUPV=PVVLOV
+!         VVUPU=PVVUPU/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPU)
+!         VVUPV=PVVUPV/(DETA1_PDTOP(KTS)+DETA2(KTS)*PDOPV)
+!         TUUP=VVUPU*(U(I,J,KTS)-U(I,J,KTS+1)+UN(KTS)-UN(KTS+1))
+!         TVUP=VVUPV*(V(I,J,KTS)-V(I,J,KTS+1)+VN(KTS)-VN(KTS+1))
+!         ADUP=TUUP+UN(KTS)-U(I,J,KTS)
+!         ADVP=TVUP+VN(KTS)-V(I,J,KTS)
+!         WRITE(0,*)' NTSD=',NTSD,' I=',ITEST,' J=',JTEST,' K=',KTS     &
+!    &,             ' ADUP=',ADUP,' ADVP=',ADVP
+!         WRITE(0,*)' U=',U(I,J,KTS),' UN=',UN(KTS)                     &
+!    &,             ' VAD_TEND_U=',VAD_TEND_U(I,KTS)                    &
+!    &,             ' V=',V(I,J,KTS),' VN=',VN(KTS)                     &
+!    &,             ' VAD_TEND_V=',VAD_TEND_V(I,KTS)
+!         WRITE(0,*)' '
+!       ENDIF
+!     endif
+!
+!-----------------------------------------------------------------------
+!***  End of check.
+!-----------------------------------------------------------------------
+!
+        ENDDO iloop_for_uv
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO main_vertical
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!***  COMPUTE HORIZONTAL ADVECTION TENDENCIES.
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(adpdx,adpdy,adt,adu,adv,array0,array1,array2,array3      &
+!$omp&        ,array3_x,dpde,f0,f1,f2,f3,fewp,fnep,fnsp,fpp,fsep,hm     &
+!$omp&        ,i,ifp,ifq,ii,ipq,isp,ispa,isq,isqa,iup_adh_j,j,k         &
+!$omp&        ,knti_adh,n_iupadh_j,n_iupadv_j,n_iuph_j,pp,qp            &
+!$omp&        ,rdpd,rdpdx,rdpdy,tew,tne,tns,tse,tst,tta,ttb             &
+!$omp&        ,uew,udy,une,uned,uns,use,used,ust                        &
+!$omp&        ,vdx,vew,vm,vne,vns,vse,vst)
+!-----------------------------------------------------------------------
+!
+      main_horizontal: DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS_P4,MYJE_P4
+        DO I=MYIS_P4,MYIE_P4
+          DPDE(I,J)=DETA1_PDTOP(K)+DETA2(K)*PDSLO(I,J)
+          RDPD(I,J)=1./DPDE(I,J)
+          TST(I,J)=T(I,J,K)*FFC+TOLD(I,J,K)*FBC
+          UST(I,J)=U(I,J,K)*FFC+UOLD(I,J,K)*FBC
+          VST(I,J)=V(I,J,K)*FFC+VOLD(I,J,K)*FBC
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  MASS FLUXES AND MASS POINT ADVECTION COMPONENTS
+!***  THE NS AND EW FLUXES IN THE FOLLOWING LOOP ARE ON V POINTS
+!***  FOR T.
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS1_P3,MYJE1_P3
+        DO I=MYIS_P3,MYIE_P3
+!
+          ADPDX=DPDE(I+IVW(J),J)+DPDE(I+IVE(J),J)
+          ADPDY=DPDE(I,J-1)+DPDE(I,J+1)
+          RDPDX(I,J)=1./ADPDX
+          RDPDY(I,J)=1./ADPDY
+!
+          UDY=U(I,J,K)*DY
+          VDX=V(I,J,K)*DX(I,J)
+!
+          FEWP=UDY*ADPDX
+          FNSP=VDX*ADPDY
+!
+          FEW(I,J,K)=FEWP
+          FNS(I,J,K)=FNSP
+!
+          TEW(I,J)=FEWP*(TST(I+IVE(J),J)-TST(I+IVW(J),J))
+          TNS(I,J)=FNSP*(TST(I,J+1)-TST(I,J-1))
+!
+          UNED(I,J)=UDY+VDX
+          USED(I,J)=UDY-VDX
+!
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND
+!***  THE NE AND SE FLUXES ARE ASSOCIATED WITH H POINTS
+!***  (ACTUALLY JUST TO THE NE AND SE OF EACH H POINT).
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS1_P2,MYJE2_P2
+        DO I=MYIS_P2,MYIE_P2
+          FNEP=(UNED(I+IHE(J),J)+UNED(I       ,J+1))                    &
+     &        *(DPDE(I       ,J)+DPDE(I+IHE(J),J+1))
+          FNE(I,J,K)=FNEP
+          TNE(I,J)=FNEP*(TST(I+IHE(J),J+1)-TST(I,J))
+        ENDDO
+        ENDDO
+!
+        DO J=MYJS2_P2,MYJE1_P2
+        DO I=MYIS_P2,MYIE_P2
+          FSEP=(USED(I+IHE(J),J)+USED(I       ,J-1))                    &
+     &        *(DPDE(I       ,J)+DPDE(I+IHE(J),J-1))
+          FSE(I,J,K)=FSEP
+          TSE(I,J)=FSEP*(TST(I+IHE(J),J-1)-TST(I,J))
+!
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  HORIZONTAL T ADVECTION TENDENCY ADT IS ON H POINTS OF COURSE.
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS5,MYJE5
+        DO I=MYIS2,MYIE2
+          ADT(I,J)=(TEW(I+IHW(J),J)+TEW(I+IHE(J),J)                     &
+     &             +TNS(I,J-1)+TNS(I,J+1)                               &
+     &             +TNE(I+IHW(J),J-1)+TNE(I,J)                          &
+     &             +TSE(I,J)+TSE(I+IHW(J),J+1))                         &
+     &             *RDPD(I,J)*FAD(I,J)
+        ENDDO
+        ENDDO
+!
+!
+!-----------------------------------------------------------------------
+!***  CALCULATION OF MOMENTUM ADVECTION COMPONENTS.
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS4_P1,MYJE4_P1
+        DO I=MYIS_P1,MYIE_P1
+!
+!-----------------------------------------------------------------------
+!***  THE NS AND EW FLUXES ARE ON H POINTS FOR U AND V.
+!-----------------------------------------------------------------------
+!
+          UEW(I,J)=(FEW(I+IHW(J),J,K)+FEW(I+IHE(J),J,K))                &
+     &            *(UST(I+IHE(J),J)-UST(I+IHW(J),J))
+          UNS(I,J)=(FNS(I+IHW(J),J,K)+FNS(I+IHE(J),J,K))                &
+     &            *(UST(I,J+1)-UST(I,J-1))
+          VEW(I,J)=(FEW(I,J-1,K)+FEW(I,J+1,K))                          &
+     &            *(VST(I+IHE(J),J)-VST(I+IHW(J),J))
+          VNS(I,J)=(FNS(I,J-1,K)+FNS(I,J+1,K))                          &
+     &            *(VST(I,J+1)-VST(I,J-1))
+!
+!-----------------------------------------------------------------------
+!***  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,J)=(FNE(I+IVW(J),J,K)+FNE(I+IVE(J),J,K))                &
+     &            *(UST(I+IVE(J),J+1)-UST(I,J))
+          USE(I,J)=(FSE(I+IVW(J),J,K)+FSE(I+IVE(J),J,K))                &
+     &            *(UST(I+IVE(J),J-1)-UST(I,J))
+          VNE(I,J)=(FNE(I,J-1,K)+FNE(I,J+1,K))                          &
+     &            *(VST(I+IVE(J),J+1)-VST(I,J))
+          VSE(I,J)=(FSE(I,J-1,K)+FSE(I,J+1,K))                          &
+     &            *(VST(I+IVE(J),J-1)-VST(I,J))
+!
+!-----------------------------------------------------------------------
+!
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  COMPUTE THE ADVECTION TENDENCIES FOR U AND V.
+!***  THE AD ARRAYS ARE ON THE VELOCITY POINTS.
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS5,MYJE5
+        DO I=MYIS2,MYIE2
+          ADU(I,J)=(UEW(I+IVW(J),J)+UEW(I+IVE(J),J)                     &
+     &             +UNS(I,J-1)+UNS(I,J+1)                               &
+     &             +UNE(I+IVW(J),J-1)+UNE(I,J)                          &
+     &             +USE(I,J)+USE(I+IVW(J),J+1))                         &
+     &             *RDPDX(I,J)*FAD(I+IVW(J),J)
+!
+          ADV(I,J)=(VEW(I+IVW(J),J)+VEW(I+IVE(J),J)                     &
+     &             +VNS(I,J-1)+VNS(I,J+1)                               &
+     &             +VNE(I+IVW(J),J-1)+VNE(I,J)                          &
+     &             +VSE(I,J)+VSE(I+IVW(J),J+1))                         &
+     &             *RDPDY(I,J)*FAD(I+IVW(J),J)
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+!***  END OF JANJIC HORIZONTAL ADVECTION
+!
+!-----------------------------------------------------------------------
+!
+!***  UPSTREAM ADVECTION OF T
+!
+!-----------------------------------------------------------------------
+!
+        upstream: IF(UPSTRM)THEN
+!
+!-----------------------------------------------------------------------
+!***
+!***  COMPUTE UPSTREAM COMPUTATIONS ON THIS TASK'S ROWS.
+!***
+!-----------------------------------------------------------------------
+!
+          jloop_upstream: DO J=MYJS2,MYJE2
+!
+            N_IUPH_J=N_IUP_H(J)   ! See explanation in START_DOMAIN_NMM
+            DO II=0,N_IUPH_J-1
+!
+              I=IUP_H(IMS+II,J)
+              TTA=EMT_LOC(J)*(UST(I,J-1)+UST(I+IHW(J),J)                &
+     &                       +UST(I+IHE(J),J)+UST(I,J+1))
+              TTB=ENT       *(VST(I,J-1)+VST(I+IHW(J),J)                &
+     &                       +VST(I+IHE(J),J)+VST(I,J+1))
+              PP=-TTA-TTB
+              QP= TTA-TTB
+!
+              IF(PP<0.)THEN
+                ISPA(I,J)=-1
+              ELSE
+                ISPA(I,J)= 1
+              ENDIF
+!
+              IF(QP<0.)THEN
+                ISQA(I,J)=-1
+              ELSE
+                ISQA(I,J)= 1
+              ENDIF
+!
+              PP=ABS(PP)
+              QP=ABS(QP)
+              ARRAY3_X=PP*QP
+              ARRAY0(I,J)=ARRAY3_X-PP-QP
+              ARRAY1(I,J)=PP-ARRAY3_X
+              ARRAY2(I,J)=QP-ARRAY3_X
+              ARRAY3(I,J)=ARRAY3_X
+            ENDDO
+!
+!-----------------------------------------------------------------------
+!
+            N_IUPADH_J=N_IUP_ADH(J)
+            KNTI_ADH=1
+            IUP_ADH_J=IUP_ADH(IMS,J)
+!
+            iloop_T: DO II=0,N_IUPH_J-1
+!
+              I=IUP_H(IMS+II,J)
+!
+              ISP=ISPA(I,J)
+              ISQ=ISQA(I,J)
+              IFP=(ISP-1)/2
+              IFQ=(-ISQ-1)/2
+              IPQ=(ISP-ISQ)/2
+!
+!-----------------------------------------------------------------------
+!
+              IF(I==IUP_ADH_J)THEN  ! Upstream advection T tendencies
+!
+                ISP=ISPA(I,J)
+                ISQ=ISQA(I,J)
+                IFP=(ISP-1)/2
+                IFQ=(-ISQ-1)/2
+                IPQ=(ISP-ISQ)/2
+!
+                F0=ARRAY0(I,J)
+                F1=ARRAY1(I,J)
+                F2=ARRAY2(I,J)
+                F3=ARRAY3(I,J)
+!
+                ADT(I,J)=F0*T(I,J,K)                                    &
+     &                  +F1*T(I+IHE(J)+IFP,J+ISP,K)                     &
+     &                  +F2*T(I+IHE(J)+IFQ,J+ISQ,K)                     &
+                        +F3*T(I+IPQ,J+ISP+ISQ,K)
+!
+!-----------------------------------------------------------------------
+!
+                IF(KNTI_ADH<N_IUPADH_J)THEN
+                  IUP_ADH_J=IUP_ADH(IMS+KNTI_ADH,J)
+                  KNTI_ADH=KNTI_ADH+1
+                ENDIF
+!
+              ENDIF  ! End of upstream advection T tendency IF block
+!
+            ENDDO iloop_T
+!
+!-----------------------------------------------------------------------
+!
+!***  UPSTREAM ADVECTION OF VELOCITY COMPONENTS
+!
+!-----------------------------------------------------------------------
+!
+            N_IUPADV_J=N_IUP_ADV(J)
+!
+            DO II=0,N_IUPADV_J-1
+              I=IUP_ADV(IMS+II,J)
+!
+              TTA=EM_LOC(J)*UST(I,J)
+              TTB=EN       *VST(I,J)
+              PP=-TTA-TTB
+              QP=TTA-TTB
+!
+              IF(PP<0.)THEN
+                ISP=-1
+              ELSE
+                ISP= 1
+              ENDIF
+!
+              IF(QP<0.)THEN
+                ISQ=-1
+              ELSE
+                ISQ= 1
+              ENDIF
+!
+              IFP=(ISP-1)/2
+              IFQ=(-ISQ-1)/2
+              IPQ=(ISP-ISQ)/2
+              PP=ABS(PP)
+              QP=ABS(QP)
+              F3=PP*QP
+              F0=F3-PP-QP
+              F1=PP-F3
+              F2=QP-F3
+!
+              ADU(I,J)=F0*U(I,J,K)                                      &
+     &                +F1*U(I+IVE(J)+IFP,J+ISP,K)                       &
+     &                +F2*U(I+IVE(J)+IFQ,J+ISQ,K)                       &
+     &                +F3*U(I+IPQ,J+ISP+ISQ,K)
+!
+              ADV(I,J)=F0*V(I,J,K)                                      &
+     &                +F1*V(I+IVE(J)+IFP,J+ISP,K)                       &
+     &                +F2*V(I+IVE(J)+IFQ,J+ISQ,K)                       &
+     &                +F3*V(I+IPQ,J+ISP+ISQ,K)
+!
+            ENDDO
+!
+          ENDDO jloop_upstream
+!
+!-----------------------------------------------------------------------
+!
+        ENDIF upstream
+!
+!-----------------------------------------------------------------------
+!
+!***  END OF HORIZONTAL ADVECTION
+!
+!-----------------------------------------------------------------------
+!
+!***  NOW SUM THE VERTICAL AND HORIZONTAL TENDENCIES,
+!***  CURVATURE AND CORIOLIS TERMS.
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+          HM=HBM2(I,J)
+          VM=VBM2(I,J)
+          ADT(I,J)=(VAD_TEND_T(I,J,K)+2.*ADT(I,J))*HM
+!
+          FPP=CURV(I,J)*2.*UST(I,J)+F(I,J)*2.
+          ADU(I,J)=(VAD_TEND_U(I,J,K)+2.*ADU(I,J)+VST(I,J)*FPP)*VM
+          ADV(I,J)=(VAD_TEND_V(I,J,K)+2.*ADV(I,J)-UST(I,J)*FPP)*VM
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  SAVE THE OLD VALUES FOR TIMESTEPPING
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS_P4,MYJE_P4
+        DO I=MYIS_P4,MYIE_P4
+          TOLD(I,J,K)=T(I,J,K)
+          UOLD(I,J,K)=U(I,J,K)
+          VOLD(I,J,K)=V(I,J,K)
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  FINALLY UPDATE THE PROGNOSTIC VARIABLES
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+          T(I,J,K)=ADT(I,J)+T(I,J,K)
+          U(I,J,K)=ADU(I,J)+U(I,J,K)
+          V(I,J,K)=ADV(I,J)+V(I,J,K)
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO main_horizontal
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE ADVE
+!
+!-----------------------------------------------------------------------
+!
+!***********************************************************************
+      SUBROUTINE VAD2(NTSD,DT,IDTAD,DX,DY                               &
+     &               ,AETA1,AETA2,DETA1,DETA2,PDSL,PDTOP,HBM2           &
+     &               ,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                                   &
+     &               ,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
+!   05-12-14  BLACK    - CONVERTED FROM IKJ TO IJK
+!   07-08-14  janjic   - bc & no conservation in the advection step
+!
+! 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
+!
+      INTEGER,INTENT(IN) :: IDTAD,NTSD
+!
+      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,JMS:JME,KMS:KME),INTENT(IN) :: PETDT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM,Q,Q2
+!
+!***  LOCAL VARIABLES
+!----------------------------------------------------------------------
+!
+      REAL,PARAMETER :: FF1=0.500
+!
+      LOGICAL,SAVE :: TRADITIONAL=.TRUE.
+!
+      INTEGER :: I,IRECV,J,JFP,JFQ,K,LAP,LLAP
+!
+      INTEGER,DIMENSION(KTS:KTE) :: LA
+!
+      REAL*8 :: ADDT,AFRP,D2PQE,D2PQQ,D2PQW,DEP,DETAP,DQP               &
+     &       ,DWP,E00,E4P,EP,EP0,HADDT,HBM2IJ                           &
+     &       ,Q00,Q4P,QP,QP0                                            &
+     &       ,rdpdn,rdpup,sfacek,sfacqk,sfacwk,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         &
+!$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
+!
+!-----------------------------------------------------------------------
+!
+        main_iloop: DO I=MYIS1_P1,MYIE1_P1
+!
+!-----------------------------------------------------------------------
+!
+          E3(KTE)=Q2(I,J,KTE)*0.5
+!
+          DO K=KTE-1,KTS,-1
+            E3(K)=MAX((Q2(I,J,K+1)+Q2(I,J,K))*0.5,EPSQ2)
+          ENDDO
+!
+          DO K=KTS,KTE
+            Q3(K)=MAX(Q(I,J,K),EPSQ)
+            W3(K)=MAX(CWM(I,J,K),CLIMIT)
+            E4(K)=E3(K)
+            Q4(K)=Q3(K)
+            W4(K)=W3(K)
+          ENDDO
+!
+          IF(TRADITIONAL)THEN
+            PETDTK(KTE)=PETDT(I,J,KTE-1)*0.5
+!
+            DO K=KTE-1,KTS+1,-1
+              PETDTK(K)=(PETDT(I,J,K)+PETDT(I,J,K-1))*0.5
+            ENDDO
+!
+            PETDTK(KTS)=PETDT(I,J,KTS)*0.5
+!
+          ELSE
+!
+!-----------------------------------------------------------------------
+!***    PERFORM HORIZONTAL AVERAGING OF VERTICAL VELOCITY
+!-----------------------------------------------------------------------
+!
+            PETDTK(KTE)=(PETDT(I+IHW(J-1),J-1,KTE-1)                    &
+     &                  +PETDT(I+IHE(J-1),J-1,KTE-1)                    &
+     &                  +PETDT(I+IHW(J+1),J+1,KTE-1)                    &
+     &                  +PETDT(I+IHE(J+1),J+1,KTE-1)                    &
+     &                  +PETDT(I,J,KTE-1)*4.        )*0.0625
+!
+            DO K=KTE-1,KTS+1,-1
+              PETDTK(K)=(PETDT(I+IHW(J-1),J-1,K-1)                      &
+                        +PETDT(I+IHE(J-1),J-1,K-1)                      &
+     &                  +PETDT(I+IHW(J+1),J+1,K-1)                      &
+     &                  +PETDT(I+IHE(J+1),J+1,K-1)                      &
+     &                  +PETDT(I+IHW(J-1),J-1,K  )                      &
+     &                  +PETDT(I+IHE(J-1),J-1,K  )                      &
+     &                  +PETDT(I+IHW(J+1),J+1,K  )                      &
+     &                  +PETDT(I+IHE(J+1),J+1,K  )                      &
+     &                  +(PETDT(I,J,K-1)+PETDT(I,J,K))*4.               &
+     &                                                   )*0.0625
+            ENDDO
+!
+            PETDTK(KTS)=(PETDT(I+IHW(J-1),J-1,KTS)                      &
+     &                  +PETDT(I+IHE(J-1),J-1,KTS)                      &
+     &                  +PETDT(I+IHW(J+1),J+1,KTS)                      &
+     &                  +PETDT(I+IHE(J+1),J+1,KTS)                      &
+     &                  +PETDT(I,J,KTS)*4.        )*0.0625
+
+          ENDIF
+!
+!-----------------------------------------------------------------------
+!
+          HADDT=-ADDT*HBM2(I,J)
+!
+          DO K=KTE,KTS,-1
+            RR=PETDTK(K)*HADDT
+!
+            IF(RR<0.)THEN
+              LAP=1
+            ELSE
+              LAP=-1
+            ENDIF
+!
+            LA(K)=LAP
+            LLAP=K+LAP
+!
+            if(llap.gt.kts-1.and.llap.lt.kte+1) then ! internal and outflow pts.
+              rr=abs(rr &
+     &          /((aeta1(llap)-aeta1(k))*pdtop &
+     &           +(aeta2(llap)-aeta2(k))*pdsl(i,j)))
+              if(rr.gt.0.999) rr=0.999   
+!
+              AFR(K)=(((FF4*RR+FF3)*RR+FF2)*RR+FF1)*RR
+              dql(k)=(q3(llap)-q3(k))*rr
+              dwl(k)=(w3(llap)-w3(k))*rr
+              del(k)=(e3(llap)-e3(k))*rr
+            elseif(llap.eq.kts-1) then
+!
+!chem              rr=abs(rr &
+!chem                /((1.-aeta2(kts))*pdsl(i,j)))
+!chem              afr(kts)=0.
+!chem              dql(kts)=(epsq  -q3(kts))*rr
+!chem              dwl(kts)=(climit-w3(kts))*rr
+!chem              del(kts)=(epsq2 -e3(kts))*rr
+!
+              rr=0.
+              afr(kts)=0.
+              dql(kts)=0.
+              dwl(kts)=0.
+              del(kts)=0.
+            else
+              rr=abs(rr &
+                /(aeta1(kte)*pdtop))
+              afr(kte)=0.
+              dql(kte)=(epsq  -q3(kte))*rr
+              dwl(kte)=(climit-w3(kte))*rr
+              del(kte)=(epsq2 -e3(kte))*rr
+            endif
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!
+          DO K=KTS,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
+!
+          antifilter: DO K=KTE-1,KTS+1,-1
+!
+            DETAP=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+!
+            DQL(K)=0.
+            DWL(K)=0.
+            DEL(K)=0.
+!
+            Q4P=Q4(K)
+            W4P=W4(K)
+            E4P=E4(K)
+!
+            LAP=LA(K)
+!
+            if(lap.ne.0)then
+              rdpdn=1./((aeta1(k+lap)-aeta1(k))*pdtop &
+     &                 +(aeta2(k+lap)-aeta2(k))*pdsl(i,j))
+              rdpup=1./((aeta1(k)-aeta1(k-lap))*pdtop &
+     &                 +(aeta2(k)-aeta2(k-lap))*pdsl(i,j))
+!
+              afrp=afr(k)*detap
+!
+              d2pqq=((q4(k+lap)-q4p)*rdpdn &
+     &              -(q4p-q4(k-lap))*rdpup)*afrp
+              d2pqw=((w4(k+lap)-w4p)*rdpdn &
+     &              -(w4p-w4(k-lap))*rdpup)*afrp
+              d2pqe=((e4(k+lap)-e4p)*rdpdn &
+     &              -(e4p-e4(k-lap))*rdpup)*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-q4p
+            dwp=wp-w4p
+            dep=ep-e4p
+!
+            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
+!
+          ENDDO antifilter
+!
+!-----------------------------------------------------------------------
+!
+          DQL(KTS)=0.
+          DWL(KTS)=0.
+          DEL(KTS)=0.
+!
+          DQL(KTE)=0.
+          DWL(KTE)=0.
+          DEL(KTE)=0.
+!
+!-----------------------------------------------------------------------
+!***  FIRST MOMENT CONSERVING FACTOR
+!-----------------------------------------------------------------------
+!
+          if(sumpq*(-sumnq).gt.1.e-9) then
+            sfacqk=-sumnq/sumpq
+          else
+            sfacqk=0.
+          endif
+!
+          if(sumpw*(-sumnw).gt.1.e-9) then
+            sfacwk=-sumnw/sumpw
+          else
+            sfacwk=0.
+          endif
+!
+          if(sumpe*(-sumne).gt.1.e-9) then
+            sfacek=-sumne/sumpe
+          else
+            sfacek=0.
+          endif
+!
+!-----------------------------------------------------------------------
+!***  IMPOSE CONSERVATION ON ANTI-FILTERING
+!-----------------------------------------------------------------------
+!
+          DO K=KTE,KTS,-1
+!
+            dqp=dql(k)
+            if(sfacqk.gt.0.) then
+              if(sfacqk.ge.1.) then
+                if(dqp.lt.0.) dqp=dqp/sfacqk
+              else
+                if(dqp.gt.0.) dqp=dqp*sfacqk
+              endif
+            else
+              dqp=0.
+            endif
+            q  (i,j,k)=q4(k)+dqp
+!
+            dwp=dwl(k)
+            if(sfacwk.gt.0.) then
+              if(sfacwk.ge.1.) then
+                if(dwp.lt.0.) dwp=dwp/sfacwk
+              else
+                if(dwp.gt.0.) dwp=dwp*sfacwk
+              endif
+            else
+              dwp=0.
+            endif
+            cwm(i,j,k)=w4(k)+dwp
+!
+            dep=del(k)
+            if(sfacek.gt.0.) then
+              if(sfacek.ge.1.) then
+                if(dep.lt.0.) dep=dep/sfacek
+              else
+                if(dep.gt.0.) dep=dep*sfacek
+              endif
+            else
+              dep=0.
+            endif
+            e3 (    k)=e4(k)+dep
+!
+          ENDDO
+!-----------------------------------------------------------------------
+          HBM2IJ=HBM2(I,J)
+          Q2(I,J,KTE)=MAX(E3(KTE)+E3(KTE)-EPSQ2,EPSQ2)*HBM2IJ           &
+       &             +Q2(I,J,KTE)*(1.-HBM2IJ)
+          DO K=KTE-1,KTS+1,-1
+            Q2(I,J,K)=MAX(E3(K)+E3(K)-Q2(I,J,K+1),EPSQ2)*HBM2IJ         &
+       &             +Q2(I,J,K)*(1.-HBM2IJ)
+          ENDDO
+!-----------------------------------------------------------------------
+!
+        ENDDO main_iloop
+!
+!-----------------------------------------------------------------------
+!
+      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                &
+     &               ,HBM2,HBM3                                         &
+     &               ,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                                   &
+     &               ,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
+!   05-12-14  BLACK    - CONVERTED FROM IKJ TO IJK
+!   07-08-14  janjic   - no conservation in advection step
+!
+! 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
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDTAD,NTSD
+!
+      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,JMS:JME,KMS:KME),INTENT(IN) :: U,V,Z
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),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) && !defined(STUBMPI)
+      LOGICAL,EXTERNAL :: WRF_DM_ON_MONITOR
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,6) :: XSUMS_L
+      REAL,DIMENSION(IDS:IDE,JDS:JDE,KDS:KDE,6) :: XSUMS_G
+#endif
+!
+      LOGICAL :: BOT,TOP
+!
+      INTEGER :: I,IRECV,J,JFP,JFQ,K,LAP,LLAP,MPI_COMM_COMP
+      INTEGER :: N
+!
+      INTEGER,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5,KTS:KTE) :: 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,PP,PPQ00,Q00,Q0Q            &
+     &       ,Q1IJ,Q4P,QP,QP0,QSTIJ,RDY,RFACE,RFACQ,RFACW,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,KTS:KTE) :: GSUMS,XSUMS
+!
+      REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,E3,E4                  &
+     &                          ,Q3,Q4,W3,W4
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: DARE,EMH
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5,KTS:KTE) :: 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,J,KTE)=MAX(Q2(I,J,KTE)*0.5,EPSQ2)
+        E2(I,J,KTE)=E1(I,J,KTE)
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dza,dzb,e1x,fpq,hm,i,j,jfp,jfq,k,pp,qp,ssa,ssb,spp,sqp   &
+!$omp&        ,tta,ttb)
+!-----------------------------------------------------------------------
+!
+      vertical_1: DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS_P3,MYJE_P3
+        DO I=MYIS_P2,MYIE_P2
+          DVOL(I,J,K)=DARE(I,J)*(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))
+          Q  (I,J,K)=MAX(Q  (I,J,K),EPSQ)
+          CWM(I,J,K)=MAX(CWM(I,J,K),CLIMIT)
+          Q1 (I,J,K)=Q  (I,J,K)
+          W1 (I,J,K)=CWM(I,J,K)
+        ENDDO
+        ENDDO
+!
+        IF(K<KTE)THEN
+          DO J=MYJS_P3,MYJE_P3
+          DO I=MYIS_P2,MYIE_P2
+            E1X=(Q2(I,J,K+1)+Q2(I,J,K))*0.5
+            E1(I,J,K)=MAX(E1X,EPSQ2)
+            E2(I,J,K)=E1(I,J,K)
+          ENDDO
+          ENDDO
+        ENDIF
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS2_P1,MYJE2_P1
+        DO I=MYIS1_P1,MYIE1_P1
+!
+          HM=HBM2(I,J)
+          TTA=(U(I,J-1,K)+U(I+IHW(J),J,K)+U(I+IHE(J),J,K)+U(I,J+1,K))   &
+     &        *EMH(I,J)*HM
+          TTB=(V(I,J-1,K)+V(I+IHW(J),J,K)+V(I+IHE(J),J,K)+V(I,J+1,K))   &
+     &        *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,J,K)=IHE(J)+I+( JFP-1)/2
+          IFQA(I,J,K)=IHE(J)+I+(-JFQ-1)/2
+!
+          JFPA(I,J,K)=J+JFP
+          JFQA(I,J,K)=J+JFQ
+!
+          IFPF(I,J,K)=IHE(J)+I+(-JFP-1)/2
+          IFQF(I,J,K)=IHE(J)+I+( JFQ-1)/2
+!
+          JFPF(I,J,K)=J-JFP
+          JFQF(I,J,K)=J-JFQ
+!     if(i==111.and.j==438.and.k==1)then
+!     endif
+!
+!-----------------------------------------------------------------------
+          IF(.NOT.HYDRO)THEN ! z currently not available for hydro=.true.
+            DZA=(Z(IFPA(I,J,K),JFPA(I,J,K),K)-Z(I,J,K))*RDY
+            DZB=(Z(IFQA(I,J,K),JFQA(I,J,K),K)-Z(I,J,K))*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
+!
+!-----------------------------------------------------------------------
+!
+          FPQ=SPP*SQP*0.25
+          PP=ABS(SPP)
+          QP=ABS(SQP)
+!
+          AFP(I,J,K)=(((FF4*PP+FF3)*PP+FF2)*PP+FF1)*PP
+          AFQ(I,J,K)=(((FF4*QP+FF3)*QP+FF2)*QP+FF1)*QP
+!
+          Q1(I,J,K)=(Q  (IFPA(I,J,K),JFPA(I,J,K),K)-Q  (I,J,K))*PP        &
+       &           +(Q  (IFQA(I,J,K),JFQA(I,J,K),K)-Q  (I,J,K))*QP        &
+       &           +(Q  (I,J-2,K)+Q  (I,J+2,K)                            &
+       &            -Q  (I-1,J,K)-Q  (I+1,J,K))*FPQ                       &
+       &           +Q(I,J,K)
+!
+          W1(I,J,K)=(CWM(IFPA(I,J,K),JFPA(I,J,K),K)-CWM(I,J,K))*PP        &
+       &           +(CWM(IFQA(I,J,K),JFQA(I,J,K),K)-CWM(I,J,K))*QP        &
+       &           +(CWM(I,J-2,K)+CWM(I,J+2,K)                            &
+       &            -CWM(I-1,J,K)-CWM(I+1,J,K))*FPQ                       &
+       &           +CWM(I,J,K)
+!
+          E2(I,J,K)=(E1 (IFPA(I,J,K),JFPA(I,J,K),K)-E1 (I,J,K))*PP        &
+       &           +(E1 (IFQA(I,J,K),JFQA(I,J,K),K)-E1 (I,J,K))*QP        &
+       &           +(E1 (I,J-2,K)+E1 (I,J+2,K)                            &
+       &            -E1 (I-1,J,K)-E1 (I+1,J,K))*FPQ                       &
+       &           +E1(I,J,K)
+!
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO vertical_1
+!
+!-----------------------------------------------------------------------
+!***  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) && !defined(STUBMPI)
+      DO N=1,6
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO K=KMS,KME 
+        DO J=JMS,JME 
+        DO I=IMS,IME 
+          XSUMS_L(I,J,K,N)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO K=KDS,KDE 
+        DO J=JDS,JDE 
+        DO I=IDS,IDE 
+          XSUMS_G(I,J,K,N)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+#endif
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(d2pqe,d2pqq,d2pqw,destij,dqstij,dvolp,dwstij             &
+!$omp&        ,e00,e0q,e2ij,ep0,estij,hafp,hafq,i,j,k                   &
+!$omp&        ,q00,q0q,q1ij,qp0,qstij,w00,w0q,w1ij,wp0,wstij)
+!-----------------------------------------------------------------------
+!
+      vertical_2: DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+!
+          DVOLP=DVOL(I,J,K)
+          Q1IJ =Q1(I,J,K)
+          W1IJ =W1(I,J,K)
+          E2IJ =E2(I,J,K)
+!
+          HAFP=AFP(I,J,K)
+          HAFQ=AFQ(I,J,K)
+!
+          D2PQQ=(Q1(IFPA(I,J,K),JFPA(I,J,K),K)-Q1IJ                     &
+     &          -Q1IJ+Q1(IFPF(I,J,K),JFPF(I,J,K),K))                    &
+     &          *HAFP                                                   &
+     &         +(Q1(IFQA(I,J,K),JFQA(I,J,K),K)-Q1IJ                     &
+     &          -Q1IJ+Q1(IFQF(I,J,K),JFQF(I,J,K),K))                    &
+     &          *HAFQ
+!
+          D2PQW=(W1(IFPA(I,J,K),JFPA(I,J,K),K)-W1IJ                     &
+     &          -W1IJ+W1(IFPF(I,J,K),JFPF(I,J,K),K))                    &
+     &          *HAFP                                                   &
+     &         +(W1(IFQA(I,J,K),JFQA(I,J,K),K)-W1IJ                     &
+     &          -W1IJ+W1(IFQF(I,J,K),JFQF(I,J,K),K))                    &
+     &          *HAFQ
+!
+          D2PQE=(E2(IFPA(I,J,K),JFPA(I,J,K),K)-E2IJ                     &
+     &          -E2IJ+E2(IFPF(I,J,K),JFPF(I,J,K),K))                    &
+     &          *HAFP                                                   &
+     &         +(E2(IFQA(I,J,K),JFQA(I,J,K),K)-E2IJ                     &
+     &          -E2IJ+E2(IFQF(I,J,K),JFQF(I,J,K),K))                    &
+     &          *HAFQ
+!
+          QSTIJ=Q1IJ-D2PQQ
+          WSTIJ=W1IJ-D2PQW
+          ESTIJ=E2IJ-D2PQE
+!
+          Q00=Q  (I          ,J          ,K)
+          QP0=Q  (IFPA(I,J,K),JFPA(I,J,K),K)
+          Q0Q=Q  (IFQA(I,J,K),JFQA(I,J,K),K)
+!
+          W00=CWM(I          ,J          ,K)
+          WP0=CWM(IFPA(I,J,K),JFPA(I,J,K),K)
+          W0Q=CWM(IFQA(I,J,K),JFQA(I,J,K),K)
+!
+          E00=E1 (I          ,J          ,K)
+          EP0=E1 (IFPA(I,J,K),JFPA(I,J,K),K)
+          E0Q=E1 (IFQA(I,J,K),JFQA(I,J,K),K)
+!
+          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,J,K)
+!          DWSTIJ=WSTIJ-CWM(I,J,K)
+!          DESTIJ=ESTIJ-E1(I,J,K)
+!
+          dqstij=qstij-q1(i,j,k)
+          dwstij=wstij-w1(i,j,k)
+          destij=estij-e2(i,j,k)
+!
+          DQST(I,J,K)=DQSTIJ
+          DWST(I,J,K)=DWSTIJ
+          DEST(I,J,K)=DESTIJ
+!
+          DQSTIJ=DQSTIJ*DVOLP
+          DWSTIJ=DWSTIJ*DVOLP
+          DESTIJ=DESTIJ*DVOLP
+!
+!-----------------------------------------------------------------------
+#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL) && !defined(STUBMPI)
+!-----------------------------------------------------------------------
+          DO N=1,6
+            XSUMS_L(I,J,K,N)=0.
+          ENDDO
+!
+          IF(DQSTIJ>0.)THEN
+            XSUMS_L(I,J,K,1)=DQSTIJ
+          ELSE
+            XSUMS_L(I,J,K,2)=DQSTIJ
+          ENDIF
+!
+          IF(DWSTIJ>0.)THEN
+            XSUMS_L(I,J,K,3)=DWSTIJ
+          ELSE
+            XSUMS_L(I,J,K,4)=DWSTIJ
+          ENDIF
+!
+          IF(DESTIJ>0.)THEN
+            XSUMS_L(I,J,K,5)=DESTIJ
+          ELSE
+            XSUMS_L(I,J,K,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
+!-----------------------------------------------------------------------
+!
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO vertical_2
+!
+!-----------------------------------------------------------------------
+#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL) && !defined(STUBMPI)
+!-----------------------------------------------------------------------
+      DO N=1,6
+        CALL WRF_PATCH_TO_GLOBAL_REAL(XSUMS_L(IMS,JMS,KMS,N)            &
+     &,                               XSUMS_G(1,1,1,N),DOMDESC          & 
+     &,                              'xyz','xyz'                        &
+     &,                               IDS,IDE,JDS,JDE,KDS,KDE           &    
+     &,                               IMS,IME,JMS,JME,KMS,KME           &
+     &,                               ITS,ITE,JTS,JTE,KTS,KTE)
+      ENDDO
+!
+      DO K=KTS,KTE
+        DO N=1,6
+          GSUMS(N,K)=0.
+        ENDDO
+      ENDDO
+!
+      IF(WRF_DM_ON_MONITOR())THEN
+        DO N=1,6
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+          DO K=KTS,KTE
+          DO J=JDS,JDE
+          DO I=IDS,IDE
+            GSUMS(N,K)=GSUMS(N,K)+XSUMS_G(I,J,K,N)
+          ENDDO
+          ENDDO
+          ENDDO
+        ENDDO
+      ENDIF
+
+      CALL WRF_DM_BCAST_BYTES(GSUMS,2*RWORDSIZE*6*(KTE-KTS+1) )
+
+!-----------------------------------------------------------------------
+#else
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***  GLOBAL REDUCTION
+!-----------------------------------------------------------------------
+!
+# if defined(DM_PARALLEL) && !defined(STUBMPI)
+      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
+      DO K=KTS,KTE
+        DO N=1,6
+          GSUMS(N,K)=XSUMS(N,K)
+        ENDDO
+      ENDDO
+# 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
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(destij,dqstij,dwstij,i,j,k,rface,rfacq,rfacw             &
+!$omp&        ,rfeij,rfqij,rfwij,sumne,sumnq,sumnw,sumpe,sumpq,sumpw)
+!-----------------------------------------------------------------------
+!
+      vertical_3: DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!       if(mype==0)then
+!         write(nunit)(gsums(i,k),i=1,6)
+!       endif
+!!!     read(nunit)(gsums(i,k),i=1,6)
+!-----------------------------------------------------------------------
+!
+        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
+          RFACQ=-SUMNQ/SUMPQ
+        ELSE
+          RFACQ=1.
+        ENDIF
+!
+        IF(SUMPW>1.)THEN
+          RFACW=-SUMNW/SUMPW
+        ELSE
+          RFACW=1.
+        ENDIF
+!
+        IF(SUMPE>1.)THEN
+          RFACE=-SUMNE/SUMPE
+        ELSE
+          RFACE=1.
+        ENDIF
+!
+        IF(RFACQ<CONSERVE_MIN.OR.RFACQ>CONSERVE_MAX)RFACQ=1.
+        IF(RFACW<CONSERVE_MIN.OR.RFACW>CONSERVE_MAX)RFACW=1.
+        IF(RFACE<CONSERVE_MIN.OR.RFACE>CONSERVE_MAX)RFACE=1.
+!
+!-----------------------------------------------------------------------
+!       if(mype==0.and.ntsd==181)close(nunit)
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***  IMPOSE CONSERVATION ON ANTI-FILTERING
+!-----------------------------------------------------------------------
+!
+        if(rfacq<1.)then
+          do j=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+              DQSTIJ=DQST(I,J,K)
+              RFQIJ=HBM2(I,J)*(RFACQ-1.)+1.
+              IF(DQSTIJ>=0.)DQSTIJ=DQSTIJ*RFQIJ
+              q(i,j,k)=q1(i,j,k)+dqstij
+            ENDDO
+          enddo
+        else
+          do j=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+              DQSTIJ=DQST(I,J,K)
+              RFQIJ=HBM2(I,J)*(RFACQ-1.)+1.
+              IF(DQSTIJ<0.)DQSTIJ=DQSTIJ/RFQIJ
+              q(i,j,k)=q1(i,j,k)+dqstij
+            ENDDO
+          enddo
+        endif
+!
+!-----------------------------------------------------------------------
+!
+        if(rfacw<1.)then
+          do j=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+              DWSTIJ=DWST(I,J,K)
+              RFWIJ=HBM2(I,J)*(RFACW-1.)+1.
+              IF(DWSTIJ>=0.)DWSTIJ=DWSTIJ*RFWIJ
+              cwm(i,j,k)=w1(i,j,k)+dwstij
+            ENDDO
+          enddo
+        else
+          do j=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+              DWSTIJ=DWST(I,J,K)
+              RFWIJ=HBM2(I,J)*(RFACW-1.)+1.
+              IF(DWSTIJ<0.)DWSTIJ=DWSTIJ/RFWIJ
+              cwm(i,j,k)=w1(i,j,k)+dwstij
+            ENDDO
+          enddo
+        endif
+
+!-----------------------------------------------------------------------
+!
+        if(rface<1.)then
+          do j=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+              DESTIJ=DEST(I,J,K)
+              RFEIJ=HBM2(I,J)*(RFACE-1.)+1.
+              IF(DESTIJ>=0.)DESTIJ=DESTIJ*RFEIJ
+              e1(i,j,k)=e2(i,j,k)+destij
+            ENDDO
+          enddo
+        else
+          do j=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+              DESTIJ=DEST(I,J,K)
+              RFEIJ=HBM2(I,J)*(RFACE-1.)+1.
+              IF(DESTIJ<0.)DESTIJ=DESTIJ/RFEIJ
+              e1(i,j,k)=e2(i,j,k)+destij
+            ENDDO
+          enddo
+        endif
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+          Q  (I,J,K)=MAX(Q  (I,J,K),EPSQ)
+          CWM(I,J,K)=MAX(CWM(I,J,K),CLIMIT)
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO vertical_3
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+        Q2(I,J,KTE)=MAX(E1(I,J,KTE)+E1(I,J,KTE)-EPSQ2,EPSQ2)
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      DO K=KTE-1,KTS+1,-1
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+          IF(K>KTS)THEN
+            Q2(I,J,K)=MAX(E1(I,J,K)+E1(I,J,K)-Q2(I,J,K+1),EPSQ2)
+          ELSE
+            Q2(I,J,K)=Q2(I,J,K+1)
+          ENDIF
+        ENDDO
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE HAD2
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+! 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                                              &
+     &               ,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                                   &
+     &               ,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 
+!$$$
+!***********************************************************************
+!----------------------------------------------------------------------
+!
+      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) :: LSTART,NUM_SCAL
+!
+      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
+!
+      INTEGER,INTENT(IN) :: IDTAD,NTSD
+!
+      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,JMS:JME,KMS:KME),INTENT(IN) :: PETDT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,1:NUM_SCAL)               &
+                                                 ,INTENT(INOUT) :: SCAL
+!
+!----------------------------------------------------------------------
+!***  LOCAL VARIABLES
+!----------------------------------------------------------------------
+!
+      REAL,PARAMETER :: FF1=0.500
+!
+      LOGICAL,SAVE :: TRADITIONAL=.TRUE.
+!
+      INTEGER :: I,IRECV,J,JFP,JFQ,K,L,LAP,LLAP
+!
+      INTEGER,DIMENSION(KTS:KTE) :: LA
+!
+      REAL*8 :: ADDT,AFRP,D2PQQ,DETAP,DPDN,DPUP,DQP                     &
+     &         ,HADDT,HBM2IJ                                            &
+     &         ,Q00,Q4P,QP,QP0                                          &
+     &         ,RFACQK,RFC,RR                                           &
+     &         ,SUMNQ,SUMPQ
+!
+      REAL :: SFACQK
+!
+      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,d2pqq,detap,dpdn,dpup                           &
+!$omp&        ,dql,dqp,haddt,i,j,k                                      &
+!$omp&        ,la,lap,llap,petdtk,q00,q3,q4,q4p,qp,qp0,rfacqk           &
+!$omp&        ,rfc,rr,sfacqk,sumnq,sumpq)
+!-----------------------------------------------------------------------
+!
+      scalar_loop: DO L=LSTART,NUM_SCAL
+!
+      main_integration: DO J=MYJS2,MYJE2
+!
+!-----------------------------------------------------------------------
+!
+        main_iloop: DO I=MYIS1_P1,MYIE1_P1
+!
+!-----------------------------------------------------------------------
+!
+          DO K=KTS,KTE
+            Q3(K)=SCAL(I,J,K,L)
+            Q4(K)=Q3(K)
+          ENDDO
+!
+          IF(TRADITIONAL)THEN
+            PETDTK(KTE)=PETDT(I,J,KTE-1)*0.5
+!
+            DO K=KTE-1,KTS+1,-1
+              PETDTK(K)=(PETDT(I,J,K)+PETDT(I,J,K-1))*0.5
+            ENDDO
+!
+            PETDTK(KTS)=PETDT(I,J,KTS)*0.5
+!
+          ELSE
+!
+!-----------------------------------------------------------------------
+!***    PERFORM HORIZONTAL AVERAGING OF VERTICAL VELOCITY
+!-----------------------------------------------------------------------
+!
+            PETDTK(KTE)=(PETDT(I+IHW(J-1),J-1,KTE-1)                    &
+     &                  +PETDT(I+IHE(J-1),J-1,KTE-1)                    &
+     &                  +PETDT(I+IHW(J+1),J+1,KTE-1)                    &
+     &                  +PETDT(I+IHE(J+1),J+1,KTE-1)                    &
+     &                  +PETDT(I,J,KTE-1)*4.        )*0.0625
+!
+            DO K=KTE-1,KTS+1,-1
+              PETDTK(K)=(PETDT(I+IHW(J-1),J-1,K-1)                      &
+                        +PETDT(I+IHE(J-1),J-1,K-1)                      &
+     &                  +PETDT(I+IHW(J+1),J+1,K-1)                      &
+     &                  +PETDT(I+IHE(J+1),J+1,K-1)                      &
+     &                  +PETDT(I+IHW(J-1),J-1,K  )                      &
+     &                  +PETDT(I+IHE(J-1),J-1,K  )                      &
+     &                  +PETDT(I+IHW(J+1),J+1,K  )                      &
+     &                  +PETDT(I+IHE(J+1),J+1,K  )                      &
+     &                  +(PETDT(I,J,K-1)+PETDT(I,J,K))*4.               &
+     &                                                   )*0.0625
+            ENDDO
+!
+            PETDTK(KTS)=(PETDT(I+IHW(J-1),J-1,KTS)                      &
+     &                  +PETDT(I+IHE(J-1),J-1,KTS)                      &
+     &                  +PETDT(I+IHW(J+1),J+1,KTS)                      &
+     &                  +PETDT(I+IHE(J+1),J+1,KTS)                      &
+     &                  +PETDT(I,J,KTS)*4.        )*0.0625
+ 
+          ENDIF
+!
+!-----------------------------------------------------------------------
+!
+          HADDT=-ADDT*HBM2(I,J)
+!
+          DO K=KTE,KTS,-1
+            RR=PETDTK(K)*HADDT
+!
+            IF(RR<0.)THEN
+              LAP=1
+            ELSE
+              LAP=-1
+            ENDIF
+!
+            LA(K)=LAP
+            LLAP=K+LAP
+!
+            IF(LLAP>KTS-1.AND.LLAP<KTE+1)THEN
+              RR=ABS(RR/((AETA1(LLAP)-AETA1(K))*PDTOP                   &
+     &                  +(AETA2(LLAP)-AETA2(K))*PDSL(I,J)))
+              IF(RR>0.9)RR=0.9
+!
+              AFR(K)=(((FF4*RR+FF3)*RR+FF2)*RR+FF1)*RR
+              DQP=(Q3(LLAP)-Q3(K))*RR
+              DQL(K)=DQP
+            ELSE
+              RR=0.
+              AFR(K)=0.
+              DQL(K)=0.
+            ENDIF
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!
+          IF(LA(KTE-1)>0)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
+!
+          IF(LA(KTS+1)<0)THEN
+            RFC=(DETA1(KTS+1)*PDTOP+DETA2(KTS+1)*PDSL(I,J))           &
+     &         /(DETA1(KTS  )*PDTOP+DETA2(KTS  )*PDSL(I,J))
+            DQL(KTS)=-DQL(KTS+1)*RFC
+          ENDIF
+!
+          DO K=KTS,KTE
+            Q4(K)=Q3(K)+DQL(K)
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!***  ANTI-FILTERING STEP
+!-----------------------------------------------------------------------
+!
+          SUMPQ=0.
+          SUMNQ=0.
+!
+!***  ANTI-FILTERING LIMITERS
+!
+          antifilter: DO K=KTE-1,KTS+1,-1
+!
+            DETAP=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+!
+            Q4P=Q4(K)
+!
+            LAP=LA(K)
+!
+            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
+!
+            QP=Q4P-D2PQQ
+!
+            Q00=Q3(K)
+            QP0=Q3(K+LAP)
+!
+            QP=MAX(QP,MIN(Q00,QP0))
+            QP=MIN(QP,MAX(Q00,QP0))
+!
+            DQP=QP-Q00
+!
+            DQL(K)=DQP
+!
+          ENDDO antifilter
+!
+!-----------------------------------------------------------------------
+!
+          IF(LA(KTE-1)>0)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+DQL(KTE)
+          ENDIF
+!
+          IF(LA(KTS+1)<0)THEN
+            RFC=(DETA1(KTS+1)*PDTOP+DETA2(KTS+1)*PDSL(I,J))             &
+     &         /(DETA1(KTS  )*PDTOP+DETA2(KTS  )*PDSL(I,J))
+            DQL(KTS)=-DQL(KTS+1)*RFC+DQL(KTS)
+          ENDIF
+!
+          DO K=KTS,KTE
+            DETAP=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+            DQP=DQL(K)*DETAP
+!
+            IF(DQP>0.)THEN
+              SUMPQ=SUMPQ+DQP
+            ELSE
+              SUMNQ=SUMNQ+DQP
+            ENDIF
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!***  FIRST MOMENT CONSERVING FACTOR
+!-----------------------------------------------------------------------
+!
+          IF(SUMPQ>1.E-9)THEN
+            SFACQK=-SUMNQ/SUMPQ
+          ELSE
+            SFACQK=1.
+          ENDIF
+!
+          IF(SFACQK<CONSERVE_MIN.OR.SFACQK>CONSERVE_MAX)SFACQK=1.
+!
+          RFACQK=1./SFACQK
+!
+!-----------------------------------------------------------------------
+!***  IMPOSE CONSERVATION ON ANTI-FILTERING
+!-----------------------------------------------------------------------
+!
+          DO K=KTE,KTS,-1
+            DQP=DQL(K)
+            IF(SFACQK>=1.)THEN
+              IF(DQP<0.)DQP=DQP*RFACQK
+            ELSE
+              IF(DQP>0.)DQP=DQP*SFACQK
+            ENDIF
+            SCAL(I,J,K,L)=Q3(K)+DQP
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!
+        ENDDO main_iloop
+!
+!-----------------------------------------------------------------------
+!
+      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                &
+     &               ,HBM2,HBM3                                         &
+     &               ,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                                   &
+     &               ,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,PECKHAM    - 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 
+!$$$
+!***********************************************************************
+!-----------------------------------------------------------------------
+!    
+      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
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: IDTAD,LSTART,NTSD,NUM_SCAL
+!
+      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,JMS:JME,KMS:KME),INTENT(IN) :: U,V,Z
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,1: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) && !defined(STUBMPI)
+      LOGICAL,EXTERNAL :: WRF_DM_ON_MONITOR
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,2) :: XSUMS_L
+      REAL,DIMENSION(IDS:IDE,JDS:JDE,KDS:KDE,2) :: XSUMS_G
+#endif
+!
+      LOGICAL :: BOT,TOP
+!
+      INTEGER :: I,IRECV,J,JFP,JFQ,K,L,LAP,LLAP,MPI_COMM_COMP
+      INTEGER :: N
+!
+      INTEGER,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5,KTS:KTE) :: 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,PP,PPQ00,Q00,Q0Q            &
+     &       ,Q1IJ,Q4P,QP,QP0,QSTIJ,RDY,RFACE,RFACQ,RFACW,RFC           &
+     &       ,RFEIJ,RFQIJ,RFWIJ,RR,SLOPAC,SPP,SQP,SSA,SSB,SUMNQ,SUMPQ   &
+     &       ,TTA,TTB,W00,W0Q,W1IJ,W4P,WP,WP0,WSTIJ
+!
+      DOUBLE PRECISION,DIMENSION(2,KTS:KTE) :: GSUMS,XSUMS
+!
+      REAL,DIMENSION(KTS:KTE) :: AFR,DEL,DQL,DWL,Q3,Q4
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: DARE,EMH
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5,KTS:KTE) :: AFP,AFQ,DEST   &
+     &                                                  ,DQST,DVOL,DWST &
+     &                                                  ,Q1
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME) :: Q
+!
+!-----------------------------------------------------------------------
+      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
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!
+      scalar_loop: DO L=LSTART,NUM_SCAL
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dza,dzb,e1x,fpq,hm,i,j,jfp,jfq,k,pp,qp,ssa,ssb,spp,sqp   &
+!$omp&        ,tta,ttb)
+!-----------------------------------------------------------------------
+!
+      vertical_1: DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS_P3,MYJE_P3
+        DO I=MYIS_P2,MYIE_P2
+          DVOL(I,J,K)=DARE(I,J)*(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))
+          Q (I,J,K)=SCAL(I,J,K,L)
+          Q1(I,J,K)=Q(I,J,K)
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS2_P1,MYJE2_P1
+        DO I=MYIS1_P1,MYIE1_P1
+!
+          HM=HBM2(I,J)
+          TTA=(U(I,J-1,K)+U(I+IHW(J),J,K)+U(I+IHE(J),J,K)+U(I,J+1,K))   &
+     &        *EMH(I,J)*HM
+          TTB=(V(I,J-1,K)+V(I+IHW(J),J,K)+V(I+IHE(J),J,K)+V(I,J+1,K))   &
+     &        *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,J,K)=IHE(J)+I+( JFP-1)/2
+          IFQA(I,J,K)=IHE(J)+I+(-JFQ-1)/2
+!
+          JFPA(I,J,K)=J+JFP
+          JFQA(I,J,K)=J+JFQ
+!
+          IFPF(I,J,K)=IHE(J)+I+(-JFP-1)/2
+          IFQF(I,J,K)=IHE(J)+I+( JFQ-1)/2
+!
+          JFPF(I,J,K)=J-JFP
+          JFQF(I,J,K)=J-JFQ
+!
+!-----------------------------------------------------------------------
+          IF(.NOT.HYDRO)THEN ! z currently not available for hydro=.true.
+            DZA=(Z(IFPA(I,J,K),JFPA(I,J,K),K)-Z(I,J,K))*RDY
+            DZB=(Z(IFQA(I,J,K),JFQA(I,J,K),K)-Z(I,J,K))*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
+!
+!-----------------------------------------------------------------------
+!
+          FPQ=SPP*SQP*0.25
+          PP=ABS(SPP)
+          QP=ABS(SQP)
+!
+          AFP(I,J,K)=(((FF4*PP+FF3)*PP+FF2)*PP+FF1)*PP
+          AFQ(I,J,K)=(((FF4*QP+FF3)*QP+FF2)*QP+FF1)*QP
+!
+          Q1(I,J,K)=(Q  (IFPA(I,J,K),JFPA(I,J,K),K)-Q  (I,J,K))*PP        &
+       &           +(Q  (IFQA(I,J,K),JFQA(I,J,K),K)-Q  (I,J,K))*QP        &
+       &           +(Q  (I,J-2,K)+Q  (I,J+2,K)                            &
+       &            -Q  (I-1,J,K)-Q  (I+1,J,K))*FPQ                       &
+       &           +Q(I,J,K)
+!
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO vertical_1
+!
+!-----------------------------------------------------------------------
+!***  ANTI-FILTERING STEP
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+        XSUMS(1,K)=0.
+        XSUMS(2,K)=0.
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+!***  ANTI-FILTERING LIMITERS
+!
+!-----------------------------------------------------------------------
+#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL) && !defined(STUBMPI)
+      DO N=1,2
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO K=KMS,KME 
+        DO J=JMS,JME 
+        DO I=IMS,IME 
+          XSUMS_L(I,J,K,N)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO K=KDS,KDE 
+        DO J=JDS,JDE 
+        DO I=IDS,IDE 
+          XSUMS_G(I,J,K,N)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+!
+      ENDDO
+!
+#endif
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(d2pqe,d2pqq,d2pqw,destij,dqstij,dvolp,dwstij             &
+!$omp&        ,e00,e0q,ep0,estij,hafp,hafq,i,j,k                        &
+!$omp&        ,q00,q0q,q1ij,qp0,qstij,w00,w0q,wp0,wstij)
+!-----------------------------------------------------------------------
+!
+      vertical_2: DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+!
+          DVOLP=DVOL(I,J,K)
+          Q1IJ =Q1(I,J,K)
+!
+          HAFP=AFP(I,J,K)
+          HAFQ=AFQ(I,J,K)
+!
+          D2PQQ=(Q1(IFPA(I,J,K),JFPA(I,J,K),K)-Q1IJ                     &
+     &          -Q1IJ+Q1(IFPF(I,J,K),JFPF(I,J,K),K))                    &
+     &          *HAFP                                                   &
+     &         +(Q1(IFQA(I,J,K),JFQA(I,J,K),K)-Q1IJ                     &
+     &          -Q1IJ+Q1(IFQF(I,J,K),JFQF(I,J,K),K))                    &
+     &          *HAFQ
+!
+          QSTIJ=Q1IJ-D2PQQ
+!
+          Q00=Q  (I          ,J          ,K)
+          QP0=Q  (IFPA(I,J,K),JFPA(I,J,K),K)
+          Q0Q=Q  (IFQA(I,J,K),JFQA(I,J,K),K)
+!
+          QSTIJ=MAX(QSTIJ,MIN(Q00,QP0,Q0Q))
+          QSTIJ=MIN(QSTIJ,MAX(Q00,QP0,Q0Q))
+!
+          DQSTIJ=QSTIJ-Q(I,J,K)
+!
+          DQST(I,J,K)=DQSTIJ
+!
+          DQSTIJ=DQSTIJ*DVOLP
+!
+!-----------------------------------------------------------------------
+#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL) && !defined(STUBMPI)
+!-----------------------------------------------------------------------
+          DO N=1,2
+            XSUMS_L(I,J,K,N)=0.
+          ENDDO
+!
+          IF(DQSTIJ>0.)THEN
+            XSUMS_L(I,J,K,1)=DQSTIJ
+          ELSE
+            XSUMS_L(I,J,K,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
+!-----------------------------------------------------------------------
+!
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO vertical_2
+!
+!-----------------------------------------------------------------------
+#if defined(BIT_FOR_BIT) && defined(DM_PARALLEL) && !defined(STUBMPI)
+!-----------------------------------------------------------------------
+      DO N=1,2
+        CALL WRF_PATCH_TO_GLOBAL_REAL(XSUMS_L(IMS,JMS,KMS,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
+!
+      DO K=KTS,KTE
+        DO N=1,2
+          GSUMS(N,K)=0.
+        ENDDO
+      ENDDO
+!
+      IF(WRF_DM_ON_MONITOR())THEN
+        DO N=1,2
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+          DO K=KDS,KDE
+          DO J=JDS,JDE
+          DO I=IDS,IDE
+            GSUMS(N,K)=GSUMS(N,K)+XSUMS_G(I,J,K,N)
+          ENDDO
+          ENDDO
+          ENDDO
+        ENDDO
+      ENDIF
+
+      CALL WRF_DM_BCAST_BYTES(GSUMS,2*RWORDSIZE*2*(KDE-KDS+1) )
+
+!-----------------------------------------------------------------------
+#else
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***  GLOBAL REDUCTION
+!-----------------------------------------------------------------------
+!
+# if defined(DM_PARALLEL) && !defined(STUBMPI)
+      CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+      CALL MPI_ALLREDUCE(XSUMS,GSUMS,2*(KTE-KTS+1)                      &
+     &                  ,MPI_DOUBLE_PRECISION,MPI_SUM                   &
+     &                  ,MPI_COMM_COMP,IRECV)
+# else
+      DO K=KTS,KTE
+        DO N=1,2
+          GSUMS(N,K)=XSUMS(N,K)
+        ENDDO
+      ENDDO
+# 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
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(destij,dqstij,dwstij,i,j,k,rface,rfacq,rfacw             &
+!$omp&        ,rfeij,rfqij,rfwij,sumnq,sumpq)
+!-----------------------------------------------------------------------
+!
+      vertical_3: DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!       if(mype==0)then
+!         write(nunit)(gsums(i,k),i=1,6)
+!       endif
+!!!     read(nunit)(gsums(i,k),i=1,6)
+!-----------------------------------------------------------------------
+!
+        SUMPQ=GSUMS(1,K)
+        SUMNQ=GSUMS(2,K)
+!
+!-----------------------------------------------------------------------
+!***  FIRST MOMENT CONSERVING FACTOR
+!-----------------------------------------------------------------------
+!
+        IF(SUMPQ>1.)THEN
+          RFACQ=-SUMNQ/SUMPQ
+        ELSE
+          RFACQ=1.
+        ENDIF
+!
+        IF(RFACQ<CONSERVE_MIN.OR.RFACQ>CONSERVE_MAX)RFACQ=1.
+!
+!-----------------------------------------------------------------------
+!       if(mype==0.and.ntsd==181)close(nunit)
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***  IMPOSE CONSERVATION ON ANTI-FILTERING
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS2,MYJE2
+          IF(RFACQ<1.)THEN
+            DO I=MYIS1,MYIE1
+              DQSTIJ=DQST(I,J,K)
+              RFQIJ=HBM2(I,J)*(RFACQ-1.)+1.
+              IF(DQSTIJ>=0.)DQSTIJ=DQSTIJ*RFQIJ
+              Q(I,J,K)=Q(I,J,K)+DQSTIJ
+            ENDDO
+          ELSE
+            DO I=MYIS1,MYIE1
+              DQSTIJ=DQST(I,J,K)
+              RFQIJ=HBM2(I,J)*(RFACQ-1.)+1.
+              IF(DQSTIJ<0.)DQSTIJ=DQSTIJ/RFQIJ
+              Q(I,J,K)=Q(I,J,K)+DQSTIJ
+            ENDDO
+          ENDIF
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+          SCAL(I,J,K,L)=Q(I,J,K)
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO vertical_3
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO scalar_loop
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE HAD2_SCAL
+!
+!-----------------------------------------------------------------------
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+                        subroutine adv2 &
+(UPSTRM &
+,mype,kss,kse &
+,ids,ide,jds,jde,kds,kde &
+,ims,ime,jms,jme,kms,kme &
+,its,ite,jts,jte,kts,kte &
+,N_IUP_H &
+,N_IUP_ADH &
+,IUP_H,IUP_ADH &
+,ENT &
+,idtad &
+,dt,pdtop &
+,ihe,ihw,ive,ivw &
+,deta1,deta2 &
+,EMT_LOC &
+,fad,hbm2,pdsl,pdslo &
+,petdt &
+,UOLD,VOLD &
+,s,sp &
+!---temporary arguments-------------------------------------------------
+,fne,fse,few,fns,s1,tcs)
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+implicit none
+!-----------------------------------------------------------------------
+real,parameter:: &
+ cfc=1.533 &                 ! adams-bashforth positioning in time
+,bfc=1.-cfc &                ! adams bashforth positioning in time
+,cflc=9.005 &                !
+,epsq=1.e-20 &               ! floor value for specific humidity
+,epsq2=0.2 &                 ! floor value for 2tke
+,epscm=2.e-6 &               ! a floor value (not used)
+,w1=1.0 &                    ! crank-nicholson uncentering
+!,w1=-1.00 &                  ! crank-nicholson uncentering
+,w2=2.-w1                    ! crank-nicholson uncentering
+
+logical,intent(in):: &
+ upstrm
+
+integer,intent(in):: &
+ idtad &                     ! time step multiplier
+,kse &                       ! terminal species index
+,kss &                       ! initial species index
+,mype &                      !
+,ids,ide,jds,jde,kds,kde &
+,ims,ime,jms,jme,kms,kme &
+,its,ite,jts,jte,kts,kte
+
+real,intent(in):: &
+ ent &                       !
+,dt &                        ! dynamics time step
+,pdtop                       !
+
+real,dimension(kts:kte),intent(in):: &
+ deta1 &                     ! delta sigmas
+,deta2                       ! delta pressures
+
+integer,dimension(jms:jme),intent(in):: &
+ ihe,ihw,ive,ivw &
+,n_iup_adh,n_iup_h
+
+integer,dimension(ims:ime,jms:jme),intent(in):: &
+ iup_h,iup_adh
+
+real,dimension(2600),intent(in):: & !!!zj see nmm_max_dim in adve !!!zj
+ emt_loc
+
+real,dimension(ims:ime,jms:jme),intent(in):: &
+ fad &                       !
+,hbm2 &                      !
+,pdsl &                      ! sigma range pressure difference
+,pdslo                       ! sigma range pressure difference
+
+real,dimension(ims:ime,jms:jme,kms:kme),intent(in):: &
+ petdt &                     ! vertical mass flux
+,uold,vold
+
+real,dimension(ims:ime,jms:jme,kms:kme,kss:kse),intent(inout):: &
+ s                           ! tracers
+
+real,dimension(ims:ime,jms:jme,kms:kme,kss:kse),intent(inout):: &
+ sp                          ! s at previous time level
+
+!---temporary arguments-------------------------------------------------
+real,dimension(ims:ime,jms:jme,kms:kme),intent(in):: &
+ fne &                       ! mass flux, ne direction
+,fse &                       ! mass flux, se direction
+,few &                       ! mass flux, x direction
+,fns                         ! mass flux, y direction
+
+real,dimension(ims:ime,jms:jme,kms:kme,kss:kse),intent(inout):: &
+ s1 &                        ! intermediate value of s
+,tcs                         ! timechange of s
+
+!--local variables------------------------------------------------------
+integer:: &
+ i &                         !
+,j &                         !
+,k &                         !
+,ks                          !
+
+      INTEGER :: IEND,IFP,IFQ,II,IPQ,ISP,ISQ,ISTART &
+     &          ,IUP_ADH_J &
+     &          ,J1,JA,JAK,JEND,JGLOBAL,JJ,JKNT,JP2,JSTART &
+     &          ,KNTI_ADH,KSTART,KSTOP &
+     &          ,N,N_IUPH_J,N_IUPADH_J,N_IUPADV_J
+
+      INTEGER :: MY_IS_GLB,MY_IE_GLB,MY_JS_GLB,MY_JE_GLB
+
+real:: &
+ cf &                        ! temporary
+,cms &                       ! temporary
+,dtq &                       ! dt/4
+,fahp &                      ! temporary grid factor
+,sn &                        !
+,rdp &                       ! 1/deltap
+,vvlo &                      ! vertical velocity, lower interface
+,vvup &                      ! vertical velocity, upper interface
+,pvvup                       ! vertical mass flux, upper interface
+
+      REAL :: ARRAY3_X &
+     &       ,F0,F1,F2,F3 &
+     &       ,PP &
+     &       ,QP &
+     &       ,TEMPA,TEMPB,TTA,TTB
+
+real,dimension(kts:kte):: &
+ deta1_pdtop                 !
+
+      INTEGER,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: ISPA,ISQA
+
+real,dimension(its-5:ite+5,jts-5:jte+5):: &
+ pdop &                      ! hydrostatic pressure difference at h points
+,pvvlo &                     ! vertical mass flux, lower interface
+,ss1 &                       ! extrapolated species between time levels
+,ssne &                      ! flux, ne direction
+,ssse &                      ! flux, nw direction
+,ssx &                       ! flux, x direction
+,ssy                         ! flux, y direction
+
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: ARRAY0,ARRAY1 &
+     &                                          ,ARRAY2,ARRAY3
+
+real,dimension(its-5:ite+5,jts-5:jte+5,kts:kte):: &
+ crs &                       ! vertical advection temporary
+,rcms                        ! vertical advection temporary
+
+real,dimension(its-5:ite+5,jts-5:jte+5,kts:kte,kss:kse):: &
+ rsts                        ! vertical advection temporary
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      DO J=JTS-5,JTE+5
+        DO I=ITS-5,ITE+5
+          pdop (i,j)=0.
+          pvvlo(i,j)=0.
+          ss1  (i,j)=0.
+          ssne (i,j)=0.
+          ssse (i,j)=0.
+        enddo
+      enddo
+!
+      DO K=KTS,KTE
+        DO J=JTS-5,JTE+5
+          DO I=ITS-5,ITE+5
+            crs (i,j,k)=0.
+            rcms(i,j,k)=0.
+          enddo
+        enddo
+      enddo
+!
+      do ks=kss,kse
+        DO K=KTS,KTE
+          DO J=JTS-5,JTE+5
+            DO I=ITS-5,ITE+5
+              rsts(i,j,k,ks)=0.
+              s1  (i,j,k,ks)=0.
+            enddo
+          enddo
+        enddo
+      enddo
+!
+      do ks=kss,kse
+        DO K=KMS,KME
+          DO J=JMS,JME
+            DO I=IMS,IME
+              s1 (i,j,k,ks)=0.
+              tcs(i,j,k,ks)=0.
+            enddo
+          enddo
+        enddo
+      enddo
+!-----------------------------------------------------------------------
+      do k=kts,kte
+        deta1_pdtop(k)=deta1(k)*pdtop
+      enddo
+!-----------------------------------------------------------------------
+      do ks=kss,kse ! loop by species
+!-----------------------------------------------------------------------
+        DO K=KTS,KTE
+          DO J=MYJS_P4,MYJE_P4
+            DO I=MYIS_P4,MYIE_P4
+              s1(i,j,k,ks)=sqrt(s(i,j,k,ks))
+            enddo
+          enddo
+        enddo
+!-----------------------------------------------------------------------
+      enddo ! end of the loop by species
+!-----------------------------------------------------------------------
+      DO J=MYJS_P4,MYJE_P4
+        DO I=MYIS_P4,MYIE_P4
+          pdop(i,j)=(pdslo(i,j)+pdsl(i,j))*0.5
+        enddo
+      enddo
+!---crank-nicholson vertical advection----------------------------------
+      dtq=dt*idtad*0.25
+
+      DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+          pvvlo(i,j)=petdt(i,j,kte-1)*dtq
+          vvlo=pvvlo(i,j)/(deta2(kte)*pdop(i,j)+deta1_pdtop(kte))
+!
+          cms=-vvlo*w2+1.
+          rcms(i,j,kte)=1./cms
+          crs(i,j,kte)=vvlo*w2
+!
+          do ks=kss,kse
+            rsts(i,j,kte,ks)=(-vvlo*w1) &
+                            *(s1(i,j,kte-1,ks)-s1(i,j,kte,ks)) &
+                            +s1(i,j,kte,ks)
+          enddo
+        enddo
+      enddo
+      DO K=KTE-1,KTS+1,-1
+        DO J=MYJS2,MYJE2
+          DO I=MYIS1,MYIE1
+            rdp=1./(deta2(k)*pdop(i,j)+deta1_pdtop(k))
+            pvvup=pvvlo(i,j)
+            pvvlo(i,j)=petdt(i,j,k-1)*dtq
+!
+            vvup=pvvup*rdp
+            vvlo=pvvlo(i,j)*rdp
+!
+!            if(abs(vvlo).gt.cflc) then
+!              if(vvlo.lt.0.) then
+!                vvlo=-cflc
+!              else
+!                vvlo= cflc
+!              endif
+!            endif
+!
+            cf=-vvup*w2*rcms(i,j,k+1)
+            cms=-crs(i,j,k+1)*cf+((vvup-vvlo)*w2+1.)
+            rcms(i,j,k)=1./cms
+            crs(i,j,k)=vvlo*w2
+!
+            do ks=kss,kse
+              rsts(i,j,k,ks)=-rsts(i,j,k+1,ks)*cf+s1(i,j,k,ks) &
+                             -(s1(i,j,k  ,ks)-s1(i,j,k+1,ks))*vvup*w1 &
+                             -(s1(i,j,k-1,ks)-s1(i,j,k  ,ks))*vvlo*w1
+            enddo
+          enddo
+        enddo
+      enddo
+      DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+          pvvup=pvvlo(i,j)
+          vvup=pvvup/(deta2(kts)*pdop(i,j)+deta1_pdtop(kts))
+!
+          cf=-vvup*w2*rcms(i,j,kts+1)
+          cms=-crs(i,j,kts+1)*cf+(vvup*w2+1.)
+          rcms(i,j,kts)=1./cms
+          crs(i,j,kts)=0.
+!
+          do ks=kss,kse
+            rsts(i,j,kts,ks)=-rsts(i,j,kts+1,ks)*cf+s1(i,j,kts,ks) &
+                             -(s1(i,j,kts,ks)-s1(i,j,kts+1,ks))*vvup*w1
+!
+            tcs(i,j,kts,ks)=rsts(i,j,kts,ks)*rcms(i,j,kts)-s1(i,j,kts,ks)
+          enddo
+        enddo
+      enddo
+      do ks=kss,kse
+        DO K=KTS+1,KTE
+          DO J=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+              tcs(i,j,k,ks)=(-crs(i,j,k)*(s1(i,j,k-1,ks)+tcs(i,j,k-1,ks)) &
+                             +rsts(i,j,k,ks)) &
+                           *rcms(i,j,k)-s1(i,j,k,ks)
+            enddo
+          enddo
+        enddo
+      enddo
+!-----------------------------------------------------------------------
+      do ks=kss,kse ! loop by species
+!-----------------------------------------------------------------------
+        DO K=KTS,KTE
+          DO J=MYJS_P5,MYJE_P5
+            DO I=MYIS_P5,MYIE_P5
+              ss1(i,j)=s1(i,j,k,ks)*cfc+sp(i,j,k,ks)*bfc
+              sp(i,j,k,ks)=s1(i,j,k,ks)
+            enddo
+          enddo
+!---fluxes--------------------------------------------------------------
+          DO J=MYJS1_P2,MYJE1_P2
+            DO I=MYIS_P2,MYIE_P3
+              ssx(i,j)=(ss1(i+ive(j),j  )-ss1(i+ivw(j),j  ))*few(i,j,k) &
+                      *hbm2(i,j)
+              ssy(i,j)=(ss1(i       ,j+1)-ss1(i       ,j-1))*fns(i,j,k) &
+                      *hbm2(i,j)
+            enddo
+          enddo
+          DO J=MYJS1_P2,MYJE2_P2
+            DO I=MYIS_P2,MYIE_P2
+              ssne(i,j)=(ss1(i+ihe(j),j+1)-ss1(i,j))*fne(i,j,k)*hbm2(i,j)
+            enddo
+          enddo
+          DO J=MYJS2_P2,MYJE1_P2
+            DO I=MYIS_P2,MYIE_P2
+              ssse(i,j)=(ss1(i+ihe(j),j-1)-ss1(i,j))*fse(i,j,k)*hbm2(i,j)
+            enddo
+          enddo
+!---advection of species------------------------------------------------
+          DO J=MYJS5,MYJE5
+            DO I=MYIS2,MYIE2
+              tcs(i,j,k,ks)=((ssx (i+ihw(j),j  )+ssx (i+ihe(j),j  ) &
+                             +ssy (i       ,j-1)+ssy (i       ,j+1) &
+                             +ssne(i+ihw(j),j-1)+ssne(i       ,j  ) &
+                             +ssse(i       ,j  )+ssse(i+ihw(j),j+1)) &
+                            *fad(i,j)*2.0*idtad &   !! 2.0 compensates for fad
+                            /(deta2(k)*pdop(i,j)+deta1_pdtop(k)) &
+                           +tcs(i,j,k,ks))*hbm2(i,j)
+            enddo
+          enddo
+!-----------------------------------------------------------------------
+!
+!***  upstream advection
+!
+!-----------------------------------------------------------------------
+!
+          upstream: IF(UPSTRM)THEN
+!
+!-----------------------------------------------------------------------
+!***
+!***  COMPUTE UPSTREAM COMPUTATIONS ON THIS TASK'S ROWS.
+!***
+!-----------------------------------------------------------------------
+!
+            jloop_upstream: DO J=MYJS2,MYJE2
+!
+              N_IUPH_J=N_IUP_H(J)   ! See explanation in START_DOMAIN_NMM
+              DO II=0,N_IUPH_J-1
+!
+                I=IUP_H(IMS+II,J)
+                tta=emt_loc(j) &
+                   *(uold(i       ,j-1,k)+uold(i+ihw(j),j  ,k) &
+                    +uold(i+ihe(j),j  ,k)+uold(i       ,j+1,k))
+                ttb=ent &
+                   *(vold(i       ,j-1,k)+vold(i+ihw(j),j  ,k) &
+                    +vold(i+ihe(j),j  ,k)+vold(i       ,j+1,k))
+                PP=-TTA-TTB
+                QP= TTA-TTB
+!
+                IF(PP<0.)THEN
+                  ISPA(I,J)=-1
+                ELSE
+                  ISPA(I,J)= 1
+                ENDIF
+!
+                IF(QP<0.)THEN
+                  ISQA(I,J)=-1
+                ELSE
+                  ISQA(I,J)= 1
+                ENDIF
+!
+                PP=ABS(PP)
+                QP=ABS(QP)
+                ARRAY3_X=PP*QP
+                ARRAY0(I,J)=ARRAY3_X-PP-QP
+                ARRAY1(I,J)=PP-ARRAY3_X
+                ARRAY2(I,J)=QP-ARRAY3_X
+                ARRAY3(I,J)=ARRAY3_X
+              ENDDO
+!
+!-----------------------------------------------------------------------
+!
+              N_IUPADH_J=N_IUP_ADH(J)
+              KNTI_ADH=1
+              IUP_ADH_J=IUP_ADH(IMS,J)
+!
+              iloop_T: DO II=0,N_IUPH_J-1
+!
+                I=IUP_H(IMS+II,J)
+!
+                ISP=ISPA(I,J)
+                ISQ=ISQA(I,J)
+                IFP=(ISP-1)/2
+                IFQ=(-ISQ-1)/2
+                IPQ=(ISP-ISQ)/2
+!
+!-----------------------------------------------------------------------
+!
+                IF(I==IUP_ADH_J)THEN  ! Upstream advection T tendencies
+!
+                  ISP=ISPA(I,J)
+                  ISQ=ISQA(I,J)
+                  IFP=(ISP-1)/2
+                  IFQ=(-ISQ-1)/2
+                  IPQ=(ISP-ISQ)/2
+!
+                  F0=ARRAY0(I,J)
+                  F1=ARRAY1(I,J)
+                  F2=ARRAY2(I,J)
+                  F3=ARRAY3(I,J)
+!
+                  tcs(i,j,k,ks)=(f0*s1(i,j,k,ks) &
+     &                          +f1*s1(i+ihe(j)+ifp,j+isp,k,ks) &
+     &                          +f2*s1(i+ihe(j)+ifq,j+isq,k,ks) &
+     &                          +f3*s1(i+ipq,j+isp+isq,k,ks))*2.0 &
+     &                          *idtad &
+     &                         +tcs(i,j,k,ks)*hbm2(i,j)
+!
+!-----------------------------------------------------------------------
+!
+                  IF(KNTI_ADH<N_IUPADH_J)THEN
+                    IUP_ADH_J=IUP_ADH(IMS+KNTI_ADH,J)
+                    KNTI_ADH=KNTI_ADH+1
+                  ENDIF
+!
+                ENDIF  ! End of upstream advection tendency IF block
+!
+              ENDDO iloop_T
+!
+!-----------------------------------------------------------------------
+            enddo jloop_upstream
+!-----------------------------------------------------------------------
+          endif upstream
+!-----------------------------------------------------------------------
+        enddo ! kts,kte
+!-----------------------------------------------------------------------
+      enddo ! end of the loop by the species
+!-----------------------------------------------------------------------
+                        endsubroutine adv2
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+                        subroutine mono &
+( &
+#if defined(DM_PARALLEL)
+ domdesc, &
+#endif
+ mype,ntsd,hours,kss,kse &
+,ids,ide,jds,jde,kds,kde &
+,ims,ime,jms,jme,kms,kme &
+,its,ite,jts,jte,kts,kte &
+,idtad &
+,dy,pdtop &
+,sumdrrw &
+,ihe,ihw &
+,deta1,deta2 &
+,dx,hbm2,pd &
+,s &
+!---temporary arguments-------------------------------------------------
+,s1,tcs)
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+implicit none
+!-----------------------------------------------------------------------
+real,parameter:: &
+ epsq=1.e-20 &               ! floor value for specific humidity
+,epsq2=0.02                  ! floor value for 2tke
+
+#ifdef DM_PARALLEL
+      INTEGER :: DOMDESC
+#endif
+
+integer,intent(in):: &
+ idtad &                     ! time step multiplier
+,kse &                       ! terminal species index
+,kss &                       ! initial species index
+,mype &                      !
+,ntsd &                      !
+,ids,ide,jds,jde,kds,kde &
+,ims,ime,jms,jme,kms,kme &
+,its,ite,jts,jte,kts,kte
+
+real,intent(in):: &
+ dy &                        !
+,pdtop &                     !
+,hours                       !
+
+real,intent(inout):: &
+ sumdrrw
+
+integer,dimension(jms:jme),intent(in):: &
+ ihe,ihw
+
+real,dimension(kts:kte),intent(in):: &
+ deta1 &                     ! delta sigmas
+,deta2                       ! delta sigmas
+
+real,dimension(ims:ime,jms:jme),intent(in):: &
+ dx &                        !
+,hbm2 &                      !
+,pd                          ! sigma range pressure difference
+
+real,dimension(ims:ime,jms:jme,kms:kme,kss:kse),intent(in):: &
+ s                           ! s
+!---temporary arguments-------------------------------------------------
+real,dimension(ims:ime,jms:jme,kms:kme,kss:kse),intent(inout):: &
+ s1 &                        ! intermediate value of s
+,tcs                         ! timechange of s
+!--local variables------------------------------------------------------
+integer:: &
+ i &                         !
+,ierr &                      !
+,irecv &                     !
+,j &                         !
+,k &                         !
+,ks &                        !
+,lngth &                     !
+,mpi_comm_comp               !
+
+real:: &
+ dsks &                      !
+,dvolp &                     !
+,rfacs &                     !
+,s1p &                       !
+,sfacs &                     !
+,smax &                      ! local maximum
+,smin &                      ! local minimum
+,smaxh &                     ! horizontal local maximum
+,sminh &                     ! horizontal local minimum
+,smaxv &                     ! vertical local maximum
+,sminv &                     ! vertical local minimum
+,sn &                        !
+,sumns &                     !
+,sumps &                     !
+,steep
+
+double precision:: &
+ xsmp,gsmp
+
+double precision,dimension(2*kss-1:2*kse):: &
+ vgsms
+
+real,dimension(kts:kte):: &
+ deta1_pdtop                 !
+
+real,dimension(2*kss-1:2*kse,kts:kte):: &
+ gsms_single                 !
+
+double precision,dimension(2*kss-1:2*kse,kts:kte):: &
+ gsms &                      ! sum of neg/pos changes all global fields
+,xsms                        ! sum of neg/pos changes all local fields
+
+double precision,dimension(2*kss-1:2*kse):: &
+ vgsums                      !
+
+real,dimension(its-5:ite+5,jts-5:jte+5,kts:kte):: &
+ dvol &                      ! grid box volume
+,rdvol                       ! 1./grid box volume
+
+logical, save :: first=.true.
+real, save :: sumrrw_first, summass_first
+real :: summass
+double precision, save :: gsmp_first
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+!     steep=1.-0.040*idtad
+      steep=1.
+
+      DO K=KTS,KTE
+        deta1_pdtop(k)=deta1(k)*pdtop
+      enddo
+!
+      DO K=KTS,KTE
+        DO J=MYJS2,MYJE2
+          DO I=MYIS1,MYIE1
+            dvolp=(deta2(k)*pd(i,j)+deta1_pdtop(k))*dx(i,j)*dy
+            rdvol(i,j,k)=hbm2(i,j)/dvolp
+            dvol (i,j,k)=hbm2(i,j)*dvolp
+          enddo
+        enddo
+      enddo
+
+!      go to 109
+!---monotonization------------------------------------------------------
+      do ks=kss,kse ! loop by species
+!-----------------------------------------------------------------------
+        DO K=KTS,KTE
+          xsms(2*ks-1,k)=0.
+          xsms(2*ks  ,k)=0.
+          gsms(2*ks-1,k)=0.
+          gsms(2*ks  ,k)=0.
+!
+          DO J=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+!
+              s1p=(s1(i,j,k,ks)+tcs(i,j,k,ks))**2
+              tcs(i,j,k,ks)=s1p-s(i,j,k,ks)
+!
+              sminh=min(s(i       ,j-2,k,ks) &
+                       ,s(i+ihw(j),j-1,k,ks) &
+                       ,s(i+ihe(j),j-1,k,ks) &
+                       ,s(i-1     ,j  ,k,ks) &
+                       ,s(i       ,j  ,k,ks) &
+                       ,s(i+1     ,j  ,k,ks) &
+                       ,s(i+ihw(j),j+1,k,ks) &
+                       ,s(i+ihe(j),j+1,k,ks) &
+                       ,s(i       ,j+2,k,ks))
+              smaxh=max(s(i       ,j-2,k,ks) &
+                       ,s(i+ihw(j),j-1,k,ks) &
+                       ,s(i+ihe(j),j-1,k,ks) &
+                       ,s(i-1     ,j  ,k,ks) &
+                       ,s(i       ,j  ,k,ks) &
+                       ,s(i+1     ,j  ,k,ks) &
+                       ,s(i+ihw(j),j+1,k,ks) &
+                       ,s(i+ihe(j),j+1,k,ks) &
+                       ,s(i       ,j+2,k,ks))
+!
+              if(k.gt.kts.and.k.lt.kte) then
+                sminv=min(s(i,j,k-1,ks),s(i,j,k  ,ks),s(i,j,k+1,ks))
+                smaxv=max(s(i,j,k-1,ks),s(i,j,k  ,ks),s(i,j,k+1,ks))
+              elseif(k.eq.kts) then
+                sminv=min(s(i,j,k  ,ks),s(i,j,k+1,ks))
+                smaxv=max(s(i,j,k  ,ks),s(i,j,k+1,ks))
+              elseif(k.eq.kte) then
+                sminv=min(s(i,j,k-1,ks),s(i,j,k  ,ks))
+                smaxv=max(s(i,j,k-1,ks),s(i,j,k  ,ks))
+              endif
+!
+              smin=min(sminh,sminv)
+              smax=max(smaxh,smaxv)
+!
+              sn=s1p
+              if(sn.gt.steep*smax) sn=smax
+              if(sn.lt.      smin) sn=smin
+!
+              dsks=(sn-s1p)*dvol(i,j,k)
+              s1(i,j,k,ks)=dsks
+              if(dsks.gt.0.) then
+                xsms(2*ks-1,k)=xsms(2*ks-1,k)+dsks
+              else
+                xsms(2*ks  ,k)=xsms(2*ks  ,k)+dsks
+              endif
+!
+            enddo
+          enddo
+        enddo
+!-----------------------------------------------------------------------
+      enddo ! end of the loop by species
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***  GLOBAL REDUCTION
+!-----------------------------------------------------------------------
+!
+# if defined(DM_PARALLEL) && !defined(STUBMPI)
+      CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+      lngth=(2*kse-2*kss+2)*(KTE-KTS+1)
+      CALL MPI_ALLREDUCE(XSMS,GSMS,lngth                              &
+     &                  ,MPI_DOUBLE_PRECISION,MPI_SUM                   &
+     &                  ,MPI_COMM_COMP,IRECV)
+# else
+      DO K=KTS,KTE
+        do ks=kss,kse
+          gsms(2*ks-1,k)=xsms(2*ks-1,k)
+          gsms(2*ks  ,k)=xsms(2*ks  ,k)
+        enddo
+      enddo
+# endif
+!
+      DO K=KTS,KTE
+        do ks=kss,kse
+          gsms_single(2*ks-1,k)=gsms(2*ks-1,k)
+          gsms_single(2*ks  ,k)=gsms(2*ks  ,k)
+        enddo
+      enddo
+!
+!-----------------------------------------------------------------------
+!***  END OF GLOBAL REDUCTION
+!-----------------------------------------------------------------------
+!
+!dusan!---forced conservation after monotonization----------------------------
+!dusan      do ks=kss,kse
+!dusan        DO K=KTS,KTE
+!dusan          sumps=gsms_single(2*ks-1,k)
+!dusan          sumns=gsms_single(2*ks  ,k)
+!dusan!
+!dusan          if(sumps*(-sumns).gt.1.) then
+!dusan            sfacs=-sumns/sumps
+!dusan            rfacs=1./sfacs
+!dusan          else
+!dusan            sfacs=0.
+!dusan            rfacs=0.
+!dusan          endif
+!dusan!
+!dusan          DO J=MYJS2,MYJE2
+!dusan            DO I=MYIS1,MYIE1
+!dusan              dsks=s1(i,j,k,ks)*rdvol(i,j,k)
+!dusan              if(sfacs.gt.1.) then
+!dusan                if(dsks.lt.0.) dsks=dsks*rfacs
+!dusan!zjtest                if(dsks.lt.0.) dsks=dsks
+!dusan              else
+!dusan                if(dsks.ge.0.) dsks=dsks*sfacs
+!dusan              endif
+!dusan              tcs(i,j,k,ks)=tcs(i,j,k,ks)+dsks
+!dusan            enddo
+!dusan          enddo
+!dusan        enddo
+!dusan!-----------------------------------------------------------------------
+!dusan      enddo ! end of the loop by species
+
+!---forced conservation after monotonization----------------------------
+      do ks=kss,kse
+        vgsums(2*ks-1)=0.
+        vgsums(2*ks  )=0.
+        DO K=KTS,KTE
+          vgsums(2*ks-1)=gsms(2*ks-1,k)+vgsums(2*ks-1)
+          vgsums(2*ks  )=gsms(2*ks  ,k)+vgsums(2*ks  )
+        enddo
+      enddo
+
+      do ks=kss,kse
+        sumps=vgsums(2*ks-1)
+        sumns=vgsums(2*ks  )
+!
+        if(sumps*(-sumns).gt.1.) then
+          sfacs=-sumns/sumps
+          rfacs=1./sfacs
+        else
+          sfacs=0.
+          rfacs=0.
+        endif
+!
+        DO K=KTS,KTE
+          DO J=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+              dsks=s1(i,j,k,ks)*rdvol(i,j,k)
+              if(sfacs.lt.1.) then
+                if(dsks.gt.0.) dsks=dsks*sfacs
+              endif
+              tcs(i,j,k,ks)=tcs(i,j,k,ks)+dsks
+            enddo
+          enddo
+        enddo
+!-----------------------------------------------------------------------
+      enddo ! end of the loop by species
+109   continue
+!-----------------------------------------------------------------------
+!zjwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww
+!-----------------------------------------------------------------------
+      do ks=kss,kse ! loop by species
+        DO K=KTS,KTE
+          xsms(2*ks-1,k)=0.
+          xsms(2*ks  ,k)=0.
+          gsms(2*ks-1,k)=0.
+          gsms(2*ks  ,k)=0.
+!
+          DO J=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+              xsms(2*ks-1,k)=xsms(2*ks-1,k)+s  (i,j,k,ks)*dvol(i,j,k)
+              xsms(2*ks  ,k)=xsms(2*ks  ,k)+tcs(i,j,k,ks)*dvol(i,j,k)
+            enddo
+          enddo
+        enddo
+      enddo
+!
+      xsmp=0.
+      DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+          xsmp=pd(i,j)*dx(i,j)*dy*hbm2(i,j)+xsmp
+        enddo
+      enddo
+!
+!-----------------------------------------------------------------------
+!***  GLOBAL REDUCTION
+!-----------------------------------------------------------------------
+!
+# if defined(DM_PARALLEL) && !defined(STUBMPI)
+      CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+      lngth=1
+      CALL MPI_ALLREDUCE(xsmp,gsmp,lngth                                &
+     &                  ,MPI_DOUBLE_PRECISION,MPI_SUM                   &
+     &                  ,MPI_COMM_COMP,IRECV)
+# else
+      gsmp=xsmp
+# endif
+!
+!-----------------------------------------------------------------------
+!***  END OF GLOBAL REDUCTION
+!-----------------------------------------------------------------------
+!
+!
+!-----------------------------------------------------------------------
+!***  GLOBAL REDUCTION
+!-----------------------------------------------------------------------
+!
+# if defined(DM_PARALLEL) && !defined(STUBMPI)
+      CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+      lngth=(2*kse-2*kss+2)*(KTE-KTS+1)
+      CALL MPI_ALLREDUCE(XSMS,GSMS,lngth                                &
+     &                  ,MPI_DOUBLE_PRECISION,MPI_SUM                   &
+     &                  ,MPI_COMM_COMP,IRECV)
+# else
+      DO K=KTS,KTE
+        do ks=kss,kse
+          gsms(2*ks-1,k)=xsms(2*ks-1,k)
+          gsms(2*ks  ,k)=xsms(2*ks  ,k)
+        enddo
+      enddo
+# endif
+!
+      DO K=KTS,KTE
+        do ks=kss,kse
+          gsms_single(2*ks-1,k)=gsms(2*ks-1,k)
+          gsms_single(2*ks  ,k)=gsms(2*ks  ,k)
+        enddo
+      enddo
+!
+!-----------------------------------------------------------------------
+!***  END OF GLOBAL REDUCTION
+!-----------------------------------------------------------------------
+!
+
+      do ks=kss,kse
+        vgsms(2*ks-1)=0.
+        vgsms(2*ks  )=0.
+      enddo
+!
+      do ks=kss,kse
+        DO K=KTS,KTE
+          vgsms(2*ks-1)=gsms(2*ks-1,k)+vgsms(2*ks-1)
+          vgsms(2*ks  )=gsms(2*ks  ,k)+vgsms(2*ks  )
+        enddo
+      enddo
+!
+      sumdrrw=vgsms(6)+sumdrrw
+!
+      summass=0.0
+      DO K=KTS,KTE
+        DO J=MYJS2,MYJE2
+          DO I=MYIS1,MYIE1
+            summass=summass+dvol(i,j,k)
+          ENDDO
+        ENDDO
+      ENDDO
+!
+      if (first) then
+         sumrrw_first = vgsms(5)
+         gsmp_first = gsmp
+         summass_first = summass
+         first=.false.
+      end if
+!
+!     write(0,1000) ntsd,hours, &                                       ! 4,5
+!                   (vgsms(ks),ks=2*kss-1,2*kse), &                     ! 6-13
+!                   gsmp,gsmp_first,gsmp/gsmp_first, &                  ! 14-16
+!                   sumdrrw, &                                          ! 17
+!                   vgsms(5)/sumrrw_first,sumrrw_first, &               ! 18-19
+!                   summass,summass_first,summass/summass_first         ! 20-22
+ 1000 format('global vol sums ',i6,f8.3,30d13.5)
+!zjmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm
+                        endsubroutine mono
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+      END MODULE MODULE_ADVECTION
+!
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_BC_NMM.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_BC_NMM.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_BC_NMM.F	(revision 17)
@@ -0,0 +1,15 @@
+!
+      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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_BNDRY_COND.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_BNDRY_COND.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_BNDRY_COND.F	(revision 17)
@@ -0,0 +1,1243 @@
+!-----------------------------------------------------------------------
+!
+!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
+!-----------------------------------------------------------------------
+      REAL :: D06666=0.06666666
+!-----------------------------------------------------------------------
+!
+      CONTAINS
+!
+!***********************************************************************
+      SUBROUTINE BOCOH(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    & 
+     &                ,LB,ETA1,ETA2,PDTOP,PT,RES                        &
+     &                ,PD_BXS, PD_BXE, PD_BYS, PD_BYE                   &
+     &                ,T_BXS, T_BXE, T_BYS, T_BYE                       &
+     &                ,Q_BXS, Q_BXE, Q_BYS, Q_BYE                       &
+     &                ,U_BXS, U_BXE, U_BYS, U_BYE                       &
+     &                ,V_BXS, V_BXE, V_BYS, V_BYE                       &
+     &                ,Q2_BXS, Q2_BXE, Q2_BYS, Q2_BYE                   &
+     &                ,CWM_BXS, CWM_BXE, CWM_BYS, CWM_BYE               &
+     &                ,PD_BTXS, PD_BTXE, PD_BTYS, PD_BTYE               &
+     &                ,T_BTXS, T_BTXE, T_BTYS, T_BTYE                   &
+     &                ,Q_BTXS, Q_BTXE, Q_BTYS, Q_BTYE                   &
+     &                ,U_BTXS, U_BTXE, U_BTYS, U_BTYE                   &
+     &                ,V_BTXS, V_BTXE, V_BTYS, V_BTYE                   &
+     &                ,Q2_BTXS, Q2_BTXE, Q2_BTYS, Q2_BTYE               &
+     &                ,CWM_BTXS, CWM_BTXE, CWM_BTYS, CWM_BTYE           &
+     &                ,PD,T,Q,Q2,CWM,PINT                               &
+     &                ,MOIST,N_MOIST,SCALAR,N_SCALAR                    &
+#ifdef WRF_CHEM
+     &                ,CHEM,NUMG,CONFIG_FLAGS                           &
+#endif
+     &                ,SPEC_BDY_WIDTH,Z                                 &  
+     &                ,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:    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
+!   05-12-19  BLACK      - CONVERTED FROM IKJ TO IJK
+!   06-06-02  GOPAL      - MODIFICATIONS FOR NESTING
+!   07-11-14  PYLE       - UPDATED FOR NEW WRF BOUNDARY FILE STRUCTURE
+!     
+! 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) :: 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
+!
+      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,1,SPEC_BDY_WIDTH)                          &
+     &                           ,INTENT(INOUT) :: PD_BYS, PD_BYE       &
+     &                                            ,PD_BTYS,PD_BTYE
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,SPEC_BDY_WIDTH)                   &
+     &                           ,INTENT(INOUT) :: T_BYS, T_BYE        &
+     &                                            ,U_BYS, U_BYE        &
+     &                                            ,V_BYS, V_BYE        &
+     &                                            ,Q_BYS, Q_BYE        &
+     &                                            ,Q2_BYS, Q2_BYE      &
+     &                                            ,CWM_BYS, CWM_BYE    &
+     &                                            ,T_BTYS, T_BTYE      &
+     &                                            ,U_BTYS, U_BTYE      &
+     &                                            ,V_BTYS, V_BTYE      &
+     &                                            ,Q_BTYS, Q_BTYE      &
+     &                                            ,Q2_BTYS, Q2_BTYE    &
+     &                                            ,CWM_BTYS, CWM_BTYE  
+
+      REAL,DIMENSION(JMS:JME,1,SPEC_BDY_WIDTH)                         &
+     &                           ,INTENT(INOUT) :: PD_BXS, PD_BXE      &
+     &                                            ,PD_BTXS,PD_BTXE
+
+      REAL,DIMENSION(JMS:JME,KMS:KME,SPEC_BDY_WIDTH)                   &
+     &                           ,INTENT(INOUT) :: T_BXS, T_BXE        &
+     &                                            ,U_BXS, U_BXE        &
+     &                                            ,V_BXS, V_BXE        &
+     &                                            ,Q_BXS, Q_BXE        &
+     &                                            ,Q2_BXS, Q2_BXE      &
+     &                                            ,CWM_BXS, CWM_BXE    &
+     &                                            ,T_BTXS, T_BTXE      &
+     &                                            ,U_BTXS, U_BTXE      &
+     &                                            ,V_BTXS, V_BTXE      &
+     &                                            ,Q_BTXS, Q_BTXE      &
+     &                                            ,Q2_BTXS, Q2_BTXE    &
+     &                                            ,CWM_BTXS, CWM_BTXE  
+                                               
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: RES
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: PD
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM      &
+     &                                                        ,PINT,Q   &
+     &                                                        ,Q2,T,Z
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,NUM_MOIST)                 &
+     &                                           ,INTENT(INOUT) :: MOIST
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,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 :: I,IB,IBDY,II,IIM,IM,IRTN,ISIZ1,ISIZ2                &
+     &          ,J,JB,JJ,JJM,JM,K,KK,N,NN,NREC,NUMGAS,NV,REC
+      INTEGER :: MY_IS_GLB,MY_JS_GLB,MY_IE_GLB,MY_JE_GLB  
+      INTEGER :: I_M,ILPAD1,IRPAD1,JBPAD1,JTPAD1
+!
+      REAL :: BCHR,CONVFAC,CWK,DT,PLYR,RRI
+!
+      LOGICAL :: E_BDY,W_BDY,N_BDY,S_BDY
+!
+      CHARACTER(LEN=255) :: message
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+#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) THEN 
+            JB=1         ! Which cell in from boundary
+            JJ=1         ! Which cell in the domain
+
+          DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+            PD_BYS(I,1,JB)=PD_BYS(I,1,JB)+PD_BTYS(I,1,JB)*DT
+            PD(I,JJ)=PD_BYS(I,1,JB)
+          ENDDO
+
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+          DO K=KTS,KTE
+            DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              T_BYS(I,K,JB)=T_BYS(I,K,JB)+T_BTYS(I,K,JB)*DT
+              Q_BYS(I,K,JB)=Q_BYS(I,K,JB)+Q_BTYS(I,K,JB)*DT
+              Q2_BYS(I,K,JB)=Q2_BYS(I,K,JB)+Q2_BTYS(I,K,JB)*DT
+              CWM_BYS(I,K,JB)=CWM_BYS(I,K,JB)+CWM_BTYS(I,K,JB)*DT
+!
+              T(I,JJ,K)=T_BYS(I,K,JB)
+              Q(I,JJ,K)=Q_BYS(I,K,JB)
+              Q2(I,JJ,K)=Q2_BYS(I,K,JB)
+              CWM(I,JJ,K)=CWM_BYS(I,K,JB)
+              PINT(I,JJ,K)=ETA1(K)*PDTOP                                &
+     &                    +ETA2(K)*PD(I,JJ)*RES(I,JJ)+PT
+            ENDDO
+           ENDDO
+
+          ELSEIF(N_BDY.AND.IBDY==2) THEN
+            JB=1         ! Which cell in from boundary
+            JJ=JJM       ! Which cell in the domain
+
+!
+          DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+            PD_BYE(I,1,JB)=PD_BYE(I,1,JB)+PD_BTYE(I,1,JB)*DT
+            PD(I,JJ)=PD_BYE(I,1,JB)
+          ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+          DO K=KTS,KTE
+            DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              T_BYE(I,K,JB)=T_BYE(I,K,JB)+T_BTYE(I,K,JB)*DT
+              Q_BYE(I,K,JB)=Q_BYE(I,K,JB)+Q_BTYE(I,K,JB)*DT
+              Q2_BYE(I,K,JB)=Q2_BYE(I,K,JB)+Q2_BTYE(I,K,JB)*DT
+              CWM_BYE(I,K,JB)=CWM_BYE(I,K,JB)+CWM_BTYE(I,K,JB)*DT
+!
+              T(I,JJ,K)=T_BYE(I,K,JB)
+              Q(I,JJ,K)=Q_BYE(I,K,JB)
+              Q2(I,JJ,K)=Q2_BYE(I,K,JB)
+              CWM(I,JJ,K)=CWM_BYE(I,K,JB)
+              PINT(I,JJ,K)=ETA1(K)*PDTOP                                &
+     &                    +ETA2(K)*PD(I,JJ)*RES(I,JJ)+PT
+            ENDDO
+          ENDDO
+
+!         ENDIF   ! for N/S boundaries
+
+!
+          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,JJ,K,I_M)=Q(I,JJ,K)/(1.-Q(I,JJ,K))
+              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,JJ,K,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,JJ,K,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,JJ,K),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,JJ,K)+PINT(I,JJ,KK))*0.5
+              RRI=R_D*T(I,JJ,K)*(1.+.608*Q(I,JJ,K))/PLYR
+              CONVFAC=PLYR/RGASUNIV/T(I,JJ,K)
+              CALL BDY_CHEM_VALUE_SORGAM (CHEM(I,K,JJ,NV),Z(I,JJ,K),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) THEN  
+            IB=1         ! Which cell in from boundary 
+            II=1         ! Which cell in the domain
+!
+          DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
+            IF(MOD(J,2)==1)THEN
+              PD_BXS(J,1,IB)=PD_BXS(J,1,IB)+PD_BTXS(J,1,IB)*DT
+              PD(II,J)=PD_BXS(J,1,IB)
+            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_BXS(J,K,IB)=T_BXS(J,K,IB)+T_BTXS(J,K,IB)*DT
+                Q_BXS(J,K,IB)=Q_BXS(J,K,IB)+Q_BTXS(J,K,IB)*DT
+                Q2_BXS(J,K,IB)=Q2_BXS(J,K,IB)+Q2_BTXS(J,K,IB)*DT
+                CWM_BXS(J,K,IB)=CWM_BXS(J,K,IB)+CWM_BTXS(J,K,IB)*DT
+!
+                T(II,J,K)=T_BXS(J,K,IB)
+                Q(II,J,K)=Q_BXS(J,K,IB)
+                Q2(II,J,K)=Q2_BXS(J,K,IB)
+                CWM(II,J,K)=CWM_BXS(J,K,IB)
+                PINT(II,J,K)=ETA1(K)*PDTOP                              &
+     &                      +ETA2(K)*PD(II,J)*RES(II,J)+PT
+              ENDIF
+!
+            ENDDO
+          ENDDO
+
+          ELSEIF(E_BDY.AND.IBDY==2) THEN
+            IB=1         ! Which cell in from boundary
+            II=IIM       ! Which cell in the domain
+
+          DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
+            IF(MOD(J,2)==1)THEN
+              PD_BXE(J,1,IB)=PD_BXE(J,1,IB)+PD_BTXE(J,1,IB)*DT
+              PD(II,J)=PD_BXE(J,1,IB)
+            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_BXE(J,K,IB)=T_BXE(J,K,IB)+T_BTXE(J,K,IB)*DT
+                Q_BXE(J,K,IB)=Q_BXE(J,K,IB)+Q_BTXE(J,K,IB)*DT
+                Q2_BXE(J,K,IB)=Q2_BXE(J,K,IB)+Q2_BTXE(J,K,IB)*DT
+                CWM_BXE(J,K,IB)=CWM_BXE(J,K,IB)+CWM_BTXE(J,K,IB)*DT
+!
+                T(II,J,K)=T_BXE(J,K,IB)
+                Q(II,J,K)=Q_BXE(J,K,IB)
+                Q2(II,J,K)=Q2_BXE(J,K,IB)
+                CWM(II,J,K)=CWM_BXE(J,K,IB)
+                PINT(II,J,K)=ETA1(K)*PDTOP                              &
+     &                      +ETA2(K)*PD(II,J)*RES(II,J)+PT
+              ENDIF
+!
+            ENDDO
+          ENDDO
+!
+!          ENDIF  ! for W/E boundaries
+!
+          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,J,K,I_M)=Q(II,J,K)/(1.-Q(II,J,K))
+                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,J,K,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,J,K,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,J,K),NV,NUMG)
+                 ENDDO
+!$omp parallel do                                                       &
+!$omp& private(nv)
+                 DO NV=NUMG+1,NUM_CHEM
+                    PLYR=(PINT(II,J,K)+PINT(II,J,KK))*0.5
+                    RRI=R_D*T(II,J,K)*(1.+P608*Q(II,J,K))/PLYR
+                    CONVFAC=PLYR/RGASUNIV/T(II,J,K)
+                    CALL BDY_CHEM_VALUE_SORGAM (CHEM(II,K,J,NV),Z(II,J,K),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
+          CWK=PD(I,2)
+          PD(I,2)=0.25*(PD(I,1)+PD(I+1,1)+PD(I,3)+PD(I+1,3))
+!
+!***  NESTING TEST
+!
+          IF(I<=IDE-1.AND.ABS(CWK-PD(I,2))>=300.)THEN
+            WRITE(message,*)'PSEUDO HYDROSTATIC IMBALANCE AT THE SOUTHERN BOUNDARY AT',I,2,'GRID #',GRIDID
+            CALL wrf_message(trim(message))
+            WRITE(message,*)'             ',CWK/100.
+            CALL wrf_message(trim(message))
+            WRITE(message,*)PD(I,3)/100.,'               ',PD(I+1,3)/100.
+            CALL wrf_message(trim(message))
+            WRITE(message,*)'             ',PD(I,2)/100.
+            CALL wrf_message(trim(message))
+            WRITE(message,*)PD(I,1)/100.,'             ',PD(I+1,1)/100.
+            CALL wrf_message(trim(message))
+            CALL wrf_message('   ')
+          ENDIF
+
+        ENDDO
+      ENDIF
+!
+!***  ONE ROW SOUTH OF NORTHERN BOUNDARY
+!
+      IF(N_BDY)THEN
+
+        DO I=MYIS,MYIE1
+          CWK=PD(I,JJM-1)
+!!        write(message,*)'I, PD is:', PD(I,JJM), PD(I,JJM-2),PD(I+1,JJM-2),PD(I+1,JJM)
+!!        call wrf_message(trim(message))
+          PD(I,JJM-1)=0.25*(PD(I,JJM-2)+PD(I+1,JJM-2)                   &
+     &                     +PD(I,JJM)+PD(I+1,JJM))
+!
+!***  NESTING TEST
+!
+          IF(I<=IDE-1.AND.ABS(CWK-PD(I,JJM-1))>=300.)THEN
+            WRITE(message,*)'PSEUDO HYDROSTATIC IMBALANCE AT THE NORTHERN BOUNDARY AT',I,JJM-1,'GRID #',GRIDID
+            CALL wrf_message(trim(message))
+            WRITE(message,*)'             ',CWK/100.
+            CALL wrf_message(trim(message))
+            WRITE(message,*)PD(I,JJM)/100.,'               ',PD(I+1,JJM)/100.
+            CALL wrf_message(trim(message))
+            WRITE(message,*)'             ',PD(I,JJM-1)/100.
+            CALL wrf_message(trim(message))
+            WRITE(message,*)PD(I,JJM-2)/100.,'             ',PD(I+1,JJM-2)/100.
+            CALL wrf_message(trim(message))
+            CALL wrf_message('   ')
+          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
+            PD(1,JJ)=0.25*(PD(1,JJ-1)+PD(2,JJ-1)+PD(1,JJ+1)+PD(2,JJ+1))
+!
+!***  NESTING TEST
+!
+             IF(ABS(CWK-PD(1,JJ))>300.)THEN
+              WRITE(message,*)'PSEUDO HYDROSTATIC IMBALANCE AT THE WESTERN BOUNDARY AT',1,JJ,'GRID #',GRIDID
+              CALL wrf_message(trim(message))
+              WRITE(message,*)'             ',CWK/100.
+              CALL wrf_message(trim(message))
+              WRITE(message,*)PD(1,JJ+1)/100.,'               ',PD(2,JJ+1)/100.
+              CALL wrf_message(trim(message))
+              WRITE(message,*)'             ',PD(1,JJ)/100.
+              CALL wrf_message(trim(message))
+              WRITE(message,*)PD(1,JJ-1)/100.,'               ',PD(2,JJ-1)/100.
+              CALL wrf_message(trim(message))
+              CALL wrf_message('   ')
+            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
+            CWK=PD(IIM-1,J)
+            JJ=J
+            PD(IIM-1,JJ)=0.25*(PD(IIM-1,JJ-1)+PD(IIM,JJ-1)              &
+     &                        +PD(IIM-1,JJ+1)+PD(IIM,JJ+1))
+!
+!***  NESTING TEST
+!
+             IF(ABS(CWK-PD(IIM-1,JJ))>300.)THEN
+              WRITE(message,*)'PSEUDO HYDROSTATIC IMBALANCE AT THE EASTERN BOUNDARY AT',IIM-1,JJ,'GRID #',GRIDID
+              CALL wrf_message(trim(message))
+              WRITE(message,*)'             ',CWK/100.
+              CALL wrf_message(trim(message))
+              WRITE(message,*)PD(IIM-1,JJ+1)/100.,'               ',PD(IIM,JJ+1)/100.
+              CALL wrf_message(trim(message))
+              WRITE(message,*)'             ',PD(IIM-1,JJ)/100.
+              CALL wrf_message(trim(message))
+              WRITE(message,*)PD(IIM-1,JJ-1)/100.,'               ',PD(IIM,JJ-1)/100.
+              CALL wrf_message(trim(message))
+              CALL wrf_message('   ')
+            ENDIF
+
+          ENDIF
+!
+        ENDDO
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,jj,k)
+      DO 200 K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!
+!***  ONE ROW NORTH OF SOUTHERN BOUNDARY
+!
+      IF(S_BDY)THEN
+        DO I=MYIS,MYIE1
+          T(I,2,K)=(T(I,1,K)+T(I+1,1,K)+T(I,3,K)+T(I+1,3,K))*0.25
+          Q(I,2,K)=(Q(I,1,K)+Q(I+1,1,K)+Q(I,3,K)+Q(I+1,3,K))*0.25
+          Q2(I,2,K)=(Q2(I,1,K)+Q2(I+1,1,K)+Q2(I,3,K)+Q2(I+1,3,K))*0.25
+          CWM(I,2,K)=(CWM(I,1,K)+CWM(I+1,1,K)+CWM(I,3,K)+CWM(I+1,3,K))  &
+     &               *0.25
+          PINT(I,2,K)=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,2,K,I_M)=Q(I,2,K)/(1.-Q(I,2,K))
+            ENDDO
+          ELSE
+            DO I=MYIS,MYIE1
+              MOIST(I,2,K,I_M)=(MOIST(I,1,K,I_M)                        &
+     &                         +MOIST(I+1,1,K,I_M)                      &
+     &                         +MOIST(I,3,K,I_M)                        &
+     &                         +MOIST(I+1,3,K,I_M))*0.25
+            ENDDO
+          ENDIF
+        ENDDO
+!
+        DO I_M=2,N_SCALAR
+          DO I=MYIS,MYIE1
+            SCALAR(I,2,K,I_M)=(SCALAR(I,1,K,I_M)                        &
+     &                        +SCALAR(I+1,1,K,I_M)                      &
+     &                        +SCALAR(I,3,K,I_M)                        &
+     &                        +SCALAR(I+1,3,K,I_M))*0.25
+          ENDDO
+        ENDDO
+!
+      ENDIF
+!
+!***  ONE ROW SOUTH OF NORTHERN BOUNDARY
+!
+      IF(N_BDY)THEN
+        DO I=MYIS,MYIE1
+          T(I,JJM-1,K)=(T(I,JJM-2,K)+T(I+1,JJM-2,K)                     &
+     &                 +T(I,JJM,K)+T(I+1,JJM,K))                        &
+     &                 *0.25
+          Q(I,JJM-1,K)=(Q(I,JJM-2,K)+Q(I+1,JJM-2,K)                     &
+     &                 +Q(I,JJM,K)+Q(I+1,JJM,K))                        &
+     &                 *0.25
+          Q2(I,JJM-1,K)=(Q2(I,JJM-2,K)+Q2(I+1,JJM-2,K)                  &
+     &                  +Q2(I,JJM,K)+Q2(I+1,JJM,K))                     &
+     &                  *0.25
+          CWM(I,JJM-1,K)=(CWM(I,JJM-2,K)+CWM(I+1,JJM-2,K)               &
+     &                   +CWM(I,JJM,K)+CWM(I+1,JJM,K))                  &
+     &                   *0.25
+          PINT(I,JJM-1,K)=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,JJM-1,K,I_M)=Q(I,JJM-1,K)/(1.-Q(I,JJM-1,K))
+            ENDDO
+          ELSE
+            DO I=MYIS,MYIE1
+              MOIST(I,JJM-1,K,I_M)=(MOIST(I,JJM-2,K,I_M)                &
+     &                             +MOIST(I+1,JJM-2,K,I_M)              &
+     &                             +MOIST(I,JJM,K,I_M)                  &
+     &                             +MOIST(I+1,JJM,K,I_M))*0.25
+            ENDDO
+
+          ENDIF
+        ENDDO
+!
+        DO I_M=2,N_SCALAR
+          DO I=MYIS,MYIE1
+            SCALAR(I,JJM-1,K,I_M)=(SCALAR(I,JJM-2,K,I_M)                &
+     &                            +SCALAR(I+1,JJM-2,K,I_M)              &
+     &                            +SCALAR(I,JJM,K,I_M)                  &
+     &                            +SCALAR(I+1,JJM,K,I_M))*0.25
+          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
+            T(1,JJ,K)=(T(1,JJ-1,K)+T(2,JJ-1,K)                          &
+     &                +T(1,JJ+1,K)+T(2,JJ+1,K))                         &
+     &                *0.25
+            Q(1,JJ,K)=(Q(1,JJ-1,K)+Q(2,JJ-1,K)                          &
+     &                +Q(1,JJ+1,K)+Q(2,JJ+1,K))                         &
+     &                *0.25
+            Q2(1,JJ,K)=(Q2(1,JJ-1,K)+Q2(2,JJ-1,K)                       &
+     &                 +Q2(1,JJ+1,K)+Q2(2,JJ+1,K))                      &
+     &                 *0.25
+            CWM(1,JJ,K)=(CWM(1,JJ-1,K)+CWM(2,JJ-1,K)                    &
+     &                  +CWM(1,JJ+1,K)+CWM(2,JJ+1,K))                   &
+     &                  *0.25
+            PINT(1,JJ,K)=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,JJ,K,I_M)=Q(1,JJ,K)/(1.-Q(1,JJ,K))     
+              ELSE  
+                MOIST(1,JJ,K,I_M)=(MOIST(1,JJ-1,K,I_M)                  &
+     &                            +MOIST(2,JJ-1,K,I_M)                  &
+     &                            +MOIST(1,JJ+1,K,I_M)                  &
+     &                            +MOIST(2,JJ+1,K,I_M))*0.25
+              ENDIF
+            ENDDO    
+!
+            DO I_M=2,N_SCALAR
+              SCALAR(1,JJ,K,I_M)=(SCALAR(1,JJ-1,K,I_M)                  &
+     &                           +SCALAR(2,JJ-1,K,I_M)                  &
+     &                           +SCALAR(1,JJ+1,K,I_M)                  &
+     &                           +SCALAR(2,JJ+1,K,I_M))*0.25
+            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
+            T(IIM-1,JJ,K)=(T(IIM-1,JJ-1,K)+T(IIM,JJ-1,K)                &
+     &                    +T(IIM-1,JJ+1,K)+T(IIM,JJ+1,K))               &
+     &                    *0.25
+            Q(IIM-1,JJ,K)=(Q(IIM-1,JJ-1,K)+Q(IIM,JJ-1,K)                &
+     &                    +Q(IIM-1,JJ+1,K)+Q(IIM,JJ+1,K))               &
+     &                    *0.25
+            Q2(IIM-1,JJ,K)=(Q2(IIM-1,JJ-1,K)+Q2(IIM,JJ-1,K)             &
+     &                     +Q2(IIM-1,JJ+1,K)+Q2(IIM,JJ+1,K))            &
+     &                     *0.25
+            CWM(IIM-1,JJ,K)=(CWM(IIM-1,JJ-1,K)+CWM(IIM,JJ-1,K)          &
+     &                      +CWM(IIM-1,JJ+1,K)+CWM(IIM,JJ+1,K))         &
+     &                      *0.25
+            PINT(IIM-1,JJ,K)=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,JJ,K,I_M)=Q(IIM-1,JJ,K)/(1.-Q(IIM-1,JJ,K))
+              ELSE
+                MOIST(IIM-1,JJ,K,I_M)=(MOIST(IIM-1,JJ-1,K,I_M)                   &
+     &                                +MOIST(IIM,JJ-1,K,I_M)                     &
+     &                                +MOIST(IIM-1,JJ+1,K,I_M)                   &
+     &                                +MOIST(IIM,JJ+1,K,I_M))*0.25
+                ENDIF
+              ENDDO
+!
+              DO I_M=2,N_SCALAR
+                SCALAR(IIM-1,JJ,K,I_M)=(SCALAR(IIM-1,JJ-1,K,I_M)                    &
+     &                                 +SCALAR(IIM,JJ-1,K,I_M)                      &
+     &                                 +SCALAR(IIM-1,JJ+1,K,I_M)                    &
+     &                                 +SCALAR(IIM,JJ+1,K,I_M))*0.25
+              ENDDO
+!
+          ENDIF
+!
+        ENDDO
+      ENDIF
+!-----------------------------------------------------------------------
+!
+  200 CONTINUE
+!
+!-----------------------------------------------------------------------
+      END SUBROUTINE BOCOH
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      SUBROUTINE BOCOV(GRIDID,NTSD,DT,LB                                &
+     &                ,U_BXS,U_BXE,U_BYS,U_BYE                         &  
+     &                ,V_BXS,V_BXE,V_BYS,V_BYE                         &  
+     &                ,U_BTXS,U_BTXE,U_BTYS,U_BTYE                     &  
+     &                ,V_BTXS,V_BTXE,V_BTYS,V_BTYE                     &  
+     &                ,U,V                                              &
+     &                ,SPEC_BDY_WIDTH                                   &  
+     &                ,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:    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
+!   05-12-19  BLACK      - CONVERTED FROM IKJ TO IJK
+!   06-06-02  GOPAL      - MODIFICATIONS FOR NESTING
+!     
+! 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) :: SPEC_BDY_WIDTH
+!
+      INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW
+!
+      INTEGER,INTENT(IN) :: GRIDID
+      INTEGER,INTENT(IN) :: LB,NTSD
+!
+      REAL,INTENT(IN) :: DT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,SPEC_BDY_WIDTH),INTENT(INOUT) ::     &
+     &                                          U_BYS,U_BYE,V_BYS,V_BYE &
+     &                                         ,U_BTYS,U_BTYE           &
+     &                                         ,V_BTYS,V_BTYE           
+
+      REAL,DIMENSION(JMS:JME,KMS:KME,SPEC_BDY_WIDTH),INTENT(INOUT) ::     &
+     &                                          U_BXS,U_BXE,V_BXS,V_BXE &
+     &                                         ,U_BTXS,U_BTXE           &
+     &                                         ,V_BTXS,V_BTXE 
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),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,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) THEN
+!
+            JB=1         ! Which cell in from Boundary 
+            JJ=1         ! Which cell in the Domain
+!
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+          DO K=KTS,KTE
+            DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              U_BYS(I,K,JB)=U_BYS(I,K,JB)+U_BTYS(I,K,JB)*DT
+              V_BYS(I,K,JB)=V_BYS(I,K,JB)+V_BTYS(I,K,JB)*DT
+              U(I,JJ,K)=U_BYS(I,K,JB)
+              V(I,JJ,K)=V_BYS(I,K,JB)
+            ENDDO
+          ENDDO
+!
+
+          ELSEIF(N_BDY.AND.IBDY==2) THEN
+            JB=1         ! Which cell in from Boundary
+            JJ=JJM       ! Which cell in the Domain
+
+!$omp parallel do                                                       &
+!$omp& private(i,k)
+          DO K=KTS,KTE
+            DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              U_BYE(I,K,JB)=U_BYE(I,K,JB)+U_BTYE(I,K,JB)*DT
+              V_BYE(I,K,JB)=V_BYE(I,K,JB)+V_BTYE(I,K,JB)*DT
+              U(I,JJ,K)=U_BYE(I,K,JB)
+              V(I,JJ,K)=V_BYE(I,K,JB)
+            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) THEN
+            IB=1         ! Which cell in from boundary
+            II=1         ! Which cell in the domain
+!
+!$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_BXS(J,K,IB)=U_BXS(J,K,IB)+U_BTXS(J,K,IB)*DT
+                V_BXS(J,K,IB)=V_BXS(J,K,IB)+V_BTXS(J,K,IB)*DT
+                U(II,J,K)=U_BXS(J,K,IB)
+                V(II,J,K)=V_BXS(J,K,IB)
+              ENDIF
+            ENDDO
+          ENDDO
+
+        ELSEIF (E_BDY.AND.IBDY==2) THEN
+            IB=1         ! Which cell in from boundary
+            II=IIM       ! Which cell in the domain
+
+!$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_BXE(J,K,IB)=U_BXE(J,K,IB)+U_BTXE(J,K,IB)*DT
+                V_BXE(J,K,IB)=V_BXE(J,K,IB)+V_BTXE(J,K,IB)*DT
+                U(II,J,K)=U_BXE(J,K,IB)
+                V(II,J,K)=V_BXE(J,K,IB)
+              ENDIF
+            ENDDO
+          ENDDO
+
+!
+        ENDIF
+
+
+
+      ENDDO
+
+!
+!-----------------------------------------------------------------------
+!***  EXTRAPOLATION OF TANGENTIAL VELOCITY AT OUTFLOW POINTS
+!***  BASED ON SOME DISCUSSIONS WITH ZAVISA, AND MY 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,1,K)<0.)U(I,1,K)=2.*U(I,3,K)-U(I,5,K)
+        ENDDO
+      ENDIF
+!
+!***  NORTHERN BOUNDARY
+!
+      IF(N_BDY)THEN
+        DO I=MYIS1_P1,MYIE2_P1
+          IF(V(I,JJM,K)>0.)                                             &
+     &        U(I,JJM,K)=2.*U(I,JJM-2,K)-U(I,JJM-4,K)
+        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,JJ,K)<0.)                                            &
+     &          V(1,JJ,K)=2.*V(2,JJ,K)-V(3,JJ,K)
+          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,JJ,K)>0.)                                          &
+     &          V(IIM,JJ,K)=2.*V(IIM-1,JJ,K)-V(IIM-2,JJ,K)
+          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,2,K)=D06666*(4.*(U(1,1,K)+U(2,1,K)+U(2,3,K))                &
+     &                     + U(1,2,K)+U(1,4,K)+U(2,4,K))
+        V(2,2,K)=D06666*(4.*(V(1,1,K)+V(2,1,K)+V(2,3,K))                &
+     &                      +V(1,2,K)+V(1,4,K)+V(2,4,K))
+      ENDIF
+!
+!***  SOUTHEAST CORNER
+!
+      IF(S_BDY.AND.E_BDY)THEN
+        U(IIM-1,2,K)=D06666*(4.*(U(IIM-2,1,K)+U(IIM-1,1,K)              &
+     &                          +U(IIM-2,3,K))                          &
+     &                          +U(IIM,2,K)+U(IIM,4,K)+U(IIM-1,4,K))
+        V(IIM-1,2,K)=D06666*(4.*(V(IIM-2,1,K)+V(IIM-1,1,K)              &
+     &                          +V(IIM-2,3,K))                          &
+     &                          +V(IIM,2,K)+V(IIM,4,K)+V(IIM-1,4,K))
+      ENDIF
+!
+!***  NORTHWEST CORNER
+!
+      IF(N_BDY.AND.W_BDY)THEN
+        U(2,JJM-1,K)=D06666*(4.*(U(1,JJM,K)+U(2,JJM,K)+U(2,JJM-2,K))    &
+     &                          +U(1,JJM-1,K)+U(1,JJM-3,K)              &
+     &                          +U(2,JJM-3,K))
+        V(2,JJM-1,K)=D06666*(4.*(V(1,JJM,K)+V(2,JJM,K)+V(2,JJM-2,K))    &
+     &                          +V(1,JJM-1,K)+V(1,JJM-3,K)              &
+     &                          +V(2,JJM-3,K))
+      ENDIF
+!
+!***  NORTHEAST CORNER
+!
+      IF(N_BDY.AND.E_BDY)THEN
+        U(IIM-1,JJM-1,K)=                                               &
+     &    D06666*(4.*(U(IIM-2,JJM,K)+U(IIM-1,JJM,K)+U(IIM-2,JJM-2,K))   &
+     &               +U(IIM,JJM-1,K)+U(IIM,JJM-3,K)+U(IIM-1,JJM-3,K))
+        V(IIM-1,JJM-1,K)=                                               &
+     &    D06666*(4.*(V(IIM-2,JJM,K)+V(IIM-1,JJM,K)+V(IIM-2,JJM-2,K))   &
+     &               +V(IIM,JJM-1,K)+V(IIM,JJM-3,K)+V(IIM-1,JJM-3,K))
+      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,2,K)=(U(I-1,1,K)+U(I,1,K)+U(I-1,3,K)+U(I,3,K))*0.25
+          V(I,2,K)=(V(I-1,1,K)+V(I,1,K)+V(I-1,3,K)+V(I,3,K))*0.25
+        ENDDO
+      ENDIF
+!
+!***  ONE ROW SOUTH OF NORTHERN BOUNDARY
+!
+      IF(N_BDY)THEN
+        DO I=MYIS2,MYIE2
+          U(I,JJM-1,K)=(U(I-1,JJM-2,K)+U(I,JJM-2,K)                     &
+     &                 +U(I-1,JJM,K)+U(I,JJM,K))*0.25
+          V(I,JJM-1,K)=(V(I-1,JJM-2,K)+V(I,JJM-2,K)                     &
+     &                 +V(I-1,JJM,K)+V(I,JJM,K))*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,JJ,K)=(U(1,JJ-1,K)+U(2,JJ-1,K)                          &
+     &                +U(1,JJ+1,K)+U(2,JJ+1,K))*0.25
+            V(1,JJ,K)=(V(1,JJ-1,K)+V(2,JJ-1,K)                          &
+     &                +V(1,JJ+1,K)+V(2,JJ+1,K))*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,JJ,K)=0.25*(U(IIM-1,JJ-1,K)+U(IIM,JJ-1,K)           &
+     &                         +U(IIM-1,JJ+1,K)+U(IIM,JJ+1,K))
+            V(IIM-1,JJ,K)=0.25*(V(IIM-1,JJ-1,K)+V(IIM,JJ-1,K)           &
+     &                         +V(IIM-1,JJ+1,K)+V(IIM,JJ+1,K))
+          ENDIF
+        ENDDO
+      ENDIF
+!-----------------------------------------------------------------------
+!
+  300 CONTINUE
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE BOCOV
+!
+!-----------------------------------------------------------------------
+!
+      END MODULE MODULE_BNDRY_COND
+!
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_CLDWTR.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_CLDWTR.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_CLDWTR.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_CTLBLK.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_CTLBLK.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_CTLBLK.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_DIFFUSION_NMM.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_DIFFUSION_NMM.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_DIFFUSION_NMM.F	(revision 17)
@@ -0,0 +1,484 @@
+!-----------------------------------------------------------------------
+!
+!NCEP_MESO:MODEL_LAYER: HORIZONTAL DIFFUSION
+!
+!-----------------------------------------------------------------------
+!
+#include "nmm_loop_basemacros.h"
+#include "nmm_loop_macros.h"
+!
+!-----------------------------------------------------------------------
+!
+      MODULE MODULE_DIFFUSION_NMM
+!
+!-----------------------------------------------------------------------
+      USE MODULE_MODEL_CONSTANTS
+      USE MODULE_CONFIGURE,             ONLY : GRID_CONFIG_REC_TYPE
+      USE MODULE_STATE_DESCRIPTION
+!-----------------------------------------------------------------------
+!
+      LOGICAL :: SECOND=.TRUE.
+      INTEGER :: KSMUD=1
+!
+!-----------------------------------------------------------------------
+!
+      CONTAINS
+!
+!***********************************************************************
+      SUBROUTINE HDIFF(NTSD,DT,FIS,DY,HDAC,HDACV                        &
+     &                ,HBM2,DETA1,SIGMA                                 &
+#ifdef HWRF
+     &                ,T,Q,U,V,Q2,Z,W,SM,SICE,h_diff                    &
+#else
+     &                ,T,Q,U,V,Q2,Z,W,SM,SICE                           &
+#endif
+     &                ,DEF3D                                            &
+     &                ,IHE,IHW,IVE,IVW                                  &
+     &                ,CONFIG_FLAGS                                     &
+     &                ,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
+!   05-12-12  BLACK      - CONVERTED FROM IKJ TO IJK
+!   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
+!
+!-----------------------------------------------------------------------
+!
+!***  STRUCTURE THAT CONTAINS RUN-TIME CONFIGURATION (NAMELIST) DATA FOR DOMAIN
+!
+      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) :: NTSD
+!
+      REAL,INTENT(IN) :: DT,DY
+#ifdef HWRF
+      REAL,INTENT(IN) :: H_DIFF  
+#endif
+!
+      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,JMS:JME,KMS:KME),INTENT(OUT) :: DEF3D          
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: W,Z
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: T,Q,Q2   &
+     &                                                        ,U,V
+!
+      INTEGER, DIMENSION(JMS:JME), INTENT(IN) :: IHE,IHW,IVE,IVW
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: SIGMA
+!
+!-----------------------------------------------------------------------
+!***  LOCAL VARIABLES
+!-----------------------------------------------------------------------
+!
+      INTEGER :: I,J,K,KS
+!
+      REAL :: DEF_IJ,DEFSK,DEFTK,HKNE_IJ,HKSE_IJ,Q2L,RDY,SLOP,SLOPHC    &
+     &       ,UTK,VKNE_IJ,VKSE_IJ,VTK,DEF1,DEF2,DEF3,DEF4
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: DEF,HKNE,HKSE          &
+     &                                          ,Q2DIF,Q2NE,Q2SE        &
+     &                                          ,QDIF,QNE,QSE,SNE,SSE   &
+     &                                          ,TDIF,TNE,TSE           &
+     &                                          ,UDIF,UNE,USE           &
+     &                                          ,VDIF,VKNE,VKSE,VNE,VSE
+!
+      LOGICAL :: CILINE,WATSLOP
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+#ifdef HWRF
+      SLOPHC=SLOPHT*SQRT(2.)*0.5*9.
+#else
+      SLOPHC=config_flags%slophc
+#endif
+      RDY=1./DY
+!
+      DO J=JTS-5,JTE+5
+      DO I=ITS-5,ITE+5
+        DEF(I,J)=0.
+        TNE(I,J)=0.
+        QNE(I,J)=0.
+        Q2NE(I,J)=0.
+        HKNE(I,J)=0.
+        UNE(I,J)=0.
+        VNE(I,J)=0.
+        VKNE(I,J)=0.
+        TSE(I,J)=0.
+        QSE(I,J)=0.
+        Q2SE(I,J)=0.
+        HKSE(I,J)=0.
+        USE(I,J)=0.
+        VSE(I,J)=0.
+        VKSE(I,J)=0.
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***
+!***  DIFFUSING Q2 AT GROUND LEVEL DOES NOT MATTER
+!***  BECAUSE USTAR2 IS RECALCULATED.
+!***
+!-----------------------------------------------------------------------
+!***  ITERATION LOOP
+!-----------------------------------------------------------------------
+!
+      DO 600 KS=1,KSMUD
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***  MAIN INTEGRATION LOOP
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(def1,def2,def3,def4,def_ij,defsk,deftk,hkne_ij,hkse_ij   &
+!$omp&        ,i,j,k,q2dif,q2ne,q2se,qdif,qne,qse,slop,sne,sse          &
+!$omp&        ,tdif,tne,tse,udif,une,use,vdif,vkne,vkne_ij              &
+!$omp&        ,vkse,vkse_ij,vne,vse)
+!-----------------------------------------------------------------------
+!
+      main_integration : DO K=KTS,KTE
+
+      DO J=JMS,JME
+      DO I=IMS,IME
+        DEF3D(I,J,K)=0.
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  SLOPE SWITCHES FOR MOISTURE
+!-----------------------------------------------------------------------
+!
+        IF(SIGMA==1)THEN
+!
+!-----------------------------------------------------------------------
+!***  PRESSURE DOMAIN
+!-----------------------------------------------------------------------
+!
+          IF(DETA1(K)>0.)THEN
+            DO J=MYJS_P1,MYJE1_P2
+            DO I=MYIS_P1,MYIE1_P1
+              SNE(I,J)=1.
+            ENDDO
+            ENDDO
+!
+            DO J=MYJS1_P1,MYJE_P2
+            DO I=MYIS_P1,MYIE1_P1
+              SSE(I,J)=1.
+            ENDDO
+            ENDDO
+!
+!-----------------------------------------------------------------------
+!***  SIGMA DOMAIN
+!-----------------------------------------------------------------------
+!
+          ELSE
+            DO J=MYJS_P1,MYJE1_P1
+            DO I=MYIS_P1,MYIE1_P1
+              SLOP=ABS((Z(I+IHE(J),J+1,K)-Z(I,J,K))*RDY)
+!
+              CILINE=((SM(I+IHE(J),J+1)/=SM(I,J)).OR.                   &
+                      (SICE(I+IHE(J),J+1)/=SICE(I,J)))
+!
+              WATSLOP=(SM(I+IHE(J),J+1)==1.0.AND.                       &
+                       SM(I,J)==1.0.AND.SLOP/=0.)
+!
+              IF(SLOP<SLOPHC.OR.CILINE.OR.WATSLOP)THEN
+                SNE(I,J)=1.
+              ELSE
+                SNE(I,J)=0.
+              ENDIF
+            ENDDO
+            ENDDO
+!
+            DO J=MYJS1_P1,MYJE_P1
+            DO I=MYIS_P1,MYIE1_P1
+              SLOP=ABS((Z(I+IHE(J),J-1,K)-Z(I,J,K))*RDY)
+!
+              CILINE=((SM(I+IHE(J),J-1)/=SM(I,J)).OR.                   &
+                      (SICE(I+IHE(J),J-1)/=SICE(I,J)))
+!
+              WATSLOP=(SM(I+IHE(J),J-1)==1.0.AND.                       &
+                       SM(I,J)==1.0.AND.SLOP/=0.)
+!
+              IF(SLOP<SLOPHC.OR.CILINE.OR.WATSLOP)THEN
+                SSE(I,J)=1.
+              ELSE
+                SSE(I,J)=0.
+              ENDIF
+            ENDDO
+            ENDDO
+          ENDIF
+!
+        ENDIF
+!-----------------------------------------------------------------------
+!***  DEFORMATIONS
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS_P1,MYJE_P1
+        DO I=MYIS_P1,MYIE_P1
+!
+          DEFTK=U(I+IHE(J),J,K)-U(I+IHW(J),J,K)                         &
+     &         -V(I,J+1,K)+V(I,J-1,K)
+          DEFSK=U(I,J+1,K)-U(I,J-1,K)                                   &
+     &         +V(I+IHE(J),J,K)-V(I+IHW(J),J,K)
+          DEF1=(W(I+IHW(J),J-1,K)-W(I,J,K))*0.5
+          DEF2=(W(I+IHE(J),J-1,K)-W(I,J,K))*0.5
+          DEF3=(W(I+IHW(J),J+1,K)-W(I,J,K))*0.5
+          DEF4=(W(I+IHE(J),J+1,K)-W(I,J,K))*0.5
+          Q2L=Q2(I,J,K)
+          IF(Q2L<=EPSQ2)Q2L=0.
+          IF ( CONFIG_FLAGS%BL_PBL_PHYSICS  == MYJPBLSCHEME) then
+                DEF_IJ=DEFTK*DEFTK+DEFSK*DEFSK+DEF1*DEF1+DEF2*DEF2 &
+    &             +DEF3*DEF3+DEF4*DEF4+SCQ2*Q2L
+          else
+                DEF_IJ=DEFTK*DEFTK+DEFSK*DEFSK+DEF1*DEF1+DEF2*DEF2 &
+    &            +DEF3*DEF3+DEF4*DEF4
+          ENDIF
+
+          DEF_IJ=SQRT(DEF_IJ+DEF_IJ)*HBM2(I,J)
+          DEF_IJ=MAX(DEF_IJ,DEFC)
+          DEF_IJ=MIN(DEF_IJ,DEFM)
+          DEF_IJ=DEF_IJ*0.1
+          DEF(I,J)=DEF_IJ
+          DEF3D(I,J,K)=DEF_IJ
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  DIAGONAL CONTRIBUTIONS
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS_P1,MYJE1_P1
+        DO I=MYIS_P1,MYIE1_P1
+          HKNE_IJ=(DEF(I,J)+DEF(I+IHE(J),J+1))*SNE(I,J)
+          TNE (I,J)=(T (I+IHE(J),J+1,K)-T (I,J,K))*HKNE_IJ
+          QNE (I,J)=(Q (I+IHE(J),J+1,K)-Q (I,J,K))*HKNE_IJ
+          Q2NE(I,J)=(Q2(I+IHE(J),J+1,K)-Q2(I,J,K))*HKNE_IJ
+          HKNE(I,J)=HKNE_IJ
+!
+          VKNE_IJ=DEF(I+IVE(J),J)+DEF(I,J+1)
+          UNE(I,J)=(U(I+IVE(J),J+1,K)-U(I,J,K))*VKNE_IJ
+          VNE(I,J)=(V(I+IVE(J),J+1,K)-V(I,J,K))*VKNE_IJ
+          VKNE(I,J)=VKNE_IJ
+        ENDDO
+        ENDDO
+!
+        DO J=MYJS1_P1,MYJE_P1
+        DO I=MYIS_P1,MYIE1_P1
+          HKSE_IJ=(DEF(I+IHE(J),J-1)+DEF(I,J))*SSE(I,J)
+          TSE (I,J)=(T (I+IHE(J),J-1,K)-T (I,J,K))*HKSE_IJ
+          QSE (I,J)=(Q (I+IHE(J),J-1,K)-Q (I,J,K))*HKSE_IJ
+          Q2SE(I,J)=(Q2(I+IHE(J),J-1,K)-Q2(I,J,K))*HKSE_IJ
+          HKSE(I,J)=HKSE_IJ
+!
+          VKSE_IJ=DEF(I,J-1)+DEF(I+IVE(J),J)
+          USE(I,J)=(U(I+IVE(J),J-1,K)-U(I,J,K))*VKSE_IJ
+          VSE(I,J)=(V(I+IVE(J),J-1,K)-V(I,J,K))*VKSE_IJ
+          VKSE(I,J)=VKSE_IJ
+        ENDDO
+        ENDDO
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS1,MYJE1
+        DO I=MYIS1,MYIE
+          TDIF (I,J)=(TNE (I,J)-TNE (I+IHW(J),J-1)                      &
+     &               +TSE (I,J)-TSE (I+IHW(J),J+1))*HDAC(I,J)
+          QDIF (I,J)=(QNE (I,J)-QNE (I+IHW(J),J-1)                      &
+     &               +QSE (I,J)-QSE (I+IHW(J),J+1))*HDAC(I,J)*FCDIF
+          Q2DIF(I,J)=(Q2NE(I,J)-Q2NE(I+IHW(J),J-1)                      &
+     &               +Q2SE(I,J)-Q2SE(I+IHW(J),J+1))*HDAC(I,J)
+!
+          UDIF(I,J)=(UNE(I,J)-UNE(I+IVW(J),J-1)                         &
+     &              +USE(I,J)-USE(I+IVW(J),J+1))*HDACV(I,J)
+          VDIF(I,J)=(VNE(I,J)-VNE(I+IVW(J),J-1)                         &
+     &              +VSE(I,J)-VSE(I+IVW(J),J+1))*HDACV(I,J)
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  2ND ORDER DIFFUSION
+!-----------------------------------------------------------------------
+!
+        IF(SECOND)THEN
+          DO J=MYJS2,MYJE2
+          DO I=MYIS1,MYIE1
+            T (I,J,K)=T (I,J,K)+TDIF (I,J)
+            Q (I,J,K)=Q (I,J,K)+QDIF (I,J)
+!
+#ifdef HWRF
+            U(I,J,K)=U(I,J,K)+UDIF(I,J)*h_diff
+            V(I,J,K)=V(I,J,K)+VDIF(I,J)*h_diff
+#else
+            U(I,J,K)=U(I,J,K)+UDIF(I,J)
+            V(I,J,K)=V(I,J,K)+VDIF(I,J)
+#endif
+          ENDDO
+          ENDDO
+!
+!-----------------------------------------------------------------------
+          IF(K>=KTS+1)THEN
+            DO J=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+              Q2(I,J,K)=Q2(I,J,K)+Q2DIF(I,J)
+            ENDDO
+            ENDDO
+          ENDIF
+!
+!-----------------------------------------------------------------------
+!***  4TH ORDER DIAGONAL CONTRIBUTIONS
+!-----------------------------------------------------------------------
+!
+        ELSE
+!
+          DO J=MYJS,MYJE1
+          DO I=MYIS,MYIE1
+            HKNE_IJ=HKNE(I,J)
+            TNE (I,J)=(TDIF (I+IHE(J),J+1)-TDIF (I,J))*HKNE_IJ
+            QNE (I,J)=(QDIF (I+IHE(J),J+1)-QDIF (I,J))*HKNE_IJ
+            Q2NE(I,J)=(Q2DIF(I+IHE(J),J+1)-Q2DIF(I,J))*HKNE_IJ
+          ENDDO
+          ENDDO
+!
+          DO J=MYJS1,MYJE
+          DO I=MYIS,MYIE1
+            HKSE_IJ=HKSE(I,J)
+            TSE (I,J)=(TDIF (I+IHE(J),J-1)-TDIF (I,J))*HKSE_IJ
+            QSE (I,J)=(QDIF (I+IHE(J),J-1)-QDIF (I,J))*HKSE_IJ
+            Q2SE(I,J)=(Q2DIF(I+IHE(J),J-1)-Q2DIF(I,J))*HKSE_IJ
+          ENDDO
+          ENDDO
+!
+          DO J=MYJS2,MYJE2
+          DO I=MYIS1,MYIE1
+            T(I,J,K)=T(I,J,K)-(TNE(I,J)-TNE(I+IHW(J),J-1)               &
+     &                        +TSE(I,J)-TSE(I+IHW(J),J+1))*HDAC(I,J)
+            Q(I,J,K)=Q(I,J,K)-(QNE(I,J)-QNE(I+IHW(J),J-1)               &
+     &                        +QSE(I,J)-QSE(I+IHW(J),J+1))*HDAC(I,J)    &
+     &                        *FCDIF
+          ENDDO
+          ENDDO
+          
+!
+          IF(K>=KTS+1)THEN
+            DO J=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+              Q2(I,J,K)=Q2(I,J,K)-(Q2NE(I,J)-Q2NE(I+IHW(J),J-1)         &
+     &                            +Q2SE(I,J)-Q2SE(I+IHW(J),J+1))        &
+     &                            *HDAC(I,J)
+            ENDDO
+            ENDDO
+          ENDIF
+!
+!-----------------------------------------------------------------------
+!
+          DO J=MYJS,MYJE1
+          DO I=MYIS,MYIE1
+            UNE(I,J)=(UDIF(I+IVE(J),J+1)-UDIF(I,J))*VKNE(I,J)
+            VNE(I,J)=(VDIF(I+IVE(J),J+1)-VDIF(I,J))*VKNE(I,J)
+          ENDDO
+          ENDDO
+!
+          DO J=MYJS1,MYJE
+          DO I=MYIS,MYIE1
+            USE(I,J)=(UDIF(I+IVE(J),J-1)-UDIF(I,J))*VKSE(I,J)
+            VSE(I,J)=(VDIF(I+IVE(J),J-1)-VDIF(I,J))*VKSE(I,J)
+          ENDDO
+          ENDDO
+!
+          DO J=MYJS2,MYJE2
+          DO I=MYIS1,MYIE1
+#ifdef HWRF
+            U(I,J,K)=U(I,J,K)-(UNE(I,J)-UNE(I+IVW(J),J-1)               &
+     &                        +USE(I,J)-USE(I+IVW(J),J+1))*HDACV(I,J)*h_diff
+            V(I,J,K)=V(I,J,K)-(VNE(I,J)-VNE(I+IVW(J),J-1)               &
+     &                        +VSE(I,J)-VSE(I+IVW(J),J+1))*HDACV(I,J)*h_diff
+#else
+            U(I,J,K)=U(I,J,K)-(UNE(I,J)-UNE(I+IVW(J),J-1)               &
+     &                        +USE(I,J)-USE(I+IVW(J),J+1))*HDACV(I,J)
+            V(I,J,K)=V(I,J,K)-(VNE(I,J)-VNE(I+IVW(J),J-1)               &
+     &                        +VSE(I,J)-VSE(I+IVW(J),J+1))*HDACV(I,J)
+#endif
+          ENDDO
+          ENDDO
+!
+!-----------------------------------------------------------------------
+        ENDIF  ! End 4th order diffusion
+!-----------------------------------------------------------------------
+!
+      ENDDO main_integration
+!
+!-----------------------------------------------------------------------
+!
+  600 CONTINUE
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE HDIFF
+!
+!-----------------------------------------------------------------------
+!
+      END MODULE MODULE_DIFFUSION_NMM
+!
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_GWD.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_GWD.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_GWD.F	(revision 17)
@@ -0,0 +1,1805 @@
+!
+!-- Module for Gravity Wave Drag (GWD) and Mountain Blocking (MB)
+!
+!-- Initially incorporated into the WRF NMM from the GFS by B. Ferrier
+!   in April/May 2007.  
+!
+!   Search for "ORIGINAL DOCUMENTATION BLOCK" for further description.
+!
+!#######################################################################
+!
+      MODULE module_gwd
+!
+!      USE MODULE_DM               ! to get processor element
+      USE MODULE_EXT_INTERNAL     ! to assign fortan unit number
+!
+!-- Contains subroutines GWD_init, GWD_driver, and GWD_col
+!
+!#######################################################################
+!
+      INTEGER, PARAMETER :: KIND_PHYS=SELECTED_REAL_KIND(13,60) ! the '60' maps to 64-bit real
+      INTEGER,PRIVATE,SAVE :: IMX, NMTVR, IDBG, JDBG
+      REAL,PRIVATE,SAVE :: RAD_TO_DEG   !-- Convert radians to degrees
+      REAL,PRIVATE,SAVE :: DEG_TO_RAD   !-- Convert degrees to radians
+      REAL (KIND=KIND_PHYS),PRIVATE,SAVE :: DELTIM,RDELTIM
+      REAL(kind=kind_phys),PRIVATE,PARAMETER :: SIGFAC=0.0   !-- Key tunable parameter
+!dbg      real,private,save :: dumin,dumax,dvmin,dvmax   !dbg
+!
+      CONTAINS
+!
+!-- Initialize variables used in GWD + MB
+!
+      SUBROUTINE GWD_init (DTPHS,DELX,DELY,CEN_LAT,CEN_LON,RESTRT       &
+     &                     ,GLAT,GLON,CROT,SROT,HANGL                   &
+     &                     ,IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE )
+
+!
+      IMPLICIT NONE
+!
+!== INPUT:
+!-- DELX, DELY - DX, DY grid resolutions in zonal, meridional directions (m)
+!-- CEN_LAT, CEN_LON - central latitude, longitude (degrees)
+!-- RESTRT - logical flag for restart file (true) or WRF input file (false)
+!-- GLAT, GLON - central latitude, longitude at mass points (radians)
+!-- CROT, SROT - cosine and sine of the angle between Earth and model coordinates
+!-- HANGL  - angle of the mountain range w/r/t east (convert to degrees)
+!
+!-- Saved variables within module:
+!-- IMX - in the GFS it is an equivalent number of points along a latitude 
+!         circle (e.g., IMX=3600 for a model resolution of 0.1 deg) 
+!       => Calculated at start of model integration in GWD_init
+!-- NMTVR - number of input 2D orographic fields
+!-- GRAV = gravitational acceleration
+!-- DELTIM - physics time step (s)
+!-- RDELTIM - reciprocal of physics time step (s)
+!
+!== INPUT indices:
+!-- 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
+!
+      REAL, INTENT(IN) :: DTPHS,DELX,DELY,CEN_LAT,CEN_LON
+      LOGICAL, INTENT(IN) :: RESTRT
+      REAL, INTENT(IN), DIMENSION (ims:ime,jms:jme) :: GLON,GLAT
+      REAL, INTENT(OUT), DIMENSION (ims:ime,jms:jme) :: CROT,SROT
+      REAL, INTENT(INOUT), DIMENSION (ims:ime,jms:jme) :: HANGL
+      INTEGER, INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                    &
+     &                      ,IMS,IME,JMS,JME,KMS,KME                    &
+     &                      ,ITS,ITE,JTS,JTE,KTS,KTE
+!
+!-- Local variables:
+!
+      REAL, PARAMETER :: POS1=1.,NEG1=-1.
+      REAL :: DX,DTR,LAT0,LoN0,CLAT0,SLAT0,CLAT,DLON,X,Y,TLON,ROT
+      INTEGER :: I,J
+
+!dbg
+!dbg real :: xdbg,ydbg,d_x,d_y,dist,dist_min
+!dbg data xdbg,ydbg / -118.3,36 / ! 118.3W 36 N
+
+!
+!-----------------------------------------------------------------------
+!
+      DX=SQRT((DELX)**2+(DELY)**2)   !-- Model resolution in degrees
+!-- IMX is the number of grid points along a latitude circle in the GFS
+      IMX=INT(360./DX+.5)
+
+!dbg IMX=1152     !dbg -- Match the grid point printed from GFS run
+
+      NMTVR=14            !-- 14 input fields for orography
+      DELTIM=DTPHS
+      RDELTIM=1./DTPHS
+!
+!-- Calculate angle of rotation (ROT) between Earth and model coordinates,
+!   but pass back out cosine (CROT) and sine (SROT) of this angle
+!
+      DTR=ACOS(-1.)/180. !-- convert from degrees to radians
+      DEG_TO_RAD=DTR     !-- save conversion from degrees to radians
+!
+      LAT0=DTR*CEN_LON   !-- central latitude of grid in radians
+      LoN0=DTR*CEN_LAT   !-- central longitude of grid in radians
+!
+      DTR=1./DTR         !-- convert from radians to degrees
+      RAD_TO_DEG=DTR     !-- save conversion from radians to degrees
+!
+      CLAT0=COS(LAT0)
+      SLAT0=SIN(LAT0)
+      DO J=JTS,JTE
+        DO I=ITS,ITE
+          CLAT=COS(GLAT(I,J))
+          DLON=GLON(I,J)-LoN0
+          X=CLAT0*CLAT*COS(DLON)+SLAT0*SIN(GLAT(I,J))
+          Y=-CLAT*SIN(DLON)
+          TLON=ATAN(Y/X)              !-- model longitude
+          X=SLAT0*SIN(TLON)/CLAT
+          Y=MIN(POS1, MAX(NEG1, X) )
+          ROT=ASIN(Y)                 !-- angle between geodetic & model coordinates
+          CROT(I,J)=COS(ROT)
+          SROT(I,J)=SIN(ROT)
+        ENDDO    !-- I
+      ENDDO      !-- J
+      IF (.NOT.RESTRT) THEN
+!-- Convert from radians to degrees for WRF input files only
+        DO J=JTS,JTE
+          DO I=ITS,ITE
+            HANGL(I,J)=DTR*HANGL(I,J)  !-- convert to degrees (+/-90 deg)
+          ENDDO    !-- I
+        ENDDO      !-- J
+      ENDIF
+!dbg
+!dbg dumin=-1.
+!dbg dumax=1.
+!dbg dvmin=-1.
+!dbg dvmax=1.
+!dbg print *,'delx=',delx,'  dely=',dely,'  dx=',dx,'  imx=',imx
+!dbg dtr=1./dtr             !-- convert from degrees back to radians
+!dbg dist_min=dtr*DX        !-- grid length in radians
+!dbg xdbg=dtr*xdbg          !-- convert xdbg to radians
+!dbg ydbg=dtr*ydbg          !-- convert ydbg to radians
+!dbg idbg=-100
+!dbg jdbg=-100
+!dbg print *,'dtr,dx,dist_min,xdbg,ydbg=',dtr,dx,dist_min,xdbg,ydbg
+!dbg do j=jts,jte
+!dbg   do i=its,ite
+!dbg !-- Find i,j for xdbg, ydbg
+!dbg     d_x=cos(glat(i,j))*(glon(i,j)-xdbg)
+!dbg     d_y=(glat(i,j)-ydbg)
+!dbg     dist=sqrt(d_x*d_x+d_y*d_y)
+!dbg !! print *,'i,j,glon,glat,d_x,d_y,dist=',i,j,glon(i,j),glat(i,j),d_x,d_y,dist
+!dbg     if (dist < dist_min) then
+!dbg       dist_min=dist
+!dbg       idbg=i
+!dbg       jdbg=j
+!dbg print *,'dist_min,idbg,jdbg=',dist_min,idbg,jdbg
+!dbg     endif
+!dbg   enddo    !-- I
+!dbg enddo      !-- J
+!dbg if (idbg>0 .and. jdbg>0) print *,'idbg=',idbg,'  jdbg=',jdbg
+
+!
+      END SUBROUTINE GWD_init
+!
+!-----------------------------------------------------------------------
+!
+      SUBROUTINE GWD_driver(U,V,T,Q,Z,DP,PINT,PMID,EXNR, KPBL, ITIME    &
+     &                     ,HSTDV,HCNVX,HASYW,HASYS,HASYSW,HASYNW       &
+     &                     ,HLENW,HLENS,HLENSW,HLENNW                   &
+     &                     ,HANGL,HANIS,HSLOP,HZMAX,CROT,SROT           &
+     &                     ,DUDT,DVDT,UGWDsfc,VGWDsfc                   &
+     &                     ,IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE )
+!
+!== INPUT:
+!-- U, V - zonal (U), meridional (V) winds at mass points (m/s)
+!-- T, Q - temperature (C), specific humidity (kg/kg)
+!-- DP - pressure thickness (Pa)
+!-- Z - geopotential height (m)
+!-- PINT, PMID - interface and midlayer pressures, respectively (Pa)
+!-- EXNR - (p/p0)**(Rd/Cp)
+!-- KPBL - vertical index at PBL top
+!-- ITIME - model time step (=NTSD)
+!-- HSTDV - orographic standard deviation
+!-- HCNVX - normalized 4th moment of the orographic convexity
+!-- Template for the next two sets of 4 arrays:
+!             NWD  1   2   3   4   5   6   7   8
+!              WD  W   S  SW  NW   E   N  NE  SE
+!-- Orographic asymmetry (HASYx, x=1-4) for upstream & downstream flow (4 planes)
+!-- * HASYW - orographic asymmetry for upstream & downstream flow in W-E plane
+!-- * HASYS - orographic asymmetry for upstream & downstream flow in S-N plane
+!-- * HASYSW - orographic asymmetry for upstream & downstream flow in SW-NE plane
+!-- * HASYNW - orographic asymmetry for upstream & downstream flow in NW-SE plane
+!-- Orographic length scale or mountain width (4 planes)
+!-- * HLENW - orographic length scale for upstream & downstream flow in W-E plane
+!-- * HLENS - orographic length scale for upstream & downstream flow in S-N plane
+!-- * HLENSW - orographic length scale for upstream & downstream flow in SW-NE plane
+!-- * HLENNW - orographic length scale for upstream & downstream flow in NW-SE plane
+!-- HANGL  - angle (degrees) of the mountain range w/r/t east
+!-- HANIS - anisotropy/aspect ratio of orography
+!-- HSLOP - slope of orography
+!-- HZMAX - max height above mean orography
+!-- CROT, SROT - cosine & sine of the angle between Earth & model coordinates
+!
+!== OUTPUT:
+!-- DUDT, DVDT - zonal, meridional wind tendencies
+!-- UGWDsfc, VGWDsfc - zonal, meridional surface wind stresses (N/m**2)
+!
+!== INPUT indices:
+!-- 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 i index for tile
+!-- ite           end i index for tile
+!-- jts           start j index for tile
+!-- jte           end j index for tile
+!-- kts           start index for k in tile
+!-- kte           end index for k in tile
+!
+!-- INPUT variables:
+!
+      REAL, INTENT(IN), DIMENSION (ims:ime, kms:kme, jms:jme) ::        &
+     &                                   U,V,T,Q,Z,DP,PINT,PMID,EXNR
+      REAL, INTENT(IN), DIMENSION (ims:ime, jms:jme) :: HSTDV,HCNVX     &
+     &      ,HASYW,HASYS,HASYSW,HASYNW,HLENW,HLENS,HLENSW,HLENNW,HANGL  &
+     &      ,HANIS,HSLOP,HZMAX,CROT,SROT
+      INTEGER, INTENT(IN), DIMENSION (ims:ime, jms:jme) :: KPBL
+      INTEGER, INTENT(IN) :: ids,ide,jds,jde,kds,kde                    &
+     &,                      ims,ime,jms,jme,kms,kme                    &
+     &,                      its,ite,jts,jte,kts,kte,ITIME
+
+!
+!-- OUTPUT variables:
+!
+      REAL, INTENT(OUT), DIMENSION (ims:ime, kms:kme, jms:jme) ::       &
+     &                                                        DUDT,DVDT
+      REAL, INTENT(OUT), DIMENSION (ims:ime, jms:jme) :: UGWDsfc,VGWDsfc
+!
+!-- Local variables
+!-- DUsfc, DVsfc - zonal, meridional wind stresses (diagnostics)
+!
+      INTEGER, PARAMETER :: IM=1    !-- Reduces changes in subroutine GWPDS
+      REAL(KIND=KIND_PHYS), PARAMETER :: G=9.806, GHALF=.5*G            &
+     &,                                  THRESH=1.E-6, dtlarge=1.   !dbg
+      INTEGER, DIMENSION (IM) :: LPBL
+      REAL(KIND=KIND_PHYS), DIMENSION (IM,4) :: OA4,CLX4
+      REAL(KIND=KIND_PHYS), DIMENSION (IM) :: DUsfc,DVsfc               &
+     &,                              HPRIME,OC,THETA,SIGMA,GAMMA,ELVMAX
+      REAL(KIND=KIND_PHYS), DIMENSION (IM,KTS:KTE) :: DUDTcol,DVDTcol   &
+     &,                    Ucol,Vcol,Tcol,Qcol,DPcol,Pcol,EXNcol,PHIcol
+      REAL(KIND=KIND_PHYS), DIMENSION (IM,KTS:KTE+1) :: PINTcol,PHILIcol
+      INTEGER :: I,J,IJ,K,Imid,Jmid
+      REAL :: Ugeo,Vgeo,Umod,Vmod, TERRtest,TERRmin
+      REAL(KIND=KIND_PHYS) :: TEST
+      CHARACTER(LEN=255) :: message
+
+!dbg
+logical :: lprnt  !dbg
+character (len=26) :: label
+integer :: kpblmin,kpblmax, mype, iunit
+real :: hzmaxmin,hzmaxmax,hanglmin,hanglmax,hslopmin,hslopmax,hanismin,hanismax  &
+,hstdvmin,hstdvmax,hcnvxmin,hcnvxmax,hasywmin,hasywmax,hasysmin,hasysmax  &
+,hasyswmin,hasyswmax,hasynwmin,hasynwmax,hlenwmin,hlenwmax,hlensmin,hlensmax  &
+,hlenswmin,hlenswmax,hlennwmin,hlennwmax,zsmin,zsmax,delu,delv
+! Added this declaration
+real :: helvmin,helvmax
+!dbg
+
+!
+!--------------------------  Executable below  -------------------------
+!
+
+lprnt=.false.
+!dbg
+if (itime <= 1) then
+  CALL WRF_GET_MYPROC(MYPE)   !-- Get processor number
+  kpblmin=100
+  kpblmax=-100
+  hzmaxmin=1.e6
+  hzmaxmax=-1.e6
+  hanglmin=1.e6
+  hanglmax=-1.e6
+  hslopmin=1.e6
+  hslopmax=-1.e6
+  hanismin=1.e6
+  hanismax=-1.e6
+  hstdvmin=1.e6
+  hstdvmax=-1.e6
+  hcnvxmin=1.e6
+  hcnvxmax=-1.e6
+  hasywmin=1.e6
+  hasywmax=-1.e6
+  hasysmin=1.e6
+  hasysmax=-1.e6
+  hasyswmin=1.e6
+  hasyswmax=-1.e6
+  hasynwmin=1.e6
+  hasynwmax=-1.e6
+  hlenwmin=1.e6
+  hlenwmax=-1.e6
+  hlensmin=1.e6
+  hlensmax=-1.e6
+  hlenswmin=1.e6
+  hlenswmax=-1.e6
+  hlennwmin=1.e6
+  hlennwmax=-1.e6
+  zsmin=1.e6
+  zsmax=-1.e6
+! Added initialization of helvmin and helvmax
+  helvmin=1.e6
+  helvmax=-1.e6
+  do j=jts,jte
+    do i=its,ite
+      kpblmin=min(kpblmin,kpbl(i,j))
+      kpblmax=max(kpblmax,kpbl(i,j))
+      helvmin=min(helvmin,hzmax(i,j))
+      helvmax=max(helvmax,hzmax(i,j))
+      hanglmin=min(hanglmin,hangl(i,j))
+      hanglmax=max(hanglmax,hangl(i,j))
+      hslopmin=min(hslopmin,hslop(i,j))
+      hslopmax=max(hslopmax,hslop(i,j))
+      hanismin=min(hanismin,hanis(i,j))
+      hanismax=max(hanismax,hanis(i,j))
+      hstdvmin=min(hstdvmin,hstdv(i,j))
+      hstdvmax=max(hstdvmax,hstdv(i,j))
+      hcnvxmin=min(hcnvxmin,hcnvx(i,j))
+      hcnvxmax=max(hcnvxmax,hcnvx(i,j))
+      hasywmin=min(hasywmin,hasyw(i,j))
+      hasywmax=max(hasywmax,hasyw(i,j))
+      hasysmin=min(hasysmin,hasys(i,j))
+      hasysmax=max(hasysmax,hasys(i,j))
+      hasyswmin=min(hasyswmin,hasysw(i,j))
+      hasyswmax=max(hasyswmax,hasysw(i,j))
+      hasynwmin=min(hasynwmin,hasynw(i,j))
+      hasynwmax=max(hasynwmax,hasynw(i,j))
+      hlenwmin=min(hlenwmin,hlenw(i,j))
+      hlenwmax=max(hlenwmax,hlenw(i,j))
+      hlensmin=min(hlensmin,hlens(i,j))
+      hlensmax=max(hlensmax,hlens(i,j))
+      hlenswmin=min(hlenswmin,hlensw(i,j))
+      hlenswmax=max(hlenswmax,hlensw(i,j))
+      hlennwmin=min(hlennwmin,hlennw(i,j))
+      hlennwmax=max(hlennwmax,hlennw(i,j))
+      zsmin=min(zsmin,z(i,1,j))
+      zsmax=max(zsmax,z(i,1,j))
+    enddo
+  enddo
+  write(message,*) 'Maximum and minimum values within GWD-driver for MYPE=',MYPE
+  write(message,"(i3,2(a,e12.5))") mype,':  deltim=',deltim,'  rdeltim=',rdeltim
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,i3))")    mype,':  kpblmin=',kpblmin,'  kpblmax=',kpblmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  helvmin=',helvmin,'  helvmax=',helvmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  hanglmin=',hanglmin,'  hanglmax=',hanglmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  hslopmin=',hslopmin,'  hslopmax=',hslopmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  hanismin=',hanismin,'  hanismax=',hanismax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  hstdvmin=',hstdvmin,'  hstdvmax=',hstdvmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  hcnvxmin=',hcnvxmin,'  hcnvxmax=',hcnvxmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  hasywmin=',hasywmin,'  hasywmax=',hasywmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  hasysmin=',hasysmin,'  hasysmax=',hasysmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  hasyswmin=',hasyswmin,'  hasyswmax=',hasyswmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  hasynwmin=',hasynwmin,'  hasynwmax=',hasynwmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  hlenwmin=',hlenwmin,'  hlenwmax=',hlenwmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  hlensmin=',hlensmin,'  hlensmax=',hlensmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  hlenswmin=',hlenswmin,'  hlenswmax=',hlenswmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  hlennwmin=',hlennwmin,'  hlennwmax=',hlennwmax
+  CALL wrf_message(trim(message))
+  write(message,"(i3,2(a,e12.5))") mype,':  zsmin=',zsmin,'  zsmax=',zsmax
+  CALL wrf_message(trim(message))
+
+endif   ! if (itime <= 1) then
+!dbg
+
+!
+!-- Initialize variables
+!
+      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
+!
+      DO J=JMS,JME
+      DO I=IMS,IME
+        UGWDsfc(I,J)=0.
+        VGWDsfc(I,J)=0.
+      ENDDO
+      ENDDO
+!
+!-- For debugging, find approximate center point within each tile
+!
+!dbg       Imid=.5*(ITS+ITE)
+!dbg       Jmid=.5*(JTS+JTE)
+!
+      DO J=JTS,JTE
+        DO I=ITS,ITE
+          if (kpbl(i,j)<kts .or. kpbl(i,j)>kte) go to 100
+!
+!-- Initial test to see if GWD calculations should be made, otherwise skip
+!
+          TERRtest=HZMAX(I,J)+SIGFAC*HSTDV(I,J)
+          TERRmin=Z(I,2,J)-Z(I,1,J)
+          IF (TERRtest < TERRmin) GO TO 100
+!
+!-- For debugging:
+!
+!dbg lprnt=.false.
+!dbg if (i==idbg .and. j==jdbg .and. itime<=1) lprnt=.true.
+!dbg ! 200   CONTINUE
+!
+          DO K=KTS,KTE
+            DUDTcol(IM,K)=0.
+            DVDTcol(IM,K)=0.
+!
+!-- Transform/rotate winds from model to geodetic (Earth) coordinates
+!
+            Ucol(IM,K)=U(I,K,J)*CROT(I,J)+V(I,K,J)*SROT(I,J)
+            Vcol(IM,K)=V(I,K,J)*CROT(I,J)-U(I,K,J)*SROT(I,J)
+!
+            Tcol(IM,K)=T(I,K,J)
+            Qcol(IM,K)=Q(I,K,J)
+!
+!-- Convert from Pa to centibars, which is what's used in subroutine GWD_col
+!
+            DPcol(IM,K)=.001*DP(I,K,J)
+            PINTcol(IM,K)=.001*PINT(I,K,J)
+            Pcol(IM,K)=.001*PMID(I,K,J)
+            EXNcol(IM,K)=EXNR(I,K,J)
+!
+!-- Next 2 fields are geopotential above the surface at the lower interface 
+!   and at midlayer
+!
+            PHILIcol(IM,K)=G*(Z(I,K,J)-Z(I,1,J))
+            PHIcol(IM,K)=GHALF*(Z(I,K,J)+Z(I,K+1,J))-G*Z(I,1,J)
+          ENDDO   !- K
+!
+          PINTcol(IM,KTE+1)=.001*PINT(I,KTE+1,J)
+          PHILIcol(IM,KTE+1)=G*(Z(I,KTE+1,J)-Z(I,1,J))
+!
+!-- Terrain-specific inputs:
+!
+          HPRIME(IM)=HSTDV(I,J)   !-- standard deviation of orography
+          OC(IM)=HCNVX(I,J)       !-- Normalized convexity
+          OA4(IM,1)=HASYW(I,J)    !-- orographic asymmetry in W-E plane
+          OA4(IM,2)=HASYS(I,J)    !-- orographic asymmetry in S-N plane
+          OA4(IM,3)=HASYSW(I,J)   !-- orographic asymmetry in SW-NE plane
+          OA4(IM,4)=HASYNW(I,J)   !-- orographic asymmetry in NW-SE plane
+          CLX4(IM,1)=HLENW(I,J)   !-- orographic length scale in W-E plane
+          CLX4(IM,2)=HLENS(I,J)   !-- orographic length scale in S-N plane
+          CLX4(IM,3)=HLENSW(I,J)  !-- orographic length scale in SW-NE plane
+          CLX4(IM,4)=HLENNW(I,J)  !-- orographic length scale in NW-SE plane
+          THETA(IM)=HANGL(I,J)       !
+          SIGMA(IM)=HSLOP(I,J)       !
+          GAMMA(IM)=HANIS(I,J)       !
+          ELVMAX(IM)=HZMAX(I,J)      !
+          LPBL(IM)=KPBL(I,J)      !
+!dbg           IF (LPBL(IM)<KTS .OR. LPBL(IM)>KTE)     &
+!dbg      & print *,'Wacky values for KPBL: I,J,N,LPBL=',I,J,ITIME,LPBL(IM)
+!
+!-- Output (diagnostics)
+!
+          DUsfc(IM)=0.             !-- U wind stress
+          DVsfc(IM)=0.             !-- V wind stress
+!
+!dbg
+!dbg if (LPRNT) then
+!dbg !
+!dbg !-- Following code is for ingesting GFS-derived inputs for final testing
+!dbg !
+!dbg   CALL INT_GET_FRESH_HANDLE(iunit)
+!dbg   close(iunit)
+!dbg   open(unit=iunit,file='gfs_gwd.input',form='formatted',iostat=ier)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) (Ucol(im,k), k=kts,kte)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) (Vcol(im,k), k=kts,kte)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) (Tcol(im,k), k=kts,kte)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) (Qcol(im,k), k=kts,kte)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) (PINTcol(im,k), k=kts,kte+1)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) (DPcol(im,k), k=kts,kte)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) (Pcol(im,k), k=kts,kte)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) (EXNcol(im,k), k=kts,kte)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) (PHILIcol(im,k), k=kts,kte+1)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) (PHIcol(im,k), k=kts,kte)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) hprime(im)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) oc(im)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) (oa4(im,k), k=1,4)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) (clx4(im,k), k=1,4)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) theta(im)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) sigma(im)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) gamma(im)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) elvmax(im)
+!dbg   read(iunit,*)    ! skip line
+!dbg   read(iunit,*) lpbl(im)
+!dbg   close(iunit)
+write(label,"('GWD:i,j,n=',2i5,i6)") I,J,ITIME
+!dbg   write(6,"(2a)") LABEL,' in GWD_driver: K U V T Q Pi DP P EX PHIi PHI'
+!dbg   do k=kts,kte
+!dbg     write(6,"(i3,10e12.4)") k,Ucol(im,k),Vcol(im,k),Tcol(im,k)          &
+!dbg     ,Qcol(im,k),PINTcol(im,k),DPcol(im,k),Pcol(im,k),EXNcol(im,k)  &
+!dbg     ,PHILIcol(im,k),PHIcol(im,k)
+!dbg   enddo
+!dbg   write(6,"(2(a,e12.4),2(a,4e12.4/),4(a,e12.4),a,i3) )")         &
+!dbg    'GWD_driver:  hprime(im)=',hprime(im),'  oc(im)=',oc(im)    &
+!dbg   ,'  oa4(im,1-4)=',(oa4(im,k),k=1,4)                          &
+!dbg   ,'  clx4(im,1-4)=',(clx4(im,k),k=1,4)                        &
+!dbg   ,'  theta=',theta(im),'  sigma(im)=',sigma(im)               &
+!dbg   ,'  gamma(im)=',gamma(im),'  elvmax(im)=',elvmax(im)         &
+!dbg   ,'  lpbl(im)=',lpbl(im)
+!dbg endif
+!dbg
+!=======================================================================
+!
+          CALL GWD_col(DVDTcol,DUDTcol, DUsfc,DVsfc                     & ! Output
+     &,              Ucol,Vcol,Tcol,Qcol,PINTcol,DPcol,Pcol,EXNcol      & ! Met input
+     &,              PHILIcol,PHIcol                                    & ! Met input
+     &,              HPRIME,OC,OA4,CLX4,THETA,SIGMA,GAMMA,ELVMAX        & ! Topo input
+     &,              LPBL,IM,KTS,KTE,LABEL,LPRNT )                        ! Indices + debugging
+!
+!=======================================================================
+!
+!dbg
+!dbg !
+!dbg ! IF (.NOT.LPRNT) THEN
+!dbg !   TEST=0.
+!dbg !   DO K=KTS,KTE
+!dbg !     TEST=MAX( TEST, ABS(DUDTcol(IM,K)), ABS(DVDTcol(IM,K)) )
+!dbg !     if ( ABS(DUDTcol(IM,K)) > RDELTIM) print *,'k,DUDTcol=',k,DUDTcol(IM,K)
+!dbg !     if ( ABS(DVDTcol(IM,K)) > RDELTIM) print *,'k,DVDTcol=',k,DVDTcol(IM,K)
+!dbg !   ENDDO
+!dbg !   IF (TEST>RDELTIM) THEN
+!dbg !     LPRNT=.TRUE.
+!dbg !     Imid=I
+!dbg !     Jmid=J
+!dbg !     GO TO 200
+!dbg !   ENDIF
+!dbg ! ENDIF
+!dbg ! TEST=ABS(DUsfc(IM))+ABS(DVsfc(IM))
+!dbg ! if (.not.lprnt) then
+!dbg !   do k=kts,kte
+!dbg !     du=DUDTcol(IM,K)*DELTIM
+!dbg !     dv=DVDTcol(IM,K)*DELTIM
+!dbg !     if (du < dumin) then
+!dbg !       lprnt=.true.
+!dbg !       dumin=1.5*du
+!dbg !     endif
+!dbg !     if (du > dumax) then
+!dbg !       lprnt=.true.
+!dbg !       dumax=1.5*du
+!dbg !     endif
+!dbg !     if (dv < dvmin) then
+!dbg !       lprnt=.true.
+!dbg !       dvmin=1.5*dv
+!dbg !     endif
+!dbg !     if (dv > dvmax) then
+!dbg !       lprnt=.true.
+!dbg !       dvmax=1.5*dv
+!dbg !     endif
+!dbg !   enddo
+!dbg !   if (lprnt) go to 200
+!dbg ! else
+!dbg if (lprnt) then
+!dbg   print *,'DUsfc,DVsfc,CROT,SROT,DELTIM=',DUsfc(IM),DVsfc(IM) &
+!dbg   &,CROT(I,J),SROT(I,J),DELTIM
+!dbg   print *,' K  P     |     Ucol      Ugeo  DUDTcol*DT   U        Umod    DU=DUDT*DT ' &
+!dbg                    ,'|     Vcol      Vgeo  DVDTcol*DT   V        Vmod    DV=DVDT*DT'
+!dbg ENDIF
+
+          DO K=KTS,KTE
+            TEST=ABS(DUDTcol(IM,K))+ABS(DVDTcol(IM,K))
+            IF (TEST > THRESH) THEN
+
+!dbg
+!dbg if (lprnt) then
+!dbg !dbg  DUDTcol(IM,K)=0.   !-- Test rotation
+!dbg !dbg  DVDTcol(IM,K)=0.   !-- Test rotation
+!dbg !-- Now replace with the original winds before they were written over by
+!dbg !   the values from the GFS
+!dbg   Ucol(IM,K)=U(I,K,J)*CROT(I,J)+V(I,K,J)*SROT(I,J)
+!dbg   Vcol(IM,K)=V(I,K,J)*CROT(I,J)-U(I,K,J)*SROT(I,J)
+!dbg endif
+
+!
+!-- First update winds in geodetic coordinates
+!
+              Ugeo=Ucol(IM,K)+DUDTcol(IM,K)*DELTIM
+              Vgeo=Vcol(IM,K)+DVDTcol(IM,K)*DELTIM
+!
+!-- Transform/rotate winds from geodetic back to model coordinates
+!
+              Umod=Ugeo*CROT(I,J)-Vgeo*SROT(I,J)
+              Vmod=Ugeo*SROT(I,J)+Vgeo*CROT(I,J)
+!
+!-- Calculate wind tendencies from the updated model winds
+!
+              DUDT(I,K,J)=RDELTIM*(Umod-U(I,K,J))
+              DVDT(I,K,J)=RDELTIM*(Vmod-V(I,K,J))
+!
+!dbg
+
+test=abs(dudt(i,k,j))+abs(dvdt(i,k,j))
+if (test > dtlarge) write(6,"(2a,i2,2(a,e12.4))")  &
+label,' => k=',k,'  dudt=',dudt(i,k,j),'  dvdt=',dvdt(i,k,j)
+
+!dbg if (lprnt) write(6,"(i2,f8.2,2(' | ',6f10.4)")  K,10.*Pcol(IM,K)  &
+!dbg ,Ucol(IM,K),Ugeo,DUDTcol(IM,K)*DELTIM,U(I,K,J),Umod,DUDT(I,K,J)*DELTIM    &
+!dbg ,Vcol(IM,K),Vgeo,DVDTcol(IM,K)*DELTIM,V(I,K,J),Vmod,DVDT(I,K,J)*DELTIM
+!dbg
+            ENDIF     !- IF (TEST > THRESH) THEN
+!
+          ENDDO   !- K
+!
+!-- Transform/rotate surface wind stresses from geodetic to model coordinates
+!
+          UGWDsfc(I,J)=DUsfc(IM)*CROT(I,J)-DVsfc(IM)*SROT(I,J)
+          VGWDsfc(I,J)=DUsfc(IM)*SROT(I,J)+DVsfc(IM)*CROT(I,J)
+!
+100       CONTINUE
+        ENDDO     !- I
+      ENDDO       !- J
+!
+      END SUBROUTINE GWD_driver
+!
+!-----------------------------------------------------------------------
+!
+!-- "A", "B" (from GFS) in GWD_col are DVDTcol, DUDTcol, respectively in GWD_driver
+!
+      SUBROUTINE GWD_col (A,B, DUsfc,DVsfc                              &  !-- Output
+     &, U1,V1,T1,Q1, PRSI,DEL,PRSL,PRSLK, PHII,PHIL                     &  !-- Met inputs
+     &, HPRIME,OC,OA4,CLX4,THETA,SIGMA,GAMMA,ELVMAX                     &  !-- Topo inputs
+     &, KPBL,IM,KTS,KTE, LABEL,LPRNT )                                     !-- Input indices, debugging
+!
+!=== Output fields
+!
+!-- A (DUDT), B (DVDT) - output zonal & meridional wind tendencies in Earth coordinates (m s^-2)
+!-- DUsfc, DVsfc - surface zonal meridional wind stresses in Earth coordinates (m s^-1?)
+!
+!=== Input fields
+!
+!-- U1, V1 - zonal, meridional wind (m/s)
+!-- T1 - temperature (deg K)
+!-- Q1 - specific humidity (kg/kg)
+!-- PRSI - lower interface pressure in centibars (1000 Pa)
+!-- DEL - pressure thickness of layer in centibars (1000 Pa)
+!-- PRSL - midlayer pressure in centibars (1000 Pa)
+!-- PRSLK - Exner function, (P/P0)**(Rd/CP)
+!-- PHII - lower interface geopotential in mks units
+!-- PHIL - midlayer geopotential in mks units
+!-- KDT - number of time steps into integration for diagnostics
+!-- HPRIME - orographic standard deviation
+!-- OC - normalized 4th moment of the orographic convexity
+!-- OA4 - orographic asymmetry for upstream & downstream flow measured 
+!         along 4 vertical planes (W-E, S-N, SW-NE, NW-SE)
+!-- CLX4 - orographic length scale or mountain width measured along
+!          4 vertical planes (W-E, S-N, SW-NE, NW-SE)
+!-- THETA - angle of the mountain range w/r/t east
+!-- SIGMA - slope of orography
+!-- GAMMA - anisotropy/aspect ratio
+!-- ELVMAX - max height above mean orography
+!-- KPBL(IM) - vertical index at the top of the PBL
+!-- KM - number of vertical levels
+!
+!== For diagnostics
+!-- LABEL - character string for diagnostic prints
+!-- LPRNT - logical flag for prints
+!
+!#######################################################################
+!##################  ORIGINAL DOCUMENTATION BLOCK  #####################
+!######  The following comments are from the original GFS code  ########
+!#######################################################################
+!   ********************************************************************
+! ----->  I M P L E M E N T A T I O N    V E R S I O N   <----------
+!
+!          --- Not in this code --  History of GWDP at NCEP----
+!              ----------------     -----------------------
+!  VERSION 3  MODIFIED FOR GRAVITY WAVES, LOCATION: .FR30(V3GWD)  *J*
+!---       3.1 INCLUDES VARIABLE SATURATION FLUX PROFILE CF ISIGST
+!---       3.G INCLUDES PS COMBINED W/ PH (GLAS AND GFDL)
+!-----         ALSO INCLUDED IS RI  SMOOTH OVER A THICK LOWER LAYER
+!-----         ALSO INCLUDED IS DECREASE IN DE-ACC AT TOP BY 1/2
+!-----     THE NMC GWD INCORPORATING BOTH GLAS(P&S) AND GFDL(MIGWD)
+!-----        MOUNTAIN INDUCED GRAVITY WAVE DRAG 
+!-----    CODE FROM .FR30(V3MONNX) FOR MONIN3
+!-----        THIS VERSION (06 MAR 1987)
+!-----        THIS VERSION (26 APR 1987)    3.G
+!-----        THIS VERSION (01 MAY 1987)    3.9
+!-----    CHANGE TO FORTRAN 77 (FEB 1989)     --- HANN-MING HENRY JUANG
+!----- 
+!
+!   VERSION 4
+!                ----- This code -----
+!
+!-----   MODIFIED TO IMPLEMENT THE ENHANCED LOW TROPOSPHERIC GRAVITY
+!-----   WAVE DRAG DEVELOPED BY KIM AND ARAKAWA(JAS, 1995).
+!        Orographic Std Dev (hprime), Convexity (OC), Asymmetry (OA4)
+!        and Lx (CLX4) are input topographic statistics needed.
+!
+!-----   PROGRAMMED AND DEBUGGED BY HONG, ALPERT AND KIM --- JAN 1996.
+!-----   debugged again - moorthi and iredell --- may 1998.
+!-----
+!       Further Cleanup, optimization and modification
+!                                       - S. Moorthi May 98, March 99.
+!-----   modified for usgs orography data (ncep office note 424)
+!        and with several bugs fixed  - moorthi and hong --- july 1999.
+!
+!-----   Modified & implemented into NRL NOGAPS
+!                                       - Young-Joon Kim, July 2000
+!-----
+!   VERSION lm MB  (6): oz fix 8/2003
+!                ----- This code -----
+!
+!------   Changed to include the Lott and Miller Mtn Blocking
+!         with some modifications by (*j*)  4/02
+!        From a Principal Coordinate calculation using the
+!        Hi Res 8 minute orography, the Angle of the
+!        mtn with that to the East (x) axis is THETA, the slope
+!        parameter SIGMA. The anisotropy is in GAMMA - all  are input
+!        topographic statistics needed.  These are calculated off-line
+!        as a function of model resolution in the fortran code ml01rg2.f,
+!        with script mlb2.sh.   (*j*)
+!-----   gwdps_mb.f version (following lmi) elvmax < hncrit (*j*)
+!        MB3a expt to enhance elvmax mtn hgt see sigfac & hncrit
+!-----
+!----------------------------------------------------------------------C
+!==== Below in "!GFS " are the original subroutine call and comments from 
+!     /nwprod/sorc/global_fcst.fd/gwdps_v.f as of April 2007
+!GFS       SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,U1,V1,T1,Q1,KPBL,
+!GFS      &               PRSI,DEL,PRSL,PRSLK,PHII, PHIL,RCL,DELTIM,KDT,
+!GFS      &               HPRIME,OC,OA4,CLX4,THETA,SIGMA,GAMMA,ELVMAX,
+!GFS      &               DUsfc,DVsfc,G, CP, RD, RV, IMX,
+!GFS      &               nmtvr, me, lprnt, ipr)
+!GFS !------------------------------------------------------------------
+!GFS !    USE
+!GFS !        ROUTINE IS CALLED FROM GBPHYS  (AFTER CALL TO MONNIN)
+!GFS !
+!GFS !    PURPOSE
+!GFS !        USING THE GWD PARAMETERIZATIONS OF PS-GLAS AND PH-
+!GFS !        GFDL TECHNIQUE.  THE TIME TENDENCIES OF U V
+!GFS !        ARE ALTERED TO INCLUDE THE EFFECT OF MOUNTAIN INDUCED
+!GFS !        GRAVITY WAVE DRAG FROM SUB-GRID SCALE OROGRAPHY INCLUDING
+!GFS !        CONVECTIVE BREAKING, SHEAR BREAKING AND THE PRESENCE OF
+!GFS !        CRITICAL LEVELS
+!GFS !
+!GFS !  INPUT
+!GFS !        A(IY,KM)  NON-LIN TENDENCY FOR V WIND COMPONENT
+!GFS !        B(IY,KM)  NON-LIN TENDENCY FOR U WIND COMPONENT
+!GFS !        U1(IX,KM) ZONAL WIND / SQRT(RCL)  M/SEC  AT T0-DT
+!GFS !        V1(IX,KM) MERIDIONAL WIND / SQRT(RCL) M/SEC AT T0-DT
+!GFS !        T1(IX,KM) TEMPERATURE DEG K AT T0-DT
+!GFS !        Q1(IX,KM) SPECIFIC HUMIDITY AT T0-DT
+!GFS !
+!GFS !        RCL     A scaling factor = RECIPROCAL OF SQUARE OF COS(LAT)
+!GFS !                FOR MRF GFS.  
+!GFS !        DELTIM  TIME STEP    SECS
+!GFS !        SI(N)   P/PSFC AT BASE OF LAYER N
+!GFS !        SL(N)   P/PSFC AT MIDDLE OF LAYER N
+!GFS !        DEL(N)  POSITIVE INCREMENT OF P/PSFC ACROSS LAYER N
+!GFS !        KPBL(IM) is the index of the top layer of the PBL
+!GFS !        ipr & lprnt for diagnostics
+!GFS !
+!GFS !  OUTPUT
+!GFS !        A, B    AS AUGMENTED BY TENDENCY DUE TO GWDPS
+!GFS !                OTHER INPUT VARIABLES UNMODIFIED.
+!GFS !   ********************************************************************
+!
+      IMPLICIT NONE
+!
+!-- INPUT:
+!
+      INTEGER, INTENT(IN) :: IM,KTS,KTE
+      REAL(kind=kind_phys), INTENT(IN), DIMENSION(IM,KTS:KTE) ::        &
+     &                                 U1,V1,T1,Q1,DEL,PRSL,PRSLK,PHIL
+      REAL(kind=kind_phys), INTENT(IN), DIMENSION(IM,KTS:KTE+1) ::      &
+     &                                                       PRSI,PHII
+      REAL(kind=kind_phys), INTENT(IN), DIMENSION(IM,4) :: OA4,CLX4
+      REAL(kind=kind_phys), INTENT(IN), DIMENSION(IM) ::                &
+     &                              HPRIME,OC,THETA,SIGMA,GAMMA,ELVMAX
+      INTEGER, INTENT(IN), DIMENSION(IM) :: KPBL
+      CHARACTER (LEN=26), INTENT(IN) :: LABEL
+      LOGICAL, INTENT(IN) :: LPRNT
+!
+!-- OUTPUT:
+!
+      REAL(kind=kind_phys), INTENT(INOUT), DIMENSION(IM,KTS:KTE) :: A,B
+      REAL(kind=kind_phys), INTENT(INOUT), DIMENSION(IM) :: DUsfc,DVsfc
+!
+!-----------------------------------------------------------------------
+!-- LOCAL variables:
+!-----------------------------------------------------------------------
+!
+!     Some constants
+!
+!
+      REAL(kind=kind_phys), PARAMETER :: PI=3.1415926535897931        &
+     &,        G=9.806, CP=1004.6, RD=287.04, RV=461.6                &
+     &,        FV=RV/RD-1., RDI=1./RD, GOR=G/RD, GR2=G*GOR, GOCP=G/CP &
+     &,        ROG=1./G, ROG2=ROG*ROG                                 &
+     &,        DW2MIN=1., RIMIN=-100., RIC=0.25, BNV2MIN=1.0E-5       &
+     &,        EFMIN=0.0, EFMAX=10.0, hpmax=200.0                     & ! or hpmax=2500.0
+     &,        FRC=1.0, CE=0.8, CEOFRC=CE/FRC, frmax=100.             &
+     &,        CG=0.5, GMAX=1.0, CRITAC=5.0E-4, VELEPS=1.0            &
+     &,        FACTOP=0.5, RLOLEV=500.0, HZERO=0., HONE=1.            & ! or RLOLEV=0.5
+     &,        HE_4=.0001, HE_2=.01                                   & 
+!
+!-- Lott & Miller mountain blocking => aka "lm mtn blocking"
+!
+     &,  cdmb = 1.0        &    ! non-dim sub grid mtn drag Amp (*j*)
+!  hncrit set to 8000m and sigfac added to enhance elvmax mtn hgt
+     &,  hncrit=8000.      &    ! Max value in meters for ELVMAX (*j*)
+!module top!     &,  sigfac=3.0        &    ! MB3a expt test for ELVMAX factor (*j*)  => control value is 0.1
+!module top    &,  sigfac=0.         &    ! MB3a expt test for ELVMAX factor (*j*)  => control value is 0.1
+     &,  hminmt=50.        &    ! min mtn height (*j*)
+     &,  hstdmin=25.       &    ! min orographic std dev in height
+     &,  minwnd=0.1        &    ! min wind component (*j*)
+     &,  dpmin=5.0              ! Minimum thickness of the reference layer (centibars)
+                                ! values of dpmin=0, 20 have also been used
+!
+      integer, parameter :: mdir=8
+      real(kind=kind_phys), parameter :: FDIR=mdir/(PI+PI)
+!
+!-- Template:
+!             NWD  1   2   3   4   5   6   7   8
+!              WD  W   S  SW  NW   E   N  NE  SE
+!
+      integer,save :: nwdir(mdir)
+      data nwdir /6,7,5,8,2,3,1,4/
+!
+      LOGICAL ICRILV(IM)
+!
+!----   MOUNTAIN INDUCED GRAVITY WAVE DRAG
+!
+!
+! for lm mtn blocking
+      real(kind=kind_phys), DIMENSION(IM) :: WK,PE,EK,ZBK,UP,TAUB,XN    &
+     & ,YN,UBAR,VBAR,ULOW,OA,CLX,ROLL,ULOI,DTFAC,XLINV,DELKS,DELKS1     &
+     & ,SCOR,BNV2bar, ELEVMX   ! ,PSTAR
+!
+      real(kind=kind_phys), DIMENSION(IM,KTS:KTE) ::                    &
+     &                      BNV2LM,DB,ANG,UDS,BNV2,RI_N,TAUD,RO,VTK,VTJ
+      real(kind=kind_phys), DIMENSION(IM,KTS:KTE-1) :: VELCO
+      real(kind=kind_phys), DIMENSION(IM,KTS:KTE+1) :: TAUP
+      real(kind=kind_phys), DIMENSION(KTE-1) :: VELKO
+!
+      integer, DIMENSION(IM) ::                                         &
+     &                 kref,kint,iwk,iwk2,ipt,kreflm,iwklm,iptlm,idxzb
+!
+! for lm mtn blocking
+!
+      real(kind=kind_phys) :: ZLEN, DBTMP, R, PHIANG, DBIM              &
+     &,                   xl,     rcsks, bnv,   fr                      &
+     &,                   brvf,   cleff, tem,   tem1,  tem2, temc, temv &
+     &,                   wdir,   ti,    rdz,   dw2,   shr2, bvf2       &
+     &,                   rdelks, wtkbj, efact, coefm, gfobnv           &
+     &,                   scork,  rscor, hd,    fro,   rim,  sira       &
+     &,                   dtaux,  dtauy, pkp1log, pklog
+!
+      integer :: ncnt, kmm1, kmm2, lcap, lcapp1, kbps, kbpsp1,kbpsm1    &
+     &, kmps, kmpsp1, idir, nwd, i, j, k, klcap, kp1, kmpbl, npt, npr   &
+     &, idxm1, ktrial, klevm1, kmll,kmds, KM                            &
+!     &, ihit,jhit                                                       &
+     &, ME              !-- processor element for debugging
+
+real :: rcl,rcs  !dbg
+
+!
+!-----------------------------------------------------------------------
+!
+      KM = KTE
+      npr = 0
+      DO I = 1, IM
+         DUsfc(I) = 0.
+         DVsfc(I) = 0.
+!
+!-- ELEVMX is a local array that could be changed below
+!
+         ELEVMX(I) = ELVMAX(I)
+      ENDDO
+!
+!-- Note that A, B already set to zero as DUDTcol, DVDTcol in subroutine GWD_driver
+!
+      ipt = 0
+      npt = 0
+      IF (NMTVR >= 14) then 
+        DO I = 1,IM
+          IF (elvmax(i) > HMINMT .AND. hprime(i) > HE_4) then
+             npt = npt + 1
+             ipt(npt) = i
+          ENDIF
+        ENDDO
+      ELSE
+        DO I = 1,IM
+          IF (hprime(i) > HE_4) then
+            npt = npt + 1
+            ipt(npt) = i
+          ENDIF
+        ENDDO
+      ENDIF    !-- IF (NMTVR >= 14) then 
+!
+
+!dbg
+rcl=1.
+rcs=1.
+!dbg if (lprnt) then
+!dbg !-- Match what's in the GFS:
+!dbg !dbg  rcl=1.53028780126139008   ! match GFS point at 36N
+!dbg !dbg  rcs=sqrt(rcl)
+!dbg   i=im
+!dbg   write(6,"(a,a)") LABEL,' in GWD_col: K U V T Q Pi DP P EX PHIi PHI'
+!dbg   do k=kts,kte
+!dbg     write(6,"(i3,10e12.4)") k,U1(i,k),V1(i,k),T1(i,k),Q1(i,k),PRSI(i,k)   &
+!dbg     ,DEL(i,k),PRSL(i,k),PRSLK(i,k),PHII(i,k),PHIL(i,k)
+!dbg   enddo
+!dbg   write(6,"(2(a,e12.4),2(a,4e12.4/),4(a,e12.4),a,i3) )")   &
+!dbg    'GWD_col:  hprime(i)=',hprime(i),'  oc(i)=',oc(i)       &
+!dbg   ,'  oa4(i,1-4)=',(oa4(i,k),k=1,4)                        &
+!dbg   ,'  clx4(i,1-4)=',(clx4(i,k),k=1,4)                      &
+!dbg   ,'  theta(i)=',theta(i),'  sigma(i)=',sigma(i)           &
+!dbg   ,'  gamma(i)=',gamma(i),'  elvmax(i)=',elvmax(i)         &
+!dbg   ,'  lpbl(i)=',kpbl(i)
+!dbg endif
+!dbg if (lprnt) CALL WRF_GET_MYPROC(ME)
+
+!
+!-- Note important criterion for immediately exiting routine!
+!
+      IF (npt <= 0) RETURN     ! No gwd/mb calculation done!
+!
+      do i=1,npt
+        IDXZB(i) = 0
+      enddo
+!
+      DO K = 1, KM
+      DO I = 1, IM
+      DB(I,K) = 0.
+      ANG(I,K) = 0.
+      UDS(I,K) = 0.
+      ENDDO
+      ENDDO
+!
+!
+!     NCNT   = 0
+      KMM1   = KM - 1
+      KMM2   = KM - 2
+      LCAP   = KM
+      LCAPP1 = LCAP + 1
+!
+!
+      IF (NMTVR .eq. 14) then 
+! ----  for lm and gwd calculation points
+!
+! --- iwklm is the level above the height of the mountain.
+! --- idxzb is the level of the dividing streamline.
+! INITIALIZE DIVIDING STREAMLINE (DS) CONTROL VECTOR
+!
+        do i=1,npt
+          iwklm(i) = 2
+          kreflm(i) = 0
+        enddo
+!
+!
+! start lm mtn blocking (mb) section
+!
+!..............................
+!..............................
+!
+!  (*j*)  11/03:  test upper limit on KMLL=km - 1
+!      then do not need hncrit -- test with large hncrit first.
+!       KMLL  = km / 2 ! maximum mtnlm height : # of vertical levels / 2
+        KMLL = kmm1
+! --- No mtn should be as high as KMLL (so we do not have to start at 
+! --- the top of the model but could do calc for all levels).
+!
+
+!dbg
+!dbg if (lprnt) print *,'k   pkp1log   pklog    vtj(i,k)     vtk(i,k)    ro(i,k)'
+
+        DO I = 1, npt
+          j = ipt(i)
+          ELEVMX(J) = min (ELEVMX(J) + sigfac * hprime(j), hncrit)
+
+!dbg
+!dbg if (lprnt) print *,'k=',k,'  elevmx(j)=',elevmx(j),'  elvmax(j)=',elvmax(j)  &
+!dbg ,'  sigfac*hprime(j)=',sigfac*hprime(j)
+
+        ENDDO
+
+        DO K = 1,KMLL
+          DO I = 1, npt
+            j = ipt(i)
+! --- interpolate to max mtn height for index, iwklm(I) wk[gz]
+! --- ELEVMX is limited to hncrit because to hi res topo30 orog.
+            pkp1log =  phil(j,k+1) * ROG
+            pklog =  phil(j,k) * ROG
+            if ( ( ELEVMX(j) .le.  pkp1log ) .and.                      &
+     &           ( ELEVMX(j) .ge.   pklog  ) ) THEN
+! ---        wk for diags but can be saved and reused.  
+               wk(i)  = G * ELEVMX(j) / ( phil(j,k+1) - phil(j,k) )
+               iwklm(I)  =  MAX(iwklm(I), k+1 ) 
+
+!dbg if (lprnt) print *,'k,wk(i),iwklm(i)=',k,wk(i),iwklm(i)    !dbg
+
+            endif
+!
+! ---        find at prsl levels large scale environment variables
+! ---        these cover all possible mtn max heights
+            VTJ(I,K)  = T1(J,K)  * (1.+FV*Q1(J,K))  ! virtual temperature
+            VTK(I,K)  = VTJ(I,K) / PRSLK(J,K)       ! potential temperature
+            RO(I,K)   = RDI * PRSL(J,K) / VTJ(I,K)  ! DENSITY (1.e-3 kg m^-3)
+
+!dbg if (lprnt) write(6,"(i2,5e12.4)") k,pkp1log,pklog,vtj(i,k),vtk(i,k),ro(i,k)   !dbg
+
+          ENDDO    !-- DO I = 1, npt
+!
+        ENDDO      !-- DO K = 1,KMLL
+!
+! testing for highest model level of mountain top
+!
+!         ihit = 2
+!         jhit = 0
+!        do i = 1, npt
+!        j=ipt(i)
+!          if ( iwklm(i) .gt. ihit ) then 
+!            ihit = iwklm(i)
+!            jhit = j
+!          endif
+!        enddo
+!     if (lprnt) print *, ' mb: kdt,max(iwklm),jhit,phil,me=',   &
+!    &          kdt,ihit,jhit,phil(jhit,ihit),me
+!        
+!dbg if (lprnt) print *,'k    rdz    bnv2lm(i,k)'   !dbg
+        klevm1 = KMLL - 1
+        DO K = 1, klevm1  
+          DO I = 1, npt
+           j   = ipt(i)
+            RDZ  = g   / ( phil(j,k+1) - phil(j,k) )
+! ---                               Brunt-Vaisala Frequency
+            BNV2LM(I,K) = (G+G) * RDZ * ( VTK(I,K+1)-VTK(I,K) )         &
+     &                     / ( VTK(I,K+1)+VTK(I,K) )
+            bnv2lm(i,k) = max( bnv2lm(i,k), bnv2min )
+
+!dbg if (lprnt) write(6,"(i2,2e12.4)") k,rdz,bnv2lm(i,k)   !dbg
+
+          ENDDO
+        ENDDO
+!
+        DO I = 1, npt
+          J   = ipt(i)
+          DELKS(I)  = 1.0 / (PRSI(J,1) - PRSI(J,iwklm(i)))
+          DELKS1(I) = 1.0 / (PRSL(J,1) - PRSL(J,iwklm(i)))
+          UBAR (I)  = 0.0
+          VBAR (I)  = 0.0
+          ROLL (I)  = 0.0
+          PE   (I)  = 0.0
+          EK   (I)  = 0.0
+          BNV2bar(I) = (PRSL(J,1)-PRSL(J,2)) * DELKS1(I) * BNV2LM(I,1)
+        ENDDO
+!
+! --- find the dividing stream line height 
+! --- starting from the level above the max mtn downward
+! --- iwklm(i) is the k-index of mtn elevmx elevation
+!
+        DO Ktrial = KMLL, 1, -1
+          DO I = 1, npt
+             IF ( Ktrial .LT. iwklm(I) .and. kreflm(I) .eq. 0 ) then
+                kreflm(I) = Ktrial
+
+if (lprnt) print *,'Ktrial,iwklm(i),kreflm(i)=',Ktrial,iwklm(i),kreflm(I)
+
+             ENDIF
+          ENDDO
+        ENDDO
+!
+! --- in the layer kreflm(I) to 1 find PE (which needs N, ELEVMX)
+! ---  make averages, guess dividing stream (DS) line layer.
+! ---  This is not used in the first cut except for testing and
+! --- is the vert ave of quantities from the surface to mtn top.
+!   
+
+!dbg
+!dbg if (lprnt) print *,' k      rdelks      ubar        vbar     roll       ' &
+!dbg ,'bnv2bar      rcsks       rcs'
+
+        DO I = 1, npt
+          DO K = 1, Kreflm(I)
+            J        = ipt(i)
+            RDELKS     = DEL(J,K) * DELKS(I)
+
+!dbg
+            RCSKS      = RCS      * RDELKS
+            UBAR(I)    = UBAR(I)  + RCSKS  * U1(J,K) ! trial Mean U below 
+            VBAR(I)    = VBAR(I)  + RCSKS  * V1(J,K) ! trial Mean V below 
+
+            ROLL(I)    = ROLL(I)  + RDELKS * RO(I,K) ! trial Mean RO below 
+            RDELKS     = (PRSL(J,K)-PRSL(J,K+1)) * DELKS1(I)
+            BNV2bar(I) = BNV2bar(I) + BNV2lm(I,K) * RDELKS
+! --- these vert ave are for diags, testing and GWD to follow (*j*).
+
+!dbg
+!dbg if (lprnt) write(6,"(i2,7e12.4)") k,rdelks,ubar(i),vbar(i),roll(i)  &
+!dbg ,bnv2bar(i),rcsks,rcs
+
+          ENDDO
+        ENDDO
+
+!dbg
+!dbg if (lprnt) print *, 'kreflm(npt)=',kreflm(npt)  &
+!dbg ,'  bnv2bar(npt)=',bnv2bar(npt)  &
+!dbg ,'  ubar(npt)=',ubar(npt)  &
+!dbg ,'  vbar(npt)=',vbar(npt)  &
+!dbg ,'  roll(npt)=',roll(npt)  &
+!dbg ,'  delks(npt)=',delks(npt)  &
+!dbg ,'  delks1(npt)=',delks1(npt)
+
+!
+! --- integrate to get PE in the trial layer.
+! --- Need the first layer where PE>EK - as soon as 
+! --- IDXZB is not 0 we have a hit and Zb is found.
+!
+        DO I = 1, npt
+          J = ipt(i)
+
+!dbg
+!dbg if (lprnt) print *,'k   phiang    u1(j,k)     v1(j,k)     theta(j)'   &
+!dbg ,'     ang(i,k)     uds(i,k)      pe(i)     up(i)     ek(i)'
+
+          DO K = iwklm(I), 1, -1
+            PHIANG   =  RAD_TO_DEG*atan2(V1(J,K),U1(J,K))
+            ANG(I,K) = ( THETA(J) - PHIANG )
+            if ( ANG(I,K) .gt.  90. ) ANG(I,K) = ANG(I,K) - 180.
+            if ( ANG(I,K) .lt. -90. ) ANG(I,K) = ANG(I,K) + 180.
+!
+!dbg            UDS(I,K) =                                                  &
+            UDS(I,K) = rcs*                                             &
+      &          MAX(SQRT(U1(J,K)*U1(J,K) + V1(J,K)*V1(J,K)), minwnd)
+! --- Test to see if we found Zb previously
+            IF (IDXZB(I) .eq. 0 ) then
+              PE(I) = PE(I) + BNV2lm(I,K) *                             &
+     &           ( G * ELEVMX(J) - phil(J,K) ) *                        &
+     &           ( PHII(J,K+1) - PHII(J,K) ) * ROG2
+
+!dbg
+!dbg     &           ( PHII(J,K+1) - PHII(J,K) ) / (G*G)
+!dbg if (lprnt) print *,   &
+!dbg 'k=',k,'  pe(i)=',pe(i),'  bnv2lm(i,k)=',bnv2lm(i,k)  &
+!dbg ,'  g=',g,'  elevmx(j)=',elevmx(j)  &
+!dbg ,'  g*elevmx(j)-phil(j,k)=',g*elevmx(j)-phil(j,k)  &
+!dbg ,'  (phii(j,k+1)-phi(j,k))/(g*g)=',(PHII(J,K+1)-PHII(J,K) )*ROG2
+
+! --- KE
+! --- Wind projected on the line perpendicular to mtn range, U(Zb(K)).
+! --- kinetic energy is at the layer Zb
+! --- THETA ranges from -+90deg |_ to the mtn "largest topo variations"
+              UP(I)  =  UDS(I,K) * cos(DEG_TO_RAD*ANG(I,K))
+              EK(I)  = 0.5 *  UP(I) * UP(I) 
+
+! --- Dividing Stream lime  is found when PE =exceeds EK.
+              IF ( PE(I) .ge.  EK(I) ) IDXZB(I) = K
+! --- Then mtn blocked flow is between Zb=k(IDXZB(I)) and surface
+!
+            ENDIF     !-- IF (IDXZB(I) .eq. 0 ) then
+
+!dbg
+!dbg if (lprnt) write(6,"(i2,9e12.4)")   &
+!dbg k,phiang,u1(j,k),v1(j,k),theta(j),ang(i,k),uds(i,k),pe(i),up(i),ek(i)
+
+          ENDDO       !-- DO K = iwklm(I), 1, -1
+        ENDDO         !-- DO I = 1, npt
+!
+        DO I = 1, npt
+          J    = ipt(i)
+! --- Calc if N constant in layers (Zb guess) - a diagnostic only.
+          ZBK(I) =  ELEVMX(J) - SQRT(UBAR(I)**2 + VBAR(I)**2)/BNV2bar(I)
+        ENDDO
+!
+
+!dbg
+!dbg if (lprnt) print *,'iwklm=',iwklm(npt),'  ZBK=',ZBK(npt)
+
+!
+! --- The drag for mtn blocked flow
+! 
+
+!dbg
+!dbg if (lprnt) print *,'k   phil(j,k)  g*hprime(j)   '   &
+!dbg ,'phil(j,idxzb(i))-phil(j,k)    zlen   r    dbtmp    db(i,k)'
+
+!
+        DO I = 1, npt
+          J = ipt(i)
+          ZLEN = 0.
+          IF ( IDXZB(I) .gt. 0 ) then 
+            DO K = IDXZB(I), 1, -1
+              IF (PHIL(J,IDXZB(I)) > PHIL(J,K)) THEN
+                ZLEN = SQRT( ( PHIL(J,IDXZB(I))-PHIL(J,K) ) /           &
+     &                       ( PHIL(J,K ) + G * hprime(J) ) )
+! --- lm eq 14:
+                R = (cos(DEG_TO_RAD*ANG(I,K))**2 + GAMMA(J) * sin(DEG_TO_RAD*ANG(I,K))**2) / &
+     &              (gamma(J) * cos(DEG_TO_RAD*ANG(I,K))**2 + sin(DEG_TO_RAD*ANG(I,K))**2)
+! --- (negative of DB -- see sign at tendency)
+                DBTMP = 0.25 *  CDmb *                                  &
+     &                  MAX( 2. - 1. / R, HZERO ) * sigma(J) *          &
+     &                  MAX(cos(DEG_TO_RAD*ANG(I,K)), gamma(J)*sin(DEG_TO_RAD*ANG(I,K))) *  &
+     &                  ZLEN / hprime(J) 
+                DB(I,K) =  DBTMP * UDS(I,K)    
+!
+
+!dbg
+!dbg if (lprnt) write(6,"(i3,7e12.4)")  &
+!dbg k,phil(j,k),g*hprime(j),phil(j,idxzb(i))-phil(j,k),zlen,r,dbtmp,db(i,k)
+
+!
+              ENDIF        !-- IF (PHIL(J,IDXZB(I)) > PHIL(J,K) .AND. DEN > 0.) THEN
+            ENDDO          !-- DO K = IDXZB(I), 1, -1
+          endif
+        ENDDO              !-- DO I = 1, npt
+!
+!.............................
+!.............................
+! end  mtn blocking section
+!
+      ENDIF      !-- IF ( NMTVR .eq. 14) then 
+!
+!.............................
+!.............................
+!
+      KMPBL  = km / 2 ! maximum pbl height : # of vertical levels / 2
+!
+!  Scale cleff between IM=384*2 and 192*2 for T126/T170 and T62
+!
+      if (imx .gt. 0) then
+!       cleff = 1.0E-5 * SQRT(FLOAT(IMX)/384.0) !  this is inverse of CLEFF!
+!       cleff = 1.0E-5 * SQRT(FLOAT(IMX)/192.0) !  this is inverse of CLEFF!
+        cleff = 0.5E-5 * SQRT(FLOAT(IMX)/192.0) !  this is inverse of CLEFF!
+!       cleff = 2.0E-5 * SQRT(FLOAT(IMX)/192.0) !  this is inverse of CLEFF!
+!       cleff = 2.5E-5 * SQRT(FLOAT(IMX)/192.0) !  this is inverse of CLEFF!
+      endif
+
+!dbg
+!dbg if (lprnt) print *,'imx, cleff, rcl, rcs=',imx,cleff,rcl,rcs
+!dbg if (lprnt) print *,' k    vtj       vtk       ro'
+
+      DO K = 1,KM
+        DO I =1,npt
+          J         = ipt(i)
+          VTJ(I,K)  = T1(J,K)  * (1.+FV*Q1(J,K))
+          VTK(I,K)  = VTJ(I,K) / PRSLK(J,K)
+          RO(I,K)   = RDI * PRSL(J,K) / VTJ(I,K)  ! DENSITY 
+          TAUP(I,K) = 0.0
+
+!dbg
+!dbg if (lprnt) write(6,"(i2,3e12.4)")  k,vtj(i,k),vtk(i,k),ro(i,k)   !dbg
+
+        ENDDO
+      ENDDO
+
+!dbg
+!dbg if (lprnt) print *,' k     ti          tem         rdz         tem1'  &
+!dbg ,'        tem2        dw2         shr2        bvf2     ri_n(i,k)   bnv2(i,k)'
+
+      DO K = 1,KMM1
+        DO I =1,npt
+          J         = ipt(i)
+          TI        = 2.0 / (T1(J,K)+T1(J,K+1))
+          TEM       = TI  / (PRSL(J,K)-PRSL(J,K+1))
+!         RDZ       = GOR * PRSI(J,K+1) * TEM
+          RDZ       = g   / (phil(j,k+1) - phil(j,k))
+          TEM1      = U1(J,K) - U1(J,K+1)
+          TEM2      = V1(J,K) - V1(J,K+1)
+
+!dbg
+!          DW2       = TEM1*TEM1 + TEM2*TEM2
+          DW2       = rcl*(TEM1*TEM1 + TEM2*TEM2)
+
+          SHR2      = MAX(DW2,DW2MIN) * RDZ * RDZ
+          BVF2      = G*(GOCP+RDZ*(VTJ(I,K+1)-VTJ(I,K))) * TI
+          ri_n(I,K) = MAX(BVF2/SHR2,RIMIN)   ! Richardson number
+!                                              Brunt-Vaisala Frequency
+!         TEM       = GR2 * (PRSL(J,K)+PRSL(J,K+1)) * TEM
+!         BNV2(I,K) = TEM * (VTK(I,K+1)-VTK(I,K))/(VTK(I,K+1)+VTK(I,K))
+          BNV2(I,K) = (G+G) * RDZ * (VTK(I,K+1)-VTK(I,K))               &
+     &                            / (VTK(I,K+1)+VTK(I,K))
+          bnv2(i,k) = max( bnv2(i,k), bnv2min )
+
+!dbg
+!dbg if (lprnt) write(6,"(i2,10e12.4)")  &
+!dbg k,ti,tem,rdz,tem1,tem2,dw2,shr2,bvf2,ri_n(i,k),bnv2(i,k)
+
+!
+        ENDDO     !-- DO K = 1,KMM1
+      ENDDO       !-- DO I =1,npt
+!
+
+!dbg
+!dbg if (lprnt) print *,'kmm1,bnv2=',kmm1,bnv2(npt,kmm1)
+
+!
+!     Apply 3 point smoothing on BNV2
+!
+!     do k=1,km
+!       do i=1,im
+!         vtk(i,k) = bnv2(i,k)
+!       enddo
+!     enddo
+!     do k=2,kmm1
+!       do i=1,im
+!         bnv2(i,k) = 0.25*(vtk(i,k-1)+vtk(i,k+1)) + 0.5*vtk(i,k)
+!       enddo
+!     enddo
+!
+!     Finding the first interface index above 50 hPa level
+!
+      do i=1,npt
+        iwk(i) = 2
+      enddo
+
+!dbg if (lprnt) print *,'kmpbl=',kmpbl    !dbg
+
+      DO K=3,KMPBL
+        DO I=1,npt
+          j   = ipt(i)
+          tem = (prsi(j,1) - prsi(j,k))
+          if (tem .lt. dpmin) iwk(i) = k
+        enddo
+      enddo
+!
+      KBPS = 1
+      KMPS = KM
+      DO I=1,npt
+        J         = ipt(i)
+        kref(I)   = MAX(IWK(I), KPBL(J)+1 ) ! reference level 
+        DELKS(I)  = 1.0 / (PRSI(J,1) - PRSI(J,kref(I)))
+        DELKS1(I) = 1.0 / (PRSL(J,1) - PRSL(J,kref(I)))
+        UBAR (I)  = 0.0
+        VBAR (I)  = 0.0
+        ROLL (I)  = 0.0
+        KBPS      = MAX(KBPS,  kref(I))
+        KMPS      = MIN(KMPS,  kref(I))
+!
+        BNV2bar(I) = (PRSL(J,1)-PRSL(J,2)) * DELKS1(I) * BNV2(I,1)
+      ENDDO
+!
+!
+      KBPSP1 = KBPS + 1
+      KBPSM1 = KBPS - 1
+      DO K = 1,KBPS
+        DO I = 1,npt
+          IF (K .LT. kref(I)) THEN
+            J          = ipt(i)
+            RDELKS     = DEL(J,K) * DELKS(I)
+
+!dbg
+!            UBAR(I)    = UBAR(I)  + RDELKS * U1(J,K)   ! Mean U below kref
+!            VBAR(I)    = VBAR(I)  + RDELKS * V1(J,K)   ! Mean V below kref
+            RCSKS      = RCS      * RDELKS
+            UBAR(I)    = UBAR(I)  + RCSKS  * U1(J,K)   ! Mean U below kref
+            VBAR(I)    = VBAR(I)  + RCSKS  * V1(J,K)   ! Mean V below kref
+
+!
+            ROLL(I)    = ROLL(I)  + RDELKS * RO(I,K)   ! Mean RO below kref
+            RDELKS     = (PRSL(J,K)-PRSL(J,K+1)) * DELKS1(I)
+            BNV2bar(I) = BNV2bar(I) + BNV2(I,K) * RDELKS
+          ENDIF
+        ENDDO
+      ENDDO
+!
+
+!dbg
+!dbg if(lprnt) print *,'ubar(npt)=',ubar(npt)  &
+!dbg ,'  vbar(npt)=',vbar(npt),'  roll(npt)=',roll(npt)  &
+!dbg ,'  bnv2bar(npt)=',bnv2bar(npt)
+
+!
+!     FIGURE OUT LOW-LEVEL HORIZONTAL WIND DIRECTION AND FIND 'OA'
+!
+!             NWD  1   2   3   4   5   6   7   8
+!              WD  W   S  SW  NW   E   N  NE  SE
+!
+      DO I = 1,npt
+        J      = ipt(i)
+        wdir   = atan2(UBAR(I),VBAR(I)) + pi
+        idir   = mod(nint(fdir*wdir),mdir) + 1
+        nwd    = nwdir(idir)
+        OA(I)  = (1-2*INT( (NWD-1)/4 )) * OA4(J,MOD(NWD-1,4)+1)
+        CLX(I) = CLX4(J,MOD(NWD-1,4)+1)
+      ENDDO
+!
+!-----XN,YN            "LOW-LEVEL" WIND PROJECTIONS IN ZONAL
+!                                    & MERIDIONAL DIRECTIONS
+!-----ULOW             "LOW-LEVEL" WIND MAGNITUDE -        (= U)
+!-----BNV2             BNV2 = N**2
+!-----TAUB             BASE MOMENTUM FLUX
+!-----= -(RO * U**3/(N*XL)*GF(FR) FOR N**2 > 0
+!-----= 0.                        FOR N**2 < 0
+!-----FR               FROUDE    =   N*HPRIME / U
+!-----G                GMAX*FR**2/(FR**2+CG/OC)
+!
+!-----INITIALIZE SOME ARRAYS
+!
+      DO I = 1,npt
+        XN(I)     = 0.0
+        YN(I)     = 0.0
+        TAUB (I)  = 0.0
+        ULOW (I)  = 0.0
+        DTFAC(I)  = 1.0
+        ICRILV(I) = .FALSE. ! INITIALIZE CRITICAL LEVEL CONTROL VECTOR
+!
+!----COMPUTE THE "LOW LEVEL" WIND MAGNITUDE (M/S)
+!
+        ULOW(I) = MAX(SQRT(UBAR(I)*UBAR(I) + VBAR(I)*VBAR(I)), HONE)
+        ULOI(I) = 1.0 / ULOW(I)
+      ENDDO
+
+!dbg
+!dbg if (lprnt) print *,'idir,nwd,wdir,oa,clx,ulow,uloi='   &
+!dbg ,idir,nwd,wdir,oa(npt),clx(npt),ulow(npt),uloi(npt)
+
+!
+      DO  K = 1,KMM1
+        DO  I = 1,npt
+          J            = ipt(i)
+
+!dbg
+!          VELCO(I,K)   = 0.5*  ((U1(J,K)+U1(J,K+1))*UBAR(I)             &
+          VELCO(I,K)   = 0.5*rcs*((U1(J,K)+U1(J,K+1))*UBAR(I)            &
+     &                       +  (V1(J,K)+V1(J,K+1))*VBAR(I))
+
+          VELCO(I,K)   = VELCO(I,K) * ULOI(I)
+
+!dbg if (lprnt) write(6,"(a,i2,a,e12.4)") 'k=',k,' velco(i,k)=',velco(i,k)  !dbg
+
+!         IF ((VELCO(I,K).LT.VELEPS) .AND. (VELCO(I,K).GT.0.)) THEN
+!           VELCO(I,K) = VELEPS
+!         ENDIF
+        ENDDO
+      ENDDO
+!
+!   find the interface level of the projected wind where
+!   low levels & upper levels meet above pbl
+!
+      do i=1,npt
+        kint(i) = km
+      enddo
+      do k = 1,kmm1
+        do i = 1,npt
+          IF (K .GT. kref(I)) THEN
+            if(velco(i,k) .lt. veleps .and. kint(i) .eq. km) then
+              kint(i) = k+1
+            endif
+          endif
+        enddo
+      enddo
+!  WARNING  KINT = KREF !!!!!!!!!
+      do i=1,npt
+        kint(i) = kref(i)
+      enddo
+!
+!
+      DO I = 1,npt
+        J      = ipt(i)
+        BNV    = SQRT( BNV2bar(I) )
+        FR     = BNV     * ULOI(I) * min(HPRIME(J),hpmax)
+        FR     = MIN(FR, FRMAX)
+        XN(I)  = UBAR(I) * ULOI(I)
+        YN(I)  = VBAR(I) * ULOI(I)
+!
+!     Compute the base level stress and store it in TAUB
+!     CALCULATE ENHANCEMENT FACTOR, NUMBER OF MOUNTAINS & ASPECT
+!     RATIO CONST. USE SIMPLIFIED RELATIONSHIP BETWEEN STANDARD
+!     DEVIATION & CRITICAL HGT
+!
+        EFACT    = (OA(I) + 2.) ** (CEOFRC*FR)
+        EFACT    = MIN( MAX(EFACT,EFMIN), EFMAX )
+!
+        COEFM    = (1. + CLX(I)) ** (OA(I)+1.)
+!
+        XLINV(I) = COEFM * CLEFF
+!
+        TEM      = FR    * FR * OC(J)
+        GFOBNV   = GMAX  * TEM / ((TEM + CG)*BNV)  ! G/N0
+!
+        TAUB(I)  = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I)               &
+     &           * ULOW(I)  * GFOBNV  * EFACT         ! BASE FLUX Tau0
+!
+!         tem      = min(HPRIME(I),hpmax)
+!         TAUB(I)  = XLINV(I) * ROLL(I) * ULOW(I) * BNV * tem * tem
+!
+        K        = MAX(1, kref(I)-1)
+        TEM      = MAX(VELCO(I,K)*VELCO(I,K), HE_4)
+        SCOR(I)  = BNV2(I,K) / TEM  ! Scorer parameter below ref level
+      ENDDO    !-- DO I = 1,npt
+!
+
+!dbg
+!dbg if (lprnt) write(6,"(a,i2,10(a,e12.4))")  &
+!dbg  'kint=',kint(npt),' bnv=',bnv,'  fr=',fr,'  xn=',xn(npt)  &
+!dbg ,'  yn=',yn(npt),'  efact=',efact,'  coefm=',coefm,'  xlinv(npt)=',xlinv(npt)   &
+!dbg ,'  gfobnv=',gfobnv,'  taub(npt)=',taub(npt),'  scor(npt)=',scor(npt)
+
+!                                                                       
+!----SET UP BOTTOM VALUES OF STRESS
+!
+      DO K = 1, KBPS
+        DO I = 1,npt
+          IF (K .LE. kref(I)) TAUP(I,K) = TAUB(I)
+        ENDDO
+      ENDDO
+
+!
+!   Now compute vertical structure of the stress.
+!
+      DO K = KMPS, KMM1                   ! Vertical Level K Loop!
+        KP1 = K + 1
+        DO I = 1, npt
+!
+!-----UNSTABLE LAYER IF RI < RIC
+!-----UNSTABLE LAYER IF UPPER AIR VEL COMP ALONG SURF VEL <=0 (CRIT LAY)
+!---- AT (U-C)=0. CRIT LAYER EXISTS AND BIT VECTOR SHOULD BE SET (.LE.)
+!
+          IF (K .GE. kref(I)) THEN
+            ICRILV(I) = ICRILV(I) .OR. ( ri_n(I,K) .LT. RIC)            &
+     &                            .OR. (VELCO(I,K) .LE. 0.0)
+          ENDIF
+        ENDDO
+!
+        DO I = 1,npt
+          IF (K .GE. kref(I))   THEN
+
+!dbg
+!dbg if (lprnt) write(6,"(2(a,i2),a,L1,3(a,e12.4))") 'k=',k,'  kref(i)=',kref(i)  &
+!dbg ,'  icrilv(i)=',icrilv(i),'  taup(i,k)=',taup(i,k)  &
+!dbg ,'  ri_n(i,k)=',ri_n(i,k),'  velco(i,k)=',velco(i,k)
+
+!
+            IF (.NOT.ICRILV(I) .AND. TAUP(I,K) .GT. 0.0 ) THEN
+              TEMV = 1.0 / max(VELCO(I,K), HE_2)
+!             IF (OA(I) .GT. 0. .AND.  PRSI(ipt(i),KP1).GT.RLOLEV) THEN
+              IF (OA(I).GT.0. .AND. kp1 .lt. kint(i)) THEN
+                SCORK   = BNV2(I,K) * TEMV * TEMV
+                RSCOR   = MIN(HONE, SCORK / SCOR(I))
+                SCOR(I) = SCORK
+              ELSE 
+                RSCOR   = 1.
+              ENDIF
+!
+              BRVF = SQRT(BNV2(I,K))        ! Brunt-Vaisala Frequency
+!             TEM1 = XLINV(I)*(RO(I,KP1)+RO(I,K))*BRVF*VELCO(I,K)*0.5
+              TEM1 = XLINV(I)*(RO(I,KP1)+RO(I,K))*BRVF*0.5              &
+     &                       * max(VELCO(I,K),HE_2)
+              HD   = SQRT(TAUP(I,K) / TEM1)
+              FRO  = BRVF * HD * TEMV
+!
+!    RIM is the  MINIMUM-RICHARDSON NUMBER BY SHUTTS (1985)
+!
+              TEM2   = SQRT(ri_n(I,K))
+              TEM    = 1. + TEM2 * FRO
+              RIM    = ri_n(I,K) * (1.-FRO) / (TEM * TEM)
+!
+!    CHECK STABILITY TO EMPLOY THE SATURATION HYPOTHESIS
+!    OF LINDZEN (1981) EXCEPT AT TROPOSPHERIC DOWNSTREAM REGIONS
+!
+!                                       ----------------------
+
+!dbg
+!dbg if (lprnt) write(6,"(a,i2,10(a,e12.4))")  &
+!dbg  'k=',k,'  brvf=',brvf,'  tem1=',tem1,'  xlinv(i)=',xlinv(i)   &
+!dbg ,'ROavg=',.5*(RO(I,KP1)+RO(I,K)),'  hd=',hd,'  temv=',temv,'  fro=',fro  &
+!dbg ,'  tem2=',tem2,'  tem=',tem,'  rim=',rim
+
+!
+              IF (RIM .LE. RIC .AND.                                    &
+!    &           (OA(I) .LE. 0. .OR.  PRSI(ipt(I),KP1).LE.RLOLEV )) THEN
+     &           (OA(I) .LE. 0. .OR.  kp1 .ge. kint(i) )) THEN
+                 TEMC = 2.0 + 1.0 / TEM2
+                 HD   = VELCO(I,K) * (2.*SQRT(TEMC)-TEMC) / BRVF
+                 TAUP(I,KP1) = TEM1 * HD * HD
+              ELSE 
+                 TAUP(I,KP1) = TAUP(I,K) * RSCOR
+              ENDIF
+              taup(i,kp1) = min(taup(i,kp1), taup(i,k))
+
+!dbg
+!dbg if (lprnt) write(6,"(a,i2,2(a,e12.4))") 'kp1=',kp1  &
+!dbg ,'  taup(i,kp1)=',taup(i,kp1),'  taup(i,k)=',taup(i,k)
+
+            ENDIF    !-- IF (.NOT.ICRILV(I) .AND. TAUP(I,K) .GT. 0.0 ) THEN
+          ENDIF      !-- IF (K .GE. kref(I))   THEN
+        ENDDO        !-- DO I = 1,npt
+      ENDDO          !-- DO K = KMPS, KMM1
+!
+!     DO I=1,IM
+!       taup(i,km+1) = taup(i,km)
+!     ENDDO
+!
+      IF(LCAP .LE. KM) THEN
+
+!dbg if (lprnt) print *,'lcap,lcapp1,km=',lcap,lcapp1,km   !dbg
+
+         DO KLCAP = LCAPP1, KM+1
+            DO I = 1,npt
+              SIRA          = PRSI(ipt(I),KLCAP) / PRSI(ipt(I),LCAP)
+              TAUP(I,KLCAP) = SIRA * TAUP(I,LCAP)
+
+!dbg
+!dbg if (lprnt) write(6,"(a,i2,5(a,e12.4))")  &
+!dbg  'klcap=',klcap,'  sira=',sira,'  prsi(ipt(i),klcap)=', prsi(ipt(i),klcap)   &
+!dbg ,'  prsi(ipt(i),lcap)=',prsi(ipt(i),lcap),'  taup(i,lcap)=',taup(i,lcap)  &
+!dbg ,'  taup(i,klcap)=',taup(i,klcap)
+
+!
+            ENDDO
+         ENDDO
+      ENDIF
+!
+!     Calculate - (g/p*)*d(tau)/d(sigma) and Decel terms DTAUX, DTAUY
+!
+      DO I=1,npt
+!       SCOR(I) = 1.0 / PSTAR(I)
+
+!dbg
+!        SCOR(I) = 1.0
+        SCOR(I) = 1.0/RCS
+
+      ENDDO
+      DO K = 1,KM
+        DO I = 1,npt
+          TAUD(I,K) = G * (TAUP(I,K+1) - TAUP(I,K)) * SCOR(I)           &
+     &                                              / DEL(ipt(I),K)
+
+!dbg
+!dbg if (lprnt) write(6,"(a,i2,4(a,e12.4))") 'k=',k,'  taud(i,k)=',taud(i,k)  &
+!dbg ,'  D(taup)=',TAUP(I,K+1)-TAUP(I,K),'  del(ipt(i),k)=',del(ipt(i),k)  &
+!dbg ,'  scor(i)=',scor(i)
+
+        ENDDO
+      ENDDO
+
+!
+!------LIMIT DE-ACCELERATION (MOMENTUM DEPOSITION ) AT TOP TO 1/2 VALUE
+!------THE IDEA IS SOME STUFF MUST GO OUT THE TOP
+!
+      DO KLCAP = LCAP, KM
+         DO I = 1,npt
+            TAUD(I,KLCAP) = TAUD(I,KLCAP) * FACTOP
+
+!dbg
+!dbg if (lprnt) write(6,"(a,i2,a,e12.4)") 'klcap=',klcap,'  taud(i,klcap)=',taud(i,klcap)
+
+         ENDDO
+      ENDDO
+!
+!------IF THE GRAVITY WAVE DRAG WOULD FORCE A CRITICAL LINE IN THE
+!------LAYERS BELOW SIGMA=RLOLEV DURING THE NEXT DELTIM TIMESTEP,
+!------THEN ONLY APPLY DRAG UNTIL THAT CRITICAL LINE IS REACHED.
+!
+      DO K = 1,KMM1
+        DO I = 1,npt
+           IF (K .GT. kref(I) .and. PRSI(ipt(i),K) .GE. RLOLEV) THEN
+             IF(TAUD(I,K).NE.0.) THEN
+
+!dbg
+!               TEM = DELTIM * TAUD(I,K)
+               TEM = rcs*DELTIM * TAUD(I,K)
+
+               DTFAC(I) = MIN(DTFAC(I),ABS(VELCO(I,K)/TEM))
+
+!dbg
+!dbg if (lprnt) write(6,"(a,i2,2(a,e12.4))") 'k=',k  &
+!dbg ,'  tem=',tem,'  dtfac(i)=',dtfac(i)
+
+             ENDIF
+           ENDIF
+        ENDDO
+      ENDDO
+!     if(lprnt .and. npr .gt. 0) then
+!       print *, before  A=,A(npr,:)
+!       print *, before  B=,B(npr,:)
+!     endif
+!
+
+!dbg
+!dbg if (lprnt) write(6,"(a,i2,3(a,e12.4))") 'idxzb(npt)=',idxzb(npt)  &
+!dbg ,'  dtfac=',dtfac(npt),'  xn=',xn(npt),'  yn=',yn(npt)
+
+!
+      DO K = 1,KM
+        DO I = 1,npt
+          J          = ipt(i)
+          TAUD(I,K)  = TAUD(I,K) * DTFAC(I)
+          DTAUX      = TAUD(I,K) * XN(I)
+          DTAUY      = TAUD(I,K) * YN(I)
+! ---  lm mb (*j*)  changes overwrite GWD
+          if ( K .lt. IDXZB(I) .AND. IDXZB(I) .ne. 0 ) then
+            DBIM = DB(I,K) / (1.+DB(I,K)*DELTIM)
+            A(J,K)  = - DBIM * V1(J,K) + A(J,K)
+            B(J,K)  = - DBIM * U1(J,K) + B(J,K)
+            DUsfc(J)   = DUsfc(J) - DBIM * V1(J,K) * DEL(J,K)
+            DVsfc(J)   = DVsfc(J) - DBIM * U1(J,K) * DEL(J,K)
+
+!dbg
+!dbg if (lprnt .and. dbim > 0.) write(6,"(a,i2,4(a,e12.4))")  &
+!dbg  'k=',k,'  db(i,k)=',db(i,k),'  dbim=',dbim  &
+!dbg ,'  dudt=',-dbim*u1(j,k),'  dvdt=',-dbim*v1(j,k)
+
+!
+          else
+!
+            A(J,K)     = DTAUY     + A(J,K)
+            B(J,K)     = DTAUX     + B(J,K)
+            DUsfc(J)   = DUsfc(J)  + DTAUX * DEL(J,K)
+            DVsfc(J)   = DVsfc(J)  + DTAUY * DEL(J,K)
+
+!dbg
+!dbg if (lprnt .and. dtaux+dtauy/=0.) write(6,"(a,i2,2(a,e12.4))")  &
+!dbg ',k=',k,'  dudt=dtaux=',dtaux,'  dvdt=dtauy=',dtauy
+
+          endif
+
+!dbg
+!dbg if (lprnt) write(6,"(a,i2,2(a,e12.4))") 'k=',k  &
+!dbg ,'  dusfc(j)=',dusfc(j),'  dvsfc(j)=',dvsfc(j)
+
+        ENDDO      !-- DO I = 1,npt
+      ENDDO        !-- DO K = 1,KM
+!     if (lprnt) then
+!       print *, in gwdps_lm.f after  A=,A(ipr,:)
+!       print *, in gwdps_lm.f after  B=,B(ipr,:)
+!       print *, DB=,DB(ipr,:)
+!     endif
+      DO I = 1,npt
+        J          = ipt(i)
+!       TEM    = (-1.E3/G) * PSTAR(I)
+
+!dbg
+!        TEM    =  -1.E3/G
+        TEM    =  -1.E3*ROG*rcs
+        DUsfc(J) = TEM * DUsfc(J)
+        DVsfc(J) = TEM * DVsfc(J)
+
+!dbg
+!dbg if (lprnt .and. i.eq.npr) write(6,"(3(a,e12.4))") 'tem=',tem  &
+!dbg ,'  dusfc(j)=',dusfc(j),'  dvsfc(j)=',dvsfc(j)
+
+      ENDDO
+!
+      END SUBROUTINE GWD_col
+!
+!#######################################################################
+!
+      END MODULE module_gwd
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_IGWAVE_ADJUST.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_IGWAVE_ADJUST.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_IGWAVE_ADJUST.F	(revision 17)
@@ -0,0 +1,1242 @@
+!-----------------------------------------------------------------------
+!
+!NCEP_MESO:MODEL_LAYER: INERTIAL GRAVITY WAVE ADJUSTMENT
+!
+!-----------------------------------------------------------------------
+#include "nmm_loop_basemacros.h"
+#include "nmm_loop_macros.h"
+#define  DATA_CALLS_INCLUDED
+!-----------------------------------------------------------------------
+!
+      MODULE MODULE_IGWAVE_ADJUST
+!
+!-----------------------------------------------------------------------
+      USE MODULE_MODEL_CONSTANTS
+!     USE MODULE_EXCHANGE
+      USE MODULE_MPP,ONLY: MYPE
+      USE MODULE_WRF_ERROR     
+!     USE MODULE_TIMERS  ! this one creates a name conflict at compile time
+!-----------------------------------------------------------------------
+!***
+!***  SPECIFY THE NUMBER OF TIMES TO SMOOTH THE VERTICAL VELOCITY
+!***  AND THE NUMBER OF ROWS FROM THE NORTHERN AND SOUTHERN EDGES
+!***  OF THE GLOBAL DOMAIN BEYOND WHICH THE SMOOTHING DOES NOT GO
+!***  FOR SUBROUTINE PDTE
+!
+      INTEGER :: KSMUD=0,LNSDT=7
+!
+!-----------------------------------------------------------------------
+!
+      CONTAINS
+!
+!***********************************************************************
+      SUBROUTINE PFDHT(NTSD,LAST_TIME,PT,DETA1,DETA2,PDTOP,RES,FIS      &
+     &                ,HYDRO,SIGMA,FIRST,DX,DY                          &
+     &                ,HBM2,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                                  &
+     &                ,IDS,IDE,JDS,JDE,KDS,KDE                          &
+     &                ,IMS,IME,JMS,JME,KMS,KME                          &
+     &                ,ITS,ITE,JTS,JTE,KTS,KTE)
+!***********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    PFDHT       DIVERGENCE/HORIZONTAL OMEGA-ALPHA
+!   PRGRMMR: JANJIC          ORG: W/NP22     DATE: 93-10-28
+!
+! ABSTRACT:
+!     PFDHT CALCULATES THE PRESSURE GRADIENT FORCE, UPDATES THE
+!     VELOCITY COMPONENTS DUE TO THE EFFECT OF THE PRESSURE GRADIENT
+!     AND CORIOILS FORCES, COMPUTES THE DIVERGENCE INCLUDING THE
+!     MODIFICATION PREVENTING GRAVITY WAVE GRID SEPARATION, AND
+!     CALCULATES THE HORIZONTAL PART OF THE OMEGA-ALPHA TERM.
+!     (THE PART PROPORTIONAL TO THE ADVECTION OF MASS ALONG
+!      COORDINATE SURFACES).
+!
+! PROGRAM HISTORY LOG:
+!   87-06-??  JANJIC     - ORIGINATOR
+!   95-03-25  BLACK      - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
+!   96-03-29  BLACK      - ADDED EXTERNAL EDGE
+!   98-10-30  BLACK      - MODIFIED FOR DISTRIBUTED MEMORY
+!   02-02-01  BLACK      - REWRITTEN FOR WRF CODING STANDARDS
+!   04-02-17  JANJIC     - REMOVED UPDATE OF TEMPERATURE
+!   04-11-23  BLACK      - THREADED
+!   05-12-09  BLACK      - CONVERTED FROM IKJ TO IJK
+!
+! USAGE: CALL PFDHT FROM MAIN PROGRAM 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
+!-----------------------------------------------------------------------
+      LOGICAL,INTENT(IN) :: FIRST,HYDRO
+      INTEGER,INTENT(IN) :: SIGMA
+!
+      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,INTENT(IN) :: NTSD
+      LOGICAL,INTENT(IN) :: LAST_TIME
+!
+      REAL,INTENT(IN) :: CPGFV,DY,PDTOP,PT
+!
+      REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: DETA1,DETA2
+!
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: DFL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CPGFU,DX,FCP,FDIV   &
+     &                                             ,PD,FIS,RES,WPDAR    &
+     &                                             ,HBM2,VBM2,VBM3
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: CWM,DWDT    &
+     &                                                     ,Q,T
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: DIV      &
+     &                                                        ,OMGALF   &
+     &                                                        ,RTOP,U,V
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(OUT) :: FEW,FNS    &
+     &                                                      ,FNE,FSE
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: PDSL
+!
+!-----------------------------------------------------------------------
+!***  LOCAL VARIABLES
+!-----------------------------------------------------------------------
+!
+      INTEGER :: I,J,K
+!
+      REAL :: SLP_STD=101300.0
+!
+      REAL :: APELP,DFI,DCNEK,DCSEK,DPFNEK,DPFSEK,DPNEK,DPSEK           &
+     &       ,EDIV,FIUP,PRSFRC,PVNEK,PVSEK,RTOPP,VM
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: ADPDNE,ADPDSE          &
+     &                                          ,ADPDX,ADPDY,APEL       &
+     &                                          ,CNE,CSE,DFDZ,DPDE      &
+     &                                          ,DPFEW,DPFNS            &
+     &                                          ,FILO,FIM,HM            &
+     &                                          ,PCEW,PCNE,PCNS,PCSE    &
+     &                                          ,PCXC,PEW,PNE,PNS       &
+     &                                          ,PPNE,PPSE,PSE          &
+     &                                          ,RDPD,RDPDX,RDPDY       &
+     &                                          ,TEW,TNE,TNS,TSE        &
+     &                                          ,UDY,VDX
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!
+!                                       
+!                CSE                          CSE            -------  1
+!                 *                            *  
+!                 *                            *    
+!       *******   *                  *******   *   
+!      *       *  *                 *       *  *  
+!   CNE         * *              CNE         * *       
+!               TEW----------OMGALF----------TEW             -------  0
+!   CSE         * *              CSE         * *         
+!      *       *  *                 *       *  *       
+!       *******   *                  *******   *     
+!                 *                            *   
+!                 *                            * 
+!                CNE                          CNE            ------- -1
+!                                        
+!
+!
+! 
+!***********************************************************************
+! 
+!                              CSE                           -------  2
+!                               *
+!                               *
+!                               *
+!                               *
+!                      CNE*****TNS                           -------  1
+!                      CSE     | *
+!                              | *
+!                              | *
+!                              | *
+!                              | CNE
+!                            OMGALF                          -------  0
+!                              | CSE
+!                              | *
+!                              | *
+!                              | *
+!                      CNE     | *
+!                      CSE*****TNS                           ------- -1
+!                               *
+!                               *
+!                               *
+!                               *
+!                              CNE                           ------- -2
+! 
+!***********************************************************************
+!-----------------------------------------------------------------------
+!***  PREPARATORY CALCULATIONS
+!-----------------------------------------------------------------------
+!     call hpm_start('PFDHT')
+!
+!$omp parallel do
+      DO K=KMS,KME
+        DO J=JMS,JME
+        DO I=IMS,IME
+          OMGALF(I,J,K)=0.
+          DIV(I,J,K)=0.
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!$omp parallel do
+      DO J=JMS,JME
+      DO I=IMS,IME
+        PDSL(I,J)=0.
+      ENDDO
+      ENDDO
+!
+!$omp parallel do
+      DO J=JTS-5,JTE+5
+      DO I=ITS-5,ITE+5
+        ADPDNE(I,J)=0.
+        ADPDSE(I,J)=0.
+        ADPDX(I,J)=0.
+        ADPDY(I,J)=0.
+        APEL(I,J)=0.
+        CNE (I,J)=0.
+        CSE (I,J)=0.
+        DFDZ(I,J)=0.
+        DPDE(I,J)=0.
+        DPFEW(I,J)=0.
+        DPFNS(I,J)=0.
+        FILO(I,J)=0.
+        FIM (I,J)=0.
+        HM (I,J)=0.
+        PCEW(I,J)=0.
+        PCNE(I,J)=0.
+        PCNS(I,J)=0.
+        PCSE(I,J)=0.
+        PCXC(I,J)=0.
+        PEW (I,J)=0.
+        PNE (I,J)=0.
+        PNS (I,J)=0.
+        PPNE(I,J)=0.
+        PPSE(I,J)=0.
+        PSE (I,J)=0.
+        RDPD(I,J)=0.
+        RDPDX(I,J)=0.
+        RDPDY(I,J)=0.
+        TEW (I,J)=0.
+        TNE (I,J)=0.
+        TNS (I,J)=0.
+        TSE (I,J)=0.
+        UDY (I,J)=0.
+        VDX (I,J)=0.
+      ENDDO
+      ENDDO
+!
+      IF(SIGMA==1)THEN
+!$omp parallel do
+        DO J=MYJS_P4,MYJE_P4
+        DO I=MYIS_P4,MYIE_P4
+          FILO(I,J)=FIS(I,J)
+          PDSL(I,J)=PD(I,J)
+        ENDDO
+        ENDDO
+      ELSE
+!$omp parallel do
+        DO J=MYJS_P4,MYJE_P4
+        DO I=MYIS_P4,MYIE_P4
+          FILO(I,J)=0.0
+          PDSL(I,J)=RES(I,J)*PD(I,J)
+        ENDDO
+        ENDDO
+      ENDIF
+!
+      PRSFRC=PDTOP/(SLP_STD-PT)
+!
+!-----------------------------------------------------------------------
+!
+!***  MAIN VERTICAL INTEGRATION LOOP
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(adpdne,adpdse,adpdx,adpdy,                               &
+!$omp&         apel,cne,cse,dcnek,dcsek,dfdz,dpde,dpfew,dpfnek,         &
+!$omp&         dpfns,dpfsek,dpnek,ediv,few,fne,fns,fse,hm,              &
+!$omp&         pcew,pcne,pcns,pcse,pcxc,pew,pne,pns,ppne,ppse,          &
+!$omp&         pse,pvnek,pvsek,rdpd,rdpdx,rdpdy,tew,tne,tns,tse,        &
+!$omp&         udy,vdx,vm)
+!-----------------------------------------------------------------------
+!
+       main_integration : DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***  INTEGRATE THE GEOPOTENTIAL
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS_P4,MYJE_P4
+        DO I=MYIS_P4,MYIE_P4
+!
+          HM(I,J)=HBM2(I,J)
+!
+          APELP=(PINT(I,J,K+1)+PINT(I,J,K))*0.5
+          RTOPP=(Q(I,J,K)*P608-CWM(I,J,K)+1.)*T(I,J,K)*R_D/APELP
+          DFI=RTOPP*(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))
+!
+          APEL(I,J)=APELP
+          RTOP(I,J,K)=RTOPP
+          DFDZ(I,J)=RTOPP
+!
+          FIUP=FILO(I,J)+DFI
+          FIM(I,J)=FILO(I,J)+FIUP
+!     if(i==154.and.j==096)then
+!       write(0,10281)k,q(i,j,k),cwm(i,j,k),t(i,j,k),apelp,pdsl(i,j)
+10281   format(' k=',i2,' q=',z8,' cwm=',z8,' t=',z8,' apelp=',z8,' pdsl=',z8)
+!     endif
+          FILO(I,J)=FIUP
+!
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS_P4,MYJE_P4
+        DO I=MYIS_P4,MYIE_P4
+          DPDE(I,J)=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+        ENDDO
+        ENDDO
+!
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+          RDPD(I,J)=1./DPDE(I,J)
+        ENDDO
+        ENDDO
+!
+        DO J=MYJS1_P3,MYJE1_P3
+        DO I=MYIS_P3,MYIE_P3
+          ADPDX(I,J)=DPDE(I+IVW(J),J)+DPDE(I+IVE(J),J)
+          ADPDY(I,J)=DPDE(I,J+1)+DPDE(I,J-1)
+          RDPDX(I,J)=1./ADPDX(I,J)
+          RDPDY(I,J)=1./ADPDY(I,J)
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  DIAGONAL CONTRIBUTIONS TO PRESSURE GRADIENT FORCE
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS_P3,MYJE1_P3
+        DO I=MYIS_P3,MYIE_P3
+          ADPDNE(I,J)=DPDE(I+IHE(J),J+1)+DPDE(I,J)
+          PNE(I,J)=(FIM (I+IHE(J),J+1)-FIM (I,J))                       &
+     &            *(DWDT(I+IHE(J),J+1,K)+DWDT(I,J,K))
+          PPNE(I,J)=PNE(I,J)*ADPDNE(I,J)
+          CNE(I,J)=(DFDZ(I+IHE(J),J+1)+DFDZ(I,J))*2.                    &
+     &            *(APEL(I+IHE(J),J+1)-APEL(I,J))
+          PCNE(I,J)=CNE(I,J)*ADPDNE(I,J)
+        ENDDO
+        ENDDO
+!
+        DO J=MYJS1_P3,MYJE_P3
+        DO I=MYIS_P3,MYIE_P3
+          ADPDSE(I,J)=DPDE(I+IHE(J),J-1)+DPDE(I,J)
+          PSE(I,J)=(FIM (I+IHE(J),J-1)-FIM (I,J))                       &
+     &            *(DWDT(I+IHE(J),J-1,K)+DWDT(I,J,K))
+!     if(i==154.and.j==096.and.k==kte)then
+!       write(0,58391)PSE(I,J),FIM(I+IHE(J),J-1),FIM(I,J),DWDT(I+IHE(J),J-1,K),DWDT(I,J,K),ihe(j)
+58391   format(' pse=',z8,' fim=',2(1x,z8),' dwdt=',2(1x,z8),' ihe=',i2)
+!     endif
+          PPSE(I,J)=PSE(I,J)*ADPDSE(I,J)
+          CSE(I,J)=(DFDZ(I+IHE(J),J-1)+DFDZ(I,J))*2.                    &
+     &            *(APEL(I+IHE(J),J-1)-APEL(I,J))
+          PCSE(I,J)=CSE(I,J)*ADPDSE(I,J)
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  CONTINUITY EQUATION MODIFICATION
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS1_P1,MYJE1_P1
+        DO I=MYIS_P1,MYIE_P1
+!     if(i==155.and.j==096.and.k==kte)then
+!       write(0,72451)PNE(I+IVW(J),J),PNE(I,J-1),PSE(I+IVW(J),J),PSE(I,J+1),ivw(j)
+!       write(0,72452)CNE(I+IVW(J),J),CNE(I,J-1),CSE(I+IVW(J),J),CSE(I,J+1)
+72451   format(' pne=',2(1x,z8),' pse=',2(1x,z8),' ivw=',i2)
+72452   format(' cne=',2(1x,z8),' cse=',2(1x,z8))
+!     endif
+          PCXC(I,J)=VBM3(I,J)*                                          &
+     &             (PNE(I+IVW(J),J)+CNE(I+IVW(J),J)                     &
+     &             +PSE(I+IVW(J),J)+CSE(I+IVW(J),J)                     &
+     &             -PNE(I,J-1)-CNE(I,J-1)                               &
+     &             -PSE(I,J+1)-CSE(I,J+1))
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+!     if(i==155.and.j==095.and.k==kte)then
+!       write(0,76501)deta1(k),deta2(k),prsfrc,wpdar(i,j),ihe(j),ihw(j)
+!       write(0,76502)PCXC(I+IHE(J),J),PCXC(I,J+1),PCXC(I+IHW(J),J),PCXC(I,J-1)
+76501   format(' deta1=',z8,' deta2=',z8,' prsfrc=',z8,' wpdar=',z8,' ihe=',i2,' ihw=',i2)
+76502   format(' pcxc=',4(1x,z8))
+!     endif
+          DIV(I,J,K)=(DETA1(K)*PRSFRC                                   &   
+     &               +DETA2(K)*(1.-PRSFRC))*WPDAR(I,J)                  &
+     &              *(PCXC(I+IHE(J),J)-PCXC(I,J+1)                      &
+     &               +PCXC(I+IHW(J),J)-PCXC(I,J-1))
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  LATITUDINAL AND LONGITUDINAL PRESSURE FORCE COMPONENTS
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS1_P2,MYJE1_P2
+        DO I=MYIS_P2,MYIE_P3
+          DPNEK=PNE(I+IVW(J),J)+PNE(I,J-1)
+          DPSEK=PSE(I+IVW(J),J)+PSE(I,J+1)
+          PEW(I,J)=DPNEK+DPSEK
+          PNS(I,J)=DPNEK-DPSEK
+          DCNEK=CNE(I+IVW(J),J)+CNE(I,J-1)
+          DCSEK=CSE(I+IVW(J),J)+CSE(I,J+1)
+          PCEW(I,J)=(DCNEK+DCSEK)*ADPDX(I,J)
+          PCNS(I,J)=(DCNEK-DCSEK)*ADPDY(I,J)
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+        IF(.NOT.FIRST)THEN     ! Skip at timestep 0
+!
+!-----------------------------------------------------------------------
+!***  UPDATE U AND V FOR PRESSURE GRADIENT FORCE
+!-----------------------------------------------------------------------
+!
+          DO J=MYJS2_P2,MYJE2_P2
+          DO I=MYIS_P2,MYIE1_P2
+            DPFNEK=((PPNE(I+IVW(J),J)+PPNE(I,J-1))                      &
+     &             +(PCNE(I+IVW(J),J)+PCNE(I,J-1)))
+            DPFNEK=DPFNEK+DPFNEK
+            DPFSEK=((PPSE(I+IVW(J),J)+PPSE(I,J+1))                      &
+     &             +(PCSE(I+IVW(J),J)+PCSE(I,J+1)))
+            DPFSEK=DPFSEK+DPFSEK
+            DPFEW(I,J)=DPFNEK+DPFSEK
+            DPFNS(I,J)=DPFNEK-DPFSEK
+          ENDDO
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!
+          DO J=MYJS2_P3,MYJE2_P3
+          DO I=MYIS_P2,MYIE1_P2
+            VM=VBM2(I,J)
+            U(I,J,K)=(((DPFEW(I,J)+PCEW(I,J))*RDPDX(I,J)                &
+     &                 +PEW(I,J))*CPGFU(I,J))*VM+U(I,J,K)
+            V(I,J,K)=(((DPFNS(I,J)+PCNS(I,J))*RDPDY(I,J)                &
+     &                 +PNS(I,J))*CPGFV)*VM+V(I,J,K)
+          ENDDO
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!
+        ENDIF    !End of IF block executed for FIRST equal to .FALSE.
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+        IF(.NOT.LAST_TIME)THEN    !Do not execute block at last timestep
+!
+!-----------------------------------------------------------------------
+!***  LATITUDINAL AND LONGITUDINAL FLUXES AND OMEGA-ALPHA COMPONENTS
+!-----------------------------------------------------------------------
+!
+          DO J=MYJS1_P2,MYJE1_P2
+          DO I=MYIS_P2,MYIE_P3
+            UDY(I,J)=DY*U(I,J,K)
+            FEW(I,J,K)=UDY(I,J)*ADPDX(I,J)
+            TEW(I,J)=UDY(I,J)*PCEW(I,J)
+            VDX(I,J)=DX(I,J)*V(I,J,K)
+!     if(i==178.and.j==003.and.k==53)then
+!       write(0,77601)udy(i,j),dy,u(i,j,k)
+77601   format(' udy=',z8,' dy=',z8,' u=',z8)
+!     endif
+            FNS(I,J,K)=VDX(I,J)*ADPDY(I,J)
+            TNS(I,J)=VDX(I,J)*PCNS(I,J)
+          ENDDO
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!***  DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND
+!-----------------------------------------------------------------------
+!
+          DO J=MYJS1_P1,MYJE2_P1
+          DO I=MYIS_P1,MYIE1_P1
+            PVNEK=(UDY(I+IHE(J),J)+VDX(I+IHE(J),J))                     &
+     &           +(UDY(I,J+1)+VDX(I,J+1))
+            FNE(I,J,K)=PVNEK*ADPDNE(I,J)
+!     if(i==178.and.j==003.and.k==53)then
+!       write(0,33781)fne(i,j,k),dpde(i+ihe(j),j+1),dpde(i,j),ihe(j)
+!       write(0,33782)udy(i+ihe(j),j),udy(i,j+1),vdx(i+ihe(j),j),vdx(i,j+1)
+33781   format(' fne=',z8,' dpdne=',2(1x,z8),' ihe=',i2)
+33782   format(' udy=',2(1x,z8),' vdx=',2(1x,z8))
+!     endif
+            TNE(I,J)=PVNEK*PCNE(I,J)*2.
+          ENDDO
+          ENDDO
+!
+          DO J=MYJS2_P1,MYJE1_P1
+          DO I=MYIS_P1,MYIE1_P1
+            PVSEK=(UDY(I+IHE(J),J)-VDX(I+IHE(J),J))                     &
+     &           +(UDY(I,J-1)-VDX(I,J-1))
+            FSE(I,J,K)=PVSEK*ADPDSE(I,J)
+            TSE(I,J)=PVSEK*PCSE(I,J)*2.
+          ENDDO
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!***  HORIZONTAL PART OF OMEGA-ALPHA & DIVERGENCE
+!-----------------------------------------------------------------------
+!
+          DO J=MYJS2,MYJE2
+          DO I=MYIS1,MYIE1
+            OMGALF(I,J,K)=(TEW(I+IHE(J),J)+TEW(I+IHW(J),J)              &
+     &                    +TNS(I,J+1)     +TNS(I,J-1)                   &
+     &                    +TNE(I,J)       +TNE(I+IHW(J),J-1)            &
+     &                    +TSE(I,J)       +TSE(I+IHW(J),J+1))           &
+     &                    *RDPD(I,J)*FCP(I,J)*HM(I,J)
+! 
+!     if(i==178.and.j==003.and.k==53)then
+!       write(0,36311)div(i,j,k),fdiv(i,j),ihe(j),ihw(j)
+!       write(0,36312)FEW(I+IHE(J),J,K),FEW(I+IHW(J),J,K),FNS(I,J+1,K),FNS(I,J-1,K)
+!       write(0,36313)FNE(I,J,K),FNE(I+IHW(J),J-1,K),FSE(I,J,K),FSE(I+IHW(J),J+1,K)
+36311   format(' PFDHT div=',z8,' fdiv=',z8,' ihe=',i2,' ihw=',i2)
+36312   format(' few=',2(1x,z8),' fns=',2(1x,z8))
+36313   format(' fne=',2(1x,z8),' fse=',2(1x,z8))
+!     endif
+            EDIV=(FEW(I+IHE(J),J,K)  +FNS(I,J+1,K)                      &
+                 +FNE(I,J,K)         +FSE(I,J,K)                        &
+                -(FEW(I+IHW(J),J,K)  +FNS(I,J-1,K)                      &
+                 +FNE(I+IHW(J),J-1,K)+FSE(I+IHW(J),J+1,K)))*FDIV(I,J)
+!
+            DIV(I,J,K)=(EDIV+DIV(I,J,K))*HM(I,J)
+          ENDDO
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!
+        ENDIF   !End block to skip execution at last timestep
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO main_integration
+!
+!-----------------------------------------------------------------------
+!     call hpm_stop('PFDHT')
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE PFDHT
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      SUBROUTINE PDTE(                                                  &
+#ifdef DM_PARALLEL
+     &                GRID,MYPE,MPI_COMM_COMP,                          &
+#endif
+     &                NTSD,DT,PT,ETA2,RES,HYDRO,HBM2                    &
+     &               ,PD,PDSL,PDSLO                                     &
+     &               ,PETDT,DIV,PSDT                                    &
+     &               ,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:    PDTE        SURFACE PRESSURE TENDENCY CALC
+!   PRGRMMR: JANJIC          ORG: W/NP2      DATE: 96-07-??      
+!     
+! ABSTRACT:
+!     PDTE VERTICALLY INTEGRATES THE MASS FLUX DIVERGENCE TO
+!     OBTAIN THE SURFACE PRESSURE TENDENCY AND VERTICAL VELOCITY ON
+!     THE LAYER INTERFACES.  THEN IT UPDATES THE HYDROSTATIC SURFACE
+!     PRESSURE AND THE NONHYDROSTATIC PRESSURE.
+!     
+! PROGRAM HISTORY LOG:
+!   87-06-??  JANJIC     - ORIGINATOR
+!   95-03-25  BLACK      - CONVERSION FROM 1-D TO 2-D IN HORIZONTAL
+!   96-05-??  JANJIC     - ADDED NONHYDROSTATIC EFFECTS & MERGED THE
+!                          PREVIOUS SUBROUTINES PDTE & PDNEW
+!   00-01-03  BLACK      - DISTRIBUTED MEMORY AND THREADS
+!   01-02-23  BLACK      - CONVERTED TO WRF FORMAT
+!   01-04-11  BLACK      - REWRITTEN FOR WRF CODING STANDARDS
+!   04-02-17  JANJIC     - MOVED UPDATE OF T DUE TO OMEGA-ALPHA TERM
+!                          AND UPDATE OF PINT TO NEW ROUTINE VTOA
+!   04-11-23  BLACK      - THREADED
+!   05-12-09  BLACK      - CONVERTED FROM IKJ TO IJK
+!     
+! USAGE: CALL PDTE 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
+!$$$  
+!***********************************************************************
+#ifdef DM_PARALLEL
+      USE module_domain
+      USE MODULE_DM,                    ONLY : LOCAL_COMMUNICATOR       &
+                                              ,MYTASK,NTASKS,NTASKS_X   &
+                                              ,NTASKS_Y                 &
+                                              ,wrf_dm_sum_real          &
+                                              ,wrf_dm_sum_integer          
+      USE MODULE_COMM_DM
+#endif
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      INCLUDE "mpif.h"
+#endif
+#ifdef DM_PARALLEL
+      TYPE (DOMAIN) :: GRID
+      INTEGER,INTENT(IN) :: MYPE,MPI_COMM_COMP
+#endif
+!-----------------------------------------------------------------------
+      LOGICAL,INTENT(IN) :: HYDRO
+!
+      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,INTENT(IN) :: NTSD
+!
+      REAL,INTENT(IN) :: DT,PT
+!
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: ETA2
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: RES,HBM2   
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: DIV
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: PD,PDSL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: PETDT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: PDSLO,PSDT
+!
+!-----------------------------------------------------------------------
+!***  LOCAL VARIABLES
+!-----------------------------------------------------------------------
+!
+      INTEGER :: I,IHH,IHL,IX,J,JHH,JHL,JX,K,KS,NSMUD
+      INTEGER :: MY_IS_GLB,MY_IE_GLB,MY_JS_GLB,MY_JE_GLB
+      INTEGER :: LOC_NPTS, GLB_NPTS
+#ifdef DM_PARALLEL
+      INTEGER :: IPS,IPE,JPS,JPE,KPS,KPE,IRET
+#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
+!
+      REAL :: PETDTL, TASK_CHANGE, GLOBAL_CHANGE, GLOBAL_CHANGE_WRF
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: HBMS,PNE,PRET,PSE
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!#include "deref_kludge.h"
+!
+      DO J=JMS,JME
+      DO I=IMS,IME
+        PDSLO(I,J)=0.
+      ENDDO
+      ENDDO
+!
+      MY_IS_GLB=ITS
+      MY_IE_GLB=ITE
+      MY_JS_GLB=JTS
+      MY_JE_GLB=JTE
+!
+!-----------------------------------------------------------------------
+!***  VERTICALLY INTEGRATE THE HORIZONTAL DIVERGENCE
+!-----------------------------------------------------------------------
+!
+
+      LOC_NPTS=0
+
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO K=KTE-1,KTS,-1
+        DO J=MYJS_P2,MYJE_P2
+        DO I=MYIS_P2,MYIE_P2
+          DIV(I,J,K)=DIV(I,J,K+1)+DIV(I,J,K)
+        if (K .eq. KTS) then
+         LOC_NPTS=LOC_NPTS+1
+        endif
+
+        ENDDO
+        ENDDO
+      ENDDO
+
+#ifdef DM_PARALLEL
+      GLB_NPTS=wrf_dm_sum_integer(LOC_NPTS)
+#else
+      GLB_NPTS=LOC_NPTS
+#endif
+
+!
+!-----------------------------------------------------------------------
+!***  COMPUTATION OF PRESSURE TENDENCY
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS_P2,MYJE_P2
+      DO I=MYIS_P2,MYIE_P2
+        PSDT(I,J)=-DIV(I,J,KTS)
+        PDSLO(I,J)=PDSL(I,J)
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+      DO J=JMS,JME
+      DO I=IMS,IME
+        PDSL(I,J)=0.
+      ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+
+      TASK_CHANGE=0.
+
+      DO J=MYJS_P2,MYJE_P2
+      DO I=MYIS_P2,MYIE_P2
+        PD(I,J)=PSDT(I,J)*DT+PD(I,J)
+        PRET(I,J)=PSDT(I,J)*RES(I,J)
+        PDSL(I,J)=PD(I,J)*RES(I,J)
+        TASK_CHANGE=TASK_CHANGE+abs(PSDT(I,J)*108./DT)  ! .01*10800/dt (hPa/3 h)
+      ENDDO
+      ENDDO
+
+#ifdef DM_PARALLEL
+      GLOBAL_CHANGE_WRF=wrf_dm_sum_real(TASK_CHANGE)/GLB_NPTS
+#else
+      GLOBAL_CHANGE_WRF=TASK_CHANGE/GLB_NPTS
+#endif
+
+#ifdef DM_PARALLEL
+      if ( MYPE == 0 ) then
+        write(wrf_err_message,*) 'avg global change (hPa/3h): ', GLOBAL_CHANGE_WRF
+        call wrf_debug(1,wrf_err_message)
+      endif
+#else
+        write(wrf_err_message,*) 'avg global change (hPa/3h): ', GLOBAL_CHANGE_WRF
+        call wrf_debug(1,wrf_err_message)
+#endif
+
+!
+!-----------------------------------------------------------------------
+!***  COMPUTATION OF PETDT
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO K=KTE-1,KTS,-1
+        DO J=MYJS_P2,MYJE_P2
+        DO I=MYIS_P2,MYIE_P2
+          PETDT(I,J,K)=-(PRET(I,J)*ETA2(K+1)+DIV(I,J,K+1))              &
+     &                  *HBM2(I,J)
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  SMOOTHING VERTICAL VELOCITY ALONG BOUNDARIES
+!-----------------------------------------------------------------------
+!
+      nonhydrostatic_smoothing: IF(.NOT.HYDRO.AND.KSMUD.GT.0)THEN
+!
+        NSMUD=KSMUD
+!
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+          HBMS(I,J)=HBM2(I,J)
+        ENDDO
+        ENDDO
+!
+        JHL=LNSDT
+        JHH=JDE-JHL+1
+!
+!$omp parallel do                                                       &
+!$omp& private(i,ihh,ihl,ix,j,jx)
+        DO J=JHL,JHH
+          IF(J.GE.MY_JS_GLB.AND.J.LE.MY_JE_GLB)THEN
+            IHL=JHL/2+1
+            IHH=IDE-IHL+MOD(J,2)
+!
+            DO I=IHL,IHH
+              IF(I.GE.MY_IS_GLB.AND.I.LE.MY_IE_GLB)THEN
+                IX=I    ! -MY_IS_GLB+1
+                JX=J    ! -MY_JS_GLB+1
+                HBMS(IX,JX)=0.
+              ENDIF
+            ENDDO
+!
+          ENDIF
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***
+!***  SMOOTH THE VERTICAL VELOCITY
+!***
+!-----------------------------------------------------------------------
+!
+        DO KS=1,NSMUD
+!
+!-----------------------------------------------------------------------
+!
+!***  PNE AT H(I,J) LIES BETWEEN (I,J) AND THE H POINT TO THE NE.
+!***  PSE AT H(I,J) LIES BETWEEN (I,J) AND THE H POINT TO THE SE.
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k,petdtl,pne,pse)
+!
+          DO K=KTS+1,KTE
+!
+            DO J=MYJS_P1,MYJE1_P1
+            DO I=MYIS_P1,MYIE1_P1
+              PNE(I,J)=PETDT(I+IHE(J),J+1,K)-PETDT(I,J,K)
+            ENDDO
+            ENDDO
+!
+            DO J=MYJS1_P1,MYJE_P1
+            DO I=MYIS_P1,MYIE1_P1
+              PSE(I,J)=PETDT(I+IHE(J),J-1,K)-PETDT(I,J,K)
+            ENDDO
+            ENDDO
+!
+            DO J=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+              PETDTL=(PNE(I,J)-PNE(I+IHW(J),J-1)                        &
+     &               +PSE(I,J)-PSE(I+IHW(J),J+1))*HBM2(I,J)
+              PETDT(I,J,K)=PETDTL*HBMS(I,J)*0.125+PETDT(I,J,K)
+            ENDDO
+            ENDDO
+!
+          ENDDO
+!
+#ifdef DM_PARALLEL
+!          IPS=ITS;IPE=ITE;JPS=JTS;JPE=JTE;KPS=KTS;KPE=KTE
+# include <HALO_NMM_E.inc>
+#endif
+!-----------------------------------------------------------------------
+!
+        ENDDO  ! End of smoothing loop
+!
+!-----------------------------------------------------------------------
+!
+      ENDIF nonhydrostatic_smoothing
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE PDTE
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      SUBROUTINE VTOA(                                                  &
+#ifdef DM_PARALLEL
+     &                GRID,                                             &
+#endif
+     &                NTSD,DT,PT,ETA2                                   &
+     &               ,HBM2,EF4T                                         &
+     &               ,T,DWDT,RTOP,OMGALF                                &
+     &               ,PINT,DIV,PSDT,RES                                 &
+     &               ,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:    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,                    ONLY : LOCAL_COMMUNICATOR       &
+                                              ,MYTASK,NTASKS,NTASKS_X   &
+                                              ,NTASKS_Y
+      USE MODULE_COMM_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
+!
+      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,JMS:JME,KMS:KME),INTENT(IN) :: DIV,DWDT    &
+     &                                                     ,RTOP
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: OMGALF,T  
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: PINT
+!
+!-----------------------------------------------------------------------
+!***  LOCAL VARIABLES
+!-----------------------------------------------------------------------
+!
+      INTEGER :: I,J,K
+!
+      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,J,KTE+1)=PT
+        TPM(I,J)=PT+PINT(I,J,KTE)
+        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,J,KTE)
+        TPMP=PINT(I,J,KTE)+PINT(I,J,KTE-1)
+!
+        RHS=-DIV(I,J,KTE)*RTOP(I,J,KTE)*DWDTP*EF4T
+        OMGALF(I,J,KTE)=OMGALF(I,J,KTE)+RHS
+        T(I,J,KTE)=OMGALF(I,J,KTE)*HBM2(I,J)+T(I,J,KTE)
+        PINT(I,J,KTE)=PRET(I,J)*(ETA2(KTE+1)+ETA2(KTE))*DWDTP*DT        &
+     &             +TPM(I,J)-PINT(I,J,KTE+1)
+!
+        TPM(I,J)=TPMP
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dwdtp,i,j,k,rhs,tpmp)
+      DO K=KTE-1,KTS+1,-1
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+          DWDTP=DWDT(I,J,K)
+          TPMP=PINT(I,J,K)+PINT(I,J,K-1)
+!
+          RHS=-(DIV(I,J,K+1)+DIV(I,J,K))*RTOP(I,J,K)*DWDTP*EF4T
+          OMGALF(I,J,K)=OMGALF(I,J,K)+RHS
+          T(I,J,K)=OMGALF(I,J,K)*HBM2(I,J)+T(I,J,K)
+          PINT(I,J,K)=PRET(I,J)*(ETA2(K+1)+ETA2(K))*DWDTP*DT            &
+     &               +TPM(I,J)-PINT(I,J,K+1)
+!
+          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,J,KTS)
+!
+!     if(i==77.and.j==53)then
+!       write(0,28361)t(i,j,kts),omgalf(i,j,kts),rtop(i,j,kts),dwdtp
+!       write(0,28362)div(i,j,kts),div(i,j,kts+1),ef4t
+28361   format(' t=',z8,' omgalf=',z8,' rtop=',z8,' dwdtp=',z8)
+28362   format(' div=',2(1x,z8),' ef4t=',z8)
+!     endif
+        RHS=-(DIV(I,J,KTS+1)+DIV(I,J,KTS))*RTOP(I,J,KTS)*DWDTP*EF4T
+        OMGALF(I,J,KTS)=OMGALF(I,J,KTS)+RHS
+        T(I,J,KTS)=OMGALF(I,J,KTS)*HBM2(I,J)+T(I,J,KTS)
+        PINT(I,J,KTS)=PRET(I,J)*(ETA2(KTS+1)+ETA2(KTS))*DWDTP*DT        &
+     &                 +TPM(I,J)-PINT(I,J,KTS+1)
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE VTOA
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE DDAMP(NTSD,DT,DETA1,DETA2,PDSL,PDTOP,DIV,HBM2          &
+     &                ,T,U,V,DDMPU,DDMPV                                &
+     &                ,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:    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
+!   05-12-09  BLACK      - CONVERTED FROM IKJ TO IJK
+!     
+! 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
+!
+      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,JMS:JME,KMS:KME),INTENT(INOUT) :: DIV,T    &
+     &                                                        ,U,V
+!
+!-----------------------------------------------------------------------
+!***  LOCAL VARIABLES
+!-----------------------------------------------------------------------
+!
+      INTEGER :: I,J,K
+!
+      REAL :: FCIM,FCXM,RDPDX,RDPDY
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: DIVE,DPDE,PDE          &
+     &                                          ,XDIVX,XDIVY
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=JTS-5,JTE+5
+      DO I=ITS-5,ITE+5
+        PDE(I,J)=0.
+        DPDE(I,J)=0.
+        XDIVX(I,J)=0.
+        XDIVY(I,J)=0.
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      FCXM=1.
+!
+      DO J=MYJS_P2,MYJE_P2
+      DO I=MYIS_P2,MYIE_P2
+        PDE (I,J)=PDSL(I,J)+PDTOP
+        DIVE(I,J)=0.
+      ENDDO
+      ENDDO
+!
+      DO K=KTS,KTE
+!$omp parallel do
+        DO J=MYJS_P2,MYJE_P2
+        DO I=MYIS_P2,MYIE_P2
+          DIVE(I,J)=DIV(I,J,K)*HBM2(I,J)+DIVE(I,J)
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,rdpdx,rdpdy)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1_P1,MYIE1_P1
+        RDPDX=DDMPU(I,J)*FCXM                                           &
+     &       /(PDE(I+IVW(J),J)  +PDE(I+IVE(J),J))    
+        RDPDY=DDMPV(I,J)*FCXM                                           &
+     &       /(PDE(I       ,J-1)+PDE(I     ,J+1))
+!
+        XDIVX(I,J)=(DIVE(I+IVE(J),J  )-DIVE(I+IVW(J),J  ))*RDPDX
+        XDIVY(I,J)=(DIVE(I       ,J+1)-DIVE(I       ,J-1))*RDPDY
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      FCIM=1.
+!
+!$omp parallel do                                                       &
+!$omp& private(dpde,i,j,k,rdpdx,rdpdy)
+!
+      DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS_P2,MYJE_P2
+        DO I=MYIS_P1,MYIE_P1
+          DPDE(I,J)=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+          DIV(I,J,K)=DIV(I,J,K)*HBM2(I,J)
+        ENDDO
+        ENDDO
+!
+        DO J=MYJS2,MYJE2
+        DO I=MYIS1_P1,MYIE1_P1
+          RDPDX=DDMPU(I,J)*FCIM                                        &
+     &         /(DPDE(I+IVW(J),J)  +DPDE(I+IVE(J),J))
+          RDPDY=DDMPV(I,J)*FCIM                                        &
+     &         /(DPDE(I       ,J-1)+DPDE(I       ,J+1))
+          U(I,J,K)=((DIV(I+IVE(J),J,K  )-DIV(I+IVW(J),J,K  ))*RDPDX    &
+     &             +XDIVX(I,J))+U(I,J,K)
+          V(I,J,K)=((DIV(I       ,J+1,K)-DIV(I       ,J-1,K))*RDPDY    &
+     &             +XDIVY(I,J))+V(I,J,K)
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO 
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE DDAMP
+!
+!-----------------------------------------------------------------------
+!
+      END MODULE MODULE_IGWAVE_ADJUST
+!
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_INDX.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_INDX.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_INDX.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_MPP.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_MPP.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_MPP.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_MPPINIT.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_MPPINIT.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_MPPINIT.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_NEST_UTIL.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_NEST_UTIL.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_NEST_UTIL.F	(revision 17)
@@ -0,0 +1,705 @@
+!
+!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_BXS,PD_BXE,PD_BYS,PD_BYE                                 &
+                             ,T_BXS,T_BXE,T_BYS,T_BYE,Q_BXS,Q_BXE,Q_BYS,Q_BYE             &
+                             ,U_BXS,U_BXE,U_BYS,U_BYE,V_BXS,V_BXE,V_BYS,V_BYE             &
+                             ,Q2_BXS,Q2_BXE,Q2_BYS,Q2_BYE                                 &
+                             ,CWM_BXS,CWM_BXE,CWM_BYS,CWM_BYE                             &
+                             ,PD_BTXS,PD_BTXE,PD_BTYS,PD_BTYE                             &
+                             ,T_BTXS,T_BTXE,T_BTYS,T_BTYE,Q_BTXS,Q_BTXE,Q_BTYS,Q_BTYE     &
+                             ,U_BTXS,U_BTXE,U_BTYS,U_BTYE,V_BTXS,V_BTXE,V_BTYS,V_BTYE     &
+                             ,Q2_BTXS,Q2_BTXE,Q2_BTYS,Q2_BTYE                             &
+                             ,CWM_BTXS,CWM_BTXE,CWM_BTYS,CWM_BTYE                         &
+!
+                             ,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 &
+!
+                             ,SPEC_BDY_WIDTH                                              &  
+                             ,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 HALO 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) :: SPEC_BDY_WIDTH
+!
+!
+      REAL,DIMENSION(IMS:IME,1,SPEC_BDY_WIDTH)                     &
+                                           ,INTENT(INOUT) :: PD_BYS,PD_BYE &
+                                                          ,PD_BTYS,PD_BTYE
+
+      REAL,DIMENSION(IMS:IME,KMS:KME,SPEC_BDY_WIDTH)                &
+                                      ,INTENT(INOUT) :: CWM_BYS,CWM_BYE &
+                                                       ,Q_BYS,Q_BYE     &
+                                                       ,Q2_BYS,Q2_BYE   &
+                                                       ,T_BYS,T_BYE     &
+                                                       ,U_BYS,U_BYE     &
+                                                       ,V_BYS,V_BYE     
+
+      REAL,DIMENSION(IMS:IME,KMS:KME,SPEC_BDY_WIDTH)                &
+                                      ,INTENT(INOUT) :: CWM_BTYS,CWM_BTYE &
+                                                       ,Q_BTYS,Q_BTYE     &
+                                                       ,Q2_BTYS,Q2_BTYE   &
+                                                       ,T_BTYS,T_BTYE     &
+                                                       ,U_BTYS,U_BTYE     &
+                                                       ,V_BTYS,V_BTYE     
+
+!
+
+      REAL,DIMENSION(JMS:JME,1,SPEC_BDY_WIDTH)                     &
+                                           ,INTENT(INOUT) :: PD_BXS,PD_BXE &
+                                                          ,PD_BTXS,PD_BTXE
+
+      REAL,DIMENSION(JMS:JME,KMS:KME,SPEC_BDY_WIDTH)                &
+                                      ,INTENT(INOUT) :: CWM_BXS,CWM_BXE &
+                                                       ,Q_BXS,Q_BXE     &
+                                                       ,Q2_BXS,Q2_BXE   &
+                                                       ,T_BXS,T_BXE     &
+                                                       ,U_BXS,U_BXE     &
+                                                       ,V_BXS,V_BXE     
+
+      REAL,DIMENSION(JMS:JME,KMS:KME,SPEC_BDY_WIDTH)                &
+                                      ,INTENT(INOUT) :: CWM_BTXS,CWM_BTXE &
+                                                       ,Q_BTXS,Q_BTXE     &
+                                                       ,Q2_BTXS,Q2_BTXE   &
+                                                       ,T_BTXS,T_BTXE     &
+                                                       ,U_BTXS,U_BTXE     &
+                                                       ,V_BTXS,V_BTXE     
+
+!
+
+      REAL,DIMENSION(IMS:IME,JMS:JME)                     &
+                                      ,INTENT(IN) :: PDTMP_B,PDTMP_BT
+
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME)                     &
+                                      ,INTENT(IN) :: CWMTMP_B,CWMTMP_BT  &
+                                                    ,QTMP_B,QTMP_BT     &
+                                                    ,Q2TMP_B,Q2TMP_BT   &
+                                                    ,TTMP_B,TTMP_BT     &
+                                                    ,UTMP_B,UTMP_BT     &
+                                                    ,VTMP_B,VTMP_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)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
+
+          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_BXS(J,1,IB)  =PDTMP_B(II,J)
+                PD_BTXS(J,1,IB) =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_BXS(J,K,IB)    = TTMP_B(II,J,K)
+                T_BTXS(J,K,IB)   = TTMP_BT(II,J,K)
+                Q_BXS(J,K,IB)    = QTMP_B(II,J,K)
+                Q_BTXS(J,K,IB)   = QTMP_BT(II,J,K)
+                Q2_BXS(J,K,IB)   = Q2TMP_B(II,J,K)
+                Q2_BTXS(J,K,IB)  = Q2TMP_BT(II,J,K)
+                CWM_BXS(J,K,IB)  = CWMTMP_B(II,J,K)
+                CWM_BTXS(J,K,IB) = CWMTMP_BT(II,J,K)
+              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_BXS(J,K,IB)    = UTMP_B(II,J,K)
+                U_BTXS(J,K,IB)   = UTMP_BT(II,J,K)
+                V_BXS(J,K,IB)    = VTMP_B(II,J,K)
+                V_BTXS(J,K,IB)   = VTMP_BT(II,J,K)
+              ENDIF
+            ENDDO
+          ENDDO
+
+        ELSEIF (E_BDY.AND.IBDY.EQ.2) THEN
+
+!            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
+
+          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_BXE(J,1,IB)  =PDTMP_B(II,J)
+                PD_BTXE(J,1,IB) =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_BXE(J,K,IB)    = TTMP_B(II,J,K)
+                T_BTXE(J,K,IB)   = TTMP_BT(II,J,K)
+                Q_BXE(J,K,IB)    = QTMP_B(II,J,K)
+                Q_BTXE(J,K,IB)   = QTMP_BT(II,J,K)
+                Q2_BXE(J,K,IB)   = Q2TMP_B(II,J,K)
+                Q2_BTXE(J,K,IB)  = Q2TMP_BT(II,J,K)
+                CWM_BXE(J,K,IB)  = CWMTMP_B(II,J,K)
+                CWM_BTXE(J,K,IB) = CWMTMP_BT(II,J,K)
+              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_BXE(J,K,IB)    = UTMP_B(II,J,K)
+                U_BTXE(J,K,IB)   = UTMP_BT(II,J,K)
+                V_BXE(J,K,IB)    = VTMP_B(II,J,K)
+                V_BTXE(J,K,IB)   = VTMP_BT(II,J,K)
+              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) 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
+!
+          DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+            PD_BYS(I,1,JB) = PDTMP_B(I,JJ)
+            PD_BTYS(I,1,JB)= PDTMP_BT(I,JJ)
+          ENDDO
+
+!
+          DO K=KTS,KTE
+            DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              T_BYS(I,K,JB)   = TTMP_B(I,JJ,K)
+              T_BTYS(I,K,JB)  = TTMP_BT(I,JJ,K)
+              Q_BYS(I,K,JB)   = QTMP_B(I,JJ,K)
+              Q_BTYS(I,K,JB)  = QTMP_BT(I,JJ,K)
+              Q2_BYS(I,K,JB)  = Q2TMP_B(I,JJ,K)
+              Q2_BTYS(I,K,JB) = Q2TMP_BT(I,JJ,K)
+              CWM_BYS(I,K,JB) = CWMTMP_B(I,JJ,K)
+              CWM_BTYS(I,K,JB)= CWMTMP_BT(I,JJ,K)
+            ENDDO
+          ENDDO
+
+          DO K=KTS,KTE
+           DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              U_BYS(I,K,JB)   = UTMP_B(I,JJ,K)
+              U_BTYS(I,K,JB)  = UTMP_BT(I,JJ,K)
+              V_BYS(I,K,JB)   = VTMP_B(I,JJ,K)
+              V_BTYS(I,K,JB)  = VTMP_BT(I,JJ,K)
+           ENDDO
+          ENDDO
+
+          ELSEIF (N_BDY.AND.IBDY.EQ.2) THEN
+!            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
+
+          DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+            PD_BYE(I,1,JB) = PDTMP_B(I,JJ)
+            PD_BTYE(I,1,JB)= PDTMP_BT(I,JJ)
+          ENDDO
+
+!
+          DO K=KTS,KTE
+            DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              T_BYE(I,K,JB)   = TTMP_B(I,JJ,K)
+              T_BTYE(I,K,JB)  = TTMP_BT(I,JJ,K)
+              Q_BYE(I,K,JB)   = QTMP_B(I,JJ,K)
+              Q_BTYE(I,K,JB)  = QTMP_BT(I,JJ,K)
+              Q2_BYE(I,K,JB)  = Q2TMP_B(I,JJ,K)
+              Q2_BTYE(I,K,JB) = Q2TMP_BT(I,JJ,K)
+              CWM_BYE(I,K,JB) = CWMTMP_B(I,JJ,K)
+              CWM_BTYE(I,K,JB)= CWMTMP_BT(I,JJ,K)
+            ENDDO
+          ENDDO
+
+          DO K=KTS,KTE
+           DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
+              U_BYE(I,K,JB)   = UTMP_B(I,JJ,K)
+              U_BTYE(I,K,JB)  = UTMP_BT(I,JJ,K)
+              V_BYE(I,K,JB)   = VTMP_B(I,JJ,K)
+              V_BTYE(I,K,JB)  = VTMP_BT(I,JJ,K)
+           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                           &
+#ifdef HWRF
+                          ,RESTART,NTIME0                        & ! zhang's doing
+                          ,MOVED,MVNEST,NTSD,NPHS,CFREQ          & ! CFREQ*DT*NPHS=540s
+#else
+                          ,MOVED,MVNEST,NTSD,NPHS                &
+#endif
+                          ,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   &
+#ifdef HWRF
+                                                              ,NTSD,NPHS,CFREQ
+#else
+                                                              ,NTSD,NPHS
+#endif
+!
+      INTEGER, INTENT(OUT)                                  :: XLOC,YLOC
+#ifdef HWRFX
+      INTEGER                                               :: NXLOC,NYLOC
+      REAL                                                  :: NSUM1,NSUM2,NSUM3
+#endif
+      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,JMS:JME,KMS:KME), INTENT(IN)  :: PINT,T,Q,U,V
+      REAL, DIMENSION(IMS:IME,JMS:JME),         INTENT(OUT) :: PDYN,MSLP,SQWS
+!
+!     LOCAL
+
+#ifdef HWRF
+!zhang's doing
+#ifdef HWRFX
+      INTEGER,INTENT(INOUT)                                 :: NTIME0
+#else
+      INTEGER                                               :: NTIME0
+#endif
+      LOGICAL,INTENT(IN)                                    :: RESTART
+#else
+      INTEGER,SAVE                                          :: NTIME0
+#endif
+      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,JMS:JME,KMS:KME)              :: Z
+
+!    EXEC 
+
+     ITF=MIN(ITE,IDE-1)
+     JTF=MIN(JTE,JDE-1)
+
+!----------------------------------------------------------------------------------
+
+!     KEEP NEST MOTION IN SINK WITH PHYSICS TIME STEPS
+#ifdef HWRF
+      IF(MOD(NTSD+1,CFREQ*NPHS)/=0)THEN   !FOR FULL COUPLING
+        IF(MOVED) NTIME0=NTSD             !FOR UPDATING NTIM0
+#else
+      IF(MOD(NTSD+1,NPHS)/=0)THEN
+#endif
+        MVNEST=.FALSE.
+        RETURN
+      ENDIF
+
+!     DETERMINE THE HEIGHTS ON THE PARENT DOMAIN
+
+      DO J = JTS, MIN(JTE,JDE)
+       DO I = ITS, MIN(ITE,IDE)
+         Z(I,J,1)=FIS(I,J)*GI
+       ENDDO
+      ENDDO
+!
+      DO K = KTS,KTE
+       DO J = JTS, MIN(JTE,JDE)
+        DO I = ITS, MIN(ITE,IDE)
+          APELP      = (PINT(I,J,K+1)+PINT(I,J,K))
+          RTOPP      = TRG*T(I,J,K)*(1.0+Q(I,J,K)*P608)/APELP
+          DZ         = RTOPP*(DETA1(K)*PDTOP+DETA2(K)*PD(I,J))
+          Z(I,J,K+1) = Z(I,J,K) + 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,J,1)*(1.+D608*Q(I,J,1)) + LAPSR*(Z(I,J,1)+Z(I,J,2))*0.5
+            A         = LAPSR*Z(I,J,1)/TSFC
+            MSLP(I,J) = PINT(I,J,1)*(1-A)**COEF2
+            SQWS(I,J) =  (U(I,J,9)*U(I,J,9) + V(I,J,9)*V(I,J,9)           &
+                      +   U(I,J,10)*U(I,J,10) + V(I,J,10)*V(I,J,10)       &
+                      +   U(I,J,11)*U(I,J,11) + V(I,J,11)*V(I,J,11))/3.0
+#ifdef HWRF
+            PDYN(I,J) =   MSLP(I,J)  
+#else
+            PDYN(I,J) =   MSLP(I,J)  + 1.1*SQWS(I,J)/2.0
+#endif
+        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.0
+          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 
+
+      STMP0=MAXGBL_PDYN*100.                 ! define arbitrary maximum
+      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)
+#ifdef HWRFX
+!     USE CENTROID TO FIND THE CENTER    Xuejin's doing
+
+      NSUM1=0.0
+      NSUM2=0.0
+      NSUM3=0.0
+      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 )THEN
+!       IF(I .EQ. IM .AND. J .EQ. JM)THEN
+          NSUM1 = NSUM1 + I*(105000.1 - PDYN(I,J))
+          NSUM2 = NSUM2 + J*(105000.1 - PDYN(I,J))
+          NSUM3 = NSUM3 + (105000.1 - PDYN(I,J))
+!         NSUM1 = NSUM1 + I*(PCUT+0.1 - PDYN(I,J))
+!         NSUM2 = NSUM2 + J*(PCUT+0.1 - PDYN(I,J))
+!         NSUM3 = NSUM3 + (PCUT+0.1 - PDYN(I,J))
+!         WRITE(0,*)'TEST',NSUM1,I,J,0.01*(105000.0 - PDYN(I,J)),PDYN(I,J) 
+        ENDIF
+       ENDDO
+      ENDDO
+      NSUM1 = WRF_DM_SUM_REAL(NSUM1)
+      NSUM2 = WRF_DM_SUM_REAL(NSUM2)
+      NSUM3 = WRF_DM_SUM_REAL(NSUM3)
+      NXLOC = NINT(NSUM1/NSUM3)
+      NYLOC = NINT(NSUM2/NSUM3)
+
+      WRITE(0,*)'NEW CALC',NSUM1,NSUM2,NSUM3
+      WRITE(0,*)'XLOC,YLOC',NXLOC,XLOC,NYLOC,YLOC
+
+      XLOC = NXLOC
+      YLOC = NYLOC
+
+#endif
+
+!     DETERMINE THE MAXIMUM MSLP AT ABOUT 18 GRID POINTS AWAY FROM THE STORM CENTER 
+
+      STMP1=0.0
+      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)
+#ifdef HWRF
+!zhang's doing
+      IF((.NOT.RESTART .AND. NTSD==0) .OR. MOVED)NTIME0=NTSD
+#else
+      IF(NTSD==0 .OR. MOVED)NTIME0=NTSD
+#endif
+      DTMOVE=NTSD-NTIME0                    ! TIME INTERVAL SINCE THE PREVIOUS MOVE
+!
+#ifdef HWRFX
+       IF(XDIFF .GE. 1 .OR. YDIFF .GE. 2) THEN
+        MVNEST=.TRUE.
+        NTIME0=NTSD
+       ELSE
+        MVNEST=.FALSE.
+        WRITE(0,*)'SUSPEND MOTION: DTMOVE=',DTMOVE,'LESS THAN 3 MINUTS'
+        WRITE(0,*)'SUSPEND MOTION: NTIME0=',NTIME0
+       ENDIF
+#else
+      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
+#endif
+
+      RETURN
+
+END SUBROUTINE STATS_FOR_MOVE
+!----------------------------------------------------------------------------------
+SUBROUTINE MSLP_DIAG (MSLP,PINT,T,Q               &
+                     ,FIS,PD,DETA1,DETA2,PDTOP    &
+                     ,IDS,IDE,JDS,JDE,KDS,KDE     &
+                     ,IMS,IME,JMS,JME,KMS,KME     &
+                     ,ITS,ITE,JTS,JTE,KTS,KTE     )
+
+
+!**********************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:  MSLP_DIAG 
+!   PRGRMMR: gopal
+!
+! ABSTRACT:
+!         THIS ROUTINE COMPUTES MSLP OVER THE PARENT DOMAIN FOR DIAGONOSTIC PURPOSE 
+! PROGRAM HISTORY LOG:
+!   07-21-2005  : gopal
+!
+! USAGE: CALL MSLP_DIAG FROM THE SOLVER 
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM SP/Linux cluster
+!$$$
+
+      USE MODULE_MODEL_CONSTANTS
+      USE MODULE_DM
+
+      IMPLICIT NONE
+
+!     global variables
+
+      INTEGER,INTENT(IN)                                      :: IDS,IDE,JDS,JDE,KDS,KDE   &
+                                                                ,IMS,IME,JMS,JME,KMS,KME   & 
+                                                                ,ITS,ITE,JTS,JTE,KTS,KTE   
+
+      REAL,                                     INTENT(IN)    :: PDTOP
+      REAL, DIMENSION(KMS:KME),                 INTENT(IN)    :: DETA1,DETA2
+      REAL, DIMENSION(IMS:IME,JMS:JME),         INTENT(INOUT) :: MSLP
+      REAL, DIMENSION(IMS:IME,JMS:JME),         INTENT(IN)    :: FIS,PD
+      REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), INTENT(IN)    :: PINT,T,Q
+
+!     local variables
+
+      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                                                  :: RTOPP,APELP,DZ,SFCT,A
+      REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME)              :: Z
+      INTEGER                                               :: I,J,K
+!-----------------------------------------------------------------------------------------------------
+
+
+     DO J = JTS, MIN(JTE,JDE)
+      DO I = ITS, MIN(ITE,IDE)
+         Z(I,J,1)=FIS(I,J)*GI
+      ENDDO
+     ENDDO
+
+     DO K = KTS,KTE
+      DO J = JTS, MIN(JTE,JDE)
+       DO I = ITS, MIN(ITE,IDE)
+         APELP      = (PINT(I,J,K+1)+PINT(I,J,K))
+         RTOPP      = TRG*T(I,J,K)*(1.0+Q(I,J,K)*P608)/APELP
+         DZ         = RTOPP*(DETA1(K)*PDTOP+DETA2(K)*PD(I,J))
+         Z(I,J,K+1) = Z(I,J,K) + DZ
+       ENDDO
+      ENDDO
+     ENDDO
+
+     MSLP=-9999.99
+     DO J = JTS, MIN(JTE,JDE)
+       DO I = ITS, MIN(ITE,IDE)
+         SFCT      = T(I,J,1)*(1.+D608*Q(I,J,1)) + LAPSR*(Z(I,J,1)+Z(I,J,2))*0.5
+         A         = LAPSR*Z(I,J,1)/SFCT
+         MSLP(I,J) = PINT(I,J,1)*(1-A)**COEF2
+       ENDDO
+     ENDDO
+
+
+END SUBROUTINE MSLP_DIAG
+!------------------------------------------------------------------------------------------------------
+
+END  MODULE module_NEST_UTIL
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_NONHY_DYNAM.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_NONHY_DYNAM.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_NONHY_DYNAM.F	(revision 17)
@@ -0,0 +1,1095 @@
+!----------------------------------------------------------------------
+!
+!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                               &
+                    ,HBM2,HBM3                                          &
+                    ,PDSL,PDSLO,PINT,RTOP,PETDT,PDWDT                   &
+                    ,DWDT,DWDTMN,DWDTMX                                 &
+                    ,FNS,FEW,FNE,FSE                                    &
+                    ,T,U,V,W,Q,CWM                                      &
+                    ,DEF3D,HDAC                                    &
+                    ,WP                                                 &    
+                    ,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:    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
+!   05-12-12  BLACK      - CONVERTED FROM IKJ TO IJK
+!
+! 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
+!-----------------------------------------------------------------------
+      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,INTENT(IN) :: NTSD
+!
+      REAL,INTENT(IN) :: DT,DY,PDTOP,PT,WP
+!
+      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          &
+                                                   ,HDAC
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PETDT,DEF3D
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: CWM         &
+                                                           ,FEW,FNE     &
+                                                           ,FNS,FSE     &
+                                                           ,Q,RTOP      &
+                                                           ,U,V
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: DWDT     &
+                                                              ,PDWDT    &
+                                                              ,T
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: PINT,W
+!
+      LOGICAL,INTENT(IN) :: HYDRO
+!
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+!-----------------------------------------------------------------------
+!
+      INTEGER,PARAMETER :: NTSHY=2
+!
+      REAL,PARAMETER :: WGHT=0.35
+!
+      INTEGER,DIMENSION(KTS:KTE) :: LA
+!
+      INTEGER :: I,J,K,LMP
+!
+      REAL,DIMENSION(KTS:KTE) :: B1,B2,B3,C0,CWM_K,DWDT_K,Q_K,RDPP      &
+                                ,RTOP_K,T_K
+!
+      REAL,DIMENSION(ITS:ITE) :: DPTU_I,PNP1_I,PSTRUP_I
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: TTB,WEW,WNE,WNS,WSE
+!
+      REAL,DIMENSION(ITS:ITE,KTS:KTE) :: B1_IK,B2_IK,B3_IK,C0_IK        &
+                                        ,CWM_IK,DWDT_IK,Q_IK            &
+                                        ,RDPP_IK,RTOP_IK,T_IK
+!
+      REAL,DIMENSION(ITS:ITE,KTS:KTE+1) :: CHI_IK,COFF_IK               &
+                                          ,PINT_IK,PSTR_IK,W_IK
+!
+      REAL :: ADDT,DELP,DETAL,DP,DPDE,DPPL,DPSTR,DPTL,DPTU              &
+             ,DWDTT,EPSN,FCT,FFC,GDT,GDT2                               &
+             ,PNP,PP1,PSTRDN,PSTRUP,RDP,RDPDN,RDPUP,RDT                 &
+             ,TFC,TMP,TTAL,TTFC,HKNE_IJ,HKSE_IJ,ADVEC
+!
+      LOGICAL :: BOT,TOP,DIFFW
+!
+      CHARACTER(LEN=255) :: message
+
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      IF(NTSD<=NTSHY.OR.HYDRO)THEN
+!***
+        DO J=MYJS_P2,MYJE_P2
+        DO I=MYIS_P1,MYIE_P1
+          PINT(I,J,KTE+1)=PT
+        ENDDO
+        ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO K=KTS,KTE
+          DO J=MYJS_P2,MYJE_P2
+          DO I=MYIS_P1,MYIE_P1
+            DWDT(I,J,K)=1.
+            PDWDT(I,J,K)=1.
+          ENDDO
+          ENDDO
+        ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO K=KTE,KTS,-1
+          DO J=MYJS_P2,MYJE_P2
+          DO I=MYIS_P1,MYIE_P1
+            PINT(I,J,K)=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)+PINT(I,J,K+1)
+          ENDDO
+          ENDDO
+        ENDDO
+!***
+        RETURN
+!***
+      ENDIF
+!-----------------------------------------------------------------------
+      ADDT=DT
+      RDT=1./ADDT
+!-----------------------------------------------------------------------
+!
+!***  TIME TENDENCY
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO K=KTS,KTE
+        DO J=MYJS_P1,MYJE_P1
+        DO I=MYIS_P1,MYIE_P1
+          DWDT(I,J,K)=(W(I,J,K)-DWDT(I,J,K))*HBM2(I,J)*RDT
+        ENDDO
+        ENDDO
+      ENDDO
+
+
+      IF (DT > 0 .and. WP .ge. 0.001) THEN
+         DIFFW=.TRUE.
+      ELSE
+         DIFFW=.FALSE.
+      ENDIF
+
+      IF(DIFFW) THEN
+
+        DO K=KTS,KTE
+         DO J=MYJS_P1,MYJE1_P1
+          DO I=MYIS_P1,MYIE1_P1
+            HKNE_IJ=(DEF3D(I,J,K)+DEF3D(I+IHE(J),J+1,K))
+            HKSE_IJ=(DEF3D(I+IHE(J),J-1,K)+DEF3D(I,J,K))
+            WNE(I,J)=(W (I+IHE(J),J+1,K)-W (I,J,K))*HKNE_IJ
+            WSE(I,J)=(W (I+IHE(J),J-1,K)-W (I,J,K))*HKSE_IJ
+          ENDDO 
+         ENDDO 
+
+         DO J=MYJS2,MYJE2
+          DO I=MYIS,MYIE
+              DWDT(I,J,K)= DWDT(I,J,K) - ( WNE (I,J)-WNE (I+IHW(J),J-1) +  &
+                                           WSE (I,J)-WSE (I+IHW(J),J+1) ) * &
+                                           HDAC(I,J)*HBM2(I,J)*RDT 
+          ENDDO 
+         ENDDO 
+        ENDDO
+
+       ENDIF
+!
+!-----------------------------------------------------------------------
+!***
+!***  VERTICAL ADVECTION
+!***
+!-----------------------------------------------------------------------
+!
+      DO J=MYJS2,MYJE2
+      DO I=MYIS,MYIE
+        TTB(I,J)=0.
+      ENDDO
+      ENDDO
+!
+      DO K=KTE,KTS+1,-1
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,ttal)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS,MYIE
+        TTAL=(W(I,J,K-1)-W(I,J,K))*PETDT(I,J,K-1)*0.5
+        DWDT(I,J,K)=(TTAL+TTB(I,J))                                     &
+                   /(DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J))                &
+                    +DWDT(I,J,K)
+        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,J,KTS)-W(I,J,KTS+1))*PETDT(I,J,KTS)*0.5
+        DWDT(I,J,KTS)=TTB(I,J)/(DETA1(KTS)*PDTOP+DETA2(KTS)*PDSLO(I,J)) &
+                     +DWDT(I,J,KTS)
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!***
+!***  END OF VERTICAL ADVECTION
+!***
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***
+!***  HORIZONTAL ADVECTION
+!***
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(dpde,i,j,k)
+!
+      main_horizontal:  DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!***  THE WORKING ARRAYS FOR THE PRIMARY VARIABLES
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS1_P3,MYJE1_P3
+        DO I=MYIS_P3,MYIE_P3
+          WEW(I,J)=FEW(I,J,K)*(W(I+IVE(J),J,K)-W(I+IVW(J),J,K))
+          WNS(I,J)=FNS(I,J,K)*(W(I,J+1,K)-W(I,J-1,K))
+        ENDDO
+        ENDDO
+!
+!***    DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND
+!
+        DO J=MYJS1_P2,MYJE2_P2
+        DO I=MYIS_P2,MYIE1_P2
+          WNE(I,J)=FNE(I,J,K)*(W(I+IHE(J),J+1,K)-W(I,J,K))
+        ENDDO
+        ENDDO
+!
+        DO J=MYJS2_P2,MYJE1_P2
+        DO I=MYIS_P2,MYIE1_P2
+          WSE(I,J)=FSE(I,J,K)*(W(I+IHE(J),J-1,K)-W(I,J,K))
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***    ADVECTION OF W
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS3,MYJE3
+        DO I=MYIS2,MYIE2
+          DPDE=DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J)
+          ADVEC=-(WEW(I+IHW(J),J)      +WEW(I+IHE(J),J)           &
+                       +WNS(I,J-1)           +WNS(I,J+1)                &
+                       +WNE(I+IHW(J),J-1)    +WNE(I,J)                  &
+                       +WSE(I,J)             +WSE(I+IHW(J),J+1))        &
+                       *FAD(I,J)*2.0*HBM3(I,J)/(DPDE*DT)
+          DWDT(I,J,K)= ADVEC + DWDT(I,J,K)
+        ENDDO
+        ENDDO
+
+      ENDDO main_horizontal
+
+!-----------------------------------------------------------------------
+!***
+!***  END OF HORIZONTAL ADVECTION
+!***
+!-----------------------------------------------------------------------
+
+      IF (WP .ge. 0.001) then
+!-----------------------------------------------------------------------
+!---taking external mode out--------------------------------------------
+!-----------------------------------------------------------------------
+
+       DO J=MYJS2_P1,MYJE2_P1
+        DO I=MYIS1_P1,MYIE1_P1
+          TTB(I,J)=0.
+        ENDDO
+       ENDDO
+!
+      DO K=KTS,KTE
+       DO J=MYJS2_P1,MYJE2_P1
+        DO I=MYIS1_P1,MYIE1_P1
+            DPDE=DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J)
+            TTB(I,J)=DPDE*DWDT(I,J,K)+TTB(I,J)
+        ENDDO
+       ENDDO
+      ENDDO
+!
+       DO J=MYJS2_P1,MYJE2_P1
+        DO I=MYIS1_P1,MYIE1_P1
+          TTB(I,J)=TTB(I,J)/(PDSLO(I,J)+PDTOP)
+        ENDDO
+       ENDDO
+!
+      DO K=KTS,KTE
+       DO J=MYJS2_P1,MYJE2_P1
+        DO I=MYIS1_P1,MYIE1_P1
+            DWDT(I,J,K)=DWDT(I,J,K)-TTB(I,J)
+        ENDDO
+       ENDDO
+      ENDDO
+     endif
+
+!$omp parallel do                                                       &
+!$omp& private(dwdtt,i,j,k)
+      DO K=KTS,KTE
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+        DWDTT=DWDT(I,J,K)
+        DWDTT=MAX(DWDTT,DWDTMN(I,J))
+        DWDTT=MIN(DWDTT,DWDTMX(I,J))
+!
+        DWDT(I,J,K)=(DWDTT*RG+1.)*(1.-WP)+PDWDT(I,J,K)*WP
+      ENDDO
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!---setting dwdt (epsilon at this point) on h points to 1. along bdy ---
+!-----------------------------------------------------------------------
+      IF (WP .ge. 0.001) THEN
+
+        do K=KTS,KTE
+          if (JDS .eq. JTS) then
+            do J=jts,jts+1
+              do I=its,ite
+                DWDT(I,J,K)=1.
+              enddo
+            enddo
+          endif
+!
+          if (JTE .ge. JDE-2) then
+            do j=jte-1,jte
+              do i=its,ite
+                DWDT(I,J,K)=1.
+              enddo
+            enddo
+          endif
+!
+          if(ITS .eq. IDS)then
+            do j=jts,jte
+              do i=its,its+1
+                DWDT(I,J,K)=1.
+              enddo
+            enddo
+          endif
+!
+          if(ITE .ge. IDE-2)then
+            do j=jts,jte
+              do i=ite-1,ite
+                DWDT(I,J,K)=1.
+              enddo
+            enddo
+          endif
+        enddo
+
+        ENDIF
+ 
+      GDT=G*DT
+      GDT2=GDT*GDT
+      FFC=-R_D/GDT2
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(b1_ik,b2_ik,b3_ik,c0_ik,chi_ik,coff_ik,cwm_ik,           &
+!$omp&        delp,dppl,dpstr,dptl,dptu_i,dwdt_ik,fct,i,j,k,            &
+!$omp&        pint_ik,pnp1_i,pp1,pstr_ik,pstrdn,pstrup_i,q_ik,          &
+!$omp&        rdpdn,rdpup,rtop_ik,t_ik,tfc,tmp,ttfc,w_ik)
+!
+      final_update:  DO J=MYJS3,MYJE3
+!
+!-----------------------------------------------------------------------
+!***  EXTRACT COLUMNS FROM 3-D ARRAYS
+!-----------------------------------------------------------------------
+!
+        DO K=KTS,KTE
+        DO I=MYIS2,MYIE2
+          CWM_IK(I,K)=CWM(I,J,K)
+          DWDT_IK(I,K)=DWDT(I,J,K)
+          Q_IK(I,K)=Q(I,J,K)
+          RTOP_IK(I,K)=RTOP(I,J,K)
+          T_IK(I,K)=T(I,J,K)
+        ENDDO
+        ENDDO
+!
+        DO K=KTS,KTE+1
+        DO I=MYIS2,MYIE2
+          PINT_IK(I,K)=PINT(I,J,K)
+          W_IK(I,K)=W(I,J,K)
+        ENDDO
+        ENDDO
+!
+        DO I=MYIS2,MYIE2
+          PSTR_IK(I,KTE+1)=PT
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+        DO K=KTE,KTS,-1
+!
+          IF(K==KTE)THEN
+            DO I=MYIS2,MYIE2
+              DPPL=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+              RDPP_IK(I,K)=1./DPPL
+              DPSTR=DWDT_IK(I,K)*DPPL
+              PSTR_IK(I,K)=PT+DPSTR
+              PP1=PT+DPSTR
+              PNP1_I(I)=(PP1-PINT_IK(I,K))*WGHT+PINT_IK(I,K)
+              TFC=Q_IK(I,K)*P608+(1.-CWM_IK(I,K))
+              TTFC=-CAPA*TFC+1.
+              COFF_IK(I,K)=T_IK(I,K)*TTFC*TFC*DPPL*FFC                  &
+                          /((PT+PNP1_I(I))*(PT+PNP1_I(I)))
+            ENDDO
+          ELSE
+            DO I=MYIS2,MYIE2
+              DPPL=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+              RDPP_ik(I,K)=1./DPPL
+              DPSTR=DWDT_IK(I,K)*DPPL
+              PSTR_IK(I,K)=PSTR_IK(I,K+1)+DPSTR
+              PP1=PNP1_I(I)+DPSTR
+              PNP=(PP1-PINT_IK(I,K))*WGHT+PINT_IK(I,K)
+              TFC=Q_IK(I,K)*P608+(1.-CWM_IK(I,K))
+              TTFC=-CAPA*TFC+1.
+              COFF_IK(I,K)=T_IK(I,K)*TTFC*TFC*DPPL*FFC                  &
+                          /((PNP1_I(I)+PNP)*(PNP+PNP1_I(I)))
+              PNP1_I(I)=PNP
+            ENDDO 
+          ENDIF
+!
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+        DO I=MYIS2,MYIE2
+!!BUG!!   PSTRUP_I(I)=-(PSTR_IK(I,KTE)-PINT_IK(I,KTE))*COFF_IK(I,KTE)
+          PSTRUP_I(I)=-(PSTR_IK(I,KTE+1)+PSTR_IK(I,KTE)                 &
+                       -PINT_IK(I,KTE+1)-PINT_IK(I,KTE))*COFF_IK(I,KTE)
+        ENDDO
+!
+!-----------------------------------------------------------------------
+        DO K=KTE-1,KTS,-1
+!
+          IF(K==KTE-1)THEN
+            DO I=MYIS2,MYIE2
+              RDPDN=RDPP_IK(I,K)
+              RDPUP=RDPP_IK(I,K+1)
+!
+              PSTRDN=-(PSTR_IK(I,K+1)+PSTR_IK(I,K)                      &
+                      -PINT_IK(I,K+1)-PINT_IK(I,K))                     &
+                      *COFF_IK(I,K)
+!
+              B1_IK(I,K)=COFF_IK(I,K+1)+RDPUP
+              B2_IK(I,K)=(COFF_IK(I,K+1)+COFF_IK(I,K))-(RDPUP+RDPDN)
+              B3_IK(I,K)=COFF_IK(I,K)+RDPDN
+              C0_IK(I,K)=PSTRUP_I(I)+PSTRDN
+              PSTRUP_I(I)=PSTRDN
+            ENDDO
+          ELSE
+            DO I=MYIS2,MYIE2
+              RDPDN=RDPP_IK(I,K)
+              RDPUP=RDPP_IK(I,K+1)
+!
+              PSTRDN=-(PSTR_IK(I,K+1)+PSTR_IK(I,K)                      &
+                      -PINT_IK(I,K+1)-PINT_IK(I,K))                     &
+                      *COFF_IK(I,K)
+!
+              B1_IK(I,K)=COFF_IK(I,K+1)+RDPUP
+              B2_IK(I,K)=(COFF_IK(I,K+1)+COFF_IK(I,K))-(RDPUP+RDPDN)
+              B3_IK(I,K)=COFF_IK(I,K)+RDPDN
+              C0_IK(I,K)=PSTRUP_I(I)+PSTRDN
+              PSTRUP_I(I)=PSTRDN
+            ENDDO
+          ENDIF
+!
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  ELIMINATION
+!-----------------------------------------------------------------------
+!
+        DO K=KTE-2,KTS,-1
+!
+          IF(K>KTS)THEN
+            DO I=MYIS2,MYIE2
+              TMP=-B1_IK(I,K)/B2_IK(I,K+1)
+              B2_IK(I,K)=B3_IK(I,K+1)*TMP+B2_IK(I,K)
+              C0_IK(I,K)=C0_IK(I,K+1)*TMP+C0_IK(I,K)
+            ENDDO
+          ELSE
+            DO I=MYIS2,MYIE2
+              TMP=-B1_IK(I,K)/B2_IK(I,K+1)
+              B2_IK(I,K)=B3_IK(I,K+1)*TMP                               &
+                       +(B2_IK(I,KTS)+B3_IK(I,KTS))
+              C0_IK(I,K)=C0_IK(I,K+1)*TMP+C0_IK(I,K)
+            ENDDO
+          ENDIF
+!
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  BACK SUBSTITUTION
+!-----------------------------------------------------------------------
+!
+        DO K=KTS+1,KTE
+!
+          IF(K==KTS+1)THEN
+            DO I=MYIS2,MYIE2
+              CHI_IK(I,K)=C0_IK(I,KTS)/B2_IK(I,KTS)
+              CHI_IK(I,KTS)=CHI_IK(I,K)
+            ENDDO
+          ELSE
+            DO I=MYIS2,MYIE2
+              CHI_IK(I,K)=(-B3_IK(I,K-1)*CHI_IK(I,K-1)+C0_IK(I,K-1))    &
+                          /B2_IK(I,K-1)
+            ENDDO
+          ENDIF
+!
+        ENDDO
+!-----------------------------------------------------------------------
+!
+        FCT=0.5/CP
+!
+        DO K=KTE,KTS,-1
+!
+          IF(K==KTE)THEN
+            DO I=MYIS2,MYIE2
+              DPTL=(CHI_IK(I,K)+PSTR_IK(I,K)-PINT_IK(I,K))*HBM3(I,J)
+              PINT_IK(I,K)=PINT_IK(I,K)+DPTL
+              T_IK(I,K)=DPTL*RTOP_IK(I,K)*FCT+T_IK(I,K)
+              DELP=(PINT_IK(I,K)-PINT_IK(I,K+1))*RDPP_IK(I,K)
+              W_IK(I,K)=((DELP-DWDT_IK(I,K))*GDT+W_IK(I,K))*HBM3(I,J)
+              DWDT_IK(I,K)=(DELP-1.)*HBM3(I,J)+1.
+              DPTU_I(I)=DPTL
+            ENDDO
+          ELSE
+            DO I=MYIS2,MYIE2
+              DPTL=(CHI_IK(I,K)+PSTR_IK(I,K)-PINT_IK(I,K))*HBM3(I,J)
+              PINT_IK(I,K)=PINT_IK(I,K)+DPTL
+              T_IK(I,K)=(DPTU_I(I)+DPTL)*RTOP_IK(I,K)*FCT+T_IK(I,K)
+              DELP=(PINT_IK(I,K)-PINT_IK(I,K+1))*RDPP_IK(I,K)
+              W_IK(I,K)=((DELP-DWDT_IK(I,K))*GDT+W_IK(I,K))*HBM3(I,J)
+              DWDT_IK(I,K)=(DELP-1.)*HBM3(I,J)+1.
+              DPTU_I(I)=DPTL
+            ENDDO
+          ENDIF
+!
+        ENDDO
+!
+!-----------------------------------------------------------------------
+        DO K=KTS,KTE
+        DO I=MYIS2,MYIE2
+          PINT(I,J,K)=PINT_IK(I,K)
+          T(I,J,K)=T_IK(I,K)
+          W(I,J,K)=W_IK(I,K)
+          DWDT(I,J,K)=DWDT_IK(I,K)
+
+#if !defined ( HWRF )
+	if (DWDT(I,J,K) .lt. 0.80 .or. DWDT(I,J,K) .gt. 1.2) then
+	write(message,*) 'very nonhydro...: ', I,J,K,DWDT(I,J,K)
+        call wrf_message(message)
+	endif
+
+#endif
+        ENDDO
+        ENDDO
+!-----------------------------------------------------------------------
+!
+      ENDDO final_update
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE EPS
+!
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE VADZ(NTSD,DT,FIS,SIGMA,DFL,HBM2                        &
+                     ,DETA1,DETA2,PDTOP                                 &
+                     ,PINT,PDSL,PDSLO,PETDT                             &
+                     ,RTOP,T,Q,CWM,Z,W,DWDT,PDWDT                       &
+                     ,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:    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
+!   05-12-12  BLACK      - CONVERTED FROM IKJ TO IJK
+!     
+! 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
+!
+!-----------------------------------------------------------------------
+!
+      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,JMS:JME,KMS:KME),INTENT(IN) :: PETDT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: CWM,Q       &
+                                                           ,RTOP,T
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(OUT) :: PDWDT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: DWDT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),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
+!
+      DO K=KTS,KTE
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+          PDWDT(I,J,K)=DWDT(I,J,K)
+          DWDT(I,J,K)=W(I,J,K)
+        ENDDO
+        ENDDO
+      ENDDO
+!
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+        W(I,J,KTS)=0.
+!
+#ifdef AS_RECEIVED
+        IF(SIGMA)THEN
+#else
+        IF(SIGMA==1)THEN
+#endif
+          Z(I,J,KTS)=FIS(I,J)*RG
+        ELSE
+          Z(I,J,KTS)=0.
+        ENDIF
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dz,i,j,k,zeta)
+!-----------------------------------------------------------------------
+!
+      kloop1 : DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+!
+          ZETA=DFL(K+1)*RG
+          DZ=(Q(I,J,K)*P608-CWM(I,J,K)+1.)*T(I,J,K)                     &
+            /(PINT(I,J,K+1)+PINT(I,J,K))                                &
+            *(DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J))*TRG
+          Z(I,J,K+1)=Z(I,J,K)+DZ
+          W(I,J,K+1)=(DZ-RTOP(I,J,K)                                    &
+                    *(DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J))*RG)           &
+                    *HBM2(I,J)                                          &
+                    +W(I,J,K)
+!
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO kloop1
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+!-----------------------------------------------------------------------
+      DO K=KTS,KTE
+!
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+          Z(I,J,K)=(Z(I,J,K+1)+Z(I,J,K))*0.5
+          W(I,J,K)=(W(I,J,K+1)+W(I,J,K))*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 K=KTE,KTS+1,-1
+        DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+          TTAL=(Z(I,J,K-1)-Z(I,J,K))*PETDT(I,J,K-1)*0.5
+          W(I,J,K)=(TTAL+TTB(I,J))/(DETA1(K)*PDTOP+DETA2(K)*PDSLO(I,J)) &
+                  +W(I,J,K)
+          TTB(I,J)=TTAL
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+!-----------------------------------------------------------------------
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1,MYIE1
+        W(I,J,KTS)=TTB(I,J)/(DETA1(KTS)*PDTOP+DETA2(KTS)*PDSLO(I,J))    &
+                  +W(I,J,KTS)
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+      END SUBROUTINE VADZ
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE HADZ(NTSD,DT,HYDRO,HBM2,DETA1,DETA2,PDTOP              &
+                     ,DX,DY,FAD                                         &
+                     ,FEW,FNS,FNE,FSE                                   &
+                     ,PDSL,U,V,W,Z,WP                                   &
+                     ,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:    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
+!   05-12-12  BLACK      - CONVERTED FROM IKJ TO IJK
+!
+! 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
+!
+!-----------------------------------------------------------------------
+!
+      REAL,INTENT(IN) :: DT,DY,PDTOP,WP
+!
+      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,JMS:JME,KMS:KME),INTENT(IN) :: U,V
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(OUT) :: FEW,FNE    &
+                                                            ,FNS,FSE
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: Z
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: W
+!-----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+!-----------------------------------------------------------------------
+      INTEGER,PARAMETER :: NTSHY=2
+!
+      INTEGER :: I,J,K
+!
+      REAL :: FEWP,FNEP,FNSP,FSEP,UDY,VDX
+!
+      REAL,DIMENSION(ITS-5:ITE+5,JTS-5:JTE+5) :: DPDE,UNED,USED         &
+     &                                          ,ZEW,ZNE,ZNS,ZSE,TTB
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      IF(NTSD+1<=NTSHY.OR.HYDRO)THEN
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO K=KTS,KTE
+          DO J=MYJS,MYJE
+          DO I=MYIS,MYIE
+            W(I,J,K)=0.
+          ENDDO
+          ENDDO
+        ENDDO
+!***
+        RETURN
+!***
+      ENDIF
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+!***  FIRST ZERO OUT SOME WORKING ARRAYS
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=JTS-5,JTE+5
+      DO I=ITS-5,ITE+5
+        DPDE(I,J)=0.
+        UNED(I,J)=0.
+        USED(I,J)=0.
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(dpde,fewp,fnep,fnsp,fsep,i,j,udy,uned,used,vdx           &
+!$omp&        ,zew,zne,zns,zse)
+!-----------------------------------------------------------------------
+!
+      main_integration:  DO K=KTS,KTE
+!
+!-----------------------------------------------------------------------
+!
+!***  MASS FLUXES AND MASS POINT ADVECTION COMPONENTS
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS_P3,MYJE_P3
+        DO I=MYIS_P4,MYIE_P4
+          DPDE(I,J)=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+        ENDDO
+        ENDDO
+!
+        DO J=MYJS1_P3,MYJE1_P3
+        DO I=MYIS_P3,MYIE_P3
+          UDY=U(I,J,K)*DY
+          VDX=V(I,J,K)*DX(I,J)
+!
+          FEWP=UDY*(DPDE(I+IVW(J),J)+DPDE(I+IVE(J),J))
+          FNSP=VDX*(DPDE(I,J-1)+DPDE(I,J+1))
+!
+          FEW(I,J,K)=FEWP
+          FNS(I,J,K)=FNSP
+!
+          ZEW(I,J)=FEWP*(Z(I+IVE(J),J,K)-Z(I+IVW(J),J,K))
+          ZNS(I,J)=FNSP*(Z(I,J+1,K)-Z(I,J-1,K))
+!
+          UNED(I,J)=UDY+VDX
+          USED(I,J)=UDY-VDX
+!
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+!***  DIAGONAL FLUXES AND DIAGONALLY AVERAGED WIND
+!
+!-----------------------------------------------------------------------
+        DO J=MYJS1_P2,MYJE2_P2
+        DO I=MYIS_P2,MYIE1_P2
+          FNEP=(UNED(I+IHE(J),J)+UNED(I,J+1))                           &
+     &        *(DPDE(I,J)+DPDE(I+IHE(J),J+1))
+          FNE(I,J,K)=FNEP
+          ZNE(I,J)=FNEP*(Z(I+IHE(J),J+1,K)-Z(I,J,K))
+        ENDDO
+        ENDDO
+!
+        DO J=MYJS2_P2,MYJE1_P2
+        DO I=MYIS_P2,MYIE1_P2
+          FSEP=(USED(I+IHE(J),J)+USED(I,J-1))                           &
+     &        *(DPDE(I,J)+DPDE(I+IHE(J),J-1))
+          FSE(I,J,K)=FSEP
+          ZSE(I,J)=FSEP*(Z(I+IHE(J),J-1,K)-Z(I,J,K))
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!
+!***  ADVECTION OF Z
+!
+!-----------------------------------------------------------------------
+!
+        DO J=MYJS2_P1,MYJE2_P1
+        DO I=MYIS1_P1,MYIE1_P1
+          W(I,J,K)=-(ZEW(I+IHW(J),J)  +ZEW(I+IHE(J),J)                  &
+                    +ZNS(I,J-1)       +ZNS(I,J+1)                       &
+                    +ZNE(I+IHW(J),J-1)+ZNE(I,J)                         &
+                    +ZSE(I,J)         +ZSE(I+IHW(J),J+1))               &
+                    *FAD(I,J)*2.0*HBM2(I,J)/(DPDE(I,J)*DT)              &
+                    +W(I,J,K)
+        ENDDO
+        ENDDO
+
+      ENDDO main_integration
+
+      IF (WP .ge. 0.001) then
+!-----------------------------------------------------------------------
+!---taking external mode out--------------------------------------------
+!-----------------------------------------------------------------------
+
+       DO J=MYJS2_P1,MYJE2_P1
+        DO I=MYIS1_P1,MYIE1_P1
+          TTB(I,J)=0.
+        ENDDO
+       ENDDO
+!
+      DO K=KTS,KTE
+       DO J=MYJS2_P1,MYJE2_P1
+        DO I=MYIS1_P1,MYIE1_P1
+            DPDE(I,J)=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+            TTB(I,J)=(DPDE(I,J))*W(I,J,K)+TTB(I,J)
+        ENDDO
+       ENDDO
+      ENDDO
+!
+       DO J=MYJS2_P1,MYJE2_P1
+        DO I=MYIS1_P1,MYIE1_P1
+          TTB(I,J)=TTB(I,J)/(PDSL(I,J)+PDTOP)
+        ENDDO
+       ENDDO
+!
+      DO K=KTS,KTE
+       DO J=MYJS2_P1,MYJE2_P1
+        DO I=MYIS1_P1,MYIE1_P1
+            W(I,J,K)=W(I,J,K)-TTB(I,J)
+        ENDDO
+       ENDDO
+      ENDDO
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE HADZ
+!
+!-----------------------------------------------------------------------
+!
+      END MODULE MODULE_NONHY_DYNAM
+!
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_PHYSICS_CALLS.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_PHYSICS_CALLS.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_PHYSICS_CALLS.F	(revision 17)
@@ -0,0 +1,3001 @@
+!-----------------------------------------------------------------------
+!
+!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,P_QNR
+      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_GWD
+      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,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
+!   05-12-15  BLACK      - CONVERTED FROM IKJ TO IJK
+!
+! 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
+!
+      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,SICE,SM      &
+     &                                             ,SNOW,THS,VEGFRC
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CUPPT
+
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: Q,T,Z
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: F_ICE       &   !<--- Used only with physics (IKJ)
+     &                                                     ,F_RAIN
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: RTHRATEN     !<--- Used only with physics (IKJ)
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_MOIST)                   &
+                                                 ,INTENT(INOUT) :: MOIST
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACFRCV,ACFRST    &
+     &                                                ,HBOT,HTOP        &
+     &                                                ,RLWIN,RLWTOA     &
+     &                                                ,RSWIN,RSWOUT     &
+     &                                                ,RSWINC,RSWTOA
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),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) ::            &   !<--- Used only with physics (IKJ)
+     &                              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,JMS:JME,KMS:KME),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,ISTAT,J,JDAY,JMONTH,K,KMNTH,N,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,PLYR,PSFC               &
+     &       ,QI,QR,QW,RADT,TIMES,WC,TDUM
+!
+      REAL,DIMENSION(KMS:KME-1) :: QL,TL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: CUPPTR,CZEN,HBOTR,HTOPR        &
+     &                                  ,PDSL,REXNSFC,SWNETDN           &
+     &                                  ,TOT,TOTLWDN,TOTSWDN,TOTSWDNC   &
+     &                                  ,TSFC,XLAND,XLAT,XLON
+!
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: CLFR,DZ                &   !<--- Used only with physics (IKJ)
+     &                                          ,P8W,P_PHY,PI_PHY       &
+     &                                          ,RR,T8W                 &
+     &                                          ,THRATENLW,THRATENSW    &
+     &                                          ,TH_PHY,T_PHY,Z_PHY
+!
+      REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS
+!
+      LOGICAL :: WARM_RAIN
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!*****
+!***** NOTE: THIS IS HARDWIRED FOR CALLS TO LONGWAVE AND SHORTWAVE
+!*****       AT EQUAL INTERVALS
+!*****
+!-----------------------------------------------------------------------
+!
+      NRAD=NRADS
+      RADT=DT*NRADS/60.
+!
+!-----------------------------------------------------------------------
+!
+      ALLOCATE(MOIST_TRANS(IMS:IME,KMS:KME,JMS:JME,N_MOIST),STAT=ISTAT)
+!
+!-----------------------------------------------------------------------
+!
+      CAPA=R_D/CP
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1,MYIE1
+!
+        PDSL(I,J)=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,KTS,J)=TSFC(I,J)
+        P8W(I,KTS,J)=ETA1(KTS)*PDTOP+ETA2(KTS)*PDSL(I,J)+PT
+        Z_PHY(I,KTS,J)=Z(I,J,KTS)
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  FILL THE SINGLE-COLUMN INPUT
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(dpl,i,j,k,plyr,ql,qr,tl)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1,MYIE1
+        DO K=KTS,KTE
+          DPL=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+          QL(K)=MAX(Q(I,J,K),EPSQ)
+          PLYR=AETA1(K)*PDTOP+AETA2(K)*PDSL(I,J)+PT
+          TL(K)=T(I,J,K)
+!
+          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(I,J)+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)
+!
+          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 
+! For RRTM 
+        T8W(I,KTE+1,J)=T8W(I,KTE,J) + 0.5*(T8W(I,KTE,J)-T8W(I,KTE-1,J))
+!
+      ENDDO
+      ENDDO
+!
+      ICLOUD=999
+!
+      GMT=REAL(IHRST)
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+      DO K=KMS,KME
+        DO J=JMS,JME
+        DO I=IMS,IME
+          CLDFRA(I,J,K)=0.
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      DO J=JMS,JME
+        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
+          HTOPR(I,J) =0.
+          HBOTR(I,J) =0.
+!
+!-- 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
+!
+!-----------------------------------------------------------------------
+!***  TRANSPOSE THE MOIST ARRAY (IJK) FOR THE PHYSICS (IKJ).
+!***  REMEMBER THAT MOIST AND MOIST_TRANS ARE ONLY USED WITH
+!***  THE PHYSICS AND THUS THE P_QV SLOT (=2) IS MIXING RATIO,
+!***  NOT SPECIFIC HUMIDITY.
+!-----------------------------------------------------------------------
+!
+      DO N=1,N_MOIST
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO K=KMS,KME
+        DO J=JMS,JME
+        DO I=IMS,IME
+          MOIST_TRANS(I,K,J,N)=MOIST(I,J,K,N)
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+!***  CALL THE INNER DRIVER.
+!
+!-----------------------------------------------------------------------
+!
+      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                               &
+     &                 ,CEN_LAT=grid%cen_lat                            &
+     &                 ,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_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV      &
+     &                 ,QC=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC      &
+     &                 ,QR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR      &
+     &                 ,QI=MOIST_TRANS(IMS,KMS,JMS,P_QI),F_QI=F_QI      &
+     &                 ,QS=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS      &
+     &                 ,QG=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG     )
+
+!
+!-----------------------------------------------------------------------
+!
+!***  UPDATE FLUXES AND TEMPERATURE TENDENCIES.
+!
+!-----------------------------------------------------------------------
+!***  SHORTWAVE
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+      nrads_block: IF(MOD(NTSD,NRADS)==0)THEN
+!-----------------------------------------------------------------------
+!
+        IF(CONFIG_FLAGS%RA_SW_PHYSICS/=GFDLSWSCHEME)THEN
+!
+!-----------------------------------------------------------------------
+!***  COMPUTE CZMEAN FOR NON-GFDL SHORTWAVE
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+          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)
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+            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
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+          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)
+        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)
+!
+          ENDDO
+        ENDDO
+!
+!$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
+            DO K=KTS,KTE
+              RSWTT(I,J,K)=THRATENSW(I,K,J)*PI_PHY(I,K,J)
+            ENDDO
+!
+          ENDDO
+        ENDDO
+!
+      ENDIF nrads_block
+!
+!-----------------------------------------------------------------------
+!***  LONGWAVE
+!-----------------------------------------------------------------------
+!
+      nradl_block: IF(MOD(NTSD,NRADL)==0)THEN
+!
+!$omp parallel do                                                       &
+!$omp& private(i,iendx,j)
+        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
+              TDUM=T(I,J,KTS)
+              SIGT4(I,J)=STBOLT*TDUM*TDUM*TDUM*TDUM
+              RLWIN(I,J)=TOTLWDN(I,J)
+            ENDIF
+!
+          ENDDO
+        ENDDO
+!
+!$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 K=KTS,KTE
+          DO I=MYIS1,IENDX
+            IF(HBM2(I,J)>0.5)THEN
+                RLWTT(I,J,K)=THRATENLW(I,K,J)*PI_PHY(I,K,J)
+            ENDIF
+          ENDDO
+          ENDDO
+!
+        ENDDO
+!
+      ENDIF nradl_block
+!
+!-----------------------------------------------------------------------
+!***  STORE 3D CLOUD FRACTIONS.
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,iendx,j,k)
+      DO K=KTS,KTE
+        DO J=MYJS2,MYJE2
+          IENDX=MYIE1
+          IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
+          DO I=MYIS1,IENDX
+            CLDFRA(I,J,K)=CLFR(I,K,J)
+          ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  RESET THE DIAGNOSTIC CONVECTIVE CLOUD TOPS/BOTTOMS AFTER
+!***  EACH RADIATION CALL.
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,iendx,j)
+!if (config_flags%ra_sw_physics/=hwrfswscheme.and.config_flags%ra_lw_physics/=hwrflwscheme)then
+      DO J=MYJS2,MYJE2
+        IENDX=MYIE1
+        IF(MOD(J,2)==0.AND.ITE==IDE)IENDX=IENDX-1
+        DO I=MYIS1,IENDX
+          HBOT(I,J)=HBOTR(I,J)
+          HTOP(I,J)=HTOPR(I,J)
+          CUPPT(I,J)=CUPPTR(I,J)
+        ENDDO
+      ENDDO
+!endif
+!
+!-----------------------------------------------------------------------
+!***  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
+!
+!
+!-----------------------------------------------------------------------
+!***  UPDATE THE PROGNOSTIC MOIST ARRAY.
+!-----------------------------------------------------------------------
+!
+      DO N=2,N_MOIST
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO J=JMS,JME
+        DO K=KMS,KME
+        DO I=IMS,IME
+          MOIST(I,J,K,N)=MOIST_TRANS(I,K,J,N)
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDDO
+!
+      DEALLOCATE(MOIST_TRANS,STAT=ISTAT)
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE RADIATION
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
+     &                ,N_MOIST,NSOIL,SLDPTH,DZSOIL                      &
+     &                ,DETA1,DETA2,AETA1,AETA2,ETA1,ETA2,PDTOP,PT       &
+     &                ,SM,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                     &
+     &                ,FIS,Z0,Z0BASE,USTAR,MIXHT,PBLH,LPBL,EL_MYJ       &
+     &                ,MOIST,RMOL,MOL                                   &
+     &                ,EXCH_H,EXCH_M,F,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        &
+     &                ,SNOTIME                                          &
+     &                ,SFCEXC,ACSNOW,ACSNOM,SNOPCX,SICE,TG,SOILTB       &
+     &                ,ALBASE,MXSNAL,ALBEDO,SH2O,SI,EPSR,EMBCK          &
+     &                ,U10,V10,TH10,Q10,TSHLTR,QSHLTR,PSHLTR            &
+     &                ,T2,QSG,QVG,QCG,SOILT1,TSNAV,SMFR3D,KEEPFR3DFLAG  &
+     &                ,TWBS,QWBS,TAUX,TAUY,SFCSHX,SFCLHX,SFCEVP                   &
+     &                ,POTEVP,POTFLX,SUBSHX                             &
+     &                ,APHTIM,ARDSW,ARDLW,ASRFC                         &
+     &                ,RSWOUT,RSWTOA,RLWTOA                             &
+     &                ,ASWIN,ASWOUT,ASWTOA,ALWIN,ALWOUT,ALWTOA          &
+     &                ,UZ0H,VZ0H,DUDT,DVDT,UGWDsfc,VGWDsfc,SFENTH              & ! GWD
+     &                ,RTHBLTEN,RQVBLTEN                                &
+     &                ,PCPFLG,DDATA                                     & ! PRECIP ASSIM
+     &                ,HSTDV,HCNVX,HASYW,HASYS,HASYSW,HASYNW,HLENW      & ! GWD
+     &                ,HLENS,HLENSW,HLENNW,HANGL,HANIS,HSLOP,HZMAX      & ! GWD
+     &                ,CROT,SROT                                        & ! GWD
+     &                ,DEW                                              & ! RUC LSM
+     &                ,GRID,CONFIG_FLAGS                                &
+     &                ,IHE,IHW,IVE,IVW                                  &
+     &                ,DISHEAT                                          &
+     &                ,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
+!   05-12-15  BLACK      - CONVERTED FROM IKJ TO IJK
+!   07-05-15  FERRIER    - ADDED GRAVITY WAVE DRAG (GWD) & MOUNTAIN BLOCKING
+!
+! USAGE: CALL TURBL FROM SOLVE_NMM
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!   MACHINE : IBM
+!$$$
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!
+#if (NMM_CORE==1)    
+      LOGICAL,INTENT(IN) ::  DISHEAT                       !  hwrf's doing
+#endif
+      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(INOUT) :: ISLTYP,IVGTYP
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: LPBL
+!
+      REAL,INTENT(IN) :: DT,PDTOP,PT
+!
+      REAL,INTENT(IN) :: SFENTH
+      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(NSOIL),INTENT(IN) :: DZSOIL,SLDPTH
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CZEN,CZMEAN         &
+     &                                             ,DX_ARRAY            &
+     &                                             ,F,FIS,HBM2          &
+     &                                             ,PD,RES              &
+     &                                             ,RLWIN,RLWTOA        &
+     &                                             ,RSWIN,RSWOUT,RSWTOA &
+     &                                             ,SHDMIN,SHDMAX       &
+!    &                                             ,SICE,SIGT4,SM,SR    & !Bandaid
+     &                                             ,SIGT4               &
+     &                ,HSTDV,HCNVX,HASYW,HASYS,HASYSW,HASYNW,HLENW      & ! GWD
+     &                ,HLENS,HLENSW,HLENNW,HANGL,HANIS,HSLOP,HZMAX      & ! GWD
+     &                ,CROT,SROT                                        & ! GWD
+     &                                             ,VBM2,VEGFRC
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: SST
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: SM,EPSR,SR       & !Bandaid
+                                                      ,TG,SICE          &
+                                                      ,EMBCK
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ALBASE,MXSNAL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACSNOM,ACSNOW    &
+     &                                                ,SNOTIME          &
+     &                                                ,AKHS,AKMS        &
+     &                                                ,ALBEDO           &
+     &                                                ,BGROFF,CMC       &
+     &                                                ,MAVAIL,MOL       &
+     &                                                ,MIXHT            &
+     &                                                ,PBLH,POTEVP      &
+     &                                                ,POTFLX,PREC      &
+     &                                                ,QCG,QS,QSG       &
+     &                                                ,QVG,QZ0          &
+     &                                                ,RMOL             &
+     &                                                ,SFCEVP           &
+     &                                                ,SFCLHX,SFCSHX    &
+     &                                                ,SI,SMSTOT        &
+     &                                                ,SNO,SNOPCX       &
+     &                                                ,SOILT1           &
+     &                                                ,SSROFF,SUBSHX    &
+     &                                                ,T2,THS,THZ0      &
+     &                                                ,TSFC,TSNAV       &
+     &                                                ,USTAR,UZ0,UZ0H   &
+     &                                                ,VZ0,VZ0H         &
+     &                                                ,DEW              & !RUC LSM
+     &                                                ,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            & ! GWD
+     &                                              ,UGWDsfc,VGWDsfc      ! GWD
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: GRNFLX,QWBS,RADOT  &
+                                                    ,SFCEXC,SMSTAV      &
+                                                    ,SOILTB,TWBS
+!
+
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: taux, tauy
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM      &
+     &                                                        ,DUDT     &
+     &                                                        ,DVDT     &
+     &                                                        ,Q,Q2     &
+     &                                                        ,T,U,V
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: F_ICE    &   !<--- Used only in physics (IKJ)
+     &                                                        ,F_RAIN   &
+     &                                                        ,RQVBLTEN &
+     &                                                        ,RTHBLTEN
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: EL_MYJ     &   !<--- Used only in physics (IKJ)
+     &                                                      ,EXCH_H     &
+     &                                                      ,EXCH_M
+!
+      REAL,DIMENSION(IMS:IME,NSOIL,JMS:JME),INTENT(INOUT) :: KEEPFR3DFLAG & !<--- Used only in physics (IKJ)
+     &                                                      ,SH2O,SMC     &
+     &                                                      ,SMFR3D,STC
+!
+      REAL,DIMENSION(IMS:IME,NSOIL,JMS:JME)               :: SMCREL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_MOIST)                   &
+     &                                           ,INTENT(INOUT) :: MOIST
+!
+      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,ISTAT,ISTR,J,K,KOUNT_ALL      &
+     &          ,LENGTH_ROW,LLIJ,LLYR,N,SST_UPDATE,SF_URBAN_PHYSICS,NUM_URBAN_LAYERS
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME) :: KPBL,LOWLYR
+!
+      REAL :: TRESH=0.95
+!
+      REAL :: ALTITUDE,CWML,DQDT,DTDT,DTPHS,DX,DZHALF,FACTR,FACTRL      &
+     &       ,G_INV,PLYR,PSFC,QI,QL,QOLD,QR,QW,RATIOMX,RDTPHS      &
+     &       ,ROG,RWMSK,SDEPTH,SNO_FACTR,TL,TLMH,TLMH4,TNEW,TSFC2       &
+     &       ,U_FRAME,V_FRAME,XLVRW
+!
+      REAL :: APES,CAPA,CKLQ,EXNER,FACTOR,FFS,PQ0X,Q2SAT,QFC1,QLOWX     &
+     &       ,RLIVWV,THBOT,DPL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: BR,CHKLOWQ,CT,CWMLOW,ELFLX     &
+     &                                  ,EXNSFC,FACTRS,FLHC,FLQC,GZ1OZ0 &
+     &                                  ,ONE,PDSL,PLM,PSFC_OUT,PSIH     &
+     &                                  ,PSIM,Q2X,QLOW,RAIN,RAINBL      &
+     &                                  ,RLW_DN_SFC,RSW_NET_SFC         &
+     &                                  ,RSW_DN_SFC                     &
+     &                                  ,SFCEVPX,SFCZ,SNOW,SNOWC,SNOWH  &
+     &                                  ,TH2X,THLOW,TLOW,VGFRCK         &
+     &                                  ,WSPD,XLAND,REGIME,HOL
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: DUDT_PHY,DVDT_PHY,DZ   &
+     &                                          ,P_PHY,P8W,PI_PHY       &
+     &                                          ,RQCBLTEN,RQIBLTEN      &
+!BSF &                                     ,RQSBLTEN,RQRBLTEN,RQGBLTEN  &
+     &                                          ,RR,DELP                & ! GWD
+     &                                          ,T_PHY,TH_PHY,TKE       &
+     &                                          ,DUDT_GWD,DVDT_GWD      & ! GWD
+     &                                          ,U_PHY,V_PHY,Z
+!
+      REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS
+!
+      REAL,DIMENSION(IMS:IME,NSOIL,JMS:JME) :: ZERO_SOIL
+!
+      LOGICAL :: E_BDY,WARM_RAIN
+!
+      INTEGER :: NUM_ROOF_LAYERS,NUM_WALL_LAYERS,NUM_ROAD_LAYERS   ! urban
+      INTEGER :: FRACTIONAL_SEAICE
+!
+      INTEGER :: IGS,IGE,JGS,JGE, PQ_I   !BSF
+      LOGICAL :: FQ_I                    !BSF
+
+      CHARACTER(len=255) :: message
+!dbg integer :: kpblmin,kpblmax,lpblmin,lpblmax    !dbg
+!
+!
+    INTEGER  :: isurban
+    CHARACTER(len=256) :: MMINLU
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      ALLOCATE(MOIST_TRANS(IMS:IME,KMS:KME,JMS:JME,N_MOIST),STAT=ISTAT)
+!
+      SF_URBAN_PHYSICS=CONFIG_FLAGS%SF_URBAN_PHYSICS
+
+      if ( config_flags%bl_pbl_physics == BOULACSCHEME ) then
+         call wrf_error_fatal("Cannot use BOULAC PBL with NMM")
+      endif
+      
+      FRACTIONAL_SEAICE = CONFIG_FLAGS%FRACTIONAL_SEAICE
+      IF ( FRACTIONAL_SEAICE == 1 ) THEN
+         CALL WRF_ERROR_FATAL("NMM cannot use FRACTIONAL_SEAICE = 1.")
+      ENDIF
+!
+      DTPHS=NPHS*DT
+      RDTPHS=1./DTPHS
+      G_INV=1./G
+      ROG=R_D*G_INV
+      FACTOR=-XLV*RHOWATER/DTPHS
+      CAPA=R_D/CP
+!
+      U_FRAME=0.
+      V_FRAME=0.
+!
+      IDUMMY=0
+      ISFFLX=1
+      DX=0.
+      SST_UPDATE=config_flags%SST_UPDATE
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+      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)
+      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.
+        EXCH_M(I,K,J)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+!***  PREPARE NEEDED ARRAYS FOR CALLING THE INNER DRIVER.
+!
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(factrl,i,j,llij,tlmh)
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+!
+        PDSL(I,J)=PD(I,J)*RES(I,J)
+!!!     PSFC=PD(I,J)+PDTOP+PT
+!!!     P8W(I,KTS,J)=PSFC
+        P8W(I,KTS,J)=PINT(I,J,KTS)
+        PSFC=PINT(I,J,KTS)
+        LOWLYR(I,J)=KTS     !<----  The lowest model layer counted from the bottom.
+        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
+!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,J,LLIJ)+PINT(I,J,LLIJ+1))*0.5
+        TH2X(I,J)=T(I,J,LLIJ)*(1.E5/PLM(I,J))**CAPA
+        Q2X(I,J)=Q(I,J,LLIJ)
+!
+!-----------------------------------------------------------------------
+!*** 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,J,LLIJ)
+          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)
+!
+        Z(I,KTS,J)=SFCZ(I,J)
+!
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  FILL THE ARRAYS FOR CALLING THE INNER DRIVER.
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(cwml,i,j,k,plyr,qi,ql,qr,qw,tl)
+      DO J=MYJS,MYJE
+        DO K=KTS,KTE
+        DO I=MYIS,MYIE
+          Q2(I,J,K)=MAX(Q2(I,J,K)*HBM2(I,J),EPSQ2)
+          QL=MAX(Q(I,J,K),EPSQ)
+          PLYR=(PINT(I,J,K)+PINT(I,J,K+1))*0.5
+!!!       PLYR=AETA1(K)*PDTOP+AETA2(K)*PDSL(I,J)+PT
+          TL=T(I,J,K)
+          CWML=CWM(I,J,K)
+!
+          RR(I,K,J)=PLYR/(R_D*TL)
+          T_PHY(I,K,J)=TL
+!
+          EXNER=(1.E5/PLYR)**CAPA
+          PI_PHY(I,K,J)=1./EXNER
+          TH_PHY(I,K,J)=TL*EXNER
+          P8W(I,K+1,J)=PINT(I,J,K+1)
+!!!       P8W(I,K+1,J)=ETA1(K+1)*PDTOP+ETA2(K+1)*PDSL(I,J)+PT
+          P_PHY(I,K,J)=PLYR
+          TKE(I,K,J)=0.5*Q2(I,J,K)
+!
+          RTHBLTEN(I,K,J)=0.
+          RQVBLTEN(I,K,J)=0.
+          RQCBLTEN(I,K,J)=0.
+          RQIBLTEN(I,K,J)=0.
+!BSF          RQSBLTEN(I,K,J)=0.
+!BSF          RQRBLTEN(I,K,J)=0.
+!BSF          RQGBLTEN(I,K,J)=0.
+!
+!-- Next 3 lines modified for GWD
+!
+          DPL=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+          Z(I,K+1,J)=Z(I,K,J)+TL/PLYR*DPL*ROG*(Q(I,J,K)*P608-CWML+1.)
+          DELP(I,K,J)=DPL
+          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,J,LLYR),EPSQ)
+        QLOWX=QLOW(I,J)/(1.-QLOW(I,J))
+        QLOW(I,J)=QLOWX/(1.+QLOWX)
+        CWMLOW(I,J)=CWM(I,J,LLYR)
+        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)
+      DO K=KTS,KTE
+        DO J=MYJS1_P1,MYJE1_P1
+          DO I=MYIS_P1,MYIE_P1
+            U_PHY(I,K,J)=(U(I+IHE(J),J,K)+U(I+IHW(J),J,K)               &
+     &                   +U(I,J+1,K)+U(I,J-1,K))                        &
+     &                   *0.25
+            V_PHY(I,K,J)=(V(I+IHE(J),J,K)+V(I+IHW(J),J,K)               &
+     &                   +V(I,J+1,K)+V(I,J-1,K))                        &
+     &                   *0.25
+          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
+!
+!-----------------------------------------------------------------------
+!***  SET MAVAIL EQUAL TO 1. ONLY FOR NMM LSM
+!-----------------------------------------------------------------------
+!
+      DO J=JTS,JTE
+      DO I=ITS,ITE
+        IF(MODEL_CONFIG_REC%SF_SURFACE_PHYSICS(GRID%ID)==2.OR.          &
+           MODEL_CONFIG_REC%SF_SURFACE_PHYSICS(GRID%ID)==99)THEN
+          ONE(I,J)=1.
+        ELSE
+!***  MAVAIL should not be equal to 1. for other LSMs
+          ONE(I,J)=MAVAIL(I,J)
+        ENDIF
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  TRANSPOSE THE MOIST ARRAY (IJK) FOR THE PHYSICS (IKJ).
+!-----------------------------------------------------------------------
+!
+      DO N=1,N_MOIST
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO K=KMS,KME
+        DO J=JMS,JME
+        DO I=IMS,IME
+          MOIST_TRANS(I,K,J,N)=MOIST(I,J,K,N)
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  URBAN RELATED VARIABLES 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 nl_get_isurban(grid%id, isurban)
+      call nl_get_mminlu(grid%id, mminlu)
+!
+!-----------------------------------------------------------------------
+!
+!***  CALL SURFACE LAYER AND LAND SURFACE PHYSICS
+!
+!-----------------------------------------------------------------------
+!
+      CALL SET_TILES(GRID,IDS,IDE-1,JDS+1,JDE-1,ITS,ITE,JTS,JTE)
+!
+      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                    &
+     &          ,FRACTIONAL_SEAICE=FRACTIONAL_SEAICE                    &
+     &          ,TICE2TSK_IF2COLD=CONFIG_FLAGS%TICE2TSK_IF2COLD         &
+     &          ,ISLTYP=ISLTYP                                          &
+     &          ,ITIMESTEP=NTSD,IVGTYP=IVGTYP,LOWLYR=LOWLYR             &
+     &          ,MAVAIL=ONE,RMOL=RMOL,MOL=MOL                           &
+     &          ,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,TAUX=TAUX,TAUY=TAUY,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          &
+     &          ,SMCREL=SMCREL                                          &
+     &          ,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,XICEM=SICE     &
+     &          ,ISICE=GRID%LANDUSE_ISICE,ISWATER=GRID%ISWATER          &
+     &          ,XLAND=XLAND,Z=Z,ZNT=Z0,ZS=SLDPTH,CT=CT,TKE_PBL=TKE,SFENTH=SFENTH     &
+     &          ,ALBBCK=ALBASE,LH=ELFLX,SH2O=SH2O,SHDMAX=SHDMAX         &
+     &          ,SHDMIN=SHDMIN,Z0=Z0BASE,FLQC=FLQC,FLHC=FLHC            &
+     &          ,PSFC=PSFC_OUT,EMISS=EPSR,EMBCK=EMBCK                   &
+     &          ,SF_SFCLAY_PHYSICS=CONFIG_FLAGS%SF_SFCLAY_PHYSICS       &
+     &          ,SF_SURFACE_PHYSICS=CONFIG_FLAGS%SF_SURFACE_PHYSICS     &
+     &          ,RA_LW_PHYSICS=CONFIG_FLAGS%RA_LW_PHYSICS               &
+     &          ,LAI=GRID%LAI,IZ0TLND=CONFIG_FLAGS%IZ0TLND              &
+     &          ,SF_URBAN_PHYSICS=SF_URBAN_PHYSICS                      &
+!     &          ,GMT=GMT,XLAT=XLAT,XLONG=XLONG,JULDAY=JULDAY            &
+     &          ,NUM_URBAN_LAYERS=NUM_URBAN_LAYERS                      &
+     &          ,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_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV        &
+     &          ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC        &
+     &          ,QR_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR        &
+     &          ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QI),F_QI=F_QI        &
+     &          ,QS_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS        &
+     &          ,QG_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG        &
+     &          ,RAINBL=RAINBL                                          &
+     &          ,LAGDAY=1                                               & ! tmn_update
+! for RUCLSM
+     &          ,QSG=QSG,QVG=QVG,QCG=QCG,SOILT1=SOILT1                  &
+     &          ,TSNAV=TSNAV,SMFR3D=SMFR3D,KEEPFR3DFLAG=KEEPFR3DFLAG    &
+     &          ,POTEVP=POTEVP,SNOPCX=SNOPCX,SOILTB=SOILTB,SR=SR        &
+     &          ,DEW=DEW                                                &
+! for URBAN
+     &          ,NUM_ROOF_LAYERS=NUM_ROOF_LAYERS                        & ! urban
+     &          ,NUM_WALL_LAYERS=NUM_WALL_LAYERS                        & ! urban
+     &          ,NUM_ROAD_LAYERS=NUM_ROAD_LAYERS                        & ! urban
+! for YSU
+     &          ,REGIME=REGIME                                          &
+! for PX LSM
+     &          ,NLCAT=grid%num_land_cat,  NSCAT=grid%num_soil_cat      & ! P-X LSM
+     &        ,ISURBAN=isurban, MMINLU=TRIM(mminlu)                       &
+     &        ,SNOTIME = grid%SNOTIME &
+     &        ,RDLAI2D=config_flags%rdlai2d                                   &
+     &        ,usemonalb=config_flags%usemonalb                           &
+     &        ,NOAHRES=grid%noahres                                       &
+     &                                                          )
+!
+!-----------------------------------------------------------------------
+!
+!***  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_PHY(I,K,J)=0.
+        DVDT_PHY(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
+!
+!BSF: Logical FQ_I index PQ_I are set to values associated with snow
+!     for the ETAMPNEW scheme so that they can be mixed by the PBL schemes.
+!
+      IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)THEN
+         FQ_I=F_QS
+         PQ_I=P_QS
+      ELSE
+         FQ_I=F_QI
+         PQ_I=P_QI
+      ENDIF
+!
+      CALL PBL_DRIVER(                                                &
+     &                ITIMESTEP=NTSD,DT=DT                            &
+     &               ,U_FRAME=U_FRAME,V_FRAME=V_FRAME                 &
+     &               ,RUBLTEN=DUDT_PHY,RVBLTEN=DVDT_PHY               &
+     &               ,RTHBLTEN=RTHBLTEN,RQVBLTEN=RQVBLTEN             & !BSF
+     &               ,RQCBLTEN=RQCBLTEN,RQIBLTEN=RQIBLTEN             & !BSF
+!BSF &               ,RQRBLTEN=RQRBLTEN,RQSBLTEN=RQSBLTEN             & !BSF
+!BSF &               ,RQGBLTEN=RQGBLTEN                               & !BSF
+     &               ,TSK=TSFC,XLAND=XLAND,ZNT=Z0,HT=SFCZ             &
+     &               ,UST=USTAR,MIXHT=MIXHT,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_PBL=TKE,EL_PBL=EL_MYJ,F=F       &
+     &               ,EXCH_H=EXCH_H,EXCH_M=EXCH_M,AKHS=AKHS,AKMS=AKMS &
+     &               ,THZ0=THZ0,QZ0=QZ0,UZ0=UZ0H,VZ0=VZ0H             &
+     &               ,QSFC=QS,LOWLYR=LOWLYR                           &
+     &               ,PSIM=PSIM,PSIH=PSIH,GZ1OZ0=GZ1OZ0               &
+     &               ,U10=U10,V10=V10,T2=T2,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        &
+#if (NMM_CORE==1)
+     &               ,DISHEAT=DISHEAT                                 &
+#endif
+                ! Optional args
+     &               ,QV_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV &
+     &               ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC &
+     &               ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,PQ_I),F_QI=FQ_I &
+     &               ,QR_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR &
+     &               ,QS_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS &
+     &               ,QG_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG &
+     &               ,HOL=HOL,sf_sfclay_physics=CONFIG_FLAGS%SF_SFCLAY_PHYSICS &
+     &               ,sf_urban_physics=CONFIG_FLAGS%SF_URBAN_PHYSICS)
+!
+!***  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==JDS)THEN
+        DO J=JDS,JDS+1
+        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(message,*)'Troublesome TSHLTR...I,J,TSHLTR,PSHLTR: '        &
+                      ,I,J,TSHLTR(I,J),PSHLTR(I,J)
+            CALL wrf_message(trim(message))
+          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
+!
+!=======================================================================
+!===  Begin gravity wave drag (GWD) and mountain blocking (MB)  ========
+!=======================================================================
+!
+      IGS=MYIS1
+      IGE=MYIE1
+      JGS=MYJS2
+      JGE=MYJE2
+!dbg !dbg
+!dbg kpblmin=100
+!dbg kpblmax=-100
+!dbg DO J=JGS,JGE
+!dbg   DO I=IGS,IGE
+!dbg     kpblmin=min(kpblmin,kpbl(i,j))
+!dbg     kpblmax=max(kpblmax,kpbl(i,j))
+!dbg   enddo
+!dbg enddo
+!dbg print *,'TURBL: IGS,IGE,JGS,JGE,kpblmin,kpblmax=',IGS,IGE,JGS,JGE,kpblmin,kpblmax
+!dbg
+
+!      print *,'grid%id  gwd_opt at module_PHYSICS ',grid%id, grid%gwd_opt
+!      WRITE(0,*)'grid%id  gwd_opt at module_PHYSICS ',grid%id, grid%gwd_opt
+!      WRITE(MESSAGE,125)grid%gwd_opt
+!125   FORMAT(1X,'grid%id  module_PHYSICS.F :  gwd_opt  ',I2,2X,I2)
+
+
+#ifdef HWRF
+      IF (grid%gwd_opt .eq. 2 .AND. grid%id.eq.1) THEN                                        !Kwon's doing for parent only now
+#else
+      IF (grid%gwd_opt .eq. 2) THEN
+#endif
+!      print *,'==grid%id  gwd_opt at module_PHYSICS inside gwd ',grid%id, grid%gwd_opt        !because there is no data for nest domain
+
+        CALL wrf_message("GWD usage currently may be problematic for some cases - use at own risk")
+
+      CALL GWD_driver(U=U_PHY,V=V_PHY,T=T_PHY                           &
+     &               ,Q=MOIST_TRANS(IMS,KMS,JMS,P_QV)                   &
+     &               ,Z=Z,DP=DELP,PINT=P8W,PMID=P_PHY,EXNR=PI_PHY       &
+     &               ,KPBL=KPBL,ITIME=NTSD                              &
+     &               ,HSTDV=HSTDV,HCNVX=HCNVX,HASYW=HASYW,HASYS=HASYS   &
+     &               ,HASYSW=HASYSW,HASYNW=HASYNW,HLENW=HLENW           &
+     &               ,HLENS=HLENS,HLENSW=HLENSW,HLENNW=HLENNW           &
+     &               ,HANGL=HANGL,HANIS=HANIS,HSLOP=HSLOP,HZMAX=HZMAX   &
+     &               ,CROT=CROT,SROT=SROT                               &
+     &               ,DUDT=DUDT_GWD,DVDT=DVDT_GWD                       &
+     &               ,UGWDsfc=UGWDsfc,VGWDsfc=VGWDsfc                   &
+     &               ,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=IGS,ITE=IGE,JTS=JGS,JTE=JGE,KTS=KTS,KTE=KTE )
+
+!=======================================================================
+!=====  End gravity wave drag (GWD) and mountain blocking (MB)  ========
+!=======================================================================
+!
+!-----------------------------------------------------------------------
+!***  TRANSFER THE WIND TENDENCIES.
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+      DO J=JTS,JTE
+      DO I=ITS,ITE
+
+
+!mp     temporary bandaid limiting GWD/MB wind tendencies
+
+        IF (DUDT_GWD(I,K,J) .gt. 1.6) then
+        write(message,*) 'BIG DUDT_GWD:: ', I,K,J, DUDT_GWD(I,K,J)
+        CALL wrf_message(message)
+        DUDT_GWD(I,K,J)=1.6
+        ENDIF
+
+        IF (DUDT_GWD(I,K,J) .lt. -1.6) then
+        write(message,*) 'BIG DUDT_GWD:: ', I,K,J, DUDT_GWD(I,K,J)
+        CALL wrf_message(message)
+        DUDT_GWD(I,K,J)=-1.6
+        ENDIF
+
+        IF (DVDT_GWD(I,K,J) .gt. 1.6) then
+        write(message,*) 'BIG DVDT_GWD:: ', I,K,J, DVDT_GWD(I,K,J)
+        CALL wrf_message(message)
+        DVDT_GWD(I,K,J)=1.6
+        ENDIF
+
+        IF (DVDT_GWD(I,K,J) .lt. -1.6) then
+        write(message,*) 'BIG DVDT_GWD:: ', I,K,J, DVDT_GWD(I,K,J)
+        CALL wrf_message(message)
+        DVDT_GWD(I,K,J)=-1.6
+        ENDIF
+
+!mp     end temporary bandaid
+
+        DUDT(I,J,K)=DUDT_PHY(I,K,J)+DUDT_GWD(I,K,J)
+        DVDT(I,J,K)=DVDT_PHY(I,K,J)+DVDT_GWD(I,K,J)
+
+      ENDDO
+      ENDDO
+      ENDDO
+
+      ELSE  ! no GWD
+
+      DO K=KTS,KTE
+      DO J=JTS,JTE
+      DO I=ITS,ITE
+        DUDT(I,J,K)=DUDT_PHY(I,K,J)
+        DVDT(I,J,K)=DVDT_PHY(I,K,J)
+      ENDDO
+      ENDDO
+      ENDDO
+
+      ENDIF ! gwd_opt
+!
+!-----------------------------------------------------------------------
+!***  TRANSPOSE THE MOIST_TRANS ARRAY BACK TO THE PROGNOSTIC MOIST ARRAY.
+!-----------------------------------------------------------------------
+!
+      DO N=1,N_MOIST
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO J=JMS,JME
+        DO K=KMS,KME
+        DO I=IMS,IME
+          MOIST(I,J,K,N)=MOIST_TRANS(I,K,J,N)
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDDO
+!
+      DEALLOCATE(MOIST_TRANS,STAT=ISTAT)
+!
+!-----------------------------------------------------------------------
+!***  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 K=KTS,KTE
+      DO J=MYJS2,MYJE2
+        IEND=MYIE1
+        IF(E_BDY.AND.MOD(J,2)==0)IEND=IEND-1
+!
+        DO I=MYIS1,IEND
+          DTDT=RTHBLTEN(I,K,J)*PI_PHY(I,K,J)
+          DQDT=RQVBLTEN(I,K,J)         !Mixing ratio tendency
+          T(I,J,K)=T(I,J,K)+DTDT*DTPHS
+          QOLD=Q(I,J,K)
+          RATIOMX=QOLD/(1.-QOLD)+DQDT*DTPHS
+          Q(I,J,K)=RATIOMX/(1.+RATIOMX)
+!         Q(I,J,K)=MAX(Q(I,J,K),EPSQ)
+          MOIST(I,J,K,P_QV)=MAX(EPSQ,(MOIST(I,J,K,P_QV)+RQVBLTEN(I,K,J)*DTPHS) )
+          CWM(I,J,K)=0.
+!
+          IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW.and.CONFIG_FLAGS%MP_PHYSICS/=etamp_hwrf)THEN
+            DO I_M=1,N_MOIST
+              IF(I_M==P_QC) THEN
+                MOIST(I,J,K,I_M)=MAX(EPSQ,(MOIST(I,J,K,I_M)+RQCBLTEN(I,K,J)*DTPHS) )
+              ELSE IF(I_M==P_QI) THEN
+                MOIST(I,J,K,I_M)=MAX(EPSQ,(MOIST(I,J,K,I_M)+RQIBLTEN(I,K,J)*DTPHS) )
+!BSF              ELSE IF(I_M==P_QS) THEN
+!BSF                MOIST(I,J,K,I_M)=MAX(EPSQ,(MOIST(I,J,K,I_M)+RQSBLTEN(I,K,J)*DTPHS) )
+!BSF              ELSE IF(I_M==P_QR) THEN
+!BSF                MOIST(I,J,K,I_M)=MAX(EPSQ,(MOIST(I,J,K,I_M)+RQRBLTEN(I,K,J)*DTPHS) )
+!BSF              ELSE IF(I_M==P_QG) THEN
+!BSF                MOIST(I,J,K,I_M)=MAX(EPSQ,(MOIST(I,J,K,I_M)+RQGBLTEN(I,K,J)*DTPHS) )
+              ENDIF
+              IF(I_M/=P_QV) CWM(I,J,K)=CWM(I,J,K)+MOIST(I,J,K,I_M)
+            ENDDO
+          ELSE
+!
+!-- Allow vertical mixing to modify cloud ice + snow for ETAMPNEW
+!
+            QW=MAX(0.,MOIST(I,J,K,P_QC)+RQCBLTEN(I,K,J)*DTPHS )
+            if(CONFIG_FLAGS%MP_PHYSICS.eq.etampnew)then
+             QI=MAX(0.,MOIST(I,J,K,P_QS)+RQIBLTEN(I,K,J)*DTPHS )  !-- Total ice
+!BSF            QR=MAX(0.,MOIST(I,J,K,P_QR)+RQRBLTEN(I,K,J)*DTPHS )
+             QR=MAX(0.,MOIST(I,J,K,P_QR) )
+             MOIST(I,J,K,P_QC)=QW
+             MOIST(I,J,K,P_QS)=QI
+             MOIST(I,J,K,P_QR)=QR
+            elseif(CONFIG_FLAGS%MP_PHYSICS.eq.etamp_hwrf)then
+             QI=MAX(0.,MOIST(I,J,K,P_QI)+RQIBLTEN(I,K,J)*DTPHS )  !-- Total ice
+!BSF            QR=MAX(0.,MOIST(I,J,K,P_QR)+RQRBLTEN(I,K,J)*DTPHS )
+             QR=MAX(0.,MOIST(I,J,K,P_QR) )
+             MOIST(I,J,K,P_QC)=QW
+             MOIST(I,J,K,P_QI)=QI
+             MOIST(I,J,K,P_QR)=QR
+            endif
+             CWM(I,J,K)=QW+QI+QR
+!
+            IF(QI<=EPSQ)THEN
+              F_ICE(I,K,J)=0.
+            ELSE
+              F_ICE(I,K,J)=MAX(0.,MIN(1.,QI/CWM(I,J,K)))
+            ENDIF
+!
+            IF(QR<=EPSQ)THEN
+              F_RAIN(I,K,J)=0.
+            ELSE
+              F_RAIN(I,K,J)=QR/(QW+QR)
+            ENDIF
+!
+          ENDIF     !-- IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW)THEN
+!
+          Q2(I,J,K)=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,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
+!   05-12-12  BLACK      - CONVERTED FROM IKJ TO IJK
+!
+! 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,JMS:JME,KMS:KME),INTENT(IN) :: DUDT,DVDT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: UZ0,VZ0
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),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 K=KTS,KTE
+        DO J=MYJS2,MYJE2
+          IEND=MYIE1
+          IF(E_BDY.AND.MOD(J,2)==1)IEND=IEND-1
+!
+          DO I=MYIS1,IEND
+            U(I,J,K)=(DUDT(I+IVE(J),J,K)+DUDT(I+IVW(J),J,K)             &
+     &               +DUDT(I,J+1,K)+DUDT(I,J-1,K))*0.25*DTPHS           &
+     &               +U(I,J,K)
+            V(I,J,K)=(DVDT(I+IVE(J),J,K)+DVDT(I+IVW(J),J,K)             &
+     &               +DVDT(I,J+1,K)+DVDT(I,J-1,K))*0.25*DTPHS           &
+     &               +V(I,J,K)
+          ENDDO
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE UV_H_TO_V
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL                       &
+     &                 ,GPS,RESTRT,HYDRO                                &
+     &                 ,CLDEFI,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,W,Z,FIS,W0AVG                        &
+     &                 ,PREC,ACPREC,CUPREC,CUPPT,CPRATE                 &
+     &                 ,SM,HBM2,LPBL,CNVBOT,CNVTOP                      &
+     &                 ,HTOP,HBOT,HTOPD,HBOTD,HTOPS,HBOTS               &
+     &                 ,RTHBLTEN,RQVBLTEN,RTHRATEN                      &
+#if (NMM_CORE==1)    
+     &                 ,DUCUDT, DVCUDT, MOMMIX, store_rand               &                  
+#endif
+     &                 ,AVCNVC,ACUTIM,IHE,IHW                           &
+     &                 ,GRID,CONFIG_FLAGS                               &
+     &                 ,NRND1                                              &  ! NRND1 for random no restart
+     &                 ,IDS,IDE,JDS,JDE,KDS,KDE                         &
+     &                 ,IMS,IME,JMS,JME,KMS,KME                         &
+     &                 ,IPS,IPE,JPS,JPE,KPS,KPE                         &
+     &                 ,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
+!   05-12-15  BLACK      - CONVERTED FROM IKJ TO IJK
+!
+! 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                     &
+     &                     ,IPS,IPE,JPS,JPE,KPS,KPE                     &
+     &                     ,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) :: 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      &
+     &                                                ,PREC,CPRATE      &
+     &                 ,APR_GR,APR_W,APR_MC                             &
+     &                 ,APR_ST,APR_AS,APR_CAPMA                         &
+     &                 ,APR_CAPME,APR_CAPMI                             &
+     &                 ,GSW,MASS_FLUX
+#if (NMM_CORE==1)
+     REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: store_rand 
+#endif
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: F_ICE       &
+     &                                                     ,F_RAIN
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: QTEN     &
+     &                                                        ,RQVBLTEN &
+     &                                                        ,RTHBLTEN &
+     &                                                        ,RTHRATEN &
+     &                                                        ,TTEN
+!
+#if (NMM_CORE==1)
+      REAL, INTENT(INOUT)::MOMMIX
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT):: DUCUDT, DVCUDT 
+      REAL,DIMENSION(IDS:IDE,JDS:JDE)               :: DATA1 
+      LOGICAL, EXTERNAL::wrf_dm_on_monitor
+#endif
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM      &
+     &                                                        ,OMGALF   &
+     &                                                        ,Q,T      &
+     &                                                        ,TCUCN    &
+     &                                                        ,U,V      &
+     &                                                        ,W,Z
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: W0AVG
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,1:ENSDIM),INTENT(INOUT) :: PR_ENS  &
+     &                                                         ,XF_ENS
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,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,ISTAT,J,K,MNTO,N,N_TIMSTPS_OUTPUT       &
+     &          ,NCUBOT,NCUTOP,NSTEP_CNV
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME) :: KPBL,LBOT,LOWLYR,LTOP
+!
+      REAL :: CAPA,CF_HI,DPL,DQDT,DTCNVC,DTDT,FICE,FRAIN,G_INV          &
+     &       ,PCPCOL,PLYR,QI,QL_K,QR,QW,RDTCNVC,TL_K,WC,WMID
+!
+      REAL,DIMENSION(KMS:KME-1) :: QL,TL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: CUBOT,CUTOP,NCA,PDSL           &
+     &                                  ,RAINC,SFCZ,XLAND
+#ifndef WRF_CHEM
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: RAINCV
+#endif
+!
+      REAL,DIMENSION(ITS:ITE,JTS:JTE) :: WMID_L
+!
+      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,WINT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,ENSDIM) :: ZERO_GD
+!
+      REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS
+!
+      LOGICAL :: RESTART,WARM_RAIN
+      LOGICAL,DIMENSION(IMS:IME,JMS:JME) :: CU_ACT_FLAG
+!
+      CHARACTER(LEN=255) :: message
+!
+!-----------------------------------------------------------------------
+!***  FOR TEMPERATURE CHANGE CHECK ONLY.
+!-----------------------------------------------------------------------
+      INTEGER :: DTEMP_CHECK=2.0
+      REAL :: TCHANGE
+!  random number restart
+      INTEGER,DIMENSION(:),INTENT(INOUT) ::   NRND1
+      INTEGER, SAVE  :: nfirst
+      data nfirst /0/
+#if (NMM_CORE==1)
+      INTEGER                    :: IDT                
+      REAL,   DIMENSION(2)       :: RND1 
+#endif
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!***  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)
+           CUTOP(I,J)=0.
+           CUBOT(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(I,J)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1,MYIE1
+!
+        PDSL(I,J)=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)=KTS        !<----  The lowest model layer counted from the bottom.
+        XLAND(I,J)=SM(I,J)+1.
+        NCA(I,J)=0.
+        SFCZ(I,J)=FIS(I,J)*G_INV
+!
+        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
+      ENDDO
+      ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(dpl,fice,frain,i,j,k,plyr,qi,ql,qr,qw,wc)
+      DO J=MYJS2,MYJE2
+        DO K=KTS,KTE
+        DO I=MYIS1,MYIE1
+          DPL=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+          QL(K)=MAX(Q(I,J,K),EPSQ)
+          PLYR=AETA1(K)*PDTOP+AETA2(K)*PDSL(I,J)+PT
+          TL(K)=T(I,J,K)
+!
+          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,J,K+1)
+          P8W(I,K+1,J)=ETA1(K+1)*PDTOP+ETA2(K+1)*PDSL(I,J)+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 K=KTS,KTE
+        DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+          DZ(I,K,J)=Z(I,J,K+1)-Z(I,J,K)
+        ENDDO
+        ENDDO
+        ENDDO
+!
+        IF(NTSD==0)THEN
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+          DO J=MYJS2,MYJE2
+          DO K=KTS,KTE+1   ! zero for all interfaces
+          DO I=MYIS1,MYIE1
+            WINT(I,K,J)=0.
+          ENDDO
+          ENDDO
+          ENDDO
+
+	ELSE  ! not NTSD=0
+
+         DO J=MYJS2,MYJE2
+           DO I=MYIS1,MYIE1
+             WINT(I,KTS,J)=0.
+             WINT(I,KTE+1,J)=0.
+           ENDDO
+         ENDDO
+
+         DO J=MYJS2,MYJE2
+          DO K=KTS+1,KTE
+           DO I=MYIS1,MYIE1
+             WINT(I,K,J)=0.5*(W(I,J,K)+W(I,J,K-1))
+           ENDDO
+          ENDDO
+         ENDDO
+
+        ENDIF
+	
+      ELSE   ! hydrostatic
+
+        DO J=MYJS2,MYJE2
+        DO I=MYIS1,MYIE1
+          WINT(I,KTS,J)=0.
+          WINT(I,KTE+1,J)=0.
+        ENDDO
+        ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k,plyr)
+        DO J=MYJS2,MYJE2
+          DO I=MYIS1,MYIE1
+            WMID_L(I,J)=-OMGALF(I,J,KTS)*CP/(G*DT)
+            PDSL(I,J)=PD(I,J)*RES(I,J)
+            PLYR=AETA1(KTS)*PDTOP+AETA2(KTS)*PDSL(I,J)+PT
+            DZ(I,KTS,J)=T(I,J,KTS)*(P608*Q(I,J,KTS)+1.)*R_D             &
+     &                 *(P8W(I,KTS,J)-P8W(I,KTS+1,J))                   &
+     &                 /(PLYR*G)
+          ENDDO
+        ENDDO
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k,ql_k,tl_k,wmid)
+        DO J=MYJS2,MYJE2
+          DO K=KTS+1,KTE
+          DO I=MYIS1,MYIE1
+            TL_K=T_PHY(I,K,J)
+            QL_K=MAX(Q(I,J,K),EPSQ)
+            WMID=-OMGALF(I,J,K)*CP/(G*DT)
+            WINT(I,K,J)=0.5*(WMID_L(I,J)+WMID)
+            WMID_L(I,J)=WMID
+            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)
+          ENDDO
+          ENDDO
+        ENDDO
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  COMPUTE VELOCITY COMPONENTS AT MASS POINTS
+!-----------------------------------------------------------------------
+!
+      IF(CONFIG_FLAGS%CU_PHYSICS/=BMJSCHEME)THEN
+!
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO K=KTS,KTE
+!
+          DO J=MYJS1_P1,MYJE1_P1
+          DO I=MYIS_P1,MYIE_P1
+            U_PHY(I,K,J)=(U(I+IHE(J),J,K)+U(I+IHW(J),J,K)               &
+     &                   +U(I,J+1,K)+U(I,J-1,K))                        &
+     &                   *0.25
+            V_PHY(I,K,J)=(V(I+IHE(J),J,K)+V(I+IHW(J),J,K)               &
+     &                   +V(I,J+1,K)+V(I,J-1,K))                        &
+     &                   *0.25
+          ENDDO
+          ENDDO
+!
+        ENDDO
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!***  TRANSPOSE THE MOIST ARRAY (IJK) FOR THE PHYSICS (IKJ).
+!-----------------------------------------------------------------------
+!
+      IF(.NOT.ALLOCATED(MOIST_TRANS))THEN
+        ALLOCATE(MOIST_TRANS(IMS:IME,KMS:KME,JMS:JME,N_MOIST),STAT=ISTAT)
+      ENDIF
+!
+      DO N=1,N_MOIST
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO K=KMS,KME
+        DO J=JMS,JME
+        DO I=IMS,IME
+          MOIST_TRANS(I,K,J,N)=MOIST(I,J,K,N)
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDDO
+
+
+      CALL SET_TILES(GRID,IDS+1,IDE-1,JDS+2,JDE-2,ITS,ITE,JTS,JTE)
+#if (NMM_CORE==1)
+!#ifdef HWRF
+!
+!-----------------------------------------------------------------------
+!
+!     SAS CONVECTION NEEDS RANDOM NUMBER WHICH IS STORED HERE FOR 
+!     EACH OF THE DOMAIN AND THEN THEY ARE PASSED ON INTO THE
+!     CUMULUS DRIVER. THIS IS gopal's doing
+!
+
+      IF(CONFIG_FLAGS%CU_PHYSICS==SASSCHEME)THEN
+!
+          IF(GRID%ID .EQ. 1)THEN   ! Both parent and nest set to 5 minutes for random number calls 
+           IDT=MOD(NTSD,NCNVC)    
+          ELSE
+           IDT=MOD(NTSD,5*NCNVC)
+          ENDIF
+ 
+          IF(IDT.EQ.0 .OR. NTSD .EQ. 0)THEN
+!$omp parallel do                                                       &
+!$omp& private(i,j)
+             IF (wrf_dm_on_monitor()) THEN   !!!! For bit reproducibility of random numbers 
+             if (restart .and. nfirst .eq. 0 ) then
+             call random_seed(put=nrnd1)
+             nfirst=1
+             endif
+             call random_seed(get=nrnd1)
+              DO J=JDS,JDE       !JTS,JTE
+               DO I=IDS,IDE      !ITS,ITE       
+                  CALL RANDOM_NUMBER(rnd1)
+                  DATA1(I,J)=rnd1(2) 
+               ENDDO
+              ENDDO
+             ENDIF
+             CALL wrf_dm_bcast_bytes (DATA1,IDE*JDE*RWORDSIZE)  !!! broadcast random nos. to other processors
+
+             DO J=JDS,JDE
+               DO I =IDS,IDE
+                 IF(I.GE.ITS .AND. I .LE. MIN(ide,ite) .AND. J.GE.JTS  .AND. J .LE. MIN(jde,jte))THEN
+                  STORE_RAND(I,J)=DATA1(I,J)
+                 ENDIF
+               ENDDO
+             ENDDO
+!
+          ENDIF    ! for IF(IDT.EQ.0 .OR. NTSD .EQ. 0)
+!
+      ELSE
+!jm        STORE_RAND(I,J) = 0.0
+        STORE_RAND = 0.0
+      ENDIF
+
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO K=KMS,KME
+        DO J=JMS,JME
+        DO I=IMS,IME
+           DUCUDT(i,j,k)=0.0
+           DVCUDT(i,j,k)=0.0
+        ENDDO
+        ENDDO
+        ENDDO
+!#endif
+#endif
+      CALL CUMULUS_DRIVER(GRID                                          &
+     &                 ,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=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                        &
+     &                 ,PERIODIC_X=.FALSE.,PERIODIC_Y=.FALSE.           &
+     &                 ,HTOP=CUTOP,HBOT=CUBOT,KPBL=KPBL,HT=SFCZ,Z=Z     &
+     &                 ,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                               &
+#if (NMM_CORE==1)
+     &                 ,RUCUTEN=DUCUDT, RVCUTEN=DVCUDT, MOMMIX=MOMMIX   &
+                       ,store_rand=store_rand                           &
+#endif
+                  ! Selection argument
+     &                 ,CU_PHYSICS=CONFIG_FLAGS%CU_PHYSICS              &
+                  ! Moisture tracer arguments
+     &                 ,QV_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV &
+     &                 ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC &
+     &                 ,QR_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR &
+     &                 ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QI),F_QI=F_QI &
+     &                 ,QS_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS &
+     &                 ,QG_CURR=MOIST_TRANS(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(i,iendx,j,ncubot,ncutop,pcpcol)
+      pcp_cloud: DO J=MYJS2,MYJE2
+        IENDX=MYIE1
+        IF(MOD(J,2)==0.AND.ITE==IDE-1)IENDX=IENDX-1
+        DO I=MYIS1,IENDX
+!
+!***  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.
+!***  THEY MUST BE TREATED SEPARATELY FROM EACH OTHER.
+!
+          CUTOP(I,J)=MIN(CUTOP(I,J),REAL(KDE))
+          CUTOP(I,J)=MAX(CUTOP(I,J),0.0)
+          CUBOT(I,J)=MIN(CUBOT(I,J),REAL(KDE))
+          CUBOT(I,J)=MAX(CUBOT(I,J),0.0)
+
+          NCUTOP=NINT(CUTOP(I,J))
+          NCUBOT=NINT(CUBOT(I,J))
+!
+          IF(NCUTOP>1.AND.NCUTOP<KDE)THEN
+            HTOP(I,J)=MAX(CUTOP(I,J),HTOP(I,J))
+            CNVTOP(I,J)=MAX(CUTOP(I,J),CNVTOP(I,J))
+            IF(PCPCOL>0.)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.NCUBOT<KDE)THEN
+            HBOT(I,J)=MIN(CUBOT(I,J),HBOT(I,J))
+            CNVBOT(I,J)=MIN(CUBOT(I,J),CNVBOT(I,J))
+            IF(PCPCOL>0.)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 pcp_cloud
+!
+!-----------------------------------------------------------------------
+!***  UPDATE TEMPERATURE, SPECIFIC HUMIDITY, AND HEATING.
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(dqdt,dtdt,i,iendx,j,k,tchange)
+      DO K=KTS,KTE
+      DO J=MYJS2,MYJE2
+        IENDX=MYIE1
+        IF(MOD(J,2)==0.AND.ITE==IDE-1)IENDX=IENDX-1
+        DO I=MYIS1,IENDX
+!
+!***  RQVCUTEN IN BMJDRV IS THE MIXING RATIO TENDENCY,
+!***  SO RETRIEVE DQDT BY CONVERTING TO SPECIFIC HUMIDITY.
+!
+          DQDT=RQVCUTEN(I,K,J)/(1.+MOIST_TRANS(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,J,K)=T(I,J,K)+DTDT*DTCNVC
+          Q(I,J,K)=Q(I,J,K)+DQDT*DTCNVC
+          TCUCN(I,J,K)=TCUCN(I,J,K)+DTDT
+          MOIST_TRANS(I,K,J,P_QV)=Q(I,J,K)/(1.-Q(I,J,K))       !Convert to mixing ratio
+!
+          cps_select: SELECT CASE(config_flags%cu_physics)
+!
+          CASE (KFSCHEME,KFETASCHEME,GDSCHEME,SASSCHEME)
+            IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW)THEN
+              MOIST_TRANS(I,K,J,P_QS)=MAX(0.,MOIST_TRANS(I,K,J,P_QS)+RQICUTEN(I,K,J)*DTCNVC+RQSCUTEN(I,K,J)*DTCNVC)
+            ELSE
+              MOIST_TRANS(I,K,J,P_QI)=MAX(0.,MOIST_TRANS(I,K,J,P_QI)+RQICUTEN(I,K,J)*DTCNVC)
+              MOIST_TRANS(I,K,J,P_QS)=MAX(0.,MOIST_TRANS(I,K,J,P_QS)+RQSCUTEN(I,K,J)*DTCNVC)
+            ENDIF
+            MOIST_TRANS(I,K,J,P_QR)=MAX(0.,MOIST_TRANS(I,K,J,P_QR)+RQRCUTEN(I,K,J)*DTCNVC)
+            MOIST_TRANS(I,K,J,P_QC)=MAX(0.,MOIST_TRANS(I,K,J,P_QC)+RQCCUTEN(I,K,J)*DTCNVC)
+          END SELECT cps_select
+!
+          TCHANGE=DTDT*DTCNVC
+	  IF(ABS(TCHANGE)>DTEMP_CHECK)THEN
+            WRITE(message,*)'BIG T CHANGE BY CONVECTION=',TCHANGE             &
+                     ,' AT (',I,',',J,',',K,') FOR NTSD=',NTSD
+            CALL wrf_message(trim(message))
+	  ENDIF
+!
+        ENDDO
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!***  REFILL THE MOIST ARRAY.
+!-----------------------------------------------------------------------
+!
+      DO N=1,N_MOIST
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO J=JMS,JME
+        DO K=KMS,KME
+        DO I=IMS,IME
+          MOIST(I,J,K,N)=MOIST_TRANS(I,K,J,N)
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      DEALLOCATE(MOIST_TRANS,STAT=ISTAT)
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE CUCNVC
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST                          &
+     &                   ,DX,DY,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                            &
+     &                   ,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
+!   05-12-19  BLACK      - CONVERTED FROM IKJ TO IJK
+!
+! 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
+!
+      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,JMS:JME,KMS:KME),INTENT(IN) :: PINT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ACPREC,PREC
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CWM,Q    &
+     &                                                        ,T,TRAIN
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: F_ICE    &   !<--- Used only with physics (IKJ)
+     &                                                        ,F_RAIN   &
+     &                                                        ,F_RIMEF
+
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_MOIST)                   &
+     &                                           ,INTENT(INOUT) :: MOIST
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,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,IENDX,IJ,ISTAT,J,K,N
+!
+      INTEGER,DIMENSION(IMS:IME,JMS:JME) :: LOWLYR
+!
+      REAL :: CAPA,DPL,DTPHS,PCPCOL,PLYR,RDTPHS,RG,TNEW
+!
+      REAL,DIMENSION(KMS:KME-1) :: QL,TL
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME) :: CUBOT,CUTOP,PDSL               &
+     &                                  ,RAINNC,RAINNCV,XLAND
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: CWM_PHY,DZ             &
+     &                                          ,P8W,P_PHY,PI_PHY       &
+     &                                          ,RR,T_PHY,TH_PHY
+!
+      REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS
+      REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: SCALAR_TRANS
+!
+      LOGICAL :: E_BDY,F_QT,QT_PRESENT,WARM_RAIN
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      ALLOCATE(MOIST_TRANS(IMS:IME,KMS:KME,JMS:JME,N_MOIST),STAT=ISTAT)
+      ALLOCATE(SCALAR_TRANS(IMS:IME,KMS:KME,JMS:JME,N_SCALAR),STAT=ISTAT)
+!
+!-----------------------------------------------------------------------
+!***  TRANSPOSE THE MOIST ARRAY (IJK) FOR THE PHYSICS (IKJ).
+!-----------------------------------------------------------------------
+!
+      DO N=1,N_MOIST
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO K=KMS,KME
+        DO J=JMS,JME
+        DO I=IMS,IME
+          MOIST_TRANS(I,K,J,N)=MOIST(I,J,K,N)
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW.and.config_flags%mp_physics/=etamp_hwrf)THEN
+        DO N=1,N_SCALAR
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+          DO K=KMS,KME
+          DO J=JMS,JME
+          DO I=IMS,IME
+            SCALAR_TRANS(I,K,J,N)=SCALAR(I,J,K,N)
+          ENDDO
+          ENDDO
+          ENDDO
+        ENDDO
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!
+      IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW.or.config_flags%mp_physics==etamp_hwrf)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(i,j)
+      DO J=MYJS2,MYJE2
+      DO I=MYIS1,MYIE1
+!
+        PDSL(I,J)=PD(I,J)*RES(I,J)
+        P8W(I,KTE+1,J)=PT
+        LOWLYR(I,J)=KTS        !<----  The lowest model layer counted from the bottom.
+        XLAND(I,J)=SM(I,J)+1.
+!-----------------------------------------------------------------------
+!***  FILL RAINNC WITH ZERO (NORMALLY CONTAINS THE NONCONVECTIVE
+!***  ACCUMULATED RAIN BUT NOT YET USED BY NMM).
+!***  CAN BE OBTAINED FROM ACPREC AND CUPREC (ACPREC-CUPREC).
+!-----------------------------------------------------------------------
+        RAINNC(I,J)=0.
+!
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  FILL THE SINGLE-COLUMN INPUT
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(dpl,i,j,k,plyr,ql,tl)
+      DO J=MYJS2,MYJE2
+        DO K=KTS,KTE
+        DO I=MYIS1,MYIE1
+          DPL=DETA1(K)*PDTOP+DETA2(K)*PDSL(I,J)
+          QL(K)=MAX(Q(I,J,K),EPSQ)
+!!!       PLYR=AETA1(K)*PDTOP+AETA2(K)*PDSL(I,J)+PT
+          PLYR=(PINT(I,J,K)+PINT(I,J,K+1))*0.5
+          TL(K)=T(I,J,K)
+!
+          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,J,K+1)
+          P8W(I,K,J)=ETA1(K)*PDTOP+ETA2(K)*PDSL(I,J)+PT
+          P_PHY(I,K,J)=PLYR
+          DZ(I,K,J)=DPL*RG/RR(I,K,J)
+          CWM_PHY(I,K,J)=CWM(I,J,K)
+        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              &
+#ifdef WRF_CHEM
+     &                 ,CHEM_OPT=CONFIG_FLAGS%CHEM_OPT                  &
+     &                 ,PROGN=CONFIG_FLAGS%PROGN                        &
+#endif
+     &                 ,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_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV &
+     &                 ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC &
+     &                 ,QR_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QR),F_QR=F_QR &
+     &                 ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QI),F_QI=F_QI &
+     &                 ,QS_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS &
+     &                 ,QG_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG &
+     &                 ,QNI_CURR=SCALAR_TRANS(IMS,KMS,JMS,P_QNI),F_QNI=F_QNI  &
+     &                 ,QNR_CURR=SCALAR_TRANS(IMS,KMS,JMS,P_QNR),F_QNR=F_QNR  &
+     &                 ,QT_CURR=CWM_PHY,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        &
+     &                 ,ID=grid%id                                      &
+                                                                        )
+
+!$omp parallel do                                                       &
+!$omp& private(ij)
+      DO IJ=1,GRID%NUM_TILES
+        CALL MICROPHYSICS_ZERO_OUTA(                                    &
+                     MOIST_TRANS,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)
+!
+!-----------------------------------------------------------------------
+!***  UPDATE TEMPERATURE, SPECIFIC HUMIDITY, CLOUD WATER, AND HEATING.
+!-----------------------------------------------------------------------
+!$omp parallel do                                                       &
+!$omp& private(i,iendx,j,k,tnew)
+      DO K=KTS,KTE
+        DO J=MYJS2,MYJE2
+          IENDX=MYIE1
+          IF(E_BDY.AND.MOD(J,2)==0)IENDX=IENDX-1
+          DO I=MYIS1,IENDX
+            TNEW=TH_PHY(I,K,J)*PI_PHY(I,K,J)
+            TRAIN(I,J,K)=TRAIN(I,J,K)+(TNEW-T(I,J,K))*RDTPHS
+            T(I,J,K)=TNEW
+            Q(I,J,K)=MOIST_TRANS(I,K,J,P_QV)/(1.+MOIST_TRANS(I,K,J,P_QV))
+            CWM(I,J,K)=CWM_PHY(I,K,J)
+          ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  UPDATE PRECIPITATION.
+!***  NOTE: RAINNC IS ACCUMULATED INSIDE MICROPHYSICS BUT NMM ZEROES IT
+!***  OUT ABOVE SINCE IT IS ONLY A LOCAL ARRAY FOR NOW.
+!-----------------------------------------------------------------------
+!
+!$omp parallel do                                                       &
+!$omp& private(i,iendx,j,pcpcol)
+      DO J=MYJS2,MYJE2
+        IENDX=MYIE1
+        IF(E_BDY.AND.MOD(J,2)==0)IENDX=IENDX-1
+        DO I=MYIS1,IENDX
+          PCPCOL=RAINNCV(I,J)*1.E-3
+          PREC(I,J)=PREC(I,J)+PCPCOL
+          ACPREC(I,J)=ACPREC(I,J)+PCPCOL
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  REFILL THE MOIST ARRAY.
+!-----------------------------------------------------------------------
+!
+      DO N=1,N_MOIST
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+        DO J=JMS,JME
+        DO K=KMS,KME
+        DO I=IMS,IME
+          MOIST(I,J,K,N)=MOIST_TRANS(I,K,J,N)
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW.and.config_flags%mp_physics/=etamp_hwrf)THEN
+        DO N=1,N_SCALAR
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+          DO J=JMS,JME
+          DO K=KMS,KME
+          DO I=IMS,IME
+            SCALAR(I,J,K,N)=SCALAR_TRANS(I,K,J,N)
+          ENDDO
+          ENDDO
+          ENDDO
+        ENDDO
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!
+      DEALLOCATE(MOIST_TRANS,STAT=ISTAT)
+      DEALLOCATE(SCALAR_TRANS,STAT=ISTAT)
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE GSMDRIVE
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+      SUBROUTINE UPDATE_MOIST(MOIST,Q,CWM,F_ICE,F_RAIN,N_MOIST          &
+     &                       ,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                     &
+     &                     ,N_MOIST
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: CWM,Q
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: F_ICE       &   !<--- Used only with physics (IKJ)
+     &                                                     ,F_RAIN
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME,N_MOIST),INTENT(OUT) :: MOIST
+!
+!-----------------------------------------------------------------------
+!***  LOCAL VARIABLES
+!-----------------------------------------------------------------------
+!
+      INTEGER :: I,J,K
+!
+      REAL :: FICE,FRAIN,QI,QR,QW,WC
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+      DO J=MYJS,MYJE
+      DO I=MYIS,MYIE
+        MOIST(I,J,K,P_QV)=Q(I,J,K)/(1.-Q(I,J,K))
+        WC=CWM(I,J,K)
+        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,J,K,P_QC)=QW
+        MOIST(I,J,K,P_QR)=QR
+        MOIST(I,J,K,P_QI)=0.
+        MOIST(I,J,K,P_QS)=QI
+        MOIST(I,J,K,P_QG)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE UPDATE_MOIST
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+      END MODULE MODULE_PHYSICS_CALLS
+!
+!-------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_PRECIP_ADJUST.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_PRECIP_ADJUST.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_PRECIP_ADJUST.F	(revision 17)
@@ -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,1X,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,1X,I4,1X,F6.0,' IHR1,IHR2=' &
+      &   ,I1,1X,I1,' TPHS1,TPHS2=',F6.0,1X,F6.0,' FRACT1,FRACT2='        &
+      &   ,2(1X,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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_TIMERS.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_TIMERS.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_TIMERS.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_ZEROX.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_ZEROX.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_ZEROX.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_initialize_real.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_initialize_real.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_initialize_real.F	(revision 17)
@@ -0,0 +1,5240 @@
+!REAL:MODEL_LAYER:INITIALIZATION
+
+!  This MODULE holds the routines which are used to perform various initializations
+!  for individual domains utilizing the NMM dynamical core.
+
+!-----------------------------------------------------------------------
+
+MODULE module_initialize_real
+
+   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,                    ONLY : LOCAL_COMMUNICATOR       &
+                                           ,MYTASK,NTASKS,NTASKS_X   &
+                                           ,NTASKS_Y
+   USE module_comm_dm
+   USE module_ext_internal
+#endif
+
+   INTEGER :: internal_time_loop
+   INTEGER:: MPI_COMM_COMP,MYPE
+   INTEGER:: loopinc, iloopinc
+
+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 :: idum1, idum2
+
+      CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
+
+        CALL init_domain_nmm (grid &
+!
+#include <actual_new_args.inc>
+!
+      )
+
+   END SUBROUTINE init_domain
+
+!-------------------------------------------------------------------
+!---------------------------------------------------------------------
+   SUBROUTINE init_domain_nmm ( grid &
+!
+# include <dummy_new_args.inc>
+!
+   )
+
+      USE module_optional_input
+      IMPLICIT NONE
+
+      !  Input space and data.  No gridded meteorological data has been stored, though.
+
+!     TYPE (domain), POINTER :: grid
+      TYPE (domain)          :: grid
+
+# include <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                             ::                       &
+                                     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
+       logical :: test
+
+!              INTEGER :: DOMDESC
+              REAL,ALLOCATABLE    :: SICE_G(:,:), SM_G(:,:)
+              INTEGER, ALLOCATABLE::  IHE_G(:),IHW_G(:)
+              INTEGER, ALLOCATABLE::  ITEMP(:,:)
+              INTEGER :: my_e,my_n,my_s,my_w,my_ne,my_nw,my_se,my_sw,myi,myj,npe
+              INTEGER :: istat,inpes,jnpes
+#else
+        integer, allocatable:: ihw(:),ihe(:)
+#endif
+
+
+      CHARACTER (LEN=255) :: 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(:,:):: grid%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
+
+        REAL:: COAC, CODAMP
+
+        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
+#if defined(HWRF)
+        REAL, PARAMETER:: DDFC=1.0
+#else
+        REAL, PARAMETER:: DDFC=8.0
+#endif
+        REAL, PARAMETER:: TWOM=.00014584
+        REAL, PARAMETER:: CP=1004.6
+        REAL, PARAMETER:: DFC=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:: TG0=258.16
+        REAL, PARAMETER:: TGA=30.0
+    integer :: numzero,numexamined
+#ifdef HWRF
+!============================================================================
+!   gopal's doing for ocean coupling
+!============================================================================
+
+ REAL, DIMENSION(:,:),    ALLOCATABLE :: NHLAT,NHLON,NVLAT,NVLON,HRES_SM
+ REAL                                 :: NDLMD,NDPHD,NWBD,NSBD
+ INTEGER                              :: NIDE,NJDE,ILOC,JLOC
+
+      INTEGER fid, ierr, nprocs
+      CHARACTER*255 f65name, SysString
+
+!============================================================================
+! end gopal's doing for ocean coupling
+!============================================================================
+#endif
+
+        if (ALLOCATED(ADUM2D)) DEALLOCATE(ADUM2D)
+        if (ALLOCATED(TG_ALT)) DEALLOCATE(TG_ALT)
+
+!#define COPY_IN
+!#include <scalar_derefs.inc>
+#ifdef DM_PARALLEL
+#    include <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 ; ! 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
+
+#ifdef DM_PARALLEL
+      CALL WRF_GET_MYPROC(MYPE)
+      CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+      call wrf_get_nprocx(inpes)
+      call wrf_get_nprocy(jnpes)
+!
+      allocate(itemp(inpes,jnpes),stat=istat)
+      npe=0
+!
+      do j=1,jnpes
+      do i=1,inpes
+        itemp(i,j)=npe
+        if(npe==mype)then
+          myi=i
+          myj=j
+        endif
+        npe=npe+1
+      enddo
+      enddo
+!
+      my_n=-1
+      if(myj+1<=jnpes)my_n=itemp(myi,myj+1)
+!
+      my_e=-1
+      if(myi+1<=inpes)my_e=itemp(myi+1,myj)
+!
+      my_s=-1
+      if(myj-1>=1)my_s=itemp(myi,myj-1)
+!
+      my_w=-1
+      if(myi-1>=1)my_w=itemp(myi-1,myj)
+!
+      my_ne=-1
+      if((myi+1<=inpes).and.(myj+1<=jnpes)) &
+         my_ne=itemp(myi+1,myj+1)
+!
+      my_se=-1
+      if((myi+1<=inpes).and.(myj-1>=1)) &
+         my_se=itemp(myi+1,myj-1)
+!
+      my_sw=-1
+      if((myi-1>=1).and.(myj-1>=1)) &
+         my_sw=itemp(myi-1,myj-1)
+!
+      my_nw=-1
+      if((myi-1>=1).and.(myj+1<=jnpes)) &
+         my_nw=itemp(myi-1,myj+1)
+!
+!     my_neb(1)=my_n
+!     my_neb(2)=my_e
+!     my_neb(3)=my_s
+!     my_neb(4)=my_w
+!     my_neb(5)=my_ne
+!     my_neb(6)=my_se
+!     my_neb(7)=my_sw
+!     my_neb(8)=my_nw
+!
+      deallocate(itemp)
+#endif
+
+        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 )
+
+       IF ( CONFIG_FLAGS%FRACTIONAL_SEAICE == 1 ) THEN
+          CALL WRF_ERROR_FATAL("NMM cannot use FRACTIONAL_SEAICE = 1")
+       ENDIF
+
+      if ( config_flags%bl_pbl_physics == BOULACSCHEME ) then
+         call wrf_error_fatal("Cannot use BOULAC PBL with NMM")
+      endif
+
+        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')
+
+        grid%dlmd=config_flags%dx
+        grid%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 (grid%ght_gc(its,jts,num_metgrid_levels/2) .lt. grid%ght_gc(its,jts,num_metgrid_levels/2+1)) 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(grid%ght_gc, 2, num_metgrid_levels &
+     &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
+     &,                            IMS,IME,JMS,JME,KMS,KME        &
+     &,                            ITS,ITE,JTS,JTE,KTS,KTE )
+
+#if defined(HWRF)
+          if(.not. grid%use_prep_hybrid) then
+#endif
+
+           CALL reverse_vert_coord(grid%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(grid%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(grid%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(grid%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(grid%rh_gc, 2, num_metgrid_levels &
+     &,                            IDS,IDE,JDS,JDE,KDS,KDE        &
+     &,                            IMS,IME,JMS,JME,KMS,KME        &
+     &,                            ITS,ITE,JTS,JTE,KTS,KTE )
+
+#if defined(HWRF)
+          endif
+#endif
+
+        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 grid%ht_gc before adjust: ', minval(grid%ht_gc), maxval(grid%ht_gc)
+          CALL wrf_debug(100,message)
+          ICOUNT=0
+          DO J=JTS,min(JTE,JDE-1)
+           DO I=ITS,min(ITE,IDE-1)
+             IF ((grid%ht_gc(I,J) - grid%ght_gc(I,J,2)) .LT. -150.) THEN
+               grid%ht_gc(I,J)=grid%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 ((grid%ht_gc(I,J) - grid%ght_gc(I,J,2)) .GT. 150.) THEN
+               grid%ht_gc(I,J)=grid%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(grid%ht_gc), maxval(grid%ht_gc)
+          CALL wrf_debug(100,message)
+        ENDIF
+
+      CALL boundary_smooth(grid%ht_gc,grid%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 (grid%landmask(I,J) .gt. 0.5) grid%sm(I,J)=0.
+           if (grid%landmask(I,J) .le. 0.5) grid%sm(I,J)=1.
+        if (grid%tsk_gc(I,J) .gt. 0.) then
+           grid%nmm_tsk(I,J)=grid%tsk_gc(I,J)
+        else
+#if defined(HWRF)
+                if(grid%use_prep_hybrid) then
+                   if(grid%t(I,J,1)<100) then
+                      write(*,*) 'NO VALID SURFACE TEMPERATURE: I,J,TSK_GC(I,J),T(I,J,1) = ', &
+                           I,J,grid%TSK_GC(I,J),grid%T(I,J,1)
+                   else
+                      grid%nmm_tsk(I,J)=grid%t(I,J,1) ! stopgap measure
+                   end if
+                else
+#endif
+           grid%nmm_tsk(I,J)=grid%t_gc(I,J,1) ! stopgap measure
+#if defined(HWRF)
+                endif
+#endif
+        endif
+!
+           grid%glat(I,J)=grid%hlat_gc(I,J)*DEGRAD
+           grid%glon(I,J)=grid%hlon_gc(I,J)*DEGRAD
+           grid%weasd(I,J)=grid%snow(I,J)
+           grid%xice(I,J)=grid%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
+     grid%pt=p_top_requested
+
+        if (internal_time_loop .eq. 1) then
+
+        if (eta_levels(1) .ne. 1.0) then
+#if defined(HWRF)
+             if(grid%use_prep_hybrid) then
+                call wrf_error_fatal('PREP_HYBRID ERROR: eta_levels is not specified, but use_prep_hybrid=.true.')
+             end if
+#endif
+
+          write(message,*) '********************************************************************* '
+          CALL wrf_message(message)
+          write(message,*) '**  eta_levels appears not to be specified in the namelist'
+          CALL wrf_message(message)
+          write(message,*) '**  We will call compute_nmm_levels to define layer thicknesses.'
+          CALL wrf_message(message)
+          write(message,*) '**  These levels should be reasonable for running the model, '
+          CALL wrf_message(message)
+          write(message,*) '**  but may not be ideal for the simulation being made.  Consider   '
+          CALL wrf_message(message)
+          write(message,*) '**  defining your own levels by specifying eta_levels in the model   '
+          CALL wrf_message(message)
+          write(message,*) '**  namelist. '
+          CALL wrf_message(message)
+          write(message,*) '********************************************************************** '
+          CALL wrf_message(message)
+
+          CALL compute_nmm_levels(KDE,p_top_requested,eta_levels)
+
+          DO L=1,KDE
+            write(message,*) 'L, eta_levels(L) returned :: ', L,eta_levels(L)
+            CALL wrf_message(message)
+          ENDDO
+
+        endif
+
+        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, grid%pt,grid%pdtop, eta_levels, &
+                                      grid%eta1,grid%deta1,grid%aeta1,             &
+                                      grid%eta2,grid%deta2,grid%aeta2, grid%dfl, grid%dfrlg         )
+
+       DO L=KDS,KDE-1
+        grid%deta(L)=eta_levels(L)-eta_levels(L+1)
+       ENDDO
+        endif
+
+        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)
+           grid%fis(I,J)=grid%ht_gc(I,J)*g
+!
+!       IF ( grid%p_gc(I,J,1) .ne. 200100. .AND.  (grid%ht_gc(I,J) .eq. grid%ght_gc(I,J,1)) .AND. grid%ht_gc(I,J) .ne. 0) THEN
+        IF ( grid%p_gc(I,J,1) .ne. 200100. .AND.  (abs(grid%ht_gc(I,J)-grid%ght_gc(I,J,1)) .lt. 0.01) .AND. grid%ht_gc(I,J) .ne. 0) THEN
+          IF (mod(I,10) .eq. 0 .and. mod(J,10) .eq. 0) THEN
+            write(message,*) 'grid%ht_gc and grid%toposoil to swap, flag_soilhgt ::: ', &
+                          I,J, grid%ht_gc(I,J),grid%toposoil(I,J),flag_soilhgt
+            CALL wrf_debug(10,message)
+          ENDIF
+                IF ( ( flag_soilhgt.EQ. 1 ) ) THEN
+                 grid%ght_gc(I,J,1)=grid%toposoil(I,J)
+                ENDIF
+        ENDIF
+
+         ENDDO
+       ENDDO
+
+       numzero=0
+       numexamined=0
+       DO j = jts, MIN(jte,jde-1)
+          DO i = its, MIN(ite,ide-1)
+             numexamined=numexamined+1
+             if(grid%fis(i,j)<1e-5 .and. grid%fis(i,j)>-1e5 ) then
+                numzero=numzero+1
+             end if
+          enddo
+       enddo
+       write(message,*) 'TOTAL NEAR-ZERO FIS POINTS: ',numzero,' OF ',numexamined
+       call wrf_debug(10,message)
+#if defined(HWRF)
+       interp_notph: if(.not. grid%use_prep_hybrid) then
+#endif
+      if (.NOT. allocated(PDVP))     allocate(PDVP(IMS:IME,JMS:JME))
+      if (.NOT. allocated(P3D_OUT))  allocate(P3D_OUT(IMS:IME,JMS:JME,KDS:KDE-1))
+      if (.NOT. allocated(PSFC_OUTV)) allocate(PSFC_OUTV(IMS:IME,JMS:JME))
+      if (.NOT. allocated(P3DV_OUT)) allocate(P3DV_OUT(IMS:IME,JMS:JME,KDS:KDE-1))
+      if (.NOT. allocated(P3DV_IN))  allocate(P3DV_IN(IMS:IME,JMS:JME,num_metgrid_levels))
+
+      CALL compute_nmm_surfacep (grid%ht_gc, grid%ght_gc, grid%p_gc , grid%t_gc               &
+     &,                          grid%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
+
+       if (internal_time_loop .eq. 1) then
+
+       write(message,*) 'psfc points (final combined)'
+	loopinc=max( (JTE-JTS)/20,1)
+	iloopinc=max( (ITE-ITS)/10,1)
+       CALL wrf_message(message)
+       DO J=min(JTE,JDE-1),JTS,-loopinc
+         write(message,633) (grid%psfc_out(I,J)/100.,I=its,min(ite,IDE-1),iloopinc)
+         CALL wrf_message(message)
+       ENDDO
+       
+       endif
+
+  633   format(35(f5.0,1x))
+
+      CALL compute_3d_pressure (grid%psfc_out,grid%aeta1,grid%aeta2   &
+     &,            grid%pdtop,grid%pt,grid%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
+
+#ifdef DM_PARALLEL
+# include "HALO_NMM_MG3.inc"
+#endif
+
+       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*(grid%pd(I,J)+grid%pd(I+1,J))
+             PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J)+grid%psfc_out(I+1,J))
+           ELSEIF (J .eq. JDE-1 .and. I .lt. IDE-1) THEN ! N boundary
+             PDVP(I,J)=0.5*(grid%pd(I,J)+grid%pd(I+1,J))
+             PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J)+grid%psfc_out(I+1,J))
+           ELSEIF (I .eq. IDS .and. mod(J,2) .eq. 0) THEN ! W boundary
+             PDVP(I,J)=0.5*(grid%pd(I,J-1)+grid%pd(I,J+1))
+             PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J-1)+grid%psfc_out(I,J+1))
+           ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 0) THEN ! E boundary
+             PDVP(I,J)=0.5*(grid%pd(I,J-1)+grid%pd(I,J+1))
+             PSFC_OUTV(I,J)=0.5*(grid%psfc_out(I,J-1)+grid%psfc_out(I,J+1))
+           ELSEIF (I .eq. IDE-1 .and. mod(J,2) .eq. 1) THEN ! phantom E boundary
+             PDVP(I,J)=grid%pd(I,J)
+             PSFC_OUTV(I,J)=grid%psfc_out(I,J)
+           ELSEIF (mod(J,2) .eq. 0) THEN ! interior even row
+             PDVP(I,J)=0.25*(grid%pd(I,J)+grid%pd(I-1,J)+grid%pd(I,J+1)+grid%pd(I,J-1))
+             PSFC_OUTV(I,J)=0.25*(grid%psfc_out(I,J)+grid%psfc_out(I-1,J)+ &
+                                  grid%psfc_out(I,J+1)+grid%psfc_out(I,J-1))
+           ELSE ! interior odd row
+             PDVP(I,J)=0.25*(grid%pd(I,J)+grid%pd(I+1,J)+grid%pd(I,J+1)+grid%pd(I,J-1))
+             PSFC_OUTV(I,J)=0.25*(grid%psfc_out(I,J)+grid%psfc_out(I+1,J)+ &
+                                  grid%psfc_out(I,J+1)+grid%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*(grid%p_gc(I,J,K)+grid%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*(grid%p_gc(I,J,K)+grid%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*(grid%p_gc(I,J-1,K)+grid%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*(grid%p_gc(I,J-1,K)+grid%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)=grid%p_gc(I,J,K)
+           ELSEIF (mod(J,2) .eq. 0) THEN ! interior even row
+             P3DV_IN(I,J,K)=0.25*(grid%p_gc(I,J,K)+grid%p_gc(I-1,J,K) + &
+                                  grid%p_gc(I,J+1,K)+grid%p_gc(I,J-1,K))
+           ELSE ! interior odd row
+             P3DV_IN(I,J,K)=0.25*(grid%p_gc(I,J,K)+grid%p_gc(I+1,J,K) + &
+                                  grid%p_gc(I,J+1,K)+grid%p_gc(I,J-1,K))
+           ENDIF
+
+         enddo
+        enddo
+       enddo
+
+      CALL compute_3d_pressure (psfc_outv,grid%aeta1,grid%aeta2   &
+     &,            grid%pdtop,grid%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(grid%p_gc, p3d_out        &
+     &,            grid%t_gc, grid%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, internal_time_loop )
+
+
+      CALL interp_press2press_lin(p3dv_in, p3dv_out        &
+     &,            grid%u_gc, grid%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, internal_time_loop )
+
+      CALL interp_press2press_lin(p3dv_in, p3dv_out        &
+     &,            grid%v_gc, grid%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, internal_time_loop )
+
+       IF (hyb_coor) THEN
+       CALL wind_adjust(p3dv_in,p3dv_out,grid%u_gc,grid%v_gc,grid%u,grid%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,JMS:JME,num_metgrid_levels))
+         ALLOCATE(qtmp2(IMS:IME,JMS:JME,num_metgrid_levels))
+
+            CALL rh_to_mxrat (grid%rh_gc, grid%t_gc, grid%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,J,K)/(1.0+QTMP(I,J,K))
+         end do
+        end do
+       end do
+
+      CALL interp_press2press_log(grid%p_gc, p3d_out        &
+     &,            QTMP2, grid%q,num_metgrid_levels          &
+     &,            .FALSE.,.TRUE.                      &
+     &,            IDS,IDE,JDS,JDE,KDS,KDE             &
+     &,            IMS,IME,JMS,JME,KMS,KME             &
+     &,            ITS,ITE,JTS,JTE,KTS,KTE, internal_time_loop )
+
+      IF (ALLOCATED(QTMP)) DEALLOCATE(QTMP)
+      IF (ALLOCATED(QTMP)) DEALLOCATE(QTMP2)
+#if defined(HWRF)
+       else ! we are using prep_hybrid
+          ! Compute surface pressure:
+          grid%psfc_out=grid%pdtop+grid%pd
+       end if interp_notph
+#endif
+
+         !  Get the monthly values interpolated to the current date
+         !  for the traditional monthly
+         !  fields of green-ness fraction and background grid%albedo.
+
+        if (internal_time_loop .eq. 1 .or. config_flags%sst_update .eq. 1) then
+
+         CALL monthly_interp_to_date ( grid%greenfrac_gc , 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%albedo12m_gc , 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%greenfrac_gc , 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.
+              grid%vegfrc(I,J)=grid%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 (grid%albbck(i,j) .lt. 5.) then
+                  write(message,*) 'reset albedo to 8%...  I,J,albbck:: ', I,J,grid%albbck(I,J)
+                  CALL wrf_debug(10,message)
+                  grid%albbck(I,J)=8.
+              endif
+              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
+              grid%albase(i,j)=grid%albbck(i,j)
+              grid%mxsnal(i,j)=grid%snoalb(i,j)
+           END DO
+         END DO
+
+         endif
+
+#if defined(HWRF)
+       if(.not.grid%use_prep_hybrid) then
+#endif
+!  new deallocs
+        DEALLOCATE(p3d_out,p3dv_out,p3dv_in)
+#if defined(HWRF)
+       end if
+#endif
+
+     END IF     !   <----- END OF VERTICAL INTERPOLATION PART ---->
+
+
+!! compute SST at each time if updating SST
+        if (config_flags%sst_update == 1) then
+
+         DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+
+        if (grid%SM(I,J) .lt. 0.5) then
+            grid%SST(I,J)=0.
+        endif
+
+        if (grid%SM(I,J) .gt. 0.5) then
+            grid%SST(I,J)=grid%NMM_TSK(I,J)
+            grid%NMM_TSK(I,J)=0.
+        endif
+
+        IF ( (grid%NMM_TSK(I,J)+grid%SST(I,J)) .lt. 200. .or. &
+             (grid%NMM_TSK(I,J)+grid%SST(I,J)) .gt. 350. ) THEN
+          write(message,*) 'TSK, SST trouble at : ', I,J
+          CALL wrf_message(message)
+          write(message,*) 'SM, NMM_TSK,SST ', grid%SM(I,J),grid%NMM_TSK(I,J),grid%SST(I,J)
+          CALL wrf_message(message)
+        ENDIF
+
+            ENDDO
+         ENDDO
+
+        endif ! sst_update test
+
+        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(grid%sm(I,J).GT.0.9) THEN
+
+       IF (grid%xice(I,J) .gt. 0) then
+         grid%si(I,J)=1.0
+       ENDIF
+
+!  SEA
+              grid%epsr(I,J)=.97
+              grid%embck(I,J)=.97
+              grid%gffc(I,J)=0.
+              grid%albedo(I,J)=.06
+              grid%albase(I,J)=.06
+              IF(grid%si (I,J).GT.0.    ) THEN
+!  SEA-ICE
+                 grid%sm(I,J)=0.
+                 grid%si(I,J)=0.
+                 grid%sice(I,J)=1.
+                 grid%gffc(I,J)=0. ! just leave zero as irrelevant
+                 grid%albedo(I,J)=.60
+                 grid%albase(I,J)=.60
+              ENDIF
+           ELSE
+
+        grid%si(I,J)=5.0*grid%weasd(I,J)/1000.
+! LAND
+        grid%epsr(I,J)=1.0
+        grid%embck(I,J)=1.0
+        grid%gffc(I,J)=0.0 ! just leave zero as irrelevant
+        grid%sice(I,J)=0.
+        grid%sno(I,J)=grid%si(I,J)*.20
+           ENDIF
+        ENDDO
+        ENDDO
+
+! DETERMINE grid%albedo OVER LAND
+       DO j = jts, MIN(jte,jde-1)
+         DO i = its, MIN(ite,ide-1)
+          IF(grid%sm(I,J).LT.0.9.AND.grid%sice(I,J).LT.0.9) THEN
+! SNOWFREE albedo
+            IF ( (grid%sno(I,J) .EQ. 0.0) .OR. &
+                (grid%albase(I,J) .GE. grid%mxsnal(I,J) ) ) THEN
+              grid%albedo(I,J) = grid%albase(I,J)
+            ELSE
+! MODIFY albedo IF SNOWCOVER:
+! BELOW SNOWDEPTH THRESHOLD...
+              IF (grid%sno(I,J) .LT. SNUP) THEN
+                RSNOW = grid%sno(I,J)/SNUP
+                SNOFAC = 1. - ( EXP(-SALP*RSNOW) - RSNOW*EXP(-SALP))
+! ABOVE SNOWDEPTH THRESHOLD...
+              ELSE
+                SNOFAC = 1.0
+              ENDIF
+! CALCULATE grid%albedo ACCOUNTING FOR SNOWDEPTH AND VGFRCK
+              grid%albedo(I,J) = grid%albase(I,J) &
+               + (1.0-grid%vegfra(I,J))*SNOFAC*(grid%mxsnal(I,J)-grid%albase(I,J))
+            ENDIF
+          END IF
+          grid%si(I,J)=5.0*grid%weasd(I,J)
+          grid%sno(I,J)=grid%weasd(I,J)
+
+!!  convert vegfra
+          grid%vegfra(I,J)=grid%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( grid%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( grid%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, grid%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,grid%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
+#if defined(HWRF)
+          ! SM_G is still needed for the high-res grid
+#else
+          DEALLOCATE(SM_G)
+#endif
+          deallocate(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) (grid%sice(I,J),I=ITS,ITE,ITE/20)
+!          CALL wrf_debug(100,message)
+!        END DO
+
+#else
+! serial sea ice reprocessing
+        allocate(IHE(JDS:JDE-1),IHW(JDS:JDE-1))
+
+       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 (grid%sm(I,J) .gt. 0.9) THEN
+          SEAICESUM=grid%sice(I+IHE(J),J+1)+grid%sice(I+IHW(J),J+1)+ &
+                  grid%sice(I+IHE(J),J-1)+grid%sice(I+IHW(J),J-1)
+          IF (SEAICESUM .ge. 1. .and. SEAICESUM .lt. 3.) THEN
+            IF ((grid%sice(I+IHE(J),J+1).lt.0.1 .and. grid%sm(I+IHE(J),J+1).lt.0.1) .OR. &
+                (grid%sice(I+IHW(J),J+1).lt.0.1 .and. grid%sm(I+IHW(J),J+1).lt.0.1) .OR. &
+                (grid%sice(I+IHE(J),J-1).lt.0.1 .and. grid%sm(I+IHE(J),J-1).lt.0.1) .OR. &
+                (grid%sice(I+IHW(J),J-1).lt.0.1 .and. grid%sm(I+IHW(J),J-1).lt.0.1)) THEN
+
+!       HAVE SEA ICE AND A SURROUNDING LAND POINT - CONVERT TO SEA ICE
+              grid%sice(I,J)=1.0
+              grid%sm(I,J)=0.
+            ENDIF
+          ELSEIF (SEAICESUM .ge. 3) THEN
+!       WATER POINT SURROUNDED BY ICE  - CONVERT TO SEA ICE
+        grid%sice(I,J)=1.0
+        grid%sm(I,J)=0.
+          ENDIF
+        ENDIF
+
+        ENDDO
+       ENDDO
+      ENDDO
+
+        DEALLOCATE(IHE,IHW)
+#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 (grid%sm(I,J) .gt. 0.5) THEN
+                grid%landmask(I,J)=0.0
+          ELSEIF (grid%sm(I,J) .lt. 0.5 .and. grid%sice(I,J) .gt. 0.9) then
+                grid%landmask(I,J)=0.0
+          ELSEIF (grid%sm(I,J) .lt. 0.5 .and. grid%sice(I,J) .lt. 0.1) then
+                grid%landmask(I,J)=1.0
+          ELSE
+                write(message,*) 'missed point in grid%landmask definition ' , I,J
+                CALL wrf_message(message)
+                grid%landmask(I,J)=0.0
+          ENDIF
+!
+        IF (grid%sice(I,J) .gt. 0.5 .and. grid%nmm_tsk(I,J) .lt. 0.1 .and. grid%sst(I,J) .gt. 0.) THEN
+           write(message,*) 'set grid%nmm_tsk to: ', grid%sst(I,J)
+           CALL wrf_message(message)
+           grid%nmm_tsk(I,J)=grid%sst(I,J)
+           grid%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)
+               grid%soiltb(i,j) = grid%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)=grid%fis(I,J)/9.81
+          END DO
+        END DO
+
+!       if (maxval(grid%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 ( grid%soiltb , 2 , &
+!                       grid%nmm_tsk , ht , grid%toposoil , grid%landmask, flag_toposoil , &
+!                       grid%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
+         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_gc , DIM=3 )
+         num_soil_top_cat = SIZE ( grid%soilctop_gc , DIM=3 )
+         num_soil_bot_cat = SIZE ( grid%soilcbot_gc , DIM=3 )
+
+        do J=JMS,JME
+        do K=1,num_veg_cat
+        do I=IMS,IME
+           grid%landusef(I,K,J)=grid%landusef_gc(I,J,K)
+        enddo
+        enddo
+        enddo
+
+        do J=JMS,JME
+        do K=1,num_soil_top_cat
+        do I=IMS,IME
+           grid%soilctop(I,K,J)=grid%soilctop_gc(I,J,K)
+        enddo
+        enddo
+        enddo
+
+        do J=JMS,JME
+        do K=1,num_soil_bot_cat
+        do I=IMS,IME
+           grid%soilcbot(I,K,J)=grid%soilcbot_gc(I,J,K)
+        enddo
+        enddo
+        enddo
+
+!       grid%sm (1=water, 0=land)
+!       grid%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) (grid%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 ( 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) )
+
+         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
+
+       ENDIF
+
+        DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+
+        IF (grid%sice(I,J) .lt. 0.1) THEN
+          IF (grid%landmask(I,J) .gt. 0.5 .and. grid%sm(I,J) .gt. 0.5) THEN
+                write(message,*) 'land mask and grid%sm both > 0.5: ', &
+                                           I,J,grid%landmask(I,J),grid%sm(I,J)
+                CALL wrf_message(message)
+                grid%sm(I,J)=0.
+          ELSEIF (grid%landmask(I,J) .lt. 0.5 .and. grid%sm(I,J) .lt. 0.5) THEN
+                write(message,*) 'land mask and grid%sm both < 0.5: ', &
+                                           I,J, grid%landmask(I,J),grid%sm(I,J)
+                CALL wrf_message(message)
+                grid%sm(I,J)=1.
+          ENDIF
+        ELSE
+          IF (grid%landmask(I,J) .gt. 0.5 .and. grid%sm(I,J)+grid%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 (grid%sice(I,J) .gt. 0.9) then
+        grid%isltyp(I,J)=16
+        grid%ivgtyp(I,J)=24
+        endif
+
+            ENDDO
+         ENDDO
+
+         DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+
+        if (grid%sm(I,J) .lt. 0.5) then
+            grid%sst(I,J)=0.
+        endif
+
+        if (grid%sm(I,J) .gt. 0.5) then
+          if (grid%sst(I,J) .lt. 0.1) then
+            grid%sst(I,J)=grid%nmm_tsk(I,J)
+          endif
+            grid%nmm_tsk(I,J)=0.
+        endif
+
+        IF ( (grid%nmm_tsk(I,J)+grid%sst(I,J)) .lt. 200. .or. &
+             (grid%nmm_tsk(I,J)+grid%sst(I,J)) .gt. 350. ) THEN
+          write(message,*) 'TSK, sst trouble at : ', I,J
+          CALL wrf_message(message)
+          write(message,*) 'sm, nmm_tsk,sst ', grid%sm(I,J),grid%nmm_tsk(I,J),grid%sst(I,J)
+          CALL wrf_message(message)
+        ENDIF
+
+            ENDDO
+         ENDDO
+
+        write(message,*) 'grid%sm'
+        CALL wrf_message(message)
+
+        DO J=min(jde-1,jte),jts,-((jte-jts)/15+1)
+          write(message,635) (grid%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) (grid%sst(I,J)+grid%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 ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN
+                  grid%soiltb(i,j) = grid%sst(i,j)
+               ELSE IF (  grid%landmask(i,j) .GT. 0.5 ) THEN
+                  grid%soiltb(i,j) = grid%nmm_tsk(i,j)
+               END IF
+            END DO
+         END DO
+
+!      END IF
+
+   !  Land use categories, dominant soil and vegetation types (if available).
+
+!       allocate(grid%lu_index(ims:ime,jms:jme))
+
+          DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+               grid%lu_index(i,j) = grid%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)*grid%dlmd)
+      WB= WBD*DTR
+      SBD=-(((jde-1)/2)*grid%dphd)
+      SB= SBD*DTR
+      DLM=grid%dlmd*DTR
+      DPH=grid%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)
+             grid%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)
+             TERM1=MIN(TERM1,1.0D0)
+             TERM1=MAX(TERM1,-1.0D0)
+             APH=ASIN(TERM1)
+             TG_ALT(I,J)=TG0+TGA*COS(APH)-grid%fis(I,J)/3333.
+           ENDDO
+         ENDDO
+
+            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%sice(I,J) .eq. 0. ) THEN
+!                     grid%tg(i,j) = grid%sst(i,j)
+!                   ELSEIF (grid%sice(I,J) .eq. 1) THEN
+!                     grid%tg(i,j) = 271.16
+!                   END IF
+
+        if (grid%tg(I,J) .lt. 200.) then   ! only use default TG_ALT definition if
+                                      ! not getting TGROUND from grid%si
+                grid%tg(I,J)=TG_ALT(I,J)
+        endif
+
+       if (grid%tg(I,J) .lt. 200. .or. grid%tg(I,J) .gt. 320.) then
+               write(message,*) 'problematic grid%tg point at : ', I,J
+               CALL wrf_message( message )
+       endif
+
+        adum2d(i,j)=grid%nmm_tsk(I,J)+grid%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, grid%tg , &
+     grid%landmask, grid%sst, &
+     st_input, sm_input, sw_input, &
+     st_levels_input , sm_levels_input , &
+     sw_levels_input , &
+     grid%sldpth , grid%dzsoil , grid%stc , grid%smc , 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 )
+
+! =============================================================
+
+!  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 )
+                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%stc(i,1,j) .gt. 200) .and. &
+                            (grid%stc(i,1,j) .lt. 400) .and. (grid%smc(i,1,j) .lt. 0.005)) then
+                            write(message,*) 'Noah > Noah: bad soil moisture at i,j = ',i,j,grid%smc(i,:,j)
+                            CALL wrf_message(message)
+                            iicount = iicount + 1
+                            grid%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)
+                         grid%smc(i,:,j) = grid%smc(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%stc(i,1,j) .gt. 200) .and. &
+                            (grid%stc(i,1,j) .lt. 400) .and. (grid%smc(i,1,j) .lt. 0.004)) then
+                            write(message,*) 'RUC -> Noah: bad soil moisture at i,j = ' &
+                                                                     ,i,j,grid%smc(i,:,j)
+                            CALL wrf_message(message)
+                            iicount = iicount + 1
+                            grid%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)
+                         grid%smc(i,:,j) = MAX ( grid%smc(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
+
+!!!     zero out grid%nmm_tsk at water points again
+
+         DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+        if (grid%sm(I,J) .gt. 0.5) then
+            grid%nmm_tsk(I,J)=0.
+        endif
+            END DO
+         END DO
+
+!!      check on grid%stc
+
+          DO j = jts, MIN(jde-1,jte)
+            DO i = its, MIN(ide-1,ite)
+
+        IF (grid%sice(I,J) .gt. 0.9) then
+          DO L = 1, grid%num_soil_layers
+            grid%stc(I,L,J)=271.16    ! grid%tg value used by Eta/NMM
+          END DO
+        END IF
+
+        IF (grid%sm(I,J) .gt. 0.9) then
+          DO L = 1, grid%num_soil_layers
+            grid%stc(I,L,J)=273.16    ! grid%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 (grid%sm(I,J) .lt. 0.1 .and. grid%stc(I,1,J) .lt. 0.1) THEN
+          write(message,*) 'troublesome grid%sm,grid%stc,grid%smc value: ', I,J,grid%sm(I,J), grid%stc(I,1,J),grid%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
+
+        grid%stc(I,L,J)=amax1(grid%stc(I,L,J),grid%stc(II,L,JJ))
+        cur_smc=grid%smc(I,L,J)
+
+        if ( grid%smc(II,L,JJ) .gt. 0.005 .and. grid%smc(II,L,JJ) .lt. 1.0) then
+		aposs_smc=grid%smc(II,L,JJ)
+
+        if ( cur_smc .eq. 0 ) then
+                cur_smc=aposs_smc
+                grid%smc(I,L,J)=cur_smc
+        else
+                cur_smc=amin1(cur_smc,aposs_smc)
+                cur_smc=amin1(cur_smc,aposs_smc)
+                grid%smc(I,L,J)=cur_smc
+        endif
+	endif
+
+	endif ! bounds check
+
+        enddo
+        enddo
+        enddo
+        write(message,*) 'grid%stc, grid%smc(1) now: ',  grid%stc(I,1,J),grid%smc(I,1,J)
+        CALL wrf_message(message)
+        endif
+
+        if (grid%stc(I,1,J) .lt. 0.1) then
+          write(message,*) 'QUITTING DUE TO STILL troublesome grid%stc value: ', I,J, grid%stc(I,1,J),grid%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
+
+!       grid%sldpth=0.
+!       grid%sldpth(1)=0.1
+!       grid%sldpth(2)=0.3
+!       grid%sldpth(3)=0.6
+!       grid%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)
+         grid%res(I,J)=1.
+        enddo
+        enddo
+
+!! grid%hbm2
+
+        grid%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
+       grid%hbm2(I,J)=1.
+        ENDIF
+       enddo
+       enddo
+
+!! grid%hbm3
+        grid%hbm3=0.
+
+!!      LOOP OVER LOCAL DIMENSIONS
+
+       do J=jts,min(jte,jde-1)
+          grid%ihwg(J)=mod(J+1,2)-1
+          IF (J .ge. 4 .and. J .le. (jde-1)-3) THEN
+            IHL=(ids+1)-grid%ihwg(J)
+            IHH=(ide-1)-2
+            do I=its,min(ite,ide-1)
+              IF (I .ge. IHL  .and. I .le. IHH) grid%hbm3(I,J)=1.
+            enddo
+          ENDIF
+        enddo
+
+!! grid%vbm2
+
+       grid%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
+
+           grid%vbm2(I,J)=1.
+
+        ENDIF
+
+       enddo
+       enddo
+
+!! grid%vbm3
+
+        grid%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
+         grid%vbm3(I,J)=1.
+        ENDIF
+
+       enddo
+       enddo
+
+      COAC=model_config_rec%coac(grid%id)
+      CODAMP=model_config_rec%codamp(grid%id)
+
+      DTAD=1.0
+!       IDTCF=DTCF, IDTCF=4
+      DTCF=4.0 ! used?
+
+      grid%dy_nmm=ERAD*DPH
+      grid%cpgfv=-GRID%DT/(48.*grid%dy_nmm)
+      grid%en= GRID%DT/( 4.*grid%dy_nmm)*DTAD
+      grid%ent=GRID%DT/(16.*grid%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+grid%dy_nmm**2)/ &
+                   (GRID%DT*32.*DXP*grid%dy_nmm)
+
+         CPGFUJ(J)=-GRID%DT/(48.*DXP)
+         CURVJ(J)=.5*GRID%DT*TAN(TPH)/ERAD
+         FCPJ(J)=GRID%DT/(CP*192.*DXP*grid%dy_nmm)
+         FDIVJ(J)=1./(12.*DXP*grid%dy_nmm)
+!         EMJ(J)= GRID%DT/( 4.*DXP)*DTAD
+!         EMTJ(J)=GRID%DT/(16.*DXP)*DTAD
+         FADJ(J)=-GRID%DT/(48.*DXP*grid%dy_nmm)*DTAD
+         ACDT=GRID%DT*SQRT((ERAD*DLM*AMIN1(COS(ANBI),COS(SBI)))**2+grid%dy_nmm**2)
+         CDDAMP=CODAMP*ACDT
+         HDACJ(J)=COAC*ACDT/(4.*DXP*grid%dy_nmm)
+         DDMPUJ(J)=CDDAMP/DXP
+         DDMPVJ(J)=CDDAMP/grid%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))
+             grid%f(I,J)=0.5*GRID%DT*FP
+
+           ENDDO
+          ENDDO
+
+! --------------DERIVED VERTICAL GRID CONSTANTS--------------------------
+
+      grid%ef4t=.5*GRID%DT/CP
+      grid%f4q =   -GRID%DT*DTAD
+      grid%f4d =-.5*GRID%DT*DTAD
+
+       DO L=KDS,KDE-1
+        grid%rdeta(L)=1./grid%deta(L)
+        grid%f4q2(L)=-.25*GRID%DT*DTAD/grid%deta(L)
+       ENDDO
+
+        DO J=JTS,min(JTE,JDE-1)
+        DO I=ITS,min(ITE,IDE-1)
+          grid%dx_nmm(I,J)=DXJ(J)
+          grid%wpdar(I,J)=WPDARJ(J)*grid%hbm2(I,J)
+          grid%cpgfu(I,J)=CPGFUJ(J)*grid%vbm2(I,J)
+          grid%curv(I,J)=CURVJ(J)*grid%vbm2(I,J)
+          grid%fcp(I,J)=FCPJ(J)*grid%hbm2(I,J)
+          grid%fdiv(I,J)=FDIVJ(J)*grid%hbm2(I,J)
+          grid%fad(I,J)=FADJ(J)
+          grid%hdacv(I,J)=HDACJ(J)*grid%vbm2(I,J)
+          grid%hdac(I,J)=HDACJ(J)*1.25*grid%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
+                   grid%hdac(I,J)=grid%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
+                    grid%hdac(I,J)=grid%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
+                   grid%hdac(I,J)=grid%hdac(I,J)* DFC
+                 ENDIF
+               ENDDO
+        ENDIF
+      ENDDO
+
+      DO J=JTS,min(JTE,JDE-1)
+      DO I=ITS,min(ITE,IDE-1)
+        grid%ddmpu(I,J)=DDMPUJ(J)*grid%vbm2(I,J)
+        grid%ddmpv(I,J)=DDMPVJ(J)*grid%vbm2(I,J)
+        grid%hdacv(I,J)=grid%hdacv(I,J)*grid%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
+             grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC
+             grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC
+             grid%hdacv(I,J)=grid%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
+            grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC
+            grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC
+            grid%hdacv(I,J)=grid%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
+            grid%ddmpu(I,J)=grid%ddmpu(I,J)*DDFC
+            grid%ddmpv(I,J)=grid%ddmpv(I,J)*DDFC
+            grid%hdacv(I,J)=grid%hdacv(I,J)* DFC
+           ENDIF
+          ENDDO
+        ENDIF
+      ENDDO
+
+        write(message,*) 'grid%stc(1)'
+        CALL wrf_message(message)
+        DO J=min(jde-1,jte),jts,-((jte-jts)/15+1)
+          write(message,635) (grid%stc(I,1,J),I=its,min(ite,ide-1),(ite-its)/12+1)
+          CALL wrf_message(message)
+        ENDDO
+
+        write(message,*) 'grid%smc(1)'
+        CALL wrf_message(message)
+        DO J=min(jde-1,jte),jts,-((jte-jts)/15+1)
+          write(message,635) (grid%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 (grid%sm(I,J) .lt. 0.1 .and. grid%smc(I,1,J) .gt. 0.5 .and. grid%sice(I,J) .lt. 0.1) then
+            write(message,*) 'very moist on land point: ', I,J,grid%smc(I,1,J)
+            CALL wrf_debug(10,message)
+          endif
+
+          enddo
+        enddo
+
+!!!   compute grid%emt, grid%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      grid%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      grid%emt(JA)=EMTJ(J)
+          DO 163 J=6,(JDE-1)-5
+          JA=JA+1
+          KHLA(JA)=2
+          KHHA(JA)=2+MOD(J,2)
+ 163      grid%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      grid%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      grid%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      grid%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      grid%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      grid%em(JA)=EMJ(J)
+
+   696  continue
+        ENDIF ! wrf_dm_on_monitor/serial job
+
+      call NMM_SH2O(IMS,IME,JMS,JME,ITS,NNXP,JTS,NNYP,grid%num_soil_layers,grid%isltyp, &
+                             grid%sm,grid%sice,grid%stc,grid%smc,grid%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
+                grid%u(IDE-1,J,K)=0.
+                grid%v(IDE-1,J,K)=0.
+              ENDIF
+            ENDDO
+          ENDDO
+        ENDIF
+
+  969   continue
+
+         DO j = jms, jme
+            DO i = ims, ime
+             fisx=max(grid%fis(i,j),0.)
+             grid%z0(I,J)    =grid%sm(I,J)*Z0SEA+(1.-grid%sm(I,J))*                      &
+     &                (0.*Z0MAX+FISx    *FCM+Z0LAND)
+            ENDDO
+          ENDDO
+
+        write(message,*) 'grid%z0 over memory, leaving module_initialize_real'
+        CALL wrf_message(message)
+        DO J=JME,JMS,-((JME-JMS)/20+1)
+          write(message,635) (grid%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) )
+#ifdef HWRF
+!=========================================================================================
+!   gopal's doing for ocean coupling. Produce a high resolution grid for the entire domain
+!=========================================================================================
+
+    if(internal_time_loop.eq.1) then      !Kwon's doing
+
+     NDLMD=grid%dlmd/3.
+     NDPHD=grid%dphd/3.
+     NIDE=3*(IDE-1)-2
+     NJDE=3*(JDE-1)-2
+     ILOC=1
+     JLOC=1
+     NWBD= WBD  ! + (ILOC -1)*2.*grid%dlmd + MOD(JLOC+1,2)*grid%dlmd
+     NSBD= SBD  ! + (JLOC -1)*grid%dphd
+
+     ALLOCATE (NHLAT(NIDE,NJDE))
+     ALLOCATE (NHLON(NIDE,NJDE))
+     ALLOCATE (NVLAT(NIDE,NJDE))
+     ALLOCATE (NVLON(NIDE,NJDE))
+     ALLOCATE (HRES_SM(NIDE,NJDE))
+
+#if defined(DM_PARALLEL)
+       if(wrf_dm_on_monitor()) then
+          ! Only the monitor process does the actual work (kinda
+          ! stupid; should be parallelized, but it's better than
+          ! writing garbage like it did before with >1 process)
+
+          ! Get high-res lat & lon:
+     CALL EARTH_LATLON_hwrf (  NHLAT,NHLON,NVLAT,NVLON,  &    ! rotated lat,lon at H and V points
+                          NDLMD,NDPHD,NWBD,NSBD,    &
+                          tph0d,tlm0d,              &
+                          1,NIDE,1,NJDE,1,1,        &
+                          1,NIDE,1,NJDE,1,1,        &
+                          1,NIDE,1,NJDE,1,1         )
+
+          ! Interpolate landmask to high-res grid:
+          CALL G2T2H_hwrf ( SM_G,HRES_SM,   & ! output grid index and weights
+                  NHLAT,NHLON,                 & ! target (hres) input lat lon in degrees
+                  grid%DLMD,grid%DPHD,WBD,SBD,           & ! parent res, west and south boundaries
+                  tph0d,tlm0d,                 & ! parent central lat,lon, all in degrees
+               IDE,JDE,IDS,IDE,JDS,JDE,     & ! parent imax and jmax, ime,jme
+                  1,NIDE,1,NJDE,1,1,           &
+                  1,NIDE,1,NJDE,1,1,           &
+                  1,NIDE,1,NJDE,1,1            )
+
+          ! We're done with the low-res sm grid now:
+          deallocate(SM_G)
+
+          ! Write out high-res grid for coupler:
+         WRITE(65)NHLAT(1:NIDE,1:NJDE)
+         WRITE(65)NHLON(1:NIDE,1:NJDE)
+         WRITE(65)NVLAT(1:NIDE,1:NJDE)
+         WRITE(65)NVLON(1:NIDE,1:NJDE)
+         WRITE(65)HRES_SM(1:NIDE,1:NJDE)
+      endif
+#else
+       ! This code is the same as above, but for the non-mpi version:
+       CALL EARTH_LATLON_hwrf (  NHLAT,NHLON,NVLAT,NVLON,  &    ! rotated lat,lon at H and V points
+            NDLMD,NDPHD,NWBD,NSBD,    &
+            tph0d,tlm0d,              &
+            1,NIDE,1,NJDE,1,1,        &
+            1,NIDE,1,NJDE,1,1,        &
+            1,NIDE,1,NJDE,1,1         )
+       CALL G2T2H_hwrf ( grid%SM,HRES_SM,                  & ! output grid index and weights
+            NHLAT,NHLON,                 & ! target (hres) input lat lon in degrees
+            grid%DLMD,grid%DPHD,WBD,SBD,           & ! parent res, west and south boundaries
+            tph0d,tlm0d,                 & ! parent central lat,lon, all in degrees
+            IDE,JDE,IMS,IME,JMS,JME,     & ! parent imax and jmax, ime,jme
+            1,NIDE,1,NJDE,1,1,           &
+            1,NIDE,1,NJDE,1,1,           &
+            1,NIDE,1,NJDE,1,1            )
+
+         WRITE(65)NHLAT(1:NIDE,1:NJDE)
+         WRITE(65)NHLON(1:NIDE,1:NJDE)
+         WRITE(65)NVLAT(1:NIDE,1:NJDE)
+         WRITE(65)NVLON(1:NIDE,1:NJDE)
+         WRITE(65)HRES_SM(1:NIDE,1:NJDE)
+#endif
+
+     DEALLOCATE (NHLAT)
+     DEALLOCATE (NHLON)
+     DEALLOCATE (NVLAT)
+     DEALLOCATE (NVLON)
+     DEALLOCATE (HRES_SM)
+
+     endif                 !Kwon's doing
+
+!==================================================================================
+!   end gopal's doing for ocean coupling.
+!==================================================================================
+#endif
+
+!#define COPY_OUT
+!#include <scalar_derefs.inc>
+      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=255)    :: 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)
+
+       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=255) :: 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. 50000. .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. 108000.) 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. 108000.) THEN
+                write(message,*) 'bad dum2d(grid%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)
+
+!        DO J=min(JTE,JDE-1),JTS,-loopinc
+!          write(message,633) (dum2d(I,J)/100.,I=ITS,min(ITE,IDE-1),iloopinc)
+!          CALL wrf_message(message)
+!        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. 108000.) THEN
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+
+          IF (DEFINED_PSFC(I,J) .AND. dum2d(I,J) .lt. 50000. ) THEN
+            IF (TERRAIN_HGT_T(I,J) .gt. 4500.) THEN
+              WRITE(message,*) 'low surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J)
+              CALL wrf_debug(2,message)
+            ELSE
+              CALL wrf_error_fatal("quit due to unrealistic surface pressure")
+            ENDIF
+          ENDIF
+
+          IF (DEFINED_PSFC(I,J) .AND. dum2d(I,J) .gt. 108000. ) THEN
+            IF (TERRAIN_HGT_T(I,J) .lt. -10.) THEN
+              WRITE(message,*) 'high surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J)
+              CALL wrf_debug(2,message)
+            ELSE
+              CALL wrf_error_fatal("quit due to unrealistic surface pressure")
+            ENDIF
+          ENDIF
+
+         END DO
+        END DO
+
+
+
+!! "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)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+
+          IF (DEFINED_PSFCB(I,J) .AND. dum2db(I,J) .lt. 50000. ) THEN
+            IF (TERRAIN_HGT_T(I,J) .gt. 4500.) THEN
+              WRITE(message,*) 'low surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J)
+              CALL wrf_debug(2,message)
+            ELSE
+              CALL wrf_error_fatal("quit due to unrealistic surface pressure")
+            ENDIF
+          ENDIF
+
+          IF (DEFINED_PSFCB(I,J) .AND. dum2db(I,J) .gt. 108000. ) THEN
+            IF (TERRAIN_HGT_T(I,J) .lt. -10.) THEN
+              WRITE(message,*) 'high surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J)
+              CALL wrf_debug(2,message)
+            ELSE
+              CALL wrf_error_fatal("quit due to unrealistic surface pressure")
+            ENDIF
+          ENDIF
+
+!          IF (DEFINED_PSFCB(I,J) .AND. ( dum2db(I,J) .lt. 50000. .OR. dum2db(I,J) .gt. 108000. )) THEN
+!          IF (TERRAIN_HGT_T(I,J) .gt. -10. .and. TERRAIN_HGT_T(I,J) .lt. 5000.) THEN
+!            write(0,*) 'I,J, terrain_hgt_t, dum2db: ', I,J, terrain_hgt_t(I,J),dum2db(I,J)
+!	    CALL wrf_error_fatal("quit due to unrealistic surface pressure")
+!          ELSE
+!            WRITE(message,*) 'surface pressure allowed because surface height is extreme value of: ', TERRAIN_HGT_T(I,J)
+!            CALL wrf_debug(2,message)
+!          ENDIF
+!          ENDIF
+
+         ENDDO
+        ENDDO
+
+!!!!! 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. ) THEN
+            IF (TERRAIN_HGT_T(I,J) .gt. 4500.) THEN
+              WRITE(message,*) 'low surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J)
+              CALL wrf_debug(2,message)
+            ELSE
+	      write(message,*) 'possibly bad combo on psfc_out: ', I,J, psfc_out(I,J)
+              CALL wrf_debug(2,message)
+	      write(message,*) 'DEFINED_PSFC, dum2d: ', DEFINED_PSFC(I,J),dum2d(I,J)
+              CALL wrf_debug(2,message)
+	      write(message,*) 'DEFINED_PSFCB, DUM2DB: ', DEFINED_PSFCB(I,J),DUM2DB(I,J)
+              CALL wrf_debug(2,message)
+              CALL wrf_error_fatal("quit due to unrealistic surface pressure")
+            ENDIF
+          ENDIF
+
+          IF (psfc_out(I,J) .gt. 108000. ) THEN
+            IF (TERRAIN_HGT_T(I,J) .lt. -10.) THEN
+              WRITE(message,*) 'high surface pressure allowed because surface height is: ', TERRAIN_HGT_T(I,J)
+              CALL wrf_debug(2,message)
+            ELSE
+	      write(message,*) 'possibly bad combo on psfc_out: ', I,J, psfc_out(I,J)
+              CALL wrf_debug(2,message)
+	      write(message,*) 'DEFINED_PSFC, dum2d: ', DEFINED_PSFC(I,J),dum2d(I,J)
+              CALL wrf_debug(2,message)
+	      write(message,*) 'DEFINED_PSFCB, DUM2DB: ', DEFINED_PSFCB(I,J),DUM2DB(I,J)
+              CALL wrf_debug(2,message)
+              CALL wrf_error_fatal("quit due to unrealistic surface pressure")
+            ENDIF
+          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 )
+
+
+        INTEGER          :: IDS,IDE,JDS,JDE,KDS,KDE
+        INTEGER          :: IMS,IME,JMS,JME,KMS,KME
+        INTEGER          :: 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,JMS:JME,KDS:KDE-1)
+        REAL, INTENT(OUT):: pd(IMS:IME,JMS:JME)
+
+        CHARACTER (len=255) :: 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,J,K)=pd(I,J)*SGML2(K)+pdtop*SGML1(K)+pt
+
+	IF (p3d_out(I,J,K) .ge. psfc_out(I,J) .or. p3d_out(I,J,K) .le. pt) THEN
+           write(message,*) 'I,K,J,p3d_out: ', I,K,J,p3d_out(I,J,K)
+           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, internal_time )
+
+    ! 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
+    INTEGER                            :: internal_time
+
+!    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,JMS:JME,KDS:KDE-1)
+!    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,JMS:JME,KMS:KME)
+    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
+
+
+
+      DO K=KMS,KME
+      DO J=JMS,JME
+      DO I=IMS,IME
+        DATA_OUT(I,J,K)=-99999.9
+      ENDDO
+      ENDDO
+      ENDDO
+
+    IF (ignore_lowest) then
+       LMIN=2
+    ELSE
+       LMIN=1
+    ENDIF
+
+    DO j = JTS, min(JTE,JDE-1)
+      test_i: DO i = ITS, min(ITE,IDE-1)
+
+     IF (internal_time_loop .gt. 1) THEN
+        IF (J .ne. JDS .and. J .ne. JDE-1 .and. &
+          I .ne. IDS .and. I .ne. IDE-1 ) THEN
+!! not on boundary
+          CYCLE test_i
+        ENDIF
+     ENDIF
+
+
+       col_smooth=.false.
+
+        output_loop: DO k = KDS,KDE-1
+
+          desired_press = press_out(i,j,k)
+
+        if (K .gt. KDS) then
+	if (TFIELD .and. col_smooth .and. desired_press .le. press_in(i,j,LMIN) &
+                                    .and. press_out(i,j,k-1) .ge. 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,j,k) = 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,j,k) = data_in(i,j,LMIN) + dvaldlnp * &
+                               ( log(desired_press)-log(press_in(i,j,LMIN)) )
+
+	if (TFIELD .and. data_out(i,j,k) .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,J,K)= data_in(i,j,LMIN) + dvaldlnp * &
+                               ( log(desired_press)-log(press_in(i,j,LMIN)) )
+
+        elseif (TFIELD .and. data_out(i,j,k) .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,J,K)= data_in(i,j,LMIN) + dvaldlnp * &
+                               ( log(desired_press)-log(press_in(i,j,LMIN)) )
+
+         endif
+
+              ELSE
+                data_out(i,j,k) = 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,j,k) = 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,j,k) =  data_in(i,j,generic) + &
+                  dvaldlnp * (log(desired_press)-log(press_in(i,j,generic)))
+              ELSE
+                data_out(i,j,k) = 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,j,k) = 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,j,k) = 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,J,K)=0.5*(data_out(I,J,K)+data_out(I,J,K+1))
+       enddo
+        endif
+
+      ENDDO test_i
+    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,JMS:JME,KDS:KDE-1)
+    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,J,1) .lt. press_in(I,J,2)) then
+         IF(  (press_in(I,J,2)-press_out(I,J,1)) .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,J,1)-press_out(I,J,L)) .lt. depth_replace) THEN
+          p1d_out(L)=(press_out(I,J,1)-press_out(I,J,L))
+          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, internal_time )
+
+    ! 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
+    INTEGER                            :: internal_time
+
+!    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,JMS:JME,KDS:KDE-1)
+!    REAL, INTENT(IN)                   :: data_in(IMS:IME,generic,JMS:JME)
+!    REAL, INTENT(IN)                   :: data_in(IMS:IME,JMS:JME,generic)
+    REAL                               :: data_in(IMS:IME,JMS:JME,generic)
+    REAL, INTENT(OUT)                  :: data_out(IMS:IME,JMS:JME,KMS:KME)
+    LOGICAL, INTENT(IN)                :: extrapolate, ignore_lowest
+
+    INTEGER                            :: i,j
+    INTEGER                            :: k,kk
+    REAL                               :: desired_press
+    REAL                               :: dlnvaldlnp,dlnp
+
+
+      DO K=1,generic
+      DO j = JTS, min(JTE,JDE-1)
+      DO i = ITS, min(ITE,IDE-1)
+        DATA_IN(I,J,K)=max(DATA_in(I,J,K),1.e-13)
+      ENDDO
+      ENDDO
+      ENDDO
+
+      DO K=KMS,KME
+      DO J=JMS,JME
+      DO I=IMS,IME
+        DATA_OUT(I,J,K)=-99999.9
+      ENDDO
+      ENDDO
+      ENDDO
+
+    IF (ignore_lowest) then
+       LMIN=2
+    ELSE
+       LMIN=1
+    ENDIF
+
+    DO j = JTS, min(JTE,JDE-1)
+     test_i:  DO i = ITS, min(ITE,IDE-1)
+
+      IF (internal_time .gt. 1) THEN
+        IF (J .ne. JDS .and. J .ne. JDE-1 .and. &
+            I .ne. IDS .and. I .ne. IDE-1 ) THEN
+!! not on boundary
+          CYCLE test_i
+        ENDIF
+      ENDIF
+
+
+        output_loop: DO k = KDS,KDE-1
+
+          desired_press = press_out(i,j,k)
+
+          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,j,k) = 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,j,k) = exp(log(data_in(i,j,LMIN)) + dlnvaldlnp * &
+                               ( log(desired_press)-log(press_in(i,j,LMIN))))
+              ELSE
+                data_out(i,j,k) = 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,j,k) = 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,j,k) =  exp(log(data_in(i,j,generic)) + &
+                          dlnvaldlnp * (log(desired_press)-log(press_in(i,j,generic))))
+              ELSE
+                data_out(i,j,k) = 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,j,k) = 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,j,k) = 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 test_i
+    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,jms:jme,kms:kme) , 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,j,k)=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,j,k) = 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,j,k) = 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:: 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 :: IPS,IPE,JPS,JPE,KPS,KPE
+        integer :: ihl, ihh, m2l, ibas,jmelin
+        integer :: I,J,KS,IOFFSET,JSTART,JEND
+        character (len=255) :: 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%ht_gc=h
+#ifdef DM_PARALLEL
+# include "HALO_NMM_MG.inc"
+#endif
+         h=grid%ht_gc
+         h_old=grid%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%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%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_debug(100,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_debug(100,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%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%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)-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 compute_nmm_levels(ninterface, ptop, eta_levels)
+
+        USE module_model_constants
+
+        IMPLICIT NONE
+
+        character(len=132):: message
+        integer        ::  ninterface,Lthick,L
+        real, parameter:: gamma=.0065
+        real, parameter:: t_stand=288.
+        real, parameter:: p_stand=101325.
+
+        real           ::  maxdz_compute, ptop
+        real           ::  plower,pupper,tlay, sum
+
+        real             :: eta_levels(ninterface)
+        real, allocatable:: Z(:)
+        real, allocatable:: deta_levels_spline(:)
+
+        logical:: print_pbl_warn
+
+!----------------------------------------------------
+
+        allocate(Z(ninterface))
+        allocate(deta_levels_spline(ninterface-1))
+
+        CALL compute_eta_spline(ninterface-1,deta_levels_spline,ptop)
+
+        sum=0.
+        DO L=1,ninterface-1
+          sum=sum+deta_levels_spline(L)
+        ENDDO
+
+        eta_levels(1)=1.00
+
+        DO L=2,ninterface
+          eta_levels(L)=eta_levels(L-1)-deta_levels_spline(L-1)
+        ENDDO
+
+        eta_levels(ninterface)=0.00
+
+        DO L=2,ninterface-1
+          eta_levels(L)=0.5*(eta_levels(L))+0.25*(eta_levels(L-1)+eta_levels(L+1))
+        ENDDO
+
+        Z(1)=0.
+        maxdz_compute=0.
+        print_pbl_warn=.false.
+
+        DO L=2,ninterface
+          tlay=max( t_stand-gamma*Z(L-1), 216.5)
+          plower=ptop+(p_stand-ptop)*eta_levels(L-1)
+          pupper=ptop+(p_stand-ptop)*eta_levels(L)
+          Z(L)=Z(L-1)+(tlay*r_d/g)*(log(plower)-log(pupper))
+
+          if (plower .gt. 85000. .and. pupper .lt. 85000. .and. L .lt. 10) then
+            print_pbl_warn=.true.
+          endif
+
+          write(message,*) 'L, eta(l), pupper, Z(L): ', L, eta_levels(L),pupper,Z(L)
+          CALL wrf_debug(100,message)
+
+          if (Z(L)-Z(L-1) .gt. maxdz_compute) then
+            Lthick=L
+          endif
+
+          maxdz_compute=max(maxdz_compute,Z(L)-Z(L-1))
+        ENDDO
+
+        if (print_pbl_warn) then
+          write(message,*) 'WARNING - PBL MAY BE POORLY RESOLVED WITH NUMBER OF VERTICAL LEVELS'
+          CALL wrf_message(message)
+          write(message,*) '        - CONSIDER INCREASING THE VERTICAL RESOLUTION'
+          CALL wrf_message(message)
+        endif
+
+        write(message,*) 'thickest layer was: ', maxdz_compute , 'meters thick at level: ', Lthick
+        CALL wrf_message(message)
+
+        END SUBROUTINE compute_nmm_levels
+
+!---------------------------
+
+     SUBROUTINE compute_eta_spline(LM, dsg, ptop)
+
+     IMPLICIT NONE
+
+     real:: dsg(LM), ptop, sum, rsum
+     real, allocatable:: xold(:),dold(:)
+     real, allocatable:: xnew(:),sgm(:)
+     real, allocatable:: pps(:),qqs(:),y2s(:)
+     integer nlev,LM,L,KOLD
+
+    IF (LM .ge. 46) THEN
+     KOLD=9
+     allocate(xold(KOLD))
+     allocate(dold(KOLD))
+
+     xold(1)=.00
+     dold(1)=.006
+     xold(2)=.13
+     dold(2)=.009
+     xold(3)=.19
+     dold(3)=.012
+     xold(4)=.30
+     dold(4)=.036
+     xold(5)=.42
+     dold(5)=.041
+     xold(6)=.56
+     dold(6)=.040
+     xold(7)=.69
+     dold(7)=.018
+
+     if (ptop .ge. 2000.) then
+      xold(8)=.90
+      dold(8)=.012
+      xold(9)=1.0
+      dold(9)=.006
+     else
+      xold(8)=.90
+      dold(8)=.008
+      xold(9)=1.0
+      dold(9)=.003
+     endif
+
+    ELSE
+
+     KOLD=8
+     allocate(xold(KOLD))
+     allocate(dold(KOLD))
+
+     xold(1)=.00
+     dold(1)=.006
+     xold(2)=.18
+     dold(2)=.015
+     xold(3)=.32
+     dold(3)=.035
+     xold(4)=.50
+     dold(4)=.040
+     xold(5)=.68
+     dold(5)=.030
+     xold(6)=.75
+     dold(6)=.017
+     xold(7)=.85
+     dold(7)=.012
+
+     if (ptop .ge. 2000.) then
+      xold(8)=1.0
+      dold(8)=.013
+     else
+      xold(8)=1.0
+      dold(8)=.008
+     endif
+
+    ENDIF
+
+        allocate(xnew(lm))
+        allocate(sgm(lm+1))
+        allocate(pps(lm))
+        allocate(qqs(lm))
+        allocate(y2s(lm))
+
+    DO L=1,LM
+       xnew(l)=float(l-1)/float(lm-1)
+    ENDDO
+
+    y2s=0.
+
+    CALL spline(kold,xold,dold,y2s,lm,xnew,dsg,pps,qqs)
+
+    sum=0.
+    DO l=1,lm
+       sum=sum+dsg(l)
+    ENDDO
+
+    rsum=1./sum
+    sgm(1)=0.
+
+    DO L=1,lm-1
+     dsg(l)=dsg(l)*rsum
+     sgm(l+1)=sgm(l)+dsg(l)
+    ENDDO
+    sgm(lm+1)=1.
+    dsg(lm)=sgm(lm+1)-sgm(lm)
+
+    END SUBROUTINE compute_eta_spline
+
+! -------------------------------------------------------------------
+
+     subroutine spline(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.                  *
+!   *                                                                  *
+!   ********************************************************************
+!
+!   LOG:
+!
+!     JOVIC - July 2008 - fixed incorrectly dimensioned arrays,
+!     PYLE                and do loop leading to out of bound array
+!                         reference
+!------
+!
+!     PYLE - June 2007 - eliminated use of GO TO statements.
+!
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: NNEW,NOLD
+      REAL,DIMENSION(NOLD),INTENT(IN) :: XOLD,YOLD
+      REAL,DIMENSION(NNEW),INTENT(IN)  :: XNEW
+      REAL,DIMENSION(NNEW),INTENT(OUT) :: YNEW
+      REAL,DIMENSION(NOLD+2),INTENT(INOUT) :: P,q,Y2
+!
+      INTEGER :: K,K1,K2,KOLD,NOLDM1, K2_hold, K_hold
+      REAL :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR                   &
+     &       ,RDX,RTDXC,X,XK,XSQ,Y2K,Y2KP1
+!-----------------------------------------------------------------------
+
+      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
+
+      K=3
+      first_loop: DO K=3,NOLD-1
+        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
+      END DO first_loop
+
+      DO K=NOLDM1,2,-1
+         Y2(K)=P(K-1)+q(K-1)*Y2(K+1)
+         K_hold=K
+      END DO
+
+      K=K_hold
+
+!-----------------------------------------------------------------------
+      second_loop:  DO K1=1,NNEW
+        XK=XNEW(K1)
+        third_loop:  DO K2=2,NOLD
+
+          IF(XOLD(K2)>XK)THEN
+            KOLD=K2-1
+            K2_hold=K2
+            exit third_loop
+          ENDIF
+        K2_hold=K2
+        END DO third_loop
+
+        IF (XOLD(K2_hold) .le. XK) THEN
+          YNEW(K1)=YOLD(NOLD)
+          CYCLE second_loop
+        ENDIF
+
+        IF (K1 .eq. 1 .or. K .ne. KOLD) THEN
+          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)
+        ENDIF
+
+        X=XK-XOLD(K)
+        XSQ=X*X
+        YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K)
+
+      END DO second_loop
+
+      END SUBROUTINE SPLINE
+!--------------------------------------------------------------------
+      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=255) :: 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
+
+!---------------------------------------------------------------------
+
+#ifdef HWRF
+! compute earth lat-lons for before interpolations. This is gopal's doing for ocean coupling
+!============================================================================================
+
+SUBROUTINE EARTH_LATLON_hwrf ( 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)
+
+      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_hwrf
+
+  SUBROUTINE G2T2H_hwrf( SM,HRES_SM,                          & ! output grid index and weights
+                    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,P_IMS,P_IME,P_JMS,P_JME, & ! 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,P_IMS,P_IME,P_JMS,P_JME
+ REAL,       INTENT(IN   )                            :: DLMD1,DPHD1,WBD1,SBD1
+ REAL,       INTENT(IN   )                            :: CENTRAL_LAT,CENTRAL_LON
+ REAL,    DIMENSION(P_IMS:P_IME,P_JMS:P_JME), INTENT(IN)   :: SM
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(IN)   :: HLAT,HLON
+ REAL,    DIMENSION(IMS:IME,JMS:JME),    INTENT(OUT)  :: HRES_SM
+
+! local
+
+ INTEGER,PARAMETER :: KNUM=SELECTED_REAL_KIND(13)
+ INTEGER           :: IMT,JMT,N2R,MK,K,I,J,DSLP0,DSLOPE,N
+ 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
+ REAL     SUM,AMAXVAL
+ REAL,    DIMENSION (4, ims:ime, jms:jme ) :: NBWGT
+ LOGICAL  FLIP
+ REAL,    DIMENSION(IMS:IME,JMS:JME)  :: HBWGT1,HBWGT2,HBWGT3,HBWGT4
+ INTEGER, DIMENSION(IMS:IME,JMS:JME)  :: IIH,JJH
+!-------------------------------------------------------------------------------
+
+  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
+      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
+
+!      WRITE(60,*)'============================================================'
+!      WRITE(60,*)'              ','i=',i,'j=',j
+!*** 
+!***
+!***  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))
+
+   ENDDO
+  ENDDO
+
+!
+!*** EXTENSION TO NEAREST NEIGHBOR
+!
+     DO J =  JTS,MIN(JTE,JDE) !-1)
+      DO I = ITS,MIN(ITE,IDE) !-1)
+         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)
+      ENDDO
+     ENDDO
+
+     DO J =  JTS,MIN(JTE,JDE) !-1)
+      DO I = ITS,MIN(ITE,IDE) !-1)
+       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
+
+
+          IF((NBWGT(1,I,J)+NBWGT(2,I,J)+NBWGT(3,I,J)+NBWGT(4,I,J)) .NE. 1)THEN
+            WRITE(0,*)'------------------------------------------------------------------------'
+            WRITE(0,*)'FATAL: SOMETHING IS WRONG WITH THE WEIGHTS IN module_initialize_real.F'
+            WRITE(0,*)'------------------------------------------------------------------------'
+            STOP
+          ENDIF
+
+!       WRITE(66,*)I,J,NBWGT(1,I,J),NBWGT(2,I,J),NBWGT(3,I,J),NBWGT(4,I,J)
+
+      ENDDO
+     ENDDO
+
+
+     DO J=MAX(3,JTS),MIN(JTE,JDE)  !-1)
+      DO I=MAX(3,ITS),MIN(ITE,IDE) !-1)
+            IF(MOD(JJH(I,J),2) .NE. 0)THEN    ! 1,3,5,7
+                HRES_SM(I,J) = NBWGT(1,I,J)*SM(IIH(I,J),JJH(I,J)  )    &
+                             + NBWGT(2,I,J)*SM(IIH(I,J)+1, JJH(I,J)  )    &
+                             + NBWGT(3,I,J)*SM(IIH(I,J),   JJH(I,J)-1)    &
+                             + NBWGT(4,I,J)*SM(IIH(I,J),   JJH(I,J)+1)
+!                WRITE(68,*)I,J,SM(IIH(I,J),JJH(I,J)),SM(IIH(I,J)+1, JJH(I,J)), &
+!                               SM(IIH(I,J),   JJH(I,J)-1),SM(IIH(I,J), JJH(I,J)+1),HRES_SM(I,J)
+            ELSE
+                HRES_SM(I,J) = NBWGT(1,I,J)*SM(IIH(I,J),   JJH(I,J)  )  &
+                             + NBWGT(2,I,J)*SM(IIH(I,J)+1, JJH(I,J)  )  &
+                             + NBWGT(3,I,J)*SM(IIH(I,J)+1, JJH(I,J)-1)  &
+                             + NBWGT(4,I,J)*SM(IIH(I,J)+1, JJH(I,J)+1)
+
+!                WRITE(68,*)I,J,SM(IIH(I,J),JJH(I,J)),SM(IIH(I,J)+1, JJH(I,J)), &
+!                               SM(IIH(I,J)+1, JJH(I,J)-1),SM(IIH(I,J)+1, JJH(I,J)+1),HRES_SM(I,J)
+
+            ENDIF
+
+      ENDDO
+     ENDDO
+!    Boundary treatment in J direction
+     DO J=MAX(3,JTS),MIN(JTE,JDE)
+       HRES_SM(2,J)=HRES_SM(3,J)
+       HRES_SM(1,J)=HRES_SM(2,J)
+     END DO
+!    Boundary treatment in J direction and 4 corners
+     DO I=ITS,MIN(ITE,IDE) 
+       HRES_SM(I,2)=HRES_SM(I,3)
+       HRES_SM(I,1)=HRES_SM(I,2)
+     END DO
+
+
+  RETURN
+  END SUBROUTINE G2T2H_hwrf
+!========================================================================================
+! end gopal's doing for ocean coupling
+!============================================================================================
+#endif
+END MODULE module_initialize_real
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_si_io_nmm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_si_io_nmm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/module_si_io_nmm.F	(revision 17)
@@ -0,0 +1,3087 @@
+MODULE module_si_io_nmm
+
+   USE module_optional_input
+
+   IMPLICIT NONE
+!! FROM MODULE_KINDS
+
+!   The numerical data types defined in this module are:
+!      i_byte    - specification kind for byte (1-byte) integer variable
+!      i_short   - specification kind for short (2-byte) integer variable
+!      i_long    - specification kind for long (4-byte) integer variable
+!      i_llong   - specification kind for double long (8-byte) integer variable
+!      r_single  - specification kind for single precision (4-byte) real variable
+!      r_double  - specification kind for double precision (8-byte) real variable
+!      r_quad    - specification kind for quad precision (16-byte) real variable
+!
+!      i_kind    - generic specification kind for default integer
+!      r_kind    - generic specification kind for default floating point
+!
+!
+! Integer type definitions below
+
+! Integer types
+  integer, parameter, public  :: i_byte  = selected_int_kind(1)      ! byte  integer
+  integer, parameter, public  :: i_short = selected_int_kind(4)      ! short integer
+  integer, parameter, public  :: i_long  = selected_int_kind(8)      ! long  integer
+  integer, parameter, private :: llong_t = selected_int_kind(16)     ! llong integer
+  integer, parameter, public  :: i_llong = max( llong_t, i_long )
+
+! Expected 8-bit byte sizes of the integer kinds
+  integer, parameter, public :: num_bytes_for_i_byte  = 1
+  integer, parameter, public :: num_bytes_for_i_short = 2
+  integer, parameter, public :: num_bytes_for_i_long  = 4
+  integer, parameter, public :: num_bytes_for_i_llong = 8
+
+! Define arrays for default definition
+  integer, parameter, private :: num_i_kinds = 4
+  integer, parameter, dimension( num_i_kinds ), private :: integer_types = (/ &
+       i_byte, i_short, i_long,  i_llong  /)
+  integer, parameter, dimension( num_i_kinds ), private :: integer_byte_sizes = (/ &
+       num_bytes_for_i_byte, num_bytes_for_i_short, &
+       num_bytes_for_i_long, num_bytes_for_i_llong  /)
+
+! Default values
+! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT INTEGER TYPE KIND ***
+  integer, parameter, private :: default_integer = 2  ! 1=byte,
+                                                      ! 2=short,
+                                                      ! 3=long,
+                                                      ! 4=llong
+  integer, parameter, public  :: i_kind = integer_types( default_integer )
+  integer, parameter, public  :: num_bytes_for_i_kind = &
+       integer_byte_sizes( default_integer )
+
+
+! Real definitions below
+
+! Real types
+  integer, parameter, public  :: r_single = selected_real_kind(6)  ! single precision
+  integer, parameter, public  :: r_double = selected_real_kind(15) ! double precision
+  integer, parameter, private :: quad_t   = selected_real_kind(20) ! quad precision
+  integer, parameter, public  :: r_quad   = max( quad_t, r_double )
+
+! Expected 8-bit byte sizes of the real kinds
+  integer, parameter, public :: num_bytes_for_r_single = 4
+  integer, parameter, public :: num_bytes_for_r_double = 8
+  integer, parameter, public :: num_bytes_for_r_quad   = 16
+
+! Define arrays for default definition
+  integer, parameter, private :: num_r_kinds = 3
+  integer, parameter, dimension( num_r_kinds ), private :: real_kinds = (/ &
+       r_single, r_double, r_quad    /)
+  integer, parameter, dimension( num_r_kinds ), private :: real_byte_sizes = (/ &
+       num_bytes_for_r_single, num_bytes_for_r_double, &
+       num_bytes_for_r_quad    /)
+
+! Default values
+! **** CHANGE THE FOLLOWING TO CHANGE THE DEFAULT REAL TYPE KIND ***
+  integer, parameter, private :: default_real = 2  ! 1=single,
+                                                   ! 2=double,
+!! END FROM MODULE_KINDS
+
+      !  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,save :: 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,save :: 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
+      CHARACTER (LEN=256) :: dummy_char_256
+
+      INTEGER :: ok , map_proj , ok_open
+      REAL :: pt
+      INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
+
+      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%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%pdtop
+
+         ELSE IF ( var_info%name(1:8) .EQ. 'PT      ' ) THEN
+            READ (13) grid%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%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%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_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%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%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%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%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%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%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%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%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%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%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 k=kts,kte-1
+      do j=jts,JMAX
+      do i=its,IMAX
+        grid%U(I,J,K)=U_input(I,J,K)
+        grid%V(I,J,K)=V_input(I,J,K)
+        grid%T(I,J,K)=T_input(I,J,K)
+        grid%Q(I,J,K)=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 J=JTS,min(JDE-1,JTE)
+         do K=1,num_st_levels_alloc
+          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)
+          grid%SOILCTOP_gc(I,J,K)=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)
+          grid%SOILCBOT_gc(I,J,K)=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)
+          grid%LANDUSEF_gc(I,J,K)=landuse_frac_input(I,J,K)
+          enddo
+         enddo
+        enddo
+
+
+      do K=KDS,KDE
+        grid%ETAX(K)=ETAX_in(KDE-K+1)
+        grid%ETA1(K)=ETA1_in(KDE-K+1)
+        grid%ETA2(K)=ETA2_in(KDE-K+1)
+        grid%DFL(K)=DFL_in(KDE-K+1)
+      enddo
+
+      do K=KDS,KDE-1
+        grid%DETA(K)=DETA_in(KDE-K)
+        grid%DETA1(K)=DETA1_in(KDE-K)
+        grid%DETA2(K)=DETA2_in(KDE-K)
+        grid%AETA(K)=AETA_in(KDE-K)
+        grid%AETA1(K)=AETA1_in(KDE-K)
+        grid%AETA2(K)=AETA2_in(KDE-K)
+      enddo
+
+   END SUBROUTINE read_si
+
+! ------------------------------------------------------------
+! ------------------------------------------------------------
+! ------------------------------------------------------------
+! ------------------------------------------------------------
+! ------------------------------------------------------------
+! ------------------------------------------------------------
+
+   SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels )
+
+      USE module_soil_pre
+      USE module_domain
+
+      IMPLICIT NONE
+
+      TYPE(domain) , INTENT(INOUT)  :: grid
+      CHARACTER (LEN=19) , INTENT(IN) :: file_date_string
+      CHARACTER (LEN=19)              :: VarName
+      CHARACTER (LEN=150)             :: chartemp
+      CHARACTER (LEN=256)             :: mminlu_loc, message
+      CHARACTER (*) , INTENT(IN) :: filename
+
+      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
+      INTEGER :: DATAHANDLE, num_metgrid_levels
+      INTEGER :: Sysdepinfo, Status, N
+      INTEGER :: istatus,ioutcount,iret,index,ierr
+
+      integer :: nrecs,iunit, L,hor_size
+
+!!
+      character*132, allocatable,save :: datestr_all(:)
+      character*132, allocatable,save :: varname_all(:)
+      integer, allocatable,save       :: domainend_all(:,:)
+      integer, allocatable,save       :: start_block(:)
+      integer, allocatable,save       :: end_block(:)
+      integer, allocatable,save       :: start_byte(:)
+      integer, allocatable,save       :: end_byte(:)
+      integer(kind=i_llong), allocatable,save           :: file_offset(:)
+!!
+
+      REAL :: dummy,tmp,garb
+      REAL, ALLOCATABLE,save :: dumdata(:,:,:)
+
+      CHARACTER (LEN= 8) :: dummy_char
+
+      INTEGER :: ok , map_proj , ok_open, igarb
+      REAL :: pt
+      INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
+
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      INCLUDE "mpif.h"
+
+      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.
+
+
+      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
+
+	mminlu_loc=''
+        mminlu_loc(1:4)='USGS'
+
+         CALL nl_set_mminlu ( grid%id, mminlu_loc)
+         CALL nl_set_iswater (grid%id, 16 )
+         CALL nl_set_isice (grid%id, 24 )
+         CALL nl_set_islake (grid%id, -1)
+
+
+      !  Get the space for the data if this is the first time here.
+
+        IF (.NOT. ALLOCATED (pmsl)              ) ALLOCATE ( pmsl(its:ite,jts:jte) )
+        IF (.NOT. ALLOCATED (psfc_in)           ) ALLOCATE ( psfc_in(its:ite,jts:jte) )
+        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) )
+
+        !  Local arrays
+
+!!! MPI IO
+
+      iunit=33
+      call count_recs_wrf_binary_file(iunit, trim(fileName), nrecs)
+
+      if (.NOT. ALLOCATED (datestr_all)) allocate (datestr_all(nrecs))
+      if (.NOT. ALLOCATED (varname_all)) allocate (varname_all(nrecs))
+      if (.NOT. ALLOCATED (domainend_all)) allocate (domainend_all(3,nrecs))
+      if (.NOT. ALLOCATED (start_block)) allocate (start_block(nrecs))
+      if (.NOT. ALLOCATED (end_block)) allocate (end_block(nrecs))
+      if (.NOT. ALLOCATED (start_byte)) allocate (start_byte(nrecs))
+      if (.NOT. ALLOCATED (end_byte)) allocate (end_byte(nrecs))
+      if (.NOT. ALLOCATED (file_offset)) allocate (file_offset(nrecs))
+
+      call inventory_wrf_binary_file(iunit, trim(filename), nrecs,  &
+                      datestr_all,varname_all,domainend_all,   &
+                      start_block,end_block,start_byte,end_byte,file_offset)
+
+        do N=1,NRECS
+         write(message,*) 'N,varname_all(N): ',N, varname_all(N)
+         call wrf_debug(100,message)
+        enddo
+
+      call mpi_file_open(mpi_comm_world, trim(filename),     &
+                         mpi_mode_rdonly,mpi_info_null, iunit, ierr)
+      if (ierr /= 0) then
+       call wrf_error_fatal("Error opening file with mpi io")
+      end if
+
+      VarName='CEN_LAT'
+      call retrieve_index(index,VarName,varname_all,nrecs,iret)
+      if (iret /= 0) then
+        write(message,*) VarName, ' not found in file'
+        call wrf_message(message)
+      else
+
+        call mpi_file_read_at(iunit,file_offset(index)+5*4,      &
+                              garb,1,mpi_real4,                  &
+                              mpi_status_ignore, ierr)
+
+        if (ierr /= 0) then
+          write(message,*) 'Error reading ', VarName,' using MPIIO'
+          call wrf_message(message)
+        else
+          write(message,*) VarName, ' from MPIIO READ= ', garb
+          call wrf_message(message)
+          CALL nl_set_cen_lat ( grid%id , garb )
+        end if
+      end if
+
+      VarName='CEN_LON'
+      call retrieve_index(index,VarName,varname_all,nrecs,iret)
+        call mpi_file_read_at(iunit,file_offset(index)+5*4,      &
+                              garb,1,mpi_real4,                  &
+                              mpi_status_ignore, ierr)
+          CALL nl_set_cen_lon ( grid%id , garb )
+          CALL nl_set_stand_lon ( grid%id , garb )
+
+      VarName='TRUELAT1'
+      call retrieve_index(index,VarName,varname_all,nrecs,iret)
+        call mpi_file_read_at(iunit,file_offset(index)+5*4,      &
+                              garb,1,mpi_real4,                  &
+                              mpi_status_ignore, ierr)
+          CALL nl_set_truelat1 ( grid%id , garb )
+
+      VarName='TRUELAT2'
+      call retrieve_index(index,VarName,varname_all,nrecs,iret)
+        call mpi_file_read_at(iunit,file_offset(index)+5*4,      &
+                              garb,1,mpi_real4,                  &
+                              mpi_status_ignore, ierr)
+          CALL nl_set_truelat2 ( grid%id , garb )
+
+      VarName='MAP_PROJ'
+      call retrieve_index(index,VarName,varname_all,nrecs,iret)
+        call mpi_file_read_at(iunit,file_offset(index)+5*4,     &
+                              igarb,1,mpi_integer4,             &
+                              mpi_status_ignore, ierr)
+
+          CALL  nl_set_map_proj( grid%id, igarb)
+
+    hor_size=(IDE-IDS)*(JDE-JDS)
+
+    varName='PRES'
+	if (.not. allocated(dumdata)) then
+    allocate(dumdata(IDS:IDE-1,JDS:JDE-1,num_metgrid_levels))
+	endif
+
+     CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+     CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                          dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
+                          mpi_status_ignore, ierr)
+
+       DO K=1,num_metgrid_levels
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%p_gc(I,J,K)=dumdata(I,J,K)
+         ENDDO
+        ENDDO
+       ENDDO
+
+    varName='GHT'
+
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+
+       DO K=1,num_metgrid_levels
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%ght_gc(I,J,K)=dumdata(I,J,K)
+         ENDDO
+        ENDDO
+       ENDDO
+
+
+    varName='VEGCAT'
+
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%vegcat(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='SOIL_CAT'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%input_soil_cat(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='CANWAT'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%canwat(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='SNOW'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%snow(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='SKINTEMP'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%tsk_gc(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='SOILHGT'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%toposoil(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='SEAICE'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%xice_gc(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='ST100200'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%st100200(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='ST040100'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%st040100(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='ST010040'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%st010040(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='ST000010'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%st000010(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='SM100200'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%sm100200(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='SM040100'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%sm040100(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='SM010040'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%sm010040(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='SM000010'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%sm000010(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='PSFC'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%psfc(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='RH'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+       DO K=1,num_metgrid_levels
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%rh_gc(I,J,K)=dumdata(I,J,K)
+         ENDDO
+        ENDDO
+       ENDDO
+
+    varName='VV'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+       DO K=1,num_metgrid_levels
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%v_gc(I,J,K)=dumdata(I,J,K)
+         ENDDO
+        ENDDO
+       ENDDO
+
+    varName='UU'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+       DO K=1,num_metgrid_levels
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%u_gc(I,J,K)=dumdata(I,J,K)
+         ENDDO
+        ENDDO
+       ENDDO
+
+    varName='TT'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+
+        if (IRET .eq. 0) then
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+       DO K=1,num_metgrid_levels
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%t_gc(I,J,K)=dumdata(I,J,K)
+         ENDDO
+        ENDDO
+       ENDDO
+        endif
+
+!    varName='RWMR'
+!    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+!        if (iret .ne. 0) then
+!        grid%rwmr_gc=0.
+!        grid%snmr_gc=0.
+!        grid%clwmr_gc=0.
+!        grid%cice_gc=0.
+!        grid%rimef_gc=0.
+!        write(0,*) 'skipping cloud reads'
+!        goto 979
+!        endif
+
+!    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+!                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
+!                             mpi_status_ignore, ierr)
+!       DO K=1,num_metgrid_levels
+!        DO J=JTS,min(JTE,JDE-1)
+!         DO I=ITS,min(ITE,IDE-1)
+!           grid%rwmr_gc(I,J,K)=dumdata(I,J,K)
+!         ENDDO
+!        ENDDO
+!       ENDDO
+
+!    varName='SNMR'
+!    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+!    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+!                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
+!                             mpi_status_ignore, ierr)
+!       DO K=1,num_metgrid_levels
+!        DO J=JTS,min(JTE,JDE-1)
+!         DO I=ITS,min(ITE,IDE-1)
+!           grid%snmr_gc(I,J,K)=dumdata(I,J,K)
+!         ENDDO
+!        ENDDO
+!       ENDDO
+
+!    varName='CLWMR'
+!    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+!    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+!                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
+!                             mpi_status_ignore, ierr)
+!       DO K=1,num_metgrid_levels
+!        DO J=JTS,min(JTE,JDE-1)
+!         DO I=ITS,min(ITE,IDE-1)
+!           grid%clwmr_gc(I,J,K)=dumdata(I,J,K)
+!         ENDDO
+!        ENDDO
+!       ENDDO
+
+!    varName='CICE'
+!    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+!    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+!                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
+!                             mpi_status_ignore, ierr)
+!       DO K=1,num_metgrid_levels
+!        DO J=JTS,min(JTE,JDE-1)
+!         DO I=ITS,min(ITE,IDE-1)
+!           grid%cice_gc(I,J,K)=dumdata(I,J,K)
+!         ENDDO
+!        ENDDO
+!       ENDDO
+
+!    varName='FRIMEF'
+!    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+!    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+!                             dumdata,hor_size*num_metgrid_levels,mpi_real4,             &
+!                             mpi_status_ignore, ierr)
+!       DO K=1,num_metgrid_levels
+!        DO J=JTS,min(JTE,JDE-1)
+!         DO I=ITS,min(ITE,IDE-1)
+!           grid%rimef_gc(I,J,K)=dumdata(I,J,K)
+!         ENDDO
+!        ENDDO
+!       ENDDO
+
+  979   continue
+
+!    varName='PMSL'
+
+    varName='SLOPECAT'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%slopecat(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='SNOALB'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%snoalb(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+         num_veg_cat      = SIZE ( grid%landusef_gc , DIM=3 )
+         num_soil_top_cat = SIZE ( grid%soilctop_gc , DIM=3 )
+         num_soil_bot_cat = SIZE ( grid%soilcbot_gc , DIM=3 )
+
+    varName='GREENFRAC'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size*12,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+       DO K=1,12
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%greenfrac_gc(I,J,K)=dumdata(I,J,K)
+         ENDDO
+        ENDDO
+       ENDDO
+
+    varName='ALBEDO12M'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size*12,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+       DO K=1,12
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%albedo12m_gc(I,J,K)=dumdata(I,J,K)
+         ENDDO
+        ENDDO
+       ENDDO
+
+    varName='SOILCBOT'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size*num_soil_bot_cat,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+       DO K=1,num_soil_bot_cat
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%soilcbot_gc(I,J,K)=dumdata(I,J,K)
+         ENDDO
+        ENDDO
+       ENDDO
+
+    varName='SOILCAT'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%soilcat(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+
+    varName='SOILCTOP'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size*num_soil_top_cat,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+       DO K=1,num_soil_top_cat
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%soilctop_gc(I,J,K)=dumdata(I,J,K)
+         ENDDO
+        ENDDO
+       ENDDO
+
+    varName='SOILTEMP'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%tmn_gc(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HGT_V'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%htv_gc(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HGT_M'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%ht_gc(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='LU_INDEX'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%lu_index(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='LANDUSEF'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size*num_veg_cat,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+       DO K=1,num_veg_cat
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%landusef_gc(I,J,K)=dumdata(I,J,K)
+         ENDDO
+        ENDDO
+       ENDDO
+
+    varName='LANDMASK'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%landmask(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+
+    varName='XLONG_V'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%vlon_gc(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='XLAT_V'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%vlat_gc(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='XLONG_M'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hlon_gc(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='XLAT_M'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hlat_gc(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+
+!!! GWD fields
+
+    varName='HSTDV'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hstdv(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HCNVX'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hcnvx(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HASYW'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hasyw(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HASYS'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hasys(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HASYSW'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hasysw(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HASYNW'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hasynw(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HLENW'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hlenw(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HLENS'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hlens(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HLENSW'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hlensw(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HLENNW'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hlennw(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HANGL'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hangl(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HANIS'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hanis(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HSLOP'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hslop(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+
+    varName='HZMAX'
+    CALL retrieve_index(index,VarName,varname_all,nrecs,iret)
+    CALL mpi_file_read_at(iunit,file_offset(index+1),     &
+                             dumdata,hor_size,mpi_real4,             &
+                             mpi_status_ignore, ierr)
+
+        DO J=JTS,min(JTE,JDE-1)
+         DO I=ITS,min(ITE,IDE-1)
+           grid%hzmax(I,J)=dumdata(I,J,1)
+         ENDDO
+        ENDDO
+	write(0,*) 'maxval grid%hzmax: ', maxval(grid%hzmax)
+
+      call mpi_file_close(mpi_comm_world, ierr)
+
+       varName='ST000010'
+       flag_st000010 = 1
+       num_st_levels_input = num_st_levels_input + 1
+       st_levels_input(num_st_levels_input) = char2int2(varName(3:8))
+       DO J=JTS,min(JTE,JDE-1)
+        DO I=ITS,min(ITE,IDE-1)
+           st_inputx(I,J,num_st_levels_input + 1) = grid%st000010(i,j)
+        ENDDO
+       ENDDO
+
+       varName='ST010040'
+       flag_st010040 = 1
+       num_st_levels_input = num_st_levels_input + 1
+       st_levels_input(num_st_levels_input) = char2int2(varName(3:8))
+       DO J=JTS,min(JTE,JDE-1)
+        DO I=ITS,min(ITE,IDE-1)
+            st_inputx(I,J,num_st_levels_input + 1) = grid%st010040(i,j)
+        ENDDO
+       ENDDO
+
+       varName='ST040100'
+       flag_st040100 = 1
+       num_st_levels_input = num_st_levels_input + 1
+       st_levels_input(num_st_levels_input) = char2int2(varName(3:8))
+       DO J=JTS,min(JTE,JDE-1)
+        DO I=ITS,min(ITE,IDE-1)
+              st_inputx(I,J,num_st_levels_input + 1) = grid%st040100(i,j)
+        ENDDO
+       ENDDO
+
+       varName='ST100200'
+       flag_st100200 = 1
+       num_st_levels_input = num_st_levels_input + 1
+       st_levels_input(num_st_levels_input) = char2int2(varName(3:8))
+       DO J=JTS,min(JTE,JDE-1)
+        DO I=ITS,min(ITE,IDE-1)
+              st_inputx(I,J,num_st_levels_input + 1) = grid%st100200(i,j)
+        ENDDO
+       ENDDO
+
+       varName='SM000010'
+       flag_sm000010 = 1
+       num_sm_levels_input = num_sm_levels_input + 1
+       sm_levels_input(num_sm_levels_input) = char2int2(varName(3:8))
+       DO J=JTS,min(JTE,JDE-1)
+        DO I=ITS,min(ITE,IDE-1)
+           sm_inputx(I,J,num_sm_levels_input + 1) = grid%sm000010(i,j)
+        ENDDO
+       ENDDO
+
+       varName='SM010040'
+       flag_sm010040 = 1
+       num_sm_levels_input = num_sm_levels_input + 1
+       sm_levels_input(num_sm_levels_input) = char2int2(varName(3:8))
+       DO J=JTS,min(JTE,JDE-1)
+        DO I=ITS,min(ITE,IDE-1)
+            sm_inputx(I,J,num_sm_levels_input + 1) = grid%sm010040(i,j)
+        ENDDO
+       ENDDO
+
+       varName='SM040100'
+       flag_sm040100 = 1
+       num_sm_levels_input = num_sm_levels_input + 1
+       sm_levels_input(num_sm_levels_input) = char2int2(varName(3:8))
+       DO J=JTS,min(JTE,JDE-1)
+        DO I=ITS,min(ITE,IDE-1)
+              sm_inputx(I,J,num_sm_levels_input + 1) = grid%sm040100(i,j)
+        ENDDO
+       ENDDO
+
+       varName='SM100200'
+       flag_sm100200 = 1
+       num_sm_levels_input = num_sm_levels_input + 1
+       sm_levels_input(num_sm_levels_input) = char2int2(varName(3:8))
+       DO J=JTS,min(JTE,JDE-1)
+        DO I=ITS,min(ITE,IDE-1)
+              sm_inputx(I,J,num_sm_levels_input + 1) = grid%sm100200(i,j)
+        ENDDO
+       ENDDO
+
+            flag_sst = 1
+
+!new
+        sw_inputx=0.
+!new
+
+      sw_input=0.
+
+
+        do J=JTS,min(JDE-1,JTE)
+         do K=1,num_st_levels_alloc
+          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
+
+!        DEALLOCATE(pmsl)
+!        DEALLOCATE(psfc_in)
+!        DEALLOCATE(st_inputx)
+!        DEALLOCATE(sm_inputx)
+!        DEALLOCATE(sw_inputx)
+!        DEALLOCATE(soilt010_input)
+!        DEALLOCATE(soilt040_input)
+!        DEALLOCATE(soilt100_input)
+!        DEALLOCATE(soilt200_input)
+!        DEALLOCATE(soilm010_input)
+!        DEALLOCATE(soilm040_input)
+!        DEALLOCATE(soilm100_input)
+!        DEALLOCATE(soilm200_input)
+!        DEALLOCATE(dumdata)
+
+#endif
+     end subroutine read_wps
+
+! -------------------------------------------------------------------------
+! -------------------------------------------------------------------------
+! -------------------------------------------------------------------------
+! -------------------------------------------------------------------------
+!!!! MPI-IO pieces
+
+subroutine retrieve_index(index,string,varname_all,nrecs,iret)
+!$$$  subprogram documentation block
+!                .      .    .                                       .
+! subprogram:    retrieve_index  get record number of desired variable
+!   prgmmr: parrish          org: np22                date: 2004-11-29
+!
+! abstract: by examining previously generated inventory of wrf binary restart file,
+!             find record number that contains the header record for variable
+!             identified by input character variable "string".
+!
+! program history log:
+!   2004-11-29  parrish
+!
+!   input argument list:
+!     string           - mnemonic for variable desired
+!     varname_all      - list of all mnemonics obtained from inventory of file
+!     nrecs            - total number of sequential records counted in wrf
+!                        binary restart file
+!
+!   output argument list:
+!     index            - desired record number
+!     iret             - return status, set to 0 if variable was found,
+!                        non-zero if not.
+!
+! attributes:
+!   language: f90
+!   machine:  ibm RS/6000 SP
+!
+!$$$
+
+  implicit none
+
+  integer,intent(out)::iret
+  integer,intent(in)::nrecs
+  integer,intent(out):: index
+  character(*), intent(in):: string
+  character(132),intent(in)::varname_all(nrecs)
+
+  integer i
+
+  iret=0
+
+  do i=1,nrecs
+   if(trim(string) == trim(varname_all(i))) then
+      index=i
+      return
+   end if
+  end do
+
+  write(6,*)' problem reading wrf nmm binary file, rec id "',trim(string),'" not found'
+
+  iret=-1
+
+end subroutine retrieve_index
+subroutine next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
+!$$$  subprogram documentation block
+!                .      .    .                                       .
+! subprogram:    next_buf    bring in next direct access block
+!   prgmmr: parrish          org: np22                date: 2004-11-29
+!
+! abstract: bring in next direct access block when needed, as the file is scanned
+!             from beginning to end during counting and inventory of records.
+!             (subroutines count_recs_wrf_binary_file and inventory_wrf_binary_file)
+!
+! program history log:
+!   2004-11-29  parrish
+!
+!   input argument list:
+!     in_unit          - fortran unit number where input file is opened through.
+!     nextbyte         - byte number from beginning of file that is desired
+!     locbyte          - byte number from beginning of last block read for desired byt
+!     lrecl            - direct access block length
+!     nreads           - number of blocks read before now (for diagnostic information
+!     lastbuf          - logical, if true, then no more blocks, so return
+!
+!   output argument list:
+!     buf              - output array containing contents of next block
+!     locbyte          - byte number from beginning of new block read for desired byte
+!     thisblock        - number of new block being read by this routine
+!     nreads           - number of blocks read now (for diagnostic information only)
+!     lastbuf          - logical, if true, then at end of file.
+!
+! attributes:
+!   language: f90
+!   machine:  ibm RS/6000 SP
+!
+!$$$
+!  use kinds, only: i_byte,i_llong
+  implicit none
+
+  integer(i_llong) lrecl
+  integer in_unit,nreads
+  integer(i_byte) buf(lrecl)
+  integer(i_llong) nextbyte,locbyte,thisblock
+  logical lastbuf
+
+  integer ierr
+
+  if(lastbuf) return
+
+  ierr=0
+  nreads=nreads+1
+
+!  compute thisblock:
+
+  thisblock = 1_i_llong + (nextbyte-1_i_llong)/lrecl
+
+  locbyte = 1_i_llong+mod(locbyte-1_i_llong,lrecl)
+
+  read(in_unit,rec=thisblock,iostat=ierr)buf
+  lastbuf = ierr /= 0
+
+end subroutine next_buf
+
+subroutine inventory_wrf_binary_file(in_unit,wrf_ges_filename,nrecs, &
+                                     datestr_all,varname_all,domainend_all, &
+                                     start_block,end_block,start_byte,end_byte,file_offset)
+!$$$  subprogram documentation block
+!                .      .    .                                       .
+! subprogram:    inventory_wrf_binary_file  get contents of wrf binary file
+!   prgmmr: parrish          org: np22                date: 2004-11-29
+!
+! abstract: generate list of contents and map of wrf binary file which can be
+!             used for reading and writing with mpi io routines.
+!             same basic routine as count_recs_wrf_binary_file, except
+!             now wrf unpacking routines are used to decode wrf header
+!             records, and send back lists of variable mnemonics, dates,
+!             grid dimensions, and byte addresses relative to start of
+!             file for each field (this is used by mpi io routines).
+!
+! program history log:
+!   2004-11-29  parrish
+!
+!
+!   input argument list:
+!     in_unit          - fortran unit number where input file is opened through.
+!     wrf_ges_filename - filename of input wrf binary restart file
+!     nrecs            - number of sequential records found on input wrf binary restart file.
+!                          (obtained by a previous call to count_recs_wrf_binary_file)
+!
+!   output argument list:  (all following dimensioned nrecs)
+!     datestr_all      - date character string for each field, where applicable (or else blanks)
+!     varname_all      - wrf mnemonic for each variable, where applicable (or blank)
+!     domainend_all    - dimensions of each field, where applicable (up to 3 dimensions)
+!     start_block      - direct access block number containing 1st byte of record
+!                            (after 4 byte record mark)
+!     end_block        - direct access block number containing last byte of record
+!                            (before 4 byte record mark)
+!     start_byte       - relative byte address in direct access block of 1st byte of record
+!     end_byte         - relative byte address in direct access block of last byte of record
+!     file_offset      - absolute address of byte before 1st byte of record (used by mpi io)
+!
+! attributes:
+!   language: f90
+!   machine:  ibm RS/6000 SP
+!
+!$$$
+!   use kinds, only: r_single,i_byte,i_long,i_llong
+  use module_internal_header_util
+  implicit none
+
+  integer,intent(in)::in_unit,nrecs
+  character(*),intent(in)::wrf_ges_filename
+  character(132),intent(out)::datestr_all(nrecs),varname_all(nrecs)
+  integer,intent(out)::domainend_all(3,nrecs)
+  integer,intent(out)::start_block(nrecs),end_block(nrecs)
+  integer,intent(out)::start_byte(nrecs),end_byte(nrecs)
+  integer(i_llong),intent(out)::file_offset(nrecs)
+
+  integer irecs
+  integer(i_llong) nextbyte,locbyte,thisblock
+  integer(i_byte) lenrec4(4)
+  integer(i_long) lenrec,lensave
+  equivalence (lenrec4(1),lenrec)
+  integer(i_byte) missing4(4)
+  integer(i_long) missing
+  equivalence (missing,missing4(1))
+  integer(i_llong),parameter:: lrecl=2**16-1
+  integer(i_byte) buf(lrecl)
+  integer i,loc_count,nreads
+  logical lastbuf
+  integer(i_byte) hdrbuf4(2048)
+  integer(i_long) hdrbuf(512)
+  equivalence(hdrbuf(1),hdrbuf4(1))
+  integer,parameter:: int_field       =       530
+  integer,parameter:: int_dom_ti_char =       220
+  integer,parameter:: int_dom_ti_real =       140
+  integer,parameter:: int_dom_ti_integer =       180
+  integer hdrbufsize
+  integer inttypesize
+  integer datahandle,count
+  character(128) element,dumstr,strdata
+  integer loccode
+  character(132) blanks
+  integer typesize
+  integer fieldtype,comm,iocomm
+  integer domaindesc
+  character(132) memoryorder,stagger,dimnames(3)
+  integer domainstart(3),domainend(3)
+  integer memorystart(3),memoryend(3)
+  integer patchstart(3),patchend(3)
+  character(132) datestr,varname
+  real(r_single) dummy_field(1)
+!  integer dummy_field
+!  real dummy_field
+  integer itypesize
+  integer idata(1)
+  real rdata(16)
+
+  call wrf_sizeof_integer(itypesize)
+  inttypesize=itypesize
+
+  blanks=trim(' ')
+
+  open(in_unit,file=trim(wrf_ges_filename),access='direct',recl=lrecl)
+  irecs=0
+  missing=-9999
+  nextbyte=0_i_llong
+  locbyte=lrecl
+  nreads=0
+  lastbuf=.false.
+  do
+
+!   get length of next record
+
+    do i=1,4
+     nextbyte=nextbyte+1_i_llong
+     locbyte=locbyte+1_i_llong
+     if(locbyte > lrecl .and. lastbuf) go to 900
+     if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
+     lenrec4(i)=buf(locbyte)
+    end do
+    if(lenrec <= 0 .and. lastbuf) go to 900
+    if(lenrec <= 0 .and. .not. lastbuf) go to 885
+    nextbyte=nextbyte+1_i_llong
+    locbyte=locbyte+1_i_llong
+    if(locbyte > lrecl .and. lastbuf) go to 900
+    if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
+
+    irecs=irecs+1
+    start_block(irecs)=thisblock
+    start_byte(irecs)=locbyte
+    file_offset(irecs)=nextbyte-1_i_llong
+    hdrbuf4(1)=buf(locbyte)
+    hdrbuf4(2:4)=missing4(2:4)
+    hdrbuf4(5:8)=missing4(1:4)
+    datestr_all(irecs)=blanks
+    varname_all(irecs)=blanks
+    domainend_all(1:3,irecs)=0
+
+    loc_count=1
+    do i=2,8
+       if(loc_count.ge.lenrec) exit
+       loc_count=loc_count+1
+       nextbyte=nextbyte+1_i_llong
+       locbyte=locbyte+1_i_llong
+       if(locbyte > lrecl .and. lastbuf) go to 900
+       if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
+       hdrbuf4(i)=buf(locbyte)
+    end do
+
+!         if(lenrec==2048) write(6,*)' irecs,hdrbuf(2),int_dom_ti_char,int_field=', &
+!                                      irecs,hdrbuf(2),int_dom_ti_char,int_field
+
+    if(lenrec==2048.and.(hdrbuf(2) == int_dom_ti_char .or. hdrbuf(2) == int_field &
+    .or. hdrbuf(2) == int_dom_ti_real .or. hdrbuf(2) == int_dom_ti_integer)) then
+
+!    bring in next full record, so we can unpack datestr, varname, and domainend
+       do i=9,lenrec
+          loc_count=loc_count+1
+          nextbyte=nextbyte+1_i_llong
+          locbyte=locbyte+1_i_llong
+          if(locbyte > lrecl .and. lastbuf) go to 900
+          if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
+          hdrbuf4(i)=buf(locbyte)
+       end do
+
+       if(hdrbuf(2) == int_dom_ti_char) then
+
+          call int_get_ti_header_char(hdrbuf,hdrbufsize,inttypesize, &
+                   datahandle,element,dumstr,strdata,loccode)
+          varname_all(irecs)=trim(element)
+          datestr_all(irecs)=trim(strdata)
+!              write(6,*)' irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),trim(datestr_all(irecs))
+
+       else if(hdrbuf(2) == int_dom_ti_real) then
+
+          call int_get_ti_header_real(hdrbuf,hdrbufsize,inttypesize,typesize, &
+                   datahandle,element,rdata,count,loccode)
+          varname_all(irecs)=trim(element)
+!          datestr_all(irecs)=trim(strdata)
+!	write(6,*) 'count: ', count
+!              write(6,*)' irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),rdata(1:count)
+         
+       else if(hdrbuf(2) == int_dom_ti_integer) then
+
+          call int_get_ti_header_integer(hdrbuf,hdrbufsize,inttypesize,typesize, &
+                   datahandle,element,idata,count,loccode)
+          varname_all(irecs)=trim(element)
+!          datestr_all(irecs)=trim(strdata)
+!              write(6,*)' irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),idata(1:count)
+
+       else
+
+          call int_get_write_field_header(hdrbuf,hdrbufsize,inttypesize,typesize, &
+             datahandle,datestr,varname,dummy_field,fieldtype,comm,iocomm, &
+             domaindesc,memoryorder,stagger,dimnames, &
+             domainstart,domainend,memorystart,memoryend,patchstart,patchend)
+          varname_all(irecs)=trim(varname)
+          datestr_all(irecs)=trim(datestr)
+          domainend_all(1:3,irecs)=domainend(1:3)
+!              write(6,*)' irecs,datestr,domend,varname = ', &
+!                  irecs,trim(datestr_all(irecs)),domainend_all(1:3,irecs),trim(varname_all(irecs))
+
+       end if
+    end if
+
+    nextbyte=nextbyte-loc_count+lenrec
+    locbyte=locbyte-loc_count+lenrec
+    if(locbyte > lrecl .and. lastbuf) go to 900
+    if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
+    end_block(irecs)=thisblock
+    end_byte(irecs)=locbyte
+    lensave=lenrec
+    do i=1,4
+     nextbyte=nextbyte+1_i_llong
+     locbyte=locbyte+1_i_llong
+     if(locbyte > lrecl .and. lastbuf) go to 900
+     if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
+     lenrec4(i)=buf(locbyte)
+    end do
+    if(lenrec /= lensave) go to 890
+
+  end do
+
+880  continue
+     write(6,*)' reached impossible place in inventory_wrf_binary_file'
+     close(in_unit)
+     return
+
+885  continue
+     write(6,*)' problem in inventory_wrf_binary_file, lenrec has bad value before end of file'
+     write(6,*)'     lenrec =',lenrec
+     close(in_unit)
+     return
+
+890  continue
+     write(6,*)' problem in inventory_wrf_binary_file, beginning and ending rec len words unequal'
+     write(6,*)'     begining reclen =',lensave
+     write(6,*)'       ending reclen =',lenrec
+     write(6,*)'               irecs =',irecs
+     write(6,*)'               nrecs =',nrecs
+     close(in_unit)
+     return
+
+900  continue
+     write(6,*)' normal end of file reached in inventory_wrf_binary_file'
+     write(6,*)'        nblocks=',thisblock
+     write(6,*)'          irecs,nrecs=',irecs,nrecs
+     write(6,*)'         nreads=',nreads
+     close(in_unit)
+
+end subroutine inventory_wrf_binary_file
+
+SUBROUTINE wrf_sizeof_integer( retval )
+  IMPLICIT NONE
+  INTEGER retval
+! 4 is defined by CPP
+  retval = 4
+  RETURN
+END SUBROUTINE wrf_sizeof_integer
+
+SUBROUTINE wrf_sizeof_real( retval )
+  IMPLICIT NONE
+  INTEGER retval
+! 4 is defined by CPP
+  retval = 4
+  RETURN
+END SUBROUTINE wrf_sizeof_real
+subroutine count_recs_wrf_binary_file(in_unit,wrf_ges_filename,nrecs)
+!$$$  subprogram documentation block
+!                .      .    .                                       .
+! subprogram:    count_recs_binary_file  count # recs on wrf binary file
+!   prgmmr: parrish          org: np22                date: 2004-11-29
+!
+! abstract: count number of sequential records contained in wrf binary
+!             file.  this is done by opening the file in direct access
+!             mode with block length of 2**20, the size of the physical
+!             blocks on ibm "blue" and "white" machines.  for optimal
+!             performance, change block length to correspond to the
+!             physical block length of host machine disk space.
+!             records are counted by looking for the 4 byte starting
+!             and ending sequential record markers, which contain the
+!             record size in bytes.  only blocks are read which are known
+!             by simple calculation to contain these record markers.
+!             even though this is done on one processor, it is still
+!             very fast, and the time will always scale by the number of
+!             sequential records, not their size.  this step and the
+!             following inventory step consistently take less than 0.1 seconds
+!             to complete.
+!
+! program history log:
+!   2004-11-29  parrish
+!
+!   input argument list:
+!     in_unit          - fortran unit number where input file is opened through.
+!     wrf_ges_filename - filename of input wrf binary restart file
+!
+!   output argument list:
+!     nrecs            - number of sequential records found on input wrf binary restart fil
+!
+! attributes:
+!   language: f90
+!   machine:  ibm RS/6000 SP
+!
+!$$$
+
+!   do an initial read through of a wrf binary file, and get total number of sequential fil
+
+!   use kinds, only: r_single,i_byte,i_long,i_llong
+  implicit none
+
+  integer,intent(in)::in_unit
+  character(*),intent(in)::wrf_ges_filename
+  integer,intent(out)::nrecs
+
+  integer(i_llong) nextbyte,locbyte,thisblock
+  integer(i_byte) lenrec4(4)
+  integer(i_long) lenrec,lensave
+  equivalence (lenrec4(1),lenrec)
+  integer(i_byte) missing4(4)
+  integer(i_long) missing
+  equivalence (missing,missing4(1))
+  integer(i_llong),parameter:: lrecl=2**16-1
+  integer(i_byte) buf(lrecl)
+  integer i,loc_count,nreads
+  logical lastbuf
+
+  open(in_unit,file=trim(wrf_ges_filename),access='direct',recl=lrecl)
+  nrecs=0
+  missing=-9999
+  nextbyte=0_i_llong
+  locbyte=lrecl
+  nreads=0
+  lastbuf=.false.
+  do
+
+!   get length of next record
+
+    do i=1,4
+     nextbyte=nextbyte+1_i_llong
+     locbyte=locbyte+1_i_llong
+     if(locbyte > lrecl .and. lastbuf) go to 900
+     if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
+     lenrec4(i)=buf(locbyte)
+    end do
+    if(lenrec <= 0 .and. lastbuf) go to 900
+    if(lenrec <= 0 .and. .not.lastbuf) go to 885
+    nextbyte=nextbyte+1_i_llong
+    locbyte=locbyte+1_i_llong
+    if(locbyte > lrecl .and. lastbuf) go to 900
+    if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
+
+    nrecs=nrecs+1
+
+    loc_count=1
+    do i=2,4
+       if(loc_count.ge.lenrec) exit
+       loc_count=loc_count+1
+       nextbyte=nextbyte+1_i_llong
+       locbyte=locbyte+1_i_llong
+       if(locbyte > lrecl .and. lastbuf) go to 900
+       if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
+    end do
+    do i=1,4
+       if(loc_count.ge.lenrec) exit
+       loc_count=loc_count+1
+       nextbyte=nextbyte+1_i_llong
+       locbyte=locbyte+1_i_llong
+       if(locbyte > lrecl .and. lastbuf) go to 900
+       if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
+    end do
+    nextbyte=nextbyte-loc_count+lenrec
+    locbyte=locbyte-loc_count+lenrec
+    if(locbyte > lrecl .and. lastbuf) go to 900
+    if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
+    lensave=lenrec
+    do i=1,4
+     nextbyte=nextbyte+1_i_llong
+     locbyte=locbyte+1_i_llong
+     if(locbyte > lrecl .and. lastbuf) go to 900
+     if(locbyte > lrecl) call next_buf(in_unit,buf,nextbyte,locbyte,thisblock,lrecl,nreads,lastbuf)
+     lenrec4(i)=buf(locbyte)
+    end do
+    if(lenrec /= lensave) go to 890
+
+  end do
+
+880  continue
+     write(6,*)' reached impossible place in count_recs_wrf_binary_file'
+     close(in_unit)
+     return
+
+885  continue
+     write(6,*)' problem in count_recs_wrf_binary_file, lenrec has bad value before end of file'
+     write(6,*)'     lenrec =',lenrec
+     close(in_unit)
+     return
+
+890  continue
+     write(6,*)' problem in count_recs_wrf_binary_file, beginning and ending rec len words unequal'
+     write(6,*)'     begining reclen =',lensave
+     write(6,*)'       ending reclen =',lenrec
+     close(in_unit)
+     return
+
+900  continue
+     write(6,*)' normal end of file reached in count_recs_wrf_binary_file'
+     write(6,*)'        nblocks=',thisblock
+     write(6,*)'          nrecs=',nrecs
+     write(6,*)'         nreads=',nreads
+     close(in_unit)
+
+end subroutine count_recs_wrf_binary_file
+
+subroutine retrieve_field(in_unit,wrfges,out,start_block,end_block,start_byte,end_byte)
+!$$$  subprogram documentation block
+!                .      .    .                                       .
+! subprogram:    retrieve_field  retrieve field from wrf binary file
+!   prgmmr: parrish          org: np22                date: 2004-11-29
+!
+! abstract: still using direct access, retrieve a field from the wrf binary restart file.
+!
+! program history log:
+!   2004-11-29  parrish
+!
+!   input argument list:
+!     in_unit          - fortran unit number where input file is opened through.
+!     wrfges - filename of input wrf binary restart file
+!     start_block      - direct access block number containing 1st byte of record
+!                            (after 4 byte record mark)
+!     end_block        - direct access block number containing last byte of record
+!                            (before 4 byte record mark)
+!     start_byte       - relative byte address in direct access block of 1st byte of record
+!     end_byte         - relative byte address in direct access block of last byte of record
+!
+!   output argument list:
+!     out              - output buffer where desired field is deposited
+!
+! attributes:
+!   language: f90
+!   machine:  ibm RS/6000 SP
+!
+!$$$
+
+ ! use kinds, only: i_byte,i_kind
+  implicit none
+
+  integer(i_kind),intent(in)::in_unit
+  character(50),intent(in)::wrfges
+  integer(i_kind),intent(in)::start_block,end_block,start_byte,end_byte
+  integer(i_byte),intent(out)::out(*)
+
+  integer(i_llong),parameter:: lrecl=2**16-1
+  integer(i_byte) buf(lrecl)
+  integer(i_kind) i,ii,k
+  integer ierr, ibegin, iend
+
+  open(in_unit,file=trim(wrfges),access='direct',recl=lrecl)
+
+     write(6,*)' in retrieve_field, start_block,end_block=',start_block,end_block
+     write(6,*)' in retrieve_field, start_byte,end_byte=',start_byte,end_byte
+  ii=0
+  ierr=0
+  do k=start_block,end_block
+     read(in_unit,rec=k,iostat=ierr)buf
+     ibegin=1 ; iend=lrecl
+     if(k == start_block) ibegin=start_byte
+     if(k == end_block) iend=end_byte
+     do i=ibegin,iend
+        ii=ii+1
+        out(ii)=buf(i)
+     end do
+  end do
+  close(in_unit)
+
+end subroutine retrieve_field
+
+
+END MODULE module_si_io_nmm
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/nmm_loop_basemacros.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/nmm_loop_basemacros.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/nmm_loop_basemacros.h	(revision 17)
@@ -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))
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/nmm_loop_macros.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/nmm_loop_macros.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/nmm_loop_macros.h	(revision 17)
@@ -0,0 +1,130 @@
+! 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 MYJS5     MY_JS( 5 , 0  )
+
+#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  )
+#define MYJE5     MY_JE( 5 , 0  )
+
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/shift_domain_nmm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/shift_domain_nmm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/shift_domain_nmm.F	(revision 17)
@@ -0,0 +1,144 @@
+SUBROUTINE shift_domain_nmm ( grid , disp_x, disp_y &
+!
+# include <dummy_new_args.inc>
+!
+                           )
+   USE module_domain
+   USE module_timing
+   USE module_configure
+   USE module_dm
+   USE module_comm_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, ipf, jpf
+   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
+   TYPE( fieldlist ), POINTER :: p
+
+   LOGICAL :: E_BDY,N_BDY,S_BDY,W_BDY
+
+   CHARACTER(LEN=255) :: message
+
+   !  Definitions of dummy arguments to solve
+#include <dummy_new_decl.inc>
+
+!#define COPY_IN
+!#include <scalar_derefs.inc>
+
+#ifdef DM_PARALLEL
+#      include <data_calls.inc>
+#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     )
+
+
+   S_BDY=(JPS==JDS)
+   N_BDY=(JPE==JDE)
+   W_BDY=(IPS==IDS)
+   E_BDY=(IPE==IDE)
+
+   write(message,*)' S_BDY,N_BDY,W_BDY,E_BDY ', S_BDY,N_BDY,W_BDY,E_BDY
+   CALL wrf_message(trim(message))
+
+   grid%imask_nostag=0
+#if 1
+   IF ( disp_x > 0 ) THEN
+      IF ( E_BDY ) THEN 
+         DO J=jps,min(jde-1,jpe)
+         DO I=ips,min(ide-1,ipe-2-mod(j+1,2)) 
+            grid%imask_nostag(i,j) = 1
+         END DO
+         END DO
+      ELSE
+         DO J=jps,min(jde-1,jpe)
+         DO I=ips,min(ide-1,ipe)
+            grid%imask_nostag(i,j) = 1
+         END DO
+         END DO
+      END IF
+   END IF
+   IF ( disp_x < 0 ) THEN
+      IF ( W_BDY ) THEN 
+         DO J=jps,min(jde-1,jpe)
+         DO I=ips+1,min(ide-1,ipe)
+            grid%imask_nostag(i,j) = 1
+         END DO
+         END DO
+      ELSE
+         DO J=jps,min(jde-1,jpe)
+         DO I=ips,min(ide-1,ipe)
+            grid%imask_nostag(i,j) = 1
+         END DO
+         END DO
+      END IF
+   END IF
+   IF ( disp_y > 0 ) THEN
+      IF ( N_BDY ) THEN 
+         DO J=jps,min(jde-1,jpe-3)
+         DO I=ips,min(ide-1,ipe)
+            grid%imask_nostag(i,j) = 1
+         END DO
+         END DO
+      ELSE
+         DO J=jps,min(jde-1,jpe)
+         DO I=ips,min(ide-1,ipe)
+            grid%imask_nostag(i,j) = 1
+         END DO
+         END DO
+      END IF
+   END IF
+   IF ( disp_y < 0 ) THEN
+      IF ( S_BDY ) THEN
+         DO J=jps+2,min(jde-1,jpe)
+         DO I=ips,min(ide-1,ipe)
+            grid%imask_nostag(i,j) = 1
+         END DO
+         END DO
+      ELSE
+         DO J=jps,min(jde-1,jpe)
+         DO I=ips,min(ide-1,ipe)
+            grid%imask_nostag(i,j) = 1
+         END DO
+         END DO
+      END IF
+   END IF
+#else
+    grid%imask_nostag(ips:min(ide-4,ipe),jps:min(jde-1,jpe)) = 1
+!   grid%imask_nostag(ips+1:min(ide-2,ipe),jps+1:min(jde-2,jpe)) = 1
+!   grid%imask_nostag(ips+1:min(ide-1,ipe-1),jps+2:min(jde-1,jpe-2)) = 1
+#endif
+
+   px = isign(grid%parent_grid_ratio,disp_x)
+   py = isign(grid%parent_grid_ratio,disp_y)
+
+#ifdef DM_PARALLEL
+! shift the nest domain in x
+   do ii = 1,abs(disp_x)
+#include <../inc/SHIFT_HALO_X_HALO.inc>
+#include <../frame/loop_based_x_shift_code.h>
+   enddo
+
+! shift the nest domain in y
+   do ii = 1,abs(disp_y)
+#include <../inc/SHIFT_HALO_Y_HALO.inc>
+#include <../frame/loop_based_y_shift_code.h>
+   enddo
+#endif
+
+!#define COPY_OUT
+!#include <scalar_derefs.inc>
+
+END SUBROUTINE shift_domain_nmm
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/solve_nmm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/solve_nmm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/solve_nmm.F	(revision 17)
@@ -0,0 +1,3185 @@
+!-----------------------------------------------------------------------
+!
+!NCEP_MESO:MEDIATION_LAYER:SOLVER
+!
+!-----------------------------------------------------------------------
+#include "nmm_loop_basemacros.h"
+#include "nmm_loop_macros.h"
+!-----------------------------------------------------------------------
+!
+      SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
+!
+#include "dummy_new_args.inc"
+!
+     &           )
+!-----------------------------------------------------------------------
+      USE MODULE_DOMAIN,                ONLY : DOMAIN, GET_IJK_FROM_GRID
+      USE MODULE_CONFIGURE,             ONLY : GRID_CONFIG_REC_TYPE
+      USE MODULE_MODEL_CONSTANTS
+      USE MODULE_STATE_DESCRIPTION
+      USE MODULE_CTLBLK
+#ifdef DM_PARALLEL
+      USE MODULE_DM,                    ONLY : LOCAL_COMMUNICATOR       &
+                                              ,MYTASK,NTASKS,NTASKS_X   &
+                                              ,NTASKS_Y
+      USE MODULE_COMM_DM
+#endif
+      USE MODULE_IGWAVE_ADJUST,         ONLY: PDTE,PFDHT,DDAMP,VTOA
+      USE MODULE_ADVECTION,             ONLY: ADVE,VAD2,HAD2            &
+                                             ,ADV2,MONO                 &
+                                             ,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     ! USEs module_MPP (contains MYPE,NPES,MPI_COMM_COMP)
+#ifdef WRF_CHEM
+      USE MODULE_INPUT_CHEM_DATA,       ONLY: GET_LAST_GAS
+#endif
+!-----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!-----------------------------------------------------------------------
+!
+!***  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 <dummy_new_decl.inc>
+!----------------------------
+!
+!***  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,IRTN,J,JC,JDF,K,KDF,LB,N_MOIST &
+     &          ,NTSD_current,L
+#ifdef HWRF
+!zhang's doing
+      INTEGER,SAVE :: NTSD_restart1,NTSD_restart2,NTSD_restart3
+#endif
+      integer :: ierr
+      INTEGER,SAVE :: NTSD_restart
+!     INTEGER :: MPI_COMM_COMP,MYPE,MYPROC,NPES
+      INTEGER :: MYPROC
+      INTEGER :: KVH,NTSD_rad,RC
+      INTEGER :: NUM_OZMIXM,NUM_AEROSOLC
+!
+      REAL :: DT_INV,FICE,FRAIN,GPS,QI,QR,QW,WC,WP
+!
+      LOGICAL :: LAST_TIME,OPERATIONAL_PHYSICS
+!
+      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
+!
+!-----------------------------------------------------------------------
+!
+      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    &
+#ifdef HWRF
+     &,            adjppt_tim,sst_tim,flux_tim
+#else
+     &,            adjppt_tim
+#endif
+      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 :: 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
+!
+!-----------------------------------------------------------------------
+!***  Passive substance variables
+!-----------------------------------------------------------------------
+!
+      LOGICAL :: EULER
+      INTEGER :: IDTADT 
+      INTEGER :: IDTADC
+      INTEGER :: KS                                                        ! species index in 4d tracer array
+!
+      REAL,SAVE :: SUMDRRW
+!
+#ifdef WRF_CHEM
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:,:) ::      &  ! i,j,k,ks
+                                                  CHE  &  ! 4d i,j,k chem tracers
+                                                 ,CH1  &  ! intermediate tracer variable
+                                                 ,CHP  &  ! ch1 at previous time level
+                                                 ,TCC     ! time change of tracers
+#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 <scalar_derefs.inc>
+!-----------------------------------------------------------------------
+!
+! 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.
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!***********************************************************************
+!***
+!***               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
+#ifdef HWRF
+!zhang's doing: temporarily hardwired for two domains
+          if( grid%id .eq. 1 ) NTSD_restart1=INT(grid%TSTART*3600./GRID%DT+0.5)
+          if( grid%id .eq. 2 ) NTSD_restart2=INT(grid%TSTART*3600./GRID%DT+0.5)
+          if( grid%id .eq. 3 ) NTSD_restart3=INT(grid%TSTART*3600./GRID%DT+0.5)
+#endif
+          IHRST=grid%nstart_hour
+          NTSD_restart=grid%ntsd
+        ELSE
+          IHRST=GRID%GMT
+          grid%nstart_hour=IHRST
+#ifdef HWRF
+!zhang's doing
+          NTSD_restart1=0
+          NTSD_restart2=0
+          NTSD_restart3=0
+#else
+          NTSD_restart=0
+#endif
+        ENDIF
+      ENDIF
+#ifdef HWRF
+!zhang's doing
+      if( grid%id .eq. 1 ) grid%ntsd=NTSD_restart1+NTSD_current
+      if( grid%id .eq. 2 ) grid%ntsd=NTSD_restart2+NTSD_current
+      if( grid%id .eq. 3 ) grid%ntsd=NTSD_restart3+NTSD_current
+#else
+      grid%ntsd=NTSD_restart+NTSD_current
+#endif
+      LAST_TIME=domain_last_time_step(GRID)
+!
+!-----------------------------------------------------------------------
+!
+!!!!! IF(WRF_DM_ON_MONITOR() )THEN
+        WRITE(MESSAGE,125)grid%ntsd,grid%ntsd*GRID%DT/3600.
+  125   FORMAT(' SOLVE_NMM: TIMESTEP IS ',I5,'   TIME IS ',F7.3,' HOURS')
+        CALL WRF_MESSAGE(TRIM(MESSAGE))
+!!!!  ENDIF
+!
+!-----------------------------------------------------------------------
+!
+      EULER=model_config_rec%EULER_ADV
+      IDTADT=model_config_rec%IDTADT
+      IDTADC=model_config_rec%IDTADC
+      WP=model_config_rec%WP(grid%id)
+!
+!-----------------------------------------------------------------------
+      CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+      CALL WRF_GET_NPROC(NPES)
+      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)
+!
+!-----------------------------------------------------------------------
+!***  SET FLAG FOR THE OPERATIONAL PHYSICS SUITE.
+!***  THIS WILL BE USED TO SAVE CLOCKTIME BY SKIPPING
+!***  FREQUENT UPDATES OF THE MOIST ARRAY AND INSTEAD
+!***  UPDATE IT ONLY WHEN IT IS NEEDED FOR PHYSICS.
+!-----------------------------------------------------------------------
+!
+      OPERATIONAL_PHYSICS=.FALSE.
+!
+      IF(CONFIG_FLAGS%RA_SW_PHYSICS    ==GFDLSWSCHEME.AND.              &
+     &   CONFIG_FLAGS%RA_LW_PHYSICS    ==GFDLLWSCHEME.AND.              &
+     &   CONFIG_FLAGS%SF_SFCLAY_PHYSICS==MYJSFCSCHEME.AND.              &
+     &   CONFIG_FLAGS%BL_PBL_PHYSICS   ==MYJPBLSCHEME.AND.              &
+     &   CONFIG_FLAGS%CU_PHYSICS       ==BMJSCHEME.AND.                 &
+     &   (CONFIG_FLAGS%MP_PHYSICS       ==ETAMPNEW.or.                  &
+     &    CONFIG_FLAGS%MP_PHYSICS==ETAMP_HWRF))THEN
+!
+        OPERATIONAL_PHYSICS=.TRUE.
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!
+!***  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
+!
+      IF(CONFIG_FLAGS%CU_PHYSICS==GDSCHEME)THEN
+        DO J=JMS,JME
+        DO K=KMS,KME
+        DO I=IMS,IME
+          TTEN(I,K,J)=grid%t(I,J,K)
+          QTEN(I,K,J)=grid%q(I,J,K)
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDIF
+!
+      GRID%SIGMA=1 
+      grid%hydro=.FALSE.
+!
+!
+      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)
+!-----------------------------------------------------------------------
+!
+      write(0,*)'grid%ntsd=',grid%ntsd
+      if(grid%ntsd==0)then
+        write(message,*)' its=',its,' ite=',ite
+        call wrf_message(trim(message))
+        write(message,*)' jts=',jts,' jte=',jte
+        call wrf_message(trim(message))
+        write(message,*)' kts=',kts,' kte=',kte
+        call wrf_message(trim(message))
+!
+#ifdef WRF_CHEM
+        ALLOCATE (CHE(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT)
+        ALLOCATE (CH1(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT)
+        ALLOCATE (CHP(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT)
+        ALLOCATE (TCC(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT)
+#endif
+!-----------------------------------------------------------------------
+      endif
+!-----------------------------------------------------------------------
+!***  SET TIMING VARIABLES TO ZERO AT START OF FORECAST.
+!-----------------------------------------------------------------------
+      if(grid%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
+        grid%iheg(J)=MOD(J+1,2)
+        grid%ihwg(J)=grid%iheg(J)-1
+        grid%iveg(J)=MOD(J,2)
+        grid%ivwg(J)=grid%iveg(J)-1
+      ENDDO
+
+      DO J=MYJS_P4,MYJE_P4
+        grid%ivw(J)=grid%ivwg(J)
+        grid%ive(J)=grid%iveg(J)
+        grid%ihe(J)=grid%iheg(J)
+        grid%ihw(J)=grid%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(grid%dx_nmm(IMS,JC)**2+grid%dy_nmm**2)
+!
+!***  TIMESTEPS PER HOUR
+!
+      TSPH=3600./GRID%DT
+!
+      n_print_time=nint(3600./grid%dt)   ! Print stats once per hour
+!-----------------------------------------------------------------------
+!
+      NBOCO=0
+!
+!-----------------------------------------------------------------------
+!
+#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 (grid%PD_BXS,grid%PD_BXE,grid%PD_BYS,grid%PD_BYE,grid%T_BXS,grid%T_BXE,grid%T_BYS,grid%T_BYE,grid%Q_BXS,grid%Q_BXE         &
+                          ,grid%Q_BYS,grid%Q_BYE,grid%U_BXS,grid%U_BXE,grid%U_BYS,grid%U_BYE,grid%V_BXS,grid%V_BXE,grid%V_BYS,grid%V_BYE             &
+                          ,grid%Q2_BXS,grid%Q2_BXE,grid%Q2_BYS,grid%Q2_BYE,grid%CWM_BXS,grid%CWM_BXE,grid%CWM_BYS,grid%CWM_BYE             &
+                          ,grid%PD_BTXS,grid%PD_BTXE,grid%PD_BTYS,grid%PD_BTYE,grid%T_BTXS,grid%T_BTXE,grid%T_BTYS,grid%T_BTYE             &
+                          ,grid%Q_BTXS,grid%Q_BTXE,grid%Q_BTYS,grid%Q_BTYE,grid%U_BTXS,grid%U_BTXE,grid%U_BTYS,grid%U_BTYE                 &
+                          ,grid%V_BTXS,grid%V_BTXE,grid%V_BTYS,grid%V_BTYE,grid%Q2_BTXS,grid%Q2_BTXE,grid%Q2_BTYS,grid%Q2_BTYE             &
+                          ,grid%CWM_BTXS,grid%CWM_BTXE,grid%CWM_BTYS,grid%CWM_BTYE,grid%pdnest_b,grid%tnest_b,grid%qnest_b,grid%unest_b    &
+                          ,grid%vnest_b,grid%q2nest_b,grid%cwmnest_b,grid%pdnest_bt,grid%tnest_bt,grid%qnest_bt                  &
+                          ,grid%unest_bt,grid%vnest_bt,grid%q2nest_bt,grid%cwmnest_bt                                  &
+                          ,GRID%SPEC_BDY_WIDTH                                                     &
+                          ,IDS,IDF,JDS,JDF,KDS,KDE                                                 &
+                          ,IMS,IME,JMS,JME,KMS,KME                                                 &
+                          ,ITS,ITE,JTS,JTE,KTS,KTE                                                 )
+
+!
+#ifdef MOVE_NESTS
+
+        IF(GRID%ID/=1.AND.MOD(grid%ntsd,1)==0.AND.GRID%NUM_MOVES==-99)THEN
+          grid%XLOC_1=(IDE-1)/2     ! This maneuvers the storm to the center of the nest quickly
+          grid%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 grid%ddata to 999. (this is the amount
+!***               of input precip allocated to each physics time step
+!***               in ADJPPT; TURBL/SURFCE, which uses grid%ddata, is called
+!***               before ADJPPT)
+!***            3) Initialize grid%lspa to zero
+!***
+!-----------------------------------------------------------------------
+
+      IF (grid%ntsd==0) THEN
+        IF (GRID%PCPFLG) THEN
+          CALL READPCP(PPTDAT,grid%ddata,grid%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(grid%ntsd,grid%nprec,grid%nsrfc,grid%nrdsw,grid%nrdlw                         &
+     &            ,GRID%RESTART,GRID%TSTART                             &
+     &            ,grid%nclod,grid%nheat,GRID%NPHS,TSPH                           &
+     &            ,grid%acprec,grid%cuprec,grid%acsnow,grid%acsnom,grid%ssroff,grid%bgroff            &
+     &            ,grid%sfcevp,grid%potevp,grid%sfcshx,grid%sfclhx,grid%subshx,grid%snopcx            &
+     &            ,grid%sfcuvx,grid%potflx                                        &
+     &            ,grid%ardsw,grid%aswin,grid%aswout,grid%aswtoa                            &
+     &            ,grid%ardlw,grid%alwin,grid%alwout,grid%alwtoa                            &
+     &            ,grid%acfrst,grid%ncfrst,grid%acfrcv,grid%ncfrcv                          &
+     &            ,grid%avcnvc,grid%avrain,grid%tcucn,grid%train                            &
+     &            ,grid%asrfc                                                &
+     &            ,grid%t,grid%tlmax,grid%tlmin,grid%tshltr,grid%pshltr,grid%qshltr                   &
+     &            ,grid%t02_max,grid%t02_min,grid%rh02_max,grid%rh02_min                    &
+     &            ,IDS,IDE,JDS,JDE,KDS,KDE                              &
+     &            ,IMS,IME,JMS,JME,KMS,KME                              &
+     &            ,ITS,ITE,JTS,JTE,KTS,KTE)
+!-----------------------------------------------------------------------
+!
+#ifdef HWRF
+!zhang
+      IF(NTSD_current==0)THEN
+#else
+      IF(grid%ntsd==0)THEN
+#endif
+        FIRST=.TRUE.
+!       call hpm_init()
+        btimx=timef()
+!emc_2010_bugfix_h50
+        grid%mommix=amin1(grid%mommix,1.0)
+!emc_2010_bugfix_h50
+!
+!-----------------------------------------------------------------------
+!***  FIRST STEP INITIALIZATION OF PASSIVE SUBSTANCE VARIABLES
+!-----------------------------------------------------------------------
+!
+      IF(EULER) THEN
+        SUMDRRW=0.
+!
+        DO K=KTS,KTE
+          DO J=JMS,JME
+            DO I=IMS,IME
+              grid%rrw(I,J,K)=0.
+!
+              IF(I>=IDE/2-6.AND.I<=IDE/2+6.AND.   &
+                 J>=JDE/2-6.AND.J<=JDE/2+6     ) THEN
+                grid%rrw(I,J,K)=10.0 !youhua
+!               grid%rrw(I,J,K)=0.9  !zj
+              ENDIF
+!
+            ENDDO
+          ENDDO
+        ENDDO
+!
+        DO KS=PARAM_FIRST_SCALAR,NUM_SZJ
+          DO K=KMS,KME
+            DO J=JMS,JME
+              DO I=IMS,IME
+                SZJ(I,J,K,KS)=0.
+                S1Z(I,J,K,KS)=0.
+                SPZ(I,J,K,KS)=0.
+                TCS(I,J,K,KS)=0.
+              ENDDO
+            ENDDO
+          ENDDO
+        ENDDO
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!
+#ifdef WRF_CHEM
+      DO KS=1,NUM_CHEM
+        DO K=KMS,KME
+          DO J=JMS,JME
+            DO I=IMS,IME
+              CHE(I,J,K,KS)=0.
+              CH1(I,J,K,KS)=0.
+              CHP(I,J,K,KS)=0.
+              TCC(I,J,K,KS)=0.
+            ENDDO
+          ENDDO
+        ENDDO
+      ENDDO
+#endif
+!
+!-----------------------------------------------------------------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_A.inc"
+#endif
+!
+!-----------------------------------------------------------------------
+#ifdef DM_PARALLEL
+      IF(CONFIG_FLAGS%MP_PHYSICS/=ETAMPNEW.and.CONFIG_FLAGS%MP_PHYSICS/=ETAMP_HWRF)THEN
+#    include "HALO_NMM_A_3.inc"
+      ENDIF
+#endif
+!-----------------------------------------------------------------------
+!***  FIRST STEP INITIALIZATION OF PASSIVE SUBSTANCE VARIABLES
+!-----------------------------------------------------------------------
+!
+      IF(EULER) THEN
+!
+        DO K=KTS,KTE
+          DO J=JMS,JME
+            DO I=IMS,IME
+              SPZ(I,J,K,P_SPZ1)=SQRT(MAX(grid%q  (I,J,K),EPSQ))
+              SPZ(I,J,K,P_SPZ2)=SQRT(MAX(grid%cwm(I,J,K),EPSQ))
+              SPZ(I,J,K,P_SPZ4)=SQRT(MAX(grid%rrw(I,J,K),0.  ))
+            ENDDO
+          ENDDO
+        ENDDO
+!
+        DO J=JMS,JME
+          DO I=IMS,IME
+            SPZ(I,J,KTE,P_SPZ3)=SQRT(MAX((grid%q2(I,J,KTE)+EPSQ2)*0.5,EPSQ2))
+          ENDDO
+        ENDDO
+!
+        DO K=KTE-1,KTS,-1
+          DO J=JMS,JME
+            DO I=IMS,IME
+              SPZ(I,J,K,P_SPZ3)=SQRT(MAX((grid%q2(I,J,K)+grid%q2(I,J,K+1))*0.5,EPSQ2))
+            ENDDO
+          ENDDO
+        ENDDO
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!
+#ifdef WRF_CHEM
+      DO KS=1,NUM_CHEM
+        DO K=KMS,KME
+          DO J=JMS,JME
+            DO I=IMS,IME
+              CHP(I,J,K,KS)=SQRT(MAX(CHEM(I,K,J,KS),0.  ))
+            ENDDO
+          ENDDO
+        ENDDO
+      ENDDO
+#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
+!-----------------------------------------------------------------------
+!
+#ifdef HWRF
+!zhang's doing
+       if(GRID%RESTART) then
+       FIRST=.FALSE.
+       else
+       GO TO 2003
+       endif
+!end of zhang's doing
+#else
+        GO TO 2003
+#endif
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+ 2000 CONTINUE
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+#ifdef HWRF
+! Coupling insertion:->
+!
+!zhang's doing      call ATM_TSTEP_INIT(NTSD,grid%NPHS,GRID%ID,grid%NPHS*grid%dt, &
+      call ATM_TSTEP_INIT(NTSD_current,grid%NPHS,GRID%ID,grid%NPHS*grid%dt, &
+!end of zhang's doing
+      ids,idf,jds,jdf,its,ite,jts,jte,ims,ime,jms,jme,           &
+                       kds,kde,kts,kte,kms,kme,                  &
+                       grid%HLON,grid%HLAT,grid%VLON,grid%VLAT,grid%sm,                   &
+                       grid%i_parent_start,grid%j_parent_start)
+!     CALL ATM_RECVdtc(NPHS*dt) <-  now called from ATM_TSTEP_INIT with no arg.
+!     CALL ATM_SENDGRIDS(HLON,HLAT,VLON,VLAT) <- now called from ATM_TSTEP_INIT
+!     CALL ATM_SENDSLM(grid%sm)                    <- now called from ATM_TSTEP_INIT
+!<-:coupling insertion
+!
+#endif
+!-----------------------------------------------------------------------
+!***  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,MYPE,MPI_COMM_COMP,                              &
+#endif
+     &            grid%ntsd,GRID%DT,grid%pt,grid%eta2,grid%res,grid%hydro,grid%hbm2                   &
+     &           ,grid%pd,grid%pdsl,grid%pdslo                                         &
+     &           ,grid%petdt,grid%div,grid%psdt                                        &
+     &           ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                       &
+     &           ,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 grid%t, grid%u, AND grid%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(grid%ntsd,GRID%DT,grid%deta1,grid%deta2,grid%pdtop                          &
+     &         ,grid%curv,grid%f,grid%fad,grid%f4d,grid%em_loc,grid%emt_loc,grid%en,grid%ent,grid%dx_nmm,grid%dy_nmm      &
+     &         ,grid%hbm2,grid%vbm2                                               &
+     &         ,grid%t,grid%u,grid%v,grid%pdslo,grid%told,grid%uold,grid%vold                              &
+     &         ,grid%petdt,grid%upstrm                                            &
+     &         ,grid%few,grid%fns,grid%fne,grid%fse                                         &
+     &         ,grid%adt,grid%adu,grid%adv                                             & 
+     &         ,grid%n_iup_h,grid%n_iup_v                                         &
+     &         ,grid%n_iup_adh,grid%n_iup_adv                                     &
+     &         ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv                             &
+     &         ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                         &
+     &         ,IDS,IDF,JDS,JDF,KDS,KDE                                 &
+     &         ,IMS,IME,JMS,JME,KMS,KME                                 &
+     &         ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      adve_tim=adve_tim+timef()-btimx
+!
+!-----------------------------------------------------------------------
+!***  PASSIVE SUBSTANCE WORKING PART
+!-----------------------------------------------------------------------
+!
+      eulerian: IF(EULER) THEN    ! Eulerian advection for model tracers
+!
+!-----------------------------------------------------------------------
+!
+!mp - allow for it to be applied in the no-physics realm
+        IF(config_flags%MP_PHYSICS/=ETAMPNEW.and.CONFIG_FLAGS%MP_PHYSICS/=ETAMP_HWRF.and.CONFIG_FLAGS%MP_PHYSICS/=0) THEN
+          WRITE( wrf_err_message , * ) 'EULER advection works only with ETAMPNEW microphysics.'
+          CALL wrf_error_fatal ( wrf_err_message )
+        ENDIF
+!
+!-----------------------------------------------------------------------
+        idtadt_block: IF(MOD(grid%ntsd,IDTADT)==0) THEN
+!-----------------------------------------------------------------------
+          btimx=timef()
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_I.inc"
+#endif
+          exch_tim=exch_tim+timef()-btimx
+!
+          btimx=timef()
+!
+          DO K=KTS,KTE
+            DO J=JMS,JME
+              DO I=IMS,IME
+                SZJ(I,J,K,P_SPZ1)=MAX(grid%q  (I,J,K),EPSQ)
+                SZJ(I,J,K,P_SPZ2)=MAX(grid%cwm(I,J,K),EPSQ)
+                SZJ(I,J,K,P_SPZ4)=MAX(grid%rrw(I,J,K),0.  )
+              ENDDO
+            ENDDO
+          ENDDO
+!
+          DO J=JMS,JME
+            DO I=IMS,IME
+              SZJ(I,J,KTE,P_SPZ3)=MAX((grid%q2 (I,J,KTE)+EPSQ2)*0.5,EPSQ2)
+            ENDDO
+          ENDDO
+!
+          DO K=KTE-1,KTS,-1
+            DO J=JMS,JME
+              DO I=IMS,IME
+                SZJ(I,J,K,P_SPZ3)=MAX((grid%q2 (I,J,K)+grid%q2 (I,J,K+1))*0.5,EPSQ2)
+              ENDDO
+            ENDDO
+          ENDDO
+!
+#ifdef DM_PARALLEL
+#    include "HALO_TRACERS.inc"
+#endif
+          CALL ADV2                &
+          (grid%upstrm                  &
+          ,MYPE,PARAM_FIRST_SCALAR,NUM_SZJ &
+          ,IDS,IDE,JDS,JDE,KDS,KDE &
+          ,IMS,IME,JMS,JME,KMS,KME &
+          ,ITS,ITE,JTS,JTE,KTS,KTE &
+          ,grid%n_iup_h                 &
+          ,grid%n_iup_adh               &
+          ,grid%iup_h,grid%iup_adh           &
+          ,grid%ent                     &
+          ,IDTADT                  &
+          ,grid%DT,grid%pdtop           &
+          ,grid%ihe,grid%ihw,grid%ive,grid%ivw         &
+          ,grid%deta1,grid%deta2             &
+          ,grid%emt_loc                 &
+          ,grid%fad,grid%hbm2,grid%pdsl,grid%pdslo     &
+          ,grid%petdt                   &
+          ,grid%uold,grid%vold               &
+          ,SZJ,SPZ                 &
+          !temporary arguments
+          ,grid%fne,grid%fse,grid%few,grid%fns,S1Z,TCS)
+!
+#ifdef DM_PARALLEL
+#    include "HALO_TRACERS.inc"
+#endif
+          CALL MONO &
+          (         &
+#if defined(DM_PARALLEL)
+           GRID%DOMDESC, &
+#endif
+           MYPE,grid%ntsd,grid%ntsd*GRID%DT/3600.,PARAM_FIRST_SCALAR,NUM_SZJ &
+          ,IDS,IDE,JDS,JDE,KDS,KDE              &
+          ,IMS,IME,JMS,JME,KMS,KME              &
+          ,ITS,ITE,JTS,JTE,KTS,KTE              &
+          ,IDTADT                               &
+          ,grid%dy_nmm,grid%pdtop                         &
+          ,SUMDRRW                              &
+          ,grid%ihe,grid%ihw                              &
+          ,grid%deta1,grid%deta2                          &
+          ,grid%dx_nmm,grid%hbm2,grid%pdsl                     &
+          ,SZJ                                  &
+          !temporary arguments
+          ,S1Z,TCS)
+!
+          DO KS=PARAM_FIRST_SCALAR,NUM_SZJ ! loop by species
+            DO K=KTS,KTE
+              DO J=MYJS2,MYJE2
+                DO I=MYIS1,MYIE1
+                  SZJ(I,J,K,KS)=SZJ(I,J,K,KS)+TCS(I,J,K,KS)
+                ENDDO
+              ENDDO
+            ENDDO
+          ENDDO         ! end of the loop by the species
+!
+          DO K=KTS,KTE
+            DO J=MYJS2,MYJE2
+              DO I=MYIS1,MYIE1
+                grid%q  (I,J,K)=SZJ(I,J,K,P_SZJ1)
+                grid%cwm(I,J,K)=SZJ(I,J,K,P_SZJ2)
+                grid%rrw(I,J,K)=SZJ(I,J,K,P_SZJ4)
+              ENDDO
+            ENDDO
+          ENDDO
+!
+          DO J=MYJS2,MYJE2
+            DO I=MYIS1,MYIE1
+              grid%q2(I,J,KTE)=MAX(SZJ(I,J,KTE,P_SZJ3)+SZJ(I,J,KTE,P_SZJ3)-EPSQ2 &
+                             ,EPSQ2)
+            ENDDO
+          ENDDO
+!
+          DO K=KTE-1,KTS+1,-1
+            DO J=MYJS2,MYJE2
+              DO I=MYIS1,MYIE1
+                IF(K>KTS)THEN
+                  grid%q2(I,J,K)=MAX(SZJ(I,J,K,P_SZJ3)+SZJ(I,J,K,P_SZJ3)-grid%q2(I,J,K+1) &
+                               ,EPSQ2)
+                ELSE
+                  grid%q2(I,J,K)=grid%q2(I,J,K+1)
+                ENDIF
+              ENDDO
+            ENDDO
+          ENDDO
+!-----------------------------------------------------------------------
+
+!
+!***  UPDATE MOIST ARRAY.
+!***  REMEMBER THAT MOIST IS ONLY USED WITH THE PHYSICS AND THUS
+!***  THE P_QV SLOT (=2) IS MIXING RATIO, NOT SPECIFIC HUMIDITY.
+!***  ALTHOUGH MOIST IS ONLY USED FOR PHYSICS IN OPERATIONS, IT IS
+!***  UPDATED HERE FROM grid%q EVERY ADVECTION TIMESTEP FOR NON-OPERATIONAL
+!***  CONFIGURATIONS WHERE IT MAY BE USED OUTSIDE OF THE PHYSICS.
+!
+        IF(.NOT.OPERATIONAL_PHYSICS)THEN
+          DO K=KTS,KTE
+            DO J=MYJS,MYJE
+              DO I=MYIS,MYIE
+                MOIST(I,J,K,P_QV)=grid%q(I,J,K)/(1.-grid%q(I,J,K))
+                WC = grid%cwm(I,J,K)
+                QI = 0.
+                QR = 0.
+                QW = 0.
+                FICE=grid%f_ice(I,K,J)
+                FRAIN=grid%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,J,K,P_QC)=QW
+                MOIST(I,J,K,P_QR)=QR
+                MOIST(I,J,K,P_QI)=0.
+                MOIST(I,J,K,P_QS)=QI
+                MOIST(I,J,K,P_QG)=0.
+              ENDDO
+            ENDDO
+          ENDDO
+        ENDIF
+!
+        had2_tim=had2_tim+timef()-btimx
+!-----------------------------------------------------------------------
+!
+        ENDIF idtadt_block
+!
+!-----------------------------------------------------------------------
+!
+      ENDIF eulerian  ! eulerian advection for model tracers
+!
+!-----------------------------------------------------------------------
+!
+#ifdef WRF_CHEM
+!-----------------------------------------------------------------------
+!
+      idtadc_block: IF(MOD(grid%ntsd,IDTADC)==0) THEN
+!
+!-----------------------------------------------------------------------
+        btimx=timef()
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_I_2.inc"
+#endif
+        exch_tim=exch_tim+timef()-btimx
+!
+        btimx=timef()
+!
+        do KS=1,NUM_CHEM
+          DO K=KTS,KTE
+            DO J=JMS,JME
+              DO I=IMS,IME
+                CHE(I,J,K,KS)=MAX(CHEM(I,K,J,KS),0.  )
+              ENDDO
+            ENDDO
+          ENDDO
+        ENDDO
+!
+        CALL ADV2                &
+        (grid%upstrm                  &
+        ,MYPE,1,NUM_CHEM         &
+        ,IDS,IDE,JDS,JDE,KDS,KDE &
+        ,IMS,IME,JMS,JME,KMS,KME &
+        ,ITS,ITE,JTS,JTE,KTS,KTE &
+        ,grid%n_iup_h                 &
+        ,grid%n_iup_adh               &
+        ,grid%iup_h,grid%iup_adh           &
+        ,grid%ent                     &
+        ,IDTADC                  &
+        ,grid%DT,grid%pdtop           &
+        ,grid%ihe,grid%ihw,grid%ive,grid%ivw         &
+        ,grid%deta1,grid%deta2             &
+        ,grid%emt_loc                 &
+        ,grid%fad,grid%hbm2,grid%pdsl,grid%pdslo     &
+        ,grid%petdt                   &
+        ,grid%uold,grid%vold               &
+        ,CHE,CHP                 &
+        !temporary arguments
+        ,grid%fne,grid%fse,grid%few,grid%fns,CH1,TCC)
+!
+        CALL MONO &
+        (         &
+#if defined(DM_PARALLEL)
+         GRID%DOMDESC, &
+#endif
+         MYPE,grid%ntsd,grid%ntsd*GRID%DT/3600.,1,NUM_CHEM &
+        ,IDS,IDE,JDS,JDE,KDS,KDE &
+        ,IMS,IME,JMS,JME,KMS,KME &
+        ,ITS,ITE,JTS,JTE,KTS,KTE &
+        ,IDTADT                  &
+        ,grid%dy_nmm,grid%pdtop            &
+        ,SUMDRRW                 &
+        ,grid%ihe,grid%ihw                 &
+        ,grid%deta1,grid%deta2             &
+        ,grid%dx_nmm,grid%hbm2,grid%pdsl        &
+        ,CHE                     &
+        !temporary arguments
+        ,CH1,TCC)
+!
+        DO KS=1,NUM_CHEM
+          DO K=KTS,KTE
+            DO J=JMS,JME
+              DO I=IMS,IME
+                CHEM(I,K,J,KS)=CHE(I,J,K,KS)+TCC(I,J,K,KS)
+              ENDDO
+            ENDDO
+          ENDDO
+        ENDDO
+!-----------------------------------------------------------------------
+!
+      ENDIF idtadc_block
+!
+!-----------------------------------------------------------------------
+#endif
+!
+!-----------------------------------------------------------------------
+!***  PRESSURE TENDENCY, ETA/SIGMADOT, VERTICAL PART OF OMEGA-ALPHA TERM
+!-----------------------------------------------------------------------
+!
+      btimx=timef()
+!
+      CALL VTOA(                                                        &
+#ifdef DM_PARALLEL
+     &          GRID,                                                   &
+#endif
+     &          grid%ntsd,GRID%DT,grid%pt,grid%eta2                                    &
+     &         ,grid%hbm2,grid%ef4t                                               &
+     &         ,grid%t,grid%dwdt,grid%rtop,grid%omgalf                                      &
+     &         ,grid%pint,grid%div,grid%psdt,grid%res                                       &
+     &         ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                         &
+     &         ,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(grid%ntsd,GRID%DT,grid%fis,GRID%SIGMA,grid%dfl,grid%hbm2                    &
+     &         ,grid%deta1,grid%deta2,grid%pdtop                                       &
+     &         ,grid%pint,grid%pdsl,grid%pdslo,grid%petdt                                   &
+     &         ,grid%rtop,grid%t,grid%q,grid%cwm,grid%z,grid%w,grid%dwdt,grid%pdwdt                             &
+     &         ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                         &
+     &         ,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(grid%ntsd,GRID%DT,grid%hydro,grid%hbm2,grid%deta1,grid%deta2,grid%pdtop               &
+     &         ,grid%dx_nmm,grid%dy_nmm,grid%fad                                       &
+     &         ,grid%few,grid%fns,grid%fne,grid%fse                                         &
+     &         ,grid%pdsl,grid%u,grid%v,grid%w,grid%z,WP                                    &
+     &         ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                         &
+     &         ,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 grid%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(grid%ntsd,GRID%DT,grid%hydro,grid%dx_nmm,grid%dy_nmm,grid%fad                     &
+     &        ,grid%deta1,grid%deta2,grid%pdtop,grid%pt                                     &
+     &        ,grid%hbm2,grid%hbm3                                                &
+     &        ,grid%pdsl,grid%pdslo,grid%pint,grid%rtop,grid%petdt,grid%pdwdt                         &
+     &        ,grid%dwdt,grid%dwdtmn,grid%dwdtmx                                       &
+     &        ,grid%fns,grid%few,grid%fne,grid%fse                                          &
+     &        ,grid%t,grid%u,grid%v,grid%w,grid%q,grid%cwm                                            &
+     &        ,grid%def3d,grid%hdac                                                &
+     &        ,WP                                                 &
+     &        ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                          &
+     &        ,IDS,IDF,JDS,JDF,KDS,KDE                                  &
+     &        ,IMS,IME,JMS,JME,KMS,KME                                  &
+     &        ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      eps_tim=eps_tim+timef()-btimx
+!
+!-----------------------------------------------------------------------
+!
+      not_euler: IF(.NOT.EULER) THEN ! Lagrangian model tracer advection
+!
+!-----------------------------------------------------------------------
+!***  VERTICAL ADVECTION OF grid%q, TKE, AND CLOUD WATER
+!-----------------------------------------------------------------------
+!
+      IF(MOD(grid%ntsd,GRID%IDTAD)==0)THEN
+        btimx=timef()
+!
+        vad2_micro_check: IF(CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW.or.CONFIG_FLAGS%MP_PHYSICS==ETAMP_HWRF)THEN
+          CALL VAD2(grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm               &
+     &             ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop,grid%hbm2             &
+     &             ,grid%q,grid%q2,grid%cwm,grid%petdt                                      &
+     &             ,grid%n_iup_h,grid%n_iup_v                                     &
+     &             ,grid%n_iup_adh,grid%n_iup_adv                                 &
+     &             ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv                         &
+     &             ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                     &
+     &             ,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(grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm          &
+     &                  ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop             &
+     &                  ,grid%hbm2                                           &
+     &                  ,grid%q2,grid%petdt                                       &
+     &                  ,grid%n_iup_h,grid%n_iup_v                                &
+     &                  ,grid%n_iup_adh,grid%n_iup_adv                            &
+     &                  ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv                    &
+     &                  ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                &
+     &                  ,1,1                                            &
+     &                  ,IDS,IDF,JDS,JDF,KDS,KDE                        &
+     &                  ,IMS,IME,JMS,JME,KMS,KME                        &
+     &                  ,ITS,ITE,JTS,JTE,KTS,KTE)                              
+     
+          CALL VAD2_SCAL(grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm          &
+     &                  ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop             &
+     &                  ,grid%hbm2                                           &
+     &                  ,MOIST,grid%petdt                                    &
+     &                  ,grid%n_iup_h,grid%n_iup_v                                &
+     &                  ,grid%n_iup_adh,grid%n_iup_adv                            &
+     &                  ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv                    &
+     &                  ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                &
+     &                  ,NUM_MOIST,2                                    &
+     &                  ,IDS,IDF,JDS,JDF,KDS,KDE                        &
+     &                  ,IMS,IME,JMS,JME,KMS,KME                        &
+     &                  ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+          CALL VAD2_SCAL(grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm          &
+     &                  ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop             &
+     &                  ,grid%hbm2                                           &
+     &                  ,SCALAR,grid%petdt                                   &
+     &                  ,grid%n_iup_h,grid%n_iup_v                                &
+     &                  ,grid%n_iup_adh,grid%n_iup_adv                            &
+     &                  ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv                    &
+     &                  ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                &
+     &                  ,NUM_SCALAR,2                                   &
+     &                  ,IDS,IDF,JDS,JDF,KDS,KDE                        &
+     &                  ,IMS,IME,JMS,JME,KMS,KME                        &
+     &                  ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+
+          DO K=KTS,KTE
+          DO J=MYJS,MYJE
+          DO I=MYIS,MYIE
+            grid%q(I,J,K)=MOIST(I,J,K,P_QV)/(1.+MOIST(I,J,K,P_QV))
+          ENDDO
+          ENDDO   
+          ENDDO   
+!
+        ENDIF vad2_micro_check
+!
+        vad2_tim=vad2_tim+timef()-btimx
+!
+      ENDIF
+!    
+!-----------------------------------------------------------------------
+!***  HORIZONTAL ADVECTION OF grid%q, TKE, AND CLOUD WATER
+!-----------------------------------------------------------------------
+!
+      idtad_block: IF(MOD(grid%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.and.CONFIG_FLAGS%MP_PHYSICS/=ETAMP_HWRF)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.or.CONFIG_FLAGS%MP_PHYSICS==ETAMP_HWRF)THEN
+!-----------------------------------------------------------------------
+!
+          CALL HAD2(                                                   &
+#if defined(DM_PARALLEL)
+     &              GRID%DOMDESC,                                      &
+#endif
+     &              grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm              &
+     &             ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop                 &
+     &             ,grid%hbm2,grid%hbm3                                          &
+     &             ,grid%q,grid%q2,grid%cwm,grid%u,grid%v,grid%z,grid%hydro                               &
+     &             ,grid%n_iup_h,grid%n_iup_v                                    &
+     &             ,grid%n_iup_adh,grid%n_iup_adv                                &
+     &             ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv                        &
+     &             ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                    &
+     &             ,IDS,IDF,JDS,JDF,KDS,KDE                            &
+     &             ,IMS,IME,JMS,JME,KMS,KME                            &
+     &             ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+!***  UPDATE MOIST ARRAY.
+!***  REMEMBER THAT MOIST IS ONLY USED WITH THE PHYSICS AND THUS
+!***  THE P_QV SLOT (=2) IS MIXING RATIO, NOT SPECIFIC HUMIDITY.
+!***  ALTHOUGH MOIST IS ONLY USED FOR PHYSICS IN OPERATIONS, IT IS 
+!***  UPDATED HERE FROM grid%q EVERY ADVECTION TIMESTEP FOR NON-OPERATIONAL
+!***  CONFIGURATIONS WHERE IT MAY BE USED OUTSIDE OF THE PHYSICS.
+!
+          IF(.NOT.OPERATIONAL_PHYSICS)THEN
+            DO K=KTS,KTE
+            DO J=MYJS,MYJE
+            DO I=MYIS,MYIE
+              MOIST(I,J,K,P_QV)=grid%q(I,J,K)/(1.-grid%q(I,J,K))
+              WC = grid%cwm(I,J,K)
+              QI = 0.
+              QR = 0.
+              QW = 0.
+              FICE=grid%f_ice(I,K,J)
+              FRAIN=grid%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,J,K,P_QC)=QW
+              MOIST(I,J,K,P_QR)=QR
+
+              if (CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW.or.CONFIG_FLAGS%MP_PHYSICS==ETAMP_HWRF)then
+#ifdef HWRF
+                 MOIST(I,J,K,P_QI)=QI
+                 MOIST(I,J,K,P_QS)=0.
+#else
+                 MOIST(I,J,K,P_QI)=0.
+                 MOIST(I,J,K,P_QS)=QI
+#endif
+              endif
+              MOIST(I,J,K,P_QG)=0.
+            ENDDO
+            ENDDO
+            ENDDO
+          ENDIF
+!
+!-----------------------------------------------------------------------
+        ELSE had2_micro_check
+!-----------------------------------------------------------------------
+!
+          CALL HAD2_SCAL(                                              &
+#if defined(DM_PARALLEL)
+     &                   GRID%DOMDESC,                                 &
+#endif        
+     &                   grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm         &
+     &                  ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop            &
+     &                  ,grid%hbm2,grid%hbm3                                     &
+     &                  ,grid%q2,grid%u,grid%v,grid%z,grid%hydro                                &
+     &                  ,grid%n_iup_h,grid%n_iup_v                               &
+     &                  ,grid%n_iup_adh,grid%n_iup_adv                           &
+     &                  ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv                   &
+     &                  ,grid%ihe,grid%ihw,grid%ive,grid%ivw                               &
+     &                  ,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
+     &                   grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm         &
+     &                  ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop            &
+     &                  ,grid%hbm2,grid%hbm3                                     &
+     &                  ,MOIST,grid%u,grid%v,grid%z,grid%hydro                             &
+     &                  ,grid%n_iup_h,grid%n_iup_v                               &
+     &                  ,grid%n_iup_adh,grid%n_iup_adv                           &
+     &                  ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv                   &
+     &                  ,grid%ihe,grid%ihw,grid%ive,grid%ivw                               &
+     &                  ,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
+     &                   grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm         &
+     &                  ,grid%aeta1,grid%aeta2,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop            &
+     &                  ,grid%hbm2,grid%hbm3                                     &
+     &                  ,SCALAR,grid%u,grid%v,grid%z,grid%hydro                            &
+     &                  ,grid%n_iup_h,grid%n_iup_v                               &
+     &                  ,grid%n_iup_adh,grid%n_iup_adv                           &
+     &                  ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv                   &
+     &                  ,grid%ihe,grid%ihw,grid%ive,grid%ivw                               &
+     &                  ,NUM_SCALAR,2                                  &
+     &                  ,IDS,IDF,JDS,JDF,KDS,KDE                       &
+     &                  ,IMS,IME,JMS,JME,KMS,KME                       &
+     &                  ,ITS,ITE,JTS,JTE,KTS,KTE)                             
+!    
+          DO K=KTS,KTE 
+          DO J=MYJS,MYJE
+          DO I=MYIS,MYIE
+            grid%q(I,J,K)=MOIST(I,J,K,P_QV)/(1.+MOIST(I,J,K,P_QV))           
+          ENDDO
+          ENDDO    
+          ENDDO   
+!
+!-----------------------------------------------------------------------
+        ENDIF had2_micro_check
+!-----------------------------------------------------------------------
+        had2_tim=had2_tim+timef()-btimx
+!-----------------------------------------------------------------------
+!
+      ENDIF idtad_block
+!
+!----------------------------------------------------------------------
+!
+      ENDIF not_euler  ! Lagrangian model tracer advection
+!
+!----------------------------------------------------------------------
+!***  RADIATION
+!----------------------------------------------------------------------
+!
+!***  When allocating CAM radiation 4d arrays (ozmixm, aerosolc), 
+!***  the following two scalars are not needed.
+!
+      NUM_OZMIXM=1
+      NUM_AEROSOLC=1
+!
+      IF(grid%ntsd<=0)THEN
+        NTSD_rad=grid%ntsd
+      ELSE
+!
+!***  Call radiation just BEFORE the top of the hour
+!***  so that updated fields are written to history files.
+!
+        NTSD_rad=grid%ntsd+1
+      ENDIF
+!
+#ifdef HWRF
+!emc_2010_bugfix_h50
+! remove this - not needed for V3.2
+!      call nl_get_start_hour(1,IHRST)
+!emc_2010_bugfix_h50
+#endif
+
+      IF(MOD(NTSD_rad,GRID%NRADS)==0.OR.                               &
+     &   MOD(NTSD_rad,GRID%NRADL)==0)THEN
+!
+        btimx=timef()
+        IF(OPERATIONAL_PHYSICS)THEN
+          CALL UPDATE_MOIST(MOIST,grid%q,grid%cwm,grid%f_ice,grid%f_rain,N_MOIST           &
+     &                     ,IDS,IDF,JDS,JDF,KDS,KDE                    &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                    &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE)
+        ENDIF
+!
+        CALL RADIATION(NTSD_rad,GRID%DT,GRID%JULDAY,GRID%JULYR         &
+     &                ,GRID%XTIME,GRID%JULIAN                          &
+     &                ,IHRST,GRID%NPHS                                 &
+     &                ,grid%glat,grid%glon,GRID%NRADS,GRID%NRADL                 &
+     &                ,grid%deta1,grid%deta2,grid%aeta1,grid%aeta2,grid%eta1,grid%eta2,grid%pdtop,grid%pt      &
+     &                ,grid%pd,grid%res,grid%pint,grid%t,grid%q,MOIST,grid%ths,grid%albedo,grid%epsr           &
+     &                ,grid%f_ice,grid%f_rain                                    &
+#ifdef WRF_CHEM
+     &                ,GD_CLOUD,GD_CLOUD2                              &
+#endif
+     &                ,grid%sm,grid%hbm2,grid%cldfra,N_MOIST,RESTRT                   &
+     &                ,grid%rlwtt,grid%rswtt,grid%rlwin,grid%rswin,grid%rswinc,grid%rswout           &
+     &                ,grid%rlwtoa,grid%rswtoa,grid%czmean                            &
+     &                ,grid%cfracl,grid%cfracm,grid%cfrach,grid%sigt4                      &
+     &                ,grid%acfrst,grid%ncfrst,grid%acfrcv,grid%ncfrcv                     &
+     &                ,grid%cuppt,grid%vegfrc,grid%sno,grid%htop,grid%hbot                      &
+     &                ,grid%z,grid%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
+          grid%gsw(I,J)=grid%rswin(I,J)-grid%rswout(I,J)
+        ENDDO
+        ENDDO
+!
+!                            ***  NOTE  ***
+! grid%rlwin/grid%rswin  - downward longwave/shortwave at the surface (formerly TOTLWDN/TOTSWDN)
+! grid%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()
+!
+!     Pass in XTIME (elapsed time from start of parent) to compute
+!     the time passed into the zenith angle code consistently between
+!     RDTEMP and RADIATION.
+
+      CALL RDTEMP(grid%ntsd,GRID%DT,GRID%JULDAY,GRID%JULYR                  &
+     &           ,GRID%XTIME,IHRST,grid%glat,grid%glon                           &
+     &           ,grid%czen,grid%czmean,grid%t,grid%rswtt,grid%rlwtt,grid%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
+!
+!
+#ifdef HWRF
+!
+!-------------------------------------------------------------------------------------
+!*** GET SSTs FROM DMITRY's COUPLER ON TO THE PARENT AND NESTED GRID
+!-------------------------------------------------------------------------------------
+! Coupling insertion:->
+        CALL ATM_GETSST(grid%sst,grid%sm)
+!<-:Coupling insertion
+      IF(GRID%ID .EQ. 1 .AND. MOD(grid%ntsd,grid%NPHS)==0)THEN
+        btimx=timef()
+        sst_tim=sst_tim+timef()-btimx
+      ENDIF
+
+#endif
+!----------------------------------------------------------------------
+!***  TURBULENT PROCESSES 
+!----------------------------------------------------------------------
+!
+      IF(MOD(grid%ntsd,GRID%NPHS)==0)THEN
+!
+        btimx=timef()
+!
+        IF(OPERATIONAL_PHYSICS                                         &
+     &    .AND.MOD(NTSD_rad,GRID%NRADS)/=0                             &
+     &    .AND.MOD(NTSD_rad,GRID%NRADL)/=0)THEN
+          CALL UPDATE_MOIST(MOIST,grid%q,grid%cwm,grid%f_ice,grid%f_rain,N_MOIST           &
+     &                     ,IDS,IDF,JDS,JDF,KDS,KDE                    &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                    &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE)
+        ENDIF
+!
+        CALL TURBL(grid%ntsd,GRID%DT,GRID%NPHS,RESTRT                       &
+     &            ,N_MOIST,GRID%NUM_SOIL_LAYERS,grid%sldpth,grid%dzsoil          &
+     &            ,grid%deta1,grid%deta2,grid%aeta1,grid%aeta2,grid%eta1,grid%eta2,grid%pdtop,grid%pt          &
+     &            ,grid%sm,grid%hbm2,grid%vbm2,grid%dx_nmm,grid%dfrlg                           &
+     &            ,grid%czen,grid%czmean,grid%sigt4,grid%rlwin,grid%rswin,grid%radot                 &
+     &            ,grid%pd,grid%res,grid%pint,grid%t,grid%q,grid%cwm,grid%f_ice,grid%f_rain,grid%sr                 &
+     &            ,grid%q2,grid%u,grid%v,grid%ths,grid%nmm_tsk,grid%sst,grid%prec,grid%sno                     &
+     &            ,grid%fis,grid%z0,grid%z0base,grid%ustar,grid%mixht,grid%pblh,grid%lpbl,grid%el_pbl          &   !PLee (3/07)
+     &            ,MOIST,grid%rmol,grid%mol                                      &
+     &            ,grid%exch_h,grid%exch_m,grid%f,grid%akhs,grid%akms,grid%akhs_out,grid%akms_out         &
+     &            ,grid%thz0,grid%qz0,grid%uz0,grid%vz0,grid%qsh,grid%mavail                         &
+     &            ,grid%stc,grid%smc,grid%cmc,grid%smstav,grid%smstot,grid%ssroff,grid%bgroff             &
+     &            ,grid%ivgtyp,grid%isltyp,grid%vegfrc,grid%shdmin,grid%shdmax,grid%grnflx           &
+     &            ,grid%snotime                                             &
+     &            ,grid%sfcexc,grid%acsnow,grid%acsnom,grid%snopcx,grid%sice,grid%tg,grid%soiltb          &
+     &            ,grid%albase,grid%mxsnal,grid%albedo,grid%sh2o,grid%si,grid%epsr,grid%embck             &
+     &            ,grid%u10,grid%v10,grid%th10,grid%q10,grid%tshltr,grid%qshltr,grid%pshltr               &
+     &            ,grid%t2,grid%qsg,grid%qvg,grid%qcg,grid%soilt1,grid%tsnav,grid%smfr3d,grid%keepfr3dflag     &
+#if (NMM_CORE==1)
+     &            ,grid%twbs,grid%qwbs,grid%taux,grid%tauy,grid%sfcshx,grid%sfclhx,grid%sfcevp                      &
+#else
+     &            ,grid%twbs,grid%qwbs,grid%sfcshx,grid%sfclhx,grid%sfcevp                      &
+#endif
+     &            ,grid%potevp,grid%potflx,grid%subshx                                &
+     &            ,grid%aphtim,grid%ardsw,grid%ardlw,grid%asrfc                            &
+     &            ,grid%rswout,grid%rswtoa,grid%rlwtoa                                &
+     &            ,grid%aswin,grid%aswout,grid%aswtoa,grid%alwin,grid%alwout,grid%alwtoa             &
+#if (NMM_CORE==1)
+     &            ,grid%uz0h,grid%vz0h,grid%dudt,grid%dvdt,grid%ugwdsfc,grid%vgwdsfc,grid%sfenth          & 
+#else
+     &            ,grid%uz0h,grid%vz0h,grid%dudt,grid%dvdt                                 & 
+#endif
+     &            ,RTHBLTEN,RQVBLTEN                                   & 
+     &            ,GRID%PCPFLG,grid%ddata                                   &
+     &            ,grid%hstdv,grid%hcnvx,grid%hasyw,grid%hasys,grid%hasysw,grid%hasynw,grid%hlenw,grid%hlens   & ! GWD
+     &            ,grid%hlensw,grid%hlennw,grid%hangl,grid%hanis,grid%hslop,grid%hzmax,grid%crot,grid%srot     & ! GWD
+     &            ,grid%dew                                            & ! RUC LSM
+     &            ,GRID,CONFIG_FLAGS                                   &
+     &            ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                     &
+     &            ,GRID%DISHEAT                                             &
+     &            ,IDS,IDF,JDS,JDF,KDS,KDE                             &
+     &            ,IMS,IME,JMS,JME,KMS,KME                             &
+     &            ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+!                     ***  NOTE  ***
+! grid%rlwin/grid%rswin - downward longwave/shortwave at the surface
+!                     ***  NOTE  ***
+!
+        turbl_tim=turbl_tim+timef()-btimx
+#ifdef HWRF
+
+
+!------------------------------------------------------------------------------
+!*** ATMOSPHERIC MODEL OUTPUTS FROM PARENT AND NESTED GRID FOR DMITRYs COUPLER
+!------------------------------------------------------------------------------
+!
+!-- grid%twbs  :  surface sensible heat flux, positive downward (grid%w/m2)
+!-- grid%qwbs  :  surface latent heat flux, positive downward (grid%w/m2)
+!-- grid%rlwin :  downward long wave flux at ground surface,positive downward (grid%w/m2)
+!-- grid%rswin :  downward short wave flux at ground surface, positive downward (grid%w/m2)
+!-- grid%radot :  outgoing long wave flux at ground surface, positive upward (grid%w/m2)
+!-- grid%rswout:  outgoing short wave flux at ground surface, positive upward (grid%w/m2)
+!-- grid%taux  :  x component of surface stress, grid%u positive Eastward
+!-- grid%tauy  :  y component of surface stress, grid%v positive Northward
+!-- grid%pint  :  3d array of interface pressure (pascals)
+!-- grid%prec  :  grid%prec (m/timestep;timestep on grid1=60 sec)
+
+!
+!
+
+! Coupling insertion:->
+      call ATM_DOFLUXES(grid%twbs,grid%qwbs,grid%rlwin,grid%rswin,grid%radot,grid%rswout, &
+      grid%taux,grid%tauy,grid%pint(:,:,1),grid%prec,grid%u10,grid%v10)
+!<-:Coupling insertion
+!
+
+      IF(GRID%ID .EQ. 1 .AND. MOD(grid%ntsd,grid%NPHS)==0)THEN
+        btimx=timef()
+        flux_tim=flux_tim+timef()-btimx
+      ENDIF
+
+#endif
+!
+        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 grid%v POINTS.
+!
+        btimx=timef()
+        CALL UV_H_TO_V(grid%ntsd,GRID%DT,GRID%NPHS,grid%uz0h,grid%vz0h,grid%uz0,grid%vz0         &
+     &                ,grid%dudt,grid%dvdt,grid%u,grid%v,grid%hbm2,grid%ive,grid%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.and.CONFIG_FLAGS%MP_PHYSICS/=ETAMP_HWRF)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,grid%t,grid%t_old,grid%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(grid%ntsd,GRID%NCNVC)==0.AND.                                  &
+     &   (CONFIG_FLAGS%CU_PHYSICS==KFETASCHEME .or.                     &
+         CONFIG_FLAGS%CU_PHYSICS==SASSCHEME))THEN                       ! Kwon's doing for SAS
+!
+        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
+!
+      convection: IF(CONFIG_FLAGS%CU_PHYSICS/=0)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)=(grid%t(I,J,K)-TTEN(I,K,J))*DT_INV
+            QTEN(I,K,J)=(grid%q(I,J,K)-QTEN(I,K,J))*DT_INV
+          ENDDO
+          ENDDO
+          ENDDO
+        ENDIF
+!
+!***  UPDATE THE MOIST ARRAY IF NEEDED.
+!
+        IF(OPERATIONAL_PHYSICS                                         &
+     &    .AND.MOD(NTSD_rad,GRID%NRADS)/=0                             &
+     &    .AND.MOD(NTSD_rad,GRID%NRADL)/=0                             &
+     &    .AND.MOD(grid%ntsd,GRID%NPHS)/=0)THEN
+          CALL UPDATE_MOIST(MOIST,grid%q,grid%cwm,grid%f_ice,grid%f_rain,N_MOIST           &
+     &                     ,IDS,IDF,JDS,JDF,KDS,KDE                    &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                    &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE)
+       ENDIF
+!
+!----------------------------------------------------------------------
+        CALL CUCNVC(grid%ntsd,GRID%DT,GRID%NCNVC,GRID%NRADS,GRID%NRADL      &
+     &             ,GPS,RESTRT,grid%hydro,grid%cldefi,N_MOIST,GRID%ENSDIM        &
+     &             ,MOIST                                              &
+     &             ,grid%deta1,grid%deta2,grid%aeta1,grid%aeta2,grid%eta1,grid%eta2                  &
+     &             ,grid%f_ice,grid%f_rain                                       &
+!***  Changes for other cu schemes, most for GD scheme
+     &             ,grid%apr_gr,grid%apr_w,grid%apr_mc,TTEN,QTEN                      &
+     &             ,grid%apr_st,grid%apr_as,grid%apr_capma                            &
+     &             ,grid%apr_capme,grid%apr_capmi                                &
+     &             ,grid%mass_flux,grid%xf_ens                                   &
+     &             ,grid%pr_ens,grid%gsw                                         &
+#ifdef WRF_CHEM
+     &             ,GD_CLOUD,GD_CLOUD2,RAINCV                          &
+#endif
+!
+     &             ,grid%pdtop,grid%pt,grid%pd,grid%res,grid%pint,grid%t,grid%q,grid%cwm,grid%tcucn                 &
+     &             ,grid%omgalf,grid%u,grid%v,grid%w,grid%z,grid%fis,grid%w0avg                           &
+     &             ,grid%prec,grid%acprec,grid%cuprec,grid%cuppt,grid%cprate                    &
+     &             ,grid%sm,grid%hbm2,grid%lpbl,grid%cnvbot,grid%cnvtop                         &
+     &             ,grid%htop,grid%hbot,grid%htopd,grid%hbotd,grid%htops,grid%hbots                  &
+     &             ,RTHBLTEN,RQVBLTEN,RTHRATEN                         & 
+#if (NMM_CORE==1)                  
+     &                 ,grid%DUCUDT, grid%DVCUDT, GRID%MOMMIX, grid%store_rand             &
+#endif
+     &             ,grid%avcnvc,grid%acutim,grid%ihe,grid%ihw                              &
+     &             ,GRID,CONFIG_FLAGS                                  &
+     &             ,grid%NRND1                                              & ! NRND1 for random num restart
+     &             ,IDS,IDF,JDS,JDF,KDS,KDE                            &
+     &             ,IMS,IME,JMS,JME,KMS,KME                            &
+     &             ,IPS,IPE,JPS,JPE,KPS,KPE                            &
+     &             ,ITS,ITE,JTS,JTE,KTS,KTE)
+!----------------------------------------------------------------------
+!
+        cucnvc_tim=cucnvc_tim+timef()-btimx
+!
+
+
+#if (NMM_CORE==1)
+!#ifdef HWRF
+!-------------------------------------------------------------------------------------
+!       This is gopal's doing for HWRFSAS
+
+!        IF(MOD(grid%ntsd,GRID%NCNVC).eq.0.and.(CONFIG_FLAGS%CU_PHYSICS.eq.SASSCHEME))THEN
+! update to match HWRFV2 behaviour - review later (1/15/10)
+!
+!emc_2010_bugfix_h50
+        IF(MOD(grid%ntsd, GRID%NCNVC).eq.0.and.CONFIG_FLAGS%CU_PHYSICS.eq.SASSCHEME)THEN
+!emc_2010_bugfix_h50
+!
+        btimx=timef()
+!-----------------
+#ifdef DM_PARALLEL
+# include "HALO_NMM_SAS_A.inc"
+#endif
+!-----------------
+#ifdef DM_PARALLEL
+# include "HALO_NMM_SAS_B.inc"
+#endif
+!-----------------
+        exch_tim=exch_tim+timef()-btimx
+
+!
+!***  INTERPOLATE WINDS FROM H POINTS BACK TO V POINTS AFTER SAS 
+!
+        btimx=timef()
+
+!emc_2010_bugfix_h50
+        CALL UV_H_TO_V(grid%NTSD,GRID%DT,GRID%NCNVC,grid%UZ0H,grid%VZ0H,grid%UZ0,grid%VZ0         &
+     &                ,grid%DUCUDT,grid%DVCUDT,grid%U,grid%V,grid%HBM2,grid%IVE,grid%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
+!emc_2010_bugfix_h50
+
+     ENDIF ! for SAS only 
+!#endif
+#endif
+!--------------------------------------------------------------------------------
+!
+  ENDIF convection
+!
+!----------------------------------------------------------------------
+!***  GRIDSCALE MICROPHYSICS (CONDENSATION & PRECIPITATION)
+!----------------------------------------------------------------------
+!
+      IF(MOD(grid%ntsd,GRID%NPHS)==0)THEN
+        btimx=timef()
+!
+        CALL GSMDRIVE(grid%ntsd,GRID%DT,GRID%NPHS,N_MOIST                   &
+     &               ,grid%dx_nmm(ITS,JC),GRID%DY,grid%sm,grid%hbm2,grid%fis               &
+     &               ,grid%deta1,grid%deta2,grid%aeta1,grid%aeta2,grid%eta1,grid%eta2                &
+     &               ,grid%pdtop,grid%pt,grid%pd,grid%res,grid%pint,grid%t,grid%q,grid%cwm,grid%train               &
+     &               ,MOIST,SCALAR,NUM_SCALAR                          &
+     &               ,grid%f_ice,grid%f_rain,grid%f_rimef,grid%sr                          &
+     &               ,grid%prec,grid%acprec,grid%avrain                               &
+     &               ,grid%mp_restart_state                                 &
+     &               ,grid%tbpvs_state                                      &
+     &               ,grid%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(grid%ntsd,GRID%DT,GRID%NPHS,grid%sr,PPTDAT                 &
+     &      ,IDS,IDE,JDS,JDE,KDS,KDE                                    &
+     &      ,IMS,IME,JMS,JME,KMS,KME                                    &
+     &      ,ITS,ITE,JTS,JTE,KTS,KTE)
+          CALL ADJPPT(grid%ntsd,GRID%DT,GRID%NPHS,grid%prec,grid%lspa,PPTDAT,grid%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,grid%t,grid%t_old,grid%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,grid%t,grid%t_old,grid%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(grid%ntsd,GRID%DT,grid%fis,grid%dy_nmm,grid%hdac,grid%hdacv         &
+     &          ,grid%hbm2,grid%deta1,GRID%SIGMA                       &
+#ifdef HWRF
+     &          ,grid%t,grid%q,grid%u,grid%v,grid%q2,grid%z,grid%w,grid%sm,grid%sice,grid%h_diff    &
+#else
+     &          ,grid%t,grid%q,grid%u,grid%v,grid%q2,grid%z,grid%w,grid%sm,grid%sice                &
+#endif
+     &          ,grid%def3d                                              &
+     &          ,grid%ihe,grid%ihw,grid%ive,grid%ivw                   &
+     &          ,CONFIG_FLAGS                                          &
+     &          ,IDS,IDF,JDS,JDF,KDS,KDE                               &
+     &          ,IMS,IME,JMS,JME,KMS,KME                               &
+     &          ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+      IF(.NOT.OPERATIONAL_PHYSICS)THEN
+        DO K=KTS,KTE
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+!!!       MOIST(I,J,K,P_QV)=MAX(0.,grid%q(I,J,K)/(1.-grid%q(I,J,K)))
+          MOIST(I,J,K,P_QV)=grid%q(I,J,K)/(1.-grid%q(I,J,K))           !<-- Update mixing ratio
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDIF
+!
+      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,grid%ntsd,GRID%DT,NEST,NUNIT_NBC,NBOCO,LAST_TIME,TSPH &
+     &          ,LB,grid%eta1,grid%eta2,grid%pdtop,grid%pt,grid%res                              &
+     &          ,grid%PD_BXS,grid%PD_BXE,grid%PD_BYS,grid%PD_BYE,grid%T_BXS,grid%T_BXE,grid%T_BYS,grid%T_BYE    &
+     &          ,grid%Q_BXS,grid%Q_BXE,grid%Q_BYS,grid%Q_BYE,grid%U_BXS,grid%U_BXE,grid%U_BYS,grid%U_BYE,grid%V_BXS  &
+     &          ,grid%V_BXE,grid%V_BYS,grid%V_BYE,grid%Q2_BXS,grid%Q2_BXE,grid%Q2_BYS,grid%Q2_BYE,grid%CWM_BXS  &
+     &          ,grid%CWM_BXE,grid%CWM_BYS,grid%CWM_BYE,grid%PD_BTXS,grid%PD_BTXE,grid%PD_BTYS        &
+     &          ,grid%PD_BTYE,grid%T_BTXS,grid%T_BTXE,grid%T_BTYS,grid%T_BTYE,grid%Q_BTXS,grid%Q_BTXE      &
+     &          ,grid%Q_BTYS,grid%Q_BTYE,grid%U_BTXS,grid%U_BTXE,grid%U_BTYS,grid%U_BTYE,grid%V_BTXS       &
+     &          ,grid%V_BTXE,grid%V_BTYS,grid%V_BTYE,grid%Q2_BTXS,grid%Q2_BTXE,grid%Q2_BTYS,grid%Q2_BTYE   &
+     &          ,grid%CWM_BTXS,grid%CWM_BTXE,grid%CWM_BTYS,grid%CWM_BTYE,grid%pd,grid%t,grid%q,grid%q2,grid%cwm,grid%pint &
+     &          ,MOIST,N_MOIST,SCALAR,NUM_SCALAR                        &
+#ifdef WRF_CHEM
+     &          ,CHEM,NUMGAS,CONFIG_FLAGS                               &
+#endif
+     &          ,GRID%SPEC_BDY_WIDTH,grid%z                                  &
+     &          ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                        &
+     &          ,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(grid%ntsd,n_print_time)==0)then
+!       call twr(grid%t,0,'grid%t',grid%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.and.CONFIG_FLAGS%MP_PHYSICS/=ETAMP_HWRF)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(grid%ntsd,LAST_TIME,grid%pt,grid%deta1,grid%deta2,grid%pdtop,grid%res,grid%fis           &
+     &          ,grid%hydro,GRID%SIGMA,FIRST,grid%dx_nmm,grid%dy_nmm                  &
+     &          ,grid%hbm2,grid%vbm2,grid%vbm3                                        &
+     &          ,grid%fdiv,grid%fcp,grid%wpdar,grid%dfl,grid%cpgfu,grid%cpgfv                        &
+     &          ,grid%pd,grid%pdsl,grid%t,grid%q,grid%u,grid%v,grid%cwm,grid%omgalf,grid%pint,grid%dwdt                  &
+     &          ,grid%rtop,grid%div,grid%few,grid%fns,grid%fne,grid%fse                              &
+     &          ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                       &
+     &          ,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(grid%ntsd,GRID%DT,grid%deta1,grid%deta2,grid%pdsl,grid%pdtop,grid%div,grid%hbm2          &
+     &          ,grid%t,grid%u,grid%v,grid%ddmpu,grid%ddmpv                                     &
+     &          ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                       &
+     &          ,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.grid%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,grid%ntsd,GRID%DT,LB,grid%U_BXS,grid%U_BXE,grid%U_BYS,grid%U_BYE,grid%V_BXS &
+     &          ,grid%V_BXE,grid%V_BYS,grid%V_BYE,grid%U_BTXS,grid%U_BTXE,grid%U_BTYS,grid%U_BTYE,grid%V_BTXS  &
+     &          ,grid%V_BTXE,grid%V_BTYS,grid%V_BTYE,grid%u,grid%v                              &
+     &          ,GRID%SPEC_BDY_WIDTH                                   &
+     &          ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                       &
+     &          ,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 grid%q2 TO THE WRF VARIABLE grid%tke_pbl
+!----------------------------------------------------------------------
+!
+      DO K=KTS,KTE
+      DO J=JTS,JTE
+      DO I=ITS,ITE
+        grid%tke_pbl(I,J,K)=0.5*grid%q2(I,J,K) !TKE is grid%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(grid%ntsd,n_print_time)==0)then
+        write(message,*)' grid%ntsd=',grid%ntsd,' solve_tim=',solve_tim*1.e-3          &
+     &           ,' sum_tim=',sum_tim*1.e-3
+        call wrf_message(trim(message))
+        write(message,*)' pdte_tim=',pdte_tim*1.e-3,' pct=',pdte_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' adve_tim=',adve_tim*1.e-3,' pct=',adve_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' vtoa_tim=',vtoa_tim*1.e-3,' pct=',vtoa_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' vadz_tim=',vadz_tim*1.e-3,' pct=',vadz_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' hadz_tim=',hadz_tim*1.e-3,' pct=',hadz_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' eps_tim=',eps_tim*1.e-3,' pct=',eps_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' vad2_tim=',vad2_tim*1.e-3,' pct=',vad2_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' had2_tim=',had2_tim*1.e-3,' pct=',had2_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' radiation_tim=',radiation_tim*1.e-3,' pct=',radiation_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' rdtemp_tim=',rdtemp_tim*1.e-3,' pct=',rdtemp_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' turbl_tim=',turbl_tim*1.e-3,' pct=',turbl_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' cltend_tim=',cltend_tim*1.e-3,' pct=',cltend_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' cucnvc_tim=',cucnvc_tim*1.e-3,' pct=',cucnvc_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' gsmdrive_tim=',gsmdrive_tim*1.e-3,' pct=',gsmdrive_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' adjppt_tim=',adjppt_tim*1.e-3,' pct=',adjppt_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' hdiff_tim=',hdiff_tim*1.e-3,' pct=',hdiff_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' bocoh_tim=',bocoh_tim*1.e-3,' pct=',bocoh_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' pfdht_tim=',pfdht_tim*1.e-3,' pct=',pfdht_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' ddamp_tim=',ddamp_tim*1.e-3,' pct=',ddamp_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' bocov_tim=',bocov_tim*1.e-3,' pct=',bocov_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' uv_h_to_v_tim=',uv_htov_tim*1.e-3,' pct=',uv_htov_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,*)' exch_tim=',exch_tim*1.e-3,' pct=',exch_tim/sum_tim*100.
+        call wrf_message(trim(message))
+!        call time_stats(exch_tim,'exchange',grid%ntsd,mype,npes,mpi_comm_comp)
+!        write(message,*)' exch_tim_max=',exch_tim_max*1.e-3
+!        call wrf_message(trim(message))
+!
+        call field_stats(grid%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)
+#ifdef WRF_CHEM
+#endif
+!
+! FOR VORTEX FOLLOWING MOVING NEST
+!
+!-----------------------------------------------------------------------------
+!***  CRITERIA SET FOR GRID MOTION. This is gopal's doing
+!-----------------------------------------------------------------------------
+!
+#ifdef MOVE_NESTS
+   IF(grid%id .NE. 1 .AND. MOD(grid%ntsd,1)==0 .AND. grid%num_moves.EQ.-99)THEN
+!-----------------
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_TRACK.inc"
+#endif
+!-----------------
+
+   CALL STATS_FOR_MOVE (grid%XLOC_2,grid%YLOC_2,grid%PDYN,grid%MSLP,grid%SQWS                   &
+                      ,grid%pint,grid%t,grid%q,grid%u,grid%v                                   &
+                      ,grid%fis,grid%pd,grid%sm,grid%pdtop,grid%pt                             &
+                      ,grid%deta1,grid%deta2                                    &
+#ifdef HWRF
+                      ,GRID%RESTART,grid%NTIME0                            & ! zhang's doing
+                      ,GRID%MOVED,grid%MVNEST,grid%ntsd,GRID%NPHS,GRID%MOVEMIN  & ! MOVEMIN*DT*NPHS=540s
+#else
+                      ,GRID%MOVED,grid%MVNEST,grid%ntsd,GRID%NPHS     &
+#endif
+                      ,IDS,IDF,JDS,JDF,KDS,KDE                        & ! MOVEMIN is defined in
+                      ,IMS,IME,JMS,JME,KMS,KME                        & ! Registry
+                      ,ITS,ITE,JTS,JTE,KTS,KTE              )           ! FOR NEST:DT=18,NPHS=3
+   CALL wrf_debug ( 100 , 'nmm stats_for_move: after advection' )
+   ENDIF
+#endif
+
+#ifdef HWRFX
+!    output MSLP over parent domain for diagonostic purposes. outputs are hourly.
+!    This is gopal's doing
+
+     IF(grid%id .EQ. 1 .AND. MOD(grid%NTSD,n_print_time)==0)THEN
+      WRITE(0,*)'COMPUTING MSLP OVER THE PARENT DOMAIN'
+
+      CALL MSLP_DIAG (grid%MSLP,grid%PINT,grid%T,grid%Q                &
+                     ,grid%FIS,grid%PD,grid%DETA1,grid%DETA2,grid%PDTOP     &
+                     ,IDS,IDF,JDS,JDF,KDS,KDE      &
+                     ,IMS,IME,JMS,JME,KMS,KME      &
+                     ,ITS,ITE,JTS,JTE,KTS,KTE      )
+
+
+     ENDIF
+
+#endif
+
+!#define COPY_OUT
+!#include <scalar_derefs.inc>
+#ifdef HWRF
+!-----------------------------------------------------------------------
+!*** ACCUMULATED ATMOSPHERIC MODEL FLUXES FOR DMITRYs COUPLER
+!-----------------------------------------------------------------------
+!
+!
+!
+! Coupling insertion:->
+      call ATM_SENDFLUXES
+!<-:Coupling insertion
+!
+! Kwon's doing to check heat flux
+!
+!  IF(grid%id==2)WRITE(0,*)'AFTER ATM_SENDFLUX grid%qwbs grid%twbs AT 10 10 ',grid%ntsd,grid%qwbs(10,10),grid%twbs(10,10)
+!
+#endif
+
+
+      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
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      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                    &
+     &                     ,KK,MPI_COMM_COMP,MYPE,NPES,ntsd
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME+KK),INTENT(IN) :: ARRAY
+!
+      CHARACTER(*),INTENT(IN) :: FIELD
+!
+!*** LOCAL VARIABLES
+!
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT
+      INTEGER,DIMENSION(MPI_STATUS_SIZE,4) :: STATUS_ARRAY
+#endif
+      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 defined(DM_PARALLEL) && !defined(STUBMPI)
+      IF(MYPE==0)THEN
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          TWRITE(I,J)=ARRAY(I,J,K)
+        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,J,K)
+        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
+#else
+
+        DO J=JDS,JDE-1
+          IENDX=IDE-1
+          IF(MOD(J,2)==0)IENDX=IENDX-1
+          WRITE(IUNIT)(ARRAY(I,K,J),I=1,IENDX)
+        ENDDO
+
+#endif
+
+!
+!----------------------------------------------------------------------
+  500 CONTINUE
+!
+      IF(MYPE==0)CLOSE(IUNIT)
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE TWR
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      SUBROUTINE VWR(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
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      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                    &
+     &                     ,KK,MPI_COMM_COMP,MYPE,NPES,ntsd
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME+KK),INTENT(IN) :: ARRAY
+!
+      CHARACTER(*),INTENT(IN) :: FIELD
+!
+!*** LOCAL VARIABLES
+!
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT
+      INTEGER,DIMENSION(MPI_STATUS_SIZE,4) :: STATUS_ARRAY
+#endif
+      INTEGER,DIMENSION(2) :: IM_REM,JM_REM,IT_REM,JT_REM
+!
+      INTEGER :: I,IENDX,IER,IPE,IRECV,IRTN,ISEND,IUNIT                &
+     &          ,J,K,L,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
+      LOGICAL :: OPENED
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+!
+      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
+!     IF(MYPE==0)THEN
+!       OPEN_UNIT: DO L=51,99
+!         INQUIRE(L,OPENED=OPENED)
+!         IF(.NOT.OPENED)THEN
+!           IUNIT=L
+!           OPEN(UNIT=IUNIT,FILE=FILENAME,STATUS='NEW'                 &
+!               ,FORM='UNFORMATTED',IOSTAT=IER)
+!           IF(IER/=0)THEN
+!             WRITE(message,*)' Opening file error=',IER
+!             CALL wrf_message(trim(message))
+!           ENDIF
+!           EXIT OPEN_UNIT
+!         ENDIF
+!       ENDDO OPEN_UNIT
+!     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 defined(DM_PARALLEL) && !defined(STUBMPI)
+      IF(MYPE==0)THEN
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          TWRITE(I,J)=ARRAY(I,J,K)
+        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,J,K)
+        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)==1)IENDX=IENDX-1
+          WRITE(IUNIT)(TWRITE(I,J),I=1,IENDX)
+        ENDDO
+!
+      ENDIF
+#else
+
+        DO J=JDS,JDE-1
+          IENDX=IDE-1
+          IF(MOD(J,2)==0)IENDX=IENDX-1
+          WRITE(IUNIT)(ARRAY(I,K,J),I=1,IENDX)
+        ENDDO
+
+#endif
+!
+!----------------------------------------------------------------------
+  500 CONTINUE
+!
+      IF(MYPE==0)CLOSE(IUNIT)
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE VWR
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      SUBROUTINE EXIT(NAME,pint,t,q,u,v,q2,w                           &
+     &               ,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
+!----------------------------------------------------------------------
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      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                    &
+     &                     ,MYPE,MPI_COMM_COMP,ntsd
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: pint,t,q   &
+                                                           ,u,v,q2,w
+      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 K=KTS,KTE
+      DO J=JTS,JTE
+      IEND=ITE
+      IF(E_BDY.AND.MOD(J,2)==0)IEND=ITE-1
+!
+      DO I=ITS,IEND
+        IF(t(I,J,K)>330..OR.t(I,J,K)<180..OR.t(I,J,K)/=t(I,J,K))THEN
+          WRITE(errmess,100)NAME,ntsd
+          CALL wrf_message(trim(errmess))
+          WRITE(errmess,200)I,J,K,t(I,J,K),MYPE,ntsd
+          CALL wrf_message(trim(errmess))
+  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,J,K),I,J,K,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,J,K)<-1.E-4.OR.q(I,J,K)>30.E-3                      &
+     &         .OR.q(I,J,K)/=q(I,J,K))THEN
+          WRITE(errmess,100)NAME,ntsd
+          CALL wrf_message(trim(errmess))
+          WRITE(errmess,300)I,J,K,q(I,J,K),MYPE,ntsd
+          CALL wrf_message(trim(errmess))
+  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,J,K),I,J,K,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)
+        ELSEIF(pint(I,J,K)<0..OR.pint(I,J,K)/=pint(I,J,K))THEN
+          WRITE(errmess,100)NAME,ntsd
+          CALL wrf_message(trim(errmess))
+          WRITE(errmess,315)I,J,K,pint(I,J,K),MYPE,ntsd
+          CALL wrf_message(trim(errmess))
+  315     FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' pint=',E12.5      &
+     &,          ' MYPE=',I3,' ntsd=',I5)
+          IRET=666
+          return
+!         CALL WRF_ERROR_FATAL(ERRMESS)
+!         CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR)
+        ELSEIF(w(I,J,K)/=w(I,J,K))THEN
+          WRITE(errmess,100)NAME,ntsd
+          CALL wrf_message(trim(errmess))
+          WRITE(errmess,325)I,J,K,w(I,J,K),MYPE,ntsd
+          CALL wrf_message(trim(errmess))
+  325     FORMAT(' BAD VALUE I=',I3,' J=',I3,' K=',I2,' w=',E12.5      &
+     &,          ' MYPE=',I3,' ntsd=',I5)
+          IRET=666
+          return
+!         CALL WRF_ERROR_FATAL(ERRMESS)
+!         CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR)
+        ENDIF
+      ENDDO
+      ENDDO
+      ENDDO
+!
+      DO K=KTS,KTE
+      DO J=JTS,JTE
+      IEND=ITE
+      IF(E_BDY.AND.MOD(J,2)==1)IEND=ITE-1
+      DO I=ITS,IEND
+        IF(ABS(u(I,J,K))>125..OR.ABS(v(I,J,K))>125.                    &
+     &         .OR.u(I,J,K)/=u(I,J,K).OR.v(I,J,K)/=v(I,J,K))THEN
+          WRITE(errmess,100)NAME,ntsd
+          CALL wrf_message(trim(errmess))
+          WRITE(errmess,400)I,J,K,u(I,J,K),v(I,J,K),MYPE,ntsd
+          CALL wrf_message(trim(errmess))
+  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,J,K),v(I,J,K),I,J,K,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
+!----------------------------------------------------------------------
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      INCLUDE "mpif.h"
+#endif
+!----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: MPI_COMM_COMP,MYPE,NPES,ntsd
+      REAL,INTENT(IN) :: TIME_LCL
+!
+      CHARACTER(*),INTENT(IN) :: NAME
+!
+!*** LOCAL VARIABLES
+!
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      INTEGER,DIMENSION(MPI_STATUS_SIZE) :: JSTAT
+      INTEGER,DIMENSION(MPI_STATUS_SIZE,4) :: STATUS_ARRAY
+#endif
+      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
+      CHARACTER(LEN=256) :: message
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+!
+      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 defined(DM_PARALLEL) && !defined(STUBMPI)
+      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)<TIME_MIN)THEN
+            TIME_MIN=TIME(N)
+            IPE_MIN=ID_PE(N)
+          ENDIF
+!
+        ENDDO
+!
+        TIME_MAX=TIME_MAX*1.E-3
+        TIME_MIN=TIME_MIN*1.E-3
+        TIME_MEAN=TIME_MEAN*1.E-3/REAL(NPES)
+!
+!***  THEN THE MEDIAN TIME.
+!
+        CALL SORT(TIME,NPES,SORT_TIME,IPE_SORT)
+        N_MEDIAN=(NPES+1)/2
+        TIME_MEDIAN=SORT_TIME(N_MEDIAN)*1.E-3
+        IPE_MEDIAN=IPE_SORT(N_MEDIAN)
+!
+!----------------------------------------------------------------------
+      ELSE
+!
+!***  SEND TIME AND PE VALUE TO PE0.
+!
+        REMOTE(1)=TIME_LCL
+        REMOTE(2)=REAL(MYPE)
+!
+        CALL MPI_SEND(REMOTE,2,MPI_REAL,0,MYPE,MPI_COMM_COMP,ISEND)
+!
+      ENDIF
+!----------------------------------------------------------------------
+!
+      CALL MPI_BARRIER(MPI_COMM_COMP,IRTN)
+!
+!***  WRITE RESULTS
+!
+      IF(MYPE==0)THEN
+        WRITE(message,100)TITLE
+        CALL wrf_message(trim(message))
+        WRITE(message,105)TIME_MAX,IPE_MAX
+        CALL wrf_message(trim(message))
+        WRITE(message,110)TIME_MIN,IPE_MIN
+        CALL wrf_message(trim(message))
+        WRITE(message,115)TIME_MEDIAN,IPE_MEDIAN
+        CALL wrf_message(trim(message))
+        WRITE(message,120)TIME_MEAN
+        CALL wrf_message(trim(message))
+  100   FORMAT(' Time for ',A)
+  105   FORMAT(' Maximum=',G11.5,' for PE ',I2.2)
+  110   FORMAT(' Minimum=',G11.5,' for PE ',I2.2)
+  115   FORMAT(' Median =',G11.5,' for PE ',I2.2)
+  120   FORMAT(' Mean   =',G11.5)
+      ENDIF
+!----------------------------------------------------------------------
+!
+#endif
+      END SUBROUTINE TIME_STATS
+!
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      SUBROUTINE SORT(DATA,NPES,DATA_SORTED,IPE_SORTED)
+!----------------------------------------------------------------------
+!***
+!***  SORT DATA FROM MULTIPLE PEs.  SEND BACK THE SORTED DATA ITEMS
+!***  ALONG WITH THE ASSOCIATED TASK IDs.
+!***
+!----------------------------------------------------------------------
+      IMPLICIT NONE
+!----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: NPES
+      REAL,DIMENSION(NPES),INTENT(IN) :: DATA
+!
+      INTEGER,DIMENSION(NPES),INTENT(OUT) :: IPE_SORTED
+      REAL,DIMENSION(NPES),INTENT(OUT) :: DATA_SORTED
+!----------------------------------------------------------------------
+      TYPE :: DATA_LINK
+        REAL :: VALUE
+        INTEGER :: IPE
+        TYPE(DATA_LINK),POINTER :: NEXT_VALUE
+      END TYPE
+!----------------------------------------------------------------------
+!
+!***  LOCAL VARIABLES
+!
+!----------------------------------------------------------------------
+      INTEGER :: ISTAT,N
+!
+      TYPE(DATA_LINK),POINTER :: HEAD,TAIL  ! Smallest, largest
+      TYPE(DATA_LINK),POINTER :: PTR_NEW    ! Each new value
+      TYPE(DATA_LINK),POINTER :: PTR1,PTR2  ! Working pointers
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      pe_loop: DO N=1,NPES
+        ALLOCATE(PTR_NEW,STAT=ISTAT)  ! Location for next data items
+        PTR_NEW%VALUE=DATA(N)
+        PTR_NEW%IPE=N-1
+!
+!----------------------------------------------------------------------
+!***  DETERMINE WHERE IN LIST TO INSERT VALUE.
+!***  FIRST THE INITIAL DATA VALUE.
+!----------------------------------------------------------------------
+!
+!       main: IF(.NOT.ASSOCIATED(HEAD))THEN
+        main: IF(N==1)THEN
+          HEAD=>PTR_NEW
+          TAIL=>HEAD
+          NULLIFY(PTR_NEW%NEXT_VALUE)
+!
+!----------------------------------------------------------------------
+!***  THE NEW VALUE IS LESS THAN THE SMALLEST VALUE ALREADY SORTED.
+!----------------------------------------------------------------------
+!
+        ELSE
+          check: IF(PTR_NEW%VALUE<HEAD%VALUE)THEN
+            PTR_NEW%NEXT_VALUE=>HEAD
+            HEAD=>PTR_NEW
+!
+!----------------------------------------------------------------------
+!***  THE NEW VALUE IS GREATER THAN THE LARGEST VALUE ALREADY SORTED.
+!----------------------------------------------------------------------
+!
+          ELSEIF(PTR_NEW%VALUE>=TAIL%VALUE)THEN
+            TAIL%NEXT_VALUE=>PTR_NEW  ! This is what connects the former
+                                      ! final value in the list to
+                                      ! the new value being appended.
+            TAIL=>PTR_NEW
+            NULLIFY(TAIL%NEXT_VALUE)
+!
+!----------------------------------------------------------------------
+!***  THE NEW VALUE IS IN BETWEEN VALUES ALREADY SORTED.
+!----------------------------------------------------------------------
+!
+          ELSE
+            PTR1=>HEAD
+            PTR2=>PTR1%NEXT_VALUE
+!
+            search: DO
+              IF((PTR_NEW%VALUE>=PTR1%VALUE).AND.                      &
+     &           (PTR_NEW%VALUE<PTR2%VALUE))THEN
+                PTR_NEW%NEXT_VALUE=>PTR2
+                PTR1%NEXT_VALUE=>PTR_NEW
+                EXIT search
+              ENDIF
+!
+              PTR1=>PTR2
+              PTR2=>PTR2%NEXT_VALUE
+            ENDDO search
+!
+          ENDIF check
+!
+        ENDIF main
+!
+      ENDDO pe_loop
+!
+!----------------------------------------------------------------------
+!***  COLLECT THE SORTED NUMBERS FROM THE LINKED LIST.
+!----------------------------------------------------------------------
+!
+      PTR1=>HEAD
+!
+      DO N=1,NPES
+!       IF(.NOT.ASSOCIATED(PTR_NEW))EXIT
+        DATA_SORTED(N)=PTR1%VALUE
+        IPE_SORTED(N)=PTR1%IPE
+        PTR1=>PTR1%NEXT_VALUE
+      ENDDO
+!
+      DEALLOCATE(PTR_NEW)
+      NULLIFY (HEAD,TAIL,PTR1,PTR2)
+!----------------------------------------------------------------------
+      END SUBROUTINE SORT
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      SUBROUTINE FIELD_STATS(FIELD,MYPE,MPI_COMM_COMP                  &
+     &                      ,IDS,IDE,JDS,JDE,KDS,KDE                   &
+     &                      ,IMS,IME,JMS,JME,KMS,KME                   &
+     &                      ,ITS,ITE,JTS,JTE,KTS,KTE)
+!----------------------------------------------------------------------
+!***
+!***  GENERATE STANDARD LAYER STATISTICS FOR THE DESIRED FIELD.
+!***
+!----------------------------------------------------------------------
+      IMPLICIT NONE
+!----------------------------------------------------------------------
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      INCLUDE "mpif.h"
+#endif
+!----------------------------------------------------------------------
+!
+      INTEGER,INTENT(IN) :: MPI_COMM_COMP,MYPE
+      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,KMS:KME),INTENT(IN) :: FIELD
+!
+!----------------------------------------------------------------------
+!***  LOCAL
+!----------------------------------------------------------------------
+!
+      INTEGER,PARAMETER :: DOUBLE=SELECTED_REAL_KIND(15,300)
+!
+      INTEGER :: I,IEND,IRTN,I_BY_J,J,K,KFLIP
+!
+      REAL :: FIKJ,FMAXK,FMINK
+      REAL(KIND=DOUBLE) :: F_MEAN,POINTS,RMS,ST_DEV,SUMFK,SUMF2K
+      REAL,DIMENSION(KTS:KTE) :: FMAX,FMAX_0,FMIN,FMIN_0
+      REAL(KIND=DOUBLE),DIMENSION(KTS:KTE) :: SUMF,SUMF_0,SUMF2,SUMF2_0
+ 
+      CHARACTER(LEN=256) :: message
+!----------------------------------------------------------------------
+!
+      I_BY_J=(IDE-IDS)*(JDE-JDS)-(JDE-JDS-1)/2  ! This assumes that
+                                                ! IDE and JDE are each
+                                                ! one greater than the
+                                                ! true grid size.
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+!
+      layer_loop:  DO K=KTS,KTE
+!
+        FMAXK=-1.E10
+        FMINK=1.E10
+        SUMFK=0.
+        SUMF2K=0.
+!
+        DO J=JTS,JTE
+          IEND=MIN(ITE,IDE-1)
+          IF(MOD(J,2)==0.AND.ITE==IDE-1)IEND=IEND-1
+          DO I=ITS,IEND
+            FIKJ=FIELD(I,J,K)
+            FMAXK=MAX(FMAXK,FIKJ)
+            FMINK=MIN(FMINK,FIKJ)
+            SUMFK=SUMFK+FIKJ
+            SUMF2K=SUMF2K+FIKJ*FIKJ
+          ENDDO
+        ENDDO
+!
+        FMAX(K)=FMAXK
+        FMIN(K)=FMINK
+        SUMF(K)=SUMFK
+        SUMF2(K)=SUMF2K
+!
+      ENDDO layer_loop
+!
+!----------------------------------------------------------------------
+!***  GLOBAL STATS
+!----------------------------------------------------------------------
+!
+      CALL MPI_REDUCE(SUMF,SUMF_0,KTE,MPI_REAL8,MPI_SUM,0              &
+     &               ,MPI_COMM_COMP,IRTN)
+      CALL MPI_REDUCE(SUMF2,SUMF2_0,KTE,MPI_REAL8,MPI_SUM,0            &
+     &               ,MPI_COMM_COMP,IRTN)
+      CALL MPI_REDUCE(FMAX,FMAX_0,KTE,MPI_REAL,MPI_MAX,0               &
+     &               ,MPI_COMM_COMP,IRTN)
+      CALL MPI_REDUCE(FMIN,FMIN_0,KTE,MPI_REAL,MPI_MIN,0               &
+     &               ,MPI_COMM_COMP,IRTN)
+!
+      IF(MYPE==0)THEN
+        POINTS=I_BY_J
+        DO K=KTE,KTS,-1
+          F_MEAN=SUMF_0(K)/POINTS
+          ST_DEV=SQRT((POINTS*SUMF2_0(K)-SUMF_0(K)*SUMF_0(K))/         &
+     &                (POINTS*(POINTS-1)))
+          RMS=SQRT(SUMF2_0(K)/POINTS)
+          KFLIP=KTE-K+1
+          WRITE(message,101)KFLIP,FMAX_0(K),FMIN_0(K)
+          CALL wrf_message(trim(message))
+          WRITE(message,102)F_MEAN,ST_DEV,RMS
+          CALL wrf_message(trim(message))
+  101     FORMAT(' LAYER=',I2,' MAX=',E13.6,' MIN=',E13.6)
+  102     FORMAT(9X,' MEAN=',E13.6,' STDEV=',E13.6,' RMS=',E13.6)
+        ENDDO
+      ENDIF
+#endif
+!----------------------------------------------------------------------
+      END SUBROUTINE FIELD_STATS
+!----------------------------------------------------------------------
+      FUNCTION TIMEF()
+      REAL*8 TIMEF
+      INTEGER :: IC,IR
+      CALL SYSTEM_CLOCK(COUNT=IC,COUNT_RATE=IR)
+      TIMEF=REAL(IC)/REAL(IR)*1000.0
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/start_domain_nmm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/start_domain_nmm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/dyn_nmm/start_domain_nmm.F	(revision 17)
@@ -0,0 +1,2242 @@
+!#define NO_RESTRICT_ACCEL
+!#define NO_GFDLETAINIT
+!#define NO_UPSTREAM_ADVECTION
+!----------------------------------------------------------------------
+!
+      SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
+!
+#include <dummy_new_args.inc>
+!
+     &           )
+!----------------------------------------------------------------------
+!
+      USE MODULE_DOMAIN
+      USE MODULE_DRIVER_CONSTANTS
+      USE module_model_constants
+      USE MODULE_CONFIGURE
+      USE MODULE_WRF_ERROR
+      USE MODULE_MPP
+      USE MODULE_CTLBLK
+#ifdef DM_PARALLEL
+      USE MODULE_DM,                    ONLY : LOCAL_COMMUNICATOR       &
+                                              ,MYTASK,NTASKS,NTASKS_X   &
+                                              ,NTASKS_Y
+      USE MODULE_COMM_DM
+#else
+      USE MODULE_DM
+#endif
+!
+      USE MODULE_IGWAVE_ADJUST,ONLY: PDTE, PFDHT, DDAMP
+      USE MODULE_ADVECTION,    ONLY: ADVE, VAD2, HAD2
+      USE MODULE_NONHY_DYNAM,  ONLY: VADZ, HADZ
+      USE MODULE_DIFFUSION_NMM,ONLY: HDIFF
+      USE MODULE_BNDRY_COND,   ONLY: BOCOH, BOCOV
+      USE MODULE_PHYSICS_INIT
+      USE MODULE_GWD
+!     USE MODULE_RA_GFDLETA
+!
+      USE MODULE_EXT_INTERNAL
+!
+#ifdef WRF_CHEM
+   USE MODULE_AEROSOLS_SORGAM, ONLY: SUM_PM_SORGAM
+   USE MODULE_GOCART_AEROSOLS, ONLY: SUM_PM_GOCART
+   USE MODULE_MOSAIC_DRIVER, ONLY: SUM_PM_MOSAIC
+#endif
+!
+!----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!----------------------------------------------------------------------
+!***
+!***  Arguments
+!***
+      TYPE(DOMAIN),INTENT(INOUT) :: GRID
+      LOGICAL , INTENT(IN)       :: allowed_to_read
+!
+#include <dummy_new_decl.inc>
+!
+      TYPE(GRID_CONFIG_REC_TYPE) :: CONFIG_FLAGS
+!
+#ifdef WRF_CHEM
+   REAL        RGASUNIV ! universal gas constant [ J/mol-K ]
+   PARAMETER ( RGASUNIV = 8.314510 )
+#endif
+!
+!***
+!***  LOCAL DATA
+!***
+#ifdef HWRF
+  LOGICAL :: ANAL   !zhang's doing, added for analysis option
+#endif
+      INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE                               &
+     &          ,IMS,IME,JMS,JME,KMS,KME                                &
+     &          ,IPS,IPE,JPS,JPE,KPS,KPE
+!
+      INTEGER :: ERROR,LOOP
+
+      REAL,ALLOCATABLE,DIMENSION(:) :: PHALF
+!
+      REAL :: EPSB=0.1,EPSIN=9.8
+!
+      INTEGER :: JHL=7
+!
+      INTEGER :: I,IEND,IER,IFE,IFS,IHH,IHL,IHRSTB,II,IRTN          &
+     &          ,ISIZ1,ISIZ2,ISTART,ISTAT,IX,J,J00,JFE,JFS,JHH,JJ       &
+     &          ,JM1,JM2,JM3,JP1,JP2,JP3,JX,KK                          &
+     &          ,K,K400,KBI,KBI2,KCCO2,KNT,KNTI                         &
+     &          ,LB,LRECBC,L                                            &
+     &          ,N,NMAP,NRADLH,NRADSH,NREC,NS,RECL,STAT                 &
+     &          ,STEPBL,STEPCU,STEPRA
+!
+      INTEGER :: MY_E,MY_N,MY_S,MY_W                                    &
+     &          ,MY_NE,MY_NW,MY_SE,MY_SW,MYI,MYJ,NPE
+!
+      INTEGER :: I_M
+!
+      INTEGER :: ILPAD2,IRPAD2,JBPAD2,JTPAD2
+      INTEGER :: ITS,ITE,JTS,JTE,KTS,KTE
+!
+      INTEGER,DIMENSION(3) :: LPTOP
+!
+      REAL :: ADDL,APELM,APELMNW,APEM1,CAPA,CLOGES,DPLM,DZLM,EPS,ESE   &
+     &       ,FAC1,FAC2,PDIF,PLM,PM1,PSFCK,PSS,PSUM,QLM,RANG           &
+     &       ,SLPM,TERM1,THLM,TIME,TLM,TSFCK,ULM,VLM
+!
+!!!   REAL :: BLDT,CWML,EXNSFC,G_INV,PLYR,PSFC,ROG,SFCZ,THSIJ,TL
+      REAL :: CWML,EXNSFC,G_INV,PLYR,PSURF,ROG,SFCZ,THSIJ,TL,ZOQING
+      REAL :: TEND
+#ifdef HWRF
+!zhang's doing 
+      REAL :: TSTART
+!zhang's doing ends
+#endif
+#ifdef HWRFX
+!     gopal's doing for the moving nest (MSLP computation)
+!-----------------------------------------------------------------------------------------------------
+      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                                                  :: RTOPP,APELP,DZ,SFCT,A
+!-----------------------------------------------------------------------------------------------------
+#endif
+
+!
+!!!   REAL,ALLOCATABLE,DIMENSION(:,:) :: RAINBL,RAINNC,RAINNC           &
+      INTEGER,ALLOCATABLE,DIMENSION(:,:) :: ITEMP,LOWLYR
+      REAL,ALLOCATABLE,DIMENSION(:) :: SFULL,SMID
+      REAL,ALLOCATABLE,DIMENSION(:) :: DZS,ZS
+      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: RQCBLTEN,RQIBLTEN            &
+     &                                    ,RQVBLTEN,RTHBLTEN            &
+     &                                    ,RUBLTEN,RVBLTEN              &
+     &                                    ,RQCCUTEN,RQICUTEN,RQRCUTEN   &
+     &                                    ,RQSCUTEN,RQVCUTEN,RTHCUTEN   &
+     &                                    ,RUSHTEN,RVSHTEN              &
+     &                                    ,RQCSHTEN,RQISHTEN,RQRSHTEN   &
+     &                                    ,RQSSHTEN,RQVSHTEN,RTHSHTEN   &
+     &                                    ,RQGSHTEN                     &
+     &                                    ,RTHRATEN                     &
+     &                                    ,RTHRATENLW,RTHRATENSW
+      REAL,ALLOCATABLE,DIMENSION(:,:) :: EMISS,EMTEMP,GLW,HFX           &
+     &                                  ,NCA                            &
+     &                                  ,QFX,RAINBL,RAINC,RAINNC        &
+     &                                  ,RAINNCV                        &
+     &                                  ,SNOWNC,SNOWNCV                 &
+     &                                  ,GRAUPELNC,GRAUPELNCV           &
+     &                                  ,SNOWC,THC,TMN,TSFC
+
+      REAL,ALLOCATABLE,DIMENSION(:,:) :: Z0_DUM, ALBEDO_DUM
+!
+      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: ZINT,RRI,CONVFAC,ZMID
+      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: T_TRANS,PINT_TRANS
+      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: CLDFRA_TRANS
+#ifndef WRF_CHEM
+      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: CLDFRA_OLD
+#endif
+#if 0
+      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: w0avg
+#endif
+      LOGICAL :: E_BDY,N_BDY,S_BDY,W_BDY,WARM_RAIN,ADV_MOIST_COND
+      LOGICAL :: START_OF_SIMULATION
+      LOGICAL :: LRESTART
+
+
+      integer :: jam,retval
+      CHARACTER(LEN=255) :: message
+      integer myproc
+      real :: dsig,dsigsum,pdbot,pdtot,rpdtot
+      real :: fisx,ht,prodx,rg
+      integer :: i_t=096,j_t=195,n_t=11
+      integer :: i_u=49,j_u=475,n_u=07
+      integer :: i_v=49,j_v=475,n_v=07
+      integer :: num_ozmixm, num_aerosolc
+      real :: cen_lat,cen_lon,dtphs   ! GWD
+      integer :: num_urban_layers
+!Rogers GMT
+      INTEGER :: hr, mn, sec, ms, rc
+      TYPE(WRFU_Time) :: currentTime
+
+      INTEGER :: interval_seconds, restart_interval
+
+! z0base new
+ 
+      REAL,DIMENSION(0:30) :: VZ0TBL_24
+      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/)
+ 
+! end z0base new
+!
+!----------------------------------------------------------------------
+!#define COPY_IN
+!#include <scalar_derefs.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)
+!
+      ITS=IPS
+      ITE=IPE
+      JTS=JPS
+      JTE=JPE
+      KTS=KPS
+      KTE=KPE
+
+      CALL model_to_grid_config_rec(grid%id,model_config_rec           &
+     &                             ,config_flags)
+!
+        RESTRT=config_flags%restart
+#ifdef HWRF
+!zhang's doing added for analysis option
+        ANAL=config_flags%analysis                ! gopal's doing
+!zhang's doing ends
+#endif
+
+#if 1
+      IF(IME>NMM_MAX_DIM )THEN
+        WRITE(wrf_err_message,*)                                       &
+         'start_domain_nmm ime (',ime,') > ',NMM_MAX_DIM,    &
+         '. Increase NMM_MAX_DIM in configure.wrf, clean, and recompile.'
+        CALL WRF_ERROR_FATAL(wrf_err_message)
+      ENDIF
+!
+      IF(JME>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>-2.OR.IME>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>-2.OR.JME>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(message,196)IHRST,IDAT
+      CALL wrf_message(trim(message))
+  196 FORMAT(' FORECAST BEGINS ',I2,' GMT ',2(I2,'/'),I4)
+
+
+!!    Restarts must be made from times for which boundary data is available
+
+      CALL nl_get_interval_seconds(GRID%ID, interval_seconds)
+      CALL nl_get_restart_interval(GRID%ID, restart_interval)
+      IF (MOD(restart_interval*60,interval_seconds) /= 0) THEN
+         WRITE(wrf_err_message,*)' restart_interval is not integer multiplier of interval_seconds'
+         CALL WRF_ERROR_FATAL(wrf_err_message)
+      END IF
+
+!!!!!!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
+
+!
+!----------------------------------------------------------------------
+!***  Let each task determine who its eight neighbors are because we
+!***  will need to know that for the halo exchanges.  The direction
+!***  to each neighbor will be designated by the following integers:
+!
+!***      north: 1
+!***       east: 2
+!***      south: 3
+!***       west: 4
+!***  northeast: 5
+!***  southeast: 6
+!***  southwest: 7
+!***  northwest: 8
+!
+!***  If a task has no neighbor in a particular direction because of
+!***  the presence of the global domain boundary then that element
+!***  of my_neb is set to -1.
+!-----------------------------------------------------------------------
+!
+      call wrf_get_nprocx(inpes)
+      call wrf_get_nprocy(jnpes)
+!
+      allocate(itemp(inpes,jnpes),stat=istat)
+      npe=0
+!
+      do j=1,jnpes
+      do i=1,inpes
+        itemp(i,j)=npe
+        if(npe==mype)then
+          myi=i
+          myj=j
+        endif
+        npe=npe+1
+      enddo
+      enddo
+!
+      my_n=-1
+      if(myj+1<=jnpes)my_n=itemp(myi,myj+1)
+!
+      my_e=-1
+      if(myi+1<=inpes)my_e=itemp(myi+1,myj)
+!
+      my_s=-1
+      if(myj-1>=1)my_s=itemp(myi,myj-1)
+!
+      my_w=-1
+      if(myi-1>=1)my_w=itemp(myi-1,myj)
+!
+      my_ne=-1
+      if((myi+1<=inpes).and.(myj+1<=jnpes)) &
+         my_ne=itemp(myi+1,myj+1)
+!
+      my_se=-1
+      if((myi+1<=inpes).and.(myj-1>=1)) &
+         my_se=itemp(myi+1,myj-1)
+!
+      my_sw=-1
+      if((myi-1>=1).and.(myj-1>=1)) &
+         my_sw=itemp(myi-1,myj-1)
+!
+      my_nw=-1
+      if((myi-1>=1).and.(myj+1<=jnpes)) &
+         my_nw=itemp(myi-1,myj+1)
+!
+!     my_neb(1)=my_n
+!     my_neb(2)=my_e
+!     my_neb(3)=my_s
+!     my_neb(4)=my_w
+!     my_neb(5)=my_ne
+!     my_neb(6)=my_se
+!     my_neb(7)=my_sw
+!     my_neb(8)=my_nw
+!
+      deallocate(itemp)
+#  include <HALO_NMM_INIT_1.inc>
+#  include <HALO_NMM_INIT_2.inc>
+#  include <HALO_NMM_INIT_3.inc>
+#  include <HALO_NMM_INIT_4.inc>
+#  include <HALO_NMM_INIT_5.inc>
+#  include <HALO_NMM_INIT_6.inc>
+#  include <HALO_NMM_INIT_7.inc>
+#  include <HALO_NMM_INIT_8.inc>
+#  include <HALO_NMM_INIT_9.inc>
+#  include <HALO_NMM_INIT_10.inc>
+#  include <HALO_NMM_INIT_11.inc>
+#  include <HALO_NMM_INIT_12.inc>
+#  include <HALO_NMM_INIT_13.inc>
+#  include <HALO_NMM_INIT_14.inc>
+#  include <HALO_NMM_INIT_15.inc>
+#  include <HALO_NMM_INIT_16.inc>
+#  include <HALO_NMM_INIT_17.inc>
+#  include <HALO_NMM_INIT_18.inc>
+#  include <HALO_NMM_INIT_19.inc>
+#  include <HALO_NMM_INIT_20.inc>
+#  include <HALO_NMM_INIT_21.inc>
+#  include <HALO_NMM_INIT_22.inc>
+#  include <HALO_NMM_INIT_23.inc>
+#  include <HALO_NMM_INIT_24.inc>
+#  include <HALO_NMM_INIT_25.inc>
+#  include <HALO_NMM_INIT_26.inc>
+#  include <HALO_NMM_INIT_27.inc>
+#  include <HALO_NMM_INIT_28.inc>
+#  include <HALO_NMM_INIT_29.inc>
+#  include <HALO_NMM_INIT_30.inc>
+#  include <HALO_NMM_INIT_31.inc>
+#  include <HALO_NMM_INIT_32.inc>
+#  include <HALO_NMM_INIT_33.inc>
+#  include <HALO_NMM_INIT_34.inc>
+#  include <HALO_NMM_INIT_35.inc>
+#  include <HALO_NMM_INIT_36.inc>
+#  include <HALO_NMM_INIT_37.inc>
+#  include <HALO_NMM_INIT_38.inc>
+#  include <HALO_NMM_INIT_39.inc>
+#endif
+!
+      DO J=MYJS_P4,MYJE_P4
+        grid%iheg(J)=MOD(J+1,2)
+        grid%ihwg(J)=grid%iheg(J)-1
+        grid%iveg(J)=MOD(J,2)
+        grid%ivwg(J)=grid%iveg(J)-1
+      ENDDO
+!
+      DO J=MYJS_P4,MYJE_P4
+        grid%ivw(J)=grid%ivwg(J)
+        grid%ive(J)=grid%iveg(J)
+        grid%ihe(J)=grid%iheg(J)
+        grid%ihw(J)=grid%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)
+!
+#ifdef HWRF
+!zhang's doing
+  IF((.NOT.RESTRT .AND. .NOT.ANAL) .OR. .NOT.allowed_to_read)THEN
+!end of zhang's doing
+#else
+      IF(.NOT.RESTRT)THEN
+#endif
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          grid%pdsl(I,J)  =grid%pd(I,J)*grid%res(I,J)
+          grid%prec(I,J)  =0.
+          IF(allowed_to_read)grid%acprec(I,J)=0.  ! This is gopal's inclusion for moving nest
+          grid%cuprec(I,J)=0.
+          rg=1./g
+          ht=grid%fis(i,j)*rg
+!!!       fisx=ht*g
+!          fisx=max(grid%fis(i,j),0.)
+!          prodx=grid%z0(I,J)*Z0MAX
+!          grid%z0(I,J)    =grid%sm(I,J)*Z0SEA+(1.-grid%sm(I,J))*                      &
+!     &                (grid%z0(I,J)*Z0MAX+FISx    *FCM+Z0LAND)
+!!!  &                (prodx        +FISx    *FCM+Z0LAND)
+          grid%qsh(I,J)   =0.
+          grid%akms(I,J)  =0.
+          grid%akhs(I,J)  =0.
+          grid%twbs(I,J)  =0.
+          grid%qwbs(I,J)  =0.
+          IF(allowed_to_read)THEN       ! This is gopal's inclusion for moving nest
+          grid%cldefi(I,J)=1.
+          grid%htop(I,J)  =REAL(KTS)
+          grid%htopd(I,J) =REAL(KTS)
+          grid%htops(I,J) =REAL(KTS)
+          grid%hbot(I,J)  =REAL(KTE)
+          grid%hbotd(I,J) =REAL(KTE)
+          grid%hbots(I,J) =REAL(KTE)
+          ENDIF
+!***
+!***  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.
+!***
+!
+!***  BECAUSE WE REINITIALIZE TOPOGRAPHY, LAND SEA MASK AND FIND THE TEMPERATURE
+!***  FIELD OVER THE NEW TOPOGRAPHY, AFTER THE MOVE, I THINK IT MORE APPROPRIATE
+!***  TO USE grid%nmm_tsk OR grid%sst TO RE-DERIVE grid%ths AND QS (AND CONSEQUENTLY grid%thz0 AND grid%qz0).
+!***  THIS MAY BE MORE CONSISTENT WITH THE PSEUDO-HYDROSTATIC BALANCING THAT IS
+!***  DONE OVER THE NEW TERRAIN (AND WITH NEW grid%sm). gopal!
+!***
+!***
+
+      IF(allowed_to_read)THEN       ! This is gopal's inclusion for moving nest
+
+          PM1=grid%aeta1(KTS)*grid%pdtop+grid%aeta2(KTS)*grid%pdsl(I,J)+grid%pt
+          APEM1=(1.E5/PM1)**CAPA
+
+        IF(grid%nmm_tsk(I,J)>=200.)THEN         ! have a specific skin temp, use it
+#ifdef HWRF
+          grid%ths(I,J)=grid%nmm_tsk(I,J)*(1.+P608*grid%q(I,J,KTS+1))*APEM1
+          TSFCK=grid%nmm_tsk(I,J)*(1.+P608*grid%q(I,J,KTS+1))
+#else
+          grid%ths(I,J)=grid%nmm_tsk(I,J)*APEM1
+          TSFCK=grid%nmm_tsk(I,J)
+#endif
+
+	ELSE                               ! use lowest layer as a proxy
+#ifdef HWRF
+          grid%ths(I,J)=grid%t(I,J,KTS)*(1.+P608*grid%q(I,J,KTS+1))*APEM1
+          TSFCK=grid%t(I,J,KTS)*(1.+P608*grid%q(I,J,KTS+1))
+#else
+          grid%ths(I,J)=grid%t(I,J,KTS)*APEM1
+          TSFCK=grid%t(I,J,KTS)
+#endif
+	ENDIF
+
+          PSFCK=grid%pd(I,J)+grid%pdtop+grid%pt
+!
+          IF(grid%sm(I,J)<0.5) THEN
+            grid%qsh(I,J)=PQ0/PSFCK*EXP(A2*(TSFCK-A3)/(TSFCK-A4))
+          ELSEIF(grid%sm(I,J)>0.5) THEN
+            grid%ths(I,J)=grid%sst(I,J)*(1.E5/(grid%pd(I,J)+grid%pdtop+grid%pt))**CAPA
+          ENDIF
+!
+          TERM1=-0.068283/grid%t(I,J,KTS)
+          grid%pshltr(I,J)=(grid%pd(I,J)+grid%pdtop+grid%pt)*EXP(TERM1)
+!
+          grid%ustar(I,J)=0.1
+          grid%thz0(I,J)=grid%ths(I,J)
+          grid%qz0(I,J)=grid%qsh(I,J)
+          grid%uz0(I,J)=0.
+          grid%vz0(I,J)=0.
+
+      ENDIF  ! endif for allowed to read
+! 
+        ENDDO
+        ENDDO
+
+!***
+!***  INITIALIZE CLOUD FIELDS
+!***
+      IF (MAXVAL(grid%cwm) .gt. 0. .and. MAXVAL(grid%cwm) .lt. 1.) then
+        CALL wrf_message('appear to have grid%cwm values...do not zero')
+      ELSE
+        IF(allowed_to_read)THEN       ! This is gopal's inclusion for moving nest
+        CALL wrf_message('zeroing grid%cwm')
+        DO K=KPS,KPE
+          DO J=JFS,JFE
+          DO I=IFS,IFE
+            grid%cwm(I,J,K)=0.
+          ENDDO
+          ENDDO
+        ENDDO
+        ENDIF
+      ENDIF
+!***
+!***  INITIALIZE ACCUMULATOR ARRAYS TO ZERO.
+!***
+        grid%ardsw=0.0
+        grid%ardlw=0.0
+        grid%asrfc=0.0
+        grid%avrain=0.0
+        grid%avcnvc=0.0
+!
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          grid%acfrcv(I,J)=0.
+          grid%ncfrcv(I,J)=0
+          grid%acfrst(I,J)=0.
+          grid%ncfrst(I,J)=0
+          grid%acsnow(I,J)=0.
+          grid%acsnom(I,J)=0.
+          grid%ssroff(I,J)=0.
+          grid%bgroff(I,J)=0.
+          grid%alwin(I,J) =0.
+          grid%alwout(I,J)=0.
+          grid%alwtoa(I,J)=0.
+          grid%aswin(I,J) =0.
+          grid%aswout(I,J)=0.
+          grid%aswtoa(I,J)=0.
+          grid%sfcshx(I,J)=0.
+          grid%sfclhx(I,J)=0.
+          grid%subshx(I,J)=0.
+          grid%snopcx(I,J)=0.
+          grid%sfcuvx(I,J)=0.
+          grid%sfcevp(I,J)=0.
+          grid%potevp(I,J)=0.
+          grid%potflx(I,J)=0.
+        ENDDO
+        ENDDO
+!***
+!***  INITIALIZE SATURATION SPECIFIC HUMIDITY OVER THE WATER.
+!***
+        EPS=R_D/R_V
+!
+      IF(allowed_to_read)THEN       ! This is gopal's inclusion for moving nest
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          IF(grid%sm(I,J)>0.5)THEN
+            CLOGES =-CM1/grid%sst(I,J)-CM2*ALOG10(grid%sst(I,J))+CM3
+            ESE    = 10.**(CLOGES+2.)
+            grid%qsh(I,J)= grid%sm(I,J)*EPS*ESE/(grid%pd(I,J)+grid%pdtop+grid%pt-ESE*(1.-EPS))
+          ENDIF
+        ENDDO
+        ENDDO
+      ENDIF
+!***  
+!***  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 grid%q2
+!
+      IF (MAXVAL(grid%q2) .gt. epsq2 .and. MAXVAL(grid%q2) .lt. 200.) then
+        CALL wrf_message('appear to have grid%q2 values...do not zero')
+      ELSE
+      IF(allowed_to_read)THEN       ! This is gopal's inclusion for moving nest
+        CALL wrf_message('zeroing grid%q2')
+        DO K=KPS,KPE-1
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+#ifdef HWRF
+          grid%q2(I,J,K)=0.
+#else
+          grid%q2(I,J,K)=grid%hbm2(I,J)*EPSQ2
+#endif
+        ENDDO
+        ENDDO
+        ENDDO
+!
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          grid%q2(I,J,LM)    = 0.
+#ifdef HWRF
+          grid%q2(I,J,KTE-2)= 0.
+          grid%q2(I,J,KTE-1)= 0.
+#else
+          grid%q2(I,J,KTE-2)= grid%hbm2(I,J)*Q2INI
+          grid%q2(I,J,KTE-1)= grid%hbm2(I,J)*Q2INI
+#endif
+        ENDDO
+        ENDDO
+      ENDIF
+      ENDIF
+!***  
+!***  PAD ABOVE GROUND SPECIFIC HUMIDITY IF IT IS TOO SMALL.
+!***  INITIALIZE LATENT HEATING ACCUMULATION ARRAYS.
+!***
+        DO K=KPS,KPE
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          IF(grid%q(I,J,K)<EPSQ)grid%q(I,J,K)=EPSQ
+          grid%train(I,J,K)=0.
+          grid%tcucn(I,J,K)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+!
+!***
+!***  INITIALIZE MAX/MIN TEMPERATURES.
+!***
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          grid%tlmax(I,J)=grid%t(I,J,KPS)
+          grid%tlmin(I,J)=grid%t(I,J,KPS)
+        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
+!
+          IF(grid%t(I,J,KTS)==0.)THEN
+            grid%t(I,J,KTS)=grid%t(I,J,KTS+1)
+          ENDIF
+!
+          TERM1=-0.068283/grid%t(I,J,KTS)
+          grid%pshltr(I,J)=(grid%pd(I,J)+grid%pdtop+grid%pt)*EXP(TERM1)
+        ENDDO
+        ENDDO
+      ENDIF
+!
+!----------------------------------------------------------------------
+!***  RESTART INITIALIZING.  CHECK TO SEE IF WE NEED TO ZERO
+!***  ACCUMULATION ARRAYS.
+!----------------------------------------------------------------------
+
+      TSPH=3600./GRID%DT ! needed?
+      grid%nphs0=GRID%NPHS
+#ifdef HWRF
+!zhang's doing
+      tstart = grid%TSTART
+!zhang's doing ends
+#endif
+
+      IF(MYPE==0)THEN
+        WRITE( wrf_err_message, * )' start_nmm TSTART=',grid%tstart
+        CALL wrf_debug( 1, TRIM(wrf_err_message) )
+        WRITE( wrf_err_message, * )' start_nmm TPREC=',grid%tprec
+        CALL wrf_debug( 1, TRIM(wrf_err_message) )
+        WRITE( wrf_err_message, * )' start_nmm THEAT=',grid%theat
+        CALL wrf_debug( 1, TRIM(wrf_err_message) )
+        WRITE( wrf_err_message, * )' start_nmm TCLOD=',grid%tclod
+        CALL wrf_debug( 1, TRIM(wrf_err_message) )
+        WRITE( wrf_err_message, * )' start_nmm TRDSW=',grid%trdsw
+        CALL wrf_debug( 1, TRIM(wrf_err_message) )
+        WRITE( wrf_err_message, * )' start_nmm TRDLW=',grid%trdlw
+        CALL wrf_debug( 1, TRIM(wrf_err_message) )
+        WRITE( wrf_err_message, * )' start_nmm TSRFC=',grid%tsrfc
+        CALL wrf_debug( 1, TRIM(wrf_err_message) )
+        WRITE( wrf_err_message, * )' start_nmm PCPFLG=',grid%pcpflg
+        CALL wrf_debug( 1, TRIM(wrf_err_message) )
+      ENDIF
+
+      NSTART = INT(grid%TSTART*TSPH+0.5)
+!
+      grid%ntsd = NSTART
+
+
+!! want non-zero values for grid%nprec, grid%nheat type vars to avoid problems
+!! with mod statements below.
+
+      grid%nprec  = INT(grid%TPREC *TSPH+0.5)
+      grid%nheat  = INT(grid%THEAT *TSPH+0.5)
+      grid%nclod  = INT(grid%TCLOD *TSPH+0.5)
+      grid%nrdsw  = INT(grid%TRDSW *TSPH+0.5)
+      grid%nrdlw  = INT(grid%TRDLW *TSPH+0.5)
+      grid%nsrfc  = INT(grid%TSRFC *TSPH+0.5)
+#ifdef HWRF
+!zhang's dong for analysis option:
+      grid%NCNVC0  = grid%NCNVC
+      grid%NPHS0   = grid%NPHS
+#endif
+!
+!----------------------------------------------------------------------
+!
+!***  FLAG FOR INITIALIZING ARRAYS, LOOKUP TABLES, & CONSTANTS USED IN
+!***  MICROPHYSICS AND RADIATION
+!
+!----------------------------------------------------------------------
+!
+      grid%micro_start=.TRUE.
+!
+!----------------------------------------------------------------------
+!***
+!***  INITIALIZE ADVECTION TENDENCIES TO ZERO SO THAT
+!***  BOUNDARY POINTS WILL ALWAYS BE ZERO
+!***
+      DO J=JFS,JFE
+      DO I=IFS,IFE
+        grid%adt(I,J)=0.
+        grid%adu(I,J)=0.
+        grid%adv(I,J)=0.
+      ENDDO
+      ENDDO
+!----------------------------------------------------------------------
+!***
+!***  SET INDEX ARRAYS FOR UPSTREAM ADVECTION
+!***
+!----------------------------------------------------------------------
+      DO J=JFS,JFE
+        grid%n_iup_h(J)=0
+        grid%n_iup_v(J)=0
+        grid%n_iup_adh(J)=0
+        grid%n_iup_adv(J)=0
+!
+        DO I=IFS,IFE
+          grid%iup_h(I,J)=-999
+          grid%iup_v(I,J)=-999
+          grid%iup_adh(I,J)=-999
+          grid%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.
+!
+      grid%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
+        grid%upstrm=.TRUE.
+        JBPAD2=0
+!
+        DO JJ=1,7
+          J=JJ      ! -MY_JS_GLB+1
+          KNTI=0
+          DO I=MYIS_P2,MYIE_P2
+            grid%iup_h(IMS+KNTI,J)=I
+            grid%iup_v(IMS+KNTI,J)=I
+            KNTI=KNTI+1
+          ENDDO
+          grid%n_iup_h(J)=KNTI
+          grid%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
+            grid%iup_adh(IMS+KNTI,J)=I
+            KNTI=KNTI+1
+          ENDDO
+          grid%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
+            grid%iup_adv(IMS+KNTI,J)=I
+            KNTI=KNTI+1
+          ENDDO
+          grid%n_iup_adv(J)=KNTI
+        ENDDO
+      ENDIF
+!
+      IF(N_BDY)THEN
+        grid%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
+            grid%iup_h(IMS+KNTI,J)=I
+            grid%iup_v(IMS+KNTI,J)=I
+            KNTI=KNTI+1
+          ENDDO
+          grid%n_iup_h(J)=KNTI
+          grid%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
+            grid%iup_adh(IMS+KNTI,J)=I
+            KNTI=KNTI+1
+          ENDDO
+          grid%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
+            grid%iup_adv(IMS+KNTI,J)=I
+            KNTI=KNTI+1
+          ENDDO
+          grid%n_iup_adv(J)=KNTI
+        ENDDO
+      ENDIF
+!
+      IF(W_BDY)THEN
+        grid%upstrm=.TRUE.
+        ILPAD2=0
+        DO JJ=8,JDE-8   ! JM-7
+          IF(JJ>=MY_JS_GLB-2.AND.JJ<=MY_JE_GLB+2)THEN
+            J=JJ      ! -MY_JS_GLB+1
+!
+            DO I=1,4
+              grid%iup_h(IMS+I-1,J)=I
+              grid%iup_v(IMS+I-1,J)=I
+            ENDDO
+            grid%n_iup_h(J)=4
+            grid%n_iup_v(J)=4
+          ENDIF
+        ENDDO
+!
+        DO JJ=6,JDE-6   ! JM-5
+          IF(JJ>=MY_JS_GLB-2.AND.JJ<=MY_JE_GLB+2)THEN
+            J=JJ      ! -MY_JS_GLB+1
+            KNTI=0
+            IEND=2+MOD(JJ,2)
+            DO I=2,IEND
+              grid%iup_adh(IMS+KNTI,J)=I
+              KNTI=KNTI+1
+            ENDDO
+            grid%n_iup_adh(J)=KNTI
+!
+            KNTI=0
+            IEND=2+MOD(JJ+1,2)
+            DO I=2,IEND
+              grid%iup_adv(IMS+KNTI,J)=I
+              KNTI=KNTI+1
+            ENDDO
+            grid%n_iup_adv(J)=KNTI
+!
+          ENDIF
+        ENDDO
+      ENDIF
+!
+      CALL WRF_GET_NPROCX(INPES)
+!
+      IF(E_BDY)THEN
+        grid%upstrm=.TRUE.
+        IRPAD2=0
+        DO JJ=8,JDE-8   ! JM-7
+          IF(JJ>=MY_JS_GLB-2.AND.JJ<=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=grid%n_iup_h(J)
+!
+            DO II=ISTART,IEND
+              I=II      ! -MY_IS_GLB+1
+              grid%iup_h(IMS+KNTI,J)=I
+              KNTI=KNTI+1
+            ENDDO
+            grid%n_iup_h(J)=KNTI
+          ENDIF
+        ENDDO
+!
+        DO JJ=6,JDE-6   ! JM-5
+          IF(JJ>=MY_JS_GLB-2.AND.JJ<=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==1)KNTI=grid%n_iup_adh(J)
+            DO II=ISTART,IEND
+              I=II      ! -MY_IS_GLB+1
+              grid%iup_adh(IMS+KNTI,J)=I
+              KNTI=KNTI+1
+            ENDDO
+            grid%n_iup_adh(J)=KNTI
+          ENDIF
+        ENDDO
+!***
+        DO JJ=8,JDE-8  ! JM-7
+          IF(JJ>=MY_JS_GLB-2.AND.JJ<=MY_JE_GLB+2)THEN
+            J=JJ      ! -MY_JS_GLB+1
+            IEND=IM-MOD(JJ,2)
+            ISTART=IEND-3
+            KNTI=0
+            IF(INPES==1)KNTI=grid%n_iup_v(J)
+!
+            DO II=ISTART,IEND
+              I=II      ! -MY_IS_GLB+1
+              grid%iup_v(IMS+KNTI,J)=I
+              KNTI=KNTI+1
+            ENDDO
+            grid%n_iup_v(J)=KNTI
+          ENDIF
+        ENDDO
+!
+        DO JJ=6,JDE-6  !  JM-5
+          IF(JJ>=MY_JS_GLB-2.AND.JJ<=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==1)KNTI=grid%n_iup_adv(J)
+            DO II=ISTART,IEND
+              I=II      ! -MY_IS_GLB+1
+              grid%iup_adv(IMS+KNTI,J)=I
+              KNTI=KNTI+1
+            ENDDO
+            grid%n_iup_adv(J)=KNTI
+          ENDIF
+        ENDDO
+      ENDIF
+!----------------------------------------------------------------------
+      jam=6+2*(JDE-JDS-1-9)
+!
+!***  EXTRACT em AND emt FOR THE LOCAL SUBDOMAINS
+!
+      DO J=MYJS_P5,MYJE_P5
+        grid%em_loc(J)=-9.E9
+        grid%emt_loc(J)=-9.E9
+      ENDDO
+!!!   IF(IBROW==1)THEN
+      IF(S_BDY)THEN
+        DO J=3,5
+          grid%em_loc(J)=grid%em(J-2)
+          grid%emt_loc(J)=grid%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
+          grid%em_loc(J)=grid%em(KNT)
+          grid%emt_loc(J)=grid%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>=MY_JS_GLB-2.AND.JJ<=MY_JE_GLB+2)THEN
+            J=JJ      ! -MY_JS_GLB+1
+            grid%em_loc(J)=grid%em(KNT)
+            grid%emt_loc(J)=grid%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>=MY_JS_GLB-2.AND.JJ<=MY_JE_GLB+2)THEN
+            J=JJ      ! -MY_JS_GLB+1
+            grid%em_loc(J)=grid%em(KNT)
+            grid%emt_loc(J)=grid%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
+!***
+#ifdef HWRF
+!zhang'sdoing       IF(NSTART.EQ.0)THEN
+      IF(NSTART.EQ.0 .or. .not.allowed_to_read )THEN
+!zhang's doing ends
+#else
+      IF(NSTART.EQ.0)THEN
+#endif
+!
+         GRID%NSOIL= GRID%NUM_SOIL_LAYERS
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          grid%pctsno(I,J)=-999.0
+          IF(grid%sm(I,J)<0.5)THEN
+              grid%cmc(I,J)=0.0
+!              grid%cmc(I,J)=grid%canwat(i,j)   ! tgs
+            IF(grid%sice(I,J)>0.5)THEN
+!***
+!***  SEA-ICE CASE
+!***
+              grid%smstav(I,J)=1.0
+              grid%smstot(I,J)=1.0
+              grid%ssroff(I,J)=0.0
+              grid%bgroff(I,J)=0.0
+              grid%cmc(I,J)=0.0
+              DO NS=1,GRID%NSOIL
+                grid%smc(I,NS,J)=1.0
+!               grid%sh2o(I,NS,J)=0.05
+                grid%sh2o(I,NS,J)=1.0
+              ENDDO
+            ENDIF
+          ELSE
+!***
+!***  WATER CASE
+!***
+            grid%smstav(I,J)=1.0
+            grid%smstot(I,J)=1.0
+            grid%ssroff(I,J)=0.0
+            grid%bgroff(I,J)=0.0
+            grid%soiltb(I,J)=273.16
+            grid%grnflx(I,J)=0.
+            grid%subshx(I,J)=0.0
+            grid%acsnow(I,J)=0.0
+            grid%acsnom(I,J)=0.0
+            grid%snopcx(I,J)=0.0
+            grid%cmc(I,J)=0.0
+            grid%sno(I,J)=0.0
+            DO NS=1,GRID%NSOIL
+              grid%smc(I,NS,J)=1.0
+              grid%stc(I,NS,J)=273.16
+!             grid%sh2o(I,NS,J)=0.05
+              grid%sh2o(I,NS,J)=1.0
+            ENDDO
+          ENDIF
+!
+        ENDDO
+        ENDDO
+!
+        grid%aphtim=0.0
+        grid%aratim=0.0
+        grid%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
+        grid%lvl(I,J)=LM-KTE
+      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=grid%pt
+      SLPM=101325.
+      PDIF=SLPM-grid%pt
+      DO K=1,LM
+        PSUM=PSUM+grid%deta(K)*PDIF
+        IF(LPTOP(3)==0)THEN
+          IF(PSUM>PHITP)LPTOP(3)=K
+        ELSEIF(LPTOP(2)==0)THEN
+          IF(PSUM>PMDHI)LPTOP(2)=K
+        ELSEIF(K400==0)THEN
+          IF(PSUM>P400)K400=K
+        ELSEIF(LPTOP(1)==0)THEN
+          IF(PSUM>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-grid%pt
+!
+      ALLOCATE(PHALF(LM+1),STAT=I)
+!
+      DO K=KPS,KPE-1
+        PHALF(K+1)=grid%aeta(K)*PDIF+grid%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==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=(grid%ntsd-1)*GRID%DT
+!
+!!!   CALL ZENITH(TIME,DAYI,HOUR)
+!
+      ADDL=0.
+      IF(MOD(IDAT(3),4)==0)ADDL=1.
+!
+!!!   CALL O3CLIM
+!
+!
+      DEALLOCATE(PHALF)
+!----------------------------------------------------------------------
+!***  SOME INITIAL VALUES RELATED TO TURBULENCE SCHEME
+!----------------------------------------------------------------------
+!
+      IF(allowed_to_read.and.(.NOT.RESTRT))THEN       ! This is gopal's inclusion for moving nest
+
+      DO J=JFS,JFE
+      DO I=IFS,IFE
+!***
+!***  TRY A SIMPLE LINEAR INTERP TO GET 2/10 M VALUES
+!***
+#ifdef HWRF
+!zhang's doing
+        IF(.NOT.RESTRT .OR. .NOT.allowed_to_read) then
+        grid%PDSL(I,J)=grid%PD(I,J)*grid%RES(I,J)
+        endif
+!end of zhang's doing
+#else
+        grid%PDSL(I,J)=grid%PD(I,J)*grid%RES(I,J)
+#endif
+!
+        ULM=grid%u(I,J,KTS)
+        VLM=grid%v(I,J,KTS)
+        TLM=grid%t(I,J,KTS)
+        QLM=grid%q(I,J,KTS)
+        PLM=grid%aeta1(KTS)*grid%pdtop+grid%aeta2(KTS)*grid%pdsl(I,J)+grid%pt
+        APELM=(1.0E5/PLM)**CAPA
+          TERM1=-0.068283/grid%t(I,J,KTS)
+          grid%pshltr(I,J)=(grid%pd(I,J)+grid%pdtop+grid%pt)*EXP(TERM1)
+        APELMNW=(1.0E5/grid%pshltr(I,J))**CAPA
+        THLM=TLM*APELM
+        DPLM=(grid%deta1(KTS)*grid%pdtop+grid%deta2(KTS)*grid%pdsl(I,J))*0.5
+        DZLM=R_D*DPLM*TLM*(1.+P608*QLM)/(G*PLM)
+        FAC1=10./DZLM
+        FAC2=(DZLM-10.)/DZLM
+        IF(DZLM<=10.)THEN
+          FAC1=1.
+          FAC2=0.
+        ENDIF
+!
+#ifdef HWRF
+!zhang's doing
+        IF(.NOT.RESTRT .OR. .NOT.allowed_to_read)THEN
+!end of zhang's doing
+#else
+        IF(.NOT.RESTRT)THEN
+#endif
+          grid%th10(I,J)=FAC2*grid%ths(I,J)+FAC1*THLM
+          grid%q10(I,J)=FAC2*grid%qsh(I,J)+FAC1*QLM
+#ifdef HWRF
+          IF(grid%sm(I,J).LT.0.5)THEN
+              grid%u10(I,J)=ULM*(log(10./grid%z0(I,J))/log(DZLM/grid%z0(I,J)))      ! this is all Qingfu's doing
+              grid%v10(I,J)=VLM*(log(10./grid%z0(I,J))/log(DZLM/grid%z0(I,J)))
+              ZOQING=1.944*SQRT(grid%u10(I,J)*grid%u10(I,J)+grid%v10(I,J)*grid%v10(I,J))
+            IF(ZOQING.GT.60.)THEN
+              grid%u10(I,J)=grid%u10(I,J)*(1.12-7.2/ZOQING)
+              grid%v10(I,J)=grid%v10(I,J)*(1.12-7.2/ZOQING)
+             ENDIF
+          ELSE
+             ZOQING=(0.074*SQRT(ULM*ULM+VLM*VLM)-0.58)*1.0e-3
+             ZOQING=MAX(ZOQING,grid%z0(I,J))          ! for winds greater than 12.5 m/s
+             grid%u10(I,J)=ULM*(log(10./ZOQING))/log(DZLM/ZOQING)      ! this is all Qingfu's doing
+             grid%v10(I,J)=VLM*(log(10./ZOQING))/log(DZLM/ZOQING)
+             ZOQING=1.944*SQRT(grid%u10(I,J)*grid%u10(I,J)+grid%v10(I,J)*grid%v10(I,J))
+           IF(ZOQING.GT.60.)THEN
+              grid%u10(I,J)=grid%u10(I,J)*(1.12-7.2/ZOQING)
+              grid%v10(I,J)=grid%v10(I,J)*(1.12-7.2/ZOQING)
+           END IF
+          ENDIF          
+#else
+          grid%u10(I,J)=ULM
+          grid%v10(I,J)=VLM
+#endif
+        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-grid%ths(I,J))>2.0) THEN  ! weight differently in different scenarios
+            FAC1=0.3
+            FAC2=0.7
+          ELSE
+            FAC1=0.8
+            FAC2=0.2
+          ENDIF
+
+#ifdef HWRF
+          grid%tshltr(I,J)=0.2*grid%ths(I,J)+0.8*THLM
+          grid%qshltr(I,J)=0.2*grid%qsh(I,J)+0.8*QLM
+#else
+          grid%tshltr(I,J)=FAC2*grid%ths(I,J)+FAC1*THLM
+          grid%qshltr(I,J)=FAC2*grid%qsh(I,J)+FAC1*QLM
+#endif
+        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
+!         grid%tshltr(I,J)=grid%tshltr(I,J)*APELMNW
+!       ENDIF
+      ENDDO
+      ENDDO
+
+      END IF ! IF(allowed_to_read)THEN
+!
+!----------------------------------------------------------------------
+!***  INITIALIZE TAU-1 VALUES FOR ADAMS-BASHFORTH 
+!----------------------------------------------------------------------
+!
+#ifdef HWRF
+!zhang's doing
+      IF(.NOT.RESTRT .OR. .NOT.allowed_to_read)THEN !zhang's doing
+#else
+      IF(.NOT.RESTRT)THEN
+#endif
+        DO K=KPS,KPE
+          DO J=JFS,JFE
+          DO I=ifs,ife
+          grid%told(I,J,K)=grid%t(I,J,K)   ! grid%t AT TAU-1
+          grid%uold(I,J,K)=grid%u(I,J,K)   ! grid%u AT TAU-1
+          grid%vold(I,J,K)=grid%v(I,J,K)   ! grid%v AT TAU-1
+          ENDDO
+          ENDDO
+        ENDDO
+      ENDIF
+!
+!----------------------------------------------------------------------
+!***  INITIALIZE NONHYDROSTATIC QUANTITIES
+!----------------------------------------------------------------------
+!
+!!!!	SHOULD grid%dwdt BE REDEFINED IF RESTRT?
+
+      IF((.NOT.RESTRT.OR.NEST).AND. allowed_to_read)THEN ! This is gopal's inclusion for moving nest
+        DO K=KPS,KPE
+          DO J=JFS,JFE
+          DO I=IFS,IFE
+            grid%dwdt(I,J,K)=1.
+          ENDDO
+          ENDDO
+        ENDDO
+      ENDIF
+!***
+#ifdef HWRF
+      IF(.NOT.RESTRT .OR. .NOT.allowed_to_read) THEN !zhang's doing
+#endif
+      IF(GRID%SIGMA==1)THEN
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          grid%pdsl(I,J)=grid%pd(I,J)
+        ENDDO
+        ENDDO
+      ELSE
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          grid%pdsl(I,J)=grid%res(I,J)*grid%pd(I,J)
+        ENDDO
+        ENDDO
+      ENDIF
+#ifdef HWRF
+      ENDIF !zhang's doing
+#endif
+!
+!***
+!
+!
+!!!!	SHOULD pint,z,w BE REDEFINED IF RESTRT?
+
+      WRITE( wrf_err_message, * )' restrt=',restrt,' nest=',nest
+        CALL wrf_debug( 0, TRIM(wrf_err_message) )
+      WRITE( wrf_err_message, * )' grid%pdtop=',grid%pdtop,' grid%pt=',grid%pt
+        CALL wrf_debug( 0, TRIM(wrf_err_message) )
+#ifdef HWRF
+!zhang's doing
+        IF(.NOT.RESTRT.OR.NEST .OR. .NOT.allowed_to_read)THEN
+!end of zhang's doing
+#else
+      IF(.NOT.RESTRT.OR.NEST)THEN
+#endif
+        DO K=KPS,KPE
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          grid%pint(I,J,K)=grid%eta1(K)*grid%pdtop+grid%eta2(K)*grid%pdsl(I,J)+grid%pt
+          grid%z(I,J,K)=grid%pint(I,J,K)
+          grid%w(I,J,K)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDIF
+#ifdef HWRF
+!zhang's doing
+      IF(.NOT.RESTRT.OR.NEST .OR. .NOT.allowed_to_read)THEN
+#endif
+
+        DO K=KTS,KTE-1
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+          grid%rtop(I,J,K)=(grid%q(I,J,K)*P608-grid%cwm(I,J,K)+1.)*grid%t(I,J,K)*R_D/ &
+                      ((grid%pint(I,J,K+1)+grid%pint(I,J,K))*0.5)
+        ENDDO
+        ENDDO
+        ENDDO
+#ifdef HWRF
+      ENDIF    !zhang 
+#endif
+
+#ifdef HWRFX
+! XUEJIN's doing
+! add to output MSLP at the initial time
+!
+!    COMPUTATION OF MSLP         ! This is gopal's doing
+!
+
+
+     DO J=JFS,JFE
+      DO I=IFS,IFE
+         grid%Z(I,J,1)=grid%FIS(I,J)*GI
+      ENDDO
+     ENDDO
+
+     DO K=KPS,2
+      DO J=JFS,JFE
+       DO I=IFS,IFE
+          APELP      = (grid%PINT(I,J,K+1)+grid%PINT(I,J,K))
+          RTOPP      = TRG*grid%T(I,J,K)*(1.0+grid%Q(I,J,K)*P608)/APELP
+          DZ         = RTOPP*(grid%DETA1(K)*grid%PDTOP+grid%DETA2(K)*grid%PD(I,J))
+          grid%Z(I,J,K+1) = grid%Z(I,J,K) + DZ
+       ENDDO
+      ENDDO
+     ENDDO
+
+     grid%MSLP=-9999.99
+     DO J=JFS,JFE
+      DO I=IFS,IFE
+         SFCT      = grid%T(I,J,1)*(1.+D608*grid%Q(I,J,1)) + LAPSR*(grid%Z(I,J,1)+grid%Z(I,J,2))*0.5
+         A         = LAPSR*grid%Z(I,J,1)/SFCT
+         grid%MSLP(I,J) = grid%PINT(I,J,1)*(1-A)**COEF2
+      ENDDO
+     ENDDO
+
+! SET BACK Z AS IN ORIGINAL CODE
+
+     DO K=KPS,KPE
+      DO J=JFS,JFE
+       DO I=IFS,IFE
+         grid%Z(I,J,K)=grid%PINT(I,J,K)
+       ENDDO
+      ENDDO
+     ENDDO
+
+#endif
+
+
+#ifndef NO_RESTRICT_ACCEL
+!----------------------------------------------------------------------
+!***  RESTRICTING THE ACCELERATION ALONG THE BOUNDARIES
+!----------------------------------------------------------------------
+!
+      DO J=JFS,JFE
+      DO I=IFS,IFE
+        grid%dwdtmn(I,J)=-EPSIN
+        grid%dwdtmx(I,J)= EPSIN
+      ENDDO
+      ENDDO
+!
+!***
+      IF(JHL>1)THEN
+        JHH=JDE-1-JHL+1 ! JM-JHL+1
+        IHL=JHL/2+1
+!
+        DO J=1,JHL
+          IF(J>=MY_JS_GLB-JBPAD2.AND.J<=MY_JE_GLB+JTPAD2)THEN
+            JX=J      ! -MY_JS_GLB+1
+            DO I=1,IDE-1 ! IM
+              IF(I>=MY_IS_GLB-ILPAD2.AND.I<=MY_IE_GLB+IRPAD2)THEN
+                IX=I      ! -MY_IS_GLB+1
+                grid%dwdtmn(IX,JX)=-EPSB
+                grid%dwdtmx(IX,JX)= EPSB
+              ENDIF
+            ENDDO
+          ENDIF
+        ENDDO
+!
+        DO J=JHH,JDE-1   ! JM
+          IF(J>=MY_JS_GLB-JBPAD2.AND.J<=MY_JE_GLB+JTPAD2)THEN
+            JX=J      ! -MY_JS_GLB+1
+            DO I=1,IDE-1 ! IM
+              IF(I>=MY_IS_GLB-ILPAD2.AND.I<=MY_IE_GLB+IRPAD2)THEN
+                IX=I      ! -MY_IS_GLB+1
+                grid%dwdtmn(IX,JX)=-EPSB
+                grid%dwdtmx(IX,JX)= EPSB
+              ENDIF
+            ENDDO
+          ENDIF
+        ENDDO
+!
+        DO J=1,JDE-1 ! JM
+          IF(J>=MY_JS_GLB-JBPAD2.AND.J<=MY_JE_GLB+JTPAD2)THEN
+            JX=J      ! -MY_JS_GLB+1
+            DO I=1,IHL
+              IF(I>=MY_IS_GLB-ILPAD2.AND.I<=MY_IE_GLB+IRPAD2)THEN
+                IX=I      ! -MY_IS_GLB+1
+                grid%dwdtmn(IX,JX)=-EPSB
+                grid%dwdtmx(IX,JX)= EPSB
+              ENDIF
+            ENDDO
+          ENDIF
+        ENDDO
+!
+        DO J=1,JDE-1 ! JM
+          IF(J>=MY_JS_GLB-JBPAD2.AND.J<=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>=MY_IS_GLB-ILPAD2.AND.I<=MY_IE_GLB+IRPAD2)THEN
+                IX=I      ! -MY_IS_GLB+1
+                grid%dwdtmn(IX,JX)=-EPSB
+                grid%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(EMTEMP(IMS:IME,JMS:JME),STAT=I)  ; EMTEMP   = 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(grid%mavail(IMS:IME,JMS:JME),STAT=I)  ; grid%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(SNOWNC(IMS:IME,JMS:JME),STAT=I)  ; SNOWNC   = 0.
+      ALLOCATE(SNOWNCV(IMS:IME,JMS:JME),STAT=I) ; SNOWNCV  = 0.
+      ALLOCATE(GRAUPELNC(IMS:IME,JMS:JME),STAT=I)  ; GRAUPELNC   = 0.
+      ALLOCATE(GRAUPELNCV(IMS:IME,JMS:JME),STAT=I) ; GRAUPELNCV  = 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(RUSHTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)     ; RUSHTEN = 0.
+      ALLOCATE(RVSHTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)     ; RVSHTEN = 0.
+      ALLOCATE(RQCSHTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQCSHTEN = 0.
+      ALLOCATE(RQISHTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQISHTEN  = 0.
+      ALLOCATE(RQRSHTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQRSHTEN = 0.
+      ALLOCATE(RQSSHTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQSSHTEN = 0.
+      ALLOCATE(RQGSHTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQGSHTEN = 0.
+      ALLOCATE(RQVSHTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RQVSHTEN = 0.
+      ALLOCATE(RTHSHTEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RTHSHTEN = 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(ZINT(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; ZINT = 0.
+      ALLOCATE(CONVFAC(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; CONVFAC = 0.
+      ALLOCATE(PINT_TRANS(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; PINT_TRANS = 0.
+      ALLOCATE(T_TRANS(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ;  T_TRANS = 0.
+      ALLOCATE(RRI(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ;  RRI = 0.
+      ALLOCATE(CLDFRA_TRANS(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; CLDFRA_TRANS = 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=grid%fis(I,J)*G_INV
+        ZINT(I,KTS,J)=SFCZ
+#ifdef HWRF
+!zhang's doing
+        IF(.NOT.RESTRT .OR. .NOT.allowed_to_read) then
+        grid%PDSL(I,J)=grid%PD(I,J)*grid%RES(I,J)
+        endif
+!end of zhang's doing
+#else
+        grid%pdsl(I,J)=grid%pd(I,J)*grid%res(I,J)
+#endif
+        PSURF=grid%pint(I,J,KTS)
+        EXNSFC=(1.E5/PSURF)**CAPA
+        grid%xland(I,J)=grid%sm(I,J)+1.
+        THSIJ=(grid%sst(I,J)*EXNSFC)*(grid%xland(I,J)-1.)                         &
+     &        +grid%ths(I,J)*(2.-grid%sm(I,J))
+        TSFC(I,J)=THSIJ/EXNSFC
+!
+        DO K=KTS,KTE-1
+          PLYR=(grid%pint(I,J,K)+grid%pint(I,J,K+1))*0.5
+          TL=grid%t(I,J,K)
+          CWML=grid%cwm(I,J,K)
+          RRI(I,K,J)=R_D*TL*(1.+P608*grid%q(I,J,K))/PLYR
+          ZINT(I,K+1,J)=ZINT(I,K,J)+TL/PLYR                             & 
+                     *(grid%deta1(K)*grid%pdtop+grid%deta2(K)*grid%pdsl(I,J))*ROG        & 
+                     *(grid%q(I,J,K)*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
+!-----------------------------------------------------------------------
+!
+      PDTOT=101325.-grid%pt
+      RPDTOT=1./PDTOT
+      PDBOT=PDTOT-grid%pdtop
+      SFULL(KTS)=1.
+      SFULL(KTE)=0.
+      DSIGSUM = 0.
+      DO K=KTS+1,KTE
+        DSIG=(grid%deta1(K-1)*grid%pdtop+grid%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=(grid%deta1(KTE-1)*grid%pdtop+grid%deta2(KTE-1)*PDBOT)*RPDTOT
+      DSIGSUM=DSIGSUM+DSIG
+      SMID(KTE-1)=0.5*(SFULL(KTE-1)+SFULL(KTE))
+!
+!-----------------------------------------------------------------------
+
+#ifdef HWRF
+!zhang's doing
+      if(.NOT.RESTRT .OR. .NOT.allowed_to_read)grid%LU_INDEX=grid%IVGTYP
+!end of zhang's doing
+#else
+      grid%lu_index=grid%ivgtyp
+#endif
+
+      IF(.NOT.RESTRT)THEN
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+          Z0_DUM(I,J)=grid%z0(I,J) ! hold
+          ALBEDO_DUM(I,J)=grid%albedo(I,J) ! Save albedos
+        ENDDO
+        ENDDO
+      ENDIF
+!
+!***  Always define the quantity grid%z0base
+                                                                                                                                              
+      IF(.NOT.RESTRT)THEN
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+!
+          IF(grid%sm(I,J)==0)then
+            grid%z0base(I,J)=VZ0TBL_24(grid%ivgtyp(I,J))+Z0LAND
+          ELSE
+            grid%z0base(I,J)=VZ0TBL_24(grid%ivgtyp(I,J))+Z0SEA
+          ENDIF
+!
+        ENDDO
+        ENDDO
+      ENDIF
+!
+! 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 )
+
+      if(restrt) then
+#ifdef HWRF
+!zhang 
+     CALL nl_get_julyr (grid%id, grid%julyr)
+     CALL nl_get_julday (grid%id, grid%julday)
+     CALL nl_get_gmt (grid%id, grid%gmt)
+!zhang end
+#else
+        CALL domain_clock_get( grid, current_time=currentTime )
+        CALL WRFU_TimeGet( currentTime, YY=grid%julyr, dayOfYear=grid%julday, &
+                           H=hr, M=mn, S=sec, MS=ms, rc=rc)
+        grid%gmt=hr+real(mn)/60.+real(sec)/3600.+real(ms)/(1000*3600)
+        WRITE( wrf_err_message , * ) 'DEBUG start_domain_nmm():  gmt = ',grid%gmt
+        CALL wrf_debug( 150, TRIM(wrf_err_message) )
+#endif
+      endif
+
+! 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
+#ifndef WRF_NMM_NEST
+      grid%moved = .FALSE.
+#endif
+
+      IF (GRID%RESTART) THEN
+         LRESTART = GRID%RESTART
+      ELSE
+         IF (grid%moved) THEN
+            LRESTART = .TRUE.
+         ELSE
+            LRESTART = .FALSE.
+         ENDIF
+      END IF
+
+      CALL PHY_INIT(GRID%ID,CONFIG_FLAGS,GRID%DT,LRESTART,SFULL,SMID    &
+     &             ,grid%pt,TSFC,GRID%RADT,GRID%BLDT,GRID%CUDT,GRID%GSMDT    &
+     &             ,grid%DUCUDT, grid%DVCUDT                            &
+     &             ,RTHCUTEN, RQVCUTEN, RQRCUTEN                        &
+     &             ,RQCCUTEN, RQSCUTEN, RQICUTEN                        &
+     &             ,RUSHTEN,  RVSHTEN,  RTHSHTEN                        &
+     &             ,RQVSHTEN, RQRSHTEN, RQCSHTEN                        &
+     &             ,RQSSHTEN, RQISHTEN, RQGSHTEN                        &
+     &             ,RUBLTEN,RVBLTEN,RTHBLTEN                            &
+     &             ,RQVBLTEN,RQCBLTEN,RQIBLTEN                          &
+     &             ,RTHRATEN,RTHRATENLW,RTHRATENSW                      &
+     &             ,STEPBL,STEPRA,STEPCU                                &
+     &             ,grid%w0avg, RAINNC, RAINC, grid%raincv, RAINNCV               &
+     &             ,SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV              &
+     &             ,NCA,GRID%SWRAD_SCAT                                 &
+     &             ,grid%cldefi,LOWLYR                                       &
+     &             ,grid%mass_flux                                           &
+     &             ,grid%rthften, grid%rqvften                                    &
+     &             ,CLDFRA_TRANS,CLDFRA_OLD,GLW,grid%gsw,EMISS,EMTEMP,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 &
+     &             ,TMN,grid%xland,grid%znt,grid%z0,grid%ustar,grid%mol,grid%pblh,grid%tke_pbl             &
+     &             ,grid%exch_h,THC,SNOWC,grid%mavail,HFX,QFX,RAINBL              &
+     &             ,grid%stc,ZS,DZS,GRID%NUM_SOIL_LAYERS,WARM_RAIN           &
+     &             ,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%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%smc                     &
+     &             ,grid%sh2o, grid%snowh, grid%smfr3d                                 &  ! temporary
+     &             ,grid%SNOALB                                         &
+     &             ,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           &
+     &             ,.TRUE.,grid%moved,START_OF_SIMULATION                    &
+     &             ,1                                                   & ! lagday
+     &             ,IDS, IDE, JDS, JDE, KDS, KDE                        &
+     &             ,IMS, IME, JMS, JME, KMS, KME                        &
+     &             ,ITS, ITE, JTS, JTE, KTS, KTE                        &
+     &             ,NUM_URBAN_LAYERS                                    &
+     &                )
+
+#ifdef HWRF
+!zhang's doing
+      grid%julyr_rst=grid%julyr_rst
+      grid%julday_rst=grid%julday_rst
+      grid%gmt_rst=grid%gmt_rst
+!end of zhang's doing
+#endif
+!-----------------------------------------------------------------------
+!---- Initialization for gravity wave drag (GWD) & mountain blocking (MB)
+!
+      CALL nl_get_cen_lat(GRID%ID, CEN_LAT)    !-- CEN_LAT in deg
+      CALL nl_get_cen_lon(GRID%ID, CEN_LON)    !-- CEN_LON in deg
+      DTPHS=grid%dt*grid%nphs
+      CALL GWD_init(DTPHS,GRID%DX,GRID%DY,CEN_LAT,CEN_LON,RESTRT        &
+     &              ,grid%glat,grid%glon,grid%crot,grid%srot,grid%hangl                          &
+     &              ,IDS,IDE,JDS,JDE,KDS,KDE                            &
+     &              ,IMS,IME,JMS,JME,KMS,KME                            &
+     &              ,ITS,ITE,JTS,JTE,KTS,KTE )
+      IF(.NOT.RESTRT)THEN
+        DO J=MYJS,MYJE
+        DO I=MYIS,MYIE
+          grid%ugwdsfc(I,J)=0.
+          grid%vgwdsfc(I,J)=0.
+        ENDDO
+        ENDDO
+      ENDIF
+
+!-----------------------------------------------------------------------
+!
+#ifdef HWRF
+      IF(NSTART.EQ.0 .or. .not.allowed_to_read )THEN
+#else
+       IF(NSTART==0)THEN
+#endif
+
+        DO J=JMS,JME
+        DO I=IMS,IME
+          grid%z0(I,J)=grid%z0base(I,J)
+        ENDDO
+        ENDDO
+
+        DO K=KMS,KME
+        DO J=JMS,JME
+        DO I=IMS,IME
+          grid%cldfra(I,J,K)=CLDFRA_TRANS(I,K,J)
+        ENDDO
+        ENDDO
+        ENDDO
+
+      ENDIF
+
+!
+!
+!mp replace F*_PHY with values defined in module_initialize_real.F?
+#ifdef HWRF
+      IF (.NOT. RESTRT) THEN   !zhang
+        moist = 0.0
+        grid%f_ice = grid%f_ice_phy
+        grid%f_rimef = grid%f_rimef_phy
+        grid%f_rain = grid%f_rain_phy
+      ENDIF                  !zhang
+#endif
+
+      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.
+
+!!mp
+        CALL wrf_message('Initializng moist(:,:,:, Qv) from q')
+        DO K=KPS,KPE
+        DO J=JFS,JFE
+        DO I=IFS,IFE
+           moist(I,J,K,P_QV) = grid%q(I,J,K) / (1.-grid%q(I,J,K))                 
+        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(grid%cwm).gt.0. .and. MAXVAL(grid%cwm).lt.1.) ) then    
+          do i_m = 2, num_moist
+          if (i_m.ne.p_qv) &
+     &       CALL wrf_message(' summing moist(:,:,:,i_m) into cwm array')
+          DO K=KPS,KPE
+          DO J=JFS,JFE
+          DO I=IFS,IFE
+            IF ( (moist(I,J,K,i_m).gt.EPSQ) .and. (i_m.ne.p_qv) ) THEN  
+               grid%cwm(I,J,K) = grid%cwm(I,J,K) + moist(I,J,K,i_m)               
+            ENDIF  
+          enddo    
+          enddo
+          enddo
+          enddo
+
+          IF (.not. ( (maxval(grid%f_ice)+maxval(grid%f_rain)) .gt. EPSQ) ) THEN
+            CALL wrf_message(' computing grid%f_ice')
+            do i_m = 2, num_moist
+            DO J=JFS,JFE
+            DO K=KPS,KPE
+            DO I=IFS,IFE
+              IF ( (moist(I,J,K,i_m).gt.EPSQ) .and. &
+     &               ( (i_m.eq.p_qi).or.(i_m.eq.p_qs).or.(i_m.eq.p_qg) ) ) THEN
+                 grid%f_ice(I,K,J) = grid%f_ice(I,K,J) + moist(I,J,K,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,J,K,p_qs)=moist(I,J,K,p_qs)+moist(I,J,K,i_m)
+                  moist(I,J,K,i_m) =0.
+                endif
+              endif
+            enddo
+            enddo
+            enddo
+            enddo
+            CALL wrf_message(' computing f_rain')
+!
+            DO J=JFS,JFE
+            DO K=KPS,KPE
+            DO I=IFS,IFE
+              IF(grid%f_ice(i,k,j)<=EPSQ)THEN
+                grid%f_ice(I,K,J)=0.
+              ELSE
+                grid%f_ice(I,K,J) = grid%f_ice(I,K,J)/grid%cwm(I,J,K)
+              ENDIF
+              IF ( (moist(I,J,K,p_qr)+moist(I,J,K,p_qc)).gt.EPSQ) THEN
+                IF(moist(i,j,k,p_qr)<=EPSQ)THEN
+                  grid%f_rain(I,K,J)=0.
+                ELSE
+                  grid%f_rain(I,K,J) = moist(i,j,k,p_qr) &
+     &                    / (moist(i,j,k,p_qr)+moist(i,j,k,p_qc))
+                ENDIF
+              ENDIF
+            enddo
+            enddo
+            enddo
+          ENDIF
+        ENDIF
+! End addition by Greg Thompson
+
+        IF (maxval(grid%f_ice) .gt. 0.) THEN
+         do J=JMS,JME
+         do K=KMS,KME
+         do I=IMS,IME
+          grid%f_ice_phy(I,K,J)=grid%f_ice(I,K,J)
+         enddo
+         enddo
+         enddo
+        ENDIF
+
+        IF (maxval(grid%f_rain) .gt. 0.) THEN
+         do J=JMS,JME
+         do K=KMS,KME
+         do I=IMS,IME
+          grid%f_rain_phy(I,K,J)=grid%f_rain(I,K,J)
+         enddo
+         enddo
+         enddo
+        ENDIF
+
+        IF (maxval(grid%f_rimef) .gt. 0.) THEN
+          do J=JMS,JME
+          do K=KMS,KME
+          do I=IMS,IME
+            grid%f_rimef_phy(I,K,J)=grid%f_rimef(I,K,J)
+          enddo
+          enddo
+          enddo
+        ENDIF
+      ENDIF
+!
+      IF (.NOT. RESTRT) THEN
+  !-- Replace albedos if original albedos are nonzero
+        IF(MAXVAL(ALBEDO_DUM)>0.)THEN
+          DO J=JMS,JME
+          DO I=IMS,IME
+            grid%albedo(I,J)=ALBEDO_DUM(I,J)
+          ENDDO
+          ENDDO
+        ENDIF
+      ENDIF
+
+#ifdef HWRF
+      if(.NOT. RESTRT .OR. .NOT.allowed_to_read) then !zhang's doing
+!zhang's doing
+#else
+      IF(.NOT.RESTRT)THEN
+#endif
+        DO J=JMS,JME
+        DO I=IMS,IME
+          grid%aprec(I,J)=RAINNC(I,J)*1.E-3
+          grid%cuprec(I,J)=grid%raincv(I,J)*1.E-3
+        ENDDO
+        ENDDO
+      ENDIF
+!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) = grid%pint(II,JJ,KK)/RGASUNIV/grid%t(II,JJ,KK)
+          ENDDO
+        ENDDO
+      ENDDO
+      
+      DO J=JMS,JME
+        DO K=KMS,KME
+          DO I=IMS,IME
+            PINT_TRANS(I,K,J)=grid%pint(I,J,K)
+            T_TRANS(I,K,J)=grid%t(I,J,K)
+          ENDDO
+        ENDDO
+      ENDDO 
+      DO J=JMS,JME
+          DO I=IMS,IME
+           grid%xlat(i,j)=grid%glat(I,J)/DEGRAD
+           grid%xlong(I,J)=grid%glon(I,J)/DEGRAD
+
+          ENDDO
+        ENDDO
+!!!    write(0,*)'now do chem_init'
+       CALL CHEM_INIT (GRID%ID,CHEM,EMIS_ANT,scalar,GRID%DT,GRID%BIOEMDT,GRID%PHOTDT,GRID%CHEMDT, &
+               STEPBIOE,STEPPHOT,STEPCHEM,STEPFIREPL,GRID%PLUMERISEFIRE_FRQ,      &
+               ZINT,grid%xlat,grid%xlong,G,AERWRF,CONFIG_FLAGS,grid,       &
+               RRI,T_TRANS,PINT_TRANS,CONVFAC,                 &
+               grid%ttday,grid%tcosz,grid%julday,grid%gmt,                         &
+               GD_CLOUD,GD_CLOUD2,raincv_a,raincv_b,           &
+               GD_CLOUD_a,GD_CLOUD2_a,            &
+               GD_CLOUD_B,GD_CLOUD2_B,            &
+               TAUAER1,TAUAER2,TAUAER3,TAUAER4,                      &
+               GAER1,GAER2,GAER3,GAER4,                              &
+               WAER1,WAER2,WAER3,WAER4,                              &
+               l2AER,l3AER,l4AER,l5AER,l6aer,l7aer,                 &
+               PM2_5_DRY,PM2_5_WATER,PM2_5_DRY_EC,                  &
+               grid%last_chem_time_year,grid%last_chem_time_month,               &
+               grid%last_chem_time_day,grid%last_chem_time_hour,                 &
+               grid%last_chem_time_minute,grid%last_chem_time_second,            &
+               GRID%CHEM_IN_OPT,  &
+               GRID%KEMIT,                                           &
+               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 (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2,GOCARTRADM2_KPP)
+           call sum_pm_gocart (                                             &
+                RRI, CHEM, PM2_5_DRY, PM2_5_DRY_EC,  PM10,                  &
+                IDS,IDE, JDS,JDE, KDS,KDE,                                  &
+                IMS,IME, JMS,JME, KMS,KME,                                  &
+                ITS,ITE, JTS,JTE, KTS,KTE-1                                 )
+        CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_KPP,RACMSORG_AQ,RACMSORG_KPP)
+!!!       write(0,*)'sum pm '
+           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-1                                 )
+             
+        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-1                                 )
+             
+        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(EMTEMP)
+      DEALLOCATE(GLW)
+      DEALLOCATE(HFX)
+      DEALLOCATE(LOWLYR)
+!     DEALLOCATE(grid%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(RUSHTEN)
+      DEALLOCATE(RVSHTEN)
+      DEALLOCATE(RQCSHTEN)
+      DEALLOCATE(RQISHTEN)
+      DEALLOCATE(RQRSHTEN)
+      DEALLOCATE(RQSSHTEN)
+      DEALLOCATE(RQGSHTEN)
+      DEALLOCATE(RQVSHTEN)
+      DEALLOCATE(RTHSHTEN)
+      DEALLOCATE(RTHRATEN)
+      DEALLOCATE(RTHRATENLW)
+      DEALLOCATE(RTHRATENSW)
+      DEALLOCATE(ZINT)
+      DEALLOCATE(CONVFAC)
+      DEALLOCATE(RRI)
+      DEALLOCATE(SNOWC)
+      DEALLOCATE(THC)
+      DEALLOCATE(TMN)
+      DEALLOCATE(TSFC)
+      DEALLOCATE(ZS)
+      DEALLOCATE(PINT_TRANS)
+      DEALLOCATE(T_TRANS)
+      DEALLOCATE(CLDFRA_TRANS)
+#ifndef WRF_CHEM
+      DEALLOCATE(CLDFRA_OLD)
+#endif
+#if 0
+      DEALLOCATE(w0avg)
+#endif
+!-----------------------------------------------------------------------
+!----------------------------------------------------------------------
+        DO J=jfs,jfe
+        DO I=ifs,ife
+          grid%dwdtmn(I,J)=grid%dwdtmn(I,J)*grid%hbm3(I,J)
+          grid%dwdtmx(I,J)=grid%dwdtmx(I,J)*grid%hbm3(I,J)
+        ENDDO
+        ENDDO
+!----------------------------------------------------------------------
+
+#ifdef DM_PARALLEL
+#  include <HALO_NMM_INIT_1.inc>
+#  include <HALO_NMM_INIT_2.inc>
+#  include <HALO_NMM_INIT_3.inc>
+#  include <HALO_NMM_INIT_4.inc>
+#  include <HALO_NMM_INIT_5.inc>
+#  include <HALO_NMM_INIT_6.inc>
+#  include <HALO_NMM_INIT_7.inc>
+#  include <HALO_NMM_INIT_8.inc>
+#  include <HALO_NMM_INIT_9.inc>
+#  include <HALO_NMM_INIT_10.inc>
+#  include <HALO_NMM_INIT_11.inc>
+#  include <HALO_NMM_INIT_12.inc>
+#  include <HALO_NMM_INIT_13.inc>
+#  include <HALO_NMM_INIT_14.inc>
+#  include <HALO_NMM_INIT_15.inc>
+#  include <HALO_NMM_INIT_15B.inc>
+#  include <HALO_NMM_INIT_16.inc>
+#  include <HALO_NMM_INIT_17.inc>
+#  include <HALO_NMM_INIT_18.inc>
+#  include <HALO_NMM_INIT_19.inc>
+#  include <HALO_NMM_INIT_20.inc>
+#  include <HALO_NMM_INIT_21.inc>
+#  include <HALO_NMM_INIT_22.inc>
+#  include <HALO_NMM_INIT_23.inc>
+#  include <HALO_NMM_INIT_24.inc>
+#  include <HALO_NMM_INIT_25.inc>
+#  include <HALO_NMM_INIT_26.inc>
+#  include <HALO_NMM_INIT_27.inc>
+#  include <HALO_NMM_INIT_28.inc>
+#  include <HALO_NMM_INIT_29.inc>
+#  include <HALO_NMM_INIT_30.inc>
+#  include <HALO_NMM_INIT_31.inc>
+#  include <HALO_NMM_INIT_32.inc>
+#  include <HALO_NMM_INIT_33.inc>
+#  include <HALO_NMM_INIT_34.inc>
+#  include <HALO_NMM_INIT_35.inc>
+#  include <HALO_NMM_INIT_36.inc>
+#  include <HALO_NMM_INIT_37.inc>
+#  include <HALO_NMM_INIT_38.inc>
+#  include <HALO_NMM_INIT_39.inc>
+#endif
+!#define COPY_OUT
+!#include <scalar_derefs.inc>
+
+   RETURN
+
+
+END SUBROUTINE START_DOMAIN_NMM
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/IOAPI
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/IOAPI	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/IOAPI	(revision 17)
@@ -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.  
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/Makefile	(revision 17)
@@ -0,0 +1,19 @@
+
+
+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_LITE ; make superclean )
+	( cd fftpack/fftpack5 ; make superclean )
+	( cd atm_ocn ; make superclean )
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/buf_for_proc.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/buf_for_proc.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/buf_for_proc.c	(revision 17)
@@ -0,0 +1,172 @@
+/***********************************************************************
+     
+                              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 MS_SUA
+# include <stdio.h>
+#endif
+#include <stdlib.h>
+#include "rsl_lite.h"
+#ifndef STUBMPI
+#  include "mpi.h"
+#endif
+
+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 *
+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 mess[1024] ;
+  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 ;
+  }
+#ifndef MS_SUA
+  fprintf(stderr,"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 ) ;
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/c_code.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/c_code.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/c_code.c	(revision 17)
@@ -0,0 +1,703 @@
+#ifndef MS_SUA_
+# include <stdio.h>
+#endif
+#include <fcntl.h>
+#ifndef O_CREAT
+# define O_CREAT _O_CREAT
+#endif
+#ifndef O_WRONLY
+# define O_WRONLY _O_WRONLY
+#endif
+
+#ifdef _WIN32
+#include <Winsock2.h>
+#endif
+
+#define STANDARD_ERROR 2
+
+#define STANDARD_OUTPUT 1
+
+#ifndef STUBMPI
+#  include "mpi.h"
+#endif
+#include "rsl_lite.h"
+
+#define F_PACK
+
+RSL_LITE_ERROR_DUP1 ( int *me )
+{
+    int newfd,rc ;
+    char filename[256] ;
+    char dirname[256] ;
+    char hostname[256] ;
+
+/* redirect standard out and standard error based on compile options*/
+                                                                                                                                              
+#ifndef NCEP_DEBUG_MULTIDIR
+    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 */
+# if defined( _WIN32 ) 
+    if ( *me != 0 ) {   /* stderr from task 0 should come to screen on windows because it is buffered if redirected */
+#endif
+    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) ;
+# if defined( _WIN32 ) 
+    }
+# endif
+#else
+# ifndef NCEP_DEBUG_GLOBALSTDOUT
+
+/*create TASKOUTPUT directory to contain separate task owned output directories*/
+                                                                                                                                              
+   /* let task 0 create the subdirectory path for the task directories */
+                                                                                                                                              
+    if (*me == 0)
+    {
+        sprintf(dirname, "%s","TASKOUTPUT");
+        rc = mkdir(dirname, 0777);
+        if ( rc != 0 && errno==EEXIST) rc=0;
+    }
+                                                                                                                                              
+    /* If TASKOUTPUT directory is not created then return */
+                                                                                                                                              
+    MPI_Bcast(&rc, 1, MPI_INTEGER, 0, MPI_COMM_WORLD);
+                                                                                                                                              
+    if (rc != 0 ) {
+       if (*me == 0 ) {
+          perror("mkdir error");
+          fprintf(stderr, "mkdir failed for directory %s on task %d. Sending error/output to stderr/stdout for all tasks and continuing.\n", dirname, *me);
+          return;
+       }
+       else {
+          return;
+       }
+    }
+        
+    /* TASKOUTPUT directory exists, continue with task specific directory */
+                                                                                                                                              
+    sprintf(dirname, "TASKOUTPUT/%04d", *me);
+    rc=mkdir(dirname, 0777);
+    if (  rc !=0 && errno!=EEXIST ) {
+        perror("mkdir error");
+        fprintf(stderr, "mkdir failed for directory %s on task %d. Sending error/output to stderr/stdout and continuing.\n", dirname, *me);
+        return;
+    }
+                                                                                                                                              
+   /* Each tasks creates/opens its own output and error files */
+                                                                                                                                              
+   sprintf(filename, "%s/%04d/rsl.out.%04d","TASKOUTPUT",*me,*me) ;
+        
+   if ((newfd = open( filename, O_CREAT | O_WRONLY, 0666 )) < 0 )
+   {
+        perror("error_dup: cannot open ./TASKOUTPUT/nnnn/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 ;
+   }
+        
+   sprintf(filename, "%s/%04d/rsl.error.%04d","TASKOUTPUT",*me,*me) ;
+   if ((newfd = open( filename, O_CREAT | O_WRONLY, 0666 )) < 0 )
+   {
+       perror("error_dup: cannot open ./TASKOUTPUT/nnnn/rsl.error.nnnn") ;
+       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 ;
+   }
+# else
+/* Each task writes to global standard error and standard out */
+     
+   return;
+     
+# endif
+#endif
+}
+
+#ifdef _WIN32
+/* Windows doesn't have a gethostid function so add a stub.
+   TODO: Create a version that will work on Windows. */
+int
+gethostid ()
+{
+        return 0;
+}
+#endif
+
+RSL_LITE_GET_HOSTNAME ( char * hn, int * size, int *n, int *hostid ) 
+{
+   char temp[512] ;
+   char *p, *q ; 
+   int i, cs ;
+   if ( gethostname(temp,512) ) return(1) ;
+   cs = gethostid() ;
+   for ( p = temp , q = hn , i = 0 ; *p && i < *size && i < 512 ; i++ , p++ , q++ ) { *q = *p ; }
+   *n = i ;
+   *hostid = cs ;
+   return(0) ;
+}
+
+BYTE_BCAST ( char * buf, int * size, int * Fcomm )
+{
+#ifndef STUBMPI
+    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
+#endif
+}
+
+static int yp_curs, ym_curs, xp_curs, xm_curs ;
+static int yp_curs_recv, ym_curs_recv, xp_curs_recv, xm_curs_recv ;
+
+RSL_LITE_INIT_EXCH ( 
+                int * Fcomm0,
+                int * shw0,  int * xy0 ,
+                int *sendbegm0 , int * sendwm0 , int * sendbegp0 , int * sendwp0 ,
+                int *recvbegm0 , int * recvwm0 , int * recvbegp0 , int * recvwp0 ,
+                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 sendbegm , sendwm, sendbegp , sendwp ;
+  int recvbegm , recvwm, recvbegp , recvwp ;
+  int me, np, np_x, np_y ;
+  int ips , ipe , jps , jpe , kps , kpe ;
+  int xy ;
+  int yp, ym, xp, xm ;
+  int nbytes ;
+  int nbytes_x_recv = 0, nbytes_y_recv = 0 ;
+
+#ifndef STUBMPI
+  MPI_Comm comm, *comm0, dummy_comm ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+
+  shw = *shw0 ;          /* logical half-width of stencil */
+  xy = *xy0 ;              /* 0 = y , 1 = x */
+  sendbegm = *sendbegm0 ;  /* send index of sten copy (edge = 1), lower/left */
+  sendwm   = *sendwm0   ;  /* send width of sten copy counting towards edge, lower/left */
+  sendbegp = *sendbegp0 ;  /* send index of sten copy (edge = 1), upper/right */
+  sendwp   = *sendwp0   ;  /* send width of sten copy counting towards edge, upper/right */
+  recvbegm = *recvbegm0 ;  /* recv index of sten copy (edge = 1), lower/left */
+  recvwm   = *recvwm0   ;  /* recv width of sten copy counting towards edge, lower/left */
+  recvbegp = *recvbegp0 ;  /* recv index of sten copy (edge = 1), upper/right */
+  recvwp   = *recvwp0   ;  /* recv width of sten copy counting towards edge, upper/right */
+  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 ;
+
+  yp_curs_recv = 0 ; ym_curs_recv = 0 ; 
+  xp_curs_recv = 0 ; xm_curs_recv = 0 ;
+
+  if ( xy == 0 && 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) ;
+    nbytes_y_recv = 
+             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_y_recv, RSL_RECVBUF ) ;
+       buffer_for_proc ( yp , nbytes, RSL_SENDBUF ) ;
+    }
+    if ( ym != MPI_PROC_NULL ) {
+       buffer_for_proc ( ym , nbytes_y_recv, RSL_RECVBUF ) ;
+       buffer_for_proc ( ym , nbytes, RSL_SENDBUF ) ;
+    }
+  }
+  if ( xy == 1 && 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) ;
+    nbytes_x_recv = 
+             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_x_recv, RSL_RECVBUF ) ;
+       buffer_for_proc ( xp , nbytes, RSL_SENDBUF ) ;
+    }
+    if ( xm != MPI_PROC_NULL ) {
+       buffer_for_proc ( xm , nbytes_x_recv, RSL_RECVBUF ) ;
+       buffer_for_proc ( xm , nbytes, RSL_SENDBUF ) ;
+    }
+  }
+#endif
+  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
+  yp_curs_recv = nbytes_y_recv ; ym_curs_recv = nbytes_y_recv ; 
+  xp_curs_recv = nbytes_x_recv ; xm_curs_recv = nbytes_x_recv ;
+}
+
+RSL_LITE_PACK ( int * Fcomm0, char * buf , int * shw0 , 
+           int * sendbegm0 , int * sendwm0 , int * sendbegp0 , int * sendwp0 ,
+           int * recvbegm0 , int * recvwm0 , int * recvbegp0 , int * recvwp0 ,
+           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 sendbegm , sendwm, sendbegp , sendwp ;
+  int recvbegm , recvwm, recvbegp , recvwp ;
+  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 ;
+
+#ifndef STUBMPI
+  MPI_Comm comm, *comm0, dummy_comm ;
+  int js, je, ks, ke, is, ie, wcount ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+
+  shw = *shw0 ;          /* logical half-width of stencil */
+  sendbegm = *sendbegm0 ;  /* send index of sten copy (edge = 1), lower/left */
+  sendwm   = *sendwm0   ;  /* send width of sten copy counting towards edge, lower/left */
+  sendbegp = *sendbegp0 ;  /* send index of sten copy (edge = 1), upper/right */
+  sendwp   = *sendwp0   ;  /* send width of sten copy counting towards edge, upper/right */
+  recvbegm = *recvbegm0 ;  /* recv index of sten copy (edge = 1), lower/left */
+  recvwm   = *recvwm0   ;  /* recv width of sten copy counting towards edge, lower/left */
+  recvbegp = *recvbegp0 ;  /* recv index of sten copy (edge = 1), upper/right */
+  recvwp   = *recvwp0   ;  /* recv width of sten copy counting towards edge, upper/right */
+  me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+  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)<ide)?(A):ide)
+#define JMAX(A) (((A)>jds)?(A):jds)
+#define JMIN(A) (((A)<jde)?(A):jde)
+
+  da_buf = ( pu == 0 ) ? RSL_SENDBUF : RSL_RECVBUF ;
+
+  if ( ips <= ipe && jps <= jpe ) {
+
+  if ( np_y > 1 && xy == 0 ) {
+    MPI_Cart_shift( *comm0 , 0, 1, &ym, &yp ) ;
+    if ( yp != MPI_PROC_NULL && jpe <= jde  && jde != jpe ) {
+      p = buffer_for_proc( yp , 0 , da_buf ) ;
+      if ( pu == 0 ) {
+        if ( sendwp > 0 ) {
+          je = jpe - sendbegp + 1 ; js = je - sendwp + 1 ;
+          ks = kps           ; ke = kpe ;
+          is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
+          nbytes = buffer_size_for_proc( yp, da_buf ) ;
+	  if ( yp_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ) > nbytes ) {
+#ifndef MS_SUA
+	    fprintf(stderr,"memory overwrite in rsl_lite_pack, Y pack up, %d > %d\n",
+	        yp_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ), nbytes ) ;
+#endif
+	    MPI_Abort(MPI_COMM_WORLD, 99) ;
+          }
+          if ( typesize == 8 ) {
+            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 == 4 ) {
+            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 {
+#ifndef MS_SUA
+            fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+          }
+        }
+      } else {
+        if ( recvwp > 0 ) {
+          js = jpe+recvbegp         ; je = js + recvwp - 1 ;
+          ks = kps           ; ke = kpe ;
+          is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
+          if ( typesize == 8 ) {
+            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 == 4 ) {
+            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 {
+#ifndef MS_SUA
+            fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+	  }
+	}
+      }
+    }
+    if ( ym != MPI_PROC_NULL && jps >= jds  && jps != jds ) {
+      p = buffer_for_proc( ym , 0 , da_buf ) ;
+      if ( pu == 0 ) {
+        if ( sendwm > 0 ) {
+          js = jps+sendbegm-1 ; je = js + sendwm -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( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ) > nbytes ) {
+#ifndef  MS_SUA
+	    fprintf(stderr,"memory overwrite in rsl_lite_pack, Y pack dn, %d > %d\n",
+	        ym_curs + RANGE( js, je, kps, kpe, ips-shw, ipe+shw, 1, typesize ), nbytes ) ;
+#endif
+	    MPI_Abort(MPI_COMM_WORLD, 99) ;
+          }
+          if ( typesize == 8 ) {
+            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 == 4 ) {
+            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 {
+#ifndef MS_SUA
+            fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+	  }
+	}
+      } else {
+        if ( recvwm > 0 ) {
+          je = jps-recvbegm ; js = je - recvwm + 1 ;
+          ks = kps           ; ke = kpe ;
+          is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
+          if ( typesize == 8 ) {
+            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 == 4 ) {
+            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 {
+#ifndef MS_SUA
+            fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+          }
+        }
+      }
+    }
+  }
+
+  if ( np_x > 1 && xy == 1 ) {
+    MPI_Cart_shift( *comm0, 1, 1, &xm, &xp ) ;
+    if ( xp != MPI_PROC_NULL  && ipe <= ide && ide != ipe ) {
+      p = buffer_for_proc( xp , 0 , da_buf ) ;
+      if ( pu == 0 ) {
+        if ( sendwp > 0 ) {
+          js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+          ks = kps           ; ke = kpe ;
+          ie = ipe - sendbegp + 1 ; is = ie - sendwp + 1 ;
+          nbytes = buffer_size_for_proc( xp, da_buf ) ;
+          if ( xp_curs + RANGE( js, je, kps, kpe, ipe-shw+1, ipe, 1, typesize ) > nbytes ) {
+#ifndef MS_SUA
+	    fprintf(stderr,"memory overwrite in rsl_lite_pack, X pack right, %d > %d\n",
+	        xp_curs + RANGE( js, je, kps, kpe, ipe-shw+1, ipe, 1, typesize ), nbytes ) ;
+#endif
+	    MPI_Abort(MPI_COMM_WORLD, 99) ;
+          }
+          if ( typesize == 8 ) {
+            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 == 4 ) {
+            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 {
+#ifndef MS_SUA
+            fprintf(stderr,"A internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+	  }
+	}
+      } else {
+        if ( recvwp > 0 ) {
+          js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+          ks = kps           ; ke = kpe ;
+          is = ipe+recvbegp  ; ie = is + recvwp - 1 ;
+          if ( typesize == 8 ) {
+            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 == 4 ) {
+            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 {
+#ifndef MS_SUA
+            fprintf(stderr,"B internal error: %s %d\n",__FILE__,__LINE__) ;
+            fprintf(stderr,"  stenbeg %d stenw  %d \n",is,ie) ;
+            fprintf(stderr,"  is %d ie %d \n",is,ie) ;
+#endif
+          }
+        }
+      }
+    }
+    if ( xm != MPI_PROC_NULL  && ips >= ids && ids != ips ) {
+      p = buffer_for_proc( xm , 0 , da_buf ) ;
+      if ( pu == 0 ) {
+        if ( sendwm > 0 ) {
+          js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+          ks = kps           ; ke = kpe ;
+          is = ips+sendbegm-1 ; ie = is + sendwm-1 ;
+          nbytes = buffer_size_for_proc( xm, da_buf ) ;
+          if ( xm_curs + RANGE( js, je, kps, kpe, ips, ips+shw-1, 1, typesize ) > nbytes ) {
+#ifndef MS_SUA
+	    fprintf(stderr,"memory overwrite in rsl_lite_pack, X left , %d > %d\n",
+	        xm_curs + RANGE( js, je, kps, kpe, ips, ips+shw-1, 1, typesize ), nbytes ) ;
+#endif
+	    MPI_Abort(MPI_COMM_WORLD, 99) ;
+          }
+          if ( typesize == 8 ) {
+            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 == 4 ) {
+            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 {
+#ifndef MS_SUA
+            fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+          }
+        }
+      } else {
+        if ( recvwm > 0 ) {
+          js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+          ks = kps           ; ke = kpe ;
+          ie = ips-recvbegm ; is = ie - recvwm + 1 ;
+          if ( typesize == 8 ) {
+            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 == 4 ) {
+            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 {
+#ifndef MS_SUA
+            fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+          }
+        }
+      }
+    }
+  }
+  }
+#endif
+
+}
+
+#ifndef STUBMPI
+static MPI_Request yp_recv, ym_recv, yp_send, ym_send ;
+static MPI_Request xp_recv, xm_recv, xp_send, xm_send ;
+#endif
+
+RSL_LITE_EXCH_Y ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ,
+                  int * sendw_m, int * sendw_p, int * recvw_m , int * recvw_p )
+{
+  int me, np, np_x, np_y ;
+  int yp, ym, xp, xm, ierr ;
+#ifndef STUBMPI
+  MPI_Status stat ;
+  MPI_Comm comm, *comm0, dummy_comm ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+  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 && *recvw_p > 0 ) {
+      ierr=MPI_Irecv ( buffer_for_proc( yp, yp_curs_recv, RSL_RECVBUF ), yp_curs_recv, MPI_CHAR, yp, me, comm, &yp_recv ) ;
+    }
+    if ( ym != MPI_PROC_NULL && *recvw_m > 0 ) {
+      ierr=MPI_Irecv ( buffer_for_proc( ym, ym_curs_recv, RSL_RECVBUF ), ym_curs_recv, MPI_CHAR, ym, me, comm, &ym_recv ) ;
+    }
+    if ( yp != MPI_PROC_NULL && *sendw_p > 0 ) {
+      ierr=MPI_Isend ( buffer_for_proc( yp, 0,       RSL_SENDBUF ), yp_curs, MPI_CHAR, yp, yp, comm, &yp_send ) ;
+    }
+    if ( ym != MPI_PROC_NULL && *sendw_m > 0 ) {
+      ierr=MPI_Isend ( buffer_for_proc( ym, 0,       RSL_SENDBUF ), ym_curs, MPI_CHAR, ym, ym, comm, &ym_send ) ;
+    }
+    if ( yp != MPI_PROC_NULL && *recvw_p > 0 ) {  MPI_Wait( &yp_recv, &stat ) ;  }
+    if ( ym != MPI_PROC_NULL && *recvw_m > 0 ) {  MPI_Wait( &ym_recv, &stat ) ;  }
+    if ( yp != MPI_PROC_NULL && *sendw_p > 0 ) {  MPI_Wait( &yp_send, &stat ) ;  }
+    if ( ym != MPI_PROC_NULL && *sendw_m > 0 ) {  MPI_Wait( &ym_send, &stat ) ;  }
+  }
+  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
+  yp_curs_recv = 0 ; ym_curs_recv = 0 ; 
+  xp_curs_recv = 0 ; xm_curs_recv = 0 ;
+#endif
+}
+
+RSL_LITE_EXCH_X ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 ,
+                  int * sendw_m, int * sendw_p, int * recvw_m , int * recvw_p )
+{
+  int me, np, np_x, np_y ;
+  int yp, ym, xp, xm ;
+#ifndef STUBMPI
+  MPI_Status stat ;
+  MPI_Comm comm, *comm0, dummy_comm ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+  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 && *recvw_p > 0 ) {
+      MPI_Irecv ( buffer_for_proc( xp, xp_curs_recv, RSL_RECVBUF ), xp_curs_recv, MPI_CHAR, xp, me, comm, &xp_recv ) ;
+    }
+    if ( xm != MPI_PROC_NULL && *recvw_m > 0 ) {
+      MPI_Irecv ( buffer_for_proc( xm, xm_curs_recv, RSL_RECVBUF ), xm_curs_recv, MPI_CHAR, xm, me, comm, &xm_recv ) ;
+    }
+    if ( xp != MPI_PROC_NULL && *sendw_p > 0 ) {
+      MPI_Isend ( buffer_for_proc( xp, 0,       RSL_SENDBUF ), xp_curs, MPI_CHAR, xp, xp, comm, &xp_send ) ;
+    }
+    if ( xm != MPI_PROC_NULL && *sendw_m > 0 ) {
+      MPI_Isend ( buffer_for_proc( xm, 0,       RSL_SENDBUF ), xm_curs, MPI_CHAR, xm, xm, comm, &xm_send ) ;
+    }
+    if ( xp != MPI_PROC_NULL && *recvw_p > 0 ) {  MPI_Wait( &xp_recv, &stat ) ;  }
+    if ( xm != MPI_PROC_NULL && *recvw_m > 0 ) {  MPI_Wait( &xm_recv, &stat ) ;  }
+    if ( xp != MPI_PROC_NULL && *sendw_p > 0 ) {  MPI_Wait( &xp_send, &stat ) ;  }
+    if ( xm != MPI_PROC_NULL && *sendw_m > 0 ) {  MPI_Wait( &xm_send, &stat ) ;  }
+  }
+  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
+  yp_curs_recv = 0 ; ym_curs_recv = 0 ; 
+  xp_curs_recv = 0 ; xm_curs_recv = 0 ;
+#endif
+}
+
+#if !defined( MS_SUA)  && !defined(_WIN32)
+#include <sys/time.h>
+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) ;
+}
+#endif
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/cycle.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/cycle.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/cycle.c	(revision 17)
@@ -0,0 +1,372 @@
+#ifndef MS_SUA
+# include <stdio.h>
+#endif
+#include <fcntl.h>
+
+#define STANDARD_ERROR 2
+
+#define STANDARD_OUTPUT 1
+
+#ifndef STUBMPI
+#  include "mpi.h"
+#endif
+#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 ; 
+
+#ifndef STUBMPI
+static MPI_Request *x_recv = NULL ,  *x_send = NULL ;
+#endif
+
+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 * min_subdomain ,
+                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] ;
+#ifndef STUBMPI
+  MPI_Comm *comm, dummy_comm ;
+  int ierr ;
+
+  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, 
+                       min_subdomain, min_subdomain, &ierr ) ;
+      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, 
+                       min_subdomain, min_subdomain, &ierr ) ;
+      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, 
+                       min_subdomain, min_subdomain, &ierr ) ;
+      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, 
+                       min_subdomain, min_subdomain, &ierr ) ;
+      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 ) ;
+  }
+#endif
+}
+
+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 * min_subdomain,
+           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 ;
+#ifndef STUBMPI
+  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)<ide)?(A):ide)
+#define JMAX(A) (((A)>jds)?(A):jds)
+#define JMIN(A) (((A)<jde)?(A):jde)
+
+  da_buf = ( pu == 0 ) ? RSL_SENDBUF : RSL_RECVBUF ;
+
+  if ( xy == 1 ) {   /* xy = 1, cycle in X, otherwise Y */
+    np_dim = np_x ;
+    ps = ips ;
+    pe = ipe ;
+    m = (ide-ids+1)/np_dim ;
+    n = (m*np_dim)/m ;
+  } else {
+    np_dim = np_y ;
+    ps = jps ;
+    pe = jpe ;
+    m = (jde-jds+1)/np_dim ;
+    n = (m*np_dim)/m ;
+  }
+
+  if ( np_x > 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, 
+                       min_subdomain, min_subdomain, &ierr ) ;
+        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, 
+                       min_subdomain, min_subdomain, &ierr ) ;
+        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, 
+                       min_subdomain, min_subdomain, &ierr ) ;
+        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, 
+                       min_subdomain, min_subdomain, &ierr ) ;
+        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]++ ;
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+#endif
+}
+
+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 ;
+#ifndef STUBMPI
+  MPI_Status stat ;
+  MPI_Comm comm, *comm0, dummy_comm ;
+  int i, P ;
+
+  comm0 = &dummy_comm ;
+  *comm0 = MPI_Comm_f2c( *Fcomm0 ) ;
+
+  comm = *comm0 ; me = *me0 ; np = *np0 ; np_x = *np_x0 ; np_y = *np_y0 ;
+
+  for ( P = 0 ; P < np ; P++ ) {
+      nb = buffer_size_for_proc( P, RSL_RECVBUF ) ;
+      MPI_Irecv ( buffer_for_proc( P, 0, RSL_RECVBUF ), nb, MPI_CHAR, P, me, comm, &(x_recv[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 ) ; 
+  }
+  for ( i = 0 ; i < np ; i++ ) {  x_curs_src[i] = 0 ; x_curs_dst[i] ; }
+#endif
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/f_pack.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/f_pack.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/f_pack.F90	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/f_xpose.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/f_xpose.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/f_xpose.F90	(revision 17)
@@ -0,0 +1,363 @@
+      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
+         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
+         integer, dimension((ep1-sp1+1)*(ep2-sp2+1)*(ep3-sp3+1)*max(1,(r_wordsize/i_wordsize)))         :: a
+         integer, dimension((ep1x-sp1x+1)*(ep2x-ep2x+1)*(ep3x-sp3x+1)*max(1,(r_wordsize/i_wordsize)))   :: ax
+#ifndef STUBMPI
+         include 'mpif.h'
+
+!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(0:(ep1-sp1+1)*(ep2-sp2+1)*(ep3-sp3+1)*max(1,(r_wordsize/i_wordsize)))       :: zbuf
+         integer, dimension(0:(ep1x-sp1x+1)*(ep2x-sp2x+1)*(ep3x-sp3x+1)*max(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
+             sendcurs(p) = sendcurs(p) * max(1,(r_wordsize/i_wordsize)) 
+           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) * max(1,(r_wordsize/i_wordsize))
+           else
+             recvcnts(p) = (ke(p)-ks(p)+1)*(ipe-ips+1)*(jpe-jps+1) * max(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
+#endif
+         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
+         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)*max(1,(r_wordsize/i_wordsize)))   :: ax
+         integer, dimension((ep1y-sp1y+1)*(ep2y-sp2y+1)*(ep3y-sp3y+1)*max(1,(r_wordsize/i_wordsize)))   :: ay
+#ifndef STUBMPI
+         include 'mpif.h'
+
+         integer, dimension(0:(ep1x-sp1x+1)*(ep2x-sp2x+1)*(ep3x-sp3x+1)*max(1,(r_wordsize/i_wordsize))) :: xbuf
+         integer, dimension(0:(ep1y-sp1y+1)*(ep2y-sp2y+1)*(ep3y-sp3y+1)*max(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
+
+
+! 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
+             sendcurs(p) = sendcurs(p) * max(1,(r_wordsize/i_wordsize)) 
+           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) * max(1,(r_wordsize/i_wordsize))
+           else
+             recvcnts(p) = (ie(p)-is(p)+1)*(kpex-kpsx+1)*(jpex-jpsx+1) * max(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(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
+#endif
+         return
+      end subroutine trans_x2y
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/gen_comms.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/gen_comms.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/gen_comms.c	(revision 17)
@@ -0,0 +1,2448 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#ifdef _WIN32
+#define index(X,Y) strchr(X,Y)
+#endif
+
+#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;
+
+/* print actual and dummy arguments and declarations for 4D and i1 arrays */
+int print_4d_i1_decls ( FILE *fp , node_t *p, int ad /* 0=argument,1=declaration */, int du /* 0=dummy,1=actual */)   
+{
+  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], moredims[80] ;
+  char * pos1 , * pos2 ;
+  char * dimspec ;
+  char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
+  int zdex, d ;
+
+    set_mark( 0, Domain.fields ) ;
+
+    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 1a : %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) ) {
+             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 , 3 ) ;
+                if ( ad == 0 ) 
+                /* actual or dummy argument */
+                {
+/* explicit dummy or actual arguments for 4D arrays */
+if ( q->mark == 0 ) {
+  fprintf(fp,"  num_%s, &\n",q->name) ;
+  for ( d = 3 ; d < q->ndims ; d++ ) {
+    char *colon, r[80],tx[80] ;
+    strcpy(r,"") ;
+    range_of_dimension(r,tx,d,q,du?"":"config_flags%") ;
+    colon = index(tx,':') ; *colon = '\0' ; 
+    if ( du ) { /* dummy args */
+      fprintf(fp,"%s_sdim%d,%s_edim%d, &\n",q->name,d-2,q->name,d-2) ;
+    } else {
+      fprintf(fp,"%s,%s,&\n",tx,colon+1) ;
+    }
+
+  }
+  q->mark = 1 ;
+}
+fprintf(fp,"  %s, &\n",varref) ;
+                }
+                else
+                {
+/* declaration of dummy arguments for 4D arrays */
+if ( q->mark == 0 ) {
+  fprintf(fp,"  INTEGER, INTENT(IN) :: num_%s\n",q->name) ;
+  for ( d = 3 ; d < q->ndims ; d++ ) {
+    fprintf(fp,"  INTEGER, INTENT(IN) :: %s_sdim%d,%s_edim%d\n",q->name,d-2,q->name,d-2) ;
+  }
+
+  q->mark = 1 ;
+}
+  strcpy(moredims,"") ;
+  for ( d = 3 ; d < q->ndims ; d++ ) {
+    char temp[80] ;
+    sprintf(temp,",%s_sdim%d:%s_edim%d",q->name,d-2,q->name,d-2) ;
+    strcat(moredims,temp) ;
+  }
+  strcat(moredims,",") ;
+
+fprintf(fp,"  %s, INTENT(INOUT) :: %s ( grid%%sm31:grid%%em31,grid%%sm32:grid%%em32,grid%%sm33:grid%%em33%snum_%s)\n",
+                     q->type->name , varref , moredims, q->name ) ;
+                }
+              }
+              else
+              {
+                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
+              }
+            }
+            else if ( q->node_kind & I1 )
+            {
+              if ( ad == 0 ) 
+              {
+/* explicit dummy or actual arguments for i1 arrays */
+fprintf(fp,"  %s, &\n",varref) ;
+              }
+              else
+              {
+/* declaration of dummy arguments for i1 arrays */
+              strcpy(tmp3,"") ;
+              dimspec=dimension_with_ranges( "grid%","(",-1,tmp3,q,")","" ) ;
+fprintf(fp,"  %s, INTENT(INOUT) :: %s %s\n", q->type->name , varref , dimspec ) ;
+              }
+            }
+          }
+        }
+        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
+      }
+      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+    }
+}
+
+int print_call_or_def( FILE * fp , node_t *p, char * callorsub, 
+                       char * commname, char * communicator, 
+                       int need_config_flags )
+  {
+  fprintf(fp,"%s %s_sub ( grid, &\n",callorsub,commname) ;
+  if (need_config_flags == 1)
+    fprintf(fp,"  config_flags, &\n") ;
+  print_4d_i1_decls( fp, p, 0, (!strcmp("CALL",callorsub))?0:1 );
+  fprintf(fp,"  %s, &\n",communicator) ;
+  fprintf(fp,"  mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
+  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") ;
+  return(0) ;
+  }
+
+int print_decl( FILE * fp , node_t *p, char * communicator, 
+                int need_config_flags )
+  {
+  fprintf(fp,"  USE module_domain, ONLY:domain\n") ;
+  fprintf(fp,"  USE module_configure, ONLY:grid_config_rec_type,in_use_for_config\n") ;
+  fprintf(fp,"  USE module_state_description, ONLY:PARAM_FIRST_SCALAR\n") ;
+  fprintf(fp,"  USE module_driver_constants\n") ;
+  fprintf(fp,"  TYPE(domain) ,               INTENT(IN) :: grid\n") ;
+  if (need_config_flags == 1) 
+    fprintf(fp,"  TYPE(grid_config_rec_type) , INTENT(IN) :: config_flags\n") ;
+  print_4d_i1_decls( fp, p, 1, 0 );
+  fprintf(fp,"  INTEGER ,                    INTENT(IN) :: %s\n",communicator) ;
+  fprintf(fp,"  INTEGER ,                    INTENT(IN) :: mytask, ntasks, ntasks_x, ntasks_y\n") ;
+  fprintf(fp,"  INTEGER ,                    INTENT(IN) :: ids, ide, jds, jde, kds, kde\n") ;
+  fprintf(fp,"  INTEGER ,                    INTENT(IN) :: ims, ime, jms, jme, kms, kme\n") ;
+  fprintf(fp,"  INTEGER ,                    INTENT(IN) :: ips, ipe, jps, jpe, kps, kpe\n") ;
+  fprintf(fp,"  INTEGER :: itrace\n") ;
+  fprintf(fp,"  INTEGER :: rsl_sendw_p, rsl_sendbeg_p, rsl_recvw_p, rsl_recvbeg_p\n") ;
+  fprintf(fp,"  INTEGER :: rsl_sendw_m, rsl_sendbeg_m, rsl_recvw_m, rsl_recvbeg_m\n") ;
+  fprintf(fp,"  LOGICAL, EXTERNAL :: rsl_comm_iter\n") ;
+  fprintf(fp,"  INTEGER :: idim1, idim2, idim3, idim4, idim5, idim6, idim7\n") ;
+  }
+
+int print_body( FILE * fp, char * commname )
+  {
+  fprintf(fp,"  \n") ;
+  fprintf(fp,"#ifdef DM_PARALLEL\n") ;
+  fprintf(fp,"#include \"%s_inline.inc\"\n",commname) ;
+  fprintf(fp,"#endif\n") ;
+  fprintf(fp,"  \n") ;
+  fprintf(fp,"  END SUBROUTINE %s_sub\n",commname) ;
+  }
+
+int
+gen_halos ( char * dirname , char * incname , node_t * halos, int split )
+{
+  node_t * p, * q ;
+  node_t * dimd ;
+  char commname[NAMELEN], subs_fname[NAMELEN] ;
+  char fname[NAMELEN], fnamecall[NAMELEN], fnamesub[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_int, stenwidth ;
+  char maxstenwidth[NAMELEN] ;
+  FILE * fp ;
+  FILE * fpcall ;
+  FILE * fpsub ;
+  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 ;
+  int need_config_flags;
+#define MAX_4DARRAYS 1000
+  char name_4d[MAX_4DARRAYS][NAMELEN] ;
+#define FRAC 4
+  int num_halos, fraction, ihalo, j ;
+
+  if ( dirname == NULL ) return(1) ;
+
+  if ( split ) {
+    for ( p = halos, num_halos=0 ; p != NULL ; p = p-> next ) {  /* howmany deez guys? */
+      if ( incname == NULL ) {
+        strcpy( commname, p->name ) ;
+        make_upper_case(commname) ;
+      }
+      else {
+        strcpy( commname, incname ) ;
+      }
+      if ( !(   !strcmp(commname,"HALO_INTERP_DOWN") || !strcmp(commname,"HALO_FORCE_DOWN"    )
+             || !strcmp(commname,"HALO_INTERP_UP"  ) || !strcmp(commname,"HALO_INTERP_SMOOTH" ) ) ) {
+        num_halos++ ;
+      }
+    } 
+  } 
+
+  ihalo = 0 ;
+  for ( p = halos ; p != NULL ; p = p->next )
+  {
+    need_config_flags = 0;  /* 0 = do not need, 1 = need */
+    if ( incname == NULL ) {
+      strcpy( commname, p->name ) ;
+      make_upper_case(commname) ;
+    } 
+    else {
+      strcpy( commname, incname ) ;
+    }
+    if ( incname == NULL ) {
+      if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_inline.inc",dirname,commname) ; }
+      else                       { sprintf(fname,"%s_inline.inc",commname) ; }
+      /* Generate call to custom routine that encapsulates inlined comm calls */
+      if ( strlen(dirname) > 0 ) { sprintf(fnamecall,"%s/%s.inc",dirname,commname) ; }
+      else                       { sprintf(fnamecall,"%s.inc",commname) ; }
+      if ((fpcall = fopen( fnamecall , "w" )) == NULL ) 
+      {
+        fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamecall ) ;
+        continue ; 
+      }
+      print_warning(fpcall,fnamecall) ;
+
+      if (   !strcmp(commname,"HALO_INTERP_DOWN") || !strcmp(commname,"HALO_FORCE_DOWN") 
+          || !strcmp(commname,"HALO_INTERP_UP"  ) || !strcmp(commname,"HALO_INTERP_SMOOTH") ) {
+         sprintf(subs_fname, "REGISTRY_COMM_NESTING_DM_subs.inc" ) ;
+      } else {
+         if ( split ) {
+           j = ihalo / ((num_halos+1)/FRAC+1) ;  /* the compiler you save may be your own */
+           sprintf(subs_fname, "REGISTRY_COMM_DM_%d_subs.inc", j ) ;
+           ihalo++ ;
+         } else {
+           sprintf(subs_fname, "REGISTRY_COMM_DM_subs.inc" ) ;
+         }
+      }
+
+      /* Generate definition of custom routine that encapsulates inlined comm calls */
+      if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/%s",dirname,subs_fname) ; }
+      else                       { sprintf(fnamesub,"%s",subs_fname) ; }
+      if ((fpsub = fopen( fnamesub , "a" )) == NULL ) 
+      {
+        fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamesub ) ;
+        continue ; 
+      }
+      print_warning(fpsub,fnamesub) ;
+    }
+    else {
+      /* for now, retain original behavior when called from gen_shift */
+      if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
+      else                       { sprintf(fname,"%s.inc",commname) ; }
+    }
+    /* Generate inlined comm calls */
+    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_int = 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) ; }
+if ( !strcmp(t2,"SHW") ) {
+   stenwidth = -99 ;
+   maxstenwidth_int = -99 ;   /* use a run-time computed stencil width based on nest ratio */
+   break ;                /* note that SHW is set internally by gen_shift, it should never be used in a Registry file */
+} else {
+      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_int ) maxstenwidth_int = stenwidth ;
+}
+      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+    }
+
+    if ( maxstenwidth_int == -99 ) {
+      sprintf(maxstenwidth,"grid%%parent_grid_ratio") ;
+    } else {
+      sprintf(maxstenwidth,"%d",maxstenwidth_int) ;
+    }
+
+    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 ) {
+                  need_config_flags = 1;
+                  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 ) {
+                int d ;
+                char temp[80], tx[80], r[10], *colon ;
+                strcpy( name_4d[n4d], q->name ) ;
+                for ( d = 3 ; d < q->ndims ; d++ ) {
+                  sprintf(temp,"*(%s_edim%d-%s_sdim%d+1)",q->name,d-2,q->name,d-2) ;
+                  strcat( name_4d[n4d],temp) ;
+                }
+              } 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 %s for Y %s')\n",maxstenwidth,fname) ;
+#endif
+    if ( subgrid != 0 ) {
+      fprintf(fp,"IF ( grid%%sr_y .GT. 0 ) THEN\n") ;
+    }
+
+    fprintf(fp,"CALL rsl_comm_iter_init(%s,jps,jpe)\n",maxstenwidth) ;
+    fprintf(fp,"DO WHILE ( rsl_comm_iter( grid%%id , grid%%is_intermediate, %s , &\n", maxstenwidth ) ; 
+    fprintf(fp,"                         0 , jds,jde,jps,jpe, grid%%njds, grid%%njde , & \n" ) ;
+    fprintf(fp,"     rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p,   & \n" ) ;
+    fprintf(fp,"     rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p    ))\n" ) ;
+    fprintf(fp," CALL RSL_LITE_INIT_EXCH ( local_communicator, %s, 0, &\n",maxstenwidth) ;
+    fprintf(fp,"     rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p,   & \n" ) ;
+    fprintf(fp,"     rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p,   & \n" ) ;
+    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_halo( 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") ;
+    fprintf(fp,"                          rsl_sendw_m,  rsl_sendw_p, rsl_recvw_m,  rsl_recvw_p    )\n" ) ;
+/* generate unpacks after stencil exchange in Y */
+    gen_packs_halo( fp, p, maxstenwidth, 0, 1 , "RSL_LITE_PACK", "local_communicator" ) ;
+    fprintf(fp,"ENDDO\n") ; 
+
+/* generate the stencil init statement for X transfer */
+    fprintf(fp,"CALL rsl_comm_iter_init(%s,ips,ipe)\n",maxstenwidth) ;
+    fprintf(fp,"DO WHILE ( rsl_comm_iter( grid%%id , grid%%is_intermediate, %s , &\n", maxstenwidth ) ; 
+    fprintf(fp,"                         1 , ids,ide,ips,ipe, grid%%nids, grid%%nide , & \n" ) ;
+    fprintf(fp,"     rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p,   & \n" ) ;
+    fprintf(fp,"     rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p    ))\n" ) ;
+    fprintf(fp," CALL RSL_LITE_INIT_EXCH ( local_communicator, %s, 1, &\n",maxstenwidth) ;
+    fprintf(fp,"     rsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p,   & \n" ) ;
+    fprintf(fp,"     rsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p,   & \n" ) ;
+    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_halo( 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") ;
+    fprintf(fp,"                          rsl_sendw_m,  rsl_sendw_p, rsl_recvw_m,  rsl_recvw_p    )\n" ) ;
+/* generate unpacks after stencil exchange in X */
+    gen_packs_halo( fp, p, maxstenwidth, 1, 1, "RSL_LITE_PACK", "local_communicator" ) ;
+    fprintf(fp,"    ENDDO\n") ; 
+    if ( subgrid != 0 ) {
+      fprintf(fp,"ENDIF\n") ;
+    }
+    close_the_file(fp) ;
+    if ( incname == NULL ) {
+      /* Finish call to custom routine that encapsulates inlined comm calls */
+      print_call_or_def(fpcall, p, "CALL", commname, "local_communicator", need_config_flags );
+      close_the_file(fpcall) ;
+      /* Generate definition of custom routine that encapsulates inlined comm calls */
+      print_call_or_def(fpsub, p, "SUBROUTINE", commname, "local_communicator", need_config_flags );
+      print_decl(fpsub, p, "local_communicator", need_config_flags );
+      print_body(fpsub, commname);
+      close_the_file(fpsub) ;
+    }
+  }
+  return(0) ;
+}
+
+gen_packs_halo ( FILE *fp , node_t *p, char *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 varname[NAMELEN] ;
+  char * pos1 , * pos2 ;
+  char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
+  int xdex,ydex,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 1b : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
+        else
+        {
+
+          strcpy( varname, t2 ) ;
+          strcpy( varref, t2 ) ;
+          if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
+             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 )
+              {
+                int d ;
+                char * colon ;
+                char moredims[80], tx[80], temp[10], r[80] ;
+                set_mem_order( q->members, memord , 3 ) ;
+fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ;
+                strcpy(moredims,"") ; 
+                for ( d = q->ndims-1 ; d >= 3  ; d-- ) {
+fprintf(fp,"  DO idim%d = %s_sdim%d,%s_edim%d\n",d-2,q->name,d-2,q->name,d-2 ) ;
+                }
+                for ( d = 3 ; d < q->ndims ; d++ ) {
+                  strcpy(r,"") ;
+                  range_of_dimension( r, tx, d, q, "config_flags%" ) ;
+                  colon = index(tx,':') ; if ( colon != NULL ) *colon = ',' ;
+                  sprintf(temp,"idim%d",d-2) ;
+                  strcat(moredims,",") ; strcat(moredims,temp) ;
+                }
+                strcat(moredims,",") ;
+                xdex = get_index_for_coord( q , COORD_X ) ;
+                ydex = get_index_for_coord( q , COORD_Y ) ;
+fprintf(fp," IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; 
+fprintf(fp,"  CALL %s ( %s,&\n%s ( grid%%sm31,grid%%sm32,grid%%sm33%sitrace),%s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n",
+                       packname, commname, varref , moredims, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
+fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
+if ( !strcmp( packname, "RSL_LITE_PACK_SWAP" ) ||
+     !strcmp( packname, "RSL_LITE_PACK_CYCLE" ) ) {
+  fprintf(fp,"thisdomain_max_halo_width,                         &\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," ENDIF\n") ;
+               for ( d = 3 ; d < q->ndims ; d++ ) {
+fprintf(fp,"  ENDDO ! idim%d \n",d-2 ) ;
+               }
+
+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 , 3 ) ;
+              if       ( q->ndims == 3 ) {
+
+                dimd = get_dimnode_for_coord( q , COORD_Z ) ;
+                xdex = get_index_for_coord( q , COORD_X ) ;
+                ydex = get_index_for_coord( q , COORD_Y ) ;
+                zdex = get_index_for_coord( q , COORD_Z ) ;
+                fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; 
+                if ( dimd != NULL )
+                {
+                  char s[256], e[256] ;
+
+                  if      ( dimd->len_defined_how == DOMAIN_STANDARD ) {
+                    fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", 
+                        packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?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) ;
+                    }
+                    fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", 
+                        packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?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 )
+                  {
+                    fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", 
+                        packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?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) ;
+                    }
+                  }
+                }
+                fprintf(fp,"ENDIF\n") ;
+              } else if ( q->ndims == 2 ) {
+                xdex = get_index_for_coord( q , COORD_X ) ;
+                ydex = get_index_for_coord( q , COORD_Y ) ;
+                fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; 
+                fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", 
+                       packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?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") ;
+                }
+                fprintf(fp,"ENDIF\n") ;
+              }
+            }
+          }
+          
+        }
+        t2 = strtok_rentr( NULL , "," , &pos2 ) ;
+      }
+      t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+    }
+}
+
+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 varname[NAMELEN] ;
+  char * pos1 , * pos2 ;
+  char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
+  int xdex,ydex,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 1b : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
+        else
+        {
+
+          strcpy( varname, t2 ) ;
+          strcpy( varref, t2 ) ;
+          if ( q->node_kind & FIELD  && ! (q->node_kind & I1) ) {
+             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 , 3 ) ;
+fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ;
+                xdex = get_index_for_coord( q , COORD_X ) ;
+                ydex = get_index_for_coord( q , COORD_Y ) ;
+fprintf(fp," IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; 
+fprintf(fp,"  CALL %s ( %s,&\n%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, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
+fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y,       &\n") ;
+if ( !strcmp( packname, "RSL_LITE_PACK_SWAP" ) ||
+     !strcmp( packname, "RSL_LITE_PACK_CYCLE" ) ) {
+  fprintf(fp,"thisdomain_max_halo_width,                         &\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," ENDIF\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 , 3 ) ;
+              if       ( q->ndims == 3 ) {
+
+                dimd = get_dimnode_for_coord( q , COORD_Z ) ;
+                xdex = get_index_for_coord( q , COORD_X ) ;
+                ydex = get_index_for_coord( q , COORD_Y ) ;
+                zdex = get_index_for_coord( q , COORD_Z ) ;
+                fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; 
+                if ( dimd != NULL )
+                {
+                  char s[256], e[256] ;
+
+                  if      ( dimd->len_defined_how == DOMAIN_STANDARD ) {
+                    fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?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) ;
+                    }
+                    fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?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 )
+                  {
+                    fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?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) ;
+                    }
+                  }
+                }
+                fprintf(fp,"ENDIF\n") ;
+              } else if ( q->ndims == 2 ) {
+                xdex = get_index_for_coord( q , COORD_X ) ;
+                ydex = get_index_for_coord( q , COORD_Y ) ;
+                fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; 
+                fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?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") ;
+                }
+                fprintf(fp,"ENDIF\n") ;
+              }
+            }
+          }
+          
+        }
+        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], fnamecall[NAMELEN], fnamesub[NAMELEN] ;
+  char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
+  char commuse[NAMELEN] ;
+  int maxperwidth, perwidth ;
+  FILE * fp ;
+  FILE * fpcall ;
+  FILE * fpsub ;
+  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) ;
+
+  /* Open and truncate REGISTRY_COMM_DM_PERIOD_subs.inc so file exists even if there are no periods. */
+  if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/REGISTRY_COMM_DM_PERIOD_subs.inc",dirname) ; }
+  else                       { sprintf(fnamesub,"REGISTRY_COMM_DM_PERIOD_subs.inc") ; }
+  if ((fpsub = fopen( fnamesub , "w" )) == NULL ) 
+  {
+    fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamesub ) ;
+  }
+  if ( fpsub != NULL ) {
+    print_warning(fpsub,fnamesub) ;
+    fclose(fpsub) ;
+  }
+
+  for ( p = periods ; p != NULL ; p = p->next )
+  {
+    strcpy( commname, p->name ) ;
+    make_upper_case(commname) ;
+    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_inline.inc",dirname,commname) ; }
+    else                       { sprintf(fname,"%s_inline.inc",commname) ; }
+    /* Generate call to custom routine that encapsulates inlined comm calls */
+    if ( strlen(dirname) > 0 ) { sprintf(fnamecall,"%s/%s.inc",dirname,commname) ; }
+    else                       { sprintf(fnamecall,"%s.inc",commname) ; }
+    if ((fpcall = fopen( fnamecall , "w" )) == NULL ) 
+    {
+      fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamecall ) ;
+      continue ; 
+    }
+    print_warning(fpcall,fnamecall) ;
+    print_call_or_def(fpcall, p, "CALL", commname, "local_communicator_periodic", 1 );
+    close_the_file(fpcall) ;
+
+    /* Generate definition of custom routine that encapsulates inlined comm calls */
+    if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/REGISTRY_COMM_DM_PERIOD_subs.inc",dirname) ; }
+    else                       { sprintf(fnamesub,"REGISTRY_COMM_DM_PERIOD_subs.inc") ; }
+    if ((fpsub = fopen( fnamesub , "a" )) == NULL ) 
+    {
+      fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamesub ) ;
+      continue ; 
+    }
+    print_call_or_def(fpsub, p, "SUBROUTINE", commname, "local_communicator_periodic", 1 );
+    print_decl(fpsub, p, "local_communicator_periodic", 1 );
+    print_body(fpsub, commname);
+    close_the_file(fpsub) ;
+
+    /* Generate inlined comm calls */
+    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 period 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,"      thisdomain_max_halo_width, &\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 cycle 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,"      thisdomain_max_halo_width,               &\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) ) {
+           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: 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)) ;
+        }
+        if ( q->node_kind & FOURD ) {
+           strcat( varref_z, "(grid%sm31,grid%sm32,grid%sm33,itrace )" ) ;
+        }
+
+/* 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) ) {
+           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: 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)) ;
+        }
+        if ( q->node_kind & FOURD ) {
+           strcat( varref_x, "(grid%sm31x,grid%sm32x,grid%sm33x,itrace )" ) ;
+        }
+
+/* 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) ) {
+           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: 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)) ;
+        }
+        if ( q->node_kind & FOURD ) {
+           strcat( varref_y, "(grid%sm31y,grid%sm32y,grid%sm33y,itrace )" ) ;
+        }
+
+        t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
+      }
+      set_mem_order( q, memord , 3 ) ;
+      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) ;
+}
+
+
+
+int
+gen_shift (  char * dirname )
+{
+  int i ;
+  FILE * fp ;
+  node_t *p, *q, *dimd ;
+  char **direction ;
+  char *directions[] = { "x", "y", 0L } ;
+  char fname[NAMELEN], vname[NAMELEN] ;
+  char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
+  char memord[NAMELEN] ;
+  int xdex,ydex,zdex ;
+  node_t Shift ;
+int said_it = 0 ;
+int said_it2 = 0 ;
+
+  for ( direction = directions ; *direction != NULL ; direction++ )
+  {
+    if ( dirname == NULL ) return(1) ;
+    if ( sw_unidir_shift_halo ) {
+       sprintf(fname,"shift_halo",*direction) ;
+    } else {
+       sprintf(fname,"shift_halo_%s_halo",*direction) ;
+    }
+
+    Shift.next = NULL ;
+    sprintf( Shift.use, "" ) ;
+    strcpy( Shift.comm_define, "SHW:" ) ;
+    strcpy( Shift.name , fname ) ;
+    if ( sw_move ) {
+    for ( p = Domain.fields ; p != NULL ; p = p->next ) {
+      if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
+      {
+
+/* 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 */
+/* also make sure we don't shift or halo any transpose variables (ALL_X_ON_PROC or ALL_Y_ON_PROC) */
+        if ( get_dimnode_for_coord( p , COORD_X ) && get_dimnode_for_coord( p , COORD_Y ) && 
+             !(p->proc_orient == ALL_X_ON_PROC || p->proc_orient == ALL_Y_ON_PROC) ) {
+          
+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' ;
+    }
+
+/* if unidir halo, then only generate on x pass */
+    if ( ! ( sw_unidir_shift_halo && !strcmp(*direction,"y" ) ) ) {
+      gen_halos( dirname , NULL, &Shift, 0 ) ;
+    }
+
+    sprintf(fname,"%s/shift_halo_%s.inc",dirname,*direction) ;
+    if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
+
+/* now generate the shifts themselves */
+    if ( sw_move ) {
+    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 ;
+}
+/* do not shift transpose variables */
+if ( p->proc_orient == ALL_X_ON_PROC || p->proc_orient == ALL_Y_ON_PROC ) continue ;
+
+      if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
+      {
+
+	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->node_kind & FOURD )
+            {
+              node_t *member ;
+
+              xdex = get_index_for_coord( p , COORD_X ) ;
+              ydex = get_index_for_coord( p , COORD_Y ) ;
+              zdex = get_index_for_coord( p , COORD_Z ) ;
+              if ( zdex >=1 && zdex <= 3 )
+              {
+                int d ; 
+                char r[10], tx[80], temp[80], moredims[80], *colon ;
+                set_mem_order( p->members, memord , 3 ) ;
+fprintf(fp, "  DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
+                for ( d = p->ndims-1; d >= 3 ; d-- ) {
+                  strcpy(r,"") ;
+                  range_of_dimension( r, tx, d, p, "config_flags%") ;
+                  colon = index(tx,':') ; *colon = ',' ;
+fprintf(fp, "  DO idim%d = %s\n", d-2, tx ) ;
+                }
+                strcpy(moredims,"") ;
+                for ( d = 3 ; d < p->ndims ; d++ ) {
+                  sprintf(temp,"idim%d",d-2) ;
+                  strcat(moredims,",") ; strcat(moredims,temp) ;
+                }
+                strcat(moredims,",") ;
+                if ( !strcmp( *direction, "x" ) )
+                {
+                  char * stag = "" ;
+                  stag = p->members->stag_x?"":"-1" ;
+                  if        ( !strncmp( memord , "XYZ", 3 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                    fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme,:%sitrace) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme,:%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "YXZ", 3 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                    fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe),:%sitrace) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px,:%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "XZY", 3 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                    fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),:,jms:jme%sitrace) = grid%%%s (ips+px:min(ide%s,ipe)+px,:,jms:jme%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "YZX", 3 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                    fprintf(fp,"grid%%%s (jms:jme,:,ips:min(ide%s,ipe)%sitrace) = grid%%%s (jms:jme,:,ips+px:min(ide%s,ipe)+px%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "ZXY", 3 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                    fprintf(fp,"grid%%%s (:,ips:min(ide%s,ipe),jms:jme%sitrace) = grid%%%s (:,ips+px:min(ide%s,ipe)+px,jms:jme%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "ZYX", 3 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                    fprintf(fp,"grid%%%s (:,jms:jme,ips:min(ide%s,ipe)%sitrace) = grid%%%s (:,jms:jme,ips+px:min(ide%s,ipe)+px%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "XY", 2 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                    fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme%sitrace) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "YX", 2 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                    fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe)%sitrace) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  }
+                }
+                else
+                {
+                  char * stag = "" ;
+                  stag = p->members->stag_y?"":"-1" ;
+                  if        ( !strncmp( memord , "XYZ", 3 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	            fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe),:%sitrace) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py,:%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "YXZ", 3 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	            fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime,:%sitrace) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime,:%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "XZY", 3 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	            fprintf(fp,"grid%%%s (ims:ime,:,jps:min(jde%s,jpe)%sitrace) = grid%%%s (ims:ime,:,jps+py:min(jde%s,jpe)+py%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "YZX", 3 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	            fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),:,ims:ime%sitrace) = grid%%%s (jps+py:min(jde%s,jpe)+py,:,ims:ime%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "ZXY", 3 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	            fprintf(fp,"grid%%%s (:,ims:ime,jps:min(jde%s,jpe)%sitrace) = grid%%%s (:,ims:ime,jps+py:min(jde%s,jpe)+py%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "ZYX", 3 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	            fprintf(fp,"grid%%%s (:,jps:min(jde%s,jpe),ims:ime%sitrace) = grid%%%s (:,jps+py:min(jde%s,jpe)+py,ims:ime%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "XY", 2 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	            fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe)%sitrace) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  } else if ( !strncmp( memord , "YX", 2 ) ) {
+                    fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	            fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime%sitrace) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime%sitrace)\n", vname, stag, moredims, vname, stag, moredims ) ;
+                    fprintf(fp,"ENDIF\n") ;
+                  }
+                }
+                for ( d = p->ndims-1; d >= 3 ; d-- ) {
+fprintf(fp, "  ENDDO\n" ) ;
+                }
+fprintf(fp, "  ENDDO\n" ) ;
+              }
+              else
+              {
+                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
+              }
+            }
+            else
+	    {
+              xdex = get_index_for_coord( p , COORD_X ) ;
+              ydex = get_index_for_coord( p , COORD_Y ) ;
+              set_mem_order( p, memord , 3 ) ;
+              if ( !strcmp( *direction, "x" ) ) {
+                if        ( !strcmp( memord , "XYZ" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                  fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme,:) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme,:)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "YXZ" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                  fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe),:) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px,:)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "XZY" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                  fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),:,jms:jme) = grid%%%s (ips+px:min(ide%s,ipe)+px,:,jms:jme)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "YZX" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                  fprintf(fp,"grid%%%s (jms:jme,:,ips:min(ide%s,ipe)) = grid%%%s (jms:jme,:,ips+px:min(ide%s,ipe)+px)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "ZXY" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                  fprintf(fp,"grid%%%s (:,ips:min(ide%s,ipe),jms:jme) = grid%%%s (:,ips+px:min(ide%s,ipe)+px,jms:jme)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "ZYX" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                  fprintf(fp,"grid%%%s (:,jms:jme,ips:min(ide%s,ipe)) = grid%%%s (:,jms:jme,ips+px:min(ide%s,ipe)+px)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "XY" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                  fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "YX" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+                  fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe)) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px)\n", vname,  p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                }
+              } else {
+                if        ( !strcmp( memord , "XYZ" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	          fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe),:) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py,:)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "YXZ" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	          fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime,:) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime,:)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "XZY" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	          fprintf(fp,"grid%%%s (ims:ime,:,jps:min(jde%s,jpe)) = grid%%%s (ims:ime,:,jps+py:min(jde%s,jpe)+py)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "YZX" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	          fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),:,ims:ime) = grid%%%s (jps+py:min(jde%s,jpe)+py,:,ims:ime)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "ZXY" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	          fprintf(fp,"grid%%%s (:,ims:ime,jps:min(jde%s,jpe)) = grid%%%s (:,ims:ime,jps+py:min(jde%s,jpe)+py)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "ZYX" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	          fprintf(fp,"grid%%%s (:,jps:min(jde%s,jpe),ims:ime) = grid%%%s (:,jps+py:min(jde%s,jpe)+py,ims:ime)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "XY" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	          fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe)) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                } else if ( !strcmp( memord , "YX" ) ) {
+                  fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ; 
+	          fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
+                  fprintf(fp,"ENDIF\n") ;
+                }
+              }
+            }
+	  }
+	}
+      }
+    }
+    } /* if sw_move */
+    close_the_file(fp) ;
+  }
+}
+
+int
+gen_datacalls ( char * dirname )
+{
+  FILE * fp ;
+  char * fn = "data_calls.inc" ;
+  char fname[NAMELEN] ;
+
+  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) ;
+  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 * 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], fourd_names[NAMELEN_LONG] ;
+  int d2, d3, sw ;
+  char *info_name ;
+
+  for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
+  {
+    fn = *fnp ;
+      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) ;
+
+      d2 = 0 ;
+      d3 = 0 ;
+      node = Domain.fields ;
+
+      count_fields ( node , &d2 , &d3 , fourd_names, 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 + %s )* nlev + %d\n", d3, fourd_names, 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,"                        ,thisdomain_max_halo_width                                  &\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, 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,"                        ,thisdomain_max_halo_width                                  &\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 * 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 fourd_names[NAMELEN_LONG] ;
+  int d2, d3 ;
+
+  for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
+  {
+    fn = *fnp ;
+      d2 = 0 ;
+      d3 = 0 ;
+      node = Domain.fields ;
+
+      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) ;
+
+      count_fields ( node , &d2 , &d3 , fourd_names, down_path[ipath] ) ;
+
+      if ( d2 + d3 > 0 && strlen(fourd_names) > 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, 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 , int dir, int down_path )
+{
+  int i, d1 ;
+  node_t *p, *p1, *dim ;
+  int d2, d3, xdex, ydex, zdex ;
+  int nest_mask ;
+  char * grid ; 
+  char ddim[3][2][NAMELEN] ;
+  char mdim[3][2][NAMELEN] ;
+  char pdim[3][2][NAMELEN] ;
+  char vname[NAMELEN], dexes[NAMELEN] ; char tag[NAMELEN] ; 
+  char tx[80], moredims[80], temp[80], r[10], *colon ;
+  char c, d ;
+
+  for ( p1 = node ;  p1 != NULL ; p1 = p1->next )
+  {
+
+    if ( p1->node_kind & FOURD )
+    {
+      if ( p1->members->next )
+        nest_mask = p1->members->next->nest_mask ;
+      else
+        continue ;
+    }
+    else
+    {
+      nest_mask = p1->nest_mask ;
+    }
+    p = p1 ;
+
+    if ( nest_mask & down_path )
+    {
+        if ( p->node_kind & FOURD ) {
+          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 ( 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 )
+        {
+          strcpy(moredims,"") ;
+          for ( d1 = 3 ; d1 < p->ndims ; d1++ ) {
+             sprintf(temp,"idim%d",d1-2) ;
+             strcat(moredims,",") ; strcat(moredims,temp) ;
+          }
+          strcat(moredims,",") ;
+          sprintf(vname,"%s%s(%s%sitrace)",p->name,tag,dexes,moredims) ;
+        }
+        else
+        {
+          sprintf(vname,"%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) ;
+           for ( d1 = p->ndims-1 ; d1 >= 3 ; d1-- ) {
+             strcpy(r,"") ;
+             range_of_dimension(r, tx, d1, p, "config_flags%" ) ;
+             colon = index( tx, ':' ) ; *colon = ',' ; 
+fprintf(fp,"DO idim%d = %s \n", d1-2, tx) ;
+           }
+        } else {
+/* note that in the case if dir != UNPACKIT and down_path == INTERP_UP the data
+   structure being used is intermediate_grid, not grid. However, intermediate_grid
+   and grid share the same id (see module_dm.F) so it will not make a difference. */
+#if 0
+fprintf(fp,"IF ( in_use_for_config(grid%%id,'%s%s') ) THEN ! okay for intermediate_grid too. see comment in gen_comms.c\n",p->name,tag) ; 
+#else
+fprintf(fp,"IF ( SIZE(%s%s%s) .GT. 1 ) THEN ! okay for intermediate_grid too. see comment in gen_comms.c\n",grid,p->name,tag) ; 
+#endif
+	}
+
+        if ( dir == UNPACKIT ) 
+        {
+          if ( down_path == INTERP_UP )
+	  {
+            char *sjl = "" ;
+            if ( !strcmp( p->interpu_fcn_name ,"nmm_vfeedback") ) sjl = "_v" ; /* KLUDGE FOR NCEP NESTING 20071217 */
+            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 ( cd_feedback_mask%s( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, %s, %s ) ) THEN\n",
+                 sjl ,
+                 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, vname ) ;
+            } else {
+fprintf(fp,"NEST_INFLUENCE(%s%s,xv(1))\n", grid, vname ) ;
+            }
+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, vname) ;
+            } else {
+fprintf(fp,"CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)\n%s%s = xv(1)\n", grid, vname) ;
+            }
+          }
+        }
+        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], vname, ddim[zdex][1], ddim[zdex][0] ) ;
+            } else {
+fprintf(fp,"xv(1)= intermediate_grid%%%s\nCALL rsl_lite_to_parent_msg(RWORDSIZE,xv)\n", vname) ;
+            }
+          }
+          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, vname, ddim[zdex][1], ddim[zdex][0] ) ;
+            } else {
+fprintf(fp,"xv(1)=%s%s\nCALL rsl_lite_to_child_msg(RWORDSIZE,xv)\n", grid, vname) ;
+            }
+          }
+        }
+        if ( p->node_kind & FOURD )
+	{
+           for ( d1 = p->ndims-1 ; d1 >= 3 ; d1-- ) {
+fprintf(fp,"ENDDO\n") ;
+           }
+fprintf(fp,"ENDDO\n") ;
+	}
+        else
+	{
+fprintf(fp,"ENDIF\n") ; /* in_use_for_config */
+	}
+    }
+  }
+
+  return(0) ;
+}
+
+/*****************/
+
+/* STOPPED HERE -- need to include the extra dimensions in the count */
+
+int
+count_fields ( node_t * node , int * d2 , int * d3 ,  char * fourd_names, int down_path )
+{
+  node_t * p ;
+  int zdex ;
+  char temp[80], r[10], tx[80], *colon ;
+  int d ;
+
+  strcpy(fourd_names,"") ;  /* only works if non-recursive, but that is ifdefd out below */
+/* count up the total number of levels from all fields */
+  for ( p = node ;  p != NULL ; p = p->next )
+  {
+    if ( p->node_kind == FOURD ) 
+    {
+#if 0
+      count_fields( p->members , d2 , d3 , down_path ) ;  /* RECURSE */
+#else
+      if ( strlen(fourd_names) > 0 ) strcat(fourd_names," & \n + ") ;
+      sprintf(temp,"((num_%s - PARAM_FIRST_SCALAR + 1)",p->name) ;
+      strcat(fourd_names,temp) ;
+      for ( d = 3 ; d < p->ndims ; d++ ) {
+        strcpy(r,"") ;
+        range_of_dimension(r,tx,d,p,"config_flags%") ;
+        colon = index(tx,':') ; *colon = '\0' ;
+        sprintf(temp," &\n  *((%s)-(%s)+1)",colon+1,tx) ;
+        strcat(fourd_names,temp) ;
+      }
+      strcat(fourd_names,")") ;
+#endif
+    }
+    else
+    {
+      if ( p->nest_mask & down_path )
+      {
+          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_debug (  char * dirname )
+{
+  int i ;
+  FILE * fp ;
+  node_t *p, *q, *dimd ;
+  char **direction ;
+  char *directions[] = { "x", "y", 0L } ;
+  char fname[NAMELEN], vname[NAMELEN] ;
+  char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
+  int zdex ;
+  node_t Shift ;
+int said_it = 0 ;
+int said_it2 = 0 ;
+
+    if ( dirname == NULL ) return(1) ;
+
+    if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/debuggal.inc",dirname) ; }
+    else                       { sprintf(fname,"debuggal.inc") ; }
+    if ((fp = fopen( fname , "w" )) == 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 )
+      {
+
+	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->node_kind & FOURD  )
+            {
+#if 0
+              node_t *member ;
+              zdex = get_index_for_coord( p , COORD_Z ) ;
+              if ( zdex >=1 && zdex <= 3 && strncmp(vname,"fdda",4)  )
+              {
+fprintf(fp, "  DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
+fprintf(fp, "   write(0,*) AAA_AAA,BBB_BBB, '%s ', itrace , %s ( IDEBUG,KDEBUG,JDEBUG,itrace)\n", vname, vname ) ;
+fprintf(fp, "  ENDDO\n" ) ;
+              }
+              else
+              {
+                fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
+              }
+#endif
+            }
+            else
+	    {
+	      if ( p->ndims == 3 ) {
+fprintf(fp, "   write(0,*) AAA_AAA,BBB_BBB, '%s ', grid%%%s ( IDEBUG,KDEBUG,JDEBUG)\n", vname, vname ) ;
+              } else if ( p->ndims == 2 ) {
+fprintf(fp, "   write(0,*) AAA_AAA,BBB_BBB, '%s ', grid%%%s ( IDEBUG,JDEBUG)\n", vname, vname ) ;
+              }
+            }
+	  }
+	}
+      }
+    }
+
+    close_the_file(fp) ;
+}
+
+/*****************/
+/*****************/
+
+int
+gen_comms ( char * dirname )
+{
+  FILE *fpsub ; 
+  if ( sw_dm_parallel )
+    fprintf(stderr,"ADVISORY: RSL_LITE version of gen_comms is linked in with registry program.\n") ;
+
+  /* truncate this file if it exists */
+  if ((fpsub = fopen( "inc/REGISTRY_COMM_NESTING_DM_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
+  if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
+  if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_0_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
+  if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_1_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
+  if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_2_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
+  if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_3_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
+
+  gen_halos( "inc" , NULL, Halos, 1 ) ;
+  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" ) ;
+#if 0
+  gen_debug( "inc" ) ;
+#endif
+
+  return(0) ;
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/makefile	(revision 17)
@@ -0,0 +1,53 @@
+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) -o $@ $(FFLAGS) -c f_pack.F90
+
+f_xpose.o:	        f_xpose.F90 f_pack.o
+			$(CPP) f_xpose.F90 > f_xpose.f
+			$(FC) -o $@ $(FFLAGS) -c f_xpose.f
+
+clean : 
+			/bin/rm -f *.f *.o *.mod *.obj *.i
+
+superclean : clean
+			/bin/rm -f *.a
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/module_dm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/module_dm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/module_dm.F	(revision 17)
@@ -0,0 +1,4478 @@
+!WRF:PACKAGE:RSL 
+!
+MODULE module_dm
+
+   USE module_machine
+   USE module_wrf_error
+   USE module_driver_constants
+!   USE module_comm_dm
+   IMPLICIT NONE
+
+#if ( NMM_CORE == 1 ) || defined( WRF_CHEM ) 
+   INTEGER, PARAMETER :: max_halo_width = 6
+#else
+   INTEGER, PARAMETER :: max_halo_width = 6 ! 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
+#if ( defined(PROMOTE_FLOAT) || ( RWORDSIZE == DWORDSIZE ) )
+     MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer
+#else
+     MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer, wrf_dm_maxval_doubleprecision
+#endif
+   END INTERFACE
+
+   INTERFACE wrf_dm_minval                       ! gopal's doing
+#if ( defined(PROMOTE_FLOAT) || ( RWORDSIZE == DWORDSIZE ) )
+     MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer
+#else
+     MODULE PROCEDURE wrf_dm_minval_real , wrf_dm_minval_integer, wrf_dm_minval_doubleprecision
+#endif
+   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 compute_mesh( ntasks , ntasks_x, ntasks_y )
+     IMPLICIT NONE
+     INTEGER, INTENT(IN)  :: ntasks
+     INTEGER, INTENT(OUT) :: ntasks_x, ntasks_y
+     CALL nl_get_nproc_x ( 1, ntasks_x )
+     CALL nl_get_nproc_y ( 1, ntasks_y )
+! 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
+   END SUBROUTINE compute_mesh
+
+   SUBROUTINE wrf_dm_initialize
+      IMPLICIT NONE
+#ifndef STUBMPI
+      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_reorder_mesh( 1, reorder_mesh )
+      CALL compute_mesh( ntasks, ntasks_x, ntasks_y )
+      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
+        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 )
+#else
+      ntasks = 1
+      ntasks_x = 1
+      ntasks_y = 1
+      mytask = 0
+      mytask_x = 0
+      mytask_y = 0
+#endif
+
+      RETURN
+   END SUBROUTINE wrf_dm_initialize
+
+   SUBROUTINE get_dm_max_halo_width( id, width )
+     IMPLICIT NONE
+     INTEGER, INTENT(IN) :: id
+     INTEGER, INTENT(OUT) :: width
+     IF ( id .EQ. 1 ) THEN   ! this is coarse domain
+       width = max_halo_width
+     ELSE
+       width = max_halo_width + 3
+     ENDIF
+     RETURN
+   END SUBROUTINE get_dm_max_halo_width
+
+   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, ONLY : domain, head_grid, find_grid_by_id
+
+      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, ierr
+      INTEGER               :: max_dom
+
+      TYPE(domain), POINTER :: intermediate_grid
+      TYPE(domain), POINTER  :: nest_grid
+      CHARACTER*256   :: mess
+
+      INTEGER parent_max_halo_width
+      INTEGER thisdomain_max_halo_width
+
+      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 nl_get_max_dom( 1 , max_dom )
+
+      CALL get_dm_max_halo_width( id , thisdomain_max_halo_width )
+      IF ( id .GT. 1 ) THEN
+        CALL get_dm_max_halo_width( parent%id , parent_max_halo_width )
+      ENDIF
+
+      CALL compute_memory_dims_rsl_lite ( id, thisdomain_max_halo_width, 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:
+
+         c_ips = -1
+         nj = ( c_jds - j_parent_start ) * parent_grid_ratio + 1 + 1 ;
+         ierr = 0 
+         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, &
+                                  1, 1,  ierr )
+            IF ( Px .EQ. mytask_x ) THEN
+               c_ipe = i
+               IF ( c_ips .EQ. -1 ) c_ips = i
+            ENDIF
+         ENDDO
+         IF ( ierr .NE. 0 ) THEN
+            CALL tfp_message(__FILE__,__LINE__)
+         ENDIF
+         IF (c_ips .EQ. -1 ) THEN
+            c_ipe = -1
+            c_ips = 0
+         ENDIF
+
+         c_jps = -1
+         ni = ( c_ids - i_parent_start ) * parent_grid_ratio + 1 + 1 ;
+         ierr = 0 
+         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, &
+                                  1, 1, ierr )
+
+
+            IF ( Py .EQ. mytask_y ) THEN
+               c_jpe = j
+               IF ( c_jps .EQ. -1 ) c_jps = j
+            ENDIF
+         ENDDO
+         IF ( ierr .NE. 0 ) THEN
+            CALL tfp_message(__FILE__,__LINE__)
+         ENDIF
+         IF (c_jps .EQ. -1 ) THEN
+            c_jpe = -1
+            c_jps = 0
+         ENDIF
+
+         IF ( c_ips <= c_ipe ) THEN
+! 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,thisdomain_max_halo_width), c_ids - bdx ) - 1
+           c_ime = min( c_ipe + max(shw,thisdomain_max_halo_width), c_ide + bdx ) + 1
+         ELSE
+           c_ims = 0
+           c_ime = 0
+         ENDIF
+
+
+! handle j dims
+         IF ( c_jps <= c_jpe ) THEN
+! 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,thisdomain_max_halo_width), c_jds - bdx ) - 1
+           c_jme = min( c_jpe + max(shw,thisdomain_max_halo_width), c_jde + bdx ) + 1
+! handle k dims
+         ELSE
+           c_jms = 0
+           c_jme = 0
+         ENDIF
+         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 ) )
+         intermediate_grid%allocated=.false.
+         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   ! these must be the same. Other parts of code depend on it (see gen_comms.c)
+         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
+
+         intermediate_grid%is_intermediate = .TRUE.
+         SELECT CASE ( model_data_order )
+            CASE ( DATA_ORDER_ZXY )
+               intermediate_grid%nids = nest_grid%sd32 ; intermediate_grid%njds = nest_grid%sd33
+               intermediate_grid%nide = nest_grid%ed32 ; intermediate_grid%njde = nest_grid%sd33
+            CASE ( DATA_ORDER_ZYX )
+               intermediate_grid%nids = nest_grid%sd33 ; intermediate_grid%njds = nest_grid%sd32
+               intermediate_grid%nide = nest_grid%ed33 ; intermediate_grid%njde = nest_grid%sd32
+            CASE ( DATA_ORDER_XYZ )
+               intermediate_grid%nids = nest_grid%sd31 ; intermediate_grid%njds = nest_grid%sd32
+               intermediate_grid%nide = nest_grid%ed31 ; intermediate_grid%njde = nest_grid%sd32
+            CASE ( DATA_ORDER_YXZ)
+               intermediate_grid%nids = nest_grid%sd32 ; intermediate_grid%njds = nest_grid%sd31
+               intermediate_grid%nide = nest_grid%ed32 ; intermediate_grid%njde = nest_grid%sd31
+            CASE ( DATA_ORDER_XZY )
+               intermediate_grid%nids = nest_grid%sd31 ; intermediate_grid%njds = nest_grid%sd33
+               intermediate_grid%nide = nest_grid%ed31 ; intermediate_grid%njde = nest_grid%sd33
+            CASE ( DATA_ORDER_YZX )
+               intermediate_grid%nids = nest_grid%sd33 ; intermediate_grid%njds = nest_grid%sd31
+               intermediate_grid%nide = nest_grid%ed33 ; intermediate_grid%njde = nest_grid%sd31
+         END SELECT
+         intermediate_grid%nids = ids
+         intermediate_grid%nide = ide
+         intermediate_grid%njds = jds
+         intermediate_grid%njde = jde
+
+         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
+
+#if defined(SGIALTIX) && (! defined(MOVE_NESTS) )
+         ! 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, &
+                               c_sm1y, c_em1y, c_sm2y, c_em2y, c_sm3y, c_em3y, &
+                               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  (      &
+                   id , maxhalowidth ,            &
+                   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 )
+
+    IMPLICIT NONE
+    INTEGER, INTENT(IN)               ::  id , maxhalowidth
+    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, ierr
+
+#if ( ! NMM_CORE == 1 )
+
+! xy decomposition
+
+    ips = -1
+    j = jds
+    ierr = 0
+    DO i = ids, ide
+       CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
+                             1, 1, ierr )
+       IF ( Px .EQ. mytask_x ) THEN
+          ipe = i
+          IF ( ips .EQ. -1 ) ips = i
+       ENDIF
+    ENDDO
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF
+    ! handle setting the memory dimensions where there are no X elements assigned to this proc
+    IF (ips .EQ. -1 ) THEN
+       ipe = -1
+       ips = 0
+    ENDIF
+    jps = -1
+    i = ids
+    ierr = 0
+    DO j = jds, jde
+       CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
+                             1, 1, ierr )
+       IF ( Py .EQ. mytask_y ) THEN
+          jpe = j
+          IF ( jps .EQ. -1 ) jps = j
+       ENDIF
+    ENDDO
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF
+    ! handle setting the memory dimensions where there are no Y elements assigned to this proc
+    IF (jps .EQ. -1 ) THEN
+       jpe = -1
+       jps = 0
+    ENDIF
+
+!begin: wig; 12-Mar-2008
+! This appears redundant with the conditionals above, but we get cases with only
+! one of the directions being set to "missing" when turning off extra processors.
+! This may break the handling of setting only one of nproc_x or nproc_y via the namelist.
+    IF (ipe .EQ. -1 .or. jpe .EQ. -1) THEN
+       ipe = -1
+       ips = 0
+       jpe = -1
+       jps = 0
+    ENDIF
+!end: wig; 12-Mar-2008
+
+! 
+! 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 ;
+    ierr = 0
+    DO k = kds, kde
+       CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, &
+                             1, 1, ierr )
+       IF ( Px .EQ. mytask_x ) THEN
+          kpex = k
+          IF ( kpsx .EQ. -1 ) kpsx = k
+       ENDIF
+    ENDDO
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF 
+    
+! handle case where no levels are assigned to this process
+! no iterations.  Do same for I and J. Need to handle memory alloc below.
+    IF (kpsx .EQ. -1 ) THEN
+       kpex = -1
+       kpsx = 0
+    ENDIF
+
+    jpsx = -1
+    k = kds ;
+    ierr = 0
+    DO j = jds, jde
+       CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, &
+                             1, 1, ierr )
+       IF ( Py .EQ. mytask_y ) THEN
+          jpex = j
+          IF ( jpsx .EQ. -1 ) jpsx = j
+       ENDIF
+    ENDDO
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF 
+    IF (jpsx .EQ. -1 ) THEN
+       jpex = -1
+       jpsx = 0
+    ENDIF
+
+!begin: wig; 12-Mar-2008
+! This appears redundant with the conditionals above, but we get cases with only
+! one of the directions being set to "missing" when turning off extra processors.
+! This may break the handling of setting only one of nproc_x or nproc_y via the namelist.
+    IF (ipex .EQ. -1 .or. jpex .EQ. -1) THEN
+       ipex = -1
+       ipsx = 0
+       jpex = -1
+       jpsx = 0
+    ENDIF
+!end: wig; 12-Mar-2008
+
+! 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 ;
+    ierr = 0
+    DO i = ids, ide
+       CALL task_for_point ( i, k, ids, ide, kds, kde, ntasks_y, ntasks_x, Py, Px, &
+                             1, 1, ierr ) ! x and y for proc mesh reversed
+       IF ( Py .EQ. mytask_y ) THEN
+          ipey = i
+          IF ( ipsy .EQ. -1 ) ipsy = i
+       ENDIF
+    ENDDO
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF 
+    IF (ipsy .EQ. -1 ) THEN
+       ipey = -1
+       ipsy = 0
+    ENDIF
+
+
+#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
+    ierr = 0
+    DO i = ids, ide-1
+       CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, &
+                             1, 1 , ierr )
+       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
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF 
+    jps = -1
+    i = ids ;
+    ierr = 0
+    DO j = jds, jde-1
+       CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, &
+                             1 , 1 , ierr )
+       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
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF 
+#endif
+
+! extend the patch dimensions out shw along edges of domain
+    IF ( ips < ipe .and. jps < jpe ) THEN           !wig; 11-Mar-2008
+       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
+    ENDIF                                           !wig; 11-Mar-2008
+
+    kps = 1
+    kpe = kde-kds+1
+
+    kms = 1
+    kme = kpe
+    kmsx = kpsx
+    kmex = kpex
+    kmsy = kpsy
+    kmey = kpey
+
+    ! handle setting the memory dimensions where there are no levels assigned to this proc
+    IF ( kpsx .EQ. 0 .AND. kpex .EQ. -1 ) THEN
+      kmsx = 0
+      kmex = 0
+    ENDIF
+    IF ( kpsy .EQ. 0 .AND. kpey .EQ. -1 ) THEN
+      kmsy = 0
+      kmey = 0
+    ENDIF
+
+    IF ( (jps .EQ. 0 .AND. jpe .EQ. -1) .OR. (ips .EQ. 0 .AND. ipe .EQ. -1) ) THEN
+      ims = 0
+      ime = 0
+    ELSE
+      ims = max( ips - max(shw,maxhalowidth), ids - bdx ) - 1
+      ime = min( ipe + max(shw,maxhalowidth), ide + bdx ) + 1
+    ENDIF
+    imsx = ids
+    imex = ide
+    ipsx = imsx
+    ipex = imex
+    ! handle setting the memory dimensions where there are no Y elements assigned to this proc
+    IF ( ipsy .EQ. 0 .AND. ipey .EQ. -1 ) THEN
+      imsy = 0
+      imey = 0
+    ELSE
+      imsy = ipsy
+      imey = ipey
+    ENDIF
+
+    IF ( (jps .EQ. 0 .AND. jpe .EQ. -1) .OR. (ips .EQ. 0 .AND. ipe .EQ. -1) ) THEN
+      jms = 0
+      jme = 0
+    ELSE
+      jms = max( jps - max(shw,maxhalowidth), jds - bdy ) - 1
+      jme = min( jpe + max(shw,maxhalowidth), jde + bdy ) + 1
+    ENDIF
+    jmsx = jpsx
+    jmex = jpex
+    jmsy = jds
+    jmey = jde
+    ! handle setting the memory dimensions where there are no X elements assigned to this proc
+    IF ( jpsx .EQ. 0 .AND. jpex .EQ. -1 ) THEN
+      jmsx = 0
+      jmex = 0
+    ELSE
+      jpsy = jmsy
+      jpey = jmey
+    ENDIF
+
+  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
+#ifndef STUBMPI
+      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
+#else
+      REAL inval
+      wrf_dm_max_real = inval
+#endif
+   END FUNCTION wrf_dm_max_real
+
+   REAL FUNCTION wrf_dm_min_real ( inval )
+      IMPLICIT NONE
+#ifndef STUBMPI
+      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
+#else
+      REAL inval
+      wrf_dm_min_real = inval
+#endif
+   END FUNCTION wrf_dm_min_real
+
+   SUBROUTINE wrf_dm_min_reals ( inval, retval, n )
+      IMPLICIT NONE
+      INTEGER n
+      REAL inval(*)
+      REAL retval(*)
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+      INTEGER ierr
+      CALL mpi_allreduce ( inval, retval , n, getrealmpitype(), MPI_MIN, local_communicator, ierr )
+#else
+      retval(1:n) = inval(1:n)
+#endif
+   END SUBROUTINE wrf_dm_min_reals
+
+   REAL FUNCTION wrf_dm_sum_real ( inval )
+      IMPLICIT NONE
+#ifndef STUBMPI
+      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
+#else
+      REAL inval
+      wrf_dm_sum_real = inval
+#endif
+   END FUNCTION wrf_dm_sum_real
+
+   SUBROUTINE wrf_dm_sum_reals (inval, retval)
+      IMPLICIT NONE
+      REAL, INTENT(IN)  :: inval(:)
+      REAL, INTENT(OUT) :: retval(:)
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+      INTEGER ierr
+      CALL mpi_allreduce ( inval, retval, SIZE(inval), getrealmpitype(), MPI_SUM, local_communicator, ierr )
+#else
+      retval = inval
+#endif
+   END SUBROUTINE wrf_dm_sum_reals
+
+   INTEGER FUNCTION wrf_dm_sum_integer ( inval )
+      IMPLICIT NONE
+#ifndef STUBMPI
+      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
+#else
+      INTEGER inval
+      wrf_dm_sum_integer = inval
+#endif
+   END FUNCTION wrf_dm_sum_integer
+
+   INTEGER FUNCTION wrf_dm_bxor_integer ( inval )
+      IMPLICIT NONE
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+      INTEGER inval, retval
+      INTEGER ierr
+      CALL mpi_allreduce ( inval, retval , 1, MPI_INTEGER, MPI_BXOR, local_communicator, ierr )
+      wrf_dm_bxor_integer = retval
+#else
+      INTEGER inval
+      wrf_dm_bxor_integer = inval
+#endif
+   END FUNCTION wrf_dm_bxor_integer
+
+   SUBROUTINE wrf_dm_maxval_real ( val, idex, jdex )
+      IMPLICIT NONE
+#ifndef STUBMPI
+      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
+#else
+      REAL val
+      INTEGER idex, jdex, ierr
+#endif
+   END SUBROUTINE wrf_dm_maxval_real
+
+#ifndef PROMOTE_FLOAT
+   SUBROUTINE wrf_dm_maxval_doubleprecision ( val, idex, jdex )
+      IMPLICIT NONE
+# ifndef STUBMPI
+      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
+# else
+      DOUBLE PRECISION val
+      INTEGER idex, jdex, ierr
+# endif
+   END SUBROUTINE wrf_dm_maxval_doubleprecision
+#endif
+
+   SUBROUTINE wrf_dm_maxval_integer ( val, idex, jdex )
+      IMPLICIT NONE
+#ifndef STUBMPI
+      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
+#else
+      INTEGER val
+      INTEGER idex, jdex
+#endif
+   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)
+! <DESCRIPTION>
+! 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.
+!
+! </DESCRIPTION>
+      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
+
+#ifndef PROMOTE_FLOAT
+   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)
+! <DESCRIPTION>
+! 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.
+!
+! </DESCRIPTION>
+      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
+#endif
+
+   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)
+! <DESCRIPTION>
+! 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.
+!
+! </DESCRIPTION>
+      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 split_communicator
+#ifndef STUBMPI
+      IMPLICIT NONE
+      INCLUDE 'mpif.h'
+      LOGICAL mpi_inited
+      INTEGER mpi_comm_here, mpi_comm_local, comdup,  mytask, ntasks, ierr, io_status
+#  if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT)
+      INTEGER thread_support_provided, thread_support_requested
+#endif
+      INTEGER i, j
+      INTEGER, ALLOCATABLE :: icolor(:)
+      INTEGER tasks_per_split
+      NAMELIST /namelist_split/ tasks_per_split
+
+      CALL MPI_INITIALIZED( mpi_inited, ierr )
+      IF ( .NOT. mpi_inited ) THEN
+#  if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT)
+        thread_support_requested = MPI_THREAD_FUNNELED
+        CALL mpi_init_thread ( thread_support_requested, thread_support_provided, ierr )
+        IF ( thread_support_provided .lt. thread_support_requested ) THEN
+           CALL WRF_ERROR_FATAL( "failed to initialize MPI thread support")
+        ENDIF
+#  else
+        CALL mpi_init ( ierr )
+#  endif
+        mpi_comm_here = MPI_COMM_WORLD
+#ifdef HWRF
+        CALL atm_cmp_start( mpi_comm_here )   ! atmospheric side of HWRF coupler will split MPI_COMM_WORLD and return communicator as argument
+#endif
+        CALL wrf_set_dm_communicator( mpi_comm_here )
+      ENDIF
+      CALL wrf_get_dm_communicator( mpi_comm_here )
+      CALL wrf_termio_dup( mpi_comm_here )
+
+      CALL MPI_Comm_rank ( mpi_comm_here, mytask, ierr ) ;
+      CALL mpi_comm_size ( mpi_comm_here, ntasks, ierr ) ;
+
+      IF ( mytask .EQ. 0 ) THEN
+        OPEN ( unit=27, file="namelist.input", form="formatted", status="old" )
+        tasks_per_split = ntasks
+        READ ( 27 , NML = namelist_split, IOSTAT=io_status )
+        CLOSE ( 27 )
+      ENDIF
+      CALL mpi_bcast( io_status, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr )
+      IF ( io_status .NE. 0 ) THEN
+          RETURN ! just ignore and return
+      ENDIF
+      CALL mpi_bcast( tasks_per_split, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr )
+      IF ( tasks_per_split .GT. ntasks .OR. tasks_per_split .LE. 0 ) RETURN
+      IF ( mod( ntasks, tasks_per_split ) .NE. 0 ) THEN
+        CALL wrf_message( 'WARNING: tasks_per_split does not evenly divide ntasks. Some tasks will be wasted.' )
+      ENDIF
+
+      ALLOCATE( icolor(ntasks) )
+      j = 0
+      DO WHILE ( j .LT. ntasks / tasks_per_split ) 
+        DO i = 1, tasks_per_split
+          icolor( i + j * tasks_per_split ) = j 
+        ENDDO
+        j = j + 1
+      ENDDO
+
+      CALL MPI_Comm_dup(mpi_comm_here,comdup,ierr)
+      CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_local,ierr)
+      CALL wrf_set_dm_communicator( mpi_comm_local )
+
+      DEALLOCATE( icolor )
+#endif
+   END SUBROUTINE split_communicator
+
+   SUBROUTINE init_module_dm
+#ifndef STUBMPI
+      IMPLICIT NONE
+      INTEGER mpi_comm_local, mpi_comm_here, 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. split_communicator) has already
+        ! initialized MPI, so just grab the communicator that
+        ! should already be stored and use that.
+        CALL mpi_init ( ierr )
+        mpi_comm_here = MPI_COMM_WORLD
+        CALL wrf_set_dm_communicator ( mpi_comm_here )
+      ENDIF
+      CALL wrf_get_dm_communicator( mpi_comm_local )
+      CALL wrf_termio_dup( mpi_comm_local )
+#endif
+   END SUBROUTINE init_module_dm
+
+! stub
+   SUBROUTINE wrf_dm_move_nest ( parent, nest, dx, dy )
+      USE module_domain, ONLY : 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. 
+!       
+!------------------------------------------------------------------------------
+        
+    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)
+
+#ifndef STUBMPI
+    INCLUDE 'mpif.h'
+        
+! 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
+    REAL PBL_BUFFER(NIOBF)    ! Buffer for holding (real) KPBL index
+    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
+       PBL_BUFFER(NLOCAL_CRS) = ERRF(5,N)     ! KPBL
+       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
+! KPBL
+   CALL MPI_ALLGATHERV( PBL_BUFFER, NLOCAL_CRS, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(5,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
+
+
+
+   SUBROUTINE wrf_dm_maxtile_real ( val , tile)
+      IMPLICIT NONE
+      REAL val, val_all( ntasks )
+      INTEGER tile
+      INTEGER ierr
+
+! <DESCRIPTION>
+! 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 tile number.
+!
+! </DESCRIPTION>
+      INTEGER i, comm
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+
+      CALL wrf_get_dm_communicator ( comm )
+      CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
+      val = val_all(1)
+      tile = 1
+      DO i = 2, ntasks
+        IF ( val_all(i) .GT. val ) THEN
+           tile = i
+           val = val_all(i)
+        ENDIF
+      ENDDO
+#endif
+   END SUBROUTINE wrf_dm_maxtile_real
+
+
+   SUBROUTINE wrf_dm_mintile_real ( val , tile)
+      IMPLICIT NONE
+      REAL val, val_all( ntasks )
+      INTEGER tile
+      INTEGER ierr
+
+! <DESCRIPTION>
+! 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 tile number.
+!
+! </DESCRIPTION>
+      INTEGER i, comm
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+
+      CALL wrf_get_dm_communicator ( comm )
+      CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
+      val = val_all(1)
+      tile = 1
+      DO i = 2, ntasks
+        IF ( val_all(i) .LT. val ) THEN
+           tile = i
+           val = val_all(i)
+        ENDIF
+      ENDDO
+#endif
+   END SUBROUTINE wrf_dm_mintile_real
+
+
+   SUBROUTINE wrf_dm_mintile_double ( val , tile)
+      IMPLICIT NONE
+      DOUBLE PRECISION val, val_all( ntasks )
+      INTEGER tile
+      INTEGER ierr
+
+! <DESCRIPTION>
+! 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 tile number.
+!
+! </DESCRIPTION>
+      INTEGER i, comm
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+
+      CALL wrf_get_dm_communicator ( comm )
+      CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
+      val = val_all(1)
+      tile = 1
+      DO i = 2, ntasks
+        IF ( val_all(i) .LT. val ) THEN
+           tile = i
+           val = val_all(i)
+        ENDIF
+      ENDDO
+#endif
+   END SUBROUTINE wrf_dm_mintile_double
+
+
+   SUBROUTINE wrf_dm_tile_val_int ( val , tile)
+      IMPLICIT NONE
+      INTEGER val, val_all( ntasks )
+      INTEGER tile
+      INTEGER ierr
+
+! <DESCRIPTION>
+! Collective operation. Get value from input tile.
+!
+! </DESCRIPTION>
+      INTEGER i, comm
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+
+      CALL wrf_get_dm_communicator ( comm )
+      CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
+      val = val_all(tile)
+#endif
+   END SUBROUTINE wrf_dm_tile_val_int
+
+   SUBROUTINE wrf_get_hostname  ( str )
+      CHARACTER*(*) str
+      CHARACTER tmp(512)
+      INTEGER i , n, cs
+      CALL rsl_lite_get_hostname( tmp, 512, n, cs )
+      DO i = 1, n 
+        str(i:i) = tmp(i)
+      ENDDO
+      RETURN
+   END SUBROUTINE wrf_get_hostname 
+
+   SUBROUTINE wrf_get_hostid  ( hostid )
+      INTEGER hostid
+      CHARACTER tmp(512)
+      INTEGER i, sz, n, cs
+      CALL rsl_lite_get_hostname( tmp, 512, n, cs )
+      hostid = cs
+      RETURN
+   END SUBROUTINE wrf_get_hostid
+
+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, ONLY : domain, head_grid, find_grid_by_id
+   USE module_dm, ONLY : patch_domain_rsl_lite
+   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( comm )
+  IMPLICIT NONE
+  INTEGER, INTENT(IN) :: comm
+  INTEGER mytask, ntasks
+#ifndef STUBMPI
+  INTEGER ierr
+  INCLUDE 'mpif.h'
+  CALL mpi_comm_size(comm, ntasks, ierr )
+  CALL mpi_comm_rank(comm, mytask, ierr )
+  write(0,*)'starting wrf task ',mytask,' of ',ntasks
+  CALL rsl_error_dup1( mytask )
+#else
+  mytask = 0
+  ntasks = 1
+#endif
+END SUBROUTINE wrf_termio_dup
+
+SUBROUTINE wrf_get_myproc( myproc )
+  USE module_dm , ONLY : mytask
+  IMPLICIT NONE
+  INTEGER myproc
+  myproc = mytask
+  RETURN
+END SUBROUTINE wrf_get_myproc
+
+SUBROUTINE wrf_get_nproc( nproc )
+  USE module_dm , ONLY : ntasks
+  IMPLICIT NONE
+  INTEGER nproc
+  nproc = ntasks
+  RETURN
+END SUBROUTINE wrf_get_nproc
+
+SUBROUTINE wrf_get_nprocx( nprocx )
+  USE module_dm , ONLY : ntasks_x
+  IMPLICIT NONE
+  INTEGER nprocx
+  nprocx = ntasks_x
+  RETURN
+END SUBROUTINE wrf_get_nprocx
+
+SUBROUTINE wrf_get_nprocy( nprocy )
+  USE module_dm , ONLY : ntasks_y
+  IMPLICIT NONE
+  INTEGER nprocy
+  nprocy = ntasks_y
+  RETURN
+END SUBROUTINE wrf_get_nprocy
+
+SUBROUTINE wrf_dm_bcast_bytes ( buf , size )
+   USE module_dm , ONLY : local_communicator
+   IMPLICIT NONE
+#ifndef STUBMPI
+   INCLUDE 'mpif.h'
+#endif
+   INTEGER size
+#ifndef NEC
+   INTEGER*1 BUF(size)
+#else
+   CHARACTER*1 BUF(size)
+#endif
+#ifndef STUBMPI
+   CALL BYTE_BCAST ( buf , size, local_communicator )
+#endif
+   RETURN
+END SUBROUTINE wrf_dm_bcast_bytes
+
+SUBROUTINE wrf_dm_bcast_string( BUF, N1 )
+   IMPLICIT NONE
+   INTEGER n1
+! <DESCRIPTION>
+! Collective operation. Given a string and a size in characters on task zero, broadcast and return that buffer on all tasks.
+!
+! </DESCRIPTION>
+   CHARACTER*(*) buf
+#ifndef STUBMPI
+   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
+#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, ONLY : 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
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+      INTEGER ierr
+      CALL mpi_abort(MPI_COMM_WORLD,1,ierr)
+#else
+      STOP
+#endif
+   END SUBROUTINE wrf_abort
+
+   SUBROUTINE wrf_dm_shutdown
+      IMPLICIT NONE
+#ifndef STUBMPI
+      INTEGER ierr
+      CALL MPI_FINALIZE( ierr )
+#endif
+      RETURN
+   END SUBROUTINE wrf_dm_shutdown
+
+   LOGICAL FUNCTION wrf_dm_on_monitor()
+      IMPLICIT NONE
+#ifndef STUBMPI
+      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
+#else
+      wrf_dm_on_monitor = .TRUE.
+#endif
+      RETURN
+   END FUNCTION wrf_dm_on_monitor
+
+   SUBROUTINE rsl_comm_iter_init(shw,ps,pe)
+      INTEGER shw, ps, pe
+      INTEGER iter, plus_send_start, plus_recv_start, &
+                    minus_send_start, minus_recv_start 
+      COMMON /rcii/ iter, plus_send_start, plus_recv_start, &
+                          minus_send_start, minus_recv_start
+      iter = 0 
+      minus_send_start = ps
+      minus_recv_start = ps-1
+      plus_send_start = pe
+      plus_recv_start = pe+1
+   END SUBROUTINE rsl_comm_iter_init
+
+   LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate,                     &
+                                    shw ,  xy , ds, de_in, ps, pe, nds,nde, & 
+                                    sendbeg_m, sendw_m, sendbeg_p, sendw_p,   &
+                                    recvbeg_m, recvw_m, recvbeg_p, recvw_p    )
+      USE module_dm, ONLY : ntasks_x, ntasks_y, mytask_x, mytask_y
+      IMPLICIT NONE
+      INTEGER, INTENT(IN)  :: id,shw,xy,ds,de_in,ps,pe,nds,nde
+      LOGICAL, INTENT(IN)  :: is_intermediate  ! treated differently, coarse but with same decomp as nest
+      INTEGER, INTENT(OUT) :: sendbeg_m, sendw_m, sendbeg_p, sendw_p
+      INTEGER, INTENT(OUT) :: recvbeg_m, recvw_m, recvbeg_p, recvw_p
+      INTEGER k, kn, ni, nj, de, Px, Py, nt, me, lb, ub, ierr 
+      LOGICAL went
+      INTEGER iter, plus_send_start, plus_recv_start, &
+                    minus_send_start, minus_recv_start 
+      INTEGER parent_grid_ratio, parent_start
+      COMMON /rcii/ iter, plus_send_start, plus_recv_start, &
+                          minus_send_start, minus_recv_start
+
+#if (NMM_CORE == 1 )
+! In case of NMM CORE, the domain only ever runs from ids..ide-1 and jds..jde-1 so
+! adjust decomposition to reflect.  20081206 JM
+      de = de_in - 1
+#else
+      de = de_in
+#endif
+
+      IF ( xy .EQ. 1 ) THEN  ! X/I axis
+        nt = ntasks_x 
+        me = mytask_x
+        IF ( is_intermediate ) THEN
+           CALL nl_get_i_parent_start(id,parent_start)
+           CALL nl_get_parent_grid_ratio(id,parent_grid_ratio)
+        ENDIF
+      ELSE
+        nt = ntasks_y
+        me = mytask_y
+        IF ( is_intermediate ) THEN
+           CALL nl_get_j_parent_start(id,parent_start)
+           CALL nl_get_parent_grid_ratio(id,parent_grid_ratio)
+        ENDIF
+      ENDIF
+      iter = iter + 1
+
+#if (DA_CORE == 0)
+      went = .FALSE.
+      ! send to minus 
+      sendw_m = 0 
+      sendbeg_m = 1
+      IF ( me .GT. 0 ) THEN
+        lb = minus_send_start
+        sendbeg_m = lb-ps+1
+        DO k = lb,ps+shw-1
+          went = .TRUE.
+          IF ( is_intermediate ) THEN
+            kn =  ( k - parent_start ) * parent_grid_ratio + 1 + 1 ;
+            CALL task_for_point (kn,1,nds,nde,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
+          ELSE
+            CALL task_for_point (k,1,ds,de,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
+          ENDIF
+          IF ( Px .NE. me+(iter-1) ) THEN
+            exit
+          ENDIF
+          minus_send_start = minus_send_start+1
+          sendw_m = sendw_m + 1
+        ENDDO
+      ENDIF
+      ! recv from minus 
+      recvw_m = 0 
+      recvbeg_m = 1
+      IF ( me .GT. 0 ) THEN
+        ub = minus_recv_start
+        recvbeg_m = ps - ub
+        DO k = minus_recv_start,ps-shw,-1
+          went = .TRUE.
+          IF ( is_intermediate ) THEN
+            kn =  ( k - parent_start ) * parent_grid_ratio + 1 + 1 ;
+            CALL task_for_point (kn,1,nds,nde,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
+          ELSE
+            CALL task_for_point (k,1,ds,de,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
+          ENDIF
+          IF ( Px .NE. me-iter ) THEN
+            exit
+          ENDIF
+          minus_recv_start = minus_recv_start-1
+          recvw_m = recvw_m + 1
+        ENDDO
+      ENDIF
+
+      ! send to plus
+      sendw_p = 0 
+      sendbeg_p = 1
+      IF ( me .LT. nt-1 ) THEN
+        ub = plus_send_start
+        sendbeg_p = pe - ub + 1 
+        DO k = ub,pe-shw+1,-1
+          went = .TRUE.
+          IF ( is_intermediate ) THEN
+            kn =  ( k - parent_start ) * parent_grid_ratio + 1 + 1 ;
+            CALL task_for_point (kn,1,nds,nde,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
+          ELSE
+            CALL task_for_point (k,1,ds,de,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
+          ENDIF
+          IF ( Px .NE. me-(iter-1) ) THEN
+            exit
+          ENDIF
+          plus_send_start = plus_send_start - 1
+          sendw_p = sendw_p + 1
+        ENDDO
+      ENDIF
+      ! recv from plus
+      recvw_p = 0 
+      recvbeg_p = 1
+      IF ( me .LT. nt-1 ) THEN
+        lb = plus_recv_start
+        recvbeg_p = lb - pe
+        DO k = lb,pe+shw
+          went = .TRUE.
+          IF ( is_intermediate ) THEN
+            kn =  ( k - parent_start ) * parent_grid_ratio + 1 + 1 ;
+            CALL task_for_point (kn,1,nds,nde,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
+          ELSE
+            CALL task_for_point (k,1,ds,de,1,1,nt,1,Px,Py,1,1,ierr) ! assume same alg. for x and y and just use x
+          ENDIF
+          IF ( Px .NE. me+iter ) THEN
+            exit
+          ENDIF
+          plus_recv_start = plus_recv_start + 1
+          recvw_p = recvw_p + 1
+        ENDDO
+      ENDIF
+#else
+      if ( iter .eq. 1 ) then
+        went = .true.
+      else 
+        went = .false.
+      endif
+      sendw_m = 0 ; sendw_p = 0 ; recvw_m = 0 ; recvw_p = 0 
+      sendbeg_m = 1 ; if ( me .GT. 0 ) sendw_m = shw ; 
+      sendbeg_p = 1 ; if ( me .LT. nt-1 ) sendw_p = shw 
+      recvbeg_m = 1 ; if ( me .GT. 0 ) recvw_m = shw ; 
+      recvbeg_p = 1 ; if ( me .LT. nt-1 ) recvw_p = shw ;
+
+      ! write(0,*)'shw  ', shw , ' xy ',xy
+      ! write(0,*)' ds, de, ps, pe, nds,nde ',ds, de, ps, pe, nds,nde
+      ! write(0,*)'sendbeg_m, sendw_m, sendbeg_p, sendw_p, recvbeg_m, recvw_m, recvbeg_p, recvw_p '
+      ! write(0,*)sendbeg_m, sendw_m, sendbeg_p, sendw_p, recvbeg_m, recvw_m, recvbeg_p, recvw_p
+#endif
+      !if ( went ) then
+      !  write(0,*)'shw  ', shw , ' xy ',xy
+      !  write(0,*)' ds, de, ps, pe, nds,nde ',ds, de, ps, pe, nds,nde
+      !  write(0,*)'sendbeg_m, sendw_m, sendbeg_p, sendw_p, recvbeg_m, recvw_m, recvbeg_p, recvw_p '
+      !  write(0,*)sendbeg_m, sendw_m, sendbeg_p, sendw_p, recvbeg_m, recvw_m, recvbeg_p, recvw_p
+      !endif
+      rsl_comm_iter = went
+   END FUNCTION rsl_comm_iter
+
+   INTEGER FUNCTION wrf_dm_monitor_rank()
+      IMPLICIT NONE
+      wrf_dm_monitor_rank = 0
+      RETURN
+   END FUNCTION wrf_dm_monitor_rank
+
+   SUBROUTINE wrf_get_dm_communicator ( communicator )
+      USE module_dm , ONLY : local_communicator
+      IMPLICIT NONE
+      INTEGER , INTENT(OUT) :: communicator
+      communicator = local_communicator
+      RETURN
+   END SUBROUTINE wrf_get_dm_communicator
+
+   SUBROUTINE wrf_get_dm_communicator_x ( communicator )
+      USE module_dm , ONLY : local_communicator_x
+      IMPLICIT NONE
+      INTEGER , INTENT(OUT) :: communicator
+      communicator = local_communicator_x
+      RETURN
+   END SUBROUTINE wrf_get_dm_communicator_x
+
+   SUBROUTINE wrf_get_dm_communicator_y ( communicator )
+      USE module_dm , ONLY : local_communicator_y
+      IMPLICIT NONE
+      INTEGER , INTENT(OUT) :: communicator
+      communicator = local_communicator_y
+      RETURN
+   END SUBROUTINE wrf_get_dm_communicator_y
+
+   SUBROUTINE wrf_get_dm_iocommunicator ( iocommunicator )
+      USE module_dm , ONLY : local_iocommunicator
+      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 , ONLY : local_communicator
+      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 , ONLY : local_iocommunicator
+      IMPLICIT NONE
+      INTEGER , INTENT(IN) :: iocommunicator
+      local_iocommunicator = iocommunicator
+      RETURN
+   END SUBROUTINE wrf_set_dm_iocommunicator
+
+   SUBROUTINE wrf_get_dm_ntasks_x ( retval )
+      USE module_dm , ONLY : ntasks_x
+      IMPLICIT NONE
+      INTEGER , INTENT(OUT) :: retval
+      retval = ntasks_x
+      RETURN
+   END SUBROUTINE wrf_get_dm_ntasks_x
+
+   SUBROUTINE wrf_get_dm_ntasks_y ( retval )
+      USE module_dm , ONLY : ntasks_y
+      IMPLICIT NONE
+      INTEGER , INTENT(OUT) :: retval
+      retval = ntasks_y
+      RETURN
+   END SUBROUTINE wrf_get_dm_ntasks_y
+
+
+!!!!!!!!!!!!!!!!!!!!!!! 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, ONLY : wrf_at_debug_level
+       USE module_dm, ONLY : local_communicator, ntasks
+
+       IMPLICIT NONE
+       INTEGER                         DS1a,DE1a,DS2a,DE2a,DS3a,DE3a,&
+                                       MS1a,ME1a,MS2a,ME2a,MS3a,ME3a,&
+                                       PS1a,PE1a,PS2a,PE2a,PS3a,PE3A 
+       CHARACTER *(*) stagger,ordering
+       INTEGER domdesc,typesize,ierr
+       REAL globbuf(*)
+       REAL buf(*)
+#ifndef STUBMPI
+       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
+       LOGICAL, EXTERNAL :: wrf_dm_on_monitor, has_char
+
+       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 )
+#endif
+       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   )
+    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   )
+    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   )
+    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   )
+    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, ONLY : ntasks
+    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, ONLY : ntasks
+    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, ONLY : ntasks
+    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, ONLY : ntasks
+    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, ONLY : local_communicator, ntasks
+       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 
+       CHARACTER *(*) stagger,ordering
+       INTEGER domdesc,typesize,ierr
+       REAL globbuf(*)
+       REAL buf(*)
+#ifndef STUBMPI
+       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+                                       PS1,PE1,PS2,PE2,PS3,PE3
+       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 )
+#endif
+       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   )
+    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   )
+    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   )
+    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   )
+    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, ONLY : ntasks
+    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, ONLY : ntasks
+    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, ONLY : ntasks
+    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, ONLY : ntasks
+    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 && DA_CORE != 1 )
+
+!------------------------------------------------------------------
+
+   SUBROUTINE force_domain_em_part2 ( grid, ngrid, config_flags    &
+!
+#include "dummy_new_args.inc"
+!
+                 )
+      USE module_state_description
+      USE module_domain, ONLY : domain, get_ijk_from_grid
+      USE module_configure, ONLY : grid_config_rec_type
+      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, local_communicator, mytask
+      USE module_comm_nesting_dm, ONLY : halo_force_down_sub
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include <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
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7,itrace
+      REAL  dummy_xs, dummy_xe, dummy_ys, dummy_ye
+
+      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 "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_FORCE_DOWN.inc"
+
+      ! code here to interpolate the data into the nested domain
+#  include "nest_forcedown_interp.inc"
+
+      RETURN
+   END SUBROUTINE force_domain_em_part2
+
+!------------------------------------------------------------------
+
+   SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags    &
+!
+#include "dummy_new_args.inc"
+!
+                 )
+      USE module_state_description
+      USE module_domain, ONLY : domain, get_ijk_from_grid
+      USE module_configure, ONLY : grid_config_rec_type
+      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, &
+                            mytask, get_dm_max_halo_width
+      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 <dummy_new_decl.inc>
+      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 idim1,idim2,idim3,idim4,idim5,idim6,idim7
+
+      INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr 
+      INTEGER thisdomain_max_halo_width
+      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
+
+      ! get max_halo_width for parent. It may be smaller if it is moad
+      CALL get_dm_max_halo_width ( grid%id , thisdomain_max_halo_width )
+
+#include "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 "dummy_new_args.inc"
+!
+                 )
+      USE module_state_description
+      USE module_domain, ONLY : domain, get_ijk_from_grid
+      USE module_configure, ONLY : grid_config_rec_type
+      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, &
+                            mytask, get_dm_max_halo_width
+      USE module_comm_nesting_dm, ONLY : halo_interp_down_sub
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include <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
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+
+      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
+
+      INTEGER myproc
+      INTEGER ierr
+      INTEGER thisdomain_max_halo_width
+
+      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 
+
+      CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width )
+
+#include "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_INTERP_DOWN.inc"
+
+#  include "nest_interpdown_interp.inc"
+
+      RETURN
+   END SUBROUTINE interp_domain_em_part2
+
+!------------------------------------------------------------------
+
+   SUBROUTINE feedback_nest_prep ( grid, config_flags    &
+!
+#include "dummy_new_args.inc"
+!
+)
+      USE module_state_description
+      USE module_domain, ONLY : domain, get_ijk_from_grid
+      USE module_configure, ONLY : grid_config_rec_type
+      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask
+      USE module_comm_nesting_dm, ONLY : halo_interp_up_sub
+      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 <dummy_new_decl.inc>
+
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+
+      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
+
+      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_INTERP_UP.inc"
+#endif
+
+   END SUBROUTINE feedback_nest_prep
+
+!------------------------------------------------------------------
+
+   SUBROUTINE feedback_domain_em_part1 ( grid, ngrid, config_flags    &
+!
+#include "dummy_new_args.inc"
+!
+                 )
+      USE module_state_description
+      USE module_domain, ONLY : domain, get_ijk_from_grid
+      USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec
+      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
+                            ipe_save, jpe_save, ips_save, jps_save
+ 
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include <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
+
+      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
+
+      INTEGER local_comm, myproc, nproc, idum1, idum2
+      INTEGER thisdomain_max_halo_width
+
+      INTERFACE
+          SUBROUTINE feedback_nest_prep ( grid, config_flags    &
+!
+#include "dummy_new_args.inc"
+!
+)
+             USE module_state_description
+             USE module_domain, ONLY : domain
+             USE module_configure, ONLY : grid_config_rec_type
+!
+             TYPE (grid_config_rec_type)            :: config_flags
+             TYPE(domain), TARGET                   :: grid
+#include <dummy_new_decl.inc>
+          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 "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 "nest_feedbackup_interp.inc"
+
+      RETURN
+   END SUBROUTINE feedback_domain_em_part1
+
+!------------------------------------------------------------------
+
+   SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_flags    &
+!
+#include "dummy_new_args.inc"
+!
+                 )
+      USE module_state_description
+      USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid
+      USE module_configure, ONLY : grid_config_rec_type, model_config_rec
+      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
+                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
+      USE module_comm_nesting_dm, ONLY : halo_interp_up_sub
+      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 <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
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+
+      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
+
+      INTEGER icoord, jcoord, idim_cd, jdim_cd
+      INTEGER local_comm, myproc, nproc
+      INTEGER iparstrt, jparstrt, sw, thisdomain_max_halo_width
+      REAL    nest_influence
+
+      character*256 :: timestr
+      integer ierr
+
+      LOGICAL, EXTERNAL  :: 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
+
+      CALL get_dm_max_halo_width ( grid%id , thisdomain_max_halo_width )
+
+#include "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 "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_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 "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 "dummy_new_args.inc"
+!
+                 )
+      USE module_state_description
+      USE module_domain, ONLY : domain, get_ijk_from_grid
+      USE module_configure, ONLY : grid_config_rec_type
+      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
+                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
+      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 <dummy_new_decl.inc>
+      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 idim1,idim2,idim3,idim4,idim5,idim6,idim7
+
+      INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr
+      INTEGER local_comm, myproc, nproc
+      INTEGER thisdomain_max_halo_width
+
+      CALL wrf_get_dm_communicator ( local_comm )
+      CALL wrf_get_myproc( myproc )
+      CALL wrf_get_nproc( nproc )
+
+!#define COPY_IN
+!#include <scalar_derefs.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    )
+      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
+
+      CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width )
+#include "nest_interpdown_pack.inc"
+
+      CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm )
+
+!#define COPY_OUT
+!#include <scalar_derefs.inc>
+      RETURN
+   END SUBROUTINE interp_domain_nmm_part1
+
+!------------------------------------------------------------------
+
+   SUBROUTINE interp_domain_nmm_part2 ( grid, ngrid, config_flags    &
+!
+#include "dummy_new_args.inc"
+!
+                 )
+      USE module_state_description
+      USE module_domain, ONLY : domain, get_ijk_from_grid
+      USE module_configure, ONLY : grid_config_rec_type
+      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
+                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
+      USE module_comm_nesting_dm, ONLY : halo_interp_down_sub
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include <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
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+
+      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
+
+      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 <scalar_derefs.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    )
+      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 "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_INTERP_DOWN.inc"
+
+#include "nest_interpdown_interp.inc"
+
+!#define COPY_OUT
+!#include <scalar_derefs.inc>
+
+      RETURN
+   END SUBROUTINE interp_domain_nmm_part2
+
+!------------------------------------------------------------------
+
+   SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, config_flags    &
+!
+#include "dummy_new_args.inc"
+!
+                 )
+      USE module_state_description
+      USE module_domain, ONLY : domain, get_ijk_from_grid
+      USE module_configure, ONLY : grid_config_rec_type
+      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
+                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
+      USE module_timing
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: intermediate_grid
+#include <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
+
+      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
+
+!#define COPY_IN
+!#include <scalar_derefs.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    )
+
+      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 "nest_forcedown_pack.inc"
+
+!   WRITE(0,*)'I have completed PACKING of BCs data successfully'
+
+!#define COPY_OUT
+!#include <scalar_derefs.inc>
+      RETURN
+   END SUBROUTINE force_domain_nmm_part1
+
+!==============================================================================================
+
+   SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags    &
+!
+#include "dummy_new_args.inc"
+!
+                 )
+      USE module_state_description
+      USE module_domain, ONLY : domain, get_ijk_from_grid
+      USE module_configure, ONLY : grid_config_rec_type
+      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
+                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
+      USE module_comm_dm, ONLY : HALO_NMM_FORCE_DOWN1_sub
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include <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
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+
+      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
+      REAL  dummy_xs, dummy_xe, dummy_ys, dummy_ye
+
+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 <scalar_derefs.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    )
+      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 "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 "nest_forcedown_interp.inc"
+
+!#define COPY_OUT
+!#include <scalar_derefs.inc>
+
+      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 "dummy_new_args.inc"
+!
+)
+      USE module_state_description
+      USE module_domain, ONLY : domain, get_ijk_from_grid
+      USE module_configure, ONLY : grid_config_rec_type
+      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
+                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
+      USE module_comm_dm, ONLY : HALO_NMM_WEIGHTS_sub
+      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 <dummy_new_decl.inc>
+
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+
+      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
+
+      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 <scalar_derefs.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    )
+
+#ifdef DM_PARALLEL
+#include "HALO_NMM_WEIGHTS.inc"
+#endif
+
+!#define COPY_OUT
+!#include <scalar_derefs.inc>
+
+   END SUBROUTINE feedback_nest_prep_nmm
+
+!------------------------------------------------------------------
+
+   SUBROUTINE feedback_domain_nmm_part1 ( grid, ngrid, config_flags    &
+!
+#include "dummy_new_args.inc"
+!
+                 )
+      USE module_state_description
+      USE module_domain, ONLY : domain, get_ijk_from_grid
+      USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec
+      USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, &
+                            ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width
+      IMPLICIT NONE
+!
+      TYPE(domain), POINTER :: grid          ! name of the grid being dereferenced (must be "grid")
+      TYPE(domain), POINTER :: ngrid
+#include <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
+
+      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
+
+      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 "dummy_new_args.inc"
+!
+)
+             USE module_state_description
+             USE module_domain, ONLY : domain
+             USE module_configure, ONLY : grid_config_rec_type
+!
+             TYPE (grid_config_rec_type)            :: config_flags
+             TYPE(domain), TARGET                   :: grid
+#include <dummy_new_decl.inc>
+          END SUBROUTINE feedback_nest_prep_nmm
+      END INTERFACE
+!
+!#define COPY_IN
+!#include <scalar_derefs.inc>
+
+      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 "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 "nest_feedbackup_interp.inc"
+
+!#define COPY_OUT
+!#include <scalar_derefs.inc>
+      RETURN
+   END SUBROUTINE feedback_domain_nmm_part1
+
+!------------------------------------------------------------------
+
+   SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_flags    &
+!
+#include "dummy_new_args.inc"
+!
+                 )
+      USE module_state_description
+      USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid
+      USE module_configure, ONLY : grid_config_rec_type
+      USE module_dm, ONLY : get_dm_max_halo_width, ips_save, ipe_save, &
+                            jps_save, jpe_save, ntasks, mytask, ntasks_x, ntasks_y, &
+                            local_communicator, itrace
+      USE module_comm_nesting_dm, ONLY : halo_interp_up_sub
+      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 <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
+      INTEGER       ::          ids, ide, jds, jde, kds, kde,    &
+                                ims, ime, jms, jme, kms, kme,    &
+                                ips, ipe, jps, jpe, kps, kpe
+
+      INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7
+
+      INTEGER icoord, jcoord, idim_cd, jdim_cd
+      INTEGER local_comm, myproc, nproc
+      INTEGER iparstrt, jparstrt, sw
+      INTEGER thisdomain_max_halo_width
+
+      character*256 :: timestr
+      integer ierr
+
+      REAL    nest_influence
+      LOGICAL, EXTERNAL  :: cd_feedback_mask
+      LOGICAL, EXTERNAL  :: cd_feedback_mask_v
+
+!#define COPY_IN
+!#include <scalar_derefs.inc>
+
+! 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
+
+      CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width )
+#include "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 "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_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 "nest_feedbackup_smooth.inc"
+
+!#define COPY_OUT
+!#include <scalar_derefs.inc>
+      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, ONLY : getrealmpitype
+   IMPLICIT NONE
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+   REAL, DIMENSION(*) :: Field, globbuf
+#ifndef STUBMPI
+   INCLUDE 'mpif.h'
+
+           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 )
+#endif
+
+   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
+   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
+#ifndef STUBMPI
+   INCLUDE 'mpif.h'
+
+           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 )
+#endif
+
+   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
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+   INTEGER, DIMENSION(*) :: Field, globbuf
+#ifndef STUBMPI
+   INCLUDE 'mpif.h'
+
+           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 )
+#endif
+
+   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, ONLY : getrealmpitype
+   IMPLICIT NONE
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+   REAL, DIMENSION(*) :: Field, globbuf
+#ifndef STUBMPI
+   INCLUDE 'mpif.h'
+
+           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 )
+#endif
+
+   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 )
+   IMPLICIT NONE
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+   REAL, DIMENSION(*) :: Field, globbuf
+#ifndef STUBMPI
+   INCLUDE 'mpif.h'
+! 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
+
+           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 )
+#endif
+
+   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
+   INTEGER field_ofst, glob_ofst
+   INTEGER my_count, communicator, root, ierr
+   INTEGER , DIMENSION(*) :: counts, displs
+   INTEGER, DIMENSION(*) :: Field, globbuf
+#ifndef STUBMPI
+   INCLUDE 'mpif.h'
+
+           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 )
+#endif
+
+   END SUBROUTINE wrf_scatterv_integer
+! end new stuff 20070124
+
+     SUBROUTINE wrf_dm_gatherv ( v, elemsize , km_s, km_e, wordsz )
+      IMPLICIT NONE
+      INTEGER  elemsize, km_s, km_e, wordsz
+      REAL v(*)
+      IF ( wordsz .EQ. DWORDSIZE ) THEN
+         CALL wrf_dm_gatherv_double(v, elemsize , km_s, km_e)
+      ELSE
+         CALL wrf_dm_gatherv_single(v, elemsize , km_s, km_e)
+      ENDIF
+     END SUBROUTINE wrf_dm_gatherv
+
+     SUBROUTINE wrf_dm_gatherv_double ( v, elemsize , km_s, km_e )
+      IMPLICIT NONE
+      INTEGER  elemsize, km_s, km_e
+      REAL*8 v(0:*)
+#ifndef STUBMPI
+# ifndef USE_MPI_IN_PLACE
+      REAL*8 v_local((km_e-km_s+1)*elemsize)
+# endif
+      INTEGER, DIMENSION(:), ALLOCATABLE :: recvcounts, displs
+      INTEGER send_type, myproc, nproc, local_comm, ierr, i
+   INCLUDE 'mpif.h'
+      send_type = MPI_DOUBLE_PRECISION
+      CALL wrf_get_dm_communicator ( local_comm )
+      CALL wrf_get_nproc( nproc )
+      CALL wrf_get_myproc( myproc )
+      ALLOCATE( recvcounts(nproc), displs(nproc) )
+      i = (km_e-km_s+1)*elemsize
+      CALL mpi_allgather( i,1,MPI_INTEGER,recvcounts,1,MPI_INTEGER,local_comm,ierr) ;
+      i = (km_s)*elemsize
+      CALL mpi_allgather( i,1,MPI_INTEGER,displs,1,MPI_INTEGER,local_comm,ierr) ;
+#  ifdef USE_MPI_IN_PLACE
+      CALL mpi_allgatherv( MPI_IN_PLACE,                                  &
+#  else
+      DO i = 1,elemsize*(km_e-km_s+1)
+        v_local(i) = v(i+km_s-1)
+      ENDDO
+      CALL mpi_allgatherv( v_local,                                       &
+#  endif
+                           (km_e-km_s+1)*elemsize,                        &
+                           send_type,                                     &
+                           v,                                             &
+                           recvcounts,                                    &
+                           displs,                                        &
+                           send_type,                                     &
+                           local_comm,                                    &
+                           ierr )
+      DEALLOCATE(recvcounts)
+      DEALLOCATE(displs)
+#endif
+      return
+     END SUBROUTINE wrf_dm_gatherv_double
+
+     SUBROUTINE wrf_dm_gatherv_single ( v, elemsize , km_s, km_e )
+      IMPLICIT NONE
+      INTEGER  elemsize, km_s, km_e
+      REAL*4 v(0:*)
+#ifndef STUBMPI
+# ifndef USE_MPI_IN_PLACE
+      REAL*4 v_local((km_e-km_s+1)*elemsize)
+# endif
+      INTEGER, DIMENSION(:), ALLOCATABLE :: recvcounts, displs
+      INTEGER send_type, myproc, nproc, local_comm, ierr, i
+   INCLUDE 'mpif.h'
+      send_type = MPI_REAL
+      CALL wrf_get_dm_communicator ( local_comm )
+      CALL wrf_get_nproc( nproc )
+      CALL wrf_get_myproc( myproc )
+      ALLOCATE( recvcounts(nproc), displs(nproc) )
+      i = (km_e-km_s+1)*elemsize
+      CALL mpi_allgather( i,1,MPI_INTEGER,recvcounts,1,MPI_INTEGER,local_comm,ierr) ;
+      i = (km_s)*elemsize
+      CALL mpi_allgather( i,1,MPI_INTEGER,displs,1,MPI_INTEGER,local_comm,ierr) ;
+#  ifdef USE_MPI_IN_PLACE
+      CALL mpi_allgatherv( MPI_IN_PLACE,                                  &
+#  else
+      DO i = 1,elemsize*(km_e-km_s+1)
+        v_local(i) = v(i+km_s-1)
+      ENDDO
+      CALL mpi_allgatherv( v_local,                                       &
+#  endif
+                           (km_e-km_s+1)*elemsize,                        &
+                           send_type,                                     &
+                           v,                                             &
+                           recvcounts,                                    &
+                           displs,                                        &
+                           send_type,                                     &
+                           local_comm,                                    &
+                           ierr )
+      DEALLOCATE(recvcounts)
+      DEALLOCATE(displs)
+#endif
+      return
+     END SUBROUTINE wrf_dm_gatherv_single
+
+      SUBROUTINE wrf_dm_decomp1d( nt, km_s, km_e )
+       IMPLICIT NONE
+       INTEGER, INTENT(IN)  :: nt
+       INTEGER, INTENT(OUT) :: km_s, km_e
+     ! local
+       INTEGER nn, nnp,  na, nb
+       INTEGER myproc, nproc
+
+       CALL wrf_get_myproc(myproc)
+       CALL wrf_get_nproc(nproc)
+       nn = nt / nproc           ! min number done by this task
+       nnp = nn
+       if ( myproc .lt. mod( nt, nproc ) )   nnp = nnp + 1 ! distribute remainder
+
+       na = min( myproc, mod(nt,nproc) ) ! Number of blocks with remainder that precede this one
+       nb = max( 0, myproc - na )        ! number of blocks without a remainder that precede this one
+       km_s = na * ( nn+1) + nb * nn     ! starting iteration for this task
+       km_e = km_s + nnp - 1             ! ending iteration for this task
+      END SUBROUTINE wrf_dm_decomp1d
+
+
+SUBROUTINE wrf_dm_define_comms ( grid )
+   USE module_domain, ONLY : domain
+   IMPLICIT NONE
+   TYPE(domain) , INTENT (INOUT) :: grid
+   RETURN
+END SUBROUTINE wrf_dm_define_comms
+
+SUBROUTINE tfp_message( fname, lno )
+   CHARACTER*(*) fname
+   INTEGER lno
+   CHARACTER*1024 mess
+#ifndef STUBMPI
+   WRITE(mess,*)'tfp_message: ',trim(fname),lno
+   CALL wrf_message(mess)
+# ifdef ALLOW_OVERDECOMP
+     CALL task_for_point_message  ! defined in RSL_LITE/task_for_point.c
+# else
+     CALL wrf_error_fatal(mess)
+# endif
+#endif 
+END SUBROUTINE tfp_message
+
+   SUBROUTINE set_dm_debug 
+    USE module_dm, ONLY : dm_debug_flag
+    IMPLICIT NONE
+    dm_debug_flag = .TRUE.
+   END SUBROUTINE set_dm_debug
+   SUBROUTINE reset_dm_debug 
+    USE module_dm, ONLY : dm_debug_flag
+    IMPLICIT NONE
+    dm_debug_flag = .FALSE.
+   END SUBROUTINE reset_dm_debug
+   SUBROUTINE get_dm_debug ( arg )
+    USE module_dm, ONLY : dm_debug_flag
+    IMPLICIT NONE
+    LOGICAL arg
+    arg = dm_debug_flag
+   END SUBROUTINE get_dm_debug
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/period.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/period.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/period.c	(revision 17)
@@ -0,0 +1,462 @@
+#ifndef MS_SUA
+# include <stdio.h>
+#endif
+#include <fcntl.h>
+
+#define STANDARD_ERROR 2
+
+#define STANDARD_OUTPUT 1
+
+#ifndef STUBMPI
+# include "mpi.h"
+#endif
+#include "rsl_lite.h"
+
+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 )
+{
+#ifndef STUBMPI
+  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 ;
+#endif
+}
+
+
+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 )
+{
+#ifndef STUBMPI
+  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)<ide)?(A):ide)
+#define JMAX(A) (((A)>jds)?(A):jds)
+#define JMIN(A) (((A)<jde)?(A):jde)
+#else
+/* allow the extent in other dimension to go into boundary region (e.g. < ids or > 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 ) {
+#ifndef MS_SUA
+	  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 ) ;
+#endif
+	  MPI_Abort(MPI_COMM_WORLD, 98) ;
+        }
+        if ( typesize == 8 ) {
+          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 == 4 ) {
+          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 {
+#ifndef MS_SUA
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+	}
+      } else {
+        js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+        ks = kps           ; ke = kpe ;
+        is = ipe           ; ie = ipe+shw-1+stag ;
+        if ( typesize == 8 ) {
+          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 == 4 ) {
+          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 {
+#ifndef MS_SUA
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+        }
+      }
+    }
+    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 ) {
+#ifndef MS_SUA
+	  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 ) ;
+#endif
+	  MPI_Abort(MPI_COMM_WORLD, 98) ;
+        }
+        if ( typesize == 8 ) {
+          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 == 4 ) {
+          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 {
+#ifndef MS_SUA
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+        }
+      } else {
+        js = JMAX(jps-shw) ; je = JMIN(jpe+shw) ;
+        ks = kps           ; ke = kpe ;
+        is = ips-shw       ; ie = ips-1           ;
+        if ( typesize == 8 ) {
+          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 == 4 ) {
+          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 {
+#ifndef MS_SUA
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+        }
+      }
+    }
+  }
+  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 ) {
+#ifndef MS_SUA
+	  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 ) ;
+#endif
+	  MPI_Abort(MPI_COMM_WORLD, 98) ;
+        }
+        if ( typesize == 8 ) {
+          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 == 4 ) {
+          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 {
+#ifndef MS_SUA
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+	}
+      } else {
+        is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
+        ks = kps           ; ke = kpe ;
+        js = jpe           ; je = jpe+shw-1+stag ;
+        if ( typesize == 8 ) {
+          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 == 4 ) {
+          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 {
+#ifndef MS_SUA
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+        }
+      }
+    }
+    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 ) {
+#ifndef MS_SUA
+	  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 ) ;
+#endif
+	  MPI_Abort(MPI_COMM_WORLD, 98) ;
+        }
+        if ( typesize == 8 ) {
+          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 == 4 ) {
+          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 {
+#ifndef MS_SUA
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+        }
+      } else {
+        is = IMAX(ips-shw) ; ie = IMIN(ipe+shw) ;
+        ks = kps           ; ke = kpe ;
+        js = jps-shw       ; je = jps-1           ;
+        if ( typesize == 8 ) {
+          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 == 4 ) {
+          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 {
+#ifndef MS_SUA
+          fprintf(stderr,"internal error: %s %d\n",__FILE__,__LINE__) ;
+#endif
+        }
+      }
+    }
+  }
+#endif
+}
+
+#ifndef STUBMPI
+static MPI_Request yp_recv, ym_recv, yp_send, ym_send ;
+static MPI_Request xp_recv, xm_recv, xp_send, xm_send ;
+#endif
+
+RSL_LITE_EXCH_PERIOD_X ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 )
+{
+#ifndef STUBMPI
+  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 
+# ifndef MS_SUA
+fprintf(stderr,"RSL_LITE_EXCH_PERIOD_X disabled\n") ;
+# endif
+#endif
+  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
+#endif
+}
+
+RSL_LITE_EXCH_PERIOD_Y ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 )
+{
+#ifndef STUBMPI
+  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
+# ifndef MS_SUA
+fprintf(stderr,"RSL_LITE_EXCH_PERIOD_Y disabled\n") ;
+# endif
+#endif
+  yp_curs = 0 ; ym_curs = 0 ; xp_curs = 0 ; xm_curs = 0 ;
+#endif
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/rsl_bcast.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/rsl_bcast.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/rsl_bcast.c	(revision 17)
@@ -0,0 +1,686 @@
+/* #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
+
+#ifndef MS_SUA
+# include <stdio.h>
+#endif
+#include <stdlib.h>
+#ifndef STUBMPI
+#  include "mpi.h"
+#endif
+#include "rsl_lite.h"
+
+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 */
+                         min_subdomain ,                 /* minimum width allowed for a subdomain in a dim ON PARENT */
+                         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 */
+    ,min_subdomain
+    ,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] ;
+  int ierr ;
+#ifndef STUBMPI
+  MPI_Comm *comm, dummy_comm ;
+
+  comm = &dummy_comm ;
+  *comm = MPI_Comm_f2c( *Fcomm ) ;
+#endif
+
+  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 ;
+    }
+    ierr = 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 ;
+
+#ifndef STUBMPI
+	   TASK_FOR_POINT ( &ni, &nj, nids_p, nide_p, njds_p, njde_p, &s_ntasks_x, &s_ntasks_y, &Px, &Py, 
+                            min_subdomain, min_subdomain, &ierr ) ;
+           coords[1] = Px ; coords[0] = Py ;
+           MPI_Cart_rank( *comm, coords, &P ) ;
+#else
+           P = 0 ;
+#endif
+	   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 */
+        }
+      }
+    }
+    if ( ierr != 0 ) {
+      fprintf(stderr,"rsl_to_child_info: ") ;
+      TASK_FOR_POINT_MESSAGE () ;
+    }
+    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 ;
+}
+
+/********************************************/
+
+/* 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 */
+                          min_subdomain ,
+                          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 */
+    ,min_subdomain
+    ,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] ;
+  int ierr ;
+#ifndef STUBMPI
+  MPI_Comm *comm, dummy_comm ;
+
+  comm = &dummy_comm ;
+  *comm = MPI_Comm_f2c( *Fcomm ) ;
+#endif
+
+  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 ;
+    }
+    ierr = 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 ) ) {
+#ifndef STUBMPI
+	  TASK_FOR_POINT ( &i, &j, cids_p, cide_p, cjds_p, cjde_p, &s_ntasks_x, &s_ntasks_y, &Px, &Py, 
+                           min_subdomain, min_subdomain, &ierr ) ;
+          coords[1] = Px ; coords[0] = Py ;
+          MPI_Cart_rank( *comm, coords, &P ) ;
+#else
+          P = 0 ;
+#endif
+	  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 */
+        }
+      }
+    }
+    if ( ierr != 0 ) {
+      fprintf(stderr,"rsl_to_parent_info: ") ;
+      TASK_FOR_POINT_MESSAGE () ;
+    }
+    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 ;
+  char mess[4096] ;
+
+  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, Fcomm )
+  int_p mytask_p, ntasks_p, Fcomm ;
+{
+#ifndef STUBMPI
+  MPI_Comm comm ;
+
+  comm = MPI_Comm_f2c( *Fcomm ) ;
+#else
+  int comm ;
+#endif
+  rsl_lite_allgather_msgs ( mytask_p, ntasks_p, comm ) ;
+}
+
+/* nest->parent */
+RSL_LITE_MERGE_MSGS ( mytask_p, ntasks_p, Fcomm )
+  int_p mytask_p, ntasks_p, Fcomm ;
+{
+#ifndef STUBMPI
+  MPI_Comm comm ;
+
+  comm = MPI_Comm_f2c( *Fcomm ) ;
+#else
+  int comm ;
+#endif
+  rsl_lite_allgather_msgs ( mytask_p, ntasks_p, comm ) ;
+}
+
+/* common code */
+rsl_lite_allgather_msgs ( mytask_p, ntasks_p, comm )
+  int_p mytask_p, ntasks_p ;
+#ifndef STUBMPI
+  MPI_Comm comm ;
+#else
+  int comm ;
+#endif
+{
+  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 ;
+
+#ifndef STUBMPI
+  ntasks = *ntasks_p ;
+  mytask = *mytask_p ;
+#else
+  ntasks = 1 ;
+  mytask = 0 ;
+#endif
+
+  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 ) ;
+
+#ifndef STUBMPI
+  MPI_Allgather( Ssizes, ntasks, MPI_INT , Psize_all, ntasks, MPI_INT, comm ) ;
+#else
+  Psize_all[0] = Ssizes[0] ;
+#endif
+
+  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 ;
+
+#ifndef STUBMPI
+  rc = MPI_Alltoallv ( Sendbuf, Ssizes, Sdisplacements, MPI_BYTE , 
+                       Recvbuf, Rsizes, Rdisplacements, MPI_BYTE ,  comm ) ;
+#else
+  work = Sendbuf ;
+  Sendbuf = Recvbuf ;
+  Recvbuf = work ;
+#endif
+
+/* 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 ) ;
+  }
+     
+  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) ;
+}
+
+/********************************************/
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/rsl_lite.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/rsl_lite.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/rsl_lite.h	(revision 17)
@@ -0,0 +1,168 @@
+#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 TASK_FOR_POINT_MESSAGE task_for_point_message
+#      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
+#      define RSL_LITE_GET_HOSTNAME rsl_lite_get_hostname
+# 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 TASK_FOR_POINT_MESSAGE task_for_point_message__
+#      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__
+#      define RSL_LITE_GET_HOSTNAME rsl_lite_get_hostname__
+#   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 TASK_FOR_POINT_MESSAGE task_for_point_message_
+#      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_
+#      define RSL_LITE_GET_HOSTNAME rsl_lite_get_hostname_
+#   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) )
+
+#ifndef STUBMPI
+# define RSL_FATAL(N)     MPI_Abort(MPI_COMM_WORLD, 9)
+#else
+# define RSL_FATAL(N)     exit(9) ;
+#endif
+#ifndef MS_SUA
+# define RSL_TEST_ERR(T,M) {if(T){fprintf(stderr,"rsl_lite error (\"%s\":%d) %s\n",__FILE__,__LINE__,M);RSL_FATAL(5);}}
+#else
+# define RSL_TEST_ERR(T,M) {if(T){RSL_FATAL(5);}}
+#endif
+
+#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 ;
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/rsl_malloc.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/rsl_malloc.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/rsl_malloc.c	(revision 17)
@@ -0,0 +1,277 @@
+/***********************************************************************
+     
+                              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
+
+#ifdef _WIN32
+#define bzero(X,Y) memset(X,0,Y)
+#endif
+
+#ifndef MS_SUA
+# include <stdio.h>
+#endif
+#include <stdlib.h>
+#ifndef MACOS
+# include <malloc.h>
+#else
+# include <malloc/malloc.h>
+#endif
+#ifdef T3D
+#include <errno.h>
+#endif
+#ifndef STUBMPI
+# include "mpi.h"
+#endif
+#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) || defined(crayx1) || defined(MACOS) || defined(MS_SUA) )
+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) || defined(crayx1) || defined(MACOS) || defined(MS_SUA) || defined(_WIN32)) 
+       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") ;
+#if !defined (MS_SUA) && !defined(_WIN32)
+	 sleep(1) ;
+#endif
+       }
+       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{
+#ifndef MS_SUA
+fprintf(stderr,"stug full %d\n",bbb) ;
+#endif
+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 ;
+}
+
+#ifdef MS_SUA
+bzero( char *buf, int l )
+{
+   int i ;
+   char * p ;
+   for ( p = buf, i=0 ; i < l ; i++ ) *p = '\0' ;
+}
+#endif
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/swap.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/swap.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/swap.c	(revision 17)
@@ -0,0 +1,347 @@
+#ifndef MS_SUA
+# include <stdio.h>
+#endif
+#include <fcntl.h>
+
+#define STANDARD_ERROR 2
+
+#define STANDARD_OUTPUT 1
+
+#ifndef STUBMPI
+# include "mpi.h"
+#endif
+#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 ; 
+#ifndef STUBMPI
+static MPI_Request *x_recv = NULL , *x_send = NULL ;
+#endif
+
+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 * min_subdomain ,
+                int * ids0 , int * ide0 , int * jds0 , int * jde0 , int * kds0 , int * kde0 ,
+                int * ips0 , int * ipe0 , int * jps0 , int * jpe0 , int * kps0 , int * kpe0 )
+{
+#ifndef STUBMPI
+  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 ;
+  int ierr ;
+
+  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, 
+                       min_subdomain, min_subdomain, &ierr ) ;
+      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, 
+                       min_subdomain, min_subdomain, &ierr ) ;
+      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 ) ;
+     }
+  }
+#endif
+}
+
+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 * min_subdomain ,
+           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 )
+{
+#ifndef STUBMPI
+  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)<ide)?(A):ide)
+#define JMAX(A) (((A)>jds)?(A):jds)
+#define JMIN(A) (((A)<jde)?(A):jde)
+
+  da_buf = ( pu == 0 ) ? RSL_SENDBUF : RSL_RECVBUF ;
+
+
+  if ( xy == 1 ) {   /* xy = 1, swap in X, otherwise Y */
+    n = (ide-ids+1)/4*2 ;
+    m = n*2 ;
+  } else {
+    n = (jde-jds+1)/4*2 ;
+    m = n*2 ;
+  }
+
+  if ( np_x > 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, 
+                       min_subdomain, min_subdomain, &ierr ) ;
+      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, 
+                       min_subdomain, min_subdomain, &ierr ) ;
+      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]++ ;
+              }
+            }
+          }
+        }
+      }
+    }
+  }
+#endif
+}
+
+RSL_LITE_SWAP ( int * Fcomm0, int *me0, int * np0 , int * np_x0 , int * np_y0 )
+{
+#ifndef STUBMPI
+  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 
+# ifndef MS_SUA
+fprintf(stderr,"RSL_LITE_SWAP disabled\n") ;
+# endif
+#endif
+  for ( i = 0 ; i < np ; i++ ) {  x_curs[i] = 0 ;  }
+#endif
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/task_for_point.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/task_for_point.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/task_for_point.c	(revision 17)
@@ -0,0 +1,142 @@
+#ifndef MS_SUA
+# include <stdio.h>
+#endif
+#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
+*/
+
+static char tfpmess[1024] ;
+
+TASK_FOR_POINT ( i_p , j_p , ids_p, ide_p , jds_p, jde_p , npx_p , npy_p , Px_p, Py_p , minx_p, miny_p, ierr_p )
+  int_p i_p , j_p , Px_p , Py_p , ids_p, ide_p , jds_p, jde_p , npx_p , npy_p, minx_p, miny_p, ierr_p ;
+{
+  int i , j , ids, ide, jds, jde, npx, npy, minx, miny ;  /* 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 ;
+#if 0
+  minx = *minx_p ;
+  miny = *miny_p ;
+#else
+  minx = 1 ;
+  miny = 1 ;
+#endif
+  ids = *ids_p - 1 ; ide = *ide_p - 1 ;
+  jds = *jds_p - 1 ; jde = *jde_p - 1 ;
+  idim = ide - ids + 1 ;
+  jdim = jde - jds + 1 ;
+
+  *ierr_p = 0 ;
+
+  /* begin: jm for Peter Johnsen -- noticed problem with polar filters in gwrf
+     if the number of processors exceeds number of vertical levels */
+  if ( npx > idim ) { npx = idim ; }
+  if ( npy > jdim ) { npy = jdim ; }
+
+  /* begin: wig; 10-Mar-2008
+    Check that the number of processors is not so high that the halos begin to overlap.
+    If they do, then reduce the number of processors allowed for that dimension.
+  */
+  tfpmess[0] = '\0' ;
+  if ( idim / npx < minx ) {
+    npx = idim/minx ;
+    if (npx < 1) { npx = 1 ;}
+    if (npx != *npx_p) {
+      sprintf(tfpmess,"RSL_LITE: TASK_FOR_POINT LIMITING PROCESSOR COUNT IN X-DIRECTION TO %d %d\n", npx,*npx_p) ;
+      *ierr_p = 1 ;
+    }
+  }
+  if ( jdim / npy < miny ) {
+    npy = jdim/miny ;
+    if (npy < 1) { npy = 1 ;}
+    if (npy != *npy_p) {
+      sprintf(tfpmess,"RSL_LITE: TASK_FOR_POINT LIMITING PROCESSOR COUNT IN Y-DIRECTION TO %d %d\n", npy,*npy_p) ;
+      *ierr_p = 1 ;
+    }
+  }
+  /* end: wig */
+
+  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 ;
+}
+
+TASK_FOR_POINT_MESSAGE()
+{
+  fprintf(stderr,"%s\n",tfpmess) ;
+}
+
+#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 %3d)   ",Px,Py) ;
+#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
Index: branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/tfp_tester.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/tfp_tester.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/RSL_LITE/tfp_tester.F	(revision 17)
@@ -0,0 +1,649 @@
+! to compile this
+!
+! g95
+! gcc -c -DF2CSTYLE task_for_point.c ; g95 -ffree-form -ffree-line-length-huge tfp_tester.F task_for_point.o
+! ifort
+! icc -c task_for_point.c ; ifort -FR tfp_tester.F task_for_point.o
+! ibm
+! cc -c -DNOUNDERSCORE task_for_point.c ; xlf -qfree=f90 tfp_tester.F task_for_point.o
+
+MODULE module_driver_constants
+
+   !  0. The following tells the rest of the model what data ordering we are
+   !     using
+
+   INTEGER , PARAMETER :: DATA_ORDER_XYZ = 1
+   INTEGER , PARAMETER :: DATA_ORDER_YXZ = 2
+   INTEGER , PARAMETER :: DATA_ORDER_ZXY = 3
+   INTEGER , PARAMETER :: DATA_ORDER_ZYX = 4
+   INTEGER , PARAMETER :: DATA_ORDER_XZY = 5
+   INTEGER , PARAMETER :: DATA_ORDER_YZX = 6
+   INTEGER , PARAMETER :: DATA_ORDER_XY = DATA_ORDER_XYZ
+   INTEGER , PARAMETER :: DATA_ORDER_YX = DATA_ORDER_YXZ
+
+!#include <model_data_order.inc>
+
+   !  1. Following are constants for use in defining maximal values for array
+   !     definitions.  
+   !
+
+   !  The maximum number of levels in the model is how deeply the domains may
+   !  be nested.
+
+   INTEGER , PARAMETER :: max_levels      =  20
+
+   !  The maximum number of nests that can depend on a single parent and other way round
+
+   INTEGER , PARAMETER :: max_nests        =  20
+
+   !  The maximum number of parents that a nest can have (simplified assumption -> one only)
+
+   INTEGER , PARAMETER :: max_parents      =  1
+
+   !  The maximum number of domains is how many grids the model will be running.
+
+#define MAX_DOMAINS_F 10
+   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
+
+   !  The maximum number of outer iterations (for DA minimisation)
+
+   INTEGER , PARAMETER :: max_outer_iterations = 10
+
+   !  The maximum number of instruments (for radiance DA)
+
+   INTEGER , PARAMETER :: max_instruments =   30
+
+   !  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
+
+   !  4. Unfortunately, the following definition is needed here (rather
+   !     than the more logical place in share/module_model_constants.F)
+   !     for the namelist reads in frame/module_configure.F, and for some
+   !     conversions in share/set_timekeeping.F
+   !     Actually, using it here will mean that we don't need to set it
+   !     in share/module_model_constants.F, since this file will be
+   !     included (USEd) in:
+   !        frame/module_configure.F
+   !     which will be USEd in:
+   !        share/module_bc.F
+   !     which will be USEd in:
+   !        phys/module_radiation_driver.F
+   !     which is the other important place for it to be, and where
+   !     it is passed as a subroutine parameter to any physics subroutine.
+   !
+   !     P2SI is the number of SI seconds in an planetary solar day
+   !     divided by the number of SI seconds in an earth solar day
+#if defined MARS
+   !     For Mars, P2SI = 88775.2/86400.
+   REAL , PARAMETER :: P2SI = 1.0274907
+#elif defined TITAN
+   !     For Titan, P2SI = 1378080.0/86400.
+   REAL , PARAMETER :: P2SI = 15.95
+#else
+   !     Default for Earth
+   REAL , PARAMETER :: P2SI = 1.0
+#endif
+ CONTAINS
+   SUBROUTINE init_module_driver_constants
+   END SUBROUTINE init_module_driver_constants
+END MODULE module_driver_constants
+
+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      (p<bl) THEN
+     ret = 0
+   ELSE IF (p>maxi-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 compute_memory_dims_rsl_lite  (      &
+                   id , maxhalowidth ,            &
+                   shw , bdx,  bdy ,              &
+                   ntasks_x, ntasks_y, &
+                   mytask_x, mytask_y, &
+                   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)               ::  id , maxhalowidth
+    INTEGER, INTENT(IN)               ::  shw, bdx, bdy
+    INTEGER, INTENT(IN)               ::  ntasks_x, ntasks_y
+    INTEGER, INTENT(IN)               ::  mytask_x, mytask_y
+    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, ierr
+
+#if ( ! NMM_CORE == 1 )
+
+! xy decomposition
+
+    ips = -1
+    j = jds
+    ierr = 0
+    DO i = ids, ide
+       CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
+                             maxhalowidth, maxhalowidth, ierr )
+       IF ( Px .EQ. mytask_x ) THEN
+          ipe = i
+          IF ( ips .EQ. -1 ) THEN
+            ips = i
+          ENDIF
+       ENDIF
+    ENDDO
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF
+    ! handle setting the memory dimensions where there are no X elements assigned to this proc
+    IF (ips .EQ. -1 ) THEN
+       ipe = -1
+       ips = 0
+    ENDIF
+    jps = -1
+    i = ids
+    ierr = 0
+    DO j = jds, jde
+       CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, &
+                             maxhalowidth, maxhalowidth, ierr )
+       IF ( Py .EQ. mytask_y ) THEN
+          jpe = j
+          IF ( jps .EQ. -1 ) jps = j
+       ENDIF
+    ENDDO
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF
+    ! handle setting the memory dimensions where there are no Y elements assigned to this proc
+    IF (jps .EQ. -1 ) THEN
+       jpe = -1
+       jps = 0
+    ENDIF
+
+!begin: wig; 12-Mar-2008
+! This appears redundant with the conditionals above, but we get cases with only
+! one of the directions being set to "missing" when turning off extra processors.
+! This may break the handling of setting only one of nproc_x or nproc_y via the namelist.
+    IF (ipe .EQ. -1 .or. jpe .EQ. -1) THEN
+       ipe = -1
+       ips = 0
+       jpe = -1
+       jps = 0
+    ENDIF
+!end: wig; 12-Mar-2008
+
+! 
+! 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 ;
+    ierr = 0
+    DO k = kds, kde
+       CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, &
+                             1, maxhalowidth, ierr )
+       IF ( Px .EQ. mytask_x ) THEN
+          kpex = k
+          IF ( kpsx .EQ. -1 ) kpsx = k
+       ENDIF
+    ENDDO
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF 
+    
+! handle case where no levels are assigned to this process
+! no iterations.  Do same for I and J. Need to handle memory alloc below.
+    IF (kpsx .EQ. -1 ) THEN
+       kpex = -1
+       kpsx = 0
+    ENDIF
+
+    jpsx = -1
+    k = kds ;
+    ierr = 0
+    DO j = jds, jde
+       CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, &
+                             1, maxhalowidth, ierr )
+       IF ( Py .EQ. mytask_y ) THEN
+          jpex = j
+          IF ( jpsx .EQ. -1 ) jpsx = j
+       ENDIF
+    ENDDO
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF 
+    IF (jpsx .EQ. -1 ) THEN
+       jpex = -1
+       jpsx = 0
+    ENDIF
+
+!begin: wig; 12-Mar-2008
+! This appears redundant with the conditionals above, but we get cases with only
+! one of the directions being set to "missing" when turning off extra processors.
+! This may break the handling of setting only one of nproc_x or nproc_y via the namelist.
+    IF (ipex .EQ. -1 .or. jpex .EQ. -1) THEN
+       ipex = -1
+       ipsx = 0
+       jpex = -1
+       jpsx = 0
+    ENDIF
+!end: wig; 12-Mar-2008
+
+! 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 ;
+    ierr = 0
+    DO i = ids, ide
+       CALL task_for_point ( i, k, ids, ide, kds, kde, ntasks_y, ntasks_x, Py, Px, &
+                             maxhalowidth, 1, ierr ) ! x and y for proc mesh reversed
+       IF ( Py .EQ. mytask_y ) THEN
+          ipey = i
+          IF ( ipsy .EQ. -1 ) ipsy = i
+       ENDIF
+    ENDDO
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF 
+    IF (ipsy .EQ. -1 ) THEN
+       ipey = -1
+       ipsy = 0
+    ENDIF
+
+
+#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
+    ierr = 0
+    DO i = ids, ide-1
+       CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, &
+                             maxhalowidth, maxhalowidth , ierr )
+       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
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF 
+    jps = -1
+    i = ids ;
+    ierr = 0
+    DO j = jds, jde-1
+       CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, &
+                             maxhalowidth , maxhalowidth , ierr )
+       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
+    IF ( ierr .NE. 0 ) THEN
+       CALL tfp_message(__FILE__,__LINE__)
+    ENDIF 
+#endif
+
+! extend the patch dimensions out shw along edges of domain
+    IF ( ips < ipe .and. jps < jpe ) THEN           !wig; 11-Mar-2008
+       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
+    ENDIF                                           !wig; 11-Mar-2008
+
+    kps = 1
+    kpe = kde-kds+1
+
+    kms = 1
+    kme = kpe
+    kmsx = kpsx
+    kmex = kpex
+    kmsy = kpsy
+    kmey = kpey
+
+    ! handle setting the memory dimensions where there are no levels assigned to this proc
+    IF ( kpsx .EQ. 0 .AND. kpex .EQ. -1 ) THEN
+      kmsx = 0
+      kmex = 0
+    ENDIF
+    IF ( kpsy .EQ. 0 .AND. kpey .EQ. -1 ) THEN
+      kmsy = 0
+      kmey = 0
+    ENDIF
+
+    IF ( (jps .EQ. 0 .AND. jpe .EQ. -1) .OR. (ips .EQ. 0 .AND. ipe .EQ. -1) ) THEN
+      ims = 0
+      ime = 0
+    ELSE
+      ims = max( ips - max(shw,maxhalowidth), ids - bdx ) - 1
+      ime = min( ipe + max(shw,maxhalowidth), ide + bdx ) + 1
+    ENDIF
+    imsx = ids
+    imex = ide
+    ipsx = imsx
+    ipex = imex
+    ! handle setting the memory dimensions where there are no Y elements assigned to this proc
+    IF ( ipsy .EQ. 0 .AND. ipey .EQ. -1 ) THEN
+      imsy = 0
+      imey = 0
+    ELSE
+      imsy = ipsy
+      imey = ipey
+    ENDIF
+
+    IF ( (jps .EQ. 0 .AND. jpe .EQ. -1) .OR. (ips .EQ. 0 .AND. ipe .EQ. -1) ) THEN
+      jms = 0
+      jme = 0
+    ELSE
+      jms = max( jps - max(shw,maxhalowidth), jds - bdy ) - 1
+      jme = min( jpe + max(shw,maxhalowidth), jde + bdy ) + 1
+    ENDIF
+    jmsx = jpsx
+    jmex = jpex
+    jmsy = jds
+    jmey = jde
+    ! handle setting the memory dimensions where there are no X elements assigned to this proc
+    IF ( jpsx .EQ. 0 .AND. jpex .EQ. -1 ) THEN
+      jmsx = 0
+      jmex = 0
+    ELSE
+      jpsy = jmsy
+      jpey = jmey
+    ENDIF
+END SUBROUTINE compute_memory_dims_rsl_lite
+
+SUBROUTINE tfp_message( fname, lno )
+   CHARACTER*(*) fname
+   INTEGER lno
+   CHARACTER*1024 mess
+#ifndef STUBMPI
+   WRITE(mess,*)'tfp_message: ',trim(fname),lno
+   CALL wrf_message(mess)
+# ifdef ALLOW_OVERDECOMP
+     CALL task_for_point_message  ! defined in RSL_LITE/task_for_point.c
+# else
+     CALL wrf_error_fatal(mess)
+# endif
+#endif
+END SUBROUTINE tfp_message
+
+SUBROUTINE wrf_message( mess )
+  CHARACTER*(*) mess
+  PRINT*,'info: ',TRIM(mess)
+END SUBROUTINE wrf_message
+
+SUBROUTINE wrf_error_fatal( mess )
+  CHARACTER*(*) mess
+  PRINT*,'fatal: ',TRIM(mess)
+  STOP
+END SUBROUTINE wrf_error_fatal
+
+
+PROGRAM tfp_tester
+     INTEGER       id , maxhalowidth ,            &
+                   shw , bdx,  bdy ,              &
+                   ntasks_x, ntasks_y, &
+                   mytask_x, mytask_y, &
+                   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
+
+     INTEGER i, j
+
+     PRINT*,'id,maxhalowidth,shw,bdx,bdy ? '
+     READ(*,*)id,maxhalowidth,shw,bdx,bdy
+     PRINT*,'ids,ide,jds,jde,kds,kde '
+     READ(*,*)ids,  ide,  jds,  jde,  kds,  kde
+     PRINT*,'ntasks_x,ntasks_y'
+     READ(*,*)ntasks_x,ntasks_y
+
+     
+     DO mytask_y = 0, ntasks_y-1
+     DO mytask_x = 0, ntasks_x-1
+       CALL compute_memory_dims_rsl_lite  (      &
+                     id , maxhalowidth ,            &
+                     shw , bdx,  bdy ,              &
+                     ntasks_x, ntasks_y, &
+                     mytask_x, mytask_y, &
+                     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 )
+
+       PRINT*,' mytask_x, mytask_y ',mytask_x, mytask_y
+       PRINT*,' ips,  ipe,  jps,  jpe,  kps,  kpe  ',ips,  ipe,  jps,  jpe,  kps,  kpe
+       PRINT*,' ims,  ime,  jms,  jme,  kms,  kme  ',ims,  ime,  jms,  jme,  kms,  kme
+       PRINT*,' ipsx, ipex, jpsx, jpex, kpsx, kpex ',ipsx, ipex, jpsx, jpex, kpsx, kpex
+       PRINT*,' imsx, imex, jmsx, jmex, kmsx, kmex ',imsx, imex, jmsx, jmex, kmsx, kmex
+       PRINT*,' ipsy, ipey, jpsy, jpey, kpsy, kpey ',ipsy, ipey, jpsy, jpey, kpsy, kpey
+       PRINT*,' imsy, imey, jmsy, jmey, kmsy, kmey ',imsy, imey, jmsy, jmey, kmsy, kmey
+     ENDDO
+     ENDDO
+END PROGRAM tfp_tester
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/Makefile	(revision 17)
@@ -0,0 +1,42 @@
+.SUFFIXES: .F .o
+FFLAGS = -I../io_int
+
+OBJ  =          module_PATCH_QUILT.o \
+        atm_comm.o  \
+        atm_tiles.o     \
+        cmpcomm.o       \
+        mpi_more.o
+
+AR = ar
+ARFLAGS = cr
+TARGET = libatm_ocn.a
+
+library: $(OBJ)
+	$(AR) $(ARFLAGS) $(TARGET) $(OBJ)
+	$(RANLIB) $(TARGET)
+
+.F.o:
+	$(CPP) $(CPPFLAGS) -DDM_PARALLEL  $*.F  > $*.f90
+	$(FC) -o $@ -c $(FFLAGS)  $*.f90 
+
+clean:
+	rm -f $(OBJ) $(TARGET)
+	rm -f *.f90 
+	rm -f *.mod
+
+
+superclean: clean
+# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES)
+
+atm_tiles.o: \
+	atm_comm.o \
+	module_PATCH_QUILT.o
+
+atm_comm.o: \
+	cmpcomm.o
+atm_tiles.o:
+cmpcomm.o:
+mpi_more.o:
+
+# DO NOT DELETE
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/atm_comm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/atm_comm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/atm_comm.F	(revision 17)
@@ -0,0 +1,668 @@
+      MODULE ATM_cc
+
+      USE CMP_COMM, ONLY: &
+
+     &   MPI_COMM_Atmos => COMM_local, &
+
+     &   Coupler_id, &
+     &   component_master_rank_local, &
+     &   process_rank_local, &
+     &   component_nprocs, &
+     &   ibuffer, &
+
+     &   MPI_INTEGER,MPI_STATUS_SIZE, &
+     &   kind_REAL,kind_alt_REAL, &
+     &   MPI_kind_REAL,MPI_kind_alt_REAL
+
+      implicit none
+
+      integer,parameter:: ND=2
+      integer Ocean_spec /-1/, WM_id /-10/
+      integer NSF
+      integer NSF_WM
+      real dtc,           &       !<- Coupling period
+     &     dta,           &     !<- AM time step ("physical")
+     &     dta2dtc              !<- AM time step / Coupling period
+      integer i_dtc2dta /100/   !<- Coupling period / AM time step
+      integer & !,dimension(ND)::
+     &ims,ime,jms,jme,its,ite,jts,jte,ids,idf,jds,jdf,  NGP
+      integer kms,kme,kts,kte,kds,kde
+      integer,parameter:: kind_R=kind_alt_REAL
+!c     integer,parameter:: kind_tiling=kind_R
+      integer,parameter:: kind_sfcflux=kind_R, &
+     &                    kind_SST=kind_R, &
+     &                    kind_SLM=kind_R, &
+     &                    kind_lonlat=kind_R
+      integer MPI_kind_R, &
+     &MPI_kind_sfcflux,MPI_kind_SST,MPI_kind_SLM,MPI_kind_lonlat
+      integer n_ts(ND) /0,0/, gid
+      integer rc /5/
+      real,parameter:: &
+     &   SLM_OS_value=1.,  &!<-must be real open sea mask value in AM
+     &   unrealistically_low_SST=0.01, & ! <- must be unreal low but >=0.,
+                                       ! see interp. --- check!
+     &   unrealistically_low_SV=-1.E30, &
+                     ! <- must be negative unreal low surface flux
+                     ! or other surface value to be sent
+                     ! to Coupler, see Coupler code
+     &   unrealistically_low_SF=unrealistically_low_SV, & !<- same thing
+     &   unrealistically_low_SVp=0.99*unrealistically_low_SV
+
+      logical initialized /.false./
+      logical PHYS,zeroSF,nrmSF,sendSF,getSST
+
+      TYPE SST_ARRAY
+        real(kind=kind_SST),dimension(:,:),pointer:: a 
+      END TYPE SST_ARRAY
+      TYPE SF_ARRAY
+        real(kind=kind_sfcflux),dimension(:,:,:),pointer:: a
+      END TYPE SF_ARRAY
+
+      TYPE (SST_ARRAY), dimension(ND):: SST_cc
+      TYPE (SF_ARRAY), dimension(ND):: sf
+
+      character*12 sgid
+
+!Controls:
+      integer nunit_announce /6/, VerbLev /3/
+
+      SAVE
+
+      END MODULE ATM_cc
+!C
+!C***********************************************************************
+!C
+      SUBROUTINE ATM_CMP_START(atm_comm)
+
+      USE ATM_cc
+
+      implicit none
+
+      integer atm_comm
+
+      integer Atmos_id /1/, Atmos_master_rank_local /0/, Atmos_spec /1/
+      integer ibuf(1),ierr
+      character*20 s
+!C
+
+                      !<-id of OM as a component of the coupled system
+      call CMP_INIT(Atmos_id,1)
+                             !<-"flexibility level"
+      if (Coupler_id.ge.0) VerbLev=min(VerbLev,ibuffer(4))
+      write(s,'(i2)') VerbLev
+
+      call CMP_INTRO(Atmos_master_rank_local)
+      call ATM_ANNOUNCE('back from CMP_INTRO, VerbLev='//s,2)
+
+      initialized=.true.
+
+      call CMP_INTEGER_SEND(Atmos_spec,1)
+
+      call CMP_gnr_RECV(Ocean_spec,1,MPI_INTEGER)
+      write(s,'(i2)') Ocean_spec
+      call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, OM spec is '//s,2)
+      call MPI_BCAST(Ocean_spec,1,MPI_INTEGER, &
+     &component_master_rank_local,MPI_COMM_Atmos,ierr)
+      call ATM_ANNOUNCE('ATM_CMP_START: Ocean_spec broadcast',2)
+
+      call CMP_gnr_RECV(WM_id,1,MPI_INTEGER)
+      write(s,'(i2)') WM_id
+      call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, WM id is '//s,2)
+      call MPI_BCAST(WM_id,1,MPI_INTEGER, &
+     &component_master_rank_local,MPI_COMM_Atmos,ierr)
+      call ATM_ANNOUNCE('ATM_CMP_START: WM_id broadcast',2)
+      if (WM_id.gt.0) then
+        NSF_WM=2
+      else
+        NSF_WM=0
+      end if
+
+      if (Ocean_spec.eq.1) then
+        NSF=4+NSF_WM
+      else if (Ocean_spec.eq.2) then
+        NSF=8+NSF_WM
+      else if (Ocean_spec.eq.0) then
+        NSF=NSF_WM
+      else if (Coupler_id.ge.0) then
+        call GLOB_ABORT(Ocean_spec-1, &
+     &  'ATM_CMP_START received wrong Ocean_spec value, aborted',rc)
+      else
+        Ocean_spec=1
+        NSF=4
+        call ATM_ANNOUNCE('AM is standalone: Ocean_spec=1, NSF=4'// &
+     &  ' assigned (as if for POM coupling)',2)
+      end if
+
+      if (kind_R.eq.kind_REAL) then
+        MPI_kind_R=MPI_kind_REAL
+      else 
+        MPI_kind_R=MPI_kind_alt_REAL
+      end if
+      if (kind_sfcflux.eq.kind_REAL) then
+        MPI_kind_sfcflux=MPI_kind_REAL
+      else 
+        MPI_kind_sfcflux=MPI_kind_alt_REAL
+      end if
+      if (kind_SST.eq.kind_REAL) then
+        MPI_kind_SST=MPI_kind_REAL
+      else 
+        MPI_kind_SST=MPI_kind_alt_REAL
+      end if
+      if (kind_SLM.eq.kind_REAL) then
+        MPI_kind_SLM=MPI_kind_REAL
+      else 
+        MPI_kind_SLM=MPI_kind_alt_REAL
+      end if
+      if (kind_lonlat.eq.kind_REAL) then
+        MPI_kind_lonlat=MPI_kind_REAL
+      else 
+        MPI_kind_lonlat=MPI_kind_alt_REAL
+      end if
+
+      atm_comm=MPI_COMM_Atmos
+
+      return
+      END
+!C
+!C***********************************************************************
+!C
+      SUBROUTINE ATM_INIT_CHECK(s)
+
+      USE ATM_cc, ONLY: initialized,rc
+
+      implicit none
+
+      character*(*) s
+
+      if (.not. initialized) call GLOB_ABORT(1,s,rc)
+
+      return
+      END
+!C
+!C***********************************************************************
+!C
+      subroutine ATM_TSTEP_INIT(NTSD,NPHS,gid_,dta_, &
+     &ids_,idf_,jds_,jdf_,its_,ite_,jts_,jte_,ims_,ime_,jms_,jme_, &
+       !<-"domain"         !<-"tile"           !<-"memory" (tile+halo)
+     &kds_,kde_,kts_,kte_,kms_,kme_, &
+     &HLON,HLAT,VLON,VLAT, &
+     &SLM, &
+     &i_parent_start,j_parent_start)
+
+      USE ATM_cc
+
+      implicit none
+
+      integer NTSD,NPHS,gid_
+      real dta_
+      integer ids_,idf_,jds_,jdf_,its_,ite_,jts_,jte_, &
+     &ims_,ime_,jms_,jme_,kds_,kde_,kts_,kte_,kms_,kme_
+      real(kind=kind_lonlat),dimension(ims_:ime_,jms_:jme_):: &
+     &HLON,HLAT,VLON,VLAT
+      real(kind=kind_SLM),dimension(ims_:ime_,jms_:jme_):: SLM
+      integer i_parent_start,j_parent_start
+
+      integer KDT,buf(2) /0,0/
+      character*24 s
+      character*80 s1
+
+      SAVE
+!C
+
+      gid=gid_
+      call GLOB_ABORT((gid-1)*(gid-2), &
+     &'Abort: in ATM_TSTEP_INIT gid is neither 1 nor 2',rc)
+      KDT=NTSD/NPHS+1
+      PHYS=MOD(NTSD,NPHS).eq.0 ! .and. gid.eq.1 <-removed to bring MG in
+      dta=dta_ 
+
+      write(s1,'("gid=",i1," NTSD=",i5," NPHS=",i3," KDT=",i5,'// &
+     &'" PHYS=",L1)') gid,NTSD,NPHS,KDT,PHYS
+      call ATM_ANNOUNCE('ATM_TSTEP_INIT entered: '//trim(s1),3)
+
+!c     IF (n_ts.eq.-1 .and. PHYS) THEN
+!c       PHYS=.false.
+!c       n_ts=0   ! init. value must be -1 . But if PHYS does not need
+!c                ! this correction, init. value must be 0 (whereas this
+!c                ! IF statement may stay)
+!c     END IF
+      if (.not.PHYS) then
+        zeroSF=.false.
+        nrmSF=.false.
+        sendSF=.false.
+        RETURN
+      end if
+
+      n_ts(gid)=n_ts(gid)+1  ! init. value must be 0   ***0***
+      write(s,'(2i8)') KDT,n_ts(gid)
+      write(sgid,'(" grid id = ",i1)') gid
+      call ATM_ANNOUNCE('ATM_TSTEP_INIT working:'// &
+     &sgid//'; KDT, n_ts: '//s,3)
+      call GLOB_ABORT(KDT-n_ts(gid), &
+     &'Abort: in ATM_TSTEP_INIT KDT, n_ts(gid) differ '//s,rc)
+
+      call ATM_RECVdtc
+
+      zeroSF=((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)-1
+      nrmSF=(n_ts(gid)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)
+      sendSF=(n_ts(gid)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)
+                                    !<-check, this depends
+                                    ! on where ATM_SENDFLUXES is called.
+                                    ! MOD(n_ts,i_dtc2dta).eq.0 should
+                                    ! be good for calling it after
+                                    ! ATM_DOFLUXES at the same t.s.
+
+      ids=ids_
+      idf=idf_
+      jds=jds_
+      jdf=jdf_
+      its=its_
+      ite=ite_
+      jts=jts_
+      jte=jte_
+      ims=ims_
+      ime=ime_
+      jms=jms_
+      jme=jme_
+
+      kds=kds_
+      kde=kde_
+      kts=kts_
+      kms=kms_
+      kme=kme_
+      kte=kte_
+
+      NGP=(idf-ids+1)*(jdf-jds+1)
+
+      call ATM_ANNOUNCE('ATM_TSTEP_INIT to allocate sf, SST_cc',3)
+
+      IF (n_ts(gid).eq.1) THEN
+        allocate(sf(gid)%a(ims:ime,jms:jme,NSF))
+        allocate(SST_cc(gid)%a(ims:ime,jms:jme))
+      END IF
+
+      if (gid.eq.2) then
+        write(s,'(2i8)') i_parent_start,j_parent_start
+        if (zeroSF) then
+          buf(1)=i_parent_start
+          buf(2)=j_parent_start
+          call CMP_INTEGER_SEND(buf,2)
+          call ATM_ANNOUNCE( &
+     &    'ATM_TSTEP_INIT: i_parent_start, j_parent_start sent '//s,3)
+        else
+          call GLOB_ABORT(abs(i_parent_start-buf(1))+abs(j_parent_start- &
+     &    buf(2)),'NESTED GRID MOVED DURING C TIME STEP: ABORTED '// &
+     &    s,rc)
+        end if
+      end if
+
+      CALL ATM_SENDGRIDS(HLON,HLAT,VLON,VLAT)
+
+      CALL ATM_SENDSLM(SLM)
+
+      if (VerbLev.ge.2) print*,'AM: ATM_TSTEP_INIT: returning ',gid, &
+     &n_ts(gid),ids,idf,jds,jdf,its,ite,jts,jte,ims,ime,jms,jme,NGP,NSF
+
+      RETURN
+      end
+!C
+!C***********************************************************************
+!C
+      SUBROUTINE ATM_RECVdtc
+
+      USE ATM_cc
+
+      implicit none
+
+      real(kind=kind_R) buf(1),dtc2dta
+      integer ierr,i
+      logical first/.true./
+      character*20 s
+      SAVE
+!C
+
+      write(s,'(1pe20.12)') dta
+      call ATM_ANNOUNCE('ATM_RECVdtc: AM time step dta='//s,3)
+
+      IF (first) THEN
+        call ATM_ANNOUNCE( &
+     &  'ATM_RECVdtc: to receive C time step; AM time step dta='//s,2)
+
+        call CMP_gnr_RECV(buf,1,MPI_kind_R)
+
+        call MPI_BCAST(buf,1,MPI_kind_R, &
+     &  component_master_rank_local,MPI_COMM_Atmos,ierr)
+        call ATM_ANNOUNCE('ATM_RECVdtc: C time step broadcast',2)
+        dtc=buf(1)
+
+        if (Coupler_id.lt.0) then
+          if (gid.eq.1) then
+            dtc=dta*2            ! just having in mind that with gid=1
+          else                   ! dta value is 5 times its value with
+            dtc=dta*10           ! gid=2 (at this moment, 270s and 54s
+          end if                 ! respectively)
+          write(s,'(1pe20.12)') dtc
+          call ATM_ANNOUNCE('ATM_RECVdtc: C time step assigned '// &
+     &    trim(s)//' : standalone mode',2)
+        else
+          write(s,'(1pe20.12)') buf
+          call ATM_ANNOUNCE( &
+     &    'ATM_RECVdtc: C time step dtc='//s//' received',2)
+        end if
+      END IF
+
+      dtc2dta=dtc/dta
+      i_dtc2dta=nint(dtc2dta)
+      if (abs(i_dtc2dta-dtc2dta).gt.1.E-5) call GLOB_ABORT(1, &
+     &'AM: ABORTED: dtc is not a multiple of dta',1)
+
+      i=3
+      if (n_ts(gid).eq.1) i=2
+      if (i_dtc2dta.eq.0) then
+        i_dtc2dta=4
+        call ATM_ANNOUNCE('ratio of C/AM time steps =0, assigned 4 .'// &
+     &  ' This should only occur in standalone mode and ONLY IF dtc '// &
+     &  'HAS NOT BEEN ASSIGNED A POSITIVE VALUE: ** ATTENTION **',i)
+      else
+        write(s,'(i2)') i_dtc2dta
+        call ATM_ANNOUNCE('ratio of C/AM time steps: '//trim(s),i)
+      end if
+
+      dta2dtc=1./i_dtc2dta
+
+      first=.false.
+
+      RETURN
+      END
+!C
+!C***********************************************************************
+!C
+      SUBROUTINE ATM_SENDGRIDS(HLON,HLAT,VLON,VLAT)
+
+      USE ATM_cc
+
+      implicit none
+
+      real(kind=kind_lonlat),dimension(ims:ime,jms:jme):: &
+     &HLON,HLAT,VLON,VLAT 
+
+      real(kind=kind_lonlat),dimension(ids:idf,jds:jdf):: &
+     &ALONt,ALATt,ALONv,ALATv
+
+      integer buf(2)
+!C
+
+!c     IF (gid.ne.1) RETURN ! only "parent grid" dim. and coor. are sent
+
+      IF (.not.PHYS .or. n_ts(gid).ne.1) RETURN
+      
+!temporarily excluded      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+      buf(1)=idf-ids+1
+      buf(2)=jdf-jds+1
+      call ATM_ANNOUNCE('to send grid dimensions,'//sgid,1)
+      call CMP_INTEGER_SEND(buf,2)
+      call ATM_ANNOUNCE('grid dimensions sent,'//sgid,1)
+
+!c     IF (gid.eq.1) THEN    !  only "parent grid" coordinates are sent
+
+        call ASSEMBLE(ALONt,HLON,kind_lonlat)
+        call ASSEMBLE(ALATt,HLAT,kind_lonlat)
+        call ASSEMBLE(ALONv,VLON,kind_lonlat)
+        call ASSEMBLE(ALATv,VLAT,kind_lonlat)
+
+        call ATM_ANNOUNCE('(BP) to send grid arrays (4 MPI calls)',2)
+
+        call CMP_gnr_SEND(ALONt,NGP,MPI_kind_lonlat)
+        call CMP_gnr_SEND(ALATt,NGP,MPI_kind_lonlat)
+        call CMP_gnr_SEND(ALONv,NGP,MPI_kind_lonlat)
+        call CMP_gnr_SEND(ALATv,NGP,MPI_kind_lonlat)
+
+        call ATM_ANNOUNCE('the 4 grid arrays sent',1)
+
+!c     END IF
+
+      call ATM_ANNOUNCE('(BP) ATM_SENDGRIDS: returning',2)
+
+      return
+      END
+!C
+!C***********************************************************************
+!C
+      SUBROUTINE ATM_SENDSLM(SLM)
+
+      USE ATM_cc
+
+      implicit none
+
+      real(kind=kind_SLM),dimension(ims:ime,jms:jme):: SLM
+
+      real(kind=kind_SLM),dimension(ids:idf,jds:jdf):: SLM_g
+      integer buf(2)
+!C
+
+!c     IF (gid.ne.1) RETURN  !  only "parent grid" mask is sent
+      IF (.not.PHYS .or. n_ts(gid).ne.1) RETURN
+      
+!temporarily excluded      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+      call ASSEMBLE(SLM_g,SLM,kind_SLM)
+
+      call ATM_ANNOUNCE('(BP) to send SLM',2)
+
+      call CMP_gnr_SEND(SLM_g,NGP,MPI_kind_SLM)
+      call CMP_gnr_SEND(SLM_g,NGP,MPI_kind_SLM)
+           ! Coupler requires as many copies of mask as there are grids
+
+      call ATM_ANNOUNCE('(BP) ATM_SENDSLM: returning',2)
+
+      return
+      END
+!C
+!C***********************************************************************
+!C
+      SUBROUTINE ATM_GETSST(SST,SLM)
+
+      USE ATM_cc
+
+      implicit none
+
+      real(kind=kind_SST) SST(ims:ime,jms:jme)
+      real(kind=kind_SLM) SLM(ims:ime,jms:jme)
+
+      integer i,j
+      real(kind=kind_SST) SST_g(ids:idf,jds:jdf)
+!C
+
+      IF (.not.PHYS) RETURN
+
+      call ATM_ANNOUNCE('ATM_GETSST entered (PHYS=.true.)',3)
+
+      getSST=((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)-1
+      if (getSST.neqv.zeroSF) then
+        call GLOB_ABORT(1,'getSST differs from zeroSF, which screws'// &
+     &  ' up the design for exchanges with C',rc)
+      end if
+
+      if (getSST) then
+        if (n_ts(gid).eq.1 .and. gid.eq.1) then
+          call ATM_ANNOUNCE('ATM_GETSST: to send ref. SST'//sgid,2)
+          call ASSEMBLE(SST_g,SST,kind_SST)
+          call CMP_gnr_SEND(SST_g,NGP,MPI_kind_SST)
+          call ATM_ANNOUNCE('ATM_GETSST: ref. SST sent'//sgid,2)
+        end if
+        call ATM_ANNOUNCE('ATM_GETSST: to receive SST',3)
+        call CMP_gnr_RECV(SST_g,NGP,MPI_kind_SST)
+        call DISASSEMBLE(SST_g,SST_cc(gid)%a,kind_SST)
+        call ATM_ANNOUNCE('ATM_GETSST: SST received',3)
+      end if
+      
+      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+      do j=jts,jte
+      do i=its,ite
+        if (abs(SLM(i,j)-SLM_OS_value).lt.0.01) then 
+                                  ! i.e. if it is OS (open sea) AMGP
+                                  !
+          if (SST_cc(gid)%a(i,j).gt.unrealistically_low_SST)  &
+                                          ! i.e. if there is a valid
+                                          ! result of interpolation from
+                                          ! OMG for this AMGP
+     &       SST(i,j)=SST_cc(gid)%a(i,j)
+        end if
+      end do
+      end do
+
+      return
+      END
+!C
+!C***********************************************************************
+!C
+      SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, &
+!c    &USTAR,U10,V10,PINT,PREC)
+     &TX,TY,PINT,PREC,U10,V10)
+
+      USE ATM_cc
+
+      implicit none
+
+      real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: &
+     &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,TX,TY,PINT,PREC,U10,V10
+!c    &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,USTAR,U10,V10,PINT,PREC
+!       Act. arg. for PINT is a 3d array - so this only is OK if
+!       Ps=Act.arg.(:,:.1) - actually, Ps=PINT(:,1,:)
+
+      real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: SWR,R
+      real dtainv
+!C
+
+      IF (.not.PHYS) RETURN
+! Debug insertion:->
+!c     if (PREC(ims+3,jms+3).ne.0 .or. PREC(ims+5,jms+5).ne.0) then
+!c       print*,'ATM_DOFLUXES,gid,n_ts(gid),PREC(3,3),PREC(5,5): ',
+!c    &  gid,n_ts(gid),PREC(ims+3,jms+3),PREC(ims+5,jms+5)
+!c     end if
+! <-:Debug insertion
+
+      call ATM_ANNOUNCE('ATM_DOFLUXES entered',3)
+
+      dtainv=1./dta
+
+      if (zeroSF) sf(gid)%a=0.
+
+      SWR=-RSWIN+RSWOUT          ! Check sign! here SWR is meant to be
+                                 ! positive upward
+!c     sf(gid)%a(:,:,NSF-1)=sf(gid)%a(:,:,NSF-1)-TX
+!c     sf(gid)%a(:,:,NSF)=sf(gid)%a(:,:,NSF)-TY
+!c                    ! <- signs for stress components are     changed
+!c                    ! so it is -stress
+
+!c     R=SWR+RADOT-RLWIN          ! Check sign! here R (net radiation)
+                                 ! is meant to be positive upward
+
+!oooooooooooooooooooooooooooooo
+      IF (Ocean_spec.eq.1) THEN
+!oooooooooooooooooooooooooooooo
+        sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)-TWBS-QWBS+RADOT-RLWIN
+                                       ! -TWBS (-QWBS) is supposed to
+                                       ! be sensible (latent) heat flux,
+                                       ! positive upward
+        sf(gid)%a(:,:,2)=sf(gid)%a(:,:,2)+SWR
+        sf(gid)%a(:,:,NSF-NSF_WM-1)=sf(gid)%a(:,:,NSF-NSF_WM-1)-TX
+        sf(gid)%a(:,:,NSF-NSF_WM)=sf(gid)%a(:,:,NSF-NSF_WM)-TY
+                     ! <- signs for stress components are changed
+!ooooooooooooooooooooooooooooooooooo
+      ELSE IF (Ocean_spec.eq.2) THEN
+!ooooooooooooooooooooooooooooooooooo
+        sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)+PREC
+        sf(gid)%a(:,:,2)=sf(gid)%a(:,:,2)-TWBS
+        sf(gid)%a(:,:,3)=sf(gid)%a(:,:,3)-QWBS
+        sf(gid)%a(:,:,4)=sf(gid)%a(:,:,4)+PINT-101300.
+        sf(gid)%a(:,:,5)=sf(gid)%a(:,:,5)-SWR-RADOT+RLWIN
+        sf(gid)%a(:,:,6)=sf(gid)%a(:,:,6)-SWR
+
+        sf(gid)%a(:,:,NSF-NSF_WM-1)=sf(gid)%a(:,:,NSF-NSF_WM-1)+TX
+        sf(gid)%a(:,:,NSF-NSF_WM)=sf(gid)%a(:,:,NSF-NSF_WM)+TY
+                     ! <- signs for stress components are NOT changed
+        if (nrmSF) then
+          sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)*dtainv
+                        ! so this will be m/s; check what OM wants
+        end if
+!ooooooooooo
+      END IF
+!ooooooooooo
+
+
+!wwwwwwwwwwwwwwwwwwwwwwwww
+      IF (WM_id.gt.0) THEN
+!wwwwwwwwwwwwwwwwwwwwwwwww
+        sf(gid)%a(:,:,NSF-1)=sf(gid)%a(:,:,NSF-1)+U10
+        sf(gid)%a(:,:,NSF)=sf(gid)%a(:,:,NSF)+V10
+!wwwwwwwwwww
+      END IF
+!wwwwwwwwwww
+
+      if (nrmSF) then
+        sf(gid)%a=sf(gid)%a*dta2dtc
+      end if
+
+      call ATM_ANNOUNCE('ATM_DOFLUXES to return',3)
+
+      return
+      END
+!C
+!C***********************************************************************
+!C
+      SUBROUTINE ATM_SENDFLUXES
+
+      USE ATM_cc
+
+      implicit none
+
+      real(kind=kind_sfcflux) F(ids:idf,jds:jdf)
+      integer n
+!C
+
+      if (.not.PHYS) RETURN
+
+      if (.not.sendSF) then
+        call ATM_ANNOUNCE( &
+     &  'ATM_SENDLUXES entered with PHYS but not sendSF: returning'// &
+     &  sgid,3)
+        RETURN
+      end if
+
+      call ATM_ANNOUNCE('In ATM_SENDLUXES'//sgid,3)
+
+      do n=1,NSF
+        call ASSEMBLE(F,sf(gid)%a(:,:,n),kind_sfcflux)
+        call CMP_gnr_SEND(F,NGP,MPI_kind_sfcflux)
+      end do
+
+      call ATM_ANNOUNCE('ATM_SENDFLUXES to return'//sgid,3)
+
+      return
+      END
+!C
+!C***********************************************************************
+!C
+      SUBROUTINE ATM_ANNOUNCE(s,DbgLev)
+
+      USE ATM_cc, ONLY: nunit_announce,VerbLev,MPI_COMM_Atmos
+
+      implicit none
+
+      character*(*) s
+      integer DbgLev
+
+      integer ierr
+!C
+      if (DbgLev.le.VerbLev) then
+        if (s(1:5).eq.'(BP) ') then
+          call MPI_BARRIER(MPI_COMM_Atmos,ierr)
+        end if
+        CALL CMP_ANNOUNCE(nunit_announce,'AM: '//s)
+      end if
+
+      return
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/atm_comm_pom.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/atm_comm_pom.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/atm_comm_pom.F	(revision 17)
@@ -0,0 +1,584 @@
+      MODULE ATM_cc
+
+      USE CMP_COMM, ONLY: &
+
+     &   MPI_COMM_Atmos => COMM_local, &
+
+     &   Coupler_id, &
+     &   component_master_rank_local, &
+     &   process_rank_local, &
+     &   component_nprocs, &
+     &   ibuffer, &
+
+     &   MPI_INTEGER,MPI_STATUS_SIZE, &
+     &   kind_REAL,kind_alt_REAL, &
+     &   MPI_kind_REAL,MPI_kind_alt_REAL 
+
+      implicit none
+
+      integer,parameter:: NSF=4, ND=2
+      real dtc,              &   !<- Coupling period 
+     &     dta,              &   !<- AM time step ("physical")
+     &     dta2dtc              !<- AM time step / Coupling period
+      integer i_dtc2dta /100/   !<- Coupling period / AM time step
+      integer &!,dimension(ND):: 
+     &ims,ime,jms,jme,its,ite,jts,jte,ids,idf,jds,jdf,  NGP
+      integer kms,kme,kts,kte,kds,kde
+      integer,parameter:: kind_R=kind_alt_REAL
+!     integer,parameter:: kind_tiling=kind_R
+      integer,parameter:: kind_sfcflux=kind_R, &
+     &                    kind_SST=kind_R, &
+     &                    kind_SLM=kind_R, &
+     &                    kind_lonlat=kind_R
+      integer MPI_kind_R, &
+     &MPI_kind_sfcflux,MPI_kind_SST,MPI_kind_SLM,MPI_kind_lonlat
+      integer n_ts(ND) /0,0/, gid
+      integer rc /5/
+      real,parameter:: &
+     &   SLM_OS_value=1.,  &!<-must be real open sea mask value in AM
+     &   unrealistically_low_SST=0.01,  &! <- must be unreal low but &=0.,
+                                       ! see interp. --- check!
+     &   unrealistically_low_SV=-1.E30, &
+                     ! <- must be negative unreal low surface flux
+                     ! or other surface value to be sent
+                     ! to Coupler, see Coupler code
+     &   unrealistically_low_SF=unrealistically_low_SV, & !<- same thing
+     &   unrealistically_low_SVp=0.99*unrealistically_low_SV
+
+      logical initialized /.false./
+      logical PHYS,zeroSF,nrmSF,sendSF,getSST
+
+      TYPE SST_ARRAY
+        real(kind=kind_SST),dimension(:,:),allocatable:: a 
+      END TYPE SST_ARRAY
+      TYPE SF_ARRAY
+        real(kind=kind_sfcflux),dimension(:,:,:),allocatable:: a 
+      END TYPE SF_ARRAY
+
+      TYPE (SST_ARRAY), dimension(ND):: SST_cc
+      TYPE (SF_ARRAY), dimension(ND):: sf
+
+      character*12 sgid
+
+!ontrols:
+      integer nunit_announce /6/, VerbLev /3/
+
+      SAVE
+
+      END MODULE ATM_cc
+!
+!***********************************************************************
+!
+      SUBROUTINE ATM_CMP_START(atm_comm)
+
+      USE ATM_cc
+
+      implicit none
+
+      integer Atmos_id /1/, Atmos_master_rank_local /0/
+      character*20 s
+      integer atm_comm
+!
+
+                      !<-id of OM as a component of the coupled system
+      call CMP_INIT(Atmos_id,1)
+                             !<-"flexibility level"
+      if (Coupler_id.ge.0) VerbLev=min(VerbLev,ibuffer(4))
+
+      call CMP_INTRO(Atmos_master_rank_local)
+
+      initialized=.true.
+
+      write(s,'(i2)') VerbLev
+      call ATM_ANNOUNCE('back from CMP_INTRO, VerbLev='//s,2)
+
+      if (kind_R.eq.kind_REAL) then
+        MPI_kind_R=MPI_kind_REAL
+      else 
+        MPI_kind_R=MPI_kind_alt_REAL
+      end if
+      if (kind_sfcflux.eq.kind_REAL) then
+        MPI_kind_sfcflux=MPI_kind_REAL
+      else 
+        MPI_kind_sfcflux=MPI_kind_alt_REAL
+      end if
+      if (kind_SST.eq.kind_REAL) then
+        MPI_kind_SST=MPI_kind_REAL
+      else 
+        MPI_kind_SST=MPI_kind_alt_REAL
+      end if
+      if (kind_SLM.eq.kind_REAL) then
+        MPI_kind_SLM=MPI_kind_REAL
+      else 
+        MPI_kind_SLM=MPI_kind_alt_REAL
+      end if
+      if (kind_lonlat.eq.kind_REAL) then
+        MPI_kind_lonlat=MPI_kind_REAL
+      else 
+        MPI_kind_lonlat=MPI_kind_alt_REAL
+      end if
+      atm_comm=MPI_COMM_Atmos
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE ATM_INIT_CHECK(s)
+
+      USE ATM_cc, ONLY: initialized,rc
+
+      implicit none
+
+      character*(*) s
+
+      if (.not. initialized) call GLOB_ABORT(1,s,rc)
+
+      return
+      END
+!
+!***********************************************************************
+!
+      subroutine ATM_TSTEP_INIT(NTSD,NPHS,gid_,dta_, &
+     &ids_,idf_,jds_,jdf_,its_,ite_,jts_,jte_,ims_,ime_,jms_,jme_, &
+       !<-"domain"         !<-"tile"           !<-"memory" (tile+halo)
+     &kds_,kde_,kts_,kte_,kms_,kme_, &
+     &HLON,HLAT,VLON,VLAT, &
+     &SLM, &
+     &i_parent_start,j_parent_start)
+
+      USE ATM_cc
+
+      implicit none
+
+      integer NTSD,NPHS,gid_
+      real dta_
+      integer ids_,idf_,jds_,jdf_,its_,ite_,jts_,jte_, &
+     &ims_,ime_,jms_,jme_,kds_,kde_,kts_,kte_,kms_,kme_ 
+      real(kind=kind_lonlat),dimension(ims_:ime_,jms_:jme_):: &
+     &HLON,HLAT,VLON,VLAT
+      real(kind=kind_SLM),dimension(ims_:ime_,jms_:jme_):: SLM
+      integer i_parent_start,j_parent_start
+
+      integer KDT,buf(2) /0,0/
+      character*24 s
+      character*80 s1
+
+      SAVE
+!
+
+      gid=gid_
+      call GLOB_ABORT((gid-1)*(gid-2), &
+     &'Abort: in ATM_TSTEP_INIT gid is neither 1 nor 2',rc)
+      KDT=NTSD/NPHS+1
+      PHYS=MOD(NTSD,NPHS).eq.0 ! .and. gid.eq.1 <-removed to bring MG in
+      dta=dta_ 
+
+      write(s1,'("gid=",i1," NTSD=",i5," NPHS=",i3," KDT=",i5,'// &
+     &'" PHYS=",L1)') gid,NTSD,NPHS,KDT,PHYS
+      call ATM_ANNOUNCE('ATM_TSTEP_INIT entered: '//trim(s1),3)
+
+!     IF (n_ts.eq.-1 .and. PHYS) THEN
+!       PHYS=.false.
+!       n_ts=0   ! init. value must be -1 . But if PHYS does not need
+!                ! this correction, init. value must be 0 (whereas this
+!                ! IF statement may stay)
+!     END IF
+      if (.not.PHYS) then
+        zeroSF=.false.
+        nrmSF=.false.
+        sendSF=.false.
+        RETURN
+      end if
+
+      n_ts(gid)=n_ts(gid)+1  ! init. value must be 0   ***0***
+      write(s,'(2i8)') KDT,n_ts(gid)
+      write(sgid,'(" grid id = ",i1)') gid
+      call ATM_ANNOUNCE('ATM_TSTEP_INIT working:'// &
+     &sgid//'; KDT, n_ts: '//s,3)
+      call GLOB_ABORT(KDT-n_ts(gid), &
+     &'Abort: in ATM_TSTEP_INIT KDT, n_ts(gid) differ '//s,rc)
+
+      call ATM_RECVdtc
+
+      zeroSF=((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)-1
+      nrmSF=(n_ts(gid)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)
+      sendSF=(n_ts(gid)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)
+                                    !<-check, this depends
+                                    ! on where ATM_SENDFLUXES is called.
+                                    ! MOD(n_ts,i_dtc2dta).eq.0 should
+                                    ! be good for calling it after
+                                    ! ATM_DOFLUXES at the same t.s.
+
+      ids=ids_
+      idf=idf_
+      jds=jds_
+      jdf=jdf_
+      its=its_
+      ite=ite_
+      jts=jts_
+      jte=jte_
+      ims=ims_
+      ime=ime_
+      jms=jms_
+      jme=jme_
+
+      kds=kds_
+      kde=kde_
+      kts=kts_
+      kms=kms_
+      kme=kme_
+      kte=kte_
+
+      NGP=(idf-ids+1)*(jdf-jds+1)
+
+      call ATM_ANNOUNCE('ATM_TSTEP_INIT to allocate sf, SST_cc',3)
+
+      IF (n_ts(gid).eq.1) THEN
+        allocate(sf(gid)%a(ims:ime,jms:jme,NSF))
+        allocate(SST_cc(gid)%a(ims:ime,jms:jme))
+      END IF
+
+      if (gid.eq.2) then
+        write(s,'(2i8)') i_parent_start,j_parent_start
+        if (zeroSF) then
+          buf(1)=i_parent_start
+          buf(2)=j_parent_start
+          call CMP_INTEGER_SEND(buf,2)
+          call ATM_ANNOUNCE( &
+     &    'ATM_TSTEP_INIT: i_parent_start, j_parent_start sent '//s,3)
+        else
+          call GLOB_ABORT(abs(i_parent_start-buf(1))+abs(j_parent_start- &
+     &    buf(2)),'NESTED GRID MOVED DURING C TIME STEP: ABORTED '// &
+     &    s,rc)
+        end if
+      end if
+
+      CALL ATM_SENDGRIDS(HLON,HLAT,VLON,VLAT)
+
+      CALL ATM_SENDSLM(SLM)
+
+      if (VerbLev.ge.2) print*,'AM: ATM_TSTEP_INIT: returning ',gid, &
+     &n_ts(gid),ids,idf,jds,jdf,its,ite,jts,jte,ims,ime,jms,jme,NGP,NSF
+
+      RETURN
+      end
+!
+!***********************************************************************
+!
+      SUBROUTINE ATM_RECVdtc
+
+      USE ATM_cc
+
+      implicit none
+
+      real(kind=kind_R) buf(1),dtc2dta
+      integer ierr,i
+      logical first/.true./
+      character*20 s
+      SAVE
+!
+
+      write(s,'(1pe20.12)') dta
+      call ATM_ANNOUNCE('ATM_RECVdtc: AM time step dta='//s,3)
+
+      IF (first) THEN
+        call ATM_ANNOUNCE( &
+     &  'ATM_RECVdtc: to receive C time step; AM time step dta='//s,2)
+
+        call CMP_gnr_RECV(buf,1,MPI_kind_R)
+
+        call MPI_BCAST(buf,1,MPI_kind_R, &
+     &  component_master_rank_local,MPI_COMM_Atmos,ierr)
+        call ATM_ANNOUNCE('ATM_RECVdtc: C time step broadcast',2)
+        dtc=buf(1)
+
+        if (Coupler_id.lt.0) then
+          if (gid.eq.1) then
+            dtc=dta*2            ! just having in mind that with gid=1
+          else                   ! dta value is 5 times its value with
+            dtc=dta*10           ! gid=2 (at this moment, 270s and 54s
+          end if                 ! respectively)
+          write(s,'(1pe20.12)') dtc
+          call ATM_ANNOUNCE('ATM_RECVdtc: C time step assigned '// &
+     &    trim(s)//' : standalone mode',2)
+        else
+          write(s,'(1pe20.12)') buf
+          call ATM_ANNOUNCE( &
+     &    'ATM_RECVdtc: C time step dtc='//s//' received',2)
+        end if
+      END IF
+
+      dtc2dta=dtc/dta
+      i_dtc2dta=nint(dtc2dta)
+      if (abs(i_dtc2dta-dtc2dta).gt.1.E-5) call GLOB_ABORT(1, &
+     &'AM: ABORTED: dtc is not a multiple of dta',1)
+
+      i=3
+      if (n_ts(gid).eq.1) i=2
+      if (i_dtc2dta.eq.0) then
+        i_dtc2dta=4
+        call ATM_ANNOUNCE('ratio of C/AM time steps =0, assigned 4 .'// &
+     &  ' This should only occur in standalone mode and ONLY IF dtc '// &
+     &  'HAS NOT BEEN ASSIGNED A POSITIVE VALUE: ** ATTENTION **',i)
+      else
+        write(s,'(i2)') i_dtc2dta
+        call ATM_ANNOUNCE('ratio of C/AM time steps: '//trim(s),i)
+      end if
+
+      dta2dtc=1./i_dtc2dta
+
+      first=.false.
+
+      RETURN
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE ATM_SENDGRIDS(HLON,HLAT,VLON,VLAT)
+
+      USE ATM_cc
+
+      implicit none
+
+      real(kind=kind_lonlat),dimension(ims:ime,jms:jme):: &
+     &HLON,HLAT,VLON,VLAT 
+
+      real(kind=kind_lonlat),dimension(ids:idf,jds:jdf):: &
+     &ALONt,ALATt,ALONv,ALATv
+
+      integer buf(2)
+!
+
+!     IF (gid.ne.1) RETURN ! only "parent grid" dim. and coor. are sent
+
+      IF (.not.PHYS .or. n_ts(gid).ne.1) RETURN
+      
+!temporarily excluded      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+      buf(1)=idf-ids+1
+      buf(2)=jdf-jds+1
+      call ATM_ANNOUNCE('to send grid dimensions,'//sgid,1)
+      call CMP_INTEGER_SEND(buf,2)
+      call ATM_ANNOUNCE('grid dimensions sent,'//sgid,1)
+
+!     IF (gid.eq.1) THEN    !  only "parent grid" coordinates are sent
+
+        call ASSEMBLE(ALONt,HLON,kind_lonlat)
+        call ASSEMBLE(ALATt,HLAT,kind_lonlat)
+        call ASSEMBLE(ALONv,VLON,kind_lonlat)
+        call ASSEMBLE(ALATv,VLAT,kind_lonlat)
+
+        call ATM_ANNOUNCE('(BP) to send grid arrays (4 MPI calls)',2)
+
+        call CMP_gnr_SEND(ALONt,NGP,MPI_kind_lonlat)
+        call CMP_gnr_SEND(ALATt,NGP,MPI_kind_lonlat)
+        call CMP_gnr_SEND(ALONv,NGP,MPI_kind_lonlat)
+        call CMP_gnr_SEND(ALATv,NGP,MPI_kind_lonlat)
+
+        call ATM_ANNOUNCE('the 4 grid arrays sent',1)
+
+!     END IF
+
+      call ATM_ANNOUNCE('(BP) ATM_SENDGRIDS: returning',2)
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE ATM_SENDSLM(SLM)
+
+      USE ATM_cc
+
+      implicit none
+
+      real(kind=kind_SLM),dimension(ims:ime,jms:jme):: SLM
+
+      real(kind=kind_SLM),dimension(ids:idf,jds:jdf):: SLM_g
+      integer buf(2)
+!
+
+!     IF (gid.ne.1) RETURN  !  only "parent grid" mask is sent
+      IF (.not.PHYS .or. n_ts(gid).ne.1) RETURN
+      
+!temporarily excluded      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+      call ASSEMBLE(SLM_g,SLM,kind_SLM)
+
+      call ATM_ANNOUNCE('(BP) to send SLM',2)
+
+      call CMP_gnr_SEND(SLM_g,NGP,MPI_kind_SLM)
+      call CMP_gnr_SEND(SLM_g,NGP,MPI_kind_SLM)
+           ! Coupler requires as many copies of mask as there are grids
+
+      call ATM_ANNOUNCE('(BP) ATM_SENDSLM: returning',2)
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE ATM_GETSST(SST,SLM)
+
+      USE ATM_cc
+
+      implicit none
+
+      real(kind=kind_SST) SST(ims:ime,jms:jme)
+      real(kind=kind_SLM) SLM(ims:ime,jms:jme)
+
+      integer i,j
+      real(kind=kind_SST) SST_g(ids:idf,jds:jdf)
+!
+
+      IF (.not.PHYS) RETURN
+
+      call ATM_ANNOUNCE('ATM_GETSST entered (PHYS=.true.)',3)
+
+      getSST=((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta .eq. n_ts(gid)-1
+      if (getSST.neqv.zeroSF) then
+        call GLOB_ABORT(1,'getSST differs from zeroSF, which screws'// &
+     &  ' up the design for exchanges with C',rc)
+      end if
+
+      if (getSST) then
+        if (n_ts(gid).eq.1 .and. gid.eq.1) then
+          call ATM_ANNOUNCE('ATM_GETSST: to send ref. SST'//sgid,2)
+          call ASSEMBLE(SST_g,SST,kind_SST)
+          call CMP_gnr_SEND(SST_g,NGP,MPI_kind_SST)
+          call ATM_ANNOUNCE('ATM_GETSST: ref. SST sent'//sgid,2)
+        end if
+        call ATM_ANNOUNCE('ATM_GETSST: to receive SST',3)
+        call CMP_gnr_RECV(SST_g,NGP,MPI_kind_SST)
+        call DISASSEMBLE(SST_g,SST_cc(gid)%a,kind_SST)
+        call ATM_ANNOUNCE('ATM_GETSST: SST received',3)
+      end if
+      
+      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+      do j=jts,jte
+      do i=its,ite
+        if (abs(SLM(i,j)-SLM_OS_value).lt.0.01) then 
+                                  ! i.e. if it is OS (open sea) AMGP
+                                  !
+          if (SST_cc(gid)%a(i,j).gt.unrealistically_low_SST)  &
+                                          ! i.e. if there is a valid
+                                          ! result of interpolation from
+                                          ! OMG for this AMGP
+     &       SST(i,j)=SST_cc(gid)%a(i,j)
+        end if
+      end do
+      end do
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, &
+!    &USTAR,U10,V10,PINT,PREC)
+     &TX,TY,PINT,PREC)
+
+      USE ATM_cc
+
+      implicit none
+
+      real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: &
+     &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,TX,TY,PINT,PREC 
+!    &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,USTAR,U10,V10,PINT,PREC
+!       Act. arg. for PINT is a 3d array - so this only is OK if
+!       Ps=Act.arg.(:,:.1) - actually, Ps=PINT(:,1,:)
+
+      real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: SWR,R
+      real dtainv
+!
+
+      IF (.not.PHYS) RETURN
+
+      call ATM_ANNOUNCE('ATM_DOFLUXES entered',3)
+
+      dtainv=1./dta
+
+      if (zeroSF) sf(gid)%a=0.
+
+      SWR=-RSWIN+RSWOUT          ! Check sign! here SWR is meant to be
+                                 ! positive upward
+
+!     R=SWR+RADOT-RLWIN          ! Check sign! here R (net radiation)
+                                 ! is meant to be positive upward
+
+      sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)-TWBS-QWBS+RADOT-RLWIN
+                                       ! -TWBS (-QWBS) is supposed to
+                                       ! be sensible (latent) heat flux,
+                                       ! positive upward
+      sf(gid)%a(:,:,2)=sf(gid)%a(:,:,2)+SWR
+
+      sf(gid)%a(:,:,3)=sf(gid)%a(:,:,3)-TX
+      sf(gid)%a(:,:,4)=sf(gid)%a(:,:,4)-TY
+                     ! <- signs for stress components are     changed
+                     ! so it is -stress
+
+      if (nrmSF) then
+        sf(gid)%a=sf(gid)%a*dta2dtc
+      end if
+
+      call ATM_ANNOUNCE('ATM_DOFLUXES to return',3)
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE ATM_SENDFLUXES
+
+      USE ATM_cc
+
+      implicit none
+
+      real(kind=kind_sfcflux) F(ids:idf,jds:jdf)
+      integer n
+!
+
+      if (.not.PHYS) RETURN
+
+      if (.not.sendSF) then
+        call ATM_ANNOUNCE( &
+     &  'ATM_SENDLUXES entered with PHYS but not sendSF: returning'// &
+     &  sgid,3)
+        RETURN
+      end if
+
+      call ATM_ANNOUNCE('In ATM_SENDLUXES'//sgid,3)
+
+      do n=1,NSF
+        call ASSEMBLE(F,sf(gid)%a(:,:,n),kind_sfcflux)
+        call CMP_gnr_SEND(F,NGP,MPI_kind_sfcflux)
+      end do
+
+      call ATM_ANNOUNCE('ATM_SENDFLUXES to return'//sgid,3)
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE ATM_ANNOUNCE(s,DbgLev)
+
+      USE ATM_cc, ONLY: nunit_announce,VerbLev,MPI_COMM_Atmos
+
+      implicit none
+
+      character*(*) s
+      integer DbgLev
+
+      integer ierr
+!
+      if (DbgLev.le.VerbLev) then
+        if (s(1:5).eq.'(BP) ') then
+          call MPI_BARRIER(MPI_COMM_Atmos,ierr)
+        end if
+        CALL CMP_ANNOUNCE(nunit_announce,'AM: '//s)
+      end if
+
+      return
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/atm_tiles.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/atm_tiles.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/atm_tiles.F	(revision 17)
@@ -0,0 +1,64 @@
+      SUBROUTINE ASSEMBLE(FG,FL,knd)
+
+      USE ATM_cc, ONLY: &
+     &                  ids,idf,jds,jdf,kds,kde, &
+     &                  ims,ime,jms,jme,kms,kme, &
+     &                  its,ite,jts,jte,kts,kte
+
+      USE MODULE_PATCH_QUILT
+
+      implicit none
+
+      real,dimension(ids:idf,jds:jdf),intent(out):: FG
+      real,dimension(ims:ime,jms:jme),intent(in) :: FL
+      integer,                        intent(in) :: knd
+
+      integer kl,kg
+!
+
+      kl=kind(FL)
+      kg=kind(FG)
+      if (knd.ne.kl .or. knd.ne.kg) then
+        print*,'knd must = loc. and glob. kinds in ASSEMBLE. '// &
+     &  'To generalize, call of QUILT_2 must be generalized ',knd,kl,kg
+        call GLOB_ABORT(1,'whong kinds in ASSEMBLE',1)
+      end if
+
+      call QUILT_2(FL,FG,ids,idf,jds,jdf,kds,kde, &
+     &ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE DISASSEMBLE(FG,FL,knd)
+
+      USE ATM_cc, ONLY: ids,idf,jds,jdf,kds,kde, &
+     &                  ims,ime,jms,jme,kms,kme, &
+     &                  its,ite,jts,jte,kts,kte
+
+      USE MODULE_PATCH_QUILT
+
+      implicit none
+
+      real,dimension(ids:idf,jds:jdf),intent(in) :: FG
+      real,dimension(ims:ime,jms:jme),intent(out):: FL
+      integer,                        intent(in) :: knd
+
+      integer kl,kg
+!
+
+      kl=kind(FL)
+      kg=kind(FG)
+      if (knd.ne.kl .or. knd.ne.kg) then
+        print*,'knd must = loc. and glob. kinds in DISASSEMBLE. '// &
+     &  'To generalize, call of PATCH must be generalized ',knd,kl,kg
+        call GLOB_ABORT(1,'whong kinds in DISASSEMBLE',1)
+      end if
+
+      call PATCH(FG,FL,ids,idf,jds,jdf,kds,kde, &
+     &ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte)
+
+      return
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/cmpcomm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/cmpcomm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/cmpcomm.F	(revision 17)
@@ -0,0 +1,964 @@
+#if defined( DM_PARALLEL ) 
+      MODULE CMP_COMM
+
+      implicit none
+
+! MPI variables
+      include 'mpif.h'
+ 
+      integer Coupler_id /0/   ! this is Coupler's id, used to address
+                               ! Coupler. This is a default value,
+                               ! possibly to be redefined later
+!
+!     Make Coupler's id 0 if it is active (i.e. communnicating with
+! the Component.) Otherwise, make it a negative integer; in this case,
+! the Component is standalone.
+!
+
+      integer ibuffer_size
+      parameter (ibuffer_size=10)
+      integer Coupler_rank,my_id,COMM_local, &
+     &component_master_rank_global,process_rank_global, &
+     &component_master_rank_local,process_rank_local,&
+     &component_nprocs,FlexLev,ibuffer(ibuffer_size),nprocs_global
+
+      integer kind_REAL,kind_INTEGER,MPI_kind_REAL,&
+     &kind_alt_REAL,MPI_kind_alt_REAL
+      parameter (kind_REAL=8,kind_INTEGER=4)
+      parameter (kind_alt_REAL=12-kind_REAL)
+!       kind_INTEGER must be number of bytes equal to number of bytes
+!     implied by MPI_INTEGER MPI constant; all integers sent/received
+!     are of this kind. No value other than 4 is anticipated as of now
+!       kind_REAL is type of real data to communicate. The corresponding
+!     MPI data type variable MPI_kind_REAL is assigned in CMP_INIT.
+!       kind_alt_REAL is alternative type of real data to communicate. 
+!     The corresponding MPI data type variable MPI_kind_alt_REAL is
+!     assigned in CMP_INIT. (It is used in subroutines CMP_alt_SEND
+!     and CMP_alt_RECV,)
+
+      save
+
+      END MODULE CMP_COMM
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_INIT(id,flex)
+!                         in  in
+!
+!     This subroutine must be called by every Component right upon
+!     calling MPI_INIT. It assigns a value to the Component communicator
+!     COMM_local (which is a global variable in module CMP), to be 
+!     thereafter used by the Component in place of
+!     MPI_COMM_WORLD wherever it is used by the Component's
+!     standalone version. Besides, it stores the Component's id,
+!     the process's ranks, and the "flexibility level" (flex) requested
+!     by the Component in glob. variables. (The latter parameter affects
+!     the mode of communications; for its description, see CMP_SEND and
+!     CMP_RECV.) Finally, it starts handshaking with Coupler, receiving
+!     the unique (global, i.e. in MPI_COMM_WORLD) Coupler process 
+!     rank Coupler_rank from Coupler
+                                        ! ibuffer may include additional
+                                        ! info to be received
+!
+      USE CMP_COMM
+
+      implicit none
+
+      integer id,flex
+
+      integer ierr,color,key,status(MPI_STATUS_SIZE),tag,dummy
+      character*10 s
+      logical izd
+!
+
+!        Determine if MPI is initialized, if not initialize
+      call MPI_INITIALIZED(izd,ierr)
+      if (.not.izd) call MPI_INIT(ierr)
+
+!        Determine MPI send/receive types according to prescribed
+!        types for arrays to be communicated
+      if (kind_REAL.eq.8) then
+        MPI_kind_REAL=MPI_REAL8
+        MPI_kind_alt_REAL=MPI_REAL4
+      else if (kind_REAL.eq.4) then
+        MPI_kind_REAL=MPI_REAL4
+        MPI_kind_alt_REAL=MPI_REAL8
+      else
+        write(s,'(i0)') kind_REAL
+        call GLOB_ABORT(1, &
+     &  'CMP_INIT: illegal value of kind_REAL='//s,1)
+      end if
+      if (kind_INTEGER.ne.4) then
+        write(s,'(i0)') kind_INTEGER
+        call GLOB_ABORT(1, &
+     &  'CMP_INIT: illegal value of kind_INTEGER='//s,1)
+      end if
+
+!        Store the Component's id
+!
+      my_id=id
+
+!        Store the Component's "flexibility level"
+!
+      FlexLev=flex
+
+!        Assign a value to the Component communicator
+!        COMM_local, to be thereafter used by the Component in place of
+!        MPI_COMM_WORLD wherever it is used by the Component's
+!        standalone version
+!
+      color=id
+      key=1
+!           print*,'CMP_INIT: to call MPI_COMM_SPLIT, color=',color
+      call MPI_COMM_SPLIT(MPI_COMM_WORLD,color,key,COMM_local,ierr)
+      call GLOB_ABORT(ierr,'CMP_INIT: error in MPI_COMM_SPLIT',1)
+
+!        Store the process's global and local ranks
+!
+!           print*,'CMP_INIT: to call MPI_COMM_RANK for global rank'
+      call MPI_COMM_RANK(MPI_COMM_WORLD,process_rank_global,ierr)
+      call GLOB_ABORT(ierr, &
+     &'CMP_INIT: error in MPI_COMM_RANK(MPI_COMM_WORLD...)',1)
+!           print*,'CMP_INIT: to call MPI_COMM_RANK for local rank'
+      call MPI_COMM_RANK(COMM_local,process_rank_local,ierr)
+      call GLOB_ABORT(ierr, &
+     &'CMP_INIT: error in MPI_COMM_RANK(COMM_local...)',1)
+
+!        Store component_nprocs - component's number of processes;
+!        calculate global number number of processes;
+!        determine whether it is standalone mode and if it is, make
+!        Coupler's id negative and return
+!
+      call MPI_COMM_SIZE(COMM_local,component_nprocs,ierr)
+      call MPI_COMM_SIZE(MPI_COMM_WORLD,nprocs_global,ierr)
+      if (component_nprocs.eq.nprocs_global) then
+        if(process_rank_local.eq.0) print*,'CMP_INIT: standalone mode'
+        Coupler_id=-1
+        RETURN
+      end if
+
+!        Start handshaking with Coupler (all processes):
+!        receive the unique (global, i.e. in MPI_COMM_WORLD) Coupler 
+!        process rank Coupler_rank from Coupler
+!
+      tag=Coupler_id+23456
+!           print*,'CMP_INIT: to call MPI_RECV'
+      call MPI_RECV(ibuffer,ibuffer_size,MPI_INTEGER,MPI_ANY_SOURCE,tag, &
+     &MPI_COMM_WORLD,status,ierr)
+      call GLOB_ABORT(ierr,'CMP_INIT: error in MPI_RECV',1)
+      Coupler_rank=ibuffer(2)
+      if (ibuffer(1).ne.Coupler_id) then
+        print*,'CMP_INIT: stopped, rcvd ibuffer(1) value is not C id: ', &
+     &  ibuffer(1)
+        CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+      end if
+      if (ibuffer(3).ne.ibuffer_size) then
+        print*,'CMP_INIT: stopped, rcvd ibuffer(3) value ',ibuffer(3), &
+     &  ' is not ibuffer_size=',ibuffer_size
+        CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+      end if
+
+!        Inform Coupler that this components exists and is active
+!
+      call MPI_GATHER(id,1,MPI_INTEGER,dummy,1,MPI_INTEGER, &
+     &Coupler_rank,MPI_COMM_WORLD,ierr)
+
+!
+!     print*,
+!    >'CMP_INIT: ranks: process local, global, Coupler; Coupler_id: ',
+!    >process_rank_local,process_rank_global,Coupler_rank,Coupler_id
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_INTRO(master_rank_local)
+!                                in
+!       This routine must be called by all Component's processes
+!       which must all know the local rank of Component's master
+!       process (master_rank_local)
+!          Alternatively, SUBROUTINE CMP_INTRO_m can be called
+!      from Component's master process only, and SUBROUTINE CMP_INTRO_s
+!      from all other processes. In this case, the local rank of
+!      Component's master process will be determined and broadcast
+!      automatically
+
+      USE CMP_COMM
+
+      implicit none
+ 
+      integer master_rank_local,ierr,ibuf(3),color,key,tag
+!
+
+!     print*,'CMP_INTRO: entered ',master_rank_local,process_rank_local
+!    >,Coupler_rank
+
+      component_master_rank_local=master_rank_local
+
+      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+!        If this process is the Component's master process,
+!        complete handshaking with Coupler:
+!        "register", i.e. send Component master process global rank 
+!        to Coupler. Also, send the requested "flexibility level".
+!        (Sending Component's id (in ibuf(1)) is for double-check only.)
+!
+      if (process_rank_local.eq.master_rank_local) then
+        component_master_rank_global=process_rank_global
+        ibuf(1)=my_id  ! redundant, sent for control only
+        ibuf(2)=process_rank_global
+        ibuf(3)=FlexLev
+        tag=my_id+54321
+            print*,'CMP_INTRO: to call MPI_SEND ',process_rank_local, &
+     &      process_rank_global
+        call MPI_SEND(ibuf,3,MPI_INTEGER,Coupler_rank,tag, &
+     &  MPI_COMM_WORLD,ierr)
+        if (ierr.ne.0) then
+          print*,'CMP_INTRO: error in MPI_SEND, process ', &
+     &    process_rank_global
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+        end if
+      end if
+!           print*,'CMP_INTRO: returning ',process_rank_local,
+!    >      process_rank_global,Coupler_rank
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_INTRO_m
+!
+!      This routine must be called by Component's master process (only),
+!      if CMP_INTRO is not called (see comments in CMP_INTRO)
+
+      USE CMP_COMM
+
+      implicit none
+ 
+      integer ierr,ibuf(3),color,key,tag,i
+!
+
+!     print*,'CMP_INTRO_m: entered, process_rank_local=',
+!    >process_rank_local
+
+      component_master_rank_local=process_rank_local
+      component_master_rank_global=process_rank_global
+
+      tag=abs(my_id)+12345
+      do i=0,component_nprocs-1
+        if (i.ne.component_master_rank_local) then
+          ibuf(1)=component_master_rank_local
+          ibuf(2)=component_master_rank_global
+          call MPI_SEND(ibuf,2,MPI_INTEGER,i,tag,COMM_local,ierr)
+          if (ierr.ne.0) then
+            print*,'CMP_INTRO_m: error in 1st MPI_SEND, i=',i
+            CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+          end if
+        end if
+      end do
+
+      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+!        Complete handshaking with Coupler:
+!        "register", i.e. send Component master process global rank 
+!        to Coupler. Also, send the requested "flexibility level".
+!        (Sending Component's id (in ibuf(1)) is for double-check only.)
+!
+      tag=my_id+54321
+      ibuf(1)=my_id  ! redundant, sent for control only
+      ibuf(2)=process_rank_global
+      ibuf(3)=FlexLev
+!         print*,'CMP_INTRO_m: to call MPI_SEND ',process_rank_local,
+!    >    process_rank_global
+      call MPI_SEND(ibuf,3,MPI_INTEGER,Coupler_rank,tag, &
+     &MPI_COMM_WORLD,ierr)
+      if (ierr.ne.0) then
+        print*,'CMP_INTRO_m: error in MPI_SEND, process ', &
+     &  process_rank_global
+        CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+      end if
+!         print*,'CMP_INTRO_m: returning ',process_rank_local,
+!    >    process_rank_global
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_INTRO_s
+!
+!      This routine must be called by all Component's processes other
+!      than master process,
+!      if CMP_INTRO is not called (see comments in CMP_INTRO)
+
+      USE CMP_COMM
+
+      implicit none
+ 
+      integer ierr,ibuf(3),color,key,tag,i,status(MPI_STATUS_SIZE)
+!
+
+!     print*,'CMP_INTRO_s: entered, process_rank_local=',
+!    >process_rank_local
+
+      tag=abs(my_id)+12345
+      call MPI_RECV(ibuf,2,MPI_INTEGER,MPI_ANY_SOURCE,tag, &
+     &COMM_local,status,ierr)
+      if (ierr.ne.0) then
+        print*,'CMP_INTRO_s: error in MPI_RECV ',process_rank_local
+        CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+      end if
+      component_master_rank_local=ibuf(1)
+      component_master_rank_global=ibuf(2)
+! WtF?      do i=0,component_nprocs-1
+! WtF?        if (i.ne.component_master_rank_local) then
+! WtF?          ibuf(1)=component_master_rank_local
+! WtF?          ibuf(2)=component_master_rank_global
+! WtF?          call MPI_SEND(ibuf,2,MPI_INTEGER,i,tag,COMM_local,ierr)
+! WtF?        end if
+! WtF?      end do
+
+!         print*,'CMP_INTRO_s: returning ',process_rank_local,
+!    >    process_rank_global,component_master_rank_local,
+!    >    component_master_rank_global
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_SEND(F,N)
+!
+      USE CMP_COMM
+
+      implicit none
+ 
+      integer N,ierr,tag
+      real(kind=kind_REAL) F(N)
+!
+      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+!           call CMP_DBG_CR(6,'CMP_SEND: entered')
+
+      if (process_rank_local.ne.component_master_rank_local) then
+        if (FlexLev.eq.0) then
+!         With "flexibility level" FlexLev=0, only Component master 
+!         process is supposed to call this subroutine.
+          print '("*** CMP_SEND: process_rank_local=",i4,"  ***"/ &
+     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
+     &    "*** STOPPED ***")', &
+     &    process_rank_local,component_master_rank_local
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+        else if (FlexLev.eq.1) then
+!         With "flexibility level" FlexLev=1, any Component process is 
+!         allowed to call this subroutine but only the Component
+!         master process can actually send data (so the
+!         others just make a dummy call), as the Coupler process only 
+!         receives data from the Component master process.
+          return
+        else if (FlexLev.ne.2 .and. FlexLev.ne.3) then
+          print '("*** CMP_SEND: illegal value of FlexLev",i9/ &
+     &    "*** STOPPED")',FlexLev
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+        end if
+!         With "flexibility level" FlexLev=2 or FlexLev=3, any 
+!         Component process is allowed to actually send data.
+!         [In this case, the Coupler process (in CPL_RECV) receives 
+!         from MPI_ANY_SOURCE rather than component_master_rank_global,
+!         and it is only identification by  tag  which enables Coupler
+!         to receive the data from the right source.]
+!         But in any case only one Component process may actually be
+!         engaged in a particular exchange of data with Coupler.
+      end if
+
+      tag=my_id
+
+      call MPI_SEND(F,N,MPI_kind_REAL,Coupler_rank,tag, &
+     &MPI_COMM_WORLD,ierr)
+      call GLOB_ABORT(ierr,'CMP_SEND: error in MPI_SEND',1)
+
+!           call CMP_DBG_CR(6,'CMP_SEND: exiting')
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_alt_SEND(F,N)
+!
+      USE CMP_COMM
+
+      implicit none
+ 
+      integer N,ierr,tag
+      real(kind=kind_alt_REAL) F(N)
+!
+      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+!           call CMP_DBG_CR(6,'CMP_alt_SEND: entered')
+
+      if (process_rank_local.ne.component_master_rank_local) then
+        if (FlexLev.eq.0) then
+!         With "flexibility level" FlexLev=0, only Component master 
+!         process is supposed to call this subroutine.
+          print '("*** CMP_SEND: process_rank_local=",i4,"  ***"/ &
+     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
+     &    "*** STOPPED ***")', &
+     &    process_rank_local,component_master_rank_local
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+        else if (FlexLev.eq.1) then
+!         With "flexibility level" FlexLev=1, any Component process is 
+!         allowed to call this subroutine but only the Component
+!         master process can actually send data (so the
+!         others just make a dummy call), as the Coupler process only 
+!         receives data from the Component master process.
+          return
+        else if (FlexLev.ne.2 .and. FlexLev.ne.3) then
+          print '("*** CMP_SEND: illegal value of FlexLev",i9/ &
+     &    "*** STOPPED")',FlexLev
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+        end if
+!         With "flexibility level" FlexLev=2 or FlexLev=3, any 
+!         Component process is allowed to actually send data.
+!         [In this case, the Coupler process (in CPL_RECV) receives 
+!         from MPI_ANY_SOURCE rather than component_master_rank_global,
+!         and it is only identification by  tag  which enables Coupler
+!         to receive the data from the right source.]
+!         But in any case only one Component process may actually be
+!         engaged in a particular exchange of data with Coupler.
+      end if
+
+      tag=my_id
+
+      call MPI_SEND(F,N,MPI_kind_alt_REAL,Coupler_rank,tag, &
+     &MPI_COMM_WORLD,ierr)
+      call GLOB_ABORT(ierr,'CMP_SEND: error in MPI_SEND',1)
+
+!           call CMP_DBG_CR(6,'CMP_SEND: exiting')
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_gnr_SEND(F,N,MPI_DATATYPE)
+!
+      USE CMP_COMM
+
+      implicit none
+ 
+      integer N,MPI_DATATYPE
+      integer F(1)
+
+      integer ierr,tag
+!
+
+      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+!           call CMP_DBG_CR(6,'CMP_alt_SEND: entered')
+
+      if (process_rank_local.ne.component_master_rank_local) then
+        if (FlexLev.eq.0) then
+!         With "flexibility level" FlexLev=0, only Component master 
+!         process is supposed to call this subroutine.
+          print '("*** CMP_SEND: process_rank_local=",i4,"  ***"/ &
+     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
+     &    "*** STOPPED ***")', &
+     &    process_rank_local,component_master_rank_local
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+        else if (FlexLev.eq.1) then
+!         With "flexibility level" FlexLev=1, any Component process is 
+!         allowed to call this subroutine but only the Component
+!         master process can actually send data (so the
+!         others just make a dummy call), as the Coupler process only 
+!         receives data from the Component master process.
+          return
+        else if (FlexLev.ne.2 .and. FlexLev.ne.3) then
+          print '("*** CMP_SEND: illegal value of FlexLev",i9/ &
+     &    "*** STOPPED")',FlexLev
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+        end if
+!         With "flexibility level" FlexLev=2 or FlexLev=3, any 
+!         Component process is allowed to actually send data.
+!         [In this case, the Coupler process (in CPL_RECV) receives 
+!         from MPI_ANY_SOURCE rather than component_master_rank_global,
+!         and it is only identification by  tag  which enables Coupler
+!         to receive the data from the right source.]
+!         But in any case only one Component process may actually be
+!         engaged in a particular exchange of data with Coupler.
+      end if
+
+      tag=my_id
+
+      call MPI_SEND(F,N,MPI_DATATYPE,Coupler_rank,tag, &
+     &MPI_COMM_WORLD,ierr)
+      call GLOB_ABORT(ierr,'CMP_SEND: error in MPI_SEND',1)
+
+!           call CMP_DBG_CR(6,'CMP_SEND: exiting')
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_INTEGER_SEND(F,N)
+!
+      USE CMP_COMM
+
+      implicit none
+ 
+      integer N,ierr,tag
+      integer F(N)
+!
+      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+!           print*,'CMP_INTEGER_SEND: entered with N=',N,' F=',F,
+!    >      '; my_id=',my_id,'Coupler_rank=',Coupler_rank
+
+      if (process_rank_local.ne.component_master_rank_local) then
+        if (FlexLev.eq.0) then
+!         With "flexibility level" FlexLev=0, only Component master 
+!         process is supposed to call this subroutine.
+          print '("*** CMP_SEND: process_rank_local=",i4,"  ***"/ &
+     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
+     &    "*** STOPPED ***")', &
+     &    process_rank_local,component_master_rank_local
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+        else if (FlexLev.eq.1) then
+!         With "flexibility level" FlexLev=1, any Component process is 
+!         allowed to call this subroutine but only the Component
+!         master process can actually send data (so the
+!         others just make a dummy call), as the Coupler process only 
+!         receives data from the Component master process.
+          return
+        else if (FlexLev.ne.2 .and. FlexLev.ne.3) then
+          print '("*** CMP_SEND: illegal value of FlexLev",i9/ &
+     &    "*** STOPPED")',FlexLev
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+        end if
+!         With "flexibility level" FlexLev=2 or FlexLev=3, any 
+!         Component process is allowed to actually send data.
+!         [In this case, the Coupler process (in CPL_RECV) receives 
+!         from MPI_ANY_SOURCE rather than component_master_rank_global,
+!         and it is only identification by  tag  which enables Coupler
+!         to receive the data from the right source.]
+!         But in any case only one Component process may actually be
+!         engaged in a particular exchange of data with Coupler.
+      end if
+
+      tag=my_id
+            print*,'CMP_INTEGER_SEND: to call MPI_SEND; F=', &
+     &      F,' N=',N,' Coupler_rank=',Coupler_rank,' tag=',tag
+      call MPI_SEND(F,N,MPI_INTEGER,Coupler_rank,tag, &
+     &MPI_COMM_WORLD,ierr)
+      call GLOB_ABORT(ierr,'CMP_INTEGER_SEND: error in MPI_SEND',1)
+            print*,'CMP_INTEGER_SEND: to return'
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_RECV(F,N)
+!
+      USE CMP_COMM
+
+      implicit none
+ 
+      integer N,ierr,tag,ibuf(3),status(MPI_STATUS_SIZE)
+      real(kind=kind_REAL) F(N)
+!
+      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+!           call CMP_DBG_CR(6,'CMP_RECV: entered')
+
+      if (process_rank_local.ne.component_master_rank_local) then
+
+        if (FlexLev.eq.0) then
+
+!         With "flexibility level" FlexLev=0, only Component master 
+!         process is supposed to call this subroutine.
+
+          print '("*** CMP_RECV: process_rank_local=",i4,"  ***"/ &
+     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
+     &    "*** STOPPED ***")', &
+     &    process_rank_local,component_master_rank_local
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+
+        else if (FlexLev.eq.1 .or. FlexLev.eq.2) then
+
+!         With "flexibility level" FlexLev=1 or FlexLev=2, any 
+!         Component process is allowed to call this subroutine but 
+!         only the Component master process is supposed to actually 
+!         receive data (so the others just make a dummy call), as
+!         the Coupler process only sends data to the Component master
+!         process.
+
+          return
+
+        else if (FlexLev.eq.3) then
+
+!         With "flexibility level" FlexLev=3, any Component process
+!         may actually receive data.
+!         [In this case, the Coupler process (in CPL_SEND) first
+!         receives the Component process global rank 
+!         (process_rank_global) from this subroutine, the source being
+!         MPI_ANY_SOURCE, so it is only identification by  tag  which 
+!         enables Coupler to receive process_rank_global from the right
+!         source. Upon the receipt, the Coupler process (in CPL_SEND)
+!         sends the data to this Component process, rather than to 
+!         the Component master process as is the case with lower 
+!         "flexibility levels".]
+!         But in any case only one Component process may actually be
+!         engaged in a particular exchange of data with Coupler.
+
+          ibuf(1)=my_id
+          ibuf(2)=process_rank_global
+          tag=my_id
+          call MPI_SEND(ibuf,2,MPI_INTEGER,Coupler_rank,tag, &
+     &    MPI_COMM_WORLD,ierr)
+          call GLOB_ABORT(ierr,'CMP_RECV: error in MPI_SEND',1)
+
+        else
+
+          print '("*** CMP_RECV: illegal value of FlexLev",i9/ &
+     &    "*** STOPPED")',FlexLev
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+
+        end if
+
+      end if
+
+      tag=my_id
+      call MPI_RECV(F,N,MPI_kind_REAL,Coupler_rank,tag, &
+     &MPI_COMM_WORLD,status,ierr)
+      call GLOB_ABORT(ierr,'CMP_RECV: error in MPI_RECV',1)
+
+!           call CMP_DBG_CR(6,'CMP_RECV: exiting')
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_alt_RECV(F,N)
+!
+      USE CMP_COMM
+
+      implicit none
+ 
+      integer N,ierr,tag,ibuf(3),status(MPI_STATUS_SIZE)
+      real(kind=kind_alt_REAL) F(N)
+!
+      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+!           call CMP_DBG_CR(6,'CMP_alt_RECV: entered')
+
+      if (process_rank_local.ne.component_master_rank_local) then
+
+        if (FlexLev.eq.0) then
+
+!         With "flexibility level" FlexLev=0, only Component master 
+!         process is supposed to call this subroutine.
+
+          print '("*** CMP_alt_RECV: process_rank_local=",i4,"  ***"/ &
+     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
+     &    "*** STOPPED ***")', &
+     &    process_rank_local,component_master_rank_local
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+
+        else if (FlexLev.eq.1 .or. FlexLev.eq.2) then
+
+!         With "flexibility level" FlexLev=1 or FlexLev=2, any 
+!         Component process is allowed to call this subroutine but 
+!         only the Component master process is supposed to actually 
+!         receive data (so the others just make a dummy call), as
+!         the Coupler process only sends data to the Component master
+!         process.
+
+          return
+
+        else if (FlexLev.eq.3) then
+
+!         With "flexibility level" FlexLev=3, any Component process
+!         may actually receive data.
+!         [In this case, the Coupler process (in CPL_SEND) first
+!         receives the Component process global rank 
+!         (process_rank_global) from this subroutine, the source being
+!         MPI_ANY_SOURCE, so it is only identification by  tag  which 
+!         enables Coupler to receive process_rank_global from the right
+!         source. Upon the receipt, the Coupler process (in CPL_SEND)
+!         sends the data to this Component process, rather than to 
+!         the Component master process as is the case with lower 
+!         "flexibility levels".]
+!         But in any case only one Component process may actually be
+!         engaged in a particular exchange of data with Coupler.
+
+          ibuf(1)=my_id
+          ibuf(2)=process_rank_global
+          tag=my_id
+          call MPI_SEND(ibuf,2,MPI_INTEGER,Coupler_rank,tag, &
+     &    MPI_COMM_WORLD,ierr)
+          call GLOB_ABORT(ierr,'CMP_alt_RECV: error in MPI_SEND',1)
+
+        else
+
+          print '("*** CMP_alt_RECV: illegal value of FlexLev",i9/ &
+     &    "*** STOPPED")',FlexLev
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+
+        end if
+
+      end if
+
+      tag=my_id
+      call MPI_RECV(F,N,MPI_kind_alt_REAL,Coupler_rank,tag, &
+     &MPI_COMM_WORLD,status,ierr)
+      call GLOB_ABORT(ierr,'CMP_alt_RECV: error in MPI_RECV',1)
+
+!           call CMP_DBG_CR(6,'CMP_alt_RECV: exiting')
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_gnr_RECV(F,N,MPI_DATATYPE)
+!
+      USE CMP_COMM
+
+      implicit none
+ 
+      integer N,MPI_DATATYPE
+      integer F(1)
+
+      integer ierr,tag,ibuf(3),status(MPI_STATUS_SIZE)
+!
+
+      if (Coupler_id.lt.0) return    !   <- standalone mode
+
+!           call CMP_DBG_CR(6,'CMP_gnr_RECV: entered')
+
+      if (process_rank_local.ne.component_master_rank_local) then
+
+        if (FlexLev.eq.0) then
+
+!         With "flexibility level" FlexLev=0, only Component master 
+!         process is supposed to call this subroutine.
+
+          print '("*** CMP_gnr_RECV: process_rank_local=",i4,"  ***"/ &
+     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
+     &    "*** STOPPED ***")', &
+     &    process_rank_local,component_master_rank_local
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+
+        else if (FlexLev.eq.1 .or. FlexLev.eq.2) then
+
+!         With "flexibility level" FlexLev=1 or FlexLev=2, any 
+!         Component process is allowed to call this subroutine but 
+!         only the Component master process is supposed to actually 
+!         receive data (so the others just make a dummy call), as
+!         the Coupler process only sends data to the Component master
+!         process.
+
+          return
+
+        else if (FlexLev.eq.3) then
+
+!         With "flexibility level" FlexLev=3, any Component process
+!         may actually receive data.
+!         [In this case, the Coupler process (in CPL_SEND) first
+!         receives the Component process global rank 
+!         (process_rank_global) from this subroutine, the source being
+!         MPI_ANY_SOURCE, so it is only identification by  tag  which 
+!         enables Coupler to receive process_rank_global from the right
+!         source. Upon the receipt, the Coupler process (in CPL_SEND)
+!         sends the data to this Component process, rather than to 
+!         the Component master process as is the case with lower 
+!         "flexibility levels".]
+!         But in any case only one Component process may actually be
+!         engaged in a particular exchange of data with Coupler.
+
+          ibuf(1)=my_id
+          ibuf(2)=process_rank_global
+          tag=my_id
+          call MPI_SEND(ibuf,2,MPI_INTEGER,Coupler_rank,tag, &
+     &    MPI_COMM_WORLD,ierr)
+          call GLOB_ABORT(ierr,'CMP_gnr_RECV: error in MPI_SEND',1)
+
+        else
+
+          print '("*** CMP_gnr_RECV: illegal value of FlexLev",i9/ &
+     &    "*** STOPPED")',FlexLev
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+
+        end if
+
+      end if
+
+      tag=my_id
+      call MPI_RECV(F,N,MPI_DATATYPE,Coupler_rank,tag, &
+     &MPI_COMM_WORLD,status,ierr)
+      call GLOB_ABORT(ierr,'CMP_gnr_RECV: error in MPI_RECV',1)
+
+!           call CMP_DBG_CR(6,'CMP_gnr_RECV: exiting')
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_ANNOUNCE(nunit,s)
+!
+      USE CMP_COMM
+
+      implicit none
+
+      character*(*) s
+ 
+      integer nunit,ierr
+!
+
+      if (process_rank_local.eq.component_master_rank_local) then
+        write(nunit,*) trim(s)
+      else if (FlexLev.eq.0) then
+
+!         With "flexibility level" FlexLev=0, only Component master 
+!         process is supposed to call this subroutine.
+
+          print '("*** CMP_ANNOUNCE: process_rank_local=",i4,"  ***"/ &
+     &    "*** and component_master_rank_local=",i4," differ:  ***"/ &
+     &    "*** STOPPED ***")', &
+     &    process_rank_local,component_master_rank_local
+          CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
+
+      end if
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_STDOUT(s)
+!
+!     USE CMP_COMM, ONLY: Coupler_id,process_rank_global
+        ! <- These values may not have the right value by this moment,
+        ! as this routine may be called before CMP_INIT  - 02/23/05
+
+      implicit none
+
+      character*(*) s
+      integer ios
+      character*4 mess
+!
+
+! -> For debugging:
+      OPEN(12345, &
+     &file='/nfsuser/g01/wx20ds/C/cmp.stdout', &
+     &form='formatted',status='old',iostat=ios)
+      if (ios.eq.0) then
+        read(12345,*) mess
+        if (mess.eq.'mess') then
+!         print*,'CMP_STDOUT: unit 6 left alone, process ',
+!    >    process_rank_global
+        ! <- process_rank_global may be undefined by this moment, as
+        !    this routine may be called before CMP_INIT  - 02/23/05
+          RETURN
+        end if
+        CLOSE(12345)
+      end if
+! <- for debugging
+
+!     if (Coupler_id.lt.0) RETURN    ! Nothing is to occur if there is
+                                     ! no communication with Coupler,
+                                     ! i.e. if Component is standalone
+        ! <- Coupler_id may not have the right value by this moment,
+        ! as this routine may be called before CMP_INIT  - 02/23/05
+
+      if (len_trim(s).eq.0) RETURN
+
+      close(6)
+      
+      open(6,file=trim(s),form='formatted',status='unknown')
+
+      print*,'CMP_STDOUT: unit 6 closed, reopened as '//trim(s)
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_DBG_CR(nunit,s)
+!
+!       Debugging routine: mainly, prints Coupler_rank
+!
+      USE CMP_COMM
+
+      implicit none
+
+      character*(*) s
+      integer nunit
+
+      integer ncall/0/,ncallmax/5000/
+      save
+!
+
+      if (s(5:6).eq.'m:') then
+        if (process_rank_local .ne. component_master_rank_local) RETURN
+      end if
+
+      if (ncall.ge.ncallmax) RETURN
+      ncall=ncall+1
+
+      write(nunit,*)process_rank_global,ncall,Coupler_id,Coupler_rank,s
+
+! The following assumes that Coupler_rank must be =0, comment out if
+! this is not the case
+      call GLOB_ABORT(Coupler_rank, &
+     &'CMP_DBG_CR: Coupler_rank.ne.0, aborting',1)
+
+      return
+      END
+!
+!***********************************************************************
+!
+      SUBROUTINE CMP_FLUSH(nunit)
+
+      USE CMP_COMM
+
+      implicit none
+
+      integer nunit
+
+      integer i,ierr,rc
+!
+
+      do i=0,component_nprocs-1
+        call MPI_BARRIER(COMM_local,ierr)
+        call GLOB_ABORT(ierr,'CMP_FLUSH: MPI_BARRIER failed, aborting', &
+     &  rc)
+        if (i.eq.process_rank_local) call FLUSH(nunit)
+      end do
+
+      return
+      END
+!
+!***********************************************************************
+!
+      subroutine CMP_FINALIZE(izd,ierr)
+
+      USE CMP_COMM
+
+      implicit none
+
+      logical izd
+      integer ierr
+
+      integer ierr1,ierr2
+!
+
+      ierr=0
+      ierr2=0
+      call MPI_INITIALIZED(izd,ierr1)
+      if (izd) call MPI_FINALIZE(ierr2)
+      ierr=abs(ierr1)+abs(ierr2)
+
+      return
+      END
+#endif
Index: branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/module_PATCH_QUILT.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/module_PATCH_QUILT.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/module_PATCH_QUILT.F	(revision 17)
@@ -0,0 +1,332 @@
+!-----------------------------------------------------------------------
+!
+!NCEP_MESO:MODEL_LAYER: SOLVER
+!
+!-----------------------------------------------------------------------
+!
+      MODULE MODULE_PATCH_QUILT
+!
+!-----------------------------------------------------------------------
+      USE MODULE_EXT_INTERNAL
+!-----------------------------------------------------------------------
+!
+      PRIVATE
+      PUBLIC :: PATCH,QUILT_2
+!
+!-----------------------------------------------------------------------
+!
+      CONTAINS
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      SUBROUTINE PATCH(ARRAYG,ARRAYL                                    &
+     &,                IDS,IDE,JDS,JDE,KDS,KDE                          &
+     &,                IMS,IME,JMS,JME,KMS,KME                          &
+     &,                ITS,ITE,JTS,JTE,KTS,KTE)
+!-----------------------------------------------------------------------
+!     PATCH DISTRIBUTES THE ELEMENTS OF REAL GLOBAL 2-D ARRAY ARRAYG TO
+!     THE REAL LOCAL 2-D ARRAY ARRAYL.
+!
+!     AUTHOR: TOM BLACK
+!-----------------------------------------------------------------------
+!
+      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
+!
+      REAL,DIMENSION(IDS:IDE,JDS:JDE),INTENT(IN) :: ARRAYG
+      REAL,DIMENSION(IMS:IME,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 I=IMS,IME
+        ARRAYL(I,J)=0.
+      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
+!-----------------------------------------------------------------------
+!
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          ARRAYL(I,J)=ARRAYG(I,J)
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  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)
+          ALLOCATE(ARRAYX(NUMVALS),STAT=I)
+ 
+          KNT=0
+!
+          DO J=JSTART,JEND
+          DO I=ISTART,IEND
+            KNT=KNT+1
+            ARRAYX(KNT)=ARRAYG(I,J)
+          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)
+        ALLOCATE(ARRAYX(NUMVALS),STAT=I)
+!
+        CALL MPI_RECV(ARRAYX,NUMVALS,MPI_REAL,0,MYPE,MPI_COMM_COMP      &
+     &,               ISTAT,IRECV)
+!
+        KNT=0
+!
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          KNT=KNT+1
+          ARRAYL(I,J)=ARRAYX(KNT)
+        ENDDO
+        ENDDO
+!
+        DEALLOCATE(ARRAYX)
+!
+!-----------------------------------------------------------------------
+!
+      ENDIF tasks
+!
+!-----------------------------------------------------------------------
+!     CALL MPI_BARRIER(MPI_COMM_COMP,IRTN)
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE PATCH
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      SUBROUTINE QUILT_2(ARRAYL,ARRAYG                                  &
+     &                  ,IDS,IDE,JDS,JDE,KDS,KDE                        &
+     &                  ,IMS,IME,JMS,JME,KMS,KME                        &
+     &                  ,ITS,ITE,JTS,JTE,KTS,KTE)
+!-----------------------------------------------------------------------
+!     QUILT_2 PULLS TOGETHER THE MPI TASKS' LOCAL ARRAYS ARRAYL AND 
+!     THEN QUILTS THEM TOGETHER INTO A SINGLE GLOBAL ARRAY ARRAYG.
+!
+!     AUTHOR: TOM BLACK
+!-----------------------------------------------------------------------
+!
+      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
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN)  :: ARRAYL
+      REAL,DIMENSION(IDS:IDE,JDS:JDE),INTENT(OUT) :: ARRAYG
+!
+!-----------------------------------------------------------------------
+!***  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=JDS,JDE
+      DO I=IDS,IDE
+        ARRAYG(I,J)=0.
+      ENDDO
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  TASK 0 FILLS ITS OWN PART OF THE GLOBAL FIRST.
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+      tasks : IF(MYPE==0)THEN
+!-----------------------------------------------------------------------
+!
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          ARRAYG(I,J)=ARRAYL(I,J)
+        ENDDO
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  TASK 0 NEEDS THE LIMITS FROM EACH OF THE OTHER TASKS AND THEN
+!***  PULLS IN THE APPROPRIATE PIECES FROM ALL OTHER TASKS.
+!-----------------------------------------------------------------------
+!
+        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)
+          ALLOCATE(ARRAYX(NUMVALS),STAT=I)
+!
+          CALL MPI_RECV(ARRAYX,NUMVALS,MPI_REAL,IPE,IPE,MPI_COMM_COMP   &
+     &                 ,ISTAT,IRECV)
+!
+          KNT=0
+!
+          DO J=JSTART,JEND
+          DO I=ISTART,IEND
+            KNT=KNT+1
+            ARRAYG(I,J)=ARRAYX(KNT)
+          ENDDO
+          ENDDO
+!
+          DEALLOCATE(ARRAYX)
+!
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!***  ALL OTHER TASKS TELL TASK 0 WHAT THEIR HORIZONTAL LIMITS ARE AND
+!***  SEND THEIR LOCAL ARRAY TO 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)
+        ALLOCATE(ARRAYX(NUMVALS),STAT=I)
+!
+        KNT=0
+!
+        DO J=JTS,JTE
+        DO I=ITS,ITE
+          KNT=KNT+1
+          ARRAYX(KNT)=ARRAYL(I,J)
+        ENDDO
+        ENDDO
+!
+        CALL MPI_SEND(ARRAYX,NUMVALS,MPI_REAL,0,MYPE,MPI_COMM_COMP      &
+     &,               ISEND)
+!
+        DEALLOCATE(ARRAYX)
+!
+!-----------------------------------------------------------------------
+!
+      ENDIF tasks
+!
+!-----------------------------------------------------------------------
+!     CALL MPI_BARRIER(MPI_COMM_COMP,IRTN)
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE QUILT_2
+!
+!-----------------------------------------------------------------------
+!
+      END MODULE MODULE_PATCH_QUILT
+!
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/mpi_more.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/mpi_more.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/atm_ocn/mpi_more.F	(revision 17)
@@ -0,0 +1,17 @@
+      SUBROUTINE GLOB_ABORT(ie,s,rc)
+#if defined( DM_PARALLEL ) 
+      implicit none
+      include 'mpif.h'
+      integer rc,ie,ierr
+      character*(*) s
+      if (ie.ne.0) then
+        print*,'GLOB_ABORT: '//s//' ie,rc:',ie,rc
+        if (rc.eq.0) RETURN
+        CALL MPI_ABORT(MPI_COMM_WORLD,rc,ierr)
+      end if
+#endif
+      RETURN
+      END
+!
+!***********************************************************************
+!
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Alarm.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Alarm.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Alarm.F90	(revision 17)
@@ -0,0 +1,963 @@
+!
+! 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 University of Illinois-NCSA license.
+!
+!==============================================================================
+!
+!     ESMF Alarm Module
+      module ESMF_AlarmMod
+!
+!==============================================================================
+!
+! This file contains the Alarm class definition and all Alarm class 
+! methods.
+!
+!------------------------------------------------------------------------------
+! INCLUDES
+#include <ESMF_TimeMgr.inc>
+
+!===============================================================================
+!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, PrevRingTime, &
+                               StopTime, Enabled, rc)
+
+! !ARGUMENTS:
+      type(ESMF_Alarm), intent(inout) :: alarm  ! really INTENT(OUT)
+      type(ESMF_Time), intent(in), optional :: RingTime, PrevRingTime
+      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( PrevRingTime ) ) THEN
+          alarm%alarmint%PrevRingTime = PrevRingTime
+        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(inout) :: alarm  ! really INTENT(OUT)
+      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(inout) :: alarm  ! really INTENT(OUT)
+      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(inout) :: alarm  ! really INTENT(OUT)
+      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(inout) :: alarm  ! really INTENT(OUT)
+      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
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_AlarmClock.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_AlarmClock.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_AlarmClock.F90	(revision 17)
@@ -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 University of Illinois-NCSA license.
+!
+!==============================================================================
+!
+!     ESMF Alarm-Clock Module
+      module ESMF_AlarmClockMod
+!
+!==============================================================================
+!
+! This file contains the AlarmCreate method.
+!
+!------------------------------------------------------------------------------
+! INCLUDES
+#include <ESMF_TimeMgr.inc>
+
+!===============================================================================
+!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
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Base.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Base.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Base.F90	(revision 17)
@@ -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 University of Illinois-NCSA license.
+!
+! 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
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_BaseTime.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_BaseTime.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_BaseTime.F90	(revision 17)
@@ -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 University of Illinois-NCSA license.
+!
+!==============================================================================
+!
+!     ESMF BaseTime Module
+      module ESMF_BaseTimeMod
+!
+!==============================================================================
+!
+! This file contains the BaseTime class definition and all BaseTime class
+! methods.
+!
+!------------------------------------------------------------------------------
+! INCLUDES
+
+#include <ESMF_TimeMgr.inc>
+!
+!===============================================================================
+!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
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Calendar.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Calendar.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Calendar.F90	(revision 17)
@@ -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 University of Illinois-NCSA license.
+!
+!==============================================================================
+!
+!     ESMF Calendar Module
+      module ESMF_CalendarMod
+!
+!==============================================================================
+!
+! This file contains the Calendar class definition and all Calendar class
+! methods.
+!
+!------------------------------------------------------------------------------
+! INCLUDES
+#include <ESMF_TimeMgr.inc>
+
+!==============================================================================
+!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
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Clock.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Clock.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Clock.F90	(revision 17)
@@ -0,0 +1,1350 @@
+!
+! 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 University of Illinois-NCSA license.
+!
+!==============================================================================
+!
+!     ESMF Clock Module
+      module ESMF_ClockMod
+!     
+!==============================================================================
+!     
+! This file contains the Clock class definition and all Clock class methods.
+!     
+!------------------------------------------------------------------------------
+! INCLUDES
+#include <ESMF_TimeMgr.inc> 
+
+!==============================================================================
+!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(inout) :: clock  ! really INTENT(OUT)
+      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(inout) :: clock  ! really INTENT(OUT)
+      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
+! write(0,*)'ESMF_ClockAddAlarm ',clock%clockint%NumAlarms
+        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 ) THEN
+                 alarm%alarmint%Ringing = .TRUE.
+                 alarm%alarmint%PrevRingTime = clock%clockint%CurrTime
+                 alarm%alarmint%RingTimeSet = .FALSE.  !it is a one time alarm, it rang, now let it resort to interval
+                 IF ( PRESENT( RingingAlarmList ) .AND. &
+                      PRESENT ( NumRingingAlarms ) ) THEN
+                   NumRingingAlarms = NumRingingAlarms + 1
+                   RingingAlarmList( NumRingingAlarms ) = alarm
+                 ENDIF
+              ELSE IF ( (.NOT. pred1) .AND. 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%RingTimeSet = .FALSE.  !it is a one time alarm, it rang, now let it resort to interval
+                   alarm%alarmint%Ringing = .TRUE.
+                   alarm%alarmint%PrevRingTime = clock%clockint%CurrTime
+                   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%RingTimeSet = .FALSE.  !it is a one time alarm, it rang, now let it resort to interval
+                   alarm%alarmint%Ringing = .TRUE.
+                   alarm%alarmint%PrevRingTime = clock%clockint%CurrTime
+                   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
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Fraction.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Fraction.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Fraction.F90	(revision 17)
@@ -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 University of Illinois-NCSA license.
+!
+! 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
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Macros.inc
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Macros.inc	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Macros.inc	(revision 17)
@@ -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 University of Illinois-NCSA license.
+
+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 
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Mod.F90	(revision 17)
@@ -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 <ESMF_TimeMgr.inc>
+   INTEGER, PARAMETER :: ESMF_MAX_ALARMS=MAX_ALARMS
+!
+END MODULE ESMF_Mod
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Stubs.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Stubs.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Stubs.F90	(revision 17)
@@ -0,0 +1,132 @@
+! 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 <mpif.h>
+#endif
+      LOGICAL :: flag
+      INTEGER :: ier
+
+      IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
+#if (defined SPMD) || (defined COUP_CSM)
+      CALL MPI_Finalized( flag, ier )
+      IF ( ier .ne. mpi_success )THEN
+        IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+      END IF
+      IF ( .NOT. flag ) THEN
+        CALL MPI_Finalize( ier ) 
+        IF ( ier .ne. mpi_success )THEN
+          IF ( PRESENT( rc ) ) rc = ESMF_FAILURE
+        END IF
+      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
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Time.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Time.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_Time.F90	(revision 17)
@@ -0,0 +1,1188 @@
+!
+! 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 University of Illinois-NCSA license.
+!
+!==============================================================================
+!
+!     ESMF Time Module
+      module ESMF_TimeMod
+!
+!==============================================================================
+!
+! This file contains the Time class definition and all Time class methods.
+!
+!------------------------------------------------------------------------------
+! INCLUDES
+#include <ESMF_TimeMgr.inc>
+
+!==============================================================================
+!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
+          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 ??
+#ifdef PLANET
+      write(TimeString,FMT="(I4.4,'-',I5.5,'_',I2.2,':',I2.2,':',I2.2)") &
+             year,dayofmonth,hour,minute,second
+#else
+      write(TimeString,FMT="(I4.4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2,':',I2.2)") &
+             year,month,dayofmonth,hour,minute,second
+#endif
+
+      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
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_TimeInterval.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_TimeInterval.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_TimeInterval.F90	(revision 17)
@@ -0,0 +1,1268 @@
+!
+! 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 University of Illinois-NCSA license.
+!
+!==============================================================================
+!
+!     ESMF TimeInterval Module
+      module ESMF_TimeIntervalMod
+!
+!==============================================================================
+!
+! This file contains the TimeInterval class definition and all TimeInterval
+! class methods.
+!
+!------------------------------------------------------------------------------
+! INCLUDES
+#include <ESMF_TimeMgr.inc>
+!
+!===============================================================================
+!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
+   !jm Month has no meaning for an interval; get rid of it, 20100319
+   !     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, S_i8, 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(ESMF_KIND_I8),  intent(out), optional :: S_i8
+      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
+!
+! Added argument to output double precision seconds, S_i8
+! William.Gustafson@pnl.gov; 9-May-2008
+!
+!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(S_i8) ) S_i8 = seconds
+      IF ( PRESENT( D ) ) THEN
+        D = seconds / SECONDS_PER_DAY
+        IF ( PRESENT(S) )    S    = MOD( seconds, SECONDS_PER_DAY )
+        IF ( PRESENT(S_i8) ) S_i8 = 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 )
+        IF ( PRESENT(S_i8) ) S_i8 = 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
+!jm      timeinterval%MM = 0
+!jm      IF ( PRESENT( MM ) ) THEN
+!jm        timeinterval%MM = MM
+!jm      ENDIF
+!jm      ! Rollover months to years
+!jm      IF      ( abs(timeinterval%MM) .GE. MONTHS_PER_YEAR ) THEN
+!jm        timeinterval%YR = timeinterval%YR + timeinterval%MM/MONTHS_PER_YEAR
+!jm        timeinterval%MM = mod(timeinterval%MM,MONTHS_PER_YEAR)
+!jm      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
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_TimeMgr.inc
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_TimeMgr.inc	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/ESMF_TimeMgr.inc	(revision 17)
@@ -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 University of Illinois-NCSA license.
+
+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 <ESMF_Macros.inc>
+
+#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 (2*(MAX_HISTORY)+10)
+
+! 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
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/Makefile	(revision 17)
@@ -0,0 +1,115 @@
+# 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
+FGREP = fgrep -iq
+
+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
+	if [ "$(AR)" != "lib.exe" ] ; then \
+          $(AR) ru libesmf_time.a $(OBJS) ; \
+        else \
+          $(AR) /out:libesmf_time.a $(OBJS) ; \
+        fi
+	$(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
+	@ if echo $(CPP) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F90 for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f > $*.f.tmp ; \
+          mv $*.f.tmp $*.f ; \
+        fi
+	$(FC) -o $@ -c $*.f
+
+.F90.f :
+	$(RM) $@
+	$(SED_FTN) $*.F90 > $*.b
+	$(CPP) -C -P -I. $*.b > $*.f
+	$(RM) $*.b
+	@ if echo $(CPP) | $(FGREP) 'DVAR4D'; then \
+          echo COMPILING $*.F90 for 4DVAR ; \
+          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f > $*.f.tmp ; \
+          mv $*.f.tmp $*.f ; \
+        fi
+
+.f.o :
+	$(RM) $@
+	$(RM) $*.b
+	$(FC) -c $*.f
+
+clean : testclean
+
+testclean: 
+	$(RM) *.b *.f *.o *.obj *.i 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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/Meat.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/Meat.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/Meat.F90	(revision 17)
@@ -0,0 +1,918 @@
+#include <ESMF_TimeMgr.inc>
+
+! 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 ) ) 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 defined MARS
+  num_diy = 669
+#elif defined TITAN
+  num_diy = 686
+#else
+  IF ( nfeb( year ) .EQ. 29 ) THEN
+    num_diy = 366
+  ELSE
+    num_diy = 365
+  ENDIF
+#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, only : months_per_year, mday, daym, mdaycum, monthbdys, &
+                               mdayleap, mdayleapcum, monthbdysleap, daymleap
+  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, only : mday
+IMPLICIT NONE
+      INTEGER, INTENT(IN)  :: YR,MM,DD   ! DD is day of month
+      INTEGER, INTENT(OUT) :: dayinyear
+      INTEGER i
+      integer nfeb
+
+#ifdef PLANET
+      dayinyear = DD
+#else
+      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
+#endif
+END SUBROUTINE compute_dayinyear
+
+
+
+SUBROUTINE timegetmonth( time, MM )
+  USE esmf_basemod
+  USE esmf_basetimemod
+  USE esmf_timemod
+  USE ESMF_CalendarMod, only : MONTHS_PER_YEAR, monthbdys, monthbdysleap
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(IN) :: time
+  INTEGER, INTENT(OUT) :: MM
+  ! locals
+  INTEGER :: nfeb
+  INTEGER :: i
+#if defined PLANET
+  MM = 0
+#else
+  MM = -1
+  IF ( nfeb(time%YR) == 29 ) THEN
+    DO i = 1,MONTHS_PER_YEAR
+      IF ( ( time%basetime >= monthbdysleap(i-1) ) .AND. ( time%basetime < monthbdysleap(i) ) ) THEN
+        MM = i
+        EXIT
+      ENDIF
+    ENDDO
+  ELSE
+    DO i = 1,MONTHS_PER_YEAR
+      IF ( ( time%basetime >= monthbdys(i-1) ) .AND. ( time%basetime < monthbdys(i) ) ) THEN
+        MM = i
+        EXIT
+      ENDIF
+    ENDDO
+  ENDIF
+#endif
+  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, only : monthbdys, monthbdysleap
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(IN) :: time
+  INTEGER, INTENT(OUT) :: DD
+  ! locals
+  INTEGER :: nfeb
+  INTEGER :: MM
+  TYPE(ESMF_BaseTime) :: tmpbasetime
+#if defined PLANET
+  tmpbasetime = time%basetime
+#else
+  CALL timegetmonth( time, MM )
+  IF ( nfeb(time%YR) == 29 ) THEN
+    tmpbasetime = time%basetime - monthbdysleap(MM-1)
+  ELSE
+    tmpbasetime = time%basetime - monthbdys(MM-1)
+  ENDIF
+#endif
+  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, only : MONTHS_PER_YEAR, monthbdys, monthbdysleap
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(INOUT) :: time
+  INTEGER, INTENT(IN) :: MM
+  INTEGER, INTENT(OUT) :: ierr
+  ! locals
+  INTEGER :: nfeb
+  ierr = ESMF_SUCCESS
+!  PRINT *,'DEBUG:  BEGIN timeaddmonths()'
+#if defined PLANET
+!  time%basetime = time%basetime
+#else
+  IF ( ( MM < 1 ) .OR. ( MM > MONTHS_PER_YEAR ) ) THEN
+    ierr = ESMF_FAILURE
+  ELSE
+    IF ( nfeb(time%YR) == 29 ) THEN
+      time%basetime = time%basetime + monthbdysleap(MM-1)
+    ELSE
+      time%basetime = time%basetime + monthbdys(MM-1)
+    ENDIF
+  ENDIF
+#endif
+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, only : mday, mdayleap
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(INOUT) :: time
+  ! locals
+  INTEGER :: nfeb
+  INTEGER :: MM
+#if defined PLANET
+!    time%basetime%S = time%basetime%S
+#else
+  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
+#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, only : mday, months_per_year, mdayleap
+  IMPLICIT NONE
+  TYPE(ESMF_Time), INTENT(INOUT) :: time
+  ! locals
+  INTEGER :: nfeb
+  INTEGER :: MM
+#if defined PLANET
+!    time%basetime%S = time%basetime%S
+#else
+  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
+#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
+#if 0
+!jm Month has no meaning for a timeinterval; removed 20100319
+#if defined PLANET
+  ! Do nothing...
+#else
+ DO m = 1, abs(timeinterval%MM)
+    IF ( timeinterval%MM > 0 ) THEN
+      CALL timeincmonth( timeOut )
+    ELSE
+      CALL timedecmonth( timeOut )
+    ENDIF
+  ENDDO
+#endif
+#endif
+  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
+#if 0
+!jm month has no meaning for an interval; removed 20100319
+#ifndef PLANET
+  neginterval%MM = -neginterval%MM
+#endif
+#endif
+  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),'|'
+   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),'|'
+   return
+END SUBROUTINE print_a_timeinterval
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/Test1.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/Test1.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/Test1.F90	(revision 17)
@@ -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:  <testname>" 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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/Test1.out.correct
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/Test1.out.correct	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/Test1.out.correct	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/module_symbols_util.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/module_symbols_util.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/module_symbols_util.F90	(revision 17)
@@ -0,0 +1,126 @@
+! 
+! NOTE:  This file will be removed once encapsulation of bare ESMF 
+!        calls is complete within WRF non-external source code.  
+!
+! NOTE:  This file was automatically generated by the findsymbol script 
+!        based on WRFV2_20050512_1410.  Recipe follows:  
+! 
+! 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_TIMEEQ => ESMF_TIMEEQ
+        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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/module_utility.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/module_utility.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/module_utility.F90	(revision 17)
@@ -0,0 +1,7 @@
+
+      MODULE module_utility
+
+        USE module_symbols_util
+
+      END MODULE module_utility
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/testall.csh
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/testall.csh	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/esmf_time_f90/testall.csh	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/77to90.csh
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/77to90.csh	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/77to90.csh	(revision 17)
@@ -0,0 +1,38 @@
+#!/bin/csh
+
+#	The NCAR CISL fftpack (version 5)
+#	convert files to f90
+
+
+cd fftpack5
+
+foreach f ( *.f )
+
+	set root = $f:r
+	
+	#	Get rid of those pesky tab characters
+
+	expand $f >! ${root}.F
+
+	#	The f77 to f90 converter wants files to
+	#	end with the .f extension.  
+
+	mv ${root}.F ${root}.f
+
+	echo "${root} /" >! input
+	../a.out < input
+
+	#	The converter makes a .f90 file, WRF expects
+	#	things to actually be .F extensioned.
+
+	mv ${root}.f90 ${root}.F
+
+	#	Zap the original f77 file.
+
+	rm ${root}.f
+	
+end
+
+rm input
+
+cd ..
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/README
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/README	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/README	(revision 17)
@@ -0,0 +1,45 @@
+Web site for convert.f90:
+ftp://ftp.numerical.rl.ac.uk/pub/MandR/convert.f90
+
+!     Copyright CERN, Geneva 1991, 1997 - Copyright and any other
+!     appropriate legal protection of these computer programs
+!     and associated documentation reserved in all countries
+!     of the world.
+!     Author: Michael Metcalf  (MichaelMetcalf@compuserve.com)
+
+======================================================
+
+Web site for fftpack5:
+http://www.cisl.ucar.edu/css/software/fftpack5/
+
+FFTPACK is a Fortran subroutine library of Fast Fourier Transforms (FFT's) 
+developed at the National Center for Atmospheric Research. Version 5 of the 
+library was written by Paul Swarztrauber and Richard Valent in the mid 
+1990's. This release of FFTPACK includes single and multiple instance 
+complex-to-complex and real-to-real transforms, two-dimensional complex-
+to-complex and real-to-complex transforms, and a collection of sine and 
+cosine transforms.  
+
+References
+
+(1) Vectorizing the Fast Fourier Transforms, by Paul Swarztrauber, 
+    Parallel Computations, G. Rodrigue, ed., Academic Press, New York 1982.
+
+(2) Fast Fourier Transforms Algorithms for Vector Computers, by Paul 
+    Swarztrauber, Parallel Computing, (1984) pp.45-63.
+
+(3) Symmetric FFTs, by P. N. Swarztrauber, Mathematics of Computation 47(1986), 
+    pp. 323-346.
+
+==========
+
+The WRF usage of the fftpack5 package is for filtering high-latitude
+data for usage in the global implementation.  The files have been 
+moved from little .f files to big .F files (to adopt the WRF convention).
+Additionally, the Makefile has been modified to accomodate this small
+naming change for the default suffix.  
+
+The fftpack source has been changed by the convert.f90 program, turning
+the code into free-format.  The only other modification is that the
+imbedded tabs in the source have been turned into spaces (otherwise
+convert.f90 coughs up a spleen).
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/convert.f90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/convert.f90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/convert.f90	(revision 17)
@@ -0,0 +1,1710 @@
+!     ftp://ftp.numerical.rl.ac.uk/pub/MandR/convert.f90
+!
+!     Copyright CERN, Geneva 1991, 1997 - Copyright and any other
+!     appropriate legal protection of these computer programs
+!     and associated documentation reserved in all countries
+!     of the world.
+!     Author: Michael Metcalf  (MichaelMetcalf@compuserve.com)
+!
+!     Requires the option -qcharlen=14400 with IBM's xlf.
+!
+!     Version 1.5. Differs from previous versions in that:
+!      (19/12/96)
+!                  Code modified to be Fortran 95 and ELF
+!                  compatible (no functional changes).
+!
+!***********************************************************************
+!                                                                      *
+!                                                                      *
+!    A program to convert FORTRAN 77 source form to Fortran 90 source  *
+!  form. It also formats the code by indenting the bodies of DO-loops  *
+!  and IF-blocks by ISHIFT columns. Statement keywords are             *
+!  followed if necessary by a blank, and blanks within tokens are      *
+!  are suppressed; this handling of blanks is optional.                *
+!    If a CONTINUE statement terminates a single DO loop, it is        *
+!  replaced by END DO.                                                 *
+!    Procedure END statements have the procedure name added, if        *
+!  blanks are handled.                                                 *
+!    Statements like INTEGER*2 are converted to INTEGER(2), if blanks  *
+!  are handled. Depending on the target processor, a further global    *
+!  edit might be required (e.g. where 2 bytes correspond to KIND=1).   *
+!  Typed functions and assumed-length character specifications are     *
+!  treated similarly. The length specification *4 is removed for all   *
+!  data types except CHARACTER, as is *8 for COMPLEX. This             *
+!  treatment of non-standard type declarations includes any            *
+!  non-standard IMPLICIT statements.                                   *
+!    Optionally, interface blocks only may be produced; this requires  *
+!  blanks processing to be requested. The interface blocks are         *
+!  compatible with both the old and new source forms.                  *
+!                                                                      *
+!    Usage: the program reads one data record in free format from the  *
+!          default input unit. This contains:                          *
+!                                                                      *
+!                        name of file                                  *
+!                        indentation depth                             *
+!                        maximum indentation level                     *
+!                        whether significant blanks should be handled  *
+!                        whether interface blocks only are required    *
+!                                                                      *
+!   The default values in the absence of this record are:              *
+!                               name 3 10 T F                          *
+!   To do nothing but change the source form of a file prog.f type     *
+!                               prog 0  0 F F                          *
+!       or simply                                                      *
+!                               prog /                                 *
+!   For more extensive processing type, say,                           *
+!                               prog 3 10 t f                          *
+!   and for interface blocks only type                                 *
+!                               prog 0 0 t t                           *
+!   The input is read from prog.f, the output is written to prog.f90;  *
+!   there should be no tabs in the input.                              *
+!                                                                      *
+!   Restrictions:  The program does not indent FORMAT statements or    *
+!                any statement containing a character string with an   *
+!                embedded multiple blank.                              *
+!                  The order of comment lines and Fortran statements   *
+!                is slightly modified if there are sequences of        *
+!                more than KKLIM (=200) comment lines.                 *
+!                  If there are syntax errors, continued lines do not  *
+!                have a trailing &.                                    *
+!                  When producing interface blocks, a check is required*
+!                that any dummy argument that is a procedure has a     *
+!                corresponding EXTERNAL statement. Also, since no      *
+!                COMMON blocks or PARAMETER statements are copied,     *
+!                part of an assumed-size array declaration may be      *
+!                missing. Similarly, parts of an assumed-length        *
+!                character symbolic constant might be copied and have  *
+!                to be deleted. BLOCK DATA statements are copied and   *
+!                must be deleted. These problems would normally be     *
+!                detected by a compiler and are trivially corrected.   *
+!                  Within a given keyword, the case must be all upper  *
+!                or all lower, and lower case programs require         *
+!                blank handling for correct indenting.                 *
+!                                                                      *
+!***********************************************************************
+!
+   MODULE STRUCTURE
+!
+!***********************************************************************
+!   Define maximum level of DO-loop nesting, and maximum length of     *
+!   a Fortran statement. LEN may be reduced for                        *
+!   compilers accepting a maximum character                            *
+!   length below 2640 and this will cause any excess                   *
+!   continuation lines and all following lines to be copied unchanged. *
+!   KKLIM defines the length of the comment line buffer. If this       *
+!   length is exceeded, the statement preceding the comments will      *
+!   appear after them.                                                 *
+!***********************************************************************
+      implicit none
+      public
+      INTEGER, PARAMETER :: NEST = 32 , LEN = 2640 , KKLIM = 200,      &
+      KLEN = 72*KKLIM
+!
+      INTEGER :: KNTDO , KNTIF , KNTCOM , LABEL , LENST , LABLNO, NOARG
+      INTEGER, DIMENSION(NEST) :: LABLDO
+!
+      LOGICAL :: SYNERR, BLNKFL, INTFL
+!
+      CHARACTER(LEN=LEN) :: STAMNT
+      CHARACTER(LEN=KLEN):: CBUF
+      CHARACTER(LEN=42)  :: NAME
+!
+   END MODULE STRUCTURE
+   MODULE DATA
+   implicit none
+   public
+!
+      INTEGER, SAVE :: ISHIFT , MXDPTH , NIN , NOUT, TIME0
+      LOGICAL, SAVE :: BLANKS, INTBFL
+!
+   END MODULE DATA
+   MODULE STATISTICS
+   implicit none
+   public
+!
+      INTEGER, SAVE :: MXDO , MXIF , KARD , KNTPU
+!
+      LOGICAL, SAVE :: SYNTAX, OVFLW, NONSTD
+!
+   END MODULE STATISTICS
+   MODULE ALL_PROCEDURES
+   private
+   public :: start, program_units, terminate
+   CONTAINS
+!***********************************************************************
+   SUBROUTINE ARGUMENT(ARGNAM, LENARG, STAMNT, LENST, NOARG)
+   implicit none
+!
+!   To store the argument names and function name, if any, for later
+!   use in checking whether a specification statement is relevant to an
+!   interface block.
+      CHARACTER(LEN=*), INTENT(IN OUT), dimension(:) :: ARGNAM
+      CHARACTER(LEN=*), INTENT(IN)         :: STAMNT
+      INTEGER, INTENT(OUT), dimension(:)   :: LENARG
+      INTEGER, INTENT(IN OUT) :: NOARG
+      INTEGER, INTENT(IN)    :: LENST
+!
+      integer :: ind1, ind2, newind
+!
+!   Correct length of function name
+      IF (NOARG == 1) LENARG(1) = LEN_TRIM(ARGNAM(1))
+!
+!   Get any other arguments
+      IND1 = index(STAMNT(:LENST), '(') + 1
+      IF (IND1  /=  1 .AND. STAMNT(IND1:IND1)  /=  ')') THEN
+         NEWIND = index(STAMNT(IND1+1:LENST), '(')
+         IF (NEWIND /= 0) IND1 = NEWIND + 1 + IND1
+    3    IND2 = index(STAMNT(IND1:LENST), ',') - 1
+         IF (IND2  ==  -1) IND2 = index(STAMNT(IND1:LENST), ')') - 1
+         IND2 = IND2 + IND1 - 1
+         IF (STAMNT(IND1+1:IND1+1)  /=  '*' ) THEN
+            NOARG = NOARG +1
+            ARGNAM(NOARG) = STAMNT(IND1:IND2)
+            LENARG(NOARG) = IND2 - IND1 +1
+         END IF
+            IF (STAMNT(IND2+1:IND2+1)  ==  ')') GO TO 4
+         IND1 = IND2 + 3
+         GO TO 3
+      END IF
+    4 LENARG(:NOARG) = MIN(LENARG(:NOARG), 6)
+!
+   RETURN
+   END SUBROUTINE ARGUMENT
+   SUBROUTINE BLANK( )
+!
+!   To suppress all blanks in the statement, and then to place
+!   a blank on each side of =,  +, -, * and / (but not ** or //), a
+!   blank after each ) and , and a blank before each (.
+!   No changes are made within character strings or FORMAT statememts.
+!
+      USE DATA
+!
+      USE STATISTICS
+!
+      USE STRUCTURE
+   implicit none
+!
+      CHARACTER(LEN=LEN) :: BUFFER
+      integer :: l1, l2, lchar, napost, lenold
+!
+!   Reduce length to that of significant characters
+      BLNKFL = .FALSE.
+      LENST = LEN_TRIM(STAMNT(1:LENST))
+      IF (.NOT.BLANKS) THEN
+         IF (LEN-LENST >= 2) STAMNT(LENST+1:LENST+2) = '  '
+         LENST = MIN(LENST+2, LEN)
+         GO TO 99
+      END IF
+      BLNKFL = .TRUE.
+!
+!   Suppress blanks (add 2 to catch
+!   odd number of apostrophes on a line in REFORM).
+      LCHAR = 0
+      NAPOST = 0
+      DO L1 = 1, LENST
+         IF (STAMNT(L1:L1)  ==  "'") NAPOST = 1-NAPOST
+         IF (NAPOST == 0 .AND. STAMNT(L1:L1)  ==  ' ') CYCLE
+         LCHAR = LCHAR+1
+         BUFFER(LCHAR:LCHAR) = STAMNT(L1:L1)
+      END DO
+      IF (LEN-LCHAR >= 2) BUFFER(LCHAR+1:LCHAR+2) = '  '
+      LCHAR = MIN(LCHAR+2, LEN)
+!
+!   Eliminate FORMATS
+       IF( LABEL  /=  0 .AND.                                          &
+     & LCHAR  >=  11 .AND.(BUFFER(:7)  ==  'FORMAT(' .OR.              &
+     &                     BUFFER(:7)  ==  'format(') .AND.            &
+     & BUFFER(LCHAR-2:LCHAR-2)  ==  ')') THEN
+         IF (LEN-LENST >= 2) STAMNT(LENST+1:LENST+2) = '  '
+         LENST = MIN(LENST+2, LEN)
+         GO TO 99
+       END IF
+!
+!   Insert blanks
+      LENOLD = LENST
+      LENST = 0
+      NAPOST = 0
+      DO L2 = 1, LCHAR
+!
+!   Check size of statement
+         IF(LENST+3 > LEN) THEN
+            LENST = LCHAR
+            STAMNT(:LENST) = BUFFER(:LENST)
+            OVFLW = .TRUE.
+            GO TO 99
+         END IF
+!
+!   Whether inside character string
+         IF (BUFFER(L2:L2)  ==  "'") NAPOST = 1-NAPOST
+         IF (NAPOST == 1) GO TO 3
+!
+!   Add blank padding according to character
+         SELECT CASE (BUFFER(L2:L2))
+         CASE ( ')' )
+            STAMNT(LENST+1:LENST+2) = ') '
+            LENST = LENST+2
+         CASE ( '(' )
+            STAMNT(LENST+1:LENST+2) = ' ('
+            LENST = LENST + 2
+         CASE ( ',' )
+            STAMNT(LENST+1:LENST+2) = ', '
+            LENST = LENST + 2
+         CASE ( '=' )
+            STAMNT(LENST+1:LENST+3) = ' = '
+            LENST = LENST + 3
+         CASE ( '*' )
+            IF (BUFFER(L2-1:L2-1)  /=  '*' .AND. BUFFER(L2+1:L2+1)     &
+             /=  '*') THEN
+               STAMNT(LENST+1:LENST+3) = ' * '
+               LENST = LENST + 3
+            ELSE
+               GO TO 3
+            END IF
+         CASE ( '/' )
+            IF (BUFFER(L2-1:L2-1)  /=  '/' .AND. BUFFER(L2+1:L2+1)     &
+             /=  '/') THEN
+               STAMNT(LENST+1:LENST+3) = ' / '
+               LENST = LENST + 3
+            ELSE
+               GO TO 3
+            END IF
+         CASE ('+')
+            IF (BUFFER(L2-1:L2-1)  /=  'E' .AND.                       &
+                BUFFER(L2-1:L2-1)  /=  'e' .AND.                       &
+                BUFFER(L2-1:L2-1)  /=  'D' .AND.                       &
+                BUFFER(L2-1:L2-1)  /=  'd' .OR.                        &
+          LLT(BUFFER(L2+1:L2+1), '0') .AND. LGT(BUFFER(L2+1:L2+1), '9')&
+               ) THEN
+               STAMNT(LENST+1:LENST+3) = ' + '
+               LENST = LENST + 3
+            ELSE
+               GO TO 3
+            END IF
+         CASE ('-')
+            IF (BUFFER(L2-1:L2-1)  /=  'E' .AND.                       &
+                BUFFER(L2-1:L2-1)  /=  'e' .AND.                       &
+                BUFFER(L2-1:L2-1)  /=  'D' .AND.                       &
+                BUFFER(L2-1:L2-1)  /=  'd' .OR.                        &
+          LLT(BUFFER(L2+1:L2+1), '0') .AND. LGT(BUFFER(L2+1:L2+1), '9')&
+               ) THEN
+               STAMNT(LENST+1:LENST+3) = ' - '
+               LENST = LENST + 3
+            ELSE
+               GO TO 3
+            END IF
+         CASE DEFAULT
+            GO TO 3
+         END SELECT
+         CYCLE
+    3    STAMNT(LENST+1:LENST+1) = BUFFER(L2:L2)
+         LENST = LENST +1
+      END DO
+!
+!   Blank out end of statement
+      IF (LENOLD > LENST) STAMNT(LENST+1:LENOLD) = ' '
+      IF (LENST < LEN .AND. MOD(LENST, 66) /= 0)                       &
+          STAMNT(LENST+1: LENST+66-MOD(LENST, 66)) = ' '
+!
+99 RETURN
+   END SUBROUTINE BLANK
+   SUBROUTINE IDENTIFY (IRET)
+!
+!***********************************************************************
+!   To identify statement as beginning or end of DO-loop or            *
+!   IF-block, or as probable FORMAT.                                   *
+!   Attempt to scan as few of the input characters as possible.        *
+!***********************************************************************
+!
+      USE STRUCTURE
+      USE DATA
+   implicit none
+!
+      CHARACTER(LEN=5), PARAMETER :: ENDIF='ENDIF' , THEN='NEHT)',     &
+                                     THENLC='neht)'
+      CHARACTER(LEN=3), PARAMETER :: BIF='IF('
+      CHARACTER(LEN=2), PARAMETER :: DO='DO'
+      CHARACTER(LEN=7), PARAMETER :: FORMAT='FORMAT('
+      CHARACTER(LEN=4), PARAMETER :: ELSE='ELSE'
+      CHARACTER(LEN=5)            :: INTFIL
+      INTEGER, INTENT(OUT)        :: IRET
+!
+      integer :: l1, l2, l3, l4, l5, l6, l7, l8, l9, l10, l11, l12,    &
+                 k1, k2, k3, k5, k6, k7, k8, lparen, kntch, napos
+!
+      IRET = 0
+!
+!   Check whether end of DO-loop
+      IF (KNTDO /= 0) THEN
+         IF (LABEL == LABLDO(KNTDO)) THEN
+            IRET = 2
+            GO TO 99
+         END IF
+      END IF
+!
+!   Check whether any of remaining possibilities
+      DO L7 = 1 , LENST
+         IF (STAMNT(L7:L7) == ' ') CYCLE
+         IF (STAMNT(L7:L7) == 'E') THEN
+            DO L11 = L7+1 , LENST
+               IF (STAMNT(L11:L11) == ' ') CYCLE
+               IF (STAMNT(L11:L11) == ENDIF(2:2)) GO TO 6
+               IF (STAMNT(L11:L11) == ELSE(2:2)) GO TO 3
+               GO TO 99
+            END DO
+         END IF
+         IF (STAMNT(L7:L7) == BIF(:1)) GO TO 9
+         IF (STAMNT(L7:L7) == DO(:1)) GO TO 15
+         IF (STAMNT(L7:L7) == FORMAT(:1)) GO TO 31
+         GO TO 99
+      END DO
+      GO TO  99
+!
+!   Check whether ELSE or ELSEIF
+    3 K8 = 3
+      DO L12 = L11+1 , LENST
+         IF (STAMNT(L12:L12) == ' ') CYCLE
+         IF (STAMNT(L12:L12) /= ELSE(K8:K8)) GO TO 99
+         IF (K8 == 4) GO TO 5
+         K8 = K8+1
+      END DO
+      GO TO  99
+    5 IF (L12 >= LENST) THEN
+         IRET = 6
+         GO TO 99
+      END IF
+      IF (STAMNT(L12+1:LENST) == ' ') THEN
+         IRET = 6
+         GO TO 99
+      END IF
+      K2 = 1
+      IRET = 6
+      L7 = L12
+      GO TO  10
+!
+!   Check whether end of IF-block
+    6 K1 = 3
+      DO L1 = L11+1 , LENST
+         IF (STAMNT(L1:L1) == ' ') CYCLE
+         IF (STAMNT(L1:L1) /= ENDIF(K1:K1)) GO TO 99
+         IF (K1 == 5) EXIT
+         K1 = K1+1
+      END DO
+      IF (L1 >= LENST) THEN
+         IRET = 4
+         GO TO 99
+      END IF
+      IF (STAMNT(L1+1:LENST) == ' ') IRET = 4
+      GO TO  99
+!
+!   Check whether beginning of IF-block
+    9 K2 = 2
+      IRET = 3
+   10 DO L2 = L7+1 , LENST
+         IF (STAMNT(L2:L2) == ' ') CYCLE
+         IF (STAMNT(L2:L2) /= BIF(K2:K2)) THEN
+            IRET = 0
+            GO TO 99
+         END IF
+         IF (K2 == 3) GO TO 12
+         K2 = K2+1
+      END DO
+      IRET = 0
+      GO TO  99
+!
+!   Backward search for )THEN at end of IF statement (to save
+!   scanning the condition).
+   12 K3 = 1
+      DO L3 = LENST , L2+1 , -1
+         IF (STAMNT(L3:L3) == ' ') CYCLE
+         IF (STAMNT(L3:L3) /= THEN(K3:K3) .AND.                        &
+             STAMNT(L3:L3) /= THENLC(K3:K3)) THEN
+            IRET = 0
+            GO TO 99
+         END IF
+         IF (K3 == 5) GO TO 99
+         K3 = K3+1
+      END DO
+      IRET = 0
+      GO TO  99
+!
+!   Check whether beginning of DO-loop
+   15 DO L4 = L7+1 , LENST
+         IF (STAMNT(L4:L4) == ' ') CYCLE
+         IF (STAMNT(L4:L4) == DO(2:2)) GO TO 17
+         GO TO 99
+      END DO
+      GO TO  99
+!
+!   Have DO - check label
+   17 K5 = 0
+      INTFIL = ' '
+      DO L5 = L4+1 , LENST
+         IF (STAMNT(L5:L5) == ' ') CYCLE
+         IF (LLT(STAMNT(L5:L5) , '0') .OR. LGT(STAMNT(L5:L5) , '9'))   &
+         EXIT
+         K5 = K5+1
+         IF (K5 > 5) GO TO 20
+         INTFIL(K5:K5) = STAMNT(L5:L5)
+      END DO
+      IF (K5 == 0) GO TO 99
+   20 READ (INTFIL , '(BN , I5)') LABLNO
+      IF (LABLNO == 0) GO TO 99
+!
+!   Have label - check comma
+      DO L8 = L5, LENST
+         IF (STAMNT(L8:L8) == ' ') CYCLE
+         IF (STAMNT(L8:L8) == ',') EXIT
+         GO TO 23
+      END DO
+      IRET = 1
+      GO TO  99
+!
+!   Have a DO and label with no comma.
+!   Check for variable whose first of maximum of six
+!   characters is alphabetic, followed by an equals sign,
+!   followed by a character string containing a comma which is
+!   not enclosed in parentheses.
+   23 K6 = 0
+      DO L9 = L8 , LENST
+         IF (STAMNT(L9:L9) == ' ') CYCLE
+         IF (K6 == 0) THEN
+            IF ((LLT(STAMNT(L9:L9), 'A') .OR. LGT(STAMNT(L9:L9), 'Z')) &
+           .AND.(LLT(STAMNT(L9:L9), 'a') .OR. LGT(STAMNT(L9:L9), 'z')))&
+            GO TO 99
+            K6 = 1
+         ELSE IF (LGE(STAMNT(L9:L9) , 'A') .AND. LLE(STAMNT(L9:L9),'Z')&
+            .OR. LGE(STAMNT(L9:L9) , 'a') .AND. LLE(STAMNT(L9:L9) ,'z')&
+         .OR. LGE(STAMNT(L9:L9) , '0') .AND. LLE(STAMNT(L9:L9) , '9')) &
+         THEN
+            K6 = K6+1
+            IF (K6 == 6) GO TO 26
+         ELSE
+            IF (K6 == 0) GO TO 99
+            GO TO 25
+         END IF
+      END DO
+      GO TO  99
+!
+!   Expect an equals sign
+   25 L9=L9-1
+   26 DO L10 = L9+1 , LENST
+         IF (STAMNT(L10:L10) == ' ') CYCLE
+         IF (STAMNT(L10:L10) == '=') GO TO 28
+         GO TO 99
+      END DO
+      GO TO  99
+!
+!   Search for bare comma
+   28 LPAREN = 0
+      KNTCH = 0
+      NAPOS = 0
+      DO L6 = L10+1 , LENST
+         IF (STAMNT(L6:L6) == ' ') CYCLE
+         IF (STAMNT(L6:L6) == "'") NAPOS = 1 - NAPOS
+         IF (NAPOS == 1) CYCLE
+         IF (STAMNT(L6:L6) == ',') THEN
+            IF (KNTCH /= 0) THEN
+               IF (LPAREN == 0) GO TO 30
+               CYCLE
+            ELSE
+               GO TO 99
+            END IF
+         ELSE IF (STAMNT(L6:L6) == '(') THEN
+            LPAREN = LPAREN+1
+         ELSE IF (STAMNT(L6:L6) == ')') THEN
+            LPAREN = LPAREN-1
+         END IF
+         KNTCH = 1
+      END DO
+      GO TO  99
+   30 IRET = 1
+!
+!   Insert blank after label
+      IF (.NOT.BLANKS .OR. LENST >= LEN) GO TO 99
+      DO L10 = LENST, L5, -1
+         STAMNT(L10+1:L10+1) = STAMNT(L10:L10)
+      END DO
+      STAMNT(L5:L5) = ' '
+      LENST = LENST  + 1
+      GO TO  99
+!
+!   Identify FORMAT statement
+   31 IF (LABEL == 0) GO TO 99
+      K7 = 2
+      DO L11 = L7+1 , LENST
+         IF (STAMNT(L11:L11) == ' ') CYCLE
+         IF (STAMNT(L11:L11) /= FORMAT(K7:K7)) GO TO 99
+         IF (K7 == 7) GO TO 33
+         K7 = K7+1
+      END DO
+      GO TO  99
+   33 IRET = 5
+!
+99 RETURN
+   END SUBROUTINE IDENTIFY
+   SUBROUTINE KEYWORD(ASSIGN, SKIP)
+!
+!   To check whether those initial keywords of the statement which
+!   require it are followed by a blank, to add one if necessary, and
+!   to suppress any embedded blanks.
+!
+      USE STATISTICS
+!
+      USE STRUCTURE
+   implicit none
+!
+      LOGICAL, INTENT(OUT) :: ASSIGN, SKIP
+!
+      INTEGER, PARAMETER    :: NKEY = 42, MAXLEN = 15
+      CHARACTER(LEN=MAXLEN) :: BEGIN
+      CHARACTER(LEN=LEN)    :: BUFFER
+      CHARACTER(LEN=3)      :: THREE
+      CHARACTER(LEN=32)     :: NAMEOF
+      CHARACTER(LEN=6), SAVE :: ARGNAM(445)
+      LOGICAL               :: IFASS
+      INTEGER, SAVE         :: LENARG(445)
+!
+      CHARACTER(LEN=MAXLEN), PARAMETER, dimension(nkey) :: KEYS = (/   &
+      'ASSIGN         ', 'BACKSPACE      ', 'BLOCKDATA      ',         &
+      'CALL           ', 'CHARACTER      ', 'CLOSE          ',         &
+      'COMMON         ', 'COMPLEX        ', 'CONTINUE       ',         &
+      'DATA           ', 'DIMENSION      ', 'DOUBLEPRECISION',         &
+      'DO             ', 'ELSEIF         ', 'ELSE           ',         &
+      'ENDFILE        ', 'ENDIF          ', 'ENTRY          ',         &
+      'EXTERNAL       ', 'EQUIVALENCE    ', 'FORMAT         ',         &
+      'FUNCTION       ', 'GOTO           ', 'IF             ',         &
+      'IMPLICIT       ', 'INQUIRE        ', 'INTEGER        ',         &
+      'INTRINSIC      ', 'LOGICAL        ', 'OPEN           ',         &
+      'PARAMETER      ', 'PAUSE          ', 'PRINT          ',         &
+      'PROGRAM        ', 'READ           ', 'REAL           ',         &
+      'RETURN         ', 'REWIND         ', 'SAVE           ',         &
+      'STOP           ', 'SUBROUTINE     ', 'WRITE          '/)
+      INTEGER, PARAMETER, dimension(nkey) :: LK =                      &
+            (/6, 9, 9, 4,                                              &
+              9, 5, 6, 7, 8, 4,                                        &
+              9,15, 2, 6, 4,                                           &
+              7, 5, 5, 8,11,                                           &
+              6, 8, 4, 2, 8, 7,                                        &
+              7, 9, 7, 4, 9,                                           &
+              5, 5, 7, 4, 4, 6,                                        &
+              6, 4, 4,10, 5    /)
+      LOGICAL, PARAMETER, dimension(nkey) :: BLANK =                   &
+               (/.TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,                    &
+                 .TRUE.,  .FALSE., .TRUE.,  .TRUE.,  .FALSE., .TRUE.,  &
+                 .TRUE.,  .TRUE.,  .TRUE.,  .FALSE., .FALSE.,          &
+                 .TRUE.,  .FALSE., .TRUE.,  .TRUE.,  .FALSE.,          &
+                 .FALSE., .TRUE.,  .TRUE.,  .FALSE., .TRUE.,  .FALSE., &
+                 .TRUE.,  .TRUE.,  .TRUE.,  .FALSE., .TRUE.,           &
+                 .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  &
+                 .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  .FALSE./)
+      LOGICAL, PARAMETER, dimension(nkey) :: FOLLOW =                  &
+               (/.TRUE.,  .TRUE.,  .FALSE., .TRUE.,                    &
+                 .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., &
+                 .FALSE., .FALSE., .FALSE., .FALSE., .FALSE.,          &
+                 .TRUE.,  .FALSE., .FALSE., .FALSE., .FALSE.,          &
+                 .FALSE., .FALSE., .TRUE.,  .FALSE., .FALSE., .FALSE., &
+                 .FALSE., .FALSE., .FALSE., .FALSE., .FALSE.,          &
+                 .TRUE.,  .TRUE.,  .FALSE., .TRUE.,  .FALSE., .TRUE.,  &
+                 .TRUE.,  .FALSE., .TRUE.,  .FALSE., .FALSE./)
+!
+      CHARACTER(LEN=MAXLEN), PARAMETER, dimension(nkey) :: KEYSLC = (/ &
+      'assign         ', 'backspace      ', 'blockdata      ',         &
+      'call           ', 'character      ', 'close          ',         &
+      'common         ', 'complex        ', 'continue       ',         &
+      'data           ', 'dimension      ', 'doubleprecision',         &
+      'do             ', 'elseif         ', 'else           ',         &
+      'endfile        ', 'endif          ', 'entry          ',         &
+      'external       ', 'equivalence    ', 'format         ',         &
+      'function       ', 'goto           ', 'if             ',         &
+      'implicit       ', 'inquire        ', 'integer        ',         &
+      'intrinsic      ', 'logical        ', 'open           ',         &
+      'parameter      ', 'pause          ', 'print          ',         &
+      'program        ', 'read           ', 'real           ',         &
+      'return         ', 'rewind         ', 'save           ',         &
+      'stop           ', 'subroutine     ', 'write          '/)
+!
+      integer :: l1, l2, l3, l4, l5, l6, l7, l20, lparen, kntap, kntch,&
+                 lc, lcc, l33, next, l8, napos, lsave, name_length
+!
+!   Test for statement function statement or assignment statement
+      SKIP = INTFL
+      ASSIGN = .FALSE.
+      IFASS = .FALSE.
+      THREE = ' '
+      LPAREN = 0
+      KNTAP = 0
+      KNTCH = 0
+      DO L1 = 1, LENST
+         IF (STAMNT(L1:L1)==' ') CYCLE
+         IF (STAMNT(L1:L1)=='=') THEN
+            IF (KNTCH==0) SYNERR = .TRUE.
+            IF (LPAREN==0 .AND. KNTAP==0) THEN
+               ASSIGN = .TRUE.
+               GO TO 9
+            ELSE
+               EXIT
+            END IF
+         ELSE IF (STAMNT(L1:L1)=='(') THEN
+            LPAREN = LPAREN+1
+         ELSE IF (STAMNT(L1:L1)==')') THEN
+            LPAREN = LPAREN-1
+         ELSE IF (STAMNT(L1:L1)=="'") THEN
+            KNTAP = 1-KNTAP
+         END IF
+         KNTCH = KNTCH+1
+         IF (KNTCH<=3) THREE(KNTCH:KNTCH) = STAMNT(L1:L1)
+      END DO
+!
+!   Suppress blanks in first 15 non-blank characters
+   10 BEGIN = ' '
+      LC = 0
+      DO L2 = 1, LENST
+         IF (STAMNT(L2:L2)==' ') CYCLE
+         LC = LC+1
+         BEGIN(LC:LC) = STAMNT(L2:L2)
+         IF (LC==MAXLEN) GO TO 3
+      END DO
+      L2 = L2-1
+!
+!   Is this a keyword? Failure of this test is not fatal, in order to
+!   allow for non-standard syntax extensions.
+    3 DO L3 = 1, NKEY
+         IF     (BEGIN(:LK(L3)) == KEYS(L3)(:LK(L3))) THEN
+            GO TO 5
+         ELSE IF (BEGIN(:LK(L3)) == KEYSLC(L3)(:LK(L3))) THEN
+            LCC = 0
+            DO  L33 = 1, L2
+               IF (STAMNT(L33:L33) == ' ') CYCLE
+               LCC = LCC + 1
+               IF (LCC == LK(L3)) EXIT
+            END DO
+            STAMNT(:L33) = KEYS(L3)(:LK(L3))
+            GO TO 5
+         END IF
+      END DO
+      NONSTD = .TRUE.
+      GO TO  98
+!
+!   Test for embedded blanks in keyword
+    5 IF (L2 /= LC) THEN
+         LC = 0
+         DO L4 =1, LENST
+            IF (STAMNT(L4:L4)==' ') CYCLE
+            LC = LC+1
+            IF (LC==LK(L3)) GO TO 7
+         END DO
+         GO TO 8
+    7    IF (L4==LC) GO TO 8
+         STAMNT(:L4) = KEYS(L3)(:LC)
+         GO TO 99
+      END IF
+!
+!   Keyword has no blanks - is it followed by a blank if it needs one?
+    8 IF (.NOT.BLANK(L3)) GO TO 99
+      NEXT = 0
+      DO L8 = 1, LK(L3)
+   17    NEXT = NEXT+1
+         IF (STAMNT(NEXT:NEXT)==' ') GO TO 17
+      END DO
+      NEXT = NEXT+1
+      IF (STAMNT(NEXT:NEXT)==' ') GO TO 99
+!
+!   Sometimes a delimiter may be present
+      IF (L3==2.OR.L3==16.OR.L3==23.OR.L3==35.OR.L3==38) THEN
+         IF (STAMNT(NEXT:NEXT)=='(') GO TO 99
+      ELSE IF (L3==5) THEN
+         IF (STAMNT(NEXT:NEXT)=='*') GO TO 99
+      ELSE IF (L3==7.OR.L3==39) THEN
+         IF (STAMNT(NEXT:NEXT)=='/') GO TO 99
+      END IF
+      IF (LENST==LEN) THEN
+         OVFLW = .TRUE.
+         GO TO 99
+      END IF
+!
+!   Insert the blank
+      BUFFER(NEXT:LENST) = STAMNT(NEXT:LENST)
+      LENST = LENST+1
+      STAMNT(NEXT:NEXT) = ' '
+      STAMNT(NEXT+1:LENST) = BUFFER(NEXT:LENST-1)
+      BLNKFL = .TRUE.
+      GO TO  99
+!
+!   Check whether, in fact, a DO-loop
+    9 IF (THREE(:2) /= 'DO' .AND. THREE(:2) /= 'do') GO TO 12
+      LPAREN = 0
+      NAPOS = 0
+      DO L5 = L1+2, LENST
+         IF (STAMNT(L5:L5)==' ') CYCLE
+         IF (STAMNT(L5:L5) == "'") NAPOS = 1 - NAPOS
+         IF (NAPOS == 1) CYCLE
+         IF (STAMNT(L5:L5)==',') THEN
+            IF (LPAREN==0) THEN
+               ASSIGN = .FALSE.
+               GO TO 10
+            END IF
+         ELSE IF (STAMNT(L5:L5)=='(') THEN
+            LPAREN = LPAREN+1
+         ELSE IF (STAMNT(L5:L5)==')') THEN
+            LPAREN = LPAREN-1
+         END IF
+      END DO
+      GO TO  99
+!
+!   Check whether, in fact, a logical IF followed by an assignment
+   12 IF (THREE /= 'IF(' .AND. THREE /= 'if(') GO TO 99
+      IFASS = .TRUE.
+      DO L6 = L1-1, 1, -1
+         IF (STAMNT(L6:L6)==' ') CYCLE
+         IF (STAMNT(L6:L6)==')') THEN
+!
+!   Is there a second pair of first-level parentheses
+            IF (index(STAMNT(:L6), ')')==0) GO TO 99
+            LPAREN = 1
+            DO L7 = L6-1, 4, -1
+               IF (STAMNT(L7:L7)==' ') CYCLE
+               IF (STAMNT(L7:L7)==')') THEN
+                  IF (LPAREN==0) THEN
+                     GO TO 14
+                  ELSE
+                     LPAREN = LPAREN+1
+                  END IF
+               ELSE IF (STAMNT(L7:L7)=='(') THEN
+                  LPAREN = LPAREN-1
+               END IF
+            END DO
+            GO TO 99
+   14       ASSIGN = .FALSE.
+            GO TO 10
+         ELSE
+            ASSIGN = .FALSE.
+            GO TO 10
+         END IF
+      END DO
+!
+!   Test for non-executable statement keyword
+   99 IF (ASSIGN) GO TO 98
+      IF (.NOT.INTFL) GO TO 97
+      SKIP = L3 ==  3.OR.L3 ==  5.OR.L3 ==  8                          &
+         .OR.L3 == 11.OR.L3 == 12.OR.L3 == 19.OR.L3 == 22              &
+         .OR.L3 == 25.OR.L3 == 27.OR.L3 == 29                          &
+         .OR.L3 == 34.OR.L3 == 36.OR.L3 == 41
+      SKIP = .NOT.SKIP
+      IF (SKIP) GO TO 98
+!
+!   Check whether this statement refers to an argument or a function
+!   name
+      IF (L3 == 3 .OR. L3 == 22 .OR. L3 == 25 .OR.                     &
+                       L3 == 34 .OR. L3 == 41) GO TO 97
+      IF(index(STAMNT(LK(L3)+1:LENST), 'FUNCTION')/= .0 .OR.           &
+         index(STAMNT(LK(L3)+1:LENST), 'function') /= 0) GO TO 97
+      DO L20 = 1, NOARG
+         IF(index(STAMNT(LK(L3)+1:LENST), ARGNAM(L20)(:LENARG(L20)))   &
+          /=  0) GO TO 97
+      END DO
+      SKIP = .TRUE.
+      GO TO 98
+!
+!   Keep procedure name for END statement
+   97 call name_of(nameof, stamnt(lk(l3)+2:lenst), name_length)
+      IF(L3 == 3.OR.L3 == 22.OR.L3 == 34.OR.                           &
+      L3 == 41) NAME = KEYS(L3)(:LK(L3))//NAMEOF(:name_length)
+!
+!   Get argument names for later use in skipping unnecessary
+!   specifications
+   21 IF (INTFL) THEN
+         IF (L3 == 22) THEN
+            ARGNAM(1) = NAME(10:15)
+            NOARG = 1
+         END IF
+         IF (L3 == 22 .OR. L3 == 41)                                   &
+         CALL ARGUMENT(ARGNAM, LENARG, STAMNT, LENST, NOARG)
+      END IF
+!
+!   Deal with awkward cases
+      LSAVE = L3
+      IF(L3 == 1.OR.L3 == 5.OR.L3 == 8.OR.L3 == 12 .OR. L3 == 13       &
+      .OR. L3 == 25                                                    &
+      .OR.L3 == 24.AND..NOT.IFASS.OR.L3 == 27.OR.L3 == 29.OR.L3 == 36) &
+        CALL SPECIAL(L3, NEXT, BUFFER, NKEY, KEYS, KEYSLC, LK, FOLLOW)
+!
+!   Was, in fact, a function
+      IF (INTFL.AND.L3 == 22.AND.LSAVE /= 22) THEN
+         SKIP = .FALSE.
+         GO TO 21
+      END IF
+!
+!   Print procedure name
+   98 IF(.NOT.ASSIGN.AND.(L3 == 3.OR.L3 == 22.OR.L3 == 34.OR.L3 == 41))&
+      WRITE (*, '('' Starting '', A)') NAME
+      RETURN
+   END SUBROUTINE KEYWORD
+   subroutine NAME_OF(nameof, HEADER, name_length)
+!
+   implicit none
+!   Pick out name of procedure
+      CHARACTER(LEN=*), INTENT(IN) :: HEADER
+      CHARACTER(LEN=*), INTENT(out):: nameof
+      integer, intent(out)         :: name_length
+      integer :: ind, indast
+!
+      NAMEOF = ' '
+!
+!   Is there a left parenthesis or an asterisk?
+      IND = index(HEADER, '(' )
+      INDAST = index(HEADER, '*')
+      IF (IND /= 0 .AND. INDAST /= 0) IND = MIN(IND, INDAST)
+      IF (IND <= LEN(NAMEOF)) THEN
+         IF (IND  ==  0) THEN
+            NAMEOF(2:) = HEADER(:LEN(HEADER))
+            name_length = min(len(header)+1, len(nameof))
+         ELSE
+            NAMEOF(2:IND) = HEADER(:IND-1)
+            name_length = ind
+         END IF
+      END IF
+      RETURN
+   END subroutine NAME_OF
+   SUBROUTINE PROGRAM_UNITS( )
+!
+!***********************************************************************
+!   The principal subroutine of CONVERT processes the                  *
+!   input stream, which is assumed to contain syntactically correct    *
+!   Fortran program units. To protect itself from bad data, failure    *
+!   to pass a primitive syntax check will cause the program to copy    *
+!   the input stream to the output unit unchanged, until an END line is*
+!   encountered.                                                       *
+!***********************************************************************
+!
+      USE DATA
+!
+      USE STATISTICS
+!
+      USE STRUCTURE
+   implicit none
+!
+!***********************************************************************
+!   USER is a character which may be defined to identify lines         *
+!   in the input stream which are to be treated as                     *
+!   comment lines ( + in this example).                                *
+!***********************************************************************
+!
+      CHARACTER(LEN=1) :: CONTIN
+      CHARACTER(LEN=3), PARAMETER :: FIN='END', FINLC='end'
+      CHARACTER(LEN=66) :: FIELD
+      CHARACTER(LEN=72) :: LINE
+      CHARACTER(LEN=72), PARAMETER :: BLANKV=' '
+!
+      LOGICAL :: NEWDO , NEWIF , FORM ,  ELSEBL , ASSIGN
+!
+      CHARACTER(LEN=*), PARAMETER :: USER = '+'
+      LOGICAL :: STAT = .FALSE. , SKIP = .FALSE.
+!
+      integer :: l1,             l5, l22, kntcon, napo, lab, l9, k1,   &
+                 irtcod, nend
+!
+!   Start processing program units
+      MXDO = 0
+      MXIF = 0
+      KARD = 0
+      KNTPU = 0
+      SYNTAX = .FALSE.
+      SYNERR = .FALSE.
+      OVFLW = .FALSE.
+      NONSTD = .FALSE.
+      KNTDO = 0
+      KNTIF = 0
+      KNTCOM = 0
+      NAME = ' '
+      NOARG = 0
+      INTFL = INTBFL
+!
+!   Set continuation line counter
+    1 KNTCON = 0
+!
+!   Set statement length counter
+      LENST = 0
+!
+!   Read one line into an internal file,
+!   columns 73-80 of all lines are ignored.
+    2 READ (NIN , '(A)' , END = 100 , ERR = 100) LINE
+      KARD = KARD+1
+!
+!   Check whether a comment line and if so copy to buffer.
+      IF (LINE(:1) == 'C' .OR. LINE(:1) == '*' .OR. LINE(:1) ==        &
+      USER .OR. LINE == ' ' .OR. LINE(:1) == 'c'                       &
+                            .OR. LINE(:1) == '!') THEN
+         IF (INTFL) GO TO 2
+         IF (LINE(:1) == 'C' .OR. LINE(:1) == '*'                      &
+         .OR. LINE(:1) == 'c') LINE(:1) = '!'
+         IF (KNTCOM == KKLIM) THEN
+            WRITE (NOUT , '(A72)') (CBUF(72*L5-71:72*L5) , L5 = 1 ,    &
+            KNTCOM) , LINE
+            KNTCOM = 0
+         ELSE IF (SYNERR .OR. .NOT.STAT) THEN
+            WRITE (NOUT , '(A72)') LINE
+         ELSE
+            KNTCOM = KNTCOM+1
+            CBUF(72*KNTCOM-71:72*KNTCOM) = LINE
+         END IF
+         GO TO 2
+      END IF
+!
+!   Some form of embedded comment?
+      NAPO = 0
+      DO L22 = 2, 72
+         IF (LINE(L22:L22)  ==  '''') NAPO = 1 - NAPO
+         IF (L22 == 6) CYCLE
+         IF (LINE(L22:L22)  /=  '!') CYCLE
+         IF (NAPO  /=  0) CYCLE
+         IF (.NOT. INTFL) THEN
+            IF (KNTCOM  <  KKLIM) THEN
+               KNTCOM = KNTCOM +1
+               CBUF(72*KNTCOM-71:72*KNTCOM) =                          &
+                                BLANKV(:L22-1)//LINE(L22:72)
+            ELSE
+               WRITE (NOUT, '(A)') BLANKV(:L22-1)//LINE(L22:72)
+            END IF
+         END IF
+         LINE(L22:72) = ' '
+         IF (LINE  ==  ' ') GO TO 2
+         EXIT
+      END DO
+!
+!   Line is some form of statement; re-read.
+      READ (LINE , '(BN , I5 , A1 , A66)') LAB , CONTIN , FIELD
+      STAT = .TRUE.
+!
+!   Check on syntax and copy to statement buffer
+    3 IF (CONTIN == '0') CONTIN = ' '
+      IF (CONTIN /= ' ') THEN
+         CONTIN = '&'
+         IF (SYNERR) THEN
+            GO TO 6
+         ELSE IF (LENST == 0 .OR. LENST+66 > LEN .OR. LAB /= 0) THEN
+            SYNERR = .TRUE.
+            IF (LENST > 0) THEN
+               IF (LABEL /= 0) THEN
+                  WRITE (NOUT , '(I5, 1X, A66:"&"/(5X, "&", A66:       &
+     &            "&"))') LABEL ,                                      &
+                  (STAMNT(66*L9-65:66*L9) , L9 = 1 , (LENST+65)/66)
+               ELSE
+                  WRITE (NOUT , '(6X, A66:"&"/(5X, "&", A66:"&"        &
+     &            ))') (STAMNT(66*L9-65:66*L9) , L9 = 1 , (LENST+65)/66)
+               END IF
+            END IF
+            IF (LAB /= 0) THEN
+               WRITE (NOUT , 1000) LAB , CONTIN , FIELD
+            ELSE
+               WRITE (NOUT , 1006) CONTIN , FIELD
+            END IF
+            GO TO 1
+         ELSE
+            KNTCON = KNTCON+1
+            STAMNT(LENST+1:LENST+66) = FIELD
+            LENST = LENST+66
+            GO TO 2
+         END IF
+      ELSE IF (KNTCON == 0) THEN
+         IF (LENST /= 0) GO TO 4
+         STAMNT(1:66) = FIELD
+         LENST = 66
+         LABEL = LAB
+         IF (SYNERR) GO TO 4
+         GO TO 2
+      END IF
+      IF (KNTCON > 0) GO TO 6
+!
+!   Have a complete statement ready for processing (the last line
+!   read is still waiting in LINE). The statement now needs to be
+!   identified.
+!   The END statement is a special case - if found it will be copied
+!   and the next program unit processed.
+    4 K1 = 1
+      DO  L1 = 1 , LENST
+         IF (STAMNT(L1:L1) == ' ') CYCLE
+         IF (STAMNT(L1:L1) /= FIN(K1:K1) .AND.                         &
+             STAMNT(L1:L1) /= FINLC(K1:K1)) THEN
+            EXIT
+         ELSE
+            K1 = K1+1
+            IF (K1 > 3 .AND. (L1 >= LENST .OR. STAMNT(L1+1:LENST)      &
+            == ' ')) THEN
+               IF (.NOT.SYNERR) THEN
+                  KNTPU=KNTPU+1
+                  IF (LABEL == 0) THEN
+                     WRITE (NOUT , 1001) FIN, NAME
+                  ELSE
+                     WRITE (NOUT , 1002) LABEL , FIN, NAME
+                  END IF
+               END IF
+!
+!   Set counters for new program unit
+               SYNTAX = SYNTAX .OR. SYNERR
+               KNTDO = 0
+               KNTIF = 0
+               SYNERR = .FALSE.
+               KNTCON = 0
+               LENST = 0
+               IF (KNTCOM /= 0) WRITE (NOUT , '(A72)') (CBUF(72*L5-71: &
+               72*L5) , L5 = 1 , KNTCOM)
+               KNTCOM = 0
+               NAME = ' '
+               NOARG = 0
+               GO TO 3
+            ELSE
+               IF (K1 > 3) EXIT
+            END IF
+         END IF
+      END DO
+!
+!   If syntax error flag set, copy and take next statement
+    6 IF (SYNERR) THEN
+         IF (LAB /= 0) THEN
+            WRITE (NOUT , 1000) LAB , CONTIN , FIELD
+         ELSE
+            WRITE (NOUT , 1006) CONTIN , FIELD
+         END IF
+         LENST = 0
+         GO TO 2
+      END IF
+!
+!   Compress blanks and insert blanks around special characters
+      CALL BLANK( )
+!
+!   Handle Fortran keywords
+      NEWDO = .FALSE.
+      NEWIF = .FALSE.
+      FORM  = .FALSE.
+      ELSEBL = .FALSE.
+      ASSIGN = .FALSE.
+      IF (BLANKS) CALL KEYWORD(ASSIGN, SKIP)
+      IF (SKIP) GO TO 16
+      IF (SYNERR) GO TO 6
+      IF (BLANKS .AND. ASSIGN .AND. LABEL == 0) GO TO 14
+!
+!   Have a valid statement which is not an END line or assignment
+!   Identify statement as    DO
+!                            IF ( ) THEN
+!                            DO terminator
+!                            END IF
+!                            FORMAT
+!                            ELSE or ELSEIF
+!                            none of these.
+      CALL IDENTIFY(IRTCOD)
+      SELECT CASE (IRTCOD)
+         CASE (0)
+            GO TO  14
+!
+!   New DO-loop
+         CASE (1)
+            IF (KNTDO == NEST) GO TO 14
+            NEWDO = .TRUE.
+            LABLDO(KNTDO+1) = LABLNO
+!
+!   End of DO-loop(s)
+         CASE (2)
+            NEND = 0
+            DO  L5 = KNTDO , 1 , -1
+               IF (LABLDO(L5) /= LABEL) EXIT
+               NEND = NEND + 1
+            END DO
+!
+!   Replace CONTINUE by END DO
+      KNTDO = KNTDO - NEND
+      IF (NEND == 1 .AND. LENST == 10 .AND. STAMNT(:LENST) ==          &
+      'CONTINUE  ') THEN
+         STAMNT(:8) = 'END DO  '
+         LENST = 6
+      END IF
+!
+!   Beginning of IF-block
+         CASE (3)
+            NEWIF = .TRUE.
+!
+!   End of IF-block
+         CASE (4)
+            KNTIF = KNTIF-1
+            IF (KNTIF < 0) THEN
+               SYNERR = .TRUE.
+               KNTIF = 0
+            END IF
+!
+!   FORMAT statement
+         CASE (5)
+            FORM =.TRUE.
+!
+!   Beginning of ELSE-block
+         CASE (6)
+            IF (KNTIF  >  0) THEN
+               ELSEBL = .TRUE.
+            ELSE
+              SYNERR = .TRUE.
+            END IF
+      END SELECT
+!
+!   Reformat statements and write
+   14 CALL REFORM (FORM , ELSEBL)
+!
+!   Set variables for next statement
+      IF (NEWDO) KNTDO = KNTDO+1
+      IF (NEWIF) KNTIF = KNTIF+1
+      MXDO = MAX(MXDO , KNTDO)
+      MXIF = MAX(MXIF , KNTIF)
+   16 KNTCON = 0
+      LENST = 0
+      GO TO   3
+!
+!   End of data. Last line must be an END.
+  100 IF (LABEL == 0) WRITE (NOUT , 1001) FIN, NAME
+      IF (LABEL /= 0) WRITE (NOUT , 1002) LABEL , FIN, NAME
+      KNTPU=KNTPU+1
+      IF (INTFL) WRITE (NOUT, '(6X, ''END INTERFACE'')')
+!
+!   Note: if there is a syntax error, continued
+!         statements do not have a trailing &
+ 1000 FORMAT(I5 , A1 , A)
+ 1001 FORMAT(TR6 , A3 ,TR1, A)
+ 1002 FORMAT(I5 , TR1 , A3 ,TR1, A)
+ 1006 FORMAT(TR5 , A1 , A66)
+!
+   RETURN
+   END SUBROUTINE PROGRAM_UNITS
+   SUBROUTINE REFORM (FORM , ELSEBL)
+!
+!   Performs reformatting and output of accepted statements
+!
+      USE DATA
+!
+      USE STRUCTURE
+   implicit none
+!
+      INTEGER, PARAMETER :: LLIMIT = LEN-(LEN/66-1)*6
+      CHARACTER(LEN=LEN) :: OUT
+      CHARACTER(LEN = 1) :: AMP
+!
+      LOGICAL, INTENT(IN) :: FORM , ELSEBL
+!
+      integer :: ind, ipnt, l6, l2, l3, l4, lout, idepth, kntap, kadd, &
+                 l5, jpnt
+!
+!   If FORMAT statement, do not indent
+      IF (FORM) GO TO 9
+!
+!   Remove the blanks before commas if no character string
+      IF (BLNKFL .AND. INDEX(STAMNT(:LENST), "'") == 0) THEN
+         IPNT = 1
+         DO
+            IND = INDEX(STAMNT(IPNT:LENST), ' , ')
+            IF (IND == 0) EXIT
+            IND = IPNT + IND - 1
+            STAMNT(IND:IND+2) = ',  '
+            IPNT = IND + 3
+         END DO
+      END IF
+!
+!   Reformat indented statement and write. If reformatting causes it
+!   to exceed LEN characters, it will be copied unchanged.
+      IDEPTH = MIN(KNTDO+KNTIF , MXDPTH)
+      IF (IDEPTH == 0 .AND. .NOT.BLNKFL) GO TO  9
+      IF (ELSEBL) IDEPTH = IDEPTH-1
+      IPNT = 1
+      JPNT = 1
+    1 IF (MOD(IPNT , 66) == 1) THEN
+         IF (IPNT+65 > LEN) GO TO 9
+         OUT(IPNT:IPNT+65) = ' '
+         IPNT = IPNT+IDEPTH*ISHIFT
+      END IF
+!
+!   Find first non-blank character
+      DO  L2 = JPNT , LENST
+         IF (STAMNT(L2:L2) /= ' ') GO TO 3
+      END DO
+      IF (JPNT == 1) THEN
+         SYNERR = .TRUE.
+         GO TO 9
+      ELSE
+         GO TO 10
+      END IF
+!
+!   Find first multiple blank (but not in a character string)
+    3 KNTAP = 0
+      DO  L3 = L2, LENST-1
+         IF (STAMNT(L3:L3) == "'") KNTAP = 1-KNTAP
+         IF (STAMNT(L3:L3+1) == '  ') THEN
+            IF (KNTAP == 0) GO TO 5
+            GO TO 9
+         END IF
+      END DO
+      L3 = LENST
+!
+!   Have section with no multiple blanks. This can be copied to OUT
+!   if there is room on the current line. Otherwise cut the
+!   section after the non-alphanumeric character nearest to the end of
+!   the line, if one exists.
+!   An apostrophe and period are considered to be alphanumeric
+!   characters, in order to hold character strings,
+!   and real and logical constants together;
+!   underscores and dollars are so treated to handle common extensions,
+!   and the ** and // operators and real literal constants are treated.
+    5 KADD = 0
+      IF (L3-L2  <=  66-MOD(IPNT , 66)) GO TO  8
+      DO L4 = 66+L2-MOD(IPNT , 66) , L2 , -1
+         IF (STAMNT(L4:L4) == ' ') GO TO 7
+         IF (LGE(STAMNT(L4:L4) , 'A') .AND. LLE(STAMNT(L4:L4) , 'Z'))  &
+         CYCLE
+         IF(LGE(STAMNT(L4:L4), '0') .AND.                              &
+                  LLE(STAMNT(L4:L4), '9')) CYCLE
+         IF (STAMNT(L4:L4)  ==  "'" .OR.                               &
+         STAMNT(L4:L4)  ==  '_' .OR. STAMNT(L4:L4)  ==  '$' .OR.       &
+         STAMNT(L4:L4)  ==  '.') CYCLE
+         IF (L4 /= LENST) THEN
+            IF (STAMNT(L4:L4+1)  ==  '**' .OR.                         &
+                STAMNT(L4:L4+1)  ==  '//' ) CYCLE
+            IF (L4 /= L2) THEN
+               IF(LGE(STAMNT(L4+1:L4+1), '0') .AND.                    &
+                  LLE(STAMNT(L4+1:L4+1), '9')) THEN
+                  IF (STAMNT(L4-1:L4)  ==  'E+' .OR.                   &
+                      STAMNT(L4-1:L4)  ==  'e+' .OR.                   &
+                      STAMNT(L4-1:L4)  ==  'E-' .OR.                   &
+                      STAMNT(L4-1:L4)  ==  'e-' .OR.                   &
+                      STAMNT(L4-1:L4)  ==  'D+' .OR.                   &
+                      STAMNT(L4-1:L4)  ==  'd+' .OR.                   &
+                      STAMNT(L4-1:L4)  ==  'D-' .OR.                   &
+                      STAMNT(L4-1:L4)  ==  'd-' ) CYCLE
+               END IF
+            END IF
+         END IF
+         IF (LGE(STAMNT(L4:L4) , 'a') .AND. LLE(STAMNT(L4:L4) , 'z'))  &
+         CYCLE
+         GO TO 7
+      END DO
+!
+!   No break character found
+      IF (BLNKFL) GO TO 9
+      L4 = 66-MOD(IPNT , 66)+L2
+!
+!   Cut here
+    7 L3 = L4
+      KADD = 1
+    8 LOUT = IPNT+L3-L2
+      IF (LOUT > LEN) GO TO  9
+      OUT(IPNT:LOUT) = STAMNT(L2:L3)
+      IF (L3 == LENST) GO TO 10
+!
+!   Set pointers for next section of statement
+      IPNT = LOUT+1
+      IF (KADD == 1 .AND. MOD(IPNT , 66) /= 1 .OR. MOD(IPNT , 66)      &
+       >= 60) IPNT = ((IPNT+65)/66)*66+1
+      IF (MOD(IPNT , 66) == 0) IPNT = IPNT+1
+      JPNT = L3+1
+      IF (KADD == 0) JPNT = JPNT+1
+      GO TO   1
+!
+!   Copied statement (if adding 6 cols. to initial line would cause
+!   total length to exceed 2640, must start it in col.1)
+    9 LENST = LEN_TRIM(STAMNT(:LENST))
+      IF (LENST > 66) THEN
+         AMP = '&'
+      ELSE
+         AMP = ' '
+      END IF
+      IF (LABEL /= 0) THEN
+         WRITE (NOUT , 1003) LABEL , STAMNT(:MIN(LENST, 66)), AMP
+      ELSE
+         IF (LENST < LEN-6) THEN
+            WRITE (NOUT , 1004) STAMNT(:MIN(LENST,66)), AMP
+         ELSE
+            WRITE (NOUT , '(A,A1)') STAMNT(:MIN(LENST, 66)), AMP
+         END IF
+      END IF
+      IF (LENST > 66) WRITE (NOUT , 1005)                              &
+     &('&', STAMNT(66*L6-65:66*L6) , L6 = 2 , (LENST+65)/66)
+      GO TO  11
+!
+!   Write OUT to output unit
+   10 LOUT = LEN_TRIM(OUT(:LOUT))
+      IF (LOUT > 66) THEN
+         AMP = '&'
+      ELSE
+         AMP =' '
+      END IF
+      IF (LABEL /= 0) THEN
+         WRITE (NOUT , 1003) LABEL , OUT(:MIN(LOUT, 66)), AMP
+      ELSE
+         WRITE (NOUT , 1004) OUT(:MIN(LOUT, 66)), AMP
+      END IF
+!
+!   An & is required in col. 6 if statement has more than 2412
+!   characters, otherwise total length including cols. 1-6 will
+!   exceed 2640. Also if making interface blocks, in order to be
+!   compatible with both old and new source forms.
+      IF (LOUT > 66) THEN
+         IF (LOUT > LLIMIT .OR. INTFL) THEN
+            AMP = '&'
+         ELSE
+            AMP = ' '
+         END IF
+         WRITE (NOUT , 1005) (AMP , OUT(66*L5-65:66*L5) , L5 = 2 , (   &
+         LOUT+65)/66)
+      END IF
+!
+!   Write any comments following statement
+   11 IF (KNTCOM /= 0) THEN
+         WRITE (NOUT ,'(A72)') (CBUF(72*L5-71:72*L5) , L5 = 1 , KNTCOM)
+         KNTCOM = 0
+      END IF
+!
+ 1003 FORMAT(I5 , TR1, A, A)
+ 1004 FORMAT(TR6, A, A)
+ 1005 FORMAT(TR5 , A , A:'&' )
+!
+   RETURN
+   END SUBROUTINE REFORM
+   SUBROUTINE SPECIAL(L3, NEXT, BUFFER, NKEY, KEYS, KEYSLC,            &
+      LK, FOLLOW)
+!
+!   Special treatment for peculiar Fortran syntax
+!
+      USE STRUCTURE
+!
+      USE STATISTICS
+   implicit none
+!
+      INTEGER, PARAMETER :: NUMLEN = 5
+!
+      CHARACTER(LEN=*), INTENT(OUT) :: BUFFER
+      INTEGER, INTENT(IN) :: NKEY
+      INTEGER, INTENT(IN), dimension(:) :: LK
+      CHARACTER(LEN=*), INTENT(IN), dimension(:) :: KEYS, KEYSLC
+      CHARACTER(LEN=32)     :: NAMEOF
+      CHARACTER(LEN=NUMLEN) :: NUMBER
+!
+      INTEGER, INTENT(IN OUT) :: L3, NEXT
+      LOGICAL, INTENT(IN), dimension(:) :: FOLLOW
+      LOGICAL :: IFASSIGN
+      integer ::         ind,        l20, istar, lparen, napos, ndigit,&
+                 nparen, l10, ilp, isss, limit, name_length
+!
+      IFASSIGN = .FALSE.
+!
+!  Deal with labelled DO WHILE
+      IF (L3 == 13) THEN
+         IND = index(STAMNT(:LENST), 'WHILE')
+         IF (IND == 0) IND = index(STAMNT(:LENST), 'while')
+         IF (IND /= 0) THEN
+            IF(LGE(STAMNT(IND-1:IND-1), '0') .AND.                     &
+               LLE(STAMNT(IND-1:IND-1), '9'))                          &
+               STAMNT(IND:IND+5) = ' WHILE'
+         END IF
+         GO TO 99
+      END IF
+!
+!   Deal with IMPLICIT with non-standard length specifiers
+      IF (L3  ==  25) THEN
+         IF (index(STAMNT(:LENST), '*')  /=  0) THEN
+!
+!   first, CHARACTER*(len)
+   11       IND = index(STAMNT(:LENST), 'CHARACTER *  (')
+            IF (IND  ==  0) IND = index(STAMNT(:LENST),'character *  (')
+            IF (IND /=  0) THEN
+               STAMNT(IND+10:IND+10) = ' '
+               GO TO 11
+            END IF
+!
+!   then, type*nn
+            NPAREN = 0
+            NAPOS = 0
+            DO L10 = 15, LENST
+               IF (STAMNT(L10:L10)  ==  "'") THEN
+                  NAPOS = 1 - NAPOS
+               ELSE IF (STAMNT(L10:L10)  ==  '(') THEN
+                  IF (NAPOS  ==  0) NPAREN = NPAREN + 1
+               ELSE IF (STAMNT(L10:L10)  ==  ')') THEN
+                  IF (NAPOS  ==  0) NPAREN = NPAREN - 1
+               ELSE IF (STAMNT(L10:L10)  ==  '*') THEN
+                  IF (NPAREN  ==  0) THEN
+                     STAMNT(L10:L10+1) = ' ('
+                     ILP = index(STAMNT(L10+2:LENST), '(')
+                     IF (ILP  ==  0) THEN
+                        SYNERR = .TRUE.
+                        GO TO 99
+                     ELSE
+                        STAMNT(L10+ILP:L10+ILP) = ')'
+                     END IF
+                     IF (STAMNT(L10+1:L10+3)  ==  '(4)') THEN
+                        IF (STAMNT(L10-5:L10-5)  /=  'C' .AND.         &
+                            STAMNT(L10-5:L10-5)  /=  'c')              &
+                            STAMNT(L10+1:L10+3) = '   '
+                     ELSE IF (STAMNT(L10-2:L10+3)  ==  'X  (8)' .OR.   &
+                             STAMNT(L10-2:L10+3)  ==  'x  (8)')THEN
+                        STAMNT(L10+1:L10+3) = '   '
+                     END IF
+
+                  END IF
+               END IF
+            END DO
+         END IF
+         GO TO 99
+      END IF
+!
+!   An ASSIGN label must be followed by a blank and a * specifier
+!   converted to (...)
+      IF(L3 == 1 .AND. STAMNT(:7 )  ==  'ASSIGN '     .OR.             &
+         L3 == 5 .AND. STAMNT(:11)  ==  'CHARACTER *' .OR.             &
+         L3 == 8 .AND. STAMNT(:9 )  ==  'COMPLEX *'   .OR.             &
+         L3 == 27.AND. STAMNT(:9 )  ==  'INTEGER *'   .OR.             &
+         L3 == 29.AND. STAMNT(:9 )  ==  'LOGICAL *'   .OR.             &
+         L3 == 36.AND. STAMNT(:6 )  ==  'REAL *'          ) THEN
+         IF (L3 < 8) THEN
+            ISSS = L3+7
+         ELSE IF (L3 < 30) THEN
+            ISSS = 10
+         ELSE
+            ISSS = 7
+         END IF
+!
+!   Extract the length parameter
+         NDIGIT = 1
+         NUMBER = '  '
+         DO L20 = ISSS, LENST
+            IF(STAMNT(L20:L20)  ==  ' ') CYCLE
+            NUMBER(:1) = STAMNT(L20:L20)
+            IF(LGE(STAMNT(L20:L20),'0') .AND. LLE(STAMNT(L20:L20),'9') &
+            ) GO TO 21
+            GO TO 1
+         END DO
+         SYNERR = .TRUE.
+         GO TO 99
+   21    DO NEXT = L20+1, LENST
+            IF(STAMNT(NEXT:NEXT)  ==  ' ') CYCLE
+            IF(LLT(STAMNT(NEXT:NEXT), '0') .OR. LGT(STAMNT(NEXT:NEXT), &
+            '9')) GO TO 19
+            NDIGIT = NDIGIT + 1
+            IF (NDIGIT  >  NUMLEN) THEN
+               SYNERR = .TRUE.
+               GO TO 99
+            END IF
+            NUMBER(NDIGIT:NDIGIT) = STAMNT(NEXT:NEXT)
+         END DO
+         SYNERR = .TRUE.
+         GO TO 99
+      END IF
+      GO TO 1
+!
+!   Insert the blank or parentheses
+   19 IF (LENST >= LEN-1) THEN
+         OVFLW = .TRUE.
+         GO TO 99
+      END IF
+      BUFFER(NEXT:LENST) = STAMNT(NEXT:LENST)
+      IF (L3 == 1) THEN
+         LENST = LENST+2
+         STAMNT(NEXT:NEXT+3) = ' TO '
+         STAMNT(NEXT+4:LENST) = BUFFER(NEXT+2:LENST-2)
+      ELSE
+         LENST = LENST+1
+         STAMNT(NEXT:NEXT) = ' '
+         STAMNT(NEXT+1:LENST) = BUFFER(NEXT:LENST-1)
+         IF (L3 /= 5.AND. NDIGIT  ==  1 .AND. NUMBER(:1)  ==  '4') THEN
+            STAMNT(NEXT-4:NEXT-1) = '    '
+         ELSE IF (L3 == 8.AND.NDIGIT  ==  1 .AND. NUMBER(:1)  ==  '8') &
+         THEN
+            STAMNT(NEXT-4:NEXT-1) = '    '
+         ELSE
+            STAMNT(NEXT-3-NDIGIT:NEXT-1) = '('//NUMBER(:NDIGIT)//')'
+         END IF
+      END IF
+      GO TO 2
+!
+!   Handle (*) case
+    1 IF(L3 == 5 .AND. STAMNT(:18)  ==  'CHARACTER *  ( * )') THEN
+         NEXT = 19
+         STAMNT(11:11) = ' '
+      END IF
+!
+!   IF statement may be followed by a keyword
+    2 IF (L3  ==  24 ) THEN
+         LPAREN = 1
+         NAPOS = 0
+         DO NEXT = 5, LENST
+            IF (STAMNT(NEXT:NEXT)  ==  "'") NAPOS = 1 - NAPOS
+            IF (NAPOS  ==  1) CYCLE
+            IF (STAMNT(NEXT:NEXT)  ==  '(' ) LPAREN = LPAREN+1
+            IF (STAMNT(NEXT:NEXT)  ==  ')' ) LPAREN = LPAREN-1
+            IF (LPAREN  ==  0) GO TO 5
+         END DO
+         GO TO 99
+    5    NEXT = NEXT+1
+         DO L3 = 1, NKEY
+            IF (FOLLOW(L3) .AND.(STAMNT(NEXT+1:NEXT+LK(L3)) == KEYS(L3)&
+                          .OR. STAMNT(NEXT+1:NEXT+LK(L3)) == KEYSLC(L3)&
+             )) THEN
+               NEXT = NEXT+LK(L3)+1
+               IF(L3 == 1) IFASSIGN = .TRUE.
+               GO TO 9
+            END IF
+         END DO
+      ELSE
+!
+! Typed function
+         IF(STAMNT(NEXT+1:NEXT+8)  ==  'FUNCTION'  .OR.                &
+            STAMNT(NEXT+1:NEXT+8)  ==  'function') THEN
+            NEXT = NEXT+9
+            call name_of(nameof, stamnt(next:lenst), name_length)
+            NAME = 'FUNCTION'//NAMEOF(:name_length)
+            L3 = 22
+!
+!   Deal with any *
+            LIMIT = index(STAMNT(:LENST), '(')
+            IF (LIMIT /= 0) THEN
+               ISTAR = index(STAMNT(:LIMIT), '*')
+               IF (ISTAR  /=  0) THEN
+                  NDIGIT = LIMIT - ISTAR -3
+                  IF (NDIGIT  >  NUMLEN) THEN
+                     SYNERR = .TRUE.
+                     GO TO 99
+                  END IF
+                  NUMBER(:NDIGIT) = STAMNT(ISTAR+2:LIMIT-2)
+                  STAMNT(NEXT-5+NDIGIT:LIMIT-2) =                      &
+                                      'FUNCTION'//NAME(10:ISTAR-NEXT+8)
+                  STAMNT(NEXT-8:NEXT-6+NDIGIT)  =                      &
+                                      '('//NUMBER(:NDIGIT)//') '
+                  IF (NDIGIT  ==  1 .AND. NUMBER(:1)  ==  '4') THEN
+                     STAMNT(NEXT-8:NEXT-5) = '    '
+                  ELSE IF (NDIGIT  ==  1 .AND. NUMBER(:1)  ==  '8'.AND.&
+                     (STAMNT(7:7) == 'X'.OR.STAMNT(7:7) == 'x')) THEN
+                     STAMNT(NEXT-8:NEXT-5) = '    '
+                  END IF
+                  NEXT = NEXT + 3 + NDIGIT
+               END IF
+            ELSE
+               SYNERR = .TRUE.
+               GO TO 99
+            END IF
+            GO TO 9
+         END IF
+      END IF
+      GO TO 99
+!
+!   Insert the blank
+    9 IF (LENST >= LEN-2) THEN
+         OVFLW = .TRUE.
+         GO TO 99
+      END IF
+      BUFFER(NEXT:LENST) = STAMNT(NEXT:LENST)
+      LENST = LENST+1
+      STAMNT(NEXT:NEXT) = ' '
+      STAMNT(NEXT+1:LENST) = BUFFER(NEXT:LENST-1)
+!
+!   ASSIGN may follow IF
+      IF(.NOT.IFASSIGN) GO TO 99
+      NEXT = index(STAMNT(:LENST), 'TO')
+      IF (NEXT == 0) NEXT = index(STAMNT(:LENST), 'to')
+      IF(NEXT == 0) THEN
+         SYNERR = .TRUE.
+         GO TO 99
+      ELSE
+         LENST = LENST+2
+         STAMNT(NEXT:NEXT+3) = ' TO '
+         STAMNT(NEXT+4:LENST) = BUFFER(NEXT+1:LENST-3)
+      END IF
+99 RETURN
+   END SUBROUTINE SPECIAL
+   SUBROUTINE START( )
+!
+!   To prepare for PROGRAM_UNITS
+!
+      USE DATA
+   implicit none
+      CHARACTER(LEN=16) :: NAME
+!
+!   Prompt for interactive use
+      WRITE (*,'(" Type name of file, shift, max. indent level, T or F &
+        &for blank treatment,",/ " T or F for interface blocks only.")')
+      WRITE (*,'(" For simple use type only the name of the file ",    &
+            &"followed by a slash (/) and RETURN.",/                   &
+            &" Note that the name should be given WITHOUT extension!")')
+!
+!   Does standard input unit contain an input record
+      NIN = 11
+      NOUT = 12
+      ISHIFT = 0
+      MXDPTH = 0
+      BLANKS = .FALSE.
+      INTBFL = .FALSE.
+      READ (* , * , END = 1 , ERR = 1) NAME, ISHIFT , MXDPTH ,         &
+      BLANKS, INTBFL
+!
+!   If record present, check input values are reasonable
+      ISHIFT = MIN(MAX(ISHIFT , 0) , 10)
+      MXDPTH = MIN(MAX(MXDPTH , 0) , 36/MAX(ISHIFT,1))
+      IF (INTBFL.AND..NOT.BLANKS) WRITE (*, '('' Interface block proces&
+     &sing cancelled as blank processing not requested'')')
+      INTBFL = BLANKS.AND.INTBFL
+      GO TO  2
+!
+!   Set default values
+    1 ISHIFT = 3
+      MXDPTH = 10
+      BLANKS = .TRUE.
+      INTBFL = .FALSE.
+      NAME = 'name'
+    2 OPEN (UNIT=NIN, FILE=TRIM(NAME)//'.f', ACTION='READ')
+      OPEN (UNIT=NOUT, FILE=TRIM(NAME)//'.f90', ACTION='WRITE')
+!
+!   Print values to be used
+      Write (*,'(" Loop bodies will be indented by",I3/                &
+     &           " Maximum indenting level is     ",I3)')              &
+              ISHIFT , MXDPTH
+      IF (BLANKS) WRITE (*,                                            &
+      '(" Significant blank proccessing requested")')
+      IF (INTBFL) WRITE (*,                                            &
+      '('' Only interface blocks will be produced'')')
+      IF (INTBFL) WRITE (NOUT, '(6X, ''INTERFACE'')')
+!
+      CALL SYSTEM_CLOCK(TIME0)
+      RETURN
+   END SUBROUTINE START
+   SUBROUTINE TERMINATE( )
+!
+!   To print the final summary
+!
+      USE STATISTICS
+      USE DATA
+   implicit none
+!
+      integer :: itick, itime
+!
+      CALL SYSTEM_CLOCK(ITIME, ITICK)
+      IF (ITICK /= 0)                                                  &
+      WRITE (*,'(" Processing complete in ", F7.3, " seconds")')       &
+            REAL(ITIME-TIME0)/REAL(ITICK)
+      WRITE (*,'(" Maximum depth of DO-loop nesting ",I3/              &
+     &           " Maximum depth of IF-block nesting",I3/              &
+     &" No. of lines read  ",I17/" No. of program units read   ",I8/   &
+     &           " Global syntax error flag",L12)')                    &
+                MXDO , MXIF , KARD , KNTPU , SYNTAX
+!
+      IF (OVFLW) WRITE(*,  '(" At least one statement was too long to h&
+     &ave a necessary blank added")')
+      IF (NONSTD) WRITE (*,  '(" At least one statement began with a no&
+     &n-standard keyword")')
+!
+    RETURN
+    END SUBROUTINE TERMINATE
+   END MODULE ALL_PROCEDURES
+   PROGRAM CONVERT
+   USE ALL_PROCEDURES
+   implicit none
+!
+!   Initialize
+      CALL START( )
+!
+!   Process the lines of program units
+      CALL PROGRAM_UNITS( )
+!
+!   Print some statistics
+      CALL TERMINATE( )
+      STOP
+   END PROGRAM CONVERT
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/Makefile	(revision 17)
@@ -0,0 +1,28 @@
+.SUFFIXES: .F .o
+
+OBJ  =   c1f2kb.o c1f2kf.o c1f3kb.o c1f3kf.o c1f4kb.o c1f4kf.o c1f5kb.o c1f5kf.o c1fgkb.o c1fgkf.o c1fm1b.o c1fm1f.o cfft1b.o \
+         cfft1f.o cfft1i.o cfft2b.o cfft2f.o cfft2i.o cfftmb.o cfftmf.o cfftmi.o cmf2kb.o \
+         cmf2kf.o cmf3kb.o cmf3kf.o cmf4kb.o cmf4kf.o cmf5kb.o cmf5kf.o cmfgkb.o cmfgkf.o cmfm1b.o cmfm1f.o cosq1b.o \
+         cosq1f.o cosq1i.o cosqb1.o cosqf1.o cosqmb.o cosqmf.o cosqmi.o cost1b.o cost1f.o cost1i.o costb1.o costf1.o \
+         costmb.o costmf.o costmi.o factor.o mcfti1.o mcsqb1.o mcsqf1.o mcstb1.o mcstf1.o mradb2.o mradb3.o \
+         mradb4.o mradb5.o mradbg.o mradf2.o mradf3.o mradf4.o mradf5.o mradfg.o mrftb1.o mrftf1.o mrfti1.o msntb1.o \
+         msntf1.o r1f2kb.o r1f2kf.o r1f3kb.o r1f3kf.o r1f4kb.o r1f4kf.o r1f5kb.o r1f5kf.o r1fgkb.o r1fgkf.o rfft1b.o \
+         rfft1f.o rfft1i.o rfft2b.o rfft2f.o rfft2i.o rfftb1.o rfftf1.o rffti1.o rfftmb.o \
+         rfftmf.o rfftmi.o sinq1b.o sinq1f.o sinq1i.o sinqmb.o sinqmf.o sinqmi.o sint1b.o sint1f.o sint1i.o sintb1.o \
+         sintf1.o sintmb.o sintmf.o sintmi.o tables.o xercon.o xerfft.o
+
+AR = ar
+ARFLAGS = cr
+TARGET = libfftpack.a
+
+library: $(OBJ)
+	$(AR) $(ARFLAGS) $(TARGET) $(OBJ)
+	$(RANLIB) $(TARGET)
+
+.F.o:
+	$(FC) -c $(FFLAGS) $< 
+
+clean:
+	rm -f $(OBJ) $(TARGET) *.obj
+
+superclean: clean
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/Makefile-orig
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/Makefile-orig	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/Makefile-orig	(revision 17)
@@ -0,0 +1,49 @@
+.SUFFIXES:
+.SUFFIXES: .f .o
+
+OBJ  =   c1f2kb.o c1f2kf.o c1f3kb.o c1f3kf.o c1f4kb.o c1f4kf.o c1f5kb.o c1f5kf.o c1fgkb.o c1fgkf.o c1fm1b.o c1fm1f.o cfft1b.o\
+         cfft1f.o cfft1i.o cfft2b.o cfft2f.o cfft2i.o cfftmb.o cfftmf.o cfftmi.o cmf2kb.o\
+         cmf2kf.o cmf3kb.o cmf3kf.o cmf4kb.o cmf4kf.o cmf5kb.o cmf5kf.o cmfgkb.o cmfgkf.o cmfm1b.o cmfm1f.o cosq1b.o\
+         cosq1f.o cosq1i.o cosqb1.o cosqf1.o cosqmb.o cosqmf.o cosqmi.o cost1b.o cost1f.o cost1i.o costb1.o costf1.o\
+         costmb.o costmf.o costmi.o factor.o mcfti1.o mcsqb1.o mcsqf1.o mcstb1.o mcstf1.o mradb2.o mradb3.o\
+         mradb4.o mradb5.o mradbg.o mradf2.o mradf3.o mradf4.o mradf5.o mradfg.o mrftb1.o mrftf1.o mrfti1.o msntb1.o\
+         msntf1.o r1f2kb.o r1f2kf.o r1f3kb.o r1f3kf.o r1f4kb.o r1f4kf.o r1f5kb.o r1f5kf.o r1fgkb.o r1fgkf.o rfft1b.o\
+         rfft1f.o rfft1i.o rfft2b.o rfft2f.o rfft2i.o rfftb1.o rfftf1.o rffti1.o rfftmb.o\
+         rfftmf.o rfftmi.o sinq1b.o sinq1f.o sinq1i.o sinqmb.o sinqmf.o sinqmi.o sint1b.o sint1f.o sint1i.o sintb1.o\
+         sintf1.o sintmb.o sintmf.o sintmi.o tables.o xercon.o xerfft.o
+
+default:
+	@echo "Usage: $(MAKE) [ sun | hp | ibm | gnu | intel | absoft | pgi]"
+
+sun:
+	@$(MAKE) FC=f90 LD=ar FFLAGS="-xO5" LDFLAGS="cr" TARGET=libfftpack.a all
+
+hp:
+	@$(MAKE) FC=f90 LD=ar FFLAGS="-fast" LDFLAGS="cr" TARGET=libfftpack.a all
+
+ibm:
+	@$(MAKE) FC=xlf LD=ar FFLAGS="-O3" LDFLAGS="cr" TARGET=libfftpack.a all
+
+gnu:
+	@$(MAKE) FC=g77 LD=ar FFLAGS="-O3" LDFLAGS="cr" TARGET=libfftpack.a all
+
+intel:
+	@$(MAKE) FC=ifort LD=ar FFLAGS="-O3" LDFLAGS="cr" TARGET=libfftpack.a all
+
+absoft:
+	@$(MAKE) FC=f77 LD=ar FFLAGS="-O3" LDFLAGS="cr" TARGET=libfftpack.a all
+
+pgi:
+	@$(MAKE) FC=pgf77 LD=ar FFLAGS="-fast" LDFLAGS="cr" TARGET=libfftpack.a all
+
+all: library
+
+library: $(OBJ)
+	$(LD) $(LDFLAGS) $(TARGET) $(OBJ)
+
+.f.o:
+	$(FC) -c $(FFLAGS) $< 
+
+clean:
+	rm -f $(OBJ) libfftpack*
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/README
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/README	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/README	(revision 17)
@@ -0,0 +1,174 @@
+
+FFTPACK5 - a FORTRAN library of fast Fourier transforms
+
+Authors:  Paul N. Swarztrauber and Richard A. Valent
+
+$Id: README,v 1.2 2004/06/17 21:59:51 rodney Exp $
+
+Website
+-------
+
+http://www.scd.ucar.edu/css/software/fftpack5
+
+
+Documentation
+-------------
+
+Documentation is provided in PDF format in the file fftpack5.pdf.
+This information is also available in HTML format at the above
+website.  Information about building the library follows below,
+as well as a synopsis of the library.
+
+
+Compiling Library
+-----------------   
+
+[Editor's note - this refers to the original build, 
+not the WRF modified build.]
+
+The included Makefile if configured to build a static
+library on most currently availble unix and unix-like
+operating systems.  The given make targets (type "make"
+without any arguments for a list of targets) correspond
+to compiler names; e.g. intel = Intel F95 compiler, 
+gnu = GNU g77 compiler, sun = Sun Solaris compiler, etc.
+
+The source code is by default configured for single precision
+real numbers.  If double precision is desired, the Makefile must
+be modified with the appropriate compiler options for promoting
+real to double precision as well as promoting constants to double
+precision (this is often "-r8" on some, but not all, compilers).
+
+
+Complex Transform Routines
+__________________________
+
+CFFT1I    1D complex initialization
+CFFT1B    1D complex backward
+CFFT1F    1D complex forward
+
+CFFT2I    2D complex initialization
+CFFT2B    2D complex backward
+CFFT2F    2D complex forward
+
+CFFTMI    multiple complex initialization
+CFFTMB    multiple complex backward
+CFFTMF    multiple complex forward
+
+
+Real Transform Routines
+_______________________
+
+RFFT1I    1D real initialization
+RFFT1B    1D real backward
+RFFT1F    1D real forward
+
+RFFT2I    2D real initialization
+RFFT2B    2D real backward
+RFFT2F    2D real forward
+
+RFFTMI    multiple real initialization
+RFFTMB    multiple real backward
+RFFTMF    multiple real forward
+
+
+Real Cosine Transform Routines
+______________________________
+
+COST1I    1D real cosine initialization
+COST1B    1D real cosine backward
+COST1F    1D real cosine forward
+
+COSTMI    multiple real cosine initialization
+COSTMB    multiple real cosine backward
+COSTMF    multiple real cosine forward
+
+
+Real Sine Transform Routines
+____________________________
+
+SINT1I    1D real sine initialization
+SINT1B    1D real sine backward
+SINT1F    1D real sine forward
+
+SINTMI    multiple real sine initialization
+SINTMB    multiple real sine backward
+SINTMF    multiple real sine forward
+
+
+Real Quarter-Cosine Transform Routines
+______________________________________
+
+COSQ1I    1D real quarter-cosine initialization
+COSQ1B    1D real quarter-cosine backward
+COSQ1F    1D real quarter-cosine forward
+
+COSQMI    multiple real quarter-cosine initialization
+COSQMB    multiple real quarter-cosine backward
+COSQMF    multiple real quarter-cosine forward
+
+
+Real Quarter-Sine Transform Routines
+____________________________________
+
+SINQ1I    1D real quarter-sine initialization
+SINQ1B    1D real quarter-sine backward
+SINQ1F    1D real quarter-sine forward
+
+SINQMI    multiple real quarter-sine initialization
+SINQMB    multiple real quarter-sine backward
+SINQMF    multiple real quarter-sine forward
+
+
+Library FFTPACK5 contains 1D, 2D, and multiple fast Fourier
+subroutines, written in Fortran 77, for transforming real and complex
+data, real even and odd wave data, and real even and odd quarter-wave
+data.
+
+All of the FFTPACK5 routines listed above are grouped in triplets
+e.g. {CFFT1I, CFFT1F, CFFT1B}.  The suffix "I" denotes "initialize",
+"F" denotes "forward" (as in "forward transform") and "B" denotes
+"backward".  In an application program, before calling "B" or "F"
+routines for the first time, or before calling them with a different
+length, users must initialize an array by calling the "I" routine of
+the appropriate pair or triplet.  Note that "I" routines need not be
+called each time before a "B" or "F" routine is called.
+
+All of the transform routines in FFTPACK5 are normalized.
+
+Error messages are written to unit 6 by routine XERFFT.  The
+standard version of XERFFT issues an error message and halts execution,
+so that no FFTPACK routine will return to the calling program with
+error return IER different than zero.  Users may consider modifying the
+STOP statement in order to call system-specific exception-handling
+facilities.
+
+FFTPACK5 is written in standard Fortran 77 except for several
+instances where arrays of type REAL or COMPLEX are passed to a
+subroutine and used as a different type.
+
+ (1) "Vectorizing the Fast Fourier Transforms", by Paul Swarztrauber,
+     Parallel Computations, G. Rodrigue, ed., Academic Press,
+     New York 1982.
+
+ (2) "Fast Fourier Transforms Algorithms for Vector Computers", by
+     Paul Swarztrauber, Parallel Computing, (1984) pp.45-63.
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f2kb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f2kb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f2kb.F	(revision 17)
@@ -0,0 +1,42 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: c1f2kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE C1F2KB (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
+      REAL  CC(IN1,L1,IDO,2),CH(IN2,L1,2,IDO),WA(IDO,1,2) 
+!                                                                       
+      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
+      DO 101 K=1,L1 
+         CHOLD1 = CC(1,K,1,1)+CC(1,K,1,2) 
+         CC(1,K,1,2) = CC(1,K,1,1)-CC(1,K,1,2) 
+         CC(1,K,1,1) = CHOLD1 
+         CHOLD2 = CC(2,K,1,1)+CC(2,K,1,2) 
+         CC(2,K,1,2) = CC(2,K,1,1)-CC(2,K,1,2) 
+         CC(2,K,1,1) = CHOLD2 
+  101 END DO 
+      RETURN 
+  102 DO 103 K=1,L1 
+         CH(1,K,1,1) = CC(1,K,1,1)+CC(1,K,1,2) 
+         CH(1,K,2,1) = CC(1,K,1,1)-CC(1,K,1,2) 
+         CH(2,K,1,1) = CC(2,K,1,1)+CC(2,K,1,2) 
+         CH(2,K,2,1) = CC(2,K,1,1)-CC(2,K,1,2) 
+  103 END DO 
+      IF(IDO .EQ. 1) RETURN 
+      DO 105 I=2,IDO 
+         DO 104 K=1,L1 
+            CH(1,K,1,I) = CC(1,K,I,1)+CC(1,K,I,2) 
+            TR2 = CC(1,K,I,1)-CC(1,K,I,2) 
+            CH(2,K,1,I) = CC(2,K,I,1)+CC(2,K,I,2) 
+            TI2 = CC(2,K,I,1)-CC(2,K,I,2) 
+            CH(2,K,2,I) = WA(I,1,1)*TI2+WA(I,1,2)*TR2 
+            CH(1,K,2,I) = WA(I,1,1)*TR2-WA(I,1,2)*TI2 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f2kf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f2kf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f2kf.F	(revision 17)
@@ -0,0 +1,50 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: c1f2kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE C1F2KF (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
+      REAL  CC(IN1,L1,IDO,2),CH(IN2,L1,2,IDO),WA(IDO,1,2) 
+!                                                                       
+      IF (IDO .GT. 1) GO TO 102 
+      SN = 1./REAL(2*L1) 
+      IF (NA .EQ. 1) GO TO 106 
+      DO 101 K=1,L1 
+         CHOLD1 = SN*(CC(1,K,1,1)+CC(1,K,1,2)) 
+         CC(1,K,1,2) = SN*(CC(1,K,1,1)-CC(1,K,1,2)) 
+         CC(1,K,1,1) = CHOLD1 
+         CHOLD2 = SN*(CC(2,K,1,1)+CC(2,K,1,2)) 
+         CC(2,K,1,2) = SN*(CC(2,K,1,1)-CC(2,K,1,2)) 
+         CC(2,K,1,1) = CHOLD2 
+  101 END DO 
+      RETURN 
+  106 DO 107 K=1,L1 
+         CH(1,K,1,1) = SN*(CC(1,K,1,1)+CC(1,K,1,2)) 
+         CH(1,K,2,1) = SN*(CC(1,K,1,1)-CC(1,K,1,2)) 
+         CH(2,K,1,1) = SN*(CC(2,K,1,1)+CC(2,K,1,2)) 
+         CH(2,K,2,1) = SN*(CC(2,K,1,1)-CC(2,K,1,2)) 
+  107 END DO 
+      RETURN 
+  102 DO 103 K=1,L1 
+         CH(1,K,1,1) = CC(1,K,1,1)+CC(1,K,1,2) 
+         CH(1,K,2,1) = CC(1,K,1,1)-CC(1,K,1,2) 
+         CH(2,K,1,1) = CC(2,K,1,1)+CC(2,K,1,2) 
+         CH(2,K,2,1) = CC(2,K,1,1)-CC(2,K,1,2) 
+  103 END DO 
+      DO 105 I=2,IDO 
+         DO 104 K=1,L1 
+            CH(1,K,1,I) = CC(1,K,I,1)+CC(1,K,I,2) 
+            TR2 = CC(1,K,I,1)-CC(1,K,I,2) 
+            CH(2,K,1,I) = CC(2,K,I,1)+CC(2,K,I,2) 
+            TI2 = CC(2,K,I,1)-CC(2,K,I,2) 
+            CH(2,K,2,I) = WA(I,1,1)*TI2-WA(I,1,2)*TR2 
+            CH(1,K,2,I) = WA(I,1,1)*TR2+WA(I,1,2)*TI2 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f3kb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f3kb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f3kb.F	(revision 17)
@@ -0,0 +1,67 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: c1f3kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE C1F3KB (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
+      REAL  CC(IN1,L1,IDO,3),CH(IN2,L1,3,IDO),WA(IDO,2,2) 
+      DATA TAUR,TAUI /-.5,.866025403784439/ 
+!                                                                       
+      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
+      DO 101 K=1,L1 
+         TR2 = CC(1,K,1,2)+CC(1,K,1,3) 
+         CR2 = CC(1,K,1,1)+TAUR*TR2 
+         CC(1,K,1,1) = CC(1,K,1,1)+TR2 
+         TI2 = CC(2,K,1,2)+CC(2,K,1,3) 
+         CI2 = CC(2,K,1,1)+TAUR*TI2 
+         CC(2,K,1,1) = CC(2,K,1,1)+TI2 
+         CR3 = TAUI*(CC(1,K,1,2)-CC(1,K,1,3)) 
+         CI3 = TAUI*(CC(2,K,1,2)-CC(2,K,1,3)) 
+         CC(1,K,1,2) = CR2-CI3 
+         CC(1,K,1,3) = CR2+CI3 
+         CC(2,K,1,2) = CI2+CR3 
+         CC(2,K,1,3) = CI2-CR3 
+  101 END DO 
+      RETURN 
+  102 DO 103 K=1,L1 
+         TR2 = CC(1,K,1,2)+CC(1,K,1,3) 
+         CR2 = CC(1,K,1,1)+TAUR*TR2 
+         CH(1,K,1,1) = CC(1,K,1,1)+TR2 
+         TI2 = CC(2,K,1,2)+CC(2,K,1,3) 
+         CI2 = CC(2,K,1,1)+TAUR*TI2 
+         CH(2,K,1,1) = CC(2,K,1,1)+TI2 
+         CR3 = TAUI*(CC(1,K,1,2)-CC(1,K,1,3)) 
+         CI3 = TAUI*(CC(2,K,1,2)-CC(2,K,1,3)) 
+         CH(1,K,2,1) = CR2-CI3 
+         CH(1,K,3,1) = CR2+CI3 
+         CH(2,K,2,1) = CI2+CR3 
+         CH(2,K,3,1) = CI2-CR3 
+  103 END DO 
+      IF (IDO .EQ. 1) RETURN 
+      DO 105 I=2,IDO 
+        DO 104 K=1,L1 
+            TR2 = CC(1,K,I,2)+CC(1,K,I,3) 
+            CR2 = CC(1,K,I,1)+TAUR*TR2 
+            CH(1,K,1,I) = CC(1,K,I,1)+TR2 
+            TI2 = CC(2,K,I,2)+CC(2,K,I,3) 
+            CI2 = CC(2,K,I,1)+TAUR*TI2 
+            CH(2,K,1,I) = CC(2,K,I,1)+TI2 
+            CR3 = TAUI*(CC(1,K,I,2)-CC(1,K,I,3)) 
+            CI3 = TAUI*(CC(2,K,I,2)-CC(2,K,I,3)) 
+            DR2 = CR2-CI3 
+            DR3 = CR2+CI3 
+            DI2 = CI2+CR3 
+            DI3 = CI2-CR3 
+            CH(2,K,2,I) = WA(I,1,1)*DI2+WA(I,1,2)*DR2 
+            CH(1,K,2,I) = WA(I,1,1)*DR2-WA(I,1,2)*DI2 
+            CH(2,K,3,I) = WA(I,2,1)*DI3+WA(I,2,2)*DR3 
+            CH(1,K,3,I) = WA(I,2,1)*DR3-WA(I,2,2)*DI3 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f3kf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f3kf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f3kf.F	(revision 17)
@@ -0,0 +1,83 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: c1f3kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE C1F3KF (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
+      REAL  CC(IN1,L1,IDO,3),CH(IN2,L1,3,IDO),WA(IDO,2,2) 
+      DATA TAUR,TAUI /-.5,-.866025403784439/ 
+!                                                                       
+      IF (IDO .GT. 1) GO TO 102 
+      SN = 1./REAL(3*L1) 
+      IF (NA .EQ. 1) GO TO 106 
+      DO 101 K=1,L1 
+         TR2 = CC(1,K,1,2)+CC(1,K,1,3) 
+         CR2 = CC(1,K,1,1)+TAUR*TR2 
+         CC(1,K,1,1) = SN*(CC(1,K,1,1)+TR2) 
+         TI2 = CC(2,K,1,2)+CC(2,K,1,3) 
+         CI2 = CC(2,K,1,1)+TAUR*TI2 
+         CC(2,K,1,1) = SN*(CC(2,K,1,1)+TI2) 
+         CR3 = TAUI*(CC(1,K,1,2)-CC(1,K,1,3)) 
+         CI3 = TAUI*(CC(2,K,1,2)-CC(2,K,1,3)) 
+         CC(1,K,1,2) = SN*(CR2-CI3) 
+         CC(1,K,1,3) = SN*(CR2+CI3) 
+         CC(2,K,1,2) = SN*(CI2+CR3) 
+         CC(2,K,1,3) = SN*(CI2-CR3) 
+  101 END DO 
+      RETURN 
+  106 DO 107 K=1,L1 
+         TR2 = CC(1,K,1,2)+CC(1,K,1,3) 
+         CR2 = CC(1,K,1,1)+TAUR*TR2 
+         CH(1,K,1,1) = SN*(CC(1,K,1,1)+TR2) 
+         TI2 = CC(2,K,1,2)+CC(2,K,1,3) 
+         CI2 = CC(2,K,1,1)+TAUR*TI2 
+         CH(2,K,1,1) = SN*(CC(2,K,1,1)+TI2) 
+         CR3 = TAUI*(CC(1,K,1,2)-CC(1,K,1,3)) 
+         CI3 = TAUI*(CC(2,K,1,2)-CC(2,K,1,3)) 
+         CH(1,K,2,1) = SN*(CR2-CI3) 
+         CH(1,K,3,1) = SN*(CR2+CI3) 
+         CH(2,K,2,1) = SN*(CI2+CR3) 
+         CH(2,K,3,1) = SN*(CI2-CR3) 
+  107 END DO 
+      RETURN 
+  102 DO 103 K=1,L1 
+         TR2 = CC(1,K,1,2)+CC(1,K,1,3) 
+         CR2 = CC(1,K,1,1)+TAUR*TR2 
+         CH(1,K,1,1) = CC(1,K,1,1)+TR2 
+         TI2 = CC(2,K,1,2)+CC(2,K,1,3) 
+         CI2 = CC(2,K,1,1)+TAUR*TI2 
+         CH(2,K,1,1) = CC(2,K,1,1)+TI2 
+         CR3 = TAUI*(CC(1,K,1,2)-CC(1,K,1,3)) 
+         CI3 = TAUI*(CC(2,K,1,2)-CC(2,K,1,3)) 
+         CH(1,K,2,1) = CR2-CI3 
+         CH(1,K,3,1) = CR2+CI3 
+         CH(2,K,2,1) = CI2+CR3 
+         CH(2,K,3,1) = CI2-CR3 
+  103 END DO 
+      DO 105 I=2,IDO 
+        DO 104 K=1,L1 
+            TR2 = CC(1,K,I,2)+CC(1,K,I,3) 
+            CR2 = CC(1,K,I,1)+TAUR*TR2 
+            CH(1,K,1,I) = CC(1,K,I,1)+TR2 
+            TI2 = CC(2,K,I,2)+CC(2,K,I,3) 
+            CI2 = CC(2,K,I,1)+TAUR*TI2 
+            CH(2,K,1,I) = CC(2,K,I,1)+TI2 
+            CR3 = TAUI*(CC(1,K,I,2)-CC(1,K,I,3)) 
+            CI3 = TAUI*(CC(2,K,I,2)-CC(2,K,I,3)) 
+            DR2 = CR2-CI3 
+            DR3 = CR2+CI3 
+            DI2 = CI2+CR3 
+            DI3 = CI2-CR3 
+            CH(2,K,2,I) = WA(I,1,1)*DI2-WA(I,1,2)*DR2 
+            CH(1,K,2,I) = WA(I,1,1)*DR2+WA(I,1,2)*DI2 
+            CH(2,K,3,I) = WA(I,2,1)*DI3-WA(I,2,2)*DR3 
+            CH(1,K,3,I) = WA(I,2,1)*DR3+WA(I,2,2)*DI3 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f4kb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f4kb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f4kb.F	(revision 17)
@@ -0,0 +1,82 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: c1f4kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE C1F4KB (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
+      REAL CC(IN1,L1,IDO,4),CH(IN2,L1,4,IDO),WA(IDO,3,2) 
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
+      DO 101 K=1,L1 
+         TI1 = CC(2,K,1,1)-CC(2,K,1,3) 
+         TI2 = CC(2,K,1,1)+CC(2,K,1,3) 
+         TR4 = CC(2,K,1,4)-CC(2,K,1,2) 
+         TI3 = CC(2,K,1,2)+CC(2,K,1,4) 
+         TR1 = CC(1,K,1,1)-CC(1,K,1,3) 
+         TR2 = CC(1,K,1,1)+CC(1,K,1,3) 
+         TI4 = CC(1,K,1,2)-CC(1,K,1,4) 
+         TR3 = CC(1,K,1,2)+CC(1,K,1,4) 
+         CC(1,K,1,1) = TR2+TR3 
+         CC(1,K,1,3) = TR2-TR3 
+         CC(2,K,1,1) = TI2+TI3 
+         CC(2,K,1,3) = TI2-TI3 
+         CC(1,K,1,2) = TR1+TR4 
+         CC(1,K,1,4) = TR1-TR4 
+         CC(2,K,1,2) = TI1+TI4 
+         CC(2,K,1,4) = TI1-TI4 
+  101 END DO 
+      RETURN 
+  102 DO 103 K=1,L1 
+         TI1 = CC(2,K,1,1)-CC(2,K,1,3) 
+         TI2 = CC(2,K,1,1)+CC(2,K,1,3) 
+         TR4 = CC(2,K,1,4)-CC(2,K,1,2) 
+         TI3 = CC(2,K,1,2)+CC(2,K,1,4) 
+         TR1 = CC(1,K,1,1)-CC(1,K,1,3) 
+         TR2 = CC(1,K,1,1)+CC(1,K,1,3) 
+         TI4 = CC(1,K,1,2)-CC(1,K,1,4) 
+         TR3 = CC(1,K,1,2)+CC(1,K,1,4) 
+         CH(1,K,1,1) = TR2+TR3 
+         CH(1,K,3,1) = TR2-TR3 
+         CH(2,K,1,1) = TI2+TI3 
+         CH(2,K,3,1) = TI2-TI3 
+         CH(1,K,2,1) = TR1+TR4 
+         CH(1,K,4,1) = TR1-TR4 
+         CH(2,K,2,1) = TI1+TI4 
+         CH(2,K,4,1) = TI1-TI4 
+  103 END DO 
+      IF(IDO .EQ. 1) RETURN 
+      DO 105 I=2,IDO 
+         DO 104 K=1,L1 
+            TI1 = CC(2,K,I,1)-CC(2,K,I,3) 
+            TI2 = CC(2,K,I,1)+CC(2,K,I,3) 
+            TI3 = CC(2,K,I,2)+CC(2,K,I,4) 
+            TR4 = CC(2,K,I,4)-CC(2,K,I,2) 
+            TR1 = CC(1,K,I,1)-CC(1,K,I,3) 
+            TR2 = CC(1,K,I,1)+CC(1,K,I,3) 
+            TI4 = CC(1,K,I,2)-CC(1,K,I,4) 
+            TR3 = CC(1,K,I,2)+CC(1,K,I,4) 
+            CH(1,K,1,I) = TR2+TR3 
+            CR3 = TR2-TR3 
+            CH(2,K,1,I) = TI2+TI3 
+            CI3 = TI2-TI3 
+            CR2 = TR1+TR4 
+            CR4 = TR1-TR4 
+            CI2 = TI1+TI4 
+            CI4 = TI1-TI4 
+            CH(1,K,2,I) = WA(I,1,1)*CR2-WA(I,1,2)*CI2 
+            CH(2,K,2,I) = WA(I,1,1)*CI2+WA(I,1,2)*CR2 
+            CH(1,K,3,I) = WA(I,2,1)*CR3-WA(I,2,2)*CI3 
+            CH(2,K,3,I) = WA(I,2,1)*CI3+WA(I,2,2)*CR3 
+            CH(1,K,4,I) = WA(I,3,1)*CR4-WA(I,3,2)*CI4 
+            CH(2,K,4,I) = WA(I,3,1)*CI4+WA(I,3,2)*CR4 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f4kf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f4kf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f4kf.F	(revision 17)
@@ -0,0 +1,102 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: c1f4kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE C1F4KF (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
+      REAL CC(IN1,L1,IDO,4),CH(IN2,L1,4,IDO),WA(IDO,3,2) 
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      IF (IDO .GT. 1) GO TO 102 
+      SN = 1./REAL(4*L1) 
+      IF (NA .EQ. 1) GO TO 106 
+      DO 101 K=1,L1 
+         TI1 = CC(2,K,1,1)-CC(2,K,1,3) 
+         TI2 = CC(2,K,1,1)+CC(2,K,1,3) 
+         TR4 = CC(2,K,1,2)-CC(2,K,1,4) 
+         TI3 = CC(2,K,1,2)+CC(2,K,1,4) 
+         TR1 = CC(1,K,1,1)-CC(1,K,1,3) 
+         TR2 = CC(1,K,1,1)+CC(1,K,1,3) 
+         TI4 = CC(1,K,1,4)-CC(1,K,1,2) 
+         TR3 = CC(1,K,1,2)+CC(1,K,1,4) 
+         CC(1,K,1,1) = SN*(TR2+TR3) 
+         CC(1,K,1,3) = SN*(TR2-TR3) 
+         CC(2,K,1,1) = SN*(TI2+TI3) 
+         CC(2,K,1,3) = SN*(TI2-TI3) 
+         CC(1,K,1,2) = SN*(TR1+TR4) 
+         CC(1,K,1,4) = SN*(TR1-TR4) 
+         CC(2,K,1,2) = SN*(TI1+TI4) 
+         CC(2,K,1,4) = SN*(TI1-TI4) 
+  101 END DO 
+      RETURN 
+  106 DO 107 K=1,L1 
+         TI1 = CC(2,K,1,1)-CC(2,K,1,3) 
+         TI2 = CC(2,K,1,1)+CC(2,K,1,3) 
+         TR4 = CC(2,K,1,2)-CC(2,K,1,4) 
+         TI3 = CC(2,K,1,2)+CC(2,K,1,4) 
+         TR1 = CC(1,K,1,1)-CC(1,K,1,3) 
+         TR2 = CC(1,K,1,1)+CC(1,K,1,3) 
+         TI4 = CC(1,K,1,4)-CC(1,K,1,2) 
+         TR3 = CC(1,K,1,2)+CC(1,K,1,4) 
+         CH(1,K,1,1) = SN*(TR2+TR3) 
+         CH(1,K,3,1) = SN*(TR2-TR3) 
+         CH(2,K,1,1) = SN*(TI2+TI3) 
+         CH(2,K,3,1) = SN*(TI2-TI3) 
+         CH(1,K,2,1) = SN*(TR1+TR4) 
+         CH(1,K,4,1) = SN*(TR1-TR4) 
+         CH(2,K,2,1) = SN*(TI1+TI4) 
+         CH(2,K,4,1) = SN*(TI1-TI4) 
+  107 END DO 
+      RETURN 
+  102 DO 103 K=1,L1 
+         TI1 = CC(2,K,1,1)-CC(2,K,1,3) 
+         TI2 = CC(2,K,1,1)+CC(2,K,1,3) 
+         TR4 = CC(2,K,1,2)-CC(2,K,1,4) 
+         TI3 = CC(2,K,1,2)+CC(2,K,1,4) 
+         TR1 = CC(1,K,1,1)-CC(1,K,1,3) 
+         TR2 = CC(1,K,1,1)+CC(1,K,1,3) 
+         TI4 = CC(1,K,1,4)-CC(1,K,1,2) 
+         TR3 = CC(1,K,1,2)+CC(1,K,1,4) 
+         CH(1,K,1,1) = TR2+TR3 
+         CH(1,K,3,1) = TR2-TR3 
+         CH(2,K,1,1) = TI2+TI3 
+         CH(2,K,3,1) = TI2-TI3 
+         CH(1,K,2,1) = TR1+TR4 
+         CH(1,K,4,1) = TR1-TR4 
+         CH(2,K,2,1) = TI1+TI4 
+         CH(2,K,4,1) = TI1-TI4 
+  103 END DO 
+      DO 105 I=2,IDO 
+         DO 104 K=1,L1 
+            TI1 = CC(2,K,I,1)-CC(2,K,I,3) 
+            TI2 = CC(2,K,I,1)+CC(2,K,I,3) 
+            TI3 = CC(2,K,I,2)+CC(2,K,I,4) 
+            TR4 = CC(2,K,I,2)-CC(2,K,I,4) 
+            TR1 = CC(1,K,I,1)-CC(1,K,I,3) 
+            TR2 = CC(1,K,I,1)+CC(1,K,I,3) 
+            TI4 = CC(1,K,I,4)-CC(1,K,I,2) 
+            TR3 = CC(1,K,I,2)+CC(1,K,I,4) 
+            CH(1,K,1,I) = TR2+TR3 
+            CR3 = TR2-TR3 
+            CH(2,K,1,I) = TI2+TI3 
+            CI3 = TI2-TI3 
+            CR2 = TR1+TR4 
+            CR4 = TR1-TR4 
+            CI2 = TI1+TI4 
+            CI4 = TI1-TI4 
+            CH(1,K,2,I) = WA(I,1,1)*CR2+WA(I,1,2)*CI2 
+            CH(2,K,2,I) = WA(I,1,1)*CI2-WA(I,1,2)*CR2 
+            CH(1,K,3,I) = WA(I,2,1)*CR3+WA(I,2,2)*CI3 
+            CH(2,K,3,I) = WA(I,2,1)*CI3-WA(I,2,2)*CR3 
+            CH(1,K,4,I) = WA(I,3,1)*CR4+WA(I,3,2)*CI4 
+            CH(2,K,4,I) = WA(I,3,1)*CI4-WA(I,3,2)*CR4 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f5kb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f5kb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f5kb.F	(revision 17)
@@ -0,0 +1,118 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: c1f5kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE C1F5KB (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
+      REAL  CC(IN1,L1,IDO,5),CH(IN2,L1,5,IDO),WA(IDO,4,2) 
+      DATA TR11,TI11,TR12,TI12 /.3090169943749474,.9510565162951536,    &
+     &-.8090169943749474,.5877852522924731/                             
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
+      DO 101 K=1,L1 
+         TI5 = CC(2,K,1,2)-CC(2,K,1,5) 
+         TI2 = CC(2,K,1,2)+CC(2,K,1,5) 
+         TI4 = CC(2,K,1,3)-CC(2,K,1,4) 
+         TI3 = CC(2,K,1,3)+CC(2,K,1,4) 
+         TR5 = CC(1,K,1,2)-CC(1,K,1,5) 
+         TR2 = CC(1,K,1,2)+CC(1,K,1,5) 
+         TR4 = CC(1,K,1,3)-CC(1,K,1,4) 
+         TR3 = CC(1,K,1,3)+CC(1,K,1,4) 
+         CHOLD1 = CC(1,K,1,1)+TR2+TR3 
+         CHOLD2 = CC(2,K,1,1)+TI2+TI3 
+         CR2 = CC(1,K,1,1)+TR11*TR2+TR12*TR3 
+         CI2 = CC(2,K,1,1)+TR11*TI2+TR12*TI3 
+         CR3 = CC(1,K,1,1)+TR12*TR2+TR11*TR3 
+         CI3 = CC(2,K,1,1)+TR12*TI2+TR11*TI3 
+         CC(1,K,1,1) = CHOLD1 
+         CC(2,K,1,1) = CHOLD2 
+         CR5 = TI11*TR5+TI12*TR4 
+         CI5 = TI11*TI5+TI12*TI4 
+         CR4 = TI12*TR5-TI11*TR4 
+         CI4 = TI12*TI5-TI11*TI4 
+         CC(1,K,1,2) = CR2-CI5 
+         CC(1,K,1,5) = CR2+CI5 
+         CC(2,K,1,2) = CI2+CR5 
+         CC(2,K,1,3) = CI3+CR4 
+         CC(1,K,1,3) = CR3-CI4 
+         CC(1,K,1,4) = CR3+CI4 
+         CC(2,K,1,4) = CI3-CR4 
+         CC(2,K,1,5) = CI2-CR5 
+  101 END DO 
+      RETURN 
+  102 DO 103 K=1,L1 
+         TI5 = CC(2,K,1,2)-CC(2,K,1,5) 
+         TI2 = CC(2,K,1,2)+CC(2,K,1,5) 
+         TI4 = CC(2,K,1,3)-CC(2,K,1,4) 
+         TI3 = CC(2,K,1,3)+CC(2,K,1,4) 
+         TR5 = CC(1,K,1,2)-CC(1,K,1,5) 
+         TR2 = CC(1,K,1,2)+CC(1,K,1,5) 
+         TR4 = CC(1,K,1,3)-CC(1,K,1,4) 
+         TR3 = CC(1,K,1,3)+CC(1,K,1,4) 
+         CH(1,K,1,1) = CC(1,K,1,1)+TR2+TR3 
+         CH(2,K,1,1) = CC(2,K,1,1)+TI2+TI3 
+         CR2 = CC(1,K,1,1)+TR11*TR2+TR12*TR3 
+         CI2 = CC(2,K,1,1)+TR11*TI2+TR12*TI3 
+         CR3 = CC(1,K,1,1)+TR12*TR2+TR11*TR3 
+         CI3 = CC(2,K,1,1)+TR12*TI2+TR11*TI3 
+         CR5 = TI11*TR5+TI12*TR4 
+         CI5 = TI11*TI5+TI12*TI4 
+         CR4 = TI12*TR5-TI11*TR4 
+         CI4 = TI12*TI5-TI11*TI4 
+         CH(1,K,2,1) = CR2-CI5 
+         CH(1,K,5,1) = CR2+CI5 
+         CH(2,K,2,1) = CI2+CR5 
+         CH(2,K,3,1) = CI3+CR4 
+         CH(1,K,3,1) = CR3-CI4 
+         CH(1,K,4,1) = CR3+CI4 
+         CH(2,K,4,1) = CI3-CR4 
+         CH(2,K,5,1) = CI2-CR5 
+  103 END DO 
+      IF(IDO .EQ. 1) RETURN 
+      DO 105 I=2,IDO 
+         DO 104 K=1,L1 
+            TI5 = CC(2,K,I,2)-CC(2,K,I,5) 
+            TI2 = CC(2,K,I,2)+CC(2,K,I,5) 
+            TI4 = CC(2,K,I,3)-CC(2,K,I,4) 
+            TI3 = CC(2,K,I,3)+CC(2,K,I,4) 
+            TR5 = CC(1,K,I,2)-CC(1,K,I,5) 
+            TR2 = CC(1,K,I,2)+CC(1,K,I,5) 
+            TR4 = CC(1,K,I,3)-CC(1,K,I,4) 
+            TR3 = CC(1,K,I,3)+CC(1,K,I,4) 
+            CH(1,K,1,I) = CC(1,K,I,1)+TR2+TR3 
+            CH(2,K,1,I) = CC(2,K,I,1)+TI2+TI3 
+            CR2 = CC(1,K,I,1)+TR11*TR2+TR12*TR3 
+            CI2 = CC(2,K,I,1)+TR11*TI2+TR12*TI3 
+            CR3 = CC(1,K,I,1)+TR12*TR2+TR11*TR3 
+            CI3 = CC(2,K,I,1)+TR12*TI2+TR11*TI3 
+            CR5 = TI11*TR5+TI12*TR4 
+            CI5 = TI11*TI5+TI12*TI4 
+            CR4 = TI12*TR5-TI11*TR4 
+            CI4 = TI12*TI5-TI11*TI4 
+            DR3 = CR3-CI4 
+            DR4 = CR3+CI4 
+            DI3 = CI3+CR4 
+            DI4 = CI3-CR4 
+            DR5 = CR2+CI5 
+            DR2 = CR2-CI5 
+            DI5 = CI2-CR5 
+            DI2 = CI2+CR5 
+            CH(1,K,2,I) = WA(I,1,1)*DR2-WA(I,1,2)*DI2 
+            CH(2,K,2,I) = WA(I,1,1)*DI2+WA(I,1,2)*DR2 
+            CH(1,K,3,I) = WA(I,2,1)*DR3-WA(I,2,2)*DI3 
+            CH(2,K,3,I) = WA(I,2,1)*DI3+WA(I,2,2)*DR3 
+            CH(1,K,4,I) = WA(I,3,1)*DR4-WA(I,3,2)*DI4 
+            CH(2,K,4,I) = WA(I,3,1)*DI4+WA(I,3,2)*DR4 
+            CH(1,K,5,I) = WA(I,4,1)*DR5-WA(I,4,2)*DI5 
+            CH(2,K,5,I) = WA(I,4,1)*DI5+WA(I,4,2)*DR5 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f5kf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f5kf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1f5kf.F	(revision 17)
@@ -0,0 +1,149 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: c1f5kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE C1F5KF (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
+      REAL  CC(IN1,L1,IDO,5),CH(IN2,L1,5,IDO),WA(IDO,4,2) 
+      DATA TR11,TI11,TR12,TI12 /.3090169943749474,-.9510565162951536,   &
+     &-.8090169943749474,-.5877852522924731/                            
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      IF (IDO .GT. 1) GO TO 102 
+      SN = 1./REAL(5*L1) 
+      IF (NA .EQ. 1) GO TO 106 
+      DO 101 K=1,L1 
+! rav    DO 101 M1=1,M1D,IM1                                            
+         TI5 = CC(2,K,1,2)-CC(2,K,1,5) 
+         TI2 = CC(2,K,1,2)+CC(2,K,1,5) 
+         TI4 = CC(2,K,1,3)-CC(2,K,1,4) 
+         TI3 = CC(2,K,1,3)+CC(2,K,1,4) 
+         TR5 = CC(1,K,1,2)-CC(1,K,1,5) 
+         TR2 = CC(1,K,1,2)+CC(1,K,1,5) 
+         TR4 = CC(1,K,1,3)-CC(1,K,1,4) 
+         TR3 = CC(1,K,1,3)+CC(1,K,1,4) 
+         CHOLD1 = SN*(CC(1,K,1,1)+TR2+TR3) 
+         CHOLD2 = SN*(CC(2,K,1,1)+TI2+TI3) 
+         CR2 = CC(1,K,1,1)+TR11*TR2+TR12*TR3 
+         CI2 = CC(2,K,1,1)+TR11*TI2+TR12*TI3 
+         CR3 = CC(1,K,1,1)+TR12*TR2+TR11*TR3 
+         CI3 = CC(2,K,1,1)+TR12*TI2+TR11*TI3 
+         CC(1,K,1,1) = CHOLD1 
+         CC(2,K,1,1) = CHOLD2 
+         CR5 = TI11*TR5+TI12*TR4 
+         CI5 = TI11*TI5+TI12*TI4 
+         CR4 = TI12*TR5-TI11*TR4 
+         CI4 = TI12*TI5-TI11*TI4 
+         CC(1,K,1,2) = SN*(CR2-CI5) 
+         CC(1,K,1,5) = SN*(CR2+CI5) 
+         CC(2,K,1,2) = SN*(CI2+CR5) 
+         CC(2,K,1,3) = SN*(CI3+CR4) 
+         CC(1,K,1,3) = SN*(CR3-CI4) 
+         CC(1,K,1,4) = SN*(CR3+CI4) 
+         CC(2,K,1,4) = SN*(CI3-CR4) 
+         CC(2,K,1,5) = SN*(CI2-CR5) 
+  101 END DO 
+      RETURN 
+  106 DO 107 K=1,L1 
+         TI5 = CC(2,K,1,2)-CC(2,K,1,5) 
+         TI2 = CC(2,K,1,2)+CC(2,K,1,5) 
+         TI4 = CC(2,K,1,3)-CC(2,K,1,4) 
+         TI3 = CC(2,K,1,3)+CC(2,K,1,4) 
+         TR5 = CC(1,K,1,2)-CC(1,K,1,5) 
+         TR2 = CC(1,K,1,2)+CC(1,K,1,5) 
+         TR4 = CC(1,K,1,3)-CC(1,K,1,4) 
+         TR3 = CC(1,K,1,3)+CC(1,K,1,4) 
+         CH(1,K,1,1) = SN*(CC(1,K,1,1)+TR2+TR3) 
+         CH(2,K,1,1) = SN*(CC(2,K,1,1)+TI2+TI3) 
+         CR2 = CC(1,K,1,1)+TR11*TR2+TR12*TR3 
+         CI2 = CC(2,K,1,1)+TR11*TI2+TR12*TI3 
+         CR3 = CC(1,K,1,1)+TR12*TR2+TR11*TR3 
+         CI3 = CC(2,K,1,1)+TR12*TI2+TR11*TI3 
+         CR5 = TI11*TR5+TI12*TR4 
+         CI5 = TI11*TI5+TI12*TI4 
+         CR4 = TI12*TR5-TI11*TR4 
+         CI4 = TI12*TI5-TI11*TI4 
+         CH(1,K,2,1) = SN*(CR2-CI5) 
+         CH(1,K,5,1) = SN*(CR2+CI5) 
+         CH(2,K,2,1) = SN*(CI2+CR5) 
+         CH(2,K,3,1) = SN*(CI3+CR4) 
+         CH(1,K,3,1) = SN*(CR3-CI4) 
+         CH(1,K,4,1) = SN*(CR3+CI4) 
+         CH(2,K,4,1) = SN*(CI3-CR4) 
+         CH(2,K,5,1) = SN*(CI2-CR5) 
+  107 END DO 
+      RETURN 
+  102 DO 103 K=1,L1 
+         TI5 = CC(2,K,1,2)-CC(2,K,1,5) 
+         TI2 = CC(2,K,1,2)+CC(2,K,1,5) 
+         TI4 = CC(2,K,1,3)-CC(2,K,1,4) 
+         TI3 = CC(2,K,1,3)+CC(2,K,1,4) 
+         TR5 = CC(1,K,1,2)-CC(1,K,1,5) 
+         TR2 = CC(1,K,1,2)+CC(1,K,1,5) 
+         TR4 = CC(1,K,1,3)-CC(1,K,1,4) 
+         TR3 = CC(1,K,1,3)+CC(1,K,1,4) 
+         CH(1,K,1,1) = CC(1,K,1,1)+TR2+TR3 
+         CH(2,K,1,1) = CC(2,K,1,1)+TI2+TI3 
+         CR2 = CC(1,K,1,1)+TR11*TR2+TR12*TR3 
+         CI2 = CC(2,K,1,1)+TR11*TI2+TR12*TI3 
+         CR3 = CC(1,K,1,1)+TR12*TR2+TR11*TR3 
+         CI3 = CC(2,K,1,1)+TR12*TI2+TR11*TI3 
+         CR5 = TI11*TR5+TI12*TR4 
+         CI5 = TI11*TI5+TI12*TI4 
+         CR4 = TI12*TR5-TI11*TR4 
+         CI4 = TI12*TI5-TI11*TI4 
+         CH(1,K,2,1) = CR2-CI5 
+         CH(1,K,5,1) = CR2+CI5 
+         CH(2,K,2,1) = CI2+CR5 
+         CH(2,K,3,1) = CI3+CR4 
+         CH(1,K,3,1) = CR3-CI4 
+         CH(1,K,4,1) = CR3+CI4 
+         CH(2,K,4,1) = CI3-CR4 
+         CH(2,K,5,1) = CI2-CR5 
+  103 END DO 
+      DO 105 I=2,IDO 
+         DO 104 K=1,L1 
+            TI5 = CC(2,K,I,2)-CC(2,K,I,5) 
+            TI2 = CC(2,K,I,2)+CC(2,K,I,5) 
+            TI4 = CC(2,K,I,3)-CC(2,K,I,4) 
+            TI3 = CC(2,K,I,3)+CC(2,K,I,4) 
+            TR5 = CC(1,K,I,2)-CC(1,K,I,5) 
+            TR2 = CC(1,K,I,2)+CC(1,K,I,5) 
+            TR4 = CC(1,K,I,3)-CC(1,K,I,4) 
+            TR3 = CC(1,K,I,3)+CC(1,K,I,4) 
+            CH(1,K,1,I) = CC(1,K,I,1)+TR2+TR3 
+            CH(2,K,1,I) = CC(2,K,I,1)+TI2+TI3 
+            CR2 = CC(1,K,I,1)+TR11*TR2+TR12*TR3 
+            CI2 = CC(2,K,I,1)+TR11*TI2+TR12*TI3 
+            CR3 = CC(1,K,I,1)+TR12*TR2+TR11*TR3 
+            CI3 = CC(2,K,I,1)+TR12*TI2+TR11*TI3 
+            CR5 = TI11*TR5+TI12*TR4 
+            CI5 = TI11*TI5+TI12*TI4 
+            CR4 = TI12*TR5-TI11*TR4 
+            CI4 = TI12*TI5-TI11*TI4 
+            DR3 = CR3-CI4 
+            DR4 = CR3+CI4 
+            DI3 = CI3+CR4 
+            DI4 = CI3-CR4 
+            DR5 = CR2+CI5 
+            DR2 = CR2-CI5 
+            DI5 = CI2-CR5 
+            DI2 = CI2+CR5 
+            CH(1,K,2,I) = WA(I,1,1)*DR2+WA(I,1,2)*DI2 
+            CH(2,K,2,I) = WA(I,1,1)*DI2-WA(I,1,2)*DR2 
+            CH(1,K,3,I) = WA(I,2,1)*DR3+WA(I,2,2)*DI3 
+            CH(2,K,3,I) = WA(I,2,1)*DI3-WA(I,2,2)*DR3 
+            CH(1,K,4,I) = WA(I,3,1)*DR4+WA(I,3,2)*DI4 
+            CH(2,K,4,I) = WA(I,3,1)*DI4-WA(I,3,2)*DR4 
+            CH(1,K,5,I) = WA(I,4,1)*DR5+WA(I,4,2)*DI5 
+            CH(2,K,5,I) = WA(I,4,1)*DI5-WA(I,4,2)*DR5 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1fgkb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1fgkb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1fgkb.F	(revision 17)
@@ -0,0 +1,111 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: c1fgkb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE C1FGKB (IDO,IP,L1,LID,NA,CC,CC1,IN1,                   &
+     &                                      CH,CH1,IN2,WA)              
+      REAL       CH(IN2,L1,IDO,IP) ,CC(IN1,L1,IP,IDO),                  &
+     &                CC1(IN1,LID,IP)    ,CH1(IN2,LID,IP)  ,            &
+     &                WA(IDO,IP-1,2)                                    
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      IPP2 = IP+2 
+      IPPH = (IP+1)/2 
+      DO 110 KI=1,LID 
+         CH1(1,KI,1) = CC1(1,KI,1) 
+         CH1(2,KI,1) = CC1(2,KI,1) 
+  110 END DO 
+      DO 111 J=2,IPPH 
+         JC = IPP2-J 
+         DO 112 KI=1,LID 
+            CH1(1,KI,J) =  CC1(1,KI,J)+CC1(1,KI,JC) 
+            CH1(1,KI,JC) = CC1(1,KI,J)-CC1(1,KI,JC) 
+            CH1(2,KI,J) =  CC1(2,KI,J)+CC1(2,KI,JC) 
+            CH1(2,KI,JC) = CC1(2,KI,J)-CC1(2,KI,JC) 
+  112    CONTINUE 
+  111 END DO 
+      DO 118 J=2,IPPH 
+         DO 117 KI=1,LID 
+            CC1(1,KI,1) = CC1(1,KI,1)+CH1(1,KI,J) 
+            CC1(2,KI,1) = CC1(2,KI,1)+CH1(2,KI,J) 
+  117    CONTINUE 
+  118 END DO 
+      DO 116 L=2,IPPH 
+         LC = IPP2-L 
+         DO 113 KI=1,LID 
+            CC1(1,KI,L) = CH1(1,KI,1)+WA(1,L-1,1)*CH1(1,KI,2) 
+            CC1(1,KI,LC) = WA(1,L-1,2)*CH1(1,KI,IP) 
+            CC1(2,KI,L) = CH1(2,KI,1)+WA(1,L-1,1)*CH1(2,KI,2) 
+            CC1(2,KI,LC) = WA(1,L-1,2)*CH1(2,KI,IP) 
+  113    CONTINUE 
+         DO 115 J=3,IPPH 
+            JC = IPP2-J 
+            IDLJ = MOD((L-1)*(J-1),IP) 
+            WAR = WA(1,IDLJ,1) 
+            WAI = WA(1,IDLJ,2) 
+            DO 114 KI=1,LID 
+               CC1(1,KI,L) = CC1(1,KI,L)+WAR*CH1(1,KI,J) 
+               CC1(1,KI,LC) = CC1(1,KI,LC)+WAI*CH1(1,KI,JC) 
+               CC1(2,KI,L) = CC1(2,KI,L)+WAR*CH1(2,KI,J) 
+               CC1(2,KI,LC) = CC1(2,KI,LC)+WAI*CH1(2,KI,JC) 
+  114       CONTINUE 
+  115    CONTINUE 
+  116 END DO 
+      IF(IDO.GT.1 .OR. NA.EQ.1) GO TO 136 
+      DO 120 J=2,IPPH 
+         JC = IPP2-J 
+         DO 119 KI=1,LID 
+            CHOLD1 = CC1(1,KI,J)-CC1(2,KI,JC) 
+            CHOLD2 = CC1(1,KI,J)+CC1(2,KI,JC) 
+            CC1(1,KI,J) = CHOLD1 
+            CC1(2,KI,JC) = CC1(2,KI,J)-CC1(1,KI,JC) 
+            CC1(2,KI,J) = CC1(2,KI,J)+CC1(1,KI,JC) 
+            CC1(1,KI,JC) = CHOLD2 
+  119    CONTINUE 
+  120 END DO 
+      RETURN 
+  136 DO 137 KI=1,LID 
+         CH1(1,KI,1) = CC1(1,KI,1) 
+         CH1(2,KI,1) = CC1(2,KI,1) 
+  137 END DO 
+      DO 135 J=2,IPPH 
+         JC = IPP2-J 
+         DO 134 KI=1,LID 
+            CH1(1,KI,J) = CC1(1,KI,J)-CC1(2,KI,JC) 
+            CH1(1,KI,JC) = CC1(1,KI,J)+CC1(2,KI,JC) 
+            CH1(2,KI,JC) = CC1(2,KI,J)-CC1(1,KI,JC) 
+            CH1(2,KI,J) = CC1(2,KI,J)+CC1(1,KI,JC) 
+  134    CONTINUE 
+  135 END DO 
+      IF (IDO .EQ. 1) RETURN 
+      DO 131 I=1,IDO 
+         DO 130 K=1,L1 
+            CC(1,K,1,I) = CH(1,K,I,1) 
+            CC(2,K,1,I) = CH(2,K,I,1) 
+  130    CONTINUE 
+  131 END DO 
+      DO 123 J=2,IP 
+         DO 122 K=1,L1 
+            CC(1,K,J,1) = CH(1,K,1,J) 
+            CC(2,K,J,1) = CH(2,K,1,J) 
+  122    CONTINUE 
+  123 END DO 
+      DO 126 J=2,IP 
+         DO 125 I=2,IDO 
+            DO 124 K=1,L1 
+               CC(1,K,J,I) = WA(I,J-1,1)*CH(1,K,I,J)                    &
+     &                      -WA(I,J-1,2)*CH(2,K,I,J)                    
+               CC(2,K,J,I) = WA(I,J-1,1)*CH(2,K,I,J)                    &
+     &                      +WA(I,J-1,2)*CH(1,K,I,J)                    
+  124       CONTINUE 
+  125    CONTINUE 
+  126 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1fgkf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1fgkf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1fgkf.F	(revision 17)
@@ -0,0 +1,130 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: c1fgkf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE C1FGKF (IDO,IP,L1,LID,NA,CC,CC1,IN1,                   &
+     &                                      CH,CH1,IN2,WA)              
+      REAL       CH(IN2,L1,IDO,IP) ,CC(IN1,L1,IP,IDO),                  &
+     &                CC1(IN1,LID,IP)    ,CH1(IN2,LID,IP)  ,            &
+     &                WA(IDO,IP-1,2)                                    
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      IPP2 = IP+2 
+      IPPH = (IP+1)/2 
+      DO 110 KI=1,LID 
+         CH1(1,KI,1) = CC1(1,KI,1) 
+         CH1(2,KI,1) = CC1(2,KI,1) 
+  110 END DO 
+      DO 111 J=2,IPPH 
+         JC = IPP2-J 
+         DO 112 KI=1,LID 
+            CH1(1,KI,J) =  CC1(1,KI,J)+CC1(1,KI,JC) 
+            CH1(1,KI,JC) = CC1(1,KI,J)-CC1(1,KI,JC) 
+            CH1(2,KI,J) =  CC1(2,KI,J)+CC1(2,KI,JC) 
+            CH1(2,KI,JC) = CC1(2,KI,J)-CC1(2,KI,JC) 
+  112    CONTINUE 
+  111 END DO 
+      DO 118 J=2,IPPH 
+         DO 117 KI=1,LID 
+            CC1(1,KI,1) = CC1(1,KI,1)+CH1(1,KI,J) 
+            CC1(2,KI,1) = CC1(2,KI,1)+CH1(2,KI,J) 
+  117    CONTINUE 
+  118 END DO 
+      DO 116 L=2,IPPH 
+         LC = IPP2-L 
+         DO 113 KI=1,LID 
+            CC1(1,KI,L) = CH1(1,KI,1)+WA(1,L-1,1)*CH1(1,KI,2) 
+            CC1(1,KI,LC) = -WA(1,L-1,2)*CH1(1,KI,IP) 
+            CC1(2,KI,L) = CH1(2,KI,1)+WA(1,L-1,1)*CH1(2,KI,2) 
+            CC1(2,KI,LC) = -WA(1,L-1,2)*CH1(2,KI,IP) 
+  113    CONTINUE 
+         DO 115 J=3,IPPH 
+            JC = IPP2-J 
+            IDLJ = MOD((L-1)*(J-1),IP) 
+            WAR = WA(1,IDLJ,1) 
+            WAI = -WA(1,IDLJ,2) 
+            DO 114 KI=1,LID 
+               CC1(1,KI,L) = CC1(1,KI,L)+WAR*CH1(1,KI,J) 
+               CC1(1,KI,LC) = CC1(1,KI,LC)+WAI*CH1(1,KI,JC) 
+               CC1(2,KI,L) = CC1(2,KI,L)+WAR*CH1(2,KI,J) 
+               CC1(2,KI,LC) = CC1(2,KI,LC)+WAI*CH1(2,KI,JC) 
+  114       CONTINUE 
+  115    CONTINUE 
+  116 END DO 
+      IF (IDO .GT. 1) GO TO 136 
+      SN = 1./REAL(IP*L1) 
+      IF (NA .EQ. 1) GO TO 146 
+      DO 149 KI=1,LID 
+         CC1(1,KI,1) = SN*CC1(1,KI,1) 
+         CC1(2,KI,1) = SN*CC1(2,KI,1) 
+  149 END DO 
+      DO 120 J=2,IPPH 
+         JC = IPP2-J 
+         DO 119 KI=1,LID 
+            CHOLD1 = SN*(CC1(1,KI,J)-CC1(2,KI,JC)) 
+            CHOLD2 = SN*(CC1(1,KI,J)+CC1(2,KI,JC)) 
+            CC1(1,KI,J) = CHOLD1 
+            CC1(2,KI,JC) = SN*(CC1(2,KI,J)-CC1(1,KI,JC)) 
+            CC1(2,KI,J) = SN*(CC1(2,KI,J)+CC1(1,KI,JC)) 
+            CC1(1,KI,JC) = CHOLD2 
+  119    CONTINUE 
+  120 END DO 
+      RETURN 
+  146 DO 147 KI=1,LID 
+         CH1(1,KI,1) = SN*CC1(1,KI,1) 
+         CH1(2,KI,1) = SN*CC1(2,KI,1) 
+  147 END DO 
+      DO 145 J=2,IPPH 
+         JC = IPP2-J 
+         DO 144 KI=1,LID 
+            CH1(1,KI,J) = SN*(CC1(1,KI,J)-CC1(2,KI,JC)) 
+            CH1(2,KI,J) = SN*(CC1(2,KI,J)+CC1(1,KI,JC)) 
+            CH1(1,KI,JC) = SN*(CC1(1,KI,J)+CC1(2,KI,JC)) 
+            CH1(2,KI,JC) = SN*(CC1(2,KI,J)-CC1(1,KI,JC)) 
+  144    CONTINUE 
+  145 END DO 
+      RETURN 
+  136 DO 137 KI=1,LID 
+         CH1(1,KI,1) = CC1(1,KI,1) 
+         CH1(2,KI,1) = CC1(2,KI,1) 
+  137 END DO 
+      DO 135 J=2,IPPH 
+         JC = IPP2-J 
+         DO 134 KI=1,LID 
+            CH1(1,KI,J) = CC1(1,KI,J)-CC1(2,KI,JC) 
+            CH1(2,KI,J) = CC1(2,KI,J)+CC1(1,KI,JC) 
+            CH1(1,KI,JC) = CC1(1,KI,J)+CC1(2,KI,JC) 
+            CH1(2,KI,JC) = CC1(2,KI,J)-CC1(1,KI,JC) 
+  134    CONTINUE 
+  135 END DO 
+      DO 131 I=1,IDO 
+         DO 130 K=1,L1 
+            CC(1,K,1,I) = CH(1,K,I,1) 
+            CC(2,K,1,I) = CH(2,K,I,1) 
+  130    CONTINUE 
+  131 END DO 
+      DO 123 J=2,IP 
+         DO 122 K=1,L1 
+            CC(1,K,J,1) = CH(1,K,1,J) 
+            CC(2,K,J,1) = CH(2,K,1,J) 
+  122    CONTINUE 
+  123 END DO 
+      DO 126 J=2,IP 
+         DO 125 I=2,IDO 
+            DO 124 K=1,L1 
+               CC(1,K,J,I) = WA(I,J-1,1)*CH(1,K,I,J)                    &
+     &                      +WA(I,J-1,2)*CH(2,K,I,J)                    
+               CC(2,K,J,I) = WA(I,J-1,1)*CH(2,K,I,J)                    &
+     &                      -WA(I,J-1,2)*CH(1,K,I,J)                    
+  124       CONTINUE 
+  125    CONTINUE 
+  126 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1fm1b.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1fm1b.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1fm1b.F	(revision 17)
@@ -0,0 +1,55 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: c1fm1b.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE C1FM1B (N,INC,C,CH,WA,FNF,FAC) 
+      COMPLEX       C(*) 
+      REAL       CH(*),     WA(*),     FAC(*) 
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      INC2 = INC+INC 
+      NF = FNF 
+      NA = 0 
+      L1 = 1 
+      IW = 1 
+      DO 125 K1=1,NF 
+         IP = FAC(K1) 
+         L2 = IP*L1 
+         IDO = N/L2 
+         LID = L1*IDO 
+         NBR = 1+NA+2*MIN(IP-2,4) 
+         GO TO (52,62,53,63,54,64,55,65,56,66),NBR 
+   52    CALL C1F2KB (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
+         GO TO 120 
+   62    CALL C1F2KB (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
+         GO TO 120 
+   53    CALL C1F3KB (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
+         GO TO 120 
+   63    CALL C1F3KB (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
+         GO TO 120 
+   54    CALL C1F4KB (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
+         GO TO 120 
+   64    CALL C1F4KB (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
+         GO TO 120 
+   55    CALL C1F5KB (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
+         GO TO 120 
+   65    CALL C1F5KB (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
+         GO TO 120 
+   56    CALL C1FGKB (IDO,IP,L1,LID,NA,C,C,INC2,CH,CH,2,                &
+     &     WA(IW))                                                      
+         GO TO 120 
+   66    CALL C1FGKB (IDO,IP,L1,LID,NA,CH,CH,2,C,C,                     &
+     &     INC2,WA(IW))                                                 
+  120    L1 = L2 
+         IW = IW+(IP-1)*(IDO+IDO) 
+         IF(IP .LE. 5) NA = 1-NA 
+  125 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1fm1f.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1fm1f.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/c1fm1f.F	(revision 17)
@@ -0,0 +1,56 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: c1fm1f.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE C1FM1F (N,INC,C,CH,WA,FNF,FAC) 
+      COMPLEX       C(*) 
+      REAL       CH(*),     WA(*),      FAC(*) 
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      INC2 = INC+INC 
+      NF = FNF 
+      NA = 0 
+      L1 = 1 
+      IW = 1 
+      DO 125 K1=1,NF 
+         IP = FAC(K1) 
+         L2 = IP*L1 
+         IDO = N/L2 
+         LID = L1*IDO 
+         NBR = 1+NA+2*MIN(IP-2,4) 
+         write(*,*) wa(iw),wa(iw+1) 
+         GO TO (52,62,53,63,54,64,55,65,56,66),NBR 
+   52    CALL C1F2KF (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
+         GO TO 120 
+   62    CALL C1F2KF (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
+         GO TO 120 
+   53    CALL C1F3KF (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
+         GO TO 120 
+   63    CALL C1F3KF (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
+         GO TO 120 
+   54    CALL C1F4KF (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
+         GO TO 120 
+   64    CALL C1F4KF (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
+         GO TO 120 
+   55    CALL C1F5KF (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
+         GO TO 120 
+   65    CALL C1F5KF (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
+         GO TO 120 
+   56    CALL C1FGKF (IDO,IP,L1,LID,NA,C,C,INC2,CH,CH,                  &
+     &     1,WA(IW))                                                    
+         GO TO 120 
+   66    CALL C1FGKF (IDO,IP,L1,LID,NA,CH,CH,2,C,C,                     &
+     &     INC2,WA(IW))                                                 
+  120    L1 = L2 
+         IW = IW+(IP-1)*(IDO+IDO) 
+         IF(IP .LE. 5) NA = 1-NA 
+  125 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft1b.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft1b.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft1b.F	(revision 17)
@@ -0,0 +1,36 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cfft1b.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CFFT1B (N, INC, C, LENC, WSAVE, LENSAV,                &
+     &                  WORK, LENWRK, IER)                              
+      INTEGER  N, INC, LENC, LENSAV, LENWRK, IER 
+      COMPLEX       C(LENC) 
+      REAL     WSAVE(LENSAV)     ,WORK(LENWRK) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENC .LT. INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('CFFT1B ', 6) 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) + 4) THEN 
+        IER = 2 
+        CALL XERFFT ('CFFT1B ', 8) 
+      ELSEIF (LENWRK .LT. 2*N) THEN 
+        IER = 3 
+        CALL XERFFT ('CFFT1B ', 10) 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+!                                                                       
+      IW1 = N+N+1 
+      CALL C1FM1B (N,INC,C,WORK,WSAVE,WSAVE(IW1),                       &
+     &                           WSAVE(IW1+1))                          
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft1f.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft1f.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft1f.F	(revision 17)
@@ -0,0 +1,36 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cfft1f.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CFFT1F (N, INC, C, LENC, WSAVE, LENSAV,                &
+     &                  WORK, LENWRK, IER)                              
+      INTEGER  N, INC, LENC, LENSAV, LENWRK, IER 
+      COMPLEX  C(LENC) 
+      REAL     WSAVE(LENSAV)     ,WORK(LENWRK) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENC .LT. INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('CFFT1F ', 6) 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) + 4) THEN 
+        IER = 2 
+        CALL XERFFT ('CFFT1F ', 8) 
+      ELSEIF (LENWRK .LT. 2*N) THEN 
+        IER = 3 
+        CALL XERFFT ('CFFTMF ', 10) 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+!                                                                       
+      IW1 = N+N+1 
+      CALL C1FM1F (N,INC,C,WORK,WSAVE,WSAVE(IW1),                       &
+     &                           WSAVE(IW1+1))                          
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft1i.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft1i.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft1i.F	(revision 17)
@@ -0,0 +1,27 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cfft1i.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CFFT1I (N, WSAVE, LENSAV, IER) 
+      INTEGER    N, LENSAV, IER 
+      REAL       WSAVE(LENSAV) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) + 4) THEN 
+        IER = 2 
+        CALL XERFFT ('CFFTMI ', 3) 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+!                                                                       
+      IW1 = N+N+1 
+      CALL MCFTI1 (N,WSAVE,WSAVE(IW1),WSAVE(IW1+1)) 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft2b.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft2b.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft2b.F	(revision 17)
@@ -0,0 +1,59 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cfft2b.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CFFT2B (LDIM, L, M, C, WSAVE, LENSAV,                  &
+     &                     WORK, LENWRK, IER)                           
+      INTEGER L, M, LDIM, LENSAV, LENWRK, IER 
+      COMPLEX C(LDIM,M) 
+      REAL WSAVE(LENSAV), WORK(LENWRK) 
+!                                                                       
+! Initialize error return                                               
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (L .GT. LDIM) THEN 
+        IER = 5 
+        CALL XERFFT ('CFFT2B', -2) 
+        GO TO 100 
+      ELSEIF (LENSAV .LT. 2*L + INT(LOG(REAL(L))) +                     &
+     &                    2*M + INT(LOG(REAL(M))) +8) THEN              
+        IER = 2 
+        CALL XERFFT ('CFFT2B', 6) 
+        GO TO 100 
+      ELSEIF (LENWRK .LT. 2*L*M) THEN 
+        IER = 3 
+        CALL XERFFT ('CFFT2B', 8) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+! Transform X lines of C array                                          
+      IW = 2*L+INT(LOG(REAL(L))*LOG(2.)) + 3 
+      CALL CFFTMB(L, 1, M, LDIM, C, (L-1) + LDIM*(M-1) +1,              &
+     &     WSAVE(IW), 2*M + INT(LOG(REAL(M))) + 4,                      &
+     &     WORK, 2*L*M, IER1)                                           
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('CFFT2B',-5) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+! Transform Y lines of C array                                          
+      IW = 1 
+      CALL CFFTMB (M, LDIM, L, 1, C, (M-1)*LDIM + L,                    &
+     &     WSAVE(IW), 2*L + INT(LOG(REAL(L))) + 4,                      &
+     &     WORK, 2*M*L, IER1)                                           
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('CFFT2B',-5) 
+      ENDIF 
+!                                                                       
+  100 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft2f.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft2f.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft2f.F	(revision 17)
@@ -0,0 +1,59 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cfft2f.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CFFT2F (LDIM, L, M, C, WSAVE, LENSAV,                  &
+     &                     WORK, LENWRK, IER)                           
+      INTEGER L, M, LDIM, LENSAV, LENWRK, IER 
+      COMPLEX C(LDIM,M) 
+      REAL WSAVE(LENSAV), WORK(LENWRK) 
+!                                                                       
+! Initialize error return                                               
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (L .GT. LDIM) THEN 
+        IER = 5 
+        CALL XERFFT ('CFFT2F', -2) 
+        GO TO 100 
+      ELSEIF (LENSAV .LT. 2*L + INT(LOG(REAL(L))) +                     &
+     &                    2*M + INT(LOG(REAL(M))) +8) THEN              
+        IER = 2 
+        CALL XERFFT ('CFFT2F', 6) 
+        GO TO 100 
+      ELSEIF (LENWRK .LT. 2*L*M) THEN 
+        IER = 3 
+        CALL XERFFT ('CFFT2F', 8) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+! Transform X lines of C array                                          
+      IW = 2*L+INT(LOG(REAL(L))*LOG(2.)) + 3 
+      CALL CFFTMF(L, 1, M, LDIM, C, (L-1) + LDIM*(M-1) +1,              &
+     &     WSAVE(IW), 2*M + INT(LOG(REAL(M))) + 4,                      &
+     &     WORK, 2*L*M, IER1)                                           
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('CFFT2F',-5) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+! Transform Y lines of C array                                          
+      IW = 1 
+      CALL CFFTMF (M, LDIM, L, 1, C, (M-1)*LDIM + L,                    &
+     &     WSAVE(IW), 2*L + INT(LOG(REAL(L))) + 4,                      &
+     &     WORK, 2*M*L, IER1)                                           
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('CFFT2F',-5) 
+      ENDIF 
+!                                                                       
+  100 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft2i.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft2i.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfft2i.F	(revision 17)
@@ -0,0 +1,41 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cfft2i.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CFFT2I (L, M, WSAVE, LENSAV, IER) 
+      INTEGER L, M, IER 
+      REAL WSAVE(LENSAV) 
+!                                                                       
+! Initialize error return                                               
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENSAV .LT. 2*L + INT(LOG(REAL(L))) +                         &
+     &                    2*M + INT(LOG(REAL(M))) +8) THEN              
+        IER = 2 
+        CALL XERFFT ('CFFT2I', 4) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+      CALL CFFTMI (L, WSAVE(1), 2*L + INT(LOG(REAL(L))) + 4, IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('CFFT2I',-5) 
+        GO TO 100 
+      ENDIF 
+      CALL CFFTMI (M, WSAVE(2*L+INT(LOG(REAL(L))*LOG(2.)) + 3),         &
+     &            2*M + INT(LOG(REAL(M))) + 4, IER1)                    
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('CFFT2I',-5) 
+      ENDIF 
+!                                                                       
+  100 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfftmb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfftmb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfftmb.F	(revision 17)
@@ -0,0 +1,40 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cfftmb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CFFTMB (LOT, JUMP, N, INC, C, LENC, WSAVE, LENSAV,     &
+     &                  WORK, LENWRK, IER)                              
+      INTEGER  LOT, JUMP, N, INC, LENC, LENSAV, LENWRK, IER 
+      COMPLEX       C(LENC) 
+      REAL     WSAVE(LENSAV)     ,WORK(LENWRK) 
+      LOGICAL XERCON 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENC .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('CFFTMB ', 6) 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) + 4) THEN 
+        IER = 2 
+        CALL XERFFT ('CFFTMB ', 8) 
+      ELSEIF (LENWRK .LT. 2*LOT*N) THEN 
+        IER = 3 
+        CALL XERFFT ('CFFTMB ', 10) 
+      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
+        IER = 4 
+        CALL XERFFT ('CFFTMB ', -1) 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+!                                                                       
+      IW1 = N+N+1 
+      CALL CMFM1B (LOT,JUMP,N,INC,C,WORK,WSAVE,WSAVE(IW1),              &
+     &                           WSAVE(IW1+1))                          
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfftmf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfftmf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfftmf.F	(revision 17)
@@ -0,0 +1,40 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cfftmf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CFFTMF (LOT, JUMP, N, INC, C, LENC, WSAVE, LENSAV,     &
+     &                  WORK, LENWRK, IER)                              
+      INTEGER  LOT, JUMP, N, INC, LENC, LENSAV, LENWRK, IER 
+      COMPLEX  C(LENC) 
+      REAL     WSAVE(LENSAV)     ,WORK(LENWRK) 
+      LOGICAL  XERCON 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENC .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('CFFTMF ', 6) 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) + 4) THEN 
+        IER = 2 
+        CALL XERFFT ('CFFTMF ', 8) 
+      ELSEIF (LENWRK .LT. 2*LOT*N) THEN 
+        IER = 3 
+        CALL XERFFT ('CFFTMF ', 10) 
+      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
+        IER = 4 
+        CALL XERFFT ('CFFTMF ', -1) 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+!                                                                       
+      IW1 = N+N+1 
+      CALL CMFM1F (LOT,JUMP,N,INC,C,WORK,WSAVE,WSAVE(IW1),              &
+     &                           WSAVE(IW1+1))                          
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfftmi.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfftmi.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cfftmi.F	(revision 17)
@@ -0,0 +1,27 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cfftmi.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CFFTMI (N, WSAVE, LENSAV, IER) 
+      INTEGER    N, LENSAV, IER 
+      REAL       WSAVE(LENSAV) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) + 4) THEN 
+        IER = 2 
+        CALL XERFFT ('CFFTMI ', 3) 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+!                                                                       
+      IW1 = N+N+1 
+      CALL MCFTI1 (N,WSAVE,WSAVE(IW1),WSAVE(IW1+1)) 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf2kb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf2kb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf2kb.F	(revision 17)
@@ -0,0 +1,51 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cmf2kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CMF2KB (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
+      REAL  CC(2,IN1,L1,IDO,2),CH(2,IN2,L1,2,IDO),WA(IDO,1,2) 
+!                                                                       
+      M1D = (LOT-1)*IM1+1 
+      M2S = 1-IM2 
+      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
+      DO 101 K=1,L1 
+         DO 101 M1=1,M1D,IM1 
+         CHOLD1 = CC(1,M1,K,1,1)+CC(1,M1,K,1,2) 
+         CC(1,M1,K,1,2) = CC(1,M1,K,1,1)-CC(1,M1,K,1,2) 
+         CC(1,M1,K,1,1) = CHOLD1 
+         CHOLD2 = CC(2,M1,K,1,1)+CC(2,M1,K,1,2) 
+         CC(2,M1,K,1,2) = CC(2,M1,K,1,1)-CC(2,M1,K,1,2) 
+         CC(2,M1,K,1,1) = CHOLD2 
+  101 CONTINUE 
+      RETURN 
+  102 DO 103 K=1,L1 
+         M2 = M2S 
+         DO 103 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH(1,M2,K,1,1) = CC(1,M1,K,1,1)+CC(1,M1,K,1,2) 
+         CH(1,M2,K,2,1) = CC(1,M1,K,1,1)-CC(1,M1,K,1,2) 
+         CH(2,M2,K,1,1) = CC(2,M1,K,1,1)+CC(2,M1,K,1,2) 
+         CH(2,M2,K,2,1) = CC(2,M1,K,1,1)-CC(2,M1,K,1,2) 
+  103 CONTINUE 
+      IF(IDO .EQ. 1) RETURN 
+      DO 105 I=2,IDO 
+         DO 104 K=1,L1 
+         M2 = M2S 
+         DO 104 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CH(1,M2,K,1,I) = CC(1,M1,K,I,1)+CC(1,M1,K,I,2) 
+            TR2 = CC(1,M1,K,I,1)-CC(1,M1,K,I,2) 
+            CH(2,M2,K,1,I) = CC(2,M1,K,I,1)+CC(2,M1,K,I,2) 
+            TI2 = CC(2,M1,K,I,1)-CC(2,M1,K,I,2) 
+            CH(2,M2,K,2,I) = WA(I,1,1)*TI2+WA(I,1,2)*TR2 
+            CH(1,M2,K,2,I) = WA(I,1,1)*TR2-WA(I,1,2)*TI2 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf2kf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf2kf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf2kf.F	(revision 17)
@@ -0,0 +1,62 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cmf2kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CMF2KF (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
+      REAL  CC(2,IN1,L1,IDO,2),CH(2,IN2,L1,2,IDO),WA(IDO,1,2) 
+!                                                                       
+      M1D = (LOT-1)*IM1+1 
+      M2S = 1-IM2 
+      IF (IDO .GT. 1) GO TO 102 
+      SN = 1./REAL(2*L1) 
+      IF (NA .EQ. 1) GO TO 106 
+      DO 101 K=1,L1 
+         DO 101 M1=1,M1D,IM1 
+         CHOLD1 = SN*(CC(1,M1,K,1,1)+CC(1,M1,K,1,2)) 
+         CC(1,M1,K,1,2) = SN*(CC(1,M1,K,1,1)-CC(1,M1,K,1,2)) 
+         CC(1,M1,K,1,1) = CHOLD1 
+         CHOLD2 = SN*(CC(2,M1,K,1,1)+CC(2,M1,K,1,2)) 
+         CC(2,M1,K,1,2) = SN*(CC(2,M1,K,1,1)-CC(2,M1,K,1,2)) 
+         CC(2,M1,K,1,1) = CHOLD2 
+  101 CONTINUE 
+      RETURN 
+  106 DO 107 K=1,L1 
+         M2 = M2S 
+         DO 107 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH(1,M2,K,1,1) = SN*(CC(1,M1,K,1,1)+CC(1,M1,K,1,2)) 
+         CH(1,M2,K,2,1) = SN*(CC(1,M1,K,1,1)-CC(1,M1,K,1,2)) 
+         CH(2,M2,K,1,1) = SN*(CC(2,M1,K,1,1)+CC(2,M1,K,1,2)) 
+         CH(2,M2,K,2,1) = SN*(CC(2,M1,K,1,1)-CC(2,M1,K,1,2)) 
+  107 CONTINUE 
+      RETURN 
+  102 DO 103 K=1,L1 
+         M2 = M2S 
+         DO 103 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH(1,M2,K,1,1) = CC(1,M1,K,1,1)+CC(1,M1,K,1,2) 
+         CH(1,M2,K,2,1) = CC(1,M1,K,1,1)-CC(1,M1,K,1,2) 
+         CH(2,M2,K,1,1) = CC(2,M1,K,1,1)+CC(2,M1,K,1,2) 
+         CH(2,M2,K,2,1) = CC(2,M1,K,1,1)-CC(2,M1,K,1,2) 
+  103 CONTINUE 
+      DO 105 I=2,IDO 
+         DO 104 K=1,L1 
+         M2 = M2S 
+         DO 104 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CH(1,M2,K,1,I) = CC(1,M1,K,I,1)+CC(1,M1,K,I,2) 
+            TR2 = CC(1,M1,K,I,1)-CC(1,M1,K,I,2) 
+            CH(2,M2,K,1,I) = CC(2,M1,K,I,1)+CC(2,M1,K,I,2) 
+            TI2 = CC(2,M1,K,I,1)-CC(2,M1,K,I,2) 
+            CH(2,M2,K,2,I) = WA(I,1,1)*TI2-WA(I,1,2)*TR2 
+            CH(1,M2,K,2,I) = WA(I,1,1)*TR2+WA(I,1,2)*TI2 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf3kb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf3kb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf3kb.F	(revision 17)
@@ -0,0 +1,76 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cmf3kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CMF3KB (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
+      REAL  CC(2,IN1,L1,IDO,3),CH(2,IN2,L1,3,IDO),WA(IDO,2,2) 
+      DATA TAUR,TAUI /-.5,.866025403784439/ 
+!                                                                       
+      M1D = (LOT-1)*IM1+1 
+      M2S = 1-IM2 
+      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
+      DO 101 K=1,L1 
+         DO 101 M1=1,M1D,IM1 
+         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,3) 
+         CR2 = CC(1,M1,K,1,1)+TAUR*TR2 
+         CC(1,M1,K,1,1) = CC(1,M1,K,1,1)+TR2 
+         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,3) 
+         CI2 = CC(2,M1,K,1,1)+TAUR*TI2 
+         CC(2,M1,K,1,1) = CC(2,M1,K,1,1)+TI2 
+         CR3 = TAUI*(CC(1,M1,K,1,2)-CC(1,M1,K,1,3)) 
+         CI3 = TAUI*(CC(2,M1,K,1,2)-CC(2,M1,K,1,3)) 
+         CC(1,M1,K,1,2) = CR2-CI3 
+         CC(1,M1,K,1,3) = CR2+CI3 
+         CC(2,M1,K,1,2) = CI2+CR3 
+         CC(2,M1,K,1,3) = CI2-CR3 
+  101 CONTINUE 
+      RETURN 
+  102 DO 103 K=1,L1 
+         M2 = M2S 
+         DO 103 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,3) 
+         CR2 = CC(1,M1,K,1,1)+TAUR*TR2 
+         CH(1,M2,K,1,1) = CC(1,M1,K,1,1)+TR2 
+         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,3) 
+         CI2 = CC(2,M1,K,1,1)+TAUR*TI2 
+         CH(2,M2,K,1,1) = CC(2,M1,K,1,1)+TI2 
+         CR3 = TAUI*(CC(1,M1,K,1,2)-CC(1,M1,K,1,3)) 
+         CI3 = TAUI*(CC(2,M1,K,1,2)-CC(2,M1,K,1,3)) 
+         CH(1,M2,K,2,1) = CR2-CI3 
+         CH(1,M2,K,3,1) = CR2+CI3 
+         CH(2,M2,K,2,1) = CI2+CR3 
+         CH(2,M2,K,3,1) = CI2-CR3 
+  103 CONTINUE 
+      IF (IDO .EQ. 1) RETURN 
+      DO 105 I=2,IDO 
+        DO 104 K=1,L1 
+         M2 = M2S 
+         DO 104 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            TR2 = CC(1,M1,K,I,2)+CC(1,M1,K,I,3) 
+            CR2 = CC(1,M1,K,I,1)+TAUR*TR2 
+            CH(1,M2,K,1,I) = CC(1,M1,K,I,1)+TR2 
+            TI2 = CC(2,M1,K,I,2)+CC(2,M1,K,I,3) 
+            CI2 = CC(2,M1,K,I,1)+TAUR*TI2 
+            CH(2,M2,K,1,I) = CC(2,M1,K,I,1)+TI2 
+            CR3 = TAUI*(CC(1,M1,K,I,2)-CC(1,M1,K,I,3)) 
+            CI3 = TAUI*(CC(2,M1,K,I,2)-CC(2,M1,K,I,3)) 
+            DR2 = CR2-CI3 
+            DR3 = CR2+CI3 
+            DI2 = CI2+CR3 
+            DI3 = CI2-CR3 
+            CH(2,M2,K,2,I) = WA(I,1,1)*DI2+WA(I,1,2)*DR2 
+            CH(1,M2,K,2,I) = WA(I,1,1)*DR2-WA(I,1,2)*DI2 
+            CH(2,M2,K,3,I) = WA(I,2,1)*DI3+WA(I,2,2)*DR3 
+            CH(1,M2,K,3,I) = WA(I,2,1)*DR3-WA(I,2,2)*DI3 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf3kf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf3kf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf3kf.F	(revision 17)
@@ -0,0 +1,95 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cmf3kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CMF3KF (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
+      REAL  CC(2,IN1,L1,IDO,3),CH(2,IN2,L1,3,IDO),WA(IDO,2,2) 
+      DATA TAUR,TAUI /-.5,-.866025403784439/ 
+!                                                                       
+      M1D = (LOT-1)*IM1+1 
+      M2S = 1-IM2 
+      IF (IDO .GT. 1) GO TO 102 
+      SN = 1./REAL(3*L1) 
+      IF (NA .EQ. 1) GO TO 106 
+      DO 101 K=1,L1 
+         DO 101 M1=1,M1D,IM1 
+         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,3) 
+         CR2 = CC(1,M1,K,1,1)+TAUR*TR2 
+         CC(1,M1,K,1,1) = SN*(CC(1,M1,K,1,1)+TR2) 
+         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,3) 
+         CI2 = CC(2,M1,K,1,1)+TAUR*TI2 
+         CC(2,M1,K,1,1) = SN*(CC(2,M1,K,1,1)+TI2) 
+         CR3 = TAUI*(CC(1,M1,K,1,2)-CC(1,M1,K,1,3)) 
+         CI3 = TAUI*(CC(2,M1,K,1,2)-CC(2,M1,K,1,3)) 
+         CC(1,M1,K,1,2) = SN*(CR2-CI3) 
+         CC(1,M1,K,1,3) = SN*(CR2+CI3) 
+         CC(2,M1,K,1,2) = SN*(CI2+CR3) 
+         CC(2,M1,K,1,3) = SN*(CI2-CR3) 
+  101 CONTINUE 
+      RETURN 
+  106 DO 107 K=1,L1 
+         M2 = M2S 
+         DO 107 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,3) 
+         CR2 = CC(1,M1,K,1,1)+TAUR*TR2 
+         CH(1,M2,K,1,1) = SN*(CC(1,M1,K,1,1)+TR2) 
+         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,3) 
+         CI2 = CC(2,M1,K,1,1)+TAUR*TI2 
+         CH(2,M2,K,1,1) = SN*(CC(2,M1,K,1,1)+TI2) 
+         CR3 = TAUI*(CC(1,M1,K,1,2)-CC(1,M1,K,1,3)) 
+         CI3 = TAUI*(CC(2,M1,K,1,2)-CC(2,M1,K,1,3)) 
+         CH(1,M2,K,2,1) = SN*(CR2-CI3) 
+         CH(1,M2,K,3,1) = SN*(CR2+CI3) 
+         CH(2,M2,K,2,1) = SN*(CI2+CR3) 
+         CH(2,M2,K,3,1) = SN*(CI2-CR3) 
+  107 CONTINUE 
+      RETURN 
+  102 DO 103 K=1,L1 
+         M2 = M2S 
+         DO 103 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,3) 
+         CR2 = CC(1,M1,K,1,1)+TAUR*TR2 
+         CH(1,M2,K,1,1) = CC(1,M1,K,1,1)+TR2 
+         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,3) 
+         CI2 = CC(2,M1,K,1,1)+TAUR*TI2 
+         CH(2,M2,K,1,1) = CC(2,M1,K,1,1)+TI2 
+         CR3 = TAUI*(CC(1,M1,K,1,2)-CC(1,M1,K,1,3)) 
+         CI3 = TAUI*(CC(2,M1,K,1,2)-CC(2,M1,K,1,3)) 
+         CH(1,M2,K,2,1) = CR2-CI3 
+         CH(1,M2,K,3,1) = CR2+CI3 
+         CH(2,M2,K,2,1) = CI2+CR3 
+         CH(2,M2,K,3,1) = CI2-CR3 
+  103 CONTINUE 
+      DO 105 I=2,IDO 
+        DO 104 K=1,L1 
+         M2 = M2S 
+         DO 104 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            TR2 = CC(1,M1,K,I,2)+CC(1,M1,K,I,3) 
+            CR2 = CC(1,M1,K,I,1)+TAUR*TR2 
+            CH(1,M2,K,1,I) = CC(1,M1,K,I,1)+TR2 
+            TI2 = CC(2,M1,K,I,2)+CC(2,M1,K,I,3) 
+            CI2 = CC(2,M1,K,I,1)+TAUR*TI2 
+            CH(2,M2,K,1,I) = CC(2,M1,K,I,1)+TI2 
+            CR3 = TAUI*(CC(1,M1,K,I,2)-CC(1,M1,K,I,3)) 
+            CI3 = TAUI*(CC(2,M1,K,I,2)-CC(2,M1,K,I,3)) 
+            DR2 = CR2-CI3 
+            DR3 = CR2+CI3 
+            DI2 = CI2+CR3 
+            DI3 = CI2-CR3 
+            CH(2,M2,K,2,I) = WA(I,1,1)*DI2-WA(I,1,2)*DR2 
+            CH(1,M2,K,2,I) = WA(I,1,1)*DR2+WA(I,1,2)*DI2 
+            CH(2,M2,K,3,I) = WA(I,2,1)*DI3-WA(I,2,2)*DR3 
+            CH(1,M2,K,3,I) = WA(I,2,1)*DR3+WA(I,2,2)*DI3 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf4kb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf4kb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf4kb.F	(revision 17)
@@ -0,0 +1,91 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cmf4kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CMF4KB (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
+      REAL CC(2,IN1,L1,IDO,4),CH(2,IN2,L1,4,IDO),WA(IDO,3,2) 
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      M1D = (LOT-1)*IM1+1 
+      M2S = 1-IM2 
+      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
+      DO 101 K=1,L1 
+         DO 101 M1=1,M1D,IM1 
+         TI1 = CC(2,M1,K,1,1)-CC(2,M1,K,1,3) 
+         TI2 = CC(2,M1,K,1,1)+CC(2,M1,K,1,3) 
+         TR4 = CC(2,M1,K,1,4)-CC(2,M1,K,1,2) 
+         TI3 = CC(2,M1,K,1,2)+CC(2,M1,K,1,4) 
+         TR1 = CC(1,M1,K,1,1)-CC(1,M1,K,1,3) 
+         TR2 = CC(1,M1,K,1,1)+CC(1,M1,K,1,3) 
+         TI4 = CC(1,M1,K,1,2)-CC(1,M1,K,1,4) 
+         TR3 = CC(1,M1,K,1,2)+CC(1,M1,K,1,4) 
+         CC(1,M1,K,1,1) = TR2+TR3 
+         CC(1,M1,K,1,3) = TR2-TR3 
+         CC(2,M1,K,1,1) = TI2+TI3 
+         CC(2,M1,K,1,3) = TI2-TI3 
+         CC(1,M1,K,1,2) = TR1+TR4 
+         CC(1,M1,K,1,4) = TR1-TR4 
+         CC(2,M1,K,1,2) = TI1+TI4 
+         CC(2,M1,K,1,4) = TI1-TI4 
+  101 CONTINUE 
+      RETURN 
+  102 DO 103 K=1,L1 
+         M2 = M2S 
+         DO 103 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         TI1 = CC(2,M1,K,1,1)-CC(2,M1,K,1,3) 
+         TI2 = CC(2,M1,K,1,1)+CC(2,M1,K,1,3) 
+         TR4 = CC(2,M1,K,1,4)-CC(2,M1,K,1,2) 
+         TI3 = CC(2,M1,K,1,2)+CC(2,M1,K,1,4) 
+         TR1 = CC(1,M1,K,1,1)-CC(1,M1,K,1,3) 
+         TR2 = CC(1,M1,K,1,1)+CC(1,M1,K,1,3) 
+         TI4 = CC(1,M1,K,1,2)-CC(1,M1,K,1,4) 
+         TR3 = CC(1,M1,K,1,2)+CC(1,M1,K,1,4) 
+         CH(1,M2,K,1,1) = TR2+TR3 
+         CH(1,M2,K,3,1) = TR2-TR3 
+         CH(2,M2,K,1,1) = TI2+TI3 
+         CH(2,M2,K,3,1) = TI2-TI3 
+         CH(1,M2,K,2,1) = TR1+TR4 
+         CH(1,M2,K,4,1) = TR1-TR4 
+         CH(2,M2,K,2,1) = TI1+TI4 
+         CH(2,M2,K,4,1) = TI1-TI4 
+  103 CONTINUE 
+      IF(IDO .EQ. 1) RETURN 
+      DO 105 I=2,IDO 
+         DO 104 K=1,L1 
+         M2 = M2S 
+         DO 104 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            TI1 = CC(2,M1,K,I,1)-CC(2,M1,K,I,3) 
+            TI2 = CC(2,M1,K,I,1)+CC(2,M1,K,I,3) 
+            TI3 = CC(2,M1,K,I,2)+CC(2,M1,K,I,4) 
+            TR4 = CC(2,M1,K,I,4)-CC(2,M1,K,I,2) 
+            TR1 = CC(1,M1,K,I,1)-CC(1,M1,K,I,3) 
+            TR2 = CC(1,M1,K,I,1)+CC(1,M1,K,I,3) 
+            TI4 = CC(1,M1,K,I,2)-CC(1,M1,K,I,4) 
+            TR3 = CC(1,M1,K,I,2)+CC(1,M1,K,I,4) 
+            CH(1,M2,K,1,I) = TR2+TR3 
+            CR3 = TR2-TR3 
+            CH(2,M2,K,1,I) = TI2+TI3 
+            CI3 = TI2-TI3 
+            CR2 = TR1+TR4 
+            CR4 = TR1-TR4 
+            CI2 = TI1+TI4 
+            CI4 = TI1-TI4 
+            CH(1,M2,K,2,I) = WA(I,1,1)*CR2-WA(I,1,2)*CI2 
+            CH(2,M2,K,2,I) = WA(I,1,1)*CI2+WA(I,1,2)*CR2 
+            CH(1,M2,K,3,I) = WA(I,2,1)*CR3-WA(I,2,2)*CI3 
+            CH(2,M2,K,3,I) = WA(I,2,1)*CI3+WA(I,2,2)*CR3 
+            CH(1,M2,K,4,I) = WA(I,3,1)*CR4-WA(I,3,2)*CI4 
+            CH(2,M2,K,4,I) = WA(I,3,1)*CI4+WA(I,3,2)*CR4 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf4kf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf4kf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf4kf.F	(revision 17)
@@ -0,0 +1,114 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cmf4kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CMF4KF (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
+      REAL CC(2,IN1,L1,IDO,4),CH(2,IN2,L1,4,IDO),WA(IDO,3,2) 
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      M1D = (LOT-1)*IM1+1 
+      M2S = 1-IM2 
+      IF (IDO .GT. 1) GO TO 102 
+      SN = 1./REAL(4*L1) 
+      IF (NA .EQ. 1) GO TO 106 
+      DO 101 K=1,L1 
+         DO 101 M1=1,M1D,IM1 
+         TI1 = CC(2,M1,K,1,1)-CC(2,M1,K,1,3) 
+         TI2 = CC(2,M1,K,1,1)+CC(2,M1,K,1,3) 
+         TR4 = CC(2,M1,K,1,2)-CC(2,M1,K,1,4) 
+         TI3 = CC(2,M1,K,1,2)+CC(2,M1,K,1,4) 
+         TR1 = CC(1,M1,K,1,1)-CC(1,M1,K,1,3) 
+         TR2 = CC(1,M1,K,1,1)+CC(1,M1,K,1,3) 
+         TI4 = CC(1,M1,K,1,4)-CC(1,M1,K,1,2) 
+         TR3 = CC(1,M1,K,1,2)+CC(1,M1,K,1,4) 
+         CC(1,M1,K,1,1) = SN*(TR2+TR3) 
+         CC(1,M1,K,1,3) = SN*(TR2-TR3) 
+         CC(2,M1,K,1,1) = SN*(TI2+TI3) 
+         CC(2,M1,K,1,3) = SN*(TI2-TI3) 
+         CC(1,M1,K,1,2) = SN*(TR1+TR4) 
+         CC(1,M1,K,1,4) = SN*(TR1-TR4) 
+         CC(2,M1,K,1,2) = SN*(TI1+TI4) 
+         CC(2,M1,K,1,4) = SN*(TI1-TI4) 
+  101 CONTINUE 
+      RETURN 
+  106 DO 107 K=1,L1 
+         M2 = M2S 
+         DO 107 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         TI1 = CC(2,M1,K,1,1)-CC(2,M1,K,1,3) 
+         TI2 = CC(2,M1,K,1,1)+CC(2,M1,K,1,3) 
+         TR4 = CC(2,M1,K,1,2)-CC(2,M1,K,1,4) 
+         TI3 = CC(2,M1,K,1,2)+CC(2,M1,K,1,4) 
+         TR1 = CC(1,M1,K,1,1)-CC(1,M1,K,1,3) 
+         TR2 = CC(1,M1,K,1,1)+CC(1,M1,K,1,3) 
+         TI4 = CC(1,M1,K,1,4)-CC(1,M1,K,1,2) 
+         TR3 = CC(1,M1,K,1,2)+CC(1,M1,K,1,4) 
+         CH(1,M2,K,1,1) = SN*(TR2+TR3) 
+         CH(1,M2,K,3,1) = SN*(TR2-TR3) 
+         CH(2,M2,K,1,1) = SN*(TI2+TI3) 
+         CH(2,M2,K,3,1) = SN*(TI2-TI3) 
+         CH(1,M2,K,2,1) = SN*(TR1+TR4) 
+         CH(1,M2,K,4,1) = SN*(TR1-TR4) 
+         CH(2,M2,K,2,1) = SN*(TI1+TI4) 
+         CH(2,M2,K,4,1) = SN*(TI1-TI4) 
+  107 CONTINUE 
+      RETURN 
+  102 DO 103 K=1,L1 
+         M2 = M2S 
+         DO 103 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         TI1 = CC(2,M1,K,1,1)-CC(2,M1,K,1,3) 
+         TI2 = CC(2,M1,K,1,1)+CC(2,M1,K,1,3) 
+         TR4 = CC(2,M1,K,1,2)-CC(2,M1,K,1,4) 
+         TI3 = CC(2,M1,K,1,2)+CC(2,M1,K,1,4) 
+         TR1 = CC(1,M1,K,1,1)-CC(1,M1,K,1,3) 
+         TR2 = CC(1,M1,K,1,1)+CC(1,M1,K,1,3) 
+         TI4 = CC(1,M1,K,1,4)-CC(1,M1,K,1,2) 
+         TR3 = CC(1,M1,K,1,2)+CC(1,M1,K,1,4) 
+         CH(1,M2,K,1,1) = TR2+TR3 
+         CH(1,M2,K,3,1) = TR2-TR3 
+         CH(2,M2,K,1,1) = TI2+TI3 
+         CH(2,M2,K,3,1) = TI2-TI3 
+         CH(1,M2,K,2,1) = TR1+TR4 
+         CH(1,M2,K,4,1) = TR1-TR4 
+         CH(2,M2,K,2,1) = TI1+TI4 
+         CH(2,M2,K,4,1) = TI1-TI4 
+  103 CONTINUE 
+      DO 105 I=2,IDO 
+         DO 104 K=1,L1 
+         M2 = M2S 
+         DO 104 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            TI1 = CC(2,M1,K,I,1)-CC(2,M1,K,I,3) 
+            TI2 = CC(2,M1,K,I,1)+CC(2,M1,K,I,3) 
+            TI3 = CC(2,M1,K,I,2)+CC(2,M1,K,I,4) 
+            TR4 = CC(2,M1,K,I,2)-CC(2,M1,K,I,4) 
+            TR1 = CC(1,M1,K,I,1)-CC(1,M1,K,I,3) 
+            TR2 = CC(1,M1,K,I,1)+CC(1,M1,K,I,3) 
+            TI4 = CC(1,M1,K,I,4)-CC(1,M1,K,I,2) 
+            TR3 = CC(1,M1,K,I,2)+CC(1,M1,K,I,4) 
+            CH(1,M2,K,1,I) = TR2+TR3 
+            CR3 = TR2-TR3 
+            CH(2,M2,K,1,I) = TI2+TI3 
+            CI3 = TI2-TI3 
+            CR2 = TR1+TR4 
+            CR4 = TR1-TR4 
+            CI2 = TI1+TI4 
+            CI4 = TI1-TI4 
+            CH(1,M2,K,2,I) = WA(I,1,1)*CR2+WA(I,1,2)*CI2 
+            CH(2,M2,K,2,I) = WA(I,1,1)*CI2-WA(I,1,2)*CR2 
+            CH(1,M2,K,3,I) = WA(I,2,1)*CR3+WA(I,2,2)*CI3 
+            CH(2,M2,K,3,I) = WA(I,2,1)*CI3-WA(I,2,2)*CR3 
+            CH(1,M2,K,4,I) = WA(I,3,1)*CR4+WA(I,3,2)*CI4 
+            CH(2,M2,K,4,I) = WA(I,3,1)*CI4-WA(I,3,2)*CR4 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf5kb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf5kb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf5kb.F	(revision 17)
@@ -0,0 +1,127 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cmf5kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CMF5KB (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
+      REAL  CC(2,IN1,L1,IDO,5),CH(2,IN2,L1,5,IDO),WA(IDO,4,2) 
+      DATA TR11,TI11,TR12,TI12 /.3090169943749474,.9510565162951536,    &
+     &-.8090169943749474,.5877852522924731/                             
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      M1D = (LOT-1)*IM1+1 
+      M2S = 1-IM2 
+      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
+      DO 101 K=1,L1 
+         DO 101 M1=1,M1D,IM1 
+         TI5 = CC(2,M1,K,1,2)-CC(2,M1,K,1,5) 
+         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,5) 
+         TI4 = CC(2,M1,K,1,3)-CC(2,M1,K,1,4) 
+         TI3 = CC(2,M1,K,1,3)+CC(2,M1,K,1,4) 
+         TR5 = CC(1,M1,K,1,2)-CC(1,M1,K,1,5) 
+         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,5) 
+         TR4 = CC(1,M1,K,1,3)-CC(1,M1,K,1,4) 
+         TR3 = CC(1,M1,K,1,3)+CC(1,M1,K,1,4) 
+         CHOLD1 = CC(1,M1,K,1,1)+TR2+TR3 
+         CHOLD2 = CC(2,M1,K,1,1)+TI2+TI3 
+         CR2 = CC(1,M1,K,1,1)+TR11*TR2+TR12*TR3 
+         CI2 = CC(2,M1,K,1,1)+TR11*TI2+TR12*TI3 
+         CR3 = CC(1,M1,K,1,1)+TR12*TR2+TR11*TR3 
+         CI3 = CC(2,M1,K,1,1)+TR12*TI2+TR11*TI3 
+         CC(1,M1,K,1,1) = CHOLD1 
+         CC(2,M1,K,1,1) = CHOLD2 
+         CR5 = TI11*TR5+TI12*TR4 
+         CI5 = TI11*TI5+TI12*TI4 
+         CR4 = TI12*TR5-TI11*TR4 
+         CI4 = TI12*TI5-TI11*TI4 
+         CC(1,M1,K,1,2) = CR2-CI5 
+         CC(1,M1,K,1,5) = CR2+CI5 
+         CC(2,M1,K,1,2) = CI2+CR5 
+         CC(2,M1,K,1,3) = CI3+CR4 
+         CC(1,M1,K,1,3) = CR3-CI4 
+         CC(1,M1,K,1,4) = CR3+CI4 
+         CC(2,M1,K,1,4) = CI3-CR4 
+         CC(2,M1,K,1,5) = CI2-CR5 
+  101 CONTINUE 
+      RETURN 
+  102 DO 103 K=1,L1 
+         M2 = M2S 
+         DO 103 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         TI5 = CC(2,M1,K,1,2)-CC(2,M1,K,1,5) 
+         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,5) 
+         TI4 = CC(2,M1,K,1,3)-CC(2,M1,K,1,4) 
+         TI3 = CC(2,M1,K,1,3)+CC(2,M1,K,1,4) 
+         TR5 = CC(1,M1,K,1,2)-CC(1,M1,K,1,5) 
+         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,5) 
+         TR4 = CC(1,M1,K,1,3)-CC(1,M1,K,1,4) 
+         TR3 = CC(1,M1,K,1,3)+CC(1,M1,K,1,4) 
+         CH(1,M2,K,1,1) = CC(1,M1,K,1,1)+TR2+TR3 
+         CH(2,M2,K,1,1) = CC(2,M1,K,1,1)+TI2+TI3 
+         CR2 = CC(1,M1,K,1,1)+TR11*TR2+TR12*TR3 
+         CI2 = CC(2,M1,K,1,1)+TR11*TI2+TR12*TI3 
+         CR3 = CC(1,M1,K,1,1)+TR12*TR2+TR11*TR3 
+         CI3 = CC(2,M1,K,1,1)+TR12*TI2+TR11*TI3 
+         CR5 = TI11*TR5+TI12*TR4 
+         CI5 = TI11*TI5+TI12*TI4 
+         CR4 = TI12*TR5-TI11*TR4 
+         CI4 = TI12*TI5-TI11*TI4 
+         CH(1,M2,K,2,1) = CR2-CI5 
+         CH(1,M2,K,5,1) = CR2+CI5 
+         CH(2,M2,K,2,1) = CI2+CR5 
+         CH(2,M2,K,3,1) = CI3+CR4 
+         CH(1,M2,K,3,1) = CR3-CI4 
+         CH(1,M2,K,4,1) = CR3+CI4 
+         CH(2,M2,K,4,1) = CI3-CR4 
+         CH(2,M2,K,5,1) = CI2-CR5 
+  103 CONTINUE 
+      IF(IDO .EQ. 1) RETURN 
+      DO 105 I=2,IDO 
+         DO 104 K=1,L1 
+         M2 = M2S 
+         DO 104 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            TI5 = CC(2,M1,K,I,2)-CC(2,M1,K,I,5) 
+            TI2 = CC(2,M1,K,I,2)+CC(2,M1,K,I,5) 
+            TI4 = CC(2,M1,K,I,3)-CC(2,M1,K,I,4) 
+            TI3 = CC(2,M1,K,I,3)+CC(2,M1,K,I,4) 
+            TR5 = CC(1,M1,K,I,2)-CC(1,M1,K,I,5) 
+            TR2 = CC(1,M1,K,I,2)+CC(1,M1,K,I,5) 
+            TR4 = CC(1,M1,K,I,3)-CC(1,M1,K,I,4) 
+            TR3 = CC(1,M1,K,I,3)+CC(1,M1,K,I,4) 
+            CH(1,M2,K,1,I) = CC(1,M1,K,I,1)+TR2+TR3 
+            CH(2,M2,K,1,I) = CC(2,M1,K,I,1)+TI2+TI3 
+            CR2 = CC(1,M1,K,I,1)+TR11*TR2+TR12*TR3 
+            CI2 = CC(2,M1,K,I,1)+TR11*TI2+TR12*TI3 
+            CR3 = CC(1,M1,K,I,1)+TR12*TR2+TR11*TR3 
+            CI3 = CC(2,M1,K,I,1)+TR12*TI2+TR11*TI3 
+            CR5 = TI11*TR5+TI12*TR4 
+            CI5 = TI11*TI5+TI12*TI4 
+            CR4 = TI12*TR5-TI11*TR4 
+            CI4 = TI12*TI5-TI11*TI4 
+            DR3 = CR3-CI4 
+            DR4 = CR3+CI4 
+            DI3 = CI3+CR4 
+            DI4 = CI3-CR4 
+            DR5 = CR2+CI5 
+            DR2 = CR2-CI5 
+            DI5 = CI2-CR5 
+            DI2 = CI2+CR5 
+            CH(1,M2,K,2,I) = WA(I,1,1)*DR2-WA(I,1,2)*DI2 
+            CH(2,M2,K,2,I) = WA(I,1,1)*DI2+WA(I,1,2)*DR2 
+            CH(1,M2,K,3,I) = WA(I,2,1)*DR3-WA(I,2,2)*DI3 
+            CH(2,M2,K,3,I) = WA(I,2,1)*DI3+WA(I,2,2)*DR3 
+            CH(1,M2,K,4,I) = WA(I,3,1)*DR4-WA(I,3,2)*DI4 
+            CH(2,M2,K,4,I) = WA(I,3,1)*DI4+WA(I,3,2)*DR4 
+            CH(1,M2,K,5,I) = WA(I,4,1)*DR5-WA(I,4,2)*DI5 
+            CH(2,M2,K,5,I) = WA(I,4,1)*DI5+WA(I,4,2)*DR5 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf5kf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf5kf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmf5kf.F	(revision 17)
@@ -0,0 +1,166 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                      C
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!      File:           cmf5kf.f                                         
+!                                                                       
+!      Library:        FFTPACK 5.0                                      
+!                                                                       
+!      Authors:        Paul N. Swarztrauber and Richard A. Valent       
+!                      National Center for Atmospheric Research         
+!                      PO 3000, Boulder, Colorado                       
+!                                                                       
+!      Date:           Wed Mar 29 18:31:13 MST 1995                     
+!                                                                       
+!      Description:    Lower-level auxiliary routine                    
+!                                                                       
+      SUBROUTINE CMF5KF (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
+      REAL  CC(2,IN1,L1,IDO,5),CH(2,IN2,L1,5,IDO),WA(IDO,4,2) 
+      DATA TR11,TI11,TR12,TI12 /.3090169943749474,-.9510565162951536,   &
+     &-.8090169943749474,-.5877852522924731/                            
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      M1D = (LOT-1)*IM1+1 
+      M2S = 1-IM2 
+      IF (IDO .GT. 1) GO TO 102 
+      SN = 1./REAL(5*L1) 
+      IF (NA .EQ. 1) GO TO 106 
+      DO 101 K=1,L1 
+         DO 101 M1=1,M1D,IM1 
+         TI5 = CC(2,M1,K,1,2)-CC(2,M1,K,1,5) 
+         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,5) 
+         TI4 = CC(2,M1,K,1,3)-CC(2,M1,K,1,4) 
+         TI3 = CC(2,M1,K,1,3)+CC(2,M1,K,1,4) 
+         TR5 = CC(1,M1,K,1,2)-CC(1,M1,K,1,5) 
+         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,5) 
+         TR4 = CC(1,M1,K,1,3)-CC(1,M1,K,1,4) 
+         TR3 = CC(1,M1,K,1,3)+CC(1,M1,K,1,4) 
+         CHOLD1 = SN*(CC(1,M1,K,1,1)+TR2+TR3) 
+         CHOLD2 = SN*(CC(2,M1,K,1,1)+TI2+TI3) 
+         CR2 = CC(1,M1,K,1,1)+TR11*TR2+TR12*TR3 
+         CI2 = CC(2,M1,K,1,1)+TR11*TI2+TR12*TI3 
+         CR3 = CC(1,M1,K,1,1)+TR12*TR2+TR11*TR3 
+         CI3 = CC(2,M1,K,1,1)+TR12*TI2+TR11*TI3 
+         CC(1,M1,K,1,1) = CHOLD1 
+         CC(2,M1,K,1,1) = CHOLD2 
+         CR5 = TI11*TR5+TI12*TR4 
+         CI5 = TI11*TI5+TI12*TI4 
+         CR4 = TI12*TR5-TI11*TR4 
+         CI4 = TI12*TI5-TI11*TI4 
+         CC(1,M1,K,1,2) = SN*(CR2-CI5) 
+         CC(1,M1,K,1,5) = SN*(CR2+CI5) 
+         CC(2,M1,K,1,2) = SN*(CI2+CR5) 
+         CC(2,M1,K,1,3) = SN*(CI3+CR4) 
+         CC(1,M1,K,1,3) = SN*(CR3-CI4) 
+         CC(1,M1,K,1,4) = SN*(CR3+CI4) 
+         CC(2,M1,K,1,4) = SN*(CI3-CR4) 
+         CC(2,M1,K,1,5) = SN*(CI2-CR5) 
+  101 CONTINUE 
+      RETURN 
+  106 DO 107 K=1,L1 
+         M2 = M2S 
+         DO 107 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         TI5 = CC(2,M1,K,1,2)-CC(2,M1,K,1,5) 
+         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,5) 
+         TI4 = CC(2,M1,K,1,3)-CC(2,M1,K,1,4) 
+         TI3 = CC(2,M1,K,1,3)+CC(2,M1,K,1,4) 
+         TR5 = CC(1,M1,K,1,2)-CC(1,M1,K,1,5) 
+         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,5) 
+         TR4 = CC(1,M1,K,1,3)-CC(1,M1,K,1,4) 
+         TR3 = CC(1,M1,K,1,3)+CC(1,M1,K,1,4) 
+         CH(1,M2,K,1,1) = SN*(CC(1,M1,K,1,1)+TR2+TR3) 
+         CH(2,M2,K,1,1) = SN*(CC(2,M1,K,1,1)+TI2+TI3) 
+         CR2 = CC(1,M1,K,1,1)+TR11*TR2+TR12*TR3 
+         CI2 = CC(2,M1,K,1,1)+TR11*TI2+TR12*TI3 
+         CR3 = CC(1,M1,K,1,1)+TR12*TR2+TR11*TR3 
+         CI3 = CC(2,M1,K,1,1)+TR12*TI2+TR11*TI3 
+         CR5 = TI11*TR5+TI12*TR4 
+         CI5 = TI11*TI5+TI12*TI4 
+         CR4 = TI12*TR5-TI11*TR4 
+         CI4 = TI12*TI5-TI11*TI4 
+         CH(1,M2,K,2,1) = SN*(CR2-CI5) 
+         CH(1,M2,K,5,1) = SN*(CR2+CI5) 
+         CH(2,M2,K,2,1) = SN*(CI2+CR5) 
+         CH(2,M2,K,3,1) = SN*(CI3+CR4) 
+         CH(1,M2,K,3,1) = SN*(CR3-CI4) 
+         CH(1,M2,K,4,1) = SN*(CR3+CI4) 
+         CH(2,M2,K,4,1) = SN*(CI3-CR4) 
+         CH(2,M2,K,5,1) = SN*(CI2-CR5) 
+  107 CONTINUE 
+      RETURN 
+  102 DO 103 K=1,L1 
+         M2 = M2S 
+         DO 103 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         TI5 = CC(2,M1,K,1,2)-CC(2,M1,K,1,5) 
+         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,5) 
+         TI4 = CC(2,M1,K,1,3)-CC(2,M1,K,1,4) 
+         TI3 = CC(2,M1,K,1,3)+CC(2,M1,K,1,4) 
+         TR5 = CC(1,M1,K,1,2)-CC(1,M1,K,1,5) 
+         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,5) 
+         TR4 = CC(1,M1,K,1,3)-CC(1,M1,K,1,4) 
+         TR3 = CC(1,M1,K,1,3)+CC(1,M1,K,1,4) 
+         CH(1,M2,K,1,1) = CC(1,M1,K,1,1)+TR2+TR3 
+         CH(2,M2,K,1,1) = CC(2,M1,K,1,1)+TI2+TI3 
+         CR2 = CC(1,M1,K,1,1)+TR11*TR2+TR12*TR3 
+         CI2 = CC(2,M1,K,1,1)+TR11*TI2+TR12*TI3 
+         CR3 = CC(1,M1,K,1,1)+TR12*TR2+TR11*TR3 
+         CI3 = CC(2,M1,K,1,1)+TR12*TI2+TR11*TI3 
+         CR5 = TI11*TR5+TI12*TR4 
+         CI5 = TI11*TI5+TI12*TI4 
+         CR4 = TI12*TR5-TI11*TR4 
+         CI4 = TI12*TI5-TI11*TI4 
+         CH(1,M2,K,2,1) = CR2-CI5 
+         CH(1,M2,K,5,1) = CR2+CI5 
+         CH(2,M2,K,2,1) = CI2+CR5 
+         CH(2,M2,K,3,1) = CI3+CR4 
+         CH(1,M2,K,3,1) = CR3-CI4 
+         CH(1,M2,K,4,1) = CR3+CI4 
+         CH(2,M2,K,4,1) = CI3-CR4 
+         CH(2,M2,K,5,1) = CI2-CR5 
+  103 CONTINUE 
+      DO 105 I=2,IDO 
+         DO 104 K=1,L1 
+         M2 = M2S 
+         DO 104 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            TI5 = CC(2,M1,K,I,2)-CC(2,M1,K,I,5) 
+            TI2 = CC(2,M1,K,I,2)+CC(2,M1,K,I,5) 
+            TI4 = CC(2,M1,K,I,3)-CC(2,M1,K,I,4) 
+            TI3 = CC(2,M1,K,I,3)+CC(2,M1,K,I,4) 
+            TR5 = CC(1,M1,K,I,2)-CC(1,M1,K,I,5) 
+            TR2 = CC(1,M1,K,I,2)+CC(1,M1,K,I,5) 
+            TR4 = CC(1,M1,K,I,3)-CC(1,M1,K,I,4) 
+            TR3 = CC(1,M1,K,I,3)+CC(1,M1,K,I,4) 
+            CH(1,M2,K,1,I) = CC(1,M1,K,I,1)+TR2+TR3 
+            CH(2,M2,K,1,I) = CC(2,M1,K,I,1)+TI2+TI3 
+            CR2 = CC(1,M1,K,I,1)+TR11*TR2+TR12*TR3 
+            CI2 = CC(2,M1,K,I,1)+TR11*TI2+TR12*TI3 
+            CR3 = CC(1,M1,K,I,1)+TR12*TR2+TR11*TR3 
+            CI3 = CC(2,M1,K,I,1)+TR12*TI2+TR11*TI3 
+            CR5 = TI11*TR5+TI12*TR4 
+            CI5 = TI11*TI5+TI12*TI4 
+            CR4 = TI12*TR5-TI11*TR4 
+            CI4 = TI12*TI5-TI11*TI4 
+            DR3 = CR3-CI4 
+            DR4 = CR3+CI4 
+            DI3 = CI3+CR4 
+            DI4 = CI3-CR4 
+            DR5 = CR2+CI5 
+            DR2 = CR2-CI5 
+            DI5 = CI2-CR5 
+            DI2 = CI2+CR5 
+            CH(1,M2,K,2,I) = WA(I,1,1)*DR2+WA(I,1,2)*DI2 
+            CH(2,M2,K,2,I) = WA(I,1,1)*DI2-WA(I,1,2)*DR2 
+            CH(1,M2,K,3,I) = WA(I,2,1)*DR3+WA(I,2,2)*DI3 
+            CH(2,M2,K,3,I) = WA(I,2,1)*DI3-WA(I,2,2)*DR3 
+            CH(1,M2,K,4,I) = WA(I,3,1)*DR4+WA(I,3,2)*DI4 
+            CH(2,M2,K,4,I) = WA(I,3,1)*DI4-WA(I,3,2)*DR4 
+            CH(1,M2,K,5,I) = WA(I,4,1)*DR5+WA(I,4,2)*DI5 
+            CH(2,M2,K,5,I) = WA(I,4,1)*DI5-WA(I,4,2)*DR5 
+  104    CONTINUE 
+  105 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmfgkb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmfgkb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmfgkb.F	(revision 17)
@@ -0,0 +1,144 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cmfgkb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CMFGKB (LOT,IDO,IP,L1,LID,NA,CC,CC1,IM1,IN1,           &
+     &                                      CH,CH1,IM2,IN2,WA)          
+      REAL       CH(2,IN2,L1,IDO,IP) ,CC(2,IN1,L1,IP,IDO),              &
+     &                CC1(2,IN1,LID,IP)    ,CH1(2,IN2,LID,IP)  ,        &
+     &                WA(IDO,IP-1,2)                                    
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      M1D = (LOT-1)*IM1+1 
+      M2S = 1-IM2 
+      IPP2 = IP+2 
+      IPPH = (IP+1)/2 
+      DO 110 KI=1,LID 
+         M2 = M2S 
+         DO 110 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH1(1,M2,KI,1) = CC1(1,M1,KI,1) 
+         CH1(2,M2,KI,1) = CC1(2,M1,KI,1) 
+  110 CONTINUE 
+      DO 111 J=2,IPPH 
+         JC = IPP2-J 
+         DO 112 KI=1,LID 
+         M2 = M2S 
+         DO 112 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CH1(1,M2,KI,J) =  CC1(1,M1,KI,J)+CC1(1,M1,KI,JC) 
+            CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)-CC1(1,M1,KI,JC) 
+            CH1(2,M2,KI,J) =  CC1(2,M1,KI,J)+CC1(2,M1,KI,JC) 
+            CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(2,M1,KI,JC) 
+  112    CONTINUE 
+  111 END DO 
+      DO 118 J=2,IPPH 
+         DO 117 KI=1,LID 
+         M2 = M2S 
+         DO 117 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CC1(1,M1,KI,1) = CC1(1,M1,KI,1)+CH1(1,M2,KI,J) 
+            CC1(2,M1,KI,1) = CC1(2,M1,KI,1)+CH1(2,M2,KI,J) 
+  117    CONTINUE 
+  118 END DO 
+      DO 116 L=2,IPPH 
+         LC = IPP2-L 
+         DO 113 KI=1,LID 
+         M2 = M2S 
+         DO 113 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CC1(1,M1,KI,L) = CH1(1,M2,KI,1)+WA(1,L-1,1)*CH1(1,M2,KI,2) 
+            CC1(1,M1,KI,LC) = WA(1,L-1,2)*CH1(1,M2,KI,IP) 
+            CC1(2,M1,KI,L) = CH1(2,M2,KI,1)+WA(1,L-1,1)*CH1(2,M2,KI,2) 
+            CC1(2,M1,KI,LC) = WA(1,L-1,2)*CH1(2,M2,KI,IP) 
+  113    CONTINUE 
+         DO 115 J=3,IPPH 
+            JC = IPP2-J 
+            IDLJ = MOD((L-1)*(J-1),IP) 
+            WAR = WA(1,IDLJ,1) 
+            WAI = WA(1,IDLJ,2) 
+            DO 114 KI=1,LID 
+               M2 = M2S 
+               DO 114 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               CC1(1,M1,KI,L) = CC1(1,M1,KI,L)+WAR*CH1(1,M2,KI,J) 
+               CC1(1,M1,KI,LC) = CC1(1,M1,KI,LC)+WAI*CH1(1,M2,KI,JC) 
+               CC1(2,M1,KI,L) = CC1(2,M1,KI,L)+WAR*CH1(2,M2,KI,J) 
+               CC1(2,M1,KI,LC) = CC1(2,M1,KI,LC)+WAI*CH1(2,M2,KI,JC) 
+  114       CONTINUE 
+  115    CONTINUE 
+  116 END DO 
+      IF(IDO.GT.1 .OR. NA.EQ.1) GO TO 136 
+      DO 120 J=2,IPPH 
+         JC = IPP2-J 
+         DO 119 KI=1,LID 
+         DO 119 M1=1,M1D,IM1 
+            CHOLD1 = CC1(1,M1,KI,J)-CC1(2,M1,KI,JC) 
+            CHOLD2 = CC1(1,M1,KI,J)+CC1(2,M1,KI,JC) 
+            CC1(1,M1,KI,J) = CHOLD1 
+            CC1(2,M1,KI,JC) = CC1(2,M1,KI,J)-CC1(1,M1,KI,JC) 
+            CC1(2,M1,KI,J) = CC1(2,M1,KI,J)+CC1(1,M1,KI,JC) 
+            CC1(1,M1,KI,JC) = CHOLD2 
+  119    CONTINUE 
+  120 END DO 
+      RETURN 
+  136 DO 137 KI=1,LID 
+         M2 = M2S 
+         DO 137 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH1(1,M2,KI,1) = CC1(1,M1,KI,1) 
+         CH1(2,M2,KI,1) = CC1(2,M1,KI,1) 
+  137 CONTINUE 
+      DO 135 J=2,IPPH 
+         JC = IPP2-J 
+         DO 134 KI=1,LID 
+         M2 = M2S 
+         DO 134 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CH1(1,M2,KI,J) = CC1(1,M1,KI,J)-CC1(2,M1,KI,JC) 
+            CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)+CC1(2,M1,KI,JC) 
+            CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(1,M1,KI,JC) 
+            CH1(2,M2,KI,J) = CC1(2,M1,KI,J)+CC1(1,M1,KI,JC) 
+  134    CONTINUE 
+  135 END DO 
+      IF (IDO .EQ. 1) RETURN 
+      DO 131 I=1,IDO 
+         DO 130 K=1,L1 
+         M2 = M2S 
+         DO 130 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CC(1,M1,K,1,I) = CH(1,M2,K,I,1) 
+            CC(2,M1,K,1,I) = CH(2,M2,K,I,1) 
+  130    CONTINUE 
+  131 END DO 
+      DO 123 J=2,IP 
+         DO 122 K=1,L1 
+         M2 = M2S 
+         DO 122 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CC(1,M1,K,J,1) = CH(1,M2,K,1,J) 
+            CC(2,M1,K,J,1) = CH(2,M2,K,1,J) 
+  122    CONTINUE 
+  123 END DO 
+      DO 126 J=2,IP 
+         DO 125 I=2,IDO 
+            DO 124 K=1,L1 
+               M2 = M2S 
+               DO 124 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               CC(1,M1,K,J,I) = WA(I,J-1,1)*CH(1,M2,K,I,J)              &
+     &                      -WA(I,J-1,2)*CH(2,M2,K,I,J)                 
+               CC(2,M1,K,J,I) = WA(I,J-1,1)*CH(2,M2,K,I,J)              &
+     &                      +WA(I,J-1,2)*CH(1,M2,K,I,J)                 
+  124       CONTINUE 
+  125    CONTINUE 
+  126 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmfgkf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmfgkf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmfgkf.F	(revision 17)
@@ -0,0 +1,172 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cmfgkf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CMFGKF (LOT,IDO,IP,L1,LID,NA,CC,CC1,IM1,IN1,           &
+     &                                      CH,CH1,IM2,IN2,WA)          
+      REAL       CH(2,IN2,L1,IDO,IP) ,CC(2,IN1,L1,IP,IDO),              &
+     &                CC1(2,IN1,LID,IP)    ,CH1(2,IN2,LID,IP)  ,        &
+     &                WA(IDO,IP-1,2)                                    
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      M1D = (LOT-1)*IM1+1 
+      M2S = 1-IM2 
+      IPP2 = IP+2 
+      IPPH = (IP+1)/2 
+      DO 110 KI=1,LID 
+         M2 = M2S 
+         DO 110 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH1(1,M2,KI,1) = CC1(1,M1,KI,1) 
+         CH1(2,M2,KI,1) = CC1(2,M1,KI,1) 
+  110 CONTINUE 
+      DO 111 J=2,IPPH 
+         JC = IPP2-J 
+         DO 112 KI=1,LID 
+         M2 = M2S 
+         DO 112 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CH1(1,M2,KI,J) =  CC1(1,M1,KI,J)+CC1(1,M1,KI,JC) 
+            CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)-CC1(1,M1,KI,JC) 
+            CH1(2,M2,KI,J) =  CC1(2,M1,KI,J)+CC1(2,M1,KI,JC) 
+            CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(2,M1,KI,JC) 
+  112    CONTINUE 
+  111 END DO 
+      DO 118 J=2,IPPH 
+         DO 117 KI=1,LID 
+         M2 = M2S 
+         DO 117 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CC1(1,M1,KI,1) = CC1(1,M1,KI,1)+CH1(1,M2,KI,J) 
+            CC1(2,M1,KI,1) = CC1(2,M1,KI,1)+CH1(2,M2,KI,J) 
+  117    CONTINUE 
+  118 END DO 
+      DO 116 L=2,IPPH 
+         LC = IPP2-L 
+         DO 113 KI=1,LID 
+         M2 = M2S 
+         DO 113 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CC1(1,M1,KI,L) = CH1(1,M2,KI,1)+WA(1,L-1,1)*CH1(1,M2,KI,2) 
+            CC1(1,M1,KI,LC) = -WA(1,L-1,2)*CH1(1,M2,KI,IP) 
+            CC1(2,M1,KI,L) = CH1(2,M2,KI,1)+WA(1,L-1,1)*CH1(2,M2,KI,2) 
+            CC1(2,M1,KI,LC) = -WA(1,L-1,2)*CH1(2,M2,KI,IP) 
+  113    CONTINUE 
+         DO 115 J=3,IPPH 
+            JC = IPP2-J 
+            IDLJ = MOD((L-1)*(J-1),IP) 
+            WAR = WA(1,IDLJ,1) 
+            WAI = -WA(1,IDLJ,2) 
+            DO 114 KI=1,LID 
+               M2 = M2S 
+               DO 114 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               CC1(1,M1,KI,L) = CC1(1,M1,KI,L)+WAR*CH1(1,M2,KI,J) 
+               CC1(1,M1,KI,LC) = CC1(1,M1,KI,LC)+WAI*CH1(1,M2,KI,JC) 
+               CC1(2,M1,KI,L) = CC1(2,M1,KI,L)+WAR*CH1(2,M2,KI,J) 
+               CC1(2,M1,KI,LC) = CC1(2,M1,KI,LC)+WAI*CH1(2,M2,KI,JC) 
+  114       CONTINUE 
+  115    CONTINUE 
+  116 END DO 
+      IF (IDO .GT. 1) GO TO 136 
+      SN = 1./REAL(IP*L1) 
+      IF (NA .EQ. 1) GO TO 146 
+      DO 149 KI=1,LID 
+         M2 = M2S 
+         DO 149 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CC1(1,M1,KI,1) = SN*CC1(1,M1,KI,1) 
+         CC1(2,M1,KI,1) = SN*CC1(2,M1,KI,1) 
+  149 CONTINUE 
+      DO 120 J=2,IPPH 
+         JC = IPP2-J 
+         DO 119 KI=1,LID 
+         DO 119 M1=1,M1D,IM1 
+            CHOLD1 = SN*(CC1(1,M1,KI,J)-CC1(2,M1,KI,JC)) 
+            CHOLD2 = SN*(CC1(1,M1,KI,J)+CC1(2,M1,KI,JC)) 
+            CC1(1,M1,KI,J) = CHOLD1 
+            CC1(2,M1,KI,JC) = SN*(CC1(2,M1,KI,J)-CC1(1,M1,KI,JC)) 
+            CC1(2,M1,KI,J) = SN*(CC1(2,M1,KI,J)+CC1(1,M1,KI,JC)) 
+            CC1(1,M1,KI,JC) = CHOLD2 
+  119    CONTINUE 
+  120 END DO 
+      RETURN 
+  146 DO 147 KI=1,LID 
+         M2 = M2S 
+         DO 147 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH1(1,M2,KI,1) = SN*CC1(1,M1,KI,1) 
+         CH1(2,M2,KI,1) = SN*CC1(2,M1,KI,1) 
+  147 CONTINUE 
+      DO 145 J=2,IPPH 
+         JC = IPP2-J 
+         DO 144 KI=1,LID 
+         M2 = M2S 
+         DO 144 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CH1(1,M2,KI,J) = SN*(CC1(1,M1,KI,J)-CC1(2,M1,KI,JC)) 
+            CH1(2,M2,KI,J) = SN*(CC1(2,M1,KI,J)+CC1(1,M1,KI,JC)) 
+            CH1(1,M2,KI,JC) = SN*(CC1(1,M1,KI,J)+CC1(2,M1,KI,JC)) 
+            CH1(2,M2,KI,JC) = SN*(CC1(2,M1,KI,J)-CC1(1,M1,KI,JC)) 
+  144    CONTINUE 
+  145 END DO 
+      RETURN 
+  136 DO 137 KI=1,LID 
+         M2 = M2S 
+         DO 137 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH1(1,M2,KI,1) = CC1(1,M1,KI,1) 
+         CH1(2,M2,KI,1) = CC1(2,M1,KI,1) 
+  137 CONTINUE 
+      DO 135 J=2,IPPH 
+         JC = IPP2-J 
+         DO 134 KI=1,LID 
+         M2 = M2S 
+         DO 134 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CH1(1,M2,KI,J) = CC1(1,M1,KI,J)-CC1(2,M1,KI,JC) 
+            CH1(2,M2,KI,J) = CC1(2,M1,KI,J)+CC1(1,M1,KI,JC) 
+            CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)+CC1(2,M1,KI,JC) 
+            CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(1,M1,KI,JC) 
+  134    CONTINUE 
+  135 END DO 
+      DO 131 I=1,IDO 
+         DO 130 K=1,L1 
+         M2 = M2S 
+         DO 130 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CC(1,M1,K,1,I) = CH(1,M2,K,I,1) 
+            CC(2,M1,K,1,I) = CH(2,M2,K,I,1) 
+  130    CONTINUE 
+  131 END DO 
+      DO 123 J=2,IP 
+         DO 122 K=1,L1 
+         M2 = M2S 
+         DO 122 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+            CC(1,M1,K,J,1) = CH(1,M2,K,1,J) 
+            CC(2,M1,K,J,1) = CH(2,M2,K,1,J) 
+  122    CONTINUE 
+  123 END DO 
+      DO 126 J=2,IP 
+         DO 125 I=2,IDO 
+            DO 124 K=1,L1 
+               M2 = M2S 
+               DO 124 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               CC(1,M1,K,J,I) = WA(I,J-1,1)*CH(1,M2,K,I,J)              &
+     &                      +WA(I,J-1,2)*CH(2,M2,K,I,J)                 
+               CC(2,M1,K,J,I) = WA(I,J-1,1)*CH(2,M2,K,I,J)              &
+     &                      -WA(I,J-1,2)*CH(1,M2,K,I,J)                 
+  124       CONTINUE 
+  125    CONTINUE 
+  126 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmfm1b.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmfm1b.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmfm1b.F	(revision 17)
@@ -0,0 +1,54 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cmfm1b.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CMFM1B (LOT,JUMP,N,INC,C,CH,WA,FNF,FAC) 
+      COMPLEX       C(*) 
+      REAL       CH(*),     WA(*),     FAC(*) 
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      NF = FNF 
+      NA = 0 
+      L1 = 1 
+      IW = 1 
+      DO 125 K1=1,NF 
+         IP = FAC(K1) 
+         L2 = IP*L1 
+         IDO = N/L2 
+         LID = L1*IDO 
+         NBR = 1+NA+2*MIN(IP-2,4) 
+         GO TO (52,62,53,63,54,64,55,65,56,66),NBR 
+   52    CALL CMF2KB (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
+         GO TO 120 
+   62    CALL CMF2KB (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
+         GO TO 120 
+   53    CALL CMF3KB (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
+         GO TO 120 
+   63    CALL CMF3KB (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
+         GO TO 120 
+   54    CALL CMF4KB (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
+         GO TO 120 
+   64    CALL CMF4KB (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
+         GO TO 120 
+   55    CALL CMF5KB (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
+         GO TO 120 
+   65    CALL CMF5KB (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
+         GO TO 120 
+   56    CALL CMFGKB (LOT,IDO,IP,L1,LID,NA,C,C,JUMP,INC,CH,CH,1,        &
+     &     LOT,WA(IW))                                                  
+         GO TO 120 
+   66    CALL CMFGKB (LOT,IDO,IP,L1,LID,NA,CH,CH,1,LOT,C,C,             &
+     &     JUMP,INC,WA(IW))                                             
+  120    L1 = L2 
+         IW = IW+(IP-1)*(IDO+IDO) 
+         IF(IP .LE. 5) NA = 1-NA 
+  125 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmfm1f.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmfm1f.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cmfm1f.F	(revision 17)
@@ -0,0 +1,54 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cmfm1f.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE CMFM1F (LOT,JUMP,N,INC,C,CH,WA,FNF,FAC) 
+      COMPLEX       C(*) 
+      REAL       CH(*),     WA(*),      FAC(*) 
+!                                                                       
+! FFTPACK 5.0 auxiliary routine                                         
+!                                                                       
+      NF = FNF 
+      NA = 0 
+      L1 = 1 
+      IW = 1 
+      DO 125 K1=1,NF 
+         IP = FAC(K1) 
+         L2 = IP*L1 
+         IDO = N/L2 
+         LID = L1*IDO 
+         NBR = 1+NA+2*MIN(IP-2,4) 
+         GO TO (52,62,53,63,54,64,55,65,56,66),NBR 
+   52    CALL CMF2KF (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
+         GO TO 120 
+   62    CALL CMF2KF (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
+         GO TO 120 
+   53    CALL CMF3KF (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
+         GO TO 120 
+   63    CALL CMF3KF (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
+         GO TO 120 
+   54    CALL CMF4KF (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
+         GO TO 120 
+   64    CALL CMF4KF (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
+         GO TO 120 
+   55    CALL CMF5KF (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
+         GO TO 120 
+   65    CALL CMF5KF (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
+         GO TO 120 
+   56    CALL CMFGKF (LOT,IDO,IP,L1,LID,NA,C,C,JUMP,INC,CH,CH,          &
+     &     1,LOT,WA(IW))                                                
+         GO TO 120 
+   66    CALL CMFGKF (LOT,IDO,IP,L1,LID,NA,CH,CH,1,LOT,C,C,             &
+     &     JUMP,INC,WA(IW))                                             
+  120    L1 = L2 
+         IW = IW+(IP-1)*(IDO+IDO) 
+         IF(IP .LE. 5) NA = 1-NA 
+  125 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosq1b.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosq1b.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosq1b.F	(revision 17)
@@ -0,0 +1,45 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cosq1b.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COSQ1B (N, INC, X, LENX, WSAVE, LENSAV,                &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENX .LT. INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('COSQ1B', 6) 
+        GO TO 300 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('COSQ1B', 8) 
+        GO TO 300 
+      ELSEIF (LENWRK .LT. N) THEN 
+        IER = 3 
+        CALL XERFFT ('COSQ1B', 10) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      IF (N-2) 300,102,103 
+  102 SSQRT2 = 1./SQRT(2.) 
+      X1 = X(1,1)+X(1,2) 
+      X(1,2) = SSQRT2*(X(1,1)-X(1,2)) 
+      X(1,1) = X1 
+      RETURN 
+  103 CALL COSQB1 (N,INC,X,WSAVE,WORK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COSQ1B',-5) 
+      ENDIF 
+!                                                                       
+  300 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosq1f.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosq1f.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosq1f.F	(revision 17)
@@ -0,0 +1,46 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cosq1f.f,v 1.3 2004/06/15 21:14:57 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COSQ1F (N, INC, X, LENX, WSAVE, LENSAV,                &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENX .LT. INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('COSQ1F', 6) 
+        GO TO 300 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('COSQ1F', 8) 
+        GO TO 300 
+      ELSEIF (LENWRK .LT. N) THEN 
+        IER = 3 
+        CALL XERFFT ('COSQ1F', 10) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      IF (N-2) 102,101,103 
+  101 SSQRT2 = 1./SQRT(2.) 
+      TSQX = SSQRT2*X(1,2) 
+      X(1,2) = .5*X(1,1)-TSQX 
+      X(1,1) = .5*X(1,1)+TSQX 
+  102 RETURN 
+  103 CALL COSQF1 (N,INC,X,WSAVE,WORK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COSQ1F',-5) 
+      ENDIF 
+!                                                                       
+  300 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosq1i.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosq1i.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosq1i.F	(revision 17)
@@ -0,0 +1,37 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cosq1i.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COSQ1I (N, WSAVE, LENSAV, IER) 
+      INTEGER    N, LENSAV, IER 
+      REAL       WSAVE(LENSAV) 
+!                                                                       
+      IER = 0 
+      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('COSQ1I', 3) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      PIH = 2.*ATAN(1.) 
+      DT = PIH/FLOAT(N) 
+      FK = 0. 
+      DO 101 K=1,N 
+         FK = FK+1. 
+         WSAVE(K) = COS(FK*DT) 
+  101 END DO 
+      LNSV = N + INT(LOG(REAL(N))) +4 
+      CALL RFFT1I (N, WSAVE(N+1), LNSV, IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COSQ1I',-5) 
+      ENDIF 
+  300 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqb1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqb1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqb1.F	(revision 17)
@@ -0,0 +1,50 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cosqb1.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COSQB1 (N,INC,X,WSAVE,WORK,IER) 
+      DIMENSION       X(INC,*)     ,WSAVE(*)     ,WORK(*) 
+      IER = 0 
+      NS2 = (N+1)/2 
+      NP2 = N+2 
+      DO 101 I=3,N,2 
+         XIM1 = X(1,I-1)+X(1,I) 
+         X(1,I) = .5*(X(1,I-1)-X(1,I)) 
+         X(1,I-1) = .5*XIM1 
+  101 END DO 
+      X(1,1) = .5*X(1,1) 
+      MODN = MOD(N,2) 
+      IF (MODN .NE. 0) GO TO 302 
+      X(1,N) = .5*X(1,N) 
+  302 LENX = INC*(N-1)  + 1 
+      LNSV = N + INT(LOG(REAL(N))) + 4 
+      LNWK = N 
+!                                                                       
+      CALL RFFT1B(N,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COSQB1',-5) 
+        GO TO 400 
+      ENDIF 
+!                                                                       
+      DO 102 K=2,NS2 
+         KC = NP2-K 
+         WORK(K) = WSAVE(K-1)*X(1,KC)+WSAVE(KC-1)*X(1,K) 
+         WORK(KC) = WSAVE(K-1)*X(1,K)-WSAVE(KC-1)*X(1,KC) 
+  102 END DO 
+      IF (MODN .NE. 0) GO TO 305 
+      X(1,NS2+1) = WSAVE(NS2)*(X(1,NS2+1)+X(1,NS2+1)) 
+  305 DO 103 K=2,NS2 
+         KC = NP2-K 
+         X(1,K) = WORK(K)+WORK(KC) 
+         X(1,KC) = WORK(K)-WORK(KC) 
+  103 END DO 
+      X(1,1) = X(1,1)+X(1,1) 
+  400 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqf1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqf1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqf1.F	(revision 17)
@@ -0,0 +1,48 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cosqf1.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COSQF1 (N,INC,X,WSAVE,WORK,IER) 
+      DIMENSION       X(INC,*)      ,WSAVE(*)      ,WORK(*) 
+      IER = 0 
+      NS2 = (N+1)/2 
+      NP2 = N+2 
+      DO 101 K=2,NS2 
+         KC = NP2-K 
+         WORK(K)  = X(1,K)+X(1,KC) 
+         WORK(KC) = X(1,K)-X(1,KC) 
+  101 END DO 
+      MODN = MOD(N,2) 
+      IF (MODN .NE. 0) GO TO 301 
+      WORK(NS2+1) = X(1,NS2+1)+X(1,NS2+1) 
+  301 DO 102 K=2,NS2 
+         KC = NP2-K 
+         X(1,K)  = WSAVE(K-1)*WORK(KC)+WSAVE(KC-1)*WORK(K) 
+         X(1,KC) = WSAVE(K-1)*WORK(K) -WSAVE(KC-1)*WORK(KC) 
+  102 END DO 
+      IF (MODN .NE. 0) GO TO 303 
+      X(1,NS2+1) = WSAVE(NS2)*WORK(NS2+1) 
+  303 LENX = INC*(N-1)  + 1 
+      LNSV = N + INT(LOG(REAL(N))) + 4 
+      LNWK = N 
+!                                                                       
+      CALL RFFT1F(N,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COSQF1',-5) 
+        GO TO 400 
+      ENDIF 
+!                                                                       
+      DO 103 I=3,N,2 
+         XIM1 = .5*(X(1,I-1)+X(1,I)) 
+         X(1,I) = .5*(X(1,I-1)-X(1,I)) 
+         X(1,I-1) = XIM1 
+  103 END DO 
+  400 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqmb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqmb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqmb.F	(revision 17)
@@ -0,0 +1,58 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cosqmb.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COSQMB (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+      LOGICAL    XERCON 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('COSQMB', 6) 
+        GO TO 300 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('COSQMB', 8) 
+        GO TO 300 
+      ELSEIF (LENWRK .LT. LOT*N) THEN 
+        IER = 3 
+        CALL XERFFT ('COSQMB', 10) 
+        GO TO 300 
+      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
+        IER = 4 
+        CALL XERFFT ('COSQMB', -1) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      LJ = (LOT-1)*JUMP+1 
+      IF (N-2) 101,102,103 
+  101 DO 201 M=1,LJ,JUMP 
+      X(M,1) = X(M,1) 
+  201 END DO 
+      RETURN 
+  102 SSQRT2 = 1./SQRT(2.) 
+      DO 202 M=1,LJ,JUMP 
+      X1 = X(M,1)+X(M,2) 
+      X(M,2) = SSQRT2*(X(M,1)-X(M,2)) 
+      X(M,1) = X1 
+  202 END DO 
+      RETURN 
+  103 CALL MCSQB1 (LOT,JUMP,N,INC,X,WSAVE,WORK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COSQMB',-5) 
+      ENDIF 
+!                                                                       
+  300 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqmf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqmf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqmf.F	(revision 17)
@@ -0,0 +1,54 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cosqmf.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COSQMF (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+      LOGICAL    XERCON 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('COSQMF', 6) 
+        GO TO 300 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('COSQMF', 8) 
+        GO TO 300 
+      ELSEIF (LENWRK .LT. LOT*N) THEN 
+        IER = 3 
+        CALL XERFFT ('COSQMF', 10) 
+        GO TO 300 
+      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
+        IER = 4 
+        CALL XERFFT ('COSQMF', -1) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      LJ = (LOT-1)*JUMP+1 
+      IF (N-2) 102,101,103 
+  101 SSQRT2 = 1./SQRT(2.) 
+      DO 201 M=1,LJ,JUMP 
+      TSQX = SSQRT2*X(M,2) 
+      X(M,2) = .5*X(M,1)-TSQX 
+      X(M,1) = .5*X(M,1)+TSQX 
+  201 END DO 
+  102 RETURN 
+  103 CALL MCSQF1 (LOT,JUMP,N,INC,X,WSAVE,WORK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COSQMF',-5) 
+      ENDIF 
+!                                                                       
+  300 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqmi.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqmi.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cosqmi.F	(revision 17)
@@ -0,0 +1,38 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cosqmi.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COSQMI (N, WSAVE, LENSAV, IER) 
+      INTEGER    N, LENSAV, IER 
+      REAL       WSAVE(LENSAV) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('COSQMI', 3) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      PIH = 2.*ATAN(1.) 
+      DT = PIH/FLOAT(N) 
+      FK = 0. 
+      DO 101 K=1,N 
+         FK = FK+1. 
+         WSAVE(K) = COS(FK*DT) 
+  101 END DO 
+      LNSV = N + INT(LOG(REAL(N))) +4 
+      CALL RFFTMI (N, WSAVE(N+1), LNSV, IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COSQMI',-5) 
+      ENDIF 
+  300 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cost1b.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cost1b.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cost1b.F	(revision 17)
@@ -0,0 +1,39 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cost1b.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COST1B ( N, INC, X, LENX, WSAVE, LENSAV,               &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+!                                                                       
+      IER = 0 
+      IF (LENX .LT. INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('COST1B', 6) 
+        GO TO 100 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('COST1B', 8) 
+        GO TO 100 
+      ELSEIF (LENWRK .LT. N-1) THEN 
+        IER = 3 
+        CALL XERFFT ('COST1B', 10) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+      CALL COSTB1 (N,INC,X,WSAVE,WORK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COST1B',-5) 
+      ENDIF 
+!                                                                       
+  100 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cost1f.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cost1f.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cost1f.F	(revision 17)
@@ -0,0 +1,39 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cost1f.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COST1F ( N, INC, X, LENX, WSAVE, LENSAV,               &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+!                                                                       
+      IER = 0 
+      IF (LENX .LT. INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('COST1F', 6) 
+        GO TO 100 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('COST1F', 8) 
+        GO TO 100 
+      ELSEIF (LENWRK .LT. N-1) THEN 
+        IER = 3 
+        CALL XERFFT ('COST1F', 10) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+      CALL COSTF1(N,INC,X,WSAVE,WORK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COST1F',-5) 
+      ENDIF 
+!                                                                       
+  100 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cost1i.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cost1i.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/cost1i.F	(revision 17)
@@ -0,0 +1,44 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: cost1i.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COST1I (N, WSAVE, LENSAV, IER) 
+      INTEGER    N, LENSAV, IER 
+      REAL       WSAVE(LENSAV) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('COST1I', 3) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      IF (N .LE. 3) RETURN 
+      NM1 = N-1 
+      NP1 = N+1 
+      NS2 = N/2 
+      PI = 4.*ATAN(1.) 
+      DT = PI/FLOAT(NM1) 
+      FK = 0. 
+      DO 101 K=2,NS2 
+         KC = NP1-K 
+         FK = FK+1. 
+         WSAVE(K) = 2.*SIN(FK*DT) 
+         WSAVE(KC) = 2.*COS(FK*DT) 
+  101 END DO 
+      LNSV = NM1 + INT(LOG(REAL(NM1))) +4 
+      CALL RFFT1I (NM1, WSAVE(N+1), LNSV, IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COST1I',-5) 
+      ENDIF 
+  300 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costb1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costb1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costb1.F	(revision 17)
@@ -0,0 +1,73 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: costb1.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COSTB1(N,INC,X,WSAVE,WORK,IER) 
+      REAL       X(INC,*)       ,WSAVE(*) 
+      DOUBLE PRECISION           DSUM 
+      IER = 0 
+      NM1 = N-1 
+      NP1 = N+1 
+      NS2 = N/2 
+      IF (N-2) 106,101,102 
+  101 X1H = X(1,1)+X(1,2) 
+      X(1,2) = X(1,1)-X(1,2) 
+      X(1,1) = X1H 
+      RETURN 
+  102 IF (N .GT. 3) GO TO 103 
+      X1P3 = X(1,1)+X(1,3) 
+      X2 = X(1,2) 
+      X(1,2) = X(1,1)-X(1,3) 
+      X(1,1) = X1P3+X2 
+      X(1,3) = X1P3-X2 
+      RETURN 
+  103 X(1,1) = X(1,1)+X(1,1) 
+      X(1,N) = X(1,N)+X(1,N) 
+      DSUM = X(1,1)-X(1,N) 
+      X(1,1) = X(1,1)+X(1,N) 
+      DO 104 K=2,NS2 
+         KC = NP1-K 
+         T1 = X(1,K)+X(1,KC) 
+         T2 = X(1,K)-X(1,KC) 
+         DSUM = DSUM+WSAVE(KC)*T2 
+         T2 = WSAVE(K)*T2 
+         X(1,K) = T1-T2 
+         X(1,KC) = T1+T2 
+  104 END DO 
+      MODN = MOD(N,2) 
+      IF (MODN .EQ. 0) GO TO 124 
+      X(1,NS2+1) = X(1,NS2+1)+X(1,NS2+1) 
+  124 LENX = INC*(NM1-1)  + 1 
+      LNSV = NM1 + INT(LOG(REAL(NM1))) + 4 
+      LNWK = NM1 
+!                                                                       
+      CALL RFFT1F(NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,                  &
+     &            LNWK,IER1)                                            
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COSTB1',-5) 
+        RETURN 
+      ENDIF 
+!                                                                       
+      FNM1S2 = FLOAT(NM1)/2. 
+      DSUM = .5*DSUM 
+      X(1,1) = FNM1S2*X(1,1) 
+      IF(MOD(NM1,2) .NE. 0) GO TO 30 
+      X(1,NM1) = X(1,NM1)+X(1,NM1) 
+   30 FNM1S4 = FLOAT(NM1)/4. 
+      DO 105 I=3,N,2 
+         XI = FNM1S4*X(1,I) 
+         X(1,I) = FNM1S4*X(1,I-1) 
+         X(1,I-1) = DSUM 
+         DSUM = DSUM+XI 
+  105 END DO 
+      IF (MODN .NE. 0) RETURN 
+         X(1,N) = DSUM 
+  106 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costf1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costf1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costf1.F	(revision 17)
@@ -0,0 +1,71 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: costf1.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COSTF1(N,INC,X,WSAVE,WORK,IER) 
+      REAL       X(INC,*)       ,WSAVE(*) 
+      DOUBLE PRECISION           DSUM 
+      IER = 0 
+      NM1 = N-1 
+      NP1 = N+1 
+      NS2 = N/2 
+      IF (N-2) 200,101,102 
+  101 X1H = X(1,1)+X(1,2) 
+      X(1,2) = .5*(X(1,1)-X(1,2)) 
+      X(1,1) = .5*X1H 
+      GO TO 200 
+  102 IF (N .GT. 3) GO TO 103 
+      X1P3 = X(1,1)+X(1,3) 
+      TX2 = X(1,2)+X(1,2) 
+      X(1,2) = .5*(X(1,1)-X(1,3)) 
+      X(1,1) = .25*(X1P3+TX2) 
+      X(1,3) = .25*(X1P3-TX2) 
+      GO TO 200 
+  103 DSUM = X(1,1)-X(1,N) 
+      X(1,1) = X(1,1)+X(1,N) 
+      DO 104 K=2,NS2 
+         KC = NP1-K 
+         T1 = X(1,K)+X(1,KC) 
+         T2 = X(1,K)-X(1,KC) 
+         DSUM = DSUM+WSAVE(KC)*T2 
+         T2 = WSAVE(K)*T2 
+         X(1,K) = T1-T2 
+         X(1,KC) = T1+T2 
+  104 END DO 
+      MODN = MOD(N,2) 
+      IF (MODN .EQ. 0) GO TO 124 
+      X(1,NS2+1) = X(1,NS2+1)+X(1,NS2+1) 
+  124 LENX = INC*(NM1-1)  + 1 
+      LNSV = NM1 + INT(LOG(REAL(NM1))) + 4 
+      LNWK = NM1 
+!                                                                       
+      CALL RFFT1F(NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,                  &
+     &            LNWK,IER1)                                            
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COSTF1',-5) 
+        GO TO 200 
+      ENDIF 
+!                                                                       
+      SNM1 = 1./FLOAT(NM1) 
+      DSUM = SNM1*DSUM 
+      IF(MOD(NM1,2) .NE. 0) GO TO 30 
+      X(1,NM1) = X(1,NM1)+X(1,NM1) 
+   30 DO 105 I=3,N,2 
+         XI = .5*X(1,I) 
+         X(1,I) = .5*X(1,I-1) 
+         X(1,I-1) = DSUM 
+         DSUM = DSUM+XI 
+  105 END DO 
+      IF (MODN .NE. 0) GO TO 117 
+      X(1,N) = DSUM 
+  117 X(1,1) = .5*X(1,1) 
+      X(1,N) = .5*X(1,N) 
+  200 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costmb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costmb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costmb.F	(revision 17)
@@ -0,0 +1,46 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: costmb.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COSTMB (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+      LOGICAL    XERCON 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('COSTMB', 6) 
+        GO TO 100 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('COSTMB', 8) 
+        GO TO 100 
+      ELSEIF (LENWRK .LT. LOT*(N+1)) THEN 
+        IER = 3 
+        CALL XERFFT ('COSTMB', 10) 
+        GO TO 100 
+      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
+        IER = 4 
+        CALL XERFFT ('COSTMB', -1) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+      IW1 = LOT+LOT+1 
+      CALL MCSTB1(LOT,JUMP,N,INC,X,WSAVE,WORK,WORK(IW1),IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COSTMB',-5) 
+      ENDIF 
+!                                                                       
+  100 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costmf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costmf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costmf.F	(revision 17)
@@ -0,0 +1,46 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: costmf.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COSTMF (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+      LOGICAL    XERCON 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('COSTMF', 6) 
+        GO TO 100 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('COSTMF', 8) 
+        GO TO 100 
+      ELSEIF (LENWRK .LT. LOT*(N+1)) THEN 
+        IER = 3 
+        CALL XERFFT ('COSTMF', 10) 
+        GO TO 100 
+      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
+        IER = 4 
+        CALL XERFFT ('COSTMF', -1) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+      IW1 = LOT+LOT+1 
+      CALL MCSTF1(LOT,JUMP,N,INC,X,WSAVE,WORK,WORK(IW1),IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COSTMF',-5) 
+      ENDIF 
+!                                                                       
+  100 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costmi.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costmi.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/costmi.F	(revision 17)
@@ -0,0 +1,44 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: costmi.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE COSTMI (N, WSAVE, LENSAV, IER) 
+      INTEGER    N, LENSAV, IER 
+      REAL       WSAVE(LENSAV) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('COSTMI', 3) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      IF (N .LE. 3) RETURN 
+      NM1 = N-1 
+      NP1 = N+1 
+      NS2 = N/2 
+      PI = 4.*ATAN(1.) 
+      DT = PI/FLOAT(NM1) 
+      FK = 0. 
+      DO 101 K=2,NS2 
+         KC = NP1-K 
+         FK = FK+1. 
+         WSAVE(K) = 2.*SIN(FK*DT) 
+         WSAVE(KC) = 2.*COS(FK*DT) 
+  101 END DO 
+      LNSV = NM1 + INT(LOG(REAL(NM1))) +4 
+      CALL RFFTMI (NM1, WSAVE(N+1), LNSV, IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('COSTMI',-5) 
+      ENDIF 
+  300 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/factor.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/factor.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/factor.F	(revision 17)
@@ -0,0 +1,32 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: factor.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE FACTOR (N,NF,FAC) 
+      REAL FAC(*) 
+      INTEGER NTRYH(4) 
+      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ 
+!                                                                       
+      NL = N 
+      NF = 0 
+      J = 0 
+  101 J = J+1 
+      IF (J-4) 102,102,103 
+  102 NTRY = NTRYH(J) 
+      GO TO 104 
+  103 NTRY = NTRY+2 
+  104 NQ = NL/NTRY 
+      NR = NL-NTRY*NQ 
+      IF (NR) 101,105,101 
+  105 NF = NF+1 
+      FAC(NF) = NTRY 
+      NL = NQ 
+      IF (NL .NE. 1) GO TO 104 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcfti1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcfti1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcfti1.F	(revision 17)
@@ -0,0 +1,27 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mcfti1.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MCFTI1 (N,WA,FNF,FAC) 
+      REAL            WA(*),FAC(*) 
+!                                                                       
+      CALL FACTOR (N,NF,FAC) 
+      FNF = NF 
+      IW = 1 
+      L1 = 1 
+      DO 110 K1=1,NF 
+         IP = FAC(K1) 
+         L2 = L1*IP 
+         IDO = N/L2 
+         CALL TABLES (IDO,IP,WA(IW)) 
+         IW = IW+(IP-1)*(IDO+IDO) 
+         L1 = L2 
+  110 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcsqb1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcsqb1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcsqb1.F	(revision 17)
@@ -0,0 +1,71 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mcsqb1.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MCSQB1 (LOT,JUMP,N,INC,X,WSAVE,WORK,IER) 
+      DIMENSION       X(INC,*)     ,WSAVE(*)     ,WORK(LOT,*) 
+      IER = 0 
+      LJ = (LOT-1)*JUMP+1 
+      NS2 = (N+1)/2 
+      NP2 = N+2 
+      DO 101 I=3,N,2 
+         DO 201 M=1,LJ,JUMP 
+         XIM1 = X(M,I-1)+X(M,I) 
+         X(M,I) = .5*(X(M,I-1)-X(M,I)) 
+         X(M,I-1) = .5*XIM1 
+  201    CONTINUE 
+  101 END DO 
+      DO 301 M=1,LJ,JUMP 
+      X(M,1) = .5*X(M,1) 
+  301 END DO 
+      MODN = MOD(N,2) 
+      IF (MODN .NE. 0) GO TO 302 
+      DO 303 M=1,LJ,JUMP 
+      X(M,N) = .5*X(M,N) 
+  303 END DO 
+  302 CONTINUE 
+      LENX = (LOT-1)*JUMP + INC*(N-1)  + 1 
+      LNSV = N + INT(LOG(REAL(N))) + 4 
+      LNWK = LOT*N 
+!                                                                       
+      CALL RFFTMB(LOT,JUMP,N,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('MCSQB1',-5) 
+        GO TO 400 
+      ENDIF 
+!                                                                       
+      DO 102 K=2,NS2 
+         KC = NP2-K 
+         M1 = 0 
+         DO 202 M=1,LJ,JUMP 
+         M1 = M1 + 1 
+         WORK(M1,K) = WSAVE(K-1)*X(M,KC)+WSAVE(KC-1)*X(M,K) 
+         WORK(M1,KC) = WSAVE(K-1)*X(M,K)-WSAVE(KC-1)*X(M,KC) 
+  202    CONTINUE 
+  102 END DO 
+      IF (MODN .NE. 0) GO TO 305 
+      DO 304 M=1,LJ,JUMP 
+         X(M,NS2+1) = WSAVE(NS2)*(X(M,NS2+1)+X(M,NS2+1)) 
+  304    CONTINUE 
+  305 DO 103 K=2,NS2 
+         KC = NP2-K 
+         M1 = 0 
+         DO 203 M=1,LJ,JUMP 
+            M1 = M1 + 1 
+            X(M,K) = WORK(M1,K)+WORK(M1,KC) 
+            X(M,KC) = WORK(M1,K)-WORK(M1,KC) 
+  203    CONTINUE 
+  103 END DO 
+      DO 104 M=1,LJ,JUMP 
+      X(M,1) = X(M,1)+X(M,1) 
+  104 END DO 
+  400 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcsqf1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcsqf1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcsqf1.F	(revision 17)
@@ -0,0 +1,69 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mcsqf1.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MCSQF1 (LOT,JUMP,N,INC,X,WSAVE,WORK,IER) 
+      DIMENSION       X(INC,*)      ,WSAVE(*)      ,WORK(LOT,*) 
+      IER = 0 
+      LJ = (LOT-1)*JUMP+1 
+      NS2 = (N+1)/2 
+      NP2 = N+2 
+      DO 101 K=2,NS2 
+         KC = NP2-K 
+         M1 = 0 
+         DO 201 M=1,LJ,JUMP 
+         M1 = M1 + 1 
+         WORK(M1,K)  = X(M,K)+X(M,KC) 
+         WORK(M1,KC) = X(M,K)-X(M,KC) 
+  201    CONTINUE 
+  101 END DO 
+      MODN = MOD(N,2) 
+      IF (MODN .NE. 0) GO TO 301 
+         M1 = 0 
+         DO 202 M=1,LJ,JUMP 
+         M1 = M1 + 1 
+         WORK(M1,NS2+1) = X(M,NS2+1)+X(M,NS2+1) 
+  202    CONTINUE 
+  301    DO 102 K=2,NS2 
+         KC = NP2-K 
+         M1 = 0 
+         DO 302 M=1,LJ,JUMP 
+         M1 = M1 + 1 
+         X(M,K)  = WSAVE(K-1)*WORK(M1,KC)+WSAVE(KC-1)*WORK(M1,K) 
+         X(M,KC) = WSAVE(K-1)*WORK(M1,K) -WSAVE(KC-1)*WORK(M1,KC) 
+  302    CONTINUE 
+  102 END DO 
+      IF (MODN .NE. 0) GO TO 303 
+      M1 = 0 
+      DO 304 M=1,LJ,JUMP 
+         M1 = M1 + 1 
+         X(M,NS2+1) = WSAVE(NS2)*WORK(M1,NS2+1) 
+  304 END DO 
+  303 CONTINUE 
+      LENX = (LOT-1)*JUMP + INC*(N-1)  + 1 
+      LNSV = N + INT(LOG(REAL(N))) + 4 
+      LNWK = LOT*N 
+!                                                                       
+      CALL RFFTMF(LOT,JUMP,N,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('MCSQF1',-5) 
+        GO TO 400 
+      ENDIF 
+!                                                                       
+      DO 103 I=3,N,2 
+         DO 203 M=1,LJ,JUMP 
+            XIM1 = .5*(X(M,I-1)+X(M,I)) 
+            X(M,I) = .5*(X(M,I-1)-X(M,I)) 
+            X(M,I-1) = XIM1 
+  203    CONTINUE 
+  103 END DO 
+  400 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcstb1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcstb1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcstb1.F	(revision 17)
@@ -0,0 +1,106 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mcstb1.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MCSTB1(LOT,JUMP,N,INC,X,WSAVE,DSUM,WORK,IER) 
+      REAL       X(INC,*)       ,WSAVE(*) 
+      DOUBLE PRECISION           DSUM(*) 
+      IER = 0 
+      NM1 = N-1 
+      NP1 = N+1 
+      NS2 = N/2 
+      LJ = (LOT-1)*JUMP+1 
+      IF (N-2) 106,101,102 
+  101 DO 111 M=1,LJ,JUMP 
+         X1H = X(M,1)+X(M,2) 
+         X(M,2) = X(M,1)-X(M,2) 
+         X(M,1) = X1H 
+  111 END DO 
+      RETURN 
+  102 IF (N .GT. 3) GO TO 103 
+      DO 112 M=1,LJ,JUMP 
+         X1P3 = X(M,1)+X(M,3) 
+         X2 = X(M,2) 
+         X(M,2) = X(M,1)-X(M,3) 
+         X(M,1) = X1P3+X2 
+         X(M,3) = X1P3-X2 
+  112 END DO 
+      RETURN 
+  103 DO 118 M=1,LJ,JUMP 
+      X(M,1) = X(M,1)+X(M,1) 
+      X(M,N) = X(M,N)+X(M,N) 
+  118 END DO 
+      M1 = 0 
+      DO 113 M=1,LJ,JUMP 
+         M1 = M1+1 
+         DSUM(M1) = X(M,1)-X(M,N) 
+         X(M,1) = X(M,1)+X(M,N) 
+  113 END DO 
+      DO 104 K=2,NS2 
+         M1 = 0 
+         DO 114 M=1,LJ,JUMP 
+         M1 = M1+1 
+         KC = NP1-K 
+         T1 = X(M,K)+X(M,KC) 
+         T2 = X(M,K)-X(M,KC) 
+         DSUM(M1) = DSUM(M1)+WSAVE(KC)*T2 
+         T2 = WSAVE(K)*T2 
+         X(M,K) = T1-T2 
+         X(M,KC) = T1+T2 
+  114    CONTINUE 
+  104 END DO 
+      MODN = MOD(N,2) 
+      IF (MODN .EQ. 0) GO TO 124 
+         DO 123 M=1,LJ,JUMP 
+         X(M,NS2+1) = X(M,NS2+1)+X(M,NS2+1) 
+  123    CONTINUE 
+  124 CONTINUE 
+      LENX = (LOT-1)*JUMP + INC*(NM1-1)  + 1 
+      LNSV = NM1 + INT(LOG(REAL(NM1))) + 4 
+      LNWK = LOT*NM1 
+!                                                                       
+      CALL RFFTMF(LOT,JUMP,NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,         &
+     &            LNWK,IER1)                                            
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('MCSTB1',-5) 
+        GO TO 106 
+      ENDIF 
+!                                                                       
+      FNM1S2 = FLOAT(NM1)/2. 
+      M1 = 0 
+      DO 10 M=1,LJ,JUMP 
+      M1 = M1+1 
+      DSUM(M1) = .5*DSUM(M1) 
+      X(M,1) = FNM1S2*X(M,1) 
+   10 END DO 
+      IF(MOD(NM1,2) .NE. 0) GO TO 30 
+      DO 20 M=1,LJ,JUMP 
+      X(M,NM1) = X(M,NM1)+X(M,NM1) 
+   20 END DO 
+   30 FNM1S4 = FLOAT(NM1)/4. 
+      DO 105 I=3,N,2 
+         M1 = 0 
+         DO 115 M=1,LJ,JUMP 
+            M1 = M1+1 
+            XI = FNM1S4*X(M,I) 
+            X(M,I) = FNM1S4*X(M,I-1) 
+            X(M,I-1) = DSUM(M1) 
+            DSUM(M1) = DSUM(M1)+XI 
+  115 END DO 
+  105 END DO 
+      IF (MODN .NE. 0) RETURN 
+      M1 = 0 
+      DO 116 M=1,LJ,JUMP 
+         M1 = M1+1 
+         X(M,N) = DSUM(M1) 
+  116 END DO 
+  106 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcstf1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcstf1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mcstf1.F	(revision 17)
@@ -0,0 +1,103 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mcstf1.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MCSTF1(LOT,JUMP,N,INC,X,WSAVE,DSUM,WORK,IER) 
+      REAL       X(INC,*)       ,WSAVE(*) 
+      DOUBLE PRECISION           DSUM(*) 
+      IER = 0 
+      NM1 = N-1 
+      NP1 = N+1 
+      NS2 = N/2 
+      LJ = (LOT-1)*JUMP+1 
+      IF (N-2) 200,101,102 
+  101 DO 111 M=1,LJ,JUMP 
+         X1H = X(M,1)+X(M,2) 
+         X(M,2) = .5*(X(M,1)-X(M,2)) 
+         X(M,1) = .5*X1H 
+  111 END DO 
+      GO TO 200 
+  102 IF (N .GT. 3) GO TO 103 
+      DO 112 M=1,LJ,JUMP 
+         X1P3 = X(M,1)+X(M,3) 
+         TX2 = X(M,2)+X(M,2) 
+         X(M,2) = .5*(X(M,1)-X(M,3)) 
+         X(M,1) = .25*(X1P3+TX2) 
+         X(M,3) = .25*(X1P3-TX2) 
+  112 END DO 
+      GO TO 200 
+  103 M1 = 0 
+      DO 113 M=1,LJ,JUMP 
+         M1 = M1+1 
+         DSUM(M1) = X(M,1)-X(M,N) 
+         X(M,1) = X(M,1)+X(M,N) 
+  113 END DO 
+      DO 104 K=2,NS2 
+         M1 = 0 
+         DO 114 M=1,LJ,JUMP 
+         M1 = M1+1 
+         KC = NP1-K 
+         T1 = X(M,K)+X(M,KC) 
+         T2 = X(M,K)-X(M,KC) 
+         DSUM(M1) = DSUM(M1)+WSAVE(KC)*T2 
+         T2 = WSAVE(K)*T2 
+         X(M,K) = T1-T2 
+         X(M,KC) = T1+T2 
+  114    CONTINUE 
+  104 END DO 
+      MODN = MOD(N,2) 
+      IF (MODN .EQ. 0) GO TO 124 
+         DO 123 M=1,LJ,JUMP 
+         X(M,NS2+1) = X(M,NS2+1)+X(M,NS2+1) 
+  123    CONTINUE 
+  124 CONTINUE 
+      LENX = (LOT-1)*JUMP + INC*(NM1-1)  + 1 
+      LNSV = NM1 + INT(LOG(REAL(NM1))) + 4 
+      LNWK = LOT*NM1 
+!                                                                       
+      CALL RFFTMF(LOT,JUMP,NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,         &
+     &            LNWK,IER1)                                            
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('MCSTF1',-5) 
+        GO TO 200 
+      ENDIF 
+!                                                                       
+      SNM1 = 1./FLOAT(NM1) 
+      DO 10 M=1,LOT 
+      DSUM(M) = SNM1*DSUM(M) 
+   10 END DO 
+      IF(MOD(NM1,2) .NE. 0) GO TO 30 
+      DO 20 M=1,LJ,JUMP 
+      X(M,NM1) = X(M,NM1)+X(M,NM1) 
+   20 END DO 
+   30 DO 105 I=3,N,2 
+         M1 = 0 
+         DO 115 M=1,LJ,JUMP 
+            M1 = M1+1 
+            XI = .5*X(M,I) 
+            X(M,I) = .5*X(M,I-1) 
+            X(M,I-1) = DSUM(M1) 
+            DSUM(M1) = DSUM(M1)+XI 
+  115 END DO 
+  105 END DO 
+      IF (MODN .NE. 0) GO TO 117 
+      M1 = 0 
+      DO 116 M=1,LJ,JUMP 
+         M1 = M1+1 
+         X(M,N) = DSUM(M1) 
+  116 END DO 
+  117 DO 118 M=1,LJ,JUMP 
+      X(M,1) = .5*X(M,1) 
+      X(M,N) = .5*X(M,N) 
+  118 END DO 
+!                                                                       
+  200 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradb2.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradb2.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradb2.F	(revision 17)
@@ -0,0 +1,51 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mradb2.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MRADB2 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1) 
+      REAL       CC(IN1,IDO,2,L1), CH(IN2,IDO,L1,2), WA1(IDO) 
+!                                                                       
+      M1D = (M-1)*IM1+1 
+      M2S = 1-IM2 
+      DO 101 K=1,L1 
+          M2 = M2S 
+          DO 1001 M1=1,M1D,IM1 
+          M2 = M2+IM2 
+         CH(M2,1,K,1) = CC(M1,1,1,K)+CC(M1,IDO,2,K) 
+         CH(M2,1,K,2) = CC(M1,1,1,K)-CC(M1,IDO,2,K) 
+ 1001     CONTINUE 
+  101 END DO 
+      IF (IDO-2) 107,105,102 
+  102 IDP2 = IDO+2 
+      DO 104 K=1,L1 
+         DO 103 I=3,IDO,2 
+            IC = IDP2-I 
+               M2 = M2S 
+               DO 1002 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+        CH(M2,I-1,K,1) = CC(M1,I-1,1,K)+CC(M1,IC-1,2,K) 
+        CH(M2,I,K,1) = CC(M1,I,1,K)-CC(M1,IC,2,K) 
+        CH(M2,I-1,K,2) = WA1(I-2)*(CC(M1,I-1,1,K)-CC(M1,IC-1,2,K))      &
+     &  -WA1(I-1)*(CC(M1,I,1,K)+CC(M1,IC,2,K))                          
+        CH(M2,I,K,2) = WA1(I-2)*(CC(M1,I,1,K)+CC(M1,IC,2,K))+WA1(I-1)   &
+     &  *(CC(M1,I-1,1,K)-CC(M1,IC-1,2,K))                               
+ 1002          CONTINUE 
+  103    CONTINUE 
+  104 END DO 
+      IF (MOD(IDO,2) .EQ. 1) RETURN 
+  105 DO 106 K=1,L1 
+          M2 = M2S 
+          DO 1003 M1=1,M1D,IM1 
+          M2 = M2+IM2 
+         CH(M2,IDO,K,1) = CC(M1,IDO,1,K)+CC(M1,IDO,1,K) 
+         CH(M2,IDO,K,2) = -(CC(M1,1,2,K)+CC(M1,1,2,K)) 
+ 1003     CONTINUE 
+  106 END DO 
+  107 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradb3.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradb3.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradb3.F	(revision 17)
@@ -0,0 +1,69 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mradb3.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MRADB3 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1,WA2) 
+      REAL       CC(IN1,IDO,3,L1)    ,CH(IN2,IDO,L1,3),                 &
+     &           WA1(IDO)   ,WA2(IDO)                                   
+!                                                                       
+      M1D = (M-1)*IM1+1 
+      M2S = 1-IM2 
+      ARG=2.*4.*ATAN(1.0)/3. 
+      TAUR=COS(ARG) 
+      TAUI=SIN(ARG) 
+      DO 101 K=1,L1 
+          M2 = M2S 
+          DO 1001 M1=1,M1D,IM1 
+          M2 = M2+IM2 
+         CH(M2,1,K,1) = CC(M1,1,1,K)+2.*CC(M1,IDO,2,K) 
+         CH(M2,1,K,2) = CC(M1,1,1,K)+(2.*TAUR)*CC(M1,IDO,2,K)           &
+     &   -(2.*TAUI)*CC(M1,1,3,K)                                        
+         CH(M2,1,K,3) = CC(M1,1,1,K)+(2.*TAUR)*CC(M1,IDO,2,K)           &
+     &   +2.*TAUI*CC(M1,1,3,K)                                          
+ 1001     CONTINUE 
+  101 END DO 
+      IF (IDO .EQ. 1) RETURN 
+      IDP2 = IDO+2 
+      DO 103 K=1,L1 
+         DO 102 I=3,IDO,2 
+            IC = IDP2-I 
+               M2 = M2S 
+               DO 1002 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+        CH(M2,I-1,K,1) = CC(M1,I-1,1,K)+(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)) 
+        CH(M2,I,K,1) = CC(M1,I,1,K)+(CC(M1,I,3,K)-CC(M1,IC,2,K)) 
+        CH(M2,I-1,K,2) = WA1(I-2)*                                      &
+     & ((CC(M1,I-1,1,K)+TAUR*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))-         &
+     & (TAUI*(CC(M1,I,3,K)+CC(M1,IC,2,K))))                             &
+     &                   -WA1(I-1)*                                     &
+     & ((CC(M1,I,1,K)+TAUR*(CC(M1,I,3,K)-CC(M1,IC,2,K)))+               &
+     & (TAUI*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))))                         
+            CH(M2,I,K,2) = WA1(I-2)*                                    &
+     & ((CC(M1,I,1,K)+TAUR*(CC(M1,I,3,K)-CC(M1,IC,2,K)))+               &
+     & (TAUI*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))))                         &
+     &                  +WA1(I-1)*                                      &
+     & ((CC(M1,I-1,1,K)+TAUR*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))-         &
+     & (TAUI*(CC(M1,I,3,K)+CC(M1,IC,2,K))))                             
+              CH(M2,I-1,K,3) = WA2(I-2)*                                &
+     & ((CC(M1,I-1,1,K)+TAUR*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))+         &
+     & (TAUI*(CC(M1,I,3,K)+CC(M1,IC,2,K))))                             &
+     &   -WA2(I-1)*                                                     &
+     & ((CC(M1,I,1,K)+TAUR*(CC(M1,I,3,K)-CC(M1,IC,2,K)))-               &
+     & (TAUI*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))))                         
+            CH(M2,I,K,3) = WA2(I-2)*                                    &
+     & ((CC(M1,I,1,K)+TAUR*(CC(M1,I,3,K)-CC(M1,IC,2,K)))-               &
+     & (TAUI*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))))                         &
+     &                 +WA2(I-1)*                                       &
+     & ((CC(M1,I-1,1,K)+TAUR*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))+         &
+     & (TAUI*(CC(M1,I,3,K)+CC(M1,IC,2,K))))                             
+ 1002          CONTINUE 
+  102    CONTINUE 
+  103 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradb4.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradb4.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradb4.F	(revision 17)
@@ -0,0 +1,83 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mradb4.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MRADB4 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1,WA2,WA3) 
+      REAL       CC(IN1,IDO,4,L1)  ,CH(IN2,IDO,L1,4)    ,               &
+     &           WA1(IDO)  ,        WA2(IDO)  ,       WA3(IDO)          
+!                                                                       
+      M1D = (M-1)*IM1+1 
+      M2S = 1-IM2 
+      SQRT2=SQRT(2.) 
+      DO 101 K=1,L1 
+          M2 = M2S 
+          DO 1001 M1=1,M1D,IM1 
+          M2 = M2+IM2 
+         CH(M2,1,K,3) = (CC(M1,1,1,K)+CC(M1,IDO,4,K))                   &
+     &   -(CC(M1,IDO,2,K)+CC(M1,IDO,2,K))                               
+         CH(M2,1,K,1) = (CC(M1,1,1,K)+CC(M1,IDO,4,K))                   &
+     &   +(CC(M1,IDO,2,K)+CC(M1,IDO,2,K))                               
+         CH(M2,1,K,4) = (CC(M1,1,1,K)-CC(M1,IDO,4,K))                   &
+     &   +(CC(M1,1,3,K)+CC(M1,1,3,K))                                   
+         CH(M2,1,K,2) = (CC(M1,1,1,K)-CC(M1,IDO,4,K))                   &
+     &   -(CC(M1,1,3,K)+CC(M1,1,3,K))                                   
+ 1001     CONTINUE 
+  101 END DO 
+      IF (IDO-2) 107,105,102 
+  102 IDP2 = IDO+2 
+      DO 104 K=1,L1 
+         DO 103 I=3,IDO,2 
+            IC = IDP2-I 
+               M2 = M2S 
+               DO 1002 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+        CH(M2,I-1,K,1) = (CC(M1,I-1,1,K)+CC(M1,IC-1,4,K))               &
+     &  +(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))                               
+        CH(M2,I,K,1) = (CC(M1,I,1,K)-CC(M1,IC,4,K))                     &
+     &  +(CC(M1,I,3,K)-CC(M1,IC,2,K))                                   
+        CH(M2,I-1,K,2)=WA1(I-2)*((CC(M1,I-1,1,K)-CC(M1,IC-1,4,K))       &
+     &  -(CC(M1,I,3,K)+CC(M1,IC,2,K)))-WA1(I-1)                         &
+     &  *((CC(M1,I,1,K)+CC(M1,IC,4,K))+(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K)))
+        CH(M2,I,K,2)=WA1(I-2)*((CC(M1,I,1,K)+CC(M1,IC,4,K))             &
+     &  +(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K)))+WA1(I-1)                     &
+     &  *((CC(M1,I-1,1,K)-CC(M1,IC-1,4,K))-(CC(M1,I,3,K)+CC(M1,IC,2,K)))
+        CH(M2,I-1,K,3)=WA2(I-2)*((CC(M1,I-1,1,K)+CC(M1,IC-1,4,K))       &
+     &  -(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))-WA2(I-1)                     &
+     &  *((CC(M1,I,1,K)-CC(M1,IC,4,K))-(CC(M1,I,3,K)-CC(M1,IC,2,K)))    
+        CH(M2,I,K,3)=WA2(I-2)*((CC(M1,I,1,K)-CC(M1,IC,4,K))             &
+     &  -(CC(M1,I,3,K)-CC(M1,IC,2,K)))+WA2(I-1)                         &
+     &  *((CC(M1,I-1,1,K)+CC(M1,IC-1,4,K))-(CC(M1,I-1,3,K)              &
+     &  +CC(M1,IC-1,2,K)))                                              
+        CH(M2,I-1,K,4)=WA3(I-2)*((CC(M1,I-1,1,K)-CC(M1,IC-1,4,K))       &
+     &  +(CC(M1,I,3,K)+CC(M1,IC,2,K)))-WA3(I-1)                         &
+     & *((CC(M1,I,1,K)+CC(M1,IC,4,K))-(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))) 
+        CH(M2,I,K,4)=WA3(I-2)*((CC(M1,I,1,K)+CC(M1,IC,4,K))             &
+     &  -(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K)))+WA3(I-1)                     &
+     &  *((CC(M1,I-1,1,K)-CC(M1,IC-1,4,K))+(CC(M1,I,3,K)+CC(M1,IC,2,K)))
+ 1002          CONTINUE 
+  103    CONTINUE 
+  104 END DO 
+      IF (MOD(IDO,2) .EQ. 1) RETURN 
+  105 CONTINUE 
+      DO 106 K=1,L1 
+               M2 = M2S 
+               DO 1003 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+         CH(M2,IDO,K,1) = (CC(M1,IDO,1,K)+CC(M1,IDO,3,K))               &
+     &   +(CC(M1,IDO,1,K)+CC(M1,IDO,3,K))                               
+         CH(M2,IDO,K,2) = SQRT2*((CC(M1,IDO,1,K)-CC(M1,IDO,3,K))        &
+     &   -(CC(M1,1,2,K)+CC(M1,1,4,K)))                                  
+         CH(M2,IDO,K,3) = (CC(M1,1,4,K)-CC(M1,1,2,K))                   &
+     &   +(CC(M1,1,4,K)-CC(M1,1,2,K))                                   
+         CH(M2,IDO,K,4) = -SQRT2*((CC(M1,IDO,1,K)-CC(M1,IDO,3,K))       &
+     &   +(CC(M1,1,2,K)+CC(M1,1,4,K)))                                  
+ 1003          CONTINUE 
+  106 END DO 
+  107 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradb5.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradb5.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradb5.F	(revision 17)
@@ -0,0 +1,125 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mradb5.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MRADB5 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,                &
+     &       WA1,WA2,WA3,WA4)                                           
+      REAL   CC(IN1,IDO,5,L1)    ,CH(IN2,IDO,L1,5),                     &
+     &       WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)     ,WA4(IDO)         
+!                                                                       
+      M1D = (M-1)*IM1+1 
+      M2S = 1-IM2 
+      ARG=2.*4.*ATAN(1.0)/5. 
+      TR11=COS(ARG) 
+      TI11=SIN(ARG) 
+      TR12=COS(2.*ARG) 
+      TI12=SIN(2.*ARG) 
+      DO 101 K=1,L1 
+      M2 = M2S 
+      DO 1001 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH(M2,1,K,1) = CC(M1,1,1,K)+2.*CC(M1,IDO,2,K)+2.*CC(M1,IDO,4,K) 
+         CH(M2,1,K,2) = (CC(M1,1,1,K)+TR11*2.*CC(M1,IDO,2,K)            &
+     &   +TR12*2.*CC(M1,IDO,4,K))-(TI11*2.*CC(M1,1,3,K)                 &
+     &   +TI12*2.*CC(M1,1,5,K))                                         
+         CH(M2,1,K,3) = (CC(M1,1,1,K)+TR12*2.*CC(M1,IDO,2,K)            &
+     &   +TR11*2.*CC(M1,IDO,4,K))-(TI12*2.*CC(M1,1,3,K)                 &
+     &   -TI11*2.*CC(M1,1,5,K))                                         
+         CH(M2,1,K,4) = (CC(M1,1,1,K)+TR12*2.*CC(M1,IDO,2,K)            &
+     &   +TR11*2.*CC(M1,IDO,4,K))+(TI12*2.*CC(M1,1,3,K)                 &
+     &   -TI11*2.*CC(M1,1,5,K))                                         
+         CH(M2,1,K,5) = (CC(M1,1,1,K)+TR11*2.*CC(M1,IDO,2,K)            &
+     &   +TR12*2.*CC(M1,IDO,4,K))+(TI11*2.*CC(M1,1,3,K)                 &
+     &   +TI12*2.*CC(M1,1,5,K))                                         
+ 1001          CONTINUE 
+  101 END DO 
+      IF (IDO .EQ. 1) RETURN 
+      IDP2 = IDO+2 
+      DO 103 K=1,L1 
+         DO 102 I=3,IDO,2 
+            IC = IDP2-I 
+            M2 = M2S 
+      DO 1002 M1=1,M1D,IM1 
+        M2 = M2+IM2 
+        CH(M2,I-1,K,1) = CC(M1,I-1,1,K)+(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))&
+     &  +(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K))                               
+        CH(M2,I,K,1) = CC(M1,I,1,K)+(CC(M1,I,3,K)-CC(M1,IC,2,K))        &
+     &  +(CC(M1,I,5,K)-CC(M1,IC,4,K))                                   
+        CH(M2,I-1,K,2) = WA1(I-2)*((CC(M1,I-1,1,K)+TR11*                &
+     &  (CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))+TR12                           &
+     &  *(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))-(TI11*(CC(M1,I,3,K)          &
+     &  +CC(M1,IC,2,K))+TI12*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             &
+     &  -WA1(I-1)*((CC(M1,I,1,K)+TR11*(CC(M1,I,3,K)-CC(M1,IC,2,K))      &
+     &  +TR12*(CC(M1,I,5,K)-CC(M1,IC,4,K)))+(TI11*(CC(M1,I-1,3,K)       &
+     &  -CC(M1,IC-1,2,K))+TI12*(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))       
+        CH(M2,I,K,2) = WA1(I-2)*((CC(M1,I,1,K)+TR11*(CC(M1,I,3,K)       &
+     &  -CC(M1,IC,2,K))+TR12*(CC(M1,I,5,K)-CC(M1,IC,4,K)))              &
+     &  +(TI11*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))+TI12                    &
+     &  *(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))+WA1(I-1)                    &
+     &  *((CC(M1,I-1,1,K)+TR11*(CC(M1,I-1,3,K)                          &
+     &  +CC(M1,IC-1,2,K))+TR12*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))        &
+     &  -(TI11*(CC(M1,I,3,K)+CC(M1,IC,2,K))+TI12                        &
+     &  *(CC(M1,I,5,K)+CC(M1,IC,4,K))))                                 
+        CH(M2,I-1,K,3) = WA2(I-2)                                       &
+     &  *((CC(M1,I-1,1,K)+TR12*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))         &
+     &  +TR11*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))-(TI12*(CC(M1,I,3,K)     &
+     &  +CC(M1,IC,2,K))-TI11*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             &
+     & -WA2(I-1)                                                        &
+     & *((CC(M1,I,1,K)+TR12*(CC(M1,I,3,K)-                              &
+     &  CC(M1,IC,2,K))+TR11*(CC(M1,I,5,K)-CC(M1,IC,4,K)))               &
+     &  +(TI12*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))-TI11                    &
+     &  *(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))                             
+        CH(M2,I,K,3) = WA2(I-2)                                         &
+     & *((CC(M1,I,1,K)+TR12*(CC(M1,I,3,K)-                              &
+     &  CC(M1,IC,2,K))+TR11*(CC(M1,I,5,K)-CC(M1,IC,4,K)))               &
+     &  +(TI12*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))-TI11                    &
+     &  *(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))                             &
+     &  +WA2(I-1)                                                       &
+     &  *((CC(M1,I-1,1,K)+TR12*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))         &
+     &  +TR11*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))-(TI12*(CC(M1,I,3,K)     &
+     &  +CC(M1,IC,2,K))-TI11*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             
+        CH(M2,I-1,K,4) = WA3(I-2)                                       &
+     &  *((CC(M1,I-1,1,K)+TR12*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))         &
+     &  +TR11*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))+(TI12*(CC(M1,I,3,K)     &
+     &  +CC(M1,IC,2,K))-TI11*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             &
+     &  -WA3(I-1)                                                       &
+     & *((CC(M1,I,1,K)+TR12*(CC(M1,I,3,K)-                              &
+     &  CC(M1,IC,2,K))+TR11*(CC(M1,I,5,K)-CC(M1,IC,4,K)))               &
+     &  -(TI12*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))-TI11                    &
+     &  *(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))                             
+        CH(M2,I,K,4) = WA3(I-2)                                         &
+     & *((CC(M1,I,1,K)+TR12*(CC(M1,I,3,K)-                              &
+     &  CC(M1,IC,2,K))+TR11*(CC(M1,I,5,K)-CC(M1,IC,4,K)))               &
+     &  -(TI12*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))-TI11                    &
+     &  *(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))                             &
+     &  +WA3(I-1)                                                       &
+     &  *((CC(M1,I-1,1,K)+TR12*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))         &
+     &  +TR11*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))+(TI12*(CC(M1,I,3,K)     &
+     &  +CC(M1,IC,2,K))-TI11*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             
+        CH(M2,I-1,K,5) = WA4(I-2)                                       &
+     &  *((CC(M1,I-1,1,K)+TR11*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))         &
+     &  +TR12*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))+(TI11*(CC(M1,I,3,K)     &
+     &  +CC(M1,IC,2,K))+TI12*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             &
+     &  -WA4(I-1)                                                       &
+     &  *((CC(M1,I,1,K)+TR11*(CC(M1,I,3,K)-CC(M1,IC,2,K))               &
+     &  +TR12*(CC(M1,I,5,K)-CC(M1,IC,4,K)))-(TI11*(CC(M1,I-1,3,K)       &
+     &  -CC(M1,IC-1,2,K))+TI12*(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))       
+        CH(M2,I,K,5) = WA4(I-2)                                         &
+     &  *((CC(M1,I,1,K)+TR11*(CC(M1,I,3,K)-CC(M1,IC,2,K))               &
+     &  +TR12*(CC(M1,I,5,K)-CC(M1,IC,4,K)))-(TI11*(CC(M1,I-1,3,K)       &
+     &  -CC(M1,IC-1,2,K))+TI12*(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))       &
+     &  +WA4(I-1)                                                       &
+     &  *((CC(M1,I-1,1,K)+TR11*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))         &
+     &  +TR12*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))+(TI11*(CC(M1,I,3,K)     &
+     &  +CC(M1,IC,2,K))+TI12*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             
+ 1002      CONTINUE 
+  102    CONTINUE 
+  103 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradbg.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradbg.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradbg.F	(revision 17)
@@ -0,0 +1,238 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mradbg.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MRADBG (M,IDO,IP,L1,IDL1,CC,C1,C2,IM1,IN1,             &
+     &          CH,CH2,IM2,IN2,WA)                                      
+      REAL      CH(IN2,IDO,L1,IP)    ,CC(IN1,IDO,IP,L1) ,               &
+     &          C1(IN1,IDO,L1,IP)    ,C2(IN1,IDL1,IP),                  &
+     &          CH2(IN2,IDL1,IP)     ,WA(IDO)                           
+!                                                                       
+      M1D = (M-1)*IM1+1 
+      M2S = 1-IM2 
+      TPI=2.*4.*ATAN(1.0) 
+      ARG = TPI/FLOAT(IP) 
+      DCP = COS(ARG) 
+      DSP = SIN(ARG) 
+      IDP2 = IDO+2 
+      NBD = (IDO-1)/2 
+      IPP2 = IP+2 
+      IPPH = (IP+1)/2 
+      IF (IDO .LT. L1) GO TO 103 
+      DO 102 K=1,L1 
+         DO 101 I=1,IDO 
+            M2 = M2S 
+            DO 1001 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CH(M2,I,K,1) = CC(M1,I,1,K) 
+ 1001       CONTINUE 
+  101    CONTINUE 
+  102 END DO 
+      GO TO 106 
+  103 DO 105 I=1,IDO 
+         DO 104 K=1,L1 
+            M2 = M2S 
+            DO 1004 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CH(M2,I,K,1) = CC(M1,I,1,K) 
+ 1004       CONTINUE 
+  104    CONTINUE 
+  105 END DO 
+  106 DO 108 J=2,IPPH 
+         JC = IPP2-J 
+         J2 = J+J 
+         DO 107 K=1,L1 
+            M2 = M2S 
+            DO 1007 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CH(M2,1,K,J) = CC(M1,IDO,J2-2,K)+CC(M1,IDO,J2-2,K) 
+            CH(M2,1,K,JC) = CC(M1,1,J2-1,K)+CC(M1,1,J2-1,K) 
+ 1007       CONTINUE 
+  107    CONTINUE 
+  108 END DO 
+      IF (IDO .EQ. 1) GO TO 116 
+      IF (NBD .LT. L1) GO TO 112 
+      DO 111 J=2,IPPH 
+         JC = IPP2-J 
+         DO 110 K=1,L1 
+            DO 109 I=3,IDO,2 
+               IC = IDP2-I 
+               M2 = M2S 
+               DO 1009 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               CH(M2,I-1,K,J) = CC(M1,I-1,2*J-1,K)+CC(M1,IC-1,2*J-2,K) 
+               CH(M2,I-1,K,JC) = CC(M1,I-1,2*J-1,K)-CC(M1,IC-1,2*J-2,K) 
+               CH(M2,I,K,J) = CC(M1,I,2*J-1,K)-CC(M1,IC,2*J-2,K) 
+               CH(M2,I,K,JC) = CC(M1,I,2*J-1,K)+CC(M1,IC,2*J-2,K) 
+ 1009          CONTINUE 
+  109       CONTINUE 
+  110    CONTINUE 
+  111 END DO 
+      GO TO 116 
+  112 DO 115 J=2,IPPH 
+         JC = IPP2-J 
+         DO 114 I=3,IDO,2 
+            IC = IDP2-I 
+            DO 113 K=1,L1 
+               M2 = M2S 
+               DO 1013 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               CH(M2,I-1,K,J) = CC(M1,I-1,2*J-1,K)+CC(M1,IC-1,2*J-2,K) 
+               CH(M2,I-1,K,JC) = CC(M1,I-1,2*J-1,K)-CC(M1,IC-1,2*J-2,K) 
+               CH(M2,I,K,J) = CC(M1,I,2*J-1,K)-CC(M1,IC,2*J-2,K) 
+               CH(M2,I,K,JC) = CC(M1,I,2*J-1,K)+CC(M1,IC,2*J-2,K) 
+ 1013          CONTINUE 
+  113       CONTINUE 
+  114    CONTINUE 
+  115 END DO 
+  116 AR1 = 1. 
+      AI1 = 0. 
+      DO 120 L=2,IPPH 
+         LC = IPP2-L 
+         AR1H = DCP*AR1-DSP*AI1 
+         AI1 = DCP*AI1+DSP*AR1 
+         AR1 = AR1H 
+         DO 117 IK=1,IDL1 
+            M2 = M2S 
+            DO 1017 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            C2(M1,IK,L) = CH2(M2,IK,1)+AR1*CH2(M2,IK,2) 
+            C2(M1,IK,LC) = AI1*CH2(M2,IK,IP) 
+ 1017       CONTINUE 
+  117    CONTINUE 
+         DC2 = AR1 
+         DS2 = AI1 
+         AR2 = AR1 
+         AI2 = AI1 
+         DO 119 J=3,IPPH 
+            JC = IPP2-J 
+            AR2H = DC2*AR2-DS2*AI2 
+            AI2 = DC2*AI2+DS2*AR2 
+            AR2 = AR2H 
+            DO 118 IK=1,IDL1 
+               M2 = M2S 
+               DO 1018 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               C2(M1,IK,L) = C2(M1,IK,L)+AR2*CH2(M2,IK,J) 
+               C2(M1,IK,LC) = C2(M1,IK,LC)+AI2*CH2(M2,IK,JC) 
+ 1018          CONTINUE 
+  118       CONTINUE 
+  119    CONTINUE 
+  120 END DO 
+      DO 122 J=2,IPPH 
+         DO 121 IK=1,IDL1 
+            M2 = M2S 
+            DO 1021 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CH2(M2,IK,1) = CH2(M2,IK,1)+CH2(M2,IK,J) 
+ 1021       CONTINUE 
+  121    CONTINUE 
+  122 END DO 
+      DO 124 J=2,IPPH 
+         JC = IPP2-J 
+         DO 123 K=1,L1 
+            M2 = M2S 
+            DO 1023 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CH(M2,1,K,J) = C1(M1,1,K,J)-C1(M1,1,K,JC) 
+            CH(M2,1,K,JC) = C1(M1,1,K,J)+C1(M1,1,K,JC) 
+ 1023       CONTINUE 
+  123    CONTINUE 
+  124 END DO 
+      IF (IDO .EQ. 1) GO TO 132 
+      IF (NBD .LT. L1) GO TO 128 
+      DO 127 J=2,IPPH 
+         JC = IPP2-J 
+         DO 126 K=1,L1 
+            DO 125 I=3,IDO,2 
+               M2 = M2S 
+               DO 1025 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               CH(M2,I-1,K,J) = C1(M1,I-1,K,J)-C1(M1,I,K,JC) 
+               CH(M2,I-1,K,JC) = C1(M1,I-1,K,J)+C1(M1,I,K,JC) 
+               CH(M2,I,K,J) = C1(M1,I,K,J)+C1(M1,I-1,K,JC) 
+               CH(M2,I,K,JC) = C1(M1,I,K,J)-C1(M1,I-1,K,JC) 
+ 1025          CONTINUE 
+  125       CONTINUE 
+  126    CONTINUE 
+  127 END DO 
+      GO TO 132 
+  128 DO 131 J=2,IPPH 
+         JC = IPP2-J 
+         DO 130 I=3,IDO,2 
+            DO 129 K=1,L1 
+               M2 = M2S 
+               DO 1029 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               CH(M2,I-1,K,J) = C1(M1,I-1,K,J)-C1(M1,I,K,JC) 
+               CH(M2,I-1,K,JC) = C1(M1,I-1,K,J)+C1(M1,I,K,JC) 
+               CH(M2,I,K,J) = C1(M1,I,K,J)+C1(M1,I-1,K,JC) 
+               CH(M2,I,K,JC) = C1(M1,I,K,J)-C1(M1,I-1,K,JC) 
+ 1029          CONTINUE 
+  129       CONTINUE 
+  130    CONTINUE 
+  131 END DO 
+  132 CONTINUE 
+      IF (IDO .EQ. 1) RETURN 
+      DO 133 IK=1,IDL1 
+         M2 = M2S 
+         DO 1033 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         C2(M1,IK,1) = CH2(M2,IK,1) 
+ 1033    CONTINUE 
+  133 END DO 
+      DO 135 J=2,IP 
+         DO 134 K=1,L1 
+            M2 = M2S 
+            DO 1034 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            C1(M1,1,K,J) = CH(M2,1,K,J) 
+ 1034       CONTINUE 
+  134    CONTINUE 
+  135 END DO 
+      IF (NBD .GT. L1) GO TO 139 
+      IS = -IDO 
+      DO 138 J=2,IP 
+         IS = IS+IDO 
+         IDIJ = IS 
+         DO 137 I=3,IDO,2 
+            IDIJ = IDIJ+2 
+            DO 136 K=1,L1 
+               M2 = M2S 
+               DO 1036 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               C1(M1,I-1,K,J) = WA(IDIJ-1)*CH(M2,I-1,K,J)-WA(IDIJ)*     &
+     &          CH(M2,I,K,J)                                            
+               C1(M1,I,K,J) = WA(IDIJ-1)*CH(M2,I,K,J)+WA(IDIJ)*         &
+     &          CH(M2,I-1,K,J)                                          
+ 1036          CONTINUE 
+  136       CONTINUE 
+  137    CONTINUE 
+  138 END DO 
+      GO TO 143 
+  139 IS = -IDO 
+      DO 142 J=2,IP 
+         IS = IS+IDO 
+         DO 141 K=1,L1 
+            IDIJ = IS 
+            DO 140 I=3,IDO,2 
+               IDIJ = IDIJ+2 
+               M2 = M2S 
+               DO 1040 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               C1(M1,I-1,K,J) = WA(IDIJ-1)*CH(M2,I-1,K,J)-WA(IDIJ)*     &
+     &          CH(M2,I,K,J)                                            
+               C1(M1,I,K,J) = WA(IDIJ-1)*CH(M2,I,K,J)+WA(IDIJ)*         &
+     &          CH(M2,I-1,K,J)                                          
+ 1040          CONTINUE 
+  140       CONTINUE 
+  141    CONTINUE 
+  142 END DO 
+  143 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradf2.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradf2.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradf2.F	(revision 17)
@@ -0,0 +1,53 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mradf2.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MRADF2 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1) 
+      REAL       CH(IN2,IDO,2,L1) ,CC(IN1,IDO,L1,2) , WA1(IDO) 
+!                                                                       
+      M1D = (M-1)*IM1+1 
+      M2S = 1-IM2 
+      DO 101 K=1,L1 
+         M2 = M2S 
+         DO 1001 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH(M2,1,1,K) = CC(M1,1,K,1)+CC(M1,1,K,2) 
+         CH(M2,IDO,2,K) = CC(M1,1,K,1)-CC(M1,1,K,2) 
+ 1001    CONTINUE 
+  101 END DO 
+      IF (IDO-2) 107,105,102 
+  102 IDP2 = IDO+2 
+      DO 104 K=1,L1 
+         DO 103 I=3,IDO,2 
+            IC = IDP2-I 
+            M2 = M2S 
+            DO 1003 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CH(M2,I,1,K) = CC(M1,I,K,1)+(WA1(I-2)*CC(M1,I,K,2)-         &
+     &       WA1(I-1)*CC(M1,I-1,K,2))                                   
+            CH(M2,IC,2,K) = (WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*            &
+     &       CC(M1,I-1,K,2))-CC(M1,I,K,1)                               
+            CH(M2,I-1,1,K) = CC(M1,I-1,K,1)+(WA1(I-2)*CC(M1,I-1,K,2)+   &
+     &       WA1(I-1)*CC(M1,I,K,2))                                     
+            CH(M2,IC-1,2,K) = CC(M1,I-1,K,1)-(WA1(I-2)*CC(M1,I-1,K,2)+  &
+     &       WA1(I-1)*CC(M1,I,K,2))                                     
+ 1003       CONTINUE 
+  103    CONTINUE 
+  104 END DO 
+      IF (MOD(IDO,2) .EQ. 1) RETURN 
+  105 DO 106 K=1,L1 
+         M2 = M2S 
+         DO 1006 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH(M2,1,2,K) = -CC(M1,IDO,K,2) 
+         CH(M2,IDO,1,K) = CC(M1,IDO,K,1) 
+ 1006    CONTINUE 
+  106 END DO 
+  107 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradf3.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradf3.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradf3.F	(revision 17)
@@ -0,0 +1,68 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mradf3.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MRADF3 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1,WA2) 
+      REAL       CH(IN2,IDO,3,L1)  ,CC(IN1,IDO,L1,3)     ,              &
+     &                WA1(IDO)     ,WA2(IDO)                            
+!                                                                       
+      M1D = (M-1)*IM1+1 
+      M2S = 1-IM2 
+      ARG=2.*4.*ATAN(1.0)/3. 
+      TAUR=COS(ARG) 
+      TAUI=SIN(ARG) 
+      DO 101 K=1,L1 
+         M2 = M2S 
+         DO 1001 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH(M2,1,1,K) = CC(M1,1,K,1)+(CC(M1,1,K,2)+CC(M1,1,K,3)) 
+         CH(M2,1,3,K) = TAUI*(CC(M1,1,K,3)-CC(M1,1,K,2)) 
+         CH(M2,IDO,2,K) = CC(M1,1,K,1)+TAUR*                            &
+     &      (CC(M1,1,K,2)+CC(M1,1,K,3))                                 
+ 1001    CONTINUE 
+  101 END DO 
+      IF (IDO .EQ. 1) RETURN 
+      IDP2 = IDO+2 
+      DO 103 K=1,L1 
+         DO 102 I=3,IDO,2 
+            IC = IDP2-I 
+            M2 = M2S 
+            DO 1002 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CH(M2,I-1,1,K) = CC(M1,I-1,K,1)+((WA1(I-2)*CC(M1,I-1,K,2)+  &
+     &       WA1(I-1)*CC(M1,I,K,2))+(WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*  &
+     &       CC(M1,I,K,3)))                                             
+            CH(M2,I,1,K) = CC(M1,I,K,1)+((WA1(I-2)*CC(M1,I,K,2)-        &
+     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*  &
+     &       CC(M1,I-1,K,3)))                                           
+            CH(M2,I-1,3,K) = (CC(M1,I-1,K,1)+TAUR*((WA1(I-2)*           &
+     &       CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2))+(WA2(I-2)*           &
+     &       CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3))))+(TAUI*((WA1(I-2)*  &
+     &       CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2))-(WA2(I-2)*           &
+     &       CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3))))                    
+            CH(M2,IC-1,2,K) = (CC(M1,I-1,K,1)+TAUR*((WA1(I-2)*          &
+     &       CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2))+(WA2(I-2)*           &
+     &       CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3))))-(TAUI*((WA1(I-2)*  &
+     &       CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2))-(WA2(I-2)*           &
+     &       CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3))))                    
+            CH(M2,I,3,K) = (CC(M1,I,K,1)+TAUR*((WA1(I-2)*CC(M1,I,K,2)-  &
+     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*  &
+     &       CC(M1,I-1,K,3))))+(TAUI*((WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*&
+     &       CC(M1,I,K,3))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*           &
+     &       CC(M1,I,K,2))))                                            
+            CH(M2,IC,2,K) = (TAUI*((WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*   &
+     &       CC(M1,I,K,3))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*           &
+     &       CC(M1,I,K,2))))-(CC(M1,I,K,1)+TAUR*((WA1(I-2)*CC(M1,I,K,2)-&
+     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*  &
+     &       CC(M1,I-1,K,3))))                                          
+ 1002       CONTINUE 
+  102    CONTINUE 
+  103 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradf4.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradf4.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradf4.F	(revision 17)
@@ -0,0 +1,90 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mradf4.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MRADF4 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1,WA2,WA3) 
+      REAL       CC(IN1,IDO,L1,4)   ,CH(IN2,IDO,4,L1)     ,             &
+     &           WA1(IDO)           ,WA2(IDO)     ,WA3(IDO)             
+!                                                                       
+      HSQT2=SQRT(2.)/2. 
+      M1D = (M-1)*IM1+1 
+      M2S = 1-IM2 
+      DO 101 K=1,L1 
+         M2 = M2S 
+         DO 1001 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH(M2,1,1,K) = (CC(M1,1,K,2)+CC(M1,1,K,4))                     &
+     &      +(CC(M1,1,K,1)+CC(M1,1,K,3))                                
+         CH(M2,IDO,4,K) = (CC(M1,1,K,1)+CC(M1,1,K,3))                   &
+     &      -(CC(M1,1,K,2)+CC(M1,1,K,4))                                
+         CH(M2,IDO,2,K) = CC(M1,1,K,1)-CC(M1,1,K,3) 
+         CH(M2,1,3,K) = CC(M1,1,K,4)-CC(M1,1,K,2) 
+ 1001    CONTINUE 
+  101 END DO 
+      IF (IDO-2) 107,105,102 
+  102 IDP2 = IDO+2 
+      DO 104 K=1,L1 
+         DO 103 I=3,IDO,2 
+            IC = IDP2-I 
+            M2 = M2S 
+            DO 1003 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CH(M2,I-1,1,K) = ((WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*        &
+     &       CC(M1,I,K,2))+(WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*           &
+     &       CC(M1,I,K,4)))+(CC(M1,I-1,K,1)+(WA2(I-2)*CC(M1,I-1,K,3)+   &
+     &       WA2(I-1)*CC(M1,I,K,3)))                                    
+            CH(M2,IC-1,4,K) = (CC(M1,I-1,K,1)+(WA2(I-2)*CC(M1,I-1,K,3)+ &
+     &       WA2(I-1)*CC(M1,I,K,3)))-((WA1(I-2)*CC(M1,I-1,K,2)+         &
+     &       WA1(I-1)*CC(M1,I,K,2))+(WA3(I-2)*CC(M1,I-1,K,4)+           &
+     &       WA3(I-1)*CC(M1,I,K,4)))                                    
+            CH(M2,I,1,K) = ((WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*            &
+     &       CC(M1,I-1,K,2))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
+     &       CC(M1,I-1,K,4)))+(CC(M1,I,K,1)+(WA2(I-2)*CC(M1,I,K,3)-     &
+     &       WA2(I-1)*CC(M1,I-1,K,3)))                                  
+            CH(M2,IC,4,K) = ((WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*           &
+     &       CC(M1,I-1,K,2))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
+     &       CC(M1,I-1,K,4)))-(CC(M1,I,K,1)+(WA2(I-2)*CC(M1,I,K,3)-     &
+     &       WA2(I-1)*CC(M1,I-1,K,3)))                                  
+            CH(M2,I-1,3,K) = ((WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*          &
+     &       CC(M1,I-1,K,2))-(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
+     &       CC(M1,I-1,K,4)))+(CC(M1,I-1,K,1)-(WA2(I-2)*CC(M1,I-1,K,3)+ &
+     &       WA2(I-1)*CC(M1,I,K,3)))                                    
+            CH(M2,IC-1,2,K) = (CC(M1,I-1,K,1)-(WA2(I-2)*CC(M1,I-1,K,3)+ &
+     &       WA2(I-1)*CC(M1,I,K,3)))-((WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*  &
+     &       CC(M1,I-1,K,2))-(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
+     &       CC(M1,I-1,K,4)))                                           
+            CH(M2,I,3,K) = ((WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*          &
+     &       CC(M1,I,K,4))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*           &
+     &       CC(M1,I,K,2)))+(CC(M1,I,K,1)-(WA2(I-2)*CC(M1,I,K,3)-       &
+     &       WA2(I-1)*CC(M1,I-1,K,3)))                                  
+            CH(M2,IC,2,K) = ((WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*         &
+     &       CC(M1,I,K,4))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*           &
+     &       CC(M1,I,K,2)))-(CC(M1,I,K,1)-(WA2(I-2)*CC(M1,I,K,3)-       &
+     &       WA2(I-1)*CC(M1,I-1,K,3)))                                  
+ 1003       CONTINUE 
+  103    CONTINUE 
+  104 END DO 
+      IF (MOD(IDO,2) .EQ. 1) RETURN 
+  105 CONTINUE 
+      DO 106 K=1,L1 
+         M2 = M2S 
+         DO 1006 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CH(M2,IDO,1,K) = (HSQT2*(CC(M1,IDO,K,2)-CC(M1,IDO,K,4)))+   &
+     &       CC(M1,IDO,K,1)                                             
+            CH(M2,IDO,3,K) = CC(M1,IDO,K,1)-(HSQT2*(CC(M1,IDO,K,2)-     &
+     &       CC(M1,IDO,K,4)))                                           
+            CH(M2,1,2,K) = (-HSQT2*(CC(M1,IDO,K,2)+CC(M1,IDO,K,4)))-    &
+     &       CC(M1,IDO,K,3)                                             
+            CH(M2,1,4,K) = (-HSQT2*(CC(M1,IDO,K,2)+CC(M1,IDO,K,4)))+    &
+     &       CC(M1,IDO,K,3)                                             
+ 1006    CONTINUE 
+  106 END DO 
+  107 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradf5.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradf5.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradf5.F	(revision 17)
@@ -0,0 +1,133 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mradf5.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MRADF5 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,                &
+     &                   WA1,WA2,WA3,WA4)                               
+      REAL       CC(IN1,IDO,L1,5)    ,CH(IN2,IDO,5,L1)     ,            &
+     &           WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)     ,WA4(IDO)     
+!                                                                       
+      M1D = (M-1)*IM1+1 
+      M2S = 1-IM2 
+      ARG=2.*4.*ATAN(1.0)/5. 
+      TR11=COS(ARG) 
+      TI11=SIN(ARG) 
+      TR12=COS(2.*ARG) 
+      TI12=SIN(2.*ARG) 
+      DO 101 K=1,L1 
+         M2 = M2S 
+         DO 1001 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH(M2,1,1,K) = CC(M1,1,K,1)+(CC(M1,1,K,5)+CC(M1,1,K,2))+       &
+     &    (CC(M1,1,K,4)+CC(M1,1,K,3))                                   
+         CH(M2,IDO,2,K) = CC(M1,1,K,1)+TR11*(CC(M1,1,K,5)+CC(M1,1,K,2))+&
+     &    TR12*(CC(M1,1,K,4)+CC(M1,1,K,3))                              
+         CH(M2,1,3,K) = TI11*(CC(M1,1,K,5)-CC(M1,1,K,2))+TI12*          &
+     &    (CC(M1,1,K,4)-CC(M1,1,K,3))                                   
+         CH(M2,IDO,4,K) = CC(M1,1,K,1)+TR12*(CC(M1,1,K,5)+CC(M1,1,K,2))+&
+     &    TR11*(CC(M1,1,K,4)+CC(M1,1,K,3))                              
+         CH(M2,1,5,K) = TI12*(CC(M1,1,K,5)-CC(M1,1,K,2))-TI11*          &
+     &    (CC(M1,1,K,4)-CC(M1,1,K,3))                                   
+ 1001    CONTINUE 
+  101 END DO 
+      IF (IDO .EQ. 1) RETURN 
+      IDP2 = IDO+2 
+      DO 103 K=1,L1 
+         DO 102 I=3,IDO,2 
+            IC = IDP2-I 
+            M2 = M2S 
+            DO 1002 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CH(M2,I-1,1,K) = CC(M1,I-1,K,1)+((WA1(I-2)*CC(M1,I-1,K,2)+  &
+     &       WA1(I-1)*CC(M1,I,K,2))+(WA4(I-2)*CC(M1,I-1,K,5)+WA4(I-1)*  &
+     &       CC(M1,I,K,5)))+((WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*         &
+     &       CC(M1,I,K,3))+(WA3(I-2)*CC(M1,I-1,K,4)+                    &
+     &       WA3(I-1)*CC(M1,I,K,4)))                                    
+            CH(M2,I,1,K) = CC(M1,I,K,1)+((WA1(I-2)*CC(M1,I,K,2)-        &
+     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*  &
+     &       CC(M1,I-1,K,5)))+((WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*         &
+     &       CC(M1,I-1,K,3))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
+     &       CC(M1,I-1,K,4)))                                           
+            CH(M2,I-1,3,K) = CC(M1,I-1,K,1)+TR11*                       &
+     &      ( WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2)             &
+     &       +WA4(I-2)*CC(M1,I-1,K,5)+WA4(I-1)*CC(M1,I,K,5))+TR12*      &
+     &      ( WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3)             &
+     &       +WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*CC(M1,I,K,4))+TI11*      &
+     &      ( WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2)             &
+     &       -(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*CC(M1,I-1,K,5)))+TI12*    &
+     &      ( WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3)             &
+     &       -(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*CC(M1,I-1,K,4)))          
+            CH(M2,IC-1,2,K) = CC(M1,I-1,K,1)+TR11*                      &
+     &      ( WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2)             &
+     &       +WA4(I-2)*CC(M1,I-1,K,5)+WA4(I-1)*CC(M1,I,K,5))+TR12*      &
+     &     ( WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3)              &
+     &      +WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*CC(M1,I,K,4))-(TI11*      &
+     &      ( WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2)             &
+     &       -(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*CC(M1,I-1,K,5)))+TI12*    &
+     &      ( WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3)             &
+     &       -(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*CC(M1,I-1,K,4))))         
+            CH(M2,I,3,K) = (CC(M1,I,K,1)+TR11*((WA1(I-2)*CC(M1,I,K,2)-  &
+     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*  &
+     &       CC(M1,I-1,K,5)))+TR12*((WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*    &
+     &       CC(M1,I-1,K,3))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
+     &       CC(M1,I-1,K,4))))+(TI11*((WA4(I-2)*CC(M1,I-1,K,5)+         &
+     &       WA4(I-1)*CC(M1,I,K,5))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*  &
+     &       CC(M1,I,K,2)))+TI12*((WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*    &
+     &       CC(M1,I,K,4))-(WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*           &
+     &       CC(M1,I,K,3))))                                            
+            CH(M2,IC,2,K) = (TI11*((WA4(I-2)*CC(M1,I-1,K,5)+WA4(I-1)*   &
+     &       CC(M1,I,K,5))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*           &
+     &       CC(M1,I,K,2)))+TI12*((WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*    &
+     &       CC(M1,I,K,4))-(WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*           &
+     &       CC(M1,I,K,3))))-(CC(M1,I,K,1)+TR11*((WA1(I-2)*CC(M1,I,K,2)-&
+     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*  &
+     &       CC(M1,I-1,K,5)))+TR12*((WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*    &
+     &       CC(M1,I-1,K,3))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
+     &       CC(M1,I-1,K,4))))                                          
+            CH(M2,I-1,5,K) = (CC(M1,I-1,K,1)+TR12*((WA1(I-2)*           &
+     &       CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2))+(WA4(I-2)*           &
+     &       CC(M1,I-1,K,5)+WA4(I-1)*CC(M1,I,K,5)))+TR11*((WA2(I-2)*    &
+     &       CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3))+(WA3(I-2)*           &
+     &       CC(M1,I-1,K,4)+WA3(I-1)*CC(M1,I,K,4))))+(TI12*((WA1(I-2)*  &
+     &       CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2))-(WA4(I-2)*           &
+     &       CC(M1,I,K,5)-WA4(I-1)*CC(M1,I-1,K,5)))-TI11*((WA2(I-2)*    &
+     &       CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3))-(WA3(I-2)*           &
+     &       CC(M1,I,K,4)-WA3(I-1)*CC(M1,I-1,K,4))))                    
+            CH(M2,IC-1,4,K) = (CC(M1,I-1,K,1)+TR12*((WA1(I-2)*          &
+     &       CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2))+(WA4(I-2)*           &
+     &       CC(M1,I-1,K,5)+WA4(I-1)*CC(M1,I,K,5)))+TR11*((WA2(I-2)*    &
+     &       CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3))+(WA3(I-2)*           &
+     &       CC(M1,I-1,K,4)+WA3(I-1)*CC(M1,I,K,4))))-(TI12*((WA1(I-2)*  &
+     &       CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2))-(WA4(I-2)*           &
+     &       CC(M1,I,K,5)-WA4(I-1)*CC(M1,I-1,K,5)))-TI11*((WA2(I-2)*    &
+     &       CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3))-(WA3(I-2)*           &
+     &       CC(M1,I,K,4)-WA3(I-1)*CC(M1,I-1,K,4))))                    
+            CH(M2,I,5,K) = (CC(M1,I,K,1)+TR12*((WA1(I-2)*CC(M1,I,K,2)-  &
+     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*  &
+     &       CC(M1,I-1,K,5)))+TR11*((WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*    &
+     &       CC(M1,I-1,K,3))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
+     &       CC(M1,I-1,K,4))))+(TI12*((WA4(I-2)*CC(M1,I-1,K,5)+         &
+     &       WA4(I-1)*CC(M1,I,K,5))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*  &
+     &       CC(M1,I,K,2)))-TI11*((WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*    &
+     &       CC(M1,I,K,4))-(WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*           &
+     &       CC(M1,I,K,3))))                                            
+            CH(M2,IC,4,K) = (TI12*((WA4(I-2)*CC(M1,I-1,K,5)+WA4(I-1)*   &
+     &       CC(M1,I,K,5))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*           &
+     &       CC(M1,I,K,2)))-TI11*((WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*    &
+     &       CC(M1,I,K,4))-(WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*           &
+     &       CC(M1,I,K,3))))-(CC(M1,I,K,1)+TR12*((WA1(I-2)*CC(M1,I,K,2)-&
+     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*  &
+     &       CC(M1,I-1,K,5)))+TR11*((WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*    &
+     &       CC(M1,I-1,K,3))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
+     &       CC(M1,I-1,K,4))))                                          
+ 1002       CONTINUE 
+  102    CONTINUE 
+  103 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradfg.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradfg.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mradfg.F	(revision 17)
@@ -0,0 +1,248 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mradfg.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MRADFG (M,IDO,IP,L1,IDL1,CC,C1,C2,IM1,IN1,             &
+     &              CH,CH2,IM2,IN2,WA)                                  
+      REAL          CH(IN2,IDO,L1,IP)   ,CC(IN1,IDO,IP,L1),             &
+     &              C1(IN1,IDO,L1,IP)   ,C2(IN1,IDL1,IP),               &
+     &              CH2(IN2,IDL1,IP)    ,WA(IDO)                        
+!                                                                       
+      M1D = (M-1)*IM1+1 
+      M2S = 1-IM2 
+      TPI=2.*4.*ATAN(1.0) 
+      ARG = TPI/FLOAT(IP) 
+      DCP = COS(ARG) 
+      DSP = SIN(ARG) 
+      IPPH = (IP+1)/2 
+      IPP2 = IP+2 
+      IDP2 = IDO+2 
+      NBD = (IDO-1)/2 
+      IF (IDO .EQ. 1) GO TO 119 
+      DO 101 IK=1,IDL1 
+         M2 = M2S 
+         DO 1001 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         CH2(M2,IK,1) = C2(M1,IK,1) 
+ 1001    CONTINUE 
+  101 END DO 
+      DO 103 J=2,IP 
+         DO 102 K=1,L1 
+            M2 = M2S 
+            DO 1002 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CH(M2,1,K,J) = C1(M1,1,K,J) 
+ 1002       CONTINUE 
+  102    CONTINUE 
+  103 END DO 
+      IF (NBD .GT. L1) GO TO 107 
+      IS = -IDO 
+      DO 106 J=2,IP 
+         IS = IS+IDO 
+         IDIJ = IS 
+         DO 105 I=3,IDO,2 
+            IDIJ = IDIJ+2 
+            DO 104 K=1,L1 
+               M2 = M2S 
+               DO 1004 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               CH(M2,I-1,K,J) = WA(IDIJ-1)*C1(M1,I-1,K,J)+WA(IDIJ)      &
+     &           *C1(M1,I,K,J)                                          
+               CH(M2,I,K,J) = WA(IDIJ-1)*C1(M1,I,K,J)-WA(IDIJ)          &
+     &           *C1(M1,I-1,K,J)                                        
+ 1004          CONTINUE 
+  104       CONTINUE 
+  105    CONTINUE 
+  106 END DO 
+      GO TO 111 
+  107 IS = -IDO 
+      DO 110 J=2,IP 
+         IS = IS+IDO 
+         DO 109 K=1,L1 
+            IDIJ = IS 
+            DO 108 I=3,IDO,2 
+               IDIJ = IDIJ+2 
+               M2 = M2S 
+               DO 1008 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               CH(M2,I-1,K,J) = WA(IDIJ-1)*C1(M1,I-1,K,J)+WA(IDIJ)      &
+     &           *C1(M1,I,K,J)                                          
+               CH(M2,I,K,J) = WA(IDIJ-1)*C1(M1,I,K,J)-WA(IDIJ)          &
+     &           *C1(M1,I-1,K,J)                                        
+ 1008          CONTINUE 
+  108       CONTINUE 
+  109    CONTINUE 
+  110 END DO 
+  111 IF (NBD .LT. L1) GO TO 115 
+      DO 114 J=2,IPPH 
+         JC = IPP2-J 
+         DO 113 K=1,L1 
+            DO 112 I=3,IDO,2 
+               M2 = M2S 
+               DO 1012 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               C1(M1,I-1,K,J) = CH(M2,I-1,K,J)+CH(M2,I-1,K,JC) 
+               C1(M1,I-1,K,JC) = CH(M2,I,K,J)-CH(M2,I,K,JC) 
+               C1(M1,I,K,J) = CH(M2,I,K,J)+CH(M2,I,K,JC) 
+               C1(M1,I,K,JC) = CH(M2,I-1,K,JC)-CH(M2,I-1,K,J) 
+ 1012          CONTINUE 
+  112       CONTINUE 
+  113    CONTINUE 
+  114 END DO 
+      GO TO 121 
+  115 DO 118 J=2,IPPH 
+         JC = IPP2-J 
+         DO 117 I=3,IDO,2 
+            DO 116 K=1,L1 
+               M2 = M2S 
+               DO 1016 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               C1(M1,I-1,K,J) = CH(M2,I-1,K,J)+CH(M2,I-1,K,JC) 
+               C1(M1,I-1,K,JC) = CH(M2,I,K,J)-CH(M2,I,K,JC) 
+               C1(M1,I,K,J) = CH(M2,I,K,J)+CH(M2,I,K,JC) 
+               C1(M1,I,K,JC) = CH(M2,I-1,K,JC)-CH(M2,I-1,K,J) 
+ 1016          CONTINUE 
+  116       CONTINUE 
+  117    CONTINUE 
+  118 END DO 
+      GO TO 121 
+  119 DO 120 IK=1,IDL1 
+         M2 = M2S 
+         DO 1020 M1=1,M1D,IM1 
+         M2 = M2+IM2 
+         C2(M1,IK,1) = CH2(M2,IK,1) 
+ 1020    CONTINUE 
+  120 END DO 
+  121 DO 123 J=2,IPPH 
+         JC = IPP2-J 
+         DO 122 K=1,L1 
+            M2 = M2S 
+            DO 1022 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            C1(M1,1,K,J) = CH(M2,1,K,J)+CH(M2,1,K,JC) 
+            C1(M1,1,K,JC) = CH(M2,1,K,JC)-CH(M2,1,K,J) 
+ 1022       CONTINUE 
+  122    CONTINUE 
+  123 END DO 
+!                                                                       
+      AR1 = 1. 
+      AI1 = 0. 
+      DO 127 L=2,IPPH 
+         LC = IPP2-L 
+         AR1H = DCP*AR1-DSP*AI1 
+         AI1 = DCP*AI1+DSP*AR1 
+         AR1 = AR1H 
+         DO 124 IK=1,IDL1 
+            M2 = M2S 
+            DO 1024 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CH2(M2,IK,L) = C2(M1,IK,1)+AR1*C2(M1,IK,2) 
+            CH2(M2,IK,LC) = AI1*C2(M1,IK,IP) 
+ 1024       CONTINUE 
+  124    CONTINUE 
+         DC2 = AR1 
+         DS2 = AI1 
+         AR2 = AR1 
+         AI2 = AI1 
+         DO 126 J=3,IPPH 
+            JC = IPP2-J 
+            AR2H = DC2*AR2-DS2*AI2 
+            AI2 = DC2*AI2+DS2*AR2 
+            AR2 = AR2H 
+            DO 125 IK=1,IDL1 
+               M2 = M2S 
+               DO 1025 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               CH2(M2,IK,L) = CH2(M2,IK,L)+AR2*C2(M1,IK,J) 
+               CH2(M2,IK,LC) = CH2(M2,IK,LC)+AI2*C2(M1,IK,JC) 
+ 1025          CONTINUE 
+  125       CONTINUE 
+  126    CONTINUE 
+  127 END DO 
+      DO 129 J=2,IPPH 
+         DO 128 IK=1,IDL1 
+            M2 = M2S 
+            DO 1028 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CH2(M2,IK,1) = CH2(M2,IK,1)+C2(M1,IK,J) 
+ 1028       CONTINUE 
+  128    CONTINUE 
+  129 END DO 
+!                                                                       
+      IF (IDO .LT. L1) GO TO 132 
+      DO 131 K=1,L1 
+         DO 130 I=1,IDO 
+            M2 = M2S 
+            DO 1030 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CC(M1,I,1,K) = CH(M2,I,K,1) 
+ 1030       CONTINUE 
+  130    CONTINUE 
+  131 END DO 
+      GO TO 135 
+  132 DO 134 I=1,IDO 
+         DO 133 K=1,L1 
+            M2 = M2S 
+            DO 1033 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CC(M1,I,1,K) = CH(M2,I,K,1) 
+ 1033       CONTINUE 
+  133    CONTINUE 
+  134 END DO 
+  135 DO 137 J=2,IPPH 
+         JC = IPP2-J 
+         J2 = J+J 
+         DO 136 K=1,L1 
+            M2 = M2S 
+            DO 1036 M1=1,M1D,IM1 
+            M2 = M2+IM2 
+            CC(M1,IDO,J2-2,K) = CH(M2,1,K,J) 
+            CC(M1,1,J2-1,K) = CH(M2,1,K,JC) 
+ 1036       CONTINUE 
+  136    CONTINUE 
+  137 END DO 
+      IF (IDO .EQ. 1) RETURN 
+      IF (NBD .LT. L1) GO TO 141 
+      DO 140 J=2,IPPH 
+         JC = IPP2-J 
+         J2 = J+J 
+         DO 139 K=1,L1 
+            DO 138 I=3,IDO,2 
+               IC = IDP2-I 
+               M2 = M2S 
+               DO 1038 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               CC(M1,I-1,J2-1,K) = CH(M2,I-1,K,J)+CH(M2,I-1,K,JC) 
+               CC(M1,IC-1,J2-2,K) = CH(M2,I-1,K,J)-CH(M2,I-1,K,JC) 
+               CC(M1,I,J2-1,K) = CH(M2,I,K,J)+CH(M2,I,K,JC) 
+               CC(M1,IC,J2-2,K) = CH(M2,I,K,JC)-CH(M2,I,K,J) 
+ 1038          CONTINUE 
+  138       CONTINUE 
+  139    CONTINUE 
+  140 END DO 
+      RETURN 
+  141 DO 144 J=2,IPPH 
+         JC = IPP2-J 
+         J2 = J+J 
+         DO 143 I=3,IDO,2 
+            IC = IDP2-I 
+            DO 142 K=1,L1 
+               M2 = M2S 
+               DO 1042 M1=1,M1D,IM1 
+               M2 = M2+IM2 
+               CC(M1,I-1,J2-1,K) = CH(M2,I-1,K,J)+CH(M2,I-1,K,JC) 
+               CC(M1,IC-1,J2-2,K) = CH(M2,I-1,K,J)-CH(M2,I-1,K,JC) 
+               CC(M1,I,J2-1,K) = CH(M2,I,K,J)+CH(M2,I,K,JC) 
+               CC(M1,IC,J2-2,K) = CH(M2,I,K,JC)-CH(M2,I,K,J) 
+ 1042          CONTINUE 
+  142       CONTINUE 
+  143    CONTINUE 
+  144 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mrftb1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mrftb1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mrftb1.F	(revision 17)
@@ -0,0 +1,105 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mrftb1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MRFTB1 (M,IM,N,IN,C,CH,WA,FAC) 
+      REAL       CH(M,*), C(IN,*), WA(N) ,FAC(15) 
+!                                                                       
+      NF = FAC(2) 
+      NA = 0 
+      DO 10 K1=1,NF 
+      IP = FAC(K1+2) 
+      NA = 1-NA 
+      IF(IP .LE. 5) GO TO 10 
+      IF(K1 .EQ. NF) GO TO 10 
+      NA = 1-NA 
+   10 END DO 
+      HALF = .5 
+      HALFM = -.5 
+      MODN = MOD(N,2) 
+      NL = N-2 
+      IF(MODN .NE. 0) NL = N-1 
+      IF (NA .EQ. 0) GO TO 120 
+      M2 = 1-IM 
+      DO 117 I=1,M 
+      M2 = M2+IM 
+      CH(I,1) = C(M2,1) 
+      CH(I,N) = C(M2,N) 
+  117 END DO 
+      DO 118 J=2,NL,2 
+      M2 = 1-IM 
+      DO 118 I=1,M 
+         M2 = M2+IM 
+         CH(I,J) = HALF*C(M2,J) 
+         CH(I,J+1) = HALFM*C(M2,J+1) 
+  118 CONTINUE 
+      GO TO 124 
+  120 continue 
+      DO 122 J=2,NL,2 
+      M2 = 1-IM 
+      DO 122 I=1,M 
+         M2 = M2+IM 
+         C(M2,J) = HALF*C(M2,J) 
+         C(M2,J+1) = HALFM*C(M2,J+1) 
+  122 CONTINUE 
+  124 L1 = 1 
+      IW = 1 
+      DO 116 K1=1,NF 
+         IP = FAC(K1+2) 
+         L2 = IP*L1 
+         IDO = N/L2 
+         IDL1 = IDO*L1 
+         IF (IP .NE. 4) GO TO 103 
+         IX2 = IW+IDO 
+         IX3 = IX2+IDO 
+         IF (NA .NE. 0) GO TO 101 
+         CALL MRADB4 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),WA(IX3)) 
+         GO TO 102 
+  101    CALL MRADB4 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2),WA(IX3)) 
+  102    NA = 1-NA 
+         GO TO 115 
+  103    IF (IP .NE. 2) GO TO 106 
+         IF (NA .NE. 0) GO TO 104 
+         CALL MRADB2 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW)) 
+         GO TO 105 
+  104    CALL MRADB2 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW)) 
+  105    NA = 1-NA 
+         GO TO 115 
+  106    IF (IP .NE. 3) GO TO 109 
+         IX2 = IW+IDO 
+         IF (NA .NE. 0) GO TO 107 
+         CALL MRADB3 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2)) 
+         GO TO 108 
+  107    CALL MRADB3 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2)) 
+  108    NA = 1-NA 
+         GO TO 115 
+  109    IF (IP .NE. 5) GO TO 112 
+         IX2 = IW+IDO 
+         IX3 = IX2+IDO 
+         IX4 = IX3+IDO 
+         IF (NA .NE. 0) GO TO 110 
+         CALL MRADB5 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),           &
+     &                  WA(IX3),WA(IX4))                                
+         GO TO 111 
+  110    CALL MRADB5 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2),           &
+     &                  WA(IX3),WA(IX4))                                
+  111    NA = 1-NA 
+         GO TO 115 
+  112    IF (NA .NE. 0) GO TO 113 
+         CALL MRADBG (M,IDO,IP,L1,IDL1,C,C,C,IM,IN,CH,CH,1,             &
+     &                            M,WA(IW))                             
+         GO TO 114 
+  113    CALL MRADBG (M,IDO,IP,L1,IDL1,CH,CH,CH,1,M,C,C,IM,             &
+     &                           IN,WA(IW))                             
+  114    IF (IDO .EQ. 1) NA = 1-NA 
+  115    L1 = L2 
+         IW = IW+(IP-1)*IDO 
+  116 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mrftf1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mrftf1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mrftf1.F	(revision 17)
@@ -0,0 +1,112 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mrftf1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MRFTF1 (M,IM,N,IN,C,CH,WA,FAC) 
+      REAL       CH(M,*) ,C(IN,*)  ,WA(N)   ,FAC(15) 
+!                                                                       
+      NF = FAC(2) 
+      NA = 1 
+      L2 = N 
+      IW = N 
+      DO 111 K1=1,NF 
+         KH = NF-K1 
+         IP = FAC(KH+3) 
+         L1 = L2/IP 
+         IDO = N/L2 
+         IDL1 = IDO*L1 
+         IW = IW-(IP-1)*IDO 
+         NA = 1-NA 
+         IF (IP .NE. 4) GO TO 102 
+         IX2 = IW+IDO 
+         IX3 = IX2+IDO 
+         IF (NA .NE. 0) GO TO 101 
+         CALL MRADF4 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),WA(IX3)) 
+         GO TO 110 
+  101    CALL MRADF4 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2),WA(IX3)) 
+         GO TO 110 
+  102    IF (IP .NE. 2) GO TO 104 
+         IF (NA .NE. 0) GO TO 103 
+         CALL MRADF2 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW)) 
+         GO TO 110 
+  103    CALL MRADF2 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW)) 
+         GO TO 110 
+  104    IF (IP .NE. 3) GO TO 106 
+         IX2 = IW+IDO 
+         IF (NA .NE. 0) GO TO 105 
+         CALL MRADF3 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2)) 
+         GO TO 110 
+  105    CALL MRADF3 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2)) 
+         GO TO 110 
+  106    IF (IP .NE. 5) GO TO 108 
+         IX2 = IW+IDO 
+         IX3 = IX2+IDO 
+         IX4 = IX3+IDO 
+         IF (NA .NE. 0) GO TO 107 
+         CALL MRADF5(M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),            &
+     &                      WA(IX3),WA(IX4))                            
+         GO TO 110 
+  107    CALL MRADF5(M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2),            &
+     &                      WA(IX3),WA(IX4))                            
+         GO TO 110 
+  108    IF (IDO .EQ. 1) NA = 1-NA 
+         IF (NA .NE. 0) GO TO 109 
+         CALL MRADFG (M,IDO,IP,L1,IDL1,C,C,C,IM,IN,CH,CH,1,M,WA(IW)) 
+         NA = 1 
+         GO TO 110 
+  109    CALL MRADFG (M,IDO,IP,L1,IDL1,CH,CH,CH,1,M,C,C,IM,IN,WA(IW)) 
+         NA = 0 
+  110    L2 = L1 
+  111 END DO 
+      SN = 1./N 
+      TSN = 2./N 
+      TSNM = -TSN 
+      MODN = MOD(N,2) 
+      NL = N-2 
+      IF(MODN .NE. 0) NL = N-1 
+      IF (NA .NE. 0) GO TO 120 
+      M2 = 1-IM 
+      DO 117 I=1,M 
+         M2 = M2+IM 
+         C(M2,1) = SN*CH(I,1) 
+  117 END DO 
+      DO 118 J=2,NL,2 
+      M2 = 1-IM 
+      DO 118 I=1,M 
+         M2 = M2+IM 
+         C(M2,J) = TSN*CH(I,J) 
+         C(M2,J+1) = TSNM*CH(I,J+1) 
+  118 CONTINUE 
+      IF(MODN .NE. 0) RETURN 
+      M2 = 1-IM 
+      DO 119 I=1,M 
+         M2 = M2+IM 
+         C(M2,N) = SN*CH(I,N) 
+  119 END DO 
+      RETURN 
+  120 M2 = 1-IM 
+      DO 121 I=1,M 
+         M2 = M2+IM 
+         C(M2,1) = SN*C(M2,1) 
+  121 END DO 
+      DO 122 J=2,NL,2 
+      M2 = 1-IM 
+      DO 122 I=1,M 
+         M2 = M2+IM 
+         C(M2,J) = TSN*C(M2,J) 
+         C(M2,J+1) = TSNM*C(M2,J+1) 
+  122 CONTINUE 
+      IF(MODN .NE. 0) RETURN 
+      M2 = 1-IM 
+      DO 123 I=1,M 
+         M2 = M2+IM 
+         C(M2,N) = SN*C(M2,N) 
+  123 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mrfti1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mrfti1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/mrfti1.F	(revision 17)
@@ -0,0 +1,70 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: mrfti1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MRFTI1 (N,WA,FAC) 
+      REAL       WA(N)      ,FAC(15) 
+      INTEGER    NTRYH(4) 
+      DOUBLE PRECISION TPI,ARGH,ARGLD,ARG 
+      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ 
+!                                                                       
+      NL = N 
+      NF = 0 
+      J = 0 
+  101 J = J+1 
+      IF (J-4) 102,102,103 
+  102 NTRY = NTRYH(J) 
+      GO TO 104 
+  103 NTRY = NTRY+2 
+  104 NQ = NL/NTRY 
+      NR = NL-NTRY*NQ 
+      IF (NR) 101,105,101 
+  105 NF = NF+1 
+      FAC(NF+2) = NTRY 
+      NL = NQ 
+      IF (NTRY .NE. 2) GO TO 107 
+      IF (NF .EQ. 1) GO TO 107 
+      DO 106 I=2,NF 
+         IB = NF-I+2 
+         FAC(IB+2) = FAC(IB+1) 
+  106 END DO 
+      FAC(3) = 2 
+  107 IF (NL .NE. 1) GO TO 104 
+      FAC(1) = N 
+      FAC(2) = NF 
+      TPI = 8.D0*DATAN(1.D0) 
+      ARGH = TPI/FLOAT(N) 
+      IS = 0 
+      NFM1 = NF-1 
+      L1 = 1 
+      IF (NFM1 .EQ. 0) RETURN 
+      DO 110 K1=1,NFM1 
+         IP = FAC(K1+2) 
+         LD = 0 
+         L2 = L1*IP 
+         IDO = N/L2 
+         IPM = IP-1 
+         DO 109 J=1,IPM 
+            LD = LD+L1 
+            I = IS 
+            ARGLD = FLOAT(LD)*ARGH 
+            FI = 0. 
+            DO 108 II=3,IDO,2 
+               I = I+2 
+               FI = FI+1. 
+               ARG = FI*ARGLD 
+               WA(I-1) = DCOS(ARG) 
+               WA(I) = DSIN(ARG) 
+  108       CONTINUE 
+            IS = IS+IDO 
+  109    CONTINUE 
+         L1 = L2 
+  110 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/msntb1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/msntb1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/msntb1.F	(revision 17)
@@ -0,0 +1,88 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: msntb1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MSNTB1(LOT,JUMP,N,INC,X,WSAVE,DSUM,XH,WORK,IER) 
+      REAL       X(INC,*)       ,WSAVE(*)   ,XH(LOT,*) 
+      DOUBLE PRECISION           DSUM(*) 
+      IER = 0 
+      LJ = (LOT-1)*JUMP+1 
+      IF (N-2) 200,102,103 
+  102 SRT3S2 = SQRT(3.)/2. 
+      DO 112 M=1,LJ,JUMP 
+         XHOLD = SRT3S2*(X(M,1)+X(M,2)) 
+         X(M,2) = SRT3S2*(X(M,1)-X(M,2)) 
+         X(M,1) = XHOLD 
+  112 END DO 
+      GO TO 200 
+  103 NP1 = N+1 
+      NS2 = N/2 
+      DO 104 K=1,NS2 
+         KC = NP1-K 
+         M1 = 0 
+         DO 114 M=1,LJ,JUMP 
+         M1 = M1+1 
+         T1 = X(M,K)-X(M,KC) 
+         T2 = WSAVE(K)*(X(M,K)+X(M,KC)) 
+         XH(M1,K+1) = T1+T2 
+         XH(M1,KC+1) = T2-T1 
+  114    CONTINUE 
+  104 END DO 
+      MODN = MOD(N,2) 
+      IF (MODN .EQ. 0) GO TO 124 
+      M1 = 0 
+      DO 123 M=1,LJ,JUMP 
+         M1 = M1+1 
+         XH(M1,NS2+2) = 4.*X(M,NS2+1) 
+  123 END DO 
+  124 DO 127 M=1,LOT 
+         XH(M,1) = 0. 
+  127 END DO 
+      LNXH = LOT-1 + LOT*(NP1-1) + 1 
+      LNSV = NP1 + INT(LOG(REAL(NP1))) + 4 
+      LNWK = LOT*NP1 
+!                                                                       
+      CALL RFFTMF(LOT,1,NP1,LOT,XH,LNXH,WSAVE(NS2+1),LNSV,WORK,         &
+     &            LNWK,IER1)                                            
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('MSNTB1',-5) 
+        GO TO 200 
+      ENDIF 
+!                                                                       
+      IF(MOD(NP1,2) .NE. 0) GO TO 30 
+      DO 20 M=1,LOT 
+      XH(M,NP1) = XH(M,NP1)+XH(M,NP1) 
+   20 END DO 
+   30 FNP1S4 = FLOAT(NP1)/4. 
+      M1 = 0 
+      DO 125 M=1,LJ,JUMP 
+         M1 = M1+1 
+         X(M,1) = FNP1S4*XH(M1,1) 
+         DSUM(M1) = X(M,1) 
+  125 END DO 
+      DO 105 I=3,N,2 
+         M1 = 0 
+         DO 115 M=1,LJ,JUMP 
+            M1 = M1+1 
+            X(M,I-1) = FNP1S4*XH(M1,I) 
+            DSUM(M1) = DSUM(M1)+FNP1S4*XH(M1,I-1) 
+            X(M,I) = DSUM(M1) 
+  115    CONTINUE 
+  105 END DO 
+      IF (MODN .NE. 0) GO TO 200 
+      M1 = 0 
+      DO 116 M=1,LJ,JUMP 
+         M1 = M1+1 
+         X(M,N) = FNP1S4*XH(M1,N+1) 
+  116 END DO 
+!                                                                       
+  200 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/msntf1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/msntf1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/msntf1.F	(revision 17)
@@ -0,0 +1,87 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: msntf1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE MSNTF1(LOT,JUMP,N,INC,X,WSAVE,DSUM,XH,WORK,IER) 
+      REAL       X(INC,*)       ,WSAVE(*)   ,XH(LOT,*) 
+      DOUBLE PRECISION           DSUM(*) 
+      IER = 0 
+      LJ = (LOT-1)*JUMP+1 
+      IF (N-2) 101,102,103 
+  102 SSQRT3 = 1./SQRT(3.) 
+      DO 112 M=1,LJ,JUMP 
+         XHOLD = SSQRT3*(X(M,1)+X(M,2)) 
+         X(M,2) = SSQRT3*(X(M,1)-X(M,2)) 
+         X(M,1) = XHOLD 
+  112 END DO 
+  101  GO TO 200 
+  103 NP1 = N+1 
+      NS2 = N/2 
+      DO 104 K=1,NS2 
+         KC = NP1-K 
+         M1 = 0 
+         DO 114 M=1,LJ,JUMP 
+         M1 = M1 + 1 
+         T1 = X(M,K)-X(M,KC) 
+         T2 = WSAVE(K)*(X(M,K)+X(M,KC)) 
+         XH(M1,K+1) = T1+T2 
+         XH(M1,KC+1) = T2-T1 
+  114    CONTINUE 
+  104 END DO 
+      MODN = MOD(N,2) 
+      IF (MODN .EQ. 0) GO TO 124 
+      M1 = 0 
+      DO 123 M=1,LJ,JUMP 
+         M1 = M1 + 1 
+         XH(M1,NS2+2) = 4.*X(M,NS2+1) 
+  123 END DO 
+  124 DO 127 M=1,LOT 
+         XH(M,1) = 0. 
+  127 END DO 
+      LNXH = LOT-1 + LOT*(NP1-1) + 1 
+      LNSV = NP1 + INT(LOG(REAL(NP1))) + 4 
+      LNWK = LOT*NP1 
+!                                                                       
+      CALL RFFTMF(LOT,1,NP1,LOT,XH,LNXH,WSAVE(NS2+1),LNSV,WORK,         &
+     &            LNWK,IER1)                                            
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('MSNTF1',-5) 
+        GO TO 200 
+      ENDIF 
+!                                                                       
+      IF(MOD(NP1,2) .NE. 0) GO TO 30 
+      DO 20 M=1,LOT 
+      XH(M,NP1) = XH(M,NP1)+XH(M,NP1) 
+   20 END DO 
+   30 SFNP1 = 1./FLOAT(NP1) 
+      M1 = 0 
+      DO 125 M=1,LJ,JUMP 
+         M1 = M1+1 
+         X(M,1) = .5*XH(M1,1) 
+         DSUM(M1) = X(M,1) 
+  125 END DO 
+      DO 105 I=3,N,2 
+         M1 = 0 
+         DO 115 M=1,LJ,JUMP 
+            M1 = M1+1 
+            X(M,I-1) = .5*XH(M1,I) 
+            DSUM(M1) = DSUM(M1)+.5*XH(M1,I-1) 
+            X(M,I) = DSUM(M1) 
+  115    CONTINUE 
+  105 END DO 
+      IF (MODN .NE. 0) GO TO 200 
+      M1 = 0 
+      DO 116 M=1,LJ,JUMP 
+         M1 = M1+1 
+         X(M,N) = .5*XH(M1,N+1) 
+  116 END DO 
+  200 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f2kb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f2kb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f2kb.F	(revision 17)
@@ -0,0 +1,40 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: r1f2kb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE R1F2KB (IDO,L1,CC,IN1,CH,IN2,WA1) 
+      REAL       CC(IN1,IDO,2,L1), CH(IN2,IDO,L1,2), WA1(IDO) 
+!                                                                       
+      DO 101 K=1,L1 
+         CH(1,1,K,1) = CC(1,1,1,K)+CC(1,IDO,2,K) 
+         CH(1,1,K,2) = CC(1,1,1,K)-CC(1,IDO,2,K) 
+  101 END DO 
+      IF (IDO-2) 107,105,102 
+  102 IDP2 = IDO+2 
+      DO 104 K=1,L1 
+         DO 103 I=3,IDO,2 
+            IC = IDP2-I 
+                                                                        
+            CH(1,I-1,K,1) = CC(1,I-1,1,K)+CC(1,IC-1,2,K) 
+            CH(1,I,K,1) = CC(1,I,1,K)-CC(1,IC,2,K) 
+                                                                        
+            CH(1,I-1,K,2) = WA1(I-2)*(CC(1,I-1,1,K)-CC(1,IC-1,2,K))     &
+     &           -WA1(I-1)*(CC(1,I,1,K)+CC(1,IC,2,K))                   
+            CH(1,I,K,2) = WA1(I-2)*(CC(1,I,1,K)+CC(1,IC,2,K))+WA1(I-1)  &
+     &           *(CC(1,I-1,1,K)-CC(1,IC-1,2,K))                        
+                                                                        
+  103    CONTINUE 
+  104 END DO 
+      IF (MOD(IDO,2) .EQ. 1) RETURN 
+  105 DO 106 K=1,L1 
+         CH(1,IDO,K,1) = CC(1,IDO,1,K)+CC(1,IDO,1,K) 
+         CH(1,IDO,K,2) = -(CC(1,1,2,K)+CC(1,1,2,K)) 
+  106 END DO 
+  107 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f2kf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f2kf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f2kf.F	(revision 17)
@@ -0,0 +1,39 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: r1f2kf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE R1F2KF (IDO,L1,CC,IN1,CH,IN2,WA1) 
+      REAL       CH(IN2,IDO,2,L1) ,CC(IN1,IDO,L1,2) , WA1(IDO) 
+!                                                                       
+      DO 101 K=1,L1 
+         CH(1,1,1,K) = CC(1,1,K,1)+CC(1,1,K,2) 
+         CH(1,IDO,2,K) = CC(1,1,K,1)-CC(1,1,K,2) 
+  101 END DO 
+      IF (IDO-2) 107,105,102 
+  102 IDP2 = IDO+2 
+      DO 104 K=1,L1 
+         DO 103 I=3,IDO,2 
+            IC = IDP2-I 
+            CH(1,I,1,K) = CC(1,I,K,1)+(WA1(I-2)*CC(1,I,K,2)-            &
+     &       WA1(I-1)*CC(1,I-1,K,2))                                    
+            CH(1,IC,2,K) = (WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*              &
+     &       CC(1,I-1,K,2))-CC(1,I,K,1)                                 
+            CH(1,I-1,1,K) = CC(1,I-1,K,1)+(WA1(I-2)*CC(1,I-1,K,2)+      &
+     &       WA1(I-1)*CC(1,I,K,2))                                      
+            CH(1,IC-1,2,K) = CC(1,I-1,K,1)-(WA1(I-2)*CC(1,I-1,K,2)+     &
+     &       WA1(I-1)*CC(1,I,K,2))                                      
+  103    CONTINUE 
+  104 END DO 
+      IF (MOD(IDO,2) .EQ. 1) RETURN 
+  105 DO 106 K=1,L1 
+         CH(1,1,2,K) = -CC(1,IDO,K,2) 
+         CH(1,IDO,1,K) = CC(1,IDO,K,1) 
+  106 END DO 
+  107 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f3kb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f3kb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f3kb.F	(revision 17)
@@ -0,0 +1,59 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: r1f3kb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE R1F3KB (IDO,L1,CC,IN1,CH,IN2,WA1,WA2) 
+      REAL       CC(IN1,IDO,3,L1)    ,CH(IN2,IDO,L1,3),                 &
+     &           WA1(IDO)   ,WA2(IDO)                                   
+!                                                                       
+      ARG=2.*4.*ATAN(1.0)/3. 
+      TAUR=COS(ARG) 
+      TAUI=SIN(ARG) 
+      DO 101 K=1,L1 
+         CH(1,1,K,1) = CC(1,1,1,K)+2.*CC(1,IDO,2,K) 
+         CH(1,1,K,2) = CC(1,1,1,K)+(2.*TAUR)*CC(1,IDO,2,K)              &
+     &   -(2.*TAUI)*CC(1,1,3,K)                                         
+         CH(1,1,K,3) = CC(1,1,1,K)+(2.*TAUR)*CC(1,IDO,2,K)              &
+     &   +2.*TAUI*CC(1,1,3,K)                                           
+  101 END DO 
+      IF (IDO .EQ. 1) RETURN 
+      IDP2 = IDO+2 
+      DO 103 K=1,L1 
+         DO 102 I=3,IDO,2 
+            IC = IDP2-I 
+        CH(1,I-1,K,1) = CC(1,I-1,1,K)+(CC(1,I-1,3,K)+CC(1,IC-1,2,K)) 
+        CH(1,I,K,1) = CC(1,I,1,K)+(CC(1,I,3,K)-CC(1,IC,2,K)) 
+        CH(1,I-1,K,2) = WA1(I-2)*                                       &
+     & ((CC(1,I-1,1,K)+TAUR*(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))-            &
+     & (TAUI*(CC(1,I,3,K)+CC(1,IC,2,K))))                               &
+     &                   -WA1(I-1)*                                     &
+     & ((CC(1,I,1,K)+TAUR*(CC(1,I,3,K)-CC(1,IC,2,K)))+                  &
+     & (TAUI*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))))                           
+            CH(1,I,K,2) = WA1(I-2)*                                     &
+     & ((CC(1,I,1,K)+TAUR*(CC(1,I,3,K)-CC(1,IC,2,K)))+                  &
+     & (TAUI*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))))                           &
+     &                  +WA1(I-1)*                                      &
+     & ((CC(1,I-1,1,K)+TAUR*(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))-            &
+     & (TAUI*(CC(1,I,3,K)+CC(1,IC,2,K))))                               
+              CH(1,I-1,K,3) = WA2(I-2)*                                 &
+     & ((CC(1,I-1,1,K)+TAUR*(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))+            &
+     & (TAUI*(CC(1,I,3,K)+CC(1,IC,2,K))))                               &
+     &   -WA2(I-1)*                                                     &
+     & ((CC(1,I,1,K)+TAUR*(CC(1,I,3,K)-CC(1,IC,2,K)))-                  &
+     & (TAUI*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))))                           
+            CH(1,I,K,3) = WA2(I-2)*                                     &
+     & ((CC(1,I,1,K)+TAUR*(CC(1,I,3,K)-CC(1,IC,2,K)))-                  &
+     & (TAUI*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))))                           &
+     &                 +WA2(I-1)*                                       &
+     & ((CC(1,I-1,1,K)+TAUR*(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))+            &
+     & (TAUI*(CC(1,I,3,K)+CC(1,IC,2,K))))                               
+  102    CONTINUE 
+  103 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f3kf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f3kf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f3kf.F	(revision 17)
@@ -0,0 +1,58 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: r1f3kf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE R1F3KF (IDO,L1,CC,IN1,CH,IN2,WA1,WA2) 
+      REAL       CH(IN2,IDO,3,L1)  ,CC(IN1,IDO,L1,3)     ,              &
+     &                WA1(IDO)     ,WA2(IDO)                            
+!                                                                       
+      ARG=2.*4.*ATAN(1.0)/3. 
+      TAUR=COS(ARG) 
+      TAUI=SIN(ARG) 
+      DO 101 K=1,L1 
+         CH(1,1,1,K) = CC(1,1,K,1)+(CC(1,1,K,2)+CC(1,1,K,3)) 
+         CH(1,1,3,K) = TAUI*(CC(1,1,K,3)-CC(1,1,K,2)) 
+         CH(1,IDO,2,K) = CC(1,1,K,1)+TAUR*                              &
+     &      (CC(1,1,K,2)+CC(1,1,K,3))                                   
+  101 END DO 
+      IF (IDO .EQ. 1) RETURN 
+      IDP2 = IDO+2 
+      DO 103 K=1,L1 
+         DO 102 I=3,IDO,2 
+            IC = IDP2-I 
+            CH(1,I-1,1,K) = CC(1,I-1,K,1)+((WA1(I-2)*CC(1,I-1,K,2)+     &
+     &       WA1(I-1)*CC(1,I,K,2))+(WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*    &
+     &       CC(1,I,K,3)))                                              
+            CH(1,I,1,K) = CC(1,I,K,1)+((WA1(I-2)*CC(1,I,K,2)-           &
+     &       WA1(I-1)*CC(1,I-1,K,2))+(WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*    &
+     &       CC(1,I-1,K,3)))                                            
+            CH(1,I-1,3,K) = (CC(1,I-1,K,1)+TAUR*((WA1(I-2)*             &
+     &       CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2))+(WA2(I-2)*             &
+     &       CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3))))+(TAUI*((WA1(I-2)*    &
+     &       CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2))-(WA2(I-2)*             &
+     &       CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3))))                      
+            CH(1,IC-1,2,K) = (CC(1,I-1,K,1)+TAUR*((WA1(I-2)*            &
+     &       CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2))+(WA2(I-2)*             &
+     &       CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3))))-(TAUI*((WA1(I-2)*    &
+     &       CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2))-(WA2(I-2)*             &
+     &       CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3))))                      
+            CH(1,I,3,K) = (CC(1,I,K,1)+TAUR*((WA1(I-2)*CC(1,I,K,2)-     &
+     &       WA1(I-1)*CC(1,I-1,K,2))+(WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*    &
+     &       CC(1,I-1,K,3))))+(TAUI*((WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*  &
+     &       CC(1,I,K,3))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*             &
+     &       CC(1,I,K,2))))                                             
+            CH(1,IC,2,K) = (TAUI*((WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*     &
+     &       CC(1,I,K,3))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*             &
+     &       CC(1,I,K,2))))-(CC(1,I,K,1)+TAUR*((WA1(I-2)*CC(1,I,K,2)-   &
+     &       WA1(I-1)*CC(1,I-1,K,2))+(WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*    &
+     &       CC(1,I-1,K,3))))                                           
+  102    CONTINUE 
+  103 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f4kb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f4kb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f4kb.F	(revision 17)
@@ -0,0 +1,69 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: r1f4kb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE R1F4KB (IDO,L1,CC,IN1,CH,IN2,WA1,WA2,WA3) 
+      REAL       CC(IN1,IDO,4,L1)  ,CH(IN2,IDO,L1,4)    ,               &
+     &           WA1(IDO)  ,        WA2(IDO)  ,       WA3(IDO)          
+!                                                                       
+      SQRT2=SQRT(2.) 
+      DO 101 K=1,L1 
+         CH(1,1,K,3) = (CC(1,1,1,K)+CC(1,IDO,4,K))                      &
+     &   -(CC(1,IDO,2,K)+CC(1,IDO,2,K))                                 
+         CH(1,1,K,1) = (CC(1,1,1,K)+CC(1,IDO,4,K))                      &
+     &   +(CC(1,IDO,2,K)+CC(1,IDO,2,K))                                 
+         CH(1,1,K,4) = (CC(1,1,1,K)-CC(1,IDO,4,K))                      &
+     &   +(CC(1,1,3,K)+CC(1,1,3,K))                                     
+         CH(1,1,K,2) = (CC(1,1,1,K)-CC(1,IDO,4,K))                      &
+     &   -(CC(1,1,3,K)+CC(1,1,3,K))                                     
+  101 END DO 
+      IF (IDO-2) 107,105,102 
+  102 IDP2 = IDO+2 
+      DO 104 K=1,L1 
+         DO 103 I=3,IDO,2 
+            IC = IDP2-I 
+        CH(1,I-1,K,1) = (CC(1,I-1,1,K)+CC(1,IC-1,4,K))                  &
+     &  +(CC(1,I-1,3,K)+CC(1,IC-1,2,K))                                 
+        CH(1,I,K,1) = (CC(1,I,1,K)-CC(1,IC,4,K))                        &
+     &  +(CC(1,I,3,K)-CC(1,IC,2,K))                                     
+        CH(1,I-1,K,2)=WA1(I-2)*((CC(1,I-1,1,K)-CC(1,IC-1,4,K))          &
+     &  -(CC(1,I,3,K)+CC(1,IC,2,K)))-WA1(I-1)                           &
+     &  *((CC(1,I,1,K)+CC(1,IC,4,K))+(CC(1,I-1,3,K)-CC(1,IC-1,2,K)))    
+        CH(1,I,K,2)=WA1(I-2)*((CC(1,I,1,K)+CC(1,IC,4,K))                &
+     &  +(CC(1,I-1,3,K)-CC(1,IC-1,2,K)))+WA1(I-1)                       &
+     &  *((CC(1,I-1,1,K)-CC(1,IC-1,4,K))-(CC(1,I,3,K)+CC(1,IC,2,K)))    
+        CH(1,I-1,K,3)=WA2(I-2)*((CC(1,I-1,1,K)+CC(1,IC-1,4,K))          &
+     &  -(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))-WA2(I-1)                       &
+     &  *((CC(1,I,1,K)-CC(1,IC,4,K))-(CC(1,I,3,K)-CC(1,IC,2,K)))        
+        CH(1,I,K,3)=WA2(I-2)*((CC(1,I,1,K)-CC(1,IC,4,K))                &
+     &  -(CC(1,I,3,K)-CC(1,IC,2,K)))+WA2(I-1)                           &
+     &  *((CC(1,I-1,1,K)+CC(1,IC-1,4,K))-(CC(1,I-1,3,K)                 &
+     &  +CC(1,IC-1,2,K)))                                               
+        CH(1,I-1,K,4)=WA3(I-2)*((CC(1,I-1,1,K)-CC(1,IC-1,4,K))          &
+     &  +(CC(1,I,3,K)+CC(1,IC,2,K)))-WA3(I-1)                           &
+     & *((CC(1,I,1,K)+CC(1,IC,4,K))-(CC(1,I-1,3,K)-CC(1,IC-1,2,K)))     
+        CH(1,I,K,4)=WA3(I-2)*((CC(1,I,1,K)+CC(1,IC,4,K))                &
+     &  -(CC(1,I-1,3,K)-CC(1,IC-1,2,K)))+WA3(I-1)                       &
+     &  *((CC(1,I-1,1,K)-CC(1,IC-1,4,K))+(CC(1,I,3,K)+CC(1,IC,2,K)))    
+  103    CONTINUE 
+  104 END DO 
+      IF (MOD(IDO,2) .EQ. 1) RETURN 
+  105 CONTINUE 
+      DO 106 K=1,L1 
+         CH(1,IDO,K,1) = (CC(1,IDO,1,K)+CC(1,IDO,3,K))                  &
+     &   +(CC(1,IDO,1,K)+CC(1,IDO,3,K))                                 
+         CH(1,IDO,K,2) = SQRT2*((CC(1,IDO,1,K)-CC(1,IDO,3,K))           &
+     &   -(CC(1,1,2,K)+CC(1,1,4,K)))                                    
+         CH(1,IDO,K,3) = (CC(1,1,4,K)-CC(1,1,2,K))                      &
+     &   +(CC(1,1,4,K)-CC(1,1,2,K))                                     
+         CH(1,IDO,K,4) = -SQRT2*((CC(1,IDO,1,K)-CC(1,IDO,3,K))          &
+     &   +(CC(1,1,2,K)+CC(1,1,4,K)))                                    
+  106 END DO 
+  107 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f4kf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f4kf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f4kf.F	(revision 17)
@@ -0,0 +1,76 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: r1f4kf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE R1F4KF (IDO,L1,CC,IN1,CH,IN2,WA1,WA2,WA3) 
+      REAL       CC(IN1,IDO,L1,4)   ,CH(IN2,IDO,4,L1)     ,             &
+     &           WA1(IDO)           ,WA2(IDO)     ,WA3(IDO)             
+!                                                                       
+      HSQT2=SQRT(2.)/2. 
+      DO 101 K=1,L1 
+         CH(1,1,1,K) = (CC(1,1,K,2)+CC(1,1,K,4))                        &
+     &      +(CC(1,1,K,1)+CC(1,1,K,3))                                  
+         CH(1,IDO,4,K) = (CC(1,1,K,1)+CC(1,1,K,3))                      &
+     &      -(CC(1,1,K,2)+CC(1,1,K,4))                                  
+         CH(1,IDO,2,K) = CC(1,1,K,1)-CC(1,1,K,3) 
+         CH(1,1,3,K) = CC(1,1,K,4)-CC(1,1,K,2) 
+  101 END DO 
+      IF (IDO-2) 107,105,102 
+  102 IDP2 = IDO+2 
+      DO 104 K=1,L1 
+         DO 103 I=3,IDO,2 
+            IC = IDP2-I 
+            CH(1,I-1,1,K) = ((WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*          &
+     &       CC(1,I,K,2))+(WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*             &
+     &       CC(1,I,K,4)))+(CC(1,I-1,K,1)+(WA2(I-2)*CC(1,I-1,K,3)+      &
+     &       WA2(I-1)*CC(1,I,K,3)))                                     
+            CH(1,IC-1,4,K) = (CC(1,I-1,K,1)+(WA2(I-2)*CC(1,I-1,K,3)+    &
+     &       WA2(I-1)*CC(1,I,K,3)))-((WA1(I-2)*CC(1,I-1,K,2)+           &
+     &       WA1(I-1)*CC(1,I,K,2))+(WA3(I-2)*CC(1,I-1,K,4)+             &
+     &       WA3(I-1)*CC(1,I,K,4)))                                     
+            CH(1,I,1,K) = ((WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*              &
+     &       CC(1,I-1,K,2))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
+     &       CC(1,I-1,K,4)))+(CC(1,I,K,1)+(WA2(I-2)*CC(1,I,K,3)-        &
+     &       WA2(I-1)*CC(1,I-1,K,3)))                                   
+            CH(1,IC,4,K) = ((WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*             &
+     &       CC(1,I-1,K,2))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
+     &       CC(1,I-1,K,4)))-(CC(1,I,K,1)+(WA2(I-2)*CC(1,I,K,3)-        &
+     &       WA2(I-1)*CC(1,I-1,K,3)))                                   
+            CH(1,I-1,3,K) = ((WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*            &
+     &       CC(1,I-1,K,2))-(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
+     &       CC(1,I-1,K,4)))+(CC(1,I-1,K,1)-(WA2(I-2)*CC(1,I-1,K,3)+    &
+     &       WA2(I-1)*CC(1,I,K,3)))                                     
+            CH(1,IC-1,2,K) = (CC(1,I-1,K,1)-(WA2(I-2)*CC(1,I-1,K,3)+    &
+     &       WA2(I-1)*CC(1,I,K,3)))-((WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*    &
+     &       CC(1,I-1,K,2))-(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
+     &       CC(1,I-1,K,4)))                                            
+            CH(1,I,3,K) = ((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*            &
+     &       CC(1,I,K,4))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*             &
+     &       CC(1,I,K,2)))+(CC(1,I,K,1)-(WA2(I-2)*CC(1,I,K,3)-          &
+     &       WA2(I-1)*CC(1,I-1,K,3)))                                   
+            CH(1,IC,2,K) = ((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*           &
+     &       CC(1,I,K,4))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*             &
+     &       CC(1,I,K,2)))-(CC(1,I,K,1)-(WA2(I-2)*CC(1,I,K,3)-          &
+     &       WA2(I-1)*CC(1,I-1,K,3)))                                   
+  103    CONTINUE 
+  104 END DO 
+      IF (MOD(IDO,2) .EQ. 1) RETURN 
+  105 CONTINUE 
+      DO 106 K=1,L1 
+            CH(1,IDO,1,K) = (HSQT2*(CC(1,IDO,K,2)-CC(1,IDO,K,4)))+      &
+     &       CC(1,IDO,K,1)                                              
+            CH(1,IDO,3,K) = CC(1,IDO,K,1)-(HSQT2*(CC(1,IDO,K,2)-        &
+     &       CC(1,IDO,K,4)))                                            
+            CH(1,1,2,K) = (-HSQT2*(CC(1,IDO,K,2)+CC(1,IDO,K,4)))-       &
+     &       CC(1,IDO,K,3)                                              
+            CH(1,1,4,K) = (-HSQT2*(CC(1,IDO,K,2)+CC(1,IDO,K,4)))+       &
+     &       CC(1,IDO,K,3)                                              
+  106 END DO 
+  107 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f5kb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f5kb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f5kb.F	(revision 17)
@@ -0,0 +1,115 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: r1f5kb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE R1F5KB (IDO,L1,CC,IN1,CH,IN2,                          &
+     &       WA1,WA2,WA3,WA4)                                           
+      REAL   CC(IN1,IDO,5,L1)    ,CH(IN2,IDO,L1,5),                     &
+     &       WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)     ,WA4(IDO)         
+!                                                                       
+      ARG=2.*4.*ATAN(1.0)/5. 
+      TR11=COS(ARG) 
+      TI11=SIN(ARG) 
+      TR12=COS(2.*ARG) 
+      TI12=SIN(2.*ARG) 
+      DO 101 K=1,L1 
+         CH(1,1,K,1) = CC(1,1,1,K)+2.*CC(1,IDO,2,K)+2.*CC(1,IDO,4,K) 
+         CH(1,1,K,2) = (CC(1,1,1,K)+TR11*2.*CC(1,IDO,2,K)               &
+     &   +TR12*2.*CC(1,IDO,4,K))-(TI11*2.*CC(1,1,3,K)                   &
+     &   +TI12*2.*CC(1,1,5,K))                                          
+         CH(1,1,K,3) = (CC(1,1,1,K)+TR12*2.*CC(1,IDO,2,K)               &
+     &   +TR11*2.*CC(1,IDO,4,K))-(TI12*2.*CC(1,1,3,K)                   &
+     &   -TI11*2.*CC(1,1,5,K))                                          
+         CH(1,1,K,4) = (CC(1,1,1,K)+TR12*2.*CC(1,IDO,2,K)               &
+     &   +TR11*2.*CC(1,IDO,4,K))+(TI12*2.*CC(1,1,3,K)                   &
+     &   -TI11*2.*CC(1,1,5,K))                                          
+         CH(1,1,K,5) = (CC(1,1,1,K)+TR11*2.*CC(1,IDO,2,K)               &
+     &   +TR12*2.*CC(1,IDO,4,K))+(TI11*2.*CC(1,1,3,K)                   &
+     &   +TI12*2.*CC(1,1,5,K))                                          
+  101 END DO 
+      IF (IDO .EQ. 1) RETURN 
+      IDP2 = IDO+2 
+      DO 103 K=1,L1 
+         DO 102 I=3,IDO,2 
+            IC = IDP2-I 
+        CH(1,I-1,K,1) = CC(1,I-1,1,K)+(CC(1,I-1,3,K)+CC(1,IC-1,2,K))    &
+     &  +(CC(1,I-1,5,K)+CC(1,IC-1,4,K))                                 
+        CH(1,I,K,1) = CC(1,I,1,K)+(CC(1,I,3,K)-CC(1,IC,2,K))            &
+     &  +(CC(1,I,5,K)-CC(1,IC,4,K))                                     
+        CH(1,I-1,K,2) = WA1(I-2)*((CC(1,I-1,1,K)+TR11*                  &
+     &  (CC(1,I-1,3,K)+CC(1,IC-1,2,K))+TR12                             &
+     &  *(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))-(TI11*(CC(1,I,3,K)             &
+     &  +CC(1,IC,2,K))+TI12*(CC(1,I,5,K)+CC(1,IC,4,K))))                &
+     &  -WA1(I-1)*((CC(1,I,1,K)+TR11*(CC(1,I,3,K)-CC(1,IC,2,K))         &
+     &  +TR12*(CC(1,I,5,K)-CC(1,IC,4,K)))+(TI11*(CC(1,I-1,3,K)          &
+     &  -CC(1,IC-1,2,K))+TI12*(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))          
+        CH(1,I,K,2) = WA1(I-2)*((CC(1,I,1,K)+TR11*(CC(1,I,3,K)          &
+     &  -CC(1,IC,2,K))+TR12*(CC(1,I,5,K)-CC(1,IC,4,K)))                 &
+     &  +(TI11*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))+TI12                      &
+     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))+WA1(I-1)                      &
+     &  *((CC(1,I-1,1,K)+TR11*(CC(1,I-1,3,K)                            &
+     &  +CC(1,IC-1,2,K))+TR12*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))           &
+     &  -(TI11*(CC(1,I,3,K)+CC(1,IC,2,K))+TI12                          &
+     &  *(CC(1,I,5,K)+CC(1,IC,4,K))))                                   
+        CH(1,I-1,K,3) = WA2(I-2)                                        &
+     &  *((CC(1,I-1,1,K)+TR12*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
+     &  +TR11*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))-(TI12*(CC(1,I,3,K)        &
+     &  +CC(1,IC,2,K))-TI11*(CC(1,I,5,K)+CC(1,IC,4,K))))                &
+     & -WA2(I-1)                                                        &
+     & *((CC(1,I,1,K)+TR12*(CC(1,I,3,K)-                                &
+     &  CC(1,IC,2,K))+TR11*(CC(1,I,5,K)-CC(1,IC,4,K)))                  &
+     &  +(TI12*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))-TI11                      &
+     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))                               
+        CH(1,I,K,3) = WA2(I-2)                                          &
+     & *((CC(1,I,1,K)+TR12*(CC(1,I,3,K)-                                &
+     &  CC(1,IC,2,K))+TR11*(CC(1,I,5,K)-CC(1,IC,4,K)))                  &
+     &  +(TI12*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))-TI11                      &
+     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))                               &
+     &  +WA2(I-1)                                                       &
+     &  *((CC(1,I-1,1,K)+TR12*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
+     &  +TR11*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))-(TI12*(CC(1,I,3,K)        &
+     &  +CC(1,IC,2,K))-TI11*(CC(1,I,5,K)+CC(1,IC,4,K))))                
+        CH(1,I-1,K,4) = WA3(I-2)                                        &
+     &  *((CC(1,I-1,1,K)+TR12*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
+     &  +TR11*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))+(TI12*(CC(1,I,3,K)        &
+     &  +CC(1,IC,2,K))-TI11*(CC(1,I,5,K)+CC(1,IC,4,K))))                &
+     &  -WA3(I-1)                                                       &
+     & *((CC(1,I,1,K)+TR12*(CC(1,I,3,K)-                                &
+     &  CC(1,IC,2,K))+TR11*(CC(1,I,5,K)-CC(1,IC,4,K)))                  &
+     &  -(TI12*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))-TI11                      &
+     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))                               
+        CH(1,I,K,4) = WA3(I-2)                                          &
+     & *((CC(1,I,1,K)+TR12*(CC(1,I,3,K)-                                &
+     &  CC(1,IC,2,K))+TR11*(CC(1,I,5,K)-CC(1,IC,4,K)))                  &
+     &  -(TI12*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))-TI11                      &
+     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))                               &
+     &  +WA3(I-1)                                                       &
+     &  *((CC(1,I-1,1,K)+TR12*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
+     &  +TR11*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))+(TI12*(CC(1,I,3,K)        &
+     &  +CC(1,IC,2,K))-TI11*(CC(1,I,5,K)+CC(1,IC,4,K))))                
+        CH(1,I-1,K,5) = WA4(I-2)                                        &
+     &  *((CC(1,I-1,1,K)+TR11*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
+     &  +TR12*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))+(TI11*(CC(1,I,3,K)        &
+     &  +CC(1,IC,2,K))+TI12*(CC(1,I,5,K)+CC(1,IC,4,K))))                &
+     &  -WA4(I-1)                                                       &
+     &  *((CC(1,I,1,K)+TR11*(CC(1,I,3,K)-CC(1,IC,2,K))                  &
+     &  +TR12*(CC(1,I,5,K)-CC(1,IC,4,K)))-(TI11*(CC(1,I-1,3,K)          &
+     &  -CC(1,IC-1,2,K))+TI12*(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))          
+        CH(1,I,K,5) = WA4(I-2)                                          &
+     &  *((CC(1,I,1,K)+TR11*(CC(1,I,3,K)-CC(1,IC,2,K))                  &
+     &  +TR12*(CC(1,I,5,K)-CC(1,IC,4,K)))-(TI11*(CC(1,I-1,3,K)          &
+     &  -CC(1,IC-1,2,K))+TI12*(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))          &
+     &  +WA4(I-1)                                                       &
+     &  *((CC(1,I-1,1,K)+TR11*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
+     &  +TR12*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))+(TI11*(CC(1,I,3,K)        &
+     &  +CC(1,IC,2,K))+TI12*(CC(1,I,5,K)+CC(1,IC,4,K))))                
+  102    CONTINUE 
+  103 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f5kf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f5kf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1f5kf.F	(revision 17)
@@ -0,0 +1,123 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: r1f5kf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE R1F5KF (IDO,L1,CC,IN1,CH,IN2,                          &
+     &                   WA1,WA2,WA3,WA4)                               
+      REAL       CC(IN1,IDO,L1,5)    ,CH(IN2,IDO,5,L1)     ,            &
+     &           WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)     ,WA4(IDO)     
+!                                                                       
+      ARG=2.*4.*ATAN(1.0)/5. 
+      TR11=COS(ARG) 
+      TI11=SIN(ARG) 
+      TR12=COS(2.*ARG) 
+      TI12=SIN(2.*ARG) 
+      DO 101 K=1,L1 
+         CH(1,1,1,K) = CC(1,1,K,1)+(CC(1,1,K,5)+CC(1,1,K,2))+           &
+     &    (CC(1,1,K,4)+CC(1,1,K,3))                                     
+         CH(1,IDO,2,K) = CC(1,1,K,1)+TR11*(CC(1,1,K,5)+CC(1,1,K,2))+    &
+     &    TR12*(CC(1,1,K,4)+CC(1,1,K,3))                                
+         CH(1,1,3,K) = TI11*(CC(1,1,K,5)-CC(1,1,K,2))+TI12*             &
+     &    (CC(1,1,K,4)-CC(1,1,K,3))                                     
+         CH(1,IDO,4,K) = CC(1,1,K,1)+TR12*(CC(1,1,K,5)+CC(1,1,K,2))+    &
+     &    TR11*(CC(1,1,K,4)+CC(1,1,K,3))                                
+         CH(1,1,5,K) = TI12*(CC(1,1,K,5)-CC(1,1,K,2))-TI11*             &
+     &    (CC(1,1,K,4)-CC(1,1,K,3))                                     
+  101 END DO 
+      IF (IDO .EQ. 1) RETURN 
+      IDP2 = IDO+2 
+      DO 103 K=1,L1 
+         DO 102 I=3,IDO,2 
+            IC = IDP2-I 
+            CH(1,I-1,1,K) = CC(1,I-1,K,1)+((WA1(I-2)*CC(1,I-1,K,2)+     &
+     &       WA1(I-1)*CC(1,I,K,2))+(WA4(I-2)*CC(1,I-1,K,5)+WA4(I-1)*    &
+     &       CC(1,I,K,5)))+((WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*           &
+     &       CC(1,I,K,3))+(WA3(I-2)*CC(1,I-1,K,4)+                      &
+     &       WA3(I-1)*CC(1,I,K,4)))                                     
+            CH(1,I,1,K) = CC(1,I,K,1)+((WA1(I-2)*CC(1,I,K,2)-           &
+     &       WA1(I-1)*CC(1,I-1,K,2))+(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*    &
+     &       CC(1,I-1,K,5)))+((WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*           &
+     &       CC(1,I-1,K,3))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
+     &       CC(1,I-1,K,4)))                                            
+            CH(1,I-1,3,K) = CC(1,I-1,K,1)+TR11*                         &
+     &      ( WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2)               &
+     &       +WA4(I-2)*CC(1,I-1,K,5)+WA4(I-1)*CC(1,I,K,5))+TR12*        &
+     &      ( WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3)               &
+     &       +WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*CC(1,I,K,4))+TI11*        &
+     &      ( WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2)               &
+     &       -(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*CC(1,I-1,K,5)))+TI12*      &
+     &      ( WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3)               &
+     &       -(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*CC(1,I-1,K,4)))            
+            CH(1,IC-1,2,K) = CC(1,I-1,K,1)+TR11*                        &
+     &      ( WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2)               &
+     &       +WA4(I-2)*CC(1,I-1,K,5)+WA4(I-1)*CC(1,I,K,5))+TR12*        &
+     &     ( WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3)                &
+     &      +WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*CC(1,I,K,4))-(TI11*        &
+     &      ( WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2)               &
+     &       -(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*CC(1,I-1,K,5)))+TI12*      &
+     &      ( WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3)               &
+     &       -(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*CC(1,I-1,K,4))))           
+            CH(1,I,3,K) = (CC(1,I,K,1)+TR11*((WA1(I-2)*CC(1,I,K,2)-     &
+     &       WA1(I-1)*CC(1,I-1,K,2))+(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*    &
+     &       CC(1,I-1,K,5)))+TR12*((WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*      &
+     &       CC(1,I-1,K,3))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
+     &       CC(1,I-1,K,4))))+(TI11*((WA4(I-2)*CC(1,I-1,K,5)+           &
+     &       WA4(I-1)*CC(1,I,K,5))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*    &
+     &       CC(1,I,K,2)))+TI12*((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*      &
+     &       CC(1,I,K,4))-(WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*             &
+     &       CC(1,I,K,3))))                                             
+            CH(1,IC,2,K) = (TI11*((WA4(I-2)*CC(1,I-1,K,5)+WA4(I-1)*     &
+     &       CC(1,I,K,5))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*             &
+     &       CC(1,I,K,2)))+TI12*((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*      &
+     &       CC(1,I,K,4))-(WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*             &
+     &       CC(1,I,K,3))))-(CC(1,I,K,1)+TR11*((WA1(I-2)*CC(1,I,K,2)-   &
+     &       WA1(I-1)*CC(1,I-1,K,2))+(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*    &
+     &       CC(1,I-1,K,5)))+TR12*((WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*      &
+     &       CC(1,I-1,K,3))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
+     &       CC(1,I-1,K,4))))                                           
+            CH(1,I-1,5,K) = (CC(1,I-1,K,1)+TR12*((WA1(I-2)*             &
+     &       CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2))+(WA4(I-2)*             &
+     &       CC(1,I-1,K,5)+WA4(I-1)*CC(1,I,K,5)))+TR11*((WA2(I-2)*      &
+     &       CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3))+(WA3(I-2)*             &
+     &       CC(1,I-1,K,4)+WA3(I-1)*CC(1,I,K,4))))+(TI12*((WA1(I-2)*    &
+     &       CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2))-(WA4(I-2)*             &
+     &       CC(1,I,K,5)-WA4(I-1)*CC(1,I-1,K,5)))-TI11*((WA2(I-2)*      &
+     &       CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3))-(WA3(I-2)*             &
+     &       CC(1,I,K,4)-WA3(I-1)*CC(1,I-1,K,4))))                      
+            CH(1,IC-1,4,K) = (CC(1,I-1,K,1)+TR12*((WA1(I-2)*            &
+     &       CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2))+(WA4(I-2)*             &
+     &       CC(1,I-1,K,5)+WA4(I-1)*CC(1,I,K,5)))+TR11*((WA2(I-2)*      &
+     &       CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3))+(WA3(I-2)*             &
+     &       CC(1,I-1,K,4)+WA3(I-1)*CC(1,I,K,4))))-(TI12*((WA1(I-2)*    &
+     &       CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2))-(WA4(I-2)*             &
+     &       CC(1,I,K,5)-WA4(I-1)*CC(1,I-1,K,5)))-TI11*((WA2(I-2)*      &
+     &       CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3))-(WA3(I-2)*             &
+     &       CC(1,I,K,4)-WA3(I-1)*CC(1,I-1,K,4))))                      
+            CH(1,I,5,K) = (CC(1,I,K,1)+TR12*((WA1(I-2)*CC(1,I,K,2)-     &
+     &       WA1(I-1)*CC(1,I-1,K,2))+(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*    &
+     &       CC(1,I-1,K,5)))+TR11*((WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*      &
+     &       CC(1,I-1,K,3))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
+     &       CC(1,I-1,K,4))))+(TI12*((WA4(I-2)*CC(1,I-1,K,5)+           &
+     &       WA4(I-1)*CC(1,I,K,5))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*    &
+     &       CC(1,I,K,2)))-TI11*((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*      &
+     &       CC(1,I,K,4))-(WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*             &
+     &       CC(1,I,K,3))))                                             
+            CH(1,IC,4,K) = (TI12*((WA4(I-2)*CC(1,I-1,K,5)+WA4(I-1)*     &
+     &       CC(1,I,K,5))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*             &
+     &       CC(1,I,K,2)))-TI11*((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*      &
+     &       CC(1,I,K,4))-(WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*             &
+     &       CC(1,I,K,3))))-(CC(1,I,K,1)+TR12*((WA1(I-2)*CC(1,I,K,2)-   &
+     &       WA1(I-1)*CC(1,I-1,K,2))+(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*    &
+     &       CC(1,I-1,K,5)))+TR11*((WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*      &
+     &       CC(1,I-1,K,3))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
+     &       CC(1,I-1,K,4))))                                           
+  102    CONTINUE 
+  103 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1fgkb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1fgkb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1fgkb.F	(revision 17)
@@ -0,0 +1,177 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: r1fgkb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE R1FGKB (IDO,IP,L1,IDL1,CC,C1,C2,IN1,                   &
+     &          CH,CH2,IN2,WA)                                          
+      REAL      CH(IN2,IDO,L1,IP)    ,CC(IN1,IDO,IP,L1) ,               &
+     &          C1(IN1,IDO,L1,IP)    ,C2(IN1,IDL1,IP),                  &
+     &          CH2(IN2,IDL1,IP)     ,WA(IDO)                           
+!                                                                       
+      TPI=2.*4.*ATAN(1.0) 
+      ARG = TPI/FLOAT(IP) 
+      DCP = COS(ARG) 
+      DSP = SIN(ARG) 
+      IDP2 = IDO+2 
+      NBD = (IDO-1)/2 
+      IPP2 = IP+2 
+      IPPH = (IP+1)/2 
+      IF (IDO .LT. L1) GO TO 103 
+      DO 102 K=1,L1 
+         DO 101 I=1,IDO 
+            CH(1,I,K,1) = CC(1,I,1,K) 
+  101    CONTINUE 
+  102 END DO 
+      GO TO 106 
+  103 DO 105 I=1,IDO 
+         DO 104 K=1,L1 
+            CH(1,I,K,1) = CC(1,I,1,K) 
+  104    CONTINUE 
+  105 END DO 
+  106 DO 108 J=2,IPPH 
+         JC = IPP2-J 
+         J2 = J+J 
+         DO 107 K=1,L1 
+            CH(1,1,K,J) = CC(1,IDO,J2-2,K)+CC(1,IDO,J2-2,K) 
+            CH(1,1,K,JC) = CC(1,1,J2-1,K)+CC(1,1,J2-1,K) 
+ 1007       CONTINUE 
+  107    CONTINUE 
+  108 END DO 
+      IF (IDO .EQ. 1) GO TO 116 
+      IF (NBD .LT. L1) GO TO 112 
+      DO 111 J=2,IPPH 
+         JC = IPP2-J 
+         DO 110 K=1,L1 
+            DO 109 I=3,IDO,2 
+               IC = IDP2-I 
+               CH(1,I-1,K,J) = CC(1,I-1,2*J-1,K)+CC(1,IC-1,2*J-2,K) 
+               CH(1,I-1,K,JC) = CC(1,I-1,2*J-1,K)-CC(1,IC-1,2*J-2,K) 
+               CH(1,I,K,J) = CC(1,I,2*J-1,K)-CC(1,IC,2*J-2,K) 
+               CH(1,I,K,JC) = CC(1,I,2*J-1,K)+CC(1,IC,2*J-2,K) 
+  109       CONTINUE 
+  110    CONTINUE 
+  111 END DO 
+      GO TO 116 
+  112 DO 115 J=2,IPPH 
+         JC = IPP2-J 
+         DO 114 I=3,IDO,2 
+            IC = IDP2-I 
+            DO 113 K=1,L1 
+               CH(1,I-1,K,J) = CC(1,I-1,2*J-1,K)+CC(1,IC-1,2*J-2,K) 
+               CH(1,I-1,K,JC) = CC(1,I-1,2*J-1,K)-CC(1,IC-1,2*J-2,K) 
+               CH(1,I,K,J) = CC(1,I,2*J-1,K)-CC(1,IC,2*J-2,K) 
+               CH(1,I,K,JC) = CC(1,I,2*J-1,K)+CC(1,IC,2*J-2,K) 
+  113       CONTINUE 
+  114    CONTINUE 
+  115 END DO 
+  116 AR1 = 1. 
+      AI1 = 0. 
+      DO 120 L=2,IPPH 
+         LC = IPP2-L 
+         AR1H = DCP*AR1-DSP*AI1 
+         AI1 = DCP*AI1+DSP*AR1 
+         AR1 = AR1H 
+         DO 117 IK=1,IDL1 
+            C2(1,IK,L) = CH2(1,IK,1)+AR1*CH2(1,IK,2) 
+            C2(1,IK,LC) = AI1*CH2(1,IK,IP) 
+  117    CONTINUE 
+         DC2 = AR1 
+         DS2 = AI1 
+         AR2 = AR1 
+         AI2 = AI1 
+         DO 119 J=3,IPPH 
+            JC = IPP2-J 
+            AR2H = DC2*AR2-DS2*AI2 
+            AI2 = DC2*AI2+DS2*AR2 
+            AR2 = AR2H 
+            DO 118 IK=1,IDL1 
+               C2(1,IK,L) = C2(1,IK,L)+AR2*CH2(1,IK,J) 
+               C2(1,IK,LC) = C2(1,IK,LC)+AI2*CH2(1,IK,JC) 
+  118       CONTINUE 
+  119    CONTINUE 
+  120 END DO 
+      DO 122 J=2,IPPH 
+         DO 121 IK=1,IDL1 
+            CH2(1,IK,1) = CH2(1,IK,1)+CH2(1,IK,J) 
+  121    CONTINUE 
+  122 END DO 
+      DO 124 J=2,IPPH 
+         JC = IPP2-J 
+         DO 123 K=1,L1 
+            CH(1,1,K,J) = C1(1,1,K,J)-C1(1,1,K,JC) 
+            CH(1,1,K,JC) = C1(1,1,K,J)+C1(1,1,K,JC) 
+  123    CONTINUE 
+  124 END DO 
+      IF (IDO .EQ. 1) GO TO 132 
+      IF (NBD .LT. L1) GO TO 128 
+      DO 127 J=2,IPPH 
+         JC = IPP2-J 
+         DO 126 K=1,L1 
+            DO 125 I=3,IDO,2 
+               CH(1,I-1,K,J) = C1(1,I-1,K,J)-C1(1,I,K,JC) 
+               CH(1,I-1,K,JC) = C1(1,I-1,K,J)+C1(1,I,K,JC) 
+               CH(1,I,K,J) = C1(1,I,K,J)+C1(1,I-1,K,JC) 
+               CH(1,I,K,JC) = C1(1,I,K,J)-C1(1,I-1,K,JC) 
+  125       CONTINUE 
+  126    CONTINUE 
+  127 END DO 
+      GO TO 132 
+  128 DO 131 J=2,IPPH 
+         JC = IPP2-J 
+         DO 130 I=3,IDO,2 
+            DO 129 K=1,L1 
+               CH(1,I-1,K,J) = C1(1,I-1,K,J)-C1(1,I,K,JC) 
+               CH(1,I-1,K,JC) = C1(1,I-1,K,J)+C1(1,I,K,JC) 
+               CH(1,I,K,J) = C1(1,I,K,J)+C1(1,I-1,K,JC) 
+               CH(1,I,K,JC) = C1(1,I,K,J)-C1(1,I-1,K,JC) 
+  129       CONTINUE 
+  130    CONTINUE 
+  131 END DO 
+  132 CONTINUE 
+      IF (IDO .EQ. 1) RETURN 
+      DO 133 IK=1,IDL1 
+         C2(1,IK,1) = CH2(1,IK,1) 
+  133 END DO 
+      DO 135 J=2,IP 
+         DO 134 K=1,L1 
+            C1(1,1,K,J) = CH(1,1,K,J) 
+  134    CONTINUE 
+  135 END DO 
+      IF (NBD .GT. L1) GO TO 139 
+      IS = -IDO 
+      DO 138 J=2,IP 
+         IS = IS+IDO 
+         IDIJ = IS 
+         DO 137 I=3,IDO,2 
+            IDIJ = IDIJ+2 
+            DO 136 K=1,L1 
+               C1(1,I-1,K,J) = WA(IDIJ-1)*CH(1,I-1,K,J)-WA(IDIJ)*       &
+     &          CH(1,I,K,J)                                             
+               C1(1,I,K,J) = WA(IDIJ-1)*CH(1,I,K,J)+WA(IDIJ)*           &
+     &          CH(1,I-1,K,J)                                           
+  136       CONTINUE 
+  137    CONTINUE 
+  138 END DO 
+      GO TO 143 
+  139 IS = -IDO 
+      DO 142 J=2,IP 
+         IS = IS+IDO 
+         DO 141 K=1,L1 
+            IDIJ = IS 
+            DO 140 I=3,IDO,2 
+               IDIJ = IDIJ+2 
+               C1(1,I-1,K,J) = WA(IDIJ-1)*CH(1,I-1,K,J)-WA(IDIJ)*       &
+     &          CH(1,I,K,J)                                             
+               C1(1,I,K,J) = WA(IDIJ-1)*CH(1,I,K,J)+WA(IDIJ)*           &
+     &          CH(1,I-1,K,J)                                           
+  140       CONTINUE 
+  141    CONTINUE 
+  142 END DO 
+  143 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1fgkf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1fgkf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/r1fgkf.F	(revision 17)
@@ -0,0 +1,182 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: r1fgkf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE R1FGKF (IDO,IP,L1,IDL1,CC,C1,C2,IN1,                   &
+     &              CH,CH2,IN2,WA)                                      
+      REAL          CH(IN2,IDO,L1,IP)   ,CC(IN1,IDO,IP,L1),             &
+     &              C1(IN1,IDO,L1,IP)   ,C2(IN1,IDL1,IP),               &
+     &              CH2(IN2,IDL1,IP)    ,WA(IDO)                        
+!                                                                       
+      TPI=2.*4.*ATAN(1.0) 
+      ARG = TPI/FLOAT(IP) 
+      DCP = COS(ARG) 
+      DSP = SIN(ARG) 
+      IPPH = (IP+1)/2 
+      IPP2 = IP+2 
+      IDP2 = IDO+2 
+      NBD = (IDO-1)/2 
+      IF (IDO .EQ. 1) GO TO 119 
+      DO 101 IK=1,IDL1 
+         CH2(1,IK,1) = C2(1,IK,1) 
+  101 END DO 
+      DO 103 J=2,IP 
+         DO 102 K=1,L1 
+            CH(1,1,K,J) = C1(1,1,K,J) 
+  102    CONTINUE 
+  103 END DO 
+      IF (NBD .GT. L1) GO TO 107 
+      IS = -IDO 
+      DO 106 J=2,IP 
+         IS = IS+IDO 
+         IDIJ = IS 
+         DO 105 I=3,IDO,2 
+            IDIJ = IDIJ+2 
+            DO 104 K=1,L1 
+               CH(1,I-1,K,J) = WA(IDIJ-1)*C1(1,I-1,K,J)+WA(IDIJ)        &
+     &           *C1(1,I,K,J)                                           
+               CH(1,I,K,J) = WA(IDIJ-1)*C1(1,I,K,J)-WA(IDIJ)            &
+     &           *C1(1,I-1,K,J)                                         
+  104       CONTINUE 
+  105    CONTINUE 
+  106 END DO 
+      GO TO 111 
+  107 IS = -IDO 
+      DO 110 J=2,IP 
+         IS = IS+IDO 
+         DO 109 K=1,L1 
+            IDIJ = IS 
+            DO 108 I=3,IDO,2 
+               IDIJ = IDIJ+2 
+               CH(1,I-1,K,J) = WA(IDIJ-1)*C1(1,I-1,K,J)+WA(IDIJ)        &
+     &           *C1(1,I,K,J)                                           
+               CH(1,I,K,J) = WA(IDIJ-1)*C1(1,I,K,J)-WA(IDIJ)            &
+     &           *C1(1,I-1,K,J)                                         
+  108       CONTINUE 
+  109    CONTINUE 
+  110 END DO 
+  111 IF (NBD .LT. L1) GO TO 115 
+      DO 114 J=2,IPPH 
+         JC = IPP2-J 
+         DO 113 K=1,L1 
+            DO 112 I=3,IDO,2 
+               C1(1,I-1,K,J) = CH(1,I-1,K,J)+CH(1,I-1,K,JC) 
+               C1(1,I-1,K,JC) = CH(1,I,K,J)-CH(1,I,K,JC) 
+               C1(1,I,K,J) = CH(1,I,K,J)+CH(1,I,K,JC) 
+               C1(1,I,K,JC) = CH(1,I-1,K,JC)-CH(1,I-1,K,J) 
+  112       CONTINUE 
+  113    CONTINUE 
+  114 END DO 
+      GO TO 121 
+  115 DO 118 J=2,IPPH 
+         JC = IPP2-J 
+         DO 117 I=3,IDO,2 
+            DO 116 K=1,L1 
+               C1(1,I-1,K,J) = CH(1,I-1,K,J)+CH(1,I-1,K,JC) 
+               C1(1,I-1,K,JC) = CH(1,I,K,J)-CH(1,I,K,JC) 
+               C1(1,I,K,J) = CH(1,I,K,J)+CH(1,I,K,JC) 
+               C1(1,I,K,JC) = CH(1,I-1,K,JC)-CH(1,I-1,K,J) 
+  116       CONTINUE 
+  117    CONTINUE 
+  118 END DO 
+      GO TO 121 
+  119 DO 120 IK=1,IDL1 
+         C2(1,IK,1) = CH2(1,IK,1) 
+  120 END DO 
+  121 DO 123 J=2,IPPH 
+         JC = IPP2-J 
+         DO 122 K=1,L1 
+            C1(1,1,K,J) = CH(1,1,K,J)+CH(1,1,K,JC) 
+            C1(1,1,K,JC) = CH(1,1,K,JC)-CH(1,1,K,J) 
+  122    CONTINUE 
+  123 END DO 
+!                                                                       
+      AR1 = 1. 
+      AI1 = 0. 
+      DO 127 L=2,IPPH 
+         LC = IPP2-L 
+         AR1H = DCP*AR1-DSP*AI1 
+         AI1 = DCP*AI1+DSP*AR1 
+         AR1 = AR1H 
+         DO 124 IK=1,IDL1 
+            CH2(1,IK,L) = C2(1,IK,1)+AR1*C2(1,IK,2) 
+            CH2(1,IK,LC) = AI1*C2(1,IK,IP) 
+  124    CONTINUE 
+         DC2 = AR1 
+         DS2 = AI1 
+         AR2 = AR1 
+         AI2 = AI1 
+         DO 126 J=3,IPPH 
+            JC = IPP2-J 
+            AR2H = DC2*AR2-DS2*AI2 
+            AI2 = DC2*AI2+DS2*AR2 
+            AR2 = AR2H 
+            DO 125 IK=1,IDL1 
+               CH2(1,IK,L) = CH2(1,IK,L)+AR2*C2(1,IK,J) 
+               CH2(1,IK,LC) = CH2(1,IK,LC)+AI2*C2(1,IK,JC) 
+  125       CONTINUE 
+  126    CONTINUE 
+  127 END DO 
+      DO 129 J=2,IPPH 
+         DO 128 IK=1,IDL1 
+            CH2(1,IK,1) = CH2(1,IK,1)+C2(1,IK,J) 
+  128    CONTINUE 
+  129 END DO 
+!                                                                       
+      IF (IDO .LT. L1) GO TO 132 
+      DO 131 K=1,L1 
+         DO 130 I=1,IDO 
+            CC(1,I,1,K) = CH(1,I,K,1) 
+  130    CONTINUE 
+  131 END DO 
+      GO TO 135 
+  132 DO 134 I=1,IDO 
+         DO 133 K=1,L1 
+            CC(1,I,1,K) = CH(1,I,K,1) 
+  133    CONTINUE 
+  134 END DO 
+  135 DO 137 J=2,IPPH 
+         JC = IPP2-J 
+         J2 = J+J 
+         DO 136 K=1,L1 
+            CC(1,IDO,J2-2,K) = CH(1,1,K,J) 
+            CC(1,1,J2-1,K) = CH(1,1,K,JC) 
+  136    CONTINUE 
+  137 END DO 
+      IF (IDO .EQ. 1) RETURN 
+      IF (NBD .LT. L1) GO TO 141 
+      DO 140 J=2,IPPH 
+         JC = IPP2-J 
+         J2 = J+J 
+         DO 139 K=1,L1 
+            DO 138 I=3,IDO,2 
+               IC = IDP2-I 
+               CC(1,I-1,J2-1,K) = CH(1,I-1,K,J)+CH(1,I-1,K,JC) 
+               CC(1,IC-1,J2-2,K) = CH(1,I-1,K,J)-CH(1,I-1,K,JC) 
+               CC(1,I,J2-1,K) = CH(1,I,K,J)+CH(1,I,K,JC) 
+               CC(1,IC,J2-2,K) = CH(1,I,K,JC)-CH(1,I,K,J) 
+  138       CONTINUE 
+  139    CONTINUE 
+  140 END DO 
+      RETURN 
+  141 DO 144 J=2,IPPH 
+         JC = IPP2-J 
+         J2 = J+J 
+         DO 143 I=3,IDO,2 
+            IC = IDP2-I 
+            DO 142 K=1,L1 
+               CC(1,I-1,J2-1,K) = CH(1,I-1,K,J)+CH(1,I-1,K,JC) 
+               CC(1,IC-1,J2-2,K) = CH(1,I-1,K,J)-CH(1,I-1,K,JC) 
+               CC(1,I,J2-1,K) = CH(1,I,K,J)+CH(1,I,K,JC) 
+               CC(1,IC,J2-2,K) = CH(1,I,K,JC)-CH(1,I,K,J) 
+  142       CONTINUE 
+  143    CONTINUE 
+  144 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft1b.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft1b.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft1b.F	(revision 17)
@@ -0,0 +1,33 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: rfft1b.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE RFFT1B ( N, INC, R, LENR, WSAVE, LENSAV,               &
+     &                  WORK, LENWRK, IER)                              
+      INTEGER  N, INC, LENR, LENSAV, LENWRK, IER 
+      REAL     R(LENR), WSAVE(LENSAV)     ,WORK(LENWRK) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENR .LT. INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('RFFT1B ', 6) 
+      ELSEIF (LENSAV .LT. N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('RFFT1B ', 8) 
+      ELSEIF (LENWRK .LT. N) THEN 
+        IER = 3 
+        CALL XERFFT ('RFFT1B ', 10) 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+!                                                                       
+      CALL RFFTB1 (N,INC,R,WORK,WSAVE,WSAVE(N+1)) 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft1f.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft1f.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft1f.F	(revision 17)
@@ -0,0 +1,33 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: rfft1f.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE RFFT1F ( N, INC, R, LENR, WSAVE, LENSAV,               &
+     &                  WORK, LENWRK, IER)                              
+      INTEGER  N, INC, LENR, LENSAV, LENWRK, IER 
+      REAL     R(LENR), WSAVE(LENSAV), WORK(LENWRK) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENR .LT. INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('RFFT1F ', 6) 
+      ELSEIF (LENSAV .LT. N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('RFFT1F ', 8) 
+      ELSEIF (LENWRK .LT. N) THEN 
+        IER = 3 
+        CALL XERFFT ('RFFT1F ', 10) 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+!                                                                       
+      CALL RFFTF1 (N,INC,R,WORK,WSAVE,WSAVE(N+1)) 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft1i.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft1i.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft1i.F	(revision 17)
@@ -0,0 +1,26 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: rfft1i.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE RFFT1I ( N, WSAVE, LENSAV, IER ) 
+      INTEGER    N, LENSAV, IER 
+      REAL       WSAVE(LENSAV) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENSAV .LT. N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('RFFT1I ', 3) 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+!                                                                       
+      CALL RFFTI1 (N,WSAVE(1),WSAVE(N+1)) 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft2b.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft2b.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft2b.F	(revision 17)
@@ -0,0 +1,79 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: rfft2b.f,v 1.5 2004/07/06 00:58:41 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE RFFT2B (LDIM, L, M, R, WSAVE, LENSAV, WORK,            &
+     &  LENWRK, IER)                                                    
+      INTEGER LDIM, L, M, LENSAV, LENWRK, IER 
+      REAL    R(LDIM,M), WSAVE(LENSAV), WORK(LENWRK) 
+!                                                                       
+!                                                                       
+! Initialize IER                                                        
+!                                                                       
+      IER = 0 
+!                                                                       
+! Verify LENSAV                                                         
+!                                                                       
+      LWSAV =   L + INT(LOG (REAL(L))) +4 
+      MWSAV =   2*M + INT(LOG (REAL(M))) +4 
+      IF (LENSAV .LT. LWSAV+MWSAV) THEN 
+        IER = 2 
+        CALL XERFFT ('RFFT2B', 6) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+! Verify LENWRK                                                         
+!                                                                       
+      IF (LENWRK .LT. 2*(L/2+1)*M) THEN 
+        IER = 3 
+        CALL XERFFT ('RFFT2B', 8) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+! Verify LDIM is as big as L                                            
+!                                                                       
+      IF (LDIM .LT. 2*(L/2+1)) THEN 
+        IER = 5 
+        CALL XERFFT ('RFFT2B', -6) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+! transform second dimension of array                                   
+!                                                                       
+      CALL CFFTMB(L/2+1,1,M,LDIM/2,R,M*LDIM/2,                          &
+     &     WSAVE(L+INT(LOG(REAL(L)))+5),                                &
+     &     2*M+INT(LOG(REAL(M)))+4,WORK,2*(L/2+1)*M,IER1)               
+      IF(IER1.NE.0) THEN 
+         IER=20 
+         CALL XERFFT('RFFT2B',-5) 
+         GO TO 100 
+      ENDIF 
+!                                                                       
+! reshuffle                                                             
+!                                                                       
+      DO J=1,M 
+         DO I=2,L 
+            R(I,J)=R(I+1,J) 
+         ENDDO 
+      ENDDO 
+!                                                                       
+! Transform first dimension of array                                    
+!                                                                       
+      CALL RFFTMB(M,LDIM,L,1,R,M*LDIM,WSAVE(1),                         &
+     &     L+INT(LOG(REAL(L)))+4,WORK,2*(L/2+1)*M,IER1)                 
+      IF(IER1.NE.0) THEN 
+         IER=20 
+         CALL XERFFT('RFFT2F',-5) 
+         GO TO 100 
+      ENDIF 
+!                                                                       
+  100 CONTINUE 
+!                                                                       
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft2f.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft2f.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft2f.F	(revision 17)
@@ -0,0 +1,81 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: rfft2f.f,v 1.5 2004/07/06 00:58:41 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE RFFT2F (LDIM, L, M, R, WSAVE, LENSAV, WORK,            &
+     &  LENWRK, IER)                                                    
+      INTEGER LDIM, L, M, LENSAV, LENWRK, IER 
+      REAL    R(LDIM,M), WSAVE(LENSAV), WORK(LENWRK) 
+!                                                                       
+!                                                                       
+! Initialize IER                                                        
+!                                                                       
+      IER = 0 
+!                                                                       
+! Verify LENSAV                                                         
+!                                                                       
+      LWSAV =   L + INT(LOG (REAL(L))) +4 
+      MWSAV =   2*M + INT(LOG (REAL(M))) +4 
+      IF (LENSAV .LT. LWSAV+MWSAV) THEN 
+        IER = 2 
+        CALL XERFFT ('RFFT2F', 6) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+! Verify LENWRK                                                         
+!                                                                       
+      IF (LENWRK .LT. 2*(L/2+1)*M) THEN 
+        IER = 3 
+        CALL XERFFT ('RFFT2F', 8) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+! Verify LDIM is as big as L                                            
+!                                                                       
+      IF (LDIM .LT. 2*(L/2+1)) THEN 
+        IER = 5 
+        CALL XERFFT ('RFFT2F', -6) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+! Transform first dimension of array                                    
+!                                                                       
+      CALL RFFTMF(M,LDIM,L,1,R,M*LDIM,WSAVE(1),                         &
+     &     L+INT(LOG(REAL(L)))+4,WORK,2*(L/2+1)*M,IER1)                 
+      IF(IER1.NE.0) THEN 
+         IER=20 
+         CALL XERFFT('RFFT2F',-5) 
+         GO TO 100 
+      ENDIF 
+!                                                                       
+! reshuffle to add in nyquist imaginary components                      
+!                                                                       
+      DO J=1,M 
+         IF(MOD(L,2).EQ.0) R(L+2,J)=0.0 
+         DO I=L,2,-1 
+            R(I+1,J)=R(I,J) 
+         ENDDO 
+         R(2,J)=0.0 
+      ENDDO 
+!                                                                       
+! transform second dimension of array                                   
+!                                                                       
+      CALL CFFTMF(L/2+1,1,M,LDIM/2,R,M*LDIM/2,                          &
+     &     WSAVE(L+INT(LOG(REAL(L)))+5),                                &
+     &     2*M+INT(LOG(REAL(M)))+4,WORK,2*(L/2+1)*M,IER1)               
+      IF(IER1.NE.0) THEN 
+         IER=20 
+         CALL XERFFT('RFFT2F',-5) 
+         GO TO 100 
+      ENDIF 
+!                                                                       
+  100 CONTINUE 
+!                                                                       
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft2i.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft2i.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfft2i.F	(revision 17)
@@ -0,0 +1,45 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: rfft2i.f,v 1.3 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE RFFT2I (L, M, WSAVE, LENSAV, IER) 
+      INTEGER L, M, LENSAV, IER 
+      INTEGER LWSAV,MWSAV 
+      REAL WSAVE(LENSAV) 
+!                                                                       
+! Initialize IER                                                        
+!                                                                       
+      IER = 0 
+!                                                                       
+! Verify LENSAV                                                         
+!                                                                       
+      LWSAV =   L+INT(LOG(REAL(L)))+4 
+      MWSAV =   2*M+INT(LOG(REAL(M)))+4 
+      IF (LENSAV .LT. LWSAV+MWSAV) THEN 
+        IER = 2 
+        CALL XERFFT ('RFFT2I', 4) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+      CALL RFFTMI (L, WSAVE(1), L + INT(LOG(REAL(L))) + 4, IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('RFFT2I',-5) 
+        GO TO 100 
+      ENDIF 
+      CALL CFFTMI (M, WSAVE(L+INT(LOG(REAL(L)))+5),                     &
+     &            2*M+INT(LOG(REAL(M)))+4,IER1)                         
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('RFFT2I',-5) 
+      ENDIF 
+!                                                                       
+  100 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftb1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftb1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftb1.F	(revision 17)
@@ -0,0 +1,95 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: rfftb1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE RFFTB1 (N,IN,C,CH,WA,FAC) 
+      REAL       CH(*), C(IN,*), WA(N) ,FAC(15) 
+!                                                                       
+      NF = FAC(2) 
+      NA = 0 
+      DO 10 K1=1,NF 
+      IP = FAC(K1+2) 
+      NA = 1-NA 
+      IF(IP .LE. 5) GO TO 10 
+      IF(K1 .EQ. NF) GO TO 10 
+      NA = 1-NA 
+   10 END DO 
+      HALF = .5 
+      HALFM = -.5 
+      MODN = MOD(N,2) 
+      NL = N-2 
+      IF(MODN .NE. 0) NL = N-1 
+      IF (NA .EQ. 0) GO TO 120 
+      CH(1) = C(1,1) 
+      CH(N) = C(1,N) 
+      DO 118 J=2,NL,2 
+         CH(J) = HALF*C(1,J) 
+         CH(J+1) = HALFM*C(1,J+1) 
+  118 END DO 
+      GO TO 124 
+  120 DO 122 J=2,NL,2 
+         C(1,J) = HALF*C(1,J) 
+         C(1,J+1) = HALFM*C(1,J+1) 
+  122 END DO 
+  124 L1 = 1 
+      IW = 1 
+      DO 116 K1=1,NF 
+         IP = FAC(K1+2) 
+         L2 = IP*L1 
+         IDO = N/L2 
+         IDL1 = IDO*L1 
+         IF (IP .NE. 4) GO TO 103 
+         IX2 = IW+IDO 
+         IX3 = IX2+IDO 
+         IF (NA .NE. 0) GO TO 101 
+         CALL R1F4KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),WA(IX3)) 
+         GO TO 102 
+  101    CALL R1F4KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),WA(IX3)) 
+  102    NA = 1-NA 
+         GO TO 115 
+  103    IF (IP .NE. 2) GO TO 106 
+         IF (NA .NE. 0) GO TO 104 
+         CALL R1F2KB (IDO,L1,C,IN,CH,1,WA(IW)) 
+         GO TO 105 
+  104    CALL R1F2KB (IDO,L1,CH,1,C,IN,WA(IW)) 
+  105    NA = 1-NA 
+         GO TO 115 
+  106    IF (IP .NE. 3) GO TO 109 
+         IX2 = IW+IDO 
+         IF (NA .NE. 0) GO TO 107 
+! rav    CALL RIF3KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2))                  
+         CALL R1F3KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2)) 
+         GO TO 108 
+  107    CALL R1F3KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2)) 
+  108    NA = 1-NA 
+         GO TO 115 
+  109    IF (IP .NE. 5) GO TO 112 
+         IX2 = IW+IDO 
+         IX3 = IX2+IDO 
+         IX4 = IX3+IDO 
+         IF (NA .NE. 0) GO TO 110 
+         CALL R1F5KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),                  &
+     &                  WA(IX3),WA(IX4))                                
+         GO TO 111 
+  110    CALL R1F5KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),                  &
+     &                  WA(IX3),WA(IX4))                                
+  111    NA = 1-NA 
+         GO TO 115 
+  112    IF (NA .NE. 0) GO TO 113 
+! rav    CALL RIFGKB (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW))           
+         CALL R1FGKB (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW)) 
+         GO TO 114 
+! rav 113    CALL RIFGKB (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW))      
+  113    CALL R1FGKB (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW)) 
+  114    IF (IDO .EQ. 1) NA = 1-NA 
+  115    L1 = L2 
+         IW = IW+(IP-1)*IDO 
+  116 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftf1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftf1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftf1.F	(revision 17)
@@ -0,0 +1,90 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: rfftf1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE RFFTF1 (N,IN,C,CH,WA,FAC) 
+      REAL       CH(*) ,C(IN,*)  ,WA(N)   ,FAC(15) 
+!                                                                       
+      NF = FAC(2) 
+      NA = 1 
+      L2 = N 
+      IW = N 
+      DO 111 K1=1,NF 
+         KH = NF-K1 
+         IP = FAC(KH+3) 
+         L1 = L2/IP 
+         IDO = N/L2 
+         IDL1 = IDO*L1 
+         IW = IW-(IP-1)*IDO 
+         NA = 1-NA 
+         IF (IP .NE. 4) GO TO 102 
+         IX2 = IW+IDO 
+         IX3 = IX2+IDO 
+         IF (NA .NE. 0) GO TO 101 
+         CALL R1F4KF (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),WA(IX3)) 
+         GO TO 110 
+  101    CALL R1F4KF (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),WA(IX3)) 
+         GO TO 110 
+  102    IF (IP .NE. 2) GO TO 104 
+         IF (NA .NE. 0) GO TO 103 
+         CALL R1F2KF (IDO,L1,C,IN,CH,1,WA(IW)) 
+         GO TO 110 
+  103    CALL R1F2KF (IDO,L1,CH,1,C,IN,WA(IW)) 
+         GO TO 110 
+  104    IF (IP .NE. 3) GO TO 106 
+         IX2 = IW+IDO 
+         IF (NA .NE. 0) GO TO 105 
+         CALL R1F3KF (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2)) 
+         GO TO 110 
+  105    CALL R1F3KF (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2)) 
+         GO TO 110 
+  106    IF (IP .NE. 5) GO TO 108 
+         IX2 = IW+IDO 
+         IX3 = IX2+IDO 
+         IX4 = IX3+IDO 
+         IF (NA .NE. 0) GO TO 107 
+         CALL R1F5KF (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),                  &
+     &                      WA(IX3),WA(IX4))                            
+         GO TO 110 
+  107    CALL R1F5KF (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),                  &
+     &                      WA(IX3),WA(IX4))                            
+         GO TO 110 
+  108    IF (IDO .EQ. 1) NA = 1-NA 
+         IF (NA .NE. 0) GO TO 109 
+         CALL R1FGKF (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW)) 
+         NA = 1 
+         GO TO 110 
+  109    CALL R1FGKF (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW)) 
+         NA = 0 
+  110    L2 = L1 
+  111 END DO 
+      SN = 1./N 
+      TSN = 2./N 
+      TSNM = -TSN 
+      MODN = MOD(N,2) 
+      NL = N-2 
+      IF(MODN .NE. 0) NL = N-1 
+      IF (NA .NE. 0) GO TO 120 
+      C(1,1) = SN*CH(1) 
+      DO 118 J=2,NL,2 
+         C(1,J) = TSN*CH(J) 
+         C(1,J+1) = TSNM*CH(J+1) 
+  118 END DO 
+      IF(MODN .NE. 0) RETURN 
+      C(1,N) = SN*CH(N) 
+      RETURN 
+  120 C(1,1) = SN*C(1,1) 
+      DO 122 J=2,NL,2 
+         C(1,J) = TSN*C(1,J) 
+         C(1,J+1) = TSNM*C(1,J+1) 
+  122 END DO 
+      IF(MODN .NE. 0) RETURN 
+      C(1,N) = SN*C(1,N) 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rffti1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rffti1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rffti1.F	(revision 17)
@@ -0,0 +1,70 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: rffti1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE RFFTI1 (N,WA,FAC) 
+      REAL       WA(N)      ,FAC(15) 
+      INTEGER    NTRYH(4) 
+      DOUBLE PRECISION TPI,ARGH,ARGLD,ARG 
+      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ 
+!                                                                       
+      NL = N 
+      NF = 0 
+      J = 0 
+  101 J = J+1 
+      IF (J-4) 102,102,103 
+  102 NTRY = NTRYH(J) 
+      GO TO 104 
+  103 NTRY = NTRY+2 
+  104 NQ = NL/NTRY 
+      NR = NL-NTRY*NQ 
+      IF (NR) 101,105,101 
+  105 NF = NF+1 
+      FAC(NF+2) = NTRY 
+      NL = NQ 
+      IF (NTRY .NE. 2) GO TO 107 
+      IF (NF .EQ. 1) GO TO 107 
+      DO 106 I=2,NF 
+         IB = NF-I+2 
+         FAC(IB+2) = FAC(IB+1) 
+  106 END DO 
+      FAC(3) = 2 
+  107 IF (NL .NE. 1) GO TO 104 
+      FAC(1) = N 
+      FAC(2) = NF 
+      TPI = 8.D0*DATAN(1.D0) 
+      ARGH = TPI/FLOAT(N) 
+      IS = 0 
+      NFM1 = NF-1 
+      L1 = 1 
+      IF (NFM1 .EQ. 0) RETURN 
+      DO 110 K1=1,NFM1 
+         IP = FAC(K1+2) 
+         LD = 0 
+         L2 = L1*IP 
+         IDO = N/L2 
+         IPM = IP-1 
+         DO 109 J=1,IPM 
+            LD = LD+L1 
+            I = IS 
+            ARGLD = FLOAT(LD)*ARGH 
+            FI = 0. 
+            DO 108 II=3,IDO,2 
+               I = I+2 
+               FI = FI+1. 
+               ARG = FI*ARGLD 
+               WA(I-1) = DCOS(ARG) 
+               WA(I) = DSIN(ARG) 
+  108       CONTINUE 
+            IS = IS+IDO 
+  109    CONTINUE 
+         L1 = L2 
+  110 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftmb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftmb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftmb.F	(revision 17)
@@ -0,0 +1,37 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: rfftmb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE RFFTMB (LOT, JUMP, N, INC, R, LENR, WSAVE, LENSAV,     &
+     &                  WORK, LENWRK, IER)                              
+      INTEGER  LOT, JUMP, N, INC, LENR, LENSAV, LENWRK, IER 
+      REAL     R(LENR), WSAVE(LENSAV)     ,WORK(LENWRK) 
+      LOGICAL  XERCON 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENR .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('RFFTMB ', 6) 
+      ELSEIF (LENSAV .LT. N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('RFFTMB ', 8) 
+      ELSEIF (LENWRK .LT. LOT*N) THEN 
+        IER = 3 
+        CALL XERFFT ('RFFTMB ', 10) 
+      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
+        IER = 4 
+        CALL XERFFT ('RFFTMB ', -1) 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+!                                                                       
+      CALL MRFTB1 (LOT,JUMP,N,INC,R,WORK,WSAVE,WSAVE(N+1)) 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftmf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftmf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftmf.F	(revision 17)
@@ -0,0 +1,37 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: rfftmf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE RFFTMF (LOT, JUMP, N, INC, R, LENR, WSAVE, LENSAV,     &
+     &                  WORK, LENWRK, IER)                              
+      INTEGER  LOT, JUMP, N, INC, LENR, LENSAV, LENWRK, IER 
+      REAL     R(LENR), WSAVE(LENSAV), WORK(LENWRK) 
+      LOGICAL  XERCON 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENR .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('RFFTMF ', 6) 
+      ELSEIF (LENSAV .LT. N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('RFFTMF ', 8) 
+      ELSEIF (LENWRK .LT. LOT*N) THEN 
+        IER = 3 
+        CALL XERFFT ('RFFTMF ', 10) 
+      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
+        IER = 4 
+        CALL XERFFT ('RFFTMF ', -1) 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+!                                                                       
+      CALL MRFTF1 (LOT,JUMP,N,INC,R,WORK,WSAVE,WSAVE(N+1)) 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftmi.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftmi.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/rfftmi.F	(revision 17)
@@ -0,0 +1,26 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: rfftmi.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE RFFTMI (N, WSAVE, LENSAV, IER) 
+      INTEGER    N, LENSAV, IER 
+      REAL       WSAVE(LENSAV) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENSAV .LT. N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('RFFTMI ', 3) 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+!                                                                       
+      CALL MRFTI1 (N,WSAVE(1),WSAVE(N+1)) 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinq1b.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinq1b.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinq1b.F	(revision 17)
@@ -0,0 +1,49 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sinq1b.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINQ1B ( N, INC, X, LENX, WSAVE, LENSAV,               &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENX .LT. INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('SINQ1B', 6) 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('SINQ1B', 8) 
+      ELSEIF (LENWRK .LT. N) THEN 
+        IER = 3 
+        CALL XERFFT ('SINQ1B', 10) 
+      ENDIF 
+!                                                                       
+      IF (N .GT. 1) GO TO 101 
+      X(1,1) = 4.*X(1,1) 
+      RETURN 
+  101 NS2 = N/2 
+      DO 102 K=2,N,2 
+         X(1,K) = -X(1,K) 
+  102 END DO 
+      CALL COSQ1B (N,INC,X,LENX,WSAVE,LENSAV,WORK,LENWRK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINQ1B',-5) 
+        GO TO 300 
+      ENDIF 
+      DO 103 K=1,NS2 
+         KC = N-K 
+         XHOLD = X(1,K) 
+         X(1,K) = X(1,KC+1) 
+         X(1,KC+1) = XHOLD 
+  103 END DO 
+  300 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinq1f.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinq1f.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinq1f.F	(revision 17)
@@ -0,0 +1,50 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sinq1f.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINQ1F ( N, INC, X, LENX, WSAVE, LENSAV,               &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENX .LT. INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('SINQ1F', 6) 
+        GO TO 300 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('SINQ1F', 8) 
+        GO TO 300 
+      ELSEIF (LENWRK .LT. N) THEN 
+        IER = 3 
+        CALL XERFFT ('SINQ1F', 10) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+      NS2 = N/2 
+      DO 101 K=1,NS2 
+         KC = N-K 
+         XHOLD = X(1,K) 
+         X(1,K) = X(1,KC+1) 
+         X(1,KC+1) = XHOLD 
+  101 END DO 
+      CALL COSQ1F (N,INC,X,LENX,WSAVE,LENSAV,WORK,LENWRK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINQ1F',-5) 
+        GO TO 300 
+      ENDIF 
+      DO 102 K=2,N,2 
+         X(1,K) = -X(1,K) 
+  102 END DO 
+  300 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinq1i.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinq1i.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinq1i.F	(revision 17)
@@ -0,0 +1,29 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sinq1i.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINQ1I (N, WSAVE, LENSAV, IER) 
+      INTEGER    N, LENSAV, IER 
+      REAL       WSAVE(LENSAV) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('SINQ1I', 3) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      CALL COSQ1I (N, WSAVE, LENSAV, IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINQ1I',-5) 
+      ENDIF 
+  300 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinqmb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinqmb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinqmb.F	(revision 17)
@@ -0,0 +1,61 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sinqmb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINQMB (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+      LOGICAL    XERCON 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('SINQMB', 6) 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('SINQMB', 8) 
+      ELSEIF (LENWRK .LT. LOT*N) THEN 
+        IER = 3 
+        CALL XERFFT ('SINQMB', 10) 
+      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
+        IER = 4 
+        CALL XERFFT ('SINQMB', -1) 
+      ENDIF 
+!                                                                       
+      LJ = (LOT-1)*JUMP+1 
+      IF (N .GT. 1) GO TO 101 
+      DO 201 M=1,LJ,JUMP 
+         X(M,1) = 4.*X(M,1) 
+  201 END DO 
+      RETURN 
+  101 NS2 = N/2 
+      DO 102 K=2,N,2 
+         DO 202 M=1,LJ,JUMP 
+         X(M,K) = -X(M,K) 
+  202    CONTINUE 
+  102 END DO 
+      CALL COSQMB (LOT,JUMP,N,INC,X,LENX,WSAVE,LENSAV,WORK,LENWRK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINQMB',-5) 
+        GO TO 300 
+      ENDIF 
+      DO 103 K=1,NS2 
+         KC = N-K 
+         DO 203 M=1,LJ,JUMP 
+         XHOLD = X(M,K) 
+         X(M,K) = X(M,KC+1) 
+         X(M,KC+1) = XHOLD 
+  203    CONTINUE 
+  103 END DO 
+  300 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinqmf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinqmf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinqmf.F	(revision 17)
@@ -0,0 +1,61 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sinqmf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINQMF (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+      LOGICAL    XERCON 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('SINQMF', 6) 
+        GO TO 300 
+      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('SINQMF', 8) 
+        GO TO 300 
+      ELSEIF (LENWRK .LT. LOT*N) THEN 
+        IER = 3 
+        CALL XERFFT ('SINQMF', 10) 
+        GO TO 300 
+      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
+        IER = 4 
+        CALL XERFFT ('SINQMF', -1) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      IF (N .EQ. 1) RETURN 
+      NS2 = N/2 
+      LJ = (LOT-1)*JUMP+1 
+      DO 101 K=1,NS2 
+         KC = N-K 
+         DO 201 M=1,LJ,JUMP 
+         XHOLD = X(M,K) 
+         X(M,K) = X(M,KC+1) 
+         X(M,KC+1) = XHOLD 
+  201    CONTINUE 
+  101 END DO 
+      CALL COSQMF (LOT,JUMP,N,INC,X,LENX,WSAVE,LENSAV,WORK,LENWRK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINQMF',-5) 
+        GO TO 300 
+      ENDIF 
+      DO 102 K=2,N,2 
+         DO 202 M=1,LJ,JUMP 
+         X(M,K) = -X(M,K) 
+  202    CONTINUE 
+  102 END DO 
+  300 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinqmi.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinqmi.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sinqmi.F	(revision 17)
@@ -0,0 +1,30 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sinqmi.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINQMI (N, WSAVE, LENSAV, IER) 
+      INTEGER    N, LENSAV, IER 
+      REAL       WSAVE(LENSAV) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('SINQMI', 3) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      CALL COSQMI (N, WSAVE, LENSAV, IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINQMI',-5) 
+      ENDIF 
+  300 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sint1b.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sint1b.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sint1b.F	(revision 17)
@@ -0,0 +1,40 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sint1b.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINT1B ( N, INC, X, LENX, WSAVE, LENSAV,               &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENX .LT. INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('SINT1B', 6) 
+        GO TO 100 
+      ELSEIF (LENSAV .LT. N/2 + N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('SINT1B', 8) 
+        GO TO 100 
+      ELSEIF (LENWRK .LT. (2*N+2)) THEN 
+        IER = 3 
+        CALL XERFFT ('SINT1B', 10) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+      CALL SINTB1(N,INC,X,WSAVE,WORK,WORK(N+2),IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINT1B',-5) 
+      ENDIF 
+!                                                                       
+  100 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sint1f.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sint1f.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sint1f.F	(revision 17)
@@ -0,0 +1,38 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sint1f.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINT1F ( N, INC, X, LENX, WSAVE, LENSAV,               &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+!                                                                       
+      IER = 0 
+      IF (LENX .LT. INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('SINT1F', 6) 
+        GO TO 100 
+      ELSEIF (LENSAV .LT. N/2 + N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('SINT1F', 8) 
+        GO TO 100 
+      ELSEIF (LENWRK .LT. (2*N+2)) THEN 
+        IER = 3 
+        CALL XERFFT ('SINT1F', 10) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+      CALL SINTF1(N,INC,X,WSAVE,WORK,WORK(N+2),IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINT1F',-5) 
+      ENDIF 
+  100 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sint1i.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sint1i.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sint1i.F	(revision 17)
@@ -0,0 +1,40 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sint1i.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINT1I (N, WSAVE, LENSAV, IER) 
+      INTEGER    N, LENSAV, IER 
+      REAL       WSAVE(LENSAV) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENSAV .LT. N/2 + N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('SINT1I', 3) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      PI = 4.*ATAN(1.) 
+      IF (N .LE. 1) RETURN 
+      NS2 = N/2 
+      NP1 = N+1 
+      DT = PI/FLOAT(NP1) 
+      DO 101 K=1,NS2 
+         WSAVE(K) = 2.*SIN(K*DT) 
+  101 END DO 
+      LNSV = NP1 + INT(LOG(REAL(NP1))) +4 
+      CALL RFFT1I (NP1, WSAVE(NS2+1), LNSV, IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINT1I',-5) 
+      ENDIF 
+!                                                                       
+  300 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintb1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintb1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintb1.F	(revision 17)
@@ -0,0 +1,60 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sintb1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINTB1(N,INC,X,WSAVE,XH,WORK,IER) 
+      REAL       X(INC,*)       ,WSAVE(*)   ,XH(*) 
+      DOUBLE PRECISION           DSUM 
+      IER = 0 
+      IF (N-2) 200,102,103 
+  102 SRT3S2 = SQRT(3.)/2. 
+      XHOLD = SRT3S2*(X(1,1)+X(1,2)) 
+      X(1,2) = SRT3S2*(X(1,1)-X(1,2)) 
+      X(1,1) = XHOLD 
+      GO TO 200 
+  103 NP1 = N+1 
+      NS2 = N/2 
+      DO 104 K=1,NS2 
+         KC = NP1-K 
+         T1 = X(1,K)-X(1,KC) 
+         T2 = WSAVE(K)*(X(1,K)+X(1,KC)) 
+         XH(K+1) = T1+T2 
+         XH(KC+1) = T2-T1 
+  104 END DO 
+      MODN = MOD(N,2) 
+      IF (MODN .EQ. 0) GO TO 124 
+      XH(NS2+2) = 4.*X(1,NS2+1) 
+  124 XH(1) = 0. 
+      LNXH = NP1 
+      LNSV = NP1 + INT(LOG(REAL(NP1))) + 4 
+      LNWK = NP1 
+!                                                                       
+      CALL RFFT1F(NP1,1,XH,LNXH,WSAVE(NS2+1),LNSV,WORK,LNWK,IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINTB1',-5) 
+        GO TO 200 
+      ENDIF 
+!                                                                       
+      IF(MOD(NP1,2) .NE. 0) GO TO 30 
+      XH(NP1) = XH(NP1)+XH(NP1) 
+   30 FNP1S4 = FLOAT(NP1)/4. 
+         X(1,1) = FNP1S4*XH(1) 
+         DSUM = X(1,1) 
+      DO 105 I=3,N,2 
+            X(1,I-1) = FNP1S4*XH(I) 
+            DSUM = DSUM+FNP1S4*XH(I-1) 
+            X(1,I) = DSUM 
+  105 END DO 
+      IF (MODN .NE. 0) GO TO 200 
+         X(1,N) = FNP1S4*XH(N+1) 
+!                                                                       
+  200 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintf1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintf1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintf1.F	(revision 17)
@@ -0,0 +1,59 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sintf1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINTF1(N,INC,X,WSAVE,XH,WORK,IER) 
+      REAL       X(INC,*)       ,WSAVE(*)   ,XH(*) 
+      DOUBLE PRECISION           DSUM 
+      IER = 0 
+      IF (N-2) 200,102,103 
+  102 SSQRT3 = 1./SQRT(3.) 
+      XHOLD = SSQRT3*(X(1,1)+X(1,2)) 
+      X(1,2) = SSQRT3*(X(1,1)-X(1,2)) 
+      X(1,1) = XHOLD 
+      GO TO 200 
+  103 NP1 = N+1 
+      NS2 = N/2 
+      DO 104 K=1,NS2 
+         KC = NP1-K 
+         T1 = X(1,K)-X(1,KC) 
+         T2 = WSAVE(K)*(X(1,K)+X(1,KC)) 
+         XH(K+1) = T1+T2 
+         XH(KC+1) = T2-T1 
+  104 END DO 
+      MODN = MOD(N,2) 
+      IF (MODN .EQ. 0) GO TO 124 
+      XH(NS2+2) = 4.*X(1,NS2+1) 
+  124 XH(1) = 0. 
+      LNXH = NP1 
+      LNSV = NP1 + INT(LOG(REAL(NP1))) + 4 
+      LNWK = NP1 
+!                                                                       
+      CALL RFFT1F(NP1,1,XH,LNXH,WSAVE(NS2+1),LNSV,WORK,                 &
+     &            LNWK,IER1)                                            
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINTF1',-5) 
+        GO TO 200 
+      ENDIF 
+!                                                                       
+      IF(MOD(NP1,2) .NE. 0) GO TO 30 
+      XH(NP1) = XH(NP1)+XH(NP1) 
+   30 SFNP1 = 1./FLOAT(NP1) 
+         X(1,1) = .5*XH(1) 
+         DSUM = X(1,1) 
+      DO 105 I=3,N,2 
+            X(1,I-1) = .5*XH(I) 
+            DSUM = DSUM+.5*XH(I-1) 
+            X(1,I) = DSUM 
+  105 END DO 
+      IF (MODN .NE. 0) GO TO 200 
+      X(1,N) = .5*XH(N+1) 
+  200 RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintmb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintmb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintmb.F	(revision 17)
@@ -0,0 +1,47 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sintmb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINTMB (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+      LOGICAL    XERCON 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('SINTMB', 6) 
+        GO TO 100 
+      ELSEIF (LENSAV .LT. N/2 + N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('SINTMB', 8) 
+        GO TO 100 
+      ELSEIF (LENWRK .LT. LOT*(2*N+4)) THEN 
+        IER = 3 
+        CALL XERFFT ('SINTMB', 10) 
+        GO TO 100 
+      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
+        IER = 4 
+        CALL XERFFT ('SINTMB', -1) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+      IW1 = LOT+LOT+1 
+      IW2 = IW1+LOT*(N+1) 
+      CALL MSNTB1(LOT,JUMP,N,INC,X,WSAVE,WORK,WORK(IW1),WORK(IW2),IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINTMB',-5) 
+      ENDIF 
+!                                                                       
+  100 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintmf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintmf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintmf.F	(revision 17)
@@ -0,0 +1,46 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sintmf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINTMF (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
+     &                   WORK, LENWRK, IER)                             
+      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
+      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
+      LOGICAL    XERCON 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
+        IER = 1 
+        CALL XERFFT ('SINTMF', 6) 
+        GO TO 100 
+      ELSEIF (LENSAV .LT. N/2 + N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('SINTMF', 8) 
+        GO TO 100 
+      ELSEIF (LENWRK .LT. LOT*(2*N+4)) THEN 
+        IER = 3 
+        CALL XERFFT ('SINTMF', 10) 
+        GO TO 100 
+      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
+        IER = 4 
+        CALL XERFFT ('SINTMF', -1) 
+        GO TO 100 
+      ENDIF 
+!                                                                       
+      IW1 = LOT+LOT+1 
+      IW2 = IW1+LOT*(N+1) 
+      CALL MSNTF1(LOT,JUMP,N,INC,X,WSAVE,WORK,WORK(IW1),WORK(IW2),IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINTMF',-5) 
+      ENDIF 
+  100 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintmi.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintmi.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/sintmi.F	(revision 17)
@@ -0,0 +1,40 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: sintmi.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE SINTMI (N, WSAVE, LENSAV, IER) 
+      INTEGER    N, LENSAV, IER 
+      REAL       WSAVE(LENSAV) 
+!                                                                       
+      IER = 0 
+!                                                                       
+      IF (LENSAV .LT. N/2 + N + INT(LOG(REAL(N))) +4) THEN 
+        IER = 2 
+        CALL XERFFT ('SINTMI', 3) 
+        GO TO 300 
+      ENDIF 
+!                                                                       
+      PI = 4.*ATAN(1.) 
+      IF (N .LE. 1) RETURN 
+      NS2 = N/2 
+      NP1 = N+1 
+      DT = PI/FLOAT(NP1) 
+      DO 101 K=1,NS2 
+         WSAVE(K) = 2.*SIN(K*DT) 
+  101 END DO 
+      LNSV = NP1 + INT(LOG(REAL(NP1))) +4 
+      CALL RFFTMI (NP1, WSAVE(NS2+1), LNSV, IER1) 
+      IF (IER1 .NE. 0) THEN 
+        IER = 20 
+        CALL XERFFT ('SINTMI',-5) 
+      ENDIF 
+!                                                                       
+  300 CONTINUE 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/tables.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/tables.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/tables.F	(revision 17)
@@ -0,0 +1,30 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: tables.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE TABLES (IDO,IP,WA) 
+      REAL  WA(IDO,IP-1,2) 
+!                                                                       
+      TPI = 8.*ATAN(1.) 
+      ARGZ = TPI/REAL(IP) 
+      ARG1 = TPI/REAL(IDO*IP) 
+      DO 110 J=2,IP 
+         ARG2 = REAL(J-1)*ARG1 
+         DO 100 I=1,IDO 
+            ARG3 = REAL(I-1)*ARG2 
+            WA(I,J-1,1) = COS(ARG3) 
+            WA(I,J-1,2) = SIN(ARG3) 
+  100    CONTINUE 
+         IF (IP .LE. 5) GO TO 110 
+         ARG4 = REAL(J-1)*ARGZ 
+         WA(1,J-1,1) = COS(ARG4) 
+         WA(1,J-1,2) = SIN(ARG4) 
+  110 END DO 
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/xercon.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/xercon.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/xercon.F	(revision 17)
@@ -0,0 +1,54 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: xercon.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      LOGICAL FUNCTION XERCON (INC,JUMP,N,LOT) 
+      INTEGER INC, JUMP, N, LOT 
+      INTEGER I, J, JNEW, LCM 
+!                                                                       
+!     Definition: positive integers INC, JUMP, N and LOT are consistent 
+!                                                            ---------- 
+!     if I1*INC + J1*JUMP = I2*INC + J2*JUMP for I1,I2 < N and J1,J2    
+!     < LOT implies I1=I2 and J1=J2.                                    
+!                                                                       
+!     For multiple FFTs to execute correctly, input parameters INC,     
+!     JUMP, N and LOT must be consistent ... otherwise at least one     
+!     array element mistakenly is transformed more than once.           
+!                                                                       
+!     XERCON = .TRUE. if and only if INC, JUMP, N and LOT are           
+!     consistent.                                                       
+!                                                                       
+!     ------------------------------------------------------------------
+!                                                                       
+!     Compute I = greatest common divisor (INC, JUMP)                   
+!                                                                       
+      I = INC 
+      J = JUMP 
+   10 CONTINUE 
+      IF (J .NE. 0) THEN 
+        JNEW = MOD(I,J) 
+        I    = J 
+        J    = JNEW 
+        GO TO 10 
+      ENDIF 
+!                                                                       
+! Compute LCM = least common multiple (INC, JUMP)                       
+!                                                                       
+      LCM = (INC*JUMP)/I 
+!                                                                       
+! Check consistency of INC, JUMP, N, LOT                                
+!                                                                       
+      IF (LCM .LE. (N-1)*INC .AND. LCM .LE. (LOT-1)*JUMP) THEN 
+        XERCON = .FALSE. 
+      ELSE 
+        XERCON = .TRUE. 
+      ENDIF 
+!                                                                       
+      RETURN 
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/xerfft.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/xerfft.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/fftpack/fftpack5/xerfft.F	(revision 17)
@@ -0,0 +1,70 @@
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!                                                                       
+!   FFTPACK 5.0                                                         
+!                                                                       
+!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
+!                                                                       
+!   $Id: xerfft.f,v 1.3 2004/07/06 00:58:41 rodney Exp $                
+!                                                                       
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+                                                                        
+      SUBROUTINE XERFFT( SRNAME, INFO) 
+!                                                                       
+!     .. Scalar Arguments ..                                            
+      CHARACTER*6        SRNAME 
+      INTEGER            INFO 
+!                                                                       
+!     ..                                                                
+!                                                                       
+!  Purpose                                                              
+!  =======                                                              
+!                                                                       
+!  XERFFT  is an error handler for library FFTPACK version 5.0 routines.
+!  It is called by an FFTPACK 5.0 routine if an input parameter has an  
+!  invalid value.  A message is printed and execution stops.            
+!                                                                       
+!  Installers may consider modifying the STOP statement in order to     
+!  call system-specific exception-handling facilities.                  
+!                                                                       
+!  Arguments                                                            
+!  =========                                                            
+!                                                                       
+!  SRNAME  (input) CHARACTER*6                                          
+!          The name of the routine which called XERFFT.                 
+!                                                                       
+!  INFO    (input) INTEGER                                              
+!          When a single  invalid parameter in the parameter list of    
+!          the calling routine has been detected, INFO is the position  
+!          of that parameter.  In the case when an illegal combination  
+!          of LOT, JUMP, N, and INC has been detected, the calling      
+!          subprogram calls XERFFT with INFO = -1.                      
+!                                                                       
+! ===================================================================== 
+!                                                                       
+!     .. Executable Statements ..                                       
+!                                                                       
+      IF (INFO .GE. 1) THEN 
+        WRITE( *, '(A,A,A,I3,A)') ' ** On entry to ', SRNAME,           &
+     &    ' parameter number ', INFO, ' had an illegal value'           
+      ELSEIF (INFO .EQ. -1) THEN 
+        WRITE( *, '(A,A,A,A)') ' ** On entry to ', SRNAME,              &
+     &    ' parameters LOT, JUMP, N and INC are inconsistent'           
+      ELSEIF (INFO .EQ. -2) THEN 
+        WRITE( *, '(A,A,A,A)') ' ** On entry to ', SRNAME,              &
+     &    ' parameter L is greater than LDIM'                           
+      ELSEIF (INFO .EQ. -3) THEN 
+        WRITE( *, '(A,A,A,A)') ' ** On entry to ', SRNAME,              &
+     &    ' parameter M is greater than MDIM'                           
+      ELSEIF (INFO .EQ. -5) THEN 
+        WRITE( *, '(A,A,A,A)') ' ** Within ', SRNAME,                   &
+     &    ' input error returned by lower level routine'                
+      ELSEIF (INFO .EQ. -6) THEN 
+        WRITE( *, '(A,A,A,A)') ' ** On entry to ', SRNAME,              &
+     &    ' parameter LDIM is less than 2*(L/2+1)'                      
+      ENDIF 
+!                                                                       
+      STOP 
+!                                                                       
+!     End of XERFFT                                                     
+!                                                                       
+      END                                           
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/README.io_esmf
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/README.io_esmf	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/README.io_esmf	(revision 17)
@@ -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.  
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/TODO.list
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/TODO.list	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/TODO.list	(revision 17)
@@ -0,0 +1,141 @@
+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:
+   - Modify 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.  
+   X Get rid of masses of "DEBUG" code.  
+   X Clean up/correct comments.  
+   X 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.  
+   X Finish sequence diagram for the coupling interactions in
+     /users/hender/Tasks/WRF_ESMF/SequenceDiagram.txt ...
+     X 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...  
+     Better yet, move to ESMF 3.0 and use its new features to correctly 
+     implement staggering.  
+   - 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.
+   X 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_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/.  
+     * 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
+     X 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
+     X Sequence diagram of component interactions (see ppt)
+     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).  
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/ext_esmf_open_for_read.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/ext_esmf_open_for_read.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/ext_esmf_open_for_read.F90	(revision 17)
@@ -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.
+!TODO:  Eventually, use nested states to allow more than one auxinput stream 
+!TODO:  to be supported via ESMF.  
+!TODO:  Eventually, get smart about interacting with "needed" and "optional" 
+!TODO:  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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/ext_esmf_open_for_write.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/ext_esmf_open_for_write.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/ext_esmf_open_for_write.F90	(revision 17)
@@ -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.
+!TODO:  Eventually, use nested states to allow more than one auxhist stream 
+!TODO:  to be supported via ESMF.  
+!TODO:  Eventually, get smart about interacting with "needed" and "optional" 
+!TODO:  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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/ext_esmf_read_field.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/ext_esmf_read_field.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/ext_esmf_read_field.F90	(revision 17)
@@ -0,0 +1,334 @@
+
+!TODO:  remove duplication between ext_esmf_read_field and 
+!TODO:  ext_esmf_write_field
+
+!TODO:  how to deal with time?  (via current ESMF_Clock)
+!TODO:  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
+  INTEGER :: esmf_kind
+  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, debug_level
+  LOGICAL, EXTERNAL :: has_char
+  character*256 mess
+
+  CALL get_wrf_debug_level( debug_level )
+
+  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_kind = ESMF_KIND_R4
+  ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
+!    esmf_kind = ESMF_KIND_R8
+    CALL wrf_error_fatal( 'ext_esmf_read_field, WRF_DOUBLE not yet supported')
+  ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+    esmf_kind = ESMF_KIND_I4
+!TODO:  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...  
+!TODO:  Eventually, use ../io_netcdf subroutines Transpose() and reorder() 
+!TODO:  (and etc.) to handle general array ranks and index orderings.  
+!TODO:  Some copies of these exist in ../../frame/module_io.F.  
+!TODO:  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.
+!TODO:  Remove EndFull hackery once ESMF can support staggered 
+!TODO:  grids in regional models.  (This hack works around the current 
+!TODO:  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
+write(0,*)__FILE__,__LINE__,'ext_esmf_read_field Stagger',TRIM(Stagger)
+write(0,*)__FILE__,__LINE__,'ext_esmf_read_field VarName',TRIM(VarName)
+write(0,*)__FILE__,__LINE__,'ext_esmf_read_field DomainEnd ', DomainEnd(1:esmf_rank)
+write(0,*)__FILE__,__LINE__,'ext_esmf_read_field PatchEnd  ', PatchEnd(1:esmf_rank)
+    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.  
+
+    ! 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.  
+!TODO:  Once ESMF can match WRF memory-patch mapping, replace this with a more 
+!TODO:  efficient solution that does not require a copy.  
+!TODO:  esmf_counts is redundant.  Remove it as soon as ESMF_ArrayCreate no 
+!TODO:  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.  
+    ! Note:  unique Field name is required by ESMF_StateAddField().  
+!TODO:  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
+!TODO:  Compute horzrelloc from Stagger as above once ESMF supports staggering
+!    horzrelloc=ESMF_CELL_CENTER
+!TODO:  Add code for other data types here...  
+!    ALLOCATE( tmp_esmf_r4_ptr(ips:ipefull,jps:jpefull) )
+    ALLOCATE( tmp_esmf_r4_ptr(ips:ipe,jps:jpe) )
+    write(mess,*)'ext_esmf_read_field: calling ESMF_FieldCreate field=',trim(varname)
+    CALL wrf_debug ( 100, mess )
+
+    tmpField = ESMF_FieldCreate(         &
+                 grid( DataHandle )%ptr, &
+                 tmp_esmf_r4_ptr,        &
+                 copyflag=ESMF_DATA_REF, &
+                 staggerloc=ESMF_STAGGERLOC_CENTER,    &
+                 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...  
+!TODO:  for now, just build ESMF_Fields and stuff them in
+!TODO:  later, use a single ESMF_Bundle
+    CALL ESMF_StateAdd( 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) )
+
+    ! 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_StateGet( importstate, itemName=TRIM(VarName), &
+                             field=tmpfield, rc=rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      CALL wrf_error_fatal("ext_esmf_read_field:  ESMF_StateGet failed" )
+    ENDIF
+
+CALL wrf_debug ( 100, 'ext_esmf_read_field '//TRIM(VarName)//':  calling ESMF_FieldPrint( tmpField ) 1' )
+IF ( 100 .LE. debug_level ) THEN
+  CALL ESMF_FieldPrint( tmpField, rc=rc )
+ENDIF
+CALL wrf_debug ( 100, 'ext_esmf_read_field '//TRIM(VarName)//':  back from ESMF_FieldPrint( tmpField ) 1' )
+
+    ! grab a pointer to the import state data and copy data into Field
+    IF      ( FieldType .EQ. WRF_REAL ) THEN
+      CALL ESMF_FieldGet( tmpField, 0, data_esmf_real_ptr, 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. &
+           ( PatchEnd(1) /= UBOUND(data_esmf_real_ptr,1) ) .OR. &
+           ( PatchStart(2)   /= LBOUND(data_esmf_real_ptr,2) ) .OR. &
+           ( PatchEnd(2) /= UBOUND(data_esmf_real_ptr,2) ) ) THEN
+        WRITE( mess,* ) 'ESMF_FieldGetDataPointer bounds mismatch',          &
+          __FILE__ ,                                                         &
+          ', line ',                                                         &
+          __LINE__ ,                                                         &
+          ', ips:ipe,jps:jpe = ',PatchStart(1),':',PatchEnd(1),',',      &
+                                 PatchStart(2),':',PatchEnd(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
+
+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) )
+
+      CALL ioesmf_extract_data_real( data_esmf_real_ptr, Field,            &
+                                     ips, ipe, jps, jpe, kps, kpe, &
+                                     ims, ime, jms, jme, kms, kme )
+    ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+      CALL ESMF_FieldGet( tmpField, 0, data_esmf_int_ptr, 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. &
+           ( PatchEnd(1) /= UBOUND(data_esmf_int_ptr,1) ) .OR. &
+           ( PatchStart(2)   /= LBOUND(data_esmf_int_ptr,2) ) .OR. &
+           ( PatchEnd(2) /= UBOUND(data_esmf_int_ptr,2) ) ) THEN
+        WRITE( mess,* ) 'ESMF_FieldGetDataPointer bounds mismatch',        &
+          __FILE__ ,                                                       &
+          ', line ',                                                       &
+          __LINE__ ,                                                       &
+          ', ips:ipe,jps:jpe = ',PatchStart(1),':',PatchEnd(1),',',    &
+                                 PatchStart(2),':',PatchEnd(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, ipe, jps, jpe, 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
+
+CALL wrf_debug ( 100, 'ext_esmf_read_field '//TRIM(VarName)//':  calling ESMF_FieldPrint( tmpField ) 2' )
+IF ( 100 .LE. debug_level ) THEN
+  CALL ESMF_FieldPrint( tmpField, rc=rc )
+ENDIF
+CALL wrf_debug ( 100, 'ext_esmf_read_field '//TRIM(VarName)//':  back from ESMF_FieldPrint( tmpField ) 2' )
+
+  Status = 0
+
+  RETURN
+
+END SUBROUTINE ext_esmf_read_field
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/ext_esmf_write_field.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/ext_esmf_write_field.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/ext_esmf_write_field.F90	(revision 17)
@@ -0,0 +1,334 @@
+
+
+!TODO:  remove duplication between ext_esmf_read_field and 
+!TODO:  ext_esmf_write_field
+
+!TODO:  how to deal with time?  (via current ESMF_Clock)
+!TODO:  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
+  INTEGER :: esmf_kind
+  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, debug_level
+  LOGICAL, EXTERNAL :: has_char
+  character*256 mess
+
+  CALL get_wrf_debug_level( debug_level )
+
+  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_kind = ESMF_KIND_R4
+  ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
+    CALL wrf_error_fatal( 'ext_esmf_write_field, WRF_DOUBLE not yet supported')
+  ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+    esmf_kind = ESMF_KIND_I4
+!TODO:  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...  
+!TODO:  Eventually, use ../io_netcdf subroutines Transpose() and reorder() 
+!TODO:  (and etc.) to handle general array ranks and index orderings.  
+!TODO:  Some copies of these exist in ../../frame/module_io.F.  
+!TODO:  Then use ESMF_ArrayDataMap class to handle index mapping.  
+  IF ( kms /= kme ) THEN
+    write(mess,*)'ext_esmf_write_field: rank > 2 not yet supported. field = ',TRIM(VarName)
+    CALL wrf_error_fatal( mess )
+  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.
+!TODO:  Remove EndFull hackery once ESMF can support staggered 
+!TODO:  grids in regional models.  (This hack works around the current 
+!TODO:  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
+write(0,*)__FILE__,__LINE__,'ext_esmf_write_field Stagger',TRIM(Stagger)
+write(0,*)__FILE__,__LINE__,'ext_esmf_write_field VarName',TRIM(VarName)
+write(0,*)__FILE__,__LINE__,'ext_esmf_write_field DomainEnd ', DomainEnd(1:esmf_rank)
+write(0,*)__FILE__,__LINE__,'ext_esmf_write_field PatchEnd  ', PatchEnd(1:esmf_rank)
+    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.  
+
+    ! 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.  
+!TODO:  Once ESMF can match WRF memory-patch mapping, replace this with a more 
+!TODO:  efficient solution that does not require a copy.  
+!TODO:  esmf_counts is redundant.  Remove it as soon as ESMF_ArrayCreate no 
+!TODO:  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.  
+    ! Note:  unique Field name is required by ESMF_StateAdd().  
+!TODO:  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
+!TODO:  Compute horzrelloc from Stagger as above once ESMF supports staggering
+!    horzrelloc=ESMF_CELL_CENTER
+!TODO:  Add code for other data types here...  
+!    ALLOCATE( tmp_esmf_r4_ptr(ips:ipefull,jps:jpefull) )
+    ALLOCATE( tmp_esmf_r4_ptr(ips:ipe,jps:jpe) )
+    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, &
+                 staggerloc=ESMF_STAGGERLOC_CENTER,    &
+                 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...  
+!TODO:  for now, just build ESMF_Fields and stuff them in
+!TODO:  later, use a single ESMF_Bundle
+    CALL ESMF_StateAdd( exportstate, tmpField, rc=rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      CALL wrf_error_fatal("ext_esmf_write_field:  ESMF_StateAddfailed" )
+    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) )
+
+    ! 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_StateGet( exportstate, itemName=TRIM(VarName), &
+                             field=tmpfield, rc=rc )
+    IF ( rc /= ESMF_SUCCESS ) THEN
+      CALL wrf_error_fatal("ext_esmf_write_field:  ESMF_StateGetfailed" )
+    ENDIF
+
+CALL wrf_debug ( 100, 'ext_esmf_write_field '//TRIM(VarName)//':  calling ESMF_FieldPrint( tmpField ) 1' )
+IF ( 100 .LE. debug_level ) THEN
+  CALL ESMF_FieldPrint( tmpField, rc=rc )
+ENDIF
+CALL wrf_debug ( 100, 'ext_esmf_write_field '//TRIM(VarName)//':  back from ESMF_FieldPrint( tmpField ) 1' )
+
+    ! grab a pointer to the export state data and copy data from Field
+    IF      ( FieldType .EQ. WRF_REAL ) THEN
+      CALL ESMF_FieldGet( tmpField, 0, data_esmf_real_ptr, 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. &
+           ( PatchEnd(1) /= UBOUND(data_esmf_real_ptr,1) ) .OR. &
+           ( PatchStart(2)   /= LBOUND(data_esmf_real_ptr,2) ) .OR. &
+           ( PatchEnd(2) /= UBOUND(data_esmf_real_ptr,2) ) ) THEN
+        WRITE( mess,* ) 'ESMF_FieldGetDataPointer bounds mismatch',          &
+          __FILE__ ,                                                         &
+          ', line ',                                                         &
+          __LINE__ ,                                                         &
+          ', ips:ipe,jps:jpe = ',PatchStart(1),':',PatchEnd(1),',',      &
+                                 PatchStart(2),':',PatchEnd(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
+
+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) )
+
+      CALL ioesmf_insert_data_real( Field, data_esmf_real_ptr,            &
+                                    ips, ipe, jps, jpe, kps, kpe, &
+                                    ims, ime, jms, jme, kms, kme )
+    ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+      CALL ESMF_FieldGet( tmpField, 0, data_esmf_int_ptr, 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. &
+           ( PatchEnd(1) /= UBOUND(data_esmf_int_ptr,1) ) .OR. &
+           ( PatchStart(2)   /= LBOUND(data_esmf_int_ptr,2) ) .OR. &
+           ( PatchEnd(2) /= UBOUND(data_esmf_int_ptr,2) ) ) THEN
+        WRITE( mess,* ) 'ESMF_FieldGetDataPointer bounds mismatch',        &
+          __FILE__ ,                                                       &
+          ', line ',                                                       &
+          __LINE__ ,                                                       &
+          ', ips:ipe,jps:jpe = ',PatchStart(1),':',PatchEnd(1),',',    &
+                                 PatchStart(2),':',PatchEnd(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, ipe, jps, jpe, 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
+
+CALL wrf_debug ( 100, 'ext_esmf_write_field '//TRIM(VarName)//':  calling ESMF_FieldPrint( tmpField ) 2' )
+IF ( 100 .LE. debug_level ) THEN
+  CALL ESMF_FieldPrint( tmpField, rc=rc )
+ENDIF
+CALL wrf_debug ( 100, 'ext_esmf_write_field '//TRIM(VarName)//':  back from ESMF_FieldPrint( tmpField ) 2' )
+
+  Status = 0
+
+  RETURN
+
+END SUBROUTINE ext_esmf_write_field
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/io_esmf.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/io_esmf.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/io_esmf.F90	(revision 17)
@@ -0,0 +1,1851 @@
+
+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
+
+!TODO:  encapsulate this state into a class...  
+  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.  
+  !TODO:  remove this hackery once ESMF can support staggered 
+  !TODO:  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.  
+  !TODO:  Note that periodicity is not supported by this interface.  If 
+  !TODO:  periodicity is needed, pass in via SysDepInfo in the call to 
+  !TODO:  ext_esmf_ioinit().  
+  !TODO:  Note that lat/lon coordinates are not supported by this interface 
+  !TODO:  since general curvilinear coordindates (needed for map projections 
+  !TODO:  used by WRF such as polar stereographic, mercator, lambert conformal)
+  !TODO:  are not supported by ESMF as of ESMF 2.1.1.  Once they are supported, 
+  !TODO:  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
+!TODO:  Note that this approach will result in duplicate ESMF_Grids when 
+!TODO:  io_esmf is used for input and output.  The first ESMF_Grid will 
+!TODO:  be associated with the input handle and the second will be associated 
+!TODO:  with the output handle.  Fix this if ESMF_Grids are expensive.  
+    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.  
+        !TODO:  remove this hackery once ESMF can support staggered 
+        !TODO:  grids in regional models
+        CALL ioesmf_endfullhack( numdims, DomainEnd, PatchEnd, Stagger, &
+                                 DomainEndFull, PatchEndFull )
+!TODO:  at the moment this is hard-coded for 2D arrays
+!TODO:  use MemoryOrder to set these properly!
+!TODO:  also, set these once only
+!TODO:  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, &
+!                              DomainStart, DomainEnd, &
+                              MemoryStart, MemoryEnd,     &
+!                              PatchStart, PatchEndFull )
+                              PatchStart, PatchEnd )
+        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.  
+  !TODO:  Note that periodicity is not supported by this interface.  If 
+  !TODO:  periodicity is needed, pass in via SysDepInfo in the call to 
+  !TODO:  ext_esmf_ioinit().  
+  !TODO:  Note that lat/lon coordinates are not supported by this interface 
+  !TODO:  since general curvilinear coordindates (needed for map projections 
+  !TODO:  used by WRF such as polar stereographic, mercator, lambert conformal)
+  !TODO:  are not supported by ESMF as of ESMF 2.1.1.  Once they are supported, 
+  !TODO:  add them via the "sieve" method used in ../io_mcel/.  
+  !TODO:  Note that DomainEnd and PatchEnd must currently include "extra" 
+  !TODO:  points for non-periodic staggered arrays.  It may be possible to 
+  !TODO:  remove this hackery once ESMF can support staggered 
+  !TODO:  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, debug_level
+    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
+    REAL(ESMF_KIND_R8), DIMENSION(:), POINTER :: coordX2d, coordY2d
+    INTEGER, DIMENSION(3) :: ubnd, lbnd
+    CHARACTER (32) :: gridname
+    INTEGER, SAVE :: gridID = 0
+
+      CALL get_wrf_debug_level( debug_level )
+
+      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
+!TODO:  Note (PET==MPI process) assumption here.  This is OK in ESMF 
+!TODO:  2.2.0 but may change in a future ESMF release.  If so, we will 
+!TODO:  need another way to do this.  May want to grab mpiCommunicator 
+!TODO:  instead and ask it directly for number of MPI tasks.  Unless this 
+!TODO:  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
+          numprocsY = numprocsY + 1
+        ENDIF
+        IF ( PatchStart(2) == jpatchStarts(pe) ) THEN
+          numprocsX = numprocsX + 1
+        ENDIF
+      ENDDO
+      DEALLOCATE( ipatchStarts, jpatchStarts )
+WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int:  numprocsX = ',numprocsX
+CALL wrf_debug ( 5 , TRIM(msg) )
+WRITE( msg,* ) 'DEBUG ioesmf_create_grid_int:  numprocsY = ',numprocsY
+CALL wrf_debug ( 5 , TRIM(msg) )
+      ! sanity check
+      IF ( numprocs /= numprocsX*numprocsY ) THEN
+        CALL wrf_error_fatal ( 'ASSERTION FAILED:  numprocs /= numprocsX*numprocsY' )
+      ENDIF
+      ! Next, create ESMF_DELayout
+      numprocsXY = (/ numprocsX, numprocsY /)
+!TODO:  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
+! NOTE:  seems to work both ways...  
+! (/ 0 2 1 3 /)
+!        permuteTasks(pe) = (i*numprocsY) + j
+! (/ 0 1 2 3 /)
+        permuteTasks(pe) = pe
+        pe = pe + 1
+        ENDDO
+      ENDDO
+      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 )
+
+      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  calling ESMF_DELayoutPrint 1' )
+      IF ( 5 .LE. debug_level ) THEN
+        CALL ESMF_DELayoutPrint( taskLayout, rc=rc )
+      ENDIF
+      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  back from ESMF_DELayoutPrint 1' )
+
+! Compute the dimensions for the ESMF grid, using WRF's non-staggered dimensions
+! This is as of ESMF v3, JM 20080715
+
+      ! 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); 
+write(0,*)__FILE__,__LINE__,'DomainStart ',DomainStart(1:2)
+write(0,*)__FILE__,__LINE__,'DomainEnd   ',DomainEnd(1:2)
+write(0,*)__FILE__,__LINE__,'PatchStart ',PatchStart(1:2)
+write(0,*)__FILE__,__LINE__,'PatchEnd   ',PatchEnd(1:2)
+      globalXcount = ide - ids  ! in other words, the number of points from ids to ide-1 inclusive
+      globalYcount = jde - jds  ! in other words, the number of points from jds to jde-1 inclusive
+      ! task-local numbers of points in patch for staggered arrays
+      myXstart = ips
+      myYstart = jps
+      myXend = MIN(ipe,ide-1)
+      myYend = MIN(jpe,jde-1)
+      myXcount = myXend - myXstart + 1
+      myYcount = myYend - myYstart + 1
+      ! 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)
+
+      !TODO:  ESMF 2.x does not support mercator, polar-stereographic, or 
+      !TODO:  lambert-conformal projections.  Therefore, we're using fake 
+      !TODO:  coordinates here.  This means that WRF will either have to 
+      !TODO:  couple to models that run on the same coorindate such that 
+      !TODO:  grid points are co-located or something else will have to 
+      !TODO:  perform the inter-grid interpolation computations.  Replace 
+      !TODO:  this once ESMF is upgraded to support the above map 
+      !TODO:  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.  
+!TODO:  Pass staggering info into this routine once ESMF can support staggered 
+!TODO:  grids.  For now, it is hard-coded for WRF-ARW.  
+      gridID = gridID + 1
+      WRITE ( gridname,'(a,i0)' ) 'WRF_grid_', gridID
+
+CALL wrf_debug ( 5 , 'DEBUG WRF:  Calling ESMF_GridCreate' )
+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) )
+
+      ! 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_GridCreate', &
+                           __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_GridCreate', &
+                           __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) )
+
+#if 0
+      esmfgrid = ESMF_GridCreateHorzXY(                     &
+                   coord1=coordX, coord2=coordY,            &
+                   horzstagger=ESMF_GRID_HORZ_STAGGER_C_SW, &
+!TODO:  use this for 3D Grids once it is stable
+!                  coordorder=ESMF_COORD_ORDER_XZY,         &
+                   name=TRIM(gridname), rc=rc )
+#else
+! based on example in 3.1 ref man sec 23.2.5, Creating an Irregularly 
+! Distributed Rectilinear Grid with a Non-Distributed Vertical Dimension
+      !esmfgrid = ESMF_GridCreateShapeTile(  &
+!write(0,*)'calling ESMF_GridCreateShapeTile for grid named ',trim(gridname)
+!write(0,*)'calling ESMF_GridCreateShapeTile dimXCount ',dimXCount
+!write(0,*)'calling ESMF_GridCreateShapeTile dimYCount ',dimYCount
+      esmfgrid = ESMF_GridCreateShapeTile(  &
+                 countsPerDEDim1=dimXCount , &
+                 countsPerDEDim2=dimYcount , &
+                 coordDep1=(/1/) , &
+                 coordDep2=(/2/) , &
+                 indexflag=ESMF_INDEX_GLOBAL, & ! use global indices
+                 name=TRIM(gridname), &
+                 rc = rc )
+
+      CALL ESMF_GridAddCoord(esmfgrid, &
+                 staggerloc=ESMF_STAGGERLOC_CENTER, &
+                 rc=rc)
+
+
+      CALL ESMF_GridGetCoord(esmfgrid,coordDim=1,localDE=0, &
+                 staggerloc=ESMF_STAGGERLOC_CENTER, &
+                 computationalLBound=lbnd,computationalUBound=ubnd, &
+                 fptr=coordX2d, &
+                 rc=rc)
+
+      DO i=lbnd(1),ubnd(1)
+        coordX2d(i) = (i-1)*1.0
+      ENDDO
+      CALL ESMF_GridGetCoord(esmfgrid,coordDim=2,localDE=0, &
+                 staggerloc=ESMF_STAGGERLOC_CENTER, &
+                 computationalLBound=lbnd,computationalUBound=ubnd, &
+                 fptr=coordY2d,                             &
+                 rc=rc)
+      DO i=lbnd(1),ubnd(1)
+        coordY2d(i) = (i-1)*1.0
+      ENDDO
+                 
+                 
+#endif
+      IF ( rc /= ESMF_SUCCESS ) THEN
+        WRITE( msg,* ) 'Error in ESMF_GridCreate', &
+                       __FILE__ ,                        &
+                       ', line',                         &
+                       __LINE__
+        CALL wrf_error_fatal ( msg )
+      ENDIF
+CALL wrf_debug ( 5 , 'DEBUG WRF:  back OK from ESMF_GridCreate' )
+
+      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  calling ESMF_DELayoutPrint 2' )
+      IF ( 5 .LE. debug_level ) THEN
+        CALL ESMF_DELayoutPrint( taskLayout, rc=rc )
+      ENDIF
+      CALL wrf_debug ( 5 , 'DEBUG ioesmf_create_grid_int:  back from ESMF_DELayoutPrint 2' )
+
+#if 0
+      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
+#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
+        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 )
+
+#if 0
+      ! Print out the ESMF decomposition info for debug comparison with WRF 
+      ! decomposition info.  
+      ALLOCATE( cellCounts(0:numprocs-1,2), globalStarts(0:numprocs-1,2) )
+
+      ! 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...' )
+      IF ( 100 .LE. debug_level ) THEN
+        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
+      ENDIF
+      CALL wrf_debug ( 100 , 'DEBUG ioesmf_create_grid_int:  print esmfgrid END' )
+
+#endif
+      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
+#if 0
+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
+#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
+
+
+!TODO:  use generic explicit interfaces and remove duplication
+!TODO:  use cpp to 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
+
+
+!TODO:  use cpp to 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
+
+
+!TODO:  use cpp to 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 )
+   !TODO:  Remove this hack once we no longer have to store non-staggered 
+   !TODO:  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
+
+
+!TODO:  use cpp to 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 )
+   !TODO:  Remove this hack once we no longer have to store non-staggered 
+   !TODO:  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) )
+
+!TODO:  need to cache file name and match with FileName argument and return 
+!TODO:  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) )
+
+!TODO:  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.  
+  CALL wrf_debug( 5, 'ext_esmf_ioclose:  WARNING:  not destroying ESMF objects' )
+#if 0
+  !TODO:  Need to upgrade this to use nested ESMF_States if we want support 
+  !TODO:  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.  
+  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 
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/makefile	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/module_esmf_extensions.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/module_esmf_extensions.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/module_esmf_extensions.F90	(revision 17)
@@ -0,0 +1,538 @@
+
+! "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(inout)            :: 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=time, yy=yy, yy_i8=yy_i8, &
+                                    mm=mm, dd=dd, &
+                                    d=d, d_i8=d_i8, &
+                                    h=h, m=m, &
+                                    s=s, s_i8=s_i8, &
+                                    ms=ms, us=us, ns=ns, &
+                                    d_r8=d_r8, h_r8=h_r8, m_r8=m_r8, s_r8=s_r8, &
+                                    ms_r8=ms_r8, us_r8=us_r8, ns_r8=ns_r8, &
+                                    sN=sN, sD=sD, &
+                                    calendar=calendar, calendarType=calendarType, timeZone=timeZone, &
+                                    timeString=timeString, timeStringISOFrac=timeStringISOFrac, &
+                                    dayOfWeek=dayOfWeek, midMonth=midMonth, &
+                                    dayOfYear=dayOfYear,  dayOfYear_R8=dayOfYear_r8, &
+                                    dayOfYear_intvl=dayOfYear_intvl, rc=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 ( PRESENT( Sd ) ) THEN
+              IF ( Sd /= 0 ) THEN
+                rsec = rsec + ( REAL( Sn, ESMF_KIND_R8 ) / REAL( Sd, ESMF_KIND_R8 ) )
+              ENDIF
+            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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/module_symbols_util.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/module_symbols_util.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/module_symbols_util.F90	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/module_utility.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/module_utility.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_esmf/module_utility.F90	(revision 17)
@@ -0,0 +1,9 @@
+
+      MODULE module_utility
+
+        USE module_symbols_util
+        ! Not-yet-implemented ESMF features
+        USE module_esmf_extensions
+
+      END MODULE module_utility
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/FTP_getfile.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/FTP_getfile.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/FTP_getfile.c	(revision 17)
@@ -0,0 +1,177 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+#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
+*
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/Makefile	(revision 17)
@@ -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<dir> tokens to specify where the dependent 
+#               libraries are, and -l<lib> 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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/README
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/README	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/README	(revision 17)
@@ -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.
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/apply_bitmap.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/apply_bitmap.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/apply_bitmap.c	(revision 17)
@@ -0,0 +1,234 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+#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<<j))
+		{  
+/*
+* A.6.2.1.1         IF (trying to access more than #elements in Incoming Array)
+*                      FILL errmsg
+*                      RETURN 3    ! incoming float array unchanged
+*                   ENDIF
+*/
+		   if (gribdata_indx == tot_bits_set) {
+		     sprintf(errmsg,
+                    "%s:  accessing more than %d elements in Grib_data[]\n",
+			func,	tot_bits_set);
+		     DPRINT1("Leaving %s, access out of range element\n",func);
+		     return(3);  /* incoming Float array is unchanged */
+		     }
+
+/*
+* A.6.2.1.2         !still within range
+*                   STORE datapoint at correct place in expanded array
+*/
+		   fbuff[buf_indx++]= (*pgrib_data)[gribdata_indx++];
+		}
+/*
+*                ELSE  ! means data point is missing
+*/
+	    else {
+/*
+* A.6.2.2           STORE Missing Value at correct place in expanded array
+*/
+		   fbuff[buf_indx++]= fill_value;
+		}
+/*
+* A.6.2.1        ENDIF
+*/
+         }  /* bit loop */
+/*
+* A.6.2      ENDLOOP 
+*/
+
+    } /* for every datapt */
+/*
+* A.6     ENDFOR !for every datapoint
+*/
+
+/*
+*
+* A.7     STORE the grid size into caller's argument
+*/
+  bds_head->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
+*
+*
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/display_gribhdr.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/display_gribhdr.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/display_gribhdr.c	(revision 17)
@@ -0,0 +1,175 @@
+/* FILE:  display_gribhdr.c  		10-OCT-96 by Alice Nakajima/SAIC */
+#include <stdio.h>              /* standard I/O header file     */
+#include <stdlib.h>
+
+#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
+*
+*
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/dprints.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/dprints.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/dprints.h	(revision 17)
@@ -0,0 +1,79 @@
+/* file:  dprints.h				12/30/96 Nakajima/SAIC/MRY
+*/
+#include <stdio.h>
+
+#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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gbyte.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gbyte.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gbyte.c	(revision 17)
@@ -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 <stdio.h>
+#include <stdlib.h>
+
+#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
+*
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib.h	(revision 17)
@@ -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;
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_dec.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_dec.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_dec.c	(revision 17)
@@ -0,0 +1,272 @@
+#include <stdio.h>              /* standard I/O header file          */
+#include <stdlib.h>
+#include <string.h>
+#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
+*
+*
+*/
+} 
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_enc.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_enc.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_enc.c	(revision 17)
@@ -0,0 +1,601 @@
+/*
+ REVISIONS:
+ 10/15/96 A. Nakajima, SAIC:  removed 'write_grib' call; make combined lib;
+ 11/03/97 /ATN  -Realloc
+*/
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#ifdef XT3_Catamount
+#include <features.h>
+#undef htonl
+#define htonl(x)     swap_byte4(x)
+#elif defined(_WIN32)
+#include <Winsock2.h>
+#else
+#include <netinet/in.h>
+#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: <Create-All mode>  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: <Create Missing Sect mode> 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
+*
+*
+*/ 
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_lookup.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_lookup.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_lookup.h	(revision 17)
@@ -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 <stdio.h>
+#include <limits.h>
+#include <float.h>
+
+#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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_seek.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_seek.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_seek.c	(revision 17)
@@ -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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#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
+*
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_uthin.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_uthin.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/grib_uthin.c	(revision 17)
@@ -0,0 +1,71 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+
+/*****************************************************************************
+ *
+ * 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<ysize; j++) {
+    if (rowsizes[j] > *xsize) {
+      *xsize = rowsizes[j];
+    }
+  }
+
+  for (j=0; j<ysize; j++) {
+    inrow_index = 0;
+    for (i=0; i<*xsize; i++) {
+      if (rowsizes[j] == *xsize) {
+	out[out_index] = in[in_index];
+	in_index++;
+	out_index++;
+      } else {
+	b = (((float)(*xsize)-1)/((float)rowsizes[j]-1))*(inrow_index+1);
+	if (i >= 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;
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribfuncs.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribfuncs.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribfuncs.h	(revision 17)
@@ -0,0 +1,119 @@
+#include <stdio.h>
+#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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribgetbds.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribgetbds.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribgetbds.c	(revision 17)
@@ -0,0 +1,439 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h> 
+#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; j<ysize; j++) {
+      if (gds->head.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
+*
+*/
+}    
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribgetbms.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribgetbms.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribgetbms.c	(revision 17)
@@ -0,0 +1,186 @@
+/*  gribgetbms.c 		June 17, 1996 by Alice Nakajima, SAIC   */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#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
+*/ 
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribgetgds.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribgetgds.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribgetgds.c	(revision 17)
@@ -0,0 +1,694 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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; i<gds->llg.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; i<gds->merc.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; i<gds->pol.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; i<gds->lam.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 
+*
+*/
+}  
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribgetpds.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribgetpds.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribgetpds.c	(revision 17)
@@ -0,0 +1,374 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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;
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribhdr2file.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribhdr2file.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribhdr2file.c	(revision 17)
@@ -0,0 +1,222 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribputbds.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribputbds.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribputbds.c	(revision 17)
@@ -0,0 +1,247 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#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
+*
+*
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribputgds.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribputgds.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribputgds.c	(revision 17)
@@ -0,0 +1,1478 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#ifdef XT3_Catamount
+#include <features.h>
+#undef htonl
+#define htonl(x)     swap_byte4(x)
+#elif defined(_WIN32)
+#include <Winsock2.h>
+#else
+#include <netinet/in.h>
+#endif
+#include "dprints.h"		/* for dprints */
+#include "gribfuncs.h"		/* prototypes */
+#include <math.h>
+
+/*
+************************************************************************
+* 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
+
+#ifdef _WIN32
+#define lrint(x) (floor(x+(x>0) ? 0.5 : -0.5))
+#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 + 0x88;
+   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 + 0x88;
+   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 + 0x88;
+   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((int)(ProjInp->lon_inc + 0.5), 3, Mercator->achDi);
+
+/* convert ulDy to 3chars */
+      set_bytes((int)(ProjInp->lat_inc + 0.5), 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;
+}
+*/
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribputpds.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribputpds.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/gribputpds.c	(revision 17)
@@ -0,0 +1,513 @@
+/* FILENAME:   gribputpds.c */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdlib.h>
+#ifdef XT3_Catamount
+#include <features.h>
+#elif defined(_WIN32)
+#include <Winsock2.h>
+#else
+#include <netinet/in.h>
+#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
+*
+*/ 
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/hdr_print.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/hdr_print.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/hdr_print.c	(revision 17)
@@ -0,0 +1,66 @@
+/* FILENAME:   hdr_print.c */
+#include <stdio.h>
+#include <stdlib.h>
+#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
+*
+*/ 
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/init_dec_struct.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/init_dec_struct.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/init_dec_struct.c	(revision 17)
@@ -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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#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
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/init_enc_struct.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/init_enc_struct.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/init_enc_struct.c	(revision 17)
@@ -0,0 +1,61 @@
+/* FILENAME:     init_enc_struct.c
+   DATE:         15 FEB 1996
+   PROGRAMMER:   STEVE LOWE, SAIC
+   REVISED BY:   ALICE NAKAJIMA, SAIC
+ */
+#include <stdio.h>
+#include <stdlib.h>
+#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
+*
+*/ 
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/init_gribhdr.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/init_gribhdr.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/init_gribhdr.c	(revision 17)
@@ -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 <stdio.h>
+#include <stdlib.h>
+#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
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/init_struct.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/init_struct.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/init_struct.c	(revision 17)
@@ -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 <stdio.h>
+#include <stdlib.h>
+#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
+*
+*/ 
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/input.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/input.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/input.h	(revision 17)
@@ -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;
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/isdb.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/isdb.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/isdb.h	(revision 17)
@@ -0,0 +1,123 @@
+#ifndef ISDB_INCLUDE
+#define ISDB_INCLUDE
+
+#ifdef _NET_NEONS
+#include <nn_client.h>
+#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 */
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/ld_dec_lookup.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/ld_dec_lookup.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/ld_dec_lookup.c	(revision 17)
@@ -0,0 +1,768 @@
+/*  FILENAME:   ld_dec_lookup.c 
+Revision logs:
+16Jul97 /atn: clear Decoder section of structs only; chg warnings to Stdout;
+*/
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#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
+*
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/ld_enc_input.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/ld_enc_input.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/ld_enc_input.c	(revision 17)
@@ -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 <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#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 
+*
+*
+*/ 
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/ld_enc_lookup.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/ld_enc_lookup.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/ld_enc_lookup.c	(revision 17)
@@ -0,0 +1,503 @@
+/* Revision logs:
+16Jul97 /atn:  only clr Encoder section of db tables; chg warning to stdout;
+*/
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+#include <stdlib.h>
+#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
+*
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/ld_grib_origctrs.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/ld_grib_origctrs.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/ld_grib_origctrs.c	(revision 17)
@@ -0,0 +1,164 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#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
+*
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/make_default_grbfn.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/make_default_grbfn.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/make_default_grbfn.c	(revision 17)
@@ -0,0 +1,61 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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);
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/make_grib_log.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/make_grib_log.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/make_grib_log.c	(revision 17)
@@ -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 <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#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<numpts; i=i+5)
+	  if (i + 5 < numpts) 
+ 	      fprintf(fp, "%03d-  %.*f  %.*f  %.*f  %.*f  %.*f\n",
+              i,fd,grib_data[i],fd,grib_data[i+1],fd,
+              grib_data[i+2],fd,grib_data[i+3],fd,grib_data[i+4] );
+	  else  {
+	      fprintf(fp,"%03d-", i); 
+	      while (i < numpts) fprintf(fp,"  %.*f", fd, grib_data[i++]);
+	      fprintf(fp,"\n");
+	    }
+	}
+  else  {
+	for (i=0; i<numpts; i=i+5)
+	  if (i + 5 < numpts)
+    	      fprintf(fp, "%03d-  %.0f  %.0f  %.0f  %.0f  %.0f\n",
+              i,grib_data[i],grib_data[i+1],
+              grib_data[i+2],grib_data[i+3],grib_data[i+4] );
+	  else  {
+	      fprintf(fp,"%03d-", i); 
+	      while (i < numpts) fprintf(fp,"  %.0f", grib_data[i++]);
+	      fprintf(fp,"\n");
+	    }
+	}
+  
+  }
+
+  fprintf (fp,"\n******** END OF MESSAGE *******\n\n");
+
+/*
+* 
+* A.7   CLOSE file
+*/
+  fclose (fp);
+
+/*
+*
+* A.8   DEBUG printing
+*/
+  DPRINT1 ("Leaving  %s, no errors\n", func);
+  return (0);
+
+/*
+* END OF FUNCTION
+*
+*
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/map_lvl.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/map_lvl.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/map_lvl.c	(revision 17)
@@ -0,0 +1,107 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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);
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/map_parm.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/map_parm.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/map_parm.c	(revision 17)
@@ -0,0 +1,139 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/pack_spatial.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/pack_spatial.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/pack_spatial.c	(revision 17)
@@ -0,0 +1,652 @@
+/* 20jun97/atn:  always scaling data up whether dsf is -/+; 
+*/
+#include <stdio.h> 
+#include <stdlib.h>
+#include <string.h> 
+#include <math.h>
+#ifdef XT3_Catamount
+#include <features.h>
+#undef htonl
+#define htonl(x)     swap_byte4(x)
+#elif defined(_WIN32)
+#include <Winsock2.h>
+#else
+#include <netinet/in.h>
+#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
+*
+*/ 
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/prt_badmsg.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/prt_badmsg.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/prt_badmsg.c	(revision 17)
@@ -0,0 +1,328 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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);
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/prt_inp_struct.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/prt_inp_struct.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/prt_inp_struct.c	(revision 17)
@@ -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 <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#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; i<bds_head_input->ulGrid_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; i<bds_head_input->ulGrid_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
+*
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/set_bytes.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/set_bytes.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/set_bytes.c	(revision 17)
@@ -0,0 +1,29 @@
+#include <stdio.h>
+#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;
+    }
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/swap.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/swap.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/swap.c	(revision 17)
@@ -0,0 +1,24 @@
+#include <stdio.h>
+#include <stdlib.h>
+void *swap_byte4(long *theInt)
+{
+  char tmp[4];
+  int i;
+
+  for (i=0; i<sizeof(long); i++)  
+    tmp[i] = *((char*)theInt+(sizeof(long)-1-i));
+
+  *theInt=*((long *)tmp);
+
+}
+
+void *swap_byte2(short *theInt)
+{
+  char tmp[4];
+  int i;
+
+  for (i=0; i<sizeof(short); i++)  
+    tmp[i] = *((char*)theInt+(sizeof(short)-1-i));
+
+  *theInt=*((short *)tmp);
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/test_set_bytes.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/test_set_bytes.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/test_set_bytes.c	(revision 17)
@@ -0,0 +1,18 @@
+#include <stdio.h>
+
+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]); */
+    }
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/upd_child_errmsg.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/upd_child_errmsg.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/MEL_grib1/upd_child_errmsg.c	(revision 17)
@@ -0,0 +1,56 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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
+*/
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/Makefile	(revision 17)
@@ -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<dir> tokens to specify where the dependent 
+#               libraries are, and -l<lib> 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 *.obj > /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.exe > /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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/README.io_grib1
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/README.io_grib1	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/README.io_grib1	(revision 17)
@@ -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_<x> 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=<your WRF dir>/run/gribmap.txt
+        For csh users
+          setenv GRIBTAB <your WRF dir>/run/gribmap.txt
+  3. To get a listing of the records in the GRIB data:
+        <your WRF dir>/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:<PARAMETER>:<DESCRIPTION>:<WRF VAR>:<DECSCL>
+          "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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/BDSunpk.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/BDSunpk.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/BDSunpk.c	(revision 17)
@@ -0,0 +1,133 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <stddef.h>
+#include <limits.h>
+#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;
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/Changes
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/Changes	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/Changes	(revision 17)
@@ -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.)
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/Makefile	(revision 17)
@@ -0,0 +1,29 @@
+.IGNORE:
+
+.SUFFIXES: .c .o
+
+CC=cc
+
+.c.o:
+	$(CC) -c -O $<
+
+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.exe
+
+archive: wgrib.exe
+
+wgrib.exe: $(obj)
+	$(CC) -o wgrib.exe $(obj) #-lm
+	( cd .. ; \rm -f wgrib.exe ; \ln -sf WGRIB/wgrib.exe wgrib.exe ; cd WGRIB )
+
+clean:	
+	\rm -f $(obj) *.obj wgrib.exe
+	( cd .. ; \rm -f wgrib.exe ; cd WGRIB )
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/PDS_date.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/PDS_date.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/PDS_date.c	(revision 17)
@@ -0,0 +1,213 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <stddef.h>
+#include <string.h>
+#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);
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/PDStimes.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/PDStimes.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/PDStimes.c	(revision 17)
@@ -0,0 +1,216 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <stddef.h>
+#include <string.h>
+#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?:");
+	}
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/README
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/README	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/README	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/bds.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/bds.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/bds.h	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/bms.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/bms.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/bms.h	(revision 17)
@@ -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)))
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/cnames.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/cnames.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/cnames.c	(revision 17)
@@ -0,0 +1,141 @@
+#include <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#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;
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/cnames.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/cnames.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/cnames.h	(revision 17)
@@ -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;
+};
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/cptectable_254.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/cptectable_254.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/cptectable_254.c	(revision 17)
@@ -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]"},
+};
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/dwdtable_002.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/dwdtable_002.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/dwdtable_002.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/dwdtable_201.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/dwdtable_201.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/dwdtable_201.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/dwdtable_202.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/dwdtable_202.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/dwdtable_202.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/dwdtable_203.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/dwdtable_203.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/dwdtable_203.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ec_ext.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ec_ext.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ec_ext.c	(revision 17)
@@ -0,0 +1,78 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <stddef.h>
+#include <string.h>
+
+#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;
+	}
+    }
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_128.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_128.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_128.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_129.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_129.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_129.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_130.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_130.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_130.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_131.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_131.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_131.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_140.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_140.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_140.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_150.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_150.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_150.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_151.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_151.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_151.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_160.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_160.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_160.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_170.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_170.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_170.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_180.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_180.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ectable_180.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ensemble.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ensemble.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ensemble.c	(revision 17)
@@ -0,0 +1,103 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <stddef.h>
+#include <string.h>
+#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 */
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/flt2ieee.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/flt2ieee.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/flt2ieee.c	(revision 17)
@@ -0,0 +1,67 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <float.h>
+#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;
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/gds.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/gds.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/gds.h	(revision 17)
@@ -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)
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/gds_grid.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/gds_grid.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/gds_grid.c	(revision 17)
@@ -0,0 +1,162 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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) "); 
+	}
+    }
+}
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/grib.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/grib.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/grib.h	(revision 17)
@@ -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);
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/gribtable.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/gribtable.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/gribtable.c	(revision 17)
@@ -0,0 +1,131 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <stddef.h>
+#include <string.h>
+#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, &center, &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;
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ibm2flt.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ibm2flt.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ibm2flt.c	(revision 17)
@@ -0,0 +1,43 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+/* 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;
+}
+	
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/intpower.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/intpower.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/intpower.c	(revision 17)
@@ -0,0 +1,31 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+/*
+ * 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;
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/levels.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/levels.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/levels.c	(revision 17)
@@ -0,0 +1,178 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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;
+	}
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/missing.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/missing.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/missing.c	(revision 17)
@@ -0,0 +1,48 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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;
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptab_129.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptab_129.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptab_129.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptab_130.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptab_130.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptab_130.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptab_131.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptab_131.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptab_131.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptable_opn.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptable_opn.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptable_opn.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptable_reanal.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptable_reanal.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/nceptable_reanal.c	(revision 17)
@@ -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"},
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ombtable.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ombtable.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/ombtable.c	(revision 17)
@@ -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"}
+};
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/pds4.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/pds4.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/pds4.h	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/readgrib.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/readgrib.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/readgrib.c	(revision 17)
@@ -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 <stdio.h>
+#include <stdlib.h>
+#include <stddef.h>
+#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);
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/seekgrib.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/seekgrib.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/seekgrib.c	(revision 17)
@@ -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 <stdio.h>
+#include <stdlib.h>
+#include <stddef.h>
+#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;
+}
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/src2all
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/src2all	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/src2all	(revision 17)
@@ -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 <stdio.h>"
+echo >>wgrib.c "#include <stdlib.h>"
+echo >>wgrib.c "#include <string.h>"
+echo >>wgrib.c "#include <stddef.h>"
+echo >>wgrib.c "#include <math.h>"
+echo >>wgrib.c "#include <float.h>"
+
+
+cat $h >>wgrib.c
+
+cat $c | grep -v '#include' >> wgrib.c
+
+tar -cvf wgrib.tar $h $c src2all makefile Changes
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/wgrib_main.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/wgrib_main.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/wgrib_main.c	(revision 17)
@@ -0,0 +1,839 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stddef.h>
+#include <math.h>
+#include <float.h>
+
+#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");
+        }
+    }
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/wrtieee.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/wrtieee.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/WGRIB/wrtieee.c	(revision 17)
@@ -0,0 +1,82 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <stddef.h>
+#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;
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/diffwrf
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/diffwrf	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/diffwrf	(revision 17)
@@ -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.exe -s $file1 | ../../external/io_grib1/wgrib.exe -s -i -o outfile1 $file1 >& /dev/null
+../../external/io_grib1/wgrib.exe -s $file2 | ../../external/io_grib1/wgrib.exe -s -i -o outfile2 $file2 >& /dev/null
+
+cmp outfile1 outfile2
+
+set ok = $status
+
+if ( $ok == 0 ) then
+	
+else
+	touch fort.88
+endif
+
+exit ( 0 ) 
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_routines.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_routines.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_routines.c	(revision 17)
@@ -0,0 +1,1292 @@
+/*
+****************************************************************************
+*
+*  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 "wrf_projection.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <ctype.h>
+#include <limits.h>
+
+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,"<METADATA>",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,"<!--",4) == 0)
+	{
+	  incomment = 1;
+	  strcpy(line,line+4);
+	}
+      
+      /* Search for end of comment */
+      if (incomment)
+	{
+	  charidx = 0;
+	  while (charidx < strlen(line)) 
+	    {
+	      
+	      if (strncmp(line+charidx,"-->",3) == 0)
+		{
+		  strcpy(line,line+charidx+3);
+		  incomment = 0;
+		  break;
+		}
+	      else
+		{
+		  charidx++;
+		}
+	    }
+	}
+
+      if (incomment) continue;
+  
+
+      /* Check for end of metadata */
+      if (strncmp(line,"</METADATA>",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 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
+
+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;
+  float dx, dy;
+  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);
+
+ /* Convert grid spacing to degrees for LATLON projection */
+  
+  if ( (grid_info->projection == WRF_LATLON) || 
+       (grid_info->projection == WRF_CASSINI) )
+  {
+      dx = grid_info->Di * KM_TO_DEGREES;
+      dy = grid_info->Dj * KM_TO_DEGREES;
+  }
+  else
+  {
+      dx = grid_info->Di;
+      dy = grid_info->Dj;
+  }
+
+ /* 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,
+		     dx, dy,
+		     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, &center,
+			   &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:
+    case WRF_CASSINI:
+      strcpy(geom_in.prjn_name,"spherical");
+      geom_in.parm_1 = dy;
+      geom_in.parm_2 = dx;
+      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 = dx;
+      geom_in.parm_3 = dy;
+      geom_in.usRes_flag = 136;
+      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 = dx;
+      geom_in.y_int_dis = dy;
+      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 = dx*(1.+sin(60. * PI/180.))
+	/ (1.+sin(abs(grid_info->latin1) * PI/180.));
+      geom_in.y_int_dis = dy*(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;
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_routines.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_routines.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_routines.h	(revision 17)
@@ -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);
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/Makefile	(revision 17)
@@ -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<dir> tokens to specify where the dependent 
+#               libraries are, and -l<lib> 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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/alloc_2d.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/alloc_2d.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/alloc_2d.c	(revision 17)
@@ -0,0 +1,54 @@
+#include "stdio.h"
+#include <stdlib.h>
+
+/**************************************************************************
+ * 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);
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/alloc_2d.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/alloc_2d.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/alloc_2d.h	(revision 17)
@@ -0,0 +1,2 @@
+float **alloc_float_2d(int firstdim,int seconddim);
+void free_float_2d(float **var, int firstdim, int seconddim);
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/cfortran.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/cfortran.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/cfortran.h	(revision 17)
@@ -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 <stdio.h>     /* NULL [in all machines stdio.h]                      */
+#include <string.h>    /* strlen, memset, memcpy, memchr.                     */
+#if !( defined(VAXUltrix) || defined(sun) || (defined(apollo)&&!defined(__STDCPP__)) )
+#include <stdlib.h>    /* malloc,free                                         */
+#else
+#include <malloc.h>    /* 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 <fortran.h>
+#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 <descrip.h>
+#else
+#include "descrip.h"  /* i.e. if crosscompiling assume user has file. */
+#endif
+#endif
+
+#ifdef sunFortran
+#if defined(sun) || defined(__sun)
+#include <math.h>     /* 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
+ * <math.h>, 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) (A<B?A:B)
+
+/* 970211 - XIX.145:
+   firstindexlength  - better name is all_but_last_index_lengths
+   secondindexlength - better name is         last_index_length
+ */
+#define  firstindexlength(A) (sizeof(A[0])==1 ? 1 : (sizeof(A) / sizeof(A[0])) )
+#define secondindexlength(A) (sizeof(A[0])==1 ?      sizeof(A) : sizeof(A[0])  )
+
+/* Behavior of FORTRAN LOGICAL. All machines' LOGICAL is same size as C's int.
+Conversion is automatic except for arrays which require F2CLOGICALV/C2FLOGICALV.
+f2c, MIPS f77 [DECstation, SGI], VAX Ultrix f77,
+HP-UX f77                                        : as in C.
+VAX/VMS FORTRAN, VAX Ultrix fort,
+Absoft Unix Fortran, IBM RS/6000 xlf             : LS Bit = 0/1 = TRUE/FALSE.
+Apollo                                           : neg.   = TRUE, else FALSE. 
+[Apollo accepts -1 as TRUE for function values, but NOT all other neg. values.]
+[DECFortran for Ultrix RISC is also called f77 but is the same as VAX/VMS.]   
+[MIPS f77 treats .eqv./.neqv. as .eq./.ne. and hence requires LOGICAL_STRICT.]*/
+
+#if defined(NAGf90Fortran) || defined(f2cFortran) || defined(mipsFortran) || defined(PowerStationFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran) || defined(SXFortran) || defined(pgiFortran)
+/* SX/PowerStationFortran have 0 and 1 defined, others are neither T nor F.   */
+/* hpuxFortran800 has 0 and 0x01000000 defined. Others are unknown.           */
+#define LOGICAL_STRICT      /* Other Fortran have .eqv./.neqv. == .eq./.ne.   */
+#endif
+
+#define C2FLOGICALV(A,I) \
+ do {int __i; for(__i=0;__i<I;__i++) A[__i]=C2FLOGICAL(A[__i]); } while (0)
+#define F2CLOGICALV(A,I) \
+ do {int __i; for(__i=0;__i<I;__i++) A[__i]=F2CLOGICAL(A[__i]); } while (0)
+
+#if defined(apolloFortran)
+#define C2FLOGICAL(L) ((L)?-1:(L)&~((unsigned)1<<sizeof(int)*8-1))
+#define F2CLOGICAL(L) ((L)<0?(L):0) 
+#else
+#if defined(CRAYFortran)
+#define C2FLOGICAL(L) _btol(L)
+#define F2CLOGICAL(L) _ltob(&(L))     /* Strangely _ltob() expects a pointer. */
+#else
+#if defined(IBMR2Fortran) || defined(vmsFortran) || defined(DECFortran) || defined(AbsoftUNIXFortran)
+/* How come no AbsoftProFortran ? */
+#define C2FLOGICAL(L) ((L)?(L)|1:(L)&~(int)1)
+#define F2CLOGICAL(L) ((L)&1?(L):0)
+#else
+#if defined(CONVEXFortran)
+#define C2FLOGICAL(L) ((L) ? ~0 : 0 )
+#define F2CLOGICAL(L) (L)
+#else   /* others evaluate LOGICALs as for C. */
+#define C2FLOGICAL(L) (L)
+#define F2CLOGICAL(L) (L)
+#ifndef LOGICAL_STRICT
+#undef  C2FLOGICALV
+#undef  F2CLOGICALV
+#define C2FLOGICALV(A,I)
+#define F2CLOGICALV(A,I)
+#endif  /* LOGICAL_STRICT                     */
+#endif  /* CONVEXFortran || All Others        */
+#endif  /* IBMR2Fortran vmsFortran DECFortran AbsoftUNIXFortran */
+#endif  /* CRAYFortran                        */
+#endif  /* apolloFortran                      */
+
+/* 970514 - In addition to CRAY, there may be other machines
+            for which LOGICAL_STRICT makes no sense. */
+#if defined(LOGICAL_STRICT) && !defined(CRAYFortran)
+/* Force C2FLOGICAL to generate only the values for either .TRUE. or .FALSE.
+   SX/PowerStationFortran only have 0 and 1 defined.
+   Elsewhere, only needed if you want to do:
+     logical lvariable
+     if (lvariable .eq.  .true.) then       ! (1)
+   instead of
+     if (lvariable .eqv. .true.) then       ! (2)
+   - (1) may not even be FORTRAN/77 and that Apollo's f77 and IBM's xlf
+     refuse to compile (1), so you are probably well advised to stay away from 
+     (1) and from LOGICAL_STRICT.
+   - You pay a (slight) performance penalty for using LOGICAL_STRICT. */
+#undef  C2FLOGICAL
+#ifdef hpuxFortran800
+#define C2FLOGICAL(L) ((L)?0x01000000:0)
+#else
+#if defined(apolloFortran) || defined(vmsFortran) || defined(DECFortran)
+#define C2FLOGICAL(L) ((L)?-1:0) /* These machines use -1/0 for .true./.false.*/
+#else
+#define C2FLOGICAL(L) ((L)? 1:0) /* All others     use +1/0 for .true./.false.*/
+#endif
+#endif
+#endif /* LOGICAL_STRICT */
+
+/* Convert a vector of C strings into FORTRAN strings. */
+#ifndef __CF__KnR
+static char *c2fstrv(char* cstr, char *fstr, int elem_len, int sizeofcstr)
+#else
+static char *c2fstrv(      cstr,       fstr,     elem_len,     sizeofcstr)
+                     char* cstr; char *fstr; int elem_len; int sizeofcstr;
+#endif
+{ int i,j;
+/* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
+   Useful size of string must be the same in both languages. */
+for (i=0; i<sizeofcstr/elem_len; i++) {
+  for (j=1; j<elem_len && *cstr; j++) *fstr++ = *cstr++;
+  cstr += 1+elem_len-j;
+  for (; j<elem_len; j++) *fstr++ = ' ';
+} /* 95109 - Seems to be returning the original fstr. */
+return fstr-sizeofcstr+sizeofcstr/elem_len; }
+
+/* Convert a vector of FORTRAN strings into C strings. */
+#ifndef __CF__KnR
+static char *f2cstrv(char *fstr, char* cstr, int elem_len, int sizeofcstr)
+#else
+static char *f2cstrv(      fstr,       cstr,     elem_len,     sizeofcstr)
+                     char *fstr; char* cstr; int elem_len; int sizeofcstr; 
+#endif
+{ int i,j;
+/* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
+   Useful size of string must be the same in both languages. */
+cstr += sizeofcstr;
+fstr += sizeofcstr - sizeofcstr/elem_len;
+for (i=0; i<sizeofcstr/elem_len; i++) {
+  *--cstr = '\0';
+  for (j=1; j<elem_len; j++) *--cstr = *--fstr;
+} return cstr; }
+
+/* kill the trailing char t's in string s. */
+#ifndef __CF__KnR
+static char *kill_trailing(char *s, char t)
+#else
+static char *kill_trailing(      s,      t) char *s; char t;
+#endif
+{char *e; 
+e = s + strlen(s);
+if (e>s) {                           /* 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 e<s string s is left unchanged. */ 
+#ifndef __CF__KnR
+static char *kill_trailingn(char *s, char t, char *e)
+#else
+static char *kill_trailingn(      s,      t,       e) char *s; char t; char *e;
+#endif
+{ 
+if (e==s) *e = '\0';                 /* Kill the string makes sense here.*/
+else if (e>s) {                      /* 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<sizeofcstr/elem_len; i++) /* elem_len includes \0 for C strings. */
+  kill_trailingn(cstr+elem_len*i,t,cstr+elem_len*(i+1)-1);
+return cstr; }
+
+#ifdef vmsFortran
+typedef struct dsc$descriptor_s fstring;
+#define DSC$DESCRIPTOR_A(DIMCT)                                                \
+struct {                                                                       \
+  unsigned short dsc$w_length;          unsigned char    dsc$b_dtype;          \
+  unsigned char  dsc$b_class;                    char   *dsc$a_pointer;        \
+           char  dsc$b_scale;           unsigned char    dsc$b_digits;         \
+  struct {                                                                     \
+    unsigned                   : 3;       unsigned dsc$v_fl_binscale : 1;      \
+    unsigned dsc$v_fl_redim    : 1;       unsigned dsc$v_fl_column   : 1;      \
+    unsigned dsc$v_fl_coeff    : 1;       unsigned dsc$v_fl_bounds   : 1;      \
+  } dsc$b_aflags;                                                              \
+  unsigned char  dsc$b_dimct;           unsigned long    dsc$l_arsize;         \
+           char *dsc$a_a0;                       long    dsc$l_m [DIMCT];      \
+  struct {                                                                     \
+    long dsc$l_l;                         long dsc$l_u;                        \
+  } dsc$bounds [DIMCT];                                                        \
+}
+typedef DSC$DESCRIPTOR_A(1) fstringvector;
+/*typedef DSC$DESCRIPTOR_A(2) fstringarrarr;
+  typedef DSC$DESCRIPTOR_A(3) fstringarrarrarr;*/
+#define initfstr(F,C,ELEMNO,ELEMLEN)                                           \
+( (F).dsc$l_arsize=  ( (F).dsc$w_length                        =(ELEMLEN) )    \
+                    *( (F).dsc$l_m[0]=(F).dsc$bounds[0].dsc$l_u=(ELEMNO)  ),   \
+  (F).dsc$a_a0    =  ( (F).dsc$a_pointer=(C) ) - (F).dsc$w_length          ,(F))
+
+#else
+#define _NUM_ELEMS      -1
+#define _NUM_ELEM_ARG   -2
+#define NUM_ELEMS(A)    A,_NUM_ELEMS
+#define NUM_ELEM_ARG(B) *_2(A,B),_NUM_ELEM_ARG
+#define TERM_CHARS(A,B) A,B
+#ifndef __CF__KnR
+static int num_elem(char *strv, unsigned elem_len, int term_char, int num_term)
+#else
+static int num_elem(      strv,          elem_len,     term_char,     num_term)
+                    char *strv; unsigned elem_len; int term_char; int num_term;
+#endif
+/* elem_len is the number of characters in each element of strv, the FORTRAN
+vector of strings. The last element of the vector must begin with at least
+num_term term_char characters, so that this routine can determine how 
+many elements are in the vector. */
+{
+unsigned num,i;
+if (num_term == _NUM_ELEMS || num_term == _NUM_ELEM_ARG) 
+  return term_char;
+if (num_term <=0) num_term = (int)elem_len;
+for (num=0; ; num++) {
+  for (i=0; i<(unsigned)num_term && *strv==term_char; i++,strv++);
+  if (i==(unsigned)num_term) break;
+  else strv += elem_len-i;
+}
+return (int)num;
+}
+#endif
+/*-------------------------------------------------------------------------*/
+
+/*           UTILITIES FOR C TO USE STRINGS IN FORTRAN COMMON BLOCKS       */
+
+/* C string TO Fortran Common Block STRing. */
+/* DIM is the number of DIMensions of the array in terms of strings, not
+   characters. e.g. char a[12] has DIM = 0, char a[12][4] has DIM = 1, etc. */
+#define C2FCBSTR(CSTR,FSTR,DIM)                                                \
+ c2fstrv((char *)CSTR, (char *)FSTR, sizeof(FSTR)/cfelementsof(FSTR,DIM)+1,    \
+         sizeof(FSTR)+cfelementsof(FSTR,DIM))
+
+/* Fortran Common Block string TO C STRing. */
+#define FCB2CSTR(FSTR,CSTR,DIM)                                                \
+ vkill_trailing(f2cstrv((char *)FSTR, (char *)CSTR,                            \
+                        sizeof(FSTR)/cfelementsof(FSTR,DIM)+1,                 \
+                        sizeof(FSTR)+cfelementsof(FSTR,DIM)),                  \
+                sizeof(FSTR)/cfelementsof(FSTR,DIM)+1,                         \
+                sizeof(FSTR)+cfelementsof(FSTR,DIM), ' ')
+
+#define cfDEREFERENCE0
+#define cfDEREFERENCE1 *
+#define cfDEREFERENCE2 **
+#define cfDEREFERENCE3 ***
+#define cfDEREFERENCE4 ****
+#define cfDEREFERENCE5 *****
+#define cfelementsof(A,D) (sizeof(A)/sizeof(_(cfDEREFERENCE,D)(A)))
+
+/*-------------------------------------------------------------------------*/
+
+/*               UTILITIES FOR C TO CALL FORTRAN SUBROUTINES               */
+
+/* Define lookup tables for how to handle the various types of variables.  */
+
+#ifdef OLD_VAXC                                /* Prevent %CC-I-PARAMNOTUSED. */
+#pragma nostandard
+#endif
+
+#define ZTRINGV_NUM(I)       I
+#define ZTRINGV_ARGFP(I) (*(_2(A,I))) /* Undocumented. For PINT, etc. */
+#define ZTRINGV_ARGF(I) _2(A,I)
+#ifdef CFSUBASFUN
+#define ZTRINGV_ARGS(I) ZTRINGV_ARGF(I)
+#else
+#define ZTRINGV_ARGS(I) _2(B,I)
+#endif
+
+#define    PBYTE_cfVP(A,B) PINT_cfVP(A,B)
+#define  PDOUBLE_cfVP(A,B)
+#define   PFLOAT_cfVP(A,B)
+#ifdef ZTRINGV_ARGS_allows_Pvariables
+/* This allows Pvariables for ARGS. ARGF machinery is above ARGFP.
+ * B is not needed because the variable may be changed by the Fortran routine,
+ * but because B is the only way to access an arbitrary macro argument.       */
+#define     PINT_cfVP(A,B) int  B = (int)A;              /* For ZSTRINGV_ARGS */
+#else
+#define     PINT_cfVP(A,B)
+#endif
+#define PLOGICAL_cfVP(A,B) int *B;      /* Returning LOGICAL in FUNn and SUBn */
+#define    PLONG_cfVP(A,B) PINT_cfVP(A,B)
+#define   PSHORT_cfVP(A,B) PINT_cfVP(A,B)
+
+#define        VCF_INT_S(T,A,B) _(T,VVVVVVV_cfTYPE) B = A;
+#define        VCF_INT_F(T,A,B) _(T,_cfVCF)(A,B)
+/* _cfVCF table is directly mapped to _cfCCC table. */
+#define     BYTE_cfVCF(A,B)
+#define   DOUBLE_cfVCF(A,B)
+#if !defined(__CF__KnR)
+#define    FLOAT_cfVCF(A,B)
+#else
+#define    FLOAT_cfVCF(A,B) FORTRAN_REAL B = A;
+#endif
+#define      INT_cfVCF(A,B)
+#define  LOGICAL_cfVCF(A,B)
+#define     LONG_cfVCF(A,B)
+#define    SHORT_cfVCF(A,B)
+
+/* 980416
+   Cast (void (*)(CF_NULL_PROTO)) causes SunOS CC 4.2 occasionally to barf,
+   while the following equivalent typedef is fine.
+   For consistency use the typedef on all machines.
+ */
+typedef void (*cfCAST_FUNCTION)(CF_NULL_PROTO);
+
+#define VCF(TN,I)       _Icf4(4,V,TN,_(A,I),_(B,I),F)
+#define VVCF(TN,AI,BI)  _Icf4(4,V,TN,AI,BI,S)
+#define        INT_cfV(T,A,B,F) _(VCF_INT_,F)(T,A,B)
+#define       INTV_cfV(T,A,B,F)
+#define      INTVV_cfV(T,A,B,F)
+#define     INTVVV_cfV(T,A,B,F)
+#define    INTVVVV_cfV(T,A,B,F)
+#define   INTVVVVV_cfV(T,A,B,F)
+#define  INTVVVVVV_cfV(T,A,B,F)
+#define INTVVVVVVV_cfV(T,A,B,F)
+#define PINT_cfV(      T,A,B,F) _(T,_cfVP)(A,B)
+#define PVOID_cfV(     T,A,B,F)
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
+#define    ROUTINE_cfV(T,A,B,F) void (*B)(CF_NULL_PROTO) = (cfCAST_FUNCTION)A;
+#else
+#define    ROUTINE_cfV(T,A,B,F)
+#endif
+#define     SIMPLE_cfV(T,A,B,F)
+#ifdef vmsFortran
+#define     STRING_cfV(T,A,B,F) static struct {fstring f; unsigned clen;} B =  \
+                                       {{0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL},0};
+#define    PSTRING_cfV(T,A,B,F) static fstring B={0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL};
+#define    STRINGV_cfV(T,A,B,F) static fstringvector B =                       \
+  {sizeof(A),DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,1,1,1},1,0,NULL,0,{1,0}};
+#define   PSTRINGV_cfV(T,A,B,F) static fstringvector B =                       \
+          {0,DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,1,1,1},1,0,NULL,0,{1,0}};
+#else
+#define     STRING_cfV(T,A,B,F) struct {unsigned int clen, flen;} B;
+#define    STRINGV_cfV(T,A,B,F) struct {char *s, *fs; unsigned flen;} B;
+#define    PSTRING_cfV(T,A,B,F) int     B;
+#define   PSTRINGV_cfV(T,A,B,F) struct{char *fs; unsigned int sizeofA,flen;}B;
+#endif
+#define    ZTRINGV_cfV(T,A,B,F)  STRINGV_cfV(T,A,B,F)
+#define   PZTRINGV_cfV(T,A,B,F) PSTRINGV_cfV(T,A,B,F)
+
+/* Note that the actions of the A table were performed inside the AA table.
+   VAX Ultrix vcc, and HP-UX cc, didn't evaluate arguments to functions left to
+   right, so we had to split the original table into the current robust two. */
+#define ACF(NAME,TN,AI,I)      _(TN,_cfSTR)(4,A,NAME,I,AI,_(B,I),0)
+#define   DEFAULT_cfA(M,I,A,B)
+#define   LOGICAL_cfA(M,I,A,B) B=C2FLOGICAL(B);
+#define  PLOGICAL_cfA(M,I,A,B) A=C2FLOGICAL(A);
+#define    STRING_cfA(M,I,A,B)  STRING_cfC(M,I,A,B,sizeof(A))
+#define   PSTRING_cfA(M,I,A,B) PSTRING_cfC(M,I,A,B,sizeof(A))
+#ifdef vmsFortran
+#define  AATRINGV_cfA(    A,B, sA,filA,silA)                                   \
+ initfstr(B,_cf_malloc((sA)-(filA)),(filA),(silA)-1),                          \
+          c2fstrv(A,B.dsc$a_pointer,(silA),(sA));
+#define APATRINGV_cfA(    A,B, sA,filA,silA)                                   \
+ initfstr(B,A,(filA),(silA)-1),c2fstrv(A,A,(silA),(sA));
+#else
+#define  AATRINGV_cfA(    A,B, sA,filA,silA)                                   \
+     (B.s=_cf_malloc((sA)-(filA)),B.fs=c2fstrv(A,B.s,(B.flen=(silA)-1)+1,(sA)));
+#define APATRINGV_cfA(    A,B, sA,filA,silA)                                   \
+ B.fs=c2fstrv(A,A,(B.flen=(silA)-1)+1,B.sizeofA=(sA));
+#endif
+#define   STRINGV_cfA(M,I,A,B)                                                 \
+    AATRINGV_cfA((char *)A,B,sizeof(A),firstindexlength(A),secondindexlength(A))
+#define  PSTRINGV_cfA(M,I,A,B)                                                 \
+   APATRINGV_cfA((char *)A,B,sizeof(A),firstindexlength(A),secondindexlength(A))
+#define   ZTRINGV_cfA(M,I,A,B)  AATRINGV_cfA( (char *)A,B,                     \
+                    (_3(M,_ELEMS_,I))*(( _3(M,_ELEMLEN_,I))+1),                \
+                              (_3(M,_ELEMS_,I)),(_3(M,_ELEMLEN_,I))+1)
+#define  PZTRINGV_cfA(M,I,A,B) APATRINGV_cfA( (char *)A,B,                     \
+                    (_3(M,_ELEMS_,I))*(( _3(M,_ELEMLEN_,I))+1),                \
+                              (_3(M,_ELEMS_,I)),(_3(M,_ELEMLEN_,I))+1)
+
+#define    PBYTE_cfAAP(A,B) &A
+#define  PDOUBLE_cfAAP(A,B) &A
+#define   PFLOAT_cfAAP(A,B) FLOATVVVVVVV_cfPP &A
+#define     PINT_cfAAP(A,B) &A
+#define PLOGICAL_cfAAP(A,B) B= &A         /* B used to keep a common W table. */
+#define    PLONG_cfAAP(A,B) &A
+#define   PSHORT_cfAAP(A,B) &A
+
+#define AACF(TN,AI,I,C) _SEP_(TN,C,cfCOMMA) _Icf(3,AA,TN,AI,_(B,I))
+#define        INT_cfAA(T,A,B) &B
+#define       INTV_cfAA(T,A,B) _(T,VVVVVV_cfPP) A
+#define      INTVV_cfAA(T,A,B) _(T,VVVVV_cfPP)  A[0]
+#define     INTVVV_cfAA(T,A,B) _(T,VVVV_cfPP)   A[0][0]
+#define    INTVVVV_cfAA(T,A,B) _(T,VVV_cfPP)    A[0][0][0]
+#define   INTVVVVV_cfAA(T,A,B) _(T,VV_cfPP)     A[0][0][0][0]
+#define  INTVVVVVV_cfAA(T,A,B) _(T,V_cfPP)      A[0][0][0][0][0]
+#define INTVVVVVVV_cfAA(T,A,B) _(T,_cfPP)       A[0][0][0][0][0][0]
+#define       PINT_cfAA(T,A,B) _(T,_cfAAP)(A,B)
+#define      PVOID_cfAA(T,A,B) (void *) A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define    ROUTINE_cfAA(T,A,B) &B
+#else
+#define    ROUTINE_cfAA(T,A,B) (cfCAST_FUNCTION)A
+#endif
+#define     STRING_cfAA(T,A,B)  STRING_cfCC(T,A,B)
+#define    PSTRING_cfAA(T,A,B) PSTRING_cfCC(T,A,B)
+#ifdef vmsFortran
+#define    STRINGV_cfAA(T,A,B) &B
+#else
+#ifdef CRAYFortran
+#define    STRINGV_cfAA(T,A,B) _cptofcd(B.fs,B.flen)
+#else
+#define    STRINGV_cfAA(T,A,B) B.fs
+#endif
+#endif
+#define   PSTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
+#define    ZTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
+#define   PZTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
+
+#if defined(vmsFortran) || defined(CRAYFortran)
+#define JCF(TN,I)
+#define KCF(TN,I)
+#else
+#define JCF(TN,I)    _(TN,_cfSTR)(1,J,_(B,I), 0,0,0,0)
+#if defined(AbsoftUNIXFortran)
+#define  DEFAULT_cfJ(B) ,0
+#else
+#define  DEFAULT_cfJ(B)
+#endif
+#define  LOGICAL_cfJ(B) DEFAULT_cfJ(B)
+#define PLOGICAL_cfJ(B) DEFAULT_cfJ(B)
+#define   STRING_cfJ(B) ,B.flen
+#define  PSTRING_cfJ(B) ,B
+#define  STRINGV_cfJ(B) STRING_cfJ(B)
+#define PSTRINGV_cfJ(B) STRING_cfJ(B)
+#define  ZTRINGV_cfJ(B) STRING_cfJ(B)
+#define PZTRINGV_cfJ(B) STRING_cfJ(B)
+
+/* KCF is identical to DCF, except that KCF ZTRING is not empty. */
+#define KCF(TN,I)    _(TN,_cfSTR)(1,KK,_(B,I), 0,0,0,0)
+#if defined(AbsoftUNIXFortran)
+#define  DEFAULT_cfKK(B) , unsigned B
+#else
+#define  DEFAULT_cfKK(B)
+#endif
+#define  LOGICAL_cfKK(B) DEFAULT_cfKK(B)
+#define PLOGICAL_cfKK(B) DEFAULT_cfKK(B)
+#define   STRING_cfKK(B) , unsigned B
+#define  PSTRING_cfKK(B) STRING_cfKK(B)
+#define  STRINGV_cfKK(B) STRING_cfKK(B)
+#define PSTRINGV_cfKK(B) STRING_cfKK(B)
+#define  ZTRINGV_cfKK(B) STRING_cfKK(B)
+#define PZTRINGV_cfKK(B) STRING_cfKK(B)
+#endif
+
+#define WCF(TN,AN,I)      _(TN,_cfSTR)(2,W,AN,_(B,I), 0,0,0)
+#define  DEFAULT_cfW(A,B)
+#define  LOGICAL_cfW(A,B)
+#define PLOGICAL_cfW(A,B) *B=F2CLOGICAL(*B);
+#define   STRING_cfW(A,B) (A[B.clen]!='\0'?A[B.clen]='\0':0); /* A?="constnt"*/
+#define  PSTRING_cfW(A,B) kill_trailing(A,' ');
+#ifdef vmsFortran
+#define  STRINGV_cfW(A,B) _cf_free(B.dsc$a_pointer);
+#define PSTRINGV_cfW(A,B)                                                      \
+  vkill_trailing(f2cstrv((char*)A, (char*)A,                                   \
+                           B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0]),     \
+                   B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0], ' ');
+#else
+#define  STRINGV_cfW(A,B) _cf_free(B.s);
+#define PSTRINGV_cfW(A,B) vkill_trailing(                                      \
+         f2cstrv((char*)A,(char*)A,B.flen+1,B.sizeofA), B.flen+1,B.sizeofA,' ');
+#endif
+#define  ZTRINGV_cfW(A,B)      STRINGV_cfW(A,B)
+#define PZTRINGV_cfW(A,B)     PSTRINGV_cfW(A,B)
+
+#define   NCF(TN,I,C)       _SEP_(TN,C,cfCOMMA) _Icf(2,N,TN,_(A,I),0) 
+#define  NNCF(TN,I,C)        UUCF(TN,I,C)
+#define NNNCF(TN,I,C)       _SEP_(TN,C,cfCOLON) _Icf(2,N,TN,_(A,I),0) 
+#define        INT_cfN(T,A) _(T,VVVVVVV_cfTYPE) * A
+#define       INTV_cfN(T,A) _(T,VVVVVV_cfTYPE)  * A
+#define      INTVV_cfN(T,A) _(T,VVVVV_cfTYPE)   * A
+#define     INTVVV_cfN(T,A) _(T,VVVV_cfTYPE)    * A
+#define    INTVVVV_cfN(T,A) _(T,VVV_cfTYPE)     * A
+#define   INTVVVVV_cfN(T,A) _(T,VV_cfTYPE)      * A
+#define  INTVVVVVV_cfN(T,A) _(T,V_cfTYPE)       * A
+#define INTVVVVVVV_cfN(T,A) _(T,_cfTYPE)        * A
+#define       PINT_cfN(T,A) _(T,_cfTYPE)        * A
+#define      PVOID_cfN(T,A) void *                A
+#if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
+#define    ROUTINE_cfN(T,A) void (**A)(CF_NULL_PROTO)
+#else
+#define    ROUTINE_cfN(T,A) void ( *A)(CF_NULL_PROTO)
+#endif
+#ifdef vmsFortran
+#define     STRING_cfN(T,A) fstring *             A
+#define    STRINGV_cfN(T,A) fstringvector *       A
+#else
+#ifdef CRAYFortran
+#define     STRING_cfN(T,A) _fcd                  A
+#define    STRINGV_cfN(T,A) _fcd                  A
+#else
+#define     STRING_cfN(T,A) char *                A
+#define    STRINGV_cfN(T,A) char *                A
+#endif
+#endif
+#define    PSTRING_cfN(T,A)   STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
+#define   PNSTRING_cfN(T,A)   STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
+#define   PPSTRING_cfN(T,A)   STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
+#define   PSTRINGV_cfN(T,A)  STRINGV_cfN(T,A)
+#define    ZTRINGV_cfN(T,A)  STRINGV_cfN(T,A)
+#define   PZTRINGV_cfN(T,A) PSTRINGV_cfN(T,A)
+
+
+/* Apollo 6.7, CRAY, old Sun, VAX/Ultrix vcc/cc and new ultrix
+   can't hack more than 31 arg's.
+   e.g. ultrix >= 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 */
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/gribsize.incl
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/gribsize.incl	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/gribsize.incl	(revision 17)
@@ -0,0 +1,3 @@
+#define IGRIBXMAX 361
+#define JGRIBXMAX 181
+#define KGRIBXMAX 38
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/read_grib.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/read_grib.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/read_grib.c	(revision 17)
@@ -0,0 +1,2462 @@
+ /**************************************************************************
+ * 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 <stdio.h>
+#include <string.h>
+#include <stdlib.h>
+#include <math.h>
+#include <limits.h>
+#ifdef MACOS
+#include "/usr/include/time.h"
+#else
+#include <time.h>
+#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(&century,
+		     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<numfinallevels; i++) {
+	contains_level = 0;
+	for (j=0; j<levelnum[parmnum]; j++) {
+	  if (finallevels[i] == tmplevels[parmnum][j]) {
+	    contains_level = 1;
+	    break;
+	  }
+	}
+	if (!contains_level) {
+	  remove_element(finallevels,i,numfinallevels);
+	  numfinallevels--;
+	  i--;
+	}
+      }
+    }
+
+  }
+
+  /* 
+   * Sort the numfinallevels array into descending order. Use straight 
+   * insertion.
+   */
+  for (j=1; j<numfinallevels; j++) {
+    tmpval = finallevels[j];
+    for (i=j-1; 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; j<ysize; j++) {
+	if (gds->head.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;
+ #ifdef _WIN32
+   localtime_s(&endtp, &time);
+ #else
+   localtime_r(&time, &endtp);
+ #endif
+  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; i<gribinfo->num_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,&center,&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;
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/read_grib.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/read_grib.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/read_grib.h	(revision 17)
@@ -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);
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/test_advance_time_str.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/test_advance_time_str.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/test_advance_time_str.c	(revision 17)
@@ -0,0 +1,13 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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);
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/test_rg_gribmap.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/test_rg_gribmap.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/test_rg_gribmap.c	(revision 17)
@@ -0,0 +1,36 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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);
+
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/write_grib.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/write_grib.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/grib1_util/write_grib.c	(revision 17)
@@ -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 <stdio.h>
+#include <stdlib.h>
+#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<geom_in.nx; i++) {
+    for (j=0; j<geom_in.ny; j++) {
+      data_one_d[i+j*geom_in.nx] = data[j][i];
+    }
+  }
+
+  status = init_gribhdr(&gh,errmsg);
+  if (status != 0) {
+    fprintf (stderr,"rg_fwrite_grib: %s",errmsg);
+    return -1;
+  }
+
+  status = grib_enc(data_input,user_input,geom_in,data_one_d,gh,errmsg);
+  if (status != 0) {
+    fprintf (stderr,"rg_fwrite_grib: %s",errmsg);
+    return -1;
+  }
+
+  status = gribhdr2file(gh,fid,errmsg);
+  if (status != 0) {
+    fprintf (stderr,"rg_fwrite_grib: %s",errmsg);
+    return -1;
+  }
+
+  free_gribhdr(&gh);
+
+  return 1;
+  
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/gribmap.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/gribmap.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/gribmap.c	(revision 17)
@@ -0,0 +1,499 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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", &center,&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;
+
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/gribmap.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/gribmap.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/gribmap.h	(revision 17)
@@ -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 *);
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/io_grib1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/io_grib1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/io_grib1.F	(revision 17)
@@ -0,0 +1,3554 @@
+!*-----------------------------------------------------------------------------
+!*
+!*  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   = 30 
+  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                                  :: this_domain = 0
+  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 (prevdata), DIMENSION(500)          :: lastdata
+
+  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
+
+  character*120, dimension(maxDomains)     :: lastDateStr
+
+  TYPE (prestype), dimension(maxDomains)   :: pressure
+  TYPE (prestype), dimension(maxDomains)   :: geopotential
+
+  integer                                  :: center, subcenter, parmtbl
+
+  character(len=15000), dimension(firstFileHandle:maxFileHandles) :: td_output
+  character(len=15000), dimension(firstFileHandle: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 = ''
+    geopotential(i)%newtime = .false.
+    geopotential(i)%lastDateStr = ''
+    lastDateStr(i) = ''
+  enddo
+
+  lastdata%fcst_secs_rainc = 0
+  lastdata%fcst_secs_rainnc = 0
+  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//'<METADATA>'//lf,ierr)
+  outstring = &
+       '<!-- The following are fields that were supplied to the WRF I/O API.'//lf//&
+       'Many variables (but not all) are redundant with the variables within '//lf//&
+       'the grib headers.  They are stored here, as METADATA, so that the '//lf//&
+       'WRF I/O API has simple access to these variables.-->'
+  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), '</METADATA>'//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 , DateStrIn , 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"
+#include "wrf_projection.h"
+  INTEGER ,       INTENT(IN)    :: DataHandle 
+  CHARACTER*(*) :: DateStrIn
+  CHARACTER(DateStrLen) :: 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
+  logical :: new_domain
+  real    :: region_center_lat, region_center_lon
+  integer :: dom_xsize, dom_ysize;
+  integer :: ierr
+  logical :: already_have_domain
+
+  call wrf_debug ( DEBUG , 'Entering ext_gr1_write_field for parameter'//VarName)
+
+  !
+  ! If DateStr is all 0's, we reset it to StartDate (if StartDate exists).  
+  !   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
+     if (StartDate .ne. '') then
+        DateStr = TRIM(StartDate)
+     else
+        DateStr = '0001-01-01_00:00:00'
+     endif
+  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.
+  !
+  new_domain = .false.
+  already_have_domain = .false.
+  do idx = 1, max_domain
+     if (this_domain .eq. domains(idx)) then
+        already_have_domain = .true.
+     endif
+  enddo
+  if (.NOT. already_have_domain) then
+     max_domain = max_domain + 1
+     domains(max_domain) = this_domain
+     new_domain = .true.
+  endif
+
+  !
+  ! If the time has changed, we open a new file.  This is a kludge to get
+  !   around slowness in WRF that occurs when opening a new data file the
+  !   standard way.
+  !
+#ifdef GRIB_ONE_TIME_PER_FILE
+  if (lastDateStr(this_domain) .ne. DateStr) then
+     write(DataFile(DataHandle),'(A8,i2.2,A1,A19)') 'wrfout_d',this_domain,'_',DateStr
+     call ext_gr1_ioclose ( DataHandle, Status )
+     CALL open_file(TRIM(DataFile(DataHandle)), 'w', FileFd(DataHandle), ierr)
+     if (ierr .ne. 0) then
+        print *,'Could not open new file: ',DataFile(DataHandle)
+        print *,'  Appending to old file.'
+     else
+        ! Just set used back to .true. here, since ioclose set it to false.
+        used(DataHandle) = .true.
+     endif
+     td_output(DataHandle) = ''
+  endif
+  lastDateStr(this_domain) = DateStr
+#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
+     ALLOCATE(lastdata(this_domain)%rainc(xsize,ysize))
+     lastdata(this_domain)%rainc(:,:) = 0.0
+     ALLOCATE(lastdata(this_domain)%rainnc(xsize,ysize))
+     lastdata(this_domain)%rainnc(:,:) = 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
+
+  !
+  ! Handle case of polare stereographic centered on pole.  In that case,
+  !   always set center lon to be the projection central longitude.
+  !
+  if ((projection .eq. WRF_POLAR_STEREO) .AND. &
+       (abs(center_lat - 90.0) < 0.01)) then
+     center_lon = proj_central_lon
+  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
+
+
+#ifdef OUTPUT_FULL_PRESSURE
+
+     ! 
+     ! The following is a kludge to output full pressure instead of the two 
+     !  fields of base-state pressure and pressure perturbation.
+     !
+     ! This code can be turned on by adding -DOUTPUT_FULL_PRESSURE to the 
+     !  compile line
+     !
+     
+     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
+#endif
+
+#ifdef OUTPUT_FULL_GEOPOTENTIAL
+
+     ! 
+     ! The following is a kludge to output full geopotential height instead 
+     !  of the two fields of base-state geopotential and perturbation 
+     !  geopotential.
+     !
+     ! This code can be turned on by adding -DOUTPUT_FULL_GEOPOTENTIAL to the 
+     !  compile line
+     !
+     
+     if ((OutName .eq. 'PHB') .or. (OutName.eq.'PH')) 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 geopotential values (this variable holds 
+        !   geopotential to be used 
+        !   later to sum base-state and perturbation to get full 
+        !   geopotential).
+        !
+
+        if (.not. ASSOCIATED(geopotential(this_domain)%vals)) then
+           ALLOCATE(geopotential(this_domain)%vals(MemoryStart(1):MemoryEnd(1), &
+                MemoryStart(2):MemoryEnd(2),MemoryStart(3):MemoryEnd(3)))
+        endif
+        if (DateStr .NE. &
+             geopotential(this_domain)%lastDateStr) then
+           geopotential(this_domain)%newtime = .true.
+        endif
+        if (geopotential(this_domain)%newtime) then
+           geopotential(this_domain)%vals = Field(1,:,:,:)
+           geopotential(this_domain)%newtime = .false.
+           output = .false.
+        else 
+           output = .true.
+        endif
+        geopotential(this_domain)%lastDateStr=DateStr
+     endif
+#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. 'RAINNCV') then
+              ! Convert time-step precip to precip rate.
+              data = data/timestep
+              accum_period = 0
+           else
+              accum_period = 0
+           endif
+
+#ifdef OUTPUT_FULL_PRESSURE
+           !
+           ! Computation of full-pressure off by default 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
+#endif
+
+#ifdef OUTPUT_FULL_GEOPOTENTIAL
+           !
+           ! Computation of full-geopotential off by default since there are 
+           !  uses for base-state and perturbation (i.e., restarts
+           !
+            if ((OutName .eq. 'PHB') .or. (OutName.eq.'PH')) then
+               if (idx3 .eq. 1) then
+                  data = data + &
+                       geopotential(this_domain)%vals(z, &
+                       patchstart(2):patchend(2),patchstart(3):patchend(3))
+               elseif (idx3 .eq. 2) then
+                  data = data + &
+                       geopotential(this_domain)%vals(patchstart(1):patchend(1), &
+                       z,patchstart(3):patchend(3))
+               elseif (idx3 .eq. 3) then
+                  data = data + &
+                       geopotential(this_domain)%vals(patchstart(1):patchend(1), &
+                       patchstart(2):patchend(2),z)
+               else
+                  call wrf_message ('error in idx3, continuing')
+               endif
+
+               OutName = 'PHP'
+            endif
+#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)
+           
+           !
+           ! Here, we copy data to a temporary array.  After write_grib,
+           !    we copy back from the temporary array to the permanent
+           !    array.  write_grib modifies data.  For certain fields that
+           !    we use below, we want the original (unmodified) data 
+           !    values.  This kludge assures that we have the original
+           !    values.
+           !
+
+           if ((OutName .eq. 'RAINC') .or. (OutName .eq. 'RAINNC') .or. &
+                (OutName .eq. 'SNOWH')) then
+              tmpdata(:,:) = data(:,:)
+           endif
+
+           CALL write_grib(grid_info, FileFd(DataHandle), data)
+
+           if ((OutName .eq. 'RAINC') .or. (OutName .eq. 'RAINNC') .or. &
+                (OutName .eq. 'SNOWH')) then
+              data(:,:) = tmpdata(:,:)
+           endif
+
+           CALL free_grid_info(grid_info)
+           
+           !
+           ! If this is the total accumulated rain, call write_grib again 
+           !   to output the accumulation since the last output time as well.
+           !   This is somewhat of a kludge to meet the requirements of PF.
+           !
+           if ((OutName .eq. 'RAINC') .or. (OutName .eq. 'RAINNC') .or. &
+                (OutName .eq. 'SNOWH')) then
+              if (OutName .eq. 'RAINC') then
+                 data(:,:) = data(:,:) - lastdata(this_domain)%rainc(:,:)
+                 lastdata(this_domain)%rainc(:,:) = tmpdata(:,:)
+                 accum_period = fcst_secs - &
+                      lastdata(this_domain)%fcst_secs_rainc
+                 lastdata(this_domain)%fcst_secs_rainc = fcst_secs
+                 TmpVarName = 'ACPCP'
+              else if (OutName .eq. 'RAINNC') then
+                 tmpdata(:,:) = data(:,:)
+                 data(:,:) = data(:,:) - lastdata(this_domain)%rainnc(:,:)
+                 lastdata(this_domain)%rainnc(:,:) = tmpdata(:,:)
+                 accum_period = fcst_secs - &
+                      lastdata(this_domain)%fcst_secs_rainnc
+                 lastdata(this_domain)%fcst_secs_rainnc = fcst_secs
+                 TmpVarName = 'NCPCP'
+              else if (OutName .eq. 'SNOWH') then
+                 if (fcst_secs .eq. 0) then
+                    firstdata(this_domain)%snod(:,:) = data(:,:)
+                 endif
+                 data(:,:) = data(:,:) - firstdata(this_domain)%snod(:,:)
+                 TmpVarName = 'SNOWCU'
+              endif
+
+              CALL load_grid_info(TmpVarName, 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)
+           endif
+
+        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_grib(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')
+
+  call wrf_message ( 'WARNING: ext_gr1_get_next_var is not supported.')
+
+  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)
+  else if (Element == 'WG_GRID_ID') then
+     wg_grid_id = Data(1)
+  else if (Element == 'GRID_ID') then
+     this_domain = 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
+        !
+        ! Remove duplicate levels, caused by multiple time periods in a 
+        ! single file.
+        !
+        if (eta_levels(idx) == eta_levels(idx-1)) eta_levels(idx) = 0.0
+        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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_grib1_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_grib1_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_grib1_routines.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_gribmap.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_gribmap.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_gribmap.F90	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_grid_info.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_grid_info.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_grid_info.F90	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_io_grib1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_io_grib1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_io_grib1.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_read_gribmap.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_read_gribmap.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_read_gribmap.c	(revision 17)
@@ -0,0 +1,23 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+#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",&center,&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);
+
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_write_grib.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_write_grib.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/test_write_grib.c	(revision 17)
@@ -0,0 +1,87 @@
+#include <stdio.h>
+#include <stdlib.h>
+#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<xdim*ydim; j++) {
+      /*
+      data[j] = rand()/RAND_MAX;
+      */
+      data[j] = j/(float)ydim;
+    }
+    fprintf(stderr,"Writing grib record %d\n",i);
+    status = LOAD_GRID_INFO("TSK", datestr, &leveltype, &level, 
+		   &level2, &fcst_secs, &accum_period, &grid_id, &projection, 
+		   &xdim, &ydim, &center_lat, &center_lon, &dx, &dy, 
+		   &proj_central_lon, &south, &latin1, &latin2,
+		   &grib1_tables, &gridinfo, strlen("TSK"), strlen(datestr));
+      
+    WRITE_GRIB(&gridinfo, &filefd, data);
+    /*
+    status = WRITE_GRIB("ABC",&level,&level2,&leveltype,
+		datestr,&fcst_secs,&accum_period,
+		&projection,&grid_id,&xdim,&ydim,&center_lat,
+		&center_lon,&proj_central_lon,&dx,&dy,&south,&latin1,
+		&latin2,data,&grib_table_info,&filefd,8);
+    */
+    fprintf(stderr,"status: %d\n",status);
+
+  }
+
+  FREE_GRIBMAP(&grib1_tables);
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/trim.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/trim.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/trim.c	(revision 17)
@@ -0,0 +1,23 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+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);
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/wrf_status_codes.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/wrf_status_codes.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib1/wrf_status_codes.h	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/Makefile	(revision 17)
@@ -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<dir> tokens to specify where the dependent 
+#               libraries are, and -l<lib> 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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/README.io_grib2
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/README.io_grib2	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/README.io_grib2	(revision 17)
@@ -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_<x> 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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/Makefile	(revision 17)
@@ -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<dir> tokens to specify where the dependent 
+#               libraries are, and -l<lib> 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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/README
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/README	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/README	(revision 17)
@@ -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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/bacio.v1.3.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/bacio.v1.3.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/bacio.v1.3.c	(revision 17)
@@ -0,0 +1,545 @@
+/* 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 <stdio.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <unistd.h>
+#ifdef MACOS
+#include <sys/malloc.h>
+#else
+#include <malloc.h>
+#endif
+#include <ctype.h>
+#include <string.h>
+
+/* 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;
+  }
+} 
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/baciof.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/baciof.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/baciof.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/baciof.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/baciof.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/baciof.h	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/clib.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/clib.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/bacio-1.3/clib.h	(revision 17)
@@ -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 <stdlib.h>
+
+/* 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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/CHANGES
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/CHANGES	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/CHANGES	(revision 17)
@@ -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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/Makefile	(revision 17)
@@ -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<dir> tokens to specify where the dependent 
+#               libraries are, and -l<lib> 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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/README
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/README	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/README	(revision 17)
@@ -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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/addfield.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/addfield.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/addfield.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/addgrid.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/addgrid.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/addgrid.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/addlocal.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/addlocal.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/addlocal.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/cmplxpack.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/cmplxpack.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/cmplxpack.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/compack.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/compack.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/compack.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/comunpack.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/comunpack.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/comunpack.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/dec_jpeg2000.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/dec_jpeg2000.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/dec_jpeg2000.c	(revision 17)
@@ -0,0 +1,154 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "jasper/jasper.h"
+#include "proto.h"
+#define JAS_1_700_2
+
+#ifdef __64BIT__
+  typedef int g2int;
+#else
+  typedef long g2int;
+#endif
+
+#ifndef CRAY
+# ifdef NOUNDERSCORE
+#      define DEC_JPEG2000 dec_jpeg2000
+# else
+#   ifdef F2CSTYLE
+#      define DEC_JPEG2000 dec_jpeg2000__
+#   else
+#      define DEC_JPEG2000 dec_jpeg2000_
+#   endif
+# endif
+#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;i<pcmpt->height_;i++) 
+      for (j=0;j<pcmpt->width_;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;
+
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/dec_png.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/dec_png.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/dec_png.c	(revision 17)
@@ -0,0 +1,139 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <png.h>
+#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<clen;k++) {
+        cout[n]=*(row_pointers[j]+k);
+        n++;
+      }
+    }
+
+/*      Clean up   */
+
+    png_destroy_read_struct(&png_ptr, &info_ptr, &end_info);
+    return 0;
+
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/drstemplates.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/drstemplates.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/drstemplates.F	(revision 17)
@@ -0,0 +1,277 @@
+      module drstemplates
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! MODULE:    drstemplates 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2001-04-03
+!
+! ABSTRACT: This Fortran Module contains info on all the available 
+!   GRIB2 Data Representation Templates used in Section 5 (DRS).
+!   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 5.1 as an example )
+!
+!   This module also contains two subroutines.  Subroutine getdrstemplate
+!   returns the octet map for a specified Template number, and
+!   subroutine extdrstemplate 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
+! 2002-12-11  Gilbert - Added templates for JPEG2000 and PNG encoding
+!
+! USAGE:    use drstemplates
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+
+      integer,parameter :: MAXLEN=200,MAXTEMP=9
+
+      type drstemplate
+          integer :: template_num
+          integer :: mapdrslen
+          integer,dimension(MAXLEN) :: mapdrs
+          logical :: needext
+      end type drstemplate
+
+      type(drstemplate),dimension(MAXTEMP) :: templates
+
+      data templates(1)%template_num /0/     !  Simple Packing
+      data templates(1)%mapdrslen /5/ 
+      data templates(1)%needext /.false./
+      data (templates(1)%mapdrs(j),j=1,5) 
+     &                             /4,-2,-2,1,1/
+
+      data templates(2)%template_num /2/     !  Complex Packing
+      data templates(2)%mapdrslen /16/
+      data templates(2)%needext /.false./
+      data (templates(2)%mapdrs(j),j=1,16)
+     &                        /4,-2,-2,1,1,1,1,4,4,4,1,1,4,1,4,1/
+
+      data templates(3)%template_num /3/     !  Complex Packing - Spatial Diff
+      data templates(3)%mapdrslen /18/
+      data templates(3)%needext /.false./
+      data (templates(3)%mapdrs(j),j=1,18)
+     &                        /4,-2,-2,1,1,1,1,4,4,4,1,1,4,1,4,1,1,1/
+
+      data templates(4)%template_num /50/     !  Simple Packing - Spectral Data
+      data templates(4)%mapdrslen /5/
+      data templates(4)%needext /.false./
+      data (templates(4)%mapdrs(j),j=1,5)
+     &                         /4,-2,-2,1,4/
+
+      data templates(5)%template_num /51/    !  Complex Packing - Spectral Data
+      data templates(5)%mapdrslen /10/
+      data templates(5)%needext /.false./
+      data (templates(5)%mapdrs(j),j=1,10)
+     &                         /4,-2,-2,1,-4,2,2,2,4,1/
+
+      data templates(6)%template_num /40000/     !  JPEG2000 Encoding
+      data templates(6)%mapdrslen /7/ 
+      data templates(6)%needext /.false./
+      data (templates(6)%mapdrs(j),j=1,7) 
+     &                             /4,-2,-2,1,1,1,1/
+
+      data templates(7)%template_num /40010/     !  PNG Encoding
+      data templates(7)%mapdrslen /5/ 
+      data templates(7)%needext /.false./
+      data (templates(7)%mapdrs(j),j=1,5) 
+     &                             /4,-2,-2,1,1/
+
+      data templates(8)%template_num /40/     !  JPEG2000 Encoding
+      data templates(8)%mapdrslen /7/ 
+      data templates(8)%needext /.false./
+      data (templates(8)%mapdrs(j),j=1,7) 
+     &                             /4,-2,-2,1,1,1,1/
+
+      data templates(9)%template_num /41/     !  PNG Encoding
+      data templates(9)%mapdrslen /5/ 
+      data templates(9)%needext /.false./
+      data (templates(9)%mapdrs(j),j=1,5) 
+     &                             /4,-2,-2,1,1/
+
+!      data templates(5)%template_num /1/      !  Simple Packing - Matrix
+!      data templates(5)%mapdrslen /15/ 
+!      data templates(5)%needext /.true./
+!      data (templates(5)%mapdrs(j),j=1,15)
+!     &                        /4,-2,-2,1,1,1,4,2,2,1,1,1,1,1,1/
+
+
+      contains
+
+         integer function getdrsindex(number)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getdrsindex 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2001-06-28
+!
+! ABSTRACT: This function returns the index of specified Data 
+!   Representation Template 5.NN (NN=number) in array templates.
+!
+! PROGRAM HISTORY LOG:
+! 2001-06-28  Gilbert
+!
+! USAGE:    index=getdrsindex(number)
+!   INPUT ARGUMENT LIST:
+!     number   - NN, indicating the number of the Data Representation 
+!                Template 5.NN that is being requested.
+!
+! RETURNS:  Index of DRT 5.NN in array templates, if template exists.
+!           = -1, otherwise.
+!
+! REMARKS: None
+!
+! ATTRIBUTES:
+!   LANGUAGE: Fortran 90
+!   MACHINE:  IBM SP
+!
+!$$$
+           integer,intent(in) :: number
+
+           getdrsindex=-1
+
+           do j=1,MAXTEMP
+              if (number.eq.templates(j)%template_num) then
+                 getdrsindex=j
+                 return
+              endif
+           enddo
+
+         end function
+
+
+         subroutine getdrstemplate(number,nummap,map,needext,iret)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    getdrstemplate 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-11
+!
+! ABSTRACT: This subroutine returns DRS template information for a 
+!   specified Data Representation Template 5.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 getdrstemplate(number,nummap,map,needext,iret)
+!   INPUT ARGUMENT LIST:
+!     number   - NN, indicating the number of the Data Representation 
+!                Template 5.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 DRS.
+!     needext  - Logical variable indicating whether the Data Representation
+!                Template has to be extended.  
+!     ierr     - Error return code.
+!                0 = no error
+!                1 = Undefined Data Representation 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=getdrsindex(number)
+
+           if (index.ne.-1) then
+              nummap=templates(index)%mapdrslen
+              needext=templates(index)%needext
+              map(1:nummap)=templates(index)%mapdrs(1:nummap)
+           else
+             nummap=0
+             needext=.false.
+             print *,'getdrstemplate: DRS Template ',number,
+     &               ' not defined.'
+             iret=1
+           endif
+
+         end subroutine
+
+         subroutine extdrstemplate(number,list,nummap,map)
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .                                       .
+! SUBPROGRAM:    extdrstemplate 
+!   PRGMMR: Gilbert         ORG: W/NP11    DATE: 2000-05-11
+!
+! ABSTRACT: This subroutine generates the remaining octet map for a
+!   given Data Representation 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 extdrstemplate(number,list,nummap,map)
+!   INPUT ARGUMENT LIST:
+!     number   - NN, indicating the number of the Data Representation 
+!                Template 5.NN that is being requested.
+!     list()   - The list of values for each entry in the 
+!                the Data Representation Template 5.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=getdrsindex(number)
+           if (index.eq.-1) return
+
+           if ( .not. templates(index)%needext ) return
+           nummap=templates(index)%mapdrslen
+           map(1:nummap)=templates(index)%mapdrs(1:nummap)
+
+           if ( number.eq.1 ) then
+              N=list(11)+list(13)
+              do i=1,N
+                map(nummap+i)=4
+              enddo
+              nummap=nummap+N
+           endif
+
+         end subroutine
+
+      end module
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/enc_jpeg2000.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/enc_jpeg2000.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/enc_jpeg2000.c	(revision 17)
@@ -0,0 +1,196 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "jasper/jasper.h"
+#define JAS_1_700_2
+#include "proto.h"
+
+#ifdef __64BIT__
+  typedef int g2int;
+#else
+  typedef long g2int;
+#endif
+
+#ifndef CRAY
+# ifdef NOUNDERSCORE
+#      define ENC_JPEG2000 enc_jpeg2000
+# else
+#   ifdef F2CSTYLE
+#      define ENC_JPEG2000 enc_jpeg2000__
+#   else
+#      define ENC_JPEG2000 enc_jpeg2000_
+#   endif
+# endif
+#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);
+
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/enc_png.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/enc_png.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/enc_png.c	(revision 17)
@@ -0,0 +1,133 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <png.h>
+#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;k<length;j++,k++) ptr[j]=data[k];*/
+     memcpy(ptr+offset,data,length);
+     mem->stream_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;
+
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/g2grids.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/g2grids.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/g2grids.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gb_info.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gb_info.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gb_info.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gbytesc.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gbytesc.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gbytesc.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gdt2gds.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gdt2gds.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gdt2gds.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getdim.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getdim.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getdim.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getfield.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getfield.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getfield.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getg2i.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getg2i.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getg2i.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getg2ir.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getg2ir.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getg2ir.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2l.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2l.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2l.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2p.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2p.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2p.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2r.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2r.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2r.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2rp.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2rp.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2rp.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2s.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2s.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getgb2s.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getidx.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getidx.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getidx.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getlocal.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getlocal.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getlocal.F	(revision 17)
@@ -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
+
+
+
+
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getpoly.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getpoly.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/getpoly.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gettemplates.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gettemplates.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gettemplates.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_free.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_free.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_free.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_getfld.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_getfld.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_getfld.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack1.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack2.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack2.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack2.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack3.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack3.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack3.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack4.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack4.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack4.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack5.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack5.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack5.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack6.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack6.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack6.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack7.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack7.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gf_unpack7.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/grib2.doc
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/grib2.doc	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/grib2.doc	(revision 17)
@@ -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$$$
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gribcreate.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gribcreate.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gribcreate.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gribend.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gribend.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gribend.F	(revision 17)
@@ -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
+
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gribinfo.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gribinfo.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gribinfo.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gribmod.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gribmod.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gribmod.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gridtemplates.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gridtemplates.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/gridtemplates.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/ixgb2.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/ixgb2.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/ixgb2.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/jpcpack.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/jpcpack.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/jpcpack.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/jpcunpack.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/jpcunpack.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/jpcunpack.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/misspack.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/misspack.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/misspack.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/mkieee.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/mkieee.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/mkieee.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/mova2i.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/mova2i.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/mova2i.c	(revision 17)
@@ -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);
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/pack_gp.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/pack_gp.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/pack_gp.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/params.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/params.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/params.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/pdstemplates.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/pdstemplates.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/pdstemplates.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/pngpack.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/pngpack.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/pngpack.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/pngunpack.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/pngunpack.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/pngunpack.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/proto.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/proto.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/proto.h	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/putgb2.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/putgb2.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/putgb2.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/rdieee.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/rdieee.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/rdieee.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/realloc.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/realloc.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/realloc.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/reduce.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/reduce.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/reduce.F	(revision 17)
@@ -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
+      
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/simpack.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/simpack.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/simpack.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/simunpack.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/simunpack.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/simunpack.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/skgb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/skgb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/skgb.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/specpack.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/specpack.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/specpack.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/specunpack.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/specunpack.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/specunpack.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/utest/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/utest/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/utest/Makefile	(revision 17)
@@ -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<dir> tokens to specify where the dependent 
+#               libraries are, and -l<lib> 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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/utest/test_g2lib.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/utest/test_g2lib.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/g2lib/utest/test_g2lib.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/grib2tbls_types.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/grib2tbls_types.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/grib2tbls_types.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/io_grib2.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/io_grib2.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/io_grib2.F	(revision 17)
@@ -0,0 +1,4530 @@
+!*-----------------------------------------------------------------------------
+!*
+!*  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_grib(MemoryOrder, di, FieldType, Field, &
+                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
+                MemoryStart(3), MemoryEnd(3), &
+                gfld%fld, zsize)
+        else
+           CALL Transpose_grib(MemoryOrder, di, FieldType, Field, &
+                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), &
+                MemoryStart(3), MemoryEnd(3), &
+                gfld%fld, dim3, ysize,xsize)
+        endif
+
+        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                           :: 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) = 0       ! 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) &
+       .or. (wrf_projection .eq. WRF_CASSINI)) then
+     incrx = (dx/ERADIUS) * RAD_TO_DEG
+     incry = (dy/ERADIUS) * RAD_TO_DEG
+  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,WRF_CASSINI)
+     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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/read_grib2map.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/read_grib2map.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/read_grib2map.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/test_read_grib2map.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/test_read_grib2map.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib2/test_read_grib2map.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/Makefile	(revision 17)
@@ -0,0 +1,88 @@
+#------------------------------------------------------------------------------
+#  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.
+AR           = ar
+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<dir> tokens to specify where the dependent 
+#               libraries are, and -l<lib> 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 *.obj > /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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/TEST_RESULTS
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/TEST_RESULTS	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/TEST_RESULTS	(revision 17)
@@ -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.                                      |
++--------------------------------------------------------------+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/application_rules.mk
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/application_rules.mk	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/application_rules.mk	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/binary_rules.mk
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/binary_rules.mk	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/binary_rules.mk	(revision 17)
@@ -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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/compile_rules.mk
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/compile_rules.mk	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/compile_rules.mk	(revision 17)
@@ -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) $(TRADFLAG) $(SYS_F_INCLUDES) $(F_INCLUDES) $*.F > $*.f90
+	$(FC) $(SYS_F_INCLUDES) $(FCSUFFIX) $(F_INCLUDES) $(FCFLAGS) $(SYS_DEFINES) $(DEBUG) $(FORMAT) -c $*.f90
+
+.f90.o:
+	$(FC) $(SYS_F_INCLUDES) $(F_INCLUDES) $(FCFLAGS) $(SYS_DEFINES) $(DEBUG) $(FORMAT) -c $<
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/config_rules.mk
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/config_rules.mk	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/config_rules.mk	(revision 17)
@@ -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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/depend_rules.mk
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/depend_rules.mk	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/depend_rules.mk	(revision 17)
@@ -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;
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/library_rules.mk
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/library_rules.mk	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/library_rules.mk	(revision 17)
@@ -0,0 +1,191 @@
+#------------------------------------------------------------------------------
+#  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_<rulename> 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)
+	$(RANLIB) $(LIB_DEST)/lib$(LIB_NAME).a
+
+#
+#  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 *.obj *.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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/package_rules.mk
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/package_rules.mk	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/package_rules.mk	(revision 17)
@@ -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;
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/script_rules.mk
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/script_rules.mk	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/script_rules.mk	(revision 17)
@@ -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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/tcl_script_rules.mk
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/tcl_script_rules.mk	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/tcl_script_rules.mk	(revision 17)
@@ -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.
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/utest_rules.mk
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/utest_rules.mk	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/utest_rules.mk	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/utility_rules.mk
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/utility_rules.mk	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/build/utility_rules.mk	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/get_region_center.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/get_region_center.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/get_region_center.c	(revision 17)
@@ -0,0 +1,208 @@
+#include "get_region_center.h"
+#include "gridnav.h"
+#include <stdio.h>
+#include <stdlib.h>
+
+#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:
+    case WRF_CASSINI:
+      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(0);
+    }
+
+  /* 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(0);
+    }
+
+  /* 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(0);
+    }
+
+  *ierr = 0;
+  return(0);
+
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/get_region_center.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/get_region_center.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/get_region_center.h	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/gridnav.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/gridnav.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/gridnav.c	(revision 17)
@@ -0,0 +1,493 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include "gridnav.h"
+
+#define MISSING -999
+#define PI 3.1415927
+#define RAD_TO_DEG 57.29577951
+/* #define EARTH_RAD 6371.200 */
+#define EARTH_RAD 6370.000
+
+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;
+    double eps = 0.00001;
+
+    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->proj_transform.parm3 + 
+		gridnav->proj_transform.parm1;
+	    Y = (row - gridnav->grid.origin_row) * 
+		gridnav->proj_transform.parm3 +
+		gridnav->proj_transform.parm2 + eps;
+	    *lon = gridnav->proj_transform.parm5 * -1 * 
+		atan(X / Y) * RAD_TO_DEG + gridnav->proj.central_lon;
+	    *lat = 90 - 2 * RAD_TO_DEG *
+		atan(X / (2 * EARTH_RAD * 
+			  sin((*lon - gridnav->proj.central_lon ) / 
+			      RAD_TO_DEG) + eps) );
+	    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 = 2 * EARTH_RAD * tan ( (45 - fabs(lat)/2) / RAD_TO_DEG );
+	    Y = gridnav->proj_transform.parm5 * -1 * Rs * 
+		cos ((lon - gridnav->proj.central_lon) / RAD_TO_DEG);
+	    X = Rs * sin ((lon - gridnav->proj.central_lon) / RAD_TO_DEG);
+
+	    *row = (Y - gridnav->proj_transform.parm2) / 
+		gridnav->proj_transform.parm3 
+		+ gridnav->grid.origin_row;
+	    *column = (X - gridnav->proj_transform.parm1) / 
+		gridnav->proj_transform.parm3 
+		+ gridnav->grid.origin_column;
+	    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;
+    double r_not;
+    double r_truelat1;
+    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 = 
+                        fabs(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.central_lat > 0) 
+                {
+                    hemifactor = 1;
+                } 
+            else 
+                {
+                    hemifactor = -1;
+                }
+
+	    /* Calculate X for origin */
+	    r_not = 2 * EARTH_RAD * 
+		tan((45 - fabs(gridnav->grid.lat_origin) / 2) / RAD_TO_DEG);
+	    gridnav->proj_transform.parm1 =  
+		r_not * 
+		sin ( (gridnav->grid.lon_origin - gridnav->proj.central_lon) /
+		      RAD_TO_DEG);
+	    /* Calculate Y for origin */
+	    gridnav->proj_transform.parm2 = 
+		hemifactor * -1 * r_not * 
+		cos ( (gridnav->grid.lon_origin - gridnav->proj.central_lon) / 
+		      RAD_TO_DEG);
+	    /* Calculate grid spacing at pole */
+	    r_truelat1 = 2 * EARTH_RAD * 
+		tan((45 - fabs(gridnav->proj.truelat1) / 2) / RAD_TO_DEG);
+	    gridnav->proj_transform.parm3 = 
+		gridnav->grid.dx * r_truelat1 / 
+		( EARTH_RAD * cos (gridnav->proj.truelat1 / 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;
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/gridnav.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/gridnav.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/gridnav.h	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/io_grib_share.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/io_grib_share.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/io_grib_share.F	(revision 17)
@@ -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_grib(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_grib(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_grib
+
+!*****************************************************************************
+!
+! 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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/open_file.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/open_file.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/open_file.c	(revision 17)
@@ -0,0 +1,117 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <fcntl.h>
+ 
+#ifdef _WIN32
+#include <io.h>
+#endif
+
+#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)
+{
+#ifdef _WIN32
+  _commit(*fd);
+#else
+  fsync(*fd);
+#endif
+  return 0;
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/wrf_io_flags.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/wrf_io_flags.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/wrf_io_flags.h	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/wrf_projection.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/wrf_projection.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/wrf_projection.h	(revision 17)
@@ -0,0 +1,14 @@
+#define WRF_LATLON 0
+#define WRF_LAMBERT 1
+#define WRF_POLAR_STEREO 2
+#define WRF_MERCATOR 3
+#define WRF_GAUSS 4
+#define WRF_CYL 5
+#define WRF_CASSINI 6
+#define WRF_PS_WGS84 102
+#define WRF_ALBERS_NAD83 105
+#define WRF_ROTLL 203
+
+#define WRF_EARTH_RADIUS 6370
+#define PI 3.141593
+#define KM_TO_DEGREES 360. / (2. * PI * WRF_EARTH_RADIUS)
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/wrf_status_codes.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/wrf_status_codes.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_grib_share/wrf_status_codes.h	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_int/diffwrf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_int/diffwrf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_int/diffwrf.F	(revision 17)
@@ -0,0 +1,461 @@
+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=255) :: flnm
+  character(len=255) :: 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
+  write (6,FMT='(4A)') '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
+if(n.eq.0) n=1
+        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
+        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_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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_int/io_int.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_int/io_int.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_int/io_int.F90	(revision 17)
@@ -0,0 +1,1675 @@
+! (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
+  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
+      else
+          WRITE(mess,*)'skipping a code=',code,' in ext_int_get_var_info'
+          CALL wrf_message(mess)
+      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 )
+  USE module_ext_internal
+  IMPLICIT NONE
+#include "intio_tags.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 locDataHandle, code
+  CHARACTER*132 locElement, locVarName
+  IF ( int_valid_handle (DataHandle) ) THEN
+     IF ( int_handle_in_use( DataHandle ) ) THEN
+        READ( unit=DataHandle ) hdrbuf
+        code=hdrbuf(2)
+        IF ( code .NE. int_var_ti_integer ) THEN
+           BACKSPACE ( unit=DataHandle )
+           write(*,*) 'unexpected code=',code,' in ext_int_get_var_ti_integer'
+           Status = 1
+           return
+        ENDIF
+        CALL int_get_ti_header_integer_varname( hdrbuf, hdrbufsize, itypesize, typesize, &
+             locDataHandle, locElement, locVarName, Data, Outcount, code )
+     ELSE
+        Status = 1
+        write(*,*) 'int_handle_in_use(DataHandle)=.False. in ext_int_get_var_ti_integer'
+        return
+     ENDIF
+  ELSE
+     Status = 1
+     write(*,*) 'int_valid_handle(DataHandle)=.False. in ext_int_get_var_ti_integer'
+     return
+  ENDIF
+  Status = 0
+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 )
+  USE module_ext_internal
+  IMPLICIT NONE
+#include "intio_tags.h"
+  INTEGER ,       INTENT(IN)  :: DataHandle
+  CHARACTER*(*) :: Element
+  CHARACTER*(*) :: VarName 
+  integer ,            INTENT(IN) :: Data(*)
+  INTEGER ,       INTENT(IN)  :: Count
+  INTEGER ,       INTENT(OUT) :: Status
+  IF ( int_valid_handle (DataHandle) ) THEN
+    IF ( int_handle_in_use( DataHandle ) ) THEN
+      CALL int_gen_ti_header_integer_varname( hdrbuf, hdrbufsize, itypesize,4,  &
+                              DataHandle, TRIM(Element), TRIM(VarName), Data, Count, &
+                              int_var_ti_integer )
+      WRITE( unit=DataHandle ) hdrbuf
+    ENDIF
+  ENDIF
+  Status = 0
+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
+       code=hdrbuf(2)
+       IF ( code .NE. int_var_ti_char ) THEN
+          BACKSPACE ( unit=DataHandle )
+          Status = 1
+          return
+       ENDIF
+       CALL int_get_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
+            locDataHandle, locElement, locVarName, Data, code )
+    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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_int/makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_int/makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_int/makefile	(revision 17)
@@ -0,0 +1,63 @@
+#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
+			@ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \
+                          echo COMPILING io_int.F90 for 4DVAR ; \
+                          $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl io_int.f > io_int.f.tmp ; \
+                          mv io_int.f.tmp io_int.f ; \
+                        fi
+			$(FC) $(FFLAGS) -I. -I../ioapi_share -o $@ -c io_int.f
+			/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. -o $@ -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    ; \
+                        x=`echo "$(FC)" | awk '{print $$1}'` ; export x ; \
+                        if [ $$x = "gfortran" ] ; then \
+                          echo removing external declaration of iargc for gfortran ; \
+			  $(CPP1)  -I../ioapi_share diffwrf.F90 | sed '/integer *, *external.*iargc/d' > diffwrf.f  ; \
+                        else \
+			  $(CPP1)  -I../ioapi_share diffwrf.F90 > diffwrf.f  ; \
+                        fi ; \
+			$(FC) -c $(FFLAGS) -I../ioapi_share diffwrf.f    ; \
+			mv diffwrf.F90 diffwrf.F ; \
+			$(FC) $(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 *.obj *.i *.mod libwrfio_int.a diffwrf 
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/configure.wrf.example
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/configure.wrf.example	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/configure.wrf.example	(revision 17)
@@ -0,0 +1,536 @@
+# 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) \
+	   -DDA_CORE=$(WRF_DA_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	=	32768
+
+
+##############################################################################
+#### 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 $(WRF_SRC_ROOT_DIR)/arch/standard.sed
+SED_FTN = $(WRF_SRC_ROOT_DIR)/tools/standard.exe
+
+# 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 = $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90/module_utility.o
+# select -I options for external/io_esmf vs. external/esmf_time_f90
+ESMF_IO_INC         = -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90
+# select -I options for separately installed ESMF library, if present
+ESMF_MOD_INC        =  $(ESMF_IO_INC)
+# 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
+
+##############################################################################
+
+LIBWRFLIB = libwrflib.a
+
+
+#### Architecture specific settings ####
+
+# To enable over-decompostion with dmpar and dm+sm compiles, 
+# add -DALLOW_OVERDECOMP to ARCH_LOCAL, below. (not recommended)
+
+# Settings for Linux x86_64, PGI compiler with gcc  (dmpar)
+#
+DMPARALLEL      =        1
+OMPCPP          =       # -D_OPENMP
+OMP             =       # -mp -Minfo=mp
+SFC             =       pgf90
+SCC             =       gcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC) -DMPI2_SUPPORT
+FC              =        $(DM_FC)
+CC              =       $(DM_CC) -DFSEEKO64_OK 
+LD              =       $(FC)
+RWORDSIZE       =       $(NATIVE_RWORDSIZE)
+PROMOTION       =       -r$(RWORDSIZE) -i4
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM
+CFLAGS_LOCAL    =       -w -O3
+LDFLAGS_LOCAL   =       
+CPLUSPLUSLIB    =       
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         = #        -fastsse -Mvect=noaltcode -Msmartalloc -Mprefetch=distance:8 -Mfprelaxed # -Minfo=all =Mneginfo=all
+FCREDUCEDOPT	=       $(FCOPTIM)
+FCNOOPT		=       -O0
+FCDEBUG         =        -g $(FCNOOPT)
+FORMAT_FIXED    =       -Mfixed
+FORMAT_FREE     =       -Mfree
+FCSUFFIX        =
+BYTESWAPIO      =       -byteswapio
+FCBASEOPTS      =       -w $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO)
+MODULE_SRCH_FLAG =     -module $(WRF_SRC_ROOT_DIR)/main
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -B 14000
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC)
+
+###########################################################
+######################
+
+ARCHFLAGS       =    $(COREDEFS) -DIWORDSIZE=4 -DDWORDSIZE=8 -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=4 \
+                     $(ARCH_LOCAL) \
+                     $(DA_ARCHFLAGS) \
+                      -DDM_PARALLEL \
+                       \
+                      -DNETCDF \
+                       \
+                       \
+                       \
+                       \
+			-DMCELIO \
+                       \
+                      -DGRIB1 \
+                      -DINTIO \
+                      -DLIMIT_ARGS \
+                      -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) \
+                      -DMAX_DOMAINS_F=$(MAX_DOMAINS) \
+		      -DNMM_NEST=$(WRF_NMM_NEST)
+CFLAGS          =    $(CFLAGS_LOCAL) -DDM_PARALLEL 
+FCFLAGS         =    $(FCOPTIM) $(FCBASEOPTS) $(OMP)
+ESMF_LIB_FLAGS  =    
+ESMF_IO_LIB     =    $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90/libesmf_time.a
+ESMF_IO_LIB_EXT =    -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90/libesmf_time.a
+INCLUDE_MODULES =    $(MODULE_SRCH_FLAG) \
+                     $(ESMF_MOD_INC) $(ESMF_LIB_FLAGS) \
+                      -I$(WRF_SRC_ROOT_DIR)/main \
+                      -I$(WRF_SRC_ROOT_DIR)/external/io_netcdf \
+                      -I$(WRF_SRC_ROOT_DIR)/external/io_int \
+                      -I$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 \
+                      -I$(WRF_SRC_ROOT_DIR)/frame \
+                      -I$(WRF_SRC_ROOT_DIR)/share \
+                      -I$(WRF_SRC_ROOT_DIR)/phys \
+                      -I$(WRF_SRC_ROOT_DIR)/chem -I$(WRF_SRC_ROOT_DIR)/inc \
+                       \
+                      
+REGISTRY        =    Registry
+
+LIB_BUNDLED     = \
+                     -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \
+                     -L$(WRF_SRC_ROOT_DIR)/external/io_grib1 -lio_grib1 \
+                     -L$(WRF_SRC_ROOT_DIR)/external/io_grib_share -lio_grib_share \
+                     -L$(WRF_SRC_ROOT_DIR)/external/io_int -lwrfio_int \
+                     -L$(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 -lesmf_time \
+                     $(ESMF_IO_LIB) \
+                     $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a \
+                     $(WRF_SRC_ROOT_DIR)/frame/module_internal_header_util.o \
+                     $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o 
+
+LIB_EXTERNAL    = \
+                     $(WRF_SRC_ROOT_DIR)/external/io_netcdf/libwrfio_nf.a -L/home/svm/software/netcdf-3.6.1/lib -lnetcdf    \
+                      \
+                      \
+                     -L$(WRF_SRC_ROOT_DIR)/external/io_mcel -lwrfio_mcel -L$(MCEL_HOME)/MCELSystem/MCEL -lMCEL -L$(MCEL_HOME)/lib \
+                     -lomniORB4 -lomnithread -lomniDynamic4 -lm -lc -lpthread -lnetcdf -lnetcdf_c++
+
+LIB             =    $(LIB_BUNDLED) $(LIB_EXTERNAL) $(LIB_LOCAL)
+LDFLAGS         =    $(OMP) $(FCFLAGS) $(LDFLAGS_LOCAL) 
+ENVCOMPDEFS     =    
+WRF_CHEM	=	0 
+CPPFLAGS        =    $(ARCHFLAGS) $(ENVCOMPDEFS) -I$(LIBINCLUDE) $(TRADFLAG) 
+NETCDFPATH      =    $(MCEL_HOME)
+PNETCDFPATH     =    
+
+bundled:  wrf_ioapi_includes wrfio_grib_share wrfio_grib1 wrfio_int esmf_time fftpack
+external:  wrfio_nf  wrfio_mcel  $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a gen_comms_rsllite module_dm_rsllite $(ESMF_TARGET)
+
+######################
+externals: bundled external
+
+gen_comms_serial :
+	( /bin/rm -f $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c )
+
+module_dm_serial :
+	( if [ ! -e module_dm.F ] ; then /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F >> module_dm.F ; fi )
+
+gen_comms_rsllite :
+	( if [ ! -e $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ] ; then \
+          /bin/cp $(WRF_SRC_ROOT_DIR)/tools/gen_comms_warning $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/gen_comms.c >> $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ; fi )
+
+module_dm_rsllite :
+	( if [ ! -e module_dm.F ] ; then /bin/cp module_dm_warning module_dm.F ; \
+          cat $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/module_dm.F >> module_dm.F ; fi )
+
+wrfio_nf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_netcdf ; \
+          make NETCDFPATH="$(NETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          CC="$(SCC)" CFLAGS="$(CFLAGS)" \
+          FC="$(SFC) $(PROMOTION) $(FCFLAGS)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_pnf : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_pnetcdf ; \
+          make NETCDFPATH="$(PNETCDFPATH)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(FC) $(PROMOTION) $(FCFLAGS)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_grib_share :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib_share ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" archive) 
+
+wrfio_grib1 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib1 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" archive)
+
+wrfio_grib2 :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_grib2 ; \
+          make CC="$(SCC)" CFLAGS="$(CFLAGS) " RM="$(RM)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="-traditional" AR="$(AR)" ARFLAGS="$(ARFLAGS)" \
+          FIXED="$(FORMAT_FIXED)" archive)
+
+wrfio_mcel :
+	( cd ../external/io_mcel ; \
+          make CC="$(CC)" FC="$(SFC) $(PROMOTION) $(FCFLAGS)" CPP="$(CPP)" TRADFLAG="$(TRADFLAG)" \
+               INCL="-I../../inc -I../io_netcdf -I../../frame -I../../share -I../ioapi_share -I$(MCEL_HOME)/MCELSystem/MCEL" all )
+
+wrfio_int : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \
+          make CC="$(CC)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \
+          FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" \
+          TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" all )
+
+esmf_time : 
+	( cd $(WRF_SRC_ROOT_DIR)/external/esmf_time_f90 ; \
+          make FC="$(SFC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \
+          CPP="$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc -I. $(ARCHFLAGS) $(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+fftpack :
+	( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \
+          make FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+$(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a :
+	( cd $(WRF_SRC_ROOT_DIR)/external/RSL_LITE ; make CC="$(CC) $(CFLAGS)" \
+          FC="$(FC) $(FCFLAGS) $(PROMOTION) $(BYTESWAPIO)" \
+          CPP="$(CPP) -I. $(ARCHFLAGS) $(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ;\
+          $(RANLIB) $(WRF_SRC_ROOT_DIR)/external/RSL_LITE/librsl_lite.a )
+
+######################
+#	Macros, these should be generic for all machines
+
+LN	=	ln -sf
+MAKE	=	make -i -r
+RM	= 	rm -f
+
+
+# These sub-directory builds are identical across all architectures
+
+wrf_ioapi_includes :
+	( cd $(WRF_SRC_ROOT_DIR)/external/ioapi_share ; \
+          $(MAKE) NATIVE_RWORDSIZE="$(NATIVE_RWORDSIZE)" RWORDSIZE="$(RWORDSIZE)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+wrfio_esmf :
+	( cd $(WRF_SRC_ROOT_DIR)/external/io_esmf ; \
+          make FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) $(ESMF_MOD_INC)" \
+          RANLIB="$(RANLIB)" CPP="$(CPP) $(POUND_DEF) " AR="$(AR)" ARFLAGS="$(ARFLAGS)" )
+
+#	There is probably no reason to modify these rules
+
+.F.i:
+	$(RM) $@
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.F > $@
+	mv $*.i $(DEVTOP)/pick/$*.f90
+	cp $*.F $(DEVTOP)/pick
+
+.F.o:
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -o $@ -c $(FCFLAGS) $(MODULE_DIRS) $(PROMOTION) $(FCSUFFIX) $*.f90
+
+.F.f90:
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b  > $@
+	$(RM) $*.b
+
+.f90.o:
+	$(RM) $@
+	$(FC) -o $@ -c $(FCFLAGS) $(PROMOTION) $(FCSUFFIX) $*.f90
+
+.c.o:
+	$(RM) $@
+	$(CC) -o $@ -c $(CFLAGS) $*.c
+
+# compile these without high optimization to speed compile
+
+convert_nmm.o : convert_nmm.F
+init_modules_em.o : init_modules_em.F
+input_wrf.o : input_wrf.F
+module_io.o : module_io.F
+mediation_feedback_domain.o : mediation_feedback_domain.F
+mediation_force_domain.o : mediation_force_domain.F
+mediation_integrate.o : mediation_integrate.F
+mediation_interp_domain.o : mediation_interp_domain.F
+module_comm_dm.o : module_comm_dm.F
+module_configure.o : module_configure.F
+module_dm.o : module_dm.F
+module_domain.o : module_domain.F
+module_domain_type.o : module_domain_type.F
+module_alloc_space.o : module_alloc_space.F
+module_tiles.o : module_tiles.F
+module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F
+module_initialize.o : module_initialize.F
+module_physics_init.o : module_physics_init.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_real.o : module_initialize_real.F
+module_initialize_real.o: module_initialize_real.F
+module_initialize_squall2d_x.o : module_initialize_squall2d_x.F
+module_initialize_squall2d_y.o : module_initialize_squall2d_y.F
+module_integrate.o : module_integrate.F
+module_io_mm5.o : module_io_mm5.F
+module_io_wrf.o : module_io_wrf.F
+module_si_io.o : module_si_io.F
+module_state_description.o : module_state_description.F 
+output_wrf.o : output_wrf.F
+shift_domain_em.o : shift_domain_em.F
+solve_em.o : solve_em.F
+solve_interface.o : solve_interface.F
+start_domain.o : start_domain.F
+start_domain_nmm.o : start_domain_nmm.F
+start_em.o : start_em.F
+wrf_auxhist10in.o : wrf_auxhist10in.F
+wrf_auxhist10out.o : wrf_auxhist10out.F
+wrf_auxhist11in.o : wrf_auxhist11in.F
+wrf_auxhist11out.o : wrf_auxhist11out.F
+wrf_auxhist1in.o : wrf_auxhist1in.F
+wrf_auxhist1out.o : wrf_auxhist1out.F
+wrf_auxhist2in.o : wrf_auxhist2in.F
+wrf_auxhist2out.o : wrf_auxhist2out.F
+wrf_auxhist3in.o : wrf_auxhist3in.F
+wrf_auxhist3out.o : wrf_auxhist3out.F
+wrf_auxhist4in.o : wrf_auxhist4in.F
+wrf_auxhist4out.o : wrf_auxhist4out.F
+wrf_auxhist5in.o : wrf_auxhist5in.F
+wrf_auxhist5out.o : wrf_auxhist5out.F
+wrf_auxhist6in.o : wrf_auxhist6in.F
+wrf_auxhist6out.o : wrf_auxhist6out.F
+wrf_auxhist7in.o : wrf_auxhist7in.F
+wrf_auxhist7out.o : wrf_auxhist7out.F
+wrf_auxhist8in.o : wrf_auxhist8in.F
+wrf_auxhist8out.o : wrf_auxhist8out.F
+wrf_auxhist9in.o : wrf_auxhist9in.F
+wrf_auxhist9out.o : wrf_auxhist9out.F
+wrf_auxinput10in.o : wrf_auxinput10in.F
+wrf_auxinput10out.o : wrf_auxinput10out.F
+wrf_auxinput11in.o : wrf_auxinput11in.F
+wrf_auxinput11out.o : wrf_auxinput11out.F
+wrf_auxinput1in.o : wrf_auxinput1in.F
+wrf_auxinput1out.o : wrf_auxinput1out.F
+wrf_auxinput2in.o : wrf_auxinput2in.F
+wrf_auxinput2out.o : wrf_auxinput2out.F
+wrf_auxinput3in.o : wrf_auxinput3in.F
+wrf_auxinput3out.o : wrf_auxinput3out.F
+wrf_auxinput4in.o : wrf_auxinput4in.F
+wrf_auxinput4out.o : wrf_auxinput4out.F
+wrf_auxinput5in.o : wrf_auxinput5in.F
+wrf_auxinput5out.o : wrf_auxinput5out.F
+wrf_auxinput6in.o : wrf_auxinput6in.F
+wrf_auxinput6out.o : wrf_auxinput6out.F
+wrf_auxinput7in.o : wrf_auxinput7in.F
+wrf_auxinput7out.o : wrf_auxinput7out.F
+wrf_auxinput8in.o : wrf_auxinput8in.F
+wrf_auxinput8out.o : wrf_auxinput8out.F
+wrf_auxinput9in.o : wrf_auxinput9in.F
+wrf_auxinput9out.o : wrf_auxinput9out.F
+wrf_bdyin.o : wrf_bdyin.F
+wrf_bdyout.o : wrf_bdyout.F
+wrf_ext_read_field.o : wrf_ext_read_field.F
+wrf_ext_write_field.o : wrf_ext_write_field.F
+wrf_fddaobs_in.o : wrf_fddaobs_in.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_tsin.o : wrf_tsin.F
+nl_get_0_routines.o : nl_get_0_routines.F
+nl_get_1_routines.o : nl_get_1_routines.F
+nl_set_0_routines.o : nl_set_0_routines.F
+nl_set_1_routines.o : nl_set_1_routines.F
+
+convert_nmm.o \
+init_modules_em.o \
+mediation_feedback_domain.o \
+mediation_force_domain.o \
+mediation_integrate.o \
+mediation_interp_domain.o \
+module_comm_dm.o \
+module_dm.o \
+module_fddaobs_rtfdda.o \
+module_initialize.o \
+module_initialize_b_wave.o \
+module_initialize_hill2d_x.o \
+module_initialize_quarter_ss.o \
+module_initialize_real.o \
+module_initialize_squall2d_x.o \
+module_initialize_squall2d_y.o \
+module_integrate.o \
+module_io_mm5.o \
+module_io_wrf.o \
+module_si_io.o \
+module_tiles.o \
+output_wrf.o \
+shift_domain_em.o \
+solve_interface.o \
+start_domain.o \
+start_domain_nmm.o \
+start_em.o \
+wrf_fddaobs_in.o \
+module_alloc_space.o \
+wrf_tsin.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $(FCSUFFIX) $*.f90
+
+solve_em.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $(SOLVE_EM_SPECIAL) $(FCSUFFIX) $*.f90
+
+module_sf_ruclsm.o : module_sf_ruclsm.F
+module_cu_kf.o : module_cu_kf.F
+
+module_sf_ruclsm.o module_cu_kf.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCREDUCEDOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $(FCSUFFIX) $*.f90
+
+# compile without OMP
+input_wrf.o \
+module_io.o \
+module_domain.o \
+module_domain_type.o \
+module_physics_init.o \
+wrf_auxhist10in.o \
+wrf_auxhist10out.o \
+wrf_auxhist11in.o \
+wrf_auxhist11out.o \
+wrf_auxhist1in.o \
+wrf_auxhist1out.o \
+wrf_auxhist2in.o \
+wrf_auxhist2out.o \
+wrf_auxhist3in.o \
+wrf_auxhist3out.o \
+wrf_auxhist4in.o \
+wrf_auxhist4out.o \
+wrf_auxhist5in.o \
+wrf_auxhist5out.o \
+wrf_auxhist6in.o \
+wrf_auxhist6out.o \
+wrf_auxhist7in.o \
+wrf_auxhist7out.o \
+wrf_auxhist8in.o \
+wrf_auxhist8out.o \
+wrf_auxhist9in.o \
+wrf_auxhist9out.o \
+wrf_auxinput10in.o \
+wrf_auxinput10out.o \
+wrf_auxinput11in.o \
+wrf_auxinput11out.o \
+wrf_auxinput1in.o \
+wrf_auxinput1out.o \
+wrf_auxinput2in.o \
+wrf_auxinput2out.o \
+wrf_auxinput3in.o \
+wrf_auxinput3out.o \
+wrf_auxinput4in.o \
+wrf_auxinput4out.o \
+wrf_auxinput5in.o \
+wrf_auxinput5out.o \
+wrf_auxinput6in.o \
+wrf_auxinput6out.o \
+wrf_auxinput7in.o \
+wrf_auxinput7out.o \
+wrf_auxinput8in.o \
+wrf_auxinput8out.o \
+wrf_auxinput9in.o \
+wrf_auxinput9out.o \
+wrf_bdyin.o \
+wrf_bdyout.o \
+wrf_ext_read_field.o \
+wrf_ext_write_field.o \
+wrf_histin.o \
+wrf_histout.o \
+wrf_inputin.o \
+wrf_inputout.o \
+wrf_restartin.o \
+wrf_restartout.o \
+module_state_description.o \
+nl_set_0_routines.o \
+nl_set_1_routines.o \
+nl_get_0_routines.o \
+nl_get_1_routines.o \
+module_configure.o :
+	$(RM) $@
+	$(SED_FTN) $*.F > $*.b 
+	$(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.b  > $*.f90
+	$(RM) $*.b
+	$(FC) -c $(PROMOTION) $(FCSUFFIX) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $*.f90
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/ext_mcel_open_for_read.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/ext_mcel_open_for_read.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/ext_mcel_open_for_read.F90	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/ext_mcel_open_for_write.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/ext_mcel_open_for_write.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/ext_mcel_open_for_write.F90	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/ext_mcel_read_field.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/ext_mcel_read_field.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/ext_mcel_read_field.F90	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/ext_mcel_write_field.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/ext_mcel_write_field.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/ext_mcel_write_field.F90	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/io_mcel.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/io_mcel.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/io_mcel.F90	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/makefile	(revision 17)
@@ -0,0 +1,38 @@
+#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 timeconvert.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
+
+timeconvert.o : timeconvert.c
+			$(CC) -c timeconvert.c
+
+.F90.o:
+			$(CPP) $(TRADFLAG) $(INCL) $*.F90 | $(M4) - > $*.f
+			$(FC) $(FFLAGS) $(INCL) -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/timeconvert.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/timeconvert.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_mcel/timeconvert.c	(revision 17)
@@ -0,0 +1,120 @@
+/* This is part of the Model Coupling Environmental Library or MCEL
+   If you have any questions mail matt at matt@mail.bettencourt.info 
+   it is covered under the LGPL http://www.gnu.org/licenses/lgpl.html
+   
+   This code was developed with DoD HPCMO CHSSI and PET funding
+   http://www.hpcmo.hpc.mil/  */
+#include <stdio.h>
+#include <time.h>
+#include <string.h>
+
+
+#define INIT2000 \
+  t1.tm_sec=-1;   \
+  t1.tm_min=-1;   \
+  t1.tm_hour=-1;  \
+  t1.tm_mday=-1;  \
+  t1.tm_mon=-1;   \
+  t1.tm_year=-1;  \
+  t1.tm_wday=-1;  \
+  t1.tm_yday=-1;  \
+  t1.tm_isdst=0; \
+  t1.tm_year=100;\
+  t1.tm_mon=0;\
+  t1.tm_mday=1;\
+  t1.tm_hour = 0;\
+  t1.tm_min = 0;\
+  t1.tm_sec = 0;
+
+#ifdef LOWERCASE
+#  ifdef UNDERSCORE
+#     	define YYMMDDHH2SECS yymmddhh2secs_
+#     	define YYMMDDHHMMSS2SECS yymmddhhmmss2secs_
+#     	define YYYYMMDDHHMMSS2SECS yyyymmddhhmmss2secs_
+#       define SECS2YYYYMMDDHHMMSS secs2yyyymmddhhmmss_
+#  else
+#     	define YYMMDDHH2SECS yymmddhh2secs
+#     	define YYMMDDHHMMSS2SECS yymmddhhmmss2secs
+#     	define YYYYMMDDHHMMSS2SECS yyyymmddhhmmss2secs
+#       define SECS2YYYYMMDDHHMMSS secs2yyyymmddhhmmss
+#  endif
+#else
+/* Do nothing */
+#endif
+
+void YYMMDDHH2SECS(char* date, double* time);
+void YYMMDDHHMMSS2SECS(char* date, double* time);
+void YYYYMMDDHHMMSS2SECS(char* date, double* time);
+ void SECS2YYYYMMDDHHMMSS(char* date, double* time);
+
+
+void YYMMDDHH2SECS(char* date, double* time) {
+
+  char date2[12];
+  strncpy(date2,date,8);
+  strncat(date2,"0000",4);
+  
+  YYMMDDHHMMSS2SECS(date2, time);
+
+}
+
+
+void YYMMDDHHMMSS2SECS(char* date, double* time) {
+  
+
+  char date2[14];
+  int year;
+  sscanf(date,"%2d",&year);
+
+  if ( year < 50 ) 
+    sprintf(date2,"20");
+  else
+    sprintf(date2,"19");
+  strncat(date2,date,12);
+  YYYYMMDDHHMMSS2SECS(date2,time);
+}
+
+
+void YYYYMMDDHHMMSS2SECS(char* date, double* time) {
+
+  struct tm t1,t2;
+  time_t tt1,tt2;
+
+  INIT2000;
+  t2=t1;
+  sscanf(date,"%4d%2d%2d%2d%2d%2d",&t2.tm_year,&t2.tm_mon,&t2.tm_mday,
+	 &t2.tm_hour,&t2.tm_min,&t2.tm_sec);
+  /* Correct year, month */
+  t2.tm_year -= 1900;
+  t2.tm_mon -= 1;
+
+
+  tt1 = mktime(&t1);
+  tt2 = mktime(&t2);
+
+  *time = difftime(tt2,tt1);
+
+}
+  
+
+void SECS2YYYYMMDDHHMMSS(char* date, double* time) {
+
+  struct tm t1,t2;
+  time_t tt1,tt2;
+  INIT2000;
+  tt1 = mktime(&t1);
+  tt2 = tt1+(unsigned long int )*time;
+  t2=t1;
+  localtime_r(&tt2,&t2);
+  if (t2.tm_isdst) 
+    tt2 -= 3600;
+  localtime_r(&tt2,&t2);
+
+  sprintf(date,"%04d%02d%02d%02d%02d%02d",
+	  1900+t2.tm_year,
+	  t2.tm_mon+1,
+	  t2.tm_mday,
+	  t2.tm_hour,
+	  t2.tm_min,
+	  t2.tm_sec);
+}
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/README
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/README	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/README	(revision 17)
@@ -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.
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/WRFIO.doc
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/WRFIO.doc	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/WRFIO.doc	(revision 17)
@@ -0,0 +1,6 @@
+Documentation for WRF I/O is at
+
+   http://www.wrf-model.org/documentation_main.html
+ 
+the first link under REFERENCES.
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/diffwrf.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/diffwrf.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/diffwrf.F90	(revision 17)
@@ -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=255) :: flnm
+  character(len=255) :: 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
+  write (6,FMT='(4A)') '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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_get_dom_ti.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_get_dom_ti.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_get_dom_ti.code	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_get_var_td.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_get_var_td.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_get_var_td.code	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_get_var_ti.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_get_var_ti.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_get_var_ti.code	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_put_dom_ti.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_put_dom_ti.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_put_dom_ti.code	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_put_var_td.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_put_var_td.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_put_var_td.code	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_put_var_ti.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_put_var_ti.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/ext_ncd_put_var_ti.code	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/field_routines.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/field_routines.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/field_routines.F90	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/makefile	(revision 17)
@@ -0,0 +1,69 @@
+#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 $@
+			if [ "$(AR)" != "lib.exe" ] ; then \
+                          $(AR) cr libwrfio_nf.a $(OBJSL) ; \
+                        else \
+                          $(AR) /out:libwrfio_nf.a $(OBJSL) ; \
+                        fi
+			$(RANLIB) $@
+
+wrf_io.o:               wrf_io.F90 $(CODE)
+			grep nf_format_64bit $(NETCDFPATH)/include/netcdf.inc ;\
+                        a=$$? ; export a ; \
+			if [ $$a -a "$$WRFIO_NCD_LARGE_FILE_SUPPORT" = "1" ] ; then \
+                          $(CPP1) -DWRFIO_NCD_LARGE_FILE_SUPPORT -I../ioapi_share wrf_io.F90 | $(M4) - > wrf_io.f ; \
+                        else \
+                          $(CPP1) -I../ioapi_share wrf_io.F90 | $(M4) - > wrf_io.f ; \
+                        fi
+			$(FC) -o $@ $(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) -o $@ $(FFLAGS) -c module_wrfsi_static.f
+
+# gfortran treats iargc as intrinsic, so get rid of external declaration in that case
+diffwrf:                diffwrf.F90
+	x=`echo "$(FC)" | awk '{print $$1}'` ; export x ; \
+	if [ $$x = "gfortran" ] ; then \
+           echo removing external declaration of iargc for gfortran ; \
+	   $(CPP1) -I$(NETCDFPATH)/include -I../ioapi_share diffwrf.F90 | sed '/integer *, *external.*iargc/d' > diffwrf.f ;\
+        else \
+	   $(CPP1) -I$(NETCDFPATH)/include -I../ioapi_share diffwrf.F90 > diffwrf.f ; \
+        fi
+	$(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. " ; \
+          if [ -f $(NETCDFPATH)/lib/libnetcdff.a ] ; then \
+            $(FC) $(FFLAGS) $(LDFLAGS) -o diffwrf diffwrf.o $(OBJSL) ../../frame/wrf_debug.o ../../frame/module_wrf_error.o $(ESMF_IO_LIB_EXT) $(LIBS) -lnetcdff ;\
+          else \
+            $(FC) $(FFLAGS) $(LDFLAGS) -o diffwrf diffwrf.o $(OBJSL) ../../frame/wrf_debug.o ../../frame/module_wrf_error.o $(ESMF_IO_LIB_EXT) $(LIBS) ;\
+          fi ; \
+        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) -o $@ $(FFLAGS) -c field_routines.f
+
+superclean:
+			/bin/rm -f *.f *.o *.obj *.i testWRFWrite testWRFRead \
+			*.mod libwrfio_nf.a diffwrf
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/module_wrfsi_static.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/module_wrfsi_static.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/module_wrfsi_static.F90	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/testWRFRead.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/testWRFRead.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/testWRFRead.F90	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/testWRFWrite.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/testWRFWrite.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/testWRFWrite.F90	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/transpose.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/transpose.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/transpose.code	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/vort.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/vort.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/vort.F90	(revision 17)
@@ -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 <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 :: 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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/wrf_io.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/wrf_io.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_netcdf/wrf_io.F90	(revision 17)
@@ -0,0 +1,3511 @@
+!*------------------------------------------------------------------------------
+!*  Standard Disclaimer
+!*
+!*  Forecast Systems Laboratory
+!*  NOAA/OAR/ERL/FSL
+!*  325 Broadway
+!*  Boulder, CO     80303
+!*
+!*  AVIATION DIVISION
+!*  ADVANCED COMPUTING BRANCH
+!*  SMS/NNT Version: 2.0.0 
+!*
+!*  This software and its documentation are in the public domain and
+!*  are furnished "as is".  The United States government, its 
+!*  instrumentalities, officers, employees, and agents make no 
+!*  warranty, express or implied, as to the usefulness of the software 
+!*  and documentation for any purpose.  They assume no 
+!*  responsibility (1) for the use of the software and documentation; 
+!*  or (2) to provide technical support to users.
+!* 
+!*  Permission to use, copy, modify, and distribute this software is
+!*  hereby granted, provided that this disclaimer notice appears in 
+!*  all copies.  All modifications to this software must be clearly
+!*  documented, and are solely the responsibility of the agent making
+!*  the modification.  If significant modifications or enhancements
+!*  are made to this software, the SMS Development team
+!*  (sms-info@fsl.noaa.gov) should be notified.
+!*
+!*----------------------------------------------------------------------------
+!*
+!*  WRF NetCDF I/O
+!   Author:  Jacques Middlecoff jacquesm@fsl.noaa.gov
+!*  Date:    October 6, 2000
+!*
+!*----------------------------------------------------------------------------
+
+module wrf_data
+
+  integer                , parameter      :: FATAL            = 1
+  integer                , parameter      :: WARN             = 1
+  integer                , parameter      :: WrfDataHandleMax = 99
+  integer                , parameter      :: MaxDims          = 2000 ! = NF_MAX_VARS
+  integer                , parameter      :: MaxVars          = 3000
+  integer                , parameter      :: MaxTimes         = 900000
+  integer                , parameter      :: DateStrLen       = 19
+  integer                , parameter      :: VarNameLen       = 31
+  integer                , parameter      :: NO_DIM           = 0
+  integer                , parameter      :: NVarDims         = 4
+  integer                , parameter      :: NMDVarDims       = 2
+  character (8)          , parameter      :: NO_NAME          = 'NULL'
+  character (DateStrLen) , parameter      :: ZeroDate = '0000-00-00-00:00:00'
+
+#include "wrf_io_flags.h"
+
+  character (256)                         :: msg
+  logical                                 :: WrfIOnotInitialized = .true.
+
+  type :: wrf_data_handle
+    character (255)                       :: FileName
+    integer                               :: FileStatus
+    integer                               :: Comm
+    integer                               :: NCID
+    logical                               :: Free
+    logical                               :: Write
+    character (5)                         :: TimesName
+    integer                               :: TimeIndex
+    integer                               :: CurrentTime  !Only used for read
+    integer                               :: NumberTimes  !Only used for read
+    character (DateStrLen), pointer       :: Times(:)
+    integer                               :: TimesVarID
+    integer               , pointer       :: DimLengths(:)
+    integer               , pointer       :: DimIDs(:)
+    character (31)        , pointer       :: DimNames(:)
+    integer                               :: DimUnlimID
+    character (9)                         :: DimUnlimName
+    integer       , dimension(NVarDims)   :: DimID
+    integer       , dimension(NVarDims)   :: Dimension
+    integer               , pointer       :: MDVarIDs(:)
+    integer               , pointer       :: MDVarDimLens(:)
+    character (80)        , pointer       :: MDVarNames(:)
+    integer               , pointer       :: VarIDs(:)
+    integer               , pointer       :: VarDimLens(:,:)
+    character (VarNameLen), pointer       :: VarNames(:)
+    integer                               :: CurrentVariable  !Only used for read
+    integer                               :: NumVars
+! first_operation is set to .TRUE. when a new handle is allocated 
+! or when open-for-write or open-for-read are committed.  It is set 
+! to .FALSE. when the first field is read or written.  
+    logical                               :: first_operation
+    logical                               :: R4OnOutput
+  end type wrf_data_handle
+  type(wrf_data_handle),target            :: WrfDataHandles(WrfDataHandleMax)
+end module wrf_data
+
+module ext_ncd_support_routines
+
+  implicit none
+
+CONTAINS
+
+subroutine allocHandle(DataHandle,DH,Comm,Status)
+  use wrf_data
+  include 'wrf_status_codes.h'
+  integer              ,intent(out) :: DataHandle
+  type(wrf_data_handle),pointer     :: DH
+  integer              ,intent(IN)  :: Comm
+  integer              ,intent(out) :: Status
+  integer                           :: i
+  integer                           :: stat
+
+  do i=1,WrfDataHandleMax
+    if(WrfDataHandles(i)%Free) then
+      DH => WrfDataHandles(i)
+      DataHandle = i
+      allocate(DH%Times(MaxTimes), STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_ALLOCATION_ERROR
+        write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      allocate(DH%DimLengths(MaxDims), STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_ALLOCATION_ERROR
+        write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      allocate(DH%DimIDs(MaxDims), STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_ALLOCATION_ERROR
+        write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      allocate(DH%DimNames(MaxDims), STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_ALLOCATION_ERROR
+        write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      allocate(DH%MDVarIDs(MaxVars), STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_ALLOCATION_ERROR
+        write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      allocate(DH%MDVarDimLens(MaxVars), STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_ALLOCATION_ERROR
+        write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      allocate(DH%MDVarNames(MaxVars), STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_ALLOCATION_ERROR
+        write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      allocate(DH%VarIDs(MaxVars), STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_ALLOCATION_ERROR
+        write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      allocate(DH%VarDimLens(NVarDims-1,MaxVars), STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_ALLOCATION_ERROR
+        write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      allocate(DH%VarNames(MaxVars), STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_ALLOCATION_ERROR
+        write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      exit
+    endif
+    if(i==WrfDataHandleMax) then
+      Status = WRF_WARN_TOO_MANY_FILES
+      write(msg,*) 'Warning TOO MANY FILES in ',__FILE__,', line', __LINE__ 
+      call wrf_debug ( WARN , TRIM(msg))
+      write(msg,*) 'Did you call ext_ncd_ioinit?'
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+  enddo
+  DH%Free      =.false.
+  DH%Comm      = Comm
+  DH%Write     =.false.
+  DH%first_operation  = .TRUE.
+  DH%R4OnOutput = .false.
+  Status = WRF_NO_ERR
+end subroutine allocHandle
+
+subroutine deallocHandle(DataHandle, Status)
+  use wrf_data
+  include 'wrf_status_codes.h'
+  integer              ,intent(in) :: DataHandle
+  integer              ,intent(out) :: Status
+  type(wrf_data_handle),pointer     :: DH
+  integer                           :: i
+  integer                           :: stat
+
+  IF ( DataHandle .GE. 1 .AND. DataHandle .LE. WrfDataHandleMax ) THEN
+    if(.NOT. WrfDataHandles(DataHandle)%Free) then
+      DH => WrfDataHandles(DataHandle)
+      deallocate(DH%Times, STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_DEALLOCATION_ERR
+        write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      deallocate(DH%DimLengths, STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_DEALLOCATION_ERR
+        write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      deallocate(DH%DimIDs, STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_DEALLOCATION_ERR
+        write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      deallocate(DH%DimNames, STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_DEALLOCATION_ERR
+        write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      deallocate(DH%MDVarIDs, STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_DEALLOCATION_ERR
+        write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      deallocate(DH%MDVarDimLens, STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_DEALLOCATION_ERR
+        write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      deallocate(DH%MDVarNames, STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_DEALLOCATION_ERR
+        write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      deallocate(DH%VarIDs, STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_DEALLOCATION_ERR
+        write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      deallocate(DH%VarDimLens, STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_DEALLOCATION_ERR
+        write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      deallocate(DH%VarNames, STAT=stat)
+      if(stat/= 0) then
+        Status = WRF_ERR_FATAL_DEALLOCATION_ERR
+        write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
+        call wrf_debug ( FATAL , msg)
+        return
+      endif
+      DH%Free      =.TRUE.
+    endif
+  ENDIF
+  Status = WRF_NO_ERR
+end subroutine deallocHandle
+
+subroutine GetDH(DataHandle,DH,Status)
+  use wrf_data
+  include 'wrf_status_codes.h'
+  integer               ,intent(in)     :: DataHandle
+  type(wrf_data_handle) ,pointer        :: DH
+  integer               ,intent(out)    :: Status
+
+  if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then
+    Status = WRF_WARN_BAD_DATA_HANDLE
+    return
+  endif
+  DH => WrfDataHandles(DataHandle)
+  if(DH%Free) then
+    Status = WRF_WARN_BAD_DATA_HANDLE
+    return
+  endif
+  Status = WRF_NO_ERR
+  return
+end subroutine GetDH
+
+subroutine DateCheck(Date,Status)
+  use wrf_data
+  include 'wrf_status_codes.h'
+  character*(*) ,intent(in)      :: Date
+  integer       ,intent(out)     :: Status
+  
+  if(len(Date) /= DateStrLen) then
+    Status = WRF_WARN_DATESTR_BAD_LENGTH
+  else  
+    Status = WRF_NO_ERR
+  endif
+  return
+end subroutine DateCheck
+
+subroutine GetName(Element,Var,Name,Status)
+  use wrf_data
+  include 'wrf_status_codes.h'
+  character*(*) ,intent(in)     :: Element
+  character*(*) ,intent(in)     :: Var
+  character*(*) ,intent(out)    :: Name
+  integer       ,intent(out)    :: Status
+  character (VarNameLen)        :: VarName
+  character (1)                 :: c
+  integer                       :: i
+  integer, parameter            ::  upper_to_lower =IACHAR('a')-IACHAR('A')
+
+  VarName = Var
+  Name = 'MD___'//trim(Element)//VarName
+  do i=1,len(Name)
+    c=Name(i:i)
+    if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower)
+    if(c=='-'.or.c==':') Name(i:i)='_'
+  enddo
+  Status = WRF_NO_ERR
+  return
+end subroutine GetName
+
+subroutine GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status)
+  use wrf_data
+  include 'wrf_status_codes.h'
+  include 'netcdf.inc'
+  character (*)         ,intent(in)     :: IO
+  integer               ,intent(in)     :: DataHandle
+  character*(*)         ,intent(in)     :: DateStr
+  integer               ,intent(out)    :: TimeIndex
+  integer               ,intent(out)    :: Status
+  type(wrf_data_handle) ,pointer        :: DH
+  integer                               :: VStart(2)
+  integer                               :: VCount(2)
+  integer                               :: stat
+  integer                               :: i
+
+  DH => WrfDataHandles(DataHandle)
+  call DateCheck(DateStr,Status)
+  if(Status /= WRF_NO_ERR) then
+    Status =  WRF_WARN_DATESTR_ERROR
+    write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  endif
+  if(IO == 'write') then
+    TimeIndex = DH%TimeIndex
+    if(TimeIndex <= 0) then
+      TimeIndex = 1
+    elseif(DateStr == DH%Times(TimeIndex)) then
+      Status = WRF_NO_ERR
+      return
+    else
+      TimeIndex = TimeIndex +1
+      if(TimeIndex > MaxTimes) then
+        Status = WRF_WARN_TIME_EOF
+        write(msg,*) 'Warning TIME EOF in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      endif
+    endif
+    DH%TimeIndex        = TimeIndex
+    DH%Times(TimeIndex) = DateStr
+    VStart(1) = 1
+    VStart(2) = TimeIndex
+    VCount(1) = DateStrLen
+    VCount(2) = 1
+    stat = NF_PUT_VARA_TEXT(DH%NCID,DH%TimesVarID,VStart,VCount,DateStr)
+    call netcdf_err(stat,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ 
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+  else
+    do i=1,MaxTimes
+      if(DH%Times(i)==DateStr) then
+        Status = WRF_NO_ERR
+        TimeIndex = i
+        exit
+      endif
+      if(i==MaxTimes) then
+        Status = WRF_WARN_TIME_NF
+        write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      endif
+    enddo
+  endif
+  return
+end subroutine GetTimeIndex
+
+subroutine GetDim(MemoryOrder,NDim,Status)
+  include 'wrf_status_codes.h'
+  character*(*) ,intent(in)  :: MemoryOrder
+  integer       ,intent(out) :: NDim
+  integer       ,intent(out) :: Status
+  character*3                :: MemOrd
+
+  call LowerCase(MemoryOrder,MemOrd)
+  select case (MemOrd)
+    case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez')
+      NDim = 3
+    case ('xy','yx','xs','xe','ys','ye','cc')
+      NDim = 2
+    case ('z','c')
+      NDim = 1
+    case ('0')  ! NDim=0 for scalars.  TBH:  20060502
+      NDim = 0
+    case default
+      Status = WRF_WARN_BAD_MEMORYORDER
+      return
+  end select
+  Status = WRF_NO_ERR
+  return
+end subroutine GetDim
+
+subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2)
+  integer              ,intent(in)  :: NDim
+  integer ,dimension(*),intent(in)  :: Start,End
+  integer              ,intent(out) :: i1,i2,j1,j2,k1,k2
+
+  i1=1
+  i2=1
+  j1=1
+  j2=1
+  k1=1
+  k2=1
+  if(NDim == 0) return  ! NDim=0 for scalars.  TBH:  20060502
+  i1 = Start(1)
+  i2 = End  (1)
+  if(NDim == 1) return
+  j1 = Start(2)
+  j2 = End  (2)
+  if(NDim == 2) return
+  k1 = Start(3)
+  k2 = End  (3)
+  return
+end subroutine GetIndices
+
+logical function ZeroLengthHorzDim(MemoryOrder,Vector,Status)
+  use wrf_data
+  include 'wrf_status_codes.h'
+  character*(*)              ,intent(in)    :: MemoryOrder
+  integer,dimension(*)       ,intent(in)    :: Vector
+  integer                    ,intent(out)   :: Status
+  integer                                   :: NDim
+  integer,dimension(NVarDims)               :: temp
+  character*3                               :: MemOrd
+  logical zero_length
+
+  call GetDim(MemoryOrder,NDim,Status)
+  temp(1:NDim) = Vector(1:NDim)
+  call LowerCase(MemoryOrder,MemOrd)
+  zero_length = .false.
+  select case (MemOrd)
+    case ('xsz','xez','ysz','yez','xs','xe','ys','ye','z','c')
+      continue
+    case ('0')
+      continue  ! NDim=0 for scalars.  TBH:  20060502
+    case ('xzy','yzx')
+      zero_length = temp(1) .lt. 1 .or. temp(3) .lt. 1
+    case ('xy','yx','xyz','yxz')
+      zero_length = temp(1) .lt. 1 .or. temp(2) .lt. 1
+    case ('zxy','zyx')
+      zero_length = temp(2) .lt. 1 .or. temp(3) .lt. 1
+    case default
+      Status = WRF_WARN_BAD_MEMORYORDER
+      ZeroLengthHorzDim = .true.
+      return
+  end select
+  Status = WRF_NO_ERR
+  ZeroLengthHorzDim = zero_length
+  return
+end function ZeroLengthHorzDim
+
+subroutine ExtOrder(MemoryOrder,Vector,Status)
+  use wrf_data
+  include 'wrf_status_codes.h'
+  character*(*)              ,intent(in)    :: MemoryOrder
+  integer,dimension(*)       ,intent(inout) :: Vector
+  integer                    ,intent(out)   :: Status
+  integer                                   :: NDim
+  integer,dimension(NVarDims)               :: temp
+  character*3                               :: MemOrd
+
+  call GetDim(MemoryOrder,NDim,Status)
+  temp(1:NDim) = Vector(1:NDim)
+  call LowerCase(MemoryOrder,MemOrd)
+  select case (MemOrd)
+
+    case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c')
+      continue
+    case ('0')
+      continue  ! NDim=0 for scalars.  TBH:  20060502
+    case ('xzy')
+      Vector(2) = temp(3)
+      Vector(3) = temp(2)
+    case ('yxz')
+      Vector(1) = temp(2)
+      Vector(2) = temp(1)
+    case ('yzx')
+      Vector(1) = temp(3)
+      Vector(2) = temp(1)
+      Vector(3) = temp(2)
+    case ('zxy')
+      Vector(1) = temp(2)
+      Vector(2) = temp(3)
+      Vector(3) = temp(1)
+    case ('zyx')
+      Vector(1) = temp(3)
+      Vector(3) = temp(1)
+    case ('yx')
+      Vector(1) = temp(2)
+      Vector(2) = temp(1)
+    case default
+      Status = WRF_WARN_BAD_MEMORYORDER
+      return
+  end select
+  Status = WRF_NO_ERR
+  return
+end subroutine ExtOrder
+
+subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status)
+  use wrf_data
+  include 'wrf_status_codes.h'
+  character*(*)                    ,intent(in)    :: MemoryOrder
+  character*(*),dimension(*)       ,intent(in)    :: Vector
+  character(80),dimension(NVarDims),intent(out)   :: ROVector
+  integer                          ,intent(out)   :: Status
+  integer                                         :: NDim
+  character*3                                     :: MemOrd
+
+  call GetDim(MemoryOrder,NDim,Status)
+  ROVector(1:NDim) = Vector(1:NDim)
+  call LowerCase(MemoryOrder,MemOrd)
+  select case (MemOrd)
+
+    case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c')
+      continue
+    case ('0')
+      continue  ! NDim=0 for scalars.  TBH:  20060502
+    case ('xzy')
+      ROVector(2) = Vector(3)
+      ROVector(3) = Vector(2)
+    case ('yxz')
+      ROVector(1) = Vector(2)
+      ROVector(2) = Vector(1)
+    case ('yzx')
+      ROVector(1) = Vector(3)
+      ROVector(2) = Vector(1)
+      ROVector(3) = Vector(2)
+    case ('zxy')
+      ROVector(1) = Vector(2)
+      ROVector(2) = Vector(3)
+      ROVector(3) = Vector(1)
+    case ('zyx')
+      ROVector(1) = Vector(3)
+      ROVector(3) = Vector(1)
+    case ('yx')
+      ROVector(1) = Vector(2)
+      ROVector(2) = Vector(1)
+    case default
+      Status = WRF_WARN_BAD_MEMORYORDER
+      return
+  end select
+  Status = WRF_NO_ERR
+  return
+end subroutine ExtOrderStr
+
+
+subroutine LowerCase(MemoryOrder,MemOrd)
+  character*(*) ,intent(in)  :: MemoryOrder
+  character*(*) ,intent(out) :: MemOrd
+  character*1                :: c
+  integer       ,parameter   :: upper_to_lower =IACHAR('a')-IACHAR('A')
+  integer                    :: i,N
+
+  MemOrd = ' '
+  N = len(MemoryOrder)
+  MemOrd(1:N) = MemoryOrder(1:N)
+  do i=1,N
+    c = MemoryOrder(i:i)
+    if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower)
+  enddo
+  return
+end subroutine LowerCase
+
+subroutine UpperCase(MemoryOrder,MemOrd)
+  character*(*) ,intent(in)  :: MemoryOrder
+  character*(*) ,intent(out) :: MemOrd
+  character*1                :: c
+  integer     ,parameter     :: lower_to_upper =IACHAR('A')-IACHAR('a')
+  integer                    :: i,N
+
+  MemOrd = ' '
+  N = len(MemoryOrder)
+  MemOrd(1:N) = MemoryOrder(1:N)
+  do i=1,N
+    c = MemoryOrder(i:i)
+    if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper)
+  enddo
+  return
+end subroutine UpperCase
+
+subroutine netcdf_err(err,Status)
+  use wrf_data
+  include 'wrf_status_codes.h'
+  include 'netcdf.inc'
+  integer  ,intent(in)  :: err
+  integer  ,intent(out) :: Status
+  character(len=80)     :: errmsg
+  integer               :: stat
+
+  if( err==NF_NOERR )then
+    Status = WRF_NO_ERR
+  else
+    errmsg = NF_STRERROR(err) 
+    write(msg,*) 'NetCDF error: ',errmsg
+    call wrf_debug ( WARN , TRIM(msg))
+    Status = WRF_WARN_NETCDF
+  endif
+  return
+end subroutine netcdf_err
+
+subroutine FieldIO(IO,DataHandle,DateStr,Length,MemoryOrder &
+                     ,FieldType,NCID,VarID,XField,Status)
+  use wrf_data
+  include 'wrf_status_codes.h'
+  include 'netcdf.inc'
+  character (*)              ,intent(in)    :: IO
+  integer                    ,intent(in)    :: DataHandle
+  character*(*)              ,intent(in)    :: DateStr
+  integer,dimension(NVarDims),intent(in)    :: Length
+  character*(*)              ,intent(in)    :: MemoryOrder
+  integer                    ,intent(in)    :: FieldType
+  integer                    ,intent(in)    :: NCID
+  integer                    ,intent(in)    :: VarID
+  integer,dimension(*)       ,intent(inout) :: XField
+  integer                    ,intent(out)   :: Status
+  integer                                   :: TimeIndex
+  integer                                   :: NDim
+  integer,dimension(NVarDims)               :: VStart
+  integer,dimension(NVarDims)               :: VCount
+
+  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 TransposeToR4(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
+                                      ,XField,x1,x2,y1,y2,z1,z2 &
+                                             ,i1,i2,j1,j2,k1,k2 )
+
+  use ext_ncd_support_routines 
+
+  character*(*)     ,intent(in)    :: IO
+  character*(*)     ,intent(in)    :: MemoryOrder
+  integer           ,intent(in)    :: l1,l2,m1,m2,n1,n2
+  integer           ,intent(in)    :: di
+  integer           ,intent(in)    :: x1,x2,y1,y2,z1,z2
+  integer           ,intent(in)    :: i1,i2,j1,j2,k1,k2
+  real*8            ,intent(inout) :: Field(di,l1:l2,m1:m2,n1:n2)
+  real*4            ,intent(inout) :: XField(di,(i2-i1+1)*(j2-j1+1)*(k2-k1+1))
+  character*3                      :: MemOrd
+  character*3                      :: MemO
+  integer           ,parameter     :: MaxUpperCase=IACHAR('Z')
+  integer                          :: i,j,k,ix,jx,kx
+
+  call LowerCase(MemoryOrder,MemOrd)
+  select case (MemOrd)
+
+!#define XDEX(A,B,C) A-A ## 1+1+(A ## 2-A ## 1+1)*((B-B ## 1)+(C-C ## 1)*(B ## 2-B ## 1+1))
+! define(`XDEX',($1-``$1''1+1+(``$1''2-``$1''1+1)*(($2-``$2''1)+($3-``$3''1)*(``$2''2-``$2''1+1))))
+
+    case ('xzy')
+#undef  DFIELD
+#define DFIELD XField(1:di,XDEX(i,k,j))
+#include "transpose.code"
+    case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c','0')
+#undef  DFIELD
+#define DFIELD XField(1:di,XDEX(i,j,k))
+#include "transpose.code"
+    case ('yxz')
+#undef  DFIELD
+#define DFIELD XField(1:di,XDEX(j,i,k))
+#include "transpose.code"
+    case ('zxy')
+#undef  DFIELD
+#define DFIELD XField(1:di,XDEX(k,i,j))
+#include "transpose.code"
+    case ('yzx')
+#undef  DFIELD
+#define DFIELD XField(1:di,XDEX(j,k,i))
+#include "transpose.code"
+    case ('zyx')
+#undef  DFIELD
+#define DFIELD XField(1:di,XDEX(k,j,i))
+#include "transpose.code"
+    case ('yx')
+#undef  DFIELD
+#define DFIELD XField(1:di,XDEX(j,i,k))
+#include "transpose.code"
+  end select
+  return
+end subroutine TransposeToR4
+
+subroutine ext_ncd_open_for_read(DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status)
+  use wrf_data
+  use ext_ncd_support_routines
+  implicit none
+  include 'wrf_status_codes.h'
+  include 'netcdf.inc'
+  character *(*), INTENT(IN)   :: DatasetName
+  integer       , INTENT(IN)   :: Comm1, Comm2
+  character *(*), INTENT(IN)   :: SysDepInfo
+  integer       , INTENT(OUT)  :: DataHandle
+  integer       , INTENT(OUT)  :: Status
+  DataHandle = 0   ! dummy setting to quiet warning message
+  CALL ext_ncd_open_for_read_begin( DatasetName, Comm1, Comm2, SysDepInfo, DataHandle, Status )
+  IF ( Status .EQ. WRF_NO_ERR ) THEN
+    CALL ext_ncd_open_for_read_commit( DataHandle, Status )
+  ENDIF
+  return
+end subroutine ext_ncd_open_for_read
+
+!ends training phase; switches internal flag to enable input
+!must be paired with call to ext_ncd_open_for_read_begin
+subroutine ext_ncd_open_for_read_commit(DataHandle, Status)
+  use wrf_data
+  use ext_ncd_support_routines
+  implicit none
+  include 'wrf_status_codes.h'
+  include 'netcdf.inc'
+  integer, intent(in) :: DataHandle
+  integer, intent(out) :: Status
+  type(wrf_data_handle) ,pointer         :: DH
+
+  if(WrfIOnotInitialized) then
+    Status = WRF_IO_NOT_INITIALIZED
+    write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__
+    call wrf_debug ( FATAL , msg)
+    return
+  endif
+  call GetDH(DataHandle,DH,Status)
+  if(Status /= WRF_NO_ERR) then
+    write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  endif
+  DH%FileStatus      = WRF_FILE_OPENED_FOR_READ
+  DH%first_operation  = .TRUE.
+  Status = WRF_NO_ERR
+  return
+end subroutine ext_ncd_open_for_read_commit
+
+subroutine ext_ncd_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, DataHandle, Status)
+  use wrf_data
+  use ext_ncd_support_routines
+  implicit none
+  include 'wrf_status_codes.h'
+  include 'netcdf.inc'
+  character*(*)         ,intent(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
+#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT
+  stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID)
+#else
+  stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID)
+#endif
+  call netcdf_err(stat,Status)
+  if(Status /= WRF_NO_ERR) then
+    write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  endif
+  DH%FileStatus  = WRF_FILE_OPENED_NOT_COMMITTED
+  DH%FileName    = FileName
+  stat = NF_DEF_DIM(DH%NCID,DH%DimUnlimName,NF_UNLIMITED,DH%DimUnlimID)
+  call netcdf_err(stat,Status)
+  if(Status /= WRF_NO_ERR) then
+    write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  endif
+  DH%VarNames  (1:MaxVars) = NO_NAME
+  DH%MDVarNames(1:MaxVars) = NO_NAME
+  do i=1,MaxDims
+    write(Buffer,FMT="('DIM',i4.4)") i
+    DH%DimNames  (i) = Buffer
+    DH%DimLengths(i) = NO_DIM
+  enddo
+  DH%DimNames(1) = 'DateStrLen'
+  stat = NF_DEF_DIM(DH%NCID,DH%DimNames(1),DateStrLen,DH%DimIDs(1))
+  call netcdf_err(stat,Status)
+  if(Status /= WRF_NO_ERR) then
+    write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  endif
+  VDimIDs(1) = DH%DimIDs(1)
+  VDimIDs(2) = DH%DimUnlimID
+  stat = NF_DEF_VAR(DH%NCID,DH%TimesName,NF_CHAR,2,VDimIDs,DH%TimesVarID)
+  call netcdf_err(stat,Status)
+  if(Status /= WRF_NO_ERR) then
+    write(msg,*) 'NetCDF error in ext_ncd_open_for_write_begin ',__FILE__,', line', __LINE__
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  endif
+  DH%DimLengths(1) = DateStrLen
+
+  if (index(SysDepInfo,'REAL_OUTPUT_SIZE=4') /= 0) then
+     DH%R4OnOutput = .true.
+  end if
+
+  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,FieldTypeIn,  &
+  Comm, IOComm, DomainDesc, MemoryOrdIn, Stagger,  DimNames,              &
+  DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status)
+  use wrf_data
+  use ext_ncd_support_routines
+  implicit none
+  include 'wrf_status_codes.h'
+  include 'netcdf.inc'
+  integer                       ,intent(in)    :: DataHandle
+  character*(*)                 ,intent(in)    :: DateStr
+  character*(*)                 ,intent(in)    :: Var
+  integer                       ,intent(inout) :: Field(*)
+  integer                       ,intent(in)    :: FieldTypeIn
+  integer                       ,intent(inout) :: Comm
+  integer                       ,intent(inout) :: IOComm
+  integer                       ,intent(in)    :: DomainDesc
+  character*(*)                 ,intent(in)    :: MemoryOrdIn
+  character*(*)                 ,intent(in)    :: Stagger ! Dummy for now
+  character*(*) ,dimension(*)   ,intent(in)    :: DimNames
+  integer       ,dimension(*)   ,intent(in)    :: DomainStart, DomainEnd
+  integer       ,dimension(*)   ,intent(in)    :: MemoryStart, MemoryEnd
+  integer       ,dimension(*)   ,intent(in)    :: PatchStart,  PatchEnd
+  integer                       ,intent(out)   :: Status
+  integer                                      :: FieldType
+  character (3)                                :: MemoryOrder
+  type(wrf_data_handle)         ,pointer       :: DH
+  integer                                      :: NCID
+  integer                                      :: NDim
+  character (VarNameLen)                       :: VarName
+  character (3)                                :: MemO
+  character (3)                                :: UCMemO
+  integer                                      :: VarID
+  integer      ,dimension(NVarDims)            :: Length
+  integer      ,dimension(NVarDims)            :: VDimIDs
+  character(80),dimension(NVarDims)            :: RODimNames
+  integer      ,dimension(NVarDims)            :: StoredStart
+  integer      ,dimension(:,:,:,:),allocatable :: XField
+  integer                                      :: stat
+  integer                                      :: NVar
+  integer                                      :: i,j
+  integer                                      :: i1,i2,j1,j2,k1,k2
+  integer                                      :: x1,x2,y1,y2,z1,z2
+  integer                                      :: l1,l2,m1,m2,n1,n2
+  integer                                      :: XType
+  integer                                      :: di
+  character (80)                               :: NullName
+  logical                                      :: NotFound
+
+  MemoryOrder = trim(adjustl(MemoryOrdIn))
+  NullName=char(0)
+  call GetDim(MemoryOrder,NDim,Status)
+  if(Status /= WRF_NO_ERR) then
+    write(msg,*) 'Warning BAD MEMORY ORDER |',MemoryOrder,'| in ',__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
+
+  if ( DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE ) then
+     FieldType = WRF_REAL
+  else
+     FieldType = FieldTypeIn
+  end if
+
+  write(msg,*)'ext_ncd_write_field: called for ',TRIM(Var)
+
+!jm 010827  Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1
+
+  Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1
+
+  IF ( ZeroLengthHorzDim(MemoryOrder,Length,Status) ) THEN
+     write(msg,*)'ext_ncd_write_field: zero length dimension in ',TRIM(Var),'. Ignoring'
+     call wrf_debug ( WARN , TRIM(msg))
+     return
+  ENDIF
+
+  call ExtOrder(MemoryOrder,Length,Status)
+  call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status)
+  if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
+    Status = WRF_WARN_FILE_NOT_OPENED
+    write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+  elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
+    Status = WRF_WARN_WRITE_RONLY_FILE
+    write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+  elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
+    do NVar=1,MaxVars
+      if(DH%VarNames(NVar) == VarName ) then
+        Status = WRF_WARN_2DRYRUNS_1VARIABLE
+        write(msg,*) 'Warning 2 DRYRUNS 1 VARIABLE in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      elseif(DH%VarNames(NVar) == NO_NAME) then
+        DH%VarNames(NVar) = VarName
+        DH%NumVars        = NVar
+        exit
+      elseif(NVar == MaxVars) then
+        Status = WRF_WARN_TOO_MANY_VARIABLES
+        write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      endif
+    enddo
+    do j = 1,NDim
+      if(RODimNames(j) == NullName .or. RODimNames(j) == '') then
+        do i=1,MaxDims
+          if(DH%DimLengths(i) == Length(j)) then
+            exit
+          elseif(DH%DimLengths(i) == NO_DIM) then
+            stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i))
+            call netcdf_err(stat,Status)
+            if(Status /= WRF_NO_ERR) then
+              write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
+              call wrf_debug ( WARN , TRIM(msg))
+              return
+            endif
+            DH%DimLengths(i) = Length(j)
+            exit
+          elseif(i == MaxDims) then
+            Status = WRF_WARN_TOO_MANY_DIMS
+            write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ 
+            call wrf_debug ( WARN , TRIM(msg))
+            return
+          endif
+        enddo
+      else !look for input name and check if already defined
+        NotFound = .true.
+        do i=1,MaxDims
+          if (DH%DimNames(i) == RODimNames(j)) then
+            if (DH%DimLengths(i) == Length(j)) then
+              NotFound = .false.
+              exit
+            else
+              Status = WRF_WARN_DIMNAME_REDEFINED
+              write(msg,*) 'Warning DIM ',i,', NAME ',TRIM(DH%DimNames(i)),' REDEFINED  by var ', &
+                           TRIM(Var),' ',DH%DimLengths(i),Length(j) ,' in ', __FILE__ ,' line', __LINE__ 
+              call wrf_debug ( WARN , TRIM(msg))
+              return
+            endif
+          endif
+        enddo
+        if (NotFound) then
+          do i=1,MaxDims
+            if (DH%DimLengths(i) == NO_DIM) then
+              DH%DimNames(i) = RODimNames(j)
+              stat = NF_DEF_DIM(NCID,DH%DimNames(i),Length(j),DH%DimIDs(i))
+              call netcdf_err(stat,Status)
+              if(Status /= WRF_NO_ERR) then
+                write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__
+                call wrf_debug ( WARN , TRIM(msg))
+                return
+              endif
+              DH%DimLengths(i) = Length(j)
+              exit
+            elseif(i == MaxDims) then
+              Status = WRF_WARN_TOO_MANY_DIMS
+              write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ 
+              call wrf_debug ( WARN , TRIM(msg))
+              return
+            endif
+          enddo
+        endif
+      endif
+      VDimIDs(j) = DH%DimIDs(i)
+      DH%VarDimLens(j,NVar) = Length(j)
+    enddo
+    VDimIDs(NDim+1) = DH%DimUnlimID
+
+    ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE
+    IF (FieldType == WRF_REAL) THEN
+      XType = NF_FLOAT
+    ELSE IF (FieldType == WRF_DOUBLE) THEN
+      Xtype = NF_DOUBLE
+    ELSE IF (FieldType == WRF_INTEGER) THEN
+      XType = NF_INT
+    ELSE IF (FieldType == WRF_LOGICAL) THEN
+      XType = NF_INT
+    ELSE
+        Status = WRF_WARN_DATA_TYPE_NOT_FOUND
+        write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+    END IF
+
+    stat = NF_DEF_VAR(NCID,VarName,XType,NDim+1,VDimIDs,VarID)
+    call netcdf_err(stat,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'ext_ncd_write_field: NetCDF error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+    DH%VarIDs(NVar) = VarID
+    stat = NF_PUT_ATT_INT(NCID,VarID,'FieldType',NF_INT,1,FieldType)
+    call netcdf_err(stat,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__ 
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+    call reorder(MemoryOrder,MemO)
+    call uppercase(MemO,UCMemO)
+    stat = NF_PUT_ATT_TEXT(NCID,VarID,'MemoryOrder',3,UCMemO)
+    call netcdf_err(stat,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'ext_ncd_write_field: NetCDF error in ',__FILE__,', line', __LINE__ 
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+  elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
+    do NVar=1,DH%NumVars
+      if(DH%VarNames(NVar) == VarName) then
+        exit
+      elseif(NVar == DH%NumVars) then
+        Status = WRF_WARN_VAR_NF
+        write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      endif
+    enddo
+    VarID = DH%VarIDs(NVar)
+    do j=1,NDim
+      if(Length(j) /= DH%VarDimLens(j,NVar) .AND. DH%FileStatus /= WRF_FILE_OPENED_FOR_UPDATE ) then
+        Status = WRF_WARN_WRTLEN_NE_DRRUNLEN
+        write(msg,*) 'Warning LENGTH != DRY RUN LENGTH for |',   &
+                     VarName,'| dim ',j,' in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        write(msg,*) '   LENGTH ',Length(j),' DRY RUN LENGTH ',DH%VarDimLens(j,NVar)
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+!jm 010825      elseif(DomainStart(j) < MemoryStart(j)) then
+      elseif(PatchStart(j) < MemoryStart(j)) then
+        Status = WRF_WARN_DIMENSION_ERROR
+        write(msg,*) 'Warning DIMENSION ERROR for |',VarName,    &
+                     '| in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      endif
+    enddo
+    StoredStart = 1
+    call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2)
+    call GetIndices(NDim,StoredStart,Length   ,x1,x2,y1,y2,z1,z2)
+    call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2)
+    di=1
+    if(FieldType == WRF_DOUBLE) di=2
+    allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat)
+    if(stat/= 0) then
+      Status = WRF_ERR_FATAL_ALLOCATION_ERROR
+      write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+      call wrf_debug ( FATAL , TRIM(msg))
+      return
+    endif
+    if (DH%R4OnOutput .and. FieldTypeIn == WRF_DOUBLE) then
+       call TransposeToR4('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
+                                                ,XField,x1,x2,y1,y2,z1,z2 &
+                                                   ,i1,i2,j1,j2,k1,k2 )
+    else
+       call Transpose('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
+                                            ,XField,x1,x2,y1,y2,z1,z2 &
+                                                   ,i1,i2,j1,j2,k1,k2 )
+    end if
+    call FieldIO('write',DataHandle,DateStr,Length,MemoryOrder, &
+                  FieldType,NCID,VarID,XField,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ 
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+    deallocate(XField, STAT=stat)
+    if(stat/= 0) then
+      Status = WRF_ERR_FATAL_DEALLOCATION_ERR
+      write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
+      call wrf_debug ( FATAL , TRIM(msg))
+      return
+    endif
+  else
+    Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+    write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( FATAL , TRIM(msg))
+  endif
+  DH%first_operation  = .FALSE.
+  return
+end subroutine ext_ncd_write_field
+
+subroutine ext_ncd_read_field(DataHandle,DateStr,Var,Field,FieldType,Comm,  &
+  IOComm, DomainDesc, MemoryOrdIn, Stagger, DimNames,                       &
+  DomainStart,DomainEnd,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Status)
+  use wrf_data
+  use ext_ncd_support_routines
+  implicit none
+  include 'wrf_status_codes.h'
+  include 'netcdf.inc'
+  integer                       ,intent(in)    :: DataHandle
+  character*(*)                 ,intent(in)    :: DateStr
+  character*(*)                 ,intent(in)    :: Var
+  integer                       ,intent(out)   :: Field(*)
+  integer                       ,intent(in)    :: FieldType
+  integer                       ,intent(inout) :: Comm
+  integer                       ,intent(inout) :: IOComm
+  integer                       ,intent(in)    :: DomainDesc
+  character*(*)                 ,intent(in)    :: MemoryOrdIn
+  character*(*)                 ,intent(in)    :: Stagger ! Dummy for now
+  character*(*) , dimension (*) ,intent(in)    :: DimNames
+  integer ,dimension(*)         ,intent(in)    :: DomainStart, DomainEnd
+  integer ,dimension(*)         ,intent(in)    :: MemoryStart, MemoryEnd
+  integer ,dimension(*)         ,intent(in)    :: PatchStart,  PatchEnd
+  integer                       ,intent(out)   :: Status
+  character (3)                                :: MemoryOrder
+  character (NF_MAX_NAME)                      :: dimname
+  type(wrf_data_handle)         ,pointer       :: DH
+  integer                                      :: NDim
+  integer                                      :: NCID
+  character (VarNameLen)                       :: VarName
+  integer                                      :: VarID
+  integer ,dimension(NVarDims)                 :: VCount
+  integer ,dimension(NVarDims)                 :: VStart
+  integer ,dimension(NVarDims)                 :: Length
+  integer ,dimension(NVarDims)                 :: VDimIDs
+  integer ,dimension(NVarDims)                 :: MemS
+  integer ,dimension(NVarDims)                 :: MemE
+  integer ,dimension(NVarDims)                 :: StoredStart
+  integer ,dimension(NVarDims)                 :: StoredLen
+  integer ,dimension(:,:,:,:)   ,allocatable   :: XField
+  integer                                      :: NVar
+  integer                                      :: j
+  integer                                      :: i1,i2,j1,j2,k1,k2
+  integer                                      :: x1,x2,y1,y2,z1,z2
+  integer                                      :: l1,l2,m1,m2,n1,n2
+  character (VarNameLen)                       :: Name
+  integer                                      :: XType
+  integer                                      :: StoredDim
+  integer                                      :: NAtts
+  integer                                      :: Len
+  integer                                      :: stat
+  integer                                      :: di
+  integer                                      :: FType
+
+  MemoryOrder = trim(adjustl(MemoryOrdIn))
+  call GetDim(MemoryOrder,NDim,Status)
+  if(Status /= WRF_NO_ERR) then
+    write(msg,*) 'Warning BAD MEMORY ORDER |',TRIM(MemoryOrder),'| for |', &
+                 TRIM(Var),'| in ext_ncd_read_field ',__FILE__,', line', __LINE__
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  endif
+  call DateCheck(DateStr,Status)
+  if(Status /= WRF_NO_ERR) then
+    write(msg,*) 'Warning DATE STRING ERROR |',TRIM(DateStr),'| for |',TRIM(Var), &
+                 '| in ext_ncd_read_field ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  endif
+  VarName = Var
+  call GetDH(DataHandle,DH,Status)
+  if(Status /= WRF_NO_ERR) then
+    write(msg,*) 'Warning Status = ',Status,' in ext_ncd_read_field ',__FILE__,', line', __LINE__
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  endif
+  if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
+    Status = WRF_WARN_FILE_NOT_OPENED
+    write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+  elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
+! jm it is okay to have a dry run read. means read is called between ofrb and ofrc. Just return.
+!    Status = WRF_WARN_DRYRUN_READ
+!    write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ 
+!    call wrf_debug ( WARN , TRIM(msg))
+    Status = WRF_NO_ERR
+    RETURN
+  elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
+    Status = WRF_WARN_READ_WONLY_FILE
+    write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+  elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then
+    NCID = DH%NCID
+
+!jm    Length(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1
+    Length(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1
+    call ExtOrder(MemoryOrder,Length,Status)
+    stat = NF_INQ_VARID(NCID,VarName,VarID)
+    call netcdf_err(stat,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Varname ',Varname
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+    stat = NF_INQ_VAR(NCID,VarID,Name,XType,StoredDim,VDimIDs,NAtts)
+    call netcdf_err(stat,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ 
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+    stat = NF_GET_ATT_INT(NCID,VarID,'FieldType',FType)
+    call netcdf_err(stat,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ 
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+! allow coercion between double and single prec real
+!jm    if(FieldType /= Ftype) then
+    if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then
+      if ( .NOT. (Ftype     == WRF_REAL .OR. Ftype     == WRF_DOUBLE ))  then
+        Status = WRF_WARN_TYPE_MISMATCH
+        write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      endif
+    else if(FieldType /= Ftype) then
+      Status = WRF_WARN_TYPE_MISMATCH
+      write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif      
+      
+    ! Do not use SELECT statement here as sometimes WRF_REAL=WRF_DOUBLE
+    IF (FieldType == WRF_REAL) THEN
+! allow coercion between double and single prec real
+        if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) )  then
+          Status = WRF_WARN_TYPE_MISMATCH
+          write(msg,*) 'Warning REAL TYPE MISMATCH in ',__FILE__,', line', __LINE__
+        endif
+    ELSE IF (FieldType == WRF_DOUBLE) THEN
+! allow coercion between double and single prec real
+        if(.NOT. (XType == NF_FLOAT .OR. XType == NF_DOUBLE) )  then
+          Status = WRF_WARN_TYPE_MISMATCH
+          write(msg,*) 'Warning DOUBLE TYPE MISMATCH in ',__FILE__,', line', __LINE__
+        endif
+    ELSE IF (FieldType == WRF_INTEGER) THEN
+        if(XType /= NF_INT)  then 
+          Status = WRF_WARN_TYPE_MISMATCH
+          write(msg,*) 'Warning INTEGER TYPE MISMATCH in ',__FILE__,', line', __LINE__
+        endif
+    ELSE IF (FieldType == WRF_LOGICAL) THEN
+        if(XType /= NF_INT)  then
+          Status = WRF_WARN_TYPE_MISMATCH
+          write(msg,*) 'Warning LOGICAL TYPE MISMATCH in ',__FILE__,', line', __LINE__
+        endif
+    ELSE
+        Status = WRF_WARN_DATA_TYPE_NOT_FOUND
+        write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__
+    END IF
+
+    if(Status /= WRF_NO_ERR) then
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+    ! NDim=0 for scalars.  Handle read of old NDim=1 files.  TBH:  20060502
+    IF ( ( NDim == 0 ) .AND. ( StoredDim == 2 ) ) THEN
+      stat = NF_INQ_DIMNAME(NCID,VDimIDs(1),dimname)
+      call netcdf_err(stat,Status)
+      if(Status /= WRF_NO_ERR) then
+        write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      endif
+      IF ( dimname(1:10) == 'ext_scalar' ) THEN
+        NDim = 1
+        Length(1) = 1
+      ENDIF
+    ENDIF
+    if(StoredDim /= NDim+1) then
+      Status = WRF_ERR_FATAL_BAD_VARIABLE_DIM
+      write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ext_ncd_read_field ',TRIM(Var),TRIM(DateStr)
+      call wrf_debug ( FATAL , msg)
+      write(msg,*) '  StoredDim ', StoredDim, ' .NE. NDim+1 ', NDim+1
+      call wrf_debug ( FATAL , msg)
+      return
+    endif
+    do j=1,NDim
+      stat = NF_INQ_DIMLEN(NCID,VDimIDs(j),StoredLen(j))
+      call netcdf_err(stat,Status)
+      if(Status /= WRF_NO_ERR) then
+        write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      endif
+      if(Length(j) > StoredLen(j)) then
+        Status = WRF_WARN_READ_PAST_EOF
+        write(msg,*) 'Warning READ PAST EOF in ext_ncd_read_field of ',TRIM(Var),Length(j),'>',StoredLen(j)
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      elseif(Length(j) <= 0) then
+        Status = WRF_WARN_ZERO_LENGTH_READ
+        write(msg,*) 'Warning ZERO LENGTH READ in ',__FILE__,', line', __LINE__
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      elseif(DomainStart(j) < MemoryStart(j)) then
+        Status = WRF_WARN_DIMENSION_ERROR
+        write(msg,*) 'Warning dim ',j,' DomainStart (',DomainStart(j), &
+                     ') < MemoryStart (',MemoryStart(j),') in ',__FILE__,', line', __LINE__
+        call wrf_debug ( WARN , TRIM(msg))
+!        return
+      endif
+    enddo
+
+    StoredStart = 1
+    call GetIndices(NDim,MemoryStart,MemoryEnd,l1,l2,m1,m2,n1,n2)
+    call GetIndices(NDim,StoredStart,StoredLen,x1,x2,y1,y2,z1,z2)
+!jm    call GetIndices(NDim,DomainStart,DomainEnd,i1,i2,j1,j2,k1,k2)
+    call GetIndices(NDim,PatchStart,PatchEnd,i1,i2,j1,j2,k1,k2)
+
+    di=1
+    if(FieldType == WRF_DOUBLE) di=2
+    allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat)
+    if(stat/= 0) then
+      Status = WRF_ERR_FATAL_ALLOCATION_ERROR
+      write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+      call wrf_debug ( FATAL , msg)
+      return
+    endif
+    call FieldIO('read',DataHandle,DateStr,Length,MemoryOrder, &
+                  FieldType,NCID,VarID,XField,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ 
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+    call Transpose('read',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
+                                        ,XField,x1,x2,y1,y2,z1,z2 &
+                                               ,i1,i2,j1,j2,k1,k2 )
+    deallocate(XField, STAT=stat)
+    if(stat/= 0) then
+      Status = WRF_ERR_FATAL_DEALLOCATION_ERR
+      write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__
+      call wrf_debug ( FATAL , msg)
+      return
+    endif
+  else
+    Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+    write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( FATAL , msg)
+  endif
+  DH%first_operation  = .FALSE.
+  return
+end subroutine ext_ncd_read_field
+
+subroutine ext_ncd_inquire_opened( DataHandle, FileName , FileStatus, Status )
+  use wrf_data
+  use ext_ncd_support_routines
+  implicit none
+  include 'wrf_status_codes.h'
+  integer               ,intent(in)     :: DataHandle
+  character*(*)         ,intent(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,*) 'DH%FileStatus ',DH%FileStatus
+    call wrf_debug ( FATAL , msg)
+    write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( FATAL , msg)
+  endif
+  return
+end subroutine ext_ncd_get_next_time
+
+subroutine ext_ncd_get_previous_time(DataHandle, DateStr, Status)
+  use wrf_data
+  use ext_ncd_support_routines
+  implicit none
+  include 'wrf_status_codes.h'
+  integer               ,intent(in)     :: DataHandle
+  character*(*)         ,intent(out)    :: DateStr
+  integer               ,intent(out)    :: Status
+  type(wrf_data_handle) ,pointer        :: DH
+
+  call GetDH(DataHandle,DH,Status)
+  if(Status /= WRF_NO_ERR) then
+    write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  endif
+  if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
+    Status = WRF_WARN_FILE_NOT_OPENED
+    write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+  elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
+    Status = WRF_WARN_DRYRUN_READ
+    write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+  elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
+    Status = WRF_WARN_READ_WONLY_FILE
+    write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+  elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
+    if(DH%CurrentTime.GT.0) then
+      DH%CurrentTime     = DH%CurrentTime -1
+    endif
+    DateStr            = DH%Times(DH%CurrentTime)
+    DH%CurrentVariable = 0
+    Status = WRF_NO_ERR
+  else
+    Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+    write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( FATAL , msg)
+  endif
+  return
+end subroutine ext_ncd_get_previous_time
+
+subroutine ext_ncd_get_next_var(DataHandle, VarName, Status)
+  use wrf_data
+  use ext_ncd_support_routines
+  implicit none
+  include 'wrf_status_codes.h'
+  include 'netcdf.inc'
+  integer               ,intent(in)     :: DataHandle
+  character*(*)         ,intent(out)    :: VarName
+  integer               ,intent(out)    :: Status
+  type(wrf_data_handle) ,pointer        :: DH
+  integer                               :: stat
+  character (80)                        :: Name
+
+  call GetDH(DataHandle,DH,Status)
+  if(Status /= WRF_NO_ERR) then
+    write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  endif
+  if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
+    Status = WRF_WARN_FILE_NOT_OPENED
+    write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+  elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
+    Status = WRF_WARN_DRYRUN_READ
+    write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+  elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
+    Status = WRF_WARN_READ_WONLY_FILE
+    write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+  elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
+
+    DH%CurrentVariable = DH%CurrentVariable +1
+    if(DH%CurrentVariable > DH%NumVars) then
+      Status = WRF_WARN_VAR_EOF
+      return
+    endif
+    VarName = DH%VarNames(DH%CurrentVariable)
+    Status  = WRF_NO_ERR
+  else
+    Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+    write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( FATAL , msg)
+  endif
+  return
+end subroutine ext_ncd_get_next_var
+
+subroutine ext_ncd_end_of_frame(DataHandle, Status)
+  use wrf_data
+  use ext_ncd_support_routines
+  implicit none
+  include 'netcdf.inc'
+  include 'wrf_status_codes.h'
+  integer               ,intent(in)     :: DataHandle
+  integer               ,intent(out)    :: Status
+  type(wrf_data_handle) ,pointer        :: DH
+
+  call GetDH(DataHandle,DH,Status)
+  return
+end subroutine ext_ncd_end_of_frame
+
+! NOTE:  For scalar variables NDim is set to zero and DomainStart and 
+! NOTE:  DomainEnd are left unmodified.  
+subroutine ext_ncd_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status)
+  use wrf_data
+  use ext_ncd_support_routines
+  implicit none
+  include 'netcdf.inc'
+  include 'wrf_status_codes.h'
+  integer               ,intent(in)     :: DataHandle
+  character*(*)         ,intent(in)     :: Name
+  integer               ,intent(out)    :: NDim
+  character*(*)         ,intent(out)    :: MemoryOrder
+  character*(*)                         :: Stagger ! Dummy for now
+  integer ,dimension(*) ,intent(out)    :: DomainStart, DomainEnd
+  integer               ,intent(out)    :: WrfType
+  integer               ,intent(out)    :: Status
+  type(wrf_data_handle) ,pointer        :: DH
+  integer                               :: VarID
+  integer ,dimension(NVarDims)          :: VDimIDs
+  integer                               :: j
+  integer                               :: stat
+  integer                               :: XType
+
+  call GetDH(DataHandle,DH,Status)
+  if(Status /= WRF_NO_ERR) then
+    write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  endif
+  if(DH%FileStatus == WRF_FILE_NOT_OPENED) then
+    Status = WRF_WARN_FILE_NOT_OPENED
+    write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then
+    Status = WRF_WARN_DRYRUN_READ
+    write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
+    Status = WRF_WARN_READ_WONLY_FILE
+    write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( WARN , TRIM(msg))
+    return
+  elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
+    stat = NF_INQ_VARID(DH%NCID,Name,VarID)
+    call netcdf_err(stat,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ 
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+    stat = NF_INQ_VARTYPE(DH%NCID,VarID,XType)
+    call netcdf_err(stat,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ 
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+    stat = NF_GET_ATT_INT(DH%NCID,VarID,'FieldType',WrfType)
+    call netcdf_err(stat,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ 
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+    select case (XType)
+      case (NF_BYTE)
+        Status = WRF_WARN_BAD_DATA_TYPE
+        write(msg,*) 'Warning BYTE IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      case (NF_CHAR)
+        Status = WRF_WARN_BAD_DATA_TYPE
+        write(msg,*) 'Warning CHAR IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      case (NF_SHORT)
+        Status = WRF_WARN_BAD_DATA_TYPE
+        write(msg,*) 'Warning SHORT IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      case (NF_INT)
+        if(WrfType /= WRF_INTEGER .and. WrfType /= WRF_LOGICAL) then
+          Status = WRF_WARN_BAD_DATA_TYPE
+          write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ 
+          call wrf_debug ( WARN , TRIM(msg))
+          return
+        endif
+      case (NF_FLOAT)
+        if(WrfType /= WRF_REAL) then
+          Status = WRF_WARN_BAD_DATA_TYPE
+          write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ 
+          call wrf_debug ( WARN , TRIM(msg))
+          return
+        endif
+      case (NF_DOUBLE)
+        if(WrfType /= WRF_DOUBLE) then
+          Status = WRF_WARN_BAD_DATA_TYPE
+          write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ 
+          call wrf_debug ( WARN , TRIM(msg))
+          return
+        endif
+      case default
+        Status = WRF_WARN_DATA_TYPE_NOT_FOUND
+        write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+    end select
+
+    stat = NF_GET_ATT_TEXT(DH%NCID,VarID,'MemoryOrder',MemoryOrder)
+    call netcdf_err(stat,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ 
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+    call GetDim(MemoryOrder,NDim,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'Warning BAD MEMORY ORDER ',TRIM(MemoryOrder),' in ',__FILE__,', line', __LINE__
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+    stat = NF_INQ_VARDIMID(DH%NCID,VarID,VDimIDs)
+    call netcdf_err(stat,Status)
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ 
+      call wrf_debug ( WARN , TRIM(msg))
+      return
+    endif
+    do j = 1, NDim
+      DomainStart(j) = 1
+      stat = NF_INQ_DIMLEN(DH%NCID,VDimIDs(j),DomainEnd(j))
+      call netcdf_err(stat,Status)
+      if(Status /= WRF_NO_ERR) then
+        write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ 
+        call wrf_debug ( WARN , TRIM(msg))
+        return
+      endif
+    enddo
+  else
+    Status = WRF_ERR_FATAL_BAD_FILE_STATUS
+    write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ 
+    call wrf_debug ( FATAL , msg)
+  endif
+  return
+end subroutine ext_ncd_get_var_info
+
+subroutine ext_ncd_warning_str( Code, ReturnString, Status)
+  use wrf_data
+  use ext_ncd_support_routines
+  implicit none
+  include 'netcdf.inc'
+  include 'wrf_status_codes.h'
+  
+  integer  , intent(in)  ::Code
+  character *(*), intent(out) :: ReturnString
+  integer, intent(out) ::Status
+  
+  SELECT CASE (Code)
+  CASE (0)
+      ReturnString='No error'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1)
+      ReturnString= 'File not found (or file is incomplete)'
+      Status=WRF_NO_ERR
+      return
+  CASE (-2)
+      ReturnString='Metadata not found'
+      Status=WRF_NO_ERR
+      return
+  CASE (-3)
+      ReturnString= 'Timestamp not found'
+      Status=WRF_NO_ERR
+      return
+  CASE (-4)
+      ReturnString= 'No more timestamps'
+      Status=WRF_NO_ERR
+      return
+  CASE (-5)
+      ReturnString= 'Variable not found'
+      Status=WRF_NO_ERR
+      return
+  CASE (-6)
+      ReturnString= 'No more variables for the current time'
+      Status=WRF_NO_ERR
+      return
+  CASE (-7)
+      ReturnString= 'Too many open files'
+      Status=WRF_NO_ERR
+      return
+  CASE (-8)
+      ReturnString= 'Data type mismatch'
+      Status=WRF_NO_ERR
+      return
+  CASE (-9)
+      ReturnString= 'Attempt to write read-only file'
+      Status=WRF_NO_ERR
+      return
+  CASE (-10)
+      ReturnString= 'Attempt to read write-only file'
+      Status=WRF_NO_ERR
+      return
+  CASE (-11)
+      ReturnString= 'Attempt to access unopened file'
+      Status=WRF_NO_ERR
+      return
+  CASE (-12)
+      ReturnString= 'Attempt to do 2 trainings for 1 variable'
+      Status=WRF_NO_ERR
+      return
+  CASE (-13)
+      ReturnString= 'Attempt to read past EOF'
+      Status=WRF_NO_ERR
+      return
+  CASE (-14)
+      ReturnString= 'Bad data handle'
+      Status=WRF_NO_ERR
+      return
+  CASE (-15)
+      ReturnString= 'Write length not equal to training length'
+      Status=WRF_NO_ERR
+      return
+  CASE (-16)
+      ReturnString= 'More dimensions requested than training'
+      Status=WRF_NO_ERR
+      return
+  CASE (-17)
+      ReturnString= 'Attempt to read more data than exists'
+      Status=WRF_NO_ERR
+      return
+  CASE (-18)
+      ReturnString= 'Input dimensions inconsistent'
+      Status=WRF_NO_ERR
+      return
+  CASE (-19)
+      ReturnString= 'Input MemoryOrder not recognized'
+      Status=WRF_NO_ERR
+      return
+  CASE (-20)
+      ReturnString= 'A dimension name with 2 different lengths'
+      Status=WRF_NO_ERR
+      return
+  CASE (-21)
+      ReturnString= 'String longer than provided storage'
+      Status=WRF_NO_ERR
+      return
+  CASE (-22)
+      ReturnString= 'Function not supportable'
+      Status=WRF_NO_ERR
+      return
+  CASE (-23)
+      ReturnString= 'Package implements this routine as NOOP'
+      Status=WRF_NO_ERR
+      return
+
+!netcdf-specific warning messages
+  CASE (-1007)
+      ReturnString= 'Bad data type'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1008)
+      ReturnString= 'File not committed'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1009)
+      ReturnString= 'File is opened for reading'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1011)
+      ReturnString= 'Attempt to write metadata after open commit'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1010)
+      ReturnString= 'I/O not initialized'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1012)
+     ReturnString=  'Too many variables requested'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1013)
+     ReturnString=  'Attempt to close file during a dry run'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1014)
+      ReturnString= 'Date string not 19 characters in length'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1015)
+      ReturnString= 'Attempt to read zero length words'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1016)
+      ReturnString= 'Data type not found'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1017)
+      ReturnString= 'Badly formatted date string'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1018)
+      ReturnString= 'Attempt at read during a dry run'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1019)
+      ReturnString= 'Attempt to get zero words'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1020)
+      ReturnString= 'Attempt to put zero length words'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1021)
+      ReturnString= 'NetCDF error'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1022)
+      ReturnString= 'Requested length <= 1'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1023)
+      ReturnString= 'More data available than requested'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1024)
+      ReturnString= 'New date less than previous date'
+      Status=WRF_NO_ERR
+      return
+
+  CASE DEFAULT
+      ReturnString= 'This warning code is not supported or handled directly by WRF and NetCDF. &
+      & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need &
+      & to be calling a package-specific routine to return a message for this warning code.'
+      Status=WRF_NO_ERR
+  END SELECT
+
+  return
+end subroutine ext_ncd_warning_str
+
+!returns message string for all WRF and netCDF warning/error status codes
+!Other i/o packages must  provide their own routines to return their own status messages
+subroutine ext_ncd_error_str( Code, ReturnString, Status)
+  use wrf_data
+  use ext_ncd_support_routines
+  implicit none
+  include 'netcdf.inc'
+  include 'wrf_status_codes.h'
+
+  integer  , intent(in)  ::Code
+  character *(*), intent(out) :: ReturnString
+  integer, intent(out) ::Status
+
+  SELECT CASE (Code)
+  CASE (-100)
+      ReturnString= 'Allocation Error'
+      Status=WRF_NO_ERR
+      return
+  CASE (-101)
+      ReturnString= 'Deallocation Error'
+      Status=WRF_NO_ERR
+      return
+  CASE (-102)
+      ReturnString= 'Bad File Status'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1004)
+      ReturnString= 'Variable on disk is not 3D'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1005)
+      ReturnString= 'Metadata on disk is not 1D'
+      Status=WRF_NO_ERR
+      return
+  CASE (-1006)
+      ReturnString= 'Time dimension too small'
+      Status=WRF_NO_ERR
+      return
+  CASE DEFAULT
+      ReturnString= 'This error code is not supported or handled directly by WRF and NetCDF. &
+      & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & 
+      & to be calling a package-specific routine to return a message for this error code.'
+      Status=WRF_NO_ERR
+  END SELECT
+
+  return
+end subroutine ext_ncd_error_str
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/INSTALL.htm
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/INSTALL.htm	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/INSTALL.htm	(revision 17)
@@ -0,0 +1,1207 @@
+<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"><html><head>
+<meta http-equiv="Content-Language" content="en-us">
+<meta name="GENERATOR" content="Microsoft FrontPage 5.0">
+<meta name="ProgId" content="FrontPage.Editor.Document">
+<meta http-equiv="Content-Type" content="text/html; charset=windows-1252"><title>To integrate HDF5</title></head><body><big><big><b>Build and Install the HDF5-WRF IO Module</b></big></big><br>
+<br>
+There are two HDF5 WRF IO modules, <i>sequential</i> and <i>parallel.</i>  The either or both modules can be configured as optional IO modules for WRF.<br>
+<br>
+The sequential HDF module (<i>io_hdf5</i>) uses the serial HDF5 library.  The parallel
+HDF module (<i>io_phdf5</i>) uses parallel HDF5 (which requires MPI-IO).<br>
+<br>
+The installation for the two modules is similar.<br>
+<br>
+<big><b>Prerequisites</b></big><br>
+<br>
+<b>WRF 1.3</b><br>
+<br>
+The HDF5 WRF IO modules require Version 1.3 of WRF.  Information and downloads are available at:<br>
+ 
+<blockquote><a href="http://www.mmm.ucar.edu/wrf/users/user_main.html">http://www.mmm.ucar.edu/wrf/users/user_main.html</a><br>
+</blockquote>
+<br>
+<b>HDF5-1.6 .2 or later</b><br>
+<br>
+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). <br>
+<br>
+Installing HDF5<br>
+<blockquote>
+  </blockquote>
+<ol>
+  <li>To obtain 
+  HDF5, download from to <a href="http://hdf.ncsa.uiuc.edu/HDF5/release/obtain5.html">
+  http://hdf.ncsa.uiuc.edu/HDF5/release/obtain5.html</a>. Install HDF5 according to the instructions. The HDF5 library must have he Fortran 90 interface installed. <br><br>
+ For the sequential WRF module,  SZIP compression can be enabled.  </li>
+  <li>
+For the parallel WRF module, parallel HDF5 must be installed (this requires MPI-IO). <br>
+Set the environment variable PHDF5 = &lt;&lt;path where phdf5 is installed&gt;&gt;.
+  
+   </li>
+
+  <li>For the sequential HDF WRF IO module, either serial or parallel HDF must be installed.<br>
+The HDF library may be installed with the optional SZIP compression enabled. <br>
+Set the environment variable HDF5 = &lt;&lt;path where hdf5 is installed&gt;&gt;.
+  
+  <br>
+  </li>
+</ol>
+<br>
+<big><b>Platforms</b></big><br>
+<p><small><small><font size="5"><small><small>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.<br>
+</small></small></font></small></small></p>
+<table cellpadding="2" cellspacing="2" border="1" width="100%">
+  <tbody>
+    <tr>
+      <td valign="top"><b>Module<br>
+      </b></td>
+      <td valign="top"><b>Platforms<br>
+      </b></td>
+      <td valign="top"><b>Notes<br>
+      </b></td>
+    </tr>
+    <tr>
+      <td valign="top">Sequential <br>
+      </td>
+      <td valign="top"><small><small><font size="5"><small><small> 
+NCSA IBM P690</small></small></font></small></small>.<br>
+      <small><small><font size="5"><small><small> NCAR IBM SP3 </small></small></font></small></small><br>
+      <small><small><font size="5"><small><small>PC Linux </small></small></font></small></small>with PGI Fortran 90 Compiler, Vers. 4<br>
+      <small><small><font size="5"><small><small>SGI IRIX6.5-64 bi</small></small></font></small></small>t<br>
+      </td>
+      <td valign="top">To date, WRF3.1 does not work on Linux with PGF, version 5.<br>
+      </td>
+    </tr>
+    <tr>
+      <td valign="top">Parallel<br>
+      </td>
+      <td valign="top"><small><small><font size="5"><small><small> 
+NCSA IBM P690</small></small></font></small></small>.<br>
+
+      <small><small><font size="5"><small><small> NCAR IBM SP3 </small></small></font></small></small><br>
+      </td>
+      <td valign="top"><br>
+      </td>
+    </tr>
+  </tbody>
+</table>
+<br>
+<br>
+<big><b>Installation of the HDF5 WRF IO Modules</b></big><br>
+<br>
+The HDF5 WRF IO modules are used by adding it to a standard WRF configuration.  This process has four main steps<br>
+<ol>
+  <li>Downoad the HDF WRF IO module(s)</li><li>Add the HDF5 WRF IO module(s) as an "extern" module</li>
+
+  <li>Modifying relevant files in the WRF distribution</li>
+  <li>Compile WRF following the usual procedures<br>
+  </li>
+
+</ol>
+The parallel, sequential, or both may be configured.<br>
+<br>
+<b>1. Download the WRD-HDF5 IO modules</b><br>
+<br>
+The HDF WRF IO modules are available from:<br>
+<ul>
+  <li>sequential: <a href="ftp://ftp.ncsa.uiuc.edu/HDF/pub/outgoing/wrf-hdf5-modules/io_hdf5.tar">
+    ftp://ftp.ncsa.uiuc.edu/HDF/pub/outgoing/wrf-hdf5-modules/io_hdf5.tar</a></li>
+  <li>parallel: 
+    <a href="ftp://ftp.ncsa.uiuc.edu/HDF/pub/outgoing/wrf-hdf5-modules/io_phdf5.tar">
+    ftp://ftp.ncsa.uiuc.edu/HDF/pub/outgoing/wrf-hdf5-modules/io_phdf5.tar</a><br>
+  </li>
+</ul>
+<blockquote><p></p>
+</blockquote>
+<p><b><small>
+    <font size="4"><small>2. Add WRF-HDF5 IO module(s) to the WRF source</small></font></small></b></p>
+
+    
+<p>
+    The HDF5 WRF IO modules are added as sub-directories in the 'external' directory of the WRF source.<br>
+</p>
+<blockquote><blockquote>
+    
+    
+    <p> cd external;<br>
+tar xvf io_hdf5.tar<br>
+tar xvf io_phdf5.tar<br>
+    </p>
+</blockquote></blockquote>
+
+<p>
+  </p>
+
+<table cellpadding="2" cellspacing="2" border="1" width="90%" align="center">
+
+
+    <tbody>
+      <tr>
+        <td valign="top">contents of the sequential HDF WRF IO module:<br>
+      <br>
+  ./io_hdf5<br>  ./io_hdf5/wrf-hdf5.F90<br>  ./io_hdf5/wrf_status_codes.h<br>  ./io_hdf5/Makefile<br>  ./io_hdf5/wrf-hdf5attr.F90<br>  ./io_hdf5/wrf-hdf5support.F90<br>  ./io_hdf5/wrf_io_flags.h<br>
+        </td>
+      </tr>
+    </tbody>
+  
+</table>
+
+
+<br>
+
+<br>
+
+
+  
+<table cellpadding="2" cellspacing="2" border="1" width="90%" align="center">
+
+
+    <tbody>
+      <tr>
+        <td valign="top">contents of the sequential HDF WRF IO module:<br>
+      <br>
+  ./io_phdf5/<br>  ./io_phdf5/Makefile<br>  ./io_phdf5/wrf_status_codes.h<br>  ./io_phdf5/wrf-phdf5attr.F90<br>  ./io_phdf5/wrf-phdf5support.F90<br>  ./io_phdf5/wrf_io_flags.h<br>  ./io_phdf5/wrf-phdf5.F90<br>
+        </td>
+      </tr>
+    </tbody>
+  
+</table>
+
+
+<br>
+
+
+<p><b><small><small><font size="5"><small><small>Design note:</small></small></font></small></small></b></p>
+
+<p><small><small><font size="5"><small><small>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.  <br>
+</small></small></font></small></small></p>
+
+
+<p><small><small><font size="5"><small><small>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.</small></small></font><br>
+<font size="5"><small><small><br>
+<i>To disable compression:</i></small></small></font></small></small></p>
+
+
+
+<blockquote>
+  <p><small><font size="5"><small><small>Edit</small></small></font><font size="4"><small> the file '</small></font></small><small><font size="4"><small>wrf/external/io_hdf5/</small></font></small><small><font size="4"><small>wrf-hdf5.F90</small></font></small><small><font size="4"><small>'<br>
+</small></font></small></p>
+  <p><small><font size="4"><small>Comment out the lines: </small></font></small></p>
+  <p><small><font face="Arial" size="4"><small>            
+call h5pset_shuffle_f(crp_list,hdf5err) </small></font></small></p>
+  <p><small><font size="4"><small>                
+and </small></font></small></p>
+  <p><small><font size="4" face="Arial"><small>            
+call h5pset_deflate_f(crp_list,6,hdf5err) </small></font></small></p>
+</blockquote>
+
+
+
+
+
+
+
+
+
+<p><i><small><small><font size="5"><small><small>To use  SZIP compression instead:</small></small></font></small></small></i></p>
+
+
+<blockquote>
+  <p><small><font size="4"><small>For SZIP information and downloads, see the szip at 
+<a href="http://hdf.ncsa.uiuc.edu/doc_resource/SZIP/">
+http://hdf.ncsa.uiuc.edu/doc_resource/SZIP/</a>.<br>
+</small></font></small></p>
+  <p><small><font size="4"><small>Edit the file 'wrf/external/io_hdf5/</small></font></small><small><font size="4"><small>wrf-hdf5.F90'.</small></font></small></p>
+  <p><small><font size="4"><small>Comment out the lines: </small></font></small></p>
+  <p><small><font face="Arial" size="4"><small>            
+call h5pset_shuffle_f(crp_list,hdf5err) </small></font></small></p>
+  <p><small><font size="4"><small>                
+and </small></font></small></p>
+  <p><small><font size="4" face="Arial"><small>            
+call h5pset_deflate_f(crp_list,6,hdf5err) </small></font></small></p>
+  <p><small><font size="4"><small>Uncomment the line:
+</small></font></small></p>
+  <p><small><font size="4"><small>             
+<font face="Arial">call 
+h5pset_szip_f(crp_list,H5_SZIP_AK13_OM_F+H5_SZIP_NN_OM_F,8,hdf5err)</font><br>
+</small></font></small></p>
+  <p><small><font size="4"><small>Change the value 
+of the parameters in the function <i>h5pset_szip_f</i> if necessary.</small></font></small>  See the SZIP documentation for more information about the parameters.<br>
+  </p>
+</blockquote>
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+<p><br>
+</p>
+<p><font size="4"><b><small>3. Modifications to WRF files</small></b><br>
+</font></p>
+
+<p><font size="4"><small>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:<br>
+</small></font></p>
+<table cellpadding="2" cellspacing="2" border="1" width="50%" align="center">
+  <tbody>
+    <tr>
+      <td valign="top">WRFV1/configure<br>
+WRFV1/Registry/Registry<br>
+WRFV1/arch/Config.pl<br>
+WRFV1/arch/configure.defaults<br>
+WRFV1/frame/md_calls.m4<br>
+WRFV1/frame/module_io.F<br>
+WRFV1/share/module_io_wrf.F<br>
+WRFV1/external/Makefile<br>
+      </td>
+    </tr>
+  </tbody>
+</table>
+<br>
+The exact changes depend on how WRF has been configured on the sytsem.  <br>
+<p>Examples of the changes to the files of the WRF1.3 distribution are available at:<br>
+</p>
+<p> 
+    
+    <a href="ftp://ftp.ncsa.uiuc.edu/HDF/pub/outgoing/wrf-hdf5-modules">
+    ftp://ftp.ncsa.uiuc.edu/HDF/pub/outgoing/wrf-hdf5-modules</a><br>
+</p>
+
+<blockquote>
+  </blockquote>
+<p><i><b>WRF configuration files<br>
+</b></i>
+</p>
+<p>The 'configure' file must be updated to add the HDF5 and PHDF5 variables.<br>
+</p>
+<table cellpadding="2" cellspacing="2" border="1" align="center" width="90%">
+  <tbody>
+    <tr>
+      <td valign="top">*** ../WRFV1/configure	Thu Feb  6 13:10:56 2003<br>
+--- ./WRFV1-with-hdf/configure	Thu May 13 12:18:40 2004<br>
+***************<br>
+*** 206,211 ****<br>
+--- 206,223 ----<br>
+    echo "Will configure for use without NetCDF"<br>
+  fi<br>
+  <br>
++ if [ -n "$HDF5" ] ; then<br>
++   echo "Will use HDF5 in dir: $HDF5"<br>
++ else<br>
++   echo "Will configure for use without HDF5"<br>
++ fi<br>
++ <br>
++ if [ -n "$PHDF5" ] ; then<br>
++   echo "Will use PHDF5 in dir: $PHDF5"<br>
++ else<br>
++   echo "Will configure for use without PHDF5"<br>
++ fi<br>
++ <br>
+  # if the uname command exists, give it a shot and see if<br>
+  # we can narrow the choices; otherwise, spam 'em<br>
+  os="ARCH"<br>
+***************<br>
+*** 227,232 ****<br>
+  <br>
+  # Found perl, so proceed with configuration<br>
+  if test -n "$PERL" ; then<br>
+!   $PERL arch/Config.pl -perl=$PERL -netcdf=$NETCDF -os=$os -mach=$mach<br>
+  fi<br>
+  <br>
+--- 239,244 ----<br>
+  <br>
+  # Found perl, so proceed with configuration<br>
+  if test -n "$PERL" ; then<br>
+!   $PERL arch/Config.pl -perl=$PERL -netcdf=$NETCDF -hdf5=$HDF5 -phdf5=$PHDF5 -os=$os -mach=$mach<br>
+  fi<br>
+  <br>
+      </td>
+    </tr>
+  </tbody>
+</table>
+<p>The file 'Registry/Registry' must be updated to add the HDF IO modules (<i>io_hdf5</i> and <i>io_phdf5</i>).<br>
+</p>
+<table cellpadding="2" cellspacing="2" border="1" width="90%" align="center">
+  <tbody>
+    <tr>
+      <td valign="top">*** ../WRFV1/Registry/Registry	Wed Feb 12 09:28:28 2003<br>
+--- ./WRFV1-with-hdf/Registry/Registry	Thu May 13 12:18:39 2004<br>
+***************<br>
+*** 738,745 ****<br>
+  # Four placeholders for additional packages (we can go beyond zzz <br>
+  # but that will entail modifying frame/module_io.F and frame/md_calls.m4)<br>
+  # Please note these are placeholders; HDF has not been implemented yet.<br>
+! package   io_hdf      io_form_restart==3                     -             -<br>
+! package   io_xxx      io_form_restart==4                     -             -<br>
+  package   io_yyy      io_form_restart==5                     -             -<br>
+  package   io_zzz      io_form_restart==6                     -             -<br>
+                                                  <br>
+--- 738,745 ----<br>
+  # Four placeholders for additional packages (we can go beyond zzz <br>
+  # but that will entail modifying frame/module_io.F and frame/md_calls.m4)<br>
+  # Please note these are placeholders; HDF has not been implemented yet.<br>
+! package   io_hdf5     io_form_restart==3                     -             -<br>
+! package   io_phdf5    io_form_restart==4                     -             -<br>
+  package   io_yyy      io_form_restart==5                     -             -<br>
+  package   io_zzz      io_form_restart==6                     -             -<br>
+                                                 <br>
+      </td>
+    </tr>
+  </tbody>
+</table>
+<p>The file 'arch/Config.pl' needs to be changed to add the code to use the HDF5 and PHDF5 variables.<br>
+</p>
+<table cellpadding="2" cellspacing="2" border="1" width="90%" align="center">
+  <tbody>
+    <tr>
+      <td valign="top">*** ../WRFV1/arch/Config.pl	Fri Mar 16 12:06:46 2001<br>
+--- ./WRFV1-with-hdf/arch/Config.pl	Thu May 13 12:18:37 2004<br>
+***************<br>
+*** 7,12 ****<br>
+--- 7,14 ----<br>
+  <br>
+  $sw_perl_path = perl ;<br>
+  $sw_netcdf_path = "" ;<br>
++ $sw_hdf5_path ="";<br>
++ $sw_phdf5_path=""; <br>
+  $sw_os = "ARCH" ;           # ARCH will match any<br>
+  $sw_mach = "ARCH" ;         # ARCH will match any<br>
+  <br>
+***************<br>
+*** 20,25 ****<br>
+--- 22,35 ----<br>
+    {<br>
+      $sw_netcdf_path = substr( $ARGV[0], 8 ) ;<br>
+    }<br>
++   if ( substr( $ARGV[0], 1, 5 ) eq "hdf5=" )<br>
++   {<br>
++     $sw_hdf5_path = substr( $ARGV[0], 6 ) ;<br>
++   }<br>
++   if ( substr( $ARGV[0], 1, 6 ) eq "phdf5=" )<br>
++   {<br>
++     $sw_phdf5_path = substr( $ARGV[0], 7 ) ;<br>
++   }<br>
+    if ( substr( $ARGV[0], 1, 3 ) eq "os=" )<br>
+    {<br>
+      $sw_os = substr( $ARGV[0], 4 ) ;<br>
+***************<br>
+*** 89,94 ****<br>
+--- 99,106 ----<br>
+    {<br>
+      $_ =~ s/CONFIGURE_PERL_PATH/$sw_perl_path/g ;<br>
+      $_ =~ s/CONFIGURE_NETCDF_PATH/$sw_netcdf_path/g ;<br>
++     $_ =~ s/CONFIGURE_HDF5_PATH/$sw_hdf5_path/g ;<br>
++     $_ =~ s/CONFIGURE_PHDF5_PATH/$sw_phdf5_path/g ;<br>
+      if ( $sw_netcdf_path ) <br>
+        { $_ =~ s/CONFIGURE_WRFIO_NF/wrfio_nf/g ;<br>
+  	$_ =~ s:CONFIGURE_NETCDF_FLAG:-DNETCDF: ;<br>
+***************<br>
+*** 99,104 ****<br>
+--- 111,140 ----<br>
+  	$_ =~ s:CONFIGURE_NETCDF_FLAG::g ;<br>
+  	$_ =~ s:CONFIGURE_NETCDF_LIB_PATH::g ;<br>
+  	 }<br>
++ <br>
++     if ( $sw_hdf5_path ) <br>
++ <br>
++       { $_ =~ s/CONFIGURE_WRFIO_HDF5/wrfio_hdf5/g ;<br>
++ 	$_ =~ s:CONFIGURE_HDF5_FLAG:-DHDF5: ;<br>
++ 	$_ =~ 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: ;<br>
++ 	 }<br>
++     else                   <br>
++       { $_ =~ s/CONFIGURE_WRFIO_HDF5//g ;<br>
++ 	$_ =~ s:CONFIGURE_HDF5_FLAG::g ;<br>
++ 	$_ =~ s:CONFIGURE_HDF5_LIB_PATH::g ;<br>
++ 	 }<br>
++ <br>
++     if ( $sw_phdf5_path ) <br>
++ <br>
++       { $_ =~ s/CONFIGURE_WRFIO_PHDF5/wrfio_phdf5/g ;<br>
++ 	$_ =~ s:CONFIGURE_PHDF5_FLAG:-DPHDF5: ;<br>
++ 	$_ =~ s:CONFIGURE_PHDF5_LIB_PATH:-L../external/io_phdf5 -lwrfio_phdf5 -L$sw_phdf5_path/lib -lhdf5_fortran -lhdf5 -lm -lz: ;<br>
++ 	 }<br>
++     else                   <br>
++       { $_ =~ s/CONFIGURE_WRFIO_PHDF5//g ;<br>
++ 	$_ =~ s:CONFIGURE_PHDF5_FLAG::g ;<br>
++ 	$_ =~ s:CONFIGURE_PHDF5_LIB_PATH::g ;<br>
++ 	 }<br>
+      @machopts = ( @machopts, $_ ) ;<br>
+    }<br>
+    if ( substr( $_, 0, 5 ) eq "#ARCH" &amp;&amp; $latchon == 0 )<br>
+      <br>
+      </td>
+    </tr>
+  </tbody>
+</table>
+<p>The file 'arch/configure.defauts' must be edited to reflect the configuration of the current system.<br>
+</p>
+<table cellpadding="2" cellspacing="2" border="1" width="90%" align="center">
+  <tbody>
+    <tr>
+      <td valign="top">*** ../WRFV1/arch/configure.defaults	Fri Mar 28 14:08:48 2003<br>
+--- ./WRFV1-with-hdf/arch/configure.defaults	Thu May 13 12:18:40 2004<br>
+***************<br>
+*** 732,758 ****<br>
+  <br>
+  <br>
+  ###########################################################<br>
+! #ARCH	AIX DM          (RSL-IO, IBM-MPI)<br>
+  #<br>
+  DMPARALLEL      =       1<br>
+! SFC             =       xlf90_r<br>
+  SCC             =       xlc_r<br>
+! FC              =       mpxlf90_r<br>
+  CC              =       mpcc_r<br>
+  CFLAGS          =       -DNOUNDERSCORE -DWRF_RSL_IO  -I../external/RSL/RSL -DDM_PARALLEL  \<br>
+                          -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC)<br>
+! FCOPTIM         =       -O2 -qarch=auto -qmaxmem=32676<br>
+  FCDEBUG         =       # -g -qfullpath<br>
+  FCBASEOPTS      =       -qspill=20000 $(FCDEBUG)<br>
+  FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS)<br>
+! INCLUDE_MODULES =       -I../external/io_netcdf -I../external/io_int  \<br>
+                          -I../frame -I../share -I../phys -I../inc<br>
+  EXTRAMODULES    =       <br>
+  ARCHFLAGS       =       -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 -DRWORDSIZE=4 \<br>
+!                         -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG -DTRIEDNTRUE -DONLY_WRFMODEL_IO -DINTIO<br>
+  PERL            =       perl<br>
+  REGISTRY        =       Registry<br>
+! LIB             =       CONFIGURE_NETCDF_LIB_PATH -L../external/RSL/RSL -lrsl -lmass \<br>
+                          -L../external/io_int -lwrfio_int  \<br>
+  			../frame/internal_header_util.o ../frame/pack_utils.o<br>
+  LDFLAGS         =	-bmaxstack:256000000<br>
+--- 732,823 ----<br>
+  <br>
+  <br>
+  ###########################################################<br>
+! #ARCH	AIX DM          (RSL-IO, IBM-MPI)(PARALLEL HDF5)<br>
+  #<br>
+  DMPARALLEL      =       1<br>
+! SFC             =       xlf90_r <br>
+  SCC             =       xlc_r<br>
+! FC              =       mpxlf90_r <br>
+  CC              =       mpcc_r<br>
+  CFLAGS          =       -DNOUNDERSCORE -DWRF_RSL_IO  -I../external/RSL/RSL -DDM_PARALLEL  \<br>
+                          -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC)<br>
+! FCOPTIM         =       -O1 -qarch=auto -qmaxmem=-1<br>
+! #FCOPTIM         =       -O2 <br>
+! FCDEBUG         =       -g -qfullpath<br>
+! FCBASEOPTS      =       -qspill=20000 $(FCDEBUG)<br>
+! FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS)<br>
+! INCLUDE_MODULES =       -I../external/io_netcdf -I../external/io_phdf5 -I../external/io_int  \<br>
+!                         -I../frame -I../share -I../phys -I../inc<br>
+! EXTRAMODULES    =       <br>
+! ARCHFLAGS       =       -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 -DRWORDSIZE=4 \<br>
+!                         -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG CONFIGURE_PHDF5_FLAG -DTRIEDNTRUE -DONLY_WRFMODEL_IO -DINTIO<br>
+! PERL            =       perl<br>
+! REGISTRY        =       Registry<br>
+! LIB             =       CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PHDF5_LIB_PATH -L../external/RSL/RSL -lrsl -lmass \<br>
+!                         -L../external/io_int -lwrfio_int  \<br>
+! 			../frame/internal_header_util.o ../frame/pack_utils.o<br>
+! LDFLAGS         =	-bmaxstack:256000000 -bmaxdata:0x80000000<br>
+! CPP		=	/lib/cpp<br>
+! CPPFLAGS	=	-I$(LIBINCLUDE) -C -P $(ARCHFLAGS) -I../external/RSL/RSL `cat ../inc/dm_comm_cpp_flags`<br>
+! MAX_DOMAINS     =       4<br>
+! MAX_PROC        =       1024<br>
+! AR              =       ar ru<br>
+! M4              =       m4 -B 8000<br>
+! RANLIB          =       ranlib<br>
+! <br>
+! externals : CONFIGURE_WRFIO_NF CONFIGURE_WRFIO_PHDF5 ../external/RSL/RSL/librsl.a wrfio_int<br>
+! 	( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL/gen_comms.c
+&gt;&gt; ../tools/gen_comms.c ;  \<br>
+!           /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F &gt;&gt; module_dm.F )<br>
+! <br>
+! wrfio_nf : <br>
+! 	( 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 )<br>
+! <br>
+! wrfio_phdf5 : <br>
+! 	( 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 )<br>
+! <br>
+! wrfio_int : <br>
+! 	( cd ../external/io_int ; \<br>
+!           make CC=$(CC) FC="$(SFC) $(FCDEBUG) -qarch=auto -qzerosize" all diffwrf )<br>
+! <br>
+! ../external/RSL/RSL/librsl.a :<br>
+! 	( cd ../external/RSL/RSL ; make MAX_DOMAINS=$(MAX_DOMAINS) MAX_PROC=$(MAX_PROC) LEARN_BCAST=-DLEARN_BCAST sp2 )<br>
+! <br>
+! # compile these without high optimization to speed compile<br>
+! mediation_force_domain.o : mediation_force_domain.F<br>
+! mediation_interp_domain.o : mediation_interp_domain.F<br>
+! <br>
+! mediation_force_domain.o \<br>
+! mediation_interp_domain.o :<br>
+! 	$(RM) $@<br>
+! 	sed /\!.\*\'/s/\'//g $*.F &gt; $*.b<br>
+! 	$(CPP) -I../inc $(CPPFLAGS) $*.b  &gt; $*.f<br>
+! 	$(RM) $*.b<br>
+! 	$(FC) -c $(FCBASEOPTS) $(MODULE_DIRS) $*.f<br>
+! <br>
+! ###########################################################<br>
+! #ARCH	AIX DM          (RSL-IO, IBM-MPI)(SERIAL HDF5)<br>
+! #<br>
+! DMPARALLEL      =       1<br>
+! SFC             =       xlf90_r <br>
+! SCC             =       xlc_r<br>
+! FC              =       mpxlf90_r <br>
+! CC              =       mpcc_r<br>
+! CFLAGS          =       -DNOUNDERSCORE -DWRF_RSL_IO  -I../external/RSL/RSL -DDM_PARALLEL  \<br>
+!                         -DMAXDOM_MAKE=$(MAX_DOMAINS) -DMAXPROC_MAKE=$(MAX_PROC)<br>
+! FCOPTIM         =       -O1 -qarch=auto -qmaxmem=32676<br>
+! #FCOPTIM         =       -O2 <br>
+  FCDEBUG         =       # -g -qfullpath<br>
+  FCBASEOPTS      =       -qspill=20000 $(FCDEBUG)<br>
+  FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS)<br>
+! INCLUDE_MODULES =       -I../external/io_netcdf -I../external/io_hdf5 -I../external/io_int  \<br>
+                          -I../frame -I../share -I../phys -I../inc<br>
+  EXTRAMODULES    =       <br>
+  ARCHFLAGS       =       -DWRF_RSL_IO -DRSL -DDM_PARALLEL -DIWORDSIZE=4 -DRWORDSIZE=4 \<br>
+!                         -DLWORDSIZE=4 CONFIGURE_NETCDF_FLAG CONFIGURE_HDF5_FLAG -DTRIEDNTRUE -DONLY_WRFMODEL_IO -DINTIO<br>
+  PERL            =       perl<br>
+  REGISTRY        =       Registry<br>
+! LIB             =       CONFIGURE_NETCDF_LIB_PATH CONFIGURE_HDF5_LIB_PATH  \<br>
+!                         -L../external/RSL/RSL -lrsl -lmass \<br>
+                          -L../external/io_int -lwrfio_int  \<br>
+  			../frame/internal_header_util.o ../frame/pack_utils.o<br>
+  LDFLAGS         =	-bmaxstack:256000000<br>
+***************<br>
+*** 764,776 ****<br>
+  M4              =       m4 -B 8000<br>
+  RANLIB          =       ranlib<br>
+  <br>
+! externals : CONFIGURE_WRFIO_NF ../external/RSL/RSL/librsl.a wrfio_int<br>
+  	( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL/gen_comms.c
+&gt;&gt; ../tools/gen_comms.c ;  \<br>
+            /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F &gt;&gt; module_dm.F )<br>
+  <br>
+  wrfio_nf : <br>
+  	( 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 )<br>
+  <br>
+  wrfio_int : <br>
+  	( cd ../external/io_int ; \<br>
+            make CC=$(CC) FC="$(SFC) $(FCDEBUG) -qarch=auto -qzerosize" all diffwrf )<br>
+--- 829,844 ----<br>
+  M4              =       m4 -B 8000<br>
+  RANLIB          =       ranlib<br>
+  <br>
+! externals : CONFIGURE_WRFIO_NF CONFIGURE_WRFIO_HDF5 ../external/RSL/RSL/librsl.a wrfio_int<br>
+  	( /bin/cp ../tools/gen_comms_warning ../tools/gen_comms.c ; cat ../external/RSL/gen_comms.c
+&gt;&gt; ../tools/gen_comms.c ;  \<br>
+            /bin/cp module_dm_warning module_dm.F ; cat ../external/RSL/module_dm.F &gt;&gt; module_dm.F )<br>
+  <br>
+  wrfio_nf : <br>
+  	( 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 )<br>
+  <br>
++ wrfio_hdf5 : <br>
++ 	( 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 )<br>
++ <br>
+  wrfio_int : <br>
+  	( cd ../external/io_int ; \<br>
+            make CC=$(CC) FC="$(SFC) $(FCDEBUG) -qarch=auto -qzerosize" all diffwrf )<br>
+***************<br>
+*** 1650,1663 ****<br>
+  FCBASEOPTS      =       -byteswapio -Ktrap=fp -Mfree -tp p6 $(FCDEBUG)<br>
+  FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS)<br>
+  ARCHFLAGS       =       -DDEREF_KLUDGE -DIO_DEREF_KLUDGE -DIWORDSIZE=4 -DRWORDSIZE=4 -DLWORDSIZE=4 \<br>
+!                          CONFIGURE_NETCDF_FLAG \<br>
+                          -DTRIEDNTRUE -DONLY_WRFMODEL_IO<br>
+! INCLUDE_MODULES =       -module ../main -I../external/io_netcdf -I../external/io_int \<br>
+                          -I../frame -I../share -I../phys -I../inc<br>
+  EXTRAMODULES    =       <br>
+  PERL            =       perl<br>
+  REGISTRY        =       Registry<br>
+! LIB             =       CONFIGURE_NETCDF_LIB_PATH \<br>
+  			../frame/internal_header_util.o ../frame/pack_utils.o<br>
+  LDFLAGS         =<br>
+  CPP             =       /lib/cpp<br>
+--- 1718,1731 ----<br>
+  FCBASEOPTS      =       -byteswapio -Ktrap=fp -Mfree -tp p6 $(FCDEBUG)<br>
+  FCFLAGS         =       $(FCOPTIM) $(FCBASEOPTS)<br>
+  ARCHFLAGS       =       -DDEREF_KLUDGE -DIO_DEREF_KLUDGE -DIWORDSIZE=4 -DRWORDSIZE=4 -DLWORDSIZE=4 \<br>
+!                          CONFIGURE_NETCDF_FLAG CONFIGURE_HDF5_FLAG\<br>
+                          -DTRIEDNTRUE -DONLY_WRFMODEL_IO<br>
+! INCLUDE_MODULES =       -module ../main -I../external/io_netcdf -I../external/io_hdf5 -I../external/io_int \<br>
+                          -I../frame -I../share -I../phys -I../inc<br>
+  EXTRAMODULES    =       <br>
+  PERL            =       perl<br>
+  REGISTRY        =       Registry<br>
+! LIB             =       CONFIGURE_NETCDF_LIB_PATH CONFIGURE_HDF5_LIB_PATH \<br>
+  			../frame/internal_header_util.o ../frame/pack_utils.o<br>
+  LDFLAGS         =<br>
+  CPP             =       /lib/cpp<br>
+***************<br>
+*** 1666,1672 ****<br>
+  M4              =       m4<br>
+  RANLIB          =       ranlib<br>
+  <br>
+! externals : CONFIGURE_WRFIO_NF wrfio_int<br>
+  	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F &gt;&gt; module_dm.F )<br>
+  <br>
+  wrfio_nf : <br>
+--- 1734,1740 ----<br>
+  M4              =       m4<br>
+  RANLIB          =       ranlib<br>
+  <br>
+! externals : CONFIGURE_WRFIO_NF CONFIGURE_WRFIO_HDF5 wrfio_int<br>
+  	( /bin/cp module_dm_warning module_dm.F ; cat module_dm_stubs.F &gt;&gt; module_dm.F )<br>
+  <br>
+  wrfio_nf : <br>
+***************<br>
+*** 1675,1680 ****<br>
+--- 1743,1754 ----<br>
+            FFLAGS='$(FCFLAGS) -ICONFIGURE_NETCDF_PATH/include' ; \<br>
+            /bin/cp wrf_io_flags.h wrf_status_codes.h ../../inc )<br>
+  <br>
++ wrfio_hdf5 : <br>
++ 	( cd ../external/io_hdf5 ; \<br>
++           make HDF5PATH=CONFIGURE_HDF5_PATH FC=$(FC) TRADFLAG="-traditional" \<br>
++           FFLAGS='$(FCFLAGS) -ICONFIGURE_HDF5_PATH/lib' ; \<br>
++           /bin/cp wrf_io_flags.h wrf_status_codes.h ../../inc )<br>
++ <br>
+  wrfio_int : <br>
+  	( cd ../external/io_int ; \<br>
+            make CC=$(CC) FC="$(SFC) $(FCDEBUG) $(FCBASEOPTS)" \<br>
+      </td>
+    </tr>
+  </tbody>
+</table>
+<p><br>
+
+  </p>
+<blockquote>
+  <ul>
+    </ul><p></p>
+  </blockquote>
+<p><i>Modifications of source code inside WRF</i><b><br>
+</b></p>
+<p>The<i> io_hdf5</i> and/or<i> io_phdf5</i> modules must be added to the WRF source. In addition, the WRF source must be modified in a few places.<br>
+</p>
+<p>The 'frame/md_calls.m4' must be modified to recognize the HDF modules.<br>
+</p>
+<blockquote>
+  </blockquote>
+<table cellpadding="2" cellspacing="2" border="1" width="90%" align="center">
+  <tbody>
+    <tr>
+      <td valign="top">*** ../WRFV1/frame/md_calls.m4	Mon Dec 10 18:10:43 2001<br>
+--- ./WRFV1-with-hdf/frame/md_calls.m4	Thu May 13 12:18:44 2004<br>
+***************<br>
+*** 70,78 ****<br>
+            CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )<br>
+          ENDIF<br>
+  #endif<br>
+! #ifdef HDF<br>
+!       CASE ( IO_HDF   )<br>
+!         CALL ext_hdf_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, &amp;<br>
+                                ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )<br>
+  #endif<br>
+  #ifdef XXX<br>
+--- 70,99 ----<br>
+            CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )<br>
+          ENDIF<br>
+  #endif<br>
+! #ifdef HDF5<br>
+!       CASE ( IO_HDF5   )<br>
+!         IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN<br>
+!            CALL ext_hdf5_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, &amp;<br>
+!                               ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )<br>
+!         ENDIF <br>
+!         IF ( .NOT. multi_files(io_form) ) THEN<br>
+!           ifelse($1,get,ifelse($3,integer,`CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )'))<br>
+!           ifelse($1,get,ifelse($3,integer,`CALL wrf_dm_bcast_bytes( Data, IWORDSIZE*locCount )'))<br>
+!           ifelse($1,get,ifelse($3,real,   `CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )'))<br>
+!           ifelse($1,get,ifelse($3,real,   `CALL wrf_dm_bcast_bytes( Data, RWORDSIZE*locCount )'))<br>
+!           ifelse($1,get,ifelse($3,logical,`CALL wrf_dm_bcast_bytes( locCount, IWORDSIZE )'))<br>
+!           ifelse($1,get,ifelse($3,logical,`CALL wrf_dm_bcast_bytes( Data, LWORDSIZE*locCount )'))<br>
+!           ifelse($1,get,ifelse($4,char,   `len_of_str = LEN(Data)'))<br>
+!           ifelse($1,get,ifelse($4,char,   `CALL wrf_dm_bcast_bytes( len_of_str, IWORDSIZE )'))<br>
+!           ifelse($1,get,ifelse($4,char,   `CALL wrf_dm_bcast_string( Data, len_of_str )'))<br>
+!           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )<br>
+!         ENDIF<br>
+!        <br>
+! <br>
+! #endif<br>
+! #ifdef PHDF5<br>
+!       CASE ( IO_PHDF5   )<br>
+!            CALL ext_phdf5_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, &amp;<br>
+                                ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )<br>
+  #endif<br>
+  #ifdef XXX<br>
+      <br>
+      </td>
+    </tr>
+  </tbody>
+</table>
+<p><br>
+The 'frame/module_io.F' file must be modified to add code to call the HDF5 modules if selected.<br>
+</p>
+<table cellpadding="2" cellspacing="2" border="1" width="90%" align="center">
+  <tbody>
+    <tr>
+      <td valign="top">*** ../WRFV1/frame/module_io.F	Tue Dec  3 14:10:48 2002<br>
+--- ./WRFV1-with-hdf/frame/module_io.F	Thu May 13 12:18:45 2004<br>
+***************<br>
+*** 34,39 ****<br>
+--- 34,48 ----<br>
+  #ifdef NETCDF<br>
+    CALL ext_ncd_ioinit( SysDepInfo, Status )<br>
+  #endif<br>
++ <br>
++ #ifdef HDF5<br>
++   CALL ext_hdf5_ioinit(SysDepInfo, Status)<br>
++ #endif<br>
++ <br>
++ #ifdef PHDF5<br>
++   CALL ext_phdf5_ioinit(SysDepInfo, Status)<br>
++ #endif<br>
++  <br>
+  END SUBROUTINE wrf_ioinit<br>
+  <br>
+  !--- ioexit<br>
+***************<br>
+*** 47,52 ****<br>
+--- 56,70 ----<br>
+  #ifdef NETCDF<br>
+    CALL ext_ncd_ioexit( Status )<br>
+  #endif<br>
++ <br>
++ #ifdef HDF5<br>
++   CALL ext_hdf5_ioexit(Status)<br>
++ #endif<br>
++ <br>
++ #ifdef PHDF5<br>
++   CALL ext_phdf5_ioexit(Status)<br>
++ #endif<br>
++ <br>
+    IF ( use_output_servers() ) CALL ext_quilt_ioexit( Status )<br>
+  END SUBROUTINE<br>
+  <br>
+***************<br>
+*** 134,139 ****<br>
+--- 152,179 ----<br>
+          CALL ext_hdf_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &amp;<br>
+                                              Hndl , Status )<br>
+  #endif<br>
++ #ifdef HDF5<br>
++       CASE ( IO_HDF5   )<br>
++         IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN<br>
++           IF ( multi_files(io_form) ) THEN<br>
++             CALL wrf_get_myproc ( myproc )<br>
++             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )<br>
++           ELSE<br>
++             LocFilename = FileName<br>
++           ENDIF<br>
++           CALL ext_hdf5_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &amp;<br>
++                                               Hndl , Status )<br>
++         ENDIF<br>
++         IF ( .NOT. multi_files(io_form) ) THEN<br>
++           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )<br>
++           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )<br>
++         ENDIF<br>
++ #endif<br>
++ #ifdef PHDF5<br>
++       CASE ( IO_PHDF5   )<br>
++           CALL ext_phdf5_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &amp;<br>
++                                               Hndl , Status )<br>
++ #endif<br>
+  #ifdef XXX<br>
+        CASE ( IO_XXX   )<br>
+          CALL ext_xxx_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &amp;<br>
+***************<br>
+*** 214,219 ****<br>
+--- 254,270 ----<br>
+        CASE ( IO_HDF   )<br>
+          CALL ext_hdf_open_for_write_commit ( Hndl , Status )<br>
+  #endif<br>
++ #ifdef HDF5<br>
++       CASE ( IO_HDF5   )<br>
++           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN<br>
++             CALL ext_hdf5_open_for_write_commit ( Hndl , Status )<br>
++           ENDIF<br>
++           IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )<br>
++ #endif<br>
++ #ifdef PHDF5<br>
++       CASE ( IO_PHDF5   )<br>
++             CALL ext_phdf5_open_for_write_commit ( Hndl , Status )<br>
++ #endif<br>
+  #ifdef XXX<br>
+        CASE ( IO_XXX   )<br>
+          CALL ext_xxx_open_for_write_commit ( Hndl , Status )<br>
+***************<br>
+*** 316,321 ****<br>
+--- 367,388 ----<br>
+        CALL ext_hdf_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &amp;<br>
+                                 Hndl , Status )<br>
+  #endif<br>
++ #ifdef HDF5<br>
++     CASE ( IO_HDF5   )<br>
++       IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN<br>
++         CALL ext_hdf5_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &amp;<br>
++                                      Hndl , Status )<br>
++       ENDIF<br>
++       IF ( .NOT. multi_files(io_form) ) THEN<br>
++         CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )<br>
++         CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )<br>
++       ENDIF<br>
++ #endif<br>
++ #ifdef PHDF5<br>
++     CASE ( IO_PHDF5   )<br>
++         CALL ext_phdf5_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &amp;<br>
++                                      Hndl , Status )<br>
++ #endif<br>
+  #ifdef XXX<br>
+      CASE ( IO_XXX   )<br>
+        CALL ext_xxx_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &amp;<br>
+***************<br>
+*** 420,425 ****<br>
+--- 487,502 ----<br>
+        CASE ( IO_HDF   )<br>
+            CALL ext_hdf_inquire_opened ( Hndl, FileName , FileStatus, Status )<br>
+  #endif<br>
++ #ifdef HDF5<br>
++       CASE ( IO_HDF5   )<br>
++           IF (wrf_dm_on_monitor()) CALL ext_hdf5_inquire_opened ( Hndl, FileName , FileStatus, Status )<br>
++           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )<br>
++           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )<br>
++ #endif<br>
++ #ifdef PHDF5<br>
++       CASE ( IO_PHDF5   )<br>
++           CALL ext_phdf5_inquire_opened ( Hndl, FileName , FileStatus, Status )<br>
++ #endif<br>
+  #ifdef XXX<br>
+        CASE ( IO_XXX   )<br>
+            CALL ext_xxx_inquire_opened ( Hndl, FileName , FileStatus, Status )<br>
+***************<br>
+*** 486,491 ****<br>
+--- 563,578 ----<br>
+          CASE ( IO_HDF   )<br>
+            CALL ext_hdf_inquire_filename ( Hndl, FileName , FileStatus, Status )<br>
+  #endif<br>
++ #ifdef HDF5<br>
++         CASE ( IO_HDF5   )<br>
++           IF (wrf_dm_on_monitor()) CALL ext_hdf5_inquire_filename ( Hndl, FileName , FileStatus, Status )<br>
++           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )<br>
++           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )<br>
++ #endif<br>
++ #ifdef PHDF5<br>
++         CASE ( IO_PHDF5   )<br>
++           CALL ext_phdf5_inquire_filename ( Hndl, FileName , FileStatus, Status )<br>
++ #endif<br>
+  #ifdef XXX<br>
+          CASE ( IO_XXX   )<br>
+            CALL ext_xxx_inquire_filename ( Hndl, FileName , FileStatus, Status )<br>
+***************<br>
+*** 607,612 ****<br>
+--- 694,708 ----<br>
+          CASE ( IO_HDF   )<br>
+            CALL ext_ncd_ioclose( Hndl, Status )<br>
+  #endif<br>
++ #ifdef HDF5<br>
++         CASE ( IO_HDF5   )<br>
++           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_hdf5_ioclose( Hndl, Status )<br>
++           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )<br>
++ #endif<br>
++ #ifdef PHDF5<br>
++         CASE ( IO_PHDF5   )<br>
++           CALL ext_phdf5_ioclose( Hndl, Status )<br>
++ #endif<br>
+  #ifdef XXX<br>
+          CASE ( IO_XXX   )<br>
+            CALL ext_xxx_ioclose( Hndl, Status )<br>
+***************<br>
+*** 675,680 ****<br>
+--- 771,790 ----<br>
+          CASE ( IO_HDF   )<br>
+            CALL ext_hdf_get_next_time( Hndl, DateStr, Status )<br>
+  #endif<br>
++ #ifdef HDF5<br>
++         CASE ( IO_HDF5   )<br>
++           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_hdf5_get_next_time( Hndl, DateStr, Status )<br>
++           IF ( .NOT. multi_files(io_form) ) THEN<br>
++             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )<br>
++             len_of_str = LEN(DateStr)<br>
++             CALL wrf_dm_bcast_bytes( len_of_str, IWORDSIZE )<br>
++             CALL wrf_dm_bcast_string ( DateStr , len_of_str )<br>
++           ENDIF<br>
++ #endif<br>
++ #ifdef PHDF5<br>
++         CASE ( IO_PHDF5   )<br>
++           CALL ext_phdf5_get_next_time( Hndl, DateStr, Status )<br>
++ #endif<br>
+  #ifdef XXX<br>
+          CASE ( IO_XXX   )<br>
+            CALL ext_xxx_get_next_time( Hndl, DateStr, Status )<br>
+***************<br>
+*** 742,747 ****<br>
+--- 852,866 ----<br>
+          CASE ( IO_HDF   )<br>
+            CALL ext_hdf_set_time( Hndl, DateStr, Status )<br>
+  #endif<br>
++ #ifdef HDF5<br>
++         CASE ( IO_HDF5   )<br>
++           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_hdf5_set_time( Hndl, DateStr, Status )<br>
++           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )<br>
++ #endif<br>
++ #ifdef PHDF5<br>
++         CASE ( IO_PHDF5   )<br>
++           CALL ext_phdf5_set_time( Hndl, DateStr, Status )<br>
++ #endif<br>
+  #ifdef XXX<br>
+          CASE ( IO_XXX   )<br>
+            CALL ext_xxx_set_time( Hndl, DateStr, Status )<br>
+***************<br>
+*** 875,880 ****<br>
+--- 994,1002 ----<br>
+  #ifdef HDF<br>
+    EXTERNAL ext_hdf_read_field<br>
+  #endif<br>
++ #ifdef HDF5<br>
++   EXTERNAL ext_hdf5_read_field<br>
++ #endif<br>
+  #ifdef XXX<br>
+    EXTERNAL ext_xxx_read_field<br>
+  #endif<br>
+***************<br>
+*** 911,916 ****<br>
+--- 1033,1058 ----<br>
+                                       PatchStart , PatchEnd ,                                      &amp;<br>
+                                       Status )<br>
+  #endif<br>
++ #ifdef HDF5<br>
++         CASE ( IO_HDF5 )<br>
++           CALL call_pkg_and_dist   ( ext_hdf5_read_field, multi_files(io_form),                  &amp;<br>
++                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &amp;<br>
++                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &amp;<br>
++                                      DomainStart , DomainEnd ,                                    &amp;<br>
++                                      MemoryStart , MemoryEnd ,                                    &amp;<br>
++                                      PatchStart , PatchEnd ,                                      &amp;<br>
++                                      Status )<br>
++ #endif<br>
++ #ifdef PHDF5                                                                                                              <br>
++        CASE (IO_PHDF5)<br>
++           CALL  ext_phdf5_read_field  (                 &amp;<br>
++                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &amp;<br>
++                                      DomainDesc ,  MemoryOrder , Stagger , DimNames ,              &amp;<br>
++                                      DomainStart , DomainEnd ,                                    &amp;<br>
++                                      MemoryStart , MemoryEnd ,                                    &amp;<br>
++                                      PatchStart , PatchEnd ,                                      &amp;<br>
++                                      Status )<br>
++ #endif<br>
+  #ifdef XXX<br>
+          CASE ( IO_XXX )<br>
+            CALL call_pkg_and_dist   ( ext_xxx_read_field, multi_files(io_form),                  &amp;<br>
+***************<br>
+*** 994,999 ****<br>
+--- 1136,1144 ----<br>
+  #ifdef HDF<br>
+    EXTERNAL ext_hdf_write_field<br>
+  #endif<br>
++ #ifdef HDF5<br>
++   EXTERNAL ext_hdf5_write_field<br>
++ #endif<br>
+  #ifdef XXX<br>
+    EXTERNAL ext_xxx_write_field<br>
+  #endif<br>
+***************<br>
+*** 1028,1033 ****<br>
+--- 1173,1198 ----<br>
+                                       PatchStart , PatchEnd ,                                      &amp;<br>
+                                       Status )<br>
+  #endif<br>
++ #ifdef HDF5<br>
++         CASE ( IO_HDF5 )<br>
++           CALL collect_fld_and_call_pkg ( ext_hdf5_write_field, multi_files(io_form),                  &amp;<br>
++                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &amp;<br>
++                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &amp;<br>
++                                      DomainStart , DomainEnd ,                                    &amp;<br>
++                                      MemoryStart , MemoryEnd ,                                    &amp;<br>
++                                      PatchStart , PatchEnd ,                                      &amp;<br>
++                                      Status )<br>
++ #endif<br>
++ #ifdef PHDF5<br>
++         CASE ( IO_PHDF5 )<br>
++           CALL ext_phdf5_write_field (                  &amp;<br>
++                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &amp;<br>
++                                      DomainDesc , MemoryOrder , Stagger , DimNames ,              &amp;<br>
++                                      DomainStart , DomainEnd ,                                    &amp;<br>
++                                      MemoryStart , MemoryEnd ,                                    &amp;<br>
++                                      PatchStart , PatchEnd ,                                      &amp;<br>
++                                      Status )<br>
++ #endif<br>
+  #ifdef XXX<br>
+          CASE ( IO_XXX )<br>
+            CALL collect_fld_and_call_pkg ( ext_xxx_write_field, multi_files(io_form),                  &amp;<br>
+***************<br>
+*** 1115,1120 ****<br>
+--- 1280,1293 ----<br>
+                                        DomainStart , DomainEnd ,                &amp;<br>
+                                        Status )<br>
+  #endif<br>
++ #ifdef HDF5<br>
++         CASE ( IO_HDF5 )<br>
++          write(*,*) "NOT IMPLEMENT at HDF5" <br>
++          ! CALL ext_hdf5_get_var_info ( Hndl , VarName , NDim ,            &amp;<br>
++          !                             MemoryOrder , Stagger ,                  &amp;<br>
++          !                             DomainStart , DomainEnd ,                &amp;<br>
++          !                             Status )<br>
++ #endif<br>
+  #ifdef XXX<br>
+          CASE ( IO_XXX )<br>
+            CALL ext_xxx_get_var_info ( Hndl , VarName , NDim ,            &amp;<br>
+      <br>
+      </td>
+    </tr>
+  </tbody>
+</table>
+<p><br>
+The 'share/module_io.F' file must be modified to recognize the HDF5 options for IO.<br>
+</p>
+<table cellpadding="2" cellspacing="2" border="1" width="90%" align="center">
+  <tbody>
+    <tr>
+      <td valign="top">*** ../WRFV1/share/module_io_wrf.F	Tue Feb 18 14:26:22 2003<br>
+--- ./WRFV1-with-hdf/share/module_io_wrf.F	Thu May 13 12:18:46 2004<br>
+***************<br>
+*** 1032,1037 ****<br>
+--- 1032,1079 ----<br>
+  		      ,Status )<br>
+      ENDIF<br>
+  <br>
++     IF (io_form .EQ. IO_HDF5) THEN<br>
++       CALL wrf_put_var_ti_char( &amp;<br>
++                        DataHandle                 &amp;  ! DataHandle<br>
++ 		      ,"description"              &amp;  ! Element<br>
++                       ,Var                        &amp;  ! Data Name<br>
++                       ,Desc                       &amp;  ! Data<br>
++ 		      ,Status )<br>
++       CALL wrf_put_var_ti_char( &amp;<br>
++                        DataHandle                 &amp;  ! DataHandle<br>
++ 		      ,"units"                    &amp;  ! Element<br>
++                       ,Var                        &amp;  ! Data Name<br>
++                       ,Units                      &amp;  ! Data<br>
++ 		      ,Status )<br>
++       CALL wrf_put_var_ti_char( &amp;<br>
++                        DataHandle                 &amp;  ! DataHandle<br>
++ 		      ,"stagger"                  &amp;  ! Element<br>
++                       ,Var                        &amp;  ! Data Name<br>
++                       ,Stagger                    &amp;  ! Data<br>
+4/ Build WRF<br>
+      <br>
++ 		      ,Status )<br>
++     ENDIF<br>
++ <br>
++     IF (io_form .EQ. IO_PHDF5) THEN<br>
++       CALL wrf_put_var_ti_char( &amp;<br>
++                        DataHandle                 &amp;  ! DataHandle<br>
++ 		      ,"description"              &amp;  ! Element<br>
++                       ,Var                        &amp;  ! Data Name<br>
++                       ,Desc                       &amp;  ! Data<br>
++ 		      ,Status )<br>
++       CALL wrf_put_var_ti_char( &amp;<br>
++                        DataHandle                 &amp;  ! DataHandle<br>
++ 		      ,"units"                    &amp;  ! Element<br>
++                       ,Var                        &amp;  ! Data Name<br>
++                       ,Units                      &amp;  ! Data<br>
++ 		      ,Status )<br>
++       CALL wrf_put_var_ti_char( &amp;<br>
++                        DataHandle                 &amp;  ! DataHandle<br>
++ 		      ,"stagger"                  &amp;  ! Element<br>
++                       ,Var                        &amp;  ! Data Name<br>
++                       ,Stagger                    &amp;  ! Data<br>
++ 		      ,Status )<br>
++     ENDIF<br>
++ <br>
+      IF ( wrf_at_debug_level(300) ) THEN<br>
+        WRITE(wrf_err_message,*) debug_message,' Status = ',Status<br>
+        CALL wrf_message ( TRIM(wrf_err_message) )<br>
+      <br>
+      </td>
+    </tr>
+  </tbody>
+</table>
+<p>The 'Makefile' for the 'external' directory must be updated to build the new IO modules.<br>
+</p>
+<table cellpadding="2" cellspacing="2" border="1" width="90%" align="center">
+  <tbody>
+    <tr>
+      <td valign="top">*** ../WRFV1/external/Makefile	Mon Dec 10 18:07:21 2001<br>
+--- ./WRFV1-with-hdf/external/Makefile	Thu May 13 12:18:38 2004<br>
+***************<br>
+*** 3,12 ****<br>
+  	( cd RSL/RSL ; make clean )<br>
+  	( cd io_netcdf ; make clean )<br>
+  	( cd io_int ; make clean )<br>
+  <br>
+  superclean : clean<br>
+  	/bin/rm -f RSL/RSL/librsl.a RSL/RSL/rsl.inc<br>
+  	/bin/rm -f io_netcdf/libwrfio_nf.a io_netcdf/diffwrf io_netcdf/*.o io_netcdf/*.f \<br>
+                     io_int/libwrfio_int.a io_int/diffwrf        */*.mod<br>
+! <br>
+! <br>
+--- 3,14 ----<br>
+  	( cd RSL/RSL ; make clean )<br>
+  	( cd io_netcdf ; make clean )<br>
+  	( cd io_int ; make clean )<br>
++ 	(cd io_hdf5; make clean)<br>
++ 	(cd io_phdf5; make clean)<br>
+  <br>
+  superclean : clean<br>
+  	/bin/rm -f RSL/RSL/librsl.a RSL/RSL/rsl.inc<br>
+  	/bin/rm -f io_netcdf/libwrfio_nf.a io_netcdf/diffwrf io_netcdf/*.o io_netcdf/*.f \<br>
+                     io_int/libwrfio_int.a io_int/diffwrf        */*.mod<br>
+! 	/bin/rm -f io_phdf5/*.a io_phdf5/*.o  *.f *.mod<br>
+! 	/bin/rm -f io_hdf5/*.a io_hdf5/*.o *.f *.mod<br>
+      <br>
+      <br>
+      </td>
+    </tr>
+  </tbody>
+</table>
+
+
+    <p><b><small>
+    <font size="4"><small></small></font></small></b><br>
+</p>
+<p><i>Last Modified: 17 May 2004 </i></p>
+<blockquote>
+  <blockquote>
+    
+    <p> </p>
+  </blockquote>
+
+</blockquote>
+
+
+<br>
+<br>
+</body></html>
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/Makefile	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/README.phdf5
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/README.phdf5	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/README.phdf5	(revision 17)
@@ -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                            
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/wrf-phdf5.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/wrf-phdf5.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/wrf-phdf5.F90	(revision 17)
@@ -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_hdf5('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_hdf5('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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/wrf-phdf5attr.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/wrf-phdf5attr.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/wrf-phdf5attr.F90	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/wrf-phdf5attr.F90btg
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/wrf-phdf5attr.F90btg	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/wrf-phdf5attr.F90btg	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/wrf-phdf5support.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/wrf-phdf5support.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_phdf5/wrf-phdf5support.F90	(revision 17)
@@ -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_hdf5(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_hdf5
+
+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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/README
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/README	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/README	(revision 17)
@@ -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.
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/WRFIO.doc
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/WRFIO.doc	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/WRFIO.doc	(revision 17)
@@ -0,0 +1,6 @@
+Documentation for WRF I/O is at
+
+   http://www.wrf-model.org/documentation_main.html
+ 
+the first link under REFERENCES.
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_get_dom_ti.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_get_dom_ti.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_get_dom_ti.code	(revision 17)
@@ -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_pnc
+  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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_get_var_td.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_get_var_td.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_get_var_td.code	(revision 17)
@@ -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_pnc
+  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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_get_var_ti.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_get_var_ti.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_get_var_ti.code	(revision 17)
@@ -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_pnc
+  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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_put_dom_ti.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_put_dom_ti.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_put_dom_ti.code	(revision 17)
@@ -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_pnc
+  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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_put_var_td.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_put_var_td.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_put_var_td.code	(revision 17)
@@ -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_pnc
+  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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_put_var_ti.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_put_var_ti.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/ext_pnc_put_var_ti.code	(revision 17)
@@ -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_pnc
+  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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/field_routines.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/field_routines.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/field_routines.F90	(revision 17)
@@ -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
+!*
+!*----------------------------------------------------------------------------
+subroutine ext_pnc_RealFieldIO(Coll,IO,NCID,VarID,VStart,VCount,Data,Status)
+  use wrf_data_pnc
+  use ext_pnc_support_routines
+  implicit none
+  include 'wrf_status_codes.h'
+#  include "pnetcdf.inc"
+  logical                     ,intent(in)    :: Coll
+  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
+    if(Coll)then
+      stat = NFMPI_PUT_VARA_REAL_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
+    else
+      stat = NFMPI_PUT_VARA_REAL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
+    end if
+  else
+    if(Coll)then
+      stat = NFMPI_GET_VARA_REAL_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
+   else
+      stat = NFMPI_GET_VARA_REAL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
+   end if
+  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(Coll,IO,NCID,VarID,VStart,VCount,Data,Status)
+  use wrf_data_pnc
+  use ext_pnc_support_routines
+  implicit none
+  include 'wrf_status_codes.h'
+#  include "pnetcdf.inc"
+  logical                     ,intent(in)    :: Coll
+  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
+    if(Coll)then
+      stat = NFMPI_PUT_VARA_DOUBLE_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
+   else
+      stat = NFMPI_PUT_VARA_DOUBLE(NCID,VarID,VStart_mpi,VCount_mpi,Data)
+   endif
+  else
+    if(Coll)then
+      stat = NFMPI_GET_VARA_DOUBLE_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
+   else
+      stat = NFMPI_GET_VARA_DOUBLE(NCID,VarID,VStart_mpi,VCount_mpi,Data)
+   endif
+  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(Coll,IO,NCID,VarID,VStart,VCount,Data,Status)
+  use wrf_data_pnc
+  use ext_pnc_support_routines
+  implicit none
+  include 'wrf_status_codes.h'
+#  include "pnetcdf.inc"
+  logical                     ,intent(in)    :: Coll
+  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
+    if(Coll)then
+      stat = NFMPI_PUT_VARA_INT_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
+    else
+      stat = NFMPI_PUT_VARA_INT(NCID,VarID,VStart_mpi,VCount_mpi,Data)
+    endif
+  else
+    if(Coll)then
+      stat = NFMPI_GET_VARA_INT_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Data)
+   else
+      stat = NFMPI_GET_VARA_INT(NCID,VarID,VStart_mpi,VCount_mpi,Data)
+   end if
+  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(Coll,IO,NCID,VarID,VStart,VCount,Data,Status)
+  use wrf_data_pnc
+  use ext_pnc_support_routines
+  implicit none
+  include 'wrf_status_codes.h'
+#  include "pnetcdf.inc"
+  logical                                         ,intent(in)    :: Coll
+  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
+    if(Coll)then
+      stat = NFMPI_PUT_VARA_INT_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Buffer)
+   else
+      stat = NFMPI_PUT_VARA_INT(NCID,VarID,VStart_mpi,VCount_mpi,Buffer)
+   end if
+  else
+    if(Coll)then
+      stat = NFMPI_GET_VARA_INT_ALL(NCID,VarID,VStart_mpi,VCount_mpi,Buffer)
+    else
+      stat = NFMPI_GET_VARA_INT(NCID,VarID,VStart_mpi,VCount_mpi,Buffer)
+    end if
+    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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/makefile	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/module_wrfsi_static.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/module_wrfsi_static.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/module_wrfsi_static.F90	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/testWRFRead.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/testWRFRead.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/testWRFRead.F90	(revision 17)
@@ -0,0 +1,138 @@
+program testread_john
+  use wrf_data_pnc
+  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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/testWRFWrite.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/testWRFWrite.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/testWRFWrite.F90	(revision 17)
@@ -0,0 +1,184 @@
+program testwrite_john
+  use wrf_data_pnc
+  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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/transpose.code
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/transpose.code	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/transpose.code	(revision 17)
@@ -0,0 +1,37 @@
+  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
Index: branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/wrf_io.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/wrf_io.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/io_pnetcdf/wrf_io.F90	(revision 17)
@@ -0,0 +1,3563 @@
+!/*------------------------------------------------------------------------------
+!*  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_pnc
+
+  integer                , parameter      :: FATAL            = 0
+  integer                , parameter      :: WARN             = 0
+  integer                , parameter      :: WrfDataHandleMax = 99
+  integer                , parameter      :: MaxDims          = 2000 ! = NF_MAX_VARS
+  integer                , parameter      :: MaxVars          = 3000
+  integer                , parameter      :: MaxTimes         = 9000000
+  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
+! Whether pnetcdf file is in collective (.true.) or independent mode
+! Collective mode is the default.
+    logical                               :: Collective
+  end type wrf_data_handle
+  type(wrf_data_handle),target            :: WrfDataHandles(WrfDataHandleMax)
+end module wrf_data_pnc
+
+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_pnc
+  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.
+  DH%Collective = .TRUE.
+  Status = WRF_NO_ERR
+end subroutine allocHandle
+
+subroutine deallocHandle(DataHandle, Status)
+  use wrf_data_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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
+
+logical function ZeroLengthHorzDim(MemoryOrder,Vector,Status)
+  use wrf_data_pnc
+  include 'wrf_status_codes.h'
+  character*(*)              ,intent(in)    :: MemoryOrder
+  integer,dimension(*)       ,intent(in)    :: Vector
+  integer                    ,intent(out)   :: Status
+  integer                                   :: NDim
+  integer,dimension(NVarDims)               :: temp
+  character*3                               :: MemOrd
+  logical zero_length
+
+  call GetDim(MemoryOrder,NDim,Status)
+  temp(1:NDim) = Vector(1:NDim)
+  call LowerCase(MemoryOrder,MemOrd)
+  zero_length = .false.
+  select case (MemOrd)
+    case ('xsz','xez','ysz','yez','xs','xe','ys','ye','z','c')
+      continue
+    case ('0')
+      continue  ! NDim=0 for scalars.  TBH:  20060502
+    case ('xzy','yzx')
+      zero_length = temp(1) .lt. 1 .or. temp(3) .lt. 1
+    case ('xy','yx','xyz','yxz')
+      zero_length = temp(1) .lt. 1 .or. temp(2) .lt. 1
+    case ('zxy','zyx')
+      zero_length = temp(2) .lt. 1 .or. temp(3) .lt. 1
+    case default
+      Status = WRF_WARN_BAD_MEMORYORDER
+      ZeroLengthHorzDim = .true.
+      return
+  end select
+  Status = WRF_NO_ERR
+  ZeroLengthHorzDim = zero_length
+  return
+end function ZeroLengthHorzDim
+
+subroutine ExtOrder(MemoryOrder,Vector,Status)
+  use wrf_data_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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    (WrfDataHandles(DataHandle)%Collective, &
+                                   IO,NCID,VarID,VStart,VCount,XField,Status)
+    case (WRF_DOUBLE)
+      call ext_pnc_DoubleFieldIO  (WrfDataHandles(DataHandle)%Collective, &
+                                   IO,NCID,VarID,VStart,VCount,XField,Status)
+    case (WRF_INTEGER)
+      call ext_pnc_IntFieldIO     (WrfDataHandles(DataHandle)%Collective, &
+                                   IO,NCID,VarID,VStart,VCount,XField,Status)
+    case (WRF_LOGICAL)
+      call ext_pnc_LogicalFieldIO (WrfDataHandles(DataHandle)%Collective, &
+                                   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_pnc
+    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_pnc
+    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_pnc
+    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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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)
+  integer                           :: info, ierr   ! added for Blue Gene (see NF_CREAT below)
+  character*128                     :: idstr,ntasks_x_str,loccomm_str
+  integer                           :: gridid
+  integer local_communicator_x, ntasks_x
+
+  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
+
+#ifndef BLUEGENE
+  call mpi_info_create( info, ierr )
+# ifdef LUSTRE_FS
+  CALL mpi_info_set(info,"romio_ds_write","disable", ierr) ; write(0,*)'mpi_info_set write returns ',ierr
+  CALL mpi_info_set(info,"romio_ds_read","disable", ierr) ; write(0,*)'mpi_info_set read returns ',ierr
+# endif
+  stat = NFMPI_CREATE(Comm, FileName, IOR(NF_CLOBBER, NF_64BIT_OFFSET), info, DH%NCID)
+  call mpi_info_free( info, ierr)
+#else
+!!!!!!!!!!!!!!!
+! rob latham suggested hint
+
+  call mpi_info_create( info, ierr )
+!  call mpi_info_set(info,'cd_buffer_size','4194304',ierr)
+  call mpi_info_set(info,'cd_buffer_size','8388608',ierr)
+  stat = NFMPI_CREATE(Comm, FileName, IOR(NF_CLOBBER, NF_64BIT_OFFSET), info, DH%NCID)
+  call mpi_info_free( info, ierr)
+!
+!!!!!!!!!!!!!!! 
+#endif
+
+  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
+  ! JPE added for performance
+  stat = NFMPI_SET_FILL(DH%NCID, NF_NOFILL, i)
+
+  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_pnc
+  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_pnc
+  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 (',stat,') from NFMPI_ENDDEF 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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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, Length_native
+  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                                      :: p1,p2,q1,q2,r1,r2
+  integer                                      :: l1,l2,m1,m2,n1,n2
+  integer                                      :: XType
+  integer                                      :: di
+  character (80)                               :: NullName
+  logical                                      :: NotFound
+  logical                                      :: quilting
+  ! Local, possibly adjusted, copies of MemoryStart and MemoryEnd
+  integer       ,dimension(NVarDims)           :: lMemoryStart, lMemoryEnd
+  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_native(1:NDim) = Length(1:NDim)
+  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)
+
+  ! Magic number to identify call from IO server when doing quilting
+  quilting = (MemoryStart(1) == -998899 .AND. MemoryEnd(1) == -998899)
+  IF(quilting)THEN
+     lMemoryStart(1:NDim) = 1
+     lMemoryEnd(1:NDim) = Length(1:NDim)
+  ELSE
+     lMemoryStart(1:NDim) = MemoryStart(1:NDim)
+     lMemoryEnd(1:NDim) = MemoryEnd(1:NDim)
+  END IF
+
+  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 (',TRIM(VarName),') 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 (',i,') in (',TRIM(VarName),') ',__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)),' REDEFINED  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) < lMemoryStart(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,lMemoryStart,lMemoryEnd,l1,l2,m1,m2,n1,n2)
+    call GetIndices(NDim,StoredStart,Length   ,x1,x2,y1,y2,z1,z2)
+    call GetIndices(NDim,StoredStart,Length_native   ,p1,p2,q1,q2,r1,r2)
+    call GetIndices(NDim,PatchStart, PatchEnd ,i1,i2,j1,j2,k1,k2)
+    di=1
+    if(FieldType == WRF_DOUBLE) di=2
+    allocate(XField(di,x1:x2,y1:y2,z1:z2), STAT=stat)
+    if(stat/= 0) then
+      Status = WRF_ERR_FATAL_ALLOCATION_ERROR
+      write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__
+      call wrf_debug ( FATAL , TRIM(msg))
+      return
+    endif
+
+#if 0
+    WRITE(msg,*) 'ARPDBG: MemoryStart = ',lMemoryStart(1:NDim)
+    CALL wrf_message(msg)
+    WRITE(msg,*) 'ARPDBG:  lMemoryEnd = ',lMemoryEnd(1:NDim)
+    CALL wrf_message(msg)
+    WRITE(msg,*) 'ARPDBG:      Length = ',Length(1:NDim)
+    CALL wrf_message(msg)
+#endif
+
+    IF(quilting)THEN
+       ! Don't pass in PatchStart and PatchEnd here since we want to
+       ! take transpose of whole patch of data which has been sent to
+       ! the IO server and passed down to us.
+       ! JM: the field and patch dimensions must be reordered or xpose is a noop
+       call Transpose('write',MemoryOrder,di, Field,p1,p2,q1,q2,r1,r2 &
+                                            ,XField,x1,x2,y1,y2,z1,z2 &
+                                                   ,p1,p2,q1,q2,r1,r2 )
+    ELSE
+       call Transpose('write',MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 &
+                                            ,XField,x1,x2,y1,y2,z1,z2 &
+                                                   ,i1,i2,j1,j2,k1,k2 )
+    END IF
+
+    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_pnc
+  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
+      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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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_pnc
+  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
+
+
+!ARPaddition...
+subroutine ext_pnc_end_independent_mode(DataHandle, Status)
+  use wrf_data_pnc
+  use ext_pnc_support_routines
+  include 'wrf_status_codes.h'
+#  include "pnetcdf.inc"
+  integer               ,intent(in)     :: DataHandle
+  integer               ,intent(out)    :: Status
+  type(wrf_data_handle) ,pointer        :: DH
+  integer                               :: stat
+
+  DH => WrfDataHandles(DataHandle)
+  DH%Collective = .TRUE.
+  stat = NFMPI_END_INDEP_DATA(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))
+  endif
+
+  return
+end subroutine ext_pnc_end_independent_mode
+
+subroutine ext_pnc_start_independent_mode(DataHandle, Status)
+  use wrf_data_pnc
+  use ext_pnc_support_routines
+  include 'wrf_status_codes.h'
+#  include "pnetcdf.inc"
+  integer               ,intent(in)     :: DataHandle
+  integer               ,intent(out)    :: Status
+  type(wrf_data_handle) ,pointer        :: DH
+  integer                               :: stat
+
+  DH => WrfDataHandles(DataHandle)
+  DH%Collective = .FALSE.
+  stat = NFMPI_BEGIN_INDEP_DATA(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))
+  endif
+
+  return
+
+end subroutine ext_pnc_start_independent_mode
+!ARPaddition end
Index: branches/LMDZ_WRFmeas/WRFV3/external/ioapi_share/makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/ioapi_share/makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/ioapi_share/makefile	(revision 17)
@@ -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 
+
Index: branches/LMDZ_WRFmeas/WRFV3/external/ioapi_share/wrf_io_flags.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/ioapi_share/wrf_io_flags.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/ioapi_share/wrf_io_flags.h	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/external/ioapi_share/wrf_status_codes.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/external/ioapi_share/wrf_status_codes.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/external/ioapi_share/wrf_status_codes.h	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/Makefile	(revision 17)
@@ -0,0 +1,301 @@
+#
+
+LN      =       ln -sf
+MAKE    =       make -i -r
+RM      =       rm -f
+
+
+
+MODULES =       module_driver_constants.o  \
+                module_domain_type.o       \
+                module_streams.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_comm_dm.o           \
+                module_comm_dm_0.o         \
+                module_comm_dm_1.o         \
+                module_comm_dm_2.o         \
+                module_comm_dm_3.o         \
+                module_comm_dm_4.o         \
+                module_comm_nesting_dm.o   \
+                module_dm.o                \
+                module_quilt_outbuf_ops.o  \
+                module_io_quilt.o
+ALOBJS =\
+                module_alloc_space_0.o       \
+                module_alloc_space_1.o       \
+                module_alloc_space_2.o       \
+                module_alloc_space_3.o       \
+                module_alloc_space_4.o       \
+                module_alloc_space_5.o       \
+                module_alloc_space_6.o       \
+                module_alloc_space_7.o       \
+                module_alloc_space_8.o       \
+                module_alloc_space_9.o
+
+NLOBJS =\
+                nl_get_0_routines.o        \
+                nl_get_1_routines.o        \
+                nl_get_2_routines.o        \
+                nl_get_3_routines.o        \
+                nl_get_4_routines.o        \
+                nl_get_5_routines.o        \
+                nl_get_6_routines.o        \
+                nl_get_7_routines.o        \
+                nl_set_0_routines.o        \
+                nl_set_1_routines.o        \
+                nl_set_2_routines.o        \
+                nl_set_3_routines.o        \
+                nl_set_4_routines.o        \
+                nl_set_5_routines.o        \
+                nl_set_6_routines.o        \
+                nl_set_7_routines.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) $(NLOBJS) $(ALOBJS)
+		$(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(OBJS) $(NLOBJS) $(ALOBJS)
+		$(RANLIB) ../main/$(LIBWRFLIB)
+
+nl_set_0_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=0 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx0.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx0.f90
+	$(RM) xx0.f90
+
+nl_set_1_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=1 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx1.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx1.f90
+	$(RM) xx1.f90
+
+nl_set_2_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=2 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx2.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx2.f90
+	$(RM) xx2.f90
+
+nl_set_3_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=3 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx3.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx3.f90
+	$(RM) xx3.f90
+
+nl_set_4_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=4 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx4.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx4.f90
+	$(RM) xx4.f90
+
+nl_set_5_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=5 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx5.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx5.f90
+	$(RM) xx5.f90
+
+nl_set_6_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=6 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx6.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx6.f90
+	$(RM) xx6.f90
+
+nl_set_7_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=7 -I../inc -DNL_set_ROUTINES nl_access_routines.F > xx7.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) xx7.f90
+	$(RM) xx7.f90
+
+nl_get_0_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=0 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy0.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy0.f90
+	$(RM) yy0.f90
+
+nl_get_1_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=1 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy1.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy1.f90
+	$(RM) yy1.f90
+
+nl_get_2_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=2 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy2.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy2.f90
+	$(RM) yy2.f90
+
+nl_get_3_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=3 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy3.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy3.f90
+	$(RM) yy3.f90
+
+nl_get_4_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=4 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy4.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy4.f90
+	$(RM) yy4.f90
+
+nl_get_5_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=5 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy5.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy5.f90
+	$(RM) yy5.f90
+
+nl_get_6_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=6 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy6.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy6.f90
+	$(RM) yy6.f90
+
+nl_get_7_routines.o : nl_access_routines.F module_configure.o
+	$(CPP) -DNNN=7 -I../inc -DNL_get_ROUTINES nl_access_routines.F > yy7.f90
+	$(FC) -o $@ -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS_NO_G) $(MODULE_DIRS) $(FCSUFFIX) yy7.f90
+	$(RM) yy7.f90
+
+wrf_num_bytes_between.o :
+	$(CC) -c $(CFLAGS) wrf_num_bytes_between.c
+
+pack_utils.o :
+	$(CC) -c $(CFLAGS) -DIWORDSIZE=$(IWORDSIZE) pack_utils.c
+
+module_internal_header_util.o :
+	$(CPP) $(CPPFLAGS) -I../inc module_internal_header_util.F > module_internal_header_util.f90
+	$(SFC) -c $(PROMOTION) $(FCSUFFIX) $(FCDEBUG) $(FCBASEOPTS) module_internal_header_util.f90
+
+clean:
+	@ echo 'use the clean script'
+
+module_state_description.F : ../Registry/$(REGISTRY)
+		  ( cd .. ; tools/registry $(ARCHFLAGS) $(ENVCOMPDEFS) -DNEW_BDYS Registry/$(REGISTRY) ) ; 
+
+md_calls.inc : md_calls.m4
+	if [ "$(M4)" = NA ] ; then \
+	  /bin/cp ../arch/md_calls.inc . ; \
+	else \
+	  $(M4) md_calls.m4 > md_calls.inc ; \
+	fi
+
+# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES)
+
+
+module_configure.o: \
+		../dyn_em/namelist_remappings_em.h \
+		module_domain_type.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_comm_nesting_dm.o \
+		module_configure.o module_comm_dm.o
+
+module_comm_dm.o: module_comm_dm_0.o module_comm_dm_1.o module_comm_dm_2.o module_comm_dm_3.o module_comm_dm_4.o
+
+module_comm_dm_0.o: module_domain.o module_configure.o
+module_comm_dm_1.o: module_domain.o module_configure.o
+module_comm_dm_2.o: module_domain.o module_configure.o
+module_comm_dm_3.o: module_domain.o module_configure.o
+module_comm_dm_4.o: module_domain.o module_configure.o
+
+module_comm_nesting_dm.o: \
+		module_domain.o \
+		module_configure.o
+
+module_dm_stubs.F: module_domain.o
+
+module_domain.o: module_domain_type.o \
+                 module_alloc_space_0.o \
+                 module_alloc_space_1.o \
+                 module_alloc_space_2.o \
+                 module_alloc_space_3.o \
+                 module_alloc_space_4.o \
+                 module_alloc_space_5.o \
+                 module_alloc_space_6.o \
+                 module_alloc_space_7.o \
+                 module_alloc_space_8.o \
+                 module_alloc_space_9.o \
+                module_driver_constants.o \
+		module_configure.o \
+		module_machine.o  \
+		module_state_description.o \
+                module_wrf_error.o \
+		$(ESMF_MOD_DEPENDENCE)
+
+module_domain_type.o : module_driver_constants.o module_streams.o $(ESMF_MOD_DEPENDENCE)
+
+module_alloc_space_0.o : module_domain_type.o module_configure.o
+module_alloc_space_1.o : module_domain_type.o module_configure.o
+module_alloc_space_2.o : module_domain_type.o module_configure.o
+module_alloc_space_3.o : module_domain_type.o module_configure.o
+module_alloc_space_4.o : module_domain_type.o module_configure.o
+module_alloc_space_5.o : module_domain_type.o module_configure.o
+module_alloc_space_6.o : module_domain_type.o module_configure.o
+module_alloc_space_7.o : module_domain_type.o module_configure.o
+module_alloc_space_8.o : module_domain_type.o module_configure.o
+module_alloc_space_9.o : module_domain_type.o module_configure.o
+
+module_streams.o : module_state_description.o 
+
+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_dm.o \
+		module_state_description.o \
+		module_configure.o  \
+                module_streams.o \
+		module_driver_constants.o 
+
+module_io_quilt.o: module_state_description.o \
+                module_dm.o \
+                module_configure.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_timing.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
Index: branches/LMDZ_WRFmeas/WRFV3/frame/collect_on_comm.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/collect_on_comm.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/collect_on_comm.c	(revision 17)
@@ -0,0 +1,244 @@
+#ifndef MS_SUA
+# include <stdio.h>
+# include <stdlib.h>
+#endif
+#if defined( DM_PARALLEL ) && ! defined( STUBMPI )
+# include <mpi.h>
+#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
+
+  
+int col_on_comm ( int *, int *, void *, int *, void *, int *, int);
+int dst_on_comm ( int *, int *, void *, int *, void *, int *, int);
+
+void 
+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*/
+void
+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 ) ;
+}
+
+int
+col_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 *recvcounts ;
+  int *displace ;
+  int noutbuf_loc ;
+  int root_task ;
+  MPI_Comm *comm, dummy_comm ;
+  int ierr ;
+
+  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 */
+  ierr = MPI_Gather( ninbuf , 1 , MPI_INT , recvcounts , 1 , MPI_INT , root_task , *comm ) ;
+#ifndef MS_SUA
+  if ( ierr != 0 ) fprintf(stderr,"%s %d MPI_Gather returns %d\n",__FILE__,__LINE__,ierr ) ;
+#endif
+
+  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 )
+    {
+#ifndef MS_SUA
+      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") ;
+#endif
+      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 ;
+    }
+  }
+
+  ierr = MPI_Gatherv( inbuf  , *ninbuf * *typesize  , MPI_CHAR ,
+               outbuf , recvcounts , displace, MPI_CHAR ,
+               root_task , *comm ) ;
+#ifndef MS_SUA
+  if ( ierr != 0 ) fprintf(stderr,"%s %d MPI_Gatherv returns %d\n",__FILE__,__LINE__,ierr ) ;
+#endif
+
+  free(recvcounts) ;
+  free(displace) ;
+#endif
+  return(0) ;
+}
+
+int
+dst_on_comm ( int * Fcomm, int * typesize ,
+              void * inbuf, int *ninbuf , void * outbuf, int * noutbuf, int sw ) ;
+
+void
+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 ) ;
+}
+
+void
+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 ) ;
+}
+
+int
+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 _WIN32
+#ifndef MACOS
+#  include <malloc.h>
+#  include <sys/resource.h>
+#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 <unistd.h>
+#include <sys/times.h>
+/*  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 ) {
+#ifndef _WIN32
+     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) ;
+#endif
+   }
+   minf = mallinfo() ;
+#ifndef _WIN32
+   fprintf(stderr,"a %ld usm %ld fsm %ld uord %ld ford %ld hblkhd %d\n",minf.arena,minf.usmblks,minf.fsmblks,minf.uordblks,minf.fordblks,minf.hblkhd) ;
+#endif
+# if 0
+   fprintf(stderr," outy %d  nouty %d  maxstug %d maxouty %d \n", outy, nouty, maxstug, maxouty ) ;
+# endif
+#endif
+}
+#endif
+#endif
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/libmassv.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/libmassv.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/libmassv.F	(revision 17)
@@ -0,0 +1,390 @@
+! 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.e0/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.e0/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
+#if defined (G95)
+! no reason why g95 should fail - oh well, we don't use this routine anyways
+      y(j)=asin( sqrt(1-x(j)*x(j)) )
+#else
+      y(j)=acos(x(j))
+#endif
+   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
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/loop_based_x_shift_code.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/loop_based_x_shift_code.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/loop_based_x_shift_code.h	(revision 17)
@@ -0,0 +1,112 @@
+      p => grid%head_statevars%next
+      DO WHILE ( ASSOCIATED( p ) ) 
+        IF ( p%ProcOrient .NE. 'X' .AND. p%ProcOrient .NE. 'Y' ) THEN
+          IF ( INDEX(TRIM(p%Stagger),'X') .GT. 0 ) THEN
+            ipf = MIN(ipe,ide)
+          ELSE
+            ipf = MIN(ipe,ide-1)
+          ENDIF
+          IF ( p%Ndim .EQ. 2 ) THEN
+            IF (      p%MemoryOrder(1:1) .EQ. 'X' .AND.  p%MemoryOrder(2:2) .EQ.  'Y' ) THEN
+              IF      ( p%Type .EQ. 'r' ) THEN
+                IF ( SIZE(p%rfield_2d,1)*SIZE(p%rfield_2d,2) .GT. 1 ) THEN
+                  p%rfield_2d(ips:ipf,jms:jme) = p%rfield_2d(ips+px:ipf+px,jms:jme)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'd' ) THEN
+                IF ( SIZE(p%dfield_2d,1)*SIZE(p%dfield_2d,2) .GT. 1 ) THEN
+                  p%dfield_2d(ips:ipf,jms:jme) = p%dfield_2d(ips+px:ipf+px,jms:jme)
+                ENDIF
+              ELSE IF ( TRIM(p%Type) .EQ. 'i' ) THEN
+                IF ( SIZE(p%ifield_2d,1)*SIZE(p%ifield_2d,2) .GT. 1 ) THEN
+                  p%ifield_2d(ips:ipf,jms:jme) = p%ifield_2d(ips+px:ipf+px,jms:jme)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'l' ) THEN
+                IF ( SIZE(p%lfield_2d,1)*SIZE(p%lfield_2d,2) .GT. 1 ) THEN
+                  p%lfield_2d(ips:ipf,jms:jme) = p%lfield_2d(ips+px:ipf+px,jms:jme)
+                ENDIF
+              ENDIF
+            ENDIF
+          ELSE IF ( p%Ndim .EQ. 3 ) THEN
+            IF (      p%MemoryOrder(1:1) .EQ. 'X' .AND.  p%MemoryOrder(3:3) .EQ.  'Y' ) THEN
+              IF      ( p%Type .EQ. 'r' ) THEN
+                IF ( SIZE(p%rfield_3d,1)*SIZE(p%rfield_3d,3) .GT. 1 ) THEN
+                  p%rfield_3d(ips:ipf,:,jms:jme) = p%rfield_3d(ips+px:ipf+px,:,jms:jme)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'd' ) THEN
+                IF ( SIZE(p%dfield_3d,1)*SIZE(p%dfield_3d,3) .GT. 1 ) THEN
+                  p%dfield_3d(ips:ipf,:,jms:jme) = p%dfield_3d(ips+px:ipf+px,:,jms:jme)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'i' ) THEN
+                IF ( SIZE(p%ifield_3d,1)*SIZE(p%ifield_3d,3) .GT. 1 ) THEN
+                  p%ifield_3d(ips:ipf,:,jms:jme) = p%ifield_3d(ips+px:ipf+px,:,jms:jme)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'l' ) THEN
+                CALL wrf_error_fatal( '3D logical arrays cannot be shifted for moving nests' )
+              ENDIF
+            ELSE IF (  p%MemoryOrder(1:2) .EQ. 'XY' ) THEN
+              IF      ( p%Type .EQ. 'r' ) THEN
+                IF ( SIZE(p%rfield_3d,1)*SIZE(p%rfield_3d,2) .GT. 1 ) THEN
+                  p%rfield_3d(ips:ipf,jms:jme,:) = p%rfield_3d(ips+px:ipf+px,jms:jme,:)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'd' ) THEN
+                IF ( SIZE(p%dfield_3d,1)*SIZE(p%dfield_3d,2) .GT. 1 ) THEN
+                  p%dfield_3d(ips:ipf,jms:jme,:) = p%dfield_3d(ips+px:ipf+px,jms:jme,:)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'i' ) THEN
+                IF ( SIZE(p%ifield_3d,1)*SIZE(p%ifield_3d,2) .GT. 1 ) THEN
+                  p%ifield_3d(ips:ipf,jms:jme,:) = p%ifield_3d(ips+px:ipf+px,jms:jme,:)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'l' ) THEN
+                CALL wrf_error_fatal( '3D logical arrays cannot be shifted for moving nests' )
+              ENDIF
+            ENDIF
+          ELSE IF ( p%Ndim .EQ. 4 ) THEN
+            IF (      p%MemoryOrder(1:1) .EQ. 'X' .AND.  p%MemoryOrder(3:3) .EQ.  'Y' ) THEN
+              IF      ( p%Type .EQ. 'r' ) THEN
+                IF ( SIZE(p%rfield_4d,1)*SIZE(p%rfield_4d,3) .GT. 1 ) THEN
+                  DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+                    p%rfield_4d(ips:ipf,:,jms:jme,itrace) = p%rfield_4d(ips+px:ipf+px,:,jms:jme,itrace)
+                  ENDDO
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'd' ) THEN
+                IF ( SIZE(p%dfield_4d,1)*SIZE(p%dfield_4d,3) .GT. 1 ) THEN
+                  DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+                    p%dfield_4d(ips:ipf,:,jms:jme,itrace) = p%dfield_4d(ips+px:ipf+px,:,jms:jme,itrace)
+                  ENDDO
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'i' ) THEN
+                IF ( SIZE(p%ifield_4d,1)*SIZE(p%ifield_4d,3) .GT. 1 ) THEN
+                  DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+                    p%ifield_4d(ips:ipf,:,jms:jme,itrace) = p%ifield_4d(ips+px:ipf+px,:,jms:jme,itrace)
+                  ENDDO
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'l' ) THEN
+                CALL wrf_error_fatal( '4D logical arrays cannot be shifted for moving nests' )
+              ENDIF
+            ELSE IF (  p%MemoryOrder(1:2) .EQ. 'XY' ) THEN
+              IF      ( p%Type .EQ. 'r' ) THEN
+                IF ( SIZE(p%rfield_4d,1)*SIZE(p%rfield_4d,2) .GT. 1 ) THEN
+                  DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+                    p%rfield_4d(ips:ipf,jms:jme,:,itrace) = p%rfield_4d(ips+px:ipf+px,jms:jme,:,itrace)
+                  ENDDO
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'd' ) THEN
+                IF ( SIZE(p%dfield_4d,1)*SIZE(p%dfield_4d,2) .GT. 1 ) THEN
+                  DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+                    p%dfield_4d(ips:ipf,jms:jme,:,itrace) = p%dfield_4d(ips+px:ipf+px,jms:jme,:,itrace)
+                  ENDDO
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'i' ) THEN
+                IF ( SIZE(p%ifield_4d,1)*SIZE(p%ifield_4d,2) .GT. 1 ) THEN
+                  DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+                    p%ifield_4d(ips:ipf,jms:jme,:,itrace) = p%ifield_4d(ips+px:ipf+px,jms:jme,:,itrace)
+                  ENDDO
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'l' ) THEN
+                CALL wrf_error_fatal( '4D logical arrays cannot be shifted for moving nests' )
+              ENDIF
+            ENDIF
+          ENDIF
+        ENDIF
+        p => p%next
+      ENDDO
Index: branches/LMDZ_WRFmeas/WRFV3/frame/loop_based_y_shift_code.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/loop_based_y_shift_code.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/loop_based_y_shift_code.h	(revision 17)
@@ -0,0 +1,113 @@
+      p => grid%head_statevars%next
+      DO WHILE ( ASSOCIATED( p ) ) 
+        IF ( p%ProcOrient .NE. 'X' .AND. p%ProcOrient .NE. 'Y' ) THEN
+          IF ( INDEX(TRIM(p%Stagger),'Y') .GT. 0 ) THEN
+            jpf = MIN(jpe,jde)
+          ELSE
+            jpf = MIN(jpe,jde-1)
+          ENDIF
+          IF ( p%Ndim .EQ. 2 ) THEN
+            IF (      p%MemoryOrder(1:1) .EQ. 'X' .AND.  p%MemoryOrder(2:2) .EQ.  'Y' ) THEN
+              IF      ( p%Type .EQ. 'r' ) THEN
+                IF ( SIZE(p%rfield_2d,1)*SIZE(p%rfield_2d,2) .GT. 1 ) THEN
+                  p%rfield_2d(ims:ime,jps:jpf) = p%rfield_2d(ims:ime,jps+py:jpf+py)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'd' ) THEN
+                IF ( SIZE(p%dfield_2d,1)*SIZE(p%dfield_2d,2) .GT. 1 ) THEN
+                  p%dfield_2d(ims:ime,jps:jpf) = p%dfield_2d(ims:ime,jps+py:jpf+py)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'i' ) THEN
+                IF ( SIZE(p%ifield_2d,1)*SIZE(p%ifield_2d,2) .GT. 1 ) THEN
+                  p%ifield_2d(ims:ime,jps:jpf) = p%ifield_2d(ims:ime,jps+py:jpf+py)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'l' ) THEN
+                IF ( SIZE(p%lfield_2d,1)*SIZE(p%lfield_2d,2) .GT. 1 ) THEN
+                  p%lfield_2d(ims:ime,jps:jpf) = p%lfield_2d(ims:ime,jps+py:jpf+py)
+                ENDIF
+              ENDIF
+            ENDIF
+          ELSE IF ( p%Ndim .EQ. 3 ) THEN
+            IF (      p%MemoryOrder(1:1) .EQ. 'X' .AND.  p%MemoryOrder(3:3) .EQ.  'Y' ) THEN
+              IF      ( p%Type .EQ. 'r' ) THEN
+                IF ( SIZE(p%rfield_3d,1)*SIZE(p%rfield_3d,3) .GT. 1 ) THEN
+                 p%rfield_3d(ims:ime,:,jps:jpf) = p%rfield_3d(ims:ime,:,jps+py:jpf+py)
+
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'd' ) THEN
+                IF ( SIZE(p%dfield_3d,1)*SIZE(p%dfield_3d,3) .GT. 1 ) THEN
+                  p%dfield_3d(ims:ime,:,jps:jpf) = p%dfield_3d(ims:ime,:,jps+py:jpf+py)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'i' ) THEN
+                IF ( SIZE(p%ifield_3d,1)*SIZE(p%ifield_3d,3) .GT. 1 ) THEN
+                  p%ifield_3d(ims:ime,:,jps:jpf) = p%ifield_3d(ims:ime,:,jps+py:jpf+py)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'l' ) THEN
+                CALL wrf_error_fatal( '3D logical arrays cannot be shifted for moving nests' )
+              ENDIF
+            ELSE IF (  p%MemoryOrder(1:2) .EQ. 'XY' ) THEN
+              IF      ( p%Type .EQ. 'r' ) THEN
+                IF ( SIZE(p%rfield_3d,1)*SIZE(p%rfield_3d,2) .GT. 1 ) THEN
+                  p%rfield_3d(ims:ime,jps:jpf,:) = p%rfield_3d(ims:ime,jps+py:jpf+py,:)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'd' ) THEN
+                IF ( SIZE(p%dfield_3d,1)*SIZE(p%dfield_3d,2) .GT. 1 ) THEN
+                  p%dfield_3d(ims:ime,jps:jpf,:) = p%dfield_3d(ims:ime,jps+py:jpf+py,:)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'i' ) THEN
+                IF ( SIZE(p%ifield_3d,1)*SIZE(p%ifield_3d,2) .GT. 1 ) THEN
+                  p%ifield_3d(ims:ime,jps:jpf,:) = p%ifield_3d(ims:ime,jps+py:jpf+py,:)
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'l' ) THEN
+                CALL wrf_error_fatal( '3D logical arrays cannot be shifted for moving nests' )
+              ENDIF
+            ENDIF
+          ELSE IF ( p%Ndim .EQ. 4 ) THEN
+            IF (      p%MemoryOrder(1:1) .EQ. 'X' .AND.  p%MemoryOrder(3:3) .EQ.  'Y' ) THEN
+              IF      ( p%Type .EQ. 'r' ) THEN
+                IF ( SIZE(p%rfield_4d,1)*SIZE(p%rfield_4d,3) .GT. 1 ) THEN
+                  DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+                    p%rfield_4d(ims:ime,:,jps:jpf,itrace) = p%rfield_4d(ims:ime,:,jps+py:jpf+py,itrace)
+                  ENDDO
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'd' ) THEN
+                IF ( SIZE(p%dfield_4d,1)*SIZE(p%dfield_4d,3) .GT. 1 ) THEN
+                  DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+                    p%dfield_4d(ims:ime,:,jps:jpf,itrace) = p%dfield_4d(ims:ime,:,jps+py:jpf+py,itrace)
+                  ENDDO
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'i' ) THEN
+                IF ( SIZE(p%ifield_4d,1)*SIZE(p%ifield_4d,3) .GT. 1 ) THEN
+                  DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+                    p%ifield_4d(ims:ime,:,jps:jpf,itrace) = p%ifield_4d(ims:ime,:,jps+py:jpf+py,itrace)
+                  ENDDO
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'l' ) THEN
+                CALL wrf_error_fatal( '4D logical arrays cannot be shifted for moving nests' )
+              ENDIF
+            ELSE IF (  p%MemoryOrder(1:2) .EQ. 'XY' ) THEN
+              IF      ( p%Type .EQ. 'r' ) THEN
+                IF ( SIZE(p%rfield_4d,1)*SIZE(p%rfield_4d,2) .GT. 1 ) THEN
+                  DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+                    p%rfield_4d(ims:ime,jps:jpf,:,itrace) = p%rfield_4d(ims:ime,jps+py:jpf+py,:,itrace)
+                  ENDDO
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'd' ) THEN
+                IF ( SIZE(p%dfield_4d,1)*SIZE(p%dfield_4d,2) .GT. 1 ) THEN
+                  DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+                    p%dfield_4d(ims:ime,jps:jpf,:,itrace) = p%dfield_4d(ims:ime,jps+py:jpf+py,:,itrace)
+                  ENDDO
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'i' ) THEN
+                IF ( SIZE(p%ifield_4d,1)*SIZE(p%ifield_4d,2) .GT. 1 ) THEN
+                  DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+                    p%ifield_4d(ims:ime,jps:jpf,:,itrace) = p%ifield_4d(ims:ime,jps+py:jpf+py,:,itrace)
+                  ENDDO
+                ENDIF
+              ELSE IF ( p%Type .EQ. 'l' ) THEN
+                CALL wrf_error_fatal( '4D logical arrays cannot be shifted for moving nests' )
+              ENDIF
+            ENDIF
+          ENDIF
+        ENDIF
+        p => p%next
+      ENDDO
Index: branches/LMDZ_WRFmeas/WRFV3/frame/md_calls.m4
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/md_calls.m4	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/md_calls.m4	(revision 17)
@@ -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 )
+!<DESCRIPTION>
+!<PRE>
+!
+! 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.')))
+!
+!</PRE>
+!</DESCRIPTION>
+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 <wrf_status_codes.h>
+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)
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space.h	(revision 17)
@@ -0,0 +1,151 @@
+   SUBROUTINE ROUTINENAME ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated , &
+                                  sd31, ed31, sd32, ed32, sd33, ed33, &
+                                  sm31 , em31 , sm32 , em32 , sm33 , em33 , &
+                                  sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                  sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                  sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                  sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                  sm31y, em31y, sm32y, em32y, sm33y, em33y )
+
+      USE module_domain_type
+      USE module_configure, ONLY : model_config_rec, grid_config_rec_type, in_use_for_config, model_to_grid_config_rec
+!      USE module_state_description
+      USE module_scalar_tables ! this includes module_state_description too
+
+      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)            :: sp31, ep31, sp32, ep32, sp33, ep33
+      INTEGER , INTENT(IN)            :: sp31x, ep31x, sp32x, ep32x, sp33x, ep33x
+      INTEGER , INTENT(IN)            :: sp31y, ep31y, sp32y, ep32y, sp33y, ep33y
+      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
+
+      INTEGER(KIND=8) , INTENT(INOUT)         :: num_bytes_allocated
+
+
+      !  Local data.
+      INTEGER idum1, idum2, spec_bdy_width
+      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
+
+   ! Local data
+
+      TYPE ( grid_config_rec_type ) :: config_flags
+
+      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
+
+      data_ordering : SELECT CASE ( model_data_order )
+         CASE  ( DATA_ORDER_XYZ )
+             ids = sd31 ; ide = ed31 ; jds = sd32 ; jde = ed32 ; kds = sd33 ; kde = ed33 ;
+             ims = sm31 ; ime = em31 ; jms = sm32 ; jme = em32 ; kms = sm33 ; kme = em33 ;
+             ips = sp31 ; ipe = ep31 ; jps = sp32 ; jpe = ep32 ; kps = sp33 ; kpe = ep33 ;
+             imsx = sm31x ; imex = em31x ; jmsx = sm32x ; jmex = em32x ; kmsx = sm33x ; kmex = em33x ;
+             ipsx = sp31x ; ipex = ep31x ; jpsx = sp32x ; jpex = ep32x ; kpsx = sp33x ; kpex = ep33x ;
+             imsy = sm31y ; imey = em31y ; jmsy = sm32y ; jmey = em32y ; kmsy = sm33y ; kmey = em33y ;
+             ipsy = sp31y ; ipey = ep31y ; jpsy = sp32y ; jpey = ep32y ; kpsy = sp33y ; kpey = ep33y ;
+         CASE  ( DATA_ORDER_YXZ )
+             ids = sd32  ; ide = ed32  ; jds = sd31  ; jde = ed31  ; kds = sd33  ; kde = ed33  ;
+             ims = sm32  ; ime = em32  ; jms = sm31  ; jme = em31  ; kms = sm33  ; kme = em33  ;
+             ips = sp32  ; ipe = ep32  ; jps = sp31  ; jpe = ep31  ; kps = sp33  ; kpe = ep33  ;
+             imsx = sm32x  ; imex = em32x  ; jmsx = sm31x  ; jmex = em31x  ; kmsx = sm33x  ; kmex = em33x  ;
+             ipsx = sp32x  ; ipex = ep32x  ; jpsx = sp31x  ; jpex = ep31x  ; kpsx = sp33x  ; kpex = ep33x  ;
+             imsy = sm32y  ; imey = em32y  ; jmsy = sm31y  ; jmey = em31y  ; kmsy = sm33y  ; kmey = em33y  ;
+             ipsy = sp32y  ; ipey = ep32y  ; jpsy = sp31y  ; jpey = ep31y  ; kpsy = sp33y  ; kpey = ep33y  ;
+         CASE  ( DATA_ORDER_ZXY )
+             ids = sd32  ; ide = ed32  ; jds = sd33  ; jde = ed33  ; kds = sd31  ; kde = ed31  ;
+             ims = sm32  ; ime = em32  ; jms = sm33  ; jme = em33  ; kms = sm31  ; kme = em31  ;
+             ips = sp32  ; ipe = ep32  ; jps = sp33  ; jpe = ep33  ; kps = sp31  ; kpe = ep31  ;
+             imsx = sm32x  ; imex = em32x  ; jmsx = sm33x  ; jmex = em33x  ; kmsx = sm31x  ; kmex = em31x  ;
+             ipsx = sp32x  ; ipex = ep32x  ; jpsx = sp33x  ; jpex = ep33x  ; kpsx = sp31x  ; kpex = ep31x  ;
+             imsy = sm32y  ; imey = em32y  ; jmsy = sm33y  ; jmey = em33y  ; kmsy = sm31y  ; kmey = em31y  ;
+             ipsy = sp32y  ; ipey = ep32y  ; jpsy = sp33y  ; jpey = ep33y  ; kpsy = sp31y  ; kpey = ep31y  ;
+         CASE  ( DATA_ORDER_ZYX )
+             ids = sd33  ; ide = ed33  ; jds = sd32  ; jde = ed32  ; kds = sd31  ; kde = ed31  ;
+             ims = sm33  ; ime = em33  ; jms = sm32  ; jme = em32  ; kms = sm31  ; kme = em31  ;
+             ips = sp33  ; ipe = ep33  ; jps = sp32  ; jpe = ep32  ; kps = sp31  ; kpe = ep31  ;
+             imsx = sm33x  ; imex = em33x  ; jmsx = sm32x  ; jmex = em32x  ; kmsx = sm31x  ; kmex = em31x  ;
+             ipsx = sp33x  ; ipex = ep33x  ; jpsx = sp32x  ; jpex = ep32x  ; kpsx = sp31x  ; kpex = ep31x  ;
+             imsy = sm33y  ; imey = em33y  ; jmsy = sm32y  ; jmey = em32y  ; kmsy = sm31y  ; kmey = em31y  ;
+             ipsy = sp33y  ; ipey = ep33y  ; jpsy = sp32y  ; jpey = ep32y  ; kpsy = sp31y  ; kpey = ep31y  ;
+         CASE  ( DATA_ORDER_XZY )
+             ids = sd31  ; ide = ed31  ; jds = sd33  ; jde = ed33  ; kds = sd32  ; kde = ed32  ;
+             ims = sm31  ; ime = em31  ; jms = sm33  ; jme = em33  ; kms = sm32  ; kme = em32  ;
+             ips = sp31  ; ipe = ep31  ; jps = sp33  ; jpe = ep33  ; kps = sp32  ; kpe = ep32  ;
+             imsx = sm31x  ; imex = em31x  ; jmsx = sm33x  ; jmex = em33x  ; kmsx = sm32x  ; kmex = em32x  ;
+             ipsx = sp31x  ; ipex = ep31x  ; jpsx = sp33x  ; jpex = ep33x  ; kpsx = sp32x  ; kpex = ep32x  ;
+             imsy = sm31y  ; imey = em31y  ; jmsy = sm33y  ; jmey = em33y  ; kmsy = sm32y  ; kmey = em32y  ;
+             ipsy = sp31y  ; ipey = ep31y  ; jpsy = sp33y  ; jpey = ep33y  ; kpsy = sp32y  ; kpey = ep32y  ;
+         CASE  ( DATA_ORDER_YZX )
+             ids = sd33  ; ide = ed33  ; jds = sd31  ; jde = ed31  ; kds = sd32  ; kde = ed32  ;
+             ims = sm33  ; ime = em33  ; jms = sm31  ; jme = em31  ; kms = sm32  ; kme = em32  ;
+             ips = sp33  ; ipe = ep33  ; jps = sp31  ; jpe = ep31  ; kps = sp32  ; kpe = ep32  ;
+             imsx = sm33x  ; imex = em33x  ; jmsx = sm31x  ; jmex = em31x  ; kmsx = sm32x  ; kmex = em32x  ;
+             ipsx = sp33x  ; ipex = ep33x  ; jpsx = sp31x  ; jpex = ep31x  ; kpsx = sp32x  ; kpex = ep32x  ;
+             imsy = sm33y  ; imey = em33y  ; jmsy = sm31y  ; jmey = em31y  ; kmsy = sm32y  ; kmey = em32y  ;
+             ipsy = sp33y  ; ipey = ep33y  ; jpsy = sp31y  ; jpey = ep31y  ; kpsy = sp32y  ; kpey = ep32y  ;
+      END SELECT data_ordering
+
+      CALL model_to_grid_config_rec ( id , model_config_rec , config_flags )
+
+      CALL nl_get_sr_x( id , sr_x )
+      CALL nl_get_sr_y( 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_spec_bdy_width( 1, spec_bdy_width )
+
+# include <allocs.inc>
+
+   END SUBROUTINE ROUTINENAME
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_0.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_0.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_0.F	(revision 17)
@@ -0,0 +1,19 @@
+#define NNNMAX 9
+#define NNN 0
+#define ROUTINENAME alloc_space_field_core_0
+MODULE module_alloc_space_0
+CONTAINS
+
+! Split the allocation bits into separate routines.
+!
+! The following bit of maximal foolishness brought to you by the makers of certain compilers
+! that can't process large files of simple branches, assignment statements and calls to very simple
+! procedures and functions without whining to their mommies about it being too complex and insisting 
+! you call your service representative or wait geological time to produce code that old 1-pass 
+! compilers (or compilers for other languages) could have managed efficiently in a second or two.
+!
+
+#include "module_alloc_space.h"
+
+END MODULE module_alloc_space_0
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_1.F	(revision 17)
@@ -0,0 +1,19 @@
+#define NNNMAX 9
+#define NNN 1
+#define ROUTINENAME alloc_space_field_core_1
+MODULE module_alloc_space_1
+CONTAINS
+
+! Split the allocation bits into separate routines.
+!
+! The following bit of maximal foolishness brought to you by the makers of certain compilers
+! that can't process large files of simple branches, assignment statements and calls to very simple
+! procedures and functions without whining to their mommies about it being too complex and insisting 
+! you call your service representative or wait geological time to produce code that old 1-pass 
+! compilers (or compilers for other languages) could have managed efficiently in a second or two.
+!
+
+#include "module_alloc_space.h"
+
+END MODULE module_alloc_space_1
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_2.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_2.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_2.F	(revision 17)
@@ -0,0 +1,19 @@
+#define NNNMAX 9
+#define NNN 2
+#define ROUTINENAME alloc_space_field_core_2
+MODULE module_alloc_space_2
+CONTAINS
+
+! Split the allocation bits into separate routines.
+!
+! The following bit of maximal foolishness brought to you by the makers of certain compilers
+! that can't process large files of simple branches, assignment statements and calls to very simple
+! procedures and functions without whining to their mommies about it being too complex and insisting 
+! you call your service representative or wait geological time to produce code that old 1-pass 
+! compilers (or compilers for other languages) could have managed efficiently in a second or two.
+!
+
+#include "module_alloc_space.h"
+
+END MODULE module_alloc_space_2
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_3.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_3.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_3.F	(revision 17)
@@ -0,0 +1,19 @@
+#define NNNMAX 9
+#define NNN 3
+#define ROUTINENAME alloc_space_field_core_3
+MODULE module_alloc_space_3
+CONTAINS
+
+! Split the allocation bits into separate routines.
+!
+! The following bit of maximal foolishness brought to you by the makers of certain compilers
+! that can't process large files of simple branches, assignment statements and calls to very simple
+! procedures and functions without whining to their mommies about it being too complex and insisting 
+! you call your service representative or wait geological time to produce code that old 1-pass 
+! compilers (or compilers for other languages) could have managed efficiently in a second or two.
+!
+
+#include "module_alloc_space.h"
+
+END MODULE module_alloc_space_3
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_4.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_4.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_4.F	(revision 17)
@@ -0,0 +1,19 @@
+#define NNNMAX 9
+#define NNN 4
+#define ROUTINENAME alloc_space_field_core_4
+MODULE module_alloc_space_4
+CONTAINS
+
+! Split the allocation bits into separate routines.
+!
+! The following bit of maximal foolishness brought to you by the makers of certain compilers
+! that can't process large files of simple branches, assignment statements and calls to very simple
+! procedures and functions without whining to their mommies about it being too complex and insisting 
+! you call your service representative or wait geological time to produce code that old 1-pass 
+! compilers (or compilers for other languages) could have managed efficiently in a second or two.
+!
+
+#include "module_alloc_space.h"
+
+END MODULE module_alloc_space_4
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_5.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_5.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_5.F	(revision 17)
@@ -0,0 +1,19 @@
+#define NNNMAX 9
+#define NNN 5
+#define ROUTINENAME alloc_space_field_core_5
+MODULE module_alloc_space_5
+CONTAINS
+
+! Split the allocation bits into separate routines.
+!
+! The following bit of maximal foolishness brought to you by the makers of certain compilers
+! that can't process large files of simple branches, assignment statements and calls to very simple
+! procedures and functions without whining to their mommies about it being too complex and insisting 
+! you call your service representative or wait geological time to produce code that old 1-pass 
+! compilers (or compilers for other languages) could have managed efficiently in a second or two.
+!
+
+#include "module_alloc_space.h"
+
+END MODULE module_alloc_space_5
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_6.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_6.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_6.F	(revision 17)
@@ -0,0 +1,19 @@
+#define NNNMAX 9
+#define NNN 6
+#define ROUTINENAME alloc_space_field_core_6
+MODULE module_alloc_space_6
+CONTAINS
+
+! Split the allocation bits into separate routines.
+!
+! The following bit of maximal foolishness brought to you by the makers of certain compilers
+! that can't process large files of simple branches, assignment statements and calls to very simple
+! procedures and functions without whining to their mommies about it being too complex and insisting 
+! you call your service representative or wait geological time to produce code that old 1-pass 
+! compilers (or compilers for other languages) could have managed efficiently in a second or two.
+!
+
+#include "module_alloc_space.h"
+
+END MODULE module_alloc_space_6
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_7.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_7.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_7.F	(revision 17)
@@ -0,0 +1,19 @@
+#define NNNMAX 9
+#define NNN 7
+#define ROUTINENAME alloc_space_field_core_7
+MODULE module_alloc_space_7
+CONTAINS
+
+! Split the allocation bits into separate routines.
+!
+! The following bit of maximal foolishness brought to you by the makers of certain compilers
+! that can't process large files of simple branches, assignment statements and calls to very simple
+! procedures and functions without whining to their mommies about it being too complex and insisting 
+! you call your service representative or wait geological time to produce code that old 1-pass 
+! compilers (or compilers for other languages) could have managed efficiently in a second or two.
+!
+
+#include "module_alloc_space.h"
+
+END MODULE module_alloc_space_7
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_8.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_8.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_8.F	(revision 17)
@@ -0,0 +1,19 @@
+#define NNNMAX 9
+#define NNN 8
+#define ROUTINENAME alloc_space_field_core_8
+MODULE module_alloc_space_8
+CONTAINS
+
+! Split the allocation bits into separate routines.
+!
+! The following bit of maximal foolishness brought to you by the makers of certain compilers
+! that can't process large files of simple branches, assignment statements and calls to very simple
+! procedures and functions without whining to their mommies about it being too complex and insisting 
+! you call your service representative or wait geological time to produce code that old 1-pass 
+! compilers (or compilers for other languages) could have managed efficiently in a second or two.
+!
+
+#include "module_alloc_space.h"
+
+END MODULE module_alloc_space_8
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_9.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_9.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_alloc_space_9.F	(revision 17)
@@ -0,0 +1,19 @@
+#define NNNMAX 9
+#define NNN 9
+#define ROUTINENAME alloc_space_field_core_9
+MODULE module_alloc_space_9
+CONTAINS
+
+! Split the allocation bits into separate routines.
+!
+! The following bit of maximal foolishness brought to you by the makers of certain compilers
+! that can't process large files of simple branches, assignment statements and calls to very simple
+! procedures and functions without whining to their mommies about it being too complex and insisting 
+! you call your service representative or wait geological time to produce code that old 1-pass 
+! compilers (or compilers for other languages) could have managed efficiently in a second or two.
+!
+
+#include "module_alloc_space.h"
+
+END MODULE module_alloc_space_9
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm.F	(revision 17)
@@ -0,0 +1,39 @@
+
+MODULE module_comm_dm
+
+   USE module_comm_dm_0
+   USE module_comm_dm_1
+   USE module_comm_dm_2
+   USE module_comm_dm_3
+   USE module_comm_dm_4_
+
+   IMPLICIT NONE
+
+   PRIVATE module_comm_dm_dummy
+
+#ifdef DM_PARALLEL
+   INTEGER, PRIVATE :: rsl_sendw_p, rsl_sendbeg_p, rsl_recvw_p, rsl_recvbeg_p
+   INTEGER, PRIVATE :: rsl_sendw_m, rsl_sendbeg_m, rsl_recvw_m, rsl_recvbeg_m
+#endif
+
+   INTEGER, PRIVATE :: idim1, idim2, idim3, idim4, idim5, idim6, idim7
+
+
+CONTAINS
+
+   ! Avoid complaints about empty CONTAINS from some compilers.
+   SUBROUTINE module_comm_dm_dummy
+     USE module_domain, ONLY:domain
+     USE module_configure, ONLY:grid_config_rec_type,in_use_for_config
+     USE module_state_description, ONLY:PARAM_FIRST_SCALAR
+     USE module_driver_constants
+     RETURN
+   END SUBROUTINE module_comm_dm_dummy
+
+! Registry-generated communication subroutines.
+#ifdef DM_PARALLEL
+#include "REGISTRY_COMM_DM_subs.inc"
+#endif
+
+END MODULE module_comm_dm
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_0.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_0.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_0.F	(revision 17)
@@ -0,0 +1,34 @@
+
+MODULE module_comm_dm_0
+
+   IMPLICIT NONE
+
+   PRIVATE module_comm_dm_dummy_0
+
+#ifdef DM_PARALLEL
+   INTEGER, PRIVATE :: rsl_sendw_p, rsl_sendbeg_p, rsl_recvw_p, rsl_recvbeg_p
+   INTEGER, PRIVATE :: rsl_sendw_m, rsl_sendbeg_m, rsl_recvw_m, rsl_recvbeg_m
+   LOGICAL, EXTERNAL :: rsl_comm_iter
+#endif
+
+   INTEGER, PRIVATE :: idim1, idim2, idim3, idim4, idim5, idim6, idim7
+
+
+CONTAINS
+
+   ! Avoid complaints about empty CONTAINS from some compilers.  
+   SUBROUTINE module_comm_dm_dummy_0
+     USE module_domain, ONLY:domain
+     USE module_configure, ONLY:grid_config_rec_type,in_use_for_config
+     USE module_state_description, ONLY:PARAM_FIRST_SCALAR
+     USE module_driver_constants
+     RETURN
+   END SUBROUTINE module_comm_dm_dummy_0
+
+! Registry-generated communication subroutines.  
+#ifdef DM_PARALLEL
+#include "REGISTRY_COMM_DM_0_subs.inc"
+#endif
+
+END MODULE module_comm_dm_0
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_1.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_1.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_1.F	(revision 17)
@@ -0,0 +1,34 @@
+
+MODULE module_comm_dm_1
+
+   IMPLICIT NONE
+
+   PRIVATE module_comm_dm_dummy_1
+
+#ifdef DM_PARALLEL
+   INTEGER, PRIVATE :: rsl_sendw_p, rsl_sendbeg_p, rsl_recvw_p, rsl_recvbeg_p
+   INTEGER, PRIVATE :: rsl_sendw_m, rsl_sendbeg_m, rsl_recvw_m, rsl_recvbeg_m
+   LOGICAL, EXTERNAL :: rsl_comm_iter
+#endif
+
+   INTEGER, PRIVATE :: idim1, idim2, idim3, idim4, idim5, idim6, idim7
+
+
+CONTAINS
+
+   ! Avoid complaints about empty CONTAINS from some compilers.  
+   SUBROUTINE module_comm_dm_dummy_1
+     USE module_domain, ONLY:domain
+     USE module_configure, ONLY:grid_config_rec_type,in_use_for_config
+     USE module_state_description, ONLY:PARAM_FIRST_SCALAR
+     USE module_driver_constants
+     RETURN
+   END SUBROUTINE module_comm_dm_dummy_1
+
+! Registry-generated communication subroutines.  
+#ifdef DM_PARALLEL
+#include "REGISTRY_COMM_DM_1_subs.inc"
+#endif
+
+END MODULE module_comm_dm_1
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_2.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_2.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_2.F	(revision 17)
@@ -0,0 +1,34 @@
+
+MODULE module_comm_dm_2
+
+   IMPLICIT NONE
+
+   PRIVATE module_comm_dm_dummy_2
+
+#ifdef DM_PARALLEL
+   INTEGER, PRIVATE :: rsl_sendw_p, rsl_sendbeg_p, rsl_recvw_p, rsl_recvbeg_p
+   INTEGER, PRIVATE :: rsl_sendw_m, rsl_sendbeg_m, rsl_recvw_m, rsl_recvbeg_m
+   LOGICAL, EXTERNAL :: rsl_comm_iter
+#endif
+
+   INTEGER, PRIVATE :: idim1, idim2, idim3, idim4, idim5, idim6, idim7
+
+
+CONTAINS
+
+   ! Avoid complaints about empty CONTAINS from some compilers.  
+   SUBROUTINE module_comm_dm_dummy_2
+     USE module_domain, ONLY:domain
+     USE module_configure, ONLY:grid_config_rec_type,in_use_for_config
+     USE module_state_description, ONLY:PARAM_FIRST_SCALAR
+     USE module_driver_constants
+     RETURN
+   END SUBROUTINE module_comm_dm_dummy_2
+
+! Registry-generated communication subroutines.  
+#ifdef DM_PARALLEL
+#include "REGISTRY_COMM_DM_2_subs.inc"
+#endif
+
+END MODULE module_comm_dm_2
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_3.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_3.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_3.F	(revision 17)
@@ -0,0 +1,34 @@
+
+MODULE module_comm_dm_3
+
+   IMPLICIT NONE
+
+   PRIVATE module_comm_dm_dummy_3
+
+#ifdef DM_PARALLEL
+   INTEGER, PRIVATE :: rsl_sendw_p, rsl_sendbeg_p, rsl_recvw_p, rsl_recvbeg_p
+   INTEGER, PRIVATE :: rsl_sendw_m, rsl_sendbeg_m, rsl_recvw_m, rsl_recvbeg_m
+   LOGICAL, EXTERNAL :: rsl_comm_iter
+#endif
+
+   INTEGER, PRIVATE :: idim1, idim2, idim3, idim4, idim5, idim6, idim7
+
+
+CONTAINS
+
+   ! Avoid complaints about empty CONTAINS from some compilers.  
+   SUBROUTINE module_comm_dm_dummy_3
+     USE module_domain, ONLY:domain
+     USE module_configure, ONLY:grid_config_rec_type,in_use_for_config
+     USE module_state_description, ONLY:PARAM_FIRST_SCALAR
+     USE module_driver_constants
+     RETURN
+   END SUBROUTINE module_comm_dm_dummy_3
+
+! Registry-generated communication subroutines.  
+#ifdef DM_PARALLEL
+#include "REGISTRY_COMM_DM_3_subs.inc"
+#endif
+
+END MODULE module_comm_dm_3
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_4.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_4.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_dm_4.F	(revision 17)
@@ -0,0 +1,34 @@
+
+MODULE module_comm_dm_4_
+
+   IMPLICIT NONE
+
+   PRIVATE module_comm_dm_dummy_4
+
+#ifdef DM_PARALLEL
+   INTEGER, PRIVATE :: rsl_sendw_p, rsl_sendbeg_p, rsl_recvw_p, rsl_recvbeg_p
+   INTEGER, PRIVATE :: rsl_sendw_m, rsl_sendbeg_m, rsl_recvw_m, rsl_recvbeg_m
+   LOGICAL, EXTERNAL :: rsl_comm_iter
+#endif
+
+   INTEGER, PRIVATE :: idim1, idim2, idim3, idim4, idim5, idim6, idim7
+
+
+CONTAINS
+
+   ! Avoid complaints about empty CONTAINS from some compilers.  
+   SUBROUTINE module_comm_dm_dummy_4
+     USE module_domain, ONLY:domain
+     USE module_configure, ONLY:grid_config_rec_type,in_use_for_config
+     USE module_state_description, ONLY:PARAM_FIRST_SCALAR
+     USE module_driver_constants
+     RETURN
+   END SUBROUTINE module_comm_dm_dummy_4
+
+! Registry-generated communication subroutines.  
+#ifdef DM_PARALLEL
+#include "REGISTRY_COMM_DM_PERIOD_subs.inc"
+#endif
+
+END MODULE module_comm_dm_4_
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_nesting_dm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_nesting_dm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_comm_nesting_dm.F	(revision 17)
@@ -0,0 +1,34 @@
+
+MODULE module_comm_nesting_dm
+
+   IMPLICIT NONE
+
+   PRIVATE module_comm_nesting_dm_dummy
+
+#ifdef DM_PARALLEL
+   INTEGER, PRIVATE :: rsl_sendw_p, rsl_sendbeg_p, rsl_recvw_p, rsl_recvbeg_p
+   INTEGER, PRIVATE :: rsl_sendw_m, rsl_sendbeg_m, rsl_recvw_m, rsl_recvbeg_m
+   LOGICAL, EXTERNAL :: rsl_comm_iter
+#endif
+
+   INTEGER, PRIVATE :: idim1, idim2, idim3, idim4, idim5, idim6, idim7
+
+
+CONTAINS
+
+   ! Avoid complaints about empty CONTAINS from some compilers.  
+   SUBROUTINE module_comm_nesting_dm_dummy
+     USE module_domain, ONLY:domain
+     USE module_configure, ONLY:grid_config_rec_type,in_use_for_config
+     USE module_state_description, ONLY:PARAM_FIRST_SCALAR
+     USE module_driver_constants
+     RETURN
+   END SUBROUTINE module_comm_nesting_dm_dummy
+
+! Registry-generated communication subroutines.  
+#ifdef DM_PARALLEL
+#include "REGISTRY_COMM_NESTING_DM_subs.inc"
+#endif
+
+END MODULE module_comm_nesting_dm
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_configure.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_configure.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_configure.F	(revision 17)
@@ -0,0 +1,542 @@
+!WRF:DRIVER_LAYER:CONFIGURATION
+!
+
+MODULE module_scalar_tables
+  USE module_driver_constants
+  USE module_state_description
+  USE module_domain_type, ONLY : streamrec
+#include <scalar_tables.inc>
+CONTAINS
+  SUBROUTINE init_module_scalar_tables
+     INTEGER i , j
+     DO j = 1, max_domains
+#include <scalar_tables_init.inc>
+     END DO
+  END SUBROUTINE init_module_scalar_tables
+END MODULE module_scalar_tables
+
+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 <namelist_defines.inc>
+   END TYPE model_config_rec_type
+
+   TYPE grid_config_rec_type
+#include <namelist_defines2.inc>
+   END TYPE grid_config_rec_type
+
+   TYPE(model_config_rec_type) :: model_config_rec
+
+!#include <scalar_tables.inc>
+
+! special entries (put here but not enshrined in Registry for one reason or other)
+
+!   CHARACTER (LEN=256) :: mminlu = ' '             ! character string for landuse table
+
+CONTAINS
+
+
+! Model layer, even though it does I/O -- special case of namelist I/O.
+
+   SUBROUTINE initial_config
+!<DESCRIPTION>
+! 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 <em>config_flags</em>
+! 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):
+!
+! <pre>
+! 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
+! </pre>
+!
+!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 <em>all</em> domains in the run. This will be revisited.
+!
+!</DESCRIPTION>
+      IMPLICIT NONE
+
+      INTEGER              :: io_status
+      INTEGER              :: i
+
+      LOGICAL              :: nml_read_error
+
+      CHARACTER (LEN=1024) :: nml_name
+
+      INTEGER, PARAMETER :: nml_write_unit= 9
+      INTEGER, PARAMETER :: nml_read_unit = 10
+
+
+! define as temporaries
+#include <namelist_defines.inc>
+
+! Statements that specify the namelists
+#include <namelist_statements.inc>
+
+      OPEN ( UNIT   = nml_read_unit    ,      &
+             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
+
+#ifndef NO_NAMELIST_PRINT
+      OPEN ( UNIT   = nml_write_unit    ,      &
+             FILE   = "namelist.output" ,      &
+             FORM   = "FORMATTED"      ,      &
+             STATUS = "REPLACE"        ,      &
+             IOSTAT = io_status         )
+
+      IF ( io_status .NE. 0 ) THEN
+        CALL WRF_ERROR_FATAL ( 'ERROR OPENING namelist.output' )
+      ENDIF
+#endif
+
+! Statements that set the namelist vars to default vals
+#  include <namelist_defaults.inc>
+
+#if (DA_CORE == 1)
+! Override the default values, because we can not assigned a arrary with different values in registry.
+
+      as1(1:3) = (/ 0.25, 1.0, 1.5 /)
+      as2(1:3) = (/ 0.25, 1.0, 1.5 /)
+      as3(1:3) = (/ 0.25, 1.0, 1.5 /)
+      as4(1:3) = (/ 0.25, 1.0, 1.5 /)
+      as5(1:3) = (/ 0.25, 1.0, 1.5 /)
+#endif
+
+! Statements that read the namelist are in this file
+#  include <config_reads.inc>
+
+! 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 <config_assigns.inc>
+
+
+      CLOSE ( UNIT = nml_read_unit , IOSTAT = io_status )
+
+      IF ( io_status .NE. 0 ) THEN
+        CALL WRF_ERROR_FATAL ( 'ERROR CLOSING namelist.input' )
+      ENDIF
+
+#ifndef NO_NAMELIST_PRINT
+      CLOSE ( UNIT = nml_write_unit , IOSTAT = io_status )
+
+      IF ( io_status .NE. 0 ) THEN
+        CALL WRF_ERROR_FATAL ( 'ERROR CLOSING namelist.output' )
+      ENDIF
+#endif
+
+#ifdef _WIN32
+      model_config_rec%nocolons = .TRUE.   ! always no colons for Windows
+#endif
+
+      RETURN
+
+   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 too 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 too 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
+! <DESCRIPTION>
+! 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.
+!
+!
+! </DESCRIPTION>
+#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 <config_assigns.inc>
+   END SUBROUTINE model_to_grid_config_rec
+
+
+   FUNCTION in_use_for_config ( id, vname ) RESULT ( in_use )
+     INTEGER, INTENT(IN) :: id
+     CHARACTER*(*), INTENT(IN) :: vname
+     LOGICAL in_use
+     INTEGER uses
+
+     uses = 0
+     in_use = .TRUE.
+
+     IF      ( vname(1:1) .GE. 'x' ) THEN
+#  include <in_use_for_config_xz.inc>
+     ELSE IF ( vname(1:1) .GE. 't' ) THEN
+#  include <in_use_for_config_tw.inc>
+     ELSE IF ( vname(1:1) .GE. 'o' ) THEN
+#  include <in_use_for_config_os.inc>
+     ELSE IF ( vname(1:1) .GE. 'l' ) THEN
+#  include <in_use_for_config_ln.inc>
+     ELSE IF ( vname(1:1) .GE. 'g' ) THEN
+#  include <in_use_for_config_gk.inc>
+     ELSE IF ( vname(1:1) .GE. 'd' ) THEN
+#  include <in_use_for_config_df.inc>
+     ELSE 
+#  include <in_use_for_config_ac.inc>
+     ENDIF
+
+     RETURN
+   END FUNCTION
+
+
+! 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
+     USE module_scalar_tables
+     IMPLICIT NONE
+     CALL init_module_scalar_tables
+   END SUBROUTINE init_module_configure
+
+   SUBROUTINE wrf_alt_nml_obsolete (nml_read_unit, nml_name)
+!
+!<DESCRIPTION>
+! If there is an error reading the "nml_name" namelist, this routine is
+! called to check for namelist variables that have been removed by the 
+! developers and are still in user's namelists.
+! 
+! The calls to this routine are in registry-generated code: inc/config_reads.inc
+!</DESCRIPTION>
+!
+     IMPLICIT NONE
+     INTEGER, INTENT(IN)       :: nml_read_unit
+     CHARACTER*(*), INTENT(IN) :: nml_name
+     INTEGER                   :: nml_error
+
+#include <namelist_defines.inc>
+#include <namelist_statements.inc>
+
+! These are the variables that have been removed
+     logical , DIMENSION(max_domains) :: pd_moist, pd_chem, pd_tke, pd_scalar
+     NAMELIST /dynamics/                 pd_moist, pd_chem, pd_tke, pd_scalar
+
+     integer , DIMENSION(max_domains) :: ucmcall
+     NAMELIST /physics/                  ucmcall
+
+     integer , DIMENSION(max_domains) :: obs_nobs_prt
+     NAMELIST /fdda/                     obs_nobs_prt
+
+     LOGICAL ::         global, print_detail_airep, print_detail_timing
+     NAMELIST /wrfvar1/ global, print_detail_airep, print_detail_timing
+
+     LOGICAL ::         write_qcw, write_qrn, write_qci, write_qsn
+     NAMELIST /wrfvar2/ write_qcw, write_qrn, write_qci, write_qsn
+     LOGICAL ::          write_qgr, write_filtered_obs
+     NAMELIST /wrfvar2/  write_qgr, write_filtered_obs
+
+     LOGICAL ::         use_eos_radobs
+     NAMELIST /wrfvar4/ use_eos_radobs
+
+     LOGICAL             :: use_crtm_kmatrix_fast
+     NAMELIST /wrfvar14/    use_crtm_kmatrix_fast
+     CHARACTER (LEN=256) :: spccoeff_file, taucoeff_file, aerosolcoeff_file
+     NAMELIST /wrfvar14/    spccoeff_file, taucoeff_file, aerosolcoeff_file
+     CHARACTER (LEN=256) :: cloudcoeff_file, emiscoeff_file
+     NAMELIST /wrfvar14/    cloudcoeff_file, emiscoeff_file
+
+
+
+! Read the namelist again, if it succeeds after adding the above variables,
+! it probably failed because these are still in the namelist.  If it fails
+! again, we will return.
+
+     REWIND ( UNIT = nml_read_unit )
+
+!----------------------------- dynamics ---------------------------------
+     if ( TRIM(nml_name) .eq. "dynamics" ) then
+
+        READ   ( UNIT = nml_read_unit , NML = dynamics , iostat=nml_error )
+
+        IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
+           CALL wrf_debug(0, "-- Are pd_moist, pd_chem, pd_tke, or pd_scalar still in your "// &
+                               TRIM(nml_name)//" namelist?")
+           CALL wrf_debug(0, "-- Replace them with moist_adv_opt, chem_adv_opt, tke_adv_opt "// &
+                             " and scalar_adv_opt, respectively.")
+        ENDIF
+
+!---------------------------------- physics -----------------------------
+     else if ( TRIM(nml_name) .eq. "physics" ) then
+
+        READ   ( UNIT = nml_read_unit , NML = physics , iostat=nml_error )
+
+        IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
+           CALL wrf_debug(0, "-- Is ucmcall still in your "// TRIM(nml_name)//" namelist?")
+           CALL wrf_debug(0, "-- Replace it with sf_urban_physics")
+        ENDIF
+
+!---------------------------------- fdda --------------------------------
+     else if ( TRIM(nml_name) .eq. "fdda" ) then
+
+        READ   ( UNIT = nml_read_unit , NML = fdda , iostat=nml_error )
+
+        IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
+           CALL wrf_debug(0, "-- Is obs_nobs_prt still in your "// TRIM(nml_name)//" namelist?")
+           CALL wrf_debug(0, "-- Replace it with obs_prt_max")
+        ENDIF
+
+!---------------------------------- wrfvar1 -----------------------------
+     else if ( TRIM(nml_name) .eq. "wrfvar1" ) then
+
+        READ   ( UNIT = nml_read_unit , NML = wrfvar1 , iostat=nml_error )
+
+        IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
+           CALL wrf_debug(0, "-- Are global, print_detail_airep, print_detail_timing still in your "// &
+                              TRIM(nml_name)//" namelist?")
+           CALL wrf_debug(0, "-- Remove global, print_detail_airep, print_detail_timing "// &
+                             "from wrfvar1 namelist as they are obsolete.")
+        ENDIF
+
+!---------------------------------- wrfvar2 -----------------------------
+     else if ( TRIM(nml_name) .eq. "wrfvar2" ) then
+
+        READ   ( UNIT = nml_read_unit , NML = wrfvar2 , iostat=nml_error )
+
+        IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
+           CALL wrf_debug(0, "-- Are write_qcw, write_qrn, write_qci, write_qsn, write_qgr, "// &
+                             "write_filtered_obs still in your "// &
+                              TRIM(nml_name)//" namelist?")
+           CALL wrf_debug(0, "-- Remove write_qcw, write_qrn, write_qci, write_qsn, write_qgr, "// &
+                             "write_filtered_obs as they are obsolete.")
+        ENDIF
+
+!---------------------------------- wrfvar4 -----------------------------
+     else if ( TRIM(nml_name) .eq. "wrfvar4" ) then
+
+        READ   ( UNIT = nml_read_unit , NML = wrfvar4 , iostat=nml_error )
+
+        IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
+           CALL wrf_debug(0, "-- Is use_eos_radobs still in your "// &
+                              TRIM(nml_name)//" namelist?")
+           CALL wrf_debug(0, "-- Remove use_eos_radobs as it is obsolete.")
+        ENDIF
+
+!---------------------------------- wrfvar14 -----------------------------
+     else if ( TRIM(nml_name) .eq. "wrfvar14" ) then
+
+     READ   ( UNIT = nml_read_unit , NML = wrfvar14 , iostat=nml_error )
+
+        IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
+           CALL wrf_debug(0, "-- Are use_crtm_kmatrix_fast, spccoeff_file, taucoeff_file, "// &
+                             "aerosolcoeff_file, cloudcoeff_file, emiscoeff_file still in your "// &
+                              TRIM(nml_name)//" namelist?")
+           CALL wrf_debug(0, "-- Remove them as they are obsolete.")
+        ENDIF
+
+!---------------------------------- error -------------------------------
+     else
+         IF ( &
+#include "namelist_nametest.inc"
+              ) THEN
+            nml_error = 0
+         ELSE
+            CALL wrf_debug(0, TRIM(nml_name)//" is not a valid namelist name")
+         ENDIF
+     end if
+
+     IF ( nml_error .NE. 0 ) then    ! Still failed
+        return
+     ENDIF
+
+   END SUBROUTINE wrf_alt_nml_obsolete
+
+END MODULE module_configure
+
+
+SUBROUTINE set_scalar_indices_from_config ( idomain , dummy2, dummy1 )
+  USE module_driver_constants
+  USE module_state_description
+  USE module_wrf_error
+  USE module_configure, ONLY : model_config_rec
+  USE module_scalar_tables
+  IMPLICIT NONE
+  INTEGER , INTENT(IN)  :: idomain
+  INTEGER               :: dummy1
+  INTEGER               :: dummy2
+
+!<DESCRIPTION>
+!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.
+!
+!</DESCRIPTION>
+
+#include <scalar_indices.inc>
+#include <scalar_indices_init.inc>
+  RETURN
+END SUBROUTINE set_scalar_indices_from_config
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_dm_stubs.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_dm_stubs.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_dm_stubs.F	(revision 17)
@@ -0,0 +1,350 @@
+!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
+
+   SUBROUTINE wrf_dm_min_reals ( inval, retval, n )
+      IMPLICIT NONE
+      INTEGER, INTENT(IN) :: n
+      REAL, INTENT(IN) :: inval(:)
+      REAL, INTENT(OUT) :: retval(:)
+      retval(:) = inval(:)
+   END SUBROUTINE wrf_dm_min_reals
+
+   REAL FUNCTION wrf_dm_sum_real ( inval )
+      IMPLICIT NONE
+      REAL inval
+      wrf_dm_sum_real = inval
+   END FUNCTION wrf_dm_sum_real
+
+   SUBROUTINE wrf_dm_sum_reals ( inval, retval )
+      IMPLICIT NONE
+      REAL, INTENT(IN) :: inval(:)
+      REAL, INTENT(OUT) :: retval(:)
+      retval(:) = inval(:)
+   END SUBROUTINE wrf_dm_sum_reals
+
+   INTEGER FUNCTION wrf_dm_sum_integer ( inval )
+      IMPLICIT NONE
+      INTEGER inval
+      wrf_dm_sum_integer = inval
+   END FUNCTION wrf_dm_sum_integer
+
+   INTEGER FUNCTION wrf_dm_bxor_integer ( inval )
+      IMPLICIT NONE
+      INTEGER inval
+      wrf_dm_bxor_integer = inval
+   END FUNCTION wrf_dm_bxor_integer
+
+   SUBROUTINE wrf_dm_maxval ( val, idex, jdex )
+      IMPLICIT NONE
+      REAL val
+      INTEGER idex, jdex
+      RETURN
+   END SUBROUTINE wrf_dm_maxval
+
+  SUBROUTINE wrf_dm_minval ( val, idex, jdex )
+     IMPLICIT NONE
+     REAL val
+     INTEGER idex, jdex
+     RETURN
+  END SUBROUTINE wrf_dm_minval
+
+   SUBROUTINE wrf_dm_maxtile_real ( val , tile)
+      IMPLICIT NONE
+      REAL val
+      INTEGER tile
+   END SUBROUTINE wrf_dm_maxtile_real
+
+   SUBROUTINE wrf_dm_mintile_double ( val , tile)
+      IMPLICIT NONE
+      DOUBLE PRECISION val
+      INTEGER tile
+   END SUBROUTINE wrf_dm_mintile_double
+
+   SUBROUTINE wrf_dm_tile_val_int ( val , tile)
+      IMPLICIT NONE
+      INTEGER val
+      INTEGER tile
+   END SUBROUTINE wrf_dm_tile_val_int
+
+! 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
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_dm_warning
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_dm_warning	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_dm_warning	(revision 17)
@@ -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.
+!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_domain.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_domain.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_domain.F	(revision 17)
@@ -0,0 +1,2929 @@
+!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_configure
+   USE module_wrf_error
+   USE module_utility
+   USE module_domain_type
+
+   ! In WRFV3, the module_domain_type is defined
+   ! in a separaate source file, frame/module_domain_type.F
+   ! This enables splitting off the alloc_space_field routine
+   ! into a separate file, reducing the size of module_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%sp31,  grid%ep31,  grid%sp32,  grid%ep32,  grid%sp33,  grid%ep33, &
+                             grid%sp31x, grid%ep31x, grid%sp32x, grid%ep32x, grid%sp33x, grid%ep33x, &
+                             grid%sp31y, grid%ep31y, grid%sp32y, grid%ep32y, grid%sp33y, grid%ep33y, &
+                             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
+
+#if 1
+   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
+#endif
+
+
+! 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 )
+!<DESCRIPTION>
+! 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 sd<em>n</em>:ed<em>n</em> are the starts
+! and ends of the staggered domains in X.  The non-staggered grid runs
+! sd<em>n</em>:ed<em>n</em>-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.
+!</DESCRIPTION>
+
+   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 ) = ( sd1                  <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
+   bdy_mask( P_YSB ) = ( sd2                  <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
+   bdy_mask( P_XEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1                  )
+   bdy_mask( P_YEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2                  )
+      CASE ( DATA_ORDER_YXZ )
+   bdy_mask( P_XSB ) = ( sd2                  <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
+   bdy_mask( P_YSB ) = ( sd1                  <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
+   bdy_mask( P_XEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2                  )
+   bdy_mask( P_YEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1                  )
+      CASE ( DATA_ORDER_ZXY )
+   bdy_mask( P_XSB ) = ( sd2                  <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
+   bdy_mask( P_YSB ) = ( sd3                  <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
+   bdy_mask( P_XEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2                  )
+   bdy_mask( P_YEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3                  )
+      CASE ( DATA_ORDER_ZYX )
+   bdy_mask( P_XSB ) = ( sd3                  <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
+   bdy_mask( P_YSB ) = ( sd2                  <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
+   bdy_mask( P_XEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3                  )
+   bdy_mask( P_YEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2                  )
+      CASE ( DATA_ORDER_XZY )
+   bdy_mask( P_XSB ) = ( sd1                  <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
+   bdy_mask( P_YSB ) = ( sd3                  <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
+   bdy_mask( P_XEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1                  )
+   bdy_mask( P_YEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3                  )
+      CASE ( DATA_ORDER_YZX )
+   bdy_mask( P_XSB ) = ( sd3                  <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
+   bdy_mask( P_YSB ) = ( sd1                  <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
+   bdy_mask( P_XEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3                  )
+   bdy_mask( P_YEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1                  )
+   END SELECT
+
+#endif
+
+   RETURN
+   END SUBROUTINE wrf_patch_domain
+!
+   SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid )
+
+!<DESCRIPTION>
+! This subroutine is used to allocate a domain data structure of
+! TYPE(DOMAIN) pointed to by the argument <em>grid</em>, 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 <em>parent</em>
+! argument will point to the already existing domain data structure for
+! the parent domain and the <em>kid</em> 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.  <b>WRF domains may have multiple children
+! but only ever have one parent.</b>
+!
+! The <em>domain_id</em> 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 <a href=med_add_config_info_to_grid.html>med_add_config_info_to_grid</a>, defined
+! in share/mediation_wrfmain.F. 
+!</DESCRIPTION>
+
+      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
+
+      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%head_statevars )
+      NULLIFY( new_grid%head_statevars%next)
+      new_grid%tail_statevars => new_grid%head_statevars 
+
+      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%is_intermediate = .FALSE.
+      new_grid%have_displayed_alloc_stats = .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)
+#if (EM_CORE == 1)
+      new_grid%stepping_to_time = .FALSE.
+      new_grid%adaptation_domain = 1
+      new_grid%last_step_updated = -1
+#endif
+
+      CALL alloc_space_field ( new_grid, domain_id , 3 , 3 , .FALSE. ,      &
+                               sd1, ed1, sd2, ed2, sd3, ed3,       &
+                               sm1,  em1,  sm2,  em2,  sm3,  em3,  &
+                               sp1,  ep1,  sp2,  ep2,  sp3,  ep3,  &
+                               sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
+                               sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
+                               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
+
+! Allocate storage for time series metadata
+      ALLOCATE( grid%lattsloc( grid%max_ts_locs ) )
+      ALLOCATE( grid%lontsloc( grid%max_ts_locs ) )
+      ALLOCATE( grid%nametsloc( grid%max_ts_locs ) )
+      ALLOCATE( grid%desctsloc( grid%max_ts_locs ) )
+      ALLOCATE( grid%itsloc( grid%max_ts_locs ) )
+      ALLOCATE( grid%jtsloc( grid%max_ts_locs ) )
+      ALLOCATE( grid%id_tsloc( grid%max_ts_locs ) )
+      ALLOCATE( grid%ts_filename( grid%max_ts_locs ) )
+      grid%ntsloc        = 0
+      grid%ntsloc_domain = 0
+
+#ifdef DM_PARALLEL
+      CALL wrf_get_dm_communicator ( grid%communicator )
+      CALL wrf_dm_define_comms( grid )
+#endif
+
+   END SUBROUTINE alloc_and_configure_domain
+
+   SUBROUTINE get_fieldstr(ix,c,instr,outstr,noutstr,noerr)
+     IMPLICIT NONE
+     INTEGER, INTENT(IN)          :: ix
+     CHARACTER*(*), INTENT(IN)    :: c
+     CHARACTER*(*), INTENT(IN)    :: instr
+     CHARACTER*(*), INTENT(OUT)   :: outstr
+     INTEGER,       INTENT(IN)    :: noutstr  ! length of outstr
+     LOGICAL,       INTENT(INOUT) :: noerr     ! status
+     !local
+     INTEGER, PARAMETER :: MAX_DEXES = 100
+     INTEGER I, PREV, IDEX
+     INTEGER DEXES(MAX_DEXES)
+     outstr = ""
+     prev = 1
+     dexes(1) = 1
+     DO i = 2,MAX_DEXES
+       idex = INDEX(instr(prev:LEN(TRIM(instr))),c)
+       IF ( idex .GT. 0 ) THEN
+         dexes(i) = idex+prev
+         prev = dexes(i)+1
+       ELSE
+         dexes(i) = LEN(TRIM(instr))+2
+       ENDIF
+     ENDDO
+
+     IF     ( (dexes(ix+1)-2)-(dexes(ix)) .GT. noutstr ) THEN
+       noerr = .FALSE.  ! would overwrite
+     ELSE IF( dexes(ix) .EQ. dexes(ix+1) ) THEN 
+       noerr = .FALSE.  ! not found
+     ELSE
+       outstr = instr(dexes(ix):(dexes(ix+1)-2))
+       noerr = noerr .AND. .TRUE.
+     ENDIF
+   END SUBROUTINE get_fieldstr
+
+   SUBROUTINE change_to_lower_case(instr,outstr)
+     CHARACTER*(*) ,INTENT(IN)  :: instr
+     CHARACTER*(*) ,INTENT(OUT) :: outstr
+!Local
+     CHARACTER*1                :: c
+     INTEGER       ,PARAMETER   :: upper_to_lower =IACHAR('a')-IACHAR('A')
+     INTEGER                    :: i,n,n1
+!
+     outstr = ' '
+     N = len(instr)
+     N1 = len(outstr)
+     N = MIN(N,N1)
+     outstr(1:N) = instr(1:N)
+     DO i=1,N
+       c = instr(i:i)
+       if('A'<=c .and. c <='Z') outstr(i:i)=achar(iachar(c)+upper_to_lower)
+     ENDDO
+     RETURN
+   END SUBROUTINE change_to_lower_case
+
+!
+   SUBROUTINE modify_io_masks1 ( grid , id )
+      IMPLICIT NONE
+#include "streams.h"
+      INTEGER              , INTENT(IN  )  :: id
+      TYPE(domain), POINTER                :: grid
+      ! Local
+      TYPE(fieldlist), POINTER :: p, q
+      INTEGER, PARAMETER :: read_unit = 10
+      LOGICAL, EXTERNAL  :: wrf_dm_on_monitor
+      CHARACTER*256      :: fname, inln, mess, dname, t1, lookee
+      CHARACTER*256      :: fieldlst
+      CHARACTER*1        :: op, strmtyp
+      CHARACTER*3        :: strmid
+      CHARACTER*10       :: strmtyp_name
+      INTEGER            :: io_status
+      INTEGER            :: strmtyp_int, count_em
+      INTEGER            :: lineno, fieldno, istrm, retval, itrace
+      LOGICAL            :: keepgoing, noerr, gavewarning, ignorewarning, found
+      LOGICAL, SAVE      :: you_warned_me = .FALSE.
+      LOGICAL, SAVE      :: you_warned_me2(100,max_domains) = .FALSE.
+
+      gavewarning = .FALSE.
+
+      CALL nl_get_iofields_filename( id, fname )
+
+      IF ( grid%is_intermediate ) RETURN                ! short circuit
+      IF ( TRIM(fname) .EQ. "NONE_SPECIFIED" ) RETURN   ! short circuit
+
+      IF ( wrf_dm_on_monitor() ) THEN
+        OPEN ( UNIT   = read_unit    ,      &
+               FILE   = TRIM(fname)      ,      &
+               FORM   = "FORMATTED"      ,      &
+               STATUS = "OLD"            ,      &
+               IOSTAT = io_status         )
+        IF ( io_status .EQ. 0 ) THEN   ! only on success
+          keepgoing = .TRUE.
+          lineno = 0
+          count_em = 0    ! Count the total number of fields
+          DO WHILE ( keepgoing )
+            READ(UNIT=read_unit,FMT='(A)',IOSTAT=io_status) inln
+            keepgoing = (io_status .EQ. 0) .AND. (LEN(TRIM(inln)) .GT. 0)  
+            IF ( keepgoing ) THEN
+              lineno = lineno + 1
+              IF ( .NOT. LEN(TRIM(inln)) .LT. LEN(inln) ) THEN
+                WRITE(mess,*)'W A R N I N G : Line ',lineno,' of ',TRIM(fname),' is too long. Limit is ',LEN(inln),' characters.' 
+                gavewarning = .TRUE.
+              ENDIF
+              IF ( INDEX(inln,'#') .EQ. 0 ) THEN   ! skip comments, which is a # anywhere on line
+                IF ( keepgoing ) THEN
+                  noerr = .TRUE.
+                  CALL get_fieldstr(1,':',inln,op,1,noerr)          ! + is add, - is remove
+                  IF ( TRIM(op) .NE. '+' .AND. TRIM(op) .NE. '-' ) THEN
+                    WRITE(mess,*)'W A R N I N G : unknown operation ',TRIM(op),' (should be + or -). Line ',lineno
+                    gavewarning = .TRUE.
+                  ENDIF
+                  CALL get_fieldstr(2,':',inln,t1,1,noerr)          ! i is input, h is history
+                  CALL change_to_lower_case(t1,strmtyp) 
+
+                  SELECT CASE (TRIM(strmtyp))
+                  CASE ('h')
+                     strmtyp_name = 'history'
+                     strmtyp_int  = first_history
+                  CASE ('i')
+                     strmtyp_name = 'input'
+                     strmtyp_int  = first_input
+                  CASE DEFAULT
+                     WRITE(mess,*)'W A R N I N G : unknown stream type ',TRIM(strmtyp),'. Line ',lineno
+                     gavewarning = .TRUE.
+                  END SELECT
+
+                  CALL get_fieldstr(3,':',inln,strmid,3,noerr)      ! number of stream (main input and hist are 0)
+                  READ(strmid,'(I3)') istrm
+                  IF ( istrm .LT. 0 .OR. istrm .GT. last_history ) THEN
+                    WRITE(mess,*)'W A R N I N G : invalid stream id ',istrm,' (should be 0 <= id <= ',last_history,'). Line ',lineno
+                    gavewarning = .TRUE.
+                  ENDIF
+                  CALL get_fieldstr(4,':',inln,fieldlst,1024,noerr) ! get list of fields
+                  IF ( noerr ) THEN
+                    fieldno = 1
+                    CALL get_fieldstr(fieldno,',',fieldlst,t1,256,noerr)
+                    CALL change_to_lower_case(t1,lookee)
+                    DO WHILE ( noerr )    ! linear search, blargh...
+                      p => grid%head_statevars
+                      found = .FALSE.
+                      count_em = count_em + 1
+                      DO WHILE ( ASSOCIATED( p ) )
+  
+                        IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
+  
+                          DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+                            CALL change_to_lower_case( p%dname_table( grid%id, itrace ) , dname ) 
+
+                            IF ( TRIM(dname) .EQ. TRIM(lookee) ) &
+                            CALL warn_me_or_set_mask (id, istrm, lineno, strmtyp_int, count_em, op, &
+                                                      strmtyp_name, dname, fname, lookee,      &
+                                                      p%streams_table(grid%id,itrace)%stream,  &
+                                                      mess, found, you_warned_me2)
+                          ENDDO
+                        ELSE 
+                          IF ( p%Ntl .GT. 0 ) THEN
+                            CALL change_to_lower_case(p%DataName(1:LEN(TRIM(p%DataName))-2),dname)
+                          ELSE
+                            CALL change_to_lower_case(p%DataName,dname)
+                          ENDIF
+  
+                          IF ( TRIM(dname) .EQ. TRIM(lookee) ) &
+                          CALL warn_me_or_set_mask (id, istrm, lineno, strmtyp_int, count_em, op, &
+                                                    strmtyp_name, dname, fname, lookee,      &
+                                                    p%streams, mess, found, you_warned_me2)
+                        ENDIF
+                        p => p%next
+                      ENDDO
+                      IF ( .NOT. found ) THEN
+                        WRITE(mess,*)'W A R N I N G : Unable to modify mask for ',TRIM(lookee),&
+                                     '.  Variable not found. File: ',TRIM(fname),' at line ',lineno
+                        CALL wrf_message(mess)
+                        gavewarning = .TRUE.
+                      ENDIF
+                      fieldno = fieldno + 1
+                      CALL get_fieldstr(fieldno,',',fieldlst,t1,256,noerr)
+                      CALL change_to_lower_case(t1,lookee)
+                    ENDDO
+                  ELSE
+                    WRITE(mess,*)'W A R N I N G : Problem reading ',TRIM(fname),' at line ',lineno
+                    CALL wrf_message(mess)
+                    gavewarning = .TRUE.
+                  ENDIF
+                ENDIF  ! keepgoing
+              ENDIF    ! skip comments
+            ENDIF      ! keepgoing
+          ENDDO
+        ELSE
+          WRITE(mess,*)'W A R N I N G : Problem opening ',TRIM(fname)
+          CALL wrf_message(mess)
+          gavewarning = .TRUE.
+        ENDIF
+        CLOSE( read_unit )
+        IF ( gavewarning ) THEN
+          CALL nl_get_ignore_iofields_warning(1,ignorewarning)
+          IF ( .NOT. ignorewarning ) THEN
+            CALL wrf_message(mess)
+            WRITE(mess,*)'modify_io_masks: problems reading ',TRIM(fname) 
+            CALL wrf_message(mess)
+            CALL wrf_error_fatal('Set ignore_iofields_warn to true in namelist to ignore')
+          ELSE
+            IF ( .NOT. you_warned_me ) THEN
+              if ( .NOT. you_warned_me2(count_em,id) ) CALL wrf_message(mess)  ! Don't repeat the W A R N I N G message
+              WRITE(mess,*)'Ignoring problems reading ',TRIM(fname) 
+              CALL wrf_message(mess)
+              CALL wrf_message('Continuing.  To make this a fatal error, set ignore_iofields_warn to false in namelist' )
+              CALL wrf_message(' ')
+              you_warned_me = .TRUE.
+            ENDIF
+          ENDIF
+        ENDIF
+      ENDIF  ! wrf_dm_on_monitor
+
+#ifdef DM_PARALLEL
+! broadcast the new masks to the other tasks
+      p => grid%head_statevars
+      DO WHILE ( ASSOCIATED( p ) )
+        IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
+
+          DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
+            CALL wrf_dm_bcast_integer( p%streams_table(grid%id,itrace)%stream, IO_MASK_SIZE )
+          ENDDO
+
+        ELSE
+          CALL wrf_dm_bcast_integer( p%streams, IO_MASK_SIZE )
+        ENDIF
+        p => p%next
+      ENDDO
+#endif
+      
+   END SUBROUTINE modify_io_masks1
+
+   SUBROUTINE warn_me_or_set_mask (id, istrm, lineno, strmtyp_int, count_em, op, &
+                                   strmtyp_name, dname, fname, lookee,      &
+                                   p_stream, mess, found, you_warned_me2)
+
+      IMPLICIT NONE
+
+! See if a field that is requested to be added to or removed from the I/O stream
+!    is already present or absent
+! If the requested action has already been done, write a warning message
+! If not, satisfy the request
+
+     INTEGER,       INTENT(IN )   :: id, istrm, lineno, strmtyp_int
+     INTEGER,       INTENT(IN )   :: p_stream(*), count_em
+     CHARACTER*1,   INTENT(IN )   :: op
+     CHARACTER*10,  INTENT(IN )   :: strmtyp_name
+     CHARACTER*256, INTENT(IN )   :: dname, fname, lookee
+     CHARACTER*256, INTENT(OUT)   :: mess
+     LOGICAL,       INTENT(OUT)   :: found
+     LOGICAL,       INTENT(INOUT) :: you_warned_me2(100,max_domains)
+   ! Local
+     INTEGER                      :: retval
+
+     found = .TRUE.
+     IF      ( TRIM(op) .EQ. '+' ) THEN
+       CALL get_mask( p_stream, strmtyp_int + istrm - 1, retval )
+       IF ( retval .NE. 0 ) THEN
+         WRITE(mess,*) 'Domain ',id, ' W A R N I N G : Variable ',TRIM(lookee),' already on ', &
+                       TRIM(strmtyp_name), ' stream ',istrm, '.  File: ', TRIM(fname),' at line ',lineno
+       ELSE
+         WRITE(mess,*) 'Domain ', id, ' Setting ', TRIM(strmtyp_name), ' stream ',istrm,' for ', &
+                                  TRIM(DNAME)  ; CALL wrf_debug(1,mess)
+         CALL set_mask( p_stream, strmtyp_int + istrm - 1 )
+       ENDIF
+     ELSE IF ( TRIM(op) .EQ. '-' ) THEN
+       CALL get_mask( p_stream, strmtyp_int + istrm - 1, retval )
+       IF ( retval .EQ. 0 ) THEN
+         WRITE(mess,*) 'Domain ',id, ' W A R N I N G : Variable ',TRIM(lookee),' already off ', &
+                       TRIM(strmtyp_name), ' stream ',istrm, '. File: ',TRIM(fname),' at line ',lineno
+       ELSE
+         WRITE(mess,*) 'Domain ', id, ' Resetting ', TRIM(strmtyp_name), ' stream ',istrm,' for ', &
+                                    TRIM(DNAME)  ; CALL wrf_debug(1,mess) 
+         CALL reset_mask( p_stream, strmtyp_int + istrm - 1)
+       ENDIF
+     ENDIF
+     IF ( count_em > 100 ) THEN
+       WRITE(mess,*)'ERROR module_domain:  Array size for you_warned_me2 is fixed at 100'
+       CALL wrf_message(mess)
+       CALL wrf_error_fatal('Did you really type > 100 fields into '//TRIM(fname)//' ?')
+     ELSE
+       IF ( .NOT. you_warned_me2(count_em,id) ) THEN
+         CALL wrf_message(mess)     ! Write warning message once for each field
+         you_warned_me2(count_em,id) = .TRUE.
+       ENDIF
+     ENDIF
+
+   END SUBROUTINE warn_me_or_set_mask 
+
+!  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 , &
+                                  sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                  sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                  sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                  sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                  sm31y, em31y, sm32y, em32y, sm33y, em33y )
+
+      USE module_alloc_space_0, ONLY : alloc_space_field_core_0
+      USE module_alloc_space_1, ONLY : alloc_space_field_core_1
+      USE module_alloc_space_2, ONLY : alloc_space_field_core_2
+      USE module_alloc_space_3, ONLY : alloc_space_field_core_3
+      USE module_alloc_space_4, ONLY : alloc_space_field_core_4
+      USE module_alloc_space_5, ONLY : alloc_space_field_core_5
+      USE module_alloc_space_6, ONLY : alloc_space_field_core_6
+      USE module_alloc_space_7, ONLY : alloc_space_field_core_7
+      USE module_alloc_space_8, ONLY : alloc_space_field_core_8
+      USE module_alloc_space_9, ONLY : alloc_space_field_core_9
+
+      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)            :: sp31, ep31, sp32, ep32, sp33, ep33
+      INTEGER , INTENT(IN)            :: sp31x, ep31x, sp32x, ep32x, sp33x, ep33x
+      INTEGER , INTENT(IN)            :: sp31y, ep31y, sp32y, ep32y, sp33y, ep33y
+      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
+      INTEGER(KIND=8)  num_bytes_allocated
+      INTEGER  idum1, idum2
+
+#if (EM_CORE == 1)
+      IF ( grid%id .EQ. 1 ) CALL wrf_message ( &
+          'DYNAMICS OPTION: Eulerian Mass Coordinate ')
+#endif
+#if (NMM_CORE == 1)
+      IF ( grid%id .EQ. 1 ) &
+          CALL wrf_message ( 'DYNAMICS OPTION: nmm dyncore' )
+#endif
+#if (COAMPS_CORE == 1)
+        IF ( grid%id .EQ. 1 ) &
+          CALL wrf_message ( 'DYNAMICS OPTION: coamps dyncore' )
+#endif
+
+      CALL set_scalar_indices_from_config( id , idum1 , idum2 )
+
+      num_bytes_allocated = 0 
+
+      ! now separate modules to reduce the size of module_domain that the compiler sees
+      CALL alloc_space_field_core_0 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated , &
+                                    sd31, ed31, sd32, ed32, sd33, ed33, &
+                                    sm31 , em31 , sm32 , em32 , sm33 , em33 , &
+                                    sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                    sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                    sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                    sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                    sm31y, em31y, sm32y, em32y, sm33y, em33y )
+      CALL alloc_space_field_core_1 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
+                                    sd31, ed31, sd32, ed32, sd33, ed33, &
+                                    sm31 , em31 , sm32 , em32 , sm33 , em33 , &
+                                    sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                    sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                    sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                    sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                    sm31y, em31y, sm32y, em32y, sm33y, em33y )
+      CALL alloc_space_field_core_2 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
+                                    sd31, ed31, sd32, ed32, sd33, ed33, &
+                                    sm31 , em31 , sm32 , em32 , sm33 , em33 , &
+                                    sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                    sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                    sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                    sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                    sm31y, em31y, sm32y, em32y, sm33y, em33y )
+      CALL alloc_space_field_core_3 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
+                                    sd31, ed31, sd32, ed32, sd33, ed33, &
+                                    sm31 , em31 , sm32 , em32 , sm33 , em33 , &
+                                    sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                    sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                    sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                    sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                    sm31y, em31y, sm32y, em32y, sm33y, em33y )
+      CALL alloc_space_field_core_4 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
+                                    sd31, ed31, sd32, ed32, sd33, ed33, &
+                                    sm31 , em31 , sm32 , em32 , sm33 , em33 , &
+                                    sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                    sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                    sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                    sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                    sm31y, em31y, sm32y, em32y, sm33y, em33y )
+      CALL alloc_space_field_core_5 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
+                                    sd31, ed31, sd32, ed32, sd33, ed33, &
+                                    sm31 , em31 , sm32 , em32 , sm33 , em33 , &
+                                    sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                    sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                    sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                    sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                    sm31y, em31y, sm32y, em32y, sm33y, em33y )
+      CALL alloc_space_field_core_6 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
+                                    sd31, ed31, sd32, ed32, sd33, ed33, &
+                                    sm31 , em31 , sm32 , em32 , sm33 , em33 , &
+                                    sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                    sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                    sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                    sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                    sm31y, em31y, sm32y, em32y, sm33y, em33y )
+      CALL alloc_space_field_core_7 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
+                                    sd31, ed31, sd32, ed32, sd33, ed33, &
+                                    sm31 , em31 , sm32 , em32 , sm33 , em33 , &
+                                    sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                    sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                    sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                    sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                    sm31y, em31y, sm32y, em32y, sm33y, em33y )
+      CALL alloc_space_field_core_8 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
+                                    sd31, ed31, sd32, ed32, sd33, ed33, &
+                                    sm31 , em31 , sm32 , em32 , sm33 , em33 , &
+                                    sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                    sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                    sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                    sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                    sm31y, em31y, sm32y, em32y, sm33y, em33y )
+      CALL alloc_space_field_core_9 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
+                                    sd31, ed31, sd32, ed32, sd33, ed33, &
+                                    sm31 , em31 , sm32 , em32 , sm33 , em33 , &
+                                    sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                    sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                    sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                    sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                    sm31y, em31y, sm32y, em32y, sm33y, em33y )
+
+      IF ( .NOT. grid%have_displayed_alloc_stats ) THEN
+        ! we do not want to see this message more than once, as can happen with the allocation and
+        ! deallocation of intermediate domains used in nesting.
+        WRITE(wrf_err_message,*)&
+            'alloc_space_field: domain ',id,', ',num_bytes_allocated,' bytes allocated'
+        CALL  wrf_debug( 0, wrf_err_message )
+        grid%have_displayed_alloc_stats = .TRUE.   
+      ENDIF
+
+
+      grid%alloced_sd31=sd31
+      grid%alloced_ed31=ed31
+      grid%alloced_sd32=sd32
+      grid%alloced_ed32=ed32
+      grid%alloced_sd33=sd33
+      grid%alloced_ed33=ed33
+      grid%alloced_sm31=sm31
+      grid%alloced_em31=em31
+      grid%alloced_sm32=sm32
+      grid%alloced_em32=em32
+      grid%alloced_sm33=sm33
+      grid%alloced_em33=em33
+      grid%alloced_sm31x=sm31x
+      grid%alloced_em31x=em31x
+      grid%alloced_sm32x=sm32x
+      grid%alloced_em32x=em32x
+      grid%alloced_sm33x=sm33x
+      grid%alloced_em33x=em33x
+      grid%alloced_sm31y=sm31y
+      grid%alloced_em31y=em31y
+      grid%alloced_sm32y=sm32y
+      grid%alloced_em32y=em32y
+      grid%alloced_sm33y=sm33y
+      grid%alloced_em33y=em33y
+
+      grid%allocated=.TRUE.
+
+   END SUBROUTINE alloc_space_field
+
+   ! Ensure_space_field allocates a grid's arrays if they are not yet
+   ! allocated.  If they were already allocated, then it deallocates and
+   ! reallocates them if they were allocated with different dimensions.
+   ! If they were already allocated with the requested dimensions, then
+   ! ensure_space_field does nothing.
+
+   SUBROUTINE ensure_space_field ( grid,   id, setinitval_in ,  tl_in , inter_domain_in ,   &
+                                  sd31, ed31, sd32, ed32, sd33, ed33, &
+                                  sm31 , em31 , sm32 , em32 , sm33 , em33 , &
+                                  sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                  sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                  sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                  sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                  sm31y, em31y, sm32y, em32y, sm33y, em33y )
+
+      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)            :: sp31, ep31, sp32, ep32, sp33, ep33
+      INTEGER , INTENT(IN)            :: sp31x, ep31x, sp32x, ep32x, sp33x, ep33x
+      INTEGER , INTENT(IN)            :: sp31y, ep31y, sp32y, ep32y, sp33y, ep33y
+      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
+      LOGICAL                         :: size_changed
+
+      size_changed=         .not. ( &
+         grid%alloced_sd31 .eq. sd31 .and. grid%alloced_ed31 .eq. ed31 .and. &
+         grid%alloced_sd32 .eq. sd32 .and. grid%alloced_ed32 .eq. ed32 .and. &
+         grid%alloced_sd33 .eq. sd33 .and. grid%alloced_ed33 .eq. ed33 .and. &
+         grid%alloced_sm31 .eq. sm31 .and. grid%alloced_em31 .eq. em31 .and. &
+         grid%alloced_sm32 .eq. sm32 .and. grid%alloced_em32 .eq. em32 .and. &
+         grid%alloced_sm33 .eq. sm33 .and. grid%alloced_em33 .eq. em33 .and. &
+         grid%alloced_sm31x .eq. sm31x .and. grid%alloced_em31x .eq. em31x .and. &
+         grid%alloced_sm32x .eq. sm32x .and. grid%alloced_em32x .eq. em32x .and. &
+         grid%alloced_sm33x .eq. sm33x .and. grid%alloced_em33x .eq. em33x .and. &
+         grid%alloced_sm31y .eq. sm31y .and. grid%alloced_em31y .eq. em31y .and. &
+         grid%alloced_sm32y .eq. sm32y .and. grid%alloced_em32y .eq. em32y .and. &
+         grid%alloced_sm33y .eq. sm33y .and. grid%alloced_em33y .eq. em33y &
+      )
+      if(.not. grid%allocated .or. size_changed) then
+         if(.not. grid%allocated) then
+            call wrf_debug(1,'ensure_space_field: calling alloc_space_field because a grid was not allocated.')
+         else
+            if(size_changed) &
+                 call wrf_debug(1,'ensure_space_field: deallocating and reallocating a grid because grid size changed.')
+         end if
+         if(grid%allocated) &
+              call dealloc_space_field( grid )
+         call alloc_space_field ( grid,   id, setinitval_in ,  tl_in , inter_domain_in ,   &
+                                  sd31, ed31, sd32, ed32, sd33, ed33, &
+                                  sm31 , em31 , sm32 , em32 , sm33 , em33 , &
+                                  sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
+                                  sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
+                                  sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
+                                  sm31x, em31x, sm32x, em32x, sm33x, em33x, &
+                                  sm31y, em31y, sm32y, em32y, sm33y, em33y )
+      end if
+
+   END SUBROUTINE ensure_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 )
+      CALL dealloc_linked_lists( 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
+      IF ( ASSOCIATED( grid%itsloc ) ) THEN
+        DEALLOCATE( grid%itsloc )
+      ENDIF 
+      IF ( ASSOCIATED( grid%jtsloc ) ) THEN
+        DEALLOCATE( grid%jtsloc )
+      ENDIF 
+      IF ( ASSOCIATED( grid%id_tsloc ) ) THEN
+        DEALLOCATE( grid%id_tsloc )
+      ENDIF 
+      IF ( ASSOCIATED( grid%lattsloc ) ) THEN
+        DEALLOCATE( grid%lattsloc )
+      ENDIF 
+      IF ( ASSOCIATED( grid%lontsloc ) ) THEN
+        DEALLOCATE( grid%lontsloc )
+      ENDIF 
+      IF ( ASSOCIATED( grid%nametsloc ) ) THEN
+        DEALLOCATE( grid%nametsloc )
+      ENDIF 
+      IF ( ASSOCIATED( grid%desctsloc ) ) THEN
+        DEALLOCATE( grid%desctsloc )
+      ENDIF 
+      IF ( ASSOCIATED( grid%ts_filename ) ) THEN
+        DEALLOCATE( grid%ts_filename )
+      ENDIF 
+      DEALLOCATE( grid )
+      NULLIFY( grid )
+
+   END SUBROUTINE domain_destroy
+
+   SUBROUTINE dealloc_linked_lists ( grid )
+      IMPLICIT NONE
+      TYPE(domain), POINTER :: grid
+      TYPE(fieldlist), POINTER :: p, q
+      p => grid%head_statevars
+      DO WHILE ( ASSOCIATED( p%next ) )
+         q => p ; p => p%next ; DEALLOCATE(q)
+      ENDDO
+      NULLIFY(grid%head_statevars) ; NULLIFY( grid%tail_statevars)
+      IF ( .NOT. grid%is_intermediate ) THEN
+        ALLOCATE( grid%head_statevars )
+        NULLIFY( grid%head_statevars%next)
+        grid%tail_statevars => grid%head_statevars
+      ENDIF
+   END SUBROUTINE dealloc_linked_lists
+
+   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                             ::  ierr
+
+# include <deallocs.inc>
+
+   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
+! <DESCRIPTION>
+! This is a recursive subroutine that traverses the domain hierarchy rooted
+! at the input argument <em>in_grid</em>, a pointer to TYPE(domain), and returns
+! a pointer to the domain matching the integer argument <em>id</em> if it exists.
+!
+! </DESCRIPTION>
+      TYPE(domain), POINTER     :: grid_ptr
+      INTEGER                   :: kid
+      LOGICAL                   :: found
+      found = .FALSE.
+      NULLIFY(result_grid)
+      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
+
+!<DESCRIPTION>
+!  This routine is used to find a specific domain identifier in an array
+!  of domain identifiers.
+!
+!</DESCRIPTION>
+      
+      !  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
+
+
+! <DESCRIPTION>
+!
+! 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).  
+!
+! </DESCRIPTION>
+
+      FUNCTION domain_get_current_time ( grid ) RESULT ( current_time ) 
+        IMPLICIT NONE
+! <DESCRIPTION>
+! This convenience function returns the current time for domain grid.  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! This convenience function returns the start time for domain grid.  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! This convenience function returns the stop time for domain grid.  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! This convenience function returns the time step for domain grid.  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! This convenience function returns the time step for domain grid.  
+! Also converts from INTEGER(WRFU_KIND_I8) to INTEGER.  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! This convenience routine destroys and deallocates all alarms associated 
+! with grid.  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! This convenience routine destroys and deallocates the domain clock.  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! This convenience function returns .TRUE. if this is the last time 
+! step for domain grid.  Thanks to Tom Black.  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! This convenience function returns .TRUE. iff grid%clock has reached its 
+! stop time.  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! This convenience function returns .TRUE. iff grid%clock has reached its 
+! grid%stop_subtime.  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! 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).  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! 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).  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! 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.  
+!
+! </DESCRIPTION>
+        ! 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
+! <DESCRIPTION>
+! This convenience function returns .TRUE. iff grid%clock is at its 
+! start time.  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! This convenience function returns .TRUE. iff grid%clock is at the 
+! simulation start time.  (It returns .FALSE. during a restart run.)  
+!
+! </DESCRIPTION>
+        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
+! <DESCRIPTION>
+! This convenience routine creates the domain_clock for domain grid and 
+! sets associated flags.  
+!
+! </DESCRIPTION>
+        ! 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
+! <DESCRIPTION>
+! This convenience routine creates alarm alarm_id for domain grid and 
+! sets associated flags.  
+!
+! </DESCRIPTION>
+        ! 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
+        CALL WRFU_AlarmRingerOff( grid%alarms( alarm_id ) , rc=rc )
+        IF ( rc /= WRFU_SUCCESS ) THEN
+          CALL wrf_error_fatal ( &
+            'domain_alarm_create:  WRFU_AlarmRingerOff() 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
+! <DESCRIPTION>
+! This convenience routine sets clock information for domain grid.  
+! The caller is responsible for ensuring that character string actual 
+! arguments are big enough.  
+!
+! </DESCRIPTION>
+        ! 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<NN>" where "<NN>" 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
+
+
+! moved these outside module domain to avoid circular reference from module_alloc_space which also uses
+
+   SUBROUTINE get_ijk_from_grid_ext (  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 )
+    USE module_domain
+    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_grid_ext
+
+! 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_ext (  grid ,                &
+                           ids0, ide0, jds0, jde0, kds0, kde0,    &
+                           ims0, ime0, jms0, jme0, kms0, kme0,    &
+                           ips0, ipe0, jps0, jpe0, kps0, kpe0    )
+    USE module_domain
+    IMPLICIT NONE
+    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_ext
+
+! find the grid based on the id reference and return that
+   SUBROUTINE get_dims_from_grid_id (  id   &
+                          ,ds, de           &
+                          ,ms, me           &
+                          ,ps, pe           &
+                          ,mxs, mxe         &
+                          ,pxs, pxe         &
+                          ,mys, mye         &
+                          ,pys, pye )
+    USE module_domain, ONLY : domain, head_grid, find_grid_by_id
+    IMPLICIT NONE
+    TYPE( domain ), POINTER  :: grid
+    INTEGER, INTENT(IN ) :: id
+    INTEGER, DIMENSION(3), INTENT(INOUT) ::                   &
+                           ds, de           &
+                          ,ms, me           &
+                          ,ps, pe           &
+                          ,mxs, mxe         &
+                          ,pxs, pxe         &
+                          ,mys, mye         &
+                          ,pys, pye
+
+     !local
+     CHARACTER*256 mess
+
+     NULLIFY( grid )
+     CALL find_grid_by_id ( id, head_grid, grid )
+
+     IF ( ASSOCIATED(grid) ) THEN
+           ds(1) = grid%sd31 ; de(1) = grid%ed31 ; ds(2) = grid%sd32 ; de(2) = grid%ed32 ; ds(3) = grid%sd33 ; de(3) = grid%ed33 ;
+           ms(1) = grid%sm31 ; me(1) = grid%em31 ; ms(2) = grid%sm32 ; me(2) = grid%em32 ; ms(3) = grid%sm33 ; me(3) = grid%em33 ;
+           ps(1) = grid%sp31 ; pe(1) = grid%ep31 ; ps(2) = grid%sp32 ; pe(2) = grid%ep32 ; ps(3) = grid%sp33 ; pe(3) = grid%ep33 ;
+           mxs(1) = grid%sm31x ; mxe(1) = grid%em31x ; mxs(2) = grid%sm32x ; mxe(2) = grid%em32x ; mxs(3) = grid%sm33x ; mxe(3) = grid%em33x ;
+           pxs(1) = grid%sp31x ; pxe(1) = grid%ep31x ; pxs(2) = grid%sp32x ; pxe(2) = grid%ep32x ; pxs(3) = grid%sp33x ; pxe(3) = grid%ep33x ;
+           mys(1) = grid%sm31y ; mye(1) = grid%em31y ; mys(2) = grid%sm32y ; mye(2) = grid%em32y ; mys(3) = grid%sm33y ; mye(3) = grid%em33y ;
+           pys(1) = grid%sp31y ; pye(1) = grid%ep31y ; pys(2) = grid%sp32y ; pye(2) = grid%ep32y ; pys(3) = grid%sp33y ; pye(3) = grid%ep33y ;
+     ELSE
+        WRITE(mess,*)'internal error: get_ijk_from_grid_id: no such grid id:',id
+        CALL wrf_error_fatal(TRIM(mess))
+     ENDIF
+
+   END SUBROUTINE get_dims_from_grid_id
+
+! find the grid based on the id reference and return that
+   SUBROUTINE get_ijk_from_grid_id (  id ,                   &
+                           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 )
+    USE module_domain, ONLY : domain, head_grid, find_grid_by_id, get_ijk_from_grid
+    IMPLICIT NONE
+    TYPE( domain ), POINTER  :: grid
+    INTEGER, INTENT(IN ) :: id
+    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
+     !local
+     CHARACTER*256 mess
+
+     NULLIFY( grid )
+     CALL find_grid_by_id ( id, head_grid, grid )
+
+     IF ( ASSOCIATED(grid) ) THEN
+     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 )
+     ELSE
+        WRITE(mess,*)'internal error: get_ijk_from_grid_id: no such grid id:',id
+        CALL wrf_error_fatal(TRIM(mess))
+     ENDIF
+
+   END SUBROUTINE get_ijk_from_grid_id
+
+! version of this routine that can be called from set_scalar_indices_from_config in
+! module_configure, which can not USE module_domain without creating a circular use assocaition
+   SUBROUTINE modify_io_masks ( id )
+     USE module_domain, ONLY : domain, modify_io_masks1, head_grid, find_grid_by_id
+     IMPLICIT NONE
+     INTEGER, INTENT(IN) :: id
+     TYPE(domain), POINTER :: grid
+!write(0,*)'modify_io_masks head_grid ',id,ASSOCIATED(head_grid)
+     CALL find_grid_by_id( id, head_grid, grid )
+!write(0,*)'modify_io_masks grid ',id,ASSOCIATED(grid)
+     IF ( ASSOCIATED( grid ) ) CALL modify_io_masks1( grid, id ) 
+     RETURN 
+   END SUBROUTINE modify_io_masks
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_domain_type.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_domain_type.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_domain_type.F	(revision 17)
@@ -0,0 +1,225 @@
+!WRF:DRIVER_LAYER:DOMAIN_OBJECT
+MODULE module_domain_type
+
+   USE module_driver_constants
+   USE module_utility
+   USE module_streams
+
+   IMPLICIT NONE
+
+! needed to provide static definition of IO_MASK_SIZE
+#include "../inc/streams.h"
+
+   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 streamrec
+     INTEGER  ::  stream(IO_MASK_SIZE)
+   END TYPE streamrec
+
+   TYPE domain_ptr
+      TYPE(domain), POINTER :: ptr
+   END TYPE domain_ptr
+
+   TYPE fieldlist
+      CHARACTER*80    :: VarName
+      CHARACTER*1     :: Type
+      CHARACTER*1     :: ProcOrient  ! 'X' 'Y' or ' ' (X, Y, or non-transposed)
+      CHARACTER*80    :: DataName
+      CHARACTER*80    :: Description
+      CHARACTER*80    :: Units
+      CHARACTER*10    :: MemoryOrder
+      CHARACTER*10    :: Stagger
+      CHARACTER*80    :: dimname1
+      CHARACTER*80    :: dimname2
+      CHARACTER*80    :: dimname3
+      LOGICAL         :: scalar_array
+      LOGICAL         :: boundary_array
+      LOGICAL         :: restart
+   ! definition of IO_MASK_SIZE comes from build and must be the same as
+   ! in both definitions of GET_MASK (frame/pack_utils.c and tools/misc.c)
+      INTEGER, DIMENSION(IO_MASK_SIZE) :: streams
+      INTEGER :: sd1,ed1,sd2,ed2,sd3,ed3
+      INTEGER :: sm1,em1,sm2,em2,sm3,em3
+      INTEGER :: sp1,ep1,sp2,ep2,sp3,ep3
+      CHARACTER*80    :: MemberOf   ! only for 4+D tracer arrays
+      INTEGER :: Ndim
+      INTEGER :: Ntl                ! 0 single; 1, 2, ... if multi
+      LOGICAL                                             :: subgrid_x, subgrid_y  ! true if has a subgrid dimension
+
+      INTEGER, POINTER :: num_table(:)
+      INTEGER, POINTER :: index_table(:,:)
+      LOGICAL, POINTER :: boundary_table(:,:)
+      CHARACTER*256, POINTER :: dname_table(:,:)
+      CHARACTER*256, POINTER :: desc_table(:,:)
+      CHARACTER*256, POINTER :: units_table(:,:)
+      TYPE(streamrec), POINTER :: streams_table(:,:)
+
+      TYPE ( fieldlist ) , POINTER :: next
+
+      REAL, POINTER                                       :: rfield_0d
+      REAL, POINTER, DIMENSION(:)                         :: rfield_1d
+      REAL, POINTER, DIMENSION(:,:)                       :: rfield_2d
+      REAL, POINTER, DIMENSION(:,:,:)                     :: rfield_3d
+      REAL, POINTER, DIMENSION(:,:,:,:)                   :: rfield_4d
+      REAL, POINTER, DIMENSION(:,:,:,:,:)                 :: rfield_5d
+      REAL, POINTER, DIMENSION(:,:,:,:,:,:)               :: rfield_6d
+      REAL, POINTER, DIMENSION(:,:,:,:,:,:,:)             :: rfield_7d
+
+      DOUBLE PRECISION, POINTER                           :: dfield_0d
+      DOUBLE PRECISION, POINTER, DIMENSION(:)             :: dfield_1d
+      DOUBLE PRECISION, POINTER, DIMENSION(:,:)           :: dfield_2d
+      DOUBLE PRECISION, POINTER, DIMENSION(:,:,:)         :: dfield_3d
+      DOUBLE PRECISION, POINTER, DIMENSION(:,:,:,:)       :: dfield_4d
+      DOUBLE PRECISION, POINTER, DIMENSION(:,:,:,:,:)     :: dfield_5d
+      DOUBLE PRECISION, POINTER, DIMENSION(:,:,:,:,:,:)   :: dfield_6d
+      DOUBLE PRECISION, POINTER, DIMENSION(:,:,:,:,:,:,:) :: dfield_7d
+
+      INTEGER, POINTER                                    :: ifield_0d
+      INTEGER, POINTER, DIMENSION(:)                      :: ifield_1d
+      INTEGER, POINTER, DIMENSION(:,:)                    :: ifield_2d
+      INTEGER, POINTER, DIMENSION(:,:,:)                  :: ifield_3d
+      INTEGER, POINTER, DIMENSION(:,:,:,:)                :: ifield_4d
+      INTEGER, POINTER, DIMENSION(:,:,:,:,:)              :: ifield_5d
+      INTEGER, POINTER, DIMENSION(:,:,:,:,:,:)            :: ifield_6d
+      INTEGER, POINTER, DIMENSION(:,:,:,:,:,:,:)          :: ifield_7d
+
+      LOGICAL, POINTER                                    :: lfield_0d
+      LOGICAL, POINTER, DIMENSION(:)                      :: lfield_1d
+      LOGICAL, POINTER, DIMENSION(:,:)                    :: lfield_2d
+! save some space; you can still have these but will not be part of list
+! so cannot do i/o, etc on 3d or greater logical arrays
+!      LOGICAL, POINTER, DIMENSION(:,:,:)                  :: lfield_3d
+!      LOGICAL, POINTER, DIMENSION(:,:,:,:)                :: lfield_4d
+!      LOGICAL, POINTER, DIMENSION(:,:,:,:,:)              :: lfield_5d
+!      LOGICAL, POINTER, DIMENSION(:,:,:,:,:,:)            :: lfield_6d
+!      LOGICAL, POINTER, DIMENSION(:,:,:,:,:,:,:)          :: lfield_7d
+
+   END TYPE fieldlist
+
+#include <state_subtypes.inc>
+
+   TYPE domain
+
+      TYPE ( fieldlist ), POINTER :: head_statevars
+      TYPE ( fieldlist ), POINTER :: tail_statevars
+
+! SEE THE INCLUDE FILE FOR DEFINITIONS OF STATE FIELDS WITHIN THE DOMAIN DATA STRUCTURE
+#include <state_struct.inc>
+
+      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
+      LOGICAL                                             :: allocated        ! has alloc_space_field been called on this domain?
+      TYPE(domain) , POINTER                              :: intermediate_grid
+      LOGICAL                                             :: is_intermediate
+      INTEGER :: nids, nide, njds, njde  ! for intermediate domains, carry around the nest dimensions 
+      INTEGER                                             :: num_parents, num_nests, num_siblings
+      INTEGER      , DIMENSION( max_parents )             :: child_of_parent
+      INTEGER      , DIMENSION( max_nests )               :: active
+
+      INTEGER      , DIMENSION(MAX_STREAMS)               :: nframes          ! frames per outfile for history 
+                                                                              ! 1 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
+
+      ! currently allocated domain dimesions
+      INTEGER    :: alloced_sd31, alloced_ed31, &
+                    alloced_sd32, alloced_ed32, &
+                    alloced_sd33, alloced_ed33, &
+                    alloced_sm31, alloced_em31, &
+                    alloced_sm32, alloced_em32, &
+                    alloced_sm33, alloced_em33, &
+                    alloced_sm31x, alloced_em31x, &
+                    alloced_sm32x, alloced_em32x, &
+                    alloced_sm33x, alloced_em33x, &
+                    alloced_sm31y, alloced_em31y, &
+                    alloced_sm32y, alloced_em32y, &
+                    alloced_sm33y, alloced_em33y
+
+      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
+!
+! The following are used by the adaptive time step
+! T. Hutchinson, WSI  1/11/07
+!
+      REAL :: max_cfl_val
+      REAL :: last_max_vert_cfl
+      REAL :: last_max_horiz_cfl
+      REAL :: max_vert_cfl
+      REAL :: max_horiz_cfl
+      Type(WRFU_TimeInterval) :: last_dtInterval
+
+      ! Time series location information
+      INTEGER :: ntsloc, ntsloc_domain
+      INTEGER :: next_ts_time
+      INTEGER, POINTER, DIMENSION(:) :: itsloc, jtsloc, id_tsloc
+      REAL, POINTER, DIMENSION(:) :: lattsloc, lontsloc
+      CHARACTER (LEN=5), POINTER, DIMENSION(:) :: nametsloc
+      CHARACTER (LEN=25), POINTER, DIMENSION(:) :: desctsloc
+      CHARACTER (LEN=256), POINTER, DIMENSION(:) :: ts_filename
+      LOGICAL :: have_calculated_tslocs
+      LOGICAL :: have_displayed_alloc_stats   ! used in module_alloc_space to display alloc stats; only do it once.
+
+   END TYPE domain
+END MODULE module_domain_type
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_driver_constants.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_driver_constants.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_driver_constants.F	(revision 17)
@@ -0,0 +1,140 @@
+!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 <model_data_order.inc>
+
+   !  1. Following are constants for use in defining maximal values for array
+   !     definitions.  
+   !
+
+   !  The maximum number of levels in the model is how deeply the domains may
+   !  be nested.
+
+   INTEGER , PARAMETER :: max_levels      =  20
+
+   !  The maximum number of nests that can depend on a single parent and other way round
+
+   INTEGER , PARAMETER :: max_nests        =  20
+
+   !  The maximum number of parents that a nest can have (simplified assumption -> one only)
+
+   INTEGER , PARAMETER :: max_parents      =  1
+
+   !  The maximum number of domains is how many grids the model will be running.
+
+   INTEGER , PARAMETER :: max_domains     =   ( MAX_DOMAINS_F - 1 ) / 2 + 1
+
+   !  The maximum number of nest move specifications allowed in a namelist
+
+   INTEGER , PARAMETER :: max_moves       =   50
+
+   !  The maximum number of eta levels
+
+   INTEGER , PARAMETER :: max_eta         =   501
+
+   !  The maximum number of outer iterations (for DA minimisation)
+
+   INTEGER , PARAMETER :: max_outer_iterations = 10
+
+   !  The maximum number of instruments (for radiance DA)
+
+   INTEGER , PARAMETER :: max_instruments =   30
+
+   !  The maximum number of bogus storms
+
+   INTEGER , PARAMETER :: max_bogus =  5
+
+   !  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
+
+   !  4. Unfortunately, the following definition is needed here (rather
+   !     than the more logical place in share/module_model_constants.F)
+   !     for the namelist reads in frame/module_configure.F, and for some
+   !     conversions in share/set_timekeeping.F
+   !     Actually, using it here will mean that we don't need to set it
+   !     in share/module_model_constants.F, since this file will be
+   !     included (USEd) in:
+   !        frame/module_configure.F
+   !     which will be USEd in:
+   !        share/module_bc.F
+   !     which will be USEd in:
+   !        phys/module_radiation_driver.F
+   !     which is the other important place for it to be, and where
+   !     it is passed as a subroutine parameter to any physics subroutine.
+   !
+   !     P2SI is the number of SI seconds in an planetary solar day
+   !     divided by the number of SI seconds in an earth solar day
+#if defined MARS
+   !     For Mars, P2SI = 88775.2/86400.
+   REAL , PARAMETER :: P2SI = 1.0274907
+#elif defined TITAN
+   !     For Titan, P2SI = 1378080.0/86400.
+   REAL , PARAMETER :: P2SI = 15.95
+#else
+   !     Default for Earth
+   REAL , PARAMETER :: P2SI = 1.0
+#endif
+ CONTAINS
+   SUBROUTINE init_module_driver_constants
+   END SUBROUTINE init_module_driver_constants
+ END MODULE module_driver_constants
+
+! routines that external packages can call to get at WRF stuff that isn't available
+! through argument lists; since they are external we don't want them using WRF 
+! modules unnecessarily (complicates the build even more)
+ SUBROUTINE inquire_of_wrf_data_order_xyz( data_order )
+   USE module_driver_constants, ONLY : DATA_ORDER_XYZ
+   IMPLICIT NONE
+   INTEGER, INTENT(OUT) :: data_order
+   data_order = DATA_ORDER_XYZ
+ END SUBROUTINE inquire_of_wrf_data_order_xyz
+
+ SUBROUTINE inquire_of_wrf_data_order_xzy( data_order )
+   USE module_driver_constants, ONLY : DATA_ORDER_XZY
+   IMPLICIT NONE
+   INTEGER, INTENT(OUT) :: data_order
+   data_order = DATA_ORDER_XZY
+ END SUBROUTINE inquire_of_wrf_data_order_xzy
+
+ SUBROUTINE inquire_of_wrf_iwordsize( iwordsz )
+   IMPLICIT NONE
+   INTEGER, INTENT(OUT) :: iwordsz
+   iwordsz = IWORDSIZE
+ END SUBROUTINE inquire_of_wrf_iwordsize
+
+ SUBROUTINE inquire_of_wrf_rwordsize( rwordsz )
+   IMPLICIT NONE
+   INTEGER, INTENT(OUT) :: rwordsz
+   rwordsz = RWORDSIZE
+ END SUBROUTINE inquire_of_wrf_rwordsize
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_integrate.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_integrate.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_integrate.F	(revision 17)
@@ -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
+! <DESCRIPTION> 
+! 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
+! <em>grid</em> 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
+! (<a href="setup_timekeeping.html">setup_timekeeping</a>) 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. <a href=model_to_grid_config_rec.html>Model_to_grid_config_rec</a> 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 <a href=med_setup_step.html>med_setup_step</a> 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 <a href=nests_to_open.html>nests_to_open</a> (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 <a href=alloc_and_configure_domain.html>alloc_and_configure_domain</a> to allocate
+! the new nest and link it as a child of this grid.
+! 
+! 4.c.2  Call <a href=setup_Timekeeping.html>setup_Timekeeping</a> for the nest.
+! 
+! 4.c.3  Initialize the nest's arrays by calling <a href=med_nest_initial.html>med_nest_initial</a>. 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 <a href=med_before_solve_io.html>med_before_solve_io</a>. In WRF this is the point at which history and
+! restart data is output.
+! 
+! 4.f  Call <a href=solve_interface.html>solve_interface</a> 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 (<tt>DO kid = 1, max_nests</tt>) 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 <a href=med_nest_force.html>med_nest_force</a>.
+! 
+! 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 <a href=med_nest_feedback.html>med_nest_feedback</a>.
+! 
+! 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 <a href=med_last_solve_io.html>med_last_solve_io</a>.  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.
+! </DESCRIPTION>
+
+   !  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
+
+     SUBROUTINE dfi_accumulate( 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.  
+   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 ( config_flags%grid_allowed ) THEN
+         CALL domain_clockprint ( 150, grid, 'DEBUG:  top of integrate(),' )
+         DO WHILE ( .NOT. domain_clockisstopsubtime(grid) )
+            IF ( wrf_dm_on_monitor() ) THEN
+               CALL start_timing
+            END IF
+            CALL med_setup_step ( grid , config_flags )
+            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 )
+               IF ( grid%dfi_stage == DFI_STARTFWD ) THEN
+                  CALL wrf_dfi_startfwd_init(new_nest)
+               ENDIF
+            END DO
+            IF ( a_nest_was_opened ) THEN
+               CALL set_overlaps ( grid )   ! find overlapping and set pointers
+            END IF
+
+            ! Accumulation calculation for DFI
+            CALL dfi_accumulate ( grid )
+
+            CALL med_before_solve_io ( grid , config_flags )
+            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
+               CALL domain_clock_get ( grid, current_timestr=message2 )
+#if (EM_CORE == 1)
+               if (config_flags%use_adaptive_time_step) then
+                  WRITE ( message , FMT = '("main (dt=",F6.2,"): time ",A," on domain ",I3)' ) grid%dt, TRIM(message2), grid%id
+               else
+                  WRITE ( message , FMT = '("main: time ",A," on domain ",I3)' ) TRIM(message2), grid%id
+               endif
+#else
+                  WRITE ( message , FMT = '("main: time ",A," on domain ",I3)' ) TRIM(message2), grid%id
+#endif
+               CALL end_timing ( TRIM(message) )
+            END IF
+            CALL med_endup_step ( grid , config_flags )
+         END DO
+
+         ! Accumulation calculation for DFI
+         CALL dfi_accumulate ( grid )
+
+         ! 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
+      ENDIF
+   END IF
+   
+END SUBROUTINE integrate
+
+END MODULE module_integrate
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_internal_header_util.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_internal_header_util.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_internal_header_util.F	(revision 17)
@@ -0,0 +1,1170 @@
+MODULE module_internal_header_util
+
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!
+!</PRE>
+!</DESCRIPTION>
+
+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 )
+!<DESCRIPTION>
+!<PRE>
+! 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".  
+!
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! See documentation block in int_gen_write_field_header() for 
+! a description of a "write field" header.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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".  
+!
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! See documentation block in int_gen_ofr_header() for 
+! a description of a "open for read" header.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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".  
+!
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! See documentation block in int_gen_ofwb_header() for 
+! a description of a "open for write begin" header.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! See documentation block in int_gen_handle_header() for 
+! a description of a "generic handle" header.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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".  
+!
+!</PRE>
+!</DESCRIPTION>
+  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_integer_varname( hdrbuf, hdrbufsize, itypesize, typesize, &
+                                      DataHandle, Element, VarName, Data, Count, code )
+!<DESCRIPTION>
+!<PRE>
+! 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
+!  hdrbuf(8+n1+n2) = LEN(TRIM(VarName)) = n3
+!  hderbuf(9+n1+n2:8+n1+n2+n3) = TRIM(VarName)
+!
+! 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.
+!  VarName:     Variable name.  Used for *_<get|put>_var_ti_char but not for
+!               *_<get|put>_dom_ti_char.
+!  Other items are described in detail in the "WRF I/O and Model Coupling API
+!  Specification".
+!
+!</PRE>
+!</DESCRIPTION>
+  IMPLICIT NONE
+#include "intio_tags.h"
+  INTEGER, INTENT(INOUT)       ::  hdrbuf(*)
+  INTEGER, INTENT(OUT)         ::  hdrbufsize
+  INTEGER, INTENT(IN)          ::  itypesize, typesize
+  CHARACTER*(*), INTENT(IN)    ::  Element, VarName
+  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
+  CALL int_pack_string ( VarName, hdrbuf( i ), n ) ; i = i + n
+  hdrbufsize = i * itypesize + hdrbufsize ! return the number in bytes
+  hdrbuf(1) = hdrbufsize
+  RETURN
+END SUBROUTINE int_gen_ti_header_integer_varname
+
+SUBROUTINE int_gen_ti_header_real( hdrbuf, hdrbufsize, itypesize, typesize, &
+                                   DataHandle, Element, Data, Count, code )
+!<DESCRIPTION>
+!<PRE>
+! Same as int_gen_ti_header_integer except that Data has type REAL.  
+!</PRE>
+!</DESCRIPTION>
+  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_varname( hdrbuf, hdrbufsize, itypesize, typesize, &
+                              DataHandle, Element, VarName, Data, Count, code)
+!<DESCRIPTION>
+!<PRE>
+! Same as int_gen_ti_header_integer except that Data is read from
+! the file.
+!</PRE>
+!</DESCRIPTION>
+  IMPLICIT NONE
+#include "intio_tags.h"
+  INTEGER, INTENT(INOUT)       ::  hdrbuf(*)
+  INTEGER, INTENT(OUT)         ::  hdrbufsize
+  INTEGER, INTENT(IN)          ::  itypesize, typesize
+  CHARACTER*(*), INTENT(INOUT) ::  Element, VarName
+  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 ( Element, hdrbuf( i ), n ) ; i=i+n;
+  CALL int_unpack_string ( VarName, hdrbuf( i ), n ) ; i = i + n
+!  write(0,*)'int_get_ti_header_integer_varname "', &
+!       TRIM(Element),'" "', TRIM(VarName),'" data(1)=',Data(1)
+  hdrbufsize = hdrbuf(1)
+  RETURN
+END SUBROUTINE int_get_ti_header_integer_varname
+
+SUBROUTINE int_get_ti_header_integer( hdrbuf, hdrbufsize, itypesize, typesize, &
+                              DataHandle, Element, Data, Count, code )
+!<DESCRIPTION>
+!<PRE>
+! Same as int_gen_ti_header_integer except that Data is read from 
+! the file.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Same as int_gen_ti_header_real except that Data is read from 
+! the file.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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 *_<get|put>_var_ti_char but not for 
+!               *_<get|put>_dom_ti_char.  
+!  Other items are described in detail in the "WRF I/O and Model Coupling API 
+!  Specification".  
+!
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Same as int_gen_ti_header_char except that Data is read from 
+! the file.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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".  
+!
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Same as int_gen_td_header_char except that Data is read from 
+! the file.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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".  
+!
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Same as int_gen_td_header_integer except that Data has type REAL.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Same as int_gen_td_header_integer except that Data is read from 
+! the file.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Same as int_gen_td_header_real except that Data is read from 
+! the file.  
+!</PRE>
+!</DESCRIPTION>
+  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
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!
+!</PRE>
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+!<PRE>
+! See documentation block in int_gen_noop_header() for 
+! a description of a "no-operation" header.  
+!</PRE>
+!</DESCRIPTION>
+  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
+!<DESCRIPTION>
+!<PRE>
+! This routine is used to store a string as a sequence of integers.  
+! The first integer is the string length.  
+!</PRE>
+!</DESCRIPTION>
+  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
+!<DESCRIPTION>
+!<PRE>
+! This routine is used to extract a string from a sequence of integers.  
+! The first integer is the string length.  
+!</PRE>
+!</DESCRIPTION>
+  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
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_io.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_io.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_io.F	(revision 17)
@@ -0,0 +1,4109 @@
+!WRF:DRIVER_LAYER:IO
+!
+#define DEBUG_LVL 500
+
+MODULE module_io
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+
+  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
+  CHARACTER*256 extradims
+
+!<DESCRIPTION>
+!<PRE>
+!
+! include the file generated from md_calls.m4 using the m4 preprocessor
+! note that this file also includes the CONTAINS declaration for the module
+!
+!</PRE>
+!</DESCRIPTION>
+#include "md_calls.inc"
+
+!--- registry-generated routine that gets the io format being used for a dataset
+
+  INTEGER FUNCTION io_form_for_dataset ( DataSet )
+    IMPLICIT NONE
+    CHARACTER*(*), INTENT(IN)  :: DataSet
+    INTEGER                    :: io_form 
+#include "io_form_for_dataset.inc"
+    io_form_for_dataset = io_form
+    RETURN
+  END FUNCTION io_form_for_dataset
+
+  INTEGER FUNCTION io_form_for_stream ( stream )
+    USE module_streams
+    IMPLICIT NONE
+    INTEGER,       INTENT(IN)  :: stream
+    INTEGER                    :: io_form 
+#include "io_form_for_stream.inc"
+    io_form_for_stream = io_form
+    RETURN
+  END FUNCTION io_form_for_stream
+
+!--- ioinit
+
+SUBROUTINE wrf_ioinit( Status )
+!<DESCRIPTION>
+!<PRE>
+! Initialize the WRF I/O system.
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Shut down the WRF I/O system.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Begin data definition ("training") phase for writing to WRF dataset 
+! FileName.  
+!</PRE>
+!</DESCRIPTION>
+  USE module_state_description
+#ifdef DM_PARALLEL
+  USE module_dm, ONLY :  ntasks_x, mytask_x, local_communicator_x
+#endif
+  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, t1
+  INTEGER i,j
+
+  WRITE(mess,*) 'module_io.F: in wrf_open_for_write_begin, FileName = ',TRIM(FileName)
+  CALL wrf_debug( DEBUG_LVL, mess )
+
+  CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet )
+
+  io_form = io_form_for_dataset( DataSet )
+
+  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  )
+        WRITE(tstr,"(A,',NTASKS_X=',i10,',MYTASK_X=',i10,',LOCAL_COMMUNICATOR_X=',i10)") TRIM(SysDepInfo),ntasks_x,mytask_x,local_communicator_x
+        j=1
+        t1 = " "
+        DO i=1,len(TRIM(tstr))
+          IF ( tstr(i:i) .NE. ' ' ) THEN
+            t1(j:j) = tstr(i:i)
+            j = j + 1
+          ENDIF
+        ENDDO
+        tstr = t1
+        CALL ext_pnc_open_for_write_begin( FileName, Comm_compute, Comm_io, tstr, &
+                                            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 )
+!<DESCRIPTION>
+!<PRE>
+! 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().
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Begin data definition ("training") phase for reading from WRF dataset 
+! FileName.  
+!</PRE>
+!</DESCRIPTION>
+  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
+  LOGICAL                     :: also_for_out
+  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 )
+
+  io_form = io_form_for_dataset( DataSet )
+
+  Status = 0
+  Hndl = -1
+  also_for_out = .FALSE.
+!  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 PNETCDF
+      CASE ( IO_PNETCDF   )
+        CALL ext_pnc_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
+                                            Hndl , Status )
+#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 )
+        also_for_out = .TRUE.
+        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 )
+        also_for_out = .TRUE.
+        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, also_for_out, DataHandle )
+END SUBROUTINE wrf_open_for_read_begin
+
+!--- open_for_read_commit
+
+SUBROUTINE wrf_open_for_read_commit( DataHandle , Status )
+!<DESCRIPTION>
+!<PRE>
+! 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().
+!</PRE>
+!</DESCRIPTION>
+  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 PNETCDF
+        CASE ( IO_PNETCDF )
+          CALL ext_pnc_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 )
+!<DESCRIPTION>
+!<PRE>
+! Opens a WRF dataset for reading.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+
+  io_form = io_form_for_dataset( DataSet )
+
+  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 PNETCDF
+    CASE ( IO_PNETCDF  )
+      CALL ext_pnc_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
+                               Hndl , Status )
+#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, &
+                               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 )
+!<DESCRIPTION>
+!<PRE>
+! Inquire if the dataset referenced by DataHandle is open.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Returns the Filename and FileStatus associated with DataHandle.  
+!</PRE>
+!</DESCRIPTION>
+  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
+  INTEGER                     :: str_length , str_count
+
+  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   )
+          str_length = LEN ( FileName )
+          DO str_count = 1 , str_length
+            FileName(str_count:str_count) = ' '
+          END DO
+          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 )
+!<DESCRIPTION>
+!<PRE>
+! Synchronize the disk copy of a dataset with memory buffers.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Close the dataset referenced by DataHandle.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Returns the next time stamp.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Returns the previous time stamp.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Sets the time stamp.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! On reading, this routine returns the name of the next variable in the 
+! current time frame.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! This routine applies only to a dataset that is open for read.  It returns 
+! information about a variable.  
+!</PRE>
+!</DESCRIPTION>
+  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()
+!<DESCRIPTION>
+!<PRE>
+! Initialize all I/O handles.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Sets internal flag to indicate that the first read or write has not yet 
+! happened for the dataset referenced by DataHandle.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Resets internal flag to indicate that the first read or write has already 
+! happened for the dataset referenced by DataHandle.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Returns .TRUE. the first read or write has not yet happened for the dataset 
+! referenced by DataHandle.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Trash a handle and return to "unused" pool.  
+!</PRE>
+!</DESCRIPTION>
+  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
+!<DESCRIPTION>
+!<PRE>
+! Initialize this module.  Must be called before any other operations are 
+! attempted.  
+!</PRE>
+!</DESCRIPTION>
+  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
+
+LOGICAL FUNCTION on_stream ( mask , switch )
+  IMPLICIT NONE
+  INTEGER, INTENT(IN) :: mask(*), switch
+  INTEGER             :: result
+! get_mask is a C routine defined in frame/pack_utils.c
+! switch is decremented from its fortran value so it is zero based
+  CALL get_mask( mask, switch-1, result )
+  on_stream = ( result .NE. 0 )
+END FUNCTION on_stream
+
+END MODULE module_io
+
+
+!<DESCRIPTION>
+!<PRE>
+! Remaining routines in this file are defined outside of the module to 
+! defeat arg/param type checking.  
+!</PRE>
+!</DESCRIPTION>
+SUBROUTINE wrf_read_field ( DataHandle , DateStr , VarName , Field , FieldType ,         &
+                            Comm       , IOComm  ,                                       &
+                            DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
+                            DomainStart , DomainEnd ,                                    &
+                            MemoryStart , MemoryEnd ,                                    &
+                            PatchStart , PatchEnd ,                                      &
+                            Status )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Read the variable named VarName from the dataset pointed to by DataHandle.
+! Calls ext_pkg_read_field() via call_pkg_and_dist().  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Write the variable named VarName to the dataset pointed to by DataHandle.
+! Calls ext_pkg_write_field() via collect_fld_and_call_pkg().  
+!</PRE>
+!</DESCRIPTION>
+
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! parse comma separated list of VARIABLE=VALUE strings and return the
+! value for the matching variable if such exists, otherwise return
+! the empty string
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Returns the ID of the external I/O package referenced by io_form.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.
+!</PRE>
+!</DESCRIPTION>
+  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
+  INTEGER test
+  CHARACTER*128 mess
+
+  IF ( wrf_dm_on_monitor() ) THEN
+    ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ), &
+              STAT=test )
+    IF ( test .NE. 0 ) THEN
+      write(mess,*)"module_io.b",'allocating globbuf ',&
+           (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3)
+      CALL wrf_error_fatal(mess)
+    ENDIF
+  ELSE
+    ALLOCATE( globbuf( 1 ), STAT=test )
+    IF ( test .NE. 0 ) THEN
+      write(mess,*)"module_io.b",'allocating globbuf ',1
+      CALL wrf_error_fatal(mess)
+    ENDIF
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.
+!</PRE>
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.
+!</PRE>
+!</DESCRIPTION>
+  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 )
+
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+  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 1
+          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
+#else
+          IF ( (MemOrd(1:2) .EQ. 'xs' ) .OR.     &
+               (MemOrd(1:2) .EQ. 'xe' )       ) THEN
+            my_displ = jps-1         
+            my_count = jpe-jps+1
+          ELSE
+            my_displ = 0
+            my_count = 0
+          ENDIF
+#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 ,                &    ! sendbuf
+                               counts                         , &    ! sendcounts
+                               Field, jps-jms+1+idx ,       &
+                               my_count ,                       &    ! recvcount
+                               displs                         , &    ! displs
+                               collective_root                , &    ! root
+                               communicator                   , &    ! communicator
+                               ierr )
+             ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
+
+               CALL wrf_scatterv_real (                          &
+                               globbuf, 1+idx2 ,                &    ! sendbuf
+                               counts                         , &    ! sendcounts
+                               Field, jps-jms+1+idx ,       &
+                               my_count ,                       &    ! recvcount
+                               displs                         , &    ! displs
+                               collective_root                , &    ! root
+                               communicator                   , &    ! communicator
+                               ierr )
+
+             ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+               CALL wrf_scatterv_integer (                       &
+                               globbuf, 1+idx2 ,                &    ! sendbuf
+                               counts                         , &    ! sendcounts
+                               Field, jps-jms+1+idx ,       &
+                               my_count ,                       &    ! recvcount
+                               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 1
+          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
+#else
+          IF ( (MemOrd(1:2) .EQ. 'ys' ) .OR.     &
+               (MemOrd(1:2) .EQ. 'ye' )       ) THEN
+            my_displ = ips-1
+            my_count = ipe-ips+1
+          ELSE
+            my_displ = 0
+            my_count = 0
+          ENDIF
+#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 ,                &    ! sendbuf
+                               counts                         , &    ! sendcounts
+                               Field, ips-ims+1+idx ,       &
+                               my_count ,                       &    ! recvcount
+                               displs                         , &    ! displs
+                               collective_root                , &    ! root
+                               communicator                   , &    ! communicator
+                               ierr )
+             ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
+               CALL wrf_scatterv_real (                          &
+                               globbuf, 1+idx2 ,                &    ! sendbuf
+                               counts                         , &    ! sendcounts
+                               Field, ips-ims+1+idx ,       &
+                               my_count ,                       &    ! recvcount
+                               displs                         , &    ! displs
+                               collective_root                , &    ! root
+                               communicator                   , &    ! communicator
+                               ierr )
+             ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+               CALL wrf_scatterv_integer (                       &
+                               globbuf, 1+idx2 ,                &    ! sendbuf
+                               counts                         , &    ! sendcounts
+                               Field, ips-ims+1+idx ,       &
+                               my_count ,                       &    ! recvcount
+                               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)
+!<DESCRIPTION>
+!<PRE>
+! Decodes array ranks from memory order.  
+!</PRE>
+!</DESCRIPTION>
+  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)
+!<DESCRIPTION>
+!<PRE>
+! Translates upper-case characters to lower-case.  
+!</PRE>
+!</DESCRIPTION>
+  CHARACTER*(*) ,INTENT(IN)  :: MemoryOrder
+  CHARACTER*(*) ,INTENT(OUT) :: MemOrd
+!Local
+  CHARACTER*1                :: c
+  INTEGER       ,PARAMETER   :: upper_to_lower =IACHAR('a')-IACHAR('A')
+  INTEGER                    :: i,n,n1
+!
+  MemOrd = ' '
+  N = len(MemoryOrder)
+  N1 = len(MemOrd)
+  N = MIN(N,N1)
+  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 )
+!<DESCRIPTION>
+!<PRE>
+! Returns .TRUE. iff string str contains character c.  Ignores character case.  
+!</PRE>
+!</DESCRIPTION>
+  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
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_io_quilt.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_io_quilt.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_io_quilt.F	(revision 17)
@@ -0,0 +1,4727 @@
+!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
+!<DESCRIPTION>
+!<PRE>
+! 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.
+!</PRE>
+!</DESCRIPTION>
+  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,SAVE :: int_local_output_buffer(:)
+  INTEGER,      SAVE :: 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
+  LOGICAL :: compute_node
+  LOGICAL :: compute_group_master(100)
+  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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+      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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+      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)
+!<DESCRIPTION>
+! 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:  
+!
+!<PRE>
+! 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 **
+!</PRE>
+!</DESCRIPTION>
+      USE module_configure
+#ifdef DM_PARALLEL
+      USE module_dm, ONLY : compute_mesh
+#endif
+      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
+
+      INTEGER :: io_form_setting
+      INTEGER :: me
+      INTEGER :: k, m, nprocx, nprocy
+      LOGICAL :: reorder_mesh
+
+!check the namelist and make sure there are no output forms specified
+!that cannot be quilted
+      CALL nl_get_io_form_history(1,   io_form_setting) ; call sokay( 'history', io_form_setting )
+      CALL nl_get_io_form_restart(1,   io_form_setting) ; call sokay( 'restart', io_form_setting )
+      CALL nl_get_io_form_auxhist1(1,  io_form_setting) ; call sokay( 'auxhist1', io_form_setting )
+      CALL nl_get_io_form_auxhist2(1,  io_form_setting) ; call sokay( 'auxhist2', io_form_setting )
+      CALL nl_get_io_form_auxhist3(1,  io_form_setting) ; call sokay( 'auxhist3', io_form_setting )
+      CALL nl_get_io_form_auxhist4(1,  io_form_setting) ; call sokay( 'auxhist4', io_form_setting )
+      CALL nl_get_io_form_auxhist5(1,  io_form_setting) ; call sokay( 'auxhist5', io_form_setting )
+      CALL nl_get_io_form_auxhist6(1,  io_form_setting) ; call sokay( 'auxhist6', io_form_setting )
+      CALL nl_get_io_form_auxhist7(1,  io_form_setting) ; call sokay( 'auxhist7', io_form_setting )
+      CALL nl_get_io_form_auxhist8(1,  io_form_setting) ; call sokay( 'auxhist8', io_form_setting )
+      CALL nl_get_io_form_auxhist9(1,  io_form_setting) ; call sokay( 'auxhist9', io_form_setting )
+      CALL nl_get_io_form_auxhist10(1, io_form_setting) ; call sokay( 'auxhist10', io_form_setting )
+      CALL nl_get_io_form_auxhist11(1, io_form_setting) ; call sokay( 'auxhist11', io_form_setting )
+
+      n_groups = n_groups_arg
+      IF ( n_groups .LT. 1 ) n_groups = 1
+
+      compute_node = .TRUE.
+
+!<DESCRIPTION>
+! 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
+!</DESCRIPTION>
+
+      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_wrld
+        mpi_comm_io_groups = mpi_comm_wrld
+        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
+      CALL nl_get_reorder_mesh(1,reorder_mesh)
+      IF ( reorder_mesh ) THEN
+        reorder_mesh = .FALSE.
+        CALL nl_set_reorder_mesh(1,reorder_mesh)
+        CALL wrf_message('Warning: reorder_mesh does not work with quilting. Disabled reorder_mesh.')
+      ENDIF
+      ! assign the compute tasks to the i/o tasks in full rows
+      CALL compute_mesh( ncompute_tasks, nprocx, nprocy )
+
+      nio = min(nio,nprocy)
+      m = mod(nprocy,nio)  ! divide up remainder, 1 row per, until gone
+      ii = 1
+      DO j = 1, nio, 1
+         DO k = 1,nprocy/nio+min(m,1)
+           DO i = 1, nprocx
+             icolor(ii) = j - 1
+             ii = ii + 1
+           ENDDO
+         ENDDO
+         m = max(m-1,0)
+      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)
+      ENDDO
+
+      compute_group_master = .FALSE.
+      compute_node         = .FALSE.
+
+      DO j = 1, n_groups
+
+         IF ( mytask .LT. ncompute_tasks .OR.                                                  &    ! I am a compute task
+              (ncompute_tasks+(j-1)*nio .LE. mytask .AND. mytask .LT. ncompute_tasks+j*nio) &    ! I am the I/O server for this group
+            ) THEN
+
+         CALL MPI_Comm_Size( mpi_comm_io_groups(j) , iisize, ierr )
+         ! Get the rank of this compute task in the compute+io 
+         ! communicator to which it belongs
+         CALL MPI_Comm_Rank( mpi_comm_io_groups(j) , me , ierr )
+
+         ! If I am an I/O server for this group then make that group's
+         ! communicator the first element in the mpi_comm_io_groups array 
+         ! (I will ignore all of the other elements).
+         IF ( me+1 .EQ. iisize ) THEN
+            mpi_comm_io_groups(1) = mpi_comm_io_groups(j)
+         ELSE
+            compute_node = .TRUE.
+            ! If I am a compute task, check whether I am the member of my 
+            ! group that will communicate things that should be sent just 
+            ! once (e.g. commands) to the IO server of my group.
+            compute_group_master(j) = (me .EQ. 0)
+
+            IF( compute_group_master(j) ) WRITE(*,*) mytask,': ARPDBG : I will talk to IO server in group ',j
+         ENDIF
+         ENDIF
+      ENDDO
+
+    END SUBROUTINE setup_quilt_servers
+
+    SUBROUTINE sokay ( stream, io_form )
+    USE module_state_description
+    CHARACTER*(*) stream
+    CHARACTER*256 mess
+    INTEGER io_form
+
+    SELECT CASE (io_form)
+#ifdef NETCDF
+      CASE ( IO_NETCDF   )
+         RETURN
+#endif
+#ifdef INTIO
+      CASE ( IO_INTIO   )
+         RETURN
+#endif
+#ifdef YYY
+      CASE ( IO_YYY )
+         RETURN
+#endif
+#ifdef GRIB1
+      CASE ( IO_GRIB1 )
+         RETURN
+#endif
+#ifdef GRIB2
+      CASE ( IO_GRIB2 )
+         RETURN
+#endif
+      CASE (0)
+         RETURN
+      CASE DEFAULT
+         WRITE(mess,*)' An output format has been specified that is incompatible with quilting: io_form: ',io_form,' ',TRIM(stream)
+         CALL wrf_error_fatal(mess)
+    END SELECT
+    END SUBROUTINE sokay
+
+    SUBROUTINE quilt
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+      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, 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, rtypesize, 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)
+      INTEGER :: num_noops, num_commit_messages, num_field_training_msgs, hdr_tag
+      CHARACTER (len=256) :: DateStr , Element, VarName, MemoryOrder , Stagger , DimNames(3), FileName, SysDepInfo, mess
+      INTEGER, EXTERNAL :: use_package
+      LOGICAL           :: stored_write_record, retval
+      INTEGER iii, jjj, vid, CC, DD
+
+logical okay_to_w
+character*120 sysline
+
+! If we've been built with PNETCDF_QUILT defined then we use parallel I/O
+! within the group of I/O servers rather than gathering the data onto the
+! root I/O server. Unfortunately, this approach means that we can no-longer
+! select different I/O layers for use with quilting at run time. ARPDBG.
+! This code is sufficiently different that it is kept in the separate 
+! quilt_pnc() routine.
+#ifdef PNETCDF_QUILT
+      CALL quilt_pnc()
+      RETURN
+#endif
+
+! 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, itypesize, ierr )
+      IF ( itypesize <= 0 ) THEN
+        CALL wrf_error_fatal("external/RSL/module_dm.F: quilt: type size <= 0 invalid")
+      ENDIF
+
+! Work out whether this i/o server processor has one fewer associated compute proc than
+! the most any processor has. Can happen when number of i/o tasks does not evenly divide
+! the number of compute tasks. This is needed to keep the i/o tasks sychronized on the
+! same message when they start commmunicating to stitch together an output.
+!
+! Compute processes associated with this task:
+       CC = ntasks_io_group - 1
+! Number of compute tasks per I/O task (less remainder)
+       DD = ncompute_tasks / ntasks_local_group
+!
+! If CC-DD is 1 on servrs with the maximum number of compute clients, 
+!             0 on servrs with one less than maximum
+
+
+! 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.  
+okay_to_w = .false.
+      DO WHILE (.TRUE.)  ! {
+
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+        ! wait for info from compute tasks in the I/O group that we're ready to rock
+        ! obufsize will contain number of *bytes*
+!CALL 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)
+!CALL end_timing("MPI_Reduce at top of forever loop") 
+!JMDEBUGwrite(0,*)'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
+            WRITE(mess,*)'Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.'
+            CALL wrf_error_fatal(mess)
+          ENDIF
+        ENDIF
+
+!        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)/itypesize ) )
+
+! let's roll; get the data from the compute procs and put in obuf
+          CALL collect_on_comm_debug(__FILE__,__LINE__, mpi_comm_io_groups(1),        &
+                                onebyte,                      &
+                                dummy, 0,                     &
+                                obuf, obufsize )
+!          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 = itypesize
+        num_noops = 0 
+        num_commit_messages = 0 
+        num_field_training_msgs = 0 
+        DO WHILE ( icurs .lt. obufsize ) ! {
+          hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) )
+          SELECT CASE ( hdr_tag )
+            CASE ( int_field )
+              CALL int_get_write_field_header ( obuf(icurs/itypesize), 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
+
+              IF ( DomainDesc .EQ. 333933 ) THEN  ! Training write, only one per group of tasks
+                 IF ( num_field_training_msgs .EQ. 0 ) THEN
+                   call add_to_bufsize_for_field( VarName, hdrbufsize )
+!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+                 ENDIF
+                 num_field_training_msgs = num_field_training_msgs + 1
+              ELSE
+                 call add_to_bufsize_for_field( VarName, hdrbufsize )
+!write(0,*) 'X-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+              ENDIF
+              icurs = icurs + hdrbufsize
+
+!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+
+              ! 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 ( int_open_for_write_commit )  ! only one per group of tasks
+              hdrbufsize = obuf(icurs/itypesize)
+              IF (num_commit_messages.EQ.0) THEN
+                call add_to_bufsize_for_field( 'COMMIT', hdrbufsize )
+              ENDIF
+              num_commit_messages = num_commit_messages + 1
+              icurs = icurs + hdrbufsize
+            CASE DEFAULT
+              hdrbufsize = obuf(icurs/itypesize)
+
+! This logic and the logic in the loop below is used to determine whether
+! to send a noop records sent by the compute processes to allow to go
+! through. The purpose is to make sure that the communications between this
+! server and the other servers in this quilt group stay synchronized in
+! the collection loop below, even when the servers are serving different
+! numbers of clients. Here are some conditions:
+! 
+!   1. The number of compute clients served will not differ by more than 1
+!   2. The servers with +1 number of compute clients begin with task 0
+!      of mpi_comm_local, the commicator shared by this group of servers
+! 
+!   3. For each collective field or metadata output from the compute tasks,
+!      there will be one record sent to the associated i/o server task. The
+!      i/o server task collects these records and stores them contiguously
+!      in a buffer (obuf) using collect_on_comm above.  Thus, obuf on this
+!      server task will contain one record from each associated compute
+!      task, in order.
+! 
+!   4. In the case of replicated output from the compute tasks
+!      (e.g. put_dom_ti records and control records like
+!      open_for_write_commit type records), compute task 0 is the only
+!      one that sends the record. The other compute tasks send noop
+!      records. Thus, obuf on server task zero will contain the output
+!      record from task 0 followed by noop records from the rest of the
+!      compute tasks associated with task 0.  Obuf on the other server
+!      tasks will contain nothing but noop records.
+! 
+!   5. The logic below will not allow any noop records from server task 0.
+!      It allows only one noop record from each of the other server tasks
+!      in the i/o group.  This way, for replicated output, when the records
+!      are collected on one server task below, using collect_on_comm on
+!      mpi_comm_local, each task will provide exactly one record for each
+!      call to collect_on_comm: 1 bona fide output record from server task
+!      0 and noops from the rest.
+
+              IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0)  &
+                  .OR.hdr_tag.NE.int_noop) THEN
+                write(VarName,'(I5.5)')vid 
+!write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+                call add_to_bufsize_for_field( VarName, hdrbufsize )
+                vid = vid+1
+              ENDIF
+              IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1
+              icurs = icurs + hdrbufsize
+          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 = itypesize
+        num_noops = 0 
+        num_commit_messages = 0 
+        num_field_training_msgs = 0 
+        DO WHILE ( icurs .lt. obufsize ) !{
+!write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize
+          hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) )
+          SELECT CASE ( hdr_tag )
+            CASE ( int_field )
+              CALL int_get_write_field_header ( obuf(icurs/itypesize), 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
+
+              IF ( DomainDesc .EQ. 333933 ) THEN  ! Training write, only one per group of tasks
+                 IF ( num_field_training_msgs .EQ. 0 ) THEN
+                   call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
+!write(0,*) 'A-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+                 ENDIF
+                 num_field_training_msgs = num_field_training_msgs + 1
+              ELSE
+                 call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
+!write(0,*) 'A-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+              ENDIF
+              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),PatchStart(1:3),PatchEnd(1:3)
+                call store_piece_of_field( obuf(icurs/itypesize), VarName, chunksize )
+                icurs = icurs + chunksize
+              ENDIF
+            CASE ( int_open_for_write_commit )  ! only one per group of tasks
+              hdrbufsize = obuf(icurs/itypesize)
+              IF (num_commit_messages.EQ.0) THEN
+                call store_piece_of_field( obuf(icurs/itypesize), 'COMMIT', hdrbufsize )
+              ENDIF
+              num_commit_messages = num_commit_messages + 1
+              icurs = icurs + hdrbufsize
+            CASE DEFAULT
+              hdrbufsize = obuf(icurs/itypesize)
+              IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0)  &
+                  .OR.hdr_tag.NE.int_noop) THEN
+                write(VarName,'(I5.5)')vid 
+!write(0,*) 'A-2b', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+                call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
+                vid = vid+1
+              ENDIF
+              IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1
+              icurs = icurs + hdrbufsize
+          END SELECT
+        ENDDO !}
+
+! 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 )
+! 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,*)'seed: sz ',sz,' bigbufsize ',bigbufsize,' VarName ', TRIM(VarName),' retval ',retval
+
+! Loop until there are no more fields to retrieve from the internal buffers.
+        DO WHILE ( retval ) !{
+#if 0
+#else
+
+! 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
+            ALLOCATE( bigbuf( (bigbufsize+1)/itypesize ) )
+          ENDIF
+
+! 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_debug2(__FILE__,__LINE__,Trim(VarName),        &
+                                get_hdr_tag(obuf),sz,get_hdr_rec_size(obuf),  &
+                                mpi_comm_local,                               &
+                                onebyte,                                      &
+                                obuf, sz,                                     &
+                                bigbuf, 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 = itypesize  ! 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/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) )
+! 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/itypesize) ) )
+! 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 )
+                  CALL int_get_noop_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize )
+                  icurs = icurs + hdrbufsize
+
+! The I/O server "root" handles the "put_dom_td_real" request.
+                CASE ( int_dom_td_real )
+                  CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
+                  ALLOCATE( RData( bigbuf(icurs/itypesize + 4 ) ) )      ! 5 is the count of data items for this record ; defined in collect_on_comm.c
+                  CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, 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/itypesize + 4 ) ) )      ! 5 is the count of data items for this record ; defined in collect_on_comm.c
+                  CALL int_get_ti_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, 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/itypesize + 4 ) ) )      ! 5 is the count of data items for this record ; defined in collect_on_comm.c
+                  CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, 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/itypesize + 4 ) ) )      ! 5 is the count of data items for this record ; defined in collect_on_comm.c
+                  CALL int_get_ti_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, 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/itypesize), hdrbufsize, itypesize, &
+                                               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/itypesize), hdrbufsize, itypesize, &
+                                               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/itypesize), hdrbufsize, itypesize, &
+                                               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/itypesize), hdrbufsize, itypesize, &
+                                              DataHandle , code )
+                  icurs = icurs + hdrbufsize
+
+                  IF ( DataHandle .GE. 1 ) THEN
+!JMDEBUGwrite(0,*)'closing DataHandle ',DataHandle,' io_form ',io_form(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 PNETCDF
+                    CASE ( IO_PNETCDF   )
+                      CALL ext_pnc_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_pnc_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/itypesize), hdrbufsize, itypesize, &
+                                            FileName,SysDepInfo,io_form_arg,DataHandle )
+
+!write(0,*)' int_open_for_write_begin itypesize ',itypesize,' 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/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) )
+                
+                  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/itypesize), hdrbufsize, itypesize, &
+                                              DataHandle , code )
+                  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 )
+                  CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
+                  CALL int_get_write_field_header ( bigbuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize,  &
+                                                    DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
+                                                    DomainDesc , MemoryOrder , Stagger , DimNames ,              &
+                                                    DomainStart , DomainEnd ,                                    &
+                                                    MemoryStart , MemoryEnd ,                                    &
+                                                    PatchStart , PatchEnd )
+!write(0,*)' int_field ',TRIM(VarName),DataHandle,okay_to_write(DataHandle)
+                  icurs = icurs + hdrbufsize
+
+                  IF ( okay_to_write(DataHandle) ) THEN
+
+!                    WRITE(0,*)'>>> ',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/itypesize), 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/itypesize), 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 )
+                  CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, &
+                                            DataHandle , code )
+                  icurs = icurs + hdrbufsize
+                CASE DEFAULT
+                  WRITE(mess,*)'quilt: bad tag: ',get_hdr_tag( bigbuf(icurs/itypesize) ),' icurs ',icurs/itypesize
+                  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
+! 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.
+!              CALL start_timing
+              CALL write_outbuf ( handle(DataHandle), use_package(io_form(DataHandle))) 
+!              CALL end_timing( "quilt: call to write_outbuf" ) 
+            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 )
+                  IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
+                    CALL ext_ncd_open_for_write_commit(handle(DataHandle),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
+#endif
+
+! Retrieve header and all patches for the next field from the internal 
+! buffers.  
+        CALL retrieve_pieces_of_field ( obuf , 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.  
+      END DO !}
+
+      DEALLOCATE( obuf )
+
+      ! flush output files if needed
+      IF (stored_write_record) THEN
+!         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
+!CALL end_timing( "quilt: flush" )
+      ENDIF
+
+      END DO ! }
+
+    END SUBROUTINE quilt
+
+    SUBROUTINE quilt_pnc
+!<DESCRIPTION>
+! Same as quilt() routine except that _all_ of the IO servers that call it
+! actually write data to disk using pNetCDF. This version is only used when 
+! the  code is compiled with PNETCDF_QUILT defined.
+!</DESCRIPTION>
+      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, 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, rtypesize, 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)
+      INTEGER :: num_noops, num_commit_messages, num_field_training_msgs, hdr_tag
+      CHARACTER (len=256) :: DateStr , Element, VarName, MemoryOrder , Stagger , DimNames(3), FileName, SysDepInfo, mess
+      INTEGER, EXTERNAL :: use_package
+      LOGICAL           :: stored_write_record, retval, written_record
+      INTEGER iii, jjj, vid, CC, DD
+
+!      logical okay_to_w
+!      character*120 sysline
+
+! Call ext_pkg_ioinit() routines to initialize I/O packages.  
+      SysDepInfo = " "
+#ifdef NETCDF
+      CALL ext_ncd_ioinit( SysDepInfo, ierr)
+#endif
+#ifdef PNETCDF_QUILT
+      CALL ext_pnc_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
+      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, itypesize, ierr )
+      IF ( itypesize <= 0 ) THEN
+        CALL wrf_error_fatal("external/RSL/module_dm.F: quilt: type size <= 0 invalid")
+      ENDIF
+
+! Work out whether this i/o server processor has one fewer associated compute proc than
+! the most any processor has. Can happen when number of i/o tasks does not evenly divide
+! the number of compute tasks. This is needed to keep the i/o tasks sychronized on the
+! same message when they start commmunicating to stitch together an output.
+!
+! Compute processes associated with this task:
+       CC = ntasks_io_group - 1
+! Number of compute tasks per I/O task (less remainder)
+       DD = ncompute_tasks / ntasks_local_group
+!
+! If CC-DD is 1 on servrs with the maximum number of compute clients, 
+!             0 on servrs with one less than maximum
+
+
+! 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.  
+!okay_to_w = .false.
+      DO WHILE (.TRUE.)  ! {
+
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+        ! wait for info from compute tasks in the I/O group that we're ready to rock
+        ! obufsize will contain number of *bytes*
+!CALL 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)
+!CALL end_timing("MPI_Reduce at top of forever loop") 
+!JMDEBUGwrite(0,*)'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 PNETCDF_QUILT
+            CALL ext_pnc_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
+            WRITE(mess,*)'Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.'
+            CALL wrf_error_fatal(mess)
+          ENDIF
+        ENDIF
+
+!        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)/itypesize ) )
+
+! let's roll; get the data from the compute procs and put in obuf
+          CALL collect_on_comm_debug(__FILE__,__LINE__, mpi_comm_io_groups(1),        &
+                                onebyte,                      &
+                                dummy, 0,                     &
+                                obuf, obufsize )
+!          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 any 
+! "quilting" (assembly of patches into full domains).  For each field, it 
+! simply writes all received patches for the field to disk.
+! ARPDBG we can vastly reduce the number of writes to disk by stitching
+! any contiguous patches together first. Has implications for synchronisation
+! of pNetCDF calls though.
+        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 = itypesize
+        num_noops = 0 
+        num_commit_messages = 0 
+        num_field_training_msgs = 0 
+        DO WHILE ( icurs .lt. obufsize ) ! {
+          hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) )
+          SELECT CASE ( hdr_tag )
+            CASE ( int_field )
+              CALL int_get_write_field_header ( obuf(icurs/itypesize), 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
+
+              IF ( DomainDesc .EQ. 333933 ) THEN  ! Training write, only one per group of tasks
+                 IF ( num_field_training_msgs .EQ. 0 ) THEN
+                   call add_to_bufsize_for_field( VarName, hdrbufsize )
+!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+                 ENDIF
+                 num_field_training_msgs = num_field_training_msgs + 1
+              ELSE
+                 call add_to_bufsize_for_field( VarName, hdrbufsize )
+!write(0,*) 'X-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+              ENDIF
+              icurs = icurs + hdrbufsize
+
+!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+
+              ! 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 ( int_open_for_write_commit )  ! only one per group of tasks
+              hdrbufsize = obuf(icurs/itypesize)
+              IF (num_commit_messages.EQ.0) THEN
+                call add_to_bufsize_for_field( 'COMMIT', hdrbufsize )
+              ENDIF
+              num_commit_messages = num_commit_messages + 1
+              icurs = icurs + hdrbufsize
+            CASE DEFAULT
+              hdrbufsize = obuf(icurs/itypesize)
+
+! This logic and the logic in the loop below is used to determine whether
+! to send a noop records sent by the compute processes to allow to go
+! through. The purpose is to make sure that the communications between this
+! server and the other servers in this quilt group stay synchronized in
+! the collection loop below, even when the servers are serving different
+! numbers of clients. Here are some conditions:
+! 
+!   1. The number of compute clients served will not differ by more than 1
+!   2. The servers with +1 number of compute clients begin with task 0
+!      of mpi_comm_local, the commicator shared by this group of servers
+! 
+!   3. For each collective field or metadata output from the compute tasks,
+!      there will be one record sent to the associated i/o server task. The
+!      i/o server task collects these records and stores them contiguously
+!      in a buffer (obuf) using collect_on_comm above.  Thus, obuf on this
+!      server task will contain one record from each associated compute
+!      task, in order.
+! ! 
+!   4. In the case of replicated output from the compute tasks
+!      (e.g. put_dom_ti records and control records like
+!      open_for_write_commit type records), only compute tasks for which 
+!      (compute_group_master == .TRUE) send the record. The other compute 
+!      tasks send noop records. This is done so that each server task 
+!      receives exactly one record plus noops from the other compute tasks. 
+! 
+!   5. Logic below does not allow any noop records through since each IO 
+!      server task now receives a valid record (from the 'compute-group master'
+!      when doing replicated output
+              IF (hdr_tag.NE.int_noop) THEN
+                write(VarName,'(I5.5)')vid 
+!write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+                call add_to_bufsize_for_field( VarName, hdrbufsize )
+                vid = vid+1
+              ENDIF
+              IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1
+              icurs = icurs + hdrbufsize
+
+          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 = itypesize
+        num_noops = 0 
+        num_commit_messages = 0 
+        num_field_training_msgs = 0 
+        DO WHILE ( icurs .lt. obufsize ) !{
+!write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize
+          hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) )
+          SELECT CASE ( hdr_tag )
+            CASE ( int_field )
+              CALL int_get_write_field_header ( obuf(icurs/itypesize), 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
+
+              IF ( DomainDesc .EQ. 333933 ) THEN  ! Training write, only one per group of tasks
+                 IF ( num_field_training_msgs .EQ. 0 ) THEN
+                   call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
+!write(0,*) 'A-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+                 ENDIF
+                 num_field_training_msgs = num_field_training_msgs + 1
+              ELSE
+                 call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
+!write(0,*) 'A-2a', icurs, hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+              ENDIF
+              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
+                call store_piece_of_field( obuf(icurs/itypesize), VarName, chunksize )
+                icurs = icurs + chunksize
+!write(0,*) 'A-1a',TRIM(VarName),' icurs ',icurs,PatchStart(1:3),PatchEnd(1:3)
+              ENDIF
+            CASE ( int_open_for_write_commit )  ! only one per group of tasks
+              hdrbufsize = obuf(icurs/itypesize)
+              IF (num_commit_messages.EQ.0) THEN
+                call store_piece_of_field( obuf(icurs/itypesize), 'COMMIT', hdrbufsize )
+              ENDIF
+              num_commit_messages = num_commit_messages + 1
+              icurs = icurs + hdrbufsize
+            CASE DEFAULT
+              hdrbufsize = obuf(icurs/itypesize)
+              IF (hdr_tag.NE.int_noop) THEN
+
+                write(VarName,'(I5.5)')vid 
+!write(0,*) 'A-2b', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName)
+                call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize )
+                vid = vid+1
+              ENDIF
+              IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1
+              icurs = icurs + hdrbufsize
+          END SELECT
+       ENDDO !} while(icurs < obufsize)
+
+! 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 )
+       written_record = .false.
+
+! Loop until there are no more fields to retrieve from the internal buffers.
+       DO WHILE ( retval ) !{
+
+! This I/O server now handles the collected requests from the compute 
+! tasks it serves
+
+            icurs = itypesize  ! icurs is a byte counter, but buffer is integer
+
+            stored_write_record = .false.
+
+! ALL I/O servers in this group loop over the collected requests they have
+! received.
+            DO WHILE ( icurs .lt. sz)! bigbufsize ) !{
+
+! The I/O server gets the request out of the next header and
+! handles it by, in most cases, calling the appropriate external I/O package
+! interface.
+!write(0,*)__FILE__,__LINE__,'get_hdr_tag ',icurs,sz,get_hdr_tag( obuf(icurs/itypesize) )
+              SELECT CASE ( get_hdr_tag( obuf(icurs/itypesize) ) )
+! The I/O server handles the "noop" (do nothing) request.  This is 
+! actually quite easy.  "Noop" requests exist to help avoid race conditions.  
+                CASE ( int_noop )
+                  CALL int_get_noop_header( obuf(icurs/itypesize), &
+                                            hdrbufsize, itypesize )
+                  icurs = icurs + hdrbufsize
+
+! The I/O server "root" handles the "put_dom_td_real" request.
+                CASE ( int_dom_td_real )
+                  CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
+                  ALLOCATE( RData( obuf(icurs/itypesize + 4 ) ) )      ! 5 is the count of data items for this record ; defined in collect_on_comm.c
+                  CALL int_get_td_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
+                                          DataHandle, DateStr, Element, RData, Count, code )
+                  icurs = icurs + hdrbufsize
+
+                  SELECT CASE (use_package(io_form(DataHandle)))
+#ifdef PNETCDF_QUILT
+                    CASE (IO_PNETCDF  )
+                      CALL ext_pnc_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status )
+#endif
+#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 )
+! Every I/O server handles the "put_dom_ti_real" request.
+                CASE ( int_dom_ti_real )
+
+                  CALL mpi_type_size( MPI_REAL, ftypesize, ierr )
+                  ALLOCATE( RData( obuf(icurs/itypesize + 4 ) ) )      ! 5 is the count of data items for this record ; defined in collect_on_comm.c
+                  CALL int_get_ti_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
+                                          DataHandle, Element, RData, Count, code )
+                  icurs = icurs + hdrbufsize
+
+                  SELECT CASE (use_package(io_form(DataHandle)))
+#ifdef PNETCDF_QUILT
+                    CASE (IO_PNETCDF  )
+                      CALL ext_pnc_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status )
+#endif
+#ifdef NETCDF
+                    CASE ( IO_NETCDF   )
+                      CALL ext_ncd_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, 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 )
+
+! Every I/O server handles the "put_dom_td_integer" request.
+                CASE ( int_dom_td_integer )
+
+                  CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
+                  ALLOCATE( IData( obuf(icurs/itypesize + 4 ) ) )      ! 5 is the count of data items for this record ; defined in collect_on_comm.c
+                  CALL int_get_td_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
+                                          DataHandle, DateStr, Element, IData, Count, code )
+                  icurs = icurs + hdrbufsize
+
+                  SELECT CASE (use_package(io_form(DataHandle)))
+#ifdef PNETCDF_QUILT
+                  CASE (IO_PNETCDF  )
+                      CALL ext_pnc_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status )
+#endif
+#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 )
+
+! Every I/O server handles the "put_dom_ti_integer" request.
+                CASE ( int_dom_ti_integer )
+
+                  CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
+                  ALLOCATE( IData( obuf(icurs/itypesize + 4 ) ) )      ! 5 is the count of data items for this record ; defined in collect_on_comm.c
+                  CALL int_get_ti_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, &
+                                          DataHandle, Element, IData, Count, code )
+                  icurs = icurs + hdrbufsize
+                  SELECT CASE (use_package(io_form(DataHandle)))
+#ifdef PNETCDF_QUILT
+                    CASE (IO_PNETCDF  )
+                      CALL ext_pnc_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status )
+#endif
+#ifdef NETCDF
+                    CASE ( IO_NETCDF   )
+                      CALL ext_ncd_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, 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)
+ 
+! Every I/O server  handles the "set_time" request.
+                CASE ( int_set_time )
+
+                  CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, &
+                                               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
+
+! Every I/O server handles the "put_dom_ti_char" request.
+                CASE ( int_dom_ti_char )
+
+                  CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, &
+                                               DataHandle, Element, VarName, CData, code )
+
+                  SELECT CASE (use_package(io_form(DataHandle)))
+#ifdef PNETCDF_QUILT
+                    CASE (IO_PNETCDF  )
+                      CALL ext_pnc_put_dom_ti_char ( handle(DataHandle), TRIM(Element), Trim(CData), Status)
+#endif
+#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
+
+! Every I/O server handles the "put_var_ti_char" request.
+                CASE ( int_var_ti_char )
+
+                  CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, &
+                                               DataHandle, Element, VarName, CData, code )
+
+                  SELECT CASE (use_package(io_form(DataHandle)))
+#ifdef PNETCDF_QUILT
+                    CASE (IO_PNETCDF  )
+                      CALL ext_pnc_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status )
+#endif
+#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")
+! Every I/O server handles the "ioclose" request.
+                CASE ( int_ioclose )
+                  CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, &
+                                              DataHandle , code )
+                  icurs = icurs + hdrbufsize
+
+                  IF ( DataHandle .GE. 1 ) THEN
+
+                     SELECT CASE (use_package(io_form(DataHandle)))
+#ifdef PNETCDF_QUILT
+                    CASE ( IO_PNETCDF   )
+                      CALL ext_pnc_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_pnc_ioclose(handle(DataHandle),Status)
+                      ENDIF
+#endif
+#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
+
+! Every I/O server handles the "open_for_write_begin" request.
+                CASE ( int_open_for_write_begin )
+
+                  CALL int_get_ofwb_header( obuf(icurs/itypesize), hdrbufsize, itypesize, &
+                                            FileName,SysDepInfo,io_form_arg,DataHandle )
+
+!write(0,*)' int_open_for_write_begin itypesize ',itypesize,' 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/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) )
+                
+                  io_form(DataHandle) = io_form_arg
+
+                  SELECT CASE (use_package(io_form(DataHandle)))
+#ifdef PNETCDF_QUILT
+                    CASE (IO_PNETCDF  )
+                      CALL ext_pnc_open_for_write_begin(FileName,mpi_comm_local,mpi_comm_local,SysDepInfo,handle(DataHandle),Status )
+#endif
+#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.
+
+! Every I/O server handles the "open_for_write_commit" request.
+! In this case, the "okay_to_commit" is simply set to .true. so "write_field"
+! (int_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( obuf(icurs/itypesize), hdrbufsize, itypesize, &
+                                              DataHandle , code )
+                  icurs = icurs + hdrbufsize
+                  okay_to_commit(DataHandle) = .true.
+
+! Every I/O server handles the "write_field" (int_field) request.
+! If okay_to_write(DataHandle) is .true. then the patch in the
+! header (bigbuf) is written to disk using pNetCDF.  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 servers will only see write_field (int_field)
+! requests AFTER an "iosync" request.
+                CASE ( int_field )
+                  CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
+                  CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize,  &
+                                                    DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, &
+                                                    DomainDesc , MemoryOrder , Stagger , DimNames ,              &
+                                                    DomainStart , DomainEnd ,                                    &
+                                                    MemoryStart , MemoryEnd ,                                    &
+                                                    PatchStart , PatchEnd )
+!write(0,*)' int_field ',TRIM(VarName),DataHandle,okay_to_write(DataHandle)
+                  icurs = icurs + hdrbufsize
+
+                  IF ( okay_to_write(DataHandle) ) THEN
+
+!!$                    WRITE(0,FMT="('>>> ',(A),1x,(A),1x,A2,I6,1x,3('[',I3,',',I3,'] '))") &
+!!$                          TRIM(DateStr), TRIM(VarName), TRIM(MemoryOrder), &
+!!$                        (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)*(PatchEnd(3)-PatchStart(3)+1), &
+!!$PatchStart(1),PatchEnd(1),PatchStart(2),PatchEnd(2),PatchStart(3),PatchEnd(3)
+!!$                    WRITE(0,FMT="('>>> ',(A),1x,(A),1x,I6,1x,3('[',I3,',',I3,'] '))") &
+!!$                          TRIM(DateStr), TRIM(VarName),  DomainDesc, &
+!!$                          DomainStart(1),DomainEnd(1),DomainStart(2),DomainEnd(2),DomainStart(3),DomainEnd(3)
+
+                    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
+
+#ifdef PNETCDF_QUILT
+!                      WRITE(mess,FMT="('>>> ',(A),1x,(A),1x,I6,1x,3('[',I3,',',I3,'] '))") &
+!                          TRIM(DateStr), TRIM(VarName),  DomainDesc, &
+!                          DomainStart(1),DomainEnd(1), &
+!                          DomainStart(2),DomainEnd(2),DomainStart(3),DomainEnd(3)
+!                      CALL wrf_message(mess)
+
+                      CALL store_patch_in_outbuf_pnc(obuf(icurs/itypesize), &
+                                                     dummybuf, TRIM(DateStr), &
+                                                     TRIM(VarName) , &
+                                                     FieldType,      &
+                                                     TRIM(MemoryOrder), &
+                                                     TRIM(Stagger), &
+                                                     DimNames, &
+                                                     DomainStart , DomainEnd ,&
+                                                     MemoryStart , MemoryEnd ,&
+                                                     PatchStart , PatchEnd )
+                      stored_write_record = .true.
+
+!!$                      IF(VarName .eq. "PSFC")THEN
+!!$                         CALL dump_real_array_c(obuf(icurs/itypesize), DomainStart,&
+!!$                                                DomainEnd, PatchStart, PatchEnd,   &
+!!$                                                mytask_local, DomainDesc)
+!!$                      ENDIF
+
+#endif
+                    ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+                      CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr )
+#ifdef PNETCDF_QUILT
+                      CALL store_patch_in_outbuf_pnc ( dummybuf, & 
+                                                   obuf(icurs/itypesize), &
+                                                   TRIM(DateStr), &
+                                                   TRIM(VarName) , &
+                                                   FieldType, &
+                                                   TRIM(MemoryOrder), &
+                                                   TRIM(Stagger), DimNames,  &
+                                                   DomainStart , DomainEnd , &
+                                                   MemoryStart , MemoryEnd , &
+                                                   PatchStart , PatchEnd )
+                      stored_write_record = .true.
+#endif
+                    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 ! Write metadata only (or do 'training'?)
+
+                    SELECT CASE (use_package(io_form(DataHandle)))
+
+#ifdef PNETCDF_QUILT
+                      CASE ( IO_PNETCDF )
+                        CALL ext_pnc_write_field ( handle(DataHandle) , TRIM(DateStr),        &
+                                   TRIM(VarName) , dummy , FieldType , mpi_comm_local , mpi_comm_local,         &
+                                   DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger), DimNames , &
+                                   DomainStart , DomainEnd ,                                  &
+                                   MemoryStart , MemoryEnd ,                                  &
+                                   PatchStart ,  PatchEnd,                                  &
+                                   Status )
+#endif
+#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 )
+                  CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, &
+                                            DataHandle , code )
+                  icurs = icurs + hdrbufsize
+                CASE DEFAULT
+                  WRITE(mess,*)'quilt: bad tag: ',                            &
+                               get_hdr_tag( obuf(icurs/itypesize) ),' icurs ',&
+                               icurs/itypesize
+                  CALL wrf_error_fatal( mess )
+              END SELECT
+
+            ENDDO !}
+! Now, we have finshed handling all commands from the latest
+! call to retrieve_pieces_of_field().
+
+            IF (stored_write_record) THEN
+! If any field patches have been stored in internal output buffers
+! (via a call to store_patch_in_outbuf_pnc()) then call write_outbuf_pnc() 
+! to write them to disk now.
+! NOTE that the I/O server will only have called
+! store_patch_in_outbuf() when handling write_field (int_field)
+! commands which only arrive AFTER an "iosync" command.
+!              CALL start_timing
+#ifdef PNETCDF_QUILT
+              CALL write_outbuf_pnc( handle(DataHandle), &
+                                     use_package(io_form(DataHandle)), &
+                                     mpi_comm_local, mytask_local,     &
+                                     ntasks_local_group) 
+#endif
+!              CALL end_timing( "quilt_pnc: call to write_outbuf_pnc" ) 
+              stored_write_record = .false.
+              written_record = .true.
+            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 PNETCDF_QUILT
+                CASE ( IO_PNETCDF   )
+                  CALL ext_pnc_inquire_filename( handle(DataHandle), fname, fstat, Status )
+                  IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
+                    CALL ext_pnc_open_for_write_commit(handle(DataHandle),Status)
+                    okay_to_write(DataHandle) = .true.
+                  ENDIF
+#endif
+#ifdef NETCDF
+                CASE ( IO_NETCDF   )
+                  CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status )
+                  IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN
+                    CALL ext_ncd_open_for_write_commit(handle(DataHandle),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
+!!endif
+
+! Retrieve header and all patches for the next field from the internal 
+! buffers.  
+        CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval )
+      END DO !}
+
+      DEALLOCATE( obuf )
+
+      ! flush output files if needed
+      IF (written_record) THEN
+!CALL start_timing
+        SELECT CASE ( use_package(io_form) )
+#ifdef PNETCDF_QUILT
+          CASE ( IO_PNETCDF   )
+            CALL ext_pnc_iosync( handle(DataHandle), Status )
+#endif
+          CASE DEFAULT
+            Status = 0
+        END SELECT
+        written_record = .false.
+!CALL end_timing( "quilt_pnc: flush" )
+      ENDIF
+
+      END DO ! }
+
+    END SUBROUTINE quilt_pnc
+
+! end of #endif of DM_PARALLEL
+#endif
+
+    SUBROUTINE init_module_wrf_quilt
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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
+#  if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT)
+      INTEGER thread_support_provided, thread_support_requested
+#endif
+      INTEGER mpi_comm_here
+      LOGICAL mpi_inited
+      LOGICAL esmf_coupling
+
+!TODO:  Change this to run-time switch
+#ifdef ESMFIO
+      esmf_coupling = .TRUE.
+#else
+      esmf_coupling = .FALSE.
+#endif
+
+      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 ( .NOT. mpi_inited ) THEN
+#  if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT)
+        thread_support_requested = MPI_THREAD_FUNNELED
+        CALL mpi_init_thread ( thread_support_requested, thread_support_provided, ierr )
+        IF ( thread_support_provided .lt. thread_support_requested ) THEN
+           CALL WRF_ERROR_FATAL( "failed to initialize MPI thread support")
+        ENDIF
+#  else
+        CALL mpi_init ( ierr )
+#  endif
+        CALL wrf_set_dm_communicator( MPI_COMM_WORLD )
+        CALL wrf_termio_dup
+      ENDIF
+      CALL wrf_get_dm_communicator( mpi_comm_here )
+
+      CALL MPI_Comm_rank ( mpi_comm_here, mytask, ierr ) ;
+      CALL mpi_x_comm_size ( mpi_comm_here, 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 )
+        IF ( esmf_coupling ) THEN
+          IF ( nio_tasks_per_group > 0 ) THEN
+            CALL wrf_error_fatal("frame/module_io_quilt.F: cannot use "// &
+                                 "ESMF coupling with quilt tasks") ;
+          ENDIF
+        ENDIF
+      ENDIF
+      CALL mpi_bcast( nio_tasks_per_group  , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr )
+      CALL mpi_bcast( nio_groups , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr )
+
+      CALL setup_quilt_servers( nio_tasks_per_group,            &
+                                mytask,               &
+                                ntasks,               &
+                                nio_groups,           &
+                                nio_tasks_in_group,   &
+                                mpi_comm_here,       &
+                                mpi_comm_local,       &
+                                mpi_comm_io_groups)
+
+       ! provide the communicator for the integration tasks to RSL
+       IF ( compute_node ) 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
+
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+
+SUBROUTINE disable_quilting
+!<DESCRIPTION>
+! Call this in programs that you never want to be quilting (e.g. real)
+! Must call before call to init_module_wrf_quilt().  
+!</DESCRIPTION>
+  USE module_wrf_quilt
+  disable_quilt = .TRUE.
+  RETURN
+END SUBROUTINE disable_quilting
+
+LOGICAL FUNCTION  use_output_servers()
+!<DESCRIPTION>
+! Returns .TRUE. if I/O quilt servers are in-use for write operations.
+! This routine is called only by client (compute) tasks.  
+!</DESCRIPTION>
+  USE module_wrf_quilt
+  use_output_servers = quilting_enabled
+  RETURN
+END FUNCTION use_output_servers
+
+LOGICAL FUNCTION  use_input_servers()
+!<DESCRIPTION>
+! Returns .TRUE. if I/O quilt servers are in-use for read operations.
+! This routine is called only by client (compute) tasks.  
+!</DESCRIPTION>
+  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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#if defined( DM_PARALLEL ) && !defined( STUBMPI )
+  USE module_wrf_quilt
+  USE module_state_description, ONLY: IO_PNETCDF
+  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
+  INTEGER, EXTERNAL :: use_package
+
+  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 )
+
+  SELECT CASE(use_package(io_form_arg))
+
+#ifdef PNETCDF_QUILT
+  CASE(IO_PNETCDF)
+     IF(compute_group_master(1)) THEN
+        CALL int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, &
+                                  locFileName,locSysDepInfo,io_form_arg,&
+                                  DataHandle )
+     ELSE
+        CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
+     END IF
+#endif
+  CASE DEFAULT
+
+     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
+
+  END SELECT
+
+  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 
+#ifdef PNETCDF_QUILT
+  IF ( compute_group_master(1) ) reduced(2) = i
+#else
+  IF ( wrf_dm_on_monitor() )  reduced(2) = i 
+#endif
+  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_debug(__FILE__,__LINE__, 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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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 )
+
+#ifdef PNETCDF_QUILT
+!ARP Only want one command to be received by each IO server when using
+!ARP parallel IO
+  IF(compute_group_master(1)) THEN
+     CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
+                                 DataHandle, int_open_for_write_commit )
+  ELSE
+     CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
+  END IF
+#else
+
+  IF ( wrf_dm_on_monitor() ) THEN
+     CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
+                                 DataHandle, int_open_for_write_commit )
+  ELSE
+     CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
+  ENDIF
+#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 
+#ifdef PNETCDF_QUILT
+  IF ( compute_group_master(1) ) reduced(2) = DataHandle
+#else
+  IF ( wrf_dm_on_monitor() )  reduced(2) = DataHandle
+#endif
+  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_debug(__FILE__,__LINE__, 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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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 , itypesize
+  INTEGER ierr, tasks_in_group, comm_io_group, dummy, i
+
+  CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_iosync' ) 
+
+!  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)
+
+!    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 
+#ifdef PNETCDF_QUILT
+! ARP Only want one command per IOServer if doing parallel IO
+    IF ( compute_group_master(1) ) reduced(2) = DataHandle
+#else
+    IF ( wrf_dm_on_monitor() )  reduced(2) = DataHandle
+#endif
+    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 )
+!    CALL end_timing("MPI_Reduce in wrf_quilt_iosync")
+
+    ! send data to the i/o processor
+#ifdef DEREF_KLUDGE
+    CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group,            &
+                          onebyte,                       &
+                          int_local_output_buffer(1), locsize , &
+                          dummy, 0 )
+#else
+    CALL collect_on_comm_debug(__FILE__,__LINE__, 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
+!  CALL end_timing("wrf_quilt_iosync")
+  Status = 0
+#endif
+  RETURN
+END SUBROUTINE wrf_quilt_iosync
+
+SUBROUTINE wrf_quilt_ioclose ( DataHandle, Status )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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 we're using pnetcdf then each IO server will need to receive the 
+! handle just once as there is
+! no longer a reduce over the IO servers to get it.
+#ifdef PNETCDF_QUILT
+  IF ( compute_group_master(1) )THEN
+     CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
+                                 DataHandle, int_ioclose )
+  ELSE
+     CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
+  ENDIF
+#else
+  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
+#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
+#ifdef PNETCDF_QUILT
+! If we're using pnetcdf then each IO server will need the handle as there is
+! no longer a reduce over the IO servers to get it.
+  IF ( compute_group_master(1) ) reduced(2) = DataHandle
+#else
+  IF ( wrf_dm_on_monitor() )  reduced(2) = DataHandle
+#endif
+  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_debug(__FILE__,__LINE__, 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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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 )
+
+!ARPDBG - potential bug. Have no access to what type of IO is being used for
+! this data so if PNETCDF_QUILT is defined then we assume that's what's being used.
+#ifdef PNETCDF_QUILT
+!ARP Send the ioexit message just once to each IOServer when using parallel IO
+  IF( compute_group_master(1) ) THEN
+     CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, &
+                                 DataHandle, int_ioexit )
+  ELSE
+     CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
+  END IF
+#else
+
+  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
+#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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#if defined( DM_PARALLEL ) && !defined( STUBMPI )
+  USE module_wrf_quilt
+  USE module_state_description, ONLY: IO_PNETCDF
+  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
+  INTEGER, EXTERNAL       :: use_package
+!
+  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
+
+!ARPDBG - potential bug. Have no access to what type of IO is being used for
+! this data so if PNETCDF_QUILT is defined then we assume that's what's being used.
+#ifdef PNETCDF_QUILT
+      IF(compute_group_master(1) )THEN
+! ARPDBG - actually only want to send one time header to each IO server as 
+! can't tell that's what they are on the IO servers themselves
+         CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
+                                      DataHandle, "TIMESTAMP", "", Data, int_set_time )
+      ELSE
+         CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
+      END IF
+#else
+      IF ( wrf_dm_on_monitor() ) THEN
+         CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, &
+                                      DataHandle, "TIMESTAMP", "", Data, int_set_time )
+      ELSE
+         CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize )
+      ENDIF
+#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 )
+
+      ! 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 
+#ifdef PNETCDF_QUILT
+      IF ( compute_group_master(1) ) reduced(2) = DataHandle
+#else
+      IF ( wrf_dm_on_monitor() )  reduced(2) = DataHandle
+#endif
+      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_debug(__FILE__,__LINE__, 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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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 )
+
+#ifdef PNETCDF_QUILT
+      IF ( compute_group_master(1) ) 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
+#else
+      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
+#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 
+#ifdef PNETCDF_QUILT
+      IF( compute_group_master(1) )  reduced(2) = DataHandle
+#else
+      IF ( wrf_dm_on_monitor() )  reduced(2) = DataHandle
+#endif
+      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_debug(__FILE__,__LINE__, 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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#if defined( DM_PARALLEL ) && !defined( STUBMPI )
+  USE module_wrf_quilt
+  USE module_state_description, ONLY: IO_PNETCDF
+  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
+  INTEGER, EXTERNAL :: use_package
+!
+
+!!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 )
+
+!ARPDBG - potential bug. Have no access to what type of IO is being used for
+! this data so if PNETCDF_QUILT is defined then we assume that's what's being used.
+#ifdef PNETCDF_QUILT
+      IF ( compute_group_master(1) )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
+#else
+      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
+#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 
+#ifdef PNETCDF_QUILT
+      IF ( compute_group_master(1) ) reduced(2) = DataHandle
+#else
+      IF ( wrf_dm_on_monitor() )  reduced(2) = DataHandle
+#endif
+      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_debug(__FILE__,__LINE__, 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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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 )
+
+!ARPDBG - potential bug. Have no access to what type of IO is being used for
+! this data so if PNETCDF_QUILT is defined then we assume that's what's being used.
+#ifdef PNETCDF_QUILT
+      IF(compute_group_master(1))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 )
+      END IF
+#else
+      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
+#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 
+#ifdef PNETCDF_QUILT
+      IF(compute_group_master(1))    reduced(2) = DataHandle
+#else
+      IF ( wrf_dm_on_monitor() )  reduced(2) = DataHandle
+#endif
+!call mpi_comm_rank( comm_io_group , me, ierr )
+
+      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_debug(__FILE__,__LINE__, 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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+
+#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 )
+
+#ifdef PNETCDF_QUILT
+      IF ( compute_group_master(1) ) 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
+#else
+      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
+#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 
+#ifdef PNETCDF_QUILT
+      IF ( compute_group_master(1) ) reduced(2) = DataHandle
+#else
+      IF ( wrf_dm_on_monitor() )  reduced(2) = DataHandle
+#endif
+      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_debug(__FILE__,__LINE__, 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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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)
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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, itypesize
+  INTEGER ierr, tasks_in_group, comm_io_group, dummy, i
+  INTEGER, EXTERNAL :: use_package
+
+!!ARPTIMING  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, itypesize, 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, itypesize, 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 0
+      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, itypesize )
+      ENDIF
+#endif
+
+
+!!ARPTIMING      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 
+#ifdef PNETCDF_QUILT
+      IF ( compute_group_master(1) ) reduced(2) = DataHandle
+#else
+      IF ( wrf_dm_on_monitor() )  reduced(2) = DataHandle
+#endif
+      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 )
+!!ARPTIMING      CALL end_timing("MPI_Reduce in wrf_quilt_write_field dryrun")
+      ! send data to the i/o processor
+
+      CALL collect_on_comm_debug(__FILE__,__LINE__, 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)/itypesize ), Stat=ierr )
+      IF(ierr /= 0)THEN
+         CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: allocate of int_local_output_buffer failed" )
+      END IF
+      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, itypesize, 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
+!!ARPTIMING  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 )
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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 )
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+#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
+
+SUBROUTINE collect_on_comm_debug(file,line, comm_io_group,   &
+                        sze,                                 &
+                        hdrbuf, hdrbufsize ,                 &
+                        outbuf, outbufsize                   )
+  IMPLICIT NONE
+  CHARACTER*(*) file
+  INTEGER line
+  INTEGER comm_io_group
+  INTEGER sze
+  INTEGER hdrbuf(*), outbuf(*)
+  INTEGER hdrbufsize, outbufsize 
+
+  !write(0,*)'collect_on_comm_debug ',trim(file),line,sze,hdrbufsize,outbufsize
+  CALL collect_on_comm( comm_io_group,                       &
+                        sze,                                 &
+                        hdrbuf, hdrbufsize ,                 &
+                        outbuf, outbufsize                   )
+  !write(0,*)trim(file),line,'returning'
+  RETURN
+END
+
+
+SUBROUTINE collect_on_comm_debug2(file,line,var,tag,sz,hdr_rec_size, &
+                        comm_io_group,                       &
+                        sze,                                 &
+                        hdrbuf, hdrbufsize ,                 &
+                        outbuf, outbufsize                   )
+  IMPLICIT NONE
+  CHARACTER*(*) file,var
+  INTEGER line,tag,sz,hdr_rec_size
+  INTEGER comm_io_group
+  INTEGER sze
+  INTEGER hdrbuf(*), outbuf(*)
+  INTEGER hdrbufsize, outbufsize
+
+!  write(0,*)'collect_on_comm_debug2 ',trim(file),line,trim(var),tag,sz,hdr_rec_size,sze,hdrbufsize,outbufsize
+  CALL collect_on_comm( comm_io_group,                       &
+                        sze,                                 &
+                        hdrbuf, hdrbufsize ,                 &
+                        outbuf, outbufsize                   )
+!  write(0,*)'collect_on_comm_debug2 ',trim(file),line,'returning for ',trim(var)
+  RETURN
+END
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_machine.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_machine.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_machine.F	(revision 17)
@@ -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      (p<bl) THEN
+     ret = 0
+   ELSE IF (p>maxi-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
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_nesting.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_nesting.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_nesting.F	(revision 17)
@@ -0,0 +1,93 @@
+!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_ret , kid_ret )
+      IMPLICIT NONE
+      TYPE(domain) , INTENT(IN)  :: parent
+      INTEGER, INTENT(OUT)       :: nestid_ret , kid_ret
+      ! Local data
+      INTEGER                    :: parent_id
+      INTEGER                    :: nestid, kid
+      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
+      LOGICAL                    :: grid_allowed
+      TYPE (WRFU_Time)           :: nest_start, nest_stop
+!#define STUB_FOR_NOW
+#ifndef STUB_FOR_NOW
+      nestid_ret = 0
+      kid_ret = 0
+      nests_to_open = .false.
+      CALL nl_get_max_dom( 1, max_dom )
+#if (NMM_CORE == 1)
+# if (NMM_NEST == 0)
+      IF ( max_dom > 1 ) THEN
+        CALL wrf_error_fatal( 'WRF-NMM compiled without nesting; set max_dom to 1 in namelist.input' )
+      END IF
+# endif
+#endif
+      DO nestid = 2, max_dom
+        CALL nl_get_grid_allowed( nestid, grid_allowed )
+        IF ( .NOT. active_domain( nestid ) .AND. grid_allowed ) 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.
+                  nestid_ret = nestid
+                  kid_ret = kid
+                  nests_to_open = .TRUE.
+                  RETURN
+                END IF
+              END DO
+            END IF
+          END IF
+        END IF
+      END DO
+#else
+      nestid_ret = 0
+      kid_ret = 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
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_quilt_outbuf_ops.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_quilt_outbuf_ops.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_quilt_outbuf_ops.F	(revision 17)
@@ -0,0 +1,1495 @@
+MODULE module_quilt_outbuf_ops
+!<DESCRIPTION>
+!<PRE>
+! This module contains routines and data structures used by the I/O quilt 
+! servers to assemble fields ("quilting") and write them to disk.  
+!</PRE>
+!</DESCRIPTION>
+  INTEGER, PARAMETER :: tabsize = 1000
+  INTEGER, SAVE      :: num_entries
+
+! ARP, for PNC-enabled quilting, 02/06/2010
+  TYPE varpatch
+    LOGICAL                            :: forDeletion ! TRUE if patch to be 
+                                                      ! deleted
+    INTEGER, DIMENSION(3)              :: PatchStart, PatchEnd, PatchExtent
+    REAL,    POINTER, DIMENSION(:,:,:) :: rptr 
+    INTEGER, POINTER, DIMENSION(:,:,:) :: iptr
+  END TYPE varpatch
+
+  ! With PNC-enabled quilting, each table entry consists of a series of
+  ! 'npatch' patches (one for each of the compute PEs that this IOServer has
+  ! as clients). We attempt to stitch these together before finally 
+  ! writing the data to disk.
+  TYPE outpatchlist
+    CHARACTER*80                       :: VarName, DateStr, MemoryOrder, &
+                                          Stagger, DimNames(3)
+    INTEGER, DIMENSION(3)              :: DomainStart, DomainEnd
+    INTEGER                            :: FieldType
+    ! Total no. of patches in the list PatchList
+    INTEGER                            :: nPatch
+    ! How many of the patches remain active in PatchList
+    INTEGER                            :: nActivePatch
+    TYPE(varpatch), DIMENSION(tabsize) :: PatchList
+  END TYPE outpatchlist
+
+  TYPE(outpatchlist), DIMENSION(tabsize), SAVE :: outpatch_table
+
+  ! List of which of the initial set of patches saved by the IOServer have 
+  ! been successfully stitched together. Without any stitching, each patch's 
+  ! entry contains just itself:
+  !   JoinedPatches(1,ipatch) = ipatch
+  ! If jpatch is then stitched to ipatch then we do:
+  !   JoinedPatches(2,ipatch) = jpatch
+  ! and so on.
+  INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE :: JoinedPatches 
+ 
+  ! The no. of original patches to be stitched together to make each new patch
+  ! i.e. if the 2nd new patch consists of 4 of the original patches stitched
+  ! together then:
+  !   PatchCount(2) = 4
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE   :: PatchCount
+
+! endARP, for PNC-enabled quilting, 02/06/2010
+
+  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
+!<DESCRIPTION>
+!<PRE>
+! This routine re-initializes module data structures.  
+!</PRE>
+!</DESCRIPTION>
+    IMPLICIT NONE
+    INTEGER :: i, j
+    DO i = 1, tabsize
+
+#ifdef PNETCDF_QUILT
+      ! This section for PNC-enabled IO quilting
+      outpatch_table(i)%VarName = ""
+      outpatch_table(i)%DateStr = ""
+      outpatch_table(i)%MemoryOrder = ""
+      outpatch_table(i)%Stagger = ""
+      outpatch_table(i)%DimNames(1:3) = ""
+      outpatch_table(i)%DomainStart(1:3) = 0
+      outpatch_table(i)%DomainEnd(1:3)   = 0
+      outpatch_table(i)%npatch           = 0
+      outpatch_table(i)%nActivePatch     = 0
+      ! We don't free any memory here - that is done immediately after the
+      ! write of each patch is completed
+      DO j = 1, tabsize
+         outpatch_table(i)%PatchList(j)%forDeletion   = .FALSE.
+         outpatch_table(i)%PatchList(j)%PatchStart(:) = 0
+         outpatch_table(i)%PatchList(j)%PatchEnd(:)   = 0
+         outpatch_table(i)%PatchList(j)%PatchExtent(:)= 0
+         NULLIFY( outpatch_table(i)%PatchList(j)%rptr )
+         NULLIFY( outpatch_table(i)%PatchList(j)%iptr )
+      END DO
+#else
+      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 )
+#endif
+
+    ENDDO
+    num_entries = 0
+  END SUBROUTINE init_outbuf
+
+#ifdef PNETCDF_QUILT
+  SUBROUTINE write_outbuf_pnc ( DataHandle, io_form_arg, local_comm, &
+                                mytask, ntasks )
+!<DESCRIPTION>
+!<PRE>
+! This routine writes all of the records stored in outpatch_table to the 
+! file referenced by DataHandle using pNetCDF. The patches constituting
+! each record are stitched together as far as is possible before
+! the pNetCDF I/O routines are called to accomplish the write.
+! 
+! It then re-initializes module data structures.  
+!</PRE>
+!</DESCRIPTION>
+    USE module_state_description
+    IMPLICIT NONE
+    INCLUDE 'mpif.h'
+#include "wrf_io_flags.h"
+    INTEGER , INTENT(IN)  :: DataHandle, io_form_arg, &
+                             local_comm, mytask, ntasks
+    INTEGER               :: ii, jj
+    INTEGER               :: DomainDesc ! dummy
+    INTEGER               :: Status
+    INTEGER               :: ipatch, icnt
+ !   INTEGER, DIMENSION(1) :: count_in, count_out
+    INTEGER, ALLOCATABLE, DIMENSION(:) :: count_buf
+    INTEGER               :: min_count
+    LOGICAL               :: do_indep_write ! If no. of patches differs between
+                                            ! IO Servers then we will have to 
+                                            ! switch pnetcdf into 
+                                            ! independent-writes mode for some 
+                                            ! of them
+    CHARACTER*256         :: mess
+
+    DomainDesc = 0 
+
+    ALLOCATE(count_buf(ntasks), Stat=Status)
+    IF(Status /= 0)THEN
+       CALL wrf_error_fatal("write_outbuf_pnc: allocate failed")
+    END IF
+
+    WRITE(mess,"('write_outbuf_pnc: table has ', I3,' entries')") num_entries
+    CALL wrf_message(mess)
+
+    DO ii = 1, num_entries
+
+      WRITE(mess,*)'write_outbuf_pnc: writing ', &
+                    TRIM(outpatch_table(ii)%DateStr)," ",                    &
+                    TRIM(outpatch_table(ii)%VarName)," ",                    &
+                    TRIM(outpatch_table(ii)%MemoryOrder)
+      CALL wrf_message(mess)
+
+      SELECT CASE ( io_form_arg )
+
+        CASE ( IO_PNETCDF   )
+
+          ! Situation is more complicated in this case since field data stored 
+          ! as a list of patches rather than in one array of global-domain 
+          ! extent.
+          ! PatchStart(1) - PatchEnd(1) is dimension with unit stride.
+
+          ! Quilt patches back together where possible in order to minimise 
+          ! number of individual writes
+          CALL stitch_outbuf_patches(ii)
+
+          ! Check how many patches each of the other IO servers has - we can
+          ! only use pNetCDF in collective mode for the same no. of writes
+          ! on each IO server. Any other patches will have to be written in
+          ! independent mode.
+!!$          count_in(1) = outpatch_table(ii)%npatch
+!!$          CALL MPI_AllReduce( count_in, count_out, 1, MPI_INTEGER,  &
+!!$                              MPI_MIN, local_comm, Status )
+!!$          WRITE(mess,*) 'ARPDBG: Min. no. of patches is ',count_out(1)
+!!$          CALL wrf_message(mess)
+!!$          WRITE(mess,*) 'ARPDBG: I have ',count_in(1),' patches.'
+!!$          CALL wrf_message(mess)
+          do_indep_write = .FALSE.
+          count_buf(:) = 0
+          min_count = outpatch_table(ii)%nActivePatch
+!          WRITE(mess,*) 'ARPDBG: before gather, I have ',min_count,' patches.'
+!          CALL wrf_message(mess)
+
+          CALL MPI_AllGather(min_count, 1, MPI_INTEGER,      &
+	                     count_buf, 1, MPI_INTEGER, &
+	                     local_comm, Status)
+!          count_buf(mytask+1) = outpatch_table(ii)%npatch
+!          CALL MPI_AllGather(MPI_IN_PLACE,0, MPI_DATATYPE_NULL, &
+!	                     count_buf, ntasks, MPI_INTEGER,    &
+!	                     local_comm, Status)
+
+          ! Work out the minimum no. of patches on any IO Server and whether 
+          ! or not we will have to enter independent IO mode.
+          min_count = outpatch_table(ii)%nActivePatch
+          DO jj=1,ntasks, 1
+             IF(count_buf(jj) < min_count) min_count = count_buf(jj)
+             IF(outpatch_table(ii)%npatch /= count_buf(jj)) do_indep_write = .TRUE.
+
+          END DO
+
+!          WRITE(mess,*) 'ARPDBG: Min. no. of patches is ', min_count
+!          CALL wrf_message(mess)
+!          WRITE(mess,*) 'ARPDBG: I have ',count_buf(mytask+1),' patches.'
+!          CALL wrf_message(mess)
+
+!          WRITE(mess,"('Field: ',I3, ' domain start = ',3I4)")  ii, outpatch_table(ii)%DomainStart(1:3)
+!          CALL wrf_message(mess)
+!          WRITE(mess,"(10x,' domain end   = ',3I4)")  outpatch_table(ii)%DomainEnd(1:3)
+!          CALL wrf_message(mess)
+
+          IF ( outpatch_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
+             
+             ! Loop over the patches in this field up to the number that 
+             ! every IO Server has. This is slightly tricky now
+             ! that some of them may be 'deleted.' 
+
+             ipatch = 0
+             icnt = 0
+             DO WHILE ( icnt < min_count )
+
+                ipatch = ipatch + 1
+
+                IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE
+
+                icnt = icnt + 1
+
+                WRITE (mess, "('Calling write for patch: ',I3, ' Start = ',3I4)") ipatch, outpatch_table(ii)%PatchList(ipatch)%PatchStart(1:3)
+                CALL wrf_message(mess)
+                WRITE (mess,"(29x,'End = ',3I4)") outpatch_table(ii)%PatchList(ipatch)%PatchEnd(1:3)
+                CALL wrf_message(mess)
+
+                CALL ext_pnc_write_field ( DataHandle ,                          &
+                                 TRIM(outpatch_table(ii)%DateStr),               &
+                                 TRIM(outpatch_table(ii)%VarName),               &
+                                 outpatch_table(ii)%PatchList(ipatch)%rptr,      &
+                                 outpatch_table(ii)%FieldType,                   &!*
+                                 local_comm, local_comm, DomainDesc ,            &
+                                 TRIM(outpatch_table(ii)%MemoryOrder),           &
+                                 TRIM(outpatch_table(ii)%Stagger),               &!*
+                                 outpatch_table(ii)%DimNames ,                   &!*
+                                 outpatch_table(ii)%DomainStart,                 &
+                                 outpatch_table(ii)%DomainEnd,                   &
+                                 ! ARP supply magic number as MemoryStart and 
+                                 ! MemoryEnd to signal that this routine is 
+                                 ! being called from quilting.
+                                 -998899,                                        &
+                                 -998899,                                        &
+                                 outpatch_table(ii)%PatchList(ipatch)%PatchStart,&
+                                 outpatch_table(ii)%PatchList(ipatch)%PatchEnd,  &
+                                 Status )
+
+                ! Free memory associated with this patch
+                DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%rptr)
+
+             END DO
+
+             IF( do_indep_write )THEN
+                ! We must do the next few patches (if any) in independent IO 
+                ! mode as not all of the IO Servers have the same no. of 
+                ! patches. 
+                ! outpatch_table(ii)%npatch holds the no. of live patches for 
+                ! this IO Server
+
+                CALL ext_pnc_start_independent_mode(DataHandle, Status)
+
+                DO WHILE ( icnt<outpatch_table(ii)%nActivePatch )
+
+                   ipatch = ipatch + 1
+
+                   IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE
+
+                   icnt = icnt + 1
+
+                   CALL ext_pnc_write_field ( DataHandle ,                          &
+                                 TRIM(outpatch_table(ii)%DateStr),               &
+                                 TRIM(outpatch_table(ii)%VarName),               &
+                                 outpatch_table(ii)%PatchList(ipatch)%rptr,      &
+                                 outpatch_table(ii)%FieldType,                   &!*
+                                 local_comm, local_comm, DomainDesc ,                      &
+                                 TRIM(outpatch_table(ii)%MemoryOrder),           &
+                                 TRIM(outpatch_table(ii)%Stagger),               &!*
+                                 outpatch_table(ii)%DimNames ,                   &!*
+                                 outpatch_table(ii)%DomainStart,                 &
+                                 outpatch_table(ii)%DomainEnd,                   &
+                                 ! ARP supply magic number as MemoryStart and 
+                                 ! MemoryEnd to signal that this routine is 
+                                 ! being called from quilting.
+                                 -998899,                                        &
+                                 -998899,                                        &
+                                 outpatch_table(ii)%PatchList(ipatch)%PatchStart,&
+                                 outpatch_table(ii)%PatchList(ipatch)%PatchEnd,  &
+                                 Status )
+
+                   ! Free memory associated with this patch
+                   DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%rptr)
+
+                END DO
+
+                ! End of patches that not every IO Server has so can switch
+                ! back to collective mode.
+                CALL ext_pnc_end_independent_mode(DataHandle, Status)
+
+
+             END IF ! Additional patches
+
+          ELSE IF ( outpatch_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
+
+             ! Loop over the patches in this field up to the number that 
+             ! every IO Server has. This is slightly tricky now
+             ! that some of them may be 'deleted.' 
+             ipatch = 0
+             icnt = 0
+             DO WHILE ( icnt < min_count )
+
+                ipatch = ipatch + 1
+
+                IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE
+
+                icnt = icnt + 1
+
+                CALL ext_pnc_write_field ( DataHandle ,                           &
+                                 TRIM(outpatch_table(ii)%DateStr),                &
+                                 TRIM(outpatch_table(ii)%VarName),                &
+                                 outpatch_table(ii)%PatchList(ipatch)%iptr,       &
+                                 outpatch_table(ii)%FieldType,                    &!*
+                                 local_comm, local_comm, DomainDesc,              &
+                                 TRIM(outpatch_table(ii)%MemoryOrder),            &
+                                 TRIM(outpatch_table(ii)%Stagger),                &!*
+                                 outpatch_table(ii)%DimNames ,                    &!*
+                                 outpatch_table(ii)%DomainStart,                  &
+                                 outpatch_table(ii)%DomainEnd,                    &
+                                 ! ARP supply magic number as MemoryStart and 
+                                 ! MemoryEnd to signal that this routine is 
+                                 ! being called from quilting.
+                                 -998899,                                         &
+                                 -998899,                                         &
+                                 outpatch_table(ii)%PatchList(ipatch)%PatchStart, &
+                                 outpatch_table(ii)%PatchList(ipatch)%PatchEnd,   &
+                                 Status )
+
+                ! Free memory associated with this patch
+                DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%iptr)
+
+             END DO
+
+             IF( do_indep_write )THEN
+
+                ! We have to do the next few patches in independent IO mode as 
+                ! not all of the IO Servers have this many patches. 
+                ! outpatch_table(ii)%npatch holds the no. of live patches for 
+                ! this IO Server
+                CALL ext_pnc_start_independent_mode(DataHandle, Status)
+
+                DO WHILE ( icnt<outpatch_table(ii)%nActivePatch )
+
+                   ipatch = ipatch + 1
+
+                   IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE
+
+                   icnt = icnt + 1
+
+                   CALL ext_pnc_write_field ( DataHandle ,                          &
+                                 TRIM(outpatch_table(ii)%DateStr),               &
+                                 TRIM(outpatch_table(ii)%VarName),               &
+                                 outpatch_table(ii)%PatchList(ipatch)%iptr,      &
+                                 outpatch_table(ii)%FieldType,                   &!*
+                                 local_comm, local_comm, DomainDesc ,                      &
+                                 TRIM(outpatch_table(ii)%MemoryOrder),           &
+                                 TRIM(outpatch_table(ii)%Stagger),               &!*
+                                 outpatch_table(ii)%DimNames ,                   &!*
+                                 outpatch_table(ii)%DomainStart,                 &
+                                 outpatch_table(ii)%DomainEnd,                   &
+                                 ! ARP supply magic number as MemoryStart and 
+                                 ! MemoryEnd to signal that this routine is 
+                                 ! being called from quilting.
+                                 -998899,                                        &
+                                 -998899,                                        &
+                                 outpatch_table(ii)%PatchList(ipatch)%PatchStart,&
+                                 outpatch_table(ii)%PatchList(ipatch)%PatchEnd,  &
+                                 Status )
+
+                   ! Free memory associated with this patch
+                   DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%iptr)
+
+                END DO
+
+                ! End of patches that not every IO Server has so can switch
+                ! back to collective mode.
+                CALL ext_pnc_end_independent_mode(DataHandle, Status)
+
+             ENDIF ! Have additional patches
+          ENDIF
+
+        CASE DEFAULT
+      END SELECT
+
+    ENDDO ! Loop over output buffers
+
+    ! Reset the table of output buffers
+    CALL init_outbuf()
+
+    DEALLOCATE(count_buf)
+
+  END SUBROUTINE write_outbuf_pnc
+#endif
+
+  SUBROUTINE write_outbuf ( DataHandle , io_form_arg )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+    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*256         :: 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
+
+
+  SUBROUTINE stitch_outbuf_patches(ibuf)
+    USE module_timing
+    IMPLICIT none
+    INTEGER, INTENT(in) :: ibuf
+!<DESCRIPTION>
+!<PRE>
+! This routine does the "output quilting" for the case where quilting has been
+! built to use Parallel NetCDF. Unlike store_patch_in_outbuf() we do not have
+! data for the whole domain --- instead we aim to quilt as much of the data as
+! possible in order to reduce the number of separate writes that we must do.
+!</PRE>
+!</DESCRIPTION>
+#include "wrf_io_flags.h"
+    INTEGER                              :: ipatch, jpatch, ii
+    INTEGER                              :: ierr
+    INTEGER                              :: npatches
+    INTEGER,              DIMENSION(3)   :: newExtent, pos
+    INTEGER, ALLOCATABLE, DIMENSION(:,:) :: OldPatchStart
+    INTEGER, POINTER,   DIMENSION(:,:,:) :: ibuffer
+    REAL,    POINTER,   DIMENSION(:,:,:) :: rbuffer
+    CHARACTER*256                        :: mess
+integer i,j
+
+!    CALL start_timing()
+
+    IF(LEN_TRIM(outpatch_table(ibuf)%MemoryOrder) < 2)THEN
+       ! This field is a scalar or 1D array. Such quantities are replicated
+       ! across compute nodes and therefore we need only keep a single
+       ! patch - delete all but the first in the list
+      IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_FLOAT ) THEN
+
+          DO jpatch=2,outpatch_table(ibuf)%npatch,1
+             outpatch_table(ibuf)%PatchList(jpatch)%forDeletion = .TRUE.
+             outpatch_table(ibuf)%nActivePatch = &
+                                 outpatch_table(ibuf)%nActivePatch - 1
+             DEALLOCATE(outpatch_table(ibuf)%PatchList(jpatch)%rptr)
+          END DO
+
+      ELSE IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_INTEGER ) THEN
+
+          DO jpatch=2,outpatch_table(ibuf)%npatch,1
+             outpatch_table(ibuf)%PatchList(jpatch)%forDeletion = .TRUE.
+             outpatch_table(ibuf)%nActivePatch = &
+                                 outpatch_table(ibuf)%nActivePatch - 1
+             DEALLOCATE(outpatch_table(ibuf)%PatchList(jpatch)%iptr)
+          END DO
+
+      ELSE
+         CALL wrf_error_fatal("stitch_outbuf_patches: unrecognised Field Type")
+      END IF
+
+
+!     CALL end_timing("stitch_outbuf_patches: deleting replicated patches")
+
+      RETURN
+
+    END IF ! Field is scalar or 1D
+
+    ! Otherwise, this field _is_ distributed across compute PEs and therefore
+    ! it's worth trying to stitch patches together...
+    ALLOCATE(OldPatchStart(3,outpatch_table(ibuf)%npatch), &
+             JoinedPatches(outpatch_table(ibuf)%npatch,    &
+                           outpatch_table(ibuf)%npatch),   &
+             PatchCount(outpatch_table(ibuf)%npatch),      &
+             Stat=ierr)
+    IF(ierr /= 0)THEN
+       CALL wrf_message('stitch_outbuf_patches: unable to stitch patches as allocate failed.')
+       RETURN
+    END IF
+
+    JoinedPatches(:,:) = -1
+    NULLIFY(ibuffer)
+    NULLIFY(rbuffer)
+
+#if 0
+!    ! ARPDBG
+    WRITE(mess,*) "--------------------------"
+    CALL wrf_message(mess)
+    WRITE(mess,"('Field ',I3,': domain end = ', 3I4)") &
+                  ibuf, outpatch_table(ibuf)%DomainEnd(1:3)
+    CALL wrf_message(mess)
+    WRITE(mess,*) "stitch_outbuf_patches: initial list of patches:"
+    CALL wrf_message(mess)
+
+    DO jpatch=1,outpatch_table(ibuf)%npatch,1
+
+       ! Each patch consists of just itself initially
+       JoinedPatches(1,jpatch) = jpatch
+       PatchCount(jpatch) = 1
+
+       ! Store the location of each patch for use after we've decided how to 
+       ! stitch them together
+       OldPatchStart(:,jpatch) = outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:)
+
+       WRITE(mess,"('Patch ',I3,': [',I3,': ',I3,'],[',I3,':',I3,'],[',I3,':',I3,']')") jpatch,  &
+             outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1), &
+             outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1),   &
+             outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2), &
+             outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2),   &
+             outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3), &
+             outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)
+       CALL wrf_message(mess)
+    END DO
+    WRITE(mess,*) "--------------------------"
+    CALL wrf_message(mess)
+    ! ARPDBGend
+#endif
+
+    ! Search through patches to find pairs that we can stitch together
+    ipatch = 1
+    OUTER: DO WHILE(ipatch < outpatch_table(ibuf)%npatch)
+
+       IF( outpatch_table(ibuf)%PatchList(ipatch)%forDeletion )THEN
+          ipatch = ipatch + 1
+          CYCLE OUTER
+       END IF
+
+       INNER: DO jpatch=ipatch+1,outpatch_table(ibuf)%npatch,1
+
+          IF(outpatch_table(ibuf)%PatchList(ipatch)%forDeletion )THEN
+             CYCLE INNER
+          END IF
+
+          ! Look for patches that can be concatenated with ipatch in the first
+          ! dimension (preferred since that is contiguous in memory in F90)
+          !  ________________         ____________  
+          !  |               |        |           |
+          ! Startx(j)     Endx(j) Startx(i)   Endx(i)
+          !
+          IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1) == &
+              (outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) - 1) )THEN
+
+             ! Patches contiguous in first dimension - do they have the same
+             ! extents in the other two dimensions?
+             IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
+		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)  ==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)   ) .AND.&
+                 (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
+		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)  ==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN
+		
+                ! We can concatenate these two patches in first dimension
+!                WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 1')") ipatch, jpatch
+!                CALL wrf_message(mess)
+
+                ! Grow patch ipatch to include jpatch
+                outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) = &
+                         outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)
+                CALL merge_patches(ibuf, ipatch, jpatch)
+                ! Go again...
+!                CALL wrf_message('Re-starting search...')
+                ipatch = 1
+                CYCLE OUTER
+             END IF
+          END IF
+          !  ______________         ____________  
+          !  |             |        |           |
+          ! Startx(i)    Endx(i) Startx(j)   Endx(j)
+          !
+          IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1) == &
+             (outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1) + 1))THEN
+
+             ! Patches contiguous in first dimension - do they have the same
+             ! extents in the other two dimensions?
+             IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
+		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)  ==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)   ) .AND.&
+                 (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
+		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)  ==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN
+
+                 ! We can concatenate these two patches in first dimension
+!                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 1')") ipatch, jpatch
+!                 CALL wrf_message(mess)
+
+		! Grow patch ipatch to include jpatch
+                outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1) = &
+                        outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)
+                CALL merge_patches(ibuf, ipatch, jpatch)
+                ! Go again...
+!                CALL wrf_message('Re-starting search...')
+		ipatch = 1
+		CYCLE OUTER
+              END IF
+           END IF
+
+           ! Try the second dimension
+           IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2) == &
+                (outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) - 1))THEN
+
+              ! Patches contiguous in second dimension - do they have the same
+              ! extents in the other two dimensions?
+              IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)==     &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
+		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)  ==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1)   ) .AND.&
+                 (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
+		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)  ==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN
+
+                 ! We can concatenate these two patches in second dimension
+!                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 2')") ipatch, jpatch
+!                 CALL wrf_message(mess)
+
+                 ! Grow patch ipatch to include jpatch
+                 outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) = &
+                         outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)
+                 CALL merge_patches(ibuf, ipatch, jpatch)
+                 ! Go again...
+!                 CALL wrf_message('Re-starting search...')
+                 ipatch = 1
+                 CYCLE OUTER
+              END IF
+           END IF
+
+           IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2) == &
+                (outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2) + 1) )THEN
+
+              ! Patches contiguous in second dimension - do they have the same
+              ! extents in the other two dimensions?
+              IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)==     &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
+		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)  ==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1)   ) .AND.&
+                 (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
+		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)  ==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN
+
+                 ! We can concatenate these two patches in second dimension
+!                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 2')") ipatch, jpatch
+!                 CALL wrf_message(mess)
+
+                 ! Grow patch ipatch to include jpatch
+                 outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2) = &
+                         outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)
+                 CALL merge_patches(ibuf, ipatch, jpatch)
+                 ! Go again...
+!                 CALL wrf_message('Re-starting search...')
+                 ipatch = 1
+                 CYCLE OUTER                 
+              END IF
+           END IF
+
+           ! Try the third dimension
+           IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3) == &
+               (outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) - 1) )THEN
+
+              ! Patches contiguous in second dimension - do they have the same
+              ! extents in the other two dimensions?
+              IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)==     &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
+		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)  ==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1)   ) .AND.&
+                 (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
+		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)  ==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)) )THEN
+
+                 ! We can concatenate these two patches in the third dimension
+!                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 3')") ipatch, jpatch
+!                 CALL wrf_message(mess)
+
+                 ! Grow patch ipatch to include jpatch
+                 outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) = &
+                         outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)
+                 CALL merge_patches(ibuf, ipatch, jpatch)
+                 ! Go again...
+!                 CALL wrf_message('Re-starting search...')
+                 ipatch = 1
+                 CYCLE OUTER                 
+              END IF
+           END IF
+
+           IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3) == &
+                (outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3) + 1))THEN
+
+              ! Patches contiguous in second dimension - do they have the same
+              ! extents in the other two dimensions?
+              IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)==     &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
+		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)  ==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1)   ) .AND.&
+                 (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
+		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)  ==      &
+                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)) )THEN
+
+                 ! We can concatenate these two patches in the third dimension
+!                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 3')") ipatch, jpatch
+!                 CALL wrf_message(mess)
+
+                 ! Grow patch ipatch to include jpatch
+                 outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3) = &
+                         outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)
+                 CALL merge_patches(ibuf, ipatch, jpatch)
+                 ! Go again...
+!                 CALL wrf_message('Re-starting search...')
+                 ipatch = 1
+                 CYCLE OUTER                 
+              END IF
+           END IF
+
+       END DO INNER
+
+       ipatch = ipatch + 1
+
+    END DO OUTER
+
+#if 0
+    ! ARPDBG
+    CALL wrf_message("--------------------------")
+    CALL wrf_message("Final list of patches:")
+
+    npatches = 0
+
+    DO jpatch=1,outpatch_table(ibuf)%npatch,1
+
+       IF ( outpatch_table(ibuf)%PatchList(jpatch)%forDeletion ) CYCLE
+
+       WRITE(mess,"('Patch ',I3,': [',I3,': ',I3,'],[',I3,':',I3,'],[',I3,':',I3,']')") jpatch, outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1), &
+             outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1),   &
+             outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2), &
+             outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2),   &
+             outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3), &
+             outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)
+       CALL wrf_message(mess)
+
+       ! Count how many patches we're left with
+       npatches = npatches + 1
+
+       ! If no patches have been merged together to make this patch then we 
+       ! don't have to do any more with it
+       IF(PatchCount(jpatch) == 1) CYCLE
+
+       ! Get the extent of this patch
+       newExtent(:) = outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(:) - &
+                      outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:) + 1
+       ! Allocate a buffer to hold all of its data
+       IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_FLOAT ) THEN
+          ALLOCATE(rbuffer(newExtent(1), newExtent(2), newExtent(3)), &
+                   Stat=ierr)
+       ELSE IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_INTEGER ) THEN
+          ALLOCATE(ibuffer(newExtent(1), newExtent(2), newExtent(3)), &
+                   Stat=ierr)
+       END IF
+       IF(ierr /= 0)THEN
+          CALL wrf_error_fatal('stitch_outbuf_patches: unable to stitch patches as allocate for merge buffer failed.')
+          RETURN
+       END IF
+
+       ! Copy data into this buffer from each of the patches that are being
+       ! stitched together
+       IF( ASSOCIATED(rbuffer) )THEN
+
+!         CALL start_timing()
+
+          DO ipatch=1,PatchCount(jpatch),1
+
+             ii = JoinedPatches(ipatch, jpatch)
+
+             ! Work out where to put it - the PatchList(i)PatchStart() has been
+             ! updated to hold the start of the newly quilted patch i. It will
+             ! therefore be less than or equal to the starts of each of the 
+             ! constituent patches.
+             pos(:) = OldPatchStart(:,ii) - &
+                      outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:) + 1
+             ! Do the copy - can use the PatchExtent data here because that
+             ! wasn't modified during the stitching of the patches.
+
+             rbuffer(pos(1): pos(1)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(1)-1, &
+                     pos(2): pos(2)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(2)-1, &
+                     pos(3): pos(3)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(3)-1 ) &
+                             = &
+                      outpatch_table(ibuf)%PatchList(ii)%rptr(:, :, :)
+
+             ! Having copied the data from this patch, we can free-up the 
+             ! associated buffer
+             DEALLOCATE(outpatch_table(ibuf)%PatchList(ii)%rptr)
+          END DO
+
+!         CALL end_timing("Data copy into new real patch")
+
+          ! Re-assign the pointer associated with this patch to the new,
+          ! larger, buffer containing the quilted patches
+          outpatch_table(ibuf)%PatchList(jpatch)%rptr => rbuffer
+
+          ! Unset the original pointer to this buffer
+          NULLIFY(rbuffer)
+
+       ELSE IF( ASSOCIATED(ibuffer) )THEN
+
+!         CALL start_timing()
+
+          DO ipatch=1,PatchCount(jpatch),1
+
+             ii = JoinedPatches(ipatch, jpatch)
+
+             ! Work out where to put it
+             pos(:) = OldPatchStart(:,ii) - &
+                      outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:) + 1
+             ! Do the copy - can use the PatchExtent data here because that
+             ! wasn't modified during the stitching of the patches.
+             ibuffer(pos(1): &
+                 pos(1)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(1)-1, &
+                 pos(2): &
+                 pos(2)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(2)-1, &
+                 pos(3): &
+                 pos(3)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(3)-1 ) = &
+                      outpatch_table(ibuf)%PatchList(ii)%iptr(:, :, :)
+
+             DEALLOCATE(outpatch_table(ibuf)%PatchList(ii)%iptr)
+          END DO
+
+!         CALL end_timing("Data copy into new integer patch")
+
+          ! Re-assign the pointer associated with this patch to the new,
+          ! larger, buffer containing the quilted patches
+          outpatch_table(ibuf)%PatchList(jpatch)%iptr => ibuffer
+          NULLIFY(ibuffer)
+
+       END IF
+
+    END DO
+
+    WRITE(mess,*) "--------------------------"
+    CALL wrf_message(mess)
+    ! ARPDBGend
+#endif
+
+    ! Record how many patches we're left with
+    outpatch_table(ibuf)%nPatch = npatches
+
+    DEALLOCATE(OldPatchStart, JoinedPatches, PatchCount)
+
+!   CALL end_timing("stitch patches")
+
+  END SUBROUTINE stitch_outbuf_patches
+
+  !-------------------------------------------------------------------------
+  SUBROUTINE merge_patches(itab, ipatch, jpatch)
+    INTEGER, INTENT(in) :: itab, ipatch, jpatch
+    ! Merge patch jpatch into patch ipatch and then 'delete' jpatch
+    INTEGER :: ii
+
+    ! Keep track of which patches we've merged: ipatch takes
+    ! on all of the original patches which currently make up 
+    ! jpatch.
+    DO ii=1,PatchCount(jpatch),1
+       PatchCount(ipatch) = PatchCount(ipatch) + 1
+       JoinedPatches(PatchCount(ipatch),ipatch) = JoinedPatches(ii,jpatch)
+    END DO
+    ! and mark patch jpatch for deletion
+    outpatch_table(itab)%PatchList(jpatch)%forDeletion = .TRUE.
+    ! decrement the count of active patches
+    outpatch_table(itab)%nActivePatch = outpatch_table(itab)%nActivePatch - 1
+
+  END SUBROUTINE merge_patches
+
+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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+    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*256         ::  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
+
+! 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_pnc( inbuf_r, inbuf_i, DateStr, VarName , &
+                                        FieldType, MemoryOrder, Stagger,     &
+                                        DimNames,&
+                                        DomainStart , DomainEnd , &
+                                        MemoryStart , MemoryEnd , &
+                                        PatchStart  , PatchEnd )
+!<DESCRIPTION>
+!<PRE>
+! This routine stores a patch in an array within an element of the 
+! outpatch_table%PatchList 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.  
+! This routine also stores DateStr, VarName, 
+! FieldType, MemoryOrder, Stagger, DimNames, DomainStart, and DomainEnd within 
+! the same element of outpatch.  
+!</PRE>
+!</DESCRIPTION>
+    USE module_quilt_outbuf_ops, Only: outpatch_table, tabsize, num_entries
+    USE module_timing
+    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*256         :: mess
+    INTEGER               :: l,m,n,ii,jj,ipatch,ierr
+    LOGICAL               :: found
+
+!   CALL start_timing()
+
+    ! 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(outpatch_table(ii)%VarName) ) THEN
+        IF ( TRIM(DateStr) .EQ. TRIM(outpatch_table(ii)%DateStr) ) THEN
+          IF ( TRIM(MemoryOrder) .EQ. TRIM(outpatch_table(ii)%MemoryOrder) ) THEN
+            found = .true.
+          ELSE
+            CALL wrf_error_fatal("store_patch_in_outbuf_pnc: memory order disagreement")
+          ENDIF
+        ELSE
+          CALL wrf_error_fatal("store_patch_in_outbuf_pnc: multiple dates in buffer")
+        ENDIF
+      ELSE
+        ii = ii + 1
+      ENDIF
+    ENDDO
+    IF ( .NOT. found ) THEN
+      num_entries = num_entries + 1
+
+      outpatch_table(num_entries)%npatch = 0
+
+      outpatch_table(num_entries)%VarName     = TRIM(VarName)
+      outpatch_table(num_entries)%DateStr     = TRIM(DateStr)
+      outpatch_table(num_entries)%MemoryOrder = TRIM(MemoryOrder)
+      outpatch_table(num_entries)%Stagger     = TRIM(Stagger)
+      outpatch_table(num_entries)%DimNames(1) = TRIM(DimNames(1))
+      outpatch_table(num_entries)%DimNames(2) = TRIM(DimNames(2))
+      outpatch_table(num_entries)%DimNames(3) = TRIM(DimNames(3))
+      outpatch_table(num_entries)%DomainStart = DomainStart
+      outpatch_table(num_entries)%DomainEnd   = DomainEnd
+      outpatch_table(num_entries)%FieldType   = FieldType
+      ii = num_entries
+
+      WRITE(mess,*)'Adding field entry no. ',num_entries
+      CALL wrf_message(mess)
+      WRITE(mess,*)'Variable = ',TRIM(VarName)
+      CALL wrf_message(mess)
+      WRITE(mess,*)'Domain start = ',DomainStart(:)
+      CALL wrf_message(mess)
+      WRITE(mess,*)'Domain end   = ',DomainEnd(:)
+      CALL wrf_message(mess)
+    ENDIF
+
+    ! We only store > 1 patch if the field has two or more dimensions. Scalars
+    ! and 1D arrays are replicated across compute nodes and therefore we only
+    ! need keep a single patch.
+    IF(LEN_TRIM(outpatch_table(ii)%MemoryOrder) >= 2 .OR. &
+       outpatch_table(ii)%npatch < 1)THEN
+
+       ! Add another patch
+       outpatch_table(ii)%npatch = outpatch_table(ii)%npatch + 1
+       outpatch_table(ii)%nActivePatch = outpatch_table(ii)%npatch
+
+       ipatch = outpatch_table(ii)%npatch
+
+       outpatch_table(ii)%PatchList(ipatch)%PatchStart(:) = PatchStart(:)
+       outpatch_table(ii)%PatchList(ipatch)%PatchEnd(:)   = PatchEnd(:)
+       outpatch_table(ii)%PatchList(ipatch)%PatchExtent(:)= PatchEnd(:) - PatchStart(:) + 1
+
+       ierr = 0
+
+       IF      ( FieldType .EQ. WRF_FLOAT ) THEN
+          ALLOCATE( outpatch_table(ii)%PatchList(ipatch)%rptr( &
+                                                 outpatch_table(ii)%PatchList(ipatch)%PatchExtent(1), &
+                                                 outpatch_table(ii)%PatchList(ipatch)%PatchExtent(2), &
+                                                 outpatch_table(ii)%PatchList(ipatch)%PatchExtent(3)),&
+                                                 Stat=ierr)
+       ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
+          ALLOCATE( outpatch_table(ii)%PatchList(ipatch)%iptr( &
+                                                 outpatch_table(ii)%PatchList(ipatch)%PatchExtent(1), &
+                                                 outpatch_table(ii)%PatchList(ipatch)%PatchExtent(2), &
+                                                 outpatch_table(ii)%PatchList(ipatch)%PatchExtent(3)),&
+                                                 Stat=ierr)
+       ELSE
+          WRITE(mess,*)"store_patch_in_outbuf_pnc: unsupported type ", FieldType
+          CALL wrf_error_fatal(mess)
+       ENDIF
+
+       IF(ierr /= 0)THEN
+          WRITE(mess,*)"store_patch_in_outbuf_pnc: failed to allocate memory to hold patch for var. ", TRIM(VarName)
+          CALL wrf_error_fatal(mess)
+       END IF
+
+       jj = 1
+
+       WRITE(mess,"('Variable ',(A),', patch ',I3,': (',I3,':',I3,',',I3,':',I3,',',I3,':',I3,')')")&
+                TRIM(outpatch_table(ii)%VarName),  &
+                ipatch, &
+                PatchStart(1),PatchEnd(1), &
+                PatchStart(2),PatchEnd(2), &
+                PatchStart(3),PatchEnd(3)
+       CALL wrf_message(mess)
+
+       IF (  FieldType .EQ. WRF_FLOAT ) THEN
+          DO n = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(3),1
+             DO m = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(2),1
+                DO l = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(1),1
+                   outpatch_table(ii)%PatchList(ipatch)%rptr(l,m,n) = inbuf_r(jj)
+                   jj = jj + 1
+                ENDDO
+             ENDDO
+          ENDDO
+       ENDIF
+       IF (  FieldType .EQ. WRF_INTEGER ) THEN
+          DO n = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(3),1
+             DO m = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(2),1
+                DO l = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(1),1
+                   outpatch_table(ii)%PatchList(ipatch)%iptr(l,m,n) = inbuf_i(jj)
+                   jj = jj + 1
+                ENDDO
+             ENDDO
+          ENDDO
+       ENDIF
+
+    END IF ! We need to add another patch
+
+!   CALL end_timing("store patch in outbuf")
+
+    RETURN
+
+  END SUBROUTINE store_patch_in_outbuf_pnc
+
+!call add_to_bufsize_for_field( VarName, hdrbufsize+chunksize )
+
+  SUBROUTINE add_to_bufsize_for_field( VarName, Nbytes )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+    USE module_quilt_outbuf_ops
+    IMPLICIT NONE
+    CHARACTER*(*)    , INTENT(IN) :: VarName
+    INTEGER          , INTENT(IN) :: Nbytes
+! Local
+    CHARACTER*256         :: 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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+    USE module_quilt_outbuf_ops
+    IMPLICIT NONE
+    INTEGER ,                INTENT(IN) :: Nbytes
+    INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf
+    CHARACTER*(*)          , INTENT(IN) :: VarName
+! Local
+    CHARACTER*256         :: 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 )
+!<DESCRIPTION>
+!<PRE>
+! 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.  
+!</PRE>
+!</DESCRIPTION>
+    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*256         :: 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
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_sm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_sm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_sm.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_streams.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_streams.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_streams.F	(revision 17)
@@ -0,0 +1,37 @@
+!WRF:DRIVER_LAYER:IO_STREAMS
+MODULE module_streams
+
+
+! registry-generated switch parameters, alarms
+
+#include "switches_and_alarms.inc"
+
+  INTEGER, PARAMETER :: first_history     = history_only
+  INTEGER, PARAMETER :: last_history      = history_only+MAX_HISTORY-1
+  INTEGER, PARAMETER :: first_auxhist     = auxhist1_only
+  INTEGER, PARAMETER :: last_auxhist      = last_history
+  INTEGER, PARAMETER :: first_input       = input_only
+  INTEGER, PARAMETER :: last_input        = input_only+MAX_HISTORY-1
+  INTEGER, PARAMETER :: first_auxinput    = auxinput1_only
+  INTEGER, PARAMETER :: last_auxinput     = last_input
+  INTEGER, PARAMETER :: first_stream      = first_history
+  INTEGER, PARAMETER :: last_stream       = last_input
+  INTEGER, PARAMETER :: restart_only      = 2*(MAX_HISTORY)+1
+  INTEGER, PARAMETER :: boundary_only     = 2*(MAX_HISTORY)+2
+
+  INTEGER, PARAMETER :: RESTART_ALARM     = restart_only
+  INTEGER, PARAMETER :: BOUNDARY_ALARM    = boundary_only
+
+  INTEGER, PARAMETER :: INPUTOUT_ALARM              = 2*(MAX_HISTORY)+3       ! for outputing input (e.g. for 3dvar)
+  INTEGER, PARAMETER :: ALARM_SUBTIME               = 2*(MAX_HISTORY)+4
+  INTEGER, PARAMETER :: COMPUTE_VORTEX_CENTER_ALARM = 2*(MAX_HISTORY)+5
+
+  INTEGER, PARAMETER :: MAX_WRF_ALARMS    = COMPUTE_VORTEX_CENTER_ALARM  ! WARNING:  MAX_WRF_ALARMS must be
+                                                                         ! large enough to include all of
+                                                                         ! the alarms declared above.
+
+  CONTAINS
+    SUBROUTINE init_module_streams
+    END SUBROUTINE init_module_streams
+
+END MODULE module_streams
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_tiles.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_tiles.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_tiles.F	(revision 17)
@@ -0,0 +1,468 @@
+!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, ONLY : 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, ONLY : 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
+     INTEGER                                :: nt
+#ifdef _OPENMP
+     INTEGER , EXTERNAL        :: omp_get_max_threads
+#endif
+     CHARACTER*80              :: mess
+     LOGICAL                   :: verbose ! whether to output tile info messages
+
+     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.
+     !
+
+     verbose = .false.
+     IF ( grid%num_tiles_spec .EQ. 0 ) THEN
+       verbose = .true.
+       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
+     ELSE
+       num_tiles = grid%num_tiles_spec
+       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
+       grid%num_tiles_x = num_tiles_x
+       grid%num_tiles_y = num_tiles_y
+     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
+
+     nt = 1
+     DO t = 0, num_tiles-1
+
+       ! do y
+        ntiles = t / num_tiles_x
+        CALL region_bounds( spy, epy,                                  &
+                            num_tiles_y, ntiles,                       &
+                            ts, te )
+        ! first y (major dimension)
+        IF ( ts .LE. te ) THEN  ! converse happens if number of tiles > number of points in dim
+!!!
+! 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 ( jps .lt. spy .and. ts .eq. spy ) ts = jps ;
+          IF ( jpe .gt. epy .and. te .eq. epy ) te = jpe ;
+!
+          grid%j_start(nt) = max ( ts , jds )
+          grid%j_end(nt)   = min ( te , jde )
+
+          ! now x
+          ntiles = mod(t,num_tiles_x)
+          CALL region_bounds( spx, epx,                                  &
+                              num_tiles_x, ntiles,                       &
+                              ts, te )
+          IF ( ts .LE. te ) THEN  ! converse happens if number of tiles > number of points in dim
+            IF ( ips .lt. spx .and. ts .eq. spx ) ts = ips ;
+            IF ( ipe .gt. epx .and. te .eq. epx ) te = ipe ;
+!!!
+            grid%i_start(nt) = max ( ts , ids )
+            grid%i_end(nt)   = min ( te , ide )
+            IF ( verbose ) THEN
+              WRITE(mess,'("WRF TILE ",I3," IS ",I6," IE ",I6," JS ",I6," JE ",I6)') &
+                        nt,grid%i_start(nt),grid%i_end(nt),grid%j_start(nt),grid%j_end(nt)
+              CALL WRF_MESSAGE ( mess )
+            ENDIF
+            nt = nt + 1
+          ENDIF
+        ENDIF
+     END DO
+     num_tiles = nt-1
+     IF ( verbose ) THEN
+       WRITE(mess,'("WRF NUMBER OF TILES = ",I3)')num_tiles
+       CALL WRF_MESSAGE ( mess )
+     ENDIF
+     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, ONLY : 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.
+     INTEGER nt
+     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)
+     DO nt = 1, num_tiles
+        WRITE(mess,'("WRF TILE ",I3," IS ",I6," IE ",I6," JS ",I6," JE ",I6)') &
+                      nt,grid%i_start(nt),grid%i_end(nt),grid%j_start(nt),grid%j_end(nt)
+        CALL wrf_debug ( 1, mess )
+     ENDDO
+     WRITE(mess,'("set_tiles3: NUMBER OF TILES = ",I3)')num_tiles
+     CALL wrf_debug ( 1, mess )
+
+     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
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_timing.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_timing.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_timing.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/module_wrf_error.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/module_wrf_error.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/module_wrf_error.F	(revision 17)
@@ -0,0 +1,106 @@
+!WRF:DRIVER_LAYER:UTIL
+!
+
+MODULE module_wrf_error
+  INTEGER           :: wrf_debug_level = 0
+  CHARACTER*256     :: wrf_err_message
+!$OMP THREADPRIVATE (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)
+# ifdef _WIN32
+  FLUSH(0)
+# endif
+#endif
+  print*, TRIM(str)
+END SUBROUTINE wrf_message
+
+! intentionally write to stderr only
+SUBROUTINE wrf_message2( str )
+  IMPLICIT NONE
+  CHARACTER*(*) str
+  write(0,*) str
+# ifdef _WIN32
+  FLUSH(0)
+# endif
+END SUBROUTINE wrf_message2
+
+SUBROUTINE wrf_error_fatal3( file_str, line, str )
+  USE module_wrf_error
+#ifdef ESMFIO
+  USE ESMF_Mod
+#endif
+  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
+#ifdef ESMFIO
+  CALL esmf_finalize(terminationflag=ESMF_ABORT)
+#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
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_access_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_access_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_access_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+#include "nl_config.inc"
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_0_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_0_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_0_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_1_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_1_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_1_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_2_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_2_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_2_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_3_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_3_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_3_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_4_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_4_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_4_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_5_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_5_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_5_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_6_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_6_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_6_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_7_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_7_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_get_7_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_0_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_0_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_0_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_1_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_1_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_1_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_2_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_2_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_2_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_3_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_3_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_3_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_4_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_4_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_4_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_5_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_5_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_5_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_6_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_6_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_6_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_7_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_7_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/nl_set_7_routines.F	(revision 17)
@@ -0,0 +1,1 @@
+dummy; make needs this to be happy
Index: branches/LMDZ_WRFmeas/WRFV3/frame/pack_utils.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/pack_utils.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/pack_utils.c	(revision 17)
@@ -0,0 +1,390 @@
+#ifndef MS_SUA
+# include <stdio.h>
+# include <stdlib.h>
+#endif
+#include <string.h>
+#include "../inc/streams.h"
+
+#ifndef CRAY
+# ifdef NOUNDERSCORE
+#      define INT_PACK_DATA  int_pack_data
+#      define INT_GET_TI_HEADER_C  int_get_ti_header_c
+#      define INT_GEN_TI_HEADER_C  int_gen_ti_header_c
+#      define ADD_TO_BUFSIZE_FOR_FIELD_C  add_to_bufsize_for_field_c
+#      define STORE_PIECE_OF_FIELD_C  store_piece_of_field_c
+#      define RETRIEVE_PIECES_OF_FIELD_C  retrieve_pieces_of_field_c
+#      define INIT_STORE_PIECE_OF_FIELD init_store_piece_of_field
+#      define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field
+#      define PERTURB_REAL perturb_real
+#      define INSPECT_HEADER inspect_header
+#      define RESET_MASK reset_mask
+#      define SET_MASK set_mask
+#      define GET_MASK get_mask
+# else
+#   ifdef F2CSTYLE
+#      define INT_PACK_DATA  int_pack_data__
+#      define INT_GET_TI_HEADER_C  int_get_ti_header_c__
+#      define INT_GEN_TI_HEADER_C  int_gen_ti_header_c__
+#      define ADD_TO_BUFSIZE_FOR_FIELD_C  add_to_bufsize_for_field_c__
+#      define STORE_PIECE_OF_FIELD_C  store_piece_of_field_c__
+#      define RETRIEVE_PIECES_OF_FIELD_C  retrieve_pieces_of_field_c__
+#      define INIT_STORE_PIECE_OF_FIELD init_store_piece_of_field__
+#      define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field__
+#      define PERTURB_REAL perturb_real__
+#      define INSPECT_HEADER inspect_header__
+#      define RESET_MASK reset_mask__
+#      define SET_MASK set_mask__
+#      define GET_MASK get_mask__
+#   else
+#      define INT_PACK_DATA  int_pack_data_
+#      define INT_GET_TI_HEADER_C  int_get_ti_header_c_
+#      define INT_GEN_TI_HEADER_C  int_gen_ti_header_c_
+#      define ADD_TO_BUFSIZE_FOR_FIELD_C  add_to_bufsize_for_field_c_
+#      define STORE_PIECE_OF_FIELD_C  store_piece_of_field_c_
+#      define RETRIEVE_PIECES_OF_FIELD_C  retrieve_pieces_of_field_c_
+#      define INIT_STORE_PIECE_OF_FIELD init_store_piece_of_field_
+#      define INIT_RETRIEVE_PIECES_OF_FIELD init_retrieve_pieces_of_field_
+#      define PERTURB_REAL perturb_real_
+#      define INSPECT_HEADER inspect_header_
+#      define RESET_MASK reset_mask_
+#      define SET_MASK set_mask_
+#      define GET_MASK get_mask_
+#   endif
+# endif
+#endif
+
+#ifdef MEMCPY_FOR_BCOPY
+# define bcopy(A,B,C) memcpy((B),(A),(C))
+#endif
+
+/*    CALL int_pack_data ( hdrbuf , hdrbufsiz * inttypesize , int_local_output_buffer, int_local_output_cursor ) */
+
+INT_PACK_DATA ( unsigned char *buf , int *ninbytes , unsigned char *obuf, int *cursor )
+{
+  int i, lcurs ;
+  lcurs = *cursor - 1 ;
+  for ( i = 0 ; i < *ninbytes ; i++ )
+  {
+    obuf[lcurs++] = buf[i] ;
+  }
+  *cursor = lcurs+1 ;
+}
+
+int
+INT_GEN_TI_HEADER_C ( char * hdrbuf, int * hdrbufsize,           /* hdrbufsize is in bytes */
+                    int * itypesize, int * typesize,
+                    int * DataHandle, char * Data,
+                    int * Count, int * code )
+{
+  int i ;
+  char * p ;
+  p = hdrbuf ;
+  p += sizeof(int) ;
+  bcopy( code, p, sizeof(int) ) ; p += sizeof(int) ;       /* 2 */
+  bcopy( DataHandle, p, sizeof(int) ) ; p += sizeof(int) ; /* 3 */
+  bcopy( typesize, p, sizeof(int) ) ; p += sizeof(int) ;   /* 4 */
+  bcopy( Count, p, sizeof(int) ) ; p += sizeof(int) ;      /* 5 */
+  bcopy( Data, p, *Count * *typesize ) ; p += *Count * *typesize ; /* 6++ */
+  *hdrbufsize = (int) (p - hdrbuf) ;
+  bcopy( hdrbufsize, hdrbuf, sizeof(int) ) ;
+  return(0) ;
+}
+
+int
+INT_GET_TI_HEADER_C ( char * hdrbuf, int * hdrbufsize, int * n,  /* hdrbufsize and n are in bytes */
+                    int * itypesize, int * typesize,
+                    int * DataHandle, char * Data,
+                    int * Count, int * code )
+{
+  int i ;
+  char * p ;
+  p = hdrbuf ;
+  bcopy( p, hdrbufsize, sizeof(int) ) ;     p += sizeof(int) ;        /* 1 */
+  bcopy( p, code, sizeof(int) ) ;           p += sizeof(int) ;        /* 2 */
+  bcopy( p, DataHandle, sizeof(int) ) ;     p += sizeof(int) ;        /* 3 */
+  bcopy( p, typesize, sizeof(int) ) ;       p += sizeof(int) ;        /* 4 */
+  bcopy( p, Count, sizeof(int) ) ;          p += sizeof(int) ;        /* 5 */
+  if ( *Count * *typesize > 0 ) {
+  bcopy( p, Data, *Count * *typesize ) ;  p += *Count * *typesize ; /* 6++ */
+  }
+  *n = (int)( p - hdrbuf ) ;
+  return(0) ;
+}
+
+#define MAX_FLDS 2000
+static char fld_name[MAX_FLDS][256] ;
+static char *fld_cache[MAX_FLDS] ;
+static int fld_curs[MAX_FLDS] ;
+static int fld_bufsize[MAX_FLDS] ;
+static int fld     = 0 ;
+static int numflds = 0 ;
+static int frst = 1 ;
+
+int INIT_STORE_PIECE_OF_FIELD ()
+{
+  int i ;
+  if ( frst ) {
+    for ( i = 0 ; i < MAX_FLDS ; i++ ) {
+      fld_cache[i] = NULL ;
+    }
+    frst = 0 ; 
+  }
+  numflds = 0 ;
+  for ( i = 0 ; i < MAX_FLDS ; i++ ) {
+    strcpy( fld_name[i], "" ) ;
+    if ( fld_cache[i] != NULL ) free( fld_cache[i] ) ;
+    fld_cache[i] = NULL ;
+    fld_curs[i] = 0 ;
+    fld_bufsize[i] = 0 ;
+  }
+  return(0) ;
+}
+
+int INIT_RETRIEVE_PIECES_OF_FIELD ()
+{
+  fld = 0 ;
+  return(0) ;
+}
+
+int
+ADD_TO_BUFSIZE_FOR_FIELD_C ( int varname[], int * chunksize )
+{
+  int i, n ;
+  int found ;
+  char vname[256] ;
+
+  n = varname[0] ;
+  for ( i = 1; i <= n ; i++ ) { vname[i-1] = varname[i] ; }
+  vname[n] = '\0' ;
+
+  found = -1 ;
+  for ( i = 0 ; i < numflds ; i++ ) { if ( !strcmp( fld_name[i], vname ) ) { found = i ; break ; } }
+  if ( found == -1 ) {
+    found = numflds++ ;
+    strcpy( fld_name[found], vname ) ;
+    fld_bufsize[found] = *chunksize ;
+  }
+  else
+  {
+    fld_bufsize[found] += *chunksize ;
+  }
+  if ( fld_cache[found] != NULL ) { free( fld_cache[found] ) ; }
+  fld_cache[found] = NULL ;
+  return(0) ;
+}
+
+int
+STORE_PIECE_OF_FIELD_C ( char * buf , int varname[], int * chunksize, int *retval )
+{
+  int i, n ;
+  int found ;
+  char vname[256] ;
+
+  n = varname[0] ;
+  for ( i = 1; i <= n ; i++ ) { vname[i-1] = varname[i] ; }
+  vname[n] = '\0' ;
+
+  found = -1 ;
+  for ( i = 0 ; i < numflds ; i++ ) { if ( !strcmp( fld_name[i], vname ) ) { found = i ; break ; } }
+  if ( found == -1 ) { 
+#ifndef MS_SUA
+    fprintf(stderr,"frame/pack_utils.c: field (%s) not found; was not set up with add_to_bufsize_for_field\n",vname ) ;
+#endif
+    *retval = 1 ;
+    return(0)  ;
+  }
+
+  if ( fld_cache[found] == NULL ) {
+     fld_cache[found] = (char *) malloc( fld_bufsize[found] ) ;
+     fld_curs[found] = 0 ;
+  }
+
+  if ( fld_curs[found] + *chunksize > fld_bufsize[found] ) {
+#ifndef MS_SUA
+    fprintf(stderr,
+"frame/pack_utils.c: %s would overwrite %d + %d  > %d [%d]\n",vname, fld_curs[found], *chunksize, fld_bufsize[found], found ) ;
+#endif
+    *retval = 1 ;
+    return(0)  ;
+  }
+
+  bcopy( buf, fld_cache[found]+fld_curs[found], *chunksize ) ;
+  fld_curs[found] += *chunksize ;
+  *retval = 0 ;
+  return(0) ;
+}
+
+int
+RETRIEVE_PIECES_OF_FIELD_C ( char * buf , int varname[], int * insize, int * outsize, int *retval )
+{
+  int i, n ;
+  int found ;
+  char vname[256] ;
+
+  if ( fld < numflds ) {
+#ifndef MS_SUA
+    if ( fld_curs[fld] > *insize ) {
+      fprintf(stderr,"retrieve: fld_curs[%d] (%d) > *insize (%d)\n",fld,fld_curs[fld], *insize ) ;
+    }
+#endif
+    *outsize = ( fld_curs[fld] <= *insize ) ? fld_curs[fld] : *insize ;
+    bcopy( fld_cache[fld], buf, *outsize ) ;
+    varname[0] = (int) strlen( fld_name[fld] ) ;
+    for ( i = 1 ; i <= varname[0] ; i++ ) varname[i] = fld_name[fld][i-1] ;
+    if ( fld_cache[fld] != NULL ) free ( fld_cache[fld] ) ;
+    fld_cache[fld] = NULL ;
+    fld_bufsize[fld] = 0 ;
+    fld++ ;
+    *retval = 0 ;
+  }
+  else {
+    numflds = 0 ;
+    *retval = -1 ;
+  }
+  return(0) ;
+}
+
+#define INDEX_2(A,B,NB)       ( (B) + (A)*(NB) )
+#define INDEX_3(A,B,C)  INDEX_2( (A), INDEX_2( (B), (C), (me[1]-ms[1]+1) ), (me[1]-ms[1]+1)*(me[0]-ms[0]+1) )
+/* flip low order bit of fp number */
+int
+PERTURB_REAL ( float * field, int ds[], int de[], int ms[], int me[], int ps[], int pe[] )
+{
+   int i,j,k ;
+   int le ; /* index of little end */
+   float x = 2.0 ;
+   unsigned int y ; 
+   unsigned char a[4], *p ;
+   if ( sizeof(float) != 4 ) return(-1) ;
+   /* check endianness of machine */
+   bcopy ( &x, a, 4 ) ;
+   le = 0 ;
+   if ( a[0] == 0x40 ) le = 3 ;
+   for ( k = ps[2]-ms[2] ; k <= pe[2]-ms[2] ; k++ )
+     for ( j = ps[1]-ms[1] ; j <= pe[1]-ms[1] ; j++ )
+       for ( i = ps[0]-ms[0] ; i <= pe[0]-ms[0] ; i++ )
+       {
+          /* do not change zeros */
+          if ( field[ INDEX_3(k,j,i) ] != 0.0 ) {
+             p = (unsigned char *)&(field[ INDEX_3(k,j,i) ] ) ; 
+             if ( *(p+le) & 1 ) { *(p+le) &= 0x7e ; }
+             else               { *(p+le) |= 1 ; }
+          }
+       }
+   return(0) ;
+}
+
+int INSPECT_HEADER ( char * buf, int * sz, int * line )
+{
+    int i ;
+#ifndef MS_SUA
+    fprintf(stderr,"INSPECT_HEADER: line = %d ", *line ) ;
+    if ( buf != NULL && sz != NULL ) {
+      for ( i = 0 ; i < *sz && i < 256 ; i++ )  { if ( (buf[i] >= 'a' && buf[i] <= 'z') || buf[i] == '_' ||
+                                             (buf[i] >= 'A' && buf[i] <= 'Z') ||
+                                             (buf[i] >= '0' && buf[i] <= '9') ) fprintf(stderr,"%c",buf[i]) ;
+                                    }
+      fprintf(stderr,"\n") ;
+   }
+#endif
+    return(0) ;
+}
+
+/* note that these work the same as the routines in tools/misc.c, but are Fortran callable.  
+   They must be kept in sync, functionally. */
+
+void
+RESET_MASK ( unsigned int * mask , int *e )
+{
+   int w ;
+   unsigned int m, n ;
+
+   w = *e / (8*sizeof(int)-1) ;
+   n = 1 ;
+   m = ~( n << *e % (8*sizeof(int)-1) ) ;
+   if ( w >= 0 && w < IO_MASK_SIZE ) {
+     mask[w] &= m ;
+   }
+}
+
+void
+SET_MASK ( unsigned int * mask , int *e )
+{
+   int w ;
+   unsigned int m, n ;
+
+   w = *e / (8*sizeof(int)-1) ;
+   n = 1 ;
+   m = ( n << *e % (8*sizeof(int)-1) ) ;
+   if ( w >= 0 && w < IO_MASK_SIZE ) {
+     mask[w] |= m ;
+   }
+}
+
+/* this is slightly different from in tools dir since it returns result as argument, not function */
+/* definition of IO_MASK_SIZE comes from build and must be uniform with frame/module_domain_type.F and
+   version of this function in tools dir */
+void
+GET_MASK ( unsigned int * mask , int *e , int * retval )
+{
+   int w ;
+   unsigned int m, n ;
+
+   w = *e / (8*sizeof(int)-1) ;   /* 8 is number of bits per byte */
+   if ( w >= 0 && w < IO_MASK_SIZE ) {
+     m = mask[w] ;
+     n =  ( 1 << *e % (8*sizeof(int)-1) ) ;;
+     *retval = ( (m & n) != 0 ) ;
+   } else {
+     *retval = 0 ;
+   }
+}
+
+#ifdef WRAP_MALLOC
+# ifndef WRAP_MALLOC_ALIGNMENT
+#  define WRAP_MALLOC_ALIGNMENT 128
+# endif
+# define _XOPEN_SOURCE 600
+# include <stdlib.h>
+void *malloc(size_t size)
+{
+       void *tmp;
+       if (posix_memalign(&tmp, WRAP_MALLOC_ALIGNMENT, size) == 0)
+               return tmp;
+       else {
+               errno = ENOMEM;
+               return NULL;
+       }
+}
+#endif
+
+#ifndef DM_PARALLEL
+# ifndef CRAY
+#  ifdef NOUNDERSCORE
+#       define RSL_INTERNAL_MICROCLOCK  rsl_internal_microclock
+#  else
+#    ifdef F2CSTYLE
+#       define RSL_INTERNAL_MICROCLOCK  rsl_internal_microclock__
+#    else
+#       define RSL_INTERNAL_MICROCLOCK  rsl_internal_microclock_
+#    endif
+#  endif
+# endif
+# if !defined(MS_SUA) && !defined(_WIN32)
+#  include <sys/time.h>
+RSL_INTERNAL_MICROCLOCK ()
+{
+    struct timeval tb ;
+    struct timezone tzp ;
+    int isec ;  /* seconds */
+    int usec ;  /* microseconds */
+    int msecs ;
+    gettimeofday( &tb, &tzp ) ;
+    isec = tb.tv_sec ;
+    usec = tb.tv_usec ;
+    msecs = 1000000 * isec + usec ;
+    return(msecs) ;
+}
+# endif
+#endif
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/wrf_debug.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/wrf_debug.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/wrf_debug.F	(revision 17)
@@ -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 
Index: branches/LMDZ_WRFmeas/WRFV3/frame/wrf_num_bytes_between.c
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/wrf_num_bytes_between.c	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/wrf_num_bytes_between.c	(revision 17)
@@ -0,0 +1,84 @@
+#include <stdio.h>
+
+#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
+
+void
+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
+void
+GET_INITIAL_DATA_VALUE ( n )
+  int * n ;
+{
+  *n = 0xffc00000 ;
+}
+#else
+void
+GET_INITIAL_DATA_VALUE ( n )
+  float * n ;
+{
+  *n = 0. ;
+}
+#endif
+
+void
+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 */
+
+void
+WRF_MEM_COPY ( a , b, n )
+  char * a ; 
+  char * b ; 
+  int * n ;
+{
+  int i ;
+  for ( i = 0 ; i < *n ; i++ )
+  {
+    *b++ = *a++ ;
+  }
+}
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/wrf_shutdown.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/wrf_shutdown.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/wrf_shutdown.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/frame/xxx_template_ioapi.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/frame/xxx_template_ioapi.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/frame/xxx_template_ioapi.F	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/inc/bench_solve_em_def.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/inc/bench_solve_em_def.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/inc/bench_solve_em_def.h	(revision 17)
@@ -0,0 +1,72 @@
+#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(shcu_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)
+BENCH_DECL(fire_driver_tim)
+BENCH_DECL(tracer_adv_tim)
+#else
+#define SOLVE_START
+#define SOLVE_END
+#define BENCH_INIT(A)
+#define BENCH_START(A)
+#define BENCH_END(A)
+#define BENCH_REPORT(A)
+#endif
Index: branches/LMDZ_WRFmeas/WRFV3/inc/bench_solve_em_end.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/inc/bench_solve_em_end.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/inc/bench_solve_em_end.h	(revision 17)
@@ -0,0 +1,56 @@
+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(shcu_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)
+BENCH_REPORT(fire_driver_tim)
+BENCH_REPORT(tracer_adv_tim)
Index: branches/LMDZ_WRFmeas/WRFV3/inc/bench_solve_em_init.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/inc/bench_solve_em_init.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/inc/bench_solve_em_init.h	(revision 17)
@@ -0,0 +1,55 @@
+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(shcu_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)
+BENCH_INIT(fire_driver_tim)
+BENCH_INIT(tracer_adv_tim)
+SOLVE_START
Index: branches/LMDZ_WRFmeas/WRFV3/inc/deref_kludge.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/inc/deref_kludge.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/inc/deref_kludge.h	(revision 17)
@@ -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
+
Index: branches/LMDZ_WRFmeas/WRFV3/inc/intio_tags.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/inc/intio_tags.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/inc/intio_tags.h	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/inc/rsl_cpp_flags
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/inc/rsl_cpp_flags	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/inc/rsl_cpp_flags	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/inc/streams.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/inc/streams.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/inc/streams.h	(revision 17)
@@ -0,0 +1,16 @@
+#ifndef MAX_HISTORY
+# define MAX_HISTORY 12
+#endif
+#ifndef IWORDSIZE
+# define IWORDSIZE 4
+#endif
+#define HISTORY_STREAM         0
+#define INPUT_STREAM           ((HISTORY_STREAM)+(MAX_HISTORY))
+#if 0
+  max streams is MAX_HISTORY plus equal number of input streams plus 1 restart + 1 boundary
+#endif
+#define MAX_STREAMS  (2*(MAX_HISTORY)+2)
+#define BOUNDARY_STREAM (2*(MAX_HISTORY)+1)
+#define RESTART_STREAM (2*(MAX_HISTORY)+2)
+#define IO_MASK_SIZE ((MAX_STREAMS)/(IWORDSIZE*8)+1)
+
Index: branches/LMDZ_WRFmeas/WRFV3/inc/version_decl
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/inc/version_decl	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/inc/version_decl	(revision 17)
@@ -0,0 +1,1 @@
+   CHARACTER (LEN=10) :: release_version = 'V3.3      '
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/FCTTRE.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/FCTTRE.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/FCTTRE.h	(revision 17)
@@ -0,0 +1,45 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!     ------------------------------------------------------------------
+!     This COMDECK includes the Thermodynamical functions for the cy39
+!       ECMWF Physics package.
+!       Consistent with YOMCST Basic physics constants, assuming the
+!       partial pressure of water vapour is given by a first order
+!       Taylor expansion of Qs(T) w.r.t. to Temperature, using constants
+!       in YOETHF
+!     ------------------------------------------------------------------
+      REAL PTARG, PDELARG, P5ARG, PQSARG, PCOARG
+      REAL FOEEW, FOEDE, qsats, qsatl, dqsats, dqsatl
+      LOGICAL thermcep
+      PARAMETER (thermcep=.TRUE.)
+!
+      FOEEW ( PTARG,PDELARG ) = EXP (                                   &
+     &          (R3LES*(1.-PDELARG)+R3IES*PDELARG) * (PTARG-RTT)        &
+     & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG)) )
+!
+      FOEDE ( PTARG,PDELARG,P5ARG,PQSARG,PCOARG ) = PQSARG*PCOARG*P5ARG &
+     & / (PTARG-(R4LES*(1.-PDELARG)+R4IES*PDELARG))**2
+!
+      qsats(ptarg) = 100.0 * 0.622 * 10.0                               &
+     &           ** (2.07023 - 0.00320991 * ptarg                       &
+     &           - 2484.896 / ptarg + 3.56654 * LOG10(ptarg))
+      qsatl(ptarg) = 100.0 * 0.622 * 10.0                               &
+     &           ** (23.8319 - 2948.964 / ptarg                         &
+     &           - 5.028 * LOG10(ptarg)                                 &
+     &           - 29810.16 * EXP( - 0.0699382 * ptarg)                 &
+     &           + 25.21935 * EXP( - 2999.924 / ptarg))
+!
+      dqsats(ptarg,pqsarg) = RLVTT/RCPD*pqsarg * (3.56654/ptarg         &
+     &                     +2484.896*LOG(10.)/ptarg**2                  &
+     &                     -0.00320991*LOG(10.))
+      dqsatl(ptarg,pqsarg) = RLVTT/RCPD*pqsarg*LOG(10.)*                &
+     &                (2948.964/ptarg**2-5.028/LOG(10.)/ptarg           &
+     &                +25.21935*2999.924/ptarg**2*EXP(-2999.924/ptarg)  &
+     &                +29810.16*0.0699382*EXP(-0.0699382*ptarg))
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/calendar.f90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/calendar.f90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/calendar.f90	(revision 17)
@@ -0,0 +1,1046 @@
+MODULE calendar
+!-
+!$Id: calendar.f90 1519 2011-08-01 09:34:10Z mmaipsl $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+!- This is the calendar which going to be used to do all
+!- calculations on time. Three types of calendars are possible :
+!-
+!-  - gregorian :
+!-      The normal calendar. The time origin for the
+!-      julian day in this case is 24 Nov -4713
+!-      (other names : 'standard','proleptic_gregorian')
+!-  - noleap :
+!-      A 365 day year without leap years.
+!-      The origin for the julian days is in this case 1 Jan 0
+!-      (other names : '365_day','365d')
+!-  - all_leap :
+!-      A 366 day year with leap years.
+!-      The origin for the julian days is in this case ????
+!-      (other names : '366_day','366d'
+!-  - julian :
+!-      same as gregorian, but with all leap century years
+!-  - xxxd :
+!-      Year of xxx days with month of equal length.
+!-      The origin for the julian days is then also 1 Jan 0
+!-
+!- As one can see it is difficult to go from one calendar to the other.
+!- All operations involving julian days will be wrong.
+!- This calendar will lock as soon as possible
+!- the length of the year and forbid any further modification.
+!-
+!- For the non leap-year calendar the method is still brute force.
+!- We need to find an Integer series which takes care of the length
+!- of the various month. (Jan)
+!-
+!-   one_day  : one day in seconds
+!-   one_year : one year in days
+!---------------------------------------------------------------------
+  USE stringop,ONLY  : strlowercase
+  USE errioipsl,ONLY : ipslerr, ipsldbg, ipslout
+!-
+  PRIVATE
+  PUBLIC :: ymds2ju,ju2ymds,tlen2itau,isittime,ioconf_calendar, &
+ &          ioget_calendar,ioget_mon_len,ioget_year_len,itau2date, &
+ &          ioget_timestamp,ioconf_startdate,itau2ymds, &
+ &          time_diff,time_add,lock_calendar
+!-
+  INTERFACE ioget_calendar
+    MODULE PROCEDURE &
+ &    ioget_calendar_real1,ioget_calendar_real2,ioget_calendar_str
+  END INTERFACE
+!-
+  INTERFACE ioconf_startdate
+     MODULE PROCEDURE &
+ &    ioconf_startdate_simple,ioconf_startdate_internal, &
+ &    ioconf_startdate_ymds
+  END INTERFACE
+!-
+  REAL,PARAMETER :: one_day = 86400.0
+  LOGICAL,SAVE :: lock_startdate = .FALSE.
+!-
+  CHARACTER(LEN=30),SAVE :: time_stamp='XXXXXXXXXXXXXXXX'
+!-
+!- Description of calendar
+!-
+  CHARACTER(LEN=20),SAVE :: calendar_used="gregorian"
+  LOGICAL,SAVE :: lock_one_year = .FALSE.
+  REAL,SAVE :: one_year = 365.2425
+  INTEGER,SAVE :: mon_len(12)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
+!-
+  CHARACTER(LEN=3),PARAMETER :: &
+ &  cal(12) = (/'JAN','FEB','MAR','APR','MAY','JUN', &
+ &              'JUL','AUG','SEP','OCT','NOV','DEC'/)
+!-
+  REAL,SAVE :: start_day,start_sec
+!-
+CONTAINS
+!-
+!===
+!-
+SUBROUTINE lock_calendar (new_status,old_status)
+!!--------------------------------------------------------------------
+!! The "lock_calendar" routine
+!! allows to lock or unlock the calendar,
+!! and to know the current status of the calendar.
+!! Be careful !
+!!
+!! SUBROUTINE lock_calendar (new_status,old_status)
+!!
+!! Optional INPUT argument
+!!
+!! (L) new_status : new status of the calendar
+!!
+!! Optional OUTPUT argument
+!!
+!! (L) old_status : current status of the calendar
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  LOGICAL,OPTIONAL,INTENT(IN)  :: new_status
+  LOGICAL,OPTIONAL,INTENT(OUT) :: old_status
+!---------------------------------------------------------------------
+  IF (PRESENT(old_status)) THEN
+    old_status = lock_one_year
+  ENDIF
+  IF (PRESENT(new_status)) THEN
+    lock_one_year = new_status
+  ENDIF
+!---------------------------
+END SUBROUTINE lock_calendar
+!-
+!===
+!-
+SUBROUTINE ymds2ju (year,month,day,sec,julian)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: year,month,day
+  REAL,INTENT(IN)    :: sec
+!-
+  REAL,INTENT(OUT) :: julian
+!-
+  INTEGER :: julian_day
+  REAL    :: julian_sec
+!---------------------------------------------------------------------
+  CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec)
+!-
+  julian = julian_day+julian_sec/one_day
+!---------------------
+END SUBROUTINE ymds2ju
+!-
+!===
+!-
+SUBROUTINE ymds2ju_internal (year,month,day,sec,julian_day,julian_sec)
+!---------------------------------------------------------------------
+!- Converts year, month, day and seconds into a julian day
+!-
+!- In 1968 in a letter to the editor of Communications of the ACM
+!- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel
+!- and Thomas C. Van Flandern presented such an algorithm.
+!-
+!- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm
+!-
+!- In the case of the Gregorian calendar we have chosen to use
+!- the Lilian day numbers. This is the day counter which starts
+!- on the 15th October 1582.
+!- This is the day at which Pope Gregory XIII introduced the
+!- Gregorian calendar.
+!- Compared to the true Julian calendar, which starts some
+!- 7980 years ago, the Lilian days are smaler and are dealt with
+!- easily on 32 bit machines. With the true Julian days you can only
+!- the fraction of the day in the real part to a precision of
+!- a 1/4 of a day with 32 bits.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: year,month,day
+  REAL,INTENT(IN)    :: sec
+!-
+  INTEGER,INTENT(OUT) :: julian_day
+  REAL,INTENT(OUT)    :: julian_sec
+!-
+  INTEGER :: jd,m,y,d,ml
+!---------------------------------------------------------------------
+  lock_one_year = .TRUE.
+!-
+  m = month
+  y = year
+  d = day
+!-
+!- We deduce the calendar from the length of the year as it
+!- is faster than an INDEX on the calendar variable.
+!-
+  IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN
+!-- "Gregorian"
+    jd = (1461*(y+4800+INT((m-14)/12)))/4 &
+ &      +(367*(m-2-12*(INT((m-14)/12))))/12 &
+ &      -(3*((y+4900+INT((m-14)/12))/100))/4 &
+ &      +d-32075
+    jd = jd-2299160
+  ELSE IF (    (ABS(one_year-365.0) <= EPSILON(one_year))  &
+ &         .OR.(ABS(one_year-366.0) <= EPSILON(one_year)) ) THEN
+!-- "No leap" or "All leap"
+    ml = SUM(mon_len(1:m-1))
+    jd = y*NINT(one_year)+ml+(d-1)
+  ELSE
+!-- Calendar with regular month
+    ml = NINT(one_year/12.)
+    jd = y*NINT(one_year)+(m-1)*ml+(d-1)
+  ENDIF
+!-
+  julian_day = jd
+  julian_sec = sec
+!------------------------------
+END SUBROUTINE ymds2ju_internal
+!-
+!===
+!-
+SUBROUTINE ju2ymds (julian,year,month,day,sec)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  REAL,INTENT(IN) :: julian
+!-
+  INTEGER,INTENT(OUT) :: year,month,day
+  REAL,INTENT(OUT)    :: sec
+!-
+  INTEGER :: julian_day
+  REAL    :: julian_sec
+!---------------------------------------------------------------------
+  julian_day = INT(julian)
+  julian_sec = (julian-julian_day)*one_day
+!-
+  CALL ju2ymds_internal(julian_day,julian_sec,year,month,day,sec)
+!---------------------
+END SUBROUTINE ju2ymds
+!-
+!===
+!-
+SUBROUTINE ju2ymds_internal (julian_day,julian_sec,year,month,day,sec)
+!---------------------------------------------------------------------
+!- This subroutine computes from the julian day the year,
+!- month, day and seconds
+!-
+!- In 1968 in a letter to the editor of Communications of the ACM
+!- (CACM, volume 11, number 10, October 1968, p.657) Henry F. Fliegel
+!- and Thomas C. Van Flandern presented such an algorithm.
+!-
+!- See also : http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm
+!-
+!- In the case of the Gregorian calendar we have chosen to use
+!- the Lilian day numbers. This is the day counter which starts
+!- on the 15th October 1582. This is the day at which Pope
+!- Gregory XIII introduced the Gregorian calendar.
+!- Compared to the true Julian calendar, which starts some 7980
+!- years ago, the Lilian days are smaler and are dealt with easily
+!- on 32 bit machines. With the true Julian days you can only the
+!- fraction of the day in the real part to a precision of a 1/4 of
+!- a day with 32 bits.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: julian_day
+  REAL,INTENT(IN)    :: julian_sec
+!-
+  INTEGER,INTENT(OUT) :: year,month,day
+  REAL,INTENT(OUT)    :: sec
+!-
+  INTEGER :: l,n,i,jd,j,d,m,y,ml
+  INTEGER :: add_day
+  REAL :: eps_day
+!---------------------------------------------------------------------
+  eps_day = SPACING(one_day)
+  lock_one_year = .TRUE.
+!-
+  jd = julian_day
+  sec = julian_sec
+  IF (sec > (one_day-eps_day)) THEN
+    add_day = INT(sec/one_day)
+    sec = sec-add_day*one_day
+    jd = jd+add_day
+  ENDIF
+  IF (sec < -eps_day) THEN
+    sec = sec+one_day
+    jd = jd-1
+  ENDIF
+!-
+  IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN
+!-- Gregorian
+    jd = jd+2299160
+!-
+    l = jd+68569
+    n = (4*l)/146097
+    l = l-(146097*n+3)/4
+    i = (4000*(l+1))/1461001
+    l = l-(1461*i)/4+31
+    j = (80*l)/2447
+    d = l-(2447*j)/80
+    l = j/11
+    m = j+2-(12*l)
+    y = 100*(n-49)+i+l
+  ELSE IF (    (ABS(one_year-365.0) <= EPSILON(one_year)) &
+ &         .OR.(ABS(one_year-366.0) <= EPSILON(one_year)) ) THEN
+!-- No leap or All leap
+    y = jd/NINT(one_year)
+    l = jd-y*NINT(one_year)
+    m = 1
+    ml = 0
+    DO WHILE (ml+mon_len(m) <= l)
+      ml = ml+mon_len(m)
+      m = m+1
+    ENDDO
+    d = l-ml+1
+  ELSE
+!-- others
+    ml = NINT(one_year/12.)
+    y = jd/NINT(one_year)
+    l = jd-y*NINT(one_year)
+    m = (l/ml)+1
+    d = l-(m-1)*ml+1
+  ENDIF
+!-
+  day = d
+  month = m
+  year = y
+!------------------------------
+END SUBROUTINE ju2ymds_internal
+!-
+!===
+!-
+SUBROUTINE tlen2itau (input_str,dt,date,itau)
+!---------------------------------------------------------------------
+!- This subroutine transforms a string containing a time length
+!- into a number of time steps.
+!- To do this operation the date (in julian days is needed as the
+!- length of the month varies.
+!- The following convention is used :
+!-   n   : n time steps
+!-   nS  : n seconds is transformed into itaus
+!-   nH  : n hours
+!-   nD  : n days
+!-   nM  : n month
+!-   nY  : n years
+!- Combinations are also possible
+!-   nYmD : nyears plus m days !
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(IN) :: input_str
+  REAL,INTENT(IN)             :: dt,date
+!-
+  INTEGER,INTENT(OUT)         :: itau
+!-
+  INTEGER           :: y_pos,m_pos,d_pos,h_pos,s_pos
+  INTEGER           :: read_time
+  CHARACTER(LEN=13) :: fmt
+  CHARACTER(LEN=80) :: tmp_str
+!-
+  INTEGER :: year,month,day
+  REAL    :: sec,date_new,dd,ss
+!---------------------------------------------------------------------
+  itau = 0
+  CALL ju2ymds (date,year,month,day,sec)
+!-
+  y_pos = MAX(INDEX(input_str,'y'),INDEX(input_str,'Y'))
+  m_pos = MAX(INDEX(input_str,'m'),INDEX(input_str,'M'))
+  d_pos = MAX(INDEX(input_str,'d'),INDEX(input_str,'D'))
+  h_pos = MAX(INDEX(input_str,'h'),INDEX(input_str,'H'))
+  s_pos = MAX(INDEX(input_str,'s'),INDEX(input_str,'S'))
+!-
+  IF (MAX(y_pos,m_pos,d_pos,s_pos) > 0) THEN
+    tmp_str = input_str
+    DO WHILE ( MAX(y_pos,m_pos,d_pos,s_pos) > 0)
+!---- WRITE(ipslout,*) tmp_str
+!---- WRITE(ipslout,*) y_pos,m_pos,d_pos,s_pos
+      IF (y_pos > 0) THEN
+        WRITE(fmt,'("(I",I10.10,")")') y_pos-1
+        READ(tmp_str(1:y_pos-1),fmt) read_time
+        CALL ymds2ju (year+read_time,month,day,sec,date_new)
+        dd = date_new-date
+        ss = INT(dd)*one_day+dd-INT(dd)
+        itau = itau+NINT(ss/dt)
+        tmp_str = tmp_str(y_pos+1:LEN_TRIM(tmp_str))
+      ELSE IF (m_pos > 0) THEN
+        WRITE(fmt,'("(I",I10.10,")")') m_pos-1
+        READ(tmp_str(1:m_pos-1),fmt) read_time
+        CALL ymds2ju (year,month+read_time,day,sec,date_new)
+        dd = date_new-date
+        ss = INT(dd)*one_day+dd-INT(dd)
+        itau = itau+NINT(ss/dt)
+        tmp_str = tmp_str(m_pos+1:LEN_TRIM(tmp_str))
+      ELSE IF (d_pos > 0) THEN
+        WRITE(fmt,'("(I",I10.10,")")') d_pos-1
+        READ(tmp_str(1:d_pos-1),fmt) read_time
+        itau = itau+NINT(read_time*one_day/dt)
+        tmp_str = tmp_str(d_pos+1:LEN_TRIM(tmp_str))
+      ELSE IF (h_pos > 0) THEN
+        WRITE(fmt,'("(I",I10.10,")")') h_pos-1
+        READ(tmp_str(1:h_pos-1),fmt) read_time
+        itau = itau+NINT(read_time*60.*60./dt)
+        tmp_str = tmp_str(d_pos+1:LEN_TRIM(tmp_str))
+      ELSE IF  (s_pos > 0) THEN
+        WRITE(fmt,'("(I",I10.10,")")') s_pos-1
+        READ(tmp_str(1:s_pos-1),fmt) read_time
+        itau = itau+NINT(read_time/dt)
+        tmp_str = tmp_str(s_pos+1:LEN_TRIM(tmp_str))
+      ENDIF
+!-
+      y_pos = MAX(INDEX(tmp_str,'y'),INDEX(tmp_str,'Y'))
+      m_pos = MAX(INDEX(tmp_str,'m'),INDEX(tmp_str,'M'))
+      d_pos = MAX(INDEX(tmp_str,'d'),INDEX(tmp_str,'D'))
+      h_pos = MAX(INDEX(tmp_str,'h'),INDEX(tmp_str,'H'))
+      s_pos = MAX(INDEX(tmp_str,'s'),INDEX(tmp_str,'S'))
+    ENDDO
+  ELSE
+    WRITE(fmt,'("(I",I10.10,")")') LEN_TRIM(input_str)
+    READ(input_str(1:LEN_TRIM(input_str)),fmt) itau
+  ENDIF
+!-----------------------
+END SUBROUTINE tlen2itau
+!-
+!===
+!-
+REAL FUNCTION itau2date (itau,date0,deltat)
+!---------------------------------------------------------------------
+!- This function transforms itau into a date. The date with which
+!- the time axis is going to be labeled
+!-
+!- INPUT
+!-   itau   : current time step
+!-   date0  : Date at which itau was equal to 0
+!-   deltat : time step between itau s
+!-
+!- OUTPUT
+!-   itau2date : Date for the given itau
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER  :: itau
+  REAL     :: date0,deltat
+!---------------------------------------------------------------------
+  itau2date = REAL(itau)*deltat/one_day+date0
+!---------------------
+END FUNCTION itau2date
+!-
+!===
+!-
+SUBROUTINE itau2ymds (itau,deltat,year,month,day,sec)
+!---------------------------------------------------------------------
+!- This subroutine transforms itau into a date. The date with which
+!- the time axis is going to be labeled
+!-
+!- INPUT
+!-   itau   : current time step
+!-   deltat : time step between itau s
+!-
+!- OUTPUT
+!-   year  : year
+!-   month : month
+!-   day   : day
+!-   sec   : seconds since midnight
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: itau
+  REAL,INTENT(IN)    :: deltat
+!-
+  INTEGER,INTENT(OUT) :: year,month,day
+  REAL,INTENT(OUT)    :: sec
+!-
+  INTEGER :: julian_day
+  REAL    :: julian_sec
+!---------------------------------------------------------------------
+  IF (.NOT.lock_startdate) THEN
+    CALL ipslerr (2,'itau2ymds', &
+ &   'You try to call this function, itau2ymds, but you didn''t', &
+ &   ' call ioconf_startdate to initialize date0 in calendar.', &
+ &   ' Please call ioconf_startdate before itau2ymds.')
+  ENDIF
+  julian_day = start_day
+  julian_sec = start_sec+REAL(itau)*deltat
+  CALL ju2ymds_internal (julian_day,julian_sec,year,month,day,sec)
+!-----------------------
+END SUBROUTINE itau2ymds
+!-
+!===
+!-
+REAL FUNCTION dtchdate (itau,date0,old_dt,new_dt)
+!---------------------------------------------------------------------
+!- This function changes the date so that the simulation can
+!- continue with the same itau but a different dt.
+!-
+!- INPUT
+!-   itau   : current time step
+!-   date0  : Date at which itau was equal to 0
+!-   old_dt : Old time step between itaus
+!-   new_dt : New time step between itaus
+!-
+!- OUTPUT
+!-   dtchdate : Date for the given itau
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: itau
+  REAL,INTENT(IN)    :: date0,old_dt,new_dt
+!-
+  REAL :: rtime
+!---------------------------------------------------------------------
+  rtime = itau2date (itau,date0,old_dt)
+  dtchdate = rtime-REAL(itau)*new_dt/one_day
+!--------------------
+END FUNCTION dtchdate
+!-
+!===
+!-
+SUBROUTINE isittime &
+ &  (itau,date0,dt,freq,last_action,last_check,do_action)
+!---------------------------------------------------------------------
+!- This subroutine checks the time as come for a given action.
+!- This is computed from the current time-step(itau).
+!- Thus we need to have the time delta (dt), the frequency
+!- of the action (freq) and the last time it was done
+!- (last_action in units of itau).
+!- In order to extrapolate when will be the next check we need
+!- the time step of the last call (last_check).
+!-
+!- The test is done on the following condition :
+!- the distance from the current time to the time for the next
+!- action is smaller than the one from the next expected
+!- check to the next action.
+!- When the test is done on the time steps simplifications make
+!- it more difficult to read in the code.
+!- For the real time case it is easier to understand !
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: itau
+  REAL,INTENT(IN)    :: dt,freq
+  INTEGER,INTENT(IN) :: last_action,last_check
+  REAL,INTENT(IN)    :: date0
+!-
+  LOGICAL,INTENT(OUT)  :: do_action
+!-
+  REAL :: dt_action,dt_check
+  REAL :: date_last_act,date_next_check,date_next_act, &
+ &        date_now,date_mp1,date_mpf
+  INTEGER :: year,month,monthp1,day,next_check_itau,next_act_itau
+  INTEGER :: yearp,dayp
+  REAL :: sec,secp
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!---------------------------------------------------------------------
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) &
+ &    "isittime 1.0 ",itau,date0,dt,freq,last_action,last_check
+  ENDIF
+!-
+  IF (last_check >= 0) THEN
+    dt_action = (itau-last_action)*dt
+    dt_check = (itau-last_check)*dt
+    next_check_itau = itau+(itau-last_check)
+!-
+!-- We are dealing with frequencies in seconds and thus operation
+!-- can be done on the time steps.
+!-
+    IF (freq > 0) THEN
+      IF (ABS(dt_action-freq) <= ABS(dt_action+dt_check-freq)) THEN
+        do_action = .TRUE.
+      ELSE
+        do_action = .FALSE.
+      ENDIF
+!-
+!---- Here we deal with frequencies in month and work on julian days.
+!-
+    ELSE
+      date_now = itau2date (itau,date0,dt)
+      date_last_act = itau2date (last_action,date0,dt)
+      CALL ju2ymds (date_last_act,year,month,day,sec)
+      monthp1 = month-freq
+      yearp = year
+!-
+!---- Here we compute what logically should be the next month
+!-
+      IF (month >= 13) THEN
+        yearp = year+1
+        monthp1 = monthp1-12
+      ENDIF
+      CALL ymds2ju (year,monthp1,day,sec,date_mpf)
+!-
+!---- But it could be that because of a shorter month or a bad
+!---- starting date that we end up further than we should be.
+!---- Thus we compute the first day of the next month.
+!---- We can not be beyond this date and if we are close
+!---- then we will take it as it is better.
+!-
+      monthp1 = month+ABS(freq)
+      yearp=year
+      IF (monthp1 >= 13) THEN
+        yearp = year+1
+        monthp1 = monthp1 -12
+      ENDIF
+      dayp = 1
+      secp = 0.0
+      CALL ymds2ju (yearp,monthp1,dayp,secp,date_mp1)
+!-
+!---- If date_mp1 is smaller than date_mpf or only less than 4 days
+!---- larger then we take it. This needed to ensure that short month
+!---- like February do not mess up the thing !
+!-
+      IF (date_mp1-date_mpf < 4.) THEN
+        date_next_act = date_mp1
+      ELSE
+        date_next_act = date_mpf
+      ENDIF
+      date_next_check = itau2date (next_check_itau,date0,dt)
+!-
+!---- Transform the dates into time-steps for the needed precisions.
+!-
+      next_act_itau = &
+ &      last_action+INT((date_next_act-date_last_act)*(one_day/dt))
+!-----
+      IF (   ABS(itau-next_act_itau) &
+ &        <= ABS( next_check_itau-next_act_itau)) THEN
+        do_action = .TRUE.
+        IF (l_dbg) THEN
+          WRITE(ipslout,*) &
+ &         'ACT-TIME : itau, next_act_itau, next_check_itau : ', &
+ &         itau,next_act_itau,next_check_itau
+          CALL ju2ymds (date_now,year,month,day,sec)
+          WRITE(ipslout,*) 'ACT-TIME : y, m, d, s : ',year,month,day,sec
+          WRITE(ipslout,*) &
+ &         'ACT-TIME : date_mp1, date_mpf : ',date_mp1,date_mpf
+        ENDIF
+      ELSE
+        do_action = .FALSE.
+      ENDIF
+    ENDIF
+!-
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) "isittime 2.0 ", &
+ &     date_next_check,date_next_act,ABS(dt_action-freq), &
+ &     ABS(dt_action+dt_check-freq),dt_action,dt_check, &
+ &     next_check_itau,do_action
+    ENDIF
+  ELSE
+    do_action=.FALSE.
+  ENDIF
+!----------------------
+END SUBROUTINE isittime
+!-
+!===
+!-
+SUBROUTINE ioconf_calendar (str)
+!---------------------------------------------------------------------
+!- This routine allows to configure the calendar to be used.
+!- This operation is only allowed once and the first call to
+!- ymds2ju or ju2ymsd will lock the current configuration.
+!- the argument to ioconf_calendar can be any of the following :
+!-  - gregorian : This is the gregorian calendar (default here)
+!-  - noleap    : A calendar without leap years = 365 days
+!-  - xxxd      : A calendar of xxx days (has to be a modulo of 12)
+!-                with 12 month of equal length
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(IN) :: str
+!-
+  INTEGER :: leng,ipos
+  CHARACTER(LEN=20) :: str_w
+!---------------------------------------------------------------------
+!-
+! Clean up the string !
+!-
+  str_w = str
+  CALL strlowercase (str_w)
+!-
+  IF (.NOT.lock_one_year) THEN
+!---
+    lock_one_year=.TRUE.
+!---
+    SELECT CASE(TRIM(str_w))
+    CASE('gregorian','standard','proleptic_gregorian')
+      calendar_used = 'gregorian'
+      one_year = 365.2425
+      mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
+    CASE('noleap','365_day','365d')
+      calendar_used = 'noleap'
+      one_year = 365.0
+      mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
+    CASE('all_leap','366_day','366d')
+      calendar_used = 'all_leap'
+      one_year = 366.0
+      mon_len(:)=(/31,29,31,30,31,30,31,31,30,31,30,31/)
+    CASE('360_day','360d')
+      calendar_used = '360d'
+      one_year = 360.0
+      mon_len(:)=(/30,30,30,30,30,30,30,30,30,30,30,30/)
+    CASE('julian')
+      calendar_used = 'julian'
+      one_year = 365.25
+      mon_len(:)=(/31,28,31,30,31,30,31,31,30,31,30,31/)
+    CASE DEFAULT
+      ipos = INDEX(str_w,'d')
+      IF (ipos == 4) THEN
+        READ(str_w(1:3),'(I3)') leng
+        IF ( (MOD(leng,12) == 0).AND.(leng > 1) ) THEN
+          calendar_used = str_w
+          one_year = leng
+          mon_len(:) = leng/12
+        ELSE
+          CALL ipslerr (3,'ioconf_calendar', &
+ &         'The length of the year as to be a modulo of 12', &
+ &         'so that it can be divided into 12 month of equal length', &
+ &         TRIM(str_w))
+        ENDIF
+      ELSE
+        CALL ipslerr (3,'ioconf_calendar', &
+ &       'Unrecognized input, please check the man pages.', &
+ &       TRIM(str_w),' ')
+      ENDIF
+    END SELECT
+  ELSE IF (TRIM(str_w) /= TRIM(calendar_used)) THEN
+    WRITE(str_w,'(f10.4)') one_year
+    CALL ipslerr (2,'ioconf_calendar', &
+ &   'The calendar was already used or configured to : '// &
+ &    TRIM(calendar_used)//'.', &
+ &   'You are not allowed to change it to : '//TRIM(str)//'.', &
+ &   'The following length of year is used : '//TRIM(ADJUSTL(str_w)))
+  ENDIF
+!-----------------------------
+END SUBROUTINE ioconf_calendar
+!-
+!===
+!-
+SUBROUTINE ioconf_startdate_simple (julian)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  REAL,INTENT(IN) :: julian
+!-
+  INTEGER :: julian_day
+  REAL    :: julian_sec
+!---------------------------------------------------------------------
+  julian_day = INT(julian)
+  julian_sec = (julian-julian_day)*one_day
+!-
+  CALL ioconf_startdate_internal (julian_day,julian_sec)
+!-------------------------------------
+END SUBROUTINE ioconf_startdate_simple
+!-
+!===
+!-
+SUBROUTINE ioconf_startdate_ymds (year,month,day,sec)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: year,month,day
+  REAL,INTENT(IN)    :: sec
+!-
+  INTEGER :: julian_day
+  REAL    :: julian_sec
+!---------------------------------------------------------------------
+  CALL ymds2ju_internal (year,month,day,sec,julian_day,julian_sec)
+!-
+  CALL ioconf_startdate_internal (julian_day,julian_sec)
+!-----------------------------------
+END SUBROUTINE ioconf_startdate_ymds
+!-
+!===
+!-
+SUBROUTINE ioconf_startdate_internal (julian_day,julian_sec)
+!---------------------------------------------------------------------
+! This subroutine allows to set the startdate for later
+! use. It allows the applications to access the date directly from
+! the timestep. In order to avoid any problems the start date will
+! be locked and can not be changed once set.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN)  :: julian_day
+  REAL,INTENT(IN)     :: julian_sec
+!-
+  CHARACTER(len=70) :: str70a,str70b
+!---------------------------------------------------------------------
+  IF (.NOT.lock_startdate) THEN
+    start_day = julian_day
+    start_sec = julian_sec
+    lock_startdate = .TRUE.
+  ELSE
+    WRITE(str70a,'("The date you tried to set : ",f10.4)') &
+ &   julian_day,julian_sec/one_day
+    WRITE(str70b, &
+ &   '("The date which was already set in the calendar : ",f10.4)') &
+ &   start_day+start_sec/one_day
+    CALL ipslerr (2,'ioconf_startdate', &
+ &   'The start date has already been set and you tried to change it', &
+ &   str70a,str70b)
+  ENDIF
+!---------------------------------------
+END SUBROUTINE ioconf_startdate_internal
+!-
+!===
+!-
+SUBROUTINE ioget_calendar_str (str)
+!---------------------------------------------------------------------
+!- This subroutine returns the name of the calendar used here.
+!- Three options exist :
+!-  - gregorian : This is the gregorian calendar (default here)
+!-  - noleap    : A calendar without leap years = 365 days
+!-  - xxxd      : A calendar of xxx days (has to be a modulo of 12)
+!-                with 12 month of equal length
+!-
+!- This routine will lock the calendar.
+!- You do not want it to change after your inquiry.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(OUT) :: str
+!---------------------------------------------------------------------
+  lock_one_year = .TRUE.
+!-
+  str = calendar_used
+!--------------------------------
+END SUBROUTINE ioget_calendar_str
+!-
+!===
+!-
+SUBROUTINE ioget_calendar_real1 (long_year)
+!---------------------------------------------------------------------
+!- This subroutine returns the name of the calendar used here.
+!- Three options exist :
+!-  - gregorian : This is the gregorian calendar (default here)
+!-  - noleap    : A calendar without leap years = 365 days
+!-  - xxxd      : A calendar of xxx days (has to be a modulo of 12)
+!-                with 12 month of equal length
+!-
+!- This routine will lock the calendar.
+!- You do not want it to change after your inquiry.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  REAL,INTENT(OUT) :: long_year
+!---------------------------------------------------------------------
+  long_year = one_year
+  lock_one_year = .TRUE.
+!----------------------------------
+END SUBROUTINE ioget_calendar_real1
+!-
+!===
+!-
+SUBROUTINE ioget_calendar_real2 (long_year,long_day)
+!---------------------------------------------------------------------
+!- This subroutine returns the name of the calendar used here.
+!- Three options exist :
+!-  - gregorian : This is the gregorian calendar (default here)
+!-  - noleap    : A calendar without leap years = 365 days
+!-  - xxxd      : A calendar of xxx days (has to be a modulo of 12)
+!-                with 12 month of equal length
+!-
+!- This routine will lock the calendar.
+!- You do not want it to change after your inquiry.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  REAL,INTENT(OUT) :: long_year,long_day
+!---------------------------------------------------------------------
+  long_year = one_year
+  long_day  = one_day
+  lock_one_year = .TRUE.
+!----------------------------------
+END SUBROUTINE ioget_calendar_real2
+!-
+!===
+!-
+INTEGER FUNCTION ioget_mon_len (year,month)
+!!--------------------------------------------------------------------
+!! The "ioget_mon_len" function returns
+!! the number of days in a "month" of a "year",
+!! in the current calendar.
+!!
+!! INTEGER FUNCTION ioget_mon_len (year,month)
+!!
+!! INPUT
+!!
+!! (I) year  : year
+!! (I) month : month in the year (1 --> 12)
+!!
+!! OUTPUT
+!!
+!! (I) ioget_mon_len : number of days in the month
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: year,month
+!-
+  INTEGER :: ml
+!---------------------------------------------------------------------
+  IF ( (month >= 1).AND.(month <= 12) ) THEN
+    IF ( (one_year > 365.0).AND.(one_year < 366.0) ) THEN
+!---- "Gregorian" or "Julian"
+      ml = mon_len(month)
+      IF (month == 2) THEN
+        IF (ABS(one_year-365.2425) <= EPSILON(one_year) ) THEN
+!-------- "Gregorian"
+          IF (    ((MOD(year,4) == 0).AND.(MOD(year,100) /= 0)) &
+              .OR.(MOD(year,400) == 0) ) THEN
+            ml = ml+1
+          ENDIF
+        ELSE
+!-------- "Julian"
+          IF (MOD(year,4) == 0) THEN
+            ml = ml+1
+          ENDIF
+        ENDIF
+      ENDIF
+      ioget_mon_len = ml
+    ELSE
+!---- "No leap" or "All leap" or "Calendar with regular month"
+      ioget_mon_len = mon_len(month)
+    ENDIF
+  ELSE
+    CALL ipslerr (3,'ioget_mon_len', &
+ &    'The number of the month','must be between','1 and 12')
+  ENDIF
+!-------------------------
+END FUNCTION ioget_mon_len
+!-
+!===
+!-
+INTEGER FUNCTION ioget_year_len (year)
+!!--------------------------------------------------------------------
+!! The "ioget_year_len" function returns
+!! the number of days in "year", in the current calendar.
+!!
+!! INTEGER FUNCTION ioget_year_len (year)
+!!
+!! INPUT
+!!
+!! (I) year  : year
+!!
+!! OUTPUT
+!!
+!! (I) ioget_year_len : number of days in the year
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: year
+!-
+  INTEGER :: yl
+!---------------------------------------------------------------------
+  SELECT CASE(TRIM(calendar_used))
+  CASE('gregorian')
+    yl = 365
+    IF (    ((MOD(year,4) == 0).AND.(MOD(year,100) /= 0)) &
+        .OR.(MOD(year,400) == 0) ) THEN
+      yl = yl+1
+    ENDIF
+  CASE('julian')
+    yl = 365
+    IF (MOD(year,4) == 0) THEN
+      yl = yl+1
+    ENDIF
+  CASE DEFAULT
+    yl = NINT(one_year)
+  END SELECT
+  ioget_year_len = yl
+!--------------------------
+END FUNCTION ioget_year_len
+!-
+!===
+!-
+SUBROUTINE ioget_timestamp (string)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=30),INTENT(OUT) :: string
+!-
+  INTEGER :: date_time(8)
+  CHARACTER(LEN=10) :: bigben(3)
+!---------------------------------------------------------------------
+  IF (INDEX(time_stamp,'XXXXXX') > 0) THEN
+    CALL DATE_AND_TIME (bigben(1),bigben(2),bigben(3),date_time)
+!---
+    WRITE(time_stamp, &
+ &   "(I4.4,'-',A3,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2,' GMT',a5)") &
+ &   date_time(1),cal(date_time(2)),date_time(3),date_time(5), &
+ &   date_time(6),date_time(7),bigben(3)
+  ENDIF
+!-
+  string = time_stamp
+!-----------------------------
+END SUBROUTINE ioget_timestamp
+!-
+!===
+!-
+SUBROUTINE time_add &
+ &  (year_s,month_s,day_s,sec_s,sec_increment, &
+ &   year_e,month_e,day_e,sec_e)
+!---------------------------------------------------------------------
+!- This subroutine allows to increment a date by a number of seconds.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: year_s,month_s,day_s
+  REAL,INTENT(IN)    :: sec_s
+!-
+! Time in seconds to be added to the date
+!-
+  REAL,INTENT(IN)    :: sec_increment
+!-
+  INTEGER,INTENT(OUT) :: year_e,month_e,day_e
+  REAL,INTENT(OUT)    :: sec_e
+!-
+  INTEGER :: julian_day
+  REAL    :: julian_sec
+!---------------------------------------------------------------------
+  CALL ymds2ju_internal &
+ &  (year_s,month_s,day_s,sec_s,julian_day,julian_sec)
+!-
+  julian_sec = julian_sec+sec_increment
+!-
+  CALL ju2ymds_internal &
+ &  (julian_day,julian_sec,year_e,month_e,day_e,sec_e)
+!----------------------
+END SUBROUTINE time_add
+!-
+!===
+!-
+SUBROUTINE time_diff &
+ &  (year_s,month_s,day_s,sec_s,year_e,month_e,day_e,sec_e,sec_diff)
+!---------------------------------------------------------------------
+!- This subroutine allows to determine the number of seconds
+!- between two dates.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: year_s,month_s,day_s
+  REAL,INTENT(IN)    :: sec_s
+  INTEGER,INTENT(IN) :: year_e,month_e,day_e
+  REAL,INTENT(IN)    :: sec_e
+!-
+! Time in seconds between the two dates
+!-
+  REAL,INTENT(OUT)    :: sec_diff
+!-
+  INTEGER :: julian_day_s,julian_day_e,day_diff
+  REAL    :: julian_sec_s,julian_sec_e
+!---------------------------------------------------------------------
+  CALL ymds2ju_internal &
+ &  (year_s,month_s,day_s,sec_s,julian_day_s,julian_sec_s)
+  CALL ymds2ju_internal &
+ &  (year_e,month_e,day_e,sec_e,julian_day_e,julian_sec_e)
+!-
+  day_diff = julian_day_e-julian_day_s
+  sec_diff = julian_sec_e-julian_sec_s
+!-
+  sec_diff = sec_diff+day_diff*one_day
+!-----------------------
+END SUBROUTINE time_diff
+!-
+!===
+!-
+END MODULE calendar
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/defprec.f90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/defprec.f90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/defprec.f90	(revision 17)
@@ -0,0 +1,22 @@
+MODULE defprec 
+!-
+! $Id: def.prec 386 2008-09-04 08:38:48Z bellier $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!!--------------------------------------------------------------------
+!! The module "defprec" set default precision for computation
+!!
+!! This module should be used by every modules
+!! to keep the right precision for every variable
+!!--------------------------------------------------------------------
+!?INTEGERS of KIND 1 are not supported on all computers
+!?INTEGER,PARAMETER :: i_1=SELECTED_INT_KIND(2)
+  INTEGER,PARAMETER :: i_2=SELECTED_INT_KIND(4)
+  INTEGER,PARAMETER :: i_4=SELECTED_INT_KIND(9)
+  INTEGER,PARAMETER :: i_8=SELECTED_INT_KIND(13)
+  INTEGER,PARAMETER :: r_4=SELECTED_REAL_KIND(6,37)
+  INTEGER,PARAMETER :: r_8=SELECTED_REAL_KIND(15,307)
+  INTEGER,PARAMETER :: i_std=i_4, r_std=r_8
+!-----------------
+END MODULE defprec
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/errioipsl.f90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/errioipsl.f90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/errioipsl.f90	(revision 17)
@@ -0,0 +1,216 @@
+MODULE errioipsl
+!-
+!$Id: errioipsl.f90 2078 2013-06-03 08:55:43Z jgipsl $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+IMPLICIT NONE
+!-
+PRIVATE
+!-
+PUBLIC :: ipslnlf, ipslerr, ipslerr_act, ipslerr_inq, histerr, ipsldbg, ipslout
+!-
+  INTEGER :: ipslout=6, ilv_cur=0, ilv_max=0
+  LOGICAL :: ioipsl_debug=.FALSE., lact_mode=.TRUE.
+!-
+!===
+CONTAINS
+!===
+SUBROUTINE ipslnlf (new_number,old_number)
+!!--------------------------------------------------------------------
+!! The "ipslnlf" routine allows to know and modify
+!! the current logical number for the messages.
+!!
+!! SUBROUTINE ipslnlf (new_number,old_number)
+!!
+!! Optional INPUT argument
+!!
+!! (I) new_number : new logical number of the file
+!!
+!! Optional OUTPUT argument
+!!
+!! (I) old_number : current logical number of the file
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,OPTIONAL,INTENT(IN)  :: new_number
+  INTEGER,OPTIONAL,INTENT(OUT) :: old_number
+!---------------------------------------------------------------------
+  IF (PRESENT(old_number)) THEN
+    old_number = ipslout
+  ENDIF
+  IF (PRESENT(new_number)) THEN
+    ipslout = new_number
+  ENDIF
+!---------------------
+END SUBROUTINE ipslnlf
+!===
+SUBROUTINE ipslerr (plev,pcname,pstr1,pstr2,pstr3)
+!---------------------------------------------------------------------
+!! The "ipslerr" routine
+!! allows to handle the messages to the user.
+!!
+!! INPUT
+!!
+!! plev   : Category of message to be reported to the user
+!!          1 = Note to the user
+!!          2 = Warning to the user
+!!          3 = Fatal error
+!! pcname : Name of subroutine which has called ipslerr
+!! pstr1   
+!! pstr2  : Strings containing the explanations to the user
+!! pstr3
+!---------------------------------------------------------------------
+   IMPLICIT NONE
+!-
+   INTEGER :: plev
+   CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3
+!-
+   CHARACTER(LEN=30),DIMENSION(3) :: pemsg = &
+  &  (/ "NOTE TO THE USER FROM ROUTINE ", &
+  &     "WARNING FROM ROUTINE          ", &
+  &     "FATAL ERROR FROM ROUTINE      " /)
+!---------------------------------------------------------------------
+   IF ( (plev >= 1).AND.(plev <= 3) ) THEN
+     ilv_cur = plev
+     ilv_max = MAX(ilv_max,plev)
+     WRITE(ipslout,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname)
+     WRITE(ipslout,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3)
+   ENDIF
+   IF ( (plev == 3).AND.lact_mode) THEN
+     WRITE(ipslout,'("Fatal error from IOIPSL. STOP in ipslerr with code")')
+     STOP 1
+   ENDIF
+!---------------------
+END SUBROUTINE ipslerr
+!===
+SUBROUTINE ipslerr_act (new_mode,old_mode)
+!!--------------------------------------------------------------------
+!! The "ipslerr_act" routine allows to know and modify
+!! the current "action mode" for the error messages,
+!! and reinitialize the error level values.
+!!
+!! SUBROUTINE ipslerr_act (new_mode,old_mode)
+!!
+!! Optional INPUT argument
+!!
+!! (I) new_mode : new error action mode
+!!                .TRUE.  -> STOP     in case of fatal error
+!!                .FALSE. -> CONTINUE in case of fatal error
+!!
+!! Optional OUTPUT argument
+!!
+!! (I) old_mode : current error action mode
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  LOGICAL,OPTIONAL,INTENT(IN)  :: new_mode
+  LOGICAL,OPTIONAL,INTENT(OUT) :: old_mode
+!---------------------------------------------------------------------
+  IF (PRESENT(old_mode)) THEN
+    old_mode = lact_mode
+  ENDIF
+  IF (PRESENT(new_mode)) THEN
+    lact_mode = new_mode
+  ENDIF
+  ilv_cur = 0
+  ilv_max = 0
+!-------------------------
+END SUBROUTINE ipslerr_act
+!===
+SUBROUTINE ipslerr_inq (current_level,maximum_level)
+!!--------------------------------------------------------------------
+!! The "ipslerr_inq" routine allows to know
+!! the current level of the error messages
+!! and the maximum level encountered since the
+!! last call to "ipslerr_act".
+!!
+!! SUBROUTINE ipslerr_inq (current_level,maximum_level)
+!!
+!! Optional OUTPUT argument
+!!
+!! (I) current_level : current error level
+!! (I) maximum_level : maximum error level
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,OPTIONAL,INTENT(OUT) :: current_level,maximum_level
+!---------------------------------------------------------------------
+  IF (PRESENT(current_level)) THEN
+    current_level = ilv_cur
+  ENDIF
+  IF (PRESENT(maximum_level)) THEN
+    maximum_level = ilv_max
+  ENDIF
+!-------------------------
+END SUBROUTINE ipslerr_inq
+!===
+SUBROUTINE histerr (plev,pcname,pstr1,pstr2,pstr3)
+!---------------------------------------------------------------------
+!- INPUT
+!- plev   : Category of message to be reported to the user
+!-          1 = Note to the user
+!-          2 = Warning to the user
+!-          3 = Fatal error
+!- pcname : Name of subroutine which has called histerr
+!- pstr1   
+!- pstr2  : String containing the explanations to the user
+!- pstr3
+!---------------------------------------------------------------------
+   IMPLICIT NONE
+!-
+   INTEGER :: plev
+   CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3
+!-
+   CHARACTER(LEN=30),DIMENSION(3) :: pemsg = &
+  &  (/ "NOTE TO THE USER FROM ROUTINE ", &
+  &     "WARNING FROM ROUTINE          ", &
+  &     "FATAL ERROR FROM ROUTINE      " /)
+!---------------------------------------------------------------------
+   IF ( (plev >= 1).AND.(plev <= 3) ) THEN
+     WRITE(*,'("     ")')
+     WRITE(*,'(A," ",A)') TRIM(pemsg(plev)),TRIM(pcname)
+     WRITE(*,'(" --> ",A)') pstr1
+     WRITE(*,'(" --> ",A)') pstr2
+     WRITE(*,'(" --> ",A)') pstr3
+   ENDIF
+   IF (plev == 3) THEN
+     WRITE(ipslout,'("Fatal error from IOIPSL. See stdout for more details")')
+     STOP 1 
+   ENDIF
+!---------------------
+END SUBROUTINE histerr
+!===
+SUBROUTINE ipsldbg (new_status,old_status)
+!!--------------------------------------------------------------------
+!! The "ipsldbg" routine
+!! allows to activate or deactivate the debug,
+!! and to know the current status of the debug.
+!!
+!! SUBROUTINE ipsldbg (new_status,old_status)
+!!
+!! Optional INPUT argument
+!!
+!! (L) new_status : new status of the debug
+!!
+!! Optional OUTPUT argument
+!!
+!! (L) old_status : current status of the debug
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  LOGICAL,OPTIONAL,INTENT(IN)  :: new_status
+  LOGICAL,OPTIONAL,INTENT(OUT) :: old_status
+!---------------------------------------------------------------------
+  IF (PRESENT(old_status)) THEN
+    old_status = ioipsl_debug
+  ENDIF
+  IF (PRESENT(new_status)) THEN
+    ioipsl_debug = new_status
+  ENDIF
+!---------------------
+END SUBROUTINE ipsldbg
+!===
+!-------------------
+END MODULE errioipsl
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/flincom.f90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/flincom.f90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/flincom.f90	(revision 17)
@@ -0,0 +1,2032 @@
+MODULE flincom
+!-
+!$Id: flincom.f90 1932 2012-11-28 09:56:17Z jgipsl $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+  USE netcdf
+!-
+  USE calendar,  ONLY : ju2ymds, ymds2ju, ioconf_calendar
+  USE errioipsl, ONLY : histerr, ipslout,ipslerr,ipsldbg
+  USE stringop,  ONLY : strlowercase
+!-
+  IMPLICIT NONE
+!-
+  PRIVATE
+  PUBLIC :: flinput, flincre, flinget, flinclo, &
+            flinopen, flininfo, flininspect, flinquery_var
+!-
+  INTERFACE flinopen
+!---------------------------------------------------------------------
+!- The "flinopen" routines will open an input file
+!-
+!- INPUT
+!-
+!- filename  : Name of the netCDF file to be opened
+!-
+!- iideb     : index i for zoom     !
+!- iilen     : length  of  zoom     !   for
+!- jjdeb     : index j for zoom     !   zoom
+!- jjlen     : length  of  zoom     !
+!-
+!- do_test   : A flag that enables the testing of the content
+!-             of the file against the input from the model
+!-
+!- INPUT if do_test=TRUE      OUTPUT else
+!-
+!- iim       : size in the x direction in the file (longitude)
+!- jjm       : size in the y direction
+!- llm       : number of levels
+!-             (llm = 0 means no axis to be expected)
+!- lon       : array of (iilen,jjlen) (zoom), or (iim,jjm) (no zoom),
+!-             that contains the longitude of each point
+!- lat       : same for latitude
+!- lev       : An array of llm for the latitude
+!-
+!- WARNING :
+!- In the case of do_test=FALSE it is for the user to check
+!- that the dimensions of lon lat and lev are correct when passed to
+!- flinopen. This can be done after the call when iim and jjm have
+!- been retrieved from the netCDF file. In F90 this problem will
+!- be solved with an internal assign
+!- IF iim, jjm, llm or ttm are parameters in the calling program and
+!- you use the option do_test=FALSE it will create a segmentation fault
+!-
+!-  OUTPUT
+!-
+!-  ttm       : size of time axis
+!-  itaus     : Time steps within this file
+!-  date0     : Julian date at which itau = 0
+!-  dt        : length of the time steps of the data
+!-  fid       : returned file ID which is later used to read the data
+!---------------------------------------------------------------------
+    MODULE PROCEDURE flinopen_zoom2d, flinopen_nozoom
+  END INTERFACE
+!-
+  INTERFACE flinput
+!---------------------------------------------------------------------
+!- The "flinput" routines will put a variable
+!- on the netCDF file created by flincre.
+!- If the sizes of the axis do not match the one of the IDs
+!- then a new axis is created.
+!- That is we loose the possibility of writting hyperslabs of data.
+!-
+!- Again here if iim = jjm = llm = ttm = 0
+!- then a global attribute is added to the file.
+!-
+!- INPUT
+!-
+!- fid      : Identification of the file in which we will write
+!- varname  : Name of variable to be written
+!- iim      : size in x of variable
+!- nlonid   : ID of x axis which could fit for this axis
+!- jjm      : size in y of variable
+!- nlatid   : ID of y axis which could fit for this axis
+!- llm      : size in z of variable
+!- zdimid   : ID of z axis which could fit for this axis
+!- ttm      : size in t of variable
+!- tdimid   : ID of t axis which could fit for this axis
+!-
+!- OUTPUT
+!-
+!- NONE
+!---------------------------------------------------------------------
+    MODULE PROCEDURE flinput_r4d, flinput_r3d, flinput_r2d, &
+                     flinput_r1d, flinput_scal
+  END INTERFACE
+!-
+  INTERFACE flinget
+    MODULE PROCEDURE flinget_r4d, flinget_r3d, flinget_r2d, &
+                     flinget_r1d, flinget_scal, &
+                     flinget_r4d_zoom2d, flinget_r3d_zoom2d, &
+                     flinget_r2d_zoom2d
+  END INTERFACE
+!-
+! This is the data we keep on each file we open
+!-
+  INTEGER, PARAMETER :: nbfile_max = 200
+  INTEGER, SAVE :: nbfiles = 0
+  INTEGER, SAVE :: ncids(nbfile_max), ncnbd(nbfile_max), &
+                   ncfunli(nbfile_max), ncnba(nbfile_max)
+  INTEGER, SAVE :: ncnbva(nbfile_max), ncdims(nbfile_max,4)
+  LOGICAL, SAVE :: ncfileopen(nbfile_max)=.FALSE.
+!-
+  INTEGER, SAVE :: cind_vid, cind_fid, cind_len
+  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: cindex
+!-
+  INTEGER,DIMENSION(4) :: w_sta, w_len, w_dim
+!-
+CONTAINS
+!-
+!===
+!-
+SUBROUTINE flincre &
+  (filename, iim1, jjm1, lon1, lat1, llm1, lev1, ttm1, itaus, &
+   time0, dt, fid_out, nlonid1, nlatid1, zdimid1, tdimid1)
+!---------------------------------------------------------------------
+!- This is a "low level" subroutine for opening netCDF files wich
+!- contain the major coordinate system of the model.
+!- Other coordinates needed for other variables
+!- will be added as they are needed.
+!-
+!- INPUT
+!-
+!- filename    : Name of the file to be created
+!- iim1, jjm1  : Horizontal size of the grid
+!-               which will be stored in the file
+!- lon1, lat1  : Horizontal grids
+!- llm1        : Size of the vertical grid
+!- lev1        : Vertical grid
+!- ttm1        : Size of time axis
+!- itaus       : time steps on the time axis
+!- time0       : Time in julian days at which itau = 0
+!- dt          : time step in seconds between itaus
+!-               (one step of itau)
+!-
+!- OUTPUT
+!-
+!- fid         : File identification
+!- nlonid1     : Identification of longitudinal axis
+!- nlatid1     : Identification of latitudinal axis
+!- zdimid1     : ID of vertical axis
+!- tdimid1     : ID of time axis
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! ARGUMENTS
+!-
+  CHARACTER(LEN=*) :: filename
+  INTEGER :: iim1, jjm1, llm1, ttm1
+  REAL :: lon1(iim1,jjm1)
+  REAL :: lat1(iim1,jjm1)
+  REAL :: lev1(llm1)
+  INTEGER :: itaus(ttm1)
+  REAL :: time0
+  REAL :: dt
+  INTEGER :: fid_out, zdimid1, nlonid1, nlatid1, tdimid1
+!-
+! LOCAL
+!-
+  INTEGER :: iret, lll, fid
+  INTEGER :: lonid, latid, levid, timeid
+  INTEGER :: year, month, day
+  REAL :: sec
+  CHARACTER(LEN=250):: name
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  lll = LEN_TRIM(filename)
+  IF (filename(lll-2:lll) /= '.nc') THEN
+    name=filename(1:lll)//'.nc'
+  ELSE
+    name=filename(1:lll)
+  ENDIF
+!-
+  iret = NF90_CREATE (name, NF90_CLOBBER, fid)
+!-
+  iret = NF90_DEF_DIM (fid, 'x',     iim1, nlonid1)
+  iret = NF90_DEF_DIM (fid, 'y',     jjm1, nlatid1)
+  iret = NF90_DEF_DIM (fid, 'lev',   llm1, zdimid1)
+  iret = NF90_DEF_DIM (fid, 'tstep', ttm1, tdimid1)
+!-
+! Vertical axis
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'flincre Vertical axis'
+!-
+  iret = NF90_DEF_VAR (fid, 'lev', NF90_FLOAT, zdimid1, levid)
+  iret = NF90_PUT_ATT (fid, levid, 'units',     '-')
+  iret = NF90_PUT_ATT (fid, levid, 'title',     'levels')
+  iret = NF90_PUT_ATT (fid, levid, 'long_name', 'Sigma Levels')
+!-
+! Time axis
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'flincre time axis'
+!-
+  iret = NF90_DEF_VAR (fid, 'tstep', NF90_FLOAT, tdimid1, timeid)
+  iret = NF90_PUT_ATT (fid, timeid, 'units',     '-')
+  iret = NF90_PUT_ATT (fid, timeid, 'title',     'time')
+  iret = NF90_PUT_ATT (fid, timeid, 'long_name', 'time steps')
+!-
+! The longitude
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'flincre Longitude axis'
+!-
+  iret = NF90_DEF_VAR (fid, "nav_lon", NF90_FLOAT, &
+                       (/ nlonid1, nlatid1 /), lonid)
+  iret = NF90_PUT_ATT (fid, lonid, 'units', "degrees_east")
+  iret = NF90_PUT_ATT (fid, lonid, 'title', "Longitude")
+  iret = NF90_PUT_ATT (fid, lonid, 'nav_model', &
+                       "Lambert projection of PROMES")
+  iret = NF90_PUT_ATT (fid, lonid, 'valid_min', &
+                       REAL(MINVAL(lon1),KIND=4))
+  iret = NF90_PUT_ATT (fid, lonid, 'valid_max', &
+                       REAL(MAXVAL(lon1),KIND=4))
+!-
+! The Latitude
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'flincre Latitude axis'
+!-
+  iret = NF90_DEF_VAR (fid, "nav_lat", NF90_FLOAT, &
+                     (/ nlonid1, nlatid1 /), latid)
+  iret = NF90_PUT_ATT (fid, latid, 'units', "degrees_north")
+  iret = NF90_PUT_ATT (fid, latid, 'title', "Latitude")
+  iret = NF90_PUT_ATT (fid, latid, 'nav_model', &
+                       "Lambert projection of PROMES")
+  iret = NF90_PUT_ATT (fid, latid, 'valid_min', &
+                       REAL(MINVAL(lat1),KIND=4))
+  iret = NF90_PUT_ATT (fid, latid, 'valid_max', &
+                       REAL(MAXVAL(lat1),KIND=4))
+!-
+! The time coordinates
+!-
+  iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'delta_tstep_sec', &
+                       REAL(dt,KIND=4))
+!-
+  CALL ju2ymds (time0, year, month, day, sec)
+!-
+  iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'year0',  REAL(year,KIND=4))
+  iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'month0', REAL(month,KIND=4))
+  iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'day0',   REAL(day,KIND=4))
+  iret = NF90_PUT_ATT (fid, NF90_GLOBAL, 'sec0',   REAL(sec,KIND=4))
+!-
+  iret = NF90_ENDDEF (fid)
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'flincre Variable'
+!-
+  iret = NF90_PUT_VAR (fid, levid, lev1(1:llm1))
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'flincre Time Variable'
+!-
+  iret = NF90_PUT_VAR (fid, timeid, REAL(itaus(1:ttm1)))
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'flincre Longitude'
+!-
+  iret = NF90_PUT_VAR (fid, lonid, lon1(1:iim1,1:jjm1))
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'flincre Latitude'
+!-
+  iret = NF90_PUT_VAR (fid, latid, lat1(1:iim1,1:jjm1))
+!-
+! Keep all this information
+!-
+  nbfiles = nbfiles+1
+!-
+  IF (nbfiles > nbfile_max) THEN
+    CALL histerr (3,'flincre', &
+     'Too many files. Please increase nbfil_max', &
+     'in program flincom.F90.',' ')
+  ENDIF
+!-
+  ncids(nbfiles) = fid
+  ncnbd(nbfiles) = 4
+!-
+  ncdims(nbfiles,1:4) = (/ iim1, jjm1, llm1, ttm1 /)
+!-
+  ncfunli(nbfiles) = -1
+  ncnba(nbfiles)   =  4
+  ncnbva(nbfiles)  =  0
+  ncfileopen(nbfiles) = .TRUE.
+!-
+  fid_out = nbfiles
+!---------------------
+END SUBROUTINE flincre
+!-
+!===
+!-
+SUBROUTINE flinopen_zoom2d &
+  (filename, iideb, iilen, jjdeb, jjlen, do_test, &
+  iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! ARGUMENTS
+!-
+  CHARACTER(LEN=*) :: filename
+  LOGICAL :: do_test
+  INTEGER :: iim, jjm, llm, ttm, iideb, iilen, jjdeb, jjlen
+  REAL :: lon(iilen,jjlen), lat(iilen,jjlen), lev(llm)
+  INTEGER :: itaus(ttm)
+  REAL :: date0, dt
+  INTEGER :: fid_out
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  IF (l_dbg) WRITE (*,*) ' iideb, iilen, jjdeb, jjlen, iim, jjm ', &
+                           iideb, iilen, jjdeb, jjlen, iim, jjm
+  IF (l_dbg) WRITE (*,*) ' lon ', lon(1,1), lon(iilen,jjlen)
+  IF (l_dbg) WRITE (*,*) ' lat ', lat(1,1), lat(iilen,jjlen)
+!-
+  CALL flinopen_work &
+    (filename, iideb, iilen, jjdeb, jjlen, do_test, &
+     iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out)
+!-----------------------------
+END SUBROUTINE flinopen_zoom2d
+!-
+!===
+!-
+SUBROUTINE flinopen_nozoom &
+  (filename, do_test, iim, jjm, llm, lon, lat, lev, ttm, &
+   itaus, date0, dt, fid_out)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! ARGUMENTS
+!-
+  CHARACTER(LEN=*) :: filename
+  LOGICAL :: do_test
+  INTEGER :: iim, jjm, llm, ttm
+  REAL :: lon(iim,jjm), lat(iim,jjm), lev(llm)
+  INTEGER :: itaus(ttm)
+  REAL :: date0, dt
+  INTEGER :: fid_out
+  INTEGER :: iimc, jjmc
+!---------------------------------------------------------------------
+  iimc=iim
+  jjmc=jjm
+  CALL flinopen_work &
+    (filename, 1, iimc, 1, jjmc, do_test, &
+     iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out)
+!-------------------------
+END SUBROUTINE flinopen_nozoom
+!-
+!===
+!-
+SUBROUTINE flinopen_work &
+  (filename, iideb, iilen, jjdeb, jjlen, do_test, &
+   iim, jjm, llm, lon, lat, lev, ttm, itaus, date0, dt, fid_out)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! ARGUMENTS
+!-
+  CHARACTER(LEN=*) :: filename
+  LOGICAL :: do_test
+  INTEGER :: iim, jjm, llm, ttm, iideb, iilen, jjdeb, jjlen
+  REAL :: lon(iilen,jjlen), lat(iilen,jjlen), lev(llm)
+  INTEGER :: itaus(ttm)
+  REAL :: date0, dt
+  INTEGER :: fid_out
+!-
+! LOCAL
+!-
+  REAL, PARAMETER :: eps = 1.e-4
+!-
+  INTEGER :: iret, vid, fid, nbdim, i, iilast, jjlast
+  INTEGER :: gdtt_id, old_id, iv, gdtmaf_id
+  CHARACTER(LEN=250) :: name
+  CHARACTER(LEN=80) :: units, calendar
+  INTEGER :: tmp_iim, tmp_jjm, tmp_llm, tmp_ttm
+  REAL :: x_first, x_last
+  INTEGER :: year, month, day
+  REAL :: r_year, r_month, r_day
+  INTEGER :: year0, month0, day0, hours0, minutes0, seci
+  REAL :: sec, sec0
+  CHARACTER :: strc
+!-
+  REAL,DIMENSION(:),ALLOCATABLE :: vec_tmp
+!-
+  LOGICAL :: open_file
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  iilast = iideb+iilen-1
+  jjlast = jjdeb+jjlen-1
+  IF (l_dbg) WRITE (*,*) &
+    ' flinopen_work zoom 2D information '// &
+    ' iideb, iilen, iilast, jjdeb, jjlen, jjlast ', &
+      iideb, iilen, iilast, jjdeb, jjlen, jjlast
+!-
+! 1.0 get all infos on the file
+!-
+! Either the fid_out has not been initialized (0 or very large)
+! then we have to open anyway. Else we only need to open the file
+! if it has not been opened before.
+!-
+  IF ( (fid_out < 1).OR.(fid_out > nbfile_max) ) THEN
+    open_file = .TRUE.
+  ELSE IF (.NOT.ncfileopen(fid_out)) THEN
+    open_file = .TRUE.
+  ELSE
+    open_file = .FALSE.
+  ENDIF
+!-
+  IF (open_file) THEN
+    CALL flininfo (filename,tmp_iim,tmp_jjm,tmp_llm,tmp_ttm,fid_out)
+  ELSE
+!-- The user has already opened the file
+!-- and we trust that he knows the dimensions
+    tmp_iim = iim
+    tmp_jjm = jjm
+    tmp_llm = llm
+    tmp_ttm = ttm
+  ENDIF
+!-
+  IF (l_dbg) &
+    WRITE(ipslout,*) 'OUT OF flininfo :',tmp_iim,tmp_jjm,tmp_llm,tmp_ttm
+!-
+  fid = ncids(fid_out)
+!-
+! 2.0 get the sizes and names of the different coordinates
+!     and do a first set of verification.
+!-
+! 2.2 We test the axis if we have to.
+!-
+  IF (l_dbg) &
+    WRITE(ipslout,*) 'flininfo 2.2 We test if we have to test : ',do_test
+!-
+  IF (do_test) THEN
+    IF      (iim /= tmp_iim) THEN
+      CALL histerr (3,'flinopen', &
+        'file '//filename//' does not have the ', &
+        'required dimension in x direction (longitude)',' ')
+    ELSE IF (jjm /= tmp_jjm) THEN
+      CALL histerr (3,'flinopen', &
+        'file '//filename//' does not have the ', &
+        'required dimension in y direction (latitude)',' ')
+    ELSE IF ( llm /= tmp_llm .AND. llm > 0 ) THEN
+      CALL histerr (3,'flinopen', &
+        'file '//filename//' does not have the ', &
+        'required dimension in the vertical',' ')
+    ENDIF
+  ELSE
+!---
+!-- 2.3 Else the sizes of the axes are returned to the user
+!---
+    IF (l_dbg) WRITE(ipslout,*) 'flinopen 2.3 Else sizes are returned'
+!---
+    iim = tmp_iim
+    jjm = tmp_jjm
+    llm = tmp_llm
+  ENDIF
+!-
+  ttm = tmp_ttm
+!-
+! 3.0 Check if we are realy talking about the same coodinate system
+!     if not then we get the lon, lat and lev variables from the file
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'flinopen 3.0 we are realy talking'
+!-
+  IF (do_test) THEN
+!---
+    CALL flinfindcood (fid_out, 'lon', vid, nbdim)
+    iret = NF90_GET_VAR (fid, vid, x_first, start=(/ iideb, jjdeb /))
+    iret = NF90_GET_VAR (fid, vid, x_last, start=(/ iilast, jjlast /))
+!---
+    IF (l_dbg) &
+      WRITE(ipslout,*) 'from file lon first and last, modulo 360. ', &
+        x_first, x_last, MODULO(x_first,360.), MODULO(x_last,360.)
+    IF (l_dbg) &
+      WRITE(ipslout,*) 'from model lon first and last, modulo 360. ', &
+        lon(1,1),lon(iilen,jjlen), &
+        MODULO(lon(1,1),360.), MODULO(lon(iilen,jjlen),360.)
+    IF (    (ABS( MODULO(x_first,360.) &
+                 -MODULO(lon(1,1),360.)) > eps) &
+        .OR.(ABS( MODULO(x_last,360.) &
+                 -MODULO(lon(iilen ,jjlen),360.)) > eps ) ) THEN
+      CALL histerr (3,'flinopen', &
+        'file '//filename//' and the model do not', &
+        'share the same longitude coordinate', &
+        'Obtained by comparing the first and last values ')
+    ENDIF
+!---
+    CALL flinfindcood (fid_out, 'lat', vid, nbdim)
+    iret = NF90_GET_VAR (fid, vid, x_first, start=(/ iideb, jjdeb /))
+    iret = NF90_GET_VAR (fid, vid, x_last, start=(/ iilast, jjlast /))
+!---
+    IF (l_dbg) WRITE(ipslout,*) &
+      'from file lat first and last ',x_first,x_last
+    IF (l_dbg) WRITE(ipslout,*) &
+      'from model lat first and last ',lat(1,1),lat(iilen,jjlen)
+!---
+    IF (    (ABS(x_first-lat(1,1)) > eps) &
+        .OR.(ABS(x_last-lat(iilen,jjlen)) > eps) ) THEN
+      CALL histerr (3,'flinopen', &
+        'file '//filename//' and the model do not', &
+        'share the same latitude coordinate', &
+        'Obtained by comparing the first and last values ')
+    ENDIF
+!---
+    IF (llm > 0) THEN
+      CALL flinfindcood (fid_out, 'lev', vid, nbdim)
+      iret = NF90_GET_VAR (fid, vid, x_first, start=(/ 1 /))
+      iret = NF90_GET_VAR (fid, vid, x_last, start=(/ llm /))
+!-----
+      IF (l_dbg) WRITE(ipslout,*) &
+        'from file lev first and last ',x_first ,x_last
+      IF (l_dbg) WRITE(ipslout,*) &
+        'from model lev first and last ',lev(1),lev(llm)
+!-----
+      IF (    (ABS(x_first-lev(1)) > eps) &
+          .OR.(ABS(x_last-lev(llm)) > eps) ) THEN
+        CALL histerr (3,'flinopen', &
+          'file '//filename//' and the model do not', &
+          'share the same vertical coordinate', &
+          'Obtained by comparing the first and last values')
+      ENDIF
+    ENDIF
+!---
+  ELSE
+!---
+!-- 4.0 extracting the coordinates if we do not check
+!---
+    IF (l_dbg) WRITE(ipslout,*) 'flinopen 4.0 extracting the coordinates'
+!---
+    CALL flinfindcood (fid_out, 'lon', vid, nbdim)
+    IF (nbdim == 2) THEN
+      iret = NF90_GET_VAR (fid, vid, lon, &
+               start=(/ iideb, jjdeb /), count=(/ iilen, jjlen /))
+    ELSE
+      ALLOCATE(vec_tmp(iilen))
+      iret = NF90_GET_VAR (fid, vid, vec_tmp, &
+               start=(/ iideb /), count=(/ iilen /))
+      DO i=1,jjlen
+        lon(:,i) = vec_tmp(:)
+      ENDDO
+      DEALLOCATE(vec_tmp)
+    ENDIF
+!---
+    CALL flinfindcood (fid_out, 'lat', vid, nbdim)
+    IF (nbdim == 2) THEN
+      iret = NF90_GET_VAR (fid, vid, lat, &
+               start=(/ iideb, jjdeb /), count=(/ iilen, jjlen /))
+    ELSE
+      ALLOCATE(vec_tmp(jjlen))
+      iret = NF90_GET_VAR (fid, vid, vec_tmp, &
+               start=(/ jjdeb /), count=(/ jjlen /))
+      DO i=1,iilen
+        lat(i,:) = vec_tmp(:)
+      ENDDO
+      DEALLOCATE(vec_tmp)
+    ENDIF
+!---
+    IF (llm > 0) THEN
+      CALL flinfindcood (fid_out, 'lev', vid, nbdim)
+      IF (nbdim == 1) THEN
+        iret = NF90_GET_VAR (fid, vid, lev, &
+                 start=(/ 1 /), count=(/ llm /))
+      ELSE
+        CALL histerr (3,'flinopen', &
+          'Can not handle vertical coordinates that have more',&
+          'than 1 dimension',' ')
+      ENDIF
+    ENDIF
+  ENDIF
+!-
+! 5.0 Get all the details for the time if possible needed
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'flinopen 5.0 Get time'
+!-
+  IF (ttm > 0) THEN
+!---
+!-- 5.1 Find the time axis. Prefered method is the 'timestep since'
+!---
+    gdtmaf_id = -1
+    gdtt_id = -1
+    old_id = -1
+    DO iv=1,ncnbva(fid_out)
+      name=''
+      iret = NF90_INQUIRE_VARIABLE (fid, iv, name=name)
+      units=''
+      iret = NF90_GET_ATT (fid, iv, 'units', units)
+      IF (INDEX(units,'seconds since') > 0) gdtmaf_id = iv
+      IF (INDEX(units,'timesteps since') > 0) gdtt_id = iv
+      IF (INDEX(name, 'tstep') > 0 .OR. INDEX(name,'time') > 0 ) old_id = iv
+    ENDDO
+!---
+    IF (gdtt_id > 0) THEN
+      vid = gdtt_id
+    ELSE IF (gdtmaf_id > 0) THEN
+      vid = gdtmaf_id
+    ELSE IF (old_id > 0) THEN
+      vid = old_id
+    ELSE
+      CALL histerr (3, 'flinopen', 'No time axis found',' ',' ')
+    ENDIF
+!---
+    ALLOCATE(vec_tmp(ttm))
+    iret = NF90_GET_VAR (fid,vid,vec_tmp,start=(/ 1 /),count=(/ ttm /))
+    itaus(1:ttm) = NINT(vec_tmp(1:ttm))
+    DEALLOCATE(vec_tmp)
+!---
+    IF (l_dbg) WRITE(ipslout,*) 'flinopen 5.1 Times ',itaus
+!---
+!-- Getting all the details for the time axis
+!---
+!-- Find the calendar
+    calendar = ''
+    iret = NF90_GET_ATT (fid,gdtmaf_id,'calendar',calendar)
+    IF (iret == NF90_NOERR) THEN
+      CALL ioconf_calendar(calendar)
+    ENDIF
+!--
+    units = ''
+    iret = NF90_GET_ATT (fid,vid,'units',units)
+    IF (gdtt_id > 0) THEN
+      units = units(INDEX(units,'since')+6:LEN_TRIM(units))
+      READ (units,'(I4.4,5(a,I2.2))') &
+        year0, strc, month0, strc, day0, &
+               strc, hours0, strc, minutes0, strc, seci
+      sec0 = hours0*3600. + minutes0*60. + seci
+      CALL ymds2ju (year0, month0, day0, sec0, date0)
+      IF (l_dbg) &
+        WRITE(ipslout,*) 'flinopen 5.1 gdtt_id year0 ... date0 ', &
+                   year0, month0, day0, sec0, date0
+!-----
+      iret = NF90_GET_ATT (fid, gdtt_id, 'tstep_sec', dt)
+    ELSE IF (gdtmaf_id > 0) THEN
+      units = units(INDEX(units,'since')+6:LEN_TRIM(units))
+      READ (units,'(I4.4,5(a,I2.2))') &
+        year0, strc, month0, strc, day0, &
+               strc, hours0, strc, minutes0, strc, seci
+      sec0 = hours0*3600. + minutes0*60. + seci
+      CALL ymds2ju (year0, month0, day0, sec0, date0)
+!-----
+      IF (l_dbg) &
+        WRITE(ipslout,*) 'flinopen 5.1 gdtmaf_id year0 ... date0 ', &
+                   year0, month0, day0, sec0, date0
+    ELSE IF (old_id > 0) THEN
+      iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'delta_tstep_sec', dt)
+      iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'day0', r_day)
+      iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'sec0', sec)
+      iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'year0', r_year)
+      iret = NF90_GET_ATT (fid, NF90_GLOBAL, 'month0', r_month)
+!-----
+      day = INT(r_day)
+      month = INT(r_month)
+      year = INT(r_year)
+!-----
+      CALL ymds2ju (year, month, day, sec, date0)
+    ENDIF
+  ENDIF
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'flinopen 6.0 File opened', date0, dt
+!---------------------------
+END SUBROUTINE flinopen_work
+!-
+!===
+!-
+SUBROUTINE flininfo (filename, iim, jjm, llm, ttm, fid_out)
+!---------------------------------------------------------------------
+!- This subroutine allows to get some information.
+!- It is usualy done within flinopen but the user may want to call
+!- it before in order to allocate the space needed to extract the
+!- data from the file.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! ARGUMENTS
+!-
+  CHARACTER(LEN=*) :: filename
+  INTEGER :: iim, jjm, llm, ttm, fid_out
+!-
+! LOCAL
+!-
+  INTEGER :: iret, fid, ndims, nvars, nb_atts, id_unlim
+  INTEGER :: iv, lll
+  INTEGER :: xid, yid, zid, tid
+  CHARACTER(LEN=80) :: name
+  CHARACTER(LEN=30) :: axname
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  lll = LEN_TRIM(filename)
+  IF (filename(lll-2:lll) /= '.nc') THEN
+    name = filename(1:lll)//'.nc'
+  ELSE
+    name = filename(1:lll)
+  ENDIF
+!-
+  iret = NF90_OPEN (name, NF90_NOWRITE, fid)
+  IF (iret /= NF90_NOERR) THEN
+    CALL histerr(3, 'flininfo','Could not open file :',TRIM(name),' ')
+  ENDIF
+!-
+  iret = NF90_INQUIRE (fid, nDimensions=ndims, nVariables=nvars, &
+                      nAttributes=nb_atts, unlimitedDimId=id_unlim)
+!-
+  xid = -1; iim = 0;
+  yid = -1; jjm = 0;
+  zid = -1; llm = 0;
+  tid = -1; ttm = 0;
+!-
+  DO iv=1,ndims
+!---
+    iret = NF90_INQUIRE_DIMENSION (fid, iv, name=axname, len=lll)
+    CALL strlowercase (axname)
+    axname = ADJUSTL(axname)
+!---
+    IF (l_dbg) WRITE(ipslout,*) &
+      'flininfo - getting axname',iv,axname,lll
+!---
+    IF      (    (INDEX(axname,'x') == 1) &
+             .OR.(INDEX(axname,'lon') == 1) ) THEN
+      xid = iv; iim = lll;
+    ELSE IF (    (INDEX(axname,'y') == 1) &
+             .OR.(INDEX(axname,'lat') == 1) ) THEN
+      yid = iv; jjm = lll;
+    ELSE IF (    (INDEX(axname,'lev') == 1) &
+             .OR.(INDEX(axname,'plev') == 1) &
+             .OR.(INDEX(axname,'z') == 1) &
+             .OR.(INDEX(axname,'depth') == 1) ) THEN
+      zid = iv; llm = lll;
+    ELSE IF (    (INDEX(axname,'tstep') == 1) &
+             .OR.(INDEX(axname,'time') == 1) &
+             .OR.(INDEX(axname,'time_counter') == 1) ) THEN
+!---- For the time we certainly need to allow for other names
+      tid = iv; ttm = lll;
+    ELSE IF (ndims == 1) THEN
+!---- Nothing was found and ndims=1 then we have a vector of data
+      xid = 1; iim = lll;
+    ENDIF
+!---
+  ENDDO
+!-
+! Keep all this information
+!-
+  nbfiles = nbfiles+1
+!-
+  IF (nbfiles > nbfile_max) THEN
+    CALL histerr (3,'flininfo', &
+      'Too many files. Please increase nbfil_max', &
+      'in program flincom.F90.',' ')
+  ENDIF
+!-
+  ncids(nbfiles) = fid
+  ncnbd(nbfiles) = ndims
+!-
+  ncdims(nbfiles,1:4) = (/ iim, jjm, llm, ttm /)
+!-
+  ncfunli(nbfiles) = id_unlim
+  ncnba(nbfiles)   = nb_atts
+  ncnbva(nbfiles)  = nvars
+  ncfileopen(nbfiles) = .TRUE.
+!-
+  fid_out = nbfiles
+!----------------------
+END SUBROUTINE flininfo
+!-
+!===
+!-
+SUBROUTINE flinput_r1d &
+  (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid
+  REAL :: var(:)
+!-
+  INTEGER :: fid, ncvarid, ndim, iret
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  IF (l_dbg) WRITE(ipslout,*) &
+     "flinput_r1d : SIZE(var) = ",SIZE(var)
+!-
+  CALL flinput_mat &
+    (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, &
+     fid,ncvarid,ndim)
+!-
+  iret = NF90_PUT_VAR (fid, ncvarid, var, &
+           start=w_sta(1:ndim), count=w_len(1:ndim))
+!-------------------------
+END SUBROUTINE flinput_r1d
+!-
+!===
+!-
+SUBROUTINE flinput_r2d &
+  (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid
+  REAL :: var(:,:)
+!-
+  INTEGER :: fid, ncvarid, ndim, iret
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  IF (l_dbg) WRITE(ipslout,*) &
+     "flinput_r2d : SIZE(var) = ",SIZE(var)
+!-
+  CALL flinput_mat &
+    (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, &
+     fid,ncvarid,ndim)
+!-
+  iret = NF90_PUT_VAR (fid, ncvarid, var, &
+           start=w_sta(1:ndim), count=w_len(1:ndim))
+!-------------------------
+END SUBROUTINE flinput_r2d
+!-
+!===
+!-
+SUBROUTINE flinput_r3d &
+  (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid
+  REAL :: var(:,:,:)
+!-
+  INTEGER :: fid, ncvarid, ndim, iret
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  IF (l_dbg) WRITE(ipslout,*) &
+     "flinput_r3d : SIZE(var) = ",SIZE(var)
+!-
+  CALL flinput_mat &
+    (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, &
+     fid,ncvarid,ndim)
+!-
+  iret = NF90_PUT_VAR (fid, ncvarid, var, &
+           start=w_sta(1:ndim), count=w_len(1:ndim))
+!-------------------------
+END SUBROUTINE flinput_r3d
+!-
+!===
+!-
+SUBROUTINE flinput_r4d &
+  (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid,var)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid
+  REAL :: var(:,:,:,:)
+!-
+  INTEGER :: fid, ncvarid, ndim, iret
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  IF (l_dbg) WRITE(ipslout,*) &
+     "flinput_r4d : SIZE(var) = ",SIZE(var)
+!-
+  CALL flinput_mat &
+    (fid_in,varname,iim,nlonid,jjm,nlatid,llm,zdimid,ttm,tdimid, &
+     fid,ncvarid,ndim)
+!-
+  iret = NF90_PUT_VAR (fid, ncvarid, var, &
+           start=w_sta(1:ndim), count=w_len(1:ndim))
+!-------------------------
+END SUBROUTINE flinput_r4d
+!-
+!===
+!-
+SUBROUTINE flinput_mat &
+  (fid_in,varname,iim,nlonid,jjm,nlatid, &
+                  llm,zdimid,ttm,tdimid,fid,ncvarid,ndim)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid
+  INTEGER :: fid, ncvarid, ndim
+!-
+! LOCAL
+!-
+  INTEGER :: iret
+!---------------------------------------------------------------------
+  fid = ncids(fid_in)
+!-
+  w_sta(1:4) = (/      1,      1,  1,  1 /)
+  w_len(1:2) = (/    iim,    jjm /)
+  w_dim(1:2) = (/ nlonid, nlatid /)
+!-
+  IF ( (llm > 0).AND.(ttm > 0) ) THEN
+    ndim = 4
+    w_len(3:4) = (/    llm,    ttm /)
+    w_dim(3:4) = (/ zdimid, tdimid /)
+  ELSE IF (llm > 0) THEN
+    ndim = 3
+    w_dim(3) = zdimid
+    w_len(3) = llm
+  ELSE IF (ttm > 0) THEN
+    ndim = 3
+    w_dim(3) = tdimid
+    w_len(3) = ttm
+  ELSE
+    ndim = 2
+  ENDIF
+!-
+  iret = NF90_REDEF   (fid)
+  iret = NF90_DEF_VAR (fid,varname,NF90_FLOAT,w_dim(1:ndim),ncvarid)
+  iret = NF90_PUT_ATT (fid,ncvarid,'short_name',TRIM(varname))
+  iret = NF90_ENDDEF  (fid)
+!--------------------------
+END  SUBROUTINE flinput_mat
+!-
+!===
+!-
+SUBROUTINE flinput_scal &
+  (fid_in, varname, iim, nlonid, jjm, nlatid, &
+                    llm, zdimid, ttm, tdimid, var)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim, nlonid, jjm, nlatid, llm, zdimid, ttm, tdimid
+  REAL :: var
+!-
+! LOCAL
+!-
+  INTEGER :: fid, iret
+!---------------------------------------------------------------------
+  fid = ncids(fid_in)
+!-
+  iret = NF90_REDEF   (fid)
+  iret = NF90_PUT_ATT (fid, NF90_GLOBAL, varname, REAL(var,KIND=4))
+  iret = NF90_ENDDEF  (fid)
+!---------------------------
+END  SUBROUTINE flinput_scal
+!-
+!===
+!-
+SUBROUTINE flinget_r1d &
+  (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin
+  REAL :: var(:)
+!-
+  INTEGER :: jl, ji
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  IF (.NOT.ALLOCATED(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r1d : allocate buff_tmp for buff_sz = ",SIZE(var)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r1d : re-allocate buff_tmp for buff_sz = ",SIZE(var)
+    DEALLOCATE (buff_tmp)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ENDIF
+!-
+  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
+                    itau_dep,itau_fin,1,iim,1,jjm,buff_tmp)
+!-
+  jl=0
+  DO ji=1,SIZE(var,1)
+    jl=jl+1
+    var(ji) = buff_tmp(jl)
+  ENDDO
+!-------------------------
+END SUBROUTINE flinget_r1d
+!-
+!===
+!-
+SUBROUTINE flinget_r2d &
+  (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin
+  REAL :: var(:,:)
+!-
+  INTEGER :: jl, jj, ji
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  IF (.NOT.ALLOCATED(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r2d : allocate buff_tmp for buff_sz = ",SIZE(var)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r2d : re-allocate buff_tmp for buff_sz = ",SIZE(var)
+    DEALLOCATE (buff_tmp)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ENDIF
+!-
+  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
+                    itau_dep,itau_fin,1,iim,1,jjm,buff_tmp)
+!-
+  jl=0
+  DO jj=1,SIZE(var,2)
+    DO ji=1,SIZE(var,1)
+      jl=jl+1
+      var(ji,jj) = buff_tmp(jl)
+    ENDDO
+  ENDDO
+!-------------------------
+END SUBROUTINE flinget_r2d
+!-
+!===
+!-
+SUBROUTINE flinget_r2d_zoom2d &
+  (fid_in,varname,iim,jjm,llm,ttm, &
+   itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,var)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim,jjm,llm,ttm,itau_dep,itau_fin,iideb,jjdeb,iilen,jjlen
+  REAL :: var(:,:)
+!-
+  INTEGER :: jl, jj, ji
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  IF (.NOT.ALLOCATED(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r2d_zoom : allocate buff_tmp for buff_sz = ",SIZE(var)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r2d_zoom : re-allocate buff_tmp for buff_sz = ",SIZE(var)
+    DEALLOCATE (buff_tmp)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ENDIF
+!-
+  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
+                    itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,buff_tmp)
+!-
+  jl=0
+  DO jj=1,SIZE(var,2)
+    DO ji=1,SIZE(var,1)
+      jl=jl+1
+      var(ji,jj) = buff_tmp(jl)
+    ENDDO
+  ENDDO
+!--------------------------------
+END SUBROUTINE flinget_r2d_zoom2d
+!-
+!===
+!-
+SUBROUTINE flinget_r3d &
+  (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin
+  REAL :: var(:,:,:)
+!-
+  INTEGER :: jl, jk, jj, ji
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  IF (.NOT.ALLOCATED(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r3d : allocate buff_tmp for buff_sz = ",SIZE(var)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r3d : re-allocate buff_tmp for buff_sz = ",SIZE(var)
+    DEALLOCATE (buff_tmp)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ENDIF
+!-
+  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
+                    itau_dep,itau_fin,1,iim,1,jjm,buff_tmp)
+!-
+  jl=0
+  DO jk=1,SIZE(var,3)
+    DO jj=1,SIZE(var,2)
+      DO ji=1,SIZE(var,1)
+        jl=jl+1
+        var(ji,jj,jk) = buff_tmp(jl)
+      ENDDO
+    ENDDO
+  ENDDO
+!-------------------------
+END SUBROUTINE flinget_r3d
+!-
+!===
+!-
+SUBROUTINE flinget_r3d_zoom2d &
+  (fid_in,varname,iim,jjm,llm,ttm, &
+   itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,var)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim,jjm,llm,ttm,itau_dep,itau_fin,iideb,jjdeb,iilen,jjlen
+  REAL :: var(:,:,:)
+!-
+  INTEGER :: jl, jk, jj, ji
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  IF (.NOT.ALLOCATED(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r3d_zoom : allocate buff_tmp for buff_sz = ",SIZE(var)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r3d_zoom : re-allocate buff_tmp for buff_sz = ",SIZE(var)
+    DEALLOCATE (buff_tmp)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ENDIF
+!-
+  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
+                    itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,buff_tmp)
+!-
+  jl=0
+  DO jk=1,SIZE(var,3)
+    DO jj=1,SIZE(var,2)
+      DO ji=1,SIZE(var,1)
+        jl=jl+1
+        var(ji,jj,jk) = buff_tmp(jl)
+      ENDDO
+    ENDDO
+  ENDDO
+!--------------------------------
+END SUBROUTINE flinget_r3d_zoom2d
+!-
+!===
+!-
+SUBROUTINE flinget_r4d &
+  (fid_in,varname,iim,jjm,llm,ttm,itau_dep,itau_fin,var)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin
+  REAL :: var(:,:,:,:)
+!-
+  INTEGER :: jl, jk, jj, ji, jm
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  IF (.NOT.ALLOCATED(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r4d : allocate buff_tmp for buff_sz = ",SIZE(var)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r4d : re-allocate buff_tmp for buff_sz = ",SIZE(var)
+    DEALLOCATE (buff_tmp)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ENDIF
+!-
+  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
+                    itau_dep,itau_fin,1,iim,1,jjm,buff_tmp)
+!-
+  jl=0
+  DO jm=1,SIZE(var,4)
+    DO jk=1,SIZE(var,3)
+      DO jj=1,SIZE(var,2)
+        DO ji=1,SIZE(var,1)
+          jl=jl+1
+          var(ji,jj,jk,jm) = buff_tmp(jl)
+        ENDDO
+      ENDDO
+    ENDDO
+  ENDDO
+!-------------------------
+END SUBROUTINE flinget_r4d
+!-
+!===
+!-
+SUBROUTINE flinget_r4d_zoom2d &
+  (fid_in,varname,iim,jjm,llm,ttm, &
+   itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,var)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim,jjm,llm,ttm,itau_dep,itau_fin,iideb,jjdeb,iilen,jjlen
+  REAL :: var(:,:,:,:)
+!-
+  INTEGER :: jl, jk, jj, ji, jm
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: buff_tmp
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  IF (.NOT.ALLOCATED(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r4d_zoom : allocate buff_tmp for buff_sz = ",SIZE(var)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ELSE IF (SIZE(var) > SIZE(buff_tmp)) THEN
+    IF (l_dbg) WRITE(ipslout,*) &
+      "flinget_r4d_zoom : re-allocate buff_tmp for buff_sz = ",SIZE(var)
+    DEALLOCATE (buff_tmp)
+    ALLOCATE (buff_tmp(SIZE(var)))
+  ENDIF
+!-
+  CALL flinget_mat (fid_in,varname,iim,jjm,llm,ttm, &
+                    itau_dep,itau_fin,iideb,iilen,jjdeb,jjlen,buff_tmp)
+!-
+  jl=0
+  DO jm=1,SIZE(var,4)
+    DO jk=1,SIZE(var,3)
+      DO jj=1,SIZE(var,2)
+        DO ji=1,SIZE(var,1)
+          jl=jl+1
+          var(ji,jj,jk,jm) = buff_tmp(jl)
+        ENDDO
+      ENDDO
+    ENDDO
+  ENDDO
+!--------------------------------
+END SUBROUTINE flinget_r4d_zoom2d
+!-
+!===
+!-
+SUBROUTINE flinget_mat &
+  (fid_in, varname, iim, jjm, llm, ttm, itau_dep, &
+   itau_fin, iideb, iilen, jjdeb, jjlen, var)
+!---------------------------------------------------------------------
+!- This subroutine will read the variable named varname from
+!- the file previously opened by flinopen and identified by fid
+!-
+!- It is checked that the dimensions of the variable to be read
+!- correspond to what the user requested when he specified
+!- iim, jjm and llm. The only exception which is allowed is
+!- for compressed data where the horizontal grid is not expected
+!- to be iim x jjm.
+!-
+!- If variable is of size zero a global attribute is read.
+!- This global attribute will be of type real
+!-
+!- INPUT
+!-
+!- fid      : File ID returned by flinopen
+!- varname  : Name of the variable to be read from the file
+!- iim      : | These three variables give the size of the variables
+!- jjm      : | to be read. It will be verified that the variables
+!- llm      : | fits in there.
+!- ttm      : |
+!- itau_dep : Time step at which we will start to read
+!- itau_fin : Time step until which we are going to read
+!-            For the moment this is done on indexes
+!-            but it should be in the physical space.
+!-            If there is no time-axis in the file then use a
+!-            itau_fin < itau_dep, this will tell flinget not to
+!-            expect a time-axis in the file.
+!- iideb    : index i for zoom
+!- iilen    : length of zoom
+!- jjdeb    : index j for zoom
+!- jjlen    : length of zoom
+!-
+!- OUTPUT
+!-
+!- var      : array that will contain the data
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! ARGUMENTS
+!-
+  INTEGER, INTENT(IN) :: fid_in
+  CHARACTER(LEN=*), INTENT(IN) :: varname
+  INTEGER, INTENT(IN) :: iim, jjm, llm, ttm
+  INTEGER, INTENT(IN) :: itau_dep, itau_fin, iideb, iilen, jjdeb, jjlen
+  REAL, INTENT(OUT) :: var(:)
+!-
+! LOCAL
+!-
+  INTEGER :: iret, fid
+  INTEGER :: vid, cvid, clen
+  CHARACTER(LEN=70) :: str1
+  CHARACTER(LEN=250) :: att_n, tmp_n
+  CHARACTER(LEN=5) :: axs_l
+  INTEGER :: tmp_i
+  REAL,SAVE :: mis_v=0.
+  REAL :: tmp_r
+  INTEGER :: ndims, x_typ, nb_atts
+  INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: dimids
+  INTEGER :: i, nvars, i2d, cnd
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: var_tmp
+  INTEGER :: itau_len
+  LOGICAL :: uncompress = .FALSE.
+  INTEGER :: il, ip, i2p, it
+  !-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+  !-
+  fid = ncids(fid_in)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) &
+    'flinget_mat : fid_in, fid, varname :', fid_in, fid, TRIM(varname)
+    WRITE(ipslout,*) &
+    'flinget_mat : iim, jjm, llm, ttm, itau_dep, itau_fin :', &
+    iim, jjm, llm, ttm, itau_dep, itau_fin
+    WRITE(ipslout,*) &
+    'flinget_mat : iideb, iilen, jjdeb, jjlen :', &
+    iideb, iilen, jjdeb, jjlen
+  ENDIF
+!-
+  uncompress = .FALSE.
+!-
+! 1.0 We get first all the details on this variable from the file
+!-
+  nvars = ncnbva(fid_in)
+!-
+  vid = -1
+  iret = NF90_INQ_VARID (fid, varname, vid)
+!-
+  IF (vid < 0 .OR. iret /= NF90_NOERR) THEN
+    CALL histerr (3,'flinget', &
+      'Variable '//TRIM(varname)//' not found in file',' ',' ')
+  ENDIF
+!-
+  iret = NF90_INQUIRE_VARIABLE (fid, vid, &
+           ndims=ndims, dimids=dimids, nAtts=nb_atts)
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) &
+    'flinget_mat : fid, vid :', fid, vid
+    WRITE(ipslout,*) &
+    'flinget_mat : ndims, dimids(1:ndims), nb_atts :', &
+    ndims, dimids(1:ndims), nb_atts
+  ENDIF
+!-
+  w_dim(:) = 0
+  DO i=1,ndims
+    iret  = NF90_INQUIRE_DIMENSION (fid, dimids(i), len=w_dim(i))
+  ENDDO
+  IF (l_dbg) WRITE(ipslout,*) &
+    'flinget_mat : w_dim :', w_dim(1:ndims)
+!-
+  mis_v = 0.0; axs_l = ' ';
+!-
+  IF (nb_atts > 0) THEN
+     IF (l_dbg) THEN
+      WRITE(ipslout,*) 'flinget_mat : attributes for variable :'
+    ENDIF
+  ENDIF
+  DO i=1,nb_atts
+    iret = NF90_INQ_ATTNAME (fid, vid, i, att_n)
+    iret = NF90_INQUIRE_ATTRIBUTE (fid, vid, att_n, xtype=x_typ)
+    CALL strlowercase (att_n)
+    IF      (    (x_typ == NF90_INT).OR.(x_typ == NF90_SHORT) &
+             .OR.(x_typ == NF90_BYTE) ) THEN
+      iret = NF90_GET_ATT (fid, vid, att_n, tmp_i)
+        IF (l_dbg) THEN
+        WRITE(ipslout,*) '   ',TRIM(att_n),' : ',tmp_i
+      ENDIF
+    ELSE IF ( (x_typ == NF90_FLOAT).OR.(x_typ == NF90_DOUBLE) ) THEN
+      iret = NF90_GET_ATT (fid, vid, att_n, tmp_r)
+        IF (l_dbg) THEN
+        WRITE(ipslout,*) '   ',TRIM(att_n),' : ',tmp_r
+      ENDIF
+      IF (index(att_n,'missing_value') > 0) THEN
+        mis_v = tmp_r
+      ENDIF
+    ELSE
+      tmp_n = ''
+      iret = NF90_GET_ATT (fid, vid, att_n, tmp_n)
+        IF (l_dbg) THEN
+        WRITE(ipslout,*) '   ',TRIM(att_n),' : ',TRIM(tmp_n)
+      ENDIF
+      IF (index(att_n,'axis') > 0) THEN
+        axs_l = tmp_n
+      ENDIF
+    ENDIF
+  ENDDO
+!?
+!!!!!!!!!! We will need a verification on the type of the variable
+!?
+!-
+! 2.0 The dimensions are analysed to determine what is to be read
+!-
+! 2.1 the longitudes
+!-
+  IF ( w_dim(1) /= iim .OR. w_dim(2) /= jjm) THEN
+!---
+!-- There is a possibility that we have to deal with a compressed axis !
+!---
+    iret = NF90_INQUIRE_DIMENSION (fid, dimids(1), &
+             name=tmp_n, len=clen)
+    iret = NF90_INQ_VARID (fid, tmp_n, cvid)
+!---
+    IF (l_dbg) WRITE(ipslout,*) &
+      'Dimname, iret , NF90_NOERR : ',TRIM(tmp_n),iret,NF90_NOERR
+!---
+!-- If we have an axis which has the same name
+!-- as the dimension we can see if it is compressed
+!---
+!-- TODO TODO for zoom2d
+!---
+    IF (iret == NF90_NOERR) THEN
+      iret = NF90_GET_ATT (fid, cvid, 'compress', str1)
+!-----
+      IF (iret == NF90_NOERR) THEN
+        iret = NF90_INQUIRE_VARIABLE (fid,cvid,xtype=x_typ,ndims=cnd)
+!-------
+        IF ( cnd /= 1 .AND. x_typ /= NF90_INT) THEN
+          CALL histerr (3,'flinget', &
+            'Variable '//TRIM(tmp_n)//' can not be a compressed axis', &
+            'Either it has too many dimensions'// &
+            ' or it is not of type integer', ' ')
+        ELSE
+!---------
+!-------- Let us see if we already have that index table
+!---------
+          IF (    (cind_len /= clen).OR.(cind_vid /= cvid) &
+              .OR.(cind_fid /= fid) ) THEN
+            IF (ALLOCATED(cindex))   DEALLOCATE(cindex)
+            ALLOCATE(cindex(clen))
+            cind_len = clen
+            cind_vid = cvid
+            cind_fid = fid
+            iret = NF90_GET_VAR (fid, cvid, cindex)
+          ENDIF
+!---------
+!-------- In any case we need to set the slab of data to be read
+!---------
+          uncompress = .TRUE.
+          w_sta(1) = 1
+          w_len(1) = clen
+          i2d = 1
+        ENDIF
+      ELSE
+        str1 = 'The horizontal dimensions of '//varname
+        CALL histerr (3,'flinget',str1, &
+          'is not compressed and does not'// &
+          ' correspond to the requested size',' ')
+      ENDIF
+    ELSE
+      IF (w_dim(1) /= iim) THEN
+        str1 = 'The longitude dimension of '//varname
+        CALL histerr (3,'flinget',str1, &
+          'in the file is not equal to the dimension', &
+          'that should be read')
+      ENDIF
+      IF (w_dim(2) /= jjm) THEN
+        str1 = 'The latitude dimension of '//varname
+        CALL histerr (3,'flinget',str1, &
+          'in the file is not equal to the dimension', &
+          'that should be read')
+      ENDIF
+    ENDIF
+  ELSE
+    w_sta(1:2) = (/ iideb, jjdeb /)
+    w_len(1:2) = (/ iilen, jjlen /)
+    i2d = 2
+  ENDIF
+!-
+! 2.3 Now the difficult part, the 3rd dimension which can be
+! time or levels.
+!-
+! Priority is given to the time axis if only three axes are present.
+!-
+  IF (ndims > i2d) THEN
+!---
+!-- 2.3.1 We have a vertical axis
+!---
+    IF (llm == 1 .AND. ndims == i2d+2 .OR. llm == w_dim(i2d+1)) THEN
+!-----
+      IF (w_dim(i2d+1) /= llm) THEN
+        CALL histerr (3,'flinget', &
+          'The vertical dimension of '//varname, &
+          'in the file is not equal to the dimension', &
+          'that should be read')
+      ELSE
+        w_sta(i2d+1) = 1
+        IF (llm > 0) THEN
+          w_len(i2d+1) = llm
+        ELSE
+          w_len(i2d+1) = w_sta(i2d+1)
+        ENDIF
+      ENDIF
+!-----
+      IF ((itau_fin-itau_dep) >= 0) THEN
+        IF      (ndims /= i2d+2) THEN
+          CALL histerr (3,'flinget', &
+            'You attempt to read a time slab', &
+            'but there is no time axis on this variable', varname)
+        ELSE IF ((itau_fin - itau_dep) <= w_dim(i2d+2)) THEN
+          w_sta(i2d+2) = itau_dep
+          w_len(i2d+2) = itau_fin-itau_dep+1
+        ELSE
+          CALL histerr (3,'flinget', &
+            'The time step you try to read is not', &
+            'in the file (1)', varname)
+        ENDIF
+      ELSE IF (ndims == i2d+2 .AND. w_dim(i2d+2) > 1) THEN
+        CALL histerr (3,'flinget', &
+          'There is a time axis in the file but no', &
+          'time step give in the call', varname)
+      ELSE
+        w_sta(i2d+2) = 1
+        w_len(i2d+2) = 1
+      ENDIF
+    ELSE
+!-----
+!---- 2.3.2 We do not have any vertical axis
+!-----
+      IF (ndims == i2d+2) THEN
+        CALL histerr (3,'flinget', &
+          'The file contains 4 dimensions', &
+          'but only 3 are requestes for variable ', varname)
+      ENDIF
+      IF ((itau_fin-itau_dep) >= 0) THEN
+        IF (ndims == i2d+1) THEN
+          IF ((itau_fin-itau_dep) < w_dim(i2d+1) ) THEN
+            w_sta(i2d+1) = itau_dep
+            w_len(i2d+1) = itau_fin-itau_dep+1
+          ELSE
+            CALL histerr (3,'flinget', &
+              'The time step you try to read is not', &
+              'in the file (2)', varname)
+          ENDIF
+        ELSE
+          CALL histerr (3,'flinget', &
+            'From your input you sould have 3 dimensions', &
+            'in the file but there are 4', varname)
+        ENDIF
+      ELSE
+        IF (ndims == i2d+1 .AND. w_dim(i2d+1) > 1) THEN
+          CALL histerr (3,'flinget', &
+            'There is a time axis in the file but no', &
+            'time step given in the call', varname)
+        ELSE
+          w_sta(i2d+1) = 1
+          w_len(i2d+1) = 1
+        ENDIF
+      ENDIF
+    ENDIF
+  ELSE
+!---
+!-- 2.3.3 We do not have any vertical axis
+!---
+    w_sta(i2d+1:i2d+2) = (/ 0, 0 /)
+    w_len(i2d+1:i2d+2) = (/ 0, 0 /)
+  ENDIF
+!-
+! 3.0 Reading the data
+!-
+  IF (l_dbg) WRITE(ipslout,*) &
+    'flinget_mat 3.0 : ', uncompress, w_sta, w_len
+!---
+  var(:) = mis_v
+  IF (uncompress) THEN
+!---
+    IF (ALLOCATED(var_tmp)) THEN
+      IF (SIZE(var_tmp) < PRODUCT(w_len(:),mask=(w_len>1))) THEN
+         DEALLOCATE(var_tmp)
+         ALLOCATE(var_tmp(PRODUCT(w_len(:),mask=(w_len>1))))
+      ENDIF
+    ELSE
+      ALLOCATE(var_tmp(PRODUCT(w_len(:),mask=(w_len>1))))
+    ENDIF
+!---
+    iret = NF90_GET_VAR (fid, vid, var_tmp, &
+             start=w_sta(:), count=w_len(:))
+!---
+    itau_len=itau_fin-itau_dep+1
+    IF (l_dbg) WRITE(ipslout,*) 'flinget_mat 3.0 : clen, itau_len ',clen,itau_len
+    var(:) = mis_v
+    IF (itau_len > 0) THEN
+       DO it=1,itau_len
+          DO il=1,clen
+             ip = il + (it-1)*clen
+             i2p = cindex(il)+(it-1)*iim*jjm
+             var(i2p) = var_tmp(ip)
+          ENDDO
+       ENDDO
+    ELSE
+       var(cindex(:)) = var_tmp(:)
+    ENDIF
+!---
+  ELSE
+    iret = NF90_GET_VAR (fid, vid, var, &
+             start=w_sta(:), count=w_len(:))
+  ENDIF
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'flinget_mat 3.1 : ',NF90_STRERROR (iret)
+!--------------------------
+END  SUBROUTINE flinget_mat
+!-
+!===
+!-
+SUBROUTINE flinget_scal &
+  (fid_in, varname, iim, jjm, llm, ttm, itau_dep, itau_fin, var)
+!---------------------------------------------------------------------
+!- This subroutine will read the variable named varname from
+!- the file previously opened by flinopen and identified by fid
+!-
+!- If variable is of size zero a global attribute is read. This
+!- global attribute will be of type real
+!-
+!- INPUT
+!-
+!- fid      : File ID returned by flinopen
+!- varname  : Name of the variable to be read from the file
+!- iim      : | These three variables give the size of the variables
+!- jjm      : | to be read. It will be verified that the variables
+!- llm      : | fits in there.
+!- ttm      : |
+!- itau_dep : Time step at which we will start to read
+!- itau_fin : Time step until which we are going to read
+!-           For the moment this is done on indeces but it should be
+!-           in the physical space
+!-           If there is no time-axis in the file then use a
+!-           itau_fin < itau_dep, this will tell flinget not to
+!-           expect a time-axis in the file.
+!-
+!- OUTPUT
+!-
+!- var      : scalar that will contain the data
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! ARGUMENTS
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim, jjm, llm, ttm, itau_dep, itau_fin
+  REAL :: var
+!-
+! LOCAL
+!-
+  INTEGER :: iret, fid, vid
+  INTEGER :: attlen, attnum
+  INTEGER :: ndims, nb_atts
+  INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: dimids
+  LOGICAL :: var_exists
+!-
+  LOGICAL :: l_dbg
+  INTEGER :: lll
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  IF (l_dbg) THEN
+    WRITE (ipslout,*) 'flinget_scal in file with id ',fid_in
+  ENDIF
+!-
+  fid = ncids(fid_in)
+  iret = NF90_INQUIRE_ATTRIBUTE(fid, NF90_GLOBAL, varname, len=attlen, attnum=attnum)
+!-
+! 1.0 Reading a global attribute
+!-
+  IF ( iret == nf90_noerr ) THEN
+     !
+     ! This seems to be a Global attribute
+     !
+     iret = NF90_GET_ATT (fid, NF90_GLOBAL, varname, var)
+  ELSE
+     !
+     ! If there was an error on the test for a global attribute it
+     ! is perhaps a scalar variable.
+     !
+     vid = -1
+     iret = NF90_INQ_VARID (fid, varname, vid)
+     !
+     IF ( (vid >= 0).AND.(iret == NF90_NOERR) ) THEN
+        iret = NF90_INQUIRE_VARIABLE (fid, vid, &
+             ndims=ndims, dimids=dimids, nAtts=nb_atts)
+        IF (ndims == 1) THEN
+           iret = NF90_INQUIRE_DIMENSION (fid, dimids(1), len=lll)
+        ENDIF
+
+        IF ( ((ndims == 0) .OR. ((ndims == 1).AND.(lll == 1))) .AND. (nb_atts >= 0) ) THEN
+           iret = NF90_GET_VAR(fid, vid, var)
+        ELSE
+           CALL histerr (3,'flinget_scal', &
+                'The variable has coordinates and thus is probably not a scalar.', &
+                'Check your netCDF file.', " ")
+        ENDIF
+     ENDIF
+     IF (l_dbg) THEN
+        WRITE(ipslout,*) "Reading a Scalar value for varibale ", varname," It has value ", var
+     ENDIF
+  ENDIF
+!-
+!---------------------------
+END  SUBROUTINE flinget_scal
+!-
+!===
+!-
+SUBROUTINE flinfindcood (fid_in, axtype, vid, ndim)
+!---------------------------------------------------------------------
+!- This subroutine explores the file in order to find
+!- the coordinate according to a number of rules
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! ARGUMENTS
+!-
+  INTEGER :: fid_in, vid, ndim
+  CHARACTER(LEN=3) :: axtype
+!-
+! LOCAL
+!-
+  INTEGER :: iv, iret, dimnb
+  CHARACTER(LEN=40) :: dimname, dimuni1, dimuni2, dimuni3
+  CHARACTER(LEN=80) :: str1
+  LOGICAL :: found_rule = .FALSE.
+!---------------------------------------------------------------------
+  vid = -1
+!-
+! Make sure all strings are invalid
+!-
+  dimname = '?-?'
+  dimuni1 = '?-?'
+  dimuni2 = '?-?'
+  dimuni3 = '?-?'
+!-
+! First rule : we look for the correct units
+! lon : east
+! lat : north
+! We make an exact check as it would be too easy to mistake
+! some units by just comparing the substrings.
+!-
+  SELECTCASE(axtype)
+  CASE ('lon')
+    dimuni1 = 'degree_e'
+    dimuni2 = 'degrees_e'
+    found_rule = .TRUE.
+  CASE('lat')
+    dimuni1 = 'degree_n'
+    dimuni2 = 'degrees_n'
+    found_rule = .TRUE.
+  CASE('lev')
+    dimuni1 = 'm'
+    dimuni2 = 'km'
+    dimuni3 = 'hpa'
+    found_rule = .TRUE.
+  CASE DEFAULT
+    found_rule = .FALSE.
+  END SELECT
+!-
+  IF (found_rule) THEN
+    iv = 0
+    DO WHILE ( (vid < 0).AND.(iv < ncnbva(fid_in)) )
+      iv = iv+1
+      str1 = ''
+      iret = NF90_GET_ATT (ncids(fid_in), iv, 'units', str1)
+      IF (iret == NF90_NOERR) THEN
+        CALL strlowercase (str1)
+        IF (    (INDEX(str1, TRIM(dimuni1)) == 1) &
+            .OR.(INDEX(str1, TRIM(dimuni2)) == 1) &
+            .OR.(INDEX(str1, TRIM(dimuni3)) == 1) ) THEN
+          vid = iv
+          iret = NF90_INQUIRE_VARIABLE (ncids(fid_in), iv, ndims=ndim)
+        ENDIF
+      ENDIF
+    ENDDO
+  ENDIF
+!-
+! Second rule : we find specific names :
+! lon : nav_lon
+! lat : nav_lat
+! Here we can check if we find the substring as the
+! names are more specific.
+!-
+  SELECTCASE(axtype)
+  CASE ('lon')
+    dimname = 'nav_lon lon longitude'
+    found_rule = .TRUE.
+  CASE('lat')
+    dimname = 'nav_lat lat latitude'
+    found_rule = .TRUE.
+  CASE('lev')
+    dimname = 'plev level depth deptht'
+    found_rule = .TRUE.
+  CASE DEFAULT
+    found_rule = .FALSE.
+  END SELECT
+!-
+  IF (found_rule) THEN
+    iv = 0
+    DO WHILE ( (vid < 0).AND.(iv < ncnbva(fid_in)) )
+      iv = iv+1
+      str1=''
+      iret = NF90_INQUIRE_VARIABLE (ncids(fid_in), iv, &
+                                    name=str1, ndims=ndim)
+      IF (INDEX(dimname,TRIM(str1)) >= 1) THEN
+        vid = iv
+      ENDIF
+    ENDDO
+  ENDIF
+!-
+! Third rule : we find a variable with the same name as the dimension
+! lon = 1
+! lat = 2
+! lev = 3
+!-
+  IF (vid < 0) THEN
+    SELECTCASE(axtype)
+    CASE ('lon')
+      dimnb = 1
+      found_rule = .TRUE.
+    CASE('lat')
+      dimnb = 2
+      found_rule = .TRUE.
+    CASE('lev')
+      dimnb = 3
+      found_rule = .TRUE.
+    CASE DEFAULT
+      found_rule = .FALSE.
+    END SELECT
+!---
+    IF (found_rule) THEN
+      iret = NF90_INQUIRE_DIMENSION (ncids(fid_in), dimnb, name=dimname)
+      iv = 0
+      DO WHILE ( (vid < 0).AND.(iv < ncnbva(fid_in)) )
+        iv = iv+1
+        str1=''
+        iret = NF90_INQUIRE_VARIABLE (ncids(fid_in), iv, &
+                                      name=str1, ndims=ndim)
+        IF (INDEX(dimname,TRIM(str1)) == 1) THEN
+          vid = iv
+        ENDIF
+      ENDDO
+    ENDIF
+  ENDIF
+!-
+! Stop the program if no coordinate was found
+!-
+  IF (vid < 0) THEN
+    CALL histerr (3,'flinfindcood', &
+           'No coordinate axis was found in the file', &
+           'The data in this file can not be used', axtype)
+  ENDIF
+!--------------------------
+END SUBROUTINE flinfindcood
+!-
+!===
+!-
+SUBROUTINE flinclo (fid_in)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+!-
+  INTEGER :: iret
+!---------------------------------------------------------------------
+  iret = NF90_CLOSE (ncids(fid_in))
+  ncfileopen(fid_in) = .FALSE.
+!---------------------
+END SUBROUTINE flinclo
+!-
+!===
+!-
+SUBROUTINE flinquery_var(fid_in, varname, exists)
+!---------------------------------------------------------------------
+!- Queries the existance of a variable in the file.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid_in
+  CHARACTER(LEN=*) varname
+  LOGICAL :: exists
+!-
+  INTEGER :: iret, fid, vid
+!---------------------------------------------------------------------
+  fid = ncids(fid_in)
+  vid = -1
+  iret = NF90_INQ_VARID (fid, varname, vid)
+!-
+  exists = ( (vid >= 0).AND.(iret == NF90_NOERR) )
+!---------------------------
+END SUBROUTINE flinquery_var
+!-
+!===
+!-
+SUBROUTINE flininspect (fid_in)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! fid : File id to inspect
+!-
+  INTEGER :: fid_in
+!-
+!- LOCAL
+!-
+  INTEGER :: iim, jjm, llm, ttm, fid_out
+  INTEGER :: iret, fid, ndims, nvars, nb_atts, id_unlim
+  INTEGER :: iv, in, lll
+  INTEGER :: xid, yid, zid, tid
+  INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: idimid
+  CHARACTER(LEN=80) :: name
+  CHARACTER(LEN=30) :: axname
+!---------------------------------------------------------------------
+  fid = ncids(fid_in)
+!-
+  iret = NF90_INQUIRE (fid, nDimensions=ndims, nVariables=nvars, &
+                       nAttributes=nb_atts, unlimitedDimId=id_unlim)
+!-
+  WRITE (*,*) 'IOIPSL ID                   : ',fid_in
+  WRITE (*,*) 'NetCDF ID                   : ',fid
+  WRITE (*,*) 'Number of dimensions        : ',ndims
+  WRITE (*,*) 'Number of variables         : ',nvars
+  WRITE (*,*) 'Number of global attributes : ',nb_atts
+  WRITE (*,*) 'ID unlimited                : ',id_unlim
+!-
+  xid = -1; iim = 0;
+  yid = -1; jjm = 0;
+  zid = -1; llm = 0;
+  tid = -1; ttm = 0;
+!-
+  DO iv=1,ndims
+!---
+    iret = NF90_INQUIRE_DIMENSION (fid, iv, name=axname, len=lll)
+    CALL strlowercase (axname)
+    axname = ADJUSTL(axname)
+!---
+    WRITE (*,*) 'Dimension number : ',iv
+    WRITE (*,*) 'Dimension name   : ',TRIM(axname)
+!---
+    IF      (    (INDEX(axname,'x') == 1) &
+             .OR.(INDEX(axname,'lon') == 1)) THEN
+      xid = iv; iim = lll;
+      WRITE (*,*) 'Dimension X size   : ',iim
+    ELSE IF (    (INDEX(axname,'y') == 1) &
+             .OR.(INDEX(axname,'lat') == 1)) THEN
+      yid = iv; jjm = lll;
+      WRITE (*,*) 'Dimension Y size   : ',jjm
+    ELSE IF (    (INDEX(axname,'lev') == 1) &
+             .OR.(INDEX(axname,'plev') == 1) &
+             .OR.(INDEX(axname,'z') == 1) &
+             .OR.(INDEX(axname,'depth') == 1)) THEN
+      zid = iv; llm = lll;
+      WRITE (*,*) 'Dimension Z size   : ',llm
+    ELSE IF (    (INDEX(axname,'tstep') == 1) &
+             .OR.(INDEX(axname,'time') == 1) &
+             .OR.(INDEX(axname,'time_counter') == 1)) THEN
+!---- For the time we certainly need to allow for other names
+      tid = iv; ttm = lll;
+    ELSE IF (ndims == 1) THEN
+!---- Nothing was found and ndims=1 then we have a vector of data
+      xid = 1; iim = lll;
+    ENDIF
+!---
+  ENDDO
+!-
+! Keep all this information
+!-
+  nbfiles = nbfiles+1
+!-
+  IF (nbfiles > nbfile_max) THEN
+    CALL histerr(3,'flininspect', &
+      'Too many files. Please increase nbfil_max', &
+      'in program flincom.F90.',' ')
+  ENDIF
+!-
+  ncids(nbfiles) = fid
+  ncnbd(nbfiles) = ndims
+!-
+  ncdims(nbfiles,1:4) = (/ iim, jjm, llm, ttm /)
+!-
+  ncfunli(nbfiles) = id_unlim
+  ncnba(nbfiles)   = nb_atts
+  ncnbva(nbfiles)  = nvars
+  ncfileopen(nbfiles) = .TRUE.
+!-
+  fid_out = nbfiles
+!-
+  DO in=1,nvars
+    iret = NF90_INQUIRE_VARIABLE (fid, in, &
+             name=name, ndims=ndims, dimids=idimid, nAtts=nb_atts)
+    WRITE (*,*) 'Variable number  ------------ > ', in
+    WRITE (*,*) 'Variable name        : ', TRIM(name)
+    WRITE (*,*) 'Number of dimensions : ', ndims
+    WRITE (*,*) 'Dimensions ID''s     : ', idimid(1:ndims)
+    WRITE (*,*) 'Number of attributes : ', nb_atts
+  ENDDO
+!-------------------------
+END SUBROUTINE flininspect
+!-
+!===
+!-
+END MODULE flincom
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/fliocom.f90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/fliocom.f90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/fliocom.f90	(revision 17)
@@ -0,0 +1,5173 @@
+MODULE fliocom
+!-
+!$Id: fliocom.f90 1896 2012-10-17 15:28:07Z jgipsl $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+USE netcdf
+!-
+USE defprec
+USE calendar,  ONLY : lock_calendar,ioget_calendar, &
+ &                    ioconf_calendar,ju2ymds,ymds2ju
+USE errioipsl, ONLY : ipslerr,ipsldbg, ipslout
+USE stringop,  ONLY : strlowercase,str_xfw
+!-
+IMPLICIT NONE
+!-
+PRIVATE
+!-
+PUBLIC :: &
+ &  fliocrfd, fliopstc, fliodefv, flioputv, flioputa, &
+ &  flioopfd, flioinqf, flioinqn, fliogstc, &
+ &  flioinqv, fliogetv, flioinqa, fliogeta, &
+ &  fliorenv, fliorena, fliodela, fliocpya, &
+ &  flioqstc, fliosync, flioclo,  fliodmpf, &
+ &  flio_dom_set,    flio_dom_unset, &
+ &  flio_dom_defset, flio_dom_defunset, flio_dom_definq, &
+ &  flio_dom_file,   flio_dom_att
+!-
+!!--------------------------------------------------------------------
+!! The following PUBLIC parameters (with "flio_" prefix)
+!! are used in the module "fliocom" :
+!!
+!! flio_max_files     : maximum number of simultaneously opened files
+!! flio_max_dims      : maximum number of dimensions for a file
+!! flio_max_var_dims  : maximum number of dimensions for a variable
+!!
+!! FLIO_DOM_NONE    : "named constant" for no_domain identifier
+!! FLIO_DOM_DEFAULT : "named constant" for default_domain identifier
+!!
+!! flio_i  : standard INTEGER external type
+!! flio_r  : standard REAL external type
+!! flio_c  : CHARACTER external type
+!! flio_i1 : INTEGER*1 external type
+!! flio_i2 : INTEGER*2 external type
+!! flio_i4 : INTEGER*4 external type
+!! flio_r4 : REAL*4 external type
+!! flio_r8 : REAL*8 external type
+!!--------------------------------------------------------------------
+  INTEGER,PARAMETER,PUBLIC :: &
+ &  flio_max_files=100, flio_max_dims=15, flio_max_var_dims=5
+  INTEGER,PARAMETER,PUBLIC :: &
+ &  flio_i = -1,        flio_r = -2,        flio_c =nf90_char, &
+ &  flio_i1=nf90_int1,  flio_i2=nf90_int2,  flio_i4=nf90_int4, &
+ &  flio_r4=nf90_real4, flio_r8=nf90_real8
+!-
+  INTEGER,PARAMETER,PUBLIC :: FLIO_DOM_NONE    =-1
+  INTEGER,PARAMETER,PUBLIC :: FLIO_DOM_DEFAULT = 0
+!-
+!!--------------------------------------------------------------------
+!! The "fliocrfd" routine creates a model file
+!! which contains the dimensions needed.
+!!
+!! SUBROUTINE fliocrfd (f_n,f_d_n,f_d_l,f_i,id_dom,mode,c_f_n)
+!!
+!! INPUT
+!!
+!! (C) f_n      : Name of the file to be created
+!! (C) f_d_n(:) : Array of (max nb_fd_mx) names of the dimensions
+!! (I) f_d_l(:) : Array of (max nb_fd_mx) lengths of the dimensions
+!!                For an unlimited dimension, enter a length of -1.
+!!                Actually, only one unlimited dimension is supported.
+!!
+!! OUTPUT
+!!
+!! (I) f_i  : Model file identifier
+!!
+!! Optional INPUT arguments
+!!
+!! (I) id_dom : Identifier of a domain defined by calling
+!!              "flio_dom_set". If this argument is present,
+!!              and not equal to FLIO_DOM_NONE, it will be
+!!              appended to the file name and
+!!              the attributes describing the related DOMAIN
+!!              will be put in the created file.
+!!              This argument can be equal to FLIO_DOM_DEFAULT
+!!              (see "flio_dom_defset").
+!! (C) mode   : String of (case insensitive) blank-separated words
+!!              defining the mode used to create the file.
+!!              Supported keywords : REPLACE, 32, 64
+!!              If this argument is present with the keyword "REPLACE",
+!!              the file will be created in mode "CLOBBER",
+!!              else the file will be created in mode "NOCLOBBER".
+!!              "32/64" defines the offset mode.
+!!              The default offset mode is 64 bits.
+!!              Keywords "NETCDF4" and "CLASSIC" are reserved
+!!              for future use.
+!!
+!! Optional OUTPUT arguments
+!!
+!! (C) c_f_n : Name of the created file.
+!!             This name can be different of "f_n",
+!!             if a suffix is added to the original name
+!!             (".nc" or "DOMAIN_identifier.nc").
+!!             The length of "c_f_n" must be sufficient
+!!             to receive the created file name.
+!!
+!!- NOTES
+!!
+!! The names used to identify the spatio-temporal dimensions
+!! (dimension associated to a coordinate variable)
+!! are the following :
+!!
+!!  Axis       Names
+!!
+!!    x        'x[...]'  'lon[...]'
+!!    y        'y[...]'  'lat[...]'
+!!    z        'z[...]'  'lev[...]'  'plev[...]'   'depth[...]'
+!!    t        't'       'time'      'tstep[...]'  'time_counter[...]'
+!!
+!! Please, apply these rules so that coordinates are
+!! correctly defined.
+!!--------------------------------------------------------------------
+!-
+!!--------------------------------------------------------------------
+!! The "fliopstc" routine defines the major coordinates system
+!! (spatio-temporal axis) of the model file (created by fliocrfd).
+!!
+!! SUBROUTINE fliopstc &
+!! & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, &
+!! &      t_axis,t_init,t_step,t_calendar)
+!!
+!! INPUT
+!!
+!! (I) f_i  : Model file identifier
+!!
+!! Optional INPUT arguments
+!!
+!! (R) x_axis(:)      : longitudinal grids
+!! (R) x_axis_2d(:,:) : longitudinal grids
+!! (R) y_axis(:)      : latitudinal grids
+!! (R) y_axis_2d(:,:) : latitudinal grids
+!! (R) z_axis(:)      : vertical grid
+!! (I) t_axis(:)      : timesteps on the time axis
+!! (R) t_init         : date in julian days at the beginning
+!! (R) t_step         : timestep in seconds between t_axis steps
+!! (C) t_calendar     : calendar
+!!
+!! [x/y]_axis and [x/y]_axis_2d are mutually exclusive.
+!!
+!!- NOTES
+!!
+!! The variables corresponding to the spatio-temporal coordinates
+!! are created according to the following characteristics :
+!!
+!!- Longitude axis     x_axis / x_axis_2d
+!!   Variable name     'lon'  / 'nav_lon'
+!!   Attributes        Values
+!!   'axis'            "X"
+!!   'standard_name'   "longitude"
+!!   'units'           "degrees_east"
+!!   'valid_min'       MINVAL(x_axis/x_axis_2d)
+!!   'valid_max'       MAXVAL(x_axis/x_axis_2d)
+!!
+!!- Latitude axis      y_axis / y_axis_2d
+!!   Variable name     'lat'  / 'nav_lat'
+!!   Attributes        Values
+!!   'axis'            "Y"
+!!   'standard_name'   "latitude"
+!!   'units'           "degrees_north"
+!!   'valid_min'       MINVAL(y_axis/y_axis_2d)
+!!   'valid_max'       MAXVAL(y_axis/y_axis_2d)
+!!
+!!- Vertical axis      z_axis
+!!   Variable name     'lev'
+!!   Attributes        Values
+!!   'axis'            "Z"
+!!   'standard_name'   "model_level_number"
+!!   'units'           "sigma_level"
+!!   'long_name'       "Sigma Levels"
+!!   'valid_min'       MINVAL(z_axis)
+!!   'valid_max'       MAXVAL(z_axis)
+!!
+!!- Time axis          t_axis
+!!   Variable name     'time'
+!!   Attributes        Values
+!!   'axis'            "T"
+!!   'standard_name'   "time"
+!!   'long_name'       "time steps"
+!!  ['calendar'        user/default valued]
+!!   'units'           calculated
+!!
+!! If you are not satisfied, it is possible
+!! to rename variables ("fliorenv")
+!! or overload the values of attributes ("flioputa").
+!! Be careful : the new values you use must allow to read variables
+!! as coordinates.
+!!
+!! The dimensions associated to the coordinates variables
+!! are searched according to their names (see "fliocrfd")
+!!--------------------------------------------------------------------
+!-
+INTERFACE fliodefv
+!!--------------------------------------------------------------------
+!! The "fliodefv" routines define a variable in a model file.
+!!
+!! SUBROUTINE fliodefv &
+!! & (f_i,v_n,[v_d],v_t, &
+!! &  axis,standard_name,long_name,units, &
+!! &  valid_min,valid_max,fillvalue)
+!!
+!! INPUT
+!!
+!! (I)  f_i  : Model file identifier
+!! (C)  v_n  : Name of variable to be defined
+!! (I) [v_d] :
+!!             "not present"
+!!                --> scalar variable
+!!             "array of one or several integers containing
+!!              the identifiers of the dimensions of the variable
+!!              (in the order specified to "fliocrfd"
+!!               or obtained from "flioopfd")"
+!!                --> multidimensioned variable
+!!
+!! Optional INPUT arguments
+!!
+!! (I) v_t : External type of the variable
+!!           "present"     --> see flio_..
+!!           "not present" --> type of standard real
+!! (C) axis,standard_name,long_name,units : Attributes
+!!     (axis should be used only for coordinates)
+!! (R) valid_min,valid_max,fillvalue : Attributes
+!!--------------------------------------------------------------------
+  MODULE PROCEDURE &
+ &  fliodv_r0d,fliodv_rnd
+END INTERFACE
+!-
+INTERFACE flioputv
+!!--------------------------------------------------------------------
+!! The "flioputv" routines put a variable (defined by fliodefv)
+!! in a model file.
+!!
+!! SUBROUTINE flioputv (f_i,v_n,v_v,start,count)
+!!
+!! INPUT
+!!
+!! (I) f_i    : model file identifier
+!! (C) v_n    : name of the variable to be written
+!! (R/I) v_v  : scalar or array (up to flio_max_var_dims dimensions)
+!!              containing the (standard) real/integer values
+!!
+!! Optional INPUT arguments
+!!
+!! (I) start(:) : array of integers specifying the index
+!!                where the first data value will be written
+!! (I) count(:) : array of integers specifying the number of
+!!                indices that will be written along each dimension
+!!                (not present if v_v is a scalar)
+!!--------------------------------------------------------------------
+!?INTEGERS of KIND 1 are not supported on all computers
+  MODULE PROCEDURE &
+ & fliopv_i40,fliopv_i41,fliopv_i42,fliopv_i43,fliopv_i44,fliopv_i45, &
+ & fliopv_i20,fliopv_i21,fliopv_i22,fliopv_i23,fliopv_i24,fliopv_i25, &
+!& fliopv_i10,fliopv_i11,fliopv_i12,fliopv_i13,fliopv_i14,fliopv_i15, &
+ & fliopv_r40,fliopv_r41,fliopv_r42,fliopv_r43,fliopv_r44,fliopv_r45, &
+ & fliopv_r80,fliopv_r81,fliopv_r82,fliopv_r83,fliopv_r84,fliopv_r85
+END INTERFACE
+!-
+INTERFACE flioputa
+!!--------------------------------------------------------------------
+!! The "flioputa" routines put a value for an attribute
+!! in a model file.
+!! If this attribute does not exist, it will be created.
+!!
+!! SUBROUTINE flioputa (f_i,v_n,a_n,a_v)
+!!
+!! INPUT
+!!
+!! (I) f_i  : Model file identifier
+!! (C) v_n  : Name of variable to which the attribute is assigned.
+!!            If this name is "?", the attribute will be global.
+!! (C) a_n  : Name of the attribute to be defined.
+!! ( ) a_v  : scalar or array of real (kind 4 or 8) or integer values,
+!!            or character string
+!!--------------------------------------------------------------------
+  MODULE PROCEDURE &
+ &  fliopa_r4_0d,fliopa_r4_1d,fliopa_r8_0d,fliopa_r8_1d, &
+ &  fliopa_i4_0d,fliopa_i4_1d,fliopa_tx_0d
+END INTERFACE
+!-
+!!--------------------------------------------------------------------
+!! The "flioopfd" routine opens an existing model file,
+!! and returns the dimensions used in the file and a file identifier.
+!! This information can be used to allocate the space needed
+!! to extract the data from the file.
+!!
+!! SUBROUTINE flioopfd (f_n,f_i,mode,nb_dim,nb_var,nb_gat)
+!!
+!! INPUT
+!!
+!! (C) f_n     : Name of the file to be opened
+!!
+!! OUTPUT
+!!
+!! (I) f_i      : Model file identifier
+!!
+!! Optional INPUT arguments
+!!
+!! (C) mode : Access mode to the file.
+!!            If this argument is present with the value "WRITE",
+!!            the file will be accessed in mode "READ-WRITE",
+!!            else the file will be accessed in mode "READ-ONLY".
+!!
+!! Optional OUTPUT arguments
+!!
+!! (I) nb_dim : number of dimensions
+!! (I) nb_var : number of variables
+!! (I) nb_gat : number of global attributes
+!!--------------------------------------------------------------------
+!-
+!!--------------------------------------------------------------------
+!! The "flioinqf" routine returns information
+!! about an opened model file given its identifier.
+!!
+!! SUBROUTINE flioinqf &
+!! & (f_i,nb_dim,nb_var,nb_gat,id_uld,id_dim,ln_dim)
+!!
+!! INPUT
+!!
+!! (I) f_i  : Model file identifier
+!!
+!! Optional OUTPUT arguments
+!!
+!! (I) nb_dim    : number of dimensions
+!! (I) nb_var    : number of variables
+!! (I) nb_gat    : number of global attributes
+!! (I) id_uld    : identifier of the unlimited dimension (0 if none)
+!! (I) id_dim(:) : identifiers of the dimensions
+!! (I) ln_dim(:) : lengths of the dimensions
+!!--------------------------------------------------------------------
+!-
+!!--------------------------------------------------------------------
+!! The "flioinqn" routine returns the names
+!! of the entities encountered in an opened model file.
+!!
+!! SUBROUTINE flioinqn &
+!! & (f_i,cn_dim,cn_var,cn_gat,cn_uld, &
+!! &  id_start,id_count,iv_start,iv_count,ia_start,ia_count)
+!!
+!! INPUT
+!!
+!! (I) f_i  : Model file identifier
+!!
+!! Optional OUTPUT arguments
+!!
+!! (C) cn_dim(:) : names of dimensions
+!! (C) cn_var(:) : names of variables
+!! (C) cn_gat(:) : names of global attributes
+!! (C) cn_uld    : names of the unlimited dimension
+!!
+!! Optional INPUT arguments
+!!
+!! (I) id_start,id_count,iv_start,iv_count,ia_start,ia_count
+!!
+!!  The prefix ( id       / iv      / ia              ) specifies
+!!         the (dimensions/variables/global attributes) entities
+!!
+!!  The suffix "start" specify the index from which
+!!  the first name will be retrieved (1 by default)
+!!
+!!  The suffix "count" specifies the number of names to be retrieved
+!!  (all by default)
+!!
+!!  If a requested entity is not available, a "?" will be returned.
+!!--------------------------------------------------------------------
+!-
+!!--------------------------------------------------------------------
+!! The "fliogstc" routine extracts the major coordinates system
+!! (spatio-temporal axis) of the model file (opened by flioopfd).
+!!
+!! SUBROUTINE fliogstc &
+!! & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, &
+!! &      t_axis,t_init,t_step,t_calendar, &
+!! &      x_start,x_count,y_start,y_count, &
+!! &      z_start,z_count,t_start,t_count)
+!!
+!! INPUT
+!!
+!! (I) f_i  : Model file identifier
+!!
+!! Optional OUTPUT arguments
+!!
+!! (R) x_axis(:)      : longitudinal grids
+!! (R) x_axis_2d(:,:) : longitudinal grids
+!! (R) y_axis(:)      : latitudinal grids
+!! (R) y_axis_2d(:,:) : latitudinal grids
+!! (R) z_axis(:)      : vertical grid
+!! (I) t_axis(:)      : timesteps on the time axis
+!! (R) t_init         : date in julian days at the beginning
+!! (R) t_step         : timestep in seconds between t_axis steps
+!! (C) t_calendar     : calendar attribute
+!!                      (the value is "not found" if the attribute
+!!                       is not present in the model file)
+!!
+!! [x/y]_axis and [x/y]_axis_2d are mutually exclusive.
+!!
+!! Optional INPUT arguments
+!!
+!! (I) x_start,x_count,y_start,y_count,z_start,z_count,t_start,t_count
+!!
+!!  The prefix (x/y/z/t) specifies the concerned direction.
+!!
+!!  The suffix "start" specify the index from which
+!!  the first data value will be read (1 by default)
+!!
+!!  The suffix "count" specifies the number of values to be read
+!!  (all by default)
+!!--------------------------------------------------------------------
+!-
+!!--------------------------------------------------------------------
+!! The "flioinqv" routine returns information about a model
+!! variable given its name.
+!! This information can be used to allocate the space needed
+!! to extract the variable from the file.
+!!
+!! SUBROUTINE flioinqv &
+!! & (f_i,v_n,l_ex,nb_dims,len_dims,id_dims, &
+!! &  nb_atts,cn_atts,ia_start,ia_count)
+!!
+!! INPUT
+!!
+!! (I) f_i  : Model file identifier
+!! (C) v_n  : Name of the variable
+!!
+!! OUTPUT
+!!
+!! (L) l_ex  : Existence of the variable
+!!
+!! Optional OUTPUT arguments
+!!
+!! (I) v_t          : External type of the variable (see flio_..)
+!! (I) nb_dims      : number of dimensions of the variable
+!! (I) len_dims(:)  : list of dimension lengths of the variable
+!! (I) id_dims(:)   : list of dimension identifiers of the variable
+!! (I) nb_atts      : number of attributes of the variable
+!! (C) cn_atts(:)   : names of the attributes
+!!
+!! Optional INPUT arguments
+!!
+!! (I) ia_start : index of the first attribute whose the name
+!!                will be retrieved (1 by default)
+!! (I) ia_count : number of names to be retrieved (all by default)
+!!
+!!  If a requested entity is not available, a "?" will be returned.
+!!--------------------------------------------------------------------
+!-
+INTERFACE fliogetv
+!!--------------------------------------------------------------------
+!! The "fliogetv" routines get a variable from a model file.
+!!
+!! SUBROUTINE fliogetv (f_i,v_n,v_v,start,count)
+!!
+!! INPUT
+!!
+!! (I) f_i  : Model file identifier
+!! (C) v_n  : Name of the variable to be read
+!!
+!! OUTPUT
+!!
+!! (R/I) v_v  : scalar or array (up to flio_max_var_dims dimensions)
+!!              that will contain the (standard) real/integer values
+!!
+!! Optional INPUT arguments
+!!
+!! (I) start(:) : array of integers specifying the index
+!!                from which the first data value will be read
+!! (I) count(:) : array of integers specifying the number of
+!!                indices that will be read along each dimension
+!!                (not present if v_v is a scalar)
+!!--------------------------------------------------------------------
+!?INTEGERS of KIND 1 are not supported on all computers
+  MODULE PROCEDURE &
+ & fliogv_i40,fliogv_i41,fliogv_i42,fliogv_i43,fliogv_i44,fliogv_i45, &
+ & fliogv_i20,fliogv_i21,fliogv_i22,fliogv_i23,fliogv_i24,fliogv_i25, &
+!& fliogv_i10,fliogv_i11,fliogv_i12,fliogv_i13,fliogv_i14,fliogv_i15, &
+ & fliogv_r40,fliogv_r41,fliogv_r42,fliogv_r43,fliogv_r44,fliogv_r45, &
+ & fliogv_r80,fliogv_r81,fliogv_r82,fliogv_r83,fliogv_r84,fliogv_r85
+END INTERFACE
+!-
+!!--------------------------------------------------------------------
+!! The "flioinqa" routine returns information about an
+!! attribute of a variable given their names, in a model file.
+!! Information about a variable includes its existence,
+!! and the number of values currently stored in the attribute.
+!! For a string-valued attribute, this is the number of
+!! characters in the string.
+!! This information can be used to allocate the space needed
+!! to extract the attribute from the file.
+!!
+!! SUBROUTINE flioinqa (f_i,v_n,a_n,l_ex,a_t,a_l)
+!!
+!! INPUT
+!!
+!! (I) f_i : Model file identifier
+!! (C) v_n : Name of variable to which the attribute is assigned.
+!!           This name is "?" for a global attribute.
+!! (C) a_n : Name of the concerned attribute.
+!!
+!! OUTPUT
+!!
+!! (L) l_ex : existence of the variable
+!!
+!! Optional OUTPUT arguments
+!!
+!! (I) a_t : external type of the attribute
+!! (I) a_l : number of values of the attribute
+!!--------------------------------------------------------------------
+!-
+INTERFACE fliogeta
+!!--------------------------------------------------------------------
+!! The "fliogeta" routines get a value for an attribute
+!! in a model file.
+!!
+!! SUBROUTINE fliogeta (f_i,v_n,a_n,a_v)
+!!
+!! INPUT
+!!
+!! (I) f_i  : Model file identifier
+!! (C) v_n  : Name of variable to which the attribute is assigned.
+!!            This name is "?" for a global attribute.
+!! (C) a_n  : Name of the attribute to be retrieved.
+!! ( ) a_v  : scalar or array of real (kind 4 or 8) or integer values,
+!!            or character string
+!!--------------------------------------------------------------------
+  MODULE PROCEDURE &
+ &  flioga_r4_0d,flioga_r4_1d,flioga_r8_0d,flioga_r8_1d, &
+ &  flioga_i4_0d,flioga_i4_1d,flioga_tx_0d
+END INTERFACE
+!-
+!!--------------------------------------------------------------------
+!! The "fliorenv" routine renames a variable, in a model file.
+!!
+!! SUBROUTINE fliorenv (f_i,v_o_n,v_n_n)
+!!
+!! INPUT
+!!
+!! (I) f_i    : Model file identifier
+!! (C) v_o_n  : Old name of the variable
+!! (C) v_n_n  : New name of the variable
+!!--------------------------------------------------------------------
+!-
+!!--------------------------------------------------------------------
+!! The "fliorena" routine renames an attribute
+!! of a variable, in a model file.
+!!
+!! SUBROUTINE fliorena (f_i,v_n,a_o_n,a_n_n)
+!!
+!! INPUT
+!!
+!! (I) f_i    : Model file identifier
+!! (C) v_n    : Name of variable to which the attribute is assigned.
+!!              This name is "?" for a global attribute.
+!! (C) a_o_n  : Old name of the concerned attribute.
+!! (C) a_n_n  : New name of the concerned attribute.
+!!--------------------------------------------------------------------
+!-
+!!--------------------------------------------------------------------
+!! The "fliodela" routine deletes an attribute in a model file.
+!!
+!! SUBROUTINE fliodela (f_i,v_n,a_n)
+!!
+!! INPUT
+!!
+!! (I) f_i  : Model file identifier
+!! (C) v_n  : Name of variable to which the attribute is assigned.
+!!            This name is "?" for a global attribute.
+!! (C) a_n  : Name of the concerned attribute.
+!!--------------------------------------------------------------------
+!-
+!!--------------------------------------------------------------------
+!! The "fliocpya" routine copies an attribute
+!! from one open model file to another.
+!! It can also be used to copy an attribute from
+!! one variable to another within the same model file.
+!!
+!! SUBROUTINE fliocpya (f_i_i,v_n_i,a_n,f_i_o,v_n_o)
+!!
+!! INPUT
+!!
+!! (I) f_i_i : Identifier of the input  model file
+!! (C) v_n_i : Name of the input variable
+!!             This name is "?" for a global attribute.
+!! (C) a_n   : Name of the concerned attribute.
+!! (I) f_i_o : Identifier of the output model file
+!!             It can be the same as the input identifier.
+!! (C) v_n_o : Name of the output variable
+!!             This name is "?" for a global attribute.
+!!--------------------------------------------------------------------
+!-
+!!--------------------------------------------------------------------
+!! The "flioqstc" routine search for a spatio-temporal coordinate
+!! in a model file and returns its name.
+!!
+!! SUBROUTINE flioqstc (f_i,c_type,l_ex,c_name)
+!!
+!! INPUT
+!!
+!! (I) f_i     : Model file identifier
+!! (C) c_type  : Type of the coordinate ("x"/"y"/"z"/"t")
+!!
+!! OUTPUT
+!!
+!! (L) l_ex    : existence of the coordinate
+!! (C) c_name  : name of the coordinate
+!!
+!!- NOTES
+!!
+!! The following rules are used for searching variables
+!! which are spatio-temporal coordinates (x/y/z/t).
+!!
+!!-- Rule 1 : we look for a variable with one dimension
+!!--          and which has the same name as its dimension
+!!
+!!-- Rule 2 : we look for a correct "axis" attribute
+!!
+!!  Axis       Axis attribute             Number of dimensions
+!!             (case insensitive)
+!!
+!!    x         X                         1/2
+!!    y         Y                         1/2
+!!    z         Z                         1
+!!    t         T                         1
+!!
+!!-- Rule 3 : we look for a correct "standard_name" attribute
+!!
+!!  Axis       Axis attribute          Number of dimensions
+!!             (case insensitive)
+!!
+!!    x         longitude              1/2
+!!    y         latitude               1/2
+!!    z         model_level_number     1
+!!    t         time                   1
+!!
+!!-- Rule 4 : we look for a specific name
+!!
+!!  Axis   Names
+!!
+!!    x    'nav_lon' 'lon'    'longitude'
+!!    y    'nav_lat' 'lat'    'latitude'
+!!    z    'depth'   'deptht' 'height'      'level'
+!!         'lev'     'plev'   'sigma_level' 'layer'
+!!    t    'time'    'tstep'  'timesteps'
+!!
+!!--------------------------------------------------------------------
+!-
+!!--------------------------------------------------------------------
+!! The "fliosync" routine synchronise one or all opened model files,
+!! to minimize data loss in case of abnormal termination.
+!!
+!! SUBROUTINE fliosync (f_i)
+!!
+!! Optional INPUT arguments
+!!
+!! (I) f_i  : Model file identifier
+!!            If this argument is not present,
+!!            all the opened model files are synchronised.
+!---------------------------------------------------------------------
+!-
+!!--------------------------------------------------------------------
+!! The "flioclo" routine closes one or all opened model files
+!! and frees the space needed to keep information about the files
+!!
+!! SUBROUTINE flioclo (f_i)
+!!
+!! Optional INPUT arguments
+!!
+!! (I) f_i  : Model file identifier
+!!            If this argument is not present,
+!!            all the opened model files are closed.
+!!--------------------------------------------------------------------
+!-
+!!--------------------------------------------------------------------
+!! The "fliodmpf" routine dumps a model file
+!! and prints the result on the standard output.
+!!
+!! SUBROUTINE fliodmpf (f_n)
+!!
+!! INPUT
+!!
+!! (C) f_n  : Name of the model file to be dumped
+!!--------------------------------------------------------------------
+!-
+!!--------------------------------------------------------------------
+!! This "flio_dom_set" sets up the domain activity of IOIPSL.
+!! It stores all the domain information and allows it to be stored
+!! in the model file and change the file names.
+!!
+!! This routine must be called by the user before opening
+!! the model file.
+!!
+!! SUBROUTINE flio_dom_set &
+!!  & (dtnb,dnb,did,dsg,dsl,dpf,dpl,dhs,dhe,cdnm,id_dom)
+!!
+!! INPUT
+!!
+!! (I) dtnb   : total number of domains
+!! (I) dnb    : domain number
+!! (I) did(:) : distributed dimensions identifiers
+!!              (up to 5 dimensions are supported)
+!! (I) dsg(:) : total number of points for each dimension
+!! (I) dsl(:) : local number of points for each dimension
+!! (I) dpf(:) : position of first local point for each dimension
+!! (I) dpl(:) : position of last local point for each dimension
+!! (I) dhs(:) : start halo size for each dimension
+!! (I) dhe(:) : end halo size for each dimension
+!! (C) cdnm   : Model domain definition name.
+!!              The names actually supported are :
+!!              "BOX", "APPLE", "ORANGE".
+!!              These names are case insensitive.
+!!
+!! OUTPUT argument
+!!
+!! (I) id_dom : Model domain identifier
+!!
+!!--------------------------------------------------------------------
+!!
+!!--------------------------------------------------------------------
+!! The "flio_dom_unset" routine unsets one or all set domains
+!! and frees the space needed to keep information about the domains
+!!
+!! This routine should be called by the user to free useless domains.
+!!
+!! SUBROUTINE flio_dom_unset (id_dom)
+!!
+!! Optional INPUT arguments
+!!
+!! (I) id_dom : Model domain identifier
+!!      >=1 & <= dom_max_nb : the domain is closed
+!!      not present         : all the set model domains are unset
+!!--------------------------------------------------------------------
+!!
+!!--------------------------------------------------------------------
+!! The "flio_dom_defset" sets
+!! the default domain identifier.
+!!
+!! SUBROUTINE flio_dom_defset (id_dom)
+!!
+!! INPUT argument
+!!
+!! (I) id_dom : Model default domain identifier
+!!     ( >=1 & <= dom_max_nb )
+!!     This identifier will be able to be taken by calling
+!!     "flio_dom_definq" and used to create model files
+!!     with the corresponding domain definitions
+!!--------------------------------------------------------------------
+!!
+!!--------------------------------------------------------------------
+!! The "flio_dom_defunset" routine unsets
+!! the default domain identifier.
+!!
+!! SUBROUTINE flio_dom_defunset ()
+!!
+!!--------------------------------------------------------------------
+!!
+!!--------------------------------------------------------------------
+!! The "flio_dom_definq" routine inquires about
+!! the default domain identifier.
+!! You should call this procedure to safeguard the current
+!! default domain identifier if you wish to use locally
+!! another default domain, in order to restore it.
+!!
+!! SUBROUTINE flio_dom_definq (id_dom)
+!!
+!! OUTPUT argument
+!!
+!! (I) id_dom : Model default domain identifier
+!!     IF no default domain identifier has been set,
+!!     the returned value is "FLIO_DOM_NONE".
+!!--------------------------------------------------------------------
+!-
+!---------------------------------------------------------------------
+! This is the data we keep concerning each file we open
+!---------------------------------------------------------------------
+!- For each file
+!- (I) nw_id(f_i)   : index to access at this file
+!- (I) nw_nd(f_i)   : number of dimensions
+!- (I) nw_nv(f_i)   : number of variables
+!- (I) nw_na(f_i)   : number of global attributes
+!- (I) nw_un(f_i)   : ID of the first unlimited dimension
+!- (L) lw_hm(f_i)   : for mode handling (.TRUE. define, .FALSE. data)
+!- (I) nw_di(:,f_i) : dimension IDs in the file "f_i"
+!- (I) nw_dl(:,f_i) : dimension lengths in the file "f_i"
+!- (I) nw_ai(:,f_i) : dimension Ids for the axis in the file "f_i"
+!---------------------------------------------------------------------
+  INTEGER,PARAMETER :: &
+ &  nb_fi_mx=flio_max_files, &
+ &  nb_fd_mx=flio_max_dims, &
+ &  nb_vd_mx=flio_max_var_dims
+  INTEGER,PARAMETER :: nb_ax_mx=4
+!-
+  INTEGER,PARAMETER :: k_lon=1, k_lat=2, k_lev=3, k_tim=4
+!-
+  INTEGER,DIMENSION(nb_fi_mx),SAVE :: &
+ &  nw_id=-1,nw_nd,nw_nv,nw_na,nw_un
+  LOGICAL,DIMENSION(nb_fi_mx),SAVE :: lw_hm
+  INTEGER,DIMENSION(nb_fd_mx,nb_fi_mx),SAVE :: nw_di=-1,nw_dl=-1
+  INTEGER,DIMENSION(nb_ax_mx,nb_fi_mx),SAVE :: nw_ai=-1
+!-
+! Maximum number of simultaneously defined domains
+  INTEGER,PARAMETER :: dom_max_nb=64
+!-
+! Maximum number of distributed dimensions for each domain
+  INTEGER,PARAMETER :: dom_max_dims=5
+!-
+! Default domain identifier
+  INTEGER,SAVE :: id_def_dom=FLIO_DOM_NONE
+!-
+! Supported domain definition names
+  INTEGER,PARAMETER :: n_dns=3, l_dns=7
+  CHARACTER(LEN=l_dns),DIMENSION(n_dns),SAVE :: &
+ &  c_dns=(/ "box    ","apple  ","orange "/)
+!-
+! DOMAINS related variables
+  INTEGER,DIMENSION(1:dom_max_nb),SAVE :: &
+ &  d_d_n=-1, d_n_t=0, d_n_c=0
+  INTEGER,DIMENSION(1:dom_max_dims,1:dom_max_nb),SAVE :: &
+ &  d_d_i, d_s_g, d_s_l, d_p_f, d_p_l, d_h_s, d_h_e
+  CHARACTER(LEN=l_dns),DIMENSION(1:dom_max_nb),SAVE :: c_d_t
+!-
+!===
+CONTAINS
+!===
+!-
+!---------------------------------------------------------------------
+!- Public procedures
+!---------------------------------------------------------------------
+!-
+!===
+SUBROUTINE fliocrfd (f_n,f_d_n,f_d_l,f_i,id_dom,mode,c_f_n)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(IN) :: f_n
+  CHARACTER(LEN=*),DIMENSION(:),INTENT(IN) :: f_d_n
+  INTEGER,DIMENSION(:),INTENT(IN) :: f_d_l
+  INTEGER,INTENT(OUT) :: f_i
+  INTEGER,OPTIONAL,INTENT(IN) :: id_dom
+  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode
+  CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: c_f_n
+!-
+  INTEGER :: i_rc,f_e,idid,ii,m_c,n_u
+  CHARACTER(LEN=NF90_MAX_NAME) :: f_nw
+  INTEGER,PARAMETER :: l_string=80,l_word=10
+  CHARACTER(LEN=l_string) :: c_string
+  CHARACTER(LEN=l_word)   :: c_word
+  LOGICAL :: l_ok
+  INTEGER,PARAMETER :: k_replace=1
+  INTEGER,PARAMETER :: k_32=1,k_64=2
+!- !? : Code to be activated for NETCDF4
+!?  INTEGER,PARAMETER :: k_netcdf4=1,k_classic=1
+  INTEGER,PARAMETER :: n_opt=4
+  INTEGER,DIMENSION(n_opt) :: i_opt
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->fliocrfd - file name : ",TRIM(f_n)
+  ENDIF
+!-
+! Search for a free local identifier
+  f_i = flio_rid()
+  IF (f_i < 0) THEN
+    CALL ipslerr (3,'fliocrfd', &
+ &   'Too many files.','Please increase nb_fi_mx', &
+ &   'in module fliocom.f90.')
+  ENDIF
+!-
+! Update the name of the file
+  f_nw = f_n
+  CALL flio_dom_file (f_nw,id_dom)
+!-
+! Check the dimensions
+  IF (SIZE(f_d_l) /= SIZE(f_d_n)) THEN
+    CALL ipslerr (3,'fliocrfd', &
+ &   'The number of names is not equal to the number of lengths', &
+ &   'for the dimensions of the file',TRIM(f_nw))
+  ENDIF
+  IF (SIZE(f_d_l) > nb_fd_mx) THEN
+    CALL ipslerr (3,'fliocrfd', &
+ &   'Too many dimensions','to create the file',TRIM(f_nw))
+  ENDIF
+!-
+! Check the mode
+!-
+  i_opt(:)=-1
+!-
+  IF (PRESENT(mode)) THEN
+!---
+    IF (LEN_TRIM(mode) > l_string) THEN
+      CALL ipslerr (3,'fliocrfd', &
+ &     '"mode" argument','too long','to be treated')
+    ENDIF
+    c_string = mode(:)
+    CALL strlowercase (c_string)
+!---
+    DO
+      CALL str_xfw  (c_string,c_word,l_ok)
+      IF (l_ok) THEN
+!- !? : Code to be activated for NETCDF4
+        SELECT CASE (TRIM(c_word))
+        CASE('replace')
+          IF (i_opt(1) > 0) THEN
+            CALL ipslerr (3,'fliocrfd', &
+ &           'Replace option','already','defined')
+          ELSE
+            i_opt(1) = k_replace
+          ENDIF
+!?      CASE('netcdf4')
+!?        IF (i_opt(2) > 0) THEN
+!?          CALL ipslerr (3,'fliocrfd', &
+!? &         'Netcdf4 format','already','defined')
+!?        ELSE
+!?          i_opt(2) = k_netcdf4
+!?        ENDIF
+        CASE('32')
+          IF (i_opt(3) > 0) THEN
+            CALL ipslerr (3,'fliocrfd', &
+ &           'Offset format','already','defined')
+          ELSE
+            i_opt(3) = k_32
+          ENDIF
+        CASE('64')
+          IF (i_opt(3) > 0) THEN
+            CALL ipslerr (3,'fliocrfd', &
+ &           'Offset format','already','defined')
+          ELSE
+            i_opt(3) = k_64
+          ENDIF
+!?      CASE('CLASSIC')
+!?        IF (i_opt(4) > 0) THEN
+!?          CALL ipslerr (3,'fliocrfd', &
+!? &         'Netcdf4 classic format','already','defined')
+!?        ELSE
+!?          i_opt(4) = k_classic
+!?        ENDIF
+        CASE DEFAULT
+          CALL ipslerr (3,'fliocrfd', &
+ &         'Option '//TRIM(c_word),'not','supported')
+        END SELECT
+      ELSE
+        EXIT
+      ENDIF
+    ENDDO
+  ENDIF
+!-
+  IF (i_opt(1) == k_replace) THEN
+    m_c = NF90_CLOBBER
+  ELSE
+    m_c = NF90_NOCLOBBER
+  ENDIF
+!-
+!- Code to be replaced by the following for NETCDF4
+!?  IF (i_opt(2) == k_netcdf4) THEN
+!?    m_c = IOR(m_c,NF90_NETCDF4)
+!?    IF (i_opt(3) > 0) THEN
+!?      CALL ipslerr (3,'fliocrfd', &
+!? &     'Netcdf4 format','and offset option','are not compatible')
+!?    ELSE IF (i_opt(4) == k_classic) THEN
+!?      m_c = IOR(m_c,NF90_CLASSIC_MODEL)
+!?    ENDIF
+!?   LSE IF (i_opt(4) > 0) THEN
+!?    CALL ipslerr (3,'fliocrfd', &
+!? &   'Classic option','is reserved','for the Netcdf4 format')
+!?  ELSE
+    IF (i_opt(3) /= k_32) THEN
+      m_c = IOR(m_c,NF90_64BIT_OFFSET)
+    ENDIF
+!?  ENDIF
+!-
+! Create file (and enter the definition mode)
+  i_rc = NF90_CREATE(f_nw,m_c,f_e)
+  lw_hm(f_i) = .TRUE.
+  IF (i_rc /= NF90_NOERR) THEN
+    CALL ipslerr (3,'fliocrfd', &
+ &   'Could not create file :',TRIM(f_nw), &
+ &   TRIM(NF90_STRERROR(i_rc))//' (Netcdf)')
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) '  fliocrfd, external model file-id : ',f_e
+  ENDIF
+!-
+! Create dimensions
+  n_u = 0
+  DO ii=1,SIZE(f_d_l)
+    IF (f_d_l(ii) == -1) THEN
+      IF (n_u == 0) THEN
+        i_rc = NF90_DEF_DIM(f_e,TRIM(f_d_n(ii)),NF90_UNLIMITED,idid)
+        n_u = n_u+1
+      ELSE
+        CALL ipslerr (3,'fliocrfd', &
+ &       'Can not handle more than one unlimited dimension', &
+ &       'for file :',TRIM(f_nw))
+      ENDIF
+    ELSE IF (f_d_l(ii) > 0) THEN
+      i_rc = NF90_DEF_DIM(f_e,TRIM(f_d_n(ii)),f_d_l(ii),idid)
+    ENDIF
+    IF ( ((f_d_l(ii) == -1).OR.(f_d_l(ii) > 0)) &
+ &      .AND.(i_rc /= NF90_NOERR) ) THEN
+      CALL ipslerr (3,'fliocrfd', &
+ &     'One dimension can not be defined', &
+ &     'for the file :',TRIM(f_nw))
+    ENDIF
+  ENDDO
+!-
+! Define "Conventions" global attribute
+  i_rc = NF90_PUT_ATT(f_e,NF90_GLOBAL,'Conventions',"CF-1.1")
+!-
+! Add the DOMAIN attributes if needed
+  CALL flio_dom_att (f_e,id_dom)
+!-
+! Keep the file information
+  nw_id(f_i) = f_e
+  CALL flio_inf (f_e, &
+ &  nb_dims=nw_nd(f_i),id_unlm=nw_un(f_i),nb_atts=nw_na(f_i), &
+ &  nn_idm=nw_di(:,f_i),nn_ldm=nw_dl(:,f_i),nn_aid=nw_ai(:,f_i))
+!-
+! Return the created file name if needed
+  IF (PRESENT(c_f_n)) THEN
+    IF (LEN(c_f_n) >= LEN_TRIM(f_nw)) THEN
+      c_f_n = TRIM(f_nw)
+    ELSE
+      CALL ipslerr (3,'fliocrfd', &
+ &     'the length of "c_f_n" is not sufficient to receive', &
+ &     'the name of the created file :',TRIM(f_nw))
+    ENDIF
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) '<-fliocrfd'
+  ENDIF
+!----------------------
+END SUBROUTINE fliocrfd
+!===
+SUBROUTINE fliopstc &
+ & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, &
+ &      t_axis,t_init,t_step,t_calendar)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  REAL,DIMENSION(:),OPTIONAL,INTENT(IN)    :: x_axis,y_axis
+  REAL,DIMENSION(:,:),OPTIONAL,INTENT(IN)  :: x_axis_2d,y_axis_2d
+  REAL,DIMENSION(:),OPTIONAL,INTENT(IN)    :: z_axis
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: t_axis
+  CHARACTER(LEN=*),OPTIONAL,INTENT(IN)     :: t_calendar
+  REAL,OPTIONAL,INTENT(IN)                 :: t_init,t_step
+!-
+  INTEGER :: i_rc,f_e
+  INTEGER :: lonid,latid,levid,timeid
+  INTEGER :: j_yy,j_mo,j_dd,j_hh,j_mn,j_ss
+  REAL    :: dt,r_ss,v_min,v_max
+  INTEGER :: k,k_1,k_2
+  LOGICAL :: l_tmp
+  CHARACTER(LEN=20) :: c_tmp1
+  CHARACTER(LEN=40) :: c_tmp2
+  CHARACTER(LEN=80) :: c_tmp3
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->fliopstc"
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('fliopstc',f_i,f_e)
+!-
+! Validate the coherence of the arguments
+!-
+  IF (    (PRESENT(x_axis).AND.PRESENT(x_axis_2d)) &
+ &    .OR.(PRESENT(y_axis).AND.PRESENT(y_axis_2d)) ) THEN
+    CALL ipslerr (3,'fliopstc', &
+ &    'The [x/y]_axis arguments', &
+ &    'are not coherent :',&
+ &    'can not handle two [x/y]_axis')
+  ENDIF
+!-
+  IF (    PRESENT(x_axis).OR.PRESENT(x_axis_2d) &
+ &    .OR.PRESENT(y_axis).OR.PRESENT(y_axis_2d) ) THEN
+    k_1=nw_ai(k_lon,f_i); k_2=nw_ai(k_lat,f_i);
+  ENDIF
+!-
+! Define the longitude axis
+!-
+  IF (PRESENT(x_axis).OR.PRESENT(x_axis_2d)) THEN
+!---
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) '  fliopstc : Define the Longitude axis'
+    ENDIF
+!---
+    IF (PRESENT(x_axis)) THEN
+      IF (SIZE(x_axis) /= nw_dl(k_1,f_i)) THEN
+        CALL ipslerr (3,'fliopstc', &
+ &       'Invalid x_axis dimension :', &
+ &       'not equal to the dimension', &
+ &       'defined at the creation of the file')
+      ENDIF
+    ELSE
+      IF (    (SIZE(x_axis_2d,DIM=1) /= nw_dl(k_1,f_i)) &
+ &        .OR.(SIZE(x_axis_2d,DIM=2) /= nw_dl(k_2,f_i)) ) THEN
+        CALL ipslerr (3,'fliopstc', &
+ &       'Invalid x_axis_2d dimensions :', &
+ &       'not equal to the dimensions', &
+ &       'defined at the creation of the file')
+      ENDIF
+    ENDIF
+!---
+    CALL flio_hdm (f_i,f_e,.TRUE.)
+    IF (PRESENT(x_axis)) THEN
+      i_rc = NF90_DEF_VAR(f_e,"lon",NF90_REAL4, &
+ &                        nw_di(k_1,f_i),lonid)
+      v_min = MINVAL(x_axis)
+      v_max = MAXVAL(x_axis)
+    ELSE
+      i_rc = NF90_DEF_VAR(f_e,"nav_lon",NF90_REAL4, &
+ &             nw_di((/k_1,k_2/),f_i),lonid)
+      v_min = MINVAL(x_axis_2d)
+      v_max = MAXVAL(x_axis_2d)
+    ENDIF
+    i_rc = NF90_PUT_ATT(f_e,lonid,"axis","X")
+    i_rc = NF90_PUT_ATT(f_e,lonid,'standard_name',"longitude")
+    i_rc = NF90_PUT_ATT(f_e,lonid,'units',"degrees_east")
+    i_rc = NF90_PUT_ATT(f_e,lonid,'valid_min',REAL(v_min,KIND=4))
+    i_rc = NF90_PUT_ATT(f_e,lonid,'valid_max',REAL(v_max,KIND=4))
+  ENDIF
+!-
+! Define the Latitude axis
+!-
+  IF (PRESENT(y_axis).OR.PRESENT(y_axis_2d)) THEN
+!---
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) '  fliopstc : Define the Latitude axis'
+    ENDIF
+!---
+    IF (PRESENT(y_axis)) THEN
+      IF (SIZE(y_axis) /= nw_dl(k_2,f_i)) THEN
+        CALL ipslerr (3,'fliopstc', &
+ &       'Invalid y_axis dimension :', &
+ &       'not equal to the dimension', &
+ &       'defined at the creation of the file')
+      ENDIF
+    ELSE
+      IF (    (SIZE(y_axis_2d,DIM=1) /= nw_dl(k_1,f_i)) &
+ &        .OR.(SIZE(y_axis_2d,DIM=2) /= nw_dl(k_2,f_i)) ) THEN
+        CALL ipslerr (3,'fliopstc', &
+ &       'Invalid y_axis_2d dimensions :', &
+ &       'not equal to the dimensions', &
+ &       'defined at the creation of the file')
+      ENDIF
+    ENDIF
+!---
+    CALL flio_hdm (f_i,f_e,.TRUE.)
+    IF (PRESENT(y_axis)) THEN
+      i_rc = NF90_DEF_VAR(f_e,"lat",NF90_REAL4, &
+ &                        nw_di(k_2,f_i),latid)
+      v_min = MINVAL(y_axis)
+      v_max = MAXVAL(y_axis)
+    ELSE
+      i_rc = NF90_DEF_VAR(f_e,"nav_lat",NF90_REAL4, &
+ &             nw_di((/k_1,k_2/),f_i),latid)
+      v_min = MINVAL(y_axis_2d)
+      v_max = MAXVAL(y_axis_2d)
+    ENDIF
+    i_rc = NF90_PUT_ATT(f_e,latid,"axis","Y")
+    i_rc = NF90_PUT_ATT(f_e,latid,'standard_name',"latitude")
+    i_rc = NF90_PUT_ATT(f_e,latid,'units',"degrees_north")
+    i_rc = NF90_PUT_ATT(f_e,latid,'valid_min',REAL(v_min,KIND=4))
+    i_rc = NF90_PUT_ATT(f_e,latid,'valid_max',REAL(v_max,KIND=4))
+  ENDIF
+!-
+! Define the Vertical axis
+!-
+  IF (PRESENT(z_axis)) THEN
+!---
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) '  fliopstc : Define the Vertical axis'
+    ENDIF
+!---
+    k_1=nw_ai(k_lev,f_i);
+!---
+    IF (SIZE(z_axis) /= nw_dl(k_1,f_i)) THEN
+      CALL ipslerr (3,'fliopstc', &
+ &     'Invalid z_axis dimension :', &
+ &     'not equal to the dimension', &
+ &     'defined at the creation of the file')
+    ENDIF
+!---
+    v_min = MINVAL(z_axis)
+    v_max = MAXVAL(z_axis)
+!---
+    CALL flio_hdm (f_i,f_e,.TRUE.)
+    i_rc = NF90_DEF_VAR(f_e,'lev',NF90_REAL4, &
+ &                      nw_di(k_1,f_i),levid)
+    i_rc = NF90_PUT_ATT(f_e,levid,"axis","Z")
+    i_rc = NF90_PUT_ATT(f_e,levid,'standard_name','model_level_number')
+    i_rc = NF90_PUT_ATT(f_e,levid,'units','sigma_level')
+    i_rc = NF90_PUT_ATT(f_e,levid,'long_name','Sigma Levels')
+    i_rc = NF90_PUT_ATT(f_e,levid,'valid_min',REAL(v_min,KIND=4))
+    i_rc = NF90_PUT_ATT(f_e,levid,'valid_max',REAL(v_max,KIND=4))
+  ENDIF
+!-
+! Define the Time axis
+!-
+  IF (PRESENT(t_axis).AND.PRESENT(t_init).AND.PRESENT(t_step)) THEN
+!---
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) '  fliopstc : Define the Time axis'
+    ENDIF
+!---
+    k_1=nw_ai(k_tim,f_i);
+!---
+    IF (     (nw_dl(k_1,f_i) /= 0) &
+ &      .AND.(SIZE(t_axis) /= nw_dl(k_1,f_i)) ) THEN
+      CALL ipslerr (3,'fliopstc', &
+ &     'Invalid t_axis dimension :', &
+ &     'not equal to the dimension', &
+ &     'defined at the creation of the file')
+    ENDIF
+!-- Retrieve the calendar date
+    CALL lock_calendar (old_status=l_tmp)
+    IF (PRESENT(t_calendar)) THEN
+      CALL ioget_calendar (c_tmp1)
+      CALL lock_calendar (new_status=.FALSE.)
+      CALL ioconf_calendar (TRIM(t_calendar))
+    ENDIF
+    CALL ju2ymds (t_init,j_yy,j_mo,j_dd,r_ss)
+    IF (PRESENT(t_calendar)) THEN
+      CALL lock_calendar (new_status=.FALSE.)
+      CALL ioconf_calendar (TRIM(c_tmp1))
+    ENDIF
+    CALL lock_calendar (new_status=l_tmp)
+!--
+    k=NINT(r_ss)
+    j_hh=k/3600
+    k=k-3600*j_hh
+    j_mn=k/60
+    j_ss=k-60*j_mn
+!-- Calculate the step unit
+    IF      (ABS(t_step) >= 604800.) THEN
+      dt = t_step/604800.
+      c_tmp2 = 'weeks'
+    ELSE IF (ABS(t_step) >= 86400.) THEN
+      dt = t_step/86400.
+      c_tmp2 = 'days'
+    ELSE IF (ABS(t_step) >=  3600.) THEN
+      dt = t_step/3600.
+      c_tmp2 = 'hours'
+    ELSE IF (ABS(t_step) >=    60.) THEN
+      dt = t_step/60.
+      c_tmp2 = 'minutes'
+    ELSE
+      dt = t_step
+      c_tmp2 = 'seconds'
+    ENDIF
+!---
+    c_tmp1 = ''
+    IF (ABS(dt-NINT(dt)) <= ABS(10.*EPSILON(dt))) THEN
+      IF (NINT(dt) /= 1) THEN
+        WRITE (UNIT=c_tmp1,FMT='(I15)') NINT(dt)
+      ENDIF
+    ELSE
+      IF (dt < 1.) THEN
+       WRITE (UNIT=c_tmp1,FMT='(F8.5)') dt
+      ELSE
+       WRITE (UNIT=c_tmp1,FMT='(F17.5)') dt
+      ENDIF
+      DO k=LEN_TRIM(c_tmp1),1,-1
+        IF (c_tmp1(k:k) /= '0') THEN
+          EXIT
+        ELSE
+          c_tmp1(k:k) = ' '
+        ENDIF
+      ENDDO
+    ENDIF
+    c_tmp2 = TRIM(c_tmp1)//' '//TRIM(c_tmp2)
+    WRITE (UNIT=c_tmp3, &
+ &   FMT='(A,I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') &
+ &    TRIM(ADJUSTL(c_tmp2))//' since ',j_yy,j_mo,j_dd,j_hh,j_mn,j_ss
+!---
+    CALL flio_hdm (f_i,f_e,.TRUE.)
+    i_rc = NF90_DEF_VAR(f_e,'time',NF90_REAL4, &
+ &                      nw_di(k_1,f_i),timeid)
+    i_rc = NF90_PUT_ATT(f_e,timeid,"axis",'T')
+    i_rc = NF90_PUT_ATT(f_e,timeid,'standard_name','time')
+    i_rc = NF90_PUT_ATT(f_e,timeid,'long_name','time steps')
+    IF (PRESENT(t_calendar)) THEN
+      i_rc = NF90_PUT_ATT(f_e,timeid,'calendar',TRIM(t_calendar))
+    ENDIF
+    i_rc = NF90_PUT_ATT(f_e,timeid,'units',TRIM(c_tmp3))
+  ELSE IF (PRESENT(t_axis).OR.PRESENT(t_init).OR.PRESENT(t_step)) THEN
+    CALL ipslerr (3,'fliopstc', &
+ &   'For time axis and coordinates', &
+ &   'arguments t_axis AND t_init AND t_step', &
+ &   'must be PRESENT')
+  ENDIF
+!-
+! Ensuring data mode
+!-
+  CALL flio_hdm (f_i,f_e,.FALSE.)
+!-
+! Create the longitude axis
+!-
+  IF (PRESENT(x_axis).OR.PRESENT(x_axis_2d)) THEN
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) '  fliopstc : Create the Longitude axis'
+    ENDIF
+    IF (PRESENT(x_axis)) THEN
+      i_rc = NF90_PUT_VAR(f_e,lonid,x_axis(:))
+    ELSE
+      i_rc = NF90_PUT_VAR(f_e,lonid,x_axis_2d(:,:))
+    ENDIF
+  ENDIF
+!-
+! Create the Latitude axis
+!-
+  IF (PRESENT(y_axis).OR.PRESENT(y_axis_2d)) THEN
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) '  fliopstc : Create the Latitude axis'
+    ENDIF
+    IF (PRESENT(y_axis)) THEN
+      i_rc = NF90_PUT_VAR(f_e,latid,y_axis(:))
+    ELSE
+      i_rc = NF90_PUT_VAR(f_e,latid,y_axis_2d(:,:))
+    ENDIF
+  ENDIF
+!-
+! Create the Vertical axis
+!-
+  IF (PRESENT(z_axis)) THEN
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) '  fliopstc : Create the Vertical axis'
+    ENDIF
+    i_rc = NF90_PUT_VAR(f_e,levid,z_axis(:))
+  ENDIF
+!-
+! Create the Time axis
+!-
+  IF (PRESENT(t_axis)) THEN
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) '  fliopstc : Create the Time axis'
+    ENDIF
+    i_rc = NF90_PUT_VAR(f_e,timeid,REAL(t_axis(:)))
+  ENDIF
+!-
+! Keep all this information
+!-
+  CALL flio_inf (f_e,nb_vars=nw_nv(f_i),nb_atts=nw_na(f_i))
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-fliopstc"
+  ENDIF
+!----------------------
+END SUBROUTINE fliopstc
+!===
+SUBROUTINE fliodv_r0d &
+ & (f_i,v_n,v_t, &
+ &  axis,standard_name,long_name,units,valid_min,valid_max,fillvalue)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER,OPTIONAL,INTENT(IN) :: v_t
+  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: &
+ & axis,standard_name,long_name,units
+  REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue
+!---------------------------------------------------------------------
+  CALL flio_udv &
+ &  (f_i,0,v_n,(/0/),v_t, &
+ &   axis,standard_name,long_name,units,valid_min,valid_max,fillvalue)
+!------------------------
+END SUBROUTINE fliodv_r0d
+!===
+SUBROUTINE fliodv_rnd &
+ & (f_i,v_n,v_d,v_t, &
+ &  axis,standard_name,long_name,units,valid_min,valid_max,fillvalue)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER,DIMENSION(:),INTENT(IN) :: v_d
+  INTEGER,OPTIONAL,INTENT(IN) :: v_t
+  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: &
+ & axis,standard_name,long_name,units
+  REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue
+!---------------------------------------------------------------------
+  CALL flio_udv &
+ &  (f_i,SIZE(v_d),v_n,v_d,v_t, &
+ &   axis,standard_name,long_name,units,valid_min,valid_max,fillvalue)
+!------------------------
+END SUBROUTINE fliodv_rnd
+!===
+SUBROUTINE flio_udv &
+ & (f_i,n_d,v_n,v_d,v_t, &
+ &  axis,standard_name,long_name,units,valid_min,valid_max,fillvalue)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i,n_d
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER,DIMENSION(:),INTENT(IN) :: v_d
+  INTEGER,OPTIONAL,INTENT(IN) :: v_t
+  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: &
+ & axis,standard_name,long_name,units
+  REAL,OPTIONAL,INTENT(IN) :: valid_min,valid_max,fillvalue
+!-
+  INTEGER :: f_e,m_k,i_v,i_rc,ii,idd
+  INTEGER,DIMENSION(nb_vd_mx) :: a_i
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->fliodefv ",TRIM(v_n)," ",n_d,"D"
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('fliodefv',f_i,f_e)
+!-
+  IF (n_d > 0) THEN
+    IF (n_d > nb_vd_mx) THEN
+      CALL ipslerr (3,'fliodefv', &
+ &     'Too many dimensions', &
+ &     'required for the variable',TRIM(v_n))
+    ENDIF
+  ENDIF
+!-
+  DO ii=1,n_d
+    IF ( (v_d(ii) >= 1).AND.(v_d(ii) <= nb_fd_mx) ) THEN
+      idd = nw_di(v_d(ii),f_i)
+      IF (idd > 0) THEN
+        a_i(ii) = idd
+      ELSE
+        CALL ipslerr (3,'fliodefv', &
+ &       'Invalid dimension identifier','(not defined)',' ')
+      ENDIF
+    ELSE
+      CALL ipslerr (3,'fliodefv', &
+ &     'Invalid dimension identifier','(not supported)',' ')
+    ENDIF
+  ENDDO
+!-
+  i_rc = NF90_INQ_VARID(f_e,v_n,i_v)
+  IF (i_rc /= NF90_NOERR) THEN
+    CALL flio_hdm (f_i,f_e,.TRUE.)
+!---
+    IF (PRESENT(v_t)) THEN
+      SELECT CASE (v_t)
+      CASE(flio_i)
+        IF (i_std == i_8) THEN
+!-------- I8 not yet supported by NETCDF
+!-------- m_k = flio_i8
+          m_k = flio_i4
+        ELSE
+          m_k = flio_i4
+        ENDIF
+      CASE(flio_r)
+        IF (r_std == r_8) THEN
+          m_k = flio_r8
+        ELSE
+          m_k = flio_r4
+        ENDIF
+      CASE(flio_c,flio_i1,flio_i2,flio_i4,flio_r4,flio_r8)
+        m_k = v_t
+      CASE DEFAULT
+        CALL ipslerr (3,'fliodefv', &
+ &        'Variable '//TRIM(v_n),'External type','not supported')
+      END SELECT
+    ELSE IF (r_std == r_8) THEN
+      m_k = flio_r8
+    ELSE
+      m_k = flio_r4
+    ENDIF
+!---
+    IF (n_d > 0) THEN
+      i_rc = NF90_DEF_VAR(f_e,v_n,m_k,a_i(1:n_d),i_v)
+    ELSE
+      i_rc = NF90_DEF_VAR(f_e,v_n,m_k,i_v)
+    ENDIF
+    IF (i_rc /= NF90_NOERR) THEN
+      CALL ipslerr (3,'fliodefv', &
+ &      'Variable '//TRIM(v_n)//' not defined','Error :', &
+ &      TRIM(NF90_STRERROR(i_rc)))
+    ENDIF
+    nw_nv(f_i) = nw_nv(f_i)+1
+!---
+    IF (PRESENT(axis)) THEN
+      i_rc = NF90_PUT_ATT(f_e,i_v,'axis',TRIM(axis))
+    ENDIF
+    IF (PRESENT(standard_name)) THEN
+      i_rc = NF90_PUT_ATT(f_e,i_v,'standard_name',TRIM(standard_name))
+    ENDIF
+    IF (PRESENT(long_name)) THEN
+      i_rc = NF90_PUT_ATT(f_e,i_v,'long_name',TRIM(long_name))
+    ENDIF
+    IF (PRESENT(units)) THEN
+      i_rc = NF90_PUT_ATT(f_e,i_v,'units',TRIM(units))
+    ENDIF
+    IF (PRESENT(valid_min)) THEN
+      SELECT CASE (m_k)
+      CASE(flio_i1,flio_i2)
+        i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',NINT(valid_min,KIND=i_2))
+      CASE(flio_i4)
+        i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',NINT(valid_min,KIND=i_4))
+      CASE(flio_r4)
+        i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',REAL(valid_min,KIND=r_4))
+      CASE(flio_r8)
+        i_rc = NF90_PUT_ATT(f_e,i_v,'valid_min',REAL(valid_min,KIND=r_8))
+      CASE DEFAULT
+        CALL ipslerr (2,'fliodefv', &
+   &      'Variable '//TRIM(v_n),'attribute valid_min', &
+   &      'not supported for this external type')
+      END SELECT
+    ENDIF
+    IF (PRESENT(valid_max)) THEN
+      SELECT CASE (m_k)
+      CASE(flio_i1,flio_i2)
+        i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',NINT(valid_max,KIND=i_2))
+      CASE(flio_i4)
+        i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',NINT(valid_max,KIND=i_4))
+      CASE(flio_r4)
+        i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',REAL(valid_max,KIND=r_4))
+      CASE(flio_r8)
+        i_rc = NF90_PUT_ATT(f_e,i_v,'valid_max',REAL(valid_max,KIND=r_8))
+      CASE DEFAULT
+        CALL ipslerr (2,'fliodefv', &
+   &      'Variable '//TRIM(v_n),'attribute valid_max', &
+   &      'not supported for this external type')
+      END SELECT
+    ENDIF
+    IF (PRESENT(fillvalue)) THEN
+      SELECT CASE (m_k)
+      CASE(flio_i1,flio_i2)
+        i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',NINT(fillvalue,KIND=i_2))
+      CASE(flio_i4)
+        i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',NINT(fillvalue,KIND=i_4))
+      CASE(flio_r4)
+        i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',REAL(fillvalue,KIND=r_4))
+      CASE(flio_r8)
+        i_rc = NF90_PUT_ATT(f_e,i_v,'_FillValue',REAL(fillvalue,KIND=r_8))
+      CASE DEFAULT
+        CALL ipslerr (2,'fliodefv', &
+   &      'Variable '//TRIM(v_n),'attribute fillvalue', &
+   &      'not supported for this external type')
+      END SELECT
+    ENDIF
+!---
+  ELSE
+    CALL ipslerr (3,'fliodefv','Variable',TRIM(v_n),'already exist')
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-fliodefv"
+  ENDIF
+!----------------------
+END SUBROUTINE flio_udv
+!===
+SUBROUTINE fliopv_i40 (f_i,v_n,v_v,start)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,i_40=v_v,start=start)
+!------------------------
+END SUBROUTINE fliopv_i40
+!===
+SUBROUTINE fliopv_i41 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),DIMENSION(:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,i_41=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_i41
+!===
+SUBROUTINE fliopv_i42 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,i_42=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_i42
+!===
+SUBROUTINE fliopv_i43 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,i_43=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_i43
+!===
+SUBROUTINE fliopv_i44 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,i_44=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_i44
+!===
+SUBROUTINE fliopv_i45 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,i_45=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_i45
+!===
+SUBROUTINE fliopv_i20 (f_i,v_n,v_v,start)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_2),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,i_20=v_v,start=start)
+!------------------------
+END SUBROUTINE fliopv_i20
+!===
+SUBROUTINE fliopv_i21 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_2),DIMENSION(:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,i_21=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_i21
+!===
+SUBROUTINE fliopv_i22 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,i_22=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_i22
+!===
+SUBROUTINE fliopv_i23 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,i_23=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_i23
+!===
+SUBROUTINE fliopv_i24 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,i_24=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_i24
+!===
+SUBROUTINE fliopv_i25 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,i_25=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_i25
+!===
+!?INTEGERS of KIND 1 are not supported on all computers
+!?SUBROUTINE fliopv_i10 (f_i,v_n,v_v,start)
+!?!---------------------------------------------------------------------
+!?  IMPLICIT NONE
+!?!-
+!?  INTEGER,INTENT(IN) :: f_i
+!?  CHARACTER(LEN=*),INTENT(IN) :: v_n
+!?  INTEGER(KIND=i_1),INTENT(IN) :: v_v
+!?  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start
+!?!---------------------------------------------------------------------
+!?  CALL flio_upv (f_i,v_n,i_10=v_v,start=start)
+!?!------------------------
+!?END SUBROUTINE fliopv_i10
+!?!===
+!?SUBROUTINE fliopv_i11 (f_i,v_n,v_v,start,count)
+!?!---------------------------------------------------------------------
+!?  IMPLICIT NONE
+!?!-
+!?  INTEGER,INTENT(IN) :: f_i
+!?  CHARACTER(LEN=*),INTENT(IN) :: v_n
+!?  INTEGER(KIND=i_1),DIMENSION(:),INTENT(IN) :: v_v
+!?  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!?!---------------------------------------------------------------------
+!?  CALL flio_upv (f_i,v_n,i_11=v_v,start=start,count=count)
+!?!------------------------
+!?END SUBROUTINE fliopv_i11
+!?!===
+!?SUBROUTINE fliopv_i12 (f_i,v_n,v_v,start,count)
+!?!---------------------------------------------------------------------
+!?  IMPLICIT NONE
+!?!-
+!?  INTEGER,INTENT(IN) :: f_i
+!?  CHARACTER(LEN=*),INTENT(IN) :: v_n
+!?  INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(IN) :: v_v
+!?  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!?!---------------------------------------------------------------------
+!?  CALL flio_upv (f_i,v_n,i_12=v_v,start=start,count=count)
+!?!------------------------
+!?END SUBROUTINE fliopv_i12
+!?!===
+!?SUBROUTINE fliopv_i13 (f_i,v_n,v_v,start,count)
+!?!---------------------------------------------------------------------
+!?  IMPLICIT NONE
+!?!-
+!?  INTEGER,INTENT(IN) :: f_i
+!?  CHARACTER(LEN=*),INTENT(IN) :: v_n
+!?  INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(IN) :: v_v
+!?  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!?!---------------------------------------------------------------------
+!?  CALL flio_upv (f_i,v_n,i_13=v_v,start=start,count=count)
+!?!------------------------
+!?END SUBROUTINE fliopv_i13
+!?!===
+!?SUBROUTINE fliopv_i14 (f_i,v_n,v_v,start,count)
+!?!---------------------------------------------------------------------
+!?  IMPLICIT NONE
+!?!-
+!?  INTEGER,INTENT(IN) :: f_i
+!?  CHARACTER(LEN=*),INTENT(IN) :: v_n
+!?  INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(IN) :: v_v
+!?  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!?!---------------------------------------------------------------------
+!?  CALL flio_upv (f_i,v_n,i_14=v_v,start=start,count=count)
+!?!------------------------
+!?END SUBROUTINE fliopv_i14
+!?!===
+!?SUBROUTINE fliopv_i15 (f_i,v_n,v_v,start,count)
+!?!---------------------------------------------------------------------
+!?  IMPLICIT NONE
+!?!-
+!?  INTEGER,INTENT(IN) :: f_i
+!?  CHARACTER(LEN=*),INTENT(IN) :: v_n
+!?  INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v
+!?  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!?!---------------------------------------------------------------------
+!?  CALL flio_upv (f_i,v_n,i_15=v_v,start=start,count=count)
+!?!------------------------
+!?END SUBROUTINE fliopv_i15
+!===
+SUBROUTINE fliopv_r40 (f_i,v_n,v_v,start)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_4),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,r_40=v_v,start=start)
+!------------------------
+END SUBROUTINE fliopv_r40
+!===
+SUBROUTINE fliopv_r41 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_4),DIMENSION(:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,r_41=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_r41
+!===
+SUBROUTINE fliopv_r42 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_4),DIMENSION(:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,r_42=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_r42
+!===
+SUBROUTINE fliopv_r43 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,r_43=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_r43
+!===
+SUBROUTINE fliopv_r44 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,r_44=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_r44
+!===
+SUBROUTINE fliopv_r45 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,r_45=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_r45
+!===
+SUBROUTINE fliopv_r80 (f_i,v_n,v_v,start)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_8),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,r_80=v_v,start=start)
+!------------------------
+END SUBROUTINE fliopv_r80
+!===
+SUBROUTINE fliopv_r81 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_8),DIMENSION(:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,r_81=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_r81
+!===
+SUBROUTINE fliopv_r82 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_8),DIMENSION(:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,r_82=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_r82
+!===
+SUBROUTINE fliopv_r83 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,r_83=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_r83
+!===
+SUBROUTINE fliopv_r84 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,r_84=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_r84
+!===
+SUBROUTINE fliopv_r85 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(IN) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_upv (f_i,v_n,r_85=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliopv_r85
+!===
+SUBROUTINE flio_upv &
+ & (f_i,v_n, &
+ &  i_40,i_41,i_42,i_43,i_44,i_45, &
+ &  i_20,i_21,i_22,i_23,i_24,i_25, &
+!? &  i_10,i_11,i_12,i_13,i_14,i_15, &
+ &  r_40,r_41,r_42,r_43,r_44,r_45, &
+ &  r_80,r_81,r_82,r_83,r_84,r_85, &
+ &  start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),INTENT(IN),OPTIONAL :: i_40
+  INTEGER(KIND=i_4),DIMENSION(:),INTENT(IN),OPTIONAL :: i_41
+  INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(IN),OPTIONAL :: i_42
+  INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: i_43
+  INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: i_44
+  INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: i_45
+  INTEGER(KIND=i_2),INTENT(IN),OPTIONAL :: i_20
+  INTEGER(KIND=i_2),DIMENSION(:),INTENT(IN),OPTIONAL :: i_21
+  INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(IN),OPTIONAL :: i_22
+  INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: i_23
+  INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: i_24
+  INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: i_25
+!?INTEGERS of KIND 1 are not supported on all computers
+!?INTEGER(KIND=i_1),INTENT(IN),OPTIONAL :: i_10
+!?INTEGER(KIND=i_1),DIMENSION(:),INTENT(IN),OPTIONAL :: i_11
+!?INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(IN),OPTIONAL :: i_12
+!?INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: i_13
+!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: i_14
+!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: i_15
+  REAL(KIND=r_4),INTENT(IN),OPTIONAL :: r_40
+  REAL(KIND=r_4),DIMENSION(:),INTENT(IN),OPTIONAL :: r_41
+  REAL(KIND=r_4),DIMENSION(:,:),INTENT(IN),OPTIONAL :: r_42
+  REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: r_43
+  REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: r_44
+  REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: r_45
+  REAL(KIND=r_8),INTENT(IN),OPTIONAL :: r_80
+  REAL(KIND=r_8),DIMENSION(:),INTENT(IN),OPTIONAL :: r_81
+  REAL(KIND=r_8),DIMENSION(:,:),INTENT(IN),OPTIONAL :: r_82
+  REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: r_83
+  REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(IN),OPTIONAL :: r_84
+  REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(IN),OPTIONAL :: r_85
+  INTEGER,DIMENSION(:),INTENT(IN),OPTIONAL :: start,count
+!-
+  INTEGER :: f_e,i_v,i_rc
+  CHARACTER(LEN=5) :: cvr_d
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    IF      (PRESENT(i_40)) THEN; cvr_d = "I1 0D";
+    ELSE IF (PRESENT(i_41)) THEN; cvr_d = "I1 1D";
+    ELSE IF (PRESENT(i_42)) THEN; cvr_d = "I1 2D";
+    ELSE IF (PRESENT(i_43)) THEN; cvr_d = "I1 3D";
+    ELSE IF (PRESENT(i_44)) THEN; cvr_d = "I1 4D";
+    ELSE IF (PRESENT(i_45)) THEN; cvr_d = "I1 5D";
+    ELSE IF (PRESENT(i_20)) THEN; cvr_d = "I2 0D";
+    ELSE IF (PRESENT(i_21)) THEN; cvr_d = "I2 1D";
+    ELSE IF (PRESENT(i_22)) THEN; cvr_d = "I2 2D";
+    ELSE IF (PRESENT(i_23)) THEN; cvr_d = "I2 3D";
+    ELSE IF (PRESENT(i_24)) THEN; cvr_d = "I2 4D";
+    ELSE IF (PRESENT(i_25)) THEN; cvr_d = "I2 5D";
+!?  ELSE IF (PRESENT(i_10)) THEN; cvr_d = "I4 0D";
+!?  ELSE IF (PRESENT(i_11)) THEN; cvr_d = "I4 1D";
+!?  ELSE IF (PRESENT(i_12)) THEN; cvr_d = "I4 2D";
+!?  ELSE IF (PRESENT(i_13)) THEN; cvr_d = "I4 3D";
+!?  ELSE IF (PRESENT(i_14)) THEN; cvr_d = "I4 4D";
+!?  ELSE IF (PRESENT(i_15)) THEN; cvr_d = "I4 5D";
+    ELSE IF (PRESENT(r_40)) THEN; cvr_d = "R4 0D";
+    ELSE IF (PRESENT(r_41)) THEN; cvr_d = "R4 1D";
+    ELSE IF (PRESENT(r_42)) THEN; cvr_d = "R4 2D";
+    ELSE IF (PRESENT(r_43)) THEN; cvr_d = "R4 3D";
+    ELSE IF (PRESENT(r_44)) THEN; cvr_d = "R4 4D";
+    ELSE IF (PRESENT(r_45)) THEN; cvr_d = "R4 5D";
+    ELSE IF (PRESENT(r_80)) THEN; cvr_d = "R8 0D";
+    ELSE IF (PRESENT(r_81)) THEN; cvr_d = "R8 1D";
+    ELSE IF (PRESENT(r_82)) THEN; cvr_d = "R8 2D";
+    ELSE IF (PRESENT(r_83)) THEN; cvr_d = "R8 3D";
+    ELSE IF (PRESENT(r_84)) THEN; cvr_d = "R8 4D";
+    ELSE IF (PRESENT(r_85)) THEN; cvr_d = "R8 5D";
+    ENDIF
+    WRITE(ipslout,*) "->flioputv ",TRIM(v_n)," ",TRIM(cvr_d)
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('flioputv',f_i,f_e)
+!-
+! Ensuring data mode
+!-
+  CALL flio_hdm (f_i,f_e,.FALSE.)
+!-
+  i_rc = NF90_INQ_VARID(f_e,v_n,i_v)
+  IF (i_rc == NF90_NOERR) THEN
+    IF      (PRESENT(i_40)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,i_40,start=start)
+    ELSE IF (PRESENT(i_41)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,i_41,start=start,count=count)
+    ELSE IF (PRESENT(i_42)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,i_42,start=start,count=count)
+    ELSE IF (PRESENT(i_43)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,i_43,start=start,count=count)
+    ELSE IF (PRESENT(i_44)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,i_44,start=start,count=count)
+    ELSE IF (PRESENT(i_45)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,i_45,start=start,count=count)
+    ELSE IF (PRESENT(i_20)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,i_20,start=start)
+    ELSE IF (PRESENT(i_21)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,i_21,start=start,count=count)
+    ELSE IF (PRESENT(i_22)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,i_22,start=start,count=count)
+    ELSE IF (PRESENT(i_23)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,i_23,start=start,count=count)
+    ELSE IF (PRESENT(i_24)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,i_24,start=start,count=count)
+    ELSE IF (PRESENT(i_25)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,i_25,start=start,count=count)
+!?  ELSE IF (PRESENT(i_10)) THEN
+!?    i_rc = NF90_PUT_VAR(f_e,i_v,i_10,start=start)
+!?  ELSE IF (PRESENT(i_11)) THEN
+!?    i_rc = NF90_PUT_VAR(f_e,i_v,i_11,start=start,count=count)
+!?  ELSE IF (PRESENT(i_12)) THEN
+!?    i_rc = NF90_PUT_VAR(f_e,i_v,i_12,start=start,count=count)
+!?  ELSE IF (PRESENT(i_13)) THEN
+!?    i_rc = NF90_PUT_VAR(f_e,i_v,i_13,start=start,count=count)
+!?  ELSE IF (PRESENT(i_14)) THEN
+!?    i_rc = NF90_PUT_VAR(f_e,i_v,i_14,start=start,count=count)
+!?  ELSE IF (PRESENT(i_15)) THEN
+!?    i_rc = NF90_PUT_VAR(f_e,i_v,i_15,start=start,count=count)
+    ELSE IF (PRESENT(r_40)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,r_40,start=start)
+    ELSE IF (PRESENT(r_41)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,r_41,start=start,count=count)
+    ELSE IF (PRESENT(r_42)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,r_42,start=start,count=count)
+    ELSE IF (PRESENT(r_43)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,r_43,start=start,count=count)
+    ELSE IF (PRESENT(r_44)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,r_44,start=start,count=count)
+    ELSE IF (PRESENT(r_45)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,r_45,start=start,count=count)
+    ELSE IF (PRESENT(r_80)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,r_80,start=start)
+    ELSE IF (PRESENT(r_81)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,r_81,start=start,count=count)
+    ELSE IF (PRESENT(r_82)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,r_82,start=start,count=count)
+    ELSE IF (PRESENT(r_83)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,r_83,start=start,count=count)
+    ELSE IF (PRESENT(r_84)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,r_84,start=start,count=count)
+    ELSE IF (PRESENT(r_85)) THEN
+      i_rc = NF90_PUT_VAR(f_e,i_v,r_85,start=start,count=count)
+    ENDIF
+    IF (i_rc /= NF90_NOERR) THEN
+      CALL ipslerr (3,'flioputv', &
+ &      'Variable '//TRIM(v_n)//' not put','Error :', &
+ &      TRIM(NF90_STRERROR(i_rc)))
+    ENDIF
+  ELSE
+    CALL ipslerr (3,'flioputv','Variable',TRIM(v_n),'not defined')
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-flioputv"
+  ENDIF
+!----------------------
+END SUBROUTINE flio_upv
+!===
+SUBROUTINE fliopa_r4_0d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  REAL(KIND=4),INTENT(IN) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_upa (f_i,1,v_n,a_n,avr4=(/a_v/))
+!--------------------------
+END SUBROUTINE fliopa_r4_0d
+!===
+SUBROUTINE fliopa_r4_1d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  REAL(KIND=4),DIMENSION(:),INTENT(IN) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_upa (f_i,SIZE(a_v),v_n,a_n,avr4=a_v)
+!--------------------------
+END SUBROUTINE fliopa_r4_1d
+!===
+SUBROUTINE fliopa_r8_0d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  REAL(KIND=8),INTENT(IN) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_upa (f_i,1,v_n,a_n,avr8=(/a_v/))
+!--------------------------
+END SUBROUTINE fliopa_r8_0d
+!===
+SUBROUTINE fliopa_r8_1d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  REAL(KIND=8),DIMENSION(:),INTENT(IN) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_upa (f_i,SIZE(a_v),v_n,a_n,avr8=a_v)
+!--------------------------
+END SUBROUTINE fliopa_r8_1d
+!===
+SUBROUTINE fliopa_i4_0d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  INTEGER(KIND=4),INTENT(IN) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_upa (f_i,1,v_n,a_n,avi4=(/a_v/))
+!--------------------------
+END SUBROUTINE fliopa_i4_0d
+!===
+SUBROUTINE fliopa_i4_1d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  INTEGER(KIND=4),DIMENSION(:),INTENT(IN) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_upa (f_i,SIZE(a_v),v_n,a_n,avi4=a_v)
+!--------------------------
+END SUBROUTINE fliopa_i4_1d
+!===
+SUBROUTINE fliopa_tx_0d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  CHARACTER(LEN=*),INTENT(IN) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_upa (f_i,1,v_n,a_n,avtx=a_v)
+!--------------------------
+END SUBROUTINE fliopa_tx_0d
+!===
+SUBROUTINE flio_upa (f_i,l_a,v_n,a_n,avr4,avr8,avi4,avtx)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i,l_a
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  REAL(KIND=4),DIMENSION(:),OPTIONAL,INTENT(IN) :: avr4
+  REAL(KIND=8),DIMENSION(:),OPTIONAL,INTENT(IN) :: avr8
+  INTEGER(KIND=4),DIMENSION(:),OPTIONAL,INTENT(IN) :: avi4
+  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: avtx
+!-
+  INTEGER :: f_e,i_v,i_a,i_rc
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->flioputa ",TRIM(v_n)," ",TRIM(a_n)
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('flioputa',f_i,f_e)
+!-
+  IF (TRIM(v_n) == '?') THEN
+    i_v = NF90_GLOBAL
+  ELSE
+    i_rc = NF90_INQ_VARID(f_e,v_n,i_v)
+    IF (i_rc /= NF90_NOERR) THEN
+      CALL ipslerr (3,'flioputa', &
+       'Variable :',TRIM(v_n),'not found')
+    ENDIF
+  ENDIF
+!-
+  i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,attnum=i_a)
+  IF ( (i_v == NF90_GLOBAL).AND.(i_rc /= NF90_NOERR) ) THEN
+    nw_na(f_i) = nw_na(f_i)+1
+  ENDIF
+  CALL flio_hdm (f_i,f_e,.TRUE.)
+  IF      (PRESENT(avr4)) THEN
+    i_rc = NF90_PUT_ATT(f_e,i_v,a_n,avr4(1:l_a))
+  ELSE IF (PRESENT(avr8)) THEN
+    i_rc = NF90_PUT_ATT(f_e,i_v,a_n,avr8(1:l_a))
+  ELSE IF (PRESENT(avi4)) THEN
+    i_rc = NF90_PUT_ATT(f_e,i_v,a_n,avi4(1:l_a))
+  ELSE IF (PRESENT(avtx)) THEN
+    i_rc = NF90_PUT_ATT(f_e,i_v,a_n,TRIM(avtx))
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-flioputa"
+  ENDIF
+!----------------------
+END SUBROUTINE flio_upa
+!===
+SUBROUTINE flioopfd (f_n,f_i,mode,nb_dim,nb_var,nb_gat)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(IN) :: f_n
+  INTEGER,INTENT(OUT) :: f_i
+  CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: mode
+  INTEGER,OPTIONAL,INTENT(OUT) :: nb_dim,nb_var,nb_gat
+!-
+  INTEGER :: i_rc,f_e,m_c
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) '->flioopfd, file name : ',TRIM(f_n)
+  ENDIF
+!-
+! Search for a free local identifier
+!-
+  f_i = flio_rid()
+  IF (f_i < 0) THEN
+    CALL ipslerr (3,'flioopfd', &
+      'Too many files.','Please increase nb_fi_mx', &
+      'in module fliocom.f90.')
+  ENDIF
+!-
+! Check the mode
+!-
+  IF (PRESENT(mode)) THEN
+    IF (TRIM(mode) == "WRITE") THEN
+      m_c = NF90_WRITE
+    ELSE
+      m_c = NF90_NOWRITE
+    ENDIF
+  ELSE
+    m_c = NF90_NOWRITE
+  ENDIF
+!-
+! Open the file.
+!-
+  i_rc = NF90_OPEN(TRIM(f_n),m_c,f_e)
+  IF (i_rc /= NF90_NOERR) THEN
+    CALL ipslerr (3,'flioopfd', &
+ &   'Could not open file :',TRIM(f_n), &
+ &   TRIM(NF90_STRERROR(i_rc))//' (Netcdf)')
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) '  flioopfd, model file-id : ',f_e
+  ENDIF
+!-
+! Retrieve and keep information about the file
+!-
+  nw_id(f_i) = f_e
+  lw_hm(f_i) = .FALSE.
+  CALL flio_inf (f_e, &
+ &  nb_dims=nw_nd(f_i),nb_vars=nw_nv(f_i), &
+ &  nb_atts=nw_na(f_i),id_unlm=nw_un(f_i), &
+ &  nn_idm=nw_di(:,f_i),nn_ldm=nw_dl(:,f_i),nn_aid=nw_ai(:,f_i))
+!-
+! Return information to the user
+!-
+  IF (PRESENT(nb_dim)) THEN
+    nb_dim = nw_nd(f_i)
+  ENDIF
+  IF (PRESENT(nb_var)) THEN
+    nb_var = nw_nv(f_i)
+  ENDIF
+  IF (PRESENT(nb_gat)) THEN
+    nb_gat = nw_na(f_i)
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,'("   flioopfd - dimensions :",/,(5(1X,I10),:))') &
+ &    nw_dl(:,f_i)
+    WRITE(ipslout,*) "<-flioopfd"
+  ENDIF
+!----------------------
+END SUBROUTINE flioopfd
+!===
+SUBROUTINE flioinqf &
+ & (f_i,nb_dim,nb_var,nb_gat,id_uld,id_dim,ln_dim)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  INTEGER,OPTIONAL,INTENT(OUT) :: nb_dim,nb_var,nb_gat,id_uld
+  INTEGER,OPTIONAL,INTENT(OUT),DIMENSION(:) :: id_dim,ln_dim
+!-
+  INTEGER :: lll
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->flioinqf"
+  ENDIF
+!-
+  IF ( (f_i < 1).OR.(f_i > nb_fi_mx) ) THEN
+    CALL ipslerr (2,'flioinqf', &
+ &   'Invalid file identifier',' ',' ')
+  ELSE IF (nw_id(f_i) <= 0) THEN
+    CALL ipslerr (2,'flioinqf', &
+ &   'Unable to inquire about the file :','probably','not opened')
+  ELSE
+    IF (PRESENT(nb_dim)) THEN
+      nb_dim = nw_nd(f_i)
+    ENDIF
+    IF (PRESENT(nb_var)) THEN
+      nb_var = nw_nv(f_i)
+    ENDIF
+    IF (PRESENT(nb_gat)) THEN
+      nb_gat = nw_na(f_i)
+    ENDIF
+    IF (PRESENT(id_uld)) THEN
+      id_uld = nw_un(f_i)
+    ENDIF
+    IF (PRESENT(id_dim)) THEN
+      lll = SIZE(id_dim)
+      IF (lll < nw_nd(f_i)) THEN
+        CALL ipslerr (2,'flioinqf', &
+ &       'Only the first identifiers', &
+ &       'of the dimensions','will be returned')
+      ENDIF
+      lll=MIN(SIZE(id_dim),nw_nd(f_i))
+      id_dim(1:lll) = nw_di(1:lll,f_i)
+    ENDIF
+    IF (PRESENT(ln_dim)) THEN
+      lll = SIZE(ln_dim)
+      IF (lll < nw_nd(f_i)) THEN
+        CALL ipslerr (2,'flioinqf', &
+ &       'Only the first lengths', &
+ &       'of the dimensions','will be returned')
+      ENDIF
+      lll=MIN(SIZE(ln_dim),nw_nd(f_i))
+      ln_dim(1:lll) = nw_dl(1:lll,f_i)
+    ENDIF
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-flioinqf"
+  ENDIF
+!----------------------
+END SUBROUTINE flioinqf
+!===
+SUBROUTINE flioinqn &
+ & (f_i,cn_dim,cn_var,cn_gat,cn_uld, &
+ &  id_start,id_count,iv_start,iv_count,ia_start,ia_count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL,INTENT(OUT) :: &
+ & cn_dim,cn_var,cn_gat
+  CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: &
+ & cn_uld
+  INTEGER,OPTIONAL,INTENT(IN) :: &
+ & id_start,id_count,iv_start,iv_count,ia_start,ia_count
+!-
+  INTEGER :: f_e,i_s,i_w,iws,iwc,i_rc
+  LOGICAL :: l_ok
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->flioinqn"
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('flioinqn',f_i,f_e)
+!-
+  IF (PRESENT(cn_dim)) THEN
+    l_ok = .TRUE.
+    i_s = SIZE(cn_dim)
+    DO i_w=1,i_s
+      cn_dim(i_w)(:) = '?'
+    ENDDO
+    IF (PRESENT(id_start)) THEN
+      iws = id_start
+    ELSE
+      iws = 1
+    ENDIF
+    IF (PRESENT(id_count)) THEN
+      iwc = id_count
+    ELSE
+      iwc = nw_nd(f_i)
+    ENDIF
+    IF (iws > nw_nd(f_i)) THEN
+      l_ok = .FALSE.
+      CALL ipslerr (2,'flioinqn', &
+ &     'The start index of requested dimensions', &
+ &     'is greater than the number of dimensions', &
+ &     'in the file')
+    ELSE IF (iws < 1) THEN
+      l_ok = .FALSE.
+      CALL ipslerr (2,'flioinqn', &
+ &     'The start index of requested dimensions', &
+ &     'is invalid', &
+ &     '( < 1 )')
+    ENDIF
+    IF ((iws+iwc-1) > nw_nd(f_i)) THEN
+      CALL ipslerr (2,'flioinqn', &
+ &     'The number of requested dimensions', &
+ &     'is greater than the number of dimensions', &
+ &     'in the file')
+    ENDIF
+    IF (iwc > i_s) THEN
+      CALL ipslerr (2,'flioinqn', &
+ &     'The number of dimensions to retrieve', &
+ &     'is greater than the size of the array,', &
+ &     'only the first dimensions of the file will be returned')
+    ELSE IF (iwc < 1) THEN
+      l_ok = .FALSE.
+      CALL ipslerr (2,'flioinqn', &
+ &     'The number of requested dimensions', &
+ &     'is invalid', &
+ &     '( < 1 )')
+    ENDIF
+    IF (l_ok) THEN
+      DO i_w=1,MIN(iwc,i_s,nw_nd(f_i)-iws+1)
+        i_rc = NF90_INQUIRE_DIMENSION(f_e,i_w+iws-1,name=cn_dim(i_w))
+      ENDDO
+    ENDIF
+  ENDIF
+!-
+  IF (PRESENT(cn_var)) THEN
+    l_ok = .TRUE.
+    i_s = SIZE(cn_var)
+    DO i_w=1,i_s
+      cn_var(i_w)(:) = '?'
+    ENDDO
+    IF (PRESENT(iv_start)) THEN
+      iws = iv_start
+    ELSE
+      iws = 1
+    ENDIF
+    IF (PRESENT(iv_count)) THEN
+      iwc = iv_count
+    ELSE
+      iwc = nw_nv(f_i)
+    ENDIF
+    IF (iws > nw_nv(f_i)) THEN
+      l_ok = .FALSE.
+      CALL ipslerr (2,'flioinqn', &
+ &     'The start index of requested variables', &
+ &     'is greater than the number of variables', &
+ &     'in the file')
+    ELSE IF (iws < 1) THEN
+      l_ok = .FALSE.
+      CALL ipslerr (2,'flioinqn', &
+ &     'The start index of requested variables', &
+ &     'is invalid', &
+ &     '( < 1 )')
+    ENDIF
+    IF ((iws+iwc-1) > nw_nv(f_i)) THEN
+      CALL ipslerr (2,'flioinqn', &
+ &     'The number of requested variables', &
+ &     'is greater than the number of variables', &
+ &     'in the file')
+    ENDIF
+    IF (iwc > i_s) THEN
+      CALL ipslerr (2,'flioinqn', &
+ &     'The number of variables to retrieve', &
+ &     'is greater than the size of the array,', &
+ &     'only the first variables of the file will be returned')
+    ELSE IF (iwc < 1) THEN
+      l_ok = .FALSE.
+      CALL ipslerr (2,'flioinqn', &
+ &     'The number of requested variables', &
+ &     'is invalid', &
+ &     '( < 1 )')
+    ENDIF
+    IF (l_ok) THEN
+      DO i_w=1,MIN(iwc,i_s,nw_nv(f_i)-iws+1)
+        i_rc = NF90_INQUIRE_VARIABLE(f_e,i_w+iws-1,name=cn_var(i_w))
+      ENDDO
+    ENDIF
+  ENDIF
+!-
+  IF (PRESENT(cn_gat)) THEN
+    l_ok = .TRUE.
+    i_s = SIZE(cn_gat)
+    DO i_w=1,i_s
+      cn_gat(i_w)(:) = '?'
+    ENDDO
+    IF (PRESENT(ia_start)) THEN
+      iws = ia_start
+    ELSE
+      iws = 1
+    ENDIF
+    IF (PRESENT(ia_count)) THEN
+      iwc = ia_count
+    ELSE
+      iwc = nw_na(f_i)
+    ENDIF
+    IF (iws > nw_na(f_i)) THEN
+      l_ok = .FALSE.
+      CALL ipslerr (2,'flioinqn', &
+ &     'The start index of requested global attributes', &
+ &     'is greater than the number of global attributes', &
+ &     'in the file')
+    ELSE IF (iws < 1) THEN
+      l_ok = .FALSE.
+      CALL ipslerr (2,'flioinqn', &
+ &     'The start index of requested global attributes', &
+ &     'is invalid', &
+ &     '( < 1 )')
+    ENDIF
+    IF ((iws+iwc-1) > nw_na(f_i)) THEN
+      CALL ipslerr (2,'flioinqn', &
+ &     'The number of requested global attributes', &
+ &     'is greater than the number of global attributes', &
+ &     'in the file')
+    ENDIF
+    IF (iwc > i_s) THEN
+      CALL ipslerr (2,'flioinqn', &
+ &     'The number of global attributes to retrieve', &
+ &     'is greater than the size of the array,', &
+ &     'only the first global attributes of the file will be returned')
+    ELSE IF (iwc < 1) THEN
+      l_ok = .FALSE.
+      CALL ipslerr (2,'flioinqn', &
+ &     'The number of requested global attributes', &
+ &     'is invalid', &
+ &     '( < 1 )')
+    ENDIF
+    IF (l_ok) THEN
+      DO i_w=1,MIN(iwc,i_s,nw_na(f_i)-iws+1)
+        i_rc = NF90_INQ_ATTNAME(f_e, &
+ &              NF90_GLOBAL,i_w+iws-1,name=cn_gat(i_w))
+      ENDDO
+    ENDIF
+  ENDIF
+!-
+  IF (PRESENT(cn_uld)) THEN
+    cn_uld = '?'
+    IF (nw_un(f_i) > 0) THEN
+      i_rc = NF90_INQUIRE_DIMENSION(f_e,nw_un(f_i),name=cn_uld)
+    ENDIF
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-flioinqn"
+  ENDIF
+!----------------------
+END SUBROUTINE flioinqn
+!===
+SUBROUTINE fliogstc &
+ & (f_i,x_axis,x_axis_2d,y_axis,y_axis_2d,z_axis, &
+ &      t_axis,t_init,t_step,t_calendar, &
+ &      x_start,x_count,y_start,y_count, &
+ &      z_start,z_count,t_start,t_count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  REAL,DIMENSION(:),OPTIONAL,INTENT(OUT)    :: x_axis,y_axis
+  REAL,DIMENSION(:,:),OPTIONAL,INTENT(OUT)  :: x_axis_2d,y_axis_2d
+  REAL,DIMENSION(:),OPTIONAL,INTENT(OUT)    :: z_axis
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(OUT) :: t_axis
+  REAL,OPTIONAL,INTENT(OUT)                 :: t_init,t_step
+  CHARACTER(LEN=*),OPTIONAL,INTENT(OUT)     :: t_calendar
+  INTEGER,OPTIONAL,INTENT(IN) :: &
+ &  x_start,x_count,y_start,y_count,z_start,z_count,t_start,t_count
+!-
+  INTEGER :: i_rc,f_e,i_v,it_t,nbdim,kv
+  INTEGER :: m_x,i_x,l_x,m_y,i_y,l_y,m_z,i_z,l_z,m_t,i_t,l_t
+  CHARACTER(LEN=NF90_MAX_NAME) :: name
+  CHARACTER(LEN=80) :: units
+  CHARACTER(LEN=20) :: c_tmp
+  CHARACTER(LEN=1) :: c_1
+  REAL    :: r_yy,r_mo,r_dd,r_ss,dtv,dtn
+  INTEGER :: j_yy,j_mo,j_dd,j_hh,j_mn,j_ss
+  LOGICAL :: l_ok,l_tmp
+!-
+  REAL,DIMENSION(:),ALLOCATABLE :: v_tmp
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->fliogstc"
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('fliogstc',f_i,f_e)
+!-
+! Validate the coherence of the arguments
+!-
+  IF (    (PRESENT(x_axis).AND.PRESENT(x_axis_2d)) &
+ &    .OR.(PRESENT(y_axis).AND.PRESENT(y_axis_2d)) ) THEN
+    CALL ipslerr (3,'fliogstc', &
+ &    'The [x/y]_axis arguments', &
+ &    'are not coherent :',&
+ &    'can not handle two [x/y]_axis')
+  ENDIF
+!-
+! Retrieve spatio-temporal dimensions
+!-
+  IF (nw_ai(k_lon,f_i) > 0) THEN
+    m_x = nw_dl(nw_ai(k_lon,f_i),f_i);
+  ELSE
+    m_x = -1;
+  ENDIF
+  IF (nw_ai(k_lat,f_i) > 0) THEN
+    m_y = nw_dl(nw_ai(k_lat,f_i),f_i);
+  ELSE
+    m_y = -1;
+  ENDIF
+  IF (nw_ai(k_lev,f_i) > 0) THEN
+    m_z = nw_dl(nw_ai(k_lev,f_i),f_i);
+  ELSE
+    m_z = -1;
+  ENDIF
+  IF (nw_ai(k_tim,f_i) > 0) THEN
+    m_t = nw_dl(nw_ai(k_tim,f_i),f_i);
+  ELSE
+    m_t = -1;
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,'("   fliogstc - dimensions :",/,(5(1X,I10),:))') &
+ &    m_x,m_y,m_z,m_t
+  ENDIF
+!-
+! Initialize the x-y indices
+!-
+  IF (    PRESENT(x_axis)    &
+ &    .OR.PRESENT(x_axis_2d) &
+ &    .OR.PRESENT(y_axis_2d) ) THEN
+    IF (PRESENT(x_start)) THEN
+      i_x = x_start
+    ELSE
+      i_x = 1
+    ENDIF
+    IF (PRESENT(x_count)) THEN
+      l_x = x_count
+    ELSE
+      l_x = m_x-i_x+1
+    ENDIF
+  ENDIF
+  IF (    PRESENT(y_axis)    &
+ &    .OR.PRESENT(y_axis_2d) &
+ &    .OR.PRESENT(x_axis_2d) ) THEN
+    IF (PRESENT(y_start)) THEN
+      i_y = y_start
+    ELSE
+      i_y = 1
+    ENDIF
+    IF (PRESENT(y_count)) THEN
+      l_y = y_count
+    ELSE
+      l_y = m_y-i_y+1
+    ENDIF
+  ENDIF
+  IF (PRESENT(x_axis)) THEN
+    IF (m_x <= 0) THEN
+      CALL ipslerr (3,'fliogstc', &
+ &      'Requested x_axis', &
+ &      'but the coordinate is not present','in the file')
+    ELSE IF ((i_x+l_x-1) > m_x) THEN
+      CALL ipslerr (3,'fliogstc', &
+ &      'The requested size for the x_axis', &
+ &      'is greater than the size of the coordinate','in the file')
+    ENDIF
+  ENDIF
+  IF (PRESENT(y_axis)) THEN
+    IF (m_y <= 0) THEN
+      CALL ipslerr (3,'fliogstc', &
+ &      'Requested y_axis', &
+ &      'but the coordinate is not present','in the file')
+    ELSE IF ((i_y+l_y-1) > m_y) THEN
+      CALL ipslerr (3,'fliogstc', &
+ &      'The requested size for the y_axis', &
+ &      'is greater than the size of the coordinate','in the file')
+    ENDIF
+  ENDIF
+  IF (PRESENT(x_axis_2d).OR.PRESENT(y_axis_2d) )THEN
+    IF ( (m_x <= 0).OR.(m_y <= 0) ) THEN
+      CALL ipslerr (3,'fliogstc', &
+ &      'Requested [x/y]_axis_2d', &
+ &      'but the coordinates are not iboth present','in the file')
+    ELSE IF ( ((i_x+l_x-1) > m_x).OR.((i_y+l_y-1) > m_y) ) THEN
+      CALL ipslerr (3,'fliogstc', &
+ &      'The requested size for the [x/y]_axis_2d', &
+ &      'is greater than the size of the coordinate','in the file')
+    ENDIF
+  ENDIF
+!-
+! Ensuring data mode
+!-
+  CALL flio_hdm (f_i,f_e,.FALSE.)
+!-
+! Extracting the x coordinate, if needed
+!-
+  IF (PRESENT(x_axis).OR.PRESENT(x_axis_2d)) THEN
+    CALL flio_qax (f_i,'x',i_v,nbdim)
+    IF (i_v > 0) THEN
+      IF      (nbdim == 1) THEN
+        IF (PRESENT(x_axis)) THEN
+          i_rc = NF90_GET_VAR(f_e,i_v,x_axis, &
+ &                 start=(/i_x/),count=(/l_x/))
+        ELSE
+          ALLOCATE(v_tmp(l_x))
+          i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, &
+ &                 start=(/i_x/),count=(/l_x/))
+          DO kv=1,l_y
+            x_axis_2d(:,kv) = v_tmp(:)
+          ENDDO
+          DEALLOCATE(v_tmp)
+        ENDIF
+      ELSE IF (nbdim == 2) THEN
+        IF (PRESENT(x_axis)) THEN
+          l_ok = .TRUE.
+          IF (l_y > 1) THEN
+            ALLOCATE(v_tmp(l_y))
+            DO kv=i_x,i_x+l_x-1
+              i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, &
+ &                     start=(/kv,i_y/),count=(/1,l_y/))
+              IF (ANY(v_tmp(2:l_y) /= v_tmp(1))) THEN
+                l_ok = .FALSE.
+                EXIT
+              ENDIF
+            ENDDO
+            DEALLOCATE(v_tmp)
+          ENDIF
+          IF (l_ok) THEN
+            i_rc = NF90_GET_VAR(f_e,i_v,x_axis, &
+ &                   start=(/i_x,i_y/),count=(/l_x,1/))
+          ELSE
+            CALL ipslerr (3,'fliogstc', &
+ &            'Requested 1D x_axis', &
+ &            'which have 2 not regular dimensions', &
+ &            'in the file')
+          ENDIF
+        ELSE
+          i_rc = NF90_GET_VAR(f_e,i_v,x_axis_2d, &
+ &                 start=(/i_x,i_y/),count=(/l_x,l_y/))
+        ENDIF
+      ELSE
+        CALL ipslerr (3,'fliogstc', &
+ &        'Can not handle x_axis', &
+ &        'that have more than 2 dimensions', &
+ &        'in the file')
+      ENDIF
+    ELSE
+      CALL ipslerr (3,'fliogstc','No x_axis found','in the file',' ')
+    ENDIF
+  ENDIF
+!-
+! Extracting the y coordinate, if needed
+!-
+  IF (PRESENT(y_axis).OR.PRESENT(y_axis_2d)) THEN
+    CALL flio_qax (f_i,'y',i_v,nbdim)
+    IF (i_v > 0) THEN
+      IF      (nbdim == 1) THEN
+        IF (PRESENT(y_axis)) THEN
+          i_rc = NF90_GET_VAR(f_e,i_v,y_axis, &
+ &                 start=(/i_y/),count=(/l_y/))
+        ELSE
+          ALLOCATE(v_tmp(l_y))
+          i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, &
+ &                 start=(/i_y/),count=(/l_y/))
+          DO kv=1,l_x
+            y_axis_2d(kv,:) = v_tmp(:)
+          ENDDO
+          DEALLOCATE(v_tmp)
+        ENDIF
+      ELSE IF (nbdim == 2) THEN
+        IF (PRESENT(y_axis)) THEN
+          l_ok = .TRUE.
+          IF (l_x > 1) THEN
+            ALLOCATE(v_tmp(l_x))
+            DO kv=i_y,i_y+l_y-1
+              i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, &
+ &                     start=(/i_x,kv/),count=(/l_x,1/))
+              IF (ANY(v_tmp(2:l_x) /= v_tmp(1))) THEN
+                l_ok = .FALSE.
+                EXIT
+              ENDIF
+            ENDDO
+            DEALLOCATE(v_tmp)
+          ENDIF
+          IF (l_ok) THEN
+            i_rc = NF90_GET_VAR(f_e,i_v,y_axis, &
+ &                   start=(/i_x,i_y/),count=(/1,l_y/))
+          ELSE
+            CALL ipslerr (3,'fliogstc', &
+ &            'Requested 1D y_axis', &
+ &            'which have 2 not regular dimensions', &
+ &            'in the file')
+          ENDIF
+        ELSE
+          i_rc = NF90_GET_VAR(f_e,i_v,y_axis_2d, &
+ &                 start=(/i_x,i_y/),count=(/l_x,l_y/))
+        ENDIF
+      ELSE
+        CALL ipslerr (3,'fliogstc', &
+ &        'Can not handle y axis', &
+ &        'that have more than 2 dimensions', &
+ &        'in the file')
+      ENDIF
+    ELSE
+      CALL ipslerr (3,'fliogstc','No y_axis found','in the file',' ')
+    ENDIF
+  ENDIF
+!-
+! Extracting the z coordinate, if needed
+!-
+  IF (PRESENT(z_axis)) THEN
+    IF (PRESENT(z_start)) THEN
+      i_z = z_start
+    ELSE
+      i_z = 1
+    ENDIF
+    IF (PRESENT(z_count)) THEN
+      l_z = z_count
+    ELSE
+      l_z = m_z-i_z+1
+    ENDIF
+    IF ((i_z+l_z-1) > m_z) THEN
+      CALL ipslerr (3,'fliogstc', &
+ &      'The requested size for the z axis', &
+ &      'is greater than the size of the coordinate',&
+ &      'in the file')
+    ENDIF
+    CALL flio_qax (f_i,'z',i_v,nbdim)
+    IF (i_v > 0) THEN
+      IF (nbdim == 1) THEN
+        i_rc = NF90_GET_VAR(f_e,i_v,z_axis, &
+ &               start=(/i_z/),count=(/l_z/))
+      ELSE
+        CALL ipslerr (3,'fliogstc', &
+ &        'Can not handle z_axis', &
+ &        'that have more than 1 dimension', &
+ &        'in the file')
+      ENDIF
+    ELSE
+      CALL ipslerr (3,'fliogstc','No z_axis found','in the file',' ')
+    ENDIF
+  ENDIF
+!-
+! Extracting the t coordinate, if needed
+!-
+  IF (PRESENT(t_axis).OR.PRESENT(t_init).OR.PRESENT(t_step)) THEN
+    CALL flio_qax (f_i,'t',i_v,nbdim)
+    IF (i_v < 0) THEN
+      CALL ipslerr (3,'fliogstc','No t_axis found','in the file',' ')
+    ENDIF
+!---
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) '  fliogstc - get time details'
+    ENDIF
+!---
+!-- Get all the details for the time
+!-- Prefered method is '"time_steps" since'
+!---
+    name=''
+    i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v,name=name)
+    units=''
+    i_rc = NF90_GET_ATT(f_e,i_v,'units',units)
+    IF      (INDEX(units,' since ') > 0) THEN
+      it_t = 1
+    ELSE IF (INDEX(name,'tstep') > 0) THEN
+      it_t = 2
+    ELSE
+      it_t = 0;
+    ENDIF
+  ENDIF
+!-
+! Extracting the t coordinate, if needed
+!-
+  IF (PRESENT(t_axis)) THEN
+    IF (PRESENT(t_start)) THEN
+      i_t = t_start
+    ELSE
+      i_t = 1
+    ENDIF
+    IF (PRESENT(t_count)) THEN
+      l_t = t_count
+    ELSE
+      l_t = m_t-i_t+1
+    ENDIF
+    IF ((i_t+l_t-1) > m_t) THEN
+      CALL ipslerr (3,'fliogstc', &
+ &      'The requested size for the t axis', &
+ &      'is greater than the size of the coordinate',&
+ &      'in the file')
+    ENDIF
+    ALLOCATE(v_tmp(l_t))
+    i_rc = NF90_GET_VAR(f_e,i_v,v_tmp, &
+ &           start=(/i_t/),count=(/l_t/))
+    t_axis(1:l_t) = NINT(v_tmp(1:l_t))
+    DEALLOCATE(v_tmp)
+!---
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) '  fliogstc - first time : ',t_axis(1:1)
+    ENDIF
+  ENDIF
+!-
+! Extracting the time at the beginning, if needed
+!-
+  IF (PRESENT(t_init)) THEN
+!-- Find the calendar
+    CALL lock_calendar (old_status=l_tmp)
+    CALL ioget_calendar (c_tmp)
+    units = ''
+    i_rc = NF90_GET_ATT(f_e,i_v,'calendar',units)
+    IF (i_rc == NF90_NOERR) THEN
+      CALL lock_calendar (new_status=.FALSE.)
+      CALL ioconf_calendar (TRIM(units))
+    ENDIF
+    IF (it_t == 1) THEN
+      units = ''
+      i_rc = NF90_GET_ATT(f_e,i_v,'units',units)
+      units = units(INDEX(units,' since ')+7:LEN_TRIM(units))
+      READ (units,'(I4.4,5(A,I2.2))') &
+ &      j_yy,c_1,j_mo,c_1,j_dd,c_1,j_hh,c_1,j_mn,c_1,j_ss
+      r_ss = j_hh*3600.+j_mn*60.+j_ss
+      CALL ymds2ju (j_yy,j_mo,j_dd,r_ss,t_init)
+    ELSE IF (it_t == 2) THEN
+      i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'year0',r_yy)
+      i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'month0',r_mo)
+      i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'day0',r_dd)
+      i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'sec0',r_ss)
+      j_yy = NINT(r_yy); j_mo = NINT(r_mo); j_dd = NINT(r_dd);
+      CALL ymds2ju (j_yy,j_mo,j_dd,r_ss,t_init)
+    ELSE
+      t_init = 0.
+    ENDIF
+    CALL lock_calendar (new_status=.FALSE.)
+    CALL ioconf_calendar (TRIM(c_tmp))
+    CALL lock_calendar (new_status=l_tmp)
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) '  fliogstc - time_type : '
+      WRITE(ipslout,*) it_t
+      WRITE(ipslout,*) '  fliogstc - year month day second t_init : '
+      WRITE(ipslout,*) j_yy,j_mo,j_dd,r_ss,t_init
+    ENDIF
+  ENDIF
+!-
+! Extracting the timestep in seconds, if needed
+!-
+  IF (PRESENT(t_step)) THEN
+    IF      (it_t == 1) THEN
+      units = ''
+      i_rc = NF90_GET_ATT(f_e,i_v,'units',units)
+      units = ADJUSTL(units(1:INDEX(units,' since ')-1))
+      dtn = 1.
+      IF      (INDEX(units,"week") /= 0) THEN
+        kv  = INDEX(units,"week")
+        dtv = 604800.
+      ELSE IF (INDEX(units,"day")  /= 0) THEN
+        kv  = INDEX(units,"day")
+        dtv = 86400.
+      ELSE IF (INDEX(units,"h")    /= 0) THEN
+        kv  = INDEX(units,"h")
+        dtv = 3600.
+      ELSE IF (INDEX(units,"min")  /= 0) THEN
+        kv  = INDEX(units,"min")
+        dtv = 60.
+      ELSE IF (INDEX(units,"sec")  /= 0) THEN
+        kv  = INDEX(units,"sec")
+        dtv = 1.
+      ELSE IF (INDEX(units,"timesteps") /= 0) THEN
+        kv  = INDEX(units,"timesteps")
+        i_rc = NF90_GET_ATT(f_e,i_v,'tstep_sec',dtv)
+        IF (i_rc /= NF90_NOERR) THEN
+          CALL ipslerr (3,'fliogstc','"timesteps" value', &
+ &                        'not found','in the file')
+        ENDIF
+      ELSE
+        kv  = 1
+        dtv = 1.
+      ENDIF
+      IF (kv > 1) THEN
+        READ (unit=units(1:kv-1),FMT=*) dtn
+      ENDIF
+      t_step = dtn*dtv
+    ELSE IF (it_t == 2) THEN
+      i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,'delta_tstep_sec',t_step)
+    ELSE
+      t_step = 1.
+    ENDIF
+  ENDIF
+!-
+! Extracting the calendar attribute, if needed
+!-
+  IF (PRESENT(t_calendar)) THEN
+    units = ''
+    i_rc = NF90_GET_ATT(f_e,i_v,'calendar',units)
+    IF (i_rc == NF90_NOERR) THEN
+      t_calendar = units
+    ELSE
+      t_calendar = "not found"
+    ENDIF
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-fliogstc"
+  ENDIF
+!----------------------
+END SUBROUTINE fliogstc
+!===
+SUBROUTINE flioinqv &
+ & (f_i,v_n,l_ex,v_t,nb_dims,len_dims,id_dims, &
+ &  nb_atts,cn_atts,ia_start,ia_count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  LOGICAL,INTENT(OUT) :: l_ex
+  INTEGER,OPTIONAL,INTENT(OUT) :: v_t,nb_dims,nb_atts
+  INTEGER,OPTIONAL,INTENT(OUT),DIMENSION(:) :: len_dims,id_dims
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL,INTENT(OUT) :: cn_atts
+  INTEGER,OPTIONAL,INTENT(IN) :: ia_start,ia_count
+!-
+  INTEGER :: f_e,i_v,n_w,i_s,i_w,iws,iwc,i_rc
+  LOGICAL :: l_ok
+  INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: dim_ids
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->flioinqv ",TRIM(v_n)
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('flioinqv',f_i,f_e)
+!-
+  i_v = -1
+  i_rc = NF90_INQ_VARID(f_e,v_n,i_v)
+!-
+  l_ex = ( (i_v >= 0).AND.(i_rc == NF90_NOERR) )
+!-
+  IF (l_ex) THEN
+    IF (PRESENT(v_t)) THEN
+      i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v,xtype=v_t)
+    ENDIF
+    n_w = -1
+    IF (PRESENT(nb_dims).OR.PRESENT(len_dims)) THEN
+      i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v, &
+ &             ndims=n_w,dimids=dim_ids)
+      IF (PRESENT(nb_dims)) THEN
+        nb_dims = n_w
+      ENDIF
+      IF (PRESENT(len_dims)) THEN
+        i_s = SIZE(len_dims)
+        len_dims(:) = -1
+        IF (i_s < n_w) THEN
+          CALL ipslerr (2,'flioinqv', &
+ &         'Only the first dimensions of the variable', &
+ &         TRIM(v_n),'will be returned')
+        ENDIF
+        DO i_w=1,MIN(n_w,i_s)
+          i_rc = NF90_INQUIRE_DIMENSION(f_e,dim_ids(i_w), &
+ &                                      len=len_dims(i_w))
+        ENDDO
+      ENDIF
+      IF (PRESENT(id_dims)) THEN
+        i_s = SIZE(id_dims)
+        id_dims(:) = -1
+        IF (i_s < n_w) THEN
+          CALL ipslerr (2,'flioinqv', &
+ &         'The number of dimensions to retrieve', &
+ &         'is greater than the size of the array,', &
+ &         'only the first dimensions of "' &
+ &           //TRIM(v_n)//'" will be returned')
+        ENDIF
+        i_w = MIN(n_w,i_s)
+        id_dims(1:i_w) = dim_ids(1:i_w)
+      ENDIF
+    ENDIF
+    IF (PRESENT(nb_atts).OR.PRESENT(cn_atts)) THEN
+      i_rc = NF90_INQUIRE_VARIABLE(f_e,i_v,nAtts=n_w)
+      IF (PRESENT(nb_atts)) THEN
+        nb_atts = n_w
+      ENDIF
+      IF (PRESENT(cn_atts)) THEN
+        l_ok = .TRUE.
+        i_s = SIZE(cn_atts)
+        DO i_w=1,i_s
+          cn_atts(i_w)(:) = '?'
+        ENDDO
+        IF (PRESENT(ia_start)) THEN
+          iws = ia_start
+        ELSE
+          iws = 1
+        ENDIF
+        IF (PRESENT(ia_count)) THEN
+          iwc = ia_count
+        ELSE
+          iwc = n_w
+        ENDIF
+        IF (iws > n_w) THEN
+          l_ok = .FALSE.
+          CALL ipslerr (2,'flioinqv', &
+ &         'The start index of requested attributes', &
+ &         'is greater than the number of attributes of', &
+ &         '"'//TRIM(v_n)//'"')
+        ELSE IF (iws < 1) THEN
+          l_ok = .FALSE.
+          CALL ipslerr (2,'flioinqv', &
+ &         'The start index of requested attributes', &
+ &         'is invalid ( < 1 ) for', &
+ &         '"'//TRIM(v_n)//'"')
+        ENDIF
+        IF ((iws+iwc-1) > n_w) THEN
+          CALL ipslerr (2,'flioinqv', &
+ &         'The number of requested attributes', &
+ &         'is greater than the number of attributes of', &
+ &         '"'//TRIM(v_n)//'"')
+        ENDIF
+        IF (iwc > i_s) THEN
+          CALL ipslerr (2,'flioinqv', &
+ &         'The number of attributes to retrieve', &
+ &         'is greater than the size of the array,', &
+ &         'only the first attributes of "' &
+ &           //TRIM(v_n)//'" will be returned')
+        ELSE IF (iwc < 1) THEN
+          l_ok = .FALSE.
+          CALL ipslerr (2,'flioinqv', &
+ &         'The number of requested attributes', &
+ &         'is invalid ( < 1 ) for', &
+ &         '"'//TRIM(v_n)//'"')
+        ENDIF
+        IF (l_ok) THEN
+          DO i_w=1,MIN(iwc,i_s,n_w-iws+1)
+            i_rc = NF90_INQ_ATTNAME(f_e, &
+ &                  i_v,i_w+iws-1,name=cn_atts(i_w))
+          ENDDO
+        ENDIF
+      ENDIF
+    ENDIF
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-flioinqv"
+  ENDIF
+!----------------------
+END SUBROUTINE flioinqv
+!===
+SUBROUTINE fliogv_i40 (f_i,v_n,v_v,start)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,i_40=v_v,start=start)
+!------------------------
+END SUBROUTINE fliogv_i40
+!===
+SUBROUTINE fliogv_i41 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),DIMENSION(:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,i_41=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_i41
+!===
+SUBROUTINE fliogv_i42 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,i_42=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_i42
+!===
+SUBROUTINE fliogv_i43 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,i_43=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_i43
+!===
+SUBROUTINE fliogv_i44 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,i_44=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_i44
+!===
+SUBROUTINE fliogv_i45 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,i_45=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_i45
+!===
+SUBROUTINE fliogv_i20 (f_i,v_n,v_v,start)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_2),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,i_20=v_v,start=start)
+!------------------------
+END SUBROUTINE fliogv_i20
+!===
+SUBROUTINE fliogv_i21 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_2),DIMENSION(:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,i_21=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_i21
+!===
+SUBROUTINE fliogv_i22 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,i_22=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_i22
+!===
+SUBROUTINE fliogv_i23 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,i_23=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_i23
+!===
+SUBROUTINE fliogv_i24 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,i_24=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_i24
+!===
+SUBROUTINE fliogv_i25 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,i_25=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_i25
+!===
+!?INTEGERS of KIND 1 are not supported on all computers
+!?SUBROUTINE fliogv_i10 (f_i,v_n,v_v,start)
+!?!---------------------------------------------------------------------
+!?  IMPLICIT NONE
+!?!-
+!?  INTEGER,INTENT(IN) :: f_i
+!?  CHARACTER(LEN=*),INTENT(IN) :: v_n
+!?  INTEGER(KIND=i_1),INTENT(OUT) :: v_v
+!?  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start
+!?!---------------------------------------------------------------------
+!?  CALL flio_ugv (f_i,v_n,i_10=v_v,start=start)
+!?!------------------------
+!?END SUBROUTINE fliogv_i10
+!?!===
+!?SUBROUTINE fliogv_i11 (f_i,v_n,v_v,start,count)
+!?!---------------------------------------------------------------------
+!?  IMPLICIT NONE
+!?!-
+!?  INTEGER,INTENT(IN) :: f_i
+!?  CHARACTER(LEN=*),INTENT(IN) :: v_n
+!?  INTEGER(KIND=i_1),DIMENSION(:),INTENT(OUT) :: v_v
+!?  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!?!---------------------------------------------------------------------
+!?  CALL flio_ugv (f_i,v_n,i_11=v_v,start=start,count=count)
+!?!------------------------
+!?END SUBROUTINE fliogv_i11
+!?!===
+!?SUBROUTINE fliogv_i12 (f_i,v_n,v_v,start,count)
+!?!---------------------------------------------------------------------
+!?  IMPLICIT NONE
+!?!-
+!?  INTEGER,INTENT(IN) :: f_i
+!?  CHARACTER(LEN=*),INTENT(IN) :: v_n
+!?  INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(OUT) :: v_v
+!?  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!?!---------------------------------------------------------------------
+!?  CALL flio_ugv (f_i,v_n,i_12=v_v,start=start,count=count)
+!?!------------------------
+!?END SUBROUTINE fliogv_i12
+!?!===
+!?SUBROUTINE fliogv_i13 (f_i,v_n,v_v,start,count)
+!?!---------------------------------------------------------------------
+!?  IMPLICIT NONE
+!?!-
+!?  INTEGER,INTENT(IN) :: f_i
+!?  CHARACTER(LEN=*),INTENT(IN) :: v_n
+!?  INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(OUT) :: v_v
+!?  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!?!---------------------------------------------------------------------
+!?  CALL flio_ugv (f_i,v_n,i_13=v_v,start=start,count=count)
+!?!------------------------
+!?END SUBROUTINE fliogv_i13
+!?!===
+!?SUBROUTINE fliogv_i14 (f_i,v_n,v_v,start,count)
+!?!---------------------------------------------------------------------
+!?  IMPLICIT NONE
+!?!-
+!?  INTEGER,INTENT(IN) :: f_i
+!?  CHARACTER(LEN=*),INTENT(IN) :: v_n
+!?  INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v
+!?  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!?!---------------------------------------------------------------------
+!?  CALL flio_ugv (f_i,v_n,i_14=v_v,start=start,count=count)
+!?!------------------------
+!?END SUBROUTINE fliogv_i14
+!?!===
+!?SUBROUTINE fliogv_i15 (f_i,v_n,v_v,start,count)
+!?!---------------------------------------------------------------------
+!?  IMPLICIT NONE
+!?!-
+!?  INTEGER,INTENT(IN) :: f_i
+!?  CHARACTER(LEN=*),INTENT(IN) :: v_n
+!?  INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v
+!?  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!?!---------------------------------------------------------------------
+!?  CALL flio_ugv (f_i,v_n,i_15=v_v,start=start,count=count)
+!?!------------------------
+!?END SUBROUTINE fliogv_i15
+!===
+SUBROUTINE fliogv_r40 (f_i,v_n,v_v,start)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_4),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,r_40=v_v,start=start)
+!------------------------
+END SUBROUTINE fliogv_r40
+!===
+SUBROUTINE fliogv_r41 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_4),DIMENSION(:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,r_41=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_r41
+!===
+SUBROUTINE fliogv_r42 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_4),DIMENSION(:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,r_42=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_r42
+!===
+SUBROUTINE fliogv_r43 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,r_43=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_r43
+!===
+SUBROUTINE fliogv_r44 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,r_44=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_r44
+!===
+SUBROUTINE fliogv_r45 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,r_45=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_r45
+!===
+SUBROUTINE fliogv_r80 (f_i,v_n,v_v,start)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_8),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,r_80=v_v,start=start)
+!------------------------
+END SUBROUTINE fliogv_r80
+!===
+SUBROUTINE fliogv_r81 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_8),DIMENSION(:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,r_81=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_r81
+!===
+SUBROUTINE fliogv_r82 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_8),DIMENSION(:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,r_82=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_r82
+!===
+SUBROUTINE fliogv_r83 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,r_83=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_r83
+!===
+SUBROUTINE fliogv_r84 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,r_84=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_r84
+!===
+SUBROUTINE fliogv_r85 (f_i,v_n,v_v,start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(OUT) :: v_v
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(IN) :: start,count
+!---------------------------------------------------------------------
+  CALL flio_ugv (f_i,v_n,r_85=v_v,start=start,count=count)
+!------------------------
+END SUBROUTINE fliogv_r85
+!===
+SUBROUTINE flio_ugv &
+ & (f_i,v_n, &
+ &  i_40,i_41,i_42,i_43,i_44,i_45, &
+ &  i_20,i_21,i_22,i_23,i_24,i_25, &
+!? &  i_10,i_11,i_12,i_13,i_14,i_15, &
+ &  r_40,r_41,r_42,r_43,r_44,r_45, &
+ &  r_80,r_81,r_82,r_83,r_84,r_85, &
+ &  start,count)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n
+  INTEGER(KIND=i_4),INTENT(OUT),OPTIONAL :: i_40
+  INTEGER(KIND=i_4),DIMENSION(:),INTENT(OUT),OPTIONAL :: i_41
+  INTEGER(KIND=i_4),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: i_42
+  INTEGER(KIND=i_4),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: i_43
+  INTEGER(KIND=i_4),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: i_44
+  INTEGER(KIND=i_4),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: i_45
+  INTEGER(KIND=i_2),INTENT(OUT),OPTIONAL :: i_20
+  INTEGER(KIND=i_2),DIMENSION(:),INTENT(OUT),OPTIONAL :: i_21
+  INTEGER(KIND=i_2),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: i_22
+  INTEGER(KIND=i_2),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: i_23
+  INTEGER(KIND=i_2),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: i_24
+  INTEGER(KIND=i_2),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: i_25
+!?INTEGERS of KIND 1 are not supported on all computers
+!?INTEGER(KIND=i_1),INTENT(OUT),OPTIONAL :: i_10
+!?INTEGER(KIND=i_1),DIMENSION(:),INTENT(OUT),OPTIONAL :: i_11
+!?INTEGER(KIND=i_1),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: i_12
+!?INTEGER(KIND=i_1),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: i_13
+!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: i_14
+!?INTEGER(KIND=i_1),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: i_15
+  REAL(KIND=r_4),INTENT(OUT),OPTIONAL :: r_40
+  REAL(KIND=r_4),DIMENSION(:),INTENT(OUT),OPTIONAL :: r_41
+  REAL(KIND=r_4),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: r_42
+  REAL(KIND=r_4),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: r_43
+  REAL(KIND=r_4),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: r_44
+  REAL(KIND=r_4),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: r_45
+  REAL(KIND=r_8),INTENT(OUT),OPTIONAL :: r_80
+  REAL(KIND=r_8),DIMENSION(:),INTENT(OUT),OPTIONAL :: r_81
+  REAL(KIND=r_8),DIMENSION(:,:),INTENT(OUT),OPTIONAL :: r_82
+  REAL(KIND=r_8),DIMENSION(:,:,:),INTENT(OUT),OPTIONAL :: r_83
+  REAL(KIND=r_8),DIMENSION(:,:,:,:),INTENT(OUT),OPTIONAL :: r_84
+  REAL(KIND=r_8),DIMENSION(:,:,:,:,:),INTENT(OUT),OPTIONAL :: r_85
+  INTEGER,DIMENSION(:),INTENT(IN),OPTIONAL :: start,count
+!-
+  INTEGER :: f_e,i_v,i_rc
+  CHARACTER(LEN=5) :: cvr_d
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    IF      (PRESENT(i_40)) THEN; cvr_d = "I1 0D";
+    ELSE IF (PRESENT(i_41)) THEN; cvr_d = "I1 1D";
+    ELSE IF (PRESENT(i_42)) THEN; cvr_d = "I1 2D";
+    ELSE IF (PRESENT(i_43)) THEN; cvr_d = "I1 3D";
+    ELSE IF (PRESENT(i_44)) THEN; cvr_d = "I1 4D";
+    ELSE IF (PRESENT(i_45)) THEN; cvr_d = "I1 5D";
+    ELSE IF (PRESENT(i_20)) THEN; cvr_d = "I2 0D";
+    ELSE IF (PRESENT(i_21)) THEN; cvr_d = "I2 1D";
+    ELSE IF (PRESENT(i_22)) THEN; cvr_d = "I2 2D";
+    ELSE IF (PRESENT(i_23)) THEN; cvr_d = "I2 3D";
+    ELSE IF (PRESENT(i_24)) THEN; cvr_d = "I2 4D";
+    ELSE IF (PRESENT(i_25)) THEN; cvr_d = "I2 5D";
+!?  ELSE IF (PRESENT(i_10)) THEN; cvr_d = "I4 0D";
+!?  ELSE IF (PRESENT(i_11)) THEN; cvr_d = "I4 1D";
+!?  ELSE IF (PRESENT(i_12)) THEN; cvr_d = "I4 2D";
+!?  ELSE IF (PRESENT(i_13)) THEN; cvr_d = "I4 3D";
+!?  ELSE IF (PRESENT(i_14)) THEN; cvr_d = "I4 4D";
+!?  ELSE IF (PRESENT(i_15)) THEN; cvr_d = "I4 5D";
+    ELSE IF (PRESENT(r_40)) THEN; cvr_d = "R4 0D";
+    ELSE IF (PRESENT(r_41)) THEN; cvr_d = "R4 1D";
+    ELSE IF (PRESENT(r_42)) THEN; cvr_d = "R4 2D";
+    ELSE IF (PRESENT(r_43)) THEN; cvr_d = "R4 3D";
+    ELSE IF (PRESENT(r_44)) THEN; cvr_d = "R4 4D";
+    ELSE IF (PRESENT(r_45)) THEN; cvr_d = "R4 5D";
+    ELSE IF (PRESENT(r_80)) THEN; cvr_d = "R8 0D";
+    ELSE IF (PRESENT(r_81)) THEN; cvr_d = "R8 1D";
+    ELSE IF (PRESENT(r_82)) THEN; cvr_d = "R8 2D";
+    ELSE IF (PRESENT(r_83)) THEN; cvr_d = "R8 3D";
+    ELSE IF (PRESENT(r_84)) THEN; cvr_d = "R8 4D";
+    ELSE IF (PRESENT(r_85)) THEN; cvr_d = "R8 5D";
+    ENDIF
+    WRITE(ipslout,*) "->fliogetv ",TRIM(v_n)," ",TRIM(cvr_d)
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('fliogetv',f_i,f_e)
+!-
+! Ensuring data mode
+!-
+  CALL flio_hdm (f_i,f_e,.FALSE.)
+!-
+  i_rc = NF90_INQ_VARID(f_e,v_n,i_v)
+  IF (i_rc == NF90_NOERR) THEN
+    IF      (PRESENT(i_40)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,i_40,start=start)
+    ELSE IF (PRESENT(i_41)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,i_41,start=start,count=count)
+    ELSE IF (PRESENT(i_42)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,i_42,start=start,count=count)
+    ELSE IF (PRESENT(i_43)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,i_43,start=start,count=count)
+    ELSE IF (PRESENT(i_44)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,i_44,start=start,count=count)
+    ELSE IF (PRESENT(i_45)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,i_45,start=start,count=count)
+    ELSE IF (PRESENT(i_20)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,i_20,start=start)
+    ELSE IF (PRESENT(i_21)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,i_21,start=start,count=count)
+    ELSE IF (PRESENT(i_22)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,i_22,start=start,count=count)
+    ELSE IF (PRESENT(i_23)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,i_23,start=start,count=count)
+    ELSE IF (PRESENT(i_24)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,i_24,start=start,count=count)
+    ELSE IF (PRESENT(i_25)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,i_25,start=start,count=count)
+!?  ELSE IF (PRESENT(i_10)) THEN
+!?    i_rc = NF90_GET_VAR(f_e,i_v,i_10,start=start)
+!?  ELSE IF (PRESENT(i_11)) THEN
+!?    i_rc = NF90_GET_VAR(f_e,i_v,i_11,start=start,count=count)
+!?  ELSE IF (PRESENT(i_12)) THEN
+!?    i_rc = NF90_GET_VAR(f_e,i_v,i_12,start=start,count=count)
+!?  ELSE IF (PRESENT(i_13)) THEN
+!?    i_rc = NF90_GET_VAR(f_e,i_v,i_13,start=start,count=count)
+!?  ELSE IF (PRESENT(i_14)) THEN
+!?    i_rc = NF90_GET_VAR(f_e,i_v,i_14,start=start,count=count)
+!?  ELSE IF (PRESENT(i_15)) THEN
+!?    i_rc = NF90_GET_VAR(f_e,i_v,i_15,start=start,count=count)
+    ELSE IF (PRESENT(r_40)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,r_40,start=start)
+    ELSE IF (PRESENT(r_41)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,r_41,start=start,count=count)
+    ELSE IF (PRESENT(r_42)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,r_42,start=start,count=count)
+    ELSE IF (PRESENT(r_43)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,r_43,start=start,count=count)
+    ELSE IF (PRESENT(r_44)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,r_44,start=start,count=count)
+    ELSE IF (PRESENT(r_45)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,r_45,start=start,count=count)
+    ELSE IF (PRESENT(r_80)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,r_80,start=start)
+    ELSE IF (PRESENT(r_81)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,r_81,start=start,count=count)
+    ELSE IF (PRESENT(r_82)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,r_82,start=start,count=count)
+    ELSE IF (PRESENT(r_83)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,r_83,start=start,count=count)
+    ELSE IF (PRESENT(r_84)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,r_84,start=start,count=count)
+    ELSE IF (PRESENT(r_85)) THEN
+      i_rc = NF90_GET_VAR(f_e,i_v,r_85,start=start,count=count)
+    ENDIF
+    IF (i_rc /= NF90_NOERR) THEN
+      CALL ipslerr (3,'fliogetv', &
+ &      'Variable '//TRIM(v_n)//' not get','Error :', &
+ &      TRIM(NF90_STRERROR(i_rc)))
+    ENDIF
+  ELSE
+    CALL ipslerr (3,'fliogetv','Variable',TRIM(v_n),'not found')
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-fliogetv"
+  ENDIF
+!----------------------
+END SUBROUTINE flio_ugv
+!===
+SUBROUTINE flioinqa (f_i,v_n,a_n,l_ex,a_t,a_l)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  LOGICAL,INTENT(OUT) :: l_ex
+  INTEGER,OPTIONAL,INTENT(OUT) :: a_t,a_l
+!-
+  INTEGER :: i_rc,f_e,i_v,t_ea,l_ea
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->flioinqa ",TRIM(v_n),"-",TRIM(a_n)
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('flioinqa',f_i,f_e)
+!-
+  IF (TRIM(v_n) == '?') THEN
+    i_v = NF90_GLOBAL
+  ELSE
+    i_rc = NF90_INQ_VARID(f_e,v_n,i_v)
+    IF (i_rc /= NF90_NOERR) THEN
+      CALL ipslerr (3,'flioinqa', &
+       'Variable :',TRIM(v_n),'not found')
+    ENDIF
+  ENDIF
+!-
+  i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,xtype=t_ea,len=l_ea)
+!-
+  l_ex = (i_rc == NF90_NOERR)
+!-
+  IF (l_ex) THEN
+    IF (PRESENT(a_t)) THEN
+      a_t = t_ea
+    ENDIF
+    IF (PRESENT(a_l)) THEN
+      a_l = l_ea
+    ENDIF
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-flioinqa"
+  ENDIF
+!----------------------
+END SUBROUTINE flioinqa
+!===
+SUBROUTINE flioga_r4_0d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  REAL(KIND=4),INTENT(OUT) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_uga (f_i,v_n,a_n,avr_4_0=a_v)
+!---------------------------
+END SUBROUTINE flioga_r4_0d
+!===
+SUBROUTINE flioga_r4_1d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  REAL(KIND=4),DIMENSION(:),INTENT(OUT) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_uga (f_i,v_n,a_n,avr_4_1=a_v)
+!--------------------------
+END SUBROUTINE flioga_r4_1d
+!===
+SUBROUTINE flioga_r8_0d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  REAL(KIND=8),INTENT(OUT) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_uga (f_i,v_n,a_n,avr_8_0=a_v)
+!---------------------------
+END SUBROUTINE flioga_r8_0d
+!===
+SUBROUTINE flioga_r8_1d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  REAL(KIND=8),DIMENSION(:),INTENT(OUT) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_uga (f_i,v_n,a_n,avr_8_1=a_v)
+!--------------------------
+END SUBROUTINE flioga_r8_1d
+!===
+SUBROUTINE flioga_i4_0d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  INTEGER(KIND=4),INTENT(OUT) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_uga (f_i,v_n,a_n,avi_4_0=a_v)
+!---------------------------
+END SUBROUTINE flioga_i4_0d
+!===
+SUBROUTINE flioga_i4_1d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  INTEGER(KIND=4),DIMENSION(:),INTENT(OUT) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_uga (f_i,v_n,a_n,avi_4_1=a_v)
+!--------------------------
+END SUBROUTINE flioga_i4_1d
+!===
+SUBROUTINE flioga_tx_0d (f_i,v_n,a_n,a_v)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  CHARACTER(LEN=*),INTENT(OUT) :: a_v
+!---------------------------------------------------------------------
+  CALL flio_uga (f_i,v_n,a_n,avtx=a_v)
+!---------------------------
+END SUBROUTINE flioga_tx_0d
+!===
+SUBROUTINE flio_uga &
+ & (f_i,v_n,a_n, &
+ &  avr_4_0,avr_4_1,avr_8_0,avr_8_1,avi_4_0,avi_4_1,avtx)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+  REAL(KIND=4),OPTIONAL,INTENT(OUT) :: avr_4_0
+  REAL(KIND=4),DIMENSION(:),OPTIONAL,INTENT(OUT) :: avr_4_1
+  REAL(KIND=8),OPTIONAL,INTENT(OUT) :: avr_8_0
+  REAL(KIND=8),DIMENSION(:),OPTIONAL,INTENT(OUT) :: avr_8_1
+  INTEGER(KIND=4),OPTIONAL,INTENT(OUT) :: avi_4_0
+  INTEGER(KIND=4),DIMENSION(:),OPTIONAL,INTENT(OUT) :: avi_4_1
+  CHARACTER(LEN=*),OPTIONAL,INTENT(OUT) :: avtx
+!-
+  INTEGER :: f_e,l_ua,i_v,t_ea,l_ea,i_rc
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->fliogeta ",TRIM(v_n)," ",TRIM(a_n)
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('fliogeta',f_i,f_e)
+!-
+  IF (TRIM(v_n) == '?') THEN
+    i_v = NF90_GLOBAL
+  ELSE
+    i_rc = NF90_INQ_VARID(f_e,v_n,i_v)
+    IF (i_rc /= NF90_NOERR) THEN
+      CALL ipslerr (3,'fliogeta', &
+       'Variable :',TRIM(v_n),'not found')
+    ENDIF
+  ENDIF
+!-
+  i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,xtype=t_ea,len=l_ea)
+  IF (i_rc /= NF90_NOERR) THEN
+    CALL ipslerr (3,'fliogeta', &
+ &   'Attribute :',TRIM(a_n),'not found')
+  ENDIF
+!-
+  IF ( (.NOT.PRESENT(avtx).AND.(t_ea == NF90_CHAR)) &
+ &      .OR.(PRESENT(avtx).AND.(t_ea /= NF90_CHAR)) ) THEN
+    CALL ipslerr (3,'fliogeta', &
+ &   'The external type of the attribute :',TRIM(a_n), &
+ &   'is not compatible with the type of the argument')
+  ENDIF
+!-
+  IF      (PRESENT(avr_4_1)) THEN
+    l_ua = SIZE(avr_4_1)
+  ELSE IF (PRESENT(avr_8_1)) THEN
+    l_ua = SIZE(avr_8_1)
+  ELSE IF (PRESENT(avi_4_1)) THEN
+    l_ua = SIZE(avi_4_1)
+  ELSE IF (PRESENT(avtx)) THEN
+    l_ua = LEN(avtx)
+  ELSE
+    l_ua = 1
+  ENDIF
+!-
+  IF (l_ua < l_ea) THEN
+    CALL ipslerr (3,'fliogeta', &
+     'Insufficient size of the argument', &
+ &   'to receive the values of the attribute :',TRIM(a_n))
+  ENDIF
+!-
+  IF      (PRESENT(avr_4_0)) THEN
+    i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_4_0)
+  ELSE IF (PRESENT(avr_4_1)) THEN
+    i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_4_1(1:l_ea))
+  ELSE IF (PRESENT(avr_8_0)) THEN
+    i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_8_0)
+  ELSE IF (PRESENT(avr_8_1)) THEN
+    i_rc = NF90_GET_ATT(f_e,i_v,a_n,avr_8_1(1:l_ea))
+  ELSE IF (PRESENT(avi_4_0)) THEN
+    i_rc = NF90_GET_ATT(f_e,i_v,a_n,avi_4_0)
+  ELSE IF (PRESENT(avi_4_1)) THEN
+    i_rc = NF90_GET_ATT(f_e,i_v,a_n,avi_4_1(1:l_ea))
+  ELSE IF (PRESENT(avtx)) THEN
+    i_rc = NF90_GET_ATT(f_e,i_v,a_n,avtx)
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-fliogeta"
+  ENDIF
+!----------------------
+END SUBROUTINE flio_uga
+!===
+SUBROUTINE fliorenv (f_i,v_o_n,v_n_n)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_o_n,v_n_n
+!-
+  INTEGER :: f_e,i_v,i_rc
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) &
+ &    "->fliorenv ",TRIM(v_o_n),"->",TRIM(v_n_n)
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('fliorenv',f_i,f_e)
+!-
+  i_rc = NF90_INQ_VARID(f_e,v_o_n,i_v)
+  IF (i_rc /= NF90_NOERR) THEN
+    CALL ipslerr (2,'fliorenv', &
+     'Variable :',TRIM(v_o_n),'not found')
+  ELSE
+    CALL flio_hdm (f_i,f_e,.TRUE.)
+    i_rc = NF90_RENAME_VAR(f_e,i_v,v_n_n)
+    IF (i_rc /= NF90_NOERR) THEN
+      CALL ipslerr (2,'fliorenv', &
+       'Variable :',TRIM(v_o_n),'can not be renamed')
+    ENDIF
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-fliorenv"
+  ENDIF
+!----------------------
+END SUBROUTINE fliorenv
+!===
+SUBROUTINE fliorena (f_i,v_n,a_o_n,a_n_n)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_o_n,a_n_n
+!-
+  INTEGER :: f_e,i_v,i_a,i_rc
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) &
+ &    "->fliorena ",TRIM(v_n),"-",TRIM(a_o_n),"->",TRIM(a_n_n)
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('fliorena',f_i,f_e)
+!-
+  IF (TRIM(v_n) == '?') THEN
+    i_v = NF90_GLOBAL
+  ELSE
+    i_rc = NF90_INQ_VARID(f_e,v_n,i_v)
+    IF (i_rc /= NF90_NOERR) THEN
+      CALL ipslerr (3,'fliorena', &
+       'Variable :',TRIM(v_n),'not found')
+    ENDIF
+  ENDIF
+!-
+  i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_o_n,attnum=i_a)
+  IF (i_rc /= NF90_NOERR) THEN
+    CALL ipslerr (2,'fliorena', &
+     'Attribute :',TRIM(a_o_n),'not found')
+  ELSE
+    CALL flio_hdm (f_i,f_e,.TRUE.)
+    i_rc = NF90_RENAME_ATT(f_e,i_v,a_o_n,a_n_n)
+    IF (i_rc /= NF90_NOERR) THEN
+      CALL ipslerr (2,'fliorena', &
+       'Attribute :',TRIM(a_o_n),'can not be renamed')
+    ENDIF
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-fliorena"
+  ENDIF
+!----------------------
+END SUBROUTINE fliorena
+!===
+SUBROUTINE fliodela (f_i,v_n,a_n)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: v_n,a_n
+!-
+  INTEGER :: f_e,i_v,i_a,i_rc
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->fliodela ",TRIM(v_n),"-",TRIM(a_n)
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('fliodela',f_i,f_e)
+!-
+  IF (TRIM(v_n) == '?') THEN
+    i_v = NF90_GLOBAL
+  ELSE
+    i_rc = NF90_INQ_VARID(f_e,v_n,i_v)
+    IF (i_rc /= NF90_NOERR) THEN
+      CALL ipslerr (3,'fliodela', &
+ &     'Variable :',TRIM(v_n),'not found')
+    ENDIF
+  ENDIF
+!-
+  i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_v,a_n,attnum=i_a)
+  IF (i_rc /= NF90_NOERR) THEN
+    CALL ipslerr (2,'fliodela', &
+ &   'Attribute :',TRIM(a_n),'not found')
+  ELSE
+    IF (i_v == NF90_GLOBAL) THEN
+      nw_na(f_i) = nw_na(f_i)-1
+    ENDIF
+    CALL flio_hdm (f_i,f_e,.TRUE.)
+    i_rc = NF90_DEL_ATT(f_e,i_v,a_n)
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-fliodela"
+  ENDIF
+!----------------------
+END SUBROUTINE fliodela
+!===
+SUBROUTINE fliocpya (f_i_i,v_n_i,a_n,f_i_o,v_n_o)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i_i,f_i_o
+  CHARACTER(LEN=*),INTENT(IN) :: v_n_i,a_n,v_n_o
+!-
+  INTEGER :: f_e_i,f_e_o,i_v_i,i_v_o,i_a,i_rc
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->fliocpya - file",f_i_i,"-",TRIM(v_n_i),"-",TRIM(a_n)
+    WRITE(ipslout,*) "  copied to file ",f_i_o,"-",TRIM(v_n_o)
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('fliocpya',f_i_i,f_e_i)
+  CALL flio_qvid ('fliocpya',f_i_o,f_e_o)
+!-
+  IF (TRIM(v_n_i) == '?') THEN
+    i_v_i = NF90_GLOBAL
+  ELSE
+    i_rc = NF90_INQ_VARID(f_e_i,v_n_i,i_v_i)
+    IF (i_rc /= NF90_NOERR) THEN
+      CALL ipslerr (3,'fliocpya', &
+ &     'Variable :',TRIM(v_n_i),'not found')
+    ENDIF
+  ENDIF
+!-
+  IF (TRIM(v_n_o) == '?') THEN
+    i_v_o = NF90_GLOBAL
+  ELSE
+    i_rc = NF90_INQ_VARID(f_e_o,v_n_o,i_v_o)
+    IF (i_rc /= NF90_NOERR) THEN
+      CALL ipslerr (3,'fliocpya', &
+ &     'Variable :',TRIM(v_n_o),'not found')
+    ENDIF
+  ENDIF
+!-
+  i_rc = NF90_INQUIRE_ATTRIBUTE(f_e_i,i_v_i,a_n,attnum=i_a)
+  IF (i_rc /= NF90_NOERR) THEN
+    CALL ipslerr (3,'fliocpya', &
+     'Attribute :',TRIM(a_n),'not found')
+  ELSE
+    i_rc = NF90_INQUIRE_ATTRIBUTE(f_e_o,i_v_o,a_n,attnum=i_a)
+    IF ( (i_v_o == NF90_GLOBAL).AND.(i_rc /= NF90_NOERR) ) THEN
+      nw_na(f_i_o) = nw_na(f_i_o)+1
+    ENDIF
+    CALL flio_hdm (f_i_o,f_e_o,.TRUE.)
+    i_rc = NF90_COPY_ATT(f_e_i,i_v_i,a_n,f_e_o,i_v_o)
+    IF (i_rc /= NF90_NOERR) THEN
+      CALL ipslerr (3,'fliocpya', &
+ &      'Attribute '//TRIM(a_n)//' not copied','Error :', &
+ &      TRIM(NF90_STRERROR(i_rc)))
+    ENDIF
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-fliocpya"
+  ENDIF
+!----------------------
+END SUBROUTINE fliocpya
+!===
+SUBROUTINE flioqstc (f_i,c_type,l_ex,c_name)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i
+  CHARACTER(LEN=*),INTENT(IN) :: c_type
+  LOGICAL,INTENT(OUT) :: l_ex
+  CHARACTER(LEN=*),INTENT(OUT) :: c_name
+!-
+  CHARACTER(LEN=1) :: c_ax
+  INTEGER :: f_e,idc,ndc,i_rc
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->flioqstc ",TRIM(c_type)
+  ENDIF
+!-
+! Retrieve the external file index
+  CALL flio_qvid ('flioqstc',f_i,f_e)
+!-
+  c_ax = TRIM(c_type)
+  IF (    (LEN_TRIM(c_type) == 1) &
+ &    .AND.(    (c_ax == 'x').OR.(c_ax == 'y') &
+ &          .OR.(c_ax == 'z').OR.(c_ax == 't')) ) THEN
+    CALL flio_qax (f_i,c_ax,idc,ndc)
+    l_ex = (idc > 0)
+    IF (l_ex) THEN
+      i_rc = NF90_INQUIRE_VARIABLE(f_e,idc,name=c_name)
+    ENDIF
+  ELSE
+    l_ex = .FALSE.
+    CALL ipslerr (2,'flioqstc', &
+ &   'The name of the coordinate,',TRIM(c_type),'is not valid')
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-flioqstc"
+  ENDIF
+!----------------------
+END SUBROUTINE flioqstc
+!===
+SUBROUTINE fliosync (f_i)
+!---------------------------------------------------------------------
+  INTEGER,INTENT(in),OPTIONAL :: f_i
+!-
+  INTEGER :: i_f,f_e,i_rc,i_s,i_e
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->fliosync"
+  ENDIF
+!-
+  IF (PRESENT(f_i)) THEN
+    IF ( (f_i >= 1).AND.(f_i <= nb_fi_mx) ) THEN
+      i_s = f_i
+      i_e = f_i
+    ELSE
+      i_s = 1
+      i_e = 0
+      CALL ipslerr (2,'fliosync', &
+ &     'Invalid file identifier',' ',' ')
+    ENDIF
+  ELSE
+    i_s = 1
+    i_e = nb_fi_mx
+  ENDIF
+!-
+! Ensuring data mode
+!-
+  CALL flio_hdm (f_i,f_e,.FALSE.)
+!-
+  DO i_f=i_s,i_e
+    f_e = nw_id(i_f)
+    IF (f_e > 0) THEN
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) '  fliosync - synchronising file number ',i_f
+      ENDIF
+      i_rc = NF90_SYNC(f_e)
+    ELSE IF (PRESENT(f_i)) THEN
+      CALL ipslerr (2,'fliosync', &
+ &     'Unable to synchronise the file :','probably','not opened')
+    ENDIF
+  ENDDO
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-fliosync"
+  ENDIF
+!----------------------
+END SUBROUTINE fliosync
+!===
+SUBROUTINE flioclo (f_i)
+!---------------------------------------------------------------------
+  INTEGER,INTENT(in),OPTIONAL :: f_i
+!-
+  INTEGER :: i_f,f_e,i_rc,i_s,i_e
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->flioclo"
+  ENDIF
+!-
+  IF (PRESENT(f_i)) THEN
+    IF ( (f_i >= 1).AND.(f_i <= nb_fi_mx) ) THEN
+      i_s = f_i
+      i_e = f_i
+    ELSE
+      i_s = 1
+      i_e = 0
+      CALL ipslerr (2,'flioclo', &
+ &     'Invalid file identifier',' ',' ')
+    ENDIF
+  ELSE
+    i_s = 1
+    i_e = nb_fi_mx
+  ENDIF
+!-
+  DO i_f=i_s,i_e
+    f_e = nw_id(i_f)
+    IF (f_e > 0) THEN
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) '  flioclo - closing file number ',i_f
+      ENDIF
+      i_rc = NF90_CLOSE(f_e)
+      nw_id(i_f) = -1
+    ELSE IF (PRESENT(f_i)) THEN
+      CALL ipslerr (2,'flioclo', &
+ &     'Unable to close the file :','probably','not opened')
+    ENDIF
+  ENDDO
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-flioclo"
+  ENDIF
+!---------------------
+END SUBROUTINE flioclo
+!===
+SUBROUTINE fliodmpf (f_n)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(IN) :: f_n
+!-
+  INTEGER :: f_e,n_dims,n_vars,n_atts,i_unlm
+  INTEGER :: i_rc,i_n,k_n,t_ea,l_ea
+  INTEGER :: tmp_i
+  REAL    :: tmp_r
+  INTEGER,DIMENSION(:),ALLOCATABLE :: tma_i
+  REAL,DIMENSION(:),ALLOCATABLE    :: tma_r
+  CHARACTER(LEN=256) :: tmp_c
+  INTEGER,DIMENSION(nb_fd_mx) :: n_idim,n_ldim
+  INTEGER,DIMENSION(nb_ax_mx) :: n_ai
+  CHARACTER(LEN=NF90_MAX_NAME),DIMENSION(nb_fd_mx) :: c_ndim
+  INTEGER,DIMENSION(NF90_MAX_VAR_DIMS) :: idimid
+  CHARACTER(LEN=NF90_MAX_NAME) :: c_name
+!---------------------------------------------------------------------
+  i_rc = NF90_OPEN(TRIM(f_n),NF90_NOWRITE,f_e)
+  IF (i_rc /= NF90_NOERR) THEN
+    CALL ipslerr (3,'fliodmpf', &
+ &   'Could not open file :',TRIM(f_n), &
+ &   TRIM(NF90_STRERROR(i_rc))//' (Netcdf)')
+  ENDIF
+!-
+  WRITE (ipslout,*) "---"
+  WRITE (ipslout,*) "--- File '",TRIM(f_n),"'"
+  WRITE (ipslout,*) "---"
+!-
+  CALL flio_inf &
+ &  (f_e,nb_dims=n_dims,nb_vars=n_vars, &
+ &       nb_atts=n_atts,id_unlm=i_unlm, &
+ &       nn_idm=n_idim,nn_ldm=n_ldim,cc_ndm=c_ndim,nn_aid=n_ai)
+!-
+  WRITE (ipslout,*) 'External model identifier   : ',f_e
+  WRITE (ipslout,*) 'Number of dimensions        : ',n_dims
+  WRITE (ipslout,*) 'Number of variables         : ',n_vars
+  WRITE (ipslout,*) 'ID unlimited                : ',i_unlm
+!-
+  WRITE (ipslout,*) "---"
+  WRITE (ipslout,*) 'Presumed axis dimensions identifiers :'
+  IF (n_ai(k_lon) > 0) THEN
+    WRITE (ipslout,*) 'x axis : ',n_ai(k_lon)
+  ELSE
+    WRITE (ipslout,*) 'x axis : NONE'
+  ENDIF
+  IF (n_ai(k_lat) > 0) THEN
+    WRITE (ipslout,*) 'y axis : ',n_ai(k_lat)
+  ELSE
+    WRITE (ipslout,*) 'y axis : NONE'
+  ENDIF
+  IF (n_ai(k_lev) > 0) THEN
+    WRITE (ipslout,*) 'z axis : ',n_ai(k_lev)
+  ELSE
+    WRITE (ipslout,*) 'z axis : NONE'
+  ENDIF
+  IF (n_ai(k_tim) > 0) THEN
+    WRITE (ipslout,*) 't axis : ',n_ai(k_tim)
+  ELSE
+    WRITE (ipslout,*) 't axis : NONE'
+  ENDIF
+!-
+  WRITE (ipslout,*) "---"
+  WRITE (ipslout,*) 'Number of global attributes : ',n_atts
+  DO k_n=1,n_atts
+    i_rc = NF90_INQ_ATTNAME(f_e,NF90_GLOBAL,k_n,c_name)
+    i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,NF90_GLOBAL,c_name, &
+ &                                xtype=t_ea,len=l_ea)
+    IF      (    (t_ea == NF90_INT4).OR.(t_ea == NF90_INT2) &
+             .OR.(t_ea == NF90_INT1) ) THEN
+      IF (l_ea > 1) THEN
+        ALLOCATE(tma_i(l_ea))
+        i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tma_i)
+        WRITE (ipslout,'("    ",A," :",/,(5(1X,I10),:))') &
+ &        TRIM(c_name),tma_i(1:l_ea)
+        DEALLOCATE(tma_i)
+      ELSE
+        i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tmp_i)
+        WRITE(ipslout,*) '   ',TRIM(c_name),' : ',tmp_i
+      ENDIF
+    ELSE IF ( (t_ea == NF90_REAL4).OR.(t_ea == NF90_REAL8) ) THEN
+      IF (l_ea > 1) THEN
+        ALLOCATE(tma_r(l_ea))
+        i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tma_r)
+        WRITE (ipslout,'("    ",A," :",/,(5(1X,1PE11.3),:))') &
+ &        TRIM(c_name),tma_r(1:l_ea)
+        DEALLOCATE(tma_r)
+      ELSE
+        i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tmp_r)
+        WRITE(ipslout,*) '   ',TRIM(c_name),' : ',tmp_r
+      ENDIF
+    ELSE
+      tmp_c = ''
+      i_rc = NF90_GET_ATT(f_e,NF90_GLOBAL,c_name,tmp_c)
+      WRITE(ipslout,*) '   ',TRIM(c_name),' : "',TRIM(tmp_c),'"'
+    ENDIF
+  ENDDO
+!-
+  DO i_n=1,nb_fd_mx
+    IF (n_idim(i_n) > 0) THEN
+      WRITE (ipslout,*) "---"
+      WRITE (ipslout,*) 'Dimension id   : ',n_idim(i_n)
+      WRITE (ipslout,*) 'Dimension name : ',TRIM(c_ndim(i_n))
+      WRITE (ipslout,*) 'Dimension size : ',n_ldim(i_n)
+    ENDIF
+  ENDDO
+!-
+  DO i_n=1,n_vars
+    i_rc = NF90_INQUIRE_VARIABLE(f_e,i_n, &
+ &           name=c_name,ndims=n_dims,dimids=idimid,nAtts=n_atts)
+    WRITE (ipslout,*) "---"
+    WRITE (ipslout,*) "Variable name        : ",TRIM(c_name)
+    WRITE (ipslout,*) "Variable identifier  : ",i_n
+    WRITE (ipslout,*) "Number of dimensions : ",n_dims
+    IF (n_dims > 0) THEN
+      WRITE (ipslout,*) "Dimensions ID's      : ",idimid(1:n_dims)
+    ENDIF
+    WRITE (ipslout,*) "Number of attributes : ",n_atts
+    DO k_n=1,n_atts
+      i_rc = NF90_INQ_ATTNAME(f_e,i_n,k_n,c_name)
+      i_rc = NF90_INQUIRE_ATTRIBUTE(f_e,i_n,c_name, &
+ &                                  xtype=t_ea,len=l_ea)
+      IF      (    (t_ea == NF90_INT4).OR.(t_ea == NF90_INT2) &
+ &             .OR.(t_ea == NF90_INT1) ) THEN
+        IF (l_ea > 1) THEN
+          ALLOCATE(tma_i(l_ea))
+          i_rc = NF90_GET_ATT(f_e,i_n,c_name,tma_i)
+          WRITE (ipslout,'("    ",A," :",/,(5(1X,I10),:))') &
+ &              TRIM(c_name),tma_i(1:l_ea)
+          DEALLOCATE(tma_i)
+        ELSE
+          i_rc = NF90_GET_ATT(f_e,i_n,c_name,tmp_i)
+          WRITE(ipslout,*) '   ',TRIM(c_name),' : ',tmp_i
+        ENDIF
+      ELSE IF ( (t_ea == NF90_REAL4).OR.(t_ea == NF90_REAL8) ) THEN
+        IF (l_ea > 1) THEN
+          ALLOCATE(tma_r(l_ea))
+          i_rc = NF90_GET_ATT(f_e,i_n,c_name,tma_r)
+          WRITE (ipslout,'("    ",A," :",/,(5(1X,1PE11.3),:))') &
+ &          TRIM(c_name),tma_r(1:l_ea)
+          DEALLOCATE(tma_r)
+        ELSE
+          i_rc = NF90_GET_ATT(f_e,i_n,c_name,tmp_r)
+          WRITE(ipslout,*) '   ',TRIM(c_name),' : ',tmp_r
+        ENDIF
+      ELSE
+        tmp_c = ''
+        i_rc = NF90_GET_ATT(f_e,i_n,c_name,tmp_c)
+        WRITE(ipslout,*) '   ',TRIM(c_name),' : "',TRIM(tmp_c),'"'
+      ENDIF
+    ENDDO
+  ENDDO
+  WRITE (ipslout,*) "---"
+!-
+  i_rc = NF90_CLOSE(f_e)
+!----------------------
+END SUBROUTINE fliodmpf
+!===
+SUBROUTINE flio_dom_set &
+ & (dtnb,dnb,did,dsg,dsl,dpf,dpl,dhs,dhe,cdnm,id_dom)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: dtnb,dnb
+  INTEGER,DIMENSION(:),INTENT(IN) :: did,dsg,dsl,dpf,dpl,dhs,dhe
+  CHARACTER(LEN=*),INTENT(IN) :: cdnm
+  INTEGER,INTENT(OUT) :: id_dom
+!-
+  INTEGER :: k_w,i_w,i_s
+  CHARACTER(LEN=l_dns) :: cd_p,cd_w
+!---------------------------------------------------------------------
+  k_w = flio_dom_rid()
+  IF (k_w < 0) THEN
+    CALL ipslerr (3,'flio_dom_set', &
+ &   'too many domains simultaneously defined', &
+ &   'please unset useless domains', &
+ &   'by calling flio_dom_unset')
+  ENDIF
+  id_dom = k_w
+!-
+  d_n_t(k_w) = dtnb
+  d_n_c(k_w) = dnb
+!-
+  i_s = SIZE(did)
+  IF (i_s > dom_max_dims) THEN
+    CALL ipslerr (3,'flio_dom_set', &
+ &   'too many distributed dimensions', &
+ &   'simultaneously defined',' ')
+  ENDIF
+  d_d_n(k_w) = i_s
+  d_d_i(1:i_s,k_w) = did(1:i_s)
+!-
+  i_w = SIZE(dsg)
+  IF (i_w /= i_s) THEN
+    CALL ipslerr (3,'flio_dom_set', &
+ &   'the size of the DOMAIN_size_global array', &
+ &   'is not equal to the size', &
+ &   'of the distributed dimensions array')
+  ENDIF
+  d_s_g(1:i_w,k_w) = dsg(1:i_w)
+!-
+  i_w = SIZE(dsl)
+  IF (i_w /= i_s) THEN
+    CALL ipslerr (3,'flio_dom_set', &
+ &   'the size of the DOMAIN_size_local array', &
+ &   'is not equal to the size', &
+ &   'of the distributed dimensions array')
+  ENDIF
+  d_s_l(1:i_w,k_w) = dsl(1:i_w)
+!-
+  i_w = SIZE(dpf)
+  IF (i_w /= i_s) THEN
+    CALL ipslerr (3,'flio_dom_set', &
+ &   'the size of the DOMAIN_position_first array', &
+ &   'is not equal to the size', &
+ &   'of the distributed dimensions array')
+  ENDIF
+  d_p_f(1:i_w,k_w) = dpf(1:i_w)
+!-
+  i_w = SIZE(dpl)
+  IF (i_w /= i_s) THEN
+    CALL ipslerr (3,'flio_dom_set', &
+ &   'the size of the DOMAIN_position_last array', &
+ &   'is not equal to the size', &
+ &   'of the distributed dimensions array')
+  ENDIF
+  d_p_l(1:i_w,k_w) = dpl(1:i_w)
+!-
+  i_w = SIZE(dhs)
+  IF (i_w /= i_s) THEN
+    CALL ipslerr (3,'flio_dom_set', &
+ &   'the size of the DOMAIN_halo_size_start array', &
+ &   'is not equal to the size', &
+ &   'of the distributed dimensions array')
+  ENDIF
+  d_h_s(1:i_w,k_w) = dhs(1:i_w)
+!-
+  i_w = SIZE(dhe)
+  IF (i_w /= i_s) THEN
+    CALL ipslerr (3,'flio_dom_set', &
+ &   'the size of the DOMAIN_halo_size_end array', &
+ &   'is not equal to the size', &
+ &   'of the distributed dimensions array')
+  ENDIF
+  d_h_e(1:i_w,k_w) = dhe(1:i_w)
+!-
+  cd_p = "unknown"
+  cd_w = cdnm; CALL strlowercase (cd_w)
+  DO i_w=1,n_dns
+    IF (TRIM(cd_w) == TRIM(c_dns(i_w))) THEN
+      cd_p = cd_w; EXIT;
+    ENDIF
+  ENDDO
+  IF (TRIM(cd_p) == "unknown") THEN
+    CALL ipslerr (3,'flio_dom_set', &
+ &   'DOMAIN_type "'//TRIM(cdnm)//'"', &
+ &   'is actually not supported', &
+ &   'please use one of the supported names')
+  ENDIF
+  c_d_t(k_w) = cd_p
+!--------------------------
+END SUBROUTINE flio_dom_set
+!===
+SUBROUTINE flio_dom_unset (id_dom)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN),OPTIONAL :: id_dom
+!-
+  INTEGER :: i_w
+!---------------------------------------------------------------------
+  IF (PRESENT(id_dom)) THEN
+    IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN
+      IF (d_d_n(id_dom) > 0) THEN
+        d_d_n(id_dom) = -1
+      ELSE
+        CALL ipslerr (2,'flio_dom_unset', &
+ &       'The domain is not set',' ',' ')
+      ENDIF
+    ELSE
+      CALL ipslerr (2,'flio_dom_unset', &
+ &     'Invalid file identifier',' ',' ')
+    ENDIF
+  ELSE
+    DO i_w=1,dom_max_nb
+      d_d_n(id_dom) = -1
+    ENDDO
+  ENDIF
+!----------------------------
+END SUBROUTINE flio_dom_unset
+!===
+SUBROUTINE flio_dom_defset (id_dom)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: id_dom
+!---------------------------------------------------------------------
+  IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN
+    id_def_dom = id_dom
+  ELSE
+    CALL ipslerr (3,'flio_dom_defset', &
+ &   'Invalid domain identifier',' ',' ')
+  ENDIF
+!-----------------------------
+END SUBROUTINE flio_dom_defset
+!===
+SUBROUTINE flio_dom_defunset ()
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!---------------------------------------------------------------------
+  id_def_dom = FLIO_DOM_NONE
+!-------------------------------
+END SUBROUTINE flio_dom_defunset
+!===
+SUBROUTINE flio_dom_definq (id_dom)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(OUT) :: id_dom
+!---------------------------------------------------------------------
+  id_dom = id_def_dom
+!-----------------------------
+END SUBROUTINE flio_dom_definq
+!===
+!-
+!---------------------------------------------------------------------
+!- Semi-public procedures
+!---------------------------------------------------------------------
+!-
+!===
+SUBROUTINE flio_dom_file (f_n,id_dom)
+!---------------------------------------------------------------------
+!- Update the model file name to include the ".nc" suffix and
+!- the DOMAIN number on which this copy of IOIPSL runs, if needed.
+!- This routine is called by IOIPSL and not by user anyway.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(INOUT) :: f_n
+  INTEGER,OPTIONAL,INTENT(IN) :: id_dom
+!-
+  INTEGER :: il,iw
+  CHARACTER(LEN=4) :: str
+!---------------------------------------------------------------------
+!-
+! Add the ".nc" suffix if needed
+  il = LEN_TRIM(f_n)
+  IF (f_n(il-2:il) /= '.nc') THEN
+    f_n = f_n(1:il)//'.nc'
+  ENDIF
+!-
+! Add the DOMAIN identifier if needed
+  IF (PRESENT(id_dom)) THEN
+    IF (id_dom == FLIO_DOM_DEFAULT) THEN
+      CALL flio_dom_definq (iw)
+    ELSE
+      iw = id_dom
+    ENDIF
+    IF (iw /= FLIO_DOM_NONE) THEN
+      IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN
+        IF (d_d_n(iw) > 0) THEN
+          WRITE(str,'(I4.4)') d_n_c(iw)
+          il = INDEX(f_n,'.nc')
+          f_n = f_n(1:il-1)//'_'//str//'.nc'
+        ELSE
+          CALL ipslerr (3,'flio_dom_file', &
+ &         'The domain has not been defined', &
+ &         'please call flio_dom_set', &
+ &         'before calling flio_dom_file')
+        ENDIF
+      ELSE
+        CALL ipslerr (3,'flio_dom_file', &
+ &       'Invalid domain identifier',' ',' ')
+      ENDIF
+    ENDIF
+  ENDIF
+!---------------------------
+END SUBROUTINE flio_dom_file
+!===
+SUBROUTINE flio_dom_att (f_e,id_dom)
+!---------------------------------------------------------------------
+!- Add the DOMAIN attributes to the NETCDF file.
+!- This routine is called by IOIPSL and not by user anyway.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(in) :: f_e
+  INTEGER,OPTIONAL,INTENT(IN) :: id_dom
+!-
+  INTEGER :: iw,i_rc,i_n
+  CHARACTER(LEN=15) :: c_ddim
+  INTEGER :: n_idim
+  CHARACTER(LEN=NF90_MAX_NAME) :: c_ndim
+!---------------------------------------------------------------------
+  IF (PRESENT(id_dom)) THEN
+    IF (id_dom == FLIO_DOM_DEFAULT) THEN
+      CALL flio_dom_definq (iw)
+    ELSE
+      iw = id_dom
+    ENDIF
+    IF (iw /= FLIO_DOM_NONE) THEN
+      IF ( (id_dom >= 1).AND.(id_dom <= dom_max_nb) ) THEN
+        IF (d_d_n(iw) > 0) THEN
+          i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, &
+ &          'DOMAIN_number_total',d_n_t(iw))
+          i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, &
+ &          'DOMAIN_number',d_n_c(iw))
+          i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, &
+ &          'DOMAIN_dimensions_ids',d_d_i(1:d_d_n(iw),iw))
+          i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, &
+ &          'DOMAIN_size_global',d_s_g(1:d_d_n(iw),iw))
+          i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, &
+ &          'DOMAIN_size_local',d_s_l(1:d_d_n(iw),iw))
+          i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, &
+ &          'DOMAIN_position_first',d_p_f(1:d_d_n(iw),iw))
+          i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, &
+ &          'DOMAIN_position_last',d_p_l(1:d_d_n(iw),iw))
+          i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, &
+ &          'DOMAIN_halo_size_start',d_h_s(1:d_d_n(iw),iw))
+          i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, &
+ &          'DOMAIN_halo_size_end',d_h_e(1:d_d_n(iw),iw))
+          i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL, &
+ &          'DOMAIN_type',TRIM(c_d_t(iw)))
+          i_rc = NF90_INQUIRE (f_e,nDimensions=n_idim)
+          DO i_n=1,n_idim
+            i_rc = NF90_INQUIRE_DIMENSION (f_e,i_n,name=c_ndim)
+            WRITE (UNIT=c_ddim,FMT='("DOMAIN_DIM_N",I3.3)') i_n
+            i_rc = NF90_PUT_ATT (f_e,NF90_GLOBAL,c_ddim,TRIM(c_ndim))
+          ENDDO
+        ELSE
+          CALL ipslerr (3,'flio_dom_att', &
+ &         'The domain has not been defined', &
+ &         'please call flio_dom_set', &
+ &         'before calling flio_dom_att')
+        ENDIF
+      ELSE
+        CALL ipslerr (3,'flio_dom_att', &
+ &       'Invalid domain identifier',' ',' ')
+      ENDIF
+    ENDIF
+  ENDIF
+!--------------------------
+END SUBROUTINE flio_dom_att
+!===
+!-
+!---------------------------------------------------------------------
+!- Local procedures
+!---------------------------------------------------------------------
+!-
+!===
+INTEGER FUNCTION flio_rid()
+!---------------------------------------------------------------------
+!- returns a free index in nw_id(:)
+!---------------------------------------------------------------------
+  INTEGER,DIMENSION(1:1) :: nfi
+!-
+  IF (ANY(nw_id < 0)) THEN
+    nfi = MINLOC(nw_id,MASK=nw_id < 0)
+    flio_rid = nfi(1)
+  ELSE
+    flio_rid = -1
+  ENDIF
+!--------------------
+END FUNCTION flio_rid
+!===
+INTEGER FUNCTION flio_dom_rid()
+!---------------------------------------------------------------------
+!- returns a free index in d_d_n(:)
+!---------------------------------------------------------------------
+  INTEGER,DIMENSION(1:1) :: nd
+!---------------------------------------------------------------------
+  IF (ANY(d_d_n < 0)) THEN
+    nd = MINLOC(d_d_n,MASK=d_d_n < 0)
+    flio_dom_rid = nd(1)
+  ELSE
+    flio_dom_rid = -1
+  ENDIF
+!------------------------
+END FUNCTION flio_dom_rid
+!===
+INTEGER FUNCTION flio_qid(iid)
+!---------------------------------------------------------------------
+!- returns the external index associated with the internal index "iid"
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: iid
+!---------------------------------------------------------------------
+  IF ( (iid >= 1).AND.(iid <= nb_fi_mx) ) THEN
+    flio_qid = nw_id(iid)
+  ELSE
+    flio_qid = -1
+  ENDIF
+!--------------------
+END FUNCTION flio_qid
+!===
+SUBROUTINE flio_qvid (cpg,iid,ixd)
+!---------------------------------------------------------------------
+!- This subroutine, called by the procedure "cpg",
+!- validates and returns the external file index "ixd"
+!- associated with the internal file index "iid"
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(IN) :: cpg
+  INTEGER,INTENT(IN)  :: iid
+  INTEGER,INTENT(OUT) :: ixd
+!-
+  CHARACTER(LEN=20) :: c_t
+!---------------------------------------------------------------------
+  ixd = flio_qid(iid)
+  IF (ixd < 0) THEN
+    WRITE (UNIT=c_t,FMT='(I15)') iid
+    CALL ipslerr (3,TRIM(cpg), &
+ &    'Invalid internal file index :',TRIM(ADJUSTL(c_t)),' ')
+  ENDIF
+!-----------------------
+END SUBROUTINE flio_qvid
+!===
+SUBROUTINE flio_hdm (f_i,f_e,lk_hm)
+!---------------------------------------------------------------------
+!- This subroutine handles the "define/data mode" of NETCDF.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_i,f_e
+  LOGICAL,INTENT(IN) :: lk_hm
+!-
+  INTEGER :: i_rc
+!---------------------------------------------------------------------
+  i_rc = NF90_NOERR
+!-
+  IF      ( (.NOT.lw_hm(f_i)).AND.(lk_hm) ) THEN
+    i_rc = NF90_REDEF(f_e)
+    lw_hm(f_i) = .TRUE.
+  ELSE IF ( (lw_hm(f_i)).AND.(.NOT.lk_hm) ) THEN
+    i_rc = NF90_ENDDEF(f_e)
+    lw_hm(f_i) = .FALSE.
+  ENDIF
+!-
+  IF (i_rc /= NF90_NOERR) THEN
+    CALL ipslerr (3,'flio_hdm', &
+ &    'Internal error ','in define/data mode :', &
+ &    TRIM(NF90_STRERROR(i_rc)))
+  ENDIF
+!----------------------
+END SUBROUTINE flio_hdm
+!===
+SUBROUTINE flio_inf (f_e, &
+ & nb_dims,nb_vars,nb_atts,id_unlm,nn_idm,nn_ldm,nn_aid,cc_ndm)
+!---------------------------------------------------------------------
+!- This subroutine allows to get some information concerning
+!- the model file whose the external identifier is "f_e".
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: f_e
+  INTEGER,OPTIONAL,INTENT(OUT) :: nb_dims,nb_vars,nb_atts,id_unlm
+  INTEGER,DIMENSION(:),OPTIONAL,INTENT(OUT) :: nn_idm,nn_ldm,nn_aid
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL,INTENT(OUT) :: cc_ndm
+!-
+  INTEGER :: nm_dims,nm_vars,nm_atts,nm_unlm,ml
+  INTEGER :: i_rc,kv
+  CHARACTER(LEN=NF90_MAX_NAME) :: f_d_n
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->flio_inf"
+  ENDIF
+!-
+  i_rc = NF90_INQUIRE(f_e,nDimensions=nm_dims,nVariables=nm_vars, &
+ &                    nAttributes=nm_atts,unlimitedDimId=nm_unlm)
+!-
+  IF (PRESENT(nb_dims))  nb_dims = nm_dims;
+  IF (PRESENT(nb_vars))  nb_vars = nm_vars;
+  IF (PRESENT(nb_atts))  nb_atts = nm_atts;
+  IF (PRESENT(id_unlm))  id_unlm = nm_unlm;
+!-
+  IF (PRESENT(nn_idm))  nn_idm(:) =  -1;
+  IF (PRESENT(nn_ldm))  nn_ldm(:) =   0;
+  IF (PRESENT(cc_ndm))  cc_ndm(:) = ' ';
+  IF (PRESENT(nn_aid))  nn_aid(:) =  -1;
+!-
+  DO kv=1,nm_dims
+!---
+    i_rc = NF90_INQUIRE_DIMENSION(f_e,kv,name=f_d_n,len=ml)
+    CALL strlowercase (f_d_n)
+    f_d_n = ADJUSTL(f_d_n)
+!---
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) "  flio_inf ",kv,ml," ",TRIM(f_d_n)
+    ENDIF
+!---
+    IF (PRESENT(nn_idm))  nn_idm(kv)=kv;
+    IF (PRESENT(nn_ldm))  nn_ldm(kv)=ml;
+    IF (PRESENT(cc_ndm))  cc_ndm(kv)=TRIM(f_d_n);
+!---
+    IF      (    (INDEX(f_d_n,'x') == 1)   &
+ &           .OR.(INDEX(f_d_n,'lon') == 1) ) THEN
+      IF (PRESENT(nn_aid)) THEN
+        IF (nn_aid(k_lon) < 0) THEN
+          nn_aid(k_lon)=kv;
+        ENDIF
+      ENDIF
+    ELSE IF (    (INDEX(f_d_n,'y') == 1)   &
+ &           .OR.(INDEX(f_d_n,'lat') == 1) ) THEN
+      IF (PRESENT(nn_aid)) THEN
+        IF (nn_aid(k_lat) < 0) THEN
+          nn_aid(k_lat)=kv;
+        ENDIF
+      ENDIF
+    ELSE IF (    (INDEX(f_d_n,'z') == 1)     &
+ &           .OR.(INDEX(f_d_n,'lev') == 1)   &
+ &           .OR.(INDEX(f_d_n,'plev') == 1)  &
+ &           .OR.(INDEX(f_d_n,'depth') == 1) ) THEN
+      IF (PRESENT(nn_aid)) THEN
+        IF (nn_aid(k_lev) < 0) THEN
+          nn_aid(k_lev)=kv;
+        ENDIF
+      ENDIF
+    ELSE IF (    (TRIM(f_d_n) == 't')         &
+ &           .OR.(TRIM(f_d_n) == 'time')      &
+ &           .OR.(INDEX(f_d_n,'tstep') == 1)  &
+ &           .OR.(INDEX(f_d_n,'time_counter') == 1) ) THEN
+!---- For the time we certainly need to allow for other names
+      IF (PRESENT(nn_aid)) THEN
+        IF (nn_aid(k_tim) < 0) THEN
+          nn_aid(k_tim)=kv;
+        ENDIF
+      ENDIF
+    ENDIF
+!---
+  ENDDO
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-flio_inf"
+  ENDIF
+!----------------------
+END SUBROUTINE flio_inf
+!===
+SUBROUTINE flio_qax (f_i,axtype,i_v,nbd)
+!---------------------------------------------------------------------
+!- This subroutine explores the file in order to find
+!- an axis (x/y/z/t) according to a number of rules
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: f_i,i_v,nbd
+  CHARACTER(LEN=*) :: axtype
+!-
+  INTEGER :: kv,k,n_r,l_d,n_d,i_rc,dimnb
+  CHARACTER(LEN=1)  :: c_ax
+  CHARACTER(LEN=18) :: c_sn
+  CHARACTER(LEN=15),DIMENSION(10) :: c_r
+  CHARACTER(LEN=40) :: c_t1,c_t2
+!---------------------------------------------------------------------
+  i_v = -1; nbd = -1;
+!---
+!- Keep the name of the axis
+!---
+  c_ax = TRIM(axtype)
+!-
+! Validate axis type
+!-
+  IF (    (LEN_TRIM(axtype) == 1) &
+ &    .AND.(    (c_ax == 'x').OR.(c_ax == 'y') &
+ &          .OR.(c_ax == 'z').OR.(c_ax == 't')) ) THEN
+!---
+!-- Define the maximum number of dimensions for the coordinate
+!---
+      SELECT CASE (c_ax)
+      CASE('x')
+        l_d = 2
+        c_sn = 'longitude'
+      CASE('y')
+        l_d = 2
+        c_sn = 'latitude'
+      CASE('z')
+        l_d = 1
+        c_sn = 'model_level_number'
+      CASE('t')
+        l_d = 1
+        c_sn = 'time'
+      END SELECT
+!---
+!-- Rule 1 : we look for a variable with one dimension
+!--          and which has the same name as its dimension (NUG)
+!---
+    IF (i_v < 0) THEN
+      SELECT CASE (c_ax)
+      CASE('x')
+        k = nw_ai(k_lon,f_i)
+      CASE('y')
+        k = nw_ai(k_lat,f_i)
+      CASE('z')
+        k = nw_ai(k_lev,f_i)
+      CASE('t')
+        k = nw_ai(k_tim,f_i)
+      END SELECT
+      IF ( (k >= 1).AND.(k <= nb_ax_mx) ) THEN
+        dimnb = nw_di(k,f_i)
+      ELSE
+        dimnb = -1
+      ENDIF
+!-----
+      i_rc = NF90_INQUIRE_DIMENSION(nw_id(f_i),dimnb,name=c_t1)
+      IF (i_rc == NF90_NOERR) THEN
+        CALL strlowercase (c_t1)
+        L_R1: DO kv=1,nw_nv(f_i)
+          i_rc = NF90_INQUIRE_VARIABLE &
+ &                 (nw_id(f_i),kv,name=c_t2,ndims=n_d)
+          IF (n_d == 1) THEN
+            CALL strlowercase (c_t2)
+            IF (TRIM(c_t1) == TRIM(c_t2)) THEN
+              i_v = kv; nbd = n_d;
+              EXIT L_R1
+            ENDIF
+          ENDIF
+        ENDDO L_R1
+      ENDIF
+    ENDIF
+!---
+!-- Rule 2 : we look for a correct "axis" attribute (CF)
+!---
+    IF (i_v < 0) THEN
+      L_R2: DO kv=1,nw_nv(f_i)
+        i_rc = NF90_GET_ATT(nw_id(f_i),kv,'axis',c_t1)
+        IF (i_rc == NF90_NOERR) THEN
+          CALL strlowercase (c_t1)
+          IF (TRIM(c_t1) == c_ax) THEN
+            i_rc = NF90_INQUIRE_VARIABLE(nw_id(f_i),kv,ndims=n_d)
+            IF (n_d <= l_d) THEN
+              i_v = kv; nbd = n_d;
+              EXIT L_R2
+            ENDIF
+          ENDIF
+        ENDIF
+      ENDDO L_R2
+    ENDIF
+!---
+!-- Rule 3 : we look for a correct "standard_name" attribute (CF)
+!---
+    IF (i_v < 0) THEN
+      L_R3: DO kv=1,nw_nv(f_i)
+        i_rc = NF90_GET_ATT(nw_id(f_i),kv,'standard_name',c_t1)
+        IF (i_rc == NF90_NOERR) THEN
+          CALL strlowercase (c_t1)
+          IF (TRIM(c_t1) == TRIM(c_sn)) THEN
+            i_rc = NF90_INQUIRE_VARIABLE(nw_id(f_i),kv,ndims=n_d)
+            IF (n_d <= l_d) THEN
+              i_v = kv; nbd = n_d;
+              EXIT L_R3
+            ENDIF
+          ENDIF
+        ENDIF
+      ENDDO L_R3
+    ENDIF
+!---
+!-- Rule 4 : we look for a specific name (IOIPSL)
+!---
+    IF (i_v < 0) THEN
+      SELECT CASE (c_ax)
+      CASE('x')
+        n_r = 3
+        c_r(1)='nav_lon'; c_r(2)='lon'; c_r(3)='longitude';
+      CASE('y')
+        n_r = 3
+        c_r(1)='nav_lat'; c_r(2)='lat'; c_r(3)='latitude';
+      CASE('z')
+        n_r = 8
+        c_r(1)='depth'; c_r(2)='deptht'; c_r(3)='height';
+        c_r(4)='level'; c_r(5)='lev'; c_r(6)='plev';
+        c_r(7)='sigma_level'; c_r(8)='layer';
+      CASE('t')
+        n_r = 3
+        c_r(1)='time'; c_r(2)='tstep'; c_r(3)='timesteps';
+      END SELECT
+!-----
+      L_R4: DO kv=1,nw_nv(f_i)
+        i_rc = NF90_INQUIRE_VARIABLE &
+ &               (nw_id(f_i),kv,name=c_t1,ndims=n_d)
+        IF (i_rc == NF90_NOERR) THEN
+          CALL strlowercase (c_t1)
+          IF (n_d <= l_d) THEN
+            DO k=1,n_r
+              IF (TRIM(c_t1) == TRIM(c_r(k))) THEN
+                i_v = kv; nbd = n_d;
+                EXIT L_R4
+              ENDIF
+            ENDDO
+          ENDIF
+        ENDIF
+      ENDDO L_R4
+    ENDIF
+!---
+  ENDIF
+!----------------------
+END SUBROUTINE flio_qax
+!-
+!===
+!-
+END MODULE fliocom
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/getincom.f90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/getincom.f90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/getincom.f90	(revision 17)
@@ -0,0 +1,2134 @@
+MODULE getincom
+!-
+!$Id: getincom.f90 1574 2011-11-10 08:21:23Z mmaipsl $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+USE errioipsl, ONLY : ipslerr,ipsldbg,ipslout
+USE stringop, &
+ &   ONLY : nocomma,cmpblank,strlowercase
+!-
+IMPLICIT NONE
+!-
+PRIVATE
+PUBLIC :: getin_name, getin, getin_dump, getin_dump_para
+!-
+!!--------------------------------------------------------------------
+!! The "getin_name" routine allows the user to change the name
+!! of the definition file in which the data will be read.
+!! ("run.def" by default)
+!!
+!!  SUBROUTINE getin_name (file_name)
+!!
+!! OPTIONAL INPUT argument
+!!
+!! (C) file_name :  the name of the file
+!!                  in which the data will be read
+!!--------------------------------------------------------------------
+!-
+!-
+INTERFACE getin
+!!--------------------------------------------------------------------
+!! The "getin" routines get a variable.
+!! We first check if we find it in the database
+!! and if not we get it from the definition file.
+!!
+!! SUBROUTINE getin (targetname,ret_val)
+!!
+!! INPUT
+!!
+!! (C) targetname : Name of the variable
+!!
+!! OUTPUT
+!!
+!! (I/R/C/L) ret_val : scalar, vector or matrix that will contain
+!!                     that will contain the (standard)
+!!                     integer/real/character/logical values
+!!--------------------------------------------------------------------
+  MODULE PROCEDURE getinrs, getinr1d, getinr2d, &
+ &                 getinis, getini1d, getini2d, &
+ &                 getincs, getinc1d, getinc2d, &
+ &                 getinls, getinl1d, getinl2d
+END INTERFACE
+!-
+!!--------------------------------------------------------------------
+!! The "getin_dump" routine will dump the content of the database
+!! into a file which has the same format as the definition file.
+!! The idea is that the user can see which parameters were used
+!! and re-use the file for another run.
+!!
+!!  SUBROUTINE getin_dump (fileprefix)
+!!
+!! OPTIONAL INPUT argument
+!!
+!! (C) fileprefix : allows the user to change the name of the file
+!!                  in which the data will be archived
+!!--------------------------------------------------------------------
+!-
+!!------------------------------------------------------------------------
+!! Parallel version of getin_dump : user must give a fileprefix and a rank.
+!! It may be usefull to verify that only the root proc is reading the input
+!! def files.
+!!
+!!  SUBROUTINE getin_dump_para (fileprefix,rank)
+!!
+!! INPUT argument
+!!
+!! (C) fileprefix : allows the user to change the name of the file
+!!                  in which the data will be archived
+!! (I) rank : the rank of the parallel process (only 0-999 files will be created)
+!!--------------------------------------------------------------------
+!-
+  INTEGER,PARAMETER :: max_files=100
+  CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist
+  INTEGER,SAVE      :: nbfiles
+!-
+  INTEGER,SAVE :: allread=0
+  CHARACTER(LEN=100),SAVE :: def_file = 'run.def'
+!-
+  INTEGER,PARAMETER :: i_txtslab=1000,l_n=30
+  INTEGER,SAVE :: nb_lines,i_txtsize=0
+  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: fichier
+  CHARACTER(LEN=l_n),SAVE,ALLOCATABLE,DIMENSION(:) :: targetlist
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: fromfile,compline
+!-
+  INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15
+  CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)'
+!-
+! The data base of parameters
+!-
+  INTEGER,PARAMETER :: memslabs=200
+  INTEGER,PARAMETER :: compress_lim=20
+!-
+  INTEGER,SAVE :: nb_keys=0
+  INTEGER,SAVE :: keymemsize=0
+!-
+! keystr definition
+! name of a key
+!-
+! keystatus definition
+! keystatus = 1 : Value comes from the file defined by 'def_file'
+! keystatus = 2 : Default value is used
+! keystatus = 3 : Some vector elements were taken from default
+  INTEGER,PARAMETER :: nondefault=1, default=2, vectornondefault=3
+!-
+! keytype definition
+! keytype = 1 : Integer
+! keytype = 2 : Real
+! keytype = 3 : Character
+! keytype = 4 : Logical
+!-
+  INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4
+!-
+! Allow compression for keys (only for integer and real)
+! keycompress < 0 : not compressed
+! keycompress > 0 : number of repeat of the value
+!-
+TYPE :: t_key
+  CHARACTER(LEN=l_n) :: keystr
+  INTEGER :: keystatus, keytype, keycompress, &
+ &           keyfromfile, keymemstart, keymemlen
+END TYPE t_key
+!-
+  TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab
+!-
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: i_mem
+  INTEGER,SAVE :: i_memsize=0, i_mempos=0
+  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: r_mem
+  INTEGER,SAVE :: r_memsize=0, r_mempos=0
+  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: c_mem
+  INTEGER,SAVE :: c_memsize=0, c_mempos=0
+  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: l_mem
+  INTEGER,SAVE :: l_memsize=0, l_mempos=0
+!-
+CONTAINS
+!-
+!=== DEFINITION FILE NAME INTERFACE
+!-
+SUBROUTINE getin_name (cname)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: cname
+!---------------------------------------------------------------------
+  IF (allread == 0) THEN
+    def_file = ADJUSTL(cname)
+  ELSE
+    CALL ipslerr (3,'getin_name', &
+ &   'The name of the database file (any_name.def)', &
+ &   'must be changed *before* any attempt','to read the database.')
+  ENDIF
+!------------------------
+END SUBROUTINE getin_name
+!-
+!=== INTEGER INTERFACE
+!-
+SUBROUTINE getinis (targetname,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  INTEGER :: ret_val
+!-
+  INTEGER,DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig, size_of_in
+!---------------------------------------------------------------------
+!-
+! Do we have this targetname in our database ?
+!-
+  CALL get_findkey (1,targetname,pos)
+!-
+  tmp_ret_val(1) = ret_val
+  size_of_in = SIZE(tmp_ret_val)
+  
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (targetname,status,fileorig,1,i_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,targetname,i_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getinis
+!===
+SUBROUTINE getini1d (targetname,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  INTEGER,DIMENSION(:) :: ret_val
+!-
+  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this targetname in our database ?
+!-
+  CALL get_findkey (1,targetname,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,targetname,i_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getini1d
+!===
+SUBROUTINE getini2d (targetname,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  INTEGER,DIMENSION(:,:) :: ret_val
+!-
+  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this targetname in our database ?
+!-
+  CALL get_findkey (1,targetname,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (targetname,status,fileorig,size_of_in,i_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,targetname,i_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getini2d
+!-
+!=== REAL INTERFACE
+!-
+SUBROUTINE getinrs (targetname,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  REAL :: ret_val
+!-
+  REAL,DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig, size_of_in
+!---------------------------------------------------------------------
+!-
+! Do we have this targetname in our database ?
+!-
+  CALL get_findkey (1,targetname,pos)
+!-
+  tmp_ret_val(1) = ret_val
+  size_of_in = SIZE(tmp_ret_val)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (targetname,status,fileorig,1,r_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,targetname,r_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getinrs
+!===
+SUBROUTINE getinr1d (targetname,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  REAL,DIMENSION(:) :: ret_val
+!-
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this targetname in our database ?
+!-
+  CALL get_findkey (1,targetname,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,targetname,r_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getinr1d
+!===
+SUBROUTINE getinr2d (targetname,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  REAL,DIMENSION(:,:) :: ret_val
+!-
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this targetname in our database ?
+!-
+  CALL get_findkey (1,targetname,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (targetname,status,fileorig,size_of_in,r_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,targetname,r_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getinr2d
+!-
+!=== CHARACTER INTERFACE
+!-
+SUBROUTINE getincs (targetname,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  CHARACTER(LEN=*) :: ret_val
+!-
+  CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig,size_of_in
+!---------------------------------------------------------------------
+!-
+! Do we have this targetname in our database ?
+!-
+  CALL get_findkey (1,targetname,pos)
+!-
+  tmp_ret_val(1) = ret_val
+  size_of_in = SIZE(tmp_ret_val)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (targetname,status,fileorig,1,c_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,targetname,c_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getincs
+!===
+SUBROUTINE getinc1d (targetname,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  CHARACTER(LEN=*),DIMENSION(:) :: ret_val
+!-
+  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this targetname in our database ?
+!-
+  CALL get_findkey (1,targetname,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,targetname,c_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getinc1d
+!===
+SUBROUTINE getinc2d (targetname,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val
+!-
+  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this targetname in our database ?
+!-
+  CALL get_findkey (1,targetname,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (targetname,status,fileorig,size_of_in,c_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,targetname,c_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getinc2d
+!-
+!=== LOGICAL INTERFACE
+!-
+SUBROUTINE getinls (targetname,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  LOGICAL :: ret_val
+!-
+  LOGICAL,DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig,size_of_in
+!---------------------------------------------------------------------
+!-
+! Do we have this targetname in our database ?
+!-
+  CALL get_findkey (1,targetname,pos)
+!-
+  tmp_ret_val(1) = ret_val
+  size_of_in = SIZE(tmp_ret_val)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (targetname,status,fileorig,1,l_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,targetname,l_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getinls
+!===
+SUBROUTINE getinl1d (targetname,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  LOGICAL,DIMENSION(:) :: ret_val
+!-
+  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this targetname in our database ?
+!-
+  CALL get_findkey (1,targetname,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,targetname,l_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getinl1d
+!===
+SUBROUTINE getinl2d (targetname,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  LOGICAL,DIMENSION(:,:) :: ret_val
+!-
+  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this targetname in our database ?
+!-
+  CALL get_findkey (1,targetname,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (targetname,status,fileorig,size_of_in,l_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,targetname,l_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getinl2d
+!-
+!=== Generic file/database INTERFACE
+!-
+SUBROUTINE get_fil (targetname,status,fileorig,nb_to_ret,i_val,r_val,c_val,l_val)
+!---------------------------------------------------------------------
+!- Subroutine that will extract from the file the values
+!- attributed to the keyword targetname
+!-
+!- (C) targetname    : target for which we will look in the file
+!- (I) status    : tells us from where we obtained the data
+!- (I) fileorig  : index of the file from which the key comes
+!- (I) nb_to_ret : size of output vector
+!- (I) i_val(:)  : INTEGER(nb_to_ret)   values
+!- (R) r_val(:)  : REAL(nb_to_ret)      values
+!- (L) l_val(:)  : LOGICAL(nb_to_ret)   values
+!- (C) c_val(:)  : CHARACTER(nb_to_ret) values
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  INTEGER,INTENT(IN) :: nb_to_ret
+  INTEGER,INTENT(OUT) :: status,fileorig
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
+  REAL,DIMENSION(:),OPTIONAL             :: r_val
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
+!-
+  INTEGER :: k_typ,it,pos,len_str,status_cnt,io_err
+  CHARACTER(LEN=n_d_fmt)  :: cnt
+  CHARACTER(LEN=80) :: str_READ,str_READ_lower
+  CHARACTER(LEN=9)  :: c_vtyp
+  LOGICAL,DIMENSION(:),ALLOCATABLE :: found
+  LOGICAL :: def_beha,compressed
+  CHARACTER(LEN=10) :: c_fmt
+  INTEGER :: i_cmpval
+  REAL    :: r_cmpval
+  INTEGER :: ipos_tr,ipos_fl
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!---------------------------------------------------------------------
+!-
+! Get the type of the argument
+  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
+  IF ( (k_typ.NE.k_i) .AND. (k_typ.NE.k_r) .AND. (k_typ.NE.k_c) .AND. (k_typ.NE.k_l) ) THEN
+    CALL ipslerr (3,'get_fil', &
+ &   'Internal error','Unknown type of data',' ')
+  ENDIF
+!-
+! Read the file(s)
+  CALL getin_read
+!-
+! Allocate and initialize the memory we need
+  ALLOCATE(found(nb_to_ret))
+  found(:) = .FALSE.
+!-
+! See what we find in the files read
+!---
+!-- We dont know from which file the target could come.
+!-- Thus by default we attribute it to the first file :
+  fileorig = 1
+!-
+  DO it=1,nb_to_ret
+!---
+!-- First try the target as it is
+    CALL get_findkey (2,targetname,pos)
+!---
+!-- Another try
+!---
+    IF (pos < 0) THEN
+      WRITE(UNIT=cnt,FMT=c_i_fmt) it
+      CALL get_findkey (2,TRIM(targetname)//'__'//cnt,pos)
+    ENDIF
+!---
+    IF (pos > 0) THEN
+!-----
+      found(it) = .TRUE.
+      fileorig = fromfile(pos)
+      !
+      IF (l_dbg) THEN
+         WRITE(*,*) &
+              &      'getin_fil : read key ',targetname,' from file ',fileorig,' has type ',k_typ
+      ENDIF
+!-----
+!---- DECODE
+!-----
+      str_READ = ADJUSTL(fichier(pos))
+      str_READ_lower = str_READ
+      CALL strlowercase (str_READ_lower)
+      IF (l_dbg) THEN
+         WRITE(*,*) &
+              &      '            value    ',str_READ_lower
+      ENDIF
+!-----
+      IF (    (TRIM(str_READ_lower) == 'def')     &
+ &        .OR.(TRIM(str_READ_lower) == 'default') ) THEN
+        def_beha = .TRUE.
+      ELSE
+        def_beha = .FALSE.
+        len_str = LEN_TRIM(str_READ)
+        io_err = 0
+        SELECT CASE (k_typ)
+        CASE(k_i)
+          WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str
+          READ (UNIT=str_READ(1:len_str), &
+ &              FMT=c_fmt,IOSTAT=io_err) i_val(it)
+        CASE(k_r)
+          READ (UNIT=str_READ(1:len_str), &
+ &              FMT=*,IOSTAT=io_err) r_val(it)
+        CASE(k_c)
+          c_val(it) = str_READ(1:len_str)
+        CASE(k_l)
+          ipos_tr = -1
+          ipos_fl = -1
+          ipos_tr = MAX(INDEX(str_READ_lower,'tru'), &
+ &                      INDEX(str_READ_lower,'y'))
+          ipos_fl = MAX(INDEX(str_READ_lower,'fal'), &
+ &                      INDEX(str_READ_lower,'n'))
+          IF (ipos_tr > 0) THEN
+            l_val(it) = .TRUE.
+          ELSE IF (ipos_fl > 0) THEN
+            l_val(it) = .FALSE.
+          ELSE
+            io_err = 100
+          ENDIF
+        END SELECT
+        IF (io_err /= 0) THEN
+          CALL ipslerr (3,'get_fil', &
+ &         'Target '//TRIM(targetname), &
+ &         'is not of '//TRIM(c_vtyp)//' type',' ')
+        ENDIF
+      ENDIF
+!-----
+      IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
+!-------
+!------ Is this the value of a compressed field ?
+        compressed = (compline(pos) > 0)
+        IF (compressed) THEN
+          IF (compline(pos) /= nb_to_ret) THEN
+            CALL ipslerr (2,'get_fil', &
+ &           'For key '//TRIM(targetname)//' we have a compressed field', &
+ &           'which does not have the right size.', &
+ &           'We will try to fix that.')
+          ENDIF
+          IF      (k_typ == k_i) THEN
+            i_cmpval = i_val(it)
+          ELSE IF (k_typ == k_r) THEN
+            r_cmpval = r_val(it)
+          ENDIF
+        ENDIF
+      ENDIF
+    ELSE
+      found(it) = .FALSE.
+      def_beha = .FALSE.
+      compressed = .FALSE.
+    ENDIF
+  ENDDO
+!-
+  IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
+!---
+!-- If this is a compressed field then we will uncompress it
+    IF (compressed) THEN
+      DO it=1,nb_to_ret
+        IF (.NOT.found(it)) THEN
+          IF      (k_typ == k_i) THEN
+            i_val(it) = i_cmpval
+          ELSE IF (k_typ == k_r) THEN
+            r_val(it) = r_cmpval
+          ENDIF
+          found(it) = .TRUE.
+        ENDIF
+      ENDDO
+    ENDIF
+  ENDIF
+!-
+! Now we set the status for what we found
+  IF (def_beha) THEN
+    status = default
+    CALL ipslerr (1,'USING DEFAULT BEHAVIOUR FOR', &
+ &   TRIM(targetname),' ',' ')
+    WRITE(ipslout,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(targetname)
+  ELSE
+    status_cnt = 0
+    DO it=1,nb_to_ret
+      IF (.NOT.found(it)) THEN
+        status_cnt = status_cnt+1
+        IF      (status_cnt <= max_msgs) THEN
+          WRITE (UNIT=ipslout,FMT='(" USING DEFAULTS : ",A)', &
+ &               ADVANCE='NO') TRIM(targetname)
+          IF (nb_to_ret > 1) THEN
+            WRITE (UNIT=ipslout,FMT='("__")',ADVANCE='NO')
+            WRITE (UNIT=ipslout,FMT=c_i_fmt,ADVANCE='NO') it
+          ENDIF
+          SELECT CASE (k_typ)
+          CASE(k_i)
+            WRITE (UNIT=ipslout,FMT=*) "=",i_val(it)
+          CASE(k_r)
+            WRITE (UNIT=ipslout,FMT=*) "=",r_val(it)
+          CASE(k_c)
+            WRITE (UNIT=ipslout,FMT=*) "=",c_val(it)
+          CASE(k_l)
+            WRITE (UNIT=ipslout,FMT=*) "=",l_val(it)
+          END SELECT
+        ELSE IF (status_cnt == max_msgs+1) THEN
+          WRITE (UNIT=ipslout,FMT='(" USING DEFAULTS ... ",A)')
+        ENDIF
+      ENDIF
+    ENDDO
+!---
+    IF (status_cnt == 0) THEN
+      status = nondefault
+    ELSE IF (status_cnt == nb_to_ret) THEN
+      status = default
+    ELSE
+      status = vectornondefault
+    ENDIF
+  ENDIF
+! Deallocate the memory
+  DEALLOCATE(found)
+!---------------------
+END SUBROUTINE get_fil
+!===
+SUBROUTINE get_rdb (pos,size_of_in,targetname,i_val,r_val,c_val,l_val)
+!---------------------------------------------------------------------
+!- Read the required variable in the database
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: pos,size_of_in
+  CHARACTER(LEN=*) :: targetname
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
+  REAL,DIMENSION(:),OPTIONAL             :: r_val
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
+!-
+  INTEGER :: k_typ,k_beg,k_end
+  CHARACTER(LEN=9) :: c_vtyp
+!---------------------------------------------------------------------
+!-
+! Get the type of the argument
+  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
+  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
+ &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
+    CALL ipslerr (3,'get_rdb', &
+ &   'Internal error','Unknown type of data',' ')
+  ENDIF
+!-
+  IF (key_tab(pos)%keytype /= k_typ) THEN
+    CALL ipslerr (3,'get_rdb', &
+ &   'Wrong data type for keyword '//TRIM(targetname), &
+ &   '(NOT '//TRIM(c_vtyp)//')',' ')
+  ENDIF
+!-
+  IF (key_tab(pos)%keycompress > 0) THEN
+    IF (    (key_tab(pos)%keycompress /= size_of_in) &
+ &      .OR.(key_tab(pos)%keymemlen /= 1) ) THEN
+      CALL ipslerr (3,'get_rdb', &
+ &     'Wrong compression length','for keyword '//TRIM(targetname),' ')
+    ELSE
+      SELECT CASE (k_typ)
+      CASE(k_i)
+        i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart)
+      CASE(k_r)
+        r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart)
+      END SELECT
+    ENDIF
+  ELSE
+    IF (key_tab(pos)%keymemlen /= size_of_in) THEN
+      CALL ipslerr (3,'get_rdb', &
+ &     'Wrong array length','for keyword '//TRIM(targetname),' ')
+    ELSE
+      k_beg = key_tab(pos)%keymemstart
+      k_end = k_beg+key_tab(pos)%keymemlen-1
+      SELECT CASE (k_typ)
+      CASE(k_i)
+        i_val(1:size_of_in) = i_mem(k_beg:k_end)
+      CASE(k_r)
+        r_val(1:size_of_in) = r_mem(k_beg:k_end)
+      CASE(k_c)
+        c_val(1:size_of_in) = c_mem(k_beg:k_end)
+      CASE(k_l)
+        l_val(1:size_of_in) = l_mem(k_beg:k_end)
+      END SELECT
+    ENDIF
+  ENDIF
+!---------------------
+END SUBROUTINE get_rdb
+!===
+SUBROUTINE get_wdb &
+ &  (targetname,status,fileorig,size_of_in, &
+ &   i_val,r_val,c_val,l_val)
+!---------------------------------------------------------------------
+!- Write data into the data base
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: targetname
+  INTEGER :: status,fileorig,size_of_in
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
+  REAL,DIMENSION(:),OPTIONAL             :: r_val
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
+!-
+  INTEGER :: k_typ
+  CHARACTER(LEN=9) :: c_vtyp
+  INTEGER :: k_mempos,k_memsize,k_beg,k_end
+  LOGICAL :: l_cmp
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!---------------------------------------------------------------------
+!-
+! Get the type of the argument
+  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
+  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
+ &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
+    CALL ipslerr (3,'get_wdb', &
+ &   'Internal error','Unknown type of data',' ')
+  ENDIF
+!-
+! First check if we have sufficiant space for the new key
+  IF (nb_keys+1 > keymemsize) THEN
+    CALL getin_allockeys ()
+  ENDIF
+!-
+  SELECT CASE (k_typ)
+  CASE(k_i)
+    k_mempos = i_mempos; k_memsize = i_memsize;
+    l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) &
+ &         .AND.(size_of_in > compress_lim)
+  CASE(k_r)
+    k_mempos = r_mempos; k_memsize = r_memsize;
+    l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) &
+ &         .AND.(size_of_in > compress_lim)
+  CASE(k_c)
+    k_mempos = c_mempos; k_memsize = c_memsize;
+    l_cmp = .FALSE.
+  CASE(k_l)
+    k_mempos = l_mempos; k_memsize = l_memsize;
+    l_cmp = .FALSE.
+  END SELECT
+!-
+! Fill out the items of the data base
+  nb_keys = nb_keys+1
+  key_tab(nb_keys)%keystr = targetname(1:MIN(LEN_TRIM(targetname),l_n))
+  key_tab(nb_keys)%keystatus = status
+  key_tab(nb_keys)%keytype = k_typ
+  key_tab(nb_keys)%keyfromfile = fileorig
+  key_tab(nb_keys)%keymemstart = k_mempos+1
+  IF (l_cmp) THEN
+    key_tab(nb_keys)%keycompress = size_of_in
+    key_tab(nb_keys)%keymemlen = 1
+  ELSE
+    key_tab(nb_keys)%keycompress = -1
+    key_tab(nb_keys)%keymemlen = size_of_in
+  ENDIF
+  IF (l_dbg) THEN
+     WRITE(*,*) &
+ &     "get_wdb : nb_keys ",nb_keys," key_tab keystr   ",key_tab(nb_keys)%keystr,&
+ &                                       ",keystatus   ",key_tab(nb_keys)%keystatus,&
+ &                                       ",keytype     ",key_tab(nb_keys)%keytype,&
+ &                                       ",keycompress ",key_tab(nb_keys)%keycompress,&
+ &                                       ",keyfromfile ",key_tab(nb_keys)%keyfromfile,&
+ &                                       ",keymemstart ",key_tab(nb_keys)%keymemstart
+  ENDIF
+
+!-
+! Before writing the actual size lets see if we have the space
+  IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen &
+ &    > k_memsize) THEN
+    CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen)
+  ENDIF
+!-
+  k_beg = key_tab(nb_keys)%keymemstart
+  k_end = k_beg+key_tab(nb_keys)%keymemlen-1
+  SELECT CASE (k_typ)
+  CASE(k_i)
+    i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen)
+    i_mempos = k_end
+  CASE(k_r)
+    r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen)
+    r_mempos = k_end
+  CASE(k_c)
+    c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen)
+    c_mempos = k_end
+  CASE(k_l)
+    l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen)
+    l_mempos = k_end
+  END SELECT
+!---------------------
+END SUBROUTINE get_wdb
+!-
+!===
+!-
+SUBROUTINE getin_read
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,SAVE :: current
+!---------------------------------------------------------------------
+  IF (allread == 0) THEN
+!-- Allocate a first set of memory.
+    CALL getin_alloctxt ()
+    CALL getin_allockeys ()
+    CALL getin_allocmem (k_i,0)
+    CALL getin_allocmem (k_r,0)
+    CALL getin_allocmem (k_c,0)
+    CALL getin_allocmem (k_l,0)
+!-- Start with reading the files
+    nbfiles = 1
+    filelist(1) = TRIM(def_file)
+    current = 1
+!--
+    DO WHILE (current <= nbfiles)
+      CALL getin_readdef (current)
+      current = current+1
+    ENDDO
+    allread = 1
+    CALL getin_checkcohe ()
+  ENDIF
+!------------------------
+END SUBROUTINE getin_read
+!-
+!===
+!-
+  SUBROUTINE getin_readdef(current)
+!---------------------------------------------------------------------
+!- This subroutine will read the files and only keep the
+!- the relevant information. The information is kept as it
+!- found in the file. The data will be analysed later.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: current
+!-
+  CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str
+  CHARACTER(LEN=n_d_fmt) :: cnt
+  CHARACTER(LEN=10) :: c_fmt
+  INTEGER :: nb_lastkey
+!-
+  INTEGER :: eof,ptn,len_str,i,it,iund,io_err
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!---------------------------------------------------------------------
+  eof = 0
+  ptn = 1
+  nb_lastkey = 0
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) 'getin_readdef : Open file ',TRIM(filelist(current))
+  ENDIF
+!-
+  OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err)
+  IF (io_err /= 0) THEN
+    CALL ipslerr (2,'getin_readdef', &
+ &  'Could not open file '//TRIM(filelist(current)),' ',' ')
+    RETURN
+  ENDIF
+!-
+  DO WHILE (eof /= 1)
+!---
+    CALL getin_skipafew (22,READ_str,eof,nb_lastkey)
+    len_str = LEN_TRIM(READ_str)
+    ptn = INDEX(READ_str,'=')
+!---
+    IF (ptn > 0) THEN
+!---- Get the target
+      key_str = TRIM(ADJUSTL(READ_str(1:ptn-1)))
+!---- Make sure that a vector keyword has the right length
+      iund = INDEX(key_str,'__')
+      IF (iund > 0) THEN
+        WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') &
+ &        LEN_TRIM(key_str)-iund-1
+        READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), &
+ &           FMT=c_fmt,IOSTAT=io_err) it
+        IF ( (io_err == 0).AND.(it > 0) ) THEN
+          WRITE(UNIT=cnt,FMT=c_i_fmt) it
+          key_str = key_str(1:iund+1)//cnt
+        ELSE
+          CALL ipslerr (3,'getin_readdef', &
+ &         'A very strange key has just been found :', &
+ &         TRIM(key_str),' ')
+        ENDIF
+      ENDIF
+!---- Prepare the content
+      NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str)))
+      CALL nocomma (NEW_str)
+      CALL cmpblank (NEW_str)
+      NEW_str  = TRIM(ADJUSTL(NEW_str))
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) &
+ &        '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str)
+      ENDIF
+!---- Decypher the content of NEW_str
+!-
+!---- This has to be a new key word, thus :
+      nb_lastkey = 0
+!----
+      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
+!----
+    ELSE IF (len_str > 0) THEN
+!---- Prepare the key if we have an old one to which
+!---- we will add the line just read
+      IF (nb_lastkey > 0) THEN
+        iund =  INDEX(last_key,'__')
+        IF (iund > 0) THEN
+!-------- We only continue a keyword, thus it is easy
+          key_str = last_key(1:iund-1)
+        ELSE
+          IF (nb_lastkey /= 1) THEN
+            CALL ipslerr (3,'getin_readdef', &
+ &           'We can not have a scalar keyword', &
+ &           'and a vector content',' ')
+          ENDIF
+!-------- The last keyword needs to be transformed into a vector.
+          WRITE(UNIT=cnt,FMT=c_i_fmt) 1
+          targetlist(nb_lines) = &
+ &         last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt
+          key_str = last_key(1:LEN_TRIM(last_key))
+        ENDIF
+      ENDIF
+!---- Prepare the content
+      NEW_str = TRIM(ADJUSTL(READ_str(1:len_str)))
+      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
+    ELSE
+!---- If we have an empty line then the keyword finishes
+      nb_lastkey = 0
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) 'getin_readdef : Have found an emtpy line '
+      ENDIF
+    ENDIF
+  ENDDO
+!-
+  CLOSE(UNIT=22)
+!-
+  IF (l_dbg) THEN
+    OPEN (UNIT=22,file=TRIM(def_file)//'.test')
+    DO i=1,nb_lines
+      WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i)
+    ENDDO
+    CLOSE(UNIT=22)
+  ENDIF
+!-
+  IF (l_dbg) THEN
+     WRITE(ipslout,*) "nb_lines ",nb_lines,"nb_keys ",nb_keys
+     WRITE(ipslout,*) "fichier ",fichier(1:nb_lines)
+     WRITE(ipslout,*) "targetlist ",targetlist(1:nb_lines)
+     WRITE(ipslout,*) "fromfile ",fromfile(1:nb_lines)
+     WRITE(ipslout,*) "compline ",compline(1:nb_lines)
+     WRITE(ipslout,*) '<-getin_readdef'
+  ENDIF
+!---------------------------
+END SUBROUTINE getin_readdef
+!-
+!===
+!-
+SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey)
+!---------------------------------------------------------------------
+!- This subroutine is going to decypher the line.
+!- It essentialy checks how many items are included and
+!- it they can be attached to a key.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! ARGUMENTS
+!-
+  INTEGER :: current,nb_lastkey
+  CHARACTER(LEN=*) :: key_str,NEW_str
+  CHARACTER(LEN=*),INTENT(out) :: last_key
+!-
+! LOCAL
+!-
+  INTEGER :: len_str,blk,nbve,starpos
+  CHARACTER(LEN=100) :: tmp_str,new_key,mult
+  CHARACTER(LEN=n_d_fmt) :: cnt
+  CHARACTER(LEN=10) :: c_fmt
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!---------------------------------------------------------------------
+  len_str = LEN_TRIM(NEW_str)
+  blk = INDEX(NEW_str(1:len_str),' ')
+  tmp_str = NEW_str(1:len_str)
+!-
+! If the key is a new file then we take it up. Else
+! we save the line and go on.
+!-
+  IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN
+    DO WHILE (blk > 0)
+      IF (nbfiles+1 > max_files) THEN
+        CALL ipslerr (3,'getin_decrypt', &
+ &       'Too many files to include',' ',' ')
+      ENDIF
+!-----
+      nbfiles = nbfiles+1
+      filelist(nbfiles) = tmp_str(1:blk)
+!-----
+      tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
+      blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ')
+    ENDDO
+!---
+    IF (nbfiles+1 > max_files) THEN
+      CALL ipslerr (3,'getin_decrypt', &
+ &     'Too many files to include',' ',' ')
+    ENDIF
+!---
+    nbfiles =  nbfiles+1
+    filelist(nbfiles) = TRIM(ADJUSTL(tmp_str))
+!---
+    last_key = 'INCLUDEDEF'
+    nb_lastkey = 1
+  ELSE
+!-
+!-- We are working on a new line of input
+!-
+    IF (nb_lines+1 > i_txtsize) THEN
+      CALL getin_alloctxt ()
+    ENDIF
+    nb_lines = nb_lines+1
+!-
+!-- First we solve the issue of conpressed information. Once
+!-- this is done all line can be handled in the same way.
+!-
+    starpos = INDEX(NEW_str(1:len_str),'*')
+    IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') &
+ &                    .AND.(tmp_str(1:1) /= "'") ) THEN
+!-----
+      IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN
+        CALL ipslerr (3,'getin_decrypt', &
+ &       'We can not have a compressed field of values', &
+ &       'in a vector notation (TARGET__n).', &
+ &       'The key at fault : '//TRIM(key_str))
+      ENDIF
+!-
+!---- Read the multiplied
+!-
+      mult = TRIM(ADJUSTL(NEW_str(1:starpos-1)))
+!---- Construct the new string and its parameters
+      NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str)))
+      len_str = LEN_TRIM(NEW_str)
+      blk = INDEX(NEW_str(1:len_str),' ')
+      IF (blk > 1) THEN
+        CALL ipslerr (2,'getin_decrypt', &
+ &       'This is a strange behavior','you could report',' ')
+      ENDIF
+      WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult)
+      READ(UNIT=mult,FMT=c_fmt) compline(nb_lines)
+!---
+    ELSE
+      compline(nb_lines) = -1
+    ENDIF
+!-
+!-- If there is no space wthin the line then the target is a scalar
+!-- or the element of a properly written vector.
+!-- (ie of the type TARGET__00001)
+!-
+    IF (    (blk <= 1) &
+ &      .OR.(tmp_str(1:1) == '"') &
+ &      .OR.(tmp_str(1:1) == "'") ) THEN
+!-
+      IF (nb_lastkey == 0) THEN
+!------ Save info of current keyword as a scalar
+!------ if it is not a continuation
+        targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n))
+        last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n))
+        nb_lastkey = 1
+      ELSE
+!------ We are continuing a vector so the keyword needs
+!------ to get the underscores
+        WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1
+        targetlist(nb_lines) = &
+ &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+        last_key = &
+ &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+        nb_lastkey = nb_lastkey+1
+      ENDIF
+!-----
+      fichier(nb_lines) = NEW_str(1:len_str)
+      fromfile(nb_lines) = current
+    ELSE
+!-
+!---- If there are blanks whithin the line then we are dealing
+!---- with a vector and we need to split it in many entries
+!---- with the TARGET__n notation.
+!----
+!---- Test if the targer is not already a vector target !
+!-
+      IF (INDEX(TRIM(key_str),'__') > 0) THEN
+        CALL ipslerr (3,'getin_decrypt', &
+ &       'We have found a mixed vector notation (TARGET__n).', &
+ &       'The key at fault : '//TRIM(key_str),' ')
+      ENDIF
+!-
+      nbve = nb_lastkey
+      nbve = nbve+1
+      WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
+!-
+      DO WHILE (blk > 0)
+!-
+!------ Save the content of target__nbve
+!-
+        fichier(nb_lines) = tmp_str(1:blk)
+        new_key = &
+ &       key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+        targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
+        fromfile(nb_lines) = current
+!-
+        tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
+        blk = INDEX(TRIM(tmp_str),' ')
+!-
+        IF (nb_lines+1 > i_txtsize) THEN
+          CALL getin_alloctxt ()
+        ENDIF
+        nb_lines = nb_lines+1
+        nbve = nbve+1
+        WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
+        compline(nb_lines)=compline(nb_lines-1)
+!-
+      ENDDO
+!-
+!---- Save the content of the last target
+!-
+      fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str))
+      new_key = &
+ &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+      targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
+      fromfile(nb_lines) = current
+!-
+      last_key = &
+ &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+      nb_lastkey = nbve
+!-
+    ENDIF
+!-
+  ENDIF
+
+  IF (l_dbg) THEN
+     WRITE(ipslout,*) "getin_decrypt ->",TRIM(NEW_str), " : "
+     WRITE(ipslout,*) "getin_decrypt ->", nb_lines,&
+          & SIZE(fichier), &
+          & SIZE(fromfile), &
+          & SIZE(filelist)
+     IF (nb_lines > 0) THEN
+        WRITE(ipslout,*) "getin_decrypt ->", &
+          & TRIM(fichier(nb_lines)), &
+          & fromfile(nb_lines), &
+          & TRIM(filelist(fromfile(nb_lines)))
+        WRITE(ipslout,*) "                compline : ",compline(nb_lines)
+        WRITE(ipslout,*) "                targetlist : ",TRIM(targetlist(nb_lines))
+     ENDIF
+     WRITE(ipslout,*) "                last_key : ",last_key
+  ENDIF
+!---------------------------
+END SUBROUTINE getin_decrypt
+!-
+!===
+!-
+SUBROUTINE getin_checkcohe ()
+!---------------------------------------------------------------------
+!- This subroutine checks for redundancies.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: line,n_k,k
+!---------------------------------------------------------------------
+  DO line=1,nb_lines-1
+!-
+    n_k = 0
+    DO k=line+1,nb_lines
+      IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN
+        n_k = k
+        EXIT
+      ENDIF
+    ENDDO
+!---
+!-- IF we have found it we have a problem to solve.
+!---
+    IF (n_k > 0) THEN
+      WRITE(ipslout,*) 'COUNT : ',n_k
+      WRITE(ipslout,*) &
+ &  'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line))
+      WRITE(ipslout,*) &
+ &  'getin_checkcohe : The following values were encoutered :'
+      WRITE(ipslout,*) &
+ &  '                ',TRIM(targetlist(line)),' == ',fichier(line)
+      WRITE(ipslout,*) &
+ &  '                ',TRIM(targetlist(k)),' == ',fichier(k)
+      WRITE(ipslout,*) &
+ &  'getin_checkcohe : We will keep only the last value'
+       CALL ipslerr (2,'getin_checkcohe','Found a problem on key ', &
+ &                     TRIM(targetlist(line)), fichier(line)//" "//fichier(k))
+      targetlist(line) = ' '
+    ENDIF
+  ENDDO
+!-----------------------------
+END SUBROUTINE getin_checkcohe
+!-
+!===
+!-
+SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: unit,eof,nb_lastkey
+  CHARACTER(LEN=100) :: dummy
+  CHARACTER(LEN=100),INTENT(out) :: out_string
+  CHARACTER(LEN=1) :: first
+!---------------------------------------------------------------------
+  first="#"
+  eof = 0
+  out_string = "    "
+!-
+  DO WHILE (first == "#")
+    READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy
+    dummy = TRIM(ADJUSTL(dummy))
+    first=dummy(1:1)
+    IF (first == "#") THEN
+      nb_lastkey = 0
+    ENDIF
+  ENDDO
+  out_string=dummy
+!-
+  RETURN
+!-
+9998 CONTINUE
+  CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ')
+!-
+7778 CONTINUE
+  eof = 1
+!----------------------------
+END SUBROUTINE getin_skipafew
+!-
+!===
+!-
+SUBROUTINE getin_allockeys ()
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab
+!-
+  INTEGER :: ier
+  CHARACTER(LEN=20) :: c_tmp
+!---------------------------------------------------------------------
+  IF (keymemsize == 0) THEN
+!---
+!-- Nothing exists in memory arrays and it is easy to do.
+!---
+    WRITE (UNIT=c_tmp,FMT=*) memslabs
+    ALLOCATE(key_tab(memslabs),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_allockeys', &
+ &     'Can not allocate key_tab', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+    ENDIF
+    nb_keys = 0
+    keymemsize = memslabs
+    key_tab(:)%keycompress = -1
+!---
+  ELSE
+!---
+!-- There is something already in the memory,
+!-- we need to transfer and reallocate.
+!---
+    WRITE (UNIT=c_tmp,FMT=*) keymemsize
+    ALLOCATE(tmp_key_tab(keymemsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_allockeys', &
+ &     'Can not allocate tmp_key_tab', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+    ENDIF
+    WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs
+    tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize)
+    DEALLOCATE(key_tab)
+    ALLOCATE(key_tab(keymemsize+memslabs),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_allockeys', &
+ &     'Can not allocate key_tab', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+    ENDIF
+    key_tab(:)%keycompress = -1
+    key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize)
+    DEALLOCATE(tmp_key_tab)
+    keymemsize = keymemsize+memslabs
+  ENDIF
+!-----------------------------
+END SUBROUTINE getin_allockeys
+!-
+!===
+!-
+SUBROUTINE getin_allocmem (type,len_wanted)
+!---------------------------------------------------------------------
+!- Allocate the memory of the data base for all 4 types of memory
+!- INTEGER / REAL / CHARACTER / LOGICAL
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: type,len_wanted
+!-
+  INTEGER,ALLOCATABLE :: tmp_int(:)
+  REAL,ALLOCATABLE :: tmp_real(:)
+  CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:)
+  LOGICAL,ALLOCATABLE :: tmp_logic(:)
+  INTEGER :: ier
+  CHARACTER(LEN=20) :: c_tmp
+!---------------------------------------------------------------------
+  SELECT CASE (type)
+  CASE(k_i)
+    IF (i_memsize == 0) THEN
+      ALLOCATE(i_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      i_memsize=memslabs
+    ELSE
+      ALLOCATE(tmp_int(i_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) i_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_int', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_int(1:i_memsize) = i_mem(1:i_memsize)
+      DEALLOCATE(i_mem)
+      ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      i_mem(1:i_memsize) = tmp_int(1:i_memsize)
+      i_memsize = i_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_int)
+    ENDIF
+  CASE(k_r)
+    IF (r_memsize == 0) THEN
+      ALLOCATE(r_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      r_memsize =  memslabs
+    ELSE
+      ALLOCATE(tmp_real(r_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) r_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_real', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_real(1:r_memsize) = r_mem(1:r_memsize)
+      DEALLOCATE(r_mem)
+      ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      r_mem(1:r_memsize) = tmp_real(1:r_memsize)
+      r_memsize = r_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_real)
+    ENDIF
+  CASE(k_c)
+    IF (c_memsize == 0) THEN
+      ALLOCATE(c_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      c_memsize = memslabs
+    ELSE
+      ALLOCATE(tmp_char(c_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) c_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_char', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_char(1:c_memsize) = c_mem(1:c_memsize)
+      DEALLOCATE(c_mem)
+      ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      c_mem(1:c_memsize) = tmp_char(1:c_memsize)
+      c_memsize = c_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_char)
+    ENDIF
+  CASE(k_l)
+    IF (l_memsize == 0) THEN
+      ALLOCATE(l_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      l_memsize = memslabs
+    ELSE
+      ALLOCATE(tmp_logic(l_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) l_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_logic', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_logic(1:l_memsize) = l_mem(1:l_memsize)
+      DEALLOCATE(l_mem)
+      ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      l_mem(1:l_memsize) = tmp_logic(1:l_memsize)
+      l_memsize = l_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_logic)
+    ENDIF
+  CASE DEFAULT
+    CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ')
+  END SELECT
+!----------------------------
+END SUBROUTINE getin_allocmem
+!-
+!===
+!-
+SUBROUTINE getin_alloctxt ()
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:)
+  CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:)
+  INTEGER,ALLOCATABLE :: tmp_int(:)
+!-
+  INTEGER :: ier
+  CHARACTER(LEN=20) :: c_tmp1,c_tmp2
+!---------------------------------------------------------------------
+  IF (i_txtsize == 0) THEN
+!---
+!-- Nothing exists in memory arrays and it is easy to do.
+!---
+    WRITE (UNIT=c_tmp1,FMT=*) i_txtslab
+    ALLOCATE(fichier(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fichier', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    ALLOCATE(targetlist(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate targetlist', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    ALLOCATE(fromfile(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fromfile', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    ALLOCATE(compline(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate compline', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    nb_lines = 0
+    i_txtsize = i_txtslab
+  ELSE
+!---
+!-- There is something already in the memory,
+!-- we need to transfer and reallocate.
+!---
+    WRITE (UNIT=c_tmp1,FMT=*) i_txtsize
+    WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab
+    ALLOCATE(tmp_fic(i_txtsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate tmp_fic', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+    tmp_fic(1:i_txtsize) = fichier(1:i_txtsize)
+    DEALLOCATE(fichier)
+    ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fichier', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    fichier(1:i_txtsize) = tmp_fic(1:i_txtsize)
+    DEALLOCATE(tmp_fic)
+!---
+    ALLOCATE(tmp_tgl(i_txtsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate tmp_tgl', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+    tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize)
+    DEALLOCATE(targetlist)
+    ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate targetlist', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize)
+    DEALLOCATE(tmp_tgl)
+!---
+    ALLOCATE(tmp_int(i_txtsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate tmp_int', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+    tmp_int(1:i_txtsize) = fromfile(1:i_txtsize)
+    DEALLOCATE(fromfile)
+    ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fromfile', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    fromfile(1:i_txtsize) = tmp_int(1:i_txtsize)
+!---
+    tmp_int(1:i_txtsize) = compline(1:i_txtsize)
+    DEALLOCATE(compline)
+    ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate compline', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    compline(1:i_txtsize) = tmp_int(1:i_txtsize)
+    DEALLOCATE(tmp_int)
+!---
+    i_txtsize = i_txtsize+i_txtslab
+  ENDIF
+!----------------------------
+END SUBROUTINE getin_alloctxt
+!-
+!===
+!-
+SUBROUTINE getin_dump (fileprefix)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(*),OPTIONAL :: fileprefix
+!-
+  CHARACTER(LEN=80) :: usedfileprefix
+  INTEGER :: ikey,if,iff,iv
+  CHARACTER(LEN=20) :: c_tmp
+  CHARACTER(LEN=100) :: tmp_str,used_filename
+  INTEGER :: io_err
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!---------------------------------------------------------------------
+  IF (PRESENT(fileprefix)) THEN
+    usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80))
+  ELSE
+    usedfileprefix = "used"
+  ENDIF
+!-
+  DO if=1,nbfiles
+!---
+    used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if))
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) &
+ &      'getin_dump : opens file : ',TRIM(used_filename),' if = ',if
+      WRITE(ipslout,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys
+    ENDIF
+    OPEN (UNIT=22,FILE=used_filename,iostat=io_err)
+    IF (io_err /= 0) THEN
+       CALL ipslerr (3,'getin_dump', &
+            &   'Could not open file :',TRIM(used_filename), &
+            &   '')
+    ENDIF
+!---
+!-- If this is the first file we need to add the list
+!-- of file which belong to it
+    IF ( (if == 1).AND.(nbfiles > 1) ) THEN
+      WRITE(22,*) '# '
+      WRITE(22,*) '# This file is linked to the following files :'
+      WRITE(22,*) '# '
+      DO iff=2,nbfiles
+        WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff))
+      ENDDO
+      WRITE(22,*) '# '
+      IF (l_dbg) THEN
+         WRITE(ipslout,*) '# '
+         WRITE(ipslout,*) '# This file is linked to the following files :'
+         WRITE(ipslout,*) '# '
+         DO iff=2,nbfiles
+            WRITE(ipslout,*) 'INCLUDEDEF = ',TRIM(filelist(iff))
+         ENDDO
+         WRITE(ipslout,*) '# '
+      ENDIF
+    ENDIF
+!---
+    DO ikey=1,nb_keys
+!-----
+!---- Is this key from this file ?
+      IF (key_tab(ikey)%keyfromfile == if) THEN
+!-------
+!------ Write some comments
+        WRITE(22,*) '#'
+        SELECT CASE (key_tab(ikey)%keystatus)
+        CASE(nondefault)
+          WRITE(22,*) '# Values of ', &
+ &          TRIM(key_tab(ikey)%keystr),' comes from ',TRIM(def_file)
+        CASE(default)
+          WRITE(22,*) '# Values of ', &
+ &          TRIM(key_tab(ikey)%keystr),' are all defaults.'
+        CASE(vectornondefault)
+          WRITE(22,*) '# Values of ', &
+ &          TRIM(key_tab(ikey)%keystr), &
+ &          ' are a mix of ',TRIM(def_file),' and defaults.'
+        CASE DEFAULT
+          WRITE(22,*) '# Dont know from where the value of ', &
+ &          TRIM(key_tab(ikey)%keystr),' comes.'
+        END SELECT
+        WRITE(22,*) '#'
+        !-
+        IF (l_dbg) THEN
+           WRITE(ipslout,*) '#'
+           WRITE(ipslout,*) '# Status of key ', ikey, ' : ',&
+ &          TRIM(key_tab(ikey)%keystr),key_tab(ikey)%keystatus
+        ENDIF
+!-------
+!------ Write the values
+        SELECT CASE (key_tab(ikey)%keytype)
+        CASE(k_i)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            IF (key_tab(ikey)%keycompress < 0) THEN
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',i_mem(key_tab(ikey)%keymemstart)
+            ELSE
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',key_tab(ikey)%keycompress, &
+ &              ' * ',i_mem(key_tab(ikey)%keymemstart)
+            ENDIF
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              '__',TRIM(ADJUSTL(c_tmp)), &
+ &              ' = ',i_mem(key_tab(ikey)%keymemstart+iv)
+            ENDDO
+          ENDIF
+        CASE(k_r)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            IF (key_tab(ikey)%keycompress < 0) THEN
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',r_mem(key_tab(ikey)%keymemstart)
+            ELSE
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',key_tab(ikey)%keycompress, &
+                   & ' * ',r_mem(key_tab(ikey)%keymemstart)
+            ENDIF
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), &
+ &              ' = ',r_mem(key_tab(ikey)%keymemstart+iv)
+            ENDDO
+          ENDIF
+        CASE(k_c)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            tmp_str = c_mem(key_tab(ikey)%keymemstart)
+            WRITE(22,*) TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',TRIM(tmp_str)
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              tmp_str = c_mem(key_tab(ikey)%keymemstart+iv)
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              '__',TRIM(ADJUSTL(c_tmp)), &
+ &              ' = ',TRIM(tmp_str)
+            ENDDO
+          ENDIF
+        CASE(k_l)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            IF (l_mem(key_tab(ikey)%keymemstart)) THEN
+              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE '
+            ELSE
+              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE '
+            ENDIF
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN
+                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
+ &                          TRIM(ADJUSTL(c_tmp)),' = TRUE '
+              ELSE
+                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
+ &                          TRIM(ADJUSTL(c_tmp)),' = FALSE '
+              ENDIF
+            ENDDO
+          ENDIF
+        CASE DEFAULT
+          CALL ipslerr (3,'getin_dump', &
+ &         'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), &
+ &         ' ',' ')
+        END SELECT
+      ENDIF
+    ENDDO
+!-
+    CLOSE(UNIT=22)
+!-
+  ENDDO
+!------------------------
+END SUBROUTINE getin_dump
+!===
+SUBROUTINE getin_dump_para (fileprefix,rank)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(*) :: fileprefix
+  INTEGER,INTENT(IN) :: rank
+!-
+  CHARACTER(LEN=80) :: usedfileprefix
+  LOGICAL :: l_dbg
+  INTEGER :: isize
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!---------------------------------------------------------------------
+  IF ( rank < 1000 ) THEN
+     isize=MIN(LEN_TRIM(fileprefix),75)
+     usedfileprefix = fileprefix(1:isize)
+     usedfileprefix((isize+1):(isize+1))='_'
+     WRITE(usedfileprefix((isize+2):(isize+5)),'(I4.4)') rank
+     IF (l_dbg) &
+          WRITE(ipslout,*) 'Dump getin to file ',usedfileprefix
+     CALL getin_dump(usedfileprefix)
+  ENDIF
+!------------------------
+END SUBROUTINE getin_dump_para
+
+!===
+SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v)
+!---------------------------------------------------------------------
+!- Returns the type of the argument (mutually exclusive)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(OUT) :: k_typ
+  CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_v
+  REAL,DIMENSION(:),OPTIONAL             :: r_v
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_v
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v
+!---------------------------------------------------------------------
+  k_typ = 0
+  IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) &
+ &    /= 1) THEN
+    CALL ipslerr (3,'get_qtyp', &
+ &   'Invalid number of optional arguments','(/= 1)',' ')
+  ENDIF
+!-
+  IF     (PRESENT(i_v)) THEN
+    k_typ = k_i
+    c_vtyp = 'INTEGER'
+  ELSEIF (PRESENT(r_v)) THEN
+    k_typ = k_r
+    c_vtyp = 'REAL'
+  ELSEIF (PRESENT(c_v)) THEN
+    k_typ = k_c
+    c_vtyp = 'CHARACTER'
+  ELSEIF (PRESENT(l_v)) THEN
+    k_typ = k_l
+    c_vtyp = 'LOGICAL'
+  ENDIF
+!----------------------
+END SUBROUTINE get_qtyp
+!===
+SUBROUTINE get_findkey (i_tab,c_key,pos)
+!---------------------------------------------------------------------
+!- This subroutine looks for a key in a table
+!---------------------------------------------------------------------
+!- INPUT
+!-   i_tab  : 1 -> search in key_tab(1:nb_keys)%keystr
+!-            2 -> search in targetlist(1:nb_lines)
+!-   c_key  : Name of the key we are looking for
+!- OUTPUT
+!-   pos    : -1 if key not found, else value in the table
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(in) :: i_tab
+  CHARACTER(LEN=*),INTENT(in) :: c_key
+  INTEGER,INTENT(out) :: pos
+!-
+  INTEGER :: ikey_max,ikey
+  CHARACTER(LEN=l_n) :: c_q_key
+!---------------------------------------------------------------------
+  pos = -1
+  IF     (i_tab == 1) THEN
+    ikey_max = nb_keys
+  ELSEIF (i_tab == 2) THEN
+    ikey_max = nb_lines
+  ELSE
+    ikey_max = 0
+  ENDIF
+  IF ( ikey_max > 0 ) THEN
+    DO ikey=1,ikey_max
+      IF (i_tab == 1) THEN
+        c_q_key = key_tab(ikey)%keystr
+      ELSE
+        c_q_key = targetlist(ikey)
+      ENDIF
+      IF (TRIM(c_q_key) == TRIM(c_key)) THEN
+        pos = ikey
+        EXIT
+      ENDIF
+    ENDDO
+  ENDIF
+!-------------------------
+END SUBROUTINE get_findkey
+!===
+!------------------
+END MODULE getincom
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/histcom.f90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/histcom.f90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/histcom.f90	(revision 17)
@@ -0,0 +1,2520 @@
+MODULE histcom
+!-
+!$Id: histcom.f90 2065 2013-05-16 11:56:50Z jgipsl $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!-
+  USE netcdf
+!-
+  USE stringop, ONLY : nocomma,cmpblank,findpos,find_str,strlowercase
+  USE mathelp,  ONLY : mathop,moycum,moycum_index,buildop
+  USE fliocom,  ONLY : flio_dom_file,flio_dom_att
+  USE calendar
+  USE errioipsl, ONLY : ipslerr,ipsldbg,ipslout
+!-
+  IMPLICIT NONE
+!-
+  PRIVATE
+  PUBLIC :: histbeg,histdef,histhori,histvert,histend, &
+ &          histwrite,histclo,histsync,ioconf_modname, histglobal_attr
+!---------------------------------------------------------------------
+!- Some confusing vocabulary in this code !
+!- =========================================
+!-
+!- A REGULAR grid is a grid which is i,j indexes
+!- and thus it is stored in a 2D matrix.
+!- This is opposed to a IRREGULAR grid which is only in a vector
+!- and where we do not know which neighbors we have.
+!- As a consequence we need the bounds for each grid-cell.
+!-
+!- A RECTILINEAR grid is a special case of a regular grid
+!- in which all longitudes for i constant are equal
+!- and all latitudes for j constant.
+!- In other words we do not need the full 2D matrix
+!- to describe the grid, just two vectors.
+!---------------------------------------------------------------------
+!-
+  INTERFACE histbeg
+    MODULE PROCEDURE histb_reg1d,histb_reg2d,histb_irreg
+  END INTERFACE
+!-
+  INTERFACE histhori
+    MODULE PROCEDURE histh_reg1d,histh_reg2d,histh_irreg
+  END INTERFACE
+!-
+  INTERFACE histwrite
+!---------------------------------------------------------------------
+!- The "histwrite" routines will give the data to the I/O system.
+!- It will trigger the operations to be performed,
+!- and the writting to the file if needed
+!-
+!- We test for the work to be done at this time here so that at a
+!- later stage we can call different operation and write subroutine
+!- for the REAL and INTEGER interfaces
+!-
+!- INPUT
+!- idf      : The ID of the file on which this variable is to be,
+!-            written. The variable should have been defined in
+!-            this file before.
+!- pvarname : The short name of the variable
+!- pitau    : Current timestep
+!- pdata    : The variable, I mean the real data !
+!- nbindex  : The number of indexes provided. If it is equal to
+!-            the size of the full field as provided in histdef
+!-            then nothing is done.
+!- nindex   : The indices used to expand the variable (pdata)
+!-            onto the full field.
+!---------------------------------------------------------------------
+!- histwrite - we have to prepare different type of fields :
+!-             real and integer, 1,2 or 3D
+    MODULE PROCEDURE histwrite_r1d,histwrite_r2d,histwrite_r3d
+  END INTERFACE
+!-
+! Fixed parameter
+!-
+  INTEGER,PARAMETER :: nb_files_max=20,nb_var_max=600, &
+ &                     nb_hax_max=5,nb_zax_max=10,nbopp_max=10
+  REAL,PARAMETER :: missing_val=nf90_fill_real
+  INTEGER,PARAMETER,PUBLIC :: &
+ &  hist_r4=nf90_real4, hist_r8=nf90_real8
+!-
+! Variable derived type
+!-
+TYPE T_D_V
+  INTEGER :: ncvid
+  INTEGER :: nbopp
+  CHARACTER(LEN=20)  :: v_name,unit_name
+  CHARACTER(LEN=256) :: title,std_name
+  CHARACTER(LEN=80)  :: fullop
+  CHARACTER(LEN=7)   :: topp
+  CHARACTER(LEN=7),DIMENSION(nbopp_max) :: sopp
+  REAL,DIMENSION(nbopp_max) :: scal
+!-External type (for R4/R8)
+  INTEGER :: v_typ
+!-Sizes of the associated grid and zommed area
+  INTEGER,DIMENSION(3) :: scsize,zorig,zsize
+!-Sizes for the data as it goes through the various math operations
+  INTEGER,DIMENSION(3) :: datasz_in = -1
+  INTEGER :: datasz_max = -1
+!-
+  INTEGER :: h_axid,z_axid,t_axid
+!-
+  REAL,DIMENSION(2) :: hist_minmax
+  LOGICAL :: hist_calc_rng=.FALSE.,hist_wrt_rng=.FALSE.
+!-Book keeping of the axes
+  INTEGER :: tdimid,tbndid=-1,tax_last
+  LOGICAL :: l_bnd
+  CHARACTER(LEN=40) :: tax_name
+!-
+  REAL :: freq_opp,freq_wrt
+  INTEGER :: &
+ &  last_opp,last_wrt,last_opp_chk,last_wrt_chk,nb_opp,nb_wrt
+!- For future optimization
+  REAL,POINTER,DIMENSION(:) :: t_bf
+!#  REAL,ALLOCATABLE,DIMENSION(:) :: V_1_D
+!#  REAL,ALLOCATABLE,DIMENSION(:,:) :: V_2_D
+!#  REAL,ALLOCATABLE,DIMENSION(:,:,:) :: V_3_D
+END TYPE T_D_V
+!-
+! File derived type
+!-
+TYPE :: T_D_F
+!-NETCDF IDs for file
+  INTEGER :: ncfid=-1
+!-Name of the file
+  CHARACTER(LEN=120) :: name
+!-Time variables
+  INTEGER :: itau0=0
+  REAL :: date0,deltat
+!-Counter of elements (variables, time-horizontal-vertical axis
+  INTEGER :: n_var=0,n_tax=0,n_hax=0,n_zax=0
+!-NETCDF dimension IDs for time-[time_bounds]-longitude-latitude
+  INTEGER :: tid,bid,xid,yid
+!-General definitions in the NETCDF file
+  INTEGER,DIMENSION(2) :: full_size=0,slab_ori,slab_siz
+!-The horizontal axes
+  CHARACTER(LEN=25),DIMENSION(nb_hax_max,2) :: hax_name
+!-The vertical axes
+  INTEGER,DIMENSION(nb_zax_max) :: zax_size,zax_ids
+  CHARACTER(LEN=20),DIMENSION(nb_zax_max) :: zax_name
+!-
+  LOGICAL :: regular=.TRUE.
+!-DOMAIN ID
+  INTEGER :: dom_id_svg=-1
+!-
+  TYPE(T_D_V),DIMENSION(nb_var_max) :: W_V
+END TYPE T_D_F
+!-
+TYPE(T_D_F),DIMENSION(nb_files_max),SAVE :: W_F
+!-
+! A list of functions which require special action
+! (Needs to be updated when functions are added
+!  but they are well located here)
+!-
+  CHARACTER(LEN=30),SAVE :: fuchnbout = 'scatter, fill'
+!- Some configurable variables with locks
+  CHARACTER(LEN=80),SAVE :: model_name='An IPSL model'
+  LOGICAL,SAVE :: lock_modname=.FALSE.
+!-
+!===
+CONTAINS
+!===
+!-
+SUBROUTINE histb_reg1d                 &
+ & (pfilename,pim,plon,pjm,plat,       &
+ &  par_orix,par_szx,par_oriy,par_szy, &
+ &  pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode)
+!---------------------------------------------------------------------
+!- histbeg for 1D regular horizontal coordinates (see histb_all)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: pfilename
+  INTEGER,INTENT(IN) :: pim,pjm
+  REAL,DIMENSION(pim),INTENT(IN) :: plon
+  REAL,DIMENSION(pjm),INTENT(IN) :: plat
+  INTEGER,INTENT(IN):: par_orix,par_szx,par_oriy,par_szy
+  INTEGER,INTENT(IN) :: pitau0
+  REAL,INTENT(IN) :: pdate0,pdeltat
+  INTEGER,INTENT(OUT) :: idf,phoriid
+  INTEGER,INTENT(IN),OPTIONAL :: domain_id
+  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode
+!---------------------------------------------------------------------
+  CALL histb_all &
+ & (1,pfilename,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, &
+ &  x_1d=plon,y_1d=plat, &
+ &  k_orx=par_orix,k_szx=par_szx,k_ory=par_oriy,k_szy=par_szy, &
+ &  domain_id=domain_id,mode=mode)
+!-------------------------
+END SUBROUTINE histb_reg1d
+!===
+SUBROUTINE histb_reg2d &
+ & (pfilename,pim,plon,pjm,plat,       &
+ &  par_orix,par_szx,par_oriy,par_szy, &
+ &  pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode)
+!---------------------------------------------------------------------
+!- histbeg for 2D regular horizontal coordinates (see histb_all)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: pfilename
+  INTEGER,INTENT(IN) :: pim,pjm
+  REAL,DIMENSION(pim,pjm),INTENT(IN) :: plon,plat
+  INTEGER,INTENT(IN):: par_orix,par_szx,par_oriy,par_szy
+  INTEGER,INTENT(IN) :: pitau0
+  REAL,INTENT(IN) :: pdate0,pdeltat
+  INTEGER,INTENT(OUT) :: idf,phoriid
+  INTEGER,INTENT(IN),OPTIONAL :: domain_id
+  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode
+!---------------------------------------------------------------------
+  CALL histb_all &
+ & (2,pfilename,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf,  &
+ &  x_2d=plon,y_2d=plat, &
+ &  k_orx=par_orix,k_szx=par_szx,k_ory=par_oriy,k_szy=par_szy,    &
+ &  domain_id=domain_id,mode=mode)
+!-------------------------
+END SUBROUTINE histb_reg2d
+!===
+SUBROUTINE histb_irreg &
+ &  (pfilename,pim,plon,plon_bounds,plat,plat_bounds, &
+ &   pitau0,pdate0,pdeltat,phoriid,idf,domain_id,mode)
+!---------------------------------------------------------------------
+!- histbeg for irregular horizontal coordinates (see histb_all)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: pfilename
+  INTEGER,INTENT(IN) :: pim
+  REAL,DIMENSION(pim),INTENT(IN) :: plon,plat
+  REAL,DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds
+  INTEGER,INTENT(IN) :: pitau0
+  REAL,INTENT(IN) :: pdate0,pdeltat
+  INTEGER,INTENT(OUT) :: idf,phoriid
+  INTEGER,INTENT(IN),OPTIONAL :: domain_id
+  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode
+!---------------------------------------------------------------------
+  CALL histb_all &
+ & (3,pfilename,pim,pim,pitau0,pdate0,pdeltat,phoriid,idf,  &
+ &  x_1d=plon,y_1d=plat,x_bnds=plon_bounds,y_bnds=plat_bounds, &
+ &  domain_id=domain_id,mode=mode)
+!-------------------------
+END SUBROUTINE histb_irreg
+!===
+SUBROUTINE histb_all &
+ & (k_typ,nc_name,pim,pjm,pitau0,pdate0,pdeltat,phoriid,idf, &
+ &  x_1d,y_1d,x_2d,y_2d,k_orx,k_szx,k_ory,k_szy, &
+ &  x_bnds,y_bnds,domain_id,mode)
+!---------------------------------------------------------------------
+!- General interface for horizontal grids.
+!- This subroutine initializes a netcdf file and returns the ID.
+!- It will set up the geographical space on which the data will be
+!- stored and offers the possibility of seting a zoom.
+!- In the case of irregular grids, all the data comes in as vectors
+!- and for the grid we have the coordinates of the 4 corners.
+!- It also gets the global parameters into the I/O subsystem.
+!-
+!- INPUT
+!-
+!- k_typ    : Type of the grid (1 rectilinear, 2 regular, 3 irregular)
+!- nc_name  : Name of the netcdf file to be created
+!- pim      : Size of arrays in longitude direction
+!- pjm      : Size of arrays in latitude direction (pjm=pim for type 3)
+!-
+!- pitau0   : time step at which the history tape starts
+!- pdate0   : The Julian date at which the itau was equal to 0
+!- pdeltat  : Time step, in seconds, of the counter itau
+!-            used in histwrite for instance
+!-
+!- OUTPUT
+!-
+!- phoriid  : Identifier of the horizontal grid
+!- idf      : Identifier of the file
+!-
+!- Optional INPUT arguments
+!-
+!- For rectilinear or irregular grid
+!- x_1d  : The longitudes
+!- y_1d  : The latitudes
+!- For regular grid
+!- x_2d  : The longitudes
+!- y_2d  : The latitudes
+!- One pair (x_1d,y_1d) or (x_2d,y_2d) must be supplied.
+!-
+!- For regular grid (reg1d or reg2d),
+!- the next 4 arguments allow to define a horizontal zoom
+!- for this file. It is assumed that all variables to come
+!- have the same index space. This can not be assumed for
+!- the z axis and thus we define the zoom in histdef.
+!- k_orx  : Origin of the slab of data within the X axis (pim)
+!- k_szx  : Size of the slab of data in X
+!- k_ory  : Origin of the slab of data within the Y axis (pjm)
+!- k_szy  : Size of the slab of data in Y
+!-
+!- For irregular grid.
+!- x_bnds : The boundaries of the grid in longitude
+!- y_bnds : The boundaries of the grid in latitude
+!-
+!- For all grids.
+!-
+!- domain_id  : Domain identifier
+!-
+!- mode       : String of (case insensitive) blank-separated words
+!-              defining the mode used to create the file.
+!-              Supported keywords : 32, 64
+!-              "32/64" defines the offset mode.
+!-              The default offset mode is 64 bits.
+!-              Keywords "NETCDF4" and "CLASSIC" are reserved
+!-              for future use.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: k_typ
+  CHARACTER(LEN=*),INTENT(IN) :: nc_name
+  INTEGER,INTENT(IN) :: pim,pjm
+  INTEGER,INTENT(IN) :: pitau0
+  REAL,INTENT(IN) :: pdate0,pdeltat
+  INTEGER,INTENT(OUT) :: idf,phoriid
+  REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d
+  REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d
+  INTEGER,INTENT(IN),OPTIONAL :: k_orx,k_szx,k_ory,k_szy
+  REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_bnds,y_bnds
+  INTEGER,INTENT(IN),OPTIONAL :: domain_id
+  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: mode
+!-
+  INTEGER :: nfid,iret,m_c
+  CHARACTER(LEN=120) :: file
+  CHARACTER(LEN=30) :: timenow
+  CHARACTER(LEN=11) :: c_nam
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF     (k_typ == 1) THEN
+    c_nam = 'histb_reg1d'
+  ELSEIF (k_typ == 2) THEN
+    c_nam = 'histb_reg2d'
+  ELSEIF (k_typ == 3) THEN
+    c_nam = 'histb_irreg'
+  ELSE
+    CALL ipslerr (3,"histbeg", &
+ &    'Illegal value of k_typ argument','in internal interface','?')
+  ENDIF
+!-
+  IF (l_dbg) WRITE(ipslout,*) c_nam//" 0.0"
+!-
+! Search for a free index
+!-
+  idf = -1
+  DO nfid=1,nb_files_max
+    IF (W_F(nfid)%ncfid < 0) THEN
+      idf = nfid; EXIT;
+    ENDIF
+  ENDDO
+  IF (idf < 0) THEN
+    CALL ipslerr (3,"histbeg", &
+   &  'Table of files too small. You should increase nb_files_max', &
+   &  'in histcom.f90 in order to accomodate all these files',' ')
+  ENDIF
+!-
+! 1.0 Transfering into the common for future use
+!-
+  IF (l_dbg) WRITE(ipslout,*) c_nam//" 1.0"
+!-
+  W_F(idf)%itau0  = pitau0
+  W_F(idf)%date0  = pdate0
+  W_F(idf)%deltat = pdeltat
+!-
+! 2.0 Initializes all variables for this file
+!-
+  IF (l_dbg) WRITE(ipslout,*) c_nam//" 2.0"
+!-
+  W_F(idf)%n_var = 0
+  W_F(idf)%n_tax = 0
+  W_F(idf)%n_hax = 0
+  W_F(idf)%n_zax = 0
+!-
+  IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN
+    W_F(idf)%slab_ori(1:2) = (/ k_orx,k_ory /)
+    W_F(idf)%slab_siz(1:2)  = (/ k_szx,k_szy /)
+  ELSE
+    W_F(idf)%slab_ori(1:2) = (/ 1,1 /)
+    W_F(idf)%slab_siz(1:2) = (/ pim,1 /)
+  ENDIF
+!-
+! 3.0 Opening netcdf file and defining dimensions
+!-
+  IF (l_dbg) WRITE(ipslout,*) c_nam//" 3.0"
+!-
+! Add DOMAIN number and ".nc" suffix in file name if needed
+!-
+  file = nc_name
+  CALL flio_dom_file (file,domain_id)
+!-
+! Check the mode
+!? See fliocom for HDF4 ????????????????????????????????????????????????
+!-
+  IF (PRESENT(mode)) THEN
+    SELECT CASE (TRIM(mode))
+    CASE('32')
+      m_c = NF90_CLOBBER
+    CASE('64')
+      m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET)
+    CASE DEFAULT
+      CALL ipslerr (3,"histbeg", &
+ &      'Invalid argument mode for file :',TRIM(file), &
+ &      'Supported values are 32 or 64')
+    END SELECT
+  ELSE
+    m_c = IOR(NF90_CLOBBER,NF90_64BIT_OFFSET)
+  ENDIF
+!-
+! Create file
+!-
+  iret = NF90_CREATE(file,m_c,nfid)
+!-
+  IF     (k_typ == 1) THEN
+    iret = NF90_DEF_DIM(nfid,'lon',k_szx,W_F(idf)%xid)
+    iret = NF90_DEF_DIM(nfid,'lat',k_szy,W_F(idf)%yid)
+  ELSEIF (k_typ == 2) THEN
+    iret = NF90_DEF_DIM(nfid,'x',k_szx,W_F(idf)%xid)
+    iret = NF90_DEF_DIM(nfid,'y',k_szy,W_F(idf)%yid)
+  ELSEIF (k_typ == 3) THEN
+    iret = NF90_DEF_DIM(nfid,'x',pim,W_F(idf)%xid)
+    W_F(idf)%yid = W_F(idf)%xid
+  ENDIF
+!-
+! 4.0 Declaring the geographical coordinates and other attributes
+!-
+  IF (l_dbg) WRITE(ipslout,*) c_nam//" 4.0"
+!-
+  iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'Conventions','CF-1.1')
+  iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'file_name',TRIM(file))
+  iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'production',TRIM(model_name))
+  lock_modname = .TRUE.
+  CALL ioget_timestamp (timenow)
+  iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,'TimeStamp',TRIM(timenow))
+!-
+! 5.0 Saving some important information on this file in the common
+!-
+  IF (l_dbg) WRITE(ipslout,*) c_nam//" 5.0"
+!-
+  IF (PRESENT(domain_id)) THEN
+    W_F(idf)%dom_id_svg = domain_id
+  ENDIF
+  W_F(idf)%name = TRIM(nc_name)
+  W_F(idf)%ncfid = nfid
+  IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN
+    W_F(idf)%full_size(1:2) = (/ pim,pjm /)
+    W_F(idf)%regular=.TRUE.
+  ELSEIF (k_typ == 3) THEN
+    W_F(idf)%full_size(1:2) = (/ pim,1 /)
+    W_F(idf)%regular=.FALSE.
+  ENDIF
+!-
+! 6.0 storing the geographical coordinates
+!-
+  IF     (k_typ == 1) THEN
+    CALL histh_all &
+ &   (k_typ,idf,pim,pjm,' ','Default grid',phoriid, &
+ &    x_1d=x_1d,y_1d=y_1d)
+  ELSEIF (k_typ == 2) THEN
+    CALL histh_all &
+ &   (k_typ,idf,pim,pjm,' ','Default grid',phoriid, &
+ &    x_2d=x_2d,y_2d=y_2d)
+  ELSEIF (k_typ == 3) THEN
+    CALL histh_all &
+ &   (k_typ,idf,pim,pim,' ','Default grid',phoriid, &
+ &    x_1d=x_1d,y_1d=y_1d,x_bnds=x_bnds,y_bnds=y_bnds)
+  ENDIF
+!-----------------------
+END SUBROUTINE histb_all
+!===
+SUBROUTINE histglobal_attr &
+ & (idf,string_attr,glob_attr)
+!---------------------------------------------------------------------
+!- Definition of GLOBAL attribute for history files.
+!-
+!- INPUT
+!-
+!- idf     : The id of the file to which the grid should be added
+!- string_attr : name of the global attribute to be added
+!- glob_attr : global_attribute to be added
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: idf
+  CHARACTER(len=*),INTENT(IN) :: string_attr
+  CHARACTER(len=*),INTENT(IN) :: glob_attr
+
+  INTEGER :: iret,nfid
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+
+  nfid = W_F(idf)%ncfid
+  IF (l_dbg) WRITE(ipslout,*) "New global attribute : ",glob_attr
+  iret = NF90_PUT_ATT(nfid,NF90_GLOBAL,string_attr,glob_attr)
+!-----------------------
+END SUBROUTINE histglobal_attr
+!===
+SUBROUTINE histh_reg1d &
+ &  (idf,pim,plon,pjm,plat,phname,phtitle,phid)
+!---------------------------------------------------------------------
+!- histhori for 1d regular grid (see histh_all)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: idf,pim,pjm
+  REAL,INTENT(IN),DIMENSION(:) :: plon,plat
+  CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle
+  INTEGER,INTENT(OUT) :: phid
+!---------------------------------------------------------------------
+  CALL histh_all &
+ & (1,idf,pim,pjm,phname,phtitle,phid,x_1d=plon,y_1d=plat)
+!-------------------------
+END SUBROUTINE histh_reg1d
+!===
+SUBROUTINE histh_reg2d &
+ & (idf,pim,plon,pjm,plat,phname,phtitle,phid)
+!---------------------------------------------------------------------
+!- histhori for 2d regular grid (see histh_all)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: idf,pim,pjm
+  REAL,INTENT(IN),DIMENSION(:,:) :: plon,plat
+  CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle
+  INTEGER,INTENT(OUT) :: phid
+!---------------------------------------------------------------------
+  CALL histh_all &
+ & (2,idf,pim,pjm,phname,phtitle,phid,x_2d=plon,y_2d=plat)
+!-------------------------
+END SUBROUTINE histh_reg2d
+!===
+SUBROUTINE histh_irreg &
+ & (idf,pim,plon,plon_bounds,plat,plat_bounds,phname,phtitle,phid)
+!---------------------------------------------------------------------
+!- histhori for irregular grid (see histh_all)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: idf,pim
+  REAL,DIMENSION(:),INTENT(IN) :: plon,plat
+  REAL,DIMENSION(:,:),INTENT(IN) :: plon_bounds,plat_bounds
+  CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle
+  INTEGER,INTENT(OUT) :: phid
+!---------------------------------------------------------------------
+  CALL histh_all &
+ & (3,idf,pim,pim,phname,phtitle,phid, &
+ &  x_1d=plon,y_1d=plat,x_bnds=plon_bounds,y_bnds=plat_bounds)
+!-------------------------
+END SUBROUTINE histh_irreg
+!===
+SUBROUTINE histh_all &
+ & (k_typ,idf,pim,pjm,phname,phtitle,phid, &
+ &  x_1d,y_1d,x_2d,y_2d,x_bnds,y_bnds)
+!---------------------------------------------------------------------
+!- General interface for horizontal grids.
+!- This subroutine is made to declare a new horizontal grid.
+!- It has to have the same number of points as
+!- the original and thus in this routine we will only
+!- add two variable (longitude and latitude).
+!- Any variable in the file can thus point to this pair
+!- through an attribute. This routine is very usefull
+!- to allow staggered grids.
+!-
+!- INPUT
+!-
+!- k_typ   : Type of the grid (1 rectilinear, 2 regular, 3 irregular)
+!- idf     : The id of the file to which the grid should be added
+!- pim     : Size in the longitude direction
+!- pjm     : Size in the latitude direction (pjm=pim for type 3)
+!- phname  : The name of grid
+!- phtitle : The title of the grid
+!-
+!- OUTPUT
+!-
+!- phid    : Id of the created grid
+!-
+!- Optional INPUT arguments
+!-
+!- For rectilinear or irregular grid
+!- x_1d  : The longitudes
+!- y_1d  : The latitudes
+!- For regular grid
+!- x_2d  : The longitudes
+!- y_2d  : The latitudes
+!- One pair (x_1d,y_1d) or (x_2d,y_2d) must be supplied.
+!-
+!- For irregular grid.
+!- x_bnds : The boundaries of the grid in longitude
+!- y_bnds : The boundaries of the grid in latitude
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: k_typ
+  INTEGER,INTENT(IN) :: idf,pim,pjm
+  CHARACTER(LEN=*),INTENT(IN) :: phname,phtitle
+  INTEGER,INTENT(OUT) :: phid
+  REAL,DIMENSION(:),INTENT(IN),OPTIONAL :: x_1d,y_1d
+  REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_2d,y_2d
+  REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL :: x_bnds,y_bnds
+!-
+  CHARACTER(LEN=25) :: lon_name,lat_name
+  CHARACTER(LEN=30) :: lonbound_name,latbound_name
+  INTEGER :: i_s,i_e
+  INTEGER,DIMENSION(2) :: dims,dims_b
+  INTEGER :: nbbounds
+  INTEGER :: nlonidb,nlatidb,twoid
+  LOGICAL :: transp = .FALSE.
+  REAL,ALLOCATABLE,DIMENSION(:,:) :: bounds_trans
+  REAL :: wmn,wmx
+  INTEGER :: nlonid,nlatid
+  INTEGER :: o_x,o_y,s_x,s_y
+  INTEGER :: iret,nfid
+  CHARACTER(LEN=11) :: c_nam
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF     (k_typ == 1) THEN
+    c_nam = 'histh_reg1d'
+  ELSEIF (k_typ == 2) THEN
+    c_nam = 'histh_reg2d'
+  ELSEIF (k_typ == 3) THEN
+    c_nam = 'histh_irreg'
+  ELSE
+    CALL ipslerr (3,"histhori", &
+ &    'Illegal value of k_typ argument','in internal interface','?')
+  ENDIF
+!-
+! 1.0 Check that all fits in the buffers
+!-
+  IF (    (pim /= W_F(idf)%full_size(1)) &
+ &    .OR.(W_F(idf)%regular.AND.(pjm /= W_F(idf)%full_size(2)))  &
+ &    .OR.(.NOT.W_F(idf)%regular.AND.(W_F(idf)%full_size(2) /= 1)) ) THEN
+    CALL ipslerr (3,"histhori", &
+ &   'The new horizontal grid does not have the same size', &
+ &   'as the one provided to histbeg. This is not yet ', &
+ &   'possible in the hist package.')
+  ENDIF
+!-
+! 1.1 Create all the variables needed
+!-
+  IF (l_dbg) WRITE(ipslout,*) c_nam//" 1.0"
+!-
+  nfid = W_F(idf)%ncfid
+!-
+  IF (k_typ == 3) THEN
+    IF     (SIZE(x_bnds,DIM=1) == pim) THEN
+      nbbounds = SIZE(x_bnds,DIM=2)
+      transp = .TRUE.
+    ELSEIF (SIZE(x_bnds,DIM=2) == pim) THEN
+      nbbounds = SIZE(x_bnds,DIM=1)
+      transp = .FALSE.
+    ELSE
+      CALL ipslerr (3,"histhori", &
+ &     'The boundary variable does not have any axis corresponding', &
+ &     'to the size of the longitude or latitude variable','.')
+    ENDIF
+    ALLOCATE(bounds_trans(nbbounds,pim))
+    iret = NF90_DEF_DIM(nfid,'nbnd',nbbounds,twoid)
+    dims_b(1:2) = (/ twoid,W_F(idf)%xid /)
+  ENDIF
+!-
+  dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /)
+!-
+  IF     (k_typ == 1) THEN
+    IF (W_F(idf)%n_hax == 0) THEN
+      lon_name = 'lon'
+      lat_name = 'lat'
+    ELSE
+      lon_name = 'lon_'//TRIM(phname)
+      lat_name = 'lat_'//TRIM(phname)
+    ENDIF
+  ELSEIF (k_typ == 2) THEN
+    IF (W_F(idf)%n_hax == 0) THEN
+      lon_name = 'nav_lon'
+      lat_name = 'nav_lat'
+    ELSE
+      lon_name = 'nav_lon_'//TRIM(phname)
+      lat_name = 'nav_lat_'//TRIM(phname)
+    ENDIF
+  ELSEIF (k_typ == 3) THEN
+    IF (W_F(idf)%n_hax == 0) THEN
+      lon_name = 'nav_lon'
+      lat_name = 'nav_lat'
+    ELSE
+      lon_name = 'nav_lon_'//TRIM(phname)
+      lat_name = 'nav_lat_'//TRIM(phname)
+    ENDIF
+    lonbound_name = TRIM(lon_name)//'_bounds'
+    latbound_name = TRIM(lat_name)//'_bounds'
+  ENDIF
+!-
+! 1.2 Save the informations
+!-
+  phid = W_F(idf)%n_hax+1
+  W_F(idf)%n_hax = phid
+  W_F(idf)%hax_name(phid,1:2) = (/ lon_name,lat_name /)
+!-
+! 2.0 Longitude
+!-
+  IF (l_dbg) WRITE(ipslout,*) c_nam//" 2.0"
+!-
+  i_s = 1;
+  IF ( (k_typ == 1).OR.(k_typ == 3) ) THEN
+    i_e = 1; wmn = MINVAL(x_1d); wmx = MAXVAL(x_1d);
+  ELSEIF (k_typ == 2) THEN
+    i_e = 2; wmn = MINVAL(x_2d); wmx = MAXVAL(x_2d);
+  ENDIF
+  iret = NF90_DEF_VAR(nfid,lon_name,NF90_REAL4,dims(i_s:i_e),nlonid)
+  IF (k_typ == 1) THEN
+    iret = NF90_PUT_ATT(nfid,nlonid,'axis',"X")
+  ENDIF
+  iret = NF90_PUT_ATT(nfid,nlonid,'standard_name',"longitude")
+  iret = NF90_PUT_ATT(nfid,nlonid,'units',"degrees_east")
+  iret = NF90_PUT_ATT(nfid,nlonid,'valid_min',REAL(wmn,KIND=4))
+  iret = NF90_PUT_ATT(nfid,nlonid,'valid_max',REAL(wmx,KIND=4))
+  iret = NF90_PUT_ATT(nfid,nlonid,'long_name',"Longitude")
+  iret = NF90_PUT_ATT(nfid,nlonid,'nav_model',TRIM(phtitle))
+!-
+  IF (k_typ == 3) THEN
+!---
+!-- 2.1 Longitude bounds
+!---
+    iret = NF90_PUT_ATT(nfid,nlonid,'bounds',TRIM(lonbound_name))
+    iret = NF90_DEF_VAR(nfid,lonbound_name,NF90_REAL4,dims_b(1:2),nlonidb)
+    iret = NF90_PUT_ATT(nfid,nlonidb,'long_name', &
+ &          'Boundaries for coordinate variable '//TRIM(lon_name))
+  ENDIF
+!-
+! 3.0 Latitude
+!-
+  IF (l_dbg) WRITE(ipslout,*) c_nam//" 3.0"
+!-
+  i_e = 2;
+  IF ( (k_typ == 1).OR.(k_typ == 3) ) THEN
+    i_s = 2; wmn = MINVAL(y_1d); wmx = MAXVAL(y_1d);
+  ELSEIF (k_typ == 2) THEN
+    i_s = 1; wmn = MINVAL(y_2d); wmx = MAXVAL(y_2d);
+  ENDIF
+  iret = NF90_DEF_VAR(nfid,lat_name,NF90_REAL4,dims(i_s:i_e),nlatid)
+  IF (k_typ == 1) THEN
+    iret = NF90_PUT_ATT(nfid,nlatid,'axis',"Y")
+  ENDIF
+!-
+  iret = NF90_PUT_ATT(nfid,nlatid,'standard_name',"latitude")
+  iret = NF90_PUT_ATT(nfid,nlatid,'units',"degrees_north")
+  iret = NF90_PUT_ATT(nfid,nlatid,'valid_min',REAL(wmn,KIND=4))
+  iret = NF90_PUT_ATT(nfid,nlatid,'valid_max',REAL(wmx,KIND=4))
+  iret = NF90_PUT_ATT(nfid,nlatid,'long_name',"Latitude")
+  iret = NF90_PUT_ATT(nfid,nlatid,'nav_model',TRIM(phtitle))
+!-
+  IF (k_typ == 3) THEN
+!---
+!-- 3.1 Latitude bounds
+!---
+    iret = NF90_PUT_ATT(nfid,nlatid,'bounds',TRIM(latbound_name))
+    iret = NF90_DEF_VAR(nfid,latbound_name,NF90_REAL4,dims_b(1:2),nlatidb)
+    iret = NF90_PUT_ATT(nfid,nlatidb,'long_name', &
+ &          'Boundaries for coordinate variable '//TRIM(lat_name))
+  ENDIF
+!-
+  iret = NF90_ENDDEF(nfid)
+!-
+! 4.0 storing the geographical coordinates
+!-
+  IF (l_dbg) WRITE(ipslout,*) c_nam//" 4.0"
+!-
+  IF ( (k_typ == 1).OR.(k_typ == 2) ) THEN
+    o_x = W_F(idf)%slab_ori(1)
+    o_y = W_F(idf)%slab_ori(2)
+    s_x = W_F(idf)%slab_siz(1)
+    s_y = W_F(idf)%slab_siz(2)
+!---
+!-- Transfer the longitude and  the latitude
+!---
+    IF     (k_typ == 1) THEN
+      iret = NF90_PUT_VAR(nfid,nlonid,x_1d(o_x:o_x+s_x-1))
+      iret = NF90_PUT_VAR(nfid,nlatid,y_1d(o_y:o_y+s_y-1))
+    ELSEIF (k_typ == 2) THEN
+      iret = NF90_PUT_VAR(nfid,nlonid, &
+ &            x_2d(o_x:o_x+s_x-1,o_y:o_y+s_y-1))
+      iret = NF90_PUT_VAR(nfid,nlatid, &
+ &            y_2d(o_x:o_x+s_x-1,o_y:o_y+s_y-1))
+    ENDIF
+  ELSEIF (k_typ == 3) THEN
+!---
+!-- Transfer the longitude and the longitude bounds
+!---
+    iret = NF90_PUT_VAR(nfid,nlonid,x_1d(1:pim))
+!---
+    IF (transp) THEN
+      bounds_trans = TRANSPOSE(x_bnds)
+    ELSE
+      bounds_trans = x_bnds
+    ENDIF
+    iret = NF90_PUT_VAR(nfid,nlonidb,bounds_trans(1:nbbounds,1:pim))
+!---
+!-- Transfer the latitude and the latitude bounds
+!---
+    iret = NF90_PUT_VAR(nfid,nlatid,y_1d(1:pim))
+!---
+    IF (transp) THEN
+      bounds_trans = TRANSPOSE(y_bnds)
+    ELSE
+      bounds_trans = y_bnds
+    ENDIF
+    iret = NF90_PUT_VAR(nfid,nlatidb,bounds_trans(1:nbbounds,1:pim))
+!---
+    DEALLOCATE(bounds_trans)
+  ENDIF
+!-
+  iret = NF90_REDEF(nfid)
+!-----------------------
+END SUBROUTINE histh_all
+!===
+SUBROUTINE histvert (idf,pzaxname,pzaxtitle,pzaxunit, &
+ &                   pzsize,pzvalues,pzaxid,pdirect)
+!---------------------------------------------------------------------
+!- This subroutine defines a vertical axis and returns it s id.
+!- It gives the user the possibility to the user to define many
+!- different vertical axes. For each variable defined with histdef a
+!- vertical axis can be specified with by it s ID.
+!-
+!- INPUT
+!-
+!- idf      : ID of the file the variable should be archived in
+!- pzaxname : Name of the vertical axis
+!- pzaxtitle: title of the vertical axis
+!- pzaxunit : Units of the vertical axis (no units if blank string)
+!- pzsize   : size of the vertical axis
+!- pzvalues : Coordinate values of the vetical axis
+!-
+!- pdirect  : is an optional argument which allows to specify the
+!-            the positive direction of the axis : up or down.
+!- OUTPUT
+!-
+!- pzaxid   : Returns the ID of the axis.
+!-            Note that this is not the netCDF ID !
+!-
+!- VERSION
+!-
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: idf,pzsize
+  CHARACTER(LEN=*),INTENT(IN) :: pzaxname,pzaxunit,pzaxtitle
+  REAL,INTENT(IN) :: pzvalues(pzsize)
+  INTEGER,INTENT(OUT) :: pzaxid
+  CHARACTER(LEN=*),INTENT(IN),OPTIONAL :: pdirect
+!-
+  INTEGER :: pos,iv,zdimid,zaxid_tmp
+  CHARACTER(LEN=70) :: str71
+  CHARACTER(LEN=20) :: direction
+  INTEGER :: iret,leng,nfid
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! 1.0 Verifications :
+!    Do we have enough space for an extra axis ?
+!    Is the name already in use ?
+!-
+  IF (l_dbg) WRITE(ipslout,*) "histvert : 1.0 Verifications", &
+ &                      pzaxname,'---',pzaxunit,'---',pzaxtitle
+!-
+! Direction of the vertical axis. Can we get if from the user.
+!-
+  IF (PRESENT(pdirect)) THEN
+    direction = TRIM(pdirect)
+    CALL strlowercase (direction)
+  ELSE
+    direction = 'unknown'
+  ENDIF
+!-
+! Check the consistency of the attribute
+!-
+  IF (     PRESENT(pdirect)    &
+ &    .AND.(direction /= 'up') &
+ &    .AND.(direction /= 'down') ) THEN
+    direction = 'unknown'
+    CALL ipslerr (2,"histvert",&
+ & "The specified positive direction for the vertical axis is invalid.",&
+ & "The value must be up or down.","The attribute will not be written.")
+  ENDIF
+!-
+  IF (W_F(idf)%n_zax+1 > nb_zax_max) THEN
+    CALL ipslerr (3,"histvert", &
+   &  'Table of vertical axes too small. You should increase ',&
+   &  'nb_zax_max in histcom.f90 in order to accomodate all ', &
+   &  'these variables ')
+  ENDIF
+!-
+  iv = W_F(idf)%n_zax
+  IF (iv > 1) THEN
+    CALL find_str (W_F(idf)%zax_name(1:iv-1),pzaxname,pos)
+  ELSE
+    pos = 0
+  ENDIF
+!-
+  IF (pos > 0) THEN
+    WRITE(str71,'("Check variable ",A," in file",I3)') &
+ &    TRIM(pzaxname),idf
+    CALL ipslerr (3,"histvert", &
+ &    "Vertical axis already exists",TRIM(str71), &
+ &    "Can also be a wrong file ID in another declaration")
+  ENDIF
+!-
+  iv = W_F(idf)%n_zax+1
+!-
+! 2.0 Add the information to the file
+!-
+  IF (l_dbg) &
+ &  WRITE(ipslout,*) "histvert : 2.0 Add the information to the file"
+!-
+  nfid = W_F(idf)%ncfid
+!-
+  leng = MIN(LEN_TRIM(pzaxname),20)
+  iret = NF90_DEF_DIM (nfid,pzaxname(1:leng),pzsize,zaxid_tmp)
+  iret = NF90_DEF_VAR (nfid,pzaxname(1:leng),NF90_REAL4, &
+ &                     zaxid_tmp,zdimid)
+  iret = NF90_PUT_ATT (nfid,zdimid,'axis',"Z")
+  iret = NF90_PUT_ATT (nfid,zdimid,'standard_name',"model_level_number")
+  leng = MIN(LEN_TRIM(pzaxunit),20)
+  IF (leng > 0) THEN
+    iret = NF90_PUT_ATT (nfid,zdimid,'units',pzaxunit(1:leng))
+  ENDIF
+  IF (direction /= 'unknown') THEN
+    iret = NF90_PUT_ATT (nfid,zdimid,'positive',TRIM(direction))
+  ENDIF
+  iret = NF90_PUT_ATT (nfid,zdimid,'valid_min', &
+ &                     REAL(MINVAL(pzvalues(1:pzsize)),KIND=4))
+  iret = NF90_PUT_ATT (nfid,zdimid,'valid_max', &
+ &                     REAL(MAXVAL(pzvalues(1:pzsize)),KIND=4))
+  leng = MIN(LEN_TRIM(pzaxname),20)
+  iret = NF90_PUT_ATT (nfid,zdimid,'title',pzaxname(1:leng))
+  leng = MIN(LEN_TRIM(pzaxtitle),80)
+  iret = NF90_PUT_ATT (nfid,zdimid,'long_name',pzaxtitle(1:leng))
+!-
+  iret = NF90_ENDDEF (nfid)
+!-
+  iret = NF90_PUT_VAR (nfid,zdimid,pzvalues(1:pzsize))
+!-
+  iret = NF90_REDEF (nfid)
+!-
+!- 3.0 add the information to the common
+!-
+  IF (l_dbg) &
+  &  WRITE(ipslout,*) "histvert : 3.0 add the information to the common"
+!-
+  W_F(idf)%n_zax = iv
+  W_F(idf)%zax_size(iv) = pzsize
+  W_F(idf)%zax_name(iv) = pzaxname
+  W_F(idf)%zax_ids(iv) = zaxid_tmp
+  pzaxid = iv
+!----------------------
+END SUBROUTINE histvert
+!===
+SUBROUTINE histdef &
+ &  (idf,pvarname,ptitle,punit, &
+ &   pxsize,pysize,phoriid,pzsize,par_oriz,par_szz,pzid, &
+ &   xtype,popp,pfreq_opp,pfreq_wrt,var_range,standard_name)
+!---------------------------------------------------------------------
+!- With this subroutine each variable to be archived on the history
+!- tape should be declared.
+!-
+!- It gives the user the choise of operation
+!- to be performed on the variables, the frequency of this operation
+!- and finaly the frequency of the archiving.
+!-
+!- INPUT
+!-
+!- idf      : ID of the file the variable should be archived in
+!- pvarname : Name of the variable, short and easy to remember
+!- ptitle   : Full name of the variable
+!- punit    : Units of the variable (no units if blank string)
+!-
+!- The next 3 arguments give the size of that data
+!- that will be passed to histwrite. The zoom will be
+!- done there with the horizontal information obtained
+!- in histbeg and the vertical information to follow.
+!-
+!- pxsize   : Size in X direction (size of the data that will be
+!-            given to histwrite)
+!- pysize   : Size in Y direction
+!- phoriid  : ID of the horizontal axis
+!-
+!- The next two arguments give the vertical zoom to use.
+!-
+!- pzsize   : Size in Z direction (If 1 then no axis is declared
+!-            for this variable and pzid is not used)
+!- par_oriz : Off set of the zoom
+!- par_szz  : Size of the zoom
+!-
+!- pzid     : ID of the vertical axis to use. It has to have
+!-            the size of the zoom.
+!- xtype    : External netCDF type (hist_r4/hist_r8)
+!- popp     : Operation to be performed. The following options
+!-            exist today :
+!- inst : keeps instantaneous values for writting
+!- ave  : Computes the average from call between writes
+!- pfreq_opp: Frequency of this operation (in seconds)
+!- pfreq_wrt: Frequency at which the variable should be
+!-            written (in seconds)
+!- var_range: Range of the variable.
+!-            If the minimum is greater than the maximum,
+!-            the values will be calculated.
+!-
+!- VERSION
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: idf,pxsize,pysize,pzsize,pzid
+  INTEGER,INTENT(IN) :: par_oriz,par_szz,xtype,phoriid
+  CHARACTER(LEN=*),INTENT(IN) :: pvarname,punit,popp,ptitle
+  REAL,INTENT(IN) :: pfreq_opp,pfreq_wrt
+  REAL,DIMENSION(2),OPTIONAL,INTENT(IN) :: var_range
+  CHARACTER(LEN=*),OPTIONAL,INTENT(IN) :: standard_name
+!-
+  INTEGER :: iv
+  CHARACTER(LEN=70) :: str70,str71,str72
+  CHARACTER(LEN=20) :: tmp_name
+  CHARACTER(LEN=40) :: str40
+  CHARACTER(LEN=10) :: str10
+  CHARACTER(LEN=120) :: ex_topps
+  REAL :: un_an,un_jour,test_fopp,test_fwrt
+  INTEGER :: pos,buff_sz
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  ex_topps = 'ave, inst, t_min, t_max, t_sum, once, never, l_max, l_min'
+!-
+  W_F(idf)%n_var = W_F(idf)%n_var+1
+  iv = W_F(idf)%n_var
+!-
+  IF (iv > nb_var_max) THEN
+    CALL ipslerr (3,"histdef", &
+   &  'Table of variables too small. You should increase nb_var_max',&
+   &  'in histcom.f90 in order to accomodate all these variables', &
+   &  ' ')
+  ENDIF
+!-
+! 1.0 Transfer informations on the variable to the common
+!     and verify that it does not already exist
+!-
+  IF (l_dbg) WRITE(ipslout,*) "histdef : 1.0"
+!-
+  IF (iv > 1) THEN
+    CALL find_str (W_F(idf)%W_V(1:iv-1)%v_name,pvarname,pos)
+  ELSE
+    pos = 0
+  ENDIF
+!-
+  IF (pos > 0) THEN
+    str70 = "Variable already exists"
+    WRITE(str71,'("Check variable  ",a," in file",I3)') &
+ &    TRIM(pvarname),idf
+    str72 = "Can also be a wrong file ID in another declaration"
+    CALL ipslerr (3,"histdef",str70,str71,str72)
+  ENDIF
+!-
+  W_F(idf)%W_V(iv)%v_name = pvarname
+  W_F(idf)%W_V(iv)%title = ptitle
+  W_F(idf)%W_V(iv)%unit_name = punit
+  IF (PRESENT(standard_name)) THEN
+    W_F(idf)%W_V(iv)%std_name = standard_name
+  ELSE
+    W_F(idf)%W_V(iv)%std_name = ptitle
+  ENDIF
+  tmp_name = W_F(idf)%W_V(iv)%v_name
+!-
+! 1.1 decode the operations
+!-
+  W_F(idf)%W_V(iv)%fullop = popp
+  CALL buildop &
+ &  (TRIM(popp),ex_topps,W_F(idf)%W_V(iv)%topp,missing_val, &
+ &   W_F(idf)%W_V(iv)%sopp,W_F(idf)%W_V(iv)%scal, &
+ &   W_F(idf)%W_V(iv)%nbopp)
+!-
+! 1.2 If we have an even number of operations
+!     then we need to add identity
+!-
+  IF ( MOD(W_F(idf)%W_V(iv)%nbopp,2) == 0) THEN
+    W_F(idf)%W_V(iv)%nbopp = W_F(idf)%W_V(iv)%nbopp+1
+    W_F(idf)%W_V(iv)%sopp(W_F(idf)%W_V(iv)%nbopp) = 'ident'
+    W_F(idf)%W_V(iv)%scal(W_F(idf)%W_V(iv)%nbopp) = missing_val
+  ENDIF
+!-
+! 1.3 External type of the variable
+!-
+  IF (xtype == hist_r8) THEN
+    W_F(idf)%W_V(iv)%v_typ = hist_r8
+  ELSE
+    W_F(idf)%W_V(iv)%v_typ = hist_r4
+  ENDIF
+!-
+! 2.0 Put the size of the variable in the common and check
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "histdef : 2.0",idf,iv,W_F(idf)%W_V(iv)%nbopp, &
+ &    W_F(idf)%W_V(iv)%sopp(1:W_F(idf)%W_V(iv)%nbopp), &
+ &    W_F(idf)%W_V(iv)%scal(1:W_F(idf)%W_V(iv)%nbopp)
+  ENDIF
+!-
+  W_F(idf)%W_V(iv)%scsize(1:3) = (/ pxsize,pysize,pzsize /)
+  W_F(idf)%W_V(iv)%zorig(1:3) = &
+ &  (/ W_F(idf)%slab_ori(1),W_F(idf)%slab_ori(2),par_oriz /)
+  W_F(idf)%W_V(iv)%zsize(1:3) = &
+ &  (/ W_F(idf)%slab_siz(1),W_F(idf)%slab_siz(2),par_szz /)
+!-
+! Is the size of the full array the same as that of the coordinates ?
+!-
+  IF (    (pxsize > W_F(idf)%full_size(1)) &
+ &    .OR.(pysize > W_F(idf)%full_size(2)) ) THEN
+!-
+    str70 = "The size of the variable is different "// &
+ &          "from the one of the coordinates"
+    WRITE(str71,'("Size of coordinates :",2I4)') &
+ &   W_F(idf)%full_size(1),W_F(idf)%full_size(2)
+    WRITE(str72,'("Size declared for variable ",a," :",2I4)') &
+ &   TRIM(tmp_name),pxsize,pysize
+    CALL ipslerr (3,"histdef",str70,str71,str72)
+  ENDIF
+!-
+! Is the size of the zoom smaller than the coordinates ?
+!-
+  IF (    (W_F(idf)%full_size(1) < W_F(idf)%slab_siz(1)) &
+ &    .OR.(W_F(idf)%full_size(2) < W_F(idf)%slab_siz(2)) ) THEN
+    str70 = &
+ &   "Size of variable should be greater or equal to those of the zoom"
+    WRITE(str71,'("Size of XY zoom :",2I4)') &
+ &   W_F(idf)%slab_siz(1),W_F(idf)%slab_siz(2)
+    WRITE(str72,'("Size declared for variable ",A," :",2I4)') &
+ &   TRIM(tmp_name),pxsize,pysize
+    CALL ipslerr (3,"histdef",str70,str71,str72)
+  ENDIF
+!-
+! 2.1 We store the horizontal grid information with minimal
+!     and a fall back onto the default grid
+!-
+  IF ( (phoriid > 0).AND.(phoriid <= W_F(idf)%n_hax) ) THEN
+    W_F(idf)%W_V(iv)%h_axid = phoriid
+  ELSE
+    W_F(idf)%W_V(iv)%h_axid = 1
+    CALL ipslerr (2,"histdef", &
+   &  'We use the default grid for variable as an invalide',&
+   &  'ID was provided for variable : ',TRIM(pvarname))
+  ENDIF
+!-
+! 2.2 Check the vertical coordinates if needed
+!-
+  IF (par_szz > 1) THEN
+!-
+!-- Does the vertical coordinate exist ?
+!-
+    IF (pzid > W_F(idf)%n_zax) THEN
+      WRITE(str70, &
+ &    '("The vertical coordinate chosen for variable ",A)') &
+ &     TRIM(tmp_name)
+      str71 = " Does not exist."
+      CALL ipslerr (3,"histdef",str70,str71," ")
+    ENDIF
+!-
+!-- Is the vertical size of the variable equal to that of the axis ?
+!-
+    IF (par_szz /= W_F(idf)%zax_size(pzid)) THEN
+      str70 = "The size of the zoom does not correspond "// &
+ &            "to the size of the chosen vertical axis"
+      WRITE(str71,'("Size of zoom in z :",I4)') par_szz
+      WRITE(str72,'("Size declared for axis ",A," :",I4)') &
+ &     TRIM(W_F(idf)%zax_name(pzid)),W_F(idf)%zax_size(pzid)
+      CALL ipslerr (3,"histdef",str70,str71,str72)
+    ENDIF
+!-
+!-- Is the zoom smaller that the total size of the variable ?
+!-
+    IF (pzsize < par_szz) THEN
+      str70 = "The vertical size of variable "// &
+ &            "is smaller than that of the zoom."
+      WRITE(str71,'("Declared vertical size of data :",I5)') pzsize
+      WRITE(str72,'("Size of zoom for variable ",a," = ",I5)') &
+ &     TRIM(tmp_name),par_szz
+      CALL ipslerr (3,"histdef",str70,str71,str72)
+    ENDIF
+    W_F(idf)%W_V(iv)%z_axid = pzid
+  ELSE
+    W_F(idf)%W_V(iv)%z_axid = -99
+  ENDIF
+!-
+! 3.0 We get the size of the arrays histwrite will get
+!     and eventually allocate the time_buffer
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "histdef : 3.0"
+  ENDIF
+!-
+  buff_sz = W_F(idf)%W_V(iv)%zsize(1) &
+ &         *W_F(idf)%W_V(iv)%zsize(2) &
+ &         *W_F(idf)%W_V(iv)%zsize(3)
+!-
+  IF (     (TRIM(W_F(idf)%W_V(iv)%topp) /= "inst") &
+ &    .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "once") &
+ &    .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= "never") )THEN
+    ALLOCATE(W_F(idf)%W_V(iv)%t_bf(buff_sz))
+    W_F(idf)%W_V(iv)%t_bf(:) = missing_val
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) "histdef : 3.0 allocating time_buffer for", &
+ &      " idf = ",idf," iv = ",iv," size = ",buff_sz
+    ENDIF
+  ENDIF
+!-
+! 4.0 Transfer the frequency of the operations and check
+!     for validity. We have to pay attention to negative values
+!     of the frequency which indicate monthly time-steps.
+!     The strategy is to bring it back to seconds for the tests
+!-
+  IF (l_dbg) WRITE(ipslout,*) "histdef : 4.0"
+!-
+  W_F(idf)%W_V(iv)%freq_opp = pfreq_opp
+  W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt
+!-
+  CALL ioget_calendar(un_an,un_jour)
+  IF (pfreq_opp < 0) THEN
+    CALL ioget_calendar(un_an)
+    test_fopp = pfreq_opp*(-1.)*un_an/12.*un_jour
+  ELSE
+    test_fopp = pfreq_opp
+  ENDIF
+  IF (pfreq_wrt < 0) THEN
+    CALL ioget_calendar(un_an)
+    test_fwrt = pfreq_wrt*(-1.)*un_an/12.*un_jour
+  ELSE
+    test_fwrt = pfreq_wrt
+  ENDIF
+!-
+! 4.1 Frequency of operations and output should be larger than deltat !
+!-
+  IF (test_fopp < W_F(idf)%deltat) THEN
+    str70 = 'Frequency of operations should be larger than deltat'
+    WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') &
+ &   TRIM(tmp_name),pfreq_opp
+    str72 = "PATCH : frequency set to deltat"
+!-
+    CALL ipslerr (2,"histdef",str70,str71,str72)
+!-
+    W_F(idf)%W_V(iv)%freq_opp = W_F(idf)%deltat
+  ENDIF
+!-
+  IF (test_fwrt < W_F(idf)%deltat) THEN
+    str70 = 'Frequency of output should be larger than deltat'
+    WRITE(str71,'("It is not the case for variable ",a," :",F10.4)') &
+ &   TRIM(tmp_name),pfreq_wrt
+    str72 = "PATCH : frequency set to deltat"
+!-
+    CALL ipslerr (2,"histdef",str70,str71,str72)
+!-
+    W_F(idf)%W_V(iv)%freq_wrt = W_F(idf)%deltat
+  ENDIF
+!-
+! 4.2 First the existence of the operation is tested and then
+!     its compaticility with the choice of frequencies
+!-
+  IF (TRIM(W_F(idf)%W_V(iv)%topp) == "inst") THEN
+    IF (test_fopp /= test_fwrt) THEN
+      str70 = 'For instantaneous output the frequency '// &
+ &            'of operations and output'
+      WRITE(str71, &
+ &     '("should be the same, this was not case for variable ",a)') &
+ &      TRIM(tmp_name)
+      str72 = "PATCH : The smalest frequency of both is used"
+      CALL ipslerr (2,"histdef",str70,str71,str72)
+      IF (test_fopp < test_fwrt) THEN
+        W_F(idf)%W_V(iv)%freq_opp = pfreq_opp
+        W_F(idf)%W_V(iv)%freq_wrt = pfreq_opp
+      ELSE
+        W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt
+        W_F(idf)%W_V(iv)%freq_wrt = pfreq_wrt
+      ENDIF
+    ENDIF
+  ELSE IF (INDEX(ex_topps,TRIM(W_F(idf)%W_V(iv)%topp)) > 0) THEN
+    IF (test_fopp > test_fwrt) THEN
+      str70 = 'For averages the frequency of operations '// &
+ &            'should be smaller or equal'
+      WRITE(str71, &
+ &     '("to that of output. It is not the case for variable ",a)') &
+ &     TRIM(tmp_name)
+      str72 = 'PATCH : The output frequency is used for both'
+      CALL ipslerr (2,"histdef",str70,str71,str72)
+      W_F(idf)%W_V(iv)%freq_opp = pfreq_wrt
+    ENDIF
+  ELSE
+    WRITE (str70,'("Operation on variable ",A," is unknown")') &
+ &   TRIM(tmp_name)
+    WRITE (str71,'("operation requested is :",A)') &
+ &   W_F(idf)%W_V(iv)%topp
+    WRITE (str72,'("File ID :",I3)') idf
+    CALL ipslerr (3,"histdef",str70,str71,str72)
+  ENDIF
+!-
+! 5.0 Initialize other variables of the common
+!-
+  IF (l_dbg) WRITE(ipslout,*) "histdef : 5.0"
+!-
+  W_F(idf)%W_V(iv)%hist_wrt_rng = (PRESENT(var_range))
+  IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN
+    W_F(idf)%W_V(iv)%hist_calc_rng = (var_range(1) > var_range(2))
+    IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN
+      W_F(idf)%W_V(iv)%hist_minmax(1:2) = &
+ &      (/ ABS(missing_val),-ABS(missing_val) /)
+    ELSE
+      W_F(idf)%W_V(iv)%hist_minmax(1:2) = var_range(1:2)
+    ENDIF
+  ENDIF
+!-
+! - freq_opp(idf,iv)/2./deltat(idf)
+  W_F(idf)%W_V(iv)%last_opp = W_F(idf)%itau0
+! - freq_wrt(idf,iv)/2./deltat(idf)
+  W_F(idf)%W_V(iv)%last_wrt = W_F(idf)%itau0
+! - freq_opp(idf,iv)/2./deltat(idf)
+  W_F(idf)%W_V(iv)%last_opp_chk = W_F(idf)%itau0
+! - freq_wrt(idf,iv)/2./deltat(idf)
+  W_F(idf)%W_V(iv)%last_wrt_chk = W_F(idf)%itau0
+  W_F(idf)%W_V(iv)%nb_opp = 0
+  W_F(idf)%W_V(iv)%nb_wrt = 0
+!-
+! 6.0 Get the time axis for this variable
+!-
+  IF (l_dbg) WRITE(ipslout,*) "histdef : 6.0"
+!-
+! No time axis for once, l_max, l_min or never operation
+!-
+  IF (     (TRIM(W_F(idf)%W_V(iv)%topp) /= 'once')  &
+ &    .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'never') &
+ &    .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_max') &
+ &    .AND.(TRIM(W_F(idf)%W_V(iv)%topp) /= 'l_min') ) THEN
+    IF (TRIM(W_F(idf)%W_V(iv)%topp) == 'inst') THEN
+      str10 = 't_inst_'
+    ELSE
+      str10 = 't_op_'
+    ENDIF
+    IF (W_F(idf)%W_V(iv)%freq_wrt > 0) THEN
+      WRITE (UNIT=str40,FMT='(A,I8.8)') &
+&      TRIM(str10),INT(W_F(idf)%W_V(iv)%freq_wrt)
+    ELSE
+      WRITE (UNIT=str40,FMT='(A,I2.2,"month")') &
+&      TRIM(str10),ABS(INT(W_F(idf)%W_V(iv)%freq_wrt))
+    ENDIF
+    CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_tax)%tax_name,str40,pos)
+    IF (pos < 0) THEN
+      W_F(idf)%n_tax = W_F(idf)%n_tax+1
+      W_F(idf)%W_V(iv)%l_bnd = &
+ &      (TRIM(W_F(idf)%W_V(iv)%topp) /= 'inst')
+      W_F(idf)%W_V(W_F(idf)%n_tax)%tax_name = str40
+      W_F(idf)%W_V(W_F(idf)%n_tax)%tax_last = 0
+      W_F(idf)%W_V(iv)%t_axid = W_F(idf)%n_tax
+    ELSE
+      W_F(idf)%W_V(iv)%t_axid = pos
+    ENDIF
+  ELSE
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) "histdef : 7.0 ",TRIM(W_F(idf)%W_V(iv)%topp),'----'
+    ENDIF
+    W_F(idf)%W_V(iv)%t_axid = -99
+  ENDIF
+!-
+! 7.0 prepare frequence of writing and operation
+!     for never or once operation
+!-
+  IF (    (TRIM(W_F(idf)%W_V(iv)%topp) == 'once')  &
+ &    .OR.(TRIM(W_F(idf)%W_V(iv)%topp) == 'never') ) THEN
+    W_F(idf)%W_V(iv)%freq_opp = 0.
+    W_F(idf)%W_V(iv)%freq_wrt = 0.
+  ENDIF
+!---------------------
+END SUBROUTINE histdef
+!===
+SUBROUTINE histend (idf)
+!---------------------------------------------------------------------
+!- This subroutine end the decalaration of variables and sets the
+!- time axes in the netcdf file and puts it into the write mode.
+!-
+!- INPUT
+!-
+!- idf : ID of the file to be worked on
+!-
+!- VERSION
+!-
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: idf
+!-
+  INTEGER :: nfid,nvid,iret,ndim,iv,itx,ziv,itax,dim_cnt
+  INTEGER,DIMENSION(4) :: dims
+  INTEGER :: year,month,day,hours,minutes
+  REAL :: sec
+  REAL :: rtime0
+  CHARACTER(LEN=30) :: str30
+  CHARACTER(LEN=35) :: str35
+  CHARACTER(LEN=120) :: assoc
+  CHARACTER(LEN=70) :: str70
+  CHARACTER(LEN=3),DIMENSION(12) :: cal =   &
+ &  (/ 'JAN','FEB','MAR','APR','MAY','JUN', &
+ &     'JUL','AUG','SEP','OCT','NOV','DEC' /)
+  CHARACTER(LEN=7) :: tmp_opp
+  LOGICAL :: l_b
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  nfid = W_F(idf)%ncfid
+!-
+! 1.0 Create the time axes
+!-
+  IF (l_dbg) WRITE(ipslout,*) "histend : 1.0"
+!-
+! 1.1 Define the time dimensions needed for this file
+!-
+  iret = NF90_DEF_DIM (nfid,'time_counter', &
+ &                     NF90_UNLIMITED,W_F(idf)%tid)
+  DO iv=1,W_F(idf)%n_var
+    IF (W_F(idf)%W_V(iv)%l_bnd) THEN
+      iret = NF90_DEF_DIM (nfid,'tbnds',2,W_F(idf)%bid)
+      EXIT
+    ENDIF
+  ENDDO
+!-
+! 1.2 Define all the time axes needed for this file
+!-
+  DO itx=1,W_F(idf)%n_tax
+    dims(1) = W_F(idf)%tid
+    l_b = (INDEX(W_F(idf)%W_V(itx)%tax_name,"t_op_") == 1)
+    IF (itx > 1) THEN
+      str30 = W_F(idf)%W_V(itx)%tax_name
+    ELSE
+      str30 = "time_counter"
+    ENDIF
+    IF (l_b) THEN
+      str35 = TRIM(str30)//'_bnds'
+    ENDIF
+    iret = NF90_DEF_VAR (nfid,TRIM(str30),NF90_REAL8, &
+ &          dims(1),W_F(idf)%W_V(itx)%tdimid)
+    IF (itx <= 1) THEN
+      iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid,'axis',"T")
+    ENDIF
+    iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
+ &          'standard_name',"time")
+!---
+!   To transform the current itau into a real date and take it
+!   as the origin of the file requires the time counter to change.
+!   Thus it is an operation the user has to ask for.
+!   This function should thus only be re-instated
+!   if there is a ioconf routine to control it.
+!---
+!-- rtime0 = itau2date(itau0(idf),date0(idf),deltat(idf))
+    rtime0 = W_F(idf)%date0
+!-
+    CALL ju2ymds(rtime0,year,month,day,sec)
+!---
+!   Catch any error induced by a change in calendar !
+!---
+    IF (year < 0) THEN
+      year = 2000+year
+    ENDIF
+!-
+    hours = INT(sec/(60.*60.))
+    minutes = INT((sec-hours*60.*60.)/60.)
+    sec = sec-(hours*60.*60.+minutes*60.)
+!-
+    WRITE (UNIT=str70, &
+ &   FMT='(A,I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') &
+ &    'seconds since ',year,month,day,hours,minutes,INT(sec)
+    iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
+ &           'units',TRIM(str70))
+!-
+    CALL ioget_calendar (str30)
+    iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
+ &           'calendar',TRIM(str30))
+!-
+    iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
+ &           'title','Time')
+!-
+    iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
+ &           'long_name','Time axis')
+!-
+    WRITE (UNIT=str70, &
+ &   FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)') &
+ &    year,cal(month),day,hours,minutes,INT(sec)
+    iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
+ &           'time_origin',TRIM(str70))
+!---
+    IF (l_b) THEN
+      iret = NF90_PUT_ATT (nfid,W_F(idf)%W_V(itx)%tdimid, &
+ &             'bounds',TRIM(str35))
+      dims(1:2) = (/ W_F(idf)%bid,W_F(idf)%tid /)
+      iret = NF90_DEF_VAR (nfid,TRIM(str35),NF90_REAL8, &
+ &            dims(1:2),W_F(idf)%W_V(itx)%tbndid)
+    ENDIF
+  ENDDO
+!-
+! 2.0 declare the variables
+!-
+  IF (l_dbg) WRITE(ipslout,*) "histend : 2.0"
+!-
+  DO iv=1,W_F(idf)%n_var
+!---
+    itax = W_F(idf)%W_V(iv)%t_axid
+!---
+    IF (W_F(idf)%regular) THEN
+      dims(1:2) = (/ W_F(idf)%xid,W_F(idf)%yid /)
+      dim_cnt = 2
+    ELSE
+      dims(1) = W_F(idf)%xid
+      dim_cnt = 1
+    ENDIF
+!---
+    tmp_opp = W_F(idf)%W_V(iv)%topp
+    ziv = W_F(idf)%W_V(iv)%z_axid
+!---
+!   2.1 dimension of field
+!---
+    IF ((TRIM(tmp_opp) /= 'never')) THEN
+      IF (     (TRIM(tmp_opp) /= 'once')  &
+     &    .AND.(TRIM(tmp_opp) /= 'l_max') &
+     &    .AND.(TRIM(tmp_opp) /= 'l_min') ) THEN
+        IF (ziv == -99) THEN
+          ndim = dim_cnt+1
+          dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%tid,0 /)
+        ELSE
+          ndim = dim_cnt+2
+          dims(dim_cnt+1:dim_cnt+2) = &
+ &         (/ W_F(idf)%zax_ids(ziv),W_F(idf)%tid /)
+        ENDIF
+      ELSE
+        IF (ziv == -99) THEN
+          ndim = dim_cnt
+          dims(dim_cnt+1:dim_cnt+2) = (/ 0,0 /)
+        ELSE
+          ndim = dim_cnt+1
+          dims(dim_cnt+1:dim_cnt+2) = (/ W_F(idf)%zax_ids(ziv),0 /)
+        ENDIF
+      ENDIF
+!-
+      iret = NF90_DEF_VAR (nfid,TRIM(W_F(idf)%W_V(iv)%v_name), &
+ &             W_F(idf)%W_V(iv)%v_typ,dims(1:ABS(ndim)),nvid)
+!-
+      W_F(idf)%W_V(iv)%ncvid = nvid
+!-
+      IF (LEN_TRIM(W_F(idf)%W_V(iv)%unit_name) > 0) THEN
+        iret = NF90_PUT_ATT (nfid,nvid,'units', &
+ &                           TRIM(W_F(idf)%W_V(iv)%unit_name))
+      ENDIF
+      iret = NF90_PUT_ATT (nfid,nvid,'standard_name', &
+ &                         TRIM(W_F(idf)%W_V(iv)%std_name))
+!-
+      IF (W_F(idf)%W_V(iv)%v_typ == hist_r8) THEN
+        iret = NF90_PUT_ATT (nfid,nvid,'_FillValue',NF90_FILL_REAL8)
+      ELSE
+        iret = NF90_PUT_ATT (nfid,nvid,'_FillValue',NF90_FILL_REAL4)
+      ENDIF
+      IF (W_F(idf)%W_V(iv)%hist_wrt_rng) THEN
+        IF (W_F(idf)%W_V(iv)%v_typ == hist_r8) THEN
+          iret = NF90_PUT_ATT (nfid,nvid,'valid_min', &
+ &                 REAL(W_F(idf)%W_V(iv)%hist_minmax(1),KIND=8))
+          iret = NF90_PUT_ATT (nfid,nvid,'valid_max', &
+ &                 REAL(W_F(idf)%W_V(iv)%hist_minmax(2),KIND=8))
+        ELSE
+          iret = NF90_PUT_ATT (nfid,nvid,'valid_min', &
+ &                 REAL(W_F(idf)%W_V(iv)%hist_minmax(1),KIND=4))
+          iret = NF90_PUT_ATT (nfid,nvid,'valid_max', &
+ &                 REAL(W_F(idf)%W_V(iv)%hist_minmax(2),KIND=4))
+        ENDIF
+      ENDIF
+      iret = NF90_PUT_ATT (nfid,nvid,'long_name', &
+ &                         TRIM(W_F(idf)%W_V(iv)%title))
+      iret = NF90_PUT_ATT (nfid,nvid,'online_operation', &
+ &                         TRIM(W_F(idf)%W_V(iv)%fullop))
+!-
+      SELECT CASE(ndim)
+      CASE(-3,2:4)
+      CASE DEFAULT
+        CALL ipslerr (3,"histend", &
+       &  'less than 2 or more than 4 dimensions are not', &
+       &  'allowed at this stage',' ')
+      END SELECT
+!-
+      assoc=TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,2)) &
+ &   //' '//TRIM(W_F(idf)%hax_name(W_F(idf)%W_V(iv)%h_axid,1))
+!-
+      ziv = W_F(idf)%W_V(iv)%z_axid
+      IF (ziv > 0) THEN
+        str30 = W_F(idf)%zax_name(ziv)
+        assoc = TRIM(str30)//' '//TRIM(assoc)
+      ENDIF
+!-
+      IF (itax > 0) THEN
+        IF (itax > 1) THEN
+          str30 = W_F(idf)%W_V(itax)%tax_name
+        ELSE
+          str30 = "time_counter"
+        ENDIF
+        assoc = TRIM(str30)//' '//TRIM(assoc)
+!-
+        IF (l_dbg) THEN
+          WRITE(ipslout,*) "histend : 2.0.n, freq_opp, freq_wrt", &
+ &          W_F(idf)%W_V(iv)%freq_opp,W_F(idf)%W_V(iv)%freq_wrt
+        ENDIF
+!-
+        iret = NF90_PUT_ATT (nfid,nvid,'interval_operation', &
+ &                           REAL(W_F(idf)%W_V(iv)%freq_opp,KIND=4))
+        iret = NF90_PUT_ATT (nfid,nvid,'interval_write', &
+ &                           REAL(W_F(idf)%W_V(iv)%freq_wrt,KIND=4))
+      ENDIF
+      iret = NF90_PUT_ATT (nfid,nvid,'coordinates',TRIM(assoc))
+    ENDIF
+  ENDDO
+!-
+! 2.2 Add DOMAIN attributes if needed
+!-
+  IF (W_F(idf)%dom_id_svg >= 0) THEN
+    CALL flio_dom_att (nfid,W_F(idf)%dom_id_svg)
+  ENDIF
+!-
+! 3.0 Put the netcdf file into write mode
+!-
+  IF (l_dbg) WRITE(ipslout,*) "histend : 3.0"
+!-
+  iret = NF90_ENDDEF (nfid)
+!-
+! 4.0 Give some informations to the user
+!-
+  IF (l_dbg) WRITE(ipslout,*) "histend : 4.0"
+!-
+  WRITE(str70,'("All variables have been initialized on file :",I3)') idf
+  CALL ipslerr (1,'histend',str70,'',' ')
+!---------------------
+END SUBROUTINE histend
+!===
+SUBROUTINE histwrite_r1d (idf,pvarname,pitau,pdata,nbindex,nindex)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: idf,pitau,nbindex
+  INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex
+  REAL,DIMENSION(:),INTENT(IN) :: pdata
+  CHARACTER(LEN=*),INTENT(IN) :: pvarname
+!---------------------------------------------------------------------
+  CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_1d=pdata)
+!---------------------------
+END SUBROUTINE histwrite_r1d
+!===
+SUBROUTINE histwrite_r2d (idf,pvarname,pitau,pdata,nbindex,nindex)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: idf,pitau,nbindex
+  INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex
+  REAL,DIMENSION(:,:),INTENT(IN) :: pdata
+  CHARACTER(LEN=*),INTENT(IN) :: pvarname
+!---------------------------------------------------------------------
+  CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_2d=pdata)
+!---------------------------
+END SUBROUTINE histwrite_r2d
+!===
+SUBROUTINE histwrite_r3d (idf,pvarname,pitau,pdata,nbindex,nindex)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: idf,pitau,nbindex
+  INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex
+  REAL,DIMENSION(:,:,:),INTENT(IN) :: pdata
+  CHARACTER(LEN=*),INTENT(IN) :: pvarname
+!---------------------------------------------------------------------
+  CALL histw_rnd (idf,pvarname,pitau,nbindex,nindex,pdata_3d=pdata)
+!---------------------------
+END SUBROUTINE histwrite_r3d
+!===
+SUBROUTINE histw_rnd (idf,pvarname,pitau,nbindex,nindex, &
+  &                   pdata_1d,pdata_2d,pdata_3d)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: idf,pitau,nbindex
+  INTEGER,DIMENSION(nbindex),INTENT(IN) :: nindex
+  CHARACTER(LEN=*),INTENT(IN) :: pvarname
+  REAL,DIMENSION(:),INTENT(IN),OPTIONAL     :: pdata_1d
+  REAL,DIMENSION(:,:),INTENT(IN),OPTIONAL   :: pdata_2d
+  REAL,DIMENSION(:,:,:),INTENT(IN),OPTIONAL :: pdata_3d
+!-
+  LOGICAL :: do_oper,do_write,largebuf,l1d,l2d,l3d
+  INTEGER :: iv,io,nbpt_out
+  INTEGER              :: nbpt_in1
+  INTEGER,DIMENSION(2) :: nbpt_in2
+  INTEGER,DIMENSION(3) :: nbpt_in3
+  REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_1
+  CHARACTER(LEN=7) :: tmp_opp
+  CHARACTER(LEN=13) :: c_nam
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  l1d=PRESENT(pdata_1d); l2d=PRESENT(pdata_2d); l3d=PRESENT(pdata_3d);
+  IF      (l1d) THEN
+    c_nam = 'histwrite_r1d'
+  ELSE IF (l2d) THEN
+    c_nam = 'histwrite_r2d'
+  ELSE IF (l3d) THEN
+    c_nam = 'histwrite_r3d'
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "histwrite : ",c_nam
+  ENDIF
+!-
+! 1.0 Try to catch errors like specifying the wrong file ID.
+!     Thanks Marine for showing us what errors users can make !
+!-
+  IF ( (idf < 1).OR.(idf > nb_files_max) ) THEN
+    CALL ipslerr (3,"histwrite", &
+ &    'Illegal file ID in the histwrite of variable',pvarname,' ')
+  ENDIF
+!-
+! 1.1 Find the id of the variable to be written and the real time
+!-
+  CALL histvar_seq (idf,pvarname,iv)
+!-
+! 2.0 do nothing for never operation
+!-
+  tmp_opp = W_F(idf)%W_V(iv)%topp
+!-
+  IF (TRIM(tmp_opp) == "never") THEN
+    W_F(idf)%W_V(iv)%last_opp_chk = -99
+    W_F(idf)%W_V(iv)%last_wrt_chk = -99
+  ENDIF
+!-
+! 3.0 We check if we need to do an operation
+!-
+  IF (W_F(idf)%W_V(iv)%last_opp_chk == pitau) THEN
+    CALL ipslerr (3,"histwrite", &
+ &    'This variable has already been analysed at the present', &
+ &    'time step',TRIM(pvarname))
+  ENDIF
+!-
+  CALL isittime &
+ &  (pitau,W_F(idf)%date0,W_F(idf)%deltat, &
+ &   W_F(idf)%W_V(iv)%freq_opp, &
+ &   W_F(idf)%W_V(iv)%last_opp, &
+ &   W_F(idf)%W_V(iv)%last_opp_chk,do_oper)
+!-
+! 4.0 We check if we need to write the data
+!-
+  IF (W_F(idf)%W_V(iv)%last_wrt_chk == pitau) THEN
+    CALL ipslerr (3,"histwrite", &
+ &    'This variable as already been written for the present', &
+ &    'time step',' ')
+  ENDIF
+!-
+  CALL isittime &
+ &  (pitau,W_F(idf)%date0,W_F(idf)%deltat, &
+ &   W_F(idf)%W_V(iv)%freq_wrt, &
+ &   W_F(idf)%W_V(iv)%last_wrt, &
+ &   W_F(idf)%W_V(iv)%last_wrt_chk,do_write)
+!-
+! 5.0 histwrite called
+!-
+  IF (do_oper.OR.do_write) THEN
+!-
+!-- 5.1 Get the sizes of the data we will handle
+!-
+    IF (W_F(idf)%W_V(iv)%datasz_in(1) <= 0) THEN
+!---- There is the risk here that the user has over-sized the array.
+!---- But how can we catch this ?
+!---- In the worst case we will do impossible operations
+!---- on part of the data !
+      W_F(idf)%W_V(iv)%datasz_in(1:3) = -1
+      IF      (l1d) THEN
+        W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_1d)
+      ELSE IF (l2d) THEN
+        W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_2d,DIM=1)
+        W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_2d,DIM=2)
+      ELSE IF (l3d) THEN
+        W_F(idf)%W_V(iv)%datasz_in(1) = SIZE(pdata_3d,DIM=1)
+        W_F(idf)%W_V(iv)%datasz_in(2) = SIZE(pdata_3d,DIM=2)
+        W_F(idf)%W_V(iv)%datasz_in(3) = SIZE(pdata_3d,DIM=3)
+      ENDIF
+    ENDIF
+!-
+!-- 5.2 The maximum size of the data will give the size of the buffer
+!-
+    IF (W_F(idf)%W_V(iv)%datasz_max <= 0) THEN
+      largebuf = .FALSE.
+      DO io=1,W_F(idf)%W_V(iv)%nbopp
+        IF (INDEX(fuchnbout,W_F(idf)%W_V(iv)%sopp(io)) > 0) THEN
+          largebuf = .TRUE.
+        ENDIF
+      ENDDO
+      IF (largebuf) THEN
+        W_F(idf)%W_V(iv)%datasz_max = &
+ &        W_F(idf)%W_V(iv)%scsize(1) &
+ &       *W_F(idf)%W_V(iv)%scsize(2) &
+ &       *W_F(idf)%W_V(iv)%scsize(3)
+      ELSE
+        IF      (l1d) THEN
+          W_F(idf)%W_V(iv)%datasz_max = &
+ &          W_F(idf)%W_V(iv)%datasz_in(1)
+        ELSE IF (l2d) THEN
+          W_F(idf)%W_V(iv)%datasz_max = &
+ &          W_F(idf)%W_V(iv)%datasz_in(1) &
+ &         *W_F(idf)%W_V(iv)%datasz_in(2)
+        ELSE IF (l3d) THEN
+          W_F(idf)%W_V(iv)%datasz_max = &
+ &          W_F(idf)%W_V(iv)%datasz_in(1) &
+ &         *W_F(idf)%W_V(iv)%datasz_in(2) &
+ &         *W_F(idf)%W_V(iv)%datasz_in(3)
+        ENDIF
+      ENDIF
+    ENDIF
+!-
+    IF (.NOT.ALLOCATED(tbf_1)) THEN
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) &
+ &       c_nam//" : allocate tbf_1 for size = ", &
+ &       W_F(idf)%W_V(iv)%datasz_max
+      ENDIF
+      ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max))
+    ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_1)) THEN
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) &
+ &       c_nam//" : re-allocate tbf_1 for size = ", &
+ &       W_F(idf)%W_V(iv)%datasz_max
+      ENDIF
+      DEALLOCATE(tbf_1)
+      ALLOCATE(tbf_1(W_F(idf)%W_V(iv)%datasz_max))
+    ENDIF
+!-
+!-- We have to do the first operation anyway.
+!-- Thus we do it here and change the ranke
+!-- of the data at the same time. This should speed up things.
+!-
+    nbpt_out = W_F(idf)%W_V(iv)%datasz_max
+    IF      (l1d) THEN
+      nbpt_in1 = W_F(idf)%W_V(iv)%datasz_in(1)
+      CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in1,pdata_1d, &
+ &                 missing_val,nbindex,nindex, &
+ &                 W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1)
+    ELSE IF (l2d) THEN
+      nbpt_in2(1:2) = W_F(idf)%W_V(iv)%datasz_in(1:2)
+      CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in2,pdata_2d, &
+ &                 missing_val,nbindex,nindex, &
+ &                 W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1)
+    ELSE IF (l3d) THEN
+      nbpt_in3(1:3) = W_F(idf)%W_V(iv)%datasz_in(1:3)
+      CALL mathop (W_F(idf)%W_V(iv)%sopp(1),nbpt_in3,pdata_3d, &
+ &                 missing_val,nbindex,nindex, &
+ &                 W_F(idf)%W_V(iv)%scal(1),nbpt_out,tbf_1)
+    ENDIF
+    CALL histwrite_real (idf,iv,pitau,nbpt_out, &
+ &            tbf_1,nbindex,nindex,do_oper,do_write)
+  ENDIF
+!-
+! 6.0 Manage time steps
+!-
+  IF ((TRIM(tmp_opp) /= "once").AND.(TRIM(tmp_opp) /= "never")) THEN
+    W_F(idf)%W_V(iv)%last_opp_chk = pitau
+    W_F(idf)%W_V(iv)%last_wrt_chk = pitau
+  ELSE
+    W_F(idf)%W_V(iv)%last_opp_chk = -99
+    W_F(idf)%W_V(iv)%last_wrt_chk = -99
+  ENDIF
+!-----------------------
+END SUBROUTINE histw_rnd
+!===
+SUBROUTINE histwrite_real &
+ & (idf,iv,pitau,nbdpt,tbf_1,nbindex,nindex,do_oper,do_write)
+!---------------------------------------------------------------------
+!- This subroutine is internal and does the calculations and writing
+!- if needed. At a later stage it should be split into an operation
+!- and writing subroutines.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: idf,pitau,iv, &
+ &                      nbindex,nindex(nbindex),nbdpt
+  REAL,DIMENSION(:)  :: tbf_1
+  LOGICAL,INTENT(IN) :: do_oper,do_write
+!-
+  INTEGER :: tsz,nfid,nvid,iret,itax,io,nbin,nbout
+  INTEGER :: nx,ny,nz,ky,kz,kt,kc
+  INTEGER,DIMENSION(4) :: corner,edges
+  INTEGER :: itime
+  LOGICAL :: flag
+!-
+  REAL :: rtime
+  REAL,DIMENSION(2) :: t_bnd
+  CHARACTER(LEN=7) :: tmp_opp
+  REAL,ALLOCATABLE,DIMENSION(:),SAVE :: tbf_2
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "histwrite 0.0 : VAR : ",W_F(idf)%W_V(iv)%v_name
+    WRITE(ipslout,*) "histwrite 0.0 : nbindex :",nbindex
+    WRITE(ipslout,*) "histwrite 0.0 : nindex  :",nindex(1:MIN(3,nbindex)),'...'
+  ENDIF
+!-
+! The sizes which can be encoutered
+!-
+  tsz =  W_F(idf)%W_V(iv)%zsize(1) &
+ &      *W_F(idf)%W_V(iv)%zsize(2) &
+ &      *W_F(idf)%W_V(iv)%zsize(3)
+!-
+! 1.0 We allocate and the temporary space needed for operations.
+!     The buffers are only deallocated when more space is needed.
+!     This reduces the umber of allocates but increases memory needs.
+!-
+  IF (.NOT.ALLOCATED(tbf_2)) THEN
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) "histwrite_real 1.1 allocate tbf_2 ",SIZE(tbf_1)
+    ENDIF
+    ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max))
+  ELSE IF (W_F(idf)%W_V(iv)%datasz_max > SIZE(tbf_2)) THEN
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) "histwrite_real 1.2 re-allocate tbf_2 : ", &
+     & SIZE(tbf_1)," instead of ",SIZE(tbf_2)
+    ENDIF
+    DEALLOCATE(tbf_2)
+    ALLOCATE(tbf_2(W_F(idf)%W_V(iv)%datasz_max))
+  ENDIF
+!-
+  rtime = pitau*W_F(idf)%deltat
+  tmp_opp = W_F(idf)%W_V(iv)%topp
+!-
+! 3.0 Do the operations or transfer the slab of data into tbf_1
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "histwrite: 3.0",idf
+  ENDIF
+!-
+! 3.1 DO the Operations only if needed
+!-
+  IF (do_oper) THEN
+    nbout = nbdpt
+!-
+!-- 3.4 We continue the sequence of operations
+!--     we started in the interface routine
+!-
+    DO io=2,W_F(idf)%W_V(iv)%nbopp,2
+      nbin = nbout
+      nbout = W_F(idf)%W_V(iv)%datasz_max
+      CALL mathop(W_F(idf)%W_V(iv)%sopp(io),nbin,tbf_1, &
+ &      missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io), &
+ &      nbout,tbf_2)
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) &
+ &       "histwrite: 3.4a nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io)
+      ENDIF
+!-
+      nbin = nbout
+      nbout = W_F(idf)%W_V(iv)%datasz_max
+      CALL mathop(W_F(idf)%W_V(iv)%sopp(io+1),nbin,tbf_2, &
+ &      missing_val,nbindex,nindex,W_F(idf)%W_V(iv)%scal(io+1), &
+ &      nbout,tbf_1)
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) &
+ &     "histwrite: 3.4b nbout : ",nbin,nbout,W_F(idf)%W_V(iv)%sopp(io+1)
+      ENDIF
+    ENDDO
+!-
+!   3.5 Zoom into the data
+!-
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) &
+ &     "histwrite: 3.5 size(tbf_1) : ",SIZE(tbf_1)
+      WRITE(ipslout,*) &
+ &     "histwrite: 3.5 slab in X :", &
+ &     W_F(idf)%W_V(iv)%zorig(1),W_F(idf)%W_V(iv)%zsize(1)
+      WRITE(ipslout,*) &
+ &     "histwrite: 3.5 slab in Y :", &
+ &     W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zsize(2)
+      WRITE(ipslout,*) &
+ &     "histwrite: 3.5 slab in Z :", &
+ &     W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zsize(3)
+      WRITE(ipslout,*) &
+ &     "histwrite: 3.5 slab of input:", &
+ &     W_F(idf)%W_V(iv)%scsize(1), &
+ &     W_F(idf)%W_V(iv)%scsize(2), &
+ &     W_F(idf)%W_V(iv)%scsize(3)
+    ENDIF
+!---
+!-- We have to consider blocks of contiguous data
+!---
+    nx=MAX(W_F(idf)%W_V(iv)%zsize(1),1)
+    ny=MAX(W_F(idf)%W_V(iv)%zsize(2),1)
+    nz=MAX(W_F(idf)%W_V(iv)%zsize(3),1)
+    IF     (     (W_F(idf)%W_V(iv)%zorig(1) == 1) &
+ &          .AND.(   W_F(idf)%W_V(iv)%zsize(1) &
+ &                == W_F(idf)%W_V(iv)%scsize(1)) &
+ &          .AND.(W_F(idf)%W_V(iv)%zorig(2) == 1) &
+ &          .AND.(   W_F(idf)%W_V(iv)%zsize(2) &
+ &                == W_F(idf)%W_V(iv)%scsize(2))) THEN
+      kt = (W_F(idf)%W_V(iv)%zorig(3)-1)*nx*ny
+      tbf_2(1:nx*ny*nz) = tbf_1(kt+1:kt+nx*ny*nz)
+    ELSEIF (     (W_F(idf)%W_V(iv)%zorig(1) == 1) &
+ &          .AND.(   W_F(idf)%W_V(iv)%zsize(1) &
+ &                == W_F(idf)%W_V(iv)%scsize(1))) THEN
+      kc = -nx*ny
+      DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1
+        kc = kc+nx*ny
+        kt = ( (kz-1)*W_F(idf)%W_V(iv)%scsize(2) &
+ &            +W_F(idf)%W_V(iv)%zorig(2)-1)*nx
+        tbf_2(kc+1:kc+nx*ny) = tbf_1(kt+1:kt+nx*ny)
+      ENDDO
+    ELSE
+      kc = -nx
+      DO kz=W_F(idf)%W_V(iv)%zorig(3),W_F(idf)%W_V(iv)%zorig(3)+nz-1
+        DO ky=W_F(idf)%W_V(iv)%zorig(2),W_F(idf)%W_V(iv)%zorig(2)+ny-1
+          kc = kc+nx
+          kt = ((kz-1)*W_F(idf)%W_V(iv)%scsize(2)+ky-1) &
+ &            *W_F(idf)%W_V(iv)%scsize(1) &
+ &            +W_F(idf)%W_V(iv)%zorig(1)-1
+          tbf_2(kc+1:kc+nx) = tbf_1(kt+1:kt+nx)
+        ENDDO
+      ENDDO
+    ENDIF
+!-
+!-- 4.0 Get the min and max of the field
+!-
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) "histwrite: 4.0 tbf_1",idf,iv, &
+ &      TRIM(tmp_opp),' ---- ',LEN_TRIM(tmp_opp),nbindex
+    ENDIF
+!-
+    IF (W_F(idf)%W_V(iv)%hist_calc_rng) THEN
+      W_F(idf)%W_V(iv)%hist_minmax(1) = &
+ &      MIN(W_F(idf)%W_V(iv)%hist_minmax(1), &
+ &      MINVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val))
+      W_F(idf)%W_V(iv)%hist_minmax(2) = &
+ &      MAX(W_F(idf)%W_V(iv)%hist_minmax(2), &
+ &      MAXVAL(tbf_2(1:tsz),MASK=tbf_2(1:tsz) /= missing_val))
+    ENDIF
+!-
+!-- 5.0 Do the operations if needed. In the case of instantaneous
+!--     output we do not transfer to the time_buffer.
+!-
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) "histwrite: 5.0 idf : ",idf," iv : ",iv," tsz : ",tsz
+    ENDIF
+!-
+    IF (     (TRIM(tmp_opp) /= "inst") &
+ &      .AND.(TRIM(tmp_opp) /= "once") ) THEN
+
+!-
+!------ 5.1 Check if scatter operation is performed
+!-      
+       flag = .FALSE. 
+       DO io = 1, nbopp_max
+          IF ( INDEX(TRIM(W_F(idf)%W_V(iv)%sopp(io)),'scatter') > 0 ) THEN 
+             flag = .TRUE. 
+          END IF
+       END DO
+
+       IF ( flag ) THEN
+!-
+!------ 5.2  Enter moycum_index only if a scatter operation is performed
+!-         
+          IF (l_dbg) &
+               & WRITE(ipslout,*) "histwrite: 5.2 moycum_index",nbindex,nx,ny,nz
+          CALL moycum_index(tmp_opp, W_F(idf)%W_V(iv)%t_bf, &
+ &             tbf_2, W_F(idf)%W_V(iv)%nb_opp, nbindex, nindex)
+       ELSE
+!-
+!------ 5.3  Enter moycum otherwise
+!-
+          IF (l_dbg) &
+               & WRITE(ipslout,*) "histwrite: 5.3 moycum",nbindex,nx,ny
+          CALL moycum(tmp_opp,tsz,W_F(idf)%W_V(iv)%t_bf, &
+               &           tbf_2,W_F(idf)%W_V(iv)%nb_opp)
+       END IF
+
+    ENDIF
+!-
+    W_F(idf)%W_V(iv)%last_opp = pitau
+    W_F(idf)%W_V(iv)%nb_opp = W_F(idf)%W_V(iv)%nb_opp+1
+!-
+  ENDIF
+!-
+! 6.0 Write to file if needed
+!-
+  IF (l_dbg) WRITE(ipslout,*) "histwrite: 6.0",idf
+!-
+  IF (do_write) THEN
+!-
+    nfid = W_F(idf)%ncfid
+    nvid = W_F(idf)%W_V(iv)%ncvid
+!-
+!-- 6.1 Do the operations that are needed before writting
+!-
+    IF (l_dbg) WRITE(ipslout,*) "histwrite: 6.1",idf
+!-
+    IF (     (TRIM(tmp_opp) /= "inst") &
+ &      .AND.(TRIM(tmp_opp) /= "once") ) THEN
+      t_bnd(1:2) = (/ W_F(idf)%W_V(iv)%last_wrt*W_F(idf)%deltat,rtime /)
+      rtime = (t_bnd(1)+t_bnd(2))/2.0
+    ENDIF
+!-
+!-- 6.2 Add a value to the time axis of this variable if needed
+!-
+    IF (     (TRIM(tmp_opp) /= "l_max") &
+ &      .AND.(TRIM(tmp_opp) /= "l_min") &
+ &      .AND.(TRIM(tmp_opp) /= "once") ) THEN
+!-
+      IF (l_dbg) WRITE(ipslout,*) "histwrite: 6.2",idf
+!-
+      itax  = W_F(idf)%W_V(iv)%t_axid
+      itime = W_F(idf)%W_V(iv)%nb_wrt+1
+!-
+      IF (W_F(idf)%W_V(itax)%tax_last < itime) THEN
+        iret = NF90_PUT_VAR (nfid,W_F(idf)%W_V(itax)%tdimid, &
+ &               (/ rtime /),start=(/ itime /),count=(/ 1 /))
+        IF (W_F(idf)%W_V(itax)%tbndid > 0) THEN
+          iret = NF90_PUT_VAR (nfid,W_F(idf)%W_V(itax)%tbndid, &
+ &                 t_bnd,start=(/ 1,itime /),count=(/ 2,1 /))
+        ENDIF
+        W_F(idf)%W_V(itax)%tax_last = itime
+      ENDIF
+    ELSE
+      itime=1
+    ENDIF
+!-
+!-- 6.3 Write the data. Only in the case of instantaneous output
+!       we do not write the buffer.
+!-
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) "histwrite: 6.3",idf,nfid,nvid,iv,itime
+    ENDIF
+!-
+    IF (W_F(idf)%W_V(iv)%scsize(3) == 1) THEN
+      IF (W_F(idf)%regular) THEN
+        corner(1:4) = (/ 1,1,itime,0 /)
+        edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), &
+ &                      W_F(idf)%W_V(iv)%zsize(2),1,0 /)
+      ELSE
+        corner(1:4) = (/ 1,itime,0,0 /)
+        edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1),1,0,0 /)
+      ENDIF
+    ELSE
+      IF (W_F(idf)%regular) THEN
+        corner(1:4) = (/ 1,1,1,itime /)
+        edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), &
+ &                      W_F(idf)%W_V(iv)%zsize(2), &
+ &                      W_F(idf)%W_V(iv)%zsize(3),1 /)
+      ELSE
+        corner(1:4) = (/ 1,1,itime,0 /)
+        edges(1:4) = (/ W_F(idf)%W_V(iv)%zsize(1), &
+ &                      W_F(idf)%W_V(iv)%zsize(3),1,0 /)
+      ENDIF
+    ENDIF
+!-
+    IF (     (TRIM(tmp_opp) /= "inst") &
+ &      .AND.(TRIM(tmp_opp) /= "once") ) THEN
+      iret = NF90_PUT_VAR (nfid,nvid,W_F(idf)%W_V(iv)%t_bf, &
+ &                         start=corner(1:4),count=edges(1:4))
+    ELSE
+      iret = NF90_PUT_VAR (nfid,nvid,tbf_2, &
+ &                         start=corner(1:4),count=edges(1:4))
+    ENDIF
+!-
+    W_F(idf)%W_V(iv)%last_wrt = pitau
+    W_F(idf)%W_V(iv)%nb_wrt = W_F(idf)%W_V(iv)%nb_wrt+1
+    W_F(idf)%W_V(iv)%nb_opp = 0
+!---
+!   After the write the file can be synchronized so that no data is
+!   lost in case of a crash. This feature gives up on the benefits of
+!   buffering and should only be used in debuging mode. A flag is
+!   needed here to switch to this mode.
+!---
+!   iret = NF90_SYNC (nfid)
+!-
+  ENDIF
+!----------------------------
+END SUBROUTINE histwrite_real
+!===
+SUBROUTINE histvar_seq (idf,pvarname,idv)
+!---------------------------------------------------------------------
+!- This subroutine optimize the search for the variable in the table.
+!- In a first phase it will learn the succession of the variables
+!- called and then it will use the table to guess what comes next.
+!- It is the best solution to avoid lengthy searches through array
+!- vectors.
+!-
+!- ARGUMENTS :
+!-
+!- idf      : id of the file on which we work
+!- pvarname : The name of the variable we are looking for
+!- idv      : The var id we found
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(in)  :: idf
+  CHARACTER(LEN=*),INTENT(IN) :: pvarname
+  INTEGER,INTENT(out) :: idv
+!-
+  LOGICAL,SAVE :: learning(nb_files_max)=.TRUE.
+  INTEGER,SAVE :: overlap(nb_files_max) = -1
+  INTEGER,SAVE :: varseq(nb_files_max,nb_var_max*3)
+  INTEGER,SAVE :: varseq_len(nb_files_max) = 0
+  INTEGER,SAVE :: varseq_pos(nb_files_max)
+  INTEGER,SAVE :: varseq_err(nb_files_max) = 0
+  INTEGER      :: ib,sp,nn,pos
+  CHARACTER(LEN=70) :: str70
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) 'histvar_seq, start of the subroutine :',learning(idf)
+  ENDIF
+!-
+  IF (learning(idf)) THEN
+!-
+!-- 1.0 We compute the length over which we are going
+!--     to check the overlap
+!-
+    IF (overlap(idf) <= 0) THEN
+      IF (W_F(idf)%n_var > 6) THEN
+        overlap(idf) = W_F(idf)%n_var/3*2
+      ELSE
+        overlap(idf) = W_F(idf)%n_var
+      ENDIF
+    ENDIF
+!-
+!-- 1.1 Find the position of this string
+!-
+    CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos)
+    IF (pos > 0) THEN
+      idv = pos
+    ELSE
+      CALL ipslerr (3,"histvar_seq", &
+ &      'The name of the variable you gave has not been declared', &
+ &      'You should use subroutine histdef for declaring variable', &
+ &      TRIM(pvarname))
+    ENDIF
+!-
+!-- 1.2 If we have not given up we store the position
+!--     in the sequence of calls
+!-
+    IF (varseq_err(idf) >= 0) THEN
+      sp = varseq_len(idf)+1
+      IF (sp <= nb_var_max*3) THEN
+        varseq(idf,sp) = idv
+        varseq_len(idf) = sp
+      ELSE
+        CALL ipslerr (2,"histvar_seq",&
+ &       'The learning process has failed and we give up. '// &
+ &       'Either you sequence is',&
+ &       'too complex or I am too dumb. '// &
+ &       'This will only affect the efficiency',&
+ &       'of your code. Thus if you wish to save time'// &
+ &       ' contact the IOIPSL team. ')
+        WRITE(ipslout,*) 'The sequence we have found up to now :'
+        WRITE(ipslout,*) varseq(idf,1:sp-1)
+        varseq_err(idf) = -1
+      ENDIF
+!-
+!---- 1.3 Check if we have found the right overlap
+!-
+      IF (varseq_len(idf) >= overlap(idf)*2) THEN
+!-
+!------ We skip a few variables if needed as they could come
+!------ from the initialisation of the model.
+!-
+        DO ib = 0,sp-overlap(idf)*2
+          IF ( learning(idf) .AND.&
+            & SUM(ABS(varseq(idf,ib+1:ib+overlap(idf)) -&
+            & varseq(idf,sp-overlap(idf)+1:sp))) == 0 ) THEN
+            learning(idf) = .FALSE.
+            varseq_len(idf) = sp-overlap(idf)-ib
+            varseq_pos(idf) = overlap(idf)+ib
+            varseq(idf,1:varseq_len(idf)) = &
+ &            varseq(idf,ib+1:ib+varseq_len(idf))
+          ENDIF
+        ENDDO
+      ENDIF
+    ENDIF
+  ELSE
+!-
+!-- 2.0 Now we know how the calls to histwrite are sequenced
+!--     and we can get a guess at the var ID
+!-
+    nn = varseq_pos(idf)+1
+    IF (nn > varseq_len(idf)) nn = 1
+!-
+    idv = varseq(idf,nn)
+!-
+    IF (TRIM(W_F(idf)%W_V(idv)%v_name) /= TRIM(pvarname)) THEN
+      CALL find_str (W_F(idf)%W_V(1:W_F(idf)%n_var)%v_name,pvarname,pos)
+      IF (pos > 0) THEN
+        idv = pos
+      ELSE
+        CALL ipslerr (3,"histvar_seq", &
+ &  'The name of the variable you gave has not been declared',&
+ &  'You should use subroutine histdef for declaring variable', &
+ &  TRIM(pvarname))
+      ENDIF
+      varseq_err(idf) = varseq_err(idf)+1
+      IF (l_dbg) &
+           WRITE(ipslout,*) "Error history file ",W_F(idf)%name," names : ", &
+ &           TRIM(W_F(idf)%W_V(idv)%v_name),TRIM(pvarname)," id : ",idv
+    ELSE
+!-
+!---- We only keep the new position if we have found the variable
+!---- this way. This way an out of sequence call to histwrite does
+!---- not defeat the process.
+!-
+      varseq_pos(idf) = nn
+    ENDIF
+!-
+    IF (varseq_err(idf) >= 10) THEN
+      WRITE(str70,'("for file ",I3)') idf
+      CALL ipslerr (2,"histvar_seq", &
+ &  'There were 10 errors in the learned sequence of variables',&
+ &  str70,'This looks like a bug, please report it.')
+         varseq_err(idf) = 0
+    ENDIF
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) &
+ &   'histvar_seq, end of the subroutine :',TRIM(pvarname),idv
+  ENDIF
+!-------------------------
+END SUBROUTINE histvar_seq
+!===
+SUBROUTINE histsync (idf)
+!---------------------------------------------------------------------
+!- This subroutine will synchronise all
+!- (or one if defined) opened files.
+!-
+!- VERSION
+!-
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! idf  : optional argument for fileid
+  INTEGER,INTENT(in),OPTIONAL :: idf
+!-
+  INTEGER :: ifile,iret,i_s,i_e
+!-
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->histsync"
+  ENDIF
+!-
+  IF (PRESENT(idf)) THEN
+    IF ( (idf >= 1).AND.(idf <= nb_files_max) ) THEN
+      IF (W_F(idf)%ncfid > 0) THEN
+        i_s = idf
+        i_e = idf
+      ELSE
+        i_s = 1
+        i_e = 0
+        CALL ipslerr (2,'histsync', &
+ &       'Unable to synchronise the file :','probably','not opened')
+      ENDIF
+    ELSE
+      CALL ipslerr (3,'histsync','Invalid file identifier',' ',' ')
+    ENDIF
+  ELSE
+    i_s = 1
+    i_e = nb_files_max
+  ENDIF
+!-
+  DO ifile=i_s,i_e
+    IF (W_F(ifile)%ncfid > 0) THEN
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) '  histsync - synchronising file number ',ifile
+      ENDIF
+      iret = NF90_SYNC(W_F(ifile)%ncfid)
+    ENDIF
+  ENDDO
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-histsync"
+  ENDIF
+!----------------------
+END SUBROUTINE histsync
+!===
+SUBROUTINE histclo (idf)
+!---------------------------------------------------------------------
+!- This subroutine will close all (or one if defined) opened files
+!-
+!- VERSION
+!-
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! idf  : optional argument for fileid
+  INTEGER,INTENT(in),OPTIONAL :: idf
+!-
+  INTEGER :: ifile,nfid,nvid,iret,iv,i_s,i_e
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "->histclo"
+  ENDIF
+!-
+  IF (PRESENT(idf)) THEN
+    IF ( (idf >= 1).AND.(idf <= nb_files_max) ) THEN
+      IF (W_F(idf)%ncfid > 0) THEN
+        i_s = idf
+        i_e = idf
+      ELSE
+        i_s = 1
+        i_e = 0
+        CALL ipslerr (2,'histclo', &
+ &       'Unable to close the file :','probably','not opened')
+      ENDIF
+    ELSE
+      CALL ipslerr (3,'histclo','Invalid file identifier',' ',' ')
+    ENDIF
+  ELSE
+    i_s = 1
+    i_e = nb_files_max
+  ENDIF
+!-
+  DO ifile=i_s,i_e
+    IF (W_F(ifile)%ncfid > 0) THEN
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) '  histclo - closing specified file number :',ifile
+      ENDIF
+      nfid = W_F(ifile)%ncfid
+      iret = NF90_REDEF(nfid)
+!-----
+!---- 1. Loop on the number of variables to add some final information
+!-----
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) '  Entering loop on vars : ',W_F(ifile)%n_var
+      ENDIF
+      DO iv=1,W_F(ifile)%n_var
+!------ Extrema
+        IF (W_F(ifile)%W_V(iv)%hist_wrt_rng) THEN
+          IF (l_dbg) THEN
+            WRITE(ipslout,*) 'min value for file :',ifile,' var n. :',iv, &
+ &                     ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(1)
+            WRITE(ipslout,*) 'max value for file :',ifile,' var n. :',iv, &
+ &                     ' is : ',W_F(ifile)%W_V(iv)%hist_minmax(2)
+          ENDIF
+          IF (W_F(ifile)%W_V(iv)%hist_calc_rng) THEN
+!---------- Put the min and max values on the file
+            nvid = W_F(ifile)%W_V(iv)%ncvid
+            IF (W_F(ifile)%W_V(iv)%v_typ == hist_r8) THEN
+              iret = NF90_PUT_ATT(nfid,nvid,'valid_min', &
+ &                     REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=8))
+              iret = NF90_PUT_ATT(nfid,nvid,'valid_max', &
+ &                     REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=8))
+            ELSE
+              iret = NF90_PUT_ATT(nfid,nvid,'valid_min', &
+ &                     REAL(W_F(ifile)%W_V(iv)%hist_minmax(1),KIND=4))
+              iret = NF90_PUT_ATT(nfid,nvid,'valid_max', &
+ &                     REAL(W_F(ifile)%W_V(iv)%hist_minmax(2),KIND=4))
+            ENDIF
+          ENDIF
+        ENDIF
+!------ Time-Buffers
+        IF (ASSOCIATED(W_F(ifile)%W_V(iv)%t_bf)) THEN
+          DEALLOCATE(W_F(ifile)%W_V(iv)%t_bf)
+        ENDIF
+!------ Reinitialize the sizes
+        W_F(ifile)%W_V(iv)%datasz_in(:) = -1
+        W_F(ifile)%W_V(iv)%datasz_max = -1
+      ENDDO
+!-----
+!---- 2. Close the file
+!-----
+      IF (l_dbg) WRITE(ipslout,*) '  close file :',nfid
+      iret = NF90_CLOSE(nfid)
+      W_F(ifile)%ncfid = -1
+      W_F(ifile)%dom_id_svg = -1
+    ENDIF
+  ENDDO
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) "<-histclo"
+  ENDIF
+!---------------------
+END SUBROUTINE histclo
+!===
+SUBROUTINE ioconf_modname (str)
+!---------------------------------------------------------------------
+!- This subroutine allows to configure the name
+!- of the model written into the file
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(IN) :: str
+!---------------------------------------------------------------------
+  IF (.NOT.lock_modname) THEN
+    model_name = str(1:MIN(LEN_TRIM(str),80))
+    lock_modname = .TRUE.
+  ELSE
+    CALL ipslerr (2,"ioconf_modname", &
+   &  'The model name can only be changed once and only', &
+   &  'before it is used. It is now set to :',model_name)
+  ENDIF
+!----------------------------
+END SUBROUTINE ioconf_modname
+!-
+!===
+!-
+!-----------------
+END MODULE histcom
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/ioipsl.f90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/ioipsl.f90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/ioipsl.f90	(revision 17)
@@ -0,0 +1,17 @@
+MODULE ioipsl
+!
+!$Id: ioipsl.f90 386 2008-09-04 08:38:48Z bellier $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!
+  USE errioipsl 
+  USE stringop
+  USE mathelp    
+  USE getincom
+  USE calendar   
+  USE fliocom    
+  USE flincom    
+  USE histcom    
+  USE restcom
+END MODULE ioipsl
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/mathelp.f90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/mathelp.f90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/mathelp.f90	(revision 17)
@@ -0,0 +1,3200 @@
+MODULE mathelp
+!-
+!$Id: mathelp.f90 1927 2012-11-22 13:54:21Z dsolyga $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+  USE errioipsl,ONLY : ipslerr
+  USE stringop
+!-
+  PRIVATE
+  PUBLIC :: mathop,moycum,moycum_index,buildop
+!-
+  INTERFACE mathop
+    MODULE PROCEDURE mathop_r11,mathop_r21,mathop_r31
+  END INTERFACE
+!-
+!- Variables used to detect and identify the operations
+!-
+  CHARACTER(LEN=80),SAVE :: &
+ &  seps='( ) , + - / * ^', ops = '+ - * / ^', mima = 'min max'
+  CHARACTER(LEN=250),SAVE :: &
+ &  funcs = 'sin cos tan asin acos atan exp log sqrt chs abs '&
+ & //'cels kelv deg rad gather scatter fill coll undef only ident'
+  CHARACTER(LEN=120),SAVE :: &
+ &  indexfu = 'gather, scatter, fill, coll, undef, only'
+!---------------------------------------------------------------------
+CONTAINS
+!===
+SUBROUTINE buildop (c_str,ex_topps,topp,fill_val,opps,scal,nbops)
+!---------------------------------------------------------------------
+!- This subroutine decomposes the input string in the elementary
+!- functions which need to be applied to the vector of data.
+!- This vector is represented by X in the string.
+!- This subroutine is the driver of the decomposition and gets
+!- the time operation but then call decoop for the other operations
+!-
+!- INPUT
+!-
+!- c_str    : String containing the operations
+!- ex_toops : Time operations that can be expected within the string
+!- fill_val :
+!-
+!- OUTPUT
+!-
+!- topp   : Time operation
+!- opps   :
+!- scal   :
+!- nbops  :
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(IN) :: c_str,ex_topps
+  CHARACTER(LEN=*),INTENT(OUT) :: topp
+  CHARACTER(LEN=*),DIMENSION(:),INTENT(OUT) :: opps
+  REAL,INTENT(IN) :: fill_val
+  REAL,DIMENSION(:),INTENT(OUT) :: scal
+  INTEGER,INTENT(OUT) :: nbops
+!-
+  CHARACTER(LEN=LEN(c_str)) :: str,new_str
+  INTEGER :: leng,ind_opb,ind_clb
+!-
+  LOGICAL :: check = .FALSE.
+!---------------------------------------------------------------------
+  IF (check) WRITE(*,*) 'buildop : Some preliminary cleaning'
+!-
+  str = c_str
+  leng = LEN_TRIM(str)
+  IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN
+    str = str(2:leng-1)
+    leng = leng-2
+  ENDIF
+!-
+  IF (check) &
+ &  WRITE(*,*) 'buildop : Starting to test the various options'
+!-
+  IF (leng <= 5 .AND. INDEX(ex_topps,str(1:leng)) > 0) THEN
+    IF (check) WRITE(*,*) 'buildop : Time operation only'
+    nbops = 0
+    topp = str(1:leng)
+  ELSE
+    IF (check) THEN
+      WRITE(*,*) 'buildop : Time operation and something else'
+    ENDIF
+!--
+    ind_opb = INDEX(str(1:leng),'(')
+    IF (ind_opb > 0) THEN
+      IF (INDEX(ex_topps,str(1:ind_opb-1)) > 0) THEN
+        IF (check) THEN
+          WRITE(*,'(2a)') &
+ &          ' buildop : Extract time operation from : ',str
+        ENDIF
+        topp = str(1:ind_opb-1)
+        ind_clb = INDEX(str(1:leng),')',BACK=.TRUE.)
+        new_str = str(ind_opb+1:ind_clb-1)
+        IF (check) THEN
+          WRITE(*,'(2a,2I3)') &
+ &          ' buildop : Call decoop ',new_str,ind_opb,ind_clb
+        ENDIF
+        CALL decoop (new_str,fill_val,opps,scal,nbops)
+      ELSE
+        CALL ipslerr(3,'buildop', &
+ &        'time operation does not exist',str(1:ind_opb-1),' ')
+      ENDIF
+    ELSE
+      CALL ipslerr(3,'buildop', &
+ &      'some long operation exists but wihout parenthesis', &
+ &      str(1:leng),' ')
+    ENDIF
+  ENDIF
+!-
+  IF (check) THEN
+    DO leng=1,nbops
+      WRITE(*,*) &
+ &      'buildop : i -- opps, scal : ',leng,opps(leng),scal(leng)
+    ENDDO
+  ENDIF
+!---------------------
+END SUBROUTINE buildop
+!===
+SUBROUTINE decoop (pstr,fill_val,opps,scal,nbops)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(IN) :: pstr
+  REAL,INTENT(IN) :: fill_val
+  CHARACTER(LEN=*),DIMENSION(:),INTENT(OUT) :: opps
+  REAL,DIMENSION(:),INTENT(OUT) :: scal
+  INTEGER,INTENT(OUT) :: nbops
+!-
+  CHARACTER(LEN=1),DIMENSION(2) :: f_char,s_char
+  INTEGER,DIMENSION(2) :: f_pos,s_pos
+  CHARACTER(LEN=20) :: opp_str,scal_str
+  CHARACTER(LEN=LEN(pstr)) :: str
+  INTEGER :: nbsep,nbops_max,xpos,leng,ppos,epos,int_tmp
+  CHARACTER(LEN=3) :: tl,dl
+  CHARACTER(LEN=10) :: fmt
+!-
+  LOGICAL :: check = .FALSE.,prio
+!---------------------------------------------------------------------
+  IF (check) WRITE(*,'(2A)') ' decoop : Incoming string : ',pstr
+!-
+  str = pstr; nbops = 0;
+!-
+  CALL findsep (str,nbsep,f_char,f_pos,s_char,s_pos)
+  IF (check) WRITE(*,*) 'decoop : Out of findsep',nbsep
+!-
+  nbops_max = min(SIZE(opps),SIZE(scal))
+!-
+  DO WHILE (nbsep > 0)
+    IF (nbops >= nbops_max) THEN
+      CALL ipslerr(3,'decoop','Expression too complex',TRIM(str),' ')
+    ENDIF
+!--
+    xpos = INDEX(str,'X')
+    leng = LEN_TRIM(str)
+    nbops = nbops+1
+!--
+    IF (check) THEN
+      WRITE(*,*) 'decoop : str   -> ',TRIM(str)
+      WRITE(*,*) 'decoop : nbops -> ',nbops
+      WRITE(*,*) s_char(1),'-',f_char(1),'|',f_char(2),'-',s_char(2)
+      WRITE(*,*) s_pos(1),'-',f_pos(1),'|',f_pos(2),'-',s_pos(2)
+    ENDIF
+!---
+!-- Start the analysis of the syntax. 3 types of constructs
+!-- are recognized.  They are scanned sequentialy
+!---
+    IF (nbsep == 1) THEN
+      IF (check) WRITE(*,*) 'decoop : Only one operation'
+      IF (INDEX(ops,f_char(1)) > 0) THEN
+!------ Type : scal+X
+        IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN
+          opp_str = f_char(1)//'I'
+        ELSE
+          opp_str = f_char(1)
+        ENDIF
+        scal_str = str(s_pos(1)+1:f_pos(1)-1)
+        str = 'X'
+      ELSE IF (INDEX(ops,f_char(2)) > 0) THEN
+!------ Type : X+scal
+        opp_str = f_char(2)
+        scal_str = str(f_pos(2)+1:s_pos(2)-1)
+        str = 'X'
+      ELSE
+        CALL ipslerr(3,'decoop', &
+ &        'Unknown operations of type X+scal',f_char(1),pstr)
+      ENDIF
+    ELSE
+      IF (check) WRITE(*,*) 'decoop : More complex operation'
+      IF ( f_char(1) == '(' .AND. f_char(2) == ')' ) THEN
+!------ Type : sin(X)
+        opp_str = str(s_pos(1)+1:f_pos(1)-1)
+        scal_str = '?'
+        str = str(1:s_pos(1))//'X'//str(f_pos(2)+1:leng)
+      ELSE IF (    (f_char(1) == '(' .AND. f_char(2) == ',')&
+ &             .OR.(f_char(1) == ',' .AND. f_char(2) == ')')) THEN
+!------ Type : max(X,scal) or max(scal,X)
+        IF (f_char(1) == '(' .AND. s_char(2) == ')') THEN
+!-------- Type : max(X,scal)
+          opp_str = str(f_pos(1)-3:f_pos(1)-1)
+          scal_str = str(f_pos(2)+1:s_pos(2)-1)
+          str = str(1:f_pos(1)-4)//'X'//str(s_pos(2)+1:leng)
+        ELSE IF (f_char(1) == ',' .AND. s_char(1) == '(') THEN
+!-------- Type : max(scal,X)
+          opp_str = str(s_pos(1)-3:s_pos(1)-1)
+          scal_str = str(s_pos(1)+1:f_pos(1)-1)
+          str = str(1:s_pos(1)-4)//'X'//str(f_pos(2)+1:leng)
+        ELSE
+          CALL ipslerr(3,'decoop','Syntax error 1',str,' ')
+        ENDIF
+      ELSE
+        prio = (f_char(2) == '*').OR.(f_char(2) == '^')
+        IF (     (INDEX(ops,f_char(1)) > 0) &
+ &          .AND.(xpos-f_pos(1) == 1).AND.(.NOT.prio) ) THEN
+!-------- Type : ... scal+X ...
+          IF (f_char(1) == '-' .OR. f_char(1) == '/') THEN
+            opp_str = f_char(1)//'I'
+          ELSE
+            opp_str = f_char(1)
+          ENDIF
+          scal_str = str(s_pos(1)+1:f_pos(1)-1)
+          str = str(1:s_pos(1))//'X'//str(f_pos(1)+2:leng)
+        ELSE IF (     (INDEX(ops,f_char(2)) > 0) &
+ &               .AND.(f_pos(2)-xpos == 1) ) THEN
+!-------- Type : ... X+scal ...
+          opp_str = f_char(2)
+          scal_str = str(f_pos(2)+1:s_pos(2)-1)
+          str = str(1:f_pos(2)-2)//'X'//str(s_pos(2):leng)
+        ELSE
+          CALL ipslerr(3,'decoop','Syntax error 2',str,' ')
+        ENDIF
+      ENDIF
+    ENDIF
+!---
+    IF (check) WRITE(*,*) 'decoop : Finished syntax,str = ',TRIM(str)
+!---
+!-- Now that the different components of the operation are identified
+!-- we transform them into what is going to be used in the program
+!---
+    IF (INDEX(scal_str,'?') > 0) THEN
+      IF (INDEX(funcs,opp_str(1:LEN_TRIM(opp_str))) > 0) THEN
+        opps(nbops) = opp_str(1:LEN_TRIM(opp_str))
+        scal(nbops) = fill_val
+      ELSE
+        CALL ipslerr(3,'decoop', &
+ &        'Unknown function',opp_str(1:LEN_TRIM(opp_str)),' ')
+      ENDIF
+    ELSE
+      leng = LEN_TRIM(opp_str)
+      IF (INDEX(mima,opp_str(1:leng)) > 0) THEN
+        opps(nbops) = 'fu'//opp_str(1:leng)
+      ELSE
+        IF (INDEX(opp_str(1:leng),'+') > 0) THEN
+          opps(nbops) = 'add'
+        ELSE IF (INDEX(opp_str(1:leng),'-I') > 0) THEN
+          opps(nbops) = 'subi'
+        ELSE IF (INDEX(opp_str(1:leng),'-') > 0) THEN
+          opps(nbops) = 'sub'
+        ELSE IF (INDEX(opp_str(1:leng),'*') > 0) THEN
+          opps(nbops) = 'mult'
+        ELSE IF (INDEX(opp_str(1:leng),'/') > 0) THEN
+          opps(nbops) = 'div'
+        ELSE IF (INDEX(opp_str(1:leng),'/I') > 0) THEN
+          opps(nbops) = 'divi'
+        ELSE IF (INDEX(opp_str(1:leng),'^') > 0) THEN
+          opps(nbops) = 'power'
+        ELSE
+          CALL ipslerr(3,'decoop', &
+ &          'Unknown operation',opp_str(1:leng),' ')
+        ENDIF
+      ENDIF
+!-----
+      leng = LEN_TRIM(scal_str)
+      ppos = INDEX(scal_str,'.')
+      epos = INDEX(scal_str,'e')
+      IF (epos == 0) epos = INDEX(scal_str,'E')
+!-----
+!---- Try to catch a few errors
+!-----
+      IF (INDEX(ops,scal_str) > 0) THEN
+        CALL ipslerr(3,'decoop', &
+ &        'Strange scalar you have here ',scal_str,pstr)
+      ENDIF
+      IF (epos > 0) THEN
+        WRITE(tl,'(I3.3)') leng
+        WRITE(dl,'(I3.3)') epos-ppos-1
+        fmt='(e'//tl//'.'//dl//')'
+        READ(scal_str,fmt) scal(nbops)
+      ELSE IF (ppos > 0) THEN
+        WRITE(tl,'(I3.3)') leng
+        WRITE(dl,'(I3.3)') leng-ppos
+        fmt='(f'//tl//'.'//dl//')'
+        READ(scal_str,fmt) scal(nbops)
+      ELSE
+        WRITE(tl,'(I3.3)') leng
+        fmt = '(I'//tl//')'
+        READ(scal_str,fmt) int_tmp
+        scal(nbops) = REAL(int_tmp)
+      ENDIF
+    ENDIF
+    IF (check) WRITE(*,*) 'decoop : Finished interpretation'
+    CALL findsep(str,nbsep,f_char,f_pos,s_char,s_pos)
+  ENDDO
+!--------------------
+END SUBROUTINE decoop
+!===
+SUBROUTINE findsep (str,nbsep,f_char,f_pos,s_char,s_pos)
+!---------------------------------------------------------------------
+!- Subroutine finds all separators in a given string
+!- It returns the following information about str :
+!-   f_char : The first separation character
+!-            (1 for before and 2 for after)
+!-   f_pos  : The position of the first separator
+!-   s_char : The second separation character
+!-            (1 for before and 2 for after)
+!-   s_pos  : The position of the second separator
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(INOUT) :: str
+  INTEGER :: nbsep
+  CHARACTER(LEN=1),DIMENSION(2) :: f_char,s_char
+  INTEGER,DIMENSION(2) :: f_pos,s_pos
+!-
+  CHARACTER(LEN=10) :: str_tmp
+  LOGICAL :: f_found,s_found
+  INTEGER :: ind,xpos,leng,i
+!-
+  LOGICAL :: check = .FALSE.
+!---------------------------------------------------------------------
+  IF (check) WRITE(*,*) 'findsep : call cleanstr: ',TRIM(str)
+!-
+  CALL cleanstr(str)
+!-
+  IF (check) WRITE(*,*) 'findsep : out of cleanstr: ',TRIM(str)
+!-
+  xpos = INDEX(str,'X')
+  leng = LEN_TRIM(str)
+!-
+  f_pos(1:2) = (/ 0,leng+1 /)
+  f_char(1:2) = (/ '?','?' /)
+  s_pos(1:2) = (/ 0,leng+1 /)
+  s_char(1:2) = (/ '?','?' /)
+!-
+  nbsep = 0
+!-
+  f_found = .FALSE.
+  s_found = .FALSE.
+  IF (xpos > 1) THEN
+    DO i=xpos-1,1,-1
+      ind = INDEX(seps,str(i:i))
+      IF (ind > 0) THEN
+        IF (.NOT.f_found) THEN
+          f_char(1) = str(i:i)
+          f_pos(1) = i
+          nbsep = nbsep+1
+          f_found = .TRUE.
+        ELSE IF (.NOT.s_found) THEN
+          s_char(1) = str(i:i)
+          s_pos(1) = i
+          nbsep = nbsep+1
+          s_found = .TRUE.
+        ENDIF
+      ENDIF
+    ENDDO
+  ENDIF
+!-
+  f_found = .FALSE.
+  s_found = .FALSE.
+  IF (xpos < leng) THEN
+    DO i=xpos+1,leng
+      ind = INDEX(seps,str(i:i))
+      IF (ind > 0) THEN
+        IF (.NOT.f_found) THEN
+          f_char(2) = str(i:i)
+          f_pos(2) = i
+          nbsep = nbsep+1
+          f_found = .TRUE.
+        ELSE IF (.NOT.s_found) THEN
+          s_char(2) = str(i:i)
+          s_pos(2) = i
+          nbsep = nbsep+1
+          s_found = .TRUE.
+        ENDIF
+      ENDIF
+    ENDDO
+  ENDIF
+!-
+  IF (nbsep > 4) THEN
+    WRITE(str_tmp,'("number :",I3)') nbsep
+    CALL ipslerr(3,'findsep', &
+ &    'How can I find that many separators',str_tmp,TRIM(str))
+  ENDIF
+!-
+  IF (check) WRITE(*,*) 'Finished findsep : ',nbsep,leng
+!---------------------
+END SUBROUTINE findsep
+!===
+SUBROUTINE cleanstr(str)
+!---------------------------------------------------------------------
+!- We clean up the string by taking out the extra () and puting
+!- everything in lower case except for the X describing the variable
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(INOUT) :: str
+!-
+  INTEGER :: ind,leng,ic,it
+  LOGICAL :: check = .FALSE.
+!---------------------------------------------------------------------
+  leng = LEN_TRIM(str)
+  CALL strlowercase(str)
+!-
+  ind = INDEX(str,'x')
+  IF (check) THEN
+    WRITE (*,*) 'cleanstr 1.0 : ind = ',ind, &
+&               ' str = ',str(1:leng),'---'
+  ENDIF
+!-
+! If the character before the x is not a letter then we can assume
+! that it is the variable and promote it to a capital letter
+!-
+  DO WHILE (ind > 0)
+    ic = 0
+    IF (ind > 1) ic = IACHAR(str(ind-1:ind-1))
+    IF (ic < 97 .OR. ic > 122) THEN
+      str(ind:ind) = 'X'
+    ENDIF
+    it = INDEX(str(ind+1:leng),'x')
+    IF (it > 0) THEN
+      ind = ind+it
+    ELSE
+      ind = it
+    ENDIF
+  ENDDO
+!-
+  IF (check) WRITE (*,*) 'cleanstr 2.0 : str = ',str(1:leng),'---'
+!-
+  IF ( str(1:1) == '(' .AND. str(leng:leng) == ')' ) THEN
+    str = str(2:leng-1)
+  ENDIF
+!-
+  IF (check) WRITE (*,*) 'cleanstr 3.0 : str = ',str(1:leng),'---'
+!-
+  leng = LEN_TRIM(str)
+  ind = INDEX(str,'((X))')
+  IF (ind > 0) THEN
+    str=str(1:ind-1)//'(X)'//str(ind+5:leng)//'  '
+  ENDIF
+!-
+  IF (check) WRITE (*,*) 'cleanstr 4.0 : str = ',str(1:leng),'---'
+!-
+  leng = LEN_TRIM(str)
+  ind = INDEX(str,'(X)')
+  IF (ind > 0 .AND. ind+3 < leng) THEN
+    IF (      (INDEX(seps,str(ind-1:ind-1)) > 0) &
+ &      .AND. (INDEX(seps,str(ind+3:ind+3)) > 0) ) THEN
+      str=str(1:ind-1)//'X'//str(ind+3:leng)//'  '
+    ENDIF
+  ENDIF
+!-
+  IF (check) WRITE (*,*) 'cleanstr 5.0 : str = ',str(1:leng),'---'
+!-
+  leng = LEN_TRIM(str)
+  ind = INDEX(str(1:leng),' ')
+  DO WHILE (ind > 0)
+    str=str(1:ind-1)//str(ind+1:leng)//' '
+    leng = LEN_TRIM(str)
+    ind = INDEX(str(1:leng),' ')
+  ENDDO
+!-
+  IF (check) WRITE (*,*) 'cleanstr 6.0 : str = ',str(1:leng),'---'
+!----------------------
+END SUBROUTINE cleanstr
+!===
+!===
+SUBROUTINE mathop_r11 &
+ &  (fun,nb,work_in,miss_val,nb_index,nindex,scal,nb_max,work_out)
+!---------------------------------------------------------------------
+!- This subroutines gives an interface to the various operation
+!- which are allowed. The interface is general enough to allow its use
+!- for other cases.
+!-
+!- INPUT
+!-
+!- fun      : function to be applied to the vector of data
+!- nb       : Length of input vector
+!- work_in  : Input vector of data (REAL)
+!- miss_val : The value of the missing data flag (it has to be a
+!-            maximum value, in f90 : huge( a real ))
+!- nb_index : Length of index vector
+!- nindex   : Vector of indices
+!- scal     : A scalar value for vector/scalar operations
+!- nb_max   : maximum length of output vector
+!-
+!- OUTPUT
+!-
+!- nb_max   : Actual length of output variable
+!- work_out : Output vector after the operation was applied
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=7) :: fun
+  INTEGER :: nb,nb_max,nb_index
+  INTEGER :: nindex(nb_index)
+  REAL :: work_in(nb),scal,miss_val
+  REAL :: work_out(nb_max)
+!-
+  INTEGER :: ierr
+!-
+  INTRINSIC SIN,COS,TAN,ASIN,ACOS,ATAN,EXP,LOG,SQRT,ABS
+!---------------------------------------------------------------------
+  ierr = 0
+!-
+  IF (scal >= miss_val-1.) THEN
+    IF (INDEX(indexfu,fun(1:LEN_TRIM(fun))) == 0) THEN
+      SELECT CASE (fun)
+      CASE('sin')
+        ierr = ma_sin_r11(nb,work_in,nb_max,work_out)
+      CASE('cos')
+        ierr = ma_cos_r11(nb,work_in,nb_max,work_out)
+      CASE('tan')
+        ierr = ma_tan_r11(nb,work_in,nb_max,work_out)
+      CASE('asin')
+        ierr = ma_asin_r11(nb,work_in,nb_max,work_out)
+      CASE('acos')
+        ierr = ma_acos_r11(nb,work_in,nb_max,work_out)
+      CASE('atan')
+        ierr = ma_atan_r11(nb,work_in,nb_max,work_out)
+      CASE('exp')
+        ierr = ma_exp_r11(nb,work_in,nb_max,work_out)
+      CASE('log')
+        ierr = ma_log_r11(nb,work_in,nb_max,work_out)
+      CASE('sqrt')
+        ierr = ma_sqrt_r11(nb,work_in,nb_max,work_out)
+      CASE('chs')
+        ierr = ma_chs_r11(nb,work_in,nb_max,work_out)
+      CASE('abs')
+        ierr = ma_abs_r11(nb,work_in,nb_max,work_out)
+      CASE('cels')
+        ierr = ma_cels_r11(nb,work_in,nb_max,work_out)
+      CASE('kelv')
+        ierr = ma_kelv_r11(nb,work_in,nb_max,work_out)
+      CASE('deg')
+        ierr = ma_deg_r11(nb,work_in,nb_max,work_out)
+      CASE('rad')
+        ierr = ma_rad_r11(nb,work_in,nb_max,work_out)
+      CASE('ident')
+        ierr = ma_ident_r11(nb,work_in,nb_max,work_out)
+      CASE DEFAULT
+        CALL ipslerr(3,"mathop", &
+ &        'scalar variable undefined and no indexing', &
+ &        'but still unknown function',fun)
+      END SELECT
+      IF (ierr > 0) THEN
+        CALL ipslerr(3,"mathop", &
+ &        'Error while executing a simple function',fun,' ')
+      ENDIF
+    ELSE
+      SELECT CASE (fun)
+      CASE('gather')
+        ierr = ma_fugath_r11(nb,work_in,nb_index,nindex, &
+&                            miss_val,nb_max,work_out)
+      CASE('scatter')
+        IF (nb_index > nb) THEN
+          work_out(1:nb_max) = miss_val
+          ierr=1
+        ELSE
+          ierr = ma_fuscat_r11(nb,work_in,nb_index,nindex, &
+&                              miss_val,nb_max,work_out)
+        ENDIF
+      CASE('coll')
+        ierr = ma_fucoll_r11(nb,work_in,nb_index,nindex, &
+&                            miss_val,nb_max,work_out)
+      CASE('fill')
+        ierr = ma_fufill_r11(nb,work_in,nb_index,nindex, &
+&                            miss_val,nb_max,work_out)
+      CASE('undef')
+        ierr = ma_fuundef_r11(nb,work_in,nb_index,nindex, &
+&                            miss_val,nb_max,work_out)
+      CASE('only')
+        ierr = ma_fuonly_r11(nb,work_in,nb_index,nindex, &
+&                            miss_val,nb_max,work_out)
+      CASE DEFAULT
+        CALL ipslerr(3,"mathop", &
+ &        'scalar variable undefined and indexing',&
+ &        'was requested but with unknown function',fun)
+      END SELECT
+      IF (ierr > 0) THEN
+        CALL ipslerr(3,"mathop_r11", &
+ &        'Error while executing an indexing function',fun,' ')
+      ENDIF
+    ENDIF
+  ELSE
+    SELECT CASE (fun)
+    CASE('fumin')
+      ierr = ma_fumin_r11(nb,work_in,scal,nb_max,work_out)
+    CASE('fumax')
+      ierr = ma_fumax_r11(nb,work_in,scal,nb_max,work_out)
+    CASE('add')
+      ierr = ma_add_r11(nb,work_in,scal,nb_max,work_out)
+    CASE('subi')
+      ierr = ma_subi_r11(nb,work_in,scal,nb_max,work_out)
+    CASE('sub')
+      ierr = ma_sub_r11(nb,work_in,scal,nb_max,work_out)
+    CASE('mult')
+      ierr = ma_mult_r11(nb,work_in,scal,nb_max,work_out)
+    CASE('div')
+      ierr = ma_div_r11(nb,work_in,scal,nb_max,work_out)
+    CASE('divi')
+      ierr = ma_divi_r11(nb,work_in,scal,nb_max,work_out)
+    CASE('power')
+      ierr = ma_power_r11(nb,work_in,scal,nb_max,work_out)
+    CASE DEFAULT
+      CALL ipslerr(3,"mathop", &
+ &      'Unknown operation with a scalar',fun,' ')
+    END SELECT
+    IF (ierr > 0) THEN
+      CALL ipslerr(3,"mathop", &
+ &      'Error while executing a scalar function',fun,' ')
+    ENDIF
+  ENDIF
+!------------------------
+END SUBROUTINE mathop_r11
+!-
+!=== FUNCTIONS (only one argument)
+!-
+INTEGER FUNCTION ma_sin_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = SIN(x(i))
+  ENDDO
+!-
+  nbo = nb
+  ma_sin_r11 = 0
+!----------------------
+END FUNCTION ma_sin_r11
+!===
+INTEGER FUNCTION ma_cos_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = COS(x(i))
+  ENDDO
+!-
+  nbo = nb
+  ma_cos_r11 = 0
+!----------------------
+END FUNCTION ma_cos_r11
+!===
+INTEGER FUNCTION ma_tan_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = TAN(x(i))
+  ENDDO
+!-
+  nbo = nb
+  ma_tan_r11 = 0
+!----------------------
+END FUNCTION ma_tan_r11
+!===
+INTEGER FUNCTION ma_asin_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = ASIN(x(i))
+  ENDDO
+!-
+  nbo = nb
+  ma_asin_r11 = 0
+!-----------------------
+END FUNCTION ma_asin_r11
+!===
+INTEGER FUNCTION ma_acos_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = ACOS(x(i))
+  ENDDO
+!-
+  nbo = nb
+  ma_acos_r11 = 0
+!-----------------------
+END FUNCTION ma_acos_r11
+!===
+INTEGER FUNCTION ma_atan_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = ATAN(x(i))
+  ENDDO
+!-
+  nbo = nb
+  ma_atan_r11 = 0
+!-----------------------
+END FUNCTION ma_atan_r11
+!===
+INTEGER FUNCTION ma_exp_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = EXP(x(i))
+  ENDDO
+!-
+  nbo = nb
+  ma_exp_r11 = 0
+!----------------------
+END FUNCTION ma_exp_r11
+!===
+INTEGER FUNCTION ma_log_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = log(x(i))
+  ENDDO
+!-
+  nbo = nb
+  ma_log_r11 = 0
+!----------------------
+END FUNCTION ma_log_r11
+!===
+INTEGER FUNCTION ma_sqrt_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = SQRT(x(i))
+  ENDDO
+!-
+  nbo = nb
+  ma_sqrt_r11 = 0
+!-----------------------
+END FUNCTION ma_sqrt_r11
+!===
+INTEGER FUNCTION ma_abs_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = ABS(x(i))
+  ENDDO
+!-
+  nbo = nb
+  ma_abs_r11 = 0
+!----------------------
+END FUNCTION ma_abs_r11
+!===
+INTEGER FUNCTION ma_chs_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = x(i)*(-1.)
+  ENDDO
+!-
+  nbo = nb
+  ma_chs_r11 = 0
+!----------------------
+END FUNCTION ma_chs_r11
+!===
+INTEGER FUNCTION ma_cels_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = x(i)-273.15
+  ENDDO
+!-
+  nbo = nb
+  ma_cels_r11 = 0
+!-----------------------
+END FUNCTION ma_cels_r11
+!===
+INTEGER FUNCTION ma_kelv_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = x(i)+273.15
+  ENDDO
+!-
+  nbo = nb
+  ma_kelv_r11 = 0
+!-----------------------
+END FUNCTION ma_kelv_r11
+!===
+INTEGER FUNCTION ma_deg_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = x(i)*57.29577951
+  ENDDO
+!-
+  nbo = nb
+  ma_deg_r11 = 0
+!-----------------------
+END FUNCTION ma_deg_r11
+!===
+INTEGER FUNCTION ma_rad_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = x(i)*0.01745329252
+  ENDDO
+!-
+  nbo = nb
+  ma_rad_r11 = 0
+!----------------------
+END FUNCTION ma_rad_r11
+!===
+INTEGER FUNCTION ma_ident_r11(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,i
+  REAL :: x(nb),y(nbo)
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = x(i)
+  ENDDO
+!-
+  nbo = nb
+  ma_ident_r11 = 0
+!------------------------
+END FUNCTION ma_ident_r11
+!-
+!=== OPERATIONS (two argument)
+!-
+INTEGER FUNCTION ma_add_r11(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo
+  REAL :: x(nb),s,y(nbo)
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = x(i)+s
+  ENDDO
+!-
+  nbo = nb
+  ma_add_r11 = 0
+!-----------------------
+  END FUNCTION ma_add_r11
+!===
+INTEGER FUNCTION ma_sub_r11(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo
+  REAL :: x(nb),s,y(nbo)
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = x(i)-s
+  ENDDO
+!-
+  nbo = nb
+  ma_sub_r11 = 0
+!----------------------
+END FUNCTION ma_sub_r11
+!===
+INTEGER FUNCTION ma_subi_r11(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo
+  REAL :: x(nb),s,y(nbo)
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) =  s-x(i)
+  ENDDO
+!-
+  nbo = nb
+  ma_subi_r11 = 0
+!-----------------------
+END FUNCTION ma_subi_r11
+!===
+INTEGER FUNCTION ma_mult_r11(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo
+  REAL :: x(nb),s,y(nbo)
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = x(i)*s
+  ENDDO
+!-
+  nbo = nb
+  ma_mult_r11 = 0
+!-----------------------
+END FUNCTION ma_mult_r11
+!===
+INTEGER FUNCTION ma_div_r11(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo
+  REAL :: x(nb),s,y(nbo)
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = x(i)/s
+  ENDDO
+!-
+  nbo = nb
+  ma_div_r11 = 0
+!-----------------------
+  END FUNCTION ma_div_r11
+!===
+INTEGER FUNCTION ma_divi_r11(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo
+  REAL :: x(nb),s,y(nbo)
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = s/x(i)
+  ENDDO
+!-
+  nbo = nb
+  ma_divi_r11 = 0
+!-----------------------
+END FUNCTION ma_divi_r11
+!===
+INTEGER FUNCTION ma_power_r11(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo
+  REAL :: x(nb),s,y(nbo)
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = x(i)**s
+  ENDDO
+!-
+  nbo = nb
+  ma_power_r11 = 0
+!-----------------------
+END FUNCTION ma_power_r11
+!===
+INTEGER FUNCTION ma_fumin_r11(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo
+  REAL :: x(nb),s,y(nbo)
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = MIN(x(i),s)
+  ENDDO
+!-
+  nbo = nb
+  ma_fumin_r11 = 0
+!------------------------
+END FUNCTION ma_fumin_r11
+!===
+INTEGER FUNCTION ma_fumax_r11(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo
+  REAL :: x(nb),s,y(nbo)
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  DO i=1,nb
+    y(i) = MAX(x(i),s)
+  ENDDO
+!-
+  nbo = nb
+  ma_fumax_r11 = 0
+!------------------------
+END FUNCTION ma_fumax_r11
+!===
+INTEGER FUNCTION ma_fuscat_r11(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb),miss_val,y(nbo)
+!-
+  INTEGER :: i,ii,ipos
+!---------------------------------------------------------------------
+  ma_fuscat_r11 = 0
+!-
+  y(1:nbo) = miss_val
+!-
+  IF (nbi <= nb) THEN
+    ipos = 0
+    DO i=1,nbi
+      IF (ind(i) <= nbo .AND. ind(i) > 0) THEN
+        ipos = ipos+1
+        y(ind(i)) = x(ipos)
+      ELSE
+        IF (ind(i) > nbo) ma_fuscat_r11  = ma_fuscat_r11+1
+      ENDIF
+    ENDDO
+!-- Repeat the data if needed
+    IF (MINVAL(ind) < 0) THEN
+      DO i=1,nbi
+        IF (ind(i) <= 0) THEN
+          DO ii=1,ABS(ind(i))-1
+            IF (ind(i+1)+ii <= nbo) THEN
+              y(ind(i+1)+ii) = y(ind(i+1))
+            ELSE
+              ma_fuscat_r11  = ma_fuscat_r11+1
+            ENDIF
+          ENDDO
+        ENDIF
+      ENDDO
+    ENDIF
+  ELSE
+    ma_fuscat_r11  = 1
+  ENDIF
+!-------------------------
+END FUNCTION ma_fuscat_r11
+!===
+INTEGER FUNCTION ma_fugath_r11(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb),miss_val,y(nbo)
+!-
+  INTEGER :: i,ipos
+!---------------------------------------------------------------------
+  IF (nbi <= nbo) THEN
+    ma_fugath_r11 = 0
+    y(1:nbo) = miss_val
+    ipos = 0
+    DO i=1,nbi
+      IF (ipos+1 <= nbo) THEN
+        IF (ind(i) > 0) THEN
+          ipos = ipos+1
+          y(ipos) = x(ind(i))
+        ENDIF
+      ELSE
+        IF (ipos+1 > nbo) ma_fugath_r11  = ma_fugath_r11+1
+      ENDIF
+    ENDDO
+  ELSE
+    ma_fugath_r11 = 1
+  ENDIF
+!-
+  nbo = ipos
+!-------------------------
+END FUNCTION ma_fugath_r11
+!===
+INTEGER FUNCTION ma_fufill_r11(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb),miss_val,y(nbo)
+!-
+  INTEGER :: i,ii,ipos
+!---------------------------------------------------------------------
+  ma_fufill_r11 = 0
+!-
+  IF (nbi <= nb) THEN
+    ipos = 0
+    DO i=1,nbi
+      IF (ind(i) <= nbo .AND. ind(i) > 0) THEN
+        ipos = ipos+1
+        y(ind(i)) = x(ipos)
+      ELSE
+        IF (ind(i) > nbo) ma_fufill_r11  = ma_fufill_r11+1
+      ENDIF
+    ENDDO
+!-- Repeat the data if needed
+    IF (MINVAL(ind) < 0) THEN
+      DO i=1,nbi
+        IF (ind(i) <= 0) THEN
+          DO ii=1,ABS(ind(i))-1
+            IF (ind(i+1)+ii <= nbo) THEN
+              y(ind(i+1)+ii) = y(ind(i+1))
+            ELSE
+              ma_fufill_r11  = ma_fufill_r11+1
+            ENDIF
+          ENDDO
+        ENDIF
+      ENDDO
+    ENDIF
+  ELSE
+    ma_fufill_r11  = 1
+  ENDIF
+!-------------------------
+END FUNCTION ma_fufill_r11
+!===
+INTEGER FUNCTION ma_fucoll_r11(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb),miss_val,y(nbo)
+!-
+  INTEGER :: i,ipos
+!---------------------------------------------------------------------
+  IF (nbi <= nbo) THEN
+    ma_fucoll_r11 = 0
+    ipos = 0
+    DO i=1,nbi
+      IF (ipos+1 <= nbo) THEN
+        IF (ind(i) > 0) THEN
+          ipos = ipos+1
+          y(ipos) = x(ind(i))
+        ENDIF
+      ELSE
+        IF (ipos+1 > nbo) ma_fucoll_r11  = ma_fucoll_r11+1
+      ENDIF
+    ENDDO
+  ELSE
+    ma_fucoll_r11 = 1
+  ENDIF
+!-
+  nbo = ipos
+!-------------------------
+END FUNCTION ma_fucoll_r11
+!===
+INTEGER FUNCTION ma_fuundef_r11(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb),miss_val,y(nbo)
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  IF (nbi <= nbo .AND. nbo == nb) THEN
+    ma_fuundef_r11 = 0
+    DO i=1,nbo
+      y(i) = x(i)
+    ENDDO
+    DO i=1,nbi
+      IF (ind(i) <= nbo .AND. ind(i) > 0) THEN
+        y(ind(i)) =  miss_val
+      ELSE
+        IF (ind(i) > nbo) ma_fuundef_r11  = ma_fuundef_r11+1
+      ENDIF
+    ENDDO
+  ELSE
+    ma_fuundef_r11 = 1
+  ENDIF
+!--------------------------
+END FUNCTION ma_fuundef_r11
+!===
+INTEGER FUNCTION ma_fuonly_r11(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb,nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb),miss_val,y(nbo)
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  IF (     (nbi <= nbo).AND.(nbo == nb) &
+ &    .AND.ALL(ind(1:nbi) <= nbo) ) THEN
+    ma_fuonly_r11 = 0
+    y(1:nbo) = miss_val
+    DO i=1,nbi
+      IF (ind(i) > 0) THEN
+        y(ind(i)) =  x(ind(i))
+      ENDIF
+    ENDDO
+  ELSE
+    ma_fuonly_r11 = 1
+  ENDIF
+!-------------------------
+END FUNCTION ma_fuonly_r11
+!===
+!===
+SUBROUTINE mathop_r21 &
+ &  (fun,nb,work_in,miss_val,nb_index,nindex,scal,nb_max,work_out)
+!---------------------------------------------------------------------
+!- This subroutines gives an interface to the various operations
+!- which are allowed. The interface is general enough to allow its use
+!- for other cases.
+!-
+!- INPUT
+!-
+!- fun      : function to be applied to the vector of data
+!- nb       : Length of input vector
+!- work_in  : Input vector of data (REAL)
+!- miss_val : The value of the missing data flag (it has to be a
+!-            maximum value, in f90 : huge( a real ))
+!- nb_index : Length of index vector
+!- nindex   : Vector of indices
+!- scal     : A scalar value for vector/scalar operations
+!- nb_max   : maximum length of output vector
+!-
+!- OUTPUT
+!-
+!- nb_max   : Actual length of output variable
+!- work_out : Output vector after the operation was applied
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=7) :: fun
+  INTEGER :: nb(2),nb_max,nb_index
+  INTEGER :: nindex(nb_index)
+  REAL :: work_in(nb(1),nb(2)),scal,miss_val
+  REAL :: work_out(nb_max)
+!-
+  INTEGER :: ierr
+!-
+  INTRINSIC SIN,COS,TAN,ASIN,ACOS,ATAN,EXP,LOG,SQRT,ABS
+!---------------------------------------------------------------------
+  ierr = 0
+!-
+  IF (scal >= miss_val-1.) THEN
+    IF (INDEX(indexfu,fun(1:LEN_TRIM(fun))) == 0) THEN
+      SELECT CASE (fun)
+      CASE('sin')
+        ierr = ma_sin_r21(nb,work_in,nb_max,work_out)
+      CASE('cos')
+        ierr = ma_cos_r21(nb,work_in,nb_max,work_out)
+      CASE('tan')
+        ierr = ma_tan_r21(nb,work_in,nb_max,work_out)
+      CASE('asin')
+        ierr = ma_asin_r21(nb,work_in,nb_max,work_out)
+      CASE('acos')
+        ierr = ma_acos_r21(nb,work_in,nb_max,work_out)
+      CASE('atan')
+        ierr = ma_atan_r21(nb,work_in,nb_max,work_out)
+      CASE('exp')
+        ierr = ma_exp_r21(nb,work_in,nb_max,work_out)
+      CASE('log')
+        ierr = ma_log_r21(nb,work_in,nb_max,work_out)
+      CASE('sqrt')
+        ierr = ma_sqrt_r21(nb,work_in,nb_max,work_out)
+      CASE('chs')
+        ierr = ma_chs_r21(nb,work_in,nb_max,work_out)
+      CASE('abs')
+        ierr = ma_abs_r21(nb,work_in,nb_max,work_out)
+      CASE('cels')
+        ierr = ma_cels_r21(nb,work_in,nb_max,work_out)
+      CASE('kelv')
+        ierr = ma_kelv_r21(nb,work_in,nb_max,work_out)
+      CASE('deg')
+        ierr = ma_deg_r21(nb,work_in,nb_max,work_out)
+      CASE('rad')
+        ierr = ma_rad_r21(nb,work_in,nb_max,work_out)
+      CASE('ident')
+        ierr = ma_ident_r21(nb,work_in,nb_max,work_out)
+      CASE DEFAULT
+        CALL ipslerr(3,"mathop", &
+ &        'scalar variable undefined and no indexing', &
+ &        'but still unknown function',fun)
+      END SELECT
+      IF (ierr > 0) THEN
+        CALL ipslerr(3,"mathop", &
+ &        'Error while executing a simple function',fun,' ')
+      ENDIF
+    ELSE
+      SELECT CASE (fun)
+      CASE('gather')
+        ierr = ma_fugath_r21(nb,work_in,nb_index,nindex, &
+ &                            miss_val,nb_max,work_out)
+      CASE('scatter')
+        IF (nb_index > (nb(1)*nb(2)) ) THEN
+          work_out(1:nb_max) = miss_val
+          ierr=1
+        ELSE
+          ierr = ma_fuscat_r21(nb,work_in,nb_index,nindex, &
+ &                             miss_val,nb_max,work_out)
+        ENDIF
+      CASE('coll')
+        ierr = ma_fucoll_r21(nb,work_in,nb_index,nindex, &
+ &                           miss_val,nb_max,work_out)
+      CASE('fill')
+        ierr = ma_fufill_r21(nb,work_in,nb_index,nindex, &
+ &                           miss_val,nb_max,work_out)
+      CASE('undef')
+        ierr = ma_fuundef_r21(nb,work_in,nb_index,nindex, &
+ &                           miss_val,nb_max,work_out)
+      CASE('only')
+        ierr = ma_fuonly_r21(nb,work_in,nb_index,nindex, &
+ &                           miss_val,nb_max,work_out)
+      CASE DEFAULT
+        CALL ipslerr(3,"mathop", &
+ &        'scalar variable undefined and indexing', &
+ &        'was requested but with unknown function',fun)
+      END SELECT
+      IF (ierr > 0) THEN
+        CALL ipslerr(3,"mathop_r21", &
+ &        'Error while executing an indexing function',fun,' ')
+      ENDIF
+    ENDIF
+  ELSE
+    SELECT CASE (fun)
+    CASE('fumin')
+      ierr = ma_fumin_r21(nb,work_in,scal,nb_max,work_out)
+    CASE('fumax')
+      ierr = ma_fumax_r21(nb,work_in,scal,nb_max,work_out)
+    CASE('add')
+      ierr = ma_add_r21(nb,work_in,scal,nb_max,work_out)
+    CASE('subi')
+      ierr = ma_subi_r21(nb,work_in,scal,nb_max,work_out)
+    CASE('sub')
+      ierr = ma_sub_r21(nb,work_in,scal,nb_max,work_out)
+    CASE('mult')
+      ierr = ma_mult_r21(nb,work_in,scal,nb_max,work_out)
+    CASE('div')
+      ierr = ma_div_r21(nb,work_in,scal,nb_max,work_out)
+    CASE('divi')
+      ierr = ma_divi_r21(nb,work_in,scal,nb_max,work_out)
+    CASE('power')
+      ierr = ma_power_r21(nb,work_in,scal,nb_max,work_out)
+    CASE DEFAULT
+      CALL ipslerr(3,"mathop", &
+ &      'Unknown operation with a scalar',fun,' ')
+    END SELECT
+    IF (ierr > 0) THEN
+      CALL ipslerr(3,"mathop", &
+ &      'Error while executing a scalar function',fun,' ')
+    ENDIF
+  ENDIF
+!------------------------
+END SUBROUTINE mathop_r21
+!-
+!=== FUNCTIONS (only one argument)
+!-
+INTEGER FUNCTION ma_sin_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = SIN(x(i,j))
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_sin_r21 = 0
+!----------------------
+END FUNCTION ma_sin_r21
+!===
+INTEGER FUNCTION ma_cos_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = COS(x(i,j))
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_cos_r21 = 0
+!----------------------
+END FUNCTION ma_cos_r21
+!===
+INTEGER FUNCTION ma_tan_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = TAN(x(i,j))
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_tan_r21 = 0
+!----------------------
+END FUNCTION ma_tan_r21
+!===
+  INTEGER FUNCTION ma_asin_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = ASIN(x(i,j))
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_asin_r21 = 0
+!-----------------------
+END FUNCTION ma_asin_r21
+!===
+INTEGER FUNCTION ma_acos_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = ACOS(x(i,j))
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_acos_r21 = 0
+!-----------------------
+END FUNCTION ma_acos_r21
+!===
+INTEGER FUNCTION ma_atan_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = ATAN(x(i,j))
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_atan_r21 = 0
+!-----------------------
+END FUNCTION ma_atan_r21
+!===
+INTEGER FUNCTION ma_exp_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = EXP(x(i,j))
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_exp_r21 = 0
+!----------------------
+END FUNCTION ma_exp_r21
+!===
+INTEGER FUNCTION ma_log_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = LOG(x(i,j))
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_log_r21 = 0
+!----------------------
+END FUNCTION ma_log_r21
+!===
+INTEGER FUNCTION ma_sqrt_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = SQRT(x(i,j))
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_sqrt_r21 = 0
+!-----------------------
+END FUNCTION ma_sqrt_r21
+!===
+INTEGER FUNCTION ma_abs_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = ABS(x(i,j))
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_abs_r21 = 0
+!----------------------
+END FUNCTION ma_abs_r21
+!===
+INTEGER FUNCTION ma_chs_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = x(i,j)*(-1.)
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_chs_r21 = 0
+!----------------------
+END FUNCTION ma_chs_r21
+!===
+INTEGER FUNCTION ma_cels_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = x(i,j)-273.15
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_cels_r21 = 0
+!-----------------------
+END FUNCTION ma_cels_r21
+!===
+INTEGER FUNCTION ma_kelv_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = x(i,j)+273.15
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_kelv_r21 = 0
+!-----------------------
+END FUNCTION ma_kelv_r21
+!===
+INTEGER FUNCTION ma_deg_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = x(i,j)*57.29577951
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_deg_r21 = 0
+!----------------------
+END FUNCTION ma_deg_r21
+!===
+INTEGER FUNCTION ma_rad_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = x(i,j)*0.01745329252
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_rad_r21 = 0
+!----------------------
+END FUNCTION ma_rad_r21
+!===
+INTEGER FUNCTION ma_ident_r21(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,i,j,ij
+  REAL :: x(nb(1),nb(2)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = x(i,j)
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_ident_r21 = 0
+!------------------------
+END FUNCTION ma_ident_r21
+!-
+!=== OPERATIONS (two argument)
+!-
+INTEGER FUNCTION ma_add_r21(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo
+  REAL :: x(nb(1),nb(2)),s,y(nbo)
+!-
+  INTEGER :: i,j,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = x(i,j)+s
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_add_r21 = 0
+!----------------------
+END FUNCTION ma_add_r21
+!===
+INTEGER FUNCTION ma_sub_r21(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo
+  REAL :: x(nb(1),nb(2)),s,y(nbo)
+!-
+  INTEGER :: i,j,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = x(i,j)-s
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_sub_r21 = 0
+!----------------------
+END FUNCTION ma_sub_r21
+!===
+INTEGER FUNCTION ma_subi_r21(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo
+  REAL :: x(nb(1),nb(2)),s,y(nbo)
+!-
+  INTEGER :: i,j,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) =  s-x(i,j)
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_subi_r21 = 0
+!-----------------------
+END FUNCTION ma_subi_r21
+!===
+INTEGER FUNCTION ma_mult_r21(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo
+  REAL :: x(nb(1),nb(2)),s,y(nbo)
+!-
+  INTEGER :: i,j,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = x(i,j)*s
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_mult_r21 = 0
+!-----------------------
+END FUNCTION ma_mult_r21
+!===
+INTEGER FUNCTION ma_div_r21(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo
+  REAL :: x(nb(1),nb(2)),s,y(nbo)
+!-
+  INTEGER :: i,j,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = x(i,j)/s
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_div_r21 = 0
+!----------------------
+END FUNCTION ma_div_r21
+!===
+INTEGER FUNCTION ma_divi_r21(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo
+  REAL :: x(nb(1),nb(2)),s,y(nbo)
+!-
+  INTEGER :: i,j,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = s/x(i,j)
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_divi_r21 = 0
+!-----------------------
+END FUNCTION ma_divi_r21
+!===
+INTEGER FUNCTION ma_power_r21(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo
+  REAL :: x(nb(1),nb(2)),s,y(nbo)
+!-
+  INTEGER :: i,j,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = x(i,j) ** s
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_power_r21 = 0
+!------------------------
+END FUNCTION ma_power_r21
+!===
+INTEGER FUNCTION ma_fumin_r21(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo
+  REAL :: x(nb(1),nb(2)),s,y(nbo)
+!-
+  INTEGER :: i,j,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = MIN(x(i,j),s)
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_fumin_r21 = 0
+!------------------------
+END FUNCTION ma_fumin_r21
+!===
+INTEGER FUNCTION ma_fumax_r21(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo
+  REAL :: x(nb(1),nb(2)),s,y(nbo)
+!-
+  INTEGER :: i,j,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO j=1,nb(2)
+    DO i=1,nb(1)
+      ij = ij+1
+      y(ij) = MAX(x(i,j),s)
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)
+  ma_fumax_r21 = 0
+!------------------------
+END FUNCTION ma_fumax_r21
+!===
+INTEGER FUNCTION ma_fuscat_r21(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb(1),nb(2)),miss_val,y(nbo)
+!-
+  INTEGER :: i,j,ij,ii,ipos
+!---------------------------------------------------------------------
+  ma_fuscat_r21 = 0
+!-
+  y(1:nbo) = miss_val
+!-
+  IF (nbi <= nb(1)*nb(2)) THEN
+    ipos = 0
+    DO ij=1,nbi
+       IF (ind(ij) <= nbo .AND. ind(ij) > 0) THEN
+         ipos = ipos+1
+         j = ((ipos-1)/nb(1))+1
+         i = (ipos-(j-1)*nb(1))
+         y(ind(ij)) = x(i,j)
+       ELSE
+         IF (ind(ij) > nbo) ma_fuscat_r21  = ma_fuscat_r21+1
+       ENDIF
+    ENDDO
+!-- Repeat the data if needed
+    IF (MINVAL(ind) < 0) THEN
+      DO i=1,nbi
+        IF (ind(i) <= 0) THEN
+          DO ii=1,ABS(ind(i))-1
+            IF (ind(i+1)+ii <= nbo) THEN
+              y(ind(i+1)+ii) = y(ind(i+1))
+            ELSE
+              ma_fuscat_r21  = ma_fuscat_r21+1
+            ENDIF
+          ENDDO
+        ENDIF
+      ENDDO
+    ENDIF
+  ELSE
+    ma_fuscat_r21  = 1
+  ENDIF
+!-------------------------
+END FUNCTION ma_fuscat_r21
+!===
+INTEGER FUNCTION ma_fugath_r21(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb(1),nb(2)),miss_val,y(nbo)
+!-
+  INTEGER :: i,j,ij,ipos
+!---------------------------------------------------------------------
+  IF (nbi <= nbo) THEN
+    ma_fugath_r21 = 0
+    y(1:nbo) = miss_val
+    ipos = 0
+    DO ij=1,nbi
+      IF (ipos+1 <= nbo) THEN
+        IF (ind(ij) > 0) THEN
+          j = ((ind(ij)-1)/nb(1))+1
+          i = (ind(ij)-(j-1)*nb(1))
+          ipos = ipos+1
+          y(ipos) = x(i,j)
+        ENDIF
+      ELSE
+        IF (ipos+1 > nbo) ma_fugath_r21  = ma_fugath_r21+1
+      ENDIF
+    ENDDO
+  ELSE
+    ma_fugath_r21 = 1
+  ENDIF
+  nbo = ipos
+!-------------------------
+END FUNCTION ma_fugath_r21
+!===
+INTEGER FUNCTION ma_fufill_r21(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb(1),nb(2)),miss_val,y(nbo)
+!-
+  INTEGER :: i,j,ij,ii,ipos
+!---------------------------------------------------------------------
+  ma_fufill_r21 = 0
+!-
+  IF (nbi <= nb(1)*nb(2)) THEN
+    ipos = 0
+    DO ij=1,nbi
+      IF (ind(ij) <= nbo .AND. ind(ij) > 0) THEN
+        ipos = ipos+1
+        j = ((ipos-1)/nb(1))+1
+        i = (ipos-(j-1)*nb(1))
+        y(ind(ij)) = x(i,j)
+      ELSE
+        IF (ind(ij) > nbo) ma_fufill_r21  = ma_fufill_r21+1
+      ENDIF
+    ENDDO
+!-- Repeat the data if needed
+    IF (MINVAL(ind) < 0) THEN
+      DO i=1,nbi
+        IF (ind(i) <= 0) THEN
+          DO ii=1,ABS(ind(i))-1
+            IF (ind(i+1)+ii <= nbo) THEN
+              y(ind(i+1)+ii) = y(ind(i+1))
+            ELSE
+              ma_fufill_r21  = ma_fufill_r21+1
+            ENDIF
+          ENDDO
+        ENDIF
+      ENDDO
+    ENDIF
+  ELSE
+    ma_fufill_r21  = 1
+  ENDIF
+!-------------------------
+END FUNCTION ma_fufill_r21
+!===
+INTEGER FUNCTION ma_fucoll_r21(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb(1),nb(2)),miss_val,y(nbo)
+!-
+  INTEGER :: i,j,ij,ipos
+!---------------------------------------------------------------------
+  IF (nbi <= nbo) THEN
+    ma_fucoll_r21 = 0
+    ipos = 0
+    DO ij=1,nbi
+      IF (ipos+1 <= nbo) THEN
+        IF (ind(ij) > 0) THEN
+          j = ((ind(ij)-1)/nb(1))+1
+          i = (ind(ij)-(j-1)*nb(1))
+          ipos = ipos+1
+          y(ipos) = x(i,j)
+        ENDIF
+      ELSE
+        IF (ipos+1 > nbo) ma_fucoll_r21  = ma_fucoll_r21+1
+      ENDIF
+    ENDDO
+  ELSE
+    ma_fucoll_r21 = 1
+  ENDIF
+  nbo = ipos
+!-------------------------
+END FUNCTION ma_fucoll_r21
+!===
+INTEGER FUNCTION ma_fuundef_r21(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb(1),nb(2)),miss_val,y(nbo)
+!-
+  INTEGER :: i,j,ij
+!---------------------------------------------------------------------
+  IF (nbi <= nbo .AND. nbo == nb(1)*nb(2)) THEN
+    ma_fuundef_r21 = 0
+    DO ij=1,nbo
+      j = ((ij-1)/nb(1))+1
+      i = (ij-(j-1)*nb(1))
+      y(ij) = x(i,j)
+    ENDDO
+    DO i=1,nbi
+      IF (ind(i) <= nbo .AND. ind(i) > 0) THEN
+        y(ind(i)) =  miss_val
+      ELSE
+        IF (ind(i) > nbo) ma_fuundef_r21 = ma_fuundef_r21+1
+      ENDIF
+    ENDDO
+  ELSE
+    ma_fuundef_r21 = 1
+  ENDIF
+!--------------------------
+END FUNCTION ma_fuundef_r21
+!===
+INTEGER FUNCTION ma_fuonly_r21(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(2),nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb(1),nb(2)),miss_val,y(nbo)
+!-
+  INTEGER :: i,j,ij
+!---------------------------------------------------------------------
+  IF (     (nbi <= nbo).AND.(nbo == nb(1)*nb(2)) &
+ &    .AND.ALL(ind(1:nbi) <= nbo) ) THEN
+    ma_fuonly_r21 = 0
+    y(1:nbo) = miss_val
+    DO ij=1,nbi
+      IF (ind(ij) > 0) THEN
+        j = ((ind(ij)-1)/nb(1))+1
+        i = (ind(ij)-(j-1)*nb(1))
+        y(ind(ij)) =  x(i,j)
+      ENDIF
+    ENDDO
+  ELSE
+    ma_fuonly_r21 = 1
+  ENDIF
+!-------------------------
+END FUNCTION ma_fuonly_r21
+!===
+!===
+SUBROUTINE mathop_r31 &
+ &  (fun,nb,work_in,miss_val,nb_index,nindex,scal,nb_max,work_out)
+!---------------------------------------------------------------------
+!- This subroutines gives an interface to the various operations
+!- which are allowed. The interface is general enough to allow its use
+!- for other cases.
+!-
+!- INPUT
+!-
+!- fun      : function to be applied to the vector of data
+!- nb       : Length of input vector
+!- work_in  : Input vector of data (REAL)
+!- miss_val : The value of the missing data flag (it has to be a
+!-            maximum value, in f90 : huge( a real ))
+!- nb_index : Length of index vector
+!- nindex   : Vector of indices
+!- scal     : A scalar value for vector/scalar operations
+!- nb_max   : maximum length of output vector
+!-
+!- OUTPUT
+!-
+!- nb_max   : Actual length of output variable
+!- work_out : Output vector after the operation was applied
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=7) :: fun
+  INTEGER :: nb(3),nb_max,nb_index
+  INTEGER :: nindex(nb_index)
+  REAL :: work_in(nb(1),nb(2),nb(3)),scal,miss_val
+  REAL :: work_out(nb_max)
+!-
+  INTEGER :: ierr
+!-
+  INTRINSIC SIN,COS,TAN,ASIN,ACOS,ATAN,EXP,LOG,SQRT,ABS
+!---------------------------------------------------------------------
+  ierr = 0
+!-
+  IF (scal >= miss_val-1.) THEN
+    IF (INDEX(indexfu,fun(1:LEN_TRIM(fun))) == 0) THEN
+      SELECT CASE (fun)
+      CASE('sin')
+        ierr = ma_sin_r31(nb,work_in,nb_max,work_out)
+      CASE('cos')
+        ierr = ma_cos_r31(nb,work_in,nb_max,work_out)
+      CASE('tan')
+        ierr = ma_tan_r31(nb,work_in,nb_max,work_out)
+      CASE('asin')
+        ierr = ma_asin_r31(nb,work_in,nb_max,work_out)
+      CASE('acos')
+        ierr = ma_acos_r31(nb,work_in,nb_max,work_out)
+      CASE('atan')
+        ierr = ma_atan_r31(nb,work_in,nb_max,work_out)
+      CASE('exp')
+        ierr = ma_exp_r31(nb,work_in,nb_max,work_out)
+      CASE('log')
+        ierr = ma_log_r31(nb,work_in,nb_max,work_out)
+      CASE('sqrt')
+        ierr = ma_sqrt_r31(nb,work_in,nb_max,work_out)
+      CASE('chs')
+        ierr = ma_chs_r31(nb,work_in,nb_max,work_out)
+      CASE('abs')
+        ierr = ma_abs_r31(nb,work_in,nb_max,work_out)
+      CASE('cels')
+        ierr = ma_cels_r31(nb,work_in,nb_max,work_out)
+      CASE('kelv')
+        ierr = ma_kelv_r31(nb,work_in,nb_max,work_out)
+      CASE('deg')
+        ierr = ma_deg_r31(nb,work_in,nb_max,work_out)
+      CASE('rad')
+        ierr = ma_rad_r31(nb,work_in,nb_max,work_out)
+      CASE('ident')
+        ierr = ma_ident_r31(nb,work_in,nb_max,work_out)
+      CASE DEFAULT
+        CALL ipslerr(3,"mathop", &
+ &        'scalar variable undefined and no indexing', &
+ &        'but still unknown function',fun)
+      END SELECT
+      IF (ierr > 0) THEN
+         CALL ipslerr(3,"mathop", &
+ &        'Error while executing a simple function',fun,' ')
+      ENDIF
+    ELSE
+      SELECT CASE (fun)
+      CASE('gather')
+        ierr = ma_fugath_r31(nb,work_in,nb_index,nindex, &
+ &                           miss_val,nb_max,work_out)
+      CASE('scatter')
+        IF (nb_index > (nb(1)*nb(2)*nb(3))) THEN
+          work_out(1:nb_max) = miss_val
+          ierr=1
+        ELSE
+          ierr = ma_fuscat_r31(nb,work_in,nb_index,nindex, &
+ &                             miss_val,nb_max,work_out)
+        ENDIF
+      CASE('coll')
+        ierr = ma_fucoll_r31(nb,work_in,nb_index,nindex, &
+ &                           miss_val,nb_max,work_out)
+      CASE('fill')
+        ierr = ma_fufill_r31(nb,work_in,nb_index,nindex, &
+ &                           miss_val,nb_max,work_out)
+      CASE('undef')
+        ierr = ma_fuundef_r31(nb,work_in,nb_index,nindex, &
+ &                           miss_val,nb_max,work_out)
+      CASE('only')
+        ierr = ma_fuonly_r31(nb,work_in,nb_index,nindex, &
+ &                           miss_val,nb_max,work_out)
+      CASE DEFAULT
+        CALL ipslerr(3,"mathop", &
+ &        'scalar variable undefined and indexing', &
+ &        'was requested but with unknown function',fun)
+      END SELECT
+      IF (ierr > 0) THEN
+        CALL ipslerr(3,"mathop_r31", &
+ &        'Error while executing an indexing function',fun,' ')
+      ENDIF
+    ENDIF
+  ELSE
+    SELECT CASE (fun)
+    CASE('fumin')
+      ierr = ma_fumin_r31(nb,work_in,scal,nb_max,work_out)
+    CASE('fumax')
+      ierr = ma_fumax_r31(nb,work_in,scal,nb_max,work_out)
+    CASE('add')
+      ierr = ma_add_r31(nb,work_in,scal,nb_max,work_out)
+    CASE('subi')
+      ierr = ma_subi_r31(nb,work_in,scal,nb_max,work_out)
+    CASE('sub')
+      ierr = ma_sub_r31(nb,work_in,scal,nb_max,work_out)
+    CASE('mult')
+      ierr = ma_mult_r31(nb,work_in,scal,nb_max,work_out)
+    CASE('div')
+      ierr = ma_div_r31(nb,work_in,scal,nb_max,work_out)
+    CASE('divi')
+      ierr = ma_divi_r31(nb,work_in,scal,nb_max,work_out)
+    CASE('power')
+      ierr = ma_power_r31(nb,work_in,scal,nb_max,work_out)
+    CASE DEFAULT
+      CALL ipslerr(3,"mathop", &
+ &      'Unknown operation with a scalar',fun,' ')
+    END SELECT
+    IF (ierr > 0) THEN
+      CALL ipslerr(3,"mathop", &
+ &      'Error while executing a scalar function',fun,' ')
+    ENDIF
+  ENDIF
+!------------------------
+END SUBROUTINE mathop_r31
+!-
+!=== FUNCTIONS (only one argument)
+!-
+INTEGER FUNCTION ma_sin_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = SIN(x(i,j,k))
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_sin_r31 = 0
+!----------------------
+END FUNCTION ma_sin_r31
+!===
+INTEGER FUNCTION ma_cos_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = COS(x(i,j,k))
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_cos_r31 = 0
+!----------------------
+END FUNCTION ma_cos_r31
+!===
+INTEGER FUNCTION ma_tan_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = TAN(x(i,j,k))
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_tan_r31 = 0
+!----------------------
+END FUNCTION ma_tan_r31
+!===
+INTEGER FUNCTION ma_asin_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = ASIN(x(i,j,k))
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_asin_r31 = 0
+!-----------------------
+END FUNCTION ma_asin_r31
+!===
+INTEGER FUNCTION ma_acos_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = ACOS(x(i,j,k))
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_acos_r31 = 0
+!-----------------------
+END FUNCTION ma_acos_r31
+!===
+INTEGER FUNCTION ma_atan_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = ATAN(x(i,j,k))
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_atan_r31 = 0
+!-----------------------
+  END FUNCTION ma_atan_r31
+!===
+INTEGER FUNCTION ma_exp_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = EXP(x(i,j,k))
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_exp_r31 = 0
+!----------------------
+END FUNCTION ma_exp_r31
+!===
+INTEGER FUNCTION ma_log_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = LOG(x(i,j,k))
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_log_r31 = 0
+!----------------------
+END FUNCTION ma_log_r31
+!===
+INTEGER FUNCTION ma_sqrt_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = SQRT(x(i,j,k))
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_sqrt_r31 = 0
+!-----------------------
+END FUNCTION ma_sqrt_r31
+!===
+INTEGER FUNCTION ma_abs_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = ABS(x(i,j,k))
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_abs_r31 = 0
+!----------------------
+END FUNCTION ma_abs_r31
+!===
+INTEGER FUNCTION ma_chs_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = x(i,j,k)*(-1.)
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_chs_r31 = 0
+!----------------------
+END FUNCTION ma_chs_r31
+!===
+INTEGER FUNCTION ma_cels_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = x(i,j,k)-273.15
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_cels_r31 = 0
+!-----------------------
+END FUNCTION ma_cels_r31
+!===
+INTEGER FUNCTION ma_kelv_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = x(i,j,k)+273.15
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_kelv_r31 = 0
+!-----------------------
+  END FUNCTION ma_kelv_r31
+!===
+INTEGER FUNCTION ma_deg_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = x(i,j,k)*57.29577951
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_deg_r31 = 0
+!----------------------
+END FUNCTION ma_deg_r31
+!===
+INTEGER FUNCTION ma_rad_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = x(i,j,k)*0.01745329252
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_rad_r31 = 0
+!----------------------
+END FUNCTION ma_rad_r31
+!===
+INTEGER FUNCTION ma_ident_r31(nb,x,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,i,j,k,ij
+  REAL :: x(nb(1),nb(2),nb(3)),y(nbo)
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = x(i,j,k)
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_ident_r31 = 0
+!------------------------
+END FUNCTION ma_ident_r31
+!-
+!=== OPERATIONS (two argument)
+!-
+INTEGER FUNCTION ma_add_r31(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo
+  REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo)
+!-
+  INTEGER :: i,j,k,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = x(i,j,k)+s
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_add_r31 = 0
+!----------------------
+END FUNCTION ma_add_r31
+!===
+INTEGER FUNCTION ma_sub_r31(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo
+  REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo)
+!-
+  INTEGER :: i,j,k,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = x(i,j,k)-s
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_sub_r31 = 0
+!----------------------
+END FUNCTION ma_sub_r31
+!===
+INTEGER FUNCTION ma_subi_r31(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo
+  REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo)
+!-
+  INTEGER :: i,j,k,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) =  s-x(i,j,k)
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_subi_r31 = 0
+!-----------------------
+END FUNCTION ma_subi_r31
+!===
+INTEGER FUNCTION ma_mult_r31(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo
+  REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo)
+!-
+  INTEGER :: i,j,k,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = x(i,j,k)*s
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_mult_r31 = 0
+!-----------------------
+END FUNCTION ma_mult_r31
+!===
+INTEGER FUNCTION ma_div_r31(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo
+  REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo)
+!-
+  INTEGER :: i,j,k,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = x(i,j,k)/s
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_div_r31 = 0
+!----------------------
+END FUNCTION ma_div_r31
+!===
+INTEGER FUNCTION ma_divi_r31(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo
+  REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo)
+!-
+  INTEGER :: i,j,k,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = s/x(i,j,k)
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_divi_r31 = 0
+!-----------------------
+END FUNCTION ma_divi_r31
+!===
+INTEGER FUNCTION ma_power_r31(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo
+  REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo)
+!-
+  INTEGER :: i,j,k,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = x(i,j,k)**s
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_power_r31 = 0
+!------------------------
+END FUNCTION ma_power_r31
+!===
+INTEGER FUNCTION ma_fumin_r31(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo
+  REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo)
+!-
+  INTEGER :: i,j,k,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = MIN(x(i,j,k),s)
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_fumin_r31 = 0
+!------------------------
+END FUNCTION ma_fumin_r31
+!===
+INTEGER FUNCTION ma_fumax_r31(nb,x,s,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo
+  REAL :: x(nb(1),nb(2),nb(3)),s,y(nbo)
+!-
+  INTEGER :: i,j,k,ij
+!---------------------------------------------------------------------
+  ij = 0
+  DO k=1,nb(3)
+    DO j=1,nb(2)
+      DO i=1,nb(1)
+        ij = ij+1
+        y(ij) = MAX(x(i,j,k),s)
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  nbo = nb(1)*nb(2)*nb(3)
+  ma_fumax_r31 = 0
+!------------------------
+END FUNCTION ma_fumax_r31
+!===
+INTEGER FUNCTION ma_fuscat_r31(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo)
+!-
+  INTEGER :: i,j,k,ij,ii,ipos,ipp,isb
+!---------------------------------------------------------------------
+  ma_fuscat_r31 = 0
+!-
+  y(1:nbo) = miss_val
+!-
+  IF (nbi <= nb(1)*nb(2)*nb(3)) THEN
+    ipos = 0
+    isb = nb(1)*nb(2)
+    DO ij=1,nbi
+      IF (ind(ij) <= nbo .AND. ind(ij) > 0) THEN
+        ipos = ipos+1
+        k = ((ipos-1)/isb)+1
+        ipp = ipos-(k-1)*isb
+        j = ((ipp-1)/nb(1))+1
+        i = (ipp-(j-1)*nb(1))
+        y(ind(ij)) = x(i,j,k)
+      ELSE
+        IF (ind(ij) > nbo) ma_fuscat_r31  = ma_fuscat_r31+1
+      ENDIF
+    ENDDO
+!-- Repeat the data if needed
+    IF (MINVAL(ind) < 0) THEN
+      DO i=1,nbi
+        IF (ind(i) <= 0) THEN
+          DO ii=1,ABS(ind(i))-1
+            IF (ind(i+1)+ii <= nbo) THEN
+              y(ind(i+1)+ii) = y(ind(i+1))
+            ELSE
+              ma_fuscat_r31  = ma_fuscat_r31+1
+            ENDIF
+          ENDDO
+        ENDIF
+      ENDDO
+    ENDIF
+  ELSE
+    ma_fuscat_r31  = 1
+  ENDIF
+!-------------------------
+END FUNCTION ma_fuscat_r31
+!===
+INTEGER FUNCTION ma_fugath_r31(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo)
+!-
+  INTEGER :: i,j,k,ij,ipos,ipp,isb
+!---------------------------------------------------------------------
+  IF (nbi <= nbo) THEN
+    ma_fugath_r31 = 0
+    y(1:nbo) = miss_val
+    ipos = 0
+    isb = nb(1)*nb(2)
+    DO ij=1,nbi
+      IF (ipos+1 <= nbo) THEN
+        IF (ind(ij) > 0) THEN
+          k = ((ind(ij)-1)/isb)+1
+          ipp = ind(ij)-(k-1)*isb
+          j = ((ipp-1)/nb(1))+1
+          i = (ipp-(j-1)*nb(1))
+          ipos = ipos+1
+          y(ipos) = x(i,j,k)
+        ENDIF
+      ELSE
+        IF (ipos+1 > nbo) ma_fugath_r31  = ma_fugath_r31+1
+      ENDIF
+    ENDDO
+  ELSE
+    ma_fugath_r31 = 1
+  ENDIF
+  nbo = ipos
+!-------------------------
+END FUNCTION ma_fugath_r31
+!===
+INTEGER FUNCTION ma_fufill_r31(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo)
+!-
+  INTEGER :: i,j,k,ij,ii,ipos,ipp,isb
+!---------------------------------------------------------------------
+  ma_fufill_r31 = 0
+  IF (nbi <= nb(1)*nb(2)*nb(3)) THEN
+    ipos = 0
+    isb = nb(1)*nb(2)
+    DO ij=1,nbi
+      IF (ind(ij) <= nbo .AND. ind(ij) > 0) THEN
+        ipos = ipos+1
+        k = ((ipos-1)/isb)+1
+        ipp = ipos-(k-1)*isb
+        j = ((ipp-1)/nb(1))+1
+        i = (ipp-(j-1)*nb(1))
+        y(ind(ij)) = x(i,j,k)
+      ELSE
+        IF (ind(ij) > nbo) ma_fufill_r31  = ma_fufill_r31+1
+      ENDIF
+    ENDDO
+!-- Repeat the data if needed
+    IF (MINVAL(ind) < 0) THEN
+      DO i=1,nbi
+        IF (ind(i) <= 0) THEN
+          DO ii=1,ABS(ind(i))-1
+            IF (ind(i+1)+ii <= nbo) THEN
+              y(ind(i+1)+ii) = y(ind(i+1))
+            ELSE
+              ma_fufill_r31  = ma_fufill_r31+1
+            ENDIF
+          ENDDO
+        ENDIF
+      ENDDO
+    ENDIF
+  ELSE
+    ma_fufill_r31  = 1
+  ENDIF
+!-------------------------
+END FUNCTION ma_fufill_r31
+!===
+INTEGER FUNCTION ma_fucoll_r31(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo)
+!-
+  INTEGER :: i,j,k,ij,ipos,ipp,isb
+!---------------------------------------------------------------------
+  IF (nbi <= nbo) THEN
+    ma_fucoll_r31 = 0
+    ipos = 0
+    isb = nb(1)*nb(2)
+    DO ij=1,nbi
+      IF (ipos+1 <= nbo) THEN
+        IF (ind(ij) > 0) THEN
+          k = ((ind(ij)-1)/isb)+1
+          ipp = ind(ij)-(k-1)*isb
+          j = ((ipp-1)/nb(1))+1
+          i = (ipp-(j-1)*nb(1))
+          ipos = ipos+1
+          y(ipos) = x(i,j,k)
+        ENDIF
+      ELSE
+        IF (ipos+1 > nbo) ma_fucoll_r31  = ma_fucoll_r31+1
+      ENDIF
+    ENDDO
+  ELSE
+    ma_fucoll_r31 = 1
+  ENDIF
+  nbo = ipos
+!-------------------------
+END FUNCTION ma_fucoll_r31
+!===
+INTEGER FUNCTION ma_fuundef_r31(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo)
+!-
+  INTEGER :: i,j,k,ij,ipp,isb
+!---------------------------------------------------------------------
+  IF (nbi <= nbo .AND. nbo == nb(1)*nb(2)*nb(3)) THEN
+    ma_fuundef_r31 = 0
+    isb = nb(1)*nb(2)
+    DO ij=1,nbo
+      k = ((ij-1)/isb)+1
+      ipp = ij-(k-1)*isb
+      j = ((ipp-1)/nb(1))+1
+      i = (ipp-(j-1)*nb(1))
+      y(ij) = x(i,j,k)
+    ENDDO
+    DO i=1,nbi
+      IF (ind(i) <= nbo .AND. ind(i) > 0) THEN
+        y(ind(i)) =  miss_val
+      ELSE
+        IF (ind(i) > nbo) ma_fuundef_r31  = ma_fuundef_r31+1
+      ENDIF
+    ENDDO
+  ELSE
+    ma_fuundef_r31 = 1
+  ENDIF
+!--------------------------
+END FUNCTION ma_fuundef_r31
+!===
+INTEGER FUNCTION ma_fuonly_r31(nb,x,nbi,ind,miss_val,nbo,y)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb(3),nbo,nbi
+  INTEGER :: ind(nbi)
+  REAL :: x(nb(1),nb(2),nb(3)),miss_val,y(nbo)
+!-
+  INTEGER :: i,j,k,ij,ipp,isb
+!---------------------------------------------------------------------
+  IF (     (nbi <= nbo).AND.(nbo == nb(1)*nb(2)*nb(3)) &
+ &    .AND.ALL(ind(1:nbi) <= nbo) ) THEN
+    ma_fuonly_r31 = 0
+    y(1:nbo) = miss_val
+    isb = nb(1)*nb(2)
+    DO ij=1,nbi
+      IF (ind(ij) > 0) THEN
+        k = ((ind(ij)-1)/isb)+1
+        ipp = ind(ij)-(k-1)*isb
+        j = ((ipp-1)/nb(1))+1
+        i = (ipp-(j-1)*nb(1))
+        y(ind(ij)) = x(i,j,k)
+      ENDIF
+    ENDDO
+  ELSE
+    ma_fuonly_r31 = 1
+  ENDIF
+!-------------------------
+END FUNCTION ma_fuonly_r31
+!===
+SUBROUTINE moycum (opp,np,px,py,pwx)
+!---------------------------------------------------------------------
+!- Does time operations
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=7) :: opp
+  INTEGER :: np
+  REAL,DIMENSION(:) :: px,py
+  INTEGER :: pwx
+!---------------------------------------------------------------------
+  IF (pwx /= 0) THEN
+    IF      (opp == 'ave') THEN
+      px(1:np)=(px(1:np)*pwx+py(1:np))/REAL(pwx+1)
+    ELSE IF (opp == 't_sum') THEN
+      px(1:np)=px(1:np)+py(1:np)
+    ELSE IF ( (opp == 'l_min').OR.(opp == 't_min') ) THEN
+      px(1:np)=MIN(px(1:np),py(1:np))
+    ELSE IF ( (opp == 'l_max').OR.(opp == 't_max') ) THEN
+      px(1:np)=MAX(px(1:np),py(1:np))
+    ELSE
+      CALL ipslerr(3,"moycum",'Unknown time operation',opp,' ')
+    ENDIF
+  ELSE
+    IF      (opp == 'l_min') THEN
+      px(1:np)=MIN(px(1:np),py(1:np))
+    ELSE IF (opp == 'l_max') THEN
+      px(1:np)=MAX(px(1:np),py(1:np))
+    ELSE
+      px(1:np)=py(1:np)
+    ENDIF
+  ENDIF
+!--------------------
+END SUBROUTINE moycum
+!===
+SUBROUTINE moycum_index( opp, px, py, pwx, nbi, ind )
+!---------------------------------------------------------------------
+!- Does time operations on index points 
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+
+  !! 0. Parameters and variables declaration
+
+  !! 0.1 Input variables
+
+  CHARACTER(LEN=7), INTENT(in)        :: opp  !! Operation performed
+  INTEGER, INTENT(in)                 :: nbi  !! Size of index vector
+  INTEGER, DIMENSION(nbi), INTENT(in) :: ind  !! Index vector
+  REAL, DIMENSION(:), INTENT(in)      :: py   !! Vector containing the 
+                                              !! previous values of px
+                                              !! Warning : due to memory 
+                                              !! optimization, we have
+                                              !! generally SIZE(px) /= SIZE(py)  
+  INTEGER, INTENT(in)                 :: pwx  !! Used to calculate average value                             
+
+  !! 0.3 Modified variables
+
+  REAL, DIMENSION(:), INTENT(inout)   :: px   !! Result
+
+  !! 0.4 Local variables
+
+  INTEGER :: ig                               !! Index
+
+!---------------------------------------------------------------------
+
+  !! Perform operations only if the values of ind don't exceed the size of px 
+
+  IF ( MAXVAL(ind) > SIZE(px) ) THEN
+     CALL ipslerr(3,"moycum_index", &
+          & "the index vector is out of range for px", &
+          & "Indexation vector problem. We stop", " " )
+  END IF
+
+  IF (pwx /= 0) THEN
+     IF      (opp == 'ave') THEN
+        DO ig = 1,nbi
+           px(ind(ig)) = (px(ind(ig))*pwx + py(ind(ig)))/REAL(pwx+1)
+        END DO
+     ELSE IF (opp == 't_sum') THEN
+        DO ig = 1,nbi
+           px(ind(ig)) = px(ind(ig)) + py(ind(ig))
+        END DO
+     ELSE IF ( (opp == 'l_min').OR.(opp == 't_min') ) THEN
+        DO ig = 1,nbi
+           px(ind(ig)) = MIN(px(ind(ig)),py(ind(ig)))
+        END DO
+     ELSE IF ( (opp == 'l_max').OR.(opp == 't_max') ) THEN
+        DO ig = 1,nbi
+           px(ind(ig)) = MAX(px(ind(ig)),py(ind(ig)))
+        END DO
+     ELSE
+        CALL ipslerr(3,"moycum_index",'Unknown time operation',opp,' ')
+     END IF
+  ELSE
+    IF      (opp == 'l_min') THEN
+       DO ig = 1,nbi
+          px(ind(ig)) = MIN(px(ind(ig)),py(ind(ig)))
+       END DO
+    ELSE IF (opp == 'l_max') THEN
+       DO ig = 1,nbi
+          px(ind(ig)) = MAX(px(ind(ig)),py(ind(ig)))
+       END DO
+    ELSE
+       DO ig = 1,nbi
+          px(ind(ig)) = py(ind(ig))
+       END DO
+    ENDIF
+ END IF
+
+END SUBROUTINE moycum_index
+
+
+!-----------------
+END MODULE mathelp
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/restcom.f90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/restcom.f90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/restcom.f90	(revision 17)
@@ -0,0 +1,2583 @@
+MODULE restcom
+!-
+!$Id: restcom.f90 2020 2013-03-07 09:22:15Z jgipsl $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!-
+USE netcdf
+!-
+USE errioipsl, ONLY : ipslerr,ipsldbg, ipslout
+USE stringop
+USE calendar
+USE mathelp
+USE fliocom,   ONLY : flio_dom_file,flio_dom_att
+!-
+IMPLICIT NONE
+!-
+PRIVATE
+!-
+PUBLIC :: &
+ &  restini, restget, restput, restclo, &
+ &  ioconf_setatt, ioget_vname, ioconf_expval, &
+ &  ioget_expval, ioget_vdim
+!-
+INTERFACE restput
+  MODULE PROCEDURE &
+ &  restput_r3d, restput_r2d, restput_r1d, &
+ &  restput_opp_r2d, restput_opp_r1d
+END INTERFACE
+!-
+INTERFACE restget
+  MODULE PROCEDURE &
+ &  restget_r3d,restget_r2d,restget_r1d, &
+ &  restget_opp_r2d,restget_opp_r1d
+END INTERFACE
+!-
+! We do not use allocatable arrays because these sizes are safe
+! and we do not know from start how many variables will be in
+! the out file.
+!-
+  INTEGER,PARAMETER :: &
+ &  max_var=500, max_file=50, max_dim=NF90_MAX_VAR_DIMS
+!-
+  CHARACTER(LEN=9),SAVE :: calend_str='unknown'
+!-
+! The IDs of the netCDF files are going in pairs.
+! The input one (netcdf_id(?,1)) and the output one (netcdf_id(?,2))
+!-
+  INTEGER,SAVE :: nb_fi = 0
+  INTEGER,DIMENSION(max_file,2),SAVE :: netcdf_id = -1
+  CHARACTER(LEN=120),DIMENSION(max_file,2),SAVE :: netcdf_name='NONE'
+!-
+! Description of the content of the 'in' files and the 'out' files.
+!   Number of variables   : nbvar_*
+!   Number of dimensions  : nbdim_*
+!   ID of the time axis   : tdimid_*
+!-
+  INTEGER,SAVE :: nbvar_in(max_file), nbvar_out(max_file)
+  INTEGER,SAVE :: tdimid_in(max_file), tdimid_out(max_file)
+!-
+! Variables for one or the other file
+!-
+! Number of dimensions in the input file               : nbdim_in
+! Number of variables read so far from the input file  : nbvar_read
+! Type of variable read from the input file            : vartyp_in
+!   (Could be used later to test if we have a restart file)
+!-
+  INTEGER,SAVE :: nbdim_in(max_file), nbvar_read(max_file)
+  INTEGER,SAVE :: vartyp_in(max_file, max_var)
+!-
+! Time step and time origine in the input file.
+!-
+  REAL,DIMENSION(max_file),SAVE :: deltat,timeorig
+!-
+! Description of the axes in the output file
+!-
+!   tstp_out  : Index on the tie axis currently beeing written
+!   itau_out  : Time step which is written on this index of the file
+!-
+  INTEGER,DIMENSION(max_file),SAVE :: tstp_out,itau_out
+!-
+! Description of the axes in the output file
+!-
+! For the ?ax_infs variable the following order is used :
+!   ?ax_infs (if,in,1) = size of axis
+!   ?ax_infs (if,in,2) = id of dimension
+! Number of x,y and z axes in the output file :
+!   ?ax_nb(if)
+!-
+  INTEGER,DIMENSION(max_file,max_dim,2),SAVE :: &
+ &  xax_infs,yax_infs,zax_infs
+  INTEGER,DIMENSION(max_file),SAVE :: &
+ &  xax_nb=0,yax_nb=0,zax_nb=0
+!-
+! Description of the time axes in the input and output files
+!-
+!   ID of the variable which contains the itaus :
+!     tind_varid_*
+!   ID of the variables which contains the seconds since date :
+!     tax_varid_*
+!   Size of the time axis in the input file :
+!     tax_size_in
+!-
+  INTEGER,SAVE :: tind_varid_in(max_file),  tax_varid_in(max_file), &
+ &                tind_varid_out(max_file), tax_varid_out(max_file)
+  INTEGER,SAVE :: tax_size_in(max_file)=1
+!-
+! The two time axes we have in the input file :
+!   t_index   : dates in itaus
+!               (thus the variable has a tstep_sec attribute)
+!   t_julian  : Julian days of the time axis
+!-
+  INTEGER,SAVE,ALLOCATABLE :: t_index(:,:)
+  REAL,SAVE,ALLOCATABLE :: t_julian(:,:)
+!-
+! Here we save a number of informations on the variables
+! in the files we are handling
+!-
+! Name of variables :                                    varname_*
+! ID of the variables :                                  varid_*
+! Number of dimensions of the variable :                 varnbdim_*
+! Dimensions which are used for the variable :           vardims_*
+! Number of attributes for a variables :                 varatt_*
+! A flag which markes the variables we have worked on :  touched_*
+!-
+  CHARACTER(LEN=20),DIMENSION(max_file,max_var),SAVE :: &
+ &  varname_in,varname_out
+  INTEGER,DIMENSION(max_file,max_var),SAVE :: &
+ &  varid_in,varid_out,varnbdim_in,varatt_in
+  INTEGER,DIMENSION(max_file,max_var,max_dim),SAVE :: &
+ &  vardims_in
+  LOGICAL,DIMENSION(max_file,max_var),SAVE :: &
+ &  touched_in,touched_out
+!-
+  CHARACTER(LEN=120),SAVE :: indchfun= 'scatter, fill, gather, coll'
+  REAL,PARAMETER :: missing_val=1.e20
+!                or HUGE(1.0) (maximum real number)
+!-
+! The default value we will use for variables
+! which are not present in the restart file
+!-
+  REAL,SAVE :: val_exp =  999999.
+  LOGICAL,SAVE :: lock_valexp = .FALSE.
+!-
+! Temporary variables in which we store the attributed which are going
+! to be given to a new variable which is going to be defined.
+!-
+  CHARACTER(LEN=80),SAVE :: rest_units='XXXXX',rest_lname='XXXXX'
+!-
+! For allocations
+!-
+  REAL,ALLOCATABLE,DIMENSION(:),SAVE :: buff_tmp1,buff_tmp2
+!-
+!===
+CONTAINS
+!===
+!-
+SUBROUTINE restini &
+ & (fnamein,iim,jjm,lon,lat,llm,lev, &
+ &  fnameout,itau,date0,dt,fid,owrite_time_in,domain_id)
+!---------------------------------------------------------------------
+!- This subroutine sets up all the restart process.
+!- It will call the subroutine which opens the input
+!- and output files.
+!- The time step (itau), date of origine (date0) and time step are
+!- READ from the input file.
+!- A file ID, which is common to the input and output file is returned
+!-
+!- If fnamein = fnameout then the same file is used for the reading
+!- the restart conditions and writing the new restart.
+!-
+!- A special mode can be switched in with filename='NONE'.
+!- This means that no restart file is present.
+!- Usefull for creating the first restart file
+!- or to get elements in a file without creating an output file.
+!-
+!- A mode needs to be written in which itau, date0 and dt
+!- are given to the restart process and thus
+!- written into the output restart file.
+!-
+!- INPUT
+!-
+!- fnamein  : name of the file for the restart
+!- iim      : Dimension in x
+!- jjm      : Dimension in y
+!- lon      : Longitude in the x,y domain
+!- lat      : Latitude in the x,y domain
+!- llm      : Dimension in the vertical
+!- lev      : Positions of the levels
+!- fnameout :
+!-
+!- OUTPUT
+!-
+!- itau     : Time step of the restart file and at which the model
+!-            should restart
+!- date0    : Time at which itau = 0
+!- dt       : time step in seconds between two succesiv itaus
+!- fid      : File identification of the restart file
+!-
+!- Optional INPUT arguments
+!-
+!- owrite_time_in : logical  argument which allows to
+!-                  overwrite the time in the restart file
+!- domain_id      : Domain identifier
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(IN) :: fnamein,fnameout
+  INTEGER :: iim,jjm,llm,fid,itau
+  REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm)
+  REAL :: date0,dt
+  LOGICAL,OPTIONAL :: owrite_time_in
+  INTEGER,INTENT(IN),OPTIONAL :: domain_id
+!-
+  INTEGER :: ncfid
+  REAL :: dt_tmp,date0_tmp
+  LOGICAL :: l_fi,l_fo,l_rw
+  LOGICAL :: overwrite_time
+  CHARACTER(LEN=120) :: fname
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! 0.0 Prepare the configuration before opening any files
+!-
+  IF (.NOT.PRESENT(owrite_time_in)) THEN
+    overwrite_time = .FALSE.
+  ELSE
+    overwrite_time = owrite_time_in
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) 'restini 0.0 : ',TRIM(fnamein),' , ',TRIM(fnameout)
+  ENDIF
+!-
+  nb_fi = nb_fi+1
+!-
+  IF (nb_fi > max_file) THEN
+    CALL ipslerr (3,'restini',&
+ &   'Too many restart files are used. The problem can be',&
+ &   'solved by increasing max_file in restcom.f90 ',&
+ &   'and recompiling ioipsl.')
+  ENDIF
+!-
+! 0.1 Define the open flags
+!-
+  l_fi = (TRIM(fnamein)  /= 'NONE')
+  l_fo = (TRIM(fnameout) /= 'NONE')
+  IF ((.NOT.l_fi).AND.(.NOT.l_fo)) THEN
+    CALL ipslerr (3,'restini',&
+ &   'Input and output file names are both to NONE.',&
+ &   'It is probably an error.','Verify your logic.')
+  ENDIF
+  l_rw = l_fi.AND.l_fo.AND.(TRIM(fnamein) == TRIM(fnameout))
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) 'restini 0.1 l_fi, l_fo, l_rw : ',l_fi,l_fo,l_rw
+  ENDIF
+!-
+! 1.0 Open the input file.
+!-
+  IF (l_fi) THEN
+!---
+    IF (l_dbg) WRITE(ipslout,*) 'restini 1.0 : Open input file'
+!-- Add DOMAIN number and ".nc" suffix in file names if needed
+    fname = fnamein
+    CALL flio_dom_file (fname,domain_id)
+!-- Open the file
+    CALL restopenin (nb_fi,fname,l_rw,iim,jjm,lon,lat,llm,lev,ncfid)
+    netcdf_id(nb_fi,1) = ncfid
+    netcdf_name(nb_fi,1) = TRIM(fnamein)
+!---
+!-- 1.3 Extract the time information
+!---
+    IF (overwrite_time) THEN
+       date0_tmp = date0
+    ENDIF
+    CALL restsett (dt_tmp,date0_tmp,itau,overwrite_time)
+    IF (.NOT.overwrite_time) THEN
+      dt = dt_tmp
+      date0 = date0_tmp
+    ENDIF
+!---
+  ELSE
+!---
+!-- 2.0 The case of a missing restart file is dealt with
+!---
+    IF (l_dbg) WRITE(ipslout,*) 'restini 2.0'
+!---
+    IF (     (ALL(MINLOC(lon(:iim,:jjm)) == MAXLOC(lon(:iim,:jjm)))) &
+        .AND.(iim > 1) ) THEN
+      CALL ipslerr (3,'restini',&
+        & 'For creating a restart file the longitudes of the',&
+        & 'grid need to be provided to restini. This ',&
+        & 'information is needed for the restart files')
+    ENDIF
+    IF (     (ALL(MINLOC(lat(:iim,:jjm)) == MAXLOC(lat(:iim,:jjm)))) &
+        .AND.(jjm > 1) ) THEN
+      CALL ipslerr (3,'restini',&
+        & 'For creating a restart file the latitudes of the',&
+        & 'grid need to be provided to restini. This ',&
+        & 'information is needed for the restart files')
+    ENDIF
+    IF (     (ALL(MINLOC(lev(:llm)) == MAXLOC(lev(:llm)))) &
+        .AND.(llm > 1) ) THEN
+      CALL ipslerr (3,'restini',&
+        & 'For creating a restart file the levels of the',&
+        & 'grid need to be provided to restini. This',&
+        & 'information is needed for the restart files')
+    ENDIF
+!---
+!-- 2.2 Allocate the time axes and write the inputed variables
+!---
+    tax_size_in(nb_fi) = 1
+    CALL rest_atim (l_dbg,'restini')
+    t_index(nb_fi,1) = itau
+    t_julian(nb_fi,1) = date0
+  ENDIF
+!-
+  IF (l_fo.AND.(.NOT.l_rw)) THEN
+!-- Add DOMAIN number and ".nc" suffix in file names if needed
+    fname = fnameout
+    CALL flio_dom_file (fname,domain_id)
+!-- Open the file
+    CALL restopenout &
+      (nb_fi,fname,iim,jjm,lon,lat,llm,lev,dt,date0,ncfid,domain_id)
+    netcdf_id(nb_fi,2) = ncfid
+    netcdf_name(nb_fi,2) = TRIM(fnameout)
+  ELSE IF (l_fi.AND.l_fo) THEN
+    netcdf_id(nb_fi,2) = netcdf_id(nb_fi,1)
+    netcdf_name(nb_fi,2) = netcdf_name(nb_fi,1)
+    varname_out(nb_fi,:) = varname_in(nb_fi,:)
+    nbvar_out(nb_fi) = nbvar_in(nb_fi)
+    tind_varid_out(nb_fi) = tind_varid_in(nb_fi)
+    tax_varid_out(nb_fi) = tax_varid_in(nb_fi)
+    varid_out(nb_fi,:) = varid_in(nb_fi,:)
+    touched_out(nb_fi,:) = .TRUE.
+  ENDIF
+!-
+! 2.3 Set the calendar for the run.
+!     This should not produce any error message if
+!     This does not mean any change in calendar
+!     (to be modified in ioconf_calendar)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) 'restini 2.3 : Configure calendar if needed : ', &
+                calend_str
+  ENDIF
+!-
+  IF (INDEX(calend_str,'unknown') < 1) THEN
+    CALL ioconf_calendar (calend_str)
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) 'restini 2.3b : new calendar : ',calend_str
+    ENDIF
+  ENDIF
+!-
+! Save some data in the module
+!-
+  deltat(nb_fi) = dt
+!-
+! Prepare the variables which will be returned
+!-
+  fid = nb_fi
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) 'SIZE of t_index :',SIZE(t_index), &
+               SIZE(t_index,dim=1),SIZE(t_index,dim=2)
+    WRITE(ipslout,*) 't_index = ',t_index(fid,:)
+  ENDIF
+  itau = t_index(fid,1)
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'restini END'
+!---------------------
+END SUBROUTINE restini
+!===
+SUBROUTINE restopenin &
+  (fid,fname,l_rw,iim,jjm,lon,lat,llm,lev,ncfid)
+!---------------------------------------------------------------------
+!- Opens the restart file and checks that it belongsd to the model.
+!- This means that the coordinates of the model are compared to the
+!- ones in the file.
+!-
+!- The number and name of variable in the file are exctracted. Also
+!- the time details.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: fid,iim,jjm,llm
+  CHARACTER(LEN=*),INTENT(IN) :: fname
+  REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm)
+  LOGICAL,INTENT(IN) :: l_rw
+  INTEGER,INTENT(OUT) :: ncfid
+!-
+  INTEGER,DIMENSION(max_dim) :: var_dims,dimlen
+  INTEGER :: nb_dim,nb_var,id_unl,id,iv
+  INTEGER :: iread,jread,lread,iret
+  INTEGER :: lon_vid,lat_vid
+  REAL :: lon_read(iim,jjm),lat_read(iim,jjm)
+  REAL :: lev_read(llm)
+  REAL :: mdlon,mdlat
+  CHARACTER(LEN=80) :: units
+  CHARACTER(LEN=NF90_max_name),DIMENSION(max_dim) :: dimname
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! If we reuse the same file for input and output
+! then we open it in write mode
+!-
+  IF (l_rw) THEN; id = NF90_WRITE; ELSE; id = NF90_NOWRITE; ENDIF
+  iret = NF90_OPEN(fname,id,ncfid)
+  IF (iret /= NF90_NOERR) THEN
+    CALL ipslerr (3,'restopenin','Could not open file :',fname,' ')
+  ENDIF
+!-
+  IF (l_dbg) WRITE (*,*) "restopenin 0.0 ",TRIM(fname)
+  iret = NF90_INQUIRE(ncfid,nDimensions=nb_dim, &
+ &         nVariables=nb_var,unlimitedDimId=id_unl)
+  tdimid_in(fid) = id_unl
+!-
+  IF (nb_dim > max_dim) THEN
+    CALL ipslerr (3,'restopenin',&
+      & 'More dimensions present in file that can be store',&
+      & 'Please increase max_dim in the global variables ',&
+      & 'in restcom.F90')
+  ENDIF
+  IF (nb_var > max_var) THEN
+    CALL ipslerr (3,'restopenin',&
+      & 'More variables present in file that can be store',&
+      & 'Please increase max_var in the global variables ',&
+      & 'in restcom.F90')
+  ENDIF
+!-
+  nbvar_in(fid) = nb_var
+  nbdim_in(fid) = nb_dim
+  iread = -1; jread = -1; lread = -1;
+  DO id=1,nb_dim
+    iret = NF90_INQUIRE_DIMENSION(ncfid,id, &
+ &           len=dimlen(id),name=dimname(id))
+    IF (l_dbg) THEN
+      WRITE (*,*) "restopenin 0.0 dimname",id,TRIM(dimname(id))
+    ENDIF
+    IF      (TRIM(dimname(id)) == 'x') THEN
+      iread = dimlen(id)
+      IF (l_dbg) WRITE (*,*) "iread",iread
+    ELSE IF (TRIM(dimname(id)) == 'y') THEN
+      jread = dimlen(id)
+      IF (l_dbg) WRITE (*,*) "jread",jread
+    ELSE IF (TRIM(dimname(id)) == 'z') THEN
+      lread = dimlen(id)
+      IF (l_dbg) WRITE (*,*) "lread",lread
+    ENDIF
+  ENDDO
+!-
+  IF (id_unl > 0) THEN
+!---
+!-- 0.1 If we are going to add values to this file
+!--     we need to know where it ends
+!--     We also need to have all the dimensions in the file
+!---
+    IF (l_rw) THEN
+      tstp_out(fid) = dimlen(id_unl)
+      itau_out(fid) = -1
+      tdimid_out(fid) =  tdimid_in(fid)
+      IF (l_dbg) THEN
+        WRITE (*,*) &
+ &       "restopenin 0.0 unlimited axis dimname", &
+ &       dimname(id_unl),tstp_out(fid)
+      ENDIF
+!-----
+      xax_nb(fid) = 0
+      yax_nb(fid) = 0
+      zax_nb(fid) = 0
+!-----
+      DO id=1,nb_dim
+        IF      (dimname(id)(1:1) == 'x') THEN
+          xax_nb(fid) = xax_nb(fid)+1
+          xax_infs(fid,xax_nb(fid),1) = dimlen(id)
+          xax_infs(fid,xax_nb(fid),2) = id
+        ELSE IF (dimname(id)(1:1) == 'y') THEN
+          yax_nb(fid) = yax_nb(fid)+1
+          yax_infs(fid,yax_nb(fid),1) = dimlen(id)
+          yax_infs(fid,yax_nb(fid),2) = id
+        ELSE IF (dimname(id)(1:1) == 'z') THEN
+          zax_nb(fid) = zax_nb(fid)+1
+          zax_infs(fid,zax_nb(fid),1) = dimlen(id)
+          zax_infs(fid,zax_nb(fid),2) = id
+        ENDIF
+      ENDDO
+    ENDIF
+  ELSE
+!---
+!-- Still need to find a method for dealing with this
+!---
+!  CALL ipslerr (3,'restopenin',&
+!    & ' We do not deal yet with files without time axis.',' ',' ')
+  ENDIF
+!-
+! 1.0 First let us check that we have the righ restart file
+!-
+  IF ((iread /= iim).OR.(jread /= jjm).OR.(lread /= llm)) THEN
+    CALL ipslerr (3,'restopenin',&
+ &    'The grid of the restart file does not correspond',&
+ &    'to that of the model',' ')
+  ENDIF
+!-
+! 2.0 Get the list of variables
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'restopenin 1.2'
+!-
+  lat_vid = -1
+  lon_vid = -1
+  tind_varid_in(fid) = -1
+  tax_varid_in(fid) = -1
+!-
+  DO iv=1,nb_var
+!---
+    varid_in(fid,iv) = iv
+    var_dims(:) = 0
+    iret = NF90_INQUIRE_VARIABLE(ncfid,iv, &
+ &           name=varname_in(fid,iv),xtype=vartyp_in(fid,iv), &
+ &           ndims=varnbdim_in(fid,iv),dimids=var_dims, &
+ &           nAtts=varatt_in(fid,iv))
+!---
+    DO id=1,varnbdim_in(fid,iv)
+      iret = NF90_INQUIRE_DIMENSION &
+ &             (ncfid,var_dims(id),len=vardims_in(fid,iv,id))
+    ENDDO
+!---
+!-- 2.1 Read the units of the variable
+!---
+    units=''
+    iret = NF90_GET_ATT(ncfid,iv,'units',units)
+    CALL strlowercase (units)
+    CALL cmpblank (units)
+!---
+!-- 2.2 Catch the time variables
+!---
+    IF (varnbdim_in(fid,iv) == 1) THEN
+      IF (     (INDEX(units,'timesteps since') > 0) &
+          .AND.(tind_varid_in(fid) < 0) ) THEN
+        tind_varid_in(fid) = iv
+        tax_size_in(fid) = vardims_in(fid,iv,1)
+      ENDIF
+      IF (     (INDEX(units,'seconds since') > 0) &
+          .AND.(tax_varid_in(fid) < 0) ) THEN
+        tax_varid_in(fid) = iv
+        tax_size_in(fid) = vardims_in(fid,iv,1)
+      ENDIF
+    ENDIF
+!---
+!-- 2.3 Catch longitude and latitude variables
+!---
+    IF      (INDEX(units,'degrees_nort') > 0) THEN
+      lat_vid = iv
+    ELSE IF (INDEX(units,'degrees_east') > 0) THEN
+      lon_vid = iv
+    ENDIF
+!---
+  ENDDO
+!-
+! 2.4 None of the variables was yet read
+!-
+  nbvar_read(fid) = 0
+  touched_in(fid,:) = .FALSE.
+!-
+! 3.0 Reading the coordinates from the input restart file
+!-
+  lon_read = missing_val
+  lat_read = missing_val
+!-
+  IF (lon_vid < 0 .OR. lat_vid < 0) THEN
+    CALL ipslerr (3,'restopenin',&
+      & ' No variables containing longitude or latitude were ',&
+      & ' found in the restart file.',' ')
+  ELSE
+    iret = NF90_GET_VAR(ncfid,lon_vid,lon_read)
+    iret = NF90_GET_VAR(ncfid,lat_vid,lat_read)
+!---
+    IF (  (ABS( MAXVAL(lon(:,:)) &
+ &             -MINVAL(lon(:,:))) < EPSILON(MAXVAL(lon(:,:)))) &
+ &   .AND.(ABS( MAXVAL(lat(:,:)) &
+ &             -MINVAL(lat(:,:))) < EPSILON(MAXVAL(lat(:,:)))) ) THEN
+!-----
+!---- 3.1 No longitude nor latitude are provided thus
+!---- they are taken from the restart file
+!-----
+      lon(:,:) = lon_read(:,:)
+      lat(:,:) = lat_read(:,:)
+    ELSE
+!-----
+!---- 3.2 We check that the longitudes and latitudes
+!----     in the file and the model are the same
+!-----
+      mdlon = MAXVAL(ABS(lon_read-lon))
+      mdlat = MAXVAL(ABS(lat_read-lat))
+!-----
+!---- We can not test against epsilon here as the longitude
+!---- can be stored at another precision in the netCDF file.
+!---- The test here does not need to be very precise.
+!-----
+      IF (mdlon > 1.e-4 .OR. mdlat > 1.e-4) THEN
+        CALL ipslerr (3,'restopenin',&
+          & ' The longitude or latitude found in the restart ',&
+          & ' file are not the same as the ones used in the model.',&
+          & ' ')
+      ENDIF
+    ENDIF
+  ENDIF
+!------------------------
+END SUBROUTINE restopenin
+!===
+SUBROUTINE restsett (timestep,date0,itau,owrite_time_in)
+!---------------------------------------------------------------------
+!- Here we get all the time information from the file.
+!-
+!- The time information can come in three forms :
+!- -global attributes which give the time origine and the
+!-  time step is taken from the input to restinit
+!- -A physical time exists and thus the julian date from the
+!-  input is used for positioning using the itau as input
+!- -A time-step axis exists and itau is positioned on it.
+!-
+!- What takes precedence : the model
+!-
+!- itau     : Time step of the model
+!-
+!- Optional INPUT arguments
+!-
+!- owrite_time_in : logical  argument which allows to
+!-                  overwrite the time in the restart file
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  REAL :: date0,timestep
+  INTEGER :: itau
+  LOGICAL,OPTIONAL :: owrite_time_in
+!-
+  INTEGER :: ncfid,iret,it,iax,iv
+  CHARACTER(LEN=80) :: itau_orig,tax_orig,calendar
+  CHARACTER(LEN=9) :: tmp_cal
+  INTEGER :: year0,month0,day0,hours0,minutes0,seci
+  REAL :: sec0,one_day,one_year,date0_ju,ttmp
+  CHARACTER :: strc
+  LOGICAL :: ow_time
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (PRESENT(owrite_time_in)) THEN
+    ow_time = owrite_time_in
+  ELSE
+    ow_time = .FALSE.
+  ENDIF
+!-
+  ncfid = netcdf_id(nb_fi,1)
+!-
+! Allocate the space we need for the time axes
+!-
+  CALL rest_atim (l_dbg,'restsett')
+!-
+! Get the calendar if possible. Else it will be gregorian.
+!-
+  IF (tax_size_in(nb_fi) > 0) THEN
+    calendar = ' '
+    iret = NF90_GET_ATT(ncfid,tax_varid_in(nb_fi),'calendar',calendar)
+    IF (iret == NF90_NOERR) THEN
+      CALL ioconf_calendar (calendar)
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) 'restsett : calendar of the restart ',calendar
+      ENDIF
+    ENDIF
+  ENDIF
+  CALL ioget_calendar (one_year,one_day)
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) 'one_year,one_day = ',one_year,one_day
+  ENDIF
+!-
+  itau_orig = 'XXXXX'
+  tax_orig  = 'XXXXX'
+!-
+! Get the time steps of the time axis if available on the restart file
+!-
+  IF (tind_varid_in(nb_fi) > 0) THEN
+    IF (ow_time) THEN
+      t_index(nb_fi,:) = itau
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) "nb_fi,t_index",nb_fi,t_index(nb_fi,:)
+      ENDIF
+      CALL ju2ymds (date0,year0,month0,day0,sec0)
+      hours0 = NINT(sec0/3600)
+      sec0 = sec0 - 3600 * hours0
+      minutes0 = NINT(sec0 / 60)
+      sec0 = sec0 - 60 * minutes0
+      seci = NINT(sec0)
+      strc=':'
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) date0
+        WRITE (UNIT=itau_orig,FMT='(I4.4,5(A,I2.2))') &
+ &       year0,'-',month0,'-',day0,' ',hours0,':',minutes0,':',seci
+        WRITE(ipslout,*) "itau_orig : ",itau_orig
+      ENDIF
+    ELSE
+      iret = NF90_GET_VAR(ncfid,tind_varid_in(nb_fi),t_index(nb_fi,:))
+      IF (l_dbg) THEN
+        WRITE(ipslout,*) "restsett, time axis : ",t_index(nb_fi,:)
+      ENDIF
+      iret = NF90_GET_ATT(ncfid,tind_varid_in(nb_fi),'units',itau_orig)
+      itau_orig = &
+ &      itau_orig(INDEX(itau_orig,'since')+6:LEN_TRIM(itau_orig))
+      iret = &
+ &      NF90_GET_ATT(ncfid,tind_varid_in(nb_fi),'tstep_sec',timestep)
+!-----
+!---- This time origin will dominate as it is linked to the time steps.
+!-----
+      READ (UNIT=itau_orig,FMT='(I4.4,5(A,I2.2))') &
+ &      year0,strc,month0,strc,day0,strc, &
+ &      hours0,strc,minutes0,strc,seci
+      sec0 = REAL(seci)
+      sec0 = hours0*3600.+minutes0*60.+sec0
+      CALL ymds2ju (year0,month0,day0,sec0,date0)
+    ENDIF
+  ENDIF
+!-
+! If a julian day time axis is available then we get it
+!-
+  IF (tax_varid_in(nb_fi) > 0) THEN
+    iret = NF90_GET_VAR(ncfid,tax_varid_in(nb_fi),t_julian(nb_fi,:))
+    iret = NF90_GET_ATT(ncfid,tax_varid_in(nb_fi),'units',tax_orig)
+    tax_orig = tax_orig(INDEX(tax_orig,'since')+6:LEN_TRIM(tax_orig))
+    tmp_cal = ' '
+    iret = NF90_GET_ATT(ncfid,tax_varid_in(nb_fi),'calendar',tmp_cal)
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) 'restsett : tmp_calendar of the restart ',tmp_cal
+    ENDIF
+!---
+    CALL strlowercase (tmp_cal)
+    IF (INDEX(calend_str,tmp_cal) < 1) THEN
+      IF (INDEX(calend_str,'unknown') > 0) THEN
+        calend_str = tmp_cal
+      ELSE
+        CALL ipslerr (2,'restsett', &
+ &       ' In the restart files two different calendars were found.', &
+ &       ' Please check the files you have used.',' ')
+      ENDIF
+    ENDIF
+!---
+!-- We need to transform that into julian days
+!-- to get ride of the intial date.
+!---
+    IF (l_dbg) WRITE(ipslout,*) 'tax_orig : ',TRIM(tax_orig)
+    READ (UNIT=tax_orig,FMT='(I4.4,5(a,I2.2))') &
+      year0,strc,month0,strc,day0,strc, &
+      hours0,strc,minutes0,strc,seci
+    sec0 = REAL(seci)
+    sec0 = hours0*3600.+minutes0*60.+sec0
+    CALL ymds2ju (year0,month0,day0,sec0,date0_ju)
+    t_julian(nb_fi,:) = t_julian(nb_fi,:)/one_day+date0_ju
+  ENDIF
+!-
+  IF (     (INDEX(itau_orig,'XXXXX') > 0) &
+      .AND.(INDEX(tax_orig,'XXXXX')  < 1) ) THEN
+!!- Compute the t_itau from the date read and the timestep in the input
+  ENDIF
+!-
+  IF (     (INDEX(tax_orig,'XXXXX')  > 0) &
+      .AND.(INDEX(itau_orig,'XXXXX') < 1) ) THEN
+    DO it=1,tax_size_in(nb_fi)
+      t_julian(nb_fi,it) = itau2date(t_index(nb_fi,it),date0,timestep)
+    ENDDO
+  ENDIF
+!-
+! If neither the indices or time is present then get global attributes
+! This is for compatibility reasons and should not be used.
+!-
+  IF ((tax_varid_in(nb_fi) < 0).AND.(tind_varid_in(nb_fi) < 0)) THEN
+    iax = -1
+    DO iv=1,nbvar_in(nb_fi)
+      IF (    (INDEX(varname_in(nb_fi,iv),'tsteps') > 0) &
+ &        .OR.(INDEX(varname_in(nb_fi,iv),'time_steps') > 0)) THEN
+        iax = iv
+      ENDIF
+    ENDDO
+!---
+    IF (iax < 0) THEN
+      CALL ipslerr (3,'restsett',&
+        & 'No time axis was found in the restart file. Please check',&
+        & 'that it corresponds to the convention used in restsett',&
+        & ' ')
+    ELSE
+      iret = NF90_GET_VAR(ncfid,tind_varid_in(nb_fi),t_index(nb_fi,:))
+      iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'delta_tstep_sec',timestep)
+      iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'year0',ttmp)
+      year0 = NINT(ttmp)
+      iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'month0',ttmp)
+      month0 = NINT(ttmp)
+      iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'day0',ttmp)
+      day0 = NINT(ttmp)
+      iret = NF90_GET_ATT(ncfid,NF90_GLOBAL,'sec0',sec0)
+!---
+      CALL ymds2ju (year0,month0,day0,sec0,date0)
+      t_julian(nb_fi,1) = itau2date(t_index(nb_fi,1),date0,timestep)
+    ENDIF
+  ENDIF
+!----------------------
+END SUBROUTINE restsett
+!===
+SUBROUTINE restopenout &
+  (fid,fname,iim,jjm, &
+   lon,lat,llm,lev,timestep,date,ncfid,domain_id)
+!---------------------------------------------------------------------
+!- Opens the restart file for output.
+!- The longitude and time variables are written.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: fid,iim,jjm,llm
+  CHARACTER(LEN=*) :: fname
+  REAL :: date,timestep
+  REAL :: lon(iim,jjm),lat(iim,jjm),lev(llm)
+  INTEGER,INTENT(OUT) :: ncfid
+  INTEGER,INTENT(IN),OPTIONAL :: domain_id
+!-
+  INTEGER :: iret
+  CHARACTER(LEN=70) :: str_t
+  INTEGER :: x_id,y_id,z_id,itauid
+  INTEGER :: nlonid,nlatid,nlevid,timeid
+  INTEGER :: year,month,day,hours,minutes
+  REAL :: sec
+  CHARACTER(LEN=3),DIMENSION(12) :: &
+    cal = (/'JAN','FEB','MAR','APR','MAY','JUN', &
+            'JUL','AUG','SEP','OCT','NOV','DEC'/)
+  CHARACTER(LEN=30) :: timenow
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (l_dbg) WRITE(ipslout,*) "restopenout 0.0 ",TRIM(fname)
+!-
+!  If we use the same file for input and output
+!- we will not even call restopenout
+!-
+  iret = NF90_CREATE(fname,cmode=or(NF90_NOCLOBBER,NF90_64BIT_OFFSET),ncid=ncfid)
+  IF (iret == -35) THEN
+    CALL ipslerr (3,'restopenout',&
+      & ' The restart file aready exists on the disc. IOIPSL ',&
+      & ' will not overwrite it. You should remove the old one or ',&
+      & ' generate the new one with another name')
+  ENDIF
+!-
+  iret = NF90_DEF_DIM(ncfid,'x',iim,x_id)
+  xax_nb(fid) = xax_nb(fid)+1
+  xax_infs(fid,xax_nb(fid),1) = iim
+  xax_infs(fid,xax_nb(fid),2) = x_id
+!-
+  iret = NF90_DEF_DIM(ncfid,'y',jjm,y_id)
+  yax_nb(fid)  = yax_nb(fid)+1
+  yax_infs(fid,yax_nb(fid),1) = jjm
+  yax_infs(fid,yax_nb(fid),2) = y_id
+!-
+  iret = NF90_DEF_DIM(ncfid,'z',llm,z_id)
+  zax_nb(fid) = zax_nb(fid)+1
+  zax_infs(fid,zax_nb(fid),1) = llm
+  zax_infs(fid,zax_nb(fid),2) = z_id
+!-
+  iret = NF90_DEF_DIM(ncfid,'time',NF90_UNLIMITED,tdimid_out(fid))
+!-
+! 1.0 Longitude
+!-
+  IF (l_dbg) WRITE(ipslout,*) "restopenout 1.0"
+!-
+  iret = NF90_DEF_VAR(ncfid,"nav_lon",NF90_FLOAT,(/x_id,y_id/),nlonid)
+  iret = NF90_PUT_ATT(ncfid,nlonid,'units',"degrees_east")
+  iret = NF90_PUT_ATT(ncfid,nlonid,'valid_min',REAL(-180.,KIND=4))
+  iret = NF90_PUT_ATT(ncfid,nlonid,'valid_max',REAL( 180.,KIND=4))
+  iret = NF90_PUT_ATT(ncfid,nlonid,'long_name',"Longitude")
+!-
+! 2.0 Latitude
+!-
+  IF (l_dbg) WRITE(ipslout,*) "restopenout 2.0"
+!-
+  iret = NF90_DEF_VAR(ncfid,"nav_lat",NF90_FLOAT,(/x_id,y_id/),nlatid)
+  iret = NF90_PUT_ATT(ncfid,nlatid,'units',"degrees_north")
+  iret = NF90_PUT_ATT(ncfid,nlatid,'valid_min',REAL(-90.,KIND=4))
+  iret = NF90_PUT_ATT(ncfid,nlatid,'valid_max',REAL( 90.,KIND=4))
+  iret = NF90_PUT_ATT(ncfid,nlatid,'long_name',"Latitude")
+!-
+! 3.0 Levels
+!-
+  IF (l_dbg) WRITE(ipslout,*) "restopenout 3.0"
+!-
+  iret = NF90_DEF_VAR(ncfid,"nav_lev",NF90_FLOAT,z_id,nlevid)
+  iret = NF90_PUT_ATT(ncfid,nlevid,'units',"model_levels")
+  iret = NF90_PUT_ATT(ncfid,nlevid,'valid_min', &
+ &                     REAL(MINVAL(lev),KIND=4))
+  iret = NF90_PUT_ATT(ncfid,nlevid,'valid_max', &
+ &                     REAL(MAXVAL(lev),KIND=4))
+  iret = NF90_PUT_ATT(ncfid,nlevid,'long_name',"Model levels")
+!-
+! 4.0 Time axis, this is the seconds since axis
+!-
+  IF (l_dbg) WRITE(ipslout,*) "restopenout 4.0"
+!-
+  iret = NF90_DEF_VAR(ncfid,"time",NF90_FLOAT, &
+                       tdimid_out(fid),timeid)
+  tax_varid_out(fid) = timeid
+!-
+  timeorig(fid) = date
+  CALL ju2ymds (date,year,month,day,sec)
+  hours   = INT(sec/(60.*60.))
+  minutes = INT((sec-hours*60.*60.)/60.)
+  sec     = sec-(hours*60.*60.+minutes*60.)
+  WRITE (UNIT=str_t, &
+   FMT='("seconds since ",I4.4,2("-",I2.2)," ",I2.2,2(":",I2.2))') &
+ &  year,month,day,hours,minutes,INT(sec)
+  iret = NF90_PUT_ATT(ncfid,timeid,'units',TRIM(str_t))
+!-
+  CALL ioget_calendar (str_t)
+  iret = NF90_PUT_ATT(ncfid,timeid,'calendar',TRIM(str_t))
+  iret = NF90_PUT_ATT(ncfid,timeid,'title','Time')
+  iret = NF90_PUT_ATT(ncfid,timeid,'long_name','Time axis')
+!-
+  WRITE(UNIT=str_t, &
+   FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,2(":",I2.2))') &
+ &  year,cal(month),day,hours,minutes,INT(sec)
+  iret = NF90_PUT_ATT(ncfid,timeid,'time_origin',TRIM(str_t))
+!-
+! 5.0 Time axis, this is the time steps since axis
+!-
+  IF (l_dbg) WRITE(ipslout,*) "restopenout 5.0"
+!-
+  iret = NF90_DEF_VAR(ncfid,"time_steps",NF90_INT, &
+ &                    tdimid_out(fid),itauid)
+  tind_varid_out(fid) = itauid
+!-
+  CALL ju2ymds (date,year,month,day,sec)
+!-
+  hours   = INT(sec/(60.*60.))
+  minutes = INT((sec-hours*60.*60.)/60.)
+  sec     = sec-(hours*60.*60.+minutes*60.)
+!-
+  WRITE (UNIT=str_t, &
+   FMT='("timesteps since ",I4.4,2("-",I2.2)," ",I2.2,2(":",I2.2))') &
+ &  year,month,day,hours,minutes,INT(sec)
+!-
+  iret = NF90_PUT_ATT(ncfid,itauid,'units',TRIM(str_t))
+  iret = NF90_PUT_ATT(ncfid,itauid,'title','Time steps')
+  iret = NF90_PUT_ATT(ncfid,itauid,'tstep_sec',REAL(timestep,KIND=4))
+  iret = NF90_PUT_ATT(ncfid,itauid,'long_name','Time step axis')
+!-
+  WRITE(UNIT=str_t, &
+   FMT='(" ",I4.4,"-",A3,"-",I2.2," ",I2.2,2(":",I2.2))') &
+ &  year,cal(month),day,hours,minutes,INT(sec)
+  iret = NF90_PUT_ATT(ncfid,itauid,'time_origin',TRIM(str_t))
+!-
+!  5.2 Write global attributes
+!-
+  iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL,'Conventions',"CF-1.1")
+  iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL,'file_name',TRIM(fname))
+!!  TO BE DONE LATER
+!!   iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL, &
+!!                       'production',TRIM(model_name))
+!!   lock_modname = .TRUE.
+  CALL ioget_timestamp (timenow)
+  iret = NF90_PUT_ATT(ncfid,NF90_GLOBAL,'TimeStamp',TRIM(timenow))
+!-
+! Add DOMAIN attributes if needed
+!-
+  CALL flio_dom_att (ncfid,domain_id)
+!-
+! 6.0 The coordinates are written to the file
+!-
+  iret = NF90_ENDDEF(ncfid)
+!-
+  iret = NF90_PUT_VAR(ncfid,nlonid,lon)
+  iret = NF90_PUT_VAR(ncfid,nlatid,lat)
+  iret = NF90_PUT_VAR(ncfid,nlevid,lev)
+!-
+! 7.0 Set a few variables related to the out file
+!-
+  nbvar_out(fid) = 0
+  itau_out(fid) = -1
+  tstp_out(fid) = 0
+  touched_out(fid,:) = .FALSE.
+!-
+! 7.1 The file is put back in define mode.
+!     This will last until itau_out >= 0
+!-
+  iret = NF90_REDEF(ncfid)
+!-
+  IF (l_dbg) WRITE(ipslout,*) "restopenout END"
+!-------------------------
+END SUBROUTINE restopenout
+!===
+SUBROUTINE restget_opp_r1d &
+ & (fid,vname_q,iim,jjm,llm,itau,def_beha, &
+ &  var,MY_OPERATOR,nbindex,ijndex)
+!---------------------------------------------------------------------
+!- This subroutine serves as an interface to restget_real
+!-
+!- Should work as restput_opp_r1d but the other way around !
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid
+  CHARACTER(LEN=*) :: vname_q
+  INTEGER :: iim,jjm,llm,itau
+  LOGICAL def_beha
+  REAL :: var(:)
+  CHARACTER(LEN=*) :: MY_OPERATOR
+  INTEGER :: nbindex,ijndex(nbindex)
+!-
+  INTEGER :: req_sz,siz1
+  REAL :: scal
+  CHARACTER(LEN=7) :: topp
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! 0.0 What size should be the data in the file
+!-
+  req_sz = 1
+  IF (nbindex == iim .AND. jjm <= 1 .AND. llm <= 1) THEN
+    IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1)
+    IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1)
+    IF (zax_infs(fid,1,1) > 0) req_sz = req_sz*zax_infs(fid,1,1)
+  ELSE
+    CALL ipslerr (3,'resget_opp_r1d', &
+      'Unable to performe an operation on this variable as it has',&
+      'a second and third dimension',vname_q)
+  ENDIF
+!-
+! 1.0 Allocate the temporary buffer we need
+!     to put the variable in right dimension
+!-
+  siz1 = SIZE(var)
+  CALL rest_alloc (1,siz1,l_dbg,'restget_opp_r1d')
+  CALL rest_alloc (2,req_sz,l_dbg,'restget_opp_r1d')
+!-
+! 2.0 Here we get the variable from the restart file
+!-
+  CALL restget_real &
+    (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), &
+     zax_infs(fid,1,1),itau,def_beha,buff_tmp2)
+!-
+! 4.0 Transfer the buffer obtained from the restart file
+!     into the variable the model expects
+!-
+  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7))
+!-
+  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN
+    scal = missing_val
+    CALL mathop (topp,req_sz,buff_tmp2,missing_val, &
+ &               nbindex,ijndex,scal,siz1,buff_tmp1)
+    var(:) = buff_tmp1(1:siz1)
+  ELSE
+    CALL ipslerr (3,'resget_opp_r1d', &
+      'The operation you wish to do on the variable for the ',&
+      'restart file is not allowed.',topp)
+  ENDIF
+!-----------------------------
+END SUBROUTINE restget_opp_r1d
+!===
+SUBROUTINE restget_opp_r2d &
+ & (fid,vname_q,iim,jjm,llm,itau,def_beha, &
+ &  var,MY_OPERATOR,nbindex,ijndex)
+!---------------------------------------------------------------------
+!- This subroutine serves as an interface to restget_real
+!-
+!- Should work as restput_opp_r2d but the other way around !
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid
+  CHARACTER(LEN=*) :: vname_q
+  INTEGER :: iim,jjm,llm,itau
+  LOGICAL def_beha
+  REAL :: var(:,:)
+  CHARACTER(LEN=*) :: MY_OPERATOR
+  INTEGER :: nbindex,ijndex(nbindex)
+!-
+  INTEGER :: jj,req_sz,ist,var_sz,siz1
+  REAL :: scal
+  CHARACTER(LEN=7) :: topp
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! 0.0 What size should be the data in the file
+!-
+  req_sz = 1
+  IF (nbindex == iim  .AND. llm <= 1) THEN
+    IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1)
+    IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1)
+  ELSE
+    CALL ipslerr (3,'resget_opp_r2d', &
+      'Unable to performe an operation on this variable as it has', &
+      'a second and third dimension',vname_q)
+  ENDIF
+!-
+  IF (jjm < 1) THEN
+    CALL ipslerr (3,'resget_opp_r2d', &
+      'Please specify a second dimension which is the', &
+      'layer on which the operations are performed',vname_q)
+  ENDIF
+!-
+! 1.0 Allocate the temporary buffer we need
+!     to put the variable in right dimension
+!-
+  siz1 = SIZE(var,1)
+  CALL rest_alloc (1,siz1,l_dbg,'restget_opp_r2d')
+  CALL rest_alloc (2,req_sz*jjm,l_dbg,'restget_opp_r2d')
+!-
+! 2.0 Here we get the full variable from the restart file
+!-
+  CALL restget_real &
+ & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), &
+ &  jjm,itau,def_beha,buff_tmp2)
+!-
+! 4.0 Transfer the buffer obtained from the restart file
+!     into the variable the model expects
+!-
+  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7))
+!-
+  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN
+    scal = missing_val
+    var_sz = siz1
+    DO jj = 1,jjm
+      ist = (jj-1)*req_sz+1
+      CALL mathop (topp,req_sz,buff_tmp2(ist:ist+req_sz-1), &
+ &      missing_val,nbindex,ijndex,scal,var_sz,buff_tmp1)
+      var(:,jj) = buff_tmp1(1:siz1)
+    ENDDO
+  ELSE
+    CALL ipslerr (3,'resget_opp_r2d', &
+      'The operation you wish to do on the variable for the ',&
+      'restart file is not allowed.',topp)
+  ENDIF
+!-----------------------------
+END SUBROUTINE restget_opp_r2d
+!===
+SUBROUTINE restget_r1d &
+ & (fid,vname_q,iim,jjm,llm,itau,def_beha,var)
+!---------------------------------------------------------------------
+!- This subroutine serves as an interface to restget_real
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid
+  CHARACTER(LEN=*) :: vname_q
+  INTEGER :: iim,jjm,llm,itau
+  LOGICAL :: def_beha
+  REAL :: var(:)
+!-
+  INTEGER :: ji,jl,req_sz,var_sz,siz1
+  CHARACTER(LEN=70) :: str,str2
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! 1.0 Allocate the temporary buffer we need
+!     to put the variable in right dimension
+!-
+  siz1 = SIZE(var)
+  var_sz = siz1
+  CALL rest_alloc (1,var_sz,l_dbg,'restget_r1d')
+!-
+! 2.0 Here we could check if the sizes specified agree
+!     with the size of the variable provided
+!-
+  req_sz = 1
+  IF (iim > 0) req_sz = req_sz*iim
+  IF (jjm > 0) req_sz = req_sz*jjm
+  IF (llm > 0) req_sz = req_sz*llm
+  IF (req_sz > var_sz) THEN
+    WRITE(str, &
+ &    '("Size of variable requested from file should be ",I6)') req_sz
+    WRITE(str2, &
+ &    '("but the provided variable can only hold ",I6)') var_sz
+    CALL ipslerr (3,'restget_r1d',str,str2,' ')
+  ENDIF
+  IF (req_sz < var_sz) THEN
+    WRITE(str, &
+ &    '("the size of variable requested from file is ",I6)') req_sz
+    WRITE(str2, &
+ &    '("but the provided variable can hold ",I6)') var_sz
+    CALL ipslerr (2,'restget_r1d', &
+      'There could be a problem here :',str,str2)
+  ENDIF
+!-
+  CALL restget_real &
+ & (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1)
+!-
+! 4.0 Transfer the buffer obtained from the restart file
+!     into the variable the model expects
+!-
+  jl=0
+  DO ji=1,siz1
+    jl=jl+1
+    var(ji) = buff_tmp1(jl)
+  ENDDO
+!-------------------------
+END SUBROUTINE restget_r1d
+!===
+SUBROUTINE restget_r2d &
+ & (fid,vname_q,iim,jjm,llm,itau,def_beha,var)
+!---------------------------------------------------------------------
+!- This subroutine serves as an interface to restget_real
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid
+  CHARACTER(LEN=*) :: vname_q
+  INTEGER :: iim,jjm,llm,itau
+  LOGICAL :: def_beha
+  REAL :: var(:,:)
+!-
+  INTEGER :: ji,jj,jl,req_sz,var_sz,siz1,siz2
+  CHARACTER(LEN=70) :: str,str2
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! 1.0 Allocate the temporary buffer we need
+!     to put the variable in right dimension
+!-
+  siz1 = SIZE(var,1)
+  siz2 = SIZE(var,2)
+  var_sz = siz1*siz2
+  CALL rest_alloc (1,var_sz,l_dbg,'restget_r2d')
+!-
+! 2.0 Here we check if the sizes specified agree
+!     with the size of the variable provided
+!-
+  req_sz = 1
+  IF (iim > 0) req_sz = req_sz*iim
+  IF (jjm > 0) req_sz = req_sz*jjm
+  IF (llm > 0) req_sz = req_sz*llm
+  IF (req_sz > var_sz) THEN
+    WRITE(str, &
+ &    '("Size of variable ",A, &
+ &      //" requested from file should be ",I6)') TRIM(vname_q),req_sz
+    WRITE(str2, &
+ &    '("but the provided variable can only hold ",I6)') var_sz
+    CALL ipslerr (3,'restget_r2d',str,str2,' ')
+  ENDIF
+  IF (req_sz < var_sz) THEN
+    WRITE(str, &
+ &    '("Size of variable ",A, &
+ &      //" requested from file is ",I6)') TRIM(vname_q),req_sz
+    WRITE(str2,'("but the provided variable can hold ",I6)') var_sz
+    CALL ipslerr (2,'restget_r2d', &
+      'There could be a problem here :',str,str2)
+  ENDIF
+!-
+  CALL restget_real &
+ & (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1)
+!-
+! 4.0 Transfer the buffer obtained from the restart file
+!     into the variable the model expects
+!-
+  jl=0
+  DO jj=1,siz2
+    DO ji=1,siz1
+      jl=jl+1
+      var(ji,jj) = buff_tmp1(jl)
+    ENDDO
+  ENDDO
+!-------------------------
+END SUBROUTINE restget_r2d
+!===
+SUBROUTINE restget_r3d &
+  (fid,vname_q,iim,jjm,llm,itau,def_beha,var)
+!---------------------------------------------------------------------
+!- This subroutine serves as an interface to restget_real
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid
+  CHARACTER(LEN=*) :: vname_q
+  INTEGER :: iim,jjm,llm,itau
+  LOGICAL def_beha
+  REAL :: var(:,:,:)
+!-
+  INTEGER :: ji,jj,jk,jl,req_sz,var_sz,siz1,siz2,siz3
+  CHARACTER(LEN=70) :: str,str2
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! 1.0 Allocate the temporary buffer we need
+!     to put the variable in right dimension
+!-
+  siz1 = SIZE(var,1)
+  siz2 = SIZE(var,2)
+  siz3 = SIZE(var,3)
+  var_sz = siz1*siz2*siz3
+  CALL rest_alloc (1,var_sz,l_dbg,'restget_r3d')
+!-
+! 2.0 Here we check if the sizes specified agree
+!     with the size of the variable provided
+!-
+  req_sz = 1
+  IF (iim > 0) req_sz = req_sz*iim
+  IF (jjm > 0) req_sz = req_sz*jjm
+  IF (llm > 0) req_sz = req_sz*llm
+  IF (req_sz > var_sz) THEN
+    WRITE(str, &
+ &    '("Size of variable ",A, &
+ &      //" requested from file should be ",I6)') TRIM(vname_q),req_sz
+    WRITE(str2, &
+ &    '("but the provided variable can only hold ",I6)') var_sz
+    CALL ipslerr (3,'restget_r3d',str,str2,' ')
+  ENDIF
+  IF (req_sz < var_sz) THEN
+    WRITE(str, &
+ &    '("Size of variable ",A, &
+ &      //" requested from file is ",I6)') TRIM(vname_q),req_sz
+    WRITE(str2,'("but the provided variable can hold ",I6)') var_sz
+    CALL ipslerr (2,'restget_r3d', &
+      'There could be a problem here :',str,str2)
+  ENDIF
+!-
+  CALL restget_real &
+    (fid,vname_q,iim,jjm,llm,itau,def_beha,buff_tmp1)
+!-
+! 4.0 Transfer the buffer obtained from the restart file
+!     into the variable the model expects
+!-
+  jl=0
+  DO jk=1,siz3
+    DO jj=1,siz2
+      DO ji=1,siz1
+        jl=jl+1
+        var(ji,jj,jk) = buff_tmp1(jl)
+      ENDDO
+    ENDDO
+  ENDDO
+!-------------------------
+END SUBROUTINE restget_r3d
+!===
+SUBROUTINE restget_real &
+  (fid,vname_q,iim,jjm,llm,itau,def_beha,var)
+!---------------------------------------------------------------------
+!- This subroutine is for getting a variable from the restart file.
+!- A number of verifications will be made :
+!- - Is this the first time we read this variable ?
+!- - Are the dimensions correct ?
+!- - Is the correct time step present in the file
+!- - is a default behaviour possible. If not the model is stoped.
+!- Default procedure is to write the content of val_exp on all values.
+!-
+!- INPUT
+!-
+!- fid            : Identification of the file
+!- vname_q        : Name of the variable to be read
+!- iim, jjm ,llm  : Dimensions of the variable that should be read
+!- itau           : Time step at whcih we are when we want
+!-                  to read the variable
+!- def_beha       : If the model can restart without this variable
+!-                  then some strange value is given.
+!-
+!- OUTPUT
+!-
+!- var            : Variable in which the data is put
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid
+  CHARACTER(LEN=*) :: vname_q
+  INTEGER :: iim,jjm,llm,itau
+  LOGICAL :: def_beha
+  REAL :: var(:)
+!-
+  INTEGER :: vid,vnb,ncfid,iret,index,it,ndim,ia
+  CHARACTER(LEN=70) str,str2
+  CHARACTER(LEN=80) attname
+  INTEGER,DIMENSION(4) :: corner,edge
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!---------------------------------------------------------------------
+  IF (l_dbg) WRITE(ipslout,*) 'RESTGET 0.0 : ',netcdf_name(fid,2),vname_q,iim,jjm,llm,itau,def_beha
+!-
+  ncfid = netcdf_id(fid,1)
+!-
+  CALL find_str (varname_in(fid,1:nbvar_in(fid)),vname_q,vnb)
+!-
+! 1.0 If the variable is not present then ERROR or filled up
+!     by default values if allowed
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'RESTGET 1.0 : ',vnb
+!-
+  IF (vnb < 0) THEN
+    IF (def_beha) THEN
+!-----
+      lock_valexp = .TRUE.
+      var(:) = val_exp
+!----
+      str = 'Variable '//TRIM(vname_q) &
+          //' is not present in the restart file'
+      CALL ipslerr (1,'restget', &
+ &      str,'but default values are used to fill in',' ')
+!----
+      IF (nbvar_in(fid) >= max_var) THEN
+        CALL ipslerr (3,'restget', &
+         'Too many variables for the restcom module', &
+         'Please increase the value of max_var',' ')
+      ENDIF
+      nbvar_in(fid) = nbvar_in(fid)+1
+      vnb = nbvar_in(fid)
+      varname_in(fid,vnb) = vname_q
+      touched_in(fid,vnb) = .TRUE.
+!-----
+      CALL restdefv (fid,vname_q,iim,jjm,llm,.TRUE.)
+      IF (l_dbg) WRITE(ipslout,*) 'RESTGET 1.1 : ',vnb
+!-----
+    ELSE
+      str = 'Variable '//TRIM(vname_q) &
+          //' is not present in the restart file'
+      CALL ipslerr (3,'restget', &
+ &      str,'but it is need to restart the model',' ')
+    ENDIF
+!---
+  ELSE
+!---
+!--  2.0 Check if the variable has not yet been read
+!--      and that the time is OK
+!---
+    vid = varid_in(fid,vnb)
+    IF (l_dbg) WRITE(ipslout,*) 'RESTGET 2.0 : ',vid
+!---
+    nbvar_read(fid) = nbvar_read(fid)+1
+!---
+    IF (touched_in(fid,vnb)) THEN
+      str = 'Variable '//TRIM(vname_q) &
+          //' has already been read from file'
+      CALL ipslerr (3,'restget',str,' ',' ')
+    ENDIF
+!---
+!-- 3.0 get the time step of the restart file
+!--     and check if it is correct
+!---
+    index = -1
+    DO it=1,tax_size_in(fid)
+      IF (t_index(fid,it) == itau)  index = it
+    ENDDO
+    IF (index < 0) THEN
+      str = 'The time step requested for variable '//TRIM(vname_q)
+      CALL ipslerr (3,'restget', &
+ &      str,'is not available in the current file',' ')
+    ENDIF
+    IF (l_dbg) WRITE(ipslout,*) 'RESTGET 3.0 : ',index
+!---
+!-- 4.0 Read the data. Note that the variables in the restart files
+!--     have no time axis is and thus we write -1
+!---
+    str='Incorrect dimension for '//TRIM(vname_q)
+    ndim = 0
+    IF (iim > 0) THEN
+      ndim = ndim+1
+      IF (vardims_in(fid,vnb,ndim) == iim) THEN
+        corner(ndim) = 1
+        edge(ndim) = iim
+      ELSE
+        WRITE (str2,'("Incompatibility for iim : ",I6,I6)') &
+             iim,vardims_in(fid,vnb,ndim)
+        CALL ipslerr (3,'restget',str,str2,' ')
+      ENDIF
+    ENDIF
+!---
+    IF (jjm > 0) THEN
+      ndim = ndim+1
+      IF (vardims_in(fid,vnb,ndim) == jjm) THEN
+        corner(ndim) = 1
+        edge(ndim) = jjm
+      ELSE
+        WRITE (str2,'("Incompatibility for jjm : ",I6,I6)') &
+             jjm,vardims_in(fid,vnb,ndim)
+        CALL ipslerr (3,'restget',str,str2,' ')
+      ENDIF
+    ENDIF
+!---
+    IF (llm > 0) THEN
+      ndim = ndim+1
+      IF (vardims_in(fid,vnb,ndim) == llm) THEN
+        corner(ndim) = 1
+        edge(ndim) = llm
+      ELSE
+        WRITE (str2,'("Incompatibility for llm : ",I6,I6)') &
+             llm,vardims_in(fid,vnb,ndim)
+        CALL ipslerr (3,'restget',str,str2,' ')
+      ENDIF
+    ENDIF
+!---
+!-- Time
+!---
+    ndim = ndim+1
+    corner(ndim) = index
+!!????? edge(ndim) = index
+    edge(ndim) = 1
+!---
+    iret = NF90_GET_VAR(ncfid,vid,var, &
+ &                      start=corner(1:ndim),count=edge(1:ndim))
+    IF (l_dbg) WRITE(ipslout,*) 'RESTGET 4.0 : ',iret
+!---
+!-- 5.0 The variable we have just read is created
+!--      in the next restart file
+!---
+    IF (     (netcdf_id(fid,1) /= netcdf_id(fid,2))  &
+ &      .AND.(netcdf_id(fid,2) > 0) ) THEN
+!-----
+      CALL restdefv (fid,vname_q,iim,jjm,llm,.FALSE.)
+!-----
+      DO ia = 1,varatt_in(fid,vnb)
+        iret = NF90_INQ_ATTNAME(ncfid,vid,ia,attname)
+        iret = NF90_COPY_ATT(ncfid,vid,attname, &
+ &               netcdf_id(fid,2),varid_out(fid,nbvar_out(fid)))
+      ENDDO
+!-----
+      IF (itau_out(fid) >= 0) THEN
+        iret = NF90_ENDDEF(netcdf_id(fid,2))
+      ENDIF
+    ENDIF
+!---
+  ENDIF
+!--------------------------
+END SUBROUTINE restget_real
+!===
+SUBROUTINE restput_opp_r1d &
+ & (fid,vname_q,iim,jjm,llm,itau,var,MY_OPERATOR,nbindex,ijndex)
+!---------------------------------------------------------------------
+!- This subroutine is the interface to restput_real which allows
+!- to re-index data onto the original grid of the restart file.
+!- The logic we use is still fuzzy in my mind but that is probably
+!- only because I have not yet though through everything.
+!-
+!- In the case iim = nbindex it means that the user attempts
+!- to project a vector back onto the original 2D or 3D field.
+!- This requires that jjm and llm be equal to 1 or 0,
+!- else I would not know what it means.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid
+  CHARACTER(LEN=*) :: vname_q
+  INTEGER :: iim,jjm,llm,itau
+  REAL :: var(:)
+  CHARACTER(LEN=*) :: MY_OPERATOR
+  INTEGER :: nbindex,ijndex(nbindex)
+!-
+  INTEGER :: req_sz,siz1
+  REAL :: scal
+  CHARACTER(LEN=7) :: topp
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! 0.0 What size should be the data in the file
+!-
+  req_sz = 1
+  IF ( nbindex == iim .AND. jjm <= 1 .AND. llm <= 1) THEN
+    IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1)
+    IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1)
+    IF (zax_infs(fid,1,1) > 0) req_sz = req_sz*zax_infs(fid,1,1)
+  ELSE
+    CALL ipslerr (3,'restput_opp_r1d', &
+      'Unable to performe an operation on this variable as it has', &
+      'a second and third dimension',vname_q)
+  ENDIF
+!-
+! 1.0 Allocate the temporary buffer we need
+!     to put the variable in right dimension
+!-
+  siz1 = SIZE(var)
+  CALL rest_alloc (1,siz1,l_dbg,'restput_opp_r1d')
+  CALL rest_alloc (2,req_sz,l_dbg,'restput_opp_r1d')
+!-
+! 2.0 We do the operation needed.
+!     It can only be a re-indexing operation.
+!     You would not want to change the values in a restart file or ?
+!-
+  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7))
+!-
+  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN
+    scal = missing_val
+    buff_tmp1(1:siz1) = var(:)
+    CALL mathop &
+ &    (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, &
+ &     scal,req_sz,buff_tmp2)
+  ELSE
+    CALL ipslerr (3,'restput_opp_r1d', &
+ &    'The operation you wish to do on the variable for the ', &
+ &    'restart file is not allowed.',topp)
+  ENDIF
+!-
+  CALL restput_real &
+ & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), &
+ &  zax_infs(fid,1,1),itau,buff_tmp2)
+!-----------------------------
+END SUBROUTINE restput_opp_r1d
+!===
+SUBROUTINE restput_opp_r2d &
+ & (fid,vname_q,iim,jjm,llm,itau,var,MY_OPERATOR,nbindex,ijndex)
+!---------------------------------------------------------------------
+!- This subroutine is the interface to restput_real which allows
+!- to re-index data onto the original grid of the restart file.
+!- The logic we use is still fuzzy in my mind but that is probably
+!- only because I have not yet though through everything.
+!-
+!- In the case iim = nbindex it means that the user attempts
+!- to project the first dimension of the matrix back onto a 3D field
+!- where jjm will be the third dimension.
+!- Here we do not allow for 4D data, thus we will take the first
+!- two dimensions in the file and require that llm = 1.
+!- These are pretty heavy constraints but I do not know how
+!- to make it more general. I need to think about it some more.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid
+  CHARACTER(LEN=*) :: vname_q
+  INTEGER :: iim,jjm,llm,itau
+  REAL :: var(:,:)
+  CHARACTER(LEN=*) :: MY_OPERATOR
+  INTEGER :: nbindex,ijndex(nbindex)
+!-
+  INTEGER :: jj,req_sz,ist,siz1
+  REAL :: scal
+  CHARACTER(LEN=7) :: topp
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! 0.0 What size should be the data in the file
+!-
+  req_sz = 1
+  IF ( nbindex == iim .AND. llm <= 1) THEN
+    IF (xax_infs(fid,1,1) > 0) req_sz = req_sz*xax_infs(fid,1,1)
+    IF (yax_infs(fid,1,1) > 0) req_sz = req_sz*yax_infs(fid,1,1)
+  ELSE
+    CALL ipslerr (3,'restput_opp_r2d', &
+      'Unable to performe an operation on this variable as it has', &
+      'a second and third dimension',vname_q)
+  ENDIF
+!-
+  IF (jjm < 1) THEN
+    CALL ipslerr (3,'restput_opp_r2d', &
+      'Please specify a second dimension which is the', &
+      'layer on which the operations are performed',vname_q)
+  ENDIF
+!-
+! 1.0 Allocate the temporary buffer we need
+!     to put the variable in right dimension
+!-
+  siz1 = SIZE(var,1)
+  CALL rest_alloc (1,siz1,l_dbg,'restput_opp_r2d')
+  CALL rest_alloc (2,req_sz*jjm,l_dbg,'restput_opp_r2d')
+!-
+! 2.0 We do the operation needed.
+!     It can only be a re-indexing operation.
+!     You would not want to change the values in a restart file or ?
+!-
+  topp = MY_OPERATOR(1:MIN(LEN_TRIM(MY_OPERATOR),7))
+!-
+  IF (INDEX(indchfun,topp(:LEN_TRIM(topp))) > 0) THEN
+    scal = missing_val
+    DO jj = 1,jjm
+      buff_tmp1(1:siz1) = var(:,jj)
+      ist = (jj-1)*req_sz+1
+      CALL mathop &
+ &      (topp,siz1,buff_tmp1,missing_val,nbindex,ijndex, &
+ &       scal,req_sz,buff_tmp2(ist:ist+req_sz-1))
+    ENDDO
+  ELSE
+    CALL ipslerr (3,'restput_opp_r2d', &
+ &    'The operation you wish to do on the variable for the ', &
+ &    'restart file is not allowed.',topp)
+  ENDIF
+!-
+  CALL restput_real &
+ & (fid,vname_q,xax_infs(fid,1,1),yax_infs(fid,1,1), &
+ &  jjm,itau,buff_tmp2)
+!-----------------------------
+END SUBROUTINE restput_opp_r2d
+!===
+SUBROUTINE restput_r1d (fid,vname_q,iim,jjm,llm,itau,var)
+!---------------------------------------------------------------------
+!- This subroutine serves as an interface to restput_real
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid
+  CHARACTER(LEN=*) :: vname_q
+  INTEGER :: iim,jjm,llm,itau
+  REAL :: var(:)
+!-
+  INTEGER :: ji,jl,req_sz,var_sz,siz1
+  CHARACTER(LEN=70) :: str,str2
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! 1.0 Allocate the temporary buffer we need
+!     to put the variable in right dimension
+!-
+  siz1 = SIZE(var)
+  var_sz = siz1
+  CALL rest_alloc (1,var_sz,l_dbg,'restput_r1d')
+!-
+! 2.0 Here we could check if the sizes specified agree
+!     with the size of the variable provided
+!-
+  req_sz = 1
+  IF (iim > 0) req_sz = req_sz*iim
+  IF (jjm > 0) req_sz = req_sz*jjm
+  IF (llm > 0) req_sz = req_sz*llm
+  IF (req_sz > var_sz) THEN
+    WRITE(str, &
+ &    '("Size of variable put to the file should be ",I6)') req_sz
+    WRITE(str2, &
+ &    '("but the provided variable is of size ",I6)') var_sz
+    CALL ipslerr (3,'restput_r1d',str,str2,' ')
+  ENDIF
+  IF (req_sz < var_sz) THEN
+    WRITE(str,'("the size of variable put to the file is ",I6)') req_sz
+    WRITE(str2,'("but the provided variable is larger ",I6)') var_sz
+    CALL ipslerr (2,'restput_r1d', &
+      'There could be a problem here :',str,str2)
+  ENDIF
+!-
+! 4.0 Transfer the buffer obtained from the restart file
+!     into the variable the model expects
+!-
+  jl=0
+  DO ji=1,siz1
+    jl=jl+1
+    buff_tmp1(jl) = var(ji)
+  ENDDO
+!-
+  CALL restput_real (fid,vname_q,iim,jjm,llm,itau,buff_tmp1)
+!-------------------------
+END SUBROUTINE restput_r1d
+!===
+SUBROUTINE restput_r2d (fid,vname_q,iim,jjm,llm,itau,var)
+!---------------------------------------------------------------------
+!- This subroutine serves as an interface to restput_real
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid
+  CHARACTER(LEN=*) :: vname_q
+  INTEGER :: iim,jjm,llm,itau
+  REAL :: var(:,:)
+!-
+  INTEGER :: ji,jj,jl,req_sz,var_sz,siz1,siz2
+  CHARACTER(LEN=70) :: str,str2
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! 1.0 Allocate the temporary buffer we need
+!     to put the variable in right dimension
+!-
+  siz1 = SIZE(var,1)
+  siz2 = SIZE(var,2)
+  var_sz = siz1*siz2
+  CALL rest_alloc (1,var_sz,l_dbg,'restput_r2d')
+!-
+! 2.0 Here we could check if the sizes specified agree
+!     with the size of the variable provided
+!-
+  req_sz = 1
+  IF (iim > 0) req_sz = req_sz*iim
+  IF (jjm > 0) req_sz = req_sz*jjm
+  IF (llm > 0) req_sz = req_sz*llm
+  IF (req_sz > var_sz) THEN
+    WRITE(str, &
+&         '("Size of variable put to the file should be ",I6)') req_sz
+    WRITE(str2,'("but the provided variable is of size  ",I6)') var_sz
+    CALL ipslerr (3,'restput_r2d',str,str2,' ')
+  ENDIF
+  IF (req_sz < var_sz) THEN
+    WRITE(str,'("the size of variable put to the file is ",I6)') req_sz
+    WRITE(str2,'("but the provided variable is larger ",I6)')  var_sz
+    CALL ipslerr (2,'restput_r2d', &
+      'There could be a problem here :',str,str2)
+  ENDIF
+!-
+! 4.0 Transfer the buffer obtained from the restart file
+!     into the variable the model expects
+!-
+  jl=0
+  DO jj=1,siz2
+    DO ji=1,siz1
+      jl=jl+1
+      buff_tmp1(jl) = var(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  CALL restput_real(fid,vname_q,iim,jjm,llm,itau,buff_tmp1)
+!-------------------------
+END SUBROUTINE restput_r2d
+!===
+SUBROUTINE restput_r3d (fid,vname_q,iim,jjm,llm,itau,var)
+!---------------------------------------------------------------------
+!- This subroutine serves as an interface to restput_real
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: fid
+  CHARACTER(LEN=*) :: vname_q
+  INTEGER :: iim,jjm,llm,itau
+  REAL :: var(:,:,:)
+!-
+  INTEGER :: ji,jj,jk,jl,req_sz,var_sz,siz1,siz2,siz3
+  CHARACTER(LEN=70) :: str,str2
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! 1.0 Allocate the temporary buffer we need
+!     to put the variable in right dimension
+!-
+  siz1 = SIZE(var,1)
+  siz2 = SIZE(var,2)
+  siz3 = SIZE(var,3)
+  var_sz = siz1*siz2*siz3
+  CALL rest_alloc (1,var_sz,l_dbg,'restput_r3d')
+!-
+! 2.0 Here we could check if the sizes specified agree
+!     with the size of the variable provided
+!-
+  req_sz = 1
+  IF (iim > 0) req_sz = req_sz*iim
+  IF (jjm > 0) req_sz = req_sz*jjm
+  IF (llm > 0) req_sz = req_sz*llm
+  IF (req_sz > var_sz) THEN
+    WRITE(str, &
+ &    '("Size of variable put to the file should be ",I6)') req_sz
+    WRITE(str2, &
+ &    '("but the provided variable is of size  ",I6)')  var_sz
+    CALL ipslerr (3,'restput_r3d',str,str2,' ')
+  ENDIF
+  IF (req_sz < var_sz) THEN
+    WRITE(str,'("the size of variable put to the file is ",I6)') req_sz
+    WRITE(str2,'("but the provided variable is larger ",I6)')  var_sz
+    CALL ipslerr (2,'restput_r3d', &
+      'There could be a problem here :',str,str2)
+  ENDIF
+!-
+! 4.0 Transfer the buffer obtained from the restart file
+!     into the variable the model expects
+!-
+  jl=0
+  DO jk=1,siz3
+    DO jj=1,siz2
+      DO ji=1,siz1
+        jl=jl+1
+        buff_tmp1(jl) = var(ji,jj,jk)
+      ENDDO
+    ENDDO
+  ENDDO
+!-
+  CALL restput_real(fid,vname_q,iim,jjm,llm,itau,buff_tmp1)
+!-------------------------
+END SUBROUTINE restput_r3d
+!===
+SUBROUTINE restput_real (fid,vname_q,iim,jjm,llm,itau,var)
+!---------------------------------------------------------------------
+!- This subroutine will put a variable into the restart file.
+!- But it will do a lot of other things if needed :
+!- - Open a file if non is opened for this time-step
+!-   and all variables were written.
+!- - Add an axis if needed
+!- - verify that the variable has the right time step for this file
+!- - If it is time for a new file then it is opened
+!-   and the old one closed
+!- This requires that variables read from the last restart file were all
+!- written
+!-
+!- INPUT
+!-
+!- fid         : Id of the file in which we will write the variable
+!- vname_q     : Name of the variable to be written
+!- iim,jjm,llm : Size in 3D of the variable
+!- itau        : Time step at which the variable is written
+!- var         : Variable
+!-
+!- OUTPUT
+!-
+!- NONE
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: vname_q
+  INTEGER :: fid,iim,jjm,llm,itau
+  REAL :: var(:)
+!-
+  INTEGER :: iret,vid,ncid,iv,vnb
+  INTEGER :: ierr
+  REAL :: secsince,one_day,one_year
+  INTEGER :: ndims
+  INTEGER,DIMENSION(4) :: corner,edge
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+! 0.0 Get some variables
+!-
+  ncid = netcdf_id(fid,2)
+  IF (netcdf_id(fid,2) < 0) THEN
+    CALL ipslerr (3,'restput', &
+ &    'The output restart file is undefined.',' ',' ')
+  ENDIF
+  CALL ioget_calendar (one_year,one_day)
+!-
+! 0.0 show arguments
+  IF (l_dbg) WRITE(ipslout,*) 'RESTPUT 0.0 : ',netcdf_name(fid,2),vname_q,iim,jjm,llm,itau
+!-
+! 1.0 Check if the variable is already present
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'RESTPUT 1.0 : ',TRIM(vname_q)
+!-
+  CALL find_str (varname_out(fid,1:nbvar_out(fid)),vname_q,vnb)
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) 'RESTPUT 1.1 : ',varname_out(fid,1:nbvar_out(fid)),vnb
+  ENDIF
+!-
+! 2.0 If variable is not present then declare it
+!     and add extra dimensions if needed.
+!-
+  IF (vnb <= 0) THEN
+    CALL restdefv (fid,vname_q,iim,jjm,llm,.TRUE.)
+    vnb = nbvar_out(fid)
+  ENDIF
+  vid = varid_out(fid,vnb)
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'RESTPUT 2.0 : ',vnb,vid
+!-
+! 2.1 Is this file already in write mode ?
+!     If itau_out is still negative then we have
+!     never written to it and we need to go into write mode.
+!-
+  IF (itau_out(fid) < 0) THEN
+    iret = NF90_ENDDEF(ncid)
+  ENDIF
+!-
+! 3.0 Is this itau already on the axis ?
+!     If not then check that all variables of previous time is OK.
+!-
+  IF (l_dbg) WRITE(ipslout,*) 'RESTPUT 3.0 : ',itau,itau_out(fid)
+!-
+  IF (itau /= itau_out(fid)) THEN
+!---
+!-- If it is the first time step written on the restart
+!-- then we only check the number
+!-- Else we see if every variable was written
+!---
+    IF (tstp_out(fid) == 0) THEN
+      IF (nbvar_out(fid) < nbvar_read(fid)) THEN
+        WRITE(ipslout,*) "ERROR :",tstp_out(fid), &
+                   nbvar_out(fid),nbvar_read(fid)
+        CALL ipslerr (1,'restput', &
+ &        'There are fewer variables read from the output file', &
+ &        'than written onto the input file.', &
+ &        'We trust you know what you are doing')
+      ENDIF
+    ELSE
+      ierr = 0
+      DO iv=1,nbvar_out(fid)
+        IF (.NOT.touched_out(fid,iv)) ierr = ierr+1
+      ENDDO
+      IF (ierr > 0) THEN
+        WRITE(ipslout,*) "ERROR :",nbvar_out(fid)
+        CALL ipslerr (1,'restput', &
+ &        'There are fewer variables in the output file for this', &
+ &        'time step than for the previous one',' ')
+      ELSE
+        touched_out(fid,:) = .FALSE.
+      ENDIF
+    ENDIF
+!---
+    secsince = itau*deltat(fid)
+    corner(1) =  tstp_out(fid)+1
+    edge(1) = 1
+!---
+!-- 3.1 Here we add the values to the time axes
+!---
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) 'RESTPUT 3.1 : ',itau,secsince,corner(1),edge(1)
+    ENDIF
+!---
+    iret = NF90_PUT_VAR(ncid,tind_varid_out(fid),itau, &
+ &                      start=corner(1:1))
+    iret = NF90_PUT_VAR(ncid,tax_varid_out(fid),secsince, &
+ &                      start=corner(1:1))
+!---
+    tstp_out(fid) = tstp_out(fid)+1
+    itau_out(fid) = itau
+  ENDIF
+!-
+! 4.0 Variable and time step should be present
+!     now so we can dump variable
+!-
+  ndims = 0
+  IF (iim > 0) THEN
+    ndims = ndims+1
+    corner(ndims) = 1
+    edge(ndims) = iim
+  ENDIF
+  IF (jjm > 0) THEN
+    ndims = ndims+1
+    corner(ndims) = 1
+    edge(ndims) = jjm
+  ENDIF
+  IF (llm > 0) THEN
+    ndims = ndims+1
+    corner(ndims) = 1
+    edge(ndims) = llm
+  ENDIF
+  ndims = ndims+1
+  corner(ndims) = tstp_out(fid)
+  edge(ndims) = 1
+!-
+  iret = NF90_PUT_VAR(ncid,vid,var, &
+ &                    start=corner(1:ndims),count=edge(1:ndims))
+!-
+  IF (iret /= NF90_NOERR) THEN
+    CALL ipslerr (2,'restput_real',NF90_STRERROR(iret), &
+ &    'Bug in restput.',&
+ &    'Please, verify compatibility between get and put commands.')
+  ENDIF
+!-
+!  5.0 Note that the variables was treated
+!-
+  touched_out(fid,vnb) = .TRUE.
+!---------------------------
+END  SUBROUTINE restput_real
+!===
+SUBROUTINE restdefv (fid,varname,iim,jjm,llm,write_att)
+!---------------------------------------------------------------------
+! This subroutine adds a variable to the output file.
+! The attributes are either taken from.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER ::fid
+  CHARACTER(LEN=*) :: varname
+  INTEGER :: iim,jjm,llm
+  LOGICAL :: write_att
+!-
+  INTEGER :: dims(4),ic,xloc,ndim,ncfid
+  INTEGER :: iret,ax_id
+  CHARACTER(LEN=3) :: str
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  ncfid = netcdf_id(fid,2)
+  IF (nbvar_out(fid) >= max_var) THEN
+    CALL ipslerr (3,'restdefv', &
+      'Too many variables for the restcom module', &
+      'Please increase the value of max_var',' ')
+  ENDIF
+  nbvar_out(fid) = nbvar_out(fid)+1
+  varname_out(fid,nbvar_out(fid)) = varname
+!-
+! 0.0 Put the file in define mode if needed
+!-
+  IF (itau_out(fid) >= 0) THEN
+    iret = NF90_REDEF(ncfid)
+    IF (l_dbg) THEN
+       WRITE(ipslout,*) 'restdefv 0.0 : REDEF',itau_out(fid)
+    ENDIF
+  ENDIF
+!-
+! 1.0 Do we have all dimensions and can we go ahead
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) 'restdefv 1.0 :',TRIM(varname),nbvar_out(fid)
+  ENDIF
+!-
+  ndim = 0
+!-
+! 1.1 Work on x
+!-
+  IF (iim > 0) THEN
+    ndim = ndim+1
+    xloc = 0
+    DO ic=1,xax_nb(fid)
+      IF (xax_infs(fid,ic,1) == iim) xloc = ic
+    ENDDO
+!---
+    IF (xloc > 0) THEN
+      dims(ndim) = xax_infs(fid,xloc,2)
+    ELSE
+      str='x_'//CHAR(96+xax_nb(fid))
+      iret = NF90_DEF_DIM(ncfid,str,iim,ax_id)
+      xax_nb(fid) = xax_nb(fid)+1
+      xax_infs(fid,xax_nb(fid),1) = iim
+      xax_infs(fid,xax_nb(fid),2) = ax_id
+      dims(ndim) = ax_id
+    ENDIF
+  ENDIF
+!-
+! 1.2 Work on y
+!-
+  IF (jjm > 0) THEN
+    ndim = ndim+1
+    xloc = 0
+    DO ic=1,yax_nb(fid)
+      IF (yax_infs(fid,ic,1) == jjm) xloc = ic
+    ENDDO
+!---
+    IF (xloc > 0) THEN
+      dims(ndim) = yax_infs(fid,xloc,2)
+    ELSE
+      str='y_'//CHAR(96+yax_nb(fid))
+      iret = NF90_DEF_DIM(ncfid,str,jjm,ax_id)
+      yax_nb(fid) = yax_nb(fid)+1
+      yax_infs(fid,yax_nb(fid),1) = jjm
+      yax_infs(fid,yax_nb(fid),2) = ax_id
+      dims(ndim) = ax_id
+    ENDIF
+  ENDIF
+!-
+! 1.3 Work on z
+!-
+  IF (llm > 0) THEN
+    ndim = ndim+1
+    xloc = 0
+    DO ic=1,zax_nb(fid)
+      IF (zax_infs(fid,ic,1) == llm) xloc = ic
+    ENDDO
+!---
+    IF (xloc > 0) THEN
+      dims(ndim) = zax_infs(fid,xloc,2)
+    ELSE
+      str='z_'//CHAR(96+zax_nb(fid))
+      iret = NF90_DEF_DIM(ncfid,str,llm,ax_id)
+      zax_nb(fid) = zax_nb(fid)+1
+      zax_infs(fid,zax_nb(fid),1) = llm
+      zax_infs(fid,zax_nb(fid),2) = ax_id
+      dims(ndim) = ax_id
+    ENDIF
+  ENDIF
+!-
+! 1.4  Time needs to be added
+!-
+  ndim = ndim+1
+  dims(ndim) = tdimid_out(fid)
+!-
+! 2.0  Declare the variable
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) 'restdefv 2.0 :',ndim,' :: ',dims(1:ndim),tdimid_out(fid)
+  ENDIF
+!-
+  iret = NF90_DEF_VAR(ncfid,varname,NF90_DOUBLE,dims(1:ndim), &
+ &                    varid_out(fid,nbvar_out(fid)))
+  IF (iret /= NF90_NOERR) THEN
+    CALL ipslerr (3,'restdefv', &
+      'Could not define new variable in file', &
+      NF90_STRERROR(iret),varname)
+  ENDIF
+!-
+! 3.0 Add the attributes if requested
+!-
+  IF (write_att) THEN
+    IF (rest_units /= 'XXXXX') THEN
+      iret =  NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), &
+ &                         'units',TRIM(rest_units))
+      rest_units = 'XXXXX'
+    ENDIF
+!---
+    IF (rest_lname /= 'XXXXX') THEN
+      iret =  NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), &
+ &                         'long_name',TRIM(rest_lname))
+      rest_lname = 'XXXXX'
+    ENDIF
+!---
+    iret = NF90_PUT_ATT(ncfid,varid_out(fid,nbvar_out(fid)), &
+ &                      'missing_value',REAL(missing_val,KIND=4))
+!---
+    IF (itau_out(fid) >= 0) THEN
+      iret = NF90_ENDDEF(ncfid)
+    ENDIF
+  ENDIF
+!-
+  IF (l_dbg) THEN
+    WRITE(ipslout,*) &
+ &    'restdefv 3.0 : LIST OF VARS ',varname_out(fid,1:nbvar_out(fid))
+  ENDIF
+!----------------------
+END SUBROUTINE restdefv
+!===
+SUBROUTINE rest_atim (l_msg,c_p)
+!---------------------------------------------------------------------
+! Called by "c_p", [re]allocate the time axes
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  LOGICAL,INTENT(IN) :: l_msg
+  CHARACTER(LEN=*),INTENT(IN) :: c_p
+!-
+  INTEGER :: i_err,tszij
+  INTEGER,ALLOCATABLE :: tmp_index(:,:)
+  REAL,ALLOCATABLE :: tmp_julian(:,:)
+!---------------------------------------------------------------------
+!-
+!  Allocate the space we need for the time axes
+!-
+  IF (.NOT.ALLOCATED(t_index) .AND. .NOT.ALLOCATED(t_julian)) THEN
+    IF (l_msg) THEN
+      WRITE(ipslout,*) TRIM(c_p)//' : Allocate times axes at :', &
+ &               max_file,tax_size_in(nb_fi)
+    ENDIF
+!---
+    ALLOCATE(t_index(max_file,tax_size_in(nb_fi)),STAT=i_err)
+    IF (i_err/=0) THEN
+      WRITE(ipslout,*) "ERROR IN ALLOCATION of t_index : ",i_err
+      CALL ipslerr (3,TRIM(c_p), &
+ &      'Problem in allocation of t_index','', &
+ &      '(you must increase memory)')
+    ENDIF
+    t_index (:,:) = 0
+!---
+    ALLOCATE(t_julian(max_file,tax_size_in(nb_fi)),STAT=i_err)
+    IF (i_err/=0) THEN
+      WRITE(ipslout,*) "ERROR IN ALLOCATION of t_julian : ",i_err
+      CALL ipslerr (3,TRIM(c_p), &
+ &      'Problem in allocation of max_file,tax_size_in','', &
+ &      '(you must increase memory)')
+    ENDIF
+    t_julian (:,:) = 0.0
+  ELSE IF (    (SIZE(t_index,DIM=2)  < tax_size_in(nb_fi)) &
+ &         .OR.(SIZE(t_julian,DIM=2) < tax_size_in(nb_fi)) ) THEN
+    IF (l_msg) THEN
+      WRITE(ipslout,*) TRIM(c_p)//' : Reallocate times axes at :', &
+ &               max_file,tax_size_in(nb_fi)
+    ENDIF
+!---
+    ALLOCATE (tmp_index(max_file,tax_size_in(nb_fi)),STAT=i_err)
+    IF (i_err/=0) THEN
+      WRITE(ipslout,*) "ERROR IN ALLOCATION of tmp_index : ",i_err
+      CALL ipslerr (3,TRIM(c_p), &
+ &      'Problem in allocation of tmp_index','', &
+ &      '(you must increase memory)')
+    ENDIF
+    tszij = SIZE(t_index,DIM=2)
+    tmp_index(:,1:tszij) = t_index(:,1:tszij)
+    DEALLOCATE(t_index)
+    ALLOCATE (t_index(max_file,tax_size_in(nb_fi)),STAT=i_err)
+    IF (i_err/=0) THEN
+      WRITE(ipslout,*) "ERROR IN ALLOCATION of t_index : ",i_err
+      CALL ipslerr (3,TRIM(c_p), &
+ &     'Problem in reallocation of t_index','', &
+ &     '(you must increase memory)')
+    ENDIF
+    t_index(:,1:tszij) = tmp_index(:,1:tszij)
+!---
+    ALLOCATE (tmp_julian(max_file,tax_size_in(nb_fi)),STAT=i_err)
+    IF (i_err/=0) THEN
+      WRITE(ipslout,*) "ERROR IN ALLOCATION of tmp_julian : ",i_err
+      CALL ipslerr (3,TRIM(c_p), &
+ &     'Problem in allocation of tmp_julian','', &
+ &     '(you must increase memory)')
+    ENDIF
+    tszij = SIZE(t_julian,DIM=2)
+    tmp_julian(:,1:tszij) = t_julian(:,1:tszij)
+    DEALLOCATE(t_julian)
+    ALLOCATE (t_julian(max_file,tax_size_in(nb_fi)),STAT=i_err)
+    IF (i_err/=0) THEN
+      WRITE(ipslout,*) "ERROR IN ALLOCATION of t_julian : ",i_err
+      CALL ipslerr (3,TRIM(c_p), &
+ &      'Problem in reallocation of t_julian','', &
+ &      '(you must increase memory)')
+    ENDIF
+    t_julian(:,1:tszij) = tmp_julian(:,1:tszij)
+  ENDIF
+!-----------------------
+END SUBROUTINE rest_atim
+!===
+SUBROUTINE rest_alloc (i_buff,i_qsz,l_msg,c_p)
+!---------------------------------------------------------------------
+! Called by "c_p", allocate a temporary buffer
+! (buff_tmp[1/2] depending on "i_buff" value) to the size "i_qsz".
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: i_buff,i_qsz
+  LOGICAL,INTENT(IN) :: l_msg
+  CHARACTER(LEN=*),INTENT(IN) :: c_p
+!-
+  INTEGER :: i_bsz,i_err
+  LOGICAL :: l_alloc1,l_alloc2
+  CHARACTER(LEN=9) :: cbn
+  CHARACTER(LEN=5) :: c_err
+!---------------------------------------------------------------------
+  IF      (i_buff == 1) THEN
+    IF (ALLOCATED(buff_tmp1)) THEN
+      i_bsz = SIZE(buff_tmp1)
+    ELSE
+      i_bsz = 0
+    ENDIF
+    l_alloc1 =    (.NOT.ALLOCATED(buff_tmp1)) &
+ &            .OR.((ALLOCATED(buff_tmp1)).AND.(i_qsz > i_bsz))
+    l_alloc2 = .FALSE.
+    cbn = 'buff_tmp1'
+  ELSE IF (i_buff == 2) THEN
+    IF (ALLOCATED(buff_tmp2)) THEN
+      i_bsz = SIZE(buff_tmp2)
+    ELSE
+      i_bsz = 0
+    ENDIF
+    l_alloc1 = .FALSE.
+    l_alloc2 =    (.NOT.ALLOCATED(buff_tmp2)) &
+ &            .OR.((ALLOCATED(buff_tmp2)).AND.(i_qsz > i_bsz))
+    cbn = 'buff_tmp2'
+  ELSE
+    CALL ipslerr (3,'rest_alloc', &
+ &    'Called by '//TRIM(c_p),'with a wrong value of i_buff','')
+  ENDIF
+!-
+!-
+  IF (l_alloc1.OR.l_alloc2) THEN
+    IF (l_msg) THEN
+      IF (    (l_alloc1.AND.ALLOCATED(buff_tmp1)) &
+ &        .OR.(l_alloc2.AND.ALLOCATED(buff_tmp2)) ) THEN
+        WRITE(ipslout,*) TRIM(c_p)//" : re_allocate "//TRIM(cbn)//"=",i_qsz
+      ELSE
+        WRITE(ipslout,*) TRIM(c_p)//" : allocate "//TRIM(cbn)//"=",i_qsz
+      ENDIF
+    ENDIF
+    IF (l_alloc1) THEN
+      IF (ALLOCATED(buff_tmp1)) THEN
+        DEALLOCATE(buff_tmp1)
+      ENDIF
+      ALLOCATE (buff_tmp1(i_qsz),STAT=i_err)
+    ELSE
+      IF (ALLOCATED(buff_tmp2)) THEN
+        DEALLOCATE(buff_tmp2)
+      ENDIF
+      ALLOCATE (buff_tmp2(i_qsz),STAT=i_err)
+    ENDIF
+    IF (i_err /= 0) THEN
+      WRITE (UNIT=c_err,FMT='(I5)') i_err
+      CALL ipslerr (3,TRIM(c_p), &
+ &      'Problem in allocation of',TRIM(cbn), &
+ &      'Error : '//TRIM(c_err)//' (you must increase memory)')
+    ENDIF
+  ENDIF
+!------------------------
+END SUBROUTINE rest_alloc
+!===
+SUBROUTINE ioconf_setatt (attname,value)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: attname,value
+!-
+  CHARACTER(LEN=LEN_TRIM(attname)) :: tmp_str
+!---------------------------------------------------------------------
+  tmp_str = attname
+  CALL strlowercase (tmp_str)
+!-
+  SELECT CASE(tmp_str)
+    CASE('units')
+      rest_units = value
+    CASE('long_name')
+      rest_lname = value
+    CASE DEFAULT
+      CALL ipslerr (2,'ioconf_restatt', &
+        'The attribute name provided is unknown',attname,' ')
+  END SELECT
+!---------------------------
+END SUBROUTINE ioconf_setatt
+!===
+SUBROUTINE ioget_vdim (fid,vname_q,varnbdim_max,varnbdim,vardims)
+!---------------------------------------------------------------------
+!- This routine allows the user to get the dimensions
+!- of a field in the restart file.
+!- This is the file which is read.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: fid
+  CHARACTER(LEN=*) :: vname_q
+  INTEGER,INTENT(IN) :: varnbdim_max
+  INTEGER,INTENT(OUT) ::  varnbdim
+  INTEGER,DIMENSION(varnbdim_max),INTENT(OUT) :: vardims
+!-
+  INTEGER :: vnb
+!---------------------------------------------------------------------
+! Find the index of the variable
+  CALL find_str (varname_in(fid,1:nbvar_in(fid)),vname_q,vnb)
+!-
+  IF (vnb > 0) THEN
+    varnbdim = varnbdim_in(fid,vnb)
+    IF (varnbdim_max < varnbdim) THEN
+      CALL ipslerr (3,'ioget_vdim', &
+        'The provided array for the variable dimensions is too small', &
+        '','')
+    ELSE
+      vardims(1:varnbdim) = vardims_in(fid,vnb,1:varnbdim)
+    ENDIF
+  ELSE
+    varnbdim = 0
+    CALL ipslerr (2,'ioget_vdim', &
+      'Variable '//TRIM(vname_q)//' not found','','')
+  ENDIF
+!------------------------
+END SUBROUTINE ioget_vdim
+!===
+SUBROUTINE ioget_vname (fid,nbvar,varnames)
+!---------------------------------------------------------------------
+!- This routine allows the user to extract the list
+!- of variables in an opened restart file.
+!- This is the file which is read
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(IN) :: fid
+  INTEGER,INTENT(OUT) ::  nbvar
+  CHARACTER(LEN=*),INTENT(OUT) :: varnames(:)
+!---------------------------------------------------------------------
+  nbvar = nbvar_in(fid)
+!-
+  IF (SIZE(varnames) < nbvar) THEN
+    CALL ipslerr (3,'ioget_vname', &
+      'The provided array for the variable names is too small','','')
+  ELSE
+    varnames(1:nbvar) = varname_in(fid,1:nbvar)
+  ENDIF
+!-------------------------
+END SUBROUTINE ioget_vname
+!===
+SUBROUTINE ioconf_expval (new_exp_val)
+!---------------------------------------------------------------------
+!- The default value written into the variables which are not
+!- in the restart file can only be changed once.
+!- This avoids further complications.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  REAL :: new_exp_val
+!---------------------------------------------------------------------
+  IF (.NOT.lock_valexp) THEN
+    lock_valexp = .TRUE.
+    val_exp = new_exp_val
+  ELSE
+    CALL ipslerr (2,'ioconf_expval', &
+     'The default value for variable' &
+   //'not available in the restart file ', &
+     'has already been locked and can not be changed at this point', &
+     ' ')
+  ENDIF
+!---------------------------
+END SUBROUTINE ioconf_expval
+!===
+SUBROUTINE ioget_expval (get_exp_val)
+!---------------------------------------------------------------------
+!- Once the user has extracted the default value,
+!- we lock it so that it can not be changed anymore.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  REAL :: get_exp_val
+!---------------------------------------------------------------------
+  get_exp_val = val_exp
+  lock_valexp = .TRUE.
+!--------------------------
+END SUBROUTINE ioget_expval
+!===
+SUBROUTINE restclo (fid)
+!---------------------------------------------------------------------
+!- This subroutine closes one or any opened restart file.
+!-
+!- INPUT
+!-
+!- fid    : File ID in the restcom system (not the netCDF ID)(optional)
+!-
+!- OUTPUT
+!-
+!- NONE
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(in),OPTIONAL :: fid
+!-
+  INTEGER :: iret,ifnc
+  CHARACTER(LEN=6) :: n_e
+  CHARACTER(LEN=3) :: n_f
+  LOGICAL :: l_dbg
+!---------------------------------------------------------------------
+  CALL ipsldbg (old_status=l_dbg)
+!-
+  IF (PRESENT(fid)) THEN
+!---
+    IF (l_dbg) THEN
+      WRITE(ipslout,*) &
+        'restclo : Closing specified restart file number :', &
+        fid,netcdf_id(fid,1:2),netcdf_name(fid,1:2)
+    ENDIF
+!---
+    IF (netcdf_id(fid,1) > 0) THEN
+      iret = NF90_CLOSE(netcdf_id(fid,1))
+      IF (iret /= NF90_NOERR) THEN
+        WRITE (n_e,'(I6)') iret
+        WRITE (n_f,'(I3)') netcdf_id(fid,1)
+        CALL ipslerr (2,'restclo', &
+          "Error "//n_e//" in closing file : "//n_f,netcdf_name(fid,1),' ')
+      ENDIF
+      IF (netcdf_id(fid,1) == netcdf_id(fid,2)) THEN
+        netcdf_id(fid,2) = -1
+        netcdf_name(fid,2) = 'NONE'
+      ENDIF
+      netcdf_id(fid,1) = -1
+      netcdf_name(fid,1) = 'NONE'
+    ENDIF
+!---
+    IF (netcdf_id(fid,2) > 0)  THEN
+      iret = NF90_CLOSE(netcdf_id(fid,2))
+      IF (iret /= NF90_NOERR) THEN
+        WRITE (n_e,'(I6)') iret
+        WRITE (n_f,'(I3)') netcdf_id(fid,2)
+        CALL ipslerr (2,'restclo', &
+          "Error "//n_e//" in closing file : "//n_f,netcdf_name(fid,2),' ')
+      ENDIF
+      netcdf_id(fid,2) = -1
+      netcdf_name(fid,2) = 'NONE'
+    ENDIF
+!---
+  ELSE
+!---
+    IF (l_dbg) WRITE(ipslout,*) 'restclo : Closing all files'
+!---
+    DO ifnc=1,nb_fi
+      IF (netcdf_id(ifnc,1) > 0) THEN
+        iret = NF90_CLOSE(netcdf_id(ifnc,1))
+        IF (iret /= NF90_NOERR) THEN
+          WRITE (n_e,'(I6)') iret
+          WRITE (n_f,'(I3)') netcdf_id(ifnc,1)
+          CALL ipslerr (2,'restclo', &
+            "Error "//n_e//" in closing file : "//n_f,netcdf_name(ifnc,1),' ')
+        ENDIF
+        IF (l_dbg) THEN
+           WRITE(ipslout,*) &
+                'restclo : Closing specified restart file number :', &
+                ifnc,netcdf_id(ifnc,1:2),netcdf_name(ifnc,1:2)
+        ENDIF
+        IF (netcdf_id(ifnc,1) == netcdf_id(ifnc,2)) THEN
+          netcdf_id(ifnc,2) = -1
+          netcdf_name(ifnc,2) = 'NONE'
+        ENDIF
+        netcdf_id(ifnc,1) = -1
+        netcdf_name(ifnc,1) = 'NONE'
+      ENDIF
+!-----
+      IF (netcdf_id(ifnc,2) > 0) THEN
+        iret = NF90_CLOSE(netcdf_id(ifnc,2))
+        IF (iret /= NF90_NOERR) THEN
+          WRITE (n_e,'(I6)') iret
+          WRITE (n_f,'(I3)') netcdf_id(ifnc,2)
+          CALL ipslerr (2,'restclo', &
+            "Error "//n_e//" in closing file : "//n_f,netcdf_name(ifnc,2),' ')
+        END IF
+        IF (l_dbg) THEN
+           WRITE(ipslout,*) &
+                'restclo : Closing specified restart file number :', &
+                ifnc,netcdf_id(ifnc,1:2),netcdf_name(ifnc,1:2)
+        END IF
+        netcdf_id(ifnc,2) = -1
+        netcdf_name(ifnc,2) = 'NONE'
+      ENDIF
+    ENDDO
+  ENDIF
+!---------------------
+END SUBROUTINE restclo
+!===
+!-----------------
+END MODULE restcom
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/stringop.f90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/stringop.f90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/IOIPSL/stringop.f90	(revision 17)
@@ -0,0 +1,185 @@
+MODULE stringop
+!-
+!$Id: stringop.f90 936 2010-03-04 11:01:32Z bellier $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+CONTAINS
+!=
+SUBROUTINE cmpblank (str)
+!---------------------------------------------------------------------
+!- Compact blanks
+!---------------------------------------------------------------------
+  CHARACTER(LEN=*),INTENT(inout) :: str
+!-
+  INTEGER :: lcc,ipb
+!---------------------------------------------------------------------
+  lcc = LEN_TRIM(str)
+  ipb = 1
+  DO
+    IF (ipb >= lcc)   EXIT
+    IF (str(ipb:ipb+1) == '  ') THEN
+      str(ipb+1:) = str(ipb+2:lcc)
+      lcc = lcc-1
+    ELSE
+      ipb = ipb+1
+    ENDIF
+  ENDDO
+!----------------------
+END SUBROUTINE cmpblank
+!===
+INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r)
+!---------------------------------------------------------------------
+!- Finds number of occurences of c_r in c_c
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(in) :: c_c
+  INTEGER,INTENT(IN) :: l_c
+  CHARACTER(LEN=*),INTENT(in) :: c_r
+  INTEGER,INTENT(IN) :: l_r
+!-
+  INTEGER :: ipos,indx
+!---------------------------------------------------------------------
+  cntpos = 0
+  ipos   = 1
+  DO
+    indx = INDEX(c_c(ipos:l_c),c_r(1:l_r))
+    IF (indx > 0) THEN
+      cntpos = cntpos+1
+      ipos   = ipos+indx+l_r-1
+    ELSE
+      EXIT
+    ENDIF
+  ENDDO
+!------------------
+END FUNCTION cntpos
+!===
+INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r)
+!---------------------------------------------------------------------
+!- Finds position of c_r in c_c
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(in) :: c_c
+  INTEGER,INTENT(IN) :: l_c
+  CHARACTER(LEN=*),INTENT(in) :: c_r
+  INTEGER,INTENT(IN) :: l_r
+!---------------------------------------------------------------------
+  findpos = INDEX(c_c(1:l_c),c_r(1:l_r))
+  IF (findpos == 0)  findpos=-1
+!-------------------
+END FUNCTION findpos
+!===
+SUBROUTINE find_str (str_tab,str,pos)
+!---------------------------------------------------------------------
+!- This subroutine looks for a string in a table
+!---------------------------------------------------------------------
+!- INPUT
+!-   str_tab  : Table  of strings
+!-   str      : Target we are looking for
+!- OUTPUT
+!-   pos      : -1 if str not found, else value in the table
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab
+  CHARACTER(LEN=*),INTENT(in) :: str
+  INTEGER,INTENT(out) :: pos
+!-
+  INTEGER :: nb_str,i
+!---------------------------------------------------------------------
+  pos = -1
+  nb_str=SIZE(str_tab)
+  IF ( nb_str > 0 ) THEN
+    DO i=1,nb_str
+      IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN
+        pos = i
+        EXIT
+      ENDIF
+    ENDDO
+  ENDIF
+!----------------------
+END SUBROUTINE find_str
+!===
+SUBROUTINE nocomma (str)
+!---------------------------------------------------------------------
+!- Replace commas with blanks
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  DO i=1,LEN_TRIM(str)
+    IF (str(i:i) == ',')   str(i:i) = ' '
+  ENDDO
+!---------------------
+END SUBROUTINE nocomma
+!===
+SUBROUTINE strlowercase (str)
+!---------------------------------------------------------------------
+!- Converts a string into lowercase
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+!-
+  INTEGER :: i,ic
+!---------------------------------------------------------------------
+  DO i=1,LEN_TRIM(str)
+    ic = IACHAR(str(i:i))
+    IF ( (ic >= 65).AND.(ic <= 90) )  str(i:i) = ACHAR(ic+32)
+  ENDDO
+!--------------------------
+END SUBROUTINE strlowercase
+!===
+SUBROUTINE struppercase (str)
+!---------------------------------------------------------------------
+!- Converts a string into uppercase
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+!-
+  INTEGER :: i,ic
+!---------------------------------------------------------------------
+  DO i=1,LEN_TRIM(str)
+    ic = IACHAR(str(i:i))
+    IF ( (ic >= 97).AND.(ic <= 122) )  str(i:i) = ACHAR(ic-32)
+  ENDDO
+!--------------------------
+END SUBROUTINE struppercase
+!===
+SUBROUTINE str_xfw (c_string,c_word,l_ok)
+!---------------------------------------------------------------------
+!- Given a character string "c_string", of arbitrary length,
+!- returns a logical flag "l_ok" if a word is found in it,
+!- the first word "c_word" if found and the new string "c_string"
+!- without the first word "c_word"
+!---------------------------------------------------------------------
+  CHARACTER(LEN=*),INTENT(INOUT) :: c_string
+  CHARACTER(LEN=*),INTENT(OUT) :: c_word
+  LOGICAL,INTENT(OUT) :: l_ok
+!-
+  INTEGER :: i_b,i_e
+!---------------------------------------------------------------------
+  l_ok = (LEN_TRIM(c_string) > 0)
+  IF (l_ok) THEN
+    i_b = VERIFY(c_string,' ')
+    i_e = INDEX(c_string(i_b:),' ')
+    IF (i_e == 0) THEN
+      c_word = c_string(i_b:)
+      c_string = ""
+    ELSE
+      c_word = c_string(i_b:i_b+i_e-2)
+      c_string = ADJUSTL(c_string(i_b+i_e-1:))
+    ENDIF
+  ENDIF
+!---------------------
+END SUBROUTINE str_xfw
+!===
+!------------------
+END MODULE stringop
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/Makefile	(revision 17)
@@ -0,0 +1,939 @@
+SFC             =       gfortran
+SCC             =       gcc
+CCOMP           =       gcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =        $(SFC)
+CC              =       $(SCC) -DFSEEKO64_OK
+LD              =       $(FC)
+RWORDSIZE       =       $(NATIVE_RWORDSIZE)
+PROMOTION       =       # -fdefault-real-8  # uncomment manually
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -w -O3 -c -DLANDREAD_STUB
+LDFLAGS_LOCAL   =
+CPLUSPLUSLIB    =
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3 -ftree-vectorize -ftree-loop-linear -funroll-loops 
+FCREDUCEDOPT    =       $(FCOPTIM)
+FCNOOPT         =       -O0
+FCDEBUG         =       -g $(FCNOOPT) -fbacktrace -Wall -fbounds-check
+FORMAT_FIXED    =       -ffixed-form
+FORMAT_FREE     =       -ffree-form -ffree-line-length-none
+FCSUFFIX        =
+BYTESWAPIO      =       -fconvert=big-endian -frecord-marker=4
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -G
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC)
+
+.SUFFIXES: 
+.SUFFIXES: .F90 .f90 .o .mod 
+
+ARCHFLAGS       =    $(COREDEFS) -DIWORDSIZE=$(IWORDSIZE) -DDWORDSIZE=$(DWORDSIZE) -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=$(LWORDSIZE) \
+                     $(ARCH_LOCAL) \
+                     $(DA_ARCHFLAGS) \
+                      -DDM_PARALLEL \
+                      -DSTUBMPI \
+                      -DNETCDF \
+                      -DLMDZ \
+                      -DCPP_IOIPSL \
+                      -DhistNMC \
+                       \
+                       \
+                       \
+                       \
+                      -DUSE_ALLOCATABLES \
+                      -DGRIB1 \
+                      -DINTIO \
+                      -DLIMIT_ARGS \
+                      -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) \
+                      -DMAX_DOMAINS_F=$(MAX_DOMAINS) \
+                      -DMAX_HISTORY=$(MAX_HISTORY) \
+                      -DNMM_NEST=$(WRF_NMM_NEST)
+
+FCLMDZFLAGS         =    $(FCOPTIM) $(FCBASEOPTS) -c
+
+NETCDFPATH      =    ${HOME}/bin/gcc_netcdf-4.3.0
+
+LIB_NETCDF    = -L${NETCDFPATH}/lib  -lnetcdf -lnetcdff 
+INC_NETCDF    = -I$(NETCDFPATH)/include
+
+WRFcode = ../tools/standard.exe
+
+#### end from configure.wrf
+
+
+LN      =       ln -sf
+MAKE    =       make -i -r
+RM      =       rm -f
+
+DIRECTLMDZOBJS = \
+		aero_mod.o \
+		albsno.o \
+		indice_sol_mod.o \
+		mod_grid_phy_lmdz.o \
+		ioipsl_errioipsl.o \
+		ioipsl_stringop.o \
+		dimphy.o \
+		phys_output_var_mod.o \
+		misc_mod.o \
+		vampir.o \
+		surface_data.o \
+		control_mod.o \
+		mod_const_mpi.o \
+		calbeta_clim.o \
+		comcstphy.o \
+		assert_m.o \
+		assert_eq_m.o \
+		interpolation.o \
+		coefcdrag.o \
+		screenp.o \
+		screenc.o \
+		iniorbit.o \
+		orbite.o \
+		orbite_mod.o \
+		clouds_gno.o \
+		ini_wake.o \
+		radiation_ar4_param.o \
+		evappot.o \
+		q_sat.o \
+		pres2lev_mod.o \
+		cv_routines.o \
+		cv30_routines.o \
+		cv3_routines.o \
+		cv3_mixscale.o \
+		cv3_vertmix.o \
+		cv3a_compress.o \
+		cv3a_uncompress.o \
+		cv3p_mixing.o \
+		cv3_buoy.o \
+		cv3_cine.o \
+		suphel.o \
+		zilch.o \
+		aeropt.o \
+		cv3_inip.o \
+		printflag.o \
+		iniradia.o \
+		cloudth.o \
+		thermcell_height.o \
+		thermcell_flux2.o \
+		thermcell_dq.o \
+		thermcell_dv2.o \
+		thermcell_qsat.o \
+		thermcell_plume.o \
+		thermcell_condens.o \
+		thermcell_dry.o \
+		thermcell_closure.o \
+		wrgrads.o \
+		formcoord.o \
+		gr_fi_dyn.o \
+		NOread_limit_sub_variables.o \
+		output_lmdz_NOmodule.o \
+		cray.o
+
+MODULES = \
+		comgeomphy.o \
+		open_climoz_m.o \
+		netcdf95.o \
+		mod_phys_lmdz_para.o \
+		mod_phys_lmdz_transfert_para.o \
+                mod_phys_lmdz_mpi_transfert.o \
+		mod_phys_lmdz_mpi_data.o \
+                mod_phys_lmdz_omp_transfert.o \
+		mod_phys_lmdz_omp_data.o \
+		phys_cal_mod.o \
+		regr_pr_av_m.o \
+		ozonecm_m.o \
+		regr1_step_av_m.o \
+		conf_phys_m.o \
+		radlwsw_m.o \
+		sw_aeroAR4.o \
+		write_field.o \
+		write_field_phy.o \
+		infotrac.o \
+		iophy.o \
+		clcdrag.o \
+		stdlevvar.o \
+		hbtm.o \
+		yamada_c.o \
+		pbl_surface_mod.o \
+		read_map2D.o \
+		carbon_cycle_mod.o \
+		surf_land_mod.o \
+		albedo.o \
+		surf_land_orchidee_noopenmp_mod.o \
+		cpl_mod.o \
+		atm2geo.o \
+		geo2atm.o \
+		oasis.o \
+		phys_state_var_mod.o \
+		surf_land_orchidee_mod.o \
+		mod_surf_para.o \
+		mod_synchro_omp.o \
+		surf_land_bucket_mod.o \
+		limit_read_mod.o \
+		fonte_neige_mod.o \
+		calcul_fluxs_mod.o \
+		calbeta.o \
+		soil.o \
+		surf_landice_mod.o \
+		surf_ocean_mod.o \
+		limit_slab.o \
+		ocean_forced_mod.o \
+		ocean_slab_mod.o \
+		ocean_cpl_mod.o \
+		surf_seaice_mod.o \
+		climb_hq_mod.o \
+		climb_wind_mod.o \
+		ustarhb.o \
+		vdif_kcay.o \
+		yamada.o \
+		yamada4.o \
+		coefkzmin.o \
+		coef_diff_turb_mod.o \
+		change_srf_frac_mod.o \
+		phys_local_var_mod.o \
+		phys_output_mod.o \
+		phys_output_ctrlout_mod.o \
+		cfmip_point_locations.o \
+		ioipsl_getincom.o \
+		abort_gcm.o \
+		plevel_new.o \
+		plevel.o \
+		orografi.o \
+		orografi_mod.o \
+		orografi_strato_mod.o \
+		nuage.o \
+		nuage_mod.o \
+		conflx.o \
+		radiation_AR4_mod.o \
+		add_phys_tend.o \
+		print_debug_phys.o \
+		hgardfou.o \
+		solarlong.o \
+		phyaqua.o \
+		phyaqua_mod.o \
+		concvl.o \
+		ajsec.o \
+		aaam_bud.o \
+		diagphy.o \
+		diagphy_mod.o \
+		readaerosolstrato.o \
+		mkstat.o \
+		readaerosol_optic.o \
+		aeropt_2bands.o \
+		aeropt_5wv.o \
+		readaerosol_interp.o \
+		readaerosol.o \
+		cva_driver.o \
+		cv_driver.o \
+		cv3p1_closure.o \
+		traclmdz_mod.o \
+		cltracrn.o \
+		radio_decay.o \
+		minmaxqfi.o \
+		initrrnpb.o \
+		init_be.o \
+		o3_chem_m.o \
+		regr_pr_comb_coefoz_m.o \
+		regr_pr_int_m.o \
+		regr1_lint_m.o \
+		press_coefoz_m.o \
+		iostart.o \
+		wstats.o \
+		inistats.o \
+		phyredem.o \
+		hines_gwd.o \
+		ini_undefSTD.o \
+		moy_undefSTD.o \
+		phyetat0.o \
+		transp.o \
+		undefSTD.o \
+		calwake.o \
+		wake.o \
+		newmicro.o \
+		calltherm.o \
+		thermcell_old.o \
+		wrgradsfi.o \
+		thermcell.o \
+		thermcellV0_main.o \
+		thermcell_env.o \
+		thermcell_main.o \
+		fisrtilp.o \
+		stratocu_if.o \
+		phystokenc.o \
+		initphysto.o \
+		ener_conserv.o \
+		tracinca_mod.o \
+		tracreprobus_mod.o \
+		cvltrorig.o \
+		cvltr.o \
+		nflxtr.o \
+		lsc_scav.o \
+		cltrac.o \
+		calcratqs.o \
+		iniphysiq.o \
+		conf_gcm.o \
+		init_phys_lmdz.o \
+		moyglo_aire.o \
+		global_mean.o \
+		wrf_lmdz_mod.o \
+		physiq_limit_variables_mod.o \
+		lmdz_wrf_variables_mod.o \
+		phytrac.o 
+
+DIRECTLMDZSRC = $(DIRECTLMDZOBJS:.o=.F90)
+LMDZSOURCES = $(MODULES:.o=.F90)
+LMDZPRE = $(MODULES:.o=.bb)
+LMDZPOST = $(MODULES:.o=.f90)
+LMDZMOD = $(MODULES:.o=.mod)
+
+NETCDF95OBJS = \
+		nf95_def_var_m.o \
+		nf95_put_var_m.o \
+		nf95_get_var_m.o \
+		nf95_gw_var_m.o \
+		nf95_put_att_m.o \
+		nf95_get_att_m.o \
+		simple.o \
+		handle_err_m.o
+
+NETCDF95SOURCES = $(NETCDF95OBJS:.o=.F90)
+NETCDF95PRE = $(NETCDF95OBJS:.o=.bb)
+NETCDF95POST = $(NETCDF95OBJS:.o=.f90)
+
+OBJS    = physiq.o 
+
+NMM_MODULES =  
+
+LIBTARGET    =  lmdz
+TARGETDIR    =  ./
+
+DIRECTIOIPSLMOD =	\
+        defprec.o \
+	errioipsl.o \
+	stringop.o \
+
+DEPIOIPSLMOD = 	\
+	mathelp.o \
+	getincom.o \
+	calendar.o \
+	fliocom.o \
+	flincom.o \
+	histcom.o \
+	restcom.o \
+	ioipsl.o 
+
+DIRECTIOIPSLSRC = $(DIRECTIOIPSLMOD:.o=.f90)
+
+IOIPSLFOLD = ./IOIPSL
+FULLIOIPSLMODS = $(addprefix $(IOIPSLFOLD)/,$(IOIPSLMOD))
+
+##include ../configure.wrf
+
+all : preprocess lmdz.a 
+
+lmdz.a:		$(MODULES) $(OBJS) $(DIRECTLMDZOBJS) $(DIRECTIOIPSLMOD) $(DEPIOIPSLMOD) $(NETCDF95OBJS)
+		/bin/rm -f lmdz.a
+		$(AR) cr lmdz.a $(MODULES) $(OBJS) $(DIRECTLMDZOBJS) $(DIRECTIOIPSLMOD) $(DEPIOIPSLMOD) $(NETCDF95OBJS)
+
+# IOIPSL
+ 
+$(DIRECTIOIPSLMOD): 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,$(DIRECTIOIPSLSRC))
+
+calendar.o: stringop.o errioipsl.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,calendar.f90)
+
+getincom.o: stringop.o errioipsl.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,getincom.f90)
+
+mathelp.o: stringop.o errioipsl.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,mathelp.f90)
+
+flincom.o: stringop.o errioipsl.o calendar.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,flincom.f90)
+
+fliocom.o: stringop.o errioipsl.o calendar.o defprec.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,fliocom.f90)
+
+histcom.o: stringop.o errioipsl.o calendar.o mathelp.o fliocom.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,histcom.f90)
+
+restcom.o: stringop.o errioipsl.o calendar.o mathelp.o fliocom.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,restcom.f90)
+
+ioipsl.o: $(DIRECTIOIPSLMOD) getincom.o calendar.o mathelp.o flincom.o fliocom.o histcom.o restcom.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,ioipsl.f90)
+
+# LMDZ
+#
+preprocess: $(LMDZPOST) $(NETCDF95POST)
+
+$(LMDZPOST): %.f90: %.bb
+		$(WRFcode) $< | $(CPP) > $@
+		rm $<
+
+$(LMDZPRE): %.bb: %.F90
+		$(CPP) $(ARCHFLAGS) $< > $@
+
+$(NETCDF95POST): %.f90: %.bb
+		$(WRFcode) $< | $(CPP) > $@
+		rm $<
+
+$(NETCDF95PRE): %.bb: %.F90
+		$(CPP) $(ARCHFLAGS) $< > $@
+
+$(DIRECTLMDZOBJS): 
+		$(FC) $(FCLMDZFLAGS) $(DIRECTLMDZSRC)
+
+infotrac.o: control_mod.o
+		$(FC) $(FCLMDZFLAGS) infotrac.f90
+
+
+mod_phys_lmdz_mpi_data.o: mod_const_mpi.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_mpi_data.f90
+
+ioipsl_getincom.o: ioipsl_errioipsl.o ioipsl_stringop.o
+		$(FC) $(FCLMDZFLAGS) ioipsl_getincom.f90
+
+abort_gcm.o: ioipsl.o ioipsl_getincom.o
+		$(FC) $(FCLMDZFLAGS) abort_gcm.f90
+
+write_field.o: 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) write_field.f90
+
+mod_phys_lmdz_omp_data.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_omp_data.f90
+
+mod_phys_lmdz_omp_transfert.o: mod_phys_lmdz_mpi_data.o mod_phys_lmdz_omp_data.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_omp_transfert.f90
+
+mod_phys_lmdz_mpi_transfert.o: mod_phys_lmdz_mpi_data.o mod_grid_phy_lmdz.o  mod_phys_lmdz_omp_transfert.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_mpi_transfert.f90
+
+mod_phys_lmdz_transfert_para.o: mod_phys_lmdz_mpi_transfert.o mod_phys_lmdz_omp_transfert.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_transfert_para.f90
+
+mod_phys_lmdz_para.o: mod_phys_lmdz_transfert_para.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_omp_data.o mod_grid_phy_lmdz.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_para.f90
+
+comgeomphy.o: mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) comgeomphy.f90
+
+handle_err_m.o: 
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) handle_err_m.f90
+
+nf95_def_var_m.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_def_var_m.f90
+
+nf95_put_var_m.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_put_var_m.f90
+
+nf95_get_var_m.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_get_var_m.f90
+
+simple.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) simple.f90
+
+nf95_gw_var_m.o: handle_err_m.o simple.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_gw_var_m.f90
+
+nf95_put_att_m.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_put_att_m.f90
+
+nf95_get_att_m.o: handle_err_m.o simple.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_get_att_m.f90
+
+netcdf95.o: $(NETCDF95OBJS) 
+		$(FC) $(FCLMDZFLAGS) netcdf95.f90
+
+open_climoz_m.o: mod_phys_lmdz_mpi_data.o mod_phys_lmdz_mpi_transfert.o netcdf95.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) open_climoz_m.f90
+
+regr1_step_av_m.o: assert_eq_m.o assert_m.o interpolation.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) regr1_step_av_m.f90
+
+regr_pr_av_m.o: dimphy.o netcdf95.o assert_m.o assert_eq_m.o regr1_step_av_m.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_transfert_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) regr_pr_av_m.f90
+
+ozonecm_m.o: dimphy.o assert_m.o
+		$(FC) $(FCLMDZFLAGS) ozonecm_m.f90
+
+conf_phys_m.o: ioipsl.o surface_data.o phys_cal_mod.o carbon_cycle_mod.o control_mod.o
+		$(FC) $(FCLMDZFLAGS) conf_phys_m.f90
+
+radiation_AR4_mod.o: dimphy.o radiation_ar4_param.o
+		$(FC) $(FCLMDZFLAGS) radiation_AR4_mod.f90	
+
+sw_aeroAR4.o: dimphy.o phys_output_mod.o radiation_AR4_mod.o
+		$(FC) $(FCLMDZFLAGS) sw_aeroAR4.f90	
+
+radlwsw_m.o: dimphy.o assert_m.o infotrac.o radiation_AR4_mod.o sw_aeroAR4.o
+		$(FC) $(FCLMDZFLAGS) radlwsw_m.f90
+
+phys_cal_mod.o: ioipsl.o
+		$(FC) $(FCLMDZFLAGS) phys_cal_mod.f90
+
+write_field_phy.o: write_field.o
+		$(FC) $(FCLMDZFLAGS) write_field_phy.f90
+
+iophy.o: ioipsl.o phys_output_var_mod.o write_field.o
+		$(FC) $(FCLMDZFLAGS) iophy.f90
+
+read_map2D.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) read_map2D.f90
+
+carbon_cycle_mod.o: dimphy.o comgeomphy.o mod_phys_lmdz_transfert_para.o infotrac.o ioipsl.o surface_data.o phys_cal_mod.o indice_sol_mod.o read_map2D.o
+		$(FC) $(FCLMDZFLAGS) carbon_cycle_mod.f90
+
+oasis.o:
+ifeq ($(ARCHFLAGS), -DCPP_COUPLE)
+oasis.o: dimphy.o mod_phys_lmdz_para.o write_field_phy.o mod_prism_proto.o mod_prism_def_partition_proto.o mod_prism_get_proto.o mod_prism_put_proto.o ioipsl.o surface_data.o carbon_cycle_mod.o
+		$(FC) $(FCLMDZFLAGS) oasis.f90
+else
+oasis.o: dimphy.o mod_phys_lmdz_para.o write_field_phy.o ioipsl.o surface_data.o carbon_cycle_mod.o
+		$(FC) $(FCLMDZFLAGS) oasis.f90
+endif
+
+phys_state_var_mod.o: dimphy.o control_mod.o aero_mod.o infotrac.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) phys_state_var_mod.f90
+
+atm2geo.o: dimphy.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) atm2geo.f90
+
+geo2atm.o: dimphy.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) geo2atm.f90
+
+cpl_mod.o: dimphy.o mod_phys_lmdz_para.o ioipsl.o iophy.o oasis.o write_field_phy.o control_mod.o carbon_cycle_mod.o surface_data.o indice_sol_mod.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) cpl_mod.f90
+
+surf_land_orchidee_noopenmp_mod.o:
+ifeq ($(ARCHFLAGS), -DORCHIDEE_NOOPENMP)
+intersurf.o: 
+		$(FC) $(FCLMDZFLAGS) intersurf.f90
+
+surf_land_orchidee_noopenmp_mod.o: dimphy.o intersurf.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_noopenmp_mod.f90
+else
+surf_land_orchidee_noopenmp_mod.o: dimphy.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_noopenmp_mod.f90
+endif
+ifeq ($(ARCHFLAGS), -DCPP_VEGET)
+intersurf.o: 
+		$(FC) $(FCLMDZFLAGS) intersurf.f90
+
+surf_land_orchidee_noopenmp_mod.o: dimphy.o intersurf.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o carbon_cycle_mod.o indice_sol_mod.o
+		rm surf_land_orchidee_noopenmp_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_noopenmp_mod.f90
+else
+surf_land_orchidee_noopenmp_mod.o: dimphy.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_noopenmp_mod.f90
+endif
+
+mod_surf_para.o: mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) mod_surf_para.f90
+
+mod_synchro_omp.o: mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) mod_synchro_omp.f90
+
+surf_land_orchidee_mod.o: 
+ifeq ($(ARCHFLAGS), -DORCHIDEE_NOOPENMP)
+intersurf.o: 
+		$(FC) $(FCLMDZFLAGS) intersurf.f90
+
+surf_land_orchidee_mod.o: dimphy.o intersurf.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o mod_surf_para.o mod_synchro_omp.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_mod.f90
+else
+surf_land_orchidee_mod.o: dimphy.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o mod_surf_para.o mod_synchro_omp.o carbon_cycle_mod.o indice_sol_mod.o
+endif
+ifeq ($(ARCHFLAGS), -DCPP_VEGET)
+intersurf.o: 
+		$(FC) $(FCLMDZFLAGS) intersurf.f90
+
+surf_land_orchidee_mod.o: dimphy.o intersurf.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o mod_surf_para.o mod_synchro_omp.o carbon_cycle_mod.o indice_sol_mod.o
+		rm surf_land_orchidee_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_mod.f90
+else
+surf_land_orchidee_mod.o: dimphy.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o mod_surf_para.o mod_synchro_omp.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_mod.f90
+endif
+
+limit_read_mod.o: dimphy.o indice_sol_mod.o surface_data.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) limit_read_mod.f90
+
+phys_local_var_mod.o: dimphy.o infotrac.o aero_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) phys_local_var_mod.f90
+
+calbeta.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) calbeta.f90
+
+soil.o: dimphy.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) soil.f90
+
+calcul_fluxs_mod.o: dimphy.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) calcul_fluxs_mod.f90
+
+fonte_neige_mod.o: dimphy.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) fonte_neige_mod.f90
+
+limit_slab.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) limit_slab.f90
+
+surf_land_bucket_mod.o: limit_read_mod.o surface_data.o fonte_neige_mod.o calcul_fluxs_mod.o cpl_mod.o dimphy.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o indice_sol_mod.o albsno.o calbeta_clim.o calbeta.o soil.o NOread_limit_sub_variables.o
+		$(FC) $(FCLMDZFLAGS) surf_land_bucket_mod.f90
+
+surf_land_mod.o: dimphy.o surface_data.o surf_land_orchidee_noopenmp_mod.o surf_land_orchidee_mod.o surf_land_bucket_mod.o calcul_fluxs_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_mod.f90
+
+surf_landice_mod.o: dimphy.o surface_data.o fonte_neige_mod.o cpl_mod.o calcul_fluxs_mod.o phys_output_var_mod.o indice_sol_mod.o albsno.o soil.o
+		$(FC) $(FCLMDZFLAGS) surf_landice_mod.f90
+
+ocean_forced_mod.o: dimphy.o calcul_fluxs_mod.o limit_read_mod.o indice_sol_mod.o surface_data.o fonte_neige_mod.o calbeta.o soil.o albsno.o NOread_limit_sub_variables.o
+		$(FC) $(FCLMDZFLAGS) ocean_forced_mod.f90
+
+ocean_slab_mod.o: dimphy.o limit_read_mod.o surface_data.o indice_sol_mod.o calcul_fluxs_mod.o limit_slab.o
+		$(FC) $(FCLMDZFLAGS) ocean_slab_mod.f90
+
+ocean_cpl_mod.o: dimphy.o cpl_mod.o calcul_fluxs_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) ocean_cpl_mod.f90
+
+albedo.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) albedo.f90
+
+surf_ocean_mod.o: dimphy.o surface_data.o ocean_forced_mod.o ocean_slab_mod.o ocean_cpl_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_ocean_mod.f90
+
+surf_seaice_mod.o: dimphy.o surface_data.o ocean_forced_mod.o ocean_cpl_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_seaice_mod.f90
+
+climb_hq_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) climb_hq_mod.f90
+
+climb_wind_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) climb_wind_mod.f90
+
+yamada4.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) yamada4.f90
+
+yamada.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) yamada.f90
+
+vdif_kcay.o: dimphy.o yamada.o
+		$(FC) $(FCLMDZFLAGS) vdif_kcay.f90
+
+ustarhb.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) ustarhb.f90
+
+coefkzmin.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) coefkzmin.f90
+
+coef_diff_turb_mod.o: dimphy.o indice_sol_mod.o yamada4.o vdif_kcay.o ustarhb.o coefkzmin.o
+		$(FC) $(FCLMDZFLAGS) coef_diff_turb_mod.f90
+
+stdlevvar.o: coefcdrag.o screenp.o screenc.o
+		$(FC) $(FCLMDZFLAGS) stdlevvar.f90
+
+clcdrag.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) clcdrag.f90
+
+hbtm.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) hbtm.f90
+
+yamada_c.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) yamada_c.f90
+
+pbl_surface_mod.o: dimphy.o mod_phys_lmdz_para.o ioipsl.o surface_data.o surf_land_mod.o surf_landice_mod.o surf_ocean_mod.o surf_seaice_mod.o cpl_mod.o climb_hq_mod.o climb_wind_mod.o coef_diff_turb_mod.o control_mod.o indice_sol_mod.o carbon_cycle_mod.o clcdrag.o stdlevvar.o hbtm.o yamada_c.o
+		$(FC) $(FCLMDZFLAGS) pbl_surface_mod.f90
+
+change_srf_frac_mod.o: dimphy.o surface_data.o limit_read_mod.o pbl_surface_mod.o cpl_mod.o ocean_slab_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) change_srf_frac_mod.f90
+
+phys_output_mod.o: indice_sol_mod.o phys_output_var_mod.o phys_output_ctrlout_mod.o aero_mod.o iophy.o dimphy.o infotrac.o ioipsl.o phys_cal_mod.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) phys_output_mod.f90
+
+phys_output_ctrlout_mod.o: phys_output_var_mod.o indice_sol_mod.o aero_mod.o
+		$(FC) $(FCLMDZFLAGS) phys_output_ctrlout_mod.f90
+
+cfmip_point_locations.o: dimphy.o iophy.o mod_grid_phy_lmdz.o
+		$(FC) $(FCLMDZFLAGS) cfmip_point_locations.f90
+
+mkstat.o: 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) mkstat.f90
+
+plevel_new.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) plevel_new.f90
+
+plevel.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) plevel.f90
+
+orografi_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) orografi_mod.f90
+
+orografi.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) orografi.f90
+
+orografi_strato_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) orografi_strato_mod.f90
+
+orografi_strato.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) orografi_strato.f90
+
+nuage_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) nuage_mod.f90
+
+nuage.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) nuage.f90
+
+conflx.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) conflx.f90
+
+hgardfou.o: dimphy.o phys_state_var_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) hgardfou.f90
+
+print_debug_phys.o: dimphy.o phys_state_var_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) print_debug_phys.f90
+
+add_phys_tend.o: dimphy.o phys_local_var_mod.o phys_state_var_mod.o print_debug_phys.o hgardfou.o
+		$(FC) $(FCLMDZFLAGS) add_phys_tend.f90
+
+solarlong.o: ioipsl.o iniorbit.o
+		$(FC) $(FCLMDZFLAGS) solarlong.f90
+
+phyaqua_mod.o: comgeomphy.o dimphy.o surface_data.o pbl_surface_mod.o fonte_neige_mod.o phys_state_var_mod.o control_mod.o indice_sol_mod.o ioipsl.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) phyaqua_mod.f90
+
+phyaqua.o: comgeomphy.o dimphy.o surface_data.o pbl_surface_mod.o fonte_neige_mod.o phys_state_var_mod.o control_mod.o indice_sol_mod.o ioipsl.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) phyaqua.f90
+
+ajsec.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) ajsec.f90
+
+aaam_bud.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) aaam_bud.f90
+
+diagphy.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) diagphy.f90
+
+diagphy_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) diagphy_mod.f90
+
+readaerosolstrato.o: netcdf95.o phys_cal_mod.o mod_grid_phy_lmdz.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_para.o phys_state_var_mod.o phys_local_var_mod.o aero_mod.o dimphy.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) readaerosolstrato.f90
+
+aeropt_2bands.o: dimphy.o aero_mod.o phys_cal_mod.o pres2lev_mod.o
+		$(FC) $(FCLMDZFLAGS) aeropt_2bands.f90
+
+aeropt_5wv.o: dimphy.o aero_mod.o phys_local_var_mod.o pres2lev_mod.o
+		$(FC) $(FCLMDZFLAGS) aeropt_5wv.f90
+
+readaerosol_mod.o: readaerosol.o
+
+readaerosol.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) readaerosol.f90
+
+readaerosol_interp.o: dimphy.o mod_phys_lmdz_para.o readaerosol_mod.o aero_mod.o write_field_phy.o phys_cal_mod.o pres2lev_mod.o
+		$(FC) $(FCLMDZFLAGS) readaerosol_interp.f90
+
+readaerosol_optic.o: dimphy.o aero_mod.o phys_local_var_mod.o readaerosol_interp.o aeropt.o
+		$(FC) $(FCLMDZFLAGS) readaerosol_optic.f90
+
+cv3p1_closure.o: cv3_cine.o cv3_buoy.o
+		$(FC) $(FCLMDZFLAGS) cv3p1_closure.f90
+
+cv_driver.o: dimphy.o cv_routines.o cv30_routines.o cv3p1_closure.o
+		$(FC) $(FCLMDZFLAGS) cv_driver.f90
+
+cva_driver.o: dimphy.o zilch.o cv_routines.o cv3_routines.o
+		$(FC) $(FCLMDZFLAGS) cva_driver.f90
+
+concvl.o: dimphy.o infotrac.o cv_driver.o cva_driver.o cv3_inip.o
+		$(FC) $(FCLMDZFLAGS) concvl.f90
+
+regr1_lint_m.o: assert_eq_m.o interpolation.o
+		$(FC) $(FCLMDZFLAGS) regr1_lint_m.f90
+
+regr_pr_int_m.o: dimphy.o netcdf95.o assert_m.o regr1_lint_m.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_transfert_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) regr_pr_int_m.f90
+
+regr_pr_comb_coefoz_m.o: dimphy.o netcdf95.o assert_m.o mod_phys_lmdz_mpi_data.o regr_pr_av_m.o regr_pr_int_m.o press_coefoz_m.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) regr_pr_comb_coefoz_m.f90
+
+press_coefoz_m.o: netcdf95.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_mpi_transfert.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) press_coefoz_m.f90
+
+o3_chem_m.o: dimphy.o assert_m.o regr_pr_comb_coefoz_m.o 
+		$(FC) $(FCLMDZFLAGS) o3_chem_m.f90
+
+initrrnpb.o: dimphy.o infotrac.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) initrrnpb.f90
+
+init_be.o: dimphy.o comgeomphy.o infotrac.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) init_be.f90
+
+minmaxqfi.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) minmaxqfi.f90
+
+radio_decay.o: dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) radio_decay.f90
+
+cltracrn.o: dimphy.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) cltracrn.f90
+
+traclmdz_mod.o: dimphy.o infotrac.o regr_pr_comb_coefoz_m.o press_coefoz_m.o carbon_cycle_mod.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o indice_sol_mod.o o3_chem_m.o q_sat.o cltracrn.o minmaxqfi.o initrrnpb.o
+		$(FC) $(FCLMDZFLAGS) traclmdz_mod.f90
+
+inistats.o: 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) inistats.f90
+
+wstats.o: inistats.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) wstats.f90
+
+iostart.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) iostart.f90
+
+wake.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) wake.f90
+
+calwake.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) calwake.f90
+
+hines_gwd.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) hines_gwd.f90
+
+ini_undefSTD.o: dimphy.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) ini_undefSTD.f90
+
+moy_undefSTD.o: dimphy.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) moy_undefSTD.f90
+
+newmicro.o: dimphy.o phys_local_var_mod.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) newmicro.f90
+
+phyetat0.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o iophy.o ocean_cpl_mod.o fonte_neige_mod.o pbl_surface_mod.o surface_data.o phys_state_var_mod.o iostart.o write_field_phy.o infotrac.o traclmdz_mod.o carbon_cycle_mod.o indice_sol_mod.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) phyetat0.f90
+
+transp.o: dimphy.o 
+		$(FC) $(FCLMDZFLAGS) transp.f90
+
+undefSTD.o: dimphy.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) undefSTD.f90
+
+stratocu_if.o: indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) stratocu_if.f90
+
+thermcell.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) thermcell.f90
+
+wrgradsfi.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o wrgrads.o gr_fi_dyn.o 
+		$(FC) $(FCLMDZFLAGS) wrgradsfi.f90
+
+thermcell_old.o: dimphy.o thermcell.o
+		$(FC) $(FCLMDZFLAGS) thermcell_old.f90
+
+thermcell_env.o: thermcell_qsat.o
+		$(FC) $(FCLMDZFLAGS) thermcell_env.f90
+
+thermcellV0_main.o: dimphy.o comgeomphy.o thermcell_env.o thermcell_height.o thermcell_flux2.o thermcell_dq.o thermcell_dv2.o 
+		$(FC) $(FCLMDZFLAGS) thermcellV0_main.f90
+
+thermcell_main.o: dimphy.o comgeomphy.o indice_sol_mod.o thermcell_env.o thermcell_plume.o thermcell_height.o thermcell_dry.o thermcell_closure.o thermcell_flux2.o thermcell_dq.o thermcell_dv2.o  
+		$(FC) $(FCLMDZFLAGS) thermcell_main.f90
+
+calltherm.o: indice_sol_mod.o dimphy.o thermcell_old.o thermcellV0_main.o thermcell_main.o
+		$(FC) $(FCLMDZFLAGS) calltherm.f90
+
+callcratqs.o: clouds_gno.o
+		$(FC) $(FCLMDZFLAGS) callcratqs.f90
+
+fisrtilp.o: dimphy.o cloudth.o
+		$(FC) $(FCLMDZFLAGS) fisrtilp.f90
+
+tracinca_mod.o: dimphy.o infotrac.o vampir.o comgeomphy.o control_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) tracinca_mod.f90
+
+tracreprobus_mod.o: dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) tracreprobus_mod.f90
+
+cvltrorig.o: dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) cvltrorig.f90
+
+cvltr.o: dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) cvltr.f90
+
+nflxtr.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) nflxtr.f90
+
+lsc_scav.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o traclmdz_mod.o infotrac.o comgeomphy.o iophy.o
+		$(FC) $(FCLMDZFLAGS) lsc_scav.f90
+
+cltrac.o: dimphy.o 
+		$(FC) $(FCLMDZFLAGS) cltrac.f90
+
+phytrac.o: phys_cal_mod.o phys_output_mod.o dimphy.o infotrac.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o comgeomphy.o iophy.o traclmdz_mod.o tracinca_mod.o tracreprobus_mod.o control_mod.o indice_sol_mod.o cvltrorig.o cvltr.o nflxtr.o lsc_scav.o cltrac.o
+		$(FC) $(FCLMDZFLAGS) phytrac.f90
+
+initphysto.o: dimphy.o mod_phys_lmdz_para.o ioipsl.o iophy.o control_mod.o indice_sol_mod.o 
+		$(FC) $(FCLMDZFLAGS) initphysto.f90
+
+phystokenc.o: dimphy.o infotrac.o iophy.o control_mod.o indice_sol_mod.o initphysto.o
+		$(FC) $(FCLMDZFLAGS) phystokenc.f90
+
+ener_conserv.o: phys_local_var_mod.o phys_output_var_mod.o
+		$(FC) $(FCLMDZFLAGS) ener_conserv.f90
+
+calcratqs.o: clouds_gno.o
+		$(FC) $(FCLMDZFLAGS) calcratqs.f90
+
+conf_gcm.o: control_mod.o ioipsl.o ioipsl_getincom.o ioipsl.o infotrac.o assert_m.o
+		$(FC) $(FCLMDZFLAGS) conf_gcm.f90
+
+iniphysiq.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o comgeomphy.o suphel.o comcstphy.o phyaqua.o
+		$(FC) $(FCLMDZFLAGS) iniphysiq.f90
+
+init_phys_lmdz.o: mod_phys_lmdz_para.o mod_grid_phy_lmdz.o dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) init_phys_lmdz.f90
+
+moyglo_aire.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) moyglo_aire.f90
+
+global_mean.o: dimphy.o mod_phys_lmdz_para.o mod_phys_lmdz_transfert_para.o mod_phys_lmdz_mpi_data.o
+		$(FC) $(FCLMDZFLAGS) global_mean.f90
+
+phyredem.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o fonte_neige_mod.o pbl_surface_mod.o phys_state_var_mod.o iostart.o traclmdz_mod.o infotrac.o control_mod.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) phyredem.f90
+
+wrf_lmdz_mod.o: ../frame/module_domain_type.o ../share/module_model_constants.o indice_sol_mod.o phys_state_var_mod.o phys_output_var_mod.o output_lmdz_NOmodule.o suphel.o pbl_surface_mod.o phys_local_var_mod.o comgeomphy.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) wrf_lmdz_mod.f90
+
+##module_lmdz_variables.o: pbl_surface_mod.o indice_sol_mod.o fonte_neige_mod.o dimphy.o
+##		$(FC) $(FCLMDZFLAGS) module_lmdz_variables.f90
+
+physiq_limit_variables_mod.o: mod_grid_phy_lmdz.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) physiq_limit_variables_mod.f90
+
+lmdz_wrf_variables_mod.o: mod_grid_phy_lmdz.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) lmdz_wrf_variables_mod.f90
+
+%.o: %.mod
+		@true
+
+physiq.o : $(MODULES) $(DIRECTLMDZOBJS) netcdf95.o ../frame/module_domain.o
+		$(CPP) $(ARCHFLAGS) physiq.F90 > physiq.bb
+		$(WRFcode) physiq.bb | $(CPP) > physiq.f90
+		rm physiq.bb
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) physiq.f90
+
+clean:
+	rm *.f90 *.o *.a *.mod
+	@ echo 'use the clean script'
+
+# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES)
+
+# DO NOT DELETE
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/Makefile.dbg.lmdz
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/Makefile.dbg.lmdz	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/Makefile.dbg.lmdz	(revision 17)
@@ -0,0 +1,939 @@
+SFC             =       gfortran
+SCC             =       gcc
+CCOMP           =       gcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =        $(SFC)
+CC              =       $(SCC) -DFSEEKO64_OK
+LD              =       $(FC)
+RWORDSIZE       =       $(NATIVE_RWORDSIZE)
+PROMOTION       =       # -fdefault-real-8  # uncomment manually
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -w -O3 -c -DLANDREAD_STUB
+LDFLAGS_LOCAL   =
+CPLUSPLUSLIB    =
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3 -ftree-vectorize -ftree-loop-linear -funroll-loops 
+FCREDUCEDOPT    =       $(FCOPTIM)
+FCNOOPT         =       -O0
+FCDEBUG         =       -g $(FCNOOPT) -fbacktrace -Wall -fbounds-check
+FORMAT_FIXED    =       -ffixed-form
+FORMAT_FREE     =       -ffree-form -ffree-line-length-none
+FCSUFFIX        =
+BYTESWAPIO      =       -fconvert=big-endian -frecord-marker=4
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -G
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC)
+
+.SUFFIXES: 
+.SUFFIXES: .F90 .f90 .o .mod 
+
+ARCHFLAGS       =    $(COREDEFS) -DIWORDSIZE=$(IWORDSIZE) -DDWORDSIZE=$(DWORDSIZE) -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=$(LWORDSIZE) \
+                     $(ARCH_LOCAL) \
+                     $(DA_ARCHFLAGS) \
+                      -DDM_PARALLEL \
+                      -DSTUBMPI \
+                      -DNETCDF \
+                      -DLMDZ \
+                      -DCPP_IOIPSL \
+                      -DhistNMC \
+                       \
+                       \
+                       \
+                       \
+                      -DUSE_ALLOCATABLES \
+                      -DGRIB1 \
+                      -DINTIO \
+                      -DLIMIT_ARGS \
+                      -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) \
+                      -DMAX_DOMAINS_F=$(MAX_DOMAINS) \
+                      -DMAX_HISTORY=$(MAX_HISTORY) \
+                      -DNMM_NEST=$(WRF_NMM_NEST)
+
+FCLMDZFLAGS         =    $(FCOPTIM) $(FCBASEOPTS) -c
+
+NETCDFPATH      =    ${HOME}/bin/gcc_netcdf-4.3.0
+
+LIB_NETCDF    = -L${NETCDFPATH}/lib  -lnetcdf -lnetcdff 
+INC_NETCDF    = -I$(NETCDFPATH)/include
+
+WRFcode = ../tools/standard.exe
+
+#### end from configure.wrf
+
+
+LN      =       ln -sf
+MAKE    =       make -i -r
+RM      =       rm -f
+
+DIRECTLMDZOBJS = \
+		aero_mod.o \
+		albsno.o \
+		indice_sol_mod.o \
+		mod_grid_phy_lmdz.o \
+		ioipsl_errioipsl.o \
+		ioipsl_stringop.o \
+		dimphy.o \
+		phys_output_var_mod.o \
+		misc_mod.o \
+		vampir.o \
+		surface_data.o \
+		control_mod.o \
+		mod_const_mpi.o \
+		calbeta_clim.o \
+		comcstphy.o \
+		assert_m.o \
+		assert_eq_m.o \
+		interpolation.o \
+		coefcdrag.o \
+		screenp.o \
+		screenc.o \
+		iniorbit.o \
+		orbite.o \
+		orbite_mod.o \
+		clouds_gno.o \
+		ini_wake.o \
+		radiation_ar4_param.o \
+		evappot.o \
+		q_sat.o \
+		pres2lev_mod.o \
+		cv_routines.o \
+		cv30_routines.o \
+		cv3_routines.o \
+		cv3_mixscale.o \
+		cv3_vertmix.o \
+		cv3a_compress.o \
+		cv3a_uncompress.o \
+		cv3p_mixing.o \
+		cv3_buoy.o \
+		cv3_cine.o \
+		suphel.o \
+		zilch.o \
+		aeropt.o \
+		cv3_inip.o \
+		printflag.o \
+		iniradia.o \
+		cloudth.o \
+		thermcell_height.o \
+		thermcell_flux2.o \
+		thermcell_dq.o \
+		thermcell_dv2.o \
+		thermcell_qsat.o \
+		thermcell_plume.o \
+		thermcell_condens.o \
+		thermcell_dry.o \
+		thermcell_closure.o \
+		wrgrads.o \
+		formcoord.o \
+		gr_fi_dyn.o \
+		NOread_limit_sub_variables.o \
+		output_lmdz_NOmodule.o \
+		cray.o
+
+MODULES = \
+		comgeomphy.o \
+		open_climoz_m.o \
+		netcdf95.o \
+		mod_phys_lmdz_para.o \
+		mod_phys_lmdz_transfert_para.o \
+                mod_phys_lmdz_mpi_transfert.o \
+		mod_phys_lmdz_mpi_data.o \
+                mod_phys_lmdz_omp_transfert.o \
+		mod_phys_lmdz_omp_data.o \
+		phys_cal_mod.o \
+		regr_pr_av_m.o \
+		ozonecm_m.o \
+		regr1_step_av_m.o \
+		conf_phys_m.o \
+		radlwsw_m.o \
+		sw_aeroAR4.o \
+		write_field.o \
+		write_field_phy.o \
+		infotrac.o \
+		iophy.o \
+		clcdrag.o \
+		stdlevvar.o \
+		hbtm.o \
+		yamada_c.o \
+		pbl_surface_mod.o \
+		read_map2D.o \
+		carbon_cycle_mod.o \
+		surf_land_mod.o \
+		albedo.o \
+		surf_land_orchidee_noopenmp_mod.o \
+		cpl_mod.o \
+		atm2geo.o \
+		geo2atm.o \
+		oasis.o \
+		phys_state_var_mod.o \
+		surf_land_orchidee_mod.o \
+		mod_surf_para.o \
+		mod_synchro_omp.o \
+		surf_land_bucket_mod.o \
+		limit_read_mod.o \
+		fonte_neige_mod.o \
+		calcul_fluxs_mod.o \
+		calbeta.o \
+		soil.o \
+		surf_landice_mod.o \
+		surf_ocean_mod.o \
+		limit_slab.o \
+		ocean_forced_mod.o \
+		ocean_slab_mod.o \
+		ocean_cpl_mod.o \
+		surf_seaice_mod.o \
+		climb_hq_mod.o \
+		climb_wind_mod.o \
+		ustarhb.o \
+		vdif_kcay.o \
+		yamada.o \
+		yamada4.o \
+		coefkzmin.o \
+		coef_diff_turb_mod.o \
+		change_srf_frac_mod.o \
+		phys_local_var_mod.o \
+		phys_output_mod.o \
+		phys_output_ctrlout_mod.o \
+		cfmip_point_locations.o \
+		ioipsl_getincom.o \
+		abort_gcm.o \
+		plevel_new.o \
+		plevel.o \
+		orografi.o \
+		orografi_mod.o \
+		orografi_strato_mod.o \
+		nuage.o \
+		nuage_mod.o \
+		conflx.o \
+		radiation_AR4_mod.o \
+		add_phys_tend.o \
+		print_debug_phys.o \
+		hgardfou.o \
+		solarlong.o \
+		phyaqua.o \
+		phyaqua_mod.o \
+		concvl.o \
+		ajsec.o \
+		aaam_bud.o \
+		diagphy.o \
+		diagphy_mod.o \
+		readaerosolstrato.o \
+		mkstat.o \
+		readaerosol_optic.o \
+		aeropt_2bands.o \
+		aeropt_5wv.o \
+		readaerosol_interp.o \
+		readaerosol.o \
+		cva_driver.o \
+		cv_driver.o \
+		cv3p1_closure.o \
+		traclmdz_mod.o \
+		cltracrn.o \
+		radio_decay.o \
+		minmaxqfi.o \
+		initrrnpb.o \
+		init_be.o \
+		o3_chem_m.o \
+		regr_pr_comb_coefoz_m.o \
+		regr_pr_int_m.o \
+		regr1_lint_m.o \
+		press_coefoz_m.o \
+		iostart.o \
+		wstats.o \
+		inistats.o \
+		phyredem.o \
+		hines_gwd.o \
+		ini_undefSTD.o \
+		moy_undefSTD.o \
+		phyetat0.o \
+		transp.o \
+		undefSTD.o \
+		calwake.o \
+		wake.o \
+		newmicro.o \
+		calltherm.o \
+		thermcell_old.o \
+		wrgradsfi.o \
+		thermcell.o \
+		thermcellV0_main.o \
+		thermcell_env.o \
+		thermcell_main.o \
+		fisrtilp.o \
+		stratocu_if.o \
+		phystokenc.o \
+		initphysto.o \
+		ener_conserv.o \
+		tracinca_mod.o \
+		tracreprobus_mod.o \
+		cvltrorig.o \
+		cvltr.o \
+		nflxtr.o \
+		lsc_scav.o \
+		cltrac.o \
+		calcratqs.o \
+		iniphysiq.o \
+		conf_gcm.o \
+		init_phys_lmdz.o \
+		moyglo_aire.o \
+		global_mean.o \
+		wrf_lmdz_mod.o \
+		physiq_limit_variables_mod.o \
+		lmdz_wrf_variables_mod.o \
+		phytrac.o 
+
+DIRECTLMDZSRC = $(DIRECTLMDZOBJS:.o=.F90)
+LMDZSOURCES = $(MODULES:.o=.F90)
+LMDZPRE = $(MODULES:.o=.bb)
+LMDZPOST = $(MODULES:.o=.f90)
+LMDZMOD = $(MODULES:.o=.mod)
+
+NETCDF95OBJS = \
+		nf95_def_var_m.o \
+		nf95_put_var_m.o \
+		nf95_get_var_m.o \
+		nf95_gw_var_m.o \
+		nf95_put_att_m.o \
+		nf95_get_att_m.o \
+		simple.o \
+		handle_err_m.o
+
+NETCDF95SOURCES = $(NETCDF95OBJS:.o=.F90)
+NETCDF95PRE = $(NETCDF95OBJS:.o=.bb)
+NETCDF95POST = $(NETCDF95OBJS:.o=.f90)
+
+OBJS    = physiq.o 
+
+NMM_MODULES =  
+
+LIBTARGET    =  lmdz
+TARGETDIR    =  ./
+
+DIRECTIOIPSLMOD =	\
+        defprec.o \
+	errioipsl.o \
+	stringop.o \
+
+DEPIOIPSLMOD = 	\
+	mathelp.o \
+	getincom.o \
+	calendar.o \
+	fliocom.o \
+	flincom.o \
+	histcom.o \
+	restcom.o \
+	ioipsl.o 
+
+DIRECTIOIPSLSRC = $(DIRECTIOIPSLMOD:.o=.f90)
+
+IOIPSLFOLD = ./IOIPSL
+FULLIOIPSLMODS = $(addprefix $(IOIPSLFOLD)/,$(IOIPSLMOD))
+
+##include ../configure.wrf
+
+all : preprocess lmdz.a 
+
+lmdz.a:		$(MODULES) $(OBJS) $(DIRECTLMDZOBJS) $(DIRECTIOIPSLMOD) $(DEPIOIPSLMOD) $(NETCDF95OBJS)
+		/bin/rm -f lmdz.a
+		$(AR) cr lmdz.a $(MODULES) $(OBJS) $(DIRECTLMDZOBJS) $(DIRECTIOIPSLMOD) $(DEPIOIPSLMOD) $(NETCDF95OBJS)
+
+# IOIPSL
+ 
+$(DIRECTIOIPSLMOD): 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,$(DIRECTIOIPSLSRC))
+
+calendar.o: stringop.o errioipsl.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,calendar.f90)
+
+getincom.o: stringop.o errioipsl.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,getincom.f90)
+
+mathelp.o: stringop.o errioipsl.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,mathelp.f90)
+
+flincom.o: stringop.o errioipsl.o calendar.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,flincom.f90)
+
+fliocom.o: stringop.o errioipsl.o calendar.o defprec.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,fliocom.f90)
+
+histcom.o: stringop.o errioipsl.o calendar.o mathelp.o fliocom.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,histcom.f90)
+
+restcom.o: stringop.o errioipsl.o calendar.o mathelp.o fliocom.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,restcom.f90)
+
+ioipsl.o: $(DIRECTIOIPSLMOD) getincom.o calendar.o mathelp.o flincom.o fliocom.o histcom.o restcom.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,ioipsl.f90)
+
+# LMDZ
+#
+preprocess: $(LMDZPOST) $(NETCDF95POST)
+
+$(LMDZPOST): %.f90: %.bb
+		$(WRFcode) $< | $(CPP) > $@
+		rm $<
+
+$(LMDZPRE): %.bb: %.F90
+		$(CPP) $(ARCHFLAGS) $< > $@
+
+$(NETCDF95POST): %.f90: %.bb
+		$(WRFcode) $< | $(CPP) > $@
+		rm $<
+
+$(NETCDF95PRE): %.bb: %.F90
+		$(CPP) $(ARCHFLAGS) $< > $@
+
+$(DIRECTLMDZOBJS): 
+		$(FC) $(FCLMDZFLAGS) $(DIRECTLMDZSRC)
+
+infotrac.o: control_mod.o
+		$(FC) $(FCLMDZFLAGS) infotrac.f90
+
+
+mod_phys_lmdz_mpi_data.o: mod_const_mpi.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_mpi_data.f90
+
+ioipsl_getincom.o: ioipsl_errioipsl.o ioipsl_stringop.o
+		$(FC) $(FCLMDZFLAGS) ioipsl_getincom.f90
+
+abort_gcm.o: ioipsl.o ioipsl_getincom.o
+		$(FC) $(FCLMDZFLAGS) abort_gcm.f90
+
+write_field.o: 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) write_field.f90
+
+mod_phys_lmdz_omp_data.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_omp_data.f90
+
+mod_phys_lmdz_omp_transfert.o: mod_phys_lmdz_mpi_data.o mod_phys_lmdz_omp_data.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_omp_transfert.f90
+
+mod_phys_lmdz_mpi_transfert.o: mod_phys_lmdz_mpi_data.o mod_grid_phy_lmdz.o  mod_phys_lmdz_omp_transfert.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_mpi_transfert.f90
+
+mod_phys_lmdz_transfert_para.o: mod_phys_lmdz_mpi_transfert.o mod_phys_lmdz_omp_transfert.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_transfert_para.f90
+
+mod_phys_lmdz_para.o: mod_phys_lmdz_transfert_para.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_omp_data.o mod_grid_phy_lmdz.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_para.f90
+
+comgeomphy.o: mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) comgeomphy.f90
+
+handle_err_m.o: 
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) handle_err_m.f90
+
+nf95_def_var_m.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_def_var_m.f90
+
+nf95_put_var_m.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_put_var_m.f90
+
+nf95_get_var_m.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_get_var_m.f90
+
+simple.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) simple.f90
+
+nf95_gw_var_m.o: handle_err_m.o simple.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_gw_var_m.f90
+
+nf95_put_att_m.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_put_att_m.f90
+
+nf95_get_att_m.o: handle_err_m.o simple.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_get_att_m.f90
+
+netcdf95.o: $(NETCDF95OBJS) 
+		$(FC) $(FCLMDZFLAGS) netcdf95.f90
+
+open_climoz_m.o: mod_phys_lmdz_mpi_data.o mod_phys_lmdz_mpi_transfert.o netcdf95.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) open_climoz_m.f90
+
+regr1_step_av_m.o: assert_eq_m.o assert_m.o interpolation.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) regr1_step_av_m.f90
+
+regr_pr_av_m.o: dimphy.o netcdf95.o assert_m.o assert_eq_m.o regr1_step_av_m.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_transfert_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) regr_pr_av_m.f90
+
+ozonecm_m.o: dimphy.o assert_m.o
+		$(FC) $(FCLMDZFLAGS) ozonecm_m.f90
+
+conf_phys_m.o: ioipsl.o surface_data.o phys_cal_mod.o carbon_cycle_mod.o control_mod.o
+		$(FC) $(FCLMDZFLAGS) conf_phys_m.f90
+
+radiation_AR4_mod.o: dimphy.o radiation_ar4_param.o
+		$(FC) $(FCLMDZFLAGS) radiation_AR4_mod.f90	
+
+sw_aeroAR4.o: dimphy.o phys_output_mod.o radiation_AR4_mod.o
+		$(FC) $(FCLMDZFLAGS) sw_aeroAR4.f90	
+
+radlwsw_m.o: dimphy.o assert_m.o infotrac.o radiation_AR4_mod.o sw_aeroAR4.o
+		$(FC) $(FCLMDZFLAGS) radlwsw_m.f90
+
+phys_cal_mod.o: ioipsl.o
+		$(FC) $(FCLMDZFLAGS) phys_cal_mod.f90
+
+write_field_phy.o: write_field.o
+		$(FC) $(FCLMDZFLAGS) write_field_phy.f90
+
+iophy.o: ioipsl.o phys_output_var_mod.o write_field.o
+		$(FC) $(FCLMDZFLAGS) iophy.f90
+
+read_map2D.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) read_map2D.f90
+
+carbon_cycle_mod.o: dimphy.o comgeomphy.o mod_phys_lmdz_transfert_para.o infotrac.o ioipsl.o surface_data.o phys_cal_mod.o indice_sol_mod.o read_map2D.o
+		$(FC) $(FCLMDZFLAGS) carbon_cycle_mod.f90
+
+oasis.o:
+ifeq ($(ARCHFLAGS), -DCPP_COUPLE)
+oasis.o: dimphy.o mod_phys_lmdz_para.o write_field_phy.o mod_prism_proto.o mod_prism_def_partition_proto.o mod_prism_get_proto.o mod_prism_put_proto.o ioipsl.o surface_data.o carbon_cycle_mod.o
+		$(FC) $(FCLMDZFLAGS) oasis.f90
+else
+oasis.o: dimphy.o mod_phys_lmdz_para.o write_field_phy.o ioipsl.o surface_data.o carbon_cycle_mod.o
+		$(FC) $(FCLMDZFLAGS) oasis.f90
+endif
+
+phys_state_var_mod.o: dimphy.o control_mod.o aero_mod.o infotrac.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) phys_state_var_mod.f90
+
+atm2geo.o: dimphy.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) atm2geo.f90
+
+geo2atm.o: dimphy.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) geo2atm.f90
+
+cpl_mod.o: dimphy.o mod_phys_lmdz_para.o ioipsl.o iophy.o oasis.o write_field_phy.o control_mod.o carbon_cycle_mod.o surface_data.o indice_sol_mod.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) cpl_mod.f90
+
+surf_land_orchidee_noopenmp_mod.o:
+ifeq ($(ARCHFLAGS), -DORCHIDEE_NOOPENMP)
+intersurf.o: 
+		$(FC) $(FCLMDZFLAGS) intersurf.f90
+
+surf_land_orchidee_noopenmp_mod.o: dimphy.o intersurf.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_noopenmp_mod.f90
+else
+surf_land_orchidee_noopenmp_mod.o: dimphy.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_noopenmp_mod.f90
+endif
+ifeq ($(ARCHFLAGS), -DCPP_VEGET)
+intersurf.o: 
+		$(FC) $(FCLMDZFLAGS) intersurf.f90
+
+surf_land_orchidee_noopenmp_mod.o: dimphy.o intersurf.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o carbon_cycle_mod.o indice_sol_mod.o
+		rm surf_land_orchidee_noopenmp_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_noopenmp_mod.f90
+else
+surf_land_orchidee_noopenmp_mod.o: dimphy.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_noopenmp_mod.f90
+endif
+
+mod_surf_para.o: mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) mod_surf_para.f90
+
+mod_synchro_omp.o: mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) mod_synchro_omp.f90
+
+surf_land_orchidee_mod.o: 
+ifeq ($(ARCHFLAGS), -DORCHIDEE_NOOPENMP)
+intersurf.o: 
+		$(FC) $(FCLMDZFLAGS) intersurf.f90
+
+surf_land_orchidee_mod.o: dimphy.o intersurf.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o mod_surf_para.o mod_synchro_omp.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_mod.f90
+else
+surf_land_orchidee_mod.o: dimphy.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o mod_surf_para.o mod_synchro_omp.o carbon_cycle_mod.o indice_sol_mod.o
+endif
+ifeq ($(ARCHFLAGS), -DCPP_VEGET)
+intersurf.o: 
+		$(FC) $(FCLMDZFLAGS) intersurf.f90
+
+surf_land_orchidee_mod.o: dimphy.o intersurf.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o mod_surf_para.o mod_synchro_omp.o carbon_cycle_mod.o indice_sol_mod.o
+		rm surf_land_orchidee_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_mod.f90
+else
+surf_land_orchidee_mod.o: dimphy.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o mod_surf_para.o mod_synchro_omp.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_mod.f90
+endif
+
+limit_read_mod.o: dimphy.o indice_sol_mod.o surface_data.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) limit_read_mod.f90
+
+phys_local_var_mod.o: dimphy.o infotrac.o aero_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) phys_local_var_mod.f90
+
+calbeta.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) calbeta.f90
+
+soil.o: dimphy.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) soil.f90
+
+calcul_fluxs_mod.o: dimphy.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) calcul_fluxs_mod.f90
+
+fonte_neige_mod.o: dimphy.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) fonte_neige_mod.f90
+
+limit_slab.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) limit_slab.f90
+
+surf_land_bucket_mod.o: limit_read_mod.o surface_data.o fonte_neige_mod.o calcul_fluxs_mod.o cpl_mod.o dimphy.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o indice_sol_mod.o albsno.o calbeta_clim.o calbeta.o soil.o NOread_limit_sub_variables.o
+		$(FC) $(FCLMDZFLAGS) surf_land_bucket_mod.f90
+
+surf_land_mod.o: dimphy.o surface_data.o surf_land_orchidee_noopenmp_mod.o surf_land_orchidee_mod.o surf_land_bucket_mod.o calcul_fluxs_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_mod.f90
+
+surf_landice_mod.o: dimphy.o surface_data.o fonte_neige_mod.o cpl_mod.o calcul_fluxs_mod.o phys_output_var_mod.o indice_sol_mod.o albsno.o soil.o
+		$(FC) $(FCLMDZFLAGS) surf_landice_mod.f90
+
+ocean_forced_mod.o: dimphy.o calcul_fluxs_mod.o limit_read_mod.o indice_sol_mod.o surface_data.o fonte_neige_mod.o calbeta.o soil.o albsno.o NOread_limit_sub_variables.o
+		$(FC) $(FCLMDZFLAGS) ocean_forced_mod.f90
+
+ocean_slab_mod.o: dimphy.o limit_read_mod.o surface_data.o indice_sol_mod.o calcul_fluxs_mod.o limit_slab.o
+		$(FC) $(FCLMDZFLAGS) ocean_slab_mod.f90
+
+ocean_cpl_mod.o: dimphy.o cpl_mod.o calcul_fluxs_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) ocean_cpl_mod.f90
+
+albedo.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) albedo.f90
+
+surf_ocean_mod.o: dimphy.o surface_data.o ocean_forced_mod.o ocean_slab_mod.o ocean_cpl_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_ocean_mod.f90
+
+surf_seaice_mod.o: dimphy.o surface_data.o ocean_forced_mod.o ocean_cpl_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_seaice_mod.f90
+
+climb_hq_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) climb_hq_mod.f90
+
+climb_wind_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) climb_wind_mod.f90
+
+yamada4.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) yamada4.f90
+
+yamada.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) yamada.f90
+
+vdif_kcay.o: dimphy.o yamada.o
+		$(FC) $(FCLMDZFLAGS) vdif_kcay.f90
+
+ustarhb.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) ustarhb.f90
+
+coefkzmin.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) coefkzmin.f90
+
+coef_diff_turb_mod.o: dimphy.o indice_sol_mod.o yamada4.o vdif_kcay.o ustarhb.o coefkzmin.o
+		$(FC) $(FCLMDZFLAGS) coef_diff_turb_mod.f90
+
+stdlevvar.o: coefcdrag.o screenp.o screenc.o
+		$(FC) $(FCLMDZFLAGS) stdlevvar.f90
+
+clcdrag.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) clcdrag.f90
+
+hbtm.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) hbtm.f90
+
+yamada_c.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) yamada_c.f90
+
+pbl_surface_mod.o: dimphy.o mod_phys_lmdz_para.o ioipsl.o surface_data.o surf_land_mod.o surf_landice_mod.o surf_ocean_mod.o surf_seaice_mod.o cpl_mod.o climb_hq_mod.o climb_wind_mod.o coef_diff_turb_mod.o control_mod.o indice_sol_mod.o carbon_cycle_mod.o clcdrag.o stdlevvar.o hbtm.o yamada_c.o
+		$(FC) $(FCLMDZFLAGS) pbl_surface_mod.f90
+
+change_srf_frac_mod.o: dimphy.o surface_data.o limit_read_mod.o pbl_surface_mod.o cpl_mod.o ocean_slab_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) change_srf_frac_mod.f90
+
+phys_output_mod.o: indice_sol_mod.o phys_output_var_mod.o phys_output_ctrlout_mod.o aero_mod.o iophy.o dimphy.o infotrac.o ioipsl.o phys_cal_mod.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) phys_output_mod.f90
+
+phys_output_ctrlout_mod.o: phys_output_var_mod.o indice_sol_mod.o aero_mod.o
+		$(FC) $(FCLMDZFLAGS) phys_output_ctrlout_mod.f90
+
+cfmip_point_locations.o: dimphy.o iophy.o mod_grid_phy_lmdz.o
+		$(FC) $(FCLMDZFLAGS) cfmip_point_locations.f90
+
+mkstat.o: 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) mkstat.f90
+
+plevel_new.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) plevel_new.f90
+
+plevel.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) plevel.f90
+
+orografi_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) orografi_mod.f90
+
+orografi.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) orografi.f90
+
+orografi_strato_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) orografi_strato_mod.f90
+
+orografi_strato.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) orografi_strato.f90
+
+nuage_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) nuage_mod.f90
+
+nuage.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) nuage.f90
+
+conflx.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) conflx.f90
+
+hgardfou.o: dimphy.o phys_state_var_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) hgardfou.f90
+
+print_debug_phys.o: dimphy.o phys_state_var_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) print_debug_phys.f90
+
+add_phys_tend.o: dimphy.o phys_local_var_mod.o phys_state_var_mod.o print_debug_phys.o hgardfou.o
+		$(FC) $(FCLMDZFLAGS) add_phys_tend.f90
+
+solarlong.o: ioipsl.o iniorbit.o
+		$(FC) $(FCLMDZFLAGS) solarlong.f90
+
+phyaqua_mod.o: comgeomphy.o dimphy.o surface_data.o pbl_surface_mod.o fonte_neige_mod.o phys_state_var_mod.o control_mod.o indice_sol_mod.o ioipsl.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) phyaqua_mod.f90
+
+phyaqua.o: comgeomphy.o dimphy.o surface_data.o pbl_surface_mod.o fonte_neige_mod.o phys_state_var_mod.o control_mod.o indice_sol_mod.o ioipsl.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) phyaqua.f90
+
+ajsec.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) ajsec.f90
+
+aaam_bud.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) aaam_bud.f90
+
+diagphy.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) diagphy.f90
+
+diagphy_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) diagphy_mod.f90
+
+readaerosolstrato.o: netcdf95.o phys_cal_mod.o mod_grid_phy_lmdz.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_para.o phys_state_var_mod.o phys_local_var_mod.o aero_mod.o dimphy.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) readaerosolstrato.f90
+
+aeropt_2bands.o: dimphy.o aero_mod.o phys_cal_mod.o pres2lev_mod.o
+		$(FC) $(FCLMDZFLAGS) aeropt_2bands.f90
+
+aeropt_5wv.o: dimphy.o aero_mod.o phys_local_var_mod.o pres2lev_mod.o
+		$(FC) $(FCLMDZFLAGS) aeropt_5wv.f90
+
+readaerosol_mod.o: readaerosol.o
+
+readaerosol.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) readaerosol.f90
+
+readaerosol_interp.o: dimphy.o mod_phys_lmdz_para.o readaerosol_mod.o aero_mod.o write_field_phy.o phys_cal_mod.o pres2lev_mod.o
+		$(FC) $(FCLMDZFLAGS) readaerosol_interp.f90
+
+readaerosol_optic.o: dimphy.o aero_mod.o phys_local_var_mod.o readaerosol_interp.o aeropt.o
+		$(FC) $(FCLMDZFLAGS) readaerosol_optic.f90
+
+cv3p1_closure.o: cv3_cine.o cv3_buoy.o
+		$(FC) $(FCLMDZFLAGS) cv3p1_closure.f90
+
+cv_driver.o: dimphy.o cv_routines.o cv30_routines.o cv3p1_closure.o
+		$(FC) $(FCLMDZFLAGS) cv_driver.f90
+
+cva_driver.o: dimphy.o zilch.o cv_routines.o cv3_routines.o
+		$(FC) $(FCLMDZFLAGS) cva_driver.f90
+
+concvl.o: dimphy.o infotrac.o cv_driver.o cva_driver.o cv3_inip.o
+		$(FC) $(FCLMDZFLAGS) concvl.f90
+
+regr1_lint_m.o: assert_eq_m.o interpolation.o
+		$(FC) $(FCLMDZFLAGS) regr1_lint_m.f90
+
+regr_pr_int_m.o: dimphy.o netcdf95.o assert_m.o regr1_lint_m.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_transfert_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) regr_pr_int_m.f90
+
+regr_pr_comb_coefoz_m.o: dimphy.o netcdf95.o assert_m.o mod_phys_lmdz_mpi_data.o regr_pr_av_m.o regr_pr_int_m.o press_coefoz_m.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) regr_pr_comb_coefoz_m.f90
+
+press_coefoz_m.o: netcdf95.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_mpi_transfert.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) press_coefoz_m.f90
+
+o3_chem_m.o: dimphy.o assert_m.o regr_pr_comb_coefoz_m.o 
+		$(FC) $(FCLMDZFLAGS) o3_chem_m.f90
+
+initrrnpb.o: dimphy.o infotrac.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) initrrnpb.f90
+
+init_be.o: dimphy.o comgeomphy.o infotrac.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) init_be.f90
+
+minmaxqfi.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) minmaxqfi.f90
+
+radio_decay.o: dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) radio_decay.f90
+
+cltracrn.o: dimphy.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) cltracrn.f90
+
+traclmdz_mod.o: dimphy.o infotrac.o regr_pr_comb_coefoz_m.o press_coefoz_m.o carbon_cycle_mod.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o indice_sol_mod.o o3_chem_m.o q_sat.o cltracrn.o minmaxqfi.o initrrnpb.o
+		$(FC) $(FCLMDZFLAGS) traclmdz_mod.f90
+
+inistats.o: 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) inistats.f90
+
+wstats.o: inistats.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) wstats.f90
+
+iostart.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) iostart.f90
+
+wake.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) wake.f90
+
+calwake.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) calwake.f90
+
+hines_gwd.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) hines_gwd.f90
+
+ini_undefSTD.o: dimphy.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) ini_undefSTD.f90
+
+moy_undefSTD.o: dimphy.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) moy_undefSTD.f90
+
+newmicro.o: dimphy.o phys_local_var_mod.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) newmicro.f90
+
+phyetat0.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o iophy.o ocean_cpl_mod.o fonte_neige_mod.o pbl_surface_mod.o surface_data.o phys_state_var_mod.o iostart.o write_field_phy.o infotrac.o traclmdz_mod.o carbon_cycle_mod.o indice_sol_mod.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) phyetat0.f90
+
+transp.o: dimphy.o 
+		$(FC) $(FCLMDZFLAGS) transp.f90
+
+undefSTD.o: dimphy.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) undefSTD.f90
+
+stratocu_if.o: indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) stratocu_if.f90
+
+thermcell.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) thermcell.f90
+
+wrgradsfi.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o wrgrads.o gr_fi_dyn.o 
+		$(FC) $(FCLMDZFLAGS) wrgradsfi.f90
+
+thermcell_old.o: dimphy.o thermcell.o
+		$(FC) $(FCLMDZFLAGS) thermcell_old.f90
+
+thermcell_env.o: thermcell_qsat.o
+		$(FC) $(FCLMDZFLAGS) thermcell_env.f90
+
+thermcellV0_main.o: dimphy.o comgeomphy.o thermcell_env.o thermcell_height.o thermcell_flux2.o thermcell_dq.o thermcell_dv2.o 
+		$(FC) $(FCLMDZFLAGS) thermcellV0_main.f90
+
+thermcell_main.o: dimphy.o comgeomphy.o indice_sol_mod.o thermcell_env.o thermcell_plume.o thermcell_height.o thermcell_dry.o thermcell_closure.o thermcell_flux2.o thermcell_dq.o thermcell_dv2.o  
+		$(FC) $(FCLMDZFLAGS) thermcell_main.f90
+
+calltherm.o: indice_sol_mod.o dimphy.o thermcell_old.o thermcellV0_main.o thermcell_main.o
+		$(FC) $(FCLMDZFLAGS) calltherm.f90
+
+callcratqs.o: clouds_gno.o
+		$(FC) $(FCLMDZFLAGS) callcratqs.f90
+
+fisrtilp.o: dimphy.o cloudth.o
+		$(FC) $(FCLMDZFLAGS) fisrtilp.f90
+
+tracinca_mod.o: dimphy.o infotrac.o vampir.o comgeomphy.o control_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) tracinca_mod.f90
+
+tracreprobus_mod.o: dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) tracreprobus_mod.f90
+
+cvltrorig.o: dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) cvltrorig.f90
+
+cvltr.o: dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) cvltr.f90
+
+nflxtr.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) nflxtr.f90
+
+lsc_scav.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o traclmdz_mod.o infotrac.o comgeomphy.o iophy.o
+		$(FC) $(FCLMDZFLAGS) lsc_scav.f90
+
+cltrac.o: dimphy.o 
+		$(FC) $(FCLMDZFLAGS) cltrac.f90
+
+phytrac.o: phys_cal_mod.o phys_output_mod.o dimphy.o infotrac.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o comgeomphy.o iophy.o traclmdz_mod.o tracinca_mod.o tracreprobus_mod.o control_mod.o indice_sol_mod.o cvltrorig.o cvltr.o nflxtr.o lsc_scav.o cltrac.o
+		$(FC) $(FCLMDZFLAGS) phytrac.f90
+
+initphysto.o: dimphy.o mod_phys_lmdz_para.o ioipsl.o iophy.o control_mod.o indice_sol_mod.o 
+		$(FC) $(FCLMDZFLAGS) initphysto.f90
+
+phystokenc.o: dimphy.o infotrac.o iophy.o control_mod.o indice_sol_mod.o initphysto.o
+		$(FC) $(FCLMDZFLAGS) phystokenc.f90
+
+ener_conserv.o: phys_local_var_mod.o phys_output_var_mod.o
+		$(FC) $(FCLMDZFLAGS) ener_conserv.f90
+
+calcratqs.o: clouds_gno.o
+		$(FC) $(FCLMDZFLAGS) calcratqs.f90
+
+conf_gcm.o: control_mod.o ioipsl.o ioipsl_getincom.o ioipsl.o infotrac.o assert_m.o
+		$(FC) $(FCLMDZFLAGS) conf_gcm.f90
+
+iniphysiq.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o comgeomphy.o suphel.o comcstphy.o phyaqua.o
+		$(FC) $(FCLMDZFLAGS) iniphysiq.f90
+
+init_phys_lmdz.o: mod_phys_lmdz_para.o mod_grid_phy_lmdz.o dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) init_phys_lmdz.f90
+
+moyglo_aire.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) moyglo_aire.f90
+
+global_mean.o: dimphy.o mod_phys_lmdz_para.o mod_phys_lmdz_transfert_para.o mod_phys_lmdz_mpi_data.o
+		$(FC) $(FCLMDZFLAGS) global_mean.f90
+
+phyredem.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o fonte_neige_mod.o pbl_surface_mod.o phys_state_var_mod.o iostart.o traclmdz_mod.o infotrac.o control_mod.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) phyredem.f90
+
+wrf_lmdz_mod.o: ../frame/module_domain_type.o indice_sol_mod.o phys_state_var_mod.o phys_output_var_mod.o output_lmdz_NOmodule.o suphel.o pbl_surface_mod.o phys_local_var_mod.o comgeomphy.o
+		$(FC) $(FCLMDZFLAGS) wrf_lmdz_mod.f90
+
+##module_lmdz_variables.o: pbl_surface_mod.o indice_sol_mod.o fonte_neige_mod.o dimphy.o
+##		$(FC) $(FCLMDZFLAGS) module_lmdz_variables.f90
+
+physiq_limit_variables_mod.o: mod_grid_phy_lmdz.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) physiq_limit_variables_mod.f90
+
+lmdz_wrf_variables_mod.o: mod_grid_phy_lmdz.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) lmdz_wrf_variables_mod.f90
+
+%.o: %.mod
+		@true
+
+physiq.o : $(MODULES) $(DIRECTLMDZOBJS) netcdf95.o ../frame/module_domain.o
+		$(CPP) $(ARCHFLAGS) physiq.F90 > physiq.bb
+		$(WRFcode) physiq.bb | $(CPP) > physiq.f90
+		rm physiq.bb
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) physiq.f90
+
+clean:
+	rm *.f90 *.o *.a *.mod
+	@ echo 'use the clean script'
+
+# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES)
+
+# DO NOT DELETE
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/Makefile.lmdz
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/Makefile.lmdz	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/Makefile.lmdz	(revision 17)
@@ -0,0 +1,939 @@
+SFC             =       gfortran
+SCC             =       gcc
+CCOMP           =       gcc
+DM_FC           =       mpif90 -f90=$(SFC)
+DM_CC           =       mpicc -cc=$(SCC)
+FC              =        $(SFC)
+CC              =       $(SCC) -DFSEEKO64_OK
+LD              =       $(FC)
+RWORDSIZE       =       $(NATIVE_RWORDSIZE)
+PROMOTION       =       # -fdefault-real-8  # uncomment manually
+ARCH_LOCAL      =       -DNONSTANDARD_SYSTEM_SUBR
+CFLAGS_LOCAL    =       -w -O3 -c -DLANDREAD_STUB
+LDFLAGS_LOCAL   =
+CPLUSPLUSLIB    =
+ESMF_LDFLAG     =       $(CPLUSPLUSLIB)
+FCOPTIM         =       -O3 -ftree-vectorize -ftree-loop-linear -funroll-loops 
+FCREDUCEDOPT    =       $(FCOPTIM)
+FCNOOPT         =       -O0
+FCDEBUG         =       # -g $(FCNOOPT) -fbacktrace -Wall -fbounds-check
+FORMAT_FIXED    =       -ffixed-form
+FORMAT_FREE     =       -ffree-form -ffree-line-length-none
+FCSUFFIX        =
+BYTESWAPIO      =       -fconvert=big-endian -frecord-marker=4
+FCBASEOPTS_NO_G =       -w $(FORMAT_FREE) $(BYTESWAPIO)
+FCBASEOPTS      =       $(FCBASEOPTS_NO_G) $(FCDEBUG)
+MODULE_SRCH_FLAG =
+TRADFLAG        =      -traditional
+CPP             =      /lib/cpp -C -P
+AR              =      ar
+ARFLAGS         =      ru
+M4              =      m4 -G
+RANLIB          =      ranlib
+CC_TOOLS        =      $(SCC)
+
+.SUFFIXES: 
+.SUFFIXES: .F90 .f90 .o .mod 
+
+ARCHFLAGS       =    $(COREDEFS) -DIWORDSIZE=$(IWORDSIZE) -DDWORDSIZE=$(DWORDSIZE) -DRWORDSIZE=$(RWORDSIZE) -DLWORDSIZE=$(LWORDSIZE) \
+                     $(ARCH_LOCAL) \
+                     $(DA_ARCHFLAGS) \
+                      -DDM_PARALLEL \
+                      -DSTUBMPI \
+                      -DNETCDF \
+                      -DLMDZ \
+                      -DCPP_IOIPSL \
+                      -DhistNMC \
+                       \
+                       \
+                       \
+                       \
+                      -DUSE_ALLOCATABLES \
+                      -DGRIB1 \
+                      -DINTIO \
+                      -DLIMIT_ARGS \
+                      -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) \
+                      -DMAX_DOMAINS_F=$(MAX_DOMAINS) \
+                      -DMAX_HISTORY=$(MAX_HISTORY) \
+                      -DNMM_NEST=$(WRF_NMM_NEST)
+
+FCLMDZFLAGS         =    $(FCOPTIM) $(FCBASEOPTS) -c
+
+NETCDFPATH      =    ${HOME}/bin/gcc_netcdf-4.3.0
+
+LIB_NETCDF    = -L${NETCDFPATH}/lib  -lnetcdf -lnetcdff 
+INC_NETCDF    = -I$(NETCDFPATH)/include
+
+WRFcode = ../tools/standard.exe
+
+#### end from configure.wrf
+
+
+LN      =       ln -sf
+MAKE    =       make -i -r
+RM      =       rm -f
+
+DIRECTLMDZOBJS = \
+		aero_mod.o \
+		albsno.o \
+		indice_sol_mod.o \
+		mod_grid_phy_lmdz.o \
+		ioipsl_errioipsl.o \
+		ioipsl_stringop.o \
+		dimphy.o \
+		phys_output_var_mod.o \
+		misc_mod.o \
+		vampir.o \
+		surface_data.o \
+		control_mod.o \
+		mod_const_mpi.o \
+		calbeta_clim.o \
+		comcstphy.o \
+		assert_m.o \
+		assert_eq_m.o \
+		interpolation.o \
+		coefcdrag.o \
+		screenp.o \
+		screenc.o \
+		iniorbit.o \
+		orbite.o \
+		orbite_mod.o \
+		clouds_gno.o \
+		ini_wake.o \
+		radiation_ar4_param.o \
+		evappot.o \
+		q_sat.o \
+		pres2lev_mod.o \
+		cv_routines.o \
+		cv30_routines.o \
+		cv3_routines.o \
+		cv3_mixscale.o \
+		cv3_vertmix.o \
+		cv3a_compress.o \
+		cv3a_uncompress.o \
+		cv3p_mixing.o \
+		cv3_buoy.o \
+		cv3_cine.o \
+		suphel.o \
+		zilch.o \
+		aeropt.o \
+		cv3_inip.o \
+		printflag.o \
+		iniradia.o \
+		cloudth.o \
+		thermcell_height.o \
+		thermcell_flux2.o \
+		thermcell_dq.o \
+		thermcell_dv2.o \
+		thermcell_qsat.o \
+		thermcell_plume.o \
+		thermcell_condens.o \
+		thermcell_dry.o \
+		thermcell_closure.o \
+		wrgrads.o \
+		formcoord.o \
+		gr_fi_dyn.o \
+		NOread_limit_sub_variables.o \
+		output_lmdz_NOmodule.o \
+		cray.o
+
+MODULES = \
+		comgeomphy.o \
+		open_climoz_m.o \
+		netcdf95.o \
+		mod_phys_lmdz_para.o \
+		mod_phys_lmdz_transfert_para.o \
+                mod_phys_lmdz_mpi_transfert.o \
+		mod_phys_lmdz_mpi_data.o \
+                mod_phys_lmdz_omp_transfert.o \
+		mod_phys_lmdz_omp_data.o \
+		phys_cal_mod.o \
+		regr_pr_av_m.o \
+		ozonecm_m.o \
+		regr1_step_av_m.o \
+		conf_phys_m.o \
+		radlwsw_m.o \
+		sw_aeroAR4.o \
+		write_field.o \
+		write_field_phy.o \
+		infotrac.o \
+		iophy.o \
+		clcdrag.o \
+		stdlevvar.o \
+		hbtm.o \
+		yamada_c.o \
+		pbl_surface_mod.o \
+		read_map2D.o \
+		carbon_cycle_mod.o \
+		surf_land_mod.o \
+		albedo.o \
+		surf_land_orchidee_noopenmp_mod.o \
+		cpl_mod.o \
+		atm2geo.o \
+		geo2atm.o \
+		oasis.o \
+		phys_state_var_mod.o \
+		surf_land_orchidee_mod.o \
+		mod_surf_para.o \
+		mod_synchro_omp.o \
+		surf_land_bucket_mod.o \
+		limit_read_mod.o \
+		fonte_neige_mod.o \
+		calcul_fluxs_mod.o \
+		calbeta.o \
+		soil.o \
+		surf_landice_mod.o \
+		surf_ocean_mod.o \
+		limit_slab.o \
+		ocean_forced_mod.o \
+		ocean_slab_mod.o \
+		ocean_cpl_mod.o \
+		surf_seaice_mod.o \
+		climb_hq_mod.o \
+		climb_wind_mod.o \
+		ustarhb.o \
+		vdif_kcay.o \
+		yamada.o \
+		yamada4.o \
+		coefkzmin.o \
+		coef_diff_turb_mod.o \
+		change_srf_frac_mod.o \
+		phys_local_var_mod.o \
+		phys_output_mod.o \
+		phys_output_ctrlout_mod.o \
+		cfmip_point_locations.o \
+		ioipsl_getincom.o \
+		abort_gcm.o \
+		plevel_new.o \
+		plevel.o \
+		orografi.o \
+		orografi_mod.o \
+		orografi_strato_mod.o \
+		nuage.o \
+		nuage_mod.o \
+		conflx.o \
+		radiation_AR4_mod.o \
+		add_phys_tend.o \
+		print_debug_phys.o \
+		hgardfou.o \
+		solarlong.o \
+		phyaqua.o \
+		phyaqua_mod.o \
+		concvl.o \
+		ajsec.o \
+		aaam_bud.o \
+		diagphy.o \
+		diagphy_mod.o \
+		readaerosolstrato.o \
+		mkstat.o \
+		readaerosol_optic.o \
+		aeropt_2bands.o \
+		aeropt_5wv.o \
+		readaerosol_interp.o \
+		readaerosol.o \
+		cva_driver.o \
+		cv_driver.o \
+		cv3p1_closure.o \
+		traclmdz_mod.o \
+		cltracrn.o \
+		radio_decay.o \
+		minmaxqfi.o \
+		initrrnpb.o \
+		init_be.o \
+		o3_chem_m.o \
+		regr_pr_comb_coefoz_m.o \
+		regr_pr_int_m.o \
+		regr1_lint_m.o \
+		press_coefoz_m.o \
+		iostart.o \
+		wstats.o \
+		inistats.o \
+		phyredem.o \
+		hines_gwd.o \
+		ini_undefSTD.o \
+		moy_undefSTD.o \
+		phyetat0.o \
+		transp.o \
+		undefSTD.o \
+		calwake.o \
+		wake.o \
+		newmicro.o \
+		calltherm.o \
+		thermcell_old.o \
+		wrgradsfi.o \
+		thermcell.o \
+		thermcellV0_main.o \
+		thermcell_env.o \
+		thermcell_main.o \
+		fisrtilp.o \
+		stratocu_if.o \
+		phystokenc.o \
+		initphysto.o \
+		ener_conserv.o \
+		tracinca_mod.o \
+		tracreprobus_mod.o \
+		cvltrorig.o \
+		cvltr.o \
+		nflxtr.o \
+		lsc_scav.o \
+		cltrac.o \
+		calcratqs.o \
+		iniphysiq.o \
+		conf_gcm.o \
+		init_phys_lmdz.o \
+		moyglo_aire.o \
+		global_mean.o \
+		wrf_lmdz_mod.o \
+		physiq_limit_variables_mod.o \
+		lmdz_wrf_variables_mod.o \
+		phytrac.o 
+
+DIRECTLMDZSRC = $(DIRECTLMDZOBJS:.o=.F90)
+LMDZSOURCES = $(MODULES:.o=.F90)
+LMDZPRE = $(MODULES:.o=.bb)
+LMDZPOST = $(MODULES:.o=.f90)
+LMDZMOD = $(MODULES:.o=.mod)
+
+NETCDF95OBJS = \
+		nf95_def_var_m.o \
+		nf95_put_var_m.o \
+		nf95_get_var_m.o \
+		nf95_gw_var_m.o \
+		nf95_put_att_m.o \
+		nf95_get_att_m.o \
+		simple.o \
+		handle_err_m.o
+
+NETCDF95SOURCES = $(NETCDF95OBJS:.o=.F90)
+NETCDF95PRE = $(NETCDF95OBJS:.o=.bb)
+NETCDF95POST = $(NETCDF95OBJS:.o=.f90)
+
+OBJS    = physiq.o 
+
+NMM_MODULES =  
+
+LIBTARGET    =  lmdz
+TARGETDIR    =  ./
+
+DIRECTIOIPSLMOD =	\
+        defprec.o \
+	errioipsl.o \
+	stringop.o \
+
+DEPIOIPSLMOD = 	\
+	mathelp.o \
+	getincom.o \
+	calendar.o \
+	fliocom.o \
+	flincom.o \
+	histcom.o \
+	restcom.o \
+	ioipsl.o 
+
+DIRECTIOIPSLSRC = $(DIRECTIOIPSLMOD:.o=.f90)
+
+IOIPSLFOLD = ./IOIPSL
+FULLIOIPSLMODS = $(addprefix $(IOIPSLFOLD)/,$(IOIPSLMOD))
+
+##include ../configure.wrf
+
+all : preprocess lmdz.a 
+
+lmdz.a:		$(MODULES) $(OBJS) $(DIRECTLMDZOBJS) $(DIRECTIOIPSLMOD) $(DEPIOIPSLMOD) $(NETCDF95OBJS)
+		/bin/rm -f lmdz.a
+		$(AR) cr lmdz.a $(MODULES) $(OBJS) $(DIRECTLMDZOBJS) $(DIRECTIOIPSLMOD) $(DEPIOIPSLMOD) $(NETCDF95OBJS)
+
+# IOIPSL
+ 
+$(DIRECTIOIPSLMOD): 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,$(DIRECTIOIPSLSRC))
+
+calendar.o: stringop.o errioipsl.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,calendar.f90)
+
+getincom.o: stringop.o errioipsl.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,getincom.f90)
+
+mathelp.o: stringop.o errioipsl.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,mathelp.f90)
+
+flincom.o: stringop.o errioipsl.o calendar.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,flincom.f90)
+
+fliocom.o: stringop.o errioipsl.o calendar.o defprec.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,fliocom.f90)
+
+histcom.o: stringop.o errioipsl.o calendar.o mathelp.o fliocom.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,histcom.f90)
+
+restcom.o: stringop.o errioipsl.o calendar.o mathelp.o fliocom.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,restcom.f90)
+
+ioipsl.o: $(DIRECTIOIPSLMOD) getincom.o calendar.o mathelp.o flincom.o fliocom.o histcom.o restcom.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) $(addprefix $(IOIPSLFOLD)/,ioipsl.f90)
+
+# LMDZ
+#
+preprocess: $(LMDZPOST) $(NETCDF95POST)
+
+$(LMDZPOST): %.f90: %.bb
+		$(WRFcode) $< | $(CPP) > $@
+		rm $<
+
+$(LMDZPRE): %.bb: %.F90
+		$(CPP) $(ARCHFLAGS) $< > $@
+
+$(NETCDF95POST): %.f90: %.bb
+		$(WRFcode) $< | $(CPP) > $@
+		rm $<
+
+$(NETCDF95PRE): %.bb: %.F90
+		$(CPP) $(ARCHFLAGS) $< > $@
+
+$(DIRECTLMDZOBJS): 
+		$(FC) $(FCLMDZFLAGS) $(DIRECTLMDZSRC)
+
+infotrac.o: control_mod.o
+		$(FC) $(FCLMDZFLAGS) infotrac.f90
+
+
+mod_phys_lmdz_mpi_data.o: mod_const_mpi.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_mpi_data.f90
+
+ioipsl_getincom.o: ioipsl_errioipsl.o ioipsl_stringop.o
+		$(FC) $(FCLMDZFLAGS) ioipsl_getincom.f90
+
+abort_gcm.o: ioipsl.o ioipsl_getincom.o
+		$(FC) $(FCLMDZFLAGS) abort_gcm.f90
+
+write_field.o: 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) write_field.f90
+
+mod_phys_lmdz_omp_data.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_omp_data.f90
+
+mod_phys_lmdz_omp_transfert.o: mod_phys_lmdz_mpi_data.o mod_phys_lmdz_omp_data.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_omp_transfert.f90
+
+mod_phys_lmdz_mpi_transfert.o: mod_phys_lmdz_mpi_data.o mod_grid_phy_lmdz.o  mod_phys_lmdz_omp_transfert.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_mpi_transfert.f90
+
+mod_phys_lmdz_transfert_para.o: mod_phys_lmdz_mpi_transfert.o mod_phys_lmdz_omp_transfert.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_transfert_para.f90
+
+mod_phys_lmdz_para.o: mod_phys_lmdz_transfert_para.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_omp_data.o mod_grid_phy_lmdz.o
+		$(FC) $(FCLMDZFLAGS) mod_phys_lmdz_para.f90
+
+comgeomphy.o: mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) comgeomphy.f90
+
+handle_err_m.o: 
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) handle_err_m.f90
+
+nf95_def_var_m.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_def_var_m.f90
+
+nf95_put_var_m.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_put_var_m.f90
+
+nf95_get_var_m.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_get_var_m.f90
+
+simple.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) simple.f90
+
+nf95_gw_var_m.o: handle_err_m.o simple.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_gw_var_m.f90
+
+nf95_put_att_m.o: handle_err_m.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_put_att_m.f90
+
+nf95_get_att_m.o: handle_err_m.o simple.o
+		$(FC) $(FCLMDZFLAGS)  $(LIB_NETCDF) $(INC_NETCDF) nf95_get_att_m.f90
+
+netcdf95.o: $(NETCDF95OBJS) 
+		$(FC) $(FCLMDZFLAGS) netcdf95.f90
+
+open_climoz_m.o: mod_phys_lmdz_mpi_data.o mod_phys_lmdz_mpi_transfert.o netcdf95.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) open_climoz_m.f90
+
+regr1_step_av_m.o: assert_eq_m.o assert_m.o interpolation.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) regr1_step_av_m.f90
+
+regr_pr_av_m.o: dimphy.o netcdf95.o assert_m.o assert_eq_m.o regr1_step_av_m.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_transfert_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) regr_pr_av_m.f90
+
+ozonecm_m.o: dimphy.o assert_m.o
+		$(FC) $(FCLMDZFLAGS) ozonecm_m.f90
+
+conf_phys_m.o: ioipsl.o surface_data.o phys_cal_mod.o carbon_cycle_mod.o control_mod.o
+		$(FC) $(FCLMDZFLAGS) conf_phys_m.f90
+
+radiation_AR4_mod.o: dimphy.o radiation_ar4_param.o
+		$(FC) $(FCLMDZFLAGS) radiation_AR4_mod.f90	
+
+sw_aeroAR4.o: dimphy.o phys_output_mod.o radiation_AR4_mod.o
+		$(FC) $(FCLMDZFLAGS) sw_aeroAR4.f90	
+
+radlwsw_m.o: dimphy.o assert_m.o infotrac.o radiation_AR4_mod.o sw_aeroAR4.o
+		$(FC) $(FCLMDZFLAGS) radlwsw_m.f90
+
+phys_cal_mod.o: ioipsl.o
+		$(FC) $(FCLMDZFLAGS) phys_cal_mod.f90
+
+write_field_phy.o: write_field.o
+		$(FC) $(FCLMDZFLAGS) write_field_phy.f90
+
+iophy.o: ioipsl.o phys_output_var_mod.o write_field.o
+		$(FC) $(FCLMDZFLAGS) iophy.f90
+
+read_map2D.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) read_map2D.f90
+
+carbon_cycle_mod.o: dimphy.o comgeomphy.o mod_phys_lmdz_transfert_para.o infotrac.o ioipsl.o surface_data.o phys_cal_mod.o indice_sol_mod.o read_map2D.o
+		$(FC) $(FCLMDZFLAGS) carbon_cycle_mod.f90
+
+oasis.o:
+ifeq ($(ARCHFLAGS), -DCPP_COUPLE)
+oasis.o: dimphy.o mod_phys_lmdz_para.o write_field_phy.o mod_prism_proto.o mod_prism_def_partition_proto.o mod_prism_get_proto.o mod_prism_put_proto.o ioipsl.o surface_data.o carbon_cycle_mod.o
+		$(FC) $(FCLMDZFLAGS) oasis.f90
+else
+oasis.o: dimphy.o mod_phys_lmdz_para.o write_field_phy.o ioipsl.o surface_data.o carbon_cycle_mod.o
+		$(FC) $(FCLMDZFLAGS) oasis.f90
+endif
+
+phys_state_var_mod.o: dimphy.o control_mod.o aero_mod.o infotrac.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) phys_state_var_mod.f90
+
+atm2geo.o: dimphy.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) atm2geo.f90
+
+geo2atm.o: dimphy.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) geo2atm.f90
+
+cpl_mod.o: dimphy.o mod_phys_lmdz_para.o ioipsl.o iophy.o oasis.o write_field_phy.o control_mod.o carbon_cycle_mod.o surface_data.o indice_sol_mod.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) cpl_mod.f90
+
+surf_land_orchidee_noopenmp_mod.o:
+ifeq ($(ARCHFLAGS), -DORCHIDEE_NOOPENMP)
+intersurf.o: 
+		$(FC) $(FCLMDZFLAGS) intersurf.f90
+
+surf_land_orchidee_noopenmp_mod.o: dimphy.o intersurf.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_noopenmp_mod.f90
+else
+surf_land_orchidee_noopenmp_mod.o: dimphy.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_noopenmp_mod.f90
+endif
+ifeq ($(ARCHFLAGS), -DCPP_VEGET)
+intersurf.o: 
+		$(FC) $(FCLMDZFLAGS) intersurf.f90
+
+surf_land_orchidee_noopenmp_mod.o: dimphy.o intersurf.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o carbon_cycle_mod.o indice_sol_mod.o
+		rm surf_land_orchidee_noopenmp_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_noopenmp_mod.f90
+else
+surf_land_orchidee_noopenmp_mod.o: dimphy.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_noopenmp_mod.f90
+endif
+
+mod_surf_para.o: mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) mod_surf_para.f90
+
+mod_synchro_omp.o: mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) mod_synchro_omp.f90
+
+surf_land_orchidee_mod.o: 
+ifeq ($(ARCHFLAGS), -DORCHIDEE_NOOPENMP)
+intersurf.o: 
+		$(FC) $(FCLMDZFLAGS) intersurf.f90
+
+surf_land_orchidee_mod.o: dimphy.o intersurf.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o mod_surf_para.o mod_synchro_omp.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_mod.f90
+else
+surf_land_orchidee_mod.o: dimphy.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o mod_surf_para.o mod_synchro_omp.o carbon_cycle_mod.o indice_sol_mod.o
+endif
+ifeq ($(ARCHFLAGS), -DCPP_VEGET)
+intersurf.o: 
+		$(FC) $(FCLMDZFLAGS) intersurf.f90
+
+surf_land_orchidee_mod.o: dimphy.o intersurf.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o mod_surf_para.o mod_synchro_omp.o carbon_cycle_mod.o indice_sol_mod.o
+		rm surf_land_orchidee_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_mod.f90
+else
+surf_land_orchidee_mod.o: dimphy.o cpl_mod.o surface_data.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o mod_surf_para.o mod_synchro_omp.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_orchidee_mod.f90
+endif
+
+limit_read_mod.o: dimphy.o indice_sol_mod.o surface_data.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) limit_read_mod.f90
+
+phys_local_var_mod.o: dimphy.o infotrac.o aero_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) phys_local_var_mod.f90
+
+calbeta.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) calbeta.f90
+
+soil.o: dimphy.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) soil.f90
+
+calcul_fluxs_mod.o: dimphy.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) calcul_fluxs_mod.f90
+
+fonte_neige_mod.o: dimphy.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) fonte_neige_mod.f90
+
+limit_slab.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) limit_slab.f90
+
+surf_land_bucket_mod.o: limit_read_mod.o surface_data.o fonte_neige_mod.o calcul_fluxs_mod.o cpl_mod.o dimphy.o comgeomphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o indice_sol_mod.o albsno.o calbeta_clim.o calbeta.o soil.o NOread_limit_sub_variables.o
+		$(FC) $(FCLMDZFLAGS) surf_land_bucket_mod.f90
+
+surf_land_mod.o: dimphy.o surface_data.o surf_land_orchidee_noopenmp_mod.o surf_land_orchidee_mod.o surf_land_bucket_mod.o calcul_fluxs_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_land_mod.f90
+
+surf_landice_mod.o: dimphy.o surface_data.o fonte_neige_mod.o cpl_mod.o calcul_fluxs_mod.o phys_output_var_mod.o indice_sol_mod.o albsno.o soil.o
+		$(FC) $(FCLMDZFLAGS) surf_landice_mod.f90
+
+ocean_forced_mod.o: dimphy.o calcul_fluxs_mod.o limit_read_mod.o indice_sol_mod.o surface_data.o fonte_neige_mod.o calbeta.o soil.o albsno.o NOread_limit_sub_variables.o
+		$(FC) $(FCLMDZFLAGS) ocean_forced_mod.f90
+
+ocean_slab_mod.o: dimphy.o limit_read_mod.o surface_data.o indice_sol_mod.o calcul_fluxs_mod.o limit_slab.o
+		$(FC) $(FCLMDZFLAGS) ocean_slab_mod.f90
+
+ocean_cpl_mod.o: dimphy.o cpl_mod.o calcul_fluxs_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) ocean_cpl_mod.f90
+
+albedo.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) albedo.f90
+
+surf_ocean_mod.o: dimphy.o surface_data.o ocean_forced_mod.o ocean_slab_mod.o ocean_cpl_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_ocean_mod.f90
+
+surf_seaice_mod.o: dimphy.o surface_data.o ocean_forced_mod.o ocean_cpl_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) surf_seaice_mod.f90
+
+climb_hq_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) climb_hq_mod.f90
+
+climb_wind_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) climb_wind_mod.f90
+
+yamada4.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) yamada4.f90
+
+yamada.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) yamada.f90
+
+vdif_kcay.o: dimphy.o yamada.o
+		$(FC) $(FCLMDZFLAGS) vdif_kcay.f90
+
+ustarhb.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) ustarhb.f90
+
+coefkzmin.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) coefkzmin.f90
+
+coef_diff_turb_mod.o: dimphy.o indice_sol_mod.o yamada4.o vdif_kcay.o ustarhb.o coefkzmin.o
+		$(FC) $(FCLMDZFLAGS) coef_diff_turb_mod.f90
+
+stdlevvar.o: coefcdrag.o screenp.o screenc.o
+		$(FC) $(FCLMDZFLAGS) stdlevvar.f90
+
+clcdrag.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) clcdrag.f90
+
+hbtm.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) hbtm.f90
+
+yamada_c.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) yamada_c.f90
+
+pbl_surface_mod.o: dimphy.o mod_phys_lmdz_para.o ioipsl.o surface_data.o surf_land_mod.o surf_landice_mod.o surf_ocean_mod.o surf_seaice_mod.o cpl_mod.o climb_hq_mod.o climb_wind_mod.o coef_diff_turb_mod.o control_mod.o indice_sol_mod.o carbon_cycle_mod.o clcdrag.o stdlevvar.o hbtm.o yamada_c.o
+		$(FC) $(FCLMDZFLAGS) pbl_surface_mod.f90
+
+change_srf_frac_mod.o: dimphy.o surface_data.o limit_read_mod.o pbl_surface_mod.o cpl_mod.o ocean_slab_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) change_srf_frac_mod.f90
+
+phys_output_mod.o: indice_sol_mod.o phys_output_var_mod.o phys_output_ctrlout_mod.o aero_mod.o iophy.o dimphy.o infotrac.o ioipsl.o phys_cal_mod.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) phys_output_mod.f90
+
+phys_output_ctrlout_mod.o: phys_output_var_mod.o indice_sol_mod.o aero_mod.o
+		$(FC) $(FCLMDZFLAGS) phys_output_ctrlout_mod.f90
+
+cfmip_point_locations.o: dimphy.o iophy.o mod_grid_phy_lmdz.o
+		$(FC) $(FCLMDZFLAGS) cfmip_point_locations.f90
+
+mkstat.o: 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) mkstat.f90
+
+plevel_new.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) plevel_new.f90
+
+plevel.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) plevel.f90
+
+orografi_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) orografi_mod.f90
+
+orografi.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) orografi.f90
+
+orografi_strato_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) orografi_strato_mod.f90
+
+orografi_strato.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) orografi_strato.f90
+
+nuage_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) nuage_mod.f90
+
+nuage.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) nuage.f90
+
+conflx.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) conflx.f90
+
+hgardfou.o: dimphy.o phys_state_var_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) hgardfou.f90
+
+print_debug_phys.o: dimphy.o phys_state_var_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) print_debug_phys.f90
+
+add_phys_tend.o: dimphy.o phys_local_var_mod.o phys_state_var_mod.o print_debug_phys.o hgardfou.o
+		$(FC) $(FCLMDZFLAGS) add_phys_tend.f90
+
+solarlong.o: ioipsl.o iniorbit.o
+		$(FC) $(FCLMDZFLAGS) solarlong.f90
+
+phyaqua_mod.o: comgeomphy.o dimphy.o surface_data.o pbl_surface_mod.o fonte_neige_mod.o phys_state_var_mod.o control_mod.o indice_sol_mod.o ioipsl.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) phyaqua_mod.f90
+
+phyaqua.o: comgeomphy.o dimphy.o surface_data.o pbl_surface_mod.o fonte_neige_mod.o phys_state_var_mod.o control_mod.o indice_sol_mod.o ioipsl.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) phyaqua.f90
+
+ajsec.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) ajsec.f90
+
+aaam_bud.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) aaam_bud.f90
+
+diagphy.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) diagphy.f90
+
+diagphy_mod.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) diagphy_mod.f90
+
+readaerosolstrato.o: netcdf95.o phys_cal_mod.o mod_grid_phy_lmdz.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_para.o phys_state_var_mod.o phys_local_var_mod.o aero_mod.o dimphy.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) readaerosolstrato.f90
+
+aeropt_2bands.o: dimphy.o aero_mod.o phys_cal_mod.o pres2lev_mod.o
+		$(FC) $(FCLMDZFLAGS) aeropt_2bands.f90
+
+aeropt_5wv.o: dimphy.o aero_mod.o phys_local_var_mod.o pres2lev_mod.o
+		$(FC) $(FCLMDZFLAGS) aeropt_5wv.f90
+
+readaerosol_mod.o: readaerosol.o
+
+readaerosol.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) readaerosol.f90
+
+readaerosol_interp.o: dimphy.o mod_phys_lmdz_para.o readaerosol_mod.o aero_mod.o write_field_phy.o phys_cal_mod.o pres2lev_mod.o
+		$(FC) $(FCLMDZFLAGS) readaerosol_interp.f90
+
+readaerosol_optic.o: dimphy.o aero_mod.o phys_local_var_mod.o readaerosol_interp.o aeropt.o
+		$(FC) $(FCLMDZFLAGS) readaerosol_optic.f90
+
+cv3p1_closure.o: cv3_cine.o cv3_buoy.o
+		$(FC) $(FCLMDZFLAGS) cv3p1_closure.f90
+
+cv_driver.o: dimphy.o cv_routines.o cv30_routines.o cv3p1_closure.o
+		$(FC) $(FCLMDZFLAGS) cv_driver.f90
+
+cva_driver.o: dimphy.o zilch.o cv_routines.o cv3_routines.o
+		$(FC) $(FCLMDZFLAGS) cva_driver.f90
+
+concvl.o: dimphy.o infotrac.o cv_driver.o cva_driver.o cv3_inip.o
+		$(FC) $(FCLMDZFLAGS) concvl.f90
+
+regr1_lint_m.o: assert_eq_m.o interpolation.o
+		$(FC) $(FCLMDZFLAGS) regr1_lint_m.f90
+
+regr_pr_int_m.o: dimphy.o netcdf95.o assert_m.o regr1_lint_m.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_transfert_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) regr_pr_int_m.f90
+
+regr_pr_comb_coefoz_m.o: dimphy.o netcdf95.o assert_m.o mod_phys_lmdz_mpi_data.o regr_pr_av_m.o regr_pr_int_m.o press_coefoz_m.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) regr_pr_comb_coefoz_m.f90
+
+press_coefoz_m.o: netcdf95.o mod_phys_lmdz_mpi_data.o mod_phys_lmdz_mpi_transfert.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) press_coefoz_m.f90
+
+o3_chem_m.o: dimphy.o assert_m.o regr_pr_comb_coefoz_m.o 
+		$(FC) $(FCLMDZFLAGS) o3_chem_m.f90
+
+initrrnpb.o: dimphy.o infotrac.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) initrrnpb.f90
+
+init_be.o: dimphy.o comgeomphy.o infotrac.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) init_be.f90
+
+minmaxqfi.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) minmaxqfi.f90
+
+radio_decay.o: dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) radio_decay.f90
+
+cltracrn.o: dimphy.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) cltracrn.f90
+
+traclmdz_mod.o: dimphy.o infotrac.o regr_pr_comb_coefoz_m.o press_coefoz_m.o carbon_cycle_mod.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o indice_sol_mod.o o3_chem_m.o q_sat.o cltracrn.o minmaxqfi.o initrrnpb.o
+		$(FC) $(FCLMDZFLAGS) traclmdz_mod.f90
+
+inistats.o: 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) inistats.f90
+
+wstats.o: inistats.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) wstats.f90
+
+iostart.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) iostart.f90
+
+wake.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) wake.f90
+
+calwake.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) calwake.f90
+
+hines_gwd.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) hines_gwd.f90
+
+ini_undefSTD.o: dimphy.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) ini_undefSTD.f90
+
+moy_undefSTD.o: dimphy.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) moy_undefSTD.f90
+
+newmicro.o: dimphy.o phys_local_var_mod.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) newmicro.f90
+
+phyetat0.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o iophy.o ocean_cpl_mod.o fonte_neige_mod.o pbl_surface_mod.o surface_data.o phys_state_var_mod.o iostart.o write_field_phy.o infotrac.o traclmdz_mod.o carbon_cycle_mod.o indice_sol_mod.o 
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) phyetat0.f90
+
+transp.o: dimphy.o 
+		$(FC) $(FCLMDZFLAGS) transp.f90
+
+undefSTD.o: dimphy.o phys_state_var_mod.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) undefSTD.f90
+
+stratocu_if.o: indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) stratocu_if.f90
+
+thermcell.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) thermcell.f90
+
+wrgradsfi.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o wrgrads.o gr_fi_dyn.o 
+		$(FC) $(FCLMDZFLAGS) wrgradsfi.f90
+
+thermcell_old.o: dimphy.o thermcell.o
+		$(FC) $(FCLMDZFLAGS) thermcell_old.f90
+
+thermcell_env.o: thermcell_qsat.o
+		$(FC) $(FCLMDZFLAGS) thermcell_env.f90
+
+thermcellV0_main.o: dimphy.o comgeomphy.o thermcell_env.o thermcell_height.o thermcell_flux2.o thermcell_dq.o thermcell_dv2.o 
+		$(FC) $(FCLMDZFLAGS) thermcellV0_main.f90
+
+thermcell_main.o: dimphy.o comgeomphy.o indice_sol_mod.o thermcell_env.o thermcell_plume.o thermcell_height.o thermcell_dry.o thermcell_closure.o thermcell_flux2.o thermcell_dq.o thermcell_dv2.o  
+		$(FC) $(FCLMDZFLAGS) thermcell_main.f90
+
+calltherm.o: indice_sol_mod.o dimphy.o thermcell_old.o thermcellV0_main.o thermcell_main.o
+		$(FC) $(FCLMDZFLAGS) calltherm.f90
+
+callcratqs.o: clouds_gno.o
+		$(FC) $(FCLMDZFLAGS) callcratqs.f90
+
+fisrtilp.o: dimphy.o cloudth.o
+		$(FC) $(FCLMDZFLAGS) fisrtilp.f90
+
+tracinca_mod.o: dimphy.o infotrac.o vampir.o comgeomphy.o control_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) tracinca_mod.f90
+
+tracreprobus_mod.o: dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) tracreprobus_mod.f90
+
+cvltrorig.o: dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) cvltrorig.f90
+
+cvltr.o: dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) cvltr.f90
+
+nflxtr.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) nflxtr.f90
+
+lsc_scav.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o traclmdz_mod.o infotrac.o comgeomphy.o iophy.o
+		$(FC) $(FCLMDZFLAGS) lsc_scav.f90
+
+cltrac.o: dimphy.o 
+		$(FC) $(FCLMDZFLAGS) cltrac.f90
+
+phytrac.o: phys_cal_mod.o phys_output_mod.o dimphy.o infotrac.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o comgeomphy.o iophy.o traclmdz_mod.o tracinca_mod.o tracreprobus_mod.o control_mod.o indice_sol_mod.o cvltrorig.o cvltr.o nflxtr.o lsc_scav.o cltrac.o
+		$(FC) $(FCLMDZFLAGS) phytrac.f90
+
+initphysto.o: dimphy.o mod_phys_lmdz_para.o ioipsl.o iophy.o control_mod.o indice_sol_mod.o 
+		$(FC) $(FCLMDZFLAGS) initphysto.f90
+
+phystokenc.o: dimphy.o infotrac.o iophy.o control_mod.o indice_sol_mod.o initphysto.o
+		$(FC) $(FCLMDZFLAGS) phystokenc.f90
+
+ener_conserv.o: phys_local_var_mod.o phys_output_var_mod.o
+		$(FC) $(FCLMDZFLAGS) ener_conserv.f90
+
+calcratqs.o: clouds_gno.o
+		$(FC) $(FCLMDZFLAGS) calcratqs.f90
+
+conf_gcm.o: control_mod.o ioipsl.o ioipsl_getincom.o ioipsl.o infotrac.o assert_m.o
+		$(FC) $(FCLMDZFLAGS) conf_gcm.f90
+
+iniphysiq.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o comgeomphy.o suphel.o comcstphy.o phyaqua.o
+		$(FC) $(FCLMDZFLAGS) iniphysiq.f90
+
+init_phys_lmdz.o: mod_phys_lmdz_para.o mod_grid_phy_lmdz.o dimphy.o infotrac.o
+		$(FC) $(FCLMDZFLAGS) init_phys_lmdz.f90
+
+moyglo_aire.o: dimphy.o
+		$(FC) $(FCLMDZFLAGS) moyglo_aire.f90
+
+global_mean.o: dimphy.o mod_phys_lmdz_para.o mod_phys_lmdz_transfert_para.o mod_phys_lmdz_mpi_data.o
+		$(FC) $(FCLMDZFLAGS) global_mean.f90
+
+phyredem.o: dimphy.o mod_grid_phy_lmdz.o mod_phys_lmdz_para.o fonte_neige_mod.o pbl_surface_mod.o phys_state_var_mod.o iostart.o traclmdz_mod.o infotrac.o control_mod.o carbon_cycle_mod.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) phyredem.f90
+
+wrf_lmdz_mod.o: ../frame/module_domain_type.o indice_sol_mod.o phys_state_var_mod.o phys_output_var_mod.o output_lmdz_NOmodule.o suphel.o pbl_surface_mod.o phys_local_var_mod.o comgeomphy.o
+		$(FC) $(FCLMDZFLAGS) wrf_lmdz_mod.f90
+
+##module_lmdz_variables.o: pbl_surface_mod.o indice_sol_mod.o fonte_neige_mod.o dimphy.o
+##		$(FC) $(FCLMDZFLAGS) module_lmdz_variables.f90
+
+physiq_limit_variables_mod.o: mod_grid_phy_lmdz.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) physiq_limit_variables_mod.f90
+
+lmdz_wrf_variables_mod.o: mod_grid_phy_lmdz.o indice_sol_mod.o
+		$(FC) $(FCLMDZFLAGS) lmdz_wrf_variables_mod.f90
+
+%.o: %.mod
+		@true
+
+physiq.o : $(MODULES) $(DIRECTLMDZOBJS) netcdf95.o ../frame/module_domain.o
+		$(CPP) $(ARCHFLAGS) physiq.F90 > physiq.bb
+		$(WRFcode) physiq.bb | $(CPP) > physiq.f90
+		rm physiq.bb
+		$(FC) $(FCLMDZFLAGS) $(LIB_NETCDF) $(INC_NETCDF) physiq.f90
+
+clean:
+	rm *.f90 *.o *.a *.mod
+	@ echo 'use the clean script'
+
+# DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES)
+
+# DO NOT DELETE
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/NOread_limit_sub_variables.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/NOread_limit_sub_variables.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/NOread_limit_sub_variables.F90	(revision 17)
@@ -0,0 +1,33 @@
+MODULE NOread_limit_sub_variables
+! Module to create SAVE definitions for that variables that were used in the 
+!   subroutines when 'limit.nc' or 'startphy.nc' were read
+
+  IMPLICIT NONE
+
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE                  :: tsurf_limit
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE                  :: z0_limit
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE                  :: alb_limit
+
+  CONTAINS
+
+  SUBROUTINE NOread_limit_init(dlmdz, kglo)
+! Subroutine to initialize the variables not readed from 'limit.nc'
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: dlmdz, kglo
+
+    IF (ALLOCATED(tsurf_limit)) DEALLOCATE(tsurf_limit)
+    ALLOCATE(tsurf_limit(dlmdz))
+
+    IF (ALLOCATED(z0_limit)) DEALLOCATE(z0_limit)
+    ALLOCATE(z0_limit(dlmdz))
+
+    IF (ALLOCATED(alb_limit)) DEALLOCATE(alb_limit)
+    ALLOCATE(alb_limit(dlmdz))
+
+    RETURN
+
+  END SUBROUTINE NOread_limit_init
+
+END MODULE NOread_limit_sub_variables
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/YOECUMF.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/YOECUMF.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/YOECUMF.h	(revision 17)
@@ -0,0 +1,48 @@
+!
+! $Id: YOECUMF.h 1279 2009-12-10 09:02:56Z fairhead $
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez n'utiliser que des ! pour les commentaires
+!                 et bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!     ----------------------------------------------------------------
+!*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
+!     ----------------------------------------------------------------
+!
+      COMMON /YOECUMF/                                                  &
+     &                 LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV,              &
+     &                 ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP,          &
+     &                 CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON
+
+      LOGICAL          LMFPEN,LMFSCV,LMFMID,LMFDD,LMFDUDV
+      REAL ENTRPEN, ENTRSCV, ENTRMID, ENTRDD
+      REAL CMFCTOP, CMFCMAX, CMFCMIN, CMFDEPS, RHCDD, CPRCON
+!$OMP THREADPRIVATE(/YOECUMF/)
+!
+!*if (DOC,declared) <> 'UNKNOWN'
+!*    *COMMON* *YOECUMF* - PARAMETERS FOR CUMULUS MASSFLUX SCHEME
+!
+!     M.TIEDTKE       E. C. M. W. F.      18/1/89
+!
+!     NAME      TYPE      PURPOSE
+!     ----      ----      -------
+!
+!     LMFPEN    LOGICAL  TRUE IF PENETRATIVE CONVECTION IS SWITCHED ON
+!     LMFSCV    LOGICAL  TRUE IF SHALLOW     CONVECTION IS SWITCHED ON
+!     LMFMID    LOGICAL  TRUE IF MIDLEVEL    CONVECTION IS SWITCHED ON
+!     LMFDD     LOGICAL  TRUE IF CUMULUS DOWNDRAFT      IS SWITCHED ON
+!     LMFDUDV   LOGICAL  TRUE IF CUMULUS FRICTION       IS SWITCHED ON
+!     ENTRPEN   REAL     ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+!     ENTRSCV   REAL     ENTRAINMENT RATE FOR SHALLOW CONVECTION
+!     ENTRMID   REAL     ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+!     ENTRDD    REAL     ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS
+!     CMFCTOP   REAL     RELAT. CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANC
+!     CMFCMAX   REAL     MAXIMUM MASSFLUX VALUE ALLOWED FOR
+!     CMFCMIN   REAL     MINIMUM MASSFLUX VALUE (FOR SAFETY)
+!     CMFDEPS   REAL     FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+!     RHCDD     REAL     RELATIVE SATURATION IN DOWNDRAFTS
+!     CPRCON    REAL     COEFFICIENTS FOR DETERMINING CONVERSION
+!                        FROM CLOUD WATER TO RAIN
+!*ifend
+!     ----------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/YOEGWD.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/YOEGWD.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/YOEGWD.h	(revision 17)
@@ -0,0 +1,17 @@
+!
+! $Header$
+!
+!  ATTENTION : ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!     -----------------------------------------------------------------
+!*    *COMMON* *YOEGWD* - PARAMETERS FOR GRAVITY WAVE DRAG CALCULATIONS
+!     -----------------------------------------------------------------
+!
+      integer NKTOPG,NSTRA
+      real GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT
+      real GHMAX,GRAHILO,GSIGCR,GSSEC,GTSEC,GVSEC
+      COMMON/YOEGWD/ GFRCRIT,GKWAKE,GRCRIT,GVCRIT,GKDRAG,GKLIFT         &
+     &        ,GHMAX,GRAHILO,GSIGCR,NKTOPG,NSTRA,GSSEC,GTSEC,GVSEC
+!$OMP THREADPRIVATE(/YOEGWD/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/YOETHF.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/YOETHF.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/YOETHF.h	(revision 17)
@@ -0,0 +1,21 @@
+!
+! $Header$
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!*    COMMON *YOETHF* DERIVED CONSTANTS SPECIFIC TO ECMWF THERMODYNAMICS
+!
+!     *R__ES*   *CONSTANTS USED FOR COMPUTATION OF SATURATION
+!                MIXING RATIO OVER LIQUID WATER(*R_LES*) OR
+!                ICE(*R_IES*).
+!     *RVTMP2*  *RVTMP2=RCPV/RCPD-1.
+!     *RHOH2O*  *DENSITY OF LIQUID WATER.   (RATM/100.)
+!
+      REAL R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES
+      REAL RVTMP2, RHOH2O
+      COMMON /YOETHF/R2ES, R3LES, R3IES, R4LES, R4IES, R5LES, R5IES,    &
+     &               RVTMP2, RHOH2O
+!$OMP THREADPRIVATE(/YOETHF/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/YOMCST.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/YOMCST.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/YOMCST.h	(revision 17)
@@ -0,0 +1,44 @@
+!
+! $Header$
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez a n-utiliser que des ! pour les commentaires
+!                 et a bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+! A1.0 Fundamental constants
+      REAL RPI,RCLUM,RHPLA,RKBOL,RNAVO
+! A1.1 Astronomical constants
+      REAL RDAY,REA,REPSM,RSIYEA,RSIDAY,ROMEGA
+! A1.1.bis Constantes concernant l-orbite de la Terre:
+      REAL R_ecc, R_peri, R_incl
+! A1.2 Geoide
+      REAL RA,RG,R1SA
+! A1.3 Radiation
+!     REAL RSIGMA,RI0
+      REAL RSIGMA
+! A1.4 Thermodynamic gas phase
+      REAL R,RMD,RMO3,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV
+      REAL RKAPPA,RETV
+! A1.5,6 Thermodynamic liquid,solid phases
+      REAL RCW,RCS
+! A1.7 Thermodynamic transition of phase
+      REAL RLVTT,RLSTT,RLMLT,RTT,RATM
+! A1.8 Curve of saturation
+      REAL RESTT,RALPW,RBETW,RGAMW,RALPS,RBETS,RGAMS
+      REAL RALPD,RBETD,RGAMD
+!
+      COMMON/YOMCST/RPI   ,RCLUM ,RHPLA ,RKBOL ,RNAVO                   &
+     &      ,RDAY  ,REA   ,REPSM ,RSIYEA,RSIDAY,ROMEGA                  &
+     &      ,R_ecc, R_peri, R_incl                                      &
+     &      ,RA    ,RG    ,R1SA                                         &
+     &      ,RSIGMA                                                     &
+     &      ,R     ,RMD   ,RMO3  ,RMV   ,RD    ,RV    ,RCPD             &
+     &      ,RCPV  ,RCVD  ,RCVV  ,RKAPPA,RETV                           &
+     &      ,RCW   ,RCS                                                 &
+     &      ,RLVTT ,RLSTT ,RLMLT ,RTT   ,RATM                           &
+     &      ,RESTT ,RALPW ,RBETW ,RGAMW ,RALPS ,RBETS ,RGAMS            &
+     &      ,RALPD ,RBETD ,RGAMD
+!    ------------------------------------------------------------------
+!$OMP THREADPRIVATE(/YOMCST/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/YOMCST2.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/YOMCST2.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/YOMCST2.h	(revision 17)
@@ -0,0 +1,13 @@
+
+      INTEGER choice, iflag_mix
+      REAL  gammas, alphas, betas, Fmax, qqa1, qqa2, qqa3, scut
+      REAL  Qcoef1max,Qcoef2max,Supcrit1,Supcrit2
+!
+      COMMON/YOMCST2/gammas,    alphas, betas, Fmax, scut,              &
+     &               qqa1, qqa2, qqa3,                                  &
+     &               Qcoef1max,Qcoef2max,                               &
+     &               Supcrit1, Supcrit2,                                &
+     &               choice,iflag_mix
+!$OMP THREADPRIVATE(/YOMCST2/)
+!    --------------------------------------------------------------------
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/aaam_bud.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/aaam_bud.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/aaam_bud.F	(revision 17)
@@ -0,0 +1,372 @@
+!
+! $Id: aaam_bud.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      subroutine aaam_bud (iam,nlon,nlev,rjour,rsec,
+     i                   rea,rg,ome,      
+     i                   plat,plon,phis,
+     i                   dragu,liftu,phyu,
+     i                   dragv,liftv,phyv,
+     i                   p, u, v,
+     o                   aam, torsfc)
+c
+      use dimphy
+      implicit none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 20031020
+c Object: Compute different terms of the axial AAAM Budget.
+C No outputs, every AAM quantities are written on the IAM
+C File. 
+c
+c Modif : I.Musat (LMD/CNRS) date : 20041020
+c Outputs : axial components of wind AAM "aam" and total surface torque "torsfc",
+c but no write in the iam file.
+c
+C WARNING: Only valid for regular rectangular grids.
+C REMARK: CALL DANS PHYSIQ AFTER lift_noro:
+C        CALL aaam_bud (27,klon,klev,rjourvrai,gmtime,
+C    C               ra,rg,romega,
+C    C               rlat,rlon,pphis,
+C    C               zustrdr,zustrli,zustrph,
+C    C               zvstrdr,zvstrli,zvstrph,
+C    C               paprs,u,v)
+C
+C======================================================================
+c Explicit Arguments:
+c ==================
+c iam-----input-I-File number where AAMs and torques are written
+c                 It is a formatted file that has been opened
+c                 in physiq.F
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c rjour        -R-Jour compte depuis le debut de la simu (run.def)
+c rsec         -R-Seconde de la journee
+c rea          -R-Earth radius
+c rg           -R-gravity constant
+c ome          -R-Earth rotation rate
+c plat ---input-R-Latitude en degres
+c plon ---input-R-Longitude en degres
+c phis ---input-R-Geopotential at the ground
+c dragu---input-R-orodrag stress (zonal)
+c liftu---input-R-orolift stress (zonal)
+c phyu----input-R-Stress total de la physique (zonal)
+c dragv---input-R-orodrag stress (Meridional)
+c liftv---input-R-orolift stress (Meridional)
+c phyv----input-R-Stress total de la physique (Meridional)
+c p-------input-R-Pressure (Pa) at model half levels
+c u-------input-R-Horizontal wind (m/s)
+c v-------input-R-Meridional wind (m/s)
+c aam-----output-R-Axial Wind AAM (=raam(3))
+c torsfc--output-R-Total surface torque (=tmou(3)+tsso(3)+tbls(3))
+c
+c Implicit Arguments:
+c ===================
+c
+c iim--common-I: Number of longitude intervals
+c jjm--common-I: Number of latitude intervals
+c klon-common-I: Number of points seen by the physics
+c                iim*(jjm-1)+2 for instance
+c klev-common-I: Number of vertical layers
+c======================================================================
+c Local Variables:
+c ================
+c dlat-----R: Latitude increment (Radians)
+c dlon-----R: Longitude increment (Radians)
+c raam  ---R: Wind AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
+c oaam  ---R: Mass AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
+c tmou-----R: Resolved Mountain torque (3 components)
+c tsso-----R: Parameterised Moutain drag torque (3 components)
+c tbls-----R: Parameterised Boundary layer torque (3 components)
+c
+c LOCAL ARRAY:
+c ===========
+c zs    ---R: Topographic height
+c ps    ---R: Surface Pressure  
+c ub    ---R: Barotropic wind zonal
+c vb    ---R: Barotropic wind meridional
+c zlat  ---R: Latitude in radians
+c zlon  ---R: Longitude in radians
+c======================================================================
+
+#include "dimensions.h"
+ccc#include "dimphy.h"
+c
+c ARGUMENTS
+c
+      INTEGER iam,nlon,nlev
+      REAL, intent(in):: rjour,rsec,rea,rg,ome
+      REAL plat(nlon),plon(nlon),phis(nlon)
+      REAL dragu(nlon),liftu(nlon),phyu(nlon)             
+      REAL dragv(nlon),liftv(nlon),phyv(nlon)             
+      REAL p(nlon,nlev+1), u(nlon,nlev), v(nlon,nlev)
+c
+c Variables locales:
+c
+      INTEGER i,j,k,l
+      REAL xpi,hadley,hadday
+      REAL dlat,dlon
+      REAL raam(3),oaam(3),tmou(3),tsso(3),tbls(3)
+      integer iax
+cIM ajout aam, torsfc
+c aam = composante axiale du Wind AAM raam
+c torsfc = composante axiale de (tmou+tsso+tbls)
+      REAL aam, torsfc
+
+      REAL ZS(801,401),PS(801,401)
+      REAL UB(801,401),VB(801,401)
+      REAL SSOU(801,401),SSOV(801,401)
+      REAL BLSU(801,401),BLSV(801,401)
+      REAL ZLON(801),ZLAT(401)
+
+      CHARACTER (LEN=20) :: modname='aaam_bud'
+      CHARACTER (LEN=80) :: abort_message
+
+
+C
+C  PUT AAM QUANTITIES AT ZERO:
+C
+      if(iim+1.gt.801.or.jjm+1.gt.401)then
+        abort_message = 'Pb de dimension dans aaam_bud'
+        CALL abort_gcm (modname,abort_message,1)
+      endif
+
+      xpi=acos(-1.)
+      hadley=1.e18
+      hadday=1.e18*24.*3600.
+      dlat=xpi/REAL(jjm)
+      dlon=2.*xpi/REAL(iim) 
+      
+      do iax=1,3
+      oaam(iax)=0.
+      raam(iax)=0.
+      tmou(iax)=0.
+      tsso(iax)=0.
+      tbls(iax)=0.
+      enddo
+
+C MOUNTAIN HEIGHT, PRESSURE AND BAROTROPIC WIND:
+
+C North pole values (j=1):
+ 
+      l=1
+
+        ub(1,1)=0.
+        vb(1,1)=0.
+        do k=1,nlev
+          ub(1,1)=ub(1,1)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+          vb(1,1)=vb(1,1)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+        enddo
+
+          zlat(1)=plat(l)*xpi/180.
+
+        do i=1,iim+1
+
+          zs(i,1)=phis(l)/rg
+          ps(i,1)=p(l,1)
+          ub(i,1)=ub(1,1)                             
+          vb(i,1)=vb(1,1)                             
+          ssou(i,1)=dragu(l)+liftu(l)
+          ssov(i,1)=dragv(l)+liftv(l)
+          blsu(i,1)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,1)=phyv(l)-dragv(l)-liftv(l)
+
+        enddo
+
+
+      do j = 2,jjm
+
+C Values at Greenwich (Periodicity)
+
+      zs(iim+1,j)=phis(l+1)/rg
+      ps(iim+1,j)=p(l+1,1)
+          ssou(iim+1,j)=dragu(l+1)+liftu(l+1)
+          ssov(iim+1,j)=dragv(l+1)+liftv(l+1)
+          blsu(iim+1,j)=phyu(l+1)-dragu(l+1)-liftu(l+1)
+          blsv(iim+1,j)=phyv(l+1)-dragv(l+1)-liftv(l+1)
+      zlon(iim+1)=-plon(l+1)*xpi/180.
+      zlat(j)=plat(l+1)*xpi/180.
+
+      ub(iim+1,j)=0.
+      vb(iim+1,j)=0.
+         do k=1,nlev
+         ub(iim+1,j)=ub(iim+1,j)+u(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg
+         vb(iim+1,j)=vb(iim+1,j)+v(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg
+         enddo
+      
+
+      do i=1,iim
+
+      l=l+1
+      zs(i,j)=phis(l)/rg
+      ps(i,j)=p(l,1)
+          ssou(i,j)=dragu(l)+liftu(l)
+          ssov(i,j)=dragv(l)+liftv(l)
+          blsu(i,j)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,j)=phyv(l)-dragv(l)-liftv(l)
+      zlon(i)=plon(l)*xpi/180.
+
+      ub(i,j)=0.
+      vb(i,j)=0.
+         do k=1,nlev
+         ub(i,j)=ub(i,j)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+         vb(i,j)=vb(i,j)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+         enddo
+
+      enddo
+
+      enddo
+
+
+C South Pole
+
+      if (jjm.GT.1) then
+      l=l+1
+      ub(1,jjm+1)=0.
+      vb(1,jjm+1)=0.
+      do k=1,nlev
+         ub(1,jjm+1)=ub(1,jjm+1)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+         vb(1,jjm+1)=vb(1,jjm+1)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+      enddo
+      zlat(jjm+1)=plat(l)*xpi/180.
+
+      do i=1,iim+1
+      zs(i,jjm+1)=phis(l)/rg
+      ps(i,jjm+1)=p(l,1)
+          ssou(i,jjm+1)=dragu(l)+liftu(l)
+          ssov(i,jjm+1)=dragv(l)+liftv(l)
+          blsu(i,jjm+1)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,jjm+1)=phyv(l)-dragv(l)-liftv(l)
+      ub(i,jjm+1)=ub(1,jjm+1)                               
+      vb(i,jjm+1)=vb(1,jjm+1)                                
+      enddo
+      endif
+
+C
+C  MOMENT ANGULAIRE 
+C
+        DO j=1,jjm    
+        DO i=1,iim
+
+           raam(1)=raam(1)-rea**3*dlon*dlat*0.5*
+     c    (cos(zlon(i  ))*sin(zlat(j  ))*cos(zlat(j  ))*ub(i  ,j  )
+     c    +cos(zlon(i  ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i  ,j+1))
+     c                    +rea**3*dlon*dlat*0.5*
+     c    (sin(zlon(i  ))*cos(zlat(j  ))*vb(i  ,j  )
+     c    +sin(zlon(i  ))*cos(zlat(j+1))*vb(i  ,j+1))
+
+           oaam(1)=oaam(1)-ome*rea**4*dlon*dlat/rg*0.5*
+     c   (cos(zlon(i  ))*cos(zlat(j  ))**2*sin(zlat(j  ))*ps(i  ,j  )
+     c   +cos(zlon(i  ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i  ,j+1))
+
+           raam(2)=raam(2)-rea**3*dlon*dlat*0.5*
+     c    (sin(zlon(i  ))*sin(zlat(j  ))*cos(zlat(j  ))*ub(i  ,j  )
+     c    +sin(zlon(i  ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i  ,j+1))
+     c                    -rea**3*dlon*dlat*0.5*
+     c    (cos(zlon(i  ))*cos(zlat(j  ))*vb(i  ,j  )
+     c    +cos(zlon(i  ))*cos(zlat(j+1))*vb(i  ,j+1))
+
+           oaam(2)=oaam(2)-ome*rea**4*dlon*dlat/rg*0.5*
+     c   (sin(zlon(i  ))*cos(zlat(j  ))**2*sin(zlat(j  ))*ps(i  ,j  )
+     c   +sin(zlon(i  ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i  ,j+1))
+
+           raam(3)=raam(3)+rea**3*dlon*dlat*0.5*
+     c           (cos(zlat(j))**2*ub(i,j)+cos(zlat(j+1))**2*ub(i,j+1))
+
+           oaam(3)=oaam(3)+ome*rea**4*dlon*dlat/rg*0.5*
+     c        (cos(zlat(j))**3*ps(i,j)+cos(zlat(j+1))**3*ps(i,j+1))
+
+        ENDDO
+        ENDDO
+
+C
+C COUPLE DES MONTAGNES:
+C
+
+        DO j=1,jjm
+        DO i=1,iim
+           tmou(1)=tmou(1)-rea**2*dlon*0.5*sin(zlon(i))
+     c  *(zs(i,j)-zs(i,j+1))
+     c  *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) 
+           tmou(2)=tmou(2)+rea**2*dlon*0.5*cos(zlon(i))
+     c  *(zs(i,j)-zs(i,j+1))
+     c  *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) 
+        ENDDO
+        ENDDO
+           
+        DO j=2,jjm 
+        DO i=1,iim
+           tmou(1)=tmou(1)+rea**2*dlat*0.5*sin(zlat(j))
+     c  *(zs(i+1,j)-zs(i,j))
+     c  *(cos(zlon(i+1))*ps(i+1,j)+cos(zlon(i))*ps(i,j))
+           tmou(2)=tmou(2)+rea**2*dlat*0.5*sin(zlat(j))
+     c  *(zs(i+1,j)-zs(i,j))
+     c  *(sin(zlon(i+1))*ps(i+1,j)+sin(zlon(i))*ps(i,j))
+           tmou(3)=tmou(3)-rea**2*dlat*0.5*
+     c  cos(zlat(j))*(zs(i+1,j)-zs(i,j))*(ps(i+1,j)+ps(i,j))
+        ENDDO
+        ENDDO
+
+C
+C COUPLES DES DIFFERENTES FRICTION AU SOL:
+C
+        l=1
+        DO j=2,jjm
+        DO i=1,iim
+        l=l+1
+           tsso(1)=tsso(1)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssou(i,j)          *sin(zlat(j))*cos(zlon(i))
+     c                    +rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssov(i,j)          *sin(zlon(i))
+
+           tsso(2)=tsso(2)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssou(i,j)          *sin(zlat(j))*sin(zlon(i))
+     c                    -rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssov(i,j)          *cos(zlon(i))
+
+           tsso(3)=tsso(3)+rea**3*cos(zlat(j))*dlon*dlat*
+     c     ssou(i,j)          *cos(zlat(j))
+
+           tbls(1)=tbls(1)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsu(i,j)          *sin(zlat(j))*cos(zlon(i))
+     c                    +rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsv(i,j)          *sin(zlon(i))
+
+           tbls(2)=tbls(2)-rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsu(i,j)          *sin(zlat(j))*sin(zlon(i))
+     c                    -rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsv(i,j)          *cos(zlon(i))
+
+           tbls(3)=tbls(3)+rea**3*cos(zlat(j))*dlon*dlat*
+     c     blsu(i,j)          *cos(zlat(j))
+
+        ENDDO
+        ENDDO
+            
+
+c     write(*,*) 'AAM',rsec,
+c     write(*,*) 'AAM',rjour+rsec/86400.,
+c    c      raam(3)/hadday,oaam(3)/hadday,
+c    c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley
+
+c     write(iam,100)rjour+rsec/86400.,
+c    c      raam(1)/hadday,oaam(1)/hadday,
+c    c      tmou(1)/hadley,tsso(1)/hadley,tbls(1)/hadley,
+c    c      raam(2)/hadday,oaam(2)/hadday,
+c    c      tmou(2)/hadley,tsso(2)/hadley,tbls(2)/hadley,
+c    c      raam(3)/hadday,oaam(3)/hadday,
+c    c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley 
+100   format(F12.5,15(1x,F12.5))
+
+c     write(iam+1,*)((zs(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ps(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ub(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((vb(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ssou(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((ssov(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((blsu(i,j),i=1,iim),j=1,jjm+1)
+c     write(iam+1,*)((blsv(i,j),i=1,iim),j=1,jjm+1)
+c
+      aam=raam(3)
+      torsfc= tmou(3)+tsso(3)+tbls(3)
+c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/aaam_bud.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/aaam_bud.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/aaam_bud.F90	(revision 17)
@@ -0,0 +1,372 @@
+!
+! $Id: aaam_bud.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      subroutine aaam_bud (iam,nlon,nlev,rjour,rsec,                                 &
+       &                   rea,rg,ome,                                               &
+       &                   plat,plon,phis,                                           &
+       &                   dragu,liftu,phyu,                                         &
+       &                   dragv,liftv,phyv,                                         &
+       &                   p, u, v,                                                  &
+       &                   aam, torsfc)
+!c
+      use dimphy
+      implicit none
+!c======================================================================
+!c Auteur(s): F.Lott (LMD/CNRS) date: 20031020
+!c Object: Compute different terms of the axial AAAM Budget.
+!C No outputs, every AAM quantities are written on the IAM
+!C File. 
+!c
+!c Modif : I.Musat (LMD/CNRS) date : 20041020
+!c Outputs : axial components of wind AAM "aam" and total surface torque "torsfc",
+!c but no write in the iam file.
+!c
+!C WARNING: Only valid for regular rectangular grids.
+!C REMARK: CALL DANS PHYSIQ AFTER lift_noro:
+!C        CALL aaam_bud (27,klon,klev,rjourvrai,gmtime,
+!C    C               ra,rg,romega,
+!C    C               rlat,rlon,pphis,
+!C    C               zustrdr,zustrli,zustrph,
+!C    C               zvstrdr,zvstrli,zvstrph,
+!C    C               paprs,u,v)
+!C
+!C======================================================================
+!c Explicit Arguments:
+!c ==================
+!c iam-----input-I-File number where AAMs and torques are written
+!c                 It is a formatted file that has been opened
+!c                 in physiq.F
+!c nlon----input-I-Total number of horizontal points that get into physics
+!c nlev----input-I-Number of vertical levels
+!c rjour        -R-Jour compte depuis le debut de la simu (run.def)
+!c rsec         -R-Seconde de la journee
+!c rea          -R-Earth radius
+!c rg           -R-gravity constant
+!c ome          -R-Earth rotation rate
+!c plat ---input-R-Latitude en degres
+!c plon ---input-R-Longitude en degres
+!c phis ---input-R-Geopotential at the ground
+!c dragu---input-R-orodrag stress (zonal)
+!c liftu---input-R-orolift stress (zonal)
+!c phyu----input-R-Stress total de la physique (zonal)
+!c dragv---input-R-orodrag stress (Meridional)
+!c liftv---input-R-orolift stress (Meridional)
+!c phyv----input-R-Stress total de la physique (Meridional)
+!c p-------input-R-Pressure (Pa) at model half levels
+!c u-------input-R-Horizontal wind (m/s)
+!c v-------input-R-Meridional wind (m/s)
+!c aam-----output-R-Axial Wind AAM (=raam(3))
+!c torsfc--output-R-Total surface torque (=tmou(3)+tsso(3)+tbls(3))
+!c
+!c Implicit Arguments:
+!c ===================
+!c
+!c iim--common-I: Number of longitude intervals
+!c jjm--common-I: Number of latitude intervals
+!c klon-common-I: Number of points seen by the physics
+!c                iim*(jjm-1)+2 for instance
+!c klev-common-I: Number of vertical layers
+!c======================================================================
+!c Local Variables:
+!c ================
+!c dlat-----R: Latitude increment (Radians)
+!c dlon-----R: Longitude increment (Radians)
+!c raam  ---R: Wind AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
+!c oaam  ---R: Mass AAM (3 Components, 1 & 2 Equatoriales; 3 Axiale)
+!c tmou-----R: Resolved Mountain torque (3 components)
+!c tsso-----R: Parameterised Moutain drag torque (3 components)
+!c tbls-----R: Parameterised Boundary layer torque (3 components)
+!c
+!c LOCAL ARRAY:
+!c ===========
+!c zs    ---R: Topographic height
+!c ps    ---R: Surface Pressure  
+!c ub    ---R: Barotropic wind zonal
+!c vb    ---R: Barotropic wind meridional
+!c zlat  ---R: Latitude in radians
+!c zlon  ---R: Longitude in radians
+!c======================================================================
+
+#include "dimensions.h"
+!ccc#include "dimphy.h"
+!c
+!c ARGUMENTS
+!c
+      INTEGER iam,nlon,nlev
+      REAL, intent(in):: rjour,rsec,rea,rg,ome
+      REAL plat(nlon),plon(nlon),phis(nlon)
+      REAL dragu(nlon),liftu(nlon),phyu(nlon)             
+      REAL dragv(nlon),liftv(nlon),phyv(nlon)             
+      REAL p(nlon,nlev+1), u(nlon,nlev), v(nlon,nlev)
+!c
+!c Variables locales:
+!c
+      INTEGER i,j,k,l
+      REAL xpi,hadley,hadday
+      REAL dlat,dlon
+      REAL raam(3),oaam(3),tmou(3),tsso(3),tbls(3)
+      integer iax
+!IM ajout aam, torsfc
+!c aam = composante axiale du Wind AAM raam
+!c torsfc = composante axiale de (tmou+tsso+tbls)
+      REAL aam, torsfc
+
+      REAL ZS(801,401),PS(801,401)
+      REAL UB(801,401),VB(801,401)
+      REAL SSOU(801,401),SSOV(801,401)
+      REAL BLSU(801,401),BLSV(801,401)
+      REAL ZLON(801),ZLAT(401)
+
+      CHARACTER (LEN=20) :: modname='aaam_bud'
+      CHARACTER (LEN=80) :: abort_message
+
+
+!C
+!C  PUT AAM QUANTITIES AT ZERO:
+!C
+      if(iim+1.gt.801.or.jjm+1.gt.401)then
+        abort_message = 'Pb de dimension dans aaam_bud'
+        CALL abort_gcm (modname,abort_message,1)
+      endif
+
+      xpi=acos(-1.)
+      hadley=1.e18
+      hadday=1.e18*24.*3600.
+      dlat=xpi/REAL(jjm)
+      dlon=2.*xpi/REAL(iim) 
+      
+      do iax=1,3
+      oaam(iax)=0.
+      raam(iax)=0.
+      tmou(iax)=0.
+      tsso(iax)=0.
+      tbls(iax)=0.
+      enddo
+
+!C MOUNTAIN HEIGHT, PRESSURE AND BAROTROPIC WIND:
+
+!C North pole values (j=1):
+ 
+      l=1
+
+        ub(1,1)=0.
+        vb(1,1)=0.
+        do k=1,nlev
+          ub(1,1)=ub(1,1)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+          vb(1,1)=vb(1,1)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+        enddo
+
+          zlat(1)=plat(l)*xpi/180.
+
+        do i=1,iim+1
+
+          zs(i,1)=phis(l)/rg
+          ps(i,1)=p(l,1)
+          ub(i,1)=ub(1,1)                             
+          vb(i,1)=vb(1,1)                             
+          ssou(i,1)=dragu(l)+liftu(l)
+          ssov(i,1)=dragv(l)+liftv(l)
+          blsu(i,1)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,1)=phyv(l)-dragv(l)-liftv(l)
+
+        enddo
+
+
+      do j = 2,jjm
+
+!C Values at Greenwich (Periodicity)
+
+      zs(iim+1,j)=phis(l+1)/rg
+      ps(iim+1,j)=p(l+1,1)
+          ssou(iim+1,j)=dragu(l+1)+liftu(l+1)
+          ssov(iim+1,j)=dragv(l+1)+liftv(l+1)
+          blsu(iim+1,j)=phyu(l+1)-dragu(l+1)-liftu(l+1)
+          blsv(iim+1,j)=phyv(l+1)-dragv(l+1)-liftv(l+1)
+      zlon(iim+1)=-plon(l+1)*xpi/180.
+      zlat(j)=plat(l+1)*xpi/180.
+
+      ub(iim+1,j)=0.
+      vb(iim+1,j)=0.
+         do k=1,nlev
+         ub(iim+1,j)=ub(iim+1,j)+u(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg
+         vb(iim+1,j)=vb(iim+1,j)+v(l+1,k)*(p(l+1,k)-p(l+1,k+1))/rg
+         enddo
+      
+
+      do i=1,iim
+
+      l=l+1
+      zs(i,j)=phis(l)/rg
+      ps(i,j)=p(l,1)
+          ssou(i,j)=dragu(l)+liftu(l)
+          ssov(i,j)=dragv(l)+liftv(l)
+          blsu(i,j)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,j)=phyv(l)-dragv(l)-liftv(l)
+      zlon(i)=plon(l)*xpi/180.
+
+      ub(i,j)=0.
+      vb(i,j)=0.
+         do k=1,nlev
+         ub(i,j)=ub(i,j)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+         vb(i,j)=vb(i,j)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+         enddo
+
+      enddo
+
+      enddo
+
+
+!C South Pole
+
+      if (jjm.GT.1) then
+      l=l+1
+      ub(1,jjm+1)=0.
+      vb(1,jjm+1)=0.
+      do k=1,nlev
+         ub(1,jjm+1)=ub(1,jjm+1)+u(l,k)*(p(l,k)-p(l,k+1))/rg
+         vb(1,jjm+1)=vb(1,jjm+1)+v(l,k)*(p(l,k)-p(l,k+1))/rg
+      enddo
+      zlat(jjm+1)=plat(l)*xpi/180.
+
+      do i=1,iim+1
+      zs(i,jjm+1)=phis(l)/rg
+      ps(i,jjm+1)=p(l,1)
+          ssou(i,jjm+1)=dragu(l)+liftu(l)
+          ssov(i,jjm+1)=dragv(l)+liftv(l)
+          blsu(i,jjm+1)=phyu(l)-dragu(l)-liftu(l)
+          blsv(i,jjm+1)=phyv(l)-dragv(l)-liftv(l)
+      ub(i,jjm+1)=ub(1,jjm+1)                               
+      vb(i,jjm+1)=vb(1,jjm+1)                                
+      enddo
+      endif
+
+!C
+!C  MOMENT ANGULAIRE 
+!C
+        DO j=1,jjm    
+        DO i=1,iim
+
+           raam(1)=raam(1)-rea**3*dlon*dlat*0.5*                                     &
+       &    (cos(zlon(i  ))*sin(zlat(j  ))*cos(zlat(j  ))*ub(i  ,j  )                &
+       &    +cos(zlon(i  ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i  ,j+1))               &
+       &                    +rea**3*dlon*dlat*0.5*                                   &
+       &    (sin(zlon(i  ))*cos(zlat(j  ))*vb(i  ,j  )                               &
+       &    +sin(zlon(i  ))*cos(zlat(j+1))*vb(i  ,j+1))
+
+           oaam(1)=oaam(1)-ome*rea**4*dlon*dlat/rg*0.5*                              &
+       &   (cos(zlon(i  ))*cos(zlat(j  ))**2*sin(zlat(j  ))*ps(i  ,j  )              &
+       &   +cos(zlon(i  ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i  ,j+1))
+
+           raam(2)=raam(2)-rea**3*dlon*dlat*0.5*                                     &
+       &    (sin(zlon(i  ))*sin(zlat(j  ))*cos(zlat(j  ))*ub(i  ,j  )                &
+       &    +sin(zlon(i  ))*sin(zlat(j+1))*cos(zlat(j+1))*ub(i  ,j+1))               &
+       &                    -rea**3*dlon*dlat*0.5*                                   &
+       &    (cos(zlon(i  ))*cos(zlat(j  ))*vb(i  ,j  )                               &
+       &    +cos(zlon(i  ))*cos(zlat(j+1))*vb(i  ,j+1))
+
+           oaam(2)=oaam(2)-ome*rea**4*dlon*dlat/rg*0.5*                              &
+       &   (sin(zlon(i  ))*cos(zlat(j  ))**2*sin(zlat(j  ))*ps(i  ,j  )              &
+       &   +sin(zlon(i  ))*cos(zlat(j+1))**2*sin(zlat(j+1))*ps(i  ,j+1))
+
+           raam(3)=raam(3)+rea**3*dlon*dlat*0.5*                                     &
+       &           (cos(zlat(j))**2*ub(i,j)+cos(zlat(j+1))**2*ub(i,j+1))
+
+           oaam(3)=oaam(3)+ome*rea**4*dlon*dlat/rg*0.5*                              &
+       &        (cos(zlat(j))**3*ps(i,j)+cos(zlat(j+1))**3*ps(i,j+1))
+
+        ENDDO
+        ENDDO
+
+!C
+!C COUPLE DES MONTAGNES:
+!C
+
+        DO j=1,jjm
+        DO i=1,iim
+           tmou(1)=tmou(1)-rea**2*dlon*0.5*sin(zlon(i))                              &
+       &  *(zs(i,j)-zs(i,j+1))                                                       &
+       &  *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) 
+           tmou(2)=tmou(2)+rea**2*dlon*0.5*cos(zlon(i))                              &
+       &  *(zs(i,j)-zs(i,j+1))                                                       &
+       &  *(cos(zlat(j+1))*ps(i,j+1)+cos(zlat(j))*ps(i,j)) 
+        ENDDO
+        ENDDO
+           
+        DO j=2,jjm 
+        DO i=1,iim
+           tmou(1)=tmou(1)+rea**2*dlat*0.5*sin(zlat(j))                              &
+       &  *(zs(i+1,j)-zs(i,j))                                                       &
+       &  *(cos(zlon(i+1))*ps(i+1,j)+cos(zlon(i))*ps(i,j))
+           tmou(2)=tmou(2)+rea**2*dlat*0.5*sin(zlat(j))                              &
+       &  *(zs(i+1,j)-zs(i,j))                                                       &
+       &  *(sin(zlon(i+1))*ps(i+1,j)+sin(zlon(i))*ps(i,j))
+           tmou(3)=tmou(3)-rea**2*dlat*0.5*                                          &
+       &  cos(zlat(j))*(zs(i+1,j)-zs(i,j))*(ps(i+1,j)+ps(i,j))
+        ENDDO
+        ENDDO
+
+!C
+!C COUPLES DES DIFFERENTES FRICTION AU SOL:
+!C
+        l=1
+        DO j=2,jjm
+        DO i=1,iim
+        l=l+1
+           tsso(1)=tsso(1)-rea**3*cos(zlat(j))*dlon*dlat*                            &
+       &     ssou(i,j)          *sin(zlat(j))*cos(zlon(i))                           &
+       &                    +rea**3*cos(zlat(j))*dlon*dlat*                          &
+       &     ssov(i,j)          *sin(zlon(i))
+
+           tsso(2)=tsso(2)-rea**3*cos(zlat(j))*dlon*dlat*                            &
+       &     ssou(i,j)          *sin(zlat(j))*sin(zlon(i))                           &
+       &                    -rea**3*cos(zlat(j))*dlon*dlat*                          &
+       &     ssov(i,j)          *cos(zlon(i))
+
+           tsso(3)=tsso(3)+rea**3*cos(zlat(j))*dlon*dlat*                            &
+       &     ssou(i,j)          *cos(zlat(j))
+
+           tbls(1)=tbls(1)-rea**3*cos(zlat(j))*dlon*dlat*                            &
+       &     blsu(i,j)          *sin(zlat(j))*cos(zlon(i))                           &
+       &                    +rea**3*cos(zlat(j))*dlon*dlat*                          &
+       &     blsv(i,j)          *sin(zlon(i))
+
+           tbls(2)=tbls(2)-rea**3*cos(zlat(j))*dlon*dlat*                            &
+       &     blsu(i,j)          *sin(zlat(j))*sin(zlon(i))                           &
+       &                    -rea**3*cos(zlat(j))*dlon*dlat*                          &
+       &     blsv(i,j)          *cos(zlon(i))
+
+           tbls(3)=tbls(3)+rea**3*cos(zlat(j))*dlon*dlat*                            &
+       &     blsu(i,j)          *cos(zlat(j))
+
+        ENDDO
+        ENDDO
+            
+
+!c     write(*,*) 'AAM',rsec,
+!c     write(*,*) 'AAM',rjour+rsec/86400.,
+!c    c      raam(3)/hadday,oaam(3)/hadday,
+!c    c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley
+
+!c     write(iam,100)rjour+rsec/86400.,
+!c    c      raam(1)/hadday,oaam(1)/hadday,
+!c    c      tmou(1)/hadley,tsso(1)/hadley,tbls(1)/hadley,
+!c    c      raam(2)/hadday,oaam(2)/hadday,
+!c    c      tmou(2)/hadley,tsso(2)/hadley,tbls(2)/hadley,
+!c    c      raam(3)/hadday,oaam(3)/hadday,
+!c    c      tmou(3)/hadley,tsso(3)/hadley,tbls(3)/hadley 
+100   format(F12.5,15(1x,F12.5))
+
+!c     write(iam+1,*)((zs(i,j),i=1,iim),j=1,jjm+1)
+!c     write(iam+1,*)((ps(i,j),i=1,iim),j=1,jjm+1)
+!c     write(iam+1,*)((ub(i,j),i=1,iim),j=1,jjm+1)
+!c     write(iam+1,*)((vb(i,j),i=1,iim),j=1,jjm+1)
+!c     write(iam+1,*)((ssou(i,j),i=1,iim),j=1,jjm+1)
+!c     write(iam+1,*)((ssov(i,j),i=1,iim),j=1,jjm+1)
+!c     write(iam+1,*)((blsu(i,j),i=1,iim),j=1,jjm+1)
+!c     write(iam+1,*)((blsv(i,j),i=1,iim),j=1,jjm+1)
+!c
+      aam=raam(3)
+      torsfc= tmou(3)+tsso(3)+tbls(3)
+!c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/abort_gcm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/abort_gcm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/abort_gcm.F	(revision 17)
@@ -0,0 +1,47 @@
+!
+! $Id: abort_gcm.F 1425 2010-09-02 13:45:23Z lguez $
+!
+c
+c
+      SUBROUTINE abort_gcm(modname, message, ierr)
+     
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin_dump
+      USE ioipsl_getincom
+#endif
+#include "iniprint.h"
+ 
+C
+C Stops the simulation cleanly, closing files and printing various
+C comments
+C
+C  Input: modname = name of calling program
+C         message = stuff to print
+C         ierr    = severity of situation ( = 0 normal )
+
+      character(len=*) modname
+      integer ierr
+      character(len=*) message
+
+      write(lunout,*) 'in abort_gcm'
+#ifdef CPP_IOIPSL
+      call histclo
+      call restclo
+#endif
+      call getin_dump
+c     call histclo(2)
+c     call histclo(3)
+c     call histclo(4)
+c     call histclo(5)
+      write(lunout,*) 'Stopping in ', modname
+      write(lunout,*) 'Reason = ',message
+      if (ierr .eq. 0) then
+        write(lunout,*) 'Everything is cool'
+        stop
+      else
+        write(lunout,*) 'Houston, we have a problem ', ierr
+        stop 1
+      endif
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/abort_gcm.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/abort_gcm.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/abort_gcm.F90	(revision 17)
@@ -0,0 +1,47 @@
+!
+! $Id: abort_gcm.F 1425 2010-09-02 13:45:23Z lguez $
+!
+!c
+!c
+      SUBROUTINE abort_gcm(modname, message, ierr)
+     
+#ifdef CPP_IOIPSL
+      USE IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin_dump
+      USE ioipsl_getincom
+#endif
+#include "iniprint.h"
+ 
+!C
+!C Stops the simulation cleanly, closing files and printing various
+!C comments
+!C
+!C  Input: modname = name of calling program
+!C         message = stuff to print
+!C         ierr    = severity of situation ( = 0 normal )
+
+      character(len=*) modname
+      integer ierr
+      character(len=*) message
+
+      write(lunout,*) 'in abort_gcm'
+#ifdef CPP_IOIPSL
+      call histclo
+      call restclo
+#endif
+      call getin_dump
+!c     call histclo(2)
+!c     call histclo(3)
+!c     call histclo(4)
+!c     call histclo(5)
+      write(lunout,*) 'Stopping in ', modname
+      write(lunout,*) 'Reason = ',message
+      if (ierr .eq. 0) then
+        write(lunout,*) 'Everything is cool'
+        stop
+      else
+        write(lunout,*) 'Houston, we have a problem ', ierr
+        stop 1
+      endif
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/add_phys_tend.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/add_phys_tend.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/add_phys_tend.F90	(revision 17)
@@ -0,0 +1,193 @@
+!
+! $Id: add_phys_tend.F90 1163 2009-05-20 14:11:21Z fairhead $
+!
+SUBROUTINE add_phys_tend (zdu,zdv,zdt,zdq,zdql,text)
+!======================================================================
+! Ajoute les tendances des variables physiques aux variables 
+! d'etat de la dynamique t_seri, q_seri ...
+! On en profite pour faire des tests sur les tendances en question.
+!======================================================================
+
+
+!======================================================================
+! Declarations
+!======================================================================
+
+use dimphy
+use phys_local_var_mod
+use phys_state_var_mod
+IMPLICIT none
+#include "iniprint.h"
+
+! Arguments :
+!------------
+REAL zdu(klon,klev),zdv(klon,klev)
+REAL zdt(klon,klev),zdq(klon,klev),zdql(klon,klev)
+CHARACTER*(*) text
+
+! Local :
+!--------
+REAL zt,zq
+
+INTEGER i, k,j
+INTEGER jadrs(klon*klev), jbad
+INTEGER jqadrs(klon*klev), jqbad
+INTEGER kadrs(klon*klev)
+INTEGER kqadrs(klon*klev)
+
+integer debug_level
+logical, save :: first=.true.
+!$OMP THREADPRIVATE(first)
+INTEGER, SAVE :: itap
+!$OMP THREADPRIVATE(itap)
+!======================================================================
+! Initialisations
+
+debug_level=10
+     if (first) then
+        itap=0
+        first=.false.
+     endif
+! Incrementer le compteur de la physique
+     itap   = itap + 1
+!======================================================================
+! Ajout des tendances sur le vent et l'eau liquide
+!======================================================================
+
+     u_seri(:,:)=u_seri(:,:)+zdu(:,:)
+     v_seri(:,:)=v_seri(:,:)+zdv(:,:)
+     ql_seri(:,:)=ql_seri(:,:)+zdql(:,:)
+
+!======================================================================
+! On ajoute les tendances de la temperature et de la vapeur d'eau
+! en verifiant que ca ne part pas dans les choux
+!======================================================================
+
+      jbad=0
+      jqbad=0
+      DO k = 1, klev
+         DO i = 1, klon
+            zt=t_seri(i,k)+zdt(i,k)
+            zq=q_seri(i,k)+zdq(i,k)
+            IF ( zt>370. .or. zt<130. .or. abs(zdt(i,k))>50. ) then
+            jbad = jbad + 1
+            jadrs(jbad) = i
+            kadrs(jbad) = k
+            ENDIF
+            IF ( zq<0. .or. zq>0.1 .or. abs(zdq(i,k))>1.e-2 ) then
+            jqbad = jqbad + 1
+            jqadrs(jqbad) = i
+            kqadrs(jqbad) = k
+            ENDIF
+            t_seri(i,k)=zt
+            q_seri(i,k)=zq
+         ENDDO
+      ENDDO
+
+!=====================================================================================
+! Impression et stop en cas de probleme important
+!=====================================================================================
+
+IF (jbad .GT. 0) THEN
+      DO j = 1, jbad
+         i=jadrs(j)
+         if(prt_level.ge.debug_level) THEN
+          print*,'PLANTAGE POUR LE POINT i rlon rlat =',i,rlon(i),rlat(i),text
+          print*,'l    T     dT       Q     dQ    '
+          DO k = 1, klev
+             write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
+          ENDDO
+          call print_debug_phys(i,debug_level,text)
+         endif
+      ENDDO
+ENDIF
+!
+!=====================================================================================
+! Impression, warning et correction en cas de probleme moins important
+!=====================================================================================
+IF (jqbad .GT. 0) THEN
+      DO j = 1, jqbad
+         i=jqadrs(j)
+         if(prt_level.ge.debug_level) THEN
+          print*,'WARNING  : EAU POUR LE POINT i rlon rlat =',i,rlon(i),rlat(i),text
+          print*,'l    T     dT       Q     dQ    '
+         endif
+         DO k = 1, klev
+           zq=q_seri(i,k)+zdq(i,k)
+           if (zq.lt.1.e-15) then
+              if (q_seri(i,k).lt.1.e-15) then
+               if(prt_level.ge.debug_level) THEN
+                print*,' cas q_seri<1.e-15 i k q_seri zq zdq :',i,k,q_seri(i,k),zq,zdq(i,k)
+               endif
+               q_seri(i,k)=1.e-15
+               zdq(i,k)=(1.e-15-q_seri(i,k))
+              endif
+           endif
+!           zq=q_seri(i,k)+zdq(i,k)
+!           if (zq.lt.1.e-15) then
+!              zdq(i,k)=(1.e-15-q_seri(i,k))
+!           endif
+         ENDDO
+      ENDDO
+ENDIF
+!
+
+!IM ajout memes tests pour reverifier les jbad, jqbad beg
+      jbad=0
+      jqbad=0
+      DO k = 1, klev
+         DO i = 1, klon
+            IF ( t_seri(i,k)>370. .or. t_seri(i,k)<130. .or. abs(zdt(i,k))>50. ) then
+            jbad = jbad + 1
+            jadrs(jbad) = i
+!            if(prt_level.ge.debug_level) THEN
+!             print*,'cas2 i k t_seri zdt',i,k,t_seri(i,k),zdt(i,k)
+!            endif
+            ENDIF
+            IF ( q_seri(i,k)<0. .or. q_seri(i,k)>0.1 .or. abs(zdq(i,k))>1.e-2 ) then
+            jqbad = jqbad + 1
+            jqadrs(jqbad) = i
+            kqadrs(jqbad) = k
+!            if(prt_level.ge.debug_level) THEN
+!             print*,'cas2 i k q_seri zdq',i,k,q_seri(i,k),zdq(i,k)
+!            endif
+            ENDIF
+         ENDDO
+      ENDDO
+IF (jbad .GT. 0) THEN
+      DO j = 1, jbad
+         i=jadrs(j)
+         k=kadrs(j)
+         if(prt_level.ge.debug_level) THEN
+          print*,'PLANTAGE2 POUR LE POINT i itap rlon rlat txt jbad zdt t',i,itap,rlon(i),rlat(i),text,jbad, &
+       &        zdt(i,k),t_seri(i,k)-zdt(i,k)
+!!!       if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN 
+          print*,'l    T     dT       Q     dQ    '
+          DO k = 1, klev
+             write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
+          ENDDO
+          call print_debug_phys(i,debug_level,text)
+         endif
+      ENDDO
+ENDIF 
+!
+IF (jqbad .GT. 0) THEN
+      DO j = 1, jqbad
+         i=jqadrs(j)
+         k=kqadrs(j)
+         if(prt_level.ge.debug_level) THEN
+          print*,'WARNING  : EAU2 POUR LE POINT i itap rlon rlat txt jqbad zdq q zdql ql',i,itap,rlon(i),rlat(i),text,jqbad,&
+       &        zdq(i,k), q_seri(i,k)-zdq(i,k), zdql(i,k), ql_seri(i,k)-zdql(i,k)
+!!!       if(prt_level.ge.10.and.itap.GE.229.and.i.EQ.3027) THEN 
+          print*,'l    T     dT       Q     dQ    '
+          DO k = 1, klev
+            write(*,'(i3,2f14.4,2e14.2)') k,t_seri(i,k),zdt(i,k),q_seri(i,k),zdq(i,k)
+          ENDDO
+          call print_debug_phys(i,debug_level,text)
+         endif
+      ENDDO
+ENDIF
+
+      CALL  hgardfou(t_seri,ftsol,text)
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/aero_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/aero_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/aero_mod.F90	(revision 17)
@@ -0,0 +1,77 @@
+! $Id$
+!
+MODULE aero_mod
+  ! Declaration des indices pour les aerosols 
+
+  ! Total number of aerosols
+!  INTEGER, PARAMETER :: naero_tot = 10 
+!--STRAT AER
+  INTEGER, PARAMETER :: naero_tot = 11
+
+  ! Identification number used in aeropt_2bands and aeropt_5wv
+  ! corresponding to naero_tot
+  INTEGER, PARAMETER :: id_ASBCM    = 1
+  INTEGER, PARAMETER :: id_ASPOMM   = 2
+  INTEGER, PARAMETER :: id_ASSO4M   = 3
+  INTEGER, PARAMETER :: id_CSSO4M   = 4
+  INTEGER, PARAMETER :: id_SSSSM    = 5
+  INTEGER, PARAMETER :: id_CSSSM    = 6
+  INTEGER, PARAMETER :: id_ASSSM    = 7
+  INTEGER, PARAMETER :: id_CIDUSTM  = 8
+  INTEGER, PARAMETER :: id_AIBCM    = 9
+  INTEGER, PARAMETER :: id_AIPOMM   = 10
+!--STRAT AER
+  INTEGER, PARAMETER :: id_strat   = 11
+
+
+  ! Total number of aerosols actually used in LMDZ 
+  ! 1 =  ASBCM
+  ! 2 =  ASPOMM
+  ! 3 =  ASSO4M ( = SO4) 
+  ! 4 =  CSSO4M 
+  ! 5 =  SSSSM 
+  ! 6 =  CSSSM
+  ! 7 =  ASSSM
+  ! 8 =  CIDUSTM
+  ! 9 =  AIBCM
+  !10 =  AIPOMM
+!--STRAT AER
+  !11 = aerosols stratos
+!  INTEGER, PARAMETER :: naero_spc = 10
+  INTEGER, PARAMETER :: naero_spc = 11
+
+  ! Corresponding names for the aerosols
+  CHARACTER(len=7),DIMENSION(naero_spc), PARAMETER :: name_aero=(/&
+       "ASBCM  ", &
+       "ASPOMM ", &
+       "SO4    ", &
+       "CSSO4M ", &
+       "SSSSM  ", &
+       "CSSSM  ", &
+       "ASSSM  ", &
+       "CIDUSTM", &
+       "AIBCM  ", &
+!       "AIPOMM " /)
+       "AIPOMM ", &
+       "STRAT  " /)
+
+
+  ! Number of aerosol groups
+  ! 1 = ZERO    
+  ! 2 = AER total    
+  ! 3 = NAT    
+  ! 4 = BC    
+  ! 5 = SO4    
+  ! 6 = POM    
+  ! 7 = DUST    
+  ! 8 = SS    
+  ! 9 = NO3    
+  INTEGER, PARAMETER :: naero_grp = 9 
+
+  ! Number of  wavelengths
+  INTEGER, PARAMETER :: nwave = 5
+
+  ! Number of modes spectral bands
+  INTEGER, parameter :: nbands = 2
+
+END MODULE aero_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/aeropt.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/aeropt.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/aeropt.F	(revision 17)
@@ -0,0 +1,141 @@
+!
+! $Id: aeropt.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE aeropt(pplay, paprs, t_seri, msulfate, RHcl,
+     .            tau_ae, piz_ae, cg_ae, ai        )
+c
+      USE dimphy
+      IMPLICIT none
+c
+c
+c     
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      REAL, INTENT(in) :: paprs(klon,klev+1)
+      REAL, INTENT(in) :: pplay(klon,klev), t_seri(klon,klev)
+      REAL, INTENT(in) :: msulfate(klon,klev) ! masse sulfate ug SO4/m3  [ug/m^3]
+      REAL, INTENT(in) :: RHcl(klon,klev)     ! humidite relative ciel clair
+      REAL, INTENT(out) :: tau_ae(klon,klev,2) ! epaisseur optique aerosol
+      REAL, INTENT(out) :: piz_ae(klon,klev,2) ! single scattering albedo aerosol
+      REAL, INTENT(out) :: cg_ae(klon,klev,2)  ! asymmetry parameter aerosol
+      REAL, INTENT(out) :: ai(klon)            ! POLDER aerosol index 
+c
+c Local
+c
+      INTEGER i, k, inu
+      INTEGER RH_num, nbre_RH
+      PARAMETER (nbre_RH=12)
+      REAL RH_tab(nbre_RH)
+      REAL RH_MAX, DELTA, rh 
+      PARAMETER (RH_MAX=95.)
+      DATA RH_tab/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./
+      REAL zrho, zdz
+      REAL taue670(klon)       ! epaisseur optique aerosol absorption 550 nm
+      REAL taue865(klon)       ! epaisseur optique aerosol extinction 865 nm
+      REAL alpha_aer_sulfate(nbre_RH,5)   !--unit m2/g SO4
+      REAL alphasulfate      
+
+      CHARACTER (LEN=20) :: modname='aeropt'
+      CHARACTER (LEN=80) :: abort_message
+
+c
+c Proprietes optiques
+c
+      REAL alpha_aer(nbre_RH,2)   !--unit m2/g SO4
+      REAL cg_aer(nbre_RH,2)
+      DATA alpha_aer/.500130E+01,  .500130E+01,  .500130E+01,  
+     .               .500130E+01,  .500130E+01,  .616710E+01,  
+     .               .826850E+01,  .107687E+02,  .136976E+02,  
+     .               .162972E+02,  .211690E+02,  .354833E+02,  
+     .               .139460E+01,  .139460E+01,  .139460E+01,  
+     .               .139460E+01,  .139460E+01,  .173910E+01,  
+     .               .244380E+01,  .332320E+01,  .440120E+01,  
+     .               .539570E+01,  .734580E+01,  .136038E+02 / 
+      DATA cg_aer/.619800E+00,  .619800E+00,  .619800E+00,  
+     .            .619800E+00,  .619800E+00,  .662700E+00,  
+     .            .682100E+00,  .698500E+00,  .712500E+00,  
+     .            .721800E+00,  .734600E+00,  .755800E+00,  
+     .            .545600E+00,  .545600E+00,  .545600E+00,  
+     .            .545600E+00,  .545600E+00,  .583700E+00,  
+     .            .607100E+00,  .627700E+00,  .645800E+00,  
+     .            .658400E+00,  .676500E+00,  .708500E+00 / 
+      DATA alpha_aer_sulfate/
+     . 4.910,4.910,4.910,4.910,6.547,7.373,
+     . 8.373,9.788,12.167,14.256,17.924,28.433,
+     . 1.453,1.453,1.453,1.453,2.003,2.321,
+     . 2.711,3.282,4.287,5.210,6.914,12.305,
+     . 4.308,4.308,4.308,4.308,5.753,6.521,
+     . 7.449,8.772,11.014,12.999,16.518,26.772,
+     . 3.265,3.265,3.265,3.265,4.388,5.016,
+     . 5.775,6.868,8.745,10.429,13.457,22.538,
+     . 2.116,2.116,2.116,2.116,2.882,3.330,
+     . 3.876,4.670,6.059,7.327,9.650,16.883/
+c
+      DO i=1, klon
+         taue670(i)=0.0
+         taue865(i)=0.0
+      ENDDO
+c      
+      DO k=1, klev
+      DO i=1, klon
+         if (t_seri(i,k).eq.0) write (*,*) 'aeropt T ',i,k,t_seri(i,k)
+         if (pplay(i,k).eq.0) write (*,*) 'aeropt p ',i,k,pplay(i,k)         
+        zrho=pplay(i,k)/t_seri(i,k)/RD                  ! kg/m3
+        zdz=(paprs(i,k)-paprs(i,k+1))/zrho/RG           ! m
+        rh=MIN(RHcl(i,k)*100.,RH_MAX)
+        RH_num = INT( rh/10. + 1.)
+        IF (rh.LT.0.) THEN
+          abort_message = 'aeropt: RH < 0 not possible'
+          CALL abort_gcm (modname,abort_message,1)
+        ENDIF
+        IF (rh.gt.85.) RH_num=10
+        IF (rh.gt.90.) RH_num=11
+        DELTA=(rh-RH_tab(RH_num))/(RH_tab(RH_num+1)-RH_tab(RH_num))
+c                
+        inu=1
+        tau_ae(i,k,inu)=alpha_aer(RH_num,inu) +
+     .             DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu))
+        tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6
+        piz_ae(i,k,inu)=1.0
+        cg_ae(i,k,inu)=cg_aer(RH_num,inu) +
+     .                 DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu))
+c
+        inu=2
+        tau_ae(i,k,inu)=alpha_aer(RH_num,inu) +
+     .             DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu))
+        tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6
+        piz_ae(i,k,inu)=1.0
+        cg_ae(i,k,inu)=cg_aer(RH_num,inu) +
+     .                 DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu))
+cjq
+cjq for aerosol index
+c
+        alphasulfate=alpha_aer_sulfate(RH_num,4) +
+     .       DELTA*(alpha_aer_sulfate(RH_num+1,4)-
+     .       alpha_aer_sulfate(RH_num,4)) !--m2/g 
+c     
+        taue670(i)=taue670(i)+
+     .       alphasulfate*msulfate(i,k)*zdz*1.e-6
+c
+        alphasulfate=alpha_aer_sulfate(RH_num,5) +
+     .       DELTA*(alpha_aer_sulfate(RH_num+1,5)-
+     .       alpha_aer_sulfate(RH_num,5)) !--m2/g 
+c
+        taue865(i)=taue865(i)+
+     .         alphasulfate*msulfate(i,k)*zdz*1.e-6
+        
+      ENDDO
+      ENDDO
+c      
+      DO i=1, klon
+        ai(i)=(-log(MAX(taue670(i),0.0001)/
+     .                MAX(taue865(i),0.0001))/log(670./865.)) * 
+     .        taue865(i)
+      ENDDO     
+c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/aeropt.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/aeropt.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/aeropt.F90	(revision 17)
@@ -0,0 +1,141 @@
+!
+! $Id: aeropt.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE aeropt(pplay, paprs, t_seri, msulfate, RHcl,                        &
+       &            tau_ae, piz_ae, cg_ae, ai        )
+!c
+      USE dimphy
+      IMPLICIT none
+!c
+!c
+!c     
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c
+!c Arguments:
+!c
+      REAL, INTENT(in) :: paprs(klon,klev+1)
+      REAL, INTENT(in) :: pplay(klon,klev), t_seri(klon,klev)
+      REAL, INTENT(in) :: msulfate(klon,klev) ! masse sulfate ug SO4/m3  [ug/m^3]
+      REAL, INTENT(in) :: RHcl(klon,klev)     ! humidite relative ciel clair
+      REAL, INTENT(out) :: tau_ae(klon,klev,2) ! epaisseur optique aerosol
+      REAL, INTENT(out) :: piz_ae(klon,klev,2) ! single scattering albedo aerosol
+      REAL, INTENT(out) :: cg_ae(klon,klev,2)  ! asymmetry parameter aerosol
+      REAL, INTENT(out) :: ai(klon)            ! POLDER aerosol index 
+!c
+!c Local
+!c
+      INTEGER i, k, inu
+      INTEGER RH_num, nbre_RH
+      PARAMETER (nbre_RH=12)
+      REAL RH_tab(nbre_RH)
+      REAL RH_MAX, DELTA, rh 
+      PARAMETER (RH_MAX=95.)
+      DATA RH_tab/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./
+      REAL zrho, zdz
+      REAL taue670(klon)       ! epaisseur optique aerosol absorption 550 nm
+      REAL taue865(klon)       ! epaisseur optique aerosol extinction 865 nm
+      REAL alpha_aer_sulfate(nbre_RH,5)   !--unit m2/g SO4
+      REAL alphasulfate      
+
+      CHARACTER (LEN=20) :: modname='aeropt'
+      CHARACTER (LEN=80) :: abort_message
+
+!c
+!c Proprietes optiques
+!c
+      REAL alpha_aer(nbre_RH,2)   !--unit m2/g SO4
+      REAL cg_aer(nbre_RH,2)
+      DATA alpha_aer/.500130E+01,  .500130E+01,  .500130E+01,                        &
+       &               .500130E+01,  .500130E+01,  .616710E+01,                      &
+       &               .826850E+01,  .107687E+02,  .136976E+02,                      &
+       &               .162972E+02,  .211690E+02,  .354833E+02,                      &
+       &               .139460E+01,  .139460E+01,  .139460E+01,                      &
+       &               .139460E+01,  .139460E+01,  .173910E+01,                      &
+       &               .244380E+01,  .332320E+01,  .440120E+01,                      &
+       &               .539570E+01,  .734580E+01,  .136038E+02 / 
+      DATA cg_aer/.619800E+00,  .619800E+00,  .619800E+00,                           &
+       &            .619800E+00,  .619800E+00,  .662700E+00,                         &
+       &            .682100E+00,  .698500E+00,  .712500E+00,                         &
+       &            .721800E+00,  .734600E+00,  .755800E+00,                         &
+       &            .545600E+00,  .545600E+00,  .545600E+00,                         &
+       &            .545600E+00,  .545600E+00,  .583700E+00,                         &
+       &            .607100E+00,  .627700E+00,  .645800E+00,                         &
+       &            .658400E+00,  .676500E+00,  .708500E+00 / 
+      DATA alpha_aer_sulfate/                                                        &
+       & 4.910,4.910,4.910,4.910,6.547,7.373,                                        &
+       & 8.373,9.788,12.167,14.256,17.924,28.433,                                    &
+       & 1.453,1.453,1.453,1.453,2.003,2.321,                                        &
+       & 2.711,3.282,4.287,5.210,6.914,12.305,                                       &
+       & 4.308,4.308,4.308,4.308,5.753,6.521,                                        &
+       & 7.449,8.772,11.014,12.999,16.518,26.772,                                    &
+       & 3.265,3.265,3.265,3.265,4.388,5.016,                                        &
+       & 5.775,6.868,8.745,10.429,13.457,22.538,                                     &
+       & 2.116,2.116,2.116,2.116,2.882,3.330,                                        &
+       & 3.876,4.670,6.059,7.327,9.650,16.883/
+!c
+      DO i=1, klon
+         taue670(i)=0.0
+         taue865(i)=0.0
+      ENDDO
+!c      
+      DO k=1, klev
+      DO i=1, klon
+         if (t_seri(i,k).eq.0) write (*,*) 'aeropt T ',i,k,t_seri(i,k)
+         if (pplay(i,k).eq.0) write (*,*) 'aeropt p ',i,k,pplay(i,k)         
+        zrho=pplay(i,k)/t_seri(i,k)/RD                  ! kg/m3
+        zdz=(paprs(i,k)-paprs(i,k+1))/zrho/RG           ! m
+        rh=MIN(RHcl(i,k)*100.,RH_MAX)
+        RH_num = INT( rh/10. + 1.)
+        IF (rh.LT.0.) THEN
+          abort_message = 'aeropt: RH < 0 not possible'
+          CALL abort_gcm (modname,abort_message,1)
+        ENDIF
+        IF (rh.gt.85.) RH_num=10
+        IF (rh.gt.90.) RH_num=11
+        DELTA=(rh-RH_tab(RH_num))/(RH_tab(RH_num+1)-RH_tab(RH_num))
+!c                
+        inu=1
+        tau_ae(i,k,inu)=alpha_aer(RH_num,inu) +                                      &
+       &             DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu))
+        tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6
+        piz_ae(i,k,inu)=1.0
+        cg_ae(i,k,inu)=cg_aer(RH_num,inu) +                                          &
+       &                 DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu))
+!c
+        inu=2
+        tau_ae(i,k,inu)=alpha_aer(RH_num,inu) +                                      &
+       &             DELTA*(alpha_aer(RH_num+1,inu)-alpha_aer(RH_num,inu))
+        tau_ae(i,k,inu)=tau_ae(i,k,inu)*msulfate(i,k)*zdz*1.e-6
+        piz_ae(i,k,inu)=1.0
+        cg_ae(i,k,inu)=cg_aer(RH_num,inu) +                                          &
+       &                 DELTA*(cg_aer(RH_num+1,inu)-cg_aer(RH_num,inu))
+!cjq
+!cjq for aerosol index
+!c
+        alphasulfate=alpha_aer_sulfate(RH_num,4) +                                   &
+       &       DELTA*(alpha_aer_sulfate(RH_num+1,4)-                                 &
+       &       alpha_aer_sulfate(RH_num,4)) !--m2/g 
+!c     
+        taue670(i)=taue670(i)+                                                       &
+       &       alphasulfate*msulfate(i,k)*zdz*1.e-6
+!c
+        alphasulfate=alpha_aer_sulfate(RH_num,5) +                                   &
+       &       DELTA*(alpha_aer_sulfate(RH_num+1,5)-                                 &
+       &       alpha_aer_sulfate(RH_num,5)) !--m2/g 
+!c
+        taue865(i)=taue865(i)+                                                       &
+       &         alphasulfate*msulfate(i,k)*zdz*1.e-6
+        
+      ENDDO
+      ENDDO
+!c      
+      DO i=1, klon
+        ai(i)=(-log(MAX(taue670(i),0.0001)/                                          &
+       &                MAX(taue865(i),0.0001))/log(670./865.)) *                    &
+       &        taue865(i)
+      ENDDO     
+!c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/aeropt_2bands.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/aeropt_2bands.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/aeropt_2bands.F90	(revision 17)
@@ -0,0 +1,1133 @@
+!
+! $Id: aeropt_2bands.F90 1750 2013-04-25 15:27:27Z fairhead $
+!
+SUBROUTINE AEROPT_2BANDS( &
+     pdel, m_allaer, delt, RHcl, &
+     tau_allaer, piz_allaer, &
+     cg_allaer, m_allaer_pi, &
+     flag_aerosol, pplay, t_seri, presnivs)
+
+  USE dimphy
+  USE aero_mod
+  USE phys_local_var_mod, only: absvisaer
+  USE pres2lev_mod
+
+
+  !    Yves Balkanski le 12 avril 2006
+  !    Celine Deandreis
+  !    Anne Cozic Avril 2009
+  !    a partir d'une sous-routine de Johannes Quaas pour les sulfates
+  !
+  IMPLICIT NONE
+
+  INCLUDE "YOMCST.h"
+  INCLUDE "iniprint.h"
+
+  !
+  ! Input arguments:
+  !
+  REAL, DIMENSION(klon,klev),     INTENT(in)  :: pdel
+  REAL,                           INTENT(in)  :: delt
+  REAL, DIMENSION(klon,klev,naero_spc),   INTENT(in)  :: m_allaer
+!RAF
+  REAL, DIMENSION(klon,klev,naero_spc),   INTENT(in)  :: m_allaer_pi
+  REAL, DIMENSION(klon,klev),     INTENT(in)  :: RHcl       ! humidite relative ciel clair
+!RAF  REAL, DIMENSION(klon,naero_tot),INTENT(in)  :: fractnat_allaer
+  INTEGER,                        INTENT(in)  :: flag_aerosol
+  REAL, DIMENSION(klon,klev),     INTENT(in)  :: pplay
+  REAL, DIMENSION(klon,klev),     INTENT(in)  :: t_seri
+  REAL, DIMENSION(klev),          INTENT(in)  :: presnivs
+  !
+  ! Output arguments:
+  !
+  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: tau_allaer ! epaisseur optique aerosol
+  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: piz_allaer ! single scattering albedo aerosol
+  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(out) :: cg_allaer  ! asymmetry parameter aerosol
+
+  !
+  ! Local
+  !
+  REAL, DIMENSION(klon,klev,naero_tot,nbands) ::  tau_ae
+!RAF
+  REAL, DIMENSION(klon,klev,naero_tot,nbands) ::  tau_ae_pi
+  REAL, DIMENSION(klon,klev,naero_tot,nbands) ::  piz_ae
+  REAL, DIMENSION(klon,klev,naero_tot,nbands) ::  cg_ae
+  LOGICAL ::  soluble
+  INTEGER :: i, k,n, ierr, inu, m, mrfspecies
+  INTEGER :: spsol, spinsol, spss
+  INTEGER :: RH_num(klon,klev)
+  INTEGER, PARAMETER :: nb_level=19 ! number of vertical levels in DATA
+
+  INTEGER, PARAMETER :: nbre_RH=12
+  INTEGER, PARAMETER :: naero_soluble=7    ! 1- BC soluble; 2- POM soluble; 3- SO4. acc. 4- SO4 coarse
+                                           ! 5- seasalt super coarse  6- seasalt coarse   7- seasalt acc.
+  INTEGER, PARAMETER :: naero_insoluble=3  ! 1- Dust; 2- BC insoluble; 3- POM insoluble
+  LOGICAL, SAVE :: firstcall=.TRUE. 
+!$OMP THREADPRIVATE(firstcall)
+
+! Coefficient optiques sur 19 niveaux
+  REAL, SAVE, DIMENSION(nb_level) :: presnivs_19  ! Pression milieux couche pour 19 niveaux (nb_level)
+!$OMP THREADPRIVATE(presnivs_19)
+
+  REAL, SAVE, DIMENSION(nb_level) :: A1_ASSSM_b1_19, A2_ASSSM_b1_19, A3_ASSSM_b1_19,&
+          B1_ASSSM_b1_19, B2_ASSSM_b1_19, C1_ASSSM_b1_19, C2_ASSSM_b1_19,&
+          A1_CSSSM_b1_19, A2_CSSSM_b1_19, A3_CSSSM_b1_19,&
+          B1_CSSSM_b1_19, B2_CSSSM_b1_19, C1_CSSSM_b1_19, C2_CSSSM_b1_19,&
+          A1_SSSSM_b1_19, A2_SSSSM_b1_19, A3_SSSSM_b1_19,&
+          B1_SSSSM_b1_19, B2_SSSSM_b1_19, C1_SSSSM_b1_19, C2_SSSSM_b1_19,&
+          A1_ASSSM_b2_19, A2_ASSSM_b2_19, A3_ASSSM_b2_19,&
+          B1_ASSSM_b2_19, B2_ASSSM_b2_19, C1_ASSSM_b2_19, C2_ASSSM_b2_19,&
+          A1_CSSSM_b2_19, A2_CSSSM_b2_19, A3_CSSSM_b2_19,&
+          B1_CSSSM_b2_19, B2_CSSSM_b2_19, C1_CSSSM_b2_19, C2_CSSSM_b2_19,&
+          A1_SSSSM_b2_19, A2_SSSSM_b2_19, A3_SSSSM_b2_19,&
+          B1_SSSSM_b2_19, B2_SSSSM_b2_19, C1_SSSSM_b2_19, C2_SSSSM_b2_19
+!$OMP THREADPRIVATE(A1_ASSSM_b1_19, A2_ASSSM_b1_19, A3_ASSSM_b1_19)
+!$OMP THREADPRIVATE(B1_ASSSM_b1_19, B2_ASSSM_b1_19, C1_ASSSM_b1_19, C2_ASSSM_b1_19)
+!$OMP THREADPRIVATE(A1_CSSSM_b1_19, A2_CSSSM_b1_19, A3_CSSSM_b1_19)
+!$OMP THREADPRIVATE(B1_CSSSM_b1_19, B2_CSSSM_b1_19, C1_CSSSM_b1_19, C2_CSSSM_b1_19)
+!$OMP THREADPRIVATE(A1_SSSSM_b1_19, A2_SSSSM_b1_19, A3_SSSSM_b1_19)
+!$OMP THREADPRIVATE(B1_SSSSM_b1_19, B2_SSSSM_b1_19, C1_SSSSM_b1_19, C2_SSSSM_b1_19)
+!$OMP THREADPRIVATE(A1_ASSSM_b2_19, A2_ASSSM_b2_19, A3_ASSSM_b2_19)
+!$OMP THREADPRIVATE(B1_ASSSM_b2_19, B2_ASSSM_b2_19, C1_ASSSM_b2_19, C2_ASSSM_b2_19)
+!$OMP THREADPRIVATE(A1_CSSSM_b2_19, A2_CSSSM_b2_19, A3_CSSSM_b2_19)
+!$OMP THREADPRIVATE(B1_CSSSM_b2_19, B2_CSSSM_b2_19, C1_CSSSM_b2_19, C2_CSSSM_b2_19)
+!$OMP THREADPRIVATE(A1_SSSSM_b2_19, A2_SSSSM_b2_19, A3_SSSSM_b2_19)
+!$OMP THREADPRIVATE(B1_SSSSM_b2_19, B2_SSSSM_b2_19, C1_SSSSM_b2_19, C2_SSSSM_b2_19)
+
+
+! Coefficient optiques interpole sur le nombre de niveau du modele
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE :: &
+          A1_ASSSM_b1, A2_ASSSM_b1, A3_ASSSM_b1,&
+          B1_ASSSM_b1, B2_ASSSM_b1, C1_ASSSM_b1, C2_ASSSM_b1,&
+          A1_CSSSM_b1, A2_CSSSM_b1, A3_CSSSM_b1,&
+          B1_CSSSM_b1, B2_CSSSM_b1, C1_CSSSM_b1, C2_CSSSM_b1,&
+          A1_SSSSM_b1, A2_SSSSM_b1, A3_SSSSM_b1,&
+          B1_SSSSM_b1, B2_SSSSM_b1, C1_SSSSM_b1, C2_SSSSM_b1,&
+          A1_ASSSM_b2, A2_ASSSM_b2, A3_ASSSM_b2,&
+          B1_ASSSM_b2, B2_ASSSM_b2, C1_ASSSM_b2, C2_ASSSM_b2,&
+          A1_CSSSM_b2, A2_CSSSM_b2, A3_CSSSM_b2,&
+          B1_CSSSM_b2, B2_CSSSM_b2, C1_CSSSM_b2, C2_CSSSM_b2,&
+          A1_SSSSM_b2, A2_SSSSM_b2, A3_SSSSM_b2,&
+          B1_SSSSM_b2, B2_SSSSM_b2, C1_SSSSM_b2, C2_SSSSM_b2
+!$OMP THREADPRIVATE(A1_ASSSM_b1, A2_ASSSM_b1, A3_ASSSM_b1)
+!$OMP THREADPRIVATE(B1_ASSSM_b1, B2_ASSSM_b1, C1_ASSSM_b1, C2_ASSSM_b1)
+!$OMP THREADPRIVATE(A1_CSSSM_b1, A2_CSSSM_b1, A3_CSSSM_b1)
+!$OMP THREADPRIVATE(B1_CSSSM_b1, B2_CSSSM_b1, C1_CSSSM_b1, C2_CSSSM_b1)
+!$OMP THREADPRIVATE(A1_SSSSM_b1, A2_SSSSM_b1, A3_SSSSM_b1)
+!$OMP THREADPRIVATE(B1_SSSSM_b1, B2_SSSSM_b1, C1_SSSSM_b1, C2_SSSSM_b1)
+!$OMP THREADPRIVATE(A1_ASSSM_b2, A2_ASSSM_b2, A3_ASSSM_b2)
+!$OMP THREADPRIVATE(B1_ASSSM_b2, B2_ASSSM_b2, C1_ASSSM_b2, C2_ASSSM_b2)
+!$OMP THREADPRIVATE(A1_CSSSM_b2, A2_CSSSM_b2, A3_CSSSM_b2)
+!$OMP THREADPRIVATE(B1_CSSSM_b2, B2_CSSSM_b2, C1_CSSSM_b2, C2_CSSSM_b2)
+!$OMP THREADPRIVATE(A1_SSSSM_b2, A2_SSSSM_b2, A3_SSSSM_b2)
+!$OMP THREADPRIVATE(B1_SSSSM_b2, B2_SSSSM_b2, C1_SSSSM_b2, C2_SSSSM_b2)
+  
+  REAL,PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./)
+  REAL, PARAMETER :: RH_MAX=95.
+  REAL:: DELTA(klon,klev), rh(klon,klev), H
+  REAL:: tau_ae2b_int   ! Intermediate computation of epaisseur optique aerosol
+  REAL:: piz_ae2b_int   ! Intermediate computation of Single scattering albedo
+  REAL:: cg_ae2b_int    ! Intermediate computation of Assymetry parameter
+  REAL :: Fact_RH(nbre_RH)
+  REAL :: zrho
+  REAL :: fac
+  REAL :: zdp1(klon,klev) 
+  REAL, PARAMETER ::  gravit = 9.80616    ! m2/s
+  INTEGER, ALLOCATABLE, DIMENSION(:)   :: aerosol_name
+  INTEGER :: nb_aer
+  REAL, DIMENSION(klon,klev,naero_spc) :: mass_temp
+!RAF
+  REAL, DIMENSION(klon,klev,naero_spc) :: mass_temp_pi
+
+  !
+  ! Proprietes optiques
+  !
+  REAL:: alpha_aers_2bands(nbre_RH,nbands,naero_soluble)   !--unit m2/g SO4
+  REAL:: alpha_aeri_2bands(nbands,naero_insoluble)
+  REAL:: cg_aers_2bands(nbre_RH,nbands,naero_soluble)      !--unit 
+  REAL:: cg_aeri_2bands(nbands,naero_insoluble)
+  REAL:: piz_aers_2bands(nbre_RH,nbands,naero_soluble)     !-- unit
+  REAL:: piz_aeri_2bands(nbands,naero_insoluble)           !-- unit
+
+  INTEGER :: id
+  LOGICAL :: used_aer(naero_tot)
+  REAL :: tmp_var, tmp_var_pi
+
+  DATA presnivs_19/&
+       100426.5,  98327.6, 95346.5, 90966.8, 84776.9, &
+       76536.5,   66292.2, 54559.3, 42501.8, 31806, &
+       23787.5,   18252.7, 13996,   10320.8, 7191.1, &
+       4661.7,    2732.9,  1345.6,  388.2/  
+
+
+!***********************BAND 1***********************************
+!ACCUMULATION MODE
+  DATA A1_ASSSM_b1_19/ 4.373E+00,  4.361E+00,  4.331E+00, &
+                    4.278E+00,  4.223E+00,  4.162E+00, &
+                    4.103E+00,  4.035E+00,  3.962E+00, &
+                    3.904E+00,  3.871E+00,  3.847E+00, &
+                    3.824E+00,  3.780E+00,  3.646E+00, &
+                    3.448E+00,  3.179E+00,  2.855E+00,  2.630E+00/
+  DATA A2_ASSSM_b1_19/ 2.496E+00,  2.489E+00,  2.472E+00, &
+                    2.442E+00,  2.411E+00,  2.376E+00, &
+                    2.342E+00,  2.303E+00,  2.261E+00, &
+                    2.228E+00,  2.210E+00,  2.196E+00, &
+                    2.183E+00,  2.158E+00,  2.081E+00, &
+                    1.968E+00,  1.814E+00,  1.630E+00,  1.501E+00/
+  DATA A3_ASSSM_b1_19/-4.688E-02, -4.676E-02, -4.644E-02, &
+                   -4.587E-02, -4.528E-02, -4.463E-02, &
+                   -4.399E-02, -4.326E-02, -4.248E-02, &
+                   -4.186E-02, -4.151E-02, -4.125E-02, &
+                   -4.100E-02, -4.053E-02, -3.910E-02, &
+                   -3.697E-02, -3.408E-02, -3.061E-02, -2.819E-02/
+  DATA B1_ASSSM_b1_19/ 1.165E-08,  1.145E-08,  1.097E-08, &
+                    1.012E-08,  9.233E-09,  8.261E-09, &
+                    7.297E-09,  6.201E-09,  5.026E-09, &
+                    4.098E-09,  3.567E-09,  3.187E-09, &
+                    2.807E-09,  2.291E-09,  2.075E-09, &
+                    1.756E-09,  1.322E-09,  8.011E-10, 4.379E-10/
+  DATA B2_ASSSM_b1_19/ 2.193E-08,  2.192E-08,  2.187E-08, &
+                    2.179E-08,  2.171E-08,  2.162E-08, &
+                    2.153E-08,  2.143E-08,  2.132E-08, &
+                    2.124E-08,  2.119E-08,  2.115E-08, &
+                    2.112E-08,  2.106E-08,  2.100E-08, &
+                    2.090E-08,  2.077E-08,  2.061E-08,  2.049E-08/
+  DATA C1_ASSSM_b1_19/ 7.365E-01,  7.365E-01,  7.365E-01, &
+                    7.364E-01,  7.363E-01,  7.362E-01, &
+                    7.361E-01,  7.359E-01,  7.358E-01, &
+                    7.357E-01,  7.356E-01,  7.356E-01, &
+                    7.356E-01,  7.355E-01,  7.354E-01, &
+                    7.352E-01,  7.350E-01,  7.347E-01,  7.345E-01/
+  DATA C2_ASSSM_b1_19/ 5.833E-02,  5.835E-02,  5.841E-02, &
+                    5.850E-02,  5.859E-02,  5.870E-02, &
+                    5.880E-02,  5.891E-02,  5.904E-02, &
+                    5.914E-02,  5.920E-02,  5.924E-02, &
+                    5.928E-02,  5.934E-02,  5.944E-02, &
+                    5.959E-02,  5.979E-02,  6.003E-02,  6.020E-02/
+!COARSE MODE
+  DATA A1_CSSSM_b1_19/ 7.403E-01,  7.422E-01,  7.626E-01, &
+                    8.019E-01,  8.270E-01,  8.527E-01, &
+                    8.702E-01,  8.806E-01,  8.937E-01, &
+                    9.489E-01,  1.030E+00,  1.105E+00, &
+                    1.199E+00,  1.357E+00,  1.660E+00, &
+                    2.540E+00,  4.421E+00,  2.151E+00,  9.518E-01/
+  DATA A2_CSSSM_b1_19/ 4.522E-01,  4.532E-01,  4.644E-01, &
+                    4.859E-01,  4.996E-01,  5.137E-01, &
+                    5.233E-01,  5.290E-01,  5.361E-01, &
+                    5.655E-01,  6.085E-01,  6.483E-01, &
+                    6.979E-01,  7.819E-01,  9.488E-01, &
+                    1.450E+00,  2.523E+00,  1.228E+00,  5.433E-01/
+  DATA A3_CSSSM_b1_19/-8.516E-03, -8.535E-03, -8.744E-03, &
+                   -9.148E-03, -9.406E-03, -9.668E-03, &
+                   -9.848E-03, -9.955E-03, -1.009E-02, &
+                   -1.064E-02, -1.145E-02, -1.219E-02, &
+                   -1.312E-02, -1.470E-02, -1.783E-02, &
+                   -2.724E-02, -4.740E-02, -2.306E-02, -1.021E-02/
+  DATA B1_CSSSM_b1_19/ 2.535E-07,  2.530E-07,  2.479E-07, &
+                    2.380E-07,  2.317E-07,  2.252E-07, &
+                    2.208E-07,  2.182E-07,  2.149E-07, &
+                    2.051E-07,  1.912E-07,  1.784E-07, &
+                    1.624E-07,  1.353E-07,  1.012E-07, &
+                    6.016E-08,  2.102E-08,  0.000E+00,  0.000E+00/
+  DATA B2_CSSSM_b1_19/ 1.221E-07,  1.217E-07,  1.179E-07, &
+                    1.104E-07,  1.056E-07,  1.008E-07, &
+                    9.744E-08,  9.546E-08,  9.299E-08, &
+                    8.807E-08,  8.150E-08,  7.544E-08, &
+                    6.786E-08,  5.504E-08,  4.080E-08, &
+                    2.960E-08,  2.300E-08,  2.030E-08,  1.997E-08/
+  DATA C1_CSSSM_b1_19/ 7.659E-01,  7.658E-01,  7.652E-01, &
+                    7.639E-01,  7.631E-01,  7.623E-01, &
+                    7.618E-01,  7.614E-01,  7.610E-01, &
+                    7.598E-01,  7.581E-01,  7.566E-01, &
+                    7.546E-01,  7.513E-01,  7.472E-01, &
+                    7.423E-01,  7.376E-01,  7.342E-01,  7.334E-01/
+  DATA C2_CSSSM_b1_19/ 3.691E-02,  3.694E-02,  3.729E-02, &
+                    3.796E-02,  3.839E-02,  3.883E-02, &
+                    3.913E-02,  3.931E-02,  3.953E-02, &
+                    4.035E-02,  4.153E-02,  4.263E-02, &
+                    4.400E-02,  4.631E-02,  4.933E-02, &
+                    5.331E-02,  5.734E-02,  6.053E-02,  6.128E-02/
+!SUPER COARSE MODE
+  DATA A1_SSSSM_b1_19/ 2.836E-01,  2.876E-01,  2.563E-01, &
+                    2.414E-01,  2.541E-01,  2.546E-01, &
+                    2.572E-01,  2.638E-01,  2.781E-01, &
+                    3.167E-01,  4.209E-01,  5.286E-01, &
+                    6.959E-01,  9.233E-01,  1.282E+00, &
+                    1.836E+00,  2.981E+00,  4.355E+00,  4.059E+00/
+  DATA A2_SSSSM_b1_19/ 1.608E-01,  1.651E-01,  1.577E-01, &
+                    1.587E-01,  1.686E-01,  1.690E-01, &
+                    1.711E-01,  1.762E-01,  1.874E-01, &
+                    2.138E-01,  2.751E-01,  3.363E-01, &
+                    4.279E-01,  5.519E-01,  7.421E-01, &
+                    1.048E+00,  1.702E+00,  2.485E+00,  2.317E+00/
+  DATA A3_SSSSM_b1_19/-3.025E-03, -3.111E-03, -2.981E-03, &
+                   -3.005E-03, -3.193E-03, -3.200E-03, &
+                   -3.239E-03, -3.336E-03, -3.548E-03, &
+                   -4.047E-03, -5.196E-03, -6.345E-03, &
+                   -8.061E-03, -1.038E-02, -1.395E-02, &
+                   -1.970E-02, -3.197E-02, -4.669E-02, -4.352E-02/
+  DATA B1_SSSSM_b1_19/ 6.759E-07,  6.246E-07,  5.542E-07, &
+                    4.953E-07,  4.746E-07,  4.738E-07, &
+                    4.695E-07,  4.588E-07,  4.354E-07, &
+                    3.947E-07,  3.461E-07,  3.067E-07, &
+                    2.646E-07,  2.095E-07,  1.481E-07, &
+                    9.024E-08,  5.747E-08,  2.384E-08,  6.599E-09/
+  DATA B2_SSSSM_b1_19/ 5.977E-07,  5.390E-07,  4.468E-07, &
+                    3.696E-07,  3.443E-07,  3.433E-07, &
+                    3.380E-07,  3.249E-07,  2.962E-07, &
+                    2.483E-07,  1.989E-07,  1.623E-07, &
+                    1.305E-07,  9.015E-08,  6.111E-08, &
+                    3.761E-08,  2.903E-08,  2.337E-08,  2.147E-08/
+  DATA C1_SSSSM_b1_19/ 8.120E-01,  8.084E-01,  8.016E-01, &
+                    7.953E-01,  7.929E-01,  7.928E-01, &
+                    7.923E-01,  7.910E-01,  7.882E-01, &
+                    7.834E-01,  7.774E-01,  7.725E-01, &
+                    7.673E-01,  7.604E-01,  7.529E-01, &
+                    7.458E-01,  7.419E-01,  7.379E-01,  7.360E-01/
+  DATA C2_SSSSM_b1_19/ 2.388E-02,  2.392E-02,  2.457E-02,  2.552E-02, &
+                    2.615E-02,  2.618E-02,  2.631E-02,  2.663E-02, &
+                    2.735E-02,  2.875E-02,  3.113E-02,  3.330E-02, &
+                    3.615E-02,  3.997E-02,  4.521E-02,  5.038E-02, &
+                    5.358E-02,  5.705E-02,  5.887E-02/
+!*********************BAND 2************************************************
+!ACCUMULATION MODE
+  DATA A1_ASSSM_b2_19/1.256E+00, 1.246E+00, 1.226E+00, 1.187E+00, 1.148E+00, &
+                   1.105E+00, 1.062E+00, 1.014E+00, 9.616E-01, 9.205E-01, &
+                   8.970E-01, 8.800E-01, 8.632E-01, 8.371E-01, 7.943E-01, &
+                   7.308E-01, 6.448E-01, 5.414E-01, 4.693E-01/
+  DATA A2_ASSSM_b2_19/5.321E-01, 5.284E-01, 5.196E-01, 5.036E-01, 4.872E-01, &
+                   4.691E-01, 4.512E-01, 4.308E-01, 4.089E-01, 3.917E-01, &
+                   3.818E-01, 3.747E-01, 3.676E-01, 3.567E-01, 3.385E-01, &
+                   3.116E-01, 2.751E-01, 2.312E-01, 2.006E-01/
+  DATA A3_ASSSM_b2_19/-1.053E-02, -1.046E-02, -1.028E-02, -9.964E-03, -9.637E-03, &
+                   -9.279E-03, -8.923E-03, -8.518E-03, -8.084E-03, -7.741E-03, &
+                   -7.545E-03, -7.405E-03, -7.265E-03, -7.048E-03, -6.687E-03, &
+                   -6.156E-03, -5.433E-03, -4.565E-03, -3.961E-03/
+  DATA B1_ASSSM_b2_19/1.560E-02, 1.560E-02, 1.561E-02, 1.565E-02, 1.568E-02, &
+                   1.572E-02, 1.576E-02, 1.580E-02, 1.584E-02, 1.588E-02, &
+                   1.590E-02, 1.592E-02, 1.593E-02, 1.595E-02, 1.599E-02, &
+                   1.605E-02, 1.612E-02, 1.621E-02, 1.627E-02/
+  DATA B2_ASSSM_b2_19/1.073E-02, 1.074E-02, 1.076E-02, 1.079E-02, 1.082E-02, &
+                   1.085E-02, 1.089E-02, 1.093E-02, 1.097E-02, 1.100E-02, &
+                   1.102E-02, 1.103E-02, 1.105E-02, 1.107E-02, 1.110E-02, &
+                   1.115E-02, 1.122E-02, 1.130E-02, 1.136E-02/
+  DATA C1_ASSSM_b2_19/7.429E-01, 7.429E-01, 7.429E-01, 7.427E-01, 7.427E-01, &
+                   7.424E-01, 7.423E-01, 7.422E-01, 7.421E-01, 7.420E-01, &
+                   7.419E-01, 7.419E-01, 7.418E-01, 7.417E-01, 7.416E-01, &
+                   7.415E-01, 7.413E-01, 7.409E-01, 7.408E-01/
+  DATA C2_ASSSM_b2_19/3.031E-02, 3.028E-02, 3.022E-02, 3.011E-02, 2.999E-02, &
+                   2.986E-02, 2.973E-02, 2.959E-02, 2.943E-02, 2.931E-02, &
+                   2.924E-02, 2.919E-02, 2.913E-02, 2.905E-02, 2.893E-02, &
+                   2.874E-02, 2.847E-02, 2.817E-02, 2.795E-02/
+!COARSE MODE
+  DATA A1_CSSSM_b2_19/7.061E-01, 7.074E-01, 7.211E-01, 7.476E-01, 7.647E-01, &
+                   7.817E-01, 7.937E-01, 8.007E-01, 8.095E-01, 8.436E-01, &
+                   8.932E-01, 9.390E-01, 9.963E-01, 1.093E+00, 1.256E+00, &
+                   1.668E+00, 1.581E+00, 3.457E-01, 1.331E-01/
+  DATA A2_CSSSM_b2_19/3.617E-01, 3.621E-01, 3.662E-01, 3.739E-01, 3.789E-01, &
+                   3.840E-01, 3.874E-01, 3.895E-01, 3.921E-01, 4.001E-01, &
+                   4.117E-01, 4.223E-01, 4.356E-01, 4.581E-01, 5.099E-01, &
+                   6.831E-01, 6.663E-01, 1.481E-01, 5.703E-02/
+  DATA A3_CSSSM_b2_19/-6.953E-03, -6.961E-03, -7.048E-03, -7.216E-03, -7.322E-03, &
+                   -7.431E-03, -7.506E-03, -7.551E-03, -7.606E-03, -7.791E-03, &
+                   -8.059E-03, -8.305E-03, -8.613E-03, -9.134E-03, -1.023E-02, &
+                   -1.365E-02, -1.320E-02, -2.922E-03, -1.125E-03/
+  DATA B1_CSSSM_b2_19/1.007E-02, 1.008E-02, 1.012E-02, 1.019E-02, 1.024E-02, &
+                   1.029E-02, 1.033E-02, 1.035E-02, 1.038E-02, 1.056E-02, &
+                   1.083E-02, 1.109E-02, 1.140E-02, 1.194E-02, 1.270E-02, &
+                   1.390E-02, 1.524E-02, 1.639E-02, 1.667E-02/
+  DATA B2_CSSSM_b2_19/4.675E-03, 4.682E-03, 4.760E-03, 4.908E-03, 5.004E-03, &
+                   5.102E-03, 5.168E-03, 5.207E-03, 5.256E-03, 5.474E-03, &
+                   5.793E-03, 6.089E-03, 6.457E-03, 7.081E-03, 7.923E-03, &
+                   9.127E-03, 1.041E-02, 1.147E-02, 1.173E-02/
+  DATA C1_CSSSM_b2_19/7.571E-01, 7.571E-01, 7.570E-01, 7.568E-01, 7.565E-01, &
+                   7.564E-01, 7.563E-01, 7.562E-01, 7.562E-01, 7.557E-01, &
+                   7.552E-01, 7.545E-01, 7.539E-01, 7.527E-01, 7.509E-01, &
+                   7.478E-01, 7.440E-01, 7.404E-01, 7.394E-01/
+  DATA C2_CSSSM_b2_19/4.464E-02, 4.465E-02, 4.468E-02, 4.474E-02, 4.477E-02, &
+                   4.480E-02, 4.482E-02, 4.484E-02, 4.486E-02, 4.448E-02, &
+                   4.389E-02, 4.334E-02, 4.264E-02, 4.148E-02, 3.957E-02, &
+                   3.588E-02, 3.149E-02, 2.751E-02, 2.650E-02/
+!SUPER COARSE MODE
+  DATA A1_SSSSM_b2_19/2.357E-01, 2.490E-01, 2.666E-01, 2.920E-01, 3.120E-01, &
+                   3.128E-01, 3.169E-01, 3.272E-01, 3.498E-01, 3.960E-01, &
+                   4.822E-01, 5.634E-01, 6.763E-01, 8.278E-01, 1.047E+00, &
+                   1.340E+00, 1.927E+00, 1.648E+00, 1.031E+00/
+  DATA A2_SSSSM_b2_19/1.219E-01, 1.337E-01, 1.633E-01, 1.929E-01, 2.057E-01, &
+                   2.062E-01, 2.089E-01, 2.155E-01, 2.300E-01, 2.560E-01, &
+                   2.908E-01, 3.199E-01, 3.530E-01, 3.965E-01, 4.475E-01, &
+                   5.443E-01, 7.943E-01, 6.928E-01, 4.381E-01/
+  DATA A3_SSSSM_b2_19/-2.387E-03, -2.599E-03, -3.092E-03, -3.599E-03, -3.832E-03, &
+                   -3.842E-03, -3.890E-03, -4.012E-03, -4.276E-03, -4.763E-03, &
+                   -5.455E-03, -6.051E-03, -6.763E-03, -7.708E-03, -8.887E-03, &
+                   -1.091E-02, -1.585E-02, -1.373E-02, -8.665E-03/
+  DATA B1_SSSSM_b2_19/1.260E-02, 1.211E-02, 1.126E-02, 1.056E-02, 1.038E-02, &
+                   1.037E-02, 1.033E-02, 1.023E-02, 1.002E-02, 9.717E-03, &
+                   9.613E-03, 9.652E-03, 9.983E-03, 1.047E-02, 1.168E-02, &
+                   1.301E-02, 1.399E-02, 1.514E-02, 1.578E-02/
+  DATA B2_SSSSM_b2_19/2.336E-03, 2.419E-03, 2.506E-03, 2.610E-03, 2.690E-03, &
+                   2.694E-03, 2.711E-03, 2.752E-03, 2.844E-03, 3.043E-03, &
+                   3.455E-03, 3.871E-03, 4.507E-03, 5.373E-03, 6.786E-03, &
+                   8.238E-03, 9.208E-03, 1.032E-02, 1.091E-02/
+  DATA C1_SSSSM_b2_19/7.832E-01, 7.787E-01, 7.721E-01, 7.670E-01, 7.657E-01, &
+                   7.657E-01, 7.654E-01, 7.648E-01, 7.634E-01, 7.613E-01, &
+                   7.596E-01, 7.585E-01, 7.574E-01, 7.560E-01, 7.533E-01, &
+                   7.502E-01, 7.476E-01, 7.443E-01, 7.423E-01/
+  DATA C2_SSSSM_b2_19/3.144E-02, 3.268E-02, 3.515E-02, 3.748E-02, 3.837E-02, &
+                   3.840E-02, 3.860E-02, 3.906E-02, 4.006E-02, 4.173E-02, &
+                   4.338E-02, 4.435E-02, 4.459E-02, 4.467E-02, 4.202E-02, &
+                   3.864E-02, 3.559E-02, 3.183E-02, 2.964E-02/
+!***************************************************************************
+
+  spsol = 0
+  spinsol = 0 
+  spss = 0 
+
+  DATA alpha_aers_2bands/  & 
+       ! bc soluble
+       7.675,7.675,7.675,7.675,7.675,7.675,    &
+       7.675,7.675,10.433,11.984,13.767,15.567,& 
+       4.720,4.720,4.720,4.720,4.720,4.720,    & 
+       4.720,4.720,6.081,6.793,7.567,9.344,    & 
+       ! pom soluble
+       5.503,5.503,5.503,5.503,5.588,5.957,    & 
+       6.404,7.340,8.545,10.319,13.595,20.398, & 
+       1.402,1.402,1.402,1.402,1.431,1.562,    & 
+       1.715,2.032,2.425,2.991,4.193,7.133,    & 
+       ! sulfate    
+       4.681,5.062,5.460,5.798,6.224,6.733,    & 
+       7.556,8.613,10.687,12.265,16.32,21.692, & 
+       1.107,1.239,1.381,1.490,1.635,1.8030,   &
+       2.071,2.407,3.126,3.940,5.539,7.921,    &
+                                ! sulfate coarse
+       4.681,5.062,5.460,5.798,6.224,6.733,    & 
+       7.556,8.613,10.687,12.265,16.32,21.692, & 
+       1.107,1.239,1.381,1.490,1.635,1.8030,   &
+       2.071,2.407,3.126,3.940,5.539,7.921,    &
+                                ! seasalt Super Coarse Soluble (SS)
+       0.5090,0.6554,0.7129,0.7767,0.8529,1.2728, &
+       1.3820,1.5792,1.9173,2.2002,2.7173,4.1487, &
+       0.5167,0.6613,0.7221,0.7868,0.8622,1.3027, &
+       1.4227,1.6317,1.9887,2.2883,2.8356,4.3453, &
+                                ! seasalt  Coarse Soluble (CS)
+       0.5090,0.6554,0.7129,0.7767,0.8529,1.2728, &
+       1.3820,1.5792,1.9173,2.2002,2.7173,4.1487, &
+       0.5167,0.6613,0.7221,0.7868,0.8622,1.3027, &
+       1.4227,1.6317,1.9887,2.2883,2.8356,4.3453, &
+                                ! seasalt  Accumulation Soluble (AS)
+       4.125, 4.674, 5.005, 5.434, 5.985, 10.006, &
+       11.175,13.376,17.264,20.540,26.604, 42.349,&
+       4.187, 3.939, 3.919, 3.937, 3.995,  5.078, &
+       5.511, 6.434, 8.317,10.152,14.024, 26.537/
+
+  DATA alpha_aeri_2bands/  & 
+       ! dust insoluble
+       0.7661,0.7123,&
+       ! bc insoluble
+       10.360,4.437, &
+       ! pom insoluble
+       3.741,0.606/
+
+  DATA cg_aers_2bands/ &
+       ! bc soluble
+       .612, .612, .612, .612, .612, .612, &
+       .612, .612, .702, .734, .760, .796, &
+       .433, .433, .433, .433, .433, .433, &
+       .433, .433, .534, .575, .613, .669, &
+       ! pom soluble
+       .663, .663, .663, .663, .666, .674, &
+       .685, .702, .718, .737, .757, .777, &
+       .544, .544, .544, .544, .547, .554, &
+       .565, .583, .604, .631, .661, .698, &
+       ! sulfate    
+       .658, .669, .680, .688, .698, .707, &
+       .719, .733, .752, .760, .773, .786, &
+       .544, .555, .565, .573, .583, .593, &
+       .610, .628, .655, .666, .692, .719, &
+                                ! sulfate coarse
+       .658, .669, .680, .688, .698, .707, &
+       .719, .733, .752, .760, .773, .786, &
+       .544, .555, .565, .573, .583, .593, &
+       .610, .628, .655, .666, .692, .719, &
+                                ! seasalt Super Coarse soluble (SS)
+       .727, .747, .755, .761, .770, .788, &
+       .792, .799, .805, .809, .815, .826, &
+       .717, .738, .745, .752, .761, .779, &
+       .781, .786, .793, .797, .803, .813, &
+                                ! seasalt Coarse soluble (CS)
+       .727, .747, .755, .761, .770, .788, &
+       .792, .799, .805, .809, .815, .826, &
+       .717, .738, .745, .752, .761, .779, &
+       .781, .786, .793, .797, .803, .813, &
+                                ! Sesalt Accumulation Soluble (AS)
+       .727, .741, .748, .754, .761, .782, &
+       .787, .792, .797, .799, .801, .799, &
+       .606, .645, .658, .669, .681, .726, &
+       .734, .746, .761, .770, .782, .798/
+
+  DATA cg_aeri_2bands/ &
+       ! dust insoluble
+       .701, .670, &
+       ! bc insoluble
+       .471, .297, &
+       ! pom insoluble
+       .568, .365/
+
+  DATA piz_aers_2bands/&
+       ! bc soluble
+       .445, .445, .445, .445, .445, .445, &
+       .445, .445, .461, .480, .505, .528, &
+       .362, .362, .362, .362, .362, .362, &
+       .362, .362, .381, .405, .437, .483, &
+       ! pom soluble
+       .972, .972, .972, .972, .972, .974, &
+       .976, .979, .982, .986, .989, .992, &
+       .924, .924, .924, .924, .925, .927, &
+       .932, .938, .945, .952, .961, .970, &
+       ! sulfate
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       .992, .988, .988, .987, .986, .985,  &
+       .985, .985, .984, .984, .984, .984,  &
+                                ! sulfate coarse
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       .992, .988, .988, .987, .986, .985,  &
+       .985, .985, .984, .984, .984, .984,  &
+                                ! seasalt Super Coarse Soluble (SS)
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       0.992,0.989,0.987,0.986,0.986,0.980, &
+       0.980,0.978,0.976,0.976,0.974,0.971, &
+                                ! seasalt Coarse soluble (CS)
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       1.000,1.000,1.000,1.000,1.000,1.000, &
+       0.992,0.989,0.987,0.986,0.986,0.980, &
+       0.980,0.978,0.976,0.976,0.974,0.971, &
+                                ! seasalt Accumulation Soluble (AS)
+       1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
+       1.000, 1.000, 1.000, 1.000, 1.000, 1.000, &
+       0.970, 0.975, 0.976, 0.977, 0.978, 0.982, &
+       0.982, 0.983, 0.984, 0.984, 0.985, 0.985/
+
+  DATA piz_aeri_2bands/ &
+       ! dust insoluble
+       .963, .987, &
+       ! bc insoluble
+       .395, .264, &
+       ! pom insoluble
+       .966, .859/
+
+! Interpolation des coefficients optiques de 19 niveaux vers le nombre des niveaux du model
+  IF (firstcall) THEN
+     firstcall=.FALSE.
+     
+     IF (.NOT. ALLOCATED(A1_ASSSM_b1)) THEN
+        ALLOCATE(A1_ASSSM_b1(klev),A2_ASSSM_b1(klev), A3_ASSSM_b1(klev),&
+          B1_ASSSM_b1(klev), B2_ASSSM_b1(klev), C1_ASSSM_b1(klev), C2_ASSSM_b1(klev),&
+          A1_CSSSM_b1(klev), A2_CSSSM_b1(klev), A3_CSSSM_b1(klev),&
+          B1_CSSSM_b1(klev), B2_CSSSM_b1(klev), C1_CSSSM_b1(klev), C2_CSSSM_b1(klev),&
+          A1_SSSSM_b1(klev), A2_SSSSM_b1(klev), A3_SSSSM_b1(klev),&
+          B1_SSSSM_b1(klev), B2_SSSSM_b1(klev), C1_SSSSM_b1(klev), C2_SSSSM_b1(klev),&
+          A1_ASSSM_b2(klev), A2_ASSSM_b2(klev), A3_ASSSM_b2(klev),&
+          B1_ASSSM_b2(klev), B2_ASSSM_b2(klev), C1_ASSSM_b2(klev), C2_ASSSM_b2(klev),&
+          A1_CSSSM_b2(klev), A2_CSSSM_b2(klev), A3_CSSSM_b2(klev),&
+          B1_CSSSM_b2(klev), B2_CSSSM_b2(klev), C1_CSSSM_b2(klev), C2_CSSSM_b2(klev),&
+          A1_SSSSM_b2(klev), A2_SSSSM_b2(klev), A3_SSSSM_b2(klev),&
+          B1_SSSSM_b2(klev), B2_SSSSM_b2(klev), C1_SSSSM_b2(klev), C2_SSSSM_b2(klev), stat=ierr)
+        IF (ierr /= 0) CALL abort_gcm('aeropt_2bands', 'pb in allocation 1',1)
+     END IF
+     
+! bande 1
+     CALL pres2lev(A1_ASSSM_b1_19, A1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_ASSSM_b1_19, A2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_ASSSM_b1_19, A3_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_ASSSM_b1_19, B1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_ASSSM_b1_19, B2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_ASSSM_b1_19, C1_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_ASSSM_b1_19, C2_ASSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+     CALL pres2lev(A1_CSSSM_b1_19, A1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_CSSSM_b1_19, A2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_CSSSM_b1_19, A3_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_CSSSM_b1_19, B1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_CSSSM_b1_19, B2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_CSSSM_b1_19, C1_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_CSSSM_b1_19, C2_CSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+     CALL pres2lev(A1_SSSSM_b1_19, A1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_SSSSM_b1_19, A2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_SSSSM_b1_19, A3_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_SSSSM_b1_19, B1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_SSSSM_b1_19, B2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_SSSSM_b1_19, C1_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_SSSSM_b1_19, C2_SSSSM_b1, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+! bande 2
+     CALL pres2lev(A1_ASSSM_b2_19, A1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_ASSSM_b2_19, A2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_ASSSM_b2_19, A3_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_ASSSM_b2_19, B1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_ASSSM_b2_19, B2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_ASSSM_b2_19, C1_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_ASSSM_b2_19, C2_ASSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+     CALL pres2lev(A1_CSSSM_b2_19, A1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_CSSSM_b2_19, A2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_CSSSM_b2_19, A3_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_CSSSM_b2_19, B1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_CSSSM_b2_19, B2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_CSSSM_b2_19, C1_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_CSSSM_b2_19, C2_CSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+     CALL pres2lev(A1_SSSSM_b2_19, A1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_SSSSM_b2_19, A2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_SSSSM_b2_19, A3_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_SSSSM_b2_19, B1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_SSSSM_b2_19, B2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_SSSSM_b2_19, C1_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_SSSSM_b2_19, C2_SSSSM_b2, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+  END IF ! firstcall
+
+
+  DO k=1, klev
+    DO i=1, klon
+      zrho=pplay(i,k)/t_seri(i,k)/RD                  ! kg/m3
+!CDIR UNROLL=naero_spc
+      mass_temp(i,k,:) = m_allaer(i,k,:) / zrho / 1.e+9
+!RAF zrho
+!CDIR UNROLL=naero_spc
+      mass_temp_pi(i,k,:) = m_allaer_pi(i,k,:) / zrho / 1.e+9
+      zdp1(i,k)=pdel(i,k)/(gravit*delt)      ! air mass auxiliary  variable --> zdp1 [kg/(m^2 *s)]
+    ENDDO
+  ENDDO
+
+  IF (flag_aerosol .EQ. 1) THEN 
+     nb_aer = 2
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASSO4M
+     aerosol_name(2) = id_CSSO4M
+  ELSEIF (flag_aerosol .EQ. 2) THEN
+     nb_aer = 2
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASBCM
+     aerosol_name(2) = id_AIBCM
+  ELSEIF (flag_aerosol .EQ. 3) THEN 
+     nb_aer = 2
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASPOMM
+     aerosol_name(2) = id_AIPOMM
+  ELSEIF (flag_aerosol .EQ. 4) THEN 
+     nb_aer = 3
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_CSSSM
+     aerosol_name(2) = id_SSSSM
+     aerosol_name(3) = id_ASSSM
+  ELSEIF (flag_aerosol .EQ. 5) THEN 
+     nb_aer = 1
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_CIDUSTM
+  ELSEIF (flag_aerosol .EQ. 6) THEN 
+     nb_aer = 10
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASSO4M      
+     aerosol_name(2) = id_ASBCM
+     aerosol_name(3) = id_AIBCM
+     aerosol_name(4) = id_ASPOMM
+     aerosol_name(5) = id_AIPOMM
+     aerosol_name(6) = id_CSSSM
+     aerosol_name(7) = id_SSSSM
+     aerosol_name(8) = id_ASSSM
+     aerosol_name(9) = id_CIDUSTM
+     aerosol_name(10)= id_CSSO4M
+  ENDIF
+
+
+  !
+  ! loop over modes, use of precalculated nmd and corresponding sigma
+  !    loop over wavelengths
+  !    for each mass species in mode
+  !      interpolate from Sext to retrieve Sext_at_gridpoint_per_species
+  !      compute optical_thickness_at_gridpoint_per_species
+
+
+
+!!CDIR ON_ADB(RH_tab)
+!CDIR ON_ADB(fact_RH)
+!CDIR SHORTLOOP
+  DO n=1,nbre_RH-1
+    fact_RH(n)=1./(RH_tab(n+1)-RH_tab(n))
+  ENDDO
+   
+  DO k=1, KLEV
+!!CDIR ON_ADB(RH_tab)
+!CDIR ON_ADB(fact_RH)
+    DO i=1, KLON
+      rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX)
+      RH_num(i,k) = INT( rh(i,k)/10. + 1.)
+      IF (rh(i,k).GT.85.) RH_num(i,k)=10
+      IF (rh(i,k).GT.90.) RH_num(i,k)=11
+      
+      DELTA(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k))
+    ENDDO
+  ENDDO
+
+  used_aer(:)=.FALSE.
+    
+  DO m=1,nb_aer   ! tau is only computed for each mass
+    fac=1.0
+     IF (aerosol_name(m).EQ.id_ASBCM) THEN
+         soluble=.TRUE.
+         spsol=1
+         spss=0
+     ELSEIF (aerosol_name(m).EQ.id_ASPOMM) THEN 
+        soluble=.TRUE.
+        spsol=2 
+        spss=0
+     ELSEIF (aerosol_name(m).EQ.id_ASSO4M) THEN 
+        soluble=.TRUE.
+        spsol=3
+        spss=0
+        fac=1.375    ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD
+     ELSEIF  (aerosol_name(m).EQ.id_CSSO4M) THEN
+        soluble=.TRUE.
+        spsol=4
+        spss=0
+        fac=1.375    ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD
+     ELSEIF (aerosol_name(m).EQ.id_SSSSM) THEN 
+         soluble=.TRUE.
+         spsol=5
+         spss=3
+     ELSEIF (aerosol_name(m).EQ.id_CSSSM) THEN 
+         soluble=.TRUE.
+         spsol=6
+         spss=2
+     ELSEIF (aerosol_name(m).EQ.id_ASSSM) THEN
+         soluble=.TRUE.
+         spsol=7
+         spss=1
+     ELSEIF (aerosol_name(m).EQ.id_CIDUSTM) THEN 
+         soluble=.FALSE.
+         spinsol=1
+         spss=0
+     ELSEIF  (aerosol_name(m).EQ.id_AIBCM) THEN 
+         soluble=.FALSE.
+         spinsol=2
+         spss=0
+     ELSEIF (aerosol_name(m).EQ.id_AIPOMM) THEN 
+         soluble=.FALSE.
+         spinsol=3
+         spss=0
+     ELSE 
+         CYCLE
+     ENDIF
+
+    id=aerosol_name(m)
+    used_aer(id)=.TRUE.
+
+     
+    IF (soluble) THEN
+
+      IF (spss.NE.0) THEN
+
+         IF (spss.EQ.1) THEN !accumulation mode
+            DO k=1, KLEV
+!CDIR ON_ADB(A1_ASSSM_b1)
+!CDIR ON_ADB(A2_ASSSM_b1)
+!CDIR ON_ADB(A3_ASSSM_b1)
+!CDIR ON_ADB(B1_ASSSM_b1)
+!CDIR ON_ADB(B2_ASSSM_b1)
+!CDIR ON_ADB(C1_ASSSM_b1)
+!CDIR ON_ADB(C2_ASSSM_b2)
+!CDIR ON_ADB(A1_ASSSM_b2)
+!CDIR ON_ADB(A2_ASSSM_b2)
+!CDIR ON_ADB(A3_ASSSM_b2)
+!CDIR ON_ADB(B1_ASSSM_b2)
+!CDIR ON_ADB(B2_ASSSM_b2)
+!CDIR ON_ADB(C1_ASSSM_b2)
+!CDIR ON_ADB(C2_ASSSM_b2)
+              DO i=1, KLON
+                H=rh(i,k)/100
+                tmp_var=mass_temp(i,k,spsol)*1000.*zdp1(i,k)*delt*fac
+                tmp_var_pi=mass_temp_pi(i,k,spsol)*1000.*zdp1(i,k)*delt*fac
+
+                ! band 1
+                tau_ae2b_int=A1_ASSSM_b1(k)+A2_ASSSM_b1(k)*H+A3_ASSSM_b1(k)/(H-1.05)
+                piz_ae2b_int=1-B1_ASSSM_b1(k)-B2_ASSSM_b1(k)*H
+                cg_ae2b_int=C1_ASSSM_b1(k)+C2_ASSSM_b1(k)*H
+
+                tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,1) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,1) = piz_ae2b_int
+                cg_ae(i,k,id,1)= cg_ae2b_int
+                
+                !band 2
+                tau_ae2b_int=A1_ASSSM_b2(k)+A2_ASSSM_b2(k)*H+A3_ASSSM_b2(k)/(H-1.05)
+                piz_ae2b_int=1-B1_ASSSM_b2(k)-B2_ASSSM_b2(k)*H
+                cg_ae2b_int=C1_ASSSM_b2(k)+C2_ASSSM_b2(k)*H
+
+                tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,2) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,2) = piz_ae2b_int
+                cg_ae(i,k,id,2)= cg_ae2b_int
+
+              ENDDO
+            ENDDO
+          ENDIF
+
+          IF (spss.EQ.2) THEN !coarse mode
+            DO k=1, KLEV
+!CDIR ON_ADB(A1_CSSSM_b1)
+!CDIR ON_ADB(A2_CSSSM_b1)
+!CDIR ON_ADB(A3_CSSSM_b1)
+!CDIR ON_ADB(B1_CSSSM_b1)
+!CDIR ON_ADB(B2_CSSSM_b1)
+!CDIR ON_ADB(C1_CSSSM_b1)
+!CDIR ON_ADB(C2_CSSSM_b2)
+!CDIR ON_ADB(A1_CSSSM_b2)
+!CDIR ON_ADB(A2_CSSSM_b2)
+!CDIR ON_ADB(A3_CSSSM_b2)
+!CDIR ON_ADB(B1_CSSSM_b2)
+!CDIR ON_ADB(B2_CSSSM_b2)
+!CDIR ON_ADB(C1_CSSSM_b2)
+!CDIR ON_ADB(C2_CSSSM_b2)
+              DO i=1, KLON
+                H=rh(i,k)/100
+                tmp_var=mass_temp(i,k,spsol)*1000.*zdp1(i,k)*delt*fac
+                tmp_var_pi=mass_temp_pi(i,k,spsol)*1000.*zdp1(i,k)*delt*fac
+                ! band 1
+                tau_ae2b_int=A1_CSSSM_b1(k)+A2_CSSSM_b1(k)*H+A3_CSSSM_b1(k)/(H-1.05)
+                piz_ae2b_int=1-B1_CSSSM_b1(k)-B2_CSSSM_b1(k)*H
+                cg_ae2b_int=C1_CSSSM_b1(k)+C2_CSSSM_b1(k)*H
+
+                tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,1) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,1) = piz_ae2b_int
+                cg_ae(i,k,id,1)= cg_ae2b_int
+
+                ! band 2
+                tau_ae2b_int=A1_CSSSM_b2(k)+A2_CSSSM_b2(k)*H+A3_CSSSM_b2(k)/(H-1.05)
+                piz_ae2b_int=1-B1_CSSSM_b2(k)-B2_CSSSM_b2(k)*H
+                cg_ae2b_int=C1_CSSSM_b2(k)+C2_CSSSM_b2(k)*H
+
+                tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,2) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,2) = piz_ae2b_int
+                cg_ae(i,k,id,2)= cg_ae2b_int
+
+             ENDDO
+           ENDDO
+         ENDIF
+
+         IF (spss.EQ.3) THEN !super coarse mode
+            DO k=1, KLEV
+!CDIR ON_ADB(A1_SSSSM_b1)
+!CDIR ON_ADB(A2_SSSSM_b1)
+!CDIR ON_ADB(A3_SSSSM_b1)
+!CDIR ON_ADB(B1_SSSSM_b1)
+!CDIR ON_ADB(B2_SSSSM_b1)
+!CDIR ON_ADB(C1_SSSSM_b1)
+!CDIR ON_ADB(C2_SSSSM_b2)
+!CDIR ON_ADB(A1_SSSSM_b2)
+!CDIR ON_ADB(A2_SSSSM_b2)
+!CDIR ON_ADB(A3_SSSSM_b2)
+!CDIR ON_ADB(B1_SSSSM_b2)
+!CDIR ON_ADB(B2_SSSSM_b2)
+!CDIR ON_ADB(C1_SSSSM_b2)
+!CDIR ON_ADB(C2_SSSSM_b2)
+              DO i=1, KLON
+                H=rh(i,k)/100
+                tmp_var=mass_temp(i,k,spsol)*1000.*zdp1(i,k)*delt*fac
+                tmp_var_pi=mass_temp_pi(i,k,spsol)*1000.*zdp1(i,k)*delt*fac
+
+                ! band 1 
+                tau_ae2b_int=A1_SSSSM_b1(k)+A2_SSSSM_b1(k)*H+A3_SSSSM_b1(k)/(H-1.05)
+                piz_ae2b_int=1-B1_SSSSM_b1(k)-B2_SSSSM_b1(k)*H
+                cg_ae2b_int=C1_SSSSM_b1(k)+C2_SSSSM_b1(k)*H
+
+                tau_ae(i,k,id,1) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,1) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,1) = piz_ae2b_int
+                cg_ae(i,k,id,1)= cg_ae2b_int
+
+                ! band 2
+                tau_ae2b_int=A1_SSSSM_b2(k)+A2_SSSSM_b2(k)*H+A3_SSSSM_b2(k)/(H-1.05)
+                piz_ae2b_int=1-B1_SSSSM_b2(k)-B2_SSSSM_b2(k)*H
+                cg_ae2b_int=C1_SSSSM_b2(k)+C2_SSSSM_b2(k)*H
+
+                tau_ae(i,k,id,2) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,2) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,2) = piz_ae2b_int
+                cg_ae(i,k,id,2)= cg_ae2b_int
+
+              ENDDO
+            ENDDO
+          ENDIF
+
+        ELSE
+                        
+!CDIR ON_ADB(alpha_aers_2bands)
+!CDIR ON_ADB(piz_aers_2bands)
+!CDIR ON_ADB(cg_aers_2bands)
+          DO k=1, KLEV
+            DO i=1, KLON
+              tmp_var=mass_temp(i,k,spsol)*1000.*zdp1(i,k)*delt*fac
+              tmp_var_pi=mass_temp_pi(i,k,spsol)*1000.*zdp1(i,k)*delt*fac
+!CDIR UNROLL=nbands
+              DO inu=1,nbands
+
+                tau_ae2b_int= alpha_aers_2bands(RH_num(i,k),inu,spsol)+ & 
+                              DELTA(i,k)* (alpha_aers_2bands(RH_num(i,k)+1,inu,spsol) - & 
+                              alpha_aers_2bands(RH_num(i,k),inu,spsol))
+                      
+                piz_ae2b_int = piz_aers_2bands(RH_num(i,k),inu,spsol) + & 
+                               DELTA(i,k)* (piz_aers_2bands(RH_num(i,k)+1,inu,spsol) - & 
+                               piz_aers_2bands(RH_num(i,k),inu,spsol))
+                      
+                cg_ae2b_int = cg_aers_2bands(RH_num(i,k),inu,spsol) + & 
+                              DELTA(i,k)* (cg_aers_2bands(RH_num(i,k)+1,inu,spsol) - & 
+                              cg_aers_2bands(RH_num(i,k),inu,spsol))
+
+                tau_ae(i,k,id,inu) = tmp_var*tau_ae2b_int
+                tau_ae_pi(i,k,id,inu) =  tmp_var_pi* tau_ae2b_int
+                piz_ae(i,k,id,inu) = piz_ae2b_int
+                cg_ae(i,k,id,inu)= cg_ae2b_int
+                         
+              ENDDO
+            ENDDO
+          ENDDO
+        
+        ENDIF                     
+
+      ELSE                                                    ! For all aerosol insoluble components
+
+!CDIR ON_ADB(alpha_aers_2bands)
+!CDIR ON_ADB(piz_aers_2bands)
+!CDIR ON_ADB(cg_aers_2bands)
+        DO k=1, KLEV
+          DO i=1, KLON
+            tmp_var=mass_temp(i,k,naero_soluble+ spinsol)*1000.*zdp1(i,k)*delt*fac
+            tmp_var_pi=mass_temp_pi(i,k,naero_soluble+spinsol)*1000.*zdp1(i,k)*delt*fac
+!CDIR UNROLL=nbands
+            DO inu=1,nbands
+              tau_ae2b_int = alpha_aeri_2bands(inu,spinsol)
+              piz_ae2b_int = piz_aeri_2bands(inu,spinsol)
+              cg_ae2b_int = cg_aeri_2bands(inu,spinsol) 
+
+              tau_ae(i,k,id,inu) = tmp_var*tau_ae2b_int
+              tau_ae_pi(i,k,id,inu) = tmp_var_pi*tau_ae2b_int
+              piz_ae(i,k,id,inu) = piz_ae2b_int
+              cg_ae(i,k,id,inu)= cg_ae2b_int
+            ENDDO
+          ENDDO
+        ENDDO
+
+      ENDIF ! soluble
+
+    ENDDO  ! nb_aer  
+
+  DO m=1,nb_aer   
+    IF (.NOT. used_aer(m)) THEN
+      tau_ae(:,:,m,:)=0.
+      tau_ae_pi(:,:,m,:)=0.
+      piz_ae(:,:,m,:)=0.
+      cg_ae(:,:,m,:)=0.
+    ENDIF
+  ENDDO
+
+  DO inu=1, nbands
+    DO mrfspecies=1,naero_grp
+      IF (mrfspecies .EQ. 2) THEN             ! = total aerosol AER	 
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSO4M,inu)+tau_ae(i,k,id_CSSO4M,inu)+ &
+                                           tau_ae(i,k,id_ASBCM,inu)+tau_ae(i,k,id_AIBCM,inu)+   &						     
+                                           tau_ae(i,k,id_ASPOMM,inu)+tau_ae(i,k,id_AIPOMM,inu)+ &	
+                                           tau_ae(i,k,id_ASSSM,inu)+tau_ae(i,k,id_CSSSM,inu)+   &
+                                           tau_ae(i,k,id_SSSSM,inu)+ tau_ae(i,k,id_CIDUSTM,inu)
+	     tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+                 
+             piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)+ &
+                                             tau_ae(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu)+ &
+                                             tau_ae(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu)+ &
+                                             tau_ae(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)+ &
+                                             tau_ae(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu)+ &
+                                             tau_ae(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)+ &	
+                                             tau_ae(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu)+ &
+                                             tau_ae(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)+ &
+                                             tau_ae(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)+ &
+                                             tau_ae(i,k,id_CIDUSTM,inu)*piz_ae(i,k,id_CIDUSTM,inu)) &
+                                            /tau_allaer(i,k,mrfspecies,inu)
+	     piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
+
+             cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)*cg_ae(i,k,id_ASSO4M,inu)+ &
+                      tau_ae(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu)*cg_ae(i,k,id_CSSO4M,inu)+ &
+                      tau_ae(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu)*cg_ae(i,k,id_ASBCM,inu)+ &
+                      tau_ae(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)*cg_ae(i,k,id_AIBCM,inu)+ &
+                      tau_ae(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu)*cg_ae(i,k,id_ASPOMM,inu)+ &
+                      tau_ae(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)*cg_ae(i,k,id_AIPOMM,inu)+ &	
+                      tau_ae(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu)*cg_ae(i,k,id_ASSSM,inu)+ &
+                      tau_ae(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)*cg_ae(i,k,id_CSSSM,inu)+ &
+                      tau_ae(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)*cg_ae(i,k,id_SSSSM,inu)+ &
+                      tau_ae(i,k,id_CIDUSTM,inu)*piz_ae(i,k,id_CIDUSTM,inu)*cg_ae(i,k,id_CIDUSTM,inu))/ &
+                      (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
+          ENDDO    
+        ENDDO 
+
+      ELSEIF (mrfspecies .EQ. 3) THEN             ! = natural aerosol NAT
+
+        DO k=1, KLEV
+          DO i=1, KLON
+!RAF
+	 	 tau_allaer(i,k,mrfspecies,inu)=tau_ae_pi(i,k,id_ASSO4M,inu)+ &
+                      tau_ae_pi(i,k,id_CSSO4M,inu)+ &
+                      tau_ae_pi(i,k,id_ASBCM,inu)+ &
+                      tau_ae_pi(i,k,id_AIBCM,inu)+ &
+                      tau_ae_pi(i,k,id_ASPOMM,inu)+ &
+                      tau_ae_pi(i,k,id_AIPOMM,inu)+ &	
+                      tau_ae_pi(i,k,id_ASSSM,inu)+ &
+                      tau_ae_pi(i,k,id_CSSSM,inu)+ &
+                      tau_ae_pi(i,k,id_SSSSM,inu)+ &
+                      tau_ae_pi(i,k,id_CIDUSTM,inu)
+	         tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+
+	 	 piz_allaer(i,k,mrfspecies,inu)=(tau_ae_pi(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)+ &
+                      tau_ae_pi(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu)+ &
+                      tau_ae_pi(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu)+ &
+                      tau_ae_pi(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)+ &
+                      tau_ae_pi(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu)+ &
+                      tau_ae_pi(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)+ &	
+                      tau_ae_pi(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu)+ &
+                      tau_ae_pi(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)+ &
+                      tau_ae_pi(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)+ &
+                      tau_ae_pi(i,k,id_CIDUSTM,inu)*piz_ae(i,k,id_CIDUSTM,inu)) &
+                      /tau_allaer(i,k,mrfspecies,inu)
+	         piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
+
+	 	 cg_allaer(i,k,mrfspecies,inu)=(&
+                      tau_ae_pi(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)*cg_ae(i,k,id_ASSO4M,inu)+ &
+                      tau_ae_pi(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu)*cg_ae(i,k,id_CSSO4M,inu)+ &
+                      tau_ae_pi(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu)*cg_ae(i,k,id_ASBCM,inu)+ &
+                      tau_ae_pi(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)*cg_ae(i,k,id_AIBCM,inu)+ &
+                      tau_ae_pi(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu)*cg_ae(i,k,id_ASPOMM,inu)+ &
+                      tau_ae_pi(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)*cg_ae(i,k,id_AIPOMM,inu)+ &
+                      tau_ae_pi(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu)*cg_ae(i,k,id_ASSSM,inu)+ &
+                      tau_ae_pi(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)*cg_ae(i,k,id_CSSSM,inu)+ &
+                      tau_ae_pi(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)*cg_ae(i,k,id_SSSSM,inu)+ &
+                      tau_ae_pi(i,k,id_CIDUSTM,inu)*piz_ae(i,k,id_CIDUSTM,inu)*&
+                      cg_ae(i,k,id_CIDUSTM,inu))/ &
+                      (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
+          ENDDO
+        ENDDO
+                   
+      ELSEIF (mrfspecies .EQ. 4) THEN             ! = BC
+        DO k=1, KLEV
+          DO i=1, KLON
+	    tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASBCM,inu)+tau_ae(i,k,id_AIBCM,inu)
+	    tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+	    piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu) &
+                      +tau_ae(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu))/ &
+                      tau_allaer(i,k,mrfspecies,inu)
+	    piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
+            cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASBCM,inu)*piz_ae(i,k,id_ASBCM,inu) *cg_ae(i,k,id_ASBCM,inu)&
+                      +tau_ae(i,k,id_AIBCM,inu)*piz_ae(i,k,id_AIBCM,inu)*cg_ae(i,k,id_AIBCM,inu))/ &
+                      (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
+          ENDDO
+        ENDDO
+              
+      ELSEIF (mrfspecies .EQ. 5) THEN             ! = SO4
+
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSO4M,inu)+tau_ae(i,k,id_CSSO4M,inu)
+	    tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+            piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu) &
+                      +tau_ae(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu))/ &
+                      tau_allaer(i,k,mrfspecies,inu)
+	    piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
+            cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_CSSO4M,inu)*piz_ae(i,k,id_CSSO4M,inu) *cg_ae(i,k,id_CSSO4M,inu)&
+                      +tau_ae(i,k,id_ASSO4M,inu)*piz_ae(i,k,id_ASSO4M,inu)*cg_ae(i,k,id_ASSO4M,inu))/ &
+                      (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
+          ENDDO
+        ENDDO
+
+      ELSEIF (mrfspecies .EQ. 6) THEN             ! = POM
+
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASPOMM,inu)+tau_ae(i,k,id_AIPOMM,inu)
+            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+	    piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu) &
+                      +tau_ae(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu))/ &
+                      tau_allaer(i,k,mrfspecies,inu)
+	    piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
+	    cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASPOMM,inu)*piz_ae(i,k,id_ASPOMM,inu) *cg_ae(i,k,id_ASPOMM,inu)&
+                      +tau_ae(i,k,id_AIPOMM,inu)*piz_ae(i,k,id_AIPOMM,inu)*cg_ae(i,k,id_AIPOMM,inu))/ &
+                      (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
+          ENDDO
+        ENDDO
+              
+      ELSEIF (mrfspecies .EQ. 7) THEN             ! = DUST
+
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_CIDUSTM,inu)
+	    tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+            piz_allaer(i,k,mrfspecies,inu)=piz_ae(i,k,id_CIDUSTM,inu)
+	    cg_allaer(i,k,mrfspecies,inu)=cg_ae(i,k,id_CIDUSTM,inu)
+          ENDDO
+        ENDDO
+
+      ELSEIF (mrfspecies .EQ. 8) THEN             ! = SS
+
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=tau_ae(i,k,id_ASSSM,inu)+tau_ae(i,k,id_CSSSM,inu)+tau_ae(i,k,id_SSSSM,inu)
+            tau_allaer(i,k,mrfspecies,inu)=MAX(tau_allaer(i,k,mrfspecies,inu),1e-5)
+            piz_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu) &
+                    +tau_ae(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu) &
+                    +tau_ae(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu))/ &
+                    tau_allaer(i,k,mrfspecies,inu)
+            piz_allaer(i,k,mrfspecies,inu)=MAX(piz_allaer(i,k,mrfspecies,inu),0.1)
+            cg_allaer(i,k,mrfspecies,inu)=(tau_ae(i,k,id_ASSSM,inu)*piz_ae(i,k,id_ASSSM,inu) *cg_ae(i,k,id_ASSSM,inu)&
+                    +tau_ae(i,k,id_CSSSM,inu)*piz_ae(i,k,id_CSSSM,inu)*cg_ae(i,k,id_CSSSM,inu) &
+                    +tau_ae(i,k,id_SSSSM,inu)*piz_ae(i,k,id_SSSSM,inu)*cg_ae(i,k,id_SSSSM,inu))/ &
+                    (tau_allaer(i,k,mrfspecies,inu)*piz_allaer(i,k,mrfspecies,inu))
+          ENDDO
+        ENDDO
+      
+      ELSEIF (mrfspecies .EQ. 9) THEN             ! = NO3
+      
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=0.   ! preliminary
+            piz_allaer(i,k,mrfspecies,inu)=0.
+            cg_allaer(i,k,mrfspecies,inu)=0.
+          ENDDO
+        ENDDO
+      
+      ELSE
+
+        DO k=1, KLEV
+          DO i=1, KLON
+            tau_allaer(i,k,mrfspecies,inu)=0.  
+            piz_allaer(i,k,mrfspecies,inu)=0.
+            cg_allaer(i,k,mrfspecies,inu)=0.
+          ENDDO
+        ENDDO
+           
+      ENDIF
+
+    ENDDO
+  ENDDO
+   
+
+  inu=1
+  DO i=1, KLON
+     absvisaer(i)=SUM((1-piz_allaer(i,:,:,inu))*tau_allaer(i,:,:,inu))
+  END DO	
+
+  DEALLOCATE(aerosol_name) 
+
+END SUBROUTINE AEROPT_2BANDS
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/aeropt_5wv.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/aeropt_5wv.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/aeropt_5wv.F90	(revision 17)
@@ -0,0 +1,890 @@
+!
+! $Id: aeropt_5wv.F90 1750 2013-04-25 15:27:27Z fairhead $
+!
+
+SUBROUTINE AEROPT_5WV(&
+   pdel, m_allaer, delt, &
+   RHcl, ai, flag_aerosol, &
+   pplay, t_seri, &
+   tausum, tau, presnivs)
+
+  USE DIMPHY
+  USE aero_mod
+  USE phys_local_var_mod, only: od550aer,od865aer,ec550aer,od550lt1aer
+  USE pres2lev_mod
+
+
+  !
+  !    Yves Balkanski le 12 avril 2006
+  !    Celine Deandreis
+  !    Anne Cozic  Avril 2009
+  !    a partir d'une sous-routine de Johannes Quaas pour les sulfates
+  !
+  !
+  ! Refractive indices for seasalt come from Shettle and Fenn (1979)
+  !
+  ! Refractive indices from water come from Hale and Querry (1973)
+  !
+  ! Refractive indices from Ammonium Sulfate Toon and Pollack (1976)
+  !
+  ! Refractive indices for Dust, internal mixture of minerals coated with 1.5% hematite 
+  ! by Volume (Balkanski et al., 2006)
+  !
+  ! Refractive indices for POM: Kinne (pers. Communication 
+  !
+  ! Refractive index for BC from Shettle and Fenn (1979)
+  !
+  ! Shettle, E. P., & Fenn, R. W. (1979), Models for the aerosols of the lower atmosphere and 
+  ! the effects of humidity variations on their optical properties, U.S. Air Force Geophysics 
+  ! Laboratory Rept. AFGL-TR-79-0214, Hanscomb Air Force Base, MA.
+  !
+  ! Hale, G. M. and M. R. Querry, Optical constants of water in the 200-nm to 200-m 
+  ! wavelength region, Appl. Opt., 12, 555-563, 1973.
+  !
+  ! Toon, O. B. and J. B. Pollack, The optical constants of several atmospheric aerosol species:
+  ! Ammonium sulfate, aluminum oxide, and sodium chloride, J. Geohys. Res., 81, 5733-5748,
+  ! 1976.
+  !
+  ! Balkanski, Y., M. Schulz, T. Claquin And O. Boucher, Reevaluation of mineral aerosol 
+  ! radiative forcings suggests a better agreement with satellite and AERONET data, Atmospheric 
+  ! Chemistry and Physics Discussions., 6, pp 8383-8419, 2006.
+  !
+  IMPLICIT NONE
+  INCLUDE "YOMCST.h"
+  !
+  ! Input arguments:
+  !
+  REAL, DIMENSION(klon,klev), INTENT(in)   :: pdel
+  REAL, INTENT(in)                         :: delt
+  REAL, DIMENSION(klon,klev,naero_spc), INTENT(in) :: m_allaer
+  REAL, DIMENSION(klon,klev), INTENT(in)   :: RHcl     ! humidite relative ciel clair
+  INTEGER,INTENT(in)                       :: flag_aerosol
+  REAL, DIMENSION(klon,klev), INTENT(in)   :: pplay
+  REAL, DIMENSION(klon,klev), INTENT(in)   :: t_seri
+  REAL, DIMENSION(klev),      INTENT(in)   :: presnivs
+  !
+  ! Output arguments:
+  !
+  REAL, DIMENSION(klon), INTENT(out)          :: ai      ! POLDER aerosol index 
+  REAL, DIMENSION(klon,nwave,naero_spc), INTENT(out)      :: tausum
+  REAL, DIMENSION(klon,klev,nwave,naero_spc), INTENT(out) :: tau
+
+
+  !
+  ! Local
+  !
+  INTEGER, PARAMETER :: las = nwave
+  LOGICAL :: soluble
+  
+  INTEGER :: i, k, ierr, m
+  INTEGER :: spsol, spinsol, spss, la
+  INTEGER :: RH_num(klon,klev)
+  INTEGER, PARAMETER :: la443 = 1
+  INTEGER, PARAMETER :: la550 = 2
+  INTEGER, PARAMETER :: la670 = 3
+  INTEGER, PARAMETER :: la765 = 4
+  INTEGER, PARAMETER :: la865 = 5
+  INTEGER, PARAMETER :: nbre_RH=12
+  INTEGER, PARAMETER :: naero_soluble=7   !  1- BC soluble; 2- POM soluble; 3- SO4 acc.
+                                          !  4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc.
+  INTEGER, PARAMETER :: naero_insoluble=3 !  1- Dust; 2- BC insoluble; 3- POM insoluble
+  INTEGER, PARAMETER :: nb_level = 19     ! number of vertical levels
+  LOGICAL, SAVE :: firstcall=.TRUE.
+!$OMP THREADPRIVATE(firstcall)
+
+  REAL :: zrho
+
+  ! Coefficient optiques sur 19 niveaux
+  REAL, SAVE, DIMENSION(nb_level) :: presnivs_19  ! Pression milieux couche pour 19 niveaux (nb_level)
+!$OMP THREADPRIVATE(presnivs_19)
+
+  REAL, SAVE, DIMENSION(nb_level) :: A1_ASSSM_19, A2_ASSSM_19, A3_ASSSM_19,&
+          B1_ASSSM_19, B2_ASSSM_19, C1_ASSSM_19, C2_ASSSM_19,&
+          A1_CSSSM_19, A2_CSSSM_19, A3_CSSSM_19,&
+          B1_CSSSM_19, B2_CSSSM_19, C1_CSSSM_19, C2_CSSSM_19, &
+          A1_SSSSM_19, A2_SSSSM_19, A3_SSSSM_19,&
+          B1_SSSSM_19, B2_SSSSM_19, C1_SSSSM_19, C2_SSSSM_19
+!$OMP THREADPRIVATE(A1_ASSSM_19, A2_ASSSM_19, A3_ASSSM_19)
+!$OMP THREADPRIVATE(B1_ASSSM_19, B2_ASSSM_19, C1_ASSSM_19, C2_ASSSM_19)
+!$OMP THREADPRIVATE(A1_CSSSM_19, A2_CSSSM_19, A3_CSSSM_19)
+!$OMP THREADPRIVATE(B1_CSSSM_19, B2_CSSSM_19, C1_CSSSM_19, C2_CSSSM_19)
+!$OMP THREADPRIVATE(A1_SSSSM_19, A2_SSSSM_19, A3_SSSSM_19)
+!$OMP THREADPRIVATE(B1_SSSSM_19, B2_SSSSM_19, C1_SSSSM_19, C2_SSSSM_19)
+
+  ! Coefficient optiques interpole sur le nombre de niveau du modele
+  REAL, ALLOCATABLE,  DIMENSION(:), SAVE :: &
+          A1_ASSSM, A2_ASSSM, A3_ASSSM,&
+          B1_ASSSM, B2_ASSSM, C1_ASSSM, C2_ASSSM,&
+          A1_CSSSM, A2_CSSSM, A3_CSSSM,&
+          B1_CSSSM, B2_CSSSM, C1_CSSSM, C2_CSSSM, &
+          A1_SSSSM, A2_SSSSM, A3_SSSSM,&
+          B1_SSSSM, B2_SSSSM, C1_SSSSM, C2_SSSSM
+!$OMP THREADPRIVATE(A1_ASSSM, A2_ASSSM, A3_ASSSM)
+!$OMP THREADPRIVATE(B1_ASSSM, B2_ASSSM, C1_ASSSM, C2_ASSSM)
+!$OMP THREADPRIVATE(A1_CSSSM, A2_CSSSM, A3_CSSSM)
+!$OMP THREADPRIVATE(B1_CSSSM, B2_CSSSM, C1_CSSSM, C2_CSSSM)
+!$OMP THREADPRIVATE(A1_SSSSM, A2_SSSSM, A3_SSSSM)
+!$OMP THREADPRIVATE(B1_SSSSM, B2_SSSSM, C1_SSSSM, C2_SSSSM)
+
+
+  REAL,PARAMETER :: RH_tab(nbre_RH)=(/0.,10.,20.,30.,40.,50.,60.,70.,80.,85.,90.,95./)
+  REAL :: DELTA(klon,klev), rh(klon,klev), H
+  REAL :: tau_ae5wv_int ! Intermediate computation of epaisseur optique aerosol
+  REAL :: piz_ae5wv_int ! Intermediate single scattering albedo aerosol
+  REAL :: cg_ae5wv_int  ! Intermediate asymmetry parameter aerosol
+  REAL, PARAMETER :: RH_MAX=95.
+  REAL :: taue670(KLON)       ! epaisseur optique aerosol absorption 550 nm
+  REAL :: taue865(KLON)       ! epaisseur optique aerosol extinction 865 nm
+  REAL :: fac
+  REAL :: zdp1(klon,klev) 
+  REAL, PARAMETER ::  gravit = 9.80616    ! m2/s
+  INTEGER, ALLOCATABLE, DIMENSION(:)  :: aerosol_name
+  INTEGER :: nb_aer
+  
+  REAL :: tau3d(KLON,KLEV), piz3d(KLON,KLEV), cg3d(KLON,KLEV)
+  REAL :: abs3d(KLON,KLEV)     ! epaisseur optique d'absorption
+  REAL :: dh(KLON,KLEV)
+  
+  REAL :: alpha_aers_5wv(nbre_RH,las,naero_soluble)   ! ext. coeff. Soluble comp. units *** m2/g 
+   !  1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc.
+  REAL :: alpha_aeri_5wv(las,naero_insoluble)         ! ext. coeff. Insoluble comp. 1- Dust: 2- BC; 3- POM
+  REAL :: cg_aers_5wv(nbre_RH,las,naero_soluble)      ! Asym. param. soluble comp. 
+   !  1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc.
+  REAL :: cg_aeri_5wv(las,naero_insoluble)            ! Asym. param. insoluble comp. 1- Dust: 2- BC; 3- POM
+  REAL :: piz_aers_5wv(nbre_RH,las,naero_soluble)   
+   !  1- BC soluble; 2- POM soluble; 3- SO4 acc.; 4- SO4 coarse; 5 seasalt super-C; 6 seasalt coarse; 7 seasalt acc.
+  REAL :: piz_aeri_5wv(las,naero_insoluble)           ! Insoluble comp. 1- Dust: 2- BC; 3- POM
+
+  REAL, DIMENSION(klon,klev,naero_spc) :: mass_temp
+  
+  !
+  ! Proprietes optiques
+  !
+  REAL :: radry = 287.054
+  REAL :: tau_tmp                     ! dry air mass constant
+  REAL :: fact_RH(nbre_RH)
+  LOGICAL :: used_tau(naero_spc)
+  INTEGER :: n
+  
+  DATA presnivs_19/&
+       100426.5,  98327.6, 95346.5, 90966.8, 84776.9, &
+       76536.5,   66292.2, 54559.3, 42501.8, 31806, &
+       23787.5,   18252.7, 13996,   10320.8, 7191.1, &
+       4661.7,    2732.9,  1345.6,  388.2/
+
+!!ACCUMULATION MODE
+  DATA A1_ASSSM_19/ 4.373E+00,  4.361E+00,  4.331E+00, &
+                 4.278E+00,  4.223E+00,  4.162E+00, &
+                 4.103E+00,  4.035E+00,  3.962E+00, &
+                 3.904E+00,  3.871E+00,  3.847E+00, &
+                 3.824E+00,  3.780E+00,  3.646E+00, &
+                 3.448E+00,  3.179E+00,  2.855E+00,  2.630E+00/
+  DATA A2_ASSSM_19/ 2.496E+00,  2.489E+00,  2.472E+00, &
+                 2.442E+00,  2.411E+00,  2.376E+00, &
+                 2.342E+00,  2.303E+00,  2.261E+00, &
+                 2.228E+00,  2.210E+00,  2.196E+00, &
+                 2.183E+00,  2.158E+00,  2.081E+00, &
+                 1.968E+00,  1.814E+00,  1.630E+00,  1.501E+00/
+  DATA A3_ASSSM_19/-4.688E-02, -4.676E-02, -4.644E-02, &
+                -4.587E-02, -4.528E-02, -4.463E-02, &
+                -4.399E-02, -4.326E-02, -4.248E-02, &
+                -4.186E-02, -4.151E-02, -4.125E-02, &
+                -4.100E-02, -4.053E-02, -3.910E-02, &
+                -3.697E-02, -3.408E-02, -3.061E-02, -2.819E-02/
+  DATA B1_ASSSM_19/ 1.165E-08,  1.145E-08,  1.097E-08, &
+                 1.012E-08,  9.233E-09,  8.261E-09, &
+                 7.297E-09,  6.201E-09,  5.026E-09, &
+                 4.098E-09,  3.567E-09,  3.187E-09, &
+                 2.807E-09,  2.291E-09,  2.075E-09, &
+                 1.756E-09,  1.322E-09,  8.011E-10, 4.379E-10/
+  DATA B2_ASSSM_19/ 2.193E-08,  2.192E-08,  2.187E-08, &
+                 2.179E-08,  2.171E-08,  2.162E-08, &
+                 2.153E-08,  2.143E-08,  2.132E-08, &
+                 2.124E-08,  2.119E-08,  2.115E-08, &
+                 2.112E-08,  2.106E-08,  2.100E-08, &
+                 2.090E-08,  2.077E-08,  2.061E-08,  2.049E-08/
+  DATA C1_ASSSM_19/ 7.365E-01,  7.365E-01,  7.365E-01, &
+                 7.364E-01,  7.363E-01,  7.362E-01, &
+                 7.361E-01,  7.359E-01,  7.358E-01, &
+                 7.357E-01,  7.356E-01,  7.356E-01, &
+                 7.356E-01,  7.355E-01,  7.354E-01, &
+                 7.352E-01,  7.350E-01,  7.347E-01,  7.345E-01/
+  DATA C2_ASSSM_19/ 5.833E-02,  5.835E-02,  5.841E-02, &
+                 5.850E-02,  5.859E-02,  5.870E-02, &
+                 5.880E-02,  5.891E-02,  5.904E-02, &
+                 5.914E-02,  5.920E-02,  5.924E-02, &
+                 5.928E-02,  5.934E-02,  5.944E-02, &
+                 5.959E-02,  5.979E-02,  6.003E-02,  6.020E-02/
+!COARSE MODE
+  DATA A1_CSSSM_19/ 7.403E-01,  7.422E-01,  7.626E-01, &
+                 8.019E-01,  8.270E-01,  8.527E-01, &
+                 8.702E-01,  8.806E-01,  8.937E-01, &
+                 9.489E-01,  1.030E+00,  1.105E+00, &
+                 1.199E+00,  1.357E+00,  1.660E+00, &
+                 2.540E+00,  4.421E+00,  2.151E+00,  9.518E-01/
+  DATA A2_CSSSM_19/ 4.522E-01,  4.532E-01,  4.644E-01, &
+                 4.859E-01,  4.996E-01,  5.137E-01, &
+                 5.233E-01,  5.290E-01,  5.361E-01, &
+                 5.655E-01,  6.085E-01,  6.483E-01, &
+                 6.979E-01,  7.819E-01,  9.488E-01, &
+                 1.450E+00,  2.523E+00,  1.228E+00,  5.433E-01/
+  DATA A3_CSSSM_19/-8.516E-03, -8.535E-03, -8.744E-03, &
+                -9.148E-03, -9.406E-03, -9.668E-03, &
+                -9.848E-03, -9.955E-03, -1.009E-02, &
+                -1.064E-02, -1.145E-02, -1.219E-02, &
+                -1.312E-02, -1.470E-02, -1.783E-02, &
+                -2.724E-02, -4.740E-02, -2.306E-02, -1.021E-02/
+  DATA B1_CSSSM_19/ 2.535E-07,  2.530E-07,  2.479E-07, &
+                 2.380E-07,  2.317E-07,  2.252E-07, &
+                 2.208E-07,  2.182E-07,  2.149E-07, &
+                 2.051E-07,  1.912E-07,  1.784E-07, &
+                 1.624E-07,  1.353E-07,  1.012E-07, &
+                 6.016E-08,  2.102E-08,  0.000E+00,  0.000E+00/
+  DATA B2_CSSSM_19/ 1.221E-07,  1.217E-07,  1.179E-07, &
+                 1.104E-07,  1.056E-07,  1.008E-07, &
+                 9.744E-08,  9.546E-08,  9.299E-08, &
+                 8.807E-08,  8.150E-08,  7.544E-08, &
+                 6.786E-08,  5.504E-08,  4.080E-08, &
+                 2.960E-08,  2.300E-08,  2.030E-08,  1.997E-08/
+  DATA C1_CSSSM_19/ 7.659E-01,  7.658E-01,  7.652E-01, &
+                 7.639E-01,  7.631E-01,  7.623E-01, &
+                 7.618E-01,  7.614E-01,  7.610E-01, &
+                 7.598E-01,  7.581E-01,  7.566E-01, &
+                 7.546E-01,  7.513E-01,  7.472E-01, &
+                 7.423E-01,  7.376E-01,  7.342E-01,  7.334E-01/
+  DATA C2_CSSSM_19/ 3.691E-02,  3.694E-02,  3.729E-02, &
+                 3.796E-02,  3.839E-02,  3.883E-02, &
+                 3.913E-02,  3.931E-02,  3.953E-02, &
+                 4.035E-02,  4.153E-02,  4.263E-02, &
+                 4.400E-02,  4.631E-02,  4.933E-02, &
+                 5.331E-02,  5.734E-02,  6.053E-02,  6.128E-02/
+!SUPER COARSE MODE
+  DATA A1_SSSSM_19/ 2.836E-01,  2.876E-01,  2.563E-01, &
+                 2.414E-01,  2.541E-01,  2.546E-01, &
+                 2.572E-01,  2.638E-01,  2.781E-01, &
+                 3.167E-01,  4.209E-01,  5.286E-01, &
+                 6.959E-01,  9.233E-01,  1.282E+00, &
+                 1.836E+00,  2.981E+00,  4.355E+00,  4.059E+00/
+  DATA A2_SSSSM_19/ 1.608E-01,  1.651E-01,  1.577E-01, &
+                 1.587E-01,  1.686E-01,  1.690E-01, &
+                 1.711E-01,  1.762E-01,  1.874E-01, &
+                 2.138E-01,  2.751E-01,  3.363E-01, &
+                 4.279E-01,  5.519E-01,  7.421E-01, &
+                 1.048E+00,  1.702E+00,  2.485E+00,  2.317E+00/
+  DATA A3_SSSSM_19/-3.025E-03, -3.111E-03, -2.981E-03, &
+                -3.005E-03, -3.193E-03, -3.200E-03, &
+                -3.239E-03, -3.336E-03, -3.548E-03, &
+                -4.047E-03, -5.196E-03, -6.345E-03, &
+                -8.061E-03, -1.038E-02, -1.395E-02, &
+                -1.970E-02, -3.197E-02, -4.669E-02, -4.352E-02/
+  DATA B1_SSSSM_19/ 6.759E-07,  6.246E-07,  5.542E-07, &
+                 4.953E-07,  4.746E-07,  4.738E-07, &
+                 4.695E-07,  4.588E-07,  4.354E-07, &
+                 3.947E-07,  3.461E-07,  3.067E-07, &
+                 2.646E-07,  2.095E-07,  1.481E-07, &
+                 9.024E-08,  5.747E-08,  2.384E-08,  6.599E-09/
+  DATA B2_SSSSM_19/ 5.977E-07,  5.390E-07,  4.468E-07, &
+                 3.696E-07,  3.443E-07,  3.433E-07, &
+                 3.380E-07,  3.249E-07,  2.962E-07, &
+                 2.483E-07,  1.989E-07,  1.623E-07, &
+                 1.305E-07,  9.015E-08,  6.111E-08, &
+                 3.761E-08,  2.903E-08,  2.337E-08,  2.147E-08/
+  DATA C1_SSSSM_19/ 8.120E-01,  8.084E-01,  8.016E-01, &
+                 7.953E-01,  7.929E-01,  7.928E-01, &
+                 7.923E-01,  7.910E-01,  7.882E-01, &
+                 7.834E-01,  7.774E-01,  7.725E-01, &
+                 7.673E-01,  7.604E-01,  7.529E-01, &
+                 7.458E-01,  7.419E-01,  7.379E-01,  7.360E-01/
+  DATA C2_SSSSM_19/ 2.388E-02,  2.392E-02,  2.457E-02,  2.552E-02, &
+                 2.615E-02,  2.618E-02,  2.631E-02,  2.663E-02, &
+                 2.735E-02,  2.875E-02,  3.113E-02,  3.330E-02, &
+                 3.615E-02,  3.997E-02,  4.521E-02,  5.038E-02, &
+                 5.358E-02,  5.705E-02,  5.887E-02/
+!*********************************************************************
+!
+!
+! 
+! 
+!  
+! 
+! From here on we look at the optical parameters at 5 wavelengths:  
+! 443nm, 550, 670, 765 and 865 nm 
+!                                   le 12 AVRIL 2006 
+!  
+ DATA alpha_aers_5wv/ & 
+                                ! bc soluble 
+       7.930,7.930,7.930,7.930,7.930,7.930,     & 
+       7.930,7.930,10.893,12.618,14.550,16.613, & 
+       7.658,7.658,7.658,7.658,7.658,7.658,     & 
+       7.658,7.658,10.351,11.879,13.642,15.510, & 
+       7.195,7.195,7.195,7.195,7.195,7.195,     & 
+       7.195,7.195,9.551,10.847,12.381,13.994,  & 
+       6.736,6.736,6.736,6.736,6.736,6.736,     & 
+       6.736,6.736,8.818,9.938,11.283,12.687,   & 
+       6.277,6.277,6.277,6.277,6.277,6.277,     & 
+       6.277,6.277,8.123,9.094,10.275,11.501,   & 
+                                ! pom soluble 
+       6.676,6.676,6.676,6.676,6.710,6.934,   & 
+       7.141,7.569,8.034,8.529,9.456,10.511,  & 
+       5.109,5.109,5.109,5.109,5.189,5.535,   & 
+       5.960,6.852,8.008,9.712,12.897,19.676, & 
+       3.718,3.718,3.718,3.718,3.779,4.042,   & 
+       4.364,5.052,5.956,7.314,9.896,15.688,  & 
+       2.849,2.849,2.849,2.849,2.897,3.107,   & 
+       3.365,3.916,4.649,5.760,7.900,12.863,  & 
+       2.229,2.229,2.229,2.229,2.268,2.437,   & 
+       2.645,3.095,3.692,4.608,6.391,10.633,  & 
+                                ! Sulfate (Accumulation) 
+       5.751,6.215,6.690,7.024,7.599,8.195,      & 
+       9.156,10.355,12.660,14.823,18.908,24.508, & 
+       4.320,4.675,5.052,5.375,5.787,6.274,      & 
+       7.066,8.083,10.088,12.003,15.697,21.133,  & 
+       3.079,3.351,3.639,3.886,4.205,4.584,      & 
+       5.206,6.019,7.648,9.234,12.391,17.220,    & 
+       2.336,2.552,2.781,2.979,3.236,3.540,      & 
+       4.046,4.711,6.056,7.388,10.093,14.313,    & 
+       1.777,1.949,2.134,2.292,2.503,2.751,      & 
+       3.166,3.712,4.828,5.949,8.264,11.922,     & 
+                                ! Sulfate (Coarse) 
+       5.751,6.215,6.690,7.024,7.599,8.195,      & 
+       9.156,10.355,12.660,14.823,18.908,24.508, & 
+       4.320,4.675,5.052,5.375,5.787,6.274,      & 
+       7.066,8.083,10.088,12.003,15.697,21.133,  & 
+       3.079,3.351,3.639,3.886,4.205,4.584,      & 
+       5.206,6.019,7.648,9.234,12.391,17.220,    & 
+       2.336,2.552,2.781,2.979,3.236,3.540,      & 
+       4.046,4.711,6.056,7.388,10.093,14.313,    & 
+       1.777,1.949,2.134,2.292,2.503,2.751,      & 
+       3.166,3.712,4.828,5.949,8.264,11.922,     & 
+                                ! Seasalt soluble super_coarse (computed below for 550nm) 
+       0.50,0.90,1.05,1.21,1.40,2.41, &  
+       2.66,3.11,3.88,4.52,5.69,8.84, &  
+       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.52,0.93,1.08,1.24,1.43,2.47, &  
+     2.73,3.20,3.99,4.64,5.84,9.04, &  
+     0.52,0.93,1.09,1.25,1.44,2.50, &  
+     2.76,3.23,4.03,4.68,5.89,9.14, &  
+     0.52,0.94,1.09,1.26,1.45,2.51, &  
+     2.78,3.25,4.06,4.72,5.94,9.22, &  
+                                ! seasalt soluble coarse (computed below for 550nm) 
+       0.50,0.90,1.05,1.21,1.40,2.41, &  
+       2.66,3.11,3.88,4.52,5.69,8.84, &  
+       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.52,0.93,1.08,1.24,1.43,2.47, &  
+     2.73,3.20,3.99,4.64,5.84,9.04, &  
+     0.52,0.93,1.09,1.25,1.44,2.50, &  
+     2.76,3.23,4.03,4.68,5.89,9.14, &  
+     0.52,0.94,1.09,1.26,1.45,2.51, &  
+     2.78,3.25,4.06,4.72,5.94,9.22, &  
+                                ! seasalt soluble accumulation (computed below for 550nm) 
+     4.28, 7.17, 8.44, 9.85,11.60,22.44,  &  
+     25.34,30.54,39.38,46.52,59.33,91.77, &  
+       0.000,0.000,0.000,0.000,0.000,0.000, &  
+       0.000,0.000,0.000,0.000,0.000,0.000, &  
+     2.48, 4.22, 5.02, 5.94, 7.11,15.29,  &  
+     17.70,22.31,30.73,38.06,52.15,90.59, &  
+     1.90, 3.29, 3.94, 4.69, 5.65, 12.58, &  
+     14.68,18.77,26.41,33.25,46.77,85.50, &  
+     1.47, 2.59, 3.12, 3.74, 4.54, 10.42, &  
+     12.24,15.82,22.66,28.91,41.54,79.33/ 
+
+  DATA alpha_aeri_5wv/ &
+                                 ! dust insoluble 
+        0.759, 0.770, 0.775, 0.775, 0.772, & 
+                                 !!jb bc insoluble 
+        11.536,10.033, 8.422, 7.234, 6.270, & 
+                                 ! pom insoluble 
+        5.042, 3.101, 1.890, 1.294, 0.934/ 
+   ! 
+  DATA cg_aers_5wv/ &  
+                                 ! bc soluble 
+      .651, .651, .651, .651, .651, .651, & 
+      .651, .651, .738, .764, .785, .800, & 
+      .597, .597, .597, .597, .597, .597, & 
+      .597, .597, .695, .725, .751, .770, & 
+      .543, .543, .543, .543, .543, .543, & 
+      .543, .543, .650, .684, .714, .736, &  
+      .504, .504, .504, .504, .504, .504, & 
+      .504, .504, .614, .651, .683, .708, &  
+      .469, .469, .469, .469, .469, .469, & 
+      .469, .469, .582, .620, .655, .681, & 
+                                 ! pom soluble 
+      .679, .679, .679, .679, .683, .691, & 
+      .703, .720, .736, .751, .766, .784, & 
+      .656, .656, .656, .656, .659, .669, & 
+      .681, .699, .717, .735, .750, .779, &  
+      .623, .623, .623, .623, .627, .637, & 
+      .649, .668, .688, .709, .734, .762, & 
+      .592, .592, .592, .592, .595, .605, & 
+      .618, .639, .660, .682, .711, .743, & 
+      .561, .561, .561, .561, .565, .575, & 
+      .588, .609, .632, .656, .688, .724, & 
+                                 ! Accumulation sulfate 
+      .671, .684, .697, .704, .714, .723, & 
+      .734, .746, .762, .771, .781, .789, & 
+      .653, .666, .678, .687, .697, .707, & 
+      .719, .732, .751, .762, .775, .789, & 
+      .622, .635, .648, .657, .667, .678, & 
+      .691, .705, .728, .741, .758, .777, & 
+      .591, .604, .617, .627, .638, .650, & 
+      .664, .679, .704, .719, .739, .761, & 
+      .560, .574, .587, .597, .609, .621, &  
+      .637, .653, .680, .697, .719, .745, & 
+                                 ! Coarse sulfate 
+      .671, .684, .697, .704, .714, .723, & 
+      .734, .746, .762, .771, .781, .789, & 
+      .653, .666, .678, .687, .697, .707, & 
+      .719, .732, .751, .762, .775, .789, & 
+      .622, .635, .648, .657, .667, .678, & 
+      .691, .705, .728, .741, .758, .777, & 
+      .591, .604, .617, .627, .638, .650, & 
+      .664, .679, .704, .719, .739, .761, & 
+      .560, .574, .587, .597, .609, .621, &  
+      .637, .653, .680, .697, .719, .745, & 
+                                 ! For super coarse seasalt (computed below for 550nm!) 
+      0.730,0.753,0.760,0.766,0.772,0.793, &  
+      0.797,0.802,0.809,0.813,0.820,0.830, &  
+      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.721,0.744,0.750,0.756,0.762,0.784, &  
+      0.787,0.793,0.800,0.804,0.811,0.822, &  
+      0.717,0.741,0.747,0.753,0.759,0.780, &  
+      0.784,0.789,0.795,0.800,0.806,0.817, &  
+      0.715,0.739,0.745,0.751,0.757,0.777, &   
+      0.781,0.786,0.793,0.797,0.803,0.814, &  
+                                 ! For coarse-soluble seasalt (computed below for 550nm!) 
+      0.730,0.753,0.760,0.766,0.772,0.793, &  
+      0.797,0.802,0.809,0.813,0.820,0.830, &  
+      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.721,0.744,0.750,0.756,0.762,0.784, &  
+      0.787,0.793,0.800,0.804,0.811,0.822, &  
+      0.717,0.741,0.747,0.753,0.759,0.780, &  
+      0.784,0.789,0.795,0.800,0.806,0.817, &  
+      0.715,0.739,0.745,0.751,0.757,0.777, &   
+      0.781,0.786,0.793,0.797,0.803,0.814, &  
+                                 ! accumulation-seasalt soluble (computed below for 550nm!)  
+      0.698,0.722,0.729,0.736,0.743,0.765, &  
+      0.768,0.773,0.777,0.779,0.781,0.779, &  
+      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.658,0.691,0.701,0.710,0.720,0.756, &  
+      0.763,0.771,0.782,0.788,0.795,0.801, &  
+      0.632,0.668,0.679,0.690,0.701,0.743, &  
+      0.750,0.762,0.775,0.783,0.792,0.804, &  
+      0.605,0.644,0.656,0.669,0.681,0.729, &  
+      0.737,0.750,0.765,0.775,0.787,0.803/
+ !
+
+  DATA cg_aeri_5wv/&
+     ! dust insoluble
+     0.714, 0.697, 0.688, 0.683, 0.679, &
+     ! bc insoluble
+     0.511, 0.445, 0.384, 0.342, 0.307, &
+     !c pom insoluble
+     0.596, 0.536, 0.466, 0.409, 0.359/
+  !
+  DATA piz_aers_5wv/&
+                           ! bc soluble 
+  .445, .445, .445, .445, .445, .445, & 
+  .445, .445, .470, .487, .508, .531, & 
+  .442, .442, .442, .442, .442, .442, & 
+  .442, .442, .462, .481, .506, .533, & 
+  .427, .427, .427, .427, .427, .427, & 
+  .427, .427, .449, .470, .497, .526, & 
+  .413, .413, .413, .413, .413, .413, & 
+  .413, .413, .437, .458, .486, .516, & 
+  .399, .399, .399, .399, .399, .399, & 
+  .399, .399, .423, .445, .473, .506, & 
+                           ! pom soluble 
+  .975, .975, .975, .975, .975, .977, & 
+  .979, .982, .984, .987, .990, .994, & 
+  .972, .972, .972, .972, .973, .974, & 
+  .977, .980, .983, .986, .989, .993, & 
+  .963, .963, .963, .963, .964, .966, & 
+  .969, .974, .977, .982, .986, .991, & 
+  .955, .955, .955, .955, .955, .958, & 
+  .962, .967, .972, .977, .983, .989, & 
+  .944, .944, .944, .944, .944, .948, & 
+  .952, .959, .962, .972, .979, .987, & 
+                           ! sulfate soluble accumulation 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+                           ! sulfate soluble coarse 
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+                           ! seasalt super coarse (computed below for 550nm) 
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, & 
+                           ! seasalt coarse (computed below for 550nm) 
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+                           ! seasalt soluble accumulation (computed below for 550nm) 
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000, &  
+  1.000,1.000,1.000,1.000,1.000,1.000/ 
+
+ !
+  DATA piz_aeri_5wv/&
+     ! dust insoluble
+     0.944, 0.970, 0.977, 0.982, 0.987, &
+     ! bc insoluble
+     0.415, 0.387, 0.355, 0.328, 0.301, &
+     ! pom insoluble
+     0.972, 0.963, 0.943, 0.923, 0.897/
+
+! Interpolation des coefficients optiques de 19 niveaux vers le nombre des niveaux du model
+  IF (firstcall) THEN
+     firstcall=.FALSE.
+! Allocation
+    IF (.NOT. ALLOCATED(A1_ASSSM)) THEN
+        ALLOCATE(A1_ASSSM(klev),A2_ASSSM(klev), A3_ASSSM(klev),&
+          B1_ASSSM(klev), B2_ASSSM(klev), C1_ASSSM(klev), C2_ASSSM(klev),&
+          A1_CSSSM(klev), A2_CSSSM(klev), A3_CSSSM(klev),&
+          B1_CSSSM(klev), B2_CSSSM(klev), C1_CSSSM(klev), C2_CSSSM(klev),&
+          A1_SSSSM(klev), A2_SSSSM(klev), A3_SSSSM(klev),&
+          B1_SSSSM(klev), B2_SSSSM(klev), C1_SSSSM(klev), C2_SSSSM(klev), stat=ierr)
+        IF (ierr /= 0) CALL abort_gcm('aeropt_5mw', 'pb in allocation 1',1)
+     END IF
+
+!Accumulation mode
+     CALL pres2lev(A1_ASSSM_19, A1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_ASSSM_19, A2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_ASSSM_19, A3_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_ASSSM_19, B1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_ASSSM_19, B2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_ASSSM_19, C1_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_ASSSM_19, C2_ASSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+!Coarse mode
+     CALL pres2lev(A1_CSSSM_19, A1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_CSSSM_19, A2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_CSSSM_19, A3_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_CSSSM_19, B1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_CSSSM_19, B2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_CSSSM_19, C1_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_CSSSM_19, C2_CSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+!Super coarse mode
+     CALL pres2lev(A1_SSSSM_19, A1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A2_SSSSM_19, A2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(A3_SSSSM_19, A3_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B1_SSSSM_19, B1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(B2_SSSSM_19, B2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C1_SSSSM_19, C1_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+     CALL pres2lev(C2_SSSSM_19, C2_SSSSM, nb_level, klev, presnivs_19, presnivs, 1, 1, .FALSE.)
+
+  END IF ! firstcall
+
+
+  ! Initialisations
+  ai(:) = 0.
+  tausum(:,:,:) = 0.
+
+
+  DO k=1, klev
+    DO i=1, klon
+!      IF (t_seri(i,k).EQ.0) stop 'stop aeropt_5wv T '
+!      IF (pplay(i,k).EQ.0) stop  'stop aeropt_5wv p '
+      zrho=pplay(i,k)/t_seri(i,k)/RD                  ! kg/m3
+      dh(i,k)=pdel(i,k)/(gravit*zrho)
+!CDIR UNROLL=naero_spc
+      mass_temp(i,k,:) = m_allaer(i,k,:) / zrho / 1.e+9
+      zdp1(i,k)=pdel(i,k)/(gravit*delt)     ! air mass auxiliary  variable --> zdp1 [kg/(m^2 *s)]
+
+    ENDDO
+  ENDDO
+
+
+  IF (flag_aerosol .EQ. 1) THEN 
+     nb_aer = 2
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASSO4M
+     aerosol_name(2) = id_CSSO4M
+  ELSEIF (flag_aerosol .EQ. 2) THEN
+     nb_aer = 2
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASBCM
+     aerosol_name(2) = id_AIBCM
+  ELSEIF (flag_aerosol .EQ. 3) THEN 
+     nb_aer = 2
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASPOMM
+     aerosol_name(2) = id_AIPOMM
+  ELSEIF (flag_aerosol .EQ. 4) THEN 
+     nb_aer = 3
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_CSSSM
+     aerosol_name(2) = id_SSSSM
+     aerosol_name(3) = id_ASSSM
+  ELSEIF (flag_aerosol .EQ. 5) THEN 
+     nb_aer = 1
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_CIDUSTM
+  ELSEIF (flag_aerosol .EQ. 6) THEN 
+     nb_aer = 10
+     ALLOCATE (aerosol_name(nb_aer)) 
+     aerosol_name(1) = id_ASSO4M      
+     aerosol_name(2) = id_ASBCM
+     aerosol_name(3) = id_AIBCM
+     aerosol_name(4) = id_ASPOMM
+     aerosol_name(5) = id_AIPOMM
+     aerosol_name(6) = id_CSSSM
+     aerosol_name(7) = id_SSSSM
+     aerosol_name(8) = id_ASSSM
+     aerosol_name(9) = id_CIDUSTM
+     aerosol_name(10) = id_CSSO4M
+  ENDIF
+
+  ! 
+  ! loop over modes, use of precalculated nmd and corresponding sigma
+  !    loop over wavelengths
+  !    for each mass species in mode
+  !      interpolate from Sext to retrieve Sext_at_gridpoint_per_species
+  !      compute optical_thickness_at_gridpoint_per_species
+  
+
+  !
+  ! Calculations that need to be done since we are not in the subroutines INCA
+  !      
+
+!CDIR ON_ADB(RH_tab)
+!CDIR ON_ADB(fact_RH)
+!CDIR NOVECTOR
+  DO n=1,nbre_RH-1
+    fact_RH(n)=1./(RH_tab(n+1)-RH_tab(n))
+  ENDDO
+   
+  DO k=1, KLEV
+!CDIR ON_ADB(RH_tab)
+!CDIR ON_ADB(fact_RH)
+    DO i=1, KLON
+      rh(i,k)=MIN(RHcl(i,k)*100.,RH_MAX)
+      RH_num(i,k) = INT( rh(i,k)/10. + 1.)
+      IF (rh(i,k).GT.85.) RH_num(i,k)=10
+      IF (rh(i,k).GT.90.) RH_num(i,k)=11
+      DELTA(i,k)=(rh(i,k)-RH_tab(RH_num(i,k)))*fact_RH(RH_num(i,k))
+    ENDDO
+  ENDDO
+
+!CDIR SHORTLOOP  
+  used_tau(:)=.FALSE.
+    
+  DO m=1,nb_aer   ! tau is only computed for each mass    
+    fac=1.0
+    IF (aerosol_name(m).EQ.id_ASBCM) THEN
+        soluble=.TRUE.
+        spsol=1
+        spss=0
+    ELSEIF (aerosol_name(m).EQ.id_ASPOMM) THEN 
+        soluble=.TRUE.
+        spsol=2 
+        spss=0
+    ELSEIF (aerosol_name(m).EQ.id_ASSO4M) THEN
+        soluble=.TRUE.
+        spsol=3
+        spss=0
+        fac=1.375    ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD
+    ELSEIF (aerosol_name(m).EQ.id_CSSO4M) THEN
+        soluble=.TRUE.
+        spsol=4
+        spss=0
+        fac=1.375    ! (NH4)2-SO4/SO4 132/96 mass conversion factor for OD
+    ELSEIF (aerosol_name(m).EQ.id_SSSSM) THEN 
+        soluble=.TRUE.
+        spsol=5
+        spss=3
+    ELSEIF (aerosol_name(m).EQ.id_CSSSM) THEN 
+        soluble=.TRUE.
+        spsol=6
+        spss=2
+    ELSEIF (aerosol_name(m).EQ.id_ASSSM) THEN
+        soluble=.TRUE.
+        spsol=7
+        spss=1
+    ELSEIF (aerosol_name(m).EQ.id_CIDUSTM) THEN 
+        soluble=.FALSE.
+        spinsol=1
+        spss=0
+    ELSEIF  (aerosol_name(m).EQ.id_AIBCM) THEN 
+        soluble=.FALSE.
+        spinsol=2
+        spss=0
+    ELSEIF (aerosol_name(m).EQ.id_AIPOMM) THEN 
+        soluble=.FALSE.
+        spinsol=3
+        spss=0
+    ELSE 
+        CYCLE
+    ENDIF
+
+!Bug 21 12 10 AI
+!    used_tau(spsol)=.TRUE.
+    IF (soluble) then
+      used_tau(spsol)=.TRUE.
+       ELSE
+      used_tau(naero_soluble+spinsol)=.TRUE.
+    ENDIF
+
+    DO la=1,las
+
+      IF (soluble) THEN
+
+        IF((la.EQ.2).AND.(spss.NE.0)) THEN !la=2 corresponds to 550 nm
+          IF (spss.EQ.1) THEN !accumulation mode
+            DO k=1, KLEV
+!CDIR ON_ADB(A1_ASSSM)
+!CDIR ON_ADB(A2_ASSSM)
+!CDIR ON_ADB(A3_ASSSM)
+              DO i=1, KLON
+                H=rh(i,k)/100
+                tau_ae5wv_int=A1_ASSSM(k)+A2_ASSSM(k)*H+A3_ASSSM(k)/(H-1.05)
+                tau(i,k,la,spsol) = mass_temp(i,k,spsol)*1000.*zdp1(i,k)   &
+                                   *tau_ae5wv_int*delt*fac
+                tausum(i,la,spsol)=tausum(i,la,spsol)+tau(i,k,la,spsol)
+              ENDDO
+            ENDDO
+          ENDIF
+  
+          IF (spss.EQ.2) THEN !coarse mode
+            DO k=1, KLEV
+!CDIR ON_ADB(A1_CSSSM)
+!CDIR ON_ADB(A2_CSSSM)
+!CDIR ON_ADB(A3_CSSSM)
+              DO i=1, KLON
+                H=rh(i,k)/100
+                tau_ae5wv_int=A1_CSSSM(k)+A2_CSSSM(k)*H+A3_CSSSM(k)/(H-1.05)
+                tau(i,k,la,spsol) = mass_temp(i,k,spsol)*1000.*zdp1(i,k)  &
+                                   *tau_ae5wv_int*delt*fac
+                tausum(i,la,spsol) = tausum(i,la,spsol)+tau(i,k,la,spsol)
+              ENDDO
+            ENDDO
+          ENDIF
+
+          IF (spss.EQ.3) THEN !super coarse mode
+            DO k=1, KLEV
+!CDIR ON_ADB(A1_SSSSM)
+!CDIR ON_ADB(A2_SSSSM)
+!CDIR ON_ADB(A3_SSSSM)
+              DO i=1, KLON
+                H=rh(i,k)/100
+                tau_ae5wv_int=A1_SSSSM(k)+A2_SSSSM(k)*H+A3_SSSSM(k)/(H-1.05)
+                tau(i,k,la,spsol) = mass_temp(i,k,spsol)*1000.*zdp1(i,k)  &
+                                   *tau_ae5wv_int*delt*fac
+                tausum(i,la,spsol)=tausum(i,la,spsol)+tau(i,k,la,spsol)
+              ENDDO
+            ENDDO
+          ENDIF
+
+        ELSE
+          DO k=1, KLEV
+!CDIR ON_ADB(alpha_aers_5wv)
+            DO i=1, KLON
+              tau_ae5wv_int = alpha_aers_5wv(RH_num(i,k),la,spsol)+DELTA(i,k)* &
+                             (alpha_aers_5wv(RH_num(i,k)+1,la,spsol) - & 
+                              alpha_aers_5wv(RH_num(i,k),la,spsol))
+
+              tau(i,k,la,spsol) = mass_temp(i,k,spsol)*1000.*zdp1(i,k)   &
+                                 *tau_ae5wv_int*delt*fac
+              tausum(i,la,spsol)=tausum(i,la,spsol)+tau(i,k,la,spsol)
+            ENDDO
+          ENDDO
+        ENDIF
+
+      ELSE                                                  ! For insoluble aerosol
+        DO k=1, KLEV
+!CDIR ON_ADB(alpha_aeri_5wv)
+          DO i=1, KLON
+            tau_ae5wv_int = alpha_aeri_5wv(la,spinsol)
+            tau(i,k,la,naero_soluble+spinsol) = mass_temp(i,k,naero_soluble+spinsol)*1000.*zdp1(i,k)* &
+                                                tau_ae5wv_int*delt*fac
+            tausum(i,la,naero_soluble+spinsol)= tausum(i,la,naero_soluble+spinsol)  &
+                                               +tau(i,k,la,naero_soluble+spinsol)
+          ENDDO
+        ENDDO
+      ENDIF
+    ENDDO   ! boucle sur les longueurs d'onde
+  ENDDO     ! Boucle  sur les masses de traceurs
+
+  DO m=1,naero_spc
+    IF (.NOT.used_tau(m)) tau(:,:,:,m)=0.
+  ENDDO  
+!
+!
+!  taue670(:) = SUM(tausum(:,la670,:),dim=2) 
+!  taue865(:) = SUM(tausum(:,la865,:),dim=2) 
+!
+!  DO i=1, klon
+!    ai(i)=-LOG(MAX(taue670(i),0.0001)/ &
+!       MAX(taue865(i),0.0001))/LOG(670./865.)
+!  ENDDO
+
+  DO i=1, klon
+     od550aer(i)=0.
+     DO m=1,naero_spc
+        od550aer(i)=od550aer(i)+tausum(i,2,m)
+     END DO
+  END DO
+  DO i=1, klon
+     od865aer(i)=0.
+     DO m=1,naero_spc
+        od865aer(i)=od865aer(i)+tausum(i,5,m)
+     END DO
+  END DO
+  DO i=1, klon
+     DO k=1, KLEV
+        ec550aer(i,k)=0.
+        DO m=1,naero_spc
+           ec550aer(i,k)=ec550aer(i,k)+tau(i,k,2,m)/dh(i,k)
+        END DO
+     END DO
+  END DO
+  
+   od550lt1aer(:)=tausum(:,2,id_ASSO4M)+tausum(:,2,id_ASBCM)+tausum(:,2,id_AIBCM)+ &
+	tausum(:,2,id_ASPOMM)+tausum(:,2,id_AIPOMM)+tausum(:,2,id_ASSSM)+ &
+	0.03*tausum(:,2,id_CSSSM)+0.4*tausum(:,2,id_CIDUSTM)
+
+
+
+  DEALLOCATE(aerosol_name) 
+  
+END SUBROUTINE AEROPT_5WV
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ajsec.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ajsec.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ajsec.F90	(revision 17)
@@ -0,0 +1,403 @@
+!
+! $Header$
+!
+      SUBROUTINE ajsec(paprs, pplay, t,q,limbas,d_t,d_q)
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+!c Objet: ajustement sec (adaptation du GCM du LMD)
+!c======================================================================
+!c Arguments:
+!c t-------input-R- Temperature
+!c
+!c d_t-----output-R-Incrementation de la temperature
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev)
+      REAL d_t(klon,klev), d_q(klon,klev)
+!c
+      INTEGER limbas(klon), limhau ! les couches a ajuster
+!c
+      LOGICAL mixq
+!ccc      PARAMETER (mixq=.TRUE.)
+      PARAMETER (mixq=.FALSE.)
+!c
+      REAL zh(klon,klev)
+      REAL zho(klon,klev)
+      REAL zq(klon,klev)
+      REAL zpk(klon,klev)
+      REAL zpkdp(klon,klev)
+      REAL hm, sm, qm
+      LOGICAL modif(klon), down
+      INTEGER i, k, k1, k2
+!c
+!c Initialisation:
+!c
+!cym
+      limhau=klev
+  
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+!c------------------------------------- detection des profils a modifier
+      DO k = 1, limhau
+      DO i = 1, klon
+         zpk(i,k) = pplay(i,k)**RKAPPA
+         zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
+         zho(i,k) = zh(i,k)
+         zq(i,k) = q(i,k)
+      ENDDO
+      ENDDO
+!c
+      DO k = 1, limhau
+      DO i = 1, klon
+         zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
+      ENDDO
+      ENDDO
+!c
+      DO i = 1, klon
+         modif(i) = .FALSE.
+      ENDDO
+      DO k = 2, limhau
+      DO i = 1, klon
+      IF (.NOT.modif(i).and.k-1>limbas(i)) THEN
+         IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
+      ENDIF
+      ENDDO
+      ENDDO
+!c------------------------------------- correction des profils instables
+      DO 1080 i = 1, klon
+      IF (modif(i)) THEN
+          k2 = limbas(i)
+ 8000     CONTINUE
+            k2 = k2 + 1
+            IF (k2 .GT. limhau) goto 8001
+            IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
+              k1 = k2 - 1
+              k = k1
+              sm = zpkdp(i,k2)
+              hm = zh(i,k2)
+              qm = zq(i,k2)
+ 8020         CONTINUE
+                sm = sm +zpkdp(i,k)
+                hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
+                qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
+                down = .FALSE.
+                IF (k1 .ne. limbas(i)) THEN
+                  IF (hm .LT. zh(i,k1-1)) down = .TRUE.
+                ENDIF
+                IF (down) THEN
+                  k1 = k1 - 1
+                  k = k1
+                ELSE
+                  IF ((k2 .EQ. limhau)) GOTO 8021
+                  IF ((zh(i,k2+1).GE.hm)) GOTO 8021
+                  k2 = k2 + 1
+                  k = k2
+                ENDIF
+              GOTO 8020
+ 8021         CONTINUE
+!c------------ nouveau profil : constant (valeur moyenne)
+              DO k = k1, k2
+                zh(i,k) = hm
+                zq(i,k) = qm
+              ENDDO
+              k2 = k2 + 1
+            ENDIF
+          GOTO 8000
+ 8001     CONTINUE
+      ENDIF
+ 1080 CONTINUE
+!c
+      DO k = 1, limhau
+      DO i = 1, klon
+         d_t(i,k) = (zh(i,k)-zho(i,k))*zpk(i,k)/RCPD
+         d_q(i,k) = zq(i,k) - q(i,k)
+      ENDDO
+      ENDDO
+!c
+! FH : les d_q et d_t sont maintenant calcules de facon a valoir
+! effectivement 0. si on ne fait rien.
+!
+!     IF (limbas.GT.1) THEN
+!     DO k = 1, limbas-1
+!     DO i = 1, klon
+!        d_t(i,k) = 0.0
+!        d_q(i,k) = 0.0
+!     ENDDO
+!     ENDDO
+!     ENDIF
+!c
+!     IF (limhau.LT.klev) THEN
+!     DO k = limhau+1, klev
+!     DO i = 1, klon
+!        d_t(i,k) = 0.0
+!        d_q(i,k) = 0.0
+!     ENDDO
+!     ENDDO
+!     ENDIF
+!c
+      IF (.NOT.mixq) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+!c
+      RETURN
+      END
+
+      SUBROUTINE ajsec_convV2(paprs, pplay, t,q, d_t,d_q)
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+!c Objet: ajustement sec (adaptation du GCM du LMD)
+!c======================================================================
+!c Arguments:
+!c t-------input-R- Temperature
+!c
+!c d_t-----output-R-Incrementation de la temperature
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev)
+      REAL d_t(klon,klev), d_q(klon,klev)
+!c
+      INTEGER limbas, limhau ! les couches a ajuster
+!ccc      PARAMETER (limbas=klev-3, limhau=klev)
+!cym      PARAMETER (limbas=1, limhau=klev)
+!c
+      LOGICAL mixq
+!ccc      PARAMETER (mixq=.TRUE.)
+      PARAMETER (mixq=.FALSE.)
+!c
+      REAL zh(klon,klev)
+      REAL zq(klon,klev)
+      REAL zpk(klon,klev)
+      REAL zpkdp(klon,klev)
+      REAL hm, sm, qm
+      LOGICAL modif(klon), down
+      INTEGER i, k, k1, k2
+!c
+!c Initialisation:
+!c
+!cym
+      limbas=1
+      limhau=klev
+  
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+!c------------------------------------- detection des profils a modifier
+      DO k = limbas, limhau
+      DO i = 1, klon
+         zpk(i,k) = pplay(i,k)**RKAPPA
+         zh(i,k) = RCPD * t(i,k)/ zpk(i,k)
+         zq(i,k) = q(i,k)
+      ENDDO
+      ENDDO
+!c
+      DO k = limbas, limhau
+      DO i = 1, klon
+         zpkdp(i,k) = zpk(i,k) * (paprs(i,k)-paprs(i,k+1))
+      ENDDO
+      ENDDO
+!c
+      DO i = 1, klon
+         modif(i) = .FALSE.
+      ENDDO
+      DO k = limbas+1, limhau
+      DO i = 1, klon
+      IF (.NOT.modif(i)) THEN
+         IF ( zh(i,k).LT.zh(i,k-1) ) modif(i) = .TRUE.
+      ENDIF
+      ENDDO
+      ENDDO
+!c------------------------------------- correction des profils instables
+      DO 1080 i = 1, klon
+      IF (modif(i)) THEN
+          k2 = limbas
+ 8000     CONTINUE
+            k2 = k2 + 1
+            IF (k2 .GT. limhau) goto 8001
+            IF (zh(i,k2) .LT. zh(i,k2-1)) THEN
+              k1 = k2 - 1
+              k = k1
+              sm = zpkdp(i,k2)
+              hm = zh(i,k2)
+              qm = zq(i,k2)
+ 8020         CONTINUE
+                sm = sm +zpkdp(i,k)
+                hm = hm +zpkdp(i,k) * (zh(i,k)-hm) / sm
+                qm = qm +zpkdp(i,k) * (zq(i,k)-qm) / sm
+                down = .FALSE.
+                IF (k1 .ne. limbas) THEN
+                  IF (hm .LT. zh(i,k1-1)) down = .TRUE.
+                ENDIF
+                IF (down) THEN
+                  k1 = k1 - 1
+                  k = k1
+                ELSE
+                  IF ((k2 .EQ. limhau)) GOTO 8021
+                  IF ((zh(i,k2+1).GE.hm)) GOTO 8021
+                  k2 = k2 + 1
+                  k = k2
+                ENDIF
+              GOTO 8020
+ 8021         CONTINUE
+!c------------ nouveau profil : constant (valeur moyenne)
+              DO k = k1, k2
+                zh(i,k) = hm
+                zq(i,k) = qm
+              ENDDO
+              k2 = k2 + 1
+            ENDIF
+          GOTO 8000
+ 8001     CONTINUE
+      ENDIF
+ 1080 CONTINUE
+!c
+      DO k = limbas, limhau
+      DO i = 1, klon
+         d_t(i,k) = zh(i,k)*zpk(i,k)/RCPD - t(i,k)
+         d_q(i,k) = zq(i,k) - q(i,k)
+      ENDDO
+      ENDDO
+!c
+      IF (limbas.GT.1) THEN
+      DO k = 1, limbas-1
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+!c
+      IF (limhau.LT.klev) THEN
+      DO k = limhau+1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+!c
+      IF (.NOT.mixq) THEN
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,k) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+!c
+      RETURN
+      END
+      SUBROUTINE ajsec_old(paprs, pplay, t, d_t)
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+!c Objet: ajustement sec (adaptation du GCM du LMD)
+!c======================================================================
+!c Arguments:
+!c t-------input-R- Temperature
+!c
+!c d_t-----output-R-Incrementation de la temperature
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+      REAL d_t(klon,klev)
+!c
+      REAL local_h(klon,klev)
+      REAL hm, sm
+      LOGICAL modif(klon), down
+      INTEGER i, l, l1, l2
+!c------------------------------------- detection des profils a modifier
+      DO i = 1, klon
+         modif(i)   = .false.
+      ENDDO
+!c
+      DO l = 1, klev
+      DO i = 1, klon
+         local_h(i,l) = RCPD * t(i,l)/ (pplay(i,l)**RKAPPA)
+      ENDDO
+      ENDDO
+!c
+      DO l = 2, klev
+      DO i = 1, klon
+         IF ( local_h(i,l).lt.local_h(i,l-1) ) THEN
+            modif(i) = .true.
+         ELSE
+            modif(i) = modif(i)
+         ENDIF
+      ENDDO
+      ENDDO
+!c------------------------------------- correction des profils instables
+      do 1080 i = 1, klon
+        if (modif(i)) then
+          l2 = 1
+ 8000     continue
+            l2 = l2 + 1
+            if (l2 .gt. klev) goto 8001
+            if (local_h(i, l2) .lt. local_h(i, l2-1)) then
+              l1 = l2 - 1
+              l  = l1
+              sm = pplay(i,l2)**rkappa * (paprs(i,l2)-paprs(i,l2+1))
+              hm = local_h(i, l2)
+ 8020         continue
+                sm = sm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1))
+                hm = hm +pplay(i,l)**rkappa*(paprs(i,l)-paprs(i,l+1))                &
+       &                         * (local_h(i, l) - hm) / sm
+                down = .false.
+                if (l1 .ne. 1) then
+                  if (hm .lt. local_h(i, l1-1)) then
+                    down = .true.
+                  end if
+                end if
+                if (down) then
+                  l1 = l1 - 1
+                  l  = l1
+                else
+                  if ((l2 .eq. klev)) GOTO 8021
+                  IF ((local_h(i, l2+1).ge.hm)) goto 8021
+                  l2 = l2 + 1
+                  l  = l2
+                end if
+              go to 8020
+ 8021         continue
+!c------------ nouveau profil : constant (valeur moyenne)
+              do 1100 l = l1, l2
+                local_h(i, l) = hm
+ 1100         continue
+              l2 = l2 + 1
+            end if
+          go to 8000
+ 8001     continue
+        end if
+ 1080 continue
+!c
+      DO l = 1, klev
+      DO i = 1, klon
+         d_t(i,l) = local_h(i,l)*(pplay(i,l)**rkappa)/RCPD - t(i,l)
+      ENDDO
+      ENDDO
+!c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/albedo.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/albedo.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/albedo.F	(revision 17)
@@ -0,0 +1,191 @@
+!
+! $Id: albedo.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+c
+c
+      SUBROUTINE alboc(rjour,rlat,albedo)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD)
+c Date: le 16 mars 1995
+c Objet: Calculer l'albedo sur l'ocean
+c Methode: Integrer numeriquement l'albedo pendant une journee
+c
+c Arguments;
+c rjour (in,R)  : jour dans l'annee (a compter du 1 janvier)
+c rlat (in,R)   : latitude en degre
+c albedo (out,R): albedo obtenu (de 0 a 1)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "clesphys.h"
+c
+c fmagic -> clesphys.h/.inc
+c     REAL fmagic ! un facteur magique pour regler l'albedo
+ccc      PARAMETER (fmagic=0.7)
+cccIM => a remplacer  
+c       PARAMETER (fmagic=1.32)
+c       PARAMETER (fmagic=1.0)
+c       PARAMETER (fmagic=0.7)
+      INTEGER npts ! il controle la precision de l'integration
+      PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes
+c
+      REAL rlat(klon), rjour, albedo(klon)
+      REAL zdist, zlonsun, zpi, zdeclin
+      REAL rmu,alb, srmu, salb, fauxo, aa, bb
+      INTEGER i, k
+cccIM
+      LOGICAL ancien_albedo
+      PARAMETER(ancien_albedo=.FALSE.) 
+c     SAVE albedo
+c
+      IF ( ancien_albedo ) THEN
+c
+      zpi = 4. * ATAN(1.)
+c
+c Calculer la longitude vraie de l'orbite terrestre:
+      CALL orbite(rjour,zlonsun,zdist)
+c
+c Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+      zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0))
+c
+      DO 999 i=1,klon
+      aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin)
+      bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin)
+c
+c Midi local (angle du temps = 0.0):
+      rmu = aa + bb * COS(0.0)
+      rmu = MAX(0.0, rmu)
+      fauxo = (1.47-ACOS(rmu))/.15
+      alb = 0.03+0.630/(1.+fauxo*fauxo)
+      srmu = rmu
+      salb = alb * rmu
+c
+c Faire l'integration numerique de midi a minuit (le facteur 2
+c prend en compte l'autre moitie de la journee):
+      DO k = 1, npts
+         rmu = aa + bb * COS(REAL(k)/REAL(npts)*zpi)
+         rmu = MAX(0.0, rmu)
+         fauxo = (1.47-ACOS(rmu))/.15
+         alb = 0.03+0.630/(1.+fauxo*fauxo)
+         srmu = srmu + rmu * 2.0
+         salb = salb + alb*rmu * 2.0
+      ENDDO
+      IF (srmu .NE. 0.0) THEN
+         albedo(i) = salb / srmu * fmagic+pmagic
+      ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+         albedo(i) = fmagic
+      ENDIF
+  999 CONTINUE
+c
+c nouvel albedo 
+c
+      ELSE
+c
+      zpi = 4. * ATAN(1.)
+c
+c Calculer la longitude vraie de l'orbite terrestre:
+      CALL orbite(rjour,zlonsun,zdist)
+c
+c Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+      zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0))
+c
+      DO 1999 i=1,klon
+      aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin)
+      bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin)
+c
+c Midi local (angle du temps = 0.0):
+      rmu = aa + bb * COS(0.0)
+      rmu = MAX(0.0, rmu)
+cIM cf. PB  alb = 0.058/(rmu + 0.30)
+c     alb = 0.058/(rmu + 0.30) * 1.5
+      alb = 0.058/(rmu + 0.30) * 1.2
+c     alb = 0.058/(rmu + 0.30) * 1.3
+      srmu = rmu
+      salb = alb * rmu
+c
+c Faire l'integration numerique de midi a minuit (le facteur 2
+c prend en compte l'autre moitie de la journee):
+      DO k = 1, npts
+         rmu = aa + bb * COS(REAL(k)/REAL(npts)*zpi)
+         rmu = MAX(0.0, rmu)
+cIM cf. PB      alb = 0.058/(rmu + 0.30)
+c        alb = 0.058/(rmu + 0.30) * 1.5
+         alb = 0.058/(rmu + 0.30) * 1.2
+c        alb = 0.058/(rmu + 0.30) * 1.3
+         srmu = srmu + rmu * 2.0
+         salb = salb + alb*rmu * 2.0
+      ENDDO
+      IF (srmu .NE. 0.0) THEN
+         albedo(i) = salb / srmu * fmagic+pmagic
+      ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+         albedo(i) = fmagic
+      ENDIF
+1999  CONTINUE
+      ENDIF
+      RETURN
+      END
+c=====================================================================
+      SUBROUTINE alboc_cd(rmu0,albedo)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS)
+c date: 19940624
+c Calculer l'albedo sur l'ocean en fonction de l'angle zenithal moyen
+c Formule due a Larson and Barkstrom (1977) Proc. of the symposium
+C on radiation in the atmosphere, 19-28 August 1976, science Press,
+C 1977 pp 451-453, ou These de 3eme cycle de Sylvie Joussaume.
+c
+c Arguments
+c rmu0    (in): cosinus de l'angle solaire zenithal
+c albedo (out): albedo de surface de l'ocean
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "clesphys.h"
+      REAL rmu0(klon), albedo(klon)
+c
+c     REAL fmagic ! un facteur magique pour regler l'albedo
+ccc      PARAMETER (fmagic=0.7)
+cccIM => a remplacer  
+c       PARAMETER (fmagic=1.32)
+c       PARAMETER (fmagic=1.0)
+c       PARAMETER (fmagic=0.7) 
+c
+      REAL fauxo
+      INTEGER i
+cccIM
+      LOGICAL ancien_albedo
+      PARAMETER(ancien_albedo=.FALSE.) 
+c     SAVE albedo
+c
+      IF ( ancien_albedo ) THEN
+c
+      DO i = 1, klon
+c
+         rmu0(i) = MAX(rmu0(i),0.0)
+c
+         fauxo = ( 1.47 - ACOS( rmu0(i) ) )/0.15
+         albedo(i) = fmagic*( .03 + .630/( 1. + fauxo*fauxo))+pmagic
+         albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
+      ENDDO
+c
+c nouvel albedo 
+c
+      ELSE
+c
+      DO i = 1, klon
+         rmu0(i) = MAX(rmu0(i),0.0)
+cIM:orig albedo(i) = 0.058/(rmu0(i) + 0.30)
+         albedo(i) = fmagic * 0.058/(rmu0(i) + 0.30)+pmagic
+         albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
+      ENDDO
+c
+      ENDIF
+c
+      RETURN
+      END
+c========================================================================
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/albedo.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/albedo.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/albedo.F90	(revision 17)
@@ -0,0 +1,191 @@
+!
+! $Id: albedo.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+!c
+!c
+      SUBROUTINE alboc(rjour,rlat,albedo)
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM du LMD)
+!c Date: le 16 mars 1995
+!c Objet: Calculer l'albedo sur l'ocean
+!c Methode: Integrer numeriquement l'albedo pendant une journee
+!c
+!c Arguments;
+!c rjour (in,R)  : jour dans l'annee (a compter du 1 janvier)
+!c rlat (in,R)   : latitude en degre
+!c albedo (out,R): albedo obtenu (de 0 a 1)
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "clesphys.h"
+!c
+!c fmagic -> clesphys.h/.inc
+!c     REAL fmagic ! un facteur magique pour regler l'albedo
+!ccc      PARAMETER (fmagic=0.7)
+!cccIM => a remplacer  
+!c       PARAMETER (fmagic=1.32)
+!c       PARAMETER (fmagic=1.0)
+!c       PARAMETER (fmagic=0.7)
+      INTEGER npts ! il controle la precision de l'integration
+      PARAMETER (npts=120) ! 120 correspond a l'interval 6 minutes
+!c
+      REAL rlat(klon), rjour, albedo(klon)
+      REAL zdist, zlonsun, zpi, zdeclin
+      REAL rmu,alb, srmu, salb, fauxo, aa, bb
+      INTEGER i, k
+!cccIM
+      LOGICAL ancien_albedo
+      PARAMETER(ancien_albedo=.FALSE.) 
+!c     SAVE albedo
+!c
+      IF ( ancien_albedo ) THEN
+!c
+      zpi = 4. * ATAN(1.)
+!c
+!c Calculer la longitude vraie de l'orbite terrestre:
+      CALL orbite(rjour,zlonsun,zdist)
+!c
+!c Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+      zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0))
+!c
+      DO 999 i=1,klon
+      aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin)
+      bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin)
+!c
+!c Midi local (angle du temps = 0.0):
+      rmu = aa + bb * COS(0.0)
+      rmu = MAX(0.0, rmu)
+      fauxo = (1.47-ACOS(rmu))/.15
+      alb = 0.03+0.630/(1.+fauxo*fauxo)
+      srmu = rmu
+      salb = alb * rmu
+!c
+!c Faire l'integration numerique de midi a minuit (le facteur 2
+!c prend en compte l'autre moitie de la journee):
+      DO k = 1, npts
+         rmu = aa + bb * COS(REAL(k)/REAL(npts)*zpi)
+         rmu = MAX(0.0, rmu)
+         fauxo = (1.47-ACOS(rmu))/.15
+         alb = 0.03+0.630/(1.+fauxo*fauxo)
+         srmu = srmu + rmu * 2.0
+         salb = salb + alb*rmu * 2.0
+      ENDDO
+      IF (srmu .NE. 0.0) THEN
+         albedo(i) = salb / srmu * fmagic+pmagic
+      ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+         albedo(i) = fmagic
+      ENDIF
+  999 CONTINUE
+!c
+!c nouvel albedo 
+!c
+      ELSE
+!c
+      zpi = 4. * ATAN(1.)
+!c
+!c Calculer la longitude vraie de l'orbite terrestre:
+      CALL orbite(rjour,zlonsun,zdist)
+!c
+!c Calculer la declinaison du soleil (qui varie entre + et - R_incl):
+      zdeclin = ASIN(SIN(zlonsun*zpi/180.0)*SIN(R_incl*zpi/180.0))
+!c
+      DO 1999 i=1,klon
+      aa = SIN(rlat(i)*zpi/180.0) * SIN(zdeclin)
+      bb = COS(rlat(i)*zpi/180.0) * COS(zdeclin)
+!c
+!c Midi local (angle du temps = 0.0):
+      rmu = aa + bb * COS(0.0)
+      rmu = MAX(0.0, rmu)
+!IM cf. PB  alb = 0.058/(rmu + 0.30)
+!c     alb = 0.058/(rmu + 0.30) * 1.5
+      alb = 0.058/(rmu + 0.30) * 1.2
+!c     alb = 0.058/(rmu + 0.30) * 1.3
+      srmu = rmu
+      salb = alb * rmu
+!c
+!c Faire l'integration numerique de midi a minuit (le facteur 2
+!c prend en compte l'autre moitie de la journee):
+      DO k = 1, npts
+         rmu = aa + bb * COS(REAL(k)/REAL(npts)*zpi)
+         rmu = MAX(0.0, rmu)
+!IM cf. PB      alb = 0.058/(rmu + 0.30)
+!c        alb = 0.058/(rmu + 0.30) * 1.5
+         alb = 0.058/(rmu + 0.30) * 1.2
+!c        alb = 0.058/(rmu + 0.30) * 1.3
+         srmu = srmu + rmu * 2.0
+         salb = salb + alb*rmu * 2.0
+      ENDDO
+      IF (srmu .NE. 0.0) THEN
+         albedo(i) = salb / srmu * fmagic+pmagic
+      ELSE ! nuit polaire (on peut prendre une valeur quelconque)
+         albedo(i) = fmagic
+      ENDIF
+1999  CONTINUE
+      ENDIF
+      RETURN
+      END SUBROUTINE alboc
+!c=====================================================================
+      SUBROUTINE alboc_cd(rmu0,albedo)
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS)
+!c date: 19940624
+!c Calculer l'albedo sur l'ocean en fonction de l'angle zenithal moyen
+!c Formule due a Larson and Barkstrom (1977) Proc. of the symposium
+!C on radiation in the atmosphere, 19-28 August 1976, science Press,
+!C 1977 pp 451-453, ou These de 3eme cycle de Sylvie Joussaume.
+!c
+!c Arguments
+!c rmu0    (in): cosinus de l'angle solaire zenithal
+!c albedo (out): albedo de surface de l'ocean
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "clesphys.h"
+      REAL rmu0(klon), albedo(klon)
+!c
+!c     REAL fmagic ! un facteur magique pour regler l'albedo
+!ccc      PARAMETER (fmagic=0.7)
+!cccIM => a remplacer  
+!c       PARAMETER (fmagic=1.32)
+!c       PARAMETER (fmagic=1.0)
+!c       PARAMETER (fmagic=0.7) 
+!c
+      REAL fauxo
+      INTEGER i
+!cccIM
+      LOGICAL ancien_albedo
+      PARAMETER(ancien_albedo=.FALSE.) 
+!c     SAVE albedo
+!c
+      IF ( ancien_albedo ) THEN
+!c
+      DO i = 1, klon
+!c
+         rmu0(i) = MAX(rmu0(i),0.0)
+!c
+         fauxo = ( 1.47 - ACOS( rmu0(i) ) )/0.15
+         albedo(i) = fmagic*( .03 + .630/( 1. + fauxo*fauxo))+pmagic
+         albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
+      ENDDO
+!c
+!c nouvel albedo 
+!c
+      ELSE
+!c
+      DO i = 1, klon
+         rmu0(i) = MAX(rmu0(i),0.0)
+!IM:orig albedo(i) = 0.058/(rmu0(i) + 0.30)
+         albedo(i) = fmagic * 0.058/(rmu0(i) + 0.30)+pmagic
+         albedo(i) = MAX(MIN(albedo(i),0.60),0.04)
+      ENDDO
+!c
+      ENDIF
+!c
+      RETURN
+      END SUBROUTINE alboc_cd
+!c========================================================================
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/albsno.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/albsno.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/albsno.F90	(revision 17)
@@ -0,0 +1,55 @@
+!
+! $Header$
+!
+SUBROUTINE albsno(klon, knon, dtime, agesno, alb_neig_grid, precip_snow)
+
+  IMPLICIT NONE
+
+! Input arguments
+!****************************************************************************************
+  INTEGER, INTENT(IN)                  :: klon, knon
+  REAL, INTENT(IN)                     :: dtime
+  REAL, DIMENSION(klon), INTENT(IN)    :: precip_snow
+
+! In/Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(INOUT) :: agesno
+
+! Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(OUT)   :: alb_neig_grid
+
+! Local variables
+!****************************************************************************************
+  INTEGER                              :: i, nv
+  INTEGER, PARAMETER                   :: nvm = 8 
+  REAL                                 :: as
+  REAL, DIMENSION(klon,nvm)            :: veget
+  REAL, DIMENSION(nvm),SAVE            :: init, decay
+  !$OMP THREADPRIVATE(init, decay)
+
+  DATA init /0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./
+  DATA decay/0.30, 0.67, 0.63, 0.45, 0.40, 0.14, 0.06, 1./
+!****************************************************************************************
+
+  veget = 0.
+  veget(:,1) = 1.     ! desert partout
+  DO i = 1, knon
+     alb_neig_grid(i) = 0.0
+  ENDDO
+  DO nv = 1, nvm
+     DO i = 1, knon
+        as = init(nv)+decay(nv)*EXP(-agesno(i)/5.)
+        alb_neig_grid(i) = alb_neig_grid(i) + veget(i,nv)*as
+     ENDDO
+  ENDDO
+  
+
+! modilation en fonction de l'age de la neige
+  DO i = 1, knon
+     agesno(i)  = (agesno(i) + (1.-agesno(i)/50.)*dtime/86400.)&
+          &             * EXP(-1.*MAX(0.0,precip_snow(i))*dtime/0.3)
+     agesno(i) =  MAX(agesno(i),0.0)
+  ENDDO
+  
+END SUBROUTINE albsno
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/assert_eq_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/assert_eq_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/assert_eq_m.F90	(revision 17)
@@ -0,0 +1,70 @@
+! $Id$
+MODULE assert_eq_m
+
+  implicit none
+
+  INTERFACE assert_eq
+     MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn
+  END INTERFACE
+
+  private assert_eq2,assert_eq3,assert_eq4,assert_eqn
+
+CONTAINS
+
+  FUNCTION assert_eq2(n1,n2,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    INTEGER, INTENT(IN) :: n1,n2
+    INTEGER  assert_eq2
+    if (n1 == n2) then
+       assert_eq2=n1
+    else
+       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
+            string
+       print *, 'program terminated by assert_eq2'
+       stop 1
+    end if
+  END FUNCTION assert_eq2
+  !BL
+  FUNCTION assert_eq3(n1,n2,n3,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    INTEGER, INTENT(IN) :: n1,n2,n3
+    INTEGER  assert_eq3
+    if (n1 == n2 .and. n2 == n3) then
+       assert_eq3=n1
+    else
+       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
+            string
+       print *, 'program terminated by assert_eq3'
+       stop 1
+    end if
+  END FUNCTION assert_eq3
+  !BL
+  FUNCTION assert_eq4(n1,n2,n3,n4,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    INTEGER, INTENT(IN) :: n1,n2,n3,n4
+    INTEGER  assert_eq4
+    if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then
+       assert_eq4=n1
+    else
+       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
+            string,n1,n2,n3,n4
+       print *, 'program terminated by assert_eq4'
+       stop 1
+    end if
+  END FUNCTION assert_eq4
+  !BL
+  FUNCTION assert_eqn(nn,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    INTEGER, DIMENSION(:), INTENT(IN) :: nn
+    INTEGER  assert_eqn
+    if (all(nn(2:) == nn(1))) then
+       assert_eqn=nn(1)
+    else
+       write (*,*) 'nrerror: an assert_eq failed with this tag: ', &
+            string
+       print *, 'program terminated by assert_eqn'
+       stop 1
+    end if
+  END FUNCTION assert_eqn
+
+END MODULE assert_eq_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/assert_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/assert_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/assert_m.F90	(revision 17)
@@ -0,0 +1,69 @@
+! $Id$
+MODULE assert_m
+
+  implicit none
+
+  INTERFACE assert
+     MODULE PROCEDURE assert1,assert2,assert3,assert4,assert_v
+  END INTERFACE
+
+  private assert1,assert2,assert3,assert4,assert_v
+
+CONTAINS
+
+  SUBROUTINE assert1(n1,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, INTENT(IN) :: n1
+    if (.not. n1) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert1'
+       stop 1
+    end if
+  END SUBROUTINE assert1
+  !BL
+  SUBROUTINE assert2(n1,n2,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, INTENT(IN) :: n1,n2
+    if (.not. (n1 .and. n2)) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert2'
+       stop 1
+    end if
+  END SUBROUTINE assert2
+  !BL
+  SUBROUTINE assert3(n1,n2,n3,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, INTENT(IN) :: n1,n2,n3
+    if (.not. (n1 .and. n2 .and. n3)) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert3'
+       stop 1
+    end if
+  END SUBROUTINE assert3
+  !BL
+  SUBROUTINE assert4(n1,n2,n3,n4,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, INTENT(IN) :: n1,n2,n3,n4
+    if (.not. (n1 .and. n2 .and. n3 .and. n4)) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert4'
+       stop 1
+    end if
+  END SUBROUTINE assert4
+  !BL
+  SUBROUTINE assert_v(n,string)
+    CHARACTER(LEN=*), INTENT(IN) :: string
+    LOGICAL, DIMENSION(:), INTENT(IN) :: n
+    if (.not. all(n)) then
+       write (*,*) 'nrerror: an assertion failed with this tag:', &
+            string
+       print *, 'program terminated by assert_v'
+       stop 1
+    end if
+  END SUBROUTINE assert_v
+
+END MODULE assert_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/atm2geo.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/atm2geo.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/atm2geo.F90	(revision 17)
@@ -0,0 +1,48 @@
+!
+! $Header$
+!
+SUBROUTINE atm2geo ( im, jm, pte, ptn, plon, plat, pxx, pyy, pzz )
+  USE dimphy
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+  INCLUDE 'dimensions.h'
+  INCLUDE 'YOMCST.h'
+!
+! Change wind local atmospheric coordinates to geocentric
+!
+  INTEGER, INTENT (in)                 :: im, jm
+  REAL, DIMENSION (im,jm), INTENT (in) :: pte, ptn
+  REAL, DIMENSION (im,jm), INTENT (in) :: plon, plat
+  REAL, DIMENSION (im,jm), INTENT(out) :: pxx, pyy, pzz
+  
+  REAL :: rad
+
+
+  rad = rpi / 180.0E0
+  
+  pxx(:,:) = & 
+       - pte(:,:) * SIN(rad * plon(:,:)) &
+       - ptn(:,:) * SIN(rad * plat(:,:)) * COS(rad * plon(:,:))
+
+  pyy(:,:) = &
+       + pte(:,:) * COS(rad * plon(:,:)) &
+       - ptn(:,:) * SIN(rad * plat(:,:)) * SIN(rad * plon(:,:))
+  
+  pzz(:,:) = &
+       + ptn(:,:) * COS(rad * plat (:,:))
+  
+! Value at North Pole  
+  IF (is_north_pole) THEN
+     pxx(:, 1) = - pte (1, 1)
+     pyy(:, 1) = - ptn (1, 1) 
+     pzz(:, 1) = pzz(1,1)
+  ENDIF
+
+! Value at South Pole
+  IF (is_south_pole) THEN
+     pxx(:,jm) = pxx(1,jm)
+     pyy(:,jm) = pyy(1,jm)
+     pzz(:,jm) = pzz(1,jm)
+  ENDIF
+  
+END SUBROUTINE atm2geo
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/calbeta.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/calbeta.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/calbeta.F90	(revision 17)
@@ -0,0 +1,102 @@
+!
+! $Header$
+!
+SUBROUTINE calbeta(dtime,indice,knon,snow,qsol, &
+     vbeta,vcal,vdif)
+
+  USE dimphy
+  USE indice_sol_mod
+  IMPLICIT none
+!======================================================================
+! Auteur(s): Z.X. Li (LMD/CNRS) (adaptation du GCM au LMD)
+! date: 19940414
+!======================================================================
+!
+! Calculer quelques parametres pour appliquer la couche limite
+! ------------------------------------------------------------ 
+! Variables d'entrees
+!****************************************************************************************
+  REAL, INTENT(IN)                   :: dtime
+  INTEGER, INTENT(IN)                :: indice
+  INTEGER, INTENT(IN)                :: knon
+  REAL, DIMENSION(klon), INTENT(IN)  :: snow
+  REAL, DIMENSION(klon), INTENT(IN)  :: qsol
+
+  
+! Variables de sorties
+!****************************************************************************************
+  REAL, DIMENSION(klon), INTENT(OUT) :: vbeta
+  REAL, DIMENSION(klon), INTENT(OUT) :: vcal
+  REAL, DIMENSION(klon), INTENT(OUT) :: vdif
+
+! Variables locales
+!****************************************************************************************
+  REAL, PARAMETER :: tau_gl=86400.0*5.0 ! temps de relaxation pour la glace de mer
+!cc      PARAMETER (tau_gl=86400.0*30.0)
+  REAL, PARAMETER :: mx_eau_sol=150.0
+  REAL, PARAMETER :: calsol=1.0/(2.5578E+06*0.15)
+  REAL, PARAMETER :: calsno=1.0/(2.3867E+06*0.15)
+  REAL, PARAMETER :: calice=1.0/(5.1444E+06*0.15)
+  
+  INTEGER         :: i
+
+!****************************************************************************************  
+   
+  vbeta(:) = 0.0
+  vcal(:) = 0.0
+  vdif(:) = 0.0
+  
+  IF (indice.EQ.is_oce) THEN
+     DO i = 1, knon
+        vcal(i)   = 0.0
+        vbeta(i)  = 1.0
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_sic) THEN
+     DO i = 1, knon
+        vcal(i) = calice
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = 1.0
+        vdif(i) = 1.0/tau_gl
+!          vdif(i) = calice/tau_gl ! c'etait une erreur
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_ter) THEN
+     DO i = 1, knon
+        vcal(i) = calsol
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = MIN(2.0*qsol(i)/mx_eau_sol, 1.0)
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+  IF (indice.EQ.is_lic) THEN
+     DO i = 1, knon
+        vcal(i) = calice
+        IF (snow(i) .GT. 0.0) vcal(i) = calsno
+        vbeta(i)  = 1.0
+        vdif(i) = 0.0
+     ENDDO
+  ENDIF
+  
+END SUBROUTINE calbeta
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/calbeta_clim.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/calbeta_clim.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/calbeta_clim.F90	(revision 17)
@@ -0,0 +1,67 @@
+!
+! $Header: /home/cvsroot/LMDZ4/libf/phylmd/calbeta.F90,v 1.2 2007/06/22 12:49:51
+! fairhead Exp $
+!
+
+SUBROUTINE calbeta_clim(klon,time,lat_radian,beta)
+ 
+!======================================================================
+! Auteur(s): A.K. TRAORE
+!======================================================================
+!USE phys_local_var_mod, ONLY : ideal_beta !pour faire la variable dans le
+! physiq.f pour des sorties directes de beta
+!==============================================
+
+implicit none
+integer klon,nt,j,it
+real logbeta(klon),pi
+real lat(klon),lat_radian(klon)
+integer time
+real time_radian
+real lat_sahel,beta(klon)
+real lat_nord,lat_sud
+!==============================================
+
+pi=2.*asin(1.)
+beta=0.
+    
+            !calcul des cordonnees
+
+!  print*,'LATITUDES BETA ',lat_radian
+   time_radian=(time+15.)*2.*pi/360.
+
+   print*,'BETA time_radian',time_radian,time
+
+   lat(:)=180.*lat_radian(:)/pi !lat(:)=lat_radian(:)
+        
+   lat_sahel=-5*sin(time_radian)+13
+   lat_nord=lat_sahel+25.
+   lat_sud=lat_sahel-25.
+do j=1,klon
+    !===========
+        if (lat(j) < 5. ) then
+                
+                logbeta(j)=0.2*(lat(j)-lat_sud)-1.6
+                beta(j)=10**(logbeta(j))
+                beta(j)=max(beta(j),0.03)
+                beta(j)=min(beta(j),0.22)
+!              print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j)
+    !===========
+        elseif (lat(j) < 22.) then !lat(j)<22.
+                
+                logbeta(j)=-0.25*(lat(j)-lat_sahel)-1.6
+                beta(j)=10**(logbeta(j))
+                beta(j)=max(beta(j),1.e-2)
+                beta(j)=min(beta(j),0.22)
+!              print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j)
+    !===========
+        else
+              logbeta(j)=0.25*(lat(j)-lat_nord)-1.
+              beta(j)=10**(logbeta(j))
+              beta(j)=max(beta(j),1.e-2)
+              beta(j)=min(beta(j),0.25)
+!              print*,'j,lat,lat_radian,beta',j,lat(j),lat_radian(j),beta(j)
+        endif
+    !===========
+enddo
+end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/calcratqs.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/calcratqs.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/calcratqs.F90	(revision 17)
@@ -0,0 +1,185 @@
+SUBROUTINE calcratqs(klon,klev,prt_level,lunout,       &
+           iflag_ratqs,iflag_con,iflag_cldcon,pdtphys, &
+           ratqsbas,ratqshaut,tau_ratqs,fact_cldcon,   &
+           ptconv,ptconvth,clwcon0th, rnebcon0th,      &
+           paprs,pplay,q_seri,zqsat,fm_therm,          &
+           ratqs,ratqsc)
+
+implicit none
+
+!========================================================================
+! Computation of ratqs, the width of the subrid scale water distribution
+! (normalized by the mean value)
+! Various options controled by flags iflag_con and iflag_ratqs
+! F Hourdin 2012/12/06
+!========================================================================
+
+! Declarations
+
+! Input
+integer,intent(in) :: klon,klev,prt_level,lunout
+integer,intent(in) :: iflag_con,iflag_cldcon,iflag_ratqs
+real,intent(in) :: pdtphys,ratqsbas,ratqshaut,fact_cldcon,tau_ratqs
+real, dimension(klon,klev+1),intent(in) :: paprs
+real, dimension(klon,klev),intent(in) :: pplay,q_seri,zqsat,fm_therm
+logical, dimension(klon,klev),intent(in) :: ptconv
+real, dimension(klon,klev),intent(in) :: rnebcon0th,clwcon0th
+
+! Output
+real, dimension(klon,klev),intent(inout) :: ratqs,ratqsc
+logical, dimension(klon,klev),intent(inout) :: ptconvth
+
+! local
+integer i,k
+real, dimension(klon,klev) :: ratqss
+real facteur,zfratqs1,zfratqs2
+
+!-------------------------------------------------------------------------
+!  Caclul des ratqs
+!-------------------------------------------------------------------------
+
+!      print*,'calcul des ratqs'
+!   ratqs convectifs a l'ancienne en fonction de q(z=0)-q / q
+!   ----------------
+!   on ecrase le tableau ratqsc calcule par clouds_gno
+      if (iflag_cldcon.eq.1) then
+         do k=1,klev
+         do i=1,klon
+            if(ptconv(i,k)) then
+              ratqsc(i,k)=ratqsbas &
+              +fact_cldcon*(q_seri(i,1)-q_seri(i,k))/q_seri(i,k)
+            else
+               ratqsc(i,k)=0.
+            endif
+         enddo
+         enddo
+
+!-----------------------------------------------------------------------
+!  par nversion de la fonction log normale
+!-----------------------------------------------------------------------
+      else if (iflag_cldcon.eq.4) then
+         ptconvth(:,:)=.false.
+         ratqsc(:,:)=0.
+         if(prt_level.ge.9) print*,'avant clouds_gno thermique'
+         call clouds_gno &
+         (klon,klev,q_seri,zqsat,clwcon0th,ptconvth,ratqsc,rnebcon0th)
+         if(prt_level.ge.9) print*,' CLOUDS_GNO OK'
+       
+       endif
+
+!   ratqs stables
+!   -------------
+
+      if (iflag_ratqs.eq.0) then
+
+! Le cas iflag_ratqs=0 correspond a la version IPCC 2005 du modele.
+         do k=1,klev
+            do i=1, klon
+               ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)* &
+               min((paprs(i,1)-pplay(i,k))/(paprs(i,1)-30000.),1.) 
+            enddo 
+         enddo
+
+! Pour iflag_ratqs=1 ou 2, le ratqs est constant au dessus de 
+! 300 hPa (ratqshaut), varie lineariement en fonction de la pression
+! entre 600 et 300 hPa et est soit constant (ratqsbas) pour iflag_ratqs=1
+! soit lineaire (entre 0 a la surface et ratqsbas) pour iflag_ratqs=2
+! Il s'agit de differents tests dans la phase de reglage du modele
+! avec thermiques.
+
+      else if (iflag_ratqs.eq.1) then
+
+         do k=1,klev
+            do i=1, klon
+               if (pplay(i,k).ge.60000.) then
+                  ratqss(i,k)=ratqsbas
+               else if ((pplay(i,k).ge.30000.).and.(pplay(i,k).lt.60000.)) then
+                  ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*(60000.-pplay(i,k))/(60000.-30000.)
+               else
+                  ratqss(i,k)=ratqshaut
+               endif
+            enddo
+         enddo
+
+      else if (iflag_ratqs.eq.2) then
+
+         do k=1,klev
+            do i=1, klon
+               if (pplay(i,k).ge.60000.) then
+                  ratqss(i,k)=ratqsbas*(paprs(i,1)-pplay(i,k))/(paprs(i,1)-60000.)
+               else if ((pplay(i,k).ge.30000.).and.(pplay(i,k).lt.60000.)) then
+                    ratqss(i,k)=ratqsbas+(ratqshaut-ratqsbas)*(60000.-pplay(i,k))/(60000.-30000.)
+               else
+                    ratqss(i,k)=ratqshaut
+               endif
+            enddo
+         enddo
+
+      else if (iflag_ratqs==3) then
+         do k=1,klev
+           ratqss(:,k)=ratqsbas+(ratqshaut-ratqsbas) &
+           *min( ((paprs(:,1)-pplay(:,k))/70000.)**2 , 1. )
+         enddo
+
+      else if (iflag_ratqs==4) then
+         do k=1,klev
+           ratqss(:,k)=ratqsbas+0.5*(ratqshaut-ratqsbas) &
+           *( tanh( (50000.-pplay(:,k))/20000.) + 1.)
+         enddo
+
+      endif
+
+
+
+
+!  ratqs final
+!  -----------
+
+      if (iflag_cldcon.eq.1 .or.iflag_cldcon.eq.2.or.iflag_cldcon.eq.4) then
+
+! On ajoute une constante au ratqsc*2 pour tenir compte de 
+! fluctuations turbulentes de petite echelle
+
+         do k=1,klev
+            do i=1,klon
+               if ((fm_therm(i,k).gt.1.e-10)) then
+                  ratqsc(i,k)=sqrt(ratqsc(i,k)**2+0.05**2)
+               endif
+            enddo
+         enddo
+
+!   les ratqs sont une combinaison de ratqss et ratqsc
+       if(prt_level.ge.9) write(lunout,*)'PHYLMD NOUVEAU TAU_RATQS ',tau_ratqs
+
+         if (tau_ratqs>1.e-10) then
+            facteur=exp(-pdtphys/tau_ratqs)
+         else
+            facteur=0.
+         endif
+         ratqs(:,:)=ratqsc(:,:)*(1.-facteur)+ratqs(:,:)*facteur
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 22/09/2009
+! La ligne ci-dessous faisait osciller le modele et donnait une solution
+! assymptotique bidon et dÃ©pendant fortement du pas de temps.
+!        ratqs(:,:)=sqrt(ratqs(:,:)**2+ratqss(:,:)**2)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+         ratqs(:,:)=max(ratqs(:,:),ratqss(:,:))
+      else if (iflag_cldcon<=6) then
+!   on ne prend que le ratqs stable pour fisrtilp
+         ratqs(:,:)=ratqss(:,:)
+      else
+          zfratqs1=exp(-pdtphys/10800.)
+          zfratqs2=exp(-pdtphys/10800.)
+          do k=1,klev
+             do i=1,klon
+                if (ratqsc(i,k).gt.1.e-10) then
+                   ratqs(i,k)=ratqs(i,k)*zfratqs2+(iflag_cldcon/100.)*ratqsc(i,k)*(1.-zfratqs2)
+                endif
+                ratqs(i,k)=min(ratqs(i,k)*zfratqs1+ratqss(i,k)*(1.-zfratqs1),0.5)
+             enddo
+          enddo
+      endif
+
+
+return
+end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/calcul_STDlev.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/calcul_STDlev.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/calcul_STDlev.h	(revision 17)
@@ -0,0 +1,243 @@
+!c
+!c $Header$
+!c
+!cIM on initialise les variables 
+!c
+        missing_val=nf90_fill_real
+!c
+!cIM freq_moyNMC = frequences auxquelles on moyenne les champs accumules 
+!cIM               sur les niveaux de pression standard du NMC
+      DO n=1, nout
+       freq_moyNMC(n)=freq_outNMC(n)/freq_calNMC(n)
+      ENDDO
+!c
+        CALL ini_undefSTD(itap,freq_outNMC)
+!c
+!cIM on interpole les champs sur les niveaux STD de pression 
+!cIM a chaque pas de temps de la physique
+!c
+!c-------------------------------------------------------c
+!c positionnement de l'argument logique a .false.        c
+!c pour ne pas recalculer deux fois la meme chose !      c
+!c a cet effet un appel a plevel_new a ete deplace       c
+!c a la fin de la serie d'appels                         c
+!c la boucle 'DO k=1, nlevSTD' a ete internalisee        c
+!c dans plevel_new, d'ou la creation de cette routine... c
+!c-------------------------------------------------------c
+!c
+        CALL plevel_new(klon,klev,nlevSTD,.true.,pplay,rlevSTD,                      &
+       &              t_seri,tlevSTD)
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             u_seri,ulevSTD)
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             v_seri,vlevSTD)
+!c
+
+!c
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             zphi/RG,philevSTD)
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             qx(:,:,ivap),qlevSTD)
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             zx_rh*100.,rhlevSTD)
+!c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=u_seri(i,l)*v_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             zx_tmp_fi3d,uvSTD)
+!c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*q_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             zx_tmp_fi3d,vqSTD)
+!c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*t_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             zx_tmp_fi3d,vTSTD)
+!c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=omega(i,l)*qx(i,l,ivap)
+         ENDDO !i 
+        ENDDO !l
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             zx_tmp_fi3d,wqSTD)
+!c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*zphi(i,l)/RG
+         ENDDO !i
+        ENDDO !l
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             zx_tmp_fi3d,vphiSTD)
+!c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=omega(i,l)*t_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             zx_tmp_fi3d,wTSTD)
+!c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=u_seri(i,l)*u_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             zx_tmp_fi3d,u2STD)
+!c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=v_seri(i,l)*v_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             zx_tmp_fi3d,v2STD)
+!c
+        DO l=1, klev
+         DO i=1, klon
+          zx_tmp_fi3d(i,l)=t_seri(i,l)*t_seri(i,l)
+         ENDDO !i
+        ENDDO !l
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             zx_tmp_fi3d,T2STD)
+
+!c
+      zx_tmp_fi3d(:,:)=wo(:,:,1) * dobson_u * 1e3 / zmasse / rmo3 * rmd
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             zx_tmp_fi3d,O3STD)
+!c
+      if (read_climoz == 2) THEN
+      zx_tmp_fi3d(:,:)=wo(:,:,2) * dobson_u * 1e3 / zmasse / rmo3 * rmd
+        CALL plevel_new(klon,klev,nlevSTD,.false.,pplay,rlevSTD,                     &
+       &             zx_tmp_fi3d,O3daySTD)
+      endif
+!c
+        DO l=1, klev
+        DO i=1, klon
+         zx_tmp_fi3d(i,l)=paprs(i,l)
+        ENDDO !i
+        ENDDO !l
+        CALL plevel_new(klon,klev,nlevSTD,.true.,zx_tmp_fi3d,rlevSTD,                &
+       &             omega,wlevSTD)
+!c
+!cIM on somme les valeurs toutes les freq_calNMC secondes
+!c
+       CALL undefSTD(itap,freq_calNMC, read_climoz)
+!c
+!cIM on moyenne a la fin du mois ou du jour (toutes les freq_outNMC secondes)
+!c
+       CALL moy_undefSTD(itap,freq_outNMC,freq_moyNMC)
+!c
+       CALL plevel(klon,klev,.true.,pplay,50000.,                                    &
+       &              zphi/RG,geo500)
+
+!cIM on interpole a chaque pas de temps le SWup(clr) et SWdn(clr) a 200 hPa
+!c
+      CALL plevel(klon,klevp1,.true.,paprs,20000.,                                   &
+       &     swdn0,SWdn200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,                                  &
+       &     swdn,SWdn200)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,                                  &
+       &     swup0,SWup200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,                                  &
+       &     swup,SWup200)
+!c
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,                                  &
+       &     lwdn0,LWdn200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,                                  &
+       &     lwdn,LWdn200)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,                                  &
+       &     lwup0,LWup200clr)
+      CALL plevel(klon,klevp1,.false.,paprs,20000.,                                  &
+       &     lwup,LWup200)
+!c
+      twriteSTD(:,:,1)=tsumSTD(:,:,1)
+      qwriteSTD(:,:,1)=qsumSTD(:,:,1)
+      rhwriteSTD(:,:,1)=rhsumSTD(:,:,1)
+      phiwriteSTD(:,:,1)=phisumSTD(:,:,1)
+      uwriteSTD(:,:,1)=usumSTD(:,:,1)
+      vwriteSTD(:,:,1)=vsumSTD(:,:,1)
+      wwriteSTD(:,:,1)=wsumSTD(:,:,1)
+
+      twriteSTD(:,:,2)=tsumSTD(:,:,2)
+      qwriteSTD(:,:,2)=qsumSTD(:,:,2)
+      rhwriteSTD(:,:,2)=rhsumSTD(:,:,2)
+      phiwriteSTD(:,:,2)=phisumSTD(:,:,2)
+      uwriteSTD(:,:,2)=usumSTD(:,:,2)
+      vwriteSTD(:,:,2)=vsumSTD(:,:,2)
+      wwriteSTD(:,:,2)=wsumSTD(:,:,2)
+
+      twriteSTD(:,:,3)=tlevSTD(:,:)
+      qwriteSTD(:,:,3)=qlevSTD(:,:)
+      rhwriteSTD(:,:,3)=rhlevSTD(:,:)
+      phiwriteSTD(:,:,3)=philevSTD(:,:)
+      uwriteSTD(:,:,3)=ulevSTD(:,:)
+      vwriteSTD(:,:,3)=vlevSTD(:,:)
+      wwriteSTD(:,:,3)=wlevSTD(:,:)
+
+      twriteSTD(:,:,4)=tlevSTD(:,:)
+      qwriteSTD(:,:,4)=qlevSTD(:,:)
+      rhwriteSTD(:,:,4)=rhlevSTD(:,:)
+      phiwriteSTD(:,:,4)=philevSTD(:,:)
+      uwriteSTD(:,:,4)=ulevSTD(:,:)
+      vwriteSTD(:,:,4)=vlevSTD(:,:)
+      wwriteSTD(:,:,4)=wlevSTD(:,:)
+!c
+!cIM initialisation 5eme fichier de sortie 
+      twriteSTD(:,:,5)=tlevSTD(:,:)
+      qwriteSTD(:,:,5)=qlevSTD(:,:)
+      rhwriteSTD(:,:,5)=rhlevSTD(:,:)
+      phiwriteSTD(:,:,5)=philevSTD(:,:)
+      uwriteSTD(:,:,5)=ulevSTD(:,:)
+      vwriteSTD(:,:,5)=vlevSTD(:,:)
+      wwriteSTD(:,:,5)=wlevSTD(:,:)
+!c
+!cIM initialisation 6eme fichier de sortie 
+      twriteSTD(:,:,6)=tlevSTD(:,:)
+      qwriteSTD(:,:,6)=qlevSTD(:,:)
+      rhwriteSTD(:,:,6)=rhlevSTD(:,:)
+      phiwriteSTD(:,:,6)=philevSTD(:,:)
+      uwriteSTD(:,:,6)=ulevSTD(:,:)
+      vwriteSTD(:,:,6)=vlevSTD(:,:)
+      wwriteSTD(:,:,6)=wlevSTD(:,:)
+!cIM for NMC files
+      DO n=1, nlevSTD3
+       DO k=1, nlevSTD
+        if(rlevSTD3(n).EQ.rlevSTD(k)) THEN
+         twriteSTD3(:,n)=tlevSTD(:,k)
+         qwriteSTD3(:,n)=qlevSTD(:,k)
+         rhwriteSTD3(:,n)=rhlevSTD(:,k)
+         phiwriteSTD3(:,n)=philevSTD(:,k)
+         uwriteSTD3(:,n)=ulevSTD(:,k)
+         vwriteSTD3(:,n)=vlevSTD(:,k)
+         wwriteSTD3(:,n)=wlevSTD(:,k)
+        endif !rlevSTD3(n).EQ.rlevSTD(k)
+       ENDDO 
+      ENDDO 
+!c
+      DO n=1, nlevSTD8
+       DO k=1, nlevSTD
+        if(rlevSTD8(n).EQ.rlevSTD(k)) THEN
+         tnondefSTD8(:,n)=tnondef(:,k,2)
+         twriteSTD8(:,n)=tsumSTD(:,k,2)
+         qwriteSTD8(:,n)=qsumSTD(:,k,2)
+         rhwriteSTD8(:,n)=rhsumSTD(:,k,2)
+         phiwriteSTD8(:,n)=phisumSTD(:,k,2)
+         uwriteSTD8(:,n)=usumSTD(:,k,2)
+         vwriteSTD8(:,n)=vsumSTD(:,k,2)
+         wwriteSTD8(:,n)=wsumSTD(:,k,2)
+        endif !rlevSTD8(n).EQ.rlevSTD(k)
+       ENDDO 
+      ENDDO
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/calcul_divers.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/calcul_divers.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/calcul_divers.h	(revision 17)
@@ -0,0 +1,24 @@
+!c
+!c $Header$
+!c
+
+!c     Initialisations diverses au "debut" du mois
+      IF(debut) THEN
+         nday_rain(:)=0.
+
+!c        surface terre
+         paire_ter(:)=0.
+         DO i=1, klon
+            IF(pctsrf(i,is_ter).GT.0.) THEN
+               paire_ter(i)=airephy(i)*pctsrf(i,is_ter)
+            ENDIF 
+         ENDDO
+      ENDIF
+
+!cIM   Calcul une fois par jour : total_rain, nday_rain
+      IF(MOD(itap,INT(un_jour/dtime)).EQ.0) THEN
+         DO i = 1, klon
+            total_rain(i)=rain_fall(i)+snow_fall(i)  
+            IF(total_rain(i).GT.0.) nday_rain(i)=nday_rain(i)+1.
+         ENDDO
+      ENDIF
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/calcul_fluxs_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/calcul_fluxs_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/calcul_fluxs_mod.F90	(revision 17)
@@ -0,0 +1,307 @@
+!
+MODULE calcul_fluxs_mod
+
+
+CONTAINS
+  SUBROUTINE calcul_fluxs( knon, nisurf, dtime, &
+       tsurf, p1lay, cal, beta, coef1lay, ps, &
+       precip_rain, precip_snow, snow, qsurf, &
+       radsol, dif_grnd, t1lay, q1lay, u1lay, v1lay, &
+       petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+    USE dimphy, ONLY : klon
+    USE indice_sol_mod
+
+! Cette routine calcule les fluxs en h et q a l'interface et eventuellement
+! une temperature de surface (au cas ou ok_veget = false)
+!
+! L. Fairhead 4/2000
+!
+! input:
+!   knon         nombre de points a traiter
+!   nisurf       surface a traiter
+!   tsurf        temperature de surface
+!   p1lay        pression 1er niveau (milieu de couche)
+!   cal          capacite calorifique du sol
+!   beta         evap reelle
+!   coef1lay     coefficient d'echange
+!   ps           pression au sol
+!   precip_rain  precipitations liquides
+!   precip_snow  precipitations solides
+!   snow         champs hauteur de neige
+!   runoff       runoff en cas de trop plein
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   radsol       rayonnement net aus sol (LW + SW)
+!   dif_grnd     coeff. diffusion vers le sol profond
+!
+! output:
+!   tsurf_new    temperature au sol
+!   qsurf        humidite de l'air au dessus du sol
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   dflux_s      derivee du flux de chaleur sensible / Ts
+!   dflux_l      derivee du flux de chaleur latente  / Ts
+!
+
+    INCLUDE "YOETHF.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "YOMCST.h"
+
+! Parametres d'entree
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon, nisurf
+    REAL   , INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps, q1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf, p1lay, cal, beta, coef1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow ! pas utiles
+    REAL, DIMENSION(klon), INTENT(IN)    :: radsol, dif_grnd
+    REAL, DIMENSION(klon), INTENT(IN)    :: t1lay, u1lay, v1lay
+
+! Parametres entree-sorties
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow  ! snow pas utile
+
+! Parametres sorties
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)   :: tsurf_new, evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)   :: dflux_s, dflux_l
+
+! Variables locales
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL, DIMENSION(klon)                :: zx_mh, zx_nh, zx_oh
+    REAL, DIMENSION(klon)                :: zx_mq, zx_nq, zx_oq
+    REAL, DIMENSION(klon)                :: zx_pkh, zx_dq_s_dt, zx_qsat, zx_coef
+    REAL, DIMENSION(klon)                :: zx_sl, zx_k1
+    REAL, DIMENSION(klon)                :: d_ts
+    REAL                                 :: zdelta, zcvm5, zx_qs, zcor, zx_dq_s_dh
+    REAL                                 :: qsat_new, q1_new
+    REAL, PARAMETER                      :: t_grnd = 271.35, t_coup = 273.15
+    REAL, PARAMETER                      :: max_eau_sol = 150.0
+    CHARACTER (len = 20)                 :: modname = 'calcul_fluxs'
+    LOGICAL                              :: fonte_neige
+    LOGICAL, SAVE                        :: check = .FALSE.
+    !$OMP THREADPRIVATE(check)
+
+! End definition
+!****************************************************************************************
+!Lluis
+    INTEGER                                              :: lpt
+    lpt = 550
+
+    IF (nisurf == 3) THEN
+      PRINT *,'  Lluis in calcul_fluxs________________________'
+      PRINT *,'    knon: ',knon,' nisurf:' , nisurf, ' dtime: ',dtime
+      PRINT *,'    tsurf: ',tsurf(lpt),' p1lay: ', p1lay(lpt),' cal: ',cal(lpt),' beta: ', beta(lpt) 
+      PRINT *,'    coef1lay: ', coef1lay(lpt),' ps: ', ps(lpt)
+      PRINT *,'    p_rain: ',precip_rain(lpt),' p_snow: ', precip_snow(lpt),' snow: ', snow(lpt)
+      PRINT *,'    qsurf: ', qsurf(lpt)
+      PRINT *,'    radsol: ',radsol(lpt),' dif_grnd: ', dif_grnd(lpt),' t1lay: ', t1lay(lpt)
+      PRINT *,'    q1lay: ', q1lay(lpt),' u1lay: ', u1lay(lpt),' v1lay: ', v1lay(lpt)
+      PRINT *,'    ptAcoef: ', petAcoef(lpt),' peqAcoef: ', peqAcoef(lpt)
+      PRINT *,'    pteBcoef: ', petBcoef(lpt),' peqBcoef: ', peqBcoef(lpt)
+      PRINT *,'    tsurf_new: ', tsurf_new(lpt), ' evap: ',evap(lpt),' fluxlat: ',fluxlat(lpt)
+      PRINT *,'    fluxsens: ', fluxsens(lpt),' dflux_s: ', dflux_s(lpt),' dflux_l: ', dflux_l(lpt)
+    END IF
+
+    IF (check) WRITE(*,*)'Entree ', modname,' surface = ',nisurf
+    
+    IF (check) THEN
+       WRITE(*,*)' radsol (min, max)', &
+            MINVAL(radsol(1:knon)), MAXVAL(radsol(1:knon))
+    ENDIF
+  
+! Traitement neige et humidite du sol
+!****************************************************************************************
+!
+!!$  WRITE(*,*)'test calcul_flux, surface ', nisurf
+!!PB test
+!!$    if (nisurf == is_oce) then
+!!$      snow = 0.
+!!$      qsol = max_eau_sol
+!!$    else
+!!$      where (precip_snow > 0.) snow = snow + (precip_snow * dtime)
+!!$      where (snow > epsilon(snow)) snow = max(0.0, snow - (evap * dtime))
+!!$!      snow = max(0.0, snow + (precip_snow - evap) * dtime)
+!!$      where (precip_rain > 0.) qsol = qsol + (precip_rain - evap) * dtime
+!!$    endif 
+!!$    IF (nisurf /= is_ter) qsol = max_eau_sol
+
+
+! 
+! Initialisation
+!****************************************************************************************
+    evap = 0.
+    fluxsens=0.
+    fluxlat=0.
+    dflux_s = 0.
+    dflux_l = 0.	
+!
+! zx_qs = qsat en kg/kg
+!****************************************************************************************
+    DO i = 1, knon
+       zx_pkh(i) = (ps(i)/ps(i))**RKAPPA
+       IF (thermcep) THEN
+          zdelta=MAX(0.,SIGN(1.,rtt-tsurf(i)))
+          zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+          zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q1lay(i))
+          zx_qs= r2es * FOEEW(tsurf(i),zdelta)/ps(i)
+          zx_qs=MIN(0.5,zx_qs)
+          zcor=1./(1.-retv*zx_qs)
+          zx_qs=zx_qs*zcor
+          zx_dq_s_dh = FOEDE(tsurf(i),zdelta,zcvm5,zx_qs,zcor) &
+               /RLVTT / zx_pkh(i)
+       ELSE
+          IF (tsurf(i).LT.t_coup) THEN
+             zx_qs = qsats(tsurf(i)) / ps(i)
+             zx_dq_s_dh = dqsats(tsurf(i),zx_qs)/RLVTT &
+                  / zx_pkh(i)
+          ELSE
+             zx_qs = qsatl(tsurf(i)) / ps(i)
+             zx_dq_s_dh = dqsatl(tsurf(i),zx_qs)/RLVTT &
+                  / zx_pkh(i)
+          ENDIF
+       ENDIF
+       zx_dq_s_dt(i) = RCPD * zx_pkh(i) * zx_dq_s_dh
+       zx_qsat(i) = zx_qs
+       zx_coef(i) = coef1lay(i) * &
+            (1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) * &
+            p1lay(i)/(RD*t1lay(i))
+       
+    ENDDO
+
+
+! === Calcul de la temperature de surface ===
+! zx_sl = chaleur latente d'evaporation ou de sublimation
+!****************************************************************************************
+
+    DO i = 1, knon
+       zx_sl(i) = RLVTT
+       IF (tsurf(i) .LT. RTT) zx_sl(i) = RLSTT
+       zx_k1(i) = zx_coef(i)
+    ENDDO
+    
+
+    DO i = 1, knon
+! Q
+       zx_oq(i) = 1. - (beta(i) * zx_k1(i) * peqBcoef(i) * dtime)
+       zx_mq(i) = beta(i) * zx_k1(i) * &
+            (peqAcoef(i) - zx_qsat(i) + &
+            zx_dq_s_dt(i) * tsurf(i)) &
+            / zx_oq(i)
+       zx_nq(i) = beta(i) * zx_k1(i) * (-1. * zx_dq_s_dt(i)) &
+            / zx_oq(i)
+       
+! H
+       zx_oh(i) = 1. - (zx_k1(i) * petBcoef(i) * dtime)
+       zx_mh(i) = zx_k1(i) * petAcoef(i) / zx_oh(i)
+       zx_nh(i) = - (zx_k1(i) * RCPD * zx_pkh(i))/ zx_oh(i)
+     
+! Tsurface
+       tsurf_new(i) = (tsurf(i) + cal(i)/(RCPD * zx_pkh(i)) * dtime * &
+            (radsol(i) + zx_mh(i) + zx_sl(i) * zx_mq(i)) & 
+            + dif_grnd(i) * t_grnd * dtime)/ &
+            ( 1. - dtime * cal(i)/(RCPD * zx_pkh(i)) * ( &
+            zx_nh(i) + zx_sl(i) * zx_nq(i)) &  
+            + dtime * dif_grnd(i))
+
+!
+! Y'a-t-il fonte de neige?
+!
+!    fonte_neige = (nisurf /= is_oce) .AND. &
+!     & (snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
+!     & .AND. (tsurf_new(i) >= RTT)
+!    if (fonte_neige) tsurf_new(i) = RTT  
+       d_ts(i) = tsurf_new(i) - tsurf(i)
+!    zx_h_ts(i) = tsurf_new(i) * RCPD * zx_pkh(i)
+!    zx_q_0(i) = zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+
+!== flux_q est le flux de vapeur d'eau: kg/(m**2 s)  positive vers bas
+!== flux_t est le flux de cpt (energie sensible): j/(m**2 s)
+       evap(i) = - zx_mq(i) - zx_nq(i) * tsurf_new(i) 
+       fluxlat(i) = - evap(i) * zx_sl(i)
+       fluxsens(i) = zx_mh(i) + zx_nh(i) * tsurf_new(i)
+       
+! Derives des flux dF/dTs (W m-2 K-1):
+       dflux_s(i) = zx_nh(i)
+       dflux_l(i) = (zx_sl(i) * zx_nq(i))
+
+! Nouvelle valeure de l'humidite au dessus du sol
+       qsat_new=zx_qsat(i) + zx_dq_s_dt(i) * d_ts(i)
+       q1_new = peqAcoef(i) - peqBcoef(i)*evap(i)*dtime
+       qsurf(i)=q1_new*(1.-beta(i)) + beta(i)*qsat_new
+!
+! en cas de fonte de neige
+!
+!    if (fonte_neige) then
+!      bilan_f = radsol(i) + fluxsens(i) - (zx_sl(i) * evap (i)) - &
+!     &          dif_grnd(i) * (tsurf_new(i) - t_grnd) - &
+!     &          RCPD * (zx_pkh(i))/cal(i)/dtime * (tsurf_new(i) - tsurf(i))
+!      bilan_f = max(0., bilan_f)
+!      fq_fonte = bilan_f / zx_sl(i)
+!      snow(i) = max(0., snow(i) - fq_fonte * dtime)
+!      qsol(i) = qsol(i) + (fq_fonte * dtime)
+!    endif
+!!$    if (nisurf == is_ter)  &
+!!$     &  run_off(i) = run_off(i) + max(qsol(i) - max_eau_sol, 0.0)
+!!$    qsol(i) = min(qsol(i), max_eau_sol) 
+    ENDDO
+!
+!****************************************************************************************
+!
+  END SUBROUTINE calcul_fluxs
+!
+!****************************************************************************************
+!
+  SUBROUTINE calcul_flux_wind(knon, dtime, &
+       u0, v0, u1, v1, cdrag_m, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       p1lay, t1lay, &
+       flux_u1, flux_v1)
+
+    USE dimphy
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: u0, v0  ! u and v at niveau 0
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1  ! u and v at niveau 1
+    REAL, DIMENSION(klon), INTENT(IN)    :: cdrag_m ! cdrag pour momentum
+    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay   ! pression 1er niveau (milieu de couche)
+    REAL, DIMENSION(klon), INTENT(IN)    :: t1lay   ! temperature 
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_u1
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_v1
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: i
+    REAL                                 :: mod_wind, buf
+
+!****************************************************************************************
+! Calculate the surface flux
+!
+!****************************************************************************************
+    DO i=1,knon
+       mod_wind = 1.0 + SQRT((u1(i) - u0(i))**2 + (v1(i)-v0(i))**2)
+       buf = cdrag_m(i) * mod_wind * p1lay(i)/(RD*t1lay(i))
+       flux_u1(i) = (AcoefU(i) - u0(i)) / (1/buf - BcoefU(i)*dtime )
+       flux_v1(i) = (AcoefV(i) - v0(i)) / (1/buf - BcoefV(i)*dtime )
+    END DO
+
+  END SUBROUTINE calcul_flux_wind
+!
+!****************************************************************************************
+!
+END MODULE calcul_fluxs_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/calcul_simulISCCP.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/calcul_simulISCCP.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/calcul_simulISCCP.h	(revision 17)
@@ -0,0 +1,148 @@
+!c
+!c $Id: calcul_simulISCCP.h 1403 2010-07-01 09:02:53Z fairhead $
+!c
+!c on appelle le simulateur ISCCP toutes les 3h
+!c et on fait des sorties 1 fois par jour 
+!c
+!c ATTENTION : le temps de calcul peut augmenter considerablement !
+!c =============================================================== c
+      DO n=1, napisccp
+!c
+      nbapp_isccp=30 !appel toutes les 15h
+!IM 170107      isccppas=NINT((itap*dtime)/3600.) !Nb. d'heures de la physique
+      freqin_pdt(n)=ifreq_isccp(n)
+!c
+!IM initialisation nbsunlit pour calculs simulateur ISCCP pdt la journee
+!c
+      DO i=1, klon
+       sunlit(i)=1 
+       IF(rmu0(i).EQ.0.) sunlit(i)=0
+       nbsunlit(1,i,n)=REAL(sunlit(i))
+      ENDDO
+!c
+!IM calcul tau, emissivite nuages convectifs
+!c
+      convfra(:,:)=rnebcon(:,:)
+      convliq(:,:)=rnebcon(:,:)*clwcon(:,:)
+!c
+      CALL newmicro (paprs, pplay,ok_newmicro,                                       &
+       &            t_seri, convliq, convfra, dtau_c, dem_c,                         &
+       &            cldh_c, cldl_c, cldm_c, cldt_c, cldq_c,                          &
+       &            flwp_c, fiwp_c, flwc_c, fiwc_c,                                  &
+       &            ok_aie,                                                          &
+       &            mass_solu_aero, mass_solu_aero_pi,                               &
+       &            bl95_b0, bl95_b1,                                                &
+       &            cldtaupi, re, fl)
+!c
+!IM calcul tau, emissivite nuages startiformes
+!c
+      CALL newmicro (paprs, pplay,ok_newmicro,                                       &
+       &            t_seri, cldliq, cldfra, dtau_s, dem_s,                           &
+       &            cldh_s, cldl_s, cldm_s, cldt_s, cldq_s,                          &
+       &            flwp_s, fiwp_s, flwc_s, fiwc_s,                                  &
+       &            ok_aie,                                                          &
+       &            mass_solu_aero, mass_solu_aero_pi,                               &
+       &            bl95_b0, bl95_b1,                                                &
+       &            cldtaupi, re, fl)
+!c
+      cldtot(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
+!c
+!IM inversion des niveaux de pression ==> de haut en bas
+!c
+      CALL haut2bas(klon, klev, pplay, pfull)
+      CALL haut2bas(klon, klev, q_seri, qv)
+      CALL haut2bas(klon, klev, cldtot, cc)
+      CALL haut2bas(klon, klev, rnebcon, conv)
+      CALL haut2bas(klon, klev, dtau_s, dtau_sH2B)
+      CALL haut2bas(klon, klev, dtau_c, dtau_cH2B)
+      CALL haut2bas(klon, klev, t_seri, at)
+      CALL haut2bas(klon, klev, dem_s, dem_sH2B)
+      CALL haut2bas(klon, klev, dem_c, dem_cH2B)
+      CALL haut2bas(klon, klevp1, paprs, phalf)
+!c
+!IM: initialisation de seed
+!c
+        DO i=1, klon
+!c
+         aa=ABS(paprs(i,2)-NINT(paprs(i,2)))
+         seed_re(i,n)=1000.*aa+1.
+         seed(i,n)=NINT(seed_re(i,n))
+!c
+         IF(seed(i,n).LT.50) THEN
+!c          print*,'seed<50 avant i seed itap paprs',i,
+!c    .     seed(i,n),itap,paprs(i,2)
+           seed(i,n)=50+seed(i,n)+i+itap
+           seed_old(i,n)=seed(i,n)
+!c
+           IF(itap.GT.1) then
+            IF(seed(i,n).EQ.seed_old(i,n)) THEN
+             seed(i,n)=seed(i,n)+10
+             seed_old(i,n)=seed(i,n)
+            ENDIF
+           ENDIF
+!c
+!c          print*,'seed<50 apres i seed itap paprs',i,
+!c    .     seed(i,n),itap,paprs(i,2)
+!c
+          ELSE IF(seed(i,n).EQ.0) THEN
+           print*,'seed=0 i paprs aa seed_re',                                       &
+       &     i,paprs(i,2),aa,seed_re(i,n)
+           abort_message = ''
+           CALL abort_gcm (modname,abort_message,1)
+          ELSE IF(seed(i,n).LT.0) THEN
+           print*,'seed < 0, i seed itap paprs',i,                                   &
+       &     seed(i,n),itap,paprs(i,2)
+           abort_message = ''
+           CALL abort_gcm (modname,abort_message,1)
+          ENDIF
+!c
+        ENDDO
+!c     
+!IM: pas de debug, debugcol
+      debug=0
+      debugcol=0
+!c
+!IM o500 ==> distribution nuage ftion du regime dynamique (vit. verticale a 500 hPa)
+!c
+        DO k=1, klevm1
+        kp1=k+1
+!c       PRINT*,'k, presnivs',k,presnivs(k), presnivs(kp1)
+        if(presnivs(k).GT.50000.AND.presnivs(kp1).LT.50000.) THEN
+         DO i=1, klon
+          o500(i)=omega(i,k)*RDAY/100.
+!c         if(i.EQ.1) print*,' 500hPa lev',k,presnivs(k),presnivs(kp1)
+         ENDDO
+         GOTO 1000
+        endif 
+1000  continue
+      ENDDO
+!c
+!IM recalcule les nuages vus par satellite, via le simulateur ISCCP
+!c
+      CALL ISCCP_CLOUD_TYPES(                                                        &
+       &     debug,                                                                  &
+       &     debugcol,                                                               &
+       &     klon,                                                                   &
+       &     sunlit,                                                                 &
+       &     klev,                                                                   &
+       &     ncol(n),                                                                &
+       &     seed(:,n),                                                              &
+       &     pfull,                                                                  &
+       &     phalf,                                                                  &
+       &     qv, cc, conv, dtau_sH2B, dtau_cH2B,                                     &
+       &     top_height,                                                             &
+       &     overlap,                                                                &
+       &     tautab,                                                                 &
+       &     invtau,                                                                 &
+       &     ztsol,                                                                  &
+       &     emsfc_lw,                                                               &
+       &     at, dem_sH2B, dem_cH2B,                                                 &
+       &     fq_isccp(:,:,:,n),                                                      &
+       &     totalcldarea(:,n),                                                      &
+       &     meanptop(:,n),                                                          &
+       &     meantaucld(:,n),                                                        &
+       &     boxtau(:,:,n),                                                          &
+       &     boxptop(:,:,n))
+!c
+      ENDDO !n=1, napisccp
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/calltherm.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/calltherm.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/calltherm.F90	(revision 17)
@@ -0,0 +1,437 @@
+!
+! $Id: calltherm.F90 1795 2013-07-18 08:20:28Z emillour $
+!
+      subroutine calltherm(dtime  &
+     &      ,pplay,paprs,pphi,weak_inversion  &
+     &      ,u_seri,v_seri,t_seri,q_seri,zqsat,debut  &
+     &      ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs  &
+     &      ,fm_therm,entr_therm,detr_therm,zqasc,clwcon0,lmax,ratqscth,  &
+     &       ratqsdiff,zqsatth,Ale_bl,Alp_bl,lalim_conv,wght_th, &
+     &       zmax0,f0,zw2,fraca,ztv,zpspsk,ztla,zthl &
+!!! nrlmd le 10/04/2012
+     &      ,pbl_tke,pctsrf,omega,airephy &
+     &      ,zlcl_th,fraca0,w0,w_conv,therm_tke_max0,env_tke_max0 &
+     &      ,n2,s2,ale_bl_stat &
+     &      ,therm_tke_max,env_tke_max &
+     &      ,alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke &
+     &      ,alp_bl_conv,alp_bl_stat &
+!!! fin nrlmd le 10/04/2012
+     &      ,zqla,ztva )
+
+      USE dimphy
+      USE indice_sol_mod
+
+      implicit none
+#include "dimensions.h"
+!#include "dimphy.h"
+#include "thermcell.h"
+#include "iniprint.h"
+
+
+!IM 140508
+      INTEGER, SAVE ::  itap
+!$OMP THREADPRIVATE(itap)
+      REAL dtime
+      LOGICAL debut
+      LOGICAL logexpr0, logexpr2(klon,klev), logexpr1(klon)
+      REAL fact(klon)
+      INTEGER nbptspb
+
+      REAL u_seri(klon,klev),v_seri(klon,klev)
+      REAL t_seri(klon,klev),q_seri(klon,klev),qmemoire(klon,klev)
+      REAL weak_inversion(klon)
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pphi(klon,klev)
+      real zlev(klon,klev+1) 
+!test: on sort lentr et a* pour alimenter KE
+      REAL wght_th(klon,klev)
+      INTEGER lalim_conv(klon)
+      REAL zw2(klon,klev+1),fraca(klon,klev+1)
+
+!FH Update Thermiques
+      REAL d_t_ajs(klon,klev), d_q_ajs(klon,klev)
+      REAL d_u_ajs(klon,klev),d_v_ajs(klon,klev)
+      real fm_therm(klon,klev+1)
+      real entr_therm(klon,klev),detr_therm(klon,klev)
+
+!********************************************************
+!     declarations
+      LOGICAL flag_bidouille_stratocu
+      real fmc_therm(klon,klev+1),zqasc(klon,klev)
+      real zqla(klon,klev)
+      real zqta(klon,klev)
+      real ztv(klon,klev),ztva(klon,klev)
+      real zpspsk(klon,klev)
+      real ztla(klon,klev)
+      real zthl(klon,klev)
+      real wmax_sec(klon)
+      real zmax_sec(klon)
+      real f_sec(klon)
+      real detrc_therm(klon,klev)
+! FH WARNING : il semble que ces save ne servent a rien
+!     save fmc_therm, detrc_therm
+      real clwcon0(klon,klev)
+      real zqsat(klon,klev)
+      real zw_sec(klon,klev+1)
+      integer lmix_sec(klon)
+      integer lmax(klon)
+      real ratqscth(klon,klev)
+      real ratqsdiff(klon,klev)
+      real zqsatth(klon,klev)  
+!nouvelles variables pour la convection
+      real Ale_bl(klon)
+      real Alp_bl(klon)
+      real Ale(klon)
+      real Alp(klon)
+!RC
+      !on garde le zmax du pas de temps precedent
+      real zmax0(klon), f0(klon)
+
+!!! nrlmd le 10/04/2012
+      real pbl_tke(klon,klev+1,nbsrf)
+      real pctsrf(klon,nbsrf)
+      real omega(klon,klev)
+      real airephy(klon)
+      real zlcl_th(klon),fraca0(klon),w0(klon),w_conv(klon)
+      real therm_tke_max0(klon),env_tke_max0(klon)
+      real n2(klon),s2(klon)
+      real ale_bl_stat(klon)
+      real therm_tke_max(klon,klev),env_tke_max(klon,klev)
+      real alp_bl_det(klon),alp_bl_fluct_m(klon),alp_bl_fluct_tke(klon),alp_bl_conv(klon),alp_bl_stat(klon)
+!!! fin nrlmd le 10/04/2012
+
+!********************************************************
+
+
+! variables locales
+      REAL d_t_the(klon,klev), d_q_the(klon,klev)
+      REAL d_u_the(klon,klev),d_v_the(klon,klev)
+!
+      real zfm_therm(klon,klev+1),zdt
+      real zentr_therm(klon,klev),zdetr_therm(klon,klev)
+! FH A VERIFIER : SAVE INUTILES
+!      save zentr_therm,zfm_therm
+
+      character (len=20) :: modname='calltherm'
+      character (len=80) :: abort_message
+
+      integer i,k
+      logical, save :: first=.true.
+!$OMP THREADPRIVATE(first)
+!********************************************************
+      if (first) then
+        itap=0
+        first=.false.
+      endif
+
+! Incrementer le compteur de la physique
+     itap   = itap + 1
+
+!  Modele du thermique
+!  ===================
+!         print*,'thermiques: WARNING on passe t au lieu de t_seri'
+
+
+! On prend comme valeur initiale des thermiques la valeur du pas
+! de temps precedent
+         zfm_therm(:,:)=fm_therm(:,:)
+         zdetr_therm(:,:)=detr_therm(:,:)
+         zentr_therm(:,:)=entr_therm(:,:)
+
+! On reinitialise les flux de masse a zero pour le cumul en
+! cas de splitting
+         fm_therm(:,:)=0.
+         entr_therm(:,:)=0.
+         detr_therm(:,:)=0.
+
+         Ale_bl(:)=0.
+         Alp_bl(:)=0.
+         if (prt_level.ge.10) then
+          print*,'thermV4 nsplit: ',nsplit_thermals,' weak_inversion'
+         endif
+
+!   tests sur les valeurs negatives de l'eau
+         logexpr0=prt_level.ge.10
+         nbptspb=0
+         do k=1,klev
+            do i=1,klon
+! Attention teste abderr 19-03-09
+!               logexpr2(i,k)=.not.q_seri(i,k).ge.0.
+                logexpr2(i,k)=.not.q_seri(i,k).ge.1.e-15
+               if (logexpr2(i,k)) then
+                q_seri(i,k)=1.e-15
+                nbptspb=nbptspb+1
+               endif
+!               if (logexpr0) &
+!    &             print*,'WARN eau<0 avant therm i=',i,'  k=',k  &
+!    &         ,' dq,q',d_q_the(i,k),q_seri(i,k)
+            enddo
+         enddo
+         if(nbptspb.GT.0) print*,'Number of points with q_seri(i,k)<=0 ',nbptspb   
+
+         zdt=dtime/REAL(nsplit_thermals)
+         do isplit=1,nsplit_thermals
+
+          if (iflag_thermals.eq.1) then
+            CALL thermcell_2002(klon,klev,zdt   &
+     &      ,pplay,paprs,pphi  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm  &
+     &      ,r_aspect_thermals,30.,w2di_thermals  &
+     &      ,tau_thermals)
+          else if (iflag_thermals.eq.2) then
+            CALL thermcell_sec(klon,klev,zdt  &
+     &      ,pplay,paprs,pphi,zlev  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm  &
+     &      ,r_aspect_thermals,30.,w2di_thermals  &
+     &      ,tau_thermals)
+          else if (iflag_thermals.eq.3) then
+            CALL thermcell(klon,klev,zdt  &
+     &      ,pplay,paprs,pphi  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm  &
+     &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+     &      ,tau_thermals)
+          else if (iflag_thermals.eq.10) then
+            CALL thermcell_eau(klon,klev,zdt  &
+     &      ,pplay,paprs,pphi  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm  &
+     &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+     &      ,tau_thermals)
+          else if (iflag_thermals.eq.11) then
+              abort_message = 'cas non prevu dans calltherm'
+              CALL abort_gcm (modname,abort_message,1)
+
+!           CALL thermcell_pluie(klon,klev,zdt  &
+!   &      ,pplay,paprs,pphi,zlev  &
+!    &      ,u_seri,v_seri,t_seri,q_seri  &
+!    &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+!    &      ,zfm_therm,zentr_therm,zqla  &
+!    &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+!    &      ,tau_thermals,3)
+          else if (iflag_thermals.eq.12) then
+            CALL calcul_sec(klon,klev,zdt  &
+     &      ,pplay,paprs,pphi,zlev  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,zmax_sec,wmax_sec,zw_sec,lmix_sec  &
+     &      ,r_aspect_thermals,l_mix_thermals,w2di_thermals  &
+     &      ,tau_thermals)
+          else if (iflag_thermals==13.or.iflag_thermals==14) then
+            CALL thermcellV0_main(itap,klon,klev,zdt  &
+     &      ,pplay,paprs,pphi,debut  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm,zdetr_therm,zqasc,zqla,lmax  &
+     &      ,ratqscth,ratqsdiff,zqsatth  &
+     &      ,r_aspect_thermals,l_mix_thermals  &
+     &      ,tau_thermals,Ale,Alp,lalim_conv,wght_th &
+     &      ,zmax0,f0,zw2,fraca)
+          else if (iflag_thermals>=15.and.iflag_thermals<=18) then
+
+!            print*,'THERM iflag_thermas_ed=',iflag_thermals_ed
+            CALL thermcell_main(itap,klon,klev,zdt  &
+     &      ,pplay,paprs,pphi,debut  &
+     &      ,u_seri,v_seri,t_seri,q_seri  &
+     &      ,d_u_the,d_v_the,d_t_the,d_q_the  &
+     &      ,zfm_therm,zentr_therm,zdetr_therm,zqasc,zqla,lmax  &
+     &      ,ratqscth,ratqsdiff,zqsatth  &
+!    &      ,r_aspect_thermals,l_mix_thermals &
+!    &      ,tau_thermals,iflag_thermals_ed,iflag_coupl &
+     &      ,Ale,Alp,lalim_conv,wght_th &
+     &      ,zmax0,f0,zw2,fraca,ztv,zpspsk &
+     &      ,ztla,zthl &
+!!! nrlmd le 10/04/2012
+     &      ,pbl_tke,pctsrf,omega,airephy &
+     &      ,zlcl_th,fraca0,w0,w_conv,therm_tke_max0,env_tke_max0 &
+     &      ,n2,s2,ale_bl_stat &
+     &      ,therm_tke_max,env_tke_max &
+     &      ,alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke &
+     &      ,alp_bl_conv,alp_bl_stat &
+!!! fin nrlmd le 10/04/2012
+     &      ,ztva ) 
+           if (prt_level.gt.10) write(lunout,*)'Apres thermcell_main OK'
+         else
+           abort_message = 'Cas des thermiques non prevu'
+           CALL abort_gcm (modname,abort_message,1)
+         endif
+
+! Attention : les noms sont contre intuitif.
+! flag_bidouille_stratocu est .true. si on ne fait pas de bidouille.
+! Il aurait mieux valu avoir un nobidouille_stratocu
+! Et pour simplifier :
+! nobidouille_stratocu=.not.(iflag_thermals==13.or.iflag_thermals=15)
+! Ce serait bien de changer, mai en prenant le temps de vÃ©rifier que ca
+! fait bien ce qu'on croit.
+
+       flag_bidouille_stratocu=iflag_thermals<=12.or.iflag_thermals==14.or.iflag_thermals==16.or.iflag_thermals==18
+
+      if (iflag_thermals<=12) then
+         lmax=1
+         do k=1,klev-1
+            zdetr_therm(:,k)=zentr_therm(:,k)+zfm_therm(:,k)-zfm_therm(:,k+1)
+         enddo
+      endif
+
+      fact(:)=0.
+      DO i=1,klon
+       logexpr1(i)=flag_bidouille_stratocu.or.weak_inversion(i).gt.0.5
+       IF(logexpr1(i)) fact(i)=1./REAL(nsplit_thermals)
+      ENDDO
+
+     DO k=1,klev
+!  transformation de la derivee en tendance
+            d_t_the(:,k)=d_t_the(:,k)*dtime*fact(:)
+            d_u_the(:,k)=d_u_the(:,k)*dtime*fact(:)
+            d_v_the(:,k)=d_v_the(:,k)*dtime*fact(:)
+            d_q_the(:,k)=d_q_the(:,k)*dtime*fact(:)
+            fm_therm(:,k)=fm_therm(:,k)  &
+     &      +zfm_therm(:,k)*fact(:)
+            entr_therm(:,k)=entr_therm(:,k)  &
+     &       +zentr_therm(:,k)*fact(:)
+            detr_therm(:,k)=detr_therm(:,k)  &
+     &       +zdetr_therm(:,k)*fact(:)
+      ENDDO
+       fm_therm(:,klev+1)=0.
+
+
+
+!  accumulation de la tendance
+            d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_the(:,:)
+            d_u_ajs(:,:)=d_u_ajs(:,:)+d_u_the(:,:)
+            d_v_ajs(:,:)=d_v_ajs(:,:)+d_v_the(:,:)
+            d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_the(:,:)
+
+!  incrementation des variables meteo
+            t_seri(:,:) = t_seri(:,:) + d_t_the(:,:)
+            u_seri(:,:) = u_seri(:,:) + d_u_the(:,:)
+            v_seri(:,:) = v_seri(:,:) + d_v_the(:,:)
+            qmemoire(:,:)=q_seri(:,:)
+            q_seri(:,:) = q_seri(:,:) + d_q_the(:,:)
+           if (prt_level.gt.10) write(lunout,*)'Apres apres thermcell_main OK'
+
+       DO i=1,klon
+            fm_therm(i,klev+1)=0.
+            Ale_bl(i)=Ale_bl(i)+Ale(i)/REAL(nsplit_thermals)
+!            write(22,*)'ALE CALLTHERM',Ale_bl(i),Ale(i)
+            Alp_bl(i)=Alp_bl(i)+Alp(i)/REAL(nsplit_thermals)
+!            write(23,*)'ALP CALLTHERM',Alp_bl(i),Alp(i)
+        if(prt_level.GE.10) print*,'calltherm i Alp_bl Alp Ale_bl Ale',i,Alp_bl(i),Alp(i),Ale_bl(i),Ale(i)
+       ENDDO
+
+!IM 060508 marche pas comme cela !!!        enddo ! isplit
+
+!   tests sur les valeurs negatives de l'eau
+         nbptspb=0
+            DO k = 1, klev
+            DO i = 1, klon
+               logexpr2(i,k)=.not.q_seri(i,k).ge.0.
+               if (logexpr2(i,k)) then
+                q_seri(i,k)=1.e-15
+                nbptspb=nbptspb+1
+!                if (prt_level.ge.10) then
+!                  print*,'WARN eau<0 apres therm i=',i,'  k=',k  &
+!    &         ,' dq,q',d_q_the(i,k),q_seri(i,k),  &
+!    &         'fm=',zfm_therm(i,k),'entr=',entr_therm(i,k)
+                 endif
+            ENDDO
+            ENDDO
+        IF(nbptspb.GT.0) print*,'Number of points with q_seri(i,k)<=0 ',nbptspb   
+! tests sur les valeurs de la temperature
+        nbptspb=0
+            DO k = 1, klev
+            DO i = 1, klon
+               logexpr2(i,k)=t_seri(i,k).lt.50..or.t_seri(i,k).gt.370.
+               if (logexpr2(i,k)) nbptspb=nbptspb+1
+!              if ((t_seri(i,k).lt.50.) .or.  &
+!    &              (t_seri(i,k).gt.370.)) then
+!                 print*,'WARN temp apres therm i=',i,'  k=',k  &
+!    &         ,' t_seri',t_seri(i,k)
+!              CALL abort
+!              endif
+            ENDDO
+            ENDDO
+        IF(nbptspb.GT.0) print*,'Number of points with q_seri(i,k)<=0 ',nbptspb
+         enddo ! isplit
+
+!
+!***************************************************************
+!     calcul du flux ascencant conservatif
+!            print*,'<<<<calcul flux ascendant conservatif'
+
+      fmc_therm=0.
+               do k=1,klev
+            do i=1,klon
+                  if (entr_therm(i,k).gt.0.) then
+                     fmc_therm(i,k+1)=fmc_therm(i,k)+entr_therm(i,k)
+                  else
+                     fmc_therm(i,k+1)=fmc_therm(i,k)
+                  endif
+                  detrc_therm(i,k)=(fmc_therm(i,k+1)-fm_therm(i,k+1))  &
+     &                 -(fmc_therm(i,k)-fm_therm(i,k))
+               enddo
+            enddo
+      
+     
+!****************************************************************
+!     calcul de l'humidite dans l'ascendance
+!      print*,'<<<<calcul de lhumidite dans thermique'
+!CR:on ne le calcule que pour le cas sec
+      if (iflag_thermals.le.11) then      
+      do i=1,klon
+         zqasc(i,1)=q_seri(i,1)
+         do k=2,klev
+            if (fmc_therm(i,k+1).gt.1.e-6) then
+               zqasc(i,k)=(fmc_therm(i,k)*zqasc(i,k-1)  &
+     &              +entr_therm(i,k)*q_seri(i,k))/fmc_therm(i,k+1)
+!CR:test on asseche le thermique
+!               zqasc(i,k)=zqasc(i,k)/2.
+!            else
+!               zqasc(i,k)=q_seri(i,k)
+            endif
+         enddo
+       enddo
+      
+
+!     calcul de l'eau condensee dans l'ascendance
+!             print*,'<<<<calcul de leau condensee dans thermique'
+             do i=1,klon
+                do k=1,klev
+                   clwcon0(i,k)=zqasc(i,k)-zqsat(i,k)
+                   if (clwcon0(i,k).lt.0. .or.   &
+     &             (fm_therm(i,k+1)+detrc_therm(i,k)).lt.1.e-6) then
+                      clwcon0(i,k)=0.
+                   endif
+                enddo
+             enddo
+       else
+              do i=1,klon
+                do k=1,klev
+                   clwcon0(i,k)=zqla(i,k)  
+                   if (clwcon0(i,k).lt.0. .or.   &
+     &             (fm_therm(i,k+1)+detrc_therm(i,k)).lt.1.e-6) then
+                   clwcon0(i,k)=0. 
+                   endif
+                enddo
+             enddo
+       endif
+!*******************************************************************    
+
+
+!jyg  Protection contre les temperatures nulles
+          do i=1,klon
+             do k=1,klev
+                if (ztla(i,k) .lt. 1.e-10) fraca(i,k) =0.
+             enddo
+          enddo
+
+
+      return
+
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/calwake.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/calwake.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/calwake.F	(revision 17)
@@ -0,0 +1,475 @@
+!
+! $Id: calwake.F 1665 2012-10-09 13:35:26Z fairhead $
+!
+      SUBROUTINE CALWAKE(paprs,pplay,dtime
+     :             ,t,q,omgb
+     :             ,dt_dwn,dq_dwn,M_dwn,M_up
+     :             ,dt_a,dq_a,sigd
+     :             ,wdt_PBL,wdq_PBL
+     :             ,udt_PBL,udq_PBL
+     o             ,wake_deltat,wake_deltaq,wake_dth
+     o             ,wake_h,wake_s,wake_dens
+     o             ,wake_pe,wake_fip,wake_gfl
+     o             ,dt_wake,dq_wake
+     o             ,wake_k
+     o             ,undi_t,undi_q
+     o             ,wake_omgbdth,wake_dp_omgb
+     o             ,wake_dtKE,wake_dqKE
+     o             ,wake_dtPBL,wake_dqPBL
+     o             ,wake_omg,wake_dp_deltomg
+     o             ,wake_spread,wake_Cstar,wake_d_deltat_gw
+     o             ,wake_ddeltat,wake_ddeltaq)
+***************************************************************
+*                                                             *
+* CALWAKE                                                     *
+*           interface avec le schema de calcul de la poche    *
+*           froide                                            *
+*                                                             *
+* written by   : CHERUY Frederique, 13/03/2000, 10.31.05      *
+* modified by :  ROEHRIG Romain,    01/30/2007                *
+***************************************************************
+*
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+#include "dimensions.h"
+!#include "dimphy.h"
+#include "YOMCST.h"
+
+c Arguments
+c----------
+
+      INTEGER  i,l,ktopw(klon)
+      REAL   dtime
+
+      REAL paprs(klon,klev+1),pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev), omgb(klon,klev)
+      REAL dt_dwn(klon,klev), dq_dwn(klon,klev),M_dwn(klon,klev)
+      REAL M_up(klon,klev)
+      REAL dt_a(klon,klev), dq_a(klon,klev)
+      REAL wdt_PBL(klon,klev), wdq_PBL(klon,klev)
+      REAL udt_PBL(klon,klev), udq_PBL(klon,klev)
+      REAL wake_deltat(klon,klev),wake_deltaq(klon,klev)
+      REAL dt_wake(klon,klev),dq_wake(klon,klev)
+      REAL wake_d_deltat_gw(klon,klev)
+      REAL wake_h(klon),wake_s(klon)
+      REAL wake_dth(klon,klev)
+      REAL wake_pe(klon),wake_fip(klon),wake_gfl(klon)
+      REAL undi_t(klon,klev),undi_q(klon,klev)
+      REAL wake_omgbdth(klon,klev),wake_dp_omgb(klon,klev)
+      REAL wake_dtKE(klon,klev),wake_dqKE(klon,klev)
+      REAL wake_dtPBL(klon,klev),wake_dqPBL(klon,klev)
+      REAL wake_omg(klon,klev),wake_dp_deltomg(klon,klev)
+      REAL wake_spread(klon,klev),wake_Cstar(klon)
+      REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev)
+      REAL d_deltatw(klon,klev), d_deltaqw(klon,klev)
+      INTEGER wake_k(klon)
+      REAL sigd(klon)
+      REAL wake_dens(klon)
+
+C  Variable internes
+C  -----------------
+
+      REAL aire
+      REAL p(klon,klev),ph(klon,klev+1),pi(klon,klev)
+      REAL te(klon,klev),qe(klon,klev),omgbe(klon,klev+1)
+      REAL dtdwn(klon,klev),dqdwn(klon,klev)
+      REAL dta(klon,klev),dqa(klon,klev)
+      REAL wdtPBL(klon,klev),wdqPBL(klon,klev)
+      REAL udtPBL(klon,klev),udqPBL(klon,klev) 
+      REAL amdwn(klon,klev),amup(klon,klev)
+      REAL dtw(klon,klev),dqw(klon,klev),dth(klon,klev)
+      REAL d_deltat_gw(klon,klev)
+      REAL dtls(klon,klev),dqls(klon,klev)
+      REAL tu(klon,klev),qu(klon,klev)
+      REAL hw(klon),sigmaw(klon),wape(klon),fip(klon),gfl(klon)
+      REAL omgbdth(klon,klev+1),dp_omgb(klon,klev)
+      REAL dtKE(klon,klev),dqKE(klon,klev)
+      REAL dtPBL(klon,klev),dqPBL(klon,klev)
+      REAL omg(klon,klev+1),dp_deltomg(klon,klev),spread(klon,klev)
+      REAL Cstar(klon)
+      REAL sigd0(klon),wdens(klon)
+
+      REAL RDCP
+
+c      print *, '-> calwake, wake_s ', wake_s(1)
+
+      RDCP=1./3.5
+
+
+c-----------------------------------------------------------
+cIM 290108     DO 999 i=1,klon   ! a vectoriser
+c----------------------------------------------------------
+
+
+      DO l=1,klev
+      DO i=1,klon 
+        p(i,l)= pplay(i,l)
+        ph(i,l)= paprs(i,l)
+        pi(i,l) = (pplay(i,l)/100000.)**RDCP
+
+        te(i,l) = t(i,l)
+        qe(i,l) = q(i,l)
+        omgbe(i,l) = omgb(i,l)
+
+        dtdwn(i,l)= dt_dwn(i,l)
+        dqdwn(i,l)= dq_dwn(i,l)
+        dta(i,l)= dt_a(i,l)
+        dqa(i,l)= dq_a(i,l)
+        wdtPBL(i,l)= wdt_PBL(i,l)
+        wdqPBL(i,l)= wdq_PBL(i,l)
+        udtPBL(i,l)= udt_PBL(i,l)
+        udqPBL(i,l)= udq_PBL(i,l)
+      ENDDO
+      ENDDO
+
+      omgbe(:,klev+1) = 0.
+      
+      DO i=1,klon 
+      sigd0(i)=sigd(i)
+      ENDDO
+c      print*, 'sigd0,sigd', sigd0, sigd(i)
+      DO i=1,klon 
+      ph(i,klev+1)=0.
+      ENDDO
+
+      DO i=1,klon 
+      ktopw(i) = wake_k(i)
+      ENDDO
+
+      DO l=1,klev
+      DO i=1,klon 
+        dtw(i,l) = wake_deltat(i,l)
+        dqw(i,l) = wake_deltaq(i,l)
+      ENDDO
+      ENDDO
+
+      DO l=1,klev
+      DO i=1,klon 
+        dtls(i,l)=dt_wake(i,l)
+        dqls(i,l)=dq_wake(i,l)
+      ENDDO
+      ENDDO
+
+      DO i=1,klon 
+      hw(i) = wake_h(i)
+      sigmaw(i)= wake_s(i)
+      ENDDO
+
+cfkc les flux de masses sont evalues aux niveaux et valent 0 a la surface
+cfkc  on veut le flux de masse au milieu des couches
+
+      DO l=1,klev-1
+      DO i=1,klon 
+        amdwn(i,l)= 0.5*(M_dwn(i,l)+M_dwn(i,l+1))
+        amdwn(i,l)= (M_dwn(i,l+1))
+      ENDDO
+      ENDDO
+
+c au sommet le flux de masse est nul
+
+      DO i=1,klon 
+      amdwn(i,klev)=0.5*M_dwn(i,klev)
+      ENDDO
+c
+      DO l = 1,klev
+      DO i=1,klon 
+        amup(i,l)=M_up(i,l)
+      ENDDO
+      ENDDO
+
+      call WAKE(p,ph,pi,dtime,sigd0
+     $                ,te,qe,omgbe
+     $                ,dtdwn,dqdwn,amdwn,amup,dta,dqa
+     $                ,wdtPBL,wdqPBL,udtPBL,udqPBL
+     $                ,dtw,dqw,dth,hw,sigmaw,wape,fip,gfl
+     $                ,dtls,dqls,ktopw
+     $                ,omgbdth,dp_omgb,wdens
+     $                ,tu,qu
+     $                ,dtKE,dqKE
+     $                ,dtPBL,dqPBL
+     $                ,omg,dp_deltomg,spread
+     $                ,Cstar,d_deltat_gw
+     $                ,d_deltatw,d_deltaqw)
+c
+      DO l=1,klev
+       DO i=1,klon 
+        IF (ktopw(i) .GT. 0) THEN
+           wake_deltat(i,l)= dtw(i,l)
+           wake_deltaq(i,l)= dqw(i,l)
+           wake_d_deltat_gw(i,l)= d_deltat_gw(i,l)
+           wake_omgbdth(i,l) = omgbdth(i,l)
+           wake_dp_omgb(i,l) = dp_omgb(i,l)
+           wake_dtKE(i,l) = dtKE(i,l)
+           wake_dqKE(i,l) = dqKE(i,l)
+ 	   wake_dtPBL(i,l) = dtPBL(i,l)
+	   wake_dqPBL(i,l) = dqPBL(i,l)
+           wake_omg(i,l) = omg(i,l)
+           wake_dp_deltomg(i,l) = dp_deltomg(i,l)
+           wake_spread(i,l) = spread(i,l)
+           wake_dth(i,l) = dth(i,l)
+           dt_wake(i,l) = dtls(i,l)
+           dq_wake(i,l) = dqls(i,l)
+           undi_t(i,l) = tu(i,l)
+           undi_q(i,l) = qu(i,l)
+           wake_ddeltat(i,l) = d_deltatw(i,l)
+           wake_ddeltaq(i,l) = d_deltaqw(i,l)
+        ELSE
+           wake_deltat(i,l)= 0.
+           wake_deltaq(i,l)= 0.
+           wake_d_deltat_gw(i,l)= 0.
+           wake_omgbdth(i,l) = 0.
+           wake_dp_omgb(i,l) = 0.
+           wake_dtKE(i,l) = 0.
+           wake_dqKE(i,l) = 0.
+ 	   wake_dtPBL(i,l) = 0.
+	   wake_dqPBL(i,l) = 0.
+           wake_omg(i,l) = 0.
+           wake_dp_deltomg(i,l) = 0.
+           wake_spread(i,l) = 0.
+           wake_dth(i,l)=0.
+           dt_wake(i,l)=0.
+           dq_wake(i,l)=0.
+           undi_t(i,l)=te(i,l)
+           undi_q(i,l)=qe(i,l)
+           wake_ddeltat(i,l) = 0.
+           wake_ddeltaq(i,l) = 0.
+        ENDIF
+       ENDDO
+      ENDDO
+c
+      DO i=1,klon 
+       wake_h(i)= hw(i)
+       wake_s(i)= sigmaw(i)
+       wake_pe(i)= wape(i)
+       wake_fip(i)= fip(i)
+       wake_gfl(i) = gfl(i)
+       wake_k(i) =ktopw(i)
+       wake_Cstar(i) = Cstar(i)
+       wake_dens(i) = wdens(i)
+      ENDDO
+c
+      RETURN
+      END
+
+      SUBROUTINE CALWAKE_scal(paprs,pplay,dtime
+     :             ,t,q,omgb
+     :             ,dt_dwn,dq_dwn,M_dwn,M_up
+     :             ,dt_a,dq_a,sigd
+     :             ,wdt_PBL,wdq_PBL
+     :             ,udt_PBL,udq_PBL
+     o             ,wake_deltat,wake_deltaq,wake_dth
+     o             ,wake_h,wake_s,wake_dens
+     o             ,wake_pe,wake_fip,wake_gfl
+     o             ,dt_wake,dq_wake
+     o             ,wake_k
+     o             ,undi_t,undi_q
+     o             ,wake_omgbdth,wake_dp_omgb
+     o             ,wake_dtKE,wake_dqKE
+     o             ,wake_dtPBL,wake_dqPBL
+     o             ,wake_omg,wake_dp_deltomg
+     o             ,wake_spread,wake_Cstar,wake_d_deltat_gw
+     o             ,wake_ddeltat,wake_ddeltaq)
+***************************************************************
+*                                                             *
+* CALWAKE                                                     *
+*           interface avec le schema de calcul de la poche    *
+*           froide                                            *
+*                                                             *
+* written by   : CHERUY Frederique, 13/03/2000, 10.31.05      *
+* modified by :  ROEHRIG Romain,    01/30/2007                *
+***************************************************************
+*
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+c Arguments
+c----------
+
+      INTEGER  i,l,ktopw
+      REAL   dtime
+
+      REAL paprs(klon,klev+1),pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev), omgb(klon,klev)
+      REAL dt_dwn(klon,klev), dq_dwn(klon,klev),M_dwn(klon,klev)
+      REAL M_up(klon,klev)
+      REAL dt_a(klon,klev), dq_a(klon,klev)
+      REAL wdt_PBL(klon,klev), wdq_PBL(klon,klev)
+      REAL udt_PBL(klon,klev), udq_PBL(klon,klev)
+      REAL wake_deltat(klon,klev),wake_deltaq(klon,klev)
+      REAL dt_wake(klon,klev),dq_wake(klon,klev)
+      REAL wake_d_deltat_gw(klon,klev)
+      REAL wake_h(klon),wake_s(klon)
+      REAL wake_dth(klon,klev)
+      REAL wake_pe(klon),wake_fip(klon),wake_gfl(klon)
+      REAL undi_t(klon,klev),undi_q(klon,klev)
+      REAL wake_omgbdth(klon,klev),wake_dp_omgb(klon,klev)
+      REAL wake_dtKE(klon,klev),wake_dqKE(klon,klev)
+      REAL wake_dtPBL(klon,klev),wake_dqPBL(klon,klev)
+      REAL wake_omg(klon,klev+1),wake_dp_deltomg(klon,klev)
+      REAL wake_spread(klon,klev),wake_Cstar(klon)
+      REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev)
+      REAL d_deltatw(klev), d_deltaqw(klev)
+      INTEGER wake_k(klon)
+      REAL sigd(klon)
+      REAL wake_dens(klon)
+
+C  Variable internes
+C  -----------------
+
+      REAL aire
+      REAL p(klev),ph(klev+1),pi(klev)
+      REAL te(klev),qe(klev),omgbe(klev),dtdwn(klev),dqdwn(klev)
+      REAL dta(klev),dqa(klev)
+      REAL wdtPBL(klev),wdqPBL(klev)
+      REAL udtPBL(klev),udqPBL(klev) 
+      REAL amdwn(klev),amup(klev)
+      REAL dtw(klev),dqw(klev),dth(klev),d_deltat_gw(klev)
+      REAL dtls(klev),dqls(klev)
+      REAL tu(klev),qu(klev)
+      REAL hw,sigmaw,wape,fip,gfl
+      REAL omgbdth(klev),dp_omgb(klev)
+      REAL dtKE(klev),dqKE(klev)
+      REAL dtPBL(klev),dqPBL(klev)
+      REAL omg(klev+1),dp_deltomg(klev),spread(klev),Cstar
+      REAL sigd0,wdens
+
+      REAL RDCP
+
+c      print *, '-> calwake, wake_s ', wake_s(1)
+
+      RDCP=1./3.5
+
+c-----------------------------------------------------------
+      DO 999 i=1,klon   ! a vectoriser
+c----------------------------------------------------------
+
+
+      DO l=1,klev
+        p(l)= pplay(i,l)
+        ph(l)= paprs(i,l)
+        pi(l) = (pplay(i,l)/100000.)**RDCP
+
+        te(l) = t(i,l)
+        qe(l) = q(i,l)
+        omgbe(l) = omgb(i,l)
+
+        dtdwn(l)= dt_dwn(i,l)
+        dqdwn(l)= dq_dwn(i,l)
+        dta(l)= dt_a(i,l)
+        dqa(l)= dq_a(i,l)
+        wdtPBL(l)= wdt_PBL(i,l)
+        wdqPBL(l)= wdq_PBL(i,l)
+        udtPBL(l)= udt_PBL(i,l)
+        udqPBL(l)= udq_PBL(i,l)
+      ENDDO
+      
+      sigd0=sigd(i)
+c      print*, 'sigd0,sigd', sigd0, sigd(i)
+      ph(klev+1)=0.
+
+      ktopw = wake_k(i)
+
+      DO l=1,klev
+        dtw(l) = wake_deltat(i,l)
+        dqw(l) = wake_deltaq(i,l)
+      ENDDO
+
+      DO l=1,klev
+        dtls(l)=dt_wake(i,l)
+        dqls(l)=dq_wake(i,l)
+      ENDDO
+
+      hw = wake_h(i)
+      sigmaw = wake_s(i)
+
+cfkc les flux de masses sont evalues aux niveaux et valent 0 a la surface
+cfkc  on veut le flux de masse au milieu des couches
+
+      DO l=1,klev-1
+        amdwn(l)= 0.5*(M_dwn(i,l)+M_dwn(i,l+1))
+        amdwn(l)= (M_dwn(i,l+1))
+      ENDDO
+
+c au sommet le flux de masse est nul
+
+      amdwn(klev)=0.5*M_dwn(i,klev)
+c
+      DO l = 1,klev
+        amup(l)=M_up(i,l)
+      ENDDO
+
+      call WAKE_scal(p,ph,pi,dtime,sigd0
+     $                ,te,qe,omgbe
+     $                ,dtdwn,dqdwn,amdwn,amup,dta,dqa
+     $                ,wdtPBL,wdqPBL,udtPBL,udqPBL
+     $                ,dtw,dqw,dth,hw,sigmaw,wape,fip,gfl
+     $                ,dtls,dqls,ktopw
+     $                ,omgbdth,dp_omgb,wdens
+     $                ,tu,qu
+     $                ,dtKE,dqKE
+     $                ,dtPBL,dqPBL
+     $                ,omg,dp_deltomg,spread
+     $                ,Cstar,d_deltat_gw
+     $                ,d_deltatw,d_deltaqw)
+
+       IF (ktopw .GT. 0) THEN
+         DO l=1,klev
+           wake_deltat(i,l)= dtw(l)
+           wake_deltaq(i,l)= dqw(l)
+           wake_d_deltat_gw(i,l)= d_deltat_gw(l)
+           wake_omgbdth(i,l) = omgbdth(l)
+           wake_dp_omgb(i,l) = dp_omgb(l)
+           wake_dtKE(i,l) = dtKE(l)
+           wake_dqKE(i,l) = dqKE(l)
+ 	   wake_dtPBL(i,l) = dtPBL(l)
+	   wake_dqPBL(i,l) = dqPBL(l)
+           wake_omg(i,l) = omg(l)
+           wake_dp_deltomg(i,l) = dp_deltomg(l)
+           wake_spread(i,l) = spread(l)
+           wake_dth(i,l) = dth(l)
+           dt_wake(i,l) = dtls(l)
+           dq_wake(i,l) = dqls(l)
+           undi_t(i,l) = tu(l)
+           undi_q(i,l) = qu(l)
+           wake_ddeltat(i,l) = d_deltatw(l)
+           wake_ddeltaq(i,l) = d_deltaqw(l)
+         ENDDO
+       ELSE
+         DO l = 1,klev
+           wake_deltat(i,l)= 0.
+           wake_deltaq(i,l)= 0.
+           wake_d_deltat_gw(i,l)= 0.
+           wake_omgbdth(i,l) = 0.
+           wake_dp_omgb(i,l) = 0.
+           wake_dtKE(i,l) = 0.
+           wake_dqKE(i,l) = 0.
+           wake_omg(i,l) = 0.
+           wake_dp_deltomg(i,l) = 0.
+           wake_spread(i,l) = 0.
+           wake_dth(i,l)=0.
+           dt_wake(i,l)=0.
+           dq_wake(i,l)=0.
+           undi_t(i,l)=te(l)
+           undi_q(i,l)=qe(l)
+         ENDDO
+       ENDIF
+
+       wake_h(i)= hw
+       wake_s(i)= sigmaw
+       wake_pe(i)= wape
+       wake_fip(i)= fip
+       wake_gfl(i) = gfl
+       wake_k(i) =ktopw
+       wake_Cstar(i) = Cstar
+       wake_dens(i) = wdens
+c
+ 999  CONTINUE
+c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/calwake.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/calwake.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/calwake.F90	(revision 17)
@@ -0,0 +1,475 @@
+!
+! $Id: calwake.F 1665 2012-10-09 13:35:26Z fairhead $
+!
+      SUBROUTINE CALWAKE(paprs,pplay,dtime                                           &
+       &             ,t,q,omgb                                                       &
+       &             ,dt_dwn,dq_dwn,M_dwn,M_up                                       &
+       &             ,dt_a,dq_a,sigd                                                 &
+       &             ,wdt_PBL,wdq_PBL                                                &
+       &             ,udt_PBL,udq_PBL                                                &
+       &             ,wake_deltat,wake_deltaq,wake_dth                               &
+       &             ,wake_h,wake_s,wake_dens                                        &
+       &             ,wake_pe,wake_fip,wake_gfl                                      &
+       &             ,dt_wake,dq_wake                                                &
+       &             ,wake_k                                                         &
+       &             ,undi_t,undi_q                                                  &
+       &             ,wake_omgbdth,wake_dp_omgb                                      &
+       &             ,wake_dtKE,wake_dqKE                                            &
+       &             ,wake_dtPBL,wake_dqPBL                                          &
+       &             ,wake_omg,wake_dp_deltomg                                       &
+       &             ,wake_spread,wake_Cstar,wake_d_deltat_gw                        &
+       &             ,wake_ddeltat,wake_ddeltaq)
+!***************************************************************
+!*                                                             *
+!* CALWAKE                                                     *
+!*           interface avec le schema de calcul de la poche    *
+!*           froide                                            *
+!*                                                             *
+!* written by   : CHERUY Frederique, 13/03/2000, 10.31.05      *
+!* modified by :  ROEHRIG Romain,    01/30/2007                *
+!***************************************************************
+!*
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+#include "dimensions.h"
+!#include "dimphy.h"
+#include "YOMCST.h"
+
+!c Arguments
+!c----------
+
+      INTEGER  i,l,ktopw(klon)
+      REAL   dtime
+
+      REAL paprs(klon,klev+1),pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev), omgb(klon,klev)
+      REAL dt_dwn(klon,klev), dq_dwn(klon,klev),M_dwn(klon,klev)
+      REAL M_up(klon,klev)
+      REAL dt_a(klon,klev), dq_a(klon,klev)
+      REAL wdt_PBL(klon,klev), wdq_PBL(klon,klev)
+      REAL udt_PBL(klon,klev), udq_PBL(klon,klev)
+      REAL wake_deltat(klon,klev),wake_deltaq(klon,klev)
+      REAL dt_wake(klon,klev),dq_wake(klon,klev)
+      REAL wake_d_deltat_gw(klon,klev)
+      REAL wake_h(klon),wake_s(klon)
+      REAL wake_dth(klon,klev)
+      REAL wake_pe(klon),wake_fip(klon),wake_gfl(klon)
+      REAL undi_t(klon,klev),undi_q(klon,klev)
+      REAL wake_omgbdth(klon,klev),wake_dp_omgb(klon,klev)
+      REAL wake_dtKE(klon,klev),wake_dqKE(klon,klev)
+      REAL wake_dtPBL(klon,klev),wake_dqPBL(klon,klev)
+      REAL wake_omg(klon,klev),wake_dp_deltomg(klon,klev)
+      REAL wake_spread(klon,klev),wake_Cstar(klon)
+      REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev)
+      REAL d_deltatw(klon,klev), d_deltaqw(klon,klev)
+      INTEGER wake_k(klon)
+      REAL sigd(klon)
+      REAL wake_dens(klon)
+
+!C  Variable internes
+!C  -----------------
+
+      REAL aire
+      REAL p(klon,klev),ph(klon,klev+1),pi(klon,klev)
+      REAL te(klon,klev),qe(klon,klev),omgbe(klon,klev+1)
+      REAL dtdwn(klon,klev),dqdwn(klon,klev)
+      REAL dta(klon,klev),dqa(klon,klev)
+      REAL wdtPBL(klon,klev),wdqPBL(klon,klev)
+      REAL udtPBL(klon,klev),udqPBL(klon,klev) 
+      REAL amdwn(klon,klev),amup(klon,klev)
+      REAL dtw(klon,klev),dqw(klon,klev),dth(klon,klev)
+      REAL d_deltat_gw(klon,klev)
+      REAL dtls(klon,klev),dqls(klon,klev)
+      REAL tu(klon,klev),qu(klon,klev)
+      REAL hw(klon),sigmaw(klon),wape(klon),fip(klon),gfl(klon)
+      REAL omgbdth(klon,klev+1),dp_omgb(klon,klev)
+      REAL dtKE(klon,klev),dqKE(klon,klev)
+      REAL dtPBL(klon,klev),dqPBL(klon,klev)
+      REAL omg(klon,klev+1),dp_deltomg(klon,klev),spread(klon,klev)
+      REAL Cstar(klon)
+      REAL sigd0(klon),wdens(klon)
+
+      REAL RDCP
+
+!c      print *, '-> calwake, wake_s ', wake_s(1)
+
+      RDCP=1./3.5
+
+
+!c-----------------------------------------------------------
+!IM 290108     DO 999 i=1,klon   ! a vectoriser
+!c----------------------------------------------------------
+
+
+      DO l=1,klev
+      DO i=1,klon 
+        p(i,l)= pplay(i,l)
+        ph(i,l)= paprs(i,l)
+        pi(i,l) = (pplay(i,l)/100000.)**RDCP
+
+        te(i,l) = t(i,l)
+        qe(i,l) = q(i,l)
+        omgbe(i,l) = omgb(i,l)
+
+        dtdwn(i,l)= dt_dwn(i,l)
+        dqdwn(i,l)= dq_dwn(i,l)
+        dta(i,l)= dt_a(i,l)
+        dqa(i,l)= dq_a(i,l)
+        wdtPBL(i,l)= wdt_PBL(i,l)
+        wdqPBL(i,l)= wdq_PBL(i,l)
+        udtPBL(i,l)= udt_PBL(i,l)
+        udqPBL(i,l)= udq_PBL(i,l)
+      ENDDO
+      ENDDO
+
+      omgbe(:,klev+1) = 0.
+      
+      DO i=1,klon 
+      sigd0(i)=sigd(i)
+      ENDDO
+!c      print*, 'sigd0,sigd', sigd0, sigd(i)
+      DO i=1,klon 
+      ph(i,klev+1)=0.
+      ENDDO
+
+      DO i=1,klon 
+      ktopw(i) = wake_k(i)
+      ENDDO
+
+      DO l=1,klev
+      DO i=1,klon 
+        dtw(i,l) = wake_deltat(i,l)
+        dqw(i,l) = wake_deltaq(i,l)
+      ENDDO
+      ENDDO
+
+      DO l=1,klev
+      DO i=1,klon 
+        dtls(i,l)=dt_wake(i,l)
+        dqls(i,l)=dq_wake(i,l)
+      ENDDO
+      ENDDO
+
+      DO i=1,klon 
+      hw(i) = wake_h(i)
+      sigmaw(i)= wake_s(i)
+      ENDDO
+
+!cfkc les flux de masses sont evalues aux niveaux et valent 0 a la surface
+!cfkc  on veut le flux de masse au milieu des couches
+
+      DO l=1,klev-1
+      DO i=1,klon 
+        amdwn(i,l)= 0.5*(M_dwn(i,l)+M_dwn(i,l+1))
+        amdwn(i,l)= (M_dwn(i,l+1))
+      ENDDO
+      ENDDO
+
+!c au sommet le flux de masse est nul
+
+      DO i=1,klon 
+      amdwn(i,klev)=0.5*M_dwn(i,klev)
+      ENDDO
+!c
+      DO l = 1,klev
+      DO i=1,klon 
+        amup(i,l)=M_up(i,l)
+      ENDDO
+      ENDDO
+
+      call WAKE(p,ph,pi,dtime,sigd0                                                  &
+       &                ,te,qe,omgbe                                                 &
+       &                ,dtdwn,dqdwn,amdwn,amup,dta,dqa                              &
+       &                ,wdtPBL,wdqPBL,udtPBL,udqPBL                                 &
+       &                ,dtw,dqw,dth,hw,sigmaw,wape,fip,gfl                          &
+       &                ,dtls,dqls,ktopw                                             &
+       &                ,omgbdth,dp_omgb,wdens                                       &
+       &                ,tu,qu                                                       &
+       &                ,dtKE,dqKE                                                   &
+       &                ,dtPBL,dqPBL                                                 &
+       &                ,omg,dp_deltomg,spread                                       &
+       &                ,Cstar,d_deltat_gw                                           &
+       &                ,d_deltatw,d_deltaqw)
+!c
+      DO l=1,klev
+       DO i=1,klon 
+        IF (ktopw(i) .GT. 0) THEN
+           wake_deltat(i,l)= dtw(i,l)
+           wake_deltaq(i,l)= dqw(i,l)
+           wake_d_deltat_gw(i,l)= d_deltat_gw(i,l)
+           wake_omgbdth(i,l) = omgbdth(i,l)
+           wake_dp_omgb(i,l) = dp_omgb(i,l)
+           wake_dtKE(i,l) = dtKE(i,l)
+           wake_dqKE(i,l) = dqKE(i,l)
+ 	   wake_dtPBL(i,l) = dtPBL(i,l)
+	   wake_dqPBL(i,l) = dqPBL(i,l)
+           wake_omg(i,l) = omg(i,l)
+           wake_dp_deltomg(i,l) = dp_deltomg(i,l)
+           wake_spread(i,l) = spread(i,l)
+           wake_dth(i,l) = dth(i,l)
+           dt_wake(i,l) = dtls(i,l)
+           dq_wake(i,l) = dqls(i,l)
+           undi_t(i,l) = tu(i,l)
+           undi_q(i,l) = qu(i,l)
+           wake_ddeltat(i,l) = d_deltatw(i,l)
+           wake_ddeltaq(i,l) = d_deltaqw(i,l)
+        ELSE
+           wake_deltat(i,l)= 0.
+           wake_deltaq(i,l)= 0.
+           wake_d_deltat_gw(i,l)= 0.
+           wake_omgbdth(i,l) = 0.
+           wake_dp_omgb(i,l) = 0.
+           wake_dtKE(i,l) = 0.
+           wake_dqKE(i,l) = 0.
+ 	   wake_dtPBL(i,l) = 0.
+	   wake_dqPBL(i,l) = 0.
+           wake_omg(i,l) = 0.
+           wake_dp_deltomg(i,l) = 0.
+           wake_spread(i,l) = 0.
+           wake_dth(i,l)=0.
+           dt_wake(i,l)=0.
+           dq_wake(i,l)=0.
+           undi_t(i,l)=te(i,l)
+           undi_q(i,l)=qe(i,l)
+           wake_ddeltat(i,l) = 0.
+           wake_ddeltaq(i,l) = 0.
+        ENDIF
+       ENDDO
+      ENDDO
+!c
+      DO i=1,klon 
+       wake_h(i)= hw(i)
+       wake_s(i)= sigmaw(i)
+       wake_pe(i)= wape(i)
+       wake_fip(i)= fip(i)
+       wake_gfl(i) = gfl(i)
+       wake_k(i) =ktopw(i)
+       wake_Cstar(i) = Cstar(i)
+       wake_dens(i) = wdens(i)
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE CALWAKE
+
+      SUBROUTINE CALWAKE_scal(paprs,pplay,dtime                                      &
+       &             ,t,q,omgb                                                       &
+       &             ,dt_dwn,dq_dwn,M_dwn,M_up                                       &
+       &             ,dt_a,dq_a,sigd                                                 &
+       &             ,wdt_PBL,wdq_PBL                                                &
+       &             ,udt_PBL,udq_PBL                                                &
+       &             ,wake_deltat,wake_deltaq,wake_dth                               &
+       &             ,wake_h,wake_s,wake_dens                                        &
+       &             ,wake_pe,wake_fip,wake_gfl                                      &
+       &             ,dt_wake,dq_wake                                                &
+       &             ,wake_k                                                         &
+       &             ,undi_t,undi_q                                                  &
+       &             ,wake_omgbdth,wake_dp_omgb                                      &
+       &             ,wake_dtKE,wake_dqKE                                            &
+       &             ,wake_dtPBL,wake_dqPBL                                          &
+       &             ,wake_omg,wake_dp_deltomg                                       &
+       &             ,wake_spread,wake_Cstar,wake_d_deltat_gw                        &
+       &             ,wake_ddeltat,wake_ddeltaq)
+!***************************************************************
+!*                                                             *
+!* CALWAKE                                                     *
+!*           interface avec le schema de calcul de la poche    *
+!*           froide                                            *
+!*                                                             *
+!* written by   : CHERUY Frederique, 13/03/2000, 10.31.05      *
+!* modified by :  ROEHRIG Romain,    01/30/2007                *
+!***************************************************************
+!*
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+!c Arguments
+!c----------
+
+      INTEGER  i,l,ktopw
+      REAL   dtime
+
+      REAL paprs(klon,klev+1),pplay(klon,klev)
+      REAL t(klon,klev), q(klon,klev), omgb(klon,klev)
+      REAL dt_dwn(klon,klev), dq_dwn(klon,klev),M_dwn(klon,klev)
+      REAL M_up(klon,klev)
+      REAL dt_a(klon,klev), dq_a(klon,klev)
+      REAL wdt_PBL(klon,klev), wdq_PBL(klon,klev)
+      REAL udt_PBL(klon,klev), udq_PBL(klon,klev)
+      REAL wake_deltat(klon,klev),wake_deltaq(klon,klev)
+      REAL dt_wake(klon,klev),dq_wake(klon,klev)
+      REAL wake_d_deltat_gw(klon,klev)
+      REAL wake_h(klon),wake_s(klon)
+      REAL wake_dth(klon,klev)
+      REAL wake_pe(klon),wake_fip(klon),wake_gfl(klon)
+      REAL undi_t(klon,klev),undi_q(klon,klev)
+      REAL wake_omgbdth(klon,klev),wake_dp_omgb(klon,klev)
+      REAL wake_dtKE(klon,klev),wake_dqKE(klon,klev)
+      REAL wake_dtPBL(klon,klev),wake_dqPBL(klon,klev)
+      REAL wake_omg(klon,klev+1),wake_dp_deltomg(klon,klev)
+      REAL wake_spread(klon,klev),wake_Cstar(klon)
+      REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev)
+      REAL d_deltatw(klev), d_deltaqw(klev)
+      INTEGER wake_k(klon)
+      REAL sigd(klon)
+      REAL wake_dens(klon)
+
+!C  Variable internes
+!C  -----------------
+
+      REAL aire
+      REAL p(klev),ph(klev+1),pi(klev)
+      REAL te(klev),qe(klev),omgbe(klev),dtdwn(klev),dqdwn(klev)
+      REAL dta(klev),dqa(klev)
+      REAL wdtPBL(klev),wdqPBL(klev)
+      REAL udtPBL(klev),udqPBL(klev) 
+      REAL amdwn(klev),amup(klev)
+      REAL dtw(klev),dqw(klev),dth(klev),d_deltat_gw(klev)
+      REAL dtls(klev),dqls(klev)
+      REAL tu(klev),qu(klev)
+      REAL hw,sigmaw,wape,fip,gfl
+      REAL omgbdth(klev),dp_omgb(klev)
+      REAL dtKE(klev),dqKE(klev)
+      REAL dtPBL(klev),dqPBL(klev)
+      REAL omg(klev+1),dp_deltomg(klev),spread(klev),Cstar
+      REAL sigd0,wdens
+
+      REAL RDCP
+
+!c      print *, '-> calwake, wake_s ', wake_s(1)
+
+      RDCP=1./3.5
+
+!c-----------------------------------------------------------
+      DO 999 i=1,klon   ! a vectoriser
+!c----------------------------------------------------------
+
+
+      DO l=1,klev
+        p(l)= pplay(i,l)
+        ph(l)= paprs(i,l)
+        pi(l) = (pplay(i,l)/100000.)**RDCP
+
+        te(l) = t(i,l)
+        qe(l) = q(i,l)
+        omgbe(l) = omgb(i,l)
+
+        dtdwn(l)= dt_dwn(i,l)
+        dqdwn(l)= dq_dwn(i,l)
+        dta(l)= dt_a(i,l)
+        dqa(l)= dq_a(i,l)
+        wdtPBL(l)= wdt_PBL(i,l)
+        wdqPBL(l)= wdq_PBL(i,l)
+        udtPBL(l)= udt_PBL(i,l)
+        udqPBL(l)= udq_PBL(i,l)
+      ENDDO
+      
+      sigd0=sigd(i)
+!c      print*, 'sigd0,sigd', sigd0, sigd(i)
+      ph(klev+1)=0.
+
+      ktopw = wake_k(i)
+
+      DO l=1,klev
+        dtw(l) = wake_deltat(i,l)
+        dqw(l) = wake_deltaq(i,l)
+      ENDDO
+
+      DO l=1,klev
+        dtls(l)=dt_wake(i,l)
+        dqls(l)=dq_wake(i,l)
+      ENDDO
+
+      hw = wake_h(i)
+      sigmaw = wake_s(i)
+
+!cfkc les flux de masses sont evalues aux niveaux et valent 0 a la surface
+!cfkc  on veut le flux de masse au milieu des couches
+
+      DO l=1,klev-1
+        amdwn(l)= 0.5*(M_dwn(i,l)+M_dwn(i,l+1))
+        amdwn(l)= (M_dwn(i,l+1))
+      ENDDO
+
+!c au sommet le flux de masse est nul
+
+      amdwn(klev)=0.5*M_dwn(i,klev)
+!c
+      DO l = 1,klev
+        amup(l)=M_up(i,l)
+      ENDDO
+
+      call WAKE_scal(p,ph,pi,dtime,sigd0                                             &
+       &                ,te,qe,omgbe                                                 &
+       &                ,dtdwn,dqdwn,amdwn,amup,dta,dqa                              &
+       &                ,wdtPBL,wdqPBL,udtPBL,udqPBL                                 &
+       &                ,dtw,dqw,dth,hw,sigmaw,wape,fip,gfl                          &
+       &                ,dtls,dqls,ktopw                                             &
+       &                ,omgbdth,dp_omgb,wdens                                       &
+       &                ,tu,qu                                                       &
+       &                ,dtKE,dqKE                                                   &
+       &                ,dtPBL,dqPBL                                                 &
+       &                ,omg,dp_deltomg,spread                                       &
+       &                ,Cstar,d_deltat_gw                                           &
+       &                ,d_deltatw,d_deltaqw)
+
+       IF (ktopw .GT. 0) THEN
+         DO l=1,klev
+           wake_deltat(i,l)= dtw(l)
+           wake_deltaq(i,l)= dqw(l)
+           wake_d_deltat_gw(i,l)= d_deltat_gw(l)
+           wake_omgbdth(i,l) = omgbdth(l)
+           wake_dp_omgb(i,l) = dp_omgb(l)
+           wake_dtKE(i,l) = dtKE(l)
+           wake_dqKE(i,l) = dqKE(l)
+ 	   wake_dtPBL(i,l) = dtPBL(l)
+	   wake_dqPBL(i,l) = dqPBL(l)
+           wake_omg(i,l) = omg(l)
+           wake_dp_deltomg(i,l) = dp_deltomg(l)
+           wake_spread(i,l) = spread(l)
+           wake_dth(i,l) = dth(l)
+           dt_wake(i,l) = dtls(l)
+           dq_wake(i,l) = dqls(l)
+           undi_t(i,l) = tu(l)
+           undi_q(i,l) = qu(l)
+           wake_ddeltat(i,l) = d_deltatw(l)
+           wake_ddeltaq(i,l) = d_deltaqw(l)
+         ENDDO
+       ELSE
+         DO l = 1,klev
+           wake_deltat(i,l)= 0.
+           wake_deltaq(i,l)= 0.
+           wake_d_deltat_gw(i,l)= 0.
+           wake_omgbdth(i,l) = 0.
+           wake_dp_omgb(i,l) = 0.
+           wake_dtKE(i,l) = 0.
+           wake_dqKE(i,l) = 0.
+           wake_omg(i,l) = 0.
+           wake_dp_deltomg(i,l) = 0.
+           wake_spread(i,l) = 0.
+           wake_dth(i,l)=0.
+           dt_wake(i,l)=0.
+           dq_wake(i,l)=0.
+           undi_t(i,l)=te(l)
+           undi_q(i,l)=qe(l)
+         ENDDO
+       ENDIF
+
+       wake_h(i)= hw
+       wake_s(i)= sigmaw
+       wake_pe(i)= wape
+       wake_fip(i)= fip
+       wake_gfl(i) = gfl
+       wake_k(i) =ktopw
+       wake_Cstar(i) = Cstar
+       wake_dens(i) = wdens
+!c
+ 999  CONTINUE
+!c
+      RETURN
+      END SUBROUTINE CALWAKE_scal
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/carbon_cycle_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/carbon_cycle_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/carbon_cycle_mod.F90	(revision 17)
@@ -0,0 +1,482 @@
+MODULE carbon_cycle_mod
+! Controle module for the carbon CO2 tracers :
+!   - Identification
+!   - Get concentrations comming from coupled model or read from file to tracers
+!   - Calculate new RCO2 for radiation scheme
+!   - Calculate new carbon flux for sending to coupled models (PISCES and ORCHIDEE)
+!
+! Author : Josefine GHATTAS, Patricia CADULE
+
+  IMPLICIT NONE
+  SAVE
+  PRIVATE
+  PUBLIC :: carbon_cycle_init, carbon_cycle
+
+! Variables read from parmeter file physiq.def
+  LOGICAL, PUBLIC :: carbon_cycle_tr        ! 3D transport of CO2 in the atmosphere, parameter read in conf_phys
+!$OMP THREADPRIVATE(carbon_cycle_tr)
+  LOGICAL, PUBLIC :: carbon_cycle_cpl       ! Coupling of CO2 fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES) 
+!$OMP THREADPRIVATE(carbon_cycle_cpl)
+
+  LOGICAL :: carbon_cycle_emis_comp_omp=.FALSE.
+  LOGICAL :: carbon_cycle_emis_comp=.FALSE. ! Calculation of emission compatible
+!$OMP THREADPRIVATE(carbon_cycle_emis_comp)
+
+  LOGICAL :: RCO2_inter_omp
+  LOGICAL :: RCO2_inter  ! RCO2 interactive : if true calculate new value RCO2 for the radiation scheme
+!$OMP THREADPRIVATE(RCO2_inter)
+
+! Scalare values when no transport, from physiq.def
+  REAL :: fos_fuel_s_omp
+  REAL :: fos_fuel_s  ! carbon_cycle_fos_fuel dans physiq.def
+!$OMP THREADPRIVATE(fos_fuel_s)
+  REAL :: emis_land_s ! not yet implemented
+!$OMP THREADPRIVATE(emis_land_s)
+
+  REAL :: airetot     ! Total area of the earth surface
+!$OMP THREADPRIVATE(airetot)
+
+  INTEGER :: ntr_co2  ! Number of tracers concerning the carbon cycle
+!$OMP THREADPRIVATE(ntr_co2)
+
+! fco2_ocn_day : flux CO2 from ocean for 1 day (cumulated) [gC/m2/d]. Allocation and initalization done in cpl_mod
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_ocn_day 
+!$OMP THREADPRIVATE(fco2_ocn_day)
+
+  REAL, DIMENSION(:), ALLOCATABLE :: fco2_land_day   ! flux CO2 from land for 1 day (cumulated)  [gC/m2/d]
+!$OMP THREADPRIVATE(fco2_land_day)
+  REAL, DIMENSION(:), ALLOCATABLE :: fco2_lu_day     ! Emission from land use change for 1 day (cumulated) [gC/m2/d]
+!$OMP THREADPRIVATE(fco2_lu_day)
+
+  REAL, DIMENSION(:,:), ALLOCATABLE :: dtr_add       ! Tracer concentration to be injected 
+!$OMP THREADPRIVATE(dtr_add)
+
+! Following 2 fields will be allocated and initialized in surf_land_orchidee
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_inst  ! flux CO2 from land at one time step
+!$OMP THREADPRIVATE(fco2_land_inst)
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_lu_inst    ! Emission from land use change at one time step
+!$OMP THREADPRIVATE(fco2_lu_inst)
+
+! Calculated co2 field to be send to the ocean via the coupler and to ORCHIDEE 
+  REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: co2_send ! Field allocated in phyetat0
+!$OMP THREADPRIVATE(co2_send)
+
+
+  TYPE, PUBLIC ::   co2_trac_type
+     CHARACTER(len = 8) :: name       ! Tracer name in tracer.def
+     INTEGER            :: id         ! Index in total tracer list, tr_seri
+     CHARACTER(len=30)  :: file       ! File name
+     LOGICAL            :: cpl        ! True if this tracers is coupled from ORCHIDEE or PISCES. 
+                                      ! False if read from file.
+     INTEGER            :: updatefreq ! Frequence to inject in second
+     INTEGER            :: readstep   ! Actual time step to read in file
+     LOGICAL            :: updatenow  ! True if this tracer should be updated this time step
+  END TYPE co2_trac_type
+  INTEGER,PARAMETER :: maxco2trac=5  ! Maximum number of different CO2 fluxes
+  TYPE(co2_trac_type), DIMENSION(maxco2trac) :: co2trac
+
+CONTAINS
+  
+  SUBROUTINE carbon_cycle_init(tr_seri, pdtphys, aerosol, radio)
+! This subroutine is called from traclmdz_init, only at first timestep.
+! - Read controle parameters from .def input file
+! - Search for carbon tracers and set default values
+! - Allocate variables
+! - Test for compatibility
+
+    USE dimphy
+    USE comgeomphy
+    USE mod_phys_lmdz_transfert_para
+    USE infotrac
+    USE IOIPSL
+    USE surface_data, ONLY : ok_veget, type_ocean
+    USE phys_cal_mod, ONLY : mth_len
+
+    IMPLICIT NONE
+    INCLUDE "clesphys.h"
+    INCLUDE "iniprint.h"
+ 
+! Input argument
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr_seri ! Concentration Traceur [U/KgA]  
+    REAL,INTENT(IN)                           :: pdtphys ! length of time step in physiq (sec)
+
+! InOutput arguments
+    LOGICAL,DIMENSION(nbtr), INTENT(INOUT) :: aerosol
+    LOGICAL,DIMENSION(nbtr), INTENT(INOUT) :: radio
+
+! Local variables
+    INTEGER               :: ierr, it, iiq, itc
+    INTEGER               :: teststop
+
+
+
+! 1) Read controle parameters from .def input file
+! ------------------------------------------------
+    ! Read fosil fuel value if no transport
+    IF (.NOT. carbon_cycle_tr) THEN
+!$OMP MASTER
+       fos_fuel_s_omp = 0.
+       CALL getin ('carbon_cycle_fos_fuel',fos_fuel_s_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+       fos_fuel_s=fos_fuel_s_omp
+       WRITE(lunout,*) 'carbon_cycle_fos_fuel = ', fos_fuel_s 
+    END IF
+
+
+    ! Read parmeter for calculation compatible emission
+    IF (.NOT. carbon_cycle_tr) THEN
+!$OMP MASTER
+       carbon_cycle_emis_comp_omp=.FALSE.
+       CALL getin('carbon_cycle_emis_comp',carbon_cycle_emis_comp_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+       carbon_cycle_emis_comp=carbon_cycle_emis_comp_omp
+       WRITE(lunout,*) 'carbon_cycle_emis_comp = ',carbon_cycle_emis_comp
+       IF (carbon_cycle_emis_comp) THEN
+          CALL abort_gcm('carbon_cycle_init', 'carbon_cycle_emis_comp option not yet implemented!!',1)
+       END IF
+    END IF
+
+    ! Read parameter for interactive calculation of the CO2 value for the radiation scheme
+!$OMP MASTER
+    RCO2_inter_omp=.FALSE.
+    CALL getin('RCO2_inter',RCO2_inter_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+    RCO2_inter=RCO2_inter_omp
+    WRITE(lunout,*) 'RCO2_inter = ', RCO2_inter
+    IF (RCO2_inter) THEN
+       WRITE(lunout,*) 'RCO2 will be recalculated once a day'
+       WRITE(lunout,*) 'RCO2 initial = ', RCO2
+    END IF
+
+
+! 2) Search for carbon tracers and set default values
+! ---------------------------------------------------
+    itc=0
+    DO it=1,nbtr
+       iiq=niadv(it+2)
+       
+       SELECT CASE(tname(iiq))
+       CASE("fCO2_ocn")
+          itc = itc + 1
+          co2trac(itc)%name='fCO2_ocn'
+          co2trac(itc)%id=it
+          co2trac(itc)%file='fl_co2_ocean.nc'
+          IF (carbon_cycle_cpl .AND. type_ocean=='couple') THEN 
+             co2trac(itc)%cpl=.TRUE.
+             co2trac(itc)%updatefreq = 86400 ! Once a day as the coupling with OASIS/PISCES
+          ELSE
+             co2trac(itc)%cpl=.FALSE.
+             co2trac(itc)%updatefreq = 86400*mth_len ! Once a month
+          END IF
+       CASE("fCO2_land")
+          itc = itc + 1
+          co2trac(itc)%name='fCO2_land'
+          co2trac(itc)%id=it
+          co2trac(itc)%file='fl_co2_land.nc'
+          IF (carbon_cycle_cpl .AND. ok_veget) THEN 
+             co2trac(itc)%cpl=.TRUE.
+             co2trac(itc)%updatefreq = INT(pdtphys) ! Each timestep as the coupling with ORCHIDEE
+          ELSE
+             co2trac(itc)%cpl=.FALSE.
+!             co2trac(itc)%updatefreq = 10800   ! 10800sec = 3H
+             co2trac(itc)%updatefreq = 86400*mth_len ! Once a month
+          END IF
+       CASE("fCO2_land_use")
+          itc = itc + 1
+          co2trac(itc)%name='fCO2_land_use'
+          co2trac(itc)%id=it
+          co2trac(itc)%file='fl_co2_land_use.nc'
+          IF (carbon_cycle_cpl .AND. ok_veget) THEN 
+             co2trac(it)%cpl=.TRUE.
+             co2trac(itc)%updatefreq = INT(pdtphys) ! Each timestep as the coupling with ORCHIDEE
+          ELSE
+             co2trac(itc)%cpl=.FALSE.
+             co2trac(itc)%updatefreq = 10800   ! 10800sec = 3H
+          END IF
+       CASE("fCO2_fos_fuel")
+          itc = itc + 1
+          co2trac(itc)%name='fCO2_fos_fuel'
+          co2trac(itc)%id=it
+          co2trac(itc)%file='fossil_fuel.nc'
+          co2trac(itc)%cpl=.FALSE.       ! This tracer always read from file
+!         co2trac(itc)%updatefreq = 86400  ! 86400sec = 24H Cadule case
+          co2trac(itc)%updatefreq = 86400*mth_len ! Once a month
+       CASE("fCO2_bbg")
+          itc = itc + 1
+          co2trac(itc)%name='fCO2_bbg'
+          co2trac(itc)%id=it
+          co2trac(itc)%file='fl_co2_bbg.nc'
+          co2trac(itc)%cpl=.FALSE.       ! This tracer always read from file
+          co2trac(itc)%updatefreq = 86400*mth_len ! Once a month
+       CASE("fCO2")
+          ! fCO2 : One tracer transporting the total CO2 flux
+          itc = itc + 1
+          co2trac(itc)%name='fCO2'
+          co2trac(itc)%id=it
+          co2trac(itc)%file='fl_co2.nc'
+          IF (carbon_cycle_cpl) THEN 
+             co2trac(itc)%cpl=.TRUE.
+          ELSE
+             co2trac(itc)%cpl=.FALSE.
+          END IF
+          co2trac(itc)%updatefreq = 86400
+          ! DOES THIS WORK ???? Problematic due to implementation of the coupled fluxes...
+          CALL abort_gcm('carbon_cycle_init','transport of total CO2 has to be implemented and tested',1)
+       END SELECT
+    END DO
+
+    ! Total number of carbon CO2 tracers
+    ntr_co2 = itc 
+    
+    ! Definition of control varaiables for the tracers
+    DO it=1,ntr_co2
+       aerosol(co2trac(it)%id) = .FALSE.
+       radio(co2trac(it)%id)   = .FALSE.
+    END DO
+    
+    ! Vector indicating which timestep to read for each tracer
+    ! Always start read in the beginning of the file
+    co2trac(:)%readstep = 0
+   
+
+! 3) Allocate variables
+! ---------------------
+    ! Allocate vector for storing fluxes to inject
+    ALLOCATE(dtr_add(klon,maxco2trac), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 11',1)       
+    
+    ! Allocate variables for cumulating fluxes from ORCHIDEE
+    IF (RCO2_inter) THEN
+       IF (.NOT. carbon_cycle_tr .AND. carbon_cycle_cpl) THEN
+          ALLOCATE(fco2_land_day(klon), stat=ierr)
+          IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 2',1)
+          fco2_land_day(1:klon) = 0.
+          
+          ALLOCATE(fco2_lu_day(klon), stat=ierr)
+          IF (ierr /= 0) CALL abort_gcm('carbon_cycle_init', 'pb in allocation 3',1)
+          fco2_lu_day(1:klon)   = 0.
+       END IF
+    END IF
+
+
+! 4) Test for compatibility
+! -------------------------
+!    IF (carbon_cycle_cpl .AND. type_ocean/='couple') THEN
+!       WRITE(lunout,*) 'Coupling with ocean model is needed for carbon_cycle_cpl'
+!       CALL abort_gcm('carbon_cycle_init', 'coupled ocean is needed for carbon_cycle_cpl',1)
+!    END IF
+!
+!    IF (carbon_cycle_cpl .AND..NOT. ok_veget) THEN
+!       WRITE(lunout,*) 'Coupling with surface land model ORCHDIEE is needed for carbon_cycle_cpl'
+!       CALL abort_gcm('carbon_cycle_init', 'ok_veget is needed for carbon_cycle_cpl',1)
+!    END IF
+
+    ! Compiler test : following should never happen
+    teststop=0
+    DO it=1,teststop
+       CALL abort_gcm('carbon_cycle_init', 'Entering loop from 1 to 0',1)
+    END DO
+
+    IF (ntr_co2==0) THEN
+       ! No carbon tracers found in tracer.def. It is not possible to do carbon cycle 
+       WRITE(lunout,*) 'No carbon tracers found in tracer.def. Not ok with carbon_cycle_tr and/or carbon_cycle_cp'
+       CALL abort_gcm('carbon_cycle_init', 'No carbon tracers found in tracer.def',1)
+    END IF
+    
+! 5) Calculate total area of the earth surface
+! --------------------------------------------
+    CALL reduce_sum(SUM(airephy),airetot)
+    CALL bcast(airetot)
+
+  END SUBROUTINE carbon_cycle_init
+
+
+  SUBROUTINE carbon_cycle(nstep, pdtphys, pctsrf, tr_seri, source)
+! Subroutine for injection of co2 in the tracers
+!
+! - Find out if it is time to update
+! - Get tracer from coupled model or from file
+! - Calculate new RCO2 value for the radiation scheme
+! - Calculate CO2 flux to send to ocean and land models (PISCES and ORCHIDEE)
+
+    USE infotrac
+    USE dimphy
+    USE mod_phys_lmdz_transfert_para
+    USE phys_cal_mod, ONLY : mth_cur, mth_len
+    USE phys_cal_mod, ONLY : day_cur
+    USE comgeomphy
+    USE indice_sol_mod
+
+    IMPLICIT NONE
+
+    INCLUDE "clesphys.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "YOMCST.h"
+
+! In/Output arguments
+    INTEGER,INTENT(IN) :: nstep      ! time step in physiq
+    REAL,INTENT(IN)    :: pdtphys    ! length of time step in physiq (sec)
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf            ! Surface fraction
+    REAL, DIMENSION(klon,klev,nbtr), INTENT(INOUT)  :: tr_seri ! All tracers
+    REAL, DIMENSION(klon,nbtr), INTENT(INOUT)       :: source  ! Source for all tracers
+
+! Local variables
+    INTEGER :: it
+    LOGICAL :: newmonth ! indicates if a new month just started
+    LOGICAL :: newday   ! indicates if a new day just started
+    LOGICAL :: endday   ! indicated if last time step in a day
+
+    REAL, PARAMETER :: fact=1.E-15/2.12  ! transformation factor from gC/m2/day => ppm/m2/day
+    REAL, DIMENSION(klon) :: fco2_tmp
+    REAL :: sumtmp
+    REAL :: delta_co2_ppm
+    
+
+! 1) Calculate logicals indicating if it is a new month, new day or the last time step in a day (end day)
+! -------------------------------------------------------------------------------------------------------
+
+    newday = .FALSE.; endday = .FALSE.; newmonth = .FALSE.
+
+    IF (MOD(nstep,INT(86400./pdtphys))==1) newday=.TRUE.
+    IF (MOD(nstep,INT(86400./pdtphys))==0) endday=.TRUE.
+    IF (newday .AND. day_cur==1) newmonth=.TRUE.
+
+! 2)  For each carbon tracer find out if it is time to inject (update)
+! --------------------------------------------------------------------
+    DO it = 1, ntr_co2
+       IF ( MOD(nstep,INT(co2trac(it)%updatefreq/pdtphys)) == 1 ) THEN
+          co2trac(it)%updatenow = .TRUE.
+       ELSE
+          co2trac(it)%updatenow = .FALSE.
+       END IF
+    END DO
+
+! 3) Get tracer update
+! --------------------------------------
+    DO it = 1, ntr_co2
+       IF ( co2trac(it)%updatenow ) THEN
+          IF ( co2trac(it)%cpl ) THEN
+             ! Get tracer from coupled model
+             SELECT CASE(co2trac(it)%name)
+             CASE('fCO2_land')     ! from ORCHIDEE
+                dtr_add(:,it) = fco2_land_inst(:)*pctsrf(:,is_ter)*fact ! [ppm/m2/day]
+             CASE('fCO2_land_use') ! from ORCHIDEE
+                dtr_add(:,it) = fco2_lu_inst(:)  *pctsrf(:,is_ter)*fact ! [ppm/m2/day]
+             CASE('fCO2_ocn')      ! from PISCES
+                dtr_add(:,it) = fco2_ocn_day(:)  *pctsrf(:,is_oce)*fact ! [ppm/m2/day]
+             CASE DEFAULT
+                WRITE(lunout,*) 'Error with tracer ',co2trac(it)%name
+                CALL abort_gcm('carbon_cycle', 'No coupling implemented for this tracer',1)
+             END SELECT
+          ELSE
+             ! Read tracer from file
+             co2trac(it)%readstep = co2trac(it)%readstep + 1 ! increment time step in file
+! Patricia   CALL read_map2D(co2trac(it)%file,'fco2',co2trac(it)%readstep,.FALSE.,dtr_add(:,it))
+             CALL read_map2D(co2trac(it)%file,'fco2',co2trac(it)%readstep,.TRUE.,dtr_add(:,it))
+
+             ! Converte from kgC/m2/h to kgC/m2/s
+             dtr_add(:,it) = dtr_add(:,it)/3600
+             ! Add individual treatment of values read from file
+             SELECT CASE(co2trac(it)%name)
+             CASE('fCO2_land')
+                dtr_add(:,it) = dtr_add(:,it) *pctsrf(:,is_ter)
+             CASE('fCO2_land_use')
+                dtr_add(:,it) = dtr_add(:,it) *pctsrf(:,is_ter)
+             CASE('fCO2_ocn')
+                dtr_add(:,it) = dtr_add(:,it) *pctsrf(:,is_oce)
+! Patricia :
+!             CASE('fCO2_fos_fuel')
+!                dtr_add(:,it) = dtr_add(:,it)/mth_len
+!                co2trac(it)%readstep = 0 ! Always read same value for fossil fuel(Cadule case)
+             END SELECT
+          END IF
+       END IF
+    END DO
+
+! 4) Update co2 tracers : 
+!    Loop over all carbon tracers and add source
+! ------------------------------------------------------------------
+    IF (carbon_cycle_tr) THEN
+       DO it = 1, ntr_co2
+          IF (.FALSE.) THEN
+             tr_seri(1:klon,1,co2trac(it)%id) = tr_seri(1:klon,1,co2trac(it)%id) + dtr_add(1:klon,it)
+             source(1:klon,co2trac(it)%id) = 0.
+          ELSE
+             source(1:klon,co2trac(it)%id) = dtr_add(1:klon,it)
+          END IF
+       END DO
+    END IF
+
+
+! 5) Calculations for new CO2 value for the radiation scheme(instead of reading value from .def)
+! ----------------------------------------------------------------------------------------------
+    IF (RCO2_inter) THEN
+       ! Cumulate fluxes from ORCHIDEE at each timestep
+       IF (.NOT. carbon_cycle_tr .AND. carbon_cycle_cpl) THEN
+          IF (newday) THEN ! Reset cumulative variables once a day 
+             fco2_land_day(1:klon) = 0.
+             fco2_lu_day(1:klon)   = 0.
+          END IF
+          fco2_land_day(1:klon) = fco2_land_day(1:klon) + fco2_land_inst(1:klon) ![gC/m2/day]
+          fco2_lu_day(1:klon)   = fco2_lu_day(1:klon)   + fco2_lu_inst(1:klon)   ![gC/m2/day]
+       END IF
+
+       ! At the end of a new day, calculate a mean scalare value of CO2
+       ! JG : Ici on utilise uniquement le traceur du premier couche du modele. Est-ce que c'est correcte ? 
+       IF (endday) THEN
+
+          IF (carbon_cycle_tr) THEN
+             ! Sum all co2 tracers to get the total delta CO2 flux
+             fco2_tmp(:) = 0.
+             DO it = 1, ntr_co2
+                fco2_tmp(1:klon) = fco2_tmp(1:klon) + tr_seri(1:klon,1,co2trac(it)%id)
+             END DO
+             
+          ELSE IF (carbon_cycle_cpl) THEN ! no carbon_cycle_tr
+             ! Sum co2 fluxes comming from coupled models and parameter for fossil fuel
+             fco2_tmp(1:klon) = fos_fuel_s + ((fco2_lu_day(1:klon) + fco2_land_day(1:klon))*pctsrf(1:klon,is_ter) &
+                  + fco2_ocn_day(:)*pctsrf(:,is_oce)) * fact
+          END IF
+
+          ! Calculate a global mean value of delta CO2 flux
+          fco2_tmp(1:klon) = fco2_tmp(1:klon) * airephy(1:klon)
+          CALL reduce_sum(SUM(fco2_tmp),sumtmp)
+          CALL bcast(sumtmp)
+          delta_co2_ppm = sumtmp/airetot
+          
+          ! Add initial value for co2_ppm and delta value
+          co2_ppm = co2_ppm0 + delta_co2_ppm
+          
+          ! Transformation of atmospheric CO2 concentration for the radiation code
+          RCO2 = co2_ppm * 1.0e-06  * 44.011/28.97 
+          
+          WRITE(lunout,*) 'RCO2 is now updated! RCO2 = ', RCO2
+       END IF ! endday
+
+    END IF ! RCO2_inter
+
+
+! 6) Calculate CO2 flux to send to ocean and land models : PISCES and ORCHIDEE         
+! ----------------------------------------------------------------------------
+    IF (carbon_cycle_cpl) THEN
+
+       IF (carbon_cycle_tr) THEN
+          ! Sum all co2 tracers to get the total delta CO2 flux at first model layer
+          fco2_tmp(:) = 0.
+          DO it = 1, ntr_co2
+             fco2_tmp(1:klon) = fco2_tmp(1:klon) + tr_seri(1:klon,1,co2trac(it)%id)
+          END DO
+          co2_send(1:klon) = fco2_tmp(1:klon) + co2_ppm0
+       ELSE
+          ! Send a scalare value in 2D variable to ocean and land model (PISCES and ORCHIDEE)
+          co2_send(1:klon) = co2_ppm
+       END IF
+
+    END IF
+
+  END SUBROUTINE carbon_cycle
+  
+END MODULE carbon_cycle_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cfmip_point_locations.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cfmip_point_locations.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cfmip_point_locations.F90	(revision 17)
@@ -0,0 +1,121 @@
+MODULE cfmip_point_locations
+  IMPLICIT NONE
+
+CONTAINS
+
+ SUBROUTINE read_CFMIP_point_locations(npCFMIP, tab, lonCFMIP, latCFMIP)
+  IMPLICIT none
+  INTEGER :: npCFMIP
+  REAL, DIMENSION(npCFMIP) :: lonCFMIP, latCFMIP
+  INTEGER :: tab(npCFMIP), np
+
+  WRITE(*,*) 'npCFMIP=',npCFMIP
+! OPEN(20, file="pointlocations.txt",status='old')
+  OPEN(20, file="pointlocations.txt",status='old',err=999)
+  OPEN(21, file="pointlocations_lon180.txt")
+  np=1
+10 READ(20,*) tab(np), lonCFMIP(np), latCFMIP(np)
+!!! passage de 0-360 a -180/180
+   IF (lonCFMIP(np).GT.180.) THEN
+    lonCFMIP(np)=lonCFMIP(np)-360.
+   ENDIF 
+   WRITE(21,*) np, lonCFMIP(np), latCFMIP(np)
+   np=np+1
+   IF(np.LE.npCFMIP) THEN 
+    GOTO 10
+   ENDIF
+   CLOSE(20)
+   CLOSE(21)
+999 RETURN
+ END SUBROUTINE read_CFMIP_point_locations
+
+ SUBROUTINE LMDZ_CFMIP_point_locations(npCFMIP, lonCFMIP, latCFMIP, &
+  tabijGCM, lonGCM, latGCM, ipt, jpt)
+  USE dimphy
+  USE iophy
+  USE mod_grid_phy_lmdz
+
+  IMPLICIT none 
+#include "dimensions.h"
+  INTEGER :: npCFMIP
+  REAL, DIMENSION(npCFMIP) :: lonCFMIP, latCFMIP
+  INTEGER :: i, j, np, ip
+  INTEGER, DIMENSION(npCFMIP) :: ipt, jpt 
+  REAL :: dlon1, dlon2
+  REAL :: dlat1, dlat2
+  REAL, DIMENSION(iim+1) :: lon
+  INTEGER, DIMENSION(npCFMIP) :: tabijGCM
+  REAL, DIMENSION(npCFMIP) :: lonGCM, latGCM
+
+  lon(1:iim)=io_lon(:)
+  lon(iim+1)=-1*lon(1)
+  OPEN(22, file="LMDZ_pointsCFMIP.txt")
+  DO np=1, npCFMIP
+  DO i=1, iim
+!
+! PRINT*,'IM np i lonCF lonGCM lonGCM+1',np,i,lonCFMIP(np),lon(i), &
+!  lon(i+1)
+!
+   IF(lonCFMIP(np).GE.lon(i).AND.lonCFMIP(np).LT.lon(i+1)) THEN
+    dlon1 = abs (lonCFMIP(np) - lon(i))
+    dlon2 = abs (lonCFMIP(np) - lon(i+1))
+    IF (dlon1.LE.dlon2) THEN
+     ipt(np)=i
+    ELSE
+     ipt(np)=i+1
+    ENDIF
+   ENDIF
+  END DO
+  END DO
+!
+   np=1
+30 j=1
+40 IF(latCFMIP(np).LE.io_lat(j).AND.latCFMIP(np).GE.io_lat(j+1)) THEN
+    dlat1 = abs (latCFMIP(np) - io_lat(j))
+    dlat2 = abs (latCFMIP(np) - io_lat(j+1))
+    IF (dlat1.LE.dlat2) THEN
+     jpt(np)=j
+    ELSE
+     jpt(np)=j+1
+    ENDIF
+    np=np+1
+    IF(np.LE.npCFMIP) THEN
+     GOTO 30
+    ENDIF 
+   ELSE
+    j=j+1
+    IF(j.LE.jjm) THEN 
+     GOTO 40
+    ENDIF
+   ENDIF
+
+  DO np=1, npCFMIP
+   WRITE(22,*) lon(ipt(np)), io_lat(jpt(np))
+  ENDDO
+  CLOSE(22)
+
+  OPEN(23, file="pointsCFMIPvsLMDZ.txt")
+    DO ip=1, npCFMIP
+     lonGCM(ip)=lon(ipt(ip))
+     latGCM(ip)=io_lat(jpt(ip))
+     if(jpt(ip).GE.2.AND.jpt(ip).LE.jjm) THEN     
+      tabijGCM(ip)=1+(jpt(ip)-2)*iim+ipt(ip)
+     else if(jpt(ip).EQ.1) THEN
+      tabijGCM(ip)=1
+     else if(jpt(ip).EQ.jjm+1) THEN
+      tabijGCM(ip)=klon_glo
+     else 
+      print*,'ip jpt tabijGCM',ip,jpt(ip),tabijGCM(ip)
+     endif
+!    PRINT*,'CFMIP ip lon lat tabijGCM',ip,lonGCM(ip),latGCM(ip),tabijGCM(ip)
+    ENDDO
+    DO ip=1, npCFMIP
+     if(lonGCM(ip).EQ.io_lon(1)) lonGCM(ip)=360.+lonGCM(ip)
+    ENDDO
+   DO i=1, npCFMIP
+    WRITE(23,*) i, lonCFMIP(i), latCFMIP(i), lonGCM(i), latGCM(i), tabijGCM(i)
+   ENDDO
+   CLOSE(23)
+ END SUBROUTINE LMDZ_CFMIP_point_locations 
+
+END MODULE CFMIP_point_locations
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/change_srf_frac_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/change_srf_frac_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/change_srf_frac_mod.F90	(revision 17)
@@ -0,0 +1,166 @@
+!
+! $Header$
+!
+MODULE change_srf_frac_mod
+
+  IMPLICIT NONE
+
+CONTAINS
+! 
+! Change Surface Fractions
+! Author J Ghattas 2008
+
+  SUBROUTINE change_srf_frac(itime, dtime, jour, &
+       pctsrf, alb1, alb2, tsurf, ustar, u10m, v10m, pbl_tke)
+!
+! This subroutine is called from physiq.F at each timestep. 
+! 1- For each type of ocean (force, slab, couple) receive new fractions only if
+!    it's time to modify (is_modified=true). Otherwise nothing is done (is_modified=false).   
+! If received new fraction :
+! 2- Tests and ajustements are done on the fractions 
+! 3- Initialize variables where a new fraction(new or melted ice) has appered, 
+!
+
+    USE dimphy 
+    USE surface_data, ONLY : type_ocean
+    USE limit_read_mod
+    USE pbl_surface_mod, ONLY : pbl_surface_newfrac
+    USE cpl_mod, ONLY : cpl_receive_frac
+    USE ocean_slab_mod, ONLY : ocean_slab_frac
+    USE indice_sol_mod
+
+    INCLUDE "iniprint.h"
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime   ! current time step
+    INTEGER, INTENT(IN)                     :: jour    ! day of the year
+    REAL,    INTENT(IN)                     :: dtime   ! length of time step (s)
+  
+! In-Output arguments
+!****************************************************************************************
+   
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf ! sub-surface fraction
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: alb1   ! albedo first interval in SW spektrum
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: alb2   ! albedo second interval in SW spektrum
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: tsurf
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: ustar
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: u10m
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: v10m
+    REAL, DIMENSION(klon,klev+1,nbsrf), INTENT(INOUT) :: pbl_tke
+
+! Loccal variables
+!****************************************************************************************
+    INTEGER                        :: i, nsrf
+    LOGICAL                        :: is_modified   ! true if pctsrf is modified at this time step
+    LOGICAL                        :: test_sum=.FALSE.
+    LOGICAL, DIMENSION(klon,nbsrf) :: new_surf
+    REAL, DIMENSION(klon,nbsrf)    :: pctsrf_old    ! fraction from previous time-step
+    REAL                           :: tmpsum
+
+    pctsrf_old(:,:) = pctsrf(:,:)
+!****************************************************************************************
+! 1) 
+! For each type of ocean (force, slab, couple) receive new fractions only if it's time  
+! to modify (is_modified=true). Otherwise nothing is done (is_modified=false).   
+!****************************************************************************************
+    SELECT CASE (type_ocean)
+    CASE ('force')
+       ! Read fraction from limit.nc
+! L. Fita, LMD. Ovember 2013. Removing reading from 'limit.nc'
+!!       CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
+       PRINT *,'  L. Fita. LMDZ+WRF: Already loaded, no limit.nc !'
+    CASE ('slab')
+       ! Get fraction from slab module
+       CALL ocean_slab_frac(itime, dtime, jour, pctsrf, is_modified)
+    CASE ('couple')
+       ! Get fraction from the coupler
+       CALL cpl_receive_frac(itime, dtime, pctsrf, is_modified)
+    END SELECT
+
+
+!****************************************************************************************
+! 2) 
+! Tests and ajustements on the new fractions :
+! - Put to zero fractions that are too small
+! - Test total fraction sum is one for each grid point
+!
+!****************************************************************************************
+    IF (is_modified) THEN
+  
+! Test and exit if a fraction is negative
+       IF (MINVAL(pctsrf(:,:)) < 0.) THEN
+          WRITE(lunout,*)'Warning! One or several fractions are negative, itime=',itime
+          WRITE(lunout,*)'at point = ',MINLOC(pctsrf(:,:))
+          WRITE(lunout,*)'value = ',MINVAL(pctsrf(:,:)) 
+          CALL abort_gcm('change_srf_frac','Negative fraction',1)
+       END IF
+
+! Optional test on the incoming fraction 
+       IF (test_sum) THEN
+          DO i= 1, klon
+             tmpsum = SUM(pctsrf(i,:))
+             IF (ABS(1. - tmpsum) > 0.05) CALL abort_gcm('change_srf_frac','Total fraction not equal 1.',1)
+          END DO
+       END IF
+
+! Test for too small fractions of the sum land+landice and ocean+sea-ice
+       WHERE ((pctsrf(:,is_ter) + pctsrf(:,is_lic)) < 2*EPSFRA)
+          pctsrf(:,is_ter) = 0.
+          pctsrf(:,is_lic) = 0.
+       END WHERE
+
+       WHERE ((pctsrf(:,is_oce) + pctsrf(:,is_sic)) < 2*EPSFRA)
+          pctsrf(:,is_oce) = 0.
+          pctsrf(:,is_sic) = 0.
+       END WHERE
+
+! Normalize to force total fraction to be equal one
+       DO i= 1, klon
+          tmpsum = SUM(pctsrf(i,:))
+          DO nsrf = 1, nbsrf
+             pctsrf(i,nsrf) = pctsrf(i,nsrf) / tmpsum
+          END DO
+       END DO
+
+! Test for too small fractions at each sub-surface
+       WHERE (pctsrf(:,is_ter) < EPSFRA)
+          pctsrf(:,is_lic) = pctsrf(:,is_ter) + pctsrf(:,is_lic)
+          pctsrf(:,is_ter) = 0.
+       END WHERE
+
+       WHERE (pctsrf(:,is_lic) < EPSFRA)
+          pctsrf(:,is_ter) = pctsrf(:,is_ter) + pctsrf(:,is_lic)
+          pctsrf(:,is_lic) = 0.
+       END WHERE
+
+       WHERE (pctsrf(:,is_oce) < EPSFRA)
+          pctsrf(:,is_sic) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+          pctsrf(:,is_oce) = 0.
+       END WHERE
+
+       WHERE (pctsrf(:,is_sic) < EPSFRA)
+          pctsrf(:,is_oce) = pctsrf(:,is_oce) + pctsrf(:,is_sic)
+          pctsrf(:,is_sic) = 0.
+       END WHERE
+
+!****************************************************************************************
+! 3)
+! Initialize variables where a new fraction has appered, 
+! i.e. where new sea ice has been formed
+! or where ice free ocean has appread in a grid cell
+! 
+!****************************************************************************************
+       CALL pbl_surface_newfrac(itime, pctsrf, pctsrf_old, tsurf, alb1, alb2, ustar, u10m, v10m, pbl_tke)
+
+    ELSE
+       ! No modifcation should be done
+       pctsrf(:,:) = pctsrf_old(:,:)
+
+    END IF ! is_modified
+
+  END SUBROUTINE change_srf_frac
+
+
+END MODULE change_srf_frac_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/chem.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/chem.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/chem.h	(revision 17)
@@ -0,0 +1,14 @@
+!
+! $Header$
+!
+      INTEGER idms, iso2, iso4, ih2s, idmso, imsa, ih2o2
+      PARAMETER (idms=1, iso2=2, iso4=3)
+      PARAMETER (ih2s=4, idmso=5, imsa=6, ih2o2=7)
+
+      REAL n_avogadro, masse_s, masse_so4, rho_water, rho_ice
+      PARAMETER (n_avogadro=6.02E23)                  !--molec mol-1
+      PARAMETER (masse_s=32.0)                        !--g mol-1
+      PARAMETER (masse_so4=96.0)                      !--g mol-1
+      PARAMETER (rho_water=1000.0)                    !--kg m-3
+      PARAMETER (rho_ice=500.0)                       !--kg m-3
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/clcdrag.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/clcdrag.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/clcdrag.F90	(revision 17)
@@ -0,0 +1,135 @@
+!
+!$Id: clcdrag.F90 1795 2013-07-18 08:20:28Z emillour $
+!
+SUBROUTINE clcdrag(knon, nsrf, paprs, pplay,&
+     u1, v1, t1, q1, &
+     tsurf, qsurf, rugos, &
+     pcfm, pcfh)
+
+  USE dimphy
+  USE indice_sol_mod
+
+  IMPLICIT NONE
+! ================================================================= c
+!
+! Objet : calcul des cdrags pour le moment (pcfm) et 
+!         les flux de chaleur sensible et latente (pcfh).   
+!
+! ================================================================= c
+!
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
+! u1-------input-R- vent zonal au 1er niveau du modele
+! v1-------input-R- vent meridien au 1er niveau du modele
+! t1-------input-R- temperature de l'air au 1er niveau du modele
+! q1-------input-R- humidite de l'air au 1er niveau du modele
+! tsurf------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite de l'air a la surface
+! rugos---input-R- rugosite
+!
+! pcfm---output-R- cdrag pour le moment 
+! pcfh---output-R- cdrag pour les flux de chaleur latente et sensible
+!
+  INTEGER, INTENT(IN)                      :: knon, nsrf
+  REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+  REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1, t1, q1
+  REAL, DIMENSION(klon), INTENT(IN)        :: tsurf, qsurf
+  REAL, DIMENSION(klon), INTENT(IN)        :: rugos
+  REAL, DIMENSION(klon), INTENT(OUT)       :: pcfm, pcfh
+!
+! ================================================================= c
+!
+  INCLUDE "YOMCST.h"
+  INCLUDE "YOETHF.h"
+  INCLUDE "clesphys.h"
+!
+! Quelques constantes et options:
+!!$PB      REAL, PARAMETER :: ckap=0.35, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2
+  REAL, PARAMETER :: ckap=0.40, cb=5.0, cc=5.0, cd=5.0, cepdu2=(0.1)**2
+!
+! Variables locales :
+  INTEGER               :: i
+  REAL                  :: zdu2, ztsolv
+  REAL                  :: ztvd, zscf
+  REAL                  :: zucf, zcr
+  REAL                  :: friv, frih
+  REAL, DIMENSION(klon) :: zcfm1, zcfm2
+  REAL, DIMENSION(klon) :: zcfh1, zcfh2
+  REAL, DIMENSION(klon) :: zcdn
+  REAL, DIMENSION(klon) :: zri
+  REAL, DIMENSION(klon) :: zgeop1       ! geopotentiel au 1er niveau du modele
+  LOGICAL, PARAMETER    :: zxli=.FALSE. ! calcul des cdrags selon Laurent Li
+!
+! Fonctions thermodynamiques et fonctions d'instabilite
+  REAL                  :: fsta, fins, x
+  fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+  fins(x) = SQRT(1.0-18.0*x)
+! ================================================================= c
+!
+! Calculer le geopotentiel du premier couche de modele
+!
+  DO i = 1, knon
+     zgeop1(i) = RD * t1(i) / (0.5*(paprs(i,1)+pplay(i,1))) &
+          * (paprs(i,1)-pplay(i,1))
+  END DO
+! ================================================================= c
+!
+! Calculer le frottement au sol (Cdrag)
+!
+  DO i = 1, knon
+     zdu2 = MAX(cepdu2,u1(i)**2+v1(i)**2)
+     ztsolv = tsurf(i) * (1.0+RETV*qsurf(i))
+     ztvd = (t1(i)+zgeop1(i)/RCPD/(1.+RVTMP2*q1(i))) &
+          *(1.+RETV*q1(i))
+     zri(i) = zgeop1(i)*(ztvd-ztsolv)/(zdu2*ztvd)
+     zcdn(i) = (ckap/LOG(1.+zgeop1(i)/(RG*rugos(i))))**2
+
+!!$        IF (zri(i) .ge. 0.) THEN      ! situation stable
+     IF (zri(i) .GT. 0.) THEN      ! situation stable
+        zri(i) = MIN(20.,zri(i))
+        IF (.NOT.zxli) THEN
+           zscf = SQRT(1.+cd*ABS(zri(i)))
+           FRIV = AMAX1(1. / (1.+2.*CB*zri(i)/ZSCF), 0.1)
+           zcfm1(i) = zcdn(i) * FRIV
+           FRIH = AMAX1(1./ (1.+3.*CB*zri(i)*ZSCF), 0.1 )
+!!$  PB          zcfh1(i) = zcdn(i) * FRIH
+!!$ PB           zcfh1(i) = f_cdrag_stable * zcdn(i) * FRIH
+           zcfh1(i) = f_cdrag_ter * zcdn(i) * FRIH
+           IF(nsrf.EQ.is_oce) zcfh1(i) = f_cdrag_oce * zcdn(i) * FRIH
+!!$ PB
+           pcfm(i) = zcfm1(i)
+           pcfh(i) = zcfh1(i)
+        ELSE
+           pcfm(i) = zcdn(i)* fsta(zri(i))
+           pcfh(i) = zcdn(i)* fsta(zri(i))
+        ENDIF
+     ELSE                          ! situation instable
+        IF (.NOT.zxli) THEN
+           zucf = 1./(1.+3.0*cb*cc*zcdn(i)*SQRT(ABS(zri(i)) &
+                *(1.0+zgeop1(i)/(RG*rugos(i)))))
+           zcfm2(i) = zcdn(i)*amax1((1.-2.0*cb*zri(i)*zucf),0.1)
+!!$PB            zcfh2(i) = zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1)
+           zcfh2(i) = f_cdrag_ter*zcdn(i)*amax1((1.-3.0*cb*zri(i)*zucf),0.1)
+           pcfm(i) = zcfm2(i)
+           pcfh(i) = zcfh2(i)
+        ELSE
+           pcfm(i) = zcdn(i)* fins(zri(i))
+           pcfh(i) = zcdn(i)* fins(zri(i))
+        ENDIF
+        zcr = (0.0016/(zcdn(i)*SQRT(zdu2)))*ABS(ztvd-ztsolv)**(1./3.)
+        IF(nsrf.EQ.is_oce) pcfh(i) =f_cdrag_oce* zcdn(i)*(1.0+zcr**1.25)**(1./1.25)
+     ENDIF
+  END DO
+
+! ================================================================= c
+     
+  ! IM cf JLD : on seuille cdrag_m et cdrag_h
+  IF (nsrf == is_oce) THEN
+     DO i=1,knon
+        pcfm(i)=MIN(pcfm(i),cdmmax)
+        pcfh(i)=MIN(pcfh(i),cdhmax)
+     END DO
+  END IF
+
+END SUBROUTINE clcdrag
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/clesphys.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/clesphys.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/clesphys.h	(revision 17)
@@ -0,0 +1,107 @@
+
+!
+! $Id: clesphys.h 1795 2013-07-18 08:20:28Z emillour $
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation 
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!..include cles_phys.h
+!
+       LOGICAL cycle_diurne,soil_model,new_oliq,ok_orodr,ok_orolf 
+       LOGICAL ok_limitvrai
+       INTEGER nbapp_rad, iflag_con,iflag_ener_conserv
+       REAL co2_ppm, co2_ppm0, solaire
+       REAL(kind=8) RCO2, RCH4, RN2O, RCFC11, RCFC12  
+       REAL(kind=8) RCO2_act, RCH4_act, RN2O_act, RCFC11_act, RCFC12_act  
+       REAL(kind=8) CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt
+!IM ajout CFMIP2/CMIP5
+       REAL co2_ppm_per
+       LOGICAL ok_4xCO2atm
+       REAL(kind=8) RCO2_per,RCH4_per,RN2O_per,RCFC11_per,RCFC12_per
+       REAL(kind=8) CH4_ppb_per,N2O_ppb_per,CFC11_ppt_per,CFC12_ppt_per
+
+!OM ---> correction du bilan d'eau global
+!OM Correction sur precip KE
+       REAL cvl_corr
+!OM Fonte calotte dans bilan eau
+       LOGICAL ok_lic_melt
+
+!IM simulateur ISCCP 
+       INTEGER top_height, overlap
+!IM seuils cdrm, cdrh
+       REAL cdmmax, cdhmax
+!IM param. stabilite s/ terres et en dehors
+       REAL ksta, ksta_ter
+!IM ok_kzmin : clef calcul Kzmin dans la CL de surface cf FH
+       LOGICAL ok_kzmin
+!IM, MAFo fmagic, pmagic : parametres - additionnel et multiplicatif - 
+!                          pour regler l albedo sur ocean
+       REAL fmagic, pmagic
+! Hauteur (imposee) du contenu en eau du sol
+           REAL qsol0
+! Frottement au sol (Cdrag)
+       Real f_cdrag_ter,f_cdrag_oce
+! Rugoro
+       Real f_rugoro
+
+!IM lev_histhf  : niveau sorties 6h
+!IM lev_histday : niveau sorties journalieres
+!IM lev_histmth : niveau sorties mensuelles
+!IM lev_histdayNMC : on peut sortir soit sur 8 (comme AR5) ou bien 
+!                    sur 17 niveaux de pression
+       INTEGER lev_histhf, lev_histday, lev_histmth
+       INTEGER lev_histdayNMC
+       Integer lev_histins, lev_histLES  
+!IM ok_histNMC  : sortie fichiers niveaux de pression (histmthNMC, histdayNMC, histhfNMC)
+!IM freq_outNMC : frequences de sortie fichiers niveaux de pression (histmthNMC, histdayNMC, histhfNMC)
+!IM freq_calNMC : frequences de calcul fis. hist*NMC.nc
+!IM pasphys : pas de temps de physique (secondes)
+       REAL pasphys
+       LOGICAL ok_histNMC(3)
+       REAL freq_outNMC(3) , freq_calNMC(3)
+       CHARACTER(len=4) type_run
+! aer_type: pour utiliser un fichier constant dans readaerosol 
+       CHARACTER*8 :: aer_type 
+       LOGICAL ok_isccp, ok_regdyn
+       REAL lonmin_ins, lonmax_ins, latmin_ins, latmax_ins
+       REAL ecrit_ins, ecrit_hf, ecrit_day
+       REAL ecrit_mth, ecrit_tra, ecrit_reg 
+       REAL ecrit_LES
+       REAL freq_ISCCP, ecrit_ISCCP
+       REAL freq_COSP
+       LOGICAL :: ok_cosp,ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP
+       INTEGER :: ip_ebil_phy, iflag_rrtm
+       LOGICAL :: ok_strato
+       LOGICAL :: ok_hines
+
+       COMMON/clesphys/cycle_diurne, soil_model, new_oliq,              &
+     &     ok_orodr, ok_orolf, ok_limitvrai, nbapp_rad, iflag_con       &
+     &     , iflag_ener_conserv                                         &
+     &     , co2_ppm, solaire                                           &
+     &     , RCO2, RCH4, RN2O, RCFC11, RCFC12                           &
+     &     , RCO2_act, RCH4_act, RN2O_act, RCFC11_act, RCFC12_act       &
+     &     , ok_4xCO2atm                                                & 
+     &     , RCO2_per, RCH4_per, RN2O_per, RCFC11_per, RCFC12_per       &
+     &     , CH4_ppb, N2O_ppb, CFC11_ppt, CFC12_ppt                     &
+     &     , CH4_ppb_per, N2O_ppb_per, CFC11_ppt_per, CFC12_ppt_per     &
+     &     , top_height, overlap, cdmmax, cdhmax, ksta, ksta_ter        &
+     &     , ok_kzmin, fmagic, pmagic                                   &
+     &     , f_cdrag_ter,f_cdrag_oce,f_rugoro                           &
+     &     , lev_histhf, lev_histday, lev_histmth                       &
+     &     , lev_histins, lev_histLES, lev_histdayNMC                   &
+     &     , pasphys, ok_histNMC, freq_outNMC, freq_calNMC              &
+     &     , type_run, ok_isccp, ok_regdyn, ok_cosp                     &
+     &     , ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP                     &
+     &     , lonmin_ins, lonmax_ins, latmin_ins, latmax_ins             &
+     &     , ecrit_ins, ecrit_hf, ecrit_day                             &
+     &     , ecrit_mth, ecrit_tra, ecrit_reg                            &
+     &     , freq_ISCCP, ecrit_ISCCP, freq_COSP, ip_ebil_phy            &
+     &     , ok_lic_melt, cvl_corr, aer_type                            &
+     &     , qsol0, iflag_rrtm, ok_strato,ok_hines,ecrit_LES            &
+     &     , co2_ppm0
+     
+       save /clesphys/
+!$OMP THREADPRIVATE(/clesphys/)
+ 
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/climb_hq_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/climb_hq_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/climb_hq_mod.F90	(revision 17)
@@ -0,0 +1,388 @@
+MODULE climb_hq_mod
+!
+! Module to solve the verctical diffusion of "q" and "H"; 
+! specific humidity and potential energi.
+!
+  USE dimphy
+
+  IMPLICIT NONE
+  SAVE 
+  PRIVATE
+  PUBLIC :: climb_hq_down, climb_hq_up
+
+  REAL, DIMENSION(:,:), ALLOCATABLE :: gamaq, gamah
+  !$OMP THREADPRIVATE(gamaq,gamah)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_Q, Dcoef_Q
+  !$OMP THREADPRIVATE(Ccoef_Q, Dcoef_Q)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Ccoef_H, Dcoef_H
+  !$OMP THREADPRIVATE(Ccoef_H, Dcoef_H)
+  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_Q, Bcoef_Q
+  !$OMP THREADPRIVATE(Acoef_Q, Bcoef_Q)
+  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_H, Bcoef_H
+  !$OMP THREADPRIVATE(Acoef_H, Bcoef_H)
+  REAL, DIMENSION(:,:), ALLOCATABLE :: Kcoefhq
+  !$OMP THREADPRIVATE(Kcoefhq)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_hq_down(knon, coefhq, paprs, pplay, &
+       delp, temp, q, dtime, &
+       Acoef_H_out, Acoef_Q_out, Bcoef_H_out, Bcoef_Q_out)
+
+    INCLUDE "YOMCST.h"
+! This routine calculates recursivly the coefficients C and D
+! for the quantity X=[Q,H] in equation X(k) = C(k) + D(k)*X(k-1), where k is
+! the index of the vertical layer.
+!
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coefhq
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay 
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs 
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp, delp  ! temperature
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: q
+    REAL, INTENT(IN)                         :: dtime
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_H_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_Q_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_H_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_Q_out
+
+! Local variables
+!****************************************************************************************
+    LOGICAL, SAVE                            :: first=.TRUE.
+    !$OMP THREADPRIVATE(first)
+    REAL, DIMENSION(klon,klev)               :: local_H
+    REAL, DIMENSION(klon)                    :: psref 
+    REAL                                     :: delz, pkh
+    INTEGER                                  :: k, i, ierr
+
+! Include
+!****************************************************************************************
+    INCLUDE "compbl.h"    
+
+
+!****************************************************************************************
+! 1)
+! Allocation at first time step only
+!   
+!****************************************************************************************
+
+    IF (first) THEN
+       first=.FALSE.
+       ALLOCATE(Ccoef_Q(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_Q, ierr=', ierr
+       
+       ALLOCATE(Dcoef_Q(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_Q, ierr=', ierr
+       
+       ALLOCATE(Ccoef_H(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Ccoef_H, ierr=', ierr
+       
+       ALLOCATE(Dcoef_H(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Dcoef_H, ierr=', ierr
+       
+       ALLOCATE(Acoef_Q(klon), Bcoef_Q(klon), Acoef_H(klon), Bcoef_H(klon), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Acoef_X and Bcoef_X, ierr=', ierr
+       
+       ALLOCATE(Kcoefhq(klon,klev), STAT=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in allloc Kcoefhq, ierr=', ierr
+       
+       ALLOCATE(gamaq(1:klon,2:klev), STAT=ierr)
+       IF ( ierr /= 0 ) PRINT*,' pb in allloc gamaq, ierr=', ierr
+       
+       ALLOCATE(gamah(1:klon,2:klev), STAT=ierr)
+       IF ( ierr /= 0 ) PRINT*,' pb in allloc gamah, ierr=', ierr
+    END IF
+
+!****************************************************************************************
+! 2)
+! Definition of the coeficient K 
+!
+!****************************************************************************************
+    Kcoefhq(:,:) = 0.0
+    DO k = 2, klev
+       DO i = 1, knon
+          Kcoefhq(i,k) = &
+               coefhq(i,k)*RG*RG*dtime /(pplay(i,k-1)-pplay(i,k)) &
+               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
+       ENDDO
+    ENDDO
+
+!****************************************************************************************
+! 3)
+! Calculation of gama for "Q" and "H"
+!
+!****************************************************************************************
+!   surface pressure is used as reference
+    psref(:) = paprs(:,1) 
+
+!   definition of gama
+    IF (iflag_pbl == 1) THEN
+       gamaq(:,:) = 0.0
+       gamah(:,:) = -1.0e-03
+       gamah(:,2) = -2.5e-03
+ 
+! conversion de gama
+       DO k = 2, klev
+          DO i = 1, knon
+             delz = RD * (temp(i,k-1)+temp(i,k)) / & 
+                    2.0 / RG / paprs(i,k) * (pplay(i,k-1)-pplay(i,k))
+             pkh  = (psref(i)/paprs(i,k))**RKAPPA
+          
+! convertie gradient verticale d'humidite specifique en difference d'humidite specifique entre centre de couches
+             gamaq(i,k) = gamaq(i,k) * delz    
+! convertie gradient verticale de temperature en difference de temperature potentielle entre centre de couches 
+             gamah(i,k) = gamah(i,k) * delz * RCPD * pkh
+          ENDDO
+       ENDDO
+
+    ELSE
+       gamaq(:,:) = 0.0
+       gamah(:,:) = 0.0
+    ENDIF
+    
+
+!****************************************************************************************    
+! 4)
+! Calculte the coefficients C and D for specific humidity, q
+!
+!****************************************************************************************
+    
+    CALL calc_coef(knon, Kcoefhq(:,:), gamaq(:,:), delp(:,:), q(:,:), &
+         Ccoef_Q(:,:), Dcoef_Q(:,:), Acoef_Q, Bcoef_Q)
+
+!****************************************************************************************
+! 5)
+! Calculte the coefficients C and D for potentiel entalpie, H 
+!
+!****************************************************************************************
+    local_H(:,:) = 0.0
+
+    DO k=1,klev
+       DO i = 1, knon
+          ! convertie la temperature en entalpie potentielle
+          local_H(i,k) = RCPD * temp(i,k) * &
+               (psref(i)/pplay(i,k))**RKAPPA
+       ENDDO
+    ENDDO
+
+    CALL calc_coef(knon, Kcoefhq(:,:), gamah(:,:), delp(:,:), local_H(:,:), &
+         Ccoef_H(:,:), Dcoef_H(:,:), Acoef_H, Bcoef_H)
+ 
+!****************************************************************************************
+! 6)
+! Return the first layer in output variables
+!
+!****************************************************************************************
+    Acoef_H_out = Acoef_H
+    Bcoef_H_out = Bcoef_H
+    Acoef_Q_out = Acoef_Q
+    Bcoef_Q_out = Bcoef_Q
+
+    PRINT *,'    Lluis in climb_hq_down 1 k dplay dpaprs Kcoefhq gamaq gamah '// &
+      'delp q Ccoef_Q Dcoef_Q Acoef_Q Bcoef_Q local_H ________' 
+
+    DO k=2,klev
+      PRINT *,k,pplay(1,k-1)-pplay(1,k),paprs(1,k-1)-paprs(1,k),Kcoefhq(1,k), &
+        gamaq(1,k),gamah(1,k),delp(1,k),q(1,k),Ccoef_Q(1,k),Dcoef_Q(1,k),     &
+        Acoef_Q(1),Bcoef_Q(1), local_H(1,k)
+    END DO
+
+  END SUBROUTINE climb_hq_down
+!
+!****************************************************************************************
+!
+  SUBROUTINE calc_coef(knon, Kcoef, gama, delp, X, Ccoef, Dcoef, Acoef, Bcoef)
+!
+! Calculate the coefficients C and D in : X(k) = C(k) + D(k)*X(k-1)
+! where X is H or Q, and k the vertical level k=1,klev
+!
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, delp
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
+    REAL, DIMENSION(klon,2:klev), INTENT(IN) :: gama
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef, Bcoef
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef, Dcoef
+
+! Local variables
+!****************************************************************************************
+    INTEGER                                  :: k, i
+    REAL                                     :: buf
+
+!****************************************************************************************
+! Niveau au sommet, k=klev
+!
+!****************************************************************************************
+    Ccoef(:,:) = 0.0
+    Dcoef(:,:) = 0.0
+
+    DO i = 1, knon
+       buf = delp(i,klev) + Kcoef(i,klev)
+       
+       Ccoef(i,klev) = (X(i,klev)*delp(i,klev) - Kcoef(i,klev)*gama(i,klev))/buf
+       Dcoef(i,klev) = Kcoef(i,klev)/buf
+    END DO
+
+
+!****************************************************************************************
+! Niveau  (klev-1) <= k <= 2
+!
+!****************************************************************************************
+
+    DO k=(klev-1),2,-1
+       DO i = 1, knon
+          buf = delp(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
+          Ccoef(i,k) = (X(i,k)*delp(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1) + &
+               Kcoef(i,k+1)*gama(i,k+1) - Kcoef(i,k)*gama(i,k))/buf
+          Dcoef(i,k) = Kcoef(i,k)/buf
+       END DO
+    END DO
+
+!****************************************************************************************
+! Niveau k=1
+!
+!****************************************************************************************
+
+    DO i = 1, knon
+       buf = delp(i,1) + Kcoef(i,2)*(1.-Dcoef(i,2))
+       Acoef(i) = (X(i,1)*delp(i,1) + Kcoef(i,2)*(gama(i,2)+Ccoef(i,2)))/buf
+       Bcoef(i) = -1. * RG / buf
+    END DO
+    acoef(knon+1: klon) = 0.
+    bcoef(knon+1: klon) = 0.
+
+  END SUBROUTINE calc_coef
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_hq_up(knon, dtime, t_old, q_old, &
+       flx_q1, flx_h1, paprs, pplay, &
+       flux_q, flux_h, d_q, d_t)
+! 
+! This routine calculates the flux and tendency of the specific humidity q and 
+! the potential engergi H. 
+! The quantities q and H are calculated according to 
+! X(k) = C(k) + D(k)*X(k-1) for X=[q,H], where the coefficients 
+! C and D are known from before and k is index of the vertical layer.
+!   
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_old, q_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: flx_q1, flx_h1
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: flux_q, flux_h, d_q, d_t
+
+! Local variables
+!****************************************************************************************
+    LOGICAL, SAVE                            :: last=.FALSE.
+    REAL, DIMENSION(klon,klev)               :: h_new, q_new
+    REAL, DIMENSION(klon)                    :: psref         
+    INTEGER                                  :: k, i, ierr
+
+!****************************************************************************************
+! 1) 
+! Definition of some variables
+!
+!****************************************************************************************
+    flux_q(:,:) = 0.0
+    flux_h(:,:) = 0.0
+    d_q(:,:)    = 0.0
+    d_t(:,:)    = 0.0
+
+    psref(1:knon) = paprs(1:knon,1)  
+
+!****************************************************************************************
+! 2)
+! Calculation of Q and H
+!
+!****************************************************************************************
+
+!- First layer
+    q_new(1:knon,1) = Acoef_Q(1:knon) + Bcoef_Q(1:knon)*flx_q1(1:knon)*dtime
+    h_new(1:knon,1) = Acoef_H(1:knon) + Bcoef_H(1:knon)*flx_h1(1:knon)*dtime
+    
+!- All the other layers 
+    DO k = 2, klev
+       DO i = 1, knon
+          q_new(i,k) = Ccoef_Q(i,k) + Dcoef_Q(i,k)*q_new(i,k-1)
+          h_new(i,k) = Ccoef_H(i,k) + Dcoef_H(i,k)*h_new(i,k-1)
+       END DO
+    END DO
+!****************************************************************************************
+! 3)
+! Calculation of the flux for Q and H
+!
+!****************************************************************************************
+
+!- The flux at first layer, k=1
+    flux_q(1:knon,1)=flx_q1(1:knon)
+    flux_h(1:knon,1)=flx_h1(1:knon)
+
+!- The flux at all layers above surface
+    DO k = 2, klev
+       DO i = 1, knon
+          flux_q(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
+               (q_new(i,k)-q_new(i,k-1)+gamaq(i,k))
+
+          flux_h(i,k) = (Kcoefhq(i,k)/RG/dtime) * &
+               (h_new(i,k)-h_new(i,k-1)+gamah(i,k)) 
+       END DO
+    END DO
+
+!****************************************************************************************
+! 4)
+! Calculation of tendency for Q and H
+!
+!****************************************************************************************
+
+    DO k = 1, klev
+       DO i = 1, knon
+          d_t(i,k) = h_new(i,k)/(psref(i)/pplay(i,k))**RKAPPA/RCPD - t_old(i,k)
+          d_q(i,k) = q_new(i,k) - q_old(i,k)
+       END DO
+    END DO
+
+!****************************************************************************************
+! Some deallocations
+!
+!****************************************************************************************
+    IF (last) THEN
+       DEALLOCATE(Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H,stat=ierr)    
+       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Ccoef_Q, Dcoef_Q, Ccoef_H, Dcoef_H, ierr=', ierr
+       DEALLOCATE(Acoef_Q, Bcoef_Q, Acoef_H, Bcoef_H,stat=ierr)    
+       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Acoef_Q, Bcoef_Q, Acoef_H, Bcoef_H, ierr=', ierr
+       DEALLOCATE(gamaq, gamah,stat=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate gamaq, gamah, ierr=', ierr
+       DEALLOCATE(Kcoefhq,stat=ierr)
+       IF ( ierr /= 0 )  PRINT*,' pb in dealllocate Kcoefhq, ierr=', ierr
+    END IF
+  END SUBROUTINE climb_hq_up
+!
+!****************************************************************************************
+!
+END MODULE climb_hq_mod
+
+ 
+
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/climb_wind_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/climb_wind_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/climb_wind_mod.F90	(revision 17)
@@ -0,0 +1,309 @@
+!
+MODULE climb_wind_mod
+!
+! Module to solve the verctical diffusion of the wind components "u" and "v".
+!
+  USE dimphy
+
+  IMPLICIT NONE
+
+  SAVE
+  PRIVATE
+  
+  REAL, DIMENSION(:),   ALLOCATABLE  :: alf1, alf2
+  !$OMP THREADPRIVATE(alf1,alf2)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Kcoefm
+  !$OMP THREADPRIVATE(Kcoefm)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_U, Dcoef_U
+  !$OMP THREADPRIVATE(Ccoef_U, Dcoef_U)
+  REAL, DIMENSION(:,:), ALLOCATABLE  :: Ccoef_V, Dcoef_V
+  !$OMP THREADPRIVATE(Ccoef_V, Dcoef_V)
+  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_U, Bcoef_U
+  !$OMP THREADPRIVATE(Acoef_U, Bcoef_U)
+  REAL, DIMENSION(:), ALLOCATABLE   :: Acoef_V, Bcoef_V
+  !$OMP THREADPRIVATE(Acoef_V, Bcoef_V)
+  LOGICAL                            :: firstcall=.TRUE.
+  !$OMP THREADPRIVATE(firstcall)
+
+  
+  PUBLIC :: climb_wind_down, climb_wind_up
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_init
+
+    INTEGER             :: ierr
+    CHARACTER(len = 20) :: modname = 'climb_wind_init'    
+
+!****************************************************************************************
+! Allocation of global module variables
+!
+!****************************************************************************************
+
+    ALLOCATE(alf1(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1)
+
+    ALLOCATE(alf2(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate alf2',1)
+
+    ALLOCATE(Kcoefm(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Kcoefm',1)
+
+    ALLOCATE(Ccoef_U(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocate Ccoef_U',1)
+
+    ALLOCATE(Dcoef_U(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_U',1)
+
+    ALLOCATE(Ccoef_V(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Ccoef_V',1)
+
+    ALLOCATE(Dcoef_V(klon,klev), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm(modname,'Pb in allocation Dcoef_V',1)
+
+    ALLOCATE(Acoef_U(klon), Bcoef_U(klon), Acoef_V(klon), Bcoef_V(klon), STAT=ierr)
+    IF ( ierr /= 0 )  PRINT*,' pb in allloc Acoef_U and Bcoef_U, ierr=', ierr
+
+    firstcall=.FALSE.
+
+  END SUBROUTINE climb_wind_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE climb_wind_down(knon, dtime, coef_in, pplay, paprs, temp, delp, u_old, v_old, &
+       Acoef_U_out, Acoef_V_out, Bcoef_U_out, Bcoef_V_out)
+!
+! This routine calculates for the wind components u and v,
+! recursivly the coefficients C and D in equation 
+! X(k) = C(k) + D(k)*X(k-1), X=[u,v], k=[1,klev] is the vertical layer.
+!
+!
+    INCLUDE "YOMCST.h"
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: coef_in
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay ! pres au milieu de couche (Pa)
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs ! pression a inter-couche (Pa)
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: temp  ! temperature
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: delp
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u_old
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: v_old
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_U_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef_V_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_U_out
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Bcoef_V_out
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon)                    :: u1lay, v1lay
+    INTEGER                                  :: k, i
+
+
+!****************************************************************************************
+! Initialize module
+    IF (firstcall) CALL climb_wind_init
+
+!****************************************************************************************
+! Calculate the coefficients C and D in : u(k) = C(k) + D(k)*u(k-1)
+!
+!****************************************************************************************
+! - Define alpha (alf1 and alf2) 
+    alf1(:) = 1.0
+    alf2(:) = 1.0 - alf1(:)
+
+! - Calculate the coefficients K
+    Kcoefm(:,:) = 0.0
+    DO k = 2, klev
+       DO i=1,knon
+          Kcoefm(i,k) = coef_in(i,k)*RG*RG*dtime/(pplay(i,k-1)-pplay(i,k)) &
+               *(paprs(i,k)*2/(temp(i,k)+temp(i,k-1))/RD)**2
+       END DO
+    END DO
+
+! - Calculate the coefficients C and D, component "u"
+    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
+         u_old(:,:), alf1(:), alf2(:),  &
+         Ccoef_U(:,:), Dcoef_U(:,:), Acoef_U(:), Bcoef_U(:))
+
+! - Calculate the coefficients C and D, component "v"
+    CALL calc_coef(knon, Kcoefm(:,:), delp(:,:), &
+         v_old(:,:), alf1(:), alf2(:),  &
+         Ccoef_V(:,:), Dcoef_V(:,:), Acoef_V(:), Bcoef_V(:))
+
+!****************************************************************************************
+! 6)
+! Return the first layer in output variables
+!
+!****************************************************************************************
+    Acoef_U_out = Acoef_U
+    Bcoef_U_out = Bcoef_U
+    Acoef_V_out = Acoef_V
+    Bcoef_V_out = Bcoef_V
+
+  END SUBROUTINE climb_wind_down
+!
+!****************************************************************************************
+!
+  SUBROUTINE calc_coef(knon, Kcoef, delp, X, alfa1, alfa2, Ccoef, Dcoef, Acoef, Bcoef)
+!
+! Find the coefficients C and D in fonction of alfa, K and delp
+!
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: knon
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: Kcoef, delp
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: X
+    REAL, DIMENSION(klon), INTENT(IN)        :: alfa1, alfa2
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: Acoef, Bcoef
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: Ccoef, Dcoef
+  
+! local variables
+!****************************************************************************************
+    INTEGER                                  :: k, i
+    REAL                                     :: buf
+
+    INCLUDE "YOMCST.h"
+!****************************************************************************************
+! 
+
+! Calculate coefficients C and D at top level, k=klev
+!
+    Ccoef(:,:) = 0.0
+    Dcoef(:,:) = 0.0
+
+    DO i = 1, knon
+       buf = delp(i,klev) + Kcoef(i,klev)
+
+       Ccoef(i,klev) = X(i,klev)*delp(i,klev)/buf 
+       Dcoef(i,klev) = Kcoef(i,klev)/buf
+    END DO
+    
+! 
+! Calculate coefficients C and D at top level (klev-1) <= k <= 2
+!
+    DO k=(klev-1),2,-1
+       DO i = 1, knon
+          buf = delp(i,k) + Kcoef(i,k) + Kcoef(i,k+1)*(1.-Dcoef(i,k+1))
+          
+          Ccoef(i,k) = (X(i,k)*delp(i,k) + Kcoef(i,k+1)*Ccoef(i,k+1))/buf
+          Dcoef(i,k) = Kcoef(i,k)/buf
+       END DO
+    END DO
+
+!
+! Calculate coeffiecent A and B at surface
+!
+    DO i = 1, knon
+       buf = delp(i,1) + Kcoef(i,2)*(1-Dcoef(i,2))
+       Acoef(i) = (X(i,1)*delp(i,1) + Kcoef(i,2)*Ccoef(i,2))/buf
+       Bcoef(i) = -RG/buf
+    END DO
+    acoef(knon+1: klon) = 0.
+    bcoef(knon+1: klon) = 0.
+
+  END SUBROUTINE calc_coef
+!
+!****************************************************************************************
+!
+
+  SUBROUTINE climb_wind_up(knon, dtime, u_old, v_old, flx_u1, flx_v1,  &
+       flx_u_new, flx_v_new, d_u_new, d_v_new)
+!
+! Diffuse the wind components from the surface layer and up to the top layer. 
+! Coefficents A, B, C and D are known from before. Start values for the diffusion are the
+! momentum fluxes at surface.
+!
+! u(k=1) = A + B*flx*dtime
+! u(k)   = C(k) + D(k)*u(k-1)  [2 <= k <= klev]
+!
+!****************************************************************************************
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: u_old
+    REAL, DIMENSION(klon,klev), INTENT(IN)  :: v_old
+    REAL, DIMENSION(klon), INTENT(IN)       :: flx_u1, flx_v1 ! momentum flux
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT) :: flx_u_new, flx_v_new
+    REAL, DIMENSION(klon,klev), INTENT(OUT) :: d_u_new, d_v_new
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev)              :: u_new, v_new
+    INTEGER                                 :: k, i
+    
+!
+!****************************************************************************************
+
+! Niveau 1
+    DO i = 1, knon
+       u_new(i,1) = Acoef_U(i) + Bcoef_U(i)*flx_u1(i)*dtime
+       v_new(i,1) = Acoef_V(i) + Bcoef_V(i)*flx_v1(i)*dtime
+    END DO
+
+! Niveau 2 jusqu'au sommet klev
+    DO k = 2, klev
+       DO i=1, knon
+          u_new(i,k) = Ccoef_U(i,k) + Dcoef_U(i,k) * u_new(i,k-1)
+          v_new(i,k) = Ccoef_V(i,k) + Dcoef_V(i,k) * v_new(i,k-1)
+       END DO
+    END DO
+
+!****************************************************************************************
+! Calcul flux
+!
+!== flux_u/v est le flux de moment angulaire (positif vers bas)
+!== dont l'unite est: (kg m/s)/(m**2 s) 
+!
+!****************************************************************************************
+!
+    flx_u_new(:,:) = 0.0
+    flx_v_new(:,:) = 0.0
+
+    flx_u_new(1:knon,1)=flx_u1(1:knon)
+    flx_v_new(1:knon,1)=flx_v1(1:knon)
+
+! Niveau 2->klev
+    DO k = 2, klev
+       DO i = 1, knon
+          flx_u_new(i,k) = Kcoefm(i,k)/RG/dtime * &
+               (u_new(i,k)-u_new(i,k-1))
+          
+          flx_v_new(i,k) = Kcoefm(i,k)/RG/dtime * &
+               (v_new(i,k)-v_new(i,k-1))
+       END DO
+    END DO
+
+!****************************************************************************************
+! Calcul tendances
+!
+!****************************************************************************************
+    d_u_new(:,:) = 0.0
+    d_v_new(:,:) = 0.0
+    DO k = 1, klev
+       DO i = 1, knon
+          d_u_new(i,k) = u_new(i,k) - u_old(i,k)
+          d_v_new(i,k) = v_new(i,k) - v_old(i,k)
+       END DO
+    END DO
+
+  END SUBROUTINE climb_wind_up
+!
+!****************************************************************************************
+!
+END MODULE climb_wind_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/clouds_gno.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/clouds_gno.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/clouds_gno.F	(revision 17)
@@ -0,0 +1,263 @@
+!
+! $Header$
+!
+C
+C================================================================================
+C
+      SUBROUTINE CLOUDS_GNO(klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF)
+      IMPLICIT NONE
+C     
+C--------------------------------------------------------------------------------
+C
+C Inputs:
+C
+C  ND----------: Number of vertical levels
+C  R--------ND-: Domain-averaged mixing ratio of total water 
+C  RS-------ND-: Mean saturation humidity mixing ratio within the gridbox
+C  QSUB-----ND-: Mixing ratio of condensed water within clouds associated
+C                with SUBGRID-SCALE condensation processes (here, it is
+C                predicted by the convection scheme)
+C Outputs:
+C
+C  PTCONV-----ND-: Point convectif = TRUE
+C  RATQSC-----ND-: Largeur normalisee de la distribution
+C  CLDF-----ND-: Fraction nuageuse
+C
+C--------------------------------------------------------------------------------
+
+
+      INTEGER klon,ND
+      REAL R(klon,ND),  RS(klon,ND), QSUB(klon,ND)
+      LOGICAL PTCONV(klon,ND)
+      REAL RATQSC(klon,ND)
+      REAL CLDF(klon,ND)
+
+c -- parameters controlling the iteration:
+c --    nmax    : maximum nb of iterations (hopefully never reached)
+c --    epsilon : accuracy of the numerical resolution 
+c --    vmax    : v-value above which we use an asymptotic expression for ERF(v)
+
+      INTEGER nmax
+      PARAMETER ( nmax = 10) 
+      REAL epsilon, vmax0, vmax(klon)
+      PARAMETER ( epsilon = 0.02, vmax0 = 2.0 ) 
+
+      REAL min_mu, min_Q
+      PARAMETER ( min_mu =  1.e-12, min_Q=1.e-12 )
+     
+      INTEGER i,K, n, m
+      REAL mu(klon), qsat, delta(klon), beta(klon) 
+      real zu2,zv2
+      REAL xx(klon), aux(klon), coeff, block
+      REAL  dist, fprime, det
+      REAL pi, u, v, erfcu, erfcv
+      REAL  xx1, xx2
+      real erf,hsqrtlog_2,v2
+      real sqrtpi,sqrt2,zx1,zx2,exdel
+c lconv = true si le calcul a converge (entre autre si qsub < min_q)
+       LOGICAL lconv(klon)
+
+!cdir arraycomb
+      cldf  (1:klon,1:ND)=0.0        ! cym
+      ratqsc(1:klon,1:ND)=0.0
+      ptconv(1:klon,1:ND)=.false.
+!cdir end arraycomb
+      
+      pi = ACOS(-1.)
+      sqrtpi=sqrt(pi)
+      sqrt2=sqrt(2.)
+      hsqrtlog_2=0.5*SQRT(log(2.))
+
+      DO 500 K = 1, ND
+
+                                    do i=1,klon ! vector
+      mu(i) = R(i,K)
+      mu(i) = MAX(mu(i),min_mu)
+      qsat = RS(i,K) 
+      qsat = MAX(qsat,min_mu)
+      delta(i) = log(mu(i)/qsat)
+c                                   enddo ! vector
+
+C
+C ***          There is no subgrid-scale condensation;        ***
+C ***   the scheme becomes equivalent to an "all-or-nothing"  *** 
+C ***             large-scale condensation scheme.            ***
+C
+
+C
+C ***     Some condensation is produced at the subgrid-scale       ***
+C ***                                                              ***
+C ***       PDF = generalized log-normal distribution (GNO)        ***
+C ***   (k<0 because a lower bound is considered for the PDF)      ***
+C ***                                                              ***
+C ***  -> Determine x (the parameter k of the GNO PDF) such        ***
+C ***  that the contribution of subgrid-scale processes to         ***
+C ***  the in-cloud water content is equal to QSUB(K)              ***
+C ***  (equations (13), (14), (15) + Appendix B of the paper)      ***
+C ***                                                              ***
+C ***    Here, an iterative method is used for this purpose        ***
+C ***    (other numerical methods might be more efficient)         ***
+C ***                                                              ***
+C ***          NB: the "error function" is called ERF              ***
+C ***                 (ERF in double precision)                   ***
+C
+
+c  On commence par eliminer les cas pour lesquels on n'a pas
+c  suffisamment d'eau nuageuse.
+
+c                                   do i=1,klon ! vector
+
+      IF ( QSUB(i,K) .lt. min_Q ) THEN
+        ptconv(i,k)=.false.
+        ratqsc(i,k)=0.
+        lconv(i)  = .true.
+
+c   Rien on a deja initialise
+
+      ELSE 
+
+        lconv(i)  = .FALSE. 
+        vmax(i) = vmax0
+
+        beta(i) = QSUB(i,K)/mu(i) + EXP( -MIN(0.0,delta(i)) )
+
+c --  roots of equation v > vmax:
+
+        det = delta(i) + vmax(i)*vmax(i)
+        if (det.LE.0.0) vmax(i) = vmax0 + 1.0
+        det = delta(i) + vmax(i)*vmax(i)
+
+        if (det.LE.0.) then
+          xx(i) = -0.0001
+        else 
+         zx1=-sqrt2*vmax(i)
+         zx2=SQRT(1.0+delta(i)/(vmax(i)*vmax(i)))
+         xx1=zx1*(1.0-zx2)
+         xx2=zx1*(1.0+zx2)
+         xx(i) = 1.01 * xx1
+         if ( xx1 .GE. 0.0 ) xx(i) = 0.5*xx2
+        endif
+        if (delta(i).LT.0.) xx(i) = -hsqrtlog_2
+
+      ENDIF
+
+                                    enddo       ! vector
+
+c----------------------------------------------------------------------
+c   Debut des nmax iterations pour trouver la solution.
+c----------------------------------------------------------------------
+
+      DO n = 1, nmax 
+
+                                    do i=1,klon ! vector
+        if (.not.lconv(i)) then
+
+          u = delta(i)/(xx(i)*sqrt2) + xx(i)/(2.*sqrt2)
+          v = delta(i)/(xx(i)*sqrt2) - xx(i)/(2.*sqrt2)
+          v2 = v*v
+
+          IF ( v .GT. vmax(i) ) THEN 
+
+            IF (     ABS(u)  .GT. vmax(i) 
+     :          .AND.  delta(i) .LT. 0. ) THEN
+
+c -- use asymptotic expression of erf for u and v large:
+c ( -> analytic solution for xx )
+             exdel=beta(i)*EXP(delta(i))
+             aux(i) = 2.0*delta(i)*(1.-exdel)
+     :                       /(1.+exdel)
+             if (aux(i).lt.0.) then
+c                print*,'AUX(',i,',',k,')<0',aux(i),delta(i),beta(i)
+                aux(i)=0.
+             endif
+             xx(i) = -SQRT(aux(i))
+             block = EXP(-v*v) / v / sqrtpi
+             dist = 0.0
+             fprime = 1.0
+
+            ELSE
+
+c -- erfv -> 1.0, use an asymptotic expression of erfv for v large:
+
+             erfcu = 1.0-ERF(u)
+c  !!! ATTENTION : rajout d'un seuil pour l'exponentiel
+             aux(i) = sqrtpi*erfcu*EXP(min(v2,100.))
+             coeff = 1.0 - 0.5/(v2) + 0.75/(v2*v2)
+             block = coeff * EXP(-v2) / v / sqrtpi
+             dist = v * aux(i) / coeff - beta(i)
+             fprime = 2.0 / xx(i) * (v2)
+     :           * ( EXP(-delta(i)) - u * aux(i) / coeff )
+     :           / coeff
+            
+            ENDIF ! ABS(u)
+
+          ELSE
+
+c -- general case:
+
+           erfcu = 1.0-ERF(u)
+           erfcv = 1.0-ERF(v)
+           block = erfcv
+           dist = erfcu / erfcv - beta(i)
+           zu2=u*u
+           zv2=v2
+           if(zu2.gt.20..or. zv2.gt.20.) then
+c              print*,'ATTENTION !!! xx(',i,') =', xx(i)
+c           print*,'ATTENTION !!! klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF',
+c     .klon,ND,R(i,k),RS(i,k),QSUB(i,k),PTCONV(i,k),RATQSC(i,k),
+c     .CLDF(i,k)
+c              print*,'ATTENTION !!! zu2 zv2 =',zu2(i),zv2(i)
+              zu2=20.
+              zv2=20.
+             fprime = 0.
+           else
+             fprime = 2. /sqrtpi /xx(i) /(erfcv*erfcv)
+     :           * (   erfcv*v*EXP(-zu2)
+     :               - erfcu*u*EXP(-zv2) )
+           endif
+          ENDIF ! x
+
+c -- test numerical convergence:
+
+!          if (beta(i).lt.1.e-10) then
+!              print*,'avant test ',i,k,lconv(i),u(i),v(i),beta(i)
+!              stop
+!          endif
+          if (abs(fprime).lt.1.e-11) then
+!              print*,'avant test fprime<.e-11 '
+!     s        ,i,k,lconv(i),u(i),v(i),beta(i),fprime(i)
+!              print*,'klon,ND,R,RS,QSUB',
+!     s        klon,ND,R(i,k),rs(i,k),qsub(i,k)
+              fprime=sign(1.e-11,fprime)
+          endif
+
+
+          if ( ABS(dist/beta(i)) .LT. epsilon ) then 
+c           print*,'v-u **2',(v(i)-u(i))**2
+c           print*,'exp v-u **2',exp((v(i)-u(i))**2)
+            ptconv(i,K) = .TRUE. 
+            lconv(i)=.true.
+c  borne pour l'exponentielle
+            ratqsc(i,k)=min(2.*(v-u)*(v-u),20.)
+            ratqsc(i,k)=sqrt(exp(ratqsc(i,k))-1.)
+            CLDF(i,K) = 0.5 * block
+          else
+            xx(i) = xx(i) - dist/fprime
+          endif
+c         print*,'apres test ',i,k,lconv(i)
+
+        endif ! lconv
+                                    enddo       ! vector
+
+c----------------------------------------------------------------------
+c   Fin des nmax iterations pour trouver la solution.
+        ENDDO ! n
+c----------------------------------------------------------------------
+
+500   CONTINUE  ! K
+
+       RETURN
+       END
+
+ 
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/clouds_gno.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/clouds_gno.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/clouds_gno.F90	(revision 17)
@@ -0,0 +1,262 @@
+!
+! $Header$
+!
+!C
+!C================================================================================
+!C
+      SUBROUTINE CLOUDS_GNO(klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF)
+      IMPLICIT NONE
+!C     
+!C--------------------------------------------------------------------------------
+!C
+!C Inputs:
+!C
+!C  ND----------: Number of vertical levels
+!C  R--------ND-: Domain-averaged mixing ratio of total water 
+!C  RS-------ND-: Mean saturation humidity mixing ratio within the gridbox
+!C  QSUB-----ND-: Mixing ratio of condensed water within clouds associated
+!C                with SUBGRID-SCALE condensation processes (here, it is
+!C                predicted by the convection scheme)
+!C Outputs:
+!C
+!C  PTCONV-----ND-: Point convectif = TRUE
+!C  RATQSC-----ND-: Largeur normalisee de la distribution
+!C  CLDF-----ND-: Fraction nuageuse
+!C
+!C--------------------------------------------------------------------------------
+
+
+      INTEGER klon,ND
+      REAL R(klon,ND),  RS(klon,ND), QSUB(klon,ND)
+      LOGICAL PTCONV(klon,ND)
+      REAL RATQSC(klon,ND)
+      REAL CLDF(klon,ND)
+
+!c -- parameters controlling the iteration:
+!c --    nmax    : maximum nb of iterations (hopefully never reached)
+!c --    epsilon : accuracy of the numerical resolution 
+!c --    vmax    : v-value above which we use an asymptotic expression for ERF(v)
+
+      INTEGER nmax
+      PARAMETER ( nmax = 10) 
+      REAL epsilon, vmax0, vmax(klon)
+      PARAMETER ( epsilon = 0.02, vmax0 = 2.0 ) 
+
+      REAL min_mu, min_Q
+      PARAMETER ( min_mu =  1.e-12, min_Q=1.e-12 )
+      INTEGER i,K, n, m
+      REAL mu(klon), qsat, delta(klon), beta(klon) 
+      real zu2,zv2
+      REAL xx(klon), aux(klon), coeff, block
+      REAL  dist, fprime, det
+      REAL pi, u, v, erfcu, erfcv
+      REAL  xx1, xx2
+      real erf,hsqrtlog_2,v2
+      real sqrtpi,sqrt2,zx1,zx2,exdel
+!c lconv = true si le calcul a converge (entre autre si qsub < min_q)
+       LOGICAL lconv(klon)
+
+!cdir arraycomb
+      cldf  (1:klon,1:ND)=0.0        ! cym
+      ratqsc(1:klon,1:ND)=0.0
+      ptconv(1:klon,1:ND)=.false.
+!cdir end arraycomb
+      
+      pi = ACOS(-1.)
+      sqrtpi=sqrt(pi)
+      sqrt2=sqrt(2.)
+      hsqrtlog_2=0.5*SQRT(log(2.))
+
+      DO 500 K = 1, ND
+
+                                    do i=1,klon ! vector
+      mu(i) = R(i,K)
+      mu(i) = MAX(mu(i),min_mu)
+      qsat = RS(i,K) 
+      qsat = MAX(qsat,min_mu)
+      delta(i) = log(mu(i)/qsat)
+!c                                   enddo ! vector
+
+!C
+!C ***          There is no subgrid-scale condensation;        ***
+!C ***   the scheme becomes equivalent to an "all-or-nothing"  *** 
+!C ***             large-scale condensation scheme.            ***
+!C
+
+!C
+!C ***     Some condensation is produced at the subgrid-scale       ***
+!C ***                                                              ***
+!C ***       PDF = generalized log-normal distribution (GNO)        ***
+!C ***   (k<0 because a lower bound is considered for the PDF)      ***
+!C ***                                                              ***
+!C ***  -> Determine x (the parameter k of the GNO PDF) such        ***
+!C ***  that the contribution of subgrid-scale processes to         ***
+!C ***  the in-cloud water content is equal to QSUB(K)              ***
+!C ***  (equations (13), (14), (15) + Appendix B of the paper)      ***
+!C ***                                                              ***
+!C ***    Here, an iterative method is used for this purpose        ***
+!C ***    (other numerical methods might be more efficient)         ***
+!C ***                                                              ***
+!C ***          NB: the "error function" is called ERF              ***
+!C ***                 (ERF in double precision)                   ***
+!C
+
+!c  On commence par eliminer les cas pour lesquels on n'a pas
+!c  suffisamment d'eau nuageuse.
+
+!c                                   do i=1,klon ! vector
+
+      IF ( QSUB(i,K) .lt. min_Q ) THEN
+        ptconv(i,k)=.false.
+        ratqsc(i,k)=0.
+        lconv(i)  = .true.
+
+!c   Rien on a deja initialise
+
+      ELSE 
+
+        lconv(i)  = .FALSE. 
+        vmax(i) = vmax0
+
+        beta(i) = QSUB(i,K)/mu(i) + EXP( -MIN(0.0,delta(i)) )
+
+!c --  roots of equation v > vmax:
+
+        det = delta(i) + vmax(i)*vmax(i)
+        if (det.LE.0.0) vmax(i) = vmax0 + 1.0
+        det = delta(i) + vmax(i)*vmax(i)
+
+        if (det.LE.0.) then
+          xx(i) = -0.0001
+        else 
+         zx1=-sqrt2*vmax(i)
+         zx2=SQRT(1.0+delta(i)/(vmax(i)*vmax(i)))
+         xx1=zx1*(1.0-zx2)
+         xx2=zx1*(1.0+zx2)
+         xx(i) = 1.01 * xx1
+         if ( xx1 .GE. 0.0 ) xx(i) = 0.5*xx2
+        endif
+        if (delta(i).LT.0.) xx(i) = -hsqrtlog_2
+
+      ENDIF
+
+                                    enddo       ! vector
+
+!c----------------------------------------------------------------------
+!c   Debut des nmax iterations pour trouver la solution.
+!c----------------------------------------------------------------------
+
+      DO n = 1, nmax 
+
+                                    do i=1,klon ! vector
+        if (.not.lconv(i)) then
+
+          u = delta(i)/(xx(i)*sqrt2) + xx(i)/(2.*sqrt2)
+          v = delta(i)/(xx(i)*sqrt2) - xx(i)/(2.*sqrt2)
+          v2 = v*v
+
+          IF ( v .GT. vmax(i) ) THEN 
+
+            IF (     ABS(u)  .GT. vmax(i)                                            &
+       &          .AND.  delta(i) .LT. 0. ) THEN
+
+!c -- use asymptotic expression of erf for u and v large:
+!c ( -> analytic solution for xx )
+             exdel=beta(i)*EXP(delta(i))
+             aux(i) = 2.0*delta(i)*(1.-exdel)                                        &
+       &                       /(1.+exdel)
+             if (aux(i).lt.0.) then
+!c                print*,'AUX(',i,',',k,')<0',aux(i),delta(i),beta(i)
+                aux(i)=0.
+             endif
+             xx(i) = -SQRT(aux(i))
+             block = EXP(-v*v) / v / sqrtpi
+             dist = 0.0
+             fprime = 1.0
+
+            ELSE
+
+!c -- erfv -> 1.0, use an asymptotic expression of erfv for v large:
+
+             erfcu = 1.0-ERF(u)
+!c  !!! ATTENTION : rajout d'un seuil pour l'exponentiel
+             aux(i) = sqrtpi*erfcu*EXP(min(v2,100.))
+             coeff = 1.0 - 0.5/(v2) + 0.75/(v2*v2)
+             block = coeff * EXP(-v2) / v / sqrtpi
+             dist = v * aux(i) / coeff - beta(i)
+             fprime = 2.0 / xx(i) * (v2)                                             &
+       &           * ( EXP(-delta(i)) - u * aux(i) / coeff )                         &
+       &           / coeff
+            
+            ENDIF ! ABS(u)
+
+          ELSE
+
+!c -- general case:
+
+           erfcu = 1.0-ERF(u)
+           erfcv = 1.0-ERF(v)
+           block = erfcv
+           dist = erfcu / erfcv - beta(i)
+           zu2=u*u
+           zv2=v2
+           if(zu2.gt.20..or. zv2.gt.20.) then
+!c              print*,'ATTENTION !!! xx(',i,') =', xx(i)
+!c           print*,'ATTENTION !!! klon,ND,R,RS,QSUB,PTCONV,RATQSC,CLDF',
+!c     .klon,ND,R(i,k),RS(i,k),QSUB(i,k),PTCONV(i,k),RATQSC(i,k),
+!c     .CLDF(i,k)
+!c              print*,'ATTENTION !!! zu2 zv2 =',zu2(i),zv2(i)
+              zu2=20.
+              zv2=20.
+             fprime = 0.
+           else
+             fprime = 2. /sqrtpi /xx(i) /(erfcv*erfcv)                               &
+       &           * (   erfcv*v*EXP(-zu2)                                           &
+       &               - erfcu*u*EXP(-zv2) )
+           endif
+          ENDIF ! x
+
+!c -- test numerical convergence:
+
+!          if (beta(i).lt.1.e-10) then
+!              print*,'avant test ',i,k,lconv(i),u(i),v(i),beta(i)
+!              stop
+!          endif
+          if (abs(fprime).lt.1.e-11) then
+!              print*,'avant test fprime<.e-11 '
+!     s        ,i,k,lconv(i),u(i),v(i),beta(i),fprime(i)
+!              print*,'klon,ND,R,RS,QSUB',
+!     s        klon,ND,R(i,k),rs(i,k),qsub(i,k)
+              fprime=sign(1.e-11,fprime)
+          endif
+
+
+          if ( ABS(dist/beta(i)) .LT. epsilon ) then 
+!c           print*,'v-u **2',(v(i)-u(i))**2
+!c           print*,'exp v-u **2',exp((v(i)-u(i))**2)
+            ptconv(i,K) = .TRUE. 
+            lconv(i)=.true.
+!c  borne pour l'exponentielle
+            ratqsc(i,k)=min(2.*(v-u)*(v-u),20.)
+            ratqsc(i,k)=sqrt(exp(ratqsc(i,k))-1.)
+            CLDF(i,K) = 0.5 * block
+          else
+            xx(i) = xx(i) - dist/fprime
+          endif
+!c         print*,'apres test ',i,k,lconv(i)
+
+        endif ! lconv
+                                    enddo       ! vector
+
+!c----------------------------------------------------------------------
+!c   Fin des nmax iterations pour trouver la solution.
+        ENDDO ! n
+!c----------------------------------------------------------------------
+
+500   CONTINUE  ! K
+
+       RETURN
+       END SUBROUTINE CLOUDS_GNO
+
+ 
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cloudth.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cloudth.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cloudth.F90	(revision 17)
@@ -0,0 +1,243 @@
+       SUBROUTINE cloudth(ngrid,klev,ind2,  &
+     &           ztv,po,zqta,fraca, & 
+     &           qcloud,ctot,zpspsk,paprs,ztla,zthl, &
+     &           ratqs,zqs,t)
+
+
+      IMPLICIT NONE
+
+
+!===========================================================================
+! Auteur : Arnaud Octavio Jam (LMD/CNRS)
+! Date : 25 Mai 2010
+! Objet : calcule les valeurs de qc et rneb dans les thermiques
+!===========================================================================
+
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+#include "iniprint.h"
+#include "thermcell.h"
+
+      INTEGER itap,ind1,ind2
+      INTEGER ngrid,klev,klon,l,ig 
+      
+      REAL ztv(ngrid,klev)
+      REAL po(ngrid)
+      REAL zqenv(ngrid)   
+      REAL zqta(ngrid,klev)
+          
+      REAL fraca(ngrid,klev+1)
+      REAL zpspsk(ngrid,klev)
+      REAL paprs(ngrid,klev+1)
+      REAL ztla(ngrid,klev)
+      REAL zthl(ngrid,klev)
+
+      REAL zqsatth(ngrid,klev)
+      REAL zqsatenv(ngrid,klev)
+      
+      
+      REAL sigma1(ngrid,klev)                                                         
+      REAL sigma2(ngrid,klev)
+      REAL qlth(ngrid,klev)
+      REAL qlenv(ngrid,klev)
+      REAL qltot(ngrid,klev) 
+      REAL cth(ngrid,klev)  
+      REAL cenv(ngrid,klev)   
+      REAL ctot(ngrid,klev)
+      REAL rneb(ngrid,klev)
+      REAL t(ngrid,klev)                                                                  
+      REAL qsatmmussig1,qsatmmussig2,sqrt2pi,pi
+      REAL rdd,cppd,Lv
+      REAL alth,alenv,ath,aenv
+      REAL sth,senv,sigma1s,sigma2s,xth,xenv
+      REAL Tbef,zdelta,qsatbef,zcor
+      REAL alpha,qlbef  
+      REAL ratqs(ngrid,klev) ! determine la largeur de distribution de vapeur
+      
+      REAL zpdf_sig(ngrid),zpdf_k(ngrid),zpdf_delta(ngrid)
+      REAL zpdf_a(ngrid),zpdf_b(ngrid),zpdf_e1(ngrid),zpdf_e2(ngrid) 
+      REAL zqs(ngrid), qcloud(ngrid)
+      REAL erf
+
+
+
+
+
+!      print*,ngrid,klev,ind1,ind2,ztv(ind1,ind2),po(ind1),zqta(ind1,ind2), &
+!     &       fraca(ind1,ind2),zpspsk(ind1,ind2),paprs(ind1,ind2),ztla(ind1,ind2),zthl(ind1,ind2), &
+!     &       'verif'
+
+
+!      LOGICAL active(ngrid)   
+      
+!-----------------------------------------------------------------------------------------------------------------
+! Initialisation des variables réelles
+!-----------------------------------------------------------------------------------------------------------------
+      sigma1(:,:)=0.
+      sigma2(:,:)=0.
+      qlth(:,:)=0.
+      qlenv(:,:)=0.  
+      qltot(:,:)=0.
+      rneb(:,:)=0.
+      qcloud(:)=0.
+      cth(:,:)=0.
+      cenv(:,:)=0.
+      ctot(:,:)=0.
+      qsatmmussig1=0.
+      qsatmmussig2=0.
+      rdd=287.04
+      cppd=1005.7
+      pi=3.14159 
+      Lv=2.5e6
+      sqrt2pi=sqrt(2.*pi)
+
+
+
+!------------------------------------------------------------------------------------------------------------------
+! Calcul de la fraction du thermique et des écart-types des distributions
+!------------------------------------------------------------------------------------------------------------------                 
+      do ind1=1,ngrid
+
+      if ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) then 
+
+      zqenv(ind1)=(po(ind1)-fraca(ind1,ind2)*zqta(ind1,ind2))/(1.-fraca(ind1,ind2))
+
+
+!      zqenv(ind1)=po(ind1)
+      Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatenv(ind1,ind2)=qsatbef
+
+
+
+
+      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)  
+      aenv=1./(1.+(alenv*Lv/cppd))
+      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) 
+
+
+
+
+      Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatth(ind1,ind2)=qsatbef
+            
+      alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2)   
+      ath=1./(1.+(alth*Lv/cppd))
+      sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2)) 
+      
+      
+
+!-----------------------------------------------------------------------------------------------------------------
+! Calcul des écart-types pour s
+!-----------------------------------------------------------------------------------------------------------------
+
+      sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1)
+      sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.02)**0.4+0.002*zqta(ind1,ind2)  
+
+ 
+!-----------------------------------------------------------------------------------------------------------------
+! Calcul de l'eau condensée et de la couverture nuageuse
+!-----------------------------------------------------------------------------------------------------------------
+      sqrt2pi=sqrt(2.*pi)
+      xth=sth/(sqrt(2.)*sigma2s)
+      xenv=senv/(sqrt(2.)*sigma1s)
+      cth(ind1,ind2)=0.5*(1.+1.*erf(xth))
+      cenv(ind1,ind2)=0.5*(1.+1.*erf(xenv)) 
+      ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2)   
+!      ctot(ind1,ind2)=alpha*cth(ind1,ind2)+(1.-1.*alpha)*cenv(ind1,ind2) 
+
+
+
+      qlth(ind1,ind2)=sigma2s*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt(2.)*cth(ind1,ind2))
+      qlenv(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))   
+      qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2)
+!      qltot(ind1,ind2)=alpha*qlth(ind1,ind2)+(1.-1.*alpha)*qlenv(ind1,ind2)
+     
+
+!      print*,senv,sth,sigma1s,sigma2s,fraca(ind1,ind2),'senv et sth et sig1 et sig2 et alpha'
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      if (ctot(ind1,ind2).lt.1.e-10) then
+      ctot(ind1,ind2)=0.
+      qcloud(ind1)=zqsatenv(ind1,ind2) 
+
+      else   
+                
+      ctot(ind1,ind2)=ctot(ind1,ind2) 
+      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqs(ind1)
+
+      endif                           
+      
+          
+!     print*,sth,sigma2s,qlth(ind1,ind2),ctot(ind1,ind2),qltot(ind1,ind2),'verif'
+
+
+      else  ! gaussienne environnement seule
+      
+      zqenv(ind1)=po(ind1)
+      Tbef=t(ind1,ind2)
+      zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+      qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2)
+      qsatbef=MIN(0.5,qsatbef)
+      zcor=1./(1.-retv*qsatbef)
+      qsatbef=qsatbef*zcor
+      zqsatenv(ind1,ind2)=qsatbef
+      
+
+!      qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.)
+      zthl(ind1,ind2)=t(ind1,ind2)*(101325/paprs(ind1,ind2))**(rdd/cppd)
+      alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2)  
+      aenv=1./(1.+(alenv*Lv/cppd))
+      senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) 
+      
+
+      sigma1s=ratqs(ind1,ind2)*zqenv(ind1)
+
+      sqrt2pi=sqrt(2.*pi)
+      xenv=senv/(sqrt(2.)*sigma1s)
+      ctot(ind1,ind2)=0.5*(1.+1.*erf(xenv))
+      qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2))
+      
+      if (ctot(ind1,ind2).lt.1.e-3) then
+      ctot(ind1,ind2)=0.
+      qcloud(ind1)=zqsatenv(ind1,ind2) 
+
+      else   
+                
+      ctot(ind1,ind2)=ctot(ind1,ind2) 
+      qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqsatenv(ind1,ind2)
+
+      endif    
+ 
+ 
+ 
+ 
+ 
+ 
+      endif   
+      enddo
+     
+      return
+      end
+
+
+
+
+
+                                                                            
+
+
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cltrac.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cltrac.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cltrac.F90	(revision 17)
@@ -0,0 +1,149 @@
+!
+! $Id $
+!
+SUBROUTINE cltrac(dtime,coef,t,tr,flux,paprs,pplay,delp, &
+                  d_tr,d_tr_dry,flux_tr_dry)                    !jyg
+
+  USE dimphy
+  IMPLICIT NONE
+!======================================================================
+! Auteur(s): O. Boucher (LOA/LMD) date: 19961127
+!            inspire de clvent
+! Objet: diffusion verticale de traceurs avec flux fixe a la surface
+!        ou/et flux du type c-drag
+!
+! Arguments:
+!-----------
+! dtime.......input-R- intervalle du temps (en secondes)
+! coef........input-R- le coefficient d'echange (m**2/s) l>1
+! t...........input-R- temperature (K)
+! tr..........input-R- la q. de traceurs
+! flux........input-R- le flux de traceurs a la surface
+! paprs.......input-R- pression a inter-couche (Pa)
+! pplay.......input-R- pression au milieu de couche (Pa)
+! delp........input-R- epaisseur de couche (Pa)
+! cdrag.......input-R- cdrag pour le flux de surface (non active)
+! tr0.........input-R- traceurs a la surface ou dans l'ocean (non active)
+! d_tr........output-R- le changement de tr
+! d_tr_dry....output-R- le changement de tr du au depot sec (1st layer)
+! flux_tr_dry.output-R- depot sec
+!!! flux_tr..output-R- flux de tr
+!======================================================================
+  include "YOMCST.h"
+!
+! Entree
+! 
+  REAL,INTENT(IN)                        :: dtime
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: coef
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t, tr
+  REAL,DIMENSION(klon),INTENT(IN)        :: flux !(at/s/m2)
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs 
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay, delp
+!
+! Sorties
+!
+  REAL ,DIMENSION(klon,klev),INTENT(OUT) :: d_tr
+  REAL ,DIMENSION(klon),INTENT(OUT)       :: d_tr_dry          !jyg
+  REAL ,DIMENSION(klon),INTENT(OUT)       :: flux_tr_dry       !jyg
+!  REAL ,DIMENSION(klon,klev),INTENT(OUT) :: flux_tr
+!
+! Local
+! 
+  INTEGER                   :: i, k
+  REAL,DIMENSION(klon)      :: cdrag, tr0
+  REAL,DIMENSION(klon,klev) :: zx_ctr
+  REAL,DIMENSION(klon,klev) :: zx_dtr
+  REAL,DIMENSION(klon)      :: zx_buf
+  REAL,DIMENSION(klon,klev) :: zx_coef
+  REAL,DIMENSION(klon,klev) :: local_tr
+  REAL,DIMENSION(klon)      :: zx_alf1,zx_alf2,zx_flux
+
+!======================================================================
+
+  DO k = 1, klev
+     DO i = 1, klon
+        local_tr(i,k) = tr(i,k)
+     ENDDO
+  ENDDO
+
+!======================================================================
+
+  DO i = 1, klon
+     zx_alf1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+     zx_alf2(i) = 1.0 - zx_alf1(i)
+     flux_tr_dry(i) = -flux(i)*dtime                              !jyg
+     zx_flux(i) =  flux_tr_dry(i)*RG                              !jyg
+!!     zx_flux(i) =  -flux(i)*dtime*RG                            !jyg
+! Pour le moment le flux est prescrit cdrag et zx_coef(1) vaut 0
+     cdrag(i) = 0.0 
+     tr0(i) = 0.0
+     zx_coef(i,1) = cdrag(i)*dtime*RG 
+     zx_ctr(i,1)=0.
+     zx_dtr(i,1)=0.
+  ENDDO
+
+!======================================================================
+
+  DO k = 2, klev
+     DO i = 1, klon
+        zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k))   &
+             *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+        zx_coef(i,k) = zx_coef(i,k)*dtime*RG  
+     ENDDO
+  ENDDO
+
+!======================================================================
+
+  DO i = 1, klon
+     zx_buf(i) = delp(i,1) + zx_coef(i,1)*zx_alf1(i) + zx_coef(i,2)
+     !
+     zx_ctr(i,2) = (local_tr(i,1)*delp(i,1)+                  &
+          zx_coef(i,1)*tr0(i)-zx_flux(i))/zx_buf(i)
+     !
+     zx_dtr(i,2) = (zx_coef(i,2)-zx_alf2(i)*zx_coef(i,1)) /   & 
+          zx_buf(i)
+     d_tr_dry(i) = -zx_flux(i)/zx_buf(i)                          !jyg
+  ENDDO
+
+  DO k = 3, klev
+     DO i = 1, klon
+        zx_buf(i) = delp(i,k-1) + zx_coef(i,k)      &
+             + zx_coef(i,k-1)*(1.-zx_dtr(i,k-1))
+        zx_ctr(i,k) = (local_tr(i,k-1)*delp(i,k-1)  & 
+             +zx_coef(i,k-1)*zx_ctr(i,k-1) )/zx_buf(i)
+        zx_dtr(i,k) = zx_coef(i,k)/zx_buf(i)
+     ENDDO
+  ENDDO
+
+  DO i = 1, klon
+     local_tr(i,klev) = ( local_tr(i,klev)*delp(i,klev) &
+          +zx_coef(i,klev)*zx_ctr(i,klev) )             &
+          / ( delp(i,klev) + zx_coef(i,klev)            &
+          -zx_coef(i,klev)*zx_dtr(i,klev) )
+  ENDDO
+
+  DO k = klev-1, 1, -1
+     DO i = 1, klon
+        local_tr(i,k) = zx_ctr(i,k+1) + zx_dtr(i,k+1)*local_tr(i,k+1)
+     ENDDO
+  ENDDO
+
+!======================================================================
+!== flux_tr est le flux de traceur (positif vers bas)
+!      DO i = 1, klon
+!         flux_tr(i,1) = zx_coef(i,1)/(RG*dtime)
+!      ENDDO
+!      DO k = 2, klev
+!      DO i = 1, klon
+!         flux_tr(i,k) = zx_coef(i,k)/(RG*dtime)
+!     .               * (local_tr(i,k)-local_tr(i,k-1))
+!      ENDDO
+!      ENDDO
+!======================================================================
+  DO k = 1, klev
+     DO i = 1, klon
+        d_tr(i,k) = local_tr(i,k) - tr(i,k)
+     ENDDO
+  ENDDO
+  
+END SUBROUTINE cltrac
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cltracrn.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cltracrn.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cltracrn.F90	(revision 17)
@@ -0,0 +1,293 @@
+
+!$Id $
+
+SUBROUTINE cltracrn( id_rn, id_pb, itr, dtime,u1lay, v1lay, &
+     cdrag,coef,t,ftsol,pctsrf,               &
+     tr,trs,paprs,pplay,delp,                 &
+     masktr,fshtr,hsoltr,tautr,vdeptr,        &
+     lat,d_tr,d_trs )
+  
+  USE dimphy
+  USE indice_sol_mod
+
+  IMPLICIT NONE
+!======================================================================
+! Auteur(s): Alex/LMD) date:  fev 99
+!            inspire de clqh + clvent
+! Objet: diffusion verticale de traceurs avec quantite de traceur ds 
+!        le sol ( reservoir de sol de radon ) 
+!        
+! note : pour l'instant le traceur dans le sol et le flux sont
+!        calcules mais ils ne servent que de diagnostiques
+!        seule la tendance sur le traceur est sortie (d_tr)
+!---------------------------------------------------------------------
+! Arguments:
+! itr......input-R-  le type de traceur : id_rn(radon), id_pb(plomb)
+! dtime....input-R-  intervalle du temps (en secondes) ~ pdtphys
+! u1lay....input-R-  vent u de la premiere couche (m/s)
+! v1lay....input-R-  vent v de la premiere couche (m/s)
+! cdrag....input-R-  cdrag
+! coef.....input-R-  le coefficient d'echange (m**2/s) l>1, valable uniquement pour k entre 2 et klev
+! t........input-R-  temperature (K)
+! paprs....input-R-  pression a inter-couche (Pa)
+! pplay....input-R-  pression au milieu de couche (Pa)
+! delp.....input-R-  epaisseur de couche (Pa)
+! ftsol....input-R-  temperature du sol (en Kelvin)
+! tr.......input-R-  traceurs
+! trs......input-R-  traceurs dans le sol
+! masktr...input-R-  Masque reservoir de sol traceur (1 = reservoir)
+! fshtr....input-R-  Flux surfacique de production dans le sol
+! tautr....input-R-  Constante de decroissance du traceur
+! vdeptr...input-R-  Vitesse de depot sec dans la couche brownienne
+! hsoltr...input-R-  Epaisseur equivalente du reservoir de sol
+! lat......input-R-  latitude en degree
+! d_tr.....output-R- le changement de "tr"
+! d_trs....output-R- le changement de "trs"
+!======================================================================
+  include "YOMCST.h"
+!
+!Entrees
+  INTEGER,INTENT(IN)                     :: id_rn, id_pb
+  INTEGER,INTENT(IN)                     :: itr
+  REAL,INTENT(IN)                        :: dtime
+  REAL,DIMENSION(klon),INTENT(IN)        :: u1lay, v1lay
+  REAL,DIMENSION(klon),INTENT(IN)        :: cdrag
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: coef, t
+  REAL,DIMENSION(klon,nbsrf),INTENT(IN)  :: ftsol, pctsrf 
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: tr 
+  REAL,DIMENSION(klon),INTENT(IN)        :: trs
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs 
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay, delp
+  REAL,DIMENSION(klon),INTENT(IN)        :: masktr 
+  REAL,DIMENSION(klon),INTENT(IN)        :: fshtr 
+  REAL,INTENT(IN)                        :: hsoltr
+  REAL,INTENT(IN)                        :: tautr
+  REAL,INTENT(IN)                        :: vdeptr
+  REAL,DIMENSION(klon),INTENT(IN)        :: lat   
+
+!Sorties
+  REAL,DIMENSION(klon,klev),INTENT(OUT) :: d_tr
+  REAL,DIMENSION(klon),INTENT(OUT) :: d_trs  ! (diagnostic) traceur ds le sol
+
+!Locales
+  REAL,DIMENSION(klon,klev) :: flux_tr  ! (diagnostic) flux de traceur
+  INTEGER                   :: i, k, n, l
+  REAL,DIMENSION(klon)      :: rotrhi
+  REAL,DIMENSION(klon,klev) :: zx_coef
+  REAL,DIMENSION(klon)      :: zx_buf
+  REAL,DIMENSION(klon,klev) :: zx_ctr
+  REAL,DIMENSION(klon,klev) :: zx_dtr
+  REAL,DIMENSION(klon)      :: zx_trs
+  REAL                      :: zx_a, zx_b
+  
+  REAL,DIMENSION(klon,klev) :: local_tr
+  REAL,DIMENSION(klon)      :: local_trs
+  REAL,DIMENSION(klon)      :: zts      ! champ de temperature du sol
+  REAL,DIMENSION(klon)      :: zx_alpha1, zx_alpha2
+!======================================================================
+!AA Pour l'instant les 4 types de surface ne sont pas pris en compte
+!AA On fabrique avec zts un champ de temperature de sol  
+!AA que le pondere par la fraction de nature de sol.
+
+  PRINT *,'  Lluis in cltracrn: ftsol', ftsol(550,:)
+  PRINT *,'    UBOUND tr: ',UBOUND(tr),' trs: ',UBOUND(trs)
+  PRINT *,'    tr: ', tr(550,:),' trs: ', trs(550)
+ 
+  DO i = 1,klon
+     zts(i) = 0. 
+  ENDDO
+
+  DO n=1,nbsrf
+     DO i = 1,klon
+        zts(i) = zts(i) + ftsol(i,n)*pctsrf(i,n)
+     ENDDO
+  ENDDO
+
+  DO i = 1,klon
+     rotrhi(i) = RD * zts(i) / hsoltr 
+  ENDDO
+
+  DO k = 1, klev
+     DO i = 1, klon
+        local_tr(i,k) = tr(i,k)
+     ENDDO
+  ENDDO
+
+  DO i = 1, klon
+     local_trs(i) = trs(i)
+  ENDDO
+!======================================================================
+!AA   Attention si dans clmain zx_alf1(i) = 1.0 
+!AA   Il doit y avoir coherence (dc la meme chose ici)
+
+  DO i = 1, klon
+!AA         zx_alpha1(i) = (paprs(i,1)-pplay(i,2))/(pplay(i,1)-pplay(i,2))
+     zx_alpha1(i) = 1.0
+     zx_alpha2(i) = 1.0 - zx_alpha1(i)
+  ENDDO
+!======================================================================
+  DO i = 1, klon
+     zx_coef(i,1) = cdrag(i)*(1.0+SQRT(u1lay(i)**2+v1lay(i)**2)) &
+          *pplay(i,1)/(RD*t(i,1))
+     zx_coef(i,1) = zx_coef(i,1) * dtime*RG
+  ENDDO
+
+  DO k = 2, klev
+     DO i = 1, klon
+        zx_coef(i,k) = coef(i,k)*RG/(pplay(i,k-1)-pplay(i,k)) &
+             *(paprs(i,k)*2/(t(i,k)+t(i,k-1))/RD)**2
+        zx_coef(i,k) = zx_coef(i,k) * dtime*RG
+     ENDDO
+  ENDDO
+!======================================================================
+  DO i = 1, klon
+     zx_buf(i)      = delp(i,klev) + zx_coef(i,klev)
+     zx_ctr(i,klev) = local_tr(i,klev)*delp(i,klev)/zx_buf(i)
+     zx_dtr(i,klev) = zx_coef(i,klev) / zx_buf(i)
+  ENDDO
+
+  DO l = klev-1, 2 , -1
+     DO i = 1, klon
+        zx_buf(i) = delp(i,l)+zx_coef(i,l)      &
+             +zx_coef(i,l+1)*(1.-zx_dtr(i,l+1))
+ 
+        zx_ctr(i,l) = ( local_tr(i,l)*delp(i,l) &
+             + zx_coef(i,l+1)*zx_ctr(i,l+1) )/zx_buf(i)
+        zx_dtr(i,l) = zx_coef(i,l) / zx_buf(i)
+     ENDDO
+  ENDDO
+
+  DO i = 1, klon
+     zx_buf(i) = delp(i,1) + zx_coef(i,2)*(1.-zx_dtr(i,2))  &
+          + masktr(i) * zx_coef(i,1)                        &
+          *( zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2) )
+
+     zx_ctr(i,1) = ( local_tr(i,1)*delp(i,1)                &
+          + zx_ctr(i,2)                                     &
+          *(zx_coef(i,2)                                    &
+          - masktr(i) * zx_coef(i,1)                        &
+          *zx_alpha2(i) ) ) / zx_buf(i)
+     zx_dtr(i,1) = masktr(i) * zx_coef(i,1) / zx_buf(i)
+  ENDDO
+!======================================================================
+! Calculer d'abord local_trs nouvelle quantite dans le reservoir
+! de sol
+!=====================================================================
+
+  DO i = 1, klon
+!-------------------------
+! Au dessus des continents
+!--
+! Le pb peut se deposer partout : vdeptr = 10-3 m/s
+! Le Rn est traiter commme une couche Brownienne puisque vdeptr = 0.
+!-------------------------------------------------------------------
+     IF ( NINT(masktr(i)) .EQ. 1 ) THEN
+        zx_trs(i) = local_trs(i)
+        zx_a = zx_trs(i)                                           &
+             +fshtr(i)*dtime*rotrhi(i)                             &
+             +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG                  &
+             *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)) &
+             +zx_alpha2(i)*zx_ctr(i,2))
+! Pour l'instant, pour aller vite, le depot sec est traite comme une decroissance
+        zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG            &
+             * (1.-zx_dtr(i,1)                                     &
+             *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))             &
+             + dtime / tautr                                       & 
+             + dtime * vdeptr / hsoltr 
+        zx_trs(i) = zx_a / zx_b
+        local_trs(i) = zx_trs(i)
+     ENDIF
+!--------------------------------------------------------
+! Si on est entre 60N et 70N on divise par 2 l'emanation
+!--------------------------------------------------------
+
+     IF ( (itr.eq.id_rn.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60..AND.lat(i).LE.70.).OR.      &
+          (itr.eq.id_pb.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GE.60..AND.lat(i).LE.70.) ) THEN
+        zx_trs(i) = local_trs(i)
+        zx_a = zx_trs(i)                                           &
+             +(fshtr(i)/2.)*dtime*rotrhi(i)                        & 
+             +rotrhi(i)*masktr(i)*zx_coef(i,1)/RG                  &
+             *(zx_ctr(i,1)*(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)) &
+             +zx_alpha2(i)*zx_ctr(i,2))
+        !
+        zx_b = 1. + rotrhi(i)*masktr(i)*zx_coef(i,1)/RG  &
+             * (1.-zx_dtr(i,1)                           &
+             *(zx_alpha1(i)+zx_alpha2(i)*zx_dtr(i,2)))   &
+             + dtime / tautr                             &
+             + dtime * vdeptr / hsoltr
+        ! 
+        zx_trs(i) = zx_a / zx_b
+        local_trs(i) = zx_trs(i)
+     ENDIF
+
+!----------------------------------------------
+! Au dessus des oceans et aux hautes latitudes
+!--
+! au dessous de -60S  pas d'emission de radon au dessus 
+! des oceans et des continents
+!---------------------------------------------------------------
+
+     IF ( (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.0).OR.       &
+          (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.1.AND.lat(i).LT.-60.)) THEN
+        zx_trs(i) = 0.
+        local_trs(i) = 0.
+     END IF
+!--
+! au dessus de 70 N pas d'emission de radon au dessus 
+! des oceans et des continents
+!--------------------------------------------------------------
+     IF ( (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.0).OR.    &
+          (itr.EQ.id_rn.AND.NINT(masktr(i)).EQ.1.AND.lat(i).GT.70.)) THEN
+        zx_trs(i) = 0.
+        local_trs(i) = 0.
+     END IF
+!---------------------------------------------
+! Au dessus des oceans la source est nulle
+!--------------------------------------------
+
+     IF (itr.eq.id_rn.AND.NINT(masktr(i)).EQ.0) THEN
+        zx_trs(i) = 0.
+        local_trs(i) = 0.
+     END IF
+
+  ENDDO    ! sur le i=1,klon
+!
+!======================================================================
+! Une fois on a zx_trs, on peut faire l'iteration 
+!====================================================================== 
+
+  DO i = 1, klon
+     local_tr(i,1) = zx_ctr(i,1)+zx_dtr(i,1)*zx_trs(i)
+  ENDDO
+  DO l = 2, klev
+     DO i = 1, klon
+        local_tr(i,l) = zx_ctr(i,l) + zx_dtr(i,l)*local_tr(i,l-1)
+     ENDDO
+  ENDDO
+!======================================================================
+! Calcul du flux de traceur (flux_tr): UA/(m**2 s)
+!======================================================================
+  DO i = 1, klon
+     flux_tr(i,1) = masktr(i)*zx_coef(i,1)/RG                      &
+          * (zx_alpha1(i)*local_tr(i,1)+zx_alpha2(i)*local_tr(i,2) &
+          -zx_trs(i)) / dtime
+  ENDDO
+  DO l = 2, klev
+     DO i = 1, klon
+        flux_tr(i,l) = zx_coef(i,l)/RG                    &
+             * (local_tr(i,l)-local_tr(i,l-1)) / dtime
+     ENDDO
+  ENDDO
+!======================================================================
+! Calcul des tendances du traceur ds le sol et dans l'atmosphere
+!======================================================================
+  DO l = 1, klev
+     DO i = 1, klon
+        d_tr(i,l) = local_tr(i,l) - tr(i,l)
+     ENDDO
+  ENDDO
+  DO i = 1, klon
+     d_trs(i) = local_trs(i) - trs(i)
+  ENDDO
+
+END SUBROUTINE cltracrn
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/coef_diff_turb_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/coef_diff_turb_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/coef_diff_turb_mod.F90	(revision 17)
@@ -0,0 +1,586 @@
+!
+MODULE coef_diff_turb_mod
+!
+! This module contains some procedures for calculation of the coefficients of the
+! turbulent diffusion in the atmosphere and coefficients for turbulent diffusion 
+! at surface(cdrag)
+!
+  IMPLICIT NONE
+  
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE coef_diff_turb(dtime, nsrf, knon, ni, &
+       ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, ycdragm, &
+       ycoefm, ycoefh ,yq2)
+ 
+    USE dimphy
+    USE indice_sol_mod
+!
+! Calculate coefficients(ycoefm, ycoefh) for turbulent diffusion in the 
+! atmosphere 
+! NB! No values are calculated between surface and the first model layer. 
+!     ycoefm(:,1) and ycoefh(:,1) are not valid !!!
+!
+!
+! Input arguments
+!****************************************************************************************
+    REAL, INTENT(IN)                           :: dtime
+    INTEGER, INTENT(IN)                        :: nsrf, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)       :: ni
+    REAL, DIMENSION(klon,klev+1), INTENT(IN)   :: ypaprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: ypplay
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yu, yv
+    REAL, DIMENSION(klon,klev), INTENT(IN)     :: yq, yt
+    REAL, DIMENSION(klon), INTENT(IN)          :: yts, yrugos, yqsurf
+    REAL, DIMENSION(klon), INTENT(IN)          :: ycdragm
+
+! InOutput arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev+1), INTENT(INOUT):: yq2
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefh
+    REAL, DIMENSION(klon,klev), INTENT(OUT)    :: ycoefm
+
+! Other local variables
+!****************************************************************************************
+    INTEGER                                    :: k, i, j
+    REAL, DIMENSION(klon,klev)                 :: ycoefm0, ycoefh0, yzlay, yteta
+    REAL, DIMENSION(klon,klev+1)               :: yzlev, q2diag, ykmm, ykmn, ykmq
+    REAL, DIMENSION(klon)                      :: yustar
+
+! Include
+!****************************************************************************************
+    INCLUDE "clesphys.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "compbl.h"
+    INCLUDE "YOETHF.h"
+    INCLUDE "YOMCST.h"
+
+
+!****************************************************************************************    
+! Calcul de coefficients de diffusion turbulent de l'atmosphere : 
+! ycoefm(:,2:klev), ycoefh(:,2:klev) 
+!
+!****************************************************************************************    
+
+    CALL coefkz(nsrf, knon, ypaprs, ypplay, &
+         ksta, ksta_ter, &
+         yts, yrugos, yu, yv, yt, yq, &
+         yqsurf, &
+         ycoefm, ycoefh)
+  
+!****************************************************************************************
+! Eventuelle recalcule des coeffeicients de diffusion turbulent de l'atmosphere : 
+! ycoefm(:,2:klev), ycoefh(:,2:klev) 
+!
+!****************************************************************************************
+
+    IF (iflag_pbl.EQ.1) THEN
+       CALL coefkz2(nsrf, knon, ypaprs, ypplay, yt, &
+            ycoefm0, ycoefh0)
+
+       DO k = 2, klev
+          DO i = 1, knon
+             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+          ENDDO
+       ENDDO
+    ENDIF
+
+  
+!****************************************************************************************  
+! Calcul d'une diffusion minimale pour les conditions tres stables
+!
+!****************************************************************************************
+    IF (ok_kzmin) THEN
+       CALL coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycdragm, &
+            ycoefm0,ycoefh0)
+       
+       DO k = 2, klev
+          DO i = 1, knon
+             ycoefm(i,k) = MAX(ycoefm(i,k),ycoefm0(i,k))
+             ycoefh(i,k) = MAX(ycoefh(i,k),ycoefh0(i,k))
+          ENDDO
+       ENDDO
+       
+    ENDIF
+
+  
+!****************************************************************************************
+! MELLOR ET YAMADA adapte a Mars Richard Fournier et Frederic Hourdin
+! 
+!****************************************************************************************
+
+    IF (iflag_pbl.GE.3) THEN
+
+       yzlay(1:knon,1)= &
+            RD*yt(1:knon,1)/(0.5*(ypaprs(1:knon,1)+ypplay(1:knon,1))) &
+            *(ypaprs(1:knon,1)-ypplay(1:knon,1))/RG
+       DO k=2,klev
+          DO i = 1, knon
+             yzlay(i,k)= &
+                  yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k)) &
+                  /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG
+          END DO
+       END DO
+
+       DO k=1,klev
+          DO i = 1, knon
+             yteta(i,k)= &
+                  yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**RKAPPA &
+                  *(1.+0.61*yq(i,k))
+          END DO
+       END DO
+
+       yzlev(1:knon,1)=0.
+       yzlev(1:knon,klev+1)=2.*yzlay(1:knon,klev)-yzlay(1:knon,klev-1)
+       DO k=2,klev
+          DO i = 1, knon
+             yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1))
+          END DO
+       END DO
+
+!!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!$! Pour memoire, le papier Hourdin et al. 2002 a ete obtenur avec un
+!!$! bug sur les coefficients de surface :
+!!$!          ycdragh(1:knon) = ycoefm(1:knon,1)
+!!$!          ycdragm(1:knon) = ycoefh(1:knon,1)
+!!$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+       CALL ustarhb(knon,yu,yv,ycdragm, yustar)
+     
+       IF (prt_level > 9) THEN
+          WRITE(lunout,*) 'USTAR = ',yustar
+       ENDIF
+         
+!   iflag_pbl peut etre utilise comme longuer de melange
+       IF (iflag_pbl.GE.31) THEN
+          CALL vdif_kcay(knon,dtime,RG,RD,ypaprs,yt, &
+               yzlev,yzlay,yu,yv,yteta, &
+               ycdragm,yq2,q2diag,ykmm,ykmn,yustar, &
+               iflag_pbl)
+       ELSE IF (iflag_pbl<20) THEN
+          CALL yamada4(knon,dtime,RG,RD,ypaprs,yt, &
+               yzlev,yzlay,yu,yv,yteta, &
+               ycdragm,yq2,ykmm,ykmn,ykmq,yustar, &
+               iflag_pbl)
+       ENDIF
+       
+       ycoefm(1:knon,2:klev)=ykmm(1:knon,2:klev)
+       ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev)
+               
+    ENDIF !(iflag_pbl.ge.3)
+
+  END SUBROUTINE coef_diff_turb
+!
+!****************************************************************************************
+!
+  SUBROUTINE coefkz(nsrf, knon, paprs, pplay, &
+       ksta, ksta_ter, &
+       ts, rugos, &
+       u,v,t,q, &
+       qsurf, &
+       pcfm, pcfh)
+    
+    USE dimphy
+    USE indice_sol_mod
+  
+!======================================================================
+! Auteur(s) F. Hourdin, M. Forichon, Z.X. Li (LMD/CNRS) date: 19930922
+!           (une version strictement identique a l'ancien modele)
+! Objet: calculer le coefficient du frottement du sol (Cdrag) et les
+!        coefficients d'echange turbulent dans l'atmosphere.
+! Arguments:
+! nsrf-----input-I- indicateur de la nature du sol
+! knon-----input-I- nombre de points a traiter
+! paprs----input-R- pregssion a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! ts-------input-R- temperature du sol (en Kelvin)
+! rugos----input-R- longeur de rugosite (en m)
+! u--------input-R- vitesse u
+! v--------input-R- vitesse v
+! t--------input-R- temperature (K)
+! q--------input-R- vapeur d'eau (kg/kg)
+!
+! pcfm-----output-R- coefficients a calculer (vitesse)
+! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
+!======================================================================
+    INCLUDE "YOETHF.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "compbl.h"
+    INCLUDE "YOMCST.h"
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                      :: knon, nsrf
+    REAL, INTENT(IN)                         :: ksta, ksta_ter
+    REAL, DIMENSION(klon), INTENT(IN)        :: ts
+    REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+    REAL, DIMENSION(klon,klev), INTENT(IN)   :: u, v, t, q
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugos
+    REAL, DIMENSION(klon), INTENT(IN)        :: qsurf
+
+    REAL, DIMENSION(klon,klev), INTENT(OUT)  :: pcfm, pcfh
+
+!
+! Local variables:
+!
+    INTEGER, DIMENSION(klon)    :: itop ! numero de couche du sommet de la couche limite
+!
+! Quelques constantes et options:
+!
+    REAL, PARAMETER :: cepdu2=0.1**2
+    REAL, PARAMETER :: CKAP=0.4
+    REAL, PARAMETER :: cb=5.0
+    REAL, PARAMETER :: cc=5.0
+    REAL, PARAMETER :: cd=5.0
+    REAL, PARAMETER :: clam=160.0
+    REAL, PARAMETER :: ratqs=0.05 ! largeur de distribution de vapeur d'eau
+    LOGICAL, PARAMETER :: richum=.TRUE. ! utilise le nombre de Richardson humide
+    REAL, PARAMETER :: ric=0.4 ! nombre de Richardson critique
+    REAL, PARAMETER :: prandtl=0.4
+    REAL kstable ! diffusion minimale (situation stable)
+    ! GKtest
+    ! PARAMETER (kstable=1.0e-10)
+!IM: 261103     REAL kstable_ter, kstable_sinon
+!IM: 211003 cf GK   PARAMETER (kstable_ter = 1.0e-6)
+!IM: 261103     PARAMETER (kstable_ter = 1.0e-8)
+!IM: 261103   PARAMETER (kstable_ter = 1.0e-10)
+!IM: 261103   PARAMETER (kstable_sinon = 1.0e-10)
+    ! fin GKtest
+    REAL, PARAMETER :: mixlen=35.0 ! constante controlant longueur de melange
+    INTEGER isommet ! le sommet de la couche limite
+    LOGICAL, PARAMETER :: tvirtu=.TRUE. ! calculer Ri d'une maniere plus performante
+    LOGICAL, PARAMETER :: opt_ec=.FALSE.! formule du Centre Europeen dans l'atmosphere
+
+!
+! Variables locales:
+    INTEGER i, k !IM 120704
+    REAL zgeop(klon,klev)
+    REAL zmgeom(klon)
+    REAL zri(klon)
+    REAL zl2(klon)
+    REAL zdphi, zdu2, ztvd, ztvu, zcdn
+    REAL zscf
+    REAL zt, zq, zdelta, zcvm5, zcor, zqs, zfr, zdqs
+    REAL z2geomf, zalh2, zalm2, zscfh, zscfm
+    REAL, PARAMETER :: t_coup=273.15
+    LOGICAL, PARAMETER :: check=.FALSE.
+!
+! contre-gradient pour la chaleur sensible: Kelvin/metre
+    REAL gamt(2:klev)
+
+    LOGICAL, SAVE :: appel1er=.TRUE.
+    !$OMP THREADPRIVATE(appel1er)
+!
+! Fonctions thermodynamiques et fonctions d'instabilite
+    REAL fsta, fins, x
+
+    fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+    fins(x) = SQRT(1.0-18.0*x)
+
+    isommet=klev
+      
+    IF (appel1er) THEN
+       IF (prt_level > 9) THEN
+          WRITE(lunout,*)'coefkz, opt_ec:', opt_ec
+          WRITE(lunout,*)'coefkz, richum:', richum
+          IF (richum) WRITE(lunout,*)'coefkz, ratqs:', ratqs
+          WRITE(lunout,*)'coefkz, isommet:', isommet
+          WRITE(lunout,*)'coefkz, tvirtu:', tvirtu
+          appel1er = .FALSE.
+       ENDIF
+    ENDIF
+!
+! Initialiser les sorties
+!
+    DO k = 1, klev
+       DO i = 1, knon
+          pcfm(i,k) = 0.0
+          pcfh(i,k) = 0.0
+       ENDDO
+    ENDDO
+    DO i = 1, knon
+       itop(i) = 0
+    ENDDO
+    
+!
+! Prescrire la valeur de contre-gradient
+!
+    IF (iflag_pbl.EQ.1) THEN
+       DO k = 3, klev
+          gamt(k) = -1.0E-03
+       ENDDO
+       gamt(2) = -2.5E-03
+    ELSE
+       DO k = 2, klev
+          gamt(k) = 0.0
+       ENDDO
+    ENDIF
+!IM cf JLD/ GKtest
+    IF ( nsrf .NE. is_oce ) THEN
+!IM 261103     kstable = kstable_ter
+       kstable = ksta_ter
+    ELSE
+!IM 261103     kstable = kstable_sinon
+       kstable = ksta
+    ENDIF
+!IM cf JLD/ GKtest fin
+
+!
+! Calculer les geopotentiels de chaque couche
+!
+    DO i = 1, knon
+       zgeop(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1))) &
+            * (paprs(i,1)-pplay(i,1))
+    ENDDO
+    DO k = 2, klev
+       DO i = 1, knon
+          zgeop(i,k) = zgeop(i,k-1) &
+               + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k) &
+               * (pplay(i,k-1)-pplay(i,k))
+       ENDDO
+    ENDDO
+
+!
+! Calculer les coefficients turbulents dans l'atmosphere
+!
+    DO i = 1, knon
+       itop(i) = isommet
+    ENDDO
+
+
+    DO k = 2, isommet
+       DO i = 1, knon
+          zdu2=MAX(cepdu2,(u(i,k)-u(i,k-1))**2 &
+               +(v(i,k)-v(i,k-1))**2)
+          zmgeom(i)=zgeop(i,k)-zgeop(i,k-1)
+          zdphi =zmgeom(i) / 2.0
+          zt = (t(i,k)+t(i,k-1)) * 0.5
+          zq = (q(i,k)+q(i,k-1)) * 0.5
+
+!
+! Calculer Qs et dQs/dT:
+!
+          IF (thermcep) THEN
+             zdelta = MAX(0.,SIGN(1.,RTT-zt))
+             zcvm5 = R5LES*RLVTT/RCPD/(1.0+RVTMP2*zq)*(1.-zdelta) &
+                  + R5IES*RLSTT/RCPD/(1.0+RVTMP2*zq)*zdelta
+             zqs = R2ES * FOEEW(zt,zdelta) / pplay(i,k)
+             zqs = MIN(0.5,zqs)
+             zcor = 1./(1.-RETV*zqs)
+             zqs = zqs*zcor
+             zdqs = FOEDE(zt,zdelta,zcvm5,zqs,zcor)
+          ELSE
+             IF (zt .LT. t_coup) THEN
+                zqs = qsats(zt) / pplay(i,k)
+                zdqs = dqsats(zt,zqs)
+             ELSE
+                zqs = qsatl(zt) / pplay(i,k)
+                zdqs = dqsatl(zt,zqs)
+             ENDIF
+          ENDIF
+!
+!           calculer la fraction nuageuse (processus humide):
+!
+          if (zq /= 0.) then
+             zfr = (zq+ratqs*zq-zqs) / (2.0*ratqs*zq)
+          else
+             zfr = 0.
+          end if
+          zfr = MAX(0.0,MIN(1.0,zfr))
+          IF (.NOT.richum) zfr = 0.0
+!
+!           calculer le nombre de Richardson:
+!
+          IF (tvirtu) THEN
+             ztvd =( t(i,k) &
+                  + zdphi/RCPD/(1.+RVTMP2*zq) &
+                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
+                  )*(1.+RETV*q(i,k))
+             ztvu =( t(i,k-1) &
+                  - zdphi/RCPD/(1.+RVTMP2*zq) &
+                  *( (1.-zfr) + zfr*(1.+RLVTT*zqs/RD/zt)/(1.+zdqs) ) &
+                  )*(1.+RETV*q(i,k-1))
+             zri(i) =zmgeom(i)*(ztvd-ztvu)/(zdu2*0.5*(ztvd+ztvu))
+             zri(i) = zri(i) &
+                  + zmgeom(i)*zmgeom(i)/RG*gamt(k) &
+                  *(paprs(i,k)/101325.0)**RKAPPA &
+                  /(zdu2*0.5*(ztvd+ztvu))
+
+          ELSE ! calcul de Ridchardson compatible LMD5
+
+             zri(i) =(RCPD*(t(i,k)-t(i,k-1)) &
+                  -RD*0.5*(t(i,k)+t(i,k-1))/paprs(i,k) &
+                  *(pplay(i,k)-pplay(i,k-1)) &
+                  )*zmgeom(i)/(zdu2*0.5*RCPD*(t(i,k-1)+t(i,k)))
+             zri(i) = zri(i) + &
+                  zmgeom(i)*zmgeom(i)*gamt(k)/RG &
+                  *(paprs(i,k)/101325.0)**RKAPPA &
+                  /(zdu2*0.5*(t(i,k-1)+t(i,k)))
+          ENDIF
+!
+!           finalement, les coefficients d'echange sont obtenus:
+!
+          zcdn=SQRT(zdu2) / zmgeom(i) * RG
+
+          IF (opt_ec) THEN
+             z2geomf=zgeop(i,k-1)+zgeop(i,k)
+             zalm2=(0.5*ckap/RG*z2geomf &
+                  /(1.+0.5*ckap/rg/clam*z2geomf))**2
+             zalh2=(0.5*ckap/rg*z2geomf &
+                  /(1.+0.5*ckap/RG/(clam*SQRT(1.5*cd))*z2geomf))**2
+             IF (zri(i).LT.0.0) THEN  ! situation instable
+                zscf = ((zgeop(i,k)/zgeop(i,k-1))**(1./3.)-1.)**3 &
+                     / (zmgeom(i)/RG)**3 / (zgeop(i,k-1)/RG)
+                zscf = SQRT(-zri(i)*zscf)
+                zscfm = 1.0 / (1.0+3.0*cb*cc*zalm2*zscf)
+                zscfh = 1.0 / (1.0+3.0*cb*cc*zalh2*zscf)
+                pcfm(i,k)=zcdn*zalm2*(1.-2.0*cb*zri(i)*zscfm)
+                pcfh(i,k)=zcdn*zalh2*(1.-3.0*cb*zri(i)*zscfh)
+             ELSE ! situation stable
+                zscf=SQRT(1.+cd*zri(i))
+                pcfm(i,k)=zcdn*zalm2/(1.+2.0*cb*zri(i)/zscf)
+                pcfh(i,k)=zcdn*zalh2/(1.+3.0*cb*zri(i)*zscf)
+             ENDIF
+          ELSE
+             zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,itop(i)+1)) &
+                  /(paprs(i,2)-paprs(i,itop(i)+1)) ))**2
+             pcfm(i,k)=SQRT(MAX(zcdn*zcdn*(ric-zri(i))/ric, kstable))
+             pcfm(i,k)= zl2(i)* pcfm(i,k)
+             pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+          ENDIF
+       ENDDO
+    ENDDO
+
+!
+! Au-dela du sommet, pas de diffusion turbulente:
+!
+    DO i = 1, knon
+       IF (itop(i)+1 .LE. klev) THEN
+          DO k = itop(i)+1, klev
+             pcfh(i,k) = 0.0
+             pcfm(i,k) = 0.0
+          ENDDO
+       ENDIF
+    ENDDO
+      
+  END SUBROUTINE coefkz
+!
+!****************************************************************************************
+!
+  SUBROUTINE coefkz2(nsrf, knon, paprs, pplay,t, &
+       pcfm, pcfh)
+
+    USE dimphy
+    USE indice_sol_mod
+
+!======================================================================
+! J'introduit un peu de diffusion sauf dans les endroits
+! ou une forte inversion est presente
+! On peut dire qu'il represente la convection peu profonde
+!
+! Arguments:
+! nsrf-----input-I- indicateur de la nature du sol
+! knon-----input-I- nombre de points a traiter
+! paprs----input-R- pression a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! t--------input-R- temperature (K)
+!
+! pcfm-----output-R- coefficients a calculer (vitesse)
+! pcfh-----output-R- coefficients a calculer (chaleur et humidite)
+!======================================================================
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                       :: knon, nsrf
+    REAL, DIMENSION(klon, klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon, klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon, klev), INTENT(IN)   :: t(klon,klev)
+    
+    REAL, DIMENSION(klon, klev), INTENT(OUT)  :: pcfm, pcfh
+!
+! Quelques constantes et options:
+!
+    REAL, PARAMETER :: prandtl=0.4
+    REAL, PARAMETER :: kstable=0.002
+!   REAL, PARAMETER :: kstable=0.001
+    REAL, PARAMETER :: mixlen=35.0 ! constante controlant longueur de melange
+    REAL, PARAMETER :: seuil=-0.02 ! au-dela l'inversion est consideree trop faible
+!    PARAMETER (seuil=-0.04)
+!    PARAMETER (seuil=-0.06)
+!    PARAMETER (seuil=-0.09)
+
+!
+! Variables locales:
+!
+    INTEGER i, k, invb(knon)
+    REAL zl2(knon)
+    REAL zdthmin(knon), zdthdp
+
+    INCLUDE "YOMCST.h"
+!
+! Initialiser les sorties
+!
+    DO k = 1, klev
+       DO i = 1, knon
+          pcfm(i,k) = 0.0
+          pcfh(i,k) = 0.0
+       ENDDO
+    ENDDO
+
+!
+! Chercher la zone d'inversion forte
+!
+    DO i = 1, knon
+       invb(i) = klev
+       zdthmin(i)=0.0
+    ENDDO
+    DO k = 2, klev/2-1
+       DO i = 1, knon
+          zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) &
+               - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+          zdthdp = zdthdp * 100.0
+          IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. &
+               zdthdp.LT.zdthmin(i) ) THEN
+             zdthmin(i) = zdthdp
+             invb(i) = k
+          ENDIF
+       ENDDO
+    ENDDO
+
+!
+! Introduire une diffusion:
+!
+    IF ( nsrf.EQ.is_oce ) THEN
+       DO k = 2, klev
+          DO i = 1, knon
+!IM cf FH/GK   IF ( (nsrf.NE.is_oce) .OR.  ! si ce n'est pas sur l'ocean
+!IM cf FH/GK  .     (invb(i).EQ.klev) .OR. ! s'il n'y a pas d'inversion
+      !IM cf JLD/ GKtest TERkz2
+      ! IF ( (nsrf.EQ.is_ter) .OR.  ! si on est sur la terre
+      ! fin GKtest
+
+
+! s'il n'y a pas d'inversion ou si l'inversion est trop faible
+!          IF ( (nsrf.EQ.is_oce) .AND. &
+             IF ( (invb(i).EQ.klev) .OR. (zdthmin(i).GT.seuil) ) THEN 
+                zl2(i)=(mixlen*MAX(0.0,(paprs(i,k)-paprs(i,klev+1)) &
+                     /(paprs(i,2)-paprs(i,klev+1)) ))**2
+                pcfm(i,k)= zl2(i)* kstable
+                pcfh(i,k) = pcfm(i,k) /prandtl ! h et m different
+             ENDIF
+          ENDDO
+       ENDDO
+    ENDIF
+
+  END SUBROUTINE coefkz2
+!
+!****************************************************************************************
+!
+END MODULE coef_diff_turb_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/coefcdrag.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/coefcdrag.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/coefcdrag.F90	(revision 17)
@@ -0,0 +1,146 @@
+!
+!
+!
+      SUBROUTINE coefcdrag (klon, knon, nsrf, zxli, &
+                            speed, t, q, zgeop, psol, &
+                            ts, qsurf, rugos, okri, ri1, &
+                            cdram, cdrah, cdran, zri1, pref)
+
+      USE indice_sol_mod
+
+      IMPLICIT none
+!-------------------------------------------------------------------------
+! Objet : calcul des cdrags pour le moment (cdram) et les flux de chaleur 
+!         sensible et latente (cdrah), du cdrag neutre (cdran), 
+!         du nombre de Richardson entre la surface et le niveau de reference 
+!         (zri1) et de la pression au niveau de reference (pref).    
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! speed---input-R- module du vent au 1er niveau du modele
+! t-------input-R- temperature de l'air au 1er niveau du modele
+! q-------input-R- humidite de l'air au 1er niveau du modele
+! zgeop---input-R- geopotentiel au 1er niveau du modele
+! psol----input-R- pression au sol 
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite de l'air a la surface
+! rugos---input-R- rugosite
+! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
+!                  et zref par rapport au Ri entre la sfce et la 1ere couche
+! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche
+!
+! cdram--output-R- cdrag pour le moment
+! cdrah--output-R- cdrag pour les flux de chaleur latente et sensible
+! cdran--output-R- cdrag neutre
+! zri1---output-R- nb. Richardson entre la surface et la couche zgeop/RG
+! pref---output-R- pression au niveau zgeop/RG
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli 
+      REAL, dimension(klon), intent(in) :: speed, t, q, zgeop, psol
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, ri1 
+      LOGICAL, intent(in) :: okri    
+!
+      REAL, dimension(klon), intent(out) :: cdram, cdrah, cdran, zri1, pref
+!-------------------------------------------------------------------------
+!
+      include "YOMCST.h"
+      include "YOETHF.h"
+! Quelques constantes :
+      REAL, parameter :: RKAR=0.40, CB=5.0, CC=5.0, CD=5.0, cepdu2=(0.1)**2
+!
+! Variables locales :
+      INTEGER :: i
+      REAL, dimension(klon) :: zdu2, zdphi, ztsolv, ztvd
+      REAL, dimension(klon) :: zscf, friv, frih, zucf, zcr
+      REAL, dimension(klon) :: zcfm1, zcfh1
+      REAL, dimension(klon) :: zcfm2, zcfh2
+      REAL, dimension(klon) :: trm0, trm1
+!-------------------------------------------------------------------------
+      REAL :: fsta, fins, x
+      fsta(x) = 1.0 / (1.0+10.0*x*(1+8.0*x))
+      fins(x) = SQRT(1.0-18.0*x)
+!-------------------------------------------------------------------------
+!
+      DO i = 1, knon
+!
+       zdphi(i) = zgeop(i)
+       zdu2(i) = max(cepdu2,speed(i)**2)
+       pref(i) = exp(log(psol(i)) - zdphi(i)/(RD*t(i)* &
+                 (1.+ RETV * max(q(i),0.0))))
+       ztsolv(i) = ts(i)
+       ztvd(i) = t(i) * (psol(i)/pref(i))**RKAPPA
+       trm0(i) = 1. + RETV * max(qsurf(i),0.0)
+       trm1(i) = 1. + RETV * max(q(i),0.0)
+       ztsolv(i) = ztsolv(i) * trm0(i)
+       ztvd(i) = ztvd(i) * trm1(i)
+       zri1(i) = zdphi(i)*(ztvd(i)-ztsolv(i))/(zdu2(i)*ztvd(i))
+!
+! on teste zri1 par rapport au Richardson de la 1ere couche ri1 
+!
+!IM +++
+       IF(1.EQ.0) THEN
+       IF (okri) THEN
+         IF (ri1(i).GE.0.0.AND.zri1(i).LT.0.0) THEN
+           zri1(i) = ri1(i)
+         ELSE IF(ri1(i).LT.0.0.AND.zri1(i).GE.0.0) THEN
+           zri1(i) = ri1(i)
+         ENDIF 
+       ENDIF
+       ENDIF
+!IM ---
+! 
+       cdran(i) = (RKAR/log(1.+zdphi(i)/(RG*rugos(i))))**2
+
+       IF (zri1(i) .ge. 0.) THEN 
+!
+! situation stable : pour eviter les inconsistances dans les cas 
+! tres stables on limite zri1 a 20. cf Hess et al. (1995)
+!
+         zri1(i) = min(20.,zri1(i))
+!
+         IF (.NOT.zxli) THEN
+           zscf(i) = SQRT(1.+CD*ABS(zri1(i)))
+           friv(i) = max(1. / (1.+2.*CB*zri1(i)/ zscf(i)), 0.1)
+           zcfm1(i) = cdran(i) * friv(i)
+           frih(i) = max(1./ (1.+3.*CB*zri1(i)*zscf(i)), 0.1 )
+           zcfh1(i) = cdran(i) * frih(i)
+           cdram(i) = zcfm1(i)
+           cdrah(i) = zcfh1(i)
+         ELSE
+           cdram(i) = cdran(i)* fsta(zri1(i))
+           cdrah(i) = cdran(i)* fsta(zri1(i))
+         ENDIF
+!
+       ELSE
+! 
+! situation instable
+!
+         IF (.NOT.zxli) THEN
+           zucf(i) = 1./(1.+3.0*CB*CC*cdran(i)*SQRT(ABS(zri1(i)) &
+                 *(1.0+zdphi(i)/(RG*rugos(i)))))
+           zcfm2(i) = cdran(i)*max((1.-2.0*CB*zri1(i)*zucf(i)),0.1)
+           zcfh2(i) = cdran(i)*max((1.-3.0*CB*zri1(i)*zucf(i)),0.1)
+           cdram(i) = zcfm2(i)
+           cdrah(i) = zcfh2(i)
+         ELSE
+           cdram(i) = cdran(i)* fins(zri1(i))
+           cdrah(i) = cdran(i)* fins(zri1(i))
+         ENDIF
+!
+! cdrah sur l'ocean cf. Miller et al. (1992)
+!
+         zcr(i) = (0.0016/(cdran(i)*SQRT(zdu2(i))))*ABS(ztvd(i)-ztsolv(i)) &
+               **(1./3.)
+         IF (nsrf.EQ.is_oce) cdrah(i) = cdran(i)*(1.0+zcr(i)**1.25) &
+                  **(1./1.25)
+       ENDIF
+!
+      END DO
+      RETURN 
+      END SUBROUTINE coefcdrag
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/coefkzmin.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/coefkzmin.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/coefkzmin.F	(revision 17)
@@ -0,0 +1,132 @@
+!
+       SUBROUTINE coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycdragm
+     .   ,km,kn)
+
+      USE dimphy
+      IMPLICIT NONE
+
+      include "YOMCST.h"
+
+c.......................................................................
+c  Entrees modifies en attendant une version ou les zlev, et zlay soient
+c  disponibles.
+
+      REAL  ycdragm(klon)
+
+      REAL yu(klon,klev), yv(klon,klev)
+      REAL yt(klon,klev), yq(klon,klev)
+      REAL ypaprs(klon,klev+1), ypplay(klon,klev)
+      REAL yustar(klon)
+      real yzlay(klon,klev),yzlev(klon,klev+1),yteta(klon,klev)
+
+      integer i
+
+c.......................................................................
+c
+c  En entree :
+c  -----------
+c
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c ustar : u*
+c
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c
+c  en sortier :
+c  ------------
+c
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c
+c.......................................................................
+
+      real ustar(klon)
+      real kmin,qmin,pblhmin(klon),coriol(klon)
+      REAL zlev(klon,klev+1)
+      REAL teta(klon,klev)
+
+      REAL km(klon,klev)
+      REAL kn(klon,klev)
+      integer knon
+
+
+      integer nlay,nlev
+      integer ig,k
+
+      real,parameter :: kap=0.4
+
+      nlay=klev
+      nlev=klev+1
+c.......................................................................
+c  en attendant une version ou les zlev, et zlay soient
+c  disponibles.
+c  Debut de la partie qui doit etre unclue a terme dans clmain.
+c
+         do i=1,knon
+            yzlay(i,1)=RD*yt(i,1)/(0.5*(ypaprs(i,1)+ypplay(i,1)))
+     .                *(ypaprs(i,1)-ypplay(i,1))/RG
+         enddo
+         do k=2,klev
+            do i=1,knon
+               yzlay(i,k)=yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k))
+     s                /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG
+            enddo
+         enddo
+         do k=1,klev
+            do i=1,knon
+cATTENTION:on passe la temperature potentielle virt. pour le calcul de K
+             yteta(i,k)=yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**rkappa
+     s          *(1.+0.61*yq(i,k))
+            enddo
+         enddo
+         do i=1,knon
+            yzlev(i,1)=0.
+            yzlev(i,klev+1)=2.*yzlay(i,klev)-yzlay(i,klev-1)
+         enddo
+         do k=2,klev
+            do i=1,knon
+               yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1))
+            enddo
+         enddo
+
+      yustar(1:knon) =SQRT(ycdragm(1:knon)*
+     $       (yu(1:knon,1)*yu(1:knon,1)+yv(1:knon,1)*yv(1:knon,1)))
+
+c  Fin de la partie qui doit etre unclue a terme dans clmain.
+
+Cette routine est ecrite pour avoir en entree ustar, teta et zlev
+c  Ici, on a inclut le calcul de ces trois variables dans la routine
+c  coefkzmin en attendant une nouvelle version de la couche limite
+c  ou ces variables seront disponibles.
+
+c Debut de la routine coefkzmin proprement dite.
+
+      ustar=yustar
+      teta=yteta
+      zlev=yzlev
+
+      do ig=1,knon
+         coriol(ig)=1.e-4
+         pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5)
+      enddo
+         
+      do k=2,klev
+         do ig=1,knon
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=0. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            kn(ig,k)=kmin
+            km(ig,k)=kmin
+         enddo
+      enddo
+
+
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/coefkzmin.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/coefkzmin.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/coefkzmin.F90	(revision 17)
@@ -0,0 +1,135 @@
+!
+       SUBROUTINE coefkzmin(knon,ypaprs,ypplay,yu,yv,yt,yq,ycdragm                   &
+       &   ,km,kn)
+
+      USE dimphy
+      IMPLICIT NONE
+
+      include "YOMCST.h"
+
+!c.......................................................................
+!c  Entrees modifies en attendant une version ou les zlev, et zlay soient
+!c  disponibles.
+
+      REAL  ycdragm(klon)
+
+      REAL yu(klon,klev), yv(klon,klev)
+      REAL yt(klon,klev), yq(klon,klev)
+      REAL ypaprs(klon,klev+1), ypplay(klon,klev)
+      REAL yustar(klon)
+      real yzlay(klon,klev),yzlev(klon,klev+1),yteta(klon,klev)
+
+      integer i
+
+!c.......................................................................
+!c
+!c  En entree :
+!c  -----------
+!c
+!c zlev : altitude a chaque niveau (interface inferieure de la couche
+!c        de meme indice)
+!c ustar : u*
+!c
+!c teta : temperature potentielle au centre de chaque couche
+!c        (en entree : la valeur au debut du pas de temps)
+!c
+!c  en sortier :
+!c  ------------
+!c
+!c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+!c      couche)
+!c      (en sortie : la valeur a la fin du pas de temps)
+!c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+!c      (en sortie : la valeur a la fin du pas de temps)
+!c
+!c.......................................................................
+
+      real ustar(klon)
+      real kmin,qmin,pblhmin(klon),coriol(klon)
+      REAL zlev(klon,klev+1)
+      REAL teta(klon,klev)
+
+      REAL km(klon,klev)
+      REAL kn(klon,klev)
+      integer knon
+
+
+      integer nlay,nlev
+      integer ig,k
+
+      real,parameter :: kap=0.4
+
+      nlay=klev
+      nlev=klev+1
+!c.......................................................................
+!c  en attendant une version ou les zlev, et zlay soient
+!c  disponibles.
+!c  Debut de la partie qui doit etre unclue a terme dans clmain.
+!c
+         do i=1,knon
+            yzlay(i,1)=RD*yt(i,1)/(0.5*(ypaprs(i,1)+ypplay(i,1)))                    &
+       &                *(ypaprs(i,1)-ypplay(i,1))/RG
+         enddo
+         do k=2,klev
+            do i=1,knon
+               yzlay(i,k)=yzlay(i,k-1)+RD*0.5*(yt(i,k-1)+yt(i,k))                    &
+       &                /ypaprs(i,k)*(ypplay(i,k-1)-ypplay(i,k))/RG
+            enddo
+         enddo
+         do k=1,klev
+            do i=1,knon
+!cATTENTION:on passe la temperature potentielle virt. pour le calcul de K
+             yteta(i,k)=yt(i,k)*(ypaprs(i,1)/ypplay(i,k))**rkappa                    &
+       &          *(1.+0.61*yq(i,k))
+            enddo
+         enddo
+         do i=1,knon
+            yzlev(i,1)=0.
+            yzlev(i,klev+1)=2.*yzlay(i,klev)-yzlay(i,klev-1)
+         enddo
+         do k=2,klev
+            do i=1,knon
+               yzlev(i,k)=0.5*(yzlay(i,k)+yzlay(i,k-1))
+            enddo
+         enddo
+
+      yustar(1:knon) =SQRT(ycdragm(1:knon)*                                          &
+       &       (yu(1:knon,1)*yu(1:knon,1)+yv(1:knon,1)*yv(1:knon,1)))
+
+!c  Fin de la partie qui doit etre unclue a terme dans clmain.
+
+!Cette routine est ecrite pour avoir en entree ustar, teta et zlev
+!c  Ici, on a inclut le calcul de ces trois variables dans la routine
+!c  coefkzmin en attendant une nouvelle version de la couche limite
+!c  ou ces variables seront disponibles.
+
+!c Debut de la routine coefkzmin proprement dite.
+
+      ustar=yustar
+      teta=yteta
+      zlev=yzlev
+
+      do ig=1,knon
+         coriol(ig)=1.e-4
+         pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5)
+      enddo
+      PRINT *,'    Fin of coefkzmin k ustar zlev pblhmin qmin kap kn km _____'
+         
+      do k=2,klev
+         do ig=1,knon
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=0. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            kn(ig,k)=kmin
+            km(ig,k)=kmin
+            IF (ig == 1) PRINT *,'    ',k,ustar(ig),zlev(ig,k),pblhmin(ig),&
+              qmin,kap,kn(ig,k),km(ig,k)
+         enddo
+      enddo
+
+
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/comconst.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/comconst.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/comconst.h	(revision 17)
@@ -0,0 +1,42 @@
+!
+! $Id: comconst.h 1795 2013-07-18 08:20:28Z emillour $
+!
+!-----------------------------------------------------------------------
+! INCLUDE comconst.h
+
+      COMMON/comconsti/im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl,          &
+     &                 iflag_top_bound,mode_top_bound
+      COMMON/comconstr/dtvr,daysec,                                     &
+     & pi,dtphys,dtdiss,rad,r,cpp,kappa,cotot,unsim,g,omeg              &
+     &                   ,dissip_factz,dissip_deltaz,dissip_zref        &
+     &                   ,tau_top_bound,                                &
+     & daylen,year_day,molmass, ihf
+
+
+      INTEGER im,jm,lllm,imp1,jmp1,lllmm1,lllmp1,lcl
+      REAL dtvr ! dynamical time step (in s)
+      REAL daysec !length (in s) of a standard day
+      REAL pi    ! something like 3.14159....
+      REAL dtphys ! (s) time step for the physics
+      REAL dtdiss ! (s) time step for the dissipation
+      REAL rad ! (m) radius of the planet
+      REAL r ! Reduced Gas constant r=R/mu
+             ! with R=8.31.. J.K-1.mol-1, mu: mol mass of atmosphere (kg/mol)
+      REAL cpp   ! Specific heat Cp (J.kg-1.K-1)
+      REAL kappa ! kappa=R/Cp 
+      REAL cotot
+      REAL unsim ! = 1./iim
+      REAL g ! (m/s2) gravity
+      REAL omeg ! (rad/s) rotation rate of the planet
+      REAL dissip_factz,dissip_deltaz,dissip_zref
+! top_bound sponge:
+      INTEGER iflag_top_bound ! sponge type
+      INTEGER mode_top_bound  ! sponge mode
+      REAL tau_top_bound ! inverse of sponge characteristic time scale (Hz)
+      REAL daylen ! length of solar day, in 'standard' day length
+      REAL year_day ! Number of standard days in a year
+      REAL molmass ! (g/mol) molar mass of the atmosphere
+
+      REAL ihf ! (W/m2) Intrinsic heat flux (for giant planets)
+
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/comcstphy.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/comcstphy.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/comcstphy.F90	(revision 17)
@@ -0,0 +1,8 @@
+module comcstphy
+  
+  real :: rradius ! planet radius (m)
+  real :: rr      ! recuced gas constant: R/molar mass of atm
+  real :: rg      ! gravity
+  real :: rcpp    ! specific heat of the atmosphere
+
+end module comcstphy
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/comdissnew.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/comdissnew.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/comdissnew.h	(revision 17)
@@ -0,0 +1,30 @@
+!
+! $Id: comdissnew.h 1707 2013-01-11 09:19:19Z fairhead $
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez à n'utiliser que des ! pour les commentaires
+!                 et à bien positionner les & des lignes de continuation 
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!-----------------------------------------------------------------------
+! INCLUDE 'comdissnew.h'
+
+      COMMON/comdissnew/ lstardis,nitergdiv,nitergrot,niterh,tetagdiv,  &
+     &                   tetagrot,tetatemp,coefdis, vert_prof_dissip
+
+      LOGICAL lstardis
+      INTEGER nitergdiv, nitergrot, niterh
+
+      integer vert_prof_dissip ! vertical profile of horizontal dissipation
+!     Allowed values:
+!     0: rational fraction, function of pressure
+!     1: tanh of altitude
+
+      REAL     tetagdiv, tetagrot,  tetatemp, coefdis
+
+!
+! ... Les parametres de ce common comdissnew sont  lues par defrun_new 
+!              sur le fichier  run.def    ....
+!
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/comgeom.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/comgeom.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/comgeom.h	(revision 17)
@@ -0,0 +1,33 @@
+!
+! $Header$
+!
+!CDK comgeom
+      COMMON/comgeom/                                                   &
+     & cu(ip1jmp1),cv(ip1jm),unscu2(ip1jmp1),unscv2(ip1jm),             &
+     & aire(ip1jmp1),airesurg(ip1jmp1),aireu(ip1jmp1),                  &
+     & airev(ip1jm),unsaire(ip1jmp1),apoln,apols,                       &
+     & unsairez(ip1jm),airuscv2(ip1jm),airvscu2(ip1jm),                 &
+     & aireij1(ip1jmp1),aireij2(ip1jmp1),aireij3(ip1jmp1),              &
+     & aireij4(ip1jmp1),alpha1(ip1jmp1),alpha2(ip1jmp1),                &
+     & alpha3(ip1jmp1),alpha4(ip1jmp1),alpha1p2(ip1jmp1),               &
+     & alpha1p4(ip1jmp1),alpha2p3(ip1jmp1),alpha3p4(ip1jmp1),           &
+     & fext(ip1jm),constang(ip1jmp1),rlatu(jjp1),rlatv(jjm),            &
+     & rlonu(iip1),rlonv(iip1),cuvsurcv(ip1jm),cvsurcuv(ip1jm),         &
+     & cvusurcu(ip1jmp1),cusurcvu(ip1jmp1),cuvscvgam1(ip1jm),           &
+     & cuvscvgam2(ip1jm),cvuscugam1(ip1jmp1),                           &
+     & cvuscugam2(ip1jmp1),cvscuvgam(ip1jm),cuscvugam(ip1jmp1),         &
+     & unsapolnga1,unsapolnga2,unsapolsga1,unsapolsga2,                 &
+     & unsair_gam1(ip1jmp1),unsair_gam2(ip1jmp1),unsairz_gam(ip1jm),    &
+     & aivscu2gam(ip1jm),aiuscv2gam(ip1jm),xprimu(iip1),xprimv(iip1)
+
+!
+        REAL                                                            &
+     & cu,cv,unscu2,unscv2,aire,airesurg,aireu,airev,unsaire,apoln     ,&
+     & apols,unsairez,airuscv2,airvscu2,aireij1,aireij2,aireij3,aireij4,&
+     & alpha1,alpha2,alpha3,alpha4,alpha1p2,alpha1p4,alpha2p3,alpha3p4 ,&
+     & fext,constang,rlatu,rlatv,rlonu,rlonv,cuvscvgam1,cuvscvgam2     ,&
+     & cvuscugam1,cvuscugam2,cvscuvgam,cuscvugam,unsapolnga1,unsapolnga2&
+     & ,unsapolsga1,unsapolsga2,unsair_gam1,unsair_gam2,unsairz_gam    ,&
+     & aivscu2gam ,aiuscv2gam,cuvsurcv,cvsurcuv,cvusurcu,cusurcvu,xprimu&
+     & , xprimv
+!
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/comgeomphy.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/comgeomphy.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/comgeomphy.F90	(revision 17)
@@ -0,0 +1,23 @@
+module comgeomphy
+   real,save,allocatable :: airephy(:)
+   real,save,allocatable :: cuphy(:)
+   real,save,allocatable :: cvphy(:)
+   real,save,allocatable :: rlatd(:)
+   real,save,allocatable :: rlond(:)
+!$OMP THREADPRIVATE(airephy,cuphy,cvphy,rlatd,rlond)
+contains
+  
+  subroutine InitComgeomphy
+  USE mod_phys_lmdz_para
+  implicit none
+    
+ 
+    allocate(airephy(klon_omp))
+    allocate(cuphy(klon_omp))
+    allocate(cvphy(klon_omp))
+    allocate(rlatd(klon_omp))
+    allocate(rlond(klon_omp))
+
+  end subroutine InitComgeomphy
+  
+end module comgeomphy
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/compbl.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/compbl.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/compbl.h	(revision 17)
@@ -0,0 +1,6 @@
+      !
+      ! $Header$
+      !
+      integer iflag_pbl
+      common/compbl/iflag_pbl
+!$OMP THREADPRIVATE(/compbl/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/comsoil.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/comsoil.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/comsoil.h	(revision 17)
@@ -0,0 +1,7 @@
+!
+! $Header$
+!
+
+      common /comsoil/inertie_sol,inertie_sno,inertie_ice
+      real inertie_sol,inertie_sno,inertie_ice
+!$OMP THREADPRIVATE(/comsoil/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/comvert.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/comvert.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/comvert.h	(revision 17)
@@ -0,0 +1,38 @@
+!
+! $Id: comvert.h 1795 2013-07-18 08:20:28Z emillour $
+!
+!-----------------------------------------------------------------------
+!   INCLUDE 'comvert.h'
+
+      COMMON/comvertr/ap(llm+1),bp(llm+1),presnivs(llm),dpres(llm),     &
+     &               pa,preff,nivsigs(llm),nivsig(llm+1),               &
+     &               aps(llm),bps(llm),scaleheight,pseudoalt(llm)
+
+      common/comverti/disvert_type, pressure_exner
+
+      real ap     ! hybrid pressure contribution at interlayers
+      real bp     ! hybrid sigma contribution at interlayer
+      real presnivs ! (reference) pressure at mid-layers
+      real dpres
+      real pa     ! reference pressure (Pa) at which hybrid coordinates
+                  ! become purely pressure
+      real preff  ! reference surface pressure (Pa)
+      real nivsigs
+      real nivsig
+      real aps    ! hybrid pressure contribution at mid-layers
+      real bps    ! hybrid sigma contribution at mid-layers
+      real scaleheight ! atmospheric (reference) scale height (km)
+      real pseudoalt ! pseudo-altitude of model levels (km), based on presnivs(),
+                     ! preff and scaleheight
+
+      integer disvert_type ! type of vertical discretization:
+                           ! 1: Earth (default for planet_type==earth),
+                           !     automatic generation
+                           ! 2: Planets (default for planet_type!=earth),
+                           !     using 'z2sig.def' (or 'esasig.def) file
+
+      logical pressure_exner
+!     compute pressure inside layers using Exner function, else use mean
+!     of pressure values at interfaces
+
+ !-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/concvl.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/concvl.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/concvl.F	(revision 17)
@@ -0,0 +1,518 @@
+      SUBROUTINE concvl (iflag_con,iflag_clos,
+     .             dtime,paprs,pplay,
+     .             t,q,t_wake,q_wake,s_wake,u,v,tra,ntra,
+     .             ALE,ALP,work1,work2,
+     .             d_t,d_q,d_u,d_v,d_tra,
+     .             rain, snow, kbas, ktop, sigd,
+     .             cbmf,plcl,plfc,wbeff,upwd,dnwd,dnwdbis,
+     .             Ma,mip,Vprecip,
+     .             cape,cin,tvp,Tconv,iflag,
+     .             pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,
+     .             qcondc,wd,pmflxr,pmflxs,
+! RomP >>>
+!!     .             da,phi,mp,dd_t,dd_q,lalim_conv,wght_th)
+     .             da,phi,mp,phi2,d1a,dam,sij,clw,elij,        ! RomP
+     .             dd_t,dd_q,lalim_conv,wght_th,               ! RomP
+     .             evap, ep, epmlmMm,eplaMm,                   ! RomP
+     .             wdtrainA,wdtrainM)                          ! RomP
+! RomP <<<
+***************************************************************
+*                                                             *
+* CONCVL                                                      *
+*                                                             *
+*                                                             *
+* written by   : Sandrine Bony-Lena, 17/05/2003, 11.16.04    *
+* modified by :                                               *
+***************************************************************
+*
+c
+      USE dimphy
+      USE infotrac, ONLY : nbtr
+      IMPLICIT none
+c======================================================================
+c Auteur(s): S. Bony-Lena (LMD/CNRS) date: ???
+c Objet: schema de convection de Emanuel (1991) interface
+c======================================================================
+c Arguments:
+c dtime--input-R-pas d'integration (s)
+c s-------input-R-la valeur "s" pour chaque couche
+c sigs----input-R-la valeur "sigma" de chaque couche
+c sig-----input-R-la valeur de "sigma" pour chaque niveau
+c psolpa--input-R-la pression au sol (en Pa)
+C pskapa--input-R-exponentiel kappa de psolpa
+c h-------input-R-enthalpie potentielle (Cp*T/P**kappa)
+c q-------input-R-vapeur d'eau (en kg/kg)
+c
+c work*: input et output: deux variables de travail,
+c                            on peut les mettre a 0 au debut
+c ALE-----input-R-energie disponible pour soulevement
+c ALP-----input-R-puissance disponible pour soulevement
+c
+C d_h-----output-R-increment de l'enthalpie potentielle (h)
+c d_q-----output-R-increment de la vapeur d'eau
+c rain----output-R-la pluie (mm/s)
+c snow----output-R-la neige (mm/s)
+c upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
+c Ma------output-R-adiabatic ascent mass flux (kg/m2/s)
+c mip-----output-R-mass flux shed by adiabatic ascent (kg/m2/s)
+c Vprecip-output-R-vertical profile of precipitations (kg/m2/s)
+c Tconv---output-R-environment temperature seen by convective scheme (K)
+c Cape----output-R-CAPE (J/kg)
+c Cin ----output-R-CIN  (J/kg)
+c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
+c                  adiabatiquement a partir du niveau 1 (K)
+c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa)
+c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace
+c dd_t-----output-R-increment de la temperature du aux descentes precipitantes
+c dd_q-----output-R-increment de la vapeur d'eau du aux desc precip
+c======================================================================
+c
+#include "dimensions.h"
+c
+       INTEGER iflag_con,iflag_clos
+c
+       REAL dtime, paprs(klon,klev+1),pplay(klon,klev)
+       REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev)
+       REAL t_wake(klon,klev),q_wake(klon,klev)
+       Real s_wake(klon)
+       REAL tra(klon,klev,nbtr)
+       INTEGER ntra
+       REAL work1(klon,klev),work2(klon,klev),ptop2(klon)
+       REAL pmflxr(klon,klev+1),pmflxs(klon,klev+1)
+       REAL ALE(klon),ALP(klon)
+c
+       REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev)
+       REAL dd_t(klon,klev),dd_q(klon,klev)
+       REAL d_tra(klon,klev,nbtr)
+       REAL rain(klon),snow(klon)
+c
+       INTEGER kbas(klon),ktop(klon)
+       REAL em_ph(klon,klev+1),em_p(klon,klev)
+       REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev)
+
+!!       REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev)     !jyg
+       REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev+1)     !jyg
+
+       real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
+! RomP >>>
+       real phi2(klon,klev,klev)                                    
+       real d1a(klon,klev),dam(klon,klev)
+       real sij(klon,klev,klev),clw(klon,klev),elij(klon,klev,klev)
+       REAL wdtrainA(klon,klev),wdtrainM(klon,klev)
+       REAL evap(klon,klev),ep(klon,klev)
+       REAL epmlmMm(klon,klev,klev),eplaMm(klon,klev)
+! RomP <<<
+       REAL cape(klon),cin(klon),tvp(klon,klev)
+       REAL Tconv(klon,klev)
+c
+cCR:test: on passe lentr et alim_star des thermiques
+       INTEGER lalim_conv(klon)
+       REAL wght_th(klon,klev)
+       REAL em_sig1feed ! sigma at lower bound of feeding layer
+       REAL em_sig2feed ! sigma at upper bound of feeding layer
+       REAL em_wght(klev) ! weight density determining the feeding mixture
+con enleve le save
+c       SAVE em_sig1feed,em_sig2feed,em_wght
+c
+       INTEGER iflag(klon)
+       REAL rflag(klon)
+       REAL pbase(klon),bbase(klon)
+       REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev)
+       REAL dplcldt(klon),dplcldr(klon)
+       REAL qcondc(klon,klev)
+       REAL wd(klon)
+       REAL Plim1(klon),Plim2(klon),asupmax(klon,klev)
+       REAL supmax0(klon),asupmaxmin(klon)
+c
+       REAL sigd(klon)
+       REAL zx_t,zdelta,zx_qs,zcor
+c
+!       INTEGER iflag_mix
+!       SAVE iflag_mix
+       INTEGER noff, minorig
+       INTEGER i,k,itra
+       REAL qs(klon,klev),qs_wake(klon,klev)
+       REAL cbmf(klon),plcl(klon),plfc(klon),wbeff(klon)
+cLF       SAVE cbmf
+cIM/JYG      REAL, SAVE, ALLOCATABLE :: cbmf(:)
+ccc$OMP THREADPRIVATE(cbmf)!       
+       REAL cbmflast(klon)
+       INTEGER ifrst
+       SAVE ifrst
+       DATA ifrst /0/
+c$OMP THREADPRIVATE(ifrst)
+
+c
+C     Variables supplementaires liees au bilan d'energie
+c      Real paire(klon)
+cLF      Real ql(klon,klev)
+c      Save paire
+cLF      Save ql
+cLF      Real t1(klon,klev),q1(klon,klev)
+cLF      Save t1,q1
+c      Data paire /1./
+       REAL, SAVE, ALLOCATABLE :: ql(:,:), q1(:,:), t1(:,:)
+c$OMP THREADPRIVATE(ql, q1, t1)
+c
+C     Variables liees au bilan d'energie et d'enthalpi
+      REAL ztsol(klon)
+      REAL      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     $        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+      SAVE      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     $        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+c$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot)
+c$OMP THREADPRIVATE(h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot)
+      REAL      d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
+      REAL      d_h_vcol_phy
+      REAL      fs_bound, fq_bound
+      SAVE      d_h_vcol_phy
+c$OMP THREADPRIVATE(d_h_vcol_phy)
+      REAL      zero_v(klon)
+      CHARACTER*15 ztit
+      INTEGER   ip_ebil  ! PRINT level for energy conserv. diag.
+      SAVE      ip_ebil
+      DATA      ip_ebil/2/
+c$OMP THREADPRIVATE(ip_ebil)
+      INTEGER   if_ebil ! level for energy conserv. dignostics
+      SAVE      if_ebil
+      DATA      if_ebil/2/
+c$OMP THREADPRIVATE(if_ebil)
+c+jld ec_conser
+      REAL d_t_ec(klon,klev)    ! tendance du a la conersion Ec -> E thermique
+      REAL ZRCPD
+c-jld ec_conser
+cLF
+      INTEGER nloc
+      logical, save :: first=.true.
+c$OMP THREADPRIVATE(first)
+      INTEGER, SAVE :: itap, igout
+c$OMP THREADPRIVATE(itap, igout)
+c
+#include "YOMCST.h"
+#include "YOMCST2.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+#include "iniprint.h"
+c
+      if (first) then
+c Allocate some variables LF 04/2008
+c
+cIM/JYG allocate(cbmf(klon))
+        allocate(ql(klon,klev))
+        allocate(t1(klon,klev))
+        allocate(q1(klon,klev))
+        itap=0
+        igout=klon/2+1/klon
+      endif
+c Incrementer le compteur de la physique
+      itap   = itap + 1
+
+c    Copy T into Tconv
+      DO k = 1,klev
+        DO i = 1,klon
+          Tconv(i,k) = T(i,k)
+        ENDDO
+      ENDDO
+c
+      IF (if_ebil.ge.1) THEN
+        DO i=1,klon
+          ztsol(i) = t(i,1)
+          zero_v(i)=0.
+          Do k = 1,klev
+            ql(i,k) = 0.
+          ENDDO
+        END DO
+      END IF
+c
+cym
+      snow(:)=0
+      
+c      IF (ifrst .EQ. 0) THEN
+c         ifrst = 1
+       if (first) then
+         first=.false.
+c
+C===========================================================================
+C    READ IN PARAMETERS FOR THE CLOSURE AND THE MIXING DISTRIBUTION
+C===========================================================================
+C
+      if (iflag_con.eq.3) then
+c     CALL cv3_inicp()
+      CALL cv3_inip()
+      endif
+c
+C===========================================================================
+C    READ IN PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
+C===========================================================================
+C
+cc$$$         open (56,file='supcrit.data')
+cc$$$         read (56,*) Supcrit1, Supcrit2
+cc$$$         close (56)
+c
+         IF (prt_level .ge. 10) 
+     &       WRITE(lunout,*) 'supcrit1, supcrit2' ,supcrit1, supcrit2
+C
+C===========================================================================
+C      Initialisation pour les bilans d'eau et d'energie
+C===========================================================================
+         IF (if_ebil.ge.1) d_h_vcol_phy=0.
+c
+         DO i = 1, klon
+          cbmf(i) = 0.
+!!          plcl(i) = 0.
+          sigd(i) = 0.
+         ENDDO
+      ENDIF   !(ifrst .EQ. 0)
+
+c Initialisation a chaque pas de temps
+      plfc(:)  = 0.
+      wbeff(:) = 100.
+      plcl(:) = 0.
+
+      DO k = 1, klev+1
+         DO i=1,klon
+         em_ph(i,k) = paprs(i,k) / 100.0
+         pmflxr(i,k)=0.
+         pmflxs(i,k)=0.
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+         DO i=1,klon
+         em_p(i,k) = pplay(i,k) / 100.0
+      ENDDO
+      ENDDO
+c
+!
+!  Feeding layer
+!
+      em_sig1feed = 1.
+      em_sig2feed = 0.97
+c      em_sig2feed = 0.8
+! Relative Weight densities
+       do k=1,klev
+         em_wght(k)=1.
+       end do
+cCRtest: couche alim des tehrmiques ponderee par a*
+c       DO i = 1, klon
+c         do k=1,lalim_conv(i)
+c         em_wght(k)=wght_th(i,k)
+c         print*,'em_wght=',em_wght(k),wght_th(i,k)
+c       end do
+c      END DO
+
+      if (iflag_con .eq. 4) then
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0)
+         zcor=1./(1.-retv*zx_qs)
+         qs(i,k)=zx_qs*zcor
+        ENDDO
+        DO i = 1, klon
+         zx_t = t_wake(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0)
+         zcor=1./(1.-retv*zx_qs)
+         qs_wake(i,k)=zx_qs*zcor
+        ENDDO
+      ENDDO
+      else ! iflag_con=3 (modif de puristes qui fait la diffce pour la convergence numerique)
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0
+         zx_qs= MIN(0.5,zx_qs)
+         zcor=1./(1.-retv*zx_qs)
+         zx_qs=zx_qs*zcor
+         qs(i,k)=zx_qs
+        ENDDO
+        DO i = 1, klon
+         zx_t = t_wake(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0
+         zx_qs= MIN(0.5,zx_qs)
+         zcor=1./(1.-retv*zx_qs)
+         zx_qs=zx_qs*zcor
+         qs_wake(i,k)=zx_qs
+        ENDDO
+      ENDDO
+      endif ! iflag_con
+c
+C------------------------------------------------------------------
+
+C Main driver for convection:
+C               iflag_con=3 -> nvlle version de KE (JYG)
+C		iflag_con = 30  -> equivalent to convect3
+C		iflag_con = 4  -> equivalent to convect1/2
+c
+c
+      if (iflag_con.eq.30) then
+
+      print *, '-> cv_driver'      !jyg
+      CALL cv_driver(klon,klev,klevp1,ntra,iflag_con,
+     :              t,q,qs,u,v,tra,
+     $              em_p,em_ph,iflag,
+     $              d_t,d_q,d_u,d_v,d_tra,rain,
+     $              Vprecip,cbmf,work1,work2,                  !jyg
+     $              kbas,ktop,
+     $              dtime,Ma,upwd,dnwd,dnwdbis,qcondc,wd,cape,
+     $              da,phi,mp,phi2,d1a,dam,sij,clw,elij,       !RomP
+     $              evap,ep,epmlmMm,eplaMm,                    !RomP
+     $              wdtrainA,wdtrainM)                         !RomP
+      print *, 'cv_driver ->'      !jyg
+c
+      DO i = 1,klon
+        cbmf(i) = Ma(i,kbas(i))
+      ENDDO
+c
+      else
+
+cLF   necessary for gathered fields
+      nloc=klon
+      CALL cva_driver(klon,klev,klev+1,ntra,nloc,
+     $              iflag_con,iflag_mix,iflag_clos,dtime,
+     :              t,q,qs,t_wake,q_wake,qs_wake,s_wake,u,v,tra,
+     $              em_p,em_ph,
+     .              ALE,ALP,
+     .              em_sig1feed,em_sig2feed,em_wght,
+     .              iflag,d_t,d_q,d_u,d_v,d_tra,rain,kbas,ktop,
+     $              cbmf,plcl,plfc,wbeff,work1,work2,ptop2,sigd,
+     $              Ma,mip,Vprecip,upwd,dnwd,dnwdbis,qcondc,wd,
+     $              cape,cin,tvp,
+     $              dd_t,dd_q,Plim1,Plim2,asupmax,supmax0,
+     $              asupmaxmin,lalim_conv,
+!AC!+!RomP+jyg
+     $              da,phi,mp,phi2,d1a,dam,sij,clw,elij,       ! RomP
+     $              evap,ep,epmlmMm,eplaMm,                    ! RomP
+     $              wdtrainA,wdtrainM)                         ! RomP
+!AC!+!RomP+jyg
+      endif  
+C------------------------------------------------------------------
+      IF (prt_level .ge. 10)
+     .   WRITE(lunout,*) ' cva_driver -> cbmf,plcl,plfc,wbeff ',
+     .                     cbmf(1),plcl(1),plfc(1),wbeff(1)
+
+      DO i = 1,klon
+        rain(i) = rain(i)/86400.
+        rflag(i)=iflag(i)
+      ENDDO
+
+      DO k = 1, klev
+        DO i = 1, klon
+           d_t(i,k) = dtime*d_t(i,k)
+           d_q(i,k) = dtime*d_q(i,k)
+           d_u(i,k) = dtime*d_u(i,k)
+           d_v(i,k) = dtime*d_v(i,k)
+        ENDDO
+      ENDDO
+c
+       if (iflag_con.eq.30) then
+       DO itra = 1,ntra
+        DO k = 1, klev
+         DO i = 1, klon
+            d_tra(i,k,itra) =dtime*d_tra(i,k,itra) 
+         ENDDO
+        ENDDO
+       ENDDO 
+       endif
+
+c!AC!
+       if (iflag_con.eq.3) then
+       DO itra = 1,ntra
+        DO k = 1, klev
+         DO i = 1, klon
+            d_tra(i,k,itra) =dtime*d_tra(i,k,itra) 
+         ENDDO
+        ENDDO
+       ENDDO 
+       endif
+c!AC!
+
+      DO k = 1, klev
+        DO i = 1, klon
+          t1(i,k) = t(i,k)+ d_t(i,k)
+          q1(i,k) = q(i,k)+ d_q(i,k)
+        ENDDO
+      ENDDO
+c                                                  !jyg
+c--Separation neige/pluie (pour diagnostics)       !jyg
+      DO k = 1, klev                               !jyg
+      DO i = 1, klon                               !jyg
+       IF (t1(i,k).LT.RTT) THEN                    !jyg
+         pmflxs(i,k)=Vprecip(i,k)                  !jyg
+       ELSE                                        !jyg
+         pmflxr(i,k)=Vprecip(i,k)                  !jyg
+       ENDIF                                       !jyg
+      ENDDO                                        !jyg
+      ENDDO                                        !jyg
+c
+cc      IF (if_ebil.ge.2) THEN
+cc        ztit='after convect'
+cc        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
+cc     e      , t1,q1,ql,qs,u,v,paprs,pplay
+cc     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+cc         call diagphy(paire,ztit,ip_ebil
+cc     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+cc     e      , zero_v, rain, zero_v, ztsol
+cc     e      , d_h_vcol, d_qt, d_ec
+cc     s      , fs_bound, fq_bound )
+cc      END IF
+C
+c
+c les traceurs ne sont pas mis dans cette version de convect4:
+      if (iflag_con.eq.4) then
+       DO itra = 1,ntra
+        DO k = 1, klev
+         DO i = 1, klon
+            d_tra(i,k,itra) = 0.
+         ENDDO
+        ENDDO
+       ENDDO
+      endif
+c     print*, 'concvl->: dd_t,dd_q ',dd_t(1,1),dd_q(1,1)
+
+        DO k = 1, klev
+         DO i = 1, klon
+            dtvpdt1(i,k) = 0.
+            dtvpdq1(i,k) = 0.
+         ENDDO
+        ENDDO
+        DO i = 1, klon
+           dplcldt(i) = 0.
+           dplcldr(i) = 0.
+        ENDDO
+c
+       if(prt_level.GE.20) THEN
+       DO k=1,klev
+!       print*,'physiq apres_add_con i k it d_u d_v d_t d_q qdl0',igout
+!    .,k,itap,d_u_con(igout,k) ,d_v_con(igout,k), d_t_con(igout,k),
+!    .d_q_con(igout,k),dql0(igout,k)
+!      print*,'phys apres_add_con itap Ma cin ALE ALP wak t q undi t q'
+!    .,itap,Ma(igout,k),cin(igout),ALE(igout), ALP(igout),
+!    . t_wake(igout,k),q_wake(igout,k),t_undi(igout,k),q_undi(igout,k)
+!      print*,'phy apres_add_con itap CON rain snow EMA wk1 wk2 Vpp mip'
+!    .,itap,rain_con(igout),snow_con(igout),ema_work1(igout,k),
+!    .ema_work2(igout,k),Vprecip(igout,k), mip(igout,k)
+!      print*,'phy apres_add_con itap upwd dnwd dnwd0 cape tvp Tconv '
+!    .,itap,upwd(igout,k),dnwd(igout,k),dnwd0(igout,k),cape(igout),
+!    .tvp(igout,k),Tconv(igout,k)
+!      print*,'phy apres_add_con itap dtvpdt dtvdq dplcl dplcldr qcondc'
+!    .,itap,dtvpdt1(igout,k),dtvpdq1(igout,k),dplcldt(igout),
+!    .dplcldr(igout),qcondc(igout,k)
+!      print*,'phy apres_add_con itap wd pmflxr Kpmflxr Kp1 Kpmflxs Kp1'
+!    .,itap,wd(igout),pmflxr(igout,k),pmflxr(igout,k+1),pmflxs(igout,k)
+!    .,pmflxs(igout,k+1)
+!      print*,'phy apres_add_con itap da phi mp ftd fqd lalim wgth',
+!    .itap,da(igout,k),phi(igout,k,k),mp(igout,k),ftd(igout,k),
+!    . fqd(igout,k),lalim_conv(igout),wght_th(igout,k)
+      ENDDO
+      endif !(prt_level.EQ.20) THEN
+c
+      RETURN
+      END
+ 
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/concvl.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/concvl.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/concvl.F90	(revision 17)
@@ -0,0 +1,518 @@
+      SUBROUTINE concvl (iflag_con,iflag_clos,                                       &
+       &             dtime,paprs,pplay,                                              &
+       &             t,q,t_wake,q_wake,s_wake,u,v,tra,ntra,                          &
+       &             ALE,ALP,work1,work2,                                            &
+       &             d_t,d_q,d_u,d_v,d_tra,                                          &
+       &             rain, snow, kbas, ktop, sigd,                                   &
+       &             cbmf,plcl,plfc,wbeff,upwd,dnwd,dnwdbis,                         &
+       &             Ma,mip,Vprecip,                                                 &
+       &             cape,cin,tvp,Tconv,iflag,                                       &
+       &             pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,                    &
+       &             qcondc,wd,pmflxr,pmflxs,                                        &
+! RomP >>>
+!!     .             da,phi,mp,dd_t,dd_q,lalim_conv,wght_th)                         &
+       &             da,phi,mp,phi2,d1a,dam,sij,clw,elij,                            & ! RomP
+       &             dd_t,dd_q,lalim_conv,wght_th,                                   & ! RomP
+       &             evap, ep, epmlmMm,eplaMm,                                       & ! RomP
+       &             wdtrainA,wdtrainM)                                                ! RomP
+! RomP <<<
+!***************************************************************
+!*                                                             *
+!* CONCVL                                                      *
+!*                                                             *
+!*                                                             *
+!* written by   : Sandrine Bony-Lena, 17/05/2003, 11.16.04    *
+!* modified by :                                               *
+!***************************************************************
+!*
+!c
+      USE dimphy
+      USE infotrac, ONLY : nbtr
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): S. Bony-Lena (LMD/CNRS) date: ???
+!c Objet: schema de convection de Emanuel (1991) interface
+!c======================================================================
+!c Arguments:
+!c dtime--input-R-pas d'integration (s)
+!c s-------input-R-la valeur "s" pour chaque couche
+!c sigs----input-R-la valeur "sigma" de chaque couche
+!c sig-----input-R-la valeur de "sigma" pour chaque niveau
+!c psolpa--input-R-la pression au sol (en Pa)
+!C pskapa--input-R-exponentiel kappa de psolpa
+!c h-------input-R-enthalpie potentielle (Cp*T/P**kappa)
+!c q-------input-R-vapeur d'eau (en kg/kg)
+!c
+!c work*: input et output: deux variables de travail,
+!c                            on peut les mettre a 0 au debut
+!c ALE-----input-R-energie disponible pour soulevement
+!c ALP-----input-R-puissance disponible pour soulevement
+!c
+!C d_h-----output-R-increment de l'enthalpie potentielle (h)
+!c d_q-----output-R-increment de la vapeur d'eau
+!c rain----output-R-la pluie (mm/s)
+!c snow----output-R-la neige (mm/s)
+!c upwd----output-R-saturated updraft mass flux (kg/m**2/s)
+!c dnwd----output-R-saturated downdraft mass flux (kg/m**2/s)
+!c dnwd0---output-R-unsaturated downdraft mass flux (kg/m**2/s)
+!c Ma------output-R-adiabatic ascent mass flux (kg/m2/s)
+!c mip-----output-R-mass flux shed by adiabatic ascent (kg/m2/s)
+!c Vprecip-output-R-vertical profile of precipitations (kg/m2/s)
+!c Tconv---output-R-environment temperature seen by convective scheme (K)
+!c Cape----output-R-CAPE (J/kg)
+!c Cin ----output-R-CIN  (J/kg)
+!c Tvp-----output-R-Temperature virtuelle d'une parcelle soulevee
+!c                  adiabatiquement a partir du niveau 1 (K)
+!c deltapb-output-R-distance entre LCL et base de la colonne (<0 ; Pa)
+!c Ice_flag-input-L-TRUE->prise en compte de la thermodynamique de la glace
+!c dd_t-----output-R-increment de la temperature du aux descentes precipitantes
+!c dd_q-----output-R-increment de la vapeur d'eau du aux desc precip
+!c======================================================================
+!c
+#include "dimensions.h"
+!c
+       INTEGER iflag_con,iflag_clos
+!c
+       REAL dtime, paprs(klon,klev+1),pplay(klon,klev)
+       REAL t(klon,klev),q(klon,klev),u(klon,klev),v(klon,klev)
+       REAL t_wake(klon,klev),q_wake(klon,klev)
+       Real s_wake(klon)
+       REAL tra(klon,klev,nbtr)
+       INTEGER ntra
+       REAL work1(klon,klev),work2(klon,klev),ptop2(klon)
+       REAL pmflxr(klon,klev+1),pmflxs(klon,klev+1)
+       REAL ALE(klon),ALP(klon)
+!c
+       REAL d_t(klon,klev),d_q(klon,klev),d_u(klon,klev),d_v(klon,klev)
+       REAL dd_t(klon,klev),dd_q(klon,klev)
+       REAL d_tra(klon,klev,nbtr)
+       REAL rain(klon),snow(klon)
+!c
+       INTEGER kbas(klon),ktop(klon)
+       REAL em_ph(klon,klev+1),em_p(klon,klev)
+       REAL upwd(klon,klev),dnwd(klon,klev),dnwdbis(klon,klev)
+
+!!       REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev)     !jyg
+       REAL Ma(klon,klev), mip(klon,klev),Vprecip(klon,klev+1)     !jyg
+
+       real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
+! RomP >>>
+       real phi2(klon,klev,klev)                                    
+       real d1a(klon,klev),dam(klon,klev)
+       real sij(klon,klev,klev),clw(klon,klev),elij(klon,klev,klev)
+       REAL wdtrainA(klon,klev),wdtrainM(klon,klev)
+       REAL evap(klon,klev),ep(klon,klev)
+       REAL epmlmMm(klon,klev,klev),eplaMm(klon,klev)
+! RomP <<<
+       REAL cape(klon),cin(klon),tvp(klon,klev)
+       REAL Tconv(klon,klev)
+!c
+!cCR:test: on passe lentr et alim_star des thermiques
+       INTEGER lalim_conv(klon)
+       REAL wght_th(klon,klev)
+       REAL em_sig1feed ! sigma at lower bound of feeding layer
+       REAL em_sig2feed ! sigma at upper bound of feeding layer
+       REAL em_wght(klev) ! weight density determining the feeding mixture
+!con enleve le save
+!c       SAVE em_sig1feed,em_sig2feed,em_wght
+!c
+       INTEGER iflag(klon)
+       REAL rflag(klon)
+       REAL pbase(klon),bbase(klon)
+       REAL dtvpdt1(klon,klev),dtvpdq1(klon,klev)
+       REAL dplcldt(klon),dplcldr(klon)
+       REAL qcondc(klon,klev)
+       REAL wd(klon)
+       REAL Plim1(klon),Plim2(klon),asupmax(klon,klev)
+       REAL supmax0(klon),asupmaxmin(klon)
+!c
+       REAL sigd(klon)
+       REAL zx_t,zdelta,zx_qs,zcor
+!c
+!       INTEGER iflag_mix
+!       SAVE iflag_mix
+       INTEGER noff, minorig
+       INTEGER i,k,itra
+       REAL qs(klon,klev),qs_wake(klon,klev)
+       REAL cbmf(klon),plcl(klon),plfc(klon),wbeff(klon)
+!cLF       SAVE cbmf
+!IM/JYG      REAL, SAVE, ALLOCATABLE :: cbmf(:)
+!ccc$OMP THREADPRIVATE(cbmf)!       
+       REAL cbmflast(klon)
+       INTEGER ifrst
+       SAVE ifrst
+       DATA ifrst /0/
+!$OMP THREADPRIVATE(ifrst)
+
+!c
+!C     Variables supplementaires liees au bilan d'energie
+!c      Real paire(klon)
+!cLF      Real ql(klon,klev)
+!c      Save paire
+!cLF      Save ql
+!cLF      Real t1(klon,klev),q1(klon,klev)
+!cLF      Save t1,q1
+!c      Data paire /1./
+       REAL, SAVE, ALLOCATABLE :: ql(:,:), q1(:,:), t1(:,:)
+!$OMP THREADPRIVATE(ql, q1, t1)
+!c
+!C     Variables liees au bilan d'energie et d'enthalpi
+      REAL ztsol(klon)
+      REAL      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot                           &
+       &        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+      SAVE      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot                           &
+       &        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+!$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot)
+!$OMP THREADPRIVATE(h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot)
+      REAL      d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
+      REAL      d_h_vcol_phy
+      REAL      fs_bound, fq_bound
+      SAVE      d_h_vcol_phy
+!$OMP THREADPRIVATE(d_h_vcol_phy)
+      REAL      zero_v(klon)
+      CHARACTER*15 ztit
+      INTEGER   ip_ebil  ! PRINT level for energy conserv. diag.
+      SAVE      ip_ebil
+      DATA      ip_ebil/2/
+!$OMP THREADPRIVATE(ip_ebil)
+      INTEGER   if_ebil ! level for energy conserv. dignostics
+      SAVE      if_ebil
+      DATA      if_ebil/2/
+!$OMP THREADPRIVATE(if_ebil)
+!c+jld ec_conser
+      REAL d_t_ec(klon,klev)    ! tendance du a la conersion Ec -> E thermique
+      REAL ZRCPD
+!c-jld ec_conser
+!cLF
+      INTEGER nloc
+      logical, save :: first=.true.
+!$OMP THREADPRIVATE(first)
+      INTEGER, SAVE :: itap, igout
+!$OMP THREADPRIVATE(itap, igout)
+!c
+#include "YOMCST.h"
+#include "YOMCST2.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+#include "iniprint.h"
+!c
+      if (first) then
+!c Allocate some variables LF 04/2008
+!c
+!IM/JYG allocate(cbmf(klon))
+        allocate(ql(klon,klev))
+        allocate(t1(klon,klev))
+        allocate(q1(klon,klev))
+        itap=0
+        igout=klon/2+1/klon
+      endif
+!c Incrementer le compteur de la physique
+      itap   = itap + 1
+
+!c    Copy T into Tconv
+      DO k = 1,klev
+        DO i = 1,klon
+          Tconv(i,k) = T(i,k)
+        ENDDO
+      ENDDO
+!c
+      IF (if_ebil.ge.1) THEN
+        DO i=1,klon
+          ztsol(i) = t(i,1)
+          zero_v(i)=0.
+          Do k = 1,klev
+            ql(i,k) = 0.
+          ENDDO
+        END DO
+      END IF
+!c
+!cym
+      snow(:)=0
+      
+!c      IF (ifrst .EQ. 0) THEN
+!c         ifrst = 1
+       if (first) then
+         first=.false.
+!c
+!C===========================================================================
+!C    READ IN PARAMETERS FOR THE CLOSURE AND THE MIXING DISTRIBUTION
+!C===========================================================================
+!C
+      if (iflag_con.eq.3) then
+!c     CALL cv3_inicp()
+      CALL cv3_inip()
+      endif
+!c
+!C===========================================================================
+!C    READ IN PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
+!C===========================================================================
+!C
+!cc$$$         open (56,file='supcrit.data')
+!cc$$$         read (56,*) Supcrit1, Supcrit2
+!cc$$$         close (56)
+!c
+         IF (prt_level .ge. 10)                                                      &
+       &       WRITE(lunout,*) 'supcrit1, supcrit2' ,supcrit1, supcrit2
+!C
+!C===========================================================================
+!C      Initialisation pour les bilans d'eau et d'energie
+!C===========================================================================
+         IF (if_ebil.ge.1) d_h_vcol_phy=0.
+!c
+         DO i = 1, klon
+          cbmf(i) = 0.
+!!          plcl(i) = 0.
+          sigd(i) = 0.
+         ENDDO
+      ENDIF   !(ifrst .EQ. 0)
+
+!c Initialisation a chaque pas de temps
+      plfc(:)  = 0.
+      wbeff(:) = 100.
+      plcl(:) = 0.
+
+      DO k = 1, klev+1
+         DO i=1,klon
+         em_ph(i,k) = paprs(i,k) / 100.0
+         pmflxr(i,k)=0.
+         pmflxs(i,k)=0.
+      ENDDO
+      ENDDO
+!c
+      DO k = 1, klev
+         DO i=1,klon
+         em_p(i,k) = pplay(i,k) / 100.0
+      ENDDO
+      ENDDO
+!c
+!
+!  Feeding layer
+!
+      em_sig1feed = 1.
+      em_sig2feed = 0.97
+!c      em_sig2feed = 0.8
+! Relative Weight densities
+       do k=1,klev
+         em_wght(k)=1.
+       end do
+!cCRtest: couche alim des tehrmiques ponderee par a*
+!c       DO i = 1, klon
+!c         do k=1,lalim_conv(i)
+!c         em_wght(k)=wght_th(i,k)
+!c         print*,'em_wght=',em_wght(k),wght_th(i,k)
+!c       end do
+!c      END DO
+
+      if (iflag_con .eq. 4) then
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0)
+         zcor=1./(1.-retv*zx_qs)
+         qs(i,k)=zx_qs*zcor
+        ENDDO
+        DO i = 1, klon
+         zx_t = t_wake(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= MIN(0.5 , r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0)
+         zcor=1./(1.-retv*zx_qs)
+         qs_wake(i,k)=zx_qs*zcor
+        ENDDO
+      ENDDO
+      else ! iflag_con=3 (modif de puristes qui fait la diffce pour la convergence numerique)
+      DO k = 1, klev
+        DO i = 1, klon
+         zx_t = t(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0
+         zx_qs= MIN(0.5,zx_qs)
+         zcor=1./(1.-retv*zx_qs)
+         zx_qs=zx_qs*zcor
+         qs(i,k)=zx_qs
+        ENDDO
+        DO i = 1, klon
+         zx_t = t_wake(i,k)
+         zdelta=MAX(0.,SIGN(1.,rtt-zx_t))
+         zx_qs= r2es * FOEEW(zx_t,zdelta)/em_p(i,k)/100.0
+         zx_qs= MIN(0.5,zx_qs)
+         zcor=1./(1.-retv*zx_qs)
+         zx_qs=zx_qs*zcor
+         qs_wake(i,k)=zx_qs
+        ENDDO
+      ENDDO
+      endif ! iflag_con
+!c
+!C------------------------------------------------------------------
+
+!C Main driver for convection:
+!C               iflag_con=3 -> nvlle version de KE (JYG)
+!C		iflag_con = 30  -> equivalent to convect3
+!C		iflag_con = 4  -> equivalent to convect1/2
+!c
+!c
+      if (iflag_con.eq.30) then
+
+      print *, '-> cv_driver'      !jyg
+      CALL cv_driver(klon,klev,klevp1,ntra,iflag_con,                                &
+       &              t,q,qs,u,v,tra,                                                &
+       &              em_p,em_ph,iflag,                                              &
+       &              d_t,d_q,d_u,d_v,d_tra,rain,                                    &
+       &              Vprecip,cbmf,work1,work2,                                      & !jyg
+       &              kbas,ktop,                                                     &
+       &              dtime,Ma,upwd,dnwd,dnwdbis,qcondc,wd,cape,                     &
+       &              da,phi,mp,phi2,d1a,dam,sij,clw,elij,                           & !RomP
+       &              evap,ep,epmlmMm,eplaMm,                                        & !RomP
+       &              wdtrainA,wdtrainM)                                               !RomP
+      print *, 'cv_driver ->'      !jyg
+!c
+      DO i = 1,klon
+        cbmf(i) = Ma(i,kbas(i))
+      ENDDO
+!c
+      else
+
+!cLF   necessary for gathered fields
+      nloc=klon
+      CALL cva_driver(klon,klev,klev+1,ntra,nloc,                                    &
+       &              iflag_con,iflag_mix,iflag_clos,dtime,                          &
+       &              t,q,qs,t_wake,q_wake,qs_wake,s_wake,u,v,tra,                   &
+       &              em_p,em_ph,                                                    &
+       &              ALE,ALP,                                                       &
+       &              em_sig1feed,em_sig2feed,em_wght,                               &
+       &              iflag,d_t,d_q,d_u,d_v,d_tra,rain,kbas,ktop,                    &
+       &              cbmf,plcl,plfc,wbeff,work1,work2,ptop2,sigd,                   &
+       &              Ma,mip,Vprecip,upwd,dnwd,dnwdbis,qcondc,wd,                    &
+       &              cape,cin,tvp,                                                  &
+       &              dd_t,dd_q,Plim1,Plim2,asupmax,supmax0,                         &
+       &              asupmaxmin,lalim_conv,                                         &
+!AC!+!RomP+jyg                                                                       &
+       &              da,phi,mp,phi2,d1a,dam,sij,clw,elij,                           & ! RomP
+       &              evap,ep,epmlmMm,eplaMm,                                        & ! RomP
+       &              wdtrainA,wdtrainM)                                               ! RomP
+!AC!+!RomP+jyg
+      endif  
+!C------------------------------------------------------------------
+      IF (prt_level .ge. 10)                                                         &
+       &   WRITE(lunout,*) ' cva_driver -> cbmf,plcl,plfc,wbeff ',                   &
+       &                     cbmf(1),plcl(1),plfc(1),wbeff(1)
+
+      DO i = 1,klon
+        rain(i) = rain(i)/86400.
+        rflag(i)=iflag(i)
+      ENDDO
+
+      DO k = 1, klev
+        DO i = 1, klon
+           d_t(i,k) = dtime*d_t(i,k)
+           d_q(i,k) = dtime*d_q(i,k)
+           d_u(i,k) = dtime*d_u(i,k)
+           d_v(i,k) = dtime*d_v(i,k)
+        ENDDO
+      ENDDO
+!c
+       if (iflag_con.eq.30) then
+       DO itra = 1,ntra
+        DO k = 1, klev
+         DO i = 1, klon
+            d_tra(i,k,itra) =dtime*d_tra(i,k,itra) 
+         ENDDO
+        ENDDO
+       ENDDO 
+       endif
+
+!c!AC!
+       if (iflag_con.eq.3) then
+       DO itra = 1,ntra
+        DO k = 1, klev
+         DO i = 1, klon
+            d_tra(i,k,itra) =dtime*d_tra(i,k,itra) 
+         ENDDO
+        ENDDO
+       ENDDO 
+       endif
+!c!AC!
+
+      DO k = 1, klev
+        DO i = 1, klon
+          t1(i,k) = t(i,k)+ d_t(i,k)
+          q1(i,k) = q(i,k)+ d_q(i,k)
+        ENDDO
+      ENDDO
+!c                                                  !jyg
+!c--Separation neige/pluie (pour diagnostics)       !jyg
+      DO k = 1, klev                               !jyg
+      DO i = 1, klon                               !jyg
+       IF (t1(i,k).LT.RTT) THEN                    !jyg
+         pmflxs(i,k)=Vprecip(i,k)                  !jyg
+       ELSE                                        !jyg
+         pmflxr(i,k)=Vprecip(i,k)                  !jyg
+       ENDIF                                       !jyg
+      ENDDO                                        !jyg
+      ENDDO                                        !jyg
+!c
+!cc      IF (if_ebil.ge.2) THEN
+!cc        ztit='after convect'
+!cc        CALL diagetpq(paire,ztit,ip_ebil,2,2,dtime
+!cc     e      , t1,q1,ql,qs,u,v,paprs,pplay
+!cc     s      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+!cc         call diagphy(paire,ztit,ip_ebil
+!cc     e      , zero_v, zero_v, zero_v, zero_v, zero_v
+!cc     e      , zero_v, rain, zero_v, ztsol
+!cc     e      , d_h_vcol, d_qt, d_ec
+!cc     s      , fs_bound, fq_bound )
+!cc      END IF
+!C
+!c
+!c les traceurs ne sont pas mis dans cette version de convect4:
+      if (iflag_con.eq.4) then
+       DO itra = 1,ntra
+        DO k = 1, klev
+         DO i = 1, klon
+            d_tra(i,k,itra) = 0.
+         ENDDO
+        ENDDO
+       ENDDO
+      endif
+!c     print*, 'concvl->: dd_t,dd_q ',dd_t(1,1),dd_q(1,1)
+
+        DO k = 1, klev
+         DO i = 1, klon
+            dtvpdt1(i,k) = 0.
+            dtvpdq1(i,k) = 0.
+         ENDDO
+        ENDDO
+        DO i = 1, klon
+           dplcldt(i) = 0.
+           dplcldr(i) = 0.
+        ENDDO
+!c
+       if(prt_level.GE.20) THEN
+       DO k=1,klev
+!       print*,'physiq apres_add_con i k it d_u d_v d_t d_q qdl0',igout
+!    .,k,itap,d_u_con(igout,k) ,d_v_con(igout,k), d_t_con(igout,k),
+!    .d_q_con(igout,k),dql0(igout,k)
+!      print*,'phys apres_add_con itap Ma cin ALE ALP wak t q undi t q'
+!    .,itap,Ma(igout,k),cin(igout),ALE(igout), ALP(igout),
+!    . t_wake(igout,k),q_wake(igout,k),t_undi(igout,k),q_undi(igout,k)
+!      print*,'phy apres_add_con itap CON rain snow EMA wk1 wk2 Vpp mip'
+!    .,itap,rain_con(igout),snow_con(igout),ema_work1(igout,k),
+!    .ema_work2(igout,k),Vprecip(igout,k), mip(igout,k)
+!      print*,'phy apres_add_con itap upwd dnwd dnwd0 cape tvp Tconv '
+!    .,itap,upwd(igout,k),dnwd(igout,k),dnwd0(igout,k),cape(igout),
+!    .tvp(igout,k),Tconv(igout,k)
+!      print*,'phy apres_add_con itap dtvpdt dtvdq dplcl dplcldr qcondc'
+!    .,itap,dtvpdt1(igout,k),dtvpdq1(igout,k),dplcldt(igout),
+!    .dplcldr(igout),qcondc(igout,k)
+!      print*,'phy apres_add_con itap wd pmflxr Kpmflxr Kp1 Kpmflxs Kp1'
+!    .,itap,wd(igout),pmflxr(igout,k),pmflxr(igout,k+1),pmflxs(igout,k)
+!    .,pmflxs(igout,k+1)
+!      print*,'phy apres_add_con itap da phi mp ftd fqd lalim wgth',
+!    .itap,da(igout,k),phi(igout,k,k),mp(igout,k),ftd(igout,k),
+!    . fqd(igout,k),lalim_conv(igout),wght_th(igout,k)
+      ENDDO
+      endif !(prt_level.EQ.20) THEN
+!c
+      RETURN
+      END
+ 
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/conema3.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/conema3.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/conema3.h	(revision 17)
@@ -0,0 +1,17 @@
+!
+! $Header$
+!-- Modified by : Filiberti M-A 06/2005
+!
+      real epmax             ! 0.993
+      logical ok_adj_ema      ! F
+      integer iflag_clw      ! 0
+	  integer iflag_cvl_sigd
+      real sig1feed      ! 1.
+      real sig2feed      ! 0.95
+
+      common/comconema1/epmax,ok_adj_ema,iflag_clw,sig1feed,sig2feed
+      common/comconema2/iflag_cvl_sigd
+
+!      common/comconema/epmax,ok_adj_ema,iflag_clw
+!$OMP THREADPRIVATE(/comconema1/)
+!$OMP THREADPRIVATE(/comconema2/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/conf_gcm.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/conf_gcm.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/conf_gcm.F90	(revision 17)
@@ -0,0 +1,950 @@
+!
+! $Id: conf_gcm.F 1795 2013-07-18 08:20:28Z emillour $
+!
+!c
+!c
+      SUBROUTINE conf_gcm( tapedef, etatinit, clesphy0 )
+!c
+      USE control_mod
+#ifdef CPP_IOIPSL
+      use IOIPSL
+#else
+! if not using IOIPSL, we still need to use (a local version of) getin
+      use ioipsl_getincom
+#endif
+      USE infotrac, ONLY : type_trac
+      use assert_m, only: assert
+
+      IMPLICIT NONE
+!c-----------------------------------------------------------------------
+!c     Auteurs :   L. Fairhead , P. Le Van  .
+!c
+!c     Arguments :
+!c
+!c     tapedef   :
+!c     etatinit  :     = TRUE   , on ne  compare pas les valeurs des para- 
+!c     -metres  du zoom  avec  celles lues sur le fichier start .
+!c      clesphy0 :  sortie  .
+!c
+       LOGICAL etatinit
+       INTEGER tapedef
+
+       INTEGER        longcles
+       PARAMETER(     longcles = 20 )
+       REAL clesphy0( longcles )
+!c
+!c   Declarations :
+!c   --------------
+#include "dimensions.h"
+#include "paramet.h"
+#include "logic.h"
+#include "serre.h"
+#include "comdissnew.h"
+#include "temps.h"
+#include "comconst.h"
+
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! #include "clesphys.h"
+#include "iniprint.h"
+!c
+!c
+!c   local:
+!c   ------
+
+      CHARACTER ch1*72,ch2*72,ch3*72,ch4*12
+      REAL clonn,clatt,grossismxx,grossismyy
+      REAL dzoomxx,dzoomyy, tauxx,tauyy
+      LOGICAL  fxyhypbb, ysinuss
+      INTEGER i
+      LOGICAL use_filtre_fft
+!c
+!c  -------------------------------------------------------------------
+!c
+!c       .........     Version  du 29/04/97       ..........
+!c
+!c   Nouveaux parametres nitergdiv,nitergrot,niterh,tetagdiv,tetagrot,
+!c      tetatemp   ajoutes  pour la dissipation   .
+!c
+!c   Autre parametre ajoute en fin de liste de tapedef : ** fxyhypb ** 
+!c
+!c  Si fxyhypb = .TRUE. , choix de la fonction a derivee tangente hyperb.
+!c    Sinon , choix de fxynew  , a derivee sinusoidale  ..
+!c
+!c   ......  etatinit = . TRUE. si defrun  est appele dans ETAT0_LMD  ou
+!c         LIMIT_LMD  pour l'initialisation de start.dat (dic) et
+!c                de limit.dat ( dic)                        ...........
+!c           Sinon  etatinit = . FALSE .
+!c
+!c   Donc etatinit = .F.  si on veut comparer les valeurs de  grossismx ,
+!c    grossismy,clon,clat, fxyhypb  lues sur  le fichier  start  avec
+!c   celles passees  par run.def ,  au debut du gcm, apres l'appel a 
+!c    lectba .  
+!c   Ces parmetres definissant entre autres la grille et doivent etre
+!c   pareils et coherents , sinon il y aura  divergence du gcm .
+!c
+!c-----------------------------------------------------------------------
+!c   initialisations:
+!c   ----------------
+
+!Config  Key  = lunout
+!Config  Desc = unite de fichier pour les impressions
+!Config  Def  = 6
+!Config  Help = unite de fichier pour les impressions 
+!Config         (defaut sortie standard = 6)
+      lunout=6
+      CALL getin('lunout', lunout)
+      IF (lunout /= 5 .and. lunout /= 6) THEN
+        OPEN(UNIT=lunout,FILE='lmdz.out',ACTION='write',                             &
+       &          STATUS='unknown',FORM='formatted')
+      ENDIF
+
+!Config  Key  = prt_level
+!Config  Desc = niveau d'impressions de débogage
+!Config  Def  = 0
+!Config  Help = Niveau d'impression pour le débogage
+!Config         (0 = minimum d'impression)
+      prt_level = 0
+      CALL getin('prt_level',prt_level)
+
+!c-----------------------------------------------------------------------
+!c  Parametres de controle du run:
+!c-----------------------------------------------------------------------
+!Config  Key  = planet_type
+!Config  Desc = planet type ("earth", "mars", "venus", ...)
+!Config  Def  = earth
+!Config  Help = this flag sets the type of atymosphere that is considered
+      planet_type="earth"
+      CALL getin('planet_type',planet_type)
+
+!Config  Key  = calend
+!Config  Desc = type de calendrier utilise
+!Config  Def  = earth_360d
+!Config  Help = valeur possible: earth_360d, earth_365d, earth_366d
+!Config         
+      calend = 'earth_360d'
+      CALL getin('calend', calend)
+
+!Config  Key  = dayref
+!Config  Desc = Jour de l'etat initial
+!Config  Def  = 1
+!Config  Help = Jour de l'etat initial ( = 350  si 20 Decembre ,
+!Config         par expl. ,comme ici ) ... A completer
+      dayref=1
+      CALL getin('dayref', dayref)
+
+!Config  Key  = anneeref
+!Config  Desc = Annee de l'etat initial
+!Config  Def  = 1998
+!Config  Help = Annee de l'etat  initial 
+!Config         (   avec  4  chiffres   ) ... A completer
+      anneeref = 1998
+      CALL getin('anneeref',anneeref)
+
+!Config  Key  = raz_date
+!Config  Desc = Remise a zero de la date initiale
+!Config  Def  = 0 (pas de remise a zero)
+!Config  Help = Remise a zero de la date initiale 
+!Config         0 pas de remise a zero, on garde la date du fichier restart
+!Config         1 prise en compte de la date de gcm.def avec remise a zero
+!Config         des compteurs de pas de temps
+      raz_date = 0
+      CALL getin('raz_date', raz_date)
+
+!Config  Key  = nday
+!Config  Desc = Nombre de jours d'integration
+!Config  Def  = 10
+!Config  Help = Nombre de jours d'integration
+!Config         ... On pourait aussi permettre des mois ou des annees !
+      nday = 10
+      CALL getin('nday',nday)
+
+!Config  Key  = starttime
+!Config  Desc = Heure de depart de la simulation
+!Config  Def  = 0
+!Config  Help = Heure de depart de la simulation
+!Config         en jour
+      starttime = 0
+      CALL getin('starttime',starttime)
+
+!Config  Key  = day_step
+!Config  Desc = nombre de pas par jour
+!Config  Def  = 240 
+!Config  Help = nombre de pas par jour (multiple de iperiod) (
+!Config          ici pour  dt = 1 min ) 
+       day_step = 240 
+       CALL getin('day_step',day_step)
+
+!Config  Key  = nsplit_phys
+       nsplit_phys = 1 
+       CALL getin('nsplit_phys',nsplit_phys)
+
+!Config  Key  = iperiod
+!Config  Desc = periode pour le pas Matsuno
+!Config  Def  = 5
+!Config  Help = periode pour le pas Matsuno (en pas de temps)
+       iperiod = 5
+       CALL getin('iperiod',iperiod)
+
+!Config  Key  = iapp_tracvl
+!Config  Desc = frequence du groupement des flux 
+!Config  Def  = iperiod
+!Config  Help = frequence du groupement des flux (en pas de temps) 
+       iapp_tracvl = iperiod
+       CALL getin('iapp_tracvl',iapp_tracvl)
+
+!Config  Key  = iconser
+!Config  Desc = periode de sortie des variables de controle
+!Config  Def  = 240  
+!Config  Help = periode de sortie des variables de controle
+!Config         (En pas de temps)
+       iconser = 240  
+       CALL getin('iconser', iconser)
+
+!Config  Key  = iecri
+!Config  Desc = periode d'ecriture du fichier histoire
+!Config  Def  = 1
+!Config  Help = periode d'ecriture du fichier histoire (en jour) 
+       iecri = 1
+       CALL getin('iecri',iecri)
+
+
+!Config  Key  = periodav
+!Config  Desc = periode de stockage fichier histmoy
+!Config  Def  = 1
+!Config  Help = periode de stockage fichier histmoy (en jour) 
+       periodav = 1.
+       CALL getin('periodav',periodav)
+
+!Config  Key  = output_grads_dyn
+!Config  Desc = output dynamics diagnostics in 'dyn.dat' file
+!Config  Def  = n
+!Config  Help = output dynamics diagnostics in Grads-readable 'dyn.dat' file
+       output_grads_dyn=.false.
+       CALL getin('output_grads_dyn',output_grads_dyn)
+
+!Config  Key  = dissip_period
+!Config  Desc = periode de la dissipation 
+!Config  Def  = 0
+!Config  Help = periode de la dissipation 
+!Config  dissip_period=0 => la valeur sera calcule dans inidissip       
+!Config  dissip_period>0 => on prend cette valeur
+       dissip_period = 0
+       CALL getin('dissip_period',dissip_period)
+
+!ccc  ....   P. Le Van , modif le 29/04/97 .pour la dissipation  ...
+!ccc
+
+!Config  Key  = lstardis
+!Config  Desc = choix de l'operateur de dissipation
+!Config  Def  = y
+!Config  Help = choix de l'operateur de dissipation
+!Config         'y' si on veut star et 'n' si on veut non-start !
+!Config         Moi y en a pas comprendre ! 
+       lstardis = .TRUE.
+       CALL getin('lstardis',lstardis)
+
+
+!Config  Key  = nitergdiv
+!Config  Desc = Nombre d'iteration de gradiv
+!Config  Def  = 1
+!Config  Help = nombre d'iterations de l'operateur de dissipation 
+!Config         gradiv
+       nitergdiv = 1
+       CALL getin('nitergdiv',nitergdiv)
+
+!Config  Key  = nitergrot
+!Config  Desc = nombre d'iterations de nxgradrot
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation  
+!Config         nxgradrot
+       nitergrot = 2
+       CALL getin('nitergrot',nitergrot)
+
+
+!Config  Key  = niterh
+!Config  Desc = nombre d'iterations de divgrad
+!Config  Def  = 2
+!Config  Help = nombre d'iterations de l'operateur de dissipation
+!Config         divgrad
+       niterh = 2
+       CALL getin('niterh',niterh)
+
+
+!Config  Key  = tetagdiv
+!Config  Desc = temps de dissipation pour div
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (gradiv)
+       tetagdiv = 7200.
+       CALL getin('tetagdiv',tetagdiv)
+
+!Config  Key  = tetagrot
+!Config  Desc = temps de dissipation pour grad
+!Config  Def  = 7200
+!Config  Help = temps de dissipation des plus petites longeur 
+!Config         d'ondes pour u,v (nxgradrot)
+       tetagrot = 7200.
+       CALL getin('tetagrot',tetagrot)
+
+!Config  Key  = tetatemp 
+!Config  Desc = temps de dissipation pour h
+!Config  Def  = 7200
+!Config  Help =  temps de dissipation des plus petites longeur 
+!Config         d'ondes pour h (divgrad)   
+       tetatemp  = 7200.
+       CALL getin('tetatemp',tetatemp )
+
+! Parametres controlant la variation sur la verticale des constantes de
+! dissipation.
+! Pour le moment actifs uniquement dans la version a 39 niveaux
+! avec ok_strato=y
+
+       dissip_factz=4.
+       dissip_deltaz=10.
+       dissip_zref=30.
+       CALL getin('dissip_factz',dissip_factz )
+       CALL getin('dissip_deltaz',dissip_deltaz )
+       CALL getin('dissip_zref',dissip_zref )
+
+! top_bound sponge: only active if ok_strato=.true. and iflag_top_bound!=0
+!                   iflag_top_bound=0 for no sponge
+!                   iflag_top_bound=1 for sponge over 4 topmost layers
+!                   iflag_top_bound=2 for sponge from top to ~1% of top layer pressure
+       iflag_top_bound=1
+       CALL getin('iflag_top_bound',iflag_top_bound)
+
+! mode_top_bound : fields towards which sponge relaxation will be done:
+!                  mode_top_bound=0: no relaxation
+!                  mode_top_bound=1: u and v relax towards 0
+!                  mode_top_bound=2: u and v relax towards their zonal mean
+!                  mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean
+       mode_top_bound=3
+       CALL getin('mode_top_bound',mode_top_bound)
+
+! top_bound sponge : inverse of charactericstic relaxation time scale for sponge
+       tau_top_bound=1.e-5
+       CALL getin('tau_top_bound',tau_top_bound)
+
+!Config  Key  = coefdis
+!Config  Desc = coefficient pour gamdissip
+!Config  Def  = 0
+!Config  Help = coefficient pour gamdissip  
+       coefdis = 0.
+       CALL getin('coefdis',coefdis)
+
+!Config  Key  = purmats
+!Config  Desc = Schema d'integration
+!Config  Def  = n
+!Config  Help = Choix du schema d'integration temporel.
+!Config         y = pure Matsuno sinon c'est du Matsuno-leapfrog
+       purmats = .FALSE.
+       CALL getin('purmats',purmats)
+
+!Config  Key  = ok_guide
+!Config  Desc = Guidage
+!Config  Def  = n
+!Config  Help = Guidage
+       ok_guide = .FALSE.
+       CALL getin('ok_guide',ok_guide)
+
+!c    ...............................................................
+
+!Config  Key  =  read_start
+!Config  Desc = Initialize model using a 'start.nc' file
+!Config  Def  = y
+!Config  Help = y: intialize dynamical fields using a 'start.nc' file
+!               n: fields are initialized by 'iniacademic' routine
+       read_start= .true.
+       CALL getin('read_start',read_start)
+
+!Config  Key  = iflag_phys
+!Config  Desc = Avec ls physique 
+!Config  Def  = 1
+!Config  Help = Permet de faire tourner le modele sans 
+!Config         physique.
+       iflag_phys = 1
+       CALL getin('iflag_phys',iflag_phys)
+
+
+!Config  Key  =  iphysiq
+!Config  Desc = Periode de la physique
+!Config  Def  = 5
+!Config  Help = Periode de la physique en pas de temps de la dynamique.
+       iphysiq = 5
+       CALL getin('iphysiq', iphysiq)
+
+!Config  Key  = ip_ebil_dyn
+!Config  Desc = PRINT level for energy conserv. diag.
+!Config  Def  = 0
+!Config  Help = PRINT level for energy conservation diag. ;
+!               les options suivantes existent :
+!Config         0 pas de print
+!Config         1 pas de print
+!Config         2 print,
+       ip_ebil_dyn = 0
+       CALL getin('ip_ebil_dyn',ip_ebil_dyn)
+!
+
+      DO i = 1, longcles
+       clesphy0(i) = 0.
+      ENDDO
+
+!ccc  ....   P. Le Van , ajout  le 7/03/95 .pour le zoom ...
+!c     .........   (  modif  le 17/04/96 )   .........
+!c
+      IF( etatinit ) GO TO 100
+
+!Config  Key  = clon
+!Config  Desc = centre du zoom, longitude
+!Config  Def  = 0
+!Config  Help = longitude en degres du centre 
+!Config         du zoom
+       clonn = 0.
+       CALL getin('clon',clonn)
+
+!Config  Key  = clat
+!Config  Desc = centre du zoom, latitude
+!Config  Def  = 0
+!Config  Help = latitude en degres du centre du zoom
+!Config         
+       clatt = 0.
+       CALL getin('clat',clatt)
+
+!c
+!c
+      IF( ABS(clat - clatt).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de clat passee par run.def',             &
+       &    ' est differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+!Config  Key  = grossismx 
+!Config  Desc = zoom en longitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la longitude
+       grossismxx = 1.0
+       CALL getin('grossismx',grossismxx)
+
+
+      IF( ABS(grossismx - grossismxx).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de grossismx passee par ',               &
+       &  'run.def est differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+
+!Config  Key  = grossismy
+!Config  Desc = zoom en latitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la latitude
+       grossismyy = 1.0
+       CALL getin('grossismy',grossismyy)
+
+      IF( ABS(grossismy - grossismyy).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de grossismy passee par ',               &
+       & 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+      ENDIF
+      
+      IF( grossismx.LT.1. )  THEN
+        write(lunout,*)                                                              &
+       &       'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        write(lunout,*)                                                              &
+       &       'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      write(lunout,*)'conf_gcm: alphax alphay',alphax,alphay
+!c
+!c    alphax et alphay sont les anciennes formulat. des grossissements
+!c
+!c
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypbb = .TRUE.
+       CALL getin('fxyhypb',fxyhypbb)
+
+      IF( .NOT.fxyhypb )  THEN
+         IF( fxyhypbb )     THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' *** fxyhypb lu sur le fichier start est ',              &
+       &       'F alors  qu il est  T  sur  run.def  ***'
+              STOP
+         ENDIF
+      ELSE
+         IF( .NOT.fxyhypbb )   THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' ***  fxyhypb lu sur le fichier start est ',             &
+       &        'T alors  qu il est  F  sur  run.def  ****  '
+              STOP
+         ENDIF
+      ENDIF
+!c
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomxx = 0.0
+       CALL getin('dzoomx',dzoomxx)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomx - dzoomxx).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de dzoomx passee par ',                  &
+       &  'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!Config  Key  = dzoomy
+!Config  Desc = extension en latitude
+!Config  Def  = 0
+!Config  Help = extension en latitude de la zone  du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomyy = 0.0
+       CALL getin('dzoomy',dzoomyy)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(dzoomy - dzoomyy).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de dzoomy passee par ',                  &
+       & 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+      
+!Config  Key  = taux
+!Config  Desc = raideur du zoom en  X
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  X
+       tauxx = 3.0
+       CALL getin('taux',tauxx)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(taux - tauxx).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de taux passee par ',                    &
+       & 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!Config  Key  = tauyy
+!Config  Desc = raideur du zoom en  Y
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  Y
+       tauyy = 3.0
+       CALL getin('tauy',tauyy)
+
+      IF( fxyhypb )  THEN
+       IF( ABS(tauy - tauyy).GE. 0.001 )  THEN
+        write(lunout,*)'conf_gcm: La valeur de tauy passee par ',                    &
+       & 'run.def est differente de celle lue sur le fichier  start '
+        STOP
+       ENDIF
+      ENDIF
+
+!cc
+      IF( .NOT.fxyhypb  )  THEN
+
+!Config  Key  = ysinus
+!Config  IF   = !fxyhypb
+!Config  Desc = Fonction en Sinus
+!Config  Def  = y
+!Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+!Config         sinon y = latit.
+       ysinuss = .TRUE.
+       CALL getin('ysinus',ysinuss)
+
+        IF( .NOT.ysinus )  THEN
+          IF( ysinuss )     THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' *** ysinus lu sur le fichier start est F',              &
+       &       ' alors  qu il est  T  sur  run.def  ***'
+            STOP
+          ENDIF
+        ELSE
+          IF( .NOT.ysinuss )   THEN
+            write(lunout,*)' ********  PBS DANS  CONF_GCM  ******** '
+            write(lunout,*)' *** ysinus lu sur le fichier start est T',              &
+       &        ' alors  qu il est  F  sur  run.def  ****  '
+              STOP
+          ENDIF
+        ENDIF
+      ENDIF 
+
+! of IF( .NOT.fxyhypb  )
+!c
+!Config  Key  = offline
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = n
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       offline = .FALSE.
+       CALL getin('offline',offline)
+
+!Config  Key  = type_trac
+!Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
+!Config  Def  = lmdz
+!Config  Help = 
+!Config         'lmdz' = pas de couplage, pur LMDZ
+!Config         'inca' = model de chime INCA 
+!Config         'repr' = model de chime REPROBUS
+      type_trac = 'lmdz'
+      CALL getin('type_trac',type_trac)
+
+!Config  Key  = config_inca
+!Config  Desc = Choix de configuration de INCA
+!Config  Def  = none
+!Config  Help = Choix de configuration de INCA :
+!Config         'none' = sans INCA
+!Config         'chem' = INCA avec calcul de chemie
+!Config         'aero' = INCA avec calcul des aerosols 
+      config_inca = 'none'
+      CALL getin('config_inca',config_inca)
+
+!Config  Key  = ok_dynzon 
+!Config  Desc = calcul et sortie des transports 
+!Config  Def  = n 
+!Config  Help = Permet de mettre en route le calcul des transports 
+!Config          
+      ok_dynzon = .FALSE. 
+      CALL getin('ok_dynzon',ok_dynzon) 
+
+!Config  Key  = ok_dyn_ins
+!Config  Desc = sorties instantanees dans la dynamique
+!Config  Def  = n 
+!Config  Help = 
+!Config          
+      ok_dyn_ins = .FALSE. 
+      CALL getin('ok_dyn_ins',ok_dyn_ins) 
+
+!Config  Key  = ok_dyn_ave
+!Config  Desc = sorties moyennes dans la dynamique
+!Config  Def  = n 
+!Config  Help = 
+!Config          
+      ok_dyn_ave = .FALSE. 
+      CALL getin('ok_dyn_ave',ok_dyn_ave) 
+
+      write(lunout,*)' #########################################'
+      write(lunout,*)' Configuration des parametres du gcm: '
+      write(lunout,*)' planet_type = ', planet_type
+      write(lunout,*)' calend = ', calend
+      write(lunout,*)' dayref = ', dayref
+      write(lunout,*)' anneeref = ', anneeref
+      write(lunout,*)' nday = ', nday
+      write(lunout,*)' day_step = ', day_step
+      write(lunout,*)' iperiod = ', iperiod
+      write(lunout,*)' nsplit_phys = ', nsplit_phys
+      write(lunout,*)' iconser = ', iconser
+      write(lunout,*)' iecri = ', iecri
+      write(lunout,*)' periodav = ', periodav 
+      write(lunout,*)' output_grads_dyn = ', output_grads_dyn
+      write(lunout,*)' dissip_period = ', dissip_period
+      write(lunout,*)' lstardis = ', lstardis
+      write(lunout,*)' nitergdiv = ', nitergdiv
+      write(lunout,*)' nitergrot = ', nitergrot
+      write(lunout,*)' niterh = ', niterh
+      write(lunout,*)' tetagdiv = ', tetagdiv
+      write(lunout,*)' tetagrot = ', tetagrot
+      write(lunout,*)' tetatemp = ', tetatemp
+      write(lunout,*)' coefdis = ', coefdis
+      write(lunout,*)' purmats = ', purmats
+      write(lunout,*)' read_start = ', read_start
+      write(lunout,*)' iflag_phys = ', iflag_phys
+      write(lunout,*)' iphysiq = ', iphysiq
+      write(lunout,*)' clonn = ', clonn 
+      write(lunout,*)' clatt = ', clatt
+      write(lunout,*)' grossismx = ', grossismx
+      write(lunout,*)' grossismy = ', grossismy
+      write(lunout,*)' fxyhypbb = ', fxyhypbb
+      write(lunout,*)' dzoomxx = ', dzoomxx
+      write(lunout,*)' dzoomy = ', dzoomyy
+      write(lunout,*)' tauxx = ', tauxx
+      write(lunout,*)' tauyy = ', tauyy
+      write(lunout,*)' offline = ', offline
+      write(lunout,*)' type_trac = ', type_trac
+      write(lunout,*)' config_inca = ', config_inca
+      write(lunout,*)' ok_dynzon = ', ok_dynzon 
+      write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins 
+      write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave 
+
+      RETURN
+!c   ...............................................
+!c
+100   CONTINUE
+!Config  Key  = clon
+!Config  Desc = centre du zoom, longitude
+!Config  Def  = 0
+!Config  Help = longitude en degres du centre 
+!Config         du zoom
+       clon = 0.
+       CALL getin('clon',clon)
+
+!Config  Key  = clat
+!Config  Desc = centre du zoom, latitude
+!Config  Def  = 0
+!Config  Help = latitude en degres du centre du zoom
+!Config         
+       clat = 0.
+       CALL getin('clat',clat)
+
+!Config  Key  = grossismx 
+!Config  Desc = zoom en longitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la longitude
+       grossismx = 1.0
+       CALL getin('grossismx',grossismx)
+
+!Config  Key  = grossismy
+!Config  Desc = zoom en latitude
+!Config  Def  = 1.0
+!Config  Help = facteur de grossissement du zoom,
+!Config         selon la latitude
+       grossismy = 1.0
+       CALL getin('grossismy',grossismy)
+
+      IF( grossismx.LT.1. )  THEN
+        write(lunout,*)                                                              &
+       &   'conf_gcm: ***  ATTENTION !! grossismx < 1 .   *** '
+         STOP
+      ELSE
+         alphax = 1. - 1./ grossismx
+      ENDIF
+
+
+      IF( grossismy.LT.1. )  THEN
+        write(lunout,*)                                                              &
+       &  'conf_gcm: ***  ATTENTION !! grossismy < 1 .   *** '
+         STOP
+      ELSE
+         alphay = 1. - 1./ grossismy
+      ENDIF
+
+      write(lunout,*)'conf_gcm: alphax alphay ',alphax,alphay
+!c
+!c    alphax et alphay sont les anciennes formulat. des grossissements
+!c
+!c
+
+!Config  Key  = fxyhypb
+!Config  Desc = Fonction  hyperbolique
+!Config  Def  = y
+!Config  Help = Fonction  f(y)  hyperbolique  si = .true.  
+!Config         sinon  sinusoidale
+       fxyhypb = .TRUE.
+       CALL getin('fxyhypb',fxyhypb)
+
+!Config  Key  = dzoomx
+!Config  Desc = extension en longitude
+!Config  Def  = 0
+!Config  Help = extension en longitude  de la zone du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomx = 0.0
+       CALL getin('dzoomx',dzoomx)
+
+!Config  Key  = dzoomy
+!Config  Desc = extension en latitude
+!Config  Def  = 0
+!Config  Help = extension en latitude de la zone  du zoom  
+!Config         ( fraction de la zone totale)
+       dzoomy = 0.0
+       CALL getin('dzoomy',dzoomy)
+
+!Config  Key  = taux
+!Config  Desc = raideur du zoom en  X
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  X
+       taux = 3.0
+       CALL getin('taux',taux)
+
+!Config  Key  = tauy
+!Config  Desc = raideur du zoom en  Y
+!Config  Def  = 3
+!Config  Help = raideur du zoom en  Y
+       tauy = 3.0
+       CALL getin('tauy',tauy)
+
+!Config  Key  = ysinus
+!Config  IF   = !fxyhypb
+!Config  Desc = Fonction en Sinus
+!Config  Def  = y
+!Config  Help = Fonction  f(y) avec y = Sin(latit.) si = .true. 
+!Config         sinon y = latit.
+       ysinus = .TRUE.
+       CALL getin('ysinus',ysinus)
+!c
+!Config  Key  = offline
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = n
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       offline = .FALSE.
+       CALL getin('offline',offline)
+
+!Config  Key  = type_trac
+!Config  Desc = Choix de couplage avec model de chimie INCA ou REPROBUS
+!Config  Def  = lmdz
+!Config  Help = 
+!Config         'lmdz' = pas de couplage, pur LMDZ
+!Config         'inca' = model de chime INCA 
+!Config         'repr' = model de chime REPROBUS
+      type_trac = 'lmdz'
+      CALL getin('type_trac',type_trac)
+
+!Config  Key  = config_inca
+!Config  Desc = Choix de configuration de INCA
+!Config  Def  = none
+!Config  Help = Choix de configuration de INCA :
+!Config         'none' = sans INCA
+!Config         'chem' = INCA avec calcul de chemie
+!Config         'aero' = INCA avec calcul des aerosols 
+      config_inca = 'none'
+      CALL getin('config_inca',config_inca)
+
+!Config  Key  = ok_dynzon 
+!Config  Desc = sortie des transports zonaux dans la dynamique
+!Config  Def  = n 
+!Config  Help = Permet de mettre en route le calcul des transports 
+!Config          
+      ok_dynzon = .FALSE. 
+      CALL getin('ok_dynzon',ok_dynzon) 
+
+!Config  Key  = ok_dyn_ins
+!Config  Desc = sorties instantanees dans la dynamique
+!Config  Def  = n 
+!Config  Help = 
+!Config          
+      ok_dyn_ins = .FALSE. 
+      CALL getin('ok_dyn_ins',ok_dyn_ins) 
+
+!Config  Key  = ok_dyn_ave
+!Config  Desc = sorties moyennes dans la dynamique
+!Config  Def  = n 
+!Config  Help = 
+!Config          
+      ok_dyn_ave = .FALSE. 
+      CALL getin('ok_dyn_ave',ok_dyn_ave) 
+
+!Config  Key  = use_filtre_fft
+!Config  Desc = flag d'activation des FFT pour le filtre
+!Config  Def  = false
+!Config  Help = permet d'activer l'utilisation des FFT pour effectuer
+!Config         le filtrage aux poles.
+! Le filtre fft n'est pas implemente dans dyn3d 
+      use_filtre_fft=.FALSE.
+      CALL getin('use_filtre_fft',use_filtre_fft)
+
+      IF (use_filtre_fft) THEN
+        write(lunout,*)'STOP !!!'
+        write(lunout,*)'use_filtre_fft n est pas implemente dans dyn3d'
+        STOP 1
+      ENDIF
+      
+!Config key = ok_strato
+!Config  Desc = activation de la version strato
+!Config  Def  = .FALSE.
+!Config  Help = active la version stratosphérique de LMDZ de F. Lott
+
+      ok_strato=.FALSE.
+      CALL getin('ok_strato',ok_strato)
+
+      vert_prof_dissip = merge(1, 0, ok_strato .and. llm==39)
+      CALL getin('vert_prof_dissip', vert_prof_dissip)
+      call assert(vert_prof_dissip == 0 .or. vert_prof_dissip ==  1,                 &
+       &     "bad value for vert_prof_dissip")
+
+!Config  Key  = ok_gradsfile
+!Config  Desc = activation des sorties grads du guidage
+!Config  Def  = n
+!Config  Help = active les sorties grads du guidage
+
+       ok_gradsfile = .FALSE.
+       CALL getin('ok_gradsfile',ok_gradsfile)
+
+!Config  Key  = ok_limit
+!Config  Desc = creation des fichiers limit dans create_etat0_limit
+!Config  Def  = y
+!Config  Help = production du fichier limit.nc requise
+
+       ok_limit = .TRUE.
+       CALL getin('ok_limit',ok_limit)
+
+!Config  Key  = ok_etat0
+!Config  Desc = creation des fichiers etat0 dans create_etat0_limit
+!Config  Def  = y
+!Config  Help = production des fichiers start.nc, startphy.nc requise
+
+      ok_etat0 = .TRUE.
+      CALL getin('ok_etat0',ok_etat0)
+
+!Config  Key  = grilles_gcm_netcdf
+!Config  Desc = creation de fichier grilles_gcm.nc dans create_etat0_limit
+!Config  Def  = n
+      grilles_gcm_netcdf = .FALSE.
+      CALL getin('grilles_gcm_netcdf',grilles_gcm_netcdf)
+
+      write(lunout,*)' #########################################'
+      write(lunout,*)' Configuration des parametres de cel0'                         &
+       &             //'_limit: '
+      write(lunout,*)' planet_type = ', planet_type
+      write(lunout,*)' calend = ', calend
+      write(lunout,*)' dayref = ', dayref
+      write(lunout,*)' anneeref = ', anneeref
+      write(lunout,*)' nday = ', nday
+      write(lunout,*)' day_step = ', day_step
+      write(lunout,*)' iperiod = ', iperiod
+      write(lunout,*)' iconser = ', iconser
+      write(lunout,*)' iecri = ', iecri
+      write(lunout,*)' periodav = ', periodav 
+      write(lunout,*)' output_grads_dyn = ', output_grads_dyn
+      write(lunout,*)' dissip_period = ', dissip_period
+      write(lunout,*)' lstardis = ', lstardis
+      write(lunout,*)' nitergdiv = ', nitergdiv
+      write(lunout,*)' nitergrot = ', nitergrot
+      write(lunout,*)' niterh = ', niterh
+      write(lunout,*)' tetagdiv = ', tetagdiv
+      write(lunout,*)' tetagrot = ', tetagrot
+      write(lunout,*)' tetatemp = ', tetatemp
+      write(lunout,*)' coefdis = ', coefdis
+      write(lunout,*)' purmats = ', purmats
+      write(lunout,*)' read_start = ', read_start
+      write(lunout,*)' iflag_phys = ', iflag_phys
+      write(lunout,*)' iphysiq = ', iphysiq
+      write(lunout,*)' clon = ', clon
+      write(lunout,*)' clat = ', clat
+      write(lunout,*)' grossismx = ', grossismx
+      write(lunout,*)' grossismy = ', grossismy
+      write(lunout,*)' fxyhypb = ', fxyhypb
+      write(lunout,*)' dzoomx = ', dzoomx
+      write(lunout,*)' dzoomy = ', dzoomy
+      write(lunout,*)' taux = ', taux
+      write(lunout,*)' tauy = ', tauy
+      write(lunout,*)' offline = ', offline
+      write(lunout,*)' type_trac = ', type_trac
+      write(lunout,*)' config_inca = ', config_inca
+      write(lunout,*)' ok_dynzon = ', ok_dynzon
+      write(lunout,*)' ok_dyn_ins = ', ok_dyn_ins 
+      write(lunout,*)' ok_dyn_ave = ', ok_dyn_ave 
+      write(lunout,*)' ok_strato = ', ok_strato
+      write(lunout,*)' ok_gradsfile = ', ok_gradsfile
+      write(lunout,*)' ok_limit = ', ok_limit
+      write(lunout,*)' ok_etat0 = ', ok_etat0
+      write(lunout,*)' grilles_gcm_netcdf = ', grilles_gcm_netcdf
+!c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/conf_phys_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/conf_phys_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/conf_phys_m.F90	(revision 17)
@@ -0,0 +1,2024 @@
+!
+! $Id: conf_phys.F90 1668 2012-10-12 10:47:37Z idelkadi $
+!
+!
+!
+module conf_phys_m
+
+   implicit none
+
+contains
+
+  subroutine conf_phys(ok_journe, ok_mensuel, ok_instan, ok_hf, &
+                       ok_LES,&
+                       callstats,&
+                       solarlong0,seuil_inversion, &
+                       fact_cldcon, facttemps,ok_newmicro,iflag_radia,&
+                       iflag_cldcon, &
+                       iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, &
+  		       ok_ade, ok_aie, ok_cdnc, aerosol_couple, &
+                       flag_aerosol, flag_aerosol_strat, new_aod, &
+                       bl95_b0, bl95_b1,&
+                       read_climoz, &
+                       alp_offset)
+
+   use IOIPSL
+   USE surface_data
+   USE phys_cal_mod
+   USE carbon_cycle_mod, ONLY : carbon_cycle_tr, carbon_cycle_cpl
+   use control_mod
+
+ include "conema3.h"
+ include "fisrtilp.h"
+ include "nuage.h"
+ include "YOMCST.h"
+ include "YOMCST2.h"
+
+ include "thermcell.h"
+ include "iniprint.h"
+
+!IM : on inclut/initialise les taux de CH4, N2O, CFC11 et CFC12
+include "clesphys.h"
+include "compbl.h"
+include "comsoil.h"
+!
+! Configuration de la "physique" de LMDZ a l'aide de la fonction
+! GETIN de IOIPSL
+!
+! LF 05/2001
+!
+
+!
+! type_ocean:      type d'ocean (force, slab, couple)
+! version_ocean:   version d'ocean (opa8/nemo pour type_ocean=couple ou 
+!                                   sicOBS pour type_ocean=slab)
+! ok_veget:   type de modele de vegetation
+! ok_journe:  sorties journalieres
+! ok_hf:  sorties haute frequence
+! ok_mensuel: sorties mensuelles
+! ok_instan:  sorties instantanees
+! ok_ade, ok_aie: apply or not aerosol direct and indirect effects
+! ok_cdnc, ok cloud droplet number concentration
+! flag_aerosol_strat : flag pour les aerosols stratos
+! bl95_b*: parameters in the formula to link CDNC to aerosol mass conc 
+!
+
+
+! Sortie:
+  logical              :: ok_newmicro
+  integer              :: iflag_radia
+  logical              :: ok_journe, ok_mensuel, ok_instan, ok_hf
+  logical              :: ok_LES
+  LOGICAL              :: callstats
+  LOGICAL              :: ok_ade, ok_aie, ok_cdnc, aerosol_couple
+  INTEGER              :: flag_aerosol
+  LOGICAL              :: flag_aerosol_strat
+  LOGICAL              :: new_aod
+  REAL                 :: bl95_b0, bl95_b1
+  real                 :: fact_cldcon, facttemps,ratqsbas,ratqshaut,tau_ratqs
+  integer              :: iflag_cldcon
+  integer              :: iflag_ratqs
+
+  character (len = 6),SAVE  :: type_ocean_omp, version_ocean_omp, ocean_omp
+  character (len = 10),SAVE  :: type_veget_omp
+  CHARACTER(len = 8),SAVE   :: aer_type_omp
+  logical,SAVE              :: ok_newmicro_omp
+  logical,SAVE        :: ok_journe_omp, ok_mensuel_omp, ok_instan_omp, ok_hf_omp        
+  logical,SAVE        :: ok_LES_omp   
+  LOGICAL,SAVE        :: callstats_omp
+  LOGICAL,SAVE        :: ok_ade_omp, ok_aie_omp, ok_cdnc_omp, aerosol_couple_omp
+  INTEGER, SAVE       :: flag_aerosol_omp
+  LOGICAL, SAVE       :: flag_aerosol_strat_omp
+  LOGICAL, SAVE       :: new_aod_omp
+  REAL,SAVE           :: bl95_b0_omp, bl95_b1_omp
+  REAL,SAVE           :: freq_ISCCP_omp, ecrit_ISCCP_omp
+  REAL,SAVE           :: freq_COSP_omp
+  real,SAVE           :: fact_cldcon_omp, facttemps_omp,ratqsbas_omp
+  real,SAVE           :: ratqshaut_omp
+  real,SAVE           :: tau_ratqs_omp
+  integer,SAVE        :: iflag_radia_omp
+  integer,SAVE        :: iflag_rrtm_omp
+  integer,SAVE        :: iflag_cldcon_omp, ip_ebil_phy_omp
+  integer,SAVE        :: iflag_ratqs_omp
+
+  Real,SAVE           :: f_cdrag_ter_omp,f_cdrag_oce_omp
+  Real,SAVE           :: f_rugoro_omp   
+
+! Local
+  real                 :: zzz
+
+  real :: seuil_inversion
+  real,save :: seuil_inversion_omp
+
+  integer,SAVE :: iflag_thermals_ed_omp,iflag_thermals_optflux_omp
+  integer,SAVE :: iflag_thermals_omp,nsplit_thermals_omp
+  real,save :: tau_thermals_omp,alp_bl_k_omp
+!!! nrlmd le 10/04/2012
+  integer,SAVE :: iflag_trig_bl_omp,iflag_clos_bl_omp
+  integer,SAVE :: tau_trig_shallow_omp,tau_trig_deep_omp
+  real,SAVE    :: s_trig_omp
+!!! fin nrlmd le 10/04/2012
+  real :: alp_offset
+  REAL, SAVE :: alp_offset_omp
+  integer,SAVE :: iflag_coupl_omp,iflag_clos_omp,iflag_wake_omp
+  integer,SAVE :: iflag_cvl_sigd_omp
+  REAL, SAVE :: supcrit1_omp, supcrit2_omp
+  INTEGER, SAVE :: iflag_mix_omp
+  real, save :: scut_omp, qqa1_omp, qqa2_omp, gammas_omp, Fmax_omp, alphas_omp
+
+  REAL,SAVE :: R_ecc_omp,R_peri_omp,R_incl_omp,solaire_omp
+  REAL,SAVE :: co2_ppm_omp, RCO2_omp, co2_ppm_per_omp, RCO2_per_omp
+  REAL,SAVE :: CH4_ppb_omp, RCH4_omp, CH4_ppb_per_omp, RCH4_per_omp
+  REAL,SAVE :: N2O_ppb_omp, RN2O_omp, N2O_ppb_per_omp, RN2O_per_omp
+  REAL,SAVE :: CFC11_ppt_omp,RCFC11_omp,CFC11_ppt_per_omp,RCFC11_per_omp
+  REAL,SAVE :: CFC12_ppt_omp,RCFC12_omp,CFC12_ppt_per_omp,RCFC12_per_omp
+  LOGICAL,SAVE :: ok_4xCO2atm_omp
+  REAL,SAVE :: epmax_omp
+  LOGICAL,SAVE :: ok_adj_ema_omp
+  INTEGER,SAVE :: iflag_clw_omp
+  REAL,SAVE :: cld_lc_lsc_omp,cld_lc_con_omp,cld_tau_lsc_omp,cld_tau_con_omp
+  REAL,SAVE :: ffallv_lsc_omp, ffallv_con_omp,coef_eva_omp
+  LOGICAL,SAVE :: reevap_ice_omp
+  INTEGER,SAVE :: iflag_pdf_omp
+  REAL,SAVE :: rad_froid_omp, rad_chau1_omp, rad_chau2_omp
+  REAL,SAVE :: t_glace_min_omp, t_glace_max_omp
+  REAL,SAVE :: rei_min_omp, rei_max_omp
+  REAL,SAVE :: inertie_sol_omp,inertie_sno_omp,inertie_ice_omp
+  REAL,SAVE :: qsol0_omp
+  REAL      :: solarlong0
+  REAL,SAVE :: solarlong0_omp
+  INTEGER,SAVE :: top_height_omp,overlap_omp
+  REAL,SAVE :: cdmmax_omp,cdhmax_omp,ksta_omp,ksta_ter_omp
+  LOGICAL,SAVE :: ok_kzmin_omp
+  REAL, SAVE ::  fmagic_omp, pmagic_omp
+  INTEGER,SAVE :: iflag_pbl_omp,lev_histhf_omp,lev_histday_omp,lev_histmth_omp
+  Integer, save :: lev_histins_omp, lev_histLES_omp 
+  INTEGER, SAVE :: lev_histdayNMC_omp
+  LOGICAL, SAVE :: ok_histNMC_omp(3)
+  REAL, SAVE :: freq_outNMC_omp(3), freq_calNMC_omp(3)
+  CHARACTER*4, SAVE :: type_run_omp
+  LOGICAL,SAVE :: ok_isccp_omp
+  LOGICAL,SAVE :: ok_cosp_omp
+  LOGICAL,SAVE :: ok_mensuelCOSP_omp,ok_journeCOSP_omp,ok_hfCOSP_omp
+  REAL,SAVE :: lonmin_ins_omp, lonmax_ins_omp, latmin_ins_omp, latmax_ins_omp
+  REAL,SAVE :: ecrit_hf_omp, ecrit_day_omp, ecrit_mth_omp, ecrit_reg_omp
+  REAL,SAVE :: ecrit_ins_omp
+  REAL,SAVE :: ecrit_LES_omp
+  REAL,SAVE :: ecrit_tra_omp
+  REAL,SAVE :: cvl_corr_omp
+  LOGICAL,SAVE :: ok_lic_melt_omp
+!
+  LOGICAL,SAVE :: cycle_diurne_omp,soil_model_omp,new_oliq_omp
+  LOGICAL,SAVE :: ok_orodr_omp, ok_orolf_omp, ok_limitvrai_omp
+  INTEGER, SAVE :: nbapp_rad_omp, iflag_con_omp
+  INTEGER, SAVE :: iflag_ener_conserv_omp
+  LOGICAL,SAVE :: ok_strato_omp
+  LOGICAL,SAVE :: ok_hines_omp
+  LOGICAL,SAVE      :: carbon_cycle_tr_omp
+  LOGICAL,SAVE      :: carbon_cycle_cpl_omp
+
+  integer, intent(out):: read_climoz ! read ozone climatology, OpenMP shared
+  ! Allowed values are 0, 1 and 2
+  ! 0: do not read an ozone climatology
+  ! 1: read a single ozone climatology that will be used day and night
+  ! 2: read two ozone climatologies, the average day and night
+  ! climatology and the daylight climatology
+
+!$OMP MASTER 
+!Config Key  = type_ocean 
+!Config Desc = Type d'ocean
+!Config Def  = force
+!Config Help = Type d'ocean utilise: force, slab,couple
+!
+  type_ocean_omp = 'force '
+  call getin('type_ocean', type_ocean_omp)
+!
+!Config Key  = version_ocean 
+!Config Desc = Version d'ocean
+!Config Def  = xxxxxx
+!Config Help = Version d'ocean utilise: opa8/nemo/sicOBS/xxxxxx
+!
+  version_ocean_omp = 'xxxxxx'
+  call getin('version_ocean', version_ocean_omp)
+
+!Config Key  = OCEAN
+!Config Desc = Old parameter name for type_ocean
+!Config Def  = yyyyyy
+!Config Help = This is only for testing purpose
+!
+  ocean_omp = 'yyyyyy'
+  call getin('OCEAN', ocean_omp)
+  IF (ocean_omp /= 'yyyyyy') THEN
+     WRITE(lunout,*)'ERROR!! Old variable name OCEAN used in parmeter file.'
+     WRITE(lunout,*)'Variable OCEAN has been replaced by the variable type_ocean.'
+     WRITE(lunout,*)'You have to update your parameter file physiq.def to succed running'
+     CALL abort_gcm('conf_phys','Variable OCEAN no longer existing, use variable name type_ocean',1)
+  END IF
+
+!
+!Config Key  = VEGET 
+!Config Desc = Type de modele de vegetation
+!Config Def  = .false.
+!Config Help = Type de modele de vegetation utilise
+!
+  type_veget_omp ='orchidee'
+  call getin('VEGET', type_veget_omp)
+!
+!Config Key  = OK_journe
+!Config Desc = Pour des sorties journalieres 
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histday contenant les sorties
+!              journalieres 
+!
+  ok_journe_omp = .false.
+  call getin('OK_journe', ok_journe_omp)
+!
+!Config Key  = ok_hf
+!Config Desc = Pour des sorties haute frequence
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histhf contenant les sorties
+!              haute frequence ( 3h ou 6h)
+!
+  ok_hf_omp = .false.
+  call getin('ok_hf', ok_hf_omp)
+!
+!Config Key  = OK_mensuel
+!Config Desc = Pour des sorties mensuelles 
+!Config Def  = .true.
+!Config Help = Pour creer le fichier histmth contenant les sorties
+!              mensuelles 
+!
+  ok_mensuel_omp = .true.
+  call getin('OK_mensuel', ok_mensuel_omp)
+!
+!Config Key  = OK_instan
+!Config Desc = Pour des sorties instantanees 
+!Config Def  = .false.
+!Config Help = Pour creer le fichier histins contenant les sorties
+!              instantanees 
+!
+  ok_instan_omp = .false.
+  call getin('OK_instan', ok_instan_omp)
+!
+!Config Key  = ok_ade
+!Config Desc = Aerosol direct effect or not?
+!Config Def  = .false.
+!Config Help = Used in radlwsw.F
+!
+  ok_ade_omp = .false.
+  call getin('ok_ade', ok_ade_omp)
+
+!
+!Config Key  = ok_aie
+!Config Desc = Aerosol indirect effect or not?
+!Config Def  = .false.
+!Config Help = Used in nuage.F and radlwsw.F
+!
+  ok_aie_omp = .false.
+  call getin('ok_aie', ok_aie_omp)
+
+!
+!Config Key  = ok_cdnc
+!Config Desc = ok cloud droplet number concentration
+!Config Def  = .false.
+!Config Help = Used in newmicro.F
+!
+  ok_cdnc_omp = .false.
+  call getin('ok_cdnc', ok_cdnc_omp)
+!
+!Config Key  = aerosol_couple
+!Config Desc = read aerosol in file or calcul by inca
+!Config Def  = .false.
+!Config Help = Used in physiq.F
+!
+  aerosol_couple_omp = .false.
+  CALL getin('aerosol_couple',aerosol_couple_omp)
+!
+!Config Key  = flag_aerosol
+!Config Desc = which aerosol is use for coupled model
+!Config Def  = 1
+!Config Help = Used in physiq.F
+!
+! - flag_aerosol=0 => no aerosol
+! - flag_aerosol=1 => so4 only (defaut) 
+! - flag_aerosol=2 => bc  only 
+! - flag_aerosol=3 => pom only
+! - flag_aerosol=4 => seasalt only 
+! - flag_aerosol=5 => dust only
+! - flag_aerosol=6 => all aerosol
+
+  flag_aerosol_omp = 0
+  CALL getin('flag_aerosol',flag_aerosol_omp)
+!
+!Config Key  = flag_aerosol_strat
+!Config Desc = use stratospheric aerosols T/F
+!Config Def  = false
+!Config Help = Used in physiq.F
+!
+!
+  flag_aerosol_strat_omp = .false.
+  CALL getin('flag_aerosol_strat',flag_aerosol_strat_omp)
+
+! Temporary variable for testing purpose!!
+!Config Key  = new_aod
+!Config Desc = which calcul of aeropt
+!Config Def  = false
+!Config Help = Used in physiq.F
+!
+  new_aod_omp = .true.
+  CALL getin('new_aod',new_aod_omp)
+
+! 
+!Config Key  = aer_type 
+!Config Desc = Use a constant field for the aerosols 
+!Config Def  = scenario 
+!Config Help = Used in readaerosol.F90 
+! 
+  aer_type_omp = 'scenario' 
+  call getin('aer_type', aer_type_omp) 
+
+!
+!Config Key  = bl95_b0
+!Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995)
+!Config Def  = .false.
+!Config Help = Used in nuage.F
+!
+  bl95_b0_omp = 2.
+  call getin('bl95_b0', bl95_b0_omp)
+
+!Config Key  = bl95_b1
+!Config Desc = Parameter in CDNC-maer link (Boucher&Lohmann 1995)
+!Config Def  = .false.
+!Config Help = Used in nuage.F
+!
+  bl95_b1_omp = 0.2
+  call getin('bl95_b1', bl95_b1_omp)
+
+!Config Key  = freq_ISCCP
+!Config Desc = Frequence d'appel du simulateur ISCCP en secondes;
+!              par defaut 10800, i.e. 3 heures 
+!Config Def  = 10800.
+!Config Help = Used in ini_histISCCP.h
+!
+  freq_ISCCP_omp = 10800.
+  call getin('freq_ISCCP', freq_ISCCP_omp)
+!
+!Config Key  = ecrit_ISCCP
+!Config Desc = Frequence d'ecriture des resultats du simulateur ISCCP en nombre de jours;
+!              par defaut 1., i.e. 1 jour
+!Config Def  = 1.
+!Config Help = Used in ini_histISCCP.h
+!
+!
+  ecrit_ISCCP_omp = 1.
+  call getin('ecrit_ISCCP', ecrit_ISCCP_omp)
+
+!Config Key  = freq_COSP
+!Config Desc = Frequence d'appel du simulateur COSP en secondes;
+!              par defaut 10800, i.e. 3 heures
+!Config Def  = 10800.
+!Config Help = Used in ini_histdayCOSP.h
+!
+  freq_COSP_omp = 10800.
+  call getin('freq_COSP', freq_COSP_omp)
+
+!
+!Config Key  = ip_ebil_phy
+!Config Desc = Niveau de sortie pour les diags bilan d'energie 
+!Config Def  = 0
+!Config Help = 
+!               
+  ip_ebil_phy_omp = 0
+  call getin('ip_ebil_phy', ip_ebil_phy_omp)
+!
+!Config Key  = seuil_inversion
+!Config Desc = Seuil ur dTh pour le choix entre les schemas de CL
+!Config Def  = -0.1
+!Config Help = 
+!               
+  seuil_inversion_omp = -0.1
+  call getin('seuil_inversion', seuil_inversion_omp)
+
+!!
+!! Constante solaire & Parametres orbitaux & taux gaz effet de serre BEG
+!!
+!Config Key  = R_ecc
+!Config Desc = Excentricite
+!Config Def  = 0.016715
+!Config Help = 
+!               
+!valeur AMIP II
+  R_ecc_omp = 0.016715
+  call getin('R_ecc', R_ecc_omp)
+!!
+!Config Key  = R_peri
+!Config Desc = Equinoxe
+!Config Def  = 
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  R_peri_omp = 102.7
+  call getin('R_peri', R_peri_omp)
+!!
+!Config Key  = R_incl
+!Config Desc = Inclinaison
+!Config Def  = 
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  R_incl_omp = 23.441
+  call getin('R_incl', R_incl_omp)
+!!
+!Config Key  = solaire
+!Config Desc = Constante solaire en W/m2
+!Config Def  = 1365.
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  solaire_omp = 1365.
+  call getin('solaire', solaire_omp)
+!!
+!Config Key  = co2_ppm
+!Config Desc = concentration du gaz carbonique en ppmv
+!Config Def  = 348.
+!Config Help = 
+!               
+!
+!valeur AMIP II
+  co2_ppm_omp = 348.
+  call getin('co2_ppm', co2_ppm_omp)
+!!
+!Config Key  = RCO2
+!Config Desc = Concentration du CO2
+!Config Def  = co2_ppm * 1.0e-06  * 44.011/28.97
+!Config Def  = 348. * 1.0e-06  * 44.011/28.97
+!Config Help = 
+!               
+! RCO2 = 5.286789092164308E-04
+!ancienne valeur
+  RCO2_omp = co2_ppm_omp * 1.0e-06  * 44.011/28.97 ! pour co2_ppm=348.
+
+!!  call getin('RCO2', RCO2)
+!!
+!Config Key  = RCH4
+!Config Desc = Concentration du CH4
+!Config Def  = 1.65E-06* 16.043/28.97
+!Config Help = 
+!               
+!
+!valeur AMIP II
+!OK  RCH4 = 1.65E-06* 16.043/28.97
+! RCH4 = 9.137366240938903E-07
+!
+!ancienne valeur
+! RCH4 = 1.72E-06* 16.043/28.97
+!OK call getin('RCH4', RCH4)
+  zzz = 1650.
+  call getin('CH4_ppb', zzz)
+  CH4_ppb_omp = zzz
+  RCH4_omp = CH4_ppb_omp * 1.0E-09 * 16.043/28.97
+!!
+!Config Key  = RN2O
+!Config Desc = Concentration du N2O
+!Config Def  = 306.E-09* 44.013/28.97
+!Config Help = 
+!               
+!
+!valeur AMIP II
+!OK  RN2O = 306.E-09* 44.013/28.97
+! RN2O = 4.648939592682085E-07
+!
+!ancienne valeur
+! RN2O = 310.E-09* 44.013/28.97
+!OK  call getin('RN2O', RN2O)
+  zzz=306.
+  call getin('N2O_ppb', zzz)
+  N2O_ppb_omp = zzz
+  RN2O_omp = N2O_ppb_omp * 1.0E-09 * 44.013/28.97
+!!
+!Config Key  = RCFC11
+!Config Desc = Concentration du CFC11
+!Config Def  = 280.E-12* 137.3686/28.97
+!Config Help = 
+!               
+!
+!OK RCFC11 = 280.E-12* 137.3686/28.97
+  zzz = 280.
+  call getin('CFC11_ppt',zzz)
+  CFC11_ppt_omp = zzz
+  RCFC11_omp=CFC11_ppt_omp* 1.0E-12 * 137.3686/28.97
+! RCFC11 = 1.327690990680013E-09
+!OK call getin('RCFC11', RCFC11)
+!!
+!Config Key  = RCFC12
+!Config Desc = Concentration du CFC12
+!Config Def  = 484.E-12* 120.9140/28.97
+!Config Help = 
+!               
+!
+!OK RCFC12 = 484.E-12* 120.9140/28.97
+  zzz = 484.
+  call getin('CFC12_ppt',zzz)
+  CFC12_ppt_omp = zzz
+  RCFC12_omp = CFC12_ppt_omp * 1.0E-12 * 120.9140/28.97
+! RCFC12 = 2.020102726958923E-09
+!OK call getin('RCFC12', RCFC12)
+
+!ajout CFMIP begin
+!!
+!Config Key  = co2_ppm_per
+!Config Desc = concentration du co2_ppm_per
+!Config Def  = 348.
+!Config Help = 
+!               
+  co2_ppm_per_omp = co2_ppm_omp
+  call getin('co2_ppm_per', co2_ppm_per_omp)
+!!
+!Config Key  = RCO2_per
+!Config Desc = Concentration du CO2_per
+!Config Def  = co2_ppm_per * 1.0e-06  * 44.011/28.97
+!Config Def  = 348. * 1.0e-06  * 44.011/28.97
+!Config Help = 
+!               
+  RCO2_per_omp = co2_ppm_per_omp * 1.0e-06  * 44.011/28.97
+
+!Config Key  = ok_4xCO2atm
+!Config Desc = Calcul ou non effet radiatif 4xco2
+!Config Def  = .false.
+!Config Help = 
+
+  ok_4xCO2atm_omp = .false.
+  call getin('ok_4xCO2atm',ok_4xCO2atm_omp)
+
+!Config Key  = RCH4_per
+!Config Desc = Concentration du CH4_per
+!Config Def  = 1.65E-06* 16.043/28.97
+!Config Help = 
+!               
+  zzz = CH4_ppb_omp
+  call getin('CH4_ppb_per', zzz)
+  CH4_ppb_per_omp = zzz
+  RCH4_per_omp = CH4_ppb_per_omp * 1.0E-09 * 16.043/28.97
+!!
+!Config Key  = RN2O_per
+!Config Desc = Concentration du N2O_per
+!Config Def  = 306.E-09* 44.013/28.97
+!Config Help = 
+!               
+  zzz = N2O_ppb_omp
+  call getin('N2O_ppb_per', zzz)
+  N2O_ppb_per_omp = zzz
+  RN2O_per_omp = N2O_ppb_per_omp * 1.0E-09 * 44.013/28.97
+!!
+!Config Key  = RCFC11_per
+!Config Desc = Concentration du CFC11_per
+!Config Def  = 280.E-12* 137.3686/28.97
+!Config Help = 
+!               
+  zzz = CFC11_ppt_omp
+  call getin('CFC11_ppt_per',zzz)
+  CFC11_ppt_per_omp = zzz
+  RCFC11_per_omp=CFC11_ppt_per_omp* 1.0E-12 * 137.3686/28.97
+!!
+!Config Key  = RCFC12_per
+!Config Desc = Concentration du CFC12_per
+!Config Def  = 484.E-12* 120.9140/28.97
+!Config Help = 
+!               
+  zzz = CFC12_ppt_omp
+  call getin('CFC12_ppt_per',zzz)
+  CFC12_ppt_per_omp = zzz
+  RCFC12_per_omp = CFC12_ppt_per_omp * 1.0E-12 * 120.9140/28.97
+!ajout CFMIP end
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! Constantes precedemment dans dyn3d/conf_gcm
+
+!Config  Key  = cycle_diurne
+!Config  Desc = Cycle ddiurne
+!Config  Def  = y
+!Config  Help = Cette option permet d'eteidre le cycle diurne.
+!Config         Peut etre util pour accelerer le code !
+       cycle_diurne_omp = .TRUE.
+       CALL getin('cycle_diurne',cycle_diurne_omp)
+
+!Config  Key  = soil_model
+!Config  Desc = Modele de sol
+!Config  Def  = y
+!Config  Help = Choix du modele de sol (Thermique ?)
+!Config         Option qui pourait un string afin de pouvoir
+!Config         plus de choix ! Ou meme une liste d'options !
+       soil_model_omp = .TRUE.
+       CALL getin('soil_model',soil_model_omp)
+
+!Config  Key  = new_oliq
+!Config  Desc = Nouvelle eau liquide
+!Config  Def  = y
+!Config  Help = Permet de mettre en route la
+!Config         nouvelle parametrisation de l'eau liquide !
+       new_oliq_omp = .TRUE.
+       CALL getin('new_oliq',new_oliq_omp)
+
+!Config  Key  = ok_orodr
+!Config  Desc = Orodr ???
+!Config  Def  = y
+!Config  Help = Y en a pas comprendre !
+!Config         
+       ok_orodr_omp = .TRUE.
+       CALL getin('ok_orodr',ok_orodr_omp)
+
+!Config  Key  =  ok_orolf
+!Config  Desc = Orolf ??
+!Config  Def  = y
+!Config  Help = Connais pas !
+       ok_orolf_omp = .TRUE.
+       CALL getin('ok_orolf', ok_orolf_omp)
+
+!Config  Key  = ok_limitvrai
+!Config  Desc = Force la lecture de la bonne annee
+!Config  Def  = n
+!Config  Help = On peut forcer le modele a lire le
+!Config         fichier SST de la bonne annee. C'est une tres bonne
+!Config         idee, pourquoi ne pas mettre toujours a y ???
+       ok_limitvrai_omp = .FALSE.
+       CALL getin('ok_limitvrai',ok_limitvrai_omp)
+
+!Config  Key  = nbapp_rad
+!Config  Desc = Frequence d'appel au rayonnement
+!Config  Def  = 12
+!Config  Help = Nombre  d'appels des routines de rayonnements
+!Config         par jour.
+       nbapp_rad_omp = 12
+       CALL getin('nbapp_rad',nbapp_rad_omp)
+
+!Config  Key  = iflag_con
+!Config  Desc = Flag de convection
+!Config  Def  = 2
+!Config  Help = Flag  pour la convection les options suivantes existent :
+!Config         1 pour LMD,
+!Config         2 pour Tiedtke,
+!Config         3 pour CCM(NCAR)  
+       iflag_con_omp = 2
+       CALL getin('iflag_con',iflag_con_omp)
+
+!Config  Key  = iflag_ener_conserv
+!Config  Desc = Flag de convection
+!Config  Def  = 1
+!Config  Help = Flag  pour la convection les options suivantes existent :
+!Config         -1 pour Kinetic energy correction
+!Config         1  conservation kinetic and enthalpy
+       iflag_ener_conserv_omp = -1
+       CALL getin('iflag_ener_conserv',iflag_ener_conserv_omp)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!
+!! Constante solaire & Parametres orbitaux & taux gaz effet de serre END
+!!
+!! KE
+!
+
+!Config key  = cvl_corr
+!Config Desc = Facteur multiplication des precip convectives dans KE
+!Config Def  = 1.00
+!Config Help = 1.02 pour un moderne ou un pre-ind. A ajuster pour un glaciaire
+  cvl_corr_omp = 1.00
+  CALL getin('cvl_corr', cvl_corr_omp)
+
+
+!Config Key  = epmax
+!Config Desc = Efficacite precip
+!Config Def  = 0.993
+!Config Help = 
+!
+  epmax_omp = .993
+  call getin('epmax', epmax_omp)
+!
+!Config Key  = ok_adj_ema
+!Config Desc =  
+!Config Def  = false
+!Config Help = 
+!
+  ok_adj_ema_omp = .false.
+  call getin('ok_adj_ema',ok_adj_ema_omp)
+!
+!Config Key  = iflag_clw
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_clw_omp = 0
+  call getin('iflag_clw',iflag_clw_omp)
+!
+!Config Key  = cld_lc_lsc 
+!Config Desc =  
+!Config Def  = 2.6e-4
+!Config Help = 
+!
+  cld_lc_lsc_omp = 2.6e-4
+  call getin('cld_lc_lsc',cld_lc_lsc_omp)
+!
+!Config Key  = cld_lc_con
+!Config Desc =  
+!Config Def  = 2.6e-4
+!Config Help = 
+!
+  cld_lc_con_omp = 2.6e-4
+  call getin('cld_lc_con',cld_lc_con_omp)
+!
+!Config Key  = cld_tau_lsc
+!Config Desc =  
+!Config Def  = 3600.
+!Config Help = 
+!
+  cld_tau_lsc_omp = 3600.
+  call getin('cld_tau_lsc',cld_tau_lsc_omp)
+!
+!Config Key  = cld_tau_con
+!Config Desc =  
+!Config Def  = 3600.
+!Config Help = 
+!
+  cld_tau_con_omp = 3600.
+  call getin('cld_tau_con',cld_tau_con_omp)
+!
+!Config Key  = ffallv_lsc
+!Config Desc =  
+!Config Def  = 1.
+!Config Help = 
+!
+  ffallv_lsc_omp = 1.
+  call getin('ffallv_lsc',ffallv_lsc_omp)
+!
+!Config Key  = ffallv_con
+!Config Desc =  
+!Config Def  = 1.
+!Config Help = 
+!
+  ffallv_con_omp = 1.
+  call getin('ffallv_con',ffallv_con_omp)
+!
+!Config Key  = coef_eva
+!Config Desc =  
+!Config Def  = 2.e-5
+!Config Help = 
+!
+  coef_eva_omp = 2.e-5
+  call getin('coef_eva',coef_eva_omp)
+!
+!Config Key  = reevap_ice
+!Config Desc =  
+!Config Def  = .false.
+!Config Help = 
+!
+  reevap_ice_omp = .false.
+  call getin('reevap_ice',reevap_ice_omp)
+
+!Config Key  = iflag_ratqs
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  iflag_ratqs_omp = 1
+  call getin('iflag_ratqs',iflag_ratqs_omp)
+
+!
+!Config Key  = iflag_radia 
+!Config Desc =  
+!Config Def  = 1
+!Config Help = 
+!
+  iflag_radia_omp = 1
+  call getin('iflag_radia',iflag_radia_omp)
+
+!
+!Config Key  = iflag_rrtm 
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_rrtm_omp = 0
+  call getin('iflag_rrtm',iflag_rrtm_omp)
+
+!
+!Config Key  = iflag_cldcon 
+!Config Desc =  
+!Config Def  = 1
+!Config Help = 
+!
+  iflag_cldcon_omp = 1
+  call getin('iflag_cldcon',iflag_cldcon_omp)
+
+!
+!Config Key  = iflag_pdf 
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_pdf_omp = 0
+  call getin('iflag_pdf',iflag_pdf_omp)
+!
+!Config Key  = fact_cldcon
+!Config Desc =  
+!Config Def  = 0.375
+!Config Help = 
+!
+  fact_cldcon_omp = 0.375
+  call getin('fact_cldcon',fact_cldcon_omp)
+
+!
+!Config Key  = facttemps
+!Config Desc =  
+!Config Def  = 1.e-4
+!Config Help = 
+!
+  facttemps_omp = 1.e-4
+  call getin('facttemps',facttemps_omp)
+
+!
+!Config Key  = ok_newmicro
+!Config Desc =  
+!Config Def  = .true.
+!Config Help = 
+!
+  ok_newmicro_omp = .true.
+  call getin('ok_newmicro',ok_newmicro_omp)
+!
+!Config Key  = ratqsbas
+!Config Desc =  
+!Config Def  = 0.01
+!Config Help = 
+!
+  ratqsbas_omp = 0.01
+  call getin('ratqsbas',ratqsbas_omp)
+!
+!Config Key  = ratqshaut
+!Config Desc =  
+!Config Def  = 0.3
+!Config Help = 
+!
+  ratqshaut_omp = 0.3
+  call getin('ratqshaut',ratqshaut_omp)
+
+!Config Key  = tau_ratqs
+!Config Desc =  
+!Config Def  = 1800.
+!Config Help = 
+!
+  tau_ratqs_omp = 1800.
+  call getin('tau_ratqs',tau_ratqs_omp)
+
+!
+!-----------------------------------------------------------------------
+! Longitude solaire pour le calcul de l'ensoleillement en degre
+! si on veut imposer la saison. Sinon, solarlong0=-999.999
+!Config Key  = solarlong0
+!Config Desc =  
+!Config Def  = -999.999 
+!Config Help = 
+!
+  solarlong0_omp = -999.999
+  call getin('solarlong0',solarlong0_omp)
+!
+!-----------------------------------------------------------------------
+!  Valeur imposee de l'humidite du sol pour le modele bucket.
+!Config Key  = qsol0
+!Config Desc =  
+!Config Def  = -1.
+!Config Help = 
+!
+  qsol0_omp = -1.
+  call getin('qsol0',qsol0_omp)
+!
+!-----------------------------------------------------------------------
+!
+!Config Key  = inertie_ice
+!Config Desc =  
+!Config Def  = 2000.
+!Config Help = 
+!
+  inertie_ice_omp = 2000.
+  call getin('inertie_ice',inertie_ice_omp)
+!
+!Config Key  = inertie_sno
+!Config Desc =  
+!Config Def  = 2000.
+!Config Help = 
+!
+  inertie_sno_omp = 2000.
+  call getin('inertie_sno',inertie_sno_omp)
+!
+!Config Key  = inertie_sol
+!Config Desc =  
+!Config Def  = 2000.
+!Config Help = 
+!
+  inertie_sol_omp = 2000.
+  call getin('inertie_sol',inertie_sol_omp)
+
+!
+!Config Key  = rad_froid
+!Config Desc =  
+!Config Def  = 35.0
+!Config Help = 
+!
+  rad_froid_omp = 35.0
+  call getin('rad_froid',rad_froid_omp)
+
+!
+!Config Key  = rad_chau1
+!Config Desc =  
+!Config Def  = 13.0
+!Config Help = 
+!
+  rad_chau1_omp = 13.0
+  call getin('rad_chau1',rad_chau1_omp)
+
+!
+!Config Key  = rad_chau2
+!Config Desc =  
+!Config Def  = 9.0
+!Config Help = 
+!
+  rad_chau2_omp = 9.0
+  call getin('rad_chau2',rad_chau2_omp)
+
+!
+!Config Key  = t_glace_min
+!Config Desc =  
+!Config Def  = 258.
+!Config Help = 
+!
+  t_glace_min_omp = 258.
+  call getin('t_glace_min',t_glace_min_omp)
+
+!
+!Config Key  = t_glace_max
+!Config Desc =  
+!Config Def  = 273.13
+!Config Help = 
+!
+  t_glace_max_omp = 273.13
+  call getin('t_glace_max',t_glace_max_omp)
+
+!Config Key  = rei_min
+!Config Desc =  
+!Config Def  = 3.5
+!Config Help = 
+!
+  rei_min_omp = 3.5
+  call getin('rei_min',rei_min_omp)
+
+!
+!Config Key  = rei_max
+!Config Desc =  
+!Config Def  = 61.29
+!Config Help = 
+!
+  rei_max_omp = 61.29
+  call getin('rei_max',rei_max_omp)
+
+!
+!Config Key  = top_height
+!Config Desc =
+!Config Def  = 3
+!Config Help =
+!
+  top_height_omp = 3
+  call getin('top_height',top_height_omp)
+
+!
+!Config Key  = overlap
+!Config Desc =
+!Config Def  = 3
+!Config Help =
+!
+  overlap_omp = 3
+  call getin('overlap',overlap_omp)
+
+
+!
+!
+!Config Key  = cdmmax
+!Config Desc =
+!Config Def  = 1.3E-3
+!Config Help =
+!
+  cdmmax_omp = 1.3E-3
+  call getin('cdmmax',cdmmax_omp)
+
+!
+!Config Key  = cdhmax
+!Config Desc =
+!Config Def  = 1.1E-3
+!Config Help =
+!
+  cdhmax_omp = 1.1E-3
+  call getin('cdhmax',cdhmax_omp)
+
+!261103
+!
+!Config Key  = ksta
+!Config Desc =
+!Config Def  = 1.0e-10
+!Config Help =
+!
+  ksta_omp = 1.0e-10
+  call getin('ksta',ksta_omp)
+
+!
+!Config Key  = ksta_ter
+!Config Desc =
+!Config Def  = 1.0e-10
+!Config Help =
+!
+  ksta_ter_omp = 1.0e-10
+  call getin('ksta_ter',ksta_ter_omp)
+
+!
+!Config Key  = ok_kzmin
+!Config Desc =
+!Config Def  = .true.
+!Config Help =
+!
+  ok_kzmin_omp = .true.
+  call getin('ok_kzmin',ok_kzmin_omp)
+
+!
+!Config Key  = fmagic
+!Config Desc = additionnal multiplicator factor used for albedo
+!Config Def  = 1.
+!Config Help = additionnal multiplicator factor used in albedo.F
+!
+  fmagic_omp = 1.
+  call getin('fmagic',fmagic_omp)
+
+!
+!Config Key  = pmagic
+!Config Desc = additional factor used for albedo
+!Config Def  = 0.
+!Config Help = additional factor used in albedo.F
+!
+  pmagic_omp = 0.
+  call getin('pmagic',pmagic_omp)
+
+
+!Config Key = ok_lic_melt
+!Config Desc = Prise en compte de la fonte de la calotte dans le bilan d'eau
+!Config Def  = .false.
+!Config Help = mettre a .false. pour assurer la conservation en eau
+  ok_lic_melt_omp = .false.
+  call getin('ok_lic_melt', ok_lic_melt_omp)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! PARAMETER FOR THE PLANETARY BOUNDARY LAYER
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!Config Key  = iflag_pbl
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  iflag_pbl_omp = 1
+  call getin('iflag_pbl',iflag_pbl_omp)
+!
+!Config Key  = iflag_thermals
+!Config Desc =
+!Config Def  = 0
+!Config Help =
+!
+  iflag_thermals_omp = 0
+  call getin('iflag_thermals',iflag_thermals_omp)
+!
+!
+!Config Key  = iflag_thermals_ed
+!Config Desc =
+!Config Def  = 0
+!Config Help =
+!
+  iflag_thermals_ed_omp = 0
+  call getin('iflag_thermals_ed',iflag_thermals_ed_omp)
+!
+!
+!Config Key  = iflag_thermals_optflux
+!Config Desc =
+!Config Def  = 0
+!Config Help =
+!
+  iflag_thermals_optflux_omp = 0
+  call getin('iflag_thermals_optflux',iflag_thermals_optflux_omp)
+!
+!
+!Config Key  = nsplit_thermals
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  nsplit_thermals_omp = 1
+  call getin('nsplit_thermals',nsplit_thermals_omp)
+
+!Config Key  = alp_bl_k
+!Config Desc =
+!Config Def  = 0.
+!Config Help =
+!
+  alp_bl_k_omp = 1.
+  call getin('alp_bl_k',alp_bl_k_omp)
+
+!!! nrlmd le 10/04/2012
+
+!Config Key  = iflag_trig_bl
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_trig_bl_omp = 0
+  call getin('iflag_trig_bl',iflag_trig_bl_omp)
+
+!Config Key  = s_trig_bl
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  s_trig_omp = 2e7
+  call getin('s_trig',s_trig_omp)
+
+!Config Key  = tau_trig_shallow
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  tau_trig_shallow_omp = 600
+  call getin('tau_trig_shallow',tau_trig_shallow_omp)
+
+!Config Key  = tau_trig_deep
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  tau_trig_deep_omp = 1800
+  call getin('tau_trig_deep',tau_trig_deep_omp)
+
+!Config Key  = iflag_clos_bl
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_clos_bl_omp = 0
+  call getin('iflag_clos_bl',iflag_clos_bl_omp)
+
+!!! fin nrlmd le 10/04/2012
+
+!
+!Config Key  = tau_thermals
+!Config Desc =
+!Config Def  = 0.
+!Config Help =
+!
+  tau_thermals_omp = 0.
+  call getin('tau_thermals',tau_thermals_omp)
+
+!
+!Config Key  = iflag_coupl
+!Config Desc =
+!Config Def  = 0
+!Config Help =
+!
+  iflag_coupl_omp = 0
+  call getin('iflag_coupl',iflag_coupl_omp)
+
+!
+!Config Key  = iflag_clos
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_clos_omp = 1
+  call getin('iflag_clos',iflag_clos_omp)
+!
+!Config Key  = iflag_cvl_sigd
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_cvl_sigd_omp = 0
+  call getin('iflag_cvl_sigd',iflag_cvl_sigd_omp)
+
+!Config Key  = iflag_wake
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  iflag_wake_omp = 0
+  call getin('iflag_wake',iflag_wake_omp)
+
+!Config Key  = alp_offset
+!Config Desc =  
+!Config Def  = 0
+!Config Help = 
+!
+  alp_offset_omp = 0.
+  call getin('alp_offset',alp_offset_omp)
+
+!
+!Config Key  = lev_histhf
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  lev_histhf_omp = 1
+  call getin('lev_histhf',lev_histhf_omp)
+
+!
+!Config Key  = lev_histday
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  lev_histday_omp = 1
+  call getin('lev_histday',lev_histday_omp)
+
+!
+!Config Key  = lev_histmth
+!Config Desc =
+!Config Def  = 2
+!Config Help =
+!
+  lev_histmth_omp = 2
+  call getin('lev_histmth',lev_histmth_omp)
+!
+!Config Key  = lev_histins
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  lev_histins_omp = 1
+  call getin('lev_histins',lev_histins_omp)
+  !
+!Config Key  = lev_histLES
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  lev_histLES_omp = 1
+  call getin('lev_histLES',lev_histLES_omp)
+!
+!Config Key  = lev_histdayNMC
+!Config Desc =
+!Config Def  = 8
+!Config Help =
+!
+  lev_histdayNMC_omp = 8
+  call getin('lev_histdayNMC',lev_histdayNMC_omp)
+!
+!histNMC BEG
+!Config Key  = ok_histNMC
+!Config Desc = ok_histNMC(1) = frequence de sortie fichiers histmthNMC
+!Config Desc = ok_histNMC(2) = frequence de sortie fichiers histdayNMC
+!Config Desc = ok_histNMC(3) = frequence de sortie fichiers histhfNMC
+!Config Def  = n, n, n
+!Config Help =
+!
+  ok_histNMC_omp(1) = .false.
+  ok_histNMC_omp(2) = .false.
+  ok_histNMC_omp(3) = .false.
+  call getin('ok_histNMC',ok_histNMC_omp)
+!
+!Config Key  = freq_outNMC
+!Config Desc = freq_outNMC(1) = frequence de sortie fichiers histmthNMC
+!Config Desc = freq_outNMC(2) = frequence de sortie fichiers histdayNMC
+!Config Desc = freq_outNMC(3) = frequence de sortie fichiers histhfNMC
+!Config Def  = 2592000., 86400., 21600.
+!Config Help =
+!
+! freq_outNMC_omp(1) = 2592000.
+  freq_outNMC_omp(1) = mth_len*86400.
+  freq_outNMC_omp(2) = 86400.
+  freq_outNMC_omp(3) = 21600.
+  call getin('freq_outNMC',freq_outNMC_omp)
+!
+!Config Key  = freq_calNMC
+!Config Desc = freq_calNMC(1) = frequence de calcul fichiers histmthNMC
+!Config Desc = freq_calNMC(2) = frequence de calcul fichiers histdayNMC
+!Config Desc = freq_calNMC(3) = frequence de calcul fichiers histhfNMC
+!Config Def  = pasphys
+!Config Help =
+!
+  freq_calNMC_omp(1) = pasphys
+  freq_calNMC_omp(2) = pasphys
+  freq_calNMC_omp(3) = pasphys
+  call getin('freq_calNMC',freq_calNMC_omp)
+!
+!Config Key  = type_run
+!Config Desc =
+!Config Def  = 'AMIP'/'CFMIP'  ou 'CLIM'/'ENSP'
+!Config Help =
+!
+  type_run_omp = 'AMIP'
+  call getin('type_run',type_run_omp)
+
+!
+!Config Key  = ok_isccp
+!Config Desc =
+!Config Def  = .true.
+!Config Help =
+!
+! ok_isccp = .true.
+  ok_isccp_omp = .false.
+  call getin('ok_isccp',ok_isccp_omp)
+
+!
+!Config Key  = ok_cosp
+!Config Desc =
+!Config Def  = .false.
+!Config Help =
+!
+  ok_cosp_omp = .false.
+  call getin('ok_cosp',ok_cosp_omp)
+
+!
+!Config Key  = ok_mensuelCOSP
+!Config Desc =
+!Config Def  = .true.
+!Config Help =
+!
+  ok_mensuelCOSP_omp = .true.
+  call getin('ok_mensuelCOSP',ok_mensuelCOSP_omp)
+
+!
+!Config Key  = ok_journeCOSP
+!Config Desc =
+!Config Def  = .true.
+!Config Help = 
+!
+  ok_journeCOSP_omp = .true.
+  call getin('ok_journeCOSP',ok_journeCOSP_omp)
+
+!
+!Config Key  = ok_hfCOSP
+!Config Desc =
+!Config Def  = .false.
+!Config Help =
+!
+  ok_hfCOSP_omp = .false.
+  call getin('ok_hfCOSP',ok_hfCOSP_omp)
+
+!
+! coordonnees (lonmin_ins, lonmax_ins, latmin_ins, latmax_ins) pour la zone 
+! avec sorties instantannees tous les pas de temps de la physique => "histbilKP_ins.nc"
+!
+!Config Key  = lonmin_ins
+!Config Desc = 100.  
+!Config Def  = longitude minimale sorties "bilKP_ins"
+!Config Help = 
+!
+   lonmin_ins_omp = 100.
+   call getin('lonmin_ins',lonmin_ins_omp)
+!
+!Config Key  = lonmax_ins
+!Config Desc = 130. 
+!Config Def  = longitude maximale sorties "bilKP_ins"
+!Config Help =
+!
+   lonmax_ins_omp = 130.
+   call getin('lonmax_ins',lonmax_ins_omp)
+!
+!Config Key  = latmin_ins
+!Config Desc = -20.  
+!Config Def  = latitude minimale sorties "bilKP_ins"
+!Config Help = 
+!
+   latmin_ins_omp = -20.
+   call getin('latmin_ins',latmin_ins_omp)
+!
+!Config Key  = latmax_ins
+!Config Desc = 20. 
+!Config Def  = latitude maximale sorties "bilKP_ins"
+!Config Help =
+!
+   latmax_ins_omp = 20.
+   call getin('latmax_ins',latmax_ins_omp)
+!
+!Config Key  = ecrit_hf
+!Config Desc =
+!Config Def  = 1./8. !toutes les 3h
+!Config Help =
+!
+  ecrit_hf_omp = 1./8.
+  call getin('ecrit_hf',ecrit_hf_omp)
+!
+!Config Key  = ecrit_ins
+!Config Desc =
+!Config Def  = 1./48. ! toutes les 1/2 h
+!Config Help =
+!
+  ecrit_ins_omp = 1./48.
+  call getin('ecrit_ins',ecrit_ins_omp)
+!
+!Config Key  = ecrit_day
+!Config Desc =
+!Config Def  = 1.0 !tous les jours
+!Config Help = nombre de jours pour ecriture fichier histday.nc
+!
+  ecrit_day_omp = 1.0
+  call getin('ecrit_day',ecrit_day_omp)
+!
+!Config Key  = ecrit_mth
+!Config Desc =
+!Config Def  = 30. !tous les 30jours (1 fois par mois)
+!Config Help =
+!
+  ecrit_mth_omp = 30.
+  call getin('ecrit_mth',ecrit_mth_omp)
+!
+!Config Key  = ecrit_tra
+!Config Desc =
+!Config Def  = 30. !tous les 30jours (1 fois par mois)
+!Config Help =
+!
+  ecrit_tra_omp = 0.
+  call getin('ecrit_tra',ecrit_tra_omp)
+!
+!Config Key  = ecrit_reg
+!Config Desc =
+!Config Def  = 0.25  !4 fois par jour
+!Config Help =
+!
+  ecrit_reg_omp = 0.25   !4 fois par jour
+  call getin('ecrit_reg',ecrit_reg_omp)
+!
+!
+!
+! PARAMETRES CDRAG
+!
+!Config Key  = f_cdrag_ter
+!Config Desc =
+!Config Def  = 0.8
+!Config Help =
+!
+  f_cdrag_ter_omp = 0.8
+  call getin('f_cdrag_ter',f_cdrag_ter_omp)
+!
+!Config Key  = f_cdrag_oce
+!Config Desc =
+!Config Def  = 0.8
+!Config Help =
+!
+  f_cdrag_oce_omp = 0.8
+  call getin('f_cdrag_oce',f_cdrag_oce_omp)
+!
+! RUGORO
+!Config Key  = f_rugoro
+!Config Desc =
+!Config Def  = 0.
+!Config Help =
+!
+  f_rugoro_omp = 0.
+  call getin('f_rugoro',f_rugoro_omp)
+
+! PARAMETERS FOR CONVECTIVE INHIBITION BY TROPOS. DRYNESS
+!
+!Config Key  = supcrit1
+!Config Desc =
+!Config Def  = .540
+!Config Help =
+!
+  supcrit1_omp = .540
+  call getin('supcrit1',supcrit1_omp)
+
+!
+!Config Key  = supcrit2
+!Config Desc =
+!Config Def  = .600
+!Config Help =
+!
+  supcrit2_omp = .600
+  call getin('supcrit2',supcrit2_omp)
+
+!
+! PARAMETERS FOR THE MIXING DISTRIBUTION
+! iflag_mix: 0=OLD, 
+!            1=NEW (JYG),            
+!            2=NEW + conv. depth inhib. by tropos. dryness
+! '2' is NOT operationnal and should not be used.
+!
+!Config Key  = iflag_mix
+!Config Desc =
+!Config Def  = 1
+!Config Help =
+!
+  iflag_mix_omp = 1
+  call getin('iflag_mix',iflag_mix_omp)
+
+!
+!Config Key  = scut
+!Config Desc =
+!Config Def  = 0.95
+!Config Help =
+!
+  scut_omp = 0.95
+  call getin('scut',scut_omp)
+
+!
+!Config Key  = qqa1
+!Config Desc =
+!Config Def  = 1.0
+!Config Help =
+!
+  qqa1_omp = 1.0
+  call getin('qqa1',qqa1_omp)
+
+!
+!Config Key  = qqa2
+!Config Desc =
+!Config Def  = 0.0
+!Config Help =
+!
+  qqa2_omp = 0.0
+  call getin('qqa2',qqa2_omp)
+
+!
+!Config Key  = gammas
+!Config Desc =
+!Config Def  = 0.05
+!Config Help =
+!
+  gammas_omp = 0.05
+  call getin('gammas',gammas_omp)
+
+!
+!Config Key  = Fmax
+!Config Desc =
+!Config Def  = 0.65
+!Config Help =
+!
+  Fmax_omp = 0.65
+  call getin('Fmax',Fmax_omp)
+
+!
+!Config Key  = alphas  
+!Config Desc =
+!Config Def  = -5.
+!Config Help =
+!
+  alphas_omp = -5.
+  call getin('alphas',alphas_omp)
+
+!Config key = ok_strato
+!Config  Desc = activation de la version strato
+!Config  Def  = .FALSE.
+!Config  Help = active la version stratosphérique de LMDZ de F. Lott
+
+  ok_strato_omp=.FALSE.
+  CALL getin('ok_strato',ok_strato_omp)
+      
+!Config  key = ok_hines
+!Config  Desc = activation de la parametrisation de hines
+!Config  Def  = .FALSE.
+!Config  Help = Clefs controlant la parametrization de Hines
+!               Et la sponge layer (Runs Stratospheriques)
+
+  ok_hines_omp=.FALSE.
+  CALL getin('ok_hines',ok_hines_omp)
+
+!Config Key  = OK_LES                                               
+!Config Desc = Pour des sorties LES                                 
+!Config Def  = .false.                                              
+!Config Help = Pour creer le fichier histLES contenant les sorties  
+!              LES                                                  
+!                                                                   
+  ok_LES_omp = .false.                                              
+  call getin('OK_LES', ok_LES_omp)                                  
+
+!Config Key  = callstats                                               
+!Config Desc = Pour des sorties callstats                                 
+!Config Def  = .false.                                              
+!Config Help = Pour creer le fichier stats contenant les sorties  
+!              stats                                                  
+!                                                                   
+  callstats_omp = .false.                                              
+  call getin('callstats', callstats_omp)                                  
+!
+!Config Key  = ecrit_LES
+!Config Desc = Frequence d'ecriture des resultats du LES en nombre de jours;
+!              par defaut 1., i.e. 1 jour
+!Config Def  = 1./8.
+!Config Help = ... 
+!
+!
+  ecrit_LES_omp = 1./8.
+  call getin('ecrit_LES', ecrit_LES_omp)
+!
+  read_climoz = 0 ! default value
+  call getin('read_climoz', read_climoz)
+
+  carbon_cycle_tr_omp=.FALSE.
+  CALL getin('carbon_cycle_tr',carbon_cycle_tr_omp)
+
+  carbon_cycle_cpl_omp=.FALSE.
+  CALL getin('carbon_cycle_cpl',carbon_cycle_cpl_omp)
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+    R_ecc = R_ecc_omp
+    R_peri = R_peri_omp
+    R_incl = R_incl_omp
+    solaire = solaire_omp
+    co2_ppm = co2_ppm_omp
+    RCO2 = RCO2_omp
+    CH4_ppb = CH4_ppb_omp
+    RCH4 = RCH4_omp
+    N2O_ppb = N2O_ppb_omp
+    RN2O = RN2O_omp
+    CFC11_ppt = CFC11_ppt_omp
+    RCFC11 = RCFC11_omp
+    CFC12_ppt = CFC12_ppt_omp
+    RCFC12 = RCFC12_omp
+    RCO2_act = RCO2
+    RCH4_act = RCH4
+    RN2O_act = RN2O
+    RCFC11_act = RCFC11
+    RCFC12_act = RCFC12
+    ok_4xCO2atm = ok_4xCO2atm_omp
+    RCO2_per = RCO2_per_omp
+    RCH4_per = RCH4_per_omp
+    RN2O_per = RN2O_per_omp
+    RCFC11_per = RCFC11_per_omp
+    RCFC12_per = RCFC12_per_omp
+    
+    cycle_diurne = cycle_diurne_omp
+    soil_model = soil_model_omp
+    new_oliq = new_oliq_omp
+    ok_orodr = ok_orodr_omp
+    ok_orolf = ok_orolf_omp
+    ok_limitvrai = ok_limitvrai_omp
+    nbapp_rad = nbapp_rad_omp
+    iflag_con = iflag_con_omp
+    iflag_ener_conserv = iflag_ener_conserv_omp
+
+    epmax = epmax_omp
+    ok_adj_ema = ok_adj_ema_omp
+    iflag_clw = iflag_clw_omp
+    cld_lc_lsc = cld_lc_lsc_omp
+    cld_lc_con = cld_lc_con_omp
+    cld_tau_lsc = cld_tau_lsc_omp
+    cld_tau_con = cld_tau_con_omp
+    ffallv_lsc = ffallv_lsc_omp
+    ffallv_con = ffallv_con_omp
+    coef_eva = coef_eva_omp
+    reevap_ice = reevap_ice_omp
+    iflag_pdf = iflag_pdf_omp
+    solarlong0 = solarlong0_omp
+    qsol0 = qsol0_omp
+    inertie_sol = inertie_sol_omp
+    inertie_ice = inertie_ice_omp
+    inertie_sno = inertie_sno_omp
+    rad_froid = rad_froid_omp
+    rad_chau1 = rad_chau1_omp
+    rad_chau2 = rad_chau2_omp
+    t_glace_min = t_glace_min_omp
+    t_glace_max = t_glace_max_omp
+    rei_min = rei_min_omp
+    rei_max = rei_max_omp
+    top_height = top_height_omp
+    overlap = overlap_omp
+    cdmmax = cdmmax_omp
+    cdhmax = cdhmax_omp
+    ksta = ksta_omp
+    ksta_ter = ksta_ter_omp
+    ok_kzmin = ok_kzmin_omp
+    fmagic = fmagic_omp
+    pmagic = pmagic_omp
+    iflag_pbl = iflag_pbl_omp
+    lev_histhf = lev_histhf_omp
+    lev_histday = lev_histday_omp
+    lev_histmth = lev_histmth_omp
+    lev_histins = lev_histins_omp
+    lev_histLES = lev_histLES_omp
+    lev_histdayNMC = lev_histdayNMC_omp
+    ok_histNMC(:) = ok_histNMC_omp(:)
+    freq_outNMC(:) = freq_outNMC_omp(:)
+    freq_calNMC(:) = freq_calNMC_omp(:)
+
+    type_ocean = type_ocean_omp
+    version_ocean = version_ocean_omp
+
+    ok_veget=.true.
+    type_veget=type_veget_omp
+    if (type_veget=='n' .or. type_veget=='bucket' .or. type_veget=='betaclim' ) &
+         & then
+         ok_veget=.false.
+    endif
+
+    ok_newmicro = ok_newmicro_omp
+    ok_journe = ok_journe_omp
+    ok_hf = ok_hf_omp
+    ok_mensuel = ok_mensuel_omp
+    ok_instan = ok_instan_omp
+    freq_ISCCP = freq_ISCCP_omp
+    ecrit_ISCCP = ecrit_ISCCP_omp
+    freq_COSP = freq_COSP_omp
+    ok_ade = ok_ade_omp
+    ok_aie = ok_aie_omp
+    ok_cdnc = ok_cdnc_omp
+    aerosol_couple = aerosol_couple_omp
+    flag_aerosol=flag_aerosol_omp
+    flag_aerosol_strat=flag_aerosol_strat_omp
+    new_aod=new_aod_omp
+    aer_type = aer_type_omp
+    bl95_b0 = bl95_b0_omp
+    bl95_b1 = bl95_b1_omp
+    fact_cldcon = fact_cldcon_omp
+    facttemps = facttemps_omp
+    ratqsbas = ratqsbas_omp
+    ratqshaut = ratqshaut_omp
+    tau_ratqs = tau_ratqs_omp
+
+    iflag_radia = iflag_radia_omp
+    iflag_rrtm = iflag_rrtm_omp
+    iflag_cldcon = iflag_cldcon_omp
+    iflag_ratqs = iflag_ratqs_omp
+    ip_ebil_phy = ip_ebil_phy_omp
+    iflag_thermals = iflag_thermals_omp
+    iflag_thermals_ed = iflag_thermals_ed_omp
+    iflag_thermals_optflux = iflag_thermals_optflux_omp
+    nsplit_thermals = nsplit_thermals_omp
+    tau_thermals = tau_thermals_omp
+    alp_bl_k = alp_bl_k_omp
+!!! nrlmd le 10/04/2012
+    iflag_trig_bl = iflag_trig_bl_omp
+    s_trig = s_trig_omp
+    tau_trig_shallow = tau_trig_shallow_omp
+    tau_trig_deep = tau_trig_deep_omp
+    iflag_clos_bl = iflag_clos_bl_omp
+!!! fin nrlmd le 10/04/2012
+    iflag_coupl = iflag_coupl_omp
+    iflag_clos = iflag_clos_omp
+    iflag_wake = iflag_wake_omp
+    alp_offset = alp_offset_omp
+    iflag_cvl_sigd = iflag_cvl_sigd_omp
+    type_run = type_run_omp
+    ok_isccp = ok_isccp_omp
+    ok_cosp = ok_cosp_omp
+    ok_mensuelCOSP = ok_mensuelCOSP_omp
+    ok_journeCOSP = ok_journeCOSP_omp
+    ok_hfCOSP = ok_hfCOSP_omp
+    seuil_inversion=seuil_inversion_omp
+    lonmin_ins = lonmin_ins_omp
+    lonmax_ins = lonmax_ins_omp
+    latmin_ins = latmin_ins_omp
+    latmax_ins = latmax_ins_omp
+    ecrit_hf   = ecrit_hf_omp
+    ecrit_ins   = ecrit_ins_omp
+    ecrit_day = ecrit_day_omp
+    ecrit_mth = ecrit_mth_omp
+    ecrit_tra = ecrit_tra_omp
+    ecrit_reg = ecrit_reg_omp
+    cvl_corr = cvl_corr_omp
+    ok_lic_melt = ok_lic_melt_omp
+    f_cdrag_ter=f_cdrag_ter_omp
+    f_cdrag_oce=f_cdrag_oce_omp
+    f_rugoro=f_rugoro_omp
+    supcrit1 = supcrit1_omp
+    supcrit2 = supcrit2_omp
+    iflag_mix = iflag_mix_omp
+    scut = scut_omp
+    qqa1 = qqa1_omp
+    qqa2 = qqa2_omp
+    gammas = gammas_omp
+    Fmax = Fmax_omp
+    alphas = alphas_omp
+    ok_strato = ok_strato_omp
+    ok_hines = ok_hines_omp
+    ok_LES = ok_LES_omp
+    callstats = callstats_omp
+    ecrit_LES = ecrit_LES_omp
+    carbon_cycle_tr = carbon_cycle_tr_omp
+    carbon_cycle_cpl = carbon_cycle_cpl_omp
+
+! Test of coherence between type_ocean and version_ocean
+    IF (type_ocean=='couple' .AND. (version_ocean/='opa8' .AND. version_ocean/='nemo') ) THEN
+       WRITE(lunout,*)' ERROR version_ocean=',version_ocean,' not valid in coupled configuration'
+       CALL abort_gcm('conf_phys','version_ocean not valid',1)
+    END IF
+
+    IF (type_ocean=='slab' .AND. version_ocean=='xxxxxx') THEN
+       version_ocean='sicOBS'
+    ELSE IF (type_ocean=='slab' .AND. version_ocean/='sicOBS') THEN
+       WRITE(lunout,*)' ERROR version_ocean=',version_ocean,' not valid with slab ocean'
+       CALL abort_gcm('conf_phys','version_ocean not valid',1)
+    END IF
+
+! Test sur new_aod. Ce flag permet de retrouver les resultats de l'AR4
+! il n'est utilisable que lors du couplage avec le SO4 seul 
+    IF (ok_ade .OR. ok_aie) THEN 
+       IF ( flag_aerosol .EQ. 0 ) THEN
+          CALL abort_gcm('conf_phys','flag_aerosol=0 not compatible avec ok_ade ou ok_aie=.TRUE.',1)
+       END IF
+       IF ( .NOT. new_aod .AND.  flag_aerosol .NE. 1) THEN
+          CALL abort_gcm('conf_phys','new_aod=.FALSE. not compatible avec flag_aerosol=1',1)
+       END IF
+    END IF
+
+! ok_cdnc must be set to y if ok_aie is activated
+    IF (ok_aie .AND. .NOT. ok_cdnc) THEN
+       CALL abort_gcm('conf_phys', 'ok_cdnc must be set to y if ok_aie is activated',1)
+    ENDIF 
+
+!$OMP MASTER
+
+  write(lunout,*)' ##############################################'
+  write(lunout,*)' Configuration des parametres de la physique: '
+  write(lunout,*)' Type ocean = ', type_ocean
+  write(lunout,*)' Version ocean = ', version_ocean
+  write(lunout,*)' Config veget = ', ok_veget,type_veget
+  write(lunout,*)' Sortie journaliere = ', ok_journe
+  write(lunout,*)' Sortie haute frequence = ', ok_hf
+  write(lunout,*)' Sortie mensuelle = ', ok_mensuel
+  write(lunout,*)' Sortie instantanee = ', ok_instan
+  write(lunout,*)' Frequence appel simulateur ISCCP, freq_ISCCP =', freq_ISCCP
+  write(lunout,*)' Frequence appel simulateur ISCCP, ecrit_ISCCP =', ecrit_ISCCP
+  write(lunout,*)' Frequence appel simulateur COSP, freq_COSP =', freq_COSP
+  write(lunout,*)' Sortie bilan d''energie, ip_ebil_phy =', ip_ebil_phy
+  write(lunout,*)' Excentricite = ',R_ecc
+  write(lunout,*)' Equinoxe = ',R_peri
+  write(lunout,*)' Inclinaison =',R_incl
+  write(lunout,*)' Constante solaire =',solaire
+  write(lunout,*)' co2_ppm =',co2_ppm
+  write(lunout,*)' RCO2_act = ',RCO2_act
+  write(lunout,*)' CH4_ppb =',CH4_ppb,' RCH4_act = ',RCH4_act
+  write(lunout,*)' N2O_ppb =',N2O_ppb,' RN2O_act=  ',RN2O_act
+  write(lunout,*)' CFC11_ppt=',CFC11_ppt,' RCFC11_act=  ',RCFC11_act
+  write(lunout,*)' CFC12_ppt=',CFC12_ppt,' RCFC12_act=  ',RCFC12_act
+  write(lunout,*)' ok_4xCO2atm=',ok_4xCO2atm
+  write(lunout,*)' RCO2_per = ',RCO2_per,' RCH4_per = ', RCH4_per
+  write(lunout,*)' RN2O_per = ',RN2O_per,' RCFC11_per = ', RCFC11_per
+  write(lunout,*)' RCFC12_per = ',RCFC12_per
+  write(lunout,*)' cvl_corr=', cvl_corr
+  write(lunout,*)'ok_lic_melt=', ok_lic_melt
+  write(lunout,*)'cycle_diurne=',cycle_diurne
+  write(lunout,*)'soil_model=',soil_model
+  write(lunout,*)'new_oliq=',new_oliq
+  write(lunout,*)'ok_orodr=',ok_orodr
+  write(lunout,*)'ok_orolf=',ok_orolf
+  write(lunout,*)'ok_limitvrai=',ok_limitvrai
+  write(lunout,*)'nbapp_rad=',nbapp_rad
+  write(lunout,*)'iflag_con=',iflag_con
+  write(lunout,*)'iflag_ener_conserv=',iflag_ener_conserv
+  write(lunout,*)' epmax = ', epmax
+  write(lunout,*)' ok_adj_ema = ', ok_adj_ema
+  write(lunout,*)' iflag_clw = ', iflag_clw
+  write(lunout,*)' cld_lc_lsc = ', cld_lc_lsc
+  write(lunout,*)' cld_lc_con = ', cld_lc_con
+  write(lunout,*)' cld_tau_lsc = ', cld_tau_lsc
+  write(lunout,*)' cld_tau_con = ', cld_tau_con
+  write(lunout,*)' ffallv_lsc = ', ffallv_lsc
+  write(lunout,*)' ffallv_con = ', ffallv_con
+  write(lunout,*)' coef_eva = ', coef_eva
+  write(lunout,*)' reevap_ice = ', reevap_ice
+  write(lunout,*)' iflag_pdf = ', iflag_pdf
+  write(lunout,*)' iflag_cldcon = ', iflag_cldcon
+  write(lunout,*)' iflag_radia = ', iflag_radia
+  write(lunout,*)' iflag_rrtm = ', iflag_rrtm
+  write(lunout,*)' iflag_ratqs = ', iflag_ratqs
+  write(lunout,*)' seuil_inversion = ', seuil_inversion
+  write(lunout,*)' fact_cldcon = ', fact_cldcon
+  write(lunout,*)' facttemps = ', facttemps
+  write(lunout,*)' ok_newmicro = ',ok_newmicro 
+  write(lunout,*)' ratqsbas = ',ratqsbas 
+  write(lunout,*)' ratqshaut = ',ratqshaut 
+  write(lunout,*)' tau_ratqs = ',tau_ratqs 
+  write(lunout,*)' top_height = ',top_height 
+  write(lunout,*)' rad_froid = ',rad_froid
+  write(lunout,*)' rad_chau1 = ',rad_chau1
+  write(lunout,*)' rad_chau2 = ',rad_chau2
+  write(lunout,*)' t_glace_min = ',t_glace_min
+  write(lunout,*)' t_glace_max = ',t_glace_max
+  write(lunout,*)' rei_min = ',rei_min
+  write(lunout,*)' rei_max = ',rei_max
+  write(lunout,*)' overlap = ',overlap 
+  write(lunout,*)' cdmmax = ',cdmmax 
+  write(lunout,*)' cdhmax = ',cdhmax 
+  write(lunout,*)' ksta = ',ksta 
+  write(lunout,*)' ksta_ter = ',ksta_ter 
+  write(lunout,*)' ok_kzmin = ',ok_kzmin 
+  write(lunout,*)' fmagic = ',fmagic
+  write(lunout,*)' pmagic = ',pmagic
+  write(lunout,*)' ok_ade = ',ok_ade
+  write(lunout,*)' ok_aie = ',ok_aie
+  write(lunout,*)' aerosol_couple = ', aerosol_couple
+  write(lunout,*)' flag_aerosol = ', flag_aerosol
+  write(lunout,*)' flag_aerosol_strat = ', flag_aerosol_strat
+  write(lunout,*)' new_aod = ', new_aod
+  write(lunout,*)' aer_type = ',aer_type
+  write(lunout,*)' bl95_b0 = ',bl95_b0
+  write(lunout,*)' bl95_b1 = ',bl95_b1
+  write(lunout,*)' lev_histhf = ',lev_histhf 
+  write(lunout,*)' lev_histday = ',lev_histday 
+  write(lunout,*)' lev_histmth = ',lev_histmth 
+  write(lunout,*)' lev_histins = ',lev_histins
+  write(lunout,*)' lev_histLES = ',lev_histLES
+  write(lunout,*)' lev_histdayNMC = ',lev_histdayNMC
+  write(lunout,*)' ok_histNMC = ',ok_histNMC
+  write(lunout,*)' freq_outNMC = ',freq_outNMC
+  write(lunout,*)' freq_calNMC = ',freq_calNMC
+  write(lunout,*)' iflag_pbl = ', iflag_pbl
+  write(lunout,*)' iflag_thermals = ', iflag_thermals
+  write(lunout,*)' iflag_thermals_ed = ', iflag_thermals_ed
+  write(lunout,*)' iflag_thermals_optflux = ', iflag_thermals_optflux
+  write(lunout,*)' iflag_clos = ', iflag_clos
+  write(lunout,*)' type_run = ',type_run 
+  write(lunout,*)' ok_isccp = ',ok_isccp 
+  write(lunout,*)' ok_cosp = ',ok_cosp
+  write(lunout,*)' ok_mensuelCOSP = ',ok_mensuelCOSP
+  write(lunout,*)' ok_journeCOSP = ',ok_journeCOSP
+  write(lunout,*)' ok_hfCOSP =',ok_hfCOSP
+  write(lunout,*)' solarlong0 = ', solarlong0
+  write(lunout,*)' qsol0 = ', qsol0
+  write(lunout,*)' inertie_sol = ', inertie_sol
+  write(lunout,*)' inertie_ice = ', inertie_ice
+  write(lunout,*)' inertie_sno = ', inertie_sno
+  write(lunout,*)' f_cdrag_ter = ',f_cdrag_ter
+  write(lunout,*)' f_cdrag_oce = ',f_cdrag_oce
+  write(lunout,*)' f_rugoro = ',f_rugoro
+  write(lunout,*)' supcrit1 = ', supcrit1
+  write(lunout,*)' supcrit2 = ', supcrit2
+  write(lunout,*)' iflag_mix = ', iflag_mix
+  write(lunout,*)' scut = ', scut
+  write(lunout,*)' qqa1 = ', qqa1
+  write(lunout,*)' qqa2 = ', qqa2
+  write(lunout,*)' gammas = ', gammas
+  write(lunout,*)' Fmax = ', Fmax
+  write(lunout,*)' alphas = ', alphas
+  write(lunout,*)' iflag_wake = ', iflag_wake
+  write(lunout,*)' alp_offset = ', alp_offset
+!!! nrlmd le 10/04/2012
+  write(lunout,*)' iflag_trig_bl = ', iflag_trig_bl
+  write(lunout,*)' s_trig = ', s_trig
+  write(lunout,*)' tau_trig_shallow = ', tau_trig_shallow
+  write(lunout,*)' tau_trig_deep = ', tau_trig_deep
+  write(lunout,*)' iflag_clos_bl = ', iflag_clos_bl
+!!! fin nrlmd le 10/04/2012
+
+  write(lunout,*)' lonmin lonmax latmin latmax bilKP_ins =',&
+   lonmin_ins, lonmax_ins, latmin_ins, latmax_ins
+  write(lunout,*)' ecrit_ hf, ins, day, mth, reg, tra, ISCCP, LES',&
+   ecrit_hf, ecrit_ins, ecrit_day, ecrit_mth, ecrit_reg, ecrit_tra, ecrit_ISCCP, ecrit_LES
+
+  write(lunout,*) 'ok_strato = ', ok_strato
+  write(lunout,*) 'ok_hines = ',  ok_hines
+  write(lunout,*) 'read_climoz = ', read_climoz
+  write(lunout,*) 'carbon_cycle_tr = ', carbon_cycle_tr
+  write(lunout,*) 'carbon_cycle_cpl = ', carbon_cycle_cpl
+  
+!$OMP END MASTER
+
+  return
+  
+  end subroutine conf_phys
+
+end module conf_phys_m
+!
+!#################################################################
+!
+
+   subroutine conf_interface(tau_calv)
+
+   use IOIPSL
+   implicit none
+   include "iniprint.h"
+! Configuration de l'interace atm/surf
+!
+! tau_calv:    temps de relaxation pour la fonte des glaciers
+
+  REAL          :: tau_calv
+  REAL,SAVE     :: tau_calv_omp
+
+!
+!Config Key  = tau_calv
+!Config Desc = temps de relaxation pour fonte des glaciers en jours
+!Config Def  = 1 an 
+!Config Help = 
+!
+  tau_calv_omp = 360.*10.
+!$OMP MASTER
+  call getin('tau_calv',tau_calv_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+
+  tau_calv=tau_calv_omp
+  
+!$OMP MASTER
+  write(lunout,*)' ##############################################'
+  WRITE(lunout,*)' Configuration de l''interface atm/surfaces  : '
+  WRITE(lunout,*)' tau_calv = ',tau_calv
+!$OMP END MASTER
+
+  return
+
+  end subroutine conf_interface
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/conflx.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/conflx.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/conflx.F	(revision 17)
@@ -0,0 +1,1676 @@
+!
+! $Header$
+!
+      SUBROUTINE conflx (dtime,pres_h,pres_f,
+     e                   t, q, con_t, con_q, pqhfl, w,
+     s                   d_t, d_q, rain, snow,
+     s                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     s                   kcbot, kctop, kdtop, pmflxr, pmflxs)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19941014
+c Objet: Schema flux de masse pour la convection 
+c        (schema de Tiedtke avec qqs modifications mineures)
+c Dec.97: Prise en compte des modifications introduites par
+c         Olivier Boucher et Alexandre Armengaud pour melange
+c         et lessivage des traceurs passifs.
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+c Entree:
+      REAL dtime            ! pas d'integration (s)
+      REAL pres_h(klon,klev+1) ! pression half-level (Pa)
+      REAL pres_f(klon,klev)! pression full-level (Pa)
+      REAL t(klon,klev)     ! temperature (K)
+      REAL q(klon,klev)     ! humidite specifique (g/g)
+      REAL w(klon,klev)     ! vitesse verticale (Pa/s)
+      REAL con_t(klon,klev) ! convergence de temperature (K/s)
+      REAL con_q(klon,klev) ! convergence de l'eau vapeur (g/g/s)
+      REAL pqhfl(klon)      ! evaporation (negative vers haut) mm/s
+c Sortie:
+      REAL d_t(klon,klev)   ! incrementation de temperature
+      REAL d_q(klon,klev)   ! incrementation d'humidite
+      REAL pmfu(klon,klev)  ! flux masse (kg/m2/s) panache ascendant
+      REAL pmfd(klon,klev)  ! flux masse (kg/m2/s) panache descendant
+      REAL pen_u(klon,klev)
+      REAL pen_d(klon,klev)
+      REAL pde_u(klon,klev)
+      REAL pde_d(klon,klev)
+      REAL rain(klon)       ! pluie (mm/s)
+      REAL snow(klon)       ! neige (mm/s)
+      REAL pmflxr(klon,klev+1)
+      REAL pmflxs(klon,klev+1)
+      INTEGER kcbot(klon)  ! niveau du bas de la convection
+      INTEGER kctop(klon)  ! niveau du haut de la convection
+      INTEGER kdtop(klon)  ! niveau du haut des downdrafts
+c Local:
+      REAL pt(klon,klev)
+      REAL pq(klon,klev)
+      REAL pqs(klon,klev)
+      REAL pvervel(klon,klev)
+      LOGICAL land(klon)
+c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL paprs(klon,klev+1)
+      REAL paprsf(klon,klev)
+      REAL zgeom(klon,klev)
+      REAL zcvgq(klon,klev)
+      REAL zcvgt(klon,klev)
+cAA
+      REAL zmfu(klon,klev) 
+      REAL zmfd(klon,klev)
+      REAL zen_u(klon,klev)
+      REAL zen_d(klon,klev)
+      REAL zde_u(klon,klev)
+      REAL zde_d(klon,klev)
+      REAL zmflxr(klon,klev+1)
+      REAL zmflxs(klon,klev+1)
+cAA
+
+c
+      INTEGER i, k
+      REAL zdelta, zqsat
+c
+#include "FCTTRE.h"
+c
+c initialiser les variables de sortie (pour securite)
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         kcbot(i) = 0
+         kctop(i) = 0
+         kdtop(i) = 0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         pmfu(i,k) = 0.0
+         pmfd(i,k) = 0.0
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         pen_d(i,k) = 0.0
+         pde_d(i,k) = 0.0
+         zmfu(i,k) = 0.0
+         zmfd(i,k) = 0.0
+         zen_u(i,k) = 0.0
+         zde_u(i,k) = 0.0
+         zen_d(i,k) = 0.0
+         zde_d(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         zmflxr(i,k) = 0.0
+         zmflxs(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+c calculer la nature du sol (pour l'instant, ocean partout)
+      DO i = 1, klon
+         land(i) = .FALSE.
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1)
+         pq(i,k) = q(i,klev-k+1)
+         paprsf(i,k) = pres_f(i,klev-k+1)
+         paprs(i,k) = pres_h(i,klev+1-k+1)
+         pvervel(i,k) = w(i,klev+1-k)
+         zcvgt(i,k) = con_t(i,klev-k+1)
+         zcvgq(i,k) = con_q(i,klev-k+1)
+c
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i,k)))
+         zqsat=R2ES*FOEEW ( pt(i,k), zdelta ) / paprsf(i,k)
+         zqsat=MIN(0.5,zqsat)
+         zqsat=zqsat/(1.-RETV  *zqsat)
+         pqs(i,k) = zqsat
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         paprs(i,klev+1) = pres_h(i,1)
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                   / (0.5*(paprs(i,klev+1)+paprsf(i,klev)))
+     .                   * (paprs(i,klev+1)-paprsf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1)
+     .              + RD * 0.5*(pt(i,k+1)+pt(i,k)) / paprs(i,k+1)
+     .                   * (paprsf(i,k+1)-paprsf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL flxmain(dtime, pt, pq, pqs, pqhfl,
+     .             paprsf, paprs, zgeom, land, zcvgt, zcvgq, pvervel,
+     .             rain, snow, kcbot, kctop, kdtop,
+     .             zmfu, zmfd, zen_u, zde_u, zen_d, zde_d,
+     .             d_t_bis, d_q_bis, zmflxr, zmflxs)
+C
+cAA--------------------------------------------------------
+cAA rem : De la meme facon que l'on effectue le reindicage 
+cAA       pour la temperature t et le champ q 
+cAA       on reindice les flux necessaires a la convection 
+cAA       des traceurs
+cAA--------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,klev+1-k) = dtime*d_q_bis(i,k)
+         d_t(i,klev+1-k) = dtime*d_t_bis(i,k)
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         pmfu(i,1)= 0.
+         pmfd(i,1)= 0.
+         pen_d(i,1)= 0.
+         pde_d(i,1)= 0.
+      ENDDO
+     
+      DO k = 2, klev
+      DO i = 1, klon
+         pmfu(i,klev+2-k)= zmfu(i,k)
+         pmfd(i,klev+2-k)= zmfd(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pen_u(i,klev+1-k)=  zen_u(i,k)
+         pde_u(i,klev+1-k)=  zde_u(i,k)
+      ENDDO
+      ENDDO
+c
+      DO k = 1, klev-1
+      DO i = 1, klon
+         pen_d(i,klev+1-k)= -zen_d(i,k+1)
+         pde_d(i,klev+1-k)= -zde_d(i,k+1)
+      ENDDO
+      ENDDO
+
+      DO k = 1, klev+1
+      DO i = 1, klon
+         pmflxr(i,klev+2-k)= zmflxr(i,k)
+         pmflxs(i,klev+2-k)= zmflxs(i,k)
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+c--------------------------------------------------------------------
+      SUBROUTINE flxmain(pdtime, pten, pqen, pqsen, pqhfl, pap, paph,
+     .                   pgeo, ldland, ptte, pqte, pvervel,
+     .                   prsfc, pssfc, kcbot, kctop, kdtop,
+c     *                   ldcum, ktype,
+     .                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,
+     .                   dt_con, dq_con, pmflxr, pmflxs)
+      USE dimphy
+      IMPLICIT none
+C     ------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C     ----------------------------------------------------------------
+      REAL pten(klon,klev), pqen(klon,klev), pqsen(klon,klev)
+      REAL ptte(klon,klev)
+      REAL pqte(klon,klev)
+      REAL pvervel(klon,klev)
+      REAL pgeo(klon,klev), pap(klon,klev), paph(klon,klev+1)
+      REAL pqhfl(klon)
+c
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      REAL plude(klon,klev)
+      REAL pmfu(klon,klev)
+      REAL prsfc(klon), pssfc(klon)
+      INTEGER  kcbot(klon), kctop(klon), ktype(klon)
+      LOGICAL  ldland(klon), ldcum(klon)
+c
+      REAL ztenh(klon,klev), zqenh(klon,klev), zqsenh(klon,klev)
+      REAL zgeoh(klon,klev)
+      REAL zmfub(klon), zmfub1(klon)
+      REAL zmfus(klon,klev), zmfuq(klon,klev), zmful(klon,klev)
+      REAL zdmfup(klon,klev), zdpmel(klon,klev)
+      REAL zentr(klon), zhcbase(klon)
+      REAL zdqpbl(klon), zdqcv(klon), zdhpbl(klon)
+      REAL zrfl(klon)
+      REAL pmflxr(klon,klev+1)
+      REAL pmflxs(klon,klev+1)
+      INTEGER  ilab(klon,klev), ictop0(klon)
+      LOGICAL  llo1
+      REAL dt_con(klon,klev), dq_con(klon,klev)
+      REAL zmfmax, zdh
+      REAL pdtime, zqumqe, zdqmin, zalvdcp, zhsat, zzz
+      REAL zhhat, zpbmpt, zgam, zeps, zfac
+      INTEGER i, k, ikb, itopm2, kcum
+c
+      REAL pen_u(klon,klev), pde_u(klon,klev)
+      REAL pen_d(klon,klev), pde_d(klon,klev)
+c
+      REAL ptd(klon,klev), pqd(klon,klev), pmfd(klon,klev)
+      REAL zmfds(klon,klev), zmfdq(klon,klev), zdmfdp(klon,klev)
+      INTEGER kdtop(klon)
+      LOGICAL lddraf(klon)
+C---------------------------------------------------------------------
+      LOGICAL firstcal
+      SAVE firstcal
+      DATA firstcal / .TRUE. /
+c$OMP THREADPRIVATE(firstcal)
+C---------------------------------------------------------------------
+      IF (firstcal) THEN
+         CALL flxsetup
+         firstcal = .FALSE.
+      ENDIF
+C---------------------------------------------------------------------
+      DO i = 1, klon
+         ldcum(i) = .FALSE.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         dt_con(i,k) = 0.0
+         dq_con(i,k) = 0.0
+      ENDDO
+      ENDDO
+c----------------------------------------------------------------------
+c initialiser les variables et faire l'interpolation verticale
+c----------------------------------------------------------------------
+      CALL flxini(pten, pqen, pqsen, pgeo,
+     .     paph, zgeoh, ztenh, zqenh, zqsenh,
+     .     ptu, pqu, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp,
+     .     pmfu, zmfus, zmfuq, zdmfup,
+     .     zdpmel, plu, plude, ilab, pen_u, pde_u, pen_d, pde_d)
+c---------------------------------------------------------------------
+c determiner les valeurs au niveau de base de la tour convective
+c---------------------------------------------------------------------
+      CALL flxbase(ztenh, zqenh, zgeoh, paph,
+     *            ptu, pqu, plu, ldcum, kcbot, ilab)
+c---------------------------------------------------------------------
+c calculer la convergence totale de l'humidite et celle en provenance
+c de la couche limite, plus precisement, la convergence integree entre
+c le sol et la base de la convection. Cette derniere convergence est
+c comparee avec l'evaporation obtenue dans la couche limite pour
+c determiner le type de la convection
+c---------------------------------------------------------------------
+      k=1
+      DO i = 1, klon
+         zdqcv(i) = pqte(i,k)*(paph(i,k+1)-paph(i,k))
+         zdhpbl(i) = 0.0
+         zdqpbl(i) = 0.0
+      ENDDO
+c
+      DO k=2,klev
+      DO i = 1, klon
+          zdqcv(i)=zdqcv(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k))
+          IF (k.GE.kcbot(i)) THEN
+             zdqpbl(i)=zdqpbl(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k))
+             zdhpbl(i)=zdhpbl(i)+(RCPD*ptte(i,k)+RLVTT*pqte(i,k))
+     .                          *(paph(i,k+1)-paph(i,k))
+          ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         ktype(i) = 2
+         if (zdqcv(i).GT.MAX(0.,-1.5*pqhfl(i)*RG)) ktype(i) = 1
+ccc         if (zdqcv(i).GT.MAX(0.,-1.1*pqhfl(i)*RG)) ktype(i) = 1
+      ENDDO
+c
+c---------------------------------------------------------------------
+c determiner le flux de masse entrant a travers la base.
+c on ignore, pour l'instant, l'effet du panache descendant
+c---------------------------------------------------------------------
+      DO i = 1, klon
+         ikb=kcbot(i)
+         zqumqe=pqu(i,ikb)+plu(i,ikb)-zqenh(i,ikb)
+         zdqmin=MAX(0.01*zqenh(i,ikb),1.E-10)
+         IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)) THEN
+            zmfub(i) = zdqpbl(i)/(RG*MAX(zqumqe,zdqmin))
+         ELSE
+            zmfub(i) = 0.01
+            ldcum(i)=.FALSE.
+         ENDIF
+         IF (ktype(i).EQ.2) THEN
+            zdh = RCPD*(ptu(i,ikb)-ztenh(i,ikb)) + RLVTT*zqumqe
+            zdh = RG * MAX(zdh,1.0E5*zdqmin)
+            IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub(i)=zdhpbl(i)/zdh
+         ENDIF
+         zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime)
+         zmfub(i) = MIN(zmfub(i),zmfmax)
+         zentr(i) = ENTRSCV
+         IF (ktype(i).EQ.1) zentr(i) = ENTRPEN
+      ENDDO
+C-----------------------------------------------------------------------
+C DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME
+C-----------------------------------------------------------------------
+c (A) calculer d'abord la hauteur "theorique" de la tour convective sans
+c     considerer l'entrainement ni le detrainement du panache, sachant
+c     ces derniers peuvent abaisser la hauteur theorique.
+c
+      DO i = 1, klon
+         ikb=kcbot(i)
+         zhcbase(i)=RCPD*ptu(i,ikb)+zgeoh(i,ikb)+RLVTT*pqu(i,ikb)
+         ictop0(i)=kcbot(i)-1
+      ENDDO
+c
+      zalvdcp=RLVTT/RCPD
+      DO k=klev-1,3,-1
+      DO i = 1, klon
+         zhsat=RCPD*ztenh(i,k)+zgeoh(i,k)+RLVTT*zqsenh(i,k)
+         zgam=R5LES*zalvdcp*zqsenh(i,k)/
+     .        ((1.-RETV  *zqsenh(i,k))*(ztenh(i,k)-R4LES)**2)
+         zzz=RCPD*ztenh(i,k)*0.608
+         zhhat=zhsat-(zzz+zgam*zzz)/(1.+zgam*zzz/RLVTT)*
+     .               MAX(zqsenh(i,k)-zqenh(i,k),0.)
+         IF(k.LT.ictop0(i).AND.zhcbase(i).GT.zhhat) ictop0(i)=k
+      ENDDO
+      ENDDO
+c
+c (B) calculer le panache ascendant
+c
+      CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen,
+     .     pgeo, zgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, ilab,
+     .     ptu, pqu, plu, pmfu, zmfub, zentr,
+     .     zmfus, zmfuq, zmful, plude, zdmfup,
+     .     kcbot, kctop, ictop0, kcum, pen_u, pde_u)
+      IF (kcum.EQ.0) GO TO 1000
+C
+C verifier l'epaisseur de la convection et changer eventuellement
+c le taux d'entrainement/detrainement
+C
+      DO i = 1, klon
+         zpbmpt=paph(i,kcbot(i))-paph(i,kctop(i))
+         IF(ldcum(i).AND.ktype(i).EQ.1.AND.zpbmpt.LT.2.E4)ktype(i)=2
+         IF(ldcum(i)) ictop0(i)=kctop(i)
+         IF(ktype(i).EQ.2) zentr(i)=ENTRSCV
+      ENDDO
+c
+      IF (lmfdd) THEN  ! si l'on considere le panache descendant
+c
+c calculer la precipitation issue du panache ascendant pour 
+c determiner l'existence du panache descendant dans la convection
+      DO i = 1, klon
+         zrfl(i)=zdmfup(i,1)
+      ENDDO
+      DO k=2,klev
+      DO i = 1, klon
+         zrfl(i)=zrfl(i)+zdmfup(i,k)
+      ENDDO
+      ENDDO
+c
+c determiner le LFS (level of free sinking: niveau de plonge libre)
+      CALL flxdlfs(ztenh, zqenh, zgeoh, paph, ptu, pqu,
+     *     ldcum,    kcbot,    kctop,    zmfub,    zrfl,
+     *     ptd,      pqd,
+     *     pmfd,     zmfds,    zmfdq,    zdmfdp,
+     *     kdtop,    lddraf)
+c
+c calculer le panache descendant
+      CALL flxddraf(ztenh,    zqenh,
+     *     zgeoh,    paph,     zrfl,
+     *     ptd,      pqd,
+     *     pmfd,     zmfds,    zmfdq,    zdmfdp,
+     *     lddraf, pen_d, pde_d)
+c
+c calculer de nouveau le flux de masse entrant a travers la base
+c de la convection, sachant qu'il a ete modifie par le panache
+c descendant
+      DO i = 1, klon
+      IF (lddraf(i)) THEN
+         ikb = kcbot(i)
+         llo1 = PMFD(i,ikb).LT.0.
+         zeps = 0.
+         IF ( llo1 ) zeps = CMFDEPS
+         zqumqe = pqu(i,ikb)+plu(i,ikb)-
+     .            zeps*pqd(i,ikb)-(1.-zeps)*zqenh(i,ikb)
+         zdqmin = MAX(0.01*zqenh(i,ikb),1.E-10)
+         zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime)
+         IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)
+     .       .AND.zmfub(i).LT.zmfmax) THEN
+            zmfub1(i) = zdqpbl(i) / (RG*MAX(zqumqe,zdqmin))
+         ELSE
+            zmfub1(i) = zmfub(i)
+         ENDIF
+         IF (ktype(i).EQ.2) THEN
+            zdh = RCPD*(ptu(i,ikb)-zeps*ptd(i,ikb)-
+     .            (1.-zeps)*ztenh(i,ikb))+RLVTT*zqumqe
+            zdh = RG * MAX(zdh,1.0E5*zdqmin)
+            IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub1(i)=zdhpbl(i)/zdh
+         ENDIF
+         IF ( .NOT.((ktype(i).EQ.1.OR.ktype(i).EQ.2).AND.
+     .              ABS(zmfub1(i)-zmfub(i)).LT.0.2*zmfub(i)) )
+     .      zmfub1(i) = zmfub(i)
+      ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (lddraf(i)) THEN
+         zfac = zmfub1(i)/MAX(zmfub(i),1.E-10)
+         pmfd(i,k) = pmfd(i,k)*zfac
+         zmfds(i,k) = zmfds(i,k)*zfac
+         zmfdq(i,k) = zmfdq(i,k)*zfac
+         zdmfdp(i,k) = zdmfdp(i,k)*zfac
+         pen_d(i,k) = pen_d(i,k)*zfac
+         pde_d(i,k) = pde_d(i,k)*zfac
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         IF (lddraf(i)) zmfub(i)=zmfub1(i)
+      ENDDO
+c
+      ENDIF   ! fin de test sur lmfdd
+c
+c-----------------------------------------------------------------------
+c calculer de nouveau le panache ascendant
+c-----------------------------------------------------------------------
+      CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen,
+     .     pgeo, zgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, ilab,
+     .     ptu, pqu, plu, pmfu, zmfub, zentr,
+     .     zmfus, zmfuq, zmful, plude, zdmfup,
+     .     kcbot, kctop, ictop0, kcum, pen_u, pde_u)
+c
+c-----------------------------------------------------------------------
+c determiner les flux convectifs en forme finale, ainsi que
+c la quantite des precipitations
+c-----------------------------------------------------------------------
+      CALL flxflux(pdtime, pqen, pqsen, ztenh, zqenh, pap, paph, 
+     .     ldland, zgeoh, kcbot, kctop, lddraf, kdtop, ktype, ldcum,
+     .     pmfu, pmfd, zmfus, zmfds, zmfuq, zmfdq, zmful, plude,
+     .     zdmfup, zdmfdp, pten, prsfc, pssfc, zdpmel, itopm2,
+     .     pmflxr, pmflxs)
+c
+c----------------------------------------------------------------------
+c calculer les tendances pour T et Q
+c----------------------------------------------------------------------
+      CALL flxdtdq(pdtime, itopm2, paph, ldcum, pten,
+     e     zmfus, zmfds, zmfuq, zmfdq, zmful, zdmfup, zdmfdp, zdpmel,
+     s     dt_con,dq_con)
+c
+ 1000 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxini(pten, pqen, pqsen, pgeo, paph, pgeoh, ptenh,
+     .           pqenh, pqsenh, ptu, pqu, ptd, pqd, pmfd, pmfds, pmfdq,
+     .           pdmfdp, pmfu, pmfus, pmfuq, pdmfup, pdpmel, plu, plude,
+     .           klab,pen_u, pde_u, pen_d, pde_d)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC.
+C TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME),
+C AND INITIALIZES VALUES FOR UPDRAFTS
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+      REAL pten(klon,klev)   ! temperature (environnement)
+      REAL pqen(klon,klev)   ! humidite (environnement)
+      REAL pqsen(klon,klev)  ! humidite saturante (environnement)
+      REAL pgeo(klon,klev)   ! geopotentiel (g * metre)
+      REAL pgeoh(klon,klev)  ! geopotentiel aux demi-niveaux
+      REAL paph(klon,klev+1) ! pression aux demi-niveaux
+      REAL ptenh(klon,klev)  ! temperature aux demi-niveaux
+      REAL pqenh(klon,klev)  ! humidite aux demi-niveaux
+      REAL pqsenh(klon,klev) ! humidite saturante aux demi-niveaux
+C
+      REAL ptu(klon,klev)    ! temperature du panache ascendant (p-a)
+      REAL pqu(klon,klev)    ! humidite du p-a
+      REAL plu(klon,klev)    ! eau liquide du p-a
+      REAL pmfu(klon,klev)   ! flux de masse du p-a
+      REAL pmfus(klon,klev)  ! flux de l'energie seche dans le p-a
+      REAL pmfuq(klon,klev)  ! flux de l'humidite dans le p-a
+      REAL pdmfup(klon,klev) ! quantite de l'eau precipitee dans p-a
+      REAL plude(klon,klev)  ! quantite de l'eau liquide jetee du
+c                              p-a a l'environnement
+      REAL pdpmel(klon,klev) ! quantite de neige fondue
+c
+      REAL ptd(klon,klev)    ! temperature du panache descendant (p-d)
+      REAL pqd(klon,klev)    ! humidite du p-d
+      REAL pmfd(klon,klev)   ! flux de masse du p-d
+      REAL pmfds(klon,klev)  ! flux de l'energie seche dans le p-d
+      REAL pmfdq(klon,klev)  ! flux de l'humidite dans le p-d
+      REAL pdmfdp(klon,klev) ! quantite de precipitation dans p-d
+c
+      REAL pen_u(klon,klev) ! quantite de masse entrainee pour p-a
+      REAL pde_u(klon,klev) ! quantite de masse detrainee pour p-a
+      REAL pen_d(klon,klev) ! quantite de masse entrainee pour p-d
+      REAL pde_d(klon,klev) ! quantite de masse detrainee pour p-d
+C
+      INTEGER  klab(klon,klev)
+      LOGICAL  llflag(klon)
+      INTEGER k, i, icall
+      REAL zzs
+C----------------------------------------------------------------------
+C SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS
+C ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE
+C----------------------------------------------------------------------
+      DO 130 k = 2, klev
+c
+      DO i = 1, klon
+         pgeoh(i,k)=pgeo(i,k)+(pgeo(i,k-1)-pgeo(i,k))*0.5
+         ptenh(i,k)=(MAX(RCPD*pten(i,k-1)+pgeo(i,k-1),
+     .             RCPD*pten(i,k)+pgeo(i,k))-pgeoh(i,k))/RCPD
+         pqsenh(i,k)=pqsen(i,k-1)
+         llflag(i)=.TRUE.
+      ENDDO
+c
+      icall=0
+      CALL flxadjtq(paph(1,k),ptenh(1,k),pqsenh(1,k),llflag,icall)
+c
+      DO i = 1, klon
+         pqenh(i,k)=MIN(pqen(i,k-1),pqsen(i,k-1))
+     .               +(pqsenh(i,k)-pqsen(i,k-1))
+         pqenh(i,k)=MAX(pqenh(i,k),0.)
+      ENDDO
+c
+  130 CONTINUE
+C
+      DO 140 i = 1, klon
+         ptenh(i,klev)=(RCPD*pten(i,klev)+pgeo(i,klev)-
+     1                   pgeoh(i,klev))/RCPD
+         pqenh(i,klev)=pqen(i,klev)
+         ptenh(i,1)=pten(i,1)
+         pqenh(i,1)=pqen(i,1)
+         pgeoh(i,1)=pgeo(i,1)
+  140 CONTINUE
+c
+      DO 160 k = klev-1, 2, -1
+      DO 150 i = 1, klon
+         zzs = MAX(RCPD*ptenh(i,k)+pgeoh(i,k),
+     .             RCPD*ptenh(i,k+1)+pgeoh(i,k+1))
+         ptenh(i,k) = (zzs-pgeoh(i,k))/RCPD
+  150 CONTINUE
+  160 CONTINUE
+C
+C-----------------------------------------------------------------------
+C INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS
+C-----------------------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         ptu(i,k) = ptenh(i,k)
+         pqu(i,k) = pqenh(i,k)
+         plu(i,k) = 0.
+         pmfu(i,k) = 0.
+         pmfus(i,k) = 0.
+         pmfuq(i,k) = 0.
+         pdmfup(i,k) = 0.
+         pdpmel(i,k) = 0.
+         plude(i,k) = 0.
+c
+         klab(i,k) = 0
+c
+         ptd(i,k) = ptenh(i,k)
+         pqd(i,k) = pqenh(i,k)
+         pmfd(i,k) = 0.0
+         pmfds(i,k) = 0.0
+         pmfdq(i,k) = 0.0
+         pdmfdp(i,k) = 0.0
+c
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         pen_d(i,k) = 0.0
+         pde_d(i,k) = 0.0
+      ENDDO
+      ENDDO
+C
+      RETURN
+      END
+      SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph,
+     *     ptu, pqu, plu, ldcum, kcbot, klab)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
+C
+C INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
+C IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
+C   klab=1 FOR SUBCLOUD LEVELS
+C   klab=2 FOR CONDENSATION LEVEL
+C
+C LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
+C (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C       ----------------------------------------------------------------
+      REAL ptenh(klon,klev), pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+C
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      INTEGER  klab(klon,klev), kcbot(klon)
+C
+      LOGICAL llflag(klon), ldcum(klon)
+      INTEGER i, k, icall, is
+      REAL zbuo, zqold(klon)
+C----------------------------------------------------------------------
+C INITIALIZE VALUES AT LIFTING LEVEL
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         klab(i,klev)=1
+         kcbot(i)=klev-1
+         ldcum(i)=.FALSE.
+      ENDDO
+C----------------------------------------------------------------------
+C DO ASCENT IN SUBCLOUD LAYER,
+C CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
+C ADJUST T,Q AND L ACCORDINGLY
+C CHECK FOR BUOYANCY AND SET FLAGS
+C----------------------------------------------------------------------
+      DO 290 k = klev-1, 2, -1
+c
+      is = 0
+      DO i = 1, klon
+         IF (klab(i,k+1).EQ.1) is = is + 1
+         llflag(i) = .FALSE.
+         IF (klab(i,k+1).EQ.1) llflag(i) = .TRUE.
+      ENDDO
+      IF (is.EQ.0) GOTO 290
+c
+      DO i = 1, klon
+      IF(llflag(i)) THEN
+         pqu(i,k) = pqu(i,k+1)
+         ptu(i,k) = ptu(i,k+1)+(pgeoh(i,k+1)-pgeoh(i,k))/RCPD
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
+         IF (zbuo.GT.0.) klab(i,k) = 1
+         zqold(i) = pqu(i,k)
+      ENDIF
+      ENDDO
+c
+      icall=1
+      CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+c
+      DO i = 1, klon
+      IF (llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         plu(i,k) = plu(i,k) + zqold(i)-pqu(i,k)
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
+         IF (zbuo.GT.0.) kcbot(i) = k
+         IF (zbuo.GT.0.) ldcum(i) = .TRUE.
+      ENDIF
+      ENDDO
+c
+  290 CONTINUE
+c
+      RETURN
+      END
+      SUBROUTINE flxasc(pdtime, ptenh, pqenh, pten, pqen, pqsen,
+     .     pgeo, pgeoh, pap, paph, pqte, pvervel,
+     .     ldland, ldcum, ktype, klab, ptu, pqu, plu,
+     .     pmfu, pmfub, pentr, pmfus, pmfuq,
+     .     pmful, plude, pdmfup, kcbot, kctop, kctop0, kcum,
+     .     pen_u, pde_u)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS
+C FOR CUMULUS PARAMETERIZATION
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL pdtime
+      REAL pten(klon,klev), ptenh(klon,klev)
+      REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev)
+      REAL pgeo(klon,klev), pgeoh(klon,klev)
+      REAL pap(klon,klev), paph(klon,klev+1)
+      REAL pqte(klon,klev)
+      REAL pvervel(klon,klev) ! vitesse verticale en Pa/s
+C
+      REAL pmfub(klon), pentr(klon)
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      REAL plude(klon,klev)
+      REAL pmfu(klon,klev), pmfus(klon,klev)
+      REAL pmfuq(klon,klev), pmful(klon,klev)
+      REAL pdmfup(klon,klev)
+      INTEGER ktype(klon), klab(klon,klev), kcbot(klon), kctop(klon)
+      INTEGER kctop0(klon)
+      LOGICAL ldland(klon), ldcum(klon)
+C
+      REAL pen_u(klon,klev), pde_u(klon,klev)
+      REAL zqold(klon)
+      REAL zdland(klon)
+      LOGICAL llflag(klon)
+      INTEGER k, i, is, icall, kcum
+      REAL ztglace, zdphi, zqeen, zseen, zscde, zqude
+      REAL zmfusk, zmfuqk, zmfulk, zbuo, zdnoprc, zprcon, zlnew
+c
+      REAL zpbot(klon), zptop(klon), zrho(klon)
+      REAL zdprho, zentr, zpmid, zmftest, zmfmax
+      LOGICAL llo1, llo2
+c
+      REAL zwmax(klon), zzzmb
+      INTEGER klwmin(klon) ! level of maximum vertical velocity
+C----------------------------------------------------------------------
+      ztglace = RTT - 13.
+c
+c Chercher le niveau ou la vitesse verticale est maximale:
+      DO i = 1, klon
+         klwmin(i) = klev
+         zwmax(i) = 0.0
+      ENDDO
+      DO k = klev, 3, -1
+      DO i = 1, klon
+      IF (pvervel(i,k).LT.zwmax(i)) THEN
+         zwmax(i) = pvervel(i,k)
+         klwmin(i) = k
+      ENDIF
+      ENDDO
+      ENDDO
+C----------------------------------------------------------------------
+C SET DEFAULT VALUES
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         IF (.NOT.ldcum(i)) ktype(i)=0
+      ENDDO
+c
+      DO k=1,klev
+      DO i = 1, klon
+         plu(i,k)=0.
+         pmfu(i,k)=0.
+         pmfus(i,k)=0.
+         pmfuq(i,k)=0.
+         pmful(i,k)=0.
+         plude(i,k)=0.
+         pdmfup(i,k)=0.
+         IF(.NOT.ldcum(i).OR.ktype(i).EQ.3) klab(i,k)=0
+         IF(.NOT.ldcum(i).AND.paph(i,k).LT.4.E4) kctop0(i)=k
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+      IF (ldland(i)) THEN
+         zdland(i)=3.0E4
+         zdphi=pgeoh(i,kctop0(i))-pgeoh(i,kcbot(i))
+         IF (ptu(i,kctop0(i)).GE.ztglace) zdland(i)=zdphi
+         zdland(i)=MAX(3.0E4,zdland(i))
+         zdland(i)=MIN(5.0E4,zdland(i))
+      ENDIF
+      ENDDO
+C
+C Initialiser les valeurs au niveau d'ascendance
+C
+      DO i = 1, klon
+         kctop(i) = klev-1
+         IF (.NOT.ldcum(i)) THEN
+            kcbot(i) = klev-1
+            pmfub(i) = 0.
+            pqu(i,klev) = 0.
+         ENDIF
+         pmfu(i,klev) = pmfub(i)
+         pmfus(i,klev) = pmfub(i)*(RCPD*ptu(i,klev)+pgeoh(i,klev))
+         pmfuq(i,klev) = pmfub(i)*pqu(i,klev)
+      ENDDO
+c
+      DO i = 1, klon
+         ldcum(i) = .FALSE.
+      ENDDO
+C----------------------------------------------------------------------
+C  DO ASCENT: SUBCLOUD LAYER (klab=1) ,CLOUDS (klab=2)
+C  BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN
+C  BY ADJUSTING T,Q AND L ACCORDINGLY IN *flxadjtq*,
+C  THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY
+C----------------------------------------------------------------------
+      DO 480 k = klev-1,3,-1
+c
+      IF (LMFMID .AND. k.LT.klev-1 .AND. k.GT.klev/2) THEN
+         DO i = 1, klon
+         IF (.NOT.ldcum(i) .AND. klab(i,k+1).EQ.0 .AND.
+     .       pqen(i,k).GT.0.9*pqsen(i,k)) THEN
+            ptu(i,k+1) = pten(i,k) +(pgeo(i,k)-pgeoh(i,k+1))/RCPD
+            pqu(i,k+1) = pqen(i,k)
+            plu(i,k+1) = 0.0
+            zzzmb = MAX(CMFCMIN, -pvervel(i,k)/RG)
+            zmfmax = (paph(i,k)-paph(i,k-1))/(RG*pdtime)
+            pmfub(i) = MIN(zzzmb,zmfmax)
+            pmfu(i,k+1) = pmfub(i)
+            pmfus(i,k+1) = pmfub(i)*(RCPD*ptu(i,k+1)+pgeoh(i,k+1))
+            pmfuq(i,k+1) = pmfub(i)*pqu(i,k+1)
+            pmful(i,k+1) = 0.0
+            pdmfup(i,k+1) = 0.0
+            kcbot(i) = k
+            klab(i,k+1) = 1
+            ktype(i) = 3
+            pentr(i) = ENTRMID
+         ENDIF
+         ENDDO
+      ENDIF
+c
+      is = 0
+      DO i = 1, klon
+         is = is + klab(i,k+1)
+         IF (klab(i,k+1) .EQ. 0) klab(i,k) = 0
+         llflag(i) = .FALSE.
+         IF (klab(i,k+1) .GT. 0) llflag(i) = .TRUE.
+      ENDDO
+      IF (is .EQ. 0) GOTO 480
+c
+c calculer le taux d'entrainement et de detrainement
+c
+      DO i = 1, klon
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         zrho(i)=paph(i,k+1)/(RD*ptenh(i,k+1))
+         zpbot(i)=paph(i,kcbot(i))
+         zptop(i)=paph(i,kctop0(i))
+      ENDDO
+c
+      DO 125 i = 1, klon
+      IF(ldcum(i)) THEN
+         zdprho=(paph(i,k+1)-paph(i,k))/(RG*zrho(i))
+         zentr=pentr(i)*pmfu(i,k+1)*zdprho
+         llo1=k.LT.kcbot(i)
+         IF(llo1) pde_u(i,k)=zentr
+         zpmid=0.5*(zpbot(i)+zptop(i))
+         llo2=llo1.AND.ktype(i).EQ.2.AND.
+     .        (zpbot(i)-paph(i,k).LT.0.2E5.OR.
+     .         paph(i,k).GT.zpmid)
+         IF(llo2) pen_u(i,k)=zentr
+         llo2=llo1.AND.(ktype(i).EQ.1.OR.ktype(i).EQ.3).AND.
+     .        (k.GE.MAX(klwmin(i),kctop0(i)+2).OR.pap(i,k).GT.zpmid)
+         IF(llo2) pen_u(i,k)=zentr
+         llo1=pen_u(i,k).GT.0..AND.(ktype(i).EQ.1.OR.ktype(i).EQ.2)
+         IF(llo1) THEN
+            zentr=zentr*(1.+3.*(1.-MIN(1.,(zpbot(i)-pap(i,k))/1.5E4)))
+            pen_u(i,k)=pen_u(i,k)*(1.+3.*(1.-MIN(1.,
+     .                 (zpbot(i)-pap(i,k))/1.5E4)))
+            pde_u(i,k)=pde_u(i,k)*(1.+3.*(1.-MIN(1.,
+     .                 (zpbot(i)-pap(i,k))/1.5E4)))
+         ENDIF
+         IF(llo2.AND.pqenh(i,k+1).GT.1.E-5)
+     .   pen_u(i,k)=zentr+MAX(pqte(i,k),0.)/pqenh(i,k+1)*
+     .              zrho(i)*zdprho
+      ENDIF
+  125 CONTINUE
+c
+C----------------------------------------------------------------------
+c DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME
+C----------------------------------------------------------------------
+c
+      DO 420 i = 1, klon
+      IF (llflag(i)) THEN
+         IF (k.LT.kcbot(i)) THEN
+            zmftest = pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k)
+            zmfmax = MIN(zmftest,(paph(i,k)-paph(i,k-1))/(RG*pdtime))
+            pen_u(i,k)=MAX(pen_u(i,k)-MAX(0.0,zmftest-zmfmax),0.0)
+         ENDIF
+         pde_u(i,k)=MIN(pde_u(i,k),0.75*pmfu(i,k+1))
+c calculer le flux de masse du niveau k a partir de celui du k+1
+         pmfu(i,k)=pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k)
+c calculer les valeurs Su, Qu et l du niveau k dans le panache montant
+         zqeen=pqenh(i,k+1)*pen_u(i,k)
+         zseen=(RCPD*ptenh(i,k+1)+pgeoh(i,k+1))*pen_u(i,k)
+         zscde=(RCPD*ptu(i,k+1)+pgeoh(i,k+1))*pde_u(i,k)
+         zqude=pqu(i,k+1)*pde_u(i,k)
+         plude(i,k)=plu(i,k+1)*pde_u(i,k)
+         zmfusk=pmfus(i,k+1)+zseen-zscde
+         zmfuqk=pmfuq(i,k+1)+zqeen-zqude
+         zmfulk=pmful(i,k+1)    -plude(i,k)
+         plu(i,k)=zmfulk*(1./MAX(CMFCMIN,pmfu(i,k)))
+         pqu(i,k)=zmfuqk*(1./MAX(CMFCMIN,pmfu(i,k)))
+         ptu(i,k)=(zmfusk*(1./MAX(CMFCMIN,pmfu(i,k)))-
+     1               pgeoh(i,k))/RCPD
+         ptu(i,k)=MAX(100.,ptu(i,k))
+         ptu(i,k)=MIN(400.,ptu(i,k))
+         zqold(i)=pqu(i,k)
+      ELSE
+         zqold(i)=0.0
+      ENDIF
+  420 CONTINUE
+c
+C----------------------------------------------------------------------
+c DO CORRECTIONS FOR MOIST ASCENT BY ADJUSTING T,Q AND L
+C----------------------------------------------------------------------
+c
+      icall = 1
+      CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+C
+      DO 440 i = 1, klon
+      IF(llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         plu(i,k) = plu(i,k)+zqold(i)-pqu(i,k)
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-
+     .          ptenh(i,k)*(1.+RETV*pqenh(i,k))
+         IF (klab(i,k+1).EQ.1) zbuo=zbuo+0.5
+         IF (zbuo.GT.0..AND.pmfu(i,k).GE.0.1*pmfub(i)) THEN
+            kctop(i) = k
+            ldcum(i) = .TRUE.
+            zdnoprc = 1.5E4
+            IF (ldland(i)) zdnoprc = zdland(i)
+            zprcon = CPRCON
+            IF ((zpbot(i)-paph(i,k)).LT.zdnoprc) zprcon = 0.0
+            zlnew=plu(i,k)/(1.+zprcon*(pgeoh(i,k)-pgeoh(i,k+1)))
+            pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k))
+            plu(i,k)=zlnew
+         ELSE
+            klab(i,k)=0
+            pmfu(i,k)=0.
+         ENDIF
+      ENDIF
+  440 CONTINUE
+      DO 455 i = 1, klon
+      IF (llflag(i)) THEN
+         pmful(i,k)=plu(i,k)*pmfu(i,k)
+         pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k)
+         pmfuq(i,k)=pqu(i,k)*pmfu(i,k)
+      ENDIF
+  455 CONTINUE
+C
+  480 CONTINUE
+C----------------------------------------------------------------------
+C DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
+C    (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT
+C           AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN
+C           FROM PREVIOUS CALCULATIONS ABOVE)
+C----------------------------------------------------------------------
+      DO i = 1, klon
+         IF (kctop(i).EQ.klev-1) ldcum(i) = .FALSE.
+         kcbot(i) = MAX(kcbot(i),kctop(i))
+      ENDDO
+c
+      ldcum(1)=ldcum(1)
+c
+      is = 0
+      DO i = 1, klon
+         if (ldcum(i)) is = is + 1
+      ENDDO
+      kcum = is
+      IF (is.EQ.0) GOTO 800
+c
+      DO 530 i = 1, klon
+      IF (ldcum(i)) THEN
+         k=kctop(i)-1
+         pde_u(i,k)=(1.-CMFCTOP)*pmfu(i,k+1)
+         plude(i,k)=pde_u(i,k)*plu(i,k+1)
+         pmfu(i,k)=pmfu(i,k+1)-pde_u(i,k)
+         zlnew=plu(i,k)
+         pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k))
+         plu(i,k)=zlnew
+         pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k)
+         pmfuq(i,k)=pqu(i,k)*pmfu(i,k)
+         pmful(i,k)=plu(i,k)*pmfu(i,k)
+         plude(i,k-1)=pmful(i,k)
+      ENDIF
+  530 CONTINUE
+C
+  800 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxflux(pdtime, pqen, pqsen, ptenh, pqenh, pap
+     .  ,  paph, ldland, pgeoh, kcbot, kctop, lddraf, kdtop
+     .  ,  ktype, ldcum, pmfu, pmfd, pmfus, pmfds
+     .  ,  pmfuq, pmfdq, pmful, plude, pdmfup, pdmfdp
+     .  ,  pten, prfl, psfl, pdpmel, ktopm2
+     .  ,  pmflxr, pmflxs)
+      USE dimphy
+      IMPLICIT none
+C----------------------------------------------------------------------
+C THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE
+C FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL cevapcu(klon,klev)
+C     -----------------------------------------------------------------
+      REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev)
+      REAL pten(klon,klev), ptenh(klon,klev)
+      REAL paph(klon,klev+1), pgeoh(klon,klev)
+c
+      REAL pap(klon,klev)
+      REAL ztmsmlt, zdelta, zqsat
+C
+      REAL pmfu(klon,klev), pmfus(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev)
+      REAL pmfuq(klon,klev), pmful(klon,klev)
+      REAL pmfdq(klon,klev)
+      REAL plude(klon,klev)
+      REAL pdmfup(klon,klev), pdpmel(klon,klev)
+cjq The variable maxpdmfdp(klon) has been introduced by Olivier Boucher
+cjq 14/11/00 to fix the problem with the negative precipitation.      
+      REAL pdmfdp(klon,klev), maxpdmfdp(klon,klev) 
+      REAL prfl(klon), psfl(klon)
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)
+      INTEGER  kcbot(klon), kctop(klon), ktype(klon)
+      LOGICAL  ldland(klon), ldcum(klon)
+      INTEGER k, kp, i
+      REAL zcons1, zcons2, zcucov, ztmelp2
+      REAL pdtime, zdp, zzp, zfac, zsnmlt, zrfl, zrnew
+      REAL zrmin, zrfln, zdrfl
+      REAL zpds, zpdr, zdenom
+      INTEGER ktopm2, itop, ikb
+c
+      LOGICAL lddraf(klon)
+      INTEGER kdtop(klon)
+c
+#include "FCTTRE.h"
+c
+      DO 101 k=1,klev
+        DO i=1,klon
+      CEVAPCU(i,k)=1.93E-6*261.*SQRT(1.E3/(38.3*0.293)
+     1 *SQRT(0.5*(paph(i,k)+paph(i,k+1))/paph(i,klev+1)) ) * 0.5/RG
+        ENDDO
+ 101  CONTINUE
+c
+c SPECIFY CONSTANTS
+c
+      zcons1 = RCPD/(RLMLT*RG*pdtime)
+      zcons2 = 1./(RG*pdtime)
+      zcucov = 0.05
+      ztmelp2 = RTT + 2.
+c
+c DETERMINE FINAL CONVECTIVE FLUXES
+c
+      itop=klev
+      DO 110 i = 1, klon
+         itop=MIN(itop,kctop(i))
+         IF (.NOT.ldcum(i) .OR. kdtop(i).LT.kctop(i)) lddraf(i)=.FALSE.
+         IF(.NOT.ldcum(i)) ktype(i)=0
+  110 CONTINUE
+c
+      ktopm2=itop-2
+      DO 120 k=ktopm2,klev
+      DO 115 i = 1, klon
+      IF(ldcum(i).AND.k.GE.kctop(i)-1) THEN
+         pmfus(i,k)=pmfus(i,k)-pmfu(i,k)*
+     .                (RCPD*ptenh(i,k)+pgeoh(i,k))
+         pmfuq(i,k)=pmfuq(i,k)-pmfu(i,k)*pqenh(i,k)
+         zdp = 1.5E4
+         IF ( ldland(i) ) zdp = 3.E4
+c
+c        l'eau liquide detrainee est precipitee quand certaines
+c        conditions sont reunies (sinon, elle est consideree
+c        evaporee dans l'environnement)
+c
+         IF(paph(i,kcbot(i))-paph(i,kctop(i)).GE.zdp.AND.
+     .      pqen(i,k-1).GT.0.8*pqsen(i,k-1))
+     .      pdmfup(i,k-1)=pdmfup(i,k-1)+plude(i,k-1)
+c
+         IF(lddraf(i).AND.k.GE.kdtop(i)) THEN
+            pmfds(i,k)=pmfds(i,k)-pmfd(i,k)*
+     .                   (RCPD*ptenh(i,k)+pgeoh(i,k))
+            pmfdq(i,k)=pmfdq(i,k)-pmfd(i,k)*pqenh(i,k)
+         ELSE
+            pmfd(i,k)=0.
+            pmfds(i,k)=0.
+            pmfdq(i,k)=0.
+            pdmfdp(i,k-1)=0.
+         END IF
+      ELSE
+         pmfu(i,k)=0.
+         pmfus(i,k)=0.
+         pmfuq(i,k)=0.
+         pmful(i,k)=0.
+         pdmfup(i,k-1)=0.
+         plude(i,k-1)=0.
+         pmfd(i,k)=0.
+         pmfds(i,k)=0.
+         pmfdq(i,k)=0.
+         pdmfdp(i,k-1)=0.
+      ENDIF
+  115 CONTINUE
+  120 CONTINUE
+c
+      DO 130 k=ktopm2,klev
+      DO 125 i = 1, klon
+      IF(ldcum(i).AND.k.GT.kcbot(i)) THEN
+         ikb=kcbot(i)
+         zzp=((paph(i,klev+1)-paph(i,k))/
+     .        (paph(i,klev+1)-paph(i,ikb)))
+         IF (ktype(i).EQ.3) zzp = zzp**2
+         pmfu(i,k)=pmfu(i,ikb)*zzp
+         pmfus(i,k)=pmfus(i,ikb)*zzp
+         pmfuq(i,k)=pmfuq(i,ikb)*zzp
+         pmful(i,k)=pmful(i,ikb)*zzp
+      ENDIF
+  125 CONTINUE
+  130 CONTINUE
+c
+c CALCULATE RAIN/SNOW FALL RATES
+c CALCULATE MELTING OF SNOW
+c CALCULATE EVAPORATION OF PRECIP
+c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         pmflxr(i,k) = 0.0
+         pmflxs(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO k = ktopm2, klev
+      DO i = 1, klon
+      IF (ldcum(i)) THEN
+         IF (pmflxs(i,k).GT.0.0 .AND. pten(i,k).GT.ztmelp2) THEN
+            zfac=zcons1*(paph(i,k+1)-paph(i,k))
+            zsnmlt=MIN(pmflxs(i,k),zfac*(pten(i,k)-ztmelp2))
+            pdpmel(i,k)=zsnmlt
+            ztmsmlt=pten(i,k)-zsnmlt/zfac
+            zdelta=MAX(0.,SIGN(1.,RTT-ztmsmlt))
+            zqsat=R2ES*FOEEW(ztmsmlt, zdelta) / pap(i,k)
+            zqsat=MIN(0.5,zqsat)
+            zqsat=zqsat/(1.-RETV  *zqsat)
+            pqsen(i,k) = zqsat
+         ENDIF
+         IF (pten(i,k).GT.RTT) THEN
+         pmflxr(i,k+1)=pmflxr(i,k)+pdmfup(i,k)+pdmfdp(i,k)+pdpmel(i,k)
+         pmflxs(i,k+1)=pmflxs(i,k)-pdpmel(i,k)
+         ELSE
+           pmflxs(i,k+1)=pmflxs(i,k)+pdmfup(i,k)+pdmfdp(i,k)
+           pmflxr(i,k+1)=pmflxr(i,k)
+         ENDIF
+c        si la precipitation est negative, on ajuste le plux du
+c        panache descendant pour eliminer la negativite
+         IF ((pmflxr(i,k+1)+pmflxs(i,k+1)).LT.0.0) THEN
+            pdmfdp(i,k) = -pmflxr(i,k)-pmflxs(i,k)-pdmfup(i,k)
+            pmflxr(i,k+1) = 0.0
+            pmflxs(i,k+1) = 0.0
+            pdpmel(i,k) = 0.0
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+c
+cjq The new variable is initialized here.
+cjq It contains the humidity which is fed to the downdraft
+cjq by evaporation of precipitation in the column below the base
+cjq of convection.
+cjq 
+cjq In the former version, this term has been subtracted from precip
+cjq as well as the evaporation.
+cjq      
+      DO k = 1, klev
+      DO i = 1, klon 
+         maxpdmfdp(i,k)=0.0
+      ENDDO
+      ENDDO
+      DO k = 1, klev
+       DO kp = k, klev
+        DO i = 1, klon
+         maxpdmfdp(i,k)=maxpdmfdp(i,k)+pdmfdp(i,kp)
+        ENDDO
+       ENDDO
+      ENDDO
+cjq End of initialization
+c      
+      DO k = ktopm2, klev
+      DO i = 1, klon
+      IF (ldcum(i) .AND. k.GE.kcbot(i)) THEN
+         zrfl = pmflxr(i,k) + pmflxs(i,k)
+         IF (zrfl.GT.1.0E-20) THEN
+            zrnew=(MAX(0.,SQRT(zrfl/zcucov)-
+     .            CEVAPCU(i,k)*(paph(i,k+1)-paph(i,k))*
+     .            MAX(0.,pqsen(i,k)-pqen(i,k))))**2*zcucov
+            zrmin=zrfl-zcucov*MAX(0.,0.8*pqsen(i,k)-pqen(i,k))
+     .            *zcons2*(paph(i,k+1)-paph(i,k))
+            zrnew=MAX(zrnew,zrmin)
+            zrfln=MAX(zrnew,0.)
+            zdrfl=MIN(0.,zrfln-zrfl)
+cjq At least the amount of precipiation needed to feed the downdraft
+cjq with humidity below the base of convection has to be left and can't
+cjq be evaporated (surely the evaporation can't be positive):            
+            zdrfl=MAX(zdrfl,
+     .            MIN(-pmflxr(i,k)-pmflxs(i,k)-maxpdmfdp(i,k),0.0))
+cjq End of insertion
+c            
+            zdenom=1.0/MAX(1.0E-20,pmflxr(i,k)+pmflxs(i,k))
+            IF (pten(i,k).GT.RTT) THEN
+               zpdr = pdmfdp(i,k)
+               zpds = 0.0
+            ELSE
+               zpdr = 0.0
+               zpds = pdmfdp(i,k)
+            ENDIF
+            pmflxr(i,k+1) = pmflxr(i,k) + zpdr + pdpmel(i,k)
+     .                    + zdrfl*pmflxr(i,k)*zdenom
+            pmflxs(i,k+1) = pmflxs(i,k) + zpds - pdpmel(i,k)
+     .                    + zdrfl*pmflxs(i,k)*zdenom
+            pdmfup(i,k) = pdmfup(i,k) + zdrfl
+         ELSE
+            pmflxr(i,k+1) = 0.0
+            pmflxs(i,k+1) = 0.0
+            pdmfdp(i,k) = 0.0
+            pdpmel(i,k) = 0.0
+         ENDIF         
+         if (pmflxr(i,k) + pmflxs(i,k).lt.-1.e-26) 
+     .    write(*,*) 'precip. < 1e-16 ',pmflxr(i,k) + pmflxs(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      DO 210 i = 1, klon
+         prfl(i) = pmflxr(i,klev+1)
+         psfl(i) = pmflxs(i,klev+1)
+  210 CONTINUE
+c
+      RETURN
+      END
+      SUBROUTINE flxdtdq(pdtime, ktopm2, paph, ldcum, pten
+     .  ,  pmfus, pmfds, pmfuq, pmfdq, pmful, pdmfup, pdmfdp
+     .  ,  pdpmel, dt_con, dq_con)
+      USE dimphy
+      IMPLICIT none
+c----------------------------------------------------------------------
+c calculer les tendances T et Q
+c----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C     -----------------------------------------------------------------
+      LOGICAL  llo1
+C
+      REAL pten(klon,klev), paph(klon,klev+1)
+      REAL pmfus(klon,klev), pmfuq(klon,klev), pmful(klon,klev)
+      REAL pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfup(klon,klev)
+      REAL pdmfdp(klon,klev)
+      REAL pdpmel(klon,klev)
+      LOGICAL ldcum(klon)
+      REAL dt_con(klon,klev), dq_con(klon,klev)
+c
+      INTEGER ktopm2
+      REAL pdtime
+c
+      INTEGER i, k
+      REAL zalv, zdtdt, zdqdt
+c
+      DO 210 k=ktopm2,klev-1
+      DO 220 i = 1, klon
+      IF (ldcum(i)) THEN
+         llo1 = (pten(i,k)-RTT).GT.0.
+         zalv = RLSTT
+         IF (llo1) zalv = RLVTT
+         zdtdt=RG/(paph(i,k+1)-paph(i,k))/RCPD
+     .        *(pmfus(i,k+1)-pmfus(i,k)
+     .         +pmfds(i,k+1)-pmfds(i,k)
+     .          -RLMLT*pdpmel(i,k)
+     .          -zalv*(pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
+     .         )
+         dt_con(i,k)=zdtdt
+         zdqdt=RG/(paph(i,k+1)-paph(i,k))
+     .        *(pmfuq(i,k+1)-pmfuq(i,k)
+     .         +pmfdq(i,k+1)-pmfdq(i,k)
+     .          +pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
+         dq_con(i,k)=zdqdt
+      ENDIF
+  220 CONTINUE
+  210 CONTINUE
+C
+      k = klev
+      DO 230 i = 1, klon
+      IF (ldcum(i)) THEN
+         llo1 = (pten(i,k)-RTT).GT.0.
+         zalv = RLSTT
+         IF (llo1) zalv = RLVTT
+         zdtdt=-RG/(paph(i,k+1)-paph(i,k))/RCPD
+     .         *(pmfus(i,k)+pmfds(i,k)+RLMLT*pdpmel(i,k)
+     .           -zalv*(pmful(i,k)+pdmfup(i,k)+pdmfdp(i,k)))
+         dt_con(i,k)=zdtdt
+         zdqdt=-RG/(paph(i,k+1)-paph(i,k))
+     .            *(pmfuq(i,k)+pmfdq(i,k)+pmful(i,k)
+     .             +pdmfup(i,k)+pdmfdp(i,k))
+         dq_con(i,k)=zdqdt
+      ENDIF
+  230 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE flxdlfs(ptenh, pqenh, pgeoh, paph, ptu, pqu,
+     .     ldcum, kcbot, kctop, pmfub, prfl, ptd, pqd,
+     .     pmfd, pmfds, pmfdq, pdmfdp, kdtop, lddraf)
+      USE dimphy
+      IMPLICIT none
+C
+C----------------------------------------------------------------------
+C THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR
+C CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES
+C
+C TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS
+C FOR MASSFLUX CUMULUS PARAMETERIZATION
+C
+C INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI
+C AND UPDRAFT VALUES T,Q,U AND V AND ALSO
+C CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE.
+C IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS.
+C
+C CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF
+C MOIST ENVIRONMENTAL AIR AND CLOUD AIR.
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL ptenh(klon,klev)
+      REAL pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+      REAL ptu(klon,klev), pqu(klon,klev)
+      REAL pmfub(klon)
+      REAL prfl(klon)
+C
+      REAL ptd(klon,klev), pqd(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfdp(klon,klev)
+      INTEGER  kcbot(klon), kctop(klon), kdtop(klon)
+      LOGICAL  ldcum(klon), lddraf(klon)
+C
+      REAL ztenwb(klon,klev), zqenwb(klon,klev), zcond(klon)
+      REAL zttest, zqtest, zbuo, zmftop
+      LOGICAL  llo2(klon)
+      INTEGER i, k, is, icall
+C----------------------------------------------------------------------
+      DO i= 1, klon
+         lddraf(i)=.FALSE.
+         kdtop(i)=klev+1
+      ENDDO
+C
+C----------------------------------------------------------------------
+C DETERMINE LEVEL OF FREE SINKING BY
+C DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS
+C
+C FOR EVERY POINT AND PROCEED AS FOLLOWS:
+C     (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q
+C     (2) DO MIXING WITH CUMULUS CLOUD AIR
+C     (3) CHECK FOR NEGATIVE BUOYANCY
+C
+C THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE
+C OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB
+C TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO
+C EVAPORATION OF RAIN AND CLOUD WATER)
+C----------------------------------------------------------------------
+C
+      DO 290 k = 3, klev-3
+C
+      is=0
+      DO 212 i= 1, klon
+         ztenwb(i,k)=ptenh(i,k)
+         zqenwb(i,k)=pqenh(i,k)
+         llo2(i) = ldcum(i).AND.prfl(i).GT.0.
+     .             .AND..NOT.lddraf(i)
+     .             .AND.(k.LT.kcbot(i).AND.k.GT.kctop(i))
+         IF ( llo2(i) ) is = is + 1
+  212 CONTINUE
+      IF(is.EQ.0) GO TO 290
+C
+      icall=2
+      CALL flxadjtq(paph(1,k), ztenwb(1,k), zqenwb(1,k), llo2, icall)
+C
+C----------------------------------------------------------------------
+C DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR
+C AND CHECK FOR NEGATIVE BUOYANCY.
+C THEN SET VALUES FOR DOWNDRAFT AT LFS.
+C----------------------------------------------------------------------
+      DO 222 i= 1, klon
+      IF (llo2(i)) THEN
+         zttest=0.5*(ptu(i,k)+ztenwb(i,k))
+         zqtest=0.5*(pqu(i,k)+zqenwb(i,k))
+         zbuo=zttest*(1.+RETV*zqtest)-
+     .        ptenh(i,k)*(1.+RETV  *pqenh(i,k))
+         zcond(i)=pqenh(i,k)-zqenwb(i,k)
+         zmftop=-CMFDEPS*pmfub(i)
+         IF (zbuo.LT.0..AND.prfl(i).GT.10.*zmftop*zcond(i)) THEN
+            kdtop(i)=k
+            lddraf(i)=.TRUE.
+            ptd(i,k)=zttest
+            pqd(i,k)=zqtest
+            pmfd(i,k)=zmftop
+            pmfds(i,k)=pmfd(i,k)*(RCPD*ptd(i,k)+pgeoh(i,k))
+            pmfdq(i,k)=pmfd(i,k)*pqd(i,k)
+            pdmfdp(i,k-1)=-0.5*pmfd(i,k)*zcond(i)
+            prfl(i)=prfl(i)+pdmfdp(i,k-1)
+         ENDIF
+      ENDIF
+  222 CONTINUE
+c
+  290 CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl,
+     .           ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp,
+     .           lddraf, pen_d, pde_d)
+      USE dimphy
+      IMPLICIT none
+C
+C----------------------------------------------------------------------
+C          THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
+C
+C          TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
+C          (I.E. T,Q,U AND V AND FLUXES)
+C
+C          INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
+C          IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
+C          AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
+C
+C          CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
+C          A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
+C          B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
+C
+C----------------------------------------------------------------------
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+C
+      REAL ptenh(klon,klev), pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+C
+      REAL ptd(klon,klev), pqd(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfdp(klon,klev)
+      REAL prfl(klon)
+      LOGICAL lddraf(klon)
+C
+      REAL pen_d(klon,klev), pde_d(klon,klev), zcond(klon)
+      LOGICAL llo2(klon), llo1
+      INTEGER i, k, is, icall, itopde
+      REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp
+      REAL zbuo
+C----------------------------------------------------------------------
+C CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
+C       (A) CALCULATING ENTRAINMENT RATES, ASSUMING
+C           LINEAR DECREASE OF MASSFLUX IN PBL
+C       (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
+C           AND MOISTENING IS CALCULATED IN *flxadjtq*
+C       (C) CHECKING FOR NEGATIVE BUOYANCY AND
+C           SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
+C
+      DO 180 k = 3, klev
+c
+      is = 0
+      DO i = 1, klon
+         llo2(i)=lddraf(i).AND.pmfd(i,k-1).LT.0.
+         IF (llo2(i)) is = is + 1
+      ENDDO
+      IF (is.EQ.0) GOTO 180
+c
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         zentr = ENTRDD*pmfd(i,k-1)*RD*ptenh(i,k-1)/
+     .           (RG*paph(i,k-1))*(paph(i,k)-paph(i,k-1))
+         pen_d(i,k) = zentr
+         pde_d(i,k) = zentr
+      ENDIF
+      ENDDO
+c
+      itopde = klev-2
+      IF (k.GT.itopde) THEN
+         DO i = 1, klon
+         IF (llo2(i)) THEN
+            pen_d(i,k)=0.
+            pde_d(i,k)=pmfd(i,itopde)*
+     .      (paph(i,k)-paph(i,k-1))/(paph(i,klev+1)-paph(i,itopde))
+         ENDIF
+         ENDDO
+      ENDIF
+C
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         pmfd(i,k) = pmfd(i,k-1)+pen_d(i,k)-pde_d(i,k)
+         zseen = (RCPD*ptenh(i,k-1)+pgeoh(i,k-1))*pen_d(i,k)
+         zqeen = pqenh(i,k-1)*pen_d(i,k)
+         zsdde = (RCPD*ptd(i,k-1)+pgeoh(i,k-1))*pde_d(i,k)
+         zqdde = pqd(i,k-1)*pde_d(i,k)
+         zmfdsk = pmfds(i,k-1)+zseen-zsdde
+         zmfdqk = pmfdq(i,k-1)+zqeen-zqdde
+         pqd(i,k) = zmfdqk*(1./MIN(-CMFCMIN,pmfd(i,k)))
+         ptd(i,k) = (zmfdsk*(1./MIN(-CMFCMIN,pmfd(i,k)))-
+     .               pgeoh(i,k))/RCPD
+         ptd(i,k) = MIN(400.,ptd(i,k))
+         ptd(i,k) = MAX(100.,ptd(i,k))
+         zcond(i) = pqd(i,k)
+      ENDIF
+      ENDDO
+C
+      icall = 2
+      CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall)
+C
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         zcond(i) = zcond(i)-pqd(i,k)
+         zbuo = ptd(i,k)*(1.+RETV  *pqd(i,k))-
+     .          ptenh(i,k)*(1.+RETV  *pqenh(i,k))
+         llo1 = zbuo.LT.0..AND.(prfl(i)-pmfd(i,k)*zcond(i).GT.0.)
+         IF (.not.llo1) pmfd(i,k) = 0.0
+         pmfds(i,k) = (RCPD*ptd(i,k)+pgeoh(i,k))*pmfd(i,k)
+         pmfdq(i,k) = pqd(i,k)*pmfd(i,k)
+         zdmfdp = -pmfd(i,k)*zcond(i)
+         pdmfdp(i,k-1) = zdmfdp
+         prfl(i) = prfl(i)+zdmfdp
+      ENDIF
+      ENDDO
+c
+  180 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxadjtq(pp, pt, pq, ldflag, kcall)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Objet: ajustement entre T et Q
+c======================================================================
+C NOTE: INPUT PARAMETER kcall DEFINES CALCULATION AS
+C        kcall=0    ENV. T AND QS IN*CUINI*
+C        kcall=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
+C        kcall=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+C
+      REAL pt(klon), pq(klon), pp(klon)
+      LOGICAL ldflag(klon)
+      INTEGER kcall
+c
+      REAL zcond(klon), zcond1
+      REAL Z5alvcp, z5alscp, zalvdcp, zalsdcp
+      REAL zdelta, zcvm5, zldcp, zqsat, zcor
+      INTEGER is, i
+#include "YOETHF.h"
+#include "FCTTRE.h"
+C
+      z5alvcp = r5les*RLVTT/RCPD
+      z5alscp = r5ies*RLSTT/RCPD
+      zalvdcp = rlvtt/RCPD
+      zalsdcp = rlstt/RCPD
+C
+
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+
+      DO 210 i =1, klon
+      IF (ldflag(i)) THEN
+         zdelta = MAX(0.,SIGN(1.,RTT-pt(i)))
+         zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+         zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+         zqsat = R2ES*FOEEW(pt(i),zdelta) / pp(i)
+         zqsat = MIN(0.5,zqsat)
+         zcor = 1./(1.-RETV*zqsat)
+         zqsat = zqsat*zcor
+         zcond(i) = (pq(i)-zqsat)
+     .     / (1. + FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor))
+         IF (kcall.EQ.1) zcond(i) = MAX(zcond(i),0.)
+         IF (kcall.EQ.2) zcond(i) = MIN(zcond(i),0.)
+         pt(i) = pt(i) + zldcp*zcond(i)
+         pq(i) = pq(i) - zcond(i)
+      ENDIF
+  210 CONTINUE
+C
+      is = 0
+      DO i =1, klon
+         IF (zcond(i).NE.0.) is = is + 1
+      ENDDO
+      IF (is.EQ.0) GOTO 230
+C
+      DO 220 i = 1, klon
+      IF(ldflag(i).AND.zcond(i).NE.0.) THEN
+         zdelta = MAX(0.,SIGN(1.,RTT-pt(i)))
+         zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+         zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+         zqsat = R2ES* FOEEW(pt(i),zdelta) / pp(i)
+         zqsat = MIN(0.5,zqsat)
+         zcor = 1./(1.-RETV*zqsat)
+         zqsat = zqsat*zcor
+         zcond1 = (pq(i)-zqsat)
+     .     / (1. + FOEDE(pt(i),zdelta,zcvm5,zqsat,zcor))
+         pt(i) = pt(i) + zldcp*zcond1
+         pq(i) = pq(i) - zcond1
+      ENDIF
+  220 CONTINUE
+C
+  230 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxsetup
+      IMPLICIT none
+C
+C     THIS ROUTINE DEFINES DISPOSABLE PARAMETERS FOR MASSFLUX SCHEME
+C
+#include "YOECUMF.h"
+C
+      ENTRPEN=1.0E-4  ! ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+      ENTRSCV=3.0E-4  ! ENTRAINMENT RATE FOR SHALLOW CONVECTION
+      ENTRMID=1.0E-4  ! ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+      ENTRDD =2.0E-4  ! ENTRAINMENT RATE FOR DOWNDRAFTS
+      CMFCTOP=0.33  ! RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUO LEVEL
+      CMFCMAX=1.0  ! MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC
+      CMFCMIN=1.E-10  ! MINIMUM MASSFLUX VALUE (FOR SAFETY)
+      CMFDEPS=0.3  ! FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+      CPRCON =2.0E-4  ! CONVERSION FROM CLOUD WATER TO RAIN
+      RHCDD=1.  ! RELATIVE SATURATION IN DOWNDRAFRS (NO LONGER USED)
+c                 (FORMULATION IMPLIES SATURATION)
+      LMFPEN = .TRUE.
+      LMFSCV = .TRUE.
+      LMFMID = .TRUE.
+      LMFDD = .TRUE.
+      LMFDUDV = .TRUE.
+c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/conflx.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/conflx.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/conflx.F90	(revision 17)
@@ -0,0 +1,1675 @@
+!
+! $Header$
+!
+      SUBROUTINE conflx (dtime,pres_h,pres_f,                                        &
+       &                   t, q, con_t, con_q, pqhfl, w,                             &
+       &                   d_t, d_q, rain, snow,                                     &
+       &                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,                   &
+       &                   kcbot, kctop, kdtop, pmflxr, pmflxs)
+!c
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS) date: 19941014
+!c Objet: Schema flux de masse pour la convection 
+!c        (schema de Tiedtke avec qqs modifications mineures)
+!c Dec.97: Prise en compte des modifications introduites par
+!c         Olivier Boucher et Alexandre Armengaud pour melange
+!c         et lessivage des traceurs passifs.
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+!c Entree:
+      REAL dtime            ! pas d'integration (s)
+      REAL pres_h(klon,klev+1) ! pression half-level (Pa)
+      REAL pres_f(klon,klev)! pression full-level (Pa)
+      REAL t(klon,klev)     ! temperature (K)
+      REAL q(klon,klev)     ! humidite specifique (g/g)
+      REAL w(klon,klev)     ! vitesse verticale (Pa/s)
+      REAL con_t(klon,klev) ! convergence de temperature (K/s)
+      REAL con_q(klon,klev) ! convergence de l'eau vapeur (g/g/s)
+      REAL pqhfl(klon)      ! evaporation (negative vers haut) mm/s
+!c Sortie:
+      REAL d_t(klon,klev)   ! incrementation de temperature
+      REAL d_q(klon,klev)   ! incrementation d'humidite
+      REAL pmfu(klon,klev)  ! flux masse (kg/m2/s) panache ascendant
+      REAL pmfd(klon,klev)  ! flux masse (kg/m2/s) panache descendant
+      REAL pen_u(klon,klev)
+      REAL pen_d(klon,klev)
+      REAL pde_u(klon,klev)
+      REAL pde_d(klon,klev)
+      REAL rain(klon)       ! pluie (mm/s)
+      REAL snow(klon)       ! neige (mm/s)
+      REAL pmflxr(klon,klev+1)
+      REAL pmflxs(klon,klev+1)
+      INTEGER kcbot(klon)  ! niveau du bas de la convection
+      INTEGER kctop(klon)  ! niveau du haut de la convection
+      INTEGER kdtop(klon)  ! niveau du haut des downdrafts
+!c Local:
+      REAL pt(klon,klev)
+      REAL pq(klon,klev)
+      REAL pqs(klon,klev)
+      REAL pvervel(klon,klev)
+      LOGICAL land(klon)
+!c
+      REAL d_t_bis(klon,klev)
+      REAL d_q_bis(klon,klev)
+      REAL paprs(klon,klev+1)
+      REAL paprsf(klon,klev)
+      REAL zgeom(klon,klev)
+      REAL zcvgq(klon,klev)
+      REAL zcvgt(klon,klev)
+!cAA
+      REAL zmfu(klon,klev) 
+      REAL zmfd(klon,klev)
+      REAL zen_u(klon,klev)
+      REAL zen_d(klon,klev)
+      REAL zde_u(klon,klev)
+      REAL zde_d(klon,klev)
+      REAL zmflxr(klon,klev+1)
+      REAL zmflxs(klon,klev+1)
+!cAA
+
+!c
+      INTEGER i, k
+      REAL zdelta, zqsat
+!c
+#include "FCTTRE.h"
+!c
+!c initialiser les variables de sortie (pour securite)
+      DO i = 1, klon
+         rain(i) = 0.0
+         snow(i) = 0.0
+         kcbot(i) = 0
+         kctop(i) = 0
+         kdtop(i) = 0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_q(i,k) = 0.0
+         pmfu(i,k) = 0.0
+         pmfd(i,k) = 0.0
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         pen_d(i,k) = 0.0
+         pde_d(i,k) = 0.0
+         zmfu(i,k) = 0.0
+         zmfd(i,k) = 0.0
+         zen_u(i,k) = 0.0
+         zde_u(i,k) = 0.0
+         zen_d(i,k) = 0.0
+         zde_d(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         zmflxr(i,k) = 0.0
+         zmflxs(i,k) = 0.0
+      ENDDO
+      ENDDO
+!c
+!c calculer la nature du sol (pour l'instant, ocean partout)
+      DO i = 1, klon
+         land(i) = .FALSE.
+      ENDDO
+!c
+!c preparer les variables d'entree (attention: l'ordre des niveaux 
+!c verticaux augmente du haut vers le bas)
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1)
+         pq(i,k) = q(i,klev-k+1)
+         paprsf(i,k) = pres_f(i,klev-k+1)
+         paprs(i,k) = pres_h(i,klev+1-k+1)
+         pvervel(i,k) = w(i,klev+1-k)
+         zcvgt(i,k) = con_t(i,klev-k+1)
+         zcvgq(i,k) = con_q(i,klev-k+1)
+!c
+         zdelta=MAX(0.,SIGN(1.,RTT-pt(i,k)))
+         zqsat=R2ES*FOEEW ( pt(i,k), zdelta ) / paprsf(i,k)
+         zqsat=MIN(0.5,zqsat)
+         zqsat=zqsat/(1.-RETV  *zqsat)
+         pqs(i,k) = zqsat
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         paprs(i,klev+1) = pres_h(i,1)
+         zgeom(i,klev) = RD * pt(i,klev)                                             &
+       &                   / (0.5*(paprs(i,klev+1)+paprsf(i,klev)))                  &
+       &                   * (paprs(i,klev+1)-paprsf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1)                                                   &
+       &              + RD * 0.5*(pt(i,k+1)+pt(i,k)) / paprs(i,k+1)                  &
+       &                   * (paprsf(i,k+1)-paprsf(i,k))
+      ENDDO
+      ENDDO
+!c
+!c appeler la routine principale
+!c
+      CALL flxmain(dtime, pt, pq, pqs, pqhfl,                                        &
+       &             paprsf, paprs, zgeom, land, zcvgt, zcvgq, pvervel,              &
+       &             rain, snow, kcbot, kctop, kdtop,                                &
+       &             zmfu, zmfd, zen_u, zde_u, zen_d, zde_d,                         &
+       &             d_t_bis, d_q_bis, zmflxr, zmflxs)
+!C
+!cAA--------------------------------------------------------
+!cAA rem : De la meme facon que l'on effectue le reindicage 
+!cAA       pour la temperature t et le champ q 
+!cAA       on reindice les flux necessaires a la convection 
+!cAA       des traceurs
+!cAA--------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         d_q(i,klev+1-k) = dtime*d_q_bis(i,k)
+         d_t(i,klev+1-k) = dtime*d_t_bis(i,k)
+      ENDDO
+      ENDDO
+!c
+      DO i = 1, klon
+         pmfu(i,1)= 0.
+         pmfd(i,1)= 0.
+         pen_d(i,1)= 0.
+         pde_d(i,1)= 0.
+      ENDDO
+      DO k = 2, klev
+      DO i = 1, klon
+         pmfu(i,klev+2-k)= zmfu(i,k)
+         pmfd(i,klev+2-k)= zmfd(i,k)
+      ENDDO
+      ENDDO
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         pen_u(i,klev+1-k)=  zen_u(i,k)
+         pde_u(i,klev+1-k)=  zde_u(i,k)
+      ENDDO
+      ENDDO
+!c
+      DO k = 1, klev-1
+      DO i = 1, klon
+         pen_d(i,klev+1-k)= -zen_d(i,k+1)
+         pde_d(i,klev+1-k)= -zde_d(i,k+1)
+      ENDDO
+      ENDDO
+
+      DO k = 1, klev+1
+      DO i = 1, klon
+         pmflxr(i,klev+2-k)= zmflxr(i,k)
+         pmflxs(i,klev+2-k)= zmflxs(i,k)
+      ENDDO
+      ENDDO
+
+      RETURN
+      END
+!c--------------------------------------------------------------------
+      SUBROUTINE flxmain(pdtime, pten, pqen, pqsen, pqhfl, pap, paph,                &
+       &                   pgeo, ldland, ptte, pqte, pvervel,                        &
+       &                   prsfc, pssfc, kcbot, kctop, kdtop,                        &
+!c     *                   ldcum, ktype,                                             &
+       &                   pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,                   &
+       &                   dt_con, dq_con, pmflxr, pmflxs)
+      USE dimphy
+      IMPLICIT none
+!C     ------------------------------------------------------------------
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+!C     ----------------------------------------------------------------
+      REAL pten(klon,klev), pqen(klon,klev), pqsen(klon,klev)
+      REAL ptte(klon,klev)
+      REAL pqte(klon,klev)
+      REAL pvervel(klon,klev)
+      REAL pgeo(klon,klev), pap(klon,klev), paph(klon,klev+1)
+      REAL pqhfl(klon)
+!c
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      REAL plude(klon,klev)
+      REAL pmfu(klon,klev)
+      REAL prsfc(klon), pssfc(klon)
+      INTEGER  kcbot(klon), kctop(klon), ktype(klon)
+      LOGICAL  ldland(klon), ldcum(klon)
+!c
+      REAL ztenh(klon,klev), zqenh(klon,klev), zqsenh(klon,klev)
+      REAL zgeoh(klon,klev)
+      REAL zmfub(klon), zmfub1(klon)
+      REAL zmfus(klon,klev), zmfuq(klon,klev), zmful(klon,klev)
+      REAL zdmfup(klon,klev), zdpmel(klon,klev)
+      REAL zentr(klon), zhcbase(klon)
+      REAL zdqpbl(klon), zdqcv(klon), zdhpbl(klon)
+      REAL zrfl(klon)
+      REAL pmflxr(klon,klev+1)
+      REAL pmflxs(klon,klev+1)
+      INTEGER  ilab(klon,klev), ictop0(klon)
+      LOGICAL  llo1
+      REAL dt_con(klon,klev), dq_con(klon,klev)
+      REAL zmfmax, zdh
+      REAL pdtime, zqumqe, zdqmin, zalvdcp, zhsat, zzz
+      REAL zhhat, zpbmpt, zgam, zeps, zfac
+      INTEGER i, k, ikb, itopm2, kcum
+!c
+      REAL pen_u(klon,klev), pde_u(klon,klev)
+      REAL pen_d(klon,klev), pde_d(klon,klev)
+!c
+      REAL ptd(klon,klev), pqd(klon,klev), pmfd(klon,klev)
+      REAL zmfds(klon,klev), zmfdq(klon,klev), zdmfdp(klon,klev)
+      INTEGER kdtop(klon)
+      LOGICAL lddraf(klon)
+!C---------------------------------------------------------------------
+      LOGICAL firstcal
+      SAVE firstcal
+      DATA firstcal / .TRUE. /
+!$OMP THREADPRIVATE(firstcal)
+!C---------------------------------------------------------------------
+      IF (firstcal) THEN
+         CALL flxsetup
+         firstcal = .FALSE.
+      ENDIF
+!C---------------------------------------------------------------------
+      DO i = 1, klon
+         ldcum(i) = .FALSE.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         dt_con(i,k) = 0.0
+         dq_con(i,k) = 0.0
+      ENDDO
+      ENDDO
+!c----------------------------------------------------------------------
+!c initialiser les variables et faire l'interpolation verticale
+!c----------------------------------------------------------------------
+      CALL flxini(pten, pqen, pqsen, pgeo,                                           &
+       &     paph, zgeoh, ztenh, zqenh, zqsenh,                                      &
+       &     ptu, pqu, ptd, pqd, pmfd, zmfds, zmfdq, zdmfdp,                         &
+       &     pmfu, zmfus, zmfuq, zdmfup,                                             &
+       &     zdpmel, plu, plude, ilab, pen_u, pde_u, pen_d, pde_d)
+!c---------------------------------------------------------------------
+!c determiner les valeurs au niveau de base de la tour convective
+!c---------------------------------------------------------------------
+      CALL flxbase(ztenh, zqenh, zgeoh, paph,                                        &
+       &            ptu, pqu, plu, ldcum, kcbot, ilab)
+!c---------------------------------------------------------------------
+!c calculer la convergence totale de l'humidite et celle en provenance
+!c de la couche limite, plus precisement, la convergence integree entre
+!c le sol et la base de la convection. Cette derniere convergence est
+!c comparee avec l'evaporation obtenue dans la couche limite pour
+!c determiner le type de la convection
+!c---------------------------------------------------------------------
+      k=1
+      DO i = 1, klon
+         zdqcv(i) = pqte(i,k)*(paph(i,k+1)-paph(i,k))
+         zdhpbl(i) = 0.0
+         zdqpbl(i) = 0.0
+      ENDDO
+!c
+      DO k=2,klev
+      DO i = 1, klon
+          zdqcv(i)=zdqcv(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k))
+          IF (k.GE.kcbot(i)) THEN
+             zdqpbl(i)=zdqpbl(i)+pqte(i,k)*(paph(i,k+1)-paph(i,k))
+             zdhpbl(i)=zdhpbl(i)+(RCPD*ptte(i,k)+RLVTT*pqte(i,k))                    &
+       &                          *(paph(i,k+1)-paph(i,k))
+          ENDIF
+      ENDDO
+      ENDDO
+!c
+      DO i = 1, klon
+         ktype(i) = 2
+         if (zdqcv(i).GT.MAX(0.,-1.5*pqhfl(i)*RG)) ktype(i) = 1
+!ccc         if (zdqcv(i).GT.MAX(0.,-1.1*pqhfl(i)*RG)) ktype(i) = 1
+      ENDDO
+!c
+!c---------------------------------------------------------------------
+!c determiner le flux de masse entrant a travers la base.
+!c on ignore, pour l'instant, l'effet du panache descendant
+!c---------------------------------------------------------------------
+      DO i = 1, klon
+         ikb=kcbot(i)
+         zqumqe=pqu(i,ikb)+plu(i,ikb)-zqenh(i,ikb)
+         zdqmin=MAX(0.01*zqenh(i,ikb),1.E-10)
+         IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)) THEN
+            zmfub(i) = zdqpbl(i)/(RG*MAX(zqumqe,zdqmin))
+         ELSE
+            zmfub(i) = 0.01
+            ldcum(i)=.FALSE.
+         ENDIF
+         IF (ktype(i).EQ.2) THEN
+            zdh = RCPD*(ptu(i,ikb)-ztenh(i,ikb)) + RLVTT*zqumqe
+            zdh = RG * MAX(zdh,1.0E5*zdqmin)
+            IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub(i)=zdhpbl(i)/zdh
+         ENDIF
+         zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime)
+         zmfub(i) = MIN(zmfub(i),zmfmax)
+         zentr(i) = ENTRSCV
+         IF (ktype(i).EQ.1) zentr(i) = ENTRPEN
+      ENDDO
+!C-----------------------------------------------------------------------
+!C DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME
+!C-----------------------------------------------------------------------
+!c (A) calculer d'abord la hauteur "theorique" de la tour convective sans
+!c     considerer l'entrainement ni le detrainement du panache, sachant
+!c     ces derniers peuvent abaisser la hauteur theorique.
+!c
+      DO i = 1, klon
+         ikb=kcbot(i)
+         zhcbase(i)=RCPD*ptu(i,ikb)+zgeoh(i,ikb)+RLVTT*pqu(i,ikb)
+         ictop0(i)=kcbot(i)-1
+      ENDDO
+!c
+      zalvdcp=RLVTT/RCPD
+      DO k=klev-1,3,-1
+      DO i = 1, klon
+         zhsat=RCPD*ztenh(i,k)+zgeoh(i,k)+RLVTT*zqsenh(i,k)
+         zgam=R5LES*zalvdcp*zqsenh(i,k)/                                             &
+       &        ((1.-RETV  *zqsenh(i,k))*(ztenh(i,k)-R4LES)**2)
+         zzz=RCPD*ztenh(i,k)*0.608
+         zhhat=zhsat-(zzz+zgam*zzz)/(1.+zgam*zzz/RLVTT)*                             &
+       &               MAX(zqsenh(i,k)-zqenh(i,k),0.)
+         IF(k.LT.ictop0(i).AND.zhcbase(i).GT.zhhat) ictop0(i)=k
+      ENDDO
+      ENDDO
+!c
+!c (B) calculer le panache ascendant
+!c
+      CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen,                            &
+       &     pgeo, zgeoh, pap, paph, pqte, pvervel,                                  &
+       &     ldland, ldcum, ktype, ilab,                                             &
+       &     ptu, pqu, plu, pmfu, zmfub, zentr,                                      &
+       &     zmfus, zmfuq, zmful, plude, zdmfup,                                     &
+       &     kcbot, kctop, ictop0, kcum, pen_u, pde_u)
+      IF (kcum.EQ.0) GO TO 1000
+!C
+!C verifier l'epaisseur de la convection et changer eventuellement
+!c le taux d'entrainement/detrainement
+!C
+      DO i = 1, klon
+         zpbmpt=paph(i,kcbot(i))-paph(i,kctop(i))
+         IF(ldcum(i).AND.ktype(i).EQ.1.AND.zpbmpt.LT.2.E4)ktype(i)=2
+         IF(ldcum(i)) ictop0(i)=kctop(i)
+         IF(ktype(i).EQ.2) zentr(i)=ENTRSCV
+      ENDDO
+!c
+      IF (lmfdd) THEN  ! si l'on considere le panache descendant
+!c
+!c calculer la precipitation issue du panache ascendant pour 
+!c determiner l'existence du panache descendant dans la convection
+      DO i = 1, klon
+         zrfl(i)=zdmfup(i,1)
+      ENDDO
+      DO k=2,klev
+      DO i = 1, klon
+         zrfl(i)=zrfl(i)+zdmfup(i,k)
+      ENDDO
+      ENDDO
+!c
+!c determiner le LFS (level of free sinking: niveau de plonge libre)
+      CALL flxdlfs(ztenh, zqenh, zgeoh, paph, ptu, pqu,                              &
+       &     ldcum,    kcbot,    kctop,    zmfub,    zrfl,                           &
+       &     ptd,      pqd,                                                          &
+       &     pmfd,     zmfds,    zmfdq,    zdmfdp,                                   &
+       &     kdtop,    lddraf)
+!c
+!c calculer le panache descendant
+      CALL flxddraf(ztenh,    zqenh,                                                 &
+       &     zgeoh,    paph,     zrfl,                                               &
+       &     ptd,      pqd,                                                          &
+       &     pmfd,     zmfds,    zmfdq,    zdmfdp,                                   &
+       &     lddraf, pen_d, pde_d)
+!c
+!c calculer de nouveau le flux de masse entrant a travers la base
+!c de la convection, sachant qu'il a ete modifie par le panache
+!c descendant
+      DO i = 1, klon
+      IF (lddraf(i)) THEN
+         ikb = kcbot(i)
+         llo1 = PMFD(i,ikb).LT.0.
+         zeps = 0.
+         IF ( llo1 ) zeps = CMFDEPS
+         zqumqe = pqu(i,ikb)+plu(i,ikb)-                                             &
+       &            zeps*pqd(i,ikb)-(1.-zeps)*zqenh(i,ikb)
+         zdqmin = MAX(0.01*zqenh(i,ikb),1.E-10)
+         zmfmax = (paph(i,ikb)-paph(i,ikb-1)) / (RG*pdtime)
+         IF (zdqpbl(i).GT.0..AND.zqumqe.GT.zdqmin.AND.ldcum(i)                       &
+       &       .AND.zmfub(i).LT.zmfmax) THEN
+            zmfub1(i) = zdqpbl(i) / (RG*MAX(zqumqe,zdqmin))
+         ELSE
+            zmfub1(i) = zmfub(i)
+         ENDIF
+         IF (ktype(i).EQ.2) THEN
+            zdh = RCPD*(ptu(i,ikb)-zeps*ptd(i,ikb)-                                  &
+       &            (1.-zeps)*ztenh(i,ikb))+RLVTT*zqumqe
+            zdh = RG * MAX(zdh,1.0E5*zdqmin)
+            IF (zdhpbl(i).GT.0..AND.ldcum(i))zmfub1(i)=zdhpbl(i)/zdh
+         ENDIF
+         IF ( .NOT.((ktype(i).EQ.1.OR.ktype(i).EQ.2).AND.                            &
+       &              ABS(zmfub1(i)-zmfub(i)).LT.0.2*zmfub(i)) )                     &
+       &      zmfub1(i) = zmfub(i)
+      ENDIF
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (lddraf(i)) THEN
+         zfac = zmfub1(i)/MAX(zmfub(i),1.E-10)
+         pmfd(i,k) = pmfd(i,k)*zfac
+         zmfds(i,k) = zmfds(i,k)*zfac
+         zmfdq(i,k) = zmfdq(i,k)*zfac
+         zdmfdp(i,k) = zdmfdp(i,k)*zfac
+         pen_d(i,k) = pen_d(i,k)*zfac
+         pde_d(i,k) = pde_d(i,k)*zfac
+      ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         IF (lddraf(i)) zmfub(i)=zmfub1(i)
+      ENDDO
+!c
+      ENDIF   ! fin de test sur lmfdd
+!c
+!c-----------------------------------------------------------------------
+!c calculer de nouveau le panache ascendant
+!c-----------------------------------------------------------------------
+      CALL flxasc(pdtime,ztenh, zqenh, pten, pqen, pqsen,                            &
+       &     pgeo, zgeoh, pap, paph, pqte, pvervel,                                  &
+       &     ldland, ldcum, ktype, ilab,                                             &
+       &     ptu, pqu, plu, pmfu, zmfub, zentr,                                      &
+       &     zmfus, zmfuq, zmful, plude, zdmfup,                                     &
+       &     kcbot, kctop, ictop0, kcum, pen_u, pde_u)
+!c
+!c-----------------------------------------------------------------------
+!c determiner les flux convectifs en forme finale, ainsi que
+!c la quantite des precipitations
+!c-----------------------------------------------------------------------
+      CALL flxflux(pdtime, pqen, pqsen, ztenh, zqenh, pap, paph,                     &
+       &     ldland, zgeoh, kcbot, kctop, lddraf, kdtop, ktype, ldcum,               &
+       &     pmfu, pmfd, zmfus, zmfds, zmfuq, zmfdq, zmful, plude,                   &
+       &     zdmfup, zdmfdp, pten, prsfc, pssfc, zdpmel, itopm2,                     &
+       &     pmflxr, pmflxs)
+!c
+!c----------------------------------------------------------------------
+!c calculer les tendances pour T et Q
+!c----------------------------------------------------------------------
+      CALL flxdtdq(pdtime, itopm2, paph, ldcum, pten,                                &
+       &     zmfus, zmfds, zmfuq, zmfdq, zmful, zdmfup, zdmfdp, zdpmel,              &
+       &     dt_con,dq_con)
+!c
+ 1000 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxini(pten, pqen, pqsen, pgeo, paph, pgeoh, ptenh,                 &
+       &           pqenh, pqsenh, ptu, pqu, ptd, pqd, pmfd, pmfds, pmfdq,            &
+       &           pdmfdp, pmfu, pmfus, pmfuq, pdmfup, pdpmel, plu, plude,           &
+       &           klab,pen_u, pde_u, pen_d, pde_d)
+      USE dimphy
+      IMPLICIT none
+!C----------------------------------------------------------------------
+!C THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC.
+!C TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME),
+!C AND INITIALIZES VALUES FOR UPDRAFTS
+!C----------------------------------------------------------------------
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+!C
+      REAL pten(klon,klev)   ! temperature (environnement)
+      REAL pqen(klon,klev)   ! humidite (environnement)
+      REAL pqsen(klon,klev)  ! humidite saturante (environnement)
+      REAL pgeo(klon,klev)   ! geopotentiel (g * metre)
+      REAL pgeoh(klon,klev)  ! geopotentiel aux demi-niveaux
+      REAL paph(klon,klev+1) ! pression aux demi-niveaux
+      REAL ptenh(klon,klev)  ! temperature aux demi-niveaux
+      REAL pqenh(klon,klev)  ! humidite aux demi-niveaux
+      REAL pqsenh(klon,klev) ! humidite saturante aux demi-niveaux
+!C
+      REAL ptu(klon,klev)    ! temperature du panache ascendant (p-a)
+      REAL pqu(klon,klev)    ! humidite du p-a
+      REAL plu(klon,klev)    ! eau liquide du p-a
+      REAL pmfu(klon,klev)   ! flux de masse du p-a
+      REAL pmfus(klon,klev)  ! flux de l'energie seche dans le p-a
+      REAL pmfuq(klon,klev)  ! flux de l'humidite dans le p-a
+      REAL pdmfup(klon,klev) ! quantite de l'eau precipitee dans p-a
+      REAL plude(klon,klev)  ! quantite de l'eau liquide jetee du
+!c                              p-a a l'environnement
+      REAL pdpmel(klon,klev) ! quantite de neige fondue
+!c
+      REAL ptd(klon,klev)    ! temperature du panache descendant (p-d)
+      REAL pqd(klon,klev)    ! humidite du p-d
+      REAL pmfd(klon,klev)   ! flux de masse du p-d
+      REAL pmfds(klon,klev)  ! flux de l'energie seche dans le p-d
+      REAL pmfdq(klon,klev)  ! flux de l'humidite dans le p-d
+      REAL pdmfdp(klon,klev) ! quantite de precipitation dans p-d
+!c
+      REAL pen_u(klon,klev) ! quantite de masse entrainee pour p-a
+      REAL pde_u(klon,klev) ! quantite de masse detrainee pour p-a
+      REAL pen_d(klon,klev) ! quantite de masse entrainee pour p-d
+      REAL pde_d(klon,klev) ! quantite de masse detrainee pour p-d
+!C
+      INTEGER  klab(klon,klev)
+      LOGICAL  llflag(klon)
+      INTEGER k, i, icall
+      REAL zzs
+!C----------------------------------------------------------------------
+!C SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS
+!C ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE
+!C----------------------------------------------------------------------
+      DO 130 k = 2, klev
+!c
+      DO i = 1, klon
+         pgeoh(i,k)=pgeo(i,k)+(pgeo(i,k-1)-pgeo(i,k))*0.5
+         ptenh(i,k)=(MAX(RCPD*pten(i,k-1)+pgeo(i,k-1),                               &
+       &             RCPD*pten(i,k)+pgeo(i,k))-pgeoh(i,k))/RCPD
+         pqsenh(i,k)=pqsen(i,k-1)
+         llflag(i)=.TRUE.
+      ENDDO
+!c
+      icall=0
+      CALL flxadjtq(paph(1,k),ptenh(1,k),pqsenh(1,k),llflag,icall)
+!c
+      DO i = 1, klon
+         pqenh(i,k)=MIN(pqen(i,k-1),pqsen(i,k-1))                                    &
+       &               +(pqsenh(i,k)-pqsen(i,k-1))
+         pqenh(i,k)=MAX(pqenh(i,k),0.)
+      ENDDO
+!c
+  130 CONTINUE
+!C
+      DO 140 i = 1, klon
+         ptenh(i,klev)=(RCPD*pten(i,klev)+pgeo(i,klev)-                              &
+       &                   pgeoh(i,klev))/RCPD
+         pqenh(i,klev)=pqen(i,klev)
+         ptenh(i,1)=pten(i,1)
+         pqenh(i,1)=pqen(i,1)
+         pgeoh(i,1)=pgeo(i,1)
+  140 CONTINUE
+!c
+      DO 160 k = klev-1, 2, -1
+      DO 150 i = 1, klon
+         zzs = MAX(RCPD*ptenh(i,k)+pgeoh(i,k),                                       &
+       &             RCPD*ptenh(i,k+1)+pgeoh(i,k+1))
+         ptenh(i,k) = (zzs-pgeoh(i,k))/RCPD
+  150 CONTINUE
+  160 CONTINUE
+!C
+!C-----------------------------------------------------------------------
+!C INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS
+!C-----------------------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         ptu(i,k) = ptenh(i,k)
+         pqu(i,k) = pqenh(i,k)
+         plu(i,k) = 0.
+         pmfu(i,k) = 0.
+         pmfus(i,k) = 0.
+         pmfuq(i,k) = 0.
+         pdmfup(i,k) = 0.
+         pdpmel(i,k) = 0.
+         plude(i,k) = 0.
+!c
+         klab(i,k) = 0
+!c
+         ptd(i,k) = ptenh(i,k)
+         pqd(i,k) = pqenh(i,k)
+         pmfd(i,k) = 0.0
+         pmfds(i,k) = 0.0
+         pmfdq(i,k) = 0.0
+         pdmfdp(i,k) = 0.0
+!c
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         pen_d(i,k) = 0.0
+         pde_d(i,k) = 0.0
+      ENDDO
+      ENDDO
+!C
+      RETURN
+      END
+      SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph,                                  &
+       &     ptu, pqu, plu, ldcum, kcbot, klab)
+      USE dimphy
+      IMPLICIT none
+!C----------------------------------------------------------------------
+!C THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
+!C
+!C INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
+!C IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
+!C   klab=1 FOR SUBCLOUD LEVELS
+!C   klab=2 FOR CONDENSATION LEVEL
+!C
+!C LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
+!C (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
+!C----------------------------------------------------------------------
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+!C       ----------------------------------------------------------------
+      REAL ptenh(klon,klev), pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+!C
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      INTEGER  klab(klon,klev), kcbot(klon)
+!C
+      LOGICAL llflag(klon), ldcum(klon)
+      INTEGER i, k, icall, is
+      REAL zbuo, zqold(klon)
+!C----------------------------------------------------------------------
+!C INITIALIZE VALUES AT LIFTING LEVEL
+!C----------------------------------------------------------------------
+      DO i = 1, klon
+         klab(i,klev)=1
+         kcbot(i)=klev-1
+         ldcum(i)=.FALSE.
+      ENDDO
+!C----------------------------------------------------------------------
+!C DO ASCENT IN SUBCLOUD LAYER,
+!C CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
+!C ADJUST T,Q AND L ACCORDINGLY
+!C CHECK FOR BUOYANCY AND SET FLAGS
+!C----------------------------------------------------------------------
+      DO 290 k = klev-1, 2, -1
+!c
+      is = 0
+      DO i = 1, klon
+         IF (klab(i,k+1).EQ.1) is = is + 1
+         llflag(i) = .FALSE.
+         IF (klab(i,k+1).EQ.1) llflag(i) = .TRUE.
+      ENDDO
+      IF (is.EQ.0) GOTO 290
+!c
+      DO i = 1, klon
+      IF(llflag(i)) THEN
+         pqu(i,k) = pqu(i,k+1)
+         ptu(i,k) = ptu(i,k+1)+(pgeoh(i,k+1)-pgeoh(i,k))/RCPD
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-                                         &
+       &          ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
+         IF (zbuo.GT.0.) klab(i,k) = 1
+         zqold(i) = pqu(i,k)
+      ENDIF
+      ENDDO
+!c
+      icall=1
+      CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+!c
+      DO i = 1, klon
+      IF (llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         plu(i,k) = plu(i,k) + zqold(i)-pqu(i,k)
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-                                         &
+       &          ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
+         IF (zbuo.GT.0.) kcbot(i) = k
+         IF (zbuo.GT.0.) ldcum(i) = .TRUE.
+      ENDIF
+      ENDDO
+!c
+  290 CONTINUE
+!c
+      RETURN
+      END
+      SUBROUTINE flxasc(pdtime, ptenh, pqenh, pten, pqen, pqsen,                     &
+       &     pgeo, pgeoh, pap, paph, pqte, pvervel,                                  &
+       &     ldland, ldcum, ktype, klab, ptu, pqu, plu,                              &
+       &     pmfu, pmfub, pentr, pmfus, pmfuq,                                       &
+       &     pmful, plude, pdmfup, kcbot, kctop, kctop0, kcum,                       &
+       &     pen_u, pde_u)
+      USE dimphy
+      IMPLICIT none
+!C----------------------------------------------------------------------
+!C THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS
+!C FOR CUMULUS PARAMETERIZATION
+!C----------------------------------------------------------------------
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+!C
+      REAL pdtime
+      REAL pten(klon,klev), ptenh(klon,klev)
+      REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev)
+      REAL pgeo(klon,klev), pgeoh(klon,klev)
+      REAL pap(klon,klev), paph(klon,klev+1)
+      REAL pqte(klon,klev)
+      REAL pvervel(klon,klev) ! vitesse verticale en Pa/s
+!C
+      REAL pmfub(klon), pentr(klon)
+      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
+      REAL plude(klon,klev)
+      REAL pmfu(klon,klev), pmfus(klon,klev)
+      REAL pmfuq(klon,klev), pmful(klon,klev)
+      REAL pdmfup(klon,klev)
+      INTEGER ktype(klon), klab(klon,klev), kcbot(klon), kctop(klon)
+      INTEGER kctop0(klon)
+      LOGICAL ldland(klon), ldcum(klon)
+!C
+      REAL pen_u(klon,klev), pde_u(klon,klev)
+      REAL zqold(klon)
+      REAL zdland(klon)
+      LOGICAL llflag(klon)
+      INTEGER k, i, is, icall, kcum
+      REAL ztglace, zdphi, zqeen, zseen, zscde, zqude
+      REAL zmfusk, zmfuqk, zmfulk, zbuo, zdnoprc, zprcon, zlnew
+!c
+      REAL zpbot(klon), zptop(klon), zrho(klon)
+      REAL zdprho, zentr, zpmid, zmftest, zmfmax
+      LOGICAL llo1, llo2
+!c
+      REAL zwmax(klon), zzzmb
+      INTEGER klwmin(klon) ! level of maximum vertical velocity
+!C----------------------------------------------------------------------
+      ztglace = RTT - 13.
+!c
+!c Chercher le niveau ou la vitesse verticale est maximale:
+      DO i = 1, klon
+         klwmin(i) = klev
+         zwmax(i) = 0.0
+      ENDDO
+      DO k = klev, 3, -1
+      DO i = 1, klon
+      IF (pvervel(i,k).LT.zwmax(i)) THEN
+         zwmax(i) = pvervel(i,k)
+         klwmin(i) = k
+      ENDIF
+      ENDDO
+      ENDDO
+!C----------------------------------------------------------------------
+!C SET DEFAULT VALUES
+!C----------------------------------------------------------------------
+      DO i = 1, klon
+         IF (.NOT.ldcum(i)) ktype(i)=0
+      ENDDO
+!c
+      DO k=1,klev
+      DO i = 1, klon
+         plu(i,k)=0.
+         pmfu(i,k)=0.
+         pmfus(i,k)=0.
+         pmfuq(i,k)=0.
+         pmful(i,k)=0.
+         plude(i,k)=0.
+         pdmfup(i,k)=0.
+         IF(.NOT.ldcum(i).OR.ktype(i).EQ.3) klab(i,k)=0
+         IF(.NOT.ldcum(i).AND.paph(i,k).LT.4.E4) kctop0(i)=k
+      ENDDO
+      ENDDO
+!c
+      DO i = 1, klon
+      IF (ldland(i)) THEN
+         zdland(i)=3.0E4
+         zdphi=pgeoh(i,kctop0(i))-pgeoh(i,kcbot(i))
+         IF (ptu(i,kctop0(i)).GE.ztglace) zdland(i)=zdphi
+         zdland(i)=MAX(3.0E4,zdland(i))
+         zdland(i)=MIN(5.0E4,zdland(i))
+      ENDIF
+      ENDDO
+!C
+!C Initialiser les valeurs au niveau d'ascendance
+!C
+      DO i = 1, klon
+         kctop(i) = klev-1
+         IF (.NOT.ldcum(i)) THEN
+            kcbot(i) = klev-1
+            pmfub(i) = 0.
+            pqu(i,klev) = 0.
+         ENDIF
+         pmfu(i,klev) = pmfub(i)
+         pmfus(i,klev) = pmfub(i)*(RCPD*ptu(i,klev)+pgeoh(i,klev))
+         pmfuq(i,klev) = pmfub(i)*pqu(i,klev)
+      ENDDO
+!c
+      DO i = 1, klon
+         ldcum(i) = .FALSE.
+      ENDDO
+!C----------------------------------------------------------------------
+!C  DO ASCENT: SUBCLOUD LAYER (klab=1) ,CLOUDS (klab=2)
+!C  BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN
+!C  BY ADJUSTING T,Q AND L ACCORDINGLY IN *flxadjtq*,
+!C  THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY
+!C----------------------------------------------------------------------
+      DO 480 k = klev-1,3,-1
+!c
+      IF (LMFMID .AND. k.LT.klev-1 .AND. k.GT.klev/2) THEN
+         DO i = 1, klon
+         IF (.NOT.ldcum(i) .AND. klab(i,k+1).EQ.0 .AND.                              &
+       &       pqen(i,k).GT.0.9*pqsen(i,k)) THEN
+            ptu(i,k+1) = pten(i,k) +(pgeo(i,k)-pgeoh(i,k+1))/RCPD
+            pqu(i,k+1) = pqen(i,k)
+            plu(i,k+1) = 0.0
+            zzzmb = MAX(CMFCMIN, -pvervel(i,k)/RG)
+            zmfmax = (paph(i,k)-paph(i,k-1))/(RG*pdtime)
+            pmfub(i) = MIN(zzzmb,zmfmax)
+            pmfu(i,k+1) = pmfub(i)
+            pmfus(i,k+1) = pmfub(i)*(RCPD*ptu(i,k+1)+pgeoh(i,k+1))
+            pmfuq(i,k+1) = pmfub(i)*pqu(i,k+1)
+            pmful(i,k+1) = 0.0
+            pdmfup(i,k+1) = 0.0
+            kcbot(i) = k
+            klab(i,k+1) = 1
+            ktype(i) = 3
+            pentr(i) = ENTRMID
+         ENDIF
+         ENDDO
+      ENDIF
+!c
+      is = 0
+      DO i = 1, klon
+         is = is + klab(i,k+1)
+         IF (klab(i,k+1) .EQ. 0) klab(i,k) = 0
+         llflag(i) = .FALSE.
+         IF (klab(i,k+1) .GT. 0) llflag(i) = .TRUE.
+      ENDDO
+      IF (is .EQ. 0) GOTO 480
+!c
+!c calculer le taux d'entrainement et de detrainement
+!c
+      DO i = 1, klon
+         pen_u(i,k) = 0.0
+         pde_u(i,k) = 0.0
+         zrho(i)=paph(i,k+1)/(RD*ptenh(i,k+1))
+         zpbot(i)=paph(i,kcbot(i))
+         zptop(i)=paph(i,kctop0(i))
+      ENDDO
+!c
+      DO 125 i = 1, klon
+      IF(ldcum(i)) THEN
+         zdprho=(paph(i,k+1)-paph(i,k))/(RG*zrho(i))
+         zentr=pentr(i)*pmfu(i,k+1)*zdprho
+         llo1=k.LT.kcbot(i)
+         IF(llo1) pde_u(i,k)=zentr
+         zpmid=0.5*(zpbot(i)+zptop(i))
+         llo2=llo1.AND.ktype(i).EQ.2.AND.                                            &
+       &        (zpbot(i)-paph(i,k).LT.0.2E5.OR.                                     &
+       &         paph(i,k).GT.zpmid)
+         IF(llo2) pen_u(i,k)=zentr
+         llo2=llo1.AND.(ktype(i).EQ.1.OR.ktype(i).EQ.3).AND.                         &
+       &        (k.GE.MAX(klwmin(i),kctop0(i)+2).OR.pap(i,k).GT.zpmid)
+         IF(llo2) pen_u(i,k)=zentr
+         llo1=pen_u(i,k).GT.0..AND.(ktype(i).EQ.1.OR.ktype(i).EQ.2)
+         IF(llo1) THEN
+            zentr=zentr*(1.+3.*(1.-MIN(1.,(zpbot(i)-pap(i,k))/1.5E4)))
+            pen_u(i,k)=pen_u(i,k)*(1.+3.*(1.-MIN(1.,                                 &
+       &                 (zpbot(i)-pap(i,k))/1.5E4)))
+            pde_u(i,k)=pde_u(i,k)*(1.+3.*(1.-MIN(1.,                                 &
+       &                 (zpbot(i)-pap(i,k))/1.5E4)))
+         ENDIF
+         IF(llo2.AND.pqenh(i,k+1).GT.1.E-5)                                          &
+       &   pen_u(i,k)=zentr+MAX(pqte(i,k),0.)/pqenh(i,k+1)*                          &
+       &              zrho(i)*zdprho
+      ENDIF
+  125 CONTINUE
+!c
+!C----------------------------------------------------------------------
+!c DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME
+!C----------------------------------------------------------------------
+!c
+      DO 420 i = 1, klon
+      IF (llflag(i)) THEN
+         IF (k.LT.kcbot(i)) THEN
+            zmftest = pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k)
+            zmfmax = MIN(zmftest,(paph(i,k)-paph(i,k-1))/(RG*pdtime))
+            pen_u(i,k)=MAX(pen_u(i,k)-MAX(0.0,zmftest-zmfmax),0.0)
+         ENDIF
+         pde_u(i,k)=MIN(pde_u(i,k),0.75*pmfu(i,k+1))
+!c calculer le flux de masse du niveau k a partir de celui du k+1
+         pmfu(i,k)=pmfu(i,k+1)+pen_u(i,k)-pde_u(i,k)
+!c calculer les valeurs Su, Qu et l du niveau k dans le panache montant
+         zqeen=pqenh(i,k+1)*pen_u(i,k)
+         zseen=(RCPD*ptenh(i,k+1)+pgeoh(i,k+1))*pen_u(i,k)
+         zscde=(RCPD*ptu(i,k+1)+pgeoh(i,k+1))*pde_u(i,k)
+         zqude=pqu(i,k+1)*pde_u(i,k)
+         plude(i,k)=plu(i,k+1)*pde_u(i,k)
+         zmfusk=pmfus(i,k+1)+zseen-zscde
+         zmfuqk=pmfuq(i,k+1)+zqeen-zqude
+         zmfulk=pmful(i,k+1)    -plude(i,k)
+         plu(i,k)=zmfulk*(1./MAX(CMFCMIN,pmfu(i,k)))
+         pqu(i,k)=zmfuqk*(1./MAX(CMFCMIN,pmfu(i,k)))
+         ptu(i,k)=(zmfusk*(1./MAX(CMFCMIN,pmfu(i,k)))-                               &
+       &               pgeoh(i,k))/RCPD
+         ptu(i,k)=MAX(100.,ptu(i,k))
+         ptu(i,k)=MIN(400.,ptu(i,k))
+         zqold(i)=pqu(i,k)
+      ELSE
+         zqold(i)=0.0
+      ENDIF
+  420 CONTINUE
+!c
+!C----------------------------------------------------------------------
+!c DO CORRECTIONS FOR MOIST ASCENT BY ADJUSTING T,Q AND L
+!C----------------------------------------------------------------------
+!c
+      icall = 1
+      CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
+!C
+      DO 440 i = 1, klon
+      IF(llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
+         klab(i,k) = 2
+         plu(i,k) = plu(i,k)+zqold(i)-pqu(i,k)
+         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))-                                         &
+       &          ptenh(i,k)*(1.+RETV*pqenh(i,k))
+         IF (klab(i,k+1).EQ.1) zbuo=zbuo+0.5
+         IF (zbuo.GT.0..AND.pmfu(i,k).GE.0.1*pmfub(i)) THEN
+            kctop(i) = k
+            ldcum(i) = .TRUE.
+            zdnoprc = 1.5E4
+            IF (ldland(i)) zdnoprc = zdland(i)
+            zprcon = CPRCON
+            IF ((zpbot(i)-paph(i,k)).LT.zdnoprc) zprcon = 0.0
+            zlnew=plu(i,k)/(1.+zprcon*(pgeoh(i,k)-pgeoh(i,k+1)))
+            pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k))
+            plu(i,k)=zlnew
+         ELSE
+            klab(i,k)=0
+            pmfu(i,k)=0.
+         ENDIF
+      ENDIF
+  440 CONTINUE
+      DO 455 i = 1, klon
+      IF (llflag(i)) THEN
+         pmful(i,k)=plu(i,k)*pmfu(i,k)
+         pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k)
+         pmfuq(i,k)=pqu(i,k)*pmfu(i,k)
+      ENDIF
+  455 CONTINUE
+!C
+  480 CONTINUE
+!C----------------------------------------------------------------------
+!C DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
+!C    (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT
+!C           AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN
+!C           FROM PREVIOUS CALCULATIONS ABOVE)
+!C----------------------------------------------------------------------
+      DO i = 1, klon
+         IF (kctop(i).EQ.klev-1) ldcum(i) = .FALSE.
+         kcbot(i) = MAX(kcbot(i),kctop(i))
+      ENDDO
+!c
+      ldcum(1)=ldcum(1)
+!c
+      is = 0
+      DO i = 1, klon
+         if (ldcum(i)) is = is + 1
+      ENDDO
+      kcum = is
+      IF (is.EQ.0) GOTO 800
+!c
+      DO 530 i = 1, klon
+      IF (ldcum(i)) THEN
+         k=kctop(i)-1
+         pde_u(i,k)=(1.-CMFCTOP)*pmfu(i,k+1)
+         plude(i,k)=pde_u(i,k)*plu(i,k+1)
+         pmfu(i,k)=pmfu(i,k+1)-pde_u(i,k)
+         zlnew=plu(i,k)
+         pdmfup(i,k)=MAX(0.,(plu(i,k)-zlnew)*pmfu(i,k))
+         plu(i,k)=zlnew
+         pmfus(i,k)=(RCPD*ptu(i,k)+pgeoh(i,k))*pmfu(i,k)
+         pmfuq(i,k)=pqu(i,k)*pmfu(i,k)
+         pmful(i,k)=plu(i,k)*pmfu(i,k)
+         plude(i,k-1)=pmful(i,k)
+      ENDIF
+  530 CONTINUE
+!C
+  800 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxflux(pdtime, pqen, pqsen, ptenh, pqenh, pap                      &
+       &  ,  paph, ldland, pgeoh, kcbot, kctop, lddraf, kdtop                        &
+       &  ,  ktype, ldcum, pmfu, pmfd, pmfus, pmfds                                  &
+       &  ,  pmfuq, pmfdq, pmful, plude, pdmfup, pdmfdp                              &
+       &  ,  pten, prfl, psfl, pdpmel, ktopm2                                        &
+       &  ,  pmflxr, pmflxs)
+      USE dimphy
+      IMPLICIT none
+!C----------------------------------------------------------------------
+!C THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE
+!C FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER
+!C----------------------------------------------------------------------
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+!C
+      REAL cevapcu(klon,klev)
+!C     -----------------------------------------------------------------
+      REAL pqen(klon,klev), pqenh(klon,klev), pqsen(klon,klev)
+      REAL pten(klon,klev), ptenh(klon,klev)
+      REAL paph(klon,klev+1), pgeoh(klon,klev)
+!c
+      REAL pap(klon,klev)
+      REAL ztmsmlt, zdelta, zqsat
+!C
+      REAL pmfu(klon,klev), pmfus(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev)
+      REAL pmfuq(klon,klev), pmful(klon,klev)
+      REAL pmfdq(klon,klev)
+      REAL plude(klon,klev)
+      REAL pdmfup(klon,klev), pdpmel(klon,klev)
+!cjq The variable maxpdmfdp(klon) has been introduced by Olivier Boucher
+!cjq 14/11/00 to fix the problem with the negative precipitation.      
+      REAL pdmfdp(klon,klev), maxpdmfdp(klon,klev) 
+      REAL prfl(klon), psfl(klon)
+      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)
+      INTEGER  kcbot(klon), kctop(klon), ktype(klon)
+      LOGICAL  ldland(klon), ldcum(klon)
+      INTEGER k, kp, i
+      REAL zcons1, zcons2, zcucov, ztmelp2
+      REAL pdtime, zdp, zzp, zfac, zsnmlt, zrfl, zrnew
+      REAL zrmin, zrfln, zdrfl
+      REAL zpds, zpdr, zdenom
+      INTEGER ktopm2, itop, ikb
+!c
+      LOGICAL lddraf(klon)
+      INTEGER kdtop(klon)
+!c
+#include "FCTTRE.h"
+!c
+      DO 101 k=1,klev
+        DO i=1,klon
+      CEVAPCU(i,k)=1.93E-6*261.*SQRT(1.E3/(38.3*0.293)                               &
+       & *SQRT(0.5*(paph(i,k)+paph(i,k+1))/paph(i,klev+1)) ) * 0.5/RG
+        ENDDO
+ 101  CONTINUE
+!c
+!c SPECIFY CONSTANTS
+!c
+      zcons1 = RCPD/(RLMLT*RG*pdtime)
+      zcons2 = 1./(RG*pdtime)
+      zcucov = 0.05
+      ztmelp2 = RTT + 2.
+!c
+!c DETERMINE FINAL CONVECTIVE FLUXES
+!c
+      itop=klev
+      DO 110 i = 1, klon
+         itop=MIN(itop,kctop(i))
+         IF (.NOT.ldcum(i) .OR. kdtop(i).LT.kctop(i)) lddraf(i)=.FALSE.
+         IF(.NOT.ldcum(i)) ktype(i)=0
+  110 CONTINUE
+!c
+      ktopm2=itop-2
+      DO 120 k=ktopm2,klev
+      DO 115 i = 1, klon
+      IF(ldcum(i).AND.k.GE.kctop(i)-1) THEN
+         pmfus(i,k)=pmfus(i,k)-pmfu(i,k)*                                            &
+       &                (RCPD*ptenh(i,k)+pgeoh(i,k))
+         pmfuq(i,k)=pmfuq(i,k)-pmfu(i,k)*pqenh(i,k)
+         zdp = 1.5E4
+         IF ( ldland(i) ) zdp = 3.E4
+!c
+!c        l'eau liquide detrainee est precipitee quand certaines
+!c        conditions sont reunies (sinon, elle est consideree
+!c        evaporee dans l'environnement)
+!c
+         IF(paph(i,kcbot(i))-paph(i,kctop(i)).GE.zdp.AND.                            &
+       &      pqen(i,k-1).GT.0.8*pqsen(i,k-1))                                       &
+       &      pdmfup(i,k-1)=pdmfup(i,k-1)+plude(i,k-1)
+!c
+         IF(lddraf(i).AND.k.GE.kdtop(i)) THEN
+            pmfds(i,k)=pmfds(i,k)-pmfd(i,k)*                                         &
+       &                   (RCPD*ptenh(i,k)+pgeoh(i,k))
+            pmfdq(i,k)=pmfdq(i,k)-pmfd(i,k)*pqenh(i,k)
+         ELSE
+            pmfd(i,k)=0.
+            pmfds(i,k)=0.
+            pmfdq(i,k)=0.
+            pdmfdp(i,k-1)=0.
+         END IF
+      ELSE
+         pmfu(i,k)=0.
+         pmfus(i,k)=0.
+         pmfuq(i,k)=0.
+         pmful(i,k)=0.
+         pdmfup(i,k-1)=0.
+         plude(i,k-1)=0.
+         pmfd(i,k)=0.
+         pmfds(i,k)=0.
+         pmfdq(i,k)=0.
+         pdmfdp(i,k-1)=0.
+      ENDIF
+  115 CONTINUE
+  120 CONTINUE
+!c
+      DO 130 k=ktopm2,klev
+      DO 125 i = 1, klon
+      IF(ldcum(i).AND.k.GT.kcbot(i)) THEN
+         ikb=kcbot(i)
+         zzp=((paph(i,klev+1)-paph(i,k))/                                            &
+       &        (paph(i,klev+1)-paph(i,ikb)))
+         IF (ktype(i).EQ.3) zzp = zzp**2
+         pmfu(i,k)=pmfu(i,ikb)*zzp
+         pmfus(i,k)=pmfus(i,ikb)*zzp
+         pmfuq(i,k)=pmfuq(i,ikb)*zzp
+         pmful(i,k)=pmful(i,ikb)*zzp
+      ENDIF
+  125 CONTINUE
+  130 CONTINUE
+!c
+!c CALCULATE RAIN/SNOW FALL RATES
+!c CALCULATE MELTING OF SNOW
+!c CALCULATE EVAPORATION OF PRECIP
+!c
+      DO k = 1, klev+1
+      DO i = 1, klon
+         pmflxr(i,k) = 0.0
+         pmflxs(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO k = ktopm2, klev
+      DO i = 1, klon
+      IF (ldcum(i)) THEN
+         IF (pmflxs(i,k).GT.0.0 .AND. pten(i,k).GT.ztmelp2) THEN
+            zfac=zcons1*(paph(i,k+1)-paph(i,k))
+            zsnmlt=MIN(pmflxs(i,k),zfac*(pten(i,k)-ztmelp2))
+            pdpmel(i,k)=zsnmlt
+            ztmsmlt=pten(i,k)-zsnmlt/zfac
+            zdelta=MAX(0.,SIGN(1.,RTT-ztmsmlt))
+            zqsat=R2ES*FOEEW(ztmsmlt, zdelta) / pap(i,k)
+            zqsat=MIN(0.5,zqsat)
+            zqsat=zqsat/(1.-RETV  *zqsat)
+            pqsen(i,k) = zqsat
+         ENDIF
+         IF (pten(i,k).GT.RTT) THEN
+         pmflxr(i,k+1)=pmflxr(i,k)+pdmfup(i,k)+pdmfdp(i,k)+pdpmel(i,k)
+         pmflxs(i,k+1)=pmflxs(i,k)-pdpmel(i,k)
+         ELSE
+           pmflxs(i,k+1)=pmflxs(i,k)+pdmfup(i,k)+pdmfdp(i,k)
+           pmflxr(i,k+1)=pmflxr(i,k)
+         ENDIF
+!c        si la precipitation est negative, on ajuste le plux du
+!c        panache descendant pour eliminer la negativite
+         IF ((pmflxr(i,k+1)+pmflxs(i,k+1)).LT.0.0) THEN
+            pdmfdp(i,k) = -pmflxr(i,k)-pmflxs(i,k)-pdmfup(i,k)
+            pmflxr(i,k+1) = 0.0
+            pmflxs(i,k+1) = 0.0
+            pdpmel(i,k) = 0.0
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+!c
+!cjq The new variable is initialized here.
+!cjq It contains the humidity which is fed to the downdraft
+!cjq by evaporation of precipitation in the column below the base
+!cjq of convection.
+!cjq 
+!cjq In the former version, this term has been subtracted from precip
+!cjq as well as the evaporation.
+!cjq      
+      DO k = 1, klev
+      DO i = 1, klon 
+         maxpdmfdp(i,k)=0.0
+      ENDDO
+      ENDDO
+      DO k = 1, klev
+       DO kp = k, klev
+        DO i = 1, klon
+         maxpdmfdp(i,k)=maxpdmfdp(i,k)+pdmfdp(i,kp)
+        ENDDO
+       ENDDO
+      ENDDO
+!cjq End of initialization
+!c      
+      DO k = ktopm2, klev
+      DO i = 1, klon
+      IF (ldcum(i) .AND. k.GE.kcbot(i)) THEN
+         zrfl = pmflxr(i,k) + pmflxs(i,k)
+         IF (zrfl.GT.1.0E-20) THEN
+            zrnew=(MAX(0.,SQRT(zrfl/zcucov)-                                         &
+       &            CEVAPCU(i,k)*(paph(i,k+1)-paph(i,k))*                            &
+       &            MAX(0.,pqsen(i,k)-pqen(i,k))))**2*zcucov
+            zrmin=zrfl-zcucov*MAX(0.,0.8*pqsen(i,k)-pqen(i,k))                       &
+       &            *zcons2*(paph(i,k+1)-paph(i,k))
+            zrnew=MAX(zrnew,zrmin)
+            zrfln=MAX(zrnew,0.)
+            zdrfl=MIN(0.,zrfln-zrfl)
+!cjq At least the amount of precipiation needed to feed the downdraft
+!cjq with humidity below the base of convection has to be left and can't
+!cjq be evaporated (surely the evaporation can't be positive):            
+            zdrfl=MAX(zdrfl,                                                         &
+       &            MIN(-pmflxr(i,k)-pmflxs(i,k)-maxpdmfdp(i,k),0.0))
+!cjq End of insertion
+!c            
+            zdenom=1.0/MAX(1.0E-20,pmflxr(i,k)+pmflxs(i,k))
+            IF (pten(i,k).GT.RTT) THEN
+               zpdr = pdmfdp(i,k)
+               zpds = 0.0
+            ELSE
+               zpdr = 0.0
+               zpds = pdmfdp(i,k)
+            ENDIF
+            pmflxr(i,k+1) = pmflxr(i,k) + zpdr + pdpmel(i,k)                         &
+       &                    + zdrfl*pmflxr(i,k)*zdenom
+            pmflxs(i,k+1) = pmflxs(i,k) + zpds - pdpmel(i,k)                         &
+       &                    + zdrfl*pmflxs(i,k)*zdenom
+            pdmfup(i,k) = pdmfup(i,k) + zdrfl
+         ELSE
+            pmflxr(i,k+1) = 0.0
+            pmflxs(i,k+1) = 0.0
+            pdmfdp(i,k) = 0.0
+            pdpmel(i,k) = 0.0
+         ENDIF         
+         if (pmflxr(i,k) + pmflxs(i,k).lt.-1.e-26)                                   &
+       &    write(*,*) 'precip. < 1e-16 ',pmflxr(i,k) + pmflxs(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+!c
+      DO 210 i = 1, klon
+         prfl(i) = pmflxr(i,klev+1)
+         psfl(i) = pmflxs(i,klev+1)
+  210 CONTINUE
+!c
+      RETURN
+      END
+      SUBROUTINE flxdtdq(pdtime, ktopm2, paph, ldcum, pten                           &
+       &  ,  pmfus, pmfds, pmfuq, pmfdq, pmful, pdmfup, pdmfdp                       &
+       &  ,  pdpmel, dt_con, dq_con)
+      USE dimphy
+      IMPLICIT none
+!c----------------------------------------------------------------------
+!c calculer les tendances T et Q
+!c----------------------------------------------------------------------
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+!C     -----------------------------------------------------------------
+      LOGICAL  llo1
+!C
+      REAL pten(klon,klev), paph(klon,klev+1)
+      REAL pmfus(klon,klev), pmfuq(klon,klev), pmful(klon,klev)
+      REAL pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfup(klon,klev)
+      REAL pdmfdp(klon,klev)
+      REAL pdpmel(klon,klev)
+      LOGICAL ldcum(klon)
+      REAL dt_con(klon,klev), dq_con(klon,klev)
+!c
+      INTEGER ktopm2
+      REAL pdtime
+!c
+      INTEGER i, k
+      REAL zalv, zdtdt, zdqdt
+!c
+      DO 210 k=ktopm2,klev-1
+      DO 220 i = 1, klon
+      IF (ldcum(i)) THEN
+         llo1 = (pten(i,k)-RTT).GT.0.
+         zalv = RLSTT
+         IF (llo1) zalv = RLVTT
+         zdtdt=RG/(paph(i,k+1)-paph(i,k))/RCPD                                       &
+       &        *(pmfus(i,k+1)-pmfus(i,k)                                            &
+       &         +pmfds(i,k+1)-pmfds(i,k)                                            &
+       &          -RLMLT*pdpmel(i,k)                                                 &
+       &          -zalv*(pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))            &
+       &         )
+         dt_con(i,k)=zdtdt
+         zdqdt=RG/(paph(i,k+1)-paph(i,k))                                            &
+       &        *(pmfuq(i,k+1)-pmfuq(i,k)                                            &
+       &         +pmfdq(i,k+1)-pmfdq(i,k)                                            &
+       &          +pmful(i,k+1)-pmful(i,k)-pdmfup(i,k)-pdmfdp(i,k))
+         dq_con(i,k)=zdqdt
+      ENDIF
+  220 CONTINUE
+  210 CONTINUE
+!C
+      k = klev
+      DO 230 i = 1, klon
+      IF (ldcum(i)) THEN
+         llo1 = (pten(i,k)-RTT).GT.0.
+         zalv = RLSTT
+         IF (llo1) zalv = RLVTT
+         zdtdt=-RG/(paph(i,k+1)-paph(i,k))/RCPD                                      &
+       &         *(pmfus(i,k)+pmfds(i,k)+RLMLT*pdpmel(i,k)                           &
+       &           -zalv*(pmful(i,k)+pdmfup(i,k)+pdmfdp(i,k)))
+         dt_con(i,k)=zdtdt
+         zdqdt=-RG/(paph(i,k+1)-paph(i,k))                                           &
+       &            *(pmfuq(i,k)+pmfdq(i,k)+pmful(i,k)                               &
+       &             +pdmfup(i,k)+pdmfdp(i,k))
+         dq_con(i,k)=zdqdt
+      ENDIF
+  230 CONTINUE
+!C
+      RETURN
+      END
+      SUBROUTINE flxdlfs(ptenh, pqenh, pgeoh, paph, ptu, pqu,                        &
+       &     ldcum, kcbot, kctop, pmfub, prfl, ptd, pqd,                             &
+       &     pmfd, pmfds, pmfdq, pdmfdp, kdtop, lddraf)
+      USE dimphy
+      IMPLICIT none
+!C
+!C----------------------------------------------------------------------
+!C THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR
+!C CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES
+!C
+!C TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS
+!C FOR MASSFLUX CUMULUS PARAMETERIZATION
+!C
+!C INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI
+!C AND UPDRAFT VALUES T,Q,U AND V AND ALSO
+!C CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE.
+!C IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS.
+!C
+!C CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF
+!C MOIST ENVIRONMENTAL AIR AND CLOUD AIR.
+!C----------------------------------------------------------------------
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+!C
+      REAL ptenh(klon,klev)
+      REAL pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+      REAL ptu(klon,klev), pqu(klon,klev)
+      REAL pmfub(klon)
+      REAL prfl(klon)
+!C
+      REAL ptd(klon,klev), pqd(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfdp(klon,klev)
+      INTEGER  kcbot(klon), kctop(klon), kdtop(klon)
+      LOGICAL  ldcum(klon), lddraf(klon)
+!C
+      REAL ztenwb(klon,klev), zqenwb(klon,klev), zcond(klon)
+      REAL zttest, zqtest, zbuo, zmftop
+      LOGICAL  llo2(klon)
+      INTEGER i, k, is, icall
+!C----------------------------------------------------------------------
+      DO i= 1, klon
+         lddraf(i)=.FALSE.
+         kdtop(i)=klev+1
+      ENDDO
+!C
+!C----------------------------------------------------------------------
+!C DETERMINE LEVEL OF FREE SINKING BY
+!C DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS
+!C
+!C FOR EVERY POINT AND PROCEED AS FOLLOWS:
+!C     (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q
+!C     (2) DO MIXING WITH CUMULUS CLOUD AIR
+!C     (3) CHECK FOR NEGATIVE BUOYANCY
+!C
+!C THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE
+!C OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB
+!C TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO
+!C EVAPORATION OF RAIN AND CLOUD WATER)
+!C----------------------------------------------------------------------
+!C
+      DO 290 k = 3, klev-3
+!C
+      is=0
+      DO 212 i= 1, klon
+         ztenwb(i,k)=ptenh(i,k)
+         zqenwb(i,k)=pqenh(i,k)
+         llo2(i) = ldcum(i).AND.prfl(i).GT.0.                                        &
+       &             .AND..NOT.lddraf(i)                                             &
+       &             .AND.(k.LT.kcbot(i).AND.k.GT.kctop(i))
+         IF ( llo2(i) ) is = is + 1
+  212 CONTINUE
+      IF(is.EQ.0) GO TO 290
+!C
+      icall=2
+      CALL flxadjtq(paph(1,k), ztenwb(1,k), zqenwb(1,k), llo2, icall)
+!C
+!C----------------------------------------------------------------------
+!C DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR
+!C AND CHECK FOR NEGATIVE BUOYANCY.
+!C THEN SET VALUES FOR DOWNDRAFT AT LFS.
+!C----------------------------------------------------------------------
+      DO 222 i= 1, klon
+      IF (llo2(i)) THEN
+         zttest=0.5*(ptu(i,k)+ztenwb(i,k))
+         zqtest=0.5*(pqu(i,k)+zqenwb(i,k))
+         zbuo=zttest*(1.+RETV*zqtest)-                                               &
+       &        ptenh(i,k)*(1.+RETV  *pqenh(i,k))
+         zcond(i)=pqenh(i,k)-zqenwb(i,k)
+         zmftop=-CMFDEPS*pmfub(i)
+         IF (zbuo.LT.0..AND.prfl(i).GT.10.*zmftop*zcond(i)) THEN
+            kdtop(i)=k
+            lddraf(i)=.TRUE.
+            ptd(i,k)=zttest
+            pqd(i,k)=zqtest
+            pmfd(i,k)=zmftop
+            pmfds(i,k)=pmfd(i,k)*(RCPD*ptd(i,k)+pgeoh(i,k))
+            pmfdq(i,k)=pmfd(i,k)*pqd(i,k)
+            pdmfdp(i,k-1)=-0.5*pmfd(i,k)*zcond(i)
+            prfl(i)=prfl(i)+pdmfdp(i,k-1)
+         ENDIF
+      ENDIF
+  222 CONTINUE
+!c
+  290 CONTINUE
+!C
+      RETURN
+      END
+      SUBROUTINE flxddraf(ptenh, pqenh, pgeoh, paph, prfl,                           &
+       &           ptd, pqd, pmfd, pmfds, pmfdq, pdmfdp,                             &
+       &           lddraf, pen_d, pde_d)
+      USE dimphy
+      IMPLICIT none
+!C
+!C----------------------------------------------------------------------
+!C          THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
+!C
+!C          TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
+!C          (I.E. T,Q,U AND V AND FLUXES)
+!C
+!C          INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
+!C          IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
+!C          AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
+!C
+!C          CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
+!C          A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
+!C          B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
+!C
+!C----------------------------------------------------------------------
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "YOECUMF.h"
+!C
+      REAL ptenh(klon,klev), pqenh(klon,klev)
+      REAL pgeoh(klon,klev), paph(klon,klev+1)
+!C
+      REAL ptd(klon,klev), pqd(klon,klev)
+      REAL pmfd(klon,klev), pmfds(klon,klev), pmfdq(klon,klev)
+      REAL pdmfdp(klon,klev)
+      REAL prfl(klon)
+      LOGICAL lddraf(klon)
+!C
+      REAL pen_d(klon,klev), pde_d(klon,klev), zcond(klon)
+      LOGICAL llo2(klon), llo1
+      INTEGER i, k, is, icall, itopde
+      REAL zentr, zseen, zqeen, zsdde, zqdde, zmfdsk, zmfdqk, zdmfdp
+      REAL zbuo
+!C----------------------------------------------------------------------
+!C CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
+!C       (A) CALCULATING ENTRAINMENT RATES, ASSUMING
+!C           LINEAR DECREASE OF MASSFLUX IN PBL
+!C       (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
+!C           AND MOISTENING IS CALCULATED IN *flxadjtq*
+!C       (C) CHECKING FOR NEGATIVE BUOYANCY AND
+!C           SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
+!C
+      DO 180 k = 3, klev
+!c
+      is = 0
+      DO i = 1, klon
+         llo2(i)=lddraf(i).AND.pmfd(i,k-1).LT.0.
+         IF (llo2(i)) is = is + 1
+      ENDDO
+      IF (is.EQ.0) GOTO 180
+!c
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         zentr = ENTRDD*pmfd(i,k-1)*RD*ptenh(i,k-1)/                                 &
+       &           (RG*paph(i,k-1))*(paph(i,k)-paph(i,k-1))
+         pen_d(i,k) = zentr
+         pde_d(i,k) = zentr
+      ENDIF
+      ENDDO
+!c
+      itopde = klev-2
+      IF (k.GT.itopde) THEN
+         DO i = 1, klon
+         IF (llo2(i)) THEN
+            pen_d(i,k)=0.
+            pde_d(i,k)=pmfd(i,itopde)*                                               &
+       &      (paph(i,k)-paph(i,k-1))/(paph(i,klev+1)-paph(i,itopde))
+         ENDIF
+         ENDDO
+      ENDIF
+!C
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         pmfd(i,k) = pmfd(i,k-1)+pen_d(i,k)-pde_d(i,k)
+         zseen = (RCPD*ptenh(i,k-1)+pgeoh(i,k-1))*pen_d(i,k)
+         zqeen = pqenh(i,k-1)*pen_d(i,k)
+         zsdde = (RCPD*ptd(i,k-1)+pgeoh(i,k-1))*pde_d(i,k)
+         zqdde = pqd(i,k-1)*pde_d(i,k)
+         zmfdsk = pmfds(i,k-1)+zseen-zsdde
+         zmfdqk = pmfdq(i,k-1)+zqeen-zqdde
+         pqd(i,k) = zmfdqk*(1./MIN(-CMFCMIN,pmfd(i,k)))
+         ptd(i,k) = (zmfdsk*(1./MIN(-CMFCMIN,pmfd(i,k)))-                            &
+       &               pgeoh(i,k))/RCPD
+         ptd(i,k) = MIN(400.,ptd(i,k))
+         ptd(i,k) = MAX(100.,ptd(i,k))
+         zcond(i) = pqd(i,k)
+      ENDIF
+      ENDDO
+!C
+      icall = 2
+      CALL flxadjtq(paph(1,k), ptd(1,k), pqd(1,k), llo2, icall)
+!C
+      DO i = 1, klon
+      IF (llo2(i)) THEN
+         zcond(i) = zcond(i)-pqd(i,k)
+         zbuo = ptd(i,k)*(1.+RETV  *pqd(i,k))-                                       &
+       &          ptenh(i,k)*(1.+RETV  *pqenh(i,k))
+         llo1 = zbuo.LT.0..AND.(prfl(i)-pmfd(i,k)*zcond(i).GT.0.)
+         IF (.not.llo1) pmfd(i,k) = 0.0
+         pmfds(i,k) = (RCPD*ptd(i,k)+pgeoh(i,k))*pmfd(i,k)
+         pmfdq(i,k) = pqd(i,k)*pmfd(i,k)
+         zdmfdp = -pmfd(i,k)*zcond(i)
+         pdmfdp(i,k-1) = zdmfdp
+         prfl(i) = prfl(i)+zdmfdp
+      ENDIF
+      ENDDO
+!c
+  180 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxadjtq(pp, pt, pq, ldflag, kcall)
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Objet: ajustement entre T et Q
+!c======================================================================
+!C NOTE: INPUT PARAMETER kcall DEFINES CALCULATION AS
+!C        kcall=0    ENV. T AND QS IN*CUINI*
+!C        kcall=1  CONDENSATION IN UPDRAFTS  (E.G. CUBASE, CUASC)
+!C        kcall=2  EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF)
+!C
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!C
+      REAL pt(klon), pq(klon), pp(klon)
+      LOGICAL ldflag(klon)
+      INTEGER kcall
+!c
+      REAL zcond(klon), zcond1
+      REAL Z5alvcp, z5alscp, zalvdcp, zalsdcp
+      REAL zdelta, zcvm5, zldcp, zqsat, zcor
+      INTEGER is, i
+#include "YOETHF.h"
+#include "FCTTRE.h"
+!C
+      z5alvcp = r5les*RLVTT/RCPD
+      z5alscp = r5ies*RLSTT/RCPD
+      zalvdcp = rlvtt/RCPD
+      zalsdcp = rlstt/RCPD
+!C
+
+      DO i = 1, klon
+         zcond(i) = 0.0
+      ENDDO
+
+      DO 210 i =1, klon
+      IF (ldflag(i)) THEN
+         zdelta = MAX(0.,SIGN(1.,RTT-pt(i)))
+         zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+         zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+         zqsat = R2ES*FOEEW(pt(i),zdelta) / pp(i)
+         zqsat = MIN(0.5,zqsat)
+         zcor = 1./(1.-RETV*zqsat)
+         zqsat = zqsat*zcor
+         zcond(i) = (pq(i)-zqsat)                                                    &
+       &     / (1. + FOEDE(pt(i), zdelta, zcvm5, zqsat, zcor))
+         IF (kcall.EQ.1) zcond(i) = MAX(zcond(i),0.)
+         IF (kcall.EQ.2) zcond(i) = MIN(zcond(i),0.)
+         pt(i) = pt(i) + zldcp*zcond(i)
+         pq(i) = pq(i) - zcond(i)
+      ENDIF
+  210 CONTINUE
+!C
+      is = 0
+      DO i =1, klon
+         IF (zcond(i).NE.0.) is = is + 1
+      ENDDO
+      IF (is.EQ.0) GOTO 230
+!C
+      DO 220 i = 1, klon
+      IF(ldflag(i).AND.zcond(i).NE.0.) THEN
+         zdelta = MAX(0.,SIGN(1.,RTT-pt(i)))
+         zcvm5 = z5alvcp*(1.-zdelta) + zdelta*z5alscp
+         zldcp = zalvdcp*(1.-zdelta) + zdelta*zalsdcp
+         zqsat = R2ES* FOEEW(pt(i),zdelta) / pp(i)
+         zqsat = MIN(0.5,zqsat)
+         zcor = 1./(1.-RETV*zqsat)
+         zqsat = zqsat*zcor
+         zcond1 = (pq(i)-zqsat)                                                      &
+       &     / (1. + FOEDE(pt(i),zdelta,zcvm5,zqsat,zcor))
+         pt(i) = pt(i) + zldcp*zcond1
+         pq(i) = pq(i) - zcond1
+      ENDIF
+  220 CONTINUE
+!C
+  230 CONTINUE
+      RETURN
+      END
+      SUBROUTINE flxsetup
+      IMPLICIT none
+!C
+!C     THIS ROUTINE DEFINES DISPOSABLE PARAMETERS FOR MASSFLUX SCHEME
+!C
+#include "YOECUMF.h"
+!C
+      ENTRPEN=1.0E-4  ! ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+      ENTRSCV=3.0E-4  ! ENTRAINMENT RATE FOR SHALLOW CONVECTION
+      ENTRMID=1.0E-4  ! ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+      ENTRDD =2.0E-4  ! ENTRAINMENT RATE FOR DOWNDRAFTS
+      CMFCTOP=0.33  ! RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUO LEVEL
+      CMFCMAX=1.0  ! MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC
+      CMFCMIN=1.E-10  ! MINIMUM MASSFLUX VALUE (FOR SAFETY)
+      CMFDEPS=0.3  ! FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+      CPRCON =2.0E-4  ! CONVERSION FROM CLOUD WATER TO RAIN
+      RHCDD=1.  ! RELATIVE SATURATION IN DOWNDRAFRS (NO LONGER USED)
+!c                 (FORMULATION IMPLIES SATURATION)
+      LMFPEN = .TRUE.
+      LMFSCV = .TRUE.
+      LMFMID = .TRUE.
+      LMFDD = .TRUE.
+      LMFDUDV = .TRUE.
+!c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/control_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/control_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/control_mod.F90	(revision 17)
@@ -0,0 +1,27 @@
+!
+! $Id $
+!
+
+MODULE control_mod
+
+! LF 01/2010
+! Remplacement du fichier et common control
+
+  IMPLICIT NONE
+
+  REAL    :: periodav, starttime
+  INTEGER :: nday,day_step,iperiod,iapp_tracvl,nsplit_phys
+  INTEGER :: iconser,iecri,dissip_period,iphysiq,iecrimoy
+  INTEGER :: dayref,anneeref, raz_date, ip_ebil_dyn
+  LOGICAL :: offline
+  CHARACTER (len=4)  :: config_inca
+  CHARACTER (len=10) :: planet_type ! planet type ('earth','mars',...)
+  LOGICAL output_grads_dyn ! output dynamics diagnostics in
+                           ! binary grads file 'dyn.dat' (y/n)
+  LOGICAL ok_dynzon  ! output zonal transports in dynzon.nc file
+  LOGICAL ok_dyn_ins ! output instantaneous values of fields
+                     ! in the dynamics in NetCDF files dyn_hist*nc
+  LOGICAL ok_dyn_ave ! output averaged values of fields in the dynamics
+                     ! in NetCDF files dyn_hist*ave.nc
+
+END MODULE
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cpl_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cpl_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cpl_mod.F90	(revision 17)
@@ -0,0 +1,1403 @@
+!
+MODULE cpl_mod
+!
+! This module excahanges and transforms all fields that should be recieved or sent to 
+! coupler. The transformation of the fields are done from the grid 1D-array in phylmd 
+! to the regular 2D grid accepted by the coupler. Cumulation of the fields for each 
+! timestep is done in here. 
+!
+! Each type of surface that recevie fields from the coupler have a subroutine named 
+! cpl_receive_XXX_fields and each surface that have fields to be sent to the coupler 
+! have a subroutine named cpl_send_XXX_fields.
+!
+!*************************************************************************************
+
+! Use statements
+!*************************************************************************************
+  USE dimphy, ONLY : klon
+  USE mod_phys_lmdz_para
+  USE ioipsl
+  USE iophy
+
+! The module oasis is always used. Without the cpp key CPP_COUPLE only the parameters 
+! in the module are compiled and not the subroutines.
+  USE oasis
+  USE write_field_phy
+  USE control_mod
+
+  
+! Global attributes
+!*************************************************************************************
+  IMPLICIT NONE
+  PRIVATE
+
+  ! All subroutine are public except cpl_send_all
+  PUBLIC :: cpl_init, cpl_receive_frac, cpl_receive_ocean_fields, cpl_receive_seaice_fields, &
+       cpl_send_ocean_fields, cpl_send_seaice_fields, cpl_send_land_fields, &
+       cpl_send_landice_fields, gath2cpl
+  
+
+! Declaration of module variables
+!*************************************************************************************
+! variable for coupling period
+  INTEGER, SAVE :: nexca
+  !$OMP THREADPRIVATE(nexca)
+
+! variables for cumulating fields during a coupling periode :
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_sols, cpl_nsol, cpl_rain
+  !$OMP THREADPRIVATE(cpl_sols,cpl_nsol,cpl_rain)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_snow, cpl_evap, cpl_tsol
+  !$OMP THREADPRIVATE(cpl_snow,cpl_evap,cpl_tsol)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_fder, cpl_albe, cpl_taux, cpl_tauy
+  !$OMP THREADPRIVATE(cpl_fder,cpl_albe,cpl_taux,cpl_tauy)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_windsp
+  !$OMP THREADPRIVATE(cpl_windsp)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_taumod
+  !$OMP THREADPRIVATE(cpl_taumod)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_atm_co2
+  !$OMP THREADPRIVATE(cpl_atm_co2)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_rriv2D, cpl_rcoa2D, cpl_rlic2D
+  !$OMP THREADPRIVATE(cpl_rriv2D,cpl_rcoa2D,cpl_rlic2D)
+
+! variables read from coupler :
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sst     ! sea surface temperature
+  !$OMP THREADPRIVATE(read_sst)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sit     ! sea ice temperature
+  !$OMP THREADPRIVATE(read_sit)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_sic     ! sea ice fraction
+  !$OMP THREADPRIVATE(read_sic)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_alb_sic ! albedo at sea ice
+  !$OMP THREADPRIVATE(read_alb_sic)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_u0, read_v0 ! ocean surface current
+  !$OMP THREADPRIVATE(read_u0,read_v0)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: read_co2     ! ocean co2 flux 
+  !$OMP THREADPRIVATE(read_co2)
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: unity
+  !$OMP THREADPRIVATE(unity)
+  INTEGER, SAVE                             :: nidct, nidcs
+  !$OMP THREADPRIVATE(nidct,nidcs)
+
+! variables to be sent to the coupler
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_sols2D, cpl_nsol2D, cpl_rain2D
+  !$OMP THREADPRIVATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_snow2D, cpl_evap2D, cpl_tsol2D
+  !$OMP THREADPRIVATE(cpl_snow2D, cpl_evap2D, cpl_tsol2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_fder2D, cpl_albe2D
+  !$OMP THREADPRIVATE(cpl_fder2D, cpl_albe2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_taux2D, cpl_tauy2D
+  !$OMP THREADPRIVATE(cpl_taux2D, cpl_tauy2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: cpl_taumod2D
+  !$OMP THREADPRIVATE(cpl_taumod2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_windsp2D
+  !$OMP THREADPRIVATE(cpl_windsp2D)
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: cpl_atm_co22D
+  !$OMP THREADPRIVATE(cpl_atm_co22D)
+
+CONTAINS
+!
+!************************************************************************************
+!
+  SUBROUTINE cpl_init(dtime, rlon, rlat)
+    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, fco2_ocn_day
+    USE surface_data
+    USE indice_sol_mod
+
+    INCLUDE "dimensions.h"
+    INCLUDE "temps.h"
+    INCLUDE "iniprint.h"
+
+! Input arguments
+!*************************************************************************************
+    REAL, INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
+
+! Local variables
+!*************************************************************************************
+    INTEGER                           :: error, sum_error, ig, i
+    INTEGER                           :: jf, nhoridct
+    INTEGER                           :: nhoridcs
+    INTEGER                           :: idtime
+    INTEGER                           :: idayref
+    INTEGER                           :: npas ! only for OASIS2
+    REAL                              :: zjulian
+    REAL, DIMENSION(iim,jjm+1)        :: zx_lon, zx_lat
+    CHARACTER(len = 20)               :: modname = 'cpl_init'
+    CHARACTER(len = 80)               :: abort_message
+    CHARACTER(len=80)                 :: clintocplnam, clfromcplnam
+
+!*************************************************************************************
+! Calculate coupling period
+!
+!*************************************************************************************
+     
+    npas = itaufin/ iphysiq
+    nexca = 86400 / dtime
+    WRITE(lunout,*)' ##### Ocean couple #####'
+    WRITE(lunout,*)' Valeurs des pas de temps'
+    WRITE(lunout,*)' npas = ', npas
+    WRITE(lunout,*)' nexca = ', nexca
+    
+!*************************************************************************************
+! Allocate variables
+!
+!*************************************************************************************
+    error = 0
+    sum_error = 0
+
+    ALLOCATE(unity(klon), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_sols(klon,2), stat = error) 
+    sum_error = sum_error + error
+    ALLOCATE(cpl_nsol(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rain(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_snow(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_evap(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_tsol(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_fder(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_albe(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_taux(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_tauy(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_windsp(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_taumod(klon,2), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rriv2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rcoa2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(cpl_rlic2D(iim,jj_nb), stat=error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sst(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sic(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_sit(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_alb_sic(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_u0(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+    ALLOCATE(read_v0(iim, jj_nb), stat = error)
+    sum_error = sum_error + error
+
+    IF (carbon_cycle_cpl) THEN
+       ALLOCATE(read_co2(iim, jj_nb), stat = error)
+       sum_error = sum_error + error
+       ALLOCATE(cpl_atm_co2(klon,2), stat = error)
+       sum_error = sum_error + error
+
+! Allocate variable in carbon_cycle_mod
+       ALLOCATE(fco2_ocn_day(klon), stat = error)
+       sum_error = sum_error + error
+    END IF
+
+    IF (sum_error /= 0) THEN
+       abort_message='Pb allocation variables couplees'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+!*************************************************************************************
+! Initialize the allocated varaibles
+!
+!*************************************************************************************
+    DO ig = 1, klon
+       unity(ig) = ig
+    ENDDO
+
+!*************************************************************************************
+! Initialize coupling
+!
+!*************************************************************************************
+    idtime = INT(dtime)
+#ifdef CPP_COUPLE
+    CALL inicma
+#endif
+
+!*************************************************************************************
+! initialize NetCDF output
+!
+!*************************************************************************************
+    IF (is_sequential) THEN
+       idayref = day_ini
+       CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+       CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+       DO i = 1, iim
+          zx_lon(i,1) = rlon(i+1)
+          zx_lon(i,jjm+1) = rlon(i+1)
+       ENDDO
+       CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+       clintocplnam="cpl_atm_tauflx"
+       CALL histbeg(clintocplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),&
+            1,iim,1,jjm+1, itau_phy,zjulian,dtime,nhoridct,nidct) 
+! no vertical axis
+       CALL histdef(nidct, 'tauxe','tauxe', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tauyn','tauyn', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tmp_lon','tmp_lon', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       CALL histdef(nidct, 'tmp_lat','tmp_lat', &
+            "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+       DO jf=1,maxsend
+         IF (infosend(i)%action) THEN
+             CALL histdef(nidct, infosend(i)%name ,infosend(i)%name , &
+                "-",iim, jjm+1, nhoridct, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+         ENDIF
+       END DO
+       CALL histend(nidct)
+       CALL histsync(nidct)
+       
+       clfromcplnam="cpl_atm_sst"
+       CALL histbeg(clfromcplnam, iim,zx_lon(:,1),jjm+1,zx_lat(1,:),1,iim,1,jjm+1, &
+            0,zjulian,dtime,nhoridcs,nidcs) 
+! no vertical axis
+       DO jf=1,maxrecv
+         IF (inforecv(i)%action) THEN
+             CALL histdef(nidcs,inforecv(i)%name ,inforecv(i)%name , &
+                "-",iim, jjm+1, nhoridcs, 1, 1, 1, -99, 32, "inst", dtime,dtime)
+         ENDIF
+       END DO
+       CALL histend(nidcs)
+       CALL histsync(nidcs)
+
+    ENDIF    ! is_sequential
+    
+
+!*************************************************************************************
+! compatibility test
+!
+!*************************************************************************************
+    IF (carbon_cycle_cpl .AND. version_ocean=='opa8') THEN
+       abort_message='carbon_cycle_cpl does not work with opa8'
+       CALL abort_gcm(modname,abort_message,1)
+    END IF
+
+  END SUBROUTINE cpl_init
+  
+!
+!*************************************************************************************
+!
+ 
+  SUBROUTINE cpl_receive_frac(itime, dtime, pctsrf, is_modified)
+! This subroutine receives from coupler for both ocean and seaice
+! 4 fields : read_sst, read_sic, read_sit and read_alb_sic. 
+! The new sea-ice-land-landice fraction is returned. The others fields 
+! are stored in this module.
+    USE surface_data
+    USE phys_state_var_mod, ONLY : rlon, rlat
+    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
+    USE indice_sol_mod
+
+    INCLUDE "temps.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "dimensions.h"
+
+! Arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                        :: itime
+    REAL, INTENT(IN)                           :: dtime
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf
+    LOGICAL, INTENT(OUT)                       :: is_modified
+
+! Local variables
+!************************************************************************************
+    INTEGER                                 :: j, i, time_sec
+    INTEGER                                 :: itau_w
+    INTEGER, DIMENSION(iim*(jjm+1))         :: ndexcs
+    CHARACTER(len = 20)                     :: modname = 'cpl_receive_frac'
+    CHARACTER(len = 80)                     :: abort_message
+    REAL, DIMENSION(klon)                   :: read_sic1D
+    REAL, DIMENSION(iim,jj_nb,maxrecv)      :: tab_read_flds
+    REAL, DIMENSION(klon,nbsrf)             :: pctsrf_old
+    REAL, DIMENSION(klon_mpi)               :: rlon_mpi, rlat_mpi
+    REAL, DIMENSION(iim, jj_nb)             :: tmp_lon, tmp_lat
+    REAL, DIMENSION(iim, jj_nb)             :: tmp_r0
+
+!*************************************************************************************
+! Start calculation
+! Get fields from coupler
+!
+!*************************************************************************************
+
+    is_modified=.FALSE.
+
+! Check if right moment to receive from coupler
+    IF (MOD(itime, nexca) == 1) THEN
+       is_modified=.TRUE.
+ 
+       time_sec=(itime-1)*dtime
+#ifdef CPP_COUPLE
+!$OMP MASTER
+    CALL fromcpl(time_sec, tab_read_flds)
+!$OMP END MASTER
+#endif
+    
+! NetCDF output of received fields
+       IF (is_sequential) THEN
+          ndexcs(:) = 0
+          itau_w = itau_phy + itime + start_time * day_step / iphysiq
+          DO i = 1, maxrecv
+            IF (inforecv(i)%action) THEN
+                CALL histwrite(nidcs,inforecv(i)%name,itau_w,tab_read_flds(:,:,i),iim*(jjm+1),ndexcs)
+            ENDIF
+          END DO
+       ENDIF
+
+
+! Save each field in a 2D array. 
+!$OMP MASTER
+       read_sst(:,:)     = tab_read_flds(:,:,idr_sisutw)  ! Sea surface temperature
+       read_sic(:,:)     = tab_read_flds(:,:,idr_icecov)  ! Sea ice concentration
+       read_alb_sic(:,:) = tab_read_flds(:,:,idr_icealw)  ! Albedo at sea ice
+       read_sit(:,:)     = tab_read_flds(:,:,idr_icetem)  ! Sea ice temperature
+!$OMP END MASTER
+
+       IF (cpl_current) THEN
+
+! Transform the longitudes and latitudes on 2D arrays
+          CALL gather_omp(rlon,rlon_mpi)
+          CALL gather_omp(rlat,rlat_mpi)
+!$OMP MASTER
+          CALL Grid1DTo2D_mpi(rlon_mpi,tmp_lon)
+          CALL Grid1DTo2D_mpi(rlat_mpi,tmp_lat)
+
+! Transform the currents from cartesian to spheric coordinates
+! tmp_r0 should be zero
+          CALL geo2atm(iim, jj_nb, tab_read_flds(:,:,idr_curenx), &
+             tab_read_flds(:,:,idr_cureny), tab_read_flds(:,:,idr_curenz), &
+               tmp_lon, tmp_lat, &
+               read_u0(:,:), read_v0(:,:), tmp_r0(:,:))
+!$OMP END MASTER
+
+      ELSE
+          read_u0(:,:) = 0.
+          read_v0(:,:) = 0.
+      ENDIF
+
+       IF (carbon_cycle_cpl) THEN
+!$OMP MASTER
+           read_co2(:,:) = tab_read_flds(:,:,idr_oceco2) ! CO2 flux
+!$OMP END MASTER
+       ENDIF
+
+!*************************************************************************************
+!  Transform seaice fraction (read_sic : ocean-seaice mask) into global 
+!  fraction (pctsrf : ocean-seaice-land-landice mask)
+!
+!*************************************************************************************
+       CALL cpl2gath(read_sic, read_sic1D, klon, unity)
+
+       pctsrf_old(:,:) = pctsrf(:,:)
+       DO i = 1, klon
+          ! treatment only of points with ocean and/or seaice
+          ! old land-ocean mask can not be changed
+          IF (pctsrf_old(i,is_oce) + pctsrf_old(i,is_sic) > 0.) THEN
+             pctsrf(i,is_sic) = (pctsrf_old(i,is_oce) + pctsrf_old(i,is_sic)) &
+                  * read_sic1D(i)
+             pctsrf(i,is_oce) = (pctsrf_old(i,is_oce) + pctsrf_old(i,is_sic)) &
+                  - pctsrf(i,is_sic)
+          ENDIF
+       ENDDO
+
+    END IF ! if time to receive
+
+  END SUBROUTINE cpl_receive_frac
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_receive_ocean_fields(knon, knindex, tsurf_new, u0_new, v0_new)
+!
+! This routine returns the field for the ocean that has been read from the coupler
+! (done earlier with cpl_receive_frac). The field is the temperature.
+! The temperature is transformed into 1D array with valid points from index 1 to knon.
+!
+    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, fco2_ocn_day
+    USE indice_sol_mod
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)      :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: u0_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: v0_new
+
+! Local variables
+!*************************************************************************************
+    INTEGER                  :: i
+    INTEGER, DIMENSION(klon) :: index
+    REAL, DIMENSION(klon)    :: sic_new
+
+!*************************************************************************************
+! Transform read_sst into compressed 1D variable tsurf_new
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sst, tsurf_new, knon, knindex)
+    CALL cpl2gath(read_sic, sic_new, knon, knindex)
+    CALL cpl2gath(read_u0, u0_new, knon, knindex)
+    CALL cpl2gath(read_v0, v0_new, knon, knindex)
+
+!*************************************************************************************
+! Transform read_co2 into uncompressed 1D variable fco2_ocn_day added directly in 
+! the module carbon_cycle_mod
+!
+!*************************************************************************************
+    IF (carbon_cycle_cpl) THEN
+       DO i=1,klon
+          index(i)=i
+       END DO
+       CALL cpl2gath(read_co2, fco2_ocn_day, klon, index)
+    END IF
+
+!*************************************************************************************
+! The fields received from the coupler have to be weighted with the fraction of ocean 
+! in relation to the total sea-ice+ocean
+!
+!*************************************************************************************
+    DO i=1, knon
+       tsurf_new(i) = tsurf_new(i)/(1. - sic_new(i))
+    END DO
+
+  END SUBROUTINE cpl_receive_ocean_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_receive_seaice_fields(knon, knindex, &
+       tsurf_new, alb_new, u0_new, v0_new)
+!
+! This routine returns the fields for the seaice that have been read from the coupler
+! (done earlier with cpl_receive_frac). These fields are the temperature and 
+! albedo at sea ice surface and fraction of sea ice.
+! The fields are transformed into 1D arrays with valid points from index 1 to knon. 
+!
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)      :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: alb_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: u0_new
+    REAL, DIMENSION(klon), INTENT(OUT)      :: v0_new
+
+! Local variables
+!*************************************************************************************
+    INTEGER               :: i
+    REAL, DIMENSION(klon) :: sic_new
+
+!*************************************************************************************
+! Transform fields read from coupler from 2D into compressed 1D variables
+!
+!*************************************************************************************
+    CALL cpl2gath(read_sit, tsurf_new, knon, knindex)
+    CALL cpl2gath(read_alb_sic, alb_new, knon, knindex)
+    CALL cpl2gath(read_sic, sic_new, knon, knindex)
+    CALL cpl2gath(read_u0, u0_new, knon, knindex)
+    CALL cpl2gath(read_v0, v0_new, knon, knindex)
+
+!*************************************************************************************
+! The fields received from the coupler have to be weighted with the sea-ice 
+! concentration (in relation to the total sea-ice + ocean).
+!
+!*************************************************************************************
+    DO i= 1, knon
+       tsurf_new(i) = tsurf_new(i) / sic_new(i)
+       alb_new(i)   = alb_new(i)   / sic_new(i)
+    END DO
+
+  END SUBROUTINE cpl_receive_seaice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_ocean_fields(itime, knon, knindex, &
+       swdown, lwdown, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy, windsp)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. No sending to the coupler will be done from here 
+! (it is done in cpl_send_seaice_fields).
+!
+    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send
+    USE indice_sol_mod
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)       :: swdown, lwdown 
+    REAL, DIMENSION(klon), INTENT(IN)       :: fluxlat, fluxsens
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: evap, tsurf, fder, albsol
+    REAL, DIMENSION(klon), INTENT(IN)       :: taux, tauy, windsp
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                 :: cpl_index, ig 
+    INTEGER                                 :: error, sum_error
+    CHARACTER(len = 25)                     :: modname = 'cpl_send_ocean_fields'
+    CHARACTER(len = 80)                     :: abort_message
+
+!*************************************************************************************
+! Start calculation
+! The ocean points are saved with second array index=1
+!
+!*************************************************************************************
+    cpl_index = 1
+
+!*************************************************************************************
+! Reset fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_sols(1:knon,cpl_index) = 0.0
+       cpl_nsol(1:knon,cpl_index) = 0.0
+       cpl_rain(1:knon,cpl_index) = 0.0
+       cpl_snow(1:knon,cpl_index) = 0.0
+       cpl_evap(1:knon,cpl_index) = 0.0
+       cpl_tsol(1:knon,cpl_index) = 0.0
+       cpl_fder(1:knon,cpl_index) = 0.0
+       cpl_albe(1:knon,cpl_index) = 0.0
+       cpl_taux(1:knon,cpl_index) = 0.0
+       cpl_tauy(1:knon,cpl_index) = 0.0
+       cpl_windsp(1:knon,cpl_index) = 0.0
+       cpl_taumod(1:knon,cpl_index) = 0.0
+       IF (carbon_cycle_cpl) cpl_atm_co2(1:knon,cpl_index) = 0.0
+    ENDIF
+       
+!*************************************************************************************
+! Cumulate at each time-step
+!
+!*************************************************************************************    
+    DO ig = 1, knon
+       cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
+            swdown(ig)      / REAL(nexca)
+       cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
+            (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / REAL(nexca)
+       cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
+            precip_rain(ig) / REAL(nexca)
+       cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
+            precip_snow(ig) / REAL(nexca)
+       cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
+            evap(ig)        / REAL(nexca)
+       cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
+            tsurf(ig)       / REAL(nexca)
+       cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
+            fder(ig)        / REAL(nexca)
+       cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
+            albsol(ig)      / REAL(nexca)
+       cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
+            taux(ig)        / REAL(nexca)
+       cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
+            tauy(ig)        / REAL(nexca)      
+       cpl_windsp(ig,cpl_index) = cpl_windsp(ig,cpl_index) + &
+            windsp(ig)      / REAL(nexca)
+       cpl_taumod(ig,cpl_index) =   cpl_taumod(ig,cpl_index) + &
+          SQRT ( taux(ig)*taux(ig)+tauy(ig)*tauy(ig) ) / REAL (nexca)
+
+       IF (carbon_cycle_cpl) THEN
+          cpl_atm_co2(ig,cpl_index) = cpl_atm_co2(ig,cpl_index) + &
+               co2_send(knindex(ig))/ REAL(nexca) 
+       END IF
+     ENDDO
+
+!*************************************************************************************
+! If the time-step corresponds to the end of coupling period the 
+! fields are transformed to the 2D grid. 
+! No sending to the coupler (it is done from cpl_send_seaice_fields).
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 0) THEN
+
+       IF (.NOT. ALLOCATED(cpl_sols2D)) THEN
+          sum_error = 0
+          ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_taumod2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          
+          IF (carbon_cycle_cpl) THEN
+             ALLOCATE(cpl_atm_co22D(iim,jj_nb), stat=error)
+             sum_error = sum_error + error
+          END IF
+
+          IF (sum_error /= 0) THEN
+             abort_message='Pb allocation variables couplees pour l''ecriture'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       
+
+       CALL gath2cpl(cpl_sols(:,cpl_index), cpl_sols2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_nsol(:,cpl_index), cpl_nsol2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_rain(:,cpl_index), cpl_rain2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_snow(:,cpl_index), cpl_snow2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_evap(:,cpl_index), cpl_evap2D(:,:,cpl_index), &
+            knon, knindex)
+
+! cpl_tsol2D(:,:,:) not used!
+       CALL gath2cpl(cpl_tsol(:,cpl_index), cpl_tsol2D(:,:, cpl_index), &
+            knon, knindex)
+
+! cpl_fder2D(:,:,1) not used, only cpl_fder(:,:,2)!
+       CALL gath2cpl(cpl_fder(:,cpl_index), cpl_fder2D(:,:,cpl_index), &
+            knon, knindex)
+
+! cpl_albe2D(:,:,:) not used!
+       CALL gath2cpl(cpl_albe(:,cpl_index), cpl_albe2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_taux(:,cpl_index), cpl_taux2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_tauy(:,cpl_index), cpl_tauy2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_windsp(:,cpl_index), cpl_windsp2D(:,:), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_taumod(:,cpl_index), cpl_taumod2D(:,:,cpl_index), &
+            knon, knindex)
+
+       IF (carbon_cycle_cpl) &
+            CALL gath2cpl(cpl_atm_co2(:,cpl_index), cpl_atm_co22D(:,:), knon, knindex)
+   ENDIF
+
+  END SUBROUTINE cpl_send_ocean_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_seaice_fields(itime, dtime, knon, knindex, &
+       pctsrf, lafin, rlon, rlat, &
+       swdown, lwdown, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf, fder, albsol, taux, tauy)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. All fields for all types of surfaces are sent to
+! the coupler.
+!
+    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
+    USE indice_sol_mod
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)       :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)       :: swdown, lwdown 
+    REAL, DIMENSION(klon), INTENT(IN)       :: fluxlat, fluxsens
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: evap, tsurf, fder
+    REAL, DIMENSION(klon), INTENT(IN)       :: albsol, taux, tauy
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+    LOGICAL, INTENT(IN)                     :: lafin
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                 :: cpl_index, ig 
+    INTEGER                                 :: error, sum_error
+    CHARACTER(len = 25)                     :: modname = 'cpl_send_seaice_fields'
+    CHARACTER(len = 80)                     :: abort_message
+    REAL, DIMENSION(klon)                   :: cpl_fder_tmp
+
+!*************************************************************************************
+! Start calulation
+! The sea-ice points are saved with second array index=2
+!
+!*************************************************************************************
+    cpl_index = 2
+
+!*************************************************************************************
+! Reset fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+       cpl_sols(1:knon,cpl_index) = 0.0
+       cpl_nsol(1:knon,cpl_index) = 0.0
+       cpl_rain(1:knon,cpl_index) = 0.0
+       cpl_snow(1:knon,cpl_index) = 0.0
+       cpl_evap(1:knon,cpl_index) = 0.0
+       cpl_tsol(1:knon,cpl_index) = 0.0
+       cpl_fder(1:knon,cpl_index) = 0.0
+       cpl_albe(1:knon,cpl_index) = 0.0
+       cpl_taux(1:knon,cpl_index) = 0.0
+       cpl_tauy(1:knon,cpl_index) = 0.0
+       cpl_taumod(1:knon,cpl_index) = 0.0
+    ENDIF
+       
+!*************************************************************************************
+! Cumulate at each time-step
+!
+!*************************************************************************************    
+    DO ig = 1, knon
+       cpl_sols(ig,cpl_index) = cpl_sols(ig,cpl_index) + &
+            swdown(ig)      / REAL(nexca)
+       cpl_nsol(ig,cpl_index) = cpl_nsol(ig,cpl_index) + &
+            (lwdown(ig) + fluxlat(ig) +fluxsens(ig)) / REAL(nexca)
+       cpl_rain(ig,cpl_index) = cpl_rain(ig,cpl_index) + &
+            precip_rain(ig) / REAL(nexca)
+       cpl_snow(ig,cpl_index) = cpl_snow(ig,cpl_index) + &
+            precip_snow(ig) / REAL(nexca)
+       cpl_evap(ig,cpl_index) = cpl_evap(ig,cpl_index) + &
+            evap(ig)        / REAL(nexca)
+       cpl_tsol(ig,cpl_index) = cpl_tsol(ig,cpl_index) + &
+            tsurf(ig)       / REAL(nexca)
+       cpl_fder(ig,cpl_index) = cpl_fder(ig,cpl_index) + &
+            fder(ig)        / REAL(nexca)
+       cpl_albe(ig,cpl_index) = cpl_albe(ig,cpl_index) + &
+            albsol(ig)      / REAL(nexca)
+       cpl_taux(ig,cpl_index) = cpl_taux(ig,cpl_index) + &
+            taux(ig)        / REAL(nexca)
+       cpl_tauy(ig,cpl_index) = cpl_tauy(ig,cpl_index) + &
+            tauy(ig)        / REAL(nexca)     
+       cpl_taumod(ig,cpl_index) = cpl_taumod(ig,cpl_index) + &
+            SQRT ( taux(ig)*taux(ig)+tauy(ig)*tauy(ig) ) / REAL(nexca) 
+    ENDDO
+
+!*************************************************************************************
+! If the time-step corresponds to the end of coupling period the 
+! fields are transformed to the 2D grid and all fields are sent to coupler.
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 0) THEN
+       IF (.NOT. ALLOCATED(cpl_sols2D)) THEN
+          sum_error = 0
+          ALLOCATE(cpl_sols2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_nsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_rain2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_snow2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_evap2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tsol2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_fder2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_albe2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_taux2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_tauy2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_windsp2D(iim,jj_nb), stat=error)
+          sum_error = sum_error + error
+          ALLOCATE(cpl_taumod2D(iim,jj_nb,2), stat=error)
+          sum_error = sum_error + error
+
+          IF (carbon_cycle_cpl) THEN
+             ALLOCATE(cpl_atm_co22D(iim,jj_nb), stat=error)
+             sum_error = sum_error + error
+          END IF
+
+          IF (sum_error /= 0) THEN
+             abort_message='Pb allocation variables couplees pour l''ecriture'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+
+       CALL gath2cpl(cpl_sols(:,cpl_index), cpl_sols2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_nsol(:,cpl_index), cpl_nsol2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_rain(:,cpl_index), cpl_rain2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_snow(:,cpl_index), cpl_snow2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_evap(:,cpl_index), cpl_evap2D(:,:,cpl_index), &
+            knon, knindex)
+
+! cpl_tsol2D(:,:,:) not used!
+       CALL gath2cpl(cpl_tsol(:,cpl_index), cpl_tsol2D(:,:, cpl_index), &
+            knon, knindex)
+
+       ! Set default value and decompress before gath2cpl
+       cpl_fder_tmp(:) = -20.
+       DO ig = 1, knon
+          cpl_fder_tmp(knindex(ig))=cpl_fder(ig,cpl_index)
+       END DO
+       CALL gath2cpl(cpl_fder_tmp(:), cpl_fder2D(:,:,cpl_index), &
+            klon, unity)
+
+! cpl_albe2D(:,:,:) not used!
+       CALL gath2cpl(cpl_albe(:,cpl_index), cpl_albe2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_taux(:,cpl_index), cpl_taux2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_tauy(:,cpl_index), cpl_tauy2D(:,:,cpl_index), &
+            knon, knindex)
+
+       CALL gath2cpl(cpl_taumod(:,cpl_index), cpl_taumod2D(:,:,cpl_index), &
+            knon, knindex)
+
+       ! Send all fields
+       CALL cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat)
+    ENDIF
+
+  END SUBROUTINE cpl_send_seaice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_land_fields(itime, knon, knindex, rriv_in, rcoa_in)
+!
+! This subroutine cumulates some fields for each time-step during a coupling 
+! period. At last time-step in a coupling period the fields are transformed to the 
+! grid accepted by the coupler. No sending to the coupler will be done from here 
+! (it is done in cpl_send_seaice_fields).
+!
+    INCLUDE "dimensions.h"
+
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)         :: rriv_in
+    REAL, DIMENSION(klon), INTENT(IN)         :: rcoa_in
+
+! Local variables
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb)             :: rriv2D
+    REAL, DIMENSION(iim,jj_nb)             :: rcoa2D
+
+!*************************************************************************************
+! Rearrange fields in 2D variables 
+! First initialize to zero to avoid unvalid points causing problems
+!
+!*************************************************************************************
+!$OMP MASTER
+    rriv2D(:,:) = 0.0
+    rcoa2D(:,:) = 0.0
+!$OMP END MASTER
+    CALL gath2cpl(rriv_in, rriv2D, knon, knindex)
+    CALL gath2cpl(rcoa_in, rcoa2D, knon, knindex)
+
+!*************************************************************************************
+! Reset cumulated fields to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+!$OMP MASTER
+       cpl_rriv2D(:,:) = 0.0
+       cpl_rcoa2D(:,:) = 0.0
+!$OMP END MASTER
+    ENDIF
+
+!*************************************************************************************
+! Cumulate : Following fields should be cumulated at each time-step
+!
+!*************************************************************************************    
+!$OMP MASTER
+    cpl_rriv2D(:,:) = cpl_rriv2D(:,:) + rriv2D(:,:) / REAL(nexca)
+    cpl_rcoa2D(:,:) = cpl_rcoa2D(:,:) + rcoa2D(:,:) / REAL(nexca)
+!$OMP END MASTER
+
+  END SUBROUTINE cpl_send_land_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_landice_fields(itime, knon, knindex, rlic_in)
+! This subroutine cumulates the field for melting ice for each time-step 
+! during a coupling period. This routine will not send to coupler. Sending 
+! will be done in cpl_send_seaice_fields.
+!
+
+    INCLUDE "dimensions.h"
+
+! Input varibales
+!*************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)         :: rlic_in
+
+! Local varibales
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb)             :: rlic2D
+
+!*************************************************************************************
+! Rearrange field in a 2D variable 
+! First initialize to zero to avoid unvalid points causing problems
+!
+!*************************************************************************************
+!$OMP MASTER
+    rlic2D(:,:) = 0.0
+!$OMP END MASTER
+    CALL gath2cpl(rlic_in, rlic2D, knon, knindex)
+
+!*************************************************************************************
+! Reset field to zero in the beginning of a new coupling period 
+!
+!*************************************************************************************
+    IF (MOD(itime, nexca) == 1) THEN
+!$OMP MASTER
+       cpl_rlic2D(:,:) = 0.0
+!$OMP END MASTER
+    ENDIF
+
+!*************************************************************************************
+! Cumulate : Melting ice should be cumulated at each time-step
+!
+!*************************************************************************************    
+!$OMP MASTER
+    cpl_rlic2D(:,:) = cpl_rlic2D(:,:) + rlic2D(:,:) / REAL(nexca)
+!$OMP END MASTER
+
+  END SUBROUTINE cpl_send_landice_fields
+
+!
+!*************************************************************************************
+!
+
+  SUBROUTINE cpl_send_all(itime, dtime, pctsrf, lafin, rlon, rlat)
+! This routine will send fields for all different surfaces to the coupler.
+! This subroutine should be executed after calculations by the last surface(sea-ice),
+! all calculations at the different surfaces have to be done before. 
+!    
+    USE surface_data
+    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
+    USE indice_sol_mod
+! Some includes
+!*************************************************************************************
+    INCLUDE "temps.h"
+    INCLUDE "dimensions.h"
+    
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                                  :: itime
+    REAL, INTENT(IN)                                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)                    :: rlon, rlat
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)              :: pctsrf
+    LOGICAL, INTENT(IN)                                  :: lafin
+    
+! Local variables
+!*************************************************************************************
+    INTEGER                                              :: error, sum_error, j
+    INTEGER                                              :: itau_w
+    INTEGER                                              :: time_sec
+    INTEGER, DIMENSION(iim*(jjm+1))                      :: ndexct
+    REAL                                                 :: Up, Down
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_lon, tmp_lat
+    REAL, DIMENSION(iim, jj_nb, 4)                       :: pctsrf2D
+    REAL, DIMENSION(iim, jj_nb)                          :: deno
+    CHARACTER(len = 20)                                  :: modname = 'cpl_send_all'
+    CHARACTER(len = 80)                                  :: abort_message
+   
+! Variables with fields to coupler
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_taux
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_tauy
+    REAL, DIMENSION(iim, jj_nb)                          :: tmp_calv
+! Table with all fields to send to coupler
+    REAL, DIMENSION(iim, jj_nb, maxsend)                 :: tab_flds
+    REAL, DIMENSION(klon_mpi)                            :: rlon_mpi, rlat_mpi
+
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+    INTEGER, DIMENSION(MPI_STATUS_SIZE)                  :: status
+#endif
+
+! End definitions
+!*************************************************************************************
+    
+
+
+!*************************************************************************************
+! All fields are stored in a table tab_flds(:,:,:)
+! First store the fields which are already on the right format
+!
+!*************************************************************************************
+!$OMP MASTER
+    tab_flds(:,:,ids_windsp) = cpl_windsp2D(:,:)
+    tab_flds(:,:,ids_shfice) = cpl_sols2D(:,:,2)
+    tab_flds(:,:,ids_nsfice) = cpl_nsol2D(:,:,2)
+    tab_flds(:,:,ids_dflxdt) = cpl_fder2D(:,:,2)
+    
+    IF (version_ocean=='nemo') THEN
+       tab_flds(:,:,ids_liqrun) = cpl_rriv2D(:,:) + cpl_rcoa2D(:,:)
+       IF (carbon_cycle_cpl) tab_flds(:,:,ids_atmco2)=cpl_atm_co22D(:,:)
+    ELSE IF (version_ocean=='opa8') THEN
+       tab_flds(:,:,ids_shfoce) = cpl_sols2D(:,:,1)
+       tab_flds(:,:,ids_nsfoce) = cpl_nsol2D(:,:,1)
+       tab_flds(:,:,ids_icevap) = cpl_evap2D(:,:,2)
+       tab_flds(:,:,ids_ocevap) = cpl_evap2D(:,:,1)
+       tab_flds(:,:,ids_runcoa) = cpl_rcoa2D(:,:)
+       tab_flds(:,:,ids_rivflu) = cpl_rriv2D(:,:)
+    END IF
+
+!*************************************************************************************
+! Transform the fraction of sub-surfaces from 1D to 2D array
+!
+!*************************************************************************************
+    pctsrf2D(:,:,:) = 0.
+!$OMP END MASTER
+    CALL gath2cpl(pctsrf(:,is_oce), pctsrf2D(:,:,is_oce), klon, unity)
+    CALL gath2cpl(pctsrf(:,is_sic), pctsrf2D(:,:,is_sic), klon, unity)
+    CALL gath2cpl(pctsrf(:,is_lic), pctsrf2D(:,:,is_lic), klon, unity)
+
+!*************************************************************************************
+! Calculate the average calving per latitude
+! Store calving in tab_flds(:,:,19)
+! 
+!*************************************************************************************      
+    IF (is_omp_root) THEN
+
+      DO j = 1, jj_nb
+         tmp_calv(:,j) = DOT_PRODUCT (cpl_rlic2D(1:iim,j), &
+              pctsrf2D(1:iim,j,is_lic)) / REAL(iim)
+      ENDDO
+    
+    
+      IF (is_parallel) THEN
+         IF (.NOT. is_north_pole) THEN
+#ifdef CPP_MPI
+            CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error)
+            CALL MPI_SEND(tmp_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,error)
+#endif
+         ENDIF
+       
+         IF (.NOT. is_south_pole) THEN
+#ifdef CPP_MPI
+            CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error)
+            CALL MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,error)
+#endif
+         ENDIF
+         
+         IF (.NOT. is_north_pole .AND. ii_begin /=1) THEN
+            Up=Up+tmp_calv(iim,1)
+            tmp_calv(:,1)=Up
+         ENDIF
+         
+         IF (.NOT. is_south_pole .AND. ii_end /= iim) THEN
+            Down=Down+tmp_calv(1,jj_nb)
+            tmp_calv(:,jj_nb)=Down	 
+         ENDIF
+      ENDIF
+      
+      tab_flds(:,:,ids_calvin) = tmp_calv(:,:)
+
+!*************************************************************************************
+! Calculate total flux for snow, rain and wind with weighted addition using the 
+! fractions of ocean and seaice.
+!
+!*************************************************************************************    
+       ! fraction oce+seaice
+       deno =  pctsrf2D(:,:,is_oce) + pctsrf2D(:,:,is_sic) 
+
+       IF (version_ocean=='nemo') THEN
+          tab_flds(:,:,ids_shftot)  = 0.0
+          tab_flds(:,:,ids_nsftot) = 0.0
+          tab_flds(:,:,ids_totrai) = 0.0
+          tab_flds(:,:,ids_totsno) = 0.0
+          tab_flds(:,:,ids_toteva) = 0.0
+          tab_flds(:,:,ids_taumod) = 0.0
+  
+          tmp_taux(:,:)    = 0.0
+          tmp_tauy(:,:)    = 0.0
+          ! For all valid grid cells containing some fraction of ocean or sea-ice
+          WHERE ( deno(:,:) /= 0 )
+             tmp_taux = cpl_taux2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+                  cpl_taux2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+             tmp_tauy = cpl_tauy2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+                  cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+
+             tab_flds(:,:,ids_shftot) = cpl_sols2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+                  cpl_sols2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+             tab_flds(:,:,ids_nsftot) = cpl_nsol2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+                  cpl_nsol2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+             tab_flds(:,:,ids_totrai) = cpl_rain2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+                  cpl_rain2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+             tab_flds(:,:,ids_totsno) = cpl_snow2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+                  cpl_snow2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+             tab_flds(:,:,ids_toteva) = cpl_evap2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+                  cpl_evap2D(:,:,2)  * pctsrf2D(:,:,is_sic) / deno(:,:)
+             tab_flds(:,:,ids_taumod) = cpl_taumod2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+                  cpl_taumod2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+             
+         ENDWHERE
+
+          tab_flds(:,:,ids_icevap) = cpl_evap2D(:,:,2) 
+          
+       ELSE IF (version_ocean=='opa8') THEN
+          ! Store fields for rain and snow in tab_flds(:,:,15) and tab_flds(:,:,16)
+          tab_flds(:,:,ids_totrai) = 0.0
+          tab_flds(:,:,ids_totsno) = 0.0
+          tmp_taux(:,:)    = 0.0
+          tmp_tauy(:,:)    = 0.0
+          ! For all valid grid cells containing some fraction of ocean or sea-ice
+          WHERE ( deno(:,:) /= 0 )
+             tab_flds(:,:,ids_totrai) = cpl_rain2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+                  cpl_rain2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+             tab_flds(:,:,ids_totsno) = cpl_snow2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+                  cpl_snow2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+             
+             tmp_taux = cpl_taux2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+                  cpl_taux2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+             tmp_tauy = cpl_tauy2D(:,:,1) * pctsrf2D(:,:,is_oce) / deno(:,:) +    &
+                  cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:)
+          ENDWHERE
+       END IF
+
+    ENDIF ! is_omp_root
+  
+!*************************************************************************************
+! Transform the wind components from local atmospheric 2D coordinates to geocentric 
+! 3D coordinates. 
+! Store the resulting wind components in tab_flds(:,:,1:6)
+!*************************************************************************************
+
+! Transform the longitudes and latitudes on 2D arrays
+    
+    CALL gather_omp(rlon,rlon_mpi)
+    CALL gather_omp(rlat,rlat_mpi)
+!$OMP MASTER
+    CALL Grid1DTo2D_mpi(rlon_mpi,tmp_lon)
+    CALL Grid1DTo2D_mpi(rlat_mpi,tmp_lat)
+!$OMP END MASTER    
+
+    IF (is_sequential) THEN
+       IF (is_north_pole) tmp_lon(:,1)     = tmp_lon(:,2)
+       IF (is_south_pole) tmp_lon(:,jjm+1) = tmp_lon(:,jjm)
+    ENDIF
+      
+! NetCDF output of the wind before transformation of coordinate system
+    IF (is_sequential) THEN
+       ndexct(:) = 0
+       itau_w = itau_phy + itime + start_time * day_step / iphysiq
+       CALL histwrite(nidct,'tauxe',itau_w,tmp_taux,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tauyn',itau_w,tmp_tauy,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct)
+       CALL histwrite(nidct,'tmp_lat',itau_w,tmp_lat,iim*(jjm+1),ndexct)
+    ENDIF
+
+! Transform the wind from spherical atmospheric 2D coordinates to geocentric
+! cartesian 3D coordinates 
+!$OMP MASTER
+    CALL atm2geo (iim, jj_nb, tmp_taux, tmp_tauy, tmp_lon, tmp_lat, &
+         tab_flds(:,:,ids_tauxxu), tab_flds(:,:,ids_tauyyu), tab_flds(:,:,ids_tauzzu) )
+    
+    tab_flds(:,:,ids_tauxxv)  = tab_flds(:,:,ids_tauxxu)
+    tab_flds(:,:,ids_tauyyv)  = tab_flds(:,:,ids_tauyyu)
+    tab_flds(:,:,ids_tauzzv)  = tab_flds(:,:,ids_tauzzu)
+!$OMP END MASTER
+
+!*************************************************************************************
+! NetCDF output of all fields just before sending to coupler.
+!
+!*************************************************************************************
+    IF (is_sequential) THEN
+        DO j=1,maxsend
+          IF (infosend(j)%action) CALL histwrite(nidct,infosend(j)%name, itau_w, &
+             tab_flds(:,:,j),iim*(jjm+1),ndexct)
+        ENDDO
+    ENDIF
+!*************************************************************************************
+! Send the table of all fields
+!
+!*************************************************************************************
+    time_sec=(itime-1)*dtime
+#ifdef CPP_COUPLE
+!$OMP MASTER
+    CALL intocpl(time_sec, lafin, tab_flds(:,:,:))
+!$OMP END MASTER
+#endif
+
+!*************************************************************************************
+! Finish with some dellocate
+!
+!*************************************************************************************  
+    sum_error=0
+    DEALLOCATE(cpl_sols2D, cpl_nsol2D, cpl_rain2D, cpl_snow2D, stat=error )
+    sum_error = sum_error + error
+    DEALLOCATE(cpl_evap2D, cpl_tsol2D, cpl_fder2D, cpl_albe2D, stat=error )
+    sum_error = sum_error + error
+    DEALLOCATE(cpl_taux2D, cpl_tauy2D, cpl_windsp2D, cpl_taumod2D, stat=error )
+    sum_error = sum_error + error
+    
+    IF (carbon_cycle_cpl) THEN
+       DEALLOCATE(cpl_atm_co22D, stat=error )
+       sum_error = sum_error + error
+    END IF
+
+    IF (sum_error /= 0) THEN
+       abort_message='Pb in deallocation of cpl_xxxx2D coupling variables'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    
+  END SUBROUTINE cpl_send_all
+!
+!*************************************************************************************
+!
+  SUBROUTINE cpl2gath(champ_in, champ_out, knon, knindex)
+  USE mod_phys_lmdz_para
+! Cette routine transforme un champs de la grille 2D recu du coupleur sur la grille 
+! 'gathered' (la grille physiq comprime).
+!
+! 
+! input:         
+!   champ_in     champ sur la grille 2D
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!
+! output:
+!   champ_out    champ sur la grille 'gatherd'
+!
+    INCLUDE "dimensions.h"
+
+! Input
+    INTEGER, INTENT(IN)                       :: knon
+    REAL, DIMENSION(iim,jj_nb), INTENT(IN)    :: champ_in
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+
+! Output
+    REAL, DIMENSION(klon_mpi), INTENT(OUT)        :: champ_out
+
+! Local
+    INTEGER                                   :: i, ig
+    REAL, DIMENSION(klon_mpi)                 :: temp_mpi
+    REAL, DIMENSION(klon)                     :: temp_omp
+
+!*************************************************************************************
+!
+    
+
+! Transform from 2 dimensions (iim,jj_nb) to 1 dimension (klon)
+!$OMP MASTER 
+    CALL Grid2Dto1D_mpi(champ_in,temp_mpi)
+!$OMP END MASTER
+
+    CALL scatter_omp(temp_mpi,temp_omp)
+    
+! Compress from klon to knon
+    DO i = 1, knon
+       ig = knindex(i)
+       champ_out(i) = temp_omp(ig)
+    ENDDO
+
+  END SUBROUTINE cpl2gath
+!
+!*************************************************************************************
+!
+  SUBROUTINE gath2cpl(champ_in, champ_out, knon, knindex)
+  USE mod_phys_lmdz_para
+! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer
+! au coupleur.
+!
+! input:         
+!   champ_in     champ sur la grille gathere        
+!   knon         nombre de points dans le domaine a traiter
+!   knindex      index des points de la surface a traiter
+!
+! output:
+!   champ_out    champ sur la grille 2D
+!
+    INCLUDE "dimensions.h"
+    
+! Input arguments
+!*************************************************************************************
+    INTEGER, INTENT(IN)                    :: knon
+    REAL, DIMENSION(klon), INTENT(IN)      :: champ_in
+    INTEGER, DIMENSION(klon), INTENT(IN)   :: knindex
+
+! Output arguments
+!*************************************************************************************
+    REAL, DIMENSION(iim,jj_nb), INTENT(OUT) :: champ_out
+
+! Local variables
+!*************************************************************************************
+    INTEGER                                :: i, ig
+    REAL, DIMENSION(klon)                  :: temp_omp
+    REAL, DIMENSION(klon_mpi)              :: temp_mpi
+!*************************************************************************************
+
+! Decompress from knon to klon
+    temp_omp = 0.
+    DO i = 1, knon
+       ig = knindex(i)
+       temp_omp(ig) = champ_in(i)
+    ENDDO
+
+! Transform from 1 dimension (klon) to 2 dimensions (iim,jj_nb)
+    CALL gather_omp(temp_omp,temp_mpi)
+
+!$OMP MASTER    
+    CALL Grid1Dto2D_mpi(temp_mpi,champ_out)
+    
+    IF (is_north_pole) champ_out(:,1)=temp_mpi(1)
+    IF (is_south_pole) champ_out(:,jj_nb)=temp_mpi(klon)
+!$OMP END MASTER
+    
+  END SUBROUTINE gath2cpl
+!
+!*************************************************************************************
+!
+END MODULE cpl_mod
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cray.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cray.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cray.F	(revision 17)
@@ -0,0 +1,42 @@
+!
+! $Header$
+!
+#ifdef CRAY
+      SUBROUTINE riencray
+      END
+#else
+      subroutine scopy(n,sx,incx,sy,incy)
+c
+      IMPLICIT NONE
+c
+      integer n,incx,incy,ix,iy,i
+      real sx((n-1)*incx+1),sy((n-1)*incy+1)
+c
+      iy=1
+      ix=1
+      do 10 i=1,n
+         sy(iy)=sx(ix)
+         ix=ix+incx
+         iy=iy+incy
+10    continue
+c
+      return
+      end
+
+      function ssum(n,sx,incx)
+c
+      IMPLICIT NONE
+c
+      integer n,incx,i,ix
+      real ssum,sx((n-1)*incx+1)
+c
+      ssum=0.
+      ix=1
+      do 10 i=1,n
+         ssum=ssum+sx(ix)
+         ix=ix+incx
+10    continue
+c
+      return
+      end
+#endif
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cray.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cray.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cray.F90	(revision 17)
@@ -0,0 +1,42 @@
+!
+! $Header$
+!
+#ifdef CRAY
+      SUBROUTINE riencray
+      END
+#else
+      subroutine scopy(n,sx,incx,sy,incy)
+!c
+      IMPLICIT NONE
+!c
+      integer n,incx,incy,ix,iy,i
+      real sx((n-1)*incx+1),sy((n-1)*incy+1)
+!c
+      iy=1
+      ix=1
+      do 10 i=1,n
+         sy(iy)=sx(ix)
+         ix=ix+incx
+         iy=iy+incy
+10    continue
+!c
+      return
+      end subroutine scopy
+
+      function ssum(n,sx,incx)
+!c
+      IMPLICIT NONE
+!c
+      integer n,incx,i,ix
+      real ssum,sx((n-1)*incx+1)
+!c
+      ssum=0.
+      ix=1
+      do 10 i=1,n
+         ssum=ssum+sx(ix)
+         ix=ix+incx
+10    continue
+!c
+      return
+      end function ssum
+#endif
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv30_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv30_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv30_routines.F	(revision 17)
@@ -0,0 +1,3301 @@
+!
+! $Id: cv30_routines.F 1750 2013-04-25 15:27:27Z fairhead $
+!
+c
+c
+      SUBROUTINE cv30_param(nd,delt)
+      implicit none
+
+c------------------------------------------------------------
+c Set parameters for convectL for iflag_con = 3 
+c------------------------------------------------------------
+
+C
+C   ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
+C   ***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
+C   ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***     
+C   ***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***     
+C   ***                        OF CLOUD                         ***
+C
+C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
+C   ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+C   ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
+C   ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
+C
+C   ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+C   ***                     IT MUST BE LESS THAN 0              ***
+
+#include "cv30param.h"
+#include "conema3.h"
+
+      integer nd
+      real delt ! timestep (seconds)
+
+c noff: integer limit for convection (nd-noff)
+c minorig: First level of convection
+
+c -- limit levels for convection:
+
+      noff    = 1
+      minorig = 1
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+c -- "microphysical" parameters:
+
+      sigd   = 0.01
+      spfac  = 0.15
+      pbcrit = 150.0
+      ptcrit = 500.0
+cIM cf. FH     epmax  = 0.993
+
+      omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
+
+c -- misc:
+
+      dtovsh = -0.2 ! dT for overshoot
+      dpbase = -40. ! definition cloud base (400m above LCL)
+      dttrig = 5.   ! (loose) condition for triggering 
+
+c -- rate of approach to quasi-equilibrium:
+
+      dtcrit = -2.0
+      tau    = 8000.
+      beta   = 1.0 - delt/tau
+      alpha  = 1.5E-3 * delt/tau
+c increase alpha to compensate W decrease:
+      alpha  = alpha*1.5
+
+c -- interface cloud parameterization:
+
+      delta=0.01  ! cld
+
+c -- interface with boundary-layer (gust factor): (sb)
+
+      betad=10.0   ! original value (from convect 4.3)
+
+      return
+      end
+
+      SUBROUTINE cv30_prelim(len,nd,ndp1,t,q,p,ph
+     :                    ,lv,cpn,tv,gz,h,hm,th)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+! "ori": from convect4.3 (vectorized)
+! "convect3": to be exactly consistent with convect3
+!=====================================================================
+
+c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+      real th(len,nd)
+
+c local variables:
+      integer k, i
+      real rdcp
+      real tvx,tvy ! convect3
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cv30param.h"
+
+
+c ori      do 110 k=1,nlp
+      do 110 k=1,nl ! convect3
+        do 100 i=1,len
+cdebug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          lv(i,k)= lv0-clmcpv*(t(i,k)-273.15)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+c ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k))
+          rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k)
+          th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+c ori      do 140 k=2,nlp
+      do 140 k=2,nl ! convect3
+        do 130 i=1,len
+        tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k))       !convect3
+        tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
+        gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy)     !convect3
+     &          *(p(i,k-1)-p(i,k))/ph(i,k)      !convect3
+
+c ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+c ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+c ori      do 170 k=1,nlp
+      do 170 k=1,nl ! convect3
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv30_feed(len,nd,t,q,qs,p,ph,hm,gz
+     :                  ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl)
+      implicit none
+
+C================================================================
+C Purpose: CONVECTIVE FEED
+C
+C Main differences with cv_feed:
+C   - ph added in input
+C	- here, nk(i)=minorig
+C	- icb defined differently (plcl compared with ph instead of p)
+C
+C Main differences with convect3:
+C 	- we do not compute dplcldt and dplcldr of CLIFT anymore 
+C	- values iflag different (but tests identical)
+C   - A,B explicitely defined (!...)
+C================================================================
+
+#include "cv30param.h"
+
+c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), qs(len,nd), p(len,nd)
+      real hm(len,nd), gz(len,nd)
+      real ph(len,nd+1)
+
+c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+      real tnk(len), qnk(len), gznk(len), plcl(len)
+
+c local variables:
+      integer i, k
+      integer ihmin(len)
+      real work(len)
+      real pnk(len), qsnk(len), rh(len), chi(len)
+      real A, B ! convect3
+cym
+      plcl=0.0
+c@ !-------------------------------------------------------------------
+c@ ! --- Find level of minimum moist static energy
+c@ ! --- If level of minimum moist static energy coincides with
+c@ ! --- or is lower than minimum allowable parcel origin level,
+c@ ! --- set iflag to 6.
+c@ !-------------------------------------------------------------------
+c@ 
+c@       do 180 i=1,len
+c@        work(i)=1.0e12
+c@        ihmin(i)=nl
+c@  180  continue
+c@       do 200 k=2,nlp
+c@         do 190 i=1,len
+c@          if((hm(i,k).lt.work(i)).and.
+c@      &      (hm(i,k).lt.hm(i,k-1)))then
+c@            work(i)=hm(i,k)
+c@            ihmin(i)=k
+c@          endif
+c@  190    continue
+c@  200  continue
+c@       do 210 i=1,len
+c@         ihmin(i)=min(ihmin(i),nlm)
+c@         if(ihmin(i).le.minorig)then
+c@           iflag(i)=6
+c@         endif
+c@  210  continue
+c@ c
+c@ !-------------------------------------------------------------------
+c@ ! --- Find that model level below the level of minimum moist static
+c@ ! --- energy that has the maximum value of moist static energy
+c@ !-------------------------------------------------------------------
+c@  
+c@       do 220 i=1,len
+c@        work(i)=hm(i,minorig)
+c@        nk(i)=minorig
+c@  220  continue
+c@       do 240 k=minorig+1,nl
+c@         do 230 i=1,len
+c@          if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+c@            work(i)=hm(i,k)
+c@            nk(i)=k
+c@          endif
+c@  230     continue
+c@  240  continue
+
+!-------------------------------------------------------------------
+! --- Origin level of ascending parcels for convect3:
+!-------------------------------------------------------------------
+
+         do 220 i=1,len
+          nk(i)=minorig
+  220    continue
+
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if( (     ( t(i,nk(i)).lt.250.0    )
+     &       .or.( q(i,nk(i)).le.0.0      )     )
+c@      &       .or.( p(i,ihmin(i)).lt.400.0 )  )
+     &   .and.
+     &       ( iflag(i).eq.0) ) iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+
+       A = 1669.0 ! convect3
+       B = 122.0  ! convect3
+
+       do 260 i=1,len
+
+        if (iflag(i).ne.7) then ! modif sb Jun7th 2002
+
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+c
+        rh(i)=qnk(i)/qsnk(i)
+c ori        rh(i)=min(1.0,rh(i)) ! removed for convect3
+c ori        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        chi(i)=tnk(i)/(A-B*rh(i)-tnk(i)) ! convect3
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+ 
+        endif ! iflag=7  
+
+ 260   continue
+
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+
+c@      do 270 i=1,len
+c@       icb(i)=nlm
+c@ 270  continue
+c@c
+c@      do 290 k=minorig,nl
+c@        do 280 i=1,len
+c@          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+c@     &    icb(i)=min(icb(i),k)
+c@ 280    continue
+c@ 290  continue
+c@c
+c@      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+c@ 300  continue
+
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+c la modification consiste a comparer plcl a ph et non a p:
+c icb est defini par :  ph(icb)<plcl<ph(icb-1)
+c@      do 290 k=minorig,nl
+      do 290 k=3,nl-1 ! modif pour que icb soit sup/egal a 2
+        do 280 i=1,len
+          if( ph(i,k).lt.plcl(i) ) icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+        if((icb(i).eq.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+
+      do 400 i=1,len
+        icb(i) = icb(i)-1 ! icb sup ou egal a 2
+ 400  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+c!        icbmax=max(icbmax,icb(i))
+       if (iflag(i).lt.7) icbmax=max(icbmax,icb(i)) ! sb Jun7th02
+ 310  continue
+
+      return
+      end
+
+      SUBROUTINE cv30_undilute1(len,nd,t,q,qs,gz,plcl,p,nk,icb
+     :                       ,tp,tvp,clw,icbs)
+      implicit none
+
+!----------------------------------------------------------------
+! Equivalent de TLIFT entre NK et ICB+1 inclus
+!
+! Differences with convect4:
+!		- specify plcl in input
+!       - icbs is the first level above LCL (may differ from icb)
+!       - in the iterations, used x(icbs) instead x(icb)
+!       - many minor differences in the iterations
+!		- tvp is computed in only one time
+!		- icbs: first level above Plcl (IMIN de TLIFT) in output
+!       - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
+!----------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv30param.h"
+
+c inputs:
+      integer len, nd
+      integer nk(len), icb(len)
+      real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd)
+      real p(len,nd) 
+      real plcl(len) ! convect3
+
+c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+c local variables:
+      integer i, k
+      integer icb1(len), icbs(len), icbsmax2 ! convect3
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+      real qsicb(len) ! convect3
+      real cpinv(len) ! convect3
+
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+c ori        ticb(i)=t(i,icb(i))
+c ori        gzicb(i)=gz(i,icb(i))
+ 320  continue
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+        cpinv(i)=1./cpp(i)
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do i=1,len                      !convect3
+         icb1(i)=MAX(icb(i),2)          !convect3
+         icb1(i)=MIN(icb(i),nl)         !convect3
+c if icb is below LCL, start loop at ICB+1:
+c (icbs est le premier niveau au-dessus du LCL)
+         icbs(i)=icb1(i)                !convect3
+         if (plcl(i).lt.p(i,icb1(i))) then
+             icbs(i)=MIN(icbs(i)+1,nl)  !convect3
+         endif
+        enddo                           !convect3
+
+        do i=1,len                      !convect3
+         ticb(i)=t(i,icbs(i))           !convect3
+         gzicb(i)=gz(i,icbs(i))         !convect3
+         qsicb(i)=qs(i,icbs(i))         !convect3
+        enddo                           !convect3
+
+c
+c Re-compute icbsmax (icbsmax2):        !convect3
+c                                       !convect3
+      icbsmax2=2                        !convect3
+      do 310 i=1,len                    !convect3
+        icbsmax2=max(icbsmax2,icbs(i))  !convect3
+ 310  continue                          !convect3
+
+c initialization outputs:
+
+      do k=1,icbsmax2     ! convect3
+       do i=1,len         ! convect3
+        tp(i,k)  = 0.0    ! convect3
+        tvp(i,k) = 0.0    ! convect3
+        clw(i,k) = 0.0    ! convect3
+       enddo              ! convect3
+      enddo               ! convect3
+
+c tp and tvp below cloud base:
+
+        do 350 k=minorig,icbsmax2-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))*cpinv(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+c ori         qg=qs(i,icb(i))
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icbs(i))=(ah0(i)-gz(i,icbs(i))-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icbs(i))=qnk(i)-qg
+         clw(i,icbs(i))=max(0.0,clw(i,icbs(i)))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icbs(i))=tp(i,icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
+
+  360   continue
+c
+c ori      do 380 k=minorig,icbsmax2
+c ori       do 370 i=1,len
+c ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+c ori 370   continue
+c ori 380  continue
+c
+
+c -- The following is only for convect3:
+c
+c * icbs is the first level above the LCL:
+c    if plcl<p(icb), then icbs=icb+1
+c    if plcl>p(icb), then icbs=icb
+c
+c * the routine above computes tvp from minorig to icbs (included).
+c
+c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
+c    must be known. This is the case if icbs=icb+1, but not if icbs=icb.
+c
+c * therefore, in the case icbs=icb, we compute tvp at level icb+1
+c   (tvp at other levels will be computed in cv3_undilute2.F)
+c
+
+        do i=1,len              
+         ticb(i)=t(i,icb(i)+1)   
+         gzicb(i)=gz(i,icb(i)+1) 
+         qsicb(i)=qs(i,icb(i)+1) 
+        enddo                   
+
+        do 460 i=1,len
+         tg=ticb(i)
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icb(i)+1)=qnk(i)-qg
+         clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
+
+  460   continue
+
+      return
+      end
+
+      SUBROUTINE cv30_trigger(len,nd,icb,plcl,p,th,tv,tvp
+     o                ,pbase,buoybase,iflag,sig,w0)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!
+!	- computes the cloud base
+!   - triggering (crude in this version)
+!	- relaxation of sig and w0 when no convection
+!
+!	Caution1: if no convection, we set iflag=4 
+!              (it used to be 0 in convect3)
+!
+!	Caution2: at this stage, tvp (and thus buoy) are know up 
+!             through icb only!
+! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
+!-------------------------------------------------------------------
+
+#include "cv30param.h"
+
+c input:
+      integer len, nd
+      integer icb(len)
+      real plcl(len), p(len,nd)
+      real th(len,nd), tv(len,nd), tvp(len,nd)
+
+c output:
+      real pbase(len), buoybase(len)
+
+c input AND output:
+      integer iflag(len)
+      real sig(len,nd), w0(len,nd)
+
+c local variables:
+      integer i,k
+      real tvpbase, tvbase, tdif, ath, ath1
+
+c
+c ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
+c
+      do 100 i=1,len
+       pbase(i) = plcl(i) + dpbase
+       tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+     :         + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                          /(p(i,icb(i))-p(i,icb(i)+1))
+       tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                      /(p(i,icb(i))-p(i,icb(i)+1))
+     :        + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+       buoybase(i) = tvpbase - tvbase
+100   continue 
+
+c
+c   ***   make sure that column is dry adiabatic between the surface  ***
+c   ***    and cloud base, and that lifted air is positively buoyant  ***
+c   ***                         at cloud base                         ***
+c   ***       if not, return to calling program after resetting       ***
+c   ***                        sig(i) and w0(i)                       ***
+c
+
+c oct3      do 200 i=1,len
+c oct3
+c oct3       tdif = buoybase(i)
+c oct3       ath1 = th(i,1)
+c oct3       ath  = th(i,icb(i)-1) - dttrig
+c oct3 
+c oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+c oct3         do 60 k=1,nl
+c oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+c oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
+c oct3            w0(i,k)  = beta*w0(i,k)
+c oct3   60    continue
+c oct3         iflag(i)=4 ! pour version vectorisee
+c oct3c convect3         iflag(i)=0
+c oct3cccc         return
+c oct3       endif
+c oct3
+c oct3200   continue
+ 
+c -- oct3: on reecrit la boucle 200 (pour la vectorisation)
+
+      do  60 k=1,nl
+      do 200 i=1,len
+
+       tdif = buoybase(i)
+       ath1 = th(i,1)
+       ath  = th(i,icb(i)-1) - dttrig
+
+       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+            sig(i,k) = AMAX1(sig(i,k),0.0)
+            w0(i,k)  = beta*w0(i,k)
+        iflag(i)=4 ! pour version vectorisee
+c convect3         iflag(i)=0
+       endif
+
+200   continue
+ 60   continue
+
+c fin oct3 --
+
+      return
+      end
+
+      SUBROUTINE cv30_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1
+     :    ,t1,q1,qs1,u1,v1,gz1,th1
+     :    ,tra1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 
+     :    ,sig1,w01
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,pbase,buoybase
+     o    ,t,q,qs,u,v,gz,th
+     o    ,tra
+     o    ,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,sig,w0  )
+      implicit none
+
+#include "cv30param.h"
+      include 'iniprint.h'
+
+c inputs:
+      integer len,ncum,nd,ntra,nloc
+      integer iflag1(len),nk1(len),icb1(len),icbs1(len)
+      real plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real pbase1(len),buoybase1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+      real th1(len,nd)
+      real sig1(len,nd), w01(len,nd)
+      real tra1(len,nd,ntra)
+
+c outputs:
+c en fait, on a nloc=len pour l'instant (cf cv_driver)
+      integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc)
+      real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real pbase(nloc),buoybase(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real th(nloc,nd)
+      real sig(nloc,nd), w0(nloc,nd) 
+      real tra(nloc,nd,ntra)
+
+c local variables:
+      integer i,k,nn,j
+
+      CHARACTER (LEN=20) :: modname='cv30_compress'
+      CHARACTER (LEN=80) :: abort_message
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        sig(nn,k)=sig1(i,k)
+        w0(nn,k)=w01(i,k)
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+        th(nn,k)=th1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+c      do 121 j=1,ntra
+c      do 111 k=1,nd
+c       nn=0
+c      do 101 i=1,len
+c      if(iflag1(i).eq.0)then
+c       nn=nn+1
+c       tra(nn,k,j)=tra1(i,k,j)
+c      endif
+c 101  continue
+c 111  continue
+c 121  continue
+
+      if (nn.ne.ncum) then
+         write(lunout,*)'strange! nn not equal to ncum: ',nn,ncum
+         abort_message = ''
+         CALL abort_gcm (modname,abort_message,1)
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      pbase(nn)=pbase1(i)
+      buoybase(nn)=buoybase1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      icbs(nn)=icbs1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      return
+      end
+
+      SUBROUTINE cv30_undilute2(nloc,ncum,nd,icb,icbs,nk
+     :                       ,tnk,qnk,gznk,t,q,qs,gz
+     :                       ,p,h,tv,lv,pbase,buoybase,plcl
+     o                       ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      implicit none
+
+C---------------------------------------------------------------------
+C Purpose:
+C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+C     &
+C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE 
+C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+C     &
+C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+C
+C Main differences convect3/convect4:
+C	- icbs (input) is the first level above LCL (may differ from icb)
+C	- many minor differences in the iterations
+C	- condensed water not removed from tvp in convect3
+C   - vertical profile of buoyancy computed here (use of buoybase)
+C   - the determination of inb is different
+C   - no inb1, only inb in output
+C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv30param.h"
+#include "conema3.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), icbs(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+      real pbase(nloc), buoybase(nloc), plcl(nloc)
+
+c outputs:
+      integer inb(nloc)
+      real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd)
+      real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd)
+      real buoy(nloc,nd)
+
+c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac, pden
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=spfac
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+         ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+cdebug     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+c ori	    if(k.ge.(icb(i)+1))then
+	    if(k.ge.(icbs(i)+1))then ! convect3
+	      tg=t(i,k)
+	      qg=qs(i,k)
+cdebug	      alv=lv0-clmcpv*(t(i,k)-t0)
+	      alv=lv0-clmcpv*(t(i,k)-273.15)
+c
+c First iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+           s=cpd*(1.-qnk(i))+cl*qnk(i)      ! convect3
+     :      +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
+	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+c ori	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+cdebug	       alv=lv0-clmcpv*(t(i,k)-t0)
+	       alv=lv0-clmcpv*(t(i,k)-273.15)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+
+c ori c approximation here:
+c ori        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+
+c convect3: no approximation:
+           tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+c ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg):
+               tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+c
+c ori      do 320 k=minorig+1,nl
+      do 320 k=1,nl ! convect3
+        do 310 i=1,ncum
+           pden=ptcrit-pbcrit
+           ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax
+           ep(i,k)=amax1(ep(i,k),0.0)
+           ep(i,k)=amin1(ep(i,k),epmax)
+           sigp(i,k)=spfac
+c ori          if(k.ge.(nk(i)+1))then
+c ori            tca=tp(i,k)-t0
+c ori            if(tca.ge.0.0)then
+c ori              elacrit=elcrit
+c ori            else
+c ori              elacrit=elcrit*(1.0-tca/tlcrit)
+c ori            endif
+c ori            elacrit=max(elacrit,0.0)
+c ori            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+c ori            ep(i,k)=max(ep(i,k),0.0 )
+c ori            ep(i,k)=min(ep(i,k),1.0 )
+c ori            sigp(i,k)=sigs
+c ori          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+c dans convect3, tvp est calcule en une seule fois, et sans retirer
+c l'eau condensee (~> reversible CAPE)
+c
+c ori      do 340 k=minorig+1,nl
+c ori        do 330 i=1,ncum
+c ori        if(k.ge.(icb(i)+1))then
+c ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+c ori        endif
+c ori 330    continue
+c ori 340  continue
+
+c ori      do 350 i=1,ncum
+c ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+c ori 350  continue
+
+      do 350 i=1,ncum       ! convect3
+       tp(i,nlp)=tp(i,nl)   ! convect3
+ 350  continue              ! convect3
+c
+c=====================================================================
+c  --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
+c===================================================================== 
+
+c-- this is for convect3 only:
+
+c first estimate of buoyancy:
+
+      do 500 i=1,ncum
+       do 501 k=1,nl
+        buoy(i,k)=tvp(i,k)-tv(i,k) 
+ 501   continue
+ 500  continue
+
+c set buoyancy=buoybase for all levels below base
+c for safety, set buoy(icb)=buoybase
+
+      do 505 i=1,ncum
+       do 506 k=1,nl
+        if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then
+         buoy(i,k)=buoybase(i)
+        endif
+ 506   continue
+cIM cf. CRio/JYG 270807   buoy(icb(i),k)=buoybase(i)
+       buoy(i,icb(i))=buoybase(i)
+ 505  continue
+
+c-- end convect3
+
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
+c  --- LEVEL OF NEUTRAL BUOYANCY
+c=====================================================================
+c
+c-- this is for convect3 only:
+
+      do 510 i=1,ncum
+       inb(i)=nl-1
+ 510  continue
+
+      do 530 i=1,ncum
+       do 535 k=1,nl-1
+        if ((k.ge.icb(i)).and.(buoy(i,k).lt.dtovsh)) then
+         inb(i)=MIN(inb(i),k)
+        endif
+ 535   continue
+ 530  continue
+
+c-- end convect3
+
+c ori      do 510 i=1,ncum
+c ori        cape(i)=0.0
+c ori        capem(i)=0.0
+c ori        inb(i)=icb(i)+1
+c ori        inb1(i)=inb(i)
+c ori 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+c ori      call zilch(byp,ncum)
+c ori      do 515 i=1,ncum
+c ori        lcape(i)=.true.
+c ori 515  continue
+c ori      do 530 k=minorig+1,nl-1
+c ori        do 520 i=1,ncum
+c ori          if(cape(i).lt.0.0)lcape(i)=.false.
+c ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
+c ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c ori            cape(i)=cape(i)+by
+c ori            if(by.ge.0.0)inb1(i)=k+1
+c ori            if(cape(i).gt.0.0)then
+c ori              inb(i)=k+1
+c ori              capem(i)=cape(i)
+c ori            endif
+c ori          endif
+c ori 520    continue
+c ori 530  continue
+c ori      do 540 i=1,ncum
+c ori          cape(i)=capem(i)+byp(i)
+c ori          defrac=capem(i)-cape(i)
+c ori          defrac=max(defrac,0.001)
+c ori          frac(i)=-cape(i)/defrac
+c ori          frac(i)=min(frac(i),1.0)
+c ori          frac(i)=max(frac(i),0.0)
+c ori 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+cym      do i=1,ncum*nlp
+cym       hp(i,1)=h(i,1)
+cym      enddo
+
+      do k=1,nlp
+        do i=1,ncum
+	  hp(i,k)=h(i,k)
+	enddo
+      enddo
+
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+
+        return
+        end
+
+      SUBROUTINE cv30_closure(nloc,ncum,nd,icb,inb
+     :                      ,pbase,p,ph,tv,buoy
+     o                      ,sig,w0,cape,m)
+      implicit none
+
+!===================================================================
+! ---  CLOSURE OF CONVECT3
+!
+! vectorization: S. Bony
+!===================================================================
+
+#include "cvthermo.h"
+#include "cv30param.h"
+
+c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real tv(nloc,nd), buoy(nloc,nd)
+
+c input/output:
+      real sig(nloc,nd), w0(nloc,nd)
+
+c output:
+      real cape(nloc)
+      real m(nloc,nd)
+
+c local variables:
+      integer i, j, k, icbmax
+      real deltap, fac, w, amu
+      real dtmin(nloc,nd), sigold(nloc,nd)
+
+
+c -------------------------------------------------------
+c -- Initialization
+c -------------------------------------------------------
+
+      do k=1,nl
+       do i=1,ncum
+        m(i,k)=0.0
+       enddo
+      enddo
+
+c -------------------------------------------------------
+c -- Reset sig(i) and w0(i) for i>inb and i<icb   
+c -------------------------------------------------------
+      
+c update sig and w0 above LNB:
+
+      do 100 k=1,nl-1
+       do 110 i=1,ncum
+        if ((inb(i).lt.(nl-1)).and.(k.ge.(inb(i)+1)))then
+         sig(i,k)=beta*sig(i,k)
+     :            +2.*alpha*buoy(i,inb(i))*ABS(buoy(i,inb(i)))
+         sig(i,k)=AMAX1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+ 110   continue
+ 100  continue
+
+c compute icbmax:
+
+      icbmax=2
+      do 200 i=1,ncum
+        icbmax=MAX(icbmax,icb(i))
+ 200  continue
+
+c update sig and w0 below cloud base:
+
+      do 300 k=1,icbmax
+       do 310 i=1,ncum
+        if (k.le.icb(i))then
+         sig(i,k)=beta*sig(i,k)-2.*alpha*buoy(i,icb(i))*buoy(i,icb(i))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+310    continue
+300    continue
+
+c!      if(inb.lt.(nl-1))then
+c!         do 85 i=inb+1,nl-1
+c!            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
+c!     1              abs(buoy(inb))
+c!            sig(i)=amax1(sig(i),0.0)
+c!            w0(i)=beta*w0(i)
+c!   85    continue
+c!      end if
+
+c!      do 87 i=1,icb
+c!         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
+c!         sig(i)=amax1(sig(i),0.0)
+c!         w0(i)=beta*w0(i)
+c!   87 continue
+
+c -------------------------------------------------------------
+c -- Reset fractional areas of updrafts and w0 at initial time
+c -- and after 10 time steps of no convection
+c -------------------------------------------------------------
+      
+      do 400 k=1,nl-1
+       do 410 i=1,ncum
+        if (sig(i,nd).lt.1.5.or.sig(i,nd).gt.12.0)then
+         sig(i,k)=0.0
+         w0(i,k)=0.0
+        endif
+ 410   continue
+ 400  continue
+
+c -------------------------------------------------------------
+c -- Calculate convective available potential energy (cape),  
+c -- vertical velocity (w), fractional area covered by    
+c -- undilute updraft (sig), and updraft mass flux (m)  
+c -------------------------------------------------------------
+
+      do 500 i=1,ncum
+       cape(i)=0.0
+ 500  continue
+
+c compute dtmin (minimum buoyancy between ICB and given level k):
+
+      do i=1,ncum
+       do k=1,nl
+         dtmin(i,k)=100.0 
+       enddo
+      enddo
+
+      do 550 i=1,ncum
+       do 560 k=1,nl
+         do 570 j=minorig,nl
+          if ( (k.ge.(icb(i)+1)).and.(k.le.inb(i)).and.
+     :         (j.ge.icb(i)).and.(j.le.(k-1)) )then
+           dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+          endif
+ 570     continue
+ 560   continue
+ 550  continue
+
+c the interval on which cape is computed starts at pbase :
+
+      do 600 k=1,nl
+       do 610 i=1,ncum
+
+        if ((k.ge.(icb(i)+1)).and.(k.le.inb(i))) then
+
+         deltap = MIN(pbase(i),ph(i,k-1))-MIN(pbase(i),ph(i,k))
+         cape(i)=cape(i)+rrd*buoy(i,k-1)*deltap/p(i,k-1)
+         cape(i)=AMAX1(0.0,cape(i))
+         sigold(i,k)=sig(i,k)
+
+c         dtmin(i,k)=100.0
+c         do 97 j=icb(i),k-1 ! mauvaise vectorisation
+c          dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+c  97     continue
+
+         sig(i,k)=beta*sig(i,k)+alpha*dtmin(i,k)*ABS(dtmin(i,k))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         sig(i,k)=amin1(sig(i,k),0.01)
+         fac=AMIN1(((dtcrit-dtmin(i,k))/dtcrit),1.0)
+         w=(1.-beta)*fac*SQRT(cape(i))+beta*w0(i,k)
+         amu=0.5*(sig(i,k)+sigold(i,k))*w
+         m(i,k)=amu*0.007*p(i,k)*(ph(i,k)-ph(i,k+1))/tv(i,k)
+         w0(i,k)=w
+        endif
+
+ 610   continue
+ 600  continue
+
+      do 700 i=1,ncum
+       w0(i,icb(i))=0.5*w0(i,icb(i)+1)
+       m(i,icb(i))=0.5*m(i,icb(i)+1)
+     :             *(ph(i,icb(i))-ph(i,icb(i)+1))
+     :             /(ph(i,icb(i)+1)-ph(i,icb(i)+2))
+       sig(i,icb(i))=sig(i,icb(i)+1)
+       sig(i,icb(i)-1)=sig(i,icb(i))
+ 700  continue
+
+
+c!      cape=0.0
+c!      do 98 i=icb+1,inb
+c!         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
+c!         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
+c!         dcape=rrd*buoy(i-1)*deltap/p(i-1)
+c!         dlnp=deltap/p(i-1)
+c!         cape=amax1(0.0,cape)
+c!         sigold=sig(i)
+
+c!         dtmin=100.0
+c!         do 97 j=icb,i-1
+c!            dtmin=amin1(dtmin,buoy(j))
+c!   97    continue
+
+c!         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
+c!         sig(i)=amax1(sig(i),0.0)
+c!         sig(i)=amin1(sig(i),0.01)
+c!         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
+c!         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
+c!         amu=0.5*(sig(i)+sigold)*w
+c!         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
+c!         w0(i)=w
+c!   98 continue
+c!      w0(icb)=0.5*w0(icb+1)
+c!      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
+c!      sig(icb)=sig(icb+1)
+c!      sig(icb-1)=sig(icb)
+
+       return
+       end
+
+      SUBROUTINE cv30_mixing(nloc,ncum,nd,na,ntra,icb,nk,inb
+     :                    ,ph,t,rr,rs,u,v,tra,h,lv,qnk
+     :                    ,hp,tv,tvp,ep,clw,m,sig
+     :   ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+      implicit none
+
+!---------------------------------------------------------------------
+! a faire:
+! 	- changer rr(il,1) -> qnk(il)
+!   - vectorisation de la partie normalisation des flux (do 789...)
+!---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv30param.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc), nk(nloc)
+      real sig(nloc,nd)
+      real qnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra) ! input of convect3
+      real lv(nloc,na), h(nloc,na), hp(nloc,na)
+      real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na)        ! input of convect3
+
+c outputs:
+      real ment(nloc,na,na), qent(nloc,na,na)
+      real uent(nloc,na,na), vent(nloc,na,na)
+      real sij(nloc,na,na), elij(nloc,na,na)
+      real traent(nloc,nd,nd,ntra) 
+      real ments(nloc,nd,nd), qents(nloc,nd,nd)
+      real sigij(nloc,nd,nd)
+
+c local variables:
+      integer i, j, k, il, im, jm
+      integer num1, num2
+      integer nent(nloc,na)
+      real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+      real alt, smid, sjmin, sjmax, delp, delm
+      real asij(nloc), smax(nloc), scrit(nloc)
+      real asum(nloc,nd),bsum(nloc,nd),csum(nloc,nd)
+      real wgh
+      real zm(nloc,na)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+
+c ori        do 360 i=1,ncum*nlp
+        do 361 j=1,nl
+        do 360 i=1,ncum
+          nent(i,j)=0
+c in convect3, m is computed in cv3_closure
+c ori          m(i,1)=0.0
+ 360    continue
+ 361    continue
+
+c ori      do 400 k=1,nlp
+c ori       do 390 j=1,nlp
+      do 400 j=1,nl
+       do 390 k=1,nl
+          do 385 i=1,ncum
+            qent(i,k,j)=rr(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+cym            ment(i,k,j)=0.0
+cym            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+
+cym
+      ment(1:ncum,1:nd,1:nd)=0.0
+      sij(1:ncum,1:nd,1:nd)=0.0
+      
+c      do k=1,ntra
+c       do j=1,nd  ! instead nlp
+c        do i=1,nd ! instead nlp
+c         do il=1,ncum
+c            traent(il,i,j,k)=tra(il,j,k)
+c         enddo
+c        enddo
+c       enddo
+c      enddo
+      zm(:,:)=0.
+
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+
+      do 750 i=minorig+1, nl
+
+       do 710 j=minorig,nl
+        do 700 il=1,ncum
+         if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+
+          rti=rr(il,1)-ep(il,i)*clw(il,i)
+          bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd)
+          anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j))
+          denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j)
+          dei=denom
+          if(abs(dei).lt.0.01)dei=0.01
+          sij(il,i,j)=anum/dei
+          sij(il,i,i)=1.0
+          altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+          altem=altem/bf2
+          cwat=clw(il,j)*(1.-ep(il,j))
+          stemp=sij(il,i,j)
+          if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat)
+     :                 .and.j.gt.i)then
+           anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2)
+           denom=denom+lv(il,j)*(rr(il,i)-rti)
+           if(abs(denom).lt.0.01)denom=0.01
+           sij(il,i,j)=anum/denom
+           altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+           altem=altem-(bf2-1.)*cwat
+          end if
+         if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then
+          qent(il,i,j)=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti
+          uent(il,i,j)=sij(il,i,j)*u(il,i)+(1.-sij(il,i,j))*u(il,nk(il))
+          vent(il,i,j)=sij(il,i,j)*v(il,i)+(1.-sij(il,i,j))*v(il,nk(il))
+c!!!      do k=1,ntra
+c!!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+c!!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
+c!!!      end do
+          elij(il,i,j)=altem
+          elij(il,i,j)=amax1(0.0,elij(il,i,j))
+          ment(il,i,j)=m(il,i)/(1.-sij(il,i,j))
+          nent(il,i)=nent(il,i)+1
+         end if
+         sij(il,i,j)=amax1(0.0,sij(il,i,j))
+         sij(il,i,j)=amin1(1.0,sij(il,i,j))
+         endif ! new
+ 700   continue
+ 710  continue
+
+c       do k=1,ntra
+c        do j=minorig,nl
+c         do il=1,ncum
+c          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+c     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+c            traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+c     :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
+c          endif
+c         enddo
+c        enddo
+c       enddo
+
+c
+c   ***   if no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+
+c@      do 170 i=icb(il),inb(il)
+
+      do 740 il=1,ncum
+      if ((i.ge.icb(il)).and.(i.le.inb(il)).and.(nent(il,i).eq.0)) then 
+c@      if(nent(il,i).eq.0)then
+      ment(il,i,i)=m(il,i)
+      qent(il,i,i)=rr(il,nk(il))-ep(il,i)*clw(il,i)
+      uent(il,i,i)=u(il,nk(il))
+      vent(il,i,i)=v(il,nk(il))
+      elij(il,i,i)=clw(il,i)
+cMAF      sij(il,i,i)=1.0
+      sij(il,i,i)=0.0
+      end if
+ 740  continue
+ 750  continue
+ 
+c      do j=1,ntra
+c       do i=minorig+1,nl
+c        do il=1,ncum
+c         if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
+c          traent(il,i,i,j)=tra(il,nk(il),j)
+c         endif
+c        enddo
+c       enddo
+c      enddo
+
+      do 100 j=minorig,nl
+      do 101 i=minorig,nl
+      do 102 il=1,ncum
+      if ((j.ge.(icb(il)-1)).and.(j.le.inb(il))
+     :    .and.(i.ge.icb(il)).and.(i.le.inb(il)))then
+       sigij(il,i,j)=sij(il,i,j)
+      endif
+ 102  continue
+ 101  continue
+ 100  continue
+c@      enddo
+
+c@170   continue
+
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+
+cym      call zilch(asum,ncum*nd)
+cym      call zilch(bsum,ncum*nd)
+cym      call zilch(csum,ncum*nd)
+      call zilch(asum,nloc*nd)
+      call zilch(csum,nloc*nd)
+      call zilch(csum,nloc*nd)
+
+      do il=1,ncum
+       lwork(il) = .FALSE.
+      enddo
+
+      DO 789 i=minorig+1,nl 
+
+      num1=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1
+      enddo
+      if (num1.le.0) goto 789
+
+
+      do 781 il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) then
+        lwork(il)=(nent(il,i).ne.0)
+        qp=rr(il,1)-ep(il,i)*clw(il,i)
+        anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i))
+     :           +(cpv-cpd)*t(il,i)*(qp-rr(il,i))
+        denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp)
+     :           +(cpd-cpv)*t(il,i)*(rr(il,i)-qp)
+        if(abs(denom).lt.0.01)denom=0.01
+        scrit(il)=anum/denom
+        alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp)
+        if(scrit(il).le.0.0.or.alt.le.0.0)scrit(il)=1.0
+        smax(il)=0.0
+        asij(il)=0.0
+       endif
+781   continue
+
+      do 175 j=nl,minorig,-1
+
+      num2=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il) 
+     :      .and. lwork(il) ) num2=num2+1
+      enddo
+      if (num2.le.0) goto 175
+
+      do 782 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il) 
+     :      .and. lwork(il) ) then
+
+       if(sij(il,i,j).gt.1.0e-16.and.sij(il,i,j).lt.0.95)then
+        wgh=1.0
+        if(j.gt.i)then
+         sjmax=amax1(sij(il,i,j+1),smax(il))
+         sjmax=amin1(sjmax,scrit(il))
+         smax(il)=amax1(sij(il,i,j),smax(il))
+         sjmin=amax1(sij(il,i,j-1),smax(il))
+         sjmin=amin1(sjmin,scrit(il))
+         if(sij(il,i,j).lt.(smax(il)-1.0e-16))wgh=0.0
+         smid=amin1(sij(il,i,j),scrit(il))
+        else
+         sjmax=amax1(sij(il,i,j+1),scrit(il))
+         smid=amax1(sij(il,i,j),scrit(il))
+         sjmin=0.0
+         if(j.gt.1)sjmin=sij(il,i,j-1)
+         sjmin=amax1(sjmin,scrit(il))
+        endif
+        delp=abs(sjmax-smid)
+        delm=abs(sjmin-smid)
+        asij(il)=asij(il)+wgh*(delp+delm)
+        ment(il,i,j)=ment(il,i,j)*(delp+delm)*wgh
+       endif
+      endif
+782   continue
+
+175   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        asij(il)=amax1(1.0e-16,asij(il))
+        asij(il)=1.0/asij(il)
+        asum(il,i)=0.0
+        bsum(il,i)=0.0
+        csum(il,i)=0.0
+       endif
+      enddo
+
+      do 180 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asij(il)
+        endif
+       enddo
+180   continue
+
+      do 190 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         asum(il,i)=asum(il,i)+ment(il,i,j)
+         ment(il,i,j)=ment(il,i,j)*sig(il,j)
+         bsum(il,i)=bsum(il,i)+ment(il,i,j)
+        endif
+       enddo
+190   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        bsum(il,i)=amax1(bsum(il,i),1.0e-16)
+        bsum(il,i)=1.0/bsum(il,i)
+       endif
+      enddo
+
+      do 195 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asum(il,i)*bsum(il,i)
+        endif
+       enddo
+195   continue
+
+      do 197 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         csum(il,i)=csum(il,i)+ment(il,i,j)
+        endif
+       enddo
+197   continue
+
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :     .and. csum(il,i).lt.m(il,i) ) then
+        nent(il,i)=0
+        ment(il,i,i)=m(il,i)
+        qent(il,i,i)=rr(il,1)-ep(il,i)*clw(il,i)
+        uent(il,i,i)=u(il,nk(il))
+        vent(il,i,i)=v(il,nk(il))
+        elij(il,i,i)=clw(il,i)
+cMAF        sij(il,i,i)=1.0
+        sij(il,i,i)=0.0
+       endif
+      enddo ! il
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+c     :     .and. csum(il,i).lt.m(il,i) ) then
+c         traent(il,i,i,j)=tra(il,nk(il),j)
+c        endif
+c       enddo
+c      enddo
+789   continue
+c      
+c MAF: renormalisation de MENT
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          zm(il,im)=zm(il,im)+(1.-sij(il,im,jm))*ment(il,im,jm)
+         end do
+        end do
+      end do
+c
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          if(zm(il,im).ne.0.) then
+          ment(il,im,jm)=ment(il,im,jm)*m(il,im)/zm(il,im)
+          endif
+         end do
+       end do
+      end do
+c
+      do jm=1,nd
+       do im=1,nd
+        do 999 il=1,ncum
+         qents(il,im,jm)=qent(il,im,jm)
+         ments(il,im,jm)=ment(il,im,jm)
+999     continue
+       enddo
+      enddo
+
+      return
+      end
+
+
+      SUBROUTINE cv30_unsat(nloc,ncum,nd,na,ntra,icb,inb
+     :              ,t,rr,rs,gz,u,v,tra,p,ph
+     :              ,th,tv,lv,cpn,ep,sigp,clw
+     :              ,m,ment,elij,delt,plcl
+     :              ,mp,rp,up,vp,trap,wt,water,evap,b ! RomP-jyg
+     :              ,wdtrainA,wdtrainM)               ! 26/08/10  RomP-jyg
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cv30param.h"
+#include "cvflag.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc)
+      real delt, plcl(nloc)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real th(nloc,na), gz(nloc,na)
+      real lv(nloc,na), ep(nloc,na), sigp(nloc,na), clw(nloc,na)
+      real cpn(nloc,na), tv(nloc,na)
+      real m(nloc,na), ment(nloc,na,na), elij(nloc,na,na)
+
+c outputs:
+      real mp(nloc,na), rp(nloc,na), up(nloc,na), vp(nloc,na)
+      real water(nloc,na), evap(nloc,na), wt(nloc,na)
+      real trap(nloc,na,ntra)
+      real b(nloc,na)
+! 25/08/10 - RomP---- ajout des masses precipitantes ejectees
+! lascendance adiabatique et des flux melanges Pa et Pm.
+! Distinction des wdtrain
+! Pa = wdtrainA     Pm = wdtrainM
+      real  wdtrainA(nloc,na), wdtrainM(nloc,na)
+
+c local variables
+      integer i,j,k,il,num1
+      real tinv, delti
+      real awat, afac, afac1, afac2, bfac
+      real pr1, pr2, sigt, b6, c6, revap, tevap, delth
+      real amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
+      real ampmax
+      real lvcp(nloc,na)
+      real wdtrain(nloc)
+      logical lwork(nloc)
+
+
+c------------------------------------------------------
+
+        delti = 1./delt
+        tinv=1./3.
+
+        mp(:,:)=0.
+
+        do i=1,nl
+         do il=1,ncum
+          mp(il,i)=0.0
+          rp(il,i)=rr(il,i)
+          up(il,i)=u(il,i)
+          vp(il,i)=v(il,i)
+          wt(il,i)=0.001
+          water(il,i)=0.0
+          evap(il,i)=0.0
+          b(il,i)=0.0
+          lvcp(il,i)=lv(il,i)/cpn(il,i)
+         enddo
+        enddo
+
+c        do k=1,ntra
+c         do i=1,nd
+c          do il=1,ncum
+c           trap(il,i,k)=tra(il,i,k)
+c          enddo
+c         enddo
+c        enddo
+!! RomP >>>
+         do i=1,nd
+          do il=1,ncum
+          wdtrainA(il,i)=0.0     
+          wdtrainM(il,i)=0.0     
+         enddo
+        enddo
+!! RomP <<<
+c
+c   ***  check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+
+        do il=1,ncum
+          lwork(il)=.TRUE.
+          if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE.
+        enddo
+
+        call zilch(wdtrain,ncum)
+ 
+        DO 400 i=nl+1,1,-1
+
+        num1=0
+        do il=1,ncum
+         if ( i.le.inb(il) .and. lwork(il) ) num1=num1+1
+        enddo
+        if (num1.le.0) goto 400
+
+c
+c   ***  integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+
+c
+c    ***                    begin downdraft loop                    ***
+c
+
+c
+c    ***              calculate detrained precipitation             ***
+c
+       do il=1,ncum
+        if (i.le.inb(il) .and. lwork(il)) then
+         if (cvflag_grav) then
+          wdtrain(il)=grav*ep(il,i)*m(il,i)*clw(il,i)
+          wdtrainA(il,i) = wdtrain(il)/grav     !   Pa  26/08/10   RomP
+         else
+          wdtrain(il)=10.0*ep(il,i)*m(il,i)*clw(il,i)
+          wdtrainA(il,i) = wdtrain(il)/10.      !   Pa  26/08/10   RomP
+         endif
+        endif
+       enddo
+
+       if(i.gt.1)then
+
+        do 320 j=1,i-1
+         do il=1,ncum
+          if (i.le.inb(il) .and. lwork(il)) then
+           awat=elij(il,j,i)-(1.-ep(il,i))*clw(il,i)
+           awat=amax1(awat,0.0)
+           if (cvflag_grav) then
+            wdtrain(il)=wdtrain(il)+grav*awat*ment(il,j,i)
+           else
+            wdtrain(il)=wdtrain(il)+10.0*awat*ment(il,j,i)
+           endif
+          endif
+         enddo
+320     continue
+         do il=1,ncum
+           if (cvflag_grav) then
+           wdtrainM(il,i) = wdtrain(il)/grav-wdtrainA(il,i)    !   Pm  26/08/10   RomP
+           else
+           wdtrainM(il,i) = wdtrain(il)/10.-wdtrainA(il,i)    !   Pm  26/08/10   RomP
+           endif
+         enddo
+
+       endif
+
+c
+c    ***    find rain water and evaporation using provisional   ***
+c    ***              estimates of rp(i)and rp(i-1)             ***
+c
+
+      do 999 il=1,ncum
+
+       if (i.le.inb(il) .and. lwork(il)) then
+
+      wt(il,i)=45.0
+
+      if(i.lt.inb(il))then
+       rp(il,i)=rp(il,i+1)
+     :       +(cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il,i)
+       rp(il,i)=0.5*(rp(il,i)+rr(il,i))
+      endif
+      rp(il,i)=amax1(rp(il,i),0.0)
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,inb(il))=rr(il,inb(il))
+
+      if(i.eq.1)then
+       afac=p(il,1)*(rs(il,1)-rp(il,1))/(1.0e4+2000.0*p(il,1)*rs(il,1))
+      else
+       rp(il,i-1)=rp(il,i)
+     :          +(cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il,i)
+       rp(il,i-1)=0.5*(rp(il,i-1)+rr(il,i-1))
+       rp(il,i-1)=amin1(rp(il,i-1),rs(il,i-1))
+       rp(il,i-1)=amax1(rp(il,i-1),0.0)
+       afac1=p(il,i)*(rs(il,i)-rp(il,i))/(1.0e4+2000.0*p(il,i)*rs(il,i))
+       afac2=p(il,i-1)*(rs(il,i-1)-rp(il,i-1))
+     :                /(1.0e4+2000.0*p(il,i-1)*rs(il,i-1))
+       afac=0.5*(afac1+afac2)
+      endif
+      if(i.eq.inb(il))afac=0.0
+      afac=amax1(afac,0.0)
+      bfac=1./(sigd*wt(il,i))
+c
+cjyg1
+ccc        sigt=1.0
+ccc        if(i.ge.icb)sigt=sigp(i)
+c prise en compte de la variation progressive de sigt dans
+c les couches icb et icb-1:
+c 	pour plcl<ph(i+1), pr1=0 & pr2=1
+c 	pour plcl>ph(i),   pr1=1 & pr2=0
+c 	pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
+c    sur le nuage, et pr2 est la proportion sous la base du
+c    nuage.
+      pr1=(plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
+      pr1=max(0.,min(1.,pr1))
+      pr2=(ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
+      pr2=max(0.,min(1.,pr2))
+      sigt=sigp(il,i)*pr1+pr2
+cjyg2
+c
+      b6=bfac*50.*sigd*(ph(il,i)-ph(il,i+1))*sigt*afac
+      c6=water(il,i+1)+bfac*wdtrain(il)
+     :                -50.*sigd*bfac*(ph(il,i)-ph(il,i+1))*evap(il,i+1)
+      if(c6.gt.0.0)then
+       revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+       evap(il,i)=sigt*afac*revap
+       water(il,i)=revap*revap
+      else
+       evap(il,i)=-evap(il,i+1)
+     :            +0.02*(wdtrain(il)+sigd*wt(il,i)*water(il,i+1))
+     :                 /(sigd*(ph(il,i)-ph(il,i+1)))
+      end if
+c
+c    ***  calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+      if (i.ne.1) then
+
+      tevap=amax1(0.0,evap(il,i))
+      delth=amax1(0.001,(th(il,i)-th(il,i-1)))
+      if (cvflag_grav) then
+       mp(il,i)=100.*ginv*lvcp(il,i)*sigd*tevap
+     :              *(p(il,i-1)-p(il,i))/delth
+      else
+       mp(il,i)=10.*lvcp(il,i)*sigd*tevap*(p(il,i-1)-p(il,i))/delth
+      endif
+c
+c    ***           if hydrostatic assumption fails,             ***
+c    ***   solve cubic difference equation for downdraft theta  ***
+c    ***  and mass flux from two simultaneous differential eqns ***
+c
+      amfac=sigd*sigd*70.0*ph(il,i)*(p(il,i-1)-p(il,i))
+     :          *(th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
+      amp2=abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
+      if(amp2.gt.(0.1*amfac))then
+       xf=100.0*sigd*sigd*sigd*(ph(il,i)-ph(il,i+1))
+       tf=b(il,i)-5.0*(th(il,i)-th(il,i-1))*t(il,i)
+     :               /(lvcp(il,i)*sigd*th(il,i))
+       af=xf*tf+mp(il,i+1)*mp(il,i+1)*tinv
+       bf=2.*(tinv*mp(il,i+1))**3+tinv*mp(il,i+1)*xf*tf
+     :            +50.*(p(il,i-1)-p(il,i))*xf*tevap
+       fac2=1.0
+       if(bf.lt.0.0)fac2=-1.0
+       bf=abs(bf)
+       ur=0.25*bf*bf-af*af*af*tinv*tinv*tinv
+       if(ur.ge.0.0)then
+        sru=sqrt(ur)
+        fac=1.0
+        if((0.5*bf-sru).lt.0.0)fac=-1.0
+        mp(il,i)=mp(il,i+1)*tinv+(0.5*bf+sru)**tinv
+     :                  +fac*(abs(0.5*bf-sru))**tinv
+       else
+        d=atan(2.*sqrt(-ur)/(bf+1.0e-28))
+        if(fac2.lt.0.0)d=3.14159-d
+        mp(il,i)=mp(il,i+1)*tinv+2.*sqrt(af*tinv)*cos(d*tinv)
+       endif
+       mp(il,i)=amax1(0.0,mp(il,i))
+
+       if (cvflag_grav) then
+Cjyg : il y a vraisemblablement une erreur dans la ligne 2 suivante: 
+C il faut diviser par (mp(il,i)*sigd*grav) et non par (mp(il,i)+sigd*0.1). 
+C Et il faut bien revoir les facteurs 100.
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap
+     2   /(mp(il,i)+sigd*0.1)
+     3   -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)*sigd*th(il,i))
+       else
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap
+     2   /(mp(il,i)+sigd*0.1)
+     3   -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)*sigd*th(il,i))
+       endif
+       b(il,i-1)=amax1(b(il,i-1),0.0)
+      endif
+c
+c   ***         limit magnitude of mp(i) to meet cfl condition      ***
+c
+      ampmax=2.0*(ph(il,i)-ph(il,i+1))*delti
+      amp2=2.0*(ph(il,i-1)-ph(il,i))*delti
+      ampmax=amin1(ampmax,amp2)
+      mp(il,i)=amin1(mp(il,i),ampmax)
+c
+c    ***      force mp to decrease linearly to zero                 ***
+c    ***       between cloud base and the surface                   ***
+c
+      if(p(il,i).gt.p(il,icb(il)))then
+       mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il)))
+      endif
+
+360   continue
+      endif ! i.eq.1
+c
+c    ***       find mixing ratio of precipitating downdraft     ***
+c
+
+      if (i.ne.inb(il)) then
+
+      rp(il,i)=rr(il,i)
+
+      if(mp(il,i).gt.mp(il,i+1))then
+
+       if (cvflag_grav) then
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +100.*ginv*0.5*sigd*(ph(il,i)-ph(il,i+1))
+     :                     *(evap(il,i+1)+evap(il,i))
+       else
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +5.*sigd*(ph(il,i)-ph(il,i+1))
+     :                      *(evap(il,i+1)+evap(il,i))
+       endif
+      rp(il,i)=rp(il,i)/mp(il,i)
+      up(il,i)=up(il,i+1)*mp(il,i+1)+u(il,i)*(mp(il,i)-mp(il,i+1))
+      up(il,i)=up(il,i)/mp(il,i)
+      vp(il,i)=vp(il,i+1)*mp(il,i+1)+v(il,i)*(mp(il,i)-mp(il,i+1))
+      vp(il,i)=vp(il,i)/mp(il,i)
+
+c      do j=1,ntra
+c      trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
+ctestmaf     :            +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
+c     :            +tra(il,i,j)*(mp(il,i)-mp(il,i+1))
+c      trap(il,i,j)=trap(il,i,j)/mp(il,i)
+c      end do
+
+      else
+
+       if(mp(il,i+1).gt.1.0e-16)then
+        if (cvflag_grav) then
+         rp(il,i)=rp(il,i+1)
+     :            +100.*ginv*0.5*sigd*(ph(il,i)-ph(il,i+1))
+     :            *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        else
+         rp(il,i)=rp(il,i+1)
+     :           +5.*sigd*(ph(il,i)-ph(il,i+1))
+     :           *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        endif
+       up(il,i)=up(il,i+1)
+       vp(il,i)=vp(il,i+1)
+
+c       do j=1,ntra
+c       trap(il,i,j)=trap(il,i+1,j)
+c       end do
+
+       endif
+      endif
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,i)=amax1(rp(il,i),0.0)
+
+      endif
+      endif
+999   continue
+
+400   continue
+
+       return
+       end
+
+      SUBROUTINE cv30_yield(nloc,ncum,nd,na,ntra 
+     :                    ,icb,inb,delt
+     :                    ,t,rr,u,v,tra,gz,p,ph,h,hp,lv,cpn,th
+     :                    ,ep,clw,m,tp,mp,rp,up,vp,trap
+     :                    ,wt,water,evap,b
+     :                    ,ment,qent,uent,vent,nent,elij,traent,sig
+     :                    ,tv,tvp
+     :                    ,iflag,precip,VPrecip,ft,fr,fu,fv,ftra
+     :                    ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd)
+      implicit none
+
+#include "cvthermo.h"
+#include "cv30param.h"
+#include "cvflag.h"
+#include "conema3.h"
+
+c inputs:
+      integer ncum,nd,na,ntra,nloc
+      integer icb(nloc), inb(nloc)
+      real delt
+      real t(nloc,nd), rr(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra), sig(nloc,nd)
+      real gz(nloc,na), ph(nloc,nd+1), h(nloc,na), hp(nloc,na)
+      real th(nloc,na), p(nloc,nd), tp(nloc,na)
+      real lv(nloc,na), cpn(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na), mp(nloc,na), rp(nloc,na), up(nloc,na)
+      real vp(nloc,na), wt(nloc,nd), trap(nloc,nd,ntra)
+      real water(nloc,na), evap(nloc,na), b(nloc,na)
+      real ment(nloc,na,na), qent(nloc,na,na), uent(nloc,na,na)
+cym      real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
+      real vent(nloc,na,na), elij(nloc,na,na)
+      integer nent(nloc,na)
+      real traent(nloc,na,na,ntra)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+c input/output:
+      integer iflag(nloc)
+
+c outputs:
+      real precip(nloc)
+      real VPrecip(nloc,nd+1)
+      real ft(nloc,nd), fr(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real upwd(nloc,nd), dnwd(nloc,nd), ma(nloc,nd)
+      real dnwd0(nloc,nd), mike(nloc,nd)
+      real tls(nloc,nd), tps(nloc,nd)
+      real qcondc(nloc,nd)                               ! cld
+      real wd(nloc)                                      ! gust
+
+c local variables:
+      integer i,k,il,n,j,num1
+      real rat, awat, delti
+      real ax, bx, cx, dx, ex
+      real cpinv, rdcp, dpinv
+      real lvcp(nloc,na), mke(nloc,na)
+      real am(nloc), work(nloc), ad(nloc), amp1(nloc)
+c!!      real up1(nloc), dn1(nloc)
+      real up1(nloc,nd,nd), dn1(nloc,nd,nd)
+      real asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd)  ! cld
+      real siga(nloc,nd), sax(nloc,nd), mac(nloc,nd)      ! cld
+
+
+c-------------------------------------------------------------
+
+c initialization:
+
+      delti = 1.0/delt
+
+      do il=1,ncum
+       precip(il)=0.0
+       wd(il)=0.0     ! gust
+       VPrecip(il,nd+1)=0.
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+         VPrecip(il,i)=0.0
+         ft(il,i)=0.0
+         fr(il,i)=0.0
+         fu(il,i)=0.0
+         fv(il,i)=0.0
+         qcondc(il,i)=0.0                                ! cld
+         qcond(il,i)=0.0                                 ! cld
+         nqcond(il,i)=0.0                                ! cld
+       enddo 
+      enddo
+
+c      do j=1,ntra
+c       do i=1,nd
+c        do il=1,ncum
+c          ftra(il,i,j)=0.0
+c        enddo
+c       enddo 
+c      enddo
+
+      do i=1,nl
+       do il=1,ncum
+         lvcp(il,i)=lv(il,i)/cpn(il,i)
+       enddo
+      enddo
+
+
+c
+c   ***  calculate surface precipitation in mm/day     ***
+c
+      do il=1,ncum 
+       if(ep(il,inb(il)).ge.0.0001)then 
+        if (cvflag_grav) then
+         precip(il)=wt(il,1)*sigd*water(il,1)*86400.*1000./(rowl*grav)
+        else
+         precip(il)=wt(il,1)*sigd*water(il,1)*8640.
+        endif
+       endif 
+      enddo 
+
+C   ***  CALCULATE VERTICAL PROFILE OF  PRECIPITATIONs IN kg/m2/s  ===
+C
+c MAF rajout pour lessivage
+       do k=1,nl
+         do il=1,ncum
+          if (k.le.inb(il)) then
+            if (cvflag_grav) then
+             VPrecip(il,k) = wt(il,k)*sigd*water(il,k)/grav
+            else
+             VPrecip(il,k) = wt(il,k)*sigd*water(il,k)/10.
+            endif 
+          endif
+         end do
+       end do
+C
+c
+c   ***  Calculate downdraft velocity scale    ***
+c   ***  NE PAS UTILISER POUR L'INSTANT ***
+c
+c!      do il=1,ncum
+c!        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
+c!     :                                  /(sigd*p(il,icb(il)))
+c!      enddo
+
+c
+c   ***  calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+      do il=1,ncum
+       work(il)=1.0/(ph(il,1)-ph(il,2))
+       am(il)=0.0
+      enddo
+
+      do k=2,nl
+       do il=1,ncum
+        if (k.le.inb(il)) then
+         am(il)=am(il)+m(il,k)
+        endif
+       enddo
+      enddo
+
+      do il=1,ncum
+
+c convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+      if((0.01*grav*work(il)*am(il)).ge.delti)iflag(il)=1!consist vect
+       ft(il,1)=0.01*grav*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      else
+       if((0.1*work(il)*am(il)).ge.delti)iflag(il)=1 !consistency vect
+       ft(il,1)=0.1*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      endif
+
+      ft(il,1)=ft(il,1)-0.5*lvcp(il,1)*sigd*(evap(il,1)+evap(il,2))
+
+      if (cvflag_grav) then
+       ft(il,1)=ft(il,1)-0.009*grav*sigd*mp(il,2)
+     :                             *t(il,1)*b(il,1)*work(il)
+      else
+       ft(il,1)=ft(il,1)-0.09*sigd*mp(il,2)*t(il,1)*b(il,1)*work(il)
+      endif
+
+      ft(il,1)=ft(il,1)+0.01*sigd*wt(il,1)*(cl-cpd)*water(il,2)*(t(il,2)
+     :-t(il,1))*work(il)/cpn(il,1)
+
+      if (cvflag_grav) then
+Cjyg1  Correction pour mieux conserver l'eau (conformite avec CONVECT4.3)
+c (sb: pour l'instant, on ne fait que le chgt concernant grav, pas evap) 
+       fr(il,1)=0.01*grav*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
+     :          +sigd*0.5*(evap(il,1)+evap(il,2))
+c+tard     :          +sigd*evap(il,1)
+
+       fr(il,1)=fr(il,1)+0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
+
+       fu(il,1)=fu(il,1)+0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+      else  ! cvflag_grav
+       fr(il,1)=0.1*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)
+     :          +sigd*0.5*(evap(il,1)+evap(il,2))
+       fr(il,1)=fr(il,1)+0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
+       fu(il,1)=fu(il,1)+0.1*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.1*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+      endif ! cvflag_grav
+
+      enddo ! il
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        if (cvflag_grav) then
+c         ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
+c     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+c     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+c        else
+c         ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
+c     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+c     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+c        endif
+c       enddo
+c      enddo
+
+      do j=2,nl
+       do il=1,ncum
+        if (j.le.inb(il)) then
+         if (cvflag_grav) then
+          fr(il,1)=fr(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         else   ! cvflag_grav
+          fr(il,1)=fr(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         endif  ! cvflag_grav
+        endif ! j
+       enddo
+      enddo
+
+c      do k=1,ntra
+c       do j=2,nl
+c        do il=1,ncum
+c         if (j.le.inb(il)) then
+
+c          if (cvflag_grav) then
+c           ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
+c     :                *(traent(il,j,1,k)-tra(il,1,k))
+c          else
+c           ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
+c     :                *(traent(il,j,1,k)-tra(il,1,k))
+c          endif
+
+c         endif
+c        enddo
+c       enddo
+c      enddo
+
+c
+c   ***  calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  first find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+
+      do 500 i=2,nl+1 ! newvecto: mettre nl au lieu nl+1?
+
+       num1=0
+       do il=1,ncum
+        if(i.le.inb(il))num1=num1+1
+       enddo
+       if(num1.le.0)go to 500
+
+       call zilch(amp1,ncum)
+       call zilch(ad,ncum)
+
+      do 440 k=i+1,nl+1
+       do 441 il=1,ncum
+        if (i.le.inb(il) .and. k.le.(inb(il)+1)) then
+         amp1(il)=amp1(il)+m(il,k)
+        endif
+ 441   continue
+ 440  continue
+
+      do 450 k=1,i
+       do 451 j=i+1,nl+1
+        do 452 il=1,ncum
+         if (i.le.inb(il) .and. j.le.(inb(il)+1)) then
+          amp1(il)=amp1(il)+ment(il,k,j)
+         endif
+452     continue
+451    continue
+450   continue
+
+      do 470 k=1,i-1
+       do 471 j=i,nl+1 ! newvecto: nl au lieu nl+1?
+        do 472 il=1,ncum
+        if (i.le.inb(il) .and. j.le.inb(il)) then
+         ad(il)=ad(il)+ment(il,j,k)
+        endif
+472     continue
+471    continue
+470   continue
+  
+      do 1350 il=1,ncum
+      if (i.le.inb(il)) then
+       dpinv=1.0/(ph(il,i)-ph(il,i+1))
+       cpinv=1.0/cpn(il,i)
+
+c convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+       if((0.01*grav*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      else
+       if((0.1*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      endif
+
+      if (cvflag_grav) then
+       ft(il,i)=0.01*grav*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+     :    -0.5*sigd*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       rat=cpn(il,i-1)*cpinv
+       ft(il,i)=ft(il,i)-0.009*grav*sigd*(mp(il,i+1)*t(il,i)*b(il,i)
+     :   -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.01*grav*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      else  ! cvflag_grav
+       ft(il,i)=0.1*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+     :    -0.5*sigd*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       rat=cpn(il,i-1)*cpinv
+       ft(il,i)=ft(il,i)-0.09*sigd*(mp(il,i+1)*t(il,i)*b(il,i)
+     :   -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.1*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      endif ! cvflag_grav
+
+
+      ft(il,i)=ft(il,i)+0.01*sigd*wt(il,i)*(cl-cpd)*water(il,i+1)
+     :           *(t(il,i+1)-t(il,i))*dpinv*cpinv
+
+      if (cvflag_grav) then
+       fr(il,i)=0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      else  ! cvflag_grav
+       fr(il,i)=0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.1*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.1*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      endif ! cvflag_grav
+
+      endif ! i
+1350  continue
+
+c      do k=1,ntra
+c       do il=1,ncum
+c        if (i.le.inb(il)) then
+c         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c         cpinv=1.0/cpn(il,i)
+c         if (cvflag_grav) then
+c           ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
+c     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+c     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+c         else
+c           ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
+c     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+c     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+c         endif
+c        endif
+c       enddo
+c      enddo
+
+      do 480 k=1,i-1
+       do 1370 il=1,ncum
+        if (i.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+      awat=elij(il,k,i)-(1.-ep(il,i))*clw(il,i)
+      awat=amax1(awat,0.0)
+
+      if (cvflag_grav) then
+      fr(il,i)=fr(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      else  ! cvflag_grav
+      fr(il,i)=fr(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      endif ! cvflag_grav
+
+c (saturated updrafts resulting from mixing)        ! cld
+        qcond(il,i)=qcond(il,i)+(elij(il,k,i)-awat) ! cld
+        nqcond(il,i)=nqcond(il,i)+1.                ! cld
+      endif ! i
+1370  continue
+480   continue
+
+c      do j=1,ntra
+c       do k=1,i-1
+c        do il=1,ncum
+c         if (i.le.inb(il)) then
+c          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c          cpinv=1.0/cpn(il,i)
+c          if (cvflag_grav) then
+c           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+c     :        *(traent(il,k,i,j)-tra(il,i,j))
+c          else
+c           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+c     :        *(traent(il,k,i,j)-tra(il,i,j))
+c          endif
+c         endif
+c        enddo
+c       enddo
+c      enddo
+
+      do 490 k=i,nl+1
+       do 1380 il=1,ncum
+        if (i.le.inb(il) .and. k.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+         if (cvflag_grav) then
+         fr(il,i)=fr(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         else  ! cvflag_grav 
+         fr(il,i)=fr(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         endif ! cvflag_grav 
+        endif ! i and k
+1380   continue
+490   continue
+
+c      do j=1,ntra
+c       do k=i,nl+1
+c        do il=1,ncum
+c         if (i.le.inb(il) .and. k.le.inb(il)) then
+c          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c          cpinv=1.0/cpn(il,i)
+c          if (cvflag_grav) then
+c           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+c     :         *(traent(il,k,i,j)-tra(il,i,j))
+c          else
+c           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+c     :             *(traent(il,k,i,j)-tra(il,i,j))
+c          endif
+c         endif ! i and k
+c        enddo
+c       enddo
+c      enddo
+
+      do 1400 il=1,ncum
+       if (i.le.inb(il)) then
+        dpinv=1.0/(ph(il,i)-ph(il,i+1))
+        cpinv=1.0/cpn(il,i)
+
+        if (cvflag_grav) then
+c sb: on ne fait pas encore la correction permettant de mieux
+c conserver l'eau:
+         fr(il,i)=fr(il,i)+0.5*sigd*(evap(il,i)+evap(il,i+1))
+     :        +0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)
+     :               *(rp(il,i)-rr(il,i-1)))*dpinv
+
+         fu(il,i)=fu(il,i)+0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=fv(il,i)+0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        else  ! cvflag_grav
+         fr(il,i)=fr(il,i)+0.5*sigd*(evap(il,i)+evap(il,i+1))
+     :        +0.1*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)
+     :               *(rp(il,i)-rr(il,i-1)))*dpinv
+         fu(il,i)=fu(il,i)+0.1*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=fv(il,i)+0.1*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        endif ! cvflag_grav
+
+      endif ! i
+1400  continue
+
+c sb: interface with the cloud parameterization:          ! cld
+
+      do k=i+1,nl
+       do il=1,ncum 
+        if (k.le.inb(il) .and. i.le.inb(il)) then         ! cld
+C (saturated downdrafts resulting from mixing)            ! cld
+          qcond(il,i)=qcond(il,i)+elij(il,k,i)            ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+        endif                                             ! cld
+       enddo                                              ! cld
+      enddo                                               ! cld
+
+C (particular case: no detraining level is found)         ! cld
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nent(il,i).eq.0) then       ! cld
+          qcond(il,i)=qcond(il,i)+(1.-ep(il,i))*clw(il,i) ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+       endif                                              ! cld
+      enddo                                               ! cld
+
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nqcond(il,i).ne.0.) then    ! cld
+          qcond(il,i)=qcond(il,i)/nqcond(il,i)            ! cld
+       endif                                              ! cld
+      enddo
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        if (i.le.inb(il)) then
+c         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+c         cpinv=1.0/cpn(il,i)
+
+c         if (cvflag_grav) then
+c          ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
+c     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+c     :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
+c         else
+c          ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
+c     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+c     :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
+c         endif
+c        endif ! i
+c       enddo
+c      enddo 
+
+500   continue
+
+
+c   ***   move the detrainment at level inb down to level inb-1   ***
+c   ***        in such a way as to preserve the vertically        ***
+c   ***          integrated enthalpy and water tendencies         ***
+c
+      do 503 il=1,ncum
+
+      ax=0.1*ment(il,inb(il),inb(il))*(hp(il,inb(il))-h(il,inb(il))
+     : +t(il,inb(il))*(cpv-cpd)
+     : *(rr(il,inb(il))-qent(il,inb(il),inb(il))))
+     :  /(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
+      ft(il,inb(il))=ft(il,inb(il))-ax
+      ft(il,inb(il)-1)=ft(il,inb(il)-1)+ax*cpn(il,inb(il))
+     :    *(ph(il,inb(il))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)
+     :    *(ph(il,inb(il)-1)-ph(il,inb(il))))
+
+      bx=0.1*ment(il,inb(il),inb(il))*(qent(il,inb(il),inb(il))
+     :    -rr(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fr(il,inb(il))=fr(il,inb(il))-bx
+      fr(il,inb(il)-1)=fr(il,inb(il)-1)
+     :   +bx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :      /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      cx=0.1*ment(il,inb(il),inb(il))*(uent(il,inb(il),inb(il))
+     :       -u(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fu(il,inb(il))=fu(il,inb(il))-cx
+      fu(il,inb(il)-1)=fu(il,inb(il)-1)
+     :     +cx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :        /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      dx=0.1*ment(il,inb(il),inb(il))*(vent(il,inb(il),inb(il))
+     :      -v(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fv(il,inb(il))=fv(il,inb(il))-dx
+      fv(il,inb(il)-1)=fv(il,inb(il)-1)
+     :    +dx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :       /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+503   continue
+
+c      do j=1,ntra
+c       do il=1,ncum
+c        ex=0.1*ment(il,inb(il),inb(il)) 
+c     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+c     :      /(ph(il,inb(il))-ph(il,inb(il)+1))
+c        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+c        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+c     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+c     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+c       enddo
+c      enddo
+
+c
+c   ***    homoginize tendencies below cloud base    ***
+c
+c
+      do il=1,ncum
+       asum(il)=0.0
+       bsum(il)=0.0
+       csum(il)=0.0
+       dsum(il)=0.0
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+      asum(il)=asum(il)+ft(il,i)*(ph(il,i)-ph(il,i+1))
+      bsum(il)=bsum(il)+fr(il,i)*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                  *(ph(il,i)-ph(il,i+1))
+      csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                      *(ph(il,i)-ph(il,i+1))
+      dsum(il)=dsum(il)+t(il,i)*(ph(il,i)-ph(il,i+1))/th(il,i)
+        endif 
+       enddo
+      enddo
+
+c!!!      do 700 i=1,icb(il)-1
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ft(il,i)=asum(il)*t(il,i)/(th(il,i)*dsum(il))
+         fr(il,i)=bsum(il)/csum(il)
+        endif
+       enddo
+      enddo
+
+c
+c   ***           reset counter and return           ***
+c
+      do il=1,ncum
+       sig(il,nd)=2.0
+      enddo
+
+
+      do i=1,nd
+       do il=1,ncum
+        upwd(il,i)=0.0
+        dnwd(il,i)=0.0
+       enddo
+      enddo
+      
+      do i=1,nl
+       do il=1,ncum
+        dnwd0(il,i)=-mp(il,i)
+       enddo
+      enddo
+      do i=nl+1,nd
+       do il=1,ncum
+        dnwd0(il,i)=0.
+       enddo
+      enddo
+
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.ge.icb(il) .and. i.le.inb(il)) then
+          upwd(il,i)=0.0
+          dnwd(il,i)=0.0
+        endif
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=1,nl
+        do il=1,ncum
+          up1(il,k,i)=0.0
+          dn1(il,k,i)=0.0
+        enddo
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=i,nl
+        do n=1,i-1
+         do il=1,ncum
+          if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+             up1(il,k,i)=up1(il,k,i)+ment(il,n,k)
+             dn1(il,k,i)=dn1(il,k,i)-ment(il,k,n)
+          endif
+         enddo
+        enddo
+       enddo
+      enddo
+
+      do i=2,nl
+       do k=i,nl
+        do il=1,ncum
+ctest         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+         if (i.le.inb(il).and.k.le.inb(il)) then
+            upwd(il,i)=upwd(il,i)+m(il,k)+up1(il,k,i)
+            dnwd(il,i)=dnwd(il,i)+dn1(il,k,i)
+         endif
+        enddo
+       enddo
+      enddo
+
+
+c!!!      DO il=1,ncum
+c!!!      do i=icb(il),inb(il)
+c!!!     
+c!!!      upwd(il,i)=0.0
+c!!!      dnwd(il,i)=0.0
+c!!!      do k=i,inb(il)
+c!!!      up1=0.0
+c!!!      dn1=0.0
+c!!!      do n=1,i-1
+c!!!      up1=up1+ment(il,n,k)
+c!!!      dn1=dn1-ment(il,k,n)
+c!!!      enddo
+c!!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
+c!!!      dnwd(il,i)=dnwd(il,i)+dn1
+c!!!      enddo
+c!!!      enddo
+c!!!
+c!!!      ENDDO
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        determination de la variation de flux ascendant entre
+c        deux niveau non dilue mike
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nl
+       do il=1,ncum
+        mike(il,i)=m(il,i)
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        mike(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+        ma(il,i)=0
+       enddo
+      enddo
+
+      do i=1,nl
+       do j=i,nl
+        do il=1,ncum
+         ma(il,i)=ma(il,i)+m(il,j)
+        enddo
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        ma(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ma(il,i)=0
+        endif
+       enddo
+      enddo
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        icb represente de niveau ou se trouve la
+c        base du nuage , et inb le top du nuage
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nd
+       do il=1,ncum
+        mke(il,i)=upwd(il,i)+dnwd(il,i)
+       enddo
+      enddo
+
+      do i=1,nd
+       DO 999 il=1,ncum
+        rdcp=(rrd*(1.-rr(il,i))-rr(il,i)*rrv)
+     :        /(cpd*(1.-rr(il,i))+rr(il,i)*cpv)
+        tls(il,i)=t(il,i)*(1000.0/p(il,i))**rdcp
+        tps(il,i)=tp(il,i)
+999    CONTINUE
+      enddo
+
+c
+c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+c   ***           of condensed water         ***            ! cld
+c                                                           ! cld
+
+       do i=1,nd                                            ! cld
+        do il=1,ncum                                        ! cld
+         mac(il,i)=0.0                                      ! cld
+         wa(il,i)=0.0                                       ! cld
+         siga(il,i)=0.0                                     ! cld
+         sax(il,i)=0.0                                      ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=minorig, nl                                     ! cld
+        do k=i+1,nl+1                                       ! cld
+         do il=1,ncum                                       ! cld
+          if (i.le.inb(il) .and. k.le.(inb(il)+1)) then     ! cld
+            mac(il,i)=mac(il,i)+m(il,k)                     ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do j=1,i                                            ! cld
+         do il=1,ncum                                       ! cld
+          if (i.ge.icb(il) .and. i.le.(inb(il)-1)           ! cld
+     :      .and. j.ge.icb(il) ) then                       ! cld
+           sax(il,i)=sax(il,i)+rrd*(tvp(il,j)-tv(il,j))     ! cld
+     :        *(ph(il,j)-ph(il,j+1))/p(il,j)                ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (i.ge.icb(il) .and. i.le.(inb(il)-1)            ! cld
+     :       .and. sax(il,i).gt.0.0 ) then                  ! cld
+           wa(il,i)=sqrt(2.*sax(il,i))                      ! cld
+         endif                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+            
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (wa(il,i).gt.0.0)                               ! cld
+     :     siga(il,i)=mac(il,i)/wa(il,i)                    ! cld
+     :         *rrd*tvp(il,i)/p(il,i)/100./delta            ! cld
+          siga(il,i) = min(siga(il,i),1.0)                  ! cld
+cIM cf. FH
+         if (iflag_clw.eq.0) then
+          qcondc(il,i)=siga(il,i)*clw(il,i)*(1.-ep(il,i))   ! cld
+     :           + (1.-siga(il,i))*qcond(il,i)              ! cld
+         else if (iflag_clw.eq.1) then
+          qcondc(il,i)=qcond(il,i)              ! cld
+         endif
+
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+        return
+        end
+
+!!RomP >>>
+      SUBROUTINE cv30_tracer(nloc,len,ncum,nd,na,
+     &                       ment,sij,da,phi,phi2,d1a,dam,
+     &                       ep,VPrecip,elij,clw,epmlmMm,eplaMm,
+     &                       icb,inb)
+        implicit none
+
+#include "cv30param.h"
+
+c inputs:
+        integer ncum, nd, na, nloc,len
+        real ment(nloc,na,na),sij(nloc,na,na)
+	real clw(nloc,nd),elij(nloc,na,na)
+	real ep(nloc,na)
+        integer icb(nloc),inb(nloc)
+        real VPrecip(nloc,nd+1)
+c ouputs:
+        real da(nloc,na),phi(nloc,na,na)
+	real phi2(nloc,na,na)
+	real d1a(nloc,na),dam(nloc,na)
+	real epmlmMm(nloc,na,na),eplaMm(nloc,na)
+! variables pour tracer dans precip de l'AA et des mel
+c local variables:
+        integer i,j,k
+	real epm(nloc,na,na)
+c
+! variables d'Emanuel : du second indice au troisieme
+! --->    tab(i,k,j) -> de l origine k a l arrivee j 
+!  ment, sij, elij
+! variables personnelles : du troisieme au second indice
+! --->    tab(i,j,k) -> de k a j 
+! phi, phi2
+!
+! initialisations
+       do j=1,na
+        do i=1,ncum
+         da(i,j)=0.
+         d1a(i,j)=0.
+         dam(i,j)=0.
+         eplaMm(i,j)=0.
+        enddo
+       enddo
+      do k=1,na
+       do j=1,na
+        do i=1,ncum
+         epm(i,j,k)=0.
+         epmlmMm(i,j,k)=0.
+         phi(i,j,k)=0.
+         phi2(i,j,k)=0.
+        enddo
+       enddo
+      enddo
+c
+!  fraction deau condensee dans les melanges convertie en precip : epm
+! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz
+        do j=1,na
+         do k=1,j-1
+           do i=1,ncum
+            if(k.ge.icb(i).and.k.le.inb(i).and.
+     &         j.le.inb(i)) then
+!!jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
+             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/
+     &                     max(elij(i,k,j),1.e-16)
+!!
+             epm(i,j,k)=max(epm(i,j,k),0.0)
+            endif
+           end do 
+         end do 
+        end do
+!
+        do j=1,na
+         do k=1,na
+           do i=1,ncum
+            if(k.ge.icb(i).and.k.le.inb(i)) then
+             eplaMm(i,j)=eplaMm(i,j) + ep(i,j)*clw(i,j)
+     &                  *ment(i,j,k)*(1.-sij(i,j,k))
+            endif
+           end do 
+         end do 
+        end do
+!
+        do j=1,na
+         do k=1,j-1
+           do i=1,ncum
+            if(k.ge.icb(i).and.k.le.inb(i).and.
+     &         j.le.inb(i)) then
+             epmlmMm(i,j,k)=epm(i,j,k)*elij(i,k,j)*ment(i,k,j)
+            endif
+           end do 
+         end do 
+        end do
+
+!  matrices pour calculer la tendance des concentrations dans cvltr.F90
+        do j=1,na
+          do k=1,na
+            do i=1,ncum
+             da(i,j)=da(i,j)+(1.-sij(i,k,j))*ment(i,k,j)
+             phi(i,j,k)=sij(i,k,j)*ment(i,k,j)
+             d1a(i,j)=d1a(i,j)+ment(i,k,j)*ep(i,k)
+     &              *(1.-sij(i,k,j))
+            end do 
+          end do 
+        end do 
+
+        do j=1,na
+          do k=1,j-1
+            do i=1,ncum
+             dam(i,j)=dam(i,j)+ment(i,k,j)
+     &             *epm(i,j,k)*(1.-ep(i,k))*(1.-sij(i,k,j)) 
+             phi2(i,j,k)=phi(i,j,k)*epm(i,j,k)
+            end do 
+          end do 
+        end do 
+
+        return
+        end
+!RomP <<<
+
+      SUBROUTINE cv30_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :         ,iflag
+     :         ,precip,VPrecip,evap,ep,sig,w0
+     :         ,ft,fq,fu,fv,ftra
+     :         ,inb
+     :         ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape
+     :         ,da,phi,mp,phi2,d1a,dam,sij
+     :         ,elij,clw,epmlmMm,eplaMm
+     :         ,wdtrainA,wdtrainM
+     :         ,iflag1
+     :         ,precip1,VPrecip1,evap1,ep1,sig1,w01
+     :         ,ft1,fq1,fu1,fv1,ftra1
+     :         ,inb1
+     :         ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1
+     :         ,da1,phi1,mp1,phi21,d1a1,dam1,sij1
+     :         ,elij1,clw1,epmlmMm1,eplaMm1
+     :         ,wdtrainA1,wdtrainM1)
+      implicit none
+
+#include "cv30param.h"
+
+c inputs:
+      integer len, ncum, nd, ntra, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      integer inb(nloc)
+      real precip(nloc)
+      real VPrecip(nloc,nd+1),evap(nloc,nd)
+      real ep(nloc,nd)
+      real sig(nloc,nd), w0(nloc,nd)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real Ma(nloc,nd)
+      real upwd(nloc,nd),dnwd(nloc,nd),dnwd0(nloc,nd)
+      real qcondc(nloc,nd)
+      real wd(nloc),cape(nloc)
+      real da(nloc,nd),phi(nloc,nd,nd),mp(nloc,nd)
+!RomP >>>
+      real phi2(nloc,nd,nd)
+      real d1a(nloc,nd),dam(nloc,nd)
+      real wdtrainA(nloc,nd), wdtrainM(nloc,nd)
+      real sij(nloc,nd,nd)
+      real elij(nloc,nd,nd),clw(nloc,nd)
+      real epmlmMm(nloc,nd,nd),eplaMm(nloc,nd)
+!RomP <<<
+
+c outputs:
+      integer iflag1(len)
+      integer inb1(len)
+      real precip1(len)
+      real VPrecip1(len,nd+1),evap1(len,nd) !<<< RomP
+      real ep1(len,nd)                      !<<< RomP
+      real sig1(len,nd), w01(len,nd)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real Ma1(len,nd)
+      real upwd1(len,nd),dnwd1(len,nd),dnwd01(len,nd)
+      real qcondc1(nloc,nd)
+      real wd1(nloc),cape1(nloc)
+      real da1(nloc,nd),phi1(nloc,nd,nd),mp1(nloc,nd)
+!RomP >>>
+      real phi21(len,nd,nd)
+      real d1a1(len,nd),dam1(len,nd)
+      real wdtrainA1(len,nd), wdtrainM1(len,nd)
+      real sij1(len,nd,nd)
+      real elij1(len,nd,nd),clw1(len,nd)
+      real epmlmMm1(len,nd,nd),eplaMm1(len,nd)
+!RomP <<<
+
+c local variables:
+      integer i,k,j
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         iflag1(idcum(i))=iflag(i)
+         wd1(idcum(i))=wd(i)
+         inb1(idcum(i))=inb(i)
+         cape1(idcum(i))=cape(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            VPrecip1(idcum(i),k)=VPrecip(i,k)
+            evap1(idcum(i),k)=evap(i,k)   !<<< RomP
+            sig1(idcum(i),k)=sig(i,k)
+            w01(idcum(i),k)=w0(i,k)
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            upwd1(idcum(i),k)=upwd(i,k)
+            dnwd1(idcum(i),k)=dnwd(i,k)
+            dnwd01(idcum(i),k)=dnwd0(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+            da1(idcum(i),k)=da(i,k)
+            mp1(idcum(i),k)=mp(i,k)
+!RomP >>>
+            ep1(idcum(i),k)=ep(i,k)
+            d1a1(idcum(i),k)=d1a(i,k)
+            dam1(idcum(i),k)=dam(i,k)
+            clw1(idcum(i),k)=clw(i,k)
+            eplaMm1(idcum(i),k)=eplaMm(i,k)
+            wdtrainA1(idcum(i),k)=wdtrainA(i,k)
+            wdtrainM1(idcum(i),k)=wdtrainM(i,k)
+!RomP <<<
+ 2010     continue
+ 2020   continue
+
+        do 2200 i=1,ncum
+          sig1(idcum(i),nd)=sig(i,nd)
+2200    continue
+
+
+c        do 2100 j=1,ntra
+c         do 2110 k=1,nd ! oct3
+c          do 2120 i=1,ncum
+c            ftra1(idcum(i),k,j)=ftra(i,k,j)
+c 2120     continue
+c 2110    continue
+c 2100   continue
+        do j=1,nd
+         do k=1,nd 
+          do i=1,ncum
+            sij1(idcum(i),k,j)=sij(i,k,j)
+            phi1(idcum(i),k,j)=phi(i,k,j)
+            phi21(idcum(i),k,j)=phi2(i,k,j)
+            elij1(idcum(i),k,j)=elij(i,k,j)
+            epmlmMm1(idcum(i),k,j)=epmlmMm(i,k,j)
+          end do
+         end do
+        end do
+
+        return
+        end
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv30_routines.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv30_routines.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv30_routines.F90	(revision 17)
@@ -0,0 +1,3301 @@
+!
+! $Id: cv30_routines.F 1750 2013-04-25 15:27:27Z fairhead $
+!
+!c
+!c
+      SUBROUTINE cv30_param(nd,delt)
+      implicit none
+
+!c------------------------------------------------------------
+!c Set parameters for convectL for iflag_con = 3 
+!c------------------------------------------------------------
+
+!C
+!C   ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
+!C   ***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
+!C   ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***     
+!C   ***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
+!C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+!C   ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***     
+!C   ***                        OF CLOUD                         ***
+!C
+!C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
+!C   ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
+!C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+!C   ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
+!C   ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
+!C
+!C   ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
+!C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+!C   ***                     IT MUST BE LESS THAN 0              ***
+
+#include "cv30param.h"
+#include "conema3.h"
+
+      integer nd
+      real delt ! timestep (seconds)
+
+!c noff: integer limit for convection (nd-noff)
+!c minorig: First level of convection
+
+!c -- limit levels for convection:
+
+      noff    = 1
+      minorig = 1
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+!c -- "microphysical" parameters:
+
+      sigd   = 0.01
+      spfac  = 0.15
+      pbcrit = 150.0
+      ptcrit = 500.0
+!IM cf. FH     epmax  = 0.993
+
+      omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
+
+!c -- misc:
+
+      dtovsh = -0.2 ! dT for overshoot
+      dpbase = -40. ! definition cloud base (400m above LCL)
+      dttrig = 5.   ! (loose) condition for triggering 
+
+!c -- rate of approach to quasi-equilibrium:
+
+      dtcrit = -2.0
+      tau    = 8000.
+      beta   = 1.0 - delt/tau
+      alpha  = 1.5E-3 * delt/tau
+!c increase alpha to compensate W decrease:
+      alpha  = alpha*1.5
+
+!c -- interface cloud parameterization:
+
+      delta=0.01  ! cld
+
+!c -- interface with boundary-layer (gust factor): (sb)
+
+      betad=10.0   ! original value (from convect 4.3)
+
+      return
+      end SUBROUTINE cv30_param
+
+      SUBROUTINE cv30_prelim(len,nd,ndp1,t,q,p,ph                                    &
+       &                    ,lv,cpn,tv,gz,h,hm,th)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+! "ori": from convect4.3 (vectorized)
+! "convect3": to be exactly consistent with convect3
+!=====================================================================
+
+!c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+!c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+      real th(len,nd)
+
+!c local variables:
+      integer k, i
+      real rdcp
+      real tvx,tvy ! convect3
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cv30param.h"
+
+
+!c ori      do 110 k=1,nlp
+      do 110 k=1,nl ! convect3
+        do 100 i=1,len
+!cdebug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          lv(i,k)= lv0-clmcpv*(t(i,k)-273.15)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+!c ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k))
+          rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k)
+          th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp
+ 100    continue
+ 110  continue
+!c
+!c gz = phi at the full levels (same as p).
+!c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+!c ori      do 140 k=2,nlp
+      do 140 k=2,nl ! convect3
+        do 130 i=1,len
+        tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k))       !convect3
+        tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
+        gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy)                                          & !convect3
+       &          *(p(i,k-1)-p(i,k))/ph(i,k)      !convect3
+
+!c ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+!c ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+!c
+!c h  = phi + cpT (dry static energy).
+!c hm = phi + cp(T-Tbase)+Lq
+!c
+!c ori      do 170 k=1,nlp
+      do 170 k=1,nl ! convect3
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+
+      return
+      end SUBROUTINE cv30_prelim
+
+      SUBROUTINE cv30_feed(len,nd,t,q,qs,p,ph,hm,gz                                  &
+       &                  ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl)
+      implicit none
+
+!C================================================================
+!C Purpose: CONVECTIVE FEED
+!C
+!C Main differences with cv_feed:
+!C   - ph added in input
+!C	- here, nk(i)=minorig
+!C	- icb defined differently (plcl compared with ph instead of p)
+!C
+!C Main differences with convect3:
+!C 	- we do not compute dplcldt and dplcldr of CLIFT anymore 
+!C	- values iflag different (but tests identical)
+!C   - A,B explicitely defined (!...)
+!C================================================================
+
+#include "cv30param.h"
+
+!c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), qs(len,nd), p(len,nd)
+      real hm(len,nd), gz(len,nd)
+      real ph(len,nd+1)
+
+!c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+      real tnk(len), qnk(len), gznk(len), plcl(len)
+
+!c local variables:
+      integer i, k
+      integer ihmin(len)
+      real work(len)
+      real pnk(len), qsnk(len), rh(len), chi(len)
+      real A, B ! convect3
+!cym
+      plcl=0.0
+!c@ !-------------------------------------------------------------------
+!c@ ! --- Find level of minimum moist static energy
+!c@ ! --- If level of minimum moist static energy coincides with
+!c@ ! --- or is lower than minimum allowable parcel origin level,
+!c@ ! --- set iflag to 6.
+!c@ !-------------------------------------------------------------------
+!c@ 
+!c@       do 180 i=1,len
+!c@        work(i)=1.0e12
+!c@        ihmin(i)=nl
+!c@  180  continue
+!c@       do 200 k=2,nlp
+!c@         do 190 i=1,len
+!c@          if((hm(i,k).lt.work(i)).and.
+!c@      &      (hm(i,k).lt.hm(i,k-1)))then
+!c@            work(i)=hm(i,k)
+!c@            ihmin(i)=k
+!c@          endif
+!c@  190    continue
+!c@  200  continue
+!c@       do 210 i=1,len
+!c@         ihmin(i)=min(ihmin(i),nlm)
+!c@         if(ihmin(i).le.minorig)then
+!c@           iflag(i)=6
+!c@         endif
+!c@  210  continue
+!c@ c
+!c@ !-------------------------------------------------------------------
+!c@ ! --- Find that model level below the level of minimum moist static
+!c@ ! --- energy that has the maximum value of moist static energy
+!c@ !-------------------------------------------------------------------
+!c@  
+!c@       do 220 i=1,len
+!c@        work(i)=hm(i,minorig)
+!c@        nk(i)=minorig
+!c@  220  continue
+!c@       do 240 k=minorig+1,nl
+!c@         do 230 i=1,len
+!c@          if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+!c@            work(i)=hm(i,k)
+!c@            nk(i)=k
+!c@          endif
+!c@  230     continue
+!c@  240  continue
+
+!-------------------------------------------------------------------
+! --- Origin level of ascending parcels for convect3:
+!-------------------------------------------------------------------
+
+         do 220 i=1,len
+          nk(i)=minorig
+  220    continue
+
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if( (     ( t(i,nk(i)).lt.250.0    )                                          &
+       &       .or.( q(i,nk(i)).le.0.0      )     )                                  &
+!c@      &       .or.( p(i,ihmin(i)).lt.400.0 )  )                                   &
+       &   .and.                                                                     &
+       &       ( iflag(i).eq.0) ) iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+
+       A = 1669.0 ! convect3
+       B = 122.0  ! convect3
+
+       do 260 i=1,len
+
+        if (iflag(i).ne.7) then ! modif sb Jun7th 2002
+
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+!c
+        rh(i)=qnk(i)/qsnk(i)
+!c ori        rh(i)=min(1.0,rh(i)) ! removed for convect3
+!c ori        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        chi(i)=tnk(i)/(A-B*rh(i)-tnk(i)) ! convect3
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))                               &
+       &   .and.(iflag(i).eq.0))iflag(i)=8
+ 
+        endif ! iflag=7  
+
+ 260   continue
+
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+
+!c@      do 270 i=1,len
+!c@       icb(i)=nlm
+!c@ 270  continue
+!c@c
+!c@      do 290 k=minorig,nl
+!c@        do 280 i=1,len
+!c@          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+!c@     &    icb(i)=min(icb(i),k)
+!c@ 280    continue
+!c@ 290  continue
+!c@c
+!c@      do 300 i=1,len
+!c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+!c@ 300  continue
+
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+!c
+!c la modification consiste a comparer plcl a ph et non a p:
+!c icb est defini par :  ph(icb)<plcl<ph(icb-1)
+!c@      do 290 k=minorig,nl
+      do 290 k=3,nl-1 ! modif pour que icb soit sup/egal a 2
+        do 280 i=1,len
+          if( ph(i,k).lt.plcl(i) ) icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+!c
+      do 300 i=1,len
+!c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+        if((icb(i).eq.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+
+      do 400 i=1,len
+        icb(i) = icb(i)-1 ! icb sup ou egal a 2
+ 400  continue
+!c
+!c Compute icbmax.
+!c
+      icbmax=2
+      do 310 i=1,len
+!c!        icbmax=max(icbmax,icb(i))
+       if (iflag(i).lt.7) icbmax=max(icbmax,icb(i)) ! sb Jun7th02
+ 310  continue
+
+      return
+      end SUBROUTINE cv30_feed
+
+      SUBROUTINE cv30_undilute1(len,nd,t,q,qs,gz,plcl,p,nk,icb                       &
+       &                       ,tp,tvp,clw,icbs)
+      implicit none
+
+!----------------------------------------------------------------
+! Equivalent de TLIFT entre NK et ICB+1 inclus
+!
+! Differences with convect4:
+!		- specify plcl in input
+!       - icbs is the first level above LCL (may differ from icb)
+!       - in the iterations, used x(icbs) instead x(icb)
+!       - many minor differences in the iterations
+!		- tvp is computed in only one time
+!		- icbs: first level above Plcl (IMIN de TLIFT) in output
+!       - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
+!----------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv30param.h"
+
+!c inputs:
+      integer len, nd
+      integer nk(len), icb(len)
+      real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd)
+      real p(len,nd) 
+      real plcl(len) ! convect3
+
+!c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+!c local variables:
+      integer i, k
+      integer icb1(len), icbs(len), icbsmax2 ! convect3
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+      real qsicb(len) ! convect3
+      real cpinv(len) ! convect3
+
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+!c ori        ticb(i)=t(i,icb(i))
+!c ori        gzicb(i)=gz(i,icb(i))
+ 320  continue
+!c
+!c   ***  Calculate certain parcel quantities, including static energy   ***
+!c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)                                    &
+       &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+        cpinv(i)=1./cpp(i)
+ 330  continue
+!c
+!c   ***   Calculate lifted parcel quantities below cloud base   ***
+!c
+        do i=1,len                      !convect3
+         icb1(i)=MAX(icb(i),2)          !convect3
+         icb1(i)=MIN(icb(i),nl)         !convect3
+!c if icb is below LCL, start loop at ICB+1:
+!c (icbs est le premier niveau au-dessus du LCL)
+         icbs(i)=icb1(i)                !convect3
+         if (plcl(i).lt.p(i,icb1(i))) then
+             icbs(i)=MIN(icbs(i)+1,nl)  !convect3
+         endif
+        enddo                           !convect3
+
+        do i=1,len                      !convect3
+         ticb(i)=t(i,icbs(i))           !convect3
+         gzicb(i)=gz(i,icbs(i))         !convect3
+         qsicb(i)=qs(i,icbs(i))         !convect3
+        enddo                           !convect3
+
+!c
+!c Re-compute icbsmax (icbsmax2):        !convect3
+!c                                       !convect3
+      icbsmax2=2                        !convect3
+      do 310 i=1,len                    !convect3
+        icbsmax2=max(icbsmax2,icbs(i))  !convect3
+ 310  continue                          !convect3
+
+!c initialization outputs:
+
+      do k=1,icbsmax2     ! convect3
+       do i=1,len         ! convect3
+        tp(i,k)  = 0.0    ! convect3
+        tvp(i,k) = 0.0    ! convect3
+        clw(i,k) = 0.0    ! convect3
+       enddo              ! convect3
+      enddo               ! convect3
+
+!c tp and tvp below cloud base:
+
+        do 350 k=minorig,icbsmax2-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))*cpinv(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
+  340     continue
+  350   continue
+!c
+!c    ***  Find lifted parcel quantities above cloud base    ***
+!c
+        do 360 i=1,len
+         tg=ticb(i)
+!c ori         qg=qs(i,icb(i))
+         qg=qsicb(i) ! convect3
+!cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+!c
+!c First iteration.
+!c
+!c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)                                                & ! convect3
+       &      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+!c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+!c ori          tg=max(tg,35.0)
+!cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+!c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+!c ori          else
+!c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+!c ori          endif
+!c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+!c
+!c Second iteration.
+!c
+
+!c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+!c ori          s=1./s
+!c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+!c ori          tg=max(tg,35.0)
+!cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+!c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+!c ori          else
+!c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+!c ori          end if
+!c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+!c ori c approximation here:
+!c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+!c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+!c convect3: no approximation:
+         tp(i,icbs(i))=(ah0(i)-gz(i,icbs(i))-alv*qg)                                 &
+       &                /(cpd+(cl-cpd)*qnk(i))
+
+!c ori         clw(i,icb(i))=qnk(i)-qg
+!c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icbs(i))=qnk(i)-qg
+         clw(i,icbs(i))=max(0.0,clw(i,icbs(i)))
+
+         rg=qg/(1.-qnk(i))
+!c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+!c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icbs(i))=tp(i,icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
+
+  360   continue
+!c
+!c ori      do 380 k=minorig,icbsmax2
+!c ori       do 370 i=1,len
+!c ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+!c ori 370   continue
+!c ori 380  continue
+!c
+
+!c -- The following is only for convect3:
+!c
+!c * icbs is the first level above the LCL:
+!c    if plcl<p(icb), then icbs=icb+1
+!c    if plcl>p(icb), then icbs=icb
+!c
+!c * the routine above computes tvp from minorig to icbs (included).
+!c
+!c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
+!c    must be known. This is the case if icbs=icb+1, but not if icbs=icb.
+!c
+!c * therefore, in the case icbs=icb, we compute tvp at level icb+1
+!c   (tvp at other levels will be computed in cv3_undilute2.F)
+!c
+
+        do i=1,len              
+         ticb(i)=t(i,icb(i)+1)   
+         gzicb(i)=gz(i,icb(i)+1) 
+         qsicb(i)=qs(i,icb(i)+1) 
+        enddo                   
+
+        do 460 i=1,len
+         tg=ticb(i)
+         qg=qsicb(i) ! convect3
+!cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+!c
+!c First iteration.
+!c
+!c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)                                                & ! convect3
+       &      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+!c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+!c ori          tg=max(tg,35.0)
+!cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+!c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+!c ori          else
+!c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+!c ori          endif
+!c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+!c
+!c Second iteration.
+!c
+
+!c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+!c ori          s=1./s
+!c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+!c ori          tg=max(tg,35.0)
+!cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+!c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+!c ori          else
+!c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+!c ori          end if
+!c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+!c ori c approximation here:
+!c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+!c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+!c convect3: no approximation:
+         tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg)                               &
+       &                /(cpd+(cl-cpd)*qnk(i))
+
+!c ori         clw(i,icb(i))=qnk(i)-qg
+!c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icb(i)+1)=qnk(i)-qg
+         clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1))
+
+         rg=qg/(1.-qnk(i))
+!c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+!c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
+
+  460   continue
+
+      return
+      end SUBROUTINE cv30_undilute1
+
+      SUBROUTINE cv30_trigger(len,nd,icb,plcl,p,th,tv,tvp                            &
+       &                ,pbase,buoybase,iflag,sig,w0)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!
+!	- computes the cloud base
+!   - triggering (crude in this version)
+!	- relaxation of sig and w0 when no convection
+!
+!	Caution1: if no convection, we set iflag=4 
+!              (it used to be 0 in convect3)
+!
+!	Caution2: at this stage, tvp (and thus buoy) are know up 
+!             through icb only!
+! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
+!-------------------------------------------------------------------
+
+#include "cv30param.h"
+
+!c input:
+      integer len, nd
+      integer icb(len)
+      real plcl(len), p(len,nd)
+      real th(len,nd), tv(len,nd), tvp(len,nd)
+
+!c output:
+      real pbase(len), buoybase(len)
+
+!c input AND output:
+      integer iflag(len)
+      real sig(len,nd), w0(len,nd)
+
+!c local variables:
+      integer i,k
+      real tvpbase, tvbase, tdif, ath, ath1
+
+!c
+!c ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
+!c
+      do 100 i=1,len
+       pbase(i) = plcl(i) + dpbase
+       tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1))                              &
+       &                        /(p(i,icb(i))-p(i,icb(i)+1))                         &
+       &         + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i))                            &
+       &                          /(p(i,icb(i))-p(i,icb(i)+1))
+       tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1))                                &
+       &                      /(p(i,icb(i))-p(i,icb(i)+1))                           &
+       &        + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i))                              &
+       &                        /(p(i,icb(i))-p(i,icb(i)+1))
+       buoybase(i) = tvpbase - tvbase
+100   continue 
+
+!c
+!c   ***   make sure that column is dry adiabatic between the surface  ***
+!c   ***    and cloud base, and that lifted air is positively buoyant  ***
+!c   ***                         at cloud base                         ***
+!c   ***       if not, return to calling program after resetting       ***
+!c   ***                        sig(i) and w0(i)                       ***
+!c
+
+!c oct3      do 200 i=1,len
+!c oct3
+!c oct3       tdif = buoybase(i)
+!c oct3       ath1 = th(i,1)
+!c oct3       ath  = th(i,icb(i)-1) - dttrig
+!c oct3 
+!c oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+!c oct3         do 60 k=1,nl
+!c oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+!c oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
+!c oct3            w0(i,k)  = beta*w0(i,k)
+!c oct3   60    continue
+!c oct3         iflag(i)=4 ! pour version vectorisee
+!c oct3c convect3         iflag(i)=0
+!c oct3cccc         return
+!c oct3       endif
+!c oct3
+!c oct3200   continue
+ 
+!c -- oct3: on reecrit la boucle 200 (pour la vectorisation)
+
+      do  60 k=1,nl
+      do 200 i=1,len
+
+       tdif = buoybase(i)
+       ath1 = th(i,1)
+       ath  = th(i,icb(i)-1) - dttrig
+
+       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+            sig(i,k) = AMAX1(sig(i,k),0.0)
+            w0(i,k)  = beta*w0(i,k)
+        iflag(i)=4 ! pour version vectorisee
+!c convect3         iflag(i)=0
+       endif
+
+200   continue
+ 60   continue
+
+!c fin oct3 --
+
+      return
+      end SUBROUTINE cv30_trigger
+
+      SUBROUTINE cv30_compress( len,nloc,ncum,nd,ntra                                &
+       &    ,iflag1,nk1,icb1,icbs1                                                   &
+       &    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1                                  &
+       &    ,t1,q1,qs1,u1,v1,gz1,th1                                                 &
+       &    ,tra1                                                                    &
+       &    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1                                    &
+       &    ,sig1,w01                                                                &
+       &    ,iflag,nk,icb,icbs                                                       &
+       &    ,plcl,tnk,qnk,gznk,pbase,buoybase                                        &
+       &    ,t,q,qs,u,v,gz,th                                                        &
+       &    ,tra                                                                     &
+       &    ,h,lv,cpn,p,ph,tv,tp,tvp,clw                                             &
+       &    ,sig,w0  )
+      implicit none
+
+#include "cv30param.h"
+      include 'iniprint.h'
+
+!c inputs:
+      integer len,ncum,nd,ntra,nloc
+      integer iflag1(len),nk1(len),icb1(len),icbs1(len)
+      real plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real pbase1(len),buoybase1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+      real th1(len,nd)
+      real sig1(len,nd), w01(len,nd)
+      real tra1(len,nd,ntra)
+
+!c outputs:
+!c en fait, on a nloc=len pour l'instant (cf cv_driver)
+      integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc)
+      real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real pbase(nloc),buoybase(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real th(nloc,nd)
+      real sig(nloc,nd), w0(nloc,nd) 
+      real tra(nloc,nd,ntra)
+
+!c local variables:
+      integer i,k,nn,j
+
+      CHARACTER (LEN=20) :: modname='cv30_compress'
+      CHARACTER (LEN=80) :: abort_message
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        sig(nn,k)=sig1(i,k)
+        w0(nn,k)=w01(i,k)
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+        th(nn,k)=th1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+!c      do 121 j=1,ntra
+!c      do 111 k=1,nd
+!c       nn=0
+!c      do 101 i=1,len
+!c      if(iflag1(i).eq.0)then
+!c       nn=nn+1
+!c       tra(nn,k,j)=tra1(i,k,j)
+!c      endif
+!c 101  continue
+!c 111  continue
+!c 121  continue
+
+      if (nn.ne.ncum) then
+         write(lunout,*)'strange! nn not equal to ncum: ',nn,ncum
+         abort_message = ''
+         CALL abort_gcm (modname,abort_message,1)
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      pbase(nn)=pbase1(i)
+      buoybase(nn)=buoybase1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      icbs(nn)=icbs1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      return
+      end SUBROUTINE cv30_compress
+
+      SUBROUTINE cv30_undilute2(nloc,ncum,nd,icb,icbs,nk                             &
+       &                       ,tnk,qnk,gznk,t,q,qs,gz                               &
+       &                       ,p,h,tv,lv,pbase,buoybase,plcl                        &
+       &                       ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      implicit none
+
+!C---------------------------------------------------------------------
+!C Purpose:
+!C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!C     &
+!C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE 
+!C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+!C     &
+!C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+!C
+!C Main differences convect3/convect4:
+!C	- icbs (input) is the first level above LCL (may differ from icb)
+!C	- many minor differences in the iterations
+!C	- condensed water not removed from tvp in convect3
+!C   - vertical profile of buoyancy computed here (use of buoybase)
+!C   - the determination of inb is different
+!C   - no inb1, only inb in output
+!C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv30param.h"
+#include "conema3.h"
+
+!c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), icbs(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+      real pbase(nloc), buoybase(nloc), plcl(nloc)
+
+!c outputs:
+      integer inb(nloc)
+      real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd)
+      real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd)
+      real buoy(nloc,nd)
+
+!c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac, pden
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=spfac
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+!c
+!c ---       The procedure is to solve the equation.
+!c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!c
+!c   ***  Calculate certain parcel quantities, including static energy   ***
+!c
+!c
+      do 240 i=1,ncum
+         ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)                                   &
+!cdebug     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)                       &
+       &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+ 240  continue
+!c
+!c
+!c    ***  Find lifted parcel quantities above cloud base    ***
+!c
+!c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+!c ori	    if(k.ge.(icb(i)+1))then
+	    if(k.ge.(icbs(i)+1))then ! convect3
+	      tg=t(i,k)
+	      qg=qs(i,k)
+!cdebug	      alv=lv0-clmcpv*(t(i,k)-t0)
+	      alv=lv0-clmcpv*(t(i,k)-273.15)
+!c
+!c First iteration.
+!c
+!c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+           s=cpd*(1.-qnk(i))+cl*qnk(i)                                               & ! convect3
+       &      +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
+	       s=1./s
+!c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+!c ori	       tg=max(tg,35.0)
+!cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+!c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+!c ori	       else
+!c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+!c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+!c
+!c Second iteration.
+!c
+!c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+!c ori	       s=1./s
+!c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+!c ori	       tg=max(tg,35.0)
+!cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+!c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+!c ori	       else
+!c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+!c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+!c
+!cdebug	       alv=lv0-clmcpv*(t(i,k)-t0)
+	       alv=lv0-clmcpv*(t(i,k)-273.15)
+!c      print*,'cpd dans convect2 ',cpd
+!c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+!c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+
+!c ori c approximation here:
+!c ori        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+
+!c convect3: no approximation:
+           tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+!c ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+!c convect3: (qg utilise au lieu du vrai mixing ratio rg):
+               tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing
+            endif
+  290     continue
+  300   continue
+!c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+!c
+!c ori      do 320 k=minorig+1,nl
+      do 320 k=1,nl ! convect3
+        do 310 i=1,ncum
+           pden=ptcrit-pbcrit
+           ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax
+           ep(i,k)=amax1(ep(i,k),0.0)
+           ep(i,k)=amin1(ep(i,k),epmax)
+           sigp(i,k)=spfac
+!c ori          if(k.ge.(nk(i)+1))then
+!c ori            tca=tp(i,k)-t0
+!c ori            if(tca.ge.0.0)then
+!c ori              elacrit=elcrit
+!c ori            else
+!c ori              elacrit=elcrit*(1.0-tca/tlcrit)
+!c ori            endif
+!c ori            elacrit=max(elacrit,0.0)
+!c ori            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+!c ori            ep(i,k)=max(ep(i,k),0.0 )
+!c ori            ep(i,k)=min(ep(i,k),1.0 )
+!c ori            sigp(i,k)=sigs
+!c ori          endif
+ 310    continue
+ 320  continue
+!c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+!c
+!c dans convect3, tvp est calcule en une seule fois, et sans retirer
+!c l'eau condensee (~> reversible CAPE)
+!c
+!c ori      do 340 k=minorig+1,nl
+!c ori        do 330 i=1,ncum
+!c ori        if(k.ge.(icb(i)+1))then
+!c ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+!c oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+!c oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+!c ori        endif
+!c ori 330    continue
+!c ori 340  continue
+
+!c ori      do 350 i=1,ncum
+!c ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+!c ori 350  continue
+
+      do 350 i=1,ncum       ! convect3
+       tp(i,nlp)=tp(i,nl)   ! convect3
+ 350  continue              ! convect3
+!c
+!c=====================================================================
+!c  --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
+!c===================================================================== 
+
+!c-- this is for convect3 only:
+
+!c first estimate of buoyancy:
+
+      do 500 i=1,ncum
+       do 501 k=1,nl
+        buoy(i,k)=tvp(i,k)-tv(i,k) 
+ 501   continue
+ 500  continue
+
+!c set buoyancy=buoybase for all levels below base
+!c for safety, set buoy(icb)=buoybase
+
+      do 505 i=1,ncum
+       do 506 k=1,nl
+        if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then
+         buoy(i,k)=buoybase(i)
+        endif
+ 506   continue
+!IM cf. CRio/JYG 270807   buoy(icb(i),k)=buoybase(i)
+       buoy(i,icb(i))=buoybase(i)
+ 505  continue
+
+!c-- end convect3
+
+!c=====================================================================
+!c  --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
+!c  --- LEVEL OF NEUTRAL BUOYANCY
+!c=====================================================================
+!c
+!c-- this is for convect3 only:
+
+      do 510 i=1,ncum
+       inb(i)=nl-1
+ 510  continue
+
+      do 530 i=1,ncum
+       do 535 k=1,nl-1
+        if ((k.ge.icb(i)).and.(buoy(i,k).lt.dtovsh)) then
+         inb(i)=MIN(inb(i),k)
+        endif
+ 535   continue
+ 530  continue
+
+!c-- end convect3
+
+!c ori      do 510 i=1,ncum
+!c ori        cape(i)=0.0
+!c ori        capem(i)=0.0
+!c ori        inb(i)=icb(i)+1
+!c ori        inb1(i)=inb(i)
+!c ori 510  continue
+!c
+!c Originial Code
+!c
+!c     do 530 k=minorig+1,nl-1
+!c       do 520 i=1,ncum
+!c         if(k.ge.(icb(i)+1))then
+!c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+!c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+!c           cape(i)=cape(i)+by
+!c           if(by.ge.0.0)inb1(i)=k+1
+!c           if(cape(i).gt.0.0)then
+!c             inb(i)=k+1
+!c             capem(i)=cape(i)
+!c           endif
+!c         endif
+!c520    continue
+!c530  continue
+!c     do 540 i=1,ncum
+!c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+!c         cape(i)=capem(i)+byp
+!c         defrac=capem(i)-cape(i)
+!c         defrac=max(defrac,0.001)
+!c         frac(i)=-cape(i)/defrac
+!c         frac(i)=min(frac(i),1.0)
+!c         frac(i)=max(frac(i),0.0)
+!c540   continue
+!c
+!c K Emanuel fix
+!c
+!c     call zilch(byp,ncum)
+!c     do 530 k=minorig+1,nl-1
+!c       do 520 i=1,ncum
+!c         if(k.ge.(icb(i)+1))then
+!c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+!c           cape(i)=cape(i)+by
+!c           if(by.ge.0.0)inb1(i)=k+1
+!c           if(cape(i).gt.0.0)then
+!c             inb(i)=k+1
+!c             capem(i)=cape(i)
+!c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+!c           endif
+!c         endif
+!c520    continue
+!c530  continue
+!c     do 540 i=1,ncum
+!c         inb(i)=max(inb(i),inb1(i))
+!c         cape(i)=capem(i)+byp(i)
+!c         defrac=capem(i)-cape(i)
+!c         defrac=max(defrac,0.001)
+!c         frac(i)=-cape(i)/defrac
+!c         frac(i)=min(frac(i),1.0)
+!c         frac(i)=max(frac(i),0.0)
+!c540   continue
+!c
+!c J Teixeira fix
+!c
+!c ori      call zilch(byp,ncum)
+!c ori      do 515 i=1,ncum
+!c ori        lcape(i)=.true.
+!c ori 515  continue
+!c ori      do 530 k=minorig+1,nl-1
+!c ori        do 520 i=1,ncum
+!c ori          if(cape(i).lt.0.0)lcape(i)=.false.
+!c ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
+!c ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+!c ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+!c ori            cape(i)=cape(i)+by
+!c ori            if(by.ge.0.0)inb1(i)=k+1
+!c ori            if(cape(i).gt.0.0)then
+!c ori              inb(i)=k+1
+!c ori              capem(i)=cape(i)
+!c ori            endif
+!c ori          endif
+!c ori 520    continue
+!c ori 530  continue
+!c ori      do 540 i=1,ncum
+!c ori          cape(i)=capem(i)+byp(i)
+!c ori          defrac=capem(i)-cape(i)
+!c ori          defrac=max(defrac,0.001)
+!c ori          frac(i)=-cape(i)/defrac
+!c ori          frac(i)=min(frac(i),1.0)
+!c ori          frac(i)=max(frac(i),0.0)
+!c ori 540  continue
+!c
+!c=====================================================================
+!c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+!c=====================================================================
+!c
+!cym      do i=1,ncum*nlp
+!cym       hp(i,1)=h(i,1)
+!cym      enddo
+
+      do k=1,nlp
+        do i=1,ncum
+	  hp(i,k)=h(i,k)
+	enddo
+      enddo
+
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+
+        return
+        end SUBROUTINE cv30_undilute2
+
+      SUBROUTINE cv30_closure(nloc,ncum,nd,icb,inb                                   &
+       &                      ,pbase,p,ph,tv,buoy                                    &
+       &                      ,sig,w0,cape,m)
+      implicit none
+
+!===================================================================
+! ---  CLOSURE OF CONVECT3
+!
+! vectorization: S. Bony
+!===================================================================
+
+#include "cvthermo.h"
+#include "cv30param.h"
+
+!c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real tv(nloc,nd), buoy(nloc,nd)
+
+!c input/output:
+      real sig(nloc,nd), w0(nloc,nd)
+
+!c output:
+      real cape(nloc)
+      real m(nloc,nd)
+
+!c local variables:
+      integer i, j, k, icbmax
+      real deltap, fac, w, amu
+      real dtmin(nloc,nd), sigold(nloc,nd)
+
+
+!c -------------------------------------------------------
+!c -- Initialization
+!c -------------------------------------------------------
+
+      do k=1,nl
+       do i=1,ncum
+        m(i,k)=0.0
+       enddo
+      enddo
+
+!c -------------------------------------------------------
+!c -- Reset sig(i) and w0(i) for i>inb and i<icb   
+!c -------------------------------------------------------
+      
+!c update sig and w0 above LNB:
+
+      do 100 k=1,nl-1
+       do 110 i=1,ncum
+        if ((inb(i).lt.(nl-1)).and.(k.ge.(inb(i)+1)))then
+         sig(i,k)=beta*sig(i,k)                                                      &
+       &            +2.*alpha*buoy(i,inb(i))*ABS(buoy(i,inb(i)))
+         sig(i,k)=AMAX1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+ 110   continue
+ 100  continue
+
+!c compute icbmax:
+
+      icbmax=2
+      do 200 i=1,ncum
+        icbmax=MAX(icbmax,icb(i))
+ 200  continue
+
+!c update sig and w0 below cloud base:
+
+      do 300 k=1,icbmax
+       do 310 i=1,ncum
+        if (k.le.icb(i))then
+         sig(i,k)=beta*sig(i,k)-2.*alpha*buoy(i,icb(i))*buoy(i,icb(i))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+310    continue
+300    continue
+
+!c!      if(inb.lt.(nl-1))then
+!c!         do 85 i=inb+1,nl-1
+!c!            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
+!c!     1              abs(buoy(inb))
+!c!            sig(i)=amax1(sig(i),0.0)
+!c!            w0(i)=beta*w0(i)
+!c!   85    continue
+!c!      end if
+
+!c!      do 87 i=1,icb
+!c!         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
+!c!         sig(i)=amax1(sig(i),0.0)
+!c!         w0(i)=beta*w0(i)
+!c!   87 continue
+
+!c -------------------------------------------------------------
+!c -- Reset fractional areas of updrafts and w0 at initial time
+!c -- and after 10 time steps of no convection
+!c -------------------------------------------------------------
+      
+      do 400 k=1,nl-1
+       do 410 i=1,ncum
+        if (sig(i,nd).lt.1.5.or.sig(i,nd).gt.12.0)then
+         sig(i,k)=0.0
+         w0(i,k)=0.0
+        endif
+ 410   continue
+ 400  continue
+
+!c -------------------------------------------------------------
+!c -- Calculate convective available potential energy (cape),  
+!c -- vertical velocity (w), fractional area covered by    
+!c -- undilute updraft (sig), and updraft mass flux (m)  
+!c -------------------------------------------------------------
+
+      do 500 i=1,ncum
+       cape(i)=0.0
+ 500  continue
+
+!c compute dtmin (minimum buoyancy between ICB and given level k):
+
+      do i=1,ncum
+       do k=1,nl
+         dtmin(i,k)=100.0 
+       enddo
+      enddo
+
+      do 550 i=1,ncum
+       do 560 k=1,nl
+         do 570 j=minorig,nl
+          if ( (k.ge.(icb(i)+1)).and.(k.le.inb(i)).and.                              &
+       &         (j.ge.icb(i)).and.(j.le.(k-1)) )then
+           dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+          endif
+ 570     continue
+ 560   continue
+ 550  continue
+
+!c the interval on which cape is computed starts at pbase :
+
+      do 600 k=1,nl
+       do 610 i=1,ncum
+
+        if ((k.ge.(icb(i)+1)).and.(k.le.inb(i))) then
+
+         deltap = MIN(pbase(i),ph(i,k-1))-MIN(pbase(i),ph(i,k))
+         cape(i)=cape(i)+rrd*buoy(i,k-1)*deltap/p(i,k-1)
+         cape(i)=AMAX1(0.0,cape(i))
+         sigold(i,k)=sig(i,k)
+
+!c         dtmin(i,k)=100.0
+!c         do 97 j=icb(i),k-1 ! mauvaise vectorisation
+!c          dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+!c  97     continue
+
+         sig(i,k)=beta*sig(i,k)+alpha*dtmin(i,k)*ABS(dtmin(i,k))
+         sig(i,k)=amax1(sig(i,k),0.0)
+         sig(i,k)=amin1(sig(i,k),0.01)
+         fac=AMIN1(((dtcrit-dtmin(i,k))/dtcrit),1.0)
+         w=(1.-beta)*fac*SQRT(cape(i))+beta*w0(i,k)
+         amu=0.5*(sig(i,k)+sigold(i,k))*w
+         m(i,k)=amu*0.007*p(i,k)*(ph(i,k)-ph(i,k+1))/tv(i,k)
+         w0(i,k)=w
+        endif
+
+ 610   continue
+ 600  continue
+
+      do 700 i=1,ncum
+       w0(i,icb(i))=0.5*w0(i,icb(i)+1)
+       m(i,icb(i))=0.5*m(i,icb(i)+1)                                                 &
+       &             *(ph(i,icb(i))-ph(i,icb(i)+1))                                  &
+       &             /(ph(i,icb(i)+1)-ph(i,icb(i)+2))
+       sig(i,icb(i))=sig(i,icb(i)+1)
+       sig(i,icb(i)-1)=sig(i,icb(i))
+ 700  continue
+
+
+!c!      cape=0.0
+!c!      do 98 i=icb+1,inb
+!c!         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
+!c!         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
+!c!         dcape=rrd*buoy(i-1)*deltap/p(i-1)
+!c!         dlnp=deltap/p(i-1)
+!c!         cape=amax1(0.0,cape)
+!c!         sigold=sig(i)
+
+!c!         dtmin=100.0
+!c!         do 97 j=icb,i-1
+!c!            dtmin=amin1(dtmin,buoy(j))
+!c!   97    continue
+
+!c!         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
+!c!         sig(i)=amax1(sig(i),0.0)
+!c!         sig(i)=amin1(sig(i),0.01)
+!c!         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
+!c!         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
+!c!         amu=0.5*(sig(i)+sigold)*w
+!c!         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
+!c!         w0(i)=w
+!c!   98 continue
+!c!      w0(icb)=0.5*w0(icb+1)
+!c!      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
+!c!      sig(icb)=sig(icb+1)
+!c!      sig(icb-1)=sig(icb)
+
+       return
+       end SUBROUTINE cv30_closure
+
+      SUBROUTINE cv30_mixing(nloc,ncum,nd,na,ntra,icb,nk,inb                         &
+       &                    ,ph,t,rr,rs,u,v,tra,h,lv,qnk                             &
+       &                    ,hp,tv,tvp,ep,clw,m,sig                                  &
+       &   ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+      implicit none
+
+!---------------------------------------------------------------------
+! a faire:
+! 	- changer rr(il,1) -> qnk(il)
+!   - vectorisation de la partie normalisation des flux (do 789...)
+!---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv30param.h"
+
+!c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc), nk(nloc)
+      real sig(nloc,nd)
+      real qnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra) ! input of convect3
+      real lv(nloc,na), h(nloc,na), hp(nloc,na)
+      real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na)        ! input of convect3
+
+!c outputs:
+      real ment(nloc,na,na), qent(nloc,na,na)
+      real uent(nloc,na,na), vent(nloc,na,na)
+      real sij(nloc,na,na), elij(nloc,na,na)
+      real traent(nloc,nd,nd,ntra) 
+      real ments(nloc,nd,nd), qents(nloc,nd,nd)
+      real sigij(nloc,nd,nd)
+
+!c local variables:
+      integer i, j, k, il, im, jm
+      integer num1, num2
+      integer nent(nloc,na)
+      real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+      real alt, smid, sjmin, sjmax, delp, delm
+      real asij(nloc), smax(nloc), scrit(nloc)
+      real asum(nloc,nd),bsum(nloc,nd),csum(nloc,nd)
+      real wgh
+      real zm(nloc,na)
+      logical lwork(nloc)
+
+!c=====================================================================
+!c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+!c=====================================================================
+
+!c ori        do 360 i=1,ncum*nlp
+        do 361 j=1,nl
+        do 360 i=1,ncum
+          nent(i,j)=0
+!c in convect3, m is computed in cv3_closure
+!c ori          m(i,1)=0.0
+ 360    continue
+ 361    continue
+
+!c ori      do 400 k=1,nlp
+!c ori       do 390 j=1,nlp
+      do 400 j=1,nl
+       do 390 k=1,nl
+          do 385 i=1,ncum
+            qent(i,k,j)=rr(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+!cym            ment(i,k,j)=0.0
+!cym            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+
+!cym
+      ment(1:ncum,1:nd,1:nd)=0.0
+      sij(1:ncum,1:nd,1:nd)=0.0
+      
+!c      do k=1,ntra
+!c       do j=1,nd  ! instead nlp
+!c        do i=1,nd ! instead nlp
+!c         do il=1,ncum
+!c            traent(il,i,j,k)=tra(il,j,k)
+!c         enddo
+!c        enddo
+!c       enddo
+!c      enddo
+      zm(:,:)=0.
+
+!c=====================================================================
+!c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+!c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+!c --- FRACTION (sij)
+!c=====================================================================
+
+      do 750 i=minorig+1, nl
+
+       do 710 j=minorig,nl
+        do 700 il=1,ncum
+         if( (i.ge.icb(il)).and.(i.le.inb(il)).and.                                  &
+       &      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+
+          rti=rr(il,1)-ep(il,i)*clw(il,i)
+          bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd)
+          anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j))
+          denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j)
+          dei=denom
+          if(abs(dei).lt.0.01)dei=0.01
+          sij(il,i,j)=anum/dei
+          sij(il,i,i)=1.0
+          altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+          altem=altem/bf2
+          cwat=clw(il,j)*(1.-ep(il,j))
+          stemp=sij(il,i,j)
+          if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat)                         &
+       &                 .and.j.gt.i)then
+           anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2)
+           denom=denom+lv(il,j)*(rr(il,i)-rti)
+           if(abs(denom).lt.0.01)denom=0.01
+           sij(il,i,j)=anum/denom
+           altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+           altem=altem-(bf2-1.)*cwat
+          end if
+         if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then
+          qent(il,i,j)=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti
+          uent(il,i,j)=sij(il,i,j)*u(il,i)+(1.-sij(il,i,j))*u(il,nk(il))
+          vent(il,i,j)=sij(il,i,j)*v(il,i)+(1.-sij(il,i,j))*v(il,nk(il))
+!c!!!      do k=1,ntra
+!c!!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+!c!!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
+!c!!!      end do
+          elij(il,i,j)=altem
+          elij(il,i,j)=amax1(0.0,elij(il,i,j))
+          ment(il,i,j)=m(il,i)/(1.-sij(il,i,j))
+          nent(il,i)=nent(il,i)+1
+         end if
+         sij(il,i,j)=amax1(0.0,sij(il,i,j))
+         sij(il,i,j)=amin1(1.0,sij(il,i,j))
+         endif ! new
+ 700   continue
+ 710  continue
+
+!c       do k=1,ntra
+!c        do j=minorig,nl
+!c         do il=1,ncum
+!c          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+!c     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+!c            traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+!c     :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
+!c          endif
+!c         enddo
+!c        enddo
+!c       enddo
+
+!c
+!c   ***   if no air can entrain at level i assume that updraft detrains  ***
+!c   ***   at that level and calculate detrained air flux and properties  ***
+!c
+
+!c@      do 170 i=icb(il),inb(il)
+
+      do 740 il=1,ncum
+      if ((i.ge.icb(il)).and.(i.le.inb(il)).and.(nent(il,i).eq.0)) then 
+!c@      if(nent(il,i).eq.0)then
+      ment(il,i,i)=m(il,i)
+      qent(il,i,i)=rr(il,nk(il))-ep(il,i)*clw(il,i)
+      uent(il,i,i)=u(il,nk(il))
+      vent(il,i,i)=v(il,nk(il))
+      elij(il,i,i)=clw(il,i)
+!cMAF      sij(il,i,i)=1.0
+      sij(il,i,i)=0.0
+      end if
+ 740  continue
+ 750  continue
+ 
+!c      do j=1,ntra
+!c       do i=minorig+1,nl
+!c        do il=1,ncum
+!c         if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
+!c          traent(il,i,i,j)=tra(il,nk(il),j)
+!c         endif
+!c        enddo
+!c       enddo
+!c      enddo
+
+      do 100 j=minorig,nl
+      do 101 i=minorig,nl
+      do 102 il=1,ncum
+      if ((j.ge.(icb(il)-1)).and.(j.le.inb(il))                                      &
+       &    .and.(i.ge.icb(il)).and.(i.le.inb(il)))then
+       sigij(il,i,j)=sij(il,i,j)
+      endif
+ 102  continue
+ 101  continue
+ 100  continue
+!c@      enddo
+
+!c@170   continue
+
+!c=====================================================================
+!c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+!c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+!c=====================================================================
+
+!cym      call zilch(asum,ncum*nd)
+!cym      call zilch(bsum,ncum*nd)
+!cym      call zilch(csum,ncum*nd)
+      call zilch(asum,nloc*nd)
+      call zilch(csum,nloc*nd)
+      call zilch(csum,nloc*nd)
+
+      do il=1,ncum
+       lwork(il) = .FALSE.
+      enddo
+
+      DO 789 i=minorig+1,nl 
+
+      num1=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1
+      enddo
+      if (num1.le.0) goto 789
+
+
+      do 781 il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) then
+        lwork(il)=(nent(il,i).ne.0)
+        qp=rr(il,1)-ep(il,i)*clw(il,i)
+        anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i))                                 &
+       &           +(cpv-cpd)*t(il,i)*(qp-rr(il,i))
+        denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp)                                &
+       &           +(cpd-cpv)*t(il,i)*(rr(il,i)-qp)
+        if(abs(denom).lt.0.01)denom=0.01
+        scrit(il)=anum/denom
+        alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp)
+        if(scrit(il).le.0.0.or.alt.le.0.0)scrit(il)=1.0
+        smax(il)=0.0
+        asij(il)=0.0
+       endif
+781   continue
+
+      do 175 j=nl,minorig,-1
+
+      num2=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and.                                    &
+       &      j.ge.(icb(il)-1) .and. j.le.inb(il)                                    &
+       &      .and. lwork(il) ) num2=num2+1
+      enddo
+      if (num2.le.0) goto 175
+
+      do 782 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.                                     &
+       &      j.ge.(icb(il)-1) .and. j.le.inb(il)                                    &
+       &      .and. lwork(il) ) then
+
+       if(sij(il,i,j).gt.1.0e-16.and.sij(il,i,j).lt.0.95)then
+        wgh=1.0
+        if(j.gt.i)then
+         sjmax=amax1(sij(il,i,j+1),smax(il))
+         sjmax=amin1(sjmax,scrit(il))
+         smax(il)=amax1(sij(il,i,j),smax(il))
+         sjmin=amax1(sij(il,i,j-1),smax(il))
+         sjmin=amin1(sjmin,scrit(il))
+         if(sij(il,i,j).lt.(smax(il)-1.0e-16))wgh=0.0
+         smid=amin1(sij(il,i,j),scrit(il))
+        else
+         sjmax=amax1(sij(il,i,j+1),scrit(il))
+         smid=amax1(sij(il,i,j),scrit(il))
+         sjmin=0.0
+         if(j.gt.1)sjmin=sij(il,i,j-1)
+         sjmin=amax1(sjmin,scrit(il))
+        endif
+        delp=abs(sjmax-smid)
+        delm=abs(sjmin-smid)
+        asij(il)=asij(il)+wgh*(delp+delm)
+        ment(il,i,j)=ment(il,i,j)*(delp+delm)*wgh
+       endif
+      endif
+782   continue
+
+175   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        asij(il)=amax1(1.0e-16,asij(il))
+        asij(il)=1.0/asij(il)
+        asum(il,i)=0.0
+        bsum(il,i)=0.0
+        csum(il,i)=0.0
+       endif
+      enddo
+
+      do 180 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                         &
+       &   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asij(il)
+        endif
+       enddo
+180   continue
+
+      do 190 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                         &
+       &   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         asum(il,i)=asum(il,i)+ment(il,i,j)
+         ment(il,i,j)=ment(il,i,j)*sig(il,j)
+         bsum(il,i)=bsum(il,i)+ment(il,i,j)
+        endif
+       enddo
+190   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        bsum(il,i)=amax1(bsum(il,i),1.0e-16)
+        bsum(il,i)=1.0/bsum(il,i)
+       endif
+      enddo
+
+      do 195 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                         &
+       &   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asum(il,i)*bsum(il,i)
+        endif
+       enddo
+195   continue
+
+      do 197 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                         &
+       &   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         csum(il,i)=csum(il,i)+ment(il,i,j)
+        endif
+       enddo
+197   continue
+
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                          &
+       &     .and. csum(il,i).lt.m(il,i) ) then
+        nent(il,i)=0
+        ment(il,i,i)=m(il,i)
+        qent(il,i,i)=rr(il,1)-ep(il,i)*clw(il,i)
+        uent(il,i,i)=u(il,nk(il))
+        vent(il,i,i)=v(il,nk(il))
+        elij(il,i,i)=clw(il,i)
+!cMAF        sij(il,i,i)=1.0
+        sij(il,i,i)=0.0
+       endif
+      enddo ! il
+
+!c      do j=1,ntra
+!c       do il=1,ncum
+!c        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+!c     :     .and. csum(il,i).lt.m(il,i) ) then
+!c         traent(il,i,i,j)=tra(il,nk(il),j)
+!c        endif
+!c       enddo
+!c      enddo
+789   continue
+!c      
+!c MAF: renormalisation de MENT
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          zm(il,im)=zm(il,im)+(1.-sij(il,im,jm))*ment(il,im,jm)
+         end do
+        end do
+      end do
+!c
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          if(zm(il,im).ne.0.) then
+          ment(il,im,jm)=ment(il,im,jm)*m(il,im)/zm(il,im)
+          endif
+         end do
+       end do
+      end do
+!c
+      do jm=1,nd
+       do im=1,nd
+        do 999 il=1,ncum
+         qents(il,im,jm)=qent(il,im,jm)
+         ments(il,im,jm)=ment(il,im,jm)
+999     continue
+       enddo
+      enddo
+
+      return
+      end SUBROUTINE cv30_mixing
+
+
+      SUBROUTINE cv30_unsat(nloc,ncum,nd,na,ntra,icb,inb                             &
+       &              ,t,rr,rs,gz,u,v,tra,p,ph                                       &
+       &              ,th,tv,lv,cpn,ep,sigp,clw                                      &
+       &              ,m,ment,elij,delt,plcl                                         &
+       &              ,mp,rp,up,vp,trap,wt,water,evap,b                              & ! RomP-jyg
+       &              ,wdtrainA,wdtrainM)               ! 26/08/10  RomP-jyg
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cv30param.h"
+#include "cvflag.h"
+
+!c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc)
+      real delt, plcl(nloc)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real th(nloc,na), gz(nloc,na)
+      real lv(nloc,na), ep(nloc,na), sigp(nloc,na), clw(nloc,na)
+      real cpn(nloc,na), tv(nloc,na)
+      real m(nloc,na), ment(nloc,na,na), elij(nloc,na,na)
+
+!c outputs:
+      real mp(nloc,na), rp(nloc,na), up(nloc,na), vp(nloc,na)
+      real water(nloc,na), evap(nloc,na), wt(nloc,na)
+      real trap(nloc,na,ntra)
+      real b(nloc,na)
+! 25/08/10 - RomP---- ajout des masses precipitantes ejectees
+! lascendance adiabatique et des flux melanges Pa et Pm.
+! Distinction des wdtrain
+! Pa = wdtrainA     Pm = wdtrainM
+      real  wdtrainA(nloc,na), wdtrainM(nloc,na)
+
+!c local variables
+      integer i,j,k,il,num1
+      real tinv, delti
+      real awat, afac, afac1, afac2, bfac
+      real pr1, pr2, sigt, b6, c6, revap, tevap, delth
+      real amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
+      real ampmax
+      real lvcp(nloc,na)
+      real wdtrain(nloc)
+      logical lwork(nloc)
+
+
+!c------------------------------------------------------
+
+        delti = 1./delt
+        tinv=1./3.
+
+        mp(:,:)=0.
+
+        do i=1,nl
+         do il=1,ncum
+          mp(il,i)=0.0
+          rp(il,i)=rr(il,i)
+          up(il,i)=u(il,i)
+          vp(il,i)=v(il,i)
+          wt(il,i)=0.001
+          water(il,i)=0.0
+          evap(il,i)=0.0
+          b(il,i)=0.0
+          lvcp(il,i)=lv(il,i)/cpn(il,i)
+         enddo
+        enddo
+
+!c        do k=1,ntra
+!c         do i=1,nd
+!c          do il=1,ncum
+!c           trap(il,i,k)=tra(il,i,k)
+!c          enddo
+!c         enddo
+!c        enddo
+!! RomP >>>
+         do i=1,nd
+          do il=1,ncum
+          wdtrainA(il,i)=0.0     
+          wdtrainM(il,i)=0.0     
+         enddo
+        enddo
+!! RomP <<<
+!c
+!c   ***  check whether ep(inb)=0, if so, skip precipitating    ***
+!c   ***             downdraft calculation                      ***
+!c
+
+        do il=1,ncum
+          lwork(il)=.TRUE.
+          if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE.
+        enddo
+
+        call zilch(wdtrain,ncum)
+ 
+        DO 400 i=nl+1,1,-1
+
+        num1=0
+        do il=1,ncum
+         if ( i.le.inb(il) .and. lwork(il) ) num1=num1+1
+        enddo
+        if (num1.le.0) goto 400
+
+!c
+!c   ***  integrate liquid water equation to find condensed water   ***
+!c   ***                and condensed water flux                    ***
+!c
+
+!c
+!c    ***                    begin downdraft loop                    ***
+!c
+
+!c
+!c    ***              calculate detrained precipitation             ***
+!c
+       do il=1,ncum
+        if (i.le.inb(il) .and. lwork(il)) then
+         if (cvflag_grav) then
+          wdtrain(il)=grav*ep(il,i)*m(il,i)*clw(il,i)
+          wdtrainA(il,i) = wdtrain(il)/grav     !   Pa  26/08/10   RomP
+         else
+          wdtrain(il)=10.0*ep(il,i)*m(il,i)*clw(il,i)
+          wdtrainA(il,i) = wdtrain(il)/10.      !   Pa  26/08/10   RomP
+         endif
+        endif
+       enddo
+
+       if(i.gt.1)then
+
+        do 320 j=1,i-1
+         do il=1,ncum
+          if (i.le.inb(il) .and. lwork(il)) then
+           awat=elij(il,j,i)-(1.-ep(il,i))*clw(il,i)
+           awat=amax1(awat,0.0)
+           if (cvflag_grav) then
+            wdtrain(il)=wdtrain(il)+grav*awat*ment(il,j,i)
+           else
+            wdtrain(il)=wdtrain(il)+10.0*awat*ment(il,j,i)
+           endif
+          endif
+         enddo
+320     continue
+         do il=1,ncum
+           if (cvflag_grav) then
+           wdtrainM(il,i) = wdtrain(il)/grav-wdtrainA(il,i)    !   Pm  26/08/10   RomP
+           else
+           wdtrainM(il,i) = wdtrain(il)/10.-wdtrainA(il,i)    !   Pm  26/08/10   RomP
+           endif
+         enddo
+
+       endif
+
+!c
+!c    ***    find rain water and evaporation using provisional   ***
+!c    ***              estimates of rp(i)and rp(i-1)             ***
+!c
+
+      do 999 il=1,ncum
+
+       if (i.le.inb(il) .and. lwork(il)) then
+
+      wt(il,i)=45.0
+
+      if(i.lt.inb(il))then
+       rp(il,i)=rp(il,i+1)                                                           &
+       &       +(cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il,i)
+       rp(il,i)=0.5*(rp(il,i)+rr(il,i))
+      endif
+      rp(il,i)=amax1(rp(il,i),0.0)
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,inb(il))=rr(il,inb(il))
+
+      if(i.eq.1)then
+       afac=p(il,1)*(rs(il,1)-rp(il,1))/(1.0e4+2000.0*p(il,1)*rs(il,1))
+      else
+       rp(il,i-1)=rp(il,i)                                                           &
+       &          +(cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il,i)
+       rp(il,i-1)=0.5*(rp(il,i-1)+rr(il,i-1))
+       rp(il,i-1)=amin1(rp(il,i-1),rs(il,i-1))
+       rp(il,i-1)=amax1(rp(il,i-1),0.0)
+       afac1=p(il,i)*(rs(il,i)-rp(il,i))/(1.0e4+2000.0*p(il,i)*rs(il,i))
+       afac2=p(il,i-1)*(rs(il,i-1)-rp(il,i-1))                                       &
+       &                /(1.0e4+2000.0*p(il,i-1)*rs(il,i-1))
+       afac=0.5*(afac1+afac2)
+      endif
+      if(i.eq.inb(il))afac=0.0
+      afac=amax1(afac,0.0)
+      bfac=1./(sigd*wt(il,i))
+!c
+!cjyg1
+!ccc        sigt=1.0
+!ccc        if(i.ge.icb)sigt=sigp(i)
+!c prise en compte de la variation progressive de sigt dans
+!c les couches icb et icb-1:
+!c 	pour plcl<ph(i+1), pr1=0 & pr2=1
+!c 	pour plcl>ph(i),   pr1=1 & pr2=0
+!c 	pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
+!c    sur le nuage, et pr2 est la proportion sous la base du
+!c    nuage.
+      pr1=(plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
+      pr1=max(0.,min(1.,pr1))
+      pr2=(ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
+      pr2=max(0.,min(1.,pr2))
+      sigt=sigp(il,i)*pr1+pr2
+!cjyg2
+!c
+      b6=bfac*50.*sigd*(ph(il,i)-ph(il,i+1))*sigt*afac
+      c6=water(il,i+1)+bfac*wdtrain(il)                                              &
+       &                -50.*sigd*bfac*(ph(il,i)-ph(il,i+1))*evap(il,i+1)
+      if(c6.gt.0.0)then
+       revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+       evap(il,i)=sigt*afac*revap
+       water(il,i)=revap*revap
+      else
+       evap(il,i)=-evap(il,i+1)                                                      &
+       &            +0.02*(wdtrain(il)+sigd*wt(il,i)*water(il,i+1))                  &
+       &                 /(sigd*(ph(il,i)-ph(il,i+1)))
+      end if
+!c
+!c    ***  calculate precipitating downdraft mass flux under     ***
+!c    ***              hydrostatic approximation                 ***
+!c
+      if (i.ne.1) then
+
+      tevap=amax1(0.0,evap(il,i))
+      delth=amax1(0.001,(th(il,i)-th(il,i-1)))
+      if (cvflag_grav) then
+       mp(il,i)=100.*ginv*lvcp(il,i)*sigd*tevap                                      &
+       &              *(p(il,i-1)-p(il,i))/delth
+      else
+       mp(il,i)=10.*lvcp(il,i)*sigd*tevap*(p(il,i-1)-p(il,i))/delth
+      endif
+!c
+!c    ***           if hydrostatic assumption fails,             ***
+!c    ***   solve cubic difference equation for downdraft theta  ***
+!c    ***  and mass flux from two simultaneous differential eqns ***
+!c
+      amfac=sigd*sigd*70.0*ph(il,i)*(p(il,i-1)-p(il,i))                              &
+       &          *(th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
+      amp2=abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
+      if(amp2.gt.(0.1*amfac))then
+       xf=100.0*sigd*sigd*sigd*(ph(il,i)-ph(il,i+1))
+       tf=b(il,i)-5.0*(th(il,i)-th(il,i-1))*t(il,i)                                  &
+       &               /(lvcp(il,i)*sigd*th(il,i))
+       af=xf*tf+mp(il,i+1)*mp(il,i+1)*tinv
+       bf=2.*(tinv*mp(il,i+1))**3+tinv*mp(il,i+1)*xf*tf                              &
+       &            +50.*(p(il,i-1)-p(il,i))*xf*tevap
+       fac2=1.0
+       if(bf.lt.0.0)fac2=-1.0
+       bf=abs(bf)
+       ur=0.25*bf*bf-af*af*af*tinv*tinv*tinv
+       if(ur.ge.0.0)then
+        sru=sqrt(ur)
+        fac=1.0
+        if((0.5*bf-sru).lt.0.0)fac=-1.0
+        mp(il,i)=mp(il,i+1)*tinv+(0.5*bf+sru)**tinv                                  &
+       &                  +fac*(abs(0.5*bf-sru))**tinv
+       else
+        d=atan(2.*sqrt(-ur)/(bf+1.0e-28))
+        if(fac2.lt.0.0)d=3.14159-d
+        mp(il,i)=mp(il,i+1)*tinv+2.*sqrt(af*tinv)*cos(d*tinv)
+       endif
+       mp(il,i)=amax1(0.0,mp(il,i))
+
+       if (cvflag_grav) then
+!Cjyg : il y a vraisemblablement une erreur dans la ligne 2 suivante: 
+!C il faut diviser par (mp(il,i)*sigd*grav) et non par (mp(il,i)+sigd*0.1). 
+!C Et il faut bien revoir les facteurs 100.
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap                            &
+       &   /(mp(il,i)+sigd*0.1)                                                      &
+       &   -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)*sigd*th(il,i))
+       else
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap                            &
+       &   /(mp(il,i)+sigd*0.1)                                                      &
+       &   -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)*sigd*th(il,i))
+       endif
+       b(il,i-1)=amax1(b(il,i-1),0.0)
+      endif
+!c
+!c   ***         limit magnitude of mp(i) to meet cfl condition      ***
+!c
+      ampmax=2.0*(ph(il,i)-ph(il,i+1))*delti
+      amp2=2.0*(ph(il,i-1)-ph(il,i))*delti
+      ampmax=amin1(ampmax,amp2)
+      mp(il,i)=amin1(mp(il,i),ampmax)
+!c
+!c    ***      force mp to decrease linearly to zero                 ***
+!c    ***       between cloud base and the surface                   ***
+!c
+      if(p(il,i).gt.p(il,icb(il)))then
+       mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il)))
+      endif
+
+360   continue
+      endif ! i.eq.1
+!c
+!c    ***       find mixing ratio of precipitating downdraft     ***
+!c
+
+      if (i.ne.inb(il)) then
+
+      rp(il,i)=rr(il,i)
+
+      if(mp(il,i).gt.mp(il,i+1))then
+
+       if (cvflag_grav) then
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))                &
+       &   +100.*ginv*0.5*sigd*(ph(il,i)-ph(il,i+1))                                 &
+       &                     *(evap(il,i+1)+evap(il,i))
+       else
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))                &
+       &   +5.*sigd*(ph(il,i)-ph(il,i+1))                                            &
+       &                      *(evap(il,i+1)+evap(il,i))
+       endif
+      rp(il,i)=rp(il,i)/mp(il,i)
+      up(il,i)=up(il,i+1)*mp(il,i+1)+u(il,i)*(mp(il,i)-mp(il,i+1))
+      up(il,i)=up(il,i)/mp(il,i)
+      vp(il,i)=vp(il,i+1)*mp(il,i+1)+v(il,i)*(mp(il,i)-mp(il,i+1))
+      vp(il,i)=vp(il,i)/mp(il,i)
+
+!c      do j=1,ntra
+!c      trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
+!ctestmaf     :            +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
+!c     :            +tra(il,i,j)*(mp(il,i)-mp(il,i+1))
+!c      trap(il,i,j)=trap(il,i,j)/mp(il,i)
+!c      end do
+
+      else
+
+       if(mp(il,i+1).gt.1.0e-16)then
+        if (cvflag_grav) then
+         rp(il,i)=rp(il,i+1)                                                         &
+       &            +100.*ginv*0.5*sigd*(ph(il,i)-ph(il,i+1))                        &
+       &            *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        else
+         rp(il,i)=rp(il,i+1)                                                         &
+       &           +5.*sigd*(ph(il,i)-ph(il,i+1))                                    &
+       &           *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        endif
+       up(il,i)=up(il,i+1)
+       vp(il,i)=vp(il,i+1)
+
+!c       do j=1,ntra
+!c       trap(il,i,j)=trap(il,i+1,j)
+!c       end do
+
+       endif
+      endif
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,i)=amax1(rp(il,i),0.0)
+
+      endif
+      endif
+999   continue
+
+400   continue
+
+       return
+       end SUBROUTINE cv30_unsat
+
+      SUBROUTINE cv30_yield(nloc,ncum,nd,na,ntra                                     &
+       &                    ,icb,inb,delt                                            &
+       &                    ,t,rr,u,v,tra,gz,p,ph,h,hp,lv,cpn,th                     &
+       &                    ,ep,clw,m,tp,mp,rp,up,vp,trap                            &
+       &                    ,wt,water,evap,b                                         &
+       &                    ,ment,qent,uent,vent,nent,elij,traent,sig                &
+       &                    ,tv,tvp                                                  &
+       &                    ,iflag,precip,VPrecip,ft,fr,fu,fv,ftra                   &
+       &                    ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd)
+      implicit none
+
+#include "cvthermo.h"
+#include "cv30param.h"
+#include "cvflag.h"
+#include "conema3.h"
+
+!c inputs:
+      integer ncum,nd,na,ntra,nloc
+      integer icb(nloc), inb(nloc)
+      real delt
+      real t(nloc,nd), rr(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra), sig(nloc,nd)
+      real gz(nloc,na), ph(nloc,nd+1), h(nloc,na), hp(nloc,na)
+      real th(nloc,na), p(nloc,nd), tp(nloc,na)
+      real lv(nloc,na), cpn(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na), mp(nloc,na), rp(nloc,na), up(nloc,na)
+      real vp(nloc,na), wt(nloc,nd), trap(nloc,nd,ntra)
+      real water(nloc,na), evap(nloc,na), b(nloc,na)
+      real ment(nloc,na,na), qent(nloc,na,na), uent(nloc,na,na)
+!cym      real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
+      real vent(nloc,na,na), elij(nloc,na,na)
+      integer nent(nloc,na)
+      real traent(nloc,na,na,ntra)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+!c input/output:
+      integer iflag(nloc)
+
+!c outputs:
+      real precip(nloc)
+      real VPrecip(nloc,nd+1)
+      real ft(nloc,nd), fr(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real upwd(nloc,nd), dnwd(nloc,nd), ma(nloc,nd)
+      real dnwd0(nloc,nd), mike(nloc,nd)
+      real tls(nloc,nd), tps(nloc,nd)
+      real qcondc(nloc,nd)                               ! cld
+      real wd(nloc)                                      ! gust
+
+!c local variables:
+      integer i,k,il,n,j,num1
+      real rat, awat, delti
+      real ax, bx, cx, dx, ex
+      real cpinv, rdcp, dpinv
+      real lvcp(nloc,na), mke(nloc,na)
+      real am(nloc), work(nloc), ad(nloc), amp1(nloc)
+!c!!      real up1(nloc), dn1(nloc)
+      real up1(nloc,nd,nd), dn1(nloc,nd,nd)
+      real asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd)  ! cld
+      real siga(nloc,nd), sax(nloc,nd), mac(nloc,nd)      ! cld
+
+
+!c-------------------------------------------------------------
+
+!c initialization:
+
+      delti = 1.0/delt
+
+      do il=1,ncum
+       precip(il)=0.0
+       wd(il)=0.0     ! gust
+       VPrecip(il,nd+1)=0.
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+         VPrecip(il,i)=0.0
+         ft(il,i)=0.0
+         fr(il,i)=0.0
+         fu(il,i)=0.0
+         fv(il,i)=0.0
+         qcondc(il,i)=0.0                                ! cld
+         qcond(il,i)=0.0                                 ! cld
+         nqcond(il,i)=0.0                                ! cld
+       enddo 
+      enddo
+
+!c      do j=1,ntra
+!c       do i=1,nd
+!c        do il=1,ncum
+!c          ftra(il,i,j)=0.0
+!c        enddo
+!c       enddo 
+!c      enddo
+
+      do i=1,nl
+       do il=1,ncum
+         lvcp(il,i)=lv(il,i)/cpn(il,i)
+       enddo
+      enddo
+
+
+!c
+!c   ***  calculate surface precipitation in mm/day     ***
+!c
+      do il=1,ncum 
+       if(ep(il,inb(il)).ge.0.0001)then 
+        if (cvflag_grav) then
+         precip(il)=wt(il,1)*sigd*water(il,1)*86400.*1000./(rowl*grav)
+        else
+         precip(il)=wt(il,1)*sigd*water(il,1)*8640.
+        endif
+       endif 
+      enddo 
+
+!C   ***  CALCULATE VERTICAL PROFILE OF  PRECIPITATIONs IN kg/m2/s  ===
+!C
+!c MAF rajout pour lessivage
+       do k=1,nl
+         do il=1,ncum
+          if (k.le.inb(il)) then
+            if (cvflag_grav) then
+             VPrecip(il,k) = wt(il,k)*sigd*water(il,k)/grav
+            else
+             VPrecip(il,k) = wt(il,k)*sigd*water(il,k)/10.
+            endif 
+          endif
+         end do
+       end do
+!C
+!c
+!c   ***  Calculate downdraft velocity scale    ***
+!c   ***  NE PAS UTILISER POUR L'INSTANT ***
+!c
+!c!      do il=1,ncum
+!c!        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
+!c!     :                                  /(sigd*p(il,icb(il)))
+!c!      enddo
+
+!c
+!c   ***  calculate tendencies of lowest level potential temperature  ***
+!c   ***                      and mixing ratio                        ***
+!c
+      do il=1,ncum
+       work(il)=1.0/(ph(il,1)-ph(il,2))
+       am(il)=0.0
+      enddo
+
+      do k=2,nl
+       do il=1,ncum
+        if (k.le.inb(il)) then
+         am(il)=am(il)+m(il,k)
+        endif
+       enddo
+      enddo
+
+      do il=1,ncum
+
+!c convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+      if((0.01*grav*work(il)*am(il)).ge.delti)iflag(il)=1!consist vect
+       ft(il,1)=0.01*grav*work(il)*am(il)*(t(il,2)-t(il,1)                           &
+       &            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      else
+       if((0.1*work(il)*am(il)).ge.delti)iflag(il)=1 !consistency vect
+       ft(il,1)=0.1*work(il)*am(il)*(t(il,2)-t(il,1)                                 &
+       &            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      endif
+
+      ft(il,1)=ft(il,1)-0.5*lvcp(il,1)*sigd*(evap(il,1)+evap(il,2))
+
+      if (cvflag_grav) then
+       ft(il,1)=ft(il,1)-0.009*grav*sigd*mp(il,2)                                    &
+       &                             *t(il,1)*b(il,1)*work(il)
+      else
+       ft(il,1)=ft(il,1)-0.09*sigd*mp(il,2)*t(il,1)*b(il,1)*work(il)
+      endif
+
+      ft(il,1)=ft(il,1)+0.01*sigd*wt(il,1)*(cl-cpd)*water(il,2)*(t(il,2)             &
+       &-t(il,1))*work(il)/cpn(il,1)
+
+      if (cvflag_grav) then
+!Cjyg1  Correction pour mieux conserver l'eau (conformite avec CONVECT4.3)
+!c (sb: pour l'instant, on ne fait que le chgt concernant grav, pas evap) 
+       fr(il,1)=0.01*grav*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)                      &
+       &          +sigd*0.5*(evap(il,1)+evap(il,2))
+!c+tard     :          +sigd*evap(il,1)
+
+       fr(il,1)=fr(il,1)+0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)
+
+       fu(il,1)=fu(il,1)+0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1))             &
+       &         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))             &
+       &         +am(il)*(v(il,2)-v(il,1)))
+      else  ! cvflag_grav
+       fr(il,1)=0.1*mp(il,2)*(rp(il,2)-rr(il,1))*work(il)                            &
+       &          +sigd*0.5*(evap(il,1)+evap(il,2))
+       fr(il,1)=fr(il,1)+0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
+       fu(il,1)=fu(il,1)+0.1*work(il)*(mp(il,2)*(up(il,2)-u(il,1))                   &
+       &         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.1*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))                   &
+       &         +am(il)*(v(il,2)-v(il,1)))
+      endif ! cvflag_grav
+
+      enddo ! il
+
+!c      do j=1,ntra
+!c       do il=1,ncum
+!c        if (cvflag_grav) then
+!c         ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
+!c     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+!c     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+!c        else
+!c         ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
+!c     :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+!c     :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+!c        endif
+!c       enddo
+!c      enddo
+
+      do j=2,nl
+       do il=1,ncum
+        if (j.le.inb(il)) then
+         if (cvflag_grav) then
+          fr(il,1)=fr(il,1)                                                          &
+       &       +0.01*grav*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)                                                          &
+       &       +0.01*grav*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)                                                          &
+       &       +0.01*grav*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         else   ! cvflag_grav
+          fr(il,1)=fr(il,1)                                                          &
+       &         +0.1*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)                                                          &
+       &         +0.1*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)                                                          &
+       &         +0.1*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         endif  ! cvflag_grav
+        endif ! j
+       enddo
+      enddo
+
+!c      do k=1,ntra
+!c       do j=2,nl
+!c        do il=1,ncum
+!c         if (j.le.inb(il)) then
+
+!c          if (cvflag_grav) then
+!c           ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
+!c     :                *(traent(il,j,1,k)-tra(il,1,k))
+!c          else
+!c           ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
+!c     :                *(traent(il,j,1,k)-tra(il,1,k))
+!c          endif
+
+!c         endif
+!c        enddo
+!c       enddo
+!c      enddo
+
+!c
+!c   ***  calculate tendencies of potential temperature and mixing ratio  ***
+!c   ***               at levels above the lowest level                   ***
+!c
+!c   ***  first find the net saturated updraft and downdraft mass fluxes  ***
+!c   ***                      through each level                          ***
+!c
+
+      do 500 i=2,nl+1 ! newvecto: mettre nl au lieu nl+1?
+
+       num1=0
+       do il=1,ncum
+        if(i.le.inb(il))num1=num1+1
+       enddo
+       if(num1.le.0)go to 500
+
+       call zilch(amp1,ncum)
+       call zilch(ad,ncum)
+
+      do 440 k=i+1,nl+1
+       do 441 il=1,ncum
+        if (i.le.inb(il) .and. k.le.(inb(il)+1)) then
+         amp1(il)=amp1(il)+m(il,k)
+        endif
+ 441   continue
+ 440  continue
+
+      do 450 k=1,i
+       do 451 j=i+1,nl+1
+        do 452 il=1,ncum
+         if (i.le.inb(il) .and. j.le.(inb(il)+1)) then
+          amp1(il)=amp1(il)+ment(il,k,j)
+         endif
+452     continue
+451    continue
+450   continue
+
+      do 470 k=1,i-1
+       do 471 j=i,nl+1 ! newvecto: nl au lieu nl+1?
+        do 472 il=1,ncum
+        if (i.le.inb(il) .and. j.le.inb(il)) then
+         ad(il)=ad(il)+ment(il,j,k)
+        endif
+472     continue
+471    continue
+470   continue
+  
+      do 1350 il=1,ncum
+      if (i.le.inb(il)) then
+       dpinv=1.0/(ph(il,i)-ph(il,i+1))
+       cpinv=1.0/cpn(il,i)
+
+!c convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+       if((0.01*grav*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      else
+       if((0.1*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      endif
+
+      if (cvflag_grav) then
+       ft(il,i)=0.01*grav*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)                         &
+       &    +(gz(il,i+1)-gz(il,i))*cpinv)                                            &
+       &    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))                 &
+       &    -0.5*sigd*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       rat=cpn(il,i-1)*cpinv
+       ft(il,i)=ft(il,i)-0.009*grav*sigd*(mp(il,i+1)*t(il,i)*b(il,i)                 &
+       &   -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.01*grav*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)              &
+       &    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      else  ! cvflag_grav
+       ft(il,i)=0.1*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)                               &
+       &    +(gz(il,i+1)-gz(il,i))*cpinv)                                            &
+       &    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))                 &
+       &    -0.5*sigd*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       rat=cpn(il,i-1)*cpinv
+       ft(il,i)=ft(il,i)-0.09*sigd*(mp(il,i+1)*t(il,i)*b(il,i)                       &
+       &   -mp(il,i)*t(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.1*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)                    &
+       &    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      endif ! cvflag_grav
+
+
+      ft(il,i)=ft(il,i)+0.01*sigd*wt(il,i)*(cl-cpd)*water(il,i+1)                    &
+       &           *(t(il,i+1)-t(il,i))*dpinv*cpinv
+
+      if (cvflag_grav) then
+       fr(il,i)=0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))                      &
+       &           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))               &
+       &             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))               &
+       &             -ad(il)*(v(il,i)-v(il,i-1)))
+      else  ! cvflag_grav
+       fr(il,i)=0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))                            &
+       &           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.1*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))                     &
+       &             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.1*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))                     &
+       &             -ad(il)*(v(il,i)-v(il,i-1)))
+      endif ! cvflag_grav
+
+      endif ! i
+1350  continue
+
+!c      do k=1,ntra
+!c       do il=1,ncum
+!c        if (i.le.inb(il)) then
+!c         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!c         cpinv=1.0/cpn(il,i)
+!c         if (cvflag_grav) then
+!c           ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
+!c     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+!c     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+!c         else
+!c           ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
+!c     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+!c     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+!c         endif
+!c        endif
+!c       enddo
+!c      enddo
+
+      do 480 k=1,i-1
+       do 1370 il=1,ncum
+        if (i.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+      awat=elij(il,k,i)-(1.-ep(il,i))*clw(il,i)
+      awat=amax1(awat,0.0)
+
+      if (cvflag_grav) then
+      fr(il,i)=fr(il,i)                                                              &
+       &   +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
+      fu(il,i)=fu(il,i)                                                              &
+       &         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)                                                              &
+       &         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      else  ! cvflag_grav
+      fr(il,i)=fr(il,i)                                                              &
+       &   +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-awat-rr(il,i))
+      fu(il,i)=fu(il,i)                                                              &
+       &   +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)                                                              &
+       &   +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      endif ! cvflag_grav
+
+!c (saturated updrafts resulting from mixing)        ! cld
+        qcond(il,i)=qcond(il,i)+(elij(il,k,i)-awat) ! cld
+        nqcond(il,i)=nqcond(il,i)+1.                ! cld
+      endif ! i
+1370  continue
+480   continue
+
+!c      do j=1,ntra
+!c       do k=1,i-1
+!c        do il=1,ncum
+!c         if (i.le.inb(il)) then
+!c          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!c          cpinv=1.0/cpn(il,i)
+!c          if (cvflag_grav) then
+!c           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+!c     :        *(traent(il,k,i,j)-tra(il,i,j))
+!c          else
+!c           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+!c     :        *(traent(il,k,i,j)-tra(il,i,j))
+!c          endif
+!c         endif
+!c        enddo
+!c       enddo
+!c      enddo
+
+      do 490 k=i,nl+1
+       do 1380 il=1,ncum
+        if (i.le.inb(il) .and. k.le.inb(il)) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+         if (cvflag_grav) then
+         fr(il,i)=fr(il,i)                                                           &
+       &         +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)                                                           &
+       &         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)                                                           &
+       &         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         else  ! cvflag_grav 
+         fr(il,i)=fr(il,i)                                                           &
+       &         +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)                                                           &
+       &         +0.1*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)                                                           &
+       &         +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         endif ! cvflag_grav 
+        endif ! i and k
+1380   continue
+490   continue
+
+!c      do j=1,ntra
+!c       do k=i,nl+1
+!c        do il=1,ncum
+!c         if (i.le.inb(il) .and. k.le.inb(il)) then
+!c          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!c          cpinv=1.0/cpn(il,i)
+!c          if (cvflag_grav) then
+!c           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+!c     :         *(traent(il,k,i,j)-tra(il,i,j))
+!c          else
+!c           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+!c     :             *(traent(il,k,i,j)-tra(il,i,j))
+!c          endif
+!c         endif ! i and k
+!c        enddo
+!c       enddo
+!c      enddo
+
+      do 1400 il=1,ncum
+       if (i.le.inb(il)) then
+        dpinv=1.0/(ph(il,i)-ph(il,i+1))
+        cpinv=1.0/cpn(il,i)
+
+        if (cvflag_grav) then
+!c sb: on ne fait pas encore la correction permettant de mieux
+!c conserver l'eau:
+         fr(il,i)=fr(il,i)+0.5*sigd*(evap(il,i)+evap(il,i+1))                        &
+       &        +0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)                &
+       &               *(rp(il,i)-rr(il,i-1)))*dpinv
+
+         fu(il,i)=fu(il,i)+0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i))                &
+       &             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=fv(il,i)+0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i))                &
+       &             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        else  ! cvflag_grav
+         fr(il,i)=fr(il,i)+0.5*sigd*(evap(il,i)+evap(il,i+1))                        &
+       &        +0.1*(mp(il,i+1)*(rp(il,i+1)-rr(il,i))-mp(il,i)                      &
+       &               *(rp(il,i)-rr(il,i-1)))*dpinv
+         fu(il,i)=fu(il,i)+0.1*(mp(il,i+1)*(up(il,i+1)-u(il,i))                      &
+       &             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=fv(il,i)+0.1*(mp(il,i+1)*(vp(il,i+1)-v(il,i))                      &
+       &             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        endif ! cvflag_grav
+
+      endif ! i
+1400  continue
+
+!c sb: interface with the cloud parameterization:          ! cld
+
+      do k=i+1,nl
+       do il=1,ncum 
+        if (k.le.inb(il) .and. i.le.inb(il)) then         ! cld
+!C (saturated downdrafts resulting from mixing)            ! cld
+          qcond(il,i)=qcond(il,i)+elij(il,k,i)            ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+        endif                                             ! cld
+       enddo                                              ! cld
+      enddo                                               ! cld
+
+!C (particular case: no detraining level is found)         ! cld
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nent(il,i).eq.0) then       ! cld
+          qcond(il,i)=qcond(il,i)+(1.-ep(il,i))*clw(il,i) ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+       endif                                              ! cld
+      enddo                                               ! cld
+
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nqcond(il,i).ne.0.) then    ! cld
+          qcond(il,i)=qcond(il,i)/nqcond(il,i)            ! cld
+       endif                                              ! cld
+      enddo
+
+!c      do j=1,ntra
+!c       do il=1,ncum
+!c        if (i.le.inb(il)) then
+!c         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!c         cpinv=1.0/cpn(il,i)
+
+!c         if (cvflag_grav) then
+!c          ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
+!c     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+!c     :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
+!c         else
+!c          ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
+!c     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+!c     :     -mp(il,i)*(trap(il,i,j)-tra(il,i-1,j)))
+!c         endif
+!c        endif ! i
+!c       enddo
+!c      enddo 
+
+500   continue
+
+
+!c   ***   move the detrainment at level inb down to level inb-1   ***
+!c   ***        in such a way as to preserve the vertically        ***
+!c   ***          integrated enthalpy and water tendencies         ***
+!c
+      do 503 il=1,ncum
+
+      ax=0.1*ment(il,inb(il),inb(il))*(hp(il,inb(il))-h(il,inb(il))                  &
+       & +t(il,inb(il))*(cpv-cpd)                                                    &
+       & *(rr(il,inb(il))-qent(il,inb(il),inb(il))))                                 &
+       &  /(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
+      ft(il,inb(il))=ft(il,inb(il))-ax
+      ft(il,inb(il)-1)=ft(il,inb(il)-1)+ax*cpn(il,inb(il))                           &
+       &    *(ph(il,inb(il))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)                    &
+       &    *(ph(il,inb(il)-1)-ph(il,inb(il))))
+
+      bx=0.1*ment(il,inb(il),inb(il))*(qent(il,inb(il),inb(il))                      &
+       &    -rr(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fr(il,inb(il))=fr(il,inb(il))-bx
+      fr(il,inb(il)-1)=fr(il,inb(il)-1)                                              &
+       &   +bx*(ph(il,inb(il))-ph(il,inb(il)+1))                                     &
+       &      /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      cx=0.1*ment(il,inb(il),inb(il))*(uent(il,inb(il),inb(il))                      &
+       &       -u(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fu(il,inb(il))=fu(il,inb(il))-cx
+      fu(il,inb(il)-1)=fu(il,inb(il)-1)                                              &
+       &     +cx*(ph(il,inb(il))-ph(il,inb(il)+1))                                   &
+       &        /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      dx=0.1*ment(il,inb(il),inb(il))*(vent(il,inb(il),inb(il))                      &
+       &      -v(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fv(il,inb(il))=fv(il,inb(il))-dx
+      fv(il,inb(il)-1)=fv(il,inb(il)-1)                                              &
+       &    +dx*(ph(il,inb(il))-ph(il,inb(il)+1))                                    &
+       &       /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+503   continue
+
+!c      do j=1,ntra
+!c       do il=1,ncum
+!c        ex=0.1*ment(il,inb(il),inb(il)) 
+!c     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+!c     :      /(ph(il,inb(il))-ph(il,inb(il)+1))
+!c        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+!c        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+!c     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+!c     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+!c       enddo
+!c      enddo
+
+!c
+!c   ***    homoginize tendencies below cloud base    ***
+!c
+!c
+      do il=1,ncum
+       asum(il)=0.0
+       bsum(il)=0.0
+       csum(il)=0.0
+       dsum(il)=0.0
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+      asum(il)=asum(il)+ft(il,i)*(ph(il,i)-ph(il,i+1))
+      bsum(il)=bsum(il)+fr(il,i)*(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))               &
+       &                  *(ph(il,i)-ph(il,i+1))
+      csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))                        &
+       &                      *(ph(il,i)-ph(il,i+1))
+      dsum(il)=dsum(il)+t(il,i)*(ph(il,i)-ph(il,i+1))/th(il,i)
+        endif 
+       enddo
+      enddo
+
+!c!!!      do 700 i=1,icb(il)-1
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ft(il,i)=asum(il)*t(il,i)/(th(il,i)*dsum(il))
+         fr(il,i)=bsum(il)/csum(il)
+        endif
+       enddo
+      enddo
+
+!c
+!c   ***           reset counter and return           ***
+!c
+      do il=1,ncum
+       sig(il,nd)=2.0
+      enddo
+
+
+      do i=1,nd
+       do il=1,ncum
+        upwd(il,i)=0.0
+        dnwd(il,i)=0.0
+       enddo
+      enddo
+      
+      do i=1,nl
+       do il=1,ncum
+        dnwd0(il,i)=-mp(il,i)
+       enddo
+      enddo
+      do i=nl+1,nd
+       do il=1,ncum
+        dnwd0(il,i)=0.
+       enddo
+      enddo
+
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.ge.icb(il) .and. i.le.inb(il)) then
+          upwd(il,i)=0.0
+          dnwd(il,i)=0.0
+        endif
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=1,nl
+        do il=1,ncum
+          up1(il,k,i)=0.0
+          dn1(il,k,i)=0.0
+        enddo
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=i,nl
+        do n=1,i-1
+         do il=1,ncum
+          if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+             up1(il,k,i)=up1(il,k,i)+ment(il,n,k)
+             dn1(il,k,i)=dn1(il,k,i)-ment(il,k,n)
+          endif
+         enddo
+        enddo
+       enddo
+      enddo
+
+      do i=2,nl
+       do k=i,nl
+        do il=1,ncum
+!ctest         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+         if (i.le.inb(il).and.k.le.inb(il)) then
+            upwd(il,i)=upwd(il,i)+m(il,k)+up1(il,k,i)
+            dnwd(il,i)=dnwd(il,i)+dn1(il,k,i)
+         endif
+        enddo
+       enddo
+      enddo
+
+
+!c!!!      DO il=1,ncum
+!c!!!      do i=icb(il),inb(il)
+!c!!!     
+!c!!!      upwd(il,i)=0.0
+!c!!!      dnwd(il,i)=0.0
+!c!!!      do k=i,inb(il)
+!c!!!      up1=0.0
+!c!!!      dn1=0.0
+!c!!!      do n=1,i-1
+!c!!!      up1=up1+ment(il,n,k)
+!c!!!      dn1=dn1-ment(il,k,n)
+!c!!!      enddo
+!c!!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
+!c!!!      dnwd(il,i)=dnwd(il,i)+dn1
+!c!!!      enddo
+!c!!!      enddo
+!c!!!
+!c!!!      ENDDO
+
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!c        determination de la variation de flux ascendant entre
+!c        deux niveau non dilue mike
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nl
+       do il=1,ncum
+        mike(il,i)=m(il,i)
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        mike(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+        ma(il,i)=0
+       enddo
+      enddo
+
+      do i=1,nl
+       do j=i,nl
+        do il=1,ncum
+         ma(il,i)=ma(il,i)+m(il,j)
+        enddo
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        ma(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ma(il,i)=0
+        endif
+       enddo
+      enddo
+
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!c        icb represente de niveau ou se trouve la
+!c        base du nuage , et inb le top du nuage
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nd
+       do il=1,ncum
+        mke(il,i)=upwd(il,i)+dnwd(il,i)
+       enddo
+      enddo
+
+      do i=1,nd
+       DO 999 il=1,ncum
+        rdcp=(rrd*(1.-rr(il,i))-rr(il,i)*rrv)                                        &
+       &        /(cpd*(1.-rr(il,i))+rr(il,i)*cpv)
+        tls(il,i)=t(il,i)*(1000.0/p(il,i))**rdcp
+        tps(il,i)=tp(il,i)
+999    CONTINUE
+      enddo
+
+!c
+!c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+!c   ***           of condensed water         ***            ! cld
+!c                                                           ! cld
+
+       do i=1,nd                                            ! cld
+        do il=1,ncum                                        ! cld
+         mac(il,i)=0.0                                      ! cld
+         wa(il,i)=0.0                                       ! cld
+         siga(il,i)=0.0                                     ! cld
+         sax(il,i)=0.0                                      ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=minorig, nl                                     ! cld
+        do k=i+1,nl+1                                       ! cld
+         do il=1,ncum                                       ! cld
+          if (i.le.inb(il) .and. k.le.(inb(il)+1)) then     ! cld
+            mac(il,i)=mac(il,i)+m(il,k)                     ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do j=1,i                                            ! cld
+         do il=1,ncum                                       ! cld
+          if (i.ge.icb(il) .and. i.le.(inb(il)-1)                                    & ! cld
+       &      .and. j.ge.icb(il) ) then                       ! cld
+           sax(il,i)=sax(il,i)+rrd*(tvp(il,j)-tv(il,j))                              & ! cld
+       &        *(ph(il,j)-ph(il,j+1))/p(il,j)                ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (i.ge.icb(il) .and. i.le.(inb(il)-1)                                     & ! cld
+       &       .and. sax(il,i).gt.0.0 ) then                  ! cld
+           wa(il,i)=sqrt(2.*sax(il,i))                      ! cld
+         endif                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+            
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (wa(il,i).gt.0.0)                                                        & ! cld
+       &     siga(il,i)=mac(il,i)/wa(il,i)                                           & ! cld
+       &         *rrd*tvp(il,i)/p(il,i)/100./delta            ! cld
+          siga(il,i) = min(siga(il,i),1.0)                  ! cld
+!IM cf. FH
+         if (iflag_clw.eq.0) then
+          qcondc(il,i)=siga(il,i)*clw(il,i)*(1.-ep(il,i))                            & ! cld
+       &           + (1.-siga(il,i))*qcond(il,i)              ! cld
+         else if (iflag_clw.eq.1) then
+          qcondc(il,i)=qcond(il,i)              ! cld
+         endif
+
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+        return
+        end SUBROUTINE cv30_yield
+
+!!RomP >>>
+      SUBROUTINE cv30_tracer(nloc,len,ncum,nd,na,                                    &
+       &                       ment,sij,da,phi,phi2,d1a,dam,                         &
+       &                       ep,VPrecip,elij,clw,epmlmMm,eplaMm,                   &
+       &                       icb,inb)
+        implicit none
+
+#include "cv30param.h"
+
+!c inputs:
+        integer ncum, nd, na, nloc,len
+        real ment(nloc,na,na),sij(nloc,na,na)
+	real clw(nloc,nd),elij(nloc,na,na)
+	real ep(nloc,na)
+        integer icb(nloc),inb(nloc)
+        real VPrecip(nloc,nd+1)
+!c ouputs:
+        real da(nloc,na),phi(nloc,na,na)
+	real phi2(nloc,na,na)
+	real d1a(nloc,na),dam(nloc,na)
+	real epmlmMm(nloc,na,na),eplaMm(nloc,na)
+! variables pour tracer dans precip de l'AA et des mel
+!c local variables:
+        integer i,j,k
+	real epm(nloc,na,na)
+!c
+! variables d'Emanuel : du second indice au troisieme
+! --->    tab(i,k,j) -> de l origine k a l arrivee j 
+!  ment, sij, elij
+! variables personnelles : du troisieme au second indice
+! --->    tab(i,j,k) -> de k a j 
+! phi, phi2
+!
+! initialisations
+       do j=1,na
+        do i=1,ncum
+         da(i,j)=0.
+         d1a(i,j)=0.
+         dam(i,j)=0.
+         eplaMm(i,j)=0.
+        enddo
+       enddo
+      do k=1,na
+       do j=1,na
+        do i=1,ncum
+         epm(i,j,k)=0.
+         epmlmMm(i,j,k)=0.
+         phi(i,j,k)=0.
+         phi2(i,j,k)=0.
+        enddo
+       enddo
+      enddo
+!c
+!  fraction deau condensee dans les melanges convertie en precip : epm
+! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz
+        do j=1,na
+         do k=1,j-1
+           do i=1,ncum
+            if(k.ge.icb(i).and.k.le.inb(i).and.                                      &
+       &         j.le.inb(i)) then
+!!jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
+             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/                                    &
+       &                     max(elij(i,k,j),1.e-16)
+!!
+             epm(i,j,k)=max(epm(i,j,k),0.0)
+            endif
+           end do 
+         end do 
+        end do
+!
+        do j=1,na
+         do k=1,na
+           do i=1,ncum
+            if(k.ge.icb(i).and.k.le.inb(i)) then
+             eplaMm(i,j)=eplaMm(i,j) + ep(i,j)*clw(i,j)                              &
+       &                  *ment(i,j,k)*(1.-sij(i,j,k))
+            endif
+           end do 
+         end do 
+        end do
+!
+        do j=1,na
+         do k=1,j-1
+           do i=1,ncum
+            if(k.ge.icb(i).and.k.le.inb(i).and.                                      &
+       &         j.le.inb(i)) then
+             epmlmMm(i,j,k)=epm(i,j,k)*elij(i,k,j)*ment(i,k,j)
+            endif
+           end do 
+         end do 
+        end do
+
+!  matrices pour calculer la tendance des concentrations dans cvltr.F90
+        do j=1,na
+          do k=1,na
+            do i=1,ncum
+             da(i,j)=da(i,j)+(1.-sij(i,k,j))*ment(i,k,j)
+             phi(i,j,k)=sij(i,k,j)*ment(i,k,j)
+             d1a(i,j)=d1a(i,j)+ment(i,k,j)*ep(i,k)                                   &
+       &              *(1.-sij(i,k,j))
+            end do 
+          end do 
+        end do 
+
+        do j=1,na
+          do k=1,j-1
+            do i=1,ncum
+             dam(i,j)=dam(i,j)+ment(i,k,j)                                           &
+       &             *epm(i,j,k)*(1.-ep(i,k))*(1.-sij(i,k,j)) 
+             phi2(i,j,k)=phi(i,j,k)*epm(i,j,k)
+            end do 
+          end do 
+        end do 
+
+        return
+        end SUBROUTINE cv30_tracer
+!RomP <<<
+
+      SUBROUTINE cv30_uncompress(nloc,len,ncum,nd,ntra,idcum                         &
+       &         ,iflag                                                              &
+       &         ,precip,VPrecip,evap,ep,sig,w0                                      &
+       &         ,ft,fq,fu,fv,ftra                                                   &
+       &         ,inb                                                                &
+       &         ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape                                  &
+       &         ,da,phi,mp,phi2,d1a,dam,sij                                         &
+       &         ,elij,clw,epmlmMm,eplaMm                                            &
+       &         ,wdtrainA,wdtrainM                                                  &
+       &         ,iflag1                                                             &
+       &         ,precip1,VPrecip1,evap1,ep1,sig1,w01                                &
+       &         ,ft1,fq1,fu1,fv1,ftra1                                              &
+       &         ,inb1                                                               &
+       &         ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1                           &
+       &         ,da1,phi1,mp1,phi21,d1a1,dam1,sij1                                  &
+       &         ,elij1,clw1,epmlmMm1,eplaMm1                                        &
+       &         ,wdtrainA1,wdtrainM1)
+      implicit none
+
+#include "cv30param.h"
+
+!c inputs:
+      integer len, ncum, nd, ntra, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      integer inb(nloc)
+      real precip(nloc)
+      real VPrecip(nloc,nd+1),evap(nloc,nd)
+      real ep(nloc,nd)
+      real sig(nloc,nd), w0(nloc,nd)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real Ma(nloc,nd)
+      real upwd(nloc,nd),dnwd(nloc,nd),dnwd0(nloc,nd)
+      real qcondc(nloc,nd)
+      real wd(nloc),cape(nloc)
+      real da(nloc,nd),phi(nloc,nd,nd),mp(nloc,nd)
+!RomP >>>
+      real phi2(nloc,nd,nd)
+      real d1a(nloc,nd),dam(nloc,nd)
+      real wdtrainA(nloc,nd), wdtrainM(nloc,nd)
+      real sij(nloc,nd,nd)
+      real elij(nloc,nd,nd),clw(nloc,nd)
+      real epmlmMm(nloc,nd,nd),eplaMm(nloc,nd)
+!RomP <<<
+
+!c outputs:
+      integer iflag1(len)
+      integer inb1(len)
+      real precip1(len)
+      real VPrecip1(len,nd+1),evap1(len,nd) !<<< RomP
+      real ep1(len,nd)                      !<<< RomP
+      real sig1(len,nd), w01(len,nd)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real Ma1(len,nd)
+      real upwd1(len,nd),dnwd1(len,nd),dnwd01(len,nd)
+      real qcondc1(nloc,nd)
+      real wd1(nloc),cape1(nloc)
+      real da1(nloc,nd),phi1(nloc,nd,nd),mp1(nloc,nd)
+!RomP >>>
+      real phi21(len,nd,nd)
+      real d1a1(len,nd),dam1(len,nd)
+      real wdtrainA1(len,nd), wdtrainM1(len,nd)
+      real sij1(len,nd,nd)
+      real elij1(len,nd,nd),clw1(len,nd)
+      real epmlmMm1(len,nd,nd),eplaMm1(len,nd)
+!RomP <<<
+
+!c local variables:
+      integer i,k,j
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         iflag1(idcum(i))=iflag(i)
+         wd1(idcum(i))=wd(i)
+         inb1(idcum(i))=inb(i)
+         cape1(idcum(i))=cape(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            VPrecip1(idcum(i),k)=VPrecip(i,k)
+            evap1(idcum(i),k)=evap(i,k)   !<<< RomP
+            sig1(idcum(i),k)=sig(i,k)
+            w01(idcum(i),k)=w0(i,k)
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            upwd1(idcum(i),k)=upwd(i,k)
+            dnwd1(idcum(i),k)=dnwd(i,k)
+            dnwd01(idcum(i),k)=dnwd0(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+            da1(idcum(i),k)=da(i,k)
+            mp1(idcum(i),k)=mp(i,k)
+!RomP >>>
+            ep1(idcum(i),k)=ep(i,k)
+            d1a1(idcum(i),k)=d1a(i,k)
+            dam1(idcum(i),k)=dam(i,k)
+            clw1(idcum(i),k)=clw(i,k)
+            eplaMm1(idcum(i),k)=eplaMm(i,k)
+            wdtrainA1(idcum(i),k)=wdtrainA(i,k)
+            wdtrainM1(idcum(i),k)=wdtrainM(i,k)
+!RomP <<<
+ 2010     continue
+ 2020   continue
+
+        do 2200 i=1,ncum
+          sig1(idcum(i),nd)=sig(i,nd)
+2200    continue
+
+
+!c        do 2100 j=1,ntra
+!c         do 2110 k=1,nd ! oct3
+!c          do 2120 i=1,ncum
+!c            ftra1(idcum(i),k,j)=ftra(i,k,j)
+!c 2120     continue
+!c 2110    continue
+!c 2100   continue
+        do j=1,nd
+         do k=1,nd 
+          do i=1,ncum
+            sij1(idcum(i),k,j)=sij(i,k,j)
+            phi1(idcum(i),k,j)=phi(i,k,j)
+            phi21(idcum(i),k,j)=phi2(i,k,j)
+            elij1(idcum(i),k,j)=elij(i,k,j)
+            epmlmMm1(idcum(i),k,j)=epmlmMm(i,k,j)
+          end do
+         end do
+        end do
+
+        return
+        end SUBROUTINE cv30_uncompress
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv30param.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv30param.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv30param.h	(revision 17)
@@ -0,0 +1,30 @@
+!
+! $Header$
+!
+!c------------------------------------------------------------
+!c Parameters for convectL, iflag_con=30:
+!c (includes - microphysical parameters, 
+!c			- parameters that control the rate of approach 
+!c               to quasi-equilibrium)
+!c			- noff & minorig (previously in input of convect1)
+!c------------------------------------------------------------
+
+      integer noff, minorig, nl, nlp, nlm
+      real sigd, spfac
+!IM cf. FH : pour compatibilite avec conema3 TEMPORAIRE   real pbcrit, ptcrit, epmax
+      real pbcrit, ptcrit
+      real omtrain
+      real dtovsh, dpbase, dttrig
+      real dtcrit, tau, beta, alpha
+      real delta
+      real betad
+
+      COMMON /cv30param/  noff, minorig, nl, nlp, nlm                                &
+       &                ,  sigd, spfac                                               &
+!IM cf. FH : pour compatibilite avec conema3 TEMPORAIRE  :                ,pbcrit, ptcrit, epmax&
+       &                ,pbcrit, ptcrit                                              &
+       &                ,omtrain                                                     &
+       &                ,dtovsh, dpbase, dttrig                                      &
+       &                ,dtcrit, tau, beta, alpha, delta, betad
+
+!$OMP THREADPRIVATE(/cv30param/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_buoy.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_buoy.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_buoy.F	(revision 17)
@@ -0,0 +1,145 @@
+        SUBROUTINE CV3_BUOY (nloc,ncum,nd,icb,inb
+     :                      ,pbase,plcl,p,ph,Ale,Cin
+     :                      ,tv,tvp
+     :                      ,buoy )
+***************************************************************
+*                                                             *
+* CV3_BUOY                                                    *
+*         Buoyancy corrections to account for ALE             *
+*                                                             *
+* written by   : MOREAU Cecile, 07/08/2003, 15.55.48          *
+* modified by :                                               *
+***************************************************************
+*
+      implicit none
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc),plcl(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real Ale(nloc), Cin(nloc)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+c output:
+      real buoy(nloc,nd)
+
+c local variables:
+      integer il, k
+      integer kmx(nloc)
+      real bll(nloc), bmx(nloc)
+      real gamma(nloc)
+      logical ok(nloc)
+
+      real dgamma
+      real buoymin
+      parameter (dgamma = 2.e-03) !dgamma gamma
+      parameter (buoymin = 2.)
+
+      logical fixed_bll
+      SAVE fixed_bll
+      data fixed_bll /.TRUE./
+c$OMP THREADPRIVATE(fixed_bll)
+
+
+c      print *,' Ale+cin ',ale(1)+cin(1)
+c--------------------------------------------------------------
+c      Recompute buoyancies
+c--------------------------------------------------------------
+      DO k = 1,nl
+        DO il = 1,ncum
+           buoy(il,k) = tvp(il,k) - tv(il,k)
+        ENDDO
+      ENDDO
+
+c -------------------------------------------------------------
+c -- Compute low level buoyancy ( function of Ale+Cin )
+c -------------------------------------------------------------
+      IF (fixed_bll) THEN
+c
+      do il = 1,ncum
+        bll(il) = 0.5
+      end DO
+      else
+
+      do il = 1,ncum
+       IF (Ale(il)+Cin(il) .GT. 0.) THEN
+        gamma(il) = 4.*buoy(il,icb(il))**2
+     :           + 8.*dgamma*(Ale(il)+Cin(il))*tv(il,icb(il))/grav
+        gamma(il) = max(gamma(il),1.e-10)
+       ENDIF
+      end do
+
+      do il = 1,ncum
+       IF (Ale(il)+Cin(il) .GT. 0.) THEN
+        bll(il) = 4.*dgamma*(Ale(il)+Cin(il))*tv(il,icb(il))
+     :         /(grav*(abs(buoy(il,icb(il))+0.5*sqrt(gamma(il)))))
+       ENDIF
+      end do
+
+      do il = 1,ncum
+       IF (Ale(il)+Cin(il) .GT. 0.) THEN
+        bll(il) = min(bll(il),buoymin)
+       ENDIF
+      end DO
+c
+      ENDIF     !(fixed_bll)
+
+
+c -------------------------------------------------------------
+c --Get highest buoyancy among levels below LCL-200hPa
+c -------------------------------------------------------------
+
+      do il = 1,ncum
+       bmx(il) =-1000.
+       kmx(il) = icb(il)
+       ok(il) = .true.
+      end do
+
+      do k = 1,nl
+       do il = 1,ncum
+        IF (Ale(il)+Cin(il) .GT. 0. .AND. ok(il)) THEN
+        IF (k .GT. icb(il) .AND. k .LE. inb(il)) THEN
+cc         print *,'k,p(il,k),plcl(il)-200. ', k,p(il,k),plcl(il)-200.
+         IF (P(il,k) .GT. plcl(il)-200.) THEN
+          IF (buoy(il,k) .GT. bmx(il)) THEN
+           bmx(il) = buoy(il,k)
+           kmx(il) = k
+           IF (bmx(il) .GE. bll(il)) ok(il)=.false.
+          ENDIF
+         ENDIF
+        ENDIF
+        ENDIF
+       end do
+      end do
+
+c      print *,' ==cv3_buoy== bll(1),bmx(1),icb(1),kmx(1) '
+c     $       ,bll(1),bmx(1),icb(1),kmx(1)
+
+c -------------------------------------------------------------
+c --Calculate modified buoyancies
+c -------------------------------------------------------------
+
+      do il = 1,ncum
+       IF (Ale(il)+Cin(il) .GT. 0.) THEN
+        bll(il) = min(bll(il),bmx(il))
+       ENDIF
+      end do
+
+      do k = 1,nl
+       do il = 1,ncum
+        IF (Ale(il)+Cin(il) .GT. 0.) THEN
+         IF (k .GE. icb(il) .AND. k .LE. kmx(il)-1) THEN
+           buoy(il,k) = bll(il)
+         ENDIF
+        ENDIF
+       end do
+      end do
+
+
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_buoy.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_buoy.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_buoy.F90	(revision 17)
@@ -0,0 +1,145 @@
+        SUBROUTINE CV3_BUOY (nloc,ncum,nd,icb,inb                                    &
+       &                      ,pbase,plcl,p,ph,Ale,Cin                               &
+       &                      ,tv,tvp                                                &
+       &                      ,buoy )
+!***************************************************************
+!*                                                             *
+!* CV3_BUOY                                                    *
+!*         Buoyancy corrections to account for ALE             *
+!*                                                             *
+!* written by   : MOREAU Cecile, 07/08/2003, 15.55.48          *
+!* modified by :                                               *
+!***************************************************************
+!*
+      implicit none
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+!c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc),plcl(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real Ale(nloc), Cin(nloc)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+!c output:
+      real buoy(nloc,nd)
+
+!c local variables:
+      integer il, k
+      integer kmx(nloc)
+      real bll(nloc), bmx(nloc)
+      real gamma(nloc)
+      logical ok(nloc)
+
+      real dgamma
+      real buoymin
+      parameter (dgamma = 2.e-03) !dgamma gamma
+      parameter (buoymin = 2.)
+
+      logical fixed_bll
+      SAVE fixed_bll
+      data fixed_bll /.TRUE./
+!$OMP THREADPRIVATE(fixed_bll)
+
+
+!c      print *,' Ale+cin ',ale(1)+cin(1)
+!c--------------------------------------------------------------
+!c      Recompute buoyancies
+!c--------------------------------------------------------------
+      DO k = 1,nl
+        DO il = 1,ncum
+           buoy(il,k) = tvp(il,k) - tv(il,k)
+        ENDDO
+      ENDDO
+
+!c -------------------------------------------------------------
+!c -- Compute low level buoyancy ( function of Ale+Cin )
+!c -------------------------------------------------------------
+      IF (fixed_bll) THEN
+!c
+      do il = 1,ncum
+        bll(il) = 0.5
+      end DO
+      else
+
+      do il = 1,ncum
+       IF (Ale(il)+Cin(il) .GT. 0.) THEN
+        gamma(il) = 4.*buoy(il,icb(il))**2                                           &
+       &           + 8.*dgamma*(Ale(il)+Cin(il))*tv(il,icb(il))/grav
+        gamma(il) = max(gamma(il),1.e-10)
+       ENDIF
+      end do
+
+      do il = 1,ncum
+       IF (Ale(il)+Cin(il) .GT. 0.) THEN
+        bll(il) = 4.*dgamma*(Ale(il)+Cin(il))*tv(il,icb(il))                         &
+       &         /(grav*(abs(buoy(il,icb(il))+0.5*sqrt(gamma(il)))))
+       ENDIF
+      end do
+
+      do il = 1,ncum
+       IF (Ale(il)+Cin(il) .GT. 0.) THEN
+        bll(il) = min(bll(il),buoymin)
+       ENDIF
+      end DO
+!c
+      ENDIF     !(fixed_bll)
+
+
+!c -------------------------------------------------------------
+!c --Get highest buoyancy among levels below LCL-200hPa
+!c -------------------------------------------------------------
+
+      do il = 1,ncum
+       bmx(il) =-1000.
+       kmx(il) = icb(il)
+       ok(il) = .true.
+      end do
+
+      do k = 1,nl
+       do il = 1,ncum
+        IF (Ale(il)+Cin(il) .GT. 0. .AND. ok(il)) THEN
+        IF (k .GT. icb(il) .AND. k .LE. inb(il)) THEN
+!cc         print *,'k,p(il,k),plcl(il)-200. ', k,p(il,k),plcl(il)-200.
+         IF (P(il,k) .GT. plcl(il)-200.) THEN
+          IF (buoy(il,k) .GT. bmx(il)) THEN
+           bmx(il) = buoy(il,k)
+           kmx(il) = k
+           IF (bmx(il) .GE. bll(il)) ok(il)=.false.
+          ENDIF
+         ENDIF
+        ENDIF
+        ENDIF
+       end do
+      end do
+
+!c      print *,' ==cv3_buoy== bll(1),bmx(1),icb(1),kmx(1) '
+!c     $       ,bll(1),bmx(1),icb(1),kmx(1)
+
+!c -------------------------------------------------------------
+!c --Calculate modified buoyancies
+!c -------------------------------------------------------------
+
+      do il = 1,ncum
+       IF (Ale(il)+Cin(il) .GT. 0.) THEN
+        bll(il) = min(bll(il),bmx(il))
+       ENDIF
+      end do
+
+      do k = 1,nl
+       do il = 1,ncum
+        IF (Ale(il)+Cin(il) .GT. 0.) THEN
+         IF (k .GE. icb(il) .AND. k .LE. kmx(il)-1) THEN
+           buoy(il,k) = bll(il)
+         ENDIF
+        ENDIF
+       end do
+      end do
+
+
+
+      RETURN
+      END SUBROUTINE CV3_BUOY
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_cine.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_cine.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_cine.F	(revision 17)
@@ -0,0 +1,454 @@
+!
+! $Id: cv3_cine.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+        SUBROUTINE cv3_cine(nloc,ncum,nd,icb,inb
+     :                      ,pbase,plcl,p,ph,tv,tvp
+     :                      ,cina,cinb,plfc)
+
+***************************************************************
+*                                                             *
+* CV3_CINE                                                    *
+*                                                             *
+*                                                             *
+* written by   :   Frederique Cheruy                          *
+* vectorization:   Jean-Yves Grandpeix, 19/06/2003, 11.54.43  *
+* modified by :                                               *
+***************************************************************
+*
+      implicit none
+c
+#include "YOMCST.h"
+#include "cvthermo.h"
+#include "cv3param.h"
+c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc),plcl(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real tv(nloc,nd),tvp(nloc,nd)
+c
+c output
+      real cina(nloc),cinb(nloc),plfc(nloc)
+c
+c local variables
+      integer il,i,j,k
+      integer itop(nloc),ineg(nloc),ilow(nloc)
+      integer ifst(nloc),isublcl(nloc)
+      logical lswitch(nloc),lswitch1(nloc),lswitch2(nloc)
+      logical exist_lfc(nloc)
+      real dpmax
+      real deltap,dcin
+      real buoylcl(nloc),tvplcl(nloc),tvlcl(nloc)
+      real p0(nloc)
+      real buoyz(nloc), buoy(nloc,nd)
+c
+c-------------------------------------------------------------
+c     Initialization
+c-------------------------------------------------------------
+      do il = 1,ncum
+       cina(il) = 0.
+       cinb(il) = 0.
+      enddo
+c
+c--------------------------------------------------------------
+c      Recompute buoyancies
+c--------------------------------------------------------------
+      DO k = 1,nd
+        DO il = 1,ncum
+!      print*,'tvp tv=',tvp(il,k),tv(il,k)
+          buoy(il,k) = tvp(il,k) - tv(il,k)
+        ENDDO
+      ENDDO
+c---------------------------------------------------------------
+c
+c   calcul de la flottabilite a LCL (Buoylcl)
+c     ifst = first P-level above lcl
+c     isublcl = highest P-level below lcl.
+c---------------------------------------------------------------
+c
+      do il = 1,ncum
+       TVPlcl(il) = TVP(il,1)*(Plcl(il)/P(il,1))**(2./7.) !For dry air, R/Cp=2/7
+      enddo
+c
+      do il = 1,ncum
+       IF (Plcl(il) .GT. P(il,icb(il))) THEN
+        ifst(il) = icb(il)
+        isublcl(il) = icb(il)-1
+       ELSE
+        ifst(il) = icb(il)+1
+        isublcl(il) = icb(il)
+       ENDIF
+      enddo
+c
+      do il = 1,ncum
+       TVlcl(il)=TV(il,ifst(il)-1)+(TV(il,ifst(il))-TV(il,ifst(il)-1))
+     $   *(Plcl(il)-P(il,ifst(il)-1))/(P(il,ifst(il))-P(il,ifst(il)-1))
+      enddo
+c
+      do il = 1,ncum
+        BUOYlcl(il) = TVPlcl(il)-TVlcl(il)
+      enddo
+c
+c---------------------------------------------------------------
+c premiere couche contenant un  niveau de flotabilite positive
+c et premiere couche contenant un  niveau de flotabilite negative
+c  au dessus du niveau de condensation
+c---------------------------------------------------------------
+      do il = 1,ncum
+        itop(il) =nl-1
+        ineg(il) = nl-1
+        exist_lfc(il) = .FALSE.
+      enddo
+      do 100 k=nl-1,1,-1
+       do 110 il=1,ncum
+        if (k .ge. ifst(il)) then
+         if (buoy(il,k) .gt. 0.) then
+          itop(il)=k
+          exist_lfc(il) = .TRUE.
+         else
+          ineg(il)=k
+         endif
+        endif
+110    continue
+100   continue
+c
+c---------------------------------------------------------------
+c When there is no positive buoyancy level, set Plfc, Cina and Cinb
+c to arbitrary extreme values.
+c---------------------------------------------------------------
+      DO il = 1,ncum
+       IF (.NOT.exist_lfc(il)) THEN
+         Plfc(il) = 1.111
+         Cinb(il) = -1111.
+         Cina(il) = -1112.
+       ENDIF
+      ENDDO
+c
+c
+c---------------------------------------------------------------
+c -- Two cases : BUOYlcl >= 0 and BUOYlcl < 0.
+c---------------------------------------------------------------
+C
+C--------------------
+C -- 1.0 BUOYlcl >=0.
+C--------------------
+c
+      DPMAX = 50.
+      DO il = 1,ncum
+        lswitch1(il)=BUOYlcl(il) .GE. 0. .AND. exist_lfc(il)
+        lswitch(il) = lswitch1(il)
+      ENDDO
+c
+c 1.1 No inhibition case
+c ----------------------
+C   If buoyancy is positive at LCL and stays positive over a large enough
+C pressure interval (=DPMAX), inhibition is set to zero,
+C
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        IF (P(il,ineg(il)) .LT. P(il,icb(il))-DPmax) THEN
+          PLFC(il) = Plcl(il)
+          Cina(il) = 0.
+          Cinb(il) = 0.
+        ENDIF
+      ENDIF
+      ENDDO
+c
+c 1.2 Upper inhibition only case
+c ------------------------------
+      DO il = 1,ncum
+        lswitch2(il)= P(il,ineg(il)) .GE. P(il,icb(il))-DPmax
+        lswitch(il) = lswitch1(il) .AND. lswitch2(il)
+      ENDDO
+c
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+          Cinb(il) = 0.
+c
+c 1.2.1  Calcul de la pression du niveau de flot. nulle juste au-dessus de LCL
+c ---------------------------------------------------------------------------
+         IF (ineg(il) .GT. isublcl(il)+1) THEN
+C In order to get P0, one may interpolate linearly buoyancies
+C  between P(ineg) and P(ineg-1).
+        P0(il)=(buoy(il,ineg(il))*P(il,ineg(il)-1)
+     $         -buoy(il,ineg(il)-1)*P(il,ineg(il)))
+     :           / (buoy(il,ineg(il))-buoy(il,ineg(il)-1))
+         ELSE
+C In order to get P0, one has to interpolate between P(ineg) and Plcl.
+        P0(il) = (BUOY(il,ineg(il))*Plcl(il)-BUOYlcl(il)*P(il,ineg(il)))
+     $          /(BUOY(il,ineg(il))     -BUOYlcl(il))
+         ENDIF
+      ENDIF
+      ENDDO
+c
+c 1.2.2 Recompute itop (=1st layer with positive buoyancy above ineg)
+c -------------------------------------------------------------------
+      do il = 1,ncum
+      IF (lswitch(il)) THEN
+        itop(il) =nl-1
+      ENDIF
+      enddo
+c
+      do  k=nl,1,-1
+       do  il=1,ncum
+       IF (lswitch(il)) THEN
+        if (k .ge. ineg(il) .and. buoy(il,k) .gt. 0) then
+         itop(il)=k
+        endif
+       ENDIF
+       enddo
+      enddo
+c
+c 1.2.3 Computation of PLFC
+c -------------------------
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        PLFC(il)=(buoy(il,itop(il))*P(il,itop(il)-1)
+     $           -buoy(il,itop(il)-1)*P(il,itop(il)))
+     $           / (buoy(il,itop(il))-buoy(il,itop(il)-1))
+      ENDIF
+      ENDDO
+c
+c 1.2.4 Computation of CINA
+c -------------------------
+c
+C   Upper part of CINA : integral from P(itop-1) to Plfc
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P(il,itop(il)-1)-Plfc(il)
+        dcin = RD*BUOY(il,itop(il)-1)*deltap
+     $        / (P(il,itop(il)-1)+Plfc(il))
+        CINA(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+c
+C   Middle part of CINA : integral from P(ineg) to P(itop-1)
+      DO k = 1,nl
+        DO il = 1,ncum
+        IF (lswitch(il)) THEN
+          IF (k .GE. ineg(il) .AND. k .LE. itop(il)-2) THEN
+           deltap = P(il,k)-P(il,k+1)
+           dcin = 0.5*RD*(BUOY(il,k)+BUOY(il,k+1))*deltap/PH(il,k+1)
+           CINA(il) = CINA(il) + min(0.,dcin)
+          ENDIF
+        ENDIF
+        ENDDO
+      ENDDO
+c
+C   Lower part of CINA : integral from P0 to P(ineg)
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P0(il)-P(il,ineg(il))
+        dcin = RD*BUOY(il,ineg(il))*deltap/(P(il,ineg(il))+P0(il))
+        CINA(il) = CINA(il) + min(0.,dcin)
+      ENDIF
+      ENDDO
+c
+C
+C ------------------
+C -- 2.0 BUOYlcl <0.
+C ------------------
+C
+      DO il = 1,ncum
+        lswitch1(il)=BUOYlcl(il) .LT. 0. .AND. exist_lfc(il)
+        lswitch(il) = lswitch1(il)
+      ENDDO
+c
+c 2.0.1 Premiere  couche ou la flotabilite est negative au dessus du sol
+c ----------------------------------------------------
+c    au cas ou elle existe  sinon ilow=1 (nk apres)
+c      on suppose que la parcelle part de la premiere couche
+c
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+       ilow(il)=1
+      ENDIF
+      ENDDO
+c
+      do 200 k=nl,1,-1
+        DO il = 1,ncum
+        IF (lswitch(il) .AND. k .LE.icb(il)-1) THEN
+         if(buoy(il,k).lt. 0.) then
+           ilow(il) = k
+          endif
+        ENDIF
+        ENDDO
+ 200  continue
+
+c 2.0.2  Calcul de la pression du niveau de flot. nulle sous le nuage
+c ----------------------------------------------------
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+       if(ilow(il).gt. 1) then
+         P0(il)=(buoy(il,ilow(il))*P(il,ilow(il)-1)
+     $          -buoy(il,ilow(il)-1)*P(il,ilow(il)))
+     :            / (buoy(il,ilow(il))-buoy(il,ilow(il)-1))
+         BUOYz(il) = 0.
+       else
+         P0(il) = P(il,1)
+         BUOYz(il) = BUOY(il,1)
+       endif
+      ENDIF
+      ENDDO
+c
+C 2.1. Computation of CINB
+C -----------------------
+c
+      DO il = 1,ncum
+        lswitch2(il)= (isublcl(il) .EQ. 1 .AND. ilow(il) .EQ. 1)
+     $                  .OR.(isublcl(il) .EQ. ilow(il)-1)
+        lswitch(il) = lswitch1(il) .AND. lswitch2(il)
+      ENDDO
+cc      IF (    (isublcl .EQ. 1 .AND. ilow .EQ. 1)
+cc     $    .OR.(isublcl .EQ. ilow-1)) THEN
+c
+c 2.1.1 First case : Plcl just above P0
+c -------------------------------------
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P0(il)-Plcl(il)
+        dcin = RD*(BUOYz(il)+BUOYlcl(il))*deltap/(P0(il)+Plcl(il))
+        CINB(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+c
+      DO il = 1,ncum
+        lswitch(il) = lswitch1(il) .AND. .NOT. lswitch2(il)
+      ENDDO
+cc      ELSE
+c
+c 2.1.2 Second case : there is at least one P-level between P0 and Plcl
+c ---------------------------------------------------------------------
+c
+C   Lower part of CINB : integral from P0 to P(ilow)
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P0(il)-P(il,ilow(il))
+        dcin = RD*(BUOYz(il)+BUOY(il,ilow(il)))*deltap
+     $         /(P0(il)+P(il,ilow(il)))
+        CINB(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+c
+c
+C  Middle part of CINB : integral from P(ilow) to P(isublcl)
+cc      DO k = ilow,isublcl-1
+      DO k = 1,nl
+        DO il = 1,ncum
+        IF (lswitch(il)
+     $   .AND. k .GE. ilow(il) .AND. k .LE. isublcl(il)-1) THEN
+          deltap = P(il,k)-P(il,k+1)
+          dcin = 0.5*RD*(BUOY(il,k)+BUOY(il,k+1))*deltap/PH(il,k+1)
+          CINB(il) = CINB(il) + min(0.,dcin)
+        ENDIF
+        ENDDO
+      ENDDO
+c
+C  Upper part of CINB : integral from P(isublcl) to Plcl
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P(il,isublcl(il)) - Plcl(il)
+        dcin = RD*(BUOY(il,isublcl(il))+BUOYlcl(il))*deltap
+     $         /(P(il,isublcl(il))+Plcl(il))
+        CINB(il) = CINB(il)+min(0.,dcin)
+      ENDIF
+      ENDDO
+C
+c
+cc      ENDIF
+c
+C 2.2 Computation of CINA
+c ---------------------
+c
+      DO il = 1,ncum
+        lswitch2(il)= Plcl(il) .GT. P(il,itop(il)-1)
+        lswitch(il) = lswitch1(il) .AND. lswitch2(il)
+      ENDDO
+c
+c 2.2.1 FIrst case : Plcl > P(itop-1)
+C ---------------------------------
+C In order to get Plfc, one may interpolate linearly buoyancies
+C  between P(itop) and P(itop-1).
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        PLFC(il)=(buoy(il,itop(il))*P(il,itop(il)-1)
+     $           -buoy(il,itop(il)-1)*P(il,itop(il)))
+     $           / (buoy(il,itop(il))-buoy(il,itop(il)-1))
+      ENDIF
+      ENDDO
+c
+C   Upper part of CINA : integral from P(itop-1) to Plfc
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P(il,itop(il)-1)-Plfc(il)
+        dcin = RD*BUOY(il,itop(il)-1)*deltap
+     $         /(P(il,itop(il)-1)+Plfc(il))
+        CINA(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+c
+C   Middle part of CINA : integral from P(icb+1) to P(itop-1)
+      DO k = 1,nl
+        DO il = 1,ncum
+        IF (lswitch(il)
+     $     .AND. k .GE. icb(il)+1 .AND. k .LE. itop(il)-2) THEN
+          deltap = P(il,k)-P(il,k+1)
+          dcin = 0.5*RD*(BUOY(il,k)+BUOY(il,k+1))*deltap/PH(il,k+1)
+          CINA(il) = CINA(il) + min(0.,dcin)
+        ENDIF
+        ENDDO
+      ENDDO
+c
+C   Lower part of CINA : integral from Plcl to P(icb+1)
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        IF (Plcl(il) .GT. P(il,icb(il))) THEN
+          IF (icb(il) .LT. itop(il)-1) THEN
+            deltap = P(il,icb(il))-P(il,icb(il)+1)
+            dcin = 0.5*RD*(BUOY(il,icb(il))+BUOY(il,icb(il)+1))
+     $                   *deltap/PH(il,icb(il)+1)
+            CINA(il) = CINA(il)+min(0.,dcin)
+          ENDIF
+c
+          deltap = Plcl(il)-P(il,icb(il))
+          dcin = RD*(BUOYlcl(il)+BUOY(il,icb(il)))
+     $              *deltap/(Plcl(il)+P(il,icb(il)))
+          CINA(il) = CINA(il)+min(0.,dcin)
+        ELSE
+          deltap = Plcl(il)-P(il,icb(il)+1)
+          dcin = RD*(BUOYlcl(il)+BUOY(il,icb(il)+1))
+     $             *deltap/(Plcl(il)+P(il,icb(il)+1))
+          CINA(il) = CINA(il)+min(0.,dcin)
+        ENDIF
+      ENDIF
+      ENDDO
+c
+      DO il = 1,ncum
+        lswitch(il) = lswitch1(il) .AND. .NOT. lswitch2(il)
+      ENDDO
+cc      ELSE
+c
+c 2.2.2 Second case : Plcl lies between P(itop-1) and P(itop);
+C ----------------------------------------------------------
+C In order to get Plfc, one has to interpolate between P(itop) and Plcl.
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        PLFC(il) =
+     $    (BUOY(il,itop(il))*Plcl(il)-BUOYlcl(il)*P(il,itop(il)))
+     $          /(BUOY(il,itop(il))     -BUOYlcl(il))
+      ENDIF
+      ENDDO
+c
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = Plcl(il)-Plfc(il)
+        dcin = RD*BUOYlcl(il)*deltap/(Plcl(il)+Plfc(il))
+        CINA(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+cc      ENDIF
+c
+
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_cine.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_cine.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_cine.F90	(revision 17)
@@ -0,0 +1,454 @@
+!
+! $Id: cv3_cine.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+        SUBROUTINE cv3_cine(nloc,ncum,nd,icb,inb                                     &
+       &                      ,pbase,plcl,p,ph,tv,tvp                                &
+       &                      ,cina,cinb,plfc)
+
+!***************************************************************
+!*                                                             *
+!* CV3_CINE                                                    *
+!*                                                             *
+!*                                                             *
+!* written by   :   Frederique Cheruy                          *
+!* vectorization:   Jean-Yves Grandpeix, 19/06/2003, 11.54.43  *
+!* modified by :                                               *
+!***************************************************************
+!*
+      implicit none
+!c
+#include "YOMCST.h"
+#include "cvthermo.h"
+#include "cv3param.h"
+!c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc),plcl(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real tv(nloc,nd),tvp(nloc,nd)
+!c
+!c output
+      real cina(nloc),cinb(nloc),plfc(nloc)
+!c
+!c local variables
+      integer il,i,j,k
+      integer itop(nloc),ineg(nloc),ilow(nloc)
+      integer ifst(nloc),isublcl(nloc)
+      logical lswitch(nloc),lswitch1(nloc),lswitch2(nloc)
+      logical exist_lfc(nloc)
+      real dpmax
+      real deltap,dcin
+      real buoylcl(nloc),tvplcl(nloc),tvlcl(nloc)
+      real p0(nloc)
+      real buoyz(nloc), buoy(nloc,nd)
+!c
+!c-------------------------------------------------------------
+!c     Initialization
+!c-------------------------------------------------------------
+      do il = 1,ncum
+       cina(il) = 0.
+       cinb(il) = 0.
+      enddo
+!c
+!c--------------------------------------------------------------
+!c      Recompute buoyancies
+!c--------------------------------------------------------------
+      DO k = 1,nd
+        DO il = 1,ncum
+!      print*,'tvp tv=',tvp(il,k),tv(il,k)
+          buoy(il,k) = tvp(il,k) - tv(il,k)
+        ENDDO
+      ENDDO
+!c---------------------------------------------------------------
+!c
+!c   calcul de la flottabilite a LCL (Buoylcl)
+!c     ifst = first P-level above lcl
+!c     isublcl = highest P-level below lcl.
+!c---------------------------------------------------------------
+!c
+      do il = 1,ncum
+       TVPlcl(il) = TVP(il,1)*(Plcl(il)/P(il,1))**(2./7.) !For dry air, R/Cp=2/7
+      enddo
+!c
+      do il = 1,ncum
+       IF (Plcl(il) .GT. P(il,icb(il))) THEN
+        ifst(il) = icb(il)
+        isublcl(il) = icb(il)-1
+       ELSE
+        ifst(il) = icb(il)+1
+        isublcl(il) = icb(il)
+       ENDIF
+      enddo
+!c
+      do il = 1,ncum
+       TVlcl(il)=TV(il,ifst(il)-1)+(TV(il,ifst(il))-TV(il,ifst(il)-1))               &
+       &   *(Plcl(il)-P(il,ifst(il)-1))/(P(il,ifst(il))-P(il,ifst(il)-1))
+      enddo
+!c
+      do il = 1,ncum
+        BUOYlcl(il) = TVPlcl(il)-TVlcl(il)
+      enddo
+!c
+!c---------------------------------------------------------------
+!c premiere couche contenant un  niveau de flotabilite positive
+!c et premiere couche contenant un  niveau de flotabilite negative
+!c  au dessus du niveau de condensation
+!c---------------------------------------------------------------
+      do il = 1,ncum
+        itop(il) =nl-1
+        ineg(il) = nl-1
+        exist_lfc(il) = .FALSE.
+      enddo
+      do 100 k=nl-1,1,-1
+       do 110 il=1,ncum
+        if (k .ge. ifst(il)) then
+         if (buoy(il,k) .gt. 0.) then
+          itop(il)=k
+          exist_lfc(il) = .TRUE.
+         else
+          ineg(il)=k
+         endif
+        endif
+110    continue
+100   continue
+!c
+!c---------------------------------------------------------------
+!c When there is no positive buoyancy level, set Plfc, Cina and Cinb
+!c to arbitrary extreme values.
+!c---------------------------------------------------------------
+      DO il = 1,ncum
+       IF (.NOT.exist_lfc(il)) THEN
+         Plfc(il) = 1.111
+         Cinb(il) = -1111.
+         Cina(il) = -1112.
+       ENDIF
+      ENDDO
+!c
+!c
+!c---------------------------------------------------------------
+!c -- Two cases : BUOYlcl >= 0 and BUOYlcl < 0.
+!c---------------------------------------------------------------
+!C
+!C--------------------
+!C -- 1.0 BUOYlcl >=0.
+!C--------------------
+!c
+      DPMAX = 50.
+      DO il = 1,ncum
+        lswitch1(il)=BUOYlcl(il) .GE. 0. .AND. exist_lfc(il)
+        lswitch(il) = lswitch1(il)
+      ENDDO
+!c
+!c 1.1 No inhibition case
+!c ----------------------
+!C   If buoyancy is positive at LCL and stays positive over a large enough
+!C pressure interval (=DPMAX), inhibition is set to zero,
+!C
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        IF (P(il,ineg(il)) .LT. P(il,icb(il))-DPmax) THEN
+          PLFC(il) = Plcl(il)
+          Cina(il) = 0.
+          Cinb(il) = 0.
+        ENDIF
+      ENDIF
+      ENDDO
+!c
+!c 1.2 Upper inhibition only case
+!c ------------------------------
+      DO il = 1,ncum
+        lswitch2(il)= P(il,ineg(il)) .GE. P(il,icb(il))-DPmax
+        lswitch(il) = lswitch1(il) .AND. lswitch2(il)
+      ENDDO
+!c
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+          Cinb(il) = 0.
+!c
+!c 1.2.1  Calcul de la pression du niveau de flot. nulle juste au-dessus de LCL
+!c ---------------------------------------------------------------------------
+         IF (ineg(il) .GT. isublcl(il)+1) THEN
+!C In order to get P0, one may interpolate linearly buoyancies
+!C  between P(ineg) and P(ineg-1).
+        P0(il)=(buoy(il,ineg(il))*P(il,ineg(il)-1)                                   &
+       &         -buoy(il,ineg(il)-1)*P(il,ineg(il)))                                &
+       &           / (buoy(il,ineg(il))-buoy(il,ineg(il)-1))
+         ELSE
+!C In order to get P0, one has to interpolate between P(ineg) and Plcl.
+        P0(il) = (BUOY(il,ineg(il))*Plcl(il)-BUOYlcl(il)*P(il,ineg(il)))             &
+       &          /(BUOY(il,ineg(il))     -BUOYlcl(il))
+         ENDIF
+      ENDIF
+      ENDDO
+!c
+!c 1.2.2 Recompute itop (=1st layer with positive buoyancy above ineg)
+!c -------------------------------------------------------------------
+      do il = 1,ncum
+      IF (lswitch(il)) THEN
+        itop(il) =nl-1
+      ENDIF
+      enddo
+!c
+      do  k=nl,1,-1
+       do  il=1,ncum
+       IF (lswitch(il)) THEN
+        if (k .ge. ineg(il) .and. buoy(il,k) .gt. 0) then
+         itop(il)=k
+        endif
+       ENDIF
+       enddo
+      enddo
+!c
+!c 1.2.3 Computation of PLFC
+!c -------------------------
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        PLFC(il)=(buoy(il,itop(il))*P(il,itop(il)-1)                                 &
+       &           -buoy(il,itop(il)-1)*P(il,itop(il)))                              &
+       &           / (buoy(il,itop(il))-buoy(il,itop(il)-1))
+      ENDIF
+      ENDDO
+!c
+!c 1.2.4 Computation of CINA
+!c -------------------------
+!c
+!C   Upper part of CINA : integral from P(itop-1) to Plfc
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P(il,itop(il)-1)-Plfc(il)
+        dcin = RD*BUOY(il,itop(il)-1)*deltap                                         &
+       &        / (P(il,itop(il)-1)+Plfc(il))
+        CINA(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+!c
+!C   Middle part of CINA : integral from P(ineg) to P(itop-1)
+      DO k = 1,nl
+        DO il = 1,ncum
+        IF (lswitch(il)) THEN
+          IF (k .GE. ineg(il) .AND. k .LE. itop(il)-2) THEN
+           deltap = P(il,k)-P(il,k+1)
+           dcin = 0.5*RD*(BUOY(il,k)+BUOY(il,k+1))*deltap/PH(il,k+1)
+           CINA(il) = CINA(il) + min(0.,dcin)
+          ENDIF
+        ENDIF
+        ENDDO
+      ENDDO
+!c
+!C   Lower part of CINA : integral from P0 to P(ineg)
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P0(il)-P(il,ineg(il))
+        dcin = RD*BUOY(il,ineg(il))*deltap/(P(il,ineg(il))+P0(il))
+        CINA(il) = CINA(il) + min(0.,dcin)
+      ENDIF
+      ENDDO
+!c
+!C
+!C ------------------
+!C -- 2.0 BUOYlcl <0.
+!C ------------------
+!C
+      DO il = 1,ncum
+        lswitch1(il)=BUOYlcl(il) .LT. 0. .AND. exist_lfc(il)
+        lswitch(il) = lswitch1(il)
+      ENDDO
+!c
+!c 2.0.1 Premiere  couche ou la flotabilite est negative au dessus du sol
+!c ----------------------------------------------------
+!c    au cas ou elle existe  sinon ilow=1 (nk apres)
+!c      on suppose que la parcelle part de la premiere couche
+!c
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+       ilow(il)=1
+      ENDIF
+      ENDDO
+!c
+      do 200 k=nl,1,-1
+        DO il = 1,ncum
+        IF (lswitch(il) .AND. k .LE.icb(il)-1) THEN
+         if(buoy(il,k).lt. 0.) then
+           ilow(il) = k
+          endif
+        ENDIF
+        ENDDO
+ 200  continue
+
+!c 2.0.2  Calcul de la pression du niveau de flot. nulle sous le nuage
+!c ----------------------------------------------------
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+       if(ilow(il).gt. 1) then
+         P0(il)=(buoy(il,ilow(il))*P(il,ilow(il)-1)                                  &
+       &          -buoy(il,ilow(il)-1)*P(il,ilow(il)))                               &
+       &            / (buoy(il,ilow(il))-buoy(il,ilow(il)-1))
+         BUOYz(il) = 0.
+       else
+         P0(il) = P(il,1)
+         BUOYz(il) = BUOY(il,1)
+       endif
+      ENDIF
+      ENDDO
+!c
+!C 2.1. Computation of CINB
+!C -----------------------
+!c
+      DO il = 1,ncum
+        lswitch2(il)= (isublcl(il) .EQ. 1 .AND. ilow(il) .EQ. 1)                     &
+       &                  .OR.(isublcl(il) .EQ. ilow(il)-1)
+        lswitch(il) = lswitch1(il) .AND. lswitch2(il)
+      ENDDO
+!cc      IF (    (isublcl .EQ. 1 .AND. ilow .EQ. 1)
+!cc     $    .OR.(isublcl .EQ. ilow-1)) THEN
+!c
+!c 2.1.1 First case : Plcl just above P0
+!c -------------------------------------
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P0(il)-Plcl(il)
+        dcin = RD*(BUOYz(il)+BUOYlcl(il))*deltap/(P0(il)+Plcl(il))
+        CINB(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+!c
+      DO il = 1,ncum
+        lswitch(il) = lswitch1(il) .AND. .NOT. lswitch2(il)
+      ENDDO
+!cc      ELSE
+!c
+!c 2.1.2 Second case : there is at least one P-level between P0 and Plcl
+!c ---------------------------------------------------------------------
+!c
+!C   Lower part of CINB : integral from P0 to P(ilow)
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P0(il)-P(il,ilow(il))
+        dcin = RD*(BUOYz(il)+BUOY(il,ilow(il)))*deltap                               &
+       &         /(P0(il)+P(il,ilow(il)))
+        CINB(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+!c
+!c
+!C  Middle part of CINB : integral from P(ilow) to P(isublcl)
+!cc      DO k = ilow,isublcl-1
+      DO k = 1,nl
+        DO il = 1,ncum
+        IF (lswitch(il)                                                              &
+       &   .AND. k .GE. ilow(il) .AND. k .LE. isublcl(il)-1) THEN
+          deltap = P(il,k)-P(il,k+1)
+          dcin = 0.5*RD*(BUOY(il,k)+BUOY(il,k+1))*deltap/PH(il,k+1)
+          CINB(il) = CINB(il) + min(0.,dcin)
+        ENDIF
+        ENDDO
+      ENDDO
+!c
+!C  Upper part of CINB : integral from P(isublcl) to Plcl
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P(il,isublcl(il)) - Plcl(il)
+        dcin = RD*(BUOY(il,isublcl(il))+BUOYlcl(il))*deltap                          &
+       &         /(P(il,isublcl(il))+Plcl(il))
+        CINB(il) = CINB(il)+min(0.,dcin)
+      ENDIF
+      ENDDO
+!C
+!c
+!cc      ENDIF
+!c
+!C 2.2 Computation of CINA
+!c ---------------------
+!c
+      DO il = 1,ncum
+        lswitch2(il)= Plcl(il) .GT. P(il,itop(il)-1)
+        lswitch(il) = lswitch1(il) .AND. lswitch2(il)
+      ENDDO
+!c
+!c 2.2.1 FIrst case : Plcl > P(itop-1)
+!C ---------------------------------
+!C In order to get Plfc, one may interpolate linearly buoyancies
+!C  between P(itop) and P(itop-1).
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        PLFC(il)=(buoy(il,itop(il))*P(il,itop(il)-1)                                 &
+       &           -buoy(il,itop(il)-1)*P(il,itop(il)))                              &
+       &           / (buoy(il,itop(il))-buoy(il,itop(il)-1))
+      ENDIF
+      ENDDO
+!c
+!C   Upper part of CINA : integral from P(itop-1) to Plfc
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = P(il,itop(il)-1)-Plfc(il)
+        dcin = RD*BUOY(il,itop(il)-1)*deltap                                         &
+       &         /(P(il,itop(il)-1)+Plfc(il))
+        CINA(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+!c
+!C   Middle part of CINA : integral from P(icb+1) to P(itop-1)
+      DO k = 1,nl
+        DO il = 1,ncum
+        IF (lswitch(il)                                                              &
+       &     .AND. k .GE. icb(il)+1 .AND. k .LE. itop(il)-2) THEN
+          deltap = P(il,k)-P(il,k+1)
+          dcin = 0.5*RD*(BUOY(il,k)+BUOY(il,k+1))*deltap/PH(il,k+1)
+          CINA(il) = CINA(il) + min(0.,dcin)
+        ENDIF
+        ENDDO
+      ENDDO
+!c
+!C   Lower part of CINA : integral from Plcl to P(icb+1)
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        IF (Plcl(il) .GT. P(il,icb(il))) THEN
+          IF (icb(il) .LT. itop(il)-1) THEN
+            deltap = P(il,icb(il))-P(il,icb(il)+1)
+            dcin = 0.5*RD*(BUOY(il,icb(il))+BUOY(il,icb(il)+1))                      &
+       &                   *deltap/PH(il,icb(il)+1)
+            CINA(il) = CINA(il)+min(0.,dcin)
+          ENDIF
+!c
+          deltap = Plcl(il)-P(il,icb(il))
+          dcin = RD*(BUOYlcl(il)+BUOY(il,icb(il)))                                   &
+       &              *deltap/(Plcl(il)+P(il,icb(il)))
+          CINA(il) = CINA(il)+min(0.,dcin)
+        ELSE
+          deltap = Plcl(il)-P(il,icb(il)+1)
+          dcin = RD*(BUOYlcl(il)+BUOY(il,icb(il)+1))                                 &
+       &             *deltap/(Plcl(il)+P(il,icb(il)+1))
+          CINA(il) = CINA(il)+min(0.,dcin)
+        ENDIF
+      ENDIF
+      ENDDO
+!c
+      DO il = 1,ncum
+        lswitch(il) = lswitch1(il) .AND. .NOT. lswitch2(il)
+      ENDDO
+!cc      ELSE
+!c
+!c 2.2.2 Second case : Plcl lies between P(itop-1) and P(itop);
+!C ----------------------------------------------------------
+!C In order to get Plfc, one has to interpolate between P(itop) and Plcl.
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        PLFC(il) =                                                                   &
+       &    (BUOY(il,itop(il))*Plcl(il)-BUOYlcl(il)*P(il,itop(il)))                  &
+       &          /(BUOY(il,itop(il))     -BUOYlcl(il))
+      ENDIF
+      ENDDO
+!c
+      DO il = 1,ncum
+      IF (lswitch(il)) THEN
+        deltap = Plcl(il)-Plfc(il)
+        dcin = RD*BUOYlcl(il)*deltap/(Plcl(il)+Plfc(il))
+        CINA(il) = min(0.,dcin)
+      ENDIF
+      ENDDO
+!cc      ENDIF
+!c
+
+
+      RETURN
+      END SUBROUTINE cv3_cine
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_inip.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_inip.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_inip.F	(revision 17)
@@ -0,0 +1,120 @@
+        SUBROUTINE cv3_inip()
+***************************************************************
+*                                                             *
+* CV3_INIP Lecture des choix de lois de probabilité de mélange*
+*          et calcul de leurs coefficients normalisés.        *
+*                                                             *
+* written by   : Jean-Yves Grandpeix, 06/06/2006, 19.39.27    *
+* modified by :                                               *
+***************************************************************
+*
+#include "YOMCST2.h"
+c
+c      INTEGER iflag_mix
+      include 'iniprint.h'
+
+      CHARACTER (LEN=20) :: modname='cv3_inip'
+      CHARACTER (LEN=80) :: abort_message
+
+c
+c --   Mixing probability distribution functions
+c
+      real Qcoef1,Qcoef2,QFF,QFFF,Qmix,Rmix,Qmix1,Rmix1,Qmix2,Rmix2,F
+      Qcoef1(F) = tanh(F/gammas)
+      Qcoef2(F) = ( tanh(F/gammas) + gammas *
+     $            log(cosh((1.- F)/gammas)/cosh(F/gammas)))
+      QFF(F) = Max(Min(F,1.),0.)
+      QFFF(F) = Min(QFF(F),scut)
+      Qmix1(F) = ( tanh((QFF(F) - Fmax)/gammas)+Qcoef1max )/
+     $           Qcoef2max
+      Rmix1(F) = ( gammas*log(cosh((QFF(F)-Fmax)/gammas))
+     1             +QFF(F)*Qcoef1max ) / Qcoef2max
+      Qmix2(F) = -Log(1.-QFFF(F))/scut
+      Rmix2(F) = (QFFF(F)+(1.-QFF(F))*Log(1.-QFFF(F)))/scut
+      Qmix(F) = qqa1*Qmix1(F) + qqa2*Qmix2(F)
+      Rmix(F) = qqa1*Rmix1(F) + qqa2*Rmix2(F)
+C
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+C
+C===========================================================================
+C    	READ IN PARAMETERS FOR THE MIXING DISTRIBUTION
+C	AND PASS THESE THROUGH A COMMON BLOCK TO SUBROUTINE CONVECT etc.
+C       (Written by V.T.J. Phillips, 20-30/Jan/99)
+C===========================================================================
+C
+C   line 1:  a flag (0 or 1) to decide whether P(F) = 1 or the general P(F) is to be
+C         used, followed by SCUT, which is the cut-off value of F in CONVECT
+C   line 2:  blank
+C   line 3:  the coefficients for the linear combination of P(F)s to
+C                 make the general P(F)
+C   line 4:  blank
+C   line 5:  gammas, Fmax for the cosh^2 component of P(F)
+C   line 6:  blank
+C   line 7:  alphas for the 1st irrational P(F)
+C   line 8:  blank
+C   line 9:  betas  for the 2nd irrational P(F)
+C
+
+cc$$$        open(57,file='parameter_mix.data')
+cc$$$
+cc$$$        read(57,*) iflag_mix, scut
+cc$$$        read(57,*)
+cc$$$        if(iflag_mix .gt. 0) then
+cc$$$	      read(57,*) qqa1, qqa2
+cc$$$              read(57,*)
+cc$$$              read(57,*) gammas, Fmax
+cc$$$              read(57,*)
+cc$$$              read(57,*) alphas
+cc$$$         endif
+cc$$$	 close(57)
+
+c
+      if(iflag_mix .gt. 0) then
+c
+c--      Normalize Pdf weights
+c
+        sumcoef=qqa1+qqa2
+        qqa1=qqa1/sumcoef
+        qqa2=qqa2/sumcoef
+c
+        Qcoef1max = Qcoef1(Fmax)
+        Qcoef2max = Qcoef2(Fmax)
+c
+        sigma = 0.
+        aire=0.0
+        pdf=0.0
+        mu=0.0
+        df = 0.0001
+c
+c        do ff = 0.0 + df, 1.0 - 2.*df, df
+         ff=df
+         dowhile ( ff .le. 1.0 - 2.*df )
+              pdf = (Qmix(ff+df) -  Qmix(ff)) * (1.-ff) / df
+              aire=aire+(Qmix(ff+df) - Qmix(ff)) * (1.-ff)
+              mu = mu + pdf * ff * df
+         IF(prt_level>9)WRITE(lunout,*)                                 &
+     &               pdf,  Qmix(ff), aire, ff
+         ff=ff+df
+         enddo
+c
+c         do ff=0.0+df,1.0 - 2.*df,df
+          ff=df
+          dowhile ( ff .le. 1.0 - 2.*df )
+              pdf = (Qmix(ff+df)- Qmix(ff)) * (1.-ff) / df
+              sigma = sigma+pdf*(ff - mu)*(ff - mu)*df
+         ff=ff+df
+         enddo
+         sigma = sqrt(sigma)
+c
+        if (abs(aire-1.0) .gt. 0.02) then
+            write(lunout,*)'WARNING:: AREA OF MIXING PDF IS::', aire
+            abort_message = ''
+            CALL abort_gcm (modname,abort_message,1)
+        else
+            print *,'Area, mean & std deviation are ::', aire,mu,sigma
+        endif
+      endif     !  (iflag_mix .gt. 0)
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_inip.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_inip.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_inip.F90	(revision 17)
@@ -0,0 +1,120 @@
+        SUBROUTINE cv3_inip()
+!***************************************************************
+!*                                                             *
+!* CV3_INIP Lecture des choix de lois de probabilité de mélange*
+!*          et calcul de leurs coefficients normalisés.        *
+!*                                                             *
+!* written by   : Jean-Yves Grandpeix, 06/06/2006, 19.39.27    *
+!* modified by :                                               *
+!***************************************************************
+!*
+#include "YOMCST2.h"
+!c
+!c      INTEGER iflag_mix
+      include 'iniprint.h'
+
+      CHARACTER (LEN=20) :: modname='cv3_inip'
+      CHARACTER (LEN=80) :: abort_message
+
+!c
+!c --   Mixing probability distribution functions
+!c
+      real Qcoef1,Qcoef2,QFF,QFFF,Qmix,Rmix,Qmix1,Rmix1,Qmix2,Rmix2,F
+      Qcoef1(F) = tanh(F/gammas)
+      Qcoef2(F) = ( tanh(F/gammas) + gammas *                                        &
+       &            log(cosh((1.- F)/gammas)/cosh(F/gammas)))
+      QFF(F) = Max(Min(F,1.),0.)
+      QFFF(F) = Min(QFF(F),scut)
+      Qmix1(F) = ( tanh((QFF(F) - Fmax)/gammas)+Qcoef1max )/                         &
+       &           Qcoef2max
+      Rmix1(F) = ( gammas*log(cosh((QFF(F)-Fmax)/gammas))                            &
+       &             +QFF(F)*Qcoef1max ) / Qcoef2max
+      Qmix2(F) = -Log(1.-QFFF(F))/scut
+      Rmix2(F) = (QFFF(F)+(1.-QFF(F))*Log(1.-QFFF(F)))/scut
+      Qmix(F) = qqa1*Qmix1(F) + qqa2*Qmix2(F)
+      Rmix(F) = qqa1*Rmix1(F) + qqa2*Rmix2(F)
+!C
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!c
+!C
+!C===========================================================================
+!C    	READ IN PARAMETERS FOR THE MIXING DISTRIBUTION
+!C	AND PASS THESE THROUGH A COMMON BLOCK TO SUBROUTINE CONVECT etc.
+!C       (Written by V.T.J. Phillips, 20-30/Jan/99)
+!C===========================================================================
+!C
+!C   line 1:  a flag (0 or 1) to decide whether P(F) = 1 or the general P(F) is to be
+!C         used, followed by SCUT, which is the cut-off value of F in CONVECT
+!C   line 2:  blank
+!C   line 3:  the coefficients for the linear combination of P(F)s to
+!C                 make the general P(F)
+!C   line 4:  blank
+!C   line 5:  gammas, Fmax for the cosh^2 component of P(F)
+!C   line 6:  blank
+!C   line 7:  alphas for the 1st irrational P(F)
+!C   line 8:  blank
+!C   line 9:  betas  for the 2nd irrational P(F)
+!C
+
+!cc$$$        open(57,file='parameter_mix.data')
+!cc$$$
+!cc$$$        read(57,*) iflag_mix, scut
+!cc$$$        read(57,*)
+!cc$$$        if(iflag_mix .gt. 0) then
+!cc$$$	      read(57,*) qqa1, qqa2
+!cc$$$              read(57,*)
+!cc$$$              read(57,*) gammas, Fmax
+!cc$$$              read(57,*)
+!cc$$$              read(57,*) alphas
+!cc$$$         endif
+!cc$$$	 close(57)
+
+!c
+      if(iflag_mix .gt. 0) then
+!c
+!c--      Normalize Pdf weights
+!c
+        sumcoef=qqa1+qqa2
+        qqa1=qqa1/sumcoef
+        qqa2=qqa2/sumcoef
+!c
+        Qcoef1max = Qcoef1(Fmax)
+        Qcoef2max = Qcoef2(Fmax)
+!c
+        sigma = 0.
+        aire=0.0
+        pdf=0.0
+        mu=0.0
+        df = 0.0001
+!c
+!c        do ff = 0.0 + df, 1.0 - 2.*df, df
+         ff=df
+         DO WHILE ( ff .le. 1.0 - 2.*df )
+              pdf = (Qmix(ff+df) -  Qmix(ff)) * (1.-ff) / df
+              aire=aire+(Qmix(ff+df) - Qmix(ff)) * (1.-ff)
+              mu = mu + pdf * ff * df
+         IF(prt_level>9)WRITE(lunout,*)                                 &
+       &               pdf,  Qmix(ff), aire, ff
+         ff=ff+df
+         enddo
+!c
+!c         do ff=0.0+df,1.0 - 2.*df,df
+          ff=df
+          DO WHILE ( ff .le. 1.0 - 2.*df )
+              pdf = (Qmix(ff+df)- Qmix(ff)) * (1.-ff) / df
+              sigma = sigma+pdf*(ff - mu)*(ff - mu)*df
+         ff=ff+df
+         enddo
+         sigma = sqrt(sigma)
+!c
+        if (abs(aire-1.0) .gt. 0.02) then
+            write(lunout,*)'WARNING:: AREA OF MIXING PDF IS::', aire
+            abort_message = ''
+            CALL abort_gcm (modname,abort_message,1)
+        else
+            print *,'Area, mean & std deviation are ::', aire,mu,sigma
+        endif
+      endif     !  (iflag_mix .gt. 0)
+
+      RETURN
+      END SUBROUTINE cv3_inip
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_mixscale.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_mixscale.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_mixscale.F	(revision 17)
@@ -0,0 +1,29 @@
+        SUBROUTINE cv3_mixscale(nloc,ncum,na,ment,m)
+***************************************************************
+*                                                             *
+* CV3_MIXSCALE                                                *
+*                                                             *
+*                                                             *
+* written by   : Jean-Yves Grandpeix, 30/05/2003, 16.34.37    *
+* modified by :                                               *
+***************************************************************
+*
+      implicit none
+
+#include "cv3param.h"
+
+      integer nloc,ncum,na
+      integer i,j,il
+      real ment(nloc,na,na),m(nloc,na)
+c
+      do 100 j=1,nl
+        do 101 i=1,nl
+          do 102 il=1,ncum
+             ment(il,i,j) = m(il,i)*ment(il,i,j)
+102      continue
+101    continue
+100   continue
+
+c
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_mixscale.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_mixscale.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_mixscale.F90	(revision 17)
@@ -0,0 +1,29 @@
+        SUBROUTINE cv3_mixscale(nloc,ncum,na,ment,m)
+!***************************************************************
+!*                                                             *
+!* CV3_MIXSCALE                                                *
+!*                                                             *
+!*                                                             *
+!* written by   : Jean-Yves Grandpeix, 30/05/2003, 16.34.37    *
+!* modified by :                                               *
+!***************************************************************
+!*
+      implicit none
+
+#include "cv3param.h"
+
+      integer nloc,ncum,na
+      integer i,j,il
+      real ment(nloc,na,na),m(nloc,na)
+!c
+      do 100 j=1,nl
+        do 101 i=1,nl
+          do 102 il=1,ncum
+             ment(il,i,j) = m(il,i)*ment(il,i,j)
+102      continue
+101    continue
+100   continue
+
+!c
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_routines.F	(revision 17)
@@ -0,0 +1,3746 @@
+!
+! $Id: cv3_routines.F 1795 2013-07-18 08:20:28Z emillour $
+!
+c
+c
+      SUBROUTINE cv3_param(nd,delt)
+      implicit none
+
+c------------------------------------------------------------
+c Set parameters for convectL for iflag_con = 3 
+c------------------------------------------------------------
+
+C
+C   ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
+C   ***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
+C   ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***     
+C   ***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***     
+C   ***                        OF CLOUD                         ***
+C
+C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
+C   ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+C   ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
+C   ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
+C
+C   ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+C   ***                     IT MUST BE LESS THAN 0              ***
+
+#include "cv3param.h"
+#include "conema3.h"
+
+      integer nd
+      real delt ! timestep (seconds)
+
+
+      CHARACTER (LEN=20) :: modname='cv3_param'
+      CHARACTER (LEN=80) :: abort_message
+
+      LOGICAL,SAVE :: first=.true.
+c$OMP THREADPRIVATE(first)
+
+c noff: integer limit for convection (nd-noff)
+c minorig: First level of convection
+
+c -- limit levels for convection:
+
+      noff    = 1
+      minorig = 1
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+      IF (first) THEN
+
+c -- "microphysical" parameters:
+      sigdz=0.01
+      spfac  = 0.15
+      pbcrit = 150.0
+      ptcrit = 500.0
+cIM beg: ajout fis. reglage ep
+      flag_epKEorig=1
+      elcrit=0.0003
+      tlcrit=-55.0
+cIM lu dans physiq.def via conf_phys.F90     epmax  = 0.993
+
+      omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
+
+c -- misc:
+
+      dtovsh = -0.2 ! dT for overshoot
+      dpbase = -40. ! definition cloud base (400m above LCL)
+ccc      dttrig = 5.   ! (loose) condition for triggering
+      dttrig = 10.   ! (loose) condition for triggering
+      flag_wb=1
+      wbmax = 6.   ! (m/s) adiab updraught speed at LFC (used in cv3p1_closure)
+
+c -- rate of approach to quasi-equilibrium:
+
+      dtcrit = -2.0
+      tau = 8000.
+
+c -- interface cloud parameterization:
+
+      delta=0.01  ! cld
+
+c -- interface with boundary-layer (gust factor): (sb)
+
+      betad=10.0   ! original value (from convect 4.3)
+
+       OPEN(99,file='conv_param.data',status='old',
+     $          form='formatted',err=9999)
+      READ(99,*,end=9998) dpbase
+      READ(99,*,end=9998) pbcrit
+      READ(99,*,end=9998) ptcrit
+      READ(99,*,end=9998) sigdz
+      READ(99,*,end=9998) spfac
+      READ(99,*,end=9998) tau
+      READ(99,*,end=9998) flag_wb
+      READ(99,*,end=9998) wbmax
+9998  Continue
+      CLOSE(99)
+9999  Continue
+        WRITE(*,*)'dpbase=',dpbase
+        WRITE(*,*)'pbcrit=',pbcrit
+        WRITE(*,*)'ptcrit=',ptcrit
+        WRITE(*,*)'sigdz=',sigdz
+        WRITE(*,*)'spfac=',spfac
+        WRITE(*,*)'tau=',tau
+        WRITE(*,*)'flag_wb =',flag_wb
+        WRITE(*,*)'wbmax =',wbmax
+
+cIM Lecture du fichier ep_param.data
+      OPEN(79,file='ep_param.data',status='old',
+     $          form='formatted',err=7999)
+      READ(79,*,end=7998) flag_epKEorig
+      READ(79,*,end=7998) elcrit
+      READ(79,*,end=7998) tlcrit
+7998  Continue
+      CLOSE(79)
+7999  Continue
+      WRITE(*,*)'flag_epKEorig',flag_epKEorig
+      WRITE(*,*)'elcrit=',elcrit
+      WRITE(*,*)'tlcrit=',tlcrit
+cIM end: ajout fis. reglage ep
+
+       first = .false.
+      ENDIF
+
+      beta   = 1.0 - delt/tau
+      alpha1 = 1.5e-3
+cjyg    Correction bug alpha
+      alpha1  = alpha1*1.5
+      alpha  = alpha1 * delt/tau
+cjyg    Bug
+ccc increase alpha to compensate W decrease:
+cc      alpha  = alpha*1.5
+
+      return
+      end
+
+      SUBROUTINE cv3_prelim(len,nd,ndp1,t,q,p,ph
+     :                    ,lv,cpn,tv,gz,h,hm,th)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+! "ori": from convect4.3 (vectorized)
+! "convect3": to be exactly consistent with convect3
+!=====================================================================
+
+c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+      real th(len,nd)
+
+c local variables:
+      integer k, i
+      real rdcp
+      real tvx,tvy ! convect3
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+
+c ori      do 110 k=1,nlp
+! abderr     do 110 k=1,nl ! convect3
+       do 110 k=1,nlp
+      
+        do 100 i=1,len
+cdebug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          lv(i,k)= lv0-clmcpv*(t(i,k)-273.15)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+c ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k))
+          rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k)
+          th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+c ori      do 140 k=2,nlp
+      do 140 k=2,nl ! convect3
+        do 130 i=1,len
+        tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k))       !convect3
+        tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
+        gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy)     !convect3
+     &          *(p(i,k-1)-p(i,k))/ph(i,k)      !convect3
+c
+cc        print *,' gz(',k,')',gz(i,k),' tvx',tvx,' tvy ',tvy
+c
+c ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+c ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+c ori      do 170 k=1,nlp
+      do 170 k=1,nl ! convect3
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_feed(len,nd,t,q,u,v,p,ph,hm,gz
+     :                  ,p1feed,p2feed,wght
+     :                  ,wghti,tnk,thnk,qnk,qsnk,unk,vnk
+     :                  ,cpnk,hnk,nk,icb,icbmax,iflag,gznk,plcl)
+      implicit none
+
+C================================================================
+C Purpose: CONVECTIVE FEED
+C
+C Main differences with cv_feed:
+C   - ph added in input
+C	- here, nk(i)=minorig
+C	- icb defined differently (plcl compared with ph instead of p)
+C
+C Main differences with convect3:
+C 	- we do not compute dplcldt and dplcldr of CLIFT anymore 
+C	- values iflag different (but tests identical)
+C   - A,B explicitely defined (!...)
+C================================================================
+
+#include "cv3param.h"
+#include "cvthermo.h"
+
+c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), p(len,nd)
+      real u(len,nd), v(len,nd)
+      real hm(len,nd), gz(len,nd)
+      real ph(len,nd+1)
+      real p1feed(len)
+c,  wght(len)
+      real wght(nd)
+c input-output
+      real p2feed(len)
+c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+c      real   wghti(len)
+      real wghti(len,nd)
+      real   tnk(len), thnk(len), qnk(len), qsnk(len)
+      real   unk(len), vnk(len)
+      real   cpnk(len), hnk(len), gznk(len)
+      real   plcl(len)
+
+c local variables:
+      integer i, k, iter, niter
+      integer ihmin(len)
+      real work(len)
+      real pup(len),plo(len),pfeed(len)
+      real plclup(len),plcllo(len),plclfeed(len)
+      real posit(len)
+      logical nocond(len)
+!
+!-------------------------------------------------------------------
+! --- Origin level of ascending parcels for convect3:
+!-------------------------------------------------------------------
+
+         do 220 i=1,len
+          nk(i)=minorig
+          gznk(i)=gz(i,nk(i))
+  220    continue
+!
+!-------------------------------------------------------------------
+! --- Adjust feeding layer thickness so that lifting up to the top of
+! --- the feeding layer does not induce condensation (i.e. so that
+! --- plcl < p2feed).
+! --- Method : iterative secant method.
+!-------------------------------------------------------------------
+!
+c 1- First bracketing of the solution : ph(nk+1), p2feed
+c
+c 1.a- LCL associated to p2feed
+      do i = 1,len
+        pup(i) = p2feed(i)
+      enddo
+         call cv3_vertmix(len,nd,iflag,p1feed,pup,p,ph
+     i              ,t,q,u,v,wght
+     o              ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plclup)
+c 1.b- LCL associated to ph(nk+1)
+      do i = 1,len
+        plo(i) = ph(i,nk(i)+1)
+      enddo
+         call cv3_vertmix(len,nd,iflag,p1feed,plo,p,ph
+     i              ,t,q,u,v,wght
+     o              ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plcllo)
+c 2- Iterations
+      niter = 5
+      do iter = 1,niter
+        do i = 1,len
+          plcllo(i) = min(plo(i),plcllo(i))
+          plclup(i) = max(pup(i),plclup(i))
+          nocond(i) = plclup(i).le.pup(i)
+        enddo
+        do i = 1,len
+          if(nocond(i)) then
+             pfeed(i)=pup(i)
+          else
+             pfeed(i) = (pup(i)*(plo(i)-plcllo(i))+
+     :                plo(i)*(plclup(i)-pup(i)))/
+     :            (plo(i)-plcllo(i)+plclup(i)-pup(i))
+          endif
+        enddo
+         call cv3_vertmix(len,nd,iflag,p1feed,pfeed,p,ph
+     i              ,t,q,u,v,wght
+     o              ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plclfeed)
+        do i = 1,len
+          posit(i) = (sign(1.,plclfeed(i)-pfeed(i))+1.)*0.5
+          if (plclfeed(i) .eq. pfeed(i)) posit(i) = 1.
+c- posit = 1 when lcl is below top of feeding layer (plclfeed>pfeed)
+c-               => pup=pfeed
+c- posit = 0 when lcl is above top of feeding layer (plclfeed<pfeed)
+c-               => plo=pfeed
+          pup(i) = posit(i)*pfeed(i) + (1.-posit(i))*pup(i)
+          plo(i) = (1.-posit(i))*pfeed(i) + posit(i)*plo(i)
+          plclup(i) = posit(i)*plclfeed(i) + (1.-posit(i))*plclup(i)
+          plcllo(i) = (1.-posit(i))*plclfeed(i) + posit(i)*plcllo(i)
+        enddo
+      enddo       !  iter
+      do i = 1,len
+        p2feed(i) = pfeed(i)
+        plcl(i) = plclfeed(i)
+      enddo
+!
+      do 175 i=1,len
+         cpnk(i)=cpd*(1.0-qnk(i))+cpv*qnk(i)
+         hnk(i)=gz(i,1)+cpnk(i)*tnk(i)
+ 175  continue
+!
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if( (     ( tnk(i).lt.250.0    )
+     &       .or.( qnk(i).le.0.0      ) )
+     &   .and.
+     &       ( iflag(i).eq.0) ) iflag(i)=7
+ 250   continue
+c
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+
+c@      do 270 i=1,len
+c@       icb(i)=nlm
+c@ 270  continue
+c@c
+c@      do 290 k=minorig,nl
+c@        do 280 i=1,len
+c@          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+c@     &    icb(i)=min(icb(i),k)
+c@ 280    continue
+c@ 290  continue
+c@c
+c@      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+c@ 300  continue
+
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+c la modification consiste a comparer plcl a ph et non a p:
+c icb est defini par :  ph(icb)<plcl<ph(icb-1)
+c@      do 290 k=minorig,nl
+      do 290 k=3,nl-1 ! modif pour que icb soit sup/egal a 2
+        do 280 i=1,len
+          if( ph(i,k).lt.plcl(i) ) icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+
+c     print*,'icb dans cv3_feed '
+c     write(*,'(64i2)') icb(2:len-1)
+c     call dump2d(64,43,'plcl dans cv3_feed ',plcl(2:len-1))
+
+      do 300 i=1,len
+c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+        if((icb(i).eq.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+
+      do 400 i=1,len
+        icb(i) = icb(i)-1 ! icb sup ou egal a 2
+ 400  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+c!        icbmax=max(icbmax,icb(i))
+       if (iflag(i).lt.7) icbmax=max(icbmax,icb(i)) ! sb Jun7th02
+ 310  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_undilute1(len,nd,t,qs,gz,plcl,p,icb,tnk,qnk,gznk
+     :                       ,tp,tvp,clw,icbs)
+      implicit none
+
+!----------------------------------------------------------------
+! Equivalent de TLIFT entre NK et ICB+1 inclus
+!
+! Differences with convect4:
+!		- specify plcl in input
+!       - icbs is the first level above LCL (may differ from icb)
+!       - in the iterations, used x(icbs) instead x(icb)
+!       - many minor differences in the iterations
+!		- tvp is computed in only one time
+!		- icbs: first level above Plcl (IMIN de TLIFT) in output
+!       - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
+!----------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+c inputs:
+      integer len, nd
+      integer icb(len)
+      real t(len,nd), qs(len,nd), gz(len,nd)
+      real tnk(len), qnk(len), gznk(len)
+      real p(len,nd)
+      real plcl(len) ! convect3
+
+c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+c local variables:
+      integer i, k
+      integer icb1(len), icbs(len), icbsmax2 ! convect3
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real ticb(len), gzicb(len)
+      real qsicb(len) ! convect3
+      real cpinv(len) ! convect3
+
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+        cpinv(i)=1./cpp(i)
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do i=1,len                      !convect3
+         icb1(i)=MAX(icb(i),2)          !convect3
+         icb1(i)=MIN(icb(i),nl)         !convect3
+c if icb is below LCL, start loop at ICB+1:
+c (icbs est le premier niveau au-dessus du LCL)
+         icbs(i)=icb1(i)                !convect3
+         if (plcl(i).lt.p(i,icb1(i))) then
+             icbs(i)=MIN(icbs(i)+1,nl)  !convect3
+         endif
+        enddo                           !convect3
+
+        do i=1,len                      !convect3
+         ticb(i)=t(i,icbs(i))           !convect3
+         gzicb(i)=gz(i,icbs(i))         !convect3
+         qsicb(i)=qs(i,icbs(i))         !convect3
+        enddo                           !convect3
+
+c
+c Re-compute icbsmax (icbsmax2):        !convect3
+c                                       !convect3
+      icbsmax2=2                        !convect3
+      do 310 i=1,len                    !convect3
+        icbsmax2=max(icbsmax2,icbs(i))  !convect3
+ 310  continue                          !convect3
+
+c initialization outputs:
+
+      do k=1,icbsmax2     ! convect3
+       do i=1,len         ! convect3
+        tp(i,k)  = 0.0    ! convect3
+        tvp(i,k) = 0.0    ! convect3
+        clw(i,k) = 0.0    ! convect3
+       enddo              ! convect3
+      enddo               ! convect3
+
+c tp and tvp below cloud base:
+
+        do 350 k=minorig,icbsmax2-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))*cpinv(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+c ori         qg=qs(i,icb(i))
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icbs(i))=(ah0(i)-gz(i,icbs(i))-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icbs(i))=qnk(i)-qg
+         clw(i,icbs(i))=max(0.0,clw(i,icbs(i)))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icbs(i))=tp(i,icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
+
+  360   continue
+c
+c ori      do 380 k=minorig,icbsmax2
+c ori       do 370 i=1,len
+c ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+c ori 370   continue
+c ori 380  continue
+c
+
+c -- The following is only for convect3:
+c
+c * icbs is the first level above the LCL:
+c    if plcl<p(icb), then icbs=icb+1
+c    if plcl>p(icb), then icbs=icb
+c
+c * the routine above computes tvp from minorig to icbs (included).
+c
+c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
+c    must be known. This is the case if icbs=icb+1, but not if icbs=icb.
+c
+c * therefore, in the case icbs=icb, we compute tvp at level icb+1
+c   (tvp at other levels will be computed in cv3_undilute2.F)
+c
+
+        do i=1,len
+         ticb(i)=t(i,icb(i)+1)
+         gzicb(i)=gz(i,icb(i)+1)
+         qsicb(i)=qs(i,icb(i)+1)
+        enddo
+
+        do 460 i=1,len
+         tg=ticb(i)
+         qg=qsicb(i) ! convect3
+cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+c
+c First iteration.
+c
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)         ! convect3
+     :      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          endif
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+c
+c Second iteration.
+c
+
+c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+c ori          s=1./s
+c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+c ori          tg=max(tg,35.0)
+cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+c ori          else
+c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori          end if
+c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+c ori c approximation here:
+c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+c convect3: no approximation:
+         tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg)
+     :                /(cpd+(cl-cpd)*qnk(i))
+
+c ori         clw(i,icb(i))=qnk(i)-qg
+c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icb(i)+1)=qnk(i)-qg
+         clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1))
+
+         rg=qg/(1.-qnk(i))
+c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
+
+  460   continue
+
+      return
+      end
+
+      SUBROUTINE cv3_trigger(len,nd,icb,plcl,p,th,tv,tvp,thnk,
+     o                pbase,buoybase,iflag,sig,w0)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!
+!	- computes the cloud base
+!   - triggering (crude in this version)
+!	- relaxation of sig and w0 when no convection
+!
+!	Caution1: if no convection, we set iflag=4 
+!              (it used to be 0 in convect3)
+!
+!	Caution2: at this stage, tvp (and thus buoy) are know up 
+!             through icb only!
+! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
+!-------------------------------------------------------------------
+
+#include "cv3param.h"
+
+c input:
+      integer len, nd
+      integer icb(len)
+      real plcl(len), p(len,nd)
+      real th(len,nd), tv(len,nd), tvp(len,nd)
+      real thnk(len)
+
+c output:
+      real pbase(len), buoybase(len)
+
+c input AND output:
+      integer iflag(len)
+      real sig(len,nd), w0(len,nd)
+
+c local variables:
+      integer i,k
+      real tvpbase, tvbase, tdif, ath, ath1
+
+c
+c ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
+c
+      do 100 i=1,len
+       pbase(i) = plcl(i) + dpbase
+       tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+     :         + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                          /(p(i,icb(i))-p(i,icb(i)+1))
+       tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1))
+     :                      /(p(i,icb(i))-p(i,icb(i)+1))
+     :        + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i))
+     :                        /(p(i,icb(i))-p(i,icb(i)+1))
+       buoybase(i) = tvpbase - tvbase
+100   continue 
+
+c
+c   ***   make sure that column is dry adiabatic between the surface  ***
+c   ***    and cloud base, and that lifted air is positively buoyant  ***
+c   ***                         at cloud base                         ***
+c   ***       if not, return to calling program after resetting       ***
+c   ***                        sig(i) and w0(i)                       ***
+c
+
+c oct3      do 200 i=1,len
+c oct3
+c oct3       tdif = buoybase(i)
+c oct3       ath1 = th(i,1)
+c oct3       ath  = th(i,icb(i)-1) - dttrig
+c oct3 
+c oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+c oct3         do 60 k=1,nl
+c oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+c oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
+c oct3            w0(i,k)  = beta*w0(i,k)
+c oct3   60    continue
+c oct3         iflag(i)=4 ! pour version vectorisee
+c oct3c convect3         iflag(i)=0
+c oct3cccc         return
+c oct3       endif
+c oct3
+c oct3200   continue
+ 
+c -- oct3: on reecrit la boucle 200 (pour la vectorisation)
+
+      do  60 k=1,nl
+      do 200 i=1,len
+
+       tdif = buoybase(i)
+       ath1 = thnk(i)
+       ath  = th(i,icb(i)-1) - dttrig
+
+       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+            sig(i,k) = AMAX1(sig(i,k),0.0)
+            w0(i,k)  = beta*w0(i,k)
+        iflag(i)=4 ! pour version vectorisee
+c convect3         iflag(i)=0
+       endif
+
+200   continue
+ 60   continue
+
+c fin oct3 --
+
+      return
+      end
+
+      SUBROUTINE cv3_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1
+     :    ,t1,q1,qs1,u1,v1,gz1,th1
+     :    ,tra1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     :    ,sig1,w01
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,pbase,buoybase
+     o    ,t,q,qs,u,v,gz,th
+     o    ,tra
+     o    ,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,sig,w0  )
+      implicit none
+
+#include "cv3param.h"
+      include 'iniprint.h'
+
+c inputs:
+      integer len,ncum,nd,ntra,nloc
+      integer iflag1(len),nk1(len),icb1(len),icbs1(len)
+      real plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real pbase1(len),buoybase1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+      real th1(len,nd)
+      real sig1(len,nd), w01(len,nd)
+      real tra1(len,nd,ntra)
+
+c outputs:
+c en fait, on a nloc=len pour l'instant (cf cv_driver)
+      integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc)
+      real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real pbase(nloc),buoybase(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real th(nloc,nd)
+      real sig(nloc,nd), w0(nloc,nd)
+      real tra(nloc,nd,ntra)
+
+c local variables:
+      integer i,k,nn,j
+
+      CHARACTER (LEN=20) :: modname='cv3_compress'
+      CHARACTER (LEN=80) :: abort_message
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        sig(nn,k)=sig1(i,k)
+        w0(nn,k)=w01(i,k)
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+        th(nn,k)=th1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+!AC!      do 121 j=1,ntra
+!AC!ccccc      do 111 k=1,nl+1
+!AC!      do 111 k=1,nd
+!AC!       nn=0
+!AC!      do 101 i=1,len
+!AC!      if(iflag1(i).eq.0)then
+!AC!       nn=nn+1
+!AC!       tra(nn,k,j)=tra1(i,k,j)
+!AC!      endif
+!AC! 101  continue
+!AC! 111  continue
+!AC! 121  continue
+
+      if (nn.ne.ncum) then
+         write(lunout,*)'strange! nn not equal to ncum: ',nn,ncum
+         abort_message = ''
+         CALL abort_gcm (modname,abort_message,1)
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      pbase(nn)=pbase1(i)
+      buoybase(nn)=buoybase1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      icbs(nn)=icbs1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      return
+      end
+
+      SUBROUTINE cv3_undilute2(nloc,ncum,nd,icb,icbs,nk
+     :                       ,tnk,qnk,gznk,hnk,t,q,qs,gz
+     :                       ,p,h,tv,lv,pbase,buoybase,plcl
+     o                       ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      implicit none
+
+C---------------------------------------------------------------------
+C Purpose:
+C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+C     &
+C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+C     &
+C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+C
+C Main differences convect3/convect4:
+C	- icbs (input) is the first level above LCL (may differ from icb)
+C	- many minor differences in the iterations
+C	- condensed water not removed from tvp in convect3
+C   - vertical profile of buoyancy computed here (use of buoybase)
+C   - the determination of inb is different
+C   - no inb1, only inb in output
+C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "conema3.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), icbs(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real hnk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+      real pbase(nloc), buoybase(nloc), plcl(nloc)
+
+c outputs:
+      integer inb(nloc)
+      real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd)
+      real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd)
+      real buoy(nloc,nd)
+
+c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac, pden
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+      integer iposit(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=spfac
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+         ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+cdebug     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+c ori	    if(k.ge.(icb(i)+1))then
+	    if(k.ge.(icbs(i)+1))then ! convect3
+	      tg=t(i,k)
+	      qg=qs(i,k)
+cdebug	      alv=lv0-clmcpv*(t(i,k)-t0)
+	      alv=lv0-clmcpv*(t(i,k)-273.15)
+c
+c First iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+           s=cpd*(1.-qnk(i))+cl*qnk(i)      ! convect3
+     :      +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
+	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+c ori	       s=1./s
+c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+c ori	       tg=max(tg,35.0)
+cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+c ori	       else
+c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+cdebug	       alv=lv0-clmcpv*(t(i,k)-t0)
+	       alv=lv0-clmcpv*(t(i,k)-273.15)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+
+c ori c approximation here:
+c ori        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+
+c convect3: no approximation:
+           tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+c ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+c convect3: (qg utilise au lieu du vrai mixing ratio rg):
+               tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+
+      if(flag_epKEorig.ne.1) THEN
+        do 320 k=1,nl ! convect3
+        do 310 i=1,ncum
+           pden=ptcrit-pbcrit
+           ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax
+           ep(i,k)=max(ep(i,k),0.0)
+           ep(i,k)=min(ep(i,k),epmax)
+           sigp(i,k)=spfac
+ 310    continue
+ 320    continue
+      else
+        do 325 k=1,nl
+        do 315 i=1,ncum
+          if(k.ge.(nk(i)+1))then
+              tca=tp(i,k)-t0
+              if(tca.ge.0.0)then
+               elacrit=elcrit
+              else
+                elacrit=elcrit*(1.0-tca/tlcrit)
+              endif
+              elacrit=max(elacrit,0.0)
+              ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+              ep(i,k)=max(ep(i,k),0.0 )
+              ep(i,k)=min(ep(i,k),epmax )
+              sigp(i,k)=spfac
+          endif
+ 315    continue
+ 325    continue
+      endif
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+c dans convect3, tvp est calcule en une seule fois, et sans retirer
+c l'eau condensee (~> reversible CAPE)
+c
+c ori      do 340 k=minorig+1,nl
+c ori        do 330 i=1,ncum
+c ori        if(k.ge.(icb(i)+1))then
+c ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+c ori        endif
+c ori 330    continue
+c ori 340  continue
+
+c ori      do 350 i=1,ncum
+c ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+c ori 350  continue
+
+      do 350 i=1,ncum       ! convect3
+       tp(i,nlp)=tp(i,nl)   ! convect3
+ 350  continue              ! convect3
+c
+c=====================================================================
+c  --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
+c=====================================================================
+
+c-- this is for convect3 only:
+
+c first estimate of buoyancy:
+
+      do 500 i=1,ncum
+       do 501 k=1,nl
+        buoy(i,k)=tvp(i,k)-tv(i,k)
+ 501   continue
+ 500  continue
+
+c set buoyancy=buoybase for all levels below base
+c for safety, set buoy(icb)=buoybase
+
+      do 505 i=1,ncum
+       do 506 k=1,nl
+        if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then
+         buoy(i,k)=buoybase(i)
+        endif
+ 506   continue
+c       buoy(icb(i),k)=buoybase(i)
+      buoy(i,icb(i))=buoybase(i)
+ 505  continue
+
+c-- end convect3
+
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
+c  --- LEVEL OF NEUTRAL BUOYANCY
+c=====================================================================
+c
+c-- this is for convect3 only:
+
+      do 510 i=1,ncum
+       inb(i)=nl-1
+       iposit(i) = nl
+ 510  continue
+
+c
+c--    iposit(i) = first level, above icb, with positive buoyancy
+      do k = 1,nl-1
+       do i = 1,ncum
+        if (k .ge. icb(i) .and. buoy(i,k) .gt. 0.) then
+          iposit(i) = min(iposit(i),k)
+        endif
+       enddo
+      enddo
+
+      do i = 1,ncum
+       if (iposit(i) .eq. nl) then
+         iposit(i) = icb(i)
+       endif
+      enddo
+
+      do 535 k=1,nl-1
+       do 530 i=1,ncum
+        if ((k.ge.iposit(i)).and.(buoy(i,k).lt.dtovsh)) then
+         inb(i)=MIN(inb(i),k)
+        endif
+ 530   continue
+ 535  continue
+c
+c-- end convect3
+
+c ori      do 510 i=1,ncum
+c ori        cape(i)=0.0
+c ori        capem(i)=0.0
+c ori        inb(i)=icb(i)+1
+c ori        inb1(i)=inb(i)
+c ori 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+c ori      call zilch(byp,ncum)
+c ori      do 515 i=1,ncum
+c ori        lcape(i)=.true.
+c ori 515  continue
+c ori      do 530 k=minorig+1,nl-1
+c ori        do 520 i=1,ncum
+c ori          if(cape(i).lt.0.0)lcape(i)=.false.
+c ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
+c ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c ori            cape(i)=cape(i)+by
+c ori            if(by.ge.0.0)inb1(i)=k+1
+c ori            if(cape(i).gt.0.0)then
+c ori              inb(i)=k+1
+c ori              capem(i)=cape(i)
+c ori            endif
+c ori          endif
+c ori 520    continue
+c ori 530  continue
+c ori      do 540 i=1,ncum
+c ori          cape(i)=capem(i)+byp(i)
+c ori          defrac=capem(i)-cape(i)
+c ori          defrac=max(defrac,0.001)
+c ori          frac(i)=-cape(i)/defrac
+c ori          frac(i)=min(frac(i),1.0)
+c ori          frac(i)=max(frac(i),0.0)
+c ori 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+      do k = 1,nd
+      do i=1,ncum
+         hp(i,k)=h(i,k)
+      enddo
+      enddo
+
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=hnk(i)+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+
+        return
+        end
+
+      SUBROUTINE cv3_closure(nloc,ncum,nd,icb,inb
+     :                      ,pbase,p,ph,tv,buoy
+     o                      ,sig,w0,cape,m,iflag)
+      implicit none
+
+!===================================================================
+! ---  CLOSURE OF CONVECT3
+!
+! vectorization: S. Bony
+!===================================================================
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real tv(nloc,nd), buoy(nloc,nd)
+
+c input/output:
+      real sig(nloc,nd), w0(nloc,nd)
+      integer iflag(nloc)
+
+c output:
+      real cape(nloc)
+      real m(nloc,nd)
+
+c local variables:
+      integer i, j, k, icbmax
+      real deltap, fac, w, amu
+      real dtmin(nloc,nd), sigold(nloc,nd)
+      real cbmflast(nloc)
+
+
+c -------------------------------------------------------
+c -- Initialization
+c -------------------------------------------------------
+
+      do k=1,nl
+       do i=1,ncum
+        m(i,k)=0.0
+       enddo
+      enddo
+
+c -------------------------------------------------------
+c -- Reset sig(i) and w0(i) for i>inb and i<icb
+c -------------------------------------------------------
+
+c update sig and w0 above LNB:
+
+      do 100 k=1,nl-1
+       do 110 i=1,ncum
+        if ((inb(i).lt.(nl-1)).and.(k.ge.(inb(i)+1)))then
+         sig(i,k)=beta*sig(i,k)
+     :            +2.*alpha*buoy(i,inb(i))*ABS(buoy(i,inb(i)))
+         sig(i,k)=AMAX1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+ 110   continue
+ 100  continue
+
+c compute icbmax:
+
+      icbmax=2
+      do 200 i=1,ncum
+        icbmax=MAX(icbmax,icb(i))
+ 200  continue
+
+c update sig and w0 below cloud base:
+
+      do 300 k=1,icbmax
+       do 310 i=1,ncum
+        if (k.le.icb(i))then
+         sig(i,k)=beta*sig(i,k)-2.*alpha*buoy(i,icb(i))*buoy(i,icb(i))
+         sig(i,k)=max(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+310    continue
+300    continue
+
+c!      if(inb.lt.(nl-1))then
+c!         do 85 i=inb+1,nl-1
+c!            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
+c!     1              abs(buoy(inb))
+c!            sig(i)=max(sig(i),0.0)
+c!            w0(i)=beta*w0(i)
+c!   85    continue
+c!      end if
+
+c!      do 87 i=1,icb
+c!         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
+c!         sig(i)=max(sig(i),0.0)
+c!         w0(i)=beta*w0(i)
+c!   87 continue
+
+c -------------------------------------------------------------
+c -- Reset fractional areas of updrafts and w0 at initial time
+c -- and after 10 time steps of no convection
+c -------------------------------------------------------------
+
+      do 400 k=1,nl-1
+       do 410 i=1,ncum
+        if (sig(i,nd).lt.1.5.or.sig(i,nd).gt.12.0)then
+         sig(i,k)=0.0
+         w0(i,k)=0.0
+        endif
+ 410   continue
+ 400  continue
+
+c -------------------------------------------------------------
+c -- Calculate convective available potential energy (cape),
+c -- vertical velocity (w), fractional area covered by
+c -- undilute updraft (sig), and updraft mass flux (m)
+c -------------------------------------------------------------
+
+      do 500 i=1,ncum
+       cape(i)=0.0
+ 500  continue
+
+c compute dtmin (minimum buoyancy between ICB and given level k):
+
+      do i=1,ncum
+       do k=1,nl
+         dtmin(i,k)=100.0
+       enddo
+      enddo
+
+      do 550 i=1,ncum
+       do 560 k=1,nl
+         do 570 j=minorig,nl
+          if ( (k.ge.(icb(i)+1)).and.(k.le.inb(i)).and.
+     :         (j.ge.icb(i)).and.(j.le.(k-1)) )then
+           dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+          endif
+ 570     continue
+ 560   continue
+ 550  continue
+
+c the interval on which cape is computed starts at pbase :
+
+      do 600 k=1,nl
+       do 610 i=1,ncum
+
+        if ((k.ge.(icb(i)+1)).and.(k.le.inb(i))) then
+
+         deltap = MIN(pbase(i),ph(i,k-1))-MIN(pbase(i),ph(i,k))
+         cape(i)=cape(i)+rrd*buoy(i,k-1)*deltap/p(i,k-1)
+         cape(i)=AMAX1(0.0,cape(i))
+         sigold(i,k)=sig(i,k)
+
+c         dtmin(i,k)=100.0
+c         do 97 j=icb(i),k-1 ! mauvaise vectorisation
+c          dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+c  97     continue
+
+         sig(i,k)=beta*sig(i,k)+alpha*dtmin(i,k)*ABS(dtmin(i,k))
+         sig(i,k)=max(sig(i,k),0.0)
+         sig(i,k)=amin1(sig(i,k),0.01)
+         fac=AMIN1(((dtcrit-dtmin(i,k))/dtcrit),1.0)
+         w=(1.-beta)*fac*SQRT(cape(i))+beta*w0(i,k)
+         amu=0.5*(sig(i,k)+sigold(i,k))*w
+         m(i,k)=amu*0.007*p(i,k)*(ph(i,k)-ph(i,k+1))/tv(i,k)
+         w0(i,k)=w
+        endif
+
+ 610   continue
+ 600  continue
+
+      do 700 i=1,ncum
+       w0(i,icb(i))=0.5*w0(i,icb(i)+1)
+       m(i,icb(i))=0.5*m(i,icb(i)+1)
+     :             *(ph(i,icb(i))-ph(i,icb(i)+1))
+     :             /(ph(i,icb(i)+1)-ph(i,icb(i)+2))
+       sig(i,icb(i))=sig(i,icb(i)+1)
+       sig(i,icb(i)-1)=sig(i,icb(i))
+ 700  continue
+c
+cccc 3. Compute final cloud base mass flux and set iflag to 3 if
+cccc    cloud base mass flux is exceedingly small and is decreasing (i.e. if
+cccc    the final mass flux (cbmflast) is greater than the target mass flux
+cccc    (cbmf) ??).
+ccc
+cc      do i = 1,ncum
+cc       cbmflast(i) = 0.
+cc      enddo
+ccc
+cc      do k= 1,nl
+cc       do i = 1,ncum
+cc        IF (k .ge. icb(i) .and. k .le. inb(i)) THEN
+cc         cbmflast(i) = cbmflast(i)+M(i,k)
+cc        ENDIF
+cc       enddo
+cc      enddo
+ccc
+cc      do i = 1,ncum
+cc       IF (cbmflast(i) .lt. 1.e-6) THEN
+cc         iflag(i) = 3
+cc       ENDIF
+cc      enddo
+ccc
+cc      do k= 1,nl
+cc       do i = 1,ncum
+cc        IF (iflag(i) .ge. 3) THEN
+cc         M(i,k) = 0.
+cc         sig(i,k) = 0.
+cc         w0(i,k) = 0.
+cc        ENDIF
+cc       enddo
+cc      enddo
+ccc
+c!      cape=0.0
+c!      do 98 i=icb+1,inb
+c!         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
+c!         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
+c!         dcape=rrd*buoy(i-1)*deltap/p(i-1)
+c!         dlnp=deltap/p(i-1)
+c!         cape=max(0.0,cape)
+c!         sigold=sig(i)
+
+c!         dtmin=100.0
+c!         do 97 j=icb,i-1
+c!            dtmin=amin1(dtmin,buoy(j))
+c!   97    continue
+
+c!         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
+c!         sig(i)=max(sig(i),0.0)
+c!         sig(i)=amin1(sig(i),0.01)
+c!         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
+c!         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
+c!         amu=0.5*(sig(i)+sigold)*w
+c!         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
+c!         w0(i)=w
+c!   98 continue
+c!      w0(icb)=0.5*w0(icb+1)
+c!      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
+c!      sig(icb)=sig(icb+1)
+c!      sig(icb-1)=sig(icb)
+
+       return
+       end
+
+      SUBROUTINE cv3_mixing(nloc,ncum,nd,na,ntra,icb,nk,inb
+     :                    ,ph,t,rr,rs,u,v,tra,h,lv,qnk
+     :                    ,unk,vnk,hp,tv,tvp,ep,clw,m,sig
+     :   ,ment,qent,uent,vent,nent,sij,elij,ments,qents,traent)
+      implicit none
+
+!---------------------------------------------------------------------
+! a faire:
+!   - vectorisation de la partie normalisation des flux (do 789...)
+!---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc), nk(nloc)
+      real sig(nloc,nd)
+      real qnk(nloc),unk(nloc),vnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra) ! input of convect3
+      real lv(nloc,na), h(nloc,na), hp(nloc,na)
+      real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na)        ! input of convect3
+
+c outputs:
+      real ment(nloc,na,na), qent(nloc,na,na)
+      real uent(nloc,na,na), vent(nloc,na,na)
+      real sij(nloc,na,na), elij(nloc,na,na)
+      real traent(nloc,nd,nd,ntra)
+      real ments(nloc,nd,nd), qents(nloc,nd,nd)
+      real sigij(nloc,nd,nd)
+      integer nent(nloc,nd)
+
+c local variables:
+      integer i, j, k, il, im, jm
+      integer num1, num2
+      real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+      real alt, smid, sjmin, sjmax, delp, delm
+      real asij(nloc), smax(nloc), scrit(nloc)
+      real asum(nloc,nd),bsum(nloc,nd),csum(nloc,nd)
+      real wgh
+      real zm(nloc,na)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+
+c ori        do 360 i=1,ncum*nlp
+        do 361 j=1,nl
+        do 360 i=1,ncum
+          nent(i,j)=0
+c in convect3, m is computed in cv3_closure
+c ori          m(i,1)=0.0
+ 360    continue
+ 361    continue
+
+c ori      do 400 k=1,nlp
+c ori       do 390 j=1,nlp
+      do 400 j=1,nl
+       do 390 k=1,nl
+          do 385 i=1,ncum
+            qent(i,k,j)=rr(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+cym            ment(i,k,j)=0.0
+cym            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+
+cym
+      ment(1:ncum,1:nd,1:nd)=0.0
+      sij(1:ncum,1:nd,1:nd)=0.0
+      
+!AC!      do k=1,ntra
+!AC!       do j=1,nd  ! instead nlp
+!AC!        do i=1,nd ! instead nlp
+!AC!         do il=1,ncum
+!AC!            traent(il,i,j,k)=tra(il,j,k)
+!AC!         enddo
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+      zm(:,:)=0.
+
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+
+      do 750 i=minorig+1, nl
+
+       do 710 j=minorig,nl
+        do 700 il=1,ncum
+         if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+
+          rti=qnk(il)-ep(il,i)*clw(il,i)
+          bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd)
+          anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j))
+          denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j)
+          dei=denom
+          if(abs(dei).lt.0.01)dei=0.01
+          sij(il,i,j)=anum/dei
+          sij(il,i,i)=1.0
+          altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+          altem=altem/bf2
+          cwat=clw(il,j)*(1.-ep(il,j))
+          stemp=sij(il,i,j)
+          if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat)
+     :                 .and.j.gt.i)then
+           anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2)
+           denom=denom+lv(il,j)*(rr(il,i)-rti)
+           if(abs(denom).lt.0.01)denom=0.01
+           sij(il,i,j)=anum/denom
+           altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+           altem=altem-(bf2-1.)*cwat
+          end if
+         if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then
+          qent(il,i,j)=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti
+          uent(il,i,j)=sij(il,i,j)*u(il,i)+(1.-sij(il,i,j))*unk(il)
+          vent(il,i,j)=sij(il,i,j)*v(il,i)+(1.-sij(il,i,j))*vnk(il)
+c!!!      do k=1,ntra
+c!!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+c!!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
+c!!!      end do
+          elij(il,i,j)=altem
+          elij(il,i,j)=max(0.0,elij(il,i,j))
+          ment(il,i,j)=m(il,i)/(1.-sij(il,i,j))
+          nent(il,i)=nent(il,i)+1
+         end if
+         sij(il,i,j)=max(0.0,sij(il,i,j))
+         sij(il,i,j)=amin1(1.0,sij(il,i,j))
+         endif ! new
+ 700   continue
+ 710  continue
+
+!AC!       do k=1,ntra
+!AC!        do j=minorig,nl
+!AC!         do il=1,ncum
+!AC!          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+!AC!     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+!AC!            traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+!AC!     :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
+!AC!          endif
+!AC!         enddo
+!AC!        enddo
+!AC!       enddo
+
+c
+c   ***   if no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+
+c@      do 170 i=icb(il),inb(il)
+
+      do 740 il=1,ncum
+      if ((i.ge.icb(il)).and.(i.le.inb(il)).and.(nent(il,i).eq.0)) then
+c@      if(nent(il,i).eq.0)then
+      ment(il,i,i)=m(il,i)
+      qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i)
+      uent(il,i,i)=unk(il)
+      vent(il,i,i)=vnk(il)
+      elij(il,i,i)=clw(il,i)
+cMAF      sij(il,i,i)=1.0
+      sij(il,i,i)=0.0
+      end if
+ 740  continue
+ 750  continue
+
+!AC!      do j=1,ntra
+!AC!       do i=minorig+1,nl
+!AC!        do il=1,ncum
+!AC!         if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
+!AC!          traent(il,i,i,j)=tra(il,nk(il),j)
+!AC!         endif
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+
+      do 100 j=minorig,nl
+      do 101 i=minorig,nl
+      do 102 il=1,ncum
+      if ((j.ge.(icb(il)-1)).and.(j.le.inb(il))
+     :    .and.(i.ge.icb(il)).and.(i.le.inb(il)))then
+       sigij(il,i,j)=sij(il,i,j)
+      endif
+ 102  continue
+ 101  continue
+ 100  continue
+c@      enddo
+
+c@170   continue
+
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+
+      call zilch(asum,nloc*nd)
+      call zilch(csum,nloc*nd)
+      call zilch(csum,nloc*nd)
+
+      do il=1,ncum
+       lwork(il) = .FALSE.
+      enddo
+
+      DO 789 i=minorig+1,nl
+
+      num1=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1
+      enddo
+      if (num1.le.0) goto 789
+
+
+      do 781 il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) then
+        lwork(il)=(nent(il,i).ne.0)
+        qp=qnk(il)-ep(il,i)*clw(il,i)
+        anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i))
+     :           +(cpv-cpd)*t(il,i)*(qp-rr(il,i))
+        denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp)
+     :           +(cpd-cpv)*t(il,i)*(rr(il,i)-qp)
+        if(abs(denom).lt.0.01)denom=0.01
+        scrit(il)=anum/denom
+        alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp)
+        if(scrit(il).le.0.0.or.alt.le.0.0)scrit(il)=1.0
+        smax(il)=0.0
+        asij(il)=0.0
+       endif
+781   continue
+
+      do 175 j=nl,minorig,-1
+
+      num2=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) num2=num2+1
+      enddo
+      if (num2.le.0) goto 175
+
+      do 782 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) then
+
+       if(sij(il,i,j).gt.1.0e-16.and.sij(il,i,j).lt.0.95)then
+        wgh=1.0
+        if(j.gt.i)then
+         sjmax=max(sij(il,i,j+1),smax(il))
+         sjmax=amin1(sjmax,scrit(il))
+         smax(il)=max(sij(il,i,j),smax(il))
+         sjmin=max(sij(il,i,j-1),smax(il))
+         sjmin=amin1(sjmin,scrit(il))
+         if(sij(il,i,j).lt.(smax(il)-1.0e-16))wgh=0.0
+         smid=amin1(sij(il,i,j),scrit(il))
+        else
+         sjmax=max(sij(il,i,j+1),scrit(il))
+         smid=max(sij(il,i,j),scrit(il))
+         sjmin=0.0
+         if(j.gt.1)sjmin=sij(il,i,j-1)
+         sjmin=max(sjmin,scrit(il))
+        endif
+        delp=abs(sjmax-smid)
+        delm=abs(sjmin-smid)
+        asij(il)=asij(il)+wgh*(delp+delm)
+        ment(il,i,j)=ment(il,i,j)*(delp+delm)*wgh
+       endif
+      endif
+782   continue
+
+175   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        asij(il)=max(1.0e-16,asij(il))
+        asij(il)=1.0/asij(il)
+        asum(il,i)=0.0
+        bsum(il,i)=0.0
+        csum(il,i)=0.0
+       endif
+      enddo
+
+      do 180 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asij(il)
+        endif
+       enddo
+180   continue
+
+      do 190 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         asum(il,i)=asum(il,i)+ment(il,i,j)
+         ment(il,i,j)=ment(il,i,j)*sig(il,j)
+         bsum(il,i)=bsum(il,i)+ment(il,i,j)
+        endif
+       enddo
+190   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        bsum(il,i)=max(bsum(il,i),1.0e-16)
+        bsum(il,i)=1.0/bsum(il,i)
+       endif
+      enddo
+
+      do 195 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asum(il,i)*bsum(il,i)
+        endif
+       enddo
+195   continue
+
+      do 197 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         csum(il,i)=csum(il,i)+ment(il,i,j)
+        endif
+       enddo
+197   continue
+
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :     .and. csum(il,i).lt.m(il,i) ) then
+        nent(il,i)=0
+        ment(il,i,i)=m(il,i)
+        qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i)
+        uent(il,i,i)=unk(il)
+        vent(il,i,i)=vnk(il)
+        elij(il,i,i)=clw(il,i)
+cMAF        sij(il,i,i)=1.0
+        sij(il,i,i)=0.0
+       endif
+      enddo ! il
+
+!AC!      do j=1,ntra
+!AC!       do il=1,ncum
+!AC!        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+!AC!     :     .and. csum(il,i).lt.m(il,i) ) then
+!AC!         traent(il,i,i,j)=tra(il,nk(il),j)
+!AC!        endif
+!AC!       enddo
+!AC!      enddo
+789   continue
+c      
+c MAF: renormalisation de MENT
+      call zilch(zm,nloc*na)
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          zm(il,im)=zm(il,im)+(1.-sij(il,im,jm))*ment(il,im,jm)
+         end do
+        end do
+      end do
+c
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          if(zm(il,im).ne.0.) then
+          ment(il,im,jm)=ment(il,im,jm)*m(il,im)/zm(il,im)
+          endif
+         end do
+       end do
+      end do
+c
+      do jm=1,nd
+       do im=1,nd
+        do 999 il=1,ncum
+         qents(il,im,jm)=qent(il,im,jm)
+         ments(il,im,jm)=ment(il,im,jm)
+999     continue
+       enddo
+      enddo
+
+      return
+      end
+
+      SUBROUTINE cv3_unsat(nloc,ncum,nd,na,ntra,icb,inb,iflag
+     :              ,t,rr,rs,gz,u,v,tra,p,ph
+     :              ,th,tv,lv,cpn,ep,sigp,clw
+     :              ,m,ment,elij,delt,plcl,coef_clos
+     o              ,mp,rp,up,vp,trap,wt,water,evap,b,sigd
+     o              ,wdtrainA,wdtrainM)                                ! RomP
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "cvflag.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc)
+      real delt, plcl(nloc)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd),gz(nloc,na)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real ep(nloc,na), sigp(nloc,na), clw(nloc,na)
+      real th(nloc,na),tv(nloc,na),lv(nloc,na),cpn(nloc,na)
+      real m(nloc,na), ment(nloc,na,na), elij(nloc,na,na)
+      real coef_clos(nloc)
+c
+c input/output
+      integer iflag(nloc)
+c
+c outputs:
+      real mp(nloc,na), rp(nloc,na), up(nloc,na), vp(nloc,na)
+      real water(nloc,na), evap(nloc,na), wt(nloc,na)
+      real trap(nloc,na,ntra)
+      real b(nloc,na), sigd(nloc)
+! 25/08/10 - RomP---- ajout des masses precipitantes ejectees
+! lascendance adiabatique et des flux melanges Pa et Pm.
+! Distinction des wdtrain
+! Pa = wdtrainA     Pm = wdtrainM
+      real  wdtrainA(nloc,na), wdtrainM(nloc,na)
+
+c local variables
+      integer i,j,k,il,num1,ndp1
+      real tinv, delti
+      real awat, afac, afac1, afac2, bfac
+      real pr1, pr2, sigt, b6, c6, revap, delth
+      real amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
+      real ampmax
+      real tevap(nloc)
+      real lvcp(nloc,na)
+      real h(nloc,na),hm(nloc,na)
+      real wdtrain(nloc)
+      logical lwork(nloc),mplus(nloc)
+
+
+c------------------------------------------------------
+
+        delti = 1./delt
+        tinv=1./3.
+
+        mp(:,:)=0.
+
+        do i=1,nl
+         do il=1,ncum
+          mp(il,i)=0.0
+          rp(il,i)=rr(il,i)
+          up(il,i)=u(il,i)
+          vp(il,i)=v(il,i)
+          wt(il,i)=0.001
+          water(il,i)=0.0
+          evap(il,i)=0.0
+          b(il,i)=0.0
+          lvcp(il,i)=lv(il,i)/cpn(il,i)
+         enddo
+        enddo
+!AC!        do k=1,ntra
+!AC!         do i=1,nd
+!AC!          do il=1,ncum
+!AC!           trap(il,i,k)=tra(il,i,k)
+!AC!          enddo
+!AC!         enddo
+!AC!        enddo
+!! RomP >>>
+         do i=1,nd
+          do il=1,ncum
+          wdtrainA(il,i)=0.0     
+          wdtrainM(il,i)=0.0     
+         enddo
+        enddo
+!! RomP <<<
+c
+c   ***  check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+
+        do il=1,ncum
+!!          lwork(il)=.TRUE.
+!!          if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE.
+          lwork(il)= ep(il,inb(il)) .ge. 0.0001
+        enddo
+
+c   ***  Set the fractionnal area sigd of precipitating downdraughts
+        do il = 1,ncum
+          sigd(il) = sigdz*coef_clos(il)
+        enddo
+
+
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c
+c    ***                    begin downdraft loop                    ***
+c
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c
+        DO 400 i=nl+1,1,-1
+
+        num1=0
+        do il=1,ncum
+         if ( i.le.inb(il) .and. lwork(il) ) num1=num1+1
+        enddo
+        if (num1.le.0) goto 400
+
+        call zilch(wdtrain,ncum)
+
+c
+c   ***  integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+c
+c    ***              calculate detrained precipitation             ***
+c
+       do il=1,ncum
+        if (i.le.inb(il) .and. lwork(il)) then
+         if (cvflag_grav) then
+          wdtrain(il)=grav*ep(il,i)*m(il,i)*clw(il,i)
+          wdtrainA(il,i) = wdtrain(il)/grav     !   Pa   RomP
+         else
+          wdtrain(il)=10.0*ep(il,i)*m(il,i)*clw(il,i)
+          wdtrainA(il,i) = wdtrain(il)/10.      !   Pa   RomP
+         endif
+        endif
+       enddo
+
+       if(i.gt.1)then
+        do 320 j=1,i-1
+         do il=1,ncum
+          if (i.le.inb(il) .and. lwork(il)) then
+           awat=elij(il,j,i)-(1.-ep(il,i))*clw(il,i)
+           awat=max(awat,0.0)
+           if (cvflag_grav) then
+            wdtrain(il)=wdtrain(il)+grav*awat*ment(il,j,i)
+            wdtrainM(il,i) = wdtrain(il)/grav-wdtrainA(il,i)    !   Pm  RomP
+           else
+            wdtrain(il)=wdtrain(il)+10.0*awat*ment(il,j,i)
+            wdtrainM(il,i) = wdtrain(il)/10.-wdtrainA(il,i)    !   Pm  RomP
+           endif
+          endif
+         enddo
+320     continue
+       endif
+
+c
+c    ***    find rain water and evaporation using provisional   ***
+c    ***              estimates of rp(i)and rp(i-1)             ***
+c
+
+      do 995 il=1,ncum
+       if (i.le.inb(il) .and. lwork(il)) then
+
+      wt(il,i)=45.0
+
+      if(i.lt.inb(il))then
+       rp(il,i)=rp(il,i+1)
+     :       +(cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il,i)
+       rp(il,i)=0.5*(rp(il,i)+rr(il,i))
+      endif
+      rp(il,i)=max(rp(il,i),0.0)
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,inb(il))=rr(il,inb(il))
+
+      if(i.eq.1)then
+       afac=p(il,1)*(rs(il,1)-rp(il,1))/(1.0e4+2000.0*p(il,1)*rs(il,1))
+      else
+       rp(il,i-1)=rp(il,i)
+     :          +(cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il,i)
+       rp(il,i-1)=0.5*(rp(il,i-1)+rr(il,i-1))
+       rp(il,i-1)=amin1(rp(il,i-1),rs(il,i-1))
+       rp(il,i-1)=max(rp(il,i-1),0.0)
+       afac1=p(il,i)*(rs(il,i)-rp(il,i))/(1.0e4+2000.0*p(il,i)*rs(il,i))
+       afac2=p(il,i-1)*(rs(il,i-1)-rp(il,i-1))
+     :                /(1.0e4+2000.0*p(il,i-1)*rs(il,i-1))
+       afac=0.5*(afac1+afac2)
+      endif
+      if(i.eq.inb(il))afac=0.0
+      afac=max(afac,0.0)
+      bfac=1./(sigd(il)*wt(il,i))
+c
+cjyg1
+ccc        sigt=1.0
+ccc        if(i.ge.icb)sigt=sigp(i)
+c prise en compte de la variation progressive de sigt dans
+c les couches icb et icb-1:
+c 	pour plcl<ph(i+1), pr1=0 & pr2=1
+c 	pour plcl>ph(i),   pr1=1 & pr2=0
+c 	pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
+c    sur le nuage, et pr2 est la proportion sous la base du
+c    nuage.
+      pr1=(plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
+      pr1=max(0.,min(1.,pr1))
+      pr2=(ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
+      pr2=max(0.,min(1.,pr2))
+      sigt=sigp(il,i)*pr1+pr2
+cjyg2
+c
+cjyg----
+c       b6 = bfac*100.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
+c       c6 = water(il,i+1) + wdtrain(il)*bfac
+c        revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+c        evap(il,i)=sigt*afac*revap
+c        water(il,i)=revap*revap
+cc        print *,' i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il) ',
+cc     $            i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il)
+cc---end jyg---
+c
+c--------retour à la formulation originale d'Emanuel.
+      b6=bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
+      c6=water(il,i+1)+bfac*wdtrain(il)
+     :    -50.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il,i+1)
+      if(c6.gt.0.0)then
+       revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+cjyg    Dans sa formulation originale, Emanuel calcule l'evaporation par:
+cc             evap(il,i)=sigt*afac*revap
+c     ce qui n'est pas correct. Dans cv_routines, la formulation a été modifiee.
+c     Ici,l'evaporation evap est simplement calculee par l'equation de
+c     conservation.
+       water(il,i)=revap*revap
+      else
+cjyg----   Correction : si c6 <= 0, water(il,i)=0.
+       water(il,i) = 0.
+      endif
+cJYG/IM : ci-dessous formulation originale de KE
+c      evap(il,i)=-evap(il,i+1)
+c    :            +(wdtrain(il)+sigd(il)*wt(il,i)*water(il,i+1))
+c    :                 /(sigd(il)*(ph(il,i)-ph(il,i+1))*50.)
+c
+cJYG/IM : ci-dessous modification formulation originale de KE
+c        pour eliminer oscillations verticales de pluie se produisant
+c        lorsqu'il y a evaporation totale de la pluie
+c
+c       evap(il,i)= +(wdtrain(il)+sigd(il)*wt(il,i)*water(il,i+1)) !itlmd(jyg)
+c     :                 /(sigd(il)*(ph(il,i)-ph(il,i+1))*100.)
+c      end if  !itlmd(jyg)
+cjyg---   Dans tous les cas, evaporation = [tt ce qui entre dans la couche i]
+c                                    moins [tt ce qui sort de la couche i]
+       evap(il,i)=
+     :       (wdtrain(il)+sigd(il)*wt(il,i)*(water(il,i+1)-water(il,i)))
+     :                 /(sigd(il)*(ph(il,i)-ph(il,i+1))*100.)
+c
+       endif !(i.le.inb(il) .and. lwork(il))
+995   Continue
+c----------------------------------------------------------------
+c
+ccc
+c    ***  calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+      Do 996 il = 1,ncum
+       if (i.le.inb(il) .and. lwork(il) .and. i.ne.1) then
+c
+      tevap(il)=max(0.0,evap(il,i))
+      delth=max(0.001,(th(il,i)-th(il,i-1)))
+      if (cvflag_grav) then
+       mp(il,i)=100.*ginv*lvcp(il,i)*sigd(il)*tevap(il)
+     :              *(p(il,i-1)-p(il,i))/delth
+      else
+       mp(il,i)=10.*lvcp(il,i)*sigd(il)*tevap(il)
+     :         *(p(il,i-1)-p(il,i))/delth
+      endif
+c
+       endif !(i.le.inb(il) .and. lwork(il) .and. i.ne.1)
+996   Continue
+c----------------------------------------------------------------
+c
+c    ***           if hydrostatic assumption fails,             ***
+c    ***   solve cubic difference equation for downdraft theta  ***
+c    ***  and mass flux from two simultaneous differential eqns ***
+c
+      Do 997 il = 1,ncum
+       if (i.le.inb(il) .and. lwork(il) .and. i.ne.1) then
+c
+      amfac=sigd(il)*sigd(il)*70.0*ph(il,i)*(p(il,i-1)-p(il,i))
+     :          *(th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
+      amp2=abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
+c
+      if(amp2.gt.(0.1*amfac))then
+       xf=100.0*sigd(il)*sigd(il)*sigd(il)*(ph(il,i)-ph(il,i+1))
+       tf=b(il,i)-5.0*(th(il,i)-th(il,i-1))*t(il,i)
+     :               /(lvcp(il,i)*sigd(il)*th(il,i))
+       af=xf*tf+mp(il,i+1)*mp(il,i+1)*tinv
+       bf=2.*(tinv*mp(il,i+1))**3+tinv*mp(il,i+1)*xf*tf
+     :            +50.*(p(il,i-1)-p(il,i))*xf*tevap(il)
+       fac2=1.0
+       if(bf.lt.0.0)fac2=-1.0
+       bf=abs(bf)
+       ur=0.25*bf*bf-af*af*af*tinv*tinv*tinv
+       if(ur.ge.0.0)then
+        sru=sqrt(ur)
+        fac=1.0
+        if((0.5*bf-sru).lt.0.0)fac=-1.0
+        mp(il,i)=mp(il,i+1)*tinv+(0.5*bf+sru)**tinv
+     :                  +fac*(abs(0.5*bf-sru))**tinv
+       else
+        d=atan(2.*sqrt(-ur)/(bf+1.0e-28))
+        if(fac2.lt.0.0)d=3.14159-d
+        mp(il,i)=mp(il,i+1)*tinv+2.*sqrt(af*tinv)*cos(d*tinv)
+       endif
+       mp(il,i)=max(0.0,mp(il,i))
+
+       if (cvflag_grav) then
+Cjyg : il y a vraisemblablement une erreur dans la ligne 2 suivante:
+C il faut diviser par (mp(il,i)*sigd(il)*grav) et non par (mp(il,i)+sigd(il)*0.1).
+C Et il faut bien revoir les facteurs 100.
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap(il)
+     2   /(mp(il,i)+sigd(il)*0.1)
+     3 -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)
+     : *sigd(il)*th(il,i))
+       else
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap(il)
+     2   /(mp(il,i)+sigd(il)*0.1)
+     3 -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)
+     : *sigd(il)*th(il,i))
+       endif
+       b(il,i-1)=max(b(il,i-1),0.0)
+c
+      endif !(amp2.gt.(0.1*amfac))
+c
+c   ***         limit magnitude of mp(i) to meet cfl condition      ***
+c
+      ampmax=2.0*(ph(il,i)-ph(il,i+1))*delti
+      amp2=2.0*(ph(il,i-1)-ph(il,i))*delti
+      ampmax=min(ampmax,amp2)
+      mp(il,i)=min(mp(il,i),ampmax)
+c
+c    ***      force mp to decrease linearly to zero                 ***
+c    ***       between cloud base and the surface                   ***
+c
+c
+cc      if(p(il,i).gt.p(il,icb(il)))then
+cc       mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il)))
+cc      endif
+      if(ph(il,i) .gt. 0.9*plcl(il)) then
+       mp(il,i) = mp(il,i)*(ph(il,1)-ph(il,i))/
+     $                     (ph(il,1)-0.9*plcl(il))
+      endif
+
+       endif ! (i.le.inb(il) .and. lwork(il) .and. i.ne.1)
+997   Continue
+c----------------------------------------------------------------
+c
+c    ***       find mixing ratio of precipitating downdraft     ***
+c
+      Do il = 1,ncum
+       if (i.lt.inb(il) .and. lwork(il)) then
+        mplus(il) = mp(il,i).gt.mp(il,i+1)
+       endif ! (i.lt.inb(il) .and. lwork(il))
+      enddo
+c
+      Do 999 il = 1,ncum
+       if (i.lt.inb(il) .and. lwork(il)) then
+c
+      rp(il,i)=rr(il,i)
+
+      if(mplus(il))then
+
+       if (cvflag_grav) then
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1))
+     :                     *(evap(il,i+1)+evap(il,i))
+       else
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))
+     :   +5.*sigd(il)*(ph(il,i)-ph(il,i+1))
+     :                      *(evap(il,i+1)+evap(il,i))
+       endif
+      rp(il,i)=rp(il,i)/mp(il,i)
+      up(il,i)=up(il,i+1)*mp(il,i+1)+u(il,i)*(mp(il,i)-mp(il,i+1))
+      up(il,i)=up(il,i)/mp(il,i)
+      vp(il,i)=vp(il,i+1)*mp(il,i+1)+v(il,i)*(mp(il,i)-mp(il,i+1))
+      vp(il,i)=vp(il,i)/mp(il,i)
+
+      else ! if (mplus(il))
+
+       if(mp(il,i+1).gt.1.0e-16)then
+        if (cvflag_grav) then
+         rp(il,i)=rp(il,i+1)
+     :            +100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1))
+     :            *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        else
+         rp(il,i)=rp(il,i+1)
+     :           +5.*sigd(il)*(ph(il,i)-ph(il,i+1))
+     :           *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        endif
+       up(il,i)=up(il,i+1)
+       vp(il,i)=vp(il,i+1)
+       endif ! (mp(il,i+1).gt.1.0e-16)
+      endif ! (mplus(il)) else if (.not.mplus(il))
+c
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,i)=max(rp(il,i),0.0)
+
+      endif ! (i.lt.inb(il) .and. lwork(il))
+999   continue
+c----------------------------------------------------------------
+c
+c    ***       find tracer concentrations in precipitating downdraft     ***
+c
+!AC!      do j=1,ntra
+!AC!       do il = 1,ncum
+!AC!       if (i.lt.inb(il) .and. lwork(il)) then
+!AC!c
+!AC!         if(mplus(il))then
+!AC!          trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
+!AC!     :              +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
+!AC!          trap(il,i,j)=trap(il,i,j)/mp(il,i)
+!AC!         else ! if (mplus(il))
+!AC!          if(mp(il,i+1).gt.1.0e-16)then
+!AC!           trap(il,i,j)=trap(il,i+1,j)
+!AC!          endif
+!AC!         endif ! (mplus(il)) else if (.not.mplus(il))
+!AC!c
+!AC!        endif ! (i.lt.inb(il) .and. lwork(il))
+!AC!       enddo
+!AC!      end do
+
+400   continue
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c
+c    ***                    end of downdraft loop                    ***
+c
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c
+
+       return
+       end
+
+      SUBROUTINE cv3_yield(nloc,ncum,nd,na,ntra
+     :                    ,icb,inb,delt
+     :                    ,t,rr,t_wake,rr_wake,s_wake,u,v,tra
+     :                    ,gz,p,ph,h,hp,lv,cpn,th,th_wake
+     :                    ,ep,clw,m,tp,mp,rp,up,vp,trap
+     :                    ,wt,water,evap,b,sigd
+     :                    ,ment,qent,hent,iflag_mix,uent,vent
+     :                    ,nent,elij,traent,sig
+     :                    ,tv,tvp,wghti
+     :                    ,iflag,precip,Vprecip,ft,fr,fu,fv,ftra
+     :                    ,cbmf,upwd,dnwd,dnwd0,ma,mip
+     :                    ,tls,tps,qcondc,wd
+     :                    ,ftd,fqd)
+      
+      implicit none
+
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "cvflag.h"
+#include "conema3.h"
+
+c inputs:
+c      print*,'cv3_yield apres include'
+      integer iflag_mix
+      integer ncum,nd,na,ntra,nloc
+      integer icb(nloc), inb(nloc)
+      real delt
+      real t(nloc,nd), rr(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real t_wake(nloc,nd), rr_wake(nloc,nd)
+      real s_wake(nloc)
+      real tra(nloc,nd,ntra), sig(nloc,nd)
+      real gz(nloc,na), ph(nloc,nd+1), h(nloc,na), hp(nloc,na)
+      real th(nloc,na), p(nloc,nd), tp(nloc,na)
+      real lv(nloc,na), cpn(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na), mp(nloc,na), rp(nloc,na), up(nloc,na)
+      real vp(nloc,na), wt(nloc,nd), trap(nloc,nd,ntra)
+      real water(nloc,na), evap(nloc,na), b(nloc,na), sigd(nloc)
+      real ment(nloc,na,na), qent(nloc,na,na), uent(nloc,na,na)
+      real hent(nloc,na,na)
+cIM bug   real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
+      real vent(nloc,na,na), elij(nloc,na,na)
+      integer nent(nloc,nd)
+      real traent(nloc,na,na,ntra)
+      real tv(nloc,nd), tvp(nloc,nd), wghti(nloc,nd)
+c      print*,'cv3_yield declarations 1'
+c input/output:
+      integer iflag(nloc)
+
+c outputs:
+      real precip(nloc)
+      real ft(nloc,nd), fr(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftd(nloc,nd), fqd(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real upwd(nloc,nd), dnwd(nloc,nd), ma(nloc,nd)
+      real dnwd0(nloc,nd), mip(nloc,nd)
+      real Vprecip(nloc,nd+1)
+      real tls(nloc,nd), tps(nloc,nd)
+      real qcondc(nloc,nd)                               ! cld
+      real wd(nloc)                                      ! gust
+      real cbmf(nloc)
+c      print*,'cv3_yield declarations 2'
+c local variables:
+      integer i,k,il,n,j,num1
+      real rat, delti
+      real ax, bx, cx, dx, ex
+      real cpinv, rdcp, dpinv
+      real awat(nloc)
+      real lvcp(nloc,na), mke(nloc,na)
+      real am(nloc), work(nloc), ad(nloc), amp1(nloc)
+c!!      real up1(nloc), dn1(nloc)
+      real up1(nloc,nd,nd), dn1(nloc,nd,nd)
+      real asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
+      real esum(nloc), fsum(nloc), gsum(nloc), hsum(nloc)
+      real th_wake(nloc,nd)
+      real alpha_qpos(nloc),alpha_qpos1(nloc)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd)  ! cld
+      real siga(nloc,nd), sax(nloc,nd), mac(nloc,nd)      ! cld
+
+c      print*,'cv3_yield declarations 3'
+c-------------------------------------------------------------
+
+c initialization:
+
+      delti = 1.0/delt
+c      print*,'cv3_yield initialisation delt', delt
+cprecip,Vprecip,ft,fr,fu,fv,ftra
+c     :                    ,cbmf,upwd,dnwd,dnwd0,ma,mip
+c     :                    ,tls,tps,qcondc,wd
+c     :                    ,ftd,fqd  )
+      do il=1,ncum
+       precip(il)=0.0
+       Vprecip(il,nd+1)=0.0
+       wd(il)=0.0     ! gust
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+         Vprecip(il,i)=0.0
+         ft(il,i)=0.0
+         fr(il,i)=0.0
+         fu(il,i)=0.0
+         fv(il,i)=0.0
+         upwd(il,i)=0.0
+         dnwd(il,i)=0.0
+         dnwd0(il,i)=0.0
+         mip(il,i)=0.0
+         ftd(il,i)=0.0
+         fqd(il,i)=0.0
+         qcondc(il,i)=0.0                                ! cld
+         qcond(il,i)=0.0                                 ! cld
+         nqcond(il,i)=0.0                                ! cld
+       enddo 
+      enddo
+c       print*,'cv3_yield initialisation 2'
+!AC!      do j=1,ntra
+!AC!       do i=1,nd
+!AC!        do il=1,ncum
+!AC!          ftra(il,i,j)=0.0
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+c       print*,'cv3_yield initialisation 3'
+      do i=1,nl
+       do il=1,ncum
+         lvcp(il,i)=lv(il,i)/cpn(il,i)
+       enddo
+      enddo
+
+
+c
+c   ***  calculate surface precipitation in mm/day     ***
+c
+      do il=1,ncum
+       if(ep(il,inb(il)).ge.0.0001 .and. iflag(il) .le. 1)then
+        if (cvflag_grav) then
+           precip(il)=wt(il,1)*sigd(il)*water(il,1)*86400.*1000.
+     :               /(rowl*grav)
+        else
+         precip(il)=wt(il,1)*sigd(il)*water(il,1)*8640.
+        endif
+       endif
+      enddo
+c      print*,'cv3_yield apres calcul precip'
+
+C
+C   ===  calculate vertical profile of  precipitation in kg/m2/s  ===
+C
+      do i = 1,nl
+      do il=1,ncum
+       if(ep(il,inb(il)).ge.0.0001 .and. i.le.inb(il)
+     :    .and. iflag(il) .le. 1)then
+        if (cvflag_grav) then
+           VPrecip(il,i) = wt(il,i)*sigd(il)*water(il,i)/grav
+        else
+           VPrecip(il,i) = wt(il,i)*sigd(il)*water(il,i)/10.
+        endif
+       endif
+      enddo
+      enddo
+C
+c
+c   ***  Calculate downdraft velocity scale    ***
+c   ***  NE PAS UTILISER POUR L'INSTANT ***
+c
+c!      do il=1,ncum
+c!        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
+c!     :                                  /(sigd(il)*p(il,icb(il)))
+c!      enddo
+
+c
+c   ***  calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+      do il=1,ncum
+       work(il)=1.0/(ph(il,1)-ph(il,2))
+       cbmf(il)=0.0
+      enddo
+
+      do k=2,nl
+       do il=1,ncum
+        if (k.ge.icb(il)) then
+         cbmf(il)=cbmf(il)+m(il,k)
+        endif
+       enddo
+      enddo
+
+c      print*,'cv3_yield avant ft'
+c AM is the part of cbmf taken from the first level
+      do il=1,ncum
+        am(il)=cbmf(il)*wghti(il,1)
+      enddo
+c
+      do il=1,ncum
+        if (iflag(il) .le. 1) then
+c convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
+cjyg  Correction pour conserver l'eau
+ccc       ft(il,1)=-0.5*lvcp(il,1)*sigd(il)*(evap(il,1)+evap(il,2)) !precip
+       ft(il,1)=-lvcp(il,1)*sigd(il)*evap(il,1)                  !precip
+
+      if (cvflag_grav) then
+        ft(il,1)=ft(il,1)-0.009*grav*sigd(il)*mp(il,2)
+     :                              *t_wake(il,1)*b(il,1)*work(il)
+      else
+        ft(il,1)=ft(il,1)-0.09*sigd(il)*mp(il,2)
+     :                              *t_wake(il,1)*b(il,1)*work(il)
+      endif
+
+      ft(il,1)=ft(il,1)+0.01*sigd(il)*wt(il,1)*(cl-cpd)*water(il,2)
+     :     *(t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il,1)
+
+      ftd(il,1) = ft(il,1)                        ! fin precip
+
+      if (cvflag_grav) then                  !sature
+      if((0.01*grav*work(il)*am(il)).ge.delti)iflag(il)=1!consist vect
+       ft(il,1)=ft(il,1)+0.01*grav*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      else
+       if((0.1*work(il)*am(il)).ge.delti)iflag(il)=1 !consistency vect
+       ft(il,1)=ft(il,1)+0.1*work(il)*am(il)*(t(il,2)-t(il,1)
+     :            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      endif
+      endif  ! iflag
+      enddo
+
+
+       do j=2,nl
+      IF (iflag_mix .gt. 0) then
+        do il=1,ncum
+c FH WARNING a modifier :
+      cpinv=0.
+c     cpinv=1.0/cpn(il,1)
+         if (j.le.inb(il) .and. iflag(il) .le. 1) then
+         if (cvflag_grav) then
+          ft(il,1)=ft(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(hent(il,j,1)-h(il,1)
+     :       +t(il,1)*(cpv-cpd)*(rr(il,1)-Qent(il,j,1)))*cpinv
+         else
+          ft(il,1)=ft(il,1)
+     :       +0.1*work(il)*ment(il,j,1)*(hent(il,j,1)-h(il,1)
+     :       +t(il,1)*(cpv-cpd)*(rr(il,1)-Qent(il,j,1)))*cpinv
+         endif  ! cvflag_grav
+        endif ! j
+       enddo
+       ENDIF
+        enddo
+         ! fin sature
+
+
+      do il=1,ncum
+        if (iflag(il) .le. 1) then
+          if (cvflag_grav) then
+Cjyg1  Correction pour mieux conserver l'eau (conformite avec CONVECT4.3)
+       fr(il,1)=0.01*grav*mp(il,2)*(rp(il,2)-rr_wake(il,1))*work(il)
+     :          +sigd(il)*evap(il,1)
+ccc     :          +sigd(il)*0.5*(evap(il,1)+evap(il,2))
+
+       fqd(il,1)=fr(il,1)     !precip
+
+       fr(il,1)=fr(il,1)+0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)  !sature
+
+       fu(il,1)=fu(il,1)+0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+      else  ! cvflag_grav
+       fr(il,1)=0.1*mp(il,2)*(rp(il,2)-rr_wake(il,1))*work(il)
+     :          +sigd(il)*evap(il,1)
+ccc     :          +sigd(il)*0.5*(evap(il,1)+evap(il,2))
+       fqd(il,1)=fr(il,1)  !precip
+       fr(il,1)=fr(il,1)+0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
+       fu(il,1)=fu(il,1)+0.1*work(il)*(mp(il,2)*(up(il,2)-u(il,1))
+     :         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.1*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))
+     :         +am(il)*(v(il,2)-v(il,1)))
+         endif ! cvflag_grav
+       endif  ! iflag
+      enddo ! il
+
+
+!AC!     do j=1,ntra
+!AC!      do il=1,ncum
+!AC!       if (iflag(il) .le. 1) then
+!AC!       if (cvflag_grav) then
+!AC!        ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
+!AC!    :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+!AC!    :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+!AC!       else
+!AC!        ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
+!AC!    :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+!AC!    :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+!AC!       endif
+!AC!       endif  ! iflag
+!AC!      enddo
+!AC!     enddo
+
+       do j=2,nl
+       do il=1,ncum
+        if (j.le.inb(il) .and. iflag(il) .le. 1) then
+         if (cvflag_grav) then
+          fr(il,1)=fr(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :       +0.01*grav*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         else   ! cvflag_grav
+          fr(il,1)=fr(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)
+     :         +0.1*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))  ! fin sature
+         endif  ! cvflag_grav
+        endif ! j
+       enddo
+      enddo
+
+!AC!      do k=1,ntra
+!AC!       do j=2,nl
+!AC!        do il=1,ncum
+!AC!         if (j.le.inb(il) .and. iflag(il) .le. 1) then
+!AC!
+!AC!          if (cvflag_grav) then
+!AC!           ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
+!AC!     :                *(traent(il,j,1,k)-tra(il,1,k))
+!AC!          else
+!AC!           ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
+!AC!     :                *(traent(il,j,1,k)-tra(il,1,k))
+!AC!          endif
+!AC!
+!AC!         endif
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+c      print*,'cv3_yield apres ft'
+c
+c   ***  calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  first find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+
+      do 500 i=2,nl+1 ! newvecto: mettre nl au lieu nl+1?
+
+       num1=0
+       do il=1,ncum
+        if(i.le.inb(il) .and. iflag(il) .le. 1)num1=num1+1
+       enddo
+       if(num1.le.0)go to 500
+
+       call zilch(amp1,ncum)
+       call zilch(ad,ncum)
+
+      do 440 k=1,nl+1
+       do 441 il=1,ncum
+        if(i.ge.icb(il)) then
+          if(k.ge.i+1.and. k.le.(inb(il)+1)) then
+            amp1(il)=amp1(il)+m(il,k)
+          endif
+         else
+c AMP1 is the part of cbmf taken from layers I and lower
+          if(k.le.i) then
+           amp1(il)=amp1(il)+cbmf(il)*wghti(il,k)
+          endif
+        endif
+ 441   continue
+ 440  continue
+
+      do 450 k=1,i
+       do 451 j=i+1,nl+1
+        do 452 il=1,ncum
+         if (i.le.inb(il) .and. j.le.(inb(il)+1)) then
+          amp1(il)=amp1(il)+ment(il,k,j)
+         endif
+452     continue
+451    continue
+450   continue
+
+      do 470 k=1,i-1
+       do 471 j=i,nl+1 ! newvecto: nl au lieu nl+1?
+        do 472 il=1,ncum
+        if (i.le.inb(il) .and. j.le.inb(il)) then
+         ad(il)=ad(il)+ment(il,j,k)
+        endif
+472     continue
+471    continue
+470   continue
+  
+      do 1350 il=1,ncum
+      if (i.le.inb(il) .and. iflag(il) .le. 1) then
+       dpinv=1.0/(ph(il,i)-ph(il,i+1))
+       cpinv=1.0/cpn(il,i)
+
+c convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+       if((0.01*grav*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      else
+       if((0.1*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      endif
+
+       ! precip
+ccc       ft(il,i)= -0.5*sigd(il)*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       ft(il,i)= -sigd(il)*lvcp(il,i)*evap(il,i)
+        rat=cpn(il,i-1)*cpinv
+c
+      if (cvflag_grav) then
+       ft(il,i)=ft(il,i)-0.009*grav*sigd(il)
+     :   *(mp(il,i+1)*t_wake(il,i)*b(il,i)
+     :   -mp(il,i)*t_wake(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.01*sigd(il)*wt(il,i)*(cl-cpd)*water(il,i+1)
+     :           *(t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv
+       ftd(il,i)=ft(il,i)
+        ! fin precip
+c
+           ! sature
+       ft(il,i)=ft(il,i)+0.01*grav*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+
+c
+      IF (iflag_mix .eq. 0) then
+       ft(il,i)=ft(il,i)+0.01*grav*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      ENDIF
+c
+      else  ! cvflag_grav
+       ft(il,i)=ft(il,i)-0.09*sigd(il)
+     :   *(mp(il,i+1)*t_wake(il,i)*b(il,i)
+     :   -mp(il,i)*t_wake(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.01*sigd(il)*wt(il,i)*(cl-cpd)*water(il,i+1)
+     :           *(t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv
+       ftd(il,i)=ft(il,i)
+        ! fin precip
+c
+           ! sature
+       ft(il,i)=ft(il,i)+0.1*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)
+     :    +(gz(il,i+1)-gz(il,i))*cpinv)
+     :    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+
+c
+      IF (iflag_mix .eq. 0) then
+       ft(il,i)=ft(il,i)+0.1*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)
+     :    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      ENDIF
+      endif ! cvflag_grav
+
+
+        if (cvflag_grav) then
+c sb: on ne fait pas encore la correction permettant de mieux
+c conserver l'eau:
+c jyg: correction permettant de mieux conserver l'eau:
+ccc         fr(il,i)=0.5*sigd(il)*(evap(il,i)+evap(il,i+1))
+         fr(il,i)=sigd(il)*evap(il,i)
+     :        +0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr_wake(il,i))
+     :        -mp(il,i)*(rp(il,i)-rr_wake(il,i-1)))*dpinv
+         fqd(il,i)=fr(il,i)    ! precip
+
+         fu(il,i)=0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        else  ! cvflag_grav
+ccc         fr(il,i)=0.5*sigd(il)*(evap(il,i)+evap(il,i+1))
+         fr(il,i)=sigd(il)*evap(il,i)
+     :        +0.1*(mp(il,i+1)*(rp(il,i+1)-rr_wake(il,i))
+     :             -mp(il,i)*(rp(il,i)-rr_wake(il,i-1)))*dpinv
+         fqd(il,i)=fr(il,i)    ! precip
+
+         fu(il,i)=0.1*(mp(il,i+1)*(up(il,i+1)-u(il,i))
+     :             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=0.1*(mp(il,i+1)*(vp(il,i+1)-v(il,i))
+     :             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        endif ! cvflag_grav
+
+
+      if (cvflag_grav) then
+       fr(il,i)=fr(il,i)+0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      else  ! cvflag_grav
+       fr(il,i)=fr(il,i)+0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))
+     :           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.1*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))
+     :             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.1*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))
+     :             -ad(il)*(v(il,i)-v(il,i-1)))
+      endif ! cvflag_grav
+
+      endif ! i
+1350  continue
+
+!AC!      do k=1,ntra
+!AC!       do il=1,ncum
+!AC!        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+!AC!         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!AC!         cpinv=1.0/cpn(il,i)
+!AC!         if (cvflag_grav) then
+!AC!           ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
+!AC!     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+!AC!     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+!AC!         else
+!AC!           ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
+!AC!     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+!AC!     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+!AC!         endif
+!AC!        endif
+!AC!       enddo
+!AC!      enddo
+
+      do 480 k=1,i-1
+c
+       do il = 1,ncum
+        awat(il)=elij(il,k,i)-(1.-ep(il,i))*clw(il,i)
+        awat(il)=max(awat(il),0.0)
+       enddo
+c
+      IF (iflag_mix .ne. 0) then
+       do il=1,ncum
+        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+       if (cvflag_grav) then
+      ft(il,i)=ft(il,i)
+     :       +0.01*grav*dpinv*ment(il,k,i)*(hent(il,k,i)-h(il,i)
+     :       +t(il,i)*(cpv-cpd)*(rr(il,i)+awat(il)-Qent(il,k,i)))*cpinv
+
+c
+c
+       else
+      ft(il,i)=ft(il,i)
+     :       +0.1*dpinv*ment(il,k,i)*(hent(il,k,i)-h(il,i)
+     :       +t(il,i)*(cpv-cpd)*(rr(il,i)+awat(il)-Qent(il,k,i)))*cpinv
+       endif  !cvflag_grav
+       endif  ! i
+       enddo
+      ENDIF
+c
+       do 1370 il=1,ncum
+        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+       if (cvflag_grav) then
+      fr(il,i)=fr(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-awat(il)-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      else  ! cvflag_grav
+      fr(il,i)=fr(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-awat(il)-rr(il,i))
+      fu(il,i)=fu(il,i)
+     :   +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)
+     :   +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      endif ! cvflag_grav
+
+c (saturated updrafts resulting from mixing)        ! cld
+        qcond(il,i)=qcond(il,i)+(elij(il,k,i)-awat(il)) ! cld
+        nqcond(il,i)=nqcond(il,i)+1.                ! cld
+      endif ! i
+1370  continue
+480   continue
+
+!AC!      do j=1,ntra
+!AC!       do k=1,i-1
+!AC!        do il=1,ncum
+!AC!         if (i.le.inb(il) .and. iflag(il) .le. 1) then
+!AC!          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!AC!          cpinv=1.0/cpn(il,i)
+!AC!          if (cvflag_grav) then
+!AC!           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+!AC!     :        *(traent(il,k,i,j)-tra(il,i,j))
+!AC!          else
+!AC!           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+!AC!     :        *(traent(il,k,i,j)-tra(il,i,j))
+!AC!          endif
+!AC!         endif
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+
+      do 490 k=i,nl+1
+c
+      IF (iflag_mix .ne. 0) then
+       do il=1,ncum
+        if (i.le.inb(il) .and. k.le.inb(il)
+     $               .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+       if (cvflag_grav) then
+      ft(il,i)=ft(il,i)
+     :       +0.01*grav*dpinv*ment(il,k,i)*(hent(il,k,i)-h(il,i)
+     :       +t(il,i)*(cpv-cpd)*(rr(il,i)-Qent(il,k,i)))*cpinv
+c
+c
+       else
+      ft(il,i)=ft(il,i)
+     :       +0.1*dpinv*ment(il,k,i)*(hent(il,k,i)-h(il,i)
+     :       +t(il,i)*(cpv-cpd)*(rr(il,i)-Qent(il,k,i)))*cpinv
+       endif  !cvflag_grav
+       endif  ! i
+       enddo
+      ENDIF
+c
+       do 1380 il=1,ncum
+        if (i.le.inb(il) .and. k.le.inb(il)
+     $               .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+         if (cvflag_grav) then
+         fr(il,i)=fr(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         else  ! cvflag_grav
+         fr(il,i)=fr(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)
+     :         +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         endif ! cvflag_grav
+        endif ! i and k
+1380   continue
+490   continue
+
+!AC!      do j=1,ntra
+!AC!       do k=i,nl+1
+!AC!        do il=1,ncum
+!AC!         if (i.le.inb(il) .and. k.le.inb(il)
+!AC!     $                .and. iflag(il) .le. 1) then
+!AC!          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!AC!          cpinv=1.0/cpn(il,i)
+!AC!          if (cvflag_grav) then
+!AC!           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+!AC!     :         *(traent(il,k,i,j)-tra(il,i,j))
+!AC!          else
+!AC!           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+!AC!     :             *(traent(il,k,i,j)-tra(il,i,j))
+!AC!          endif
+!AC!         endif ! i and k
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+
+c sb: interface with the cloud parameterization:          ! cld
+
+      do k=i+1,nl
+       do il=1,ncum
+        if (k.le.inb(il) .and. i.le.inb(il)
+     $               .and. iflag(il) .le. 1) then         ! cld
+C (saturated downdrafts resulting from mixing)            ! cld
+          qcond(il,i)=qcond(il,i)+elij(il,k,i)            ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+        endif                                             ! cld
+       enddo                                              ! cld
+      enddo                                               ! cld
+
+C (particular case: no detraining level is found)         ! cld
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nent(il,i).eq.0
+     $                 .and. iflag(il) .le. 1) then       ! cld
+          qcond(il,i)=qcond(il,i)+(1.-ep(il,i))*clw(il,i) ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+       endif                                              ! cld
+      enddo                                               ! cld
+
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nqcond(il,i).ne.0
+     $                   .and. iflag(il) .le. 1) then     ! cld
+          qcond(il,i)=qcond(il,i)/nqcond(il,i)            ! cld
+       endif                                              ! cld
+      enddo
+
+!AC!      do j=1,ntra
+!AC!       do il=1,ncum
+!AC!        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+!AC!         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!AC!         cpinv=1.0/cpn(il,i)
+!AC!
+!AC!         if (cvflag_grav) then
+!AC!          ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
+!AC!     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+!AC!     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
+!AC!         else
+!AC!          ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
+!AC!     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+!AC!     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
+!AC!         endif
+!AC!        endif ! i
+!AC!       enddo
+!AC!      enddo
+
+
+500   continue
+
+
+c   ***   move the detrainment at level inb down to level inb-1   ***
+c   ***        in such a way as to preserve the vertically        ***
+c   ***          integrated enthalpy and water tendencies         ***
+c
+c Correction bug le 18-03-09
+      do 503 il=1,ncum
+      IF (iflag(il) .le. 1) THEN
+        if (cvflag_grav) then
+      ax=0.01*grav*ment(il,inb(il),inb(il))*(hp(il,inb(il))
+     : -h(il,inb(il))+t(il,inb(il))*(cpv-cpd)
+     : *(rr(il,inb(il))-qent(il,inb(il),inb(il))))
+     :  /(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
+      ft(il,inb(il))=ft(il,inb(il))-ax
+      ft(il,inb(il)-1)=ft(il,inb(il)-1)+ax*cpn(il,inb(il))
+     :    *(ph(il,inb(il))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)
+     :    *(ph(il,inb(il)-1)-ph(il,inb(il))))
+
+      bx=0.01*grav*ment(il,inb(il),inb(il))*(qent(il,inb(il),inb(il))
+     :    -rr(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fr(il,inb(il))=fr(il,inb(il))-bx
+      fr(il,inb(il)-1)=fr(il,inb(il)-1)
+     :   +bx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :      /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      cx=0.01*grav*ment(il,inb(il),inb(il))*(uent(il,inb(il),inb(il))
+     :       -u(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fu(il,inb(il))=fu(il,inb(il))-cx
+      fu(il,inb(il)-1)=fu(il,inb(il)-1)
+     :     +cx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :        /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      dx=0.01*grav*ment(il,inb(il),inb(il))*(vent(il,inb(il),inb(il))
+     :      -v(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fv(il,inb(il))=fv(il,inb(il))-dx
+      fv(il,inb(il)-1)=fv(il,inb(il)-1)
+     :    +dx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :       /(ph(il,inb(il)-1)-ph(il,inb(il)))
+       else
+       ax=0.1*ment(il,inb(il),inb(il))*(hp(il,inb(il))
+     : -h(il,inb(il))+t(il,inb(il))*(cpv-cpd)
+     : *(rr(il,inb(il))-qent(il,inb(il),inb(il))))
+     :  /(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
+      ft(il,inb(il))=ft(il,inb(il))-ax
+      ft(il,inb(il)-1)=ft(il,inb(il)-1)+ax*cpn(il,inb(il))
+     :    *(ph(il,inb(il))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)
+     :    *(ph(il,inb(il)-1)-ph(il,inb(il))))
+
+      bx=0.1*ment(il,inb(il),inb(il))*(qent(il,inb(il),inb(il))
+     :    -rr(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fr(il,inb(il))=fr(il,inb(il))-bx
+      fr(il,inb(il)-1)=fr(il,inb(il)-1)
+     :   +bx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :      /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      cx=0.1*ment(il,inb(il),inb(il))*(uent(il,inb(il),inb(il))
+     :       -u(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fu(il,inb(il))=fu(il,inb(il))-cx
+      fu(il,inb(il)-1)=fu(il,inb(il)-1)
+     :     +cx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :        /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      dx=0.1*ment(il,inb(il),inb(il))*(vent(il,inb(il),inb(il))
+     :      -v(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fv(il,inb(il))=fv(il,inb(il))-dx
+      fv(il,inb(il)-1)=fv(il,inb(il)-1)
+     :    +dx*(ph(il,inb(il))-ph(il,inb(il)+1))
+     :       /(ph(il,inb(il)-1)-ph(il,inb(il)))
+       endif
+      ENDIF    !iflag
+503   continue
+
+!AC!      do j=1,ntra
+!AC!       do il=1,ncum
+!AC!        IF (iflag(il) .le. 1) THEN
+!AC!	IF (cvflag_grav) then
+!AC!        ex=0.01*grav*ment(il,inb(il),inb(il))
+!AC!     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+!AC!     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
+!AC!        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+!AC!        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+!AC!     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+!AC!     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+!AC!	else
+!AC!        ex=0.1*ment(il,inb(il),inb(il))
+!AC!     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+!AC!     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
+!AC!        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+!AC!        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+!AC!     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+!AC!     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+!AC!        ENDIF   !cvflag grav
+!AC!        ENDIF    !iflag
+!AC!       enddo
+!AC!      enddo
+
+c
+c   ***    homogenize tendencies below cloud base    ***
+c
+c
+      do il=1,ncum
+       asum(il)=0.0
+       bsum(il)=0.0
+       csum(il)=0.0
+       dsum(il)=0.0
+        esum(il)=0.0
+        fsum(il)=0.0
+        gsum(il)=0.0
+        hsum(il)=0.0
+      enddo
+c
+c     do i=1,nl
+c      do il=1,ncum
+c         th_wake(il,i)=t_wake(il,i)*(1000.0/p(il,i))**rdcp
+c      enddo
+c     enddo
+c
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1) .and. iflag(il) .le. 1) then
+cjyg  Saturated part : use T profile
+      asum(il)=asum(il)+(ft(il,i)-ftd(il,i))*(ph(il,i)-ph(il,i+1))
+      bsum(il)=bsum(il)+(fr(il,i)-fqd(il,i))
+     :              *(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                  *(ph(il,i)-ph(il,i+1))
+      csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))
+     :                      *(ph(il,i)-ph(il,i+1))
+      dsum(il)=dsum(il)+t(il,i)*(ph(il,i)-ph(il,i+1))/th(il,i)
+cjyg  Unsaturated part : use T_wake profile
+      esum(il)=esum(il)+ftd(il,i)*(ph(il,i)-ph(il,i+1))
+      fsum(il)=fsum(il)+fqd(il,i)
+     :              *(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))
+     :                  *(ph(il,i)-ph(il,i+1))
+      gsum(il)=gsum(il)+(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))
+     :                      *(ph(il,i)-ph(il,i+1))
+      hsum(il)=hsum(il)+t_wake(il,i)
+     ;                      *(ph(il,i)-ph(il,i+1))/th_wake(il,i)
+        endif
+       enddo
+      enddo
+
+c!!!      do 700 i=1,icb(il)-1
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1) .and. iflag(il) .le. 1) then
+         ftd(il,i)=esum(il)*t_wake(il,i)/(th_wake(il,i)*hsum(il))
+         fqd(il,i)=fsum(il)/gsum(il)
+         ft(il,i)=ftd(il,i)+asum(il)*t(il,i)/(th(il,i)*dsum(il))
+         fr(il,i)=fqd(il,i)+bsum(il)/csum(il)
+        endif
+       enddo
+      enddo
+
+c
+c   ***   Check that moisture stays positive. If not, scale tendencies
+c        in order to ensure moisture positivity
+      DO il = 1,ncum
+      alpha_qpos(il)=1.
+       IF (iflag(il) .le. 1) THEN
+        if (fr(il,1) .le. 0.) then
+            alpha_qpos(il) = max(alpha_qpos(il) ,
+     :	   (-delt*fr(il,1))/
+     :     (s_wake(il)*rr_wake(il,1)+(1.-s_wake(il))*rr(il,1)))
+        end if
+       ENDIF
+      ENDDO
+      DO i = 2,nl
+       DO il = 1,ncum
+        IF (iflag(il) .le. 1) THEN
+          IF (fr(il,i) .le. 0.) THEN
+           alpha_qpos1(il)=max(1. , (-delt*fr(il,i))/
+     :     (s_wake(il)*rr_wake(il,i)+(1.-s_wake(il))*rr(il,i)))
+             IF (alpha_qpos1(il) .ge. alpha_qpos(il))
+     :           alpha_qpos(il)=alpha_qpos1(il)
+          ENDIF
+        ENDIF
+       ENDDO
+      ENDDO
+      DO il = 1,ncum
+       IF (iflag(il) .le. 1 .and. alpha_qpos(il) .gt. 1.001) THEN
+        alpha_qpos(il) = alpha_qpos(il)*1.1
+       ENDIF
+      ENDDO
+      DO il = 1,ncum
+       IF (iflag(il) .le. 1) THEN
+        sigd(il) = sigd(il)/alpha_qpos(il)
+        precip(il) = precip(il)/alpha_qpos(il)
+       ENDIF
+      ENDDO
+      DO i = 1,nl
+       DO il = 1,ncum
+        IF (iflag(il) .le. 1) THEN
+         fr(il,i) = fr(il,i)/alpha_qpos(il)
+         ft(il,i) = ft(il,i)/alpha_qpos(il)
+         fqd(il,i) = fqd(il,i)/alpha_qpos(il)
+         ftd(il,i) = ftd(il,i)/alpha_qpos(il)
+         fu(il,i) = fu(il,i)/alpha_qpos(il)
+         fv(il,i) = fv(il,i)/alpha_qpos(il)
+         m(il,i) = m(il,i)/alpha_qpos(il)
+         mp(il,i) = mp(il,i)/alpha_qpos(il)
+         Vprecip(il,i) = Vprecip(il,i)/alpha_qpos(il)
+        ENDIF
+       ENDDO
+      ENDDO
+      DO i = 1,nl
+      DO j = 1,nl
+       DO il = 1,ncum
+        IF (iflag(il) .le. 1) THEN
+         ment(il,i,j) = ment(il,i,j)/alpha_qpos(il)
+        ENDIF
+       ENDDO
+      ENDDO
+      ENDDO
+
+!AC!      DO j = 1,ntra
+!AC!      DO i = 1,nl
+!AC!       DO il = 1,ncum
+!AC!        IF (iflag(il) .le. 1) THEN
+!AC!         ftra(il,i,j) = ftra(il,i,j)/alpha_qpos(il)
+!AC!        ENDIF
+!AC!       ENDDO
+!AC!      ENDDO
+!AC!      ENDDO
+
+c
+c   ***           reset counter and return           ***
+c
+      do il=1,ncum
+       sig(il,nd)=2.0
+      enddo
+
+
+      do i=1,nd
+       do il=1,ncum
+        upwd(il,i)=0.0
+        dnwd(il,i)=0.0
+       enddo
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        dnwd0(il,i)=-mp(il,i)
+       enddo
+      enddo
+      do i=nl+1,nd
+       do il=1,ncum
+        dnwd0(il,i)=0.
+       enddo
+      enddo
+
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.ge.icb(il) .and. i.le.inb(il)) then
+          upwd(il,i)=0.0
+          dnwd(il,i)=0.0
+        endif
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=1,nl
+        do il=1,ncum
+          up1(il,k,i)=0.0
+          dn1(il,k,i)=0.0
+        enddo
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=i,nl
+        do n=1,i-1
+         do il=1,ncum
+          if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+             up1(il,k,i)=up1(il,k,i)+ment(il,n,k)
+             dn1(il,k,i)=dn1(il,k,i)-ment(il,k,n)
+          endif
+         enddo
+        enddo
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=1,nl
+        do il=1,ncum
+         if(i.ge.icb(il)) then
+          if(k.ge.i.and. k.le.(inb(il))) then
+            upwd(il,i)=upwd(il,i)+m(il,k)
+          endif
+         else
+          if(k.lt.i) then
+            upwd(il,i)=upwd(il,i)+cbmf(il)*wghti(il,k)
+          endif
+        endif
+cc        print *,'cbmf',il,i,k,cbmf(il),wghti(il,k)
+        end do
+       end do
+      end do
+
+      do i=2,nl
+       do k=i,nl
+        do il=1,ncum
+ctest         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+         if (i.le.inb(il).and.k.le.inb(il)) then
+            upwd(il,i)=upwd(il,i)+up1(il,k,i)
+            dnwd(il,i)=dnwd(il,i)+dn1(il,k,i)
+         endif
+cc         print *,'upwd',il,i,k,inb(il),upwd(il,i),m(il,k),up1(il,k,i)
+        enddo
+       enddo
+      enddo
+
+
+c!!!      DO il=1,ncum
+c!!!      do i=icb(il),inb(il)
+c!!!
+c!!!      upwd(il,i)=0.0
+c!!!      dnwd(il,i)=0.0
+c!!!      do k=i,inb(il)
+c!!!      up1=0.0
+c!!!      dn1=0.0
+c!!!      do n=1,i-1
+c!!!      up1=up1+ment(il,n,k)
+c!!!      dn1=dn1-ment(il,k,n)
+c!!!      enddo
+c!!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
+c!!!      dnwd(il,i)=dnwd(il,i)+dn1
+c!!!      enddo
+c!!!      enddo
+c!!!
+c!!!      ENDDO
+
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        determination de la variation de flux ascendant entre
+c        deux niveau non dilue mip
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nl
+       do il=1,ncum
+        mip(il,i)=m(il,i)
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        mip(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+        ma(il,i)=0
+       enddo
+      enddo
+
+      do i=1,nl
+       do j=i,nl
+        do il=1,ncum
+         ma(il,i)=ma(il,i)+m(il,j)
+        enddo
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        ma(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ma(il,i)=0
+        endif
+       enddo
+      enddo
+
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c        icb represente de niveau ou se trouve la
+c        base du nuage , et inb le top du nuage
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nd
+       do il=1,ncum
+        mke(il,i)=upwd(il,i)+dnwd(il,i)
+       enddo
+      enddo
+
+      do i=1,nd
+       DO 999 il=1,ncum
+        rdcp=(rrd*(1.-rr(il,i))-rr(il,i)*rrv)
+     :        /(cpd*(1.-rr(il,i))+rr(il,i)*cpv)
+        tls(il,i)=t(il,i)*(1000.0/p(il,i))**rdcp
+        tps(il,i)=tp(il,i)
+999    CONTINUE
+      enddo
+
+c
+c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+c   ***           of condensed water         ***            ! cld
+c                                                           ! cld
+
+       do i=1,nd                                            ! cld
+        do il=1,ncum                                        ! cld
+         mac(il,i)=0.0                                      ! cld
+         wa(il,i)=0.0                                       ! cld
+         siga(il,i)=0.0                                     ! cld
+         sax(il,i)=0.0                                      ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=minorig, nl                                     ! cld
+        do k=i+1,nl+1                                       ! cld
+         do il=1,ncum                                       ! cld
+          if (i.le.inb(il) .and. k.le.(inb(il)+1)
+     $                     .and. iflag(il) .le. 1) then     ! cld
+            mac(il,i)=mac(il,i)+m(il,k)                     ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do j=1,i                                            ! cld
+         do il=1,ncum                                       ! cld
+          if (i.ge.icb(il) .and. i.le.(inb(il)-1)           ! cld
+     :      .and. j.ge.icb(il)
+     :      .and. iflag(il) .le. 1 ) then                   ! cld
+           sax(il,i)=sax(il,i)+rrd*(tvp(il,j)-tv(il,j))     ! cld
+     :        *(ph(il,j)-ph(il,j+1))/p(il,j)                ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (i.ge.icb(il) .and. i.le.(inb(il)-1)            ! cld
+     :       .and. sax(il,i).gt.0.0
+     :       .and. iflag(il) .le. 1 ) then                  ! cld
+           wa(il,i)=sqrt(2.*sax(il,i))                      ! cld
+         endif                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (wa(il,i).gt.0.0 .and. iflag(il) .le. 1)        ! cld
+     :     siga(il,i)=mac(il,i)/wa(il,i)                    ! cld
+     :         *rrd*tvp(il,i)/p(il,i)/100./delta            ! cld
+          siga(il,i) = min(siga(il,i),1.0)                  ! cld
+cIM cf. FH
+         if (iflag_clw.eq.0) then
+          qcondc(il,i)=siga(il,i)*clw(il,i)*(1.-ep(il,i))   ! cld
+     :           + (1.-siga(il,i))*qcond(il,i)              ! cld
+         else if (iflag_clw.eq.1) then
+          qcondc(il,i)=qcond(il,i)                          ! cld
+         endif
+
+        enddo                                               ! cld
+       enddo
+c        print*,'cv3_yield fin'        
+                                              ! cld
+        return
+        end
+
+!AC! et !RomP >>>
+      SUBROUTINE cv3_tracer(nloc,len,ncum,nd,na,
+     &                       ment,sigij,da,phi,phi2,d1a,dam,
+     &                       ep,Vprecip,elij,clw,epmlmMm,eplaMm,
+     &                       icb,inb)
+        implicit none
+
+#include "cv3param.h"
+
+c inputs:
+        integer ncum, nd, na, nloc,len
+        real ment(nloc,na,na),sigij(nloc,na,na)
+	real clw(nloc,nd),elij(nloc,na,na)
+	real ep(nloc,na)
+        integer icb(nloc),inb(nloc)
+        real VPrecip(nloc,nd+1)
+c ouputs:
+        real da(nloc,na),phi(nloc,na,na)
+	real phi2(nloc,na,na)
+	real d1a(nloc,na),dam(nloc,na)
+	real epmlmMm(nloc,na,na),eplaMm(nloc,na)
+! variables pour tracer dans precip de l'AA et des mel
+c local variables:
+        integer i,j,k
+	real epm(nloc,na,na)
+c
+! variables d'Emanuel : du second indice au troisieme
+! --->    tab(i,k,j) -> de l origine k a l arrivee j 
+!  ment, sigij, elij
+! variables personnelles : du troisieme au second indice
+! --->    tab(i,j,k) -> de k a j 
+! phi, phi2
+!
+! initialisations
+c
+       da(:,:)=0.
+       d1a(:,:)=0.
+       dam(:,:)=0.
+       epm(:,:,:)=0.
+       eplaMm(:,:)=0.
+       epmlmMm(:,:,:)=0.
+       phi(:,:,:)=0.
+       phi2(:,:,:)=0.
+c
+!  fraction deau condensee dans les melanges convertie en precip : epm
+! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz
+        do j=1,na
+         do k=1,na
+           do i=1,ncum
+            if(k.ge.icb(i).and.k.le.inb(i).and.
+!!jyg     &         j.ge.k.and.j.le.inb(i)) then
+!!jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)
+     &         j.gt.k.and.j.le.inb(i)) then
+             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/
+     &                     max(elij(i,k,j),1.e-16)
+!!
+             epm(i,j,k)=max(epm(i,j,k),0.0)
+            endif
+           end do 
+         end do 
+        end do 
+
+!
+        do j=1,na
+         do k=1,na
+           do i=1,ncum
+            if(k.ge.icb(i).and.k.le.inb(i)) then
+             eplaMm(i,j)=eplaMm(i,j) + ep(i,j)*clw(i,j)
+     &                  *ment(i,j,k)*(1.-sigij(i,j,k))
+            endif
+           end do 
+         end do 
+        end do
+!
+        do j=1,na
+         do k=1,j-1
+           do i=1,ncum
+            if(k.ge.icb(i).and.k.le.inb(i).and.
+     &         j.le.inb(i)) then
+             epmlmMm(i,j,k)=epm(i,j,k)*elij(i,k,j)*ment(i,k,j)
+            endif
+           end do 
+         end do 
+        end do
+
+!  matrices pour calculer la tendance des concentrations dans cvltr.F90
+        do j=1,na
+          do k=1,na
+            do i=1,ncum
+             da(i,j)=da(i,j)+(1.-sigij(i,k,j))*ment(i,k,j)
+             phi(i,j,k)=sigij(i,k,j)*ment(i,k,j)
+             d1a(i,j)=d1a(i,j)+ment(i,k,j)*ep(i,k)
+     &              *(1.-sigij(i,k,j))
+            if(k.le.j) then
+             dam(i,j)=dam(i,j)+ment(i,k,j)
+     &             *epm(i,k,j)*(1.-ep(i,k))*(1.-sigij(i,k,j)) 
+
+             phi2(i,j,k)=phi(i,j,k)*epm(i,j,k)   
+            endif
+            end do 
+          end do 
+        end do 
+   
+        return
+        end
+!AC! et !RomP <<<
+
+      SUBROUTINE cv3_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :         ,iflag
+     :         ,precip,sig,w0
+     :         ,ft,fq,fu,fv,ftra
+     :         ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape
+     :         ,iflag1
+     :         ,precip1,sig1,w01
+     :         ,ft1,fq1,fu1,fv1,ftra1
+     :         ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1
+     :                               )
+      implicit none
+
+#include "cv3param.h"
+
+c inputs:
+      integer len, ncum, nd, ntra, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      real precip(nloc)
+      real sig(nloc,nd), w0(nloc,nd)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real Ma(nloc,nd)
+      real upwd(nloc,nd),dnwd(nloc,nd),dnwd0(nloc,nd)
+      real qcondc(nloc,nd)
+      real wd(nloc),cape(nloc)
+
+c outputs:
+      integer iflag1(len)
+      real precip1(len)
+      real sig1(len,nd), w01(len,nd)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real Ma1(len,nd)
+      real upwd1(len,nd),dnwd1(len,nd),dnwd01(len,nd)
+      real qcondc1(nloc,nd)
+      real wd1(nloc),cape1(nloc)
+
+c local variables:
+      integer i,k,j
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         iflag1(idcum(i))=iflag(i)
+         wd1(idcum(i))=wd(i)
+         cape1(idcum(i))=cape(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            sig1(idcum(i),k)=sig(i,k)
+            w01(idcum(i),k)=w0(i,k)
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            upwd1(idcum(i),k)=upwd(i,k)
+            dnwd1(idcum(i),k)=dnwd(i,k)
+            dnwd01(idcum(i),k)=dnwd0(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+ 2010     continue
+ 2020   continue
+
+        do 2200 i=1,ncum
+          sig1(idcum(i),nd)=sig(i,nd)
+2200    continue
+
+
+!AC!        do 2100 j=1,ntra
+!AC!c oct3         do 2110 k=1,nl
+!AC!         do 2110 k=1,nd ! oct3
+!AC!          do 2120 i=1,ncum
+!AC!            ftra1(idcum(i),k,j)=ftra(i,k,j)
+!AC! 2120     continue
+!AC! 2110    continue
+!AC! 2100   continue
+        return
+        end
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_routines.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_routines.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_routines.F90	(revision 17)
@@ -0,0 +1,3746 @@
+!
+! $Id: cv3_routines.F 1795 2013-07-18 08:20:28Z emillour $
+!
+!c
+!c
+      SUBROUTINE cv3_param(nd,delt)
+      implicit none
+
+!c------------------------------------------------------------
+!c Set parameters for convectL for iflag_con = 3 
+!c------------------------------------------------------------
+
+!C
+!C   ***  PBCRIT IS THE CRITICAL CLOUD DEPTH (MB) BENEATH WHICH THE ***
+!C   ***      PRECIPITATION EFFICIENCY IS ASSUMED TO BE ZERO     ***
+!C   ***  PTCRIT IS THE CLOUD DEPTH (MB) ABOVE WHICH THE PRECIP. ***     
+!C   ***            EFFICIENCY IS ASSUMED TO BE UNITY            ***
+!C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+!C   ***  SPFAC IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***     
+!C   ***                        OF CLOUD                         ***
+!C
+!C [TAU: CHARACTERISTIC TIMESCALE USED TO COMPUTE ALPHA & BETA]
+!C   ***    ALPHA AND BETA ARE PARAMETERS THAT CONTROL THE RATE OF ***
+!C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+!C   ***    (THEIR STANDARD VALUES ARE 1.0 AND 0.96, RESPECTIVELY) ***
+!C   ***           (BETA MUST BE LESS THAN OR EQUAL TO 1)        ***
+!C
+!C   ***    DTCRIT IS THE CRITICAL BUOYANCY (K) USED TO ADJUST THE ***
+!C   ***                 APPROACH TO QUASI-EQUILIBRIUM           ***
+!C   ***                     IT MUST BE LESS THAN 0              ***
+
+#include "cv3param.h"
+#include "conema3.h"
+
+      integer nd
+      real delt ! timestep (seconds)
+
+
+      CHARACTER (LEN=20) :: modname='cv3_param'
+      CHARACTER (LEN=80) :: abort_message
+
+      LOGICAL,SAVE :: first=.true.
+!$OMP THREADPRIVATE(first)
+
+!c noff: integer limit for convection (nd-noff)
+!c minorig: First level of convection
+
+!c -- limit levels for convection:
+
+      noff    = 1
+      minorig = 1
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+      IF (first) THEN
+
+!c -- "microphysical" parameters:
+      sigdz=0.01
+      spfac  = 0.15
+      pbcrit = 150.0
+      ptcrit = 500.0
+!IM beg: ajout fis. reglage ep
+      flag_epKEorig=1
+      elcrit=0.0003
+      tlcrit=-55.0
+!IM lu dans physiq.def via conf_phys.F90     epmax  = 0.993
+
+      omtrain = 45.0 ! used also for snow (no disctinction rain/snow)
+
+!c -- misc:
+
+      dtovsh = -0.2 ! dT for overshoot
+      dpbase = -40. ! definition cloud base (400m above LCL)
+!ccc      dttrig = 5.   ! (loose) condition for triggering
+      dttrig = 10.   ! (loose) condition for triggering
+      flag_wb=1
+      wbmax = 6.   ! (m/s) adiab updraught speed at LFC (used in cv3p1_closure)
+
+!c -- rate of approach to quasi-equilibrium:
+
+      dtcrit = -2.0
+      tau = 8000.
+
+!c -- interface cloud parameterization:
+
+      delta=0.01  ! cld
+
+!c -- interface with boundary-layer (gust factor): (sb)
+
+      betad=10.0   ! original value (from convect 4.3)
+
+       OPEN(99,file='conv_param.data',status='old',                                  &
+       &          form='formatted',err=9999)
+      READ(99,*,end=9998) dpbase
+      READ(99,*,end=9998) pbcrit
+      READ(99,*,end=9998) ptcrit
+      READ(99,*,end=9998) sigdz
+      READ(99,*,end=9998) spfac
+      READ(99,*,end=9998) tau
+      READ(99,*,end=9998) flag_wb
+      READ(99,*,end=9998) wbmax
+9998  Continue
+      CLOSE(99)
+9999  Continue
+        WRITE(*,*)'dpbase=',dpbase
+        WRITE(*,*)'pbcrit=',pbcrit
+        WRITE(*,*)'ptcrit=',ptcrit
+        WRITE(*,*)'sigdz=',sigdz
+        WRITE(*,*)'spfac=',spfac
+        WRITE(*,*)'tau=',tau
+        WRITE(*,*)'flag_wb =',flag_wb
+        WRITE(*,*)'wbmax =',wbmax
+
+!IM Lecture du fichier ep_param.data
+      OPEN(79,file='ep_param.data',status='old',                                     &
+       &          form='formatted',err=7999)
+      READ(79,*,end=7998) flag_epKEorig
+      READ(79,*,end=7998) elcrit
+      READ(79,*,end=7998) tlcrit
+7998  Continue
+      CLOSE(79)
+7999  Continue
+      WRITE(*,*)'flag_epKEorig',flag_epKEorig
+      WRITE(*,*)'elcrit=',elcrit
+      WRITE(*,*)'tlcrit=',tlcrit
+!IM end: ajout fis. reglage ep
+
+       first = .false.
+      ENDIF
+
+      beta   = 1.0 - delt/tau
+      alpha1 = 1.5e-3
+!cjyg    Correction bug alpha
+      alpha1  = alpha1*1.5
+      alpha  = alpha1 * delt/tau
+!cjyg    Bug
+!ccc increase alpha to compensate W decrease:
+!cc      alpha  = alpha*1.5
+
+      return
+      end SUBROUTINE cv3_param
+
+      SUBROUTINE cv3_prelim(len,nd,ndp1,t,q,p,ph                                     &
+       &                    ,lv,cpn,tv,gz,h,hm,th)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+! "ori": from convect4.3 (vectorized)
+! "convect3": to be exactly consistent with convect3
+!=====================================================================
+
+!c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+!c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+      real th(len,nd)
+
+!c local variables:
+      integer k, i
+      real rdcp
+      real tvx,tvy ! convect3
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+
+!c ori      do 110 k=1,nlp
+! abderr     do 110 k=1,nl ! convect3
+       do 110 k=1,nlp
+      
+        do 100 i=1,len
+!cdebug          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          lv(i,k)= lv0-clmcpv*(t(i,k)-273.15)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+!c ori          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)/eps-q(i,k))
+          rdcp=(rrd*(1.-q(i,k))+q(i,k)*rrv)/cpn(i,k)
+          th(i,k)=t(i,k)*(1000.0/p(i,k))**rdcp
+ 100    continue
+ 110  continue
+!c
+!c gz = phi at the full levels (same as p).
+!c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+!c ori      do 140 k=2,nlp
+      do 140 k=2,nl ! convect3
+        do 130 i=1,len
+        tvx=t(i,k)*(1.+q(i,k)/eps-q(i,k))       !convect3
+        tvy=t(i,k-1)*(1.+q(i,k-1)/eps-q(i,k-1)) !convect3
+        gz(i,k)=gz(i,k-1)+0.5*rrd*(tvx+tvy)                                          & !convect3
+       &          *(p(i,k-1)-p(i,k))/ph(i,k)      !convect3
+!c
+!cc        print *,' gz(',k,')',gz(i,k),' tvx',tvx,' tvy ',tvy
+!c
+!c ori         gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+!c ori    &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+!c
+!c h  = phi + cpT (dry static energy).
+!c hm = phi + cp(T-Tbase)+Lq
+!c
+!c ori      do 170 k=1,nlp
+      do 170 k=1,nl ! convect3
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+
+      return
+      end SUBROUTINE cv3_prelim
+
+      SUBROUTINE cv3_feed(len,nd,t,q,u,v,p,ph,hm,gz                                  &
+       &                  ,p1feed,p2feed,wght                                        &
+       &                  ,wghti,tnk,thnk,qnk,qsnk,unk,vnk                           &
+       &                  ,cpnk,hnk,nk,icb,icbmax,iflag,gznk,plcl)
+      implicit none
+
+!C================================================================
+!C Purpose: CONVECTIVE FEED
+!C
+!C Main differences with cv_feed:
+!C   - ph added in input
+!C	- here, nk(i)=minorig
+!C	- icb defined differently (plcl compared with ph instead of p)
+!C
+!C Main differences with convect3:
+!C 	- we do not compute dplcldt and dplcldr of CLIFT anymore 
+!C	- values iflag different (but tests identical)
+!C   - A,B explicitely defined (!...)
+!C================================================================
+
+#include "cv3param.h"
+#include "cvthermo.h"
+
+!c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), p(len,nd)
+      real u(len,nd), v(len,nd)
+      real hm(len,nd), gz(len,nd)
+      real ph(len,nd+1)
+      real p1feed(len)
+!c,  wght(len)
+      real wght(nd)
+!c input-output
+      real p2feed(len)
+!c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+!c      real   wghti(len)
+      real wghti(len,nd)
+      real   tnk(len), thnk(len), qnk(len), qsnk(len)
+      real   unk(len), vnk(len)
+      real   cpnk(len), hnk(len), gznk(len)
+      real   plcl(len)
+
+!c local variables:
+      integer i, k, iter, niter
+      integer ihmin(len)
+      real work(len)
+      real pup(len),plo(len),pfeed(len)
+      real plclup(len),plcllo(len),plclfeed(len)
+      real posit(len)
+      logical nocond(len)
+!
+!-------------------------------------------------------------------
+! --- Origin level of ascending parcels for convect3:
+!-------------------------------------------------------------------
+
+         do 220 i=1,len
+          nk(i)=minorig
+          gznk(i)=gz(i,nk(i))
+  220    continue
+!
+!-------------------------------------------------------------------
+! --- Adjust feeding layer thickness so that lifting up to the top of
+! --- the feeding layer does not induce condensation (i.e. so that
+! --- plcl < p2feed).
+! --- Method : iterative secant method.
+!-------------------------------------------------------------------
+!
+!c 1- First bracketing of the solution : ph(nk+1), p2feed
+!c
+!c 1.a- LCL associated to p2feed
+      do i = 1,len
+        pup(i) = p2feed(i)
+      enddo
+         call cv3_vertmix(len,nd,iflag,p1feed,pup,p,ph                               &
+       &              ,t,q,u,v,wght                                                  &
+       &              ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plclup)
+!c 1.b- LCL associated to ph(nk+1)
+      do i = 1,len
+        plo(i) = ph(i,nk(i)+1)
+      enddo
+         call cv3_vertmix(len,nd,iflag,p1feed,plo,p,ph                               &
+       &              ,t,q,u,v,wght                                                  &
+       &              ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plcllo)
+!c 2- Iterations
+      niter = 5
+      do iter = 1,niter
+        do i = 1,len
+          plcllo(i) = min(plo(i),plcllo(i))
+          plclup(i) = max(pup(i),plclup(i))
+          nocond(i) = plclup(i).le.pup(i)
+        enddo
+        do i = 1,len
+          if(nocond(i)) then
+             pfeed(i)=pup(i)
+          else
+             pfeed(i) = (pup(i)*(plo(i)-plcllo(i))+                                  &
+       &                plo(i)*(plclup(i)-pup(i)))/                                  &
+       &            (plo(i)-plcllo(i)+plclup(i)-pup(i))
+          endif
+        enddo
+         call cv3_vertmix(len,nd,iflag,p1feed,pfeed,p,ph                             &
+       &              ,t,q,u,v,wght                                                  &
+       &              ,wghti,nk,tnk,thnk,qnk,qsnk,unk,vnk,plclfeed)
+        do i = 1,len
+          posit(i) = (sign(1.,plclfeed(i)-pfeed(i))+1.)*0.5
+          if (plclfeed(i) .eq. pfeed(i)) posit(i) = 1.
+!c- posit = 1 when lcl is below top of feeding layer (plclfeed>pfeed)
+!c-               => pup=pfeed
+!c- posit = 0 when lcl is above top of feeding layer (plclfeed<pfeed)
+!c-               => plo=pfeed
+          pup(i) = posit(i)*pfeed(i) + (1.-posit(i))*pup(i)
+          plo(i) = (1.-posit(i))*pfeed(i) + posit(i)*plo(i)
+          plclup(i) = posit(i)*plclfeed(i) + (1.-posit(i))*plclup(i)
+          plcllo(i) = (1.-posit(i))*plclfeed(i) + posit(i)*plcllo(i)
+        enddo
+      enddo       !  iter
+      do i = 1,len
+        p2feed(i) = pfeed(i)
+        plcl(i) = plclfeed(i)
+      enddo
+!
+      do 175 i=1,len
+         cpnk(i)=cpd*(1.0-qnk(i))+cpv*qnk(i)
+         hnk(i)=gz(i,1)+cpnk(i)*tnk(i)
+ 175  continue
+!
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if( (     ( tnk(i).lt.250.0    )                                              &
+       &       .or.( qnk(i).le.0.0      ) )                                          &
+       &   .and.                                                                     &
+       &       ( iflag(i).eq.0) ) iflag(i)=7
+ 250   continue
+!c
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+
+!c@      do 270 i=1,len
+!c@       icb(i)=nlm
+!c@ 270  continue
+!c@c
+!c@      do 290 k=minorig,nl
+!c@        do 280 i=1,len
+!c@          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+!c@     &    icb(i)=min(icb(i),k)
+!c@ 280    continue
+!c@ 290  continue
+!c@c
+!c@      do 300 i=1,len
+!c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+!c@ 300  continue
+
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+!c
+!c la modification consiste a comparer plcl a ph et non a p:
+!c icb est defini par :  ph(icb)<plcl<ph(icb-1)
+!c@      do 290 k=minorig,nl
+      do 290 k=3,nl-1 ! modif pour que icb soit sup/egal a 2
+        do 280 i=1,len
+          if( ph(i,k).lt.plcl(i) ) icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+!c
+
+!c     print*,'icb dans cv3_feed '
+!c     write(*,'(64i2)') icb(2:len-1)
+!c     call dump2d(64,43,'plcl dans cv3_feed ',plcl(2:len-1))
+
+      do 300 i=1,len
+!c@        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+        if((icb(i).eq.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+
+      do 400 i=1,len
+        icb(i) = icb(i)-1 ! icb sup ou egal a 2
+ 400  continue
+!c
+!c Compute icbmax.
+!c
+      icbmax=2
+      do 310 i=1,len
+!c!        icbmax=max(icbmax,icb(i))
+       if (iflag(i).lt.7) icbmax=max(icbmax,icb(i)) ! sb Jun7th02
+ 310  continue
+
+      return
+      end SUBROUTINE cv3_feed
+
+      SUBROUTINE cv3_undilute1(len,nd,t,qs,gz,plcl,p,icb,tnk,qnk,gznk                &
+       &                       ,tp,tvp,clw,icbs)
+      implicit none
+
+!----------------------------------------------------------------
+! Equivalent de TLIFT entre NK et ICB+1 inclus
+!
+! Differences with convect4:
+!		- specify plcl in input
+!       - icbs is the first level above LCL (may differ from icb)
+!       - in the iterations, used x(icbs) instead x(icb)
+!       - many minor differences in the iterations
+!		- tvp is computed in only one time
+!		- icbs: first level above Plcl (IMIN de TLIFT) in output
+!       - if icbs=icb, compute also tp(icb+1),tvp(icb+1) & clw(icb+1)
+!----------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+!c inputs:
+      integer len, nd
+      integer icb(len)
+      real t(len,nd), qs(len,nd), gz(len,nd)
+      real tnk(len), qnk(len), gznk(len)
+      real p(len,nd)
+      real plcl(len) ! convect3
+
+!c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+!c local variables:
+      integer i, k
+      integer icb1(len), icbs(len), icbsmax2 ! convect3
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real ticb(len), gzicb(len)
+      real qsicb(len) ! convect3
+      real cpinv(len) ! convect3
+
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+
+!c
+!c   ***  Calculate certain parcel quantities, including static energy   ***
+!c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)                                    &
+       &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+        cpinv(i)=1./cpp(i)
+ 330  continue
+!c
+!c   ***   Calculate lifted parcel quantities below cloud base   ***
+!c
+        do i=1,len                      !convect3
+         icb1(i)=MAX(icb(i),2)          !convect3
+         icb1(i)=MIN(icb(i),nl)         !convect3
+!c if icb is below LCL, start loop at ICB+1:
+!c (icbs est le premier niveau au-dessus du LCL)
+         icbs(i)=icb1(i)                !convect3
+         if (plcl(i).lt.p(i,icb1(i))) then
+             icbs(i)=MIN(icbs(i)+1,nl)  !convect3
+         endif
+        enddo                           !convect3
+
+        do i=1,len                      !convect3
+         ticb(i)=t(i,icbs(i))           !convect3
+         gzicb(i)=gz(i,icbs(i))         !convect3
+         qsicb(i)=qs(i,icbs(i))         !convect3
+        enddo                           !convect3
+
+!c
+!c Re-compute icbsmax (icbsmax2):        !convect3
+!c                                       !convect3
+      icbsmax2=2                        !convect3
+      do 310 i=1,len                    !convect3
+        icbsmax2=max(icbsmax2,icbs(i))  !convect3
+ 310  continue                          !convect3
+
+!c initialization outputs:
+
+      do k=1,icbsmax2     ! convect3
+       do i=1,len         ! convect3
+        tp(i,k)  = 0.0    ! convect3
+        tvp(i,k) = 0.0    ! convect3
+        clw(i,k) = 0.0    ! convect3
+       enddo              ! convect3
+      enddo               ! convect3
+
+!c tp and tvp below cloud base:
+
+        do 350 k=minorig,icbsmax2-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))*cpinv(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)/eps-qnk(i)) !whole thing (convect3)
+  340     continue
+  350   continue
+!c
+!c    ***  Find lifted parcel quantities above cloud base    ***
+!c
+        do 360 i=1,len
+         tg=ticb(i)
+!c ori         qg=qs(i,icb(i))
+         qg=qsicb(i) ! convect3
+!cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+!c
+!c First iteration.
+!c
+!c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)                                                & ! convect3
+       &      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+!c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+!c ori          tg=max(tg,35.0)
+!cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+!c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+!c ori          else
+!c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+!c ori          endif
+!c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+!c
+!c Second iteration.
+!c
+
+!c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+!c ori          s=1./s
+!c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+!c ori          tg=max(tg,35.0)
+!cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+!c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+!c ori          else
+!c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+!c ori          end if
+!c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icbs(i))-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+!c ori c approximation here:
+!c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+!c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+!c convect3: no approximation:
+         tp(i,icbs(i))=(ah0(i)-gz(i,icbs(i))-alv*qg)                                 &
+       &                /(cpd+(cl-cpd)*qnk(i))
+
+!c ori         clw(i,icb(i))=qnk(i)-qg
+!c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icbs(i))=qnk(i)-qg
+         clw(i,icbs(i))=max(0.0,clw(i,icbs(i)))
+
+         rg=qg/(1.-qnk(i))
+!c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+!c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icbs(i))=tp(i,icbs(i))*(1.+qg/eps-qnk(i)) !whole thing
+
+  360   continue
+!c
+!c ori      do 380 k=minorig,icbsmax2
+!c ori       do 370 i=1,len
+!c ori         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+!c ori 370   continue
+!c ori 380  continue
+!c
+
+!c -- The following is only for convect3:
+!c
+!c * icbs is the first level above the LCL:
+!c    if plcl<p(icb), then icbs=icb+1
+!c    if plcl>p(icb), then icbs=icb
+!c
+!c * the routine above computes tvp from minorig to icbs (included).
+!c
+!c * to compute buoybase (in cv3_trigger.F), both tvp(icb) and tvp(icb+1)
+!c    must be known. This is the case if icbs=icb+1, but not if icbs=icb.
+!c
+!c * therefore, in the case icbs=icb, we compute tvp at level icb+1
+!c   (tvp at other levels will be computed in cv3_undilute2.F)
+!c
+
+        do i=1,len
+         ticb(i)=t(i,icb(i)+1)
+         gzicb(i)=gz(i,icb(i)+1)
+         qsicb(i)=qs(i,icb(i)+1)
+        enddo
+
+        do 460 i=1,len
+         tg=ticb(i)
+         qg=qsicb(i) ! convect3
+!cdebug         alv=lv0-clmcpv*(ticb(i)-t0)
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+!c
+!c First iteration.
+!c
+!c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=cpd*(1.-qnk(i))+cl*qnk(i)                                                & ! convect3
+       &      +alv*alv*qg/(rrv*ticb(i)*ticb(i)) ! convect3
+          s=1./s
+!c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+!c ori          tg=max(tg,35.0)
+!cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+!c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+!c ori          else
+!c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+!c ori          endif
+!c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+!c
+!c Second iteration.
+!c
+
+!c ori          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+!c ori          s=1./s
+!c ori          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gzicb(i) ! convect3
+          tg=tg+s*(ah0(i)-ahg)
+!c ori          tg=max(tg,35.0)
+!cdebug          tc=tg-t0
+          tc=tg-273.15
+          denom=243.5+tc
+          denom=MAX(denom,1.0) ! convect3
+!c ori          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+!c ori          else
+!c ori           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+!c ori          end if
+!c ori          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+          qg=eps*es/(p(i,icb(i)+1)-es*(1.-eps))
+
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+
+!c ori c approximation here:
+!c ori         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+!c ori     &   -gz(i,icb(i))-alv*qg)/cpd
+
+!c convect3: no approximation:
+         tp(i,icb(i)+1)=(ah0(i)-gz(i,icb(i)+1)-alv*qg)                               &
+       &                /(cpd+(cl-cpd)*qnk(i))
+
+!c ori         clw(i,icb(i))=qnk(i)-qg
+!c ori         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         clw(i,icb(i)+1)=qnk(i)-qg
+         clw(i,icb(i)+1)=max(0.0,clw(i,icb(i)+1))
+
+         rg=qg/(1.-qnk(i))
+!c ori         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+!c convect3: (qg utilise au lieu du vrai mixing ratio rg)
+         tvp(i,icb(i)+1)=tp(i,icb(i)+1)*(1.+qg/eps-qnk(i)) !whole thing
+
+  460   continue
+
+      return
+      end SUBROUTINE cv3_undilute1
+
+      SUBROUTINE cv3_trigger(len,nd,icb,plcl,p,th,tv,tvp,thnk,                       &
+       &                pbase,buoybase,iflag,sig,w0)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!
+!	- computes the cloud base
+!   - triggering (crude in this version)
+!	- relaxation of sig and w0 when no convection
+!
+!	Caution1: if no convection, we set iflag=4 
+!              (it used to be 0 in convect3)
+!
+!	Caution2: at this stage, tvp (and thus buoy) are know up 
+!             through icb only!
+! -> the buoyancy below cloud base not (yet) set to the cloud base buoyancy
+!-------------------------------------------------------------------
+
+#include "cv3param.h"
+
+!c input:
+      integer len, nd
+      integer icb(len)
+      real plcl(len), p(len,nd)
+      real th(len,nd), tv(len,nd), tvp(len,nd)
+      real thnk(len)
+
+!c output:
+      real pbase(len), buoybase(len)
+
+!c input AND output:
+      integer iflag(len)
+      real sig(len,nd), w0(len,nd)
+
+!c local variables:
+      integer i,k
+      real tvpbase, tvbase, tdif, ath, ath1
+
+!c
+!c ***   set cloud base buoyancy at (plcl+dpbase) level buoyancy
+!c
+      do 100 i=1,len
+       pbase(i) = plcl(i) + dpbase
+       tvpbase = tvp(i,icb(i))*(pbase(i)-p(i,icb(i)+1))                              &
+       &                        /(p(i,icb(i))-p(i,icb(i)+1))                         &
+       &         + tvp(i,icb(i)+1)*(p(i,icb(i))-pbase(i))                            &
+       &                          /(p(i,icb(i))-p(i,icb(i)+1))
+       tvbase = tv(i,icb(i))*(pbase(i)-p(i,icb(i)+1))                                &
+       &                      /(p(i,icb(i))-p(i,icb(i)+1))                           &
+       &        + tv(i,icb(i)+1)*(p(i,icb(i))-pbase(i))                              &
+       &                        /(p(i,icb(i))-p(i,icb(i)+1))
+       buoybase(i) = tvpbase - tvbase
+100   continue 
+
+!c
+!c   ***   make sure that column is dry adiabatic between the surface  ***
+!c   ***    and cloud base, and that lifted air is positively buoyant  ***
+!c   ***                         at cloud base                         ***
+!c   ***       if not, return to calling program after resetting       ***
+!c   ***                        sig(i) and w0(i)                       ***
+!c
+
+!c oct3      do 200 i=1,len
+!c oct3
+!c oct3       tdif = buoybase(i)
+!c oct3       ath1 = th(i,1)
+!c oct3       ath  = th(i,icb(i)-1) - dttrig
+!c oct3 
+!c oct3       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+!c oct3         do 60 k=1,nl
+!c oct3            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+!c oct3            sig(i,k) = AMAX1(sig(i,k),0.0)
+!c oct3            w0(i,k)  = beta*w0(i,k)
+!c oct3   60    continue
+!c oct3         iflag(i)=4 ! pour version vectorisee
+!c oct3c convect3         iflag(i)=0
+!c oct3cccc         return
+!c oct3       endif
+!c oct3
+!c oct3200   continue
+ 
+!c -- oct3: on reecrit la boucle 200 (pour la vectorisation)
+
+      do  60 k=1,nl
+      do 200 i=1,len
+
+       tdif = buoybase(i)
+       ath1 = thnk(i)
+       ath  = th(i,icb(i)-1) - dttrig
+
+       if (tdif.lt.dtcrit .or. ath.gt.ath1) then
+            sig(i,k) = beta*sig(i,k) - 2.*alpha*tdif*tdif
+            sig(i,k) = AMAX1(sig(i,k),0.0)
+            w0(i,k)  = beta*w0(i,k)
+        iflag(i)=4 ! pour version vectorisee
+!c convect3         iflag(i)=0
+       endif
+
+200   continue
+ 60   continue
+
+!c fin oct3 --
+
+      return
+      end SUBROUTINE cv3_trigger
+
+      SUBROUTINE cv3_compress( len,nloc,ncum,nd,ntra                                 &
+       &    ,iflag1,nk1,icb1,icbs1                                                   &
+       &    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1                                  &
+       &    ,t1,q1,qs1,u1,v1,gz1,th1                                                 &
+       &    ,tra1                                                                    &
+       &    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1                                    &
+       &    ,sig1,w01                                                                &
+       &    ,iflag,nk,icb,icbs                                                       &
+       &    ,plcl,tnk,qnk,gznk,pbase,buoybase                                        &
+       &    ,t,q,qs,u,v,gz,th                                                        &
+       &    ,tra                                                                     &
+       &    ,h,lv,cpn,p,ph,tv,tp,tvp,clw                                             &
+       &    ,sig,w0  )
+      implicit none
+
+#include "cv3param.h"
+      include 'iniprint.h'
+
+!c inputs:
+      integer len,ncum,nd,ntra,nloc
+      integer iflag1(len),nk1(len),icb1(len),icbs1(len)
+      real plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real pbase1(len),buoybase1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+      real th1(len,nd)
+      real sig1(len,nd), w01(len,nd)
+      real tra1(len,nd,ntra)
+
+!c outputs:
+!c en fait, on a nloc=len pour l'instant (cf cv_driver)
+      integer iflag(nloc),nk(nloc),icb(nloc),icbs(nloc)
+      real plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real pbase(nloc),buoybase(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real th(nloc,nd)
+      real sig(nloc,nd), w0(nloc,nd)
+      real tra(nloc,nd,ntra)
+
+!c local variables:
+      integer i,k,nn,j
+
+      CHARACTER (LEN=20) :: modname='cv3_compress'
+      CHARACTER (LEN=80) :: abort_message
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        sig(nn,k)=sig1(i,k)
+        w0(nn,k)=w01(i,k)
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+        th(nn,k)=th1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+!AC!      do 121 j=1,ntra
+!AC!ccccc      do 111 k=1,nl+1
+!AC!      do 111 k=1,nd
+!AC!       nn=0
+!AC!      do 101 i=1,len
+!AC!      if(iflag1(i).eq.0)then
+!AC!       nn=nn+1
+!AC!       tra(nn,k,j)=tra1(i,k,j)
+!AC!      endif
+!AC! 101  continue
+!AC! 111  continue
+!AC! 121  continue
+
+      if (nn.ne.ncum) then
+         write(lunout,*)'strange! nn not equal to ncum: ',nn,ncum
+         abort_message = ''
+         CALL abort_gcm (modname,abort_message,1)
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      pbase(nn)=pbase1(i)
+      buoybase(nn)=buoybase1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      icbs(nn)=icbs1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      return
+      end SUBROUTINE cv3_compress
+
+      SUBROUTINE cv3_undilute2(nloc,ncum,nd,icb,icbs,nk                              &
+       &                       ,tnk,qnk,gznk,hnk,t,q,qs,gz                           &
+       &                       ,p,h,tv,lv,pbase,buoybase,plcl                        &
+       &                       ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      implicit none
+
+!C---------------------------------------------------------------------
+!C Purpose:
+!C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!C     &
+!C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+!C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+!C     &
+!C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+!C
+!C Main differences convect3/convect4:
+!C	- icbs (input) is the first level above LCL (may differ from icb)
+!C	- many minor differences in the iterations
+!C	- condensed water not removed from tvp in convect3
+!C   - vertical profile of buoyancy computed here (use of buoybase)
+!C   - the determination of inb is different
+!C   - no inb1, only inb in output
+!C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "conema3.h"
+
+!c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), icbs(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real hnk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+      real pbase(nloc), buoybase(nloc), plcl(nloc)
+
+!c outputs:
+      integer inb(nloc)
+      real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd)
+      real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd)
+      real buoy(nloc,nd)
+
+!c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac, pden
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+      integer iposit(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=spfac
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+!c
+!c ---       The procedure is to solve the equation.
+!c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!c
+!c   ***  Calculate certain parcel quantities, including static energy   ***
+!c
+!c
+      do 240 i=1,ncum
+         ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)                                   &
+!cdebug     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)                       &
+       &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+ 240  continue
+!c
+!c
+!c    ***  Find lifted parcel quantities above cloud base    ***
+!c
+!c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+!c ori	    if(k.ge.(icb(i)+1))then
+	    if(k.ge.(icbs(i)+1))then ! convect3
+	      tg=t(i,k)
+	      qg=qs(i,k)
+!cdebug	      alv=lv0-clmcpv*(t(i,k)-t0)
+	      alv=lv0-clmcpv*(t(i,k)-273.15)
+!c
+!c First iteration.
+!c
+!c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+           s=cpd*(1.-qnk(i))+cl*qnk(i)                                               & ! convect3
+       &      +alv*alv*qg/(rrv*t(i,k)*t(i,k)) ! convect3
+	       s=1./s
+!c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+!c ori	       tg=max(tg,35.0)
+!cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+!c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+!c ori	       else
+!c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+!c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+!c
+!c Second iteration.
+!c
+!c ori	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+!c ori	       s=1./s
+!c ori	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+           ahg=cpd*tg+(cl-cpd)*qnk(i)*tg+alv*qg+gz(i,k) ! convect3
+	       tg=tg+s*(ah0(i)-ahg)
+!c ori	       tg=max(tg,35.0)
+!cdebug	       tc=tg-t0
+	       tc=tg-273.15
+	       denom=243.5+tc
+           denom=MAX(denom,1.0) ! convect3
+!c ori	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+!c ori	       else
+!c ori			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+!c ori	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+!c
+!cdebug	       alv=lv0-clmcpv*(t(i,k)-t0)
+	       alv=lv0-clmcpv*(t(i,k)-273.15)
+!c      print*,'cpd dans convect2 ',cpd
+!c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+!c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+
+!c ori c approximation here:
+!c ori        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+
+!c convect3: no approximation:
+           tp(i,k)=(ah0(i)-gz(i,k)-alv*qg)/(cpd+(cl-cpd)*qnk(i))
+
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+!c ori               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+!c convect3: (qg utilise au lieu du vrai mixing ratio rg):
+               tvp(i,k)=tp(i,k)*(1.+qg/eps-qnk(i)) ! whole thing
+            endif
+  290     continue
+  300   continue
+!c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+
+      if(flag_epKEorig.ne.1) THEN
+        do 320 k=1,nl ! convect3
+        do 310 i=1,ncum
+           pden=ptcrit-pbcrit
+           ep(i,k)=(plcl(i)-p(i,k)-pbcrit)/pden*epmax
+           ep(i,k)=max(ep(i,k),0.0)
+           ep(i,k)=min(ep(i,k),epmax)
+           sigp(i,k)=spfac
+ 310    continue
+ 320    continue
+      else
+        do 325 k=1,nl
+        do 315 i=1,ncum
+          if(k.ge.(nk(i)+1))then
+              tca=tp(i,k)-t0
+              if(tca.ge.0.0)then
+               elacrit=elcrit
+              else
+                elacrit=elcrit*(1.0-tca/tlcrit)
+              endif
+              elacrit=max(elacrit,0.0)
+              ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+              ep(i,k)=max(ep(i,k),0.0 )
+              ep(i,k)=min(ep(i,k),epmax )
+              sigp(i,k)=spfac
+          endif
+ 315    continue
+ 325    continue
+      endif
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+!c
+!c dans convect3, tvp est calcule en une seule fois, et sans retirer
+!c l'eau condensee (~> reversible CAPE)
+!c
+!c ori      do 340 k=minorig+1,nl
+!c ori        do 330 i=1,ncum
+!c ori        if(k.ge.(icb(i)+1))then
+!c ori          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+!c oric         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+!c oric         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+!c ori        endif
+!c ori 330    continue
+!c ori 340  continue
+
+!c ori      do 350 i=1,ncum
+!c ori       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+!c ori 350  continue
+
+      do 350 i=1,ncum       ! convect3
+       tp(i,nlp)=tp(i,nl)   ! convect3
+ 350  continue              ! convect3
+!c
+!c=====================================================================
+!c  --- EFFECTIVE VERTICAL PROFILE OF BUOYANCY (convect3 only):
+!c=====================================================================
+
+!c-- this is for convect3 only:
+
+!c first estimate of buoyancy:
+
+      do 500 i=1,ncum
+       do 501 k=1,nl
+        buoy(i,k)=tvp(i,k)-tv(i,k)
+ 501   continue
+ 500  continue
+
+!c set buoyancy=buoybase for all levels below base
+!c for safety, set buoy(icb)=buoybase
+
+      do 505 i=1,ncum
+       do 506 k=1,nl
+        if((k.ge.icb(i)).and.(k.le.nl).and.(p(i,k).ge.pbase(i)))then
+         buoy(i,k)=buoybase(i)
+        endif
+ 506   continue
+!c       buoy(icb(i),k)=buoybase(i)
+      buoy(i,icb(i))=buoybase(i)
+ 505  continue
+
+!c-- end convect3
+
+!c=====================================================================
+!c  --- FIND THE FIRST MODEL LEVEL (INB) ABOVE THE PARCEL'S
+!c  --- LEVEL OF NEUTRAL BUOYANCY
+!c=====================================================================
+!c
+!c-- this is for convect3 only:
+
+      do 510 i=1,ncum
+       inb(i)=nl-1
+       iposit(i) = nl
+ 510  continue
+
+!c
+!c--    iposit(i) = first level, above icb, with positive buoyancy
+      do k = 1,nl-1
+       do i = 1,ncum
+        if (k .ge. icb(i) .and. buoy(i,k) .gt. 0.) then
+          iposit(i) = min(iposit(i),k)
+        endif
+       enddo
+      enddo
+
+      do i = 1,ncum
+       if (iposit(i) .eq. nl) then
+         iposit(i) = icb(i)
+       endif
+      enddo
+
+      do 535 k=1,nl-1
+       do 530 i=1,ncum
+        if ((k.ge.iposit(i)).and.(buoy(i,k).lt.dtovsh)) then
+         inb(i)=MIN(inb(i),k)
+        endif
+ 530   continue
+ 535  continue
+!c
+!c-- end convect3
+
+!c ori      do 510 i=1,ncum
+!c ori        cape(i)=0.0
+!c ori        capem(i)=0.0
+!c ori        inb(i)=icb(i)+1
+!c ori        inb1(i)=inb(i)
+!c ori 510  continue
+!c
+!c Originial Code
+!c
+!c     do 530 k=minorig+1,nl-1
+!c       do 520 i=1,ncum
+!c         if(k.ge.(icb(i)+1))then
+!c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+!c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+!c           cape(i)=cape(i)+by
+!c           if(by.ge.0.0)inb1(i)=k+1
+!c           if(cape(i).gt.0.0)then
+!c             inb(i)=k+1
+!c             capem(i)=cape(i)
+!c           endif
+!c         endif
+!c520    continue
+!c530  continue
+!c     do 540 i=1,ncum
+!c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+!c         cape(i)=capem(i)+byp
+!c         defrac=capem(i)-cape(i)
+!c         defrac=max(defrac,0.001)
+!c         frac(i)=-cape(i)/defrac
+!c         frac(i)=min(frac(i),1.0)
+!c         frac(i)=max(frac(i),0.0)
+!c540   continue
+!c
+!c K Emanuel fix
+!c
+!c     call zilch(byp,ncum)
+!c     do 530 k=minorig+1,nl-1
+!c       do 520 i=1,ncum
+!c         if(k.ge.(icb(i)+1))then
+!c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+!c           cape(i)=cape(i)+by
+!c           if(by.ge.0.0)inb1(i)=k+1
+!c           if(cape(i).gt.0.0)then
+!c             inb(i)=k+1
+!c             capem(i)=cape(i)
+!c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+!c           endif
+!c         endif
+!c520    continue
+!c530  continue
+!c     do 540 i=1,ncum
+!c         inb(i)=max(inb(i),inb1(i))
+!c         cape(i)=capem(i)+byp(i)
+!c         defrac=capem(i)-cape(i)
+!c         defrac=max(defrac,0.001)
+!c         frac(i)=-cape(i)/defrac
+!c         frac(i)=min(frac(i),1.0)
+!c         frac(i)=max(frac(i),0.0)
+!c540   continue
+!c
+!c J Teixeira fix
+!c
+!c ori      call zilch(byp,ncum)
+!c ori      do 515 i=1,ncum
+!c ori        lcape(i)=.true.
+!c ori 515  continue
+!c ori      do 530 k=minorig+1,nl-1
+!c ori        do 520 i=1,ncum
+!c ori          if(cape(i).lt.0.0)lcape(i)=.false.
+!c ori          if((k.ge.(icb(i)+1)).and.lcape(i))then
+!c ori            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+!c ori            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+!c ori            cape(i)=cape(i)+by
+!c ori            if(by.ge.0.0)inb1(i)=k+1
+!c ori            if(cape(i).gt.0.0)then
+!c ori              inb(i)=k+1
+!c ori              capem(i)=cape(i)
+!c ori            endif
+!c ori          endif
+!c ori 520    continue
+!c ori 530  continue
+!c ori      do 540 i=1,ncum
+!c ori          cape(i)=capem(i)+byp(i)
+!c ori          defrac=capem(i)-cape(i)
+!c ori          defrac=max(defrac,0.001)
+!c ori          frac(i)=-cape(i)/defrac
+!c ori          frac(i)=min(frac(i),1.0)
+!c ori          frac(i)=max(frac(i),0.0)
+!c ori 540  continue
+!c
+!c=====================================================================
+!c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+!c=====================================================================
+!c
+      do k = 1,nd
+      do i=1,ncum
+         hp(i,k)=h(i,k)
+      enddo
+      enddo
+
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=hnk(i)+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+
+        return
+        end SUBROUTINE cv3_undilute2
+
+      SUBROUTINE cv3_closure(nloc,ncum,nd,icb,inb                                    &
+       &                      ,pbase,p,ph,tv,buoy                                    &
+       &                      ,sig,w0,cape,m,iflag)
+      implicit none
+
+!===================================================================
+! ---  CLOSURE OF CONVECT3
+!
+! vectorization: S. Bony
+!===================================================================
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+!c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real tv(nloc,nd), buoy(nloc,nd)
+
+!c input/output:
+      real sig(nloc,nd), w0(nloc,nd)
+      integer iflag(nloc)
+
+!c output:
+      real cape(nloc)
+      real m(nloc,nd)
+
+!c local variables:
+      integer i, j, k, icbmax
+      real deltap, fac, w, amu
+      real dtmin(nloc,nd), sigold(nloc,nd)
+      real cbmflast(nloc)
+
+
+!c -------------------------------------------------------
+!c -- Initialization
+!c -------------------------------------------------------
+
+      do k=1,nl
+       do i=1,ncum
+        m(i,k)=0.0
+       enddo
+      enddo
+
+!c -------------------------------------------------------
+!c -- Reset sig(i) and w0(i) for i>inb and i<icb
+!c -------------------------------------------------------
+
+!c update sig and w0 above LNB:
+
+      do 100 k=1,nl-1
+       do 110 i=1,ncum
+        if ((inb(i).lt.(nl-1)).and.(k.ge.(inb(i)+1)))then
+         sig(i,k)=beta*sig(i,k)                                                      &
+       &            +2.*alpha*buoy(i,inb(i))*ABS(buoy(i,inb(i)))
+         sig(i,k)=AMAX1(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+ 110   continue
+ 100  continue
+
+!c compute icbmax:
+
+      icbmax=2
+      do 200 i=1,ncum
+        icbmax=MAX(icbmax,icb(i))
+ 200  continue
+
+!c update sig and w0 below cloud base:
+
+      do 300 k=1,icbmax
+       do 310 i=1,ncum
+        if (k.le.icb(i))then
+         sig(i,k)=beta*sig(i,k)-2.*alpha*buoy(i,icb(i))*buoy(i,icb(i))
+         sig(i,k)=max(sig(i,k),0.0)
+         w0(i,k)=beta*w0(i,k)
+        endif
+310    continue
+300    continue
+
+!c!      if(inb.lt.(nl-1))then
+!c!         do 85 i=inb+1,nl-1
+!c!            sig(i)=beta*sig(i)+2.*alpha*buoy(inb)*
+!c!     1              abs(buoy(inb))
+!c!            sig(i)=max(sig(i),0.0)
+!c!            w0(i)=beta*w0(i)
+!c!   85    continue
+!c!      end if
+
+!c!      do 87 i=1,icb
+!c!         sig(i)=beta*sig(i)-2.*alpha*buoy(icb)*buoy(icb)
+!c!         sig(i)=max(sig(i),0.0)
+!c!         w0(i)=beta*w0(i)
+!c!   87 continue
+
+!c -------------------------------------------------------------
+!c -- Reset fractional areas of updrafts and w0 at initial time
+!c -- and after 10 time steps of no convection
+!c -------------------------------------------------------------
+
+      do 400 k=1,nl-1
+       do 410 i=1,ncum
+        if (sig(i,nd).lt.1.5.or.sig(i,nd).gt.12.0)then
+         sig(i,k)=0.0
+         w0(i,k)=0.0
+        endif
+ 410   continue
+ 400  continue
+
+!c -------------------------------------------------------------
+!c -- Calculate convective available potential energy (cape),
+!c -- vertical velocity (w), fractional area covered by
+!c -- undilute updraft (sig), and updraft mass flux (m)
+!c -------------------------------------------------------------
+
+      do 500 i=1,ncum
+       cape(i)=0.0
+ 500  continue
+
+!c compute dtmin (minimum buoyancy between ICB and given level k):
+
+      do i=1,ncum
+       do k=1,nl
+         dtmin(i,k)=100.0
+       enddo
+      enddo
+
+      do 550 i=1,ncum
+       do 560 k=1,nl
+         do 570 j=minorig,nl
+          if ( (k.ge.(icb(i)+1)).and.(k.le.inb(i)).and.                              &
+       &         (j.ge.icb(i)).and.(j.le.(k-1)) )then
+           dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+          endif
+ 570     continue
+ 560   continue
+ 550  continue
+
+!c the interval on which cape is computed starts at pbase :
+
+      do 600 k=1,nl
+       do 610 i=1,ncum
+
+        if ((k.ge.(icb(i)+1)).and.(k.le.inb(i))) then
+
+         deltap = MIN(pbase(i),ph(i,k-1))-MIN(pbase(i),ph(i,k))
+         cape(i)=cape(i)+rrd*buoy(i,k-1)*deltap/p(i,k-1)
+         cape(i)=AMAX1(0.0,cape(i))
+         sigold(i,k)=sig(i,k)
+
+!c         dtmin(i,k)=100.0
+!c         do 97 j=icb(i),k-1 ! mauvaise vectorisation
+!c          dtmin(i,k)=AMIN1(dtmin(i,k),buoy(i,j))
+!c  97     continue
+
+         sig(i,k)=beta*sig(i,k)+alpha*dtmin(i,k)*ABS(dtmin(i,k))
+         sig(i,k)=max(sig(i,k),0.0)
+         sig(i,k)=amin1(sig(i,k),0.01)
+         fac=AMIN1(((dtcrit-dtmin(i,k))/dtcrit),1.0)
+         w=(1.-beta)*fac*SQRT(cape(i))+beta*w0(i,k)
+         amu=0.5*(sig(i,k)+sigold(i,k))*w
+         m(i,k)=amu*0.007*p(i,k)*(ph(i,k)-ph(i,k+1))/tv(i,k)
+         w0(i,k)=w
+        endif
+
+ 610   continue
+ 600  continue
+
+      do 700 i=1,ncum
+       w0(i,icb(i))=0.5*w0(i,icb(i)+1)
+       m(i,icb(i))=0.5*m(i,icb(i)+1)                                                 &
+       &             *(ph(i,icb(i))-ph(i,icb(i)+1))                                  &
+       &             /(ph(i,icb(i)+1)-ph(i,icb(i)+2))
+       sig(i,icb(i))=sig(i,icb(i)+1)
+       sig(i,icb(i)-1)=sig(i,icb(i))
+ 700  continue
+!c
+!cccc 3. Compute final cloud base mass flux and set iflag to 3 if
+!cccc    cloud base mass flux is exceedingly small and is decreasing (i.e. if
+!cccc    the final mass flux (cbmflast) is greater than the target mass flux
+!cccc    (cbmf) ??).
+!ccc
+!cc      do i = 1,ncum
+!cc       cbmflast(i) = 0.
+!cc      enddo
+!ccc
+!cc      do k= 1,nl
+!cc       do i = 1,ncum
+!cc        IF (k .ge. icb(i) .and. k .le. inb(i)) THEN
+!cc         cbmflast(i) = cbmflast(i)+M(i,k)
+!cc        ENDIF
+!cc       enddo
+!cc      enddo
+!ccc
+!cc      do i = 1,ncum
+!cc       IF (cbmflast(i) .lt. 1.e-6) THEN
+!cc         iflag(i) = 3
+!cc       ENDIF
+!cc      enddo
+!ccc
+!cc      do k= 1,nl
+!cc       do i = 1,ncum
+!cc        IF (iflag(i) .ge. 3) THEN
+!cc         M(i,k) = 0.
+!cc         sig(i,k) = 0.
+!cc         w0(i,k) = 0.
+!cc        ENDIF
+!cc       enddo
+!cc      enddo
+!ccc
+!c!      cape=0.0
+!c!      do 98 i=icb+1,inb
+!c!         deltap = min(pbase,ph(i-1))-min(pbase,ph(i))
+!c!         cape=cape+rrd*buoy(i-1)*deltap/p(i-1)
+!c!         dcape=rrd*buoy(i-1)*deltap/p(i-1)
+!c!         dlnp=deltap/p(i-1)
+!c!         cape=max(0.0,cape)
+!c!         sigold=sig(i)
+
+!c!         dtmin=100.0
+!c!         do 97 j=icb,i-1
+!c!            dtmin=amin1(dtmin,buoy(j))
+!c!   97    continue
+
+!c!         sig(i)=beta*sig(i)+alpha*dtmin*abs(dtmin)
+!c!         sig(i)=max(sig(i),0.0)
+!c!         sig(i)=amin1(sig(i),0.01)
+!c!         fac=amin1(((dtcrit-dtmin)/dtcrit),1.0)
+!c!         w=(1.-beta)*fac*sqrt(cape)+beta*w0(i)
+!c!         amu=0.5*(sig(i)+sigold)*w
+!c!         m(i)=amu*0.007*p(i)*(ph(i)-ph(i+1))/tv(i)
+!c!         w0(i)=w
+!c!   98 continue
+!c!      w0(icb)=0.5*w0(icb+1)
+!c!      m(icb)=0.5*m(icb+1)*(ph(icb)-ph(icb+1))/(ph(icb+1)-ph(icb+2))
+!c!      sig(icb)=sig(icb+1)
+!c!      sig(icb-1)=sig(icb)
+
+       return
+       end SUBROUTINE cv3_closure
+
+      SUBROUTINE cv3_mixing(nloc,ncum,nd,na,ntra,icb,nk,inb                          &
+       &                    ,ph,t,rr,rs,u,v,tra,h,lv,qnk                             &
+       &                    ,unk,vnk,hp,tv,tvp,ep,clw,m,sig                          &
+       &   ,ment,qent,uent,vent,nent,sij,elij,ments,qents,traent)
+      implicit none
+
+!---------------------------------------------------------------------
+! a faire:
+!   - vectorisation de la partie normalisation des flux (do 789...)
+!---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cv3param.h"
+
+!c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc), nk(nloc)
+      real sig(nloc,nd)
+      real qnk(nloc),unk(nloc),vnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra) ! input of convect3
+      real lv(nloc,na), h(nloc,na), hp(nloc,na)
+      real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na)        ! input of convect3
+
+!c outputs:
+      real ment(nloc,na,na), qent(nloc,na,na)
+      real uent(nloc,na,na), vent(nloc,na,na)
+      real sij(nloc,na,na), elij(nloc,na,na)
+      real traent(nloc,nd,nd,ntra)
+      real ments(nloc,nd,nd), qents(nloc,nd,nd)
+      real sigij(nloc,nd,nd)
+      integer nent(nloc,nd)
+
+!c local variables:
+      integer i, j, k, il, im, jm
+      integer num1, num2
+      real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+      real alt, smid, sjmin, sjmax, delp, delm
+      real asij(nloc), smax(nloc), scrit(nloc)
+      real asum(nloc,nd),bsum(nloc,nd),csum(nloc,nd)
+      real wgh
+      real zm(nloc,na)
+      logical lwork(nloc)
+
+!c=====================================================================
+!c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+!c=====================================================================
+
+!c ori        do 360 i=1,ncum*nlp
+        do 361 j=1,nl
+        do 360 i=1,ncum
+          nent(i,j)=0
+!c in convect3, m is computed in cv3_closure
+!c ori          m(i,1)=0.0
+ 360    continue
+ 361    continue
+
+!c ori      do 400 k=1,nlp
+!c ori       do 390 j=1,nlp
+      do 400 j=1,nl
+       do 390 k=1,nl
+          do 385 i=1,ncum
+            qent(i,k,j)=rr(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+!cym            ment(i,k,j)=0.0
+!cym            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+
+!cym
+      ment(1:ncum,1:nd,1:nd)=0.0
+      sij(1:ncum,1:nd,1:nd)=0.0
+      
+!AC!      do k=1,ntra
+!AC!       do j=1,nd  ! instead nlp
+!AC!        do i=1,nd ! instead nlp
+!AC!         do il=1,ncum
+!AC!            traent(il,i,j,k)=tra(il,j,k)
+!AC!         enddo
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+      zm(:,:)=0.
+
+!c=====================================================================
+!c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+!c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+!c --- FRACTION (sij)
+!c=====================================================================
+
+      do 750 i=minorig+1, nl
+
+       do 710 j=minorig,nl
+        do 700 il=1,ncum
+         if( (i.ge.icb(il)).and.(i.le.inb(il)).and.                                  &
+       &      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+
+          rti=qnk(il)-ep(il,i)*clw(il,i)
+          bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd)
+          anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j))
+          denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j)
+          dei=denom
+          if(abs(dei).lt.0.01)dei=0.01
+          sij(il,i,j)=anum/dei
+          sij(il,i,i)=1.0
+          altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+          altem=altem/bf2
+          cwat=clw(il,j)*(1.-ep(il,j))
+          stemp=sij(il,i,j)
+          if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat)                         &
+       &                 .and.j.gt.i)then
+           anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2)
+           denom=denom+lv(il,j)*(rr(il,i)-rti)
+           if(abs(denom).lt.0.01)denom=0.01
+           sij(il,i,j)=anum/denom
+           altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+           altem=altem-(bf2-1.)*cwat
+          end if
+         if(sij(il,i,j).gt.0.0.and.sij(il,i,j).lt.0.95)then
+          qent(il,i,j)=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti
+          uent(il,i,j)=sij(il,i,j)*u(il,i)+(1.-sij(il,i,j))*unk(il)
+          vent(il,i,j)=sij(il,i,j)*v(il,i)+(1.-sij(il,i,j))*vnk(il)
+!c!!!      do k=1,ntra
+!c!!!      traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+!c!!!     :      +(1.-sij(il,i,j))*tra(il,nk(il),k)
+!c!!!      end do
+          elij(il,i,j)=altem
+          elij(il,i,j)=max(0.0,elij(il,i,j))
+          ment(il,i,j)=m(il,i)/(1.-sij(il,i,j))
+          nent(il,i)=nent(il,i)+1
+         end if
+         sij(il,i,j)=max(0.0,sij(il,i,j))
+         sij(il,i,j)=amin1(1.0,sij(il,i,j))
+         endif ! new
+ 700   continue
+ 710  continue
+
+!AC!       do k=1,ntra
+!AC!        do j=minorig,nl
+!AC!         do il=1,ncum
+!AC!          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+!AC!     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+!AC!            traent(il,i,j,k)=sij(il,i,j)*tra(il,i,k)
+!AC!     :            +(1.-sij(il,i,j))*tra(il,nk(il),k)
+!AC!          endif
+!AC!         enddo
+!AC!        enddo
+!AC!       enddo
+
+!c
+!c   ***   if no air can entrain at level i assume that updraft detrains  ***
+!c   ***   at that level and calculate detrained air flux and properties  ***
+!c
+
+!c@      do 170 i=icb(il),inb(il)
+
+      do 740 il=1,ncum
+      if ((i.ge.icb(il)).and.(i.le.inb(il)).and.(nent(il,i).eq.0)) then
+!c@      if(nent(il,i).eq.0)then
+      ment(il,i,i)=m(il,i)
+      qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i)
+      uent(il,i,i)=unk(il)
+      vent(il,i,i)=vnk(il)
+      elij(il,i,i)=clw(il,i)
+!cMAF      sij(il,i,i)=1.0
+      sij(il,i,i)=0.0
+      end if
+ 740  continue
+ 750  continue
+
+!AC!      do j=1,ntra
+!AC!       do i=minorig+1,nl
+!AC!        do il=1,ncum
+!AC!         if (i.ge.icb(il) .and. i.le.inb(il) .and. nent(il,i).eq.0) then
+!AC!          traent(il,i,i,j)=tra(il,nk(il),j)
+!AC!         endif
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+
+      do 100 j=minorig,nl
+      do 101 i=minorig,nl
+      do 102 il=1,ncum
+      if ((j.ge.(icb(il)-1)).and.(j.le.inb(il))                                      &
+       &    .and.(i.ge.icb(il)).and.(i.le.inb(il)))then
+       sigij(il,i,j)=sij(il,i,j)
+      endif
+ 102  continue
+ 101  continue
+ 100  continue
+!c@      enddo
+
+!c@170   continue
+
+!c=====================================================================
+!c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+!c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+!c=====================================================================
+
+      call zilch(asum,nloc*nd)
+      call zilch(csum,nloc*nd)
+      call zilch(csum,nloc*nd)
+
+      do il=1,ncum
+       lwork(il) = .FALSE.
+      enddo
+
+      DO 789 i=minorig+1,nl
+
+      num1=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1
+      enddo
+      if (num1.le.0) goto 789
+
+
+      do 781 il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) then
+        lwork(il)=(nent(il,i).ne.0)
+        qp=qnk(il)-ep(il,i)*clw(il,i)
+        anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i))                                 &
+       &           +(cpv-cpd)*t(il,i)*(qp-rr(il,i))
+        denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp)                                &
+       &           +(cpd-cpv)*t(il,i)*(rr(il,i)-qp)
+        if(abs(denom).lt.0.01)denom=0.01
+        scrit(il)=anum/denom
+        alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp)
+        if(scrit(il).le.0.0.or.alt.le.0.0)scrit(il)=1.0
+        smax(il)=0.0
+        asij(il)=0.0
+       endif
+781   continue
+
+      do 175 j=nl,minorig,-1
+
+      num2=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and.                                    &
+       &      j.ge.(icb(il)-1) .and. j.le.inb(il)                                    &
+       &      .and. lwork(il) ) num2=num2+1
+      enddo
+      if (num2.le.0) goto 175
+
+      do 782 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.                                     &
+       &      j.ge.(icb(il)-1) .and. j.le.inb(il)                                    &
+       &      .and. lwork(il) ) then
+
+       if(sij(il,i,j).gt.1.0e-16.and.sij(il,i,j).lt.0.95)then
+        wgh=1.0
+        if(j.gt.i)then
+         sjmax=max(sij(il,i,j+1),smax(il))
+         sjmax=amin1(sjmax,scrit(il))
+         smax(il)=max(sij(il,i,j),smax(il))
+         sjmin=max(sij(il,i,j-1),smax(il))
+         sjmin=amin1(sjmin,scrit(il))
+         if(sij(il,i,j).lt.(smax(il)-1.0e-16))wgh=0.0
+         smid=amin1(sij(il,i,j),scrit(il))
+        else
+         sjmax=max(sij(il,i,j+1),scrit(il))
+         smid=max(sij(il,i,j),scrit(il))
+         sjmin=0.0
+         if(j.gt.1)sjmin=sij(il,i,j-1)
+         sjmin=max(sjmin,scrit(il))
+        endif
+        delp=abs(sjmax-smid)
+        delm=abs(sjmin-smid)
+        asij(il)=asij(il)+wgh*(delp+delm)
+        ment(il,i,j)=ment(il,i,j)*(delp+delm)*wgh
+       endif
+      endif
+782   continue
+
+175   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        asij(il)=max(1.0e-16,asij(il))
+        asij(il)=1.0/asij(il)
+        asum(il,i)=0.0
+        bsum(il,i)=0.0
+        csum(il,i)=0.0
+       endif
+      enddo
+
+      do 180 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                         &
+       &   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asij(il)
+        endif
+       enddo
+180   continue
+
+      do 190 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                         &
+       &   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         asum(il,i)=asum(il,i)+ment(il,i,j)
+         ment(il,i,j)=ment(il,i,j)*sig(il,j)
+         bsum(il,i)=bsum(il,i)+ment(il,i,j)
+        endif
+       enddo
+190   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        bsum(il,i)=max(bsum(il,i),1.0e-16)
+        bsum(il,i)=1.0/bsum(il,i)
+       endif
+      enddo
+
+      do 195 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                         &
+       &   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asum(il,i)*bsum(il,i)
+        endif
+       enddo
+195   continue
+
+      do 197 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                         &
+       &   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         csum(il,i)=csum(il,i)+ment(il,i,j)
+        endif
+       enddo
+197   continue
+
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                          &
+       &     .and. csum(il,i).lt.m(il,i) ) then
+        nent(il,i)=0
+        ment(il,i,i)=m(il,i)
+        qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i)
+        uent(il,i,i)=unk(il)
+        vent(il,i,i)=vnk(il)
+        elij(il,i,i)=clw(il,i)
+!cMAF        sij(il,i,i)=1.0
+        sij(il,i,i)=0.0
+       endif
+      enddo ! il
+
+!AC!      do j=1,ntra
+!AC!       do il=1,ncum
+!AC!        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+!AC!     :     .and. csum(il,i).lt.m(il,i) ) then
+!AC!         traent(il,i,i,j)=tra(il,nk(il),j)
+!AC!        endif
+!AC!       enddo
+!AC!      enddo
+789   continue
+!c      
+!c MAF: renormalisation de MENT
+      call zilch(zm,nloc*na)
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          zm(il,im)=zm(il,im)+(1.-sij(il,im,jm))*ment(il,im,jm)
+         end do
+        end do
+      end do
+!c
+      do jm=1,nd
+        do im=1,nd
+          do il=1,ncum
+          if(zm(il,im).ne.0.) then
+          ment(il,im,jm)=ment(il,im,jm)*m(il,im)/zm(il,im)
+          endif
+         end do
+       end do
+      end do
+!c
+      do jm=1,nd
+       do im=1,nd
+        do 999 il=1,ncum
+         qents(il,im,jm)=qent(il,im,jm)
+         ments(il,im,jm)=ment(il,im,jm)
+999     continue
+       enddo
+      enddo
+
+      return
+      end SUBROUTINE cv3_mixing
+
+      SUBROUTINE cv3_unsat(nloc,ncum,nd,na,ntra,icb,inb,iflag                        &
+       &              ,t,rr,rs,gz,u,v,tra,p,ph                                       &
+       &              ,th,tv,lv,cpn,ep,sigp,clw                                      &
+       &              ,m,ment,elij,delt,plcl,coef_clos                               &
+       &              ,mp,rp,up,vp,trap,wt,water,evap,b,sigd                         &
+       &              ,wdtrainA,wdtrainM)                                ! RomP
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "cvflag.h"
+
+!c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc)
+      real delt, plcl(nloc)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd),gz(nloc,na)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real ep(nloc,na), sigp(nloc,na), clw(nloc,na)
+      real th(nloc,na),tv(nloc,na),lv(nloc,na),cpn(nloc,na)
+      real m(nloc,na), ment(nloc,na,na), elij(nloc,na,na)
+      real coef_clos(nloc)
+!c
+!c input/output
+      integer iflag(nloc)
+!c
+!c outputs:
+      real mp(nloc,na), rp(nloc,na), up(nloc,na), vp(nloc,na)
+      real water(nloc,na), evap(nloc,na), wt(nloc,na)
+      real trap(nloc,na,ntra)
+      real b(nloc,na), sigd(nloc)
+! 25/08/10 - RomP---- ajout des masses precipitantes ejectees
+! lascendance adiabatique et des flux melanges Pa et Pm.
+! Distinction des wdtrain
+! Pa = wdtrainA     Pm = wdtrainM
+      real  wdtrainA(nloc,na), wdtrainM(nloc,na)
+
+!c local variables
+      integer i,j,k,il,num1,ndp1
+      real tinv, delti
+      real awat, afac, afac1, afac2, bfac
+      real pr1, pr2, sigt, b6, c6, revap, delth
+      real amfac, amp2, xf, tf, fac2, ur, sru, fac, d, af, bf
+      real ampmax
+      real tevap(nloc)
+      real lvcp(nloc,na)
+      real h(nloc,na),hm(nloc,na)
+      real wdtrain(nloc)
+      logical lwork(nloc),mplus(nloc)
+
+
+!c------------------------------------------------------
+
+        delti = 1./delt
+        tinv=1./3.
+
+        mp(:,:)=0.
+
+        do i=1,nl
+         do il=1,ncum
+          mp(il,i)=0.0
+          rp(il,i)=rr(il,i)
+          up(il,i)=u(il,i)
+          vp(il,i)=v(il,i)
+          wt(il,i)=0.001
+          water(il,i)=0.0
+          evap(il,i)=0.0
+          b(il,i)=0.0
+          lvcp(il,i)=lv(il,i)/cpn(il,i)
+         enddo
+        enddo
+!AC!        do k=1,ntra
+!AC!         do i=1,nd
+!AC!          do il=1,ncum
+!AC!           trap(il,i,k)=tra(il,i,k)
+!AC!          enddo
+!AC!         enddo
+!AC!        enddo
+!! RomP >>>
+         do i=1,nd
+          do il=1,ncum
+          wdtrainA(il,i)=0.0     
+          wdtrainM(il,i)=0.0     
+         enddo
+        enddo
+!! RomP <<<
+!c
+!c   ***  check whether ep(inb)=0, if so, skip precipitating    ***
+!c   ***             downdraft calculation                      ***
+!c
+
+        do il=1,ncum
+!!          lwork(il)=.TRUE.
+!!          if(ep(il,inb(il)).lt.0.0001)lwork(il)=.FALSE.
+          lwork(il)= ep(il,inb(il)) .ge. 0.0001
+        enddo
+
+!c   ***  Set the fractionnal area sigd of precipitating downdraughts
+        do il = 1,ncum
+          sigd(il) = sigdz*coef_clos(il)
+        enddo
+
+
+!c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!c
+!c    ***                    begin downdraft loop                    ***
+!c
+!c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!c
+        DO 400 i=nl+1,1,-1
+
+        num1=0
+        do il=1,ncum
+         if ( i.le.inb(il) .and. lwork(il) ) num1=num1+1
+        enddo
+        if (num1.le.0) goto 400
+
+        call zilch(wdtrain,ncum)
+
+!c
+!c   ***  integrate liquid water equation to find condensed water   ***
+!c   ***                and condensed water flux                    ***
+!c
+!c
+!c    ***              calculate detrained precipitation             ***
+!c
+       do il=1,ncum
+        if (i.le.inb(il) .and. lwork(il)) then
+         if (cvflag_grav) then
+          wdtrain(il)=grav*ep(il,i)*m(il,i)*clw(il,i)
+          wdtrainA(il,i) = wdtrain(il)/grav     !   Pa   RomP
+         else
+          wdtrain(il)=10.0*ep(il,i)*m(il,i)*clw(il,i)
+          wdtrainA(il,i) = wdtrain(il)/10.      !   Pa   RomP
+         endif
+        endif
+       enddo
+
+       if(i.gt.1)then
+        do 320 j=1,i-1
+         do il=1,ncum
+          if (i.le.inb(il) .and. lwork(il)) then
+           awat=elij(il,j,i)-(1.-ep(il,i))*clw(il,i)
+           awat=max(awat,0.0)
+           if (cvflag_grav) then
+            wdtrain(il)=wdtrain(il)+grav*awat*ment(il,j,i)
+            wdtrainM(il,i) = wdtrain(il)/grav-wdtrainA(il,i)    !   Pm  RomP
+           else
+            wdtrain(il)=wdtrain(il)+10.0*awat*ment(il,j,i)
+            wdtrainM(il,i) = wdtrain(il)/10.-wdtrainA(il,i)    !   Pm  RomP
+           endif
+          endif
+         enddo
+320     continue
+       endif
+
+!c
+!c    ***    find rain water and evaporation using provisional   ***
+!c    ***              estimates of rp(i)and rp(i-1)             ***
+!c
+
+      do 995 il=1,ncum
+       if (i.le.inb(il) .and. lwork(il)) then
+
+      wt(il,i)=45.0
+
+      if(i.lt.inb(il))then
+       rp(il,i)=rp(il,i+1)                                                           &
+       &       +(cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il,i)
+       rp(il,i)=0.5*(rp(il,i)+rr(il,i))
+      endif
+      rp(il,i)=max(rp(il,i),0.0)
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,inb(il))=rr(il,inb(il))
+
+      if(i.eq.1)then
+       afac=p(il,1)*(rs(il,1)-rp(il,1))/(1.0e4+2000.0*p(il,1)*rs(il,1))
+      else
+       rp(il,i-1)=rp(il,i)                                                           &
+       &          +(cpd*(t(il,i)-t(il,i-1))+gz(il,i)-gz(il,i-1))/lv(il,i)
+       rp(il,i-1)=0.5*(rp(il,i-1)+rr(il,i-1))
+       rp(il,i-1)=amin1(rp(il,i-1),rs(il,i-1))
+       rp(il,i-1)=max(rp(il,i-1),0.0)
+       afac1=p(il,i)*(rs(il,i)-rp(il,i))/(1.0e4+2000.0*p(il,i)*rs(il,i))
+       afac2=p(il,i-1)*(rs(il,i-1)-rp(il,i-1))                                       &
+       &                /(1.0e4+2000.0*p(il,i-1)*rs(il,i-1))
+       afac=0.5*(afac1+afac2)
+      endif
+      if(i.eq.inb(il))afac=0.0
+      afac=max(afac,0.0)
+      bfac=1./(sigd(il)*wt(il,i))
+!c
+!cjyg1
+!ccc        sigt=1.0
+!ccc        if(i.ge.icb)sigt=sigp(i)
+!c prise en compte de la variation progressive de sigt dans
+!c les couches icb et icb-1:
+!c 	pour plcl<ph(i+1), pr1=0 & pr2=1
+!c 	pour plcl>ph(i),   pr1=1 & pr2=0
+!c 	pour ph(i+1)<plcl<ph(i), pr1 est la proportion a cheval
+!c    sur le nuage, et pr2 est la proportion sous la base du
+!c    nuage.
+      pr1=(plcl(il)-ph(il,i+1))/(ph(il,i)-ph(il,i+1))
+      pr1=max(0.,min(1.,pr1))
+      pr2=(ph(il,i)-plcl(il))/(ph(il,i)-ph(il,i+1))
+      pr2=max(0.,min(1.,pr2))
+      sigt=sigp(il,i)*pr1+pr2
+!cjyg2
+!c
+!cjyg----
+!c       b6 = bfac*100.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
+!c       c6 = water(il,i+1) + wdtrain(il)*bfac
+!c        revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+!c        evap(il,i)=sigt*afac*revap
+!c        water(il,i)=revap*revap
+!cc        print *,' i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il) ',
+!cc     $            i,b6,c6,revap,evap(il,i),water(il,i),wdtrain(il)
+!cc---end jyg---
+!c
+!c--------retour à la formulation originale d'Emanuel.
+      b6=bfac*50.*sigd(il)*(ph(il,i)-ph(il,i+1))*sigt*afac
+      c6=water(il,i+1)+bfac*wdtrain(il)                                              &
+       &    -50.*sigd(il)*bfac*(ph(il,i)-ph(il,i+1))*evap(il,i+1)
+      if(c6.gt.0.0)then
+       revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+!cjyg    Dans sa formulation originale, Emanuel calcule l'evaporation par:
+!cc             evap(il,i)=sigt*afac*revap
+!c     ce qui n'est pas correct. Dans cv_routines, la formulation a été modifiee.
+!c     Ici,l'evaporation evap est simplement calculee par l'equation de
+!c     conservation.
+       water(il,i)=revap*revap
+      else
+!cjyg----   Correction : si c6 <= 0, water(il,i)=0.
+       water(il,i) = 0.
+      endif
+!cJYG/IM : ci-dessous formulation originale de KE
+!c      evap(il,i)=-evap(il,i+1)
+!c    :            +(wdtrain(il)+sigd(il)*wt(il,i)*water(il,i+1))
+!c    :                 /(sigd(il)*(ph(il,i)-ph(il,i+1))*50.)
+!c
+!cJYG/IM : ci-dessous modification formulation originale de KE
+!c        pour eliminer oscillations verticales de pluie se produisant
+!c        lorsqu'il y a evaporation totale de la pluie
+!c
+!c       evap(il,i)= +(wdtrain(il)+sigd(il)*wt(il,i)*water(il,i+1)) !itlmd(jyg)
+!c     :                 /(sigd(il)*(ph(il,i)-ph(il,i+1))*100.)
+!c      end if  !itlmd(jyg)
+!cjyg---   Dans tous les cas, evaporation = [tt ce qui entre dans la couche i]
+!c                                    moins [tt ce qui sort de la couche i]
+       evap(il,i)=                                                                   &
+       &       (wdtrain(il)+sigd(il)*wt(il,i)*(water(il,i+1)-water(il,i)))           &
+       &                 /(sigd(il)*(ph(il,i)-ph(il,i+1))*100.)
+!c
+       endif !(i.le.inb(il) .and. lwork(il))
+995   Continue
+!c----------------------------------------------------------------
+!c
+!ccc
+!c    ***  calculate precipitating downdraft mass flux under     ***
+!c    ***              hydrostatic approximation                 ***
+!c
+      Do 996 il = 1,ncum
+       if (i.le.inb(il) .and. lwork(il) .and. i.ne.1) then
+!c
+      tevap(il)=max(0.0,evap(il,i))
+      delth=max(0.001,(th(il,i)-th(il,i-1)))
+      if (cvflag_grav) then
+       mp(il,i)=100.*ginv*lvcp(il,i)*sigd(il)*tevap(il)                              &
+       &              *(p(il,i-1)-p(il,i))/delth
+      else
+       mp(il,i)=10.*lvcp(il,i)*sigd(il)*tevap(il)                                    &
+       &         *(p(il,i-1)-p(il,i))/delth
+      endif
+!c
+       endif !(i.le.inb(il) .and. lwork(il) .and. i.ne.1)
+996   Continue
+!c----------------------------------------------------------------
+!c
+!c    ***           if hydrostatic assumption fails,             ***
+!c    ***   solve cubic difference equation for downdraft theta  ***
+!c    ***  and mass flux from two simultaneous differential eqns ***
+!c
+      Do 997 il = 1,ncum
+       if (i.le.inb(il) .and. lwork(il) .and. i.ne.1) then
+!c
+      amfac=sigd(il)*sigd(il)*70.0*ph(il,i)*(p(il,i-1)-p(il,i))                      &
+       &          *(th(il,i)-th(il,i-1))/(tv(il,i)*th(il,i))
+      amp2=abs(mp(il,i+1)*mp(il,i+1)-mp(il,i)*mp(il,i))
+!c
+      if(amp2.gt.(0.1*amfac))then
+       xf=100.0*sigd(il)*sigd(il)*sigd(il)*(ph(il,i)-ph(il,i+1))
+       tf=b(il,i)-5.0*(th(il,i)-th(il,i-1))*t(il,i)                                  &
+       &               /(lvcp(il,i)*sigd(il)*th(il,i))
+       af=xf*tf+mp(il,i+1)*mp(il,i+1)*tinv
+       bf=2.*(tinv*mp(il,i+1))**3+tinv*mp(il,i+1)*xf*tf                              &
+       &            +50.*(p(il,i-1)-p(il,i))*xf*tevap(il)
+       fac2=1.0
+       if(bf.lt.0.0)fac2=-1.0
+       bf=abs(bf)
+       ur=0.25*bf*bf-af*af*af*tinv*tinv*tinv
+       if(ur.ge.0.0)then
+        sru=sqrt(ur)
+        fac=1.0
+        if((0.5*bf-sru).lt.0.0)fac=-1.0
+        mp(il,i)=mp(il,i+1)*tinv+(0.5*bf+sru)**tinv                                  &
+       &                  +fac*(abs(0.5*bf-sru))**tinv
+       else
+        d=atan(2.*sqrt(-ur)/(bf+1.0e-28))
+        if(fac2.lt.0.0)d=3.14159-d
+        mp(il,i)=mp(il,i+1)*tinv+2.*sqrt(af*tinv)*cos(d*tinv)
+       endif
+       mp(il,i)=max(0.0,mp(il,i))
+
+       if (cvflag_grav) then
+!Cjyg : il y a vraisemblablement une erreur dans la ligne 2 suivante:
+!C il faut diviser par (mp(il,i)*sigd(il)*grav) et non par (mp(il,i)+sigd(il)*0.1).
+!C Et il faut bien revoir les facteurs 100.
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap(il)                        &
+       &   /(mp(il,i)+sigd(il)*0.1)                                                  &
+       & -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)                             &
+       & *sigd(il)*th(il,i))
+       else
+        b(il,i-1)=b(il,i)+100.0*(p(il,i-1)-p(il,i))*tevap(il)                        &
+       &   /(mp(il,i)+sigd(il)*0.1)                                                  &
+       & -10.0*(th(il,i)-th(il,i-1))*t(il,i)/(lvcp(il,i)                             &
+       & *sigd(il)*th(il,i))
+       endif
+       b(il,i-1)=max(b(il,i-1),0.0)
+!c
+      endif !(amp2.gt.(0.1*amfac))
+!c
+!c   ***         limit magnitude of mp(i) to meet cfl condition      ***
+!c
+      ampmax=2.0*(ph(il,i)-ph(il,i+1))*delti
+      amp2=2.0*(ph(il,i-1)-ph(il,i))*delti
+      ampmax=min(ampmax,amp2)
+      mp(il,i)=min(mp(il,i),ampmax)
+!c
+!c    ***      force mp to decrease linearly to zero                 ***
+!c    ***       between cloud base and the surface                   ***
+!c
+!c
+!cc      if(p(il,i).gt.p(il,icb(il)))then
+!cc       mp(il,i)=mp(il,icb(il))*(p(il,1)-p(il,i))/(p(il,1)-p(il,icb(il)))
+!cc      endif
+      if(ph(il,i) .gt. 0.9*plcl(il)) then
+       mp(il,i) = mp(il,i)*(ph(il,1)-ph(il,i))/                                      &
+       &                     (ph(il,1)-0.9*plcl(il))
+      endif
+
+       endif ! (i.le.inb(il) .and. lwork(il) .and. i.ne.1)
+997   Continue
+!c----------------------------------------------------------------
+!c
+!c    ***       find mixing ratio of precipitating downdraft     ***
+!c
+      Do il = 1,ncum
+       if (i.lt.inb(il) .and. lwork(il)) then
+        mplus(il) = mp(il,i).gt.mp(il,i+1)
+       endif ! (i.lt.inb(il) .and. lwork(il))
+      enddo
+!c
+      Do 999 il = 1,ncum
+       if (i.lt.inb(il) .and. lwork(il)) then
+!c
+      rp(il,i)=rr(il,i)
+
+      if(mplus(il))then
+
+       if (cvflag_grav) then
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))                &
+       &   +100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1))                             &
+       &                     *(evap(il,i+1)+evap(il,i))
+       else
+        rp(il,i)=rp(il,i+1)*mp(il,i+1)+rr(il,i)*(mp(il,i)-mp(il,i+1))                &
+       &   +5.*sigd(il)*(ph(il,i)-ph(il,i+1))                                        &
+       &                      *(evap(il,i+1)+evap(il,i))
+       endif
+      rp(il,i)=rp(il,i)/mp(il,i)
+      up(il,i)=up(il,i+1)*mp(il,i+1)+u(il,i)*(mp(il,i)-mp(il,i+1))
+      up(il,i)=up(il,i)/mp(il,i)
+      vp(il,i)=vp(il,i+1)*mp(il,i+1)+v(il,i)*(mp(il,i)-mp(il,i+1))
+      vp(il,i)=vp(il,i)/mp(il,i)
+
+      else ! if (mplus(il))
+
+       if(mp(il,i+1).gt.1.0e-16)then
+        if (cvflag_grav) then
+         rp(il,i)=rp(il,i+1)                                                         &
+       &            +100.*ginv*0.5*sigd(il)*(ph(il,i)-ph(il,i+1))                    &
+       &            *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        else
+         rp(il,i)=rp(il,i+1)                                                         &
+       &           +5.*sigd(il)*(ph(il,i)-ph(il,i+1))                                &
+       &           *(evap(il,i+1)+evap(il,i))/mp(il,i+1)
+        endif
+       up(il,i)=up(il,i+1)
+       vp(il,i)=vp(il,i+1)
+       endif ! (mp(il,i+1).gt.1.0e-16)
+      endif ! (mplus(il)) else if (.not.mplus(il))
+!c
+      rp(il,i)=amin1(rp(il,i),rs(il,i))
+      rp(il,i)=max(rp(il,i),0.0)
+
+      endif ! (i.lt.inb(il) .and. lwork(il))
+999   continue
+!c----------------------------------------------------------------
+!c
+!c    ***       find tracer concentrations in precipitating downdraft     ***
+!c
+!AC!      do j=1,ntra
+!AC!       do il = 1,ncum
+!AC!       if (i.lt.inb(il) .and. lwork(il)) then
+!AC!c
+!AC!         if(mplus(il))then
+!AC!          trap(il,i,j)=trap(il,i+1,j)*mp(il,i+1)
+!AC!     :              +trap(il,i,j)*(mp(il,i)-mp(il,i+1))
+!AC!          trap(il,i,j)=trap(il,i,j)/mp(il,i)
+!AC!         else ! if (mplus(il))
+!AC!          if(mp(il,i+1).gt.1.0e-16)then
+!AC!           trap(il,i,j)=trap(il,i+1,j)
+!AC!          endif
+!AC!         endif ! (mplus(il)) else if (.not.mplus(il))
+!AC!c
+!AC!        endif ! (i.lt.inb(il) .and. lwork(il))
+!AC!       enddo
+!AC!      end do
+
+400   continue
+!c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!c
+!c    ***                    end of downdraft loop                    ***
+!c
+!c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!c
+
+       return
+       end SUBROUTINE cv3_unsat
+
+      SUBROUTINE cv3_yield(nloc,ncum,nd,na,ntra                                      &
+       &                    ,icb,inb,delt                                            &
+       &                    ,t,rr,t_wake,rr_wake,s_wake,u,v,tra                      &
+       &                    ,gz,p,ph,h,hp,lv,cpn,th,th_wake                          &
+       &                    ,ep,clw,m,tp,mp,rp,up,vp,trap                            &
+       &                    ,wt,water,evap,b,sigd                                    &
+       &                    ,ment,qent,hent,iflag_mix,uent,vent                      &
+       &                    ,nent,elij,traent,sig                                    &
+       &                    ,tv,tvp,wghti                                            &
+       &                    ,iflag,precip,Vprecip,ft,fr,fu,fv,ftra                   &
+       &                    ,cbmf,upwd,dnwd,dnwd0,ma,mip                             &
+       &                    ,tls,tps,qcondc,wd                                       &
+       &                    ,ftd,fqd)
+      
+      implicit none
+
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "cvflag.h"
+#include "conema3.h"
+
+!c inputs:
+!c      print*,'cv3_yield apres include'
+      integer iflag_mix
+      integer ncum,nd,na,ntra,nloc
+      integer icb(nloc), inb(nloc)
+      real delt
+      real t(nloc,nd), rr(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real t_wake(nloc,nd), rr_wake(nloc,nd)
+      real s_wake(nloc)
+      real tra(nloc,nd,ntra), sig(nloc,nd)
+      real gz(nloc,na), ph(nloc,nd+1), h(nloc,na), hp(nloc,na)
+      real th(nloc,na), p(nloc,nd), tp(nloc,na)
+      real lv(nloc,na), cpn(nloc,na), ep(nloc,na), clw(nloc,na)
+      real m(nloc,na), mp(nloc,na), rp(nloc,na), up(nloc,na)
+      real vp(nloc,na), wt(nloc,nd), trap(nloc,nd,ntra)
+      real water(nloc,na), evap(nloc,na), b(nloc,na), sigd(nloc)
+      real ment(nloc,na,na), qent(nloc,na,na), uent(nloc,na,na)
+      real hent(nloc,na,na)
+!IM bug   real vent(nloc,na,na), nent(nloc,na), elij(nloc,na,na)
+      real vent(nloc,na,na), elij(nloc,na,na)
+      integer nent(nloc,nd)
+      real traent(nloc,na,na,ntra)
+      real tv(nloc,nd), tvp(nloc,nd), wghti(nloc,nd)
+!c      print*,'cv3_yield declarations 1'
+!c input/output:
+      integer iflag(nloc)
+
+!c outputs:
+      real precip(nloc)
+      real ft(nloc,nd), fr(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftd(nloc,nd), fqd(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real upwd(nloc,nd), dnwd(nloc,nd), ma(nloc,nd)
+      real dnwd0(nloc,nd), mip(nloc,nd)
+      real Vprecip(nloc,nd+1)
+      real tls(nloc,nd), tps(nloc,nd)
+      real qcondc(nloc,nd)                               ! cld
+      real wd(nloc)                                      ! gust
+      real cbmf(nloc)
+!c      print*,'cv3_yield declarations 2'
+!c local variables:
+      integer i,k,il,n,j,num1
+      real rat, delti
+      real ax, bx, cx, dx, ex
+      real cpinv, rdcp, dpinv
+      real awat(nloc)
+      real lvcp(nloc,na), mke(nloc,na)
+      real am(nloc), work(nloc), ad(nloc), amp1(nloc)
+!c!!      real up1(nloc), dn1(nloc)
+      real up1(nloc,nd,nd), dn1(nloc,nd,nd)
+      real asum(nloc), bsum(nloc), csum(nloc), dsum(nloc)
+      real esum(nloc), fsum(nloc), gsum(nloc), hsum(nloc)
+      real th_wake(nloc,nd)
+      real alpha_qpos(nloc),alpha_qpos1(nloc)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd)  ! cld
+      real siga(nloc,nd), sax(nloc,nd), mac(nloc,nd)      ! cld
+
+!c      print*,'cv3_yield declarations 3'
+!c-------------------------------------------------------------
+
+!c initialization:
+
+      delti = 1.0/delt
+!c      print*,'cv3_yield initialisation delt', delt
+!cprecip,Vprecip,ft,fr,fu,fv,ftra
+!c     :                    ,cbmf,upwd,dnwd,dnwd0,ma,mip
+!c     :                    ,tls,tps,qcondc,wd
+!c     :                    ,ftd,fqd  )
+      do il=1,ncum
+       precip(il)=0.0
+       Vprecip(il,nd+1)=0.0
+       wd(il)=0.0     ! gust
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+         Vprecip(il,i)=0.0
+         ft(il,i)=0.0
+         fr(il,i)=0.0
+         fu(il,i)=0.0
+         fv(il,i)=0.0
+         upwd(il,i)=0.0
+         dnwd(il,i)=0.0
+         dnwd0(il,i)=0.0
+         mip(il,i)=0.0
+         ftd(il,i)=0.0
+         fqd(il,i)=0.0
+         qcondc(il,i)=0.0                                ! cld
+         qcond(il,i)=0.0                                 ! cld
+         nqcond(il,i)=0.0                                ! cld
+       enddo 
+      enddo
+!c       print*,'cv3_yield initialisation 2'
+!AC!      do j=1,ntra
+!AC!       do i=1,nd
+!AC!        do il=1,ncum
+!AC!          ftra(il,i,j)=0.0
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+!c       print*,'cv3_yield initialisation 3'
+      do i=1,nl
+       do il=1,ncum
+         lvcp(il,i)=lv(il,i)/cpn(il,i)
+       enddo
+      enddo
+
+
+!c
+!c   ***  calculate surface precipitation in mm/day     ***
+!c
+      do il=1,ncum
+       if(ep(il,inb(il)).ge.0.0001 .and. iflag(il) .le. 1)then
+        if (cvflag_grav) then
+           precip(il)=wt(il,1)*sigd(il)*water(il,1)*86400.*1000.                     &
+       &               /(rowl*grav)
+        else
+         precip(il)=wt(il,1)*sigd(il)*water(il,1)*8640.
+        endif
+       endif
+      enddo
+!c      print*,'cv3_yield apres calcul precip'
+
+!C
+!C   ===  calculate vertical profile of  precipitation in kg/m2/s  ===
+!C
+      do i = 1,nl
+      do il=1,ncum
+       if(ep(il,inb(il)).ge.0.0001 .and. i.le.inb(il)                                &
+       &    .and. iflag(il) .le. 1)then
+        if (cvflag_grav) then
+           VPrecip(il,i) = wt(il,i)*sigd(il)*water(il,i)/grav
+        else
+           VPrecip(il,i) = wt(il,i)*sigd(il)*water(il,i)/10.
+        endif
+       endif
+      enddo
+      enddo
+!C
+!c
+!c   ***  Calculate downdraft velocity scale    ***
+!c   ***  NE PAS UTILISER POUR L'INSTANT ***
+!c
+!c!      do il=1,ncum
+!c!        wd(il)=betad*abs(mp(il,icb(il)))*0.01*rrd*t(il,icb(il))
+!c!     :                                  /(sigd(il)*p(il,icb(il)))
+!c!      enddo
+
+!c
+!c   ***  calculate tendencies of lowest level potential temperature  ***
+!c   ***                      and mixing ratio                        ***
+!c
+      do il=1,ncum
+       work(il)=1.0/(ph(il,1)-ph(il,2))
+       cbmf(il)=0.0
+      enddo
+
+      do k=2,nl
+       do il=1,ncum
+        if (k.ge.icb(il)) then
+         cbmf(il)=cbmf(il)+m(il,k)
+        endif
+       enddo
+      enddo
+
+!c      print*,'cv3_yield avant ft'
+!c AM is the part of cbmf taken from the first level
+      do il=1,ncum
+        am(il)=cbmf(il)*wghti(il,1)
+      enddo
+!c
+      do il=1,ncum
+        if (iflag(il) .le. 1) then
+!c convect3      if((0.1*dpinv*am).ge.delti)iflag(il)=4
+!cjyg  Correction pour conserver l'eau
+!ccc       ft(il,1)=-0.5*lvcp(il,1)*sigd(il)*(evap(il,1)+evap(il,2)) !precip
+       ft(il,1)=-lvcp(il,1)*sigd(il)*evap(il,1)                  !precip
+
+      if (cvflag_grav) then
+        ft(il,1)=ft(il,1)-0.009*grav*sigd(il)*mp(il,2)                               &
+       &                              *t_wake(il,1)*b(il,1)*work(il)
+      else
+        ft(il,1)=ft(il,1)-0.09*sigd(il)*mp(il,2)                                     &
+       &                              *t_wake(il,1)*b(il,1)*work(il)
+      endif
+
+      ft(il,1)=ft(il,1)+0.01*sigd(il)*wt(il,1)*(cl-cpd)*water(il,2)                  &
+       &     *(t_wake(il,2)-t_wake(il,1))*work(il)/cpn(il,1)
+
+      ftd(il,1) = ft(il,1)                        ! fin precip
+
+      if (cvflag_grav) then                  !sature
+      if((0.01*grav*work(il)*am(il)).ge.delti)iflag(il)=1!consist vect
+       ft(il,1)=ft(il,1)+0.01*grav*work(il)*am(il)*(t(il,2)-t(il,1)                  &
+       &            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      else
+       if((0.1*work(il)*am(il)).ge.delti)iflag(il)=1 !consistency vect
+       ft(il,1)=ft(il,1)+0.1*work(il)*am(il)*(t(il,2)-t(il,1)                        &
+       &            +(gz(il,2)-gz(il,1))/cpn(il,1))
+      endif
+      endif  ! iflag
+      enddo
+
+
+       do j=2,nl
+      IF (iflag_mix .gt. 0) then
+        do il=1,ncum
+!c FH WARNING a modifier :
+      cpinv=0.
+!c     cpinv=1.0/cpn(il,1)
+         if (j.le.inb(il) .and. iflag(il) .le. 1) then
+         if (cvflag_grav) then
+          ft(il,1)=ft(il,1)                                                          &
+       &       +0.01*grav*work(il)*ment(il,j,1)*(hent(il,j,1)-h(il,1)                &
+       &       +t(il,1)*(cpv-cpd)*(rr(il,1)-Qent(il,j,1)))*cpinv
+         else
+          ft(il,1)=ft(il,1)                                                          &
+       &       +0.1*work(il)*ment(il,j,1)*(hent(il,j,1)-h(il,1)                      &
+       &       +t(il,1)*(cpv-cpd)*(rr(il,1)-Qent(il,j,1)))*cpinv
+         endif  ! cvflag_grav
+        endif ! j
+       enddo
+       ENDIF
+        enddo
+         ! fin sature
+
+
+      do il=1,ncum
+        if (iflag(il) .le. 1) then
+          if (cvflag_grav) then
+!Cjyg1  Correction pour mieux conserver l'eau (conformite avec CONVECT4.3)
+       fr(il,1)=0.01*grav*mp(il,2)*(rp(il,2)-rr_wake(il,1))*work(il)                 &
+       &          +sigd(il)*evap(il,1)
+!ccc     :          +sigd(il)*0.5*(evap(il,1)+evap(il,2))
+
+       fqd(il,1)=fr(il,1)     !precip
+
+       fr(il,1)=fr(il,1)+0.01*grav*am(il)*(rr(il,2)-rr(il,1))*work(il)  !sature
+
+       fu(il,1)=fu(il,1)+0.01*grav*work(il)*(mp(il,2)*(up(il,2)-u(il,1))             &
+       &         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.01*grav*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))             &
+       &         +am(il)*(v(il,2)-v(il,1)))
+      else  ! cvflag_grav
+       fr(il,1)=0.1*mp(il,2)*(rp(il,2)-rr_wake(il,1))*work(il)                       &
+       &          +sigd(il)*evap(il,1)
+!ccc     :          +sigd(il)*0.5*(evap(il,1)+evap(il,2))
+       fqd(il,1)=fr(il,1)  !precip
+       fr(il,1)=fr(il,1)+0.1*am(il)*(rr(il,2)-rr(il,1))*work(il)
+       fu(il,1)=fu(il,1)+0.1*work(il)*(mp(il,2)*(up(il,2)-u(il,1))                   &
+       &         +am(il)*(u(il,2)-u(il,1)))
+       fv(il,1)=fv(il,1)+0.1*work(il)*(mp(il,2)*(vp(il,2)-v(il,1))                   &
+       &         +am(il)*(v(il,2)-v(il,1)))
+         endif ! cvflag_grav
+       endif  ! iflag
+      enddo ! il
+
+
+!AC!     do j=1,ntra
+!AC!      do il=1,ncum
+!AC!       if (iflag(il) .le. 1) then
+!AC!       if (cvflag_grav) then
+!AC!        ftra(il,1,j)=ftra(il,1,j)+0.01*grav*work(il)
+!AC!    :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+!AC!    :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+!AC!       else
+!AC!        ftra(il,1,j)=ftra(il,1,j)+0.1*work(il)
+!AC!    :                     *(mp(il,2)*(trap(il,2,j)-tra(il,1,j))
+!AC!    :             +am(il)*(tra(il,2,j)-tra(il,1,j)))
+!AC!       endif
+!AC!       endif  ! iflag
+!AC!      enddo
+!AC!     enddo
+
+       do j=2,nl
+       do il=1,ncum
+        if (j.le.inb(il) .and. iflag(il) .le. 1) then
+         if (cvflag_grav) then
+          fr(il,1)=fr(il,1)                                                          &
+       &       +0.01*grav*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)                                                          &
+       &       +0.01*grav*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)                                                          &
+       &       +0.01*grav*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))
+         else   ! cvflag_grav
+          fr(il,1)=fr(il,1)                                                          &
+       &         +0.1*work(il)*ment(il,j,1)*(qent(il,j,1)-rr(il,1))
+          fu(il,1)=fu(il,1)                                                          &
+       &         +0.1*work(il)*ment(il,j,1)*(uent(il,j,1)-u(il,1))
+          fv(il,1)=fv(il,1)                                                          &
+       &         +0.1*work(il)*ment(il,j,1)*(vent(il,j,1)-v(il,1))  ! fin sature
+         endif  ! cvflag_grav
+        endif ! j
+       enddo
+      enddo
+
+!AC!      do k=1,ntra
+!AC!       do j=2,nl
+!AC!        do il=1,ncum
+!AC!         if (j.le.inb(il) .and. iflag(il) .le. 1) then
+!AC!
+!AC!          if (cvflag_grav) then
+!AC!           ftra(il,1,k)=ftra(il,1,k)+0.01*grav*work(il)*ment(il,j,1)
+!AC!     :                *(traent(il,j,1,k)-tra(il,1,k))
+!AC!          else
+!AC!           ftra(il,1,k)=ftra(il,1,k)+0.1*work(il)*ment(il,j,1)
+!AC!     :                *(traent(il,j,1,k)-tra(il,1,k))
+!AC!          endif
+!AC!
+!AC!         endif
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+!c      print*,'cv3_yield apres ft'
+!c
+!c   ***  calculate tendencies of potential temperature and mixing ratio  ***
+!c   ***               at levels above the lowest level                   ***
+!c
+!c   ***  first find the net saturated updraft and downdraft mass fluxes  ***
+!c   ***                      through each level                          ***
+!c
+
+      do 500 i=2,nl+1 ! newvecto: mettre nl au lieu nl+1?
+
+       num1=0
+       do il=1,ncum
+        if(i.le.inb(il) .and. iflag(il) .le. 1)num1=num1+1
+       enddo
+       if(num1.le.0)go to 500
+
+       call zilch(amp1,ncum)
+       call zilch(ad,ncum)
+
+      do 440 k=1,nl+1
+       do 441 il=1,ncum
+        if(i.ge.icb(il)) then
+          if(k.ge.i+1.and. k.le.(inb(il)+1)) then
+            amp1(il)=amp1(il)+m(il,k)
+          endif
+         else
+!c AMP1 is the part of cbmf taken from layers I and lower
+          if(k.le.i) then
+           amp1(il)=amp1(il)+cbmf(il)*wghti(il,k)
+          endif
+        endif
+ 441   continue
+ 440  continue
+
+      do 450 k=1,i
+       do 451 j=i+1,nl+1
+        do 452 il=1,ncum
+         if (i.le.inb(il) .and. j.le.(inb(il)+1)) then
+          amp1(il)=amp1(il)+ment(il,k,j)
+         endif
+452     continue
+451    continue
+450   continue
+
+      do 470 k=1,i-1
+       do 471 j=i,nl+1 ! newvecto: nl au lieu nl+1?
+        do 472 il=1,ncum
+        if (i.le.inb(il) .and. j.le.inb(il)) then
+         ad(il)=ad(il)+ment(il,j,k)
+        endif
+472     continue
+471    continue
+470   continue
+  
+      do 1350 il=1,ncum
+      if (i.le.inb(il) .and. iflag(il) .le. 1) then
+       dpinv=1.0/(ph(il,i)-ph(il,i+1))
+       cpinv=1.0/cpn(il,i)
+
+!c convect3      if((0.1*dpinv*amp1).ge.delti)iflag(il)=4
+      if (cvflag_grav) then
+       if((0.01*grav*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      else
+       if((0.1*dpinv*amp1(il)).ge.delti)iflag(il)=1 ! vecto
+      endif
+
+       ! precip
+!ccc       ft(il,i)= -0.5*sigd(il)*lvcp(il,i)*(evap(il,i)+evap(il,i+1))
+       ft(il,i)= -sigd(il)*lvcp(il,i)*evap(il,i)
+        rat=cpn(il,i-1)*cpinv
+!c
+      if (cvflag_grav) then
+       ft(il,i)=ft(il,i)-0.009*grav*sigd(il)                                         &
+       &   *(mp(il,i+1)*t_wake(il,i)*b(il,i)                                         &
+       &   -mp(il,i)*t_wake(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.01*sigd(il)*wt(il,i)*(cl-cpd)*water(il,i+1)               &
+       &           *(t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv
+       ftd(il,i)=ft(il,i)
+        ! fin precip
+!c
+           ! sature
+       ft(il,i)=ft(il,i)+0.01*grav*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)                &
+       &    +(gz(il,i+1)-gz(il,i))*cpinv)                                            &
+       &    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+
+!c
+      IF (iflag_mix .eq. 0) then
+       ft(il,i)=ft(il,i)+0.01*grav*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)              &
+       &    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      ENDIF
+!c
+      else  ! cvflag_grav
+       ft(il,i)=ft(il,i)-0.09*sigd(il)                                               &
+       &   *(mp(il,i+1)*t_wake(il,i)*b(il,i)                                         &
+       &   -mp(il,i)*t_wake(il,i-1)*rat*b(il,i-1))*dpinv
+       ft(il,i)=ft(il,i)+0.01*sigd(il)*wt(il,i)*(cl-cpd)*water(il,i+1)               &
+       &           *(t_wake(il,i+1)-t_wake(il,i))*dpinv*cpinv
+       ftd(il,i)=ft(il,i)
+        ! fin precip
+!c
+           ! sature
+       ft(il,i)=ft(il,i)+0.1*dpinv*(amp1(il)*(t(il,i+1)-t(il,i)                      &
+       &    +(gz(il,i+1)-gz(il,i))*cpinv)                                            &
+       &    -ad(il)*(t(il,i)-t(il,i-1)+(gz(il,i)-gz(il,i-1))*cpinv))
+
+!c
+      IF (iflag_mix .eq. 0) then
+       ft(il,i)=ft(il,i)+0.1*dpinv*ment(il,i,i)*(hp(il,i)-h(il,i)                    &
+       &    +t(il,i)*(cpv-cpd)*(rr(il,i)-qent(il,i,i)))*cpinv
+      ENDIF
+      endif ! cvflag_grav
+
+
+        if (cvflag_grav) then
+!c sb: on ne fait pas encore la correction permettant de mieux
+!c conserver l'eau:
+!c jyg: correction permettant de mieux conserver l'eau:
+!ccc         fr(il,i)=0.5*sigd(il)*(evap(il,i)+evap(il,i+1))
+         fr(il,i)=sigd(il)*evap(il,i)                                                &
+       &        +0.01*grav*(mp(il,i+1)*(rp(il,i+1)-rr_wake(il,i))                    &
+       &        -mp(il,i)*(rp(il,i)-rr_wake(il,i-1)))*dpinv
+         fqd(il,i)=fr(il,i)    ! precip
+
+         fu(il,i)=0.01*grav*(mp(il,i+1)*(up(il,i+1)-u(il,i))                         &
+       &             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=0.01*grav*(mp(il,i+1)*(vp(il,i+1)-v(il,i))                         &
+       &             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        else  ! cvflag_grav
+!ccc         fr(il,i)=0.5*sigd(il)*(evap(il,i)+evap(il,i+1))
+         fr(il,i)=sigd(il)*evap(il,i)                                                &
+       &        +0.1*(mp(il,i+1)*(rp(il,i+1)-rr_wake(il,i))                          &
+       &             -mp(il,i)*(rp(il,i)-rr_wake(il,i-1)))*dpinv
+         fqd(il,i)=fr(il,i)    ! precip
+
+         fu(il,i)=0.1*(mp(il,i+1)*(up(il,i+1)-u(il,i))                               &
+       &             -mp(il,i)*(up(il,i)-u(il,i-1)))*dpinv
+         fv(il,i)=0.1*(mp(il,i+1)*(vp(il,i+1)-v(il,i))                               &
+       &             -mp(il,i)*(vp(il,i)-v(il,i-1)))*dpinv
+        endif ! cvflag_grav
+
+
+      if (cvflag_grav) then
+       fr(il,i)=fr(il,i)+0.01*grav*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))             &
+       &           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.01*grav*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))               &
+       &             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.01*grav*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))               &
+       &             -ad(il)*(v(il,i)-v(il,i-1)))
+      else  ! cvflag_grav
+       fr(il,i)=fr(il,i)+0.1*dpinv*(amp1(il)*(rr(il,i+1)-rr(il,i))                   &
+       &           -ad(il)*(rr(il,i)-rr(il,i-1)))
+       fu(il,i)=fu(il,i)+0.1*dpinv*(amp1(il)*(u(il,i+1)-u(il,i))                     &
+       &             -ad(il)*(u(il,i)-u(il,i-1)))
+       fv(il,i)=fv(il,i)+0.1*dpinv*(amp1(il)*(v(il,i+1)-v(il,i))                     &
+       &             -ad(il)*(v(il,i)-v(il,i-1)))
+      endif ! cvflag_grav
+
+      endif ! i
+1350  continue
+
+!AC!      do k=1,ntra
+!AC!       do il=1,ncum
+!AC!        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+!AC!         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!AC!         cpinv=1.0/cpn(il,i)
+!AC!         if (cvflag_grav) then
+!AC!           ftra(il,i,k)=ftra(il,i,k)+0.01*grav*dpinv
+!AC!     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+!AC!     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+!AC!         else
+!AC!           ftra(il,i,k)=ftra(il,i,k)+0.1*dpinv
+!AC!     :         *(amp1(il)*(tra(il,i+1,k)-tra(il,i,k))
+!AC!     :           -ad(il)*(tra(il,i,k)-tra(il,i-1,k)))
+!AC!         endif
+!AC!        endif
+!AC!       enddo
+!AC!      enddo
+
+      do 480 k=1,i-1
+!c
+       do il = 1,ncum
+        awat(il)=elij(il,k,i)-(1.-ep(il,i))*clw(il,i)
+        awat(il)=max(awat(il),0.0)
+       enddo
+!c
+      IF (iflag_mix .ne. 0) then
+       do il=1,ncum
+        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+       if (cvflag_grav) then
+      ft(il,i)=ft(il,i)                                                              &
+       &       +0.01*grav*dpinv*ment(il,k,i)*(hent(il,k,i)-h(il,i)                   &
+       &       +t(il,i)*(cpv-cpd)*(rr(il,i)+awat(il)-Qent(il,k,i)))*cpinv
+
+!c
+!c
+       else
+      ft(il,i)=ft(il,i)                                                              &
+       &       +0.1*dpinv*ment(il,k,i)*(hent(il,k,i)-h(il,i)                         &
+       &       +t(il,i)*(cpv-cpd)*(rr(il,i)+awat(il)-Qent(il,k,i)))*cpinv
+       endif  !cvflag_grav
+       endif  ! i
+       enddo
+      ENDIF
+!c
+       do 1370 il=1,ncum
+        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+       if (cvflag_grav) then
+      fr(il,i)=fr(il,i)                                                              &
+       &   +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-awat(il)-rr(il,i))
+      fu(il,i)=fu(il,i)                                                              &
+       &         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)                                                              &
+       &         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      else  ! cvflag_grav
+      fr(il,i)=fr(il,i)                                                              &
+       &   +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-awat(il)-rr(il,i))
+      fu(il,i)=fu(il,i)                                                              &
+       &   +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+      fv(il,i)=fv(il,i)                                                              &
+       &   +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+      endif ! cvflag_grav
+
+!c (saturated updrafts resulting from mixing)        ! cld
+        qcond(il,i)=qcond(il,i)+(elij(il,k,i)-awat(il)) ! cld
+        nqcond(il,i)=nqcond(il,i)+1.                ! cld
+      endif ! i
+1370  continue
+480   continue
+
+!AC!      do j=1,ntra
+!AC!       do k=1,i-1
+!AC!        do il=1,ncum
+!AC!         if (i.le.inb(il) .and. iflag(il) .le. 1) then
+!AC!          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!AC!          cpinv=1.0/cpn(il,i)
+!AC!          if (cvflag_grav) then
+!AC!           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+!AC!     :        *(traent(il,k,i,j)-tra(il,i,j))
+!AC!          else
+!AC!           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+!AC!     :        *(traent(il,k,i,j)-tra(il,i,j))
+!AC!          endif
+!AC!         endif
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+
+      do 490 k=i,nl+1
+!c
+      IF (iflag_mix .ne. 0) then
+       do il=1,ncum
+        if (i.le.inb(il) .and. k.le.inb(il)                                          &
+       &               .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+       if (cvflag_grav) then
+      ft(il,i)=ft(il,i)                                                              &
+       &       +0.01*grav*dpinv*ment(il,k,i)*(hent(il,k,i)-h(il,i)                   &
+       &       +t(il,i)*(cpv-cpd)*(rr(il,i)-Qent(il,k,i)))*cpinv
+!c
+!c
+       else
+      ft(il,i)=ft(il,i)                                                              &
+       &       +0.1*dpinv*ment(il,k,i)*(hent(il,k,i)-h(il,i)                         &
+       &       +t(il,i)*(cpv-cpd)*(rr(il,i)-Qent(il,k,i)))*cpinv
+       endif  !cvflag_grav
+       endif  ! i
+       enddo
+      ENDIF
+!c
+       do 1380 il=1,ncum
+        if (i.le.inb(il) .and. k.le.inb(il)                                          &
+       &               .and. iflag(il) .le. 1) then
+         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+         cpinv=1.0/cpn(il,i)
+
+         if (cvflag_grav) then
+         fr(il,i)=fr(il,i)                                                           &
+       &         +0.01*grav*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)                                                           &
+       &         +0.01*grav*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)                                                           &
+       &         +0.01*grav*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         else  ! cvflag_grav
+         fr(il,i)=fr(il,i)                                                           &
+       &         +0.1*dpinv*ment(il,k,i)*(qent(il,k,i)-rr(il,i))
+         fu(il,i)=fu(il,i)                                                           &
+       &         +0.1*dpinv*ment(il,k,i)*(uent(il,k,i)-u(il,i))
+         fv(il,i)=fv(il,i)                                                           &
+       &         +0.1*dpinv*ment(il,k,i)*(vent(il,k,i)-v(il,i))
+         endif ! cvflag_grav
+        endif ! i and k
+1380   continue
+490   continue
+
+!AC!      do j=1,ntra
+!AC!       do k=i,nl+1
+!AC!        do il=1,ncum
+!AC!         if (i.le.inb(il) .and. k.le.inb(il)
+!AC!     $                .and. iflag(il) .le. 1) then
+!AC!          dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!AC!          cpinv=1.0/cpn(il,i)
+!AC!          if (cvflag_grav) then
+!AC!           ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv*ment(il,k,i)
+!AC!     :         *(traent(il,k,i,j)-tra(il,i,j))
+!AC!          else
+!AC!           ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv*ment(il,k,i)
+!AC!     :             *(traent(il,k,i,j)-tra(il,i,j))
+!AC!          endif
+!AC!         endif ! i and k
+!AC!        enddo
+!AC!       enddo
+!AC!      enddo
+
+!c sb: interface with the cloud parameterization:          ! cld
+
+      do k=i+1,nl
+       do il=1,ncum
+        if (k.le.inb(il) .and. i.le.inb(il)                                          &
+       &               .and. iflag(il) .le. 1) then         ! cld
+!C (saturated downdrafts resulting from mixing)            ! cld
+          qcond(il,i)=qcond(il,i)+elij(il,k,i)            ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+        endif                                             ! cld
+       enddo                                              ! cld
+      enddo                                               ! cld
+
+!C (particular case: no detraining level is found)         ! cld
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nent(il,i).eq.0                                        &
+       &                 .and. iflag(il) .le. 1) then       ! cld
+          qcond(il,i)=qcond(il,i)+(1.-ep(il,i))*clw(il,i) ! cld
+          nqcond(il,i)=nqcond(il,i)+1.                    ! cld
+       endif                                              ! cld
+      enddo                                               ! cld
+
+      do il=1,ncum                                        ! cld
+       if (i.le.inb(il) .and. nqcond(il,i).ne.0                                      &
+       &                   .and. iflag(il) .le. 1) then     ! cld
+          qcond(il,i)=qcond(il,i)/nqcond(il,i)            ! cld
+       endif                                              ! cld
+      enddo
+
+!AC!      do j=1,ntra
+!AC!       do il=1,ncum
+!AC!        if (i.le.inb(il) .and. iflag(il) .le. 1) then
+!AC!         dpinv=1.0/(ph(il,i)-ph(il,i+1))
+!AC!         cpinv=1.0/cpn(il,i)
+!AC!
+!AC!         if (cvflag_grav) then
+!AC!          ftra(il,i,j)=ftra(il,i,j)+0.01*grav*dpinv
+!AC!     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+!AC!     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
+!AC!         else
+!AC!          ftra(il,i,j)=ftra(il,i,j)+0.1*dpinv
+!AC!     :     *(mp(il,i+1)*(trap(il,i+1,j)-tra(il,i,j))
+!AC!     :     -mp(il,i)*(trap(il,i,j)-trap(il,i-1,j)))
+!AC!         endif
+!AC!        endif ! i
+!AC!       enddo
+!AC!      enddo
+
+
+500   continue
+
+
+!c   ***   move the detrainment at level inb down to level inb-1   ***
+!c   ***        in such a way as to preserve the vertically        ***
+!c   ***          integrated enthalpy and water tendencies         ***
+!c
+!c Correction bug le 18-03-09
+      do 503 il=1,ncum
+      IF (iflag(il) .le. 1) THEN
+        if (cvflag_grav) then
+      ax=0.01*grav*ment(il,inb(il),inb(il))*(hp(il,inb(il))                          &
+       & -h(il,inb(il))+t(il,inb(il))*(cpv-cpd)                                      &
+       & *(rr(il,inb(il))-qent(il,inb(il),inb(il))))                                 &
+       &  /(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
+      ft(il,inb(il))=ft(il,inb(il))-ax
+      ft(il,inb(il)-1)=ft(il,inb(il)-1)+ax*cpn(il,inb(il))                           &
+       &    *(ph(il,inb(il))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)                    &
+       &    *(ph(il,inb(il)-1)-ph(il,inb(il))))
+
+      bx=0.01*grav*ment(il,inb(il),inb(il))*(qent(il,inb(il),inb(il))                &
+       &    -rr(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fr(il,inb(il))=fr(il,inb(il))-bx
+      fr(il,inb(il)-1)=fr(il,inb(il)-1)                                              &
+       &   +bx*(ph(il,inb(il))-ph(il,inb(il)+1))                                     &
+       &      /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      cx=0.01*grav*ment(il,inb(il),inb(il))*(uent(il,inb(il),inb(il))                &
+       &       -u(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fu(il,inb(il))=fu(il,inb(il))-cx
+      fu(il,inb(il)-1)=fu(il,inb(il)-1)                                              &
+       &     +cx*(ph(il,inb(il))-ph(il,inb(il)+1))                                   &
+       &        /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      dx=0.01*grav*ment(il,inb(il),inb(il))*(vent(il,inb(il),inb(il))                &
+       &      -v(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fv(il,inb(il))=fv(il,inb(il))-dx
+      fv(il,inb(il)-1)=fv(il,inb(il)-1)                                              &
+       &    +dx*(ph(il,inb(il))-ph(il,inb(il)+1))                                    &
+       &       /(ph(il,inb(il)-1)-ph(il,inb(il)))
+       else
+       ax=0.1*ment(il,inb(il),inb(il))*(hp(il,inb(il))                               &
+       & -h(il,inb(il))+t(il,inb(il))*(cpv-cpd)                                      &
+       & *(rr(il,inb(il))-qent(il,inb(il),inb(il))))                                 &
+       &  /(cpn(il,inb(il))*(ph(il,inb(il))-ph(il,inb(il)+1)))
+      ft(il,inb(il))=ft(il,inb(il))-ax
+      ft(il,inb(il)-1)=ft(il,inb(il)-1)+ax*cpn(il,inb(il))                           &
+       &    *(ph(il,inb(il))-ph(il,inb(il)+1))/(cpn(il,inb(il)-1)                    &
+       &    *(ph(il,inb(il)-1)-ph(il,inb(il))))
+
+      bx=0.1*ment(il,inb(il),inb(il))*(qent(il,inb(il),inb(il))                      &
+       &    -rr(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fr(il,inb(il))=fr(il,inb(il))-bx
+      fr(il,inb(il)-1)=fr(il,inb(il)-1)                                              &
+       &   +bx*(ph(il,inb(il))-ph(il,inb(il)+1))                                     &
+       &      /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      cx=0.1*ment(il,inb(il),inb(il))*(uent(il,inb(il),inb(il))                      &
+       &       -u(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fu(il,inb(il))=fu(il,inb(il))-cx
+      fu(il,inb(il)-1)=fu(il,inb(il)-1)                                              &
+       &     +cx*(ph(il,inb(il))-ph(il,inb(il)+1))                                   &
+       &        /(ph(il,inb(il)-1)-ph(il,inb(il)))
+
+      dx=0.1*ment(il,inb(il),inb(il))*(vent(il,inb(il),inb(il))                      &
+       &      -v(il,inb(il)))/(ph(il,inb(il))-ph(il,inb(il)+1))
+      fv(il,inb(il))=fv(il,inb(il))-dx
+      fv(il,inb(il)-1)=fv(il,inb(il)-1)                                              &
+       &    +dx*(ph(il,inb(il))-ph(il,inb(il)+1))                                    &
+       &       /(ph(il,inb(il)-1)-ph(il,inb(il)))
+       endif
+      ENDIF    !iflag
+503   continue
+
+!AC!      do j=1,ntra
+!AC!       do il=1,ncum
+!AC!        IF (iflag(il) .le. 1) THEN
+!AC!	IF (cvflag_grav) then
+!AC!        ex=0.01*grav*ment(il,inb(il),inb(il))
+!AC!     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+!AC!     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
+!AC!        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+!AC!        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+!AC!     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+!AC!     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+!AC!	else
+!AC!        ex=0.1*ment(il,inb(il),inb(il))
+!AC!     :      *(traent(il,inb(il),inb(il),j)-tra(il,inb(il),j))
+!AC!     :      /(ph(i l,inb(il))-ph(il,inb(il)+1))
+!AC!        ftra(il,inb(il),j)=ftra(il,inb(il),j)-ex
+!AC!        ftra(il,inb(il)-1,j)=ftra(il,inb(il)-1,j)
+!AC!     :       +ex*(ph(il,inb(il))-ph(il,inb(il)+1))
+!AC!     :          /(ph(il,inb(il)-1)-ph(il,inb(il)))
+!AC!        ENDIF   !cvflag grav
+!AC!        ENDIF    !iflag
+!AC!       enddo
+!AC!      enddo
+
+!c
+!c   ***    homogenize tendencies below cloud base    ***
+!c
+!c
+      do il=1,ncum
+       asum(il)=0.0
+       bsum(il)=0.0
+       csum(il)=0.0
+       dsum(il)=0.0
+        esum(il)=0.0
+        fsum(il)=0.0
+        gsum(il)=0.0
+        hsum(il)=0.0
+      enddo
+!c
+!c     do i=1,nl
+!c      do il=1,ncum
+!c         th_wake(il,i)=t_wake(il,i)*(1000.0/p(il,i))**rdcp
+!c      enddo
+!c     enddo
+!c
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1) .and. iflag(il) .le. 1) then
+!cjyg  Saturated part : use T profile
+      asum(il)=asum(il)+(ft(il,i)-ftd(il,i))*(ph(il,i)-ph(il,i+1))
+      bsum(il)=bsum(il)+(fr(il,i)-fqd(il,i))                                         &
+       &              *(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))                         &
+       &                  *(ph(il,i)-ph(il,i+1))
+      csum(il)=csum(il)+(lv(il,i)+(cl-cpd)*(t(il,i)-t(il,1)))                        &
+       &                      *(ph(il,i)-ph(il,i+1))
+      dsum(il)=dsum(il)+t(il,i)*(ph(il,i)-ph(il,i+1))/th(il,i)
+!cjyg  Unsaturated part : use T_wake profile
+      esum(il)=esum(il)+ftd(il,i)*(ph(il,i)-ph(il,i+1))
+      fsum(il)=fsum(il)+fqd(il,i)                                                    &
+       &              *(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))               &
+       &                  *(ph(il,i)-ph(il,i+1))
+      gsum(il)=gsum(il)+(lv(il,i)+(cl-cpd)*(t_wake(il,i)-t_wake(il,1)))              &
+       &                      *(ph(il,i)-ph(il,i+1))
+      hsum(il)=hsum(il)+t_wake(il,i)                                                 &
+       &                      *(ph(il,i)-ph(il,i+1))/th_wake(il,i)
+        endif
+       enddo
+      enddo
+
+!c!!!      do 700 i=1,icb(il)-1
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1) .and. iflag(il) .le. 1) then
+         ftd(il,i)=esum(il)*t_wake(il,i)/(th_wake(il,i)*hsum(il))
+         fqd(il,i)=fsum(il)/gsum(il)
+         ft(il,i)=ftd(il,i)+asum(il)*t(il,i)/(th(il,i)*dsum(il))
+         fr(il,i)=fqd(il,i)+bsum(il)/csum(il)
+        endif
+       enddo
+      enddo
+
+!c
+!c   ***   Check that moisture stays positive. If not, scale tendencies
+!c        in order to ensure moisture positivity
+      DO il = 1,ncum
+      alpha_qpos(il)=1.
+       IF (iflag(il) .le. 1) THEN
+        if (fr(il,1) .le. 0.) then
+            alpha_qpos(il) = max(alpha_qpos(il) ,                                    &
+       &	   (-delt*fr(il,1))/                                                 &
+       &     (s_wake(il)*rr_wake(il,1)+(1.-s_wake(il))*rr(il,1)))
+        end if
+       ENDIF
+      ENDDO
+      DO i = 2,nl
+       DO il = 1,ncum
+        IF (iflag(il) .le. 1) THEN
+          IF (fr(il,i) .le. 0.) THEN
+           alpha_qpos1(il)=max(1. , (-delt*fr(il,i))/                                &
+       &     (s_wake(il)*rr_wake(il,i)+(1.-s_wake(il))*rr(il,i)))
+             IF (alpha_qpos1(il) .ge. alpha_qpos(il))                                &
+       &           alpha_qpos(il)=alpha_qpos1(il)
+          ENDIF
+        ENDIF
+       ENDDO
+      ENDDO
+      DO il = 1,ncum
+       IF (iflag(il) .le. 1 .and. alpha_qpos(il) .gt. 1.001) THEN
+        alpha_qpos(il) = alpha_qpos(il)*1.1
+       ENDIF
+      ENDDO
+      DO il = 1,ncum
+       IF (iflag(il) .le. 1) THEN
+        sigd(il) = sigd(il)/alpha_qpos(il)
+        precip(il) = precip(il)/alpha_qpos(il)
+       ENDIF
+      ENDDO
+      DO i = 1,nl
+       DO il = 1,ncum
+        IF (iflag(il) .le. 1) THEN
+         fr(il,i) = fr(il,i)/alpha_qpos(il)
+         ft(il,i) = ft(il,i)/alpha_qpos(il)
+         fqd(il,i) = fqd(il,i)/alpha_qpos(il)
+         ftd(il,i) = ftd(il,i)/alpha_qpos(il)
+         fu(il,i) = fu(il,i)/alpha_qpos(il)
+         fv(il,i) = fv(il,i)/alpha_qpos(il)
+         m(il,i) = m(il,i)/alpha_qpos(il)
+         mp(il,i) = mp(il,i)/alpha_qpos(il)
+         Vprecip(il,i) = Vprecip(il,i)/alpha_qpos(il)
+        ENDIF
+       ENDDO
+      ENDDO
+      DO i = 1,nl
+      DO j = 1,nl
+       DO il = 1,ncum
+        IF (iflag(il) .le. 1) THEN
+         ment(il,i,j) = ment(il,i,j)/alpha_qpos(il)
+        ENDIF
+       ENDDO
+      ENDDO
+      ENDDO
+
+!AC!      DO j = 1,ntra
+!AC!      DO i = 1,nl
+!AC!       DO il = 1,ncum
+!AC!        IF (iflag(il) .le. 1) THEN
+!AC!         ftra(il,i,j) = ftra(il,i,j)/alpha_qpos(il)
+!AC!        ENDIF
+!AC!       ENDDO
+!AC!      ENDDO
+!AC!      ENDDO
+
+!c
+!c   ***           reset counter and return           ***
+!c
+      do il=1,ncum
+       sig(il,nd)=2.0
+      enddo
+
+
+      do i=1,nd
+       do il=1,ncum
+        upwd(il,i)=0.0
+        dnwd(il,i)=0.0
+       enddo
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        dnwd0(il,i)=-mp(il,i)
+       enddo
+      enddo
+      do i=nl+1,nd
+       do il=1,ncum
+        dnwd0(il,i)=0.
+       enddo
+      enddo
+
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.ge.icb(il) .and. i.le.inb(il)) then
+          upwd(il,i)=0.0
+          dnwd(il,i)=0.0
+        endif
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=1,nl
+        do il=1,ncum
+          up1(il,k,i)=0.0
+          dn1(il,k,i)=0.0
+        enddo
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=i,nl
+        do n=1,i-1
+         do il=1,ncum
+          if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+             up1(il,k,i)=up1(il,k,i)+ment(il,n,k)
+             dn1(il,k,i)=dn1(il,k,i)-ment(il,k,n)
+          endif
+         enddo
+        enddo
+       enddo
+      enddo
+
+      do i=1,nl
+       do k=1,nl
+        do il=1,ncum
+         if(i.ge.icb(il)) then
+          if(k.ge.i.and. k.le.(inb(il))) then
+            upwd(il,i)=upwd(il,i)+m(il,k)
+          endif
+         else
+          if(k.lt.i) then
+            upwd(il,i)=upwd(il,i)+cbmf(il)*wghti(il,k)
+          endif
+        endif
+!cc        print *,'cbmf',il,i,k,cbmf(il),wghti(il,k)
+        end do
+       end do
+      end do
+
+      do i=2,nl
+       do k=i,nl
+        do il=1,ncum
+!ctest         if (i.ge.icb(il).and.i.le.inb(il).and.k.le.inb(il)) then
+         if (i.le.inb(il).and.k.le.inb(il)) then
+            upwd(il,i)=upwd(il,i)+up1(il,k,i)
+            dnwd(il,i)=dnwd(il,i)+dn1(il,k,i)
+         endif
+!cc         print *,'upwd',il,i,k,inb(il),upwd(il,i),m(il,k),up1(il,k,i)
+        enddo
+       enddo
+      enddo
+
+
+!c!!!      DO il=1,ncum
+!c!!!      do i=icb(il),inb(il)
+!c!!!
+!c!!!      upwd(il,i)=0.0
+!c!!!      dnwd(il,i)=0.0
+!c!!!      do k=i,inb(il)
+!c!!!      up1=0.0
+!c!!!      dn1=0.0
+!c!!!      do n=1,i-1
+!c!!!      up1=up1+ment(il,n,k)
+!c!!!      dn1=dn1-ment(il,k,n)
+!c!!!      enddo
+!c!!!      upwd(il,i)=upwd(il,i)+m(il,k)+up1
+!c!!!      dnwd(il,i)=dnwd(il,i)+dn1
+!c!!!      enddo
+!c!!!      enddo
+!c!!!
+!c!!!      ENDDO
+
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!c        determination de la variation de flux ascendant entre
+!c        deux niveau non dilue mip
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nl
+       do il=1,ncum
+        mip(il,i)=m(il,i)
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        mip(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nd
+       do il=1,ncum
+        ma(il,i)=0
+       enddo
+      enddo
+
+      do i=1,nl
+       do j=i,nl
+        do il=1,ncum
+         ma(il,i)=ma(il,i)+m(il,j)
+        enddo
+       enddo
+      enddo
+
+      do i=nl+1,nd
+       do il=1,ncum
+        ma(il,i)=0.
+       enddo
+      enddo
+
+      do i=1,nl
+       do il=1,ncum
+        if (i.le.(icb(il)-1)) then
+         ma(il,i)=0
+        endif
+       enddo
+      enddo
+
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!c        icb represente de niveau ou se trouve la
+!c        base du nuage , et inb le top du nuage
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+      do i=1,nd
+       do il=1,ncum
+        mke(il,i)=upwd(il,i)+dnwd(il,i)
+       enddo
+      enddo
+
+      do i=1,nd
+       DO 999 il=1,ncum
+        rdcp=(rrd*(1.-rr(il,i))-rr(il,i)*rrv)                                        &
+       &        /(cpd*(1.-rr(il,i))+rr(il,i)*cpv)
+        tls(il,i)=t(il,i)*(1000.0/p(il,i))**rdcp
+        tps(il,i)=tp(il,i)
+999    CONTINUE
+      enddo
+
+!c
+!c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+!c   ***           of condensed water         ***            ! cld
+!c                                                           ! cld
+
+       do i=1,nd                                            ! cld
+        do il=1,ncum                                        ! cld
+         mac(il,i)=0.0                                      ! cld
+         wa(il,i)=0.0                                       ! cld
+         siga(il,i)=0.0                                     ! cld
+         sax(il,i)=0.0                                      ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=minorig, nl                                     ! cld
+        do k=i+1,nl+1                                       ! cld
+         do il=1,ncum                                       ! cld
+          if (i.le.inb(il) .and. k.le.(inb(il)+1)                                    &
+       &                     .and. iflag(il) .le. 1) then     ! cld
+            mac(il,i)=mac(il,i)+m(il,k)                     ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do j=1,i                                            ! cld
+         do il=1,ncum                                       ! cld
+          if (i.ge.icb(il) .and. i.le.(inb(il)-1)                                    & ! cld
+       &      .and. j.ge.icb(il)                                                     &
+       &      .and. iflag(il) .le. 1 ) then                   ! cld
+           sax(il,i)=sax(il,i)+rrd*(tvp(il,j)-tv(il,j))                              & ! cld
+       &        *(ph(il,j)-ph(il,j+1))/p(il,j)                ! cld
+          endif                                             ! cld
+         enddo                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (i.ge.icb(il) .and. i.le.(inb(il)-1)                                     & ! cld
+       &       .and. sax(il,i).gt.0.0                                                &
+       &       .and. iflag(il) .le. 1 ) then                  ! cld
+           wa(il,i)=sqrt(2.*sax(il,i))                      ! cld
+         endif                                              ! cld
+        enddo                                               ! cld
+       enddo                                                ! cld
+
+       do i=1,nl                                            ! cld
+        do il=1,ncum                                        ! cld
+         if (wa(il,i).gt.0.0 .and. iflag(il) .le. 1)                                 & ! cld
+       &     siga(il,i)=mac(il,i)/wa(il,i)                                           & ! cld
+       &         *rrd*tvp(il,i)/p(il,i)/100./delta            ! cld
+          siga(il,i) = min(siga(il,i),1.0)                  ! cld
+!IM cf. FH
+         if (iflag_clw.eq.0) then
+          qcondc(il,i)=siga(il,i)*clw(il,i)*(1.-ep(il,i))                            & ! cld
+       &           + (1.-siga(il,i))*qcond(il,i)              ! cld
+         else if (iflag_clw.eq.1) then
+          qcondc(il,i)=qcond(il,i)                          ! cld
+         endif
+
+        enddo                                               ! cld
+       enddo
+!c        print*,'cv3_yield fin'        
+                                              ! cld
+        return
+        end SUBROUTINE cv3_yield
+
+!AC! et !RomP >>>
+      SUBROUTINE cv3_tracer(nloc,len,ncum,nd,na,                                     &
+       &                       ment,sigij,da,phi,phi2,d1a,dam,                       &
+       &                       ep,Vprecip,elij,clw,epmlmMm,eplaMm,                   &
+       &                       icb,inb)
+        implicit none
+
+#include "cv3param.h"
+
+!c inputs:
+        integer ncum, nd, na, nloc,len
+        real ment(nloc,na,na),sigij(nloc,na,na)
+	real clw(nloc,nd),elij(nloc,na,na)
+	real ep(nloc,na)
+        integer icb(nloc),inb(nloc)
+        real VPrecip(nloc,nd+1)
+!c ouputs:
+        real da(nloc,na),phi(nloc,na,na)
+	real phi2(nloc,na,na)
+	real d1a(nloc,na),dam(nloc,na)
+	real epmlmMm(nloc,na,na),eplaMm(nloc,na)
+! variables pour tracer dans precip de l'AA et des mel
+!c local variables:
+        integer i,j,k
+	real epm(nloc,na,na)
+!c
+! variables d'Emanuel : du second indice au troisieme
+! --->    tab(i,k,j) -> de l origine k a l arrivee j 
+!  ment, sigij, elij
+! variables personnelles : du troisieme au second indice
+! --->    tab(i,j,k) -> de k a j 
+! phi, phi2
+!
+! initialisations
+!c
+       da(:,:)=0.
+       d1a(:,:)=0.
+       dam(:,:)=0.
+       epm(:,:,:)=0.
+       eplaMm(:,:)=0.
+       epmlmMm(:,:,:)=0.
+       phi(:,:,:)=0.
+       phi2(:,:,:)=0.
+!c
+!  fraction deau condensee dans les melanges convertie en precip : epm
+! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz
+        do j=1,na
+         do k=1,na
+           do i=1,ncum
+            if(k.ge.icb(i).and.k.le.inb(i).and.                                      &
+!!jyg     &         j.ge.k.and.j.le.inb(i)) then
+!!jyg             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/elij(i,k,j)                    &
+       &         j.gt.k.and.j.le.inb(i)) then
+             epm(i,j,k)=1.-(1.-ep(i,j))*clw(i,j)/                                    &
+       &                     max(elij(i,k,j),1.e-16)
+!!
+             epm(i,j,k)=max(epm(i,j,k),0.0)
+            endif
+           end do 
+         end do 
+        end do 
+
+!
+        do j=1,na
+         do k=1,na
+           do i=1,ncum
+            if(k.ge.icb(i).and.k.le.inb(i)) then
+             eplaMm(i,j)=eplaMm(i,j) + ep(i,j)*clw(i,j)                              &
+       &                  *ment(i,j,k)*(1.-sigij(i,j,k))
+            endif
+           end do 
+         end do 
+        end do
+!
+        do j=1,na
+         do k=1,j-1
+           do i=1,ncum
+            if(k.ge.icb(i).and.k.le.inb(i).and.                                      &
+       &         j.le.inb(i)) then
+             epmlmMm(i,j,k)=epm(i,j,k)*elij(i,k,j)*ment(i,k,j)
+            endif
+           end do 
+         end do 
+        end do
+
+!  matrices pour calculer la tendance des concentrations dans cvltr.F90
+        do j=1,na
+          do k=1,na
+            do i=1,ncum
+             da(i,j)=da(i,j)+(1.-sigij(i,k,j))*ment(i,k,j)
+             phi(i,j,k)=sigij(i,k,j)*ment(i,k,j)
+             d1a(i,j)=d1a(i,j)+ment(i,k,j)*ep(i,k)                                   &
+       &              *(1.-sigij(i,k,j))
+            if(k.le.j) then
+             dam(i,j)=dam(i,j)+ment(i,k,j)                                           &
+       &             *epm(i,k,j)*(1.-ep(i,k))*(1.-sigij(i,k,j)) 
+
+             phi2(i,j,k)=phi(i,j,k)*epm(i,j,k)   
+            endif
+            end do 
+          end do 
+        end do 
+   
+        return
+        end SUBROUTINE cv3_tracer
+!AC! et !RomP <<<
+
+      SUBROUTINE cv3_uncompress(nloc,len,ncum,nd,ntra,idcum                          &
+       &         ,iflag                                                              &
+       &         ,precip,sig,w0                                                      &
+       &         ,ft,fq,fu,fv,ftra                                                   &
+       &         ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape                                  &
+       &         ,iflag1                                                             &
+       &         ,precip1,sig1,w01                                                   &
+       &         ,ft1,fq1,fu1,fv1,ftra1                                              &
+       &         ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1                           &
+       &                               )
+      implicit none
+
+#include "cv3param.h"
+
+!c inputs:
+      integer len, ncum, nd, ntra, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      real precip(nloc)
+      real sig(nloc,nd), w0(nloc,nd)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real Ma(nloc,nd)
+      real upwd(nloc,nd),dnwd(nloc,nd),dnwd0(nloc,nd)
+      real qcondc(nloc,nd)
+      real wd(nloc),cape(nloc)
+
+!c outputs:
+      integer iflag1(len)
+      real precip1(len)
+      real sig1(len,nd), w01(len,nd)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real Ma1(len,nd)
+      real upwd1(len,nd),dnwd1(len,nd),dnwd01(len,nd)
+      real qcondc1(nloc,nd)
+      real wd1(nloc),cape1(nloc)
+
+!c local variables:
+      integer i,k,j
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         iflag1(idcum(i))=iflag(i)
+         wd1(idcum(i))=wd(i)
+         cape1(idcum(i))=cape(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            sig1(idcum(i),k)=sig(i,k)
+            w01(idcum(i),k)=w0(i,k)
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            upwd1(idcum(i),k)=upwd(i,k)
+            dnwd1(idcum(i),k)=dnwd(i,k)
+            dnwd01(idcum(i),k)=dnwd0(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+ 2010     continue
+ 2020   continue
+
+        do 2200 i=1,ncum
+          sig1(idcum(i),nd)=sig(i,nd)
+2200    continue
+
+
+!AC!        do 2100 j=1,ntra
+!AC!c oct3         do 2110 k=1,nl
+!AC!         do 2110 k=1,nd ! oct3
+!AC!          do 2120 i=1,ncum
+!AC!            ftra1(idcum(i),k,j)=ftra(i,k,j)
+!AC! 2120     continue
+!AC! 2110    continue
+!AC! 2100   continue
+        return
+        end SUBROUTINE cv3_uncompress
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_vertmix.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_vertmix.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_vertmix.F	(revision 17)
@@ -0,0 +1,179 @@
+      SUBROUTINE cv3_vertmix(len,nd,iflag,plim1,plim2,p,ph,t,q,u,v
+     :                     ,w,wi,nk,tmix,thmix,qmix,qsmix
+     :                     ,umix,vmix,plcl)
+***************************************************************
+*                                                             *
+* CV3_VERTMIX   Brassage adiabatique d'une couche d'epaisseur *
+*               arbitraire.                                   *
+*                                                             *
+* written by   : Grandpeix Jean-Yves, 28/12/2001, 13.14.24    *
+* modified by :  Filiberti M-A 06/2005 vectorisation          *
+***************************************************************
+*
+       implicit none
+C==============================================================
+C
+C vertmix : determine theta et r du melange obtenu en brassant
+C adiabatiquement entre plim1 et plim2, avec une ponderation w.
+C
+C===============================================================
+
+#include "cvthermo.h"
+#include "YOETHF.h"
+#include "YOMCST.h"
+#include "FCTTRE.h"
+c input :
+      integer nd,len
+      integer nk(len),iflag(len)
+      real t(len,nd),q(len,nd),w(nd)
+      real u(len,nd),v(len,nd)
+      real p(len,nd),ph(len,nd+1)
+      real plim1(len),plim2(len)
+c output :
+      real tmix(len),thmix(len),qmix(len),wi(len,nd)
+      real umix(len),vmix(len)
+      real qsmix(len)
+      real plcl(len)
+c internal variables :
+      integer j1(len),j2(len),niflag7
+      real A,B
+      real ahm(len),dpw(len),coef(len)
+      real p1(len,nd),p2(len,nd)
+      real rdcp(len),a2(len),b2(len),pnk(len)
+      real rh(len),chi(len)
+      real cpn
+      real x,y,p0,p0m1,zdelta,zcor
+
+      integer i,j
+
+      do j = 1,nd
+        do i=1,len
+          if (plim1(i).le.ph(i,j)) j1(i) = j
+          if (plim2(i).ge.ph(i,j+1).and.plim2(i).lt.ph(i,j)) j2(i) = j
+        enddo
+      enddo
+c
+      do j=1,nd
+        do i = 1,len
+          wi(i,j) = 0.
+        enddo
+      enddo
+      do i = 1,len
+       ahm(i)=0.
+       qmix(i)=0.
+       umix(i)=0.
+       vmix(i)=0.
+       dpw(i) =0.
+       a2(i)=0.0
+       b2(i) = 0.
+       pnk(i) = p(i,nk(i))
+      enddo
+c
+      p0 = 1000.
+      p0m1 = 1./p0
+c
+      do i=1,len
+        coef(i) = 1./(plim1(i)-plim2(i))
+      end do
+c
+      do  j=1,nd
+        do i=1,len
+          if (j.ge.j1(i).and.j.le.j2(i)) then
+            p1(i,j) = min(ph(i,j),plim1(i))
+            p2(i,j) = max(ph(i,j+1),plim2(i))
+cCRtest:couplage thermiques: deja normalise
+c             wi(i,j) = w(j)
+c             print*,'wi',wi(i,j)
+            wi(i,j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)
+            dpw(i) = dpw(i)+wi(i,j)
+          endif
+        end do
+      end do
+cCR:print
+c      do i=1,len
+c         print*,'plim',plim1(i),plim2(i)
+c      enddo 
+      do  j=1,nd
+        do i=1,len
+          if (j.ge.j1(i).and.j.le.j2(i)) then
+            wi(i,j)=wi(i,j)/dpw(i)
+            ahm(i)=ahm(i)+(cpd*(1.-q(i,j))+q(i,j)*cpv)*t(i,j)*wi(i,j)
+            qmix(i)=qmix(i)+q(i,j)*wi(i,j)
+            umix(i)=umix(i)+u(i,j)*wi(i,j)
+            vmix(i)=vmix(i)+v(i,j)*wi(i,j)
+          endif
+        end do
+      end do
+c
+      do i=1,len
+         rdcp(i)=(rrd*(1.-qmix(i))+qmix(i)*rrv)/
+     :            (cpd*(1.-qmix(i))+qmix(i)*cpv)
+      end do
+c
+
+c
+      do 20 j=1,nd
+        do 18 i=1,len
+          if (j.ge.j1(i).and.j.le.j2(i)) then
+cc            x=(.5*(p1(i,j)+p2(i,j))*p0m1)**rdcp(i)
+            y=(.5*(p1(i,j)+p2(i,j))/pnk(i))**rdcp(i)
+cc            a2(i)=a2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*x*wi(i,j)
+            b2(i)=b2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*y*wi(i,j)
+          endif
+   18  continue
+   20  continue
+c
+       do i=1,len
+         tmix(i) = ahm(i)/b2(i)
+         thmix(i) =tmix(i)*(p0/pnk(i))**rdcp(i)
+c         print*,'thmix ahm',ahm(i),b2(i)
+c         print*,'thmix t',tmix(i),p0 
+c         print*,'thmix p',pnk(i),rdcp(i)
+c         print*,'thmix',thmix(i)
+cc         thmix(i) = ahm(i)/a2(i)
+cc         tmix(i)= thmix(i)*(pnk(i)*p0m1)**rdcp(i)
+         zdelta=max(0.,sign(1.,rtt-tmix(i)))
+         qsmix(i)= r2es*FOEEW(tmix(i),zdelta)/(pnk(i)*100.)
+         qsmix(i)=min(0.5,qsmix(i))
+         zcor=1./(1.-retv*qsmix(i))
+         qsmix(i)=qsmix(i)*zcor
+       end do
+c
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+
+       A = 1669.0 ! convect3
+       B = 122.0  ! convect3
+
+
+       niflag7=0
+       do 260 i=1,len
+
+        if (iflag(i).ne.7) then ! modif sb Jun7th 2002
+c
+        rh(i)=qmix(i)/qsmix(i)
+        chi(i)=tmix(i)/(A-B*rh(i)-tmix(i)) ! convect3
+c   ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET
+c  MASQUE UN PB POTENTIEL
+        chi(i)=max(chi(i),0.)
+        rh(i)=max(rh(i),0.)
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+
+        else
+
+          niflag7=niflag7+1
+          plcl(i)=plim2(i)
+c
+        endif ! iflag=7
+
+c      print*,'NIFLAG7  =',niflag7
+
+ 260   continue
+
+      return
+      end
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_vertmix.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_vertmix.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3_vertmix.F90	(revision 17)
@@ -0,0 +1,179 @@
+      SUBROUTINE cv3_vertmix(len,nd,iflag,plim1,plim2,p,ph,t,q,u,v                   &
+       &                     ,w,wi,nk,tmix,thmix,qmix,qsmix                          &
+       &                     ,umix,vmix,plcl)
+!***************************************************************
+!*                                                             *
+!* CV3_VERTMIX   Brassage adiabatique d'une couche d'epaisseur *
+!*               arbitraire.                                   *
+!*                                                             *
+!* written by   : Grandpeix Jean-Yves, 28/12/2001, 13.14.24    *
+!* modified by :  Filiberti M-A 06/2005 vectorisation          *
+!***************************************************************
+!*
+       implicit none
+!C==============================================================
+!C
+!C vertmix : determine theta et r du melange obtenu en brassant
+!C adiabatiquement entre plim1 et plim2, avec une ponderation w.
+!C
+!C===============================================================
+
+#include "cvthermo.h"
+#include "YOETHF.h"
+#include "YOMCST.h"
+#include "FCTTRE.h"
+!c input :
+      integer nd,len
+      integer nk(len),iflag(len)
+      real t(len,nd),q(len,nd),w(nd)
+      real u(len,nd),v(len,nd)
+      real p(len,nd),ph(len,nd+1)
+      real plim1(len),plim2(len)
+!c output :
+      real tmix(len),thmix(len),qmix(len),wi(len,nd)
+      real umix(len),vmix(len)
+      real qsmix(len)
+      real plcl(len)
+!c internal variables :
+      integer j1(len),j2(len),niflag7
+      real A,B
+      real ahm(len),dpw(len),coef(len)
+      real p1(len,nd),p2(len,nd)
+      real rdcp(len),a2(len),b2(len),pnk(len)
+      real rh(len),chi(len)
+      real cpn
+      real x,y,p0,p0m1,zdelta,zcor
+
+      integer i,j
+
+      do j = 1,nd
+        do i=1,len
+          if (plim1(i).le.ph(i,j)) j1(i) = j
+          if (plim2(i).ge.ph(i,j+1).and.plim2(i).lt.ph(i,j)) j2(i) = j
+        enddo
+      enddo
+!c
+      do j=1,nd
+        do i = 1,len
+          wi(i,j) = 0.
+        enddo
+      enddo
+      do i = 1,len
+       ahm(i)=0.
+       qmix(i)=0.
+       umix(i)=0.
+       vmix(i)=0.
+       dpw(i) =0.
+       a2(i)=0.0
+       b2(i) = 0.
+       pnk(i) = p(i,nk(i))
+      enddo
+!c
+      p0 = 1000.
+      p0m1 = 1./p0
+!c
+      do i=1,len
+        coef(i) = 1./(plim1(i)-plim2(i))
+      end do
+!c
+      do  j=1,nd
+        do i=1,len
+          if (j.ge.j1(i).and.j.le.j2(i)) then
+            p1(i,j) = min(ph(i,j),plim1(i))
+            p2(i,j) = max(ph(i,j+1),plim2(i))
+!cCRtest:couplage thermiques: deja normalise
+!c             wi(i,j) = w(j)
+!c             print*,'wi',wi(i,j)
+            wi(i,j) = w(j)*(p1(i,j)-p2(i,j))*coef(i)
+            dpw(i) = dpw(i)+wi(i,j)
+          endif
+        end do
+      end do
+!cCR:print
+!c      do i=1,len
+!c         print*,'plim',plim1(i),plim2(i)
+!c      enddo 
+      do  j=1,nd
+        do i=1,len
+          if (j.ge.j1(i).and.j.le.j2(i)) then
+            wi(i,j)=wi(i,j)/dpw(i)
+            ahm(i)=ahm(i)+(cpd*(1.-q(i,j))+q(i,j)*cpv)*t(i,j)*wi(i,j)
+            qmix(i)=qmix(i)+q(i,j)*wi(i,j)
+            umix(i)=umix(i)+u(i,j)*wi(i,j)
+            vmix(i)=vmix(i)+v(i,j)*wi(i,j)
+          endif
+        end do
+      end do
+!c
+      do i=1,len
+         rdcp(i)=(rrd*(1.-qmix(i))+qmix(i)*rrv)/                                     &
+       &            (cpd*(1.-qmix(i))+qmix(i)*cpv)
+      end do
+!c
+
+!c
+      do 20 j=1,nd
+        do 18 i=1,len
+          if (j.ge.j1(i).and.j.le.j2(i)) then
+!cc            x=(.5*(p1(i,j)+p2(i,j))*p0m1)**rdcp(i)
+            y=(.5*(p1(i,j)+p2(i,j))/pnk(i))**rdcp(i)
+!cc            a2(i)=a2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*x*wi(i,j)
+            b2(i)=b2(i)+(cpd*(1.-qmix(i))+qmix(i)*cpv)*y*wi(i,j)
+          endif
+   18  continue
+   20  continue
+!c
+       do i=1,len
+         tmix(i) = ahm(i)/b2(i)
+         thmix(i) =tmix(i)*(p0/pnk(i))**rdcp(i)
+!c         print*,'thmix ahm',ahm(i),b2(i)
+!c         print*,'thmix t',tmix(i),p0 
+!c         print*,'thmix p',pnk(i),rdcp(i)
+!c         print*,'thmix',thmix(i)
+!cc         thmix(i) = ahm(i)/a2(i)
+!cc         tmix(i)= thmix(i)*(pnk(i)*p0m1)**rdcp(i)
+         zdelta=max(0.,sign(1.,rtt-tmix(i)))
+         qsmix(i)= r2es*FOEEW(tmix(i),zdelta)/(pnk(i)*100.)
+         qsmix(i)=min(0.5,qsmix(i))
+         zcor=1./(1.-retv*qsmix(i))
+         qsmix(i)=qsmix(i)*zcor
+       end do
+!c
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+
+       A = 1669.0 ! convect3
+       B = 122.0  ! convect3
+
+
+       niflag7=0
+       do 260 i=1,len
+
+        if (iflag(i).ne.7) then ! modif sb Jun7th 2002
+!c
+        rh(i)=qmix(i)/qsmix(i)
+        chi(i)=tmix(i)/(A-B*rh(i)-tmix(i)) ! convect3
+!c   ATTENTION, la LIGNE DESSOUS A ETE RAJOUTEE ARBITRAIREMENT ET
+!c  MASQUE UN PB POTENTIEL
+        chi(i)=max(chi(i),0.)
+        rh(i)=max(rh(i),0.)
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))                               &
+       &   .and.(iflag(i).eq.0))iflag(i)=8
+
+        else
+
+          niflag7=niflag7+1
+          plcl(i)=plim2(i)
+!c
+        endif ! iflag=7
+
+!c      print*,'NIFLAG7  =',niflag7
+
+ 260   continue
+
+      return
+      end
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3a_compress.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3a_compress.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3a_compress.F	(revision 17)
@@ -0,0 +1,168 @@
+      SUBROUTINE cv3a_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,hnk1,unk1,vnk1
+     :    ,wghti1,pbase1,buoybase1
+     :    ,t1,q1,qs1,t1_wake,q1_wake,qs1_wake,s1_wake
+     :    ,u1,v1,gz1,th1,th1_wake
+     :    ,tra1
+     :    ,h1     ,lv1     ,cpn1   ,p1,ph1,tv1    ,tp1,tvp1,clw1
+     :    ,h1_wake,lv1_wake,cpn1_wake     ,tv1_wake
+     :    ,sig1,w01,ptop21
+     :    ,Ale1,Alp1
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,hnk,unk,vnk
+     o    ,wghti,pbase,buoybase
+     o    ,t,q,qs,t_wake,q_wake,qs_wake,s_wake
+     o    ,u,v,gz,th,th_wake
+     o    ,tra
+     o    ,h     ,lv     ,cpn    ,p,ph,tv    ,tp,tvp,clw
+     o    ,h_wake,lv_wake,cpn_wake    ,tv_wake
+     o    ,sig,w0,ptop2
+     o    ,Ale,Alp  )
+***************************************************************
+*                                                             *
+* CV3A_COMPRESS                                               *
+*                                                             *
+*                                                             *
+* written by   : Sandrine Bony-Lena , 17/05/2003, 11.22.15    *
+* modified by  : Jean-Yves Grandpeix, 23/06/2003, 10.28.09    *
+***************************************************************
+*
+      implicit none
+
+#include "cv3param.h"
+
+c inputs:
+      integer len,nloc,ncum,nd,ntra
+      integer iflag1(len),nk1(len),icb1(len),icbs1(len)
+      real plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real hnk1(len),unk1(len),vnk1(len)
+      real wghti1(len,nd),pbase1(len),buoybase1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd)
+      real t1_wake(len,nd),q1_wake(len,nd),qs1_wake(len,nd)
+      real s1_wake(len)
+      real u1(len,nd),v1(len,nd)
+      real gz1(len,nd),th1(len,nd),th1_wake(len,nd)
+      real tra1(len,nd,ntra)
+      real h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+      real h1_wake(len,nd),lv1_wake(len,nd),cpn1_wake(len,nd)
+      real tv1_wake(len,nd)
+      real sig1(len,nd), w01(len,nd), ptop21(len)
+      real Ale1(len),Alp1(len)
+
+c outputs:
+c en fait, on a nloc=len pour l'instant (cf cv_driver)
+      integer iflag(len),nk(len),icb(len),icbs(len)
+      real plcl(len),tnk(len),qnk(len),gznk(len)
+      real hnk(len),unk(len),vnk(len)
+      real wghti(len,nd),pbase(len),buoybase(len)
+      real t(len,nd),q(len,nd),qs(len,nd)
+      real t_wake(len,nd),q_wake(len,nd),qs_wake(len,nd)
+      real s_wake(len)
+      real u(len,nd),v(len,nd)
+      real gz(len,nd),th(len,nd),th_wake(len,nd)
+      real tra(len,nd,ntra)
+      real h(len,nd),lv(len,nd),cpn(len,nd)
+      real p(len,nd),ph(len,nd+1),tv(len,nd),tp(len,nd)
+      real tvp(len,nd),clw(len,nd)
+      real h_wake(len,nd),lv_wake(len,nd),cpn_wake(len,nd)
+      real tv_wake(len,nd)
+      real sig(len,nd), w0(len,nd), ptop2(len)
+      real Ale(len),Alp(len)
+
+c local variables:
+      integer i,k,nn,j
+
+      CHARACTER (LEN=20) :: modname='cv3a_compress'
+      CHARACTER (LEN=80) :: abort_message
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        wghti(nn,k)=wghti1(i,k)
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        t_wake(nn,k)=t1_wake(i,k)
+        q_wake(nn,k)=q1_wake(i,k)
+        qs_wake(nn,k)=qs1_wake(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        th(nn,k)=th1(i,k)
+        th_wake(nn,k)=th1_wake(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+        h_wake(nn,k)=h1_wake(i,k)
+        lv_wake(nn,k)=lv1_wake(i,k)
+        cpn_wake(nn,k)=cpn1_wake(i,k)
+        tv_wake(nn,k)=tv1_wake(i,k)
+        sig(nn,k)=sig1(i,k)
+        w0(nn,k)=w01(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+!AC!      do 121 j=1,ntra
+!AC!ccccc      do 111 k=1,nl+1
+!AC!      do 111 k=1,nd
+!AC!       nn=0
+!AC!      do 101 i=1,len
+!AC!      if(iflag1(i).eq.0)then
+!AC!       nn=nn+1
+!AC!       tra(nn,k,j)=tra1(i,k,j)
+!AC!      endif
+!AC! 101  continue
+!AC! 111  continue
+!AC! 121  continue
+
+      if (nn.ne.ncum) then
+        print*,'WARNING nn not equal to ncum: ',nn,ncum
+        abort_message = ''
+        CALL abort_gcm (modname,abort_message,1)
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      s_wake(nn)=s1_wake(i)
+      iflag(nn)=iflag1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      icbs(nn)=icbs1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      hnk(nn)=hnk1(i)
+      unk(nn)=unk1(i)
+      vnk(nn)=vnk1(i)
+      pbase(nn)=pbase1(i)
+      buoybase(nn)=buoybase1(i)
+      ptop2(nn)=ptop2(i)
+      ale(nn) = ale1(i)
+      alp(nn) = alp1(i)
+      endif
+ 150  continue
+
+      if (nn.ne.ncum) then
+         print*,'WARNING nn not equal to ncum: ',nn,ncum
+         abort_message = ''
+         CALL abort_gcm (modname,abort_message,1)
+      endif
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3a_compress.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3a_compress.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3a_compress.F90	(revision 17)
@@ -0,0 +1,168 @@
+      SUBROUTINE cv3a_compress( len,nloc,ncum,nd,ntra                                &
+       &    ,iflag1,nk1,icb1,icbs1                                                   &
+       &    ,plcl1,tnk1,qnk1,gznk1,hnk1,unk1,vnk1                                    &
+       &    ,wghti1,pbase1,buoybase1                                                 &
+       &    ,t1,q1,qs1,t1_wake,q1_wake,qs1_wake,s1_wake                              &
+       &    ,u1,v1,gz1,th1,th1_wake                                                  &
+       &    ,tra1                                                                    &
+       &    ,h1     ,lv1     ,cpn1   ,p1,ph1,tv1    ,tp1,tvp1,clw1                   &
+       &    ,h1_wake,lv1_wake,cpn1_wake     ,tv1_wake                                &
+       &    ,sig1,w01,ptop21                                                         &
+       &    ,Ale1,Alp1                                                               &
+       &    ,iflag,nk,icb,icbs                                                       &
+       &    ,plcl,tnk,qnk,gznk,hnk,unk,vnk                                           &
+       &    ,wghti,pbase,buoybase                                                    &
+       &    ,t,q,qs,t_wake,q_wake,qs_wake,s_wake                                     &
+       &    ,u,v,gz,th,th_wake                                                       &
+       &    ,tra                                                                     &
+       &    ,h     ,lv     ,cpn    ,p,ph,tv    ,tp,tvp,clw                           &
+       &    ,h_wake,lv_wake,cpn_wake    ,tv_wake                                     &
+       &    ,sig,w0,ptop2                                                            &
+       &    ,Ale,Alp  )
+!***************************************************************
+!*                                                             *
+!* CV3A_COMPRESS                                               *
+!*                                                             *
+!*                                                             *
+!* written by   : Sandrine Bony-Lena , 17/05/2003, 11.22.15    *
+!* modified by  : Jean-Yves Grandpeix, 23/06/2003, 10.28.09    *
+!***************************************************************
+!*
+      implicit none
+
+#include "cv3param.h"
+
+!c inputs:
+      integer len,nloc,ncum,nd,ntra
+      integer iflag1(len),nk1(len),icb1(len),icbs1(len)
+      real plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real hnk1(len),unk1(len),vnk1(len)
+      real wghti1(len,nd),pbase1(len),buoybase1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd)
+      real t1_wake(len,nd),q1_wake(len,nd),qs1_wake(len,nd)
+      real s1_wake(len)
+      real u1(len,nd),v1(len,nd)
+      real gz1(len,nd),th1(len,nd),th1_wake(len,nd)
+      real tra1(len,nd,ntra)
+      real h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+      real h1_wake(len,nd),lv1_wake(len,nd),cpn1_wake(len,nd)
+      real tv1_wake(len,nd)
+      real sig1(len,nd), w01(len,nd), ptop21(len)
+      real Ale1(len),Alp1(len)
+
+!c outputs:
+!c en fait, on a nloc=len pour l'instant (cf cv_driver)
+      integer iflag(len),nk(len),icb(len),icbs(len)
+      real plcl(len),tnk(len),qnk(len),gznk(len)
+      real hnk(len),unk(len),vnk(len)
+      real wghti(len,nd),pbase(len),buoybase(len)
+      real t(len,nd),q(len,nd),qs(len,nd)
+      real t_wake(len,nd),q_wake(len,nd),qs_wake(len,nd)
+      real s_wake(len)
+      real u(len,nd),v(len,nd)
+      real gz(len,nd),th(len,nd),th_wake(len,nd)
+      real tra(len,nd,ntra)
+      real h(len,nd),lv(len,nd),cpn(len,nd)
+      real p(len,nd),ph(len,nd+1),tv(len,nd),tp(len,nd)
+      real tvp(len,nd),clw(len,nd)
+      real h_wake(len,nd),lv_wake(len,nd),cpn_wake(len,nd)
+      real tv_wake(len,nd)
+      real sig(len,nd), w0(len,nd), ptop2(len)
+      real Ale(len),Alp(len)
+
+!c local variables:
+      integer i,k,nn,j
+
+      CHARACTER (LEN=20) :: modname='cv3a_compress'
+      CHARACTER (LEN=80) :: abort_message
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        wghti(nn,k)=wghti1(i,k)
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        t_wake(nn,k)=t1_wake(i,k)
+        q_wake(nn,k)=q1_wake(i,k)
+        qs_wake(nn,k)=qs1_wake(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        th(nn,k)=th1(i,k)
+        th_wake(nn,k)=th1_wake(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+        h_wake(nn,k)=h1_wake(i,k)
+        lv_wake(nn,k)=lv1_wake(i,k)
+        cpn_wake(nn,k)=cpn1_wake(i,k)
+        tv_wake(nn,k)=tv1_wake(i,k)
+        sig(nn,k)=sig1(i,k)
+        w0(nn,k)=w01(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+!AC!      do 121 j=1,ntra
+!AC!ccccc      do 111 k=1,nl+1
+!AC!      do 111 k=1,nd
+!AC!       nn=0
+!AC!      do 101 i=1,len
+!AC!      if(iflag1(i).eq.0)then
+!AC!       nn=nn+1
+!AC!       tra(nn,k,j)=tra1(i,k,j)
+!AC!      endif
+!AC! 101  continue
+!AC! 111  continue
+!AC! 121  continue
+
+      if (nn.ne.ncum) then
+        print*,'WARNING nn not equal to ncum: ',nn,ncum
+        abort_message = ''
+        CALL abort_gcm (modname,abort_message,1)
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      s_wake(nn)=s1_wake(i)
+      iflag(nn)=iflag1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      icbs(nn)=icbs1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      hnk(nn)=hnk1(i)
+      unk(nn)=unk1(i)
+      vnk(nn)=vnk1(i)
+      pbase(nn)=pbase1(i)
+      buoybase(nn)=buoybase1(i)
+      ptop2(nn)=ptop2(i)
+      ale(nn) = ale1(i)
+      alp(nn) = alp1(i)
+      endif
+ 150  continue
+
+      if (nn.ne.ncum) then
+         print*,'WARNING nn not equal to ncum: ',nn,ncum
+         abort_message = ''
+         CALL abort_gcm (modname,abort_message,1)
+      endif
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3a_uncompress.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3a_uncompress.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3a_uncompress.F	(revision 17)
@@ -0,0 +1,200 @@
+      SUBROUTINE cv3a_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :         ,iflag,kbas,ktop
+     :         ,precip,cbmf,plcl,plfc,wbeff,sig,w0,ptop2
+     :         ,ft,fq,fu,fv,ftra
+     :         ,sigd,Ma,mip,Vprecip,upwd,dnwd,dnwd0
+     :         ,qcondc,wd,cape,cin
+     :         ,tvp
+     :         ,ftd,fqd
+     :         ,Plim1,Plim2,asupmax,supmax0
+     :         ,asupmaxmin
+!
+     :          ,da,phi,mp,phi2,d1a,dam,sigij         ! RomP+AC+jyg
+     :          ,clw,elij,evap,ep,epmlmMm,eplaMm      ! RomP
+     :          ,wdtrainA,wdtrainM                    ! RomP
+!
+     o         ,iflag1,kbas1,ktop1
+     o         ,precip1,cbmf1,plcl1,plfc1,wbeff1,sig1,w01,ptop21
+     o         ,ft1,fq1,fu1,fv1,ftra1
+     o         ,sigd1,Ma1,mip1,Vprecip1,upwd1,dnwd1,dnwd01
+     o         ,qcondc1,wd1,cape1,cin1
+     o         ,tvp1
+     o         ,ftd1,fqd1
+     o         ,Plim11,Plim21,asupmax1,supmax01
+     o         ,asupmaxmin1     
+!
+     o          ,da1,phi1,mp1,phi21,d1a1,dam1,sigij1  ! RomP+AC+jyg
+     o          ,clw1,elij1,evap1,ep1,epmlmMm1,eplaMm1! RomP
+     o          ,wdtrainA1,wdtrainM1)                 ! RomP
+!
+***************************************************************
+*                                                             *
+* CV3A_UNCOMPRESS                                             *
+*                                                             *
+*                                                             *
+* written by   : Sandrine Bony-Lena , 17/05/2003, 11.22.15    *
+* modified by  : Jean-Yves Grandpeix, 23/06/2003, 10.36.17    *
+***************************************************************
+*
+      implicit none
+
+#include "cv3param.h"
+
+c inputs:
+      integer nloc, len, ncum, nd, ntra
+      integer idcum(nloc)
+      integer iflag(nloc),kbas(nloc),ktop(nloc)
+      real precip(nloc),cbmf(nloc),plcl(nloc),plfc(nloc)
+      real wbeff(len)
+      real sig(nloc,nd), w0(nloc,nd),ptop2(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real sigd(nloc)
+      real Ma(nloc,nd),mip(nloc,nd),Vprecip(nloc,nd+1)
+      real upwd(nloc,nd),dnwd(nloc,nd),dnwd0(nloc,nd)
+      real qcondc(nloc,nd)
+      real wd(nloc),cape(nloc),cin(nloc)
+      real tvp(nloc,nd)
+      real ftd(nloc,nd), fqd(nloc,nd)
+      real Plim1(nloc),Plim2(nloc)
+      real asupmax(nloc,nd),supmax0(nloc)
+      real asupmaxmin(nloc)
+!
+      real da(nloc,nd),phi(nloc,nd,nd)                    !AC!
+      real mp(nloc,nd)                                    !RomP
+      real phi2(nloc,nd,nd)                               !RomP
+      real d1a(nloc,nd),dam(nloc,nd)                      !RomP
+      real sigij(nloc,nd,nd)                              !RomP
+      real clw(nloc,nd),elij(nloc,nd,nd)                  !RomP
+      real evap(nloc,nd),ep(nloc,nd)                      !RomP
+      real epmlmMm(nloc,nd,nd),eplaMm(nloc,nd)            !RomP+jyg
+      real wdtrainA(nloc,nd), wdtrainM(nloc,nd)           !RomP
+!
+c outputs:
+      integer iflag1(len),kbas1(len),ktop1(len)
+      real precip1(len),cbmf1(len),plcl1(nloc),plfc1(nloc)
+      real wbeff1(len)
+      real sig1(len,nd), w01(len,nd),ptop21(len)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real sigd1(len)
+      real Ma1(len,nd),mip1(len,nd),Vprecip1(len,nd+1)
+      real upwd1(len,nd),dnwd1(len,nd),dnwd01(len,nd)
+      real qcondc1(len,nd)
+      real wd1(len),cape1(len),cin1(len)
+      real tvp1(len,nd)
+      real ftd1(len,nd), fqd1(len,nd)
+      real Plim11(len),Plim21(len)
+      real asupmax1(len,nd),supmax01(len)
+      real asupmaxmin1(len)
+!
+      real da1(nloc,nd),phi1(nloc,nd,nd)                  !AC!
+      real mp1(nloc,nd)                                   !RomP
+      real phi21(nloc,nd,nd)                              !RomP
+      real d1a1(nloc,nd),dam1(nloc,nd)                    !RomP
+      real sigij1(len,nd,nd)                              !RomP
+      real clw1(len,nd),elij1(len,nd,nd)                  !RomP
+      real evap1(len,nd),ep1(len,nd)                      !RomP
+      real epmlmMm1(len,nd,nd),eplaMm1(len,nd)            !RomP+jyg
+      real wdtrainA1(len,nd), wdtrainM1(len,nd)           !RomP
+!
+c
+c local variables:
+      integer i,k,j
+cc    integer k1,k2
+
+        do 2000 i=1,ncum
+         ptop21(idcum(i))=ptop2(i)
+         sigd1(idcum(i))=sigd(i)
+         precip1(idcum(i))=precip(i)
+         cbmf1(idcum(i))=cbmf(i)
+         plcl1(idcum(i))=plcl(i)
+         plfc1(idcum(i))=plfc(i)
+         wbeff1(idcum(i))=wbeff(i)
+         iflag1(idcum(i))=iflag(i)
+         kbas1(idcum(i))=kbas(i)
+         ktop1(idcum(i))=ktop(i)
+         wd1(idcum(i))=wd(i)
+         cape1(idcum(i))=cape(i)
+         cin1(idcum(i))=cin(i)
+         Plim11(idcum(i))=Plim1(i)
+         Plim21(idcum(i))=Plim2(i)
+         supmax01(idcum(i))=supmax0(i)
+         asupmaxmin1(idcum(i))=asupmaxmin(i)
+ 2000   continue
+
+        do 2020 k=1,nd
+          do 2010 i=1,ncum
+            sig1(idcum(i),k)=sig(i,k)
+            w01(idcum(i),k)=w0(i,k)
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            mip1(idcum(i),k)=mip(i,k)
+            Vprecip1(idcum(i),k)=Vprecip(i,k)
+            upwd1(idcum(i),k)=upwd(i,k)
+            dnwd1(idcum(i),k)=dnwd(i,k)
+            dnwd01(idcum(i),k)=dnwd0(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+            tvp1(idcum(i),k)=tvp(i,k)
+            ftd1(idcum(i),k)=ftd(i,k)
+            fqd1(idcum(i),k)=fqd(i,k)
+            asupmax1(idcum(i),k)=asupmax(i,k)
+!
+            da1(idcum(i),k)=da(i,k)                       !AC!
+            mp1(idcum(i),k)      = mp(i,k)                !RomP
+            d1a1(idcum(i),k)     = d1a(i,k)               !RomP
+            dam1(idcum(i),k)     = dam(i,k)               !RomP
+            clw1(idcum(i),k)     = clw(i,k)               !RomP
+            evap1(idcum(i),k)    = evap(i,k)              !RomP
+            ep1(idcum(i),k)      = ep(i,k)                !RomP
+            eplaMm(idcum(i),k)   = eplaMm(i,k)            !RomP+jyg
+            wdtrainA1(idcum(i),k)= wdtrainA(i,k)          !RomP
+            wdtrainM1(idcum(i),k)= wdtrainM(i,k)          !RomP
+!
+ 2010    continue
+ 2020   continue
+
+        do 2040 i=1,ncum
+          sig1(idcum(i),nd)=sig(i,nd)
+2040    continue
+
+
+!AC!        do 2100 j=1,ntra
+!AC!c oct3         do 2110 k=1,nl
+!AC!         do 2110 k=1,nd ! oct3
+!AC!          do 2120 i=1,ncum
+!AC!            ftra1(idcum(i),k,j)=ftra(i,k,j)
+!AC! 2120     continue
+!AC! 2110    continue
+!AC! 2100   continue
+
+!AC!
+       do j=1,nd
+         do k=1,nd 
+          do i=1,ncum
+            phi1(idcum(i),k,j)   = phi(i,k,j)           !AC!
+            phi21(idcum(i),k,j)  = phi2(i,k,j)          !RomP
+            sigij1(idcum(i),k,j) = sigij(i,k,j)         !RomP
+            elij1(idcum(i),k,j)  = elij(i,k,j)          !RomP
+            epmlmMm(idcum(i),k,j)= epmlmMm(i,k,j)       !RomP+jyg
+          end do
+         end do
+        end do
+!AC!
+
+c
+c        do 2220 k2=1,nd
+c         do 2210 k1=1,nd
+c          do 2200 i=1,ncum
+c            ment1(idcum(i),k1,k2) = ment(i,k1,k2)
+c            sigij1(idcum(i),k1,k2) = sigij(i,k1,k2)
+c2200      enddo
+c2210     enddo
+c2220    enddo
+
+       RETURN
+      END
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3a_uncompress.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3a_uncompress.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3a_uncompress.F90	(revision 17)
@@ -0,0 +1,200 @@
+      SUBROUTINE cv3a_uncompress(nloc,len,ncum,nd,ntra,idcum                         &
+       &         ,iflag,kbas,ktop                                                    &
+       &         ,precip,cbmf,plcl,plfc,wbeff,sig,w0,ptop2                           &
+       &         ,ft,fq,fu,fv,ftra                                                   &
+       &         ,sigd,Ma,mip,Vprecip,upwd,dnwd,dnwd0                                &
+       &         ,qcondc,wd,cape,cin                                                 &
+       &         ,tvp                                                                &
+       &         ,ftd,fqd                                                            &
+       &         ,Plim1,Plim2,asupmax,supmax0                                        &
+       &         ,asupmaxmin                                                         &
+!                                                                                    &
+       &          ,da,phi,mp,phi2,d1a,dam,sigij                                      & ! RomP+AC+jyg
+       &          ,clw,elij,evap,ep,epmlmMm,eplaMm                                   & ! RomP
+       &          ,wdtrainA,wdtrainM                                                 & ! RomP
+!                                                                                    &
+       &         ,iflag1,kbas1,ktop1                                                 &
+       &         ,precip1,cbmf1,plcl1,plfc1,wbeff1,sig1,w01,ptop21                   &
+       &         ,ft1,fq1,fu1,fv1,ftra1                                              &
+       &         ,sigd1,Ma1,mip1,Vprecip1,upwd1,dnwd1,dnwd01                         &
+       &         ,qcondc1,wd1,cape1,cin1                                             &
+       &         ,tvp1                                                               &
+       &         ,ftd1,fqd1                                                          &
+       &         ,Plim11,Plim21,asupmax1,supmax01                                    &
+       &         ,asupmaxmin1                                                        &
+!                                                                                    &
+       &          ,da1,phi1,mp1,phi21,d1a1,dam1,sigij1                               & ! RomP+AC+jyg
+       &          ,clw1,elij1,evap1,ep1,epmlmMm1,eplaMm1                             & ! RomP
+       &          ,wdtrainA1,wdtrainM1)                 ! RomP
+!
+!***************************************************************
+!*                                                             *
+!* CV3A_UNCOMPRESS                                             *
+!*                                                             *
+!*                                                             *
+!* written by   : Sandrine Bony-Lena , 17/05/2003, 11.22.15    *
+!* modified by  : Jean-Yves Grandpeix, 23/06/2003, 10.36.17    *
+!***************************************************************
+!*
+      implicit none
+
+#include "cv3param.h"
+
+!c inputs:
+      integer nloc, len, ncum, nd, ntra
+      integer idcum(nloc)
+      integer iflag(nloc),kbas(nloc),ktop(nloc)
+      real precip(nloc),cbmf(nloc),plcl(nloc),plfc(nloc)
+      real wbeff(len)
+      real sig(nloc,nd), w0(nloc,nd),ptop2(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real ftra(nloc,nd,ntra)
+      real sigd(nloc)
+      real Ma(nloc,nd),mip(nloc,nd),Vprecip(nloc,nd+1)
+      real upwd(nloc,nd),dnwd(nloc,nd),dnwd0(nloc,nd)
+      real qcondc(nloc,nd)
+      real wd(nloc),cape(nloc),cin(nloc)
+      real tvp(nloc,nd)
+      real ftd(nloc,nd), fqd(nloc,nd)
+      real Plim1(nloc),Plim2(nloc)
+      real asupmax(nloc,nd),supmax0(nloc)
+      real asupmaxmin(nloc)
+!
+      real da(nloc,nd),phi(nloc,nd,nd)                    !AC!
+      real mp(nloc,nd)                                    !RomP
+      real phi2(nloc,nd,nd)                               !RomP
+      real d1a(nloc,nd),dam(nloc,nd)                      !RomP
+      real sigij(nloc,nd,nd)                              !RomP
+      real clw(nloc,nd),elij(nloc,nd,nd)                  !RomP
+      real evap(nloc,nd),ep(nloc,nd)                      !RomP
+      real epmlmMm(nloc,nd,nd),eplaMm(nloc,nd)            !RomP+jyg
+      real wdtrainA(nloc,nd), wdtrainM(nloc,nd)           !RomP
+!
+!c outputs:
+      integer iflag1(len),kbas1(len),ktop1(len)
+      real precip1(len),cbmf1(len),plcl1(nloc),plfc1(nloc)
+      real wbeff1(len)
+      real sig1(len,nd), w01(len,nd),ptop21(len)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real sigd1(len)
+      real Ma1(len,nd),mip1(len,nd),Vprecip1(len,nd+1)
+      real upwd1(len,nd),dnwd1(len,nd),dnwd01(len,nd)
+      real qcondc1(len,nd)
+      real wd1(len),cape1(len),cin1(len)
+      real tvp1(len,nd)
+      real ftd1(len,nd), fqd1(len,nd)
+      real Plim11(len),Plim21(len)
+      real asupmax1(len,nd),supmax01(len)
+      real asupmaxmin1(len)
+!
+      real da1(nloc,nd),phi1(nloc,nd,nd)                  !AC!
+      real mp1(nloc,nd)                                   !RomP
+      real phi21(nloc,nd,nd)                              !RomP
+      real d1a1(nloc,nd),dam1(nloc,nd)                    !RomP
+      real sigij1(len,nd,nd)                              !RomP
+      real clw1(len,nd),elij1(len,nd,nd)                  !RomP
+      real evap1(len,nd),ep1(len,nd)                      !RomP
+      real epmlmMm1(len,nd,nd),eplaMm1(len,nd)            !RomP+jyg
+      real wdtrainA1(len,nd), wdtrainM1(len,nd)           !RomP
+!
+!c
+!c local variables:
+      integer i,k,j
+!cc    integer k1,k2
+
+        do 2000 i=1,ncum
+         ptop21(idcum(i))=ptop2(i)
+         sigd1(idcum(i))=sigd(i)
+         precip1(idcum(i))=precip(i)
+         cbmf1(idcum(i))=cbmf(i)
+         plcl1(idcum(i))=plcl(i)
+         plfc1(idcum(i))=plfc(i)
+         wbeff1(idcum(i))=wbeff(i)
+         iflag1(idcum(i))=iflag(i)
+         kbas1(idcum(i))=kbas(i)
+         ktop1(idcum(i))=ktop(i)
+         wd1(idcum(i))=wd(i)
+         cape1(idcum(i))=cape(i)
+         cin1(idcum(i))=cin(i)
+         Plim11(idcum(i))=Plim1(i)
+         Plim21(idcum(i))=Plim2(i)
+         supmax01(idcum(i))=supmax0(i)
+         asupmaxmin1(idcum(i))=asupmaxmin(i)
+ 2000   continue
+
+        do 2020 k=1,nd
+          do 2010 i=1,ncum
+            sig1(idcum(i),k)=sig(i,k)
+            w01(idcum(i),k)=w0(i,k)
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            mip1(idcum(i),k)=mip(i,k)
+            Vprecip1(idcum(i),k)=Vprecip(i,k)
+            upwd1(idcum(i),k)=upwd(i,k)
+            dnwd1(idcum(i),k)=dnwd(i,k)
+            dnwd01(idcum(i),k)=dnwd0(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+            tvp1(idcum(i),k)=tvp(i,k)
+            ftd1(idcum(i),k)=ftd(i,k)
+            fqd1(idcum(i),k)=fqd(i,k)
+            asupmax1(idcum(i),k)=asupmax(i,k)
+!
+            da1(idcum(i),k)=da(i,k)                       !AC!
+            mp1(idcum(i),k)      = mp(i,k)                !RomP
+            d1a1(idcum(i),k)     = d1a(i,k)               !RomP
+            dam1(idcum(i),k)     = dam(i,k)               !RomP
+            clw1(idcum(i),k)     = clw(i,k)               !RomP
+            evap1(idcum(i),k)    = evap(i,k)              !RomP
+            ep1(idcum(i),k)      = ep(i,k)                !RomP
+            eplaMm(idcum(i),k)   = eplaMm(i,k)            !RomP+jyg
+            wdtrainA1(idcum(i),k)= wdtrainA(i,k)          !RomP
+            wdtrainM1(idcum(i),k)= wdtrainM(i,k)          !RomP
+!
+ 2010    continue
+ 2020   continue
+
+        do 2040 i=1,ncum
+          sig1(idcum(i),nd)=sig(i,nd)
+2040    continue
+
+
+!AC!        do 2100 j=1,ntra
+!AC!c oct3         do 2110 k=1,nl
+!AC!         do 2110 k=1,nd ! oct3
+!AC!          do 2120 i=1,ncum
+!AC!            ftra1(idcum(i),k,j)=ftra(i,k,j)
+!AC! 2120     continue
+!AC! 2110    continue
+!AC! 2100   continue
+
+!AC!
+       do j=1,nd
+         do k=1,nd 
+          do i=1,ncum
+            phi1(idcum(i),k,j)   = phi(i,k,j)           !AC!
+            phi21(idcum(i),k,j)  = phi2(i,k,j)          !RomP
+            sigij1(idcum(i),k,j) = sigij(i,k,j)         !RomP
+            elij1(idcum(i),k,j)  = elij(i,k,j)          !RomP
+            epmlmMm(idcum(i),k,j)= epmlmMm(i,k,j)       !RomP+jyg
+          end do
+         end do
+        end do
+!AC!
+
+!c
+!c        do 2220 k2=1,nd
+!c         do 2210 k1=1,nd
+!c          do 2200 i=1,ncum
+!c            ment1(idcum(i),k1,k2) = ment(i,k1,k2)
+!c            sigij1(idcum(i),k1,k2) = sigij(i,k1,k2)
+!c2200      enddo
+!c2210     enddo
+!c2220    enddo
+
+       RETURN
+      END
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3p1_closure.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3p1_closure.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3p1_closure.F	(revision 17)
@@ -0,0 +1,655 @@
+!
+! $Id: cv3p1_closure.F 1664 2012-10-09 13:29:15Z fairhead $
+!
+      SUBROUTINE cv3p1_closure(nloc,ncum,nd,icb,inb
+     :                      ,pbase,plcl,p,ph,tv,tvp,buoy
+     :                      ,Supmax,ok_inhib,Ale,Alp
+     o                      ,sig,w0,ptop2,cape,cin,m,iflag,coef
+     :                      ,Plim1,Plim2,asupmax,supmax0
+     :                      ,asupmaxmin,cbmf,plfc,wbeff)
+
+*
+***************************************************************
+*                                                             *
+* CV3P1_CLOSURE                                               *
+*                  Ale & Alp Closure of Convect3              *
+*                                                             *
+* written by   :   Kerry Emanuel                              *
+* vectorization:   S. Bony                                    *
+* modified by :    Jean-Yves Grandpeix, 18/06/2003, 19.32.10  *
+*                  Julie Frohwirth,     14/10/2005  17.44.22  *
+***************************************************************
+*
+      implicit none
+
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "YOMCST2.h"
+#include "YOMCST.h"
+#include "conema3.h"
+#include "iniprint.h"
+
+c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc),plcl(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real tv(nloc,nd),tvp(nloc,nd), buoy(nloc,nd)
+      real Supmax(nloc,nd)
+      logical ok_inhib ! enable convection inhibition by dryness
+      real Ale(nloc),Alp(nloc)
+
+c input/output:
+      real sig(nloc,nd), w0(nloc,nd), ptop2(nloc)
+
+c output:
+      real cape(nloc),cin(nloc)
+      real m(nloc,nd)
+      real Plim1(nloc),Plim2(nloc)
+      real asupmax(nloc,nd),supmax0(nloc)
+      real asupmaxmin(nloc)
+      real cbmf(nloc),plfc(nloc)
+      real wbeff(nloc)
+      integer iflag(nloc)
+c
+c local variables:
+      integer il, i, j, k, icbmax, i0(nloc)
+      real deltap, fac, w, amu
+      real rhodp
+      real Pbmxup
+      real dtmin(nloc,nd), sigold(nloc,nd)
+      real coefmix(nloc,nd)
+      real pzero(nloc),ptop2old(nloc)
+      real cina(nloc),cinb(nloc)
+      integer ibeg(nloc)
+      integer nsupmax(nloc)
+      real supcrit,temp(nloc,nd)
+      real P1(nloc),Pmin(nloc)
+      real asupmax0(nloc)
+      logical ok(nloc)
+      real siglim(nloc,nd),wlim(nloc,nd),mlim(nloc,nd)
+      real wb2(nloc)
+      real cbmflim(nloc),cbmf1(nloc),cbmfmax(nloc)
+      real cbmflast(nloc)
+      real coef(nloc)
+      real xp(nloc),xq(nloc),xr(nloc),discr(nloc),b3(nloc),b4(nloc)
+      real theta(nloc),bb(nloc)
+      real term1,term2,term3
+      real alp2(nloc) ! Alp with offset
+c
+      real sigmax
+      parameter (sigmax =  0.1)
+
+      CHARACTER (LEN=20) :: modname='cv3p1_closure'
+      CHARACTER (LEN=80) :: abort_message
+c
+c      print *,' -> cv3p1_closure, Ale ',ale(1)
+c
+
+c -------------------------------------------------------
+c -- Initialization
+c -------------------------------------------------------
+
+c
+c
+      do il = 1,ncum
+       alp2(il) = max(alp(il),1.e-5)
+cIM 
+       alp2(il) = max(alp(il),1.e-12)
+      enddo
+c
+      PBMXUP=50.    ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts
+c                     exist (if any)
+
+       if(prt_level.GE.20)
+     . print*,'cv3p1_param nloc ncum nd icb inb nl',nloc,ncum,nd,
+     . icb(nloc),inb(nloc),nl
+      do k=1,nl
+       do il=1,ncum
+        m(il,k)=0.0
+       enddo
+      enddo
+
+c -------------------------------------------------------
+c -- Reset sig(i) and w0(i) for i>inb and i<icb
+c -------------------------------------------------------
+
+c update sig and w0 above LNB:
+
+      do 100 k=1,nl-1
+       do 110 il=1,ncum
+        if ((inb(il).lt.(nl-1)).and.(k.ge.(inb(il)+1)))then
+         sig(il,k)=beta*sig(il,k)
+     :            +2.*alpha*buoy(il,inb(il))*ABS(buoy(il,inb(il)))
+         sig(il,k)=AMAX1(sig(il,k),0.0)
+         w0(il,k)=beta*w0(il,k)
+        endif
+ 110   continue
+ 100  continue
+
+c      if(prt.level.GE.20) print*,'cv3p1_param apres 100'
+c compute icbmax:
+
+      icbmax=2
+      do 200 il=1,ncum
+        icbmax=MAX(icbmax,icb(il))
+ 200  continue
+!     if(prt.level.GE.20) print*,'cv3p1_param apres 200'
+
+c update sig and w0 below cloud base:
+
+      do 300 k=1,icbmax
+       do 310 il=1,ncum
+        if (k.le.icb(il))then
+         sig(il,k)=beta*sig(il,k)-2.*alpha*buoy(il,icb(il))
+     $                                    *buoy(il,icb(il))
+         sig(il,k)=amax1(sig(il,k),0.0)
+         w0(il,k)=beta*w0(il,k)
+        endif
+310    continue
+300    continue
+       if(prt_level.GE.20) print*,'cv3p1_param apres 300'
+c -------------------------------------------------------------
+c -- Reset fractional areas of updrafts and w0 at initial time
+c -- and after 10 time steps of no convection
+c -------------------------------------------------------------
+
+      do 400 k=1,nl-1
+       do 410 il=1,ncum
+        if (sig(il,nd).lt.1.5.or.sig(il,nd).gt.12.0)then
+         sig(il,k)=0.0
+         w0(il,k)=0.0
+        endif
+ 410   continue
+ 400  continue
+      if(prt_level.GE.20) print*,'cv3p1_param apres 400'
+c
+c -------------------------------------------------------------
+Cjyg1
+C --  Calculate adiabatic ascent top pressure (ptop)
+c -------------------------------------------------------------
+C
+c
+cc 1. Start at first level where precipitations form
+      do il = 1,ncum
+        Pzero(il) = Plcl(il)-PBcrit
+      enddo
+c
+cc 2. Add offset
+      do il = 1,ncum
+        Pzero(il) = Pzero(il)-PBmxup
+      enddo
+      do il=1,ncum
+         ptop2old(il)=ptop2(il)
+      enddo
+c
+      do il = 1,ncum
+cCR:c est quoi ce 300??
+        P1(il) = Pzero(il)-300.
+      enddo
+
+c    compute asupmax=abs(supmax) up to lnm+1
+
+      DO il=1,ncum
+        ok(il)=.true.
+        nsupmax(il)=inb(il)
+      ENDDO
+
+      DO i = 1,nl
+        DO il = 1,ncum
+        IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+        IF (P(il,i) .LE. Pzero(il) .and.
+     $       supmax(il,i) .lt. 0 .and. ok(il)) THEN
+           nsupmax(il)=i
+           ok(il)=.false.
+        ENDIF    ! end IF (P(i) ...  )
+        ENDIF    ! end IF (icb+1 le i le inb)
+        ENDDO
+      ENDDO
+
+      if(prt_level.GE.20) print*,'cv3p1_param apres 2.'
+      DO i = 1,nl
+        DO il = 1,ncum
+        asupmax(il,i)=abs(supmax(il,i))
+        ENDDO
+      ENDDO
+
+c
+        DO il = 1,ncum
+        asupmaxmin(il)=10.
+        Pmin(il)=100.
+!IM ??
+        asupmax0(il)=0.
+        ENDDO
+
+cc 3.  Compute in which level is Pzero
+
+cIM bug      i0 = 18 
+       DO il = 1,ncum
+        i0(il) = nl
+       ENDDO
+
+       DO i = 1,nl
+        DO il = 1,ncum
+         IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+           IF (P(il,i) .LE. Pzero(il) .AND. P(il,i) .GE. P1(il)) THEN
+            IF (Pzero(il) .GT. P(il,i) .AND.
+     $           Pzero(il) .LT. P(il,i-1)) THEN
+             i0(il) = i
+            ENDIF
+           ENDIF
+          ENDIF
+        ENDDO
+       ENDDO
+       if(prt_level.GE.20) print*,'cv3p1_param apres 3.'
+
+cc 4.  Compute asupmax at Pzero
+
+       DO i = 1,nl
+        DO il = 1,ncum
+         IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+           IF (P(il,i) .LE. Pzero(il) .AND. P(il,i) .GE. P1(il)) THEN
+             asupmax0(il) = 
+     $             ((Pzero(il)-P(il,i0(il)-1))*asupmax(il,i0(il))
+     $             -(Pzero(il)-P(il,i0(il)))*asupmax(il,i0(il)-1))
+     $             /(P(il,i0(il))-P(il,i0(il)-1))
+           ENDIF
+         ENDIF
+        ENDDO
+       ENDDO
+
+
+      DO i = 1,nl
+        DO il = 1,ncum
+         IF (P(il,i) .EQ. Pzero(il)) THEN
+           asupmax(i,il) = asupmax0(il)
+         ENDIF
+        ENDDO
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres 4.'
+
+cc 5. Compute asupmaxmin, minimum of asupmax
+
+      DO i = 1,nl
+        DO il = 1,ncum
+        IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+        IF (P(il,i) .LE. Pzero(il) .AND. P(il,i) .GE. P1(il)) THEN
+          IF (asupmax(il,i) .LT. asupmaxmin(il)) THEN
+            asupmaxmin(il)=asupmax(il,i)
+            Pmin(il)=P(il,i)
+          ENDIF
+        ENDIF
+        ENDIF
+        ENDDO
+      ENDDO
+
+      DO il = 1,ncum
+!IM
+        if(prt_level.GE.20) THEN
+         print*,'cv3p1_closure il asupmax0 asupmaxmin',il,asupmax0(il),
+     $ asupmaxmin(il) ,Pzero(il),Pmin(il)
+        endif
+          IF (asupmax0(il) .LT. asupmaxmin(il)) THEN
+             asupmaxmin(il) = asupmax0(il)
+             Pmin(il) = Pzero(il)
+          ENDIF
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres 5.' 
+
+c
+c   Compute Supmax at Pzero
+c
+      DO i = 1,nl
+        DO il = 1,ncum
+        IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+        IF (P(il,i) .LE. Pzero(il)) THEN
+         Supmax0(il) = ((P(il,i  )-Pzero(il))*aSupmax(il,i-1)
+     $             -(P(il,i-1)-Pzero(il))*aSupmax(il,i  ))
+     $             /(P(il,i)-P(il,i-1))
+         GO TO 425
+        ENDIF    ! end IF (P(i) ... )
+        ENDIF    ! end IF (icb+1 le i le inb)
+        ENDDO
+      ENDDO
+
+425   continue
+      if(prt_level.GE.20) print*,'cv3p1_param apres 425.'
+
+cc 6. Calculate ptop2
+c
+      DO il = 1,ncum
+        IF (asupmaxmin(il) .LT. Supcrit1) THEN
+          Ptop2(il) = Pmin(il)
+        ENDIF
+
+        IF (asupmaxmin(il) .GT. Supcrit1
+     $ .AND. asupmaxmin(il) .LT. Supcrit2) THEN
+          Ptop2(il) = Ptop2old(il)
+        ENDIF
+
+        IF (asupmaxmin(il) .GT. Supcrit2) THEN
+            Ptop2(il) =  Ph(il,inb(il))
+        ENDIF
+      ENDDO
+c
+      if(prt_level.GE.20) print*,'cv3p1_param apres 6.'
+
+cc 7. Compute multiplying factor for adiabatic updraught mass flux
+c
+c
+      IF (ok_inhib) THEN
+c
+      DO i = 1,nl
+        DO il = 1,ncum
+         IF (i .le. nl) THEN
+         coefmix(il,i) = (min(ptop2(il),ph(il,i))-ph(il,i))
+     $                  /(ph(il,i+1)-ph(il,i))
+         coefmix(il,i) = min(coefmix(il,i),1.)
+         ENDIF
+        ENDDO
+      ENDDO
+c
+c
+      ELSE   ! when inhibition is not taken into account, coefmix=1
+c
+
+c
+      DO i = 1,nl
+        DO il = 1,ncum
+         IF (i .le. nl) THEN
+         coefmix(il,i) = 1.
+         ENDIF
+        ENDDO
+      ENDDO
+c
+      ENDIF  ! ok_inhib
+      if(prt_level.GE.20) print*,'cv3p1_param apres 7.'
+c -------------------------------------------------------------------
+c -------------------------------------------------------------------
+c
+
+Cjyg2
+C
+c==========================================================================
+C
+c
+c -------------------------------------------------------------
+c -- Calculate convective inhibition (CIN)
+c -------------------------------------------------------------
+
+c      do i=1,nloc
+c      print*,'avant cine p',pbase(i),plcl(i)
+c      enddo
+c     do j=1,nd
+c     do i=1,nloc
+c      print*,'avant cine t',tv(i),tvp(i)
+c     enddo
+c     enddo
+      CALL cv3_cine (nloc,ncum,nd,icb,inb
+     :                      ,pbase,plcl,p,ph,tv,tvp
+     :                      ,cina,cinb,plfc)
+c
+      DO il = 1,ncum
+        cin(il) = cina(il)+cinb(il)
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres cv3_cine'
+c -------------------------------------------------------------
+c --Update buoyancies to account for Ale
+c -------------------------------------------------------------
+c
+      CALL cv3_buoy (nloc,ncum,nd,icb,inb
+     :                      ,pbase,plcl,p,ph,Ale,Cin
+     :                      ,tv,tvp
+     :                      ,buoy )
+      if(prt_level.GE.20) print*,'cv3p1_param apres cv3_buoy'
+
+c -------------------------------------------------------------
+c -- Calculate convective available potential energy (cape),
+c -- vertical velocity (w), fractional area covered by
+c -- undilute updraft (sig), and updraft mass flux (m)
+c -------------------------------------------------------------
+
+      do 500 il=1,ncum
+       cape(il)=0.0
+ 500  continue
+
+c compute dtmin (minimum buoyancy between ICB and given level k):
+
+      do k=1,nl
+       do il=1,ncum
+         dtmin(il,k)=100.0
+       enddo
+      enddo
+
+      do 550 k=1,nl
+       do 560 j=minorig,nl
+        do 570 il=1,ncum
+          if ( (k.ge.(icb(il)+1)).and.(k.le.inb(il)).and.
+     :         (j.ge.icb(il)).and.(j.le.(k-1)) )then
+           dtmin(il,k)=AMIN1(dtmin(il,k),buoy(il,j))
+          endif
+ 570     continue
+ 560   continue
+ 550  continue
+
+c the interval on which cape is computed starts at pbase :
+
+      do 600 k=1,nl
+       do 610 il=1,ncum
+
+        if ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) then
+
+         deltap = MIN(pbase(il),ph(il,k-1))-MIN(pbase(il),ph(il,k))
+         cape(il)=cape(il)+rrd*buoy(il,k-1)*deltap/p(il,k-1)
+         cape(il)=AMAX1(0.0,cape(il))
+         sigold(il,k)=sig(il,k)
+
+
+cjyg       Coefficient coefmix limits convection to levels where a sufficient
+c          fraction of mixed draughts are ascending.
+         siglim(il,k)=coefmix(il,k)*alpha1*dtmin(il,k)*ABS(dtmin(il,k))
+         siglim(il,k)=amax1(siglim(il,k),0.0)
+         siglim(il,k)=amin1(siglim(il,k),0.01)
+cc         fac=AMIN1(((dtcrit-dtmin(il,k))/dtcrit),1.0)
+         fac = 1.
+         wlim(il,k)=fac*SQRT(cape(il))
+         amu=siglim(il,k)*wlim(il,k)
+         rhodp = 0.007*p(il,k)*(ph(il,k)-ph(il,k+1))/tv(il,k)
+         mlim(il,k)=amu*rhodp
+c         print*, 'siglim ', k,siglim(1,k)
+        endif
+
+ 610   continue
+ 600  continue
+      if(prt_level.GE.20) print*,'cv3p1_param apres 600'
+
+      do 700 il=1,ncum
+!IM beg
+        if(prt_level.GE.20) THEN
+         print*,'cv3p1_closure il icb mlim ph ph+1 ph+2',il,
+     $icb(il),mlim(il,icb(il)+1),ph(il,icb(il)),
+     $ph(il,icb(il)+1),ph(il,icb(il)+2)
+        endif
+
+        if (icb(il)+1.le.inb(il)) then
+!IM end
+       mlim(il,icb(il))=0.5*mlim(il,icb(il)+1)
+     :             *(ph(il,icb(il))-ph(il,icb(il)+1))
+     :             /(ph(il,icb(il)+1)-ph(il,icb(il)+2))
+!IM beg
+        endif !(icb(il.le.inb(il))) then
+!IM end
+ 700  continue
+      if(prt_level.GE.20) print*,'cv3p1_param apres 700'
+
+cjyg1
+c------------------------------------------------------------------------
+cc     Correct mass fluxes so that power used to overcome CIN does not
+cc     exceed Power Available for Lifting (PAL).
+c------------------------------------------------------------------------
+c
+      do il = 1,ncum
+       cbmflim(il) = 0.
+       cbmf(il) = 0.
+      enddo
+c
+cc 1. Compute cloud base mass flux of elementary system (Cbmf0=Cbmflim)
+c
+      do k= 1,nl
+       do il = 1,ncum
+!old       IF (k .ge. icb(il) .and. k .le. inb(il)) THEN
+!IM        IF (k .ge. icb(il)+1 .and. k .le. inb(il)) THEN
+       IF (k .ge. icb(il) .and. k .le. inb(il)         !cor jyg
+     $     .and. icb(il)+1 .le. inb(il)) THEN          !cor jyg
+         cbmflim(il) = cbmflim(il)+MLIM(il,k)
+        ENDIF
+       enddo
+      enddo
+      if(prt_level.GE.20) print*,'cv3p1_param apres cbmflim'
+
+cc 1.5 Compute cloud base mass flux given by Alp closure (Cbmf1), maximum
+cc     allowed mass flux (Cbmfmax) and final target mass flux (Cbmf)
+cc     Cbmf is set to zero if Cbmflim (the mass flux of elementary cloud) is
+c--    exceedingly small.
+c
+      DO il = 1,ncum
+        wb2(il) = sqrt(2.*max(Ale(il)+cin(il),0.))
+      ENDDO
+
+      DO il = 1, ncum
+         IF (plfc(il) .lt. 100.) THEN
+c        This is an irealistic value for plfc => no calculation of wbeff
+            wbeff(il) = 100.1
+         ELSE
+c        Calculate wbeff
+            IF (flag_wb==0) THEN
+               wbeff(il) = wbmax
+            ELSE IF (flag_wb==1) THEN
+               wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il)))
+            ELSE IF (flag_wb==2) THEN
+               wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2
+            ENDIF
+         END IF
+      END DO
+
+
+      DO il = 1,ncum
+cjyg    Modification du coef de wb*wb pour conformite avec papier Wake
+cc       cbmf1(il) = alp2(il)/(0.5*wb*wb-Cin(il))
+       cbmf1(il) = alp2(il)/(2.*wbeff(il)*wbeff(il)-Cin(il))
+       if(cbmf1(il).EQ.0.AND.alp2(il).NE.0.) THEN
+        write(lunout,*)
+     &  'cv3p1_closure cbmf1=0 and alp NE 0 il alp2 alp cin ',il,
+     . alp2(il),alp(il),cin(il)
+        abort_message = ''
+        CALL abort_gcm (modname,abort_message,1)
+       endif
+       cbmfmax(il) = sigmax*wb2(il)*100.*p(il,icb(il))
+     :              /(rrd*tv(il,icb(il)))
+      ENDDO
+c
+      DO il = 1,ncum
+       IF (cbmflim(il) .gt. 1.e-6) THEN
+cATTENTION TEST CR
+c         if (cbmfmax(il).lt.1.e-12) then
+        cbmf(il) = min(cbmf1(il),cbmfmax(il))
+c         else
+c         cbmf(il) = cbmf1(il)
+c         endif
+c        print*,'cbmf',cbmf1(il),cbmfmax(il)
+       ENDIF
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres cbmflim_testCR'
+c
+cc 2. Compute coefficient and apply correction
+c
+      do il = 1,ncum
+       coef(il) = (cbmf(il)+1.e-10)/(cbmflim(il)+1.e-10)
+      enddo
+      if(prt_level.GE.20) print*,'cv3p1_param apres coef_plantePLUS'
+c
+      DO k = 1,nl
+        do il = 1,ncum
+         IF ( k .ge. icb(il)+1 .AND. k .le. inb(il)) THEN
+         amu=beta*sig(il,k)*w0(il,k)+
+     :   (1.-beta)*coef(il)*siglim(il,k)*wlim(il,k)
+         w0(il,k) = wlim(il,k)
+         w0(il,k) =max(w0(il,k),1.e-10)
+         sig(il,k)=amu/w0(il,k)
+         sig(il,k)=min(sig(il,k),1.)
+cc         amu = 0.5*(SIG(il,k)+sigold(il,k))*W0(il,k)
+         M(il,k)=AMU*0.007*P(il,k)*(PH(il,k)-PH(il,k+1))/TV(il,k)
+         ENDIF
+        enddo
+      ENDDO
+cjyg2
+      DO il = 1,ncum
+       w0(il,icb(il))=0.5*w0(il,icb(il)+1)
+       m(il,icb(il))=0.5*m(il,icb(il)+1)
+     $       *(ph(il,icb(il))-ph(il,icb(il)+1))
+     $       /(ph(il,icb(il)+1)-ph(il,icb(il)+2))
+       sig(il,icb(il))=sig(il,icb(il)+1)
+       sig(il,icb(il)-1)=sig(il,icb(il))
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres w0_sig_M'
+c
+cc 3. Compute final cloud base mass flux and set iflag to 3 if
+cc    cloud base mass flux is exceedingly small and is decreasing (i.e. if
+cc    the final mass flux (cbmflast) is greater than the target mass flux
+cc    (cbmf)).
+c
+      do il = 1,ncum
+       cbmflast(il) = 0.
+      enddo
+c
+      do k= 1,nl
+       do il = 1,ncum
+        IF (k .ge. icb(il) .and. k .le. inb(il)) THEN
+ !IMpropo??      IF ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) THEN
+         cbmflast(il) = cbmflast(il)+M(il,k)
+        ENDIF
+       enddo
+      enddo
+c
+      do il = 1,ncum
+       IF (cbmflast(il) .lt. 1.e-6 .and.
+     $     cbmflast(il) .ge. cbmf(il)) THEN
+         iflag(il) = 3
+       ENDIF
+      enddo
+c
+      do k= 1,nl
+       do il = 1,ncum
+        IF (iflag(il) .ge. 3) THEN
+         M(il,k) = 0.
+         sig(il,k) = 0.
+         w0(il,k) = 0.
+        ENDIF
+       enddo
+      enddo
+      if(prt_level.GE.20) print*,'cv3p1_param apres iflag'
+c
+cc 4. Introduce a correcting factor for coef, in order to obtain an effective
+cc    sigdz larger in the present case (using cv3p1_closure) than in the old
+cc    closure (using cv3_closure).
+      if (1.eq.0) then
+       do il = 1,ncum 
+cc      coef(il) = 2.*coef(il)
+        coef(il) = 5.*coef(il)
+       enddo
+c version CVS du ..2008
+      else
+       if (iflag_cvl_sigd.eq.0) then
+ctest pour verifier qu on fait la meme chose qu avant: sid constant
+        coef(1:ncum)=1.
+       else
+        coef(1:ncum) = min(2.*coef(1:ncum),5.)
+        coef(1:ncum) = max(2.*coef(1:ncum),0.2)
+       endif
+      endif
+c
+      if(prt_level.GE.20) print*,'cv3p1_param FIN'
+       return
+       end
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3p1_closure.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3p1_closure.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3p1_closure.F90	(revision 17)
@@ -0,0 +1,657 @@
+!
+! $Id: cv3p1_closure.F 1664 2012-10-09 13:29:15Z fairhead $
+!
+      SUBROUTINE cv3p1_closure(nloc,ncum,nd,icb,inb                                  &
+       &                      ,pbase,plcl,p,ph,tv,tvp,buoy                           &
+       &                      ,Supmax,ok_inhib,Ale,Alp                               &
+       &                      ,sig,w0,ptop2,cape,cin,m,iflag,coef                    &
+       &                      ,Plim1,Plim2,asupmax,supmax0                           &
+       &                      ,asupmaxmin,cbmf,plfc,wbeff)
+
+!*
+!***************************************************************
+!*                                                             *
+!* CV3P1_CLOSURE                                               *
+!*                  Ale & Alp Closure of Convect3              *
+!*                                                             *
+!* written by   :   Kerry Emanuel                              *
+!* vectorization:   S. Bony                                    *
+!* modified by :    Jean-Yves Grandpeix, 18/06/2003, 19.32.10  *
+!*                  Julie Frohwirth,     14/10/2005  17.44.22  *
+!***************************************************************
+!*
+      implicit none
+
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "YOMCST2.h"
+#include "YOMCST.h"
+#include "conema3.h"
+#include "iniprint.h"
+
+!c input:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc)
+      real pbase(nloc),plcl(nloc)
+      real p(nloc,nd), ph(nloc,nd+1)
+      real tv(nloc,nd),tvp(nloc,nd), buoy(nloc,nd)
+      real Supmax(nloc,nd)
+      logical ok_inhib ! enable convection inhibition by dryness
+      real Ale(nloc),Alp(nloc)
+
+!c input/output:
+      real sig(nloc,nd), w0(nloc,nd), ptop2(nloc)
+
+!c output:
+      real cape(nloc),cin(nloc)
+      real m(nloc,nd)
+      real Plim1(nloc),Plim2(nloc)
+      real asupmax(nloc,nd),supmax0(nloc)
+      real asupmaxmin(nloc)
+      real cbmf(nloc),plfc(nloc)
+      real wbeff(nloc)
+      integer iflag(nloc)
+!c
+!c local variables:
+      integer il, i, j, k, icbmax, i0(nloc)
+      real deltap, fac, w, amu
+      real rhodp
+      real Pbmxup
+      real dtmin(nloc,nd), sigold(nloc,nd)
+      real coefmix(nloc,nd)
+      real pzero(nloc),ptop2old(nloc)
+      real cina(nloc),cinb(nloc)
+      integer ibeg(nloc)
+      integer nsupmax(nloc)
+      real supcrit,temp(nloc,nd)
+      real P1(nloc),Pmin(nloc)
+      real asupmax0(nloc)
+      logical ok(nloc)
+      real siglim(nloc,nd),wlim(nloc,nd),mlim(nloc,nd)
+      real wb2(nloc)
+      real cbmflim(nloc),cbmf1(nloc),cbmfmax(nloc)
+      real cbmflast(nloc)
+      real coef(nloc)
+      real xp(nloc),xq(nloc),xr(nloc),discr(nloc),b3(nloc),b4(nloc)
+      real theta(nloc),bb(nloc)
+      real term1,term2,term3
+      real alp2(nloc) ! Alp with offset
+!c
+      real sigmax
+      parameter (sigmax =  0.1)
+
+      CHARACTER (LEN=20) :: modname='cv3p1_closure'
+      CHARACTER (LEN=80) :: abort_message
+!c
+!c      print *,' -> cv3p1_closure, Ale ',ale(1)
+!c
+
+!c -------------------------------------------------------
+!c -- Initialization
+!c -------------------------------------------------------
+
+!c
+!c
+      do il = 1,ncum
+       alp2(il) = max(alp(il),1.e-5)
+!IM 
+       alp2(il) = max(alp(il),1.e-12)
+      enddo
+!c
+      PBMXUP=50.    ! PBMXUP+PBCRIT = cloud depth above which mixed updraughts
+!c                     exist (if any)
+
+       if(prt_level.GE.20)                                                           &
+       & print*,'cv3p1_param nloc ncum nd icb inb nl',nloc,ncum,nd,                  &
+       & icb(nloc),inb(nloc),nl
+      do k=1,nl
+       do il=1,ncum
+        m(il,k)=0.0
+       enddo
+      enddo
+
+!c -------------------------------------------------------
+!c -- Reset sig(i) and w0(i) for i>inb and i<icb
+!c -------------------------------------------------------
+
+!c update sig and w0 above LNB:
+
+      do 100 k=1,nl-1
+       do 110 il=1,ncum
+        if ((inb(il).lt.(nl-1)).and.(k.ge.(inb(il)+1)))then
+         sig(il,k)=beta*sig(il,k)                                                    &
+       &            +2.*alpha*buoy(il,inb(il))*ABS(buoy(il,inb(il)))
+         sig(il,k)=AMAX1(sig(il,k),0.0)
+         w0(il,k)=beta*w0(il,k)
+        endif
+ 110   continue
+ 100  continue
+
+!c      if(prt.level.GE.20) print*,'cv3p1_param apres 100'
+!c compute icbmax:
+
+      icbmax=2
+      do 200 il=1,ncum
+        icbmax=MAX(icbmax,icb(il))
+ 200  continue
+!     if(prt.level.GE.20) print*,'cv3p1_param apres 200'
+
+!c update sig and w0 below cloud base:
+
+      do 300 k=1,icbmax
+       do 310 il=1,ncum
+        if (k.le.icb(il))then
+         sig(il,k)=beta*sig(il,k)-2.*alpha*buoy(il,icb(il))                          &
+       &                                    *buoy(il,icb(il))
+         sig(il,k)=amax1(sig(il,k),0.0)
+         w0(il,k)=beta*w0(il,k)
+        endif
+310    continue
+300    continue
+       if(prt_level.GE.20) print*,'cv3p1_param apres 300'
+!c -------------------------------------------------------------
+!c -- Reset fractional areas of updrafts and w0 at initial time
+!c -- and after 10 time steps of no convection
+!c -------------------------------------------------------------
+
+      do 400 k=1,nl-1
+       do 410 il=1,ncum
+        if (sig(il,nd).lt.1.5.or.sig(il,nd).gt.12.0)then
+         sig(il,k)=0.0
+         w0(il,k)=0.0
+        endif
+ 410   continue
+ 400  continue
+      if(prt_level.GE.20) print*,'cv3p1_param apres 400'
+!c
+!c -------------------------------------------------------------
+!Cjyg1
+!C --  Calculate adiabatic ascent top pressure (ptop)
+!c -------------------------------------------------------------
+!C
+!c
+!cc 1. Start at first level where precipitations form
+      do il = 1,ncum
+        Pzero(il) = Plcl(il)-PBcrit
+      enddo
+!c
+!cc 2. Add offset
+      do il = 1,ncum
+        Pzero(il) = Pzero(il)-PBmxup
+      enddo
+      do il=1,ncum
+         ptop2old(il)=ptop2(il)
+      enddo
+!c
+      do il = 1,ncum
+!cCR:c est quoi ce 300??
+        P1(il) = Pzero(il)-300.
+      enddo
+
+!c    compute asupmax=abs(supmax) up to lnm+1
+
+      DO il=1,ncum
+        ok(il)=.true.
+        nsupmax(il)=inb(il)
+      ENDDO
+
+      DO i = 1,nl
+        DO il = 1,ncum
+        IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+        IF (P(il,i) .LE. Pzero(il) .and.                                             &
+       &       supmax(il,i) .lt. 0 .and. ok(il)) THEN
+           nsupmax(il)=i
+           ok(il)=.false.
+        ENDIF    ! end IF (P(i) ...  )
+        ENDIF    ! end IF (icb+1 le i le inb)
+        ENDDO
+      ENDDO
+
+      if(prt_level.GE.20) print*,'cv3p1_param apres 2.'
+      DO i = 1,nl
+        DO il = 1,ncum
+        asupmax(il,i)=abs(supmax(il,i))
+        ENDDO
+      ENDDO
+
+!c
+        DO il = 1,ncum
+        asupmaxmin(il)=10.
+        Pmin(il)=100.
+!IM ??
+        asupmax0(il)=0.
+        ENDDO
+
+!cc 3.  Compute in which level is Pzero
+
+!IM bug      i0 = 18 
+       DO il = 1,ncum
+        i0(il) = nl
+       ENDDO
+
+       DO i = 1,nl
+        DO il = 1,ncum
+         IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+           IF (P(il,i) .LE. Pzero(il) .AND. P(il,i) .GE. P1(il)) THEN
+            IF (Pzero(il) .GT. P(il,i) .AND.                                         &
+       &           Pzero(il) .LT. P(il,i-1)) THEN
+             i0(il) = i
+            ENDIF
+           ENDIF
+          ENDIF
+        ENDDO
+       ENDDO
+       if(prt_level.GE.20) print*,'cv3p1_param apres 3.'
+
+!cc 4.  Compute asupmax at Pzero
+
+       DO i = 1,nl
+        DO il = 1,ncum
+         IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+           IF (P(il,i) .LE. Pzero(il) .AND. P(il,i) .GE. P1(il)) THEN
+             asupmax0(il) =                                                          &
+       &             ((Pzero(il)-P(il,i0(il)-1))*asupmax(il,i0(il))                  &
+       &             -(Pzero(il)-P(il,i0(il)))*asupmax(il,i0(il)-1))                 &
+       &             /(P(il,i0(il))-P(il,i0(il)-1))
+           ENDIF
+         ENDIF
+        ENDDO
+       ENDDO
+
+
+      DO i = 1,nl
+        DO il = 1,ncum
+         IF (P(il,i) .EQ. Pzero(il)) THEN
+!L. Fita. LMD, October 2013
+!           asupmax(i,il) = asupmax0(il)
+           asupmax(il,i) = asupmax0(il)
+         ENDIF
+        ENDDO
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres 4.'
+
+!cc 5. Compute asupmaxmin, minimum of asupmax
+
+      DO i = 1,nl
+        DO il = 1,ncum
+        IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+        IF (P(il,i) .LE. Pzero(il) .AND. P(il,i) .GE. P1(il)) THEN
+          IF (asupmax(il,i) .LT. asupmaxmin(il)) THEN
+            asupmaxmin(il)=asupmax(il,i)
+            Pmin(il)=P(il,i)
+          ENDIF
+        ENDIF
+        ENDIF
+        ENDDO
+      ENDDO
+
+      DO il = 1,ncum
+!IM
+        if(prt_level.GE.20) THEN
+         print*,'cv3p1_closure il asupmax0 asupmaxmin',il,asupmax0(il),              &
+       & asupmaxmin(il) ,Pzero(il),Pmin(il)
+        endif
+          IF (asupmax0(il) .LT. asupmaxmin(il)) THEN
+             asupmaxmin(il) = asupmax0(il)
+             Pmin(il) = Pzero(il)
+          ENDIF
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres 5.' 
+
+!c
+!c   Compute Supmax at Pzero
+!c
+      DO i = 1,nl
+        DO il = 1,ncum
+        IF (i .GT. icb(il) .AND. i .LE. inb(il)) THEN
+        IF (P(il,i) .LE. Pzero(il)) THEN
+         Supmax0(il) = ((P(il,i  )-Pzero(il))*aSupmax(il,i-1)                        &
+       &             -(P(il,i-1)-Pzero(il))*aSupmax(il,i  ))                         &
+       &             /(P(il,i)-P(il,i-1))
+         GO TO 425
+        ENDIF    ! end IF (P(i) ... )
+        ENDIF    ! end IF (icb+1 le i le inb)
+        ENDDO
+      ENDDO
+
+425   continue
+      if(prt_level.GE.20) print*,'cv3p1_param apres 425.'
+
+!cc 6. Calculate ptop2
+!c
+      DO il = 1,ncum
+        IF (asupmaxmin(il) .LT. Supcrit1) THEN
+          Ptop2(il) = Pmin(il)
+        ENDIF
+
+        IF (asupmaxmin(il) .GT. Supcrit1                                             &
+       & .AND. asupmaxmin(il) .LT. Supcrit2) THEN
+          Ptop2(il) = Ptop2old(il)
+        ENDIF
+
+        IF (asupmaxmin(il) .GT. Supcrit2) THEN
+            Ptop2(il) =  Ph(il,inb(il))
+        ENDIF
+      ENDDO
+!c
+      if(prt_level.GE.20) print*,'cv3p1_param apres 6.'
+
+!cc 7. Compute multiplying factor for adiabatic updraught mass flux
+!c
+!c
+      IF (ok_inhib) THEN
+!c
+      DO i = 1,nl
+        DO il = 1,ncum
+         IF (i .le. nl) THEN
+         coefmix(il,i) = (min(ptop2(il),ph(il,i))-ph(il,i))                          &
+       &                  /(ph(il,i+1)-ph(il,i))
+         coefmix(il,i) = min(coefmix(il,i),1.)
+         ENDIF
+        ENDDO
+      ENDDO
+!c
+!c
+      ELSE   ! when inhibition is not taken into account, coefmix=1
+!c
+
+!c
+      DO i = 1,nl
+        DO il = 1,ncum
+         IF (i .le. nl) THEN
+         coefmix(il,i) = 1.
+         ENDIF
+        ENDDO
+      ENDDO
+!c
+      ENDIF  ! ok_inhib
+      if(prt_level.GE.20) print*,'cv3p1_param apres 7.'
+!c -------------------------------------------------------------------
+!c -------------------------------------------------------------------
+!c
+
+!Cjyg2
+!C
+!c==========================================================================
+!C
+!c
+!c -------------------------------------------------------------
+!c -- Calculate convective inhibition (CIN)
+!c -------------------------------------------------------------
+
+!c      do i=1,nloc
+!c      print*,'avant cine p',pbase(i),plcl(i)
+!c      enddo
+!c     do j=1,nd
+!c     do i=1,nloc
+!c      print*,'avant cine t',tv(i),tvp(i)
+!c     enddo
+!c     enddo
+      CALL cv3_cine (nloc,ncum,nd,icb,inb                                            &
+       &                      ,pbase,plcl,p,ph,tv,tvp                                &
+       &                      ,cina,cinb,plfc)
+!c
+      DO il = 1,ncum
+        cin(il) = cina(il)+cinb(il)
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres cv3_cine'
+!c -------------------------------------------------------------
+!c --Update buoyancies to account for Ale
+!c -------------------------------------------------------------
+!c
+      CALL cv3_buoy (nloc,ncum,nd,icb,inb                                            &
+       &                      ,pbase,plcl,p,ph,Ale,Cin                               &
+       &                      ,tv,tvp                                                &
+       &                      ,buoy )
+      if(prt_level.GE.20) print*,'cv3p1_param apres cv3_buoy'
+
+!c -------------------------------------------------------------
+!c -- Calculate convective available potential energy (cape),
+!c -- vertical velocity (w), fractional area covered by
+!c -- undilute updraft (sig), and updraft mass flux (m)
+!c -------------------------------------------------------------
+
+      do 500 il=1,ncum
+       cape(il)=0.0
+ 500  continue
+
+!c compute dtmin (minimum buoyancy between ICB and given level k):
+
+      do k=1,nl
+       do il=1,ncum
+         dtmin(il,k)=100.0
+       enddo
+      enddo
+
+      do 550 k=1,nl
+       do 560 j=minorig,nl
+        do 570 il=1,ncum
+          if ( (k.ge.(icb(il)+1)).and.(k.le.inb(il)).and.                            &
+       &         (j.ge.icb(il)).and.(j.le.(k-1)) )then
+           dtmin(il,k)=AMIN1(dtmin(il,k),buoy(il,j))
+          endif
+ 570     continue
+ 560   continue
+ 550  continue
+
+!c the interval on which cape is computed starts at pbase :
+
+      do 600 k=1,nl
+       do 610 il=1,ncum
+
+        if ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) then
+
+         deltap = MIN(pbase(il),ph(il,k-1))-MIN(pbase(il),ph(il,k))
+         cape(il)=cape(il)+rrd*buoy(il,k-1)*deltap/p(il,k-1)
+         cape(il)=AMAX1(0.0,cape(il))
+         sigold(il,k)=sig(il,k)
+
+
+!cjyg       Coefficient coefmix limits convection to levels where a sufficient
+!c          fraction of mixed draughts are ascending.
+         siglim(il,k)=coefmix(il,k)*alpha1*dtmin(il,k)*ABS(dtmin(il,k))
+         siglim(il,k)=amax1(siglim(il,k),0.0)
+         siglim(il,k)=amin1(siglim(il,k),0.01)
+!cc         fac=AMIN1(((dtcrit-dtmin(il,k))/dtcrit),1.0)
+         fac = 1.
+         wlim(il,k)=fac*SQRT(cape(il))
+         amu=siglim(il,k)*wlim(il,k)
+         rhodp = 0.007*p(il,k)*(ph(il,k)-ph(il,k+1))/tv(il,k)
+         mlim(il,k)=amu*rhodp
+!c         print*, 'siglim ', k,siglim(1,k)
+        endif
+
+ 610   continue
+ 600  continue
+      if(prt_level.GE.20) print*,'cv3p1_param apres 600'
+
+      do 700 il=1,ncum
+!IM beg
+        if(prt_level.GE.20) THEN
+         print*,'cv3p1_closure il icb mlim ph ph+1 ph+2',il,                         &
+       &icb(il),mlim(il,icb(il)+1),ph(il,icb(il)),                                   &
+       &ph(il,icb(il)+1),ph(il,icb(il)+2)
+        endif
+
+        if (icb(il)+1.le.inb(il)) then
+!IM end
+       mlim(il,icb(il))=0.5*mlim(il,icb(il)+1)                                       &
+       &             *(ph(il,icb(il))-ph(il,icb(il)+1))                              &
+       &             /(ph(il,icb(il)+1)-ph(il,icb(il)+2))
+!IM beg
+        endif !(icb(il.le.inb(il))) then
+!IM end
+ 700  continue
+      if(prt_level.GE.20) print*,'cv3p1_param apres 700'
+
+!cjyg1
+!c------------------------------------------------------------------------
+!cc     Correct mass fluxes so that power used to overcome CIN does not
+!cc     exceed Power Available for Lifting (PAL).
+!c------------------------------------------------------------------------
+!c
+      do il = 1,ncum
+       cbmflim(il) = 0.
+       cbmf(il) = 0.
+      enddo
+!c
+!cc 1. Compute cloud base mass flux of elementary system (Cbmf0=Cbmflim)
+!c
+      do k= 1,nl
+       do il = 1,ncum
+!old       IF (k .ge. icb(il) .and. k .le. inb(il)) THEN
+!IM        IF (k .ge. icb(il)+1 .and. k .le. inb(il)) THEN
+       IF (k .ge. icb(il) .and. k .le. inb(il)                                       & !cor jyg
+       &     .and. icb(il)+1 .le. inb(il)) THEN          !cor jyg
+         cbmflim(il) = cbmflim(il)+MLIM(il,k)
+        ENDIF
+       enddo
+      enddo
+      if(prt_level.GE.20) print*,'cv3p1_param apres cbmflim'
+
+!cc 1.5 Compute cloud base mass flux given by Alp closure (Cbmf1), maximum
+!cc     allowed mass flux (Cbmfmax) and final target mass flux (Cbmf)
+!cc     Cbmf is set to zero if Cbmflim (the mass flux of elementary cloud) is
+!c--    exceedingly small.
+!c
+      DO il = 1,ncum
+        wb2(il) = sqrt(2.*max(Ale(il)+cin(il),0.))
+      ENDDO
+
+      DO il = 1, ncum
+         IF (plfc(il) .lt. 100.) THEN
+!c        This is an irealistic value for plfc => no calculation of wbeff
+            wbeff(il) = 100.1
+         ELSE
+!c        Calculate wbeff
+            IF (flag_wb==0) THEN
+               wbeff(il) = wbmax
+            ELSE IF (flag_wb==1) THEN
+               wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il)))
+            ELSE IF (flag_wb==2) THEN
+               wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2
+            ENDIF
+         END IF
+      END DO
+
+
+      DO il = 1,ncum
+!cjyg    Modification du coef de wb*wb pour conformite avec papier Wake
+!cc       cbmf1(il) = alp2(il)/(0.5*wb*wb-Cin(il))
+       cbmf1(il) = alp2(il)/(2.*wbeff(il)*wbeff(il)-Cin(il))
+       if(cbmf1(il).EQ.0.AND.alp2(il).NE.0.) THEN
+        write(lunout,*)                                                              &
+       &  'cv3p1_closure cbmf1=0 and alp NE 0 il alp2 alp cin ',il,                  &
+       & alp2(il),alp(il),cin(il)
+        abort_message = ''
+        CALL abort_gcm (modname,abort_message,1)
+       endif
+       cbmfmax(il) = sigmax*wb2(il)*100.*p(il,icb(il))                               &
+       &              /(rrd*tv(il,icb(il)))
+      ENDDO
+!c
+      DO il = 1,ncum
+       IF (cbmflim(il) .gt. 1.e-6) THEN
+!cATTENTION TEST CR
+!c         if (cbmfmax(il).lt.1.e-12) then
+        cbmf(il) = min(cbmf1(il),cbmfmax(il))
+!c         else
+!c         cbmf(il) = cbmf1(il)
+!c         endif
+!c        print*,'cbmf',cbmf1(il),cbmfmax(il)
+       ENDIF
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres cbmflim_testCR'
+!c
+!cc 2. Compute coefficient and apply correction
+!c
+      do il = 1,ncum
+       coef(il) = (cbmf(il)+1.e-10)/(cbmflim(il)+1.e-10)
+      enddo
+      if(prt_level.GE.20) print*,'cv3p1_param apres coef_plantePLUS'
+!c
+      DO k = 1,nl
+        do il = 1,ncum
+         IF ( k .ge. icb(il)+1 .AND. k .le. inb(il)) THEN
+         amu=beta*sig(il,k)*w0(il,k)+                                                &
+       &   (1.-beta)*coef(il)*siglim(il,k)*wlim(il,k)
+         w0(il,k) = wlim(il,k)
+         w0(il,k) =max(w0(il,k),1.e-10)
+         sig(il,k)=amu/w0(il,k)
+         sig(il,k)=min(sig(il,k),1.)
+!cc         amu = 0.5*(SIG(il,k)+sigold(il,k))*W0(il,k)
+         M(il,k)=AMU*0.007*P(il,k)*(PH(il,k)-PH(il,k+1))/TV(il,k)
+         ENDIF
+        enddo
+      ENDDO
+!cjyg2
+      DO il = 1,ncum
+       w0(il,icb(il))=0.5*w0(il,icb(il)+1)
+       m(il,icb(il))=0.5*m(il,icb(il)+1)                                             &
+       &       *(ph(il,icb(il))-ph(il,icb(il)+1))                                    &
+       &       /(ph(il,icb(il)+1)-ph(il,icb(il)+2))
+       sig(il,icb(il))=sig(il,icb(il)+1)
+       sig(il,icb(il)-1)=sig(il,icb(il))
+      ENDDO
+      if(prt_level.GE.20) print*,'cv3p1_param apres w0_sig_M'
+!c
+!cc 3. Compute final cloud base mass flux and set iflag to 3 if
+!cc    cloud base mass flux is exceedingly small and is decreasing (i.e. if
+!cc    the final mass flux (cbmflast) is greater than the target mass flux
+!cc    (cbmf)).
+!c
+      do il = 1,ncum
+       cbmflast(il) = 0.
+      enddo
+!c
+      do k= 1,nl
+       do il = 1,ncum
+        IF (k .ge. icb(il) .and. k .le. inb(il)) THEN
+ !IMpropo??      IF ((k.ge.(icb(il)+1)).and.(k.le.inb(il))) THEN
+         cbmflast(il) = cbmflast(il)+M(il,k)
+        ENDIF
+       enddo
+      enddo
+!c
+      do il = 1,ncum
+       IF (cbmflast(il) .lt. 1.e-6 .and.                                             &
+       &     cbmflast(il) .ge. cbmf(il)) THEN
+         iflag(il) = 3
+       ENDIF
+      enddo
+!c
+      do k= 1,nl
+       do il = 1,ncum
+        IF (iflag(il) .ge. 3) THEN
+         M(il,k) = 0.
+         sig(il,k) = 0.
+         w0(il,k) = 0.
+        ENDIF
+       enddo
+      enddo
+      if(prt_level.GE.20) print*,'cv3p1_param apres iflag'
+!c
+!cc 4. Introduce a correcting factor for coef, in order to obtain an effective
+!cc    sigdz larger in the present case (using cv3p1_closure) than in the old
+!cc    closure (using cv3_closure).
+      if (1.eq.0) then
+       do il = 1,ncum 
+!cc      coef(il) = 2.*coef(il)
+        coef(il) = 5.*coef(il)
+       enddo
+!c version CVS du ..2008
+      else
+       if (iflag_cvl_sigd.eq.0) then
+!ctest pour verifier qu on fait la meme chose qu avant: sid constant
+        coef(1:ncum)=1.
+       else
+        coef(1:ncum) = min(2.*coef(1:ncum),5.)
+        coef(1:ncum) = max(2.*coef(1:ncum),0.2)
+       endif
+      endif
+!c
+      if(prt_level.GE.20) print*,'cv3p1_param FIN'
+       return
+       end
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3p_mixing.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3p_mixing.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3p_mixing.F	(revision 17)
@@ -0,0 +1,598 @@
+      SUBROUTINE cv3p_mixing(nloc,ncum,nd,na,ntra,icb,nk,inb
+     :                    ,ph,t,rr,rs,u,v,tra,h,lv,qnk
+     :                    ,unk,vnk,hp,tv,tvp,ep,clw,sig
+     :                    ,ment,qent,hent,uent,vent,nent
+     :                   ,sigij,elij,supmax,ments,qents,traent)
+***************************************************************
+*                                                             *
+* CV3P_MIXING : compute mixed draught properties and,         *
+*               within a scaling factor, mixed draught        *
+*               mass fluxes.                                  *
+* written by  : VTJ Philips,JY Grandpeix, 21/05/2003, 09.14.15*
+* modified by :                                               *
+***************************************************************
+*
+      implicit none
+c
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "YOMCST2.h"
+
+c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc), nk(nloc)
+      real sig(nloc,nd)
+      real qnk(nloc),unk(nloc),vnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra) ! input of convect3
+      real lv(nloc,na)
+      real h(nloc,na)  !liquid water static energy of environment
+      real hp(nloc,na) !liquid water static energy of air shed from adiab. asc.
+      real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na)
+
+c outputs:
+      real ment(nloc,na,na), qent(nloc,na,na)
+      real uent(nloc,na,na), vent(nloc,na,na)
+      real sigij(nloc,na,na), elij(nloc,na,na)
+      real supmax(nloc,na)     ! Highest mixing fraction of mixed updraughts
+                               ! with the sign of (h-hp)
+      real traent(nloc,nd,nd,ntra)
+      real ments(nloc,nd,nd), qents(nloc,nd,nd)
+      real hent(nloc,nd,nd)
+      integer nent(nloc,nd)
+
+c local variables:
+      integer i, j, k, il, im, jm
+      integer num1, num2
+      real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+      real alt, delp, delm
+      real Qmixmax(nloc), Rmixmax(nloc), SQmRmax(nloc)
+      real Qmixmin(nloc), Rmixmin(nloc), SQmRmin(nloc)
+      real signhpmh(nloc)
+      real Sx(nloc), Scrit2
+      real smid(nloc), sjmin(nloc), sjmax(nloc)
+      real Sbef(nloc), Sup(nloc), Smin(nloc)
+      real asij(nloc), smax(nloc), scrit(nloc)
+      real sij(nloc,nd,nd)
+      real csum(nloc,nd)
+      real awat
+      logical lwork(nloc)
+c
+      REAL amxupcrit, df, ff
+      INTEGER nstep
+C
+c --   Mixing probability distribution functions
+c
+      real Qcoef1,Qcoef2,QFF,QFFF,Qmix,Rmix,Qmix1,Rmix1,Qmix2,Rmix2,F
+      Qcoef1(F) = tanh(F/gammas)
+      Qcoef2(F) = ( tanh(F/gammas) + gammas *
+     $            log(cosh((1.- F)/gammas)/cosh(F/gammas)))
+      QFF(F) = Max(Min(F,1.),0.)
+      QFFF(F) = Min(QFF(F),scut)
+      Qmix1(F) = ( tanh((QFF(F) - Fmax)/gammas)+Qcoef1max )/
+     $           Qcoef2max
+      Rmix1(F) = ( gammas*log(cosh((QFF(F)-Fmax)/gammas))
+     1             +QFF(F)*Qcoef1max ) / Qcoef2max
+      Qmix2(F) = -Log(1.-QFFF(F))/scut
+      Rmix2(F) = (QFFF(F)+(1.-QFF(F))*Log(1.-QFFF(F)))/scut
+      Qmix(F) = qqa1*Qmix1(F) + qqa2*Qmix2(F)
+      Rmix(F) = qqa1*Rmix1(F) + qqa2*Rmix2(F)
+C
+      INTEGER, SAVE :: ifrst
+      DATA ifrst/0/
+c$OMP THREADPRIVATE(ifrst)
+C
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+c
+c -- Initialize mixing PDF coefficients
+      IF (ifrst .EQ. 0) THEN
+        ifrst = 1
+        Qcoef1max = Qcoef1(Fmax)
+        Qcoef2max = Qcoef2(Fmax)
+c
+      ENDIF
+c
+
+c ori        do 360 i=1,ncum*nlp
+        do 361 j=1,nl
+        do 360 i=1,ncum
+          nent(i,j)=0
+c in convect3, m is computed in cv3_closure
+c ori          m(i,1)=0.0
+ 360    continue
+ 361    continue
+
+c ori      do 400 k=1,nlp
+c ori       do 390 j=1,nlp
+      do 400 j=1,nl
+       do 390 k=1,nl
+          do 385 i=1,ncum
+            qent(i,k,j)=rr(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+            hent(i,k,j)=0.0
+!AC!            ment(i,k,j)=0.0
+!AC!            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+
+!AC!
+      ment(1:ncum,1:nd,1:nd)=0.0
+      sij(1:ncum,1:nd,1:nd)=0.0
+!AC!
+
+      do k=1,ntra
+       do j=1,nd  ! instead nlp
+        do i=1,nd ! instead nlp
+         do il=1,ncum
+            traent(il,i,j,k)=tra(il,j,k)
+         enddo
+        enddo
+       enddo
+      enddo
+
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+
+      do 750 i=minorig+1, nl
+
+       do 710 j=minorig,nl
+        do 700 il=1,ncum
+         if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+
+          rti=qnk(il)-ep(il,i)*clw(il,i)
+          bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd)
+          anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j))
+          denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j)
+          dei=denom
+          if(abs(dei).lt.0.01)dei=0.01
+          sij(il,i,j)=anum/dei
+          sij(il,i,i)=1.0
+          altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+          altem=altem/bf2
+          cwat=clw(il,j)*(1.-ep(il,j))
+          stemp=sij(il,i,j)
+          if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat)
+     :                 .and.j.gt.i)then
+           anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2)
+           denom=denom+lv(il,j)*(rr(il,i)-rti)
+           if(abs(denom).lt.0.01)denom=0.01
+           sij(il,i,j)=anum/denom
+           altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+           altem=altem-(bf2-1.)*cwat
+          end if
+              if(sij(il,i,j).gt.0.0)then
+ccc                 ment(il,i,j)=m(il,i)
+                 ment(il,i,j)=1.
+                 elij(il,i,j)=altem
+                 elij(il,i,j)=amax1(0.0,elij(il,i,j))
+                 nent(il,i)=nent(il,i)+1
+              endif
+
+         sij(il,i,j)=amax1(0.0,sij(il,i,j))
+         sij(il,i,j)=amin1(1.0,sij(il,i,j))
+         endif ! new
+ 700   continue
+ 710  continue
+
+c
+c   ***   if no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+
+c@      do 170 i=icb(il),inb(il)
+
+      do 740 il=1,ncum
+      if ((i.ge.icb(il)).and.(i.le.inb(il))
+     :                  .and.(nent(il,i).eq.0)) then
+c@      if(nent(il,i).eq.0)then
+ccc      ment(il,i,i)=m(il,i)
+      ment(il,i,i)=1.
+      qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i)
+      uent(il,i,i)=unk(il)
+      vent(il,i,i)=vnk(il)
+      elij(il,i,i)=clw(il,i)*(1.-ep(il,i))
+      sij(il,i,i)=0.0
+      end if
+ 740  continue
+ 750  continue
+
+      do j=1,ntra
+       do i=minorig+1,nl
+        do il=1,ncum
+         if (i.ge.icb(il) .and. i.le.inb(il)
+     :                    .and. nent(il,i).eq.0) then
+          traent(il,i,i,j)=tra(il,nk(il),j)
+         endif
+        enddo
+       enddo
+      enddo
+
+      do 100 j=minorig,nl
+      do 101 i=minorig,nl
+      do 102 il=1,ncum
+      if ((j.ge.(icb(il)-1)).and.(j.le.inb(il))
+     :    .and.(i.ge.icb(il)).and.(i.le.inb(il)))then
+       sigij(il,i,j)=sij(il,i,j)
+      endif
+ 102  continue
+ 101  continue
+ 100  continue
+c@      enddo
+
+c@170   continue
+
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+
+      call zilch(csum,nloc*nd)
+
+      do il=1,ncum
+       lwork(il) = .FALSE.
+      enddo
+
+c---------------------------------------------------------------
+      DO 789 i=minorig+1,nl     !Loop on origin level "i"
+c---------------------------------------------------------------
+
+      num1=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1
+      enddo
+      if (num1.le.0) goto 789
+
+c
+cjyg1    Find maximum of SIJ for J>I, if any.
+c
+       Sx(:) = 0.
+c
+       DO il = 1,ncum
+        IF ( i.ge.icb(il) .and. i.le.inb(il) ) THEN
+         Signhpmh(il) = sign(1.,hp(il,i)-h(il,i))
+         Sbef(il) = max(0.,signhpmh(il))
+        ENDIF
+       ENDDO
+
+       DO j = i+1,nl
+        DO il = 1,ncum
+         IF ( i.ge.icb(il) .and. i.le.inb(il)
+     :         .and. j.le.inb(il) ) THEN
+          IF (Sbef(il) .LT. Sij(il,i,j)) THEN
+            Sx(il) = max(Sij(il,i,j),Sx(il))
+          ENDIF
+          Sbef(il) = Sij(il,i,j)
+         ENDIF
+        ENDDO
+       ENDDO
+c
+
+      do 781 il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) then
+        lwork(il)=(nent(il,i).ne.0)
+        qp=qnk(il)-ep(il,i)*clw(il,i)
+        anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i))
+     :           +(cpv-cpd)*t(il,i)*(qp-rr(il,i))
+        denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp)
+     :           +(cpd-cpv)*t(il,i)*(rr(il,i)-qp)
+        if(abs(denom).lt.0.01)denom=0.01
+        scrit(il)=min(anum/denom,1.)
+        alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp)
+c
+cjyg1    Find new critical value Scrit2
+c        such that : Sij > Scrit2  => mixed draught will detrain at J<I
+c                    Sij < Scrit2  => mixed draught will detrain at J>I
+c
+       Scrit2 = min(Scrit(il),Sx(il))*max(0.,-signhpmh(il))
+     :         +Scrit(il)*max(0.,signhpmh(il))
+c
+       Scrit(il) = Scrit2
+c
+cjyg    Correction pour la nouvelle logique; la correction pour ALT
+c       est un peu au hazard
+       if(scrit(il).le.0.0)scrit(il)=0.0
+       if(alt.le.0.0) scrit(il)=1.0
+C
+        smax(il)=0.0
+        asij(il)=0.0
+       Sup(il)=0.     ! upper S-value reached by descending draughts
+       endif
+781   continue
+
+c---------------------------------------------------------------
+      do 175 j=minorig,nl   !Loop on destination level "j"
+c---------------------------------------------------------------
+
+      num2=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) num2=num2+1
+      enddo
+      if (num2.le.0) goto 175
+
+c -----------------------------------------------
+         IF (j .GT. i) THEN
+c -----------------------------------------------
+      do 782 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+           Smid(il)=min(Sij(il,i,j),Scrit(il))
+           Sjmax(il)=Smid(il)
+           Sjmin(il)=Smid(il)
+           IF (Smid(il) .LT. Smin(il) .AND.
+     1                         Sij(il,i,j+1) .LT. Smid(il)) THEN
+             Smin(il)=Smid(il)
+             Sjmax(il)=min( (Sij(il,i,j+1)+Sij(il,i,j))/2. ,
+     1                  Sij(il,i,j) ,
+     1                  Scrit(il) )
+             Sjmin(il)=max( (Sbef(il)+Sij(il,i,j))/2. ,
+     1                  Sij(il,i,j) )
+             Sjmin(il)=min(Sjmin(il),Scrit(il))
+             Sbef(il) = Sij(il,i,j)
+           ENDIF
+      endif
+      endif
+782   continue
+c -----------------------------------------------
+         ELSE IF (j .EQ. i) THEN
+c -----------------------------------------------
+      do 783 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+           Smid(il) = 1.
+           Sjmin(il) = max((Sij(il,i,j-1)+Smid(il))/2.,Scrit(il))
+     1                                         *max(0.,-signhpmh(il))
+     1            +min((Sij(il,i,j+1)+Smid(il))/2.,Scrit(il))
+     1                                         *max(0., signhpmh(il))
+           Sjmin(il) = max(Sjmin(il),Sup(il))
+           Sjmax(il) = 1.
+c
+c-           preparation des variables Scrit, Smin et Sbef pour la partie j>i
+           Scrit(il) = min(Sjmin(il),Sjmax(il),Scrit(il))
+
+           Smin(il) = 1.
+           Sbef(il) = max(0.,signhpmh(il))
+           Supmax(il,i) = sign(Scrit(il),-signhpmh(il))
+      endif
+      endif
+783   continue
+c -----------------------------------------------
+         ELSE IF ( j .LT. i) THEN
+c -----------------------------------------------
+      do 784 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+           Smid(il)=max(Sij(il,i,j),Scrit(il))
+           Sjmax(il) = Smid(il)
+           Sjmin(il) = Smid(il)
+           IF (Smid(il) .GT. Smax(il) .AND.
+     1                          Sij(il,i,j+1) .GT. Smid(il)) THEN
+             Smax(il) = Smid(il)
+             Sjmax(il) = max( (Sij(il,i,j+1)+Sij(il,i,j))/2. ,
+     1                                               Sij(il,i,j) )
+             Sjmax(il) = max(Sjmax(il),Scrit(il))
+             Sjmin(il) = min( (Sbef(il)+Sij(il,i,j))/2. ,
+     1                                               Sij(il,i,j) )
+             Sjmin(il) = max(Sjmin(il),Scrit(il))
+             Sbef(il) = Sij(il,i,j)
+           ENDIF
+          IF (abs(Sjmin(il)-Sjmax(il)) .GT. 1.e-10) Sup(il)=
+     1                            max(Sjmin(il),Sjmax(il),Sup(il))
+      endif
+      endif
+784   continue
+c -----------------------------------------------
+         END IF
+c -----------------------------------------------
+c
+c
+      do il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+         rti=qnk(il)-ep(il,i)*clw(il,i)
+         Qmixmax(il)=Qmix(Sjmax(il))
+         Qmixmin(il)=Qmix(Sjmin(il))
+         Rmixmax(il)=Rmix(Sjmax(il))
+         Rmixmin(il)=Rmix(Sjmin(il))
+         SQmRmax(il)= Sjmax(il)*Qmix(Sjmax(il))-Rmix(Sjmax(il))
+         SQmRmin(il)= Sjmin(il)*Qmix(Sjmin(il))-Rmix(Sjmin(il))
+c
+         Ment(il,i,j) = abs(Qmixmax(il)-Qmixmin(il))*Ment(il,i,j)
+c
+c    Sigij(i,j) is the 'true' mixing fraction of mixture Ment(i,j)
+         IF (abs(Qmixmax(il)-Qmixmin(il)) .GT. 1.e-10) THEN
+           Sigij(il,i,j) =
+     :           (SQmRmax(il)-SQmRmin(il))/(Qmixmax(il)-Qmixmin(il))
+         ELSE
+           Sigij(il,i,j) = 0.
+         ENDIF
+c
+c --    Compute Qent, uent, vent according to the true mixing fraction
+        Qent(il,i,j) = (1.-Sigij(il,i,j))*rti
+     :               + Sigij(il,i,j)*rr(il,i)
+        uent(il,i,j) = (1.-Sigij(il,i,j))*unk(il)
+     :               + Sigij(il,i,j)*u(il,i)
+        vent(il,i,j) = (1.-Sigij(il,i,j))*vnk(il)
+     :               + Sigij(il,i,j)*v(il,i)
+c
+c--     Compute liquid water static energy of mixed draughts
+c       IF (j .GT. i) THEN
+c        awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j)
+c        awat=amax1(awat,0.0)
+c       ELSE
+c        awat = 0.
+c       ENDIF
+c       Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i)
+c    :         + Sigij(il,i,j)*H(il,i)
+c    :         + (LV(il,j)+(cpd-cpv)*t(il,j))*awat
+cIM 301008 beg
+        Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i)
+     :         + Sigij(il,i,j)*H(il,i)
+
+        Elij(il,i,j) = Qent(il,i,j)-rs(il,j)
+        Elij(il,i,j) = Elij(il,i,j)
+     :    + ((h(il,j)-Hent(il,i,j))*rs(il,j)*LV(il,j)
+     :    / ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)
+     :    * rrv*t(il,j)*t(il,j)))
+        Elij(il,i,j) = Elij(il,i,j)
+     :    / (1.+LV(il,j)*LV(il,j)*rs(il,j)
+     :    / ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)
+     :    * rrv*t(il,j)*t(il,j)))
+
+        Elij(il,i,j) = max(elij(il,i,j),0.)
+
+        Elij(il,i,j) = min(elij(il,i,j),Qent(il,i,j))
+
+        IF (j .GT. i) THEN
+         awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j)
+         awat=amax1(awat,0.0)
+        ELSE
+         awat = 0.
+        ENDIF
+
+c        print *,h(il,j)-hent(il,i,j),LV(il,j)*rs(il,j)/(cpd*rrv*t(il,j)*
+c    :         t(il,j))
+
+        Hent(il,i,j) =  Hent(il,i,j)+(LV(il,j)+(cpd-cpv)*t(il,j))
+     :         * awat
+cIM 301008 end
+c
+c      print *,'mix : i,j,hent(il,i,j),sigij(il,i,j) ',
+c     :               i,j,hent(il,i,j),sigij(il,i,j)
+c
+c --      ASij is the integral of P(F) over the relevant F interval
+         ASij(il) = ASij(il)
+     1               + abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il)
+     1                    -Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il))
+c
+      endif
+      endif
+      enddo
+       do k=1,ntra
+         do il=1,ncum
+          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il))
+     :      .and. lwork(il) ) then
+          if(sij(il,i,j).gt.0.0)then
+            traent(il,i,j,k)=sigij(il,i,j)*tra(il,i,k)
+     :            +(1.-sigij(il,i,j))*tra(il,nk(il),k)
+          endif
+          endif
+         enddo
+       enddo
+c
+c --    If I=J (detrainement and entrainement at the same level), then only the
+c --    adiabatic ascent part of the mixture is considered
+        IF (I .EQ. J) THEN
+      do il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.
+     :      j.ge.(icb(il)-1) .and. j.le.inb(il)
+     :      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+          rti=qnk(il)-ep(il,i)*clw(il,i)
+ccc          Ment(il,i,i) = m(il,i)*abs(Qmixmax(il)*(1.-Sjmax(il))
+          Ment(il,i,i) = abs(Qmixmax(il)*(1.-Sjmax(il))
+     1                    +Rmixmax(il)
+     1                    -Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il))
+          Qent(il,i,i) = rti
+          uent(il,i,i) = unk(il)
+          vent(il,i,i) = vnk(il)
+          Hent(il,i,i) = hp(il,i)
+          Elij(il,i,i) = clw(il,i)*(1.-ep(il,i))
+          Sigij(il,i,i) = 0.
+      endif
+      endif
+      enddo
+       do k=1,ntra
+         do il=1,ncum
+          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.
+     :       (j.ge.(icb(il)-1)).and.(j.le.inb(il))
+     :      .and. lwork(il) ) then
+          if(sij(il,i,j).gt.0.0)then
+            traent(il,i,i,k)=tra(il,nk(il),k)
+          endif
+          endif
+         enddo
+       enddo
+c
+        ENDIF
+c
+175   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        asij(il)=amax1(1.0e-16,asij(il))
+        asij(il)=1.0/asij(il)
+        csum(il,i)=0.0
+       endif
+      enddo
+
+      do 180 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asij(il)
+        endif
+       enddo
+180   continue
+
+      do 197 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         csum(il,i)=csum(il,i)+ment(il,i,j)
+        endif
+       enddo
+197   continue
+
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :     .and. csum(il,i).lt.1. ) then
+ccc     :     .and. csum(il,i).lt.m(il,i) ) then
+        nent(il,i)=0
+ccc        ment(il,i,i)=m(il,i)
+        ment(il,i,i)=1.
+        qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i)
+        uent(il,i,i)=unk(il)
+        vent(il,i,i)=vnk(il)
+        elij(il,i,i)=clw(il,i)*(1.-ep(il,i))
+        sij(il,i,i)=0.0
+       endif
+      enddo ! il
+
+      do j=1,ntra
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)
+     :     .and. csum(il,i).lt.1. ) then
+ccc     :     .and. csum(il,i).lt.m(il,i) ) then
+         traent(il,i,i,j)=tra(il,nk(il),j)
+        endif
+       enddo
+      enddo
+c
+789   continue
+c
+      return
+      end
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3p_mixing.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3p_mixing.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3p_mixing.F90	(revision 17)
@@ -0,0 +1,598 @@
+      SUBROUTINE cv3p_mixing(nloc,ncum,nd,na,ntra,icb,nk,inb                         &
+       &                    ,ph,t,rr,rs,u,v,tra,h,lv,qnk                             &
+       &                    ,unk,vnk,hp,tv,tvp,ep,clw,sig                            &
+       &                    ,ment,qent,hent,uent,vent,nent                           &
+       &                   ,sigij,elij,supmax,ments,qents,traent)
+!***************************************************************
+!*                                                             *
+!* CV3P_MIXING : compute mixed draught properties and,         *
+!*               within a scaling factor, mixed draught        *
+!*               mass fluxes.                                  *
+!* written by  : VTJ Philips,JY Grandpeix, 21/05/2003, 09.14.15*
+!* modified by :                                               *
+!***************************************************************
+!*
+      implicit none
+!c
+#include "cvthermo.h"
+#include "cv3param.h"
+#include "YOMCST2.h"
+
+!c inputs:
+      integer ncum, nd, na, ntra, nloc
+      integer icb(nloc), inb(nloc), nk(nloc)
+      real sig(nloc,nd)
+      real qnk(nloc),unk(nloc),vnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), rr(nloc,nd), rs(nloc,nd)
+      real u(nloc,nd), v(nloc,nd)
+      real tra(nloc,nd,ntra) ! input of convect3
+      real lv(nloc,na)
+      real h(nloc,na)  !liquid water static energy of environment
+      real hp(nloc,na) !liquid water static energy of air shed from adiab. asc.
+      real tv(nloc,na), tvp(nloc,na), ep(nloc,na), clw(nloc,na)
+
+!c outputs:
+      real ment(nloc,na,na), qent(nloc,na,na)
+      real uent(nloc,na,na), vent(nloc,na,na)
+      real sigij(nloc,na,na), elij(nloc,na,na)
+      real supmax(nloc,na)     ! Highest mixing fraction of mixed updraughts
+                               ! with the sign of (h-hp)
+      real traent(nloc,nd,nd,ntra)
+      real ments(nloc,nd,nd), qents(nloc,nd,nd)
+      real hent(nloc,nd,nd)
+      integer nent(nloc,nd)
+
+!c local variables:
+      integer i, j, k, il, im, jm
+      integer num1, num2
+      real rti, bf2, anum, denom, dei, altem, cwat, stemp, qp
+      real alt, delp, delm
+      real Qmixmax(nloc), Rmixmax(nloc), SQmRmax(nloc)
+      real Qmixmin(nloc), Rmixmin(nloc), SQmRmin(nloc)
+      real signhpmh(nloc)
+      real Sx(nloc), Scrit2
+      real smid(nloc), sjmin(nloc), sjmax(nloc)
+      real Sbef(nloc), Sup(nloc), Smin(nloc)
+      real asij(nloc), smax(nloc), scrit(nloc)
+      real sij(nloc,nd,nd)
+      real csum(nloc,nd)
+      real awat
+      logical lwork(nloc)
+!c
+      REAL amxupcrit, df, ff
+      INTEGER nstep
+!C
+!c --   Mixing probability distribution functions
+!c
+      real Qcoef1,Qcoef2,QFF,QFFF,Qmix,Rmix,Qmix1,Rmix1,Qmix2,Rmix2,F
+      Qcoef1(F) = tanh(F/gammas)
+      Qcoef2(F) = ( tanh(F/gammas) + gammas *                                        &
+       &            log(cosh((1.- F)/gammas)/cosh(F/gammas)))
+      QFF(F) = Max(Min(F,1.),0.)
+      QFFF(F) = Min(QFF(F),scut)
+      Qmix1(F) = ( tanh((QFF(F) - Fmax)/gammas)+Qcoef1max )/                         &
+       &           Qcoef2max
+      Rmix1(F) = ( gammas*log(cosh((QFF(F)-Fmax)/gammas))                            &
+       &             +QFF(F)*Qcoef1max ) / Qcoef2max
+      Qmix2(F) = -Log(1.-QFFF(F))/scut
+      Rmix2(F) = (QFFF(F)+(1.-QFF(F))*Log(1.-QFFF(F)))/scut
+      Qmix(F) = qqa1*Qmix1(F) + qqa2*Qmix2(F)
+      Rmix(F) = qqa1*Rmix1(F) + qqa2*Rmix2(F)
+!C
+      INTEGER, SAVE :: ifrst
+      DATA ifrst/0/
+!$OMP THREADPRIVATE(ifrst)
+!C
+
+!c=====================================================================
+!c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+!c=====================================================================
+!c
+!c -- Initialize mixing PDF coefficients
+      IF (ifrst .EQ. 0) THEN
+        ifrst = 1
+        Qcoef1max = Qcoef1(Fmax)
+        Qcoef2max = Qcoef2(Fmax)
+!c
+      ENDIF
+!c
+
+!c ori        do 360 i=1,ncum*nlp
+        do 361 j=1,nl
+        do 360 i=1,ncum
+          nent(i,j)=0
+!c in convect3, m is computed in cv3_closure
+!c ori          m(i,1)=0.0
+ 360    continue
+ 361    continue
+
+!c ori      do 400 k=1,nlp
+!c ori       do 390 j=1,nlp
+      do 400 j=1,nl
+       do 390 k=1,nl
+          do 385 i=1,ncum
+            qent(i,k,j)=rr(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+            hent(i,k,j)=0.0
+!AC!            ment(i,k,j)=0.0
+!AC!            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+
+!AC!
+      ment(1:ncum,1:nd,1:nd)=0.0
+      sij(1:ncum,1:nd,1:nd)=0.0
+!AC!
+
+      do k=1,ntra
+       do j=1,nd  ! instead nlp
+        do i=1,nd ! instead nlp
+         do il=1,ncum
+            traent(il,i,j,k)=tra(il,j,k)
+         enddo
+        enddo
+       enddo
+      enddo
+
+!c=====================================================================
+!c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+!c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+!c --- FRACTION (sij)
+!c=====================================================================
+
+      do 750 i=minorig+1, nl
+
+       do 710 j=minorig,nl
+        do 700 il=1,ncum
+         if( (i.ge.icb(il)).and.(i.le.inb(il)).and.                                  &
+       &      (j.ge.(icb(il)-1)).and.(j.le.inb(il)))then
+
+          rti=qnk(il)-ep(il,i)*clw(il,i)
+          bf2=1.+lv(il,j)*lv(il,j)*rs(il,j)/(rrv*t(il,j)*t(il,j)*cpd)
+          anum=h(il,j)-hp(il,i)+(cpv-cpd)*t(il,j)*(rti-rr(il,j))
+          denom=h(il,i)-hp(il,i)+(cpd-cpv)*(rr(il,i)-rti)*t(il,j)
+          dei=denom
+          if(abs(dei).lt.0.01)dei=0.01
+          sij(il,i,j)=anum/dei
+          sij(il,i,i)=1.0
+          altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+          altem=altem/bf2
+          cwat=clw(il,j)*(1.-ep(il,j))
+          stemp=sij(il,i,j)
+          if((stemp.lt.0.0.or.stemp.gt.1.0.or.altem.gt.cwat)                         &
+       &                 .and.j.gt.i)then
+           anum=anum-lv(il,j)*(rti-rs(il,j)-cwat*bf2)
+           denom=denom+lv(il,j)*(rr(il,i)-rti)
+           if(abs(denom).lt.0.01)denom=0.01
+           sij(il,i,j)=anum/denom
+           altem=sij(il,i,j)*rr(il,i)+(1.-sij(il,i,j))*rti-rs(il,j)
+           altem=altem-(bf2-1.)*cwat
+          end if
+              if(sij(il,i,j).gt.0.0)then
+!ccc                 ment(il,i,j)=m(il,i)
+                 ment(il,i,j)=1.
+                 elij(il,i,j)=altem
+                 elij(il,i,j)=amax1(0.0,elij(il,i,j))
+                 nent(il,i)=nent(il,i)+1
+              endif
+
+         sij(il,i,j)=amax1(0.0,sij(il,i,j))
+         sij(il,i,j)=amin1(1.0,sij(il,i,j))
+         endif ! new
+ 700   continue
+ 710  continue
+
+!c
+!c   ***   if no air can entrain at level i assume that updraft detrains  ***
+!c   ***   at that level and calculate detrained air flux and properties  ***
+!c
+
+!c@      do 170 i=icb(il),inb(il)
+
+      do 740 il=1,ncum
+      if ((i.ge.icb(il)).and.(i.le.inb(il))                                          &
+       &                  .and.(nent(il,i).eq.0)) then
+!c@      if(nent(il,i).eq.0)then
+!ccc      ment(il,i,i)=m(il,i)
+      ment(il,i,i)=1.
+      qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i)
+      uent(il,i,i)=unk(il)
+      vent(il,i,i)=vnk(il)
+      elij(il,i,i)=clw(il,i)*(1.-ep(il,i))
+      sij(il,i,i)=0.0
+      end if
+ 740  continue
+ 750  continue
+
+      do j=1,ntra
+       do i=minorig+1,nl
+        do il=1,ncum
+         if (i.ge.icb(il) .and. i.le.inb(il)                                         &
+       &                    .and. nent(il,i).eq.0) then
+          traent(il,i,i,j)=tra(il,nk(il),j)
+         endif
+        enddo
+       enddo
+      enddo
+
+      do 100 j=minorig,nl
+      do 101 i=minorig,nl
+      do 102 il=1,ncum
+      if ((j.ge.(icb(il)-1)).and.(j.le.inb(il))                                      &
+       &    .and.(i.ge.icb(il)).and.(i.le.inb(il)))then
+       sigij(il,i,j)=sij(il,i,j)
+      endif
+ 102  continue
+ 101  continue
+ 100  continue
+!c@      enddo
+
+!c@170   continue
+
+!c=====================================================================
+!c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+!c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+!c=====================================================================
+
+      call zilch(csum,nloc*nd)
+
+      do il=1,ncum
+       lwork(il) = .FALSE.
+      enddo
+
+!c---------------------------------------------------------------
+      DO 789 i=minorig+1,nl     !Loop on origin level "i"
+!c---------------------------------------------------------------
+
+      num1=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) num1=num1+1
+      enddo
+      if (num1.le.0) goto 789
+
+!c
+!cjyg1    Find maximum of SIJ for J>I, if any.
+!c
+       Sx(:) = 0.
+!c
+       DO il = 1,ncum
+        IF ( i.ge.icb(il) .and. i.le.inb(il) ) THEN
+         Signhpmh(il) = sign(1.,hp(il,i)-h(il,i))
+         Sbef(il) = max(0.,signhpmh(il))
+        ENDIF
+       ENDDO
+
+       DO j = i+1,nl
+        DO il = 1,ncum
+         IF ( i.ge.icb(il) .and. i.le.inb(il)                                        &
+       &         .and. j.le.inb(il) ) THEN
+          IF (Sbef(il) .LT. Sij(il,i,j)) THEN
+            Sx(il) = max(Sij(il,i,j),Sx(il))
+          ENDIF
+          Sbef(il) = Sij(il,i,j)
+         ENDIF
+        ENDDO
+       ENDDO
+!c
+
+      do 781 il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) ) then
+        lwork(il)=(nent(il,i).ne.0)
+        qp=qnk(il)-ep(il,i)*clw(il,i)
+        anum=h(il,i)-hp(il,i)-lv(il,i)*(qp-rs(il,i))                                 &
+       &           +(cpv-cpd)*t(il,i)*(qp-rr(il,i))
+        denom=h(il,i)-hp(il,i)+lv(il,i)*(rr(il,i)-qp)                                &
+       &           +(cpd-cpv)*t(il,i)*(rr(il,i)-qp)
+        if(abs(denom).lt.0.01)denom=0.01
+        scrit(il)=min(anum/denom,1.)
+        alt=qp-rs(il,i)+scrit(il)*(rr(il,i)-qp)
+!c
+!cjyg1    Find new critical value Scrit2
+!c        such that : Sij > Scrit2  => mixed draught will detrain at J<I
+!c                    Sij < Scrit2  => mixed draught will detrain at J>I
+!c
+       Scrit2 = min(Scrit(il),Sx(il))*max(0.,-signhpmh(il))                          &
+       &         +Scrit(il)*max(0.,signhpmh(il))
+!c
+       Scrit(il) = Scrit2
+!c
+!cjyg    Correction pour la nouvelle logique; la correction pour ALT
+!c       est un peu au hazard
+       if(scrit(il).le.0.0)scrit(il)=0.0
+       if(alt.le.0.0) scrit(il)=1.0
+!C
+        smax(il)=0.0
+        asij(il)=0.0
+       Sup(il)=0.     ! upper S-value reached by descending draughts
+       endif
+781   continue
+
+!c---------------------------------------------------------------
+      do 175 j=minorig,nl   !Loop on destination level "j"
+!c---------------------------------------------------------------
+
+      num2=0
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and.                                    &
+       &      j.ge.(icb(il)-1) .and. j.le.inb(il)                                    &
+       &      .and. lwork(il) ) num2=num2+1
+      enddo
+      if (num2.le.0) goto 175
+
+!c -----------------------------------------------
+         IF (j .GT. i) THEN
+!c -----------------------------------------------
+      do 782 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.                                     &
+       &      j.ge.(icb(il)-1) .and. j.le.inb(il)                                    &
+       &      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+           Smid(il)=min(Sij(il,i,j),Scrit(il))
+           Sjmax(il)=Smid(il)
+           Sjmin(il)=Smid(il)
+           IF (Smid(il) .LT. Smin(il) .AND.                                          &
+       &                         Sij(il,i,j+1) .LT. Smid(il)) THEN
+             Smin(il)=Smid(il)
+             Sjmax(il)=min( (Sij(il,i,j+1)+Sij(il,i,j))/2. ,                         &
+       &                  Sij(il,i,j) ,                                              &
+       &                  Scrit(il) )
+             Sjmin(il)=max( (Sbef(il)+Sij(il,i,j))/2. ,                              &
+       &                  Sij(il,i,j) )
+             Sjmin(il)=min(Sjmin(il),Scrit(il))
+             Sbef(il) = Sij(il,i,j)
+           ENDIF
+      endif
+      endif
+782   continue
+!c -----------------------------------------------
+         ELSE IF (j .EQ. i) THEN
+!c -----------------------------------------------
+      do 783 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.                                     &
+       &      j.ge.(icb(il)-1) .and. j.le.inb(il)                                    &
+       &      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+           Smid(il) = 1.
+           Sjmin(il) = max((Sij(il,i,j-1)+Smid(il))/2.,Scrit(il))                    &
+       &                                         *max(0.,-signhpmh(il))              &
+       &            +min((Sij(il,i,j+1)+Smid(il))/2.,Scrit(il))                      &
+       &                                         *max(0., signhpmh(il))
+           Sjmin(il) = max(Sjmin(il),Sup(il))
+           Sjmax(il) = 1.
+!c
+!c-           preparation des variables Scrit, Smin et Sbef pour la partie j>i
+           Scrit(il) = min(Sjmin(il),Sjmax(il),Scrit(il))
+
+           Smin(il) = 1.
+           Sbef(il) = max(0.,signhpmh(il))
+           Supmax(il,i) = sign(Scrit(il),-signhpmh(il))
+      endif
+      endif
+783   continue
+!c -----------------------------------------------
+         ELSE IF ( j .LT. i) THEN
+!c -----------------------------------------------
+      do 784 il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.                                     &
+       &      j.ge.(icb(il)-1) .and. j.le.inb(il)                                    &
+       &      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+           Smid(il)=max(Sij(il,i,j),Scrit(il))
+           Sjmax(il) = Smid(il)
+           Sjmin(il) = Smid(il)
+           IF (Smid(il) .GT. Smax(il) .AND.                                          &
+       &                          Sij(il,i,j+1) .GT. Smid(il)) THEN
+             Smax(il) = Smid(il)
+             Sjmax(il) = max( (Sij(il,i,j+1)+Sij(il,i,j))/2. ,                       &
+       &                                               Sij(il,i,j) )
+             Sjmax(il) = max(Sjmax(il),Scrit(il))
+             Sjmin(il) = min( (Sbef(il)+Sij(il,i,j))/2. ,                            &
+       &                                               Sij(il,i,j) )
+             Sjmin(il) = max(Sjmin(il),Scrit(il))
+             Sbef(il) = Sij(il,i,j)
+           ENDIF
+          IF (abs(Sjmin(il)-Sjmax(il)) .GT. 1.e-10) Sup(il)=                         &
+       &                            max(Sjmin(il),Sjmax(il),Sup(il))
+      endif
+      endif
+784   continue
+!c -----------------------------------------------
+         END IF
+!c -----------------------------------------------
+!c
+!c
+      do il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.                                     &
+       &      j.ge.(icb(il)-1) .and. j.le.inb(il)                                    &
+       &      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+         rti=qnk(il)-ep(il,i)*clw(il,i)
+         Qmixmax(il)=Qmix(Sjmax(il))
+         Qmixmin(il)=Qmix(Sjmin(il))
+         Rmixmax(il)=Rmix(Sjmax(il))
+         Rmixmin(il)=Rmix(Sjmin(il))
+         SQmRmax(il)= Sjmax(il)*Qmix(Sjmax(il))-Rmix(Sjmax(il))
+         SQmRmin(il)= Sjmin(il)*Qmix(Sjmin(il))-Rmix(Sjmin(il))
+!c
+         Ment(il,i,j) = abs(Qmixmax(il)-Qmixmin(il))*Ment(il,i,j)
+!c
+!c    Sigij(i,j) is the 'true' mixing fraction of mixture Ment(i,j)
+         IF (abs(Qmixmax(il)-Qmixmin(il)) .GT. 1.e-10) THEN
+           Sigij(il,i,j) =                                                           &
+       &           (SQmRmax(il)-SQmRmin(il))/(Qmixmax(il)-Qmixmin(il))
+         ELSE
+           Sigij(il,i,j) = 0.
+         ENDIF
+!c
+!c --    Compute Qent, uent, vent according to the true mixing fraction
+        Qent(il,i,j) = (1.-Sigij(il,i,j))*rti                                        &
+       &               + Sigij(il,i,j)*rr(il,i)
+        uent(il,i,j) = (1.-Sigij(il,i,j))*unk(il)                                    &
+       &               + Sigij(il,i,j)*u(il,i)
+        vent(il,i,j) = (1.-Sigij(il,i,j))*vnk(il)                                    &
+       &               + Sigij(il,i,j)*v(il,i)
+!c
+!c--     Compute liquid water static energy of mixed draughts
+!c       IF (j .GT. i) THEN
+!c        awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j)
+!c        awat=amax1(awat,0.0)
+!c       ELSE
+!c        awat = 0.
+!c       ENDIF
+!c       Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i)
+!c    :         + Sigij(il,i,j)*H(il,i)
+!c    :         + (LV(il,j)+(cpd-cpv)*t(il,j))*awat
+!IM 301008 beg
+        Hent(il,i,j) = (1.-Sigij(il,i,j))*HP(il,i)                                   &
+       &         + Sigij(il,i,j)*H(il,i)
+
+        Elij(il,i,j) = Qent(il,i,j)-rs(il,j)
+        Elij(il,i,j) = Elij(il,i,j)                                                  &
+       &    + ((h(il,j)-Hent(il,i,j))*rs(il,j)*LV(il,j)                              &
+       &    / ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)                              &
+       &    * rrv*t(il,j)*t(il,j)))
+        Elij(il,i,j) = Elij(il,i,j)                                                  &
+       &    / (1.+LV(il,j)*LV(il,j)*rs(il,j)                                         &
+       &    / ((cpd*(1.-Qent(il,i,j))+Qent(il,i,j)*cpv)                              &
+       &    * rrv*t(il,j)*t(il,j)))
+
+        Elij(il,i,j) = max(elij(il,i,j),0.)
+
+        Elij(il,i,j) = min(elij(il,i,j),Qent(il,i,j))
+
+        IF (j .GT. i) THEN
+         awat=elij(il,i,j)-(1.-ep(il,j))*clw(il,j)
+         awat=amax1(awat,0.0)
+        ELSE
+         awat = 0.
+        ENDIF
+
+!c        print *,h(il,j)-hent(il,i,j),LV(il,j)*rs(il,j)/(cpd*rrv*t(il,j)*
+!c    :         t(il,j))
+
+        Hent(il,i,j) =  Hent(il,i,j)+(LV(il,j)+(cpd-cpv)*t(il,j))                    &
+       &         * awat
+!IM 301008 end
+!c
+!c      print *,'mix : i,j,hent(il,i,j),sigij(il,i,j) ',
+!c     :               i,j,hent(il,i,j),sigij(il,i,j)
+!c
+!c --      ASij is the integral of P(F) over the relevant F interval
+         ASij(il) = ASij(il)                                                         &
+       &               + abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il)                  &
+       &                    -Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il))
+!c
+      endif
+      endif
+      enddo
+       do k=1,ntra
+         do il=1,ncum
+          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.                                 &
+       &       (j.ge.(icb(il)-1)).and.(j.le.inb(il))                                 &
+       &      .and. lwork(il) ) then
+          if(sij(il,i,j).gt.0.0)then
+            traent(il,i,j,k)=sigij(il,i,j)*tra(il,i,k)                               &
+       &            +(1.-sigij(il,i,j))*tra(il,nk(il),k)
+          endif
+          endif
+         enddo
+       enddo
+!c
+!c --    If I=J (detrainement and entrainement at the same level), then only the
+!c --    adiabatic ascent part of the mixture is considered
+        IF (I .EQ. J) THEN
+      do il=1,ncum
+      if ( i.ge.icb(il) .and. i.le.inb(il) .and.                                     &
+       &      j.ge.(icb(il)-1) .and. j.le.inb(il)                                    &
+       &      .and. lwork(il) ) then
+       if(sij(il,i,j).gt.0.0)then
+          rti=qnk(il)-ep(il,i)*clw(il,i)
+!ccc          Ment(il,i,i) = m(il,i)*abs(Qmixmax(il)*(1.-Sjmax(il))
+          Ment(il,i,i) = abs(Qmixmax(il)*(1.-Sjmax(il))                              &
+       &                    +Rmixmax(il)                                             &
+       &                    -Qmixmin(il)*(1.-Sjmin(il))-Rmixmin(il))
+          Qent(il,i,i) = rti
+          uent(il,i,i) = unk(il)
+          vent(il,i,i) = vnk(il)
+          Hent(il,i,i) = hp(il,i)
+          Elij(il,i,i) = clw(il,i)*(1.-ep(il,i))
+          Sigij(il,i,i) = 0.
+      endif
+      endif
+      enddo
+       do k=1,ntra
+         do il=1,ncum
+          if( (i.ge.icb(il)).and.(i.le.inb(il)).and.                                 &
+       &       (j.ge.(icb(il)-1)).and.(j.le.inb(il))                                 &
+       &      .and. lwork(il) ) then
+          if(sij(il,i,j).gt.0.0)then
+            traent(il,i,i,k)=tra(il,nk(il),k)
+          endif
+          endif
+         enddo
+       enddo
+!c
+        ENDIF
+!c
+175   continue
+
+      do il=1,ncum
+       if (i.ge.icb(il).and.i.le.inb(il).and.lwork(il)) then
+        asij(il)=amax1(1.0e-16,asij(il))
+        asij(il)=1.0/asij(il)
+        csum(il,i)=0.0
+       endif
+      enddo
+
+      do 180 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                         &
+       &   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         ment(il,i,j)=ment(il,i,j)*asij(il)
+        endif
+       enddo
+180   continue
+
+      do 197 j=minorig,nl
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                         &
+       &   .and. j.ge.(icb(il)-1) .and. j.le.inb(il) ) then
+         csum(il,i)=csum(il,i)+ment(il,i,j)
+        endif
+       enddo
+197   continue
+
+      do il=1,ncum
+       if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                          &
+       &     .and. csum(il,i).lt.1. ) then
+!ccc     :     .and. csum(il,i).lt.m(il,i) ) then
+        nent(il,i)=0
+!ccc        ment(il,i,i)=m(il,i)
+        ment(il,i,i)=1.
+        qent(il,i,i)=qnk(il)-ep(il,i)*clw(il,i)
+        uent(il,i,i)=unk(il)
+        vent(il,i,i)=vnk(il)
+        elij(il,i,i)=clw(il,i)*(1.-ep(il,i))
+        sij(il,i,i)=0.0
+       endif
+      enddo ! il
+
+      do j=1,ntra
+       do il=1,ncum
+        if ( i.ge.icb(il) .and. i.le.inb(il) .and. lwork(il)                         &
+       &     .and. csum(il,i).lt.1. ) then
+!ccc     :     .and. csum(il,i).lt.m(il,i) ) then
+         traent(il,i,i,j)=tra(il,nk(il),j)
+        endif
+       enddo
+      enddo
+!c
+789   continue
+!c
+      return
+      end
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3param.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3param.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv3param.h	(revision 17)
@@ -0,0 +1,32 @@
+!c------------------------------------------------------------
+!c Parameters for convectL, iflag_con=3:
+!c (includes - microphysical parameters,
+!c			- parameters that control the rate of approach
+!c               to quasi-equilibrium)
+!c			- noff & minorig (previously in input of convect1)
+!c------------------------------------------------------------
+
+      integer noff, minorig, nl, nlp, nlm
+      real sigdz, spfac
+      integer flag_epKEorig,flag_wb
+      real pbcrit, ptcrit
+      real elcrit, tlcrit
+      real omtrain
+      real dtovsh, dpbase, dttrig
+      real dtcrit, tau, beta, alpha, alpha1
+      real wbmax
+      real delta
+      real betad
+
+      COMMON /cv3param/  noff, minorig, nl, nlp, nlm                                 &
+       &                ,  sigdz, spfac                                              &
+       &                ,flag_epKEorig                                               &
+       &                ,pbcrit, ptcrit                                              &
+       &                ,elcrit, tlcrit                                              &
+       &                ,omtrain                                                     &
+       &                ,dtovsh, dpbase, dttrig                                      &
+       &                ,dtcrit, tau, beta, alpha, alpha1                            &
+       &                ,flag_wb,wbmax                                               &
+       &                ,delta, betad
+!$OMP THREADPRIVATE(/cv3param/)
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv_driver.F	(revision 17)
@@ -0,0 +1,771 @@
+!
+! $Header$
+!
+      SUBROUTINE cv_driver(len,nd,ndp1,ntra,iflag_con,
+     &                   t1,q1,qs1,u1,v1,tra1,
+     &                   p1,ph1,iflag1,ft1,fq1,fu1,fv1,ftra1,
+     &                   precip1,VPrecip1,
+     &                   cbmf1,sig1,w01,
+     &                   icb1,inb1,
+     &                   delt,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1,
+     &                   da1,phi1,mp1,phi21,d1a1,dam1,sij1,clw1,elij1,  ! RomP
+     &                   evap1,ep1,epmlmMm1,eplaMm1,                    ! RomP 
+     &                   wdtrainA1,wdtrainM1)                           ! RomP
+C
+      USE dimphy
+      implicit none
+C
+C.............................START PROLOGUE............................
+C
+!
+! All argument names (except len,nd,ntra,nloc,delt and the flags) have a "1" appended.
+! The "1" is removed for the corresponding compressed (local) variables.
+!
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      len           Integer        Input        first (i) dimension
+C      nd            Integer        Input        vertical (k) dimension
+C      ndp1          Integer        Input        nd + 1
+C      ntra          Integer        Input        number of tracors
+C      iflag_con     Integer        Input        version of convect (3/4)
+C      t1            Real           Input        temperature
+C      q1            Real           Input        specific hum
+C      qs1           Real           Input        sat specific hum
+C      u1            Real           Input        u-wind
+C      v1            Real           Input        v-wind
+C      tra1          Real           Input        tracors
+C      p1            Real           Input        full level pressure
+C      ph1           Real           Input        half level pressure
+C      iflag1        Integer        Output       flag for Emanuel conditions
+C      ft1           Real           Output       temp tend
+C      fq1           Real           Output       spec hum tend
+C      fu1           Real           Output       u-wind tend
+C      fv1           Real           Output       v-wind tend
+C      ftra1         Real           Output       tracor tend
+C      precip1       Real           Output       precipitation
+C      VPrecip1      Real           Output       vertical profile of precipitations
+C      cbmf1         Real           Output       cloud base mass flux
+C      sig1          Real           In/Out       section adiabatic updraft
+C      w01           Real           In/Out       vertical velocity within adiab updraft
+C      delt          Real           Input        time step
+C      Ma1           Real           Output       mass flux adiabatic updraft
+C      upwd1         Real           Output       total upward mass flux (adiab+mixed)
+C      dnwd1         Real           Output       saturated downward mass flux (mixed)
+C      dnwd01        Real           Output       unsaturated downward mass flux 
+C      qcondc1       Real           Output       in-cld mixing ratio of condensed water
+C      wd1           Real           Output       downdraft velocity scale for sfc fluxes
+C      cape1         Real           Output       CAPE
+!    
+!      wdtrainA1     Real           Output   precipitation detrained from adiabatic draught;
+!                                                       used in tracer transport (cvltr)
+!      wdtrainM1     Real           Output   precipitation detrained from mixed draughts;
+!                                                       used in tracer transport (cvltr)
+!      da1           Real           Output   used in tracer transport (cvltr)
+!      phi1          Real           Output   used in tracer transport (cvltr)
+!      mp1           Real           Output   used in tracer transport (cvltr)
+!    
+!      phi21         Real           Output   used in tracer transport (cvltr)
+!    
+!      d1a1          Real           Output   used in tracer transport (cvltr)
+!      dam1          Real           Output   used in tracer transport (cvltr)
+!    
+!      evap1         Real           Output
+!      ep1           Real           Output
+!      sij1        Real           Output
+!      elij1         Real           Output
+C
+C S. Bony, Mar 2002:
+C 	* Several modules corresponding to different physical processes
+C 	* Several versions of convect may be used:
+C  		- iflag_con=3: version lmd  (previously named convect3) 
+C  		- iflag_con=4: version 4.3b (vect. version, previously convect1/2) 
+C   + tard: 	- iflag_con=5: version lmd with ice (previously named convectg) 
+C S. Bony, Oct 2002:
+C	* Vectorization of convect3 (ie version lmd)
+C
+C..............................END PROLOGUE.............................
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c
+c Input
+      integer len
+      integer nd
+      integer ndp1
+      integer noff
+      integer iflag_con
+      integer ntra
+      real delt
+      real t1(len,nd)
+      real q1(len,nd)
+      real qs1(len,nd)
+      real u1(len,nd)
+      real v1(len,nd)
+      real tra1(len,nd,ntra)
+      real p1(len,nd)
+      real ph1(len,ndp1)
+c
+c Output
+      integer iflag1(len)
+      real ft1(len,nd)
+      real fq1(len,nd)
+      real fu1(len,nd)
+      real fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real precip1(len)
+      real cbmf1(len)
+      real sig1(klon,klev)
+      real w01(klon,klev)
+      real VPrecip1(len,nd+1) 
+      real evap1(len,nd)                    !RomP
+      real ep1(len,nd)                      !RomP
+      real Ma1(len,nd)
+      real upwd1(len,nd)
+      real dnwd1(len,nd)
+      real dnwd01(len,nd)
+
+      real qcondc1(len,nd)     ! cld
+      real wd1(len)            ! gust
+      real cape1(len)     
+
+! RomP >>> 
+      real wdtrainA1(len,nd), wdtrainM1(len,nd)
+      real sij1(len,nd,nd),elij1(len,nd,nd)
+      real da1(len,nd),phi1(len,nd,nd),mp1(len,nd)
+
+      real phi21(len,nd,nd)
+      real d1a1(len,nd), dam1(len,nd)
+      real epmlmMm1(len,nd,nd),eplaMm1(len,nd)
+! RomP <<<
+!
+!-------------------------------------------------------------------
+!        Original Prologue by Kerry Emanuel.
+!-------------------------------------------------------------------
+! --- ARGUMENTS
+!-------------------------------------------------------------------
+! --- On input:
+!
+!  t:   Array of absolute temperature (K) of dimension ND, with first
+!       index corresponding to lowest model level. Note that this array
+!       will be altered by the subroutine if dry convective adjustment
+!       occurs and if IPBL is not equal to 0.
+!
+!  q:   Array of specific humidity (gm/gm) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  qs:  Array of saturation specific humidity of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+!       index corresponding with the lowest model level. Defined at
+!       same levels as T. Note that this array will be altered if
+!       dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  v:   Same as u but for meridional velocity.
+!
+!  tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+!       where NTRA is the number of different tracers. If no
+!       convective tracer transport is needed, define a dummy
+!       input array of dimension (ND,1). Tracers are defined at
+!       same vertical levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  p:   Array of pressure (mb) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T.
+!
+!  ph:  Array of pressure (mb) of dimension ND+1, with first index
+!       corresponding to lowest level. These pressures are defined at
+!       levels intermediate between those of P, T, Q and QS. The first
+!       value of PH should be greater than (i.e. at a lower level than)
+!       the first value of the array P.
+!
+!  nl:  The maximum number of levels to which convection can penetrate, plus 1.
+!       NL MUST be less than or equal to ND-1.
+!
+!  delt: The model time step (sec) between calls to CONVECT
+!
+!----------------------------------------------------------------------------
+! ---   On Output:
+!
+!  iflag: An output integer whose value denotes the following:
+!       VALUE   INTERPRETATION
+!       -----   --------------
+!         0     Moist convection occurs.
+!         1     Moist convection occurs, but a CFL condition
+!               on the subsidence warming is violated. This
+!               does not cause the scheme to terminate.
+!         2     Moist convection, but no precip because ep(inb) lt 0.0001
+!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
+!         4     No moist convection; atmosphere is not
+!               unstable
+!         6     No moist convection because ihmin le minorig.
+!         7     No moist convection because unreasonable
+!               parcel level temperature or specific humidity.
+!         8     No moist convection: lifted condensation
+!               level is above the 200 mb level.
+!         9     No moist convection: cloud base is higher
+!               then the level NL-1.
+!
+!  ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
+!        grid levels as T, Q, QS and P.
+!
+!  fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+!        defined at same grid levels as T, Q, QS and P.
+!
+!  fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+!        defined at same grid levels as T.
+!
+!  fv:   Same as FU, but for forcing of meridional velocity.
+!
+!  ftra: Array of forcing of tracer content, in tracer mixing ratio per
+!        second, defined at same levels as T. Dimensioned (ND,NTRA).
+!
+!  precip: Scalar convective precipitation rate (mm/day).
+!
+!  VPrecip: Vertical profile of convective precipitation (kg/m2/s).
+!
+!  wd:   A convective downdraft velocity scale. For use in surface
+!        flux parameterizations. See convect.ps file for details.
+!
+!  tprime: A convective downdraft temperature perturbation scale (K).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  qprime: A convective downdraft specific humidity
+!          perturbation scale (gm/gm).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+!        BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+!        ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+!        by the calling program between calls to CONVECT.
+!
+!  det:   Array of detrainment mass flux of dimension ND.
+!
+!-------------------------------------------------------------------
+c
+c  Local arrays
+c
+
+      integer i,k,n,il,j
+      integer icbmax
+      integer nk1(klon)
+      integer icb1(klon)
+      integer inb1(klon)
+      integer icbs1(klon)
+
+      real plcl1(klon)
+      real tnk1(klon)
+      real qnk1(klon)
+      real gznk1(klon)
+      real pnk1(klon)
+      real qsnk1(klon)
+      real pbase1(klon)
+      real buoybase1(klon)
+
+      real lv1(klon,klev)
+      real cpn1(klon,klev)
+      real tv1(klon,klev)
+      real gz1(klon,klev)
+      real hm1(klon,klev)
+      real h1(klon,klev)
+      real tp1(klon,klev)
+      real tvp1(klon,klev)
+      real clw1(klon,klev)
+      real th1(klon,klev)
+c
+      integer ncum
+c
+c (local) compressed fields:
+c
+cym      integer nloc
+cym      parameter (nloc=klon) ! pour l'instant
+#define nloc klon
+      integer idcum(nloc)
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      integer nent(nloc,klev)
+      integer icbs(nloc)
+      integer inb(nloc), inbis(nloc)
+
+      real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real t(nloc,klev),q(nloc,klev),qs(nloc,klev)
+      real u(nloc,klev),v(nloc,klev)
+      real gz(nloc,klev),h(nloc,klev),lv(nloc,klev),cpn(nloc,klev)
+      real p(nloc,klev),ph(nloc,klev+1),tv(nloc,klev),tp(nloc,klev)
+      real clw(nloc,klev)
+      real dph(nloc,klev)
+      real pbase(nloc), buoybase(nloc), th(nloc,klev)
+      real tvp(nloc,klev)
+      real sig(nloc,klev), w0(nloc,klev)
+      real hp(nloc,klev), ep(nloc,klev), sigp(nloc,klev)
+      real frac(nloc), buoy(nloc,klev)
+      real cape(nloc)
+      real m(nloc,klev), ment(nloc,klev,klev), qent(nloc,klev,klev)
+      real uent(nloc,klev,klev), vent(nloc,klev,klev)
+      real ments(nloc,klev,klev), qents(nloc,klev,klev)
+      real sij(nloc,klev,klev), elij(nloc,klev,klev)
+      real qp(nloc,klev), up(nloc,klev), vp(nloc,klev)
+      real wt(nloc,klev), water(nloc,klev), evap(nloc,klev)
+      real b(nloc,klev), ft(nloc,klev), fq(nloc,klev)
+      real fu(nloc,klev), fv(nloc,klev)
+      real upwd(nloc,klev), dnwd(nloc,klev), dnwd0(nloc,klev)
+      real Ma(nloc,klev), mike(nloc,klev), tls(nloc,klev)
+      real tps(nloc,klev), qprime(nloc), tprime(nloc)
+      real precip(nloc)
+      real VPrecip(nloc,klev+1)
+      real tra(nloc,klev,ntra), trap(nloc,klev,ntra)
+      real ftra(nloc,klev,ntra), traent(nloc,klev,klev,ntra)
+      real qcondc(nloc,klev)  ! cld
+      real wd(nloc)           ! gust
+!
+! RomP >>>
+      real da(nloc,klev),phi(nloc,klev,klev),mp(nloc,klev)
+      real epmlmMm(nloc,klev,klev),eplaMm(nloc,klev)  
+      real phi2(nloc,klev,klev)
+      real d1a(nloc,klev), dam(nloc,klev)
+      real wdtrainA(nloc,klev),wdtrainM(nloc,klev)
+      real sigd(nloc)
+! RomP <<<
+
+      nent(:,:)=0
+!-------------------------------------------------------------------
+! --- SET CONSTANTS AND PARAMETERS
+!-------------------------------------------------------------------
+      print *, '-> cv_driver'      !jyg
+c -- set simulation flags:
+c   (common cvflag)
+
+       CALL cv_flag
+
+c -- set thermodynamical constants:
+c 	(common cvthermo)
+
+       CALL cv_thermo(iflag_con)
+
+c -- set convect parameters 
+c
+c 	includes microphysical parameters and parameters that 
+c  	control the rate of approach to quasi-equilibrium) 
+c 	(common cvparam)
+
+
+      if (iflag_con.eq.30) then
+       CALL cv30_param(nd,delt)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_param(nd)
+      endif
+
+!---------------------------------------------------------------------
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+!---------------------------------------------------------------------
+
+         ft1(:,:)=0.0
+         fq1(:,:)=0.0
+         fu1(:,:)=0.0
+         fv1(:,:)=0.0
+         tvp1(:,:)=0.0
+         tp1(:,:)=0.0
+         clw1(:,:)=0.0
+cym
+         clw(:,:)=0.0	 
+         gz1(:,:) = 0.
+         VPrecip1(:,:) = 0.
+         Ma1(:,:)=0.0
+         upwd1(:,:)=0.0
+         dnwd1(:,:)=0.0
+         dnwd01(:,:)=0.0
+         qcondc1(:,:)=0.0
+
+         ftra1(:,:,:)=0.0
+
+        elij1(:,:,:) = 0.0
+        sij1(:,:,:) = 0.0
+
+        precip1(:)=0.0
+        iflag1(:)=0
+        wd1(:)=0.0
+        cape1(:)=0.0
+
+      if (iflag_con.eq.30) then
+        do il=1,len
+         sig1(il,nd)=sig1(il,nd)+1.
+         sig1(il,nd)=amin1(sig1(il,nd),12.1)
+        enddo
+      endif
+
+! RomP >>> 
+       wdtrainA1(:,:)  =0.
+        wdtrainM1(:,:) =0.
+       da1(:,:)        =0.
+       phi1(:,:,:)     =0.
+       epmlmMm1(:,:,:) =0.
+       eplaMm1(:,:)    =0.
+       mp1(:,:)        =0.
+       evap1(:,:)      =0.
+       ep1(:,:)        =0.
+       sij1(:,:,:)     =0.
+       elij1(:,:,:)    =0.
+       phi21(:,:,:)    =0.
+       d1a1(:,:)       =0.
+       dam1(:,:)       =0.
+! RomP <<<
+
+!--------------------------------------------------------------------
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+
+!       print*,'Emanuel version 30 '
+       CALL cv30_prelim(len,nd,ndp1,t1,q1,p1,ph1            ! nd->na
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1,th1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1)
+      endif
+
+!--------------------------------------------------------------------
+! --- CONVECTIVE FEED
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_feed(len,nd,t1,q1,qs1,p1,ph1,hm1,gz1           ! nd->na
+     o         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif 
+
+      if (iflag_con.eq.4) then
+       CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1
+     o         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif 
+
+!--------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part 
+! (up through ICB for convect4, up through ICB+1 for convect3)
+!     Calculates the lifted parcel virtual temperature at nk, the
+!     actual temperature, and the adiabatic liquid water content. 
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_undilute1(len,nd,t1,q1,qs1,gz1,plcl1,p1,nk1,icb1  ! nd->na
+     o                        ,tp1,tvp1,clw1,icbs1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax
+     :                        ,tp1,tvp1,clw1)
+      endif
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1      ! nd->na
+     o                 ,pbase1,buoybase1,iflag1,sig1,w01)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1)
+      endif
+
+!=====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+!=====================================================================
+
+      ncum=0
+      do 400 i=1,len
+        if(iflag1(i).eq.0)then
+           ncum=ncum+1
+           idcum(ncum)=i
+        endif
+ 400  continue
+
+         print*,'cv_driver : klon, ncum = ',len,ncum
+
+      IF (ncum.gt.0) THEN
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- COMPRESS THE FIELDS
+!		(-> vectorization over convective gridpoints)
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.30) then
+       CALL cv30_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1
+     :    ,t1,q1,qs1,u1,v1,gz1,th1
+     :    ,tra1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1 
+     :    ,sig1,w01
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,pbase,buoybase
+     o    ,t,q,qs,u,v,gz,th
+     o    ,tra
+     o    ,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,sig,w0  )
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_compress( len,nloc,ncum,nd
+     :    ,iflag1,nk1,icb1
+     :    ,cbmf1,plcl1,tnk1,qnk1,gznk1
+     :    ,t1,q1,qs1,u1,v1,gz1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     o    ,iflag,nk,icb
+     o    ,cbmf,plcl,tnk,qnk,gznk
+     o    ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o    ,dph )
+      endif
+
+!-------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / second part :
+! ---   FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+! ---   &
+! ---   COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+! ---   FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+! ---   &
+! ---   FIND THE LEVEL OF NEUTRAL BUOYANCY
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_undilute2(nloc,ncum,nd,icb,icbs,nk        !na->nd
+     :                        ,tnk,qnk,gznk,t,q,qs,gz
+     :                        ,p,h,tv,lv,pbase,buoybase,plcl
+     o                        ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute2(nloc,ncum,nd,icb,nk
+     :                        ,tnk,qnk,gznk,t,q,qs,gz
+     :                        ,p,dph,h,tv,lv
+     o             ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac)
+      endif
+
+!-------------------------------------------------------------------
+! --- CLOSURE
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_closure(nloc,ncum,nd,icb,inb              ! na->nd
+     :                       ,pbase,p,ph,tv,buoy
+     o                       ,sig,w0,cape,m)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_closure(nloc,ncum,nd,nk,icb
+     :                ,tv,tvp,p,ph,dph,plcl,cpn
+     o                ,iflag,cbmf)
+      endif
+
+!-------------------------------------------------------------------
+! --- MIXING
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb    ! na->nd
+     :                     ,ph,t,q,qs,u,v,tra,h,lv,qnk
+     :                     ,hp,tv,tvp,ep,clw,m,sig
+     o ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis
+     :                     ,ph,t,q,qs,u,v,h,lv,qnk
+     :                     ,hp,tv,tvp,ep,clw,cbmf
+     o                     ,m,ment,qent,uent,vent,nent,sij,elij)
+      endif
+
+!-------------------------------------------------------------------
+! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+!RomP >>>
+       CALL cv30_unsat(nloc,ncum,nd,nd,ntra,icb,inb         ! na->nd
+     :               ,t,q,qs,gz,u,v,tra,p,ph
+     :               ,th,tv,lv,cpn,ep,sigp,clw
+     :               ,m,ment,elij,delt,plcl
+     :          ,mp,qp,up,vp,trap,wt,water,evap,b
+     o          ,wdtrainA,wdtrainM)
+!RomP <<<
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph
+     :                   ,h,lv,ep,sigp,clw,m,ment,elij
+     o                   ,iflag,mp,qp,up,vp,wt,water,evap)
+      endif
+
+!-------------------------------------------------------------------
+! --- YIELD
+!     (tendencies, precipitation, variables of interface with other
+!      processes, etc)
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_yield(nloc,ncum,nd,nd,ntra            ! na->nd
+     :                     ,icb,inb,delt
+     :                     ,t,q,u,v,tra,gz,p,ph,h,hp,lv,cpn,th
+     :                     ,ep,clw,m,tp,mp,qp,up,vp,trap
+     :                     ,wt,water,evap,b
+     :                     ,ment,qent,uent,vent,nent,elij,traent,sig
+     :                     ,tv,tvp
+     o                     ,iflag,precip,VPrecip,ft,fq,fu,fv,ftra
+     o                     ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt
+     :              ,t,q,u,v,gz,p,ph,h,hp,lv,cpn
+     :              ,ep,clw,frac,m,mp,qp,up,vp
+     :              ,wt,water,evap
+     :              ,ment,qent,uent,vent,nent,elij
+     :              ,tv,tvp
+     o              ,iflag,wd,qprime,tprime
+     o              ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      endif
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- passive tracers
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.30) then
+!RomP >>>
+       CALL cv30_tracer(nloc,len,ncum,nd,nd,
+     :                  ment,sij,da,phi,phi2,d1a,dam,
+     :                  ep,VPrecip,elij,clw,epmlmMm,eplaMm,
+     :                  icb,inb)
+!RomP <<<
+      endif
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- UNCOMPRESS THE FIELDS
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+c set iflag1 =42 for non convective points 
+      do  i=1,len
+        iflag1(i)=42
+      end do
+c
+      if (iflag_con.eq.30) then
+       CALL cv30_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :          ,iflag
+     :          ,precip,VPrecip,evap,ep,sig,w0        !RomP 
+     :          ,ft,fq,fu,fv,ftra
+     :          ,inb
+     :          ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape
+     :          ,da,phi,mp,phi2,d1a,dam,sij           !RomP
+     :          ,elij,clw,epmlmMm,eplaMm              !RomP  
+     :          ,wdtrainA,wdtrainM                    !RomP
+     o          ,iflag1
+     o          ,precip1,VPrecip1,evap1,ep1,sig1,w01     !RomP
+     o          ,ft1,fq1,fu1,fv1,ftra1
+     o          ,inb1
+     o          ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1 
+     o          ,da1,phi1,mp1,phi21,d1a1,dam1,sij1       !RomP
+     o          ,elij1,clw1,epmlmMm1,eplaMm1             !RomP 
+     o          ,wdtrainA1,wdtrainM1)                    !RomP 
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_uncompress(nloc,len,ncum,nd,idcum
+     :          ,iflag
+     :          ,precip,cbmf
+     :          ,ft,fq,fu,fv
+     :          ,Ma,qcondc            
+     o          ,iflag1
+     o          ,precip1,cbmf1
+     o          ,ft1,fq1,fu1,fv1
+     o          ,Ma1,qcondc1 )           
+      endif
+
+      ENDIF ! ncum>0
+
+9999  continue
+
+      print *, 'fin cv_driver ->'      !jyg
+      return
+      end
+
+!==================================================================
+      SUBROUTINE cv_flag
+      implicit none
+
+#include "cvflag.h"
+
+c -- si .TRUE., on rend la gravite plus explicite et eventuellement
+c differente de 10.0 dans convect3: 
+      cvflag_grav = .TRUE.
+
+      return
+      end
+
+!==================================================================
+      SUBROUTINE cv_thermo(iflag_con)
+	  implicit none
+
+c-------------------------------------------------------------
+c Set thermodynamical constants for convectL
+c-------------------------------------------------------------
+
+#include "YOMCST.h" 
+#include "cvthermo.h" 
+
+      integer iflag_con
+
+
+c original set from convect:
+      if (iflag_con.eq.4) then
+       cpd=1005.7
+       cpv=1870.0
+       cl=4190.0
+       rrv=461.5
+       rrd=287.04
+       lv0=2.501E6
+       g=9.8
+       t0=273.15
+       grav=g
+      else
+
+c constants consistent with LMDZ:
+       cpd = RCPD
+       cpv = RCPV
+       cl  = RCW
+       rrv = RV
+       rrd = RD
+       lv0 = RLVTT
+       g   = RG     ! not used in convect3
+c ori      t0  = RTT
+       t0  = 273.15 ! convect3 (RTT=273.16)
+c maf       grav= 10.    ! implicitely or explicitely used in convect3
+       grav= g    ! implicitely or explicitely used in convect3
+      endif
+
+      rowl=1000.0 !(a quelle variable de YOMCST cela correspond-il?)
+
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      cpvmcl=cl-cpv ! for convect3
+      eps=rrd/rrv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+c      ginv=1.0/g
+      ginv=1.0/grav
+      hrd=0.5*rrd
+
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv_driver.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv_driver.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv_driver.F90	(revision 17)
@@ -0,0 +1,771 @@
+!
+! $Header$
+!
+      SUBROUTINE cv_driver(len,nd,ndp1,ntra,iflag_con,                               &
+       &                   t1,q1,qs1,u1,v1,tra1,                                     &
+       &                   p1,ph1,iflag1,ft1,fq1,fu1,fv1,ftra1,                      &
+       &                   precip1,VPrecip1,                                         &
+       &                   cbmf1,sig1,w01,                                           &
+       &                   icb1,inb1,                                                &
+       &                   delt,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1,            &
+       &                   da1,phi1,mp1,phi21,d1a1,dam1,sij1,clw1,elij1,             & ! RomP
+       &                   evap1,ep1,epmlmMm1,eplaMm1,                               & ! RomP
+       &                   wdtrainA1,wdtrainM1)                                        ! RomP
+!C
+      USE dimphy
+      implicit none
+!C
+!C.............................START PROLOGUE............................
+!C
+!
+! All argument names (except len,nd,ntra,nloc,delt and the flags) have a "1" appended.
+! The "1" is removed for the corresponding compressed (local) variables.
+!
+!C PARAMETERS:
+!C      Name            Type         Usage            Description
+!C   ----------      ----------     -------  ----------------------------
+!C
+!C      len           Integer        Input        first (i) dimension
+!C      nd            Integer        Input        vertical (k) dimension
+!C      ndp1          Integer        Input        nd + 1
+!C      ntra          Integer        Input        number of tracors
+!C      iflag_con     Integer        Input        version of convect (3/4)
+!C      t1            Real           Input        temperature
+!C      q1            Real           Input        specific hum
+!C      qs1           Real           Input        sat specific hum
+!C      u1            Real           Input        u-wind
+!C      v1            Real           Input        v-wind
+!C      tra1          Real           Input        tracors
+!C      p1            Real           Input        full level pressure
+!C      ph1           Real           Input        half level pressure
+!C      iflag1        Integer        Output       flag for Emanuel conditions
+!C      ft1           Real           Output       temp tend
+!C      fq1           Real           Output       spec hum tend
+!C      fu1           Real           Output       u-wind tend
+!C      fv1           Real           Output       v-wind tend
+!C      ftra1         Real           Output       tracor tend
+!C      precip1       Real           Output       precipitation
+!C      VPrecip1      Real           Output       vertical profile of precipitations
+!C      cbmf1         Real           Output       cloud base mass flux
+!C      sig1          Real           In/Out       section adiabatic updraft
+!C      w01           Real           In/Out       vertical velocity within adiab updraft
+!C      delt          Real           Input        time step
+!C      Ma1           Real           Output       mass flux adiabatic updraft
+!C      upwd1         Real           Output       total upward mass flux (adiab+mixed)
+!C      dnwd1         Real           Output       saturated downward mass flux (mixed)
+!C      dnwd01        Real           Output       unsaturated downward mass flux 
+!C      qcondc1       Real           Output       in-cld mixing ratio of condensed water
+!C      wd1           Real           Output       downdraft velocity scale for sfc fluxes
+!C      cape1         Real           Output       CAPE
+!    
+!      wdtrainA1     Real           Output   precipitation detrained from adiabatic draught;
+!                                                       used in tracer transport (cvltr)
+!      wdtrainM1     Real           Output   precipitation detrained from mixed draughts;
+!                                                       used in tracer transport (cvltr)
+!      da1           Real           Output   used in tracer transport (cvltr)
+!      phi1          Real           Output   used in tracer transport (cvltr)
+!      mp1           Real           Output   used in tracer transport (cvltr)
+!    
+!      phi21         Real           Output   used in tracer transport (cvltr)
+!    
+!      d1a1          Real           Output   used in tracer transport (cvltr)
+!      dam1          Real           Output   used in tracer transport (cvltr)
+!    
+!      evap1         Real           Output
+!      ep1           Real           Output
+!      sij1        Real           Output
+!      elij1         Real           Output
+!C
+!C S. Bony, Mar 2002:
+!C 	* Several modules corresponding to different physical processes
+!C 	* Several versions of convect may be used:
+!C  		- iflag_con=3: version lmd  (previously named convect3) 
+!C  		- iflag_con=4: version 4.3b (vect. version, previously convect1/2) 
+!C   + tard: 	- iflag_con=5: version lmd with ice (previously named convectg) 
+!C S. Bony, Oct 2002:
+!C	* Vectorization of convect3 (ie version lmd)
+!C
+!C..............................END PROLOGUE.............................
+!c
+!c
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!c
+!c Input
+      integer len
+      integer nd
+      integer ndp1
+      integer noff
+      integer iflag_con
+      integer ntra
+      real delt
+      real t1(len,nd)
+      real q1(len,nd)
+      real qs1(len,nd)
+      real u1(len,nd)
+      real v1(len,nd)
+      real tra1(len,nd,ntra)
+      real p1(len,nd)
+      real ph1(len,ndp1)
+!c
+!c Output
+      integer iflag1(len)
+      real ft1(len,nd)
+      real fq1(len,nd)
+      real fu1(len,nd)
+      real fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real precip1(len)
+      real cbmf1(len)
+      real sig1(klon,klev)
+      real w01(klon,klev)
+      real VPrecip1(len,nd+1) 
+      real evap1(len,nd)                    !RomP
+      real ep1(len,nd)                      !RomP
+      real Ma1(len,nd)
+      real upwd1(len,nd)
+      real dnwd1(len,nd)
+      real dnwd01(len,nd)
+
+      real qcondc1(len,nd)     ! cld
+      real wd1(len)            ! gust
+      real cape1(len)     
+
+! RomP >>> 
+      real wdtrainA1(len,nd), wdtrainM1(len,nd)
+      real sij1(len,nd,nd),elij1(len,nd,nd)
+      real da1(len,nd),phi1(len,nd,nd),mp1(len,nd)
+
+      real phi21(len,nd,nd)
+      real d1a1(len,nd), dam1(len,nd)
+      real epmlmMm1(len,nd,nd),eplaMm1(len,nd)
+! RomP <<<
+!
+!-------------------------------------------------------------------
+!        Original Prologue by Kerry Emanuel.
+!-------------------------------------------------------------------
+! --- ARGUMENTS
+!-------------------------------------------------------------------
+! --- On input:
+!
+!  t:   Array of absolute temperature (K) of dimension ND, with first
+!       index corresponding to lowest model level. Note that this array
+!       will be altered by the subroutine if dry convective adjustment
+!       occurs and if IPBL is not equal to 0.
+!
+!  q:   Array of specific humidity (gm/gm) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  qs:  Array of saturation specific humidity of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+!       index corresponding with the lowest model level. Defined at
+!       same levels as T. Note that this array will be altered if
+!       dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  v:   Same as u but for meridional velocity.
+!
+!  tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+!       where NTRA is the number of different tracers. If no
+!       convective tracer transport is needed, define a dummy
+!       input array of dimension (ND,1). Tracers are defined at
+!       same vertical levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  p:   Array of pressure (mb) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T.
+!
+!  ph:  Array of pressure (mb) of dimension ND+1, with first index
+!       corresponding to lowest level. These pressures are defined at
+!       levels intermediate between those of P, T, Q and QS. The first
+!       value of PH should be greater than (i.e. at a lower level than)
+!       the first value of the array P.
+!
+!  nl:  The maximum number of levels to which convection can penetrate, plus 1.
+!       NL MUST be less than or equal to ND-1.
+!
+!  delt: The model time step (sec) between calls to CONVECT
+!
+!----------------------------------------------------------------------------
+! ---   On Output:
+!
+!  iflag: An output integer whose value denotes the following:
+!       VALUE   INTERPRETATION
+!       -----   --------------
+!         0     Moist convection occurs.
+!         1     Moist convection occurs, but a CFL condition
+!               on the subsidence warming is violated. This
+!               does not cause the scheme to terminate.
+!         2     Moist convection, but no precip because ep(inb) lt 0.0001
+!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
+!         4     No moist convection; atmosphere is not
+!               unstable
+!         6     No moist convection because ihmin le minorig.
+!         7     No moist convection because unreasonable
+!               parcel level temperature or specific humidity.
+!         8     No moist convection: lifted condensation
+!               level is above the 200 mb level.
+!         9     No moist convection: cloud base is higher
+!               then the level NL-1.
+!
+!  ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
+!        grid levels as T, Q, QS and P.
+!
+!  fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+!        defined at same grid levels as T, Q, QS and P.
+!
+!  fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+!        defined at same grid levels as T.
+!
+!  fv:   Same as FU, but for forcing of meridional velocity.
+!
+!  ftra: Array of forcing of tracer content, in tracer mixing ratio per
+!        second, defined at same levels as T. Dimensioned (ND,NTRA).
+!
+!  precip: Scalar convective precipitation rate (mm/day).
+!
+!  VPrecip: Vertical profile of convective precipitation (kg/m2/s).
+!
+!  wd:   A convective downdraft velocity scale. For use in surface
+!        flux parameterizations. See convect.ps file for details.
+!
+!  tprime: A convective downdraft temperature perturbation scale (K).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  qprime: A convective downdraft specific humidity
+!          perturbation scale (gm/gm).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+!        BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+!        ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+!        by the calling program between calls to CONVECT.
+!
+!  det:   Array of detrainment mass flux of dimension ND.
+!
+!-------------------------------------------------------------------
+!c
+!c  Local arrays
+!c
+
+      integer i,k,n,il,j
+      integer icbmax
+      integer nk1(klon)
+      integer icb1(klon)
+      integer inb1(klon)
+      integer icbs1(klon)
+
+      real plcl1(klon)
+      real tnk1(klon)
+      real qnk1(klon)
+      real gznk1(klon)
+      real pnk1(klon)
+      real qsnk1(klon)
+      real pbase1(klon)
+      real buoybase1(klon)
+
+      real lv1(klon,klev)
+      real cpn1(klon,klev)
+      real tv1(klon,klev)
+      real gz1(klon,klev)
+      real hm1(klon,klev)
+      real h1(klon,klev)
+      real tp1(klon,klev)
+      real tvp1(klon,klev)
+      real clw1(klon,klev)
+      real th1(klon,klev)
+!c
+      integer ncum
+!c
+!c (local) compressed fields:
+!c
+!cym      integer nloc
+!cym      parameter (nloc=klon) ! pour l'instant
+#define nloc klon
+      integer idcum(nloc)
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      integer nent(nloc,klev)
+      integer icbs(nloc)
+      integer inb(nloc), inbis(nloc)
+
+      real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real t(nloc,klev),q(nloc,klev),qs(nloc,klev)
+      real u(nloc,klev),v(nloc,klev)
+      real gz(nloc,klev),h(nloc,klev),lv(nloc,klev),cpn(nloc,klev)
+      real p(nloc,klev),ph(nloc,klev+1),tv(nloc,klev),tp(nloc,klev)
+      real clw(nloc,klev)
+      real dph(nloc,klev)
+      real pbase(nloc), buoybase(nloc), th(nloc,klev)
+      real tvp(nloc,klev)
+      real sig(nloc,klev), w0(nloc,klev)
+      real hp(nloc,klev), ep(nloc,klev), sigp(nloc,klev)
+      real frac(nloc), buoy(nloc,klev)
+      real cape(nloc)
+      real m(nloc,klev), ment(nloc,klev,klev), qent(nloc,klev,klev)
+      real uent(nloc,klev,klev), vent(nloc,klev,klev)
+      real ments(nloc,klev,klev), qents(nloc,klev,klev)
+      real sij(nloc,klev,klev), elij(nloc,klev,klev)
+      real qp(nloc,klev), up(nloc,klev), vp(nloc,klev)
+      real wt(nloc,klev), water(nloc,klev), evap(nloc,klev)
+      real b(nloc,klev), ft(nloc,klev), fq(nloc,klev)
+      real fu(nloc,klev), fv(nloc,klev)
+      real upwd(nloc,klev), dnwd(nloc,klev), dnwd0(nloc,klev)
+      real Ma(nloc,klev), mike(nloc,klev), tls(nloc,klev)
+      real tps(nloc,klev), qprime(nloc), tprime(nloc)
+      real precip(nloc)
+      real VPrecip(nloc,klev+1)
+      real tra(nloc,klev,ntra), trap(nloc,klev,ntra)
+      real ftra(nloc,klev,ntra), traent(nloc,klev,klev,ntra)
+      real qcondc(nloc,klev)  ! cld
+      real wd(nloc)           ! gust
+!
+! RomP >>>
+      real da(nloc,klev),phi(nloc,klev,klev),mp(nloc,klev)
+      real epmlmMm(nloc,klev,klev),eplaMm(nloc,klev)  
+      real phi2(nloc,klev,klev)
+      real d1a(nloc,klev), dam(nloc,klev)
+      real wdtrainA(nloc,klev),wdtrainM(nloc,klev)
+      real sigd(nloc)
+! RomP <<<
+
+      nent(:,:)=0
+!-------------------------------------------------------------------
+! --- SET CONSTANTS AND PARAMETERS
+!-------------------------------------------------------------------
+      print *, '-> cv_driver'      !jyg
+!c -- set simulation flags:
+!c   (common cvflag)
+
+       CALL cv_flag
+
+!c -- set thermodynamical constants:
+!c 	(common cvthermo)
+
+       CALL cv_thermo(iflag_con)
+
+!c -- set convect parameters 
+!c
+!c 	includes microphysical parameters and parameters that 
+!c  	control the rate of approach to quasi-equilibrium) 
+!c 	(common cvparam)
+
+
+      if (iflag_con.eq.30) then
+       CALL cv30_param(nd,delt)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_param(nd)
+      endif
+
+!---------------------------------------------------------------------
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+!---------------------------------------------------------------------
+
+         ft1(:,:)=0.0
+         fq1(:,:)=0.0
+         fu1(:,:)=0.0
+         fv1(:,:)=0.0
+         tvp1(:,:)=0.0
+         tp1(:,:)=0.0
+         clw1(:,:)=0.0
+!cym
+         clw(:,:)=0.0	 
+         gz1(:,:) = 0.
+         VPrecip1(:,:) = 0.
+         Ma1(:,:)=0.0
+         upwd1(:,:)=0.0
+         dnwd1(:,:)=0.0
+         dnwd01(:,:)=0.0
+         qcondc1(:,:)=0.0
+
+         ftra1(:,:,:)=0.0
+
+        elij1(:,:,:) = 0.0
+        sij1(:,:,:) = 0.0
+
+        precip1(:)=0.0
+        iflag1(:)=0
+        wd1(:)=0.0
+        cape1(:)=0.0
+
+      if (iflag_con.eq.30) then
+        do il=1,len
+         sig1(il,nd)=sig1(il,nd)+1.
+         sig1(il,nd)=amin1(sig1(il,nd),12.1)
+        enddo
+      endif
+
+! RomP >>> 
+       wdtrainA1(:,:)  =0.
+        wdtrainM1(:,:) =0.
+       da1(:,:)        =0.
+       phi1(:,:,:)     =0.
+       epmlmMm1(:,:,:) =0.
+       eplaMm1(:,:)    =0.
+       mp1(:,:)        =0.
+       evap1(:,:)      =0.
+       ep1(:,:)        =0.
+       sij1(:,:,:)     =0.
+       elij1(:,:,:)    =0.
+       phi21(:,:,:)    =0.
+       d1a1(:,:)       =0.
+       dam1(:,:)       =0.
+! RomP <<<
+
+!--------------------------------------------------------------------
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+
+!       print*,'Emanuel version 30 '
+       CALL cv30_prelim(len,nd,ndp1,t1,q1,p1,ph1                                     & ! nd->na
+       &               ,lv1,cpn1,tv1,gz1,h1,hm1,th1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1                                       &
+       &               ,lv1,cpn1,tv1,gz1,h1,hm1)
+      endif
+
+!--------------------------------------------------------------------
+! --- CONVECTIVE FEED
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_feed(len,nd,t1,q1,qs1,p1,ph1,hm1,gz1                                & ! nd->na
+       &         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif 
+
+      if (iflag_con.eq.4) then
+       CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1                                      &
+       &         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif 
+
+!--------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part 
+! (up through ICB for convect4, up through ICB+1 for convect3)
+!     Calculates the lifted parcel virtual temperature at nk, the
+!     actual temperature, and the adiabatic liquid water content. 
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_undilute1(len,nd,t1,q1,qs1,gz1,plcl1,p1,nk1,icb1                    & ! nd->na
+       &                        ,tp1,tvp1,clw1,icbs1)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax                     &
+       &                        ,tp1,tvp1,clw1)
+      endif
+
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1                           & ! nd->na
+       &                 ,pbase1,buoybase1,iflag1,sig1,w01)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1)
+      endif
+
+!=====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+!=====================================================================
+
+      ncum=0
+      do 400 i=1,len
+        if(iflag1(i).eq.0)then
+           ncum=ncum+1
+           idcum(ncum)=i
+        endif
+ 400  continue
+
+         print*,'cv_driver : klon, ncum = ',len,ncum
+
+      IF (ncum.gt.0) THEN
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- COMPRESS THE FIELDS
+!		(-> vectorization over convective gridpoints)
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.30) then
+       CALL cv30_compress( len,nloc,ncum,nd,ntra                                     &
+       &    ,iflag1,nk1,icb1,icbs1                                                   &
+       &    ,plcl1,tnk1,qnk1,gznk1,pbase1,buoybase1                                  &
+       &    ,t1,q1,qs1,u1,v1,gz1,th1                                                 &
+       &    ,tra1                                                                    &
+       &    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1                                    &
+       &    ,sig1,w01                                                                &
+       &    ,iflag,nk,icb,icbs                                                       &
+       &    ,plcl,tnk,qnk,gznk,pbase,buoybase                                        &
+       &    ,t,q,qs,u,v,gz,th                                                        &
+       &    ,tra                                                                     &
+       &    ,h,lv,cpn,p,ph,tv,tp,tvp,clw                                             &
+       &    ,sig,w0  )
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_compress( len,nloc,ncum,nd                                            &
+       &    ,iflag1,nk1,icb1                                                         &
+       &    ,cbmf1,plcl1,tnk1,qnk1,gznk1                                             &
+       &    ,t1,q1,qs1,u1,v1,gz1                                                     &
+       &    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1                                    &
+       &    ,iflag,nk,icb                                                            &
+       &    ,cbmf,plcl,tnk,qnk,gznk                                                  &
+       &    ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw                               &
+       &    ,dph )
+      endif
+
+!-------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / second part :
+! ---   FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+! ---   &
+! ---   COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+! ---   FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+! ---   &
+! ---   FIND THE LEVEL OF NEUTRAL BUOYANCY
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_undilute2(nloc,ncum,nd,icb,icbs,nk                                  & !na->nd
+       &                        ,tnk,qnk,gznk,t,q,qs,gz                              &
+       &                        ,p,h,tv,lv,pbase,buoybase,plcl                       &
+       &                        ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute2(nloc,ncum,nd,icb,nk                                         &
+       &                        ,tnk,qnk,gznk,t,q,qs,gz                              &
+       &                        ,p,dph,h,tv,lv                                       &
+       &             ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac)
+      endif
+
+!-------------------------------------------------------------------
+! --- CLOSURE
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_closure(nloc,ncum,nd,icb,inb                                        & ! na->nd
+       &                       ,pbase,p,ph,tv,buoy                                   &
+       &                       ,sig,w0,cape,m)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_closure(nloc,ncum,nd,nk,icb                                           &
+       &                ,tv,tvp,p,ph,dph,plcl,cpn                                    &
+       &                ,iflag,cbmf)
+      endif
+
+!-------------------------------------------------------------------
+! --- MIXING
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb                              & ! na->nd
+       &                     ,ph,t,q,qs,u,v,tra,h,lv,qnk                             &
+       &                     ,hp,tv,tvp,ep,clw,m,sig                                 &
+       & ,ment,qent,uent,vent,sij,elij,ments,qents,traent)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis                                  &
+       &                     ,ph,t,q,qs,u,v,h,lv,qnk                                 &
+       &                     ,hp,tv,tvp,ep,clw,cbmf                                  &
+       &                     ,m,ment,qent,uent,vent,nent,sij,elij)
+      endif
+
+!-------------------------------------------------------------------
+! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+!RomP >>>
+       CALL cv30_unsat(nloc,ncum,nd,nd,ntra,icb,inb                                  & ! na->nd
+       &               ,t,q,qs,gz,u,v,tra,p,ph                                       &
+       &               ,th,tv,lv,cpn,ep,sigp,clw                                     &
+       &               ,m,ment,elij,delt,plcl                                        &
+       &          ,mp,qp,up,vp,trap,wt,water,evap,b                                  &
+       &          ,wdtrainA,wdtrainM)
+!RomP <<<
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph                             &
+       &                   ,h,lv,ep,sigp,clw,m,ment,elij                             &
+       &                   ,iflag,mp,qp,up,vp,wt,water,evap)
+      endif
+
+!-------------------------------------------------------------------
+! --- YIELD
+!     (tendencies, precipitation, variables of interface with other
+!      processes, etc)
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.30) then
+       CALL cv30_yield(nloc,ncum,nd,nd,ntra                                          & ! na->nd
+       &                     ,icb,inb,delt                                           &
+       &                     ,t,q,u,v,tra,gz,p,ph,h,hp,lv,cpn,th                     &
+       &                     ,ep,clw,m,tp,mp,qp,up,vp,trap                           &
+       &                     ,wt,water,evap,b                                        &
+       &                     ,ment,qent,uent,vent,nent,elij,traent,sig               &
+       &                     ,tv,tvp                                                 &
+       &                     ,iflag,precip,VPrecip,ft,fq,fu,fv,ftra                  &
+       &                     ,upwd,dnwd,dnwd0,ma,mike,tls,tps,qcondc,wd)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt                                    &
+       &              ,t,q,u,v,gz,p,ph,h,hp,lv,cpn                                   &
+       &              ,ep,clw,frac,m,mp,qp,up,vp                                     &
+       &              ,wt,water,evap                                                 &
+       &              ,ment,qent,uent,vent,nent,elij                                 &
+       &              ,tv,tvp                                                        &
+       &              ,iflag,wd,qprime,tprime                                        &
+       &              ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      endif
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- passive tracers
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.30) then
+!RomP >>>
+       CALL cv30_tracer(nloc,len,ncum,nd,nd,                                         &
+       &                  ment,sij,da,phi,phi2,d1a,dam,                              &
+       &                  ep,VPrecip,elij,clw,epmlmMm,eplaMm,                        &
+       &                  icb,inb)
+!RomP <<<
+      endif
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- UNCOMPRESS THE FIELDS
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+!c set iflag1 =42 for non convective points 
+      do  i=1,len
+        iflag1(i)=42
+      end do
+!c
+      if (iflag_con.eq.30) then
+       CALL cv30_uncompress(nloc,len,ncum,nd,ntra,idcum                              &
+       &          ,iflag                                                             &
+       &          ,precip,VPrecip,evap,ep,sig,w0                                     & !RomP
+       &          ,ft,fq,fu,fv,ftra                                                  &
+       &          ,inb                                                               &
+       &          ,Ma,upwd,dnwd,dnwd0,qcondc,wd,cape                                 &
+       &          ,da,phi,mp,phi2,d1a,dam,sij                                        & !RomP
+       &          ,elij,clw,epmlmMm,eplaMm                                           & !RomP
+       &          ,wdtrainA,wdtrainM                                                 & !RomP
+       &          ,iflag1                                                            &
+       &          ,precip1,VPrecip1,evap1,ep1,sig1,w01                               & !RomP
+       &          ,ft1,fq1,fu1,fv1,ftra1                                             &
+       &          ,inb1                                                              &
+       &          ,Ma1,upwd1,dnwd1,dnwd01,qcondc1,wd1,cape1                          &
+       &          ,da1,phi1,mp1,phi21,d1a1,dam1,sij1                                 & !RomP
+       &          ,elij1,clw1,epmlmMm1,eplaMm1                                       & !RomP
+       &          ,wdtrainA1,wdtrainM1)                                               !RomP 
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_uncompress(nloc,len,ncum,nd,idcum                                     &
+       &          ,iflag                                                             &
+       &          ,precip,cbmf                                                       &
+       &          ,ft,fq,fu,fv                                                       &
+       &          ,Ma,qcondc                                                         &
+       &          ,iflag1                                                            &
+       &          ,precip1,cbmf1                                                     &
+       &          ,ft1,fq1,fu1,fv1                                                   &
+       &          ,Ma1,qcondc1 )           
+      endif
+
+      ENDIF ! ncum>0
+
+9999  continue
+
+      print *, 'fin cv_driver ->'      !jyg
+      return
+      end SUBROUTINE cv_driver
+
+!==================================================================
+      SUBROUTINE cv_flag
+      implicit none
+
+#include "cvflag.h"
+
+!c -- si .TRUE., on rend la gravite plus explicite et eventuellement
+!c differente de 10.0 dans convect3: 
+      cvflag_grav = .TRUE.
+
+      return
+      end SUBROUTINE cv_flag
+
+!==================================================================
+      SUBROUTINE cv_thermo(iflag_con)
+	  implicit none
+
+!c-------------------------------------------------------------
+!c Set thermodynamical constants for convectL
+!c-------------------------------------------------------------
+
+#include "YOMCST.h" 
+#include "cvthermo.h" 
+
+      integer iflag_con
+
+
+!c original set from convect:
+      if (iflag_con.eq.4) then
+       cpd=1005.7
+       cpv=1870.0
+       cl=4190.0
+       rrv=461.5
+       rrd=287.04
+       lv0=2.501E6
+       g=9.8
+       t0=273.15
+       grav=g
+      else
+
+!c constants consistent with LMDZ:
+       cpd = RCPD
+       cpv = RCPV
+       cl  = RCW
+       rrv = RV
+       rrd = RD
+       lv0 = RLVTT
+       g   = RG     ! not used in convect3
+!c ori      t0  = RTT
+       t0  = 273.15 ! convect3 (RTT=273.16)
+!c maf       grav= 10.    ! implicitely or explicitely used in convect3
+       grav= g    ! implicitely or explicitely used in convect3
+      endif
+
+      rowl=1000.0 !(a quelle variable de YOMCST cela correspond-il?)
+
+      clmcpv=cl-cpv
+      clmcpd=cl-cpd
+      cpdmcp=cpd-cpv
+      cpvmcpd=cpv-cpd
+      cpvmcl=cl-cpv ! for convect3
+      eps=rrd/rrv
+      epsi=1.0/eps
+      epsim1=epsi-1.0
+!c      ginv=1.0/g
+      ginv=1.0/grav
+      hrd=0.5*rrd
+
+      return
+      end SUBROUTINE cv_thermo
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv_routines.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv_routines.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv_routines.F	(revision 17)
@@ -0,0 +1,1762 @@
+!
+! $Id: cv_routines.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE cv_param(nd)
+      implicit none
+
+c------------------------------------------------------------
+c Set parameters for convectL
+c (includes microphysical parameters and parameters that 
+c  control the rate of approach to quasi-equilibrium) 
+c------------------------------------------------------------
+
+C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+C   ***               BETWEEN 0 C AND TLCRIT)                        ***
+C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+C   ***                       FORMULATION                            ***
+C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+C   ***                        OF CLOUD                              ***
+C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF RAIN                             ***
+C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+C   ***                          OF SNOW                             ***
+C   ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+C   ***                         TRANSPORT                            ***
+C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
+
+#include "cvparam.h"
+      integer nd
+      CHARACTER (LEN=20) :: modname='cv_routines'
+      CHARACTER (LEN=80) :: abort_message
+
+c noff: integer limit for convection (nd-noff)
+c minorig: First level of convection
+
+      noff = 2
+      minorig = 2
+
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+      elcrit=0.0011
+      tlcrit=-55.0
+      entp=1.5
+      sigs=0.12
+      sigd=0.05
+      omtrain=50.0
+      omtsnow=5.5
+      coeffr=1.0
+      coeffs=0.8
+      dtmax=0.9
+c
+      cu=0.70
+c
+      betad=10.0
+c
+      damp=0.1
+      alpha=0.2
+c
+      delta=0.01  ! cld
+c
+      return
+      end
+
+      SUBROUTINE cv_prelim(len,nd,ndp1,t,q,p,ph
+     :                    ,lv,cpn,tv,gz,h,hm)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!=====================================================================
+
+c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+
+c local variables:
+      integer k, i
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+
+      do 110 k=1,nlp
+        do 100 i=1,len
+          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+ 100    continue
+ 110  continue
+c
+c gz = phi at the full levels (same as p).
+c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+      do 140 k=2,nlp
+        do 130 i=1,len
+          gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))
+     &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+c
+c h  = phi + cpT (dry static energy).
+c hm = phi + cp(T-Tbase)+Lq
+c
+      do 170 k=1,nlp
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv_feed(len,nd,t,q,qs,p,hm,gz
+     :                  ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl)
+      implicit none
+
+C================================================================
+C Purpose: CONVECTIVE FEED
+C================================================================
+
+#include "cvparam.h"
+
+c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), qs(len,nd), p(len,nd)
+      real hm(len,nd), gz(len,nd)
+
+c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+      real tnk(len), qnk(len), gznk(len), plcl(len)
+
+c local variables:
+      integer i, k
+      integer ihmin(len)
+      real work(len)
+      real pnk(len), qsnk(len), rh(len), chi(len)
+
+!-------------------------------------------------------------------
+! --- Find level of minimum moist static energy
+! --- If level of minimum moist static energy coincides with
+! --- or is lower than minimum allowable parcel origin level,
+! --- set iflag to 6.
+!-------------------------------------------------------------------
+
+      do 180 i=1,len
+       work(i)=1.0e12
+       ihmin(i)=nl
+ 180  continue
+      do 200 k=2,nlp
+        do 190 i=1,len
+         if((hm(i,k).lt.work(i)).and.
+     &      (hm(i,k).lt.hm(i,k-1)))then
+           work(i)=hm(i,k)
+           ihmin(i)=k
+         endif
+ 190    continue
+ 200  continue
+      do 210 i=1,len
+        ihmin(i)=min(ihmin(i),nlm)
+        if(ihmin(i).le.minorig)then
+          iflag(i)=6
+        endif
+ 210  continue
+c
+!-------------------------------------------------------------------
+! --- Find that model level below the level of minimum moist static
+! --- energy that has the maximum value of moist static energy
+!-------------------------------------------------------------------
+ 
+      do 220 i=1,len
+       work(i)=hm(i,minorig)
+       nk(i)=minorig
+ 220  continue
+      do 240 k=minorig+1,nl
+        do 230 i=1,len
+         if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+           work(i)=hm(i,k)
+           nk(i)=k
+         endif
+ 230     continue
+ 240  continue
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if(((t(i,nk(i)).lt.250.0).or.
+     &      (q(i,nk(i)).le.0.0).or.
+     &      (p(i,ihmin(i)).lt.400.0)).and.
+     &      (iflag(i).eq.0))iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+       do 260 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+c
+        rh(i)=qnk(i)/qsnk(i)
+        rh(i)=min(1.0,rh(i))
+        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))
+     &   .and.(iflag(i).eq.0))iflag(i)=8
+ 260   continue
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+c
+      do 290 k=minorig,nl
+        do 280 i=1,len
+          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))
+     &    icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+c
+      do 300 i=1,len
+        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+c
+c Compute icbmax.
+c
+      icbmax=2
+      do 310 i=1,len
+        icbmax=max(icbmax,icb(i))
+ 310  continue
+
+      return
+      end
+
+      SUBROUTINE cv_undilute1(len,nd,t,q,qs,gz,p,nk,icb,icbmax
+     :                       ,tp,tvp,clw)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer len, nd
+      integer nk(len), icb(len), icbmax
+      real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd)
+      real p(len,nd)
+
+c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+c local variables:
+      integer i, k
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        ticb(i)=t(i,icb(i))
+        gzicb(i)=gz(i,icb(i))
+ 320  continue
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+ 330  continue
+c
+c   ***   Calculate lifted parcel quantities below cloud base   ***
+c
+        do 350 k=minorig,icbmax-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))/cpp(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)*epsi)
+  340     continue
+  350   continue
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+        do 360 i=1,len
+         tg=ticb(i)
+         qg=qs(i,icb(i))
+         alv=lv0-clmcpv*(ticb(i)-t0)
+c
+c First iteration.
+c
+          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-t0
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          endif
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+c Second iteration.
+c
+          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-t0
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          end if
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+c
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)
+     &   -gz(i,icb(i))-alv*qg)/cpd
+         clw(i,icb(i))=qnk(i)-qg
+         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         rg=qg/(1.-qnk(i))
+         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+  360   continue
+c
+      do 380 k=minorig,icbmax
+       do 370 i=1,len
+         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+ 370   continue
+ 380  continue
+c
+      return
+      end
+
+      SUBROUTINE cv_trigger(len,nd,icb,cbmf,tv,tvp,iflag)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- Test for instability.
+! --- If there was no convection at last time step and parcel
+! --- is stable at icb, then set iflag to 4.
+!-------------------------------------------------------------------
+ 
+#include "cvparam.h"
+
+c inputs:
+       integer len, nd, icb(len)
+       real cbmf(len), tv(len,nd), tvp(len,nd)
+
+c outputs:
+       integer iflag(len) ! also an input
+
+c local variables:
+       integer i
+
+
+      do 390 i=1,len
+        if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and.
+     &  (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4
+ 390  continue
+ 
+      return
+      end
+
+      SUBROUTINE cv_compress( len,nloc,ncum,nd
+     :   ,iflag1,nk1,icb1
+     :   ,cbmf1,plcl1,tnk1,qnk1,gznk1
+     :   ,t1,q1,qs1,u1,v1,gz1
+     :   ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     o   ,iflag,nk,icb
+     o   ,cbmf,plcl,tnk,qnk,gznk
+     o   ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw 
+     o   ,dph          )
+      implicit none
+
+#include "cvparam.h"
+
+c inputs:
+      integer len,ncum,nd,nloc
+      integer iflag1(len),nk1(len),icb1(len)
+      real cbmf1(len),plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+
+c outputs:
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real dph(nloc,nd)
+
+c local variables:
+      integer i,k,nn
+      CHARACTER (LEN=20) :: modname='cv_compress'
+      CHARACTER (LEN=80) :: abort_message
+
+      include 'iniprint.h'
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+      if (nn.ne.ncum) then
+         write(lunout,*)'strange! nn not equal to ncum: ',nn,ncum
+         abort_message = ''
+         CALL abort_gcm (modname,abort_message,1)
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      cbmf(nn)=cbmf1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      do 170 k=1,nl
+       do 160 i=1,ncum
+        dph(i,k)=ph(i,k)-ph(i,k+1)
+ 160   continue
+ 170  continue
+
+      return
+      end
+
+      SUBROUTINE cv_undilute2(nloc,ncum,nd,icb,nk
+     :                       ,tnk,qnk,gznk,t,q,qs,gz
+     :                       ,p,dph,h,tv,lv
+     o                       ,inb,inb1,tp,tvp,clw,hp,ep,sigp,frac)
+      implicit none
+
+C---------------------------------------------------------------------
+C Purpose:
+C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+C     &
+C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE 
+C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+C     &
+C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd), dph(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+
+c outputs:
+      integer inb(nloc), inb1(nloc)
+      real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd)
+      real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd)
+      real frac(nloc)
+
+c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=sigs
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+c
+c ---       The procedure is to solve the equation.
+c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+c
+c   ***  Calculate certain parcel quantities, including static energy   ***
+c
+c
+      do 240 i=1,ncum
+         ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)
+     &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
+ 240  continue
+c
+c
+c    ***  Find lifted parcel quantities above cloud base    ***
+c
+c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+	    if(k.ge.(icb(i)+1))then
+	      tg=t(i,k)
+	      qg=qs(i,k)
+	      alv=lv0-clmcpv*(t(i,k)-t0)
+c
+c First iteration.
+c
+	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-t0
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+	       else
+			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+c Second iteration.
+c
+	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-t0
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+	       else
+			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+c
+	       alv=lv0-clmcpv*(t(i,k)-t0)
+c      print*,'cpd dans convect2 ',cpd
+c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+c              if (.not.cpd.gt.1000.) then
+c                  print*,'CPD=',cpd
+c                  stop
+c              endif
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+            endif
+  290     continue
+  300   continue
+c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+c
+      do 320 k=minorig+1,nl
+        do 310 i=1,ncum
+          if(k.ge.(nk(i)+1))then
+            tca=tp(i,k)-t0
+            if(tca.ge.0.0)then
+              elacrit=elcrit
+            else
+              elacrit=elcrit*(1.0-tca/tlcrit)
+            endif
+            elacrit=max(elacrit,0.0)
+            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+            ep(i,k)=max(ep(i,k),0.0 )
+            ep(i,k)=min(ep(i,k),1.0 )
+            sigp(i,k)=sigs
+          endif
+ 310    continue
+ 320  continue
+c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+c
+      do 340 k=minorig+1,nl
+        do 330 i=1,ncum
+        if(k.ge.(icb(i)+1))then
+          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+c         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+c         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+        endif
+ 330    continue
+ 340  continue
+      do 350 i=1,ncum
+       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+ 350  continue
+c
+c=====================================================================
+c  --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
+c  --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
+c  --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
+c=====================================================================
+c
+      do 510 i=1,ncum
+        cape(i)=0.0
+        capem(i)=0.0
+        inb(i)=icb(i)+1
+        inb1(i)=inb(i)
+ 510  continue
+c
+c Originial Code
+c
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+c         cape(i)=capem(i)+byp
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c K Emanuel fix
+c
+c     call zilch(byp,ncum)
+c     do 530 k=minorig+1,nl-1
+c       do 520 i=1,ncum
+c         if(k.ge.(icb(i)+1))then
+c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+c           cape(i)=cape(i)+by
+c           if(by.ge.0.0)inb1(i)=k+1
+c           if(cape(i).gt.0.0)then
+c             inb(i)=k+1
+c             capem(i)=cape(i)
+c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+c           endif
+c         endif
+c520    continue
+c530  continue
+c     do 540 i=1,ncum
+c         inb(i)=max(inb(i),inb1(i))
+c         cape(i)=capem(i)+byp(i)
+c         defrac=capem(i)-cape(i)
+c         defrac=max(defrac,0.001)
+c         frac(i)=-cape(i)/defrac
+c         frac(i)=min(frac(i),1.0)
+c         frac(i)=max(frac(i),0.0)
+c540   continue
+c
+c J Teixeira fix
+c
+      call zilch(byp,ncum)
+      do 515 i=1,ncum
+        lcape(i)=.true.
+ 515  continue
+      do 530 k=minorig+1,nl-1
+        do 520 i=1,ncum
+          if(cape(i).lt.0.0)lcape(i)=.false.
+          if((k.ge.(icb(i)+1)).and.lcape(i))then
+            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+            cape(i)=cape(i)+by
+            if(by.ge.0.0)inb1(i)=k+1
+            if(cape(i).gt.0.0)then
+              inb(i)=k+1
+              capem(i)=cape(i)
+            endif
+          endif
+ 520    continue
+ 530  continue
+      do 540 i=1,ncum
+          cape(i)=capem(i)+byp(i)
+          defrac=capem(i)-cape(i)
+          defrac=max(defrac,0.001)
+          frac(i)=-cape(i)/defrac
+          frac(i)=min(frac(i),1.0)
+          frac(i)=max(frac(i),0.0)
+ 540  continue
+c
+c=====================================================================
+c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+c=====================================================================
+c
+c initialization:
+      do i=1,ncum*nlp
+       hp(i,1)=h(i,1)
+      enddo
+
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+c
+        return
+        end
+c
+      SUBROUTINE cv_closure(nloc,ncum,nd,nk,icb
+     :                     ,tv,tvp,p,ph,dph,plcl,cpn
+     :                     ,iflag,cbmf)
+      implicit none
+
+c inputs:
+      integer ncum, nd, nloc
+      integer nk(nloc), icb(nloc)
+      real tv(nloc,nd), tvp(nloc,nd), p(nloc,nd), dph(nloc,nd)
+      real ph(nloc,nd+1) ! caution nd instead ndp1 to be consistent...
+      real plcl(nloc), cpn(nloc,nd)
+
+c outputs:
+      integer iflag(nloc)
+      real cbmf(nloc) ! also an input
+
+c local variables:
+      integer i, k, icbmax
+      real dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc)
+      real work(nloc)
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c-------------------------------------------------------------------
+c Compute icbmax. 
+c-------------------------------------------------------------------
+
+      icbmax=2
+      do 230 i=1,ncum
+       icbmax=max(icbmax,icb(i))
+ 230  continue
+
+c=====================================================================
+c ---  CALCULATE CLOUD BASE MASS FLUX 
+c=====================================================================
+c
+c tvpplcl = parcel temperature lifted adiabatically from level
+c           icb-1 to the LCL.
+c tvaplcl = virtual temperature at the LCL.
+c
+      do 610 i=1,ncum
+        dtpbl(i)=0.0
+        tvpplcl(i)=tvp(i,icb(i)-1)
+     &  -rrd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i))
+     &  /(cpn(i,icb(i)-1)*p(i,icb(i)-1))
+        tvaplcl(i)=tv(i,icb(i))
+     &  +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i)))
+     &  /(p(i,icb(i))-p(i,icb(i)+1))
+ 610  continue
+
+c-------------------------------------------------------------------
+c --- Interpolate difference between lifted parcel and
+c --- environmental temperatures to lifted condensation level
+c-------------------------------------------------------------------
+c
+c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
+c
+      do 630 k=minorig,icbmax
+        do 620 i=1,ncum
+        if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then
+          dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k)
+        endif
+ 620    continue
+ 630  continue
+      do 640 i=1,ncum
+        dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
+        dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i)
+ 640  continue
+c
+c-------------------------------------------------------------------
+c --- Adjust cloud base mass flux
+c-------------------------------------------------------------------
+c
+      do 650 i=1,ncum
+       work(i)=cbmf(i)
+       cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
+       if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then
+         iflag(i)=3
+       endif
+ 650  continue
+
+       return
+       end
+
+      SUBROUTINE cv_mixing(nloc,ncum,nd,icb,nk,inb,inb1
+     :                    ,ph,t,q,qs,u,v,h,lv,qnk
+     :                    ,hp,tv,tvp,ep,clw,cbmf
+     :                    ,m,ment,qent,uent,vent,nent,sij,elij)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc), inb1(nloc), nk(nloc)
+      real cbmf(nloc), qnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), lv(nloc,nd)
+      real u(nloc,nd), v(nloc,nd), h(nloc,nd), hp(nloc,nd)
+      real tv(nloc,nd), tvp(nloc,nd), ep(nloc,nd), clw(nloc,nd)
+
+c outputs:
+      integer nent(nloc,nd)
+      real m(nloc,nd), ment(nloc,nd,nd), qent(nloc,nd,nd)
+      real uent(nloc,nd,nd), vent(nloc,nd,nd)
+      real sij(nloc,nd,nd), elij(nloc,nd,nd)
+
+c local variables:
+      integer i, j, k, ij
+      integer num1, num2
+      real dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp
+      real alt, qp1, smid, sjmin, sjmax, delp, delm
+      real work(nloc), asij(nloc), smin(nloc), scrit(nloc)
+      real bsum(nloc,nd)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+c=====================================================================
+c
+        do 360 i=1,ncum*nlp
+          nent(i,1)=0
+          m(i,1)=0.0
+ 360    continue
+c
+      do 400 k=1,nlp
+       do 390 j=1,nlp
+          do 385 i=1,ncum
+            qent(i,k,j)=q(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+            ment(i,k,j)=0.0
+            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+c
+c-------------------------------------------------------------------
+c --- Calculate rates of mixing,  m(i)
+c-------------------------------------------------------------------
+c
+      call zilch(work,ncum)
+c
+      do 670 j=minorig+1,nl
+        do 660 i=1,ncum
+          if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then
+             k=min(j,inb1(i))
+             dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1))
+     &       +entp*0.04*(ph(i,k)-ph(i,k+1))
+             work(i)=work(i)+dbo
+             m(i,j)=cbmf(i)*dbo
+          endif
+ 660    continue
+ 670  continue
+      do 690 k=minorig+1,nl
+        do 680 i=1,ncum
+          if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then
+            m(i,k)=m(i,k)/work(i)
+          endif
+ 680    continue
+ 690  continue
+c
+c
+c=====================================================================
+c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+c --- FRACTION (sij)
+c=====================================================================
+c
+c
+       do 750 i=minorig+1,nl
+         do 710 j=minorig+1,nl
+           do 700 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij))
+     &         .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then
+               qti=qnk(ij)-ep(ij,i)*clw(ij,i)
+               bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j)
+     &         /(rrv*t(ij,j)*t(ij,j)*cpd)
+               anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j))
+               denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j)
+               dei=denom
+               if(abs(dei).lt.0.01)dei=0.01
+               sij(ij,i,j)=anum/dei
+               sij(ij,i,i)=1.0
+               altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+               altem=altem/bf2
+               cwat=clw(ij,j)*(1.-ep(ij,j))
+               stemp=sij(ij,i,j)
+               if((stemp.lt.0.0.or.stemp.gt.1.0.or.
+     1           altem.gt.cwat).and.j.gt.i)then
+                 anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2)
+                 denom=denom+lv(ij,j)*(q(ij,i)-qti)
+                 if(abs(denom).lt.0.01)denom=0.01
+                 sij(ij,i,j)=anum/denom
+                 altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+                 altem=altem-(bf2-1.)*cwat
+               endif
+               if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                 qent(ij,i,j)=sij(ij,i,j)*q(ij,i)
+     &                        +(1.-sij(ij,i,j))*qti
+                 uent(ij,i,j)=sij(ij,i,j)*u(ij,i)
+     &                        +(1.-sij(ij,i,j))*u(ij,nk(ij))
+                 vent(ij,i,j)=sij(ij,i,j)*v(ij,i)
+     &                        +(1.-sij(ij,i,j))*v(ij,nk(ij))
+                 elij(ij,i,j)=altem
+                 elij(ij,i,j)=max(0.0,elij(ij,i,j))
+                 ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j))
+                 nent(ij,i)=nent(ij,i)+1
+               endif
+             sij(ij,i,j)=max(0.0,sij(ij,i,j))
+             sij(ij,i,j)=min(1.0,sij(ij,i,j))
+             endif
+  700      continue
+  710    continue
+c
+c   ***   If no air can entrain at level i assume that updraft detrains  ***
+c   ***   at that level and calculate detrained air flux and properties  ***
+c
+           do 740 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij))
+     &       .and.(nent(ij,i).eq.0))then
+               ment(ij,i,i)=m(ij,i)
+               qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+               uent(ij,i,i)=u(ij,nk(ij))
+               vent(ij,i,i)=v(ij,nk(ij))
+               elij(ij,i,i)=clw(ij,i)
+               sij(ij,i,i)=1.0
+             endif
+ 740       continue
+ 750   continue
+c
+      do 770 i=1,ncum
+        sij(i,inb(i),inb(i))=1.0
+ 770  continue
+c
+c=====================================================================
+c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+c=====================================================================
+c
+       call zilch(bsum,ncum*nlp)
+       do 780 ij=1,ncum
+         lwork(ij)=.false.
+ 780   continue
+       do 789 i=minorig+1,nl
+c
+         num1=0
+         do 779 ij=1,ncum
+           if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1
+ 779     continue
+         if(num1.le.0)go to 789
+c
+           do 781 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then
+                lwork(ij)=(nent(ij,i).ne.0)
+                qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i))
+                denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1)
+                if(abs(denom).lt.0.01)denom=0.01
+                scrit(ij)=anum/denom
+                alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1)
+                if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0
+                asij(ij)=0.0
+                smin(ij)=1.0
+             endif
+ 781       continue
+         do 783 j=minorig,nl
+c
+         num2=0
+         do 778 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &       .and.lwork(ij))num2=num2+1
+ 778     continue
+         if(num2.le.0)go to 783
+c
+           do 782 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then
+                  if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                    if(j.gt.i)then
+                      smid=min(sij(ij,i,j),scrit(ij))
+                      sjmax=smid
+                      sjmin=smid
+                        if(smid.lt.smin(ij)
+     &                  .and.sij(ij,i,j+1).lt.smid)then
+                          smin(ij)=smid
+                          sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij))
+                          sjmin=max(sij(ij,i,j-1),sij(ij,i,j))
+                          sjmin=min(sjmin,scrit(ij))
+                        endif
+                    else
+                      sjmax=max(sij(ij,i,j+1),scrit(ij))
+                      smid=max(sij(ij,i,j),scrit(ij))
+                      sjmin=0.0
+                      if(j.gt.1)sjmin=sij(ij,i,j-1)
+                      sjmin=max(sjmin,scrit(ij))
+                    endif
+                    delp=abs(sjmax-smid)
+                    delm=abs(sjmin-smid)
+                    asij(ij)=asij(ij)+(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                    ment(ij,i,j)=ment(ij,i,j)*(delp+delm)
+     &                           *(ph(ij,j)-ph(ij,j+1))
+                  endif
+              endif
+  782    continue
+  783    continue
+            do 784 ij=1,ncum
+            if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then
+               asij(ij)=max(1.0e-21,asij(ij))
+               asij(ij)=1.0/asij(ij)
+               bsum(ij,i)=0.0
+            endif
+ 784        continue
+            do 786 j=minorig,nl+1
+              do 785 ij=1,ncum
+                if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &          .and.(j.ge.icb(ij)).and.(j.le.inb(ij))
+     &          .and.lwork(ij))then
+                   ment(ij,i,j)=ment(ij,i,j)*asij(ij)
+                   bsum(ij,i)=bsum(ij,i)+ment(ij,i,j)
+                endif
+ 785     continue
+ 786     continue
+             do 787 ij=1,ncum
+               if((i.ge.icb(ij)+1).and.(i.le.inb(ij))
+     &         .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then
+                 nent(ij,i)=0
+                 ment(ij,i,i)=m(ij,i)
+                 qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                 uent(ij,i,i)=u(ij,nk(ij))
+                 vent(ij,i,i)=v(ij,nk(ij))
+                 elij(ij,i,i)=clw(ij,i)
+                 sij(ij,i,i)=1.0
+               endif
+  787        continue
+  789  continue
+c
+       return
+       end
+
+      SUBROUTINE cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph
+     :                  ,h,lv,ep,sigp,clw,m,ment,elij
+     :                  ,iflag,mp,qp,up,vp,wt,water,evap)
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs:
+      integer ncum, nd, nloc
+      integer inb(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd)
+      real gz(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd)
+      real lv(nloc,nd), ep(nloc,nd), sigp(nloc,nd), clw(nloc,nd)
+      real m(nloc,nd), ment(nloc,nd,nd), elij(nloc,nd,nd)
+
+c outputs:
+      integer iflag(nloc) ! also an input
+      real mp(nloc,nd), qp(nloc,nd), up(nloc,nd), vp(nloc,nd)
+      real water(nloc,nd), evap(nloc,nd), wt(nloc,nd)
+
+c local variables:
+      integer i,j,k,ij,num1
+      integer jtt(nloc)
+      real awat, coeff, qsm, afac, sigt, b6, c6, revap
+      real dhdp, fac, qstm, rat
+      real wdtrain(nloc)
+      logical lwork(nloc)
+
+c=====================================================================
+c --- PRECIPITATING DOWNDRAFT CALCULATION
+c=====================================================================
+c
+c Initializations:
+c
+         do i = 1, ncum
+         do k = 1, nl+1
+          wt(i,k) = omtsnow
+          mp(i,k) = 0.0
+          evap(i,k) = 0.0
+          water(i,k) = 0.0
+         enddo
+         enddo
+
+         do 420 i=1,ncum
+          qp(i,1)=q(i,1)
+          up(i,1)=u(i,1)
+          vp(i,1)=v(i,1)
+ 420     continue
+
+         do 440 k=2,nl+1
+         do 430 i=1,ncum
+          qp(i,k)=q(i,k-1)
+          up(i,k)=u(i,k-1)
+          vp(i,k)=v(i,k-1)
+ 430     continue
+ 440     continue
+
+
+c   ***  Check whether ep(inb)=0, if so, skip precipitating    ***
+c   ***             downdraft calculation                      ***
+c
+c
+c   ***  Integrate liquid water equation to find condensed water   ***
+c   ***                and condensed water flux                    ***
+c
+c
+      do 890 i=1,ncum
+        jtt(i)=2
+        if(ep(i,inb(i)).le.0.0001)iflag(i)=2
+        if(iflag(i).eq.0)then
+          lwork(i)=.true.
+        else
+          lwork(i)=.false.
+        endif
+ 890  continue
+c
+c    ***                    Begin downdraft loop                    ***
+c
+c
+        call zilch(wdtrain,ncum)
+        do 899 i=nl+1,1,-1
+c
+          num1=0
+          do 879 ij=1,ncum
+            if((i.le.inb(ij)).and.lwork(ij))num1=num1+1
+ 879      continue
+          if(num1.le.0)go to 899
+c
+c
+c    ***        Calculate detrained precipitation             ***
+c
+          do 891 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i)
+            endif
+ 891      continue
+c
+          if(i.gt.1)then
+            do 893 j=1,i-1
+              do 892 ij=1,ncum
+                if((i.le.inb(ij)).and.(lwork(ij)))then
+                  awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i)
+                  awat=max(0.0,awat)
+                  wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i)
+                endif
+ 892          continue
+ 893      continue
+          endif
+c
+c    ***    Find rain water and evaporation using provisional   ***
+c    ***              estimates of qp(i)and qp(i-1)             ***
+c
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for snow   ***
+c
+          do 894 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            coeff=coeffs
+            wt(ij,i)=omtsnow
+c
+c  ***  Value of terminal velocity and coeffecient of evaporation for rain   ***
+c
+            if(t(ij,i).gt.273.0)then
+              coeff=coeffr
+              wt(ij,i)=omtrain
+            endif
+            qsm=0.5*(q(ij,i)+qp(ij,i+1))
+            afac=coeff*ph(ij,i)*(qs(ij,i)-qsm)
+     &       /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i))
+            afac=max(afac,0.0)
+            sigt=sigp(ij,i)
+            sigt=max(0.0,sigt)
+            sigt=min(1.0,sigt)
+            b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i)
+            c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i)
+            revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+            evap(ij,i)=sigt*afac*revap
+            water(ij,i)=revap*revap
+c
+c    ***  Calculate precipitating downdraft mass flux under     ***
+c    ***              hydrostatic approximation                 ***
+c
+            if(i.gt.1)then
+              dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
+              dhdp=max(dhdp,10.0)
+              mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp
+              mp(ij,i)=max(mp(ij,i),0.0)
+c
+c   ***   Add small amount of inertia to downdraft              ***
+c
+              fac=20.0/(ph(ij,i-1)-ph(ij,i))
+              mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
+c
+c    ***      Force mp to decrease linearly to zero                 ***
+c    ***      between about 950 mb and the surface                  ***
+c
+              if(p(ij,i).gt.(0.949*p(ij,1)))then
+                 jtt(ij)=max(jtt(ij),i)
+                 mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i))
+     &           /(p(ij,1)-p(ij,jtt(ij)))
+              endif
+            endif
+c
+c    ***       Find mixing ratio of precipitating downdraft     ***
+c
+            if(i.ne.inb(ij))then
+              if(i.eq.1)then
+                qstm=qs(ij,1)
+              else
+                qstm=qs(ij,i-1)
+              endif
+              if(mp(ij,i).gt.mp(ij,i+1))then
+                 rat=mp(ij,i+1)/mp(ij,i)
+                 qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv*
+     &             sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
+                 up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat)
+                 vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat)
+               else
+                 if(mp(ij,i+1).gt.0.0)then
+                   qp(ij,i)=(gz(ij,i+1)-gz(ij,i)
+     &               +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1)
+     &               *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i)))
+     &               /(lv(ij,i)+t(ij,i)*(cl-cpd))
+                   up(ij,i)=up(ij,i+1)
+                   vp(ij,i)=vp(ij,i+1)
+                 endif
+              endif
+              qp(ij,i)=min(qp(ij,i),qstm)
+              qp(ij,i)=max(qp(ij,i),0.0)
+            endif
+            endif
+ 894      continue
+ 899    continue
+c
+        return
+        end
+
+      SUBROUTINE cv_yield(nloc,ncum,nd,nk,icb,inb,delt
+     :             ,t,q,u,v,gz,p,ph,h,hp,lv,cpn
+     :             ,ep,clw,frac,m,mp,qp,up,vp
+     :             ,wt,water,evap
+     :             ,ment,qent,uent,vent,nent,elij
+     :             ,tv,tvp
+     o             ,iflag,wd,qprime,tprime
+     o             ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+c inputs
+      integer ncum, nd, nloc
+      integer nk(nloc), icb(nloc), inb(nloc)
+      integer nent(nloc,nd)
+      real delt
+      real t(nloc,nd), q(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real gz(nloc,nd)
+      real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd)
+      real hp(nloc,nd), lv(nloc,nd)
+      real cpn(nloc,nd), ep(nloc,nd), clw(nloc,nd), frac(nloc)
+      real m(nloc,nd), mp(nloc,nd), qp(nloc,nd)
+      real up(nloc,nd), vp(nloc,nd)
+      real wt(nloc,nd), water(nloc,nd), evap(nloc,nd)
+      real ment(nloc,nd,nd), qent(nloc,nd,nd), elij(nloc,nd,nd)
+      real uent(nloc,nd,nd), vent(nloc,nd,nd)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+c outputs
+      integer iflag(nloc)  ! also an input
+      real cbmf(nloc)      ! also an input
+      real wd(nloc), tprime(nloc), qprime(nloc)
+      real precip(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real Ma(nloc,nd)
+      real qcondc(nloc,nd)
+
+c local variables
+      integer i,j,ij,k,num1
+      real dpinv,cpinv,awat,fqold,ftold,fuold,fvold,delti
+      real work(nloc), am(nloc),amp1(nloc),ad(nloc)
+      real ents(nloc), uav(nloc),vav(nloc),lvcp(nloc,nd)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd) ! cld
+      real siga(nloc,nd), ax(nloc,nd), mac(nloc,nd)     ! cld
+
+ 
+c -- initializations:
+
+      delti = 1.0/delt
+
+      do 160 i=1,ncum
+      precip(i)=0.0
+      wd(i)=0.0
+      tprime(i)=0.0
+      qprime(i)=0.0
+       do 170 k=1,nl+1
+        ft(i,k)=0.0
+        fu(i,k)=0.0
+        fv(i,k)=0.0
+        fq(i,k)=0.0
+        lvcp(i,k)=lv(i,k)/cpn(i,k)
+        qcondc(i,k)=0.0              ! cld
+        qcond(i,k)=0.0               ! cld
+        nqcond(i,k)=0.0              ! cld
+ 170   continue
+ 160  continue
+
+c
+c   ***  Calculate surface precipitation in mm/day     ***
+c
+        do 1190 i=1,ncum
+          if(iflag(i).le.1)then
+cc            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
+cc     &                /(rowl*g)
+cc            precip(i)=precip(i)*delt/86400.
+            precip(i) = wt(i,1)*sigd*water(i,1)*86400/g
+          endif
+ 1190   continue
+c
+c
+c   ***  Calculate downdraft velocity scale and surface temperature and  ***
+c   ***                    water vapor fluctuations                      ***
+c
+      do i=1,ncum
+       wd(i)=betad*abs(mp(i,icb(i)))*0.01*rrd*t(i,icb(i))
+     :           /(sigd*p(i,icb(i)))
+       qprime(i)=0.5*(qp(i,1)-q(i,1))
+       tprime(i)=lv0*qprime(i)/cpd
+      enddo
+c
+c   ***  Calculate tendencies of lowest level potential temperature  ***
+c   ***                      and mixing ratio                        ***
+c
+        do 1200 i=1,ncum
+          work(i)=0.01/(ph(i,1)-ph(i,2))
+          am(i)=0.0
+ 1200   continue
+        do 1220 k=2,nl
+          do 1210 i=1,ncum
+            if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then
+              am(i)=am(i)+m(i,k)
+            endif
+ 1210     continue
+ 1220   continue
+        do 1240 i=1,ncum
+          if((g*work(i)*am(i)).ge.delti)iflag(i)=1
+          ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1)
+     &    +(gz(i,2)-gz(i,1))/cpn(i,1))
+          ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1)
+          ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2)
+     &     -t(i,1))*work(i)/cpn(i,1)
+          fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))*
+     &    work(i)+sigd*evap(i,1)
+          fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i)
+          fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))
+     &    +am(i)*(u(i,2)-u(i,1)))
+          fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))
+     &    +am(i)*(v(i,2)-v(i,1)))
+ 1240   continue
+        do 1260 j=2,nl
+           do 1250 i=1,ncum
+             if(j.le.inb(i))then
+               fq(i,1)=fq(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1))
+               fu(i,1)=fu(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1))
+               fv(i,1)=fv(i,1)
+     &                 +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1))
+             endif
+ 1250      continue
+ 1260   continue
+c
+c   ***  Calculate tendencies of potential temperature and mixing ratio  ***
+c   ***               at levels above the lowest level                   ***
+c
+c   ***  First find the net saturated updraft and downdraft mass fluxes  ***
+c   ***                      through each level                          ***
+c
+        do 1500 i=2,nl+1
+c
+          num1=0
+          do 1265 ij=1,ncum
+            if(i.le.inb(ij))num1=num1+1
+ 1265     continue
+          if(num1.le.0)go to 1500
+c
+          call zilch(amp1,ncum)
+          call zilch(ad,ncum)
+c
+          do 1280 k=i+1,nl+1
+            do 1270 ij=1,ncum
+              if((i.ge.nk(ij)).and.(i.le.inb(ij))
+     &            .and.(k.le.(inb(ij)+1)))then
+                amp1(ij)=amp1(ij)+m(ij,k)
+              endif
+ 1270         continue
+ 1280     continue
+c
+          do 1310 k=1,i
+            do 1300 j=i+1,nl+1
+               do 1290 ij=1,ncum
+                 if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then
+                   amp1(ij)=amp1(ij)+ment(ij,k,j)
+                 endif
+ 1290          continue
+ 1300       continue
+ 1310     continue
+          do 1340 k=1,i-1
+            do 1330 j=i,nl+1
+              do 1320 ij=1,ncum
+                if((i.le.inb(ij)).and.(j.le.inb(ij)))then
+                   ad(ij)=ad(ij)+ment(ij,j,k)
+                endif
+ 1320         continue
+ 1330       continue
+ 1340     continue
+c
+          do 1350 ij=1,ncum
+          if(i.le.inb(ij))then
+            dpinv=0.01/(ph(ij,i)-ph(ij,i+1))
+            cpinv=1.0/cpn(ij,i)
+c
+            ft(ij,i)=ft(ij,i)
+     &       +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i)
+     &       +(gz(ij,i+1)-gz(ij,i))*cpinv)
+     &       -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv))
+     &       -sigd*lvcp(ij,i)*evap(ij,i)
+            ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+
+     &        t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
+            ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)*
+     &        (t(ij,i+1)-t(ij,i))*dpinv*cpinv
+            fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))-
+     &        ad(ij)*(q(ij,i)-q(ij,i-1)))
+            fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))-
+     &        ad(ij)*(u(ij,i)-u(ij,i-1)))
+            fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))-
+     &        ad(ij)*(v(ij,i)-v(ij,i-1)))
+         endif
+ 1350    continue
+         do 1370 k=1,i-1
+           do 1360 ij=1,ncum
+             if(i.le.inb(ij))then
+               awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i)
+               awat=max(awat,0.0)
+               fq(ij,i)=fq(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &         +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+c (saturated updrafts resulting from mixing)               ! cld
+               qcond(ij,i)=qcond(ij,i)+(elij(ij,k,i)-awat) ! cld
+               nqcond(ij,i)=nqcond(ij,i)+1.                ! cld
+             endif
+ 1360      continue
+ 1370    continue
+         do 1390 k=i,nl+1
+           do 1380 ij=1,ncum
+             if((i.le.inb(ij)).and.(k.le.inb(ij)))then
+               fq(ij,i)=fq(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i))
+               fu(ij,i)=fu(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)
+     &                  +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+             endif
+ 1380      continue
+ 1390    continue
+          do 1400 ij=1,ncum
+           if(i.le.inb(ij))then
+             fq(ij,i)=fq(ij,i)
+     &                +sigd*evap(ij,i)+g*(mp(ij,i+1)*
+     &                (qp(ij,i+1)-q(ij,i))
+     &                -mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
+             fu(ij,i)=fu(ij,i)
+     &                +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)*
+     &                (up(ij,i)-u(ij,i-1)))*dpinv
+             fv(ij,i)=fv(ij,i)
+     &               +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)*
+     &               (vp(ij,i)-v(ij,i-1)))*dpinv
+C (saturated downdrafts resulting from mixing)               ! cld
+            do k=i+1,inb(ij)                                 ! cld
+             qcond(ij,i)=qcond(ij,i)+elij(ij,k,i)            ! cld
+             nqcond(ij,i)=nqcond(ij,i)+1.                    ! cld
+            enddo                                            ! cld
+C (particular case: no detraining level is found)            ! cld
+            if (nent(ij,i).eq.0) then                        ! cld
+             qcond(ij,i)=qcond(ij,i)+(1.-ep(ij,i))*clw(ij,i) ! cld
+             nqcond(ij,i)=nqcond(ij,i)+1.                    ! cld
+            endif                                            ! cld
+            if (nqcond(ij,i).ne.0.) then                     ! cld
+             qcond(ij,i)=qcond(ij,i)/nqcond(ij,i)            ! cld
+            endif                                            ! cld
+           endif
+ 1400     continue
+ 1500   continue
+c
+c   *** Adjust tendencies at top of convection layer to reflect  ***
+c   ***       actual position of the level zero cape             ***
+c
+        do 503 ij=1,ncum
+        fqold=fq(ij,inb(ij))
+        fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij))
+        fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1)
+     &   +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij))
+     &   /lv(ij,inb(ij)-1)
+        ftold=ft(ij,inb(ij))
+        ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij))
+        ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1)
+     &   +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij))
+     &   /cpn(ij,inb(ij)-1)
+        fuold=fu(ij,inb(ij))
+        fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij))
+        fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1)
+     &   +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+        fvold=fv(ij,inb(ij))
+        fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij))
+        fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1)
+     &  +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/
+     1   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+ 503    continue
+c
+c   ***   Very slightly adjust tendencies to force exact   ***
+c   ***     enthalpy, momentum and tracer conservation     ***
+c
+        do 682 ij=1,ncum
+        ents(ij)=0.0
+        uav(ij)=0.0
+        vav(ij)=0.0
+        do 681 i=1,inb(ij)
+         ents(ij)=ents(ij)
+     &  +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1))	
+         uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1))
+         vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1))
+  681	continue
+  682   continue
+        do 683 ij=1,ncum
+        ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+ 683    continue
+        do 642 ij=1,ncum
+        do 641 i=1,inb(ij)
+         ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i)
+         fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij))
+         fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij))
+  641	continue
+ 642    continue
+c
+        do 1810 k=1,nl+1
+          do 1800 i=1,ncum
+            if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10
+ 1800     continue
+ 1810   continue
+c
+c
+        do 1900 i=1,ncum
+          if(iflag(i).gt.2)then
+          precip(i)=0.0
+          cbmf(i)=0.0
+          endif
+ 1900   continue
+        do 1920 k=1,nl
+         do 1910 i=1,ncum
+           if(iflag(i).gt.2)then
+             ft(i,k)=0.0
+             fq(i,k)=0.0
+             fu(i,k)=0.0
+             fv(i,k)=0.0
+             qcondc(i,k)=0.0                               ! cld
+           endif
+ 1910    continue
+ 1920   continue
+
+        do k=1,nl+1
+        do i=1,ncum
+          Ma(i,k) = 0.
+        enddo
+        enddo
+        do k=nl,1,-1
+        do i=1,ncum
+          Ma(i,k) = Ma(i,k+1)+m(i,k)
+        enddo
+        enddo
+
+c
+c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+c   ***           of condensed water         ***            ! cld
+c                                                           ! cld
+      DO ij=1,ncum                                          ! cld   
+       do i=1,nd                                            ! cld 
+        mac(ij,i)=0.0                                       ! cld   
+        wa(ij,i)=0.0                                        ! cld
+        siga(ij,i)=0.0                                      ! cld
+       enddo                                                ! cld
+       do i=nk(ij),inb(ij)                                  ! cld
+       do k=i+1,inb(ij)+1                                   ! cld
+        mac(ij,i)=mac(ij,i)+m(ij,k)                         ! cld
+       enddo                                                ! cld
+       enddo                                                ! cld
+       do i=icb(ij),inb(ij)-1                               ! cld
+        ax(ij,i)=0.                                         ! cld
+        do j=icb(ij),i                                      ! cld
+         ax(ij,i)=ax(ij,i)+rrd*(tvp(ij,j)-tv(ij,j))         ! cld   
+     :       *(ph(ij,j)-ph(ij,j+1))/p(ij,j)                 ! cld   
+        enddo                                               ! cld
+        if (ax(ij,i).gt.0.0) then                           ! cld   
+         wa(ij,i)=sqrt(2.*ax(ij,i))                         ! cld
+        endif                                               ! cld
+       enddo                                                ! cld
+       do i=1,nl                                            ! cld
+        if (wa(ij,i).gt.0.0)                                ! cld
+     :    siga(ij,i)=mac(ij,i)/wa(ij,i)                     ! cld   
+     :        *rrd*tvp(ij,i)/p(ij,i)/100./delta             ! cld   
+        siga(ij,i) = min(siga(ij,i),1.0)                    ! cld
+        qcondc(ij,i)=siga(ij,i)*clw(ij,i)*(1.-ep(ij,i))     ! cld   
+     :          + (1.-siga(ij,i))*qcond(ij,i)               ! cld   
+       enddo                                                ! cld
+      ENDDO                                                 ! cld   
+
+        return
+        end
+
+      SUBROUTINE cv_uncompress(nloc,len,ncum,nd,idcum
+     :         ,iflag
+     :         ,precip,cbmf
+     :         ,ft,fq,fu,fv
+     :         ,Ma,qcondc            
+     :         ,iflag1
+     :         ,precip1,cbmf1
+     :         ,ft1,fq1,fu1,fv1
+     :         ,Ma1,qcondc1            
+     :                               )
+      implicit none
+
+#include "cvparam.h"
+
+c inputs:
+      integer len, ncum, nd, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      real precip(nloc), cbmf(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real Ma(nloc,nd)
+      real qcondc(nloc,nd) !cld
+
+c outputs:
+      integer iflag1(len)
+      real precip1(len), cbmf1(len)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real Ma1(len,nd)
+      real qcondc1(len,nd) !cld
+
+c local variables:
+      integer i,k
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         cbmf1(idcum(i))=cbmf(i)
+         iflag1(idcum(i))=iflag(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+ 2010     continue
+ 2020   continue
+
+        return
+        end
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cv_routines.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cv_routines.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cv_routines.F90	(revision 17)
@@ -0,0 +1,1762 @@
+!
+! $Id: cv_routines.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE cv_param(nd)
+      implicit none
+
+!c------------------------------------------------------------
+!c Set parameters for convectL
+!c (includes microphysical parameters and parameters that 
+!c  control the rate of approach to quasi-equilibrium) 
+!c------------------------------------------------------------
+
+!C   *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
+!C   ***  TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO-        ***
+!C   ***       CONVERSION THRESHOLD IS ASSUMED TO BE ZERO             ***
+!C   ***     (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY            ***
+!C   ***               BETWEEN 0 C AND TLCRIT)                        ***
+!C   ***   ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT       ***
+!C   ***                       FORMULATION                            ***
+!C   ***  SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT  ***
+!C   ***  SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE       ***
+!C   ***                        OF CLOUD                              ***
+!C   ***        OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN       ***
+!C   ***     OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW          ***
+!C   ***  COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+!C   ***                          OF RAIN                             ***
+!C   ***  COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION   ***
+!C   ***                          OF SNOW                             ***
+!C   ***     CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM      ***
+!C   ***                         TRANSPORT                            ***
+!C   ***    DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION    ***
+!C   ***        A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC      ***
+!C   ***    ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF    ***
+!C   ***                 APPROACH TO QUASI-EQUILIBRIUM                ***
+!C   ***   (THEIR STANDARD VALUES ARE  0.20 AND 0.1, RESPECTIVELY)    ***
+!C   ***                   (DAMP MUST BE LESS THAN 1)                 ***
+
+#include "cvparam.h"
+      integer nd
+      CHARACTER (LEN=20) :: modname='cv_routines'
+      CHARACTER (LEN=80) :: abort_message
+
+!c noff: integer limit for convection (nd-noff)
+!c minorig: First level of convection
+
+      noff = 2
+      minorig = 2
+
+      nl=nd-noff
+      nlp=nl+1
+      nlm=nl-1
+
+      elcrit=0.0011
+      tlcrit=-55.0
+      entp=1.5
+      sigs=0.12
+      sigd=0.05
+      omtrain=50.0
+      omtsnow=5.5
+      coeffr=1.0
+      coeffs=0.8
+      dtmax=0.9
+!c
+      cu=0.70
+!c
+      betad=10.0
+!c
+      damp=0.1
+      alpha=0.2
+!c
+      delta=0.01  ! cld
+!c
+      return
+      end SUBROUTINE cv_param
+
+      SUBROUTINE cv_prelim(len,nd,ndp1,t,q,p,ph                                      &
+       &                    ,lv,cpn,tv,gz,h,hm)
+      implicit none
+
+!=====================================================================
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!=====================================================================
+
+!c inputs:
+      integer len, nd, ndp1
+      real t(len,nd), q(len,nd), p(len,nd), ph(len,ndp1)
+
+!c outputs:
+      real lv(len,nd), cpn(len,nd), tv(len,nd)
+      real gz(len,nd), h(len,nd), hm(len,nd)
+
+!c local variables:
+      integer k, i
+      real cpx(len,nd)
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+
+      do 110 k=1,nlp
+        do 100 i=1,len
+          lv(i,k)= lv0-clmcpv*(t(i,k)-t0)
+          cpn(i,k)=cpd*(1.0-q(i,k))+cpv*q(i,k)
+          cpx(i,k)=cpd*(1.0-q(i,k))+cl*q(i,k)
+          tv(i,k)=t(i,k)*(1.0+q(i,k)*epsim1)
+ 100    continue
+ 110  continue
+!c
+!c gz = phi at the full levels (same as p).
+!c
+      do 120 i=1,len
+        gz(i,1)=0.0
+ 120  continue
+      do 140 k=2,nlp
+        do 130 i=1,len
+          gz(i,k)=gz(i,k-1)+hrd*(tv(i,k-1)+tv(i,k))                                  &
+       &         *(p(i,k-1)-p(i,k))/ph(i,k)
+ 130    continue
+ 140  continue
+!c
+!c h  = phi + cpT (dry static energy).
+!c hm = phi + cp(T-Tbase)+Lq
+!c
+      do 170 k=1,nlp
+        do 160 i=1,len
+          h(i,k)=gz(i,k)+cpn(i,k)*t(i,k)
+          hm(i,k)=gz(i,k)+cpx(i,k)*(t(i,k)-t(i,1))+lv(i,k)*q(i,k)
+ 160    continue
+ 170  continue
+
+      return
+      end SUBROUTINE cv_prelim
+
+      SUBROUTINE cv_feed(len,nd,t,q,qs,p,hm,gz                                       &
+       &                  ,nk,icb,icbmax,iflag,tnk,qnk,gznk,plcl)
+      implicit none
+
+!C================================================================
+!C Purpose: CONVECTIVE FEED
+!C================================================================
+
+#include "cvparam.h"
+
+!c inputs:
+	  integer len, nd
+      real t(len,nd), q(len,nd), qs(len,nd), p(len,nd)
+      real hm(len,nd), gz(len,nd)
+
+!c outputs:
+	  integer iflag(len), nk(len), icb(len), icbmax
+      real tnk(len), qnk(len), gznk(len), plcl(len)
+
+!c local variables:
+      integer i, k
+      integer ihmin(len)
+      real work(len)
+      real pnk(len), qsnk(len), rh(len), chi(len)
+
+!-------------------------------------------------------------------
+! --- Find level of minimum moist static energy
+! --- If level of minimum moist static energy coincides with
+! --- or is lower than minimum allowable parcel origin level,
+! --- set iflag to 6.
+!-------------------------------------------------------------------
+
+      do 180 i=1,len
+       work(i)=1.0e12
+       ihmin(i)=nl
+ 180  continue
+      do 200 k=2,nlp
+        do 190 i=1,len
+         if((hm(i,k).lt.work(i)).and.                                                &
+       &      (hm(i,k).lt.hm(i,k-1)))then
+           work(i)=hm(i,k)
+           ihmin(i)=k
+         endif
+ 190    continue
+ 200  continue
+      do 210 i=1,len
+        ihmin(i)=min(ihmin(i),nlm)
+        if(ihmin(i).le.minorig)then
+          iflag(i)=6
+        endif
+ 210  continue
+!c
+!-------------------------------------------------------------------
+! --- Find that model level below the level of minimum moist static
+! --- energy that has the maximum value of moist static energy
+!-------------------------------------------------------------------
+ 
+      do 220 i=1,len
+       work(i)=hm(i,minorig)
+       nk(i)=minorig
+ 220  continue
+      do 240 k=minorig+1,nl
+        do 230 i=1,len
+         if((hm(i,k).gt.work(i)).and.(k.le.ihmin(i)))then
+           work(i)=hm(i,k)
+           nk(i)=k
+         endif
+ 230     continue
+ 240  continue
+!-------------------------------------------------------------------
+! --- Check whether parcel level temperature and specific humidity
+! --- are reasonable
+!-------------------------------------------------------------------
+       do 250 i=1,len
+       if(((t(i,nk(i)).lt.250.0).or.                                                 &
+       &      (q(i,nk(i)).le.0.0).or.                                                &
+       &      (p(i,ihmin(i)).lt.400.0)).and.                                         &
+       &      (iflag(i).eq.0))iflag(i)=7
+ 250   continue
+!-------------------------------------------------------------------
+! --- Calculate lifted condensation level of air at parcel origin level
+! --- (Within 0.2% of formula of Bolton, MON. WEA. REV.,1980)
+!-------------------------------------------------------------------
+       do 260 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        pnk(i)=p(i,nk(i))
+        qsnk(i)=qs(i,nk(i))
+!c
+        rh(i)=qnk(i)/qsnk(i)
+        rh(i)=min(1.0,rh(i))
+        chi(i)=tnk(i)/(1669.0-122.0*rh(i)-tnk(i))
+        plcl(i)=pnk(i)*(rh(i)**chi(i))
+        if(((plcl(i).lt.200.0).or.(plcl(i).ge.2000.0))                               &
+       &   .and.(iflag(i).eq.0))iflag(i)=8
+ 260   continue
+!-------------------------------------------------------------------
+! --- Calculate first level above lcl (=icb)
+!-------------------------------------------------------------------
+      do 270 i=1,len
+       icb(i)=nlm
+ 270  continue
+!c
+      do 290 k=minorig,nl
+        do 280 i=1,len
+          if((k.ge.(nk(i)+1)).and.(p(i,k).lt.plcl(i)))                               &
+       &    icb(i)=min(icb(i),k)
+ 280    continue
+ 290  continue
+!c
+      do 300 i=1,len
+        if((icb(i).ge.nlm).and.(iflag(i).eq.0))iflag(i)=9
+ 300  continue
+!c
+!c Compute icbmax.
+!c
+      icbmax=2
+      do 310 i=1,len
+        icbmax=max(icbmax,icb(i))
+ 310  continue
+
+      return
+      end SUBROUTINE cv_feed
+
+      SUBROUTINE cv_undilute1(len,nd,t,q,qs,gz,p,nk,icb,icbmax                       &
+       &                       ,tp,tvp,clw)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+!c inputs:
+      integer len, nd
+      integer nk(len), icb(len), icbmax
+      real t(len,nd), q(len,nd), qs(len,nd), gz(len,nd)
+      real p(len,nd)
+
+!c outputs:
+      real tp(len,nd), tvp(len,nd), clw(len,nd)
+
+!c local variables:
+      integer i, k
+      real tg, qg, alv, s, ahg, tc, denom, es, rg
+      real ah0(len), cpp(len)
+      real tnk(len), qnk(len), gznk(len), ticb(len), gzicb(len)
+
+!-------------------------------------------------------------------
+! --- Calculates the lifted parcel virtual temperature at nk,
+! --- the actual temperature, and the adiabatic
+! --- liquid water content. The procedure is to solve the equation.
+!     cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!-------------------------------------------------------------------
+
+      do 320 i=1,len
+        tnk(i)=t(i,nk(i))
+        qnk(i)=q(i,nk(i))
+        gznk(i)=gz(i,nk(i))
+        ticb(i)=t(i,icb(i))
+        gzicb(i)=gz(i,icb(i))
+ 320  continue
+!c
+!c   ***  Calculate certain parcel quantities, including static energy   ***
+!c
+      do 330 i=1,len
+        ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)                                    &
+       &         +qnk(i)*(lv0-clmcpv*(tnk(i)-273.15))+gznk(i)
+        cpp(i)=cpd*(1.-qnk(i))+qnk(i)*cpv
+ 330  continue
+!c
+!c   ***   Calculate lifted parcel quantities below cloud base   ***
+!c
+        do 350 k=minorig,icbmax-1
+          do 340 i=1,len
+           tp(i,k)=tnk(i)-(gz(i,k)-gznk(i))/cpp(i)
+           tvp(i,k)=tp(i,k)*(1.+qnk(i)*epsi)
+  340     continue
+  350   continue
+!c
+!c    ***  Find lifted parcel quantities above cloud base    ***
+!c
+        do 360 i=1,len
+         tg=ticb(i)
+         qg=qs(i,icb(i))
+         alv=lv0-clmcpv*(ticb(i)-t0)
+!c
+!c First iteration.
+!c
+          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-t0
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          endif
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+!c
+!c Second iteration.
+!c
+          s=cpd+alv*alv*qg/(rrv*ticb(i)*ticb(i))
+          s=1./s
+          ahg=cpd*tg+(cl-cpd)*qnk(i)*ticb(i)+alv*qg+gzicb(i)
+          tg=tg+s*(ah0(i)-ahg)
+          tg=max(tg,35.0)
+          tc=tg-t0
+          denom=243.5+tc
+          if(tc.ge.0.0)then
+           es=6.112*exp(17.67*tc/denom)
+          else
+           es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+          end if
+          qg=eps*es/(p(i,icb(i))-es*(1.-eps))
+!c
+         alv=lv0-clmcpv*(ticb(i)-273.15)
+         tp(i,icb(i))=(ah0(i)-(cl-cpd)*qnk(i)*ticb(i)                                &
+       &   -gz(i,icb(i))-alv*qg)/cpd
+         clw(i,icb(i))=qnk(i)-qg
+         clw(i,icb(i))=max(0.0,clw(i,icb(i)))
+         rg=qg/(1.-qnk(i))
+         tvp(i,icb(i))=tp(i,icb(i))*(1.+rg*epsi)
+  360   continue
+!c
+      do 380 k=minorig,icbmax
+       do 370 i=1,len
+         tvp(i,k)=tvp(i,k)-tp(i,k)*qnk(i)
+ 370   continue
+ 380  continue
+!c
+      return
+      end SUBROUTINE cv_undilute1
+
+      SUBROUTINE cv_trigger(len,nd,icb,cbmf,tv,tvp,iflag)
+      implicit none
+
+!-------------------------------------------------------------------
+! --- Test for instability.
+! --- If there was no convection at last time step and parcel
+! --- is stable at icb, then set iflag to 4.
+!-------------------------------------------------------------------
+ 
+#include "cvparam.h"
+
+!c inputs:
+       integer len, nd, icb(len)
+       real cbmf(len), tv(len,nd), tvp(len,nd)
+
+!c outputs:
+       integer iflag(len) ! also an input
+
+!c local variables:
+       integer i
+
+
+      do 390 i=1,len
+        if((cbmf(i).eq.0.0) .and.(iflag(i).eq.0).and.                                &
+       &  (tvp(i,icb(i)).le.(tv(i,icb(i))-dtmax)))iflag(i)=4
+ 390  continue
+ 
+      return
+      end SUBROUTINE cv_trigger
+
+      SUBROUTINE cv_compress( len,nloc,ncum,nd                                       &
+       &   ,iflag1,nk1,icb1                                                          &
+       &   ,cbmf1,plcl1,tnk1,qnk1,gznk1                                              &
+       &   ,t1,q1,qs1,u1,v1,gz1                                                      &
+       &   ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1                                     &
+       &   ,iflag,nk,icb                                                             &
+       &   ,cbmf,plcl,tnk,qnk,gznk                                                   &
+       &   ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw                                &
+       &   ,dph          )
+      implicit none
+
+#include "cvparam.h"
+
+!c inputs:
+      integer len,ncum,nd,nloc
+      integer iflag1(len),nk1(len),icb1(len)
+      real cbmf1(len),plcl1(len),tnk1(len),qnk1(len),gznk1(len)
+      real t1(len,nd),q1(len,nd),qs1(len,nd),u1(len,nd),v1(len,nd)
+      real gz1(len,nd),h1(len,nd),lv1(len,nd),cpn1(len,nd)
+      real p1(len,nd),ph1(len,nd+1),tv1(len,nd),tp1(len,nd)
+      real tvp1(len,nd),clw1(len,nd)
+
+!c outputs:
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      real cbmf(nloc),plcl(nloc),tnk(nloc),qnk(nloc),gznk(nloc)
+      real t(nloc,nd),q(nloc,nd),qs(nloc,nd),u(nloc,nd),v(nloc,nd)
+      real gz(nloc,nd),h(nloc,nd),lv(nloc,nd),cpn(nloc,nd)
+      real p(nloc,nd),ph(nloc,nd+1),tv(nloc,nd),tp(nloc,nd)
+      real tvp(nloc,nd),clw(nloc,nd)
+      real dph(nloc,nd)
+
+!c local variables:
+      integer i,k,nn
+      CHARACTER (LEN=20) :: modname='cv_compress'
+      CHARACTER (LEN=80) :: abort_message
+
+      include 'iniprint.h'
+
+
+      do 110 k=1,nl+1
+       nn=0
+      do 100 i=1,len
+      if(iflag1(i).eq.0)then
+        nn=nn+1
+        t(nn,k)=t1(i,k)
+        q(nn,k)=q1(i,k)
+        qs(nn,k)=qs1(i,k)
+        u(nn,k)=u1(i,k)
+        v(nn,k)=v1(i,k)
+        gz(nn,k)=gz1(i,k)
+        h(nn,k)=h1(i,k)
+        lv(nn,k)=lv1(i,k)
+        cpn(nn,k)=cpn1(i,k)
+        p(nn,k)=p1(i,k)
+        ph(nn,k)=ph1(i,k)
+        tv(nn,k)=tv1(i,k)
+        tp(nn,k)=tp1(i,k)
+        tvp(nn,k)=tvp1(i,k)
+        clw(nn,k)=clw1(i,k)
+      endif
+ 100    continue
+ 110  continue
+
+      if (nn.ne.ncum) then
+         write(lunout,*)'strange! nn not equal to ncum: ',nn,ncum
+         abort_message = ''
+         CALL abort_gcm (modname,abort_message,1)
+      endif
+
+      nn=0
+      do 150 i=1,len
+      if(iflag1(i).eq.0)then
+      nn=nn+1
+      cbmf(nn)=cbmf1(i)
+      plcl(nn)=plcl1(i)
+      tnk(nn)=tnk1(i)
+      qnk(nn)=qnk1(i)
+      gznk(nn)=gznk1(i)
+      nk(nn)=nk1(i)
+      icb(nn)=icb1(i)
+      iflag(nn)=iflag1(i)
+      endif
+ 150  continue
+
+      do 170 k=1,nl
+       do 160 i=1,ncum
+        dph(i,k)=ph(i,k)-ph(i,k+1)
+ 160   continue
+ 170  continue
+
+      return
+      end SUBROUTINE cv_compress
+
+      SUBROUTINE cv_undilute2(nloc,ncum,nd,icb,nk                                    &
+       &                       ,tnk,qnk,gznk,t,q,qs,gz                               &
+       &                       ,p,dph,h,tv,lv                                        &
+       &                       ,inb,inb1,tp,tvp,clw,hp,ep,sigp,frac)
+      implicit none
+
+!C---------------------------------------------------------------------
+!C Purpose:
+!C     FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!C     &
+!C     COMPUTE THE PRECIPITATION EFFICIENCIES AND THE 
+!C     FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+!C     &
+!C     FIND THE LEVEL OF NEUTRAL BUOYANCY
+!C---------------------------------------------------------------------
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+!c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), nk(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), gz(nloc,nd)
+      real p(nloc,nd), dph(nloc,nd)
+      real tnk(nloc), qnk(nloc), gznk(nloc)
+      real lv(nloc,nd), tv(nloc,nd), h(nloc,nd)
+
+!c outputs:
+      integer inb(nloc), inb1(nloc)
+      real tp(nloc,nd), tvp(nloc,nd), clw(nloc,nd)
+      real ep(nloc,nd), sigp(nloc,nd), hp(nloc,nd)
+      real frac(nloc)
+
+!c local variables:
+      integer i, k
+      real tg,qg,ahg,alv,s,tc,es,denom,rg,tca,elacrit
+      real by, defrac
+      real ah0(nloc), cape(nloc), capem(nloc), byp(nloc)
+      logical lcape(nloc)
+
+!=====================================================================
+! --- SOME INITIALIZATIONS
+!=====================================================================
+
+      do 170 k=1,nl
+      do 160 i=1,ncum
+       ep(i,k)=0.0
+       sigp(i,k)=sigs
+ 160  continue
+ 170  continue
+
+!=====================================================================
+! --- FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+!=====================================================================
+!c
+!c ---       The procedure is to solve the equation.
+!c              cp*tp+L*qp+phi=cp*tnk+L*qnk+gznk.
+!c
+!c   ***  Calculate certain parcel quantities, including static energy   ***
+!c
+!c
+      do 240 i=1,ncum
+         ah0(i)=(cpd*(1.-qnk(i))+cl*qnk(i))*tnk(i)                                   &
+       &         +qnk(i)*(lv0-clmcpv*(tnk(i)-t0))+gznk(i)
+ 240  continue
+!c
+!c
+!c    ***  Find lifted parcel quantities above cloud base    ***
+!c
+!c
+	do 300 k=minorig+1,nl
+	  do 290 i=1,ncum
+	    if(k.ge.(icb(i)+1))then
+	      tg=t(i,k)
+	      qg=qs(i,k)
+	      alv=lv0-clmcpv*(t(i,k)-t0)
+!c
+!c First iteration.
+!c
+	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-t0
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+	       else
+			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+!c
+!c Second iteration.
+!c
+	       s=cpd+alv*alv*qg/(rrv*t(i,k)*t(i,k))
+	       s=1./s
+	       ahg=cpd*tg+(cl-cpd)*qnk(i)*t(i,k)+alv*qg+gz(i,k)
+	       tg=tg+s*(ah0(i)-ahg)
+	       tg=max(tg,35.0)
+	       tc=tg-t0
+	       denom=243.5+tc
+	       if(tc.ge.0.0)then
+			es=6.112*exp(17.67*tc/denom)
+	       else
+			es=exp(23.33086-6111.72784/tg+0.15215*log(tg))
+	       endif
+			qg=eps*es/(p(i,k)-es*(1.-eps))
+!c
+	       alv=lv0-clmcpv*(t(i,k)-t0)
+!c      print*,'cpd dans convect2 ',cpd
+!c      print*,'tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd'
+!c      print*,tp(i,k),ah0(i),cl,cpd,qnk(i),t(i,k),gz(i,k),alv,qg,cpd
+        tp(i,k)=(ah0(i)-(cl-cpd)*qnk(i)*t(i,k)-gz(i,k)-alv*qg)/cpd
+!c              if (.not.cpd.gt.1000.) then
+!c                  print*,'CPD=',cpd
+!c                  stop
+!c              endif
+               clw(i,k)=qnk(i)-qg
+               clw(i,k)=max(0.0,clw(i,k))
+               rg=qg/(1.-qnk(i))
+               tvp(i,k)=tp(i,k)*(1.+rg*epsi)
+            endif
+  290     continue
+  300   continue
+!c
+!=====================================================================
+! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF
+! --- PRECIPITATION FALLING OUTSIDE OF CLOUD
+! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I)
+!=====================================================================
+!c
+      do 320 k=minorig+1,nl
+        do 310 i=1,ncum
+          if(k.ge.(nk(i)+1))then
+            tca=tp(i,k)-t0
+            if(tca.ge.0.0)then
+              elacrit=elcrit
+            else
+              elacrit=elcrit*(1.0-tca/tlcrit)
+            endif
+            elacrit=max(elacrit,0.0)
+            ep(i,k)=1.0-elacrit/max(clw(i,k),1.0e-8)
+            ep(i,k)=max(ep(i,k),0.0 )
+            ep(i,k)=min(ep(i,k),1.0 )
+            sigp(i,k)=sigs
+          endif
+ 310    continue
+ 320  continue
+!c
+!=====================================================================
+! --- CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL
+! --- VIRTUAL TEMPERATURE
+!=====================================================================
+!c
+      do 340 k=minorig+1,nl
+        do 330 i=1,ncum
+        if(k.ge.(icb(i)+1))then
+          tvp(i,k)=tvp(i,k)*(1.0-qnk(i)+ep(i,k)*clw(i,k))
+!c         print*,'i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)'
+!c         print*, i,k,tvp(i,k),qnk(i),ep(i,k),clw(i,k)
+        endif
+ 330    continue
+ 340  continue
+      do 350 i=1,ncum
+       tvp(i,nlp)=tvp(i,nl)-(gz(i,nlp)-gz(i,nl))/cpd
+ 350  continue
+!c
+!c=====================================================================
+!c  --- FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S
+!c  --- HIGHEST LEVEL OF NEUTRAL BUOYANCY
+!c  --- AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB)
+!c=====================================================================
+!c
+      do 510 i=1,ncum
+        cape(i)=0.0
+        capem(i)=0.0
+        inb(i)=icb(i)+1
+        inb1(i)=inb(i)
+ 510  continue
+!c
+!c Originial Code
+!c
+!c     do 530 k=minorig+1,nl-1
+!c       do 520 i=1,ncum
+!c         if(k.ge.(icb(i)+1))then
+!c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+!c           byp=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+!c           cape(i)=cape(i)+by
+!c           if(by.ge.0.0)inb1(i)=k+1
+!c           if(cape(i).gt.0.0)then
+!c             inb(i)=k+1
+!c             capem(i)=cape(i)
+!c           endif
+!c         endif
+!c520    continue
+!c530  continue
+!c     do 540 i=1,ncum
+!c         byp=(tvp(i,nl)-tv(i,nl))*dph(i,nl)/p(i,nl)
+!c         cape(i)=capem(i)+byp
+!c         defrac=capem(i)-cape(i)
+!c         defrac=max(defrac,0.001)
+!c         frac(i)=-cape(i)/defrac
+!c         frac(i)=min(frac(i),1.0)
+!c         frac(i)=max(frac(i),0.0)
+!c540   continue
+!c
+!c K Emanuel fix
+!c
+!c     call zilch(byp,ncum)
+!c     do 530 k=minorig+1,nl-1
+!c       do 520 i=1,ncum
+!c         if(k.ge.(icb(i)+1))then
+!c           by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+!c           cape(i)=cape(i)+by
+!c           if(by.ge.0.0)inb1(i)=k+1
+!c           if(cape(i).gt.0.0)then
+!c             inb(i)=k+1
+!c             capem(i)=cape(i)
+!c             byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+!c           endif
+!c         endif
+!c520    continue
+!c530  continue
+!c     do 540 i=1,ncum
+!c         inb(i)=max(inb(i),inb1(i))
+!c         cape(i)=capem(i)+byp(i)
+!c         defrac=capem(i)-cape(i)
+!c         defrac=max(defrac,0.001)
+!c         frac(i)=-cape(i)/defrac
+!c         frac(i)=min(frac(i),1.0)
+!c         frac(i)=max(frac(i),0.0)
+!c540   continue
+!c
+!c J Teixeira fix
+!c
+      call zilch(byp,ncum)
+      do 515 i=1,ncum
+        lcape(i)=.true.
+ 515  continue
+      do 530 k=minorig+1,nl-1
+        do 520 i=1,ncum
+          if(cape(i).lt.0.0)lcape(i)=.false.
+          if((k.ge.(icb(i)+1)).and.lcape(i))then
+            by=(tvp(i,k)-tv(i,k))*dph(i,k)/p(i,k)
+            byp(i)=(tvp(i,k+1)-tv(i,k+1))*dph(i,k+1)/p(i,k+1)
+            cape(i)=cape(i)+by
+            if(by.ge.0.0)inb1(i)=k+1
+            if(cape(i).gt.0.0)then
+              inb(i)=k+1
+              capem(i)=cape(i)
+            endif
+          endif
+ 520    continue
+ 530  continue
+      do 540 i=1,ncum
+          cape(i)=capem(i)+byp(i)
+          defrac=capem(i)-cape(i)
+          defrac=max(defrac,0.001)
+          frac(i)=-cape(i)/defrac
+          frac(i)=min(frac(i),1.0)
+          frac(i)=max(frac(i),0.0)
+ 540  continue
+!c
+!c=====================================================================
+!c ---   CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL
+!c=====================================================================
+!c
+!c initialization:
+      do i=1,ncum*nlp
+       hp(i,1)=h(i,1)
+      enddo
+
+      do 600 k=minorig+1,nl
+        do 590 i=1,ncum
+        if((k.ge.icb(i)).and.(k.le.inb(i)))then
+          hp(i,k)=h(i,nk(i))+(lv(i,k)+(cpd-cpv)*t(i,k))*ep(i,k)*clw(i,k)
+        endif
+ 590    continue
+ 600  continue
+!c
+        return
+        end SUBROUTINE cv_undilute2
+!c
+      SUBROUTINE cv_closure(nloc,ncum,nd,nk,icb                                      &
+       &                     ,tv,tvp,p,ph,dph,plcl,cpn                               &
+       &                     ,iflag,cbmf)
+      implicit none
+
+!c inputs:
+      integer ncum, nd, nloc
+      integer nk(nloc), icb(nloc)
+      real tv(nloc,nd), tvp(nloc,nd), p(nloc,nd), dph(nloc,nd)
+      real ph(nloc,nd+1) ! caution nd instead ndp1 to be consistent...
+      real plcl(nloc), cpn(nloc,nd)
+
+!c outputs:
+      integer iflag(nloc)
+      real cbmf(nloc) ! also an input
+
+!c local variables:
+      integer i, k, icbmax
+      real dtpbl(nloc), dtmin(nloc), tvpplcl(nloc), tvaplcl(nloc)
+      real work(nloc)
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+!c-------------------------------------------------------------------
+!c Compute icbmax. 
+!c-------------------------------------------------------------------
+
+      icbmax=2
+      do 230 i=1,ncum
+       icbmax=max(icbmax,icb(i))
+ 230  continue
+
+!c=====================================================================
+!c ---  CALCULATE CLOUD BASE MASS FLUX 
+!c=====================================================================
+!c
+!c tvpplcl = parcel temperature lifted adiabatically from level
+!c           icb-1 to the LCL.
+!c tvaplcl = virtual temperature at the LCL.
+!c
+      do 610 i=1,ncum
+        dtpbl(i)=0.0
+        tvpplcl(i)=tvp(i,icb(i)-1)                                                   &
+       &  -rrd*tvp(i,icb(i)-1)*(p(i,icb(i)-1)-plcl(i))                               &
+       &  /(cpn(i,icb(i)-1)*p(i,icb(i)-1))
+        tvaplcl(i)=tv(i,icb(i))                                                      &
+       &  +(tvp(i,icb(i))-tvp(i,icb(i)+1))*(plcl(i)-p(i,icb(i)))                     &
+       &  /(p(i,icb(i))-p(i,icb(i)+1))
+ 610  continue
+
+!c-------------------------------------------------------------------
+!c --- Interpolate difference between lifted parcel and
+!c --- environmental temperatures to lifted condensation level
+!c-------------------------------------------------------------------
+!c
+!c dtpbl = average of tvp-tv in the PBL (k=nk to icb-1).
+!c
+      do 630 k=minorig,icbmax
+        do 620 i=1,ncum
+        if((k.ge.nk(i)).and.(k.le.(icb(i)-1)))then
+          dtpbl(i)=dtpbl(i)+(tvp(i,k)-tv(i,k))*dph(i,k)
+        endif
+ 620    continue
+ 630  continue
+      do 640 i=1,ncum
+        dtpbl(i)=dtpbl(i)/(ph(i,nk(i))-ph(i,icb(i)))
+        dtmin(i)=tvpplcl(i)-tvaplcl(i)+dtmax+dtpbl(i)
+ 640  continue
+!c
+!c-------------------------------------------------------------------
+!c --- Adjust cloud base mass flux
+!c-------------------------------------------------------------------
+!c
+      do 650 i=1,ncum
+       work(i)=cbmf(i)
+       cbmf(i)=max(0.0,(1.0-damp)*cbmf(i)+0.1*alpha*dtmin(i))
+       if((work(i).eq.0.0).and.(cbmf(i).eq.0.0))then
+         iflag(i)=3
+       endif
+ 650  continue
+
+       return
+       end SUBROUTINE cv_closure
+
+      SUBROUTINE cv_mixing(nloc,ncum,nd,icb,nk,inb,inb1                              &
+       &                    ,ph,t,q,qs,u,v,h,lv,qnk                                  &
+       &                    ,hp,tv,tvp,ep,clw,cbmf                                   &
+       &                    ,m,ment,qent,uent,vent,nent,sij,elij)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+!c inputs:
+      integer ncum, nd, nloc
+      integer icb(nloc), inb(nloc), inb1(nloc), nk(nloc)
+      real cbmf(nloc), qnk(nloc)
+      real ph(nloc,nd+1)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd), lv(nloc,nd)
+      real u(nloc,nd), v(nloc,nd), h(nloc,nd), hp(nloc,nd)
+      real tv(nloc,nd), tvp(nloc,nd), ep(nloc,nd), clw(nloc,nd)
+
+!c outputs:
+      integer nent(nloc,nd)
+      real m(nloc,nd), ment(nloc,nd,nd), qent(nloc,nd,nd)
+      real uent(nloc,nd,nd), vent(nloc,nd,nd)
+      real sij(nloc,nd,nd), elij(nloc,nd,nd)
+
+!c local variables:
+      integer i, j, k, ij
+      integer num1, num2
+      real dbo, qti, bf2, anum, denom, dei, altem, cwat, stemp
+      real alt, qp1, smid, sjmin, sjmax, delp, delm
+      real work(nloc), asij(nloc), smin(nloc), scrit(nloc)
+      real bsum(nloc,nd)
+      logical lwork(nloc)
+
+!c=====================================================================
+!c --- INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS
+!c=====================================================================
+!c
+        do 360 i=1,ncum*nlp
+          nent(i,1)=0
+          m(i,1)=0.0
+ 360    continue
+!c
+      do 400 k=1,nlp
+       do 390 j=1,nlp
+          do 385 i=1,ncum
+            qent(i,k,j)=q(i,j)
+            uent(i,k,j)=u(i,j)
+            vent(i,k,j)=v(i,j)
+            elij(i,k,j)=0.0
+            ment(i,k,j)=0.0
+            sij(i,k,j)=0.0
+ 385      continue
+ 390    continue
+ 400  continue
+!c
+!c-------------------------------------------------------------------
+!c --- Calculate rates of mixing,  m(i)
+!c-------------------------------------------------------------------
+!c
+      call zilch(work,ncum)
+!c
+      do 670 j=minorig+1,nl
+        do 660 i=1,ncum
+          if((j.ge.(icb(i)+1)).and.(j.le.inb(i)))then
+             k=min(j,inb1(i))
+             dbo=abs(tv(i,k+1)-tvp(i,k+1)-tv(i,k-1)+tvp(i,k-1))                      &
+       &       +entp*0.04*(ph(i,k)-ph(i,k+1))
+             work(i)=work(i)+dbo
+             m(i,j)=cbmf(i)*dbo
+          endif
+ 660    continue
+ 670  continue
+      do 690 k=minorig+1,nl
+        do 680 i=1,ncum
+          if((k.ge.(icb(i)+1)).and.(k.le.inb(i)))then
+            m(i,k)=m(i,k)/work(i)
+          endif
+ 680    continue
+ 690  continue
+!c
+!c
+!c=====================================================================
+!c --- CALCULATE ENTRAINED AIR MASS FLUX (ment), TOTAL WATER MIXING
+!c --- RATIO (QENT), TOTAL CONDENSED WATER (elij), AND MIXING
+!c --- FRACTION (sij)
+!c=====================================================================
+!c
+!c
+       do 750 i=minorig+1,nl
+         do 710 j=minorig+1,nl
+           do 700 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(j.ge.icb(ij))                                &
+       &         .and.(i.le.inb(ij)).and.(j.le.inb(ij)))then
+               qti=qnk(ij)-ep(ij,i)*clw(ij,i)
+               bf2=1.+lv(ij,j)*lv(ij,j)*qs(ij,j)                                     &
+       &         /(rrv*t(ij,j)*t(ij,j)*cpd)
+               anum=h(ij,j)-hp(ij,i)+(cpv-cpd)*t(ij,j)*(qti-q(ij,j))
+               denom=h(ij,i)-hp(ij,i)+(cpd-cpv)*(q(ij,i)-qti)*t(ij,j)
+               dei=denom
+               if(abs(dei).lt.0.01)dei=0.01
+               sij(ij,i,j)=anum/dei
+               sij(ij,i,i)=1.0
+               altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+               altem=altem/bf2
+               cwat=clw(ij,j)*(1.-ep(ij,j))
+               stemp=sij(ij,i,j)
+               if((stemp.lt.0.0.or.stemp.gt.1.0.or.                                  &
+       &           altem.gt.cwat).and.j.gt.i)then
+                 anum=anum-lv(ij,j)*(qti-qs(ij,j)-cwat*bf2)
+                 denom=denom+lv(ij,j)*(q(ij,i)-qti)
+                 if(abs(denom).lt.0.01)denom=0.01
+                 sij(ij,i,j)=anum/denom
+                 altem=sij(ij,i,j)*q(ij,i)+(1.-sij(ij,i,j))*qti-qs(ij,j)
+                 altem=altem-(bf2-1.)*cwat
+               endif
+               if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                 qent(ij,i,j)=sij(ij,i,j)*q(ij,i)                                    &
+       &                        +(1.-sij(ij,i,j))*qti
+                 uent(ij,i,j)=sij(ij,i,j)*u(ij,i)                                    &
+       &                        +(1.-sij(ij,i,j))*u(ij,nk(ij))
+                 vent(ij,i,j)=sij(ij,i,j)*v(ij,i)                                    &
+       &                        +(1.-sij(ij,i,j))*v(ij,nk(ij))
+                 elij(ij,i,j)=altem
+                 elij(ij,i,j)=max(0.0,elij(ij,i,j))
+                 ment(ij,i,j)=m(ij,i)/(1.-sij(ij,i,j))
+                 nent(ij,i)=nent(ij,i)+1
+               endif
+             sij(ij,i,j)=max(0.0,sij(ij,i,j))
+             sij(ij,i,j)=min(1.0,sij(ij,i,j))
+             endif
+  700      continue
+  710    continue
+!c
+!c   ***   If no air can entrain at level i assume that updraft detrains  ***
+!c   ***   at that level and calculate detrained air flux and properties  ***
+!c
+           do 740 ij=1,ncum
+             if((i.ge.(icb(ij)+1)).and.(i.le.inb(ij))                                &
+       &       .and.(nent(ij,i).eq.0))then
+               ment(ij,i,i)=m(ij,i)
+               qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+               uent(ij,i,i)=u(ij,nk(ij))
+               vent(ij,i,i)=v(ij,nk(ij))
+               elij(ij,i,i)=clw(ij,i)
+               sij(ij,i,i)=1.0
+             endif
+ 740       continue
+ 750   continue
+!c
+      do 770 i=1,ncum
+        sij(i,inb(i),inb(i))=1.0
+ 770  continue
+!c
+!c=====================================================================
+!c   ---  NORMALIZE ENTRAINED AIR MASS FLUXES
+!c   ---  TO REPRESENT EQUAL PROBABILITIES OF MIXING
+!c=====================================================================
+!c
+       call zilch(bsum,ncum*nlp)
+       do 780 ij=1,ncum
+         lwork(ij)=.false.
+ 780   continue
+       do 789 i=minorig+1,nl
+!c
+         num1=0
+         do 779 ij=1,ncum
+           if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))num1=num1+1
+ 779     continue
+         if(num1.le.0)go to 789
+!c
+           do 781 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij)))then
+                lwork(ij)=(nent(ij,i).ne.0)
+                qp1=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                anum=h(ij,i)-hp(ij,i)-lv(ij,i)*(qp1-qs(ij,i))
+                denom=h(ij,i)-hp(ij,i)+lv(ij,i)*(q(ij,i)-qp1)
+                if(abs(denom).lt.0.01)denom=0.01
+                scrit(ij)=anum/denom
+                alt=qp1-qs(ij,i)+scrit(ij)*(q(ij,i)-qp1)
+                if(scrit(ij).lt.0.0.or.alt.lt.0.0)scrit(ij)=1.0
+                asij(ij)=0.0
+                smin(ij)=1.0
+             endif
+ 781       continue
+         do 783 j=minorig,nl
+!c
+         num2=0
+         do 778 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))                                  &
+       &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij))                                &
+       &       .and.lwork(ij))num2=num2+1
+ 778     continue
+         if(num2.le.0)go to 783
+!c
+           do 782 ij=1,ncum
+             if((i.ge.icb(ij)+1).and.(i.le.inb(ij))                                  &
+       &       .and.(j.ge.icb(ij)).and.(j.le.inb(ij)).and.lwork(ij))then
+                  if(sij(ij,i,j).gt.0.0.and.sij(ij,i,j).lt.0.9)then
+                    if(j.gt.i)then
+                      smid=min(sij(ij,i,j),scrit(ij))
+                      sjmax=smid
+                      sjmin=smid
+                        if(smid.lt.smin(ij)                                          &
+       &                  .and.sij(ij,i,j+1).lt.smid)then
+                          smin(ij)=smid
+                          sjmax=min(sij(ij,i,j+1),sij(ij,i,j),scrit(ij))
+                          sjmin=max(sij(ij,i,j-1),sij(ij,i,j))
+                          sjmin=min(sjmin,scrit(ij))
+                        endif
+                    else
+                      sjmax=max(sij(ij,i,j+1),scrit(ij))
+                      smid=max(sij(ij,i,j),scrit(ij))
+                      sjmin=0.0
+                      if(j.gt.1)sjmin=sij(ij,i,j-1)
+                      sjmin=max(sjmin,scrit(ij))
+                    endif
+                    delp=abs(sjmax-smid)
+                    delm=abs(sjmin-smid)
+                    asij(ij)=asij(ij)+(delp+delm)                                    &
+       &                           *(ph(ij,j)-ph(ij,j+1))
+                    ment(ij,i,j)=ment(ij,i,j)*(delp+delm)                            &
+       &                           *(ph(ij,j)-ph(ij,j+1))
+                  endif
+              endif
+  782    continue
+  783    continue
+            do 784 ij=1,ncum
+            if((i.ge.icb(ij)+1).and.(i.le.inb(ij)).and.lwork(ij))then
+               asij(ij)=max(1.0e-21,asij(ij))
+               asij(ij)=1.0/asij(ij)
+               bsum(ij,i)=0.0
+            endif
+ 784        continue
+            do 786 j=minorig,nl+1
+              do 785 ij=1,ncum
+                if((i.ge.icb(ij)+1).and.(i.le.inb(ij))                               &
+       &          .and.(j.ge.icb(ij)).and.(j.le.inb(ij))                             &
+       &          .and.lwork(ij))then
+                   ment(ij,i,j)=ment(ij,i,j)*asij(ij)
+                   bsum(ij,i)=bsum(ij,i)+ment(ij,i,j)
+                endif
+ 785     continue
+ 786     continue
+             do 787 ij=1,ncum
+               if((i.ge.icb(ij)+1).and.(i.le.inb(ij))                                &
+       &         .and.(bsum(ij,i).lt.1.0e-18).and.lwork(ij))then
+                 nent(ij,i)=0
+                 ment(ij,i,i)=m(ij,i)
+                 qent(ij,i,i)=q(ij,nk(ij))-ep(ij,i)*clw(ij,i)
+                 uent(ij,i,i)=u(ij,nk(ij))
+                 vent(ij,i,i)=v(ij,nk(ij))
+                 elij(ij,i,i)=clw(ij,i)
+                 sij(ij,i,i)=1.0
+               endif
+  787        continue
+  789  continue
+!c
+       return
+       end SUBROUTINE cv_mixing
+
+      SUBROUTINE cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph                        &
+       &                  ,h,lv,ep,sigp,clw,m,ment,elij                              &
+       &                  ,iflag,mp,qp,up,vp,wt,water,evap)
+      implicit none
+
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+!c inputs:
+      integer ncum, nd, nloc
+      integer inb(nloc)
+      real t(nloc,nd), q(nloc,nd), qs(nloc,nd)
+      real gz(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd)
+      real lv(nloc,nd), ep(nloc,nd), sigp(nloc,nd), clw(nloc,nd)
+      real m(nloc,nd), ment(nloc,nd,nd), elij(nloc,nd,nd)
+
+!c outputs:
+      integer iflag(nloc) ! also an input
+      real mp(nloc,nd), qp(nloc,nd), up(nloc,nd), vp(nloc,nd)
+      real water(nloc,nd), evap(nloc,nd), wt(nloc,nd)
+
+!c local variables:
+      integer i,j,k,ij,num1
+      integer jtt(nloc)
+      real awat, coeff, qsm, afac, sigt, b6, c6, revap
+      real dhdp, fac, qstm, rat
+      real wdtrain(nloc)
+      logical lwork(nloc)
+
+!c=====================================================================
+!c --- PRECIPITATING DOWNDRAFT CALCULATION
+!c=====================================================================
+!c
+!c Initializations:
+!c
+         do i = 1, ncum
+         do k = 1, nl+1
+          wt(i,k) = omtsnow
+          mp(i,k) = 0.0
+          evap(i,k) = 0.0
+          water(i,k) = 0.0
+         enddo
+         enddo
+
+         do 420 i=1,ncum
+          qp(i,1)=q(i,1)
+          up(i,1)=u(i,1)
+          vp(i,1)=v(i,1)
+ 420     continue
+
+         do 440 k=2,nl+1
+         do 430 i=1,ncum
+          qp(i,k)=q(i,k-1)
+          up(i,k)=u(i,k-1)
+          vp(i,k)=v(i,k-1)
+ 430     continue
+ 440     continue
+
+
+!c   ***  Check whether ep(inb)=0, if so, skip precipitating    ***
+!c   ***             downdraft calculation                      ***
+!c
+!c
+!c   ***  Integrate liquid water equation to find condensed water   ***
+!c   ***                and condensed water flux                    ***
+!c
+!c
+      do 890 i=1,ncum
+        jtt(i)=2
+        if(ep(i,inb(i)).le.0.0001)iflag(i)=2
+        if(iflag(i).eq.0)then
+          lwork(i)=.true.
+        else
+          lwork(i)=.false.
+        endif
+ 890  continue
+!c
+!c    ***                    Begin downdraft loop                    ***
+!c
+!c
+        call zilch(wdtrain,ncum)
+        do 899 i=nl+1,1,-1
+!c
+          num1=0
+          do 879 ij=1,ncum
+            if((i.le.inb(ij)).and.lwork(ij))num1=num1+1
+ 879      continue
+          if(num1.le.0)go to 899
+!c
+!c
+!c    ***        Calculate detrained precipitation             ***
+!c
+          do 891 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            wdtrain(ij)=g*ep(ij,i)*m(ij,i)*clw(ij,i)
+            endif
+ 891      continue
+!c
+          if(i.gt.1)then
+            do 893 j=1,i-1
+              do 892 ij=1,ncum
+                if((i.le.inb(ij)).and.(lwork(ij)))then
+                  awat=elij(ij,j,i)-(1.-ep(ij,i))*clw(ij,i)
+                  awat=max(0.0,awat)
+                  wdtrain(ij)=wdtrain(ij)+g*awat*ment(ij,j,i)
+                endif
+ 892          continue
+ 893      continue
+          endif
+!c
+!c    ***    Find rain water and evaporation using provisional   ***
+!c    ***              estimates of qp(i)and qp(i-1)             ***
+!c
+!c
+!c  ***  Value of terminal velocity and coeffecient of evaporation for snow   ***
+!c
+          do 894 ij=1,ncum
+            if((i.le.inb(ij)).and.(lwork(ij)))then
+            coeff=coeffs
+            wt(ij,i)=omtsnow
+!c
+!c  ***  Value of terminal velocity and coeffecient of evaporation for rain   ***
+!c
+            if(t(ij,i).gt.273.0)then
+              coeff=coeffr
+              wt(ij,i)=omtrain
+            endif
+            qsm=0.5*(q(ij,i)+qp(ij,i+1))
+            afac=coeff*ph(ij,i)*(qs(ij,i)-qsm)                                       &
+       &       /(1.0e4+2.0e3*ph(ij,i)*qs(ij,i))
+            afac=max(afac,0.0)
+            sigt=sigp(ij,i)
+            sigt=max(0.0,sigt)
+            sigt=min(1.0,sigt)
+            b6=100.*(ph(ij,i)-ph(ij,i+1))*sigt*afac/wt(ij,i)
+            c6=(water(ij,i+1)*wt(ij,i+1)+wdtrain(ij)/sigd)/wt(ij,i)
+            revap=0.5*(-b6+sqrt(b6*b6+4.*c6))
+            evap(ij,i)=sigt*afac*revap
+            water(ij,i)=revap*revap
+!c
+!c    ***  Calculate precipitating downdraft mass flux under     ***
+!c    ***              hydrostatic approximation                 ***
+!c
+            if(i.gt.1)then
+              dhdp=(h(ij,i)-h(ij,i-1))/(p(ij,i-1)-p(ij,i))
+              dhdp=max(dhdp,10.0)
+              mp(ij,i)=100.*ginv*lv(ij,i)*sigd*evap(ij,i)/dhdp
+              mp(ij,i)=max(mp(ij,i),0.0)
+!c
+!c   ***   Add small amount of inertia to downdraft              ***
+!c
+              fac=20.0/(ph(ij,i-1)-ph(ij,i))
+              mp(ij,i)=(fac*mp(ij,i+1)+mp(ij,i))/(1.+fac)
+!c
+!c    ***      Force mp to decrease linearly to zero                 ***
+!c    ***      between about 950 mb and the surface                  ***
+!c
+              if(p(ij,i).gt.(0.949*p(ij,1)))then
+                 jtt(ij)=max(jtt(ij),i)
+                 mp(ij,i)=mp(ij,jtt(ij))*(p(ij,1)-p(ij,i))                           &
+       &           /(p(ij,1)-p(ij,jtt(ij)))
+              endif
+            endif
+!c
+!c    ***       Find mixing ratio of precipitating downdraft     ***
+!c
+            if(i.ne.inb(ij))then
+              if(i.eq.1)then
+                qstm=qs(ij,1)
+              else
+                qstm=qs(ij,i-1)
+              endif
+              if(mp(ij,i).gt.mp(ij,i+1))then
+                 rat=mp(ij,i+1)/mp(ij,i)
+                 qp(ij,i)=qp(ij,i+1)*rat+q(ij,i)*(1.0-rat)+100.*ginv*                &
+       &             sigd*(ph(ij,i)-ph(ij,i+1))*(evap(ij,i)/mp(ij,i))
+                 up(ij,i)=up(ij,i+1)*rat+u(ij,i)*(1.-rat)
+                 vp(ij,i)=vp(ij,i+1)*rat+v(ij,i)*(1.-rat)
+               else
+                 if(mp(ij,i+1).gt.0.0)then
+                   qp(ij,i)=(gz(ij,i+1)-gz(ij,i)                                     &
+       &               +qp(ij,i+1)*(lv(ij,i+1)+t(ij,i+1)                             &
+       &               *(cl-cpd))+cpd*(t(ij,i+1)-t(ij,i)))                           &
+       &               /(lv(ij,i)+t(ij,i)*(cl-cpd))
+                   up(ij,i)=up(ij,i+1)
+                   vp(ij,i)=vp(ij,i+1)
+                 endif
+              endif
+              qp(ij,i)=min(qp(ij,i),qstm)
+              qp(ij,i)=max(qp(ij,i),0.0)
+            endif
+            endif
+ 894      continue
+ 899    continue
+!c
+        return
+        end SUBROUTINE cv_unsat
+
+      SUBROUTINE cv_yield(nloc,ncum,nd,nk,icb,inb,delt                               &
+       &             ,t,q,u,v,gz,p,ph,h,hp,lv,cpn                                    &
+       &             ,ep,clw,frac,m,mp,qp,up,vp                                      &
+       &             ,wt,water,evap                                                  &
+       &             ,ment,qent,uent,vent,nent,elij                                  &
+       &             ,tv,tvp                                                         &
+       &             ,iflag,wd,qprime,tprime                                         &
+       &             ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      implicit none
+
+#include "cvthermo.h"
+#include "cvparam.h"
+
+!c inputs
+      integer ncum, nd, nloc
+      integer nk(nloc), icb(nloc), inb(nloc)
+      integer nent(nloc,nd)
+      real delt
+      real t(nloc,nd), q(nloc,nd), u(nloc,nd), v(nloc,nd)
+      real gz(nloc,nd)
+      real p(nloc,nd), ph(nloc,nd+1), h(nloc,nd)
+      real hp(nloc,nd), lv(nloc,nd)
+      real cpn(nloc,nd), ep(nloc,nd), clw(nloc,nd), frac(nloc)
+      real m(nloc,nd), mp(nloc,nd), qp(nloc,nd)
+      real up(nloc,nd), vp(nloc,nd)
+      real wt(nloc,nd), water(nloc,nd), evap(nloc,nd)
+      real ment(nloc,nd,nd), qent(nloc,nd,nd), elij(nloc,nd,nd)
+      real uent(nloc,nd,nd), vent(nloc,nd,nd)
+      real tv(nloc,nd), tvp(nloc,nd)
+
+!c outputs
+      integer iflag(nloc)  ! also an input
+      real cbmf(nloc)      ! also an input
+      real wd(nloc), tprime(nloc), qprime(nloc)
+      real precip(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real Ma(nloc,nd)
+      real qcondc(nloc,nd)
+
+!c local variables
+      integer i,j,ij,k,num1
+      real dpinv,cpinv,awat,fqold,ftold,fuold,fvold,delti
+      real work(nloc), am(nloc),amp1(nloc),ad(nloc)
+      real ents(nloc), uav(nloc),vav(nloc),lvcp(nloc,nd)
+      real qcond(nloc,nd), nqcond(nloc,nd), wa(nloc,nd) ! cld
+      real siga(nloc,nd), ax(nloc,nd), mac(nloc,nd)     ! cld
+
+ 
+!c -- initializations:
+
+      delti = 1.0/delt
+
+      do 160 i=1,ncum
+      precip(i)=0.0
+      wd(i)=0.0
+      tprime(i)=0.0
+      qprime(i)=0.0
+       do 170 k=1,nl+1
+        ft(i,k)=0.0
+        fu(i,k)=0.0
+        fv(i,k)=0.0
+        fq(i,k)=0.0
+        lvcp(i,k)=lv(i,k)/cpn(i,k)
+        qcondc(i,k)=0.0              ! cld
+        qcond(i,k)=0.0               ! cld
+        nqcond(i,k)=0.0              ! cld
+ 170   continue
+ 160  continue
+
+!c
+!c   ***  Calculate surface precipitation in mm/day     ***
+!c
+        do 1190 i=1,ncum
+          if(iflag(i).le.1)then
+!cc            precip(i)=precip(i)+wt(i,1)*sigd*water(i,1)*3600.*24000.
+!cc     &                /(rowl*g)
+!cc            precip(i)=precip(i)*delt/86400.
+            precip(i) = wt(i,1)*sigd*water(i,1)*86400/g
+          endif
+ 1190   continue
+!c
+!c
+!c   ***  Calculate downdraft velocity scale and surface temperature and  ***
+!c   ***                    water vapor fluctuations                      ***
+!c
+      do i=1,ncum
+       wd(i)=betad*abs(mp(i,icb(i)))*0.01*rrd*t(i,icb(i))                            &
+       &           /(sigd*p(i,icb(i)))
+       qprime(i)=0.5*(qp(i,1)-q(i,1))
+       tprime(i)=lv0*qprime(i)/cpd
+      enddo
+!c
+!c   ***  Calculate tendencies of lowest level potential temperature  ***
+!c   ***                      and mixing ratio                        ***
+!c
+        do 1200 i=1,ncum
+          work(i)=0.01/(ph(i,1)-ph(i,2))
+          am(i)=0.0
+ 1200   continue
+        do 1220 k=2,nl
+          do 1210 i=1,ncum
+            if((nk(i).eq.1).and.(k.le.inb(i)).and.(nk(i).eq.1))then
+              am(i)=am(i)+m(i,k)
+            endif
+ 1210     continue
+ 1220   continue
+        do 1240 i=1,ncum
+          if((g*work(i)*am(i)).ge.delti)iflag(i)=1
+          ft(i,1)=ft(i,1)+g*work(i)*am(i)*(t(i,2)-t(i,1)                             &
+       &    +(gz(i,2)-gz(i,1))/cpn(i,1))
+          ft(i,1)=ft(i,1)-lvcp(i,1)*sigd*evap(i,1)
+          ft(i,1)=ft(i,1)+sigd*wt(i,2)*(cl-cpd)*water(i,2)*(t(i,2)                   &
+       &     -t(i,1))*work(i)/cpn(i,1)
+          fq(i,1)=fq(i,1)+g*mp(i,2)*(qp(i,2)-q(i,1))*                                &
+       &    work(i)+sigd*evap(i,1)
+          fq(i,1)=fq(i,1)+g*am(i)*(q(i,2)-q(i,1))*work(i)
+          fu(i,1)=fu(i,1)+g*work(i)*(mp(i,2)*(up(i,2)-u(i,1))                        &
+       &    +am(i)*(u(i,2)-u(i,1)))
+          fv(i,1)=fv(i,1)+g*work(i)*(mp(i,2)*(vp(i,2)-v(i,1))                        &
+       &    +am(i)*(v(i,2)-v(i,1)))
+ 1240   continue
+        do 1260 j=2,nl
+           do 1250 i=1,ncum
+             if(j.le.inb(i))then
+               fq(i,1)=fq(i,1)                                                       &
+       &                 +g*work(i)*ment(i,j,1)*(qent(i,j,1)-q(i,1))
+               fu(i,1)=fu(i,1)                                                       &
+       &                 +g*work(i)*ment(i,j,1)*(uent(i,j,1)-u(i,1))
+               fv(i,1)=fv(i,1)                                                       &
+       &                 +g*work(i)*ment(i,j,1)*(vent(i,j,1)-v(i,1))
+             endif
+ 1250      continue
+ 1260   continue
+!c
+!c   ***  Calculate tendencies of potential temperature and mixing ratio  ***
+!c   ***               at levels above the lowest level                   ***
+!c
+!c   ***  First find the net saturated updraft and downdraft mass fluxes  ***
+!c   ***                      through each level                          ***
+!c
+        do 1500 i=2,nl+1
+!c
+          num1=0
+          do 1265 ij=1,ncum
+            if(i.le.inb(ij))num1=num1+1
+ 1265     continue
+          if(num1.le.0)go to 1500
+!c
+          call zilch(amp1,ncum)
+          call zilch(ad,ncum)
+!c
+          do 1280 k=i+1,nl+1
+            do 1270 ij=1,ncum
+              if((i.ge.nk(ij)).and.(i.le.inb(ij))                                    &
+       &            .and.(k.le.(inb(ij)+1)))then
+                amp1(ij)=amp1(ij)+m(ij,k)
+              endif
+ 1270         continue
+ 1280     continue
+!c
+          do 1310 k=1,i
+            do 1300 j=i+1,nl+1
+               do 1290 ij=1,ncum
+                 if((j.le.(inb(ij)+1)).and.(i.le.inb(ij)))then
+                   amp1(ij)=amp1(ij)+ment(ij,k,j)
+                 endif
+ 1290          continue
+ 1300       continue
+ 1310     continue
+          do 1340 k=1,i-1
+            do 1330 j=i,nl+1
+              do 1320 ij=1,ncum
+                if((i.le.inb(ij)).and.(j.le.inb(ij)))then
+                   ad(ij)=ad(ij)+ment(ij,j,k)
+                endif
+ 1320         continue
+ 1330       continue
+ 1340     continue
+!c
+          do 1350 ij=1,ncum
+          if(i.le.inb(ij))then
+            dpinv=0.01/(ph(ij,i)-ph(ij,i+1))
+            cpinv=1.0/cpn(ij,i)
+!c
+            ft(ij,i)=ft(ij,i)                                                        &
+       &       +g*dpinv*(amp1(ij)*(t(ij,i+1)-t(ij,i)                                 &
+       &       +(gz(ij,i+1)-gz(ij,i))*cpinv)                                         &
+       &       -ad(ij)*(t(ij,i)-t(ij,i-1)+(gz(ij,i)-gz(ij,i-1))*cpinv))              &
+       &       -sigd*lvcp(ij,i)*evap(ij,i)
+            ft(ij,i)=ft(ij,i)+g*dpinv*ment(ij,i,i)*(hp(ij,i)-h(ij,i)+                &
+       &        t(ij,i)*(cpv-cpd)*(q(ij,i)-qent(ij,i,i)))*cpinv
+            ft(ij,i)=ft(ij,i)+sigd*wt(ij,i+1)*(cl-cpd)*water(ij,i+1)*                &
+       &        (t(ij,i+1)-t(ij,i))*dpinv*cpinv
+            fq(ij,i)=fq(ij,i)+g*dpinv*(amp1(ij)*(q(ij,i+1)-q(ij,i))-                 &
+       &        ad(ij)*(q(ij,i)-q(ij,i-1)))
+            fu(ij,i)=fu(ij,i)+g*dpinv*(amp1(ij)*(u(ij,i+1)-u(ij,i))-                 &
+       &        ad(ij)*(u(ij,i)-u(ij,i-1)))
+            fv(ij,i)=fv(ij,i)+g*dpinv*(amp1(ij)*(v(ij,i+1)-v(ij,i))-                 &
+       &        ad(ij)*(v(ij,i)-v(ij,i-1)))
+         endif
+ 1350    continue
+         do 1370 k=1,i-1
+           do 1360 ij=1,ncum
+             if(i.le.inb(ij))then
+               awat=elij(ij,k,i)-(1.-ep(ij,i))*clw(ij,i)
+               awat=max(awat,0.0)
+               fq(ij,i)=fq(ij,i)                                                     &
+       &         +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-awat-q(ij,i))
+               fu(ij,i)=fu(ij,i)                                                     &
+       &         +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)                                                     &
+       &         +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+!c (saturated updrafts resulting from mixing)               ! cld
+               qcond(ij,i)=qcond(ij,i)+(elij(ij,k,i)-awat) ! cld
+               nqcond(ij,i)=nqcond(ij,i)+1.                ! cld
+             endif
+ 1360      continue
+ 1370    continue
+         do 1390 k=i,nl+1
+           do 1380 ij=1,ncum
+             if((i.le.inb(ij)).and.(k.le.inb(ij)))then
+               fq(ij,i)=fq(ij,i)                                                     &
+       &                  +g*dpinv*ment(ij,k,i)*(qent(ij,k,i)-q(ij,i))
+               fu(ij,i)=fu(ij,i)                                                     &
+       &                  +g*dpinv*ment(ij,k,i)*(uent(ij,k,i)-u(ij,i))
+               fv(ij,i)=fv(ij,i)                                                     &
+       &                  +g*dpinv*ment(ij,k,i)*(vent(ij,k,i)-v(ij,i))
+             endif
+ 1380      continue
+ 1390    continue
+          do 1400 ij=1,ncum
+           if(i.le.inb(ij))then
+             fq(ij,i)=fq(ij,i)                                                       &
+       &                +sigd*evap(ij,i)+g*(mp(ij,i+1)*                              &
+       &                (qp(ij,i+1)-q(ij,i))                                         &
+       &                -mp(ij,i)*(qp(ij,i)-q(ij,i-1)))*dpinv
+             fu(ij,i)=fu(ij,i)                                                       &
+       &                +g*(mp(ij,i+1)*(up(ij,i+1)-u(ij,i))-mp(ij,i)*                &
+       &                (up(ij,i)-u(ij,i-1)))*dpinv
+             fv(ij,i)=fv(ij,i)                                                       &
+       &               +g*(mp(ij,i+1)*(vp(ij,i+1)-v(ij,i))-mp(ij,i)*                 &
+       &               (vp(ij,i)-v(ij,i-1)))*dpinv
+!C (saturated downdrafts resulting from mixing)               ! cld
+            do k=i+1,inb(ij)                                 ! cld
+             qcond(ij,i)=qcond(ij,i)+elij(ij,k,i)            ! cld
+             nqcond(ij,i)=nqcond(ij,i)+1.                    ! cld
+            enddo                                            ! cld
+!C (particular case: no detraining level is found)            ! cld
+            if (nent(ij,i).eq.0) then                        ! cld
+             qcond(ij,i)=qcond(ij,i)+(1.-ep(ij,i))*clw(ij,i) ! cld
+             nqcond(ij,i)=nqcond(ij,i)+1.                    ! cld
+            endif                                            ! cld
+            if (nqcond(ij,i).ne.0.) then                     ! cld
+             qcond(ij,i)=qcond(ij,i)/nqcond(ij,i)            ! cld
+            endif                                            ! cld
+           endif
+ 1400     continue
+ 1500   continue
+!c
+!c   *** Adjust tendencies at top of convection layer to reflect  ***
+!c   ***       actual position of the level zero cape             ***
+!c
+        do 503 ij=1,ncum
+        fqold=fq(ij,inb(ij))
+        fq(ij,inb(ij))=fq(ij,inb(ij))*(1.-frac(ij))
+        fq(ij,inb(ij)-1)=fq(ij,inb(ij)-1)                                            &
+       &   +frac(ij)*fqold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/                       &
+       &   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*lv(ij,inb(ij))                         &
+       &   /lv(ij,inb(ij)-1)
+        ftold=ft(ij,inb(ij))
+        ft(ij,inb(ij))=ft(ij,inb(ij))*(1.-frac(ij))
+        ft(ij,inb(ij)-1)=ft(ij,inb(ij)-1)                                            &
+       &   +frac(ij)*ftold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/                       &
+       &   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))*cpn(ij,inb(ij))                        &
+       &   /cpn(ij,inb(ij)-1)
+        fuold=fu(ij,inb(ij))
+        fu(ij,inb(ij))=fu(ij,inb(ij))*(1.-frac(ij))
+        fu(ij,inb(ij)-1)=fu(ij,inb(ij)-1)                                            &
+       &   +frac(ij)*fuold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/                       &
+       &   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+        fvold=fv(ij,inb(ij))
+        fv(ij,inb(ij))=fv(ij,inb(ij))*(1.-frac(ij))
+        fv(ij,inb(ij)-1)=fv(ij,inb(ij)-1)                                            &
+       &  +frac(ij)*fvold*((ph(ij,inb(ij))-ph(ij,inb(ij)+1))/                        &
+       &   (ph(ij,inb(ij)-1)-ph(ij,inb(ij))))
+ 503    continue
+!c
+!c   ***   Very slightly adjust tendencies to force exact   ***
+!c   ***     enthalpy, momentum and tracer conservation     ***
+!c
+        do 682 ij=1,ncum
+        ents(ij)=0.0
+        uav(ij)=0.0
+        vav(ij)=0.0
+        do 681 i=1,inb(ij)
+         ents(ij)=ents(ij)                                                           &
+       &  +(cpn(ij,i)*ft(ij,i)+lv(ij,i)*fq(ij,i))*(ph(ij,i)-ph(ij,i+1))	
+         uav(ij)=uav(ij)+fu(ij,i)*(ph(ij,i)-ph(ij,i+1))
+         vav(ij)=vav(ij)+fv(ij,i)*(ph(ij,i)-ph(ij,i+1))
+  681	continue
+  682   continue
+        do 683 ij=1,ncum
+        ents(ij)=ents(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        uav(ij)=uav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+        vav(ij)=vav(ij)/(ph(ij,1)-ph(ij,inb(ij)+1))
+ 683    continue
+        do 642 ij=1,ncum
+        do 641 i=1,inb(ij)
+         ft(ij,i)=ft(ij,i)-ents(ij)/cpn(ij,i)
+         fu(ij,i)=(1.-cu)*(fu(ij,i)-uav(ij))
+         fv(ij,i)=(1.-cu)*(fv(ij,i)-vav(ij))
+  641	continue
+ 642    continue
+!c
+        do 1810 k=1,nl+1
+          do 1800 i=1,ncum
+            if((q(i,k)+delt*fq(i,k)).lt.0.0)iflag(i)=10
+ 1800     continue
+ 1810   continue
+!c
+!c
+        do 1900 i=1,ncum
+          if(iflag(i).gt.2)then
+          precip(i)=0.0
+          cbmf(i)=0.0
+          endif
+ 1900   continue
+        do 1920 k=1,nl
+         do 1910 i=1,ncum
+           if(iflag(i).gt.2)then
+             ft(i,k)=0.0
+             fq(i,k)=0.0
+             fu(i,k)=0.0
+             fv(i,k)=0.0
+             qcondc(i,k)=0.0                               ! cld
+           endif
+ 1910    continue
+ 1920   continue
+
+        do k=1,nl+1
+        do i=1,ncum
+          Ma(i,k) = 0.
+        enddo
+        enddo
+        do k=nl,1,-1
+        do i=1,ncum
+          Ma(i,k) = Ma(i,k+1)+m(i,k)
+        enddo
+        enddo
+
+!c
+!c   *** diagnose the in-cloud mixing ratio   ***            ! cld
+!c   ***           of condensed water         ***            ! cld
+!c                                                           ! cld
+      DO ij=1,ncum                                          ! cld   
+       do i=1,nd                                            ! cld 
+        mac(ij,i)=0.0                                       ! cld   
+        wa(ij,i)=0.0                                        ! cld
+        siga(ij,i)=0.0                                      ! cld
+       enddo                                                ! cld
+       do i=nk(ij),inb(ij)                                  ! cld
+       do k=i+1,inb(ij)+1                                   ! cld
+        mac(ij,i)=mac(ij,i)+m(ij,k)                         ! cld
+       enddo                                                ! cld
+       enddo                                                ! cld
+       do i=icb(ij),inb(ij)-1                               ! cld
+        ax(ij,i)=0.                                         ! cld
+        do j=icb(ij),i                                      ! cld
+         ax(ij,i)=ax(ij,i)+rrd*(tvp(ij,j)-tv(ij,j))                                  & ! cld
+       &       *(ph(ij,j)-ph(ij,j+1))/p(ij,j)                 ! cld   
+        enddo                                               ! cld
+        if (ax(ij,i).gt.0.0) then                           ! cld   
+         wa(ij,i)=sqrt(2.*ax(ij,i))                         ! cld
+        endif                                               ! cld
+       enddo                                                ! cld
+       do i=1,nl                                            ! cld
+        if (wa(ij,i).gt.0.0)                                                         & ! cld
+       &    siga(ij,i)=mac(ij,i)/wa(ij,i)                                            & ! cld
+       &        *rrd*tvp(ij,i)/p(ij,i)/100./delta             ! cld   
+        siga(ij,i) = min(siga(ij,i),1.0)                    ! cld
+        qcondc(ij,i)=siga(ij,i)*clw(ij,i)*(1.-ep(ij,i))                              & ! cld
+       &          + (1.-siga(ij,i))*qcond(ij,i)               ! cld   
+       enddo                                                ! cld
+      ENDDO                                                 ! cld   
+
+        return
+        end SUBROUTINE cv_yield
+
+      SUBROUTINE cv_uncompress(nloc,len,ncum,nd,idcum                                &
+       &         ,iflag                                                              &
+       &         ,precip,cbmf                                                        &
+       &         ,ft,fq,fu,fv                                                        &
+       &         ,Ma,qcondc                                                          &
+       &         ,iflag1                                                             &
+       &         ,precip1,cbmf1                                                      &
+       &         ,ft1,fq1,fu1,fv1                                                    &
+       &         ,Ma1,qcondc1                                                        &
+       &                               )
+      implicit none
+
+#include "cvparam.h"
+
+!c inputs:
+      integer len, ncum, nd, nloc
+      integer idcum(nloc)
+      integer iflag(nloc)
+      real precip(nloc), cbmf(nloc)
+      real ft(nloc,nd), fq(nloc,nd), fu(nloc,nd), fv(nloc,nd)
+      real Ma(nloc,nd)
+      real qcondc(nloc,nd) !cld
+
+!c outputs:
+      integer iflag1(len)
+      real precip1(len), cbmf1(len)
+      real ft1(len,nd), fq1(len,nd), fu1(len,nd), fv1(len,nd)
+      real Ma1(len,nd)
+      real qcondc1(len,nd) !cld
+
+!c local variables:
+      integer i,k
+
+        do 2000 i=1,ncum
+         precip1(idcum(i))=precip(i)
+         cbmf1(idcum(i))=cbmf(i)
+         iflag1(idcum(i))=iflag(i)
+ 2000   continue
+
+        do 2020 k=1,nl
+          do 2010 i=1,ncum
+            ft1(idcum(i),k)=ft(i,k)
+            fq1(idcum(i),k)=fq(i,k)
+            fu1(idcum(i),k)=fu(i,k)
+            fv1(idcum(i),k)=fv(i,k)
+            Ma1(idcum(i),k)=Ma(i,k)
+            qcondc1(idcum(i),k)=qcondc(i,k)
+ 2010     continue
+ 2020   continue
+
+        return
+        end  SUBROUTINE cv_uncompress
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cva_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cva_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cva_driver.F	(revision 17)
@@ -0,0 +1,1045 @@
+!
+! $Id: cva_driver.F 1795 2013-07-18 08:20:28Z emillour $
+!
+      SUBROUTINE cva_driver(len,nd,ndp1,ntra,nloc,
+     &                   iflag_con,iflag_mix,
+     &                   iflag_clos,delt,
+     &                   t1,q1,qs1,t1_wake,q1_wake,qs1_wake,s1_wake,
+     &                   u1,v1,tra1,
+     &                   p1,ph1,
+     &                   ALE1,ALP1,
+     &                   sig1feed1,sig2feed1,wght1,
+     o                   iflag1,ft1,fq1,fu1,fv1,ftra1,
+     &                   precip1,kbas1,ktop1,
+     &                   cbmf1,plcl1,plfc1,wbeff1,
+     &                   sig1,w01,                  !input/output
+     &                   ptop21,sigd1,
+     &                   Ma1,mip1,Vprecip1,upwd1,dnwd1,dnwd01,
+     &                   qcondc1,wd1,
+     &                   cape1,cin1,tvp1,
+     &                   ftd1,fqd1,
+     &                   Plim11,Plim21,asupmax1,supmax01,asupmaxmin1
+     &                   ,lalim_conv, 
+     &                   da1,phi1,mp1,phi21,d1a1,dam1,sigij1,clw1,     ! RomP
+     &                   elij1,evap1,ep1,epmlmMm1,eplaMm1,             ! RomP 
+     &                   wdtrainA1,wdtrainM1)                          ! RomP
+***************************************************************
+*                                                             *
+* CV_DRIVER                                                   *
+*                                                             *
+*                                                             *
+* written by   : Sandrine Bony-Lena , 17/05/2003, 11.19.41    *
+* modified by :                                               *
+***************************************************************
+***************************************************************
+C
+      USE dimphy
+      implicit none
+C
+C.............................START PROLOGUE............................
+C
+!
+! All argument names (except len,nd,ntra,nloc,delt and the flags) have a "1" appended.
+! The "1" is removed for the corresponding compressed variables.
+C PARAMETERS:
+C      Name            Type         Usage            Description
+C   ----------      ----------     -------  ----------------------------
+C
+C      len           Integer        Input        first (i) dimension
+C      nd            Integer        Input        vertical (k) dimension
+C      ndp1          Integer        Input        nd + 1
+C      ntra          Integer        Input        number of tracors
+C      iflag_con     Integer        Input        version of convect (3/4)
+C      iflag_mix     Integer        Input        version of mixing  (0/1/2)
+C      iflag_clos    Integer        Input        version of closure (0/1)
+C      delt          Real           Input        time step
+C      t1            Real           Input        temperature (sat draught envt)
+C      q1            Real           Input        specific hum (sat draught envt)
+C      qs1           Real           Input        sat specific hum (sat draught envt)
+C      t1_wake       Real           Input        temperature (unsat draught envt)
+C      q1_wake       Real           Input        specific hum(unsat draught envt)
+C      qs1_wake      Real           Input        sat specific hum(unsat draughts envt)
+C      s1_wake       Real           Input        fractionnal area covered by wakes
+C      u1            Real           Input        u-wind
+C      v1            Real           Input        v-wind
+C      tra1          Real           Input        tracors
+C      p1            Real           Input        full level pressure
+C      ph1           Real           Input        half level pressure
+C      ALE1          Real           Input        Available lifting Energy
+C      ALP1          Real           Input        Available lifting Power
+C      sig1feed1     Real           Input        sigma coord at lower bound of feeding layer
+C      sig2feed1     Real           Input        sigma coord at upper bound of feeding layer
+C      wght1         Real           Input        weight density determining the feeding mixture
+C      iflag1        Integer        Output       flag for Emanuel conditions
+C      ft1           Real           Output       temp tend
+C      fq1           Real           Output       spec hum tend
+C      fu1           Real           Output       u-wind tend
+C      fv1           Real           Output       v-wind tend
+C      ftra1         Real           Output       tracor tend
+C      precip1       Real           Output       precipitation
+C      kbas1         Integer        Output       cloud base level
+C      ktop1         Integer        Output       cloud top level
+C      cbmf1         Real           Output       cloud base mass flux
+C      sig1          Real           In/Out       section adiabatic updraft
+C      w01           Real           In/Out       vertical velocity within adiab updraft
+C      ptop21        Real           In/Out       top of entraining zone
+C      Ma1           Real           Output       mass flux adiabatic updraft
+C      mip1          Real           Output       mass flux shed by the adiabatic updraft
+C      Vprecip1      Real           Output       vertical profile of precipitations
+C      upwd1         Real           Output       total upward mass flux (adiab+mixed)
+C      dnwd1         Real           Output       saturated downward mass flux (mixed)
+C      dnwd01        Real           Output       unsaturated downward mass flux
+C      qcondc1       Real           Output       in-cld mixing ratio of condensed water
+C      wd1           Real           Output       downdraft velocity scale for sfc fluxes
+C      cape1         Real           Output       CAPE
+C      cin1          Real           Output       CIN
+C      tvp1          Real           Output       adiab lifted parcell virt temp
+C      ftd1          Real           Output       precip temp tend
+C      fqt1          Real           Output       precip spec hum tend
+C      Plim11        Real           Output
+C      Plim21        Real           Output
+C      asupmax1      Real           Output
+C      supmax01      Real           Output
+C      asupmaxmin1   Real           Output
+!
+!      ftd1          Real           Output  Array of temperature tendency due to precipitations (K/s) of dimension ND,
+!                                           defined at same grid levels as T, Q, QS and P.
+!    
+!      fqd1          Real           Output  Array of specific humidity tendencies due to precipitations ((gm/gm)/s)
+!                                           of dimension ND, defined at same grid levels as T, Q, QS and P.
+!    
+!      wdtrainA1     Real           Output   precipitation detrained from adiabatic draught;
+!                                                       used in tracer transport (cvltr)
+!      wdtrainM1     Real           Output   precipitation detrained from mixed draughts;
+!                                                       used in tracer transport (cvltr)
+!      da1           Real           Output   used in tracer transport (cvltr)
+!      phi1          Real           Output   used in tracer transport (cvltr)
+!      mp1           Real           Output   used in tracer transport (cvltr)
+!    
+!      phi21         Real           Output   used in tracer transport (cvltr)
+!    
+!      d1a1          Real           Output   used in tracer transport (cvltr)
+!      dam1          Real           Output   used in tracer transport (cvltr)
+!    
+!      epmlmMm1      Real           Output   used in tracer transport (cvltr)
+!      eplaMm1       Real           Output   used in tracer transport (cvltr)
+!
+!      evap1         Real           Output
+!      ep1           Real           Output
+!      sigij1        Real           Output
+!      elij1         Real           Output
+
+C
+C S. Bony, Mar 2002:
+C 	* Several modules corresponding to different physical processes
+C 	* Several versions of convect may be used:
+C  		- iflag_con=3: version lmd  (previously named convect3)
+C  		- iflag_con=4: version 4.3b (vect. version, previously convect1/2)
+C   + tard: 	- iflag_con=5: version lmd with ice (previously named convectg)
+C S. Bony, Oct 2002:
+C	* Vectorization of convect3 (ie version lmd)
+C
+C..............................END PROLOGUE.............................
+c
+c
+#include "dimensions.h"
+ccccc#include "dimphy.h"
+      include 'iniprint.h'
+
+c
+c Input
+      integer len
+      integer nd
+      integer ndp1
+      integer ntra
+      integer iflag_con
+      integer iflag_mix
+      integer iflag_clos
+      real delt
+      real t1(len,nd)
+      real q1(len,nd)
+      real qs1(len,nd)
+      real t1_wake(len,nd)
+      real q1_wake(len,nd)
+      real qs1_wake(len,nd)
+      real s1_wake(len)
+      real u1(len,nd)
+      real v1(len,nd)
+      real tra1(len,nd,ntra)
+      real p1(len,nd)
+      real ph1(len,ndp1)
+      real ALE1(len)
+      real ALP1(len)
+      real sig1feed1 ! pressure at lower bound of feeding layer
+      real sig2feed1 ! pressure at upper bound of feeding layer
+      real wght1(nd) ! weight density determining the feeding mixture
+c
+c Output
+      integer iflag1(len)
+      real ft1(len,nd)
+      real fq1(len,nd)
+      real fu1(len,nd)
+      real fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real precip1(len)
+      integer kbas1(len)
+      integer ktop1(len)
+      real cbmf1(len)
+      real plcl1(klon)
+      real plfc1(klon)
+      real wbeff1(klon)
+      real sig1(len,klev)      !input/output
+      real w01(len,klev)       !input/output
+      real ptop21(len)
+      real sigd1(len)
+      real Ma1(len,nd)
+      real mip1(len,nd)
+!      real Vprecip1(len,nd)
+      real Vprecip1(len,nd+1)
+      real upwd1(len,nd)
+      real dnwd1(len,nd)
+      real dnwd01(len,nd)
+      real qcondc1(len,nd)     ! cld
+      real wd1(len)            ! gust
+      real cape1(len)
+      real cin1(len)
+      real tvp1(len,nd)
+c
+!AC!
+!!      real da1(len,nd),phi1(len,nd,nd)
+!!      real da(len,nd),phi(len,nd,nd)
+!AC!
+      real ftd1(len,nd)
+      real fqd1(len,nd)
+      real Plim11(len)
+      real Plim21(len)
+      real asupmax1(len,nd)
+      real supmax01(len)
+      real asupmaxmin1(len)
+      integer lalim_conv(len)
+! RomP >>> 
+      real wdtrainA1(len,nd), wdtrainM1(len,nd)
+      real da1(len,nd),phi1(len,nd,nd),mp1(len,nd)
+      real epmlmMm1(len,nd,nd),eplaMm1(len,nd)
+      real evap1(len,nd),ep1(len,nd)
+      real sigij1(len,nd,nd),elij1(len,nd,nd)
+      real phi21(len,nd,nd)
+      real d1a1(len,nd), dam1(len,nd)
+! RomP <<<
+!
+!-------------------------------------------------------------------
+!        Prolog by Kerry Emanuel.
+!-------------------------------------------------------------------
+! --- ARGUMENTS
+!-------------------------------------------------------------------
+! --- On input:
+!
+!  t:   Array of absolute temperature (K) of dimension ND, with first
+!       index corresponding to lowest model level. Note that this array
+!       will be altered by the subroutine if dry convective adjustment
+!       occurs and if IPBL is not equal to 0.
+!
+!  q:   Array of specific humidity (gm/gm) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  qs:  Array of saturation specific humidity of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+! t_wake: Array of absolute temperature (K), seen by unsaturated draughts,
+!       of dimension ND, with first index corresponding to lowest model level.
+!
+! q_wake: Array of specific humidity (gm/gm), seen by unsaturated draughts,
+!       of dimension ND, with first index corresponding to lowest model level.
+!       Must be defined at same grid levels as T.
+!
+!qs_wake: Array of saturation specific humidity, seen by unsaturated draughts,
+!       of dimension ND, with first index corresponding to lowest model level.
+!       Must be defined at same grid levels as T.
+!
+!s_wake: Array of fractionnal area occupied by the wakes.
+!
+!  u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+!       index corresponding with the lowest model level. Defined at
+!       same levels as T. Note that this array will be altered if
+!       dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  v:   Same as u but for meridional velocity.
+!
+!  tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+!       where NTRA is the number of different tracers. If no
+!       convective tracer transport is needed, define a dummy
+!       input array of dimension (ND,1). Tracers are defined at
+!       same vertical levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  p:   Array of pressure (mb) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T.
+!
+!  ph:  Array of pressure (mb) of dimension ND+1, with first index
+!       corresponding to lowest level. These pressures are defined at
+!       levels intermediate between those of P, T, Q and QS. The first
+!       value of PH should be greater than (i.e. at a lower level than)
+!       the first value of the array P.
+!
+! ALE:  Available lifting Energy
+!
+! ALP:  Available lifting Power
+!
+!  nl:  The maximum number of levels to which convection can penetrate, plus 1.
+!       NL MUST be less than or equal to ND-1.
+!
+!  delt: The model time step (sec) between calls to CONVECT
+!
+!----------------------------------------------------------------------------
+! ---   On Output:
+!
+!  iflag: An output integer whose value denotes the following:
+!       VALUE   INTERPRETATION
+!       -----   --------------
+!         0     Moist convection occurs.
+!         1     Moist convection occurs, but a CFL condition
+!               on the subsidence warming is violated. This
+!               does not cause the scheme to terminate.
+!         2     Moist convection, but no precip because ep(inb) lt 0.0001
+!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
+!         4     No moist convection; atmosphere is not
+!               unstable
+!         6     No moist convection because ihmin le minorig.
+!         7     No moist convection because unreasonable
+!               parcel level temperature or specific humidity.
+!         8     No moist convection: lifted condensation
+!               level is above the 200 mb level.
+!         9     No moist convection: cloud base is higher
+!               then the level NL-1.
+!
+!  ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
+!        grid levels as T, Q, QS and P.
+!
+!  fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+!        defined at same grid levels as T, Q, QS and P.
+!
+!  fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+!        defined at same grid levels as T.
+!
+!  fv:   Same as FU, but for forcing of meridional velocity.
+!
+!  ftra: Array of forcing of tracer content, in tracer mixing ratio per
+!        second, defined at same levels as T. Dimensioned (ND,NTRA).
+!
+!  precip: Scalar convective precipitation rate (mm/day).
+!
+!  wd:   A convective downdraft velocity scale. For use in surface
+!        flux parameterizations. See convect.ps file for details.
+!
+!  tprime: A convective downdraft temperature perturbation scale (K).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  qprime: A convective downdraft specific humidity
+!          perturbation scale (gm/gm).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+!        BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+!        ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+!        by the calling program between calls to CONVECT.
+!
+!  det:   Array of detrainment mass flux of dimension ND.
+!-------------------------------------------------------------------
+c
+c  Local arrays
+c
+
+      integer i,k,n,il,j
+      integer nword1,nword2,nword3,nword4
+      integer icbmax
+      integer nk1(klon)
+      integer icb1(klon)
+      integer icbs1(klon)
+
+      logical ok_inhib  ! True => possible inhibition of convection by dryness
+      logical, save :: debut=.true. 
+c$OMP THREADPRIVATE(debut)
+
+      real tnk1(klon)
+      real thnk1(klon)
+      real qnk1(klon)
+      real gznk1(klon)
+      real pnk1(klon)
+      real qsnk1(klon)
+      real unk1(klon)
+      real vnk1(klon)
+      real cpnk1(klon)
+      real hnk1(klon)
+      real pbase1(klon)
+      real buoybase1(klon)
+
+      real lv1(klon,klev) ,lv1_wake(klon,klev)
+      real cpn1(klon,klev),cpn1_wake(klon,klev)
+      real tv1(klon,klev) ,tv1_wake(klon,klev)
+      real gz1(klon,klev) ,gz1_wake(klon,klev)
+      real hm1(klon,klev) ,hm1_wake(klon,klev)
+      real h1(klon,klev)  ,h1_wake(klon,klev)
+      real tp1(klon,klev)
+      real clw1(klon,klev)
+      real th1(klon,klev) ,th1_wake(klon,klev)
+c
+      real bid(klon,klev)   ! dummy array
+c
+      integer ncum
+c
+      integer j1feed(klon)
+      integer j2feed(klon)
+      real p1feed1(len) ! pressure at lower bound of feeding layer
+      real p2feed1(len) ! pressure at upper bound of feeding layer
+      real wghti1(len,nd) ! weights of the feeding layers
+c
+c (local) compressed fields:
+c
+      integer nloc
+c      parameter (nloc=klon) ! pour l'instant
+
+      integer idcum(nloc)
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      integer nent(nloc,klev)
+      integer icbs(nloc)
+      integer inb(nloc), inbis(nloc)
+
+      real cbmf(nloc),plcl(nloc),plfc(nloc),wbeff(nloc)
+      real t(nloc,klev),q(nloc,klev),qs(nloc,klev)
+      real t_wake(nloc,klev),q_wake(nloc,klev),qs_wake(nloc,klev)
+      real s_wake(nloc)
+      real u(nloc,klev),v(nloc,klev)
+      real gz(nloc,klev),h(nloc,klev)     ,hm(nloc,klev)
+      real               h_wake(nloc,klev),hm_wake(nloc,klev)
+      real lv(nloc,klev)     ,cpn(nloc,klev)
+      real lv_wake(nloc,klev),cpn_wake(nloc,klev)
+      real p(nloc,klev),ph(nloc,klev+1),tv(nloc,klev)    ,tp(nloc,klev)
+      real                              tv_wake(nloc,klev)
+      real clw(nloc,klev)
+      real dph(nloc,klev)
+      real pbase(nloc), buoybase(nloc), th(nloc,klev)
+      real                              th_wake(nloc,klev)
+      real tvp(nloc,klev)
+      real sig(nloc,klev), w0(nloc,klev), ptop2(nloc)
+      real hp(nloc,klev), ep(nloc,klev), sigp(nloc,klev)
+      real frac(nloc), buoy(nloc,klev)
+      real cape(nloc)
+      real cin(nloc)
+      real m(nloc,klev)
+      real ment(nloc,klev,klev), sigij(nloc,klev,klev)
+      real qent(nloc,klev,klev)
+      real hent(nloc,klev,klev)
+      real uent(nloc,klev,klev), vent(nloc,klev,klev)
+      real ments(nloc,klev,klev), qents(nloc,klev,klev)
+      real elij(nloc,klev,klev)
+      real supmax(nloc,klev)
+      real ale(nloc),alp(nloc),coef_clos(nloc)
+      real sigd(nloc)
+!      real mp(nloc,klev), qp(nloc,klev), up(nloc,klev), vp(nloc,klev)
+!      real wt(nloc,klev), water(nloc,klev), evap(nloc,klev)
+!      real b(nloc,klev), sigd(nloc)
+!      save mp,qp,up,vp,wt,water,evap,b
+      real, save, allocatable :: mp(:,:),qp(:,:),up(:,:),vp(:,:)
+      real, save, allocatable :: wt(:,:),water(:,:),evap(:,:), b(:,:)
+c$OMP THREADPRIVATE(mp,qp,up,vp,wt,water,evap,b)
+      real  ft(nloc,klev), fq(nloc,klev)
+      real ftd(nloc,klev), fqd(nloc,klev)
+      real fu(nloc,klev), fv(nloc,klev)
+      real upwd(nloc,klev), dnwd(nloc,klev), dnwd0(nloc,klev)
+      real Ma(nloc,klev), mip(nloc,klev), tls(nloc,klev)
+      real tps(nloc,klev), qprime(nloc), tprime(nloc)
+      real precip(nloc)
+!      real Vprecip(nloc,klev)
+      real Vprecip(nloc,klev+1)
+      real tra(nloc,klev,ntra), trap(nloc,klev,ntra)
+      real ftra(nloc,klev,ntra), traent(nloc,klev,klev,ntra)
+      real qcondc(nloc,klev)  ! cld
+      real wd(nloc)           ! gust
+      real Plim1(nloc),Plim2(nloc)
+      real asupmax(nloc,klev)
+      real supmax0(nloc)
+      real asupmaxmin(nloc)
+c
+      real tnk(nloc),qnk(nloc),gznk(nloc)
+      real wghti(nloc,nd)
+      real hnk(nloc),unk(nloc),vnk(nloc)
+!
+! RomP >>> 
+      real wdtrainA(nloc,klev),wdtrainM(nloc,klev)
+      real da(len,nd),phi(len,nd,nd)
+      real epmlmMm(nloc,klev,klev),eplaMm(nloc,klev)  
+      real phi2(len,nd,nd)
+      real d1a(len,nd), dam(len,nd)
+! RomP <<<
+!
+      logical, save :: first=.true.
+c$OMP THREADPRIVATE(first)
+      CHARACTER (LEN=20) :: modname='cva_driver'
+      CHARACTER (LEN=80) :: abort_message
+
+c
+!      print *, 't1, t1_wake ',(k,t1(1,k),t1_wake(1,k),k=1,klev)
+!      print *, 'q1, q1_wake ',(k,q1(1,k),q1_wake(1,k),k=1,klev)
+
+!-------------------------------------------------------------------
+! --- SET CONSTANTS AND PARAMETERS
+!-------------------------------------------------------------------
+
+       if (first) then
+         allocate(mp(nloc,klev), qp(nloc,klev), up(nloc,klev))
+         allocate(vp(nloc,klev), wt(nloc,klev), water(nloc,klev))
+         allocate(evap(nloc,klev), b(nloc,klev))
+         first=.false.
+       endif
+c -- set simulation flags:
+c   (common cvflag)
+
+       CALL cv_flag
+
+c -- set thermodynamical constants:
+c 	(common cvthermo)
+
+       CALL cv_thermo(iflag_con)
+
+c -- set convect parameters
+c
+c 	includes microphysical parameters and parameters that
+c  	control the rate of approach to quasi-equilibrium)
+c 	(common cvparam)
+
+      if (iflag_con.eq.3) then
+       CALL cv3_param(nd,delt)
+  
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_param(nd)
+      endif
+
+!---------------------------------------------------------------------
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+!---------------------------------------------------------------------
+      nword1=len
+      nword2=len*nd
+      nword3=len*nd*ntra
+      nword4=len*nd*nd
+ 
+      iflag1(:)     = 0
+      ktop1(:)      = 0
+      kbas1(:)      = 0
+      ft1(:,:)      = 0.0
+      fq1(:,:)      = 0.0
+      fu1(:,:)      = 0.0
+      fv1(:,:)      = 0.0
+      ftra1(:,:,:)  = 0.
+      precip1(:)    = 0.
+      cbmf1(:)      = 0.
+      ptop21(:)     = 0.
+      sigd1(:)      = 0.
+      Ma1(:,:)      = 0.
+      mip1(:,:)     = 0.
+      Vprecip1(:,:) = 0.
+      upwd1   (:,:) = 0.
+      dnwd1   (:,:) = 0.
+      dnwd01  (:,:) = 0.
+      qcondc1 (:,:) = 0.
+      wd1     (:)   = 0.
+      cape1   (:)   = 0.
+      cin1    (:)   = 0.
+      tvp1    (:,:) = 0.
+      ftd1    (:,:) = 0.
+      fqd1    (:,:) = 0.
+      Plim11  (:)   = 0.
+      Plim21  (:)   = 0.
+      asupmax1(:,:) = 0.
+      supmax01(:)   = 0.
+      asupmaxmin1(:)= 0.
+c
+      DO il = 1,len
+       cin1(il) = -100000.
+       cape1(il) = -1.
+      ENDDO
+c  
+      if (iflag_con.eq.3) then
+        do il=1,len
+         sig1(il,nd)=sig1(il,nd)+1.
+         sig1(il,nd)=amin1(sig1(il,nd),12.1)
+        enddo
+      endif
+  
+! RomP >>> 
+       wdtrainA1(:,:)  = 0.
+       wdtrainM1(:,:)  = 0.
+       da1(:,:)        = 0.
+       phi1(:,:,:)     = 0.
+       epmlmMm1(:,:,:) = 0.
+       eplaMm1(:,:)    = 0.
+       mp1(:,:)        = 0.
+       evap1(:,:)      = 0.
+       ep1(:,:)        = 0.
+       sigij1(:,:,:)   = 0.
+       elij1(:,:,:)    = 0.
+       phi21(:,:,:)    = 0.
+       d1a1(:,:)       = 0.
+       dam1(:,:)       = 0.
+! RomP <<<
+!---------------------------------------------------------------------
+! --- INITIALIZE LOCAL ARRAYS AND PARAMETERS
+!---------------------------------------------------------------------
+!
+      do il = 1,nloc
+         coef_clos(il)=1.
+      enddo
+
+!--------------------------------------------------------------------
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+  
+       if (debut) THEN 
+        print*,'Emanuel version 3 nouvelle'
+       endif 
+!       print*,'t1, q1 ',t1,q1
+       CALL cv3_prelim(len,nd,ndp1,t1,q1,p1,ph1      ! nd->na
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1,th1)
+    
+c
+       CALL cv3_prelim(len,nd,ndp1,t1_wake,q1_wake,p1,ph1 ! nd->na
+     o               ,lv1_wake,cpn1_wake,tv1_wake,gz1_wake
+     o               ,h1_wake,bid,th1_wake)
+    
+      endif
+c
+      if (iflag_con.eq.4) then
+       print*,'Emanuel version 4 '
+       CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1
+     o               ,lv1,cpn1,tv1,gz1,h1,hm1)
+      endif
+
+!--------------------------------------------------------------------
+! --- CONVECTIVE FEED
+!--------------------------------------------------------------------
+!
+! compute feeding layer potential temperature and mixing ratio :
+!
+! get bounds of feeding layer
+!
+c test niveaux couche alimentation KE
+       if(sig1feed1.eq.sig2feed1) then
+         write(lunout,*)'impossible de choisir sig1feed=sig2feed'
+         write(lunout,*)'changer la valeur de sig2feed dans physiq.def'
+         abort_message = ''
+         CALL abort_gcm (modname,abort_message,1)
+       endif
+c
+       do i=1,len
+         p1feed1(i)=sig1feed1*ph1(i,1)
+         p2feed1(i)=sig2feed1*ph1(i,1)
+ctest maf
+c         p1feed1(i)=ph1(i,1)
+c         p2feed1(i)=ph1(i,2)
+c         p2feed1(i)=ph1(i,3)
+ctestCR: on prend la couche alim des thermiques
+c          p2feed1(i)=ph1(i,lalim_conv(i)+1)
+c          print*,'lentr=',lentr(i),ph1(i,lentr(i)+1),ph1(i,2)
+       end do
+!
+       if (iflag_con.eq.3) then
+       endif
+      do i=1,len
+!      print*,'avant cv3_feed plim',p1feed1(i),p2feed1(i)
+      enddo
+      if (iflag_con.eq.3) then
+ 
+c     print*, 'IFLAG1 avant cv3_feed'
+c     print*,'len,nd',len,nd
+c     write(*,'(64i1)') iflag1(2:klon-1)
+
+       CALL cv3_feed(len,nd,t1,q1,u1,v1,p1,ph1,hm1,gz1           ! nd->na
+     i         ,p1feed1,p2feed1,wght1
+     o         ,wghti1,tnk1,thnk1,qnk1,qsnk1,unk1,vnk1
+     o         ,cpnk1,hnk1,nk1,icb1,icbmax,iflag1,gznk1,plcl1)
+      endif
+    
+c     print*, 'IFLAG1 apres cv3_feed'
+c     print*,'len,nd',len,nd
+c     write(*,'(64i1)') iflag1(2:klon-1)
+
+      if (iflag_con.eq.4) then
+       CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1
+     o         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif
+c
+!      print *, 'cv3_feed-> iflag1, plcl1 ',iflag1(1),plcl1(1)
+c
+!--------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part
+! (up through ICB for convect4, up through ICB+1 for convect3)
+!     Calculates the lifted parcel virtual temperature at nk, the
+!     actual temperature, and the adiabatic liquid water content.
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+    
+       CALL cv3_undilute1(len,nd,t1,qs1,gz1,plcl1,p1,icb1,tnk1,qnk1  ! nd->na
+     o                    ,gznk1,tp1,tvp1,clw1,icbs1)
+      endif
+   
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax
+     :                        ,tp1,tvp1,clw1)
+      endif
+c
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!-------------------------------------------------------------------
+c
+!      print *,' avant triggering, iflag_con ',iflag_con
+c
+      if (iflag_con.eq.3) then
+    
+       CALL cv3_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1,thnk1      ! nd->na
+     o                 ,pbase1,buoybase1,iflag1,sig1,w01)
+    
+
+c     print*, 'IFLAG1 apres cv3_triger'
+c     print*,'len,nd',len,nd
+c     write(*,'(64i1)') iflag1(2:klon-1)
+
+c     call dump2d(iim,jjm-1,sig1(2)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1)
+      endif
+c
+c
+!=====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+!=====================================================================
+
+      ncum=0
+      do 400 i=1,len
+        if(iflag1(i).eq.0)then
+           ncum=ncum+1
+           idcum(ncum)=i
+        endif
+ 400  continue
+c
+!       print*,'klon, ncum = ',len,ncum
+c
+      IF (ncum.gt.0) THEN
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- COMPRESS THE FIELDS
+!		(-> vectorization over convective gridpoints)
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.3) then
+!       print*,'ncum tv1 ',ncum,tv1 
+!       print*,'tvp1 ',tvp1
+       CALL cv3a_compress( len,nloc,ncum,nd,ntra
+     :    ,iflag1,nk1,icb1,icbs1
+     :    ,plcl1,tnk1,qnk1,gznk1,hnk1,unk1,vnk1
+     :    ,wghti1,pbase1,buoybase1
+     :    ,t1,q1,qs1,t1_wake,q1_wake,qs1_wake,s1_wake
+     :    ,u1,v1,gz1,th1,th1_wake
+     :    ,tra1
+     :    ,h1     ,lv1     ,cpn1   ,p1,ph1,tv1    ,tp1,tvp1,clw1
+     :    ,h1_wake,lv1_wake,cpn1_wake     ,tv1_wake
+     :    ,sig1,w01,ptop21
+     :    ,Ale1,Alp1
+     o    ,iflag,nk,icb,icbs
+     o    ,plcl,tnk,qnk,gznk,hnk,unk,vnk
+     o    ,wghti,pbase,buoybase
+     o    ,t,q,qs,t_wake,q_wake,qs_wake,s_wake
+     o    ,u,v,gz,th,th_wake
+     o    ,tra
+     o    ,h     ,lv     ,cpn    ,p,ph,tv    ,tp,tvp,clw
+     o    ,h_wake,lv_wake,cpn_wake    ,tv_wake
+     o    ,sig,w0,ptop2
+     o    ,Ale,Alp  ) 
+
+!       print*,'tv ',tv
+!       print*,'tvp ',tvp
+
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_compress( len,nloc,ncum,nd
+     :    ,iflag1,nk1,icb1
+     :    ,cbmf1,plcl1,tnk1,qnk1,gznk1
+     :    ,t1,q1,qs1,u1,v1,gz1
+     :    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1
+     o    ,iflag,nk,icb
+     o    ,cbmf,plcl,tnk,qnk,gznk
+     o    ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw
+     o    ,dph )
+      endif
+
+!-------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / second part :
+! ---   FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+! ---   &
+! ---   COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+! ---   FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+! ---   &
+! ---   FIND THE LEVEL OF NEUTRAL BUOYANCY
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_undilute2(nloc,ncum,nd,icb,icbs,nk        !na->nd
+     :                        ,tnk,qnk,gznk,hnk,t,q,qs,gz
+     :                        ,p,h,tv,lv,pbase,buoybase,plcl
+     o                        ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+   
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute2(nloc,ncum,nd,icb,nk
+     :                        ,tnk,qnk,gznk,t,q,qs,gz
+     :                        ,p,dph,h,tv,lv
+     o             ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac)
+      endif
+c
+!-------------------------------------------------------------------
+! --- MIXING(1)   (if iflag_mix .ge. 1)
+!-------------------------------------------------------------------
+      IF (iflag_con .eq. 3) THEN
+       IF (iflag_mix .ge. 1 ) THEN
+         CALL zilch(supmax,nloc*klev)    
+         CALL cv3p_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb    ! na->nd
+     :                       ,ph,t,q,qs,u,v,tra,h,lv,qnk
+     :                       ,unk,vnk,hp,tv,tvp,ep,clw,sig
+     :                    ,ment,qent,hent,uent,vent,nent
+     :                   ,sigij,elij,supmax,ments,qents,traent)
+!        print*, 'cv3p_mixing-> supmax ', (supmax(1,k), k=1,nd)
+      
+       ELSE
+        CALL zilch(supmax,nloc*klev)
+       ENDIF
+      ENDIF
+!-------------------------------------------------------------------
+! --- CLOSURE
+!-------------------------------------------------------------------
+
+c
+      if (iflag_con.eq.3) then
+       IF (iflag_clos .eq. 0) THEN
+        CALL cv3_closure(nloc,ncum,nd,icb,inb              ! na->nd
+     :                       ,pbase,p,ph,tv,buoy
+     o                       ,sig,w0,cape,m,iflag)
+       ENDIF
+c
+       ok_inhib = iflag_mix .EQ. 2
+c
+       IF (iflag_clos .eq. 1) THEN
+        print *,' pas d appel cv3p_closure'
+cc        CALL cv3p_closure(nloc,ncum,nd,icb,inb              ! na->nd
+cc    :                       ,pbase,plcl,p,ph,tv,tvp,buoy
+cc    :                       ,supmax
+cc    o                       ,sig,w0,ptop2,cape,cin,m)
+       ENDIF
+       IF (iflag_clos .eq. 2) THEN
+        CALL cv3p1_closure(nloc,ncum,nd,icb,inb              ! na->nd
+     :                       ,pbase,plcl,p,ph,tv,tvp,buoy
+     :                       ,supmax,ok_inhib,Ale,Alp
+     o                       ,sig,w0,ptop2,cape,cin,m,iflag,coef_clos
+     :                       ,Plim1,Plim2,asupmax,supmax0
+     :                       ,asupmaxmin,cbmf,plfc,wbeff)
+       
+        print *,'cv3p1_closure-> plfc,wbeff ', plfc(1),wbeff(1)
+       ENDIF
+      endif   ! iflag_con.eq.3
+  
+      if (iflag_con.eq.4) then
+       CALL cv_closure(nloc,ncum,nd,nk,icb
+     :                ,tv,tvp,p,ph,dph,plcl,cpn
+     o                ,iflag,cbmf)
+      endif
+c
+!      print *,'cv_closure-> cape ',cape(1)
+c
+!-------------------------------------------------------------------
+! --- MIXING(2)
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+        IF (iflag_mix.eq.0) THEN
+         CALL cv3_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb    ! na->nd
+     :                       ,ph,t,q,qs,u,v,tra,h,lv,qnk
+     :                       ,unk,vnk,hp,tv,tvp,ep,clw,m,sig
+     o   ,ment,qent,uent,vent,nent,sigij,elij,ments,qents,traent)
+         CALL zilch(hent,nloc*klev*klev)
+        ELSE
+         CALL cv3_mixscale(nloc,ncum,nd,ment,m)
+         if (debut) THEN 
+          print *,' cv3_mixscale-> '
+         endif !(debut) THEN 
+        ENDIF
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis
+     :                     ,ph,t,q,qs,u,v,h,lv,qnk
+     :                     ,hp,tv,tvp,ep,clw,cbmf
+     o                     ,m,ment,qent,uent,vent,nent,sigij,elij)
+      endif
+c
+      if (debut) THEN 
+       print *,' cv_mixing ->'
+      endif !(debut) THEN 
+c      do i = 1,klev
+c        print*,'cv_mixing-> i,ment ',i,(ment(1,i,j),j=1,klev)
+c      enddo
+c
+!-------------------------------------------------------------------
+! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS
+!-------------------------------------------------------------------
+      if (iflag_con.eq.3) then
+       if (debut) THEN 
+        print *,' cva_driver -> cv3_unsat '
+       endif !(debut) THEN 
+    
+       CALL cv3_unsat(nloc,ncum,nd,nd,ntra,icb,inb,iflag    ! na->nd
+     :               ,t_wake,q_wake,qs_wake,gz,u,v,tra,p,ph
+     :               ,th_wake,tv_wake,lv_wake,cpn_wake
+     :               ,ep,sigp,clw
+     :               ,m,ment,elij,delt,plcl,coef_clos
+     o          ,mp,qp,up,vp,trap,wt,water,evap,b,sigd
+     o          ,wdtrainA,wdtrainM)   ! RomP
+      endif
+     
+      if (iflag_con.eq.4) then
+       CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph
+     :                   ,h,lv,ep,sigp,clw,m,ment,elij
+     o                   ,iflag,mp,qp,up,vp,wt,water,evap)
+      endif
+c
+      if (debut) THEN 
+       print *,'cv_unsat-> '
+      endif !(debut) THEN
+!
+c      print *,'cv_unsat-> mp ',mp
+c      print *,'cv_unsat-> water ',water
+!-------------------------------------------------------------------
+! --- YIELD
+!     (tendencies, precipitation, variables of interface with other
+!      processes, etc)
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+  
+       CALL cv3_yield(nloc,ncum,nd,nd,ntra            ! na->nd
+     :                     ,icb,inb,delt
+     :                     ,t,q,t_wake,q_wake,s_wake,u,v,tra
+     :                     ,gz,p,ph,h,hp,lv,cpn,th,th_wake
+     :                     ,ep,clw,m,tp,mp,qp,up,vp,trap
+     :                     ,wt,water,evap,b,sigd
+     :                    ,ment,qent,hent,iflag_mix,uent,vent
+     :                    ,nent,elij,traent,sig
+     :                    ,tv,tvp,wghti
+     :                    ,iflag,precip,Vprecip,ft,fq,fu,fv,ftra
+     :                    ,cbmf,upwd,dnwd,dnwd0,ma,mip
+     :                    ,tls,tps,qcondc,wd
+     :                    ,ftd,fqd)
+      endif
+c
+      if (debut) THEN 
+       print *,' cv3_yield -> fqd(1) = ',fqd(1,1)
+      endif !(debut) THEN
+c
+      if (iflag_con.eq.4) then
+       CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt
+     :              ,t,q,u,v
+     :              ,gz,p,ph,h,hp,lv,cpn
+     :              ,ep,clw,frac,m,mp,qp,up,vp
+     :              ,wt,water,evap
+     :              ,ment,qent,uent,vent,nent,elij
+     :              ,tv,tvp
+     o              ,iflag,wd,qprime,tprime
+     o              ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      endif
+
+!AC!
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- passive tracers
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.3) then
+!RomP >>>
+       CALL cv3_tracer(nloc,len,ncum,nd,nd,
+     :                  ment,sigij,da,phi,phi2,d1a,dam,
+     :                  ep,Vprecip,elij,clw,epmlmMm,eplaMm,
+     :                  icb,inb)
+!RomP <<<
+      endif
+
+!AC!
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- UNCOMPRESS THE FIELDS
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+
+      if (iflag_con.eq.3) then
+       CALL cv3a_uncompress(nloc,len,ncum,nd,ntra,idcum
+     :          ,iflag,icb,inb
+     :          ,precip,cbmf,plcl,plfc,wbeff,sig,w0,ptop2
+     :          ,ft,fq,fu,fv,ftra
+     :          ,sigd,Ma,mip,Vprecip,upwd,dnwd,dnwd0
+     ;          ,qcondc,wd,cape,cin
+     :          ,tvp
+     :          ,ftd,fqd
+     :          ,Plim1,Plim2,asupmax,supmax0
+     :          ,asupmaxmin
+     :          ,da,phi,mp,phi2,d1a,dam,sigij         ! RomP
+     :          ,clw,elij,evap,ep,epmlmMm,eplaMm      ! RomP
+     :          ,wdtrainA,wdtrainM                    ! RomP
+     o          ,iflag1,kbas1,ktop1
+     o          ,precip1,cbmf1,plcl1,plfc1,wbeff1,sig1,w01,ptop21
+     o          ,ft1,fq1,fu1,fv1,ftra1
+     o          ,sigd1,Ma1,mip1,Vprecip1,upwd1,dnwd1,dnwd01
+     o          ,qcondc1,wd1,cape1,cin1
+     o          ,tvp1
+     o          ,ftd1,fqd1
+     o          ,Plim11,Plim21,asupmax1,supmax01
+     o          ,asupmaxmin1
+     o          ,da1,phi1,mp1,phi21,d1a1,dam1,sigij1  ! RomP
+     o          ,clw1,elij1,evap1,ep1,epmlmMm1,eplaMm1! RomP
+     o          ,wdtrainA1,wdtrainM1)                 ! RomP
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_uncompress(nloc,len,ncum,nd,idcum
+     :          ,iflag
+     :          ,precip,cbmf
+     :          ,ft,fq,fu,fv
+     :          ,Ma,qcondc
+     o          ,iflag1
+     o          ,precip1,cbmf1
+     o          ,ft1,fq1,fu1,fv1
+     o          ,Ma1,qcondc1 )
+      endif
+
+      ENDIF ! ncum>0
+c
+      if (debut) THEN 
+       print *,' cv_compress -> '
+       debut=.FALSE.
+      endif !(debut) THEN
+c
+
+9999  continue
+      return
+      end
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cva_driver.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cva_driver.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cva_driver.F90	(revision 17)
@@ -0,0 +1,1045 @@
+!
+! $Id: cva_driver.F 1795 2013-07-18 08:20:28Z emillour $
+!
+      SUBROUTINE cva_driver(len,nd,ndp1,ntra,nloc,                                   &
+       &                   iflag_con,iflag_mix,                                      &
+       &                   iflag_clos,delt,                                          &
+       &                   t1,q1,qs1,t1_wake,q1_wake,qs1_wake,s1_wake,               &
+       &                   u1,v1,tra1,                                               &
+       &                   p1,ph1,                                                   &
+       &                   ALE1,ALP1,                                                &
+       &                   sig1feed1,sig2feed1,wght1,                                &
+       &                   iflag1,ft1,fq1,fu1,fv1,ftra1,                             &
+       &                   precip1,kbas1,ktop1,                                      &
+       &                   cbmf1,plcl1,plfc1,wbeff1,                                 &
+       &                   sig1,w01,                                                 & !input/output
+       &                   ptop21,sigd1,                                             &
+       &                   Ma1,mip1,Vprecip1,upwd1,dnwd1,dnwd01,                     &
+       &                   qcondc1,wd1,                                              &
+       &                   cape1,cin1,tvp1,                                          &
+       &                   ftd1,fqd1,                                                &
+       &                   Plim11,Plim21,asupmax1,supmax01,asupmaxmin1               &
+       &                   ,lalim_conv,                                              &
+       &                   da1,phi1,mp1,phi21,d1a1,dam1,sigij1,clw1,                 & ! RomP
+       &                   elij1,evap1,ep1,epmlmMm1,eplaMm1,                         & ! RomP
+       &                   wdtrainA1,wdtrainM1)                                        ! RomP
+!***************************************************************
+!*                                                             *
+!* CV_DRIVER                                                   *
+!*                                                             *
+!*                                                             *
+!* written by   : Sandrine Bony-Lena , 17/05/2003, 11.19.41    *
+!* modified by :                                               *
+!***************************************************************
+!***************************************************************
+!C
+      USE dimphy
+      implicit none
+!C
+!C.............................START PROLOGUE............................
+!C
+!
+! All argument names (except len,nd,ntra,nloc,delt and the flags) have a "1" appended.
+! The "1" is removed for the corresponding compressed variables.
+!C PARAMETERS:
+!C      Name            Type         Usage            Description
+!C   ----------      ----------     -------  ----------------------------
+!C
+!C      len           Integer        Input        first (i) dimension
+!C      nd            Integer        Input        vertical (k) dimension
+!C      ndp1          Integer        Input        nd + 1
+!C      ntra          Integer        Input        number of tracors
+!C      iflag_con     Integer        Input        version of convect (3/4)
+!C      iflag_mix     Integer        Input        version of mixing  (0/1/2)
+!C      iflag_clos    Integer        Input        version of closure (0/1)
+!C      delt          Real           Input        time step
+!C      t1            Real           Input        temperature (sat draught envt)
+!C      q1            Real           Input        specific hum (sat draught envt)
+!C      qs1           Real           Input        sat specific hum (sat draught envt)
+!C      t1_wake       Real           Input        temperature (unsat draught envt)
+!C      q1_wake       Real           Input        specific hum(unsat draught envt)
+!C      qs1_wake      Real           Input        sat specific hum(unsat draughts envt)
+!C      s1_wake       Real           Input        fractionnal area covered by wakes
+!C      u1            Real           Input        u-wind
+!C      v1            Real           Input        v-wind
+!C      tra1          Real           Input        tracors
+!C      p1            Real           Input        full level pressure
+!C      ph1           Real           Input        half level pressure
+!C      ALE1          Real           Input        Available lifting Energy
+!C      ALP1          Real           Input        Available lifting Power
+!C      sig1feed1     Real           Input        sigma coord at lower bound of feeding layer
+!C      sig2feed1     Real           Input        sigma coord at upper bound of feeding layer
+!C      wght1         Real           Input        weight density determining the feeding mixture
+!C      iflag1        Integer        Output       flag for Emanuel conditions
+!C      ft1           Real           Output       temp tend
+!C      fq1           Real           Output       spec hum tend
+!C      fu1           Real           Output       u-wind tend
+!C      fv1           Real           Output       v-wind tend
+!C      ftra1         Real           Output       tracor tend
+!C      precip1       Real           Output       precipitation
+!C      kbas1         Integer        Output       cloud base level
+!C      ktop1         Integer        Output       cloud top level
+!C      cbmf1         Real           Output       cloud base mass flux
+!C      sig1          Real           In/Out       section adiabatic updraft
+!C      w01           Real           In/Out       vertical velocity within adiab updraft
+!C      ptop21        Real           In/Out       top of entraining zone
+!C      Ma1           Real           Output       mass flux adiabatic updraft
+!C      mip1          Real           Output       mass flux shed by the adiabatic updraft
+!C      Vprecip1      Real           Output       vertical profile of precipitations
+!C      upwd1         Real           Output       total upward mass flux (adiab+mixed)
+!C      dnwd1         Real           Output       saturated downward mass flux (mixed)
+!C      dnwd01        Real           Output       unsaturated downward mass flux
+!C      qcondc1       Real           Output       in-cld mixing ratio of condensed water
+!C      wd1           Real           Output       downdraft velocity scale for sfc fluxes
+!C      cape1         Real           Output       CAPE
+!C      cin1          Real           Output       CIN
+!C      tvp1          Real           Output       adiab lifted parcell virt temp
+!C      ftd1          Real           Output       precip temp tend
+!C      fqt1          Real           Output       precip spec hum tend
+!C      Plim11        Real           Output
+!C      Plim21        Real           Output
+!C      asupmax1      Real           Output
+!C      supmax01      Real           Output
+!C      asupmaxmin1   Real           Output
+!
+!      ftd1          Real           Output  Array of temperature tendency due to precipitations (K/s) of dimension ND,
+!                                           defined at same grid levels as T, Q, QS and P.
+!    
+!      fqd1          Real           Output  Array of specific humidity tendencies due to precipitations ((gm/gm)/s)
+!                                           of dimension ND, defined at same grid levels as T, Q, QS and P.
+!    
+!      wdtrainA1     Real           Output   precipitation detrained from adiabatic draught;
+!                                                       used in tracer transport (cvltr)
+!      wdtrainM1     Real           Output   precipitation detrained from mixed draughts;
+!                                                       used in tracer transport (cvltr)
+!      da1           Real           Output   used in tracer transport (cvltr)
+!      phi1          Real           Output   used in tracer transport (cvltr)
+!      mp1           Real           Output   used in tracer transport (cvltr)
+!    
+!      phi21         Real           Output   used in tracer transport (cvltr)
+!    
+!      d1a1          Real           Output   used in tracer transport (cvltr)
+!      dam1          Real           Output   used in tracer transport (cvltr)
+!    
+!      epmlmMm1      Real           Output   used in tracer transport (cvltr)
+!      eplaMm1       Real           Output   used in tracer transport (cvltr)
+!
+!      evap1         Real           Output
+!      ep1           Real           Output
+!      sigij1        Real           Output
+!      elij1         Real           Output
+
+!C
+!C S. Bony, Mar 2002:
+!C 	* Several modules corresponding to different physical processes
+!C 	* Several versions of convect may be used:
+!C  		- iflag_con=3: version lmd  (previously named convect3)
+!C  		- iflag_con=4: version 4.3b (vect. version, previously convect1/2)
+!C   + tard: 	- iflag_con=5: version lmd with ice (previously named convectg)
+!C S. Bony, Oct 2002:
+!C	* Vectorization of convect3 (ie version lmd)
+!C
+!C..............................END PROLOGUE.............................
+!c
+!c
+#include "dimensions.h"
+!ccccc#include "dimphy.h"
+      include 'iniprint.h'
+
+!c
+!c Input
+      integer len
+      integer nd
+      integer ndp1
+      integer ntra
+      integer iflag_con
+      integer iflag_mix
+      integer iflag_clos
+      real delt
+      real t1(len,nd)
+      real q1(len,nd)
+      real qs1(len,nd)
+      real t1_wake(len,nd)
+      real q1_wake(len,nd)
+      real qs1_wake(len,nd)
+      real s1_wake(len)
+      real u1(len,nd)
+      real v1(len,nd)
+      real tra1(len,nd,ntra)
+      real p1(len,nd)
+      real ph1(len,ndp1)
+      real ALE1(len)
+      real ALP1(len)
+      real sig1feed1 ! pressure at lower bound of feeding layer
+      real sig2feed1 ! pressure at upper bound of feeding layer
+      real wght1(nd) ! weight density determining the feeding mixture
+!c
+!c Output
+      integer iflag1(len)
+      real ft1(len,nd)
+      real fq1(len,nd)
+      real fu1(len,nd)
+      real fv1(len,nd)
+      real ftra1(len,nd,ntra)
+      real precip1(len)
+      integer kbas1(len)
+      integer ktop1(len)
+      real cbmf1(len)
+      real plcl1(klon)
+      real plfc1(klon)
+      real wbeff1(klon)
+      real sig1(len,klev)      !input/output
+      real w01(len,klev)       !input/output
+      real ptop21(len)
+      real sigd1(len)
+      real Ma1(len,nd)
+      real mip1(len,nd)
+!      real Vprecip1(len,nd)
+      real Vprecip1(len,nd+1)
+      real upwd1(len,nd)
+      real dnwd1(len,nd)
+      real dnwd01(len,nd)
+      real qcondc1(len,nd)     ! cld
+      real wd1(len)            ! gust
+      real cape1(len)
+      real cin1(len)
+      real tvp1(len,nd)
+!c
+!AC!
+!!      real da1(len,nd),phi1(len,nd,nd)
+!!      real da(len,nd),phi(len,nd,nd)
+!AC!
+      real ftd1(len,nd)
+      real fqd1(len,nd)
+      real Plim11(len)
+      real Plim21(len)
+      real asupmax1(len,nd)
+      real supmax01(len)
+      real asupmaxmin1(len)
+      integer lalim_conv(len)
+! RomP >>> 
+      real wdtrainA1(len,nd), wdtrainM1(len,nd)
+      real da1(len,nd),phi1(len,nd,nd),mp1(len,nd)
+      real epmlmMm1(len,nd,nd),eplaMm1(len,nd)
+      real evap1(len,nd),ep1(len,nd)
+      real sigij1(len,nd,nd),elij1(len,nd,nd)
+      real phi21(len,nd,nd)
+      real d1a1(len,nd), dam1(len,nd)
+! RomP <<<
+!
+!-------------------------------------------------------------------
+!        Prolog by Kerry Emanuel.
+!-------------------------------------------------------------------
+! --- ARGUMENTS
+!-------------------------------------------------------------------
+! --- On input:
+!
+!  t:   Array of absolute temperature (K) of dimension ND, with first
+!       index corresponding to lowest model level. Note that this array
+!       will be altered by the subroutine if dry convective adjustment
+!       occurs and if IPBL is not equal to 0.
+!
+!  q:   Array of specific humidity (gm/gm) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  qs:  Array of saturation specific humidity of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+! t_wake: Array of absolute temperature (K), seen by unsaturated draughts,
+!       of dimension ND, with first index corresponding to lowest model level.
+!
+! q_wake: Array of specific humidity (gm/gm), seen by unsaturated draughts,
+!       of dimension ND, with first index corresponding to lowest model level.
+!       Must be defined at same grid levels as T.
+!
+!qs_wake: Array of saturation specific humidity, seen by unsaturated draughts,
+!       of dimension ND, with first index corresponding to lowest model level.
+!       Must be defined at same grid levels as T.
+!
+!s_wake: Array of fractionnal area occupied by the wakes.
+!
+!  u:   Array of zonal wind velocity (m/s) of dimension ND, witth first
+!       index corresponding with the lowest model level. Defined at
+!       same levels as T. Note that this array will be altered if
+!       dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  v:   Same as u but for meridional velocity.
+!
+!  tra: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
+!       where NTRA is the number of different tracers. If no
+!       convective tracer transport is needed, define a dummy
+!       input array of dimension (ND,1). Tracers are defined at
+!       same vertical levels as T. Note that this array will be altered
+!       if dry convective adjustment occurs and if IPBL is not equal to 0.
+!
+!  p:   Array of pressure (mb) of dimension ND, with first
+!       index corresponding to lowest model level. Must be defined
+!       at same grid levels as T.
+!
+!  ph:  Array of pressure (mb) of dimension ND+1, with first index
+!       corresponding to lowest level. These pressures are defined at
+!       levels intermediate between those of P, T, Q and QS. The first
+!       value of PH should be greater than (i.e. at a lower level than)
+!       the first value of the array P.
+!
+! ALE:  Available lifting Energy
+!
+! ALP:  Available lifting Power
+!
+!  nl:  The maximum number of levels to which convection can penetrate, plus 1.
+!       NL MUST be less than or equal to ND-1.
+!
+!  delt: The model time step (sec) between calls to CONVECT
+!
+!----------------------------------------------------------------------------
+! ---   On Output:
+!
+!  iflag: An output integer whose value denotes the following:
+!       VALUE   INTERPRETATION
+!       -----   --------------
+!         0     Moist convection occurs.
+!         1     Moist convection occurs, but a CFL condition
+!               on the subsidence warming is violated. This
+!               does not cause the scheme to terminate.
+!         2     Moist convection, but no precip because ep(inb) lt 0.0001
+!         3     No moist convection because new cbmf is 0 and old cbmf is 0.
+!         4     No moist convection; atmosphere is not
+!               unstable
+!         6     No moist convection because ihmin le minorig.
+!         7     No moist convection because unreasonable
+!               parcel level temperature or specific humidity.
+!         8     No moist convection: lifted condensation
+!               level is above the 200 mb level.
+!         9     No moist convection: cloud base is higher
+!               then the level NL-1.
+!
+!  ft:   Array of temperature tendency (K/s) of dimension ND, defined at same
+!        grid levels as T, Q, QS and P.
+!
+!  fq:   Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
+!        defined at same grid levels as T, Q, QS and P.
+!
+!  fu:   Array of forcing of zonal velocity (m/s^2) of dimension ND,
+!        defined at same grid levels as T.
+!
+!  fv:   Same as FU, but for forcing of meridional velocity.
+!
+!  ftra: Array of forcing of tracer content, in tracer mixing ratio per
+!        second, defined at same levels as T. Dimensioned (ND,NTRA).
+!
+!  precip: Scalar convective precipitation rate (mm/day).
+!
+!  wd:   A convective downdraft velocity scale. For use in surface
+!        flux parameterizations. See convect.ps file for details.
+!
+!  tprime: A convective downdraft temperature perturbation scale (K).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  qprime: A convective downdraft specific humidity
+!          perturbation scale (gm/gm).
+!          For use in surface flux parameterizations. See convect.ps
+!          file for details.
+!
+!  cbmf: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
+!        BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
+!        ITS NEXT CALL. That is, the value of CBMF must be "remembered"
+!        by the calling program between calls to CONVECT.
+!
+!  det:   Array of detrainment mass flux of dimension ND.
+!-------------------------------------------------------------------
+!c
+!c  Local arrays
+!c
+
+      integer i,k,n,il,j
+      integer nword1,nword2,nword3,nword4
+      integer icbmax
+      integer nk1(klon)
+      integer icb1(klon)
+      integer icbs1(klon)
+
+      logical ok_inhib  ! True => possible inhibition of convection by dryness
+      logical, save :: debut=.true. 
+!$OMP THREADPRIVATE(debut)
+
+      real tnk1(klon)
+      real thnk1(klon)
+      real qnk1(klon)
+      real gznk1(klon)
+      real pnk1(klon)
+      real qsnk1(klon)
+      real unk1(klon)
+      real vnk1(klon)
+      real cpnk1(klon)
+      real hnk1(klon)
+      real pbase1(klon)
+      real buoybase1(klon)
+
+      real lv1(klon,klev) ,lv1_wake(klon,klev)
+      real cpn1(klon,klev),cpn1_wake(klon,klev)
+      real tv1(klon,klev) ,tv1_wake(klon,klev)
+      real gz1(klon,klev) ,gz1_wake(klon,klev)
+      real hm1(klon,klev) ,hm1_wake(klon,klev)
+      real h1(klon,klev)  ,h1_wake(klon,klev)
+      real tp1(klon,klev)
+      real clw1(klon,klev)
+      real th1(klon,klev) ,th1_wake(klon,klev)
+!c
+      real bid(klon,klev)   ! dummy array
+!c
+      integer ncum
+!c
+      integer j1feed(klon)
+      integer j2feed(klon)
+      real p1feed1(len) ! pressure at lower bound of feeding layer
+      real p2feed1(len) ! pressure at upper bound of feeding layer
+      real wghti1(len,nd) ! weights of the feeding layers
+!c
+!c (local) compressed fields:
+!c
+      integer nloc
+!c      parameter (nloc=klon) ! pour l'instant
+
+      integer idcum(nloc)
+      integer iflag(nloc),nk(nloc),icb(nloc)
+      integer nent(nloc,klev)
+      integer icbs(nloc)
+      integer inb(nloc), inbis(nloc)
+
+      real cbmf(nloc),plcl(nloc),plfc(nloc),wbeff(nloc)
+      real t(nloc,klev),q(nloc,klev),qs(nloc,klev)
+      real t_wake(nloc,klev),q_wake(nloc,klev),qs_wake(nloc,klev)
+      real s_wake(nloc)
+      real u(nloc,klev),v(nloc,klev)
+      real gz(nloc,klev),h(nloc,klev)     ,hm(nloc,klev)
+      real               h_wake(nloc,klev),hm_wake(nloc,klev)
+      real lv(nloc,klev)     ,cpn(nloc,klev)
+      real lv_wake(nloc,klev),cpn_wake(nloc,klev)
+      real p(nloc,klev),ph(nloc,klev+1),tv(nloc,klev)    ,tp(nloc,klev)
+      real                              tv_wake(nloc,klev)
+      real clw(nloc,klev)
+      real dph(nloc,klev)
+      real pbase(nloc), buoybase(nloc), th(nloc,klev)
+      real                              th_wake(nloc,klev)
+      real tvp(nloc,klev)
+      real sig(nloc,klev), w0(nloc,klev), ptop2(nloc)
+      real hp(nloc,klev), ep(nloc,klev), sigp(nloc,klev)
+      real frac(nloc), buoy(nloc,klev)
+      real cape(nloc)
+      real cin(nloc)
+      real m(nloc,klev)
+      real ment(nloc,klev,klev), sigij(nloc,klev,klev)
+      real qent(nloc,klev,klev)
+      real hent(nloc,klev,klev)
+      real uent(nloc,klev,klev), vent(nloc,klev,klev)
+      real ments(nloc,klev,klev), qents(nloc,klev,klev)
+      real elij(nloc,klev,klev)
+      real supmax(nloc,klev)
+      real ale(nloc),alp(nloc),coef_clos(nloc)
+      real sigd(nloc)
+!      real mp(nloc,klev), qp(nloc,klev), up(nloc,klev), vp(nloc,klev)
+!      real wt(nloc,klev), water(nloc,klev), evap(nloc,klev)
+!      real b(nloc,klev), sigd(nloc)
+!      save mp,qp,up,vp,wt,water,evap,b
+      real, save, allocatable :: mp(:,:),qp(:,:),up(:,:),vp(:,:)
+      real, save, allocatable :: wt(:,:),water(:,:),evap(:,:), b(:,:)
+!$OMP THREADPRIVATE(mp,qp,up,vp,wt,water,evap,b)
+      real  ft(nloc,klev), fq(nloc,klev)
+      real ftd(nloc,klev), fqd(nloc,klev)
+      real fu(nloc,klev), fv(nloc,klev)
+      real upwd(nloc,klev), dnwd(nloc,klev), dnwd0(nloc,klev)
+      real Ma(nloc,klev), mip(nloc,klev), tls(nloc,klev)
+      real tps(nloc,klev), qprime(nloc), tprime(nloc)
+      real precip(nloc)
+!      real Vprecip(nloc,klev)
+      real Vprecip(nloc,klev+1)
+      real tra(nloc,klev,ntra), trap(nloc,klev,ntra)
+      real ftra(nloc,klev,ntra), traent(nloc,klev,klev,ntra)
+      real qcondc(nloc,klev)  ! cld
+      real wd(nloc)           ! gust
+      real Plim1(nloc),Plim2(nloc)
+      real asupmax(nloc,klev)
+      real supmax0(nloc)
+      real asupmaxmin(nloc)
+!c
+      real tnk(nloc),qnk(nloc),gznk(nloc)
+      real wghti(nloc,nd)
+      real hnk(nloc),unk(nloc),vnk(nloc)
+!
+! RomP >>> 
+      real wdtrainA(nloc,klev),wdtrainM(nloc,klev)
+      real da(len,nd),phi(len,nd,nd)
+      real epmlmMm(nloc,klev,klev),eplaMm(nloc,klev)  
+      real phi2(len,nd,nd)
+      real d1a(len,nd), dam(len,nd)
+! RomP <<<
+!
+      logical, save :: first=.true.
+!$OMP THREADPRIVATE(first)
+      CHARACTER (LEN=20) :: modname='cva_driver'
+      CHARACTER (LEN=80) :: abort_message
+
+!c
+!      print *, 't1, t1_wake ',(k,t1(1,k),t1_wake(1,k),k=1,klev)
+!      print *, 'q1, q1_wake ',(k,q1(1,k),q1_wake(1,k),k=1,klev)
+
+!-------------------------------------------------------------------
+! --- SET CONSTANTS AND PARAMETERS
+!-------------------------------------------------------------------
+
+       if (first) then
+         allocate(mp(nloc,klev), qp(nloc,klev), up(nloc,klev))
+         allocate(vp(nloc,klev), wt(nloc,klev), water(nloc,klev))
+         allocate(evap(nloc,klev), b(nloc,klev))
+         first=.false.
+       endif
+!c -- set simulation flags:
+!c   (common cvflag)
+
+       CALL cv_flag
+
+!c -- set thermodynamical constants:
+!c 	(common cvthermo)
+
+       CALL cv_thermo(iflag_con)
+
+!c -- set convect parameters
+!c
+!c 	includes microphysical parameters and parameters that
+!c  	control the rate of approach to quasi-equilibrium)
+!c 	(common cvparam)
+
+      if (iflag_con.eq.3) then
+       CALL cv3_param(nd,delt)
+  
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_param(nd)
+      endif
+
+!---------------------------------------------------------------------
+! --- INITIALIZE OUTPUT ARRAYS AND PARAMETERS
+!---------------------------------------------------------------------
+      nword1=len
+      nword2=len*nd
+      nword3=len*nd*ntra
+      nword4=len*nd*nd
+ 
+      iflag1(:)     = 0
+      ktop1(:)      = 0
+      kbas1(:)      = 0
+      ft1(:,:)      = 0.0
+      fq1(:,:)      = 0.0
+      fu1(:,:)      = 0.0
+      fv1(:,:)      = 0.0
+      ftra1(:,:,:)  = 0.
+      precip1(:)    = 0.
+      cbmf1(:)      = 0.
+      ptop21(:)     = 0.
+      sigd1(:)      = 0.
+      Ma1(:,:)      = 0.
+      mip1(:,:)     = 0.
+      Vprecip1(:,:) = 0.
+      upwd1   (:,:) = 0.
+      dnwd1   (:,:) = 0.
+      dnwd01  (:,:) = 0.
+      qcondc1 (:,:) = 0.
+      wd1     (:)   = 0.
+      cape1   (:)   = 0.
+      cin1    (:)   = 0.
+      tvp1    (:,:) = 0.
+      ftd1    (:,:) = 0.
+      fqd1    (:,:) = 0.
+      Plim11  (:)   = 0.
+      Plim21  (:)   = 0.
+      asupmax1(:,:) = 0.
+      supmax01(:)   = 0.
+      asupmaxmin1(:)= 0.
+!c
+      DO il = 1,len
+       cin1(il) = -100000.
+       cape1(il) = -1.
+      ENDDO
+!c  
+      if (iflag_con.eq.3) then
+        do il=1,len
+         sig1(il,nd)=sig1(il,nd)+1.
+         sig1(il,nd)=amin1(sig1(il,nd),12.1)
+        enddo
+      endif
+  
+! RomP >>> 
+       wdtrainA1(:,:)  = 0.
+       wdtrainM1(:,:)  = 0.
+       da1(:,:)        = 0.
+       phi1(:,:,:)     = 0.
+       epmlmMm1(:,:,:) = 0.
+       eplaMm1(:,:)    = 0.
+       mp1(:,:)        = 0.
+       evap1(:,:)      = 0.
+       ep1(:,:)        = 0.
+       sigij1(:,:,:)   = 0.
+       elij1(:,:,:)    = 0.
+       phi21(:,:,:)    = 0.
+       d1a1(:,:)       = 0.
+       dam1(:,:)       = 0.
+! RomP <<<
+!---------------------------------------------------------------------
+! --- INITIALIZE LOCAL ARRAYS AND PARAMETERS
+!---------------------------------------------------------------------
+!
+      do il = 1,nloc
+         coef_clos(il)=1.
+      enddo
+
+!--------------------------------------------------------------------
+! --- CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY & STATIC ENERGY
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+  
+       if (debut) THEN 
+        print*,'Emanuel version 3 nouvelle'
+       endif 
+!       print*,'t1, q1 ',t1,q1
+       CALL cv3_prelim(len,nd,ndp1,t1,q1,p1,ph1                                      & ! nd->na
+       &               ,lv1,cpn1,tv1,gz1,h1,hm1,th1)
+    
+!c
+       CALL cv3_prelim(len,nd,ndp1,t1_wake,q1_wake,p1,ph1                            & ! nd->na
+       &               ,lv1_wake,cpn1_wake,tv1_wake,gz1_wake                         &
+       &               ,h1_wake,bid,th1_wake)
+    
+      endif
+!c
+      if (iflag_con.eq.4) then
+       print*,'Emanuel version 4 '
+       CALL cv_prelim(len,nd,ndp1,t1,q1,p1,ph1                                       &
+       &               ,lv1,cpn1,tv1,gz1,h1,hm1)
+      endif
+
+!--------------------------------------------------------------------
+! --- CONVECTIVE FEED
+!--------------------------------------------------------------------
+!
+! compute feeding layer potential temperature and mixing ratio :
+!
+! get bounds of feeding layer
+!
+!c test niveaux couche alimentation KE
+       if(sig1feed1.eq.sig2feed1) then
+         write(lunout,*)'impossible de choisir sig1feed=sig2feed'
+         write(lunout,*)'changer la valeur de sig2feed dans physiq.def'
+         abort_message = ''
+         CALL abort_gcm (modname,abort_message,1)
+       endif
+!c
+       do i=1,len
+         p1feed1(i)=sig1feed1*ph1(i,1)
+         p2feed1(i)=sig2feed1*ph1(i,1)
+!ctest maf
+!c         p1feed1(i)=ph1(i,1)
+!c         p2feed1(i)=ph1(i,2)
+!c         p2feed1(i)=ph1(i,3)
+!ctestCR: on prend la couche alim des thermiques
+!c          p2feed1(i)=ph1(i,lalim_conv(i)+1)
+!c          print*,'lentr=',lentr(i),ph1(i,lentr(i)+1),ph1(i,2)
+       end do
+!
+       if (iflag_con.eq.3) then
+       endif
+      do i=1,len
+!      print*,'avant cv3_feed plim',p1feed1(i),p2feed1(i)
+      enddo
+      if (iflag_con.eq.3) then
+ 
+!c     print*, 'IFLAG1 avant cv3_feed'
+!c     print*,'len,nd',len,nd
+!c     write(*,'(64i1)') iflag1(2:klon-1)
+
+       CALL cv3_feed(len,nd,t1,q1,u1,v1,p1,ph1,hm1,gz1                               & ! nd->na
+       &         ,p1feed1,p2feed1,wght1                                              &
+       &         ,wghti1,tnk1,thnk1,qnk1,qsnk1,unk1,vnk1                             &
+       &         ,cpnk1,hnk1,nk1,icb1,icbmax,iflag1,gznk1,plcl1)
+      endif
+    
+!c     print*, 'IFLAG1 apres cv3_feed'
+!c     print*,'len,nd',len,nd
+!c     write(*,'(64i1)') iflag1(2:klon-1)
+
+      if (iflag_con.eq.4) then
+       CALL cv_feed(len,nd,t1,q1,qs1,p1,hm1,gz1                                      &
+       &         ,nk1,icb1,icbmax,iflag1,tnk1,qnk1,gznk1,plcl1)
+      endif
+!c
+!      print *, 'cv3_feed-> iflag1, plcl1 ',iflag1(1),plcl1(1)
+!c
+!--------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / 1st part
+! (up through ICB for convect4, up through ICB+1 for convect3)
+!     Calculates the lifted parcel virtual temperature at nk, the
+!     actual temperature, and the adiabatic liquid water content.
+!--------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+    
+       CALL cv3_undilute1(len,nd,t1,qs1,gz1,plcl1,p1,icb1,tnk1,qnk1                  & ! nd->na
+       &                    ,gznk1,tp1,tvp1,clw1,icbs1)
+      endif
+   
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute1(len,nd,t1,q1,qs1,gz1,p1,nk1,icb1,icbmax                     &
+       &                        ,tp1,tvp1,clw1)
+      endif
+!c
+!-------------------------------------------------------------------
+! --- TRIGGERING
+!-------------------------------------------------------------------
+!c
+!      print *,' avant triggering, iflag_con ',iflag_con
+!c
+      if (iflag_con.eq.3) then
+    
+       CALL cv3_trigger(len,nd,icb1,plcl1,p1,th1,tv1,tvp1,thnk1                      & ! nd->na
+       &                 ,pbase1,buoybase1,iflag1,sig1,w01)
+    
+
+!c     print*, 'IFLAG1 apres cv3_triger'
+!c     print*,'len,nd',len,nd
+!c     write(*,'(64i1)') iflag1(2:klon-1)
+
+!c     call dump2d(iim,jjm-1,sig1(2)
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_trigger(len,nd,icb1,cbmf1,tv1,tvp1,iflag1)
+      endif
+!c
+!c
+!=====================================================================
+! --- IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY
+!=====================================================================
+
+      ncum=0
+      do 400 i=1,len
+        if(iflag1(i).eq.0)then
+           ncum=ncum+1
+           idcum(ncum)=i
+        endif
+ 400  continue
+!c
+!       print*,'klon, ncum = ',len,ncum
+!c
+      IF (ncum.gt.0) THEN
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- COMPRESS THE FIELDS
+!		(-> vectorization over convective gridpoints)
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.3) then
+!       print*,'ncum tv1 ',ncum,tv1 
+!       print*,'tvp1 ',tvp1
+       CALL cv3a_compress( len,nloc,ncum,nd,ntra                                     &
+       &    ,iflag1,nk1,icb1,icbs1                                                   &
+       &    ,plcl1,tnk1,qnk1,gznk1,hnk1,unk1,vnk1                                    &
+       &    ,wghti1,pbase1,buoybase1                                                 &
+       &    ,t1,q1,qs1,t1_wake,q1_wake,qs1_wake,s1_wake                              &
+       &    ,u1,v1,gz1,th1,th1_wake                                                  &
+       &    ,tra1                                                                    &
+       &    ,h1     ,lv1     ,cpn1   ,p1,ph1,tv1    ,tp1,tvp1,clw1                   &
+       &    ,h1_wake,lv1_wake,cpn1_wake     ,tv1_wake                                &
+       &    ,sig1,w01,ptop21                                                         &
+       &    ,Ale1,Alp1                                                               &
+       &    ,iflag,nk,icb,icbs                                                       &
+       &    ,plcl,tnk,qnk,gznk,hnk,unk,vnk                                           &
+       &    ,wghti,pbase,buoybase                                                    &
+       &    ,t,q,qs,t_wake,q_wake,qs_wake,s_wake                                     &
+       &    ,u,v,gz,th,th_wake                                                       &
+       &    ,tra                                                                     &
+       &    ,h     ,lv     ,cpn    ,p,ph,tv    ,tp,tvp,clw                           &
+       &    ,h_wake,lv_wake,cpn_wake    ,tv_wake                                     &
+       &    ,sig,w0,ptop2                                                            &
+       &    ,Ale,Alp  ) 
+
+!       print*,'tv ',tv
+!       print*,'tvp ',tvp
+
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_compress( len,nloc,ncum,nd                                            &
+       &    ,iflag1,nk1,icb1                                                         &
+       &    ,cbmf1,plcl1,tnk1,qnk1,gznk1                                             &
+       &    ,t1,q1,qs1,u1,v1,gz1                                                     &
+       &    ,h1,lv1,cpn1,p1,ph1,tv1,tp1,tvp1,clw1                                    &
+       &    ,iflag,nk,icb                                                            &
+       &    ,cbmf,plcl,tnk,qnk,gznk                                                  &
+       &    ,t,q,qs,u,v,gz,h,lv,cpn,p,ph,tv,tp,tvp,clw                               &
+       &    ,dph )
+      endif
+
+!-------------------------------------------------------------------
+! --- UNDILUTE (ADIABATIC) UPDRAFT / second part :
+! ---   FIND THE REST OF THE LIFTED PARCEL TEMPERATURES
+! ---   &
+! ---   COMPUTE THE PRECIPITATION EFFICIENCIES AND THE
+! ---   FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD
+! ---   &
+! ---   FIND THE LEVEL OF NEUTRAL BUOYANCY
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+       CALL cv3_undilute2(nloc,ncum,nd,icb,icbs,nk                                   & !na->nd
+       &                        ,tnk,qnk,gznk,hnk,t,q,qs,gz                          &
+       &                        ,p,h,tv,lv,pbase,buoybase,plcl                       &
+       &                        ,inb,tp,tvp,clw,hp,ep,sigp,buoy)
+   
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_undilute2(nloc,ncum,nd,icb,nk                                         &
+       &                        ,tnk,qnk,gznk,t,q,qs,gz                              &
+       &                        ,p,dph,h,tv,lv                                       &
+       &             ,inb,inbis,tp,tvp,clw,hp,ep,sigp,frac)
+      endif
+!c
+!-------------------------------------------------------------------
+! --- MIXING(1)   (if iflag_mix .ge. 1)
+!-------------------------------------------------------------------
+      IF (iflag_con .eq. 3) THEN
+       IF (iflag_mix .ge. 1 ) THEN
+         CALL zilch(supmax,nloc*klev)    
+         CALL cv3p_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb                            & ! na->nd
+       &                       ,ph,t,q,qs,u,v,tra,h,lv,qnk                           &
+       &                       ,unk,vnk,hp,tv,tvp,ep,clw,sig                         &
+       &                    ,ment,qent,hent,uent,vent,nent                           &
+       &                   ,sigij,elij,supmax,ments,qents,traent)
+!        print*, 'cv3p_mixing-> supmax ', (supmax(1,k), k=1,nd)
+      
+       ELSE
+        CALL zilch(supmax,nloc*klev)
+       ENDIF
+      ENDIF
+!-------------------------------------------------------------------
+! --- CLOSURE
+!-------------------------------------------------------------------
+
+!c
+      if (iflag_con.eq.3) then
+       IF (iflag_clos .eq. 0) THEN
+        CALL cv3_closure(nloc,ncum,nd,icb,inb                                        & ! na->nd
+       &                       ,pbase,p,ph,tv,buoy                                   &
+       &                       ,sig,w0,cape,m,iflag)
+       ENDIF
+!c
+       ok_inhib = iflag_mix .EQ. 2
+!c
+       IF (iflag_clos .eq. 1) THEN
+        print *,' pas d appel cv3p_closure'
+!cc        CALL cv3p_closure(nloc,ncum,nd,icb,inb              ! na->nd
+!cc    :                       ,pbase,plcl,p,ph,tv,tvp,buoy
+!cc    :                       ,supmax
+!cc    o                       ,sig,w0,ptop2,cape,cin,m)
+       ENDIF
+       IF (iflag_clos .eq. 2) THEN
+        CALL cv3p1_closure(nloc,ncum,nd,icb,inb                                      & ! na->nd
+       &                       ,pbase,plcl,p,ph,tv,tvp,buoy                          &
+       &                       ,supmax,ok_inhib,Ale,Alp                              &
+       &                       ,sig,w0,ptop2,cape,cin,m,iflag,coef_clos              &
+       &                       ,Plim1,Plim2,asupmax,supmax0                          &
+       &                       ,asupmaxmin,cbmf,plfc,wbeff)
+       
+        print *,'cv3p1_closure-> plfc,wbeff ', plfc(1),wbeff(1)
+       ENDIF
+      endif   ! iflag_con.eq.3
+  
+      if (iflag_con.eq.4) then
+       CALL cv_closure(nloc,ncum,nd,nk,icb                                           &
+       &                ,tv,tvp,p,ph,dph,plcl,cpn                                    &
+       &                ,iflag,cbmf)
+      endif
+!c
+!      print *,'cv_closure-> cape ',cape(1)
+!c
+!-------------------------------------------------------------------
+! --- MIXING(2)
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+        IF (iflag_mix.eq.0) THEN
+         CALL cv3_mixing(nloc,ncum,nd,nd,ntra,icb,nk,inb                             & ! na->nd
+       &                       ,ph,t,q,qs,u,v,tra,h,lv,qnk                           &
+       &                       ,unk,vnk,hp,tv,tvp,ep,clw,m,sig                       &
+       &   ,ment,qent,uent,vent,nent,sigij,elij,ments,qents,traent)
+         CALL zilch(hent,nloc*klev*klev)
+        ELSE
+         CALL cv3_mixscale(nloc,ncum,nd,ment,m)
+         if (debut) THEN 
+          print *,' cv3_mixscale-> '
+         endif !(debut) THEN 
+        ENDIF
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_mixing(nloc,ncum,nd,icb,nk,inb,inbis                                  &
+       &                     ,ph,t,q,qs,u,v,h,lv,qnk                                 &
+       &                     ,hp,tv,tvp,ep,clw,cbmf                                  &
+       &                     ,m,ment,qent,uent,vent,nent,sigij,elij)
+      endif
+!c
+      if (debut) THEN 
+       print *,' cv_mixing ->'
+      endif !(debut) THEN 
+!c      do i = 1,klev
+!c        print*,'cv_mixing-> i,ment ',i,(ment(1,i,j),j=1,klev)
+!c      enddo
+!c
+!-------------------------------------------------------------------
+! --- UNSATURATED (PRECIPITATING) DOWNDRAFTS
+!-------------------------------------------------------------------
+      if (iflag_con.eq.3) then
+       if (debut) THEN 
+        print *,' cva_driver -> cv3_unsat '
+       endif !(debut) THEN 
+    
+       CALL cv3_unsat(nloc,ncum,nd,nd,ntra,icb,inb,iflag                             & ! na->nd
+       &               ,t_wake,q_wake,qs_wake,gz,u,v,tra,p,ph                        &
+       &               ,th_wake,tv_wake,lv_wake,cpn_wake                             &
+       &               ,ep,sigp,clw                                                  &
+       &               ,m,ment,elij,delt,plcl,coef_clos                              &
+       &          ,mp,qp,up,vp,trap,wt,water,evap,b,sigd                             &
+       &          ,wdtrainA,wdtrainM)   ! RomP
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_unsat(nloc,ncum,nd,inb,t,q,qs,gz,u,v,p,ph                             &
+       &                   ,h,lv,ep,sigp,clw,m,ment,elij                             &
+       &                   ,iflag,mp,qp,up,vp,wt,water,evap)
+      endif
+!c
+      if (debut) THEN 
+       print *,'cv_unsat-> '
+      endif !(debut) THEN
+!
+!c      print *,'cv_unsat-> mp ',mp
+!c      print *,'cv_unsat-> water ',water
+!-------------------------------------------------------------------
+! --- YIELD
+!     (tendencies, precipitation, variables of interface with other
+!      processes, etc)
+!-------------------------------------------------------------------
+
+      if (iflag_con.eq.3) then
+  
+       CALL cv3_yield(nloc,ncum,nd,nd,ntra                                           & ! na->nd
+       &                     ,icb,inb,delt                                           &
+       &                     ,t,q,t_wake,q_wake,s_wake,u,v,tra                       &
+       &                     ,gz,p,ph,h,hp,lv,cpn,th,th_wake                         &
+       &                     ,ep,clw,m,tp,mp,qp,up,vp,trap                           &
+       &                     ,wt,water,evap,b,sigd                                   &
+       &                    ,ment,qent,hent,iflag_mix,uent,vent                      &
+       &                    ,nent,elij,traent,sig                                    &
+       &                    ,tv,tvp,wghti                                            &
+       &                    ,iflag,precip,Vprecip,ft,fq,fu,fv,ftra                   &
+       &                    ,cbmf,upwd,dnwd,dnwd0,ma,mip                             &
+       &                    ,tls,tps,qcondc,wd                                       &
+       &                    ,ftd,fqd)
+      endif
+!c
+      if (debut) THEN 
+       print *,' cv3_yield -> fqd(1) = ',fqd(1,1)
+      endif !(debut) THEN
+!c
+      if (iflag_con.eq.4) then
+       CALL cv_yield(nloc,ncum,nd,nk,icb,inb,delt                                    &
+       &              ,t,q,u,v                                                       &
+       &              ,gz,p,ph,h,hp,lv,cpn                                           &
+       &              ,ep,clw,frac,m,mp,qp,up,vp                                     &
+       &              ,wt,water,evap                                                 &
+       &              ,ment,qent,uent,vent,nent,elij                                 &
+       &              ,tv,tvp                                                        &
+       &              ,iflag,wd,qprime,tprime                                        &
+       &              ,precip,cbmf,ft,fq,fu,fv,Ma,qcondc)
+      endif
+
+!AC!
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- passive tracers
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+      if (iflag_con.eq.3) then
+!RomP >>>
+       CALL cv3_tracer(nloc,len,ncum,nd,nd,                                          &
+       &                  ment,sigij,da,phi,phi2,d1a,dam,                            &
+       &                  ep,Vprecip,elij,clw,epmlmMm,eplaMm,                        &
+       &                  icb,inb)
+!RomP <<<
+      endif
+
+!AC!
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! --- UNCOMPRESS THE FIELDS
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+
+      if (iflag_con.eq.3) then
+       CALL cv3a_uncompress(nloc,len,ncum,nd,ntra,idcum                              &
+       &          ,iflag,icb,inb                                                     &
+       &          ,precip,cbmf,plcl,plfc,wbeff,sig,w0,ptop2                          &
+       &          ,ft,fq,fu,fv,ftra                                                  &
+       &          ,sigd,Ma,mip,Vprecip,upwd,dnwd,dnwd0                               &
+       &          ,qcondc,wd,cape,cin                                                &
+       &          ,tvp                                                               &
+       &          ,ftd,fqd                                                           &
+       &          ,Plim1,Plim2,asupmax,supmax0                                       &
+       &          ,asupmaxmin                                                        &
+       &          ,da,phi,mp,phi2,d1a,dam,sigij                                      & ! RomP
+       &          ,clw,elij,evap,ep,epmlmMm,eplaMm                                   & ! RomP
+       &          ,wdtrainA,wdtrainM                                                 & ! RomP
+       &          ,iflag1,kbas1,ktop1                                                &
+       &          ,precip1,cbmf1,plcl1,plfc1,wbeff1,sig1,w01,ptop21                  &
+       &          ,ft1,fq1,fu1,fv1,ftra1                                             &
+       &          ,sigd1,Ma1,mip1,Vprecip1,upwd1,dnwd1,dnwd01                        &
+       &          ,qcondc1,wd1,cape1,cin1                                            &
+       &          ,tvp1                                                              &
+       &          ,ftd1,fqd1                                                         &
+       &          ,Plim11,Plim21,asupmax1,supmax01                                   &
+       &          ,asupmaxmin1                                                       &
+       &          ,da1,phi1,mp1,phi21,d1a1,dam1,sigij1                               & ! RomP
+       &          ,clw1,elij1,evap1,ep1,epmlmMm1,eplaMm1                             & ! RomP
+       &          ,wdtrainA1,wdtrainM1)                                              ! RomP
+      endif
+
+      if (iflag_con.eq.4) then
+       CALL cv_uncompress(nloc,len,ncum,nd,idcum                                     &
+       &          ,iflag                                                             &
+       &          ,precip,cbmf                                                       &
+       &          ,ft,fq,fu,fv                                                       &
+       &          ,Ma,qcondc                                                         &
+       &          ,iflag1                                                            &
+       &          ,precip1,cbmf1                                                     &
+       &          ,ft1,fq1,fu1,fv1                                                   &
+       &          ,Ma1,qcondc1 )
+      endif
+
+      ENDIF ! ncum>0
+!c
+      if (debut) THEN 
+       print *,' cv_compress -> '
+       debut=.FALSE.
+      endif !(debut) THEN
+!c
+
+9999  continue
+      return
+      end SUBROUTINE cva_driver
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cvflag.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cvflag.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cvflag.h	(revision 17)
@@ -0,0 +1,7 @@
+!
+! $Header$
+!
+      logical cvflag_grav
+
+      COMMON /cvflag/ cvflag_grav 
+!$OMP THREADPRIVATE(/cvflag/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cvltr.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cvltr.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cvltr.F90	(revision 17)
@@ -0,0 +1,679 @@
+!
+! $Id $
+!
+SUBROUTINE cvltr(pdtime, da, phi,phi2,d1a,dam, mpIN,epIN, &
+           sigd,sij,clw,elij,epmlmMm,eplaMm,              &
+           pmflxrIN,pmflxsIN,ev,te,wdtrainA,wdtrainM,     &
+           paprs,it,tr,upd,dnd,inb,icb,                   &
+           dtrcv,trsptd,dtrSscav,dtrsat,dtrUscav,qDi,qPr, &
+           qPa,qMel,qTrdi,dtrcvMA,Mint,                   &
+           zmfd1a,zmfphi2,zmfdam)
+  USE IOIPSL 
+  USE dimphy
+  USE infotrac, ONLY : nbtr,tname
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : convection des traceurs / KE
+! Auteurs: M-A Filiberti and J-Y Grandpeix
+! modifiee par R Pilon : lessivage des traceurs / KE
+!=====================================================================
+
+  include "YOMCST.h"
+  include "YOECUMF.h"
+  include "conema3.h"
+
+! Entree
+  REAL,INTENT(IN)                           :: pdtime
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: da
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi
+! RomP
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: d1a,dam ! matrices pour simplifier
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi2    ! l'ecriture des tendances
+!
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: mpIN
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)    :: paprs  ! pression aux 1/2 couches (bas en haut)
+!  REAL,DIMENSION(klon,klev),INTENT(IN)    :: pplay ! pression aux 1/2 couches (bas en haut)
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr     ! q de traceur (bas en haut)
+  INTEGER,INTENT(IN)                        :: it 
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: upd   ! saturated updraft mass flux
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: dnd   ! saturated downdraft mass flux
+!
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainA   ! masses precipitantes de l'asc adiab
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainM   ! masses precipitantes des melanges
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxrIN   ! vprecip: eau
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pmflxsIN   ! vprecip: neige
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: ev         ! evaporation cv30_routine
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: epIN
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: te 
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: sij        ! fraction dair de lenv
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: elij       ! contenu en eau condensée spécifique/conc deau condensée massique
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: epmlmMm    ! eau condensee precipitee dans mel masse dair sat
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: eplaMm    ! eau condensee precipitee dans aa masse dair sat
+
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: clw        ! contenu en eau condensée dans lasc adiab
+  REAL,DIMENSION(klon),INTENT(IN)           :: sigd
+  INTEGER,DIMENSION(klon),INTENT(IN)        :: icb,inb
+! Sortie
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcv     ! tendance totale (bas en haut)
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrcvMA ! M-A Filiberti
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: trsptd    ! tendance du transport 
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrSscav  ! tendance du lessivage courant sat
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrsat    ! tendance trsp+sat scav
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)     :: dtrUscav  ! tendance du lessivage courant unsat
+!
+! Variables locales
+  INTEGER                           :: i,j,k
+  REAL,DIMENSION(klon,klev)         :: dxpres   ! difference de pression entre niveau (j+1) et (j)
+  REAL                              :: pdtimeRG ! pas de temps * gravite
+! variables pour les courants satures
+  REAL,DIMENSION(klon,klev,klev)    :: zmd
+  REAL,DIMENSION(klon,klev,klev)    :: za
+  REAL,DIMENSION(klon,klev,nbtr)    :: zmfd,zmfa
+  REAL,DIMENSION(klon,klev,nbtr)    :: zmfp,zmfu
+
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfd1a
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfdam
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: zmfphi2
+
+! RomP ! les variables sont nettoyees des valeurs aberrantes
+  REAL,DIMENSION(klon,klev)         :: Pa, Pm  ! pluie AA et mélanges, var temporaire
+  REAL,DIMENSION(klon,klev)         :: pmflxs,pmflxr ! pmflxrIN,pmflxsIN sans valeur aberante
+  REAL,DIMENSION(klon,klev)         :: mp            ! flux de masse
+  REAL,DIMENSION(klon,klev)         :: ep            ! fraction d'eau convertie en precipitation 
+  REAL,DIMENSION(klon,klev)         :: evap          ! evaporation : variable temporaire 
+  REAL,DIMENSION(klon,klev)         :: rho    !environmental density
+
+  REAL,DIMENSION(klon,klev)         :: kappa ! denominateur du au calcul de la matrice 
+                                             ! pour obtenir qd et qp
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qTrdi ! traceurs descente air insature transport MA
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qDi  ! traceurs descente insaturees
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPr  ! traceurs colonne precipitante
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qPa  ! traceurs dans les precip issues lasc. adiab.
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)    :: qMel ! traceurs dans les precip issues des melanges
+  REAL,DIMENSION(klon,klev,nbtr)                :: qMeltmp ! variable temporaire 
+  REAL,DIMENSION(klon,klev,nbtr)                :: qpmMint
+  REAL,DIMENSION(klon,klev),INTENT(OUT)         :: Mint
+! tendances
+  REAL                              :: tdcvMA           ! terme de transport de traceur (schema Marie Angele)
+  REAL                              :: trsptrac         ! terme de transport de traceur par l'air
+  REAL                              :: scavtrac         ! terme de lessivage courant sature
+  REAL                              :: uscavtrac        ! terme de lessivage courant insature
+! impaction
+!!!       Correction apres discussion Romain P. / Olivier B. 
+!!!  REAL,PARAMETER                    :: rdrop=2.5e-3     ! rayon des gouttes d'eau
+  REAL,PARAMETER                    :: rdrop=1.e-3     ! rayon des gouttes d'eau 
+!!!
+  REAL,DIMENSION(klon,klev)         :: imp              ! coefficient d'impaction
+! parametres lessivage
+  REAL                    :: ccntrAA_coef        ! \alpha_a : fract aerosols de l'AA convertis en CCN
+  REAL                    :: ccntrENV_coef       ! \beta_m  : fract aerosols de l'env convertis en CCN
+  REAL                    :: coefcoli            ! coefficient de collision des gouttes sur les aerosols
+!
+  LOGICAL,DIMENSION(klon,klev) :: NO_precip
+!  LOGICAL                      :: scavON
+! var tmp tests
+  REAL                           :: conserv
+  real                           :: conservMA
+
+! coefficient lessivage
+   ccntrAA_coef     = 0.
+   ccntrENV_coef    = 0.
+   coefcoli         = 0.
+
+!$OMP MASTER
+  call getin('ccntrAA_coef',ccntrAA_coef)
+  call getin('ccntrENV_coef',ccntrENV_coef)
+  call getin('coefcoli',coefcoli)
+!$OMP END MASTER
+!$OMP BARRIER
+  print*,'cvltr coef lessivage convectif', ccntrAA_coef,ccntrENV_coef,coefcoli
+
+!  scavON=.TRUE.
+!  if(scavON) then
+!   ccntrAA_coef     = 1.
+!   ccntrENV_coef    = 1.
+!   coefcoli         = 1.
+!  else
+!   ccntrAA_coef     = 0.
+!   ccntrENV_coef    = 0.
+!   coefcoli         = 0.
+!  endif
+
+! ======================================================
+! calcul de l'impaction
+! ======================================================
+!initialisation
+  do j=1,klev
+   do i=1,klon
+     imp(i,j)=0.
+   enddo
+  enddo
+! impaction sur la surface de la colonne de la descente insaturee
+! On prend la moyenne des precip entre le niveau i+1 et i
+! I=3/4* (P(1+1)+P(i))/2 / (sigd*r*rho_l)
+!  1000kg/m3= densité de l'eau
+! 0.75e-3 = 3/4 /1000
+! Par la suite, I est tout le temps multiplié par sig_d pour avoir l'impaction sur la surface de la maille
+! on le néglige ici pour simplifier le code
+  do j=1,klev-1
+   do i=1,klon
+    imp(i,j) = coefcoli*0.75e-3/rdrop *&
+             0.5*(pmflxr(i,j+1)+pmflxs(i,j+1)+pmflxr(i,j)+pmflxs(i,j))
+!    rho(i,j)=pplay(i,j)/(rd*te(i,j))
+   enddo
+  enddo
+!
+! initialisation pour flux de traceurs, td et autre
+   trsptrac = 0.
+   scavtrac = 0.
+   uscavtrac = 0.
+
+  DO j=1,klev
+   DO i=1,klon
+    zmfd(i,j,it)=0.
+    zmfa(i,j,it)=0.
+    zmfu(i,j,it)=0.
+    zmfp(i,j,it)=0.
+    zmfphi2(i,j,it)=0.
+    zmfd1a(i,j,it)=0.
+    zmfdam(i,j,it)=0.
+    qDi(i,j,it)=0.
+    qPr(i,j,it)=0.
+    qPa(i,j,it)=0.
+    qMel(i,j,it)=0.
+    qMeltmp(i,j,it)=0.
+    qTrdi(i,j,it)=0.
+    kappa(i,j)=0.
+    trsptd(i,j,it)=0.
+    dtrsat(i,j,it)=0.
+    dtrSscav(i,j,it)=0.
+    dtrUscav(i,j,it)=0.
+    dtrcv(i,j,it)=0.
+    dtrcvMA(i,j,it)=0.
+    evap(i,j)=0.
+    dxpres(i,j)=0.
+    qpmMint(i,j,it)=0.
+    Mint(i,j)=0.
+   END DO
+  END DO
+
+! suppression des valeurs très faibles (~1e-320)
+! multiplication de levaporation pour lavoir par unite de temps
+! et par unite de surface de la maille
+! -> cv30_unsat : evap : masse evaporee/s/(m2 de la descente)
+  DO j=1,klev
+   DO i=1,klon
+    if(ev(i,j).lt.1.e-16) then
+     evap(i,j)=0.
+    else
+     evap(i,j)=ev(i,j)*sigd(i)
+    endif
+   END DO
+  END DO
+
+  DO j=1,klev
+   DO i=1,klon
+   if(j.lt.klev) then
+    if(epIN(i,j).lt.1.e-32) then
+     ep(i,j)=0.
+    else
+     ep(i,j)=epIN(i,j)
+    endif
+   else
+    ep(i,j)=epmax
+   endif
+    if(mpIN(i,j).lt.1.e-32) then
+     mp(i,j)=0.
+    else
+     mp(i,j)=mpIN(i,j)
+    endif
+    if(pmflxsIN(i,j).lt.1.e-32) then
+     pmflxs(i,j)=0.
+    else
+     pmflxs(i,j)=pmflxsIN(i,j)
+    endif
+    if(pmflxrIN(i,j).lt.1.e-32) then
+     pmflxr(i,j)=0.
+    else
+     pmflxr(i,j)=pmflxrIN(i,j)
+    endif
+    if(wdtrainA(i,j).lt.1.e-32) then
+     Pa(i,j)=0.
+    else
+     Pa(i,j)=wdtrainA(i,j)
+    endif
+    if(wdtrainM(i,j).lt.1.e-32) then
+     Pm(i,j)=0.
+    else
+     Pm(i,j)=wdtrainM(i,j)
+    endif
+   END DO
+  END DO
+
+!==========================================
+  DO j = klev-1,1,-1
+   DO i = 1,klon
+     NO_precip(i,j) = (pmflxr(i,j+1)+pmflxs(i,j+1)).lt.1.e-10&
+                    .and.Pa(i,j).lt.1.e-10.and.Pm(i,j).lt.1.e-10
+   END DO
+  END DO
+
+! =========================================
+! calcul des tendances liees au downdraft
+! =========================================
+!cdir collapse
+  DO k=1,klev
+   DO j=1,klev
+    DO i=1,klon
+     zmd(i,j,k)=0.
+     za (i,j,k)=0.
+    END DO
+   END DO
+  END DO
+! calcul de la matrice d echange
+! matrice de distribution de la masse entrainee en k
+! commmentaire RomP : mp > 0
+  DO k=1,klev-1
+     DO i=1,klon
+        zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1))   ! ~ mk(k)
+     END DO
+  END DO
+  DO k=2,klev
+     DO j=k-1,1,-1
+        DO i=1,klon
+           if(mp(i,j+1).gt.1.e-10) then
+              zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1)) !det ~ mk(j)=mk(j+1)*mp(i,j)/mp(i,j+1)
+           ENDif
+        END DO
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev-1
+        DO i=1,klon
+           za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
+        END DO
+     END DO
+  END DO
+!!!!! quantite  de traceur dans la descente d'air insaturee  :   4 juin 2012
+  DO k=1,klev
+     DO j=1,klev-1
+        DO i=1,klon
+        if(mp(i,j+1).gt.1.e-10) then
+          qTrdi(i,j+1,it)=qTrdi(i,j+1,it)+(zmd(i,j+1,k)/mp(i,j+1))*tr(i,k,it)
+        else
+          qTrdi(i,j,it)=0.!tr(i,j,it)
+        endif
+        ENDDO
+     ENDDO
+  ENDDO
+!!!!!
+!
+! rajout du terme lie a l ascendance induite
+!
+  DO j=2,klev
+     DO i=1,klon
+        za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
+     END DO
+  END DO
+!
+! tendance courants insatures  ! sans lessivage ancien schema
+!
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfd(i,j,it)=zmfd(i,j,it)+za(i,j,k)*(tr(i,k,it)-tr(i,j,it))
+        END DO
+     END DO
+  END DO
+!
+! =========================================
+! calcul des tendances liees aux courants satures   j <-> z ; k <-> z'
+! =========================================
+  DO j=1,klev
+     DO i=1,klon
+        zmfa(i,j,it)=da(i,j)*(tr(i,1,it)-tr(i,j,it))                     ! da
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfp(i,j,it)=zmfp(i,j,it)+phi(i,j,k)*(tr(i,k,it)-tr(i,j,it))  ! phi
+        END DO
+     END DO
+  END DO
+! RomP ajout des matrices liees au lessivage
+  DO j=1,klev
+     DO i=1,klon
+        zmfd1a(i,j,it)=d1a(i,j)*tr(i,1,it)   ! da1
+        zmfdam(i,j,it)=dam(i,j)*tr(i,1,it)   ! dam
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+          zmfphi2(i,j,it)=zmfphi2(i,j,it)+phi2(i,j,k)*tr(i,k,it)  ! psi
+        END DO
+     END DO
+  END DO
+  DO j=1,klev-1
+     DO i=1,klon
+        zmfu(i,j,it)=max(0.,upd(i,j+1)+dnd(i,j+1))*(tr(i,j+1,it)-tr(i,j,it))
+     END DO
+  END DO
+  DO j=2,klev
+     DO i=1,klon
+        zmfu(i,j,it)=zmfu(i,j,it)+min(0.,upd(i,j)+dnd(i,j))*(tr(i,j,it)-tr(i,j-1,it))
+     END DO
+  END DO
+! ===================================================
+! calcul des tendances liees aux courants insatures
+! ===================================================
+!  pression  
+  DO k=1, klev
+     DO i=1, klon
+        dxpres(i,k)=paprs(i,k)-paprs(i,k+1)
+     ENDDO
+  ENDDO
+  pdtimeRG=pdtime*RG
+
+! q_pa et q_pm    traceurs issues des courants satures se retrouvant dans les precipitations
+  DO j=1,klev
+     DO i=1,klon
+        if(j.ge.icb(i).and.j.le.inb(i)) then
+          if(clw(i,j).gt.1.e-16) then
+           qPa(i,j,it)=ccntrAA_coef*tr(i,1,it)/clw(i,j)
+          else
+           qPa(i,j,it)=0.
+          endif
+        endif
+     END DO
+  END DO
+
+! calcul de q_pm en 2 parties :
+! 1) calcul de sa valeur pour un niveau z' donne
+! 2) integration sur la verticale sur z'
+     DO j=1,klev
+      DO k=1,j-1
+        DO i=1,klon
+        if(k.ge.icb(i).and.k.le.inb(i).and.& 
+           j.le.inb(i)) then
+            if(elij(i,k,j).gt.1.e-16) then
+             qMeltmp(i,j,it)=((1-ep(i,k))*ccntrAA_coef*tr(i,1,it)&
+                         *(1.-sij(i,k,j))  +ccntrENV_coef&
+                         *tr(i,k,it)*sij(i,k,j)) / elij(i,k,j)
+            else
+             qMeltmp(i,j,it)=0.
+            endif
+          qpmMint(i,j,it)=qpmMint(i,j,it) + qMeltmp(i,j,it)*epmlmMm(i,j,k)
+          Mint(i,j)=Mint(i,j) + epmlmMm(i,j,k)
+        endif ! end if dans nuage
+        END DO
+     END DO
+  END DO
+
+     DO j=1,klev
+        DO i=1,klon
+          if(Mint(i,j).gt.1.e-16) then
+           qMel(i,j,it)=qpmMint(i,j,it)/Mint(i,j)
+          else
+           qMel(i,j,it)=0.
+          endif
+     END DO
+  END DO
+
+! calcul de q_d et q_p    traceurs de la descente precipitante 
+   DO j=klev-1,1,-1
+    DO i=1,klon
+     if(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then  ! detrainement
+       kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))&
+                + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
+             
+     elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then! entrainement
+       if(j.eq.1) then
+        kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                 (-mp(i,2)-imp(i,j)/RG*dxpres(i,j))&
+                 + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
+       else
+        kappa(i,j)=((pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+                 (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))&
+                 + (imp(i,j)/RG*dxpres(i,j))*(evap(i,j)/RG*dxpres(i,j)))
+       endif
+      else
+        kappa(i,j)=1.
+      endif
+    ENDDO
+   ENDDO
+
+  DO j=klev-1,1,-1
+   DO i=1,klon
+    if (abs(kappa(i,j)).lt.1.e-25) then    !si denominateur nul (il peut y avoir des mp!=0)
+     kappa(i,j)=1.
+     if(j.eq.1) then
+       qDi(i,j,it)=qDi(i,j+1,it) !orig tr(i,j,it)   ! mp(1)=0 donc tout vient de la couche supérieure
+     elseif(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then
+       qDi(i,j,it)=qDi(i,j+1,it)
+     elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then! entrainement
+       qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
+     else  ! si  mp (i)=0 et mp(j+1)=0
+       qDi(i,j,it)=tr(i,j,it) ! orig 0.
+     endif 
+
+      if(NO_precip(i,j)) then
+       qPr(i,j,it)=0.
+      else
+       qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
+                   +imp(i,j)/RG*dxpres(i,j)*qDi(i,j,it))/&
+                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
+      endif
+    else   !     denominateur non nul
+     kappa(i,j)=1./kappa(i,j)     
+! calcul de qd et qp
+!!jyg  (20130119) correction pour le sommet du nuage
+!!     if(j.ge.inb(i)) then       !au-dessus du nuage, sommet inclu
+     if(j.gt.inb(i)) then       !au-dessus du nuage
+       qDi(i,j,it)=tr(i,j,it)   ! pas de descente => environnement = descente insaturee
+       qPr(i,j,it)=0.
+
+!  vvv premiere couche du modele ou mp(1)=0  ! det tout le temps  vvv
+     elseif(j.eq.1) then 
+      if(mp(i,2).gt.1.e-10) then !mp(2) non nul -> detrainement (car mp(1) = 0) !ent pas possible
+       if(NO_precip(i,j)) then !pas de precip en (i)
+        qDi(i,j,it)=qDi(i,j+1,it)
+        qPr(i,j,it)=0.
+       else
+        qDi(i,j,it)=kappa(i,j)*(&
+            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
+            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+            (-mp(i,j+1)*qDi(i,j+1,it)))
+
+        qPr(i,j,it)=kappa(i,j)*(&
+            (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
+            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
+            +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
+       endif
+
+      else !mp(2) nul -> plus de descente insaturee -> pluie agit sur environnement
+        qDi(i,j,it)=tr(i,j,it) ! orig 0.
+        if(NO_precip(i,j)) then
+         qPr(i,j,it)=0.
+        else
+         qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
+                   +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
+                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
+        endif
+
+      endif  !mp(2) nul ou non
+
+! vvv  (j!=1.and.j.lt.inb(i))  en-dessous du sommet nuage   vvv
+     else 
+!------------------------------------------------------------- detrainement 
+      if(mp(i,j+1).gt.mp(i,j).and.mp(i,j+1).gt.1.e-10) then !mp(i,j).gt.1.e-10) then
+         if(NO_precip(i,j)) then 
+          qDi(i,j,it)=qDi(i,j+1,it)
+          qPr(i,j,it)=0.
+         else
+          qDi(i,j,it)=kappa(i,j)*(&
+            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
+            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+            (-mp(i,j+1)*qDi(i,j+1,it)))
+!
+          qPr(i,j,it)=kappa(i,j)*(&
+            (-mp(i,j+1)-imp(i,j)/RG*dxpres(i,j))*&
+            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
+            +(-mp(i,j+1)*qDi(i,j+1,it)) * (imp(i,j)/RG*dxpres(i,j)))
+         endif !precip
+!------------------------------------------------------------- entrainement 
+      elseif(mp(i,j).gt.mp(i,j+1).and.mp(i,j).gt.1.e-10) then 
+         if(NO_precip(i,j)) then
+          qDi(i,j,it)=(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))/(-mp(i,j))
+          qPr(i,j,it)=0.
+         else
+          qDi(i,j,it)=kappa(i,j)*(&
+            (-evap(i,j)/RG*dxpres(i,j))*((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)) +&
+            (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))*&
+            (-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it)))
+!
+          qPr(i,j,it)=kappa(i,j)*(&
+            (-mp(i,j)-imp(i,j)/RG*dxpres(i,j))*&
+            ((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+            Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it))&
+            +(-mp(i,j+1)*(qDi(i,j+1,it)-tr(i,j,it))-mp(i,j)*tr(i,j,it))*&
+            (imp(i,j)/RG*dxpres(i,j)))
+         endif !precip
+!------------------------------------------------------------- endif ! ent/det
+      else  !mp nul
+        qDi(i,j,it)=tr(i,j,it) ! orig 0.
+        if(NO_precip(i,j)) then
+         qPr(i,j,it)=0.
+        else
+         qPr(i,j,it)=((pmflxr(i,j+1)+pmflxs(i,j+1))*qPr(i,j+1,it)+&
+                   Pa(i,j)*qPa(i,j,it)+Pm(i,j)*qMel(i,j,it)&
+                   +imp(i,j)/RG*dxpres(i,j)*tr(i,j,it))/&
+                  (pmflxr(i,j+1)+pmflxs(i,j+1)+Pa(i,j)+Pm(i,j))
+        endif
+      endif ! mp nul ou non
+     endif ! condition sur j
+    endif ! kappa
+   ENDDO
+  ENDDO
+
+!! print test descente insaturee
+!  DO j=klev,1,-1
+!   DO i=1,klon
+!     if(it.eq.3) then
+!   write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') j,&
+!!         'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),&
+!          'zmfdam+zmfpsi',zmfdam(i,j,it)+zmfphi2(i,j,it),'qpmMint',qpmMint(i,j,it),&
+!          'Pm',Pm(i,j),'Mint',Mint(i,j),&
+!!          'zmfa',zmfa(i,j,it),'zmfp',zmfp(i,j,it),&
+!        'zmfdam',zmfdam(i,j,it),'zmfpsi',zmfphi2(i,j,it),'zmfd1a',zmfd1a(i,j,it)
+!!          'Pa',Pa(i,j),'eplaMm',eplaMm(i,j)
+!!         'zmfd1a=da1*qa',zmfd1a(i,j,it),'Pa*qPa',wdtrainA(i,j)*qPa(i,j,it),'da1',d1a(i,j)
+!     endif
+!   ENDDO
+!  ENDDO
+
+
+! ===================================================
+! calcul final des tendances
+! ===================================================
+
+  DO k=klev-1,1,-1
+    DO i=1, klon
+! transport
+     tdcvMA=zmfd(i,k,it)+zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)   ! double comptage des downdraft insatures
+     trsptrac=zmfu(i,k,it)+zmfa(i,k,it)+zmfp(i,k,it)
+! lessivage courants satures
+     scavtrac=-ccntrAA_coef*zmfd1a(i,k,it)&
+               -zmfphi2(i,k,it)*ccntrENV_coef&
+               -zmfdam(i,k,it)*ccntrAA_coef
+! lessivage courants insatures
+   if(k.le.inb(i).and.k.gt.1) then   ! tendances dans le nuage
+!------------------------------------------------------------- detrainement
+      if(mp(i,k+1).gt.mp(i,k).and.mp(i,k+1).gt.1.e-10) then
+        uscavtrac= (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))&
+                   + mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
+!
+!        if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' det incloud',&
+!                    (-mp(i,k)+mp(i,k+1))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
+!                    mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
+!                    'mp',mp(i,k)
+!------------------------------------------------------------- entrainement 
+      elseif(mp(i,k).gt.mp(i,k+1).and.mp(i,k).gt.1.e-10) then
+         uscavtrac= mp(i,k)*(tr(i,k-1,it)-tr(i,k,it))
+!
+!         if(it.eq.3) write(*,'(I2,1X,a,5X,e20.12,82X,a,e20.12)')k,' ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+!=!------------------------------------------------------------- end ent/det 
+      else !        mp(i,k+1)=0. et mp(i,k)=0.    pluie directement sur l environnement
+
+        if(NO_precip(i,k)) then
+          uscavtrac=0.
+!         if(it.eq.3) write(*,'(I2,1X,a,e20.12,82X,a,e20.12)')k,' no P ent incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+        else
+          uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
+!         if(it.eq.3) write(*,'(I2,1X,a,3X,e20.12,82X,a,e20.12)')k,' P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+        endif
+      endif  ! mp/det/ent
+!------------------------------------------------------------- premiere couche 
+   elseif(k.eq.1) then  !                                      mp(1)=0.
+      if(mp(i,2).gt.1.e-10) then  !detrainement
+         uscavtrac= (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it)) !&
+!                   + mp(i,2)*(0.-tr(i,k,it))
+!
+!       if(it.eq.3) write(*,'(I2,1X,a,e20.12,84X,a,e20.12)')k,' 1 det',&
+!                  (-0.+mp(i,2))*(qDi(i,k,it)-tr(i,k,it))*pdtimeRG/dxpres(i,k)+&
+!                  mp(i,2)*(0.-tr(i,k,it))*pdtimeRG/dxpres(i,k),&
+!                   'mp',mp(i,k)
+      else   ! mp(2) = 0 = mp(1) pas de descente insaturee, rien ne se passe s'il ne pleut pas, sinon pluie->env
+        if(NO_precip(i,1)) then
+          uscavtrac=0.
+        else
+          uscavtrac=-imp(i,k)*tr(i,k,it)*dxpres(i,k)/RG+evap(i,k)*qPr(i,k,it)*dxpres(i,k)/RG
+        endif
+!         if(it.eq.3) write(*,'(I2,1X,a,2X,e20.12,82X,a,e20.12)')k,'1 P env incloud',uscavtrac*pdtimeRG/dxpres(i,k), 'mp',mp(i,k)
+      endif
+
+   else   ! k > INB  au-dessus du nuage
+    uscavtrac=0.
+   endif
+
+! =====    tendances finales  ======
+     trsptd(i,k,it)=trsptrac*pdtimeRG/dxpres(i,k)              ! td transport sans eau dans courants satures
+     dtrSscav(i,k,it)=scavtrac*pdtimeRG/dxpres(i,k)            ! td du lessivage dans courants satures
+     dtrUscav(i,k,it)=uscavtrac*pdtimeRG/dxpres(i,k)           ! td courant insat
+     dtrsat(i,k,it)=(trsptrac+scavtrac)*pdtimeRG/dxpres(i,k)   ! td courant sat
+     dtrcv(i,k,it)=(trsptrac+scavtrac+uscavtrac)*pdtimeRG/dxpres(i,k)!dtrsat(i,k,it)+dtrUscav(i,k,it)         td conv
+!!!!!!
+     dtrcvMA(i,k,it)=tdcvMA*pdtimeRG/dxpres(i,k) ! MA tendance convection
+     ENDDO
+  ENDDO
+
+! test de conservation du traceur
+!print*,"_____________________________________________________________"
+!print*,"                                                             "
+!      conserv=0.
+!      conservMA=0.
+!      DO k= klev-1,1,-1
+!        DO i=1, klon
+!         conserv=conserv+dtrcv(i,k,it)*   &
+!        (paprs(i,k)-paprs(i,k+1))/RG
+!         conservMA=conservMA+dtrcvMA(i,k,it)*   &
+!        (paprs(i,k)-paprs(i,k+1))/RG
+!
+!      if(it.eq.3)  write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)') k,&
+!         'MA td ',dtrcvMA(i,k,it)*dxpres(i,k)/RG,&
+!         ' td',dtrcv(i,k,it)*dxpres(i,k)/RG,'         conservMA ',conservMA,'conserv ',conserv
+!!
+!        ENDDO
+!      ENDDO
+!       if(it.eq.3) print *,'it',it,'conserv ',conserv,'conservMA ',conservMA
+
+END SUBROUTINE cvltr
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cvltrorig.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cvltrorig.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cvltrorig.F90	(revision 17)
@@ -0,0 +1,166 @@
+!
+! $Id $
+!
+SUBROUTINE cvltrorig(it,pdtime,da, phi, mp,paprs,pplay,x,upd,dnd,dx)
+  USE dimphy
+  USE infotrac, ONLY : nbtr
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : convection des traceurs / KE
+! Auteurs: M-A Filiberti and J-Y Grandpeix
+!=====================================================================
+  include "YOMCST.h"
+  include "YOECUMF.h" 
+
+! Entree
+  REAL,INTENT(IN)                           :: pdtime
+  INTEGER, INTENT(IN)                       :: it
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: da
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: mp
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)    :: paprs ! pression aux 1/2 couches (bas en haut)
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: pplay ! pression pour le milieu de chaque couche
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)      :: x     ! q de traceur (bas en haut) 
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: upd   ! saturated updraft mass flux
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: dnd   ! saturated downdraft mass flux
+
+! Sortie
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: dx ! tendance de traceur  (bas en haut)
+
+! Variables locales     
+! REAL,DIMENSION(klon,klev)       :: zed
+  REAL,DIMENSION(klon,klev,klev)  :: zmd
+  REAL,DIMENSION(klon,klev,klev)  :: za
+  REAL,DIMENSION(klon,klev)       :: zmfd,zmfa
+  REAL,DIMENSION(klon,klev)       :: zmfp,zmfu
+  REAL,DIMENSION(klon,klev)       :: deltap
+  INTEGER                         :: i,k,j 
+  REAL                            :: pdtimeRG
+!!  real conserv
+
+! =========================================
+! calcul des tendances liees au downdraft
+! =========================================
+!cdir collapse
+  DO j=1,klev
+  DO i=1,klon
+!   zed(i,j)=0.
+    zmfd(i,j)=0.
+    zmfa(i,j)=0.
+    zmfu(i,j)=0.
+    zmfp(i,j)=0.
+  END DO
+  END DO
+!cdir collapse
+  DO k=1,klev
+  DO j=1,klev
+  DO i=1,klon
+    zmd(i,j,k)=0.
+    za (i,j,k)=0.
+  END DO
+  END DO
+  END DO
+! entrainement
+! DO k=1,klev-1
+!    DO i=1,klon
+!       zed(i,k)=max(0.,mp(i,k)-mp(i,k+1))
+!    END DO
+! END DO
+
+! calcul de la matrice d echange
+! matrice de distribution de la masse entrainee en k
+
+  DO k=1,klev-1
+     DO i=1,klon
+        zmd(i,k,k)=max(0.,mp(i,k)-mp(i,k+1))
+     END DO
+  END DO
+  DO k=2,klev
+     DO j=k-1,1,-1
+        DO i=1,klon
+           if(mp(i,j+1).ne.0) then
+              zmd(i,j,k)=zmd(i,j+1,k)*min(1.,mp(i,j)/mp(i,j+1))
+           ENDif
+        END DO
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev-1
+        DO i=1,klon
+           za(i,j,k)=max(0.,zmd(i,j+1,k)-zmd(i,j,k))
+        END DO
+     END DO
+  END DO
+!
+! rajout du terme lie a l ascendance induite
+!
+  DO j=2,klev
+     DO i=1,klon
+        za(i,j,j-1)=za(i,j,j-1)+mp(i,j)
+     END DO
+  END DO
+!
+! tendances
+!            
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfd(i,j)=zmfd(i,j)+za(i,j,k)*(x(i,k,it)-x(i,j,it))
+        END DO
+     END DO
+  END DO
+!
+! =========================================
+! calcul des tendances liees aux flux satures
+! =========================================
+  DO j=1,klev
+     DO i=1,klon
+        zmfa(i,j)=da(i,j)*(x(i,1,it)-x(i,j,it))
+     END DO
+  END DO
+  DO k=1,klev
+     DO j=1,klev
+        DO i=1,klon
+           zmfp(i,j)=zmfp(i,j)+phi(i,j,k)*(x(i,k,it)-x(i,j,it))
+        END DO
+     END DO
+  END DO
+  DO j=1,klev-1
+     DO i=1,klon
+        zmfu(i,j)=max(0.,upd(i,j+1)+dnd(i,j+1))*(x(i,j+1,it)-x(i,j,it))
+     END DO
+  END DO
+  DO j=2,klev
+     DO i=1,klon
+        zmfu(i,j)=zmfu(i,j)+min(0.,upd(i,j)+dnd(i,j))*(x(i,j,it)-x(i,j-1,it))
+     END DO
+  END DO
+
+! =========================================
+! calcul final des tendances
+! =========================================
+  DO k=1, klev
+     DO i=1, klon
+        deltap(i,k)=paprs(i,k)-paprs(i,k+1)
+     ENDDO
+  ENDDO
+  pdtimeRG=pdtime*RG
+!cdir collapse
+  DO k=1, klev
+     DO i=1, klon
+        dx(i,k,it)=(zmfd(i,k)+zmfu(i,k)       &
+                +zmfa(i,k)+zmfp(i,k))*pdtimeRG/deltap(i,k)
+     ENDDO
+  ENDDO
+
+! test de conservation du traceur
+!      conserv=0.
+!      DO k=1, klev
+!        DO i=1, klon
+!         conserv=conserv+dx(i,k,it)*   &
+!          deltap(i,k)/RG
+!        ENDDO
+!      ENDDO
+!      print *,'it',it,'cvltrorig conserv',conserv
+     
+END SUBROUTINE cvltrorig
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cvparam.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cvparam.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cvparam.h	(revision 17)
@@ -0,0 +1,29 @@
+!
+! $Header$
+!
+!c------------------------------------------------------------
+!c Parameters for convectL:
+!c (includes - microphysical parameters, 
+!c			- parameters that control the rate of approach 
+!c               to quasi-equilibrium)
+!c			- noff & minorig (previously in input of convect1)
+!c------------------------------------------------------------
+
+      integer noff, minorig, nl, nlp, nlm
+      real elcrit, tlcrit
+      real entp
+      real sigs, sigd
+      real omtrain, omtsnow, coeffr, coeffs
+      real dtmax
+      real cu
+      real betad
+      real alpha, damp
+      real delta
+
+      COMMON /cvparam/ noff, minorig, nl, nlp, nlm                                   &
+       &                ,elcrit, tlcrit                                              &
+       &                ,entp, sigs, sigd                                            &
+       &                ,omtrain, omtsnow, coeffr, coeffs                            &
+       &                ,dtmax, cu, betad, alpha, damp, delta
+
+!$OMP THREADPRIVATE(/cvparam/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/cvthermo.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/cvthermo.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/cvthermo.h	(revision 17)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+! Thermodynamical constants for convectL:
+
+      real cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0
+      real clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl
+      real eps, epsi, epsim1
+      real ginv, hrd
+      real grav
+
+      COMMON /cvthermo/ cpd, cpv, cl, rrv, rrd, lv0, g, rowl, t0                     &
+     &                 ,clmcpv, clmcpd, cpdmcp, cpvmcpd, cpvmcl                      &
+     &                 ,eps, epsi, epsim1, ginv, hrd, grav
+
+!$OMP THREADPRIVATE(/cvthermo/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/declare_STDlev.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/declare_STDlev.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/declare_STDlev.h	(revision 17)
@@ -0,0 +1,61 @@
+!cIM for NMC files
+      real twriteSTD(klon,nlevSTD,nfiles)
+      real qwriteSTD(klon,nlevSTD,nfiles)
+      real rhwriteSTD(klon,nlevSTD,nfiles)
+      real phiwriteSTD(klon,nlevSTD,nfiles)
+      real uwriteSTD(klon,nlevSTD,nfiles)
+      real vwriteSTD(klon,nlevSTD,nfiles)
+      real wwriteSTD(klon,nlevSTD,nfiles)
+
+      real twriteSTD3(klon,nlevSTD3)
+      real qwriteSTD3(klon,nlevSTD3)
+      real rhwriteSTD3(klon,nlevSTD3)
+      real phiwriteSTD3(klon,nlevSTD3)
+      real uwriteSTD3(klon,nlevSTD3)
+      real vwriteSTD3(klon,nlevSTD3)
+      real wwriteSTD3(klon,nlevSTD3)
+
+      real tnondefSTD8(klon,nlevSTD8)
+      real twriteSTD8(klon,nlevSTD8)
+      real qwriteSTD8(klon,nlevSTD8)
+      real rhwriteSTD8(klon,nlevSTD8)
+      real phiwriteSTD8(klon,nlevSTD8)
+      real uwriteSTD8(klon,nlevSTD8)
+      real vwriteSTD8(klon,nlevSTD8)
+      real wwriteSTD8(klon,nlevSTD8)
+
+      real, save :: rlevSTD(nlevSTD)
+      DATA rlevSTD/100000., 92500., 85000., 70000.,                                  &
+        & 60000., 50000., 40000., 30000., 25000., 20000.,                            &
+        & 15000., 10000., 7000., 5000., 3000., 2000., 1000./
+!c$OMP THREADPRIVATE(rlevstd)
+
+      CHARACTER*4, SAVE :: clevSTD(nlevSTD)
+      DATA clevSTD/'1000','925 ','850 ','700 ','600 ',                               &
+        & '500 ','400 ','300 ','250 ','200 ','150 ','100 ',                          &
+        & '70  ','50  ','30  ','20  ','10  '/
+!c$OMP THREADPRIVATE(clevSTD)
+
+      real, save :: rlevSTD3(nlevSTD3)
+      DATA rlevSTD3/85000., 50000., 25000./
+!c$OMP THREADPRIVATE(rlevSTD3)
+
+      real, save :: rlevSTD8(nlevSTD8)
+      DATA rlevSTD8/100000., 85000., 70000., 50000., 25000., 10000.,                 &
+        & 5000., 1000./
+!c$OMP THREADPRIVATE(rlevSTD8) 
+!c
+      REAL geo500(klon)
+
+!c nout : niveau de output des variables a une pression donnee
+      logical oknondef(klon,nlevSTD,nout)
+!c
+!c les produits uvSTD, vqSTD, .., T2STD sont calcules
+!c a partir des valeurs instantannees toutes les 6 h
+!c qui sont moyennees sur le mois
+
+      REAL zx_tmp_fiNC(klon,nlevSTD)
+
+      REAL missing_val
+      REAL, SAVE :: freq_moyNMC(nout)
+!c$OMP THREADPRIVATE(freq_moyNMC)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/description.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/description.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/description.h	(revision 17)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      character *120 descript
+      common /titre/descript
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/diagphy.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/diagphy.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/diagphy.F	(revision 17)
@@ -0,0 +1,415 @@
+!
+! $Header$
+!
+      SUBROUTINE diagphy(airephy,tit,iprt
+     $    , tops, topl, sols, soll, sens
+     $    , evap, rain_fall, snow_fall, ts
+     $    , d_etp_tot, d_qt_tot, d_ec_tot
+     $    , fs_bound, fq_bound)
+C======================================================================
+C
+C Purpose:
+C    Compute the thermal flux and the watter mass flux at the atmosphere
+c    boundaries. Print them and also the atmospheric enthalpy change and
+C    the  atmospheric mass change.
+C
+C Arguments: 
+C airephy-------input-R-  grid area
+C tit---------input-A15- Comment to be added in PRINT (CHARACTER*15)
+C iprt--------input-I-  PRINT level ( <=0 : no PRINT)
+C tops(klon)--input-R-  SW rad. at TOA (W/m2), positive up.
+C topl(klon)--input-R-  LW rad. at TOA (W/m2), positive down
+C sols(klon)--input-R-  Net SW flux above surface (W/m2), positive up 
+C                   (i.e. -1 * flux absorbed by the surface)
+C soll(klon)--input-R-  Net LW flux above surface (W/m2), positive up 
+C                   (i.e. flux emited - flux absorbed by the surface)
+C sens(klon)--input-R-  Sensible Flux at surface  (W/m2), positive down
+C evap(klon)--input-R-  Evaporation + sublimation watter vapour mass flux
+C                   (kg/m2/s), positive up
+C rain_fall(klon)
+C           --input-R- Liquid  watter mass flux (kg/m2/s), positive down
+C snow_fall(klon)
+C           --input-R- Solid  watter mass flux (kg/m2/s), positive down
+C ts(klon)----input-R- Surface temperature (K)
+C d_etp_tot---input-R- Heat flux equivalent to atmospheric enthalpy 
+C                    change (W/m2)
+C d_qt_tot----input-R- Mass flux equivalent to atmospheric watter mass 
+C                    change (kg/m2/s)
+C d_ec_tot----input-R- Flux equivalent to atmospheric cinetic energy
+C                    change (W/m2)
+C
+C fs_bound---output-R- Thermal flux at the atmosphere boundaries (W/m2)
+C fq_bound---output-R- Watter mass flux at the atmosphere boundaries (kg/m2/s)
+C
+C J.L. Dufresne, July 2002
+C Version prise sur ~rlmd833/LMDZOR_201102/modipsl/modeles/LMDZ.3.3/libf/phylmd
+C  le 25 Novembre 2002.
+C======================================================================
+C 
+      use dimphy
+      implicit none
+
+#include "dimensions.h"
+ccccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+C     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt
+      real tops(klon),topl(klon),sols(klon),soll(klon)
+      real sens(klon),evap(klon),rain_fall(klon),snow_fall(klon)
+      REAL ts(klon)
+      REAL d_etp_tot, d_qt_tot, d_ec_tot
+c     Output variables
+      REAL fs_bound, fq_bound
+C
+C     Local variables
+      real stops,stopl,ssols,ssoll
+      real ssens,sfront,slat
+      real airetot, zcpvap, zcwat, zcice
+      REAL rain_fall_tot, snow_fall_tot, evap_tot
+C
+      integer i
+C
+      integer pas
+      save pas
+      data pas/0/
+c$OMP THREADPRIVATE(pas)
+C
+      pas=pas+1
+      stops=0.
+      stopl=0.
+      ssols=0.
+      ssoll=0.
+      ssens=0.
+      sfront = 0.
+      evap_tot = 0.
+      rain_fall_tot = 0.
+      snow_fall_tot = 0.
+      airetot=0.
+C
+C     Pour les chaleur specifiques de la vapeur d'eau, de l'eau et de
+C     la glace, on travaille par difference a la chaleur specifique de l'
+c     air sec. En effet, comme on travaille a niveau de pression donne,
+C     toute variation de la masse d'un constituant est totalement
+c     compense par une variation de masse d'air.
+C
+      zcpvap=RCPV-RCPD
+      zcwat=RCW-RCPD
+      zcice=RCS-RCPD
+C
+      do i=1,klon
+           stops=stops+tops(i)*airephy(i)
+           stopl=stopl+topl(i)*airephy(i)
+           ssols=ssols+sols(i)*airephy(i)
+           ssoll=ssoll+soll(i)*airephy(i)
+           ssens=ssens+sens(i)*airephy(i)
+           sfront = sfront
+     $         + ( evap(i)*zcpvap-rain_fall(i)*zcwat-snow_fall(i)*zcice
+     $           ) *ts(i) *airephy(i)
+           evap_tot = evap_tot + evap(i)*airephy(i)
+           rain_fall_tot = rain_fall_tot + rain_fall(i)*airephy(i)
+           snow_fall_tot = snow_fall_tot + snow_fall(i)*airephy(i)
+           airetot=airetot+airephy(i)
+      enddo
+      stops=stops/airetot
+      stopl=stopl/airetot
+      ssols=ssols/airetot
+      ssoll=ssoll/airetot
+      ssens=ssens/airetot
+      sfront = sfront/airetot
+      evap_tot = evap_tot /airetot
+      rain_fall_tot = rain_fall_tot/airetot
+      snow_fall_tot = snow_fall_tot/airetot
+C
+      slat = RLVTT * rain_fall_tot + RLSTT * snow_fall_tot
+C     Heat flux at atm. boundaries
+      fs_bound = stops-stopl - (ssols+ssoll)+ssens+sfront
+     $    + slat
+C     Watter flux at atm. boundaries
+      fq_bound = evap_tot - rain_fall_tot -snow_fall_tot
+C
+      IF (iprt.ge.1) write(6,6666) 
+     $    tit, pas, fs_bound, d_etp_tot, fq_bound, d_qt_tot
+C
+      IF (iprt.ge.1) write(6,6668) 
+     $    tit, pas, d_etp_tot+d_ec_tot-fs_bound, d_qt_tot-fq_bound
+C
+      IF (iprt.ge.2) write(6,6667) 
+     $    tit, pas, stops,stopl,ssols,ssoll,ssens,slat,evap_tot
+     $    ,rain_fall_tot+snow_fall_tot
+
+      return
+
+ 6666 format('Phys. Flux Budget ',a15,1i6,2f8.2,2(1pE13.5))
+ 6667 format('Phys. Boundary Flux ',a15,1i6,6f8.2,2(1pE13.5))
+ 6668 format('Phys. Total Budget ',a15,1i6,f8.2,2(1pE13.5))
+
+      end
+
+C======================================================================
+      SUBROUTINE diagetpq(airephy,tit,iprt,idiag,idiag2,dtime
+     e  ,t,q,ql,qs,u,v,paprs,pplay
+     s  , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+C======================================================================
+C
+C Purpose:
+C    Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
+C    et calcul le flux de chaleur et le flux d'eau necessaire a ces 
+C    changements. Ces valeurs sont moyennees sur la surface de tout
+C    le globe et sont exprime en W/2 et kg/s/m2
+C    Outil pour diagnostiquer la conservation de l'energie
+C    et de la masse dans la physique. Suppose que les niveau de
+c    pression entre couche ne varie pas entre 2 appels.
+C
+C Plusieurs de ces diagnostics peuvent etre fait en parallele: les
+c bilans sont sauvegardes dans des tableaux indices. On parlera
+C "d'indice de diagnostic"
+c 
+C
+c======================================================================
+C Arguments: 
+C airephy-------input-R-  grid area
+C tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
+C iprt----input-I-  PRINT level ( <=1 : no PRINT)
+C idiag---input-I- indice dans lequel sera range les nouveaux
+C                  bilans d' entalpie et de masse
+C idiag2--input-I-les nouveaux bilans d'entalpie et de masse 
+C                 sont compare au bilan de d'enthalpie de masse de
+C                 l'indice numero idiag2 
+C                 Cas parriculier : si idiag2=0, pas de comparaison, on
+c                 sort directement les bilans d'enthalpie et de masse 
+C dtime----input-R- time step (s)
+c t--------input-R- temperature (K)
+c q--------input-R- vapeur d'eau (kg/kg)
+c ql-------input-R- liquid watter (kg/kg)
+c qs-------input-R- solid watter (kg/kg)
+c u--------input-R- vitesse u
+c v--------input-R- vitesse v
+c paprs----input-R- pression a intercouche (Pa)
+c pplay----input-R- pression au milieu de couche (Pa)
+c
+C the following total value are computed by UNIT of earth surface
+C
+C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy 
+c            change (J/m2) during one time step (dtime) for the whole 
+C            atmosphere (air, watter vapour, liquid and solid)
+C d_qt------output-R- total water mass flux (kg/m2/s) defined as the 
+C           total watter (kg/m2) change during one time step (dtime),
+C d_qw------output-R- same, for the watter vapour only (kg/m2/s)
+C d_ql------output-R- same, for the liquid watter only (kg/m2/s)
+C d_qs------output-R- same, for the solid watter only (kg/m2/s)
+C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
+C
+C     other (COMMON...)
+C     RCPD, RCPV, ....
+C
+C J.L. Dufresne, July 2002
+c======================================================================
+ 
+      USE dimphy
+      IMPLICIT NONE
+C
+#include "dimensions.h"
+cccccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+C
+c     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt,idiag, idiag2
+      REAL dtime
+      REAL t(klon,klev), q(klon,klev), ql(klon,klev), qs(klon,klev)
+      REAL u(klon,klev), v(klon,klev)
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+c     Output variables
+      REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
+C
+C     Local variables
+c
+      REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot
+     .  , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+c h_vcol_tot--  total enthalpy of vertical air column 
+C            (air with watter vapour, liquid and solid) (J/m2)
+c h_dair_tot-- total enthalpy of dry air (J/m2)
+c h_qw_tot----  total enthalpy of watter vapour (J/m2)
+c h_ql_tot----  total enthalpy of liquid watter (J/m2)
+c h_qs_tot----  total enthalpy of solid watter  (J/m2)
+c qw_tot------  total mass of watter vapour (kg/m2)
+c ql_tot------  total mass of liquid watter (kg/m2)
+c qs_tot------  total mass of solid watter (kg/m2)
+c ec_tot------  total cinetic energy (kg/m2)
+C
+      REAL zairm(klon,klev) ! layer air mass (kg/m2)
+      REAL  zqw_col(klon)
+      REAL  zql_col(klon)
+      REAL  zqs_col(klon)
+      REAL  zec_col(klon)
+      REAL  zh_dair_col(klon)
+      REAL  zh_qw_col(klon), zh_ql_col(klon), zh_qs_col(klon)
+C
+      REAL      d_h_dair, d_h_qw, d_h_ql, d_h_qs
+C
+      REAL airetot, zcpvap, zcwat, zcice
+C
+      INTEGER i, k
+C
+      INTEGER ndiag     ! max number of diagnostic in parallel
+      PARAMETER (ndiag=10)
+      integer pas(ndiag)
+      save pas
+      data pas/ndiag*0/
+c$OMP THREADPRIVATE(pas)
+C     
+      REAL      h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag)
+     $    , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag)
+     $    , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag)
+      SAVE      h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre
+     $        , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre
+c$OMP THREADPRIVATE(h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre)
+c$OMP THREADPRIVATE(h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre)
+c======================================================================
+C
+      DO k = 1, klev
+        DO i = 1, klon
+C         layer air mass
+          zairm(i,k) = (paprs(i,k)-paprs(i,k+1))/RG
+        ENDDO
+      END DO
+C
+C     Reset variables
+      DO i = 1, klon
+        zqw_col(i)=0.
+        zql_col(i)=0.
+        zqs_col(i)=0.
+        zec_col(i) = 0.
+        zh_dair_col(i) = 0.
+        zh_qw_col(i) = 0.
+        zh_ql_col(i) = 0.
+        zh_qs_col(i) = 0.
+      ENDDO
+C
+      zcpvap=RCPV
+      zcwat=RCW
+      zcice=RCS
+C
+C     Compute vertical sum for each atmospheric column
+C     ================================================
+      DO k = 1, klev
+        DO i = 1, klon
+C         Watter mass
+          zqw_col(i) = zqw_col(i) + q(i,k)*zairm(i,k)
+          zql_col(i) = zql_col(i) + ql(i,k)*zairm(i,k)
+          zqs_col(i) = zqs_col(i) + qs(i,k)*zairm(i,k)
+C         Cinetic Energy
+          zec_col(i) =  zec_col(i)
+     $        +0.5*(u(i,k)**2+v(i,k)**2)*zairm(i,k)
+C         Air enthalpy
+          zh_dair_col(i) = zh_dair_col(i) 
+     $        + RCPD*(1.-q(i,k)-ql(i,k)-qs(i,k))*zairm(i,k)*t(i,k)
+          zh_qw_col(i) = zh_qw_col(i)
+     $        + zcpvap*q(i,k)*zairm(i,k)*t(i,k) 
+          zh_ql_col(i) = zh_ql_col(i)
+     $        + zcwat*ql(i,k)*zairm(i,k)*t(i,k) 
+     $        - RLVTT*ql(i,k)*zairm(i,k)
+          zh_qs_col(i) = zh_qs_col(i)
+     $        + zcice*qs(i,k)*zairm(i,k)*t(i,k) 
+     $        - RLSTT*qs(i,k)*zairm(i,k)
+
+        END DO
+      ENDDO
+C
+C     Mean over the planete surface
+C     =============================
+      qw_tot = 0.
+      ql_tot = 0.
+      qs_tot = 0.
+      ec_tot = 0.
+      h_vcol_tot = 0.
+      h_dair_tot = 0.
+      h_qw_tot = 0.
+      h_ql_tot = 0.
+      h_qs_tot = 0.
+      airetot=0.
+C
+      do i=1,klon
+        qw_tot = qw_tot + zqw_col(i)*airephy(i)
+        ql_tot = ql_tot + zql_col(i)*airephy(i)
+        qs_tot = qs_tot + zqs_col(i)*airephy(i)
+        ec_tot = ec_tot + zec_col(i)*airephy(i)
+        h_dair_tot = h_dair_tot + zh_dair_col(i)*airephy(i)
+        h_qw_tot = h_qw_tot + zh_qw_col(i)*airephy(i)
+        h_ql_tot = h_ql_tot + zh_ql_col(i)*airephy(i)
+        h_qs_tot = h_qs_tot + zh_qs_col(i)*airephy(i)
+        airetot=airetot+airephy(i)
+      END DO
+C
+      qw_tot = qw_tot/airetot
+      ql_tot = ql_tot/airetot
+      qs_tot = qs_tot/airetot
+      ec_tot = ec_tot/airetot
+      h_dair_tot = h_dair_tot/airetot
+      h_qw_tot = h_qw_tot/airetot
+      h_ql_tot = h_ql_tot/airetot
+      h_qs_tot = h_qs_tot/airetot
+C
+      h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot
+C
+C     Compute the change of the atmospheric state compare to the one 
+C     stored in "idiag2", and convert it in flux. THis computation
+C     is performed IF idiag2 /= 0 and IF it is not the first CALL
+c     for "idiag"
+C     ===================================
+C
+      IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN
+        d_h_vcol  = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime
+        d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime
+        d_h_qw   = (h_qw_tot  - h_qw_pre(idiag2)  )/dtime
+        d_h_ql   = (h_ql_tot  - h_ql_pre(idiag2)  )/dtime 
+        d_h_qs   = (h_qs_tot  - h_qs_pre(idiag2)  )/dtime 
+        d_qw     = (qw_tot    - qw_pre(idiag2)    )/dtime
+        d_ql     = (ql_tot    - ql_pre(idiag2)    )/dtime
+        d_qs     = (qs_tot    - qs_pre(idiag2)    )/dtime
+        d_ec     = (ec_tot    - ec_pre(idiag2)    )/dtime
+        d_qt = d_qw + d_ql + d_qs
+      ELSE 
+        d_h_vcol = 0.
+        d_h_dair = 0.
+        d_h_qw   = 0.
+        d_h_ql   = 0.
+        d_h_qs   = 0. 
+        d_qw     = 0.
+        d_ql     = 0.
+        d_qs     = 0.
+        d_ec     = 0.
+        d_qt     = 0.
+      ENDIF 
+C
+      IF (iprt.ge.2) THEN
+        WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs
+ 9000   format('Phys. Watter Mass Budget (kg/m2/s)',A15
+     $      ,1i6,10(1pE14.6))
+        WRITE(6,9001) tit,pas(idiag), d_h_vcol
+ 9001   format('Phys. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2))
+        WRITE(6,9002) tit,pas(idiag), d_ec
+ 9002   format('Phys. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+      END IF 
+C
+C     Store the new atmospheric state in "idiag"
+C
+      pas(idiag)=pas(idiag)+1
+      h_vcol_pre(idiag)  = h_vcol_tot
+      h_dair_pre(idiag) = h_dair_tot
+      h_qw_pre(idiag)   = h_qw_tot
+      h_ql_pre(idiag)   = h_ql_tot
+      h_qs_pre(idiag)   = h_qs_tot
+      qw_pre(idiag)     = qw_tot
+      ql_pre(idiag)     = ql_tot
+      qs_pre(idiag)     = qs_tot
+      ec_pre (idiag)    = ec_tot
+C
+      RETURN 
+      END 
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/diagphy.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/diagphy.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/diagphy.F90	(revision 17)
@@ -0,0 +1,433 @@
+!
+! $Header$
+!
+!!MODULE diagphy
+
+!!  CONTAINS
+
+      SUBROUTINE diagphy(airephy,tit,iprt                                            &
+       &    , tops, topl, sols, soll, sens                                           &
+       &    , evap, rain_fall, snow_fall, ts                                         &
+       &    , d_etp_tot, d_qt_tot, d_ec_tot                                          &
+       &    , fs_bound, fq_bound)
+!C======================================================================
+!C
+!C Purpose:
+!C    Compute the thermal flux and the watter mass flux at the atmosphere
+!c    boundaries. Print them and also the atmospheric enthalpy change and
+!C    the  atmospheric mass change.
+!C
+!C Arguments: 
+!C airephy-------input-R-  grid area
+!C tit---------input-A15- Comment to be added in PRINT (CHARACTER*15)
+!C iprt--------input-I-  PRINT level ( <=0 : no PRINT)
+!C tops(klon)--input-R-  SW rad. at TOA (W/m2), positive up.
+!C topl(klon)--input-R-  LW rad. at TOA (W/m2), positive down
+!C sols(klon)--input-R-  Net SW flux above surface (W/m2), positive up 
+!C                   (i.e. -1 * flux absorbed by the surface)
+!C soll(klon)--input-R-  Net LW flux above surface (W/m2), positive up 
+!C                   (i.e. flux emited - flux absorbed by the surface)
+!C sens(klon)--input-R-  Sensible Flux at surface  (W/m2), positive down
+!C evap(klon)--input-R-  Evaporation + sublimation watter vapour mass flux
+!C                   (kg/m2/s), positive up
+!C rain_fall(klon)
+!C           --input-R- Liquid  watter mass flux (kg/m2/s), positive down
+!C snow_fall(klon)
+!C           --input-R- Solid  watter mass flux (kg/m2/s), positive down
+!C ts(klon)----input-R- Surface temperature (K)
+!C d_etp_tot---input-R- Heat flux equivalent to atmospheric enthalpy 
+!C                    change (W/m2)
+!C d_qt_tot----input-R- Mass flux equivalent to atmospheric watter mass 
+!C                    change (kg/m2/s)
+!C d_ec_tot----input-R- Flux equivalent to atmospheric cinetic energy
+!C                    change (W/m2)
+!C
+!C fs_bound---output-R- Thermal flux at the atmosphere boundaries (W/m2)
+!C fq_bound---output-R- Watter mass flux at the atmosphere boundaries (kg/m2/s)
+!C
+!C J.L. Dufresne, July 2002
+!C Version prise sur ~rlmd833/LMDZOR_201102/modipsl/modeles/LMDZ.3.3/libf/phylmd
+!C  le 25 Novembre 2002.
+!C======================================================================
+!C 
+      use dimphy
+      implicit none
+
+#include "dimensions.h"
+!ccccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+!C
+!C     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt
+      real tops(klon),topl(klon),sols(klon),soll(klon)
+      real sens(klon),evap(klon),rain_fall(klon),snow_fall(klon)
+      REAL ts(klon)
+      REAL d_etp_tot, d_qt_tot, d_ec_tot
+!c     Output variables
+      REAL fs_bound, fq_bound
+!C
+!C     Local variables
+      real stops,stopl,ssols,ssoll
+      real ssens,sfront,slat
+      real airetot, zcpvap, zcwat, zcice
+      REAL rain_fall_tot, snow_fall_tot, evap_tot
+!C
+      integer i
+!C
+      integer pas
+      save pas
+      data pas/0/
+!$OMP THREADPRIVATE(pas)
+!C
+      pas=pas+1
+      stops=0.
+      stopl=0.
+      ssols=0.
+      ssoll=0.
+      ssens=0.
+      sfront = 0.
+      evap_tot = 0.
+      rain_fall_tot = 0.
+      snow_fall_tot = 0.
+      airetot=0.
+!C
+!C     Pour les chaleur specifiques de la vapeur d'eau, de l'eau et de
+!C     la glace, on travaille par difference a la chaleur specifique de l'
+!c     air sec. En effet, comme on travaille a niveau de pression donne,
+!C     toute variation de la masse d'un constituant est totalement
+!c     compense par une variation de masse d'air.
+!C
+      zcpvap=RCPV-RCPD
+      zcwat=RCW-RCPD
+      zcice=RCS-RCPD
+!C
+      do i=1,klon
+           stops=stops+tops(i)*airephy(i)
+           stopl=stopl+topl(i)*airephy(i)
+           ssols=ssols+sols(i)*airephy(i)
+           ssoll=ssoll+soll(i)*airephy(i)
+           ssens=ssens+sens(i)*airephy(i)
+           sfront = sfront                                                           &
+       &         + ( evap(i)*zcpvap-rain_fall(i)*zcwat-snow_fall(i)*zcice            &
+       &           ) *ts(i) *airephy(i)
+           evap_tot = evap_tot + evap(i)*airephy(i)
+           rain_fall_tot = rain_fall_tot + rain_fall(i)*airephy(i)
+           snow_fall_tot = snow_fall_tot + snow_fall(i)*airephy(i)
+           airetot=airetot+airephy(i)
+      enddo
+      stops=stops/airetot
+      stopl=stopl/airetot
+      ssols=ssols/airetot
+      ssoll=ssoll/airetot
+      ssens=ssens/airetot
+      sfront = sfront/airetot
+      evap_tot = evap_tot /airetot
+      rain_fall_tot = rain_fall_tot/airetot
+      snow_fall_tot = snow_fall_tot/airetot
+!C
+      slat = RLVTT * rain_fall_tot + RLSTT * snow_fall_tot
+!C     Heat flux at atm. boundaries
+      fs_bound = stops-stopl - (ssols+ssoll)+ssens+sfront                            &
+       &    + slat
+!C     Watter flux at atm. boundaries
+      fq_bound = evap_tot - rain_fall_tot -snow_fall_tot
+!C
+      IF (iprt.ge.1) write(6,6666)                                                   &
+       &    tit, pas, fs_bound, d_etp_tot, fq_bound, d_qt_tot
+!C
+      IF (iprt.ge.1) write(6,6668)                                                   &
+       &    tit, pas, d_etp_tot+d_ec_tot-fs_bound, d_qt_tot-fq_bound
+!C
+      IF (iprt.ge.2) write(6,6667)                                                   &
+       &    tit, pas, stops,stopl,ssols,ssoll,ssens,slat,evap_tot                    &
+       &    ,rain_fall_tot+snow_fall_tot
+
+      return
+
+ 6666 format('Phys. Flux Budget ',a15,1i6,2f8.2,2(1pE13.5))
+ 6667 format('Phys. Boundary Flux ',a15,1i6,6f8.2,2(1pE13.5))
+ 6668 format('Phys. Total Budget ',a15,1i6,f8.2,2(1pE13.5))
+
+      end SUBROUTINE diagphy
+
+!C======================================================================
+      SUBROUTINE diagetpq(airephy,tit,iprt,idiag,idiag2,dtime                        &
+       &  ,t,q,ql,qs,u,v,paprs,pplay                                                 &
+       &  , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+!C======================================================================
+!C
+!C Purpose:
+!C    Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
+!C    et calcul le flux de chaleur et le flux d'eau necessaire a ces 
+!C    changements. Ces valeurs sont moyennees sur la surface de tout
+!C    le globe et sont exprime en W/2 et kg/s/m2
+!C    Outil pour diagnostiquer la conservation de l'energie
+!C    et de la masse dans la physique. Suppose que les niveau de
+!c    pression entre couche ne varie pas entre 2 appels.
+!C
+!C Plusieurs de ces diagnostics peuvent etre fait en parallele: les
+!c bilans sont sauvegardes dans des tableaux indices. On parlera
+!C "d'indice de diagnostic"
+!c 
+!C
+!c======================================================================
+!C Arguments: 
+!C airephy-------input-R-  grid area
+!C tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
+!C iprt----input-I-  PRINT level ( <=1 : no PRINT)
+!C idiag---input-I- indice dans lequel sera range les nouveaux
+!C                  bilans d' entalpie et de masse
+!C idiag2--input-I-les nouveaux bilans d'entalpie et de masse 
+!C                 sont compare au bilan de d'enthalpie de masse de
+!C                 l'indice numero idiag2 
+!C                 Cas parriculier : si idiag2=0, pas de comparaison, on
+!c                 sort directement les bilans d'enthalpie et de masse 
+!C dtime----input-R- time step (s)
+!c t--------input-R- temperature (K)
+!c q--------input-R- vapeur d'eau (kg/kg)
+!c ql-------input-R- liquid watter (kg/kg)
+!c qs-------input-R- solid watter (kg/kg)
+!c u--------input-R- vitesse u
+!c v--------input-R- vitesse v
+!c paprs----input-R- pression a intercouche (Pa)
+!c pplay----input-R- pression au milieu de couche (Pa)
+!c
+!C the following total value are computed by UNIT of earth surface
+!C
+!C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy 
+!c            change (J/m2) during one time step (dtime) for the whole 
+!C            atmosphere (air, watter vapour, liquid and solid)
+!C d_qt------output-R- total water mass flux (kg/m2/s) defined as the 
+!C           total watter (kg/m2) change during one time step (dtime),
+!C d_qw------output-R- same, for the watter vapour only (kg/m2/s)
+!C d_ql------output-R- same, for the liquid watter only (kg/m2/s)
+!C d_qs------output-R- same, for the solid watter only (kg/m2/s)
+!C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
+!C
+!C     other (COMMON...)
+!C     RCPD, RCPV, ....
+!C
+!C J.L. Dufresne, July 2002
+!c======================================================================
+ 
+      USE dimphy
+      IMPLICIT NONE
+!C
+#include "dimensions.h"
+!cccccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+!C
+!c     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt,idiag, idiag2
+      REAL dtime
+      REAL t(klon,klev), q(klon,klev), ql(klon,klev), qs(klon,klev)
+      REAL u(klon,klev), v(klon,klev)
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+!c     Output variables
+      REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
+!C
+!C     Local variables
+!c
+      REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot                                &
+       &  , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+!c h_vcol_tot--  total enthalpy of vertical air column 
+!C            (air with watter vapour, liquid and solid) (J/m2)
+!c h_dair_tot-- total enthalpy of dry air (J/m2)
+!c h_qw_tot----  total enthalpy of watter vapour (J/m2)
+!c h_ql_tot----  total enthalpy of liquid watter (J/m2)
+!c h_qs_tot----  total enthalpy of solid watter  (J/m2)
+!c qw_tot------  total mass of watter vapour (kg/m2)
+!c ql_tot------  total mass of liquid watter (kg/m2)
+!c qs_tot------  total mass of solid watter (kg/m2)
+!c ec_tot------  total cinetic energy (kg/m2)
+!C
+      REAL zairm(klon,klev) ! layer air mass (kg/m2)
+      REAL  zqw_col(klon)
+      REAL  zql_col(klon)
+      REAL  zqs_col(klon)
+      REAL  zec_col(klon)
+      REAL  zh_dair_col(klon)
+      REAL  zh_qw_col(klon), zh_ql_col(klon), zh_qs_col(klon)
+!C
+      REAL      d_h_dair, d_h_qw, d_h_ql, d_h_qs
+!C
+      REAL airetot, zcpvap, zcwat, zcice
+!C
+      INTEGER i, k
+!C
+      INTEGER ndiag     ! max number of diagnostic in parallel
+      PARAMETER (ndiag=10)
+      integer pas(ndiag)
+      save pas
+      data pas/ndiag*0/
+!$OMP THREADPRIVATE(pas)
+!C     
+      REAL      h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag)                &
+       &    , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag)                        &
+       &    , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag)
+      SAVE      h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre                           &
+       &        , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre
+!$OMP THREADPRIVATE(h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre)
+!$OMP THREADPRIVATE(h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre)
+!c======================================================================
+!C
+
+!Lluis
+      INTEGER :: ix,iy,pl,il,jl
+
+      pl=813
+      jl=INT(pl/iim) + 1
+      il=pl-(jl-1)*iim
+
+      DO k = 1, klev
+        DO i = 1, klon
+!C         layer air mass
+          zairm(i,k) = (paprs(i,k)-paprs(i,k+1))/RG
+        ENDDO
+      END DO
+!C
+!C     Reset variables
+      DO i = 1, klon
+        zqw_col(i)=0.
+        zql_col(i)=0.
+        zqs_col(i)=0.
+        zec_col(i) = 0.
+        zh_dair_col(i) = 0.
+        zh_qw_col(i) = 0.
+        zh_ql_col(i) = 0.
+        zh_qs_col(i) = 0.
+      ENDDO
+!C
+      zcpvap=RCPV
+      zcwat=RCW
+      zcice=RCS
+!C
+!C     Compute vertical sum for each atmospheric column
+!C     ================================================
+      DO k = 1, klev
+        DO i = 1, klon
+!C         Watter mass
+          zqw_col(i) = zqw_col(i) + q(i,k)*zairm(i,k)
+          zql_col(i) = zql_col(i) + ql(i,k)*zairm(i,k)
+          zqs_col(i) = zqs_col(i) + qs(i,k)*zairm(i,k)
+!C         Cinetic Energy
+          zec_col(i) =  zec_col(i)                                                   &
+       &        +0.5*(u(i,k)**2+v(i,k)**2)*zairm(i,k)
+!C         Air enthalpy
+          zh_dair_col(i) = zh_dair_col(i)                                            &
+       &        + RCPD*(1.-q(i,k)-ql(i,k)-qs(i,k))*zairm(i,k)*t(i,k)
+          zh_qw_col(i) = zh_qw_col(i)                                                &
+       &        + zcpvap*q(i,k)*zairm(i,k)*t(i,k) 
+          zh_ql_col(i) = zh_ql_col(i)                                                &
+       &        + zcwat*ql(i,k)*zairm(i,k)*t(i,k)                                    &
+       &        - RLVTT*ql(i,k)*zairm(i,k)
+          zh_qs_col(i) = zh_qs_col(i)                                                &
+       &        + zcice*qs(i,k)*zairm(i,k)*t(i,k)                                    &
+       &        - RLSTT*qs(i,k)*zairm(i,k)
+
+        END DO
+      ENDDO
+
+!C
+!C     Mean over the planete surface
+!C     =============================
+      qw_tot = 0.
+      ql_tot = 0.
+      qs_tot = 0.
+      ec_tot = 0.
+      h_vcol_tot = 0.
+      h_dair_tot = 0.
+      h_qw_tot = 0.
+      h_ql_tot = 0.
+      h_qs_tot = 0.
+      airetot=0.
+!C
+      do i=1,klon
+        qw_tot = qw_tot + zqw_col(i)*airephy(i)
+        ql_tot = ql_tot + zql_col(i)*airephy(i)
+        qs_tot = qs_tot + zqs_col(i)*airephy(i)
+        ec_tot = ec_tot + zec_col(i)*airephy(i)
+        h_dair_tot = h_dair_tot + zh_dair_col(i)*airephy(i)
+        h_qw_tot = h_qw_tot + zh_qw_col(i)*airephy(i)
+        h_ql_tot = h_ql_tot + zh_ql_col(i)*airephy(i)
+        h_qs_tot = h_qs_tot + zh_qs_col(i)*airephy(i)
+        airetot=airetot+airephy(i)
+      END DO
+
+!C
+      qw_tot = qw_tot/airetot
+      ql_tot = ql_tot/airetot
+      qs_tot = qs_tot/airetot
+      ec_tot = ec_tot/airetot
+      h_dair_tot = h_dair_tot/airetot
+      h_qw_tot = h_qw_tot/airetot
+      h_ql_tot = h_ql_tot/airetot
+      h_qs_tot = h_qs_tot/airetot
+!C
+      h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot
+!C
+!C     Compute the change of the atmospheric state compare to the one 
+!C     stored in "idiag2", and convert it in flux. THis computation
+!C     is performed IF idiag2 /= 0 and IF it is not the first CALL
+!c     for "idiag"
+!C     ===================================
+!C
+      IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN
+        d_h_vcol  = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime
+        d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime
+        d_h_qw   = (h_qw_tot  - h_qw_pre(idiag2)  )/dtime
+        d_h_ql   = (h_ql_tot  - h_ql_pre(idiag2)  )/dtime 
+        d_h_qs   = (h_qs_tot  - h_qs_pre(idiag2)  )/dtime 
+        d_qw     = (qw_tot    - qw_pre(idiag2)    )/dtime
+        d_ql     = (ql_tot    - ql_pre(idiag2)    )/dtime
+        d_qs     = (qs_tot    - qs_pre(idiag2)    )/dtime
+        d_ec     = (ec_tot    - ec_pre(idiag2)    )/dtime
+        d_qt = d_qw + d_ql + d_qs
+
+      ELSE 
+        d_h_vcol = 0.
+        d_h_dair = 0.
+        d_h_qw   = 0.
+        d_h_ql   = 0.
+        d_h_qs   = 0. 
+        d_qw     = 0.
+        d_ql     = 0.
+        d_qs     = 0.
+        d_ec     = 0.
+        d_qt     = 0.
+      ENDIF 
+!C
+      IF (iprt.ge.2) THEN
+        WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs
+ 9000   format('Phys. Watter Mass Budget (kg/m2/s)',A15                              &
+       &      ,1i6,10(1pE14.6))
+        WRITE(6,9001) tit,pas(idiag), d_h_vcol
+ 9001   format('Phys. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2))
+        WRITE(6,9002) tit,pas(idiag), d_ec
+ 9002   format('Phys. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+      END IF 
+!C
+!C     Store the new atmospheric state in "idiag"
+!C
+      pas(idiag)=pas(idiag)+1
+      h_vcol_pre(idiag)  = h_vcol_tot
+      h_dair_pre(idiag) = h_dair_tot
+      h_qw_pre(idiag)   = h_qw_tot
+      h_ql_pre(idiag)   = h_ql_tot
+      h_qs_pre(idiag)   = h_qs_tot
+      qw_pre(idiag)     = qw_tot
+      ql_pre(idiag)     = ql_tot
+      qs_pre(idiag)     = qs_tot
+      ec_pre (idiag)    = ec_tot
+!C
+      RETURN 
+      END SUBROUTINE diagetpq
+
+!!END MODULE diagphy
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/diagphy_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/diagphy_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/diagphy_mod.F90	(revision 17)
@@ -0,0 +1,424 @@
+!
+! $Header$
+!
+MODULE diagphy_mod
+
+  CONTAINS
+
+      SUBROUTINE diagphy(airephy,tit,iprt                                            &
+       &    , tops, topl, sols, soll, sens                                           &
+       &    , evap, rain_fall, snow_fall, ts                                         &
+       &    , d_etp_tot, d_qt_tot, d_ec_tot                                          &
+       &    , fs_bound, fq_bound)
+!C======================================================================
+!C
+!C Purpose:
+!C    Compute the thermal flux and the watter mass flux at the atmosphere
+!c    boundaries. Print them and also the atmospheric enthalpy change and
+!C    the  atmospheric mass change.
+!C
+!C Arguments: 
+!C airephy-------input-R-  grid area
+!C tit---------input-A15- Comment to be added in PRINT (CHARACTER*15)
+!C iprt--------input-I-  PRINT level ( <=0 : no PRINT)
+!C tops(klon)--input-R-  SW rad. at TOA (W/m2), positive up.
+!C topl(klon)--input-R-  LW rad. at TOA (W/m2), positive down
+!C sols(klon)--input-R-  Net SW flux above surface (W/m2), positive up 
+!C                   (i.e. -1 * flux absorbed by the surface)
+!C soll(klon)--input-R-  Net LW flux above surface (W/m2), positive up 
+!C                   (i.e. flux emited - flux absorbed by the surface)
+!C sens(klon)--input-R-  Sensible Flux at surface  (W/m2), positive down
+!C evap(klon)--input-R-  Evaporation + sublimation watter vapour mass flux
+!C                   (kg/m2/s), positive up
+!C rain_fall(klon)
+!C           --input-R- Liquid  watter mass flux (kg/m2/s), positive down
+!C snow_fall(klon)
+!C           --input-R- Solid  watter mass flux (kg/m2/s), positive down
+!C ts(klon)----input-R- Surface temperature (K)
+!C d_etp_tot---input-R- Heat flux equivalent to atmospheric enthalpy 
+!C                    change (W/m2)
+!C d_qt_tot----input-R- Mass flux equivalent to atmospheric watter mass 
+!C                    change (kg/m2/s)
+!C d_ec_tot----input-R- Flux equivalent to atmospheric cinetic energy
+!C                    change (W/m2)
+!C
+!C fs_bound---output-R- Thermal flux at the atmosphere boundaries (W/m2)
+!C fq_bound---output-R- Watter mass flux at the atmosphere boundaries (kg/m2/s)
+!C
+!C J.L. Dufresne, July 2002
+!C Version prise sur ~rlmd833/LMDZOR_201102/modipsl/modeles/LMDZ.3.3/libf/phylmd
+!C  le 25 Novembre 2002.
+!C======================================================================
+!C 
+      use dimphy
+      implicit none
+
+#include "dimensions.h"
+!ccccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+!C
+!C     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt
+      real tops(klon),topl(klon),sols(klon),soll(klon)
+      real sens(klon),evap(klon),rain_fall(klon),snow_fall(klon)
+      REAL ts(klon)
+      REAL d_etp_tot, d_qt_tot, d_ec_tot
+!c     Output variables
+      REAL fs_bound, fq_bound
+!C
+!C     Local variables
+      real stops,stopl,ssols,ssoll
+      real ssens,sfront,slat
+      real airetot, zcpvap, zcwat, zcice
+      REAL rain_fall_tot, snow_fall_tot, evap_tot
+!C
+      integer i
+!C
+      integer pas
+      save pas
+      data pas/0/
+!$OMP THREADPRIVATE(pas)
+!C
+      pas=pas+1
+      stops=0.
+      stopl=0.
+      ssols=0.
+      ssoll=0.
+      ssens=0.
+      sfront = 0.
+      evap_tot = 0.
+      rain_fall_tot = 0.
+      snow_fall_tot = 0.
+      airetot=0.
+!C
+!C     Pour les chaleur specifiques de la vapeur d'eau, de l'eau et de
+!C     la glace, on travaille par difference a la chaleur specifique de l'
+!c     air sec. En effet, comme on travaille a niveau de pression donne,
+!C     toute variation de la masse d'un constituant est totalement
+!c     compense par une variation de masse d'air.
+!C
+      zcpvap=RCPV-RCPD
+      zcwat=RCW-RCPD
+      zcice=RCS-RCPD
+!C
+      do i=1,klon
+           stops=stops+tops(i)*airephy(i)
+           stopl=stopl+topl(i)*airephy(i)
+           ssols=ssols+sols(i)*airephy(i)
+           ssoll=ssoll+soll(i)*airephy(i)
+           ssens=ssens+sens(i)*airephy(i)
+           sfront = sfront                                                           &
+       &         + ( evap(i)*zcpvap-rain_fall(i)*zcwat-snow_fall(i)*zcice            &
+       &           ) *ts(i) *airephy(i)
+           evap_tot = evap_tot + evap(i)*airephy(i)
+           rain_fall_tot = rain_fall_tot + rain_fall(i)*airephy(i)
+           snow_fall_tot = snow_fall_tot + snow_fall(i)*airephy(i)
+           airetot=airetot+airephy(i)
+      enddo
+      stops=stops/airetot
+      stopl=stopl/airetot
+      ssols=ssols/airetot
+      ssoll=ssoll/airetot
+      ssens=ssens/airetot
+      sfront = sfront/airetot
+      evap_tot = evap_tot /airetot
+      rain_fall_tot = rain_fall_tot/airetot
+      snow_fall_tot = snow_fall_tot/airetot
+!C
+      slat = RLVTT * rain_fall_tot + RLSTT * snow_fall_tot
+!C     Heat flux at atm. boundaries
+      fs_bound = stops-stopl - (ssols+ssoll)+ssens+sfront                            &
+       &    + slat
+!C     Watter flux at atm. boundaries
+      fq_bound = evap_tot - rain_fall_tot -snow_fall_tot
+!C
+      IF (iprt.ge.1) write(6,6666)                                                   &
+       &    tit, pas, fs_bound, d_etp_tot, fq_bound, d_qt_tot
+!C
+      IF (iprt.ge.1) write(6,6668)                                                   &
+       &    tit, pas, d_etp_tot+d_ec_tot-fs_bound, d_qt_tot-fq_bound
+!C
+      IF (iprt.ge.2) write(6,6667)                                                   &
+       &    tit, pas, stops,stopl,ssols,ssoll,ssens,slat,evap_tot                    &
+       &    ,rain_fall_tot+snow_fall_tot
+
+      return
+
+ 6666 format('Phys. Flux Budget ',a15,1i6,2f8.2,2(1pE13.5))
+ 6667 format('Phys. Boundary Flux ',a15,1i6,6f8.2,2(1pE13.5))
+ 6668 format('Phys. Total Budget ',a15,1i6,f8.2,2(1pE13.5))
+
+      end SUBROUTINE diagphy
+
+!C======================================================================
+      SUBROUTINE diagetpq(airephy,tit,iprt,idiag,idiag2,dtime                        &
+       &  ,t,q,ql,qs,u,v,paprs,pplay                                                 &
+       &  , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+!C======================================================================
+!C
+!C Purpose:
+!C    Calcul la difference d'enthalpie et de masse d'eau entre 2 appels,
+!C    et calcul le flux de chaleur et le flux d'eau necessaire a ces 
+!C    changements. Ces valeurs sont moyennees sur la surface de tout
+!C    le globe et sont exprime en W/2 et kg/s/m2
+!C    Outil pour diagnostiquer la conservation de l'energie
+!C    et de la masse dans la physique. Suppose que les niveau de
+!c    pression entre couche ne varie pas entre 2 appels.
+!C
+!C Plusieurs de ces diagnostics peuvent etre fait en parallele: les
+!c bilans sont sauvegardes dans des tableaux indices. On parlera
+!C "d'indice de diagnostic"
+!c 
+!C
+!c======================================================================
+!C Arguments: 
+!C airephy-------input-R-  grid area
+!C tit-----imput-A15- Comment added in PRINT (CHARACTER*15)
+!C iprt----input-I-  PRINT level ( <=1 : no PRINT)
+!C idiag---input-I- indice dans lequel sera range les nouveaux
+!C                  bilans d' entalpie et de masse
+!C idiag2--input-I-les nouveaux bilans d'entalpie et de masse 
+!C                 sont compare au bilan de d'enthalpie de masse de
+!C                 l'indice numero idiag2 
+!C                 Cas parriculier : si idiag2=0, pas de comparaison, on
+!c                 sort directement les bilans d'enthalpie et de masse 
+!C dtime----input-R- time step (s)
+!c t--------input-R- temperature (K)
+!c q--------input-R- vapeur d'eau (kg/kg)
+!c ql-------input-R- liquid watter (kg/kg)
+!c qs-------input-R- solid watter (kg/kg)
+!c u--------input-R- vitesse u
+!c v--------input-R- vitesse v
+!c paprs----input-R- pression a intercouche (Pa)
+!c pplay----input-R- pression au milieu de couche (Pa)
+!c
+!C the following total value are computed by UNIT of earth surface
+!C
+!C d_h_vcol--output-R- Heat flux (W/m2) define as the Enthalpy 
+!c            change (J/m2) during one time step (dtime) for the whole 
+!C            atmosphere (air, watter vapour, liquid and solid)
+!C d_qt------output-R- total water mass flux (kg/m2/s) defined as the 
+!C           total watter (kg/m2) change during one time step (dtime),
+!C d_qw------output-R- same, for the watter vapour only (kg/m2/s)
+!C d_ql------output-R- same, for the liquid watter only (kg/m2/s)
+!C d_qs------output-R- same, for the solid watter only (kg/m2/s)
+!C d_ec------output-R- Cinetic Energy Budget (W/m2) for vertical air column
+!C
+!C     other (COMMON...)
+!C     RCPD, RCPV, ....
+!C
+!C J.L. Dufresne, July 2002
+!c======================================================================
+ 
+      USE dimphy
+      IMPLICIT NONE
+!C
+#include "dimensions.h"
+!cccccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+!C
+!c     Input variables
+      real airephy(klon)
+      CHARACTER*15 tit
+      INTEGER iprt,idiag, idiag2
+      REAL dtime
+      REAL t(klon,klev), q(klon,klev), ql(klon,klev), qs(klon,klev)
+      REAL u(klon,klev), v(klon,klev)
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+!c     Output variables
+      REAL d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec
+!C
+!C     Local variables
+!c
+      REAL h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot                                &
+       &  , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+!c h_vcol_tot--  total enthalpy of vertical air column 
+!C            (air with watter vapour, liquid and solid) (J/m2)
+!c h_dair_tot-- total enthalpy of dry air (J/m2)
+!c h_qw_tot----  total enthalpy of watter vapour (J/m2)
+!c h_ql_tot----  total enthalpy of liquid watter (J/m2)
+!c h_qs_tot----  total enthalpy of solid watter  (J/m2)
+!c qw_tot------  total mass of watter vapour (kg/m2)
+!c ql_tot------  total mass of liquid watter (kg/m2)
+!c qs_tot------  total mass of solid watter (kg/m2)
+!c ec_tot------  total cinetic energy (kg/m2)
+!C
+      REAL zairm(klon,klev) ! layer air mass (kg/m2)
+      REAL  zqw_col(klon)
+      REAL  zql_col(klon)
+      REAL  zqs_col(klon)
+      REAL  zec_col(klon)
+      REAL  zh_dair_col(klon)
+      REAL  zh_qw_col(klon), zh_ql_col(klon), zh_qs_col(klon)
+!C
+      REAL      d_h_dair, d_h_qw, d_h_ql, d_h_qs
+!C
+      REAL airetot, zcpvap, zcwat, zcice
+!C
+      INTEGER i, k
+!C
+      INTEGER ndiag     ! max number of diagnostic in parallel
+      PARAMETER (ndiag=10)
+      integer pas(ndiag)
+      save pas
+      data pas/ndiag*0/
+!$OMP THREADPRIVATE(pas)
+!C     
+      REAL      h_vcol_pre(ndiag), h_dair_pre(ndiag), h_qw_pre(ndiag)                &
+       &    , h_ql_pre(ndiag), h_qs_pre(ndiag), qw_pre(ndiag)                        &
+       &    , ql_pre(ndiag), qs_pre(ndiag) , ec_pre(ndiag)
+      SAVE      h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre                           &
+       &        , h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre
+!$OMP THREADPRIVATE(h_vcol_pre, h_dair_pre, h_qw_pre, h_ql_pre)
+!$OMP THREADPRIVATE(h_qs_pre, qw_pre, ql_pre, qs_pre , ec_pre)
+!c======================================================================
+!C
+      DO k = 1, klev
+        DO i = 1, klon
+!C         layer air mass
+          zairm(i,k) = (paprs(i,k)-paprs(i,k+1))/RG
+        ENDDO
+      END DO
+!C
+!C     Reset variables
+      DO i = 1, klon
+        zqw_col(i)=0.
+        zql_col(i)=0.
+        zqs_col(i)=0.
+        zec_col(i) = 0.
+        zh_dair_col(i) = 0.
+        zh_qw_col(i) = 0.
+        zh_ql_col(i) = 0.
+        zh_qs_col(i) = 0.
+      ENDDO
+!C
+      zcpvap=RCPV
+      zcwat=RCW
+      zcice=RCS
+!C
+!C     Compute vertical sum for each atmospheric column
+!C     ================================================
+      DO k = 1, klev
+        DO i = 1, klon
+!C         Watter mass
+          zqw_col(i) = zqw_col(i) + q(i,k)*zairm(i,k)
+          zql_col(i) = zql_col(i) + ql(i,k)*zairm(i,k)
+          zqs_col(i) = zqs_col(i) + qs(i,k)*zairm(i,k)
+!C         Cinetic Energy
+          zec_col(i) =  zec_col(i)                                                   &
+       &        +0.5*(u(i,k)**2+v(i,k)**2)*zairm(i,k)
+!C         Air enthalpy
+          zh_dair_col(i) = zh_dair_col(i)                                            &
+       &        + RCPD*(1.-q(i,k)-ql(i,k)-qs(i,k))*zairm(i,k)*t(i,k)
+          zh_qw_col(i) = zh_qw_col(i)                                                &
+       &        + zcpvap*q(i,k)*zairm(i,k)*t(i,k) 
+          zh_ql_col(i) = zh_ql_col(i)                                                &
+       &        + zcwat*ql(i,k)*zairm(i,k)*t(i,k)                                    &
+       &        - RLVTT*ql(i,k)*zairm(i,k)
+          zh_qs_col(i) = zh_qs_col(i)                                                &
+       &        + zcice*qs(i,k)*zairm(i,k)*t(i,k)                                    &
+       &        - RLSTT*qs(i,k)*zairm(i,k)
+
+        END DO
+      ENDDO
+
+!C
+!C     Mean over the planete surface
+!C     =============================
+      qw_tot = 0.
+      ql_tot = 0.
+      qs_tot = 0.
+      ec_tot = 0.
+      h_vcol_tot = 0.
+      h_dair_tot = 0.
+      h_qw_tot = 0.
+      h_ql_tot = 0.
+      h_qs_tot = 0.
+      airetot=0.
+!C
+      do i=1,klon
+        qw_tot = qw_tot + zqw_col(i)*airephy(i)
+        ql_tot = ql_tot + zql_col(i)*airephy(i)
+        qs_tot = qs_tot + zqs_col(i)*airephy(i)
+        ec_tot = ec_tot + zec_col(i)*airephy(i)
+        h_dair_tot = h_dair_tot + zh_dair_col(i)*airephy(i)
+        h_qw_tot = h_qw_tot + zh_qw_col(i)*airephy(i)
+        h_ql_tot = h_ql_tot + zh_ql_col(i)*airephy(i)
+        h_qs_tot = h_qs_tot + zh_qs_col(i)*airephy(i)
+        airetot=airetot+airephy(i)
+      END DO
+!C
+      qw_tot = qw_tot/airetot
+      ql_tot = ql_tot/airetot
+      qs_tot = qs_tot/airetot
+      ec_tot = ec_tot/airetot
+      h_dair_tot = h_dair_tot/airetot
+      h_qw_tot = h_qw_tot/airetot
+      h_ql_tot = h_ql_tot/airetot
+      h_qs_tot = h_qs_tot/airetot
+!C
+      h_vcol_tot = h_dair_tot+h_qw_tot+h_ql_tot+h_qs_tot
+!C
+!C     Compute the change of the atmospheric state compare to the one 
+!C     stored in "idiag2", and convert it in flux. THis computation
+!C     is performed IF idiag2 /= 0 and IF it is not the first CALL
+!c     for "idiag"
+!C     ===================================
+!C
+      IF ( (idiag2.gt.0) .and. (pas(idiag2) .ne. 0) ) THEN
+        d_h_vcol  = (h_vcol_tot - h_vcol_pre(idiag2) )/dtime
+        d_h_dair = (h_dair_tot- h_dair_pre(idiag2))/dtime
+        d_h_qw   = (h_qw_tot  - h_qw_pre(idiag2)  )/dtime
+        d_h_ql   = (h_ql_tot  - h_ql_pre(idiag2)  )/dtime 
+        d_h_qs   = (h_qs_tot  - h_qs_pre(idiag2)  )/dtime 
+        d_qw     = (qw_tot    - qw_pre(idiag2)    )/dtime
+        d_ql     = (ql_tot    - ql_pre(idiag2)    )/dtime
+        d_qs     = (qs_tot    - qs_pre(idiag2)    )/dtime
+        d_ec     = (ec_tot    - ec_pre(idiag2)    )/dtime
+        d_qt = d_qw + d_ql + d_qs
+
+      ELSE 
+        d_h_vcol = 0.
+        d_h_dair = 0.
+        d_h_qw   = 0.
+        d_h_ql   = 0.
+        d_h_qs   = 0. 
+        d_qw     = 0.
+        d_ql     = 0.
+        d_qs     = 0.
+        d_ec     = 0.
+        d_qt     = 0.
+      ENDIF 
+!C
+      IF (iprt.ge.2) THEN
+        WRITE(6,9000) tit,pas(idiag),d_qt,d_qw,d_ql,d_qs
+ 9000   format('Phys. Watter Mass Budget (kg/m2/s)',A15                              &
+       &      ,1i6,10(1pE14.6))
+        WRITE(6,9001) tit,pas(idiag), d_h_vcol
+ 9001   format('Phys. Enthalpy Budget (W/m2) ',A15,1i6,10(F8.2))
+        WRITE(6,9002) tit,pas(idiag), d_ec
+ 9002   format('Phys. Cinetic Energy Budget (W/m2) ',A15,1i6,10(F8.2))
+      END IF 
+!C
+!C     Store the new atmospheric state in "idiag"
+!C
+      pas(idiag)=pas(idiag)+1
+      h_vcol_pre(idiag)  = h_vcol_tot
+      h_dair_pre(idiag) = h_dair_tot
+      h_qw_pre(idiag)   = h_qw_tot
+      h_ql_pre(idiag)   = h_ql_tot
+      h_qs_pre(idiag)   = h_qs_tot
+      qw_pre(idiag)     = qw_tot
+      ql_pre(idiag)     = ql_tot
+      qs_pre(idiag)     = qs_tot
+      ec_pre (idiag)    = ec_tot
+!C
+      RETURN 
+      END SUBROUTINE diagetpq
+
+END MODULE diagphy_mod
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/dimensions.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/dimensions.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/dimensions.h	(revision 17)
@@ -0,0 +1,5 @@
+
+       INTEGER iim,jjm,llm,ndm,wiim,wjjm,wbdym
+
+       PARAMETER (iim= 1, jjm=13029,llm=38,ndm=1,wiim=129,wjjm=109,wbdym=5)
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/dimphy.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/dimphy.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/dimphy.F90	(revision 17)
@@ -0,0 +1,40 @@
+MODULE dimphy
+  
+  INTEGER,SAVE :: klon
+  INTEGER,SAVE :: kdlon
+  INTEGER,SAVE :: kfdia
+  INTEGER,SAVE :: kidia
+  INTEGER,SAVE :: klev
+  INTEGER,SAVE :: klevp1
+  INTEGER,SAVE :: klevm1
+  INTEGER,SAVE :: kflev
+
+!$OMP THREADPRIVATE(klon,kfdia,kidia,kdlon)
+  REAL,save,allocatable,dimension(:) :: zmasq
+!$OMP THREADPRIVATE(zmasq)   
+
+CONTAINS
+  
+  SUBROUTINE Init_dimphy(klon0,klev0)
+  IMPLICIT NONE
+  
+    INTEGER, INTENT(in) :: klon0
+    INTEGER, INTENT(in) :: klev0
+    
+    klon=klon0
+    
+    kdlon=klon
+    kidia=1
+    kfdia=klon
+!$OMP MASTER 
+    klev=klev0
+    klevp1=klev+1
+    klevm1=klev-1
+    kflev=klev
+!$OMP END MASTER    
+    ALLOCATE(zmasq(klon))    
+    
+  END SUBROUTINE Init_dimphy
+
+  
+END MODULE dimphy
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/dimsoil.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/dimsoil.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/dimsoil.h	(revision 17)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER nsoilmx
+      PARAMETER (nsoilmx=11)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ener_conserv.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ener_conserv.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ener_conserv.F90	(revision 17)
@@ -0,0 +1,171 @@
+subroutine ener_conserv(klon,klev,pdtphys, &
+ &    puo,pvo,pto,pqo,pun,pvn,ptn,pqn,dtke,masse,exner,d_t_ec)
+
+!=============================================================
+! Energy conservation
+! Based on the TKE equation
+! The M2 and N2 terms at the origin of TKE production are
+! concerted into heating in the d_t_ec term
+! Option 1 is the standard
+!        101 is for M2 term only
+!        101 for N2 term only
+!         -1 is a previours treatment for kinetic energy only
+!  FH (hourdin@lmd.jussieu.fr), 2013/04/25
+!=============================================================
+
+!=============================================================
+! Declarations
+!=============================================================
+
+! From module
+USE phys_local_var_mod, ONLY : d_u_vdf,d_v_vdf,d_t_vdf,d_u_ajs,d_v_ajs,d_t_ajs,d_u_con,d_v_con,d_t_con,d_t_diss
+USE phys_output_var_mod, ONLY : bils_ec,bils_tke,bils_kinetic,bils_enthalp,bils_latent,bils_diss
+
+IMPLICIT none
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "clesphys.h"
+#include "compbl.h"
+
+! Arguments
+INTEGER, INTENT(IN) :: klon,klev
+REAL, INTENT(IN) :: pdtphys
+REAL, DIMENSION(klon,klev),INTENT(IN) :: puo,pvo,pto,pqo
+REAL, DIMENSION(klon,klev),INTENT(IN) :: pun,pvn,ptn,pqn
+REAL, DIMENSION(klon,klev),INTENT(IN) :: masse,exner
+REAL, DIMENSION(klon,klev+1),INTENT(IN) :: dtke
+REAL, DIMENSION(klon,klev),INTENT(OUT) :: d_t_ec
+      integer k,i
+
+! Local
+REAL, DIMENSION(klon,klev+1) :: fluxu,fluxv,fluxt
+REAL, DIMENSION(klon,klev+1) :: dddu,dddv,dddt
+REAL, DIMENSION(klon,klev) :: d_u,d_v,d_t,zv,zu
+REAL ZRCPD
+
+character*80 abort_message
+character*20 :: modname
+
+
+modname='ener_conser'
+d_t_ec(:,:)=0.
+
+IF (iflag_ener_conserv==-1) THEN
+!+jld ec_conser
+   DO k = 1, klev
+   DO i = 1, klon
+      ZRCPD = RCPD*(1.0+RVTMP2*pqn(i,k))
+      d_t_ec(i,k)=0.5/ZRCPD &
+ &      *(puo(i,k)**2+pvo(i,k)**2-pun(i,k)**2-pvn(i,k)**2)
+      ENDDO
+      ENDDO
+!-jld ec_conser
+
+
+
+ELSEIF (iflag_ener_conserv>=1) THEN
+
+   IF (iflag_ener_conserv<=2) THEN
+!     print*,'ener_conserv pbl=',iflag_pbl
+      IF (iflag_pbl>=20 .AND. iflag_pbl<=27) THEN !d_t_diss accounts for conserv
+         d_t(:,:)=d_t_ajs(:,:)   ! d_t_ajs = adjust + thermals
+         d_u(:,:)=d_u_ajs(:,:)+d_u_con(:,:)
+         d_v(:,:)=d_v_ajs(:,:)+d_v_con(:,:)
+      ELSE
+         d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:)   ! d_t_ajs = adjust + thermals
+         d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)
+         d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)
+      ENDIF
+   ELSEIF (iflag_ener_conserv==101) THEN
+      d_t(:,:)=0.
+      d_u(:,:)=d_u_vdf(:,:)+d_u_ajs(:,:)+d_u_con(:,:)
+      d_v(:,:)=d_v_vdf(:,:)+d_v_ajs(:,:)+d_v_con(:,:)
+   ELSEIF (iflag_ener_conserv==110) THEN
+      d_t(:,:)=d_t_vdf(:,:)+d_t_ajs(:,:)
+      d_u(:,:)=0.
+      d_v(:,:)=0.
+   ELSE
+      abort_message = 'iflag_ener_conserv non prevu'
+      CALL abort_gcm (modname,abort_message,1)
+   ENDIF
+
+!----------------------------------------------------------------------------
+! Two options wether we consider time integration in the energy conservation
+!----------------------------------------------------------------------------
+
+   if (iflag_ener_conserv==2) then
+      zu(:,:)=puo(:,:)
+      zv(:,:)=pvo(:,:)
+   else
+      IF (iflag_pbl>=20 .AND. iflag_pbl<=27) THEN
+         zu(:,:)=puo(:,:)+d_u_vdf(:,:)+0.5*d_u(:,:)
+         zv(:,:)=pvo(:,:)+d_v_vdf(:,:)+0.5*d_v(:,:)
+      ELSE
+         zu(:,:)=puo(:,:)+0.5*d_u(:,:)
+         zv(:,:)=pvo(:,:)+0.5*d_v(:,:)
+      ENDIF
+   endif
+
+   fluxu(:,klev+1)=0.
+   fluxv(:,klev+1)=0.
+   fluxt(:,klev+1)=0.
+
+   do k=klev,1,-1
+      fluxu(:,k)=fluxu(:,k+1)+masse(:,k)*d_u(:,k)
+      fluxv(:,k)=fluxv(:,k+1)+masse(:,k)*d_v(:,k)
+      fluxt(:,k)=fluxt(:,k+1)+masse(:,k)*d_t(:,k)/exner(:,k)
+   enddo
+
+   dddu(:,1)=2*zu(:,1)*fluxu(:,1)
+   dddv(:,1)=2*zv(:,1)*fluxv(:,1)
+   dddt(:,1)=(exner(:,1)-1.)*fluxt(:,1)
+
+   do k=2,klev
+      dddu(:,k)=(zu(:,k)-zu(:,k-1))*fluxu(:,k)
+      dddv(:,k)=(zv(:,k)-zv(:,k-1))*fluxv(:,k)
+      dddt(:,k)=(exner(:,k)-exner(:,k-1))*fluxt(:,k)
+   enddo
+   dddu(:,klev+1)=0.
+   dddv(:,klev+1)=0.
+   dddt(:,klev+1)=0.
+
+   do k=1,klev
+      d_t_ec(:,k)=-(dddu(:,k)+dddu(:,k+1)+dddv(:,k)+dddv(:,k+1) &
+   &  +rcpd*(dddt(:,k)+dddt(:,k+1)))/(2.*rcpd*masse(:,k))
+   enddo
+! d_t_ec=0.
+
+ENDIF
+
+!================================================================
+!  Computation of integrated enthalpie and kinetic energy variation
+!  FH (hourdin@lmd.jussieu.fr), 2013/04/25
+!================================================================
+
+      bils_ec(:)=0.
+      bils_tke(:)=0.
+      bils_diss(:)=0.
+      bils_kinetic(:)=0.
+      bils_enthalp(:)=0.
+      bils_latent(:)=0.
+      DO k=1,klev
+        bils_ec(:)=bils_ec(:)-d_t_ec(:,k)*masse(:,k)
+        bils_tke(:)=bils_tke(:)+0.5*(dtke(:,k)+dtke(:,k+1))*masse(:,k)
+        bils_diss(:)=bils_diss(:)-d_t_diss(:,k)*masse(:,k)
+        bils_kinetic(:)=bils_kinetic(:)+masse(:,k)* &
+     &           (pun(:,k)*pun(:,k)+pvn(:,k)*pvn(:,k) &
+     &            -puo(:,k)*puo(:,k)-pvo(:,k)*pvo(:,k))
+        bils_enthalp(:)= &
+     &  bils_enthalp(:)+masse(:,k)*(ptn(:,k)-pto(:,k)+d_t_ec(:,k))
+        bils_latent(:)=bils_latent(:)+masse(:,k)* &
+     &             (pqn(:,k)-pqo(:,k))
+      ENDDO
+      bils_ec(:)=rcpd*bils_ec(:)/pdtphys
+      bils_tke(:)=bils_tke(:)/pdtphys
+      bils_diss(:)=rcpd*bils_diss(:)/pdtphys
+      bils_kinetic(:)= 0.5*bils_kinetic(:)/pdtphys
+      bils_enthalp(:)=rcpd*bils_enthalp(:)/pdtphys
+      bils_latent(:)=rlvtt*bils_latent(:)/pdtphys
+RETURN
+
+END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/evappot.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/evappot.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/evappot.F90	(revision 17)
@@ -0,0 +1,42 @@
+SUBROUTINE evappot(klon,nbsrf,ftsol,pplay,cdragh,  &
+       &    t_seri,q_seri,u_seri,v_seri,evap_pot)
+
+IMPLICIT NONE
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+
+INTEGER :: klon, nbsrf
+REAL, DIMENSION(klon,nbsrf) :: ftsol,evap_pot
+REAL, DIMENSION(klon) :: pplay,t_seri,wind,q_seri,u_seri,v_seri,cdragh
+
+INTEGER :: nsrf,i
+REAL, DIMENSION(klon,nbsrf) :: qsat_ftsol
+REAL, DIMENSION(klon) :: rhos, norme_u
+REAL :: t_coup
+
+      t_coup=234.   ! Quelle horreur !!!!!
+
+DO nsrf = 1, nbsrf
+   DO i = 1, klon
+      IF (ftsol(i,nsrf).LT.t_coup) THEN
+         qsat_ftsol(i,nsrf) = qsats(ftsol(i,nsrf))/pplay(i)
+      ELSE
+         qsat_ftsol(i,nsrf) = qsatl(ftsol(i,nsrf))/pplay(i)
+      ENDIF
+   ENDDO
+ENDDO
+! ========================================================== c
+! Calcul de l'evaporation Potentielle
+
+
+rhos(:) = pplay(:)/(RD*t_seri(:))
+norme_u(:)=1.+sqrt(u_seri(:)*u_seri(:)+v_seri(:)*v_seri(:))
+DO nsrf = 1, nbsrf
+  evap_pot(:,nsrf)=rhos(:)*cdragh(:)*norme_u(:)*(qsat_ftsol(:,nsrf)-q_seri(:))
+ENDDO
+RETURN
+
+END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/fisrtilp.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/fisrtilp.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/fisrtilp.F90	(revision 17)
@@ -0,0 +1,632 @@
+!
+! $Id: fisrtilp.F90 1796 2013-07-18 08:32:32Z emillour $
+!
+!
+SUBROUTINE fisrtilp(dtime,paprs,pplay,t,q,ptconv,ratqs, &
+     d_t, d_q, d_ql, rneb, radliq, rain, snow,          &
+     pfrac_impa, pfrac_nucl, pfrac_1nucl,               &
+     frac_impa, frac_nucl, beta,                        &
+     prfl, psfl, rhcl, zqta, fraca,                     &
+     ztv, zpspsk, ztla, zthl, iflag_cldcon)
+
+  !
+  USE dimphy
+  IMPLICIT none
+  !======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS)
+  ! Date: le 20 mars 1995
+  ! Objet: condensation et precipitation stratiforme.
+  !        schema de nuage
+  !======================================================================
+  !======================================================================
+  !ym include "dimensions.h"
+  !ym include "dimphy.h"
+  include "YOMCST.h"
+  include "tracstoke.h"
+  include "fisrtilp.h"
+  include "iniprint.h"
+
+  !
+  ! Arguments:
+  !
+  REAL dtime ! intervalle du temps (s)
+  REAL paprs(klon,klev+1) ! pression a inter-couche
+  REAL pplay(klon,klev) ! pression au milieu de couche
+  REAL t(klon,klev) ! temperature (K)
+  REAL q(klon,klev) ! humidite specifique (kg/kg)
+  REAL d_t(klon,klev) ! incrementation de la temperature (K)
+  REAL d_q(klon,klev) ! incrementation de la vapeur d'eau
+  REAL d_ql(klon,klev) ! incrementation de l'eau liquide
+  REAL rneb(klon,klev) ! fraction nuageuse
+  REAL radliq(klon,klev) ! eau liquide utilisee dans rayonnements
+  REAL rhcl(klon,klev) ! humidite relative en ciel clair
+  REAL rain(klon) ! pluies (mm/s)
+  REAL snow(klon) ! neige (mm/s)
+  REAL prfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s)
+  REAL psfl(klon,klev+1) ! flux d'eau precipitante aux interfaces (kg/m2/s) 
+  REAL ztv(klon,klev)
+  REAL zqta(klon,klev),fraca(klon,klev) 
+  REAL sigma1(klon,klev),sigma2(klon,klev)
+  REAL qltot(klon,klev),ctot(klon,klev)
+  REAL zpspsk(klon,klev),ztla(klon,klev)
+  REAL zthl(klon,klev)
+
+  logical lognormale(klon)
+
+  !AA
+  ! Coeffients de fraction lessivee : pour OFF-LINE
+  !
+  REAL pfrac_nucl(klon,klev)
+  REAL pfrac_1nucl(klon,klev)
+  REAL pfrac_impa(klon,klev)
+  !
+  ! Fraction d'aerosols lessivee par impaction et par nucleation
+  ! POur ON-LINE
+  !
+  REAL frac_impa(klon,klev)
+  REAL frac_nucl(klon,klev)
+  real zct      ,zcl
+  !AA
+  !
+  ! Options du programme:
+  !
+  REAL seuil_neb ! un nuage existe vraiment au-dela
+  PARAMETER (seuil_neb=0.001)
+
+  INTEGER ninter ! sous-intervals pour la precipitation
+  INTEGER ncoreczq  
+  INTEGER iflag_cldcon
+  PARAMETER (ninter=5)
+  LOGICAL evap_prec ! evaporation de la pluie
+  PARAMETER (evap_prec=.TRUE.)
+  REAL ratqs(klon,klev) ! determine la largeur de distribution de vapeur
+  logical ptconv(klon,klev) ! determine la largeur de distribution de vapeur
+
+  real zpdf_sig(klon),zpdf_k(klon),zpdf_delta(klon)
+  real Zpdf_a(klon),zpdf_b(klon),zpdf_e1(klon),zpdf_e2(klon)
+  real erf   
+  REAL qcloud(klon)
+  !
+  LOGICAL cpartiel ! condensation partielle
+  PARAMETER (cpartiel=.TRUE.)
+  REAL t_coup
+  PARAMETER (t_coup=234.0)
+  !
+  ! Variables locales:
+  !
+  INTEGER i, k, n, kk
+  REAL zqs(klon), zdqs(klon), zdelta, zcor, zcvm5   
+  REAL zrfl(klon), zrfln(klon), zqev, zqevt
+  REAL zoliq(klon), zcond(klon), zq(klon), zqn(klon), zdelq
+  REAL ztglace, zt(klon)
+  INTEGER nexpo ! exponentiel pour glace/eau
+  REAL zdz(klon),zrho(klon),ztot      , zrhol(klon)
+  REAL zchau      ,zfroi      ,zfice(klon),zneb(klon)
+  !
+  LOGICAL appel1er
+  SAVE appel1er
+  !$OMP THREADPRIVATE(appel1er)
+  !
+  !---------------------------------------------------------------
+  !
+  !AA Variables traceurs:
+  !AA  Provisoire !!! Parametres alpha du lessivage
+  !AA  A priori on a 4 scavenging # possibles
+  !
+  REAL a_tr_sca(4)
+  save a_tr_sca
+  !$OMP THREADPRIVATE(a_tr_sca)
+  !
+  ! Variables intermediaires
+  !
+  REAL zalpha_tr
+  REAL zfrac_lessi
+  REAL zprec_cond(klon)
+  !AA
+! RomP >>> 15 nov 2012
+  REAL   beta(klon,klev) ! taux de conversion de l'eau cond
+! RomP <<<
+  REAL zmair, zcpair, zcpeau
+  !     Pour la conversion eau-neige
+  REAL zlh_solid(klon), zm_solid
+  !IM 
+  !ym      INTEGER klevm1
+  !---------------------------------------------------------------
+  !
+  ! Fonctions en ligne:
+  !
+  REAL fallvs,fallvc ! vitesse de chute pour crystaux de glace
+  REAL zzz
+
+  include "YOETHF.h"
+  include "FCTTRE.h"
+  fallvc (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_con
+  fallvs (zzz) = 3.29/2.0 * ((zzz)**0.16) * ffallv_lsc
+  !
+  DATA appel1er /.TRUE./
+  !ym
+  zdelq=0.0
+
+  if (prt_level>9)write(lunout,*)'NUAGES4 A. JAM'
+  IF (appel1er) THEN
+     !
+     WRITE(lunout,*) 'fisrtilp, ninter:', ninter
+     WRITE(lunout,*) 'fisrtilp, evap_prec:', evap_prec
+     WRITE(lunout,*) 'fisrtilp, cpartiel:', cpartiel
+     IF (ABS(dtime/REAL(ninter)-360.0).GT.0.001) THEN
+        WRITE(lunout,*) 'fisrtilp: Ce n est pas prevu, voir Z.X.Li', dtime
+        WRITE(lunout,*) 'Je prefere un sous-intervalle de 6 minutes'
+        !         CALL abort
+     ENDIF
+     appel1er = .FALSE.
+     !
+     !AA initialiation provisoire
+     a_tr_sca(1) = -0.5
+     a_tr_sca(2) = -0.5
+     a_tr_sca(3) = -0.5
+     a_tr_sca(4) = -0.5
+     !
+     !AA Initialisation a 1 des coefs des fractions lessivees 
+     !
+     !cdir collapse
+     DO k = 1, klev
+        DO i = 1, klon
+           pfrac_nucl(i,k)=1.
+           pfrac_1nucl(i,k)=1.
+           pfrac_impa(i,k)=1.
+           beta(i,k)=0.  !RomP initialisation
+        ENDDO
+     ENDDO
+
+  ENDIF          !  test sur appel1er
+  !
+  !MAf Initialisation a 0 de zoliq
+  !      DO i = 1, klon
+  !         zoliq(i)=0.
+  !      ENDDO 
+  ! Determiner les nuages froids par leur temperature
+  !  nexpo regle la raideur de la transition eau liquide / eau glace.
+  !
+  ztglace = RTT - 15.0
+  nexpo = 6
+  !cc      nexpo = 1
+  !
+  ! Initialiser les sorties:
+  !
+  !cdir collapse
+  DO k = 1, klev+1
+     DO i = 1, klon
+        prfl(i,k) = 0.0
+        psfl(i,k) = 0.0
+     ENDDO
+  ENDDO
+
+  !cdir collapse
+  DO k = 1, klev
+     DO i = 1, klon
+        d_t(i,k) = 0.0
+        d_q(i,k) = 0.0
+        d_ql(i,k) = 0.0
+        rneb(i,k) = 0.0
+        radliq(i,k) = 0.0
+        frac_nucl(i,k) = 1. 
+        frac_impa(i,k) = 1. 
+     ENDDO
+  ENDDO
+  DO i = 1, klon
+     rain(i) = 0.0
+     snow(i) = 0.0
+     zoliq(i)=0.
+     !     ENDDO
+     !
+     ! Initialiser le flux de precipitation a zero
+     !
+     !     DO i = 1, klon
+     zrfl(i) = 0.0
+     zneb(i) = seuil_neb
+  ENDDO
+  !
+  !
+  !AA Pour plus de securite 
+
+  zalpha_tr   = 0.
+  zfrac_lessi = 0.
+
+  !AA----------------------------------------------------------
+  !
+  ncoreczq=0
+  ! Boucle verticale (du haut vers le bas)
+  !
+  !IM : klevm1
+  !ym      klevm1=klev-1
+  DO k = klev, 1, -1
+     !
+     !AA----------------------------------------------------------
+     !
+     DO i = 1, klon
+        zt(i)=t(i,k)
+        zq(i)=q(i,k)
+     ENDDO
+     !
+     ! Calculer la varition de temp. de l'air du a la chaleur sensible
+     ! transporter par la pluie.
+     ! Il resterait a rajouter cet effet de la chaleur sensible sur les
+     ! flux de surface, du a la diff. de temp. entre le 1er niveau et la
+     ! surface.
+     !
+     IF(k.LE.klevm1) THEN         
+        DO i = 1, klon
+           !IM
+           zmair=(paprs(i,k)-paprs(i,k+1))/RG
+           zcpair=RCPD*(1.0+RVTMP2*zq(i))
+           zcpeau=RCPD*RVTMP2
+           zt(i) = ( (t(i,k+1)+d_t(i,k+1))*zrfl(i)*dtime*zcpeau &
+                + zmair*zcpair*zt(i) ) &
+                / (zmair*zcpair + zrfl(i)*dtime*zcpeau)
+           !     C        WRITE (6,*) 'cppluie ', zt(i)-(t(i,k+1)+d_t(i,k+1))
+        ENDDO
+     ENDIF
+     !
+     !
+     ! Calculer l'evaporation de la precipitation
+     !
+
+
+     IF (evap_prec) THEN
+        DO i = 1, klon
+           IF (zrfl(i) .GT.0.) THEN
+              IF (thermcep) THEN
+                 zdelta=MAX(0.,SIGN(1.,RTT-zt(i)))
+                 zqs(i)= R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+                 zqs(i)=MIN(0.5,zqs(i))
+                 zcor=1./(1.-RETV*zqs(i))
+                 zqs(i)=zqs(i)*zcor
+              ELSE
+                 IF (zt(i) .LT. t_coup) THEN
+                    zqs(i) = qsats(zt(i)) / pplay(i,k)
+                 ELSE
+                    zqs(i) = qsatl(zt(i)) / pplay(i,k)
+                 ENDIF
+              ENDIF
+              zqev = MAX (0.0, (zqs(i)-zq(i))*zneb(i) )
+              zqevt = coef_eva * (1.0-zq(i)/zqs(i)) * SQRT(zrfl(i)) &
+                   * (paprs(i,k)-paprs(i,k+1))/pplay(i,k)*zt(i)*RD/RG
+              zqevt = MAX(0.0,MIN(zqevt,zrfl(i))) &
+                   * RG*dtime/(paprs(i,k)-paprs(i,k+1))
+              zqev = MIN (zqev, zqevt)
+              zrfln(i) = zrfl(i) - zqev*(paprs(i,k)-paprs(i,k+1)) &
+                   /RG/dtime
+
+
+              ! pour la glace, on ré-évapore toute la précip dans la
+              ! couche du dessous
+              ! la glace venant de la couche du dessus est simplement
+              ! dans la couche du dessous.
+
+              IF (zt(i) .LT. t_coup.and.reevap_ice) zrfln(i)=0.
+
+              zq(i) = zq(i) - (zrfln(i)-zrfl(i)) &
+                   * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime
+              zt(i) = zt(i) + (zrfln(i)-zrfl(i)) &
+                   * (RG/(paprs(i,k)-paprs(i,k+1)))*dtime &
+                   * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+              zrfl(i) = zrfln(i)
+           ENDIF
+        ENDDO
+     ENDIF
+     !
+     ! Calculer Qs et L/Cp*dQs/dT:
+     !
+     IF (thermcep) THEN
+        DO i = 1, klon
+           zdelta = MAX(0.,SIGN(1.,RTT-zt(i)))
+           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+           zcvm5 = zcvm5 /RCPD/(1.0+RVTMP2*zq(i))
+           zqs(i) = R2ES*FOEEW(zt(i),zdelta)/pplay(i,k)
+           zqs(i) = MIN(0.5,zqs(i))
+           zcor = 1./(1.-RETV*zqs(i))
+           zqs(i) = zqs(i)*zcor
+           zdqs(i) = FOEDE(zt(i),zdelta,zcvm5,zqs(i),zcor)
+        ENDDO
+
+     ELSE
+        DO i = 1, klon
+           IF (zt(i).LT.t_coup) THEN
+              zqs(i) = qsats(zt(i))/pplay(i,k)
+              zdqs(i) = dqsats(zt(i),zqs(i))
+           ELSE
+              zqs(i) = qsatl(zt(i))/pplay(i,k)
+              zdqs(i) = dqsatl(zt(i),zqs(i))
+           ENDIF
+        ENDDO
+     ENDIF
+     !
+     ! Determiner la condensation partielle et calculer la quantite
+     ! de l'eau condensee:
+     !
+
+     IF (cpartiel) THEN
+
+        !        print*,'Dans partiel k=',k
+        !
+        !   Calcul de l'eau condensee et de la fraction nuageuse et de l'eau
+        !   nuageuse a partir des PDF de Sandrine Bony.
+        !   rneb  : fraction nuageuse
+        !   zqn   : eau totale dans le nuage
+        !   zcond : eau condensee moyenne dans la maille.
+        !  on prend en compte le réchauffement qui diminue la partie
+        ! condensee
+        !
+        !   Version avec les raqts
+
+        if (iflag_pdf.eq.0) then
+
+           do i=1,klon
+              zdelq = min(ratqs(i,k),0.99) * zq(i)
+              rneb(i,k) = (zq(i)+zdelq-zqs(i)) / (2.0*zdelq)
+              zqn(i) = (zq(i)+zdelq+zqs(i))/2.0
+           enddo
+
+        else
+           !
+           !   Version avec les nouvelles PDFs.
+           do i=1,klon
+              if(zq(i).lt.1.e-15) then
+                 ncoreczq=ncoreczq+1
+                 zq(i)=1.e-15
+              endif
+           enddo
+
+           if (iflag_cldcon>=5) then
+
+              call cloudth(klon,klev,k,ztv, &
+                   zq,zqta,fraca, &
+                   qcloud,ctot,zpspsk,paprs,ztla,zthl, &
+                   ratqs,zqs,t)
+
+              do i=1,klon
+                 rneb(i,k)=ctot(i,k)
+                 zqn(i)=qcloud(i)
+              enddo
+
+           endif
+
+           if (iflag_cldcon <= 4) then
+              lognormale = .true.
+           elseif (iflag_cldcon >= 6) then
+              ! lognormale en l'absence des thermiques
+              lognormale = fraca(:,k) < 1e-10
+           else
+              ! Dans le cas iflag_cldcon=5, on prend systématiquement la
+              ! bi-gaussienne
+              lognormale = .false.
+           end if
+
+           do i=1,klon
+              if (lognormale(i)) then
+                 zpdf_sig(i)=ratqs(i,k)*zq(i)
+                 zpdf_k(i)=-sqrt(log(1.+(zpdf_sig(i)/zq(i))**2))
+                 zpdf_delta(i)=log(zq(i)/zqs(i))
+                 zpdf_a(i)=zpdf_delta(i)/(zpdf_k(i)*sqrt(2.))
+                 zpdf_b(i)=zpdf_k(i)/(2.*sqrt(2.))
+                 zpdf_e1(i)=zpdf_a(i)-zpdf_b(i)
+                 zpdf_e1(i)=sign(min(abs(zpdf_e1(i)),5.),zpdf_e1(i))
+                 zpdf_e1(i)=1.-erf(zpdf_e1(i))
+                 zpdf_e2(i)=zpdf_a(i)+zpdf_b(i)
+                 zpdf_e2(i)=sign(min(abs(zpdf_e2(i)),5.),zpdf_e2(i))
+                 zpdf_e2(i)=1.-erf(zpdf_e2(i))
+              endif
+           enddo
+
+           do i=1,klon
+              if (lognormale(i)) then
+                 if (zpdf_e1(i).lt.1.e-10) then
+                    rneb(i,k)=0.
+                    zqn(i)=zqs(i)
+                 else
+                    rneb(i,k)=0.5*zpdf_e1(i)
+                    zqn(i)=zq(i)*zpdf_e2(i)/zpdf_e1(i)
+                 endif
+              endif
+
+           enddo
+
+        endif ! iflag_pdf
+
+        DO i=1,klon
+           IF (rneb(i,k) .LE. 0.0) THEN
+              zqn(i) = 0.0
+              rneb(i,k) = 0.0
+              zcond(i) = 0.0
+              rhcl(i,k)=zq(i)/zqs(i)
+           ELSE IF (rneb(i,k) .GE. 1.0) THEN
+              zqn(i) = zq(i)
+              rneb(i,k) = 1.0                  
+              zcond(i) = MAX(0.0,zqn(i)-zqs(i))/(1+zdqs(i))
+              rhcl(i,k)=1.0
+           ELSE
+              zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1+zdqs(i))
+              rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i)
+           ENDIF
+        ENDDO
+        !         do i=1,klon
+        !            IF (rneb(i,k) .LE. 0.0) zqn(i) = 0.0
+        !            IF (rneb(i,k) .GE. 1.0) zqn(i) = zq(i)
+        !            rneb(i,k) = MAX(0.0,MIN(1.0,rneb(i,k)))
+        !c           zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)/(1.+zdqs(i))
+        !c  On ne divise pas par 1+zdqs pour forcer a avoir l'eau predite par
+        !c  la convection.
+        !c  ATTENTION !!! Il va falloir verifier tout ca.
+        !            zcond(i) = MAX(0.0,zqn(i)-zqs(i))*rneb(i,k)
+        !c           print*,'ZDQS ',zdqs(i)
+        !c--Olivier
+        !            rhcl(i,k)=(zqs(i)+zq(i)-zdelq)/2./zqs(i)
+        !            IF (rneb(i,k) .LE. 0.0) rhcl(i,k)=zq(i)/zqs(i)
+        !            IF (rneb(i,k) .GE. 1.0) rhcl(i,k)=1.0
+        !c--fin
+        !           ENDDO
+     ELSE
+        DO i = 1, klon
+           IF (zq(i).GT.zqs(i)) THEN
+              rneb(i,k) = 1.0
+           ELSE
+              rneb(i,k) = 0.0
+           ENDIF
+           zcond(i) = MAX(0.0,zq(i)-zqs(i))/(1.+zdqs(i))
+        ENDDO
+     ENDIF
+     !
+     DO i = 1, klon
+        zq(i) = zq(i) - zcond(i)
+        !         zt(i) = zt(i) + zcond(i) * RLVTT/RCPD
+        zt(i) = zt(i) + zcond(i) * RLVTT/RCPD/(1.0+RVTMP2*zq(i))
+     ENDDO
+     !
+     ! Partager l'eau condensee en precipitation et eau liquide nuageuse
+     !
+     DO i = 1, klon
+        IF (rneb(i,k).GT.0.0) THEN
+           zoliq(i) = zcond(i)
+           zrho(i) = pplay(i,k) / zt(i) / RD
+           zdz(i) = (paprs(i,k)-paprs(i,k+1)) / (zrho(i)*RG)
+           zfice(i) = 1.0 - (zt(i)-ztglace) / (273.13-ztglace)
+           zfice(i) = MIN(MAX(zfice(i),0.0),1.0)
+           zfice(i) = zfice(i)**nexpo
+           zneb(i) = MAX(rneb(i,k), seuil_neb)
+           radliq(i,k) = zoliq(i)/REAL(ninter+1)
+        ENDIF
+     ENDDO
+     !
+     DO n = 1, ninter
+        DO i = 1, klon
+           IF (rneb(i,k).GT.0.0) THEN
+              zrhol(i) = zrho(i) * zoliq(i) / zneb(i)
+
+              IF (zneb(i).EQ.seuil_neb) THEN
+                 ztot = 0.0
+              ELSE
+                 !  quantite d'eau a eliminer: zchau
+                 !  meme chose pour la glace: zfroi
+                 if (ptconv(i,k)) then
+                    zcl   =cld_lc_con
+                    zct   =1./cld_tau_con
+                    zfroi    = dtime/REAL(ninter)/zdz(i)*zoliq(i) &
+                         *fallvc(zrhol(i)) * zfice(i)
+                 else
+                    zcl   =cld_lc_lsc
+                    zct   =1./cld_tau_lsc
+                    zfroi    = dtime/REAL(ninter)/zdz(i)*zoliq(i) &
+                         *fallvs(zrhol(i)) * zfice(i)
+                 endif
+                 zchau    = zct   *dtime/REAL(ninter) * zoliq(i) &
+                      *(1.0-EXP(-(zoliq(i)/zneb(i)/zcl   )**2)) *(1.-zfice(i))
+                 ztot    = zchau    + zfroi
+                 ztot    = MAX(ztot   ,0.0)
+              ENDIF
+              ztot    = MIN(ztot,zoliq(i))
+              zoliq(i) = MAX(zoliq(i)-ztot   , 0.0)
+              radliq(i,k) = radliq(i,k) + zoliq(i)/REAL(ninter+1)
+           ENDIF
+        ENDDO
+     ENDDO
+     !
+     DO i = 1, klon
+        IF (rneb(i,k).GT.0.0) THEN
+           d_ql(i,k) = zoliq(i)
+           zrfl(i) = zrfl(i)+ MAX(zcond(i)-zoliq(i),0.0) &
+                * (paprs(i,k)-paprs(i,k+1))/(RG*dtime)
+        ENDIF
+        IF (zt(i).LT.RTT) THEN
+           psfl(i,k)=zrfl(i)
+        ELSE
+           prfl(i,k)=zrfl(i)
+        ENDIF
+     ENDDO
+     !
+     ! Calculer les tendances de q et de t:
+     !
+     DO i = 1, klon
+        d_q(i,k) = zq(i) - q(i,k)
+        d_t(i,k) = zt(i) - t(i,k)
+     ENDDO
+     !
+     !AA--------------- Calcul du lessivage stratiforme  -------------
+
+     DO i = 1,klon
+        !
+        if(zcond(i).gt.zoliq(i)+1.e-10) then
+         beta(i,k) = (zcond(i)-zoliq(i))/zcond(i)/dtime
+        else
+         beta(i,k) = 0.
+        endif
+        zprec_cond(i) = MAX(zcond(i)-zoliq(i),0.0) &
+             * (paprs(i,k)-paprs(i,k+1))/RG
+        IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+           !AA lessivage nucleation LMD5 dans la couche elle-meme
+           if (t(i,k) .GE. ztglace) THEN
+              zalpha_tr = a_tr_sca(3)
+           else
+              zalpha_tr = a_tr_sca(4)
+           endif
+           zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+           pfrac_nucl(i,k)=pfrac_nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+           frac_nucl(i,k)= 1.-zneb(i)*zfrac_lessi 
+           !
+           ! nucleation avec un facteur -1 au lieu de -0.5
+           zfrac_lessi = 1. - EXP(-zprec_cond(i)/zneb(i))
+           pfrac_1nucl(i,k)=pfrac_1nucl(i,k)*(1.-zneb(i)*zfrac_lessi)
+        ENDIF
+        !
+     ENDDO      ! boucle sur i
+     !
+     !AA Lessivage par impaction dans les couches en-dessous
+     DO kk = k-1, 1, -1
+        DO i = 1, klon
+           IF (rneb(i,k).GT.0.0.and.zprec_cond(i).gt.0.) THEN
+              if (t(i,kk) .GE. ztglace) THEN
+                 zalpha_tr = a_tr_sca(1)
+              else
+                 zalpha_tr = a_tr_sca(2)
+              endif
+              zfrac_lessi = 1. - EXP(zalpha_tr*zprec_cond(i)/zneb(i))
+              pfrac_impa(i,kk)=pfrac_impa(i,kk)*(1.-zneb(i)*zfrac_lessi)
+              frac_impa(i,kk)= 1.-zneb(i)*zfrac_lessi
+           ENDIF
+        ENDDO
+     ENDDO
+     !
+     !AA----------------------------------------------------------
+     !                     FIN DE BOUCLE SUR K   
+  end DO
+  !
+  !AA-----------------------------------------------------------
+  !
+  ! Pluie ou neige au sol selon la temperature de la 1ere couche
+  !
+  DO i = 1, klon
+     IF ((t(i,1)+d_t(i,1)) .LT. RTT) THEN
+        snow(i) = zrfl(i)
+        zlh_solid(i) = RLSTT-RLVTT
+     ELSE
+        rain(i) = zrfl(i)
+        zlh_solid(i) = 0.
+     ENDIF
+  ENDDO
+  !
+  ! For energy conservation : when snow is present, the solification
+  ! latent heat is considered.
+  DO k = 1, klev
+     DO i = 1, klon
+        zcpair=RCPD*(1.0+RVTMP2*(q(i,k)+d_q(i,k)))
+        zmair=(paprs(i,k)-paprs(i,k+1))/RG
+        zm_solid = (prfl(i,k)-prfl(i,k+1)+psfl(i,k)-psfl(i,k+1))*dtime
+        d_t(i,k) = d_t(i,k) + zlh_solid(i) *zm_solid / (zcpair*zmair)
+     END DO
+  END DO
+  !
+
+  if (ncoreczq>0) then
+     WRITE(lunout,*)'WARNING : ZQ dans fisrtilp ',ncoreczq,' val < 1.e-15.'
+  endif
+
+END SUBROUTINE fisrtilp
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/fisrtilp.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/fisrtilp.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/fisrtilp.h	(revision 17)
@@ -0,0 +1,28 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+      REAL cld_lc_lsc,cld_lc_con
+      REAL cld_tau_lsc,cld_tau_con
+      REAL ffallv_lsc,ffallv_con
+      REAL coef_eva
+      LOGICAL reevap_ice
+      INTEGER iflag_pdf
+
+      common/comfisrtilp/                                               &
+     &     cld_lc_lsc                                                   &
+     &     ,cld_lc_con                                                  &
+     &     ,cld_tau_lsc                                                 &
+     &     ,cld_tau_con                                                 &
+     &     ,ffallv_lsc                                                  &
+     &     ,ffallv_con                                                  &
+     &     ,coef_eva                                                    &
+     &     ,reevap_ice                                                  &
+     &     ,iflag_pdf        
+
+!$OMP THREADPRIVATE(/comfisrtilp/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/fonte_neige_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/fonte_neige_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/fonte_neige_mod.F90	(revision 17)
@@ -0,0 +1,361 @@
+! $Header$
+!
+MODULE fonte_neige_mod
+!
+! This module will treat the process of snow, melting, accumulating, calving, in 
+! case of simplified soil model.
+!
+!****************************************************************************************
+  USE dimphy, ONLY : klon
+  USE indice_sol_mod
+
+  IMPLICIT NONE
+  SAVE
+
+! run_off_ter and run_off_lic are the runoff at the compressed grid knon for 
+! land and land-ice respectively
+! Note: run_off_lic is used in mod_landice and therfore not private
+!L. Fita, LMD. November 2013
+! Removing all the PRIVATE, I removed startphy.nc and limit.nc
+!  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE    :: run_off_ter
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE             :: run_off_ter
+  !$OMP THREADPRIVATE(run_off_ter)
+  REAL, ALLOCATABLE, DIMENSION(:), SAVE             :: run_off_lic
+  !$OMP THREADPRIVATE(run_off_lic)
+
+! run_off_lic_0 is the runoff at land-ice a time-step earlier, on the global 1D array grid
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE    :: run_off_lic_0
+!  REAL, ALLOCATABLE, DIMENSION(:),SAVE    :: run_off_lic_0
+  !$OMP THREADPRIVATE(run_off_lic_0)
+  
+  REAL, PRIVATE                               :: tau_calv  
+  !$OMP THREADPRIVATE(tau_calv)
+!  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: ffonte_global
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE                :: ffonte_global
+  !$OMP THREADPRIVATE(ffonte_global)
+!  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: fqfonte_global
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE                :: fqfonte_global
+  !$OMP THREADPRIVATE(fqfonte_global)
+!  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE  :: fqcalving_global
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE                :: fqcalving_global
+  !$OMP THREADPRIVATE(fqcalving_global)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_init(restart_runoff)
+
+! This subroutine allocates and initialize variables in the module. 
+! The variable run_off_lic_0 is initialized to the field read from
+! restart file. The other variables are initialized to zero.
+!
+!****************************************************************************************
+! Input argument
+    REAL, DIMENSION(klon), INTENT(IN) :: restart_runoff 
+
+! Local variables
+    INTEGER                           :: error
+    CHARACTER (len = 80)              :: abort_message 
+    CHARACTER (len = 20)              :: modname = 'fonte_neige_init'
+
+
+!****************************************************************************************
+! Allocate run-off at landice and initilize with field read from restart
+!
+!****************************************************************************************
+
+    ALLOCATE(run_off_lic_0(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_lic'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_lic_0(:) = restart_runoff(:) 
+
+!****************************************************************************************
+! Allocate other variables and initilize to zero
+!
+!****************************************************************************************
+    ALLOCATE(run_off_ter(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_ter'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_ter(:) = 0.
+    
+    ALLOCATE(run_off_lic(klon), stat = error)
+    IF (error /= 0) THEN
+       abort_message='Pb allocation run_off_lic'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    run_off_lic(:) = 0.
+    
+    ALLOCATE(ffonte_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation ffonte_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    ffonte_global(:,:) = 0.0
+
+    ALLOCATE(fqfonte_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation fqfonte_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    fqfonte_global(:,:) = 0.0
+
+    ALLOCATE(fqcalving_global(klon,nbsrf))
+    IF (error /= 0) THEN
+       abort_message='Pb allocation fqcalving_global'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+    fqcalving_global(:,:) = 0.0
+
+!****************************************************************************************
+! Read tau_calv
+!
+!****************************************************************************************
+    CALL conf_interface(tau_calv)
+
+
+  END SUBROUTINE fonte_neige_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige( knon, nisurf, knindex, dtime, &
+       tsurf, precip_rain, precip_snow, &
+       snow, qsol, tsurf_new, evap)
+
+  USE indice_sol_mod
+        
+! Routine de traitement de la fonte de la neige dans le cas du traitement
+! de sol simplifie!
+! LF 03/2001
+! input:
+!   knon         nombre de points a traiter
+!   nisurf       surface a traiter
+!   knindex      index des mailles valables pour surface a traiter
+!   dtime        
+!   tsurf        temperature de surface
+!   precip_rain  precipitations liquides
+!   precip_snow  precipitations solides
+!
+! input/output:
+!   snow         champs hauteur de neige
+!   qsol         hauteur d'eau contenu dans le sol
+!   tsurf_new    temperature au sol
+!   evap
+!
+  INCLUDE "dimensions.h"
+  INCLUDE "YOETHF.h"
+  INCLUDE "YOMCST.h"
+  INCLUDE "FCTTRE.h"
+  INCLUDE "clesphys.h"
+
+! Input variables
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: knon
+    INTEGER, INTENT(IN)                  :: nisurf
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL   , INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_snow
+    
+! Input/Output variables
+!****************************************************************************************
+
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT) :: qsol
+    REAL, DIMENSION(klon), INTENT(INOUT) :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(INOUT) :: evap
+
+! Local variables
+!****************************************************************************************
+
+    INTEGER               :: i, j
+    REAL                  :: fq_fonte
+    REAL                  :: coeff_rel
+    REAL, PARAMETER       :: snow_max=3000.
+    REAL, PARAMETER       :: max_eau_sol = 150.0
+!! PB temporaire en attendant mieux pour le modele de neige
+! REAL, parameter :: chasno = RLMLT/(2.3867E+06*0.15)
+    REAL, PARAMETER       :: chasno = 3.334E+05/(2.3867E+06*0.15)
+!IM cf JLD/ GKtest
+    REAL, PARAMETER       :: chaice = 3.334E+05/(2.3867E+06*0.15)
+! fin GKtest
+    REAL, DIMENSION(klon) :: ffonte
+    REAL, DIMENSION(klon) :: fqcalving, fqfonte
+    REAL, DIMENSION(klon) :: d_ts
+    REAL, DIMENSION(klon) :: bil_eau_s, snow_evap
+
+    LOGICAL               :: neige_fond
+
+!****************************************************************************************
+! Start calculation
+! - Initialization
+!
+!****************************************************************************************
+    coeff_rel = dtime/(tau_calv * rday)
+    
+    bil_eau_s(:) = 0.
+
+!****************************************************************************************
+! - Increment snow due to precipitation and evaporation
+! - Calculate the water balance due to precipitation and evaporation (bil_eau_s)
+!
+!****************************************************************************************
+    WHERE (precip_snow > 0.) 
+       snow = snow + (precip_snow * dtime)
+    END WHERE
+
+    snow_evap = 0.
+    WHERE (evap > 0. ) 
+       snow_evap = MIN (snow / dtime, evap) 
+       snow = snow - snow_evap * dtime
+       snow = MAX(0.0, snow)
+    END WHERE
+    
+    bil_eau_s(:) = (precip_rain(:) * dtime) - (evap(:) - snow_evap(:)) * dtime
+
+
+!****************************************************************************************
+! - Calculate melting snow
+! - Calculate calving and decrement snow, if there are to much snow
+! - Update temperature at surface
+!
+!****************************************************************************************
+
+    ffonte(:) = 0.0
+    fqcalving(:) = 0.0
+    fqfonte(:) = 0.0
+    DO i = 1, knon
+       ! Y'a-t-il fonte de neige?
+       neige_fond = ((snow(i) > epsfra .OR. nisurf == is_sic .OR. nisurf == is_lic) &
+            .AND. tsurf_new(i) >= RTT)
+       IF (neige_fond) THEN
+          fq_fonte     = MIN( MAX((tsurf_new(i)-RTT )/chasno,0.0),snow(i))
+          ffonte(i)    = fq_fonte * RLMLT/dtime
+          fqfonte(i)   = fq_fonte/dtime
+          snow(i)      = MAX(0., snow(i) - fq_fonte)
+          bil_eau_s(i) = bil_eau_s(i) + fq_fonte 
+          tsurf_new(i) = tsurf_new(i) - fq_fonte * chasno  
+
+!IM cf JLD OK     
+!IM cf JLD/ GKtest fonte aussi pour la glace
+          IF (nisurf == is_sic .OR. nisurf == is_lic ) THEN
+             fq_fonte = MAX((tsurf_new(i)-RTT )/chaice,0.0)
+             ffonte(i) = ffonte(i) + fq_fonte * RLMLT/dtime
+             IF ( ok_lic_melt ) THEN
+                fqfonte(i) = fqfonte(i) + fq_fonte/dtime
+                bil_eau_s(i) = bil_eau_s(i) + fq_fonte
+             ENDIF
+             tsurf_new(i) = RTT
+          ENDIF
+          d_ts(i) = tsurf_new(i) - tsurf(i)
+       ENDIF
+
+       ! s'il y a une hauteur trop importante de neige, elle s'coule
+       fqcalving(i) = MAX(0., snow(i) - snow_max)/dtime
+       snow(i)=MIN(snow(i),snow_max)
+    END DO
+
+    IF (nisurf == is_ter) THEN
+       DO i = 1, knon
+          qsol(i) = qsol(i) + bil_eau_s(i)
+! L. Fita, LMD. March 2014
+!   'run_off_ter' is not used anymore. Not need to worry about!
+!          run_off_ter(i) = run_off_ter(i) + MAX(qsol(i) - max_eau_sol, 0.0)
+          qsol(i) = MIN(qsol(i), max_eau_sol) 
+       END DO
+    ELSE IF (nisurf == is_lic) THEN
+       DO i = 1, knon
+          j = knindex(i)
+          run_off_lic(i)   = (coeff_rel *  fqcalving(i)) + &
+               (1. - coeff_rel) * run_off_lic_0(j)
+          run_off_lic_0(j) = run_off_lic(i)
+          run_off_lic(i)   = run_off_lic(i) + fqfonte(i) + precip_rain(i)
+       END DO
+    ENDIF
+    
+!****************************************************************************************
+! Save ffonte, fqfonte and fqcalving in global arrays for each 
+! sub-surface separately
+!
+!****************************************************************************************
+    DO i = 1, knon
+       ffonte_global(knindex(i),nisurf)    = ffonte(i)
+       fqfonte_global(knindex(i),nisurf)   = fqfonte(i)
+       fqcalving_global(knindex(i),nisurf) = fqcalving(i)
+    ENDDO
+
+  END SUBROUTINE fonte_neige
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_final(restart_runoff)
+!
+! This subroutine returns run_off_lic_0 for later writing to restart file.
+!
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT) :: restart_runoff
+
+!****************************************************************************************
+! Set the output variables
+    restart_runoff(:) = run_off_lic_0(:)
+
+! Deallocation of all varaibles in the module
+!   DEALLOCATE(run_off_lic_0, run_off_ter, run_off_lic, ffonte_global, &
+!        fqfonte_global, fqcalving_global)
+
+    IF (ALLOCATED(run_off_lic_0)) DEALLOCATE(run_off_lic_0)
+    IF (ALLOCATED(run_off_ter)) DEALLOCATE(run_off_ter)
+    IF (ALLOCATED(run_off_lic)) DEALLOCATE(run_off_lic)
+    IF (ALLOCATED(ffonte_global)) DEALLOCATE(ffonte_global)
+    IF (ALLOCATED(fqfonte_global)) DEALLOCATE(fqfonte_global)
+    IF (ALLOCATED(fqcalving_global)) DEALLOCATE(fqcalving_global)
+
+  END SUBROUTINE fonte_neige_final
+!
+!****************************************************************************************
+!
+  SUBROUTINE fonte_neige_get_vars(pctsrf, fqcalving_out, &
+       fqfonte_out, ffonte_out)
+
+
+
+! Cumulate ffonte, fqfonte and fqcalving respectively for
+! all type of surfaces according to their fraction.
+!
+! This routine is called from physiq.F before histwrite.
+!****************************************************************************************
+
+  USE indice_sol_mod
+
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+
+    REAL, DIMENSION(klon), INTENT(OUT)      :: fqcalving_out
+    REAL, DIMENSION(klon), INTENT(OUT)      :: fqfonte_out
+    REAL, DIMENSION(klon), INTENT(OUT)      :: ffonte_out
+
+    INTEGER   :: nisurf
+!****************************************************************************************
+
+    ffonte_out(:)    = 0.0
+    fqfonte_out(:)   = 0.0
+    fqcalving_out(:) = 0.0
+
+    DO nisurf = 1, nbsrf
+       ffonte_out(:) = ffonte_out(:) + ffonte_global(:,nisurf)*pctsrf(:,nisurf)
+       fqfonte_out(:) = fqfonte_out(:) + fqfonte_global(:,nisurf)*pctsrf(:,nisurf)
+       fqcalving_out(:) = fqcalving_out(:) + fqcalving_global(:,nisurf)*pctsrf(:,nisurf)
+    ENDDO
+
+  END SUBROUTINE fonte_neige_get_vars
+!
+!****************************************************************************************
+!
+END MODULE fonte_neige_mod
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/formcoord.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/formcoord.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/formcoord.F	(revision 17)
@@ -0,0 +1,54 @@
+!
+! $Header$
+!
+      subroutine formcoord(unit,n,x,a,rev,text)
+      implicit none
+      integer n,unit,ndec
+      logical rev
+      real x(n),a
+      character*4 text
+
+      integer i,id,i1,i2,in
+      real dx,dxmin
+
+      if(rev) then
+         id=-1
+         i1=n
+         i2=n-1
+         in=1
+         write(unit,3000) text(1:1)
+      else
+         id=1
+         i1=1
+         i2=2
+         in=n
+      endif
+
+      if (n.lt.2) then
+         ndec=1
+         write(unit,1000) text,n,x(1)*a
+      else
+         dxmin=abs(x(2)-x(1))
+         do i=2,n-1
+            dx=abs(x(i+1)-x(i))
+            if (dx.lt.dxmin) dxmin=dx
+         enddo
+
+         ndec=-log10(dxmin)+2
+         if(mod(n,6).eq.1) then
+            write(unit,1000) text,n,x(i1)*a
+            write(unit,2000) (x(i)*a,i=i2,in,id)
+         else
+            write(unit,1000) text,n
+            write(unit,2000) (x(i)*a,i=i1,in,id)
+         endif
+      endif
+
+1000  format(a4,2x,i4,' LEVELS',43x,f12.2)
+2000  format(6f12.2)
+c1000  format(a4,2x,i4,' LEVELS',43x,f12.<ndec>)
+c2000  format(6f12.<ndec>)
+3000  format('FORMAT ',a1,'REV')
+      return
+
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/formcoord.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/formcoord.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/formcoord.F90	(revision 17)
@@ -0,0 +1,54 @@
+!
+! $Header$
+!
+      subroutine formcoord(unit,n,x,a,rev,text)
+      implicit none
+      integer n,unit,ndec
+      logical rev
+      real x(n),a
+      character*4 text
+
+      integer i,id,i1,i2,in
+      real dx,dxmin
+
+      if(rev) then
+         id=-1
+         i1=n
+         i2=n-1
+         in=1
+         write(unit,3000) text(1:1)
+      else
+         id=1
+         i1=1
+         i2=2
+         in=n
+      endif
+
+      if (n.lt.2) then
+         ndec=1
+         write(unit,1000) text,n,x(1)*a
+      else
+         dxmin=abs(x(2)-x(1))
+         do i=2,n-1
+            dx=abs(x(i+1)-x(i))
+            if (dx.lt.dxmin) dxmin=dx
+         enddo
+
+         ndec=-log10(dxmin)+2
+         if(mod(n,6).eq.1) then
+            write(unit,1000) text,n,x(i1)*a
+            write(unit,2000) (x(i)*a,i=i2,in,id)
+         else
+            write(unit,1000) text,n
+            write(unit,2000) (x(i)*a,i=i1,in,id)
+         endif
+      endif
+
+1000  format(a4,2x,i4,' LEVELS',43x,f12.2)
+2000  format(6f12.2)
+!c1000  format(a4,2x,i4,' LEVELS',43x,f12.<ndec>)
+!c2000  format(6f12.<ndec>)
+3000  format('FORMAT ',a1,'REV')
+      return
+
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/geo2atm.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/geo2atm.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/geo2atm.F90	(revision 17)
@@ -0,0 +1,53 @@
+!
+! $Header: /home/cvsroot/LMDZ4/libf/phylmd/geo2atm.F90,v 1.1 2008-12-05 17:56:40 lsce Exp $
+!
+SUBROUTINE geo2atm(im, jm, px, py, pz, plon, plat, pu, pv, pr)
+  USE dimphy
+  USE mod_phys_lmdz_para
+
+  IMPLICIT NONE
+  INCLUDE 'dimensions.h'
+  INCLUDE 'YOMCST.h'
+
+! Change wind coordinates from cartesian geocentric to local spherical
+! NB! Fonctionne probablement uniquement en MPI seul (sans OpenMP)
+!
+  INTEGER, INTENT (IN)                 :: im, jm
+  REAL, DIMENSION (im,jm), INTENT(IN)  :: px, py, pz
+  REAL, DIMENSION (im,jm), INTENT(IN)  :: plon, plat
+  REAL, DIMENSION (im,jm), INTENT(OUT) :: pu, pv, pr
+
+  REAL :: rad
+
+
+  rad = rpi / 180.0E0
+  
+  pu(:,:) = &
+       - px(:,:) * SIN(rad * plon(:,:)) &
+       + py(:,:) * COS(rad * plon(:,:))
+
+  pv(:,:) = &
+       - px(:,:) * SIN(rad * plat(:,:)) * COS(rad * plon(:,:)) &
+       - py(:,:) * SIN(rad * plat(:,:)) * SIN(rad * plon(:,:)) &
+       + pz(:,:) * COS(rad * plat(:,:))  
+
+  pr(:,:) = &
+       + px(:,:) * COS(rad * plat(:,:)) * COS(rad * plon(:,:)) &
+       + py(:,:) * COS(rad * plat(:,:)) * SIN(rad * plon(:,:)) &
+       + pz(:,:) * SIN(rad * plat(:,:))
+
+  ! Value at North Pole
+  IF (is_north_pole) THEN
+     pu(:, 1) = -px (1,1)
+     pv(:, 1) = -py (1,1)
+     pr(:, 1) = 0.0
+  ENDIF
+  
+  ! Value at South Pole     
+  IF (is_south_pole) THEN
+     pu(:,jm) = -px (1,jm)
+     pv(:,jm) = -py (1,jm)
+     pr(:,jm) = 0.0
+  ENDIF
+  
+END SUBROUTINE geo2atm
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/global_mean.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/global_mean.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/global_mean.F90	(revision 17)
@@ -0,0 +1,63 @@
+  subroutine global_mean(field,airephy,laire,mfield)
+!
+! I.Musat: 05.2011
+! calcul moyenne globale d'un champ pondere par l'aire de la maille
+! (laire=.TRUE.) ou somme globale du champ (laire=.FALSE.)
+!
+  USE dimphy
+  USE mod_phys_lmdz_para, only: is_sequential
+  USE mod_phys_lmdz_transfert_para, only: reduce_sum
+  use mod_phys_lmdz_mpi_data, only: is_mpi_root
+  USE ioipsl
+  implicit none
+
+  real,dimension(klon),intent(in) :: field
+  real,dimension(klon),intent(in) :: airephy
+  LOGICAL, intent(in) :: laire
+  REAL, intent(out) :: mfield
+  REAL :: airetot     ! Total area the earth
+  REAL :: sumtmp
+  INTEGER :: i
+
+  if (is_sequential) then
+
+   airetot = 0.
+   sumtmp = 0.
+   DO i=1, klon
+    airetot = airetot + airephy(i)
+    sumtmp = sumtmp + field(i)
+   END DO
+   if (laire) THEN
+    if(airetot.NE.0.) THEN
+     mfield=sumtmp/airetot
+    endif
+   else
+    mfield=sumtmp
+   endif
+
+  else
+
+   CALL reduce_sum(SUM(airephy),airetot)
+   CALL reduce_sum(SUM(field),sumtmp)
+
+!$OMP MASTER
+  if (is_mpi_root) THEN
+  if (laire) THEN
+!  print*,'gmean airetot=',airetot
+   if(airetot.NE.0.) THEN
+    mfield=sumtmp/airetot
+!  else
+!   mfield=sumtmp
+   endif
+  else
+   mfield=sumtmp
+  endif
+
+! print*,'gmean sumtmp mfield=',sumtmp,mfield
+
+  endif !(is_mpi_root) THEN
+!$OMP END MASTER
+
+  endif
+
+  end subroutine global_mean
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/gr_fi_dyn.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/gr_fi_dyn.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/gr_fi_dyn.F	(revision 17)
@@ -0,0 +1,40 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn)
+      IMPLICIT NONE
+c=======================================================================
+c   passage d'un champ de la grille scalaire a la grille physique
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+      INTEGER im,jm,ngrid,nfield
+      REAL pdyn(im,jm,nfield)
+      REAL pfi(ngrid,nfield)
+
+      INTEGER i,j,ifield,ig
+
+c-----------------------------------------------------------------------
+c   calcul:
+c   -------
+
+      DO ifield=1,nfield
+c   traitement des poles
+         DO i=1,im
+            pdyn(i,1,ifield)=pfi(1,ifield)
+            pdyn(i,jm,ifield)=pfi(ngrid,ifield)
+         ENDDO
+
+c   traitement des point normaux
+         DO j=2,jm-1
+	    ig=2+(j-2)*(im-1)
+            CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1)
+	    pdyn(im,j,ifield)=pdyn(1,j,ifield)
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/gr_fi_dyn.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/gr_fi_dyn.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/gr_fi_dyn.F90	(revision 17)
@@ -0,0 +1,40 @@
+!
+! $Header$
+!
+      SUBROUTINE gr_fi_dyn(nfield,ngrid,im,jm,pfi,pdyn)
+      IMPLICIT NONE
+!c=======================================================================
+!c   passage d'un champ de la grille scalaire a la grille physique
+!c=======================================================================
+
+!c-----------------------------------------------------------------------
+!c   declarations:
+!c   -------------
+
+      INTEGER im,jm,ngrid,nfield
+      REAL pdyn(im,jm,nfield)
+      REAL pfi(ngrid,nfield)
+
+      INTEGER i,j,ifield,ig
+
+!c-----------------------------------------------------------------------
+!c   calcul:
+!c   -------
+
+      DO ifield=1,nfield
+!c   traitement des poles
+         DO i=1,im
+            pdyn(i,1,ifield)=pfi(1,ifield)
+            pdyn(i,jm,ifield)=pfi(ngrid,ifield)
+         ENDDO
+
+!c   traitement des point normaux
+         DO j=2,jm-1
+	    ig=2+(j-2)*(im-1)
+            CALL SCOPY(im-1,pfi(ig,ifield),1,pdyn(1,j,ifield),1)
+	    pdyn(im,j,ifield)=pdyn(1,j,ifield)
+         ENDDO
+      ENDDO
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/gradsdef.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/gradsdef.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/gradsdef.h	(revision 17)
@@ -0,0 +1,23 @@
+!
+! $Header$
+!
+      integer nfmx,imx,jmx,lmx,nvarmx
+      parameter(nfmx=10,imx=200,jmx=150,lmx=200,nvarmx=1000)
+
+      real xd(imx,nfmx),yd(jmx,nfmx),zd(lmx,nfmx),dtime(nfmx)
+
+      integer imd(imx),jmd(jmx),lmd(lmx)
+      integer iid(imx),jid(jmx)
+      integer ifd(imx),jfd(jmx)
+      integer unit(nfmx),irec(nfmx),itime(nfmx),nld(nvarmx,nfmx)
+
+      integer nvar(nfmx),ivar(nfmx)
+      logical firsttime(nfmx)
+
+      character*10 var(nvarmx,nfmx),fichier(nfmx)
+      character*40 title(nfmx),tvar(nvarmx,nfmx)
+
+      common/gradsdef/xd,yd,zd,dtime,                                                &
+       &   imd,jmd,lmd,iid,jid,ifd,jfd,                                              &
+       &   unit,irec,nvar,ivar,itime,nld,firsttime,                                  &
+       &   var,fichier,title,tvar
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/handle_err_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/handle_err_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/handle_err_m.F90	(revision 17)
@@ -0,0 +1,46 @@
+! $Id$
+module handle_err_m
+
+  implicit none
+
+contains
+
+  subroutine handle_err(message, ncerr, ncid, varid)
+
+    use netcdf, only: nf90_strerror, nf90_noerr, nf90_close
+
+    character(len=*), intent(in):: message
+    ! (should include name of calling procedure)
+
+    integer, intent(in):: ncerr
+
+    integer, intent(in), optional :: ncid
+    ! (Provide this argument if you want "handle_err" to try to close
+    ! the file.)
+
+    integer, intent(in), optional :: varid
+
+    ! Variable local to the procedure:
+    integer ncerr_close
+
+    !-------------------
+
+    if (ncerr /= nf90_noerr) then
+       print *, message, ":"
+       if (present(varid)) print *, "varid = ", varid
+       print *, trim(nf90_strerror(ncerr))
+       if (present(ncid)) then
+          ! Try to close, to leave the file in a consistent state:
+          ncerr_close = nf90_close(ncid)
+          ! (do not call "nf95_close", we do not want to recurse)
+          if (ncerr_close /= nf90_noerr) then
+             print *, "nf90_close:"
+             print *, trim(nf90_strerror(ncerr_close))
+          end if
+       end if
+       stop 1
+    end if
+
+  end subroutine handle_err
+
+end module handle_err_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/hbtm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/hbtm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/hbtm.F	(revision 17)
@@ -0,0 +1,777 @@
+!
+! $Header$
+!
+
+      SUBROUTINE HBTM(knon, paprs, pplay,
+     .                t2m,t10m,q2m,q10m,ustar,
+     .                flux_t,flux_q,u,v,t,q,
+     .                pblh,cape,EauLiq,ctei,pblT,
+     .                therm,trmb1,trmb2,trmb3,plcl)
+        USE dimphy
+        IMPLICIT none
+
+c***************************************************************
+c*                                                             *
+c* HBTM2   D'apres Holstag&Boville et Troen&Mahrt              *
+c*                 JAS 47              BLM                     *
+c* Algorithme These Anne Mathieu                               *
+c* Critere d'Entrainement Peter Duynkerke (JAS 50)             *
+c* written by  : Anne MATHIEU & Alain LAHELLEC, 22/11/99       *
+c* features : implem. exces Mathieu                            *
+c***************************************************************
+c* mods : decembre 99 passage th a niveau plus bas. voir fixer *
+c* la prise du th a z/Lambda = -.2 (max Ray)                   *
+c* Autre algo : entrainement ~ Theta+v =cste mais comment=>The?*
+c* on peut fixer q a .7qsat(cf non adiab)=>T2 et The2          *
+c* voir aussi //KE pblh = niveau The_e ou l = env.             *
+c***************************************************************
+c* fin therm a la HBTM passage a forme Mathieu 12/09/2001      *
+c***************************************************************
+c*
+c
+c
+cAM Fev 2003
+c Adaptation a LMDZ version couplee
+c
+c Pour le moment on fait passer en argument les grdeurs de surface : 
+c flux, t,q2m, t,q10m, on va utiliser systematiquement les grdeurs a 2m ms 
+c on garde la possibilite de changer si besoin est (jusqu'a present la 
+c forme de HB avec le 1er niveau modele etait conservee)
+c
+c
+c
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL RLvCp, REPS
+c Arguments:
+c
+      INTEGER knon ! nombre de points a calculer
+cAM
+      REAL t2m(klon), t10m(klon) ! temperature a 2 et 10m
+      REAL q2m(klon), q10m(klon) ! q a 2 et 10m
+      REAL ustar(klon)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL flux_t(klon,klev), flux_q(klon,klev)     ! Flux 
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! vapeur d'eau (kg/kg)
+cAM      REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
+cAM      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+c
+      INTEGER isommet
+cum      PARAMETER (isommet=klev) ! limite max sommet pbl
+      REAL vk
+      PARAMETER (vk=0.35)     ! Von Karman => passer a .41 ! cf U.Olgstrom
+      REAL ricr
+      PARAMETER (ricr=0.4)
+      REAL fak
+      PARAMETER (fak=8.5)     ! b calcul du Prandtl et de dTetas
+      REAL fakn
+      PARAMETER (fakn=7.2)    ! a
+      REAL onet
+      PARAMETER (onet=1.0/3.0)
+      REAL t_coup
+      PARAMETER(t_coup=273.15)
+      REAL zkmin
+      PARAMETER (zkmin=0.01)
+      REAL betam
+      PARAMETER (betam=15.0)  ! pour Phim / h dans la S.L stable
+      REAL betah
+      PARAMETER (betah=15.0)
+      REAL betas
+      PARAMETER (betas=5.0)   ! Phit dans la S.L. stable (mais 2 formes / z/OBL<>1
+      REAL sffrac
+      PARAMETER (sffrac=0.1)  ! S.L. = z/h < .1
+      REAL binm
+      PARAMETER (binm=betam*sffrac)
+      REAL binh
+      PARAMETER (binh=betah*sffrac)
+      REAL ccon
+      PARAMETER (ccon=fak*sffrac*vk)
+c
+      REAL q_star,t_star
+      REAL b1,b2,b212,b2sr     ! Lambert correlations T' q' avec T* q*
+      PARAMETER (b1=70.,b2=20.)
+c
+      REAL z(klon,klev)
+cAM      REAL pcfm(klon,klev), pcfh(klon,klev)
+cAM
+      REAL zref
+      PARAMETER (zref=2.)    ! Niveau de ref a 2m peut eventuellement 
+c                              etre choisi a 10m
+cMA
+c
+      INTEGER i, k, j
+      REAL zxt
+cAM      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+cAM      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
+      REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
+      REAL heatv(klon)      ! surface virtual heat flux
+      REAL rhino(klon,klev) ! bulk Richardon no. mais en Theta_v
+      LOGICAL unstbl(klon)  ! pts w/unstbl pbl (positive virtual ht flx)
+      LOGICAL stblev(klon)  ! stable pbl with levels within pbl
+      LOGICAL unslev(klon)  ! unstbl pbl with levels within pbl
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+      LOGICAL omegafl(klon) ! flag de prolongerment cape pour pt Omega
+      REAL pblh(klon)
+      REAL pblT(klon)
+      REAL plcl(klon)
+cAM      REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m]
+cAM      REAL cgq(klon,2:klev) ! counter-gradient term for constituents
+cAM      REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux)
+      REAL obklen(klon)     ! Monin-Obukhov lengh
+cAM      REAL ztvd, ztvu, 
+      REAL zdu2
+      REAL therm(klon)      ! thermal virtual temperature excess
+      REAL trmb1(klon),trmb2(klon),trmb3(klon)
+C  Algorithme thermique
+      REAL s(klon,klev)     ! [P/Po]^Kappa milieux couches
+      REAL Th_th(klon)      ! potential temperature of thermal
+      REAL The_th(klon)     ! equivalent potential temperature of thermal
+      REAL qT_th(klon)      ! total water  of thermal
+      REAL Tbef(klon)       ! T thermique niveau precedent
+      REAL qsatbef(klon)
+      LOGICAL Zsat(klon)    ! le thermique est sature
+      REAL Cape(klon)       ! Cape du thermique
+      REAL Kape(klon)       ! Cape locale
+      REAL EauLiq(klon)     ! Eau liqu integr du thermique
+      REAL ctei(klon)       ! Critere d'instab d'entrainmt des nuages de CL
+      REAL the1,the2,aa,bb,zthvd,zthvu,xintpos,qqsat
+cIM 091204 BEG
+      REAL a1,a2,a3
+cIM 091204 END
+      REAL xhis,rnum,denom,th1,th2,thv1,thv2,ql2
+      REAL dqsat_dt,qsat2,qT1,q2,t1,t2,xnull,delt_the
+      REAL delt_qt,delt_2,quadsat,spblh,reduc
+c
+      REAL phiminv(klon)    ! inverse phi function for momentum
+      REAL phihinv(klon)    ! inverse phi function for heat
+      REAL wm(klon)         ! turbulent velocity scale for momentum
+      REAL fak1(klon)       ! k*ustar*pblh
+      REAL fak2(klon)       ! k*wm*pblh
+      REAL fak3(klon)       ! fakn*wstr/wm
+      REAL pblk(klon)       ! level eddy diffusivity for momentum
+      REAL pr(klon)         ! Prandtl number for eddy diffusivities
+      REAL zl(klon)         ! zmzp / Obukhov length
+      REAL zh(klon)         ! zmzp / pblh
+      REAL zzh(klon)        ! (1-(zmzp/pblh))**2
+      REAL wstr(klon)       ! w*, convective velocity scale
+      REAL zm(klon)         ! current level height
+      REAL zp(klon)         ! current level height + one level up
+      REAL zcor, zdelta, zcvm5
+cAM      REAL zxqs
+      REAL fac, pblmin, zmzp, term
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+
+
+! initialisations (Anne)
+      isommet=klev
+      th_th(:) = 0.
+      q_star = 0
+      t_star = 0
+
+
+      b212=sqrt(b1*b2)
+      b2sr=sqrt(b2)
+c
+C ============================================================
+C     Fonctions thermo implicites
+C ============================================================
+c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c Tetens : pression partielle de vap d'eau e_sat(T)
+c =================================================
+C++ e_sat(T) = r2*exp( r3*(T-Tf)/(T-r4) ) id a r2*FOEWE
+C++ avec :
+C++ Tf = 273.16 K  (Temp de fusion de la glace)
+C++ r2 = 611.14 Pa
+C++ r3 = 17.269 (liquide) 21.875 (solide) adim
+C++ r4 = 35.86             7.66           Kelvin
+C++  q_sat = eps*e_sat/(p-(1-eps)*e_sat)
+C++ derivï¿œ :
+C++ =========
+C++                   r3*(Tf-r4)*q_sat(T,p)
+C++ d_qsat_dT = --------------------------------
+C++             (T-r4)^2*( 1-(1-eps)*e_sat(T)/p )
+c++ pour zcvm5=Lv, c'est FOEDE
+c++ Rq :(1.-REPS)*esarg/Parg id a RETV*Qsat
+C     ------------------------------------------------------------------
+c
+c Initialisation
+      RLvCp = RLVTT/RCPD
+      REPS  = RD/RV
+
+c
+c      DO i = 1, klon
+c         pcfh(i,1) = cd_h(i)
+c         pcfm(i,1) = cd_m(i)
+c      ENDDO
+c      DO k = 2, klev
+c      DO i = 1, klon
+c         pcfh(i,k) = zkmin
+c         pcfm(i,k) = zkmin
+c         cgs(i,k) = 0.0
+c         cgh(i,k) = 0.0
+c         cgq(i,k) = 0.0
+c      ENDDO
+c      ENDDO
+c
+c Calculer les hauteurs de chaque couche
+c (geopotentielle Int_dp/ro = Int_[Rd.T.dp/p] z = geop/g)
+c  pourquoi ne pas utiliser Phi/RG ?
+      DO i = 1, knon
+         z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))
+     .               * (paprs(i,1)-pplay(i,1)) / RG
+         s(i,1) = (pplay(i,1)/paprs(i,1))**RKappa
+      ENDDO
+c                                 s(k) = [pplay(k)/ps]^kappa
+c    + + + + + + + + + pplay  <-> s(k)   t  dp=pplay(k-1)-pplay(k)
+c
+c    -----------------  paprs <-> sig(k)
+c
+c    + + + + + + + + + pplay  <-> s(k-1)
+c
+c
+c    + + + + + + + + + pplay  <-> s(1)   t  dp=paprs-pplay   z(1)
+c
+c    -----------------  paprs <-> sig(1)
+c
+      DO k = 2, klev
+      DO i = 1, knon
+         z(i,k) = z(i,k-1)
+     .              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)
+     .                   * (pplay(i,k-1)-pplay(i,k)) / RG
+         s(i,k) = (pplay(i,k)/paprs(i,1))**RKappa
+      ENDDO
+      ENDDO
+c  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +++  Determination des grandeurs de surface  +++++++++++++++++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      DO i = 1, knon
+cAM         IF (thermcep) THEN
+cAM           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
+c           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+c           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+cAM           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
+cAM           zxqs=MIN(0.5,zxqs)
+cAM           zcor=1./(1.-retv*zxqs)
+cAM           zxqs=zxqs*zcor
+cAM         ELSE
+cAM           IF (tsol(i).LT.t_coup) THEN
+cAM              zxqs = qsats(tsol(i)) / paprs(i,1)
+cAM           ELSE
+cAM              zxqs = qsatl(tsol(i)) / paprs(i,1)
+cAM           ENDIF
+cAM         ENDIF
+c niveau de reference bulk; mais ici, c,a pourrait etre le niveau de ref du thermique
+cAM        zx_alf1 = 1.0
+cAM        zx_alf2 = 1.0 - zx_alf1
+cAM        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
+cAM     .        *(1.+RETV*q(i,1))*zx_alf1
+cAM     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
+cAM     .        *(1.+RETV*q(i,2))*zx_alf2
+cAM        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+cAM        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+cAM        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
+cAM      
+cAMAM           zxu = u10m(i)
+cAMAM           zxv = v10m(i)
+cAMAM           zxmod = 1.0+SQRT(zxu**2+zxv**2)
+cAM Niveau de ref choisi a 2m
+        zxt = t2m(i)
+
+c ***************************************************
+c attention, il doit s'agir de <w'theta'>
+c   ;Calcul de tcls virtuel et de w'theta'virtuel
+c   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+c   tcls=tcls*(1+.608*qcls)
+c
+c   ;Pour avoir w'theta',
+c   ; il faut diviser par ro.Cp
+c   Cp=Cpd*(1+0.84*qcls)
+c   fcs=fcs/(ro_surf*Cp)
+c   ;On transforme w'theta' en w'thetav'
+c   Lv=(2.501-0.00237*(tcls-273.15))*1.E6
+c   xle=xle/(ro_surf*Lv)
+c   fcsv=fcs+.608*xle*tcls
+c ***************************************************
+cAM        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
+cAM        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
+cAM
+cdif khfs est deja w't'_v / heatv(i) = khfs(i) + RETV*zxt*kqfs(i)
+cAM calcule de Ro = paprs(i,1)/Rd zxt
+cAM convention >0 vers le bas ds lmdz 
+        khfs(i) = - flux_t(i,1)*zxt*Rd / (RCPD*paprs(i,1))
+        kqfs(i) = - flux_q(i,1)*zxt*Rd / (paprs(i,1))
+cAM   verifier que khfs et kqfs sont bien de la forme w'l'
+        heatv(i) = khfs(i) + 0.608*zxt*kqfs(i)
+c a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv
+cAM        heatv(i) = khfs(i)
+cAM ustar est en entree
+cAM        taux = zxu *zxmod*cd_m(i)
+cAM        tauy = zxv *zxmod*cd_m(i)
+cAM        ustar(i) = SQRT(taux**2+tauy**2)
+cAM        ustar(i) = MAX(SQRT(ustar(i)),0.01)
+c Theta et qT du thermique sans exces (interpolin vers surf)
+c chgt de niveau du thermique (jeudi 30/12/1999)
+c (interpolation lineaire avant integration phi_h)
+cAM        qT_th(i) = zxqs*beta(i) + 4./z(i,1)*(q(i,1)-zxqs*beta(i))
+cAM        qT_th(i) = max(qT_th(i),q(i,1))
+        qT_th(i) = q2m(i)
+cn The_th restera la Theta du thermique sans exces jusqu'a 2eme calcul
+cn reste a regler convention P) pour Theta
+c        The_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
+c     -                      + RLvCp*qT_th(i)
+cAM        Th_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
+        Th_th(i) = t2m(i)
+      ENDDO
+c
+      DO i = 1, knon
+         rhino(i,1) = 0.0   ! Global Richardson
+         check(i) = .TRUE.
+         pblh(i) = z(i,1)   ! on initialise pblh a l'altitude du 1er niveau
+         plcl(i) = 6000.
+c Lambda = -u*^3 / (alpha.g.kvon.<w'Theta'v>
+         obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
+         trmb1(i)   = 0.
+         trmb2(i)   = 0.
+         trmb3(i) = 0.
+      ENDDO
+
+C
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C PBL height calculation:
+C Search for level of pbl. Scan upward until the Richardson number between
+C the first level and the current level exceeds the "critical" value.
+C (bonne idee Nu de separer le Ric et l'exces de temp du thermique)
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      fac = 100.0
+      DO k = 2, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+! pourquoi / niveau 1 (au lieu du sol) et le terme en u*^2 ?
+ctest     zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = u(i,k)**2+v(i,k)**2
+         zdu2 = max(zdu2,1.0e-20)
+c Theta_v environnement
+         zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k))
+c
+c therm Theta_v sans exces (avec hypothese fausse de H&B, sinon,
+c passer par Theta_e et virpot)
+c         zthvu=t(i,1)/s(i,1)*(1.+RETV*q(i,1))
+cAM         zthvu = Th_th(i)*(1.+RETV*q(i,1))
+         zthvu = Th_th(i)*(1.+RETV*qT_th(i))
+c  Le Ri par Theta_v
+cAM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
+cAM     .               /(zdu2*0.5*(zthvd+zthvu))
+cAM On a nveau de ref a 2m ???
+         rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu)
+     .               /(zdu2*0.5*(zthvd+zthvu))
+c
+         IF (rhino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
+c test04
+           pblh(i) = pblh(i) + 100.
+           pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *
+     .              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C Improve estimate of pbl height for the unstable points.
+C Find unstable points (sensible heat flux is upward):
+C
+      DO i = 1, knon
+      IF (heatv(i) .GT. 0.) THEN
+        unstbl(i) = .TRUE.
+        check(i) = .TRUE.
+      ELSE
+        unstbl(i) = .FALSE.
+        check(i) = .FALSE.
+      ENDIF
+      ENDDO
+C
+C For the unstable case, compute velocity scale and the
+C convective temperature excess:
+C
+      DO i = 1, knon
+      IF (check(i)) THEN
+        phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+c ***************************************************
+c Wm ? et W* ? c'est la formule pour z/h < .1
+c   ;Calcul de w* ;;
+c   ;;;;;;;;;;;;;;;;
+c   w_star=((g/tcls)*fcsv*z(ind))^(1/3.) [ou prendre la premiere approx de h)
+c   ;; CALCUL DE wm ;;
+c   ;;;;;;;;;;;;;;;;;;
+c   ; Ici on considerera que l'on est dans la couche de surf jusqu'a 100m
+c   ; On prend svt couche de surface=0.1*h mais on ne connait pas h
+c   ;;;;;;;;;;;Dans la couche de surface
+c   if (z(ind) le 20) then begin
+c   Phim=(1.-15.*(z(ind)/L))^(-1/3.)
+c   wm=u_star/Phim
+c   ;;;;;;;;;;;En dehors de la couche de surface
+c   endif else if (z(ind) gt 20) then begin
+c   wm=(u_star^3+c1*w_star^3)^(1/3.)
+c   endif
+c ***************************************************
+        wm(i)= ustar(i)*phiminv(i)
+c======================================================================
+cvaleurs de Dominique Lambert de la campagne SEMAPHORE :
+c <T'^2> = 100.T*^2; <q'^2> = 20.q*^2 a 10m
+c <Tv'^2> = (1+1.2q).100.T* + 1.2Tv.sqrt(20*100).T*.q* + (.608*Tv)^2*20.q*^2;
+c et dTetavS = sqrt(<Tv'^2>) ainsi calculee.
+c avec : T*=<w'T'>_s/w* et q*=<w'q'>/w*
+c !!! on peut donc utiliser w* pour les fluctuations <-> Lambert
+c(leur corellation pourrait dependre de beta par ex)
+c  if fcsv(i,j) gt 0 then begin
+c    dTetavs=b1*(1.+2.*.608*q_10(i,j))*(fcs(i,j)/wm(i,j))^2+$
+c    (.608*Thetav_10(i,j))^2*b2*(xle(i,j)/wm(i,j))^2+$
+c    2.*.608*thetav_10(i,j)*sqrt(b1*b2)*(xle(i,j)/wm(i,j))*(fcs(i,j)/wm(i,j))
+c    dqs=b2*(xle(i,j)/wm(i,j))^2
+c    theta_s(i,j)=thetav_10(i,j)+sqrt(dTetavs)
+c    q_s(i,j)=q_10(i,j)+sqrt(dqs)
+c  endif else begin
+c    Theta_s(i,j)=thetav_10(i,j)
+c    q_s(i,j)=q_10(i,j)
+c  endelse
+c======================================================================
+c
+cHBTM        therm(i) = heatv(i)*fak/wm(i)
+c forme Mathieu :
+        q_star = kqfs(i)/wm(i)
+        t_star = khfs(i)/wm(i)
+cIM 091204 BEG
+        IF(1.EQ.0) THEN
+        IF(t_star.LT.0..OR.q_star.LT.0.) THEN
+          print*,'i t_star q_star khfs kqfs wm',i,t_star,q_star,
+     $    khfs(i),kqfs(i),wm(i)
+        ENDIF
+        ENDIF
+cIM 091204 END
+cAM Nveau cde ref 2m =>
+cAM        therm(i) = sqrt( b1*(1.+2.*RETV*q(i,1))*t_star**2
+cAM     +             + (RETV*T(i,1))**2*b2*q_star**2
+cAM     +             + 2.*RETV*T(i,1)*b212*q_star*t_star
+cAM     +                 )
+cIM 091204 BEG
+        a1=b1*(1.+2.*RETV*qT_th(i))*t_star**2
+        a2=(RETV*Th_th(i))**2*b2*q_star*q_star
+        a3=2.*RETV*Th_th(i)*b212*q_star*t_star
+        aa=a1+a2+a3
+        IF(1.EQ.0) THEN
+        IF (aa.LT.0.) THEN 
+         print*,'i a1 a2 a3 aa',i,a1,a2,a3,aa
+         print*,'i qT_th Th_th t_star q_star RETV b1 b2 b212',
+     $   i,qT_th(i),Th_th(i),t_star,q_star,RETV,b1,b2,b212
+        ENDIF
+        ENDIF
+cIM 091204 END
+        therm(i) = sqrt( b1*(1.+2.*RETV*qT_th(i))*t_star**2
+     +             + (RETV*Th_th(i))**2*b2*q_star*q_star
+cIM 101204  +             + 2.*RETV*Th_th(i)*b212*q_star*t_star
+     +             + max(0.,2.*RETV*Th_th(i)*b212*q_star*t_star)
+     +                 )
+c
+c Theta et qT du thermique (forme H&B) avec exces
+c (attention, on ajoute therm(i) qui est virtuelle ...)
+c pourquoi pas sqrt(b1)*t_star ?
+c        dqs = b2sr*kqfs(i)/wm(i)
+        qT_th(i) = qT_th(i)  + b2sr*q_star
+cnew on differre le calcul de Theta_e
+c        The_th(i) = The_th(i) + therm(i) + RLvCp*qT_th(i)
+c ou:    The_th(i) = The_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
+        rhino(i,1) = 0.0
+      ENDIF
+      ENDDO
+C
+c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C ++ Improve pblh estimate for unstable conditions using the +++++++
+C ++          convective temperature excess :                +++++++
+c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+C
+      DO k = 2, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+ctest     zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = u(i,k)**2+v(i,k)**2
+         zdu2 = max(zdu2,1.0e-20)
+c Theta_v environnement
+         zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k))
+c
+c et therm Theta_v (avec hypothese de constance de H&B,
+c         zthvu=(t(i,1)+therm(i))/s(i,1)*(1.+RETV*q(i,1))
+         zthvu = Th_th(i)*(1.+RETV*qT_th(i)) + therm(i)
+
+c
+c  Le Ri par Theta_v
+cAM Niveau de ref 2m
+cAM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
+cAM     .               /(zdu2*0.5*(zthvd+zthvu))
+         rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu)
+     .               /(zdu2*0.5*(zthvd+zthvu))
+c
+c
+         IF (rhino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .              (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
+c test04
+           pblh(i) = pblh(i) + 100.
+           pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *
+     .              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
+           check(i) = .FALSE.
+cIM 170305 BEG
+      IF(1.EQ.0) THEN
+c debug print -120;34       -34-        58 et    0;26 wamp
+      if (i.eq.950.or.i.eq.192.or.i.eq.624.or.i.eq.118) then
+            print*,' i,Th_th,Therm,qT :',i,Th_th(i),therm(i),qT_th(i)
+            q_star = kqfs(i)/wm(i)
+            t_star = khfs(i)/wm(i)
+            print*,'q* t*, b1,b2,b212 ',q_star,t_star
+     -            , b1*(1.+2.*RETV*qT_th(i))*t_star**2
+     -            , (RETV*Th_th(i))**2*b2*q_star**2
+     -            , 2.*RETV*Th_th(i)*b212*q_star*t_star
+            print*,'zdu2 ,100.*ustar(i)**2',zdu2 ,fac*ustar(i)**2
+      endif
+      ENDIF !(1.EQ.0) THEN
+cIM 170305 END
+c             q_star = kqfs(i)/wm(i)
+c             t_star = khfs(i)/wm(i)
+c             trmb1(i) = b1*(1.+2.*RETV*q(i,1))*t_star**2
+c             trmb2(i) = (RETV*T(i,1))**2*b2*q_star**2
+c Omega now   trmb3(i) = 2.*RETV*T(i,1)*b212*q_star*t_star
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+C
+C Set pbl height to maximum value where computation exceeds number of
+C layers allowed
+C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+C
+C PBL height must be greater than some minimum mechanical mixing depth
+C Several investigators have proposed minimum mechanical mixing depth
+C relationships as a function of the local friction velocity, u*.  We
+C make use of a linear relationship of the form h = c u* where c=700.
+C The scaling arguments that give rise to this relationship most often
+C represent the coefficient c as some constant over the local coriolis
+C parameter.  Here we make use of the experimental results of Koracin
+C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
+C where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
+C latitude value for f so that c = 0.07/f = 700.
+C
+      DO i = 1, knon
+        pblmin  = 700.0*ustar(i)
+        pblh(i) = MAX(pblh(i),pblmin)
+c par exemple :
+        pblT(i) = t(i,2) + (t(i,3)-t(i,2)) *
+     .              (pblh(i)-z(i,2))/(z(i,3)-z(i,2))
+      ENDDO
+
+C ********************************************************************
+C  pblh is now available; do preparation for diffusivity calculation :
+C ********************************************************************
+      DO i = 1, knon
+        check(i) = .TRUE.
+        Zsat(i)   = .FALSE.
+c omegafl utilise pour prolongement CAPE
+        omegafl(i) = .FALSE.
+        Cape(i)   = 0.
+        Kape(i)   = 0.
+        EauLiq(i) = 0.
+        CTEI(i)   = 0.
+        pblk(i) = 0.0
+        fak1(i) = ustar(i)*pblh(i)*vk
+C
+C Do additional preparation for unstable cases only, set temperature
+C and moisture perturbations depending on stability.
+C *** Rq: les formule sont prises dans leur forme CS ***
+        IF (unstbl(i)) THEN
+cAM Niveau de ref du thermique
+cAM          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+cAM     .         *(1.+RETV*q(i,1))
+          zxt=(Th_th(i)-zref*0.5*RG/RCPD/(1.+RVTMP2*qT_th(i)))
+     .         *(1.+RETV*qT_th(i))
+          phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet
+          phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i))
+          wm(i)      = ustar(i)*phiminv(i)
+          fak2(i)    = wm(i)*pblh(i)*vk
+          wstr(i)    = (heatv(i)*RG*pblh(i)/zxt)**onet
+          fak3(i)    = fakn*wstr(i)/wm(i)
+        ENDIF
+c Computes Theta_e for thermal (all cases : to be modified)
+c   attention ajout therm(i) = virtuelle
+        The_th(i) = Th_th(i) + therm(i) + RLvCp*qT_th(i)
+c ou:    The_th(i) = Th_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
+      ENDDO
+
+C Main level loop to compute the diffusivities and
+C counter-gradient terms:
+C
+      DO 1000 k = 2, isommet
+C
+C Find levels within boundary layer:
+C
+        DO i = 1, knon
+          unslev(i) = .FALSE.
+          stblev(i) = .FALSE.
+          zm(i) = z(i,k-1)
+          zp(i) = z(i,k)
+          IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i)
+          IF (zm(i) .LT. pblh(i)) THEN
+            zmzp = 0.5*(zm(i) + zp(i))
+C debug
+c          if (i.EQ.1864) then
+c             print*,'i,pblh(1864),obklen(1864)',i,pblh(i),obklen(i)
+c          endif
+
+            zh(i) = zmzp/pblh(i)
+            zl(i) = zmzp/obklen(i)
+            zzh(i) = 0.
+            IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2
+C
+C stblev for points zm < plbh and stable and neutral
+C unslev for points zm < plbh and unstable
+C
+            IF (unstbl(i)) THEN
+              unslev(i) = .TRUE.
+            ELSE
+              stblev(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+c        print*,'fin calcul niveaux'
+C
+C Stable and neutral points; set diffusivities; counter-gradient
+C terms zero for stable case:
+C
+        DO i = 1, knon
+          IF (stblev(i)) THEN
+            IF (zl(i).LE.1.) THEN
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i))
+            ELSE
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i))
+            ENDIF
+c            pcfm(i,k) = pblk(i)
+c            pcfh(i,k) = pcfm(i,k)
+          ENDIF
+        ENDDO
+C
+C unssrf, unstable within surface layer of pbl
+C unsout, unstable within outer   layer of pbl
+C
+        DO i = 1, knon
+          unssrf(i) = .FALSE.
+          unsout(i) = .FALSE.
+          IF (unslev(i)) THEN
+            IF (zh(i).lt.sffrac) THEN
+              unssrf(i) = .TRUE.
+            ELSE
+              unsout(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+C
+C Unstable for surface layer; counter-gradient terms zero
+C
+        DO i = 1, knon
+          IF (unssrf(i)) THEN
+            term = (1. - betam*zl(i))**onet
+            pblk(i) = fak1(i)*zh(i)*zzh(i)*term
+            pr(i) = term/sqrt(1. - betah*zl(i))
+          ENDIF
+        ENDDO
+c        print*,'fin counter-gradient terms zero'
+C
+C Unstable for outer layer; counter-gradient terms non-zero:
+C
+        DO i = 1, knon
+          IF (unsout(i)) THEN
+            pblk(i) = fak2(i)*zh(i)*zzh(i)
+c            cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
+c            cgh(i,k) = khfs(i)*cgs(i,k)
+            pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
+c            cgq(i,k) = kqfs(i)*cgs(i,k)
+          ENDIF
+        ENDDO
+c        print*,'fin counter-gradient terms non zero'
+C
+C For all unstable layers, compute diffusivities and ctrgrad ter m
+C
+c        DO i = 1, knon
+c        IF (unslev(i)) THEN
+c            pcfm(i,k) = pblk(i)
+c            pcfh(i,k) = pblk(i)/pr(i)
+c etc cf original
+c        ENDIF
+c        ENDDO
+C
+C For all layers, compute integral info and CTEI
+C
+        DO i = 1, knon
+        if (check(i).or.omegafl(i)) then
+          if (.not.Zsat(i)) then
+c            Th2 = The_th(i) - RLvCp*qT_th(i)
+            Th2 = Th_th(i)
+            T2 = Th2*s(i,k)
+c thermodyn functions
+            zdelta=MAX(0.,SIGN(1.,RTT-T2))
+            qqsat= r2es * FOEEW(T2,zdelta)/pplay(i,k)
+            qqsat=MIN(0.5,qqsat)
+            zcor=1./(1.-retv*qqsat)
+            qqsat=qqsat*zcor
+c
+            if (qqsat.lt.qT_th(i)) then
+c on calcule lcl
+              if (k.eq.2) then
+                plcl(i) = z(i,k)
+              else
+                plcl(i) =  z(i,k-1) + (z(i,k-1)-z(i,k)) *
+     .                 (qT_th(i)-qsatbef(i))/(qsatbef(i)-qqsat)
+              endif
+              Zsat(i) = .true.
+              Tbef(i) = T2
+            endif
+c
+            qsatbef(i) = qqsat    ! bug dans la version orig ???
+          endif
+camn ???? cette ligne a deja ete faite normalement ?
+        endif
+c            print*,'hbtm2 i,k=',i,k
+        ENDDO
+ 1000 continue           ! end of level loop
+cIM 170305 BEG
+        IF(1.EQ.0) THEN
+            print*,'hbtm2  ok'
+        ENDIF !(1.EQ.0) THEN
+cIM 170305 END
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/hbtm.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/hbtm.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/hbtm.F90	(revision 17)
@@ -0,0 +1,777 @@
+!
+! $Header$
+!
+
+      SUBROUTINE HBTM(knon, paprs, pplay,                                            &
+       &                t2m,t10m,q2m,q10m,ustar,                                     &
+       &                flux_t,flux_q,u,v,t,q,                                       &
+       &                pblh,cape,EauLiq,ctei,pblT,                                  &
+       &                therm,trmb1,trmb2,trmb3,plcl)
+        USE dimphy
+        IMPLICIT none
+
+!c***************************************************************
+!c*                                                             *
+!c* HBTM2   D'apres Holstag&Boville et Troen&Mahrt              *
+!c*                 JAS 47              BLM                     *
+!c* Algorithme These Anne Mathieu                               *
+!c* Critere d'Entrainement Peter Duynkerke (JAS 50)             *
+!c* written by  : Anne MATHIEU & Alain LAHELLEC, 22/11/99       *
+!c* features : implem. exces Mathieu                            *
+!c***************************************************************
+!c* mods : decembre 99 passage th a niveau plus bas. voir fixer *
+!c* la prise du th a z/Lambda = -.2 (max Ray)                   *
+!c* Autre algo : entrainement ~ Theta+v =cste mais comment=>The?*
+!c* on peut fixer q a .7qsat(cf non adiab)=>T2 et The2          *
+!c* voir aussi //KE pblh = niveau The_e ou l = env.             *
+!c***************************************************************
+!c* fin therm a la HBTM passage a forme Mathieu 12/09/2001      *
+!c***************************************************************
+!c*
+!c
+!c
+!cAM Fev 2003
+!c Adaptation a LMDZ version couplee
+!c
+!c Pour le moment on fait passer en argument les grdeurs de surface : 
+!c flux, t,q2m, t,q10m, on va utiliser systematiquement les grdeurs a 2m ms 
+!c on garde la possibilite de changer si besoin est (jusqu'a present la 
+!c forme de HB avec le 1er niveau modele etait conservee)
+!c
+!c
+!c
+!c
+!c
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+      REAL RLvCp, REPS
+!c Arguments:
+!c
+      INTEGER knon ! nombre de points a calculer
+!cAM
+      REAL t2m(klon), t10m(klon) ! temperature a 2 et 10m
+      REAL q2m(klon), q10m(klon) ! q a 2 et 10m
+      REAL ustar(klon)
+      REAL paprs(klon,klev+1) ! pression a inter-couche (Pa)
+      REAL pplay(klon,klev)   ! pression au milieu de couche (Pa)
+      REAL flux_t(klon,klev), flux_q(klon,klev)     ! Flux 
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! vapeur d'eau (kg/kg)
+!cAM      REAL cd_h(klon) ! coefficient de friction au sol pour chaleur
+!cAM      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+!c
+      INTEGER isommet
+!cum      PARAMETER (isommet=klev) ! limite max sommet pbl
+      REAL vk
+      PARAMETER (vk=0.35)     ! Von Karman => passer a .41 ! cf U.Olgstrom
+      REAL ricr
+      PARAMETER (ricr=0.4)
+      REAL fak
+      PARAMETER (fak=8.5)     ! b calcul du Prandtl et de dTetas
+      REAL fakn
+      PARAMETER (fakn=7.2)    ! a
+      REAL onet
+      PARAMETER (onet=1.0/3.0)
+      REAL t_coup
+      PARAMETER(t_coup=273.15)
+      REAL zkmin
+      PARAMETER (zkmin=0.01)
+      REAL betam
+      PARAMETER (betam=15.0)  ! pour Phim / h dans la S.L stable
+      REAL betah
+      PARAMETER (betah=15.0)
+      REAL betas
+      PARAMETER (betas=5.0)   ! Phit dans la S.L. stable (mais 2 formes / z/OBL<>1
+      REAL sffrac
+      PARAMETER (sffrac=0.1)  ! S.L. = z/h < .1
+      REAL binm
+      PARAMETER (binm=betam*sffrac)
+      REAL binh
+      PARAMETER (binh=betah*sffrac)
+      REAL ccon
+      PARAMETER (ccon=fak*sffrac*vk)
+!c
+      REAL q_star,t_star
+      REAL b1,b2,b212,b2sr     ! Lambert correlations T' q' avec T* q*
+      PARAMETER (b1=70.,b2=20.)
+!c
+      REAL z(klon,klev)
+!cAM      REAL pcfm(klon,klev), pcfh(klon,klev)
+!cAM
+      REAL zref
+      PARAMETER (zref=2.)    ! Niveau de ref a 2m peut eventuellement 
+!c                              etre choisi a 10m
+!cMA
+!c
+      INTEGER i, k, j
+      REAL zxt
+!cAM      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+!cAM      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      REAL khfs(klon)       ! surface kinematic heat flux [mK/s]
+      REAL kqfs(klon)       ! sfc kinematic constituent flux [m/s]
+      REAL heatv(klon)      ! surface virtual heat flux
+      REAL rhino(klon,klev) ! bulk Richardon no. mais en Theta_v
+      LOGICAL unstbl(klon)  ! pts w/unstbl pbl (positive virtual ht flx)
+      LOGICAL stblev(klon)  ! stable pbl with levels within pbl
+      LOGICAL unslev(klon)  ! unstbl pbl with levels within pbl
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+      LOGICAL omegafl(klon) ! flag de prolongerment cape pour pt Omega
+      REAL pblh(klon)
+      REAL pblT(klon)
+      REAL plcl(klon)
+!cAM      REAL cgh(klon,2:klev) ! counter-gradient term for heat [K/m]
+!cAM      REAL cgq(klon,2:klev) ! counter-gradient term for constituents
+!cAM      REAL cgs(klon,2:klev) ! counter-gradient star (cg/flux)
+      REAL obklen(klon)     ! Monin-Obukhov lengh
+!cAM      REAL ztvd, ztvu, 
+      REAL zdu2
+      REAL therm(klon)      ! thermal virtual temperature excess
+      REAL trmb1(klon),trmb2(klon),trmb3(klon)
+!C  Algorithme thermique
+      REAL s(klon,klev)     ! [P/Po]^Kappa milieux couches
+      REAL Th_th(klon)      ! potential temperature of thermal
+      REAL The_th(klon)     ! equivalent potential temperature of thermal
+      REAL qT_th(klon)      ! total water  of thermal
+      REAL Tbef(klon)       ! T thermique niveau precedent
+      REAL qsatbef(klon)
+      LOGICAL Zsat(klon)    ! le thermique est sature
+      REAL Cape(klon)       ! Cape du thermique
+      REAL Kape(klon)       ! Cape locale
+      REAL EauLiq(klon)     ! Eau liqu integr du thermique
+      REAL ctei(klon)       ! Critere d'instab d'entrainmt des nuages de CL
+      REAL the1,the2,aa,bb,zthvd,zthvu,xintpos,qqsat
+!IM 091204 BEG
+      REAL a1,a2,a3
+!IM 091204 END
+      REAL xhis,rnum,denom,th1,th2,thv1,thv2,ql2
+      REAL dqsat_dt,qsat2,qT1,q2,t1,t2,xnull,delt_the
+      REAL delt_qt,delt_2,quadsat,spblh,reduc
+!c
+      REAL phiminv(klon)    ! inverse phi function for momentum
+      REAL phihinv(klon)    ! inverse phi function for heat
+      REAL wm(klon)         ! turbulent velocity scale for momentum
+      REAL fak1(klon)       ! k*ustar*pblh
+      REAL fak2(klon)       ! k*wm*pblh
+      REAL fak3(klon)       ! fakn*wstr/wm
+      REAL pblk(klon)       ! level eddy diffusivity for momentum
+      REAL pr(klon)         ! Prandtl number for eddy diffusivities
+      REAL zl(klon)         ! zmzp / Obukhov length
+      REAL zh(klon)         ! zmzp / pblh
+      REAL zzh(klon)        ! (1-(zmzp/pblh))**2
+      REAL wstr(klon)       ! w*, convective velocity scale
+      REAL zm(klon)         ! current level height
+      REAL zp(klon)         ! current level height + one level up
+      REAL zcor, zdelta, zcvm5
+!cAM      REAL zxqs
+      REAL fac, pblmin, zmzp, term
+!c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+
+
+! initialisations (Anne)
+      isommet=klev
+      th_th(:) = 0.
+      q_star = 0
+      t_star = 0
+
+
+      b212=sqrt(b1*b2)
+      b2sr=sqrt(b2)
+!c
+!C ============================================================
+!C     Fonctions thermo implicites
+!C ============================================================
+!c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!c Tetens : pression partielle de vap d'eau e_sat(T)
+!c =================================================
+!C++ e_sat(T) = r2*exp( r3*(T-Tf)/(T-r4) ) id a r2*FOEWE
+!C++ avec :
+!C++ Tf = 273.16 K  (Temp de fusion de la glace)
+!C++ r2 = 611.14 Pa
+!C++ r3 = 17.269 (liquide) 21.875 (solide) adim
+!C++ r4 = 35.86             7.66           Kelvin
+!C++  q_sat = eps*e_sat/(p-(1-eps)*e_sat)
+!C++ derivï¿œ :
+!C++ =========
+!C++                   r3*(Tf-r4)*q_sat(T,p)
+!C++ d_qsat_dT = --------------------------------
+!C++             (T-r4)^2*( 1-(1-eps)*e_sat(T)/p )
+!c++ pour zcvm5=Lv, c'est FOEDE
+!c++ Rq :(1.-REPS)*esarg/Parg id a RETV*Qsat
+!C     ------------------------------------------------------------------
+!c
+!c Initialisation
+      RLvCp = RLVTT/RCPD
+      REPS  = RD/RV
+
+!c
+!c      DO i = 1, klon
+!c         pcfh(i,1) = cd_h(i)
+!c         pcfm(i,1) = cd_m(i)
+!c      ENDDO
+!c      DO k = 2, klev
+!c      DO i = 1, klon
+!c         pcfh(i,k) = zkmin
+!c         pcfm(i,k) = zkmin
+!c         cgs(i,k) = 0.0
+!c         cgh(i,k) = 0.0
+!c         cgq(i,k) = 0.0
+!c      ENDDO
+!c      ENDDO
+!c
+!c Calculer les hauteurs de chaque couche
+!c (geopotentielle Int_dp/ro = Int_[Rd.T.dp/p] z = geop/g)
+!c  pourquoi ne pas utiliser Phi/RG ?
+      DO i = 1, knon
+         z(i,1) = RD * t(i,1) / (0.5*(paprs(i,1)+pplay(i,1)))                        &
+       &               * (paprs(i,1)-pplay(i,1)) / RG
+         s(i,1) = (pplay(i,1)/paprs(i,1))**RKappa
+      ENDDO
+!c                                 s(k) = [pplay(k)/ps]^kappa
+!c    + + + + + + + + + pplay  <-> s(k)   t  dp=pplay(k-1)-pplay(k)
+!c
+!c    -----------------  paprs <-> sig(k)
+!c
+!c    + + + + + + + + + pplay  <-> s(k-1)
+!c
+!c
+!c    + + + + + + + + + pplay  <-> s(1)   t  dp=paprs-pplay   z(1)
+!c
+!c    -----------------  paprs <-> sig(1)
+!c
+      DO k = 2, klev
+      DO i = 1, knon
+         z(i,k) = z(i,k-1)                                                           &
+       &              + RD * 0.5*(t(i,k-1)+t(i,k)) / paprs(i,k)                      &
+       &                   * (pplay(i,k-1)-pplay(i,k)) / RG
+         s(i,k) = (pplay(i,k)/paprs(i,1))**RKappa
+      ENDDO
+      ENDDO
+!c  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!c +++  Determination des grandeurs de surface  +++++++++++++++++++++
+!c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!c  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      DO i = 1, knon
+!cAM         IF (thermcep) THEN
+!cAM           zdelta=MAX(0.,SIGN(1.,RTT-tsol(i)))
+!c           zcvm5 = R5LES*RLVTT*(1.-zdelta) + R5IES*RLSTT*zdelta
+!c           zcvm5 = zcvm5 / RCPD / (1.0+RVTMP2*q(i,1))
+!cAM           zxqs= r2es * FOEEW(tsol(i),zdelta)/paprs(i,1)
+!cAM           zxqs=MIN(0.5,zxqs)
+!cAM           zcor=1./(1.-retv*zxqs)
+!cAM           zxqs=zxqs*zcor
+!cAM         ELSE
+!cAM           IF (tsol(i).LT.t_coup) THEN
+!cAM              zxqs = qsats(tsol(i)) / paprs(i,1)
+!cAM           ELSE
+!cAM              zxqs = qsatl(tsol(i)) / paprs(i,1)
+!cAM           ENDIF
+!cAM         ENDIF
+!c niveau de reference bulk; mais ici, c,a pourrait etre le niveau de ref du thermique
+!cAM        zx_alf1 = 1.0
+!cAM        zx_alf2 = 1.0 - zx_alf1
+!cAM        zxt = (t(i,1)+z(i,1)*RG/RCPD/(1.+RVTMP2*q(i,1)))
+!cAM     .        *(1.+RETV*q(i,1))*zx_alf1
+!cAM     .      + (t(i,2)+z(i,2)*RG/RCPD/(1.+RVTMP2*q(i,2)))
+!cAM     .        *(1.+RETV*q(i,2))*zx_alf2
+!cAM        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+!cAM        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+!cAM        zxq = q(i,1)*zx_alf1+q(i,2)*zx_alf2
+!cAM      
+!cAMAM           zxu = u10m(i)
+!cAMAM           zxv = v10m(i)
+!cAMAM           zxmod = 1.0+SQRT(zxu**2+zxv**2)
+!cAM Niveau de ref choisi a 2m
+        zxt = t2m(i)
+
+!c ***************************************************
+!c attention, il doit s'agir de <w'theta'>
+!c   ;Calcul de tcls virtuel et de w'theta'virtuel
+!c   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+!c   tcls=tcls*(1+.608*qcls)
+!c
+!c   ;Pour avoir w'theta',
+!c   ; il faut diviser par ro.Cp
+!c   Cp=Cpd*(1+0.84*qcls)
+!c   fcs=fcs/(ro_surf*Cp)
+!c   ;On transforme w'theta' en w'thetav'
+!c   Lv=(2.501-0.00237*(tcls-273.15))*1.E6
+!c   xle=xle/(ro_surf*Lv)
+!c   fcsv=fcs+.608*xle*tcls
+!c ***************************************************
+!cAM        khfs(i) = (tsol(i)*(1.+RETV*q(i,1))-zxt) *zxmod*cd_h(i)
+!cAM        kqfs(i) = (zxqs-zxq) *zxmod*cd_h(i) * beta(i)
+!cAM
+!cdif khfs est deja w't'_v / heatv(i) = khfs(i) + RETV*zxt*kqfs(i)
+!cAM calcule de Ro = paprs(i,1)/Rd zxt
+!cAM convention >0 vers le bas ds lmdz 
+        khfs(i) = - flux_t(i,1)*zxt*Rd / (RCPD*paprs(i,1))
+        kqfs(i) = - flux_q(i,1)*zxt*Rd / (paprs(i,1))
+!cAM   verifier que khfs et kqfs sont bien de la forme w'l'
+        heatv(i) = khfs(i) + 0.608*zxt*kqfs(i)
+!c a comparer aussi aux sorties de clqh : flux_T/RoCp et flux_q/RoLv
+!cAM        heatv(i) = khfs(i)
+!cAM ustar est en entree
+!cAM        taux = zxu *zxmod*cd_m(i)
+!cAM        tauy = zxv *zxmod*cd_m(i)
+!cAM        ustar(i) = SQRT(taux**2+tauy**2)
+!cAM        ustar(i) = MAX(SQRT(ustar(i)),0.01)
+!c Theta et qT du thermique sans exces (interpolin vers surf)
+!c chgt de niveau du thermique (jeudi 30/12/1999)
+!c (interpolation lineaire avant integration phi_h)
+!cAM        qT_th(i) = zxqs*beta(i) + 4./z(i,1)*(q(i,1)-zxqs*beta(i))
+!cAM        qT_th(i) = max(qT_th(i),q(i,1))
+        qT_th(i) = q2m(i)
+!cn The_th restera la Theta du thermique sans exces jusqu'a 2eme calcul
+!cn reste a regler convention P) pour Theta
+!c        The_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
+!c     -                      + RLvCp*qT_th(i)
+!cAM        Th_th(i) = tsol(i) + 4./z(i,1)*(t(i,1)-tsol(i))
+        Th_th(i) = t2m(i)
+      ENDDO
+!c
+      DO i = 1, knon
+         rhino(i,1) = 0.0   ! Global Richardson
+         check(i) = .TRUE.
+         pblh(i) = z(i,1)   ! on initialise pblh a l'altitude du 1er niveau
+         plcl(i) = 6000.
+!c Lambda = -u*^3 / (alpha.g.kvon.<w'Theta'v>
+         obklen(i) = -t(i,1)*ustar(i)**3/(RG*vk*heatv(i))
+         trmb1(i)   = 0.
+         trmb2(i)   = 0.
+         trmb3(i) = 0.
+      ENDDO
+
+!C
+!c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!C PBL height calculation:
+!C Search for level of pbl. Scan upward until the Richardson number between
+!C the first level and the current level exceeds the "critical" value.
+!C (bonne idee Nu de separer le Ric et l'exces de temp du thermique)
+!c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+      fac = 100.0
+      DO k = 2, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+! pourquoi / niveau 1 (au lieu du sol) et le terme en u*^2 ?
+!ctest     zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = u(i,k)**2+v(i,k)**2
+         zdu2 = max(zdu2,1.0e-20)
+!c Theta_v environnement
+         zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k))
+!c
+!c therm Theta_v sans exces (avec hypothese fausse de H&B, sinon,
+!c passer par Theta_e et virpot)
+!c         zthvu=t(i,1)/s(i,1)*(1.+RETV*q(i,1))
+!cAM         zthvu = Th_th(i)*(1.+RETV*q(i,1))
+         zthvu = Th_th(i)*(1.+RETV*qT_th(i))
+!c  Le Ri par Theta_v
+!cAM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
+!cAM     .               /(zdu2*0.5*(zthvd+zthvu))
+!cAM On a nveau de ref a 2m ???
+         rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu)                                 &
+       &               /(zdu2*0.5*(zthvd+zthvu))
+!c
+         IF (rhino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *                                  &
+       &              (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
+!c test04
+           pblh(i) = pblh(i) + 100.
+           pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *                                  &
+       &              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
+           check(i) = .FALSE.
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+
+!C
+!C Set pbl height to maximum value where computation exceeds number of
+!C layers allowed
+!C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+!C
+!C Improve estimate of pbl height for the unstable points.
+!C Find unstable points (sensible heat flux is upward):
+!C
+      DO i = 1, knon
+      IF (heatv(i) .GT. 0.) THEN
+        unstbl(i) = .TRUE.
+        check(i) = .TRUE.
+      ELSE
+        unstbl(i) = .FALSE.
+        check(i) = .FALSE.
+      ENDIF
+      ENDDO
+!C
+!C For the unstable case, compute velocity scale and the
+!C convective temperature excess:
+!C
+      DO i = 1, knon
+      IF (check(i)) THEN
+        phiminv(i) = (1.-binm*pblh(i)/obklen(i))**onet
+!c ***************************************************
+!c Wm ? et W* ? c'est la formule pour z/h < .1
+!c   ;Calcul de w* ;;
+!c   ;;;;;;;;;;;;;;;;
+!c   w_star=((g/tcls)*fcsv*z(ind))^(1/3.) [ou prendre la premiere approx de h)
+!c   ;; CALCUL DE wm ;;
+!c   ;;;;;;;;;;;;;;;;;;
+!c   ; Ici on considerera que l'on est dans la couche de surf jusqu'a 100m
+!c   ; On prend svt couche de surface=0.1*h mais on ne connait pas h
+!c   ;;;;;;;;;;;Dans la couche de surface
+!c   if (z(ind) le 20) then begin
+!c   Phim=(1.-15.*(z(ind)/L))^(-1/3.)
+!c   wm=u_star/Phim
+!c   ;;;;;;;;;;;En dehors de la couche de surface
+!c   endif else if (z(ind) gt 20) then begin
+!c   wm=(u_star^3+c1*w_star^3)^(1/3.)
+!c   endif
+!c ***************************************************
+        wm(i)= ustar(i)*phiminv(i)
+!c======================================================================
+!cvaleurs de Dominique Lambert de la campagne SEMAPHORE :
+!c <T'^2> = 100.T*^2; <q'^2> = 20.q*^2 a 10m
+!c <Tv'^2> = (1+1.2q).100.T* + 1.2Tv.sqrt(20*100).T*.q* + (.608*Tv)^2*20.q*^2;
+!c et dTetavS = sqrt(<Tv'^2>) ainsi calculee.
+!c avec : T*=<w'T'>_s/w* et q*=<w'q'>/w*
+!c !!! on peut donc utiliser w* pour les fluctuations <-> Lambert
+!c(leur corellation pourrait dependre de beta par ex)
+!c  if fcsv(i,j) gt 0 then begin
+!c    dTetavs=b1*(1.+2.*.608*q_10(i,j))*(fcs(i,j)/wm(i,j))^2+$
+!c    (.608*Thetav_10(i,j))^2*b2*(xle(i,j)/wm(i,j))^2+$
+!c    2.*.608*thetav_10(i,j)*sqrt(b1*b2)*(xle(i,j)/wm(i,j))*(fcs(i,j)/wm(i,j))
+!c    dqs=b2*(xle(i,j)/wm(i,j))^2
+!c    theta_s(i,j)=thetav_10(i,j)+sqrt(dTetavs)
+!c    q_s(i,j)=q_10(i,j)+sqrt(dqs)
+!c  endif else begin
+!c    Theta_s(i,j)=thetav_10(i,j)
+!c    q_s(i,j)=q_10(i,j)
+!c  endelse
+!c======================================================================
+!c
+!cHBTM        therm(i) = heatv(i)*fak/wm(i)
+!c forme Mathieu :
+        q_star = kqfs(i)/wm(i)
+        t_star = khfs(i)/wm(i)
+!IM 091204 BEG
+        IF(1.EQ.0) THEN
+        IF(t_star.LT.0..OR.q_star.LT.0.) THEN
+          print*,'i t_star q_star khfs kqfs wm',i,t_star,q_star,                     &
+       &    khfs(i),kqfs(i),wm(i)
+        ENDIF
+        ENDIF
+!IM 091204 END
+!cAM Nveau cde ref 2m =>
+!cAM        therm(i) = sqrt( b1*(1.+2.*RETV*q(i,1))*t_star**2
+!cAM     +             + (RETV*T(i,1))**2*b2*q_star**2
+!cAM     +             + 2.*RETV*T(i,1)*b212*q_star*t_star
+!cAM     +                 )
+!IM 091204 BEG
+        a1=b1*(1.+2.*RETV*qT_th(i))*t_star**2
+        a2=(RETV*Th_th(i))**2*b2*q_star*q_star
+        a3=2.*RETV*Th_th(i)*b212*q_star*t_star
+        aa=a1+a2+a3
+        IF(1.EQ.0) THEN
+        IF (aa.LT.0.) THEN 
+         print*,'i a1 a2 a3 aa',i,a1,a2,a3,aa
+         print*,'i qT_th Th_th t_star q_star RETV b1 b2 b212',                       &
+       &   i,qT_th(i),Th_th(i),t_star,q_star,RETV,b1,b2,b212
+        ENDIF
+        ENDIF
+!IM 091204 END
+        therm(i) = sqrt( b1*(1.+2.*RETV*qT_th(i))*t_star**2                          &
+       &             + (RETV*Th_th(i))**2*b2*q_star*q_star                           &
+!IM 101204  +             + 2.*RETV*Th_th(i)*b212*q_star*t_star                      &
+       &             + max(0.,2.*RETV*Th_th(i)*b212*q_star*t_star)                   &
+       &                 )
+!c
+!c Theta et qT du thermique (forme H&B) avec exces
+!c (attention, on ajoute therm(i) qui est virtuelle ...)
+!c pourquoi pas sqrt(b1)*t_star ?
+!c        dqs = b2sr*kqfs(i)/wm(i)
+        qT_th(i) = qT_th(i)  + b2sr*q_star
+!cnew on differre le calcul de Theta_e
+!c        The_th(i) = The_th(i) + therm(i) + RLvCp*qT_th(i)
+!c ou:    The_th(i) = The_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
+        rhino(i,1) = 0.0
+      ENDIF
+      ENDDO
+!C
+!c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!C ++ Improve pblh estimate for unstable conditions using the +++++++
+!C ++          convective temperature excess :                +++++++
+!c ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!C
+      DO k = 2, isommet
+      DO i = 1, knon
+      IF (check(i)) THEN
+!ctest     zdu2 = (u(i,k)-u(i,1))**2+(v(i,k)-v(i,1))**2+fac*ustar(i)**2
+         zdu2 = u(i,k)**2+v(i,k)**2
+         zdu2 = max(zdu2,1.0e-20)
+!c Theta_v environnement
+         zthvd=t(i,k)/s(i,k)*(1.+RETV*q(i,k))
+!c
+!c et therm Theta_v (avec hypothese de constance de H&B,
+!c         zthvu=(t(i,1)+therm(i))/s(i,1)*(1.+RETV*q(i,1))
+         zthvu = Th_th(i)*(1.+RETV*qT_th(i)) + therm(i)
+
+!c
+!c  Le Ri par Theta_v
+!cAM Niveau de ref 2m
+!cAM         rhino(i,k) = (z(i,k)-z(i,1))*RG*(zthvd-zthvu)
+!cAM     .               /(zdu2*0.5*(zthvd+zthvu))
+         rhino(i,k) = (z(i,k)-zref)*RG*(zthvd-zthvu)                                 &
+       &               /(zdu2*0.5*(zthvd+zthvu))
+!c
+!c
+         IF (rhino(i,k).GE.ricr) THEN
+           pblh(i) = z(i,k-1) + (z(i,k-1)-z(i,k)) *                                  &
+       &              (ricr-rhino(i,k-1))/(rhino(i,k-1)-rhino(i,k))
+!c test04
+           pblh(i) = pblh(i) + 100.
+           pblT(i) = t(i,k-1) + (t(i,k)-t(i,k-1)) *                                  &
+       &              (pblh(i)-z(i,k-1))/(z(i,k)-z(i,k-1))
+           check(i) = .FALSE.
+!IM 170305 BEG
+      IF(1.EQ.0) THEN
+!c debug print -120;34       -34-        58 et    0;26 wamp
+      if (i.eq.950.or.i.eq.192.or.i.eq.624.or.i.eq.118) then
+            print*,' i,Th_th,Therm,qT :',i,Th_th(i),therm(i),qT_th(i)
+            q_star = kqfs(i)/wm(i)
+            t_star = khfs(i)/wm(i)
+            print*,'q* t*, b1,b2,b212 ',q_star,t_star                                &
+       &            , b1*(1.+2.*RETV*qT_th(i))*t_star**2                             &
+       &            , (RETV*Th_th(i))**2*b2*q_star**2                                &
+       &            , 2.*RETV*Th_th(i)*b212*q_star*t_star
+            print*,'zdu2 ,100.*ustar(i)**2',zdu2 ,fac*ustar(i)**2
+      endif
+      ENDIF !(1.EQ.0) THEN
+!IM 170305 END
+!c             q_star = kqfs(i)/wm(i)
+!c             t_star = khfs(i)/wm(i)
+!c             trmb1(i) = b1*(1.+2.*RETV*q(i,1))*t_star**2
+!c             trmb2(i) = (RETV*T(i,1))**2*b2*q_star**2
+!c Omega now   trmb3(i) = 2.*RETV*T(i,1)*b212*q_star*t_star
+         ENDIF
+      ENDIF
+      ENDDO
+      ENDDO
+!C
+!C Set pbl height to maximum value where computation exceeds number of
+!C layers allowed
+!C
+      DO i = 1, knon
+        if (check(i)) pblh(i) = z(i,isommet)
+      ENDDO
+!C
+!C PBL height must be greater than some minimum mechanical mixing depth
+!C Several investigators have proposed minimum mechanical mixing depth
+!C relationships as a function of the local friction velocity, u*.  We
+!C make use of a linear relationship of the form h = c u* where c=700.
+!C The scaling arguments that give rise to this relationship most often
+!C represent the coefficient c as some constant over the local coriolis
+!C parameter.  Here we make use of the experimental results of Koracin
+!C and Berkowicz (1988) [BLM, Vol 43] for wich they recommend 0.07/f
+!C where f was evaluated at 39.5 N and 52 N.  Thus we use a typical mid
+!C latitude value for f so that c = 0.07/f = 700.
+!C
+      DO i = 1, knon
+        pblmin  = 700.0*ustar(i)
+        pblh(i) = MAX(pblh(i),pblmin)
+!c par exemple :
+        pblT(i) = t(i,2) + (t(i,3)-t(i,2)) *                                         &
+       &              (pblh(i)-z(i,2))/(z(i,3)-z(i,2))
+      ENDDO
+
+!C ********************************************************************
+!C  pblh is now available; do preparation for diffusivity calculation :
+!C ********************************************************************
+      DO i = 1, knon
+        check(i) = .TRUE.
+        Zsat(i)   = .FALSE.
+!c omegafl utilise pour prolongement CAPE
+        omegafl(i) = .FALSE.
+        Cape(i)   = 0.
+        Kape(i)   = 0.
+        EauLiq(i) = 0.
+        CTEI(i)   = 0.
+        pblk(i) = 0.0
+        fak1(i) = ustar(i)*pblh(i)*vk
+!C
+!C Do additional preparation for unstable cases only, set temperature
+!C and moisture perturbations depending on stability.
+!C *** Rq: les formule sont prises dans leur forme CS ***
+        IF (unstbl(i)) THEN
+!cAM Niveau de ref du thermique
+!cAM          zxt=(t(i,1)-z(i,1)*0.5*RG/RCPD/(1.+RVTMP2*q(i,1)))
+!cAM     .         *(1.+RETV*q(i,1))
+          zxt=(Th_th(i)-zref*0.5*RG/RCPD/(1.+RVTMP2*qT_th(i)))                       &
+       &         *(1.+RETV*qT_th(i))
+          phiminv(i) = (1. - binm*pblh(i)/obklen(i))**onet
+          phihinv(i) = sqrt(1. - binh*pblh(i)/obklen(i))
+          wm(i)      = ustar(i)*phiminv(i)
+          fak2(i)    = wm(i)*pblh(i)*vk
+          wstr(i)    = (heatv(i)*RG*pblh(i)/zxt)**onet
+          fak3(i)    = fakn*wstr(i)/wm(i)
+        ENDIF
+!c Computes Theta_e for thermal (all cases : to be modified)
+!c   attention ajout therm(i) = virtuelle
+        The_th(i) = Th_th(i) + therm(i) + RLvCp*qT_th(i)
+!c ou:    The_th(i) = Th_th(i) + sqrt(b1)*khfs(i)/wm(i) + RLvCp*qT_th(i)
+      ENDDO
+
+!C Main level loop to compute the diffusivities and
+!C counter-gradient terms:
+!C
+      DO 1000 k = 2, isommet
+!C
+!C Find levels within boundary layer:
+!C
+        DO i = 1, knon
+          unslev(i) = .FALSE.
+          stblev(i) = .FALSE.
+          zm(i) = z(i,k-1)
+          zp(i) = z(i,k)
+          IF (zkmin.EQ.0.0 .AND. zp(i).GT.pblh(i)) zp(i) = pblh(i)
+          IF (zm(i) .LT. pblh(i)) THEN
+            zmzp = 0.5*(zm(i) + zp(i))
+!C debug
+!c          if (i.EQ.1864) then
+!c             print*,'i,pblh(1864),obklen(1864)',i,pblh(i),obklen(i)
+!c          endif
+
+            zh(i) = zmzp/pblh(i)
+            zl(i) = zmzp/obklen(i)
+            zzh(i) = 0.
+            IF (zh(i).LE.1.0) zzh(i) = (1. - zh(i))**2
+!C
+!C stblev for points zm < plbh and stable and neutral
+!C unslev for points zm < plbh and unstable
+!C
+            IF (unstbl(i)) THEN
+              unslev(i) = .TRUE.
+            ELSE
+              stblev(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+!c        print*,'fin calcul niveaux'
+!C
+!C Stable and neutral points; set diffusivities; counter-gradient
+!C terms zero for stable case:
+!C
+        DO i = 1, knon
+          IF (stblev(i)) THEN
+            IF (zl(i).LE.1.) THEN
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(1. + betas*zl(i))
+            ELSE
+              pblk(i) = fak1(i)*zh(i)*zzh(i)/(betas + zl(i))
+            ENDIF
+!c            pcfm(i,k) = pblk(i)
+!c            pcfh(i,k) = pcfm(i,k)
+          ENDIF
+        ENDDO
+!C
+!C unssrf, unstable within surface layer of pbl
+!C unsout, unstable within outer   layer of pbl
+!C
+        DO i = 1, knon
+          unssrf(i) = .FALSE.
+          unsout(i) = .FALSE.
+          IF (unslev(i)) THEN
+            IF (zh(i).lt.sffrac) THEN
+              unssrf(i) = .TRUE.
+            ELSE
+              unsout(i) = .TRUE.
+            ENDIF
+          ENDIF
+        ENDDO
+!C
+!C Unstable for surface layer; counter-gradient terms zero
+!C
+        DO i = 1, knon
+          IF (unssrf(i)) THEN
+            term = (1. - betam*zl(i))**onet
+            pblk(i) = fak1(i)*zh(i)*zzh(i)*term
+            pr(i) = term/sqrt(1. - betah*zl(i))
+          ENDIF
+        ENDDO
+!c        print*,'fin counter-gradient terms zero'
+!C
+!C Unstable for outer layer; counter-gradient terms non-zero:
+!C
+        DO i = 1, knon
+          IF (unsout(i)) THEN
+            pblk(i) = fak2(i)*zh(i)*zzh(i)
+!c            cgs(i,k) = fak3(i)/(pblh(i)*wm(i))
+!c            cgh(i,k) = khfs(i)*cgs(i,k)
+            pr(i) = phiminv(i)/phihinv(i) + ccon*fak3(i)/fak
+!c            cgq(i,k) = kqfs(i)*cgs(i,k)
+          ENDIF
+        ENDDO
+!c        print*,'fin counter-gradient terms non zero'
+!C
+!C For all unstable layers, compute diffusivities and ctrgrad ter m
+!C
+!c        DO i = 1, knon
+!c        IF (unslev(i)) THEN
+!c            pcfm(i,k) = pblk(i)
+!c            pcfh(i,k) = pblk(i)/pr(i)
+!c etc cf original
+!c        ENDIF
+!c        ENDDO
+!C
+!C For all layers, compute integral info and CTEI
+!C
+        DO i = 1, knon
+        if (check(i).or.omegafl(i)) then
+          if (.not.Zsat(i)) then
+!c            Th2 = The_th(i) - RLvCp*qT_th(i)
+            Th2 = Th_th(i)
+            T2 = Th2*s(i,k)
+!c thermodyn functions
+            zdelta=MAX(0.,SIGN(1.,RTT-T2))
+            qqsat= r2es * FOEEW(T2,zdelta)/pplay(i,k)
+            qqsat=MIN(0.5,qqsat)
+            zcor=1./(1.-retv*qqsat)
+            qqsat=qqsat*zcor
+!c
+            if (qqsat.lt.qT_th(i)) then
+!c on calcule lcl
+              if (k.eq.2) then
+                plcl(i) = z(i,k)
+              else
+                plcl(i) =  z(i,k-1) + (z(i,k-1)-z(i,k)) *                            &
+       &                 (qT_th(i)-qsatbef(i))/(qsatbef(i)-qqsat)
+              endif
+              Zsat(i) = .true.
+              Tbef(i) = T2
+            endif
+!c
+            qsatbef(i) = qqsat    ! bug dans la version orig ???
+          endif
+!camn ???? cette ligne a deja ete faite normalement ?
+        endif
+!c            print*,'hbtm2 i,k=',i,k
+        ENDDO
+ 1000 continue           ! end of level loop
+!IM 170305 BEG
+        IF(1.EQ.0) THEN
+            print*,'hbtm2  ok'
+        ENDIF !(1.EQ.0) THEN
+!IM 170305 END
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/hgardfou.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/hgardfou.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/hgardfou.F	(revision 17)
@@ -0,0 +1,140 @@
+!
+! $Id: hgardfou.F 1795 2013-07-18 08:20:28Z emillour $
+      SUBROUTINE hgardfou (t,tsol,text)
+      USE dimphy
+      USE phys_state_var_mod
+      USE indice_sol_mod
+      IMPLICIT none
+c======================================================================
+c Verifier la temperature
+c======================================================================
+#include "dimensions.h"
+#include "YOMCST.h"
+#include "iniprint.h"
+      REAL t(klon,klev), tsol(klon,nbsrf)
+      CHARACTER*(*) text
+      character (len=20) :: modname = 'hgardfou'
+      character (len=80) :: abort_message
+C
+      INTEGER i, k, nsrf
+      REAL zt(klon)
+      INTEGER jadrs(klon), jbad
+      LOGICAL ok
+c
+      LOGICAL firstcall
+      SAVE firstcall
+      DATA firstcall /.TRUE./
+c$OMP THREADPRIVATE(firstcall)
+
+      IF (firstcall) THEN
+         WRITE(lunout,*) 
+     $  'hgardfou garantit la temperature dans [100,370] K'
+         firstcall = .FALSE.
+c        DO i = 1, klon
+c         WRITE(lunout,*)'i=',i,'rlon=',rlon(i),'rlat=',rlat(i)
+c        ENDDO
+c
+      ENDIF
+c
+      ok = .TRUE.
+      DO k = 1, klev
+         DO i = 1, klon
+            zt(i) = t(i,k)
+         ENDDO
+#ifdef CRAY
+         CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+         IF (zt(i) > 370.) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             WRITE(lunout,*)
+     $       'i,k,temperature,lon,lat,pourc ter,lic,oce,sic =',
+     $       jadrs(i),k,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i)),
+     $       (pctsrf(jadrs(i),nsrf),nsrf=1,nbsrf)
+           ENDDO
+         ENDIF
+#ifdef CRAY
+         CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             WRITE(lunout,*)
+     $       'i,k,temperature,lon,lat,pourc ter,lic,oce,sic =',
+     $       jadrs(i),k,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i)),
+     $       (pctsrf(jadrs(i),nsrf),nsrf=1,nbsrf)
+           ENDDO
+         ENDIF
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+         DO i = 1, klon
+            zt(i) = tsol(i,nsrf)
+         ENDDO
+#ifdef CRAY
+         CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+         IF (zt(i).GT.370.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+            WRITE(lunout,*) 
+     $      'i,nsrf,temperature,lon,lat,pourc ter,lic,oce,sic ='
+     $      ,jadrs(i),nsrf,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i))
+     $      ,pctsrf(jadrs(i),nsrf)
+           ENDDO
+         ENDIF
+#ifdef CRAY
+         CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+            WRITE(lunout,*) 
+     $      'i,nsrf,temperature,lon,lat,pourc ter,lic,oce,sic ='
+     $      ,jadrs(i),nsrf,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i))
+     $      ,pctsrf(jadrs(i),nsrf)
+           ENDDO
+         ENDIF
+      ENDDO
+c
+      IF (.NOT. ok) THEN
+         abort_message= 'hgardfou s arrete '//text
+         CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/hgardfou.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/hgardfou.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/hgardfou.F90	(revision 17)
@@ -0,0 +1,153 @@
+!
+! $Id: hgardfou.F 1795 2013-07-18 08:20:28Z emillour $
+      SUBROUTINE hgardfou (t,tsol,text)
+      USE dimphy
+      USE phys_state_var_mod
+      USE indice_sol_mod
+      IMPLICIT none
+!c======================================================================
+!c Verifier la temperature
+!c======================================================================
+#include "dimensions.h"
+#include "YOMCST.h"
+#include "iniprint.h"
+      REAL t(klon,klev), tsol(klon,nbsrf)
+      CHARACTER*(*) text
+      character (len=20) :: modname = 'hgardfou'
+      character (len=80) :: abort_message
+!C
+      INTEGER i, k, nsrf
+      REAL zt(klon)
+      INTEGER jadrs(klon), jbad
+      LOGICAL ok
+!c
+      LOGICAL firstcall
+      SAVE firstcall
+      DATA firstcall /.TRUE./
+!$OMP THREADPRIVATE(firstcall)
+
+! Lluis
+      INTEGER                                            :: lp
+      lp = 885
+
+      IF (firstcall) THEN
+         WRITE(lunout,*)                                                             &
+       &  'hgardfou garantit la temperature dans [100,370] K'
+         firstcall = .FALSE.
+!c        DO i = 1, klon
+!c         WRITE(lunout,*)'i=',i,'rlon=',rlon(i),'rlat=',rlat(i)
+!c        ENDDO
+!c
+      ENDIF
+!c
+      ok = .TRUE.
+      DO k = 1, klev
+         DO i = 1, klon
+            zt(i) = t(i,k)
+         ENDDO
+#ifdef CRAY
+         CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+         IF (zt(i) > 370.) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             WRITE(lunout,*)                                                         &
+       &       'i,k,temperature,lon,lat,pourc ter,lic,oce,sic =',                    &
+       &       jadrs(i),k,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i)),                &
+       &       (pctsrf(jadrs(i),nsrf),nsrf=1,nbsrf)
+           ENDDO
+         ENDIF
+#ifdef CRAY
+         CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+             WRITE(lunout,*)                                                         &
+       &       'i,k,temperature,lon,lat,pourc ter,lic,oce,sic =',                    &
+       &       jadrs(i),k,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i)),                &
+       &       (pctsrf(jadrs(i),nsrf),nsrf=1,nbsrf)
+           ENDDO
+         ENDIF
+      ENDDO
+!c
+      DO nsrf = 1, nbsrf
+         PRINT *,'  Lluis nsrf: ',nsrf
+         DO i = 1, klon
+            IF (pctsrf(i,nsrf) > 0.) THEN
+              zt(i) = tsol(i,nsrf)
+            ELSE
+              zt(i) = 300.0
+            END IF
+         ENDDO
+#ifdef CRAY
+         CALL WHENFGT(klon, zt, 1, 370.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+         IF (zt(i).GT.370.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+            WRITE(lunout,*)                                                          &
+       &      'i,nsrf,temperature,lon,lat,pourc ter,lic,oce,sic ='                   &
+       &      ,jadrs(i),nsrf,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i))              &
+       &      ,pctsrf(jadrs(i),nsrf)
+           ENDDO
+         ENDIF
+#ifdef CRAY
+         CALL WHENFLT(klon, zt, 1, 100.0, jadrs, jbad)
+#else
+         jbad = 0
+         DO i = 1, klon
+!         IF (zt(i).LT.100.0) THEN
+         IF (zt(i).LT.50.0) THEN
+            jbad = jbad + 1
+            jadrs(jbad) = i
+         ENDIF
+         ENDDO
+#endif
+         IF (jbad .GT. 0) THEN
+           ok = .FALSE.
+           DO i = 1, jbad
+            WRITE(lunout,*)                                                          &
+       &      'i,nsrf,temperature,lon,lat,pourc ter,lic,oce,sic ='                   &
+       &      ,jadrs(i),nsrf,zt(jadrs(i)),rlon(jadrs(i)),rlat(jadrs(i))              &
+       &      ,pctsrf(jadrs(i),nsrf)
+             PRINT *,'    Lluis: nsrf k isfc tsol zt pctsrf_____'
+             DO k=1,nbsrf
+               PRINT *,'    ',nsrf,k,jadrs(i),tsol(jadrs(i),k),zt(jadrs(i)),pctsrf(jadrs(i),k)
+             END DO
+           ENDDO
+         ENDIF
+      ENDDO
+!c
+      IF (.NOT. ok) THEN
+         abort_message= 'hgardfou s arrete '//text
+         CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/hines_gwd.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/hines_gwd.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/hines_gwd.F	(revision 17)
@@ -0,0 +1,2080 @@
+!
+! $Id: hines_gwd.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE HINES_GWD(NLON,NLEV,DTIME,paphm1x, papm1x,
+     I      rlat,tx,ux,vx,
+     O      zustrhi,zvstrhi,
+     O      d_t_hin, d_u_hin, d_v_hin)
+
+C ########################################################################
+C Parametrization of the momentum flux deposition due to a broad band 
+C spectrum of gravity waves, following Hines (1997a,b), as coded by 
+C McLANDRESS (1995). Modified by McFARLANE and MANZINI (1995-1997) 
+C                 MAECHAM model stand alone version
+C ########################################################################
+C 
+C
+         USE dimphy
+         implicit none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOEGWD.h"
+#include "YOMCST.h"
+
+      INTEGER NAZMTH
+      PARAMETER(NAZMTH=8)
+
+C     INPUT ARGUMENTS.
+C     ----- ----------
+C
+C  - 2D
+C  PAPHM1   : HALF LEVEL PRESSURE (T-DT)
+C  PAPM1    : FULL LEVEL PRESSURE (T-DT)
+C  PTM1     : TEMPERATURE (T-DT)
+C  PUM1     : ZONAL WIND (T-DT)
+C  PVM1     : MERIDIONAL WIND (T-DT)
+C
+
+C     REFERENCE.
+C     ----------
+C         SEE MODEL DOCUMENTATION
+C
+C     AUTHOR.
+C     -------
+C
+C      N. MCFARLANE   DKRZ-HAMBURG   MAY 1995
+C      STAND ALONE E. MANZINI MPI-HAMBURG FEBRUARY 1997
+C
+C      BASED ON A COMBINATION OF THE OROGRAPHIC SCHEME BY N.MCFARLANE 1987
+C      AND THE HINES SCHEME AS CODED BY C. MCLANDRESS 1995.                       
+C
+C
+C
+cym      INTEGER KLEVM1
+C
+      REAL PAPHM1(klon,klev+1), PAPM1(klon,KLEV)  
+      REAL PTM1(klon,KLEV), PUM1(klon,KLEV), PVM1(klon,KLEV)
+      REAL PRFLUX(klon)
+C1
+C1
+C1
+      REAL RLAT(klon),COSLAT(KLON)
+C 
+      REAL TH(klon,KLEV),
+     2     UTENDGW(klon,KLEV), VTENDGW(klon,KLEV), 
+     3     PRESSG(klon),
+     4     UHS(klon,KLEV),     VHS(klon,KLEV), ZPR(klon)
+
+C     * VERTICAL POSITIONING ARRAYS.
+
+      REAL SGJ(klon,KLEV),     SHJ(klon,KLEV),    
+     1     SHXKJ(klon,KLEV),   DSGJ(klon,KLEV)
+
+C     * LOGICAL SWITCHES TO CONTROL ROOF DRAG, ENVELOP GW DRAG AND
+C     * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG.
+C     * LOZPR IS TRUE FOR ZPR ENHANCEMENT
+
+
+C     * WORK ARRAYS.
+
+      REAL M_ALPHA(klon,KLEV,NAZMTH),     V_ALPHA(klon,KLEV,NAZMTH),
+     1     SIGMA_ALPHA(klon,KLEV,NAZMTH), 
+     1     SIGSQH_ALPHA(klon,KLEV,NAZMTH),
+     2     DRAG_U(klon,KLEV),   DRAG_V(klon,KLEV),  FLUX_U(klon,KLEV),
+     3     FLUX_V(klon,KLEV),   HEAT(klon,KLEV),    DIFFCO(klon,KLEV),
+     4     BVFREQ(klon,KLEV),   DENSITY(klon,KLEV), SIGMA_T(klon,KLEV),
+     5     VISC_MOL(klon,KLEV), ALT(klon,KLEV),      
+     6     SIGSQMCW(klon,KLEV,NAZMTH), 
+     6     SIGMATM(klon,KLEV), 
+     7     AK_ALPHA(klon,NAZMTH),       K_ALPHA(klon,NAZMTH),
+     8     MMIN_ALPHA(klon,NAZMTH),     I_ALPHA(klon,NAZMTH),
+     9     RMSWIND(klon), BVFBOT(klon), DENSBOT(klon)
+      REAL  SMOOTHR1(klon,KLEV), SMOOTHR2(klon,KLEV)
+      REAL  SIGALPMC(klon,KLEV,NAZMTH)      
+      REAL  F2MOD(klon,KLEV)
+      
+C     * THES ARE THE INPUT PARAMETERS FOR HINES ROUTINE AND
+C     * ARE SPECIFIED IN ROUTINE HINES_SETUP. SINCE THIS IS CALLED
+C     * ONLY AT FIRST CALL TO THIS ROUTINE THESE VARIABLES MUST BE SAVED
+C     * FOR USE AT SUBSEQUENT CALLS. THIS CAN BE AVOIDED BY CALLING
+C     * HINES_SETUP IN MAIN PROGRAM AND PASSING THE PARAMETERS AS
+C     * SUBROUTINE ARGUEMENTS.
+C
+
+      REAL    RMSCON
+      INTEGER NMESSG, IPRINT, ILRMS
+      INTEGER IFL
+C
+      INTEGER  NAZ,ICUTOFF,NSMAX,IHEATCAL
+      REAL  SLOPE,F1,F2,F3,F5,F6,KSTAR(KLON),ALT_CUTOFF,SMCO
+C
+C    PROVIDED AS INPUT
+C
+      integer nlon,nlev
+
+      real dtime
+      real paphm1x(nlon,nlev+1), papm1x(nlon,nlev)
+      real ux(nlon,nlev), vx(nlon,nlev), tx(nlon,nlev)
+c
+c     VARIABLES FOR OUTPUT
+c
+
+      real d_t_hin(nlon,nlev),d_u_hin(nlon,nlev),d_v_hin(nlon,nlev)
+      real zustrhi(nlon),zvstrhi(nlon) 
+
+C
+C     * LOGICAL SWITCHES TO CONTROL PRECIP ENHANCEMENT AND
+C     * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG.
+C     * LOZPR IS TRUE FOR ZPR ENHANCEMENT
+C  
+      LOGICAL LOZPR, LORMS(klon)
+C
+C  LOCAL PARAMETERS TO MAKE THINGS WORK (TEMPORARY VARIABLE)
+
+      REAL RHOH2O,ZPCONS,RGOCP,ZLAT,DTTDSF,RATIO,HSCAL
+      INTEGER I,J,L,JL,JK,LE,LREF,LREFP,LEVBOT
+C
+C  DATA PARAMETERS NEEDED, EXPLAINED LATER
+
+      REAL V0,VMIN,DMPSCAL,TAUFAC,HMIN,APIBT,CPART,FCRIT
+      REAL PCRIT,PCONS
+      INTEGER IPLEV,IERROR
+   
+C
+C      
+C     PRINT *,' IT IS STARTED HINES GOING ON...'
+C
+C
+C
+C
+C*    COMPUTATIONAL CONSTANTS.
+C     ------------- ----------
+C
+C
+      d_t_hin(:,:)=0.
+      
+      RHOH2O=1000.    
+      ZPCONS = (1000.*86400.)/RHOH2O
+cym      KLEVM1=KLEV-1
+C
+
+        do jl=kidia,kfdia
+        PAPHM1(JL,1) = paphm1x(JL,klev+1)
+          do jk=1,klev      
+          le=klev+1-jk
+          PAPHM1(JL,JK+1) =  paphm1x(JL,le) 
+          PAPM1(JL,JK) = papm1x(JL,le)
+          PTM1(JL,JK) = tx(JL,le)
+          PUM1(JL,JK) = ux(JL,le)
+          PVM1(JL,JK) = vx(JL,le)
+          enddo
+        enddo
+C
+  100 CONTINUE
+C
+C    Define constants and arrays needed for the ccc/mam gwd scheme
+C    *Constants:
+
+      RGOCP=RD/RCPD
+      LREFP=KLEV-1
+      LREF=KLEV-2
+C1
+C1    *Arrays
+C1
+      DO 2101 JK=1,KLEV
+      DO 2102 JL=KIDIA,KFDIA
+      SHJ(JL,JK)=PAPM1(JL,JK)/PAPHM1(JL,klev+1)
+      SGJ(JL,JK)=PAPM1(JL,JK)/PAPHM1(JL,klev+1)
+      DSGJ(JL,JK)=(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))/PAPHM1(JL,klev+1)
+      SHXKJ(JL,JK)=(PAPM1(JL,JK)/PAPHM1(JL,klev+1))**RGOCP 
+      TH(JL,JK)= PTM1(JL,JK)
+ 2102 CONTINUE
+ 2101 CONTINUE    
+      
+CC
+      DO 211 JL=KIDIA,KFDIA
+      PRESSG(JL)=PAPHM1(JL,klev+1)
+  211 CONTINUE
+C
+C
+      DO 301 JL=KIDIA,KFDIA
+      PRFLUX(JL) = 0.0
+      ZPR(JL)=ZPCONS*PRFLUX(JL)
+      ZLAT=(RLAT(JL)/180.)*RPI
+      COSLAT(Jl)=COS(ZLAT)    
+  301 CONTINUE
+C
+C
+  400 CONTINUE
+C  
+C
+C
+C
+*/#########################################################################
+*/
+*/
+C
+C     * AUG. 14/95 - C. MCLANDRESS.
+C     * SEP.    95   N. MCFARLANE.
+C
+C     * THIS ROUTINE CALCULATES THE HORIZONTAL WIND TENDENCIES
+C     * DUE TO MCFARLANE'S OROGRAPHIC GW DRAG SCHEME, HINES'
+C     * DOPPLER SPREAD SCHEME FOR "EXTROWAVES" AND ADDS ON
+C     * ROOF DRAG. IT IS BASED ON THE ROUTINE GWDFLX8.
+C
+C     * LREFP IS THE INDEX OF THE MODEL LEVEL BELOW THE REFERENCE LEVEL
+C     * I/O ARRAYS PASSED FROM MAIN.
+C     * (PRESSG = SURFACE PRESSURE)
+C
+C
+C
+C
+C     * CONSTANTS VALUES DEFINED IN DATA STATEMENT ARE :
+C     * VMIN     = MIMINUM WIND IN THE DIRECTION OF REFERENCE LEVEL
+C     *            WIND BEFORE WE CONSIDER BREAKING TO HAVE OCCURED.
+C     * DMPSCAL  = DAMPING TIME FOR GW DRAG IN SECONDS.
+C     * TAUFAC   = 1/(LENGTH SCALE).
+C     * HMIN     = MIMINUM ENVELOPE HEIGHT REQUIRED TO PRODUCE GW DRAG.
+C     * V0       = VALUE OF WIND THAT APPROXIMATES ZERO.
+
+
+      DATA    VMIN  /    5.0 /, V0       / 1.E-10 /,
+     1        TAUFAC/  5.E-6 /, HMIN     /   40000. /,
+     3        DMPSCAL  / 6.5E+6 /, APIBT / 1.5708 /,
+     4        CPART /    0.7 /, FCRIT    / 1. /
+
+C     * HINES EXTROWAVE GWD CONSTANTS DEFINED IN DATA STATEMENT ARE:
+C     * RMSCON = ROOT MEAN SQUARE GRAVITY WAVE WIND AT LOWEST LEVEL (M/S).
+C     * NMESSG  = UNIT NUMBER FOR PRINTED MESSAGES.
+C     * IPRINT  = 1 TO DO PRINT OUT SOME HINES ARRAYS.
+C     * IFL     = FIRST CALL FLAG TO HINES_SETUP ("SAVE" IT)
+C     * PCRIT = CRITICAL VALUE OF ZPR (MM/D)
+C     * IPLEV = LEVEL OF APPLICATION OF PRCIT
+C     * PCONS = FACTOR OF ZPR ENHANCEMENT
+C
+
+      DATA PCRIT / 5. /, PCONS / 4.75 /
+
+      IPLEV = LREFP-1
+C
+      DATA    RMSCON  / 1.00 /
+     1        IPRINT   /  2  /, NMESSG  /   6   /
+      DATA    IFL / 0 /
+C
+      LOZPR = .FALSE.
+C
+C-----------------------------------------------------------------------
+C
+C
+C
+C     * SET ERROR FLAG
+
+      IERROR = 0
+
+C     * SPECIFY VARIOUS PARAMETERS FOR HINES ROUTINE AT VERY FIRST CALL.
+C     * (NOTE THAT ARRAY K_ALPHA IS SPECIFIED SO MAKE SURE THAT
+C     * IT IS NOT OVERWRITTEN LATER ON).
+C
+        CALL HINES_SETUP (NAZ,SLOPE,F1,F2,F3,F5,F6,KSTAR,
+     1                    ICUTOFF,ALT_CUTOFF,SMCO,NSMAX,IHEATCAL,
+     2                   K_ALPHA,IERROR,NMESSG,klon,NAZMTH,COSLAT)
+        IF (IERROR.NE.0)  GO TO 999
+C
+C     * START GWD CALCULATIONS.
+
+      LREF  = LREFP-1
+
+C
+      DO 105 J=1,NAZMTH
+      DO 105 L=1,KLEV
+      DO 105 I=kidia,klon
+        SIGSQMCW(I,L,J) = 0.
+  105 CONTINUE
+c
+
+
+C     * INITIALIZE NECESSARY ARRAYS.
+C
+      DO 120 L=1,KLEV
+      DO 120 I=KIDIA,KFDIA
+        UTENDGW(I,L) = 0.
+        VTENDGW(I,L) = 0.
+
+        UHS(I,L) = 0.
+        VHS(I,L) = 0.
+
+ 120  CONTINUE
+C
+C     * IF USING HINES SCHEME THEN CALCULATE B V FREQUENCY AT ALL POINTS
+C     * AND SMOOTH BVFREQ.
+
+        DO 130 L=2,KLEV
+        DO 130 I=KIDIA,KFDIA
+          DTTDSF=(TH(I,L)/SHXKJ(I,L)-TH(I,L-1)/
+     1            SHXKJ(I,L-1))/(SHJ(I,L)-SHJ(I,L-1))
+          DTTDSF=MIN(DTTDSF, -5./SGJ(I,L))
+          BVFREQ(I,L)=SQRT(-DTTDSF*SGJ(I,L)*(SGJ(I,L)**RGOCP)/RD)
+     1                     *RG/PTM1(I,L)
+  130   CONTINUE
+        DO 135 L=1,KLEV
+        DO 135 I=KIDIA,KFDIA
+          IF(L.EQ.1)                        THEN
+            BVFREQ(I,L) = BVFREQ(I,L+1)
+          ENDIF
+          IF(L.GT.1)                        THEN
+            RATIO=5.*LOG(SGJ(I,L)/SGJ(I,L-1))
+            BVFREQ(I,L) = (BVFREQ(I,L-1) + RATIO*BVFREQ(I,L))
+     1                       /(1.+RATIO)
+          ENDIF
+  135   CONTINUE
+C
+C
+  300 CONTINUE
+
+C     * CALCULATE GW DRAG DUE TO HINES' EXTROWAVES
+C     * SET MOLECULAR VISCOSITY TO A VERY SMALL VALUE.
+C     * IF THE MODEL TOP IS GREATER THAN 100 KM THEN THE ACTUAL
+C     * VISCOSITY COEFFICIENT COULD BE SPECIFIED HERE.
+
+      DO 310 L=1,KLEV
+      DO 310 I=KIDIA,KFDIA
+         VISC_MOL(I,L) = 1.5E-5
+         DRAG_U(I,L) = 0.
+         DRAG_V(I,L) = 0.
+         FLUX_U(I,L) = 0.
+         FLUX_V(I,L) = 0.
+         HEAT(I,L)   = 0.
+         DIFFCO(I,L) = 0.
+ 310  CONTINUE
+
+C     * ALTITUDE AND DENSITY AT BOTTOM.
+
+      DO 330 I=KIDIA,KFDIA
+         HSCAL = RD * PTM1(I,KLEV) / RG
+         DENSITY(I,KLEV) = SGJ(I,KLEV) * PRESSG(I) / (RG*HSCAL)
+         ALT(I,KLEV) = 0.
+  330 CONTINUE
+
+C     * ALTITUDE AND DENSITY AT REMAINING LEVELS.
+
+      DO 340 L=KLEV-1,1,-1
+      DO 340 I=KIDIA,KFDIA
+         HSCAL = RD * PTM1(I,L) / RG
+         ALT(I,L) = ALT(I,L+1) + HSCAL * DSGJ(I,L) / SGJ(I,L)
+         DENSITY(I,L) = SGJ(I,L) * PRESSG(I) / (RG*HSCAL)
+  340 CONTINUE
+
+C
+C     * INITIALIZE SWITCHES FOR HINES GWD CALCULATION
+C
+      ILRMS = 0
+C
+      DO 345 I=KIDIA,KFDIA 
+      LORMS(I) = .FALSE.
+  345 CONTINUE 
+C
+C
+C     * DEFILE BOTTOM LAUNCH LEVEL
+C
+      LEVBOT = IPLEV
+C
+C     * BACKGROUND WIND MINUS VALUE AT BOTTOM LAUNCH LEVEL.
+C
+      DO 351 L=1,LEVBOT
+      DO 351 I=KIDIA,KFDIA 
+      UHS(I,L) = PUM1(I,L) - PUM1(I,LEVBOT)
+      VHS(I,L) = PVM1(I,L) - PVM1(I,LEVBOT)
+  351 CONTINUE
+C
+C     * SPECIFY ROOT MEAN SQUARE WIND AT BOTTOM LAUNCH LEVEL.
+C
+       DO 355 I=KIDIA,KFDIA 
+       RMSWIND(I) = RMSCON
+  355  CONTINUE
+
+      IF (LOZPR) THEN
+        DO 350 I=KIDIA,KFDIA 
+        IF (ZPR(I) .GT. PCRIT) THEN
+          RMSWIND(I) = RMSCON
+     >                +( (ZPR(I)-PCRIT)/ZPR(I) )*PCONS
+        ENDIF
+  350   CONTINUE
+      ENDIF
+C
+      DO 356 I=KIDIA,KFDIA 
+      IF (RMSWIND(I) .GT. 0.0) THEN
+      ILRMS = ILRMS+1
+      LORMS(I) = .TRUE.
+      ENDIF
+  356 CONTINUE
+C
+C     * CALCULATE GWD (NOTE THAT DIFFUSION COEFFICIENT AND
+C     * HEATING RATE ONLY CALCULATED IF IHEATCAL = 1).
+C
+      IF ( ILRMS.GT.0 )       THEN                    
+C
+      CALL HINES_EXTRO0 (DRAG_U,DRAG_V,HEAT,DIFFCO,FLUX_U,FLUX_V,
+     1                   UHS,VHS,BVFREQ,DENSITY,VISC_MOL,ALT,
+     2                   RMSWIND,K_ALPHA,M_ALPHA,V_ALPHA,
+     3                   SIGMA_ALPHA,SIGSQH_ALPHA,AK_ALPHA,
+     4                   MMIN_ALPHA,I_ALPHA,SIGMA_T,DENSBOT,BVFBOT,
+     5                   1,IHEATCAL,ICUTOFF,IPRINT,NSMAX,
+     6                   SMCO,ALT_CUTOFF,KSTAR,SLOPE,
+     7                   F1,F2,F3,F5,F6,NAZ,SIGSQMCW,SIGMATM,
+     8                   KIDIA,klon,1,LEVBOT,KLON,KLEV,NAZMTH,
+     9                   LORMS,SMOOTHR1,SMOOTHR2,
+     9                   SIGALPMC,F2MOD)
+
+C     * ADD ON HINES' GWD TENDENCIES TO OROGRAPHIC TENDENCIES AND
+C     * APPLY HINES' GW DRAG ON (UROW,VROW) WORK ARRAYS.
+
+      DO 360 L=1,KLEV
+      DO 360 I=KIDIA,KFDIA
+         UTENDGW(I,L) = UTENDGW(I,L) + DRAG_U(I,L)
+         VTENDGW(I,L) = VTENDGW(I,L) + DRAG_V(I,L)
+  360 CONTINUE
+C
+
+C     * END OF HINES CALCULATIONS.
+C
+      ENDIF
+C
+  500 CONTINUE
+
+
+C-----------------------------------------------------------------------
+C
+        do jl=kidia,kfdia
+          zustrhi(jl)=FLUX_U(jl,1)
+          zvstrhi(jl)=FLUX_v(jl,1)
+          do jk=1,klev
+          le=klev-jk+1
+          d_u_hin(jl,JK) =  UTENDGW(jl,le) * dtime
+          d_v_hin(jl,JK) =  VTENDGW(jl,le) * dtime
+          enddo
+        enddo
+
+c     PRINT *,'UTENDGW:',UTENDGW
+
+C     PRINT *,' HINES HAS BEEN COMPLETED (LONG ISNT IT...)'
+
+      RETURN
+ 999  CONTINUE
+
+C     * IF ERROR DETECTED THEN ABORT.
+
+      WRITE (NMESSG,6000)
+      WRITE (NMESSG,6010) IERROR
+ 6000 FORMAT (/' EXECUTION ABORTED IN GWDOREXV')
+ 6010 FORMAT ('     ERROR FLAG =',I4)
+
+C
+      RETURN
+      END
+*/
+*/
+
+
+      SUBROUTINE HINES_EXTRO0 (DRAG_U,DRAG_V,HEAT,DIFFCO,FLUX_U,FLUX_V,
+     1                         VEL_U,VEL_V,BVFREQ,DENSITY,VISC_MOL,ALT,
+     2                         RMSWIND,K_ALPHA,M_ALPHA,V_ALPHA,
+     3                         SIGMA_ALPHA,SIGSQH_ALPHA,AK_ALPHA,
+     4                         MMIN_ALPHA,I_ALPHA,SIGMA_T,DENSB,BVFB,
+     5                         IORDER,IHEATCAL,ICUTOFF,IPRINT,NSMAX,
+     6                         SMCO,ALT_CUTOFF,KSTAR,SLOPE,
+     7                         F1,F2,F3,F5,F6,NAZ,SIGSQMCW,SIGMATM,
+     8                         IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH,
+     9                         LORMS,SMOOTHR1,SMOOTHR2,
+     9                         SIGALPMC,F2MOD)
+
+       implicit none
+C
+C  Main routine for Hines' "extrowave" gravity wave parameterization based
+C  on Hines' Doppler spread theory. This routine calculates zonal
+C  and meridional components of gravity wave drag, heating rates
+C  and diffusion coefficient on a longitude by altitude grid.
+C  No "mythical" lower boundary region calculation is made so it
+C  is assumed that lowest level winds are weak (i.e, approximately zero).
+C
+C  Aug. 13/95 - C. McLandress
+C  SEPT. /95  - N.McFarlane
+C
+C  Modifications:
+C
+C  Output arguements:
+C
+C     * DRAG_U = zonal component of gravity wave drag (m/s^2).
+C     * DRAG_V = meridional component of gravity wave drag (m/s^2).
+C     * HEAT   = gravity wave heating (K/sec).
+C     * DIFFCO = diffusion coefficient (m^2/sec)
+C     * FLUX_U = zonal component of vertical momentum flux (Pascals)
+C     * FLUX_V = meridional component of vertical momentum flux (Pascals)
+C
+C  Input arguements:
+C
+C     * VEL_U      = background zonal wind component (m/s).
+C     * VEL_V      = background meridional wind component (m/s).
+C     * BVFREQ     = background Brunt Vassala frequency (radians/sec).
+C     * DENSITY    = background density (kg/m^3) 
+C     * VISC_MOL   = molecular viscosity (m^2/s)
+C     * ALT        = altitude of momentum, density, buoyancy levels (m)
+C     *              (NOTE: levels ordered so that ALT(I,1) > ALT(I,2), etc.)
+C     * RMSWIND   = root mean square gravity wave wind at lowest level (m/s).
+C     * K_ALPHA    = horizontal wavenumber of each azimuth (1/m).
+C     * IORDER	   = 1 means vertical levels are indexed from top down 
+C     *              (i.e., highest level indexed 1 and lowest level NLEVS);
+C     *           .NE. 1 highest level is index NLEVS.
+C     * IHEATCAL   = 1 to calculate heating rates and diffusion coefficient.
+C     * IPRINT     = 1 to print out various arrays.
+C     * ICUTOFF    = 1 to exponentially damp GWD, heating and diffusion 
+C     *              arrays above ALT_CUTOFF; otherwise arrays not modified.
+C     * ALT_CUTOFF = altitude in meters above which exponential decay applied.
+C     * SMCO       = smoothing factor used to smooth cutoff vertical 
+C     *              wavenumbers and total rms winds in vertical direction
+C     *              before calculating drag or heating
+C     *              (SMCO >= 1 ==> 1:SMCO:1 stencil used).
+C     * NSMAX      = number of times smoother applied ( >= 1),
+C     *            = 0 means no smoothing performed.
+C     * KSTAR      = typical gravity wave horizontal wavenumber (1/m).
+C     * SLOPE      = slope of incident vertical wavenumber spectrum
+C     *              (SLOPE must equal 1., 1.5 or 2.).
+C     * F1 to F6   = Hines's fudge factors (F4 not needed since used for
+C     *              vertical flux of vertical momentum).
+C     * NAZ        = actual number of horizontal azimuths used.
+C     * IL1        = first longitudinal index to use (IL1 >= 1).
+C     * IL2        = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * LEV1       = index of first level for drag calculation.
+C     * LEV2       = index of last level for drag calculation 
+C     *              (i.e., LEV1 < LEV2 <= NLEVS).
+C     * NLONS      = number of longitudes.
+C     * NLEVS      = number of vertical levels.
+C     * NAZMTH     = azimuthal array dimension (NAZMTH >= NAZ).
+C 
+C  Work arrays.
+C
+C     * M_ALPHA      = cutoff vertical wavenumber (1/m).
+C     * V_ALPHA      = wind component at each azimuth (m/s) and if IHEATCAL=1
+C     *                holds vertical derivative of cutoff wavenumber.
+C     * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
+C     * SIGSQH_ALPHA = portion of wind variance from waves having wave
+C     *                normals in the alpha azimuth (m/s).
+C     * SIGMA_T      = total rms horizontal wind (m/s).
+C     * AK_ALPHA     = spectral amplitude factor at each azimuth 
+C     *                (i.e.,{AjKj}) in m^4/s^2.
+C     * I_ALPHA      = Hines' integral.
+C     * MMIN_ALPHA   = minimum value of cutoff wavenumber.
+C     * DENSB        = background density at bottom level.
+C     * BVFB         = buoyancy frequency at bottom level and
+C     *                work array for ICUTOFF = 1.
+C
+C     * LORMS       = .TRUE. for drag computation 
+C
+      INTEGER  NAZ, NLONS, NLEVS, NAZMTH, IL1, IL2, LEV1, LEV2
+      INTEGER  ICUTOFF, NSMAX, IORDER, IHEATCAL, IPRINT
+      REAL  KSTAR(NLONS), F1, F2, F3, F5, F6, SLOPE
+      REAL  ALT_CUTOFF, SMCO
+      REAL  DRAG_U(NLONS,NLEVS),   DRAG_V(NLONS,NLEVS) 
+      REAL  HEAT(NLONS,NLEVS),     DIFFCO(NLONS,NLEVS)
+      REAL  FLUX_U(NLONS,NLEVS),   FLUX_V(NLONS,NLEVS)
+      REAL  VEL_U(NLONS,NLEVS),    VEL_V(NLONS,NLEVS)
+      REAL  BVFREQ(NLONS,NLEVS),   DENSITY(NLONS,NLEVS)
+      REAL  VISC_MOL(NLONS,NLEVS), ALT(NLONS,NLEVS)
+      REAL  RMSWIND(NLONS),       BVFB(NLONS),   DENSB(NLONS)
+      REAL  SIGMA_T(NLONS,NLEVS), SIGSQMCW(NLONS,NLEVS,NAZMTH)
+      REAL  SIGMA_ALPHA(NLONS,NLEVS,NAZMTH), SIGMATM(NLONS,NLEVS)
+      REAL  SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH), V_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  AK_ALPHA(NLONS,NAZMTH),      K_ALPHA(NLONS,NAZMTH)
+      REAL  MMIN_ALPHA(NLONS,NAZMTH) ,   I_ALPHA(NLONS,NAZMTH)
+      REAL  SMOOTHR1(NLONS,NLEVS), SMOOTHR2(NLONS,NLEVS)
+      REAL  SIGALPMC(NLONS,NLEVS,NAZMTH)
+      REAL  F2MOD(NLONS,NLEVS)
+C
+      LOGICAL LORMS(NLONS)
+C
+C  Internal variables.
+C
+      INTEGER  LEVBOT, LEVTOP, I, N, L, LEV1P, LEV2M
+      INTEGER  ILPRT1, ILPRT2
+C----------------------------------------------------------------------- 
+C
+C     PRINT *,' IN HINES_EXTRO0'
+      LEV1P = LEV1 + 1
+      LEV2M = LEV2 - 1
+C
+C  Index of lowest altitude level (bottom of drag calculation).
+C
+      LEVBOT = LEV2
+      LEVTOP = LEV1
+      IF (IORDER.NE.1)  THEN
+      write(6,1)
+   1  format(2x,' error: IORDER NOT ONE! ')
+      END IF
+C
+C  Buoyancy and density at bottom level.
+C
+      DO 10 I = IL1,IL2
+        BVFB(I)  = BVFREQ(I,LEVBOT)
+        DENSB(I) = DENSITY(I,LEVBOT)
+ 10   CONTINUE
+C
+C  initialize some variables
+C
+      DO 20 N = 1,NAZ
+      DO 20 L=LEV1,LEV2
+      DO 20 I=IL1,IL2
+      M_ALPHA(I,L,N) = 0.0
+  20  CONTINUE
+      DO 21 L=LEV1,LEV2
+      DO 21 I=IL1,IL2
+      SIGMA_T(I,L) = 0.0
+  21  CONTINUE
+      DO 22 N = 1,NAZ
+      DO 22 I=IL1,IL2
+      I_ALPHA(I,N) = 0.0
+  22  CONTINUE 
+C
+C  Compute azimuthal wind components from zonal and meridional winds.
+C
+      CALL HINES_WIND ( V_ALPHA, 
+     ^                  VEL_U, VEL_V, NAZ,
+     ^                  IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH )
+C
+C  Calculate cutoff vertical wavenumber and velocity variances.
+C
+      CALL HINES_WAVNUM ( M_ALPHA, SIGMA_ALPHA, SIGSQH_ALPHA, SIGMA_T,
+     ^                    AK_ALPHA, V_ALPHA, VISC_MOL, DENSITY, DENSB,
+     ^                    BVFREQ, BVFB, RMSWIND, I_ALPHA, MMIN_ALPHA,
+     ^                    KSTAR, SLOPE, F1, F2, F3, NAZ, LEVBOT,
+     ^                    LEVTOP,IL1,IL2,NLONS,NLEVS,NAZMTH, SIGSQMCW,
+     ^                    SIGMATM,LORMS,SIGALPMC,F2MOD)
+C
+C  Smooth cutoff wavenumbers and total rms velocity in the vertical 
+C  direction NSMAX times, using FLUX_U as temporary work array.
+C   
+      IF (NSMAX.GT.0)  THEN
+        DO 80 N = 1,NAZ
+          DO 81 L=LEV1,LEV2
+          DO 81 I=IL1,IL2
+          SMOOTHR1(I,L) = M_ALPHA(I,L,N)
+ 81       CONTINUE 
+             CALL VERT_SMOOTH (SMOOTHR1, 
+     ^                       SMOOTHR2, SMCO, NSMAX,
+     ^                       IL1, IL2, LEV1, LEV2, NLONS, NLEVS )
+        DO 83 L=LEV1,LEV2
+        DO 83 I=IL1,IL2
+        M_ALPHA(I,L,N) = SMOOTHR1(I,L)
+ 83     CONTINUE
+ 80     CONTINUE
+        CALL VERT_SMOOTH ( SIGMA_T, 
+     ^                     SMOOTHR2, SMCO, NSMAX,
+     ^                     IL1, IL2, LEV1, LEV2, NLONS, NLEVS )
+      END IF
+C
+C  Calculate zonal and meridional components of the
+C  momentum flux and drag.
+C
+      CALL HINES_FLUX ( FLUX_U, FLUX_V, DRAG_U, DRAG_V, 
+     ^                  ALT, DENSITY, DENSB, M_ALPHA, 
+     ^                  AK_ALPHA, K_ALPHA, SLOPE, NAZ,
+     ^                  IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH,
+     ^                  LORMS)
+C
+C  Cutoff drag above ALT_CUTOFF, using BVFB as temporary work array.
+C
+      IF (ICUTOFF.EQ.1)  THEN		
+        CALL HINES_EXP ( DRAG_U, 
+     ^                   BVFB, ALT, ALT_CUTOFF, IORDER,
+     ^                   IL1, IL2, LEV1, LEV2, NLONS, NLEVS )
+        CALL HINES_EXP ( DRAG_V, 
+     ^                   BVFB, ALT, ALT_CUTOFF, IORDER,
+     ^                   IL1, IL2, LEV1, LEV2, NLONS, NLEVS )
+      END IF   
+C
+C  Print out various arrays for diagnostic purposes.
+C
+      IF (IPRINT.EQ.1)  THEN
+        ILPRT1 = 15
+        ILPRT2 = 16
+        CALL HINES_PRINT ( FLUX_U, FLUX_V, DRAG_U, DRAG_V, ALT,
+     ^                     SIGMA_T, SIGMA_ALPHA, V_ALPHA, M_ALPHA,
+     ^                     1, 1, 6, ILPRT1, ILPRT2, LEV1, LEV2,
+     ^                     NAZ, NLONS, NLEVS, NAZMTH)
+      END IF
+C
+C  If not calculating heating rate and diffusion coefficient then finished.
+C
+      IF (IHEATCAL.NE.1)  RETURN
+C
+C  Calculate vertical derivative of cutoff wavenumber (store
+C  in array V_ALPHA) using centered differences at interior gridpoints
+C  and one-sided differences at first and last levels.
+C 
+      DO 130 N = 1,NAZ
+        DO 100 L = LEV1P,LEV2M
+          DO 90 I = IL1,IL2
+            V_ALPHA(I,L,N) = ( M_ALPHA(I,L+1,N) - M_ALPHA(I,L-1,N) ) 
+     ^                       / ( ALT(I,L+1) - ALT(I,L-1) )
+  90      CONTINUE
+ 100    CONTINUE
+        DO 110 I = IL1,IL2
+          V_ALPHA(I,LEV1,N) = ( M_ALPHA(I,LEV1P,N) - M_ALPHA(I,LEV1,N) ) 
+     ^                       / ( ALT(I,LEV1P) - ALT(I,LEV1) )
+ 110    CONTINUE
+        DO 120 I = IL1,IL2
+          V_ALPHA(I,LEV2,N) = ( M_ALPHA(I,LEV2,N) - M_ALPHA(I,LEV2M,N) ) 
+     ^                       / ( ALT(I,LEV2) - ALT(I,LEV2M) )
+ 120    CONTINUE
+ 130  CONTINUE
+C
+C  Heating rate and diffusion coefficient.
+C
+      CALL HINES_HEAT ( HEAT, DIFFCO, 
+     ^                  M_ALPHA, V_ALPHA, AK_ALPHA, K_ALPHA, 
+     ^                  BVFREQ, DENSITY, DENSB, SIGMA_T, VISC_MOL, 
+     ^                  KSTAR, SLOPE, F2, F3, F5, F6, NAZ, 
+     ^                  IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH)
+C
+C  Finished.
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_WAVNUM (M_ALPHA,SIGMA_ALPHA,SIGSQH_ALPHA,SIGMA_T,
+     1                         AK_ALPHA,V_ALPHA,VISC_MOL,DENSITY,DENSB,
+     2                         BVFREQ,BVFB,RMS_WIND,I_ALPHA,MMIN_ALPHA,
+     3                         KSTAR,SLOPE,F1,F2,F3,NAZ,LEVBOT,LEVTOP,
+     4                         IL1,IL2,NLONS,NLEVS,NAZMTH,SIGSQMCW,
+     5                         SIGMATM,LORMS,SIGALPMC,F2MOD)
+C
+C  This routine calculates the cutoff vertical wavenumber and velocity
+C  variances on a longitude by altitude grid for the Hines' Doppler 
+C  spread gravity wave drag parameterization scheme.
+C  NOTE: (1) only values of four or eight can be used for # azimuths (NAZ).
+C        (2) only values of 1.0, 1.5 or 2.0 can be used for slope (SLOPE). 
+C
+C  Aug. 10/95 - C. McLandress
+C
+C  Output arguements:
+C
+C     * M_ALPHA      = cutoff wavenumber at each azimuth (1/m).
+C     * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
+C     * SIGSQH_ALPHA = portion of wind variance from waves having wave
+C     *                normals in the alpha azimuth (m/s).
+C     * SIGMA_T      = total rms horizontal wind (m/s).
+C     * AK_ALPHA     = spectral amplitude factor at each azimuth 
+C     *                (i.e.,{AjKj}) in m^4/s^2.
+C
+C  Input arguements:
+C
+C     * V_ALPHA  = wind component at each azimuth (m/s). 
+C     * VISC_MOL = molecular viscosity (m^2/s)
+C     * DENSITY  = background density (kg/m^3).
+C     * DENSB    = background density at model bottom (kg/m^3).
+C     * BVFREQ   = background Brunt Vassala frequency (radians/sec).
+C     * BVFB     = background Brunt Vassala frequency at model bottom.
+C     * RMS_WIND = root mean square gravity wave wind at lowest level (m/s).
+C     * KSTAR    = typical gravity wave horizontal wavenumber (1/m).
+C     * SLOPE    = slope of incident vertical wavenumber spectrum
+C     *            (SLOPE = 1., 1.5 or 2.).
+C     * F1,F2,F3 = Hines's fudge factors.
+C     * NAZ      = actual number of horizontal azimuths used (4 or 8).
+C     * LEVBOT   = index of lowest vertical level.
+C     * LEVTOP   = index of highest vertical level 
+C     *            (NOTE: if LEVTOP < LEVBOT then level index 
+C     *             increases from top down).
+C     * IL1      = first longitudinal index to use (IL1 >= 1).
+C     * IL2      = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * NLONS    = number of longitudes.
+C     * NLEVS    = number of vertical levels.
+C     * NAZMTH   = azimuthal array dimension (NAZMTH >= NAZ).
+C
+C     * LORMS       = .TRUE. for drag computation 
+C
+C  Input work arrays:
+C
+C     * I_ALPHA    = Hines' integral at a single level.
+C     * MMIN_ALPHA = minimum value of cutoff wavenumber.
+C
+      INTEGER  NAZ, LEVBOT, LEVTOP, IL1, IL2, NLONS, NLEVS, NAZMTH
+      REAL  SLOPE, KSTAR(NLONS), F1, F2, F3
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  SIGMA_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  SIGALPMC(NLONS,NLEVS,NAZMTH)
+      REAL  SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  SIGSQMCW(NLONS,NLEVS,NAZMTH)
+      REAL  SIGMA_T(NLONS,NLEVS)
+      REAL  SIGMATM(NLONS,NLEVS)
+      REAL  AK_ALPHA(NLONS,NAZMTH)
+      REAL  V_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  VISC_MOL(NLONS,NLEVS)
+      REAL  F2MOD(NLONS,NLEVS)
+      REAL  DENSITY(NLONS,NLEVS),  DENSB(NLONS)
+      REAL  BVFREQ(NLONS,NLEVS),   BVFB(NLONS),  RMS_WIND(NLONS)
+      REAL  I_ALPHA(NLONS,NAZMTH), MMIN_ALPHA(NLONS,NAZMTH)
+C
+      LOGICAL LORMS(NLONS)
+C
+C Internal variables.
+C
+      INTEGER  I, L, N, LSTART, LEND, LINCR, LBELOW
+      REAL  M_SUB_M_TURB, M_SUB_M_MOL, M_TRIAL
+      REAL  VISC, VISC_MIN, AZFAC, SP1
+
+cc      REAL  N_OVER_M(1000), SIGFAC(1000)
+
+      REAL  N_OVER_M(NLONS), SIGFAC(NLONS)
+      DATA  VISC_MIN / 1.E-10 / 
+C-----------------------------------------------------------------------     
+C
+
+C     PRINT *,'IN HINES_WAVNUM'
+      SP1 = SLOPE + 1.
+C
+C  Indices of levels to process.
+C
+      IF (LEVBOT.GT.LEVTOP)  THEN
+        LSTART = LEVBOT - 1     
+        LEND   = LEVTOP         
+        LINCR  = -1
+      ELSE
+      write(6,1)
+   1  format(2x,' error: IORDER NOT ONE! ')
+      END IF
+C
+C  Use horizontal isotropy to calculate azimuthal variances at bottom level.
+C
+      AZFAC = 1. / REAL(NAZ)
+      DO 20 N = 1,NAZ
+        DO 10 I = IL1,IL2
+          SIGSQH_ALPHA(I,LEVBOT,N) = AZFAC * RMS_WIND(I)**2
+ 10     CONTINUE
+ 20   CONTINUE
+C
+C  Velocity variances at bottom level.
+C
+      CALL HINES_SIGMA ( SIGMA_T, SIGMA_ALPHA, 
+     ^                   SIGSQH_ALPHA, NAZ, LEVBOT, 
+     ^                   IL1, IL2, NLONS, NLEVS, NAZMTH)
+c
+      CALL HINES_SIGMA ( SIGMATM, SIGALPMC, 
+     ^                   SIGSQMCW, NAZ, LEVBOT, 
+     ^                   IL1, IL2, NLONS, NLEVS, NAZMTH) 
+C
+C  Calculate cutoff wavenumber and spectral amplitude factor 
+C  at bottom level where it is assumed that background winds vanish
+C  and also initialize minimum value of cutoff wavnumber.
+C
+      DO 40 N = 1,NAZ
+        DO 30 I = IL1,IL2
+        IF (LORMS(I)) THEN
+          M_ALPHA(I,LEVBOT,N) =  BVFB(I) / 
+     ^                           ( F1 * SIGMA_ALPHA(I,LEVBOT,N) 
+     ^                           + F2 * SIGMA_T(I,LEVBOT) )
+          AK_ALPHA(I,N)   = SIGSQH_ALPHA(I,LEVBOT,N) 
+     ^                      / ( M_ALPHA(I,LEVBOT,N)**SP1 / SP1 )
+          MMIN_ALPHA(I,N) = M_ALPHA(I,LEVBOT,N)
+        ENDIF
+ 30     CONTINUE
+ 40   CONTINUE
+C
+C  Calculate quantities from the bottom upwards, 
+C  starting one level above bottom.
+C
+      DO 150 L = LSTART,LEND,LINCR
+C
+C  Level beneath present level.
+C
+        LBELOW = L - LINCR 
+C
+C  Calculate N/m_M where m_M is maximum permissible value of the vertical
+C  wavenumber (i.e., m > m_M are obliterated) and N is buoyancy frequency.
+C  m_M is taken as the smaller of the instability-induced 
+C  wavenumber (M_SUB_M_TURB) and that imposed by molecular viscosity
+C  (M_SUB_M_MOL). Since variance at this level is not yet known
+C  use value at level below.
+C
+        DO 50 I = IL1,IL2
+        IF (LORMS(I)) THEN
+c
+        F2MFAC=SIGMATM(I,LBELOW)**2
+        F2MOD(I,LBELOW) =1.+ 2.*F2MFAC
+     ^                      / ( F2MFAC+SIGMA_T(I,LBELOW)**2 )
+c
+         VISC = AMAX1 ( VISC_MOL(I,L), VISC_MIN )
+         M_SUB_M_TURB = BVFREQ(I,L) 
+     ^                 / ( F2 *F2MOD(I,LBELOW)*SIGMA_T(I,LBELOW))
+         M_SUB_M_MOL = (BVFREQ(I,L)*KSTAR(I)/VISC)**0.33333333/F3
+          IF (M_SUB_M_TURB .LT. M_SUB_M_MOL)  THEN
+            N_OVER_M(I) = F2 *F2MOD(I,LBELOW)*SIGMA_T(I,LBELOW)
+          ELSE
+            N_OVER_M(I) = BVFREQ(I,L) / M_SUB_M_MOL 
+          END IF
+        ENDIF
+  50    CONTINUE
+C
+C  Calculate cutoff wavenumber at this level.
+C
+        DO 70 N = 1,NAZ
+          DO 60 I = IL1,IL2
+          IF (LORMS(I)) THEN
+C
+C  Calculate trial value (since variance at this level is not yet known
+C  use value at level below). If trial value is negative or if it exceeds 
+C  minimum value (not permitted) then set it to minimum value. 
+C                                                                      
+            M_TRIAL = BVFB(I) / ( F1 * ( SIGMA_ALPHA(I,LBELOW,N)+  
+     ^       SIGALPMC(I,LBELOW,N)) + N_OVER_M(I) + V_ALPHA(I,L,N) )
+            IF (M_TRIAL.LE.0. .OR. M_TRIAL.GT.MMIN_ALPHA(I,N))  THEN
+              M_TRIAL = MMIN_ALPHA(I,N)
+            END IF
+            M_ALPHA(I,L,N) = M_TRIAL
+C
+C  Reset minimum value of cutoff wavenumber if necessary.
+C
+            IF (M_ALPHA(I,L,N) .LT. MMIN_ALPHA(I,N))  THEN
+              MMIN_ALPHA(I,N) = M_ALPHA(I,L,N)
+            END IF
+C
+          ENDIF
+ 60       CONTINUE
+ 70     CONTINUE
+C
+C  Calculate the Hines integral at this level.
+C
+        CALL HINES_INTGRL ( I_ALPHA, 
+     ^                      V_ALPHA, M_ALPHA, BVFB, SLOPE, NAZ, 
+     ^                      L, IL1, IL2, NLONS, NLEVS, NAZMTH,
+     ^                      LORMS )
+
+C
+C  Calculate the velocity variances at this level.
+C
+        DO 80 I = IL1,IL2
+          SIGFAC(I) = DENSB(I) / DENSITY(I,L) 
+     ^                * BVFREQ(I,L) / BVFB(I) 
+ 80     CONTINUE
+        DO 100 N = 1,NAZ
+          DO 90 I = IL1,IL2
+            SIGSQH_ALPHA(I,L,N) = SIGFAC(I) * AK_ALPHA(I,N) 
+     ^                            * I_ALPHA(I,N)
+  90      CONTINUE
+ 100    CONTINUE
+        CALL HINES_SIGMA ( SIGMA_T, SIGMA_ALPHA, 
+     ^                     SIGSQH_ALPHA, NAZ, L, 
+     ^                     IL1, IL2, NLONS, NLEVS, NAZMTH )
+c
+        CALL HINES_SIGMA ( SIGMATM, SIGALPMC, 
+     ^                     SIGSQMCW, NAZ, L, 
+     ^                     IL1, IL2, NLONS, NLEVS, NAZMTH )
+C
+C  End of level loop.
+C
+ 150  CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_WIND (V_ALPHA,VEL_U,VEL_V,
+     1                       NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH)
+C
+C  This routine calculates the azimuthal horizontal background wind components 
+C  on a longitude by altitude grid for the case of 4 or 8 azimuths for
+C  the Hines' Doppler spread GWD parameterization scheme.
+C
+C  Aug. 7/95 - C. McLandress
+C
+C  Output arguement:
+C
+C     * V_ALPHA   = background wind component at each azimuth (m/s). 
+C     *             (note: first azimuth is in eastward direction
+C     *              and rotate in counterclockwise direction.)
+C
+C  Input arguements:
+C
+C     * VEL_U     = background zonal wind component (m/s).
+C     * VEL_V     = background meridional wind component (m/s).
+C     * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
+C     * IL1       = first longitudinal index to use (IL1 >= 1).
+C     * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * LEV1      = first altitude level to use (LEV1 >=1). 
+C     * LEV2      = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+C     * NLONS     = number of longitudes.
+C     * NLEVS     = number of vertical levels.
+C     * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
+C
+C  Constants in DATA statements.
+C
+C     * COS45 = cosine of 45 degrees. 		
+C     * UMIN  = minimum allowable value for zonal or meridional 
+C     *         wind component (m/s).
+C
+C  Subroutine arguements.
+C
+      INTEGER  NAZ, IL1, IL2, LEV1, LEV2
+      INTEGER  NLONS, NLEVS, NAZMTH
+      REAL  V_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  VEL_U(NLONS,NLEVS), VEL_V(NLONS,NLEVS)
+C
+C  Internal variables.
+C
+      INTEGER  I, L
+      REAL U, V, COS45, UMIN
+C
+      DATA  COS45 / 0.7071068 /
+      DATA  UMIN / 0.001 /
+C-----------------------------------------------------------------------     
+C
+C  Case with 4 azimuths.
+C
+
+C      PRINT *,'IN HINES_WIND'
+      IF (NAZ.EQ.4)  THEN
+        DO 20 L = LEV1,LEV2
+          DO 10 I = IL1,IL2
+            U = VEL_U(I,L)
+            V = VEL_V(I,L)
+            IF (ABS(U) .LT. UMIN)  U = UMIN 
+            IF (ABS(V) .LT. UMIN)  V = UMIN 
+            V_ALPHA(I,L,1) = U 
+            V_ALPHA(I,L,2) = V
+            V_ALPHA(I,L,3) = - U
+            V_ALPHA(I,L,4) = - V
+ 10       CONTINUE
+ 20     CONTINUE
+      END IF
+C
+C  Case with 8 azimuths.
+C
+      IF (NAZ.EQ.8)  THEN
+        DO 40 L = LEV1,LEV2
+          DO 30 I = IL1,IL2
+            U = VEL_U(I,L)
+            V = VEL_V(I,L)
+            IF (ABS(U) .LT. UMIN)  U = UMIN  
+            IF (ABS(V) .LT. UMIN)  V = UMIN  
+            V_ALPHA(I,L,1) = U 
+            V_ALPHA(I,L,2) = COS45 * ( V + U )
+            V_ALPHA(I,L,3) = V
+            V_ALPHA(I,L,4) = COS45 * ( V - U )
+            V_ALPHA(I,L,5) = - U
+            V_ALPHA(I,L,6) = - V_ALPHA(I,L,2)
+            V_ALPHA(I,L,7) = - V
+            V_ALPHA(I,L,8) = - V_ALPHA(I,L,4)
+ 30       CONTINUE
+ 40     CONTINUE
+      END IF
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_FLUX (FLUX_U,FLUX_V,DRAG_U,DRAG_V,ALT,DENSITY,
+     1                       DENSB,M_ALPHA,AK_ALPHA,K_ALPHA,SLOPE,
+     2                       NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH,
+     3                       LORMS)
+C
+C  Calculate zonal and meridional components of the vertical flux 
+C  of horizontal momentum and corresponding wave drag (force per unit mass)
+C  on a longitude by altitude grid for the Hines' Doppler spread 
+C  GWD parameterization scheme.
+C  NOTE: only 4 or 8 azimuths can be used.
+C
+C  Aug. 6/95 - C. McLandress
+C
+C  Output arguements:
+C
+C     * FLUX_U = zonal component of vertical momentum flux (Pascals)
+C     * FLUX_V = meridional component of vertical momentum flux (Pascals)
+C     * DRAG_U = zonal component of drag (m/s^2).
+C     * DRAG_V = meridional component of drag (m/s^2).
+C
+C  Input arguements:
+C
+C     * ALT       = altitudes (m).
+C     * DENSITY   = background density (kg/m^3).
+C     * DENSB     = background density at bottom level (kg/m^3).
+C     * M_ALPHA   = cutoff vertical wavenumber (1/m).
+C     * AK_ALPHA  = spectral amplitude factor (i.e., {AjKj} in m^4/s^2).
+C     * K_ALPHA   = horizontal wavenumber (1/m).
+C     * SLOPE     = slope of incident vertical wavenumber spectrum.
+C     * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
+C     * IL1       = first longitudinal index to use (IL1 >= 1).
+C     * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * LEV1      = first altitude level to use (LEV1 >=1). 
+C     * LEV2      = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+C     * NLONS     = number of longitudes.
+C     * NLEVS     = number of vertical levels.
+C     * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
+C
+C     * LORMS       = .TRUE. for drag computation 
+C
+C  Constant in DATA statement.
+C
+C     * COS45 = cosine of 45 degrees. 		
+C
+C  Subroutine arguements.
+C
+      INTEGER  NAZ, IL1, IL2, LEV1, LEV2
+      INTEGER  NLONS, NLEVS, NAZMTH
+      REAL  SLOPE
+      REAL  FLUX_U(NLONS,NLEVS), FLUX_V(NLONS,NLEVS)
+      REAL  DRAG_U(NLONS,NLEVS), DRAG_V(NLONS,NLEVS)
+      REAL  ALT(NLONS,NLEVS),    DENSITY(NLONS,NLEVS), DENSB(NLONS)
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  AK_ALPHA(NLONS,NAZMTH), K_ALPHA(NLONS,NAZMTH)
+C
+      LOGICAL LORMS(NLONS)
+C
+C  Internal variables.
+C
+      INTEGER  I, L, LEV1P, LEV2M
+      REAL  COS45, PROD2, PROD4, PROD6, PROD8, DENDZ, DENDZ2
+      DATA  COS45 / 0.7071068 /   
+C-----------------------------------------------------------------------
+C
+      LEV1P = LEV1 + 1
+      LEV2M = LEV2 - 1
+      LEV2P = LEV2 + 1
+C
+C  Sum over azimuths for case where SLOPE = 1.
+C
+      IF (SLOPE.EQ.1.)  THEN
+C
+C  Case with 4 azimuths.
+C
+        IF (NAZ.EQ.4)  THEN
+          DO 20 L = LEV1,LEV2
+            DO 10 I = IL1,IL2
+              FLUX_U(I,L) = AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)
+     ^                    - AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)
+              FLUX_V(I,L) = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)
+     ^                    - AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)
+ 10         CONTINUE
+ 20       CONTINUE
+        END IF
+C
+C  Case with 8 azimuths.
+C
+        IF (NAZ.EQ.8)  THEN
+          DO 40 L = LEV1,LEV2
+            DO 30 I = IL1,IL2
+              PROD2 = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)
+              PROD4 = AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)
+              PROD6 = AK_ALPHA(I,6)*K_ALPHA(I,6)*M_ALPHA(I,L,6)
+              PROD8 = AK_ALPHA(I,8)*K_ALPHA(I,8)*M_ALPHA(I,L,8)
+              FLUX_U(I,L) = 
+     ^                AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)
+     ^              - AK_ALPHA(I,5)*K_ALPHA(I,5)*M_ALPHA(I,L,5)
+     ^              + COS45 * ( PROD2 - PROD4 - PROD6 + PROD8 )
+              FLUX_V(I,L) = 
+     ^                AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)
+     ^              - AK_ALPHA(I,7)*K_ALPHA(I,7)*M_ALPHA(I,L,7)
+     ^              + COS45 * ( PROD2 + PROD4 - PROD6 - PROD8 )
+ 30         CONTINUE
+ 40       CONTINUE
+        END IF
+C
+      END IF
+C
+C  Sum over azimuths for case where SLOPE not equal to 1.
+C
+      IF (SLOPE.NE.1.)  THEN
+C
+C  Case with 4 azimuths.
+C
+        IF (NAZ.EQ.4)  THEN
+          DO 60 L = LEV1,LEV2
+            DO 50 I = IL1,IL2
+              FLUX_U(I,L) = 
+     ^               AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)**SLOPE
+     ^             - AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)**SLOPE
+              FLUX_V(I,L) = 
+     ^               AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)**SLOPE
+     ^             - AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)**SLOPE
+ 50         CONTINUE
+ 60       CONTINUE
+        END IF
+C
+C  Case with 8 azimuths.
+C
+        IF (NAZ.EQ.8)  THEN
+          DO 80 L = LEV1,LEV2
+            DO 70 I = IL1,IL2
+              PROD2 = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)**SLOPE
+              PROD4 = AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)**SLOPE
+              PROD6 = AK_ALPHA(I,6)*K_ALPHA(I,6)*M_ALPHA(I,L,6)**SLOPE
+              PROD8 = AK_ALPHA(I,8)*K_ALPHA(I,8)*M_ALPHA(I,L,8)**SLOPE
+              FLUX_U(I,L) = 
+     ^                AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)**SLOPE
+     ^              - AK_ALPHA(I,5)*K_ALPHA(I,5)*M_ALPHA(I,L,5)**SLOPE
+     ^              + COS45 * ( PROD2 - PROD4 - PROD6 + PROD8 )
+              FLUX_V(I,L) = 
+     ^                AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)**SLOPE
+     ^              - AK_ALPHA(I,7)*K_ALPHA(I,7)*M_ALPHA(I,L,7)**SLOPE
+     ^              + COS45 * ( PROD2 + PROD4 - PROD6 - PROD8 )
+ 70         CONTINUE
+ 80       CONTINUE
+        END IF
+C
+      END IF
+C
+C  Calculate flux from sum.
+C
+      DO 100 L = LEV1,LEV2
+        DO 90 I = IL1,IL2
+          FLUX_U(I,L) = FLUX_U(I,L) * DENSB(I) / SLOPE
+          FLUX_V(I,L) = FLUX_V(I,L) * DENSB(I) / SLOPE
+  90    CONTINUE
+ 100  CONTINUE
+C
+C  Calculate drag at intermediate levels using centered differences 
+C      
+      DO 120 L = LEV1P,LEV2M
+        DO 110 I = IL1,IL2
+        IF (LORMS(I)) THEN
+ccc       DENDZ2 = DENSITY(I,L) * ( ALT(I,L+1) - ALT(I,L-1) )
+          DENDZ2 = DENSITY(I,L) * ( ALT(I,L-1) - ALT(I,L) ) 
+ccc       DRAG_U(I,L) = - ( FLUX_U(I,L+1) - FLUX_U(I,L-1) ) / DENDZ2
+          DRAG_U(I,L) = - ( FLUX_U(I,L-1) - FLUX_U(I,L) ) / DENDZ2
+ccc       DRAG_V(I,L) = - ( FLUX_V(I,L+1) - FLUX_V(I,L-1) ) / DENDZ2
+          DRAG_V(I,L) = - ( FLUX_V(I,L-1) - FLUX_V(I,L) ) / DENDZ2
+          
+        ENDIF
+ 110    CONTINUE
+ 120  CONTINUE
+C
+C  Drag at first and last levels using one-side differences.
+C 
+      DO 130 I = IL1,IL2
+      IF (LORMS(I)) THEN
+        DENDZ = DENSITY(I,LEV1) * ( ALT(I,LEV1) - ALT(I,LEV1P) ) 
+        DRAG_U(I,LEV1) =  FLUX_U(I,LEV1)  / DENDZ
+        DRAG_V(I,LEV1) =  FLUX_V(I,LEV1)  / DENDZ
+      ENDIF
+ 130  CONTINUE
+      DO 140 I = IL1,IL2
+      IF (LORMS(I)) THEN
+        DENDZ = DENSITY(I,LEV2) * ( ALT(I,LEV2M) - ALT(I,LEV2) )
+        DRAG_U(I,LEV2) = - ( FLUX_U(I,LEV2M) - FLUX_U(I,LEV2) ) / DENDZ
+        DRAG_V(I,LEV2) = - ( FLUX_V(I,LEV2M) - FLUX_V(I,LEV2) ) / DENDZ
+      ENDIF
+ 140  CONTINUE
+      IF (NLEVS .GT. LEV2) THEN
+      DO 150 I = IL1,IL2
+      IF (LORMS(I)) THEN
+        DENDZ = DENSITY(I,LEV2P) * ( ALT(I,LEV2) - ALT(I,LEV2P) )
+        DRAG_U(I,LEV2P) = -  FLUX_U(I,LEV2)  / DENDZ
+        DRAG_V(I,LEV2P) = - FLUX_V(I,LEV2)  / DENDZ
+      ENDIF
+150   CONTINUE
+      ENDIF
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_HEAT (HEAT,DIFFCO,M_ALPHA,DMDZ_ALPHA,
+     1                       AK_ALPHA,K_ALPHA,BVFREQ,DENSITY,DENSB,
+     2                       SIGMA_T,VISC_MOL,KSTAR,SLOPE,F2,F3,F5,F6,
+     3                       NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH)
+C
+C  This routine calculates the gravity wave induced heating and 
+C  diffusion coefficient on a longitude by altitude grid for  
+C  the Hines' Doppler spread gravity wave drag parameterization scheme.
+C
+C  Aug. 6/95 - C. McLandress
+C
+C  Output arguements:
+C
+C     * HEAT   = gravity wave heating (K/sec).
+C     * DIFFCO = diffusion coefficient (m^2/sec)
+C
+C  Input arguements:
+C
+C     * M_ALPHA     = cutoff vertical wavenumber (1/m).
+C     * DMDZ_ALPHA  = vertical derivative of cutoff wavenumber.
+C     * AK_ALPHA    = spectral amplitude factor of each azimuth 
+C                     (i.e., {AjKj} in m^4/s^2).
+C     * K_ALPHA     = horizontal wavenumber of each azimuth (1/m).
+C     * BVFREQ      = background Brunt Vassala frequency (rad/sec).
+C     * DENSITY     = background density (kg/m^3).
+C     * DENSB       = background density at bottom level (kg/m^3).
+C     * SIGMA_T     = total rms horizontal wind (m/s).
+C     * VISC_MOL    = molecular viscosity (m^2/s).
+C     * KSTAR       = typical gravity wave horizontal wavenumber (1/m).
+C     * SLOPE       = slope of incident vertical wavenumber spectrum.
+C     * F2,F3,F5,F6 = Hines's fudge factors.
+C     * NAZ         = actual number of horizontal azimuths used.
+C     * IL1         = first longitudinal index to use (IL1 >= 1).
+C     * IL2         = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * LEV1        = first altitude level to use (LEV1 >=1). 
+C     * LEV2        = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+C     * NLONS       = number of longitudes.
+C     * NLEVS       = number of vertical levels.
+C     * NAZMTH      = azimuthal array dimension (NAZMTH >= NAZ).
+C
+      INTEGER  NAZ, IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH
+      REAL  KSTAR(NLONS), SLOPE, F2, F3, F5, F6
+      REAL  HEAT(NLONS,NLEVS), DIFFCO(NLONS,NLEVS)
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH), DMDZ_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  AK_ALPHA(NLONS,NAZMTH), K_ALPHA(NLONS,NAZMTH)
+      REAL  BVFREQ(NLONS,NLEVS), DENSITY(NLONS,NLEVS),  DENSB(NLONS) 
+      REAL  SIGMA_T(NLONS,NLEVS), VISC_MOL(NLONS,NLEVS)
+C
+C Internal variables.
+C
+      INTEGER  I, L, N
+      REAL  M_SUB_M_TURB, M_SUB_M_MOL, M_SUB_M, HEATNG
+      REAL  VISC, VISC_MIN, CPGAS, SM1
+C
+C specific heat at constant pressure
+C
+      DATA  CPGAS / 1004. / 
+C             
+C minimum permissible viscosity
+C
+      DATA  VISC_MIN / 1.E-10 /       
+C-----------------------------------------------------------------------     
+C
+C  Initialize heating array.
+C
+      DO 20 L = 1,NLEVS
+        DO 10 I = 1,NLONS
+          HEAT(I,L) = 0.
+  10    CONTINUE
+  20  CONTINUE
+C
+C  Perform sum over azimuths for case where SLOPE = 1.
+C
+      IF (SLOPE.EQ.1.)  THEN
+        DO 50 N = 1,NAZ
+          DO 40 L = LEV1,LEV2
+            DO 30 I = IL1,IL2
+              HEAT(I,L) = HEAT(I,L) + AK_ALPHA(I,N) * K_ALPHA(I,N) 
+     ^                    * DMDZ_ALPHA(I,L,N) 
+ 30         CONTINUE
+ 40       CONTINUE
+ 50     CONTINUE
+      END IF
+C
+C  Perform sum over azimuths for case where SLOPE not 1.
+C
+      IF (SLOPE.NE.1.)  THEN
+        SM1 = SLOPE - 1.
+        DO 80 N = 1,NAZ
+          DO 70 L = LEV1,LEV2
+            DO 60 I = IL1,IL2
+              HEAT(I,L) = HEAT(I,L) + AK_ALPHA(I,N) * K_ALPHA(I,N) 
+     ^                    * M_ALPHA(I,L,N)**SM1 * DMDZ_ALPHA(I,L,N) 
+ 60         CONTINUE
+ 70       CONTINUE
+ 80     CONTINUE
+      END IF
+C
+C  Heating and diffusion.
+C
+      DO 100 L = LEV1,LEV2
+        DO 90 I = IL1,IL2
+C
+C  Maximum permissible value of cutoff wavenumber is the smaller 
+C  of the instability-induced wavenumber (M_SUB_M_TURB) and 
+C  that imposed by molecular viscosity (M_SUB_M_MOL).
+C
+          VISC    = AMAX1 ( VISC_MOL(I,L), VISC_MIN )
+          M_SUB_M_TURB = BVFREQ(I,L) / ( F2 * SIGMA_T(I,L) )
+          M_SUB_M_MOL  = (BVFREQ(I,L)*KSTAR(I)/VISC)**0.33333333/F3
+          M_SUB_M      = AMIN1 ( M_SUB_M_TURB, M_SUB_M_MOL )
+C
+          HEATNG = - HEAT(I,L) * F5 * BVFREQ(I,L) / M_SUB_M 
+     ^               * DENSB(I) / DENSITY(I,L) 
+          DIFFCO(I,L) = F6 * HEATNG**0.33333333 / M_SUB_M**1.33333333
+          HEAT(I,L)   = HEATNG / CPGAS
+C
+ 90     CONTINUE
+ 100  CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_SIGMA (SIGMA_T,SIGMA_ALPHA,SIGSQH_ALPHA,
+     1                        NAZ,LEV,IL1,IL2,NLONS,NLEVS,NAZMTH)
+C
+C  This routine calculates the total rms and azimuthal rms horizontal 
+C  velocities at a given level on a longitude by altitude grid for 
+C  the Hines' Doppler spread GWD parameterization scheme.
+C  NOTE: only four or eight azimuths can be used.
+C
+C  Aug. 7/95 - C. McLandress
+C
+C  Output arguements:
+C
+C     * SIGMA_T      = total rms horizontal wind (m/s).
+C     * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
+C
+C  Input arguements:
+C
+C     * SIGSQH_ALPHA = portion of wind variance from waves having wave
+C     *                normals in the alpha azimuth (m/s).
+C     * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
+C     * LEV       = altitude level to process.
+C     * IL1       = first longitudinal index to use (IL1 >= 1).
+C     * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * NLONS     = number of longitudes.
+C     * NLEVS     = number of vertical levels.
+C     * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
+C
+C  Subroutine arguements.
+C
+      INTEGER  LEV, NAZ, IL1, IL2
+      INTEGER  NLONS, NLEVS, NAZMTH
+      REAL  SIGMA_T(NLONS,NLEVS)
+      REAL  SIGMA_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH)
+C
+C  Internal variables.
+C
+      INTEGER  I, N
+      REAL  SUM_EVEN, SUM_ODD 
+C-----------------------------------------------------------------------     
+C
+C  Calculate azimuthal rms velocity for the 4 azimuth case.
+C
+      IF (NAZ.EQ.4)  THEN
+        DO 10 I = IL1,IL2
+          SIGMA_ALPHA(I,LEV,1) = SQRT ( SIGSQH_ALPHA(I,LEV,1)
+     ^                                + SIGSQH_ALPHA(I,LEV,3) )
+          SIGMA_ALPHA(I,LEV,2) = SQRT ( SIGSQH_ALPHA(I,LEV,2)
+     ^                                + SIGSQH_ALPHA(I,LEV,4) )
+          SIGMA_ALPHA(I,LEV,3) = SIGMA_ALPHA(I,LEV,1)
+          SIGMA_ALPHA(I,LEV,4) = SIGMA_ALPHA(I,LEV,2)
+ 10     CONTINUE
+      END IF
+C
+C  Calculate azimuthal rms velocity for the 8 azimuth case.
+C
+      IF (NAZ.EQ.8)  THEN
+        DO 20 I = IL1,IL2
+          SUM_ODD  = ( SIGSQH_ALPHA(I,LEV,1) 
+     ^                 + SIGSQH_ALPHA(I,LEV,3) 
+     ^                 + SIGSQH_ALPHA(I,LEV,5) 
+     ^                 + SIGSQH_ALPHA(I,LEV,7) ) / 2.
+          SUM_EVEN = ( SIGSQH_ALPHA(I,LEV,2) 
+     ^                 + SIGSQH_ALPHA(I,LEV,4)
+     ^                 + SIGSQH_ALPHA(I,LEV,6) 
+     ^                 + SIGSQH_ALPHA(I,LEV,8) ) / 2.
+          SIGMA_ALPHA(I,LEV,1) = SQRT ( SIGSQH_ALPHA(I,LEV,1) 
+     ^                           + SIGSQH_ALPHA(I,LEV,5) + SUM_EVEN )
+          SIGMA_ALPHA(I,LEV,2) = SQRT ( SIGSQH_ALPHA(I,LEV,2) 
+     ^                           + SIGSQH_ALPHA(I,LEV,6) + SUM_ODD )
+          SIGMA_ALPHA(I,LEV,3) = SQRT ( SIGSQH_ALPHA(I,LEV,3) 
+     ^                           + SIGSQH_ALPHA(I,LEV,7) + SUM_EVEN )
+          SIGMA_ALPHA(I,LEV,4) = SQRT ( SIGSQH_ALPHA(I,LEV,4) 
+     ^                           + SIGSQH_ALPHA(I,LEV,8) + SUM_ODD )
+          SIGMA_ALPHA(I,LEV,5) = SIGMA_ALPHA(I,LEV,1)
+          SIGMA_ALPHA(I,LEV,6) = SIGMA_ALPHA(I,LEV,2)
+          SIGMA_ALPHA(I,LEV,7) = SIGMA_ALPHA(I,LEV,3)
+          SIGMA_ALPHA(I,LEV,8) = SIGMA_ALPHA(I,LEV,4)
+ 20     CONTINUE
+      END IF
+C
+C  Calculate total rms velocity.
+C
+      DO 50 I = IL1,IL2
+        SIGMA_T(I,LEV) = 0.
+ 50   CONTINUE
+      DO 70 N = 1,NAZ
+        DO 60 I = IL1,IL2
+          SIGMA_T(I,LEV) = SIGMA_T(I,LEV) + SIGSQH_ALPHA(I,LEV,N)
+ 60     CONTINUE
+ 70   CONTINUE
+      DO 80 I = IL1,IL2
+        SIGMA_T(I,LEV) = SQRT ( SIGMA_T(I,LEV) )
+ 80   CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------     
+      END
+
+      SUBROUTINE HINES_INTGRL (I_ALPHA,V_ALPHA,M_ALPHA,BVFB,SLOPE,
+     1                         NAZ,LEV,IL1,IL2,NLONS,NLEVS,NAZMTH,
+     2                         LORMS)
+C
+C  This routine calculates the vertical wavenumber integral
+C  for a single vertical level at each azimuth on a longitude grid
+C  for the Hines' Doppler spread GWD parameterization scheme.
+C  NOTE: (1) only spectral slopes of 1, 1.5 or 2 are permitted.
+C        (2) the integral is written in terms of the product QM
+C            which by construction is always less than 1. Series
+C            solutions are used for small |QM| and analytical solutions
+C            for remaining values.
+C
+C  Aug. 8/95 - C. McLandress
+C
+C  Output arguement:
+C
+C     * I_ALPHA = Hines' integral.
+C
+C  Input arguements:
+C
+C     * V_ALPHA = azimuthal wind component (m/s). 
+C     * M_ALPHA = azimuthal cutoff vertical wavenumber (1/m).
+C     * BVFB    = background Brunt Vassala frequency at model bottom.
+C     * SLOPE   = slope of initial vertical wavenumber spectrum 
+C     *           (must use SLOPE = 1., 1.5 or 2.)
+C     * NAZ     = actual number of horizontal azimuths used.
+C     * LEV     = altitude level to process.
+C     * IL1     = first longitudinal index to use (IL1 >= 1).
+C     * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * NLONS   = number of longitudes.
+C     * NLEVS   = number of vertical levels.
+C     * NAZMTH  = azimuthal array dimension (NAZMTH >= NAZ).
+C
+C     * LORMS       = .TRUE. for drag computation 
+C
+C  Constants in DATA statements:
+C
+C     * QMIN = minimum value of Q_ALPHA (avoids indeterminant form of integral)
+C     * QM_MIN = minimum value of Q_ALPHA * M_ALPHA (used to avoid numerical
+C     *          problems).
+C
+      INTEGER  LEV, NAZ, IL1, IL2, NLONS, NLEVS, NAZMTH
+      REAL  I_ALPHA(NLONS,NAZMTH)
+      REAL  V_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  BVFB(NLONS), SLOPE
+C
+      LOGICAL LORMS(NLONS)
+C
+C  Internal variables.
+C
+      INTEGER  I, N
+      REAL  Q_ALPHA, QM, SQRTQM, Q_MIN, QM_MIN
+C
+      DATA  Q_MIN / 1.0 /, QM_MIN / 0.01 /
+C-----------------------------------------------------------------------     
+C
+C  For integer value SLOPE = 1.
+C
+      IF (SLOPE .EQ. 1.)  THEN
+C
+        DO 20 N = 1,NAZ
+          DO 10 I = IL1,IL2
+          IF (LORMS(I)) THEN
+C
+            Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I)
+            QM = Q_ALPHA * M_ALPHA(I,LEV,N)
+C
+C  If |QM| is small then use first 4 terms series of Taylor series
+C  expansion of integral in order to avoid indeterminate form of integral,
+C  otherwise use analytical form of integral.
+C
+            IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN)  THEN  
+              IF (Q_ALPHA .EQ. 0.)  THEN
+                I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**2 / 2.
+              ELSE
+                I_ALPHA(I,N) = ( QM**2/2. + QM**3/3. + QM**4/4.
+     ^                           + QM**5/5. ) / Q_ALPHA**2
+              END IF
+            ELSE
+              I_ALPHA(I,N) = - ( ALOG(1.-QM) + QM ) / Q_ALPHA**2
+            END IF
+C
+          ENDIF
+ 10       CONTINUE
+ 20     CONTINUE
+C
+      END IF
+C
+C  For integer value SLOPE = 2.
+C
+      IF (SLOPE .EQ. 2.)  THEN
+C
+        DO 40 N = 1,NAZ
+          DO 30 I = IL1,IL2
+          IF (LORMS(I)) THEN
+C
+            Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I)
+            QM = Q_ALPHA * M_ALPHA(I,LEV,N)
+C
+C  If |QM| is small then use first 4 terms series of Taylor series
+C  expansion of integral in order to avoid indeterminate form of integral,
+C  otherwise use analytical form of integral.
+C
+            IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN)  THEN  
+              IF (Q_ALPHA .EQ. 0.)  THEN
+                I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**3 / 3.
+              ELSE
+                I_ALPHA(I,N) = ( QM**3/3. + QM**4/4. + QM**5/5. 
+     ^                           + QM**6/6. ) / Q_ALPHA**3
+              END IF
+            ELSE
+              I_ALPHA(I,N) = - ( ALOG(1.-QM) + QM + QM**2/2.) 
+     ^                         / Q_ALPHA**3
+            END IF
+C
+          ENDIF
+ 30       CONTINUE
+ 40     CONTINUE
+C
+      END IF
+C
+C  For real value SLOPE = 1.5
+C
+      IF (SLOPE .EQ. 1.5)  THEN
+C
+        DO 60 N = 1,NAZ
+          DO 50 I = IL1,IL2
+          IF (LORMS(I)) THEN
+C
+            Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I)
+            QM = Q_ALPHA * M_ALPHA(I,LEV,N)       
+C
+C  If |QM| is small then use first 4 terms series of Taylor series
+C  expansion of integral in order to avoid indeterminate form of integral,
+C  otherwise use analytical form of integral.
+C
+            IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN)  THEN  
+              IF (Q_ALPHA .EQ. 0.)  THEN
+                I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**2.5 / 2.5
+              ELSE
+                I_ALPHA(I,N) = ( QM/2.5 + QM**2/3.5 
+     ^                           + QM**3/4.5 + QM**4/5.5 ) 
+     ^                           * M_ALPHA(I,LEV,N)**1.5 / Q_ALPHA
+              END IF
+            ELSE
+              QM     = ABS(QM)
+              SQRTQM = SQRT(QM)
+              IF (Q_ALPHA .GE. 0.)  THEN
+                I_ALPHA(I,N) = ( ALOG( (1.+SQRTQM)/(1.-SQRTQM) )
+     ^                          -2.*SQRTQM*(1.+QM/3.) ) / Q_ALPHA**2.5
+              ELSE
+                I_ALPHA(I,N) = 2. * ( ATAN(SQRTQM) + SQRTQM*(QM/3.-1.) )
+     ^                          / ABS(Q_ALPHA)**2.5
+              END IF
+            END IF
+C
+          ENDIF
+ 50       CONTINUE
+ 60     CONTINUE
+C
+      END IF
+C
+C  If integral is negative (which in principal should not happen) then
+C  print a message and some info since execution will abort when calculating
+C  the variances.
+C
+c      DO 80 N = 1,NAZ
+c        DO 70 I = IL1,IL2
+c          IF (I_ALPHA(I,N).LT.0.)  THEN
+c            WRITE (6,*) 
+c            WRITE (6,*) '******************************'
+c            WRITE (6,*) 'Hines integral I_ALPHA < 0 '
+c            WRITE (6,*) '  longitude I=',I
+c            WRITE (6,*) '  azimuth   N=',N
+c            WRITE (6,*) '  level   LEV=',LEV
+c            WRITE (6,*) '  I_ALPHA =',I_ALPHA(I,N)
+c            WRITE (6,*) '  V_ALPHA =',V_ALPHA(I,LEV,N)
+c            WRITE (6,*) '  M_ALPHA =',M_ALPHA(I,LEV,N)
+c            WRITE (6,*) '  Q_ALPHA =',V_ALPHA(I,LEV,N) / BVFB(I)
+c            WRITE (6,*) '  QM      =',V_ALPHA(I,LEV,N) / BVFB(I) 
+c     ^                                * M_ALPHA(I,LEV,N)
+c            WRITE (6,*) '******************************'
+c          END IF
+c 70     CONTINUE
+c 80   CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_SETUP (NAZ,SLOPE,F1,F2,F3,F5,F6,KSTAR,
+     1                        ICUTOFF,ALT_CUTOFF,SMCO,NSMAX,IHEATCAL,
+     2                       K_ALPHA,IERROR,NMESSG,NLONS,NAZMTH,COSLAT)
+C
+C  This routine specifies various parameters needed for the
+C  the Hines' Doppler spread gravity wave drag parameterization scheme.
+C
+C  Aug. 8/95 - C. McLandress
+C
+C  Output arguements:
+C
+C     * NAZ        = actual number of horizontal azimuths used
+C     *              (code set up presently for only NAZ = 4 or 8).
+C     * SLOPE      = slope of incident vertical wavenumber spectrum
+C     *              (code set up presently for SLOPE 1., 1.5 or 2.).
+C     * F1         = "fudge factor" used in calculation of trial value of
+C     *              azimuthal cutoff wavenumber M_ALPHA (1.2 <= F1 <= 1.9).
+C     * F2         = "fudge factor" used in calculation of maximum
+C     *              permissible instabiliy-induced cutoff wavenumber 
+C     *              M_SUB_M_TURB (0.1 <= F2 <= 1.4).
+C     * F3         = "fudge factor" used in calculation of maximum 
+C     *              permissible molecular viscosity-induced cutoff wavenumber 
+C     *              M_SUB_M_MOL (0.1 <= F2 <= 1.4).
+C     * F5         = "fudge factor" used in calculation of heating rate
+C     *              (1 <= F5 <= 3).
+C     * F6         = "fudge factor" used in calculation of turbulent 
+C     *              diffusivity coefficient.
+C     * KSTAR      = typical gravity wave horizontal wavenumber (1/m)
+C     *              used in calculation of M_SUB_M_TURB.
+C     * ICUTOFF    = 1 to exponentially damp off GWD, heating and diffusion 
+C     *              arrays above ALT_CUTOFF; otherwise arrays not modified.
+C     * ALT_CUTOFF = altitude in meters above which exponential decay applied.
+C     * SMCO       = smoother used to smooth cutoff vertical wavenumbers
+C     *              and total rms winds before calculating drag or heating.
+C     *              (==> a 1:SMCO:1 stencil used; SMCO >= 1.).
+C     * NSMAX      = number of times smoother applied ( >= 1),
+C     *            = 0 means no smoothing performed.
+C     * IHEATCAL   = 1 to calculate heating rates and diffusion coefficient.
+C     *            = 0 means only drag and flux calculated.
+C     * K_ALPHA    = horizontal wavenumber of each azimuth (1/m) which
+C     *              is set here to KSTAR.
+C     * IERROR     = error flag.
+C     *            = 0 no errors.
+C     *            = 10 ==> NAZ > NAZMTH
+C     *            = 20 ==> invalid number of azimuths (NAZ must be 4 or 8).
+C     *            = 30 ==> invalid slope (SLOPE must be 1., 1.5 or 2.).
+C     *            = 40 ==> invalid smoother (SMCO must be >= 1.)
+C
+C  Input arguements:
+C
+C     * NMESSG  = output unit number where messages to be printed.
+C     * NLONS   = number of longitudes.
+C     * NAZMTH  = azimuthal array dimension (NAZMTH >= NAZ).
+C
+      INTEGER  NAZ, NLONS, NAZMTH, IHEATCAL, ICUTOFF
+      INTEGER  NMESSG, NSMAX, IERROR
+      REAL  KSTAR(NLONS), SLOPE, F1, F2, F3, F5, F6, ALT_CUTOFF, SMCO
+      REAL  K_ALPHA(NLONS,NAZMTH),COSLAT(NLONS)
+      REAL  KSMIN, KSMAX
+C
+C Internal variables.
+C
+      INTEGER  I, N
+C-----------------------------------------------------------------------     
+C
+C  Specify constants.
+C
+      NAZ   = 8
+      SLOPE = 1.
+      F1    = 1.5 
+      F2    = 0.3 
+      F3    = 1.0 
+      F5    = 3.0 
+      F6    = 1.0       
+      KSMIN = 1.E-5       
+      KSMAX = 1.E-4       
+      DO I=1,NLONS
+         KSTAR(I) = KSMIN/( COSLAT(I)+(KSMIN/KSMAX) )      
+      ENDDO
+      ICUTOFF    = 1   
+      ALT_CUTOFF = 105.E3
+      SMCO       = 2.0 
+c      SMCO       = 1.0 
+      NSMAX      = 5
+c      NSMAX      = 2
+      IHEATCAL   = 0 
+C
+C  Print information to output file.
+C
+c      WRITE (NMESSG,6000)
+c 6000 FORMAT (/' Subroutine HINES_SETUP:')
+c      WRITE (NMESSG,*)  '  SLOPE = ', SLOPE
+c      WRITE (NMESSG,*)  '  NAZ = ', NAZ
+c      WRITE (NMESSG,*)  '  F1,F2,F3  = ', F1, F2, F3
+c      WRITE (NMESSG,*)  '  F5,F6     = ', F5, F6
+c      WRITE (NMESSG,*)  '  KSTAR     = ', KSTAR
+c     >           ,'  COSLAT     = ', COSLAT
+c      IF (ICUTOFF .EQ. 1)  THEN
+c        WRITE (NMESSG,*) '  Drag exponentially damped above ',
+c     &                       ALT_CUTOFF/1.E3
+c     END IF
+c      IF (NSMAX.LT.1 )  THEN
+c        WRITE (NMESSG,*) '  No smoothing of cutoff wavenumbers, etc'
+c      ELSE
+c        WRITE (NMESSG,*) '  Cutoff wavenumbers and sig_t smoothed:'
+c        WRITE (NMESSG,*) '    SMCO  =', SMCO
+c        WRITE (NMESSG,*) '    NSMAX =', NSMAX
+c     END IF
+C
+C  Check that things are setup correctly and log error if not
+C
+      IERROR = 0
+      IF (NAZ .GT. NAZMTH)                                  IERROR = 10
+      IF (NAZ.NE.4 .AND. NAZ.NE.8)                          IERROR = 20
+      IF (SLOPE.NE.1. .AND. SLOPE.NE.1.5 .AND. SLOPE.NE.2.) IERROR = 30
+      IF (SMCO .LT. 1.)                                     IERROR = 40
+C
+C  Use single value for azimuthal-dependent horizontal wavenumber.
+C
+      DO 20 N = 1,NAZ
+        DO 10 I = 1,NLONS
+          K_ALPHA(I,N) = KSTAR(I)
+ 10     CONTINUE
+ 20   CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_PRINT (FLUX_U,FLUX_V,DRAG_U,DRAG_V,ALT,SIGMA_T,
+     1                        SIGMA_ALPHA,V_ALPHA,M_ALPHA,
+     2                        IU_PRINT,IV_PRINT,NMESSG,
+     3                        ILPRT1,ILPRT2,LEVPRT1,LEVPRT2,
+     4                        NAZ,NLONS,NLEVS,NAZMTH)
+C
+C  Print out altitude profiles of various quantities from
+C  Hines' Doppler spread gravity wave drag parameterization scheme.
+C  (NOTE: only for NAZ = 4 or 8). 
+C
+C  Aug. 8/95 - C. McLandress
+C
+C  Input arguements:
+C
+C     * IU_PRINT = 1 to print out values in east-west direction.
+C     * IV_PRINT = 1 to print out values in north-south direction.
+C     * NMESSG   = unit number for printed output.
+C     * ILPRT1   = first longitudinal index to print.
+C     * ILPRT2   = last longitudinal index to print.
+C     * LEVPRT1  = first altitude level to print.
+C     * LEVPRT2  = last altitude level to print.
+C
+      INTEGER  NAZ, ILPRT1, ILPRT2, LEVPRT1, LEVPRT2
+      INTEGER  NLONS, NLEVS, NAZMTH
+      INTEGER  IU_PRINT, IV_PRINT, NMESSG
+      REAL  FLUX_U(NLONS,NLEVS), FLUX_V(NLONS,NLEVS)
+      REAL  DRAG_U(NLONS,NLEVS), DRAG_V(NLONS,NLEVS)
+      REAL  ALT(NLONS,NLEVS), SIGMA_T(NLONS,NLEVS)
+      REAL  SIGMA_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  V_ALPHA(NLONS,NLEVS,NAZMTH), M_ALPHA(NLONS,NLEVS,NAZMTH)
+C
+C  Internal variables.
+C
+      INTEGER  N_EAST, N_WEST, N_NORTH, N_SOUTH
+      INTEGER  I, L
+C-----------------------------------------------------------------------
+C
+C  Azimuthal indices of cardinal directions.
+C
+      N_EAST = 1
+      IF (NAZ.EQ.4)  THEN
+        N_WEST  = 3       
+        N_NORTH = 2
+        N_SOUTH = 4       
+      ELSE IF (NAZ.EQ.8)  THEN
+        N_WEST  = 5       
+        N_NORTH = 3
+        N_SOUTH = 7       
+      END IF
+C
+C  Print out values for range of longitudes.
+C
+      DO 100 I = ILPRT1,ILPRT2
+C
+C  Print east-west wind, sigmas, cutoff wavenumbers, flux and drag.
+C
+        IF (IU_PRINT.EQ.1)  THEN
+          WRITE (NMESSG,*) 
+          WRITE (NMESSG,6001) I
+          WRITE (NMESSG,6005) 
+ 6001     FORMAT ( 'Hines GW (east-west) at longitude I =',I3)
+ 6005     FORMAT (15x,' U ',2x,'sig_E',2x,'sig_T',3x,'m_E',
+     &            4x,'m_W',4x,'fluxU',5x,'gwdU')
+          DO 10 L = LEVPRT1,LEVPRT2
+            WRITE (NMESSG,6701) ALT(I,L)/1.E3, V_ALPHA(I,L,N_EAST), 
+     &                          SIGMA_ALPHA(I,L,N_EAST), SIGMA_T(I,L),
+     &                          M_ALPHA(I,L,N_EAST)*1.E3, 
+     &                          M_ALPHA(I,L,N_WEST)*1.E3,
+     &                          FLUX_U(I,L)*1.E5, DRAG_U(I,L)*24.*3600.
+  10      CONTINUE
+ 6701     FORMAT (' z=',f7.2,1x,3f7.1,2f7.3,f9.4,f9.3)
+        END IF
+C
+C  Print north-south winds, sigmas, cutoff wavenumbers, flux and drag.
+C
+        IF (IV_PRINT.EQ.1)  THEN
+          WRITE(NMESSG,*) 
+          WRITE(NMESSG,6002) I
+ 6002     FORMAT ( 'Hines GW (north-south) at longitude I =',I3)
+          WRITE(NMESSG,6006) 
+ 6006     FORMAT (15x,' V ',2x,'sig_N',2x,'sig_T',3x,'m_N',
+     &            4x,'m_S',4x,'fluxV',5x,'gwdV')
+          DO 20 L = LEVPRT1,LEVPRT2
+            WRITE (NMESSG,6701) ALT(I,L)/1.E3, V_ALPHA(I,L,N_NORTH), 
+     &                          SIGMA_ALPHA(I,L,N_NORTH), SIGMA_T(I,L),
+     &                          M_ALPHA(I,L,N_NORTH)*1.E3, 
+     &                          M_ALPHA(I,L,N_SOUTH)*1.E3,
+     &                          FLUX_V(I,L)*1.E5, DRAG_V(I,L)*24.*3600.
+ 20       CONTINUE
+        END IF
+C
+ 100  CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE HINES_EXP (DATA,DATA_ZMAX,ALT,ALT_EXP,IORDER,
+     1                      IL1,IL2,LEV1,LEV2,NLONS,NLEVS)
+C
+C  This routine exponentially damps a longitude by altitude array 
+C  of data above a specified altitude.
+C
+C  Aug. 13/95 - C. McLandress
+C
+C  Output arguements:
+C
+C     * DATA = modified data array.
+C
+C  Input arguements:
+C
+C     * DATA    = original data array.
+C     * ALT     = altitudes.
+C     * ALT_EXP = altitude above which exponential decay applied.
+C     * IORDER	= 1 means vertical levels are indexed from top down 
+C     *           (i.e., highest level indexed 1 and lowest level NLEVS);
+C     *           .NE. 1 highest level is index NLEVS.
+C     * IL1     = first longitudinal index to use (IL1 >= 1).
+C     * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * LEV1    = first altitude level to use (LEV1 >=1). 
+C     * LEV2    = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+C     * NLONS   = number of longitudes.
+C     * NLEVS   = number of vertical
+C
+C  Input work arrays:
+C
+C     * DATA_ZMAX = data values just above altitude ALT_EXP.
+C
+      INTEGER  IORDER, IL1, IL2, LEV1, LEV2, NLONS, NLEVS
+      REAL  ALT_EXP
+      REAL  DATA(NLONS,NLEVS), DATA_ZMAX(NLONS), ALT(NLONS,NLEVS)
+C
+C Internal variables.
+C
+      INTEGER  LEVBOT, LEVTOP, LINCR, I, L
+      REAL  HSCALE
+      DATA  HSCALE / 5.E3 /
+C-----------------------------------------------------------------------     
+C
+C  Index of lowest altitude level (bottom of drag calculation).
+C
+      LEVBOT = LEV2
+      LEVTOP = LEV1
+      LINCR  = 1
+      IF (IORDER.NE.1)  THEN
+        LEVBOT = LEV1
+        LEVTOP = LEV2
+        LINCR  = -1
+      END IF
+C
+C  Data values at first level above ALT_EXP.
+C
+      DO 20 I = IL1,IL2
+        DO 10 L = LEVTOP,LEVBOT,LINCR
+          IF (ALT(I,L) .GE. ALT_EXP)  THEN
+            DATA_ZMAX(I) = DATA(I,L) 
+          END IF	   
+ 10     CONTINUE
+ 20   CONTINUE
+C
+C  Exponentially damp field above ALT_EXP to model top at L=1.
+C
+      DO 40 L = 1,LEV2 
+        DO 30 I = IL1,IL2
+          IF (ALT(I,L) .GE. ALT_EXP)  THEN
+            DATA(I,L) = DATA_ZMAX(I) * EXP( (ALT_EXP-ALT(I,L))/HSCALE )
+          END IF
+ 30     CONTINUE
+ 40   CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+      SUBROUTINE VERT_SMOOTH (DATA,WORK,COEFF,NSMOOTH,
+     1                        IL1,IL2,LEV1,LEV2,NLONS,NLEVS)
+C
+C  Smooth a longitude by altitude array in the vertical over a
+C  specified number of levels using a three point smoother. 
+C
+C  NOTE: input array DATA is modified on output!
+C
+C  Aug. 3/95 - C. McLandress
+C
+C  Output arguement:
+C
+C     * DATA    = smoothed array (on output).
+C
+C  Input arguements:
+C
+C     * DATA    = unsmoothed array of data (on input).
+C     * WORK    = work array of same dimension as DATA.
+C     * COEFF   = smoothing coefficient for a 1:COEFF:1 stencil.
+C     *           (e.g., COEFF = 2 will result in a smoother which
+C     *           weights the level L gridpoint by two and the two 
+C     *           adjecent levels (L+1 and L-1) by one).
+C     * NSMOOTH = number of times to smooth in vertical.
+C     *           (e.g., NSMOOTH=1 means smoothed only once, 
+C     *           NSMOOTH=2 means smoothing repeated twice, etc.)
+C     * IL1     = first longitudinal index to use (IL1 >= 1).
+C     * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+C     * LEV1    = first altitude level to use (LEV1 >=1). 
+C     * LEV2    = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+C     * NLONS   = number of longitudes.
+C     * NLEVS   = number of vertical levels.
+C
+C  Subroutine arguements.
+C
+      INTEGER  NSMOOTH, IL1, IL2, LEV1, LEV2, NLONS, NLEVS
+      REAL  COEFF
+      REAL  DATA(NLONS,NLEVS), WORK(NLONS,NLEVS)
+C
+C  Internal variables.
+C
+      INTEGER  I, L, NS, LEV1P, LEV2M
+      REAL  SUM_WTS
+C-----------------------------------------------------------------------     
+C
+C  Calculate sum of weights.
+C
+      SUM_WTS = COEFF + 2.
+C
+      LEV1P = LEV1 + 1
+      LEV2M = LEV2 - 1
+C
+C  Smooth NSMOOTH times
+C
+      DO 50 NS = 1,NSMOOTH
+C
+C  Copy data into work array.
+C
+        DO 20 L = LEV1,LEV2
+          DO 10 I = IL1,IL2
+            WORK(I,L) = DATA(I,L)
+ 10       CONTINUE
+ 20     CONTINUE
+C
+C  Smooth array WORK in vertical direction and put into DATA.
+C
+        DO 40 L = LEV1P,LEV2M
+          DO 30 I = IL1,IL2
+            DATA(I,L) = ( WORK(I,L+1) + COEFF*WORK(I,L) + WORK(I,L-1) ) 
+     &                    / SUM_WTS 
+ 30       CONTINUE
+ 40     CONTINUE
+C
+ 50   CONTINUE
+C
+      RETURN
+C-----------------------------------------------------------------------
+      END
+
+
+
+
+      
+      
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/hines_gwd.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/hines_gwd.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/hines_gwd.F90	(revision 17)
@@ -0,0 +1,2080 @@
+!
+! $Id: hines_gwd.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE HINES_GWD(NLON,NLEV,DTIME,paphm1x, papm1x,                          &
+       &      rlat,tx,ux,vx,                                                         &
+       &      zustrhi,zvstrhi,                                                       &
+       &      d_t_hin, d_u_hin, d_v_hin)
+
+!C ########################################################################
+!C Parametrization of the momentum flux deposition due to a broad band 
+!C spectrum of gravity waves, following Hines (1997a,b), as coded by 
+!C McLANDRESS (1995). Modified by McFARLANE and MANZINI (1995-1997) 
+!C                 MAECHAM model stand alone version
+!C ########################################################################
+!C 
+!C
+         USE dimphy
+         implicit none
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOEGWD.h"
+#include "YOMCST.h"
+
+      INTEGER NAZMTH
+      PARAMETER(NAZMTH=8)
+
+!C     INPUT ARGUMENTS.
+!C     ----- ----------
+!C
+!C  - 2D
+!C  PAPHM1   : HALF LEVEL PRESSURE (T-DT)
+!C  PAPM1    : FULL LEVEL PRESSURE (T-DT)
+!C  PTM1     : TEMPERATURE (T-DT)
+!C  PUM1     : ZONAL WIND (T-DT)
+!C  PVM1     : MERIDIONAL WIND (T-DT)
+!C
+
+!C     REFERENCE.
+!C     ----------
+!C         SEE MODEL DOCUMENTATION
+!C
+!C     AUTHOR.
+!C     -------
+!C
+!C      N. MCFARLANE   DKRZ-HAMBURG   MAY 1995
+!C      STAND ALONE E. MANZINI MPI-HAMBURG FEBRUARY 1997
+!C
+!C      BASED ON A COMBINATION OF THE OROGRAPHIC SCHEME BY N.MCFARLANE 1987
+!C      AND THE HINES SCHEME AS CODED BY C. MCLANDRESS 1995.                       
+!C
+!C
+!C
+!cym      INTEGER KLEVM1
+!C
+      REAL PAPHM1(klon,klev+1), PAPM1(klon,KLEV)  
+      REAL PTM1(klon,KLEV), PUM1(klon,KLEV), PVM1(klon,KLEV)
+      REAL PRFLUX(klon)
+!C1
+!C1
+!C1
+      REAL RLAT(klon),COSLAT(KLON)
+!C 
+      REAL TH(klon,KLEV),                                                            &
+       &     UTENDGW(klon,KLEV), VTENDGW(klon,KLEV),                                 &
+       &     PRESSG(klon),                                                           &
+       &     UHS(klon,KLEV),     VHS(klon,KLEV), ZPR(klon)
+
+!C     * VERTICAL POSITIONING ARRAYS.
+
+      REAL SGJ(klon,KLEV),     SHJ(klon,KLEV),                                       &
+       &     SHXKJ(klon,KLEV),   DSGJ(klon,KLEV)
+
+!C     * LOGICAL SWITCHES TO CONTROL ROOF DRAG, ENVELOP GW DRAG AND
+!C     * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG.
+!C     * LOZPR IS TRUE FOR ZPR ENHANCEMENT
+
+
+!C     * WORK ARRAYS.
+
+      REAL M_ALPHA(klon,KLEV,NAZMTH),     V_ALPHA(klon,KLEV,NAZMTH),                 &
+       &     SIGMA_ALPHA(klon,KLEV,NAZMTH),                                          &
+       &     SIGSQH_ALPHA(klon,KLEV,NAZMTH),                                         &
+       &     DRAG_U(klon,KLEV),   DRAG_V(klon,KLEV),  FLUX_U(klon,KLEV),             &
+       &     FLUX_V(klon,KLEV),   HEAT(klon,KLEV),    DIFFCO(klon,KLEV),             &
+       &     BVFREQ(klon,KLEV),   DENSITY(klon,KLEV), SIGMA_T(klon,KLEV),            &
+       &     VISC_MOL(klon,KLEV), ALT(klon,KLEV),                                    &
+       &     SIGSQMCW(klon,KLEV,NAZMTH),                                             &
+       &     SIGMATM(klon,KLEV),                                                     &
+       &     AK_ALPHA(klon,NAZMTH),       K_ALPHA(klon,NAZMTH),                      &
+       &     MMIN_ALPHA(klon,NAZMTH),     I_ALPHA(klon,NAZMTH),                      &
+       &     RMSWIND(klon), BVFBOT(klon), DENSBOT(klon)
+      REAL  SMOOTHR1(klon,KLEV), SMOOTHR2(klon,KLEV)
+      REAL  SIGALPMC(klon,KLEV,NAZMTH)      
+      REAL  F2MOD(klon,KLEV)
+      
+!C     * THES ARE THE INPUT PARAMETERS FOR HINES ROUTINE AND
+!C     * ARE SPECIFIED IN ROUTINE HINES_SETUP. SINCE THIS IS CALLED
+!C     * ONLY AT FIRST CALL TO THIS ROUTINE THESE VARIABLES MUST BE SAVED
+!C     * FOR USE AT SUBSEQUENT CALLS. THIS CAN BE AVOIDED BY CALLING
+!C     * HINES_SETUP IN MAIN PROGRAM AND PASSING THE PARAMETERS AS
+!C     * SUBROUTINE ARGUEMENTS.
+!C
+
+      REAL    RMSCON
+      INTEGER NMESSG, IPRINT, ILRMS
+      INTEGER IFL
+!C
+      INTEGER  NAZ,ICUTOFF,NSMAX,IHEATCAL
+      REAL  SLOPE,F1,F2,F3,F5,F6,KSTAR(KLON),ALT_CUTOFF,SMCO
+!C
+!C    PROVIDED AS INPUT
+!C
+      integer nlon,nlev
+
+      real dtime
+      real paphm1x(nlon,nlev+1), papm1x(nlon,nlev)
+      real ux(nlon,nlev), vx(nlon,nlev), tx(nlon,nlev)
+!c
+!c     VARIABLES FOR OUTPUT
+!c
+
+      real d_t_hin(nlon,nlev),d_u_hin(nlon,nlev),d_v_hin(nlon,nlev)
+      real zustrhi(nlon),zvstrhi(nlon) 
+
+!C
+!C     * LOGICAL SWITCHES TO CONTROL PRECIP ENHANCEMENT AND
+!C     * HINES' DOPPLER SPREADING EXTROWAVE GW DRAG.
+!C     * LOZPR IS TRUE FOR ZPR ENHANCEMENT
+!C  
+      LOGICAL LOZPR, LORMS(klon)
+!C
+!C  LOCAL PARAMETERS TO MAKE THINGS WORK (TEMPORARY VARIABLE)
+
+      REAL RHOH2O,ZPCONS,RGOCP,ZLAT,DTTDSF,RATIO,HSCAL
+      INTEGER I,J,L,JL,JK,LE,LREF,LREFP,LEVBOT
+!C
+!C  DATA PARAMETERS NEEDED, EXPLAINED LATER
+
+      REAL V0,VMIN,DMPSCAL,TAUFAC,HMIN,APIBT,CPART,FCRIT
+      REAL PCRIT,PCONS
+      INTEGER IPLEV,IERROR
+   
+!C
+!C      
+!C     PRINT *,' IT IS STARTED HINES GOING ON...'
+!C
+!C
+!C
+!C
+!C*    COMPUTATIONAL CONSTANTS.
+!C     ------------- ----------
+!C
+!C
+      d_t_hin(:,:)=0.
+      
+      RHOH2O=1000.    
+      ZPCONS = (1000.*86400.)/RHOH2O
+!cym      KLEVM1=KLEV-1
+!C
+
+        do jl=kidia,kfdia
+        PAPHM1(JL,1) = paphm1x(JL,klev+1)
+          do jk=1,klev      
+          le=klev+1-jk
+          PAPHM1(JL,JK+1) =  paphm1x(JL,le) 
+          PAPM1(JL,JK) = papm1x(JL,le)
+          PTM1(JL,JK) = tx(JL,le)
+          PUM1(JL,JK) = ux(JL,le)
+          PVM1(JL,JK) = vx(JL,le)
+          enddo
+        enddo
+!C
+  100 CONTINUE
+!C
+!C    Define constants and arrays needed for the ccc/mam gwd scheme
+!C    *Constants:
+
+      RGOCP=RD/RCPD
+      LREFP=KLEV-1
+      LREF=KLEV-2
+!C1
+!C1    *Arrays
+!C1
+      DO 2101 JK=1,KLEV
+      DO 2102 JL=KIDIA,KFDIA
+      SHJ(JL,JK)=PAPM1(JL,JK)/PAPHM1(JL,klev+1)
+      SGJ(JL,JK)=PAPM1(JL,JK)/PAPHM1(JL,klev+1)
+      DSGJ(JL,JK)=(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))/PAPHM1(JL,klev+1)
+      SHXKJ(JL,JK)=(PAPM1(JL,JK)/PAPHM1(JL,klev+1))**RGOCP 
+      TH(JL,JK)= PTM1(JL,JK)
+ 2102 CONTINUE
+ 2101 CONTINUE    
+      
+!CC
+      DO 211 JL=KIDIA,KFDIA
+      PRESSG(JL)=PAPHM1(JL,klev+1)
+  211 CONTINUE
+!C
+!C
+      DO 301 JL=KIDIA,KFDIA
+      PRFLUX(JL) = 0.0
+      ZPR(JL)=ZPCONS*PRFLUX(JL)
+      ZLAT=(RLAT(JL)/180.)*RPI
+      COSLAT(Jl)=COS(ZLAT)    
+  301 CONTINUE
+!C
+!C
+  400 CONTINUE
+!C  
+!C
+!C
+!C
+!*/#########################################################################
+!*/
+!*/
+!C
+!C     * AUG. 14/95 - C. MCLANDRESS.
+!C     * SEP.    95   N. MCFARLANE.
+!C
+!C     * THIS ROUTINE CALCULATES THE HORIZONTAL WIND TENDENCIES
+!C     * DUE TO MCFARLANE'S OROGRAPHIC GW DRAG SCHEME, HINES'
+!C     * DOPPLER SPREAD SCHEME FOR "EXTROWAVES" AND ADDS ON
+!C     * ROOF DRAG. IT IS BASED ON THE ROUTINE GWDFLX8.
+!C
+!C     * LREFP IS THE INDEX OF THE MODEL LEVEL BELOW THE REFERENCE LEVEL
+!C     * I/O ARRAYS PASSED FROM MAIN.
+!C     * (PRESSG = SURFACE PRESSURE)
+!C
+!C
+!C
+!C
+!C     * CONSTANTS VALUES DEFINED IN DATA STATEMENT ARE :
+!C     * VMIN     = MIMINUM WIND IN THE DIRECTION OF REFERENCE LEVEL
+!C     *            WIND BEFORE WE CONSIDER BREAKING TO HAVE OCCURED.
+!C     * DMPSCAL  = DAMPING TIME FOR GW DRAG IN SECONDS.
+!C     * TAUFAC   = 1/(LENGTH SCALE).
+!C     * HMIN     = MIMINUM ENVELOPE HEIGHT REQUIRED TO PRODUCE GW DRAG.
+!C     * V0       = VALUE OF WIND THAT APPROXIMATES ZERO.
+
+
+      DATA    VMIN  /    5.0 /, V0       / 1.E-10 /,                                 &
+       &        TAUFAC/  5.E-6 /, HMIN     /   40000. /,                             &
+       &        DMPSCAL  / 6.5E+6 /, APIBT / 1.5708 /,                               &
+       &        CPART /    0.7 /, FCRIT    / 1. /
+
+!C     * HINES EXTROWAVE GWD CONSTANTS DEFINED IN DATA STATEMENT ARE:
+!C     * RMSCON = ROOT MEAN SQUARE GRAVITY WAVE WIND AT LOWEST LEVEL (M/S).
+!C     * NMESSG  = UNIT NUMBER FOR PRINTED MESSAGES.
+!C     * IPRINT  = 1 TO DO PRINT OUT SOME HINES ARRAYS.
+!C     * IFL     = FIRST CALL FLAG TO HINES_SETUP ("SAVE" IT)
+!C     * PCRIT = CRITICAL VALUE OF ZPR (MM/D)
+!C     * IPLEV = LEVEL OF APPLICATION OF PRCIT
+!C     * PCONS = FACTOR OF ZPR ENHANCEMENT
+!C
+
+      DATA PCRIT / 5. /, PCONS / 4.75 /
+
+      IPLEV = LREFP-1
+!C
+      DATA    RMSCON  / 1.00 /                                                       &
+       &        IPRINT   /  2  /, NMESSG  /   6   /
+      DATA    IFL / 0 /
+!C
+      LOZPR = .FALSE.
+!C
+!C-----------------------------------------------------------------------
+!C
+!C
+!C
+!C     * SET ERROR FLAG
+
+      IERROR = 0
+
+!C     * SPECIFY VARIOUS PARAMETERS FOR HINES ROUTINE AT VERY FIRST CALL.
+!C     * (NOTE THAT ARRAY K_ALPHA IS SPECIFIED SO MAKE SURE THAT
+!C     * IT IS NOT OVERWRITTEN LATER ON).
+!C
+        CALL HINES_SETUP (NAZ,SLOPE,F1,F2,F3,F5,F6,KSTAR,                            &
+       &                    ICUTOFF,ALT_CUTOFF,SMCO,NSMAX,IHEATCAL,                  &
+       &                   K_ALPHA,IERROR,NMESSG,klon,NAZMTH,COSLAT)
+        IF (IERROR.NE.0)  GO TO 999
+!C
+!C     * START GWD CALCULATIONS.
+
+      LREF  = LREFP-1
+
+!C
+      DO 105 J=1,NAZMTH
+      DO 105 L=1,KLEV
+      DO 105 I=kidia,klon
+        SIGSQMCW(I,L,J) = 0.
+  105 CONTINUE
+!c
+
+
+!C     * INITIALIZE NECESSARY ARRAYS.
+!C
+      DO 120 L=1,KLEV
+      DO 120 I=KIDIA,KFDIA
+        UTENDGW(I,L) = 0.
+        VTENDGW(I,L) = 0.
+
+        UHS(I,L) = 0.
+        VHS(I,L) = 0.
+
+ 120  CONTINUE
+!C
+!C     * IF USING HINES SCHEME THEN CALCULATE B V FREQUENCY AT ALL POINTS
+!C     * AND SMOOTH BVFREQ.
+
+        DO 130 L=2,KLEV
+        DO 130 I=KIDIA,KFDIA
+          DTTDSF=(TH(I,L)/SHXKJ(I,L)-TH(I,L-1)/                                      &
+       &            SHXKJ(I,L-1))/(SHJ(I,L)-SHJ(I,L-1))
+          DTTDSF=MIN(DTTDSF, -5./SGJ(I,L))
+          BVFREQ(I,L)=SQRT(-DTTDSF*SGJ(I,L)*(SGJ(I,L)**RGOCP)/RD)                    &
+       &                     *RG/PTM1(I,L)
+  130   CONTINUE
+        DO 135 L=1,KLEV
+        DO 135 I=KIDIA,KFDIA
+          IF(L.EQ.1)                        THEN
+            BVFREQ(I,L) = BVFREQ(I,L+1)
+          ENDIF
+          IF(L.GT.1)                        THEN
+            RATIO=5.*LOG(SGJ(I,L)/SGJ(I,L-1))
+            BVFREQ(I,L) = (BVFREQ(I,L-1) + RATIO*BVFREQ(I,L))                        &
+       &                       /(1.+RATIO)
+          ENDIF
+  135   CONTINUE
+!C
+!C
+  300 CONTINUE
+
+!C     * CALCULATE GW DRAG DUE TO HINES' EXTROWAVES
+!C     * SET MOLECULAR VISCOSITY TO A VERY SMALL VALUE.
+!C     * IF THE MODEL TOP IS GREATER THAN 100 KM THEN THE ACTUAL
+!C     * VISCOSITY COEFFICIENT COULD BE SPECIFIED HERE.
+
+      DO 310 L=1,KLEV
+      DO 310 I=KIDIA,KFDIA
+         VISC_MOL(I,L) = 1.5E-5
+         DRAG_U(I,L) = 0.
+         DRAG_V(I,L) = 0.
+         FLUX_U(I,L) = 0.
+         FLUX_V(I,L) = 0.
+         HEAT(I,L)   = 0.
+         DIFFCO(I,L) = 0.
+ 310  CONTINUE
+
+!C     * ALTITUDE AND DENSITY AT BOTTOM.
+
+      DO 330 I=KIDIA,KFDIA
+         HSCAL = RD * PTM1(I,KLEV) / RG
+         DENSITY(I,KLEV) = SGJ(I,KLEV) * PRESSG(I) / (RG*HSCAL)
+         ALT(I,KLEV) = 0.
+  330 CONTINUE
+
+!C     * ALTITUDE AND DENSITY AT REMAINING LEVELS.
+
+      DO 340 L=KLEV-1,1,-1
+      DO 340 I=KIDIA,KFDIA
+         HSCAL = RD * PTM1(I,L) / RG
+         ALT(I,L) = ALT(I,L+1) + HSCAL * DSGJ(I,L) / SGJ(I,L)
+         DENSITY(I,L) = SGJ(I,L) * PRESSG(I) / (RG*HSCAL)
+  340 CONTINUE
+
+!C
+!C     * INITIALIZE SWITCHES FOR HINES GWD CALCULATION
+!C
+      ILRMS = 0
+!C
+      DO 345 I=KIDIA,KFDIA 
+      LORMS(I) = .FALSE.
+  345 CONTINUE 
+!C
+!C
+!C     * DEFILE BOTTOM LAUNCH LEVEL
+!C
+      LEVBOT = IPLEV
+!C
+!C     * BACKGROUND WIND MINUS VALUE AT BOTTOM LAUNCH LEVEL.
+!C
+      DO 351 L=1,LEVBOT
+      DO 351 I=KIDIA,KFDIA 
+      UHS(I,L) = PUM1(I,L) - PUM1(I,LEVBOT)
+      VHS(I,L) = PVM1(I,L) - PVM1(I,LEVBOT)
+  351 CONTINUE
+!C
+!C     * SPECIFY ROOT MEAN SQUARE WIND AT BOTTOM LAUNCH LEVEL.
+!C
+       DO 355 I=KIDIA,KFDIA 
+       RMSWIND(I) = RMSCON
+  355  CONTINUE
+
+      IF (LOZPR) THEN
+        DO 350 I=KIDIA,KFDIA 
+        IF (ZPR(I) .GT. PCRIT) THEN
+          RMSWIND(I) = RMSCON                                                        &
+       &                +( (ZPR(I)-PCRIT)/ZPR(I) )*PCONS
+        ENDIF
+  350   CONTINUE
+      ENDIF
+!C
+      DO 356 I=KIDIA,KFDIA 
+      IF (RMSWIND(I) .GT. 0.0) THEN
+      ILRMS = ILRMS+1
+      LORMS(I) = .TRUE.
+      ENDIF
+  356 CONTINUE
+!C
+!C     * CALCULATE GWD (NOTE THAT DIFFUSION COEFFICIENT AND
+!C     * HEATING RATE ONLY CALCULATED IF IHEATCAL = 1).
+!C
+      IF ( ILRMS.GT.0 )       THEN                    
+!C
+      CALL HINES_EXTRO0 (DRAG_U,DRAG_V,HEAT,DIFFCO,FLUX_U,FLUX_V,                    &
+       &                   UHS,VHS,BVFREQ,DENSITY,VISC_MOL,ALT,                      &
+       &                   RMSWIND,K_ALPHA,M_ALPHA,V_ALPHA,                          &
+       &                   SIGMA_ALPHA,SIGSQH_ALPHA,AK_ALPHA,                        &
+       &                   MMIN_ALPHA,I_ALPHA,SIGMA_T,DENSBOT,BVFBOT,                &
+       &                   1,IHEATCAL,ICUTOFF,IPRINT,NSMAX,                          &
+       &                   SMCO,ALT_CUTOFF,KSTAR,SLOPE,                              &
+       &                   F1,F2,F3,F5,F6,NAZ,SIGSQMCW,SIGMATM,                      &
+       &                   KIDIA,klon,1,LEVBOT,KLON,KLEV,NAZMTH,                     &
+       &                   LORMS,SMOOTHR1,SMOOTHR2,                                  &
+       &                   SIGALPMC,F2MOD)
+
+!C     * ADD ON HINES' GWD TENDENCIES TO OROGRAPHIC TENDENCIES AND
+!C     * APPLY HINES' GW DRAG ON (UROW,VROW) WORK ARRAYS.
+
+      DO 360 L=1,KLEV
+      DO 360 I=KIDIA,KFDIA
+         UTENDGW(I,L) = UTENDGW(I,L) + DRAG_U(I,L)
+         VTENDGW(I,L) = VTENDGW(I,L) + DRAG_V(I,L)
+  360 CONTINUE
+!C
+
+!C     * END OF HINES CALCULATIONS.
+!C
+      ENDIF
+!C
+  500 CONTINUE
+
+
+!C-----------------------------------------------------------------------
+!C
+        do jl=kidia,kfdia
+          zustrhi(jl)=FLUX_U(jl,1)
+          zvstrhi(jl)=FLUX_v(jl,1)
+          do jk=1,klev
+          le=klev-jk+1
+          d_u_hin(jl,JK) =  UTENDGW(jl,le) * dtime
+          d_v_hin(jl,JK) =  VTENDGW(jl,le) * dtime
+          enddo
+        enddo
+
+!c     PRINT *,'UTENDGW:',UTENDGW
+
+!C     PRINT *,' HINES HAS BEEN COMPLETED (LONG ISNT IT...)'
+
+      RETURN
+ 999  CONTINUE
+
+!C     * IF ERROR DETECTED THEN ABORT.
+
+      WRITE (NMESSG,6000)
+      WRITE (NMESSG,6010) IERROR
+ 6000 FORMAT (/' EXECUTION ABORTED IN GWDOREXV')
+ 6010 FORMAT ('     ERROR FLAG =',I4)
+
+!C
+      RETURN
+      END SUBROUTINE HINES_GWD
+!*/
+!*/
+
+
+      SUBROUTINE HINES_EXTRO0 (DRAG_U,DRAG_V,HEAT,DIFFCO,FLUX_U,FLUX_V,              &
+       &                         VEL_U,VEL_V,BVFREQ,DENSITY,VISC_MOL,ALT,            &
+       &                         RMSWIND,K_ALPHA,M_ALPHA,V_ALPHA,                    &
+       &                         SIGMA_ALPHA,SIGSQH_ALPHA,AK_ALPHA,                  &
+       &                         MMIN_ALPHA,I_ALPHA,SIGMA_T,DENSB,BVFB,              &
+       &                         IORDER,IHEATCAL,ICUTOFF,IPRINT,NSMAX,               &
+       &                         SMCO,ALT_CUTOFF,KSTAR,SLOPE,                        &
+       &                         F1,F2,F3,F5,F6,NAZ,SIGSQMCW,SIGMATM,                &
+       &                         IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH,               &
+       &                         LORMS,SMOOTHR1,SMOOTHR2,                            &
+       &                         SIGALPMC,F2MOD)
+
+       implicit none
+!C
+!C  Main routine for Hines' "extrowave" gravity wave parameterization based
+!C  on Hines' Doppler spread theory. This routine calculates zonal
+!C  and meridional components of gravity wave drag, heating rates
+!C  and diffusion coefficient on a longitude by altitude grid.
+!C  No "mythical" lower boundary region calculation is made so it
+!C  is assumed that lowest level winds are weak (i.e, approximately zero).
+!C
+!C  Aug. 13/95 - C. McLandress
+!C  SEPT. /95  - N.McFarlane
+!C
+!C  Modifications:
+!C
+!C  Output arguements:
+!C
+!C     * DRAG_U = zonal component of gravity wave drag (m/s^2).
+!C     * DRAG_V = meridional component of gravity wave drag (m/s^2).
+!C     * HEAT   = gravity wave heating (K/sec).
+!C     * DIFFCO = diffusion coefficient (m^2/sec)
+!C     * FLUX_U = zonal component of vertical momentum flux (Pascals)
+!C     * FLUX_V = meridional component of vertical momentum flux (Pascals)
+!C
+!C  Input arguements:
+!C
+!C     * VEL_U      = background zonal wind component (m/s).
+!C     * VEL_V      = background meridional wind component (m/s).
+!C     * BVFREQ     = background Brunt Vassala frequency (radians/sec).
+!C     * DENSITY    = background density (kg/m^3) 
+!C     * VISC_MOL   = molecular viscosity (m^2/s)
+!C     * ALT        = altitude of momentum, density, buoyancy levels (m)
+!C     *              (NOTE: levels ordered so that ALT(I,1) > ALT(I,2), etc.)
+!C     * RMSWIND   = root mean square gravity wave wind at lowest level (m/s).
+!C     * K_ALPHA    = horizontal wavenumber of each azimuth (1/m).
+!C     * IORDER	   = 1 means vertical levels are indexed from top down 
+!C     *              (i.e., highest level indexed 1 and lowest level NLEVS);
+!C     *           .NE. 1 highest level is index NLEVS.
+!C     * IHEATCAL   = 1 to calculate heating rates and diffusion coefficient.
+!C     * IPRINT     = 1 to print out various arrays.
+!C     * ICUTOFF    = 1 to exponentially damp GWD, heating and diffusion 
+!C     *              arrays above ALT_CUTOFF; otherwise arrays not modified.
+!C     * ALT_CUTOFF = altitude in meters above which exponential decay applied.
+!C     * SMCO       = smoothing factor used to smooth cutoff vertical 
+!C     *              wavenumbers and total rms winds in vertical direction
+!C     *              before calculating drag or heating
+!C     *              (SMCO >= 1 ==> 1:SMCO:1 stencil used).
+!C     * NSMAX      = number of times smoother applied ( >= 1),
+!C     *            = 0 means no smoothing performed.
+!C     * KSTAR      = typical gravity wave horizontal wavenumber (1/m).
+!C     * SLOPE      = slope of incident vertical wavenumber spectrum
+!C     *              (SLOPE must equal 1., 1.5 or 2.).
+!C     * F1 to F6   = Hines's fudge factors (F4 not needed since used for
+!C     *              vertical flux of vertical momentum).
+!C     * NAZ        = actual number of horizontal azimuths used.
+!C     * IL1        = first longitudinal index to use (IL1 >= 1).
+!C     * IL2        = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+!C     * LEV1       = index of first level for drag calculation.
+!C     * LEV2       = index of last level for drag calculation 
+!C     *              (i.e., LEV1 < LEV2 <= NLEVS).
+!C     * NLONS      = number of longitudes.
+!C     * NLEVS      = number of vertical levels.
+!C     * NAZMTH     = azimuthal array dimension (NAZMTH >= NAZ).
+!C 
+!C  Work arrays.
+!C
+!C     * M_ALPHA      = cutoff vertical wavenumber (1/m).
+!C     * V_ALPHA      = wind component at each azimuth (m/s) and if IHEATCAL=1
+!C     *                holds vertical derivative of cutoff wavenumber.
+!C     * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
+!C     * SIGSQH_ALPHA = portion of wind variance from waves having wave
+!C     *                normals in the alpha azimuth (m/s).
+!C     * SIGMA_T      = total rms horizontal wind (m/s).
+!C     * AK_ALPHA     = spectral amplitude factor at each azimuth 
+!C     *                (i.e.,{AjKj}) in m^4/s^2.
+!C     * I_ALPHA      = Hines' integral.
+!C     * MMIN_ALPHA   = minimum value of cutoff wavenumber.
+!C     * DENSB        = background density at bottom level.
+!C     * BVFB         = buoyancy frequency at bottom level and
+!C     *                work array for ICUTOFF = 1.
+!C
+!C     * LORMS       = .TRUE. for drag computation 
+!C
+      INTEGER  NAZ, NLONS, NLEVS, NAZMTH, IL1, IL2, LEV1, LEV2
+      INTEGER  ICUTOFF, NSMAX, IORDER, IHEATCAL, IPRINT
+      REAL  KSTAR(NLONS), F1, F2, F3, F5, F6, SLOPE
+      REAL  ALT_CUTOFF, SMCO
+      REAL  DRAG_U(NLONS,NLEVS),   DRAG_V(NLONS,NLEVS) 
+      REAL  HEAT(NLONS,NLEVS),     DIFFCO(NLONS,NLEVS)
+      REAL  FLUX_U(NLONS,NLEVS),   FLUX_V(NLONS,NLEVS)
+      REAL  VEL_U(NLONS,NLEVS),    VEL_V(NLONS,NLEVS)
+      REAL  BVFREQ(NLONS,NLEVS),   DENSITY(NLONS,NLEVS)
+      REAL  VISC_MOL(NLONS,NLEVS), ALT(NLONS,NLEVS)
+      REAL  RMSWIND(NLONS),       BVFB(NLONS),   DENSB(NLONS)
+      REAL  SIGMA_T(NLONS,NLEVS), SIGSQMCW(NLONS,NLEVS,NAZMTH)
+      REAL  SIGMA_ALPHA(NLONS,NLEVS,NAZMTH), SIGMATM(NLONS,NLEVS)
+      REAL  SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH), V_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  AK_ALPHA(NLONS,NAZMTH),      K_ALPHA(NLONS,NAZMTH)
+      REAL  MMIN_ALPHA(NLONS,NAZMTH) ,   I_ALPHA(NLONS,NAZMTH)
+      REAL  SMOOTHR1(NLONS,NLEVS), SMOOTHR2(NLONS,NLEVS)
+      REAL  SIGALPMC(NLONS,NLEVS,NAZMTH)
+      REAL  F2MOD(NLONS,NLEVS)
+!C
+      LOGICAL LORMS(NLONS)
+!C
+!C  Internal variables.
+!C
+      INTEGER  LEVBOT, LEVTOP, I, N, L, LEV1P, LEV2M
+      INTEGER  ILPRT1, ILPRT2
+!C----------------------------------------------------------------------- 
+!C
+!C     PRINT *,' IN HINES_EXTRO0'
+      LEV1P = LEV1 + 1
+      LEV2M = LEV2 - 1
+!C
+!C  Index of lowest altitude level (bottom of drag calculation).
+!C
+      LEVBOT = LEV2
+      LEVTOP = LEV1
+      IF (IORDER.NE.1)  THEN
+      write(6,1)
+   1  format(2x,' error: IORDER NOT ONE! ')
+      END IF
+!C
+!C  Buoyancy and density at bottom level.
+!C
+      DO 10 I = IL1,IL2
+        BVFB(I)  = BVFREQ(I,LEVBOT)
+        DENSB(I) = DENSITY(I,LEVBOT)
+ 10   CONTINUE
+!C
+!C  initialize some variables
+!C
+      DO 20 N = 1,NAZ
+      DO 20 L=LEV1,LEV2
+      DO 20 I=IL1,IL2
+      M_ALPHA(I,L,N) = 0.0
+  20  CONTINUE
+      DO 21 L=LEV1,LEV2
+      DO 21 I=IL1,IL2
+      SIGMA_T(I,L) = 0.0
+  21  CONTINUE
+      DO 22 N = 1,NAZ
+      DO 22 I=IL1,IL2
+      I_ALPHA(I,N) = 0.0
+  22  CONTINUE 
+!C
+!C  Compute azimuthal wind components from zonal and meridional winds.
+!C
+      CALL HINES_WIND ( V_ALPHA,                                                     &
+       &                  VEL_U, VEL_V, NAZ,                                         &
+       &                  IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH )
+!C
+!C  Calculate cutoff vertical wavenumber and velocity variances.
+!C
+      CALL HINES_WAVNUM ( M_ALPHA, SIGMA_ALPHA, SIGSQH_ALPHA, SIGMA_T,               &
+       &                    AK_ALPHA, V_ALPHA, VISC_MOL, DENSITY, DENSB,             &
+       &                    BVFREQ, BVFB, RMSWIND, I_ALPHA, MMIN_ALPHA,              &
+       &                    KSTAR, SLOPE, F1, F2, F3, NAZ, LEVBOT,                   &
+       &                    LEVTOP,IL1,IL2,NLONS,NLEVS,NAZMTH, SIGSQMCW,             &
+       &                    SIGMATM,LORMS,SIGALPMC,F2MOD)
+!C
+!C  Smooth cutoff wavenumbers and total rms velocity in the vertical 
+!C  direction NSMAX times, using FLUX_U as temporary work array.
+!C   
+      IF (NSMAX.GT.0)  THEN
+        DO 80 N = 1,NAZ
+          DO 81 L=LEV1,LEV2
+          DO 81 I=IL1,IL2
+          SMOOTHR1(I,L) = M_ALPHA(I,L,N)
+ 81       CONTINUE 
+             CALL VERT_SMOOTH (SMOOTHR1,                                             &
+       &                       SMOOTHR2, SMCO, NSMAX,                                &
+       &                       IL1, IL2, LEV1, LEV2, NLONS, NLEVS )
+        DO 83 L=LEV1,LEV2
+        DO 83 I=IL1,IL2
+        M_ALPHA(I,L,N) = SMOOTHR1(I,L)
+ 83     CONTINUE
+ 80     CONTINUE
+        CALL VERT_SMOOTH ( SIGMA_T,                                                  &
+       &                     SMOOTHR2, SMCO, NSMAX,                                  &
+       &                     IL1, IL2, LEV1, LEV2, NLONS, NLEVS )
+      END IF
+!C
+!C  Calculate zonal and meridional components of the
+!C  momentum flux and drag.
+!C
+      CALL HINES_FLUX ( FLUX_U, FLUX_V, DRAG_U, DRAG_V,                              &
+       &                  ALT, DENSITY, DENSB, M_ALPHA,                              &
+       &                  AK_ALPHA, K_ALPHA, SLOPE, NAZ,                             &
+       &                  IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH,                &
+       &                  LORMS)
+!C
+!C  Cutoff drag above ALT_CUTOFF, using BVFB as temporary work array.
+!C
+      IF (ICUTOFF.EQ.1)  THEN		
+        CALL HINES_EXP ( DRAG_U,                                                     &
+       &                   BVFB, ALT, ALT_CUTOFF, IORDER,                            &
+       &                   IL1, IL2, LEV1, LEV2, NLONS, NLEVS )
+        CALL HINES_EXP ( DRAG_V,                                                     &
+       &                   BVFB, ALT, ALT_CUTOFF, IORDER,                            &
+       &                   IL1, IL2, LEV1, LEV2, NLONS, NLEVS )
+      END IF   
+!C
+!C  Print out various arrays for diagnostic purposes.
+!C
+      IF (IPRINT.EQ.1)  THEN
+        ILPRT1 = 15
+        ILPRT2 = 16
+        CALL HINES_PRINT ( FLUX_U, FLUX_V, DRAG_U, DRAG_V, ALT,                      &
+       &                     SIGMA_T, SIGMA_ALPHA, V_ALPHA, M_ALPHA,                 &
+       &                     1, 1, 6, ILPRT1, ILPRT2, LEV1, LEV2,                    &
+       &                     NAZ, NLONS, NLEVS, NAZMTH)
+      END IF
+!C
+!C  If not calculating heating rate and diffusion coefficient then finished.
+!C
+      IF (IHEATCAL.NE.1)  RETURN
+!C
+!C  Calculate vertical derivative of cutoff wavenumber (store
+!C  in array V_ALPHA) using centered differences at interior gridpoints
+!C  and one-sided differences at first and last levels.
+!C 
+      DO 130 N = 1,NAZ
+        DO 100 L = LEV1P,LEV2M
+          DO 90 I = IL1,IL2
+            V_ALPHA(I,L,N) = ( M_ALPHA(I,L+1,N) - M_ALPHA(I,L-1,N) )                 &
+       &                       / ( ALT(I,L+1) - ALT(I,L-1) )
+  90      CONTINUE
+ 100    CONTINUE
+        DO 110 I = IL1,IL2
+          V_ALPHA(I,LEV1,N) = ( M_ALPHA(I,LEV1P,N) - M_ALPHA(I,LEV1,N) )             &
+       &                       / ( ALT(I,LEV1P) - ALT(I,LEV1) )
+ 110    CONTINUE
+        DO 120 I = IL1,IL2
+          V_ALPHA(I,LEV2,N) = ( M_ALPHA(I,LEV2,N) - M_ALPHA(I,LEV2M,N) )             &
+       &                       / ( ALT(I,LEV2) - ALT(I,LEV2M) )
+ 120    CONTINUE
+ 130  CONTINUE
+!C
+!C  Heating rate and diffusion coefficient.
+!C
+      CALL HINES_HEAT ( HEAT, DIFFCO,                                                &
+       &                  M_ALPHA, V_ALPHA, AK_ALPHA, K_ALPHA,                       &
+       &                  BVFREQ, DENSITY, DENSB, SIGMA_T, VISC_MOL,                 &
+       &                  KSTAR, SLOPE, F2, F3, F5, F6, NAZ,                         &
+       &                  IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH)
+!C
+!C  Finished.
+!C
+      RETURN
+!C-----------------------------------------------------------------------
+      END SUBROUTINE HINES_EXTRO0
+
+      SUBROUTINE HINES_WAVNUM (M_ALPHA,SIGMA_ALPHA,SIGSQH_ALPHA,SIGMA_T,             &
+       &                         AK_ALPHA,V_ALPHA,VISC_MOL,DENSITY,DENSB,            &
+       &                         BVFREQ,BVFB,RMS_WIND,I_ALPHA,MMIN_ALPHA,            &
+       &                         KSTAR,SLOPE,F1,F2,F3,NAZ,LEVBOT,LEVTOP,             &
+       &                         IL1,IL2,NLONS,NLEVS,NAZMTH,SIGSQMCW,                &
+       &                         SIGMATM,LORMS,SIGALPMC,F2MOD)
+!C
+!C  This routine calculates the cutoff vertical wavenumber and velocity
+!C  variances on a longitude by altitude grid for the Hines' Doppler 
+!C  spread gravity wave drag parameterization scheme.
+!C  NOTE: (1) only values of four or eight can be used for # azimuths (NAZ).
+!C        (2) only values of 1.0, 1.5 or 2.0 can be used for slope (SLOPE). 
+!C
+!C  Aug. 10/95 - C. McLandress
+!C
+!C  Output arguements:
+!C
+!C     * M_ALPHA      = cutoff wavenumber at each azimuth (1/m).
+!C     * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
+!C     * SIGSQH_ALPHA = portion of wind variance from waves having wave
+!C     *                normals in the alpha azimuth (m/s).
+!C     * SIGMA_T      = total rms horizontal wind (m/s).
+!C     * AK_ALPHA     = spectral amplitude factor at each azimuth 
+!C     *                (i.e.,{AjKj}) in m^4/s^2.
+!C
+!C  Input arguements:
+!C
+!C     * V_ALPHA  = wind component at each azimuth (m/s). 
+!C     * VISC_MOL = molecular viscosity (m^2/s)
+!C     * DENSITY  = background density (kg/m^3).
+!C     * DENSB    = background density at model bottom (kg/m^3).
+!C     * BVFREQ   = background Brunt Vassala frequency (radians/sec).
+!C     * BVFB     = background Brunt Vassala frequency at model bottom.
+!C     * RMS_WIND = root mean square gravity wave wind at lowest level (m/s).
+!C     * KSTAR    = typical gravity wave horizontal wavenumber (1/m).
+!C     * SLOPE    = slope of incident vertical wavenumber spectrum
+!C     *            (SLOPE = 1., 1.5 or 2.).
+!C     * F1,F2,F3 = Hines's fudge factors.
+!C     * NAZ      = actual number of horizontal azimuths used (4 or 8).
+!C     * LEVBOT   = index of lowest vertical level.
+!C     * LEVTOP   = index of highest vertical level 
+!C     *            (NOTE: if LEVTOP < LEVBOT then level index 
+!C     *             increases from top down).
+!C     * IL1      = first longitudinal index to use (IL1 >= 1).
+!C     * IL2      = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+!C     * NLONS    = number of longitudes.
+!C     * NLEVS    = number of vertical levels.
+!C     * NAZMTH   = azimuthal array dimension (NAZMTH >= NAZ).
+!C
+!C     * LORMS       = .TRUE. for drag computation 
+!C
+!C  Input work arrays:
+!C
+!C     * I_ALPHA    = Hines' integral at a single level.
+!C     * MMIN_ALPHA = minimum value of cutoff wavenumber.
+!C
+      INTEGER  NAZ, LEVBOT, LEVTOP, IL1, IL2, NLONS, NLEVS, NAZMTH
+      REAL  SLOPE, KSTAR(NLONS), F1, F2, F3
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  SIGMA_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  SIGALPMC(NLONS,NLEVS,NAZMTH)
+      REAL  SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  SIGSQMCW(NLONS,NLEVS,NAZMTH)
+      REAL  SIGMA_T(NLONS,NLEVS)
+      REAL  SIGMATM(NLONS,NLEVS)
+      REAL  AK_ALPHA(NLONS,NAZMTH)
+      REAL  V_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  VISC_MOL(NLONS,NLEVS)
+      REAL  F2MOD(NLONS,NLEVS)
+      REAL  DENSITY(NLONS,NLEVS),  DENSB(NLONS)
+      REAL  BVFREQ(NLONS,NLEVS),   BVFB(NLONS),  RMS_WIND(NLONS)
+      REAL  I_ALPHA(NLONS,NAZMTH), MMIN_ALPHA(NLONS,NAZMTH)
+!C
+      LOGICAL LORMS(NLONS)
+!C
+!C Internal variables.
+!C
+      INTEGER  I, L, N, LSTART, LEND, LINCR, LBELOW
+      REAL  M_SUB_M_TURB, M_SUB_M_MOL, M_TRIAL
+      REAL  VISC, VISC_MIN, AZFAC, SP1
+
+!cc      REAL  N_OVER_M(1000), SIGFAC(1000)
+
+      REAL  N_OVER_M(NLONS), SIGFAC(NLONS)
+      DATA  VISC_MIN / 1.E-10 / 
+!C-----------------------------------------------------------------------     
+!C
+
+!C     PRINT *,'IN HINES_WAVNUM'
+      SP1 = SLOPE + 1.
+!C
+!C  Indices of levels to process.
+!C
+      IF (LEVBOT.GT.LEVTOP)  THEN
+        LSTART = LEVBOT - 1     
+        LEND   = LEVTOP         
+        LINCR  = -1
+      ELSE
+      write(6,1)
+   1  format(2x,' error: IORDER NOT ONE! ')
+      END IF
+!C
+!C  Use horizontal isotropy to calculate azimuthal variances at bottom level.
+!C
+      AZFAC = 1. / REAL(NAZ)
+      DO 20 N = 1,NAZ
+        DO 10 I = IL1,IL2
+          SIGSQH_ALPHA(I,LEVBOT,N) = AZFAC * RMS_WIND(I)**2
+ 10     CONTINUE
+ 20   CONTINUE
+!C
+!C  Velocity variances at bottom level.
+!C
+      CALL HINES_SIGMA ( SIGMA_T, SIGMA_ALPHA,                                       &
+       &                   SIGSQH_ALPHA, NAZ, LEVBOT,                                &
+       &                   IL1, IL2, NLONS, NLEVS, NAZMTH)
+!c
+      CALL HINES_SIGMA ( SIGMATM, SIGALPMC,                                          &
+       &                   SIGSQMCW, NAZ, LEVBOT,                                    &
+       &                   IL1, IL2, NLONS, NLEVS, NAZMTH) 
+!C
+!C  Calculate cutoff wavenumber and spectral amplitude factor 
+!C  at bottom level where it is assumed that background winds vanish
+!C  and also initialize minimum value of cutoff wavnumber.
+!C
+      DO 40 N = 1,NAZ
+        DO 30 I = IL1,IL2
+        IF (LORMS(I)) THEN
+          M_ALPHA(I,LEVBOT,N) =  BVFB(I) /                                           &
+       &                           ( F1 * SIGMA_ALPHA(I,LEVBOT,N)                    &
+       &                           + F2 * SIGMA_T(I,LEVBOT) )
+          AK_ALPHA(I,N)   = SIGSQH_ALPHA(I,LEVBOT,N)                                 &
+       &                      / ( M_ALPHA(I,LEVBOT,N)**SP1 / SP1 )
+          MMIN_ALPHA(I,N) = M_ALPHA(I,LEVBOT,N)
+        ENDIF
+ 30     CONTINUE
+ 40   CONTINUE
+!C
+!C  Calculate quantities from the bottom upwards, 
+!C  starting one level above bottom.
+!C
+      DO 150 L = LSTART,LEND,LINCR
+!C
+!C  Level beneath present level.
+!C
+        LBELOW = L - LINCR 
+!C
+!C  Calculate N/m_M where m_M is maximum permissible value of the vertical
+!C  wavenumber (i.e., m > m_M are obliterated) and N is buoyancy frequency.
+!C  m_M is taken as the smaller of the instability-induced 
+!C  wavenumber (M_SUB_M_TURB) and that imposed by molecular viscosity
+!C  (M_SUB_M_MOL). Since variance at this level is not yet known
+!C  use value at level below.
+!C
+        DO 50 I = IL1,IL2
+        IF (LORMS(I)) THEN
+!c
+        F2MFAC=SIGMATM(I,LBELOW)**2
+        F2MOD(I,LBELOW) =1.+ 2.*F2MFAC                                               &
+       &                      / ( F2MFAC+SIGMA_T(I,LBELOW)**2 )
+!c
+         VISC = AMAX1 ( VISC_MOL(I,L), VISC_MIN )
+         M_SUB_M_TURB = BVFREQ(I,L)                                                  &
+       &                 / ( F2 *F2MOD(I,LBELOW)*SIGMA_T(I,LBELOW))
+         M_SUB_M_MOL = (BVFREQ(I,L)*KSTAR(I)/VISC)**0.33333333/F3
+          IF (M_SUB_M_TURB .LT. M_SUB_M_MOL)  THEN
+            N_OVER_M(I) = F2 *F2MOD(I,LBELOW)*SIGMA_T(I,LBELOW)
+          ELSE
+            N_OVER_M(I) = BVFREQ(I,L) / M_SUB_M_MOL 
+          END IF
+        ENDIF
+  50    CONTINUE
+!C
+!C  Calculate cutoff wavenumber at this level.
+!C
+        DO 70 N = 1,NAZ
+          DO 60 I = IL1,IL2
+          IF (LORMS(I)) THEN
+!C
+!C  Calculate trial value (since variance at this level is not yet known
+!C  use value at level below). If trial value is negative or if it exceeds 
+!C  minimum value (not permitted) then set it to minimum value. 
+!C                                                                      
+            M_TRIAL = BVFB(I) / ( F1 * ( SIGMA_ALPHA(I,LBELOW,N)+                    &
+       &       SIGALPMC(I,LBELOW,N)) + N_OVER_M(I) + V_ALPHA(I,L,N) )
+            IF (M_TRIAL.LE.0. .OR. M_TRIAL.GT.MMIN_ALPHA(I,N))  THEN
+              M_TRIAL = MMIN_ALPHA(I,N)
+            END IF
+            M_ALPHA(I,L,N) = M_TRIAL
+!C
+!C  Reset minimum value of cutoff wavenumber if necessary.
+!C
+            IF (M_ALPHA(I,L,N) .LT. MMIN_ALPHA(I,N))  THEN
+              MMIN_ALPHA(I,N) = M_ALPHA(I,L,N)
+            END IF
+!C
+          ENDIF
+ 60       CONTINUE
+ 70     CONTINUE
+!C
+!C  Calculate the Hines integral at this level.
+!C
+        CALL HINES_INTGRL ( I_ALPHA,                                                 &
+       &                      V_ALPHA, M_ALPHA, BVFB, SLOPE, NAZ,                    &
+       &                      L, IL1, IL2, NLONS, NLEVS, NAZMTH,                     &
+       &                      LORMS )
+
+!C
+!C  Calculate the velocity variances at this level.
+!C
+        DO 80 I = IL1,IL2
+          SIGFAC(I) = DENSB(I) / DENSITY(I,L)                                        &
+       &                * BVFREQ(I,L) / BVFB(I) 
+ 80     CONTINUE
+        DO 100 N = 1,NAZ
+          DO 90 I = IL1,IL2
+            SIGSQH_ALPHA(I,L,N) = SIGFAC(I) * AK_ALPHA(I,N)                          &
+       &                            * I_ALPHA(I,N)
+  90      CONTINUE
+ 100    CONTINUE
+        CALL HINES_SIGMA ( SIGMA_T, SIGMA_ALPHA,                                     &
+       &                     SIGSQH_ALPHA, NAZ, L,                                   &
+       &                     IL1, IL2, NLONS, NLEVS, NAZMTH )
+!c
+        CALL HINES_SIGMA ( SIGMATM, SIGALPMC,                                        &
+       &                     SIGSQMCW, NAZ, L,                                       &
+       &                     IL1, IL2, NLONS, NLEVS, NAZMTH )
+!C
+!C  End of level loop.
+!C
+ 150  CONTINUE
+!C
+      RETURN
+!C-----------------------------------------------------------------------
+      END SUBROUTINE HINES_WAVNUM
+
+      SUBROUTINE HINES_WIND (V_ALPHA,VEL_U,VEL_V,                                    &
+       &                       NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH)
+!C
+!C  This routine calculates the azimuthal horizontal background wind components 
+!C  on a longitude by altitude grid for the case of 4 or 8 azimuths for
+!C  the Hines' Doppler spread GWD parameterization scheme.
+!C
+!C  Aug. 7/95 - C. McLandress
+!C
+!C  Output arguement:
+!C
+!C     * V_ALPHA   = background wind component at each azimuth (m/s). 
+!C     *             (note: first azimuth is in eastward direction
+!C     *              and rotate in counterclockwise direction.)
+!C
+!C  Input arguements:
+!C
+!C     * VEL_U     = background zonal wind component (m/s).
+!C     * VEL_V     = background meridional wind component (m/s).
+!C     * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
+!C     * IL1       = first longitudinal index to use (IL1 >= 1).
+!C     * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+!C     * LEV1      = first altitude level to use (LEV1 >=1). 
+!C     * LEV2      = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+!C     * NLONS     = number of longitudes.
+!C     * NLEVS     = number of vertical levels.
+!C     * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
+!C
+!C  Constants in DATA statements.
+!C
+!C     * COS45 = cosine of 45 degrees. 		
+!C     * UMIN  = minimum allowable value for zonal or meridional 
+!C     *         wind component (m/s).
+!C
+!C  Subroutine arguements.
+!C
+      INTEGER  NAZ, IL1, IL2, LEV1, LEV2
+      INTEGER  NLONS, NLEVS, NAZMTH
+      REAL  V_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  VEL_U(NLONS,NLEVS), VEL_V(NLONS,NLEVS)
+!C
+!C  Internal variables.
+!C
+      INTEGER  I, L
+      REAL U, V, COS45, UMIN
+!C
+      DATA  COS45 / 0.7071068 /
+      DATA  UMIN / 0.001 /
+!C-----------------------------------------------------------------------     
+!C
+!C  Case with 4 azimuths.
+!C
+
+!C      PRINT *,'IN HINES_WIND'
+      IF (NAZ.EQ.4)  THEN
+        DO 20 L = LEV1,LEV2
+          DO 10 I = IL1,IL2
+            U = VEL_U(I,L)
+            V = VEL_V(I,L)
+            IF (ABS(U) .LT. UMIN)  U = UMIN 
+            IF (ABS(V) .LT. UMIN)  V = UMIN 
+            V_ALPHA(I,L,1) = U 
+            V_ALPHA(I,L,2) = V
+            V_ALPHA(I,L,3) = - U
+            V_ALPHA(I,L,4) = - V
+ 10       CONTINUE
+ 20     CONTINUE
+      END IF
+!C
+!C  Case with 8 azimuths.
+!C
+      IF (NAZ.EQ.8)  THEN
+        DO 40 L = LEV1,LEV2
+          DO 30 I = IL1,IL2
+            U = VEL_U(I,L)
+            V = VEL_V(I,L)
+            IF (ABS(U) .LT. UMIN)  U = UMIN  
+            IF (ABS(V) .LT. UMIN)  V = UMIN  
+            V_ALPHA(I,L,1) = U 
+            V_ALPHA(I,L,2) = COS45 * ( V + U )
+            V_ALPHA(I,L,3) = V
+            V_ALPHA(I,L,4) = COS45 * ( V - U )
+            V_ALPHA(I,L,5) = - U
+            V_ALPHA(I,L,6) = - V_ALPHA(I,L,2)
+            V_ALPHA(I,L,7) = - V
+            V_ALPHA(I,L,8) = - V_ALPHA(I,L,4)
+ 30       CONTINUE
+ 40     CONTINUE
+      END IF
+!C
+      RETURN
+!C-----------------------------------------------------------------------
+      END SUBROUTINE HINES_WIND
+
+      SUBROUTINE HINES_FLUX (FLUX_U,FLUX_V,DRAG_U,DRAG_V,ALT,DENSITY,                &
+       &                       DENSB,M_ALPHA,AK_ALPHA,K_ALPHA,SLOPE,                 &
+       &                       NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH,             &
+       &                       LORMS)
+!C
+!C  Calculate zonal and meridional components of the vertical flux 
+!C  of horizontal momentum and corresponding wave drag (force per unit mass)
+!C  on a longitude by altitude grid for the Hines' Doppler spread 
+!C  GWD parameterization scheme.
+!C  NOTE: only 4 or 8 azimuths can be used.
+!C
+!C  Aug. 6/95 - C. McLandress
+!C
+!C  Output arguements:
+!C
+!C     * FLUX_U = zonal component of vertical momentum flux (Pascals)
+!C     * FLUX_V = meridional component of vertical momentum flux (Pascals)
+!C     * DRAG_U = zonal component of drag (m/s^2).
+!C     * DRAG_V = meridional component of drag (m/s^2).
+!C
+!C  Input arguements:
+!C
+!C     * ALT       = altitudes (m).
+!C     * DENSITY   = background density (kg/m^3).
+!C     * DENSB     = background density at bottom level (kg/m^3).
+!C     * M_ALPHA   = cutoff vertical wavenumber (1/m).
+!C     * AK_ALPHA  = spectral amplitude factor (i.e., {AjKj} in m^4/s^2).
+!C     * K_ALPHA   = horizontal wavenumber (1/m).
+!C     * SLOPE     = slope of incident vertical wavenumber spectrum.
+!C     * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
+!C     * IL1       = first longitudinal index to use (IL1 >= 1).
+!C     * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+!C     * LEV1      = first altitude level to use (LEV1 >=1). 
+!C     * LEV2      = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+!C     * NLONS     = number of longitudes.
+!C     * NLEVS     = number of vertical levels.
+!C     * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
+!C
+!C     * LORMS       = .TRUE. for drag computation 
+!C
+!C  Constant in DATA statement.
+!C
+!C     * COS45 = cosine of 45 degrees. 		
+!C
+!C  Subroutine arguements.
+!C
+      INTEGER  NAZ, IL1, IL2, LEV1, LEV2
+      INTEGER  NLONS, NLEVS, NAZMTH
+      REAL  SLOPE
+      REAL  FLUX_U(NLONS,NLEVS), FLUX_V(NLONS,NLEVS)
+      REAL  DRAG_U(NLONS,NLEVS), DRAG_V(NLONS,NLEVS)
+      REAL  ALT(NLONS,NLEVS),    DENSITY(NLONS,NLEVS), DENSB(NLONS)
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  AK_ALPHA(NLONS,NAZMTH), K_ALPHA(NLONS,NAZMTH)
+!C
+      LOGICAL LORMS(NLONS)
+!C
+!C  Internal variables.
+!C
+      INTEGER  I, L, LEV1P, LEV2M
+      REAL  COS45, PROD2, PROD4, PROD6, PROD8, DENDZ, DENDZ2
+      DATA  COS45 / 0.7071068 /   
+!C-----------------------------------------------------------------------
+!C
+      LEV1P = LEV1 + 1
+      LEV2M = LEV2 - 1
+      LEV2P = LEV2 + 1
+!C
+!C  Sum over azimuths for case where SLOPE = 1.
+!C
+      IF (SLOPE.EQ.1.)  THEN
+!C
+!C  Case with 4 azimuths.
+!C
+        IF (NAZ.EQ.4)  THEN
+          DO 20 L = LEV1,LEV2
+            DO 10 I = IL1,IL2
+              FLUX_U(I,L) = AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)                &
+       &                    - AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)
+              FLUX_V(I,L) = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)                &
+       &                    - AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)
+ 10         CONTINUE
+ 20       CONTINUE
+        END IF
+!C
+!C  Case with 8 azimuths.
+!C
+        IF (NAZ.EQ.8)  THEN
+          DO 40 L = LEV1,LEV2
+            DO 30 I = IL1,IL2
+              PROD2 = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)
+              PROD4 = AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)
+              PROD6 = AK_ALPHA(I,6)*K_ALPHA(I,6)*M_ALPHA(I,L,6)
+              PROD8 = AK_ALPHA(I,8)*K_ALPHA(I,8)*M_ALPHA(I,L,8)
+              FLUX_U(I,L) =                                                          &
+       &                AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)                    &
+       &              - AK_ALPHA(I,5)*K_ALPHA(I,5)*M_ALPHA(I,L,5)                    &
+       &              + COS45 * ( PROD2 - PROD4 - PROD6 + PROD8 )
+              FLUX_V(I,L) =                                                          &
+       &                AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)                    &
+       &              - AK_ALPHA(I,7)*K_ALPHA(I,7)*M_ALPHA(I,L,7)                    &
+       &              + COS45 * ( PROD2 + PROD4 - PROD6 - PROD8 )
+ 30         CONTINUE
+ 40       CONTINUE
+        END IF
+!C
+      END IF
+!C
+!C  Sum over azimuths for case where SLOPE not equal to 1.
+!C
+      IF (SLOPE.NE.1.)  THEN
+!C
+!C  Case with 4 azimuths.
+!C
+        IF (NAZ.EQ.4)  THEN
+          DO 60 L = LEV1,LEV2
+            DO 50 I = IL1,IL2
+              FLUX_U(I,L) =                                                          &
+       &               AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)**SLOPE              &
+       &             - AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)**SLOPE
+              FLUX_V(I,L) =                                                          &
+       &               AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)**SLOPE              &
+       &             - AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)**SLOPE
+ 50         CONTINUE
+ 60       CONTINUE
+        END IF
+!C
+!C  Case with 8 azimuths.
+!C
+        IF (NAZ.EQ.8)  THEN
+          DO 80 L = LEV1,LEV2
+            DO 70 I = IL1,IL2
+              PROD2 = AK_ALPHA(I,2)*K_ALPHA(I,2)*M_ALPHA(I,L,2)**SLOPE
+              PROD4 = AK_ALPHA(I,4)*K_ALPHA(I,4)*M_ALPHA(I,L,4)**SLOPE
+              PROD6 = AK_ALPHA(I,6)*K_ALPHA(I,6)*M_ALPHA(I,L,6)**SLOPE
+              PROD8 = AK_ALPHA(I,8)*K_ALPHA(I,8)*M_ALPHA(I,L,8)**SLOPE
+              FLUX_U(I,L) =                                                          &
+       &                AK_ALPHA(I,1)*K_ALPHA(I,1)*M_ALPHA(I,L,1)**SLOPE             &
+       &              - AK_ALPHA(I,5)*K_ALPHA(I,5)*M_ALPHA(I,L,5)**SLOPE             &
+       &              + COS45 * ( PROD2 - PROD4 - PROD6 + PROD8 )
+              FLUX_V(I,L) =                                                          &
+       &                AK_ALPHA(I,3)*K_ALPHA(I,3)*M_ALPHA(I,L,3)**SLOPE             &
+       &              - AK_ALPHA(I,7)*K_ALPHA(I,7)*M_ALPHA(I,L,7)**SLOPE             &
+       &              + COS45 * ( PROD2 + PROD4 - PROD6 - PROD8 )
+ 70         CONTINUE
+ 80       CONTINUE
+        END IF
+!C
+      END IF
+!C
+!C  Calculate flux from sum.
+!C
+      DO 100 L = LEV1,LEV2
+        DO 90 I = IL1,IL2
+          FLUX_U(I,L) = FLUX_U(I,L) * DENSB(I) / SLOPE
+          FLUX_V(I,L) = FLUX_V(I,L) * DENSB(I) / SLOPE
+  90    CONTINUE
+ 100  CONTINUE
+!C
+!C  Calculate drag at intermediate levels using centered differences 
+!C      
+      DO 120 L = LEV1P,LEV2M
+        DO 110 I = IL1,IL2
+        IF (LORMS(I)) THEN
+!ccc       DENDZ2 = DENSITY(I,L) * ( ALT(I,L+1) - ALT(I,L-1) )
+          DENDZ2 = DENSITY(I,L) * ( ALT(I,L-1) - ALT(I,L) ) 
+!ccc       DRAG_U(I,L) = - ( FLUX_U(I,L+1) - FLUX_U(I,L-1) ) / DENDZ2
+          DRAG_U(I,L) = - ( FLUX_U(I,L-1) - FLUX_U(I,L) ) / DENDZ2
+!ccc       DRAG_V(I,L) = - ( FLUX_V(I,L+1) - FLUX_V(I,L-1) ) / DENDZ2
+          DRAG_V(I,L) = - ( FLUX_V(I,L-1) - FLUX_V(I,L) ) / DENDZ2
+          
+        ENDIF
+ 110    CONTINUE
+ 120  CONTINUE
+!C
+!C  Drag at first and last levels using one-side differences.
+!C 
+      DO 130 I = IL1,IL2
+      IF (LORMS(I)) THEN
+        DENDZ = DENSITY(I,LEV1) * ( ALT(I,LEV1) - ALT(I,LEV1P) ) 
+        DRAG_U(I,LEV1) =  FLUX_U(I,LEV1)  / DENDZ
+        DRAG_V(I,LEV1) =  FLUX_V(I,LEV1)  / DENDZ
+      ENDIF
+ 130  CONTINUE
+      DO 140 I = IL1,IL2
+      IF (LORMS(I)) THEN
+        DENDZ = DENSITY(I,LEV2) * ( ALT(I,LEV2M) - ALT(I,LEV2) )
+        DRAG_U(I,LEV2) = - ( FLUX_U(I,LEV2M) - FLUX_U(I,LEV2) ) / DENDZ
+        DRAG_V(I,LEV2) = - ( FLUX_V(I,LEV2M) - FLUX_V(I,LEV2) ) / DENDZ
+      ENDIF
+ 140  CONTINUE
+      IF (NLEVS .GT. LEV2) THEN
+      DO 150 I = IL1,IL2
+      IF (LORMS(I)) THEN
+        DENDZ = DENSITY(I,LEV2P) * ( ALT(I,LEV2) - ALT(I,LEV2P) )
+        DRAG_U(I,LEV2P) = -  FLUX_U(I,LEV2)  / DENDZ
+        DRAG_V(I,LEV2P) = - FLUX_V(I,LEV2)  / DENDZ
+      ENDIF
+150   CONTINUE
+      ENDIF
+!C
+      RETURN
+!C-----------------------------------------------------------------------
+      END SUBROUTINE HINES_FLUX
+
+      SUBROUTINE HINES_HEAT (HEAT,DIFFCO,M_ALPHA,DMDZ_ALPHA,                         &
+       &                       AK_ALPHA,K_ALPHA,BVFREQ,DENSITY,DENSB,                &
+       &                       SIGMA_T,VISC_MOL,KSTAR,SLOPE,F2,F3,F5,F6,             &
+       &                       NAZ,IL1,IL2,LEV1,LEV2,NLONS,NLEVS,NAZMTH)
+!C
+!C  This routine calculates the gravity wave induced heating and 
+!C  diffusion coefficient on a longitude by altitude grid for  
+!C  the Hines' Doppler spread gravity wave drag parameterization scheme.
+!C
+!C  Aug. 6/95 - C. McLandress
+!C
+!C  Output arguements:
+!C
+!C     * HEAT   = gravity wave heating (K/sec).
+!C     * DIFFCO = diffusion coefficient (m^2/sec)
+!C
+!C  Input arguements:
+!C
+!C     * M_ALPHA     = cutoff vertical wavenumber (1/m).
+!C     * DMDZ_ALPHA  = vertical derivative of cutoff wavenumber.
+!C     * AK_ALPHA    = spectral amplitude factor of each azimuth 
+!C                     (i.e., {AjKj} in m^4/s^2).
+!C     * K_ALPHA     = horizontal wavenumber of each azimuth (1/m).
+!C     * BVFREQ      = background Brunt Vassala frequency (rad/sec).
+!C     * DENSITY     = background density (kg/m^3).
+!C     * DENSB       = background density at bottom level (kg/m^3).
+!C     * SIGMA_T     = total rms horizontal wind (m/s).
+!C     * VISC_MOL    = molecular viscosity (m^2/s).
+!C     * KSTAR       = typical gravity wave horizontal wavenumber (1/m).
+!C     * SLOPE       = slope of incident vertical wavenumber spectrum.
+!C     * F2,F3,F5,F6 = Hines's fudge factors.
+!C     * NAZ         = actual number of horizontal azimuths used.
+!C     * IL1         = first longitudinal index to use (IL1 >= 1).
+!C     * IL2         = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+!C     * LEV1        = first altitude level to use (LEV1 >=1). 
+!C     * LEV2        = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+!C     * NLONS       = number of longitudes.
+!C     * NLEVS       = number of vertical levels.
+!C     * NAZMTH      = azimuthal array dimension (NAZMTH >= NAZ).
+!C
+      INTEGER  NAZ, IL1, IL2, LEV1, LEV2, NLONS, NLEVS, NAZMTH
+      REAL  KSTAR(NLONS), SLOPE, F2, F3, F5, F6
+      REAL  HEAT(NLONS,NLEVS), DIFFCO(NLONS,NLEVS)
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH), DMDZ_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  AK_ALPHA(NLONS,NAZMTH), K_ALPHA(NLONS,NAZMTH)
+      REAL  BVFREQ(NLONS,NLEVS), DENSITY(NLONS,NLEVS),  DENSB(NLONS) 
+      REAL  SIGMA_T(NLONS,NLEVS), VISC_MOL(NLONS,NLEVS)
+!C
+!C Internal variables.
+!C
+      INTEGER  I, L, N
+      REAL  M_SUB_M_TURB, M_SUB_M_MOL, M_SUB_M, HEATNG
+      REAL  VISC, VISC_MIN, CPGAS, SM1
+!C
+!C specific heat at constant pressure
+!C
+      DATA  CPGAS / 1004. / 
+!C             
+!C minimum permissible viscosity
+!C
+      DATA  VISC_MIN / 1.E-10 /       
+!C-----------------------------------------------------------------------     
+!C
+!C  Initialize heating array.
+!C
+      DO 20 L = 1,NLEVS
+        DO 10 I = 1,NLONS
+          HEAT(I,L) = 0.
+  10    CONTINUE
+  20  CONTINUE
+!C
+!C  Perform sum over azimuths for case where SLOPE = 1.
+!C
+      IF (SLOPE.EQ.1.)  THEN
+        DO 50 N = 1,NAZ
+          DO 40 L = LEV1,LEV2
+            DO 30 I = IL1,IL2
+              HEAT(I,L) = HEAT(I,L) + AK_ALPHA(I,N) * K_ALPHA(I,N)                   &
+       &                    * DMDZ_ALPHA(I,L,N) 
+ 30         CONTINUE
+ 40       CONTINUE
+ 50     CONTINUE
+      END IF
+!C
+!C  Perform sum over azimuths for case where SLOPE not 1.
+!C
+      IF (SLOPE.NE.1.)  THEN
+        SM1 = SLOPE - 1.
+        DO 80 N = 1,NAZ
+          DO 70 L = LEV1,LEV2
+            DO 60 I = IL1,IL2
+              HEAT(I,L) = HEAT(I,L) + AK_ALPHA(I,N) * K_ALPHA(I,N)                   &
+       &                    * M_ALPHA(I,L,N)**SM1 * DMDZ_ALPHA(I,L,N) 
+ 60         CONTINUE
+ 70       CONTINUE
+ 80     CONTINUE
+      END IF
+!C
+!C  Heating and diffusion.
+!C
+      DO 100 L = LEV1,LEV2
+        DO 90 I = IL1,IL2
+!C
+!C  Maximum permissible value of cutoff wavenumber is the smaller 
+!C  of the instability-induced wavenumber (M_SUB_M_TURB) and 
+!C  that imposed by molecular viscosity (M_SUB_M_MOL).
+!C
+          VISC    = AMAX1 ( VISC_MOL(I,L), VISC_MIN )
+          M_SUB_M_TURB = BVFREQ(I,L) / ( F2 * SIGMA_T(I,L) )
+          M_SUB_M_MOL  = (BVFREQ(I,L)*KSTAR(I)/VISC)**0.33333333/F3
+          M_SUB_M      = AMIN1 ( M_SUB_M_TURB, M_SUB_M_MOL )
+!C
+          HEATNG = - HEAT(I,L) * F5 * BVFREQ(I,L) / M_SUB_M                          &
+       &               * DENSB(I) / DENSITY(I,L) 
+          DIFFCO(I,L) = F6 * HEATNG**0.33333333 / M_SUB_M**1.33333333
+          HEAT(I,L)   = HEATNG / CPGAS
+!C
+ 90     CONTINUE
+ 100  CONTINUE
+!C
+      RETURN
+!C-----------------------------------------------------------------------
+      END SUBROUTINE HINES_HEAT
+
+      SUBROUTINE HINES_SIGMA (SIGMA_T,SIGMA_ALPHA,SIGSQH_ALPHA,                      &
+       &                        NAZ,LEV,IL1,IL2,NLONS,NLEVS,NAZMTH)
+!C
+!C  This routine calculates the total rms and azimuthal rms horizontal 
+!C  velocities at a given level on a longitude by altitude grid for 
+!C  the Hines' Doppler spread GWD parameterization scheme.
+!C  NOTE: only four or eight azimuths can be used.
+!C
+!C  Aug. 7/95 - C. McLandress
+!C
+!C  Output arguements:
+!C
+!C     * SIGMA_T      = total rms horizontal wind (m/s).
+!C     * SIGMA_ALPHA  = total rms wind in each azimuth (m/s).
+!C
+!C  Input arguements:
+!C
+!C     * SIGSQH_ALPHA = portion of wind variance from waves having wave
+!C     *                normals in the alpha azimuth (m/s).
+!C     * NAZ       = actual number of horizontal azimuths used (must be 4 or 8).
+!C     * LEV       = altitude level to process.
+!C     * IL1       = first longitudinal index to use (IL1 >= 1).
+!C     * IL2       = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+!C     * NLONS     = number of longitudes.
+!C     * NLEVS     = number of vertical levels.
+!C     * NAZMTH    = azimuthal array dimension (NAZMTH >= NAZ).
+!C
+!C  Subroutine arguements.
+!C
+      INTEGER  LEV, NAZ, IL1, IL2
+      INTEGER  NLONS, NLEVS, NAZMTH
+      REAL  SIGMA_T(NLONS,NLEVS)
+      REAL  SIGMA_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  SIGSQH_ALPHA(NLONS,NLEVS,NAZMTH)
+!C
+!C  Internal variables.
+!C
+      INTEGER  I, N
+      REAL  SUM_EVEN, SUM_ODD 
+!C-----------------------------------------------------------------------     
+!C
+!C  Calculate azimuthal rms velocity for the 4 azimuth case.
+!C
+      IF (NAZ.EQ.4)  THEN
+        DO 10 I = IL1,IL2
+          SIGMA_ALPHA(I,LEV,1) = SQRT ( SIGSQH_ALPHA(I,LEV,1)                        &
+       &                                + SIGSQH_ALPHA(I,LEV,3) )
+          SIGMA_ALPHA(I,LEV,2) = SQRT ( SIGSQH_ALPHA(I,LEV,2)                        &
+       &                                + SIGSQH_ALPHA(I,LEV,4) )
+          SIGMA_ALPHA(I,LEV,3) = SIGMA_ALPHA(I,LEV,1)
+          SIGMA_ALPHA(I,LEV,4) = SIGMA_ALPHA(I,LEV,2)
+ 10     CONTINUE
+      END IF
+!C
+!C  Calculate azimuthal rms velocity for the 8 azimuth case.
+!C
+      IF (NAZ.EQ.8)  THEN
+        DO 20 I = IL1,IL2
+          SUM_ODD  = ( SIGSQH_ALPHA(I,LEV,1)                                         &
+       &                 + SIGSQH_ALPHA(I,LEV,3)                                     &
+       &                 + SIGSQH_ALPHA(I,LEV,5)                                     &
+       &                 + SIGSQH_ALPHA(I,LEV,7) ) / 2.
+          SUM_EVEN = ( SIGSQH_ALPHA(I,LEV,2)                                         &
+       &                 + SIGSQH_ALPHA(I,LEV,4)                                     &
+       &                 + SIGSQH_ALPHA(I,LEV,6)                                     &
+       &                 + SIGSQH_ALPHA(I,LEV,8) ) / 2.
+          SIGMA_ALPHA(I,LEV,1) = SQRT ( SIGSQH_ALPHA(I,LEV,1)                        &
+       &                           + SIGSQH_ALPHA(I,LEV,5) + SUM_EVEN )
+          SIGMA_ALPHA(I,LEV,2) = SQRT ( SIGSQH_ALPHA(I,LEV,2)                        &
+       &                           + SIGSQH_ALPHA(I,LEV,6) + SUM_ODD )
+          SIGMA_ALPHA(I,LEV,3) = SQRT ( SIGSQH_ALPHA(I,LEV,3)                        &
+       &                           + SIGSQH_ALPHA(I,LEV,7) + SUM_EVEN )
+          SIGMA_ALPHA(I,LEV,4) = SQRT ( SIGSQH_ALPHA(I,LEV,4)                        &
+       &                           + SIGSQH_ALPHA(I,LEV,8) + SUM_ODD )
+          SIGMA_ALPHA(I,LEV,5) = SIGMA_ALPHA(I,LEV,1)
+          SIGMA_ALPHA(I,LEV,6) = SIGMA_ALPHA(I,LEV,2)
+          SIGMA_ALPHA(I,LEV,7) = SIGMA_ALPHA(I,LEV,3)
+          SIGMA_ALPHA(I,LEV,8) = SIGMA_ALPHA(I,LEV,4)
+ 20     CONTINUE
+      END IF
+!C
+!C  Calculate total rms velocity.
+!C
+      DO 50 I = IL1,IL2
+        SIGMA_T(I,LEV) = 0.
+ 50   CONTINUE
+      DO 70 N = 1,NAZ
+        DO 60 I = IL1,IL2
+          SIGMA_T(I,LEV) = SIGMA_T(I,LEV) + SIGSQH_ALPHA(I,LEV,N)
+ 60     CONTINUE
+ 70   CONTINUE
+      DO 80 I = IL1,IL2
+        SIGMA_T(I,LEV) = SQRT ( SIGMA_T(I,LEV) )
+ 80   CONTINUE
+!C
+      RETURN
+!C-----------------------------------------------------------------------     
+      END SUBROUTINE HINES_SIGMA
+
+      SUBROUTINE HINES_INTGRL (I_ALPHA,V_ALPHA,M_ALPHA,BVFB,SLOPE,                   &
+       &                         NAZ,LEV,IL1,IL2,NLONS,NLEVS,NAZMTH,                 &
+       &                         LORMS)
+!C
+!C  This routine calculates the vertical wavenumber integral
+!C  for a single vertical level at each azimuth on a longitude grid
+!C  for the Hines' Doppler spread GWD parameterization scheme.
+!C  NOTE: (1) only spectral slopes of 1, 1.5 or 2 are permitted.
+!C        (2) the integral is written in terms of the product QM
+!C            which by construction is always less than 1. Series
+!C            solutions are used for small |QM| and analytical solutions
+!C            for remaining values.
+!C
+!C  Aug. 8/95 - C. McLandress
+!C
+!C  Output arguement:
+!C
+!C     * I_ALPHA = Hines' integral.
+!C
+!C  Input arguements:
+!C
+!C     * V_ALPHA = azimuthal wind component (m/s). 
+!C     * M_ALPHA = azimuthal cutoff vertical wavenumber (1/m).
+!C     * BVFB    = background Brunt Vassala frequency at model bottom.
+!C     * SLOPE   = slope of initial vertical wavenumber spectrum 
+!C     *           (must use SLOPE = 1., 1.5 or 2.)
+!C     * NAZ     = actual number of horizontal azimuths used.
+!C     * LEV     = altitude level to process.
+!C     * IL1     = first longitudinal index to use (IL1 >= 1).
+!C     * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+!C     * NLONS   = number of longitudes.
+!C     * NLEVS   = number of vertical levels.
+!C     * NAZMTH  = azimuthal array dimension (NAZMTH >= NAZ).
+!C
+!C     * LORMS       = .TRUE. for drag computation 
+!C
+!C  Constants in DATA statements:
+!C
+!C     * QMIN = minimum value of Q_ALPHA (avoids indeterminant form of integral)
+!C     * QM_MIN = minimum value of Q_ALPHA * M_ALPHA (used to avoid numerical
+!C     *          problems).
+!C
+      INTEGER  LEV, NAZ, IL1, IL2, NLONS, NLEVS, NAZMTH
+      REAL  I_ALPHA(NLONS,NAZMTH)
+      REAL  V_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  M_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  BVFB(NLONS), SLOPE
+!C
+      LOGICAL LORMS(NLONS)
+!C
+!C  Internal variables.
+!C
+      INTEGER  I, N
+      REAL  Q_ALPHA, QM, SQRTQM, Q_MIN, QM_MIN
+!C
+      DATA  Q_MIN / 1.0 /, QM_MIN / 0.01 /
+!C-----------------------------------------------------------------------     
+!C
+!C  For integer value SLOPE = 1.
+!C
+      IF (SLOPE .EQ. 1.)  THEN
+!C
+        DO 20 N = 1,NAZ
+          DO 10 I = IL1,IL2
+          IF (LORMS(I)) THEN
+!C
+            Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I)
+            QM = Q_ALPHA * M_ALPHA(I,LEV,N)
+!C
+!C  If |QM| is small then use first 4 terms series of Taylor series
+!C  expansion of integral in order to avoid indeterminate form of integral,
+!C  otherwise use analytical form of integral.
+!C
+            IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN)  THEN  
+              IF (Q_ALPHA .EQ. 0.)  THEN
+                I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**2 / 2.
+              ELSE
+                I_ALPHA(I,N) = ( QM**2/2. + QM**3/3. + QM**4/4.                      &
+       &                           + QM**5/5. ) / Q_ALPHA**2
+              END IF
+            ELSE
+              I_ALPHA(I,N) = - ( ALOG(1.-QM) + QM ) / Q_ALPHA**2
+            END IF
+!C
+          ENDIF
+ 10       CONTINUE
+ 20     CONTINUE
+!C
+      END IF
+!C
+!C  For integer value SLOPE = 2.
+!C
+      IF (SLOPE .EQ. 2.)  THEN
+!C
+        DO 40 N = 1,NAZ
+          DO 30 I = IL1,IL2
+          IF (LORMS(I)) THEN
+!C
+            Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I)
+            QM = Q_ALPHA * M_ALPHA(I,LEV,N)
+!C
+!C  If |QM| is small then use first 4 terms series of Taylor series
+!C  expansion of integral in order to avoid indeterminate form of integral,
+!C  otherwise use analytical form of integral.
+!C
+            IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN)  THEN  
+              IF (Q_ALPHA .EQ. 0.)  THEN
+                I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**3 / 3.
+              ELSE
+                I_ALPHA(I,N) = ( QM**3/3. + QM**4/4. + QM**5/5.                      &
+       &                           + QM**6/6. ) / Q_ALPHA**3
+              END IF
+            ELSE
+              I_ALPHA(I,N) = - ( ALOG(1.-QM) + QM + QM**2/2.)                        &
+       &                         / Q_ALPHA**3
+            END IF
+!C
+          ENDIF
+ 30       CONTINUE
+ 40     CONTINUE
+!C
+      END IF
+!C
+!C  For real value SLOPE = 1.5
+!C
+      IF (SLOPE .EQ. 1.5)  THEN
+!C
+        DO 60 N = 1,NAZ
+          DO 50 I = IL1,IL2
+          IF (LORMS(I)) THEN
+!C
+            Q_ALPHA = V_ALPHA(I,LEV,N) / BVFB(I)
+            QM = Q_ALPHA * M_ALPHA(I,LEV,N)       
+!C
+!C  If |QM| is small then use first 4 terms series of Taylor series
+!C  expansion of integral in order to avoid indeterminate form of integral,
+!C  otherwise use analytical form of integral.
+!C
+            IF (ABS(Q_ALPHA).LT.Q_MIN .OR. ABS(QM).LT.QM_MIN)  THEN  
+              IF (Q_ALPHA .EQ. 0.)  THEN
+                I_ALPHA(I,N) = M_ALPHA(I,LEV,N)**2.5 / 2.5
+              ELSE
+                I_ALPHA(I,N) = ( QM/2.5 + QM**2/3.5                                  &
+       &                           + QM**3/4.5 + QM**4/5.5 )                         &
+       &                           * M_ALPHA(I,LEV,N)**1.5 / Q_ALPHA
+              END IF
+            ELSE
+              QM     = ABS(QM)
+              SQRTQM = SQRT(QM)
+              IF (Q_ALPHA .GE. 0.)  THEN
+                I_ALPHA(I,N) = ( ALOG( (1.+SQRTQM)/(1.-SQRTQM) )                     &
+       &                          -2.*SQRTQM*(1.+QM/3.) ) / Q_ALPHA**2.5
+              ELSE
+                I_ALPHA(I,N) = 2. * ( ATAN(SQRTQM) + SQRTQM*(QM/3.-1.) )             &
+       &                          / ABS(Q_ALPHA)**2.5
+              END IF
+            END IF
+!C
+          ENDIF
+ 50       CONTINUE
+ 60     CONTINUE
+!C
+      END IF
+!C
+!C  If integral is negative (which in principal should not happen) then
+!C  print a message and some info since execution will abort when calculating
+!C  the variances.
+!C
+!c      DO 80 N = 1,NAZ
+!c        DO 70 I = IL1,IL2
+!c          IF (I_ALPHA(I,N).LT.0.)  THEN
+!c            WRITE (6,*) 
+!c            WRITE (6,*) '******************************'
+!c            WRITE (6,*) 'Hines integral I_ALPHA < 0 '
+!c            WRITE (6,*) '  longitude I=',I
+!c            WRITE (6,*) '  azimuth   N=',N
+!c            WRITE (6,*) '  level   LEV=',LEV
+!c            WRITE (6,*) '  I_ALPHA =',I_ALPHA(I,N)
+!c            WRITE (6,*) '  V_ALPHA =',V_ALPHA(I,LEV,N)
+!c            WRITE (6,*) '  M_ALPHA =',M_ALPHA(I,LEV,N)
+!c            WRITE (6,*) '  Q_ALPHA =',V_ALPHA(I,LEV,N) / BVFB(I)
+!c            WRITE (6,*) '  QM      =',V_ALPHA(I,LEV,N) / BVFB(I) 
+!c     ^                                * M_ALPHA(I,LEV,N)
+!c            WRITE (6,*) '******************************'
+!c          END IF
+!c 70     CONTINUE
+!c 80   CONTINUE
+!C
+      RETURN
+!C-----------------------------------------------------------------------
+      END SUBROUTINE HINES_INTGRL
+
+      SUBROUTINE HINES_SETUP (NAZ,SLOPE,F1,F2,F3,F5,F6,KSTAR,                        &
+       &                        ICUTOFF,ALT_CUTOFF,SMCO,NSMAX,IHEATCAL,              &
+       &                       K_ALPHA,IERROR,NMESSG,NLONS,NAZMTH,COSLAT)
+!C
+!C  This routine specifies various parameters needed for the
+!C  the Hines' Doppler spread gravity wave drag parameterization scheme.
+!C
+!C  Aug. 8/95 - C. McLandress
+!C
+!C  Output arguements:
+!C
+!C     * NAZ        = actual number of horizontal azimuths used
+!C     *              (code set up presently for only NAZ = 4 or 8).
+!C     * SLOPE      = slope of incident vertical wavenumber spectrum
+!C     *              (code set up presently for SLOPE 1., 1.5 or 2.).
+!C     * F1         = "fudge factor" used in calculation of trial value of
+!C     *              azimuthal cutoff wavenumber M_ALPHA (1.2 <= F1 <= 1.9).
+!C     * F2         = "fudge factor" used in calculation of maximum
+!C     *              permissible instabiliy-induced cutoff wavenumber 
+!C     *              M_SUB_M_TURB (0.1 <= F2 <= 1.4).
+!C     * F3         = "fudge factor" used in calculation of maximum 
+!C     *              permissible molecular viscosity-induced cutoff wavenumber 
+!C     *              M_SUB_M_MOL (0.1 <= F2 <= 1.4).
+!C     * F5         = "fudge factor" used in calculation of heating rate
+!C     *              (1 <= F5 <= 3).
+!C     * F6         = "fudge factor" used in calculation of turbulent 
+!C     *              diffusivity coefficient.
+!C     * KSTAR      = typical gravity wave horizontal wavenumber (1/m)
+!C     *              used in calculation of M_SUB_M_TURB.
+!C     * ICUTOFF    = 1 to exponentially damp off GWD, heating and diffusion 
+!C     *              arrays above ALT_CUTOFF; otherwise arrays not modified.
+!C     * ALT_CUTOFF = altitude in meters above which exponential decay applied.
+!C     * SMCO       = smoother used to smooth cutoff vertical wavenumbers
+!C     *              and total rms winds before calculating drag or heating.
+!C     *              (==> a 1:SMCO:1 stencil used; SMCO >= 1.).
+!C     * NSMAX      = number of times smoother applied ( >= 1),
+!C     *            = 0 means no smoothing performed.
+!C     * IHEATCAL   = 1 to calculate heating rates and diffusion coefficient.
+!C     *            = 0 means only drag and flux calculated.
+!C     * K_ALPHA    = horizontal wavenumber of each azimuth (1/m) which
+!C     *              is set here to KSTAR.
+!C     * IERROR     = error flag.
+!C     *            = 0 no errors.
+!C     *            = 10 ==> NAZ > NAZMTH
+!C     *            = 20 ==> invalid number of azimuths (NAZ must be 4 or 8).
+!C     *            = 30 ==> invalid slope (SLOPE must be 1., 1.5 or 2.).
+!C     *            = 40 ==> invalid smoother (SMCO must be >= 1.)
+!C
+!C  Input arguements:
+!C
+!C     * NMESSG  = output unit number where messages to be printed.
+!C     * NLONS   = number of longitudes.
+!C     * NAZMTH  = azimuthal array dimension (NAZMTH >= NAZ).
+!C
+      INTEGER  NAZ, NLONS, NAZMTH, IHEATCAL, ICUTOFF
+      INTEGER  NMESSG, NSMAX, IERROR
+      REAL  KSTAR(NLONS), SLOPE, F1, F2, F3, F5, F6, ALT_CUTOFF, SMCO
+      REAL  K_ALPHA(NLONS,NAZMTH),COSLAT(NLONS)
+      REAL  KSMIN, KSMAX
+!C
+!C Internal variables.
+!C
+      INTEGER  I, N
+!C-----------------------------------------------------------------------     
+!C
+!C  Specify constants.
+!C
+      NAZ   = 8
+      SLOPE = 1.
+      F1    = 1.5 
+      F2    = 0.3 
+      F3    = 1.0 
+      F5    = 3.0 
+      F6    = 1.0       
+      KSMIN = 1.E-5       
+      KSMAX = 1.E-4       
+      DO I=1,NLONS
+         KSTAR(I) = KSMIN/( COSLAT(I)+(KSMIN/KSMAX) )      
+      ENDDO
+      ICUTOFF    = 1   
+      ALT_CUTOFF = 105.E3
+      SMCO       = 2.0 
+!c      SMCO       = 1.0 
+      NSMAX      = 5
+!c      NSMAX      = 2
+      IHEATCAL   = 0 
+!C
+!C  Print information to output file.
+!C
+!c      WRITE (NMESSG,6000)
+!c 6000 FORMAT (/' Subroutine HINES_SETUP:')
+!c      WRITE (NMESSG,*)  '  SLOPE = ', SLOPE
+!c      WRITE (NMESSG,*)  '  NAZ = ', NAZ
+!c      WRITE (NMESSG,*)  '  F1,F2,F3  = ', F1, F2, F3
+!c      WRITE (NMESSG,*)  '  F5,F6     = ', F5, F6
+!c      WRITE (NMESSG,*)  '  KSTAR     = ', KSTAR
+!c     >           ,'  COSLAT     = ', COSLAT
+!c      IF (ICUTOFF .EQ. 1)  THEN
+!c        WRITE (NMESSG,*) '  Drag exponentially damped above ',
+!c     &                       ALT_CUTOFF/1.E3
+!c     END IF
+!c      IF (NSMAX.LT.1 )  THEN
+!c        WRITE (NMESSG,*) '  No smoothing of cutoff wavenumbers, etc'
+!c      ELSE
+!c        WRITE (NMESSG,*) '  Cutoff wavenumbers and sig_t smoothed:'
+!c        WRITE (NMESSG,*) '    SMCO  =', SMCO
+!c        WRITE (NMESSG,*) '    NSMAX =', NSMAX
+!c     END IF
+!C
+!C  Check that things are setup correctly and log error if not
+!C
+      IERROR = 0
+      IF (NAZ .GT. NAZMTH)                                  IERROR = 10
+      IF (NAZ.NE.4 .AND. NAZ.NE.8)                          IERROR = 20
+      IF (SLOPE.NE.1. .AND. SLOPE.NE.1.5 .AND. SLOPE.NE.2.) IERROR = 30
+      IF (SMCO .LT. 1.)                                     IERROR = 40
+!C
+!C  Use single value for azimuthal-dependent horizontal wavenumber.
+!C
+      DO 20 N = 1,NAZ
+        DO 10 I = 1,NLONS
+          K_ALPHA(I,N) = KSTAR(I)
+ 10     CONTINUE
+ 20   CONTINUE
+!C
+      RETURN
+!C-----------------------------------------------------------------------
+      END SUBROUTINE HINES_SETUP
+
+      SUBROUTINE HINES_PRINT (FLUX_U,FLUX_V,DRAG_U,DRAG_V,ALT,SIGMA_T,               &
+       &                        SIGMA_ALPHA,V_ALPHA,M_ALPHA,                         &
+       &                        IU_PRINT,IV_PRINT,NMESSG,                            &
+       &                        ILPRT1,ILPRT2,LEVPRT1,LEVPRT2,                       &
+       &                        NAZ,NLONS,NLEVS,NAZMTH)
+!C
+!C  Print out altitude profiles of various quantities from
+!C  Hines' Doppler spread gravity wave drag parameterization scheme.
+!C  (NOTE: only for NAZ = 4 or 8). 
+!C
+!C  Aug. 8/95 - C. McLandress
+!C
+!C  Input arguements:
+!C
+!C     * IU_PRINT = 1 to print out values in east-west direction.
+!C     * IV_PRINT = 1 to print out values in north-south direction.
+!C     * NMESSG   = unit number for printed output.
+!C     * ILPRT1   = first longitudinal index to print.
+!C     * ILPRT2   = last longitudinal index to print.
+!C     * LEVPRT1  = first altitude level to print.
+!C     * LEVPRT2  = last altitude level to print.
+!C
+      INTEGER  NAZ, ILPRT1, ILPRT2, LEVPRT1, LEVPRT2
+      INTEGER  NLONS, NLEVS, NAZMTH
+      INTEGER  IU_PRINT, IV_PRINT, NMESSG
+      REAL  FLUX_U(NLONS,NLEVS), FLUX_V(NLONS,NLEVS)
+      REAL  DRAG_U(NLONS,NLEVS), DRAG_V(NLONS,NLEVS)
+      REAL  ALT(NLONS,NLEVS), SIGMA_T(NLONS,NLEVS)
+      REAL  SIGMA_ALPHA(NLONS,NLEVS,NAZMTH)
+      REAL  V_ALPHA(NLONS,NLEVS,NAZMTH), M_ALPHA(NLONS,NLEVS,NAZMTH)
+!C
+!C  Internal variables.
+!C
+      INTEGER  N_EAST, N_WEST, N_NORTH, N_SOUTH
+      INTEGER  I, L
+!C-----------------------------------------------------------------------
+!C
+!C  Azimuthal indices of cardinal directions.
+!C
+      N_EAST = 1
+      IF (NAZ.EQ.4)  THEN
+        N_WEST  = 3       
+        N_NORTH = 2
+        N_SOUTH = 4       
+      ELSE IF (NAZ.EQ.8)  THEN
+        N_WEST  = 5       
+        N_NORTH = 3
+        N_SOUTH = 7       
+      END IF
+!C
+!C  Print out values for range of longitudes.
+!C
+      DO 100 I = ILPRT1,ILPRT2
+!C
+!C  Print east-west wind, sigmas, cutoff wavenumbers, flux and drag.
+!C
+        IF (IU_PRINT.EQ.1)  THEN
+          WRITE (NMESSG,*) 
+          WRITE (NMESSG,6001) I
+          WRITE (NMESSG,6005) 
+ 6001     FORMAT ( 'Hines GW (east-west) at longitude I =',I3)
+ 6005     FORMAT (15x,' U ',2x,'sig_E',2x,'sig_T',3x,'m_E',                          &
+       &            4x,'m_W',4x,'fluxU',5x,'gwdU')
+          DO 10 L = LEVPRT1,LEVPRT2
+            WRITE (NMESSG,6701) ALT(I,L)/1.E3, V_ALPHA(I,L,N_EAST),                  &
+       &                          SIGMA_ALPHA(I,L,N_EAST), SIGMA_T(I,L),             &
+       &                          M_ALPHA(I,L,N_EAST)*1.E3,                          &
+       &                          M_ALPHA(I,L,N_WEST)*1.E3,                          &
+       &                          FLUX_U(I,L)*1.E5, DRAG_U(I,L)*24.*3600.
+  10      CONTINUE
+ 6701     FORMAT (' z=',f7.2,1x,3f7.1,2f7.3,f9.4,f9.3)
+        END IF
+!C
+!C  Print north-south winds, sigmas, cutoff wavenumbers, flux and drag.
+!C
+        IF (IV_PRINT.EQ.1)  THEN
+          WRITE(NMESSG,*) 
+          WRITE(NMESSG,6002) I
+ 6002     FORMAT ( 'Hines GW (north-south) at longitude I =',I3)
+          WRITE(NMESSG,6006) 
+ 6006     FORMAT (15x,' V ',2x,'sig_N',2x,'sig_T',3x,'m_N',                          &
+       &            4x,'m_S',4x,'fluxV',5x,'gwdV')
+          DO 20 L = LEVPRT1,LEVPRT2
+            WRITE (NMESSG,6701) ALT(I,L)/1.E3, V_ALPHA(I,L,N_NORTH),                 &
+       &                          SIGMA_ALPHA(I,L,N_NORTH), SIGMA_T(I,L),            &
+       &                          M_ALPHA(I,L,N_NORTH)*1.E3,                         &
+       &                          M_ALPHA(I,L,N_SOUTH)*1.E3,                         &
+       &                          FLUX_V(I,L)*1.E5, DRAG_V(I,L)*24.*3600.
+ 20       CONTINUE
+        END IF
+!C
+ 100  CONTINUE
+!C
+      RETURN
+!C-----------------------------------------------------------------------
+      END SUBROUTINE HINES_PRINT
+
+      SUBROUTINE HINES_EXP (DATA,DATA_ZMAX,ALT,ALT_EXP,IORDER,                       &
+       &                      IL1,IL2,LEV1,LEV2,NLONS,NLEVS)
+!C
+!C  This routine exponentially damps a longitude by altitude array 
+!C  of data above a specified altitude.
+!C
+!C  Aug. 13/95 - C. McLandress
+!C
+!C  Output arguements:
+!C
+!C     * DATA = modified data array.
+!C
+!C  Input arguements:
+!C
+!C     * DATA    = original data array.
+!C     * ALT     = altitudes.
+!C     * ALT_EXP = altitude above which exponential decay applied.
+!C     * IORDER	= 1 means vertical levels are indexed from top down 
+!C     *           (i.e., highest level indexed 1 and lowest level NLEVS);
+!C     *           .NE. 1 highest level is index NLEVS.
+!C     * IL1     = first longitudinal index to use (IL1 >= 1).
+!C     * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+!C     * LEV1    = first altitude level to use (LEV1 >=1). 
+!C     * LEV2    = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+!C     * NLONS   = number of longitudes.
+!C     * NLEVS   = number of vertical
+!C
+!C  Input work arrays:
+!C
+!C     * DATA_ZMAX = data values just above altitude ALT_EXP.
+!C
+      INTEGER  IORDER, IL1, IL2, LEV1, LEV2, NLONS, NLEVS
+      REAL  ALT_EXP
+      REAL  DATA(NLONS,NLEVS), DATA_ZMAX(NLONS), ALT(NLONS,NLEVS)
+!C
+!C Internal variables.
+!C
+      INTEGER  LEVBOT, LEVTOP, LINCR, I, L
+      REAL  HSCALE
+      DATA  HSCALE / 5.E3 /
+!C-----------------------------------------------------------------------     
+!C
+!C  Index of lowest altitude level (bottom of drag calculation).
+!C
+      LEVBOT = LEV2
+      LEVTOP = LEV1
+      LINCR  = 1
+      IF (IORDER.NE.1)  THEN
+        LEVBOT = LEV1
+        LEVTOP = LEV2
+        LINCR  = -1
+      END IF
+!C
+!C  Data values at first level above ALT_EXP.
+!C
+      DO 20 I = IL1,IL2
+        DO 10 L = LEVTOP,LEVBOT,LINCR
+          IF (ALT(I,L) .GE. ALT_EXP)  THEN
+            DATA_ZMAX(I) = DATA(I,L) 
+          END IF	   
+ 10     CONTINUE
+ 20   CONTINUE
+!C
+!C  Exponentially damp field above ALT_EXP to model top at L=1.
+!C
+      DO 40 L = 1,LEV2 
+        DO 30 I = IL1,IL2
+          IF (ALT(I,L) .GE. ALT_EXP)  THEN
+            DATA(I,L) = DATA_ZMAX(I) * EXP( (ALT_EXP-ALT(I,L))/HSCALE )
+          END IF
+ 30     CONTINUE
+ 40   CONTINUE
+!C
+      RETURN
+!C-----------------------------------------------------------------------
+      END SUBROUTINE HINES_EXP
+
+      SUBROUTINE VERT_SMOOTH (DATA,WORK,COEFF,NSMOOTH,                               &
+       &                        IL1,IL2,LEV1,LEV2,NLONS,NLEVS)
+!C
+!C  Smooth a longitude by altitude array in the vertical over a
+!C  specified number of levels using a three point smoother. 
+!C
+!C  NOTE: input array DATA is modified on output!
+!C
+!C  Aug. 3/95 - C. McLandress
+!C
+!C  Output arguement:
+!C
+!C     * DATA    = smoothed array (on output).
+!C
+!C  Input arguements:
+!C
+!C     * DATA    = unsmoothed array of data (on input).
+!C     * WORK    = work array of same dimension as DATA.
+!C     * COEFF   = smoothing coefficient for a 1:COEFF:1 stencil.
+!C     *           (e.g., COEFF = 2 will result in a smoother which
+!C     *           weights the level L gridpoint by two and the two 
+!C     *           adjecent levels (L+1 and L-1) by one).
+!C     * NSMOOTH = number of times to smooth in vertical.
+!C     *           (e.g., NSMOOTH=1 means smoothed only once, 
+!C     *           NSMOOTH=2 means smoothing repeated twice, etc.)
+!C     * IL1     = first longitudinal index to use (IL1 >= 1).
+!C     * IL2     = last longitudinal index to use (IL1 <= IL2 <= NLONS).
+!C     * LEV1    = first altitude level to use (LEV1 >=1). 
+!C     * LEV2    = last altitude level to use (LEV1 < LEV2 <= NLEVS).
+!C     * NLONS   = number of longitudes.
+!C     * NLEVS   = number of vertical levels.
+!C
+!C  Subroutine arguements.
+!C
+      INTEGER  NSMOOTH, IL1, IL2, LEV1, LEV2, NLONS, NLEVS
+      REAL  COEFF
+      REAL  DATA(NLONS,NLEVS), WORK(NLONS,NLEVS)
+!C
+!C  Internal variables.
+!C
+      INTEGER  I, L, NS, LEV1P, LEV2M
+      REAL  SUM_WTS
+!C-----------------------------------------------------------------------     
+!C
+!C  Calculate sum of weights.
+!C
+      SUM_WTS = COEFF + 2.
+!C
+      LEV1P = LEV1 + 1
+      LEV2M = LEV2 - 1
+!C
+!C  Smooth NSMOOTH times
+!C
+      DO 50 NS = 1,NSMOOTH
+!C
+!C  Copy data into work array.
+!C
+        DO 20 L = LEV1,LEV2
+          DO 10 I = IL1,IL2
+            WORK(I,L) = DATA(I,L)
+ 10       CONTINUE
+ 20     CONTINUE
+!C
+!C  Smooth array WORK in vertical direction and put into DATA.
+!C
+        DO 40 L = LEV1P,LEV2M
+          DO 30 I = IL1,IL2
+            DATA(I,L) = ( WORK(I,L+1) + COEFF*WORK(I,L) + WORK(I,L-1) )              &
+       &                    / SUM_WTS 
+ 30       CONTINUE
+ 40     CONTINUE
+!C
+ 50   CONTINUE
+!C
+      RETURN
+!C-----------------------------------------------------------------------
+      END SUBROUTINE VERT_SMOOTH
+
+
+
+
+      
+      
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/indice_sol_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/indice_sol_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/indice_sol_mod.F90	(revision 17)
@@ -0,0 +1,12 @@
+      MODULE indice_sol_mod
+            INTEGER, PARAMETER :: nbsrf = 4 ! nombre de sous-fractions pour une maille
+            INTEGER, PARAMETER :: is_ter=1, is_lic=2, is_oce = 3, is_sic=4
+                              ! terre ! ocean ! glacier continental ! glace de mer
+
+            INTEGER, PARAMETER :: is_ave=nbsrf+1 ! glacier continental
+            REAL, PARAMETER :: epsfra=1.0E-05
+
+            CHARACTER(len=3), DIMENSION(nbsrf), PARAMETER :: clnsurf = (/'ter', 'lic', 'oce', 'sic'/)
+
+      END MODULE indice_sol_mod
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/infotrac.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/infotrac.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/infotrac.F90	(revision 17)
@@ -0,0 +1,390 @@
+! $Id$
+!
+MODULE infotrac
+
+! nqtot : total number of tracers and higher order of moment, water vapor and liquid included
+  INTEGER, SAVE :: nqtot
+
+! nbtr : number of tracers not including higher order of moment or water vapor or liquid
+!        number of tracers used in the physics
+  INTEGER, SAVE :: nbtr
+
+! Name variables
+  CHARACTER(len=20), ALLOCATABLE, DIMENSION(:), SAVE :: tname ! tracer short name for restart and diagnostics
+  CHARACTER(len=23), ALLOCATABLE, DIMENSION(:), SAVE :: ttext ! tracer long name for diagnostics
+
+! iadv  : index of trasport schema for each tracer
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: iadv
+
+! niadv : vector keeping the coorspondance between all tracers(nqtot) treated in the 
+!         dynamic part of the code and the tracers (nbtr+2) used in the physics part of the code. 
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE    :: niadv ! equivalent dyn / physique
+
+! conv_flg(it)=0 : convection desactivated for tracer number it 
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: conv_flg
+! pbl_flg(it)=0  : boundary layer diffusion desactivaded for tracer number it 
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE  :: pbl_flg
+
+  CHARACTER(len=4),SAVE :: type_trac
+ 
+CONTAINS
+
+  SUBROUTINE infotrac_init
+    USE control_mod
+#ifdef REPROBUS
+    USE CHEM_REP, ONLY : Init_chem_rep_trac
+#endif
+    IMPLICIT NONE
+!=======================================================================
+!
+!   Auteur:  P. Le Van /L. Fairhead/F.Hourdin
+!   -------
+!   Modif special traceur F.Forget 05/94
+!   Modif M-A Filiberti 02/02 lecture de traceur.def
+!
+!   Objet:
+!   ------
+!   GCM LMD nouvelle grille
+!
+!=======================================================================
+!   ... modification de l'integration de q ( 26/04/94 ) ....
+!-----------------------------------------------------------------------
+! Declarations
+
+    INCLUDE "dimensions.h"
+    INCLUDE "iniprint.h"
+
+! Local variables
+    INTEGER, ALLOCATABLE, DIMENSION(:) :: hadv  ! index of horizontal trasport schema
+    INTEGER, ALLOCATABLE, DIMENSION(:) :: vadv  ! index of vertical trasport schema
+
+    CHARACTER(len=15), ALLOCATABLE, DIMENSION(:) :: tnom_0  ! tracer short name
+    CHARACTER(len=8), ALLOCATABLE, DIMENSION(:) :: tracnam ! name from INCA
+    CHARACTER(len=3), DIMENSION(30) :: descrq
+    CHARACTER(len=1), DIMENSION(3)  :: txts
+    CHARACTER(len=2), DIMENSION(9)  :: txtp
+    CHARACTER(len=23)               :: str1,str2
+  
+    INTEGER :: nqtrue  ! number of tracers read from tracer.def, without higer order of moment
+    INTEGER :: iq, new_iq, iiq, jq, ierr
+
+    character(len=*),parameter :: modname="infotrac_init"
+!-----------------------------------------------------------------------
+! Initialization :
+!
+    txts=(/'x','y','z'/)
+    txtp=(/'x ','y ','z ','xx','xy','xz','yy','yz','zz'/)
+
+    descrq(14)='VLH'
+    descrq(10)='VL1'
+    descrq(11)='VLP'
+    descrq(12)='FH1'
+    descrq(13)='FH2'
+    descrq(16)='PPM'
+    descrq(17)='PPS'
+    descrq(18)='PPP'
+    descrq(20)='SLP'
+    descrq(30)='PRA'
+    
+
+    ! Coherence test between parameter type_trac, config_inca and preprocessing keys
+    IF (type_trac=='inca') THEN
+       WRITE(lunout,*) 'You have choosen to couple with INCA chemestry model : type_trac=', &
+            type_trac,' config_inca=',config_inca
+       IF (config_inca/='aero' .AND. config_inca/='chem') THEN
+          WRITE(lunout,*) 'Incoherence between type_trac and config_inca. Model stops. Modify run.def'
+          CALL abort_gcm('infotrac_init','Incoherence between type_trac and config_inca',1)
+       END IF
+#ifndef INCA
+       WRITE(lunout,*) 'To run this option you must add cpp key INCA and compile with INCA code'
+       CALL abort_gcm('infotrac_init','You must compile with cpp key INCA',1)
+#endif
+    ELSE IF (type_trac=='repr') THEN
+       WRITE(lunout,*) 'You have choosen to couple with REPROBUS chemestry model : type_trac=', type_trac
+#ifndef REPROBUS
+       WRITE(lunout,*) 'To run this option you must add cpp key REPROBUS and compile with REPRPBUS code'
+       CALL abort_gcm('infotrac_init','You must compile with cpp key REPROBUS',1)
+#endif
+    ELSE IF (type_trac == 'lmdz') THEN
+       WRITE(lunout,*) 'Tracers are treated in LMDZ only : type_trac=', type_trac
+    ELSE
+       WRITE(lunout,*) 'type_trac=',type_trac,' not possible. Model stops'
+       CALL abort_gcm('infotrac_init','bad parameter',1)
+    END IF
+
+
+    ! Test if config_inca is other then none for run without INCA
+    IF (type_trac/='inca' .AND. config_inca/='none') THEN
+       WRITE(lunout,*) 'config_inca will now be changed to none as you do not couple with INCA model'
+       config_inca='none'
+    END IF
+
+
+!-----------------------------------------------------------------------
+!
+! 1) Get the true number of tracers + water vapor/liquid
+!    Here true tracers (nqtrue) means declared tracers (only first order)
+!
+!-----------------------------------------------------------------------
+    IF (type_trac == 'lmdz' .OR. type_trac == 'repr') THEN
+       OPEN(90,file='traceur.def',form='formatted',status='old', iostat=ierr)
+       IF(ierr.EQ.0) THEN
+          WRITE(lunout,*) trim(modname),': Open traceur.def : ok'
+          READ(90,*) nqtrue
+       ELSE 
+          WRITE(lunout,*) trim(modname),': Problem in opening traceur.def'
+          WRITE(lunout,*) trim(modname),': WARNING using defaut values'
+          if (planet_type=='earth') then
+            nqtrue=4 ! Default value for Earth
+          else
+            nqtrue=1 ! Default value for other planets
+          endif
+       END IF
+       if ( planet_type=='earth') then
+         ! For Earth, water vapour & liquid tracers are not in the physics
+         nbtr=nqtrue-2
+       else
+         ! Other planets (for now); we have the same number of tracers
+         ! in the dynamics than in the physics
+         nbtr=nqtrue
+       endif
+    ELSE ! type_trac=inca
+       ! nbtr has been read from INCA by init_const_lmdz() in gcm.F 
+       nqtrue=nbtr+2
+    END IF
+
+    IF ((planet_type=="earth").and.(nqtrue < 2)) THEN
+       WRITE(lunout,*) trim(modname),': nqtrue=',nqtrue, ' is not allowded. 2 tracers is the minimum'
+       CALL abort_gcm('infotrac_init','Not enough tracers',1)
+    END IF
+    
+! Transfert number of tracers to Reprobus
+    IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+       CALL Init_chem_rep_trac(nbtr)
+#endif
+    END IF
+       
+!
+! Allocate variables depending on nqtrue and nbtr
+!
+    ALLOCATE(tnom_0(nqtrue), hadv(nqtrue), vadv(nqtrue))
+    ALLOCATE(conv_flg(nbtr), pbl_flg(nbtr), tracnam(nbtr))
+    conv_flg(:) = 1 ! convection activated for all tracers
+    pbl_flg(:)  = 1 ! boundary layer activated for all tracers
+
+!-----------------------------------------------------------------------
+! 2)     Choix  des schemas d'advection pour l'eau et les traceurs
+!
+!     iadv = 1    schema  transport type "humidite specifique LMD"
+!     iadv = 2    schema   amont
+!     iadv = 14   schema  Van-leer + humidite specifique 
+!                            Modif F.Codron
+!     iadv = 10   schema  Van-leer (retenu pour l'eau vapeur et liquide)
+!     iadv = 11   schema  Van-Leer pour hadv et version PPM (Monotone) pour vadv
+!     iadv = 12   schema  Frederic Hourdin I
+!     iadv = 13   schema  Frederic Hourdin II
+!     iadv = 16   schema  PPM Monotone(Collela & Woodward 1984)
+!     iadv = 17   schema  PPM Semi Monotone (overshoots autorisés)
+!     iadv = 18   schema  PPM Positif Defini (overshoots undershoots autorisés)
+!     iadv = 20   schema  Slopes
+!     iadv = 30   schema  Prather
+!
+!        Dans le tableau q(ij,l,iq) : iq = 1  pour l'eau vapeur
+!                                     iq = 2  pour l'eau liquide
+!       Et eventuellement             iq = 3,nqtot pour les autres traceurs
+!
+!        iadv(1): choix pour l'eau vap. et  iadv(2) : choix pour l'eau liq.
+!------------------------------------------------------------------------
+!
+!    Get choice of advection schema from file tracer.def or from INCA
+!---------------------------------------------------------------------
+    IF (type_trac == 'lmdz' .OR. type_trac == 'repr') THEN
+       IF(ierr.EQ.0) THEN
+          ! Continue to read tracer.def
+          DO iq=1,nqtrue
+             READ(90,*) hadv(iq),vadv(iq),tnom_0(iq)
+          END DO
+          CLOSE(90)  
+       ELSE ! Without tracer.def, set default values 
+         if (planet_type=="earth") then
+          ! for Earth, default is to have 4 tracers
+          hadv(1) = 14
+          vadv(1) = 14
+          tnom_0(1) = 'H2Ov'
+          hadv(2) = 10
+          vadv(2) = 10
+          tnom_0(2) = 'H2Ol'
+          hadv(3) = 10
+          vadv(3) = 10
+          tnom_0(3) = 'RN'
+          hadv(4) = 10
+          vadv(4) = 10
+          tnom_0(4) = 'PB'
+         else ! default for other planets
+          hadv(1) = 10
+          vadv(1) = 10
+          tnom_0(1) = 'dummy'
+         endif ! of if (planet_type=="earth")
+       END IF
+       
+       WRITE(lunout,*) trim(modname),': Valeur de traceur.def :'
+       WRITE(lunout,*) trim(modname),': nombre de traceurs ',nqtrue
+       DO iq=1,nqtrue
+          WRITE(lunout,*) hadv(iq),vadv(iq),tnom_0(iq)
+       END DO
+
+    ELSE  ! type_trac=inca : config_inca='aero' ou 'chem'
+! le module de chimie fournit les noms des traceurs
+! et les schemas d'advection associes.
+     
+#ifdef INCA
+       CALL init_transport( &
+            hadv, &
+            vadv, &
+            conv_flg, &
+            pbl_flg,  &
+            tracnam)
+#endif
+       tnom_0(1)='H2Ov'
+       tnom_0(2)='H2Ol'
+
+       DO iq =3,nqtrue
+          tnom_0(iq)=tracnam(iq-2)
+       END DO
+
+    END IF ! type_trac
+
+!-----------------------------------------------------------------------
+!
+! 3) Verify if advection schema 20 or 30 choosen
+!    Calculate total number of tracers needed: nqtot
+!    Allocate variables depending on total number of tracers
+!-----------------------------------------------------------------------
+    new_iq=0
+    DO iq=1,nqtrue
+       ! Add tracers for certain advection schema
+       IF (hadv(iq)<20 .AND. vadv(iq)<20 ) THEN
+          new_iq=new_iq+1  ! no tracers added
+       ELSE IF (hadv(iq)==20 .AND. vadv(iq)==20 ) THEN
+          new_iq=new_iq+4  ! 3 tracers added
+       ELSE IF (hadv(iq)==30 .AND. vadv(iq)==30 ) THEN
+          new_iq=new_iq+10 ! 9 tracers added
+       ELSE
+          WRITE(lunout,*) trim(modname),': This choice of advection schema is not available',iq,hadv(iq),vadv(iq)
+          CALL abort_gcm('infotrac_init','Bad choice of advection schema - 1',1)
+       END IF
+    END DO
+    
+    IF (new_iq /= nqtrue) THEN
+       ! The choice of advection schema imposes more tracers
+       ! Assigne total number of tracers
+       nqtot = new_iq
+
+       WRITE(lunout,*) trim(modname),': The choice of advection schema for one or more tracers'
+       WRITE(lunout,*) 'makes it necessary to add tracers'
+       WRITE(lunout,*) trim(modname)//': ',nqtrue,' is the number of true tracers'
+       WRITE(lunout,*) trim(modname)//': ',nqtot, ' is the total number of tracers needed'
+
+    ELSE
+       ! The true number of tracers is also the total number
+       nqtot = nqtrue
+    END IF
+
+!
+! Allocate variables with total number of tracers, nqtot
+!
+    ALLOCATE(tname(nqtot), ttext(nqtot))
+    ALLOCATE(iadv(nqtot), niadv(nqtot))
+
+!-----------------------------------------------------------------------
+!
+! 4) Determine iadv, long and short name
+!
+!-----------------------------------------------------------------------
+    new_iq=0
+    DO iq=1,nqtrue
+       new_iq=new_iq+1
+
+       ! Verify choice of advection schema
+       IF (hadv(iq)==vadv(iq)) THEN
+          iadv(new_iq)=hadv(iq)
+       ELSE IF (hadv(iq)==10 .AND. vadv(iq)==16) THEN
+          iadv(new_iq)=11
+       ELSE
+          WRITE(lunout,*)trim(modname),': This choice of advection schema is not available',iq,hadv(iq),vadv(iq)
+
+          CALL abort_gcm('infotrac_init','Bad choice of advection schema - 2',1)
+       END IF
+      
+       str1=tnom_0(iq)
+       tname(new_iq)= tnom_0(iq)
+       IF (iadv(new_iq)==0) THEN
+          ttext(new_iq)=trim(str1)
+       ELSE
+          ttext(new_iq)=trim(tnom_0(iq))//descrq(iadv(new_iq))
+       END IF
+
+       ! schemas tenant compte des moments d'ordre superieur
+       str2=ttext(new_iq)
+       IF (iadv(new_iq)==20) THEN
+          DO jq=1,3
+             new_iq=new_iq+1
+             iadv(new_iq)=-20
+             ttext(new_iq)=trim(str2)//txts(jq)
+             tname(new_iq)=trim(str1)//txts(jq)
+          END DO
+       ELSE IF (iadv(new_iq)==30) THEN
+          DO jq=1,9
+             new_iq=new_iq+1
+             iadv(new_iq)=-30
+             ttext(new_iq)=trim(str2)//txtp(jq)
+             tname(new_iq)=trim(str1)//txtp(jq)
+          END DO
+       END IF
+    END DO
+
+!
+! Find vector keeping the correspodence between true and total tracers
+!
+    niadv(:)=0
+    iiq=0
+    DO iq=1,nqtot
+       IF(iadv(iq).GE.0) THEN
+          ! True tracer
+          iiq=iiq+1
+          niadv(iiq)=iq
+       ENDIF
+    END DO
+
+
+    WRITE(lunout,*) trim(modname),': Information stored in infotrac :'
+    WRITE(lunout,*) trim(modname),': iadv  niadv tname  ttext :'
+    DO iq=1,nqtot
+       WRITE(lunout,*) iadv(iq),niadv(iq),&
+       ' ',trim(tname(iq)),' ',trim(ttext(iq))
+    END DO
+
+!
+! Test for advection schema. 
+! This version of LMDZ only garantees iadv=10 and iadv=14 (14 only for water vapour) .
+!
+    DO iq=1,nqtot
+       IF (iadv(iq)/=10 .AND. iadv(iq)/=14 .AND. iadv(iq)/=0) THEN
+          WRITE(lunout,*)trim(modname),' STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ'
+          CALL abort_gcm('infotrac_init','In this version only iadv=10 and iadv=14 is tested!',1)
+       ELSE IF (iadv(iq)==14 .AND. iq/=1) THEN
+          WRITE(lunout,*)trim(modname),'STOP : The option iadv=',iadv(iq),' is not tested in this version of LMDZ'
+          CALL abort_gcm('infotrac_init','In this version iadv=14 is only permitted for water vapour!',1)
+       END IF
+    END DO
+
+!-----------------------------------------------------------------------
+! Finalize :
+!
+    DEALLOCATE(tnom_0, hadv, vadv)
+    DEALLOCATE(tracnam)
+
+  END SUBROUTINE infotrac_init
+
+END MODULE infotrac
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histISCCP.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histISCCP.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histISCCP.h	(revision 17)
@@ -0,0 +1,277 @@
+!
+! $Id: ini_histISCCP.h 1403 2010-07-01 09:02:53Z fairhead $
+!
+      IF (ok_isccp) THEN
+!c
+!$OMP MASTER
+      ndex2d = 0
+      ndex3d = 0
+!c
+!c pour les champs instantannes, il faut mettre la meme valeur pour
+!c zout et zsto.
+!c dtime est passe par ailleurs a histbeg
+!c zstophy = frequence de stockage des champs tous les pdt physiques
+!c zout = frequence d'ecriture des champs
+!IM 300505     zstophy = dtime 
+!c appel du simulateur toutes les 3heures
+!IM on lit la frequence d'appel dans physiq.def
+!         zcals(1) = dtime *6.  !toutes les 3h (en s)
+          zcals(1) = freq_ISCCP !toutes les freq_ISCCP secondes
+        DO n=1, napisccp
+          zcalh(n) = zcals(n)/3600. !stoutes les Xh (en heures)
+        ENDDO !n
+!c
+!c ecriture 8 fois par jour
+!c       zout = dtime * REAL(NINT(86400./dtime*ecrit_isccp))
+!c ecriture toutes les 2h (12 fois par jour)
+!c       zout = dtime * 4.
+!c ecriture toutes les 1/2 h (48 fois par jour)
+!c       zout = dtime
+!c
+!c       IF(freqout_isccp.EQ.1.) THEN
+!c ecriture jounaliere
+!IM on ecrit les resultats du simulateur ISCCP toutes les 
+! ecrit_ISCCP secondes      zout_isccp(1) = ecrit_day !(en s)
+          zout_isccp(1) = ecrit_ISCCP !(en s)
+!c ecriture mensuelle
+!c         zout = dtime * ecrit_mth !(en s)
+        DO n=1, napisccp 
+          zoutj(n)=zout_isccp(n)/86400. !(en jours)
+!c
+!c le nombre de sous-colonnes ncol : ncol=(100.*zcalh)/zoutd
+          ncol(n)=NINT((100.*zcalh(n))/zoutj(n))
+          IF(ncol(n).GT.ncolmx) THEN
+           PRINT*,'Warning: Augmenter le nombre colonnes du simulateur'
+           PRINT*,'         ISCCP ncol=', ncol,' ncolmx=',ncolmx
+!c          PRINT*,'n ncol',n,ncol(n)
+           CALL abort
+          ENDIF
+!c
+        DO l=1, ncol(n)
+          vertlev(l,n)=REAL(l)
+        ENDDO !ncol
+!c
+        ENDDO !n
+
+!c       PRINT*, 'La frequence de sortie ISCCP est de ', ecrit_isccp
+!c
+        idayref = day_ref
+        CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+!c       write(*,*)'ISCCP ', itau_phy, zjulian
+!c
+!c
+!c definition coordonnees lon,lat en globale
+!c
+!cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+!cym        DO i = 1, iim
+!cym          zx_lon(i,1) = rlon(i+1)
+!cym          zx_lon(i,jjmp1) = rlon(i+1)
+!cym        ENDDO
+
+!cym        CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+!c
+!IM BEG region
+!cym Desole dans un premier temps le mode region ne marchera pas
+!cym Il faudra voir dans un second temps pour l'implementer
+!cym Mais cela posera des problemes au niveau de la reconstruction
+
+          imin_ins=1
+          imax_ins=iim
+          jmin_ins=1
+          jmax_ins=jjmp1
+!cym          do i=1,iim-1
+!cym             if(zx_lon(i,1).lt.lonmin_ins) imin_ins=i
+!cym             if(zx_lon(i,1).le.lonmax_ins) imax_ins=i+1
+!cym          enddo
+!cym          do j=1,jjmp1
+!cym             if(zx_lat(1,j).ge.latmin_ins) jmax_ins=j
+!cym             if(zx_lat(1,j).gt.latmax_ins) jmin_ins=j
+!cym          enddo
+!c
+          print*,'On stoke le fichier histISCCP sur ',                               &
+       &   imin_ins,imax_ins,jmin_ins,jmax_ins
+!cym          print*,'On stoke le fichier histISCCP instantanne sur ',
+!cym     s   zx_lon(imin_ins,1),zx_lon(imax_ins,1),
+!cym     s   zx_lat(1,jmin_ins),zx_lat(1,jmax_ins)
+!IM END region
+!c
+        IF(1.EQ.0) THEN
+!cym         CALL histbeg("histISCCP.nc", iim,zx_lon(:,1),jjmp1,zx_lat(1,:),
+!cym     .                 1, iim, 1, jjmp1,
+!cym     .                 itau_phy, zjulian, dtime,
+!cym     .                 nhori, nid_isccp)
+         CALL histbeg_phy("histISCCP.nc", itau_phy, zjulian, dtime,                  &
+       &                 nhori, nid_isccp)
+        ENDIF !(1.EQ.0) THEN
+!c
+!cym         CALL histbeg("histISCCP.nc", iim,zx_lon(:,1),
+!cym     .                 jjmp1,zx_lat(1,:),
+!cym     .                 imin_ins,imax_ins-imin_ins+1,
+!cym     .                 jmin_ins,jmax_ins-jmin_ins+1,
+!cym     .                 itau_phy, zjulian, dtime,
+!cym     .                 nhori, nid_isccp)
+
+         CALL histbeg_phy("histISCCP.nc", itau_phy, zjulian, dtime,                  &
+       &                 nhori, nid_isccp)
+!c
+        IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+         CALL histvert(nid_isccp, "cldtopres","Cloud Top Pressure","mb",             &
+       &                 lmaxm1, cldtopres, nvert,'down')
+        ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+         CALL histvert(nid_isccp,"cldtopres3","Cloud Top Pressure","mb",             &
+       &                 lmax3, cldtopres3, nvert3,'down')
+        ENDIF
+        DO n=1, napisccp
+         CALL histvert(nid_isccp, "Nbcol"//verticaxe(n),                             &
+       &        "Nb of Column"//verticaxe(n),"1",                                    &
+       &        ncol(n), vertlev(:,n), nvlev(n),'up')
+        ENDDO
+!c
+        IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+!c
+!c variables a ecrire
+!c 
+         DO n=1, napisccp
+!c
+         DO k=1, kmaxm1
+          CALL histdef(nid_isccp, "cldISCCP_"//taulev(k)//verticaxe(n),              &
+       &                "LMDZ ISCCP cld", "%",                                       &
+       &                iim, jj_nb,nhori,lmaxm1,1,lmaxm1,nvert,32,                   &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+         ENDDO
+!c
+         CALL histdef(nid_isccp, "nsunlit"//verticaxe(n),                            &
+       &                "Nb of calls with sunlit ", "%",                             &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+         CALL histdef(nid_isccp, "meantaucld"//verticaxe(n),                         &
+       &                "ISCCP mean cloud optical thickness", "1",                   &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+         ENDDO
+!c
+        ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+!c
+         DO n=1, napisccp
+!c
+!c         print*,'n=',n,' avant histdef(..LMDZ ISCCP cld'
+!c
+          DO k=1, kmaxm1
+           DO l=1, lmaxm1
+!c
+           CALL histdef(nid_isccp, pclev(l)//taulev(k)//verticaxe(n),                &
+       &                "LMDZ ISCCP cld "//cnameisccp(l,k), "%",                     &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+           ENDDO
+          ENDDO
+!c
+!c         print*,'n=',n,' avant histdef(..Nb of calls sunlit'
+          CALL histdef(nid_isccp, "nsunlit"//verticaxe(n),                           &
+       &                "Nb of calls with sunlit ", "%",                             &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+         CALL histdef(nid_isccp, "meantaucld"//verticaxe(n),                         &
+       &                "ISCCP mean cloud optical thickness", "1",                   &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+!c 9types de nuages ISCCP-D2
+          CALL histdef(nid_isccp, "cirr",                                            &
+       &                "Cirrus lk ISCCP-D2", "%",                                   &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+          CALL histdef(nid_isccp, "cist",                                            &
+       &                "CiSt lk ISCCP-D2", "%",                                     &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+          CALL histdef(nid_isccp, "deep",                                            &
+       &                "Deep lk ISCCP-D2", "%",                                     &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+          CALL histdef(nid_isccp, "alcu",                                            &
+       &                "AlCu lk ISCCP-D2", "%",                                     &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+          CALL histdef(nid_isccp, "alst",                                            &
+       &                "AlSt lk ISCCP-D2", "%",                                     &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+          CALL histdef(nid_isccp, "nist",                                            &
+       &                "NiSt lk ISCCP-D2", "%",                                     &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+          CALL histdef(nid_isccp, "cumu",                                            &
+       &                "Cumu lk ISCCP-D2", "%",                                     &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+          CALL histdef(nid_isccp, "stcu",                                            &
+       &                "StCu lk ISCCP-D2", "%",                                     &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+          CALL histdef(nid_isccp, "stra",                                            &
+       &                "Stra lk ISCCP-D2", "%",                                     &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+!c 3_epaisseurs_optiques x3_pressions_au_sommet_des_nuages  types de nuages 
+          CALL histdef(nid_isccp, "thin",                                            &
+       &                "Opt. thin ISCCP-D2 like clouds", "%",                       &
+       &                iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32,                    &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+          CALL histdef(nid_isccp, "mid",                                             &
+       &                "Opt. intermediate ISCCP-D2 like clouds", "%",               &
+       &                iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32,                    &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+          CALL histdef(nid_isccp, "thick",                                           &
+       &                "Opt. thick ISCCP-D2 like clouds", "%",                      &
+       &                iim, jj_nb,nhori,lmax3,1,lmax3,nvert3,32,                    &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+!c        IF(1.EQ.0) THEN
+!c        IF(n.EQ.3) THEN
+!c        IF(n.EQ.1) THEN
+!c
+!IM 070905 BEG
+         IF(1.EQ.0) THEN
+          print*,'n=',n,' avant histdef(..boxptop axe'
+!IM verif boxptop
+          CALL histdef(nid_isccp,"boxptop"//verticaxe(n),                            &
+       &                "Boxptop axe"//verticaxe(n), "mb",                           &
+       &                iim, jj_nb,nhori,                                            &
+       &                ncol(n),1,ncol(n),nvlev(n),32,                               &
+!IM  .                ncolmx,1,ncolmx,nvlev,32,
+!IM  .                "inst(X)",dtime,dtime)                                         &
+       &                "ave(X)",zcals(n),zout_isccp(n))
+         ENDIF !(1.EQ.0) THEN
+!IM 070905 END
+!c        ENDIF !(n.EQ.3) THEN
+!c       ENDIF !(1.EQ.0) THEN
+!c
+!c         print*,'n=',n,' avant histdef(..seed axe'
+          CALL histdef(nid_isccp, "seed"//verticaxe(n),                              &
+       &                "seed axe"//verticaxe(n), "-",                               &
+       &                iim, jj_nb,nhori,1,1,1,-99,32,                               &
+!IM  .                "inst(X)", dtime,dtime)                                        &
+       &                "ave(X)", zcals(n),zout_isccp(n))
+!c
+         ENDDO !n
+        ENDIF 
+        CALL histend(nid_isccp)
+!c
+!$OMP END MASTER
+      ENDIF ! ok_isccp
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histdayNMC.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histdayNMC.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histdayNMC.h	(revision 17)
@@ -0,0 +1,140 @@
+!
+! $Header$
+!
+!$OMP MASTER
+      IF (ok_histNMC(2)) THEN
+!c
+       zstophy = dtime
+       zstohf = ecrit_hf
+       zstomth = ecrit_mth
+       zout = freq_outNMC(2)
+!c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+!c
+!cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+!cym         DO i = 1, iim
+!cym            zx_lon(i,1) = rlon(i+1)
+!cym            zx_lon(i,jjmp1) = rlon(i+1)
+!cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+!cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+!cym         CALL histbeg("histNMC.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+!cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+!cym     .                 nhori, nid_daynmc)
+
+         CALL histbeg_phy("histdayNMC",itau_phy, zjulian, dtime,                     &
+       &                 nhori, nid_daynmc)
+!c
+        IF(lev_histdayNMC.EQ.nlevSTD) THEN 
+         CALL histvert(nid_daynmc, "plev", "pressure", "Pa",                         &
+       &                 nlevSTD, rlevSTD, nvert,"down")
+        ELSE IF(lev_histdayNMC.EQ.nlevSTD8) THEN 
+         CALL histvert(nid_daynmc, "plev", "pressure", "Pa",                         &
+       &                 nlevSTD8, rlevSTD8, nvert,"down")
+        ENDIF
+!c
+!IM Astuce MAF: remplacer inst par ave pour les variables NMC pour avoir
+!IM             le time_counter et les bounds
+!c
+!ccc Champs 3D interpolles sur des niveaux de pression du NMC
+!ccc
+!c
+!c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh
+!c             sur les niveaux du NMC et on somme & moyenne
+!c             toutes les freq_moyNMC secondes par des routines undefSTD et
+!c             moy_undefSTD pour eliminer les valeurs "undef"
+!c             de la moyenne mensuelle
+!c ======> le "inst(X)" ci-dessous est par consequence factice !
+!c
+        IF(lev_histdayNMC.EQ.nlevSTD) THEN 
+          CALL histdef(nid_daynmc, "tnondef",                                        &
+       &                 "Valeurs non-definies","-",                                 &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_daynmc, "ta",                                             &
+       &                 "Air temperature","K",                                      &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+         CALL histdef(nid_daynmc, "zg",                                              &
+       &                "Geopotential height", "m",                                  &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_daynmc, "hus",                                            &
+       &                 "Specific humidity","1",                                    &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+         CALL histdef(nid_daynmc, "hur",                                             &
+       &                 "Relative humidity", "%",                                   &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_daynmc, "ua",                                             &
+       &                 "Eastward wind","m s-1",                                    &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_daynmc, "va",                                             &
+       &                 "Northward wind","m s-1",                                   &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_daynmc, "wap",                                            &
+       &                 "Lagrangian tendency of air pressure","Pa s-1",             &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+        ELSE IF(lev_histdayNMC.EQ.nlevSTD8) THEN 
+!c
+          CALL histdef(nid_daynmc, "tnondef",                                        &
+       &                 "Valeurs non-definies","-",                                 &
+       &                iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_daynmc, "ta",                                             &
+       &                 "Air temperature","K",                                      &
+       &                iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+         CALL histdef(nid_daynmc, "zg",                                              &
+       &                "Geopotential height", "m",                                  &
+       &                iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_daynmc, "hus",                                            &
+       &                 "Specific humidity","1",                                    &
+       &                iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+         CALL histdef(nid_daynmc, "hur",                                             &
+       &                 "Relative humidity", "%",                                   &
+       &                iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_daynmc, "ua",                                             &
+       &                 "Eastward wind","m s-1",                                    &
+       &                iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_daynmc, "va",                                             &
+       &                 "Northward wind","m s-1",                                   &
+       &                iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_daynmc, "wap",                                            &
+       &                 "Lagrangian tendency of air pressure","Pa s-1",             &
+       &                iim,jj_nb,nhori, nlevSTD8,1,nlevSTD8, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+        ENDIF
+!c
+         CALL histend(nid_daynmc)
+!c
+      ENDIF !(ok_histNMC(2)) THEN
+!$OMP END MASTER
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histday_seri.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histday_seri.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histday_seri.h	(revision 17)
@@ -0,0 +1,131 @@
+!c
+!c $Id: ini_histday_seri.h 1403 2010-07-01 09:02:53Z fairhead $
+!c
+!cym Ne fonctionnera pas en mode parallele
+      IF (is_sequential) THEN
+      
+      IF (type_run.EQ."AMIP") THEN
+!c
+       zstophy = dtime
+       zout = ecrit_day
+!c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+!c
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+         DO i = 1, iim
+            zx_lon(i,1) = rlon(i+1)
+            zx_lon(i,jjmp1) = rlon(i+1)
+         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=REAL(ll)
+         ENDDO
+         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+!c
+         imin_debut=1 
+         nbpti=1
+         jmin_debut=1 
+         nbptj=1
+!c
+         CALL histbeg("histday_seri.nc",                                             &
+       &                 iim,zx_lon(:,1), jjmp1,zx_lat(1,:),                         &
+       &                 imin_debut,nbpti,jmin_debut,nbptj,                          &
+       &                 itau_phy, zjulian, dtime,                                   &
+       &                 nhori, nid_day_seri)
+!c
+         CALL histvert(nid_day_seri, "presnivs",                                     &
+       &                "Vertical levels","mb",                                      &
+       &                 klev, presnivs/100., nvert)
+!c
+         CALL histdef(nid_day_seri, "bilTOA",                                        &
+       &                "Net radiation at model top", "W/m2",                        &
+       &                iim,jjmp1,nhori, 1,1,1, -99, 32,                             &
+       &                "ave(X)", zstophy,zout)
+!c
+         CALL histdef(nid_day_seri, "bils",                                          &
+       &                "Net downward energy flux at surface","W/m2",                &
+       &                iim,jjmp1,nhori, 1,1,1, -99, 32,                             &
+       &                "ave(X)", zstophy,zout)
+!c
+         CALL histdef(nid_day_seri, "ecin",                                          &
+       &                "Total kinetic energy (per unit area)","J/m2",               &
+       &                iim,jjmp1,nhori, 1,1,1, -99, 32,                             &
+       &                "ave(X)", zstophy,zout)
+!c
+!IM 151004 BEG
+         IF(1.EQ.0) THEN
+!c
+         CALL histdef(nid_day_seri, "momang",                                        &
+       &               "Total relative angular momentum (per unit area)",            &
+       &               "kg/s",                                                       &
+       &                iim,jjmp1,nhori, 1,1,1, -99, 32,                             &
+       &                "ave(X)", zstophy,zout)
+!c
+         CALL histdef(nid_day_seri, "frictor",                                       &
+       &               "Friction torque (per unit area)", "N/m",                     &
+       &                iim,jjmp1,nhori, 1,1,1, -99, 32,                             &
+       &                "ave(X)", zstophy,zout)
+!c
+         CALL histdef(nid_day_seri, "mountor",                                       &
+       &               "Mountain torque (per unit area)", "N/m",                     &
+       &                iim,jjmp1,nhori, 1,1,1, -99, 32,                             &
+       &                "ave(X)", zstophy,zout)
+!c
+         ENDIF !(1.EQ.0) THEN
+!c
+         CALL histdef(nid_day_seri, "momang",                                        &
+       &               "Axial angular momentum (per unit area)",                     &
+       &               "kg/s",                                                       &
+       &                iim,jjmp1,nhori, 1,1,1, -99, 32,                             &
+       &                "ave(X)", zstophy,zout)
+!c
+         CALL histdef(nid_day_seri, "torsfc",                                        &
+       &        "Total surface torque (including mountain torque)", "N/m",           &
+       &                iim,jjmp1,nhori, 1,1,1, -99, 32,                             &
+       &                "ave(X)", zstophy,zout)
+!c
+!IM 151004 END        
+!c
+         CALL histdef(nid_day_seri, "tamv",                                          &
+       &                "Temperature (mass-weighted vert. ave)", "K",                &
+       &                iim,jjmp1,nhori, 1,1,1, -99, 32,                             &
+       &                "ave(X)", zstophy,zout)
+!c
+         CALL histdef(nid_day_seri, "psol",                                          &
+       &                "Surface pressure", "Pa",                                    &
+       &                iim,jjmp1,nhori, 1,1,1, -99, 32,                             &
+       &                "ave(X)", zstophy,zout)
+!c
+         CALL histdef(nid_day_seri, "evap",                                          &
+       &                "Evaporation and sublimation (per unit area)",               &
+       &                "kg/(m2*s)",                                                 &
+       &                iim,jjmp1,nhori, 1,1,1, -99, 32,                             &
+       &                "ave(X)", zstophy,zout)
+!c
+!c          call histdef(nid_day_seri, 
+!c    .         "SnowFrac", 
+!c    .         "Snow-covered area ", "%",  
+!c    .         iim,jjmp1,nhori, 1,1,1, -99, 32,
+!c    .         "ave(X)", zstophy,zout)
+!c
+!c        CALL histdef(nid_day_seri, "snow_depth", 
+!IM 080904  .                "Snow Depth (water equivalent)", "m",
+!IM 191104  .                "Snow Depth (water equivalent)", "kg/m2",
+!c    .                "Snow Mass", "kg/m2",
+!c    .                iim,jjmp1,nhori, 1,1,1, -99, 32, 
+!c    .               "ave(X)", zstophy,zout)
+!c
+           call histdef(nid_day_seri,                                                &
+       &         "tsol_"//clnsurf(is_oce),                                           &
+       &         "SST over open (ice-free) ocean ", "K",                             &
+       &         iim,jjmp1,nhori, 1,1,1, -99, 32,                                    &
+       &         "ave(X)", zstophy,zout)
+!c
+!c=================================================================
+!c
+         CALL histend(nid_day_seri)
+!c
+!c=================================================================
+      ENDIF ! fin de test sur type_run.EQ.AMIP
+      
+      ENDIF ! is_sequential
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histhfNMC.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histhfNMC.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histhfNMC.h	(revision 17)
@@ -0,0 +1,152 @@
+!
+! $Header$
+!
+!$OMP MASTER
+!c
+      IF (ok_histNMC(3)) THEN
+!c
+       zstophy = dtime
+       zstohf = ecrit_hf
+       zstomth = ecrit_mth
+!c      zout = 6 * 3600.
+       zout = freq_outNMC(3)
+!c
+         idayref = day_ref
+         CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+!c
+!cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+!cym         DO i = 1, iim
+!cym            zx_lon(i,1) = rlon(i+1)
+!cym            zx_lon(i,jjmp1) = rlon(i+1)
+!cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=float(ll)
+         ENDDO
+!cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+!cym         CALL histbeg("histNMC.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+!cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+!cym     .                 nhori, nid_hfnmc)
+
+         CALL histbeg_phy("histhfNMC",itau_phy, zjulian, dtime,                      &
+       &                 nhori, nid_hfnmc)
+!c
+         CALL histvert(nid_hfnmc, "plev", "pressure", "Pa",                          &
+       &                 nlevSTD3, rlevSTD3, nvert,"down")
+!c
+!IM Astuce MAF: remplacer inst par ave pour les variables NMC pour avoir
+!IM             le time_counter et les bounds
+!c
+!ccc
+!ccc Champs 3D interpolles sur des niveaux de pression du NMC
+!ccc
+!c
+!c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh
+!c             sur les niveaux du NMC et on somme & moyenne
+!c             toutes les freq_moyNMC secondes par des routines undefSTD et
+!c             moy_undefSTD pour eliminer les valeurs "undef"
+!c             de la moyenne mensuelle
+!c ======> le "inst(X)" ci-dessous est par consequence factice !
+!c
+          CALL histdef(nid_hfnmc, "tnondef",                                         &
+       &                 "Valeurs non-definies","-",                                 &
+       &                iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "ta",                                              &
+       &                 "Air temperature","K",                                      &
+       &                iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+         CALL histdef(nid_hfnmc, "zg",                                               &
+       &                "Geopotential height", "m",                                  &
+       &                iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "hus",                                             &
+       &                 "Specific humidity","1",                                    &
+       &                iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+         CALL histdef(nid_hfnmc, "hur",                                              &
+       &                 "Relative humidity", "%",                                   &
+       &                iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "ua",                                              &
+       &                 "Eastward wind","m s-1",                                    &
+       &                iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "va",                                              &
+       &                 "Northward wind","m s-1",                                   &
+       &                iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "wap",                                             &
+       &                 "Lagrangian tendency of air pressure","Pa s-1",             &
+       &                iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32,             &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "psbg",                                            &
+       &         "Pressure sfce below ground","%",                                   &
+       &         iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32,                    &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "uv",                                              &
+       &         "uv ",                                                              &
+       &         "m2/s2",iim,jj_nb,nhori, nlevSTD3,1,nlevSTD3, nvert, 32,            &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "vq",                                              &
+       &         "vq ",                                                              &
+       &         "m/s * (kg/kg)",iim,jj_nb,nhori,                                    &
+       &          nlevSTD3,1,nlevSTD3, nvert, 32,                                    &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "vT",                                              &
+       &         "vT ",                                                              &
+       &         "mK/s",iim,jj_nb,nhori,                                             &
+       &          nlevSTD3,1,nlevSTD3, nvert, 32,                                    &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "wq",                                              &
+       &         "wq ",                                                              &
+       &         "(Pa/s)*(kg/kg)",iim,jj_nb,nhori,                                   &
+       &          nlevSTD3,1,nlevSTD3, nvert, 32,                                    &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "vphi",                                            &
+       &         "vphi ",                                                            &
+       &         "m2/s",iim,jj_nb,nhori,                                             &
+       &          nlevSTD3,1,nlevSTD3, nvert, 32,                                    &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "wT",                                              &
+       &         "wT ",                                                              &
+       &         "K*Pa/s",iim,jj_nb,nhori,                                           &
+       &          nlevSTD3,1,nlevSTD3, nvert, 32,                                    &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "uxu",                                             &
+       &         "u2 ",                                                              &
+       &         "m2/s2",iim,jj_nb,nhori,                                            &
+       &          nlevSTD3,1,nlevSTD3, nvert, 32,                                    &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "vxv",                                             &
+       &         "v2 ",                                                              &
+       &         "m2/s2",iim,jj_nb,nhori,                                            &
+       &          nlevSTD3,1,nlevSTD3, nvert, 32,                                    &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_hfnmc, "TxT",                                             &
+       &         "T2 ",                                                              &
+       &         "K2",iim,jj_nb,nhori,                                               &
+       &          nlevSTD3,1,nlevSTD3, nvert, 32,                                    &
+       &         "ave(X)", zout,zout)
+!c
+         CALL histend(nid_hfnmc)
+!c
+      ENDIF !(ok_histNMC(2)) THEN
+!c
+!$OMP END MASTER
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histmthNMC.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histmthNMC.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histmthNMC.h	(revision 17)
@@ -0,0 +1,162 @@
+!
+! $Id: ini_histmthNMC.h 1403 2010-07-01 09:02:53Z fairhead $
+!
+!$OMP MASTER
+!c
+      IF (ok_histNMC(1)) THEN
+!c
+       zout = freq_outNMC(1)
+!c
+       idayref = day_ref
+       CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+!c
+!cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon,zx_lon)
+!cym         DO i = 1, iim
+!cym            zx_lon(i,1) = rlon(i+1)
+!cym            zx_lon(i,jjmp1) = rlon(i+1)
+!cym         ENDDO
+         DO ll=1,klev
+            znivsig(ll)=REAL(ll)
+         ENDDO
+!cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat,zx_lat)
+!cym         CALL histbeg("histNMC.nc", iim,zx_lon(:,1), jjmp1,zx_lat(1,:),
+!cym     .                 1,iim,1,jjmp1, itau_phy, zjulian, dtime, 
+!cym     .                 nhori, nid_mthnmc)
+
+         CALL histbeg_phy("histmthNMC",itau_phy, zjulian, dtime,                     &
+       &                 nhori, nid_mthnmc)
+!c
+         CALL histvert(nid_mthnmc, "plev", "pressure", "Pa",                         &
+       &                 nlevSTD, rlevSTD, nvert,"down")
+!c
+!IM Astuce MAF: remplacer inst par ave pour les variables NMC pour avoir
+!IM             le time_counter et les bounds
+!IM 
+!ccc Champs 3D interpolles sur des niveaux de pression du NMC
+!ccc
+!c
+!c ATTENTION : pour AMIP2 on interpole t,u,v,wphi,q,rh
+!c             sur les niveaux du NMC et on somme & moyenne
+!c             toutes les freq_moyNMC secondes par des routines undefSTD et
+!c             moy_undefSTD pour eliminer les valeurs "undef"
+!c             de la moyenne mensuelle
+!c ======> le "inst(X)" ci-dessous est par consequence factice !
+!c
+!c
+          CALL histdef(nid_mthnmc, "tnondef",                                        &
+       &                 "Valeurs non-definies","-",                                 &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "ta",                                             &
+       &                 "Air temperature","K",                                      &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+         CALL histdef(nid_mthnmc, "zg",                                              &
+       &                "Geopotential height", "m",                                  &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "hus",                                            &
+       &                 "Specific humidity","1",                                    &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+         CALL histdef(nid_mthnmc, "hur",                                             &
+       &                 "Relative humidity", "%",                                   &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "ua",                                             &
+       &                 "Eastward wind","m s-1",                                    &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "va",                                             &
+       &                 "Northward wind","m s-1",                                   &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "wap",                                            &
+       &                 "Lagrangian tendency of air pressure","Pa s-1",             &
+       &                iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,               &
+       &                "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "psbg",                                           &
+       &         "Pressure sfce below ground","%",                                   &
+       &         iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,                      &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "uv",                                             &
+       &         "uv ",                                                              &
+       &         "m2/s2",iim,jj_nb,nhori, nlevSTD,1,nlevSTD, nvert, 32,              &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "vq",                                             &
+       &         "vq ",                                                              &
+       &         "m/s * (kg/kg)",iim,jj_nb,nhori,                                    &
+       &          nlevSTD,1,nlevSTD, nvert, 32,                                      &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "vT",                                             &
+       &         "vT ",                                                              &
+       &         "mK/s",iim,jj_nb,nhori,                                             &
+       &          nlevSTD,1,nlevSTD, nvert, 32,                                      &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "wq",                                             &
+       &         "wq ",                                                              &
+       &         "(Pa/s)*(kg/kg)",iim,jj_nb,nhori,                                   &
+       &          nlevSTD,1,nlevSTD, nvert, 32,                                      &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "vphi",                                           &
+       &         "vphi ",                                                            &
+       &         "m2/s",iim,jj_nb,nhori,                                             &
+       &          nlevSTD,1,nlevSTD, nvert, 32,                                      &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "wT",                                             &
+       &         "wT ",                                                              &
+       &         "K*Pa/s",iim,jj_nb,nhori,                                           &
+       &          nlevSTD,1,nlevSTD, nvert, 32,                                      &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "uxu",                                            &
+       &         "u2 ",                                                              &
+       &         "m2/s2",iim,jj_nb,nhori,                                            &
+       &          nlevSTD,1,nlevSTD, nvert, 32,                                      &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "vxv",                                            &
+       &         "v2 ",                                                              &
+       &         "m2/s2",iim,jj_nb,nhori,                                            &
+       &          nlevSTD,1,nlevSTD, nvert, 32,                                      &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "TxT",                                            &
+       &         "T2 ",                                                              &
+       &         "K2",iim,jj_nb,nhori,                                               &
+       &          nlevSTD,1,nlevSTD, nvert, 32,                                      &
+       &         "ave(X)", zout,zout)
+!c
+          CALL histdef(nid_mthnmc, "tro3",                                           &
+       &         "Ozone mole fraction",                                              &
+       &         "1e-9",iim,jj_nb,nhori,                                             &
+       &          nlevSTD,1,nlevSTD, nvert, 32,                                      &
+       &         "ave(X)", zout,zout)
+!c
+          if (read_climoz == 2) THEN
+           CALL histdef(nid_mthnmc, "tro3_daylight",                                 &
+       &         "Daylight ozone mole fraction",                                     &
+       &         "1e-9",iim,jj_nb,nhori,                                             &
+       &          nlevSTD,1,nlevSTD, nvert, 32,                                      &
+       &         "ave(X)", zout,zout)
+          endif
+!c
+         CALL histend(nid_mthnmc)
+!c
+      ENDIF !(ok_histNMC(1)) THEN
+!c
+!$OMP END MASTER
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histrac.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histrac.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_histrac.h	(revision 17)
@@ -0,0 +1,244 @@
+!
+! $Id $
+!
+  IF (ecrit_tra>0.) THEN
+!$OMP MASTER 
+!!!     CALL ymds2ju(annee_ref, 1, day_ref, 0.0, zjulian)
+! correction pour l heure initiale                               !jyg 
+!                                                               !jyg 
+      CALL ymds2ju(annee_ref, 1, day_ref, hour, zjulian)         !jyg
+
+     CALL histbeg_phy("histrac", itau_phy, zjulian, pdtphys,nhori, nid_tra)
+     CALL histvert(nid_tra, "presnivs", "Vertical levels", "Pa",klev, presnivs, nvert,"down")
+
+     zsto = pdtphys
+     zout = ecrit_tra
+     CALL histdef(nid_tra, "phis", "Surface geop. height", "-",   &
+          iim,jj_nb,nhori, 1,1,1, -99, 32,"once",  zsto,zout)
+     CALL histdef(nid_tra, "aire", "Grid area", "-",              &
+          iim,jj_nb,nhori, 1,1,1, -99, 32,"once",  zsto,zout)
+     CALL histdef(nid_tra, "zmasse", "column density of air in cell", &
+          "kg m-2", iim, jj_nb, nhori, klev, 1, klev, nvert, 32, "ave(X)", &
+          zsto,zout)
+! RomP >>>
+     CALL histdef(nid_tra, "sourceBE", "source 7Be", &
+          "at/kgA/s", iim, jj_nb, nhori, klev, 1, klev, nvert, 32, "ave(X)", &
+          zsto,zout)
+! RomP <<<
+
+!TRACEURS
+!----------------
+     DO it = 1,nbtr
+        iiq = niadv(it+2)
+
+! CONCENTRATIONS
+        CALL histdef(nid_tra, tname(iiq), ttext(iiq), "U/kga",    &
+             iim,jj_nb,nhori, klev,1,klev,nvert, 32,"ave(X)", zsto,zout)
+
+! TD LESSIVAGE
+        IF (lessivage .AND. aerosol(it)) THEN
+           CALL histdef(nid_tra, "fl"//tname(iiq),"Flux "//ttext(iiq), &
+                "at/m2/s",iim,jj_nb,nhori, klev,1,klev,nvert, 32,       &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "d_tr_ls_"//tname(iiq),      &
+                "tendance lessivage large scale"// ttext(iiq), "?",&
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,       &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "d_tr_insc_"//tname(iiq),      &
+                "tendance lessivage large scale"// ttext(iiq), "?",&
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,       &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "d_tr_bcscav_"//tname(iiq),      &
+                "tendance lessivage large scale"// ttext(iiq), "?",&
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,       &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "d_tr_evls_"//tname(iiq),      &
+                "tendance lessivage large scale"// ttext(iiq), "?",&
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,       &
+                "ave(X)", zsto,zout)
+!  Tracer concentration in LS precipitation at surface
+           CALL histdef(nid_tra, "qpr_ls_"//tname(iiq),       &
+                "concentration in LS precip"// ttext(iiq), "at/kgw", &
+                iim,jj_nb,nhori, 1,1,1, -99, 32,                 &
+                "ave(X)", zsto,zout)     
+                 END IF
+
+! TD THERMIQUES
+        IF (iflag_thermals.gt.0) THEN
+           CALL histdef(nid_tra, "d_tr_th_"//tname(iiq),      &
+                "tendance thermique"// ttext(iiq), "?",       &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,       &
+                "ave(X)", zsto,zout)
+        ENDIF
+
+! TD CONVECTION
+        IF (iflag_con.GE.2) THEN
+           CALL histdef(nid_tra, "d_tr_cv_"//tname(iiq),   &
+                "tendance convection"// ttext(iiq), "?",   &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+        ENDIF
+
+! RomP >>>
+        IF (iflag_con.EQ.30) THEN
+           CALL histdef(nid_tra, "d_tr_cvMA_"//tname(iiq),   &
+                "tendance convection"// ttext(iiq), "?",&
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "d_tr_trsp_"//tname(iiq),   &
+                "tendance transport "// ttext(iiq), "at/kga",   &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "d_tr_sscav_"//tname(iiq),   &
+                "tendance lessivage flux satures "// ttext(iiq), "at/kga",   &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "d_tr_sat_"//tname(iiq),   &
+                "tendance flux satures "// ttext(iiq), "at/kga",  &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "d_tr_uscav_"//tname(iiq),  &
+                "tendance flux insatures "// ttext(iiq), "at/kga", &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "tr_pr_"//tname(iiq),  &
+                "concentration dans precip"// ttext(iiq), "at/kga", &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "tr_aa_"//tname(iiq),  &
+                "concentration precip issu AA"// ttext(iiq), "at/kga", &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "tr_mel_"//tname(iiq),  &
+                "concentration precip issu melange"// ttext(iiq), "at/kga", &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "tr_di_"//tname(iiq),  &
+                "concentration dans descente insaturee"// ttext(iiq), "at/kga", &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "tr_trspdi_"//tname(iiq),  &
+                "conc descente insaturee MA"// ttext(iiq), "at/kga", &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "zmfd1a_"//tname(iiq),  &
+                "zmfd1a"// ttext(iiq), "_", &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "zmfphi2_"//tname(iiq),  &
+                "zmfphi2"// ttext(iiq), "_", &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+           CALL histdef(nid_tra, "zmfdam_"//tname(iiq),  &
+                "zmfdam"// ttext(iiq), "_", &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,    &
+                "ave(X)", zsto,zout)
+          ENDIF
+! RomP <<<
+           CALL histdef(nid_tra, "dtrdyn_"//tname(iiq),  &
+                "td dyn tra"// ttext(iiq), "at/kga", &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,  &
+                "ave(X)", zsto,zout)
+! TD decroissance radioactive
+           CALL histdef(nid_tra, "d_tr_dec_"//tname(iiq),   &
+                "tendance decroi radio "// ttext(iiq), "",  &
+                iim,jj_nb,nhori, klev,1,klev,nvert, 32,  &
+                "ave(X)", zsto,zout)
+
+! TD COUCHE-LIMITE
+      IF (couchelimite) THEN
+        CALL histdef(nid_tra, "d_tr_cl_"//tname(iiq),      &
+             "tendance couche limite"// ttext(iiq), "?",   &
+             iim,jj_nb,nhori, klev,1,klev,nvert, 32,       &
+             "ave(X)", zsto,zout)
+!  Dry deposit (1st layer and surface)
+        CALL histdef(nid_tra, "d_tr_dry_"//tname(iiq),       &
+             "tendancy dry deposit"// ttext(iiq), "at/kga/step", &
+             iim,jj_nb,nhori, 1,1,1, -99, 32,                 &
+             "ave(X)", zsto,zout)     
+        CALL histdef(nid_tra, "flux_tr_dry_"//tname(iiq),       &
+             "dry deposit at surf (downward)"// ttext(iiq), "at/m2/step", &
+             iim,jj_nb,nhori, 1,1,1, -99, 32,                 &
+             "ave(X)", zsto,zout)     
+      ENDIF
+     ENDDO
+
+     CALL histdef(nid_tra, "Mint", "Mint","",         &
+          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
+          "inst(X)", zout,zout)
+     CALL histdef(nid_tra, "frac_impa", "frac_impa","",         &
+          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
+          "inst(X)", zout,zout)
+     CALL histdef(nid_tra, "frac_nucl", "frac_nucl","",         &
+          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
+          "inst(X)", zout,zout)
+!---------------   
+!
+! VENT (niveau 1)
+     CALL histdef(nid_tra, "pyu1", "Vent niv 1", "-",      &
+          iim,jj_nb,nhori, 1,1,1, -99, 32,                 &
+          "inst(X)",  zout,zout)     
+     CALL histdef(nid_tra, "pyv1", "Vent niv 1", "-",      &
+          iim,jj_nb,nhori, 1,1,1, -99, 32,                 &
+          "inst(X)",  zout,zout)
+
+! TEMPERATURE DU SOL
+     CALL histdef(nid_tra, "ftsol1", "temper sol", "-",    &
+          iim,jj_nb,nhori, 1,1,1, -99, 32,                 &
+          "inst(X)",  zout,zout)
+     CALL histdef(nid_tra, "ftsol2", "temper sol", "-",    &
+          iim,jj_nb,nhori, 1,1,1, -99, 32,                 &
+          "inst(X)",  zout,zout)
+     CALL histdef(nid_tra, "ftsol3", "temper sol", "-",    &
+          iim,jj_nb,nhori, 1,1,1, -99, 32,                 &
+          "inst",  zout,zout)
+     CALL histdef(nid_tra, "ftsol4", "temper sol", "-",    &
+          iim,jj_nb,nhori, 1,1,1, -99, 32,                 &
+          "inst(X)",  zout,zout)
+
+! NATURE DU SOL
+     CALL histdef(nid_tra, "psrf1", "nature sol", "-",     &
+          iim,jj_nb,nhori, 1,1,1, -99, 32,                 &
+          "inst(X)",  zout,zout)
+     CALL histdef(nid_tra, "psrf2", "nature sol", "-",     &
+          iim,jj_nb,nhori, 1,1,1, -99, 32,                 &
+          "inst(X)",  zout,zout)
+     CALL histdef(nid_tra, "psrf3", "nature sol", "-",     &
+          iim,jj_nb,nhori, 1,1,1, -99, 32,                 &
+          "inst(X)",  zout,zout)
+     CALL histdef(nid_tra, "psrf4", "nature sol", "-",     &
+          iim,jj_nb,nhori, 1,1,1, -99, 32,                 & 
+          "inst(X)",  zout,zout)
+! DIVERS
+     CALL histdef(nid_tra, "pplay", "pressure","-",        &
+          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
+          "inst(X)", zout,zout)
+     CALL histdef(nid_tra, "T", "temperature","K",         &
+          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
+          "inst(X)", zout,zout)
+     CALL histdef(nid_tra, "mfu", "flux u mont","-",       &
+          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
+          "ave(X)", zsto,zout)
+     CALL histdef(nid_tra, "mfd", "flux u decen","-",      &
+          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
+          "ave(X)", zsto,zout)
+     CALL histdef(nid_tra, "en_u", "flux u mont","-",      &
+          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
+          "ave(X)", zsto,zout)
+     CALL histdef(nid_tra, "en_d", "flux u mont","-",      &
+          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
+          "ave(X)", zsto,zout)
+     CALL histdef(nid_tra, "de_d", "flux u mont","-",      &
+          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
+          "ave(X)", zsto,zout)
+     CALL histdef(nid_tra, "de_u", "flux u decen","-",     &
+          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
+          "ave(X)", zsto,zout)
+     CALL histdef(nid_tra, "coefh", "turbulent coef","-",  &
+          iim,jj_nb,nhori, klev,1,klev,nvert, 32,          &
+          "ave(X)", zsto,zout)   
+     
+     CALL histend(nid_tra)
+!$OMP END MASTER
+  END IF ! ecrit_tra>0.
+  
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_paramLMDZ_phy.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_paramLMDZ_phy.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_paramLMDZ_phy.h	(revision 17)
@@ -0,0 +1,133 @@
+!IM    Implemente en modes sequentiel et parallele
+
+       CALL gather(rlat,rlat_glo)
+       CALL bcast(rlat_glo)
+       CALL gather(rlon,rlon_glo)
+       CALL bcast(rlon_glo)
+
+!$OMP MASTER
+      if (is_mpi_root) then
+!c
+       zstophy = dtime
+       zout = mth_len*un_jour
+!c
+       idayref = day_ref
+       CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+!c
+       CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon_glo,zx_lon)
+       if (iim.gt.1) then
+       DO i = 1, iim
+         zx_lon(i,1) = rlon_glo(i+1)
+         zx_lon(i,jjmp1) = rlon_glo(i+1)
+       ENDDO
+       endif
+       CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat_glo,zx_lat)
+!c
+       CALL histbeg("paramLMDZ_phy.nc",                                              &
+       &                 np,zx_lon(np:np,1), np,zx_lat(1,np:np),                     &
+       &                 1,1,1,1,                                                    &
+       &                 itau_phy, zjulian, dtime,                                   &
+       &                 nhori, nid_ctesGCM)
+!c
+       CALL histdef(nid_ctesGCM, "R_ecc",                                            &
+       &                "Excentricite","-",                                          &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "R_peri",                                           &
+       &                "Equinoxe","-",                                              &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "R_incl",                                           &
+       &                "Inclinaison","deg",                                         &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "solaire",                                          &
+       &                "Constante solaire","W/m2",                                  &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "co2_ppm",                                          &
+       &                "Concentration du CO2", "ppm",                               &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave(X)", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "CH4_ppb",                                          &
+       &                "Concentration du CH4", "ppb",                               &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave(X)", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "N2O_ppb",                                          &
+       &                "Concentration du N2O", "ppb",                               &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave(X)", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "CFC11_ppt",                                        &
+       &                "Concentration du CFC11", "ppt",                             &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave(X)", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "CFC12_ppt",                                        &
+       &                "Concentration du CFC12", "ppt",                             &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave(X)", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "bils",                                             &
+       &                "Surface total heat flux", "W m-2",                          &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "evap",                                             &
+       &                "Evaporation", "kg m-2 s-1",                                 &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "evap_land",                                        &
+       &                "Land evaporation", "kg m-2 s-1",                            &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "flat",                                             &
+       &                "Latent heat flux", "W m-2",                                 &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "nettop0",                                          &
+       &                "Clear sky net downward radiatif flux at TOA",               &
+       &                "W m-2",                                                     &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "nettop",                                           &
+       &                "Net downward radiatif flux at TOA", "W m-2",                &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "precip",                                           &
+       &                "Total precipitation (liq+sol)", "kg m-2 s-1",               &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "tsol",                                             &
+       &                "Surface temperature", "K",                                  &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "t2m",                                              &
+       &                "Temperature at 2m", "K",                                    &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout)
+!c
+       CALL histdef(nid_ctesGCM, "prw",                                              &
+       &                "Precipitable water", "kg m-2",                              &
+       &                1,1,nhori, 1,1,1, -99, 32,                                   &
+       &                "ave", zstophy,zout) 
+!c=================================================================
+!c
+       CALL histend(nid_ctesGCM)
+       
+       endif !(is_mpi_root)
+!$OMP END MASTER
+!c=================================================================
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_undefSTD.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_undefSTD.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_undefSTD.F	(revision 17)
@@ -0,0 +1,86 @@
+!
+! $Id: ini_undefSTD.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+
+      SUBROUTINE ini_undefSTD(itap,
+     $           freq_outNMC)
+      USE dimphy
+      USE phys_state_var_mod ! Variables sauvegardees de la physique
+      IMPLICIT none
+c
+c====================================================================
+c
+c I. Musat : 09.2004
+c
+c Initialisation - a des frequences differentes : 
+c
+c 1) des variables moyennees sur la journee "day" ou sur le mois "mth"
+c    calculees a partir des valeurs "instantannees" de la physique
+c
+c 2) des variables moyennes mensuelles "NMC" calculees a partir des val.
+c    toutes les 6 heures
+c
+c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
+c              ! de la physique
+c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
+c              ! de la physique
+c nout=3 !var. mensuelle "NMC" moyennee toutes les 6heures
+c
+c NB: mettre "inst(X)" dans le write_hist*NMC.h !
+c====================================================================
+c
+cym #include "dimensions.h"
+cym      integer jjmp1
+cym      parameter (jjmp1=jjm+1-1/jjm)
+cym #include "dimphy.h"
+c variables Input/Output
+c     INTEGER nlevSTD, klevSTD, itap
+      INTEGER itap
+c     PARAMETER(klevSTD=17)
+c     REAL dtime
+c
+c variables locales
+c     INTEGER i, k, nout, n
+      INTEGER i, k, n
+c     PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
+      REAL freq_outNMC(nout)
+c
+c variables Output
+c     REAL tnondef(klon,klevSTD,nout)
+c     REAL tsumSTD(klon,klevSTD,nout)
+c
+      DO n=1, nout
+c
+c initialisation variables en debut de la journee ou du mois
+c
+       IF(MOD(itap,NINT(freq_outNMC(n)/dtime)).EQ.1.) THEN
+        DO k=1, nlevSTD
+         DO i=1, klon
+          tnondef(i,k,n)=0.
+          tsumSTD(i,k,n)=0.
+          usumSTD(i,k,n)=0.
+          vsumSTD(i,k,n)=0.
+          wsumSTD(i,k,n)=0.
+          phisumSTD(i,k,n)=0.
+          qsumSTD(i,k,n)=0.
+          rhsumSTD(i,k,n)=0.
+          uvsumSTD(i,k,n)=0.
+          vqsumSTD(i,k,n)=0.
+          vTsumSTD(i,k,n)=0.
+          wqsumSTD(i,k,n)=0.
+          vphisumSTD(i,k,n)=0.
+          wTsumSTD(i,k,n)=0.
+          u2sumSTD(i,k,n)=0.
+          v2sumSTD(i,k,n)=0.
+          T2sumSTD(i,k,n)=0.
+          O3sumSTD(i,k,n)=0.
+          O3daysumSTD(i,k,n)=0.
+         ENDDO !i
+        ENDDO !k
+c
+       ENDIF !MOD(itap,NINT(freq_outNMC(n)/dtime)).EQ.1.
+c
+      ENDDO !n
+c
+      RETURN
+      END  
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_undefSTD.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_undefSTD.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_undefSTD.F90	(revision 17)
@@ -0,0 +1,86 @@
+!
+! $Id: ini_undefSTD.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+
+      SUBROUTINE ini_undefSTD(itap,                                                  &
+       &           freq_outNMC)
+      USE dimphy
+      USE phys_state_var_mod ! Variables sauvegardees de la physique
+      IMPLICIT none
+!c
+!c====================================================================
+!c
+!c I. Musat : 09.2004
+!c
+!c Initialisation - a des frequences differentes : 
+!c
+!c 1) des variables moyennees sur la journee "day" ou sur le mois "mth"
+!c    calculees a partir des valeurs "instantannees" de la physique
+!c
+!c 2) des variables moyennes mensuelles "NMC" calculees a partir des val.
+!c    toutes les 6 heures
+!c
+!c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
+!c              ! de la physique
+!c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
+!c              ! de la physique
+!c nout=3 !var. mensuelle "NMC" moyennee toutes les 6heures
+!c
+!c NB: mettre "inst(X)" dans le write_hist*NMC.h !
+!c====================================================================
+!c
+!cym #include "dimensions.h"
+!cym      integer jjmp1
+!cym      parameter (jjmp1=jjm+1-1/jjm)
+!cym #include "dimphy.h"
+!c variables Input/Output
+!c     INTEGER nlevSTD, klevSTD, itap
+      INTEGER itap
+!c     PARAMETER(klevSTD=17)
+!c     REAL dtime
+!c
+!c variables locales
+!c     INTEGER i, k, nout, n
+      INTEGER i, k, n
+!c     PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
+      REAL freq_outNMC(nout)
+!c
+!c variables Output
+!c     REAL tnondef(klon,klevSTD,nout)
+!c     REAL tsumSTD(klon,klevSTD,nout)
+!c
+      DO n=1, nout
+!c
+!c initialisation variables en debut de la journee ou du mois
+!c
+       IF(MOD(itap,NINT(freq_outNMC(n)/dtime)).EQ.1.) THEN
+        DO k=1, nlevSTD
+         DO i=1, klon
+          tnondef(i,k,n)=0.
+          tsumSTD(i,k,n)=0.
+          usumSTD(i,k,n)=0.
+          vsumSTD(i,k,n)=0.
+          wsumSTD(i,k,n)=0.
+          phisumSTD(i,k,n)=0.
+          qsumSTD(i,k,n)=0.
+          rhsumSTD(i,k,n)=0.
+          uvsumSTD(i,k,n)=0.
+          vqsumSTD(i,k,n)=0.
+          vTsumSTD(i,k,n)=0.
+          wqsumSTD(i,k,n)=0.
+          vphisumSTD(i,k,n)=0.
+          wTsumSTD(i,k,n)=0.
+          u2sumSTD(i,k,n)=0.
+          v2sumSTD(i,k,n)=0.
+          T2sumSTD(i,k,n)=0.
+          O3sumSTD(i,k,n)=0.
+          O3daysumSTD(i,k,n)=0.
+         ENDDO !i
+        ENDDO !k
+!c
+       ENDIF !MOD(itap,NINT(freq_outNMC(n)/dtime)).EQ.1.
+!c
+      ENDDO !n
+!c
+      RETURN
+      END SUBROUTINE ini_undefSTD
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_wake.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_wake.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_wake.F	(revision 17)
@@ -0,0 +1,84 @@
+!
+! $Id: ini_wake.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE INI_WAKE(wape,fip,it_wape_prescr,
+     :     wape_prescr, fip_prescr, alp_bl_prescr, ale_bl_prescr)
+***************************************************************
+*                                                             *
+*        INI_WAKE : variables d'initialisation de la poche    *
+*                   froide, necessaires au declenchement      *
+*                   de la convection.                         *
+*                                                             *
+*                                                             *
+***************************************************************
+c Arguments
+c =========
+c Input
+c -----
+c   wape           : valeur de l'energie potentielle de la poche (WAPE)
+c                    dans l'etat initial
+c   fip            : valeur de la puissance incidente sur le front (FIP)
+c                    dans l'etat initial
+c Output
+c ------
+c   it_wape_prescr : nombre de pas de temps pendant lesquels la WAPE
+c            doit etre imposee.
+c   wape_prescr    : valeur prescrite de la WAPE.
+c   fip_prescr     : valeur prescrite de la FIP.
+c   ale_bl_prescr  : valeur prescrite de la Ale de PBL.
+c   alp_bl_prescr  : valeur prescrite de la Alp de PBL.
+c
+c Variables internes
+c ==================
+c   it = nbre de pas de temps lu
+c   w  = WAPE lue
+c   f  = FIP lue
+c   alebl  = Ale de PBL lue
+c   alpbl  = Alp de PBL lue
+c
+      include 'iniprint.h'
+cdeclarations
+      real ale_bl_prescr
+      real alp_bl_prescr
+      real it
+
+! FH A mettre si besoin dans physiq.def
+! FH : voir avec JYG
+      it=0.
+      w=4.
+      f=0.1
+      alebl=4.
+      alpbl=0.1
+c
+cCR: on rajoute ale et alp de la PBL precrits
+      open (99,file='ini_wake_param.data',form='formatted',
+     s      status='old',err=902)
+      read (99,*) it
+      read (99,*) w
+      read (99,*) f
+      read (99,*,end=901) alebl
+      read (99,*,end=901) alpbl
+901   close (99)
+902   continue
+c
+      write(lunout,*)' it,wape ',it,wape
+      it_wape_prescr = it
+      if (w .lt. 0) then
+         wape_prescr = wape
+         fip_prescr = fip
+      else
+         wape_prescr = w
+         fip_prescr = f
+      endif
+c
+      write(lunout,*)' alebl, alpbl ',alebl,alpbl
+      ale_bl_prescr=alebl
+      alp_bl_prescr=alpbl
+      print *,'Initialisation de la poche : WAPE, FIP imposees ='
+     $               ,wape_prescr, fip_prescr
+      print *, '                   pendant ',it_wape_prescr,' steps'
+c
+      print *,'Initialisation de la BL: ALP, ALE imposees ='
+     $               ,alp_bl_prescr, ale_bl_prescr
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_wake.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_wake.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ini_wake.F90	(revision 17)
@@ -0,0 +1,84 @@
+!
+! $Id: ini_wake.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE INI_WAKE(wape,fip,it_wape_prescr,                                   &
+       &     wape_prescr, fip_prescr, alp_bl_prescr, ale_bl_prescr)
+!***************************************************************
+!*                                                             *
+!*        INI_WAKE : variables d'initialisation de la poche    *
+!*                   froide, necessaires au declenchement      *
+!*                   de la convection.                         *
+!*                                                             *
+!*                                                             *
+!***************************************************************
+!c Arguments
+!c =========
+!c Input
+!c -----
+!c   wape           : valeur de l'energie potentielle de la poche (WAPE)
+!c                    dans l'etat initial
+!c   fip            : valeur de la puissance incidente sur le front (FIP)
+!c                    dans l'etat initial
+!c Output
+!c ------
+!c   it_wape_prescr : nombre de pas de temps pendant lesquels la WAPE
+!c            doit etre imposee.
+!c   wape_prescr    : valeur prescrite de la WAPE.
+!c   fip_prescr     : valeur prescrite de la FIP.
+!c   ale_bl_prescr  : valeur prescrite de la Ale de PBL.
+!c   alp_bl_prescr  : valeur prescrite de la Alp de PBL.
+!c
+!c Variables internes
+!c ==================
+!c   it = nbre de pas de temps lu
+!c   w  = WAPE lue
+!c   f  = FIP lue
+!c   alebl  = Ale de PBL lue
+!c   alpbl  = Alp de PBL lue
+!c
+      include 'iniprint.h'
+!cdeclarations
+      real ale_bl_prescr
+      real alp_bl_prescr
+      real it
+
+! FH A mettre si besoin dans physiq.def
+! FH : voir avec JYG
+      it=0.
+      w=4.
+      f=0.1
+      alebl=4.
+      alpbl=0.1
+!c
+!cCR: on rajoute ale et alp de la PBL precrits
+      open (99,file='ini_wake_param.data',form='formatted',                          &
+       &      status='old',err=902)
+      read (99,*) it
+      read (99,*) w
+      read (99,*) f
+      read (99,*,end=901) alebl
+      read (99,*,end=901) alpbl
+901   close (99)
+902   continue
+!c
+      write(lunout,*)' it,wape ',it,wape
+      it_wape_prescr = it
+      if (w .lt. 0) then
+         wape_prescr = wape
+         fip_prescr = fip
+      else
+         wape_prescr = w
+         fip_prescr = f
+      endif
+!c
+      write(lunout,*)' alebl, alpbl ',alebl,alpbl
+      ale_bl_prescr=alebl
+      alp_bl_prescr=alpbl
+      print *,'Initialisation de la poche : WAPE, FIP imposees ='                    &
+       &               ,wape_prescr, fip_prescr
+      print *, '                   pendant ',it_wape_prescr,' steps'
+!c
+      print *,'Initialisation de la BL: ALP, ALE imposees ='                         &
+       &               ,alp_bl_prescr, ale_bl_prescr
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/iniorbit.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/iniorbit.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/iniorbit.F	(revision 17)
@@ -0,0 +1,104 @@
+      SUBROUTINE iniorbit
+     $     (paphelie,pperiheli,pyear_day,pperi_day,pobliq)
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Auteur:
+c   -------
+c     Frederic Hourdin      22 Fevrier 1991
+c
+c   Objet:
+c   ------
+c    Initialisation du sous programme orbite qui calcule
+c    a une date donnee de l'annee de duree year_day commencant
+c    a l'equinoxe de printemps et dont le perihelie se situe
+c    a la date peri_day, la distance au soleil et la declinaison.
+c
+c   Interface:
+c   ----------
+c   - Doit etre appele avant d'utiliser orbite.
+c   - initialise une partie du common planete.h
+c
+c   Arguments:
+c   ----------
+c
+c   Input:
+c   ------
+c   aphelie       \   aphelie et perihelie de l'orbite
+c   periheli      /   en millions de kilometres.
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "planete.h"
+#include "YOMCST.h"
+
+c   Arguments:
+c   ----------
+
+      REAL paphelie,pperiheli,pyear_day,pperi_day,pobliq
+
+c   Local:
+c   ------
+
+      REAL zxref,zanom,zz,zx0,zdx, pi
+      INTEGER iter
+
+c-----------------------------------------------------------------------
+
+      pi=2.*asin(1.)
+
+      aphelie =paphelie
+      periheli=pperiheli
+      year_day=pyear_day
+      obliquit=pobliq
+      peri_day=pperi_day
+
+      PRINT*,'Perihelie en Mkm  ',periheli
+      PRINT*,'Aphelie  en Mkm   ',aphelie 
+      PRINT*,'obliquite en degres  :',obliquit
+      PRINT*,'Jours dans l annee : ',year_day
+      PRINT*,'Date perihelie : ',peri_day
+      unitastr=149.597870
+      e_elips=(aphelie-periheli)/(periheli+aphelie)
+      p_elips=0.5*(periheli+aphelie)*(1-e_elips*e_elips)/unitastr
+
+      print*,'e_elips',e_elips
+      print*,'p_elips',p_elips
+
+c-----------------------------------------------------------------------
+c calcul de l'angle polaire et de la distance au soleil :
+c -------------------------------------------------------
+
+c  calcul de l'zanomalie moyenne
+
+      zz=(year_day-pperi_day)/year_day
+      zanom=2.*pi*(zz-nint(zz))
+      zxref=abs(zanom)
+      PRINT*,'zanom  ',zanom
+
+c  resolution de l'equation horaire  zx0 - e * sin (zx0) = zxref
+c  methode de Newton
+
+      zx0=zxref+R_ecc*sin(zxref)
+      DO 110 iter=1,100
+         zdx=-(zx0-R_ecc*sin(zx0)-zxref)/(1.-R_ecc*cos(zx0))
+         if(abs(zdx).le.(1.e-12)) goto 120
+         zx0=zx0+zdx
+110   continue
+120   continue
+      zx0=zx0+zdx
+      if(zanom.lt.0.) zx0=-zx0
+      PRINT*,'zx0   ',zx0
+
+c zteta est la longitude solaire
+
+      timeperi=2.*atan(sqrt((1.+R_ecc)/(1.-R_ecc))*tan(zx0/2.))
+      PRINT*,'longitude solaire du perihelie timeperi = ',timeperi
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/iniorbit.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/iniorbit.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/iniorbit.F90	(revision 17)
@@ -0,0 +1,104 @@
+      SUBROUTINE iniorbit                                                            &
+       &     (paphelie,pperiheli,pyear_day,pperi_day,pobliq)
+      IMPLICIT NONE
+
+!c=======================================================================
+!c
+!c   Auteur:
+!c   -------
+!c     Frederic Hourdin      22 Fevrier 1991
+!c
+!c   Objet:
+!c   ------
+!c    Initialisation du sous programme orbite qui calcule
+!c    a une date donnee de l'annee de duree year_day commencant
+!c    a l'equinoxe de printemps et dont le perihelie se situe
+!c    a la date peri_day, la distance au soleil et la declinaison.
+!c
+!c   Interface:
+!c   ----------
+!c   - Doit etre appele avant d'utiliser orbite.
+!c   - initialise une partie du common planete.h
+!c
+!c   Arguments:
+!c   ----------
+!c
+!c   Input:
+!c   ------
+!c   aphelie       \   aphelie et perihelie de l'orbite
+!c   periheli      /   en millions de kilometres.
+!c
+!c=======================================================================
+
+!c-----------------------------------------------------------------------
+!c   Declarations:
+!c   -------------
+
+#include "planete.h"
+#include "YOMCST.h"
+
+!c   Arguments:
+!c   ----------
+
+      REAL paphelie,pperiheli,pyear_day,pperi_day,pobliq
+
+!c   Local:
+!c   ------
+
+      REAL zxref,zanom,zz,zx0,zdx, pi
+      INTEGER iter
+
+!c-----------------------------------------------------------------------
+
+      pi=2.*asin(1.)
+
+      aphelie =paphelie
+      periheli=pperiheli
+      year_day=pyear_day
+      obliquit=pobliq
+      peri_day=pperi_day
+
+      PRINT*,'Perihelie en Mkm  ',periheli
+      PRINT*,'Aphelie  en Mkm   ',aphelie 
+      PRINT*,'obliquite en degres  :',obliquit
+      PRINT*,'Jours dans l annee : ',year_day
+      PRINT*,'Date perihelie : ',peri_day
+      unitastr=149.597870
+      e_elips=(aphelie-periheli)/(periheli+aphelie)
+      p_elips=0.5*(periheli+aphelie)*(1-e_elips*e_elips)/unitastr
+
+      print*,'e_elips',e_elips
+      print*,'p_elips',p_elips
+
+!c-----------------------------------------------------------------------
+!c calcul de l'angle polaire et de la distance au soleil :
+!c -------------------------------------------------------
+
+!c  calcul de l'zanomalie moyenne
+
+      zz=(year_day-pperi_day)/year_day
+      zanom=2.*pi*(zz-nint(zz))
+      zxref=abs(zanom)
+      PRINT*,'zanom  ',zanom
+
+!c  resolution de l'equation horaire  zx0 - e * sin (zx0) = zxref
+!c  methode de Newton
+
+      zx0=zxref+R_ecc*sin(zxref)
+      DO 110 iter=1,100
+         zdx=-(zx0-R_ecc*sin(zx0)-zxref)/(1.-R_ecc*cos(zx0))
+         if(abs(zdx).le.(1.e-12)) goto 120
+         zx0=zx0+zdx
+110   continue
+120   continue
+      zx0=zx0+zdx
+      if(zanom.lt.0.) zx0=-zx0
+      PRINT*,'zx0   ',zx0
+
+!c zteta est la longitude solaire
+
+      timeperi=2.*atan(sqrt((1.+R_ecc)/(1.-R_ecc))*tan(zx0/2.))
+      PRINT*,'longitude solaire du perihelie timeperi = ',timeperi
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/iniphysiq.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/iniphysiq.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/iniphysiq.F90	(revision 17)
@@ -0,0 +1,166 @@
+!
+! $Id: iniphysiq.F 1707 2013-01-11 09:19:19Z fairhead $
+!
+!c
+!c
+      SUBROUTINE iniphysiq(ngrid,nlayer,                                             &
+       &           punjours,                                                         &
+       &           pdayref,ptimestep,                                                &
+       &           plat,plon,parea,pcu,pcv,                                          &
+       &           prad,pg,pr,pcpp,iflag_phys)
+      USE dimphy, only : klev
+      USE mod_grid_phy_lmdz, only : klon_glo
+      USE mod_phys_lmdz_para, only : klon_omp,klon_omp_begin,                        &
+       &                               klon_omp_end,klon_mpi_begin
+      USE comgeomphy, only : airephy,cuphy,cvphy,rlond,rlatd
+
+      IMPLICIT NONE
+!c
+!c=======================================================================
+!c
+!c   Initialisation of the physical constants and some positional and 
+!c   geometrical arrays for the physics
+!c
+!c
+!c    ngrid                 Size of the horizontal grid.
+!c                          All internal loops are performed on that grid.
+!c    nlayer                Number of vertical layers.
+!c    pdayref               Day of reference for the simulation
+!c
+!c=======================================================================
+ 
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "comgeomphy.h"
+#include "YOMCST.h"
+#include "iniprint.h"
+
+      REAL,INTENT(IN) :: prad ! radius of the planet (m)
+      REAL,INTENT(IN) :: pg ! gravitational acceleration (m/s2)
+      REAL,INTENT(IN) :: pr ! ! reduced gas constant R/mu
+      REAL,INTENT(IN) :: pcpp ! specific heat Cp
+      REAL,INTENT(IN) :: punjours ! length (in s) of a standard day
+      INTEGER,INTENT(IN) :: ngrid ! number of horizontal grid points in the physics
+      INTEGER,INTENT(IN) :: nlayer ! number of atmospheric layers
+      REAL,INTENT(IN) :: plat(ngrid) ! latitudes of the physics grid
+      REAL,INTENT(IN) :: plon(ngrid) ! longitudes of the physics grid
+      REAL,INTENT(IN) :: parea(klon_glo) ! area (m2)
+      REAL,INTENT(IN) :: pcu(klon_glo) ! cu coeff. (u_covariant = cu * u)
+      REAL,INTENT(IN) :: pcv(klon_glo) ! cv coeff. (v_covariant = cv * v)
+      INTEGER,INTENT(IN) :: pdayref ! reference day of for the simulation
+      REAL,INTENT(IN) :: ptimestep !physics time step (s)
+      INTEGER,INTENT(IN) :: iflag_phys ! type of physics to be called
+
+      INTEGER :: ibegin,iend,offset 
+      CHARACTER (LEN=20) :: modname='iniphysiq'
+      CHARACTER (LEN=80) :: abort_message
+ 
+      INTEGER :: ix,iy
+
+      IF (nlayer.NE.klev) THEN
+         write(lunout,*) 'STOP in ',trim(modname)
+         write(lunout,*) 'Problem with dimensions :'
+         write(lunout,*) 'nlayer     = ',nlayer
+         write(lunout,*) 'klev   = ',klev
+         abort_message = ''
+         CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+
+      IF (ngrid.NE.klon_glo) THEN
+         write(lunout,*) 'STOP in ',trim(modname)
+         write(lunout,*) 'Problem with dimensions :'
+         write(lunout,*) 'ngrid     = ',ngrid
+         write(lunout,*) 'klon   = ',klon_glo
+         abort_message = ''
+         CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+
+!$OMP PARALLEL PRIVATE(ibegin,iend) 
+!$OMP+         SHARED(parea,pcu,pcv,plon,plat)
+      
+      offset=klon_mpi_begin-1
+      airephy(1:klon_omp)=parea(offset+klon_omp_begin:                               &
+       &                          offset+klon_omp_end)
+      cuphy(1:klon_omp)=pcu(offset+klon_omp_begin:offset+klon_omp_end)
+      cvphy(1:klon_omp)=pcv(offset+klon_omp_begin:offset+klon_omp_end)
+      rlond(1:klon_omp)=plon(offset+klon_omp_begin:offset+klon_omp_end)
+      rlatd(1:klon_omp)=plat(offset+klon_omp_begin:offset+klon_omp_end)
+
+      ! suphel => initialize some physical constants (orbital parameters,
+      !           geoid, gravity, thermodynamical constants, etc.) in the
+      !           physics
+      call suphel
+      PRINT *,'Lluis after suphel'
+      
+!$OMP END PARALLEL
+
+      ! check that physical constants set in 'suphel' are coherent
+      ! with values set in the dynamics:
+      if (RDAY.ne.punjours) then
+        write(lunout,*) "iniphysiq: length of day discrepancy!!!"
+        write(lunout,*) "  in the dynamics punjours=",punjours
+        write(lunout,*) "   but in the physics RDAY=",RDAY
+        if (abs(RDAY-punjours).gt.0.01) then
+          ! stop here if the relative difference is more than 1%
+          abort_message = 'length of day discrepancy'
+          CALL abort_gcm (modname,abort_message,1)
+        endif
+      endif
+      if (RG.ne.pg) then
+        write(lunout,*) "iniphysiq: gravity discrepancy !!!"
+        write(lunout,*) "     in the dynamics pg=",pg
+        write(lunout,*) "  but in the physics RG=",RG
+        if (abs(RG-pg).gt.0.01) then
+          ! stop here if the relative difference is more than 1%
+          abort_message = 'gravity discrepancy'
+          CALL abort_gcm (modname,abort_message,1)
+        endif
+      endif
+      if (RA.ne.prad) then
+        write(lunout,*) "iniphysiq: planet radius discrepancy !!!"
+        write(lunout,*) "   in the dynamics prad=",prad
+        write(lunout,*) "  but in the physics RA=",RA
+        if (abs(RA-prad).gt.0.01) then
+          ! stop here if the relative difference is more than 1%
+          abort_message = 'planet radius discrepancy'
+          CALL abort_gcm (modname,abort_message,1)
+        endif
+      endif
+      if (RD.ne.pr) then
+        write(lunout,*)"iniphysiq: reduced gas constant discrepancy !!!"
+        write(lunout,*)"     in the dynamics pr=",pr
+        write(lunout,*)"  but in the physics RD=",RD
+        if (abs(RD-pr).gt.0.01) then
+          ! stop here if the relative difference is more than 1%
+          abort_message = 'reduced gas constant discrepancy'
+          CALL abort_gcm (modname,abort_message,1)
+        endif
+      endif
+      if (RCPD.ne.pcpp) then
+        write(lunout,*)"iniphysiq: specific heat discrepancy !!!"
+        write(lunout,*)"     in the dynamics pcpp=",pcpp
+        write(lunout,*)"  but in the physics RCPD=",RCPD
+        if (abs(RCPD-pcpp).gt.0.01) then
+          ! stop here if the relative difference is more than 1%
+          abort_message = 'specific heat discrepancy'
+          CALL abort_gcm (modname,abort_message,1)
+        endif
+      endif
+
+      PRINT *,'Lluis before iniaqua'
+
+! Additional initializations for aquaplanets
+!$OMP PARALLEL
+      if (iflag_phys>=100) then
+        call iniaqua(klon_omp,rlatd,rlond,iflag_phys)
+      endif
+!$OMP END PARALLEL
+      PRINT *,'Lluis after iniaqua'
+
+!      RETURN
+!9999  CONTINUE
+!      abort_message ='Cette version demande les fichier rnatur.dat
+!     & et surf.def'
+!      CALL abort_gcm (modname,abort_message,1)
+
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/iniprint.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/iniprint.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/iniprint.h	(revision 17)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+!
+! gestion des impressions de sorties et de débogage
+! lunout:    unité du fichier dans lequel se font les sorties 
+!                           (par defaut 6, la sortie standard)
+! prt_level: niveau d'impression souhaité (0 = minimum)
+!
+      INTEGER lunout, prt_level
+      COMMON /comprint/ lunout, prt_level
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/iniradia.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/iniradia.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/iniradia.F	(revision 17)
@@ -0,0 +1,32 @@
+      SUBROUTINE iniradia (klon,klev,pres)
+  
+      IMPLICIT none
+c======================================================================
+c
+c Auteur(s) MP Lefebvre        date: 20080827
+c
+c Objet: initialise le rayonnement RRTM           
+c======================================================================
+c  Arguments:
+c
+c klon----input-I-nombre de points horizontaux
+c klev----input-I-nombre de couches verticales
+c pres----input-R-pression pour chaque inter-couche (en Pa)
+c======================================================================
+c
+      INTEGER klon
+      INTEGER klev
+      REAL pres(klev+1)
+
+!         CALL suphel     ! initialiser constantes et parametres phys.
+!     print*,'Physiq: apres suphel '
+!        CALL SUINIT(klon,klev)
+!     print*,'iniradia: apres suinit '
+! calcul des niveaux de pression de reference au bord des couches pour
+! l'intialisation des aerosols. Momentannement, on passe un point de
+! grille du profil de pression.
+!        CALL SURAYOLMD(pres(klev+1))  ! initialiser le rayonnement RRTM
+!     print*,'iniradia: apres surayolmd '
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/iniradia.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/iniradia.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/iniradia.F90	(revision 17)
@@ -0,0 +1,32 @@
+      SUBROUTINE iniradia (klon,klev,pres)
+  
+      IMPLICIT none
+!c======================================================================
+!c
+!c Auteur(s) MP Lefebvre        date: 20080827
+!c
+!c Objet: initialise le rayonnement RRTM           
+!c======================================================================
+!c  Arguments:
+!c
+!c klon----input-I-nombre de points horizontaux
+!c klev----input-I-nombre de couches verticales
+!c pres----input-R-pression pour chaque inter-couche (en Pa)
+!c======================================================================
+!c
+      INTEGER klon
+      INTEGER klev
+      REAL pres(klev+1)
+
+!         CALL suphel     ! initialiser constantes et parametres phys.
+!     print*,'Physiq: apres suphel '
+!        CALL SUINIT(klon,klev)
+!     print*,'iniradia: apres suinit '
+! calcul des niveaux de pression de reference au bord des couches pour
+! l'intialisation des aerosols. Momentannement, on passe un point de
+! grille du profil de pression.
+!        CALL SURAYOLMD(pres(klev+1))  ! initialiser le rayonnement RRTM
+!     print*,'iniradia: apres surayolmd '
+
+      RETURN
+      END SUBROUTINE iniradia
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/inistats.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/inistats.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/inistats.F	(revision 17)
@@ -0,0 +1,132 @@
+      subroutine inistats(ierr)
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "statto.h"
+#include "netcdf.inc"
+
+      integer,intent(out) :: ierr
+      integer :: nid
+      integer :: l,nsteppd
+      real, dimension(llm) ::  sig_s
+      integer :: idim_lat,idim_lon,idim_llm,idim_llmp1,idim_time
+      real, dimension(istime) :: lt
+      integer :: nvarid
+
+      write (*,*) 
+      write (*,*) '                        || STATS ||'
+      write (*,*) 
+      write (*,*) 'daysec',daysec
+      write (*,*) 'dtphys',dtphys
+      nsteppd=nint(daysec/dtphys)
+      write (*,*) 'nsteppd=',nsteppd
+      if (abs(float(nsteppd)-daysec/dtphys).gt.1.e-8*daysec)
+     &   stop'Dans Instat:  1jour .ne. n pas physiques'
+
+      if(mod(nsteppd,istime).ne.0)
+     &   stop'Dans Instat:  1jour .ne. n*istime pas physiques'
+
+      istats=nsteppd/istime
+      write (*,*) 'istats=',istats
+      write (*,*) 'Storing ',istime,'times per day'
+      write (*,*) 'thus every ',istats,'physical timestep '
+      write (*,*) 
+
+      do l= 1, llm
+         sig_s(l)=((ap(l)+ap(l+1))/preff+bp(l)+bp(l+1))/2.
+         pseudoalt(l)=log(preff/presnivs(l))*8.  
+      enddo
+
+      ierr = NF_CREATE("stats.nc",NF_CLOBBER,nid)
+      if (ierr.ne.NF_NOERR) then
+         write (*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+
+      ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_lat)
+      ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_lon)
+      ierr = NF_DEF_DIM (nid, "altitude", llm, idim_llm)
+      ierr = NF_DEF_DIM (nid, "llmp1", llm+1, idim_llmp1)
+      ierr = NF_DEF_DIM (nid, "Time", NF_UNLIMITED, idim_time)
+
+      ierr = NF_ENDDEF(nid)
+      call def_var_stats(nid,"Time","Time",
+     &            "hours since 0000-00-0 00:00:00",1,
+     &            idim_time,nvarid,ierr)
+! Time is initialised later by mkstats subroutine
+
+      call def_var_stats(nid,"latitude","latitude",
+     &            "degrees_north",1,idim_lat,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu/pi*180)
+#endif
+      call def_var_stats(nid,"longitude","East longitude",
+     &            "degrees_east",1,idim_lon,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv/pi*180)
+#endif
+
+! Niveaux verticaux, aps et bps
+      ierr = NF_REDEF (nid)
+! presnivs
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"presnivs", NF_DOUBLE, 1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"presnivs", NF_FLOAT, 1,idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",15,
+     &                        "Vertical levels")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"Pa")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',4,"down")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid, 
+     &                          presnivs(1:llm))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid, 
+     &                        presnivs(1:llm))
+#endif 
+! Pseudo alts
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"altitude", NF_DOUBLE, 1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"altitude", NF_FLOAT, 1,idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",8,"altitude")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"km")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',2,"up")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pseudoalt)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pseudoalt)
+#endif 
+!      call def_var_stats(nid,"aps","hybrid pressure at midlayers"," ", 
+!     &            1,idim_llm,nvarid,ierr)
+!#ifdef NC_DOUBLE
+!      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aps)
+!#else
+!      ierr = NF_PUT_VAR_REAL (nid,nvarid,aps)
+!#endif
+
+!      call def_var_stats(nid,"bps","hybrid sigma at midlayers"," ", 
+!     &            1,idim_llm,nvarid,ierr)
+!#ifdef NC_DOUBLE
+!      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bps)
+!#else 
+!      ierr = NF_PUT_VAR_REAL (nid,nvarid,bps)
+!#endif
+
+      ierr=NF_CLOSE(nid)
+
+      end subroutine inistats
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/inistats.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/inistats.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/inistats.F90	(revision 17)
@@ -0,0 +1,132 @@
+      subroutine inistats(ierr)
+
+      implicit none
+
+#include "dimensions.h"
+#include "paramet.h"
+#include "comgeom.h"
+#include "comvert.h"
+#include "comconst.h"
+#include "statto.h"
+  include "netcdf.inc"
+
+      integer,intent(out) :: ierr
+      integer :: nid
+      integer :: l,nsteppd
+      real, dimension(llm) ::  sig_s
+      integer :: idim_lat,idim_lon,idim_llm,idim_llmp1,idim_time
+      real, dimension(istime) :: lt
+      integer :: nvarid
+
+      write (*,*) 
+      write (*,*) '                        || STATS ||'
+      write (*,*) 
+      write (*,*) 'daysec',daysec
+      write (*,*) 'dtphys',dtphys
+      nsteppd=nint(daysec/dtphys)
+      write (*,*) 'nsteppd=',nsteppd
+      if (abs(float(nsteppd)-daysec/dtphys).gt.1.e-8*daysec)                         &
+       &   stop'Dans Instat:  1jour .ne. n pas physiques'
+
+      if(mod(nsteppd,istime).ne.0)                                                   &
+       &   stop'Dans Instat:  1jour .ne. n*istime pas physiques'
+
+      istats=nsteppd/istime
+      write (*,*) 'istats=',istats
+      write (*,*) 'Storing ',istime,'times per day'
+      write (*,*) 'thus every ',istats,'physical timestep '
+      write (*,*) 
+
+      do l= 1, llm
+         sig_s(l)=((ap(l)+ap(l+1))/preff+bp(l)+bp(l+1))/2.
+         pseudoalt(l)=log(preff/presnivs(l))*8.  
+      enddo
+
+      ierr = NF_CREATE("stats.nc",NF_CLOBBER,nid)
+      if (ierr.ne.NF_NOERR) then
+         write (*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+
+      ierr = NF_DEF_DIM (nid, "latitude", jjp1, idim_lat)
+      ierr = NF_DEF_DIM (nid, "longitude", iip1, idim_lon)
+      ierr = NF_DEF_DIM (nid, "altitude", llm, idim_llm)
+      ierr = NF_DEF_DIM (nid, "llmp1", llm+1, idim_llmp1)
+      ierr = NF_DEF_DIM (nid, "Time", NF_UNLIMITED, idim_time)
+
+      ierr = NF_ENDDEF(nid)
+      call def_var_stats(nid,"Time","Time",                                          &
+       &            "hours since 0000-00-0 00:00:00",1,                              &
+       &            idim_time,nvarid,ierr)
+! Time is initialised later by mkstats subroutine
+
+      call def_var_stats(nid,"latitude","latitude",                                  &
+       &            "degrees_north",1,idim_lat,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlatu/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlatu/pi*180)
+#endif
+      call def_var_stats(nid,"longitude","East longitude",                           &
+       &            "degrees_east",1,idim_lon,nvarid,ierr)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,rlonv/pi*180)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,rlonv/pi*180)
+#endif
+
+! Niveaux verticaux, aps et bps
+      ierr = NF_REDEF (nid)
+! presnivs
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"presnivs", NF_DOUBLE, 1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"presnivs", NF_FLOAT, 1,idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",15,                             &
+       &                        "Vertical levels")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"Pa")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',4,"down")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,                                          &
+       &                          presnivs(1:llm))
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,                                            &
+       &                        presnivs(1:llm))
+#endif 
+! Pseudo alts
+#ifdef NC_DOUBLE
+      ierr = NF_DEF_VAR (nid,"altitude", NF_DOUBLE, 1,idim_llm,nvarid)
+#else
+      ierr = NF_DEF_VAR (nid,"altitude", NF_FLOAT, 1,idim_llm,nvarid)
+#endif
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,"long_name",8,"altitude")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'units',2,"km")
+      ierr = NF_PUT_ATT_TEXT (nid,nvarid,'positive',2,"up")
+      ierr = NF_ENDDEF(nid)
+#ifdef NC_DOUBLE
+      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,pseudoalt)
+#else
+      ierr = NF_PUT_VAR_REAL (nid,nvarid,pseudoalt)
+#endif 
+!      call def_var_stats(nid,"aps","hybrid pressure at midlayers"," ", 
+!     &            1,idim_llm,nvarid,ierr)
+!#ifdef NC_DOUBLE
+!      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,aps)
+!#else
+!      ierr = NF_PUT_VAR_REAL (nid,nvarid,aps)
+!#endif
+
+!      call def_var_stats(nid,"bps","hybrid sigma at midlayers"," ", 
+!     &            1,idim_llm,nvarid,ierr)
+!#ifdef NC_DOUBLE
+!      ierr = NF_PUT_VAR_DOUBLE (nid,nvarid,bps)
+!#else 
+!      ierr = NF_PUT_VAR_REAL (nid,nvarid,bps)
+!#endif
+
+      ierr=NF_CLOSE(nid)
+
+      end subroutine inistats
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/init_be.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/init_be.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/init_be.F90	(revision 17)
@@ -0,0 +1,565 @@
+!$Id $
+
+SUBROUTINE init_be(pctsrf,pplay,masktr,tautr,vdeptr,scavtr,srcbe)
+!!!SUBROUTINE init_be(pctsrf,masktr,tautr,vdeptr,scavtr,srcbe)
+
+  USE dimphy
+  USE comgeomphy
+  USE infotrac, ONLY : nbtr
+  USE indice_sol_mod
+    
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : prescription d'une source de Beryllium 7 
+!         pour 19 niveaux verticaux
+!        (d'apres le diagramme de Lal and Peters, 1967)
+!
+!
+! written by : O. Coindreau (CEA/LDG) 05/2005
+! last modified by : A. Jamelot (LMD/CEA)  04/03/2009 
+!=====================================================================
+
+  INCLUDE "YOMCST.h"
+  INCLUDE "YOECUMF.h" 
+
+!
+! Input Arguments
+!
+  REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf !Pourcentage de sol (f(nature du sol))
+  REAL,DIMENSION(klon,klev), INTENT(IN) :: pplay  ! Pressions en milieu de couches
+!
+! Output Arguments
+!
+  REAL,DIMENSION(klon),INTENT(OUT)      :: masktr ! Masque de l'echange avec la surface (possible => 1 )
+  REAL,INTENT(OUT)                      :: tautr  ! Constante de decroissance radioactive
+  REAL,INTENT(OUT)                      :: vdeptr ! Vitesse de depot sec dans la couche Brownienne
+  REAL,INTENT(OUT)                      :: scavtr ! Coefficient de lessivage
+  REAL,DIMENSION(klon,klev),INTENT(OUT) :: srcbe  ! source volumique de 7Be      
+!
+! Local Variables
+!
+!!!  INTEGER              :: iref      ! numero d'un point oceanique donnant la grille de pression de reference
+  REAL,DIMENSION(klon) :: rlatgeo   ! latitudes geomagnetiques de la grille
+  REAL                 :: glt       ! latitude du pole geomagnetique
+  REAL                 :: glg       ! longitude du pole geomagnetique
+  REAL                 :: latgeo,qcos
+  INTEGER              :: k,i, kref, k2
+  INTEGER              :: nref
+  PARAMETER (nref=39)
+  REAL,DIMENSION(nref), SAVE :: pref      ! grille de pression de reference (bas des couches)
+  DATA pref  /   &
+      101249.99999999994, 100387.17261011522, 99447.35334189111,  98357.43412194174,   &
+      97046.47707771382,  95447.1116450629,   93496.85259615642,  91139.46548240296,   &
+      88326.55568744117,  85019.60710580258,  81192.7404556645,   76836.48366938648,   &
+      71962.81275769137,  66611.56331321516,  60857.914829743604, 54819.84484441629,   &
+      48663.06257114699,  42598.95465845692,  36869.104365898806, 31709.927925633147,  &
+      27296.757208636915, 23682.282929080895, 20766.025578936627, 18336.105961406534,  &
+      16178.04816768436,  14168.286905562818, 12275.719926478887, 10507.798835225762,  &
+      8876.585404909414,  7391.283929569539,  6057.514475749798,  4877.165909157005,   &
+      3848.34936408203,   2965.444753540027,  2219.2391544640013, 1597.15366044666,    &
+      1083.5531161631498, 660.1311067852655,  306.36072267002805 / 
+!$OMP THREADPRIVATE(pref)
+
+  WRITE(*,*)'PASSAGE init_be ...'
+
+! la source est maintenant définie independemment de la valeur de klev.
+!!! Source actuellement definie pour klev = 19 et klev >= 39
+!!  IF (klev /= 19 .AND. klev<39) CALL abort_gcm("init_be","Source du be7 necessite klev=19 ou klev>=39",1)
+!!!
+! Definition des constantes
+! -------------------------
+  tautr = 6645000.
+  vdeptr = 1.E-3 
+  scavtr = 0.5 
+!!!!!jyg le 13/03/2013; puis 20/03/2013 : pref est maintenant une table.
+!!!
+!!!   Recherche d'un point rlat=0., rlon=180.
+!!      iref=(klon+1)/2
+!!      DO i = 1,klon
+!!        IF (abs(rlatd(i)) .LT. 0.15 .AND. cos(rlond(i)) .LT. -0.85) iref=i
+!!      ENDDO
+!!!
+!!!   Grille de pression de reference (= approx de sommets de couches)
+!!      pref(1) = pplay(iref,1)+0.5*(pplay(iref,1)-pplay(iref,2))
+!!      DO k = 2,klev
+!!        pref(k) = 0.5*(pplay(iref,k-1)+pplay(iref,k))
+!!      ENDDO
+!!!
+
+  WRITE(*,*) '-------------- SOURCE DE BERYLLIUM ------------------- '
+  WRITE(*,*)'Decroissance (s): ', tautr
+  WRITE(*,*)'Vitesse de depot sec: ',vdeptr
+  WRITE(*,*)'Facteur de lessivage: ',scavtr
+
+  DO i = 1,klon
+     masktr(i) = 0.
+     IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i) = 1.
+  END DO
+
+! Premiers niveaux: source nulle
+! ------------------------------
+  DO k = 1,6
+     DO i = 1,klon
+        srcbe(i,k) = 0.
+     END DO
+  END DO
+!
+! Pour les autres niveaux:
+! 1-passer des coordonnees geographiques a la latitude geomagnetique
+! 2-prescrire la source de Be (en 10exp5 at/g/s) dans ce repere
+! 3-mettre la source de Be ds la bonne unite (en at/kgA/s)
+!
+  glt =  78.5*rpi/180.
+  glg = -69.0*rpi/180.
+
+  DO i = 1,klon
+     qcos=sin(glt)*sin(rlatd(i))
+!!jyg
+!!     qcos=qcos+cos(glt)*cos(rlatd(i))*cos(rlond(i)+glg)
+     qcos=qcos+cos(glt)*cos(rlatd(i))*cos(rlond(i)-glg)
+!!jyg end
+     IF ( qcos .LT. -1.) qcos = -1.
+     IF ( qcos .GT. 1.)  qcos = 1.
+     rlatgeo(i)=rpi/2.-acos(qcos)
+  ENDDO
+
+!!!===========================
+!!!  Cas 19 niveaux verticaux
+!!!===========================
+!!  IF (klev.eq.19) then
+!!     DO k = 1,klev
+!!        DO i = 1,klon
+!!!!!jyg le 13/03/2013
+!!!
+!!! k est le niveau dans la grille locale
+!!! Determination du niveau kref dans la grille de refernce
+!!      kref = 1
+!!      DO k2 = 1,klev
+!!        IF (pref(k2) .GT. pplay(i,k)) kref=k2
+!!      ENDDO
+!!!!!
+!!           latgeo=(180./rpi)*abs(rlatgeo(i))
+!!           IF ( kref .EQ. 1 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.1
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.09
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.07
+!!           END IF
+!!           IF ( kref .EQ. 2 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.12
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.1
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.09
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.07
+!!           END IF
+!!           IF ( kref .EQ. 3 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.14
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.12
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.1
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.09
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.07
+!!           END IF
+!!           IF ( kref .EQ. 4 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.175
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.09
+!!           END IF
+!!           IF ( kref .EQ. 5 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.28
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.26
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.23
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.175
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.14
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.12
+!!           END IF
+!!           IF ( kref .EQ. 6 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=0.56
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.49
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.42
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.28
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.26
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.245
+!!           END IF
+!!           IF ( kref .EQ. 7 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=1.05
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.875
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.7
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.52
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.44
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.385
+!!           END IF
+!!           IF ( kref .EQ. 8 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=2.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1.8
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.5
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=1.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.8
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.75
+!!           END IF
+!!           IF ( kref .EQ. 9 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=4.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=3.5
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=3.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=2.5
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.8
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=1.4
+!!           END IF
+!!           IF ( kref .EQ. 10 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=8.5
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=8.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=7.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=4.5
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3.5
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3.
+!!           END IF
+!!           IF ( kref .EQ. 11 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=17.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=15.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=11.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=8.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=5.
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4.
+!!           END IF
+!!           IF ( kref .EQ. 12 ) THEN
+!!              IF (latgeo.GE.50.0) srcbe(i,k)=25.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=22.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=11.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.5
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.
+!!           END IF
+!!           IF ( kref .EQ. 13 ) THEN
+!!              IF (latgeo.GE.60.0) srcbe(i,k)=33.
+!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=32.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=30.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=22.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11.
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=8.
+!!           END IF
+!!           IF ( kref .EQ. 14 ) THEN
+!!              IF (latgeo.GE.60.0) srcbe(i,k)=48.
+!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=36.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=26.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=17.5
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
+!!           END IF
+!!           IF ( kref .EQ. 15 ) THEN
+!!              IF (latgeo.GE.70.0) srcbe(i,k)=58.
+!!              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=57.
+!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=38.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
+!!           END IF
+!!           IF ( kref .EQ. 16 ) THEN
+!!              IF (latgeo.GE.70.0) srcbe(i,k)=70.
+!!              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=65.
+!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=20.
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=13.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=9.
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.5
+!!           END IF
+!!           IF ( kref .GE. 17 ) THEN
+!!              IF (latgeo.GE.70.0) srcbe(i,k)=80.
+!!              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=70.
+!!              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45.
+!!              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=27.
+!!              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17.5
+!!              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=12.
+!!              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8.
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.
+!!           END IF
+!!        END DO
+!!     END DO
+!!  END IF ! fin de 19 niveaux verticaux
+!!
+!!!!!!  IF (klev .ge. 39) then
+     DO k = 1,klev
+        DO i = 1,klon
+!!!jyg le 13/03/2013
+!
+! k est le niveau dans la grille locale
+! Determination du niveau kref dans la grille de refernce
+      kref = 1
+      DO k2 = 1,nref
+        IF (pref(k2) .GT. pplay(i,k)) kref=k2
+      ENDDO
+!!!
+           latgeo=(180./rpi)*abs(rlatgeo(i))
+           IF ( kref .LE. 4 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.07
+           END IF
+           IF ( kref .EQ. 5 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.1
+              IF (latgeo.GE.20.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.09
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.07
+           END IF
+           IF ( kref .EQ. 6 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.14
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.12
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.1
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.09
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.07
+           END IF
+           IF ( kref .EQ. 7 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.16
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.09
+           END IF
+           IF ( kref .EQ. 8 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.175
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.16
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.14
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.12
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.1
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.1
+           END IF
+           IF ( kref .EQ. 9 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.245
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.21
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.175
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.14
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.12
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.12
+           END IF
+           IF ( kref .EQ. 10 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.31
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.28
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.245
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.21
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.16
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.14
+           END IF
+           IF ( kref .EQ. 11 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.35
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.3
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.3
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.2
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.18
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.16
+           END IF
+           IF ( kref .EQ. 12 ) THEN
+              IF (latgeo.GE.40.0) srcbe(i,k)=0.5
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.4
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.35
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.3
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.25
+           END IF
+           IF ( kref .EQ. 13 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=0.8
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=0.7
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.6
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.5
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.4
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.35
+           END IF
+           IF ( kref .EQ. 14 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=1.2
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=0.75
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.6
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.4
+           END IF
+           IF ( kref .EQ. 15 ) THEN
+              IF (latgeo.GE.60.0) srcbe(i,k)=1.75
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=1.8 
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=1.6
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.4
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=0.9
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=0.75
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.65
+           END IF
+           IF ( kref .EQ. 16 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=3.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=2.5
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=1.8
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=1.5
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.2
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=0.9
+           END IF
+           IF ( kref .EQ. 17 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=4.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=3.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=2.5
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=2.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=1.6
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=1.4
+           END IF
+           IF ( kref .EQ. 18 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=7.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=6.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=4.5
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=3.5
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=2.
+           END IF
+           IF ( kref .EQ. 19 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=8.5
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=8.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=7.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=4.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=3.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3.
+           END IF
+           IF ( kref .EQ. 20 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=12.5
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=12.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=8.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=6.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=4.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=3.5
+           END IF
+           IF ( kref .EQ. 21 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=16.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=13.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=10.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=7.5
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=4.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4.
+           END IF
+           IF ( kref .EQ. 22 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=20.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=17.5
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=12.5
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=9.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=6.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=4.5
+           END IF
+           IF ( kref .EQ. 23 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=25.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=22.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=15.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=10.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=6.
+           END IF
+           IF ( kref .EQ. 24 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=28.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=26.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=18.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=12.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.
+           END IF
+           IF ( kref .EQ. 25 ) THEN
+              IF (latgeo.GE.50.0) srcbe(i,k)=33.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=28.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=20.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=14.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=10.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=8.5
+           END IF
+           IF ( kref .EQ. 26 ) THEN
+              IF (latgeo.GE.60.0) srcbe(i,k)=38.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=36.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=24.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
+!!jyg
+!!              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=6.
+!!jyg end
+           END IF
+           IF ( kref .EQ. 27 ) THEN
+              IF (latgeo.GE.60.0) srcbe(i,k)=46.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=44.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=35.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=16.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
+           END IF
+           IF ( kref .EQ. 28 ) THEN
+              IF (latgeo.GE.60.0) srcbe(i,k)=53.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=48.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=37.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=25.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=16.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=12.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
+           END IF
+           IF ( kref .EQ. 29 ) THEN
+              IF (latgeo.GE.70.0) srcbe(i,k)=58.
+              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=56.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=36.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=24.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=15.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=11.5
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=10.
+           END IF
+           IF ( kref .EQ. 30 ) THEN
+              IF (latgeo.GE.70.0) srcbe(i,k)=65.
+              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=60.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=50.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=35.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=22.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=14.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=10.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=9.
+           END IF
+           IF ( kref .EQ. 31 ) THEN
+              IF (latgeo.GE.70.0) srcbe(i,k)=70.
+              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=62.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=48.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=32.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=21.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=13.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=9.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.6
+           END IF
+           IF ( kref .EQ. 32 ) THEN
+              IF (latgeo.GE.70.0) srcbe(i,k)=80.
+              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=60.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=46.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=30.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=17.5
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=11.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=8.
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.4
+           END IF
+           IF ( kref .GE. 33 ) THEN
+              IF (latgeo.GE.70.0) srcbe(i,k)=80.
+              IF (latgeo.GE.60.0 .and. latgeo.LT.70.0) srcbe(i,k)=70.
+              IF (latgeo.GE.50.0 .and. latgeo.LT.60.0) srcbe(i,k)=45.
+              IF (latgeo.GE.40.0 .and. latgeo.LT.50.0) srcbe(i,k)=27.
+              IF (latgeo.GE.30.0 .and. latgeo.LT.40.0) srcbe(i,k)=15.
+              IF (latgeo.GE.20.0 .and. latgeo.LT.30.0) srcbe(i,k)=10.
+              IF (latgeo.GE.10.0 .and. latgeo.LT.20.0) srcbe(i,k)=7.6
+              IF (latgeo.GE.0.0 .and. latgeo.LT.10.0) srcbe(i,k)=7.
+           END IF
+        END DO
+     END DO
+!!!!!!  END IF ! fin de 39 niveaux verticaux
+
+
+!====================================
+! Conversion de la source en U/s/kgA
+!====================================
+  DO k = 1,klev
+     DO i = 1,klon
+       ! La source est  at/min/m3 -> at/s/kgA
+       ! avec une masse volumique de l'air = 1.295 kg/m3
+       ! 1/(60*1.295) = 0.01287
+       srcbe(i,k)=srcbe(i,k)*0.01287
+!!       print *,'  k, srcbe(i,k) ',   &
+!!                  k, srcbe(i,k)
+       ! La source est  at/min/m3 -> at/s/m3
+       ! srcbe(i,k)=srcbe(i,k)*0.0166667
+    END DO
+ END DO
+
+END SUBROUTINE init_be
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/init_phys_lmdz.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/init_phys_lmdz.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/init_phys_lmdz.F90	(revision 17)
@@ -0,0 +1,36 @@
+!
+!$Header$
+!
+SUBROUTINE Init_Phys_lmdz(iim,jjp1,llm,nb_proc,distrib)
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  USE dimphy, ONLY : Init_dimphy
+  USE infotrac, ONLY : type_trac
+#ifdef REPROBUS
+  USE CHEM_REP, ONLY : Init_chem_rep_phys
+#endif
+
+  IMPLICIT NONE
+  
+    INTEGER,INTENT(in) :: iim
+    INTEGER,INTENT(in) :: jjp1
+    INTEGER,INTENT(in) :: llm
+    INTEGER,INTENT(in) :: nb_proc
+    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+
+    CALL Init_grid_phy_lmdz(iim,jjp1,llm)
+
+    CALL Init_phys_lmdz_para(iim,jjp1,nb_proc,distrib)
+!$OMP PARALLEL
+    CALL Init_dimphy(klon_omp,nbp_lev)
+
+! Initialization of Reprobus
+    IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+       CALL Init_chem_rep_phys(klon_omp,nbp_lev)
+#endif
+    END IF
+
+!$OMP END PARALLEL
+ 
+END SUBROUTINE Init_Phys_lmdz  
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/initphysto.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/initphysto.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/initphysto.F90	(revision 17)
@@ -0,0 +1,216 @@
+!
+! $Id: initphysto.F90 1795 2013-07-18 08:20:28Z emillour $
+!
+SUBROUTINE initphysto(infile,tstep,t_ops,t_wrt,fileid)
+  
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE IOIPSL
+  USE iophy
+  USE control_mod
+  USE indice_sol_mod
+  
+  IMPLICIT NONE
+
+!
+!   Routine d'initialisation des ecritures des fichiers histoires LMDZ
+!   au format IOIPSL
+!
+!   Appels succesifs des routines: histbeg
+!                                  histhori
+!                                  histver
+!                                  histdef
+!                                  histend
+!
+!   Entree:
+!
+!      infile: nom du fichier histoire a creer
+!      day0,anne0: date de reference
+!      tstep: duree du pas de temps en seconde
+!      t_ops: frequence de l'operation pour IOIPSL
+!      t_wrt: frequence d'ecriture sur le fichier
+!
+!   Sortie:
+!      fileid: ID du fichier netcdf cree
+!
+!   L. Fairhead, LMD, 03/99
+!
+! =====================================================================
+!
+!   Declarations
+  INCLUDE "dimensions.h"
+  INCLUDE "paramet.h"
+  INCLUDE "comconst.h"
+  INCLUDE "comgeom.h"
+  INCLUDE "temps.h"
+  INCLUDE "logic.h"
+  INCLUDE "description.h"
+  INCLUDE "serre.h"
+
+!   Arguments
+  CHARACTER(len=*), INTENT(IN) :: infile
+  REAL, INTENT(IN)             :: tstep
+  REAL, INTENT(IN)             :: t_ops
+  REAL, INTENT(IN)             :: t_wrt
+  INTEGER, INTENT(OUT)         :: fileid
+
+! Variables locales
+  INTEGER nhoriid, i
+  INTEGER l,k
+  REAL nivsigs(llm)
+  INTEGER tau0
+  REAL zjulian
+  INTEGER iq
+  INTEGER uhoriid, vhoriid, thoriid, zvertiid
+  INTEGER ii,jj
+  INTEGER zan, idayref
+  LOGICAL ok_sync
+  REAL zx_lon(iim,jjm+1), zx_lat(iim,jjm+1)
+  CHARACTER(len=12) :: nvar
+
+!  Initialisations
+!
+  pi = 4. * ATAN (1.)
+  ok_sync= .TRUE.
+!
+!  Appel a histbeg: creation du fichier netcdf et initialisations diverses
+!         
+
+  zan = annee_ref
+  idayref = day_ref
+  CALL ymds2ju(zan, 1, idayref, 0.0, zjulian)
+  tau0 = 0
+  
+  CALL histbeg_phy(infile,tau0, zjulian, tstep, &
+       nhoriid, fileid)
+
+!$OMP MASTER	
+!  Appel a histvert pour la grille verticale
+!
+  DO l=1,llm
+     nivsigs(l)=REAL(l)
+  ENDDO
+  
+  CALL histvert(fileid, 'sig_s', 'Niveaux sigma', &
+       'sigma_level', &
+       llm, nivsigs, zvertiid)
+!
+!  Appels a histdef pour la definition des variables a sauvegarder
+!
+  CALL histdef(fileid, "phis", "Surface geop. height", "-", &
+       iim,jj_nb,nhoriid, 1,1,1, -99, 32, &
+       "once", t_ops, t_wrt)
+  
+  CALL histdef(fileid, "aire", "Grid area", "-", &
+       iim,jj_nb,nhoriid, 1,1,1, -99, 32, &
+       "once", t_ops, t_wrt)
+
+  CALL histdef(fileid, "longitudes", "longitudes", "-", &
+       iim,jj_nb,nhoriid, 1,1,1, -99, 32, &
+       "once", t_ops, t_wrt)
+
+  CALL histdef(fileid, "latitudes", "latitudes", "-", &
+       iim,jj_nb,nhoriid, 1,1,1, -99, 32, &
+       "once", t_ops, t_wrt)
+! T 
+  CALL histdef(fileid, 't', 'Temperature', 'K', iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! mfu 
+  CALL histdef(fileid, 'mfu', 'flx m. pan. mt', 'kg m/s',iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid,32, 'inst(X)', t_ops, t_wrt)
+! mfd 
+  CALL histdef(fileid, 'mfd', 'flx m. pan. des', 'kg m/s',iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! en_u 
+  CALL histdef(fileid, 'en_u', 'flx ent pan mt', 'kg m/s', iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid,32, 'inst(X)', t_ops, t_wrt)
+! de_u 
+  CALL histdef(fileid, 'de_u', 'flx det pan mt', 'kg m/s',iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid,32, 'inst(X)', t_ops, t_wrt)
+! en_d 
+  CALL histdef(fileid, 'en_d', 'flx ent pan dt', 'kg m/s', iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid,32, 'inst(X)', t_ops, t_wrt)
+! de_d 
+  CALL histdef(fileid, 'de_d', 'flx det pan dt', 'kg m/s', iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! coefh
+  CALL histdef(fileid, "coefh", " ", " ", iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid,32, "inst(X)", t_ops, t_wrt)
+! fm_th
+  CALL histdef(fileid, "fm_th", " ", " ",iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid,32, "inst(X)", t_ops, t_wrt)
+! en_th
+  CALL histdef(fileid, "en_th", " ", " ",iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid,32, "inst(X)", t_ops, t_wrt)
+! frac_impa
+  CALL histdef(fileid, 'frac_impa', ' ', ' ',iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid,32, 'inst(X)', t_ops, t_wrt)
+! frac_nucl
+  CALL histdef(fileid, 'frac_nucl', ' ', ' ',iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid,32, 'inst(X)', t_ops, t_wrt)
+! pyu1
+  CALL histdef(fileid, "pyu1", " ", " ", iim,jj_nb,nhoriid, &
+       1,1,1, -99, 32, "inst(X)", t_ops, t_wrt)
+! pyv1
+  CALL histdef(fileid, "pyv1", " ", " ", iim,jj_nb,nhoriid, &
+       1,1,1, -99, 32,"inst(X)", t_ops, t_wrt)    
+! ftsol1
+  CALL histdef(fileid, "ftsol1", " ", " ",iim, jj_nb, nhoriid, &
+       1, 1,1, -99,32, "inst(X)", t_ops, t_wrt)
+! ftsol2
+  CALL histdef(fileid, "ftsol2", " ", " ",iim, jj_nb, nhoriid, &
+       1, 1,1, -99,32, "inst(X)", t_ops, t_wrt)
+! ftsol3
+  CALL histdef(fileid, "ftsol3", " ", " ", iim, jj_nb, nhoriid, &
+       1, 1,1, -99,32, "inst(X)", t_ops, t_wrt)
+! ftsol4
+  CALL histdef(fileid, "ftsol4", " ", " ",iim, jj_nb, nhoriid, &
+       1, 1,1, -99, 32, "inst(X)", t_ops, t_wrt)
+! psrf1
+  CALL histdef(fileid, "psrf1", " ", " ",iim, jj_nb, nhoriid, &
+       1, 1, 1, -99,32, "inst(X)", t_ops, t_wrt)
+! psrf2
+  CALL histdef(fileid, "psrf2", " ", " ",iim, jj_nb, nhoriid, &
+       1, 1, 1, -99, 32, "inst(X)", t_ops, t_wrt)
+! psrf3
+  CALL histdef(fileid, "psrf3", " ", " ",iim, jj_nb, nhoriid, &
+       1, 1, 1, -99, 32, "inst(X)", t_ops, t_wrt)
+! psrf4
+  CALL histdef(fileid, "psrf4", " ", " ", iim, jj_nb, nhoriid, &
+       1, 1, 1, -99,32, "inst(X)", t_ops, t_wrt)
+! sh
+  CALL histdef(fileid, 'sh', '', '', iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! da
+  CALL histdef(fileid, 'da', '', '', iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! mp
+  CALL histdef(fileid, 'mp', '', '', iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! upwd
+  CALL histdef(fileid, 'upwd', '', '', iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+! dnwd
+  CALL histdef(fileid, 'dnwd', '', '', iim, jj_nb, nhoriid, &
+       llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+
+! phi
+  DO k=1,llm
+     IF (k<10) THEN
+        WRITE(nvar,'(i1)') k
+     ELSE IF (k<100) THEN
+        WRITE(nvar,'(i2)') k
+     ELSE
+        WRITE(nvar,'(i3)') k
+     END IF
+     nvar='phi_lev'//trim(nvar)
+     
+     CALL histdef(fileid, nvar, '', '', iim, jj_nb, nhoriid, &
+          llm, 1, llm, zvertiid, 32, 'inst(X)', t_ops, t_wrt)
+  END DO
+
+  CALL histend(fileid)
+  IF (ok_sync) CALL histsync
+!$OMP END MASTER
+	
+END SUBROUTINE initphysto
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/initrrnpb.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/initrrnpb.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/initrrnpb.F90	(revision 17)
@@ -0,0 +1,95 @@
+!
+! $Id: initrrnpb.F90 1795 2013-07-18 08:20:28Z emillour $
+!
+SUBROUTINE  initrrnpb(id_rn,id_pb,ftsol,pctsrf,masktr,fshtr,hsoltr,tautr,vdeptr,scavtr)
+  USE dimphy
+  USE infotrac, ONLY : nbtr
+  USE indice_sol_mod
+  IMPLICIT NONE
+!======================================================================
+! Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
+! Objet: initialisation des constantes des traceurs
+! id_rn : identificateur du traceur radon
+! id_pb : identificateur du traceur plomb
+!======================================================================
+! Arguments:
+! nbtr.............. nombre de vrais traceurs (sans l'eau)
+! ftsol....input-R-  Temperature du sol (Kelvin)
+! pctsrf...input-R-  Nature de sol (pourcentage de sol)
+! masktr...output-R- Masque reservoir de sol traceur (1 = reservoir)
+! fshtr....output-R- Flux surfacique de production dans le reservoir de sol
+! hsoltr...output-R- Epaisseur equivalente du reservoir de sol
+! tautr....output-R- Constante de decroissance radioactive du traceur
+! vdeptr...output-R- Vitesse de depot sec dans la couche Brownienne
+! scavtr...output-R- Coefficient de lessivage
+!======================================================================
+ 
+  INTEGER, INTENT(IN)                   :: id_rn, id_pb
+  REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf
+  REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol
+  REAL,DIMENSION(klon,nbtr),INTENT(OUT) :: masktr
+  REAL,DIMENSION(klon,nbtr),INTENT(OUT) :: fshtr
+  REAL,DIMENSION(nbtr),INTENT(OUT)      :: hsoltr
+  REAL,DIMENSION(nbtr),INTENT(OUT)      :: tautr
+  REAL,DIMENSION(nbtr),INTENT(OUT)      :: vdeptr
+  REAL,DIMENSION(nbtr),INTENT(OUT)      :: scavtr
+  INTEGER                               :: i, it
+  REAL                                  :: s
+
+  CHARACTER (LEN=20) :: modname='initrrnpb'
+  CHARACTER (LEN=80) :: abort_message
+
+!
+! Radon it = id_rn
+!----------------
+  IF (id_rn /= 0) THEN
+     it = id_rn
+     s = 1.E4             ! Source: atome par m2
+     hsoltr(it) = 0.1     ! Hauteur equivalente du reservoir : 
+                          ! 1 m * porosite 0.1
+     tautr(it) = 4.765E5  ! Decroissance du radon, secondes
+     vdeptr(it) = 0.      ! Pas de depot sec pour le radon
+     scavtr(it) = 0.      ! Pas de lessivage pour le radon
+     
+     WRITE(*,*)'-------------- SOURCE DU RADON ------------------------ '
+     WRITE(*,*)'it = ',it
+     WRITE(*,*)'Source : ', s
+     WRITE(*,*)'Hauteur equivalente du reservoir de sol: ',hsoltr(it) 
+     WRITE(*,*)'Decroissance (s): ', tautr(it)
+     WRITE(*,*)'Vitesse de depot sec: ',vdeptr(it) 
+     WRITE(*,*)'Facteur de lessivage: ',scavtr(it)
+
+     DO i = 1,klon
+        masktr(i,it) = 0.
+        IF ( NINT(pctsrf(i,1)) .EQ. 1 ) masktr(i,it) = 1.
+        fshtr(i,it) = s * masktr(i,it)
+     END DO
+
+  END IF ! id_rn /= 0
+
+!
+! 210Pb it = id_pb
+!----------------
+  IF (id_pb /= 0) THEN
+     it = id_pb
+     s = 0.                ! Pas de source 
+     hsoltr(it) = 10.      ! Hauteur equivalente du reservoir 
+                           ! a partir duquel le depot Brownien a lieu
+     tautr(it) = 1.028E9   ! Decroissance du Pb210, secondes
+     vdeptr(it) = 1.E-3    ! 1 mm/s pour le 210Pb
+     scavtr(it) =  .5      ! Lessivage du Pb210
+     DO i = 1,klon
+        masktr(i,it) = 1.  ! Le depot sec peut avoir lieu partout
+        fshtr(i,it) = s * masktr(i,it)
+     END DO
+     WRITE(*,*)'-------------- SOURCE DU PLOMB ------------------------ '
+     WRITE(*,*)'it = ',it
+     WRITE(*,*)'Source : ', s
+     WRITE(*,*)'Hauteur equivalente du reservoir : ',hsoltr(it) 
+     WRITE(*,*)'Decroissance (s): ', tautr(it)
+     WRITE(*,*)'Vitesse de depot sec: ',vdeptr(it) 
+     WRITE(*,*)'Facteur de lessivage: ',scavtr(it)
+     
+  END IF
+     
+END SUBROUTINE initrrnpb
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/interpolation.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/interpolation.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/interpolation.F90	(revision 17)
@@ -0,0 +1,138 @@
+! $Id$
+module interpolation
+
+  ! From Press et al., 1996, version 2.10a
+  ! B3 Interpolation and Extrapolation
+
+  IMPLICIT NONE 
+
+contains
+
+  pure FUNCTION locate(xx,x)
+
+    REAL, DIMENSION(:), INTENT(IN) :: xx
+    REAL, INTENT(IN) :: x
+    INTEGER  locate
+
+    ! Given an array xx(1:N), and given a value x, returns a value j,
+    ! between 0 and N, such that x is between xx(j) and xx(j + 1). xx
+    ! must be monotonic, either increasing or decreasing. j = 0 or j =
+    ! N is returned to indicate that x is out of range. This
+    ! procedure should not be called with a zero-sized array argument.
+    ! See notes.
+
+    INTEGER  n,jl,jm,ju
+    LOGICAL  ascnd
+
+    !----------------------------
+
+    n=size(xx)
+    ascnd = (xx(n) >= xx(1))
+    ! (True if ascending order of table, false otherwise.)
+    ! Initialize lower and upper limits:
+    jl=0
+    ju=n+1
+    do while (ju-jl > 1)
+       jm=(ju+jl)/2 ! Compute a midpoint,
+       if (ascnd .eqv. (x >= xx(jm))) then
+          jl=jm ! and replace either the lower limit
+       else
+          ju=jm ! or the upper limit, as appropriate.
+       end if
+    end do
+    ! {ju == jl + 1}
+
+    ! {(ascnd .and. xx(jl) <= x < xx(jl+1)) 
+    !  .neqv. 
+    !  (.not. ascnd .and. xx(jl+1) <= x < xx(jl))}
+
+    ! Then set the output, being careful with the endpoints:
+    if (x == xx(1)) then
+       locate=1
+    else if (x == xx(n)) then
+       locate=n-1
+    else
+       locate=jl
+    end if
+
+  END FUNCTION locate
+
+  !***************************
+
+  pure SUBROUTINE hunt(xx,x,jlo)
+
+    ! Given an array xx(1:N ), and given a value x, returns a value
+    ! jlo such that x is between xx(jlo) and xx(jlo+1). xx must be
+    ! monotonic, either increasing or decreasing. jlo = 0 or jlo = N is
+    ! returned to indicate that x is out of range. jlo on input is taken as
+    ! the initial guess for jlo on output.
+    ! Modified so that it uses the information "jlo = 0" on input.
+
+    INTEGER, INTENT(INOUT) :: jlo
+    REAL, INTENT(IN) :: x
+    REAL, DIMENSION(:), INTENT(IN) :: xx
+    INTEGER  n,inc,jhi,jm
+    LOGICAL  ascnd, hunt_up
+
+    !-----------------------------------------------------
+
+    n=size(xx)
+    ascnd = (xx(n) >= xx(1))
+    ! (True if ascending order of table, false otherwise.)
+    if (jlo < 0 .or. jlo > n) then
+       ! Input guess not useful. Go immediately to bisection.
+       jlo=0
+       jhi=n+1
+    else
+       inc=1 ! Set the hunting increment.
+       if (jlo == 0) then
+          hunt_up = .true.
+       else
+          hunt_up = x >= xx(jlo) .eqv. ascnd
+       end if
+       if (hunt_up) then ! Hunt up:
+          do
+             jhi=jlo+inc
+             if (jhi > n) then ! Done hunting, since off end of table.
+                jhi=n+1
+                exit
+             else
+                if (x < xx(jhi) .eqv. ascnd) exit
+                jlo=jhi ! Not done hunting,
+                inc=inc+inc ! so double the increment
+             end if
+          end do ! and try again.
+       else ! Hunt down:
+          jhi=jlo
+          do
+             jlo=jhi-inc
+             if (jlo < 1) then ! Done hunting, since off end of table.
+                jlo=0
+                exit
+             else
+                if (x >= xx(jlo) .eqv. ascnd) exit
+                jhi=jlo ! Not done hunting,
+                inc=inc+inc ! so double the increment
+             end if
+          end do ! and try again.
+       end if
+    end if ! Done hunting, value bracketed.
+
+    do ! Hunt is done, so begin the final bisection phase:
+       if (jhi-jlo <= 1) then
+          if (x == xx(n)) jlo=n-1
+          if (x == xx(1)) jlo=1
+          exit
+       else
+          jm=(jhi+jlo)/2
+          if (x >= xx(jm) .eqv. ascnd) then
+             jlo=jm
+          else
+             jhi=jm
+          end if
+       end if
+    end do
+
+  END SUBROUTINE hunt
+
+end module interpolation
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ioipsl_errioipsl.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ioipsl_errioipsl.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ioipsl_errioipsl.F90	(revision 17)
@@ -0,0 +1,219 @@
+!
+! $Id$
+!
+! Module/Routines extracted from IOIPSL v2_1_8
+!
+MODULE ioipsl_errioipsl
+!-
+!$Id: errioipsl.f90 386 2008-09-04 08:38:48Z bellier $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+IMPLICIT NONE
+!-
+PRIVATE
+!-
+PUBLIC :: ipslnlf, ipslerr, ipslerr_act, ipslerr_inq, histerr, ipsldbg
+!-
+  INTEGER :: n_l=6, ilv_cur=0, ilv_max=0
+  LOGICAL :: ioipsl_debug=.FALSE., lact_mode=.TRUE.
+!-
+!===
+CONTAINS
+!===
+SUBROUTINE ipslnlf (new_number,old_number)
+!!--------------------------------------------------------------------
+!! The "ipslnlf" routine allows to know and modify
+!! the current logical number for the messages.
+!!
+!! SUBROUTINE ipslnlf (new_number,old_number)
+!!
+!! Optional INPUT argument
+!!
+!! (I) new_number : new logical number of the file
+!!
+!! Optional OUTPUT argument
+!!
+!! (I) old_number : current logical number of the file
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,OPTIONAL,INTENT(IN)  :: new_number
+  INTEGER,OPTIONAL,INTENT(OUT) :: old_number
+!---------------------------------------------------------------------
+  IF (PRESENT(old_number)) THEN
+    old_number = n_l
+  ENDIF
+  IF (PRESENT(new_number)) THEN
+    n_l = new_number
+  ENDIF
+!---------------------
+END SUBROUTINE ipslnlf
+!===
+SUBROUTINE ipslerr (plev,pcname,pstr1,pstr2,pstr3)
+!---------------------------------------------------------------------
+!! The "ipslerr" routine
+!! allows to handle the messages to the user.
+!!
+!! INPUT
+!!
+!! plev   : Category of message to be reported to the user
+!!          1 = Note to the user
+!!          2 = Warning to the user
+!!          3 = Fatal error
+!! pcname : Name of subroutine which has called ipslerr
+!! pstr1   
+!! pstr2  : Strings containing the explanations to the user
+!! pstr3
+!---------------------------------------------------------------------
+   IMPLICIT NONE
+!-
+   INTEGER :: plev
+   CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3
+!-
+   CHARACTER(LEN=30),DIMENSION(3) :: pemsg = &
+  &  (/ "NOTE TO THE USER FROM ROUTINE ", &
+  &     "WARNING FROM ROUTINE          ", &
+  &     "FATAL ERROR FROM ROUTINE      " /)
+!---------------------------------------------------------------------
+   IF ( (plev >= 1).AND.(plev <= 3) ) THEN
+     ilv_cur = plev
+     ilv_max = MAX(ilv_max,plev)
+     WRITE(n_l,'(/,A," ",A)') TRIM(pemsg(plev)),TRIM(pcname)
+     WRITE(n_l,'(3(" --> ",A,/))') TRIM(pstr1),TRIM(pstr2),TRIM(pstr3)
+   ENDIF
+   IF ( (plev == 3).AND.lact_mode) THEN
+     STOP 'Fatal error from IOIPSL. See stdout for more details'
+   ENDIF
+!---------------------
+END SUBROUTINE ipslerr
+!===
+SUBROUTINE ipslerr_act (new_mode,old_mode)
+!!--------------------------------------------------------------------
+!! The "ipslerr_act" routine allows to know and modify
+!! the current "action mode" for the error messages,
+!! and reinitialize the error level values.
+!!
+!! SUBROUTINE ipslerr_act (new_mode,old_mode)
+!!
+!! Optional INPUT argument
+!!
+!! (I) new_mode : new error action mode
+!!                .TRUE.  -> STOP     in case of fatal error
+!!                .FALSE. -> CONTINUE in case of fatal error
+!!
+!! Optional OUTPUT argument
+!!
+!! (I) old_mode : current error action mode
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  LOGICAL,OPTIONAL,INTENT(IN)  :: new_mode
+  LOGICAL,OPTIONAL,INTENT(OUT) :: old_mode
+!---------------------------------------------------------------------
+  IF (PRESENT(old_mode)) THEN
+    old_mode = lact_mode
+  ENDIF
+  IF (PRESENT(new_mode)) THEN
+    lact_mode = new_mode
+  ENDIF
+  ilv_cur = 0
+  ilv_max = 0
+!-------------------------
+END SUBROUTINE ipslerr_act
+!===
+SUBROUTINE ipslerr_inq (current_level,maximum_level)
+!!--------------------------------------------------------------------
+!! The "ipslerr_inq" routine allows to know
+!! the current level of the error messages
+!! and the maximum level encountered since the
+!! last call to "ipslerr_act".
+!!
+!! SUBROUTINE ipslerr_inq (current_level,maximum_level)
+!!
+!! Optional OUTPUT argument
+!!
+!! (I) current_level : current error level
+!! (I) maximum_level : maximum error level
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,OPTIONAL,INTENT(OUT) :: current_level,maximum_level
+!---------------------------------------------------------------------
+  IF (PRESENT(current_level)) THEN
+    current_level = ilv_cur
+  ENDIF
+  IF (PRESENT(maximum_level)) THEN
+    maximum_level = ilv_max
+  ENDIF
+!-------------------------
+END SUBROUTINE ipslerr_inq
+!===
+SUBROUTINE histerr (plev,pcname,pstr1,pstr2,pstr3)
+!---------------------------------------------------------------------
+!- INPUT
+!- plev   : Category of message to be reported to the user
+!-          1 = Note to the user
+!-          2 = Warning to the user
+!-          3 = Fatal error
+!- pcname : Name of subroutine which has called histerr
+!- pstr1   
+!- pstr2  : String containing the explanations to the user
+!- pstr3
+!---------------------------------------------------------------------
+   IMPLICIT NONE
+!-
+   INTEGER :: plev
+   CHARACTER(LEN=*) :: pcname,pstr1,pstr2,pstr3
+!-
+   CHARACTER(LEN=30),DIMENSION(3) :: pemsg = &
+  &  (/ "NOTE TO THE USER FROM ROUTINE ", &
+  &     "WARNING FROM ROUTINE          ", &
+  &     "FATAL ERROR FROM ROUTINE      " /)
+!---------------------------------------------------------------------
+   IF ( (plev >= 1).AND.(plev <= 3) ) THEN
+     WRITE(*,'("     ")')
+     WRITE(*,'(A," ",A)') TRIM(pemsg(plev)),TRIM(pcname)
+     WRITE(*,'(" --> ",A)') pstr1
+     WRITE(*,'(" --> ",A)') pstr2
+     WRITE(*,'(" --> ",A)') pstr3
+   ENDIF
+   IF (plev == 3) THEN
+     STOP 'Fatal error from IOIPSL. See stdout for more details'
+   ENDIF
+!---------------------
+END SUBROUTINE histerr
+!===
+SUBROUTINE ipsldbg (new_status,old_status)
+!!--------------------------------------------------------------------
+!! The "ipsldbg" routine
+!! allows to activate or deactivate the debug,
+!! and to know the current status of the debug.
+!!
+!! SUBROUTINE ipsldbg (new_status,old_status)
+!!
+!! Optional INPUT argument
+!!
+!! (L) new_status : new status of the debug
+!!
+!! Optional OUTPUT argument
+!!
+!! (L) old_status : current status of the debug
+!!--------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  LOGICAL,OPTIONAL,INTENT(IN)  :: new_status
+  LOGICAL,OPTIONAL,INTENT(OUT) :: old_status
+!---------------------------------------------------------------------
+  IF (PRESENT(old_status)) THEN
+    old_status = ioipsl_debug
+  ENDIF
+  IF (PRESENT(new_status)) THEN
+    ioipsl_debug = new_status
+  ENDIF
+!---------------------
+END SUBROUTINE ipsldbg
+!===
+!-------------------
+END MODULE ioipsl_errioipsl
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ioipsl_getincom.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ioipsl_getincom.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ioipsl_getincom.F90	(revision 17)
@@ -0,0 +1,1980 @@
+!
+! $Id$
+!
+! Module/Routines extracted from IOIPSL v2_1_8
+!
+MODULE ioipsl_getincom
+!-
+!$Id: getincom.f90 536 2009-01-30 11:46:27Z bellier $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+USE ioipsl_errioipsl, ONLY : ipslerr
+USE ioipsl_stringop, &
+ &   ONLY : nocomma,cmpblank,strlowercase
+!-
+IMPLICIT NONE
+!-
+PRIVATE
+PUBLIC :: getin, getin_dump
+!-
+INTERFACE getin
+!!--------------------------------------------------------------------
+!! The "getin" routines get a variable.
+!! We first check if we find it in the database
+!! and if not we get it from the run.def file.
+!!
+!! SUBROUTINE getin (target,ret_val)
+!!
+!! INPUT
+!!
+!! (C) target : Name of the variable
+!!
+!! OUTPUT
+!!
+!! (I/R/C/L) ret_val : scalar, vector or matrix that will contain
+!!                     that will contain the (standard)
+!!                     integer/real/character/logical values
+!!--------------------------------------------------------------------
+  MODULE PROCEDURE getinrs, getinr1d, getinr2d, &
+ &                 getinis, getini1d, getini2d, &
+ &                 getincs, getinc1d, getinc2d, &
+ &                 getinls, getinl1d, getinl2d
+END INTERFACE
+!-
+!!--------------------------------------------------------------------
+!! The "getin_dump" routine will dump the content of the database
+!! into a file which has the same format as the run.def file.
+!! The idea is that the user can see which parameters were used
+!! and re-use the file for another run.
+!!
+!!  SUBROUTINE getin_dump (fileprefix)
+!!
+!! OPTIONAL INPUT argument
+!!
+!! (C) fileprefix : allows the user to change the name of the file
+!!                  in which the data will be archived
+!!--------------------------------------------------------------------
+!-
+  INTEGER,PARAMETER :: max_files=100
+  CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist
+  INTEGER,SAVE      :: nbfiles
+!-
+  INTEGER,PARAMETER :: i_txtslab=1000,l_n=30
+  INTEGER,SAVE :: nb_lines,i_txtsize=0
+  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: fichier
+  CHARACTER(LEN=l_n),SAVE,ALLOCATABLE,DIMENSION(:) :: targetlist
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: fromfile,compline
+!-
+  INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15
+  CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)'
+!-
+! The data base of parameters
+!-
+  INTEGER,PARAMETER :: memslabs=200
+  INTEGER,PARAMETER :: compress_lim=20
+!-
+  INTEGER,SAVE :: nb_keys=0
+  INTEGER,SAVE :: keymemsize=0
+!-
+! keystr definition
+! name of a key
+!-
+! keystatus definition
+! keystatus = 1 : Value comes from run.def
+! keystatus = 2 : Default value is used
+! keystatus = 3 : Some vector elements were taken from default
+!-
+! keytype definition
+! keytype = 1 : Integer
+! keytype = 2 : Real
+! keytype = 3 : Character
+! keytype = 4 : Logical
+!-
+  INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4
+!-
+! Allow compression for keys (only for integer and real)
+! keycompress < 0 : not compressed
+! keycompress > 0 : number of repeat of the value
+!-
+TYPE :: t_key
+  CHARACTER(LEN=l_n) :: keystr
+  INTEGER :: keystatus, keytype, keycompress, &
+ &           keyfromfile, keymemstart, keymemlen
+END TYPE t_key
+!-
+  TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab
+!-
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: i_mem
+  INTEGER,SAVE :: i_memsize=0, i_mempos=0
+  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: r_mem
+  INTEGER,SAVE :: r_memsize=0, r_mempos=0
+  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: c_mem
+  INTEGER,SAVE :: c_memsize=0, c_mempos=0
+  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: l_mem
+  INTEGER,SAVE :: l_memsize=0, l_mempos=0
+!-
+CONTAINS
+!-
+!=== INTEGER INTERFACE
+!-
+SUBROUTINE getinis (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER :: ret_val
+!-
+  INTEGER,DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  tmp_ret_val(1) = ret_val
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,1,i_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,target,i_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getinis
+!===
+SUBROUTINE getini1d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER,DIMENSION(:) :: ret_val
+!-
+  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,i_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getini1d
+!===
+SUBROUTINE getini2d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER,DIMENSION(:,:) :: ret_val
+!-
+  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,i_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getini2d
+!-
+!=== REAL INTERFACE
+!-
+SUBROUTINE getinrs (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  REAL :: ret_val
+!-
+  REAL,DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  tmp_ret_val(1) = ret_val
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,1,r_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,target,r_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getinrs
+!===
+SUBROUTINE getinr1d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  REAL,DIMENSION(:) :: ret_val
+!-
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,r_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getinr1d
+!===
+SUBROUTINE getinr2d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  REAL,DIMENSION(:,:) :: ret_val
+!-
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,r_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getinr2d
+!-
+!=== CHARACTER INTERFACE
+!-
+SUBROUTINE getincs (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  CHARACTER(LEN=*) :: ret_val
+!-
+  CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  tmp_ret_val(1) = ret_val
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,1,c_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,target,c_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getincs
+!===
+SUBROUTINE getinc1d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  CHARACTER(LEN=*),DIMENSION(:) :: ret_val
+!-
+  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,c_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getinc1d
+!===
+SUBROUTINE getinc2d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val
+!-
+  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,c_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getinc2d
+!-
+!=== LOGICAL INTERFACE
+!-
+SUBROUTINE getinls (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  LOGICAL :: ret_val
+!-
+  LOGICAL,DIMENSION(1) :: tmp_ret_val
+  INTEGER :: pos,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  tmp_ret_val(1) = ret_val
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,1,l_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,1,target,l_val=tmp_ret_val)
+  ENDIF
+  ret_val = tmp_ret_val(1)
+!---------------------
+END SUBROUTINE getinls
+!===
+SUBROUTINE getinl1d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  LOGICAL,DIMENSION(:) :: ret_val
+!-
+  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,status=0,fileorig
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,l_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val)
+  ENDIF
+  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
+!----------------------
+END SUBROUTINE getinl1d
+!===
+SUBROUTINE getinl2d (target,ret_val)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  LOGICAL,DIMENSION(:,:) :: ret_val
+!-
+  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
+  INTEGER,SAVE :: tmp_ret_size = 0
+  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
+  INTEGER :: jl,jj,ji
+!---------------------------------------------------------------------
+!-
+! Do we have this target in our database ?
+!-
+  CALL get_findkey (1,target,pos)
+!-
+  size_of_in = SIZE(ret_val)
+  size_1 = SIZE(ret_val,1)
+  size_2 = SIZE(ret_val,2)
+  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
+    ALLOCATE (tmp_ret_val(size_of_in))
+  ELSE IF (size_of_in > tmp_ret_size) THEN
+    DEALLOCATE (tmp_ret_val)
+    ALLOCATE (tmp_ret_val(size_of_in))
+    tmp_ret_size = size_of_in
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      tmp_ret_val(jl) = ret_val(ji,jj)
+    ENDDO
+  ENDDO
+!-
+  IF (pos < 0) THEN
+!-- Get the information out of the file
+    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
+!-- Put the data into the database
+    CALL get_wdb &
+ &   (target,status,fileorig,size_of_in,l_val=tmp_ret_val)
+  ELSE
+!-- Get the value out of the database
+    CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val)
+  ENDIF
+!-
+  jl=0
+  DO jj=1,size_2
+    DO ji=1,size_1
+      jl=jl+1
+      ret_val(ji,jj) = tmp_ret_val(jl)
+    ENDDO
+  ENDDO
+!----------------------
+END SUBROUTINE getinl2d
+!-
+!=== Generic file/database INTERFACE
+!-
+SUBROUTINE get_fil (target,status,fileorig,i_val,r_val,c_val,l_val)
+!---------------------------------------------------------------------
+!- Subroutine that will extract from the file the values
+!- attributed to the keyword target
+!-
+!- (C) target    : target for which we will look in the file
+!- (I) status    : tells us from where we obtained the data
+!- (I) fileorig  : index of the file from which the key comes
+!- (I) i_val(:)  : INTEGER(nb_to_ret)   values
+!- (R) r_val(:)  : REAL(nb_to_ret)      values
+!- (L) l_val(:)  : LOGICAL(nb_to_ret)   values
+!- (C) c_val(:)  : CHARACTER(nb_to_ret) values
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER,INTENT(OUT) :: status,fileorig
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
+  REAL,DIMENSION(:),OPTIONAL             :: r_val
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
+!-
+  INTEGER :: k_typ,nb_to_ret,it,pos,len_str,status_cnt,io_err
+  CHARACTER(LEN=n_d_fmt)  :: cnt
+  CHARACTER(LEN=80) :: str_READ,str_READ_lower
+  CHARACTER(LEN=9)  :: c_vtyp
+  LOGICAL,DIMENSION(:),ALLOCATABLE :: found
+  LOGICAL :: def_beha,compressed
+  CHARACTER(LEN=10) :: c_fmt
+  INTEGER :: i_cmpval
+  REAL    :: r_cmpval
+  INTEGER :: ipos_tr,ipos_fl
+!---------------------------------------------------------------------
+!-
+! Get the type of the argument
+  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
+  SELECT CASE (k_typ)
+  CASE(k_i)
+    nb_to_ret = SIZE(i_val)
+  CASE(k_r)
+    nb_to_ret = SIZE(r_val)
+  CASE(k_c)
+    nb_to_ret = SIZE(c_val)
+  CASE(k_l)
+    nb_to_ret = SIZE(l_val)
+  CASE DEFAULT
+    CALL ipslerr (3,'get_fil', &
+ &   'Internal error','Unknown type of data',' ')
+  END SELECT
+!-
+! Read the file(s)
+  CALL getin_read
+!-
+! Allocate and initialize the memory we need
+  ALLOCATE(found(nb_to_ret))
+  found(:) = .FALSE.
+!-
+! See what we find in the files read
+  DO it=1,nb_to_ret
+!---
+!-- First try the target as it is
+    CALL get_findkey (2,target,pos)
+!---
+!-- Another try
+!---
+    IF (pos < 0) THEN
+      WRITE(UNIT=cnt,FMT=c_i_fmt) it
+      CALL get_findkey (2,TRIM(target)//'__'//cnt,pos)
+    ENDIF
+!---
+!-- We dont know from which file the target could come.
+!-- Thus by default we attribute it to the first file :
+    fileorig = 1
+!---
+    IF (pos > 0) THEN
+!-----
+      found(it) = .TRUE.
+      fileorig = fromfile(pos)
+!-----
+!---- DECODE
+!-----
+      str_READ = ADJUSTL(fichier(pos))
+      str_READ_lower = str_READ
+      CALL strlowercase (str_READ_lower)
+!-----
+      IF (    (TRIM(str_READ_lower) == 'def')     &
+ &        .OR.(TRIM(str_READ_lower) == 'default') ) THEN
+        def_beha = .TRUE.
+      ELSE
+        def_beha = .FALSE.
+        len_str = LEN_TRIM(str_READ)
+        io_err = 0
+        SELECT CASE (k_typ)
+        CASE(k_i)
+          WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str
+          READ (UNIT=str_READ(1:len_str), &
+ &              FMT=c_fmt,IOSTAT=io_err) i_val(it)
+        CASE(k_r)
+          READ (UNIT=str_READ(1:len_str), &
+ &              FMT=*,IOSTAT=io_err) r_val(it)
+        CASE(k_c)
+          c_val(it) = str_READ(1:len_str)
+        CASE(k_l)
+          ipos_tr = -1
+          ipos_fl = -1
+          ipos_tr = MAX(INDEX(str_READ_lower,'tru'), &
+ &                      INDEX(str_READ_lower,'y'))
+          ipos_fl = MAX(INDEX(str_READ_lower,'fal'), &
+ &                      INDEX(str_READ_lower,'n'))
+          IF (ipos_tr > 0) THEN
+            l_val(it) = .TRUE.
+          ELSE IF (ipos_fl > 0) THEN
+            l_val(it) = .FALSE.
+          ELSE
+            io_err = 100
+          ENDIF
+        END SELECT
+        IF (io_err /= 0) THEN
+          CALL ipslerr (3,'get_fil', &
+ &         'Target '//TRIM(target), &
+ &         'is not of '//TRIM(c_vtyp)//' type',' ')
+        ENDIF
+      ENDIF
+!-----
+      IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
+!-------
+!------ Is this the value of a compressed field ?
+        compressed = (compline(pos) > 0)
+        IF (compressed) THEN
+          IF (compline(pos) /= nb_to_ret) THEN
+            CALL ipslerr (2,'get_fil', &
+ &           'For key '//TRIM(target)//' we have a compressed field', &
+ &           'which does not have the right size.', &
+ &           'We will try to fix that.')
+          ENDIF
+          IF      (k_typ == k_i) THEN
+            i_cmpval = i_val(it)
+          ELSE IF (k_typ == k_r) THEN
+            r_cmpval = r_val(it)
+          ENDIF
+        ENDIF
+      ENDIF
+    ELSE
+      found(it) = .FALSE.
+      def_beha = .FALSE.
+      compressed = .FALSE.
+    ENDIF
+  ENDDO
+!-
+  IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
+!---
+!-- If this is a compressed field then we will uncompress it
+    IF (compressed) THEN
+      DO it=1,nb_to_ret
+        IF (.NOT.found(it)) THEN
+          IF      (k_typ == k_i) THEN
+            i_val(it) = i_cmpval
+          ELSE IF (k_typ == k_r) THEN
+          ENDIF
+          found(it) = .TRUE.
+        ENDIF
+      ENDDO
+    ENDIF
+  ENDIF
+!-
+! Now we set the status for what we found
+  IF (def_beha) THEN
+    status = 2
+    WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(target)
+  ELSE
+    status_cnt = 0
+    DO it=1,nb_to_ret
+      IF (.NOT.found(it)) THEN
+        status_cnt = status_cnt+1
+        IF      (status_cnt <= max_msgs) THEN
+          WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', &
+ &               ADVANCE='NO') TRIM(target)
+          IF (nb_to_ret > 1) THEN
+            WRITE (UNIT=*,FMT='("__")',ADVANCE='NO')
+            WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it
+          ENDIF
+          SELECT CASE (k_typ)
+          CASE(k_i)
+            WRITE (UNIT=*,FMT=*) "=",i_val(it)
+          CASE(k_r)
+            WRITE (UNIT=*,FMT=*) "=",r_val(it)
+          CASE(k_c)
+            WRITE (UNIT=*,FMT=*) "=",c_val(it)
+          CASE(k_l)
+            WRITE (UNIT=*,FMT=*) "=",l_val(it)
+          END SELECT
+        ELSE IF (status_cnt == max_msgs+1) THEN
+          WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)')
+        ENDIF
+      ENDIF
+    ENDDO
+!---
+    IF (status_cnt == 0) THEN
+      status = 1
+    ELSE IF (status_cnt == nb_to_ret) THEN
+      status = 2
+    ELSE
+      status = 3
+    ENDIF
+  ENDIF
+! Deallocate the memory
+  DEALLOCATE(found)
+!---------------------
+END SUBROUTINE get_fil
+!===
+SUBROUTINE get_rdb (pos,size_of_in,target,i_val,r_val,c_val,l_val)
+!---------------------------------------------------------------------
+!- Read the required variable in the database
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: pos,size_of_in
+  CHARACTER(LEN=*) :: target
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
+  REAL,DIMENSION(:),OPTIONAL             :: r_val
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
+!-
+  INTEGER :: k_typ,k_beg,k_end
+  CHARACTER(LEN=9) :: c_vtyp
+!---------------------------------------------------------------------
+!-
+! Get the type of the argument
+  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
+  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
+ &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
+    CALL ipslerr (3,'get_rdb', &
+ &   'Internal error','Unknown type of data',' ')
+  ENDIF
+!-
+  IF (key_tab(pos)%keytype /= k_typ) THEN
+    CALL ipslerr (3,'get_rdb', &
+ &   'Wrong data type for keyword '//TRIM(target), &
+ &   '(NOT '//TRIM(c_vtyp)//')',' ')
+  ENDIF
+!-
+  IF (key_tab(pos)%keycompress > 0) THEN
+    IF (    (key_tab(pos)%keycompress /= size_of_in) &
+ &      .OR.(key_tab(pos)%keymemlen /= 1) ) THEN
+      CALL ipslerr (3,'get_rdb', &
+ &     'Wrong compression length','for keyword '//TRIM(target),' ')
+    ELSE
+      SELECT CASE (k_typ)
+      CASE(k_i)
+        i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart)
+      CASE(k_r)
+        r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart)
+      END SELECT
+    ENDIF
+  ELSE
+    IF (key_tab(pos)%keymemlen /= size_of_in) THEN
+      CALL ipslerr (3,'get_rdb', &
+ &     'Wrong array length','for keyword '//TRIM(target),' ')
+    ELSE
+      k_beg = key_tab(pos)%keymemstart
+      k_end = k_beg+key_tab(pos)%keymemlen-1
+      SELECT CASE (k_typ)
+      CASE(k_i)
+        i_val(1:size_of_in) = i_mem(k_beg:k_end)
+      CASE(k_r)
+        r_val(1:size_of_in) = r_mem(k_beg:k_end)
+      CASE(k_c)
+        c_val(1:size_of_in) = c_mem(k_beg:k_end)
+      CASE(k_l)
+        l_val(1:size_of_in) = l_mem(k_beg:k_end)
+      END SELECT
+    ENDIF
+  ENDIF
+!---------------------
+END SUBROUTINE get_rdb
+!===
+SUBROUTINE get_wdb &
+ &  (target,status,fileorig,size_of_in, &
+ &   i_val,r_val,c_val,l_val)
+!---------------------------------------------------------------------
+!- Write data into the data base
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: target
+  INTEGER :: status,fileorig,size_of_in
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
+  REAL,DIMENSION(:),OPTIONAL             :: r_val
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
+!-
+  INTEGER :: k_typ
+  CHARACTER(LEN=9) :: c_vtyp
+  INTEGER :: k_mempos,k_memsize,k_beg,k_end
+  LOGICAL :: l_cmp
+!---------------------------------------------------------------------
+!-
+! Get the type of the argument
+  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
+  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
+ &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
+    CALL ipslerr (3,'get_wdb', &
+ &   'Internal error','Unknown type of data',' ')
+  ENDIF
+!-
+! First check if we have sufficiant space for the new key
+  IF (nb_keys+1 > keymemsize) THEN
+    CALL getin_allockeys ()
+  ENDIF
+!-
+  SELECT CASE (k_typ)
+  CASE(k_i)
+    k_mempos = i_mempos; k_memsize = i_memsize;
+    l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) &
+ &         .AND.(size_of_in > compress_lim)
+  CASE(k_r)
+    k_mempos = r_mempos; k_memsize = r_memsize;
+    l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) &
+ &         .AND.(size_of_in > compress_lim)
+  CASE(k_c)
+    k_mempos = c_mempos; k_memsize = c_memsize;
+    l_cmp = .FALSE.
+  CASE(k_l)
+    k_mempos = l_mempos; k_memsize = l_memsize;
+    l_cmp = .FALSE.
+  END SELECT
+!-
+! Fill out the items of the data base
+  nb_keys = nb_keys+1
+  key_tab(nb_keys)%keystr = target(1:MIN(LEN_TRIM(target),l_n))
+  key_tab(nb_keys)%keystatus = status
+  key_tab(nb_keys)%keytype = k_typ
+  key_tab(nb_keys)%keyfromfile = fileorig
+  key_tab(nb_keys)%keymemstart = k_mempos+1
+  IF (l_cmp) THEN
+    key_tab(nb_keys)%keycompress = size_of_in
+    key_tab(nb_keys)%keymemlen = 1
+  ELSE
+    key_tab(nb_keys)%keycompress = -1
+    key_tab(nb_keys)%keymemlen = size_of_in
+  ENDIF
+!-
+! Before writing the actual size lets see if we have the space
+  IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen &
+ &    > k_memsize) THEN
+    CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen)
+  ENDIF
+!-
+  k_beg = key_tab(nb_keys)%keymemstart
+  k_end = k_beg+key_tab(nb_keys)%keymemlen-1
+  SELECT CASE (k_typ)
+  CASE(k_i)
+    i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen)
+    i_mempos = k_end
+  CASE(k_r)
+    r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen)
+    r_mempos = k_end
+  CASE(k_c)
+    c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen)
+    c_mempos = k_end
+  CASE(k_l)
+    l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen)
+    l_mempos = k_end
+  END SELECT
+!---------------------
+END SUBROUTINE get_wdb
+!-
+!===
+!-
+SUBROUTINE getin_read
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,SAVE :: allread=0
+  INTEGER,SAVE :: current
+!---------------------------------------------------------------------
+  IF (allread == 0) THEN
+!-- Allocate a first set of memory.
+    CALL getin_alloctxt ()
+    CALL getin_allockeys ()
+    CALL getin_allocmem (k_i,0)
+    CALL getin_allocmem (k_r,0)
+    CALL getin_allocmem (k_c,0)
+    CALL getin_allocmem (k_l,0)
+!-- Start with reading the files
+    nbfiles = 1
+    filelist(1) = 'run.def'
+    current = 1
+!--
+    DO WHILE (current <= nbfiles)
+      CALL getin_readdef (current)
+      current = current+1
+    ENDDO
+    allread = 1
+    CALL getin_checkcohe ()
+  ENDIF
+!------------------------
+END SUBROUTINE getin_read
+!-
+!===
+!-
+  SUBROUTINE getin_readdef(current)
+!---------------------------------------------------------------------
+!- This subroutine will read the files and only keep the
+!- the relevant information. The information is kept as it
+!- found in the file. The data will be analysed later.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: current
+!-
+  CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str
+  CHARACTER(LEN=n_d_fmt) :: cnt
+  CHARACTER(LEN=10) :: c_fmt
+  INTEGER :: nb_lastkey
+!-
+  INTEGER :: eof,ptn,len_str,i,it,iund,io_err
+  LOGICAL :: check = .FALSE.
+!---------------------------------------------------------------------
+  eof = 0
+  ptn = 1
+  nb_lastkey = 0
+!-
+  IF (check) THEN
+    WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current))
+  ENDIF
+!-
+  OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err)
+  IF (io_err /= 0) THEN
+    CALL ipslerr (2,'getin_readdef', &
+ &  'Could not open file '//TRIM(filelist(current)),' ',' ')
+    RETURN
+  ENDIF
+!-
+  DO WHILE (eof /= 1)
+!---
+    CALL getin_skipafew (22,READ_str,eof,nb_lastkey)
+    len_str = LEN_TRIM(READ_str)
+    ptn = INDEX(READ_str,'=')
+!---
+    IF (ptn > 0) THEN
+!---- Get the target
+      key_str = TRIM(ADJUSTL(READ_str(1:ptn-1)))
+!---- Make sure that a vector keyword has the right length
+      iund = INDEX(key_str,'__')
+      IF (iund > 0) THEN
+        WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') &
+ &        LEN_TRIM(key_str)-iund-1
+        READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), &
+ &           FMT=c_fmt,IOSTAT=io_err) it
+        IF ( (io_err == 0).AND.(it > 0) ) THEN
+          WRITE(UNIT=cnt,FMT=c_i_fmt) it
+          key_str = key_str(1:iund+1)//cnt
+        ELSE
+          CALL ipslerr (3,'getin_readdef', &
+ &         'A very strange key has just been found :', &
+ &         TRIM(key_str),' ')
+        ENDIF
+      ENDIF
+!---- Prepare the content
+      NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str)))
+      CALL nocomma (NEW_str)
+      CALL cmpblank (NEW_str)
+      NEW_str  = TRIM(ADJUSTL(NEW_str))
+      IF (check) THEN
+        WRITE(*,*) &
+ &        '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str)
+      ENDIF
+!---- Decypher the content of NEW_str
+!-
+!---- This has to be a new key word, thus :
+      nb_lastkey = 0
+!----
+      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
+!----
+    ELSE IF (len_str > 0) THEN
+!---- Prepare the key if we have an old one to which
+!---- we will add the line just read
+      IF (nb_lastkey > 0) THEN
+        iund =  INDEX(last_key,'__')
+        IF (iund > 0) THEN
+!-------- We only continue a keyword, thus it is easy
+          key_str = last_key(1:iund-1)
+        ELSE
+          IF (nb_lastkey /= 1) THEN
+            CALL ipslerr (3,'getin_readdef', &
+ &           'We can not have a scalar keyword', &
+ &           'and a vector content',' ')
+          ENDIF
+!-------- The last keyword needs to be transformed into a vector.
+          WRITE(UNIT=cnt,FMT=c_i_fmt) 1
+          targetlist(nb_lines) = &
+ &         last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt
+          key_str = last_key(1:LEN_TRIM(last_key))
+        ENDIF
+      ENDIF
+!---- Prepare the content
+      NEW_str = TRIM(ADJUSTL(READ_str(1:len_str)))
+      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
+    ELSE
+!---- If we have an empty line then the keyword finishes
+      nb_lastkey = 0
+      IF (check) THEN
+        WRITE(*,*) 'getin_readdef : Have found an emtpy line '
+      ENDIF
+    ENDIF
+  ENDDO
+!-
+  CLOSE(UNIT=22)
+!-
+  IF (check) THEN
+    OPEN (UNIT=22,file='run.def.test')
+    DO i=1,nb_lines
+      WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i)
+    ENDDO
+    CLOSE(UNIT=22)
+  ENDIF
+!---------------------------
+END SUBROUTINE getin_readdef
+!-
+!===
+!-
+SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey)
+!---------------------------------------------------------------------
+!- This subroutine is going to decypher the line.
+!- It essentialy checks how many items are included and
+!- it they can be attached to a key.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+! ARGUMENTS
+!-
+  INTEGER :: current,nb_lastkey
+  CHARACTER(LEN=*) :: key_str,NEW_str,last_key
+!-
+! LOCAL
+!-
+  INTEGER :: len_str,blk,nbve,starpos
+  CHARACTER(LEN=100) :: tmp_str,new_key,mult
+  CHARACTER(LEN=n_d_fmt) :: cnt
+  CHARACTER(LEN=10) :: c_fmt
+!---------------------------------------------------------------------
+  len_str = LEN_TRIM(NEW_str)
+  blk = INDEX(NEW_str(1:len_str),' ')
+  tmp_str = NEW_str(1:len_str)
+!-
+! If the key is a new file then we take it up. Else
+! we save the line and go on.
+!-
+  IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN
+    DO WHILE (blk > 0)
+      IF (nbfiles+1 > max_files) THEN
+        CALL ipslerr (3,'getin_decrypt', &
+ &       'Too many files to include',' ',' ')
+      ENDIF
+!-----
+      nbfiles = nbfiles+1
+      filelist(nbfiles) = tmp_str(1:blk)
+!-----
+      tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
+      blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ')
+    ENDDO
+!---
+    IF (nbfiles+1 > max_files) THEN
+      CALL ipslerr (3,'getin_decrypt', &
+ &     'Too many files to include',' ',' ')
+    ENDIF
+!---
+    nbfiles =  nbfiles+1
+    filelist(nbfiles) = TRIM(ADJUSTL(tmp_str))
+!---
+    last_key = 'INCLUDEDEF'
+    nb_lastkey = 1
+  ELSE
+!-
+!-- We are working on a new line of input
+!-
+    IF (nb_lines+1 > i_txtsize) THEN
+      CALL getin_alloctxt ()
+    ENDIF
+    nb_lines = nb_lines+1
+!-
+!-- First we solve the issue of conpressed information. Once
+!-- this is done all line can be handled in the same way.
+!-
+    starpos = INDEX(NEW_str(1:len_str),'*')
+    IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') &
+ &                    .AND.(tmp_str(1:1) /= "'") ) THEN
+!-----
+      IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN
+        CALL ipslerr (3,'getin_decrypt', &
+ &       'We can not have a compressed field of values', &
+ &       'in a vector notation (TARGET__n).', &
+ &       'The key at fault : '//TRIM(key_str))
+      ENDIF
+!-
+!---- Read the multiplied
+!-
+      mult = TRIM(ADJUSTL(NEW_str(1:starpos-1)))
+!---- Construct the new string and its parameters
+      NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str)))
+      len_str = LEN_TRIM(NEW_str)
+      blk = INDEX(NEW_str(1:len_str),' ')
+      IF (blk > 1) THEN
+        CALL ipslerr (2,'getin_decrypt', &
+ &       'This is a strange behavior','you could report',' ')
+      ENDIF
+      WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult)
+      READ(UNIT=mult,FMT=c_fmt) compline(nb_lines)
+!---
+    ELSE
+      compline(nb_lines) = -1
+    ENDIF
+!-
+!-- If there is no space wthin the line then the target is a scalar
+!-- or the element of a properly written vector.
+!-- (ie of the type TARGET__00001)
+!-
+    IF (    (blk <= 1) &
+ &      .OR.(tmp_str(1:1) == '"') &
+ &      .OR.(tmp_str(1:1) == "'") ) THEN
+!-
+      IF (nb_lastkey == 0) THEN
+!------ Save info of current keyword as a scalar
+!------ if it is not a continuation
+        targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n))
+        last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n))
+        nb_lastkey = 1
+      ELSE
+!------ We are continuing a vector so the keyword needs
+!------ to get the underscores
+        WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1
+        targetlist(nb_lines) = &
+ &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+        last_key = &
+ &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+        nb_lastkey = nb_lastkey+1
+      ENDIF
+!-----
+      fichier(nb_lines) = NEW_str(1:len_str)
+      fromfile(nb_lines) = current
+    ELSE
+!-
+!---- If there are blanks whithin the line then we are dealing
+!---- with a vector and we need to split it in many entries
+!---- with the TARGET__n notation.
+!----
+!---- Test if the targer is not already a vector target !
+!-
+      IF (INDEX(TRIM(key_str),'__') > 0) THEN
+        CALL ipslerr (3,'getin_decrypt', &
+ &       'We have found a mixed vector notation (TARGET__n).', &
+ &       'The key at fault : '//TRIM(key_str),' ')
+      ENDIF
+!-
+      nbve = nb_lastkey
+      nbve = nbve+1
+      WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
+!-
+      DO WHILE (blk > 0)
+!-
+!------ Save the content of target__nbve
+!-
+        fichier(nb_lines) = tmp_str(1:blk)
+        new_key = &
+ &       key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+        targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
+        fromfile(nb_lines) = current
+!-
+        tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
+        blk = INDEX(TRIM(tmp_str),' ')
+!-
+        IF (nb_lines+1 > i_txtsize) THEN
+          CALL getin_alloctxt ()
+        ENDIF
+        nb_lines = nb_lines+1
+        nbve = nbve+1
+        WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
+!-
+      ENDDO
+!-
+!---- Save the content of the last target
+!-
+      fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str))
+      new_key = &
+ &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+      targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
+      fromfile(nb_lines) = current
+!-
+      last_key = &
+ &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
+      nb_lastkey = nbve
+!-
+    ENDIF
+!-
+  ENDIF
+!---------------------------
+END SUBROUTINE getin_decrypt
+!-
+!===
+!-
+SUBROUTINE getin_checkcohe ()
+!---------------------------------------------------------------------
+!- This subroutine checks for redundancies.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: line,n_k,k
+!---------------------------------------------------------------------
+  DO line=1,nb_lines-1
+!-
+    n_k = 0
+    DO k=line+1,nb_lines
+      IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN
+        n_k = k
+        EXIT
+      ENDIF
+    ENDDO
+!---
+!-- IF we have found it we have a problem to solve.
+!---
+    IF (n_k > 0) THEN
+      WRITE(*,*) 'COUNT : ',n_k
+      WRITE(*,*) &
+ &  'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line))
+      WRITE(*,*) &
+ &  'getin_checkcohe : The following values were encoutered :'
+      WRITE(*,*) &
+ &  '                ',TRIM(targetlist(line)),' == ',fichier(line)
+      WRITE(*,*) &
+ &  '                ',TRIM(targetlist(k)),' == ',fichier(k)
+      WRITE(*,*) &
+ &  'getin_checkcohe : We will keep only the last value'
+      targetlist(line) = ' '
+    ENDIF
+  ENDDO
+!-----------------------------
+END SUBROUTINE getin_checkcohe
+!-
+!===
+!-
+SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: unit,eof,nb_lastkey
+  CHARACTER(LEN=100) :: dummy
+  CHARACTER(LEN=100) :: out_string
+  CHARACTER(LEN=1) :: first
+!---------------------------------------------------------------------
+  first="#"
+  eof = 0
+  out_string = "    "
+!-
+  DO WHILE (first == "#")
+    READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy
+    dummy = TRIM(ADJUSTL(dummy))
+    first=dummy(1:1)
+    IF (first == "#") THEN
+      nb_lastkey = 0
+    ENDIF
+  ENDDO
+  out_string=dummy
+!-
+  RETURN
+!-
+9998 CONTINUE
+  CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ')
+!-
+7778 CONTINUE
+  eof = 1
+!----------------------------
+END SUBROUTINE getin_skipafew
+!-
+!===
+!-
+SUBROUTINE getin_allockeys ()
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab
+  CHARACTER(LEN=100),ALLOCATABLE :: tmp_str(:)
+!-
+  INTEGER :: ier
+  CHARACTER(LEN=20) :: c_tmp
+!---------------------------------------------------------------------
+  IF (keymemsize == 0) THEN
+!---
+!-- Nothing exists in memory arrays and it is easy to do.
+!---
+    WRITE (UNIT=c_tmp,FMT=*) memslabs
+    ALLOCATE(key_tab(memslabs),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_allockeys', &
+ &     'Can not allocate key_tab', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+    ENDIF
+    nb_keys = 0
+    keymemsize = memslabs
+    key_tab(:)%keycompress = -1
+!---
+  ELSE
+!---
+!-- There is something already in the memory,
+!-- we need to transfer and reallocate.
+!---
+    WRITE (UNIT=c_tmp,FMT=*) keymemsize
+    ALLOCATE(tmp_key_tab(keymemsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_allockeys', &
+ &     'Can not allocate tmp_key_tab', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+    ENDIF
+    WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs
+    tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize)
+    DEALLOCATE(key_tab)
+    ALLOCATE(key_tab(keymemsize+memslabs),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_allockeys', &
+ &     'Can not allocate key_tab', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+    ENDIF
+    key_tab(:)%keycompress = -1
+    key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize)
+    DEALLOCATE(tmp_key_tab)
+    keymemsize = keymemsize+memslabs
+  ENDIF
+!-----------------------------
+END SUBROUTINE getin_allockeys
+!-
+!===
+!-
+SUBROUTINE getin_allocmem (type,len_wanted)
+!---------------------------------------------------------------------
+!- Allocate the memory of the data base for all 4 types of memory
+!- INTEGER / REAL / CHARACTER / LOGICAL
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: type,len_wanted
+!-
+  INTEGER,ALLOCATABLE :: tmp_int(:)
+  REAL,ALLOCATABLE :: tmp_real(:)
+  CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:)
+  LOGICAL,ALLOCATABLE :: tmp_logic(:)
+  INTEGER :: ier
+  CHARACTER(LEN=20) :: c_tmp
+!---------------------------------------------------------------------
+  SELECT CASE (type)
+  CASE(k_i)
+    IF (i_memsize == 0) THEN
+      ALLOCATE(i_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      i_memsize=memslabs
+    ELSE
+      ALLOCATE(tmp_int(i_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) i_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_int', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_int(1:i_memsize) = i_mem(1:i_memsize)
+      DEALLOCATE(i_mem)
+      ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      i_mem(1:i_memsize) = tmp_int(1:i_memsize)
+      i_memsize = i_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_int)
+    ENDIF
+  CASE(k_r)
+    IF (r_memsize == 0) THEN
+      ALLOCATE(r_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      r_memsize =  memslabs
+    ELSE
+      ALLOCATE(tmp_real(r_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) r_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_real', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_real(1:r_memsize) = r_mem(1:r_memsize)
+      DEALLOCATE(r_mem)
+      ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      r_mem(1:r_memsize) = tmp_real(1:r_memsize)
+      r_memsize = r_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_real)
+    ENDIF
+  CASE(k_c)
+    IF (c_memsize == 0) THEN
+      ALLOCATE(c_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      c_memsize = memslabs
+    ELSE
+      ALLOCATE(tmp_char(c_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) c_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_char', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_char(1:c_memsize) = c_mem(1:c_memsize)
+      DEALLOCATE(c_mem)
+      ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      c_mem(1:c_memsize) = tmp_char(1:c_memsize)
+      c_memsize = c_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_char)
+    ENDIF
+  CASE(k_l)
+    IF (l_memsize == 0) THEN
+      ALLOCATE(l_mem(memslabs),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) memslabs
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate db-memory', &
+ &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      l_memsize = memslabs
+    ELSE
+      ALLOCATE(tmp_logic(l_memsize),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) l_memsize
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to allocate tmp_logic', &
+ &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      tmp_logic(1:l_memsize) = l_mem(1:l_memsize)
+      DEALLOCATE(l_mem)
+      ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier)
+      IF (ier /= 0) THEN
+        WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted)
+        CALL ipslerr (3,'getin_allocmem', &
+ &       'Unable to re-allocate db-memory', &
+ &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
+      ENDIF
+      l_mem(1:l_memsize) = tmp_logic(1:l_memsize)
+      l_memsize = l_memsize+MAX(memslabs,len_wanted)
+      DEALLOCATE(tmp_logic)
+    ENDIF
+  CASE DEFAULT
+    CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ')
+  END SELECT
+!----------------------------
+END SUBROUTINE getin_allocmem
+!-
+!===
+!-
+SUBROUTINE getin_alloctxt ()
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:)
+  CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:)
+  INTEGER,ALLOCATABLE :: tmp_int(:)
+!-
+  INTEGER :: ier
+  CHARACTER(LEN=20) :: c_tmp1,c_tmp2
+!---------------------------------------------------------------------
+  IF (i_txtsize == 0) THEN
+!---
+!-- Nothing exists in memory arrays and it is easy to do.
+!---
+    WRITE (UNIT=c_tmp1,FMT=*) i_txtslab
+    ALLOCATE(fichier(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fichier', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    ALLOCATE(targetlist(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate targetlist', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    ALLOCATE(fromfile(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fromfile', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    ALLOCATE(compline(i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate compline', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+!---
+    nb_lines = 0
+    i_txtsize = i_txtslab
+  ELSE
+!---
+!-- There is something already in the memory,
+!-- we need to transfer and reallocate.
+!---
+    WRITE (UNIT=c_tmp1,FMT=*) i_txtsize
+    WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab
+    ALLOCATE(tmp_fic(i_txtsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate tmp_fic', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+    tmp_fic(1:i_txtsize) = fichier(1:i_txtsize)
+    DEALLOCATE(fichier)
+    ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fichier', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    fichier(1:i_txtsize) = tmp_fic(1:i_txtsize)
+    DEALLOCATE(tmp_fic)
+!---
+    ALLOCATE(tmp_tgl(i_txtsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate tmp_tgl', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+    tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize)
+    DEALLOCATE(targetlist)
+    ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate targetlist', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize)
+    DEALLOCATE(tmp_tgl)
+!---
+    ALLOCATE(tmp_int(i_txtsize),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate tmp_int', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
+    ENDIF
+    tmp_int(1:i_txtsize) = fromfile(1:i_txtsize)
+    DEALLOCATE(fromfile)
+    ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate fromfile', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    fromfile(1:i_txtsize) = tmp_int(1:i_txtsize)
+!---
+    tmp_int(1:i_txtsize) = compline(1:i_txtsize)
+    DEALLOCATE(compline)
+    ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier)
+    IF (ier /= 0) THEN
+      CALL ipslerr (3,'getin_alloctxt', &
+ &     'Can not allocate compline', &
+ &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
+    ENDIF
+    compline(1:i_txtsize) = tmp_int(1:i_txtsize)
+    DEALLOCATE(tmp_int)
+!---
+    i_txtsize = i_txtsize+i_txtslab
+  ENDIF
+!----------------------------
+END SUBROUTINE getin_alloctxt
+!-
+!===
+!-
+SUBROUTINE getin_dump (fileprefix)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(*),OPTIONAL :: fileprefix
+!-
+  CHARACTER(LEN=80) :: usedfileprefix
+  INTEGER :: ikey,if,iff,iv
+  CHARACTER(LEN=20) :: c_tmp
+  CHARACTER(LEN=100) :: tmp_str,used_filename
+  LOGICAL :: check = .FALSE.
+!---------------------------------------------------------------------
+  IF (PRESENT(fileprefix)) THEN
+    usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80))
+  ELSE
+    usedfileprefix = "used"
+  ENDIF
+!-
+  DO if=1,nbfiles
+!---
+    used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if))
+    IF (check) THEN
+      WRITE(*,*) &
+ &      'GETIN_DUMP : opens file : ',TRIM(used_filename),' if = ',if
+      WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys
+    ENDIF
+    OPEN (UNIT=22,FILE=used_filename)
+!---
+!-- If this is the first file we need to add the list
+!-- of file which belong to it
+    IF ( (if == 1).AND.(nbfiles > 1) ) THEN
+      WRITE(22,*) '# '
+      WRITE(22,*) '# This file is linked to the following files :'
+      WRITE(22,*) '# '
+      DO iff=2,nbfiles
+        WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff))
+      ENDDO
+      WRITE(22,*) '# '
+    ENDIF
+!---
+    DO ikey=1,nb_keys
+!-----
+!---- Is this key from this file ?
+      IF (key_tab(ikey)%keyfromfile == if) THEN
+!-------
+!------ Write some comments
+        WRITE(22,*) '#'
+        SELECT CASE (key_tab(ikey)%keystatus)
+        CASE(1)
+          WRITE(22,*) '# Values of ', &
+ &          TRIM(key_tab(ikey)%keystr),' comes from the run.def.'
+        CASE(2)
+          WRITE(22,*) '# Values of ', &
+ &          TRIM(key_tab(ikey)%keystr),' are all defaults.'
+        CASE(3)
+          WRITE(22,*) '# Values of ', &
+ &          TRIM(key_tab(ikey)%keystr), &
+ &          ' are a mix of run.def and defaults.'
+        CASE DEFAULT
+          WRITE(22,*) '# Dont know from where the value of ', &
+ &          TRIM(key_tab(ikey)%keystr),' comes.'
+        END SELECT
+        WRITE(22,*) '#'
+!-------
+!------ Write the values
+        SELECT CASE (key_tab(ikey)%keytype)
+        CASE(k_i)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            IF (key_tab(ikey)%keycompress < 0) THEN
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',i_mem(key_tab(ikey)%keymemstart)
+            ELSE
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',key_tab(ikey)%keycompress, &
+ &              ' * ',i_mem(key_tab(ikey)%keymemstart)
+            ENDIF
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              '__',TRIM(ADJUSTL(c_tmp)), &
+ &              ' = ',i_mem(key_tab(ikey)%keymemstart+iv)
+            ENDDO
+          ENDIF
+        CASE(k_r)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            IF (key_tab(ikey)%keycompress < 0) THEN
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',r_mem(key_tab(ikey)%keymemstart)
+            ELSE
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',key_tab(ikey)%keycompress, &
+                   & ' * ',r_mem(key_tab(ikey)%keymemstart)
+            ENDIF
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), &
+ &              ' = ',r_mem(key_tab(ikey)%keymemstart+iv)
+            ENDDO
+          ENDIF
+        CASE(k_c)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            tmp_str = c_mem(key_tab(ikey)%keymemstart)
+            WRITE(22,*) TRIM(key_tab(ikey)%keystr), &
+ &              ' = ',TRIM(tmp_str)
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              tmp_str = c_mem(key_tab(ikey)%keymemstart+iv)
+              WRITE(22,*) &
+ &              TRIM(key_tab(ikey)%keystr), &
+ &              '__',TRIM(ADJUSTL(c_tmp)), &
+ &              ' = ',TRIM(tmp_str)
+            ENDDO
+          ENDIF
+        CASE(k_l)
+          IF (key_tab(ikey)%keymemlen == 1) THEN
+            IF (l_mem(key_tab(ikey)%keymemstart)) THEN
+              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE '
+            ELSE
+              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE '
+            ENDIF
+          ELSE
+            DO iv=0,key_tab(ikey)%keymemlen-1
+              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
+              IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN
+                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
+ &                          TRIM(ADJUSTL(c_tmp)),' = TRUE '
+              ELSE
+                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
+ &                          TRIM(ADJUSTL(c_tmp)),' = FALSE '
+              ENDIF
+            ENDDO
+          ENDIF
+        CASE DEFAULT
+          CALL ipslerr (3,'getin_dump', &
+ &         'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), &
+ &         ' ',' ')
+        END SELECT
+      ENDIF
+    ENDDO
+!-
+    CLOSE(UNIT=22)
+!-
+  ENDDO
+!------------------------
+END SUBROUTINE getin_dump
+!===
+SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v)
+!---------------------------------------------------------------------
+!- Returns the type of the argument (mutually exclusive)
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(OUT) :: k_typ
+  CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp
+  INTEGER,DIMENSION(:),OPTIONAL          :: i_v
+  REAL,DIMENSION(:),OPTIONAL             :: r_v
+  LOGICAL,DIMENSION(:),OPTIONAL          :: l_v
+  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v
+!---------------------------------------------------------------------
+  k_typ = 0
+  IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) &
+ &    /= 1) THEN
+    CALL ipslerr (3,'get_qtyp', &
+ &   'Invalid number of optional arguments','(/= 1)',' ')
+  ENDIF
+!-
+  IF     (PRESENT(i_v)) THEN
+    k_typ = k_i
+    c_vtyp = 'INTEGER'
+  ELSEIF (PRESENT(r_v)) THEN
+    k_typ = k_r
+    c_vtyp = 'REAL'
+  ELSEIF (PRESENT(c_v)) THEN
+    k_typ = k_c
+    c_vtyp = 'CHARACTER'
+  ELSEIF (PRESENT(l_v)) THEN
+    k_typ = k_l
+    c_vtyp = 'LOGICAL'
+  ENDIF
+!----------------------
+END SUBROUTINE get_qtyp
+!===
+SUBROUTINE get_findkey (i_tab,c_key,pos)
+!---------------------------------------------------------------------
+!- This subroutine looks for a key in a table
+!---------------------------------------------------------------------
+!- INPUT
+!-   i_tab  : 1 -> search in key_tab(1:nb_keys)%keystr
+!-            2 -> search in targetlist(1:nb_lines)
+!-   c_key  : Name of the key we are looking for
+!- OUTPUT
+!-   pos    : -1 if key not found, else value in the table
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER,INTENT(in) :: i_tab
+  CHARACTER(LEN=*),INTENT(in) :: c_key
+  INTEGER,INTENT(out) :: pos
+!-
+  INTEGER :: ikey_max,ikey
+  CHARACTER(LEN=l_n) :: c_q_key
+!---------------------------------------------------------------------
+  pos = -1
+  IF     (i_tab == 1) THEN
+    ikey_max = nb_keys
+  ELSEIF (i_tab == 2) THEN
+    ikey_max = nb_lines
+  ELSE
+    ikey_max = 0
+  ENDIF
+  IF ( ikey_max > 0 ) THEN
+    DO ikey=1,ikey_max
+      IF (i_tab == 1) THEN
+        c_q_key = key_tab(ikey)%keystr
+      ELSE
+        c_q_key = targetlist(ikey)
+      ENDIF
+      IF (TRIM(c_q_key) == TRIM(c_key)) THEN
+        pos = ikey
+        EXIT
+      ENDIF
+    ENDDO
+  ENDIF
+!-------------------------
+END SUBROUTINE get_findkey
+!===
+!------------------
+END MODULE ioipsl_getincom
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ioipsl_stringop.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ioipsl_stringop.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ioipsl_stringop.F90	(revision 17)
@@ -0,0 +1,243 @@
+!
+! $Id$
+!
+! Module/Routines extracted from IOIPSL v2_1_8
+!
+MODULE ioipsl_stringop
+!-
+!$Id: stringop.f90 386 2008-09-04 08:38:48Z bellier $
+!-
+! This software is governed by the CeCILL license
+! See IOIPSL/IOIPSL_License_CeCILL.txt
+!---------------------------------------------------------------------
+!-
+  INTEGER,DIMENSION(30) :: &
+ & prime=(/1,2,3,5,7,11,13,17,19,23,29,31,37,41,43, &
+ & 47,53,59,61,67,71,73,79,83,89,97,101,103,107,109/)
+!-
+!---------------------------------------------------------------------
+CONTAINS
+!=
+SUBROUTINE cmpblank (str)
+!---------------------------------------------------------------------
+!- Compact blanks
+!---------------------------------------------------------------------
+  CHARACTER(LEN=*),INTENT(inout) :: str
+!-
+  INTEGER :: lcc,ipb
+!---------------------------------------------------------------------
+  lcc = LEN_TRIM(str)
+  ipb = 1
+  DO
+    IF (ipb >= lcc)   EXIT
+    IF (str(ipb:ipb+1) == '  ') THEN
+      str(ipb+1:) = str(ipb+2:lcc)
+      lcc = lcc-1
+    ELSE
+      ipb = ipb+1
+    ENDIF
+  ENDDO
+!----------------------
+END SUBROUTINE cmpblank
+!===
+INTEGER FUNCTION cntpos (c_c,l_c,c_r,l_r)
+!---------------------------------------------------------------------
+!- Finds number of occurences of c_r in c_c
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(in) :: c_c
+  INTEGER,INTENT(IN) :: l_c
+  CHARACTER(LEN=*),INTENT(in) :: c_r
+  INTEGER,INTENT(IN) :: l_r
+!-
+  INTEGER :: ipos,indx
+!---------------------------------------------------------------------
+  cntpos = 0
+  ipos   = 1
+  DO
+    indx = INDEX(c_c(ipos:l_c),c_r(1:l_r))
+    IF (indx > 0) THEN
+      cntpos = cntpos+1
+      ipos   = ipos+indx+l_r-1
+    ELSE
+      EXIT
+    ENDIF
+  ENDDO
+!------------------
+END FUNCTION cntpos
+!===
+INTEGER FUNCTION findpos (c_c,l_c,c_r,l_r)
+!---------------------------------------------------------------------
+!- Finds position of c_r in c_c
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),INTENT(in) :: c_c
+  INTEGER,INTENT(IN) :: l_c
+  CHARACTER(LEN=*),INTENT(in) :: c_r
+  INTEGER,INTENT(IN) :: l_r
+!---------------------------------------------------------------------
+  findpos = INDEX(c_c(1:l_c),c_r(1:l_r))
+  IF (findpos == 0)  findpos=-1
+!-------------------
+END FUNCTION findpos
+!===
+SUBROUTINE find_str (str_tab,str,pos)
+!---------------------------------------------------------------------
+!- This subroutine looks for a string in a table
+!---------------------------------------------------------------------
+!- INPUT
+!-   str_tab  : Table  of strings
+!-   str      : Target we are looking for
+!- OUTPUT
+!-   pos      : -1 if str not found, else value in the table
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*),DIMENSION(:),INTENT(in) :: str_tab
+  CHARACTER(LEN=*),INTENT(in) :: str
+  INTEGER,INTENT(out) :: pos
+!-
+  INTEGER :: nb_str,i
+!---------------------------------------------------------------------
+  pos = -1
+  nb_str=SIZE(str_tab)
+  IF ( nb_str > 0 ) THEN
+    DO i=1,nb_str
+      IF ( TRIM(str_tab(i)) == TRIM(str) ) THEN
+        pos = i
+        EXIT
+      ENDIF
+    ENDDO
+  ENDIF
+!----------------------
+END SUBROUTINE find_str
+!===
+SUBROUTINE nocomma (str)
+!---------------------------------------------------------------------
+!- Replace commas with blanks
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  DO i=1,LEN_TRIM(str)
+    IF (str(i:i) == ',')   str(i:i) = ' '
+  ENDDO
+!---------------------
+END SUBROUTINE nocomma
+!===
+SUBROUTINE strlowercase (str)
+!---------------------------------------------------------------------
+!- Converts a string into lowercase
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+!-
+  INTEGER :: i,ic
+!---------------------------------------------------------------------
+  DO i=1,LEN_TRIM(str)
+    ic = IACHAR(str(i:i))
+    IF ( (ic >= 65).AND.(ic <= 90) )  str(i:i) = ACHAR(ic+32)
+  ENDDO
+!--------------------------
+END SUBROUTINE strlowercase
+!===
+SUBROUTINE struppercase (str)
+!---------------------------------------------------------------------
+!- Converts a string into uppercase
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+!-
+  INTEGER :: i,ic
+!---------------------------------------------------------------------
+  DO i=1,LEN_TRIM(str)
+    ic = IACHAR(str(i:i))
+    IF ( (ic >= 97).AND.(ic <= 122) )  str(i:i) = ACHAR(ic-32)
+  ENDDO
+!--------------------------
+END SUBROUTINE struppercase
+!===
+SUBROUTINE gensig (str,sig)
+!---------------------------------------------------------------------
+!- Generate a signature from the first 30 characters of the string
+!- This signature is not unique and thus when one looks for the
+!- one needs to also verify the string.
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  CHARACTER(LEN=*) :: str
+  INTEGER          :: sig
+!-
+  INTEGER :: i
+!---------------------------------------------------------------------
+  sig = 0
+  DO i=1,MIN(LEN_TRIM(str),30)
+    sig = sig + prime(i)*IACHAR(str(i:i))
+  ENDDO
+!--------------------
+END SUBROUTINE gensig
+!===
+SUBROUTINE find_sig (nb_sig,str_tab,str,sig_tab,sig,pos)
+!---------------------------------------------------------------------
+!- Find the string signature in a list of signatures
+!---------------------------------------------------------------------
+!- INPUT
+!-   nb_sig      : length of table of signatures
+!-   str_tab     : Table of strings
+!-   str         : Target string we are looking for
+!-   sig_tab     : Table of signatures
+!-   sig         : Target signature we are looking for
+!- OUTPUT
+!-   pos         : -1 if str not found, else value in the table
+!---------------------------------------------------------------------
+  IMPLICIT NONE
+!-
+  INTEGER :: nb_sig
+  CHARACTER(LEN=*),DIMENSION(nb_sig) :: str_tab
+  CHARACTER(LEN=*) :: str
+  INTEGER,DIMENSION(nb_sig) :: sig_tab
+  INTEGER :: sig
+!-
+  INTEGER :: pos
+  INTEGER,DIMENSION(nb_sig) :: loczeros
+!-
+  INTEGER :: il,len
+  INTEGER,DIMENSION(1) :: minpos
+!---------------------------------------------------------------------
+  pos = -1
+  il = LEN_TRIM(str)
+!-
+  IF ( nb_sig > 0 ) THEN
+    loczeros = ABS(sig_tab(1:nb_sig)-sig)
+    IF ( COUNT(loczeros < 1) == 1 ) THEN
+      minpos = MINLOC(loczeros)
+      len = LEN_TRIM(str_tab(minpos(1)))
+      IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
+          .AND.(len == il) ) THEN
+        pos = minpos(1)
+      ENDIF
+    ELSE IF ( COUNT(loczeros < 1) > 1 ) THEN
+      DO WHILE (COUNT(loczeros < 1) >= 1 .AND. pos < 0 )
+        minpos = MINLOC(loczeros)
+        len = LEN_TRIM(str_tab(minpos(1)))
+        IF (     (INDEX(str_tab(minpos(1)),str(1:il)) > 0) &
+            .AND.(len == il) ) THEN
+          pos = minpos(1)
+        ELSE
+          loczeros(minpos(1)) = 99999
+        ENDIF
+      ENDDO
+    ENDIF
+  ENDIF
+!-----------------------
+ END SUBROUTINE find_sig
+!===
+!------------------
+END MODULE ioipsl_stringop
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/iophy.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/iophy.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/iophy.F90	(revision 17)
@@ -0,0 +1,655 @@
+!
+! $Header$
+!
+module iophy
+  
+! abd  REAL,private,allocatable,dimension(:),save :: io_lat
+! abd  REAL,private,allocatable,dimension(:),save :: io_lon
+  REAL,ALLOCATABLE,DIMENSION(:),SAVE :: io_lat
+  REAL,ALLOCATABLE,DIMENSION(:),SAVE :: io_lon
+  INTEGER, SAVE :: phys_domain_id
+  INTEGER, SAVE :: npstn
+  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE :: nptabij
+  INTEGER, SAVE :: itau_iophy
+
+!$OMP THREADPRIVATE(itau_iophy)
+  
+  INTERFACE histwrite_phy
+    MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old
+  END INTERFACE
+
+  INTERFACE histbeg_phy_all
+    MODULE PROCEDURE histbeg_phy,histbeg_phy_points
+  END INTERFACE
+
+
+contains
+
+  subroutine init_iophy_new(rlat,rlon)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  USE ioipsl
+  implicit none
+  include 'dimensions.h'   
+    real,dimension(klon),intent(in) :: rlon
+    real,dimension(klon),intent(in) :: rlat
+
+    REAL,dimension(klon_glo)        :: rlat_glo
+    REAL,dimension(klon_glo)        :: rlon_glo
+    
+    INTEGER,DIMENSION(2) :: ddid
+    INTEGER,DIMENSION(2) :: dsg
+    INTEGER,DIMENSION(2) :: dsl
+    INTEGER,DIMENSION(2) :: dpf
+    INTEGER,DIMENSION(2) :: dpl
+    INTEGER,DIMENSION(2) :: dhs
+    INTEGER,DIMENSION(2) :: dhe 
+    INTEGER :: i    
+
+    CALL gather(rlat,rlat_glo)
+    CALL bcast(rlat_glo)
+    CALL gather(rlon,rlon_glo)
+    CALL bcast(rlon_glo)
+    
+!$OMP MASTER  
+    ALLOCATE(io_lat(jjm+1-1/(iim*jjm)))
+    io_lat(1)=rlat_glo(1)
+    io_lat(jjm+1-1/(iim*jjm))=rlat_glo(klon_glo)
+    IF ((iim*jjm) > 1) then
+      DO i=2,jjm
+        io_lat(i)=rlat_glo(2+(i-2)*iim)
+      ENDDO
+    ENDIF
+
+    ALLOCATE(io_lon(iim))
+    io_lon(:)=rlon_glo(2-1/(iim*jjm):iim+1-1/(iim*jjm))
+
+    ddid=(/ 1,2 /)
+    dsg=(/ iim, jjm+1-1/(iim*jjm) /)
+    dsl=(/ iim, jj_nb /)
+    dpf=(/ 1,jj_begin /)
+    dpl=(/ iim, jj_end /)
+    dhs=(/ ii_begin-1,0 /)
+    if (mpi_rank==mpi_size-1) then
+      dhe=(/0,0/)
+    else
+      dhe=(/ iim-ii_end,0 /)  
+    endif
+    
+    call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+                      'APPLE',phys_domain_id)
+
+!$OMP END MASTER
+      
+  end subroutine init_iophy_new
+
+  subroutine init_iophy(lat,lon)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  use ioipsl
+  implicit none
+  include 'dimensions.h'   
+    real,dimension(iim),intent(in) :: lon
+    real,dimension(jjm+1-1/(iim*jjm)),intent(in) :: lat
+
+    INTEGER,DIMENSION(2) :: ddid
+    INTEGER,DIMENSION(2) :: dsg
+    INTEGER,DIMENSION(2) :: dsl
+    INTEGER,DIMENSION(2) :: dpf
+    INTEGER,DIMENSION(2) :: dpl
+    INTEGER,DIMENSION(2) :: dhs
+    INTEGER,DIMENSION(2) :: dhe 
+
+!$OMP MASTER  
+    allocate(io_lat(jjm+1-1/(iim*jjm)))
+    io_lat(:)=lat(:)
+    allocate(io_lon(iim))
+    io_lon(:)=lon(:)
+   
+    ddid=(/ 1,2 /)
+    dsg=(/ iim, jjm+1-1/(iim*jjm) /)
+    dsl=(/ iim, jj_nb /)
+    dpf=(/ 1,jj_begin /)
+    dpl=(/ iim, jj_end /)
+    dhs=(/ ii_begin-1,0 /)
+    if (mpi_rank==mpi_size-1) then
+      dhe=(/0,0/)
+    else
+      dhe=(/ iim-ii_end,0 /)  
+    endif
+    
+    call flio_dom_set(mpi_size,mpi_rank,ddid,dsg,dsl,dpf,dpl,dhs,dhe, &
+                      'APPLE',phys_domain_id)
+
+!$OMP END MASTER
+      
+  end subroutine init_iophy
+  
+  subroutine histbeg_phy(name,itau0,zjulian,dtime,nhori,nid_day)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  use ioipsl
+  use write_field
+  implicit none
+  include 'dimensions.h'
+    
+    character*(*), intent(IN) :: name
+    integer, intent(in) :: itau0
+    real,intent(in) :: zjulian
+    real,intent(in) :: dtime
+    integer,intent(out) :: nhori
+    integer,intent(out) :: nid_day
+
+!$OMP MASTER    
+    if (is_sequential) then
+      call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
+                   1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day)
+    else
+      call histbeg(name,iim,io_lon, jj_nb,io_lat(jj_begin:jj_end), &
+                   1,iim,1,jj_nb,itau0, zjulian, dtime, nhori, nid_day,phys_domain_id)
+    endif
+!$OMP END MASTER
+  
+  end subroutine histbeg_phy
+
+  subroutine histbeg_phy_points(rlon,rlat,pim,tabij,ipt,jpt, &
+             plon,plat,plon_bounds,plat_bounds, &
+             nname,itau0,zjulian,dtime,nnhori,nnid_day)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  use ioipsl
+  use write_field
+  implicit none
+  include 'dimensions.h' 
+
+    real,dimension(klon),intent(in) :: rlon
+    real,dimension(klon),intent(in) :: rlat
+    integer, intent(in) :: itau0
+    real,intent(in) :: zjulian
+    real,intent(in) :: dtime
+    integer, intent(in) :: pim
+    integer, intent(out) :: nnhori
+    character(len=20), intent(in) :: nname
+    INTEGER, intent(out) :: nnid_day
+    integer :: i
+    REAL,dimension(klon_glo)        :: rlat_glo
+    REAL,dimension(klon_glo)        :: rlon_glo
+    INTEGER, DIMENSION(pim), intent(in)  :: tabij
+    REAL,dimension(pim), intent(in) :: plat, plon
+    INTEGER,dimension(pim), intent(in) :: ipt, jpt
+    REAL,dimension(pim,2), intent(out) :: plat_bounds, plon_bounds
+
+    INTEGER, SAVE :: tabprocbeg, tabprocend
+!$OMP THREADPRIVATE(tabprocbeg, tabprocend)
+    INTEGER :: ip
+    INTEGER, PARAMETER :: nip=1
+    INTEGER :: npproc
+    REAL, allocatable, dimension(:) :: npplat, npplon
+    REAL, allocatable, dimension(:,:) :: npplat_bounds, npplon_bounds
+    INTEGER, PARAMETER :: jjmp1=jjm+1-1/jjm
+    REAL, dimension(iim,jjmp1) :: zx_lon, zx_lat
+
+    CALL gather(rlat,rlat_glo)
+    CALL bcast(rlat_glo)
+    CALL gather(rlon,rlon_glo)
+    CALL bcast(rlon_glo)
+
+!$OMP MASTER
+    DO i=1,pim
+
+!    print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i)
+
+     plon_bounds(i,1)=rlon_glo(tabij(i)-1)
+     plon_bounds(i,2)=rlon_glo(tabij(i)+1)
+     if(plon_bounds(i,2).LE.0..AND.plon_bounds(i,1).GE.0.) THEN
+      if(rlon_glo(tabij(i)).GE.0.) THEN
+       plon_bounds(i,2)=-1*plon_bounds(i,2)
+      endif
+     endif
+     if(plon_bounds(i,2).GE.0..AND.plon_bounds(i,1).LE.0.) THEN
+      if(rlon_glo(tabij(i)).LE.0.) THEN
+       plon_bounds(i,2)=-1*plon_bounds(i,2)
+      endif
+     endif
+!
+     IF ( tabij(i).LE.iim) THEN
+      plat_bounds(i,1)=rlat_glo(tabij(i))
+     ELSE
+      plat_bounds(i,1)=rlat_glo(tabij(i)-iim)
+     ENDIF
+     plat_bounds(i,2)=rlat_glo(tabij(i)+iim)
+!
+!    print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon_glo(tabij(i)),plon_bounds(i,2) 
+!    print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat_glo(tabij(i)),plat_bounds(i,2) 
+!
+    ENDDO
+    if (is_sequential) then
+
+     npstn=pim
+     IF(.NOT. ALLOCATED(nptabij)) THEN
+      ALLOCATE(nptabij(pim))
+     ENDIF 
+     DO i=1,pim
+      nptabij(i)=tabij(i)
+     ENDDO
+
+       CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlon_glo,zx_lon)
+       if ((iim*jjm).gt.1) then
+       DO i = 1, iim
+         zx_lon(i,1) = rlon_glo(i+1)
+         zx_lon(i,jjmp1) = rlon_glo(i+1)
+       ENDDO
+       endif
+       CALL gr_fi_ecrit(1,klon,iim,jjmp1,rlat_glo,zx_lat)
+
+    DO i=1,pim
+!    print*,'CFMIP_iophy i tabij lon lat',i,tabij(i),plon(i),plat(i)
+
+     plon_bounds(i,1)=zx_lon(ipt(i)-1,jpt(i))
+     plon_bounds(i,2)=zx_lon(ipt(i)+1,jpt(i))
+
+     if (ipt(i).EQ.1) then
+      plon_bounds(i,1)=zx_lon(iim,jpt(i))
+      plon_bounds(i,2)=360.+zx_lon(ipt(i)+1,jpt(i))
+     endif
+ 
+     if (ipt(i).EQ.iim) then
+      plon_bounds(i,2)=360.+zx_lon(1,jpt(i))
+     endif
+
+     plat_bounds(i,1)=zx_lat(ipt(i),jpt(i)-1)
+     plat_bounds(i,2)=zx_lat(ipt(i),jpt(i)+1)
+
+     if (jpt(i).EQ.1) then
+      plat_bounds(i,1)=zx_lat(ipt(i),1)+0.001
+      plat_bounds(i,2)=zx_lat(ipt(i),1)-0.001
+     endif
+ 
+     if (jpt(i).EQ.jjmp1) then
+      plat_bounds(i,1)=zx_lat(ipt(i),jjmp1)+0.001
+      plat_bounds(i,2)=zx_lat(ipt(i),jjmp1)-0.001
+     endif
+!
+!    print*,'CFMIP_iophy point i lon lon_bds',i,plon_bounds(i,1),rlon(tabij(i)),plon_bounds(i,2) 
+!    print*,'CFMIP_iophy point i lat lat_bds',i,plat_bounds(i,1),rlat(tabij(i)),plat_bounds(i,2) 
+!
+    ENDDO
+!    print*,'iophy is_sequential nname, nnhori, nnid_day=',trim(nname),nnhori,nnid_day
+     call histbeg(nname,pim,plon,plon_bounds, & 
+                           plat,plat_bounds, &
+                           itau0, zjulian, dtime, nnhori, nnid_day)
+    else
+     npproc=0
+     DO ip=1, pim
+      tabprocbeg=klon_mpi_begin
+      tabprocend=klon_mpi_end
+      IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN
+       npproc=npproc+1
+       npstn=npproc
+      ENDIF 
+     ENDDO
+!    print*,'CFMIP_iophy mpi_rank npstn',mpi_rank,npstn
+     IF(.NOT. ALLOCATED(nptabij)) THEN
+      ALLOCATE(nptabij(npstn))
+      ALLOCATE(npplon(npstn), npplat(npstn))
+      ALLOCATE(npplon_bounds(npstn,2), npplat_bounds(npstn,2))
+     ENDIF
+     npproc=0
+     DO ip=1, pim
+      IF(tabij(ip).GE.tabprocbeg.AND.tabij(ip).LE.tabprocend) THEN
+       npproc=npproc+1
+       nptabij(npproc)=tabij(ip)
+!      print*,'mpi_rank npproc ip plon plat tabij=',mpi_rank,npproc,ip, &
+!      plon(ip),plat(ip),tabij(ip)
+       npplon(npproc)=plon(ip)
+       npplat(npproc)=plat(ip)
+       npplon_bounds(npproc,1)=plon_bounds(ip,1)
+       npplon_bounds(npproc,2)=plon_bounds(ip,2)
+       npplat_bounds(npproc,1)=plat_bounds(ip,1)
+       npplat_bounds(npproc,2)=plat_bounds(ip,2)
+!!!
+!!! print qui sert a reordonner les points stations selon l'ordre CFMIP
+!!! ne pas enlever
+        print*,'iophy_mpi rank ip lon lat',mpi_rank,ip,plon(ip),plat(ip)
+!!!
+      ENDIF
+     ENDDO
+     call histbeg(nname,npstn,npplon,npplon_bounds, &
+                            npplat,npplat_bounds, &
+                            itau0,zjulian,dtime,nnhori,nnid_day,phys_domain_id)
+    endif
+!$OMP END MASTER
+
+  end subroutine histbeg_phy_points
+ 
+  SUBROUTINE histwrite2d_phy_old(nid,lpoint,name,itau,field)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE phys_output_var_mod
+  USE ioipsl
+  IMPLICIT NONE
+  include 'dimensions.h'
+  include 'iniprint.h'
+    
+    integer,intent(in) :: nid
+    logical,intent(in) :: lpoint 
+    character*(*), intent(IN) :: name
+    integer, intent(in) :: itau
+    real,dimension(:),intent(in) :: field
+    REAL,dimension(klon_mpi) :: buffer_omp
+    INTEGER, allocatable, dimension(:) :: index2d
+    REAL :: Field2d(iim,jj_nb)
+
+    integer :: ip
+    real,allocatable,dimension(:) :: fieldok
+
+
+    IF (size(field)/=klon) CALL abort_gcm('iophy::histwrite2d','Field first dimension not equal to klon',1)
+    
+    CALL Gather_omp(field,buffer_omp)    
+!$OMP MASTER
+    CALL grid1Dto2D_mpi(buffer_omp,Field2d)
+    if(.NOT.lpoint) THEN
+     ALLOCATE(index2d(iim*jj_nb))
+     ALLOCATE(fieldok(iim*jj_nb))
+     IF (prt_level >= 9) write(lunout,*)'Sending ',name,' to IOIPSL'
+     CALL histwrite(nid,name,itau,Field2d,iim*jj_nb,index2d)
+     IF (prt_level >= 9) write(lunout,*)'Finished sending ',name,' to IOIPSL'
+    else
+     ALLOCATE(fieldok(npstn))
+     ALLOCATE(index2d(npstn))
+
+     if(is_sequential) then
+!     klon_mpi_begin=1
+!     klon_mpi_end=klon
+      DO ip=1, npstn
+       fieldok(ip)=buffer_omp(nptabij(ip))
+      ENDDO
+     else
+      DO ip=1, npstn
+!     print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip)
+       IF(nptabij(ip).GE.klon_mpi_begin.AND. &
+          nptabij(ip).LE.klon_mpi_end) THEN
+         fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
+       ENDIF
+      ENDDO
+     endif
+     IF (prt_level >= 9) write(lunout,*)'Sending ',name,' to IOIPSL'
+     CALL histwrite(nid,name,itau,fieldok,npstn,index2d)
+     IF (prt_level >= 9) write(lunout,*)'Finished sending ',name,' to IOIPSL'
+!
+    endif
+    deallocate(index2d)
+    deallocate(fieldok)
+!$OMP END MASTER   
+
+ 
+  end subroutine histwrite2d_phy_old
+
+  subroutine histwrite3d_phy_old(nid,lpoint,name,itau,field)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE phys_output_var_mod
+
+  use ioipsl
+  implicit none
+  include 'dimensions.h'
+  include 'iniprint.h'
+    
+    integer,intent(in) :: nid
+    logical,intent(in) :: lpoint
+    character*(*), intent(IN) :: name
+    integer, intent(in) :: itau
+    real,dimension(:,:),intent(in) :: field  ! --> field(klon,:)
+    REAL,dimension(klon_mpi,size(field,2)) :: buffer_omp
+    REAL :: Field3d(iim,jj_nb,size(field,2))
+    INTEGER :: ip, n, nlev
+    INTEGER, ALLOCATABLE, dimension(:) :: index3d
+    real,allocatable, dimension(:,:) :: fieldok
+
+
+    IF (size(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first dimension not equal to klon',1)
+    nlev=size(field,2)
+
+!   print*,'hist3d_phy mpi_rank npstn=',mpi_rank,npstn
+
+!   DO ip=1, npstn
+!    print*,'hist3d_phy mpi_rank nptabij',mpi_rank,nptabij(ip)
+!   ENDDO
+
+    CALL Gather_omp(field,buffer_omp)
+!$OMP MASTER
+    CALL grid1Dto2D_mpi(buffer_omp,field3d)
+    if(.NOT.lpoint) THEN
+     ALLOCATE(index3d(iim*jj_nb*nlev))
+     ALLOCATE(fieldok(iim*jj_nb,nlev))
+     IF (prt_level >= 9) write(lunout,*)'Sending ',name,' to IOIPSL'
+     CALL histwrite(nid,name,itau,Field3d,iim*jj_nb*nlev,index3d)
+     IF (prt_level >= 9) write(lunout,*)'Finished sending ',name,' to IOIPSL'
+   else
+      nlev=size(field,2)
+      ALLOCATE(index3d(npstn*nlev))
+      ALLOCATE(fieldok(npstn,nlev))
+
+      if(is_sequential) then
+!      klon_mpi_begin=1
+!      klon_mpi_end=klon
+       DO n=1, nlev
+       DO ip=1, npstn
+        fieldok(ip,n)=buffer_omp(nptabij(ip),n)
+       ENDDO
+       ENDDO
+      else
+       DO n=1, nlev
+       DO ip=1, npstn
+        IF(nptabij(ip).GE.klon_mpi_begin.AND. &
+         nptabij(ip).LE.klon_mpi_end) THEN
+         fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
+        ENDIF
+       ENDDO
+       ENDDO
+      endif
+      IF (prt_level >= 9) write(lunout,*)'Sending ',name,' to IOIPSL'
+      CALL histwrite(nid,name,itau,fieldok,npstn*nlev,index3d)
+      IF (prt_level >= 9) write(lunout,*)'Finished sending ',name,' to IOIPSL'
+    endif 
+  deallocate(index3d)
+  deallocate(fieldok)
+!$OMP END MASTER    
+
+  end subroutine histwrite3d_phy_old
+
+
+! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
+  SUBROUTINE histwrite2d_phy(var,field, STD_iff)
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE ioipsl
+!Pour avoir nfiles, nidfiles tout Ã§a tout Ã§a...
+  USE phys_output_var_mod
+  
+  
+
+#ifdef CPP_XIOS
+!  USE WXIOS
+#endif
+
+  IMPLICIT NONE
+  include 'dimensions.h'
+    
+!    integer,intent(in) :: nid
+!    logical,intent(in) :: lpoint 
+!    character*(*), intent(IN) :: name
+!    integer, intent(in) :: itau
+!    real,dimension(:),intent(in) :: field
+
+      TYPE(ctrl_out), INTENT(IN) :: var
+      REAL, DIMENSION(:), INTENT(IN) :: field
+      INTEGER, INTENT(IN), OPTIONAL :: STD_iff ! ug RUSTINE POUR LES STD LEVS.....
+      
+      INTEGER :: iff, iff_beg, iff_end
+      
+    REAL,dimension(klon_mpi) :: buffer_omp
+    INTEGER, allocatable, dimension(:) :: index2d
+    REAL :: Field2d(iim,jj_nb)
+
+    INTEGER :: ip
+    REAL, ALLOCATABLE, DIMENSION(:) :: fieldok
+
+! ug RUSTINE POUR LES STD LEVS.....
+      IF (PRESENT(STD_iff)) THEN
+            iff_beg = STD_iff
+            iff_end = STD_iff
+      ELSE
+            iff_beg = 1
+            iff_end = nfiles
+      END IF
+
+    IF (size(field)/=klon) CALL abort_gcm('iophy::histwrite2d','Field first dimension not equal to klon',1)
+    
+    CALL Gather_omp(field,buffer_omp)    
+!$OMP MASTER
+    CALL grid1Dto2D_mpi(buffer_omp,Field2d)
+    
+! La boucle sur les fichiers:
+      DO iff=iff_beg, iff_end
+            IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN 
+    
+                  IF(.NOT.clef_stations(iff)) THEN
+                        ALLOCATE(index2d(iim*jj_nb))
+                        ALLOCATE(fieldok(iim*jj_nb))
+     
+                        CALL histwrite(nid_files(iff),var%name,itau_iophy,Field2d,iim*jj_nb,index2d)
+#ifdef CPP_XIOS
+!                        IF (iff .EQ. 1) THEN
+!                              CALL wxios_write_2D(var%name, Field2d)
+!                        ENDIF
+#endif
+                  ELSE 
+                        ALLOCATE(fieldok(npstn))
+                        ALLOCATE(index2d(npstn))
+
+                        IF (is_sequential) THEN
+!                            klon_mpi_begin=1
+!                             klon_mpi_end=klon
+                              DO ip=1, npstn
+                                    fieldok(ip)=buffer_omp(nptabij(ip))
+                              ENDDO
+                             ELSE
+                              DO ip=1, npstn
+!                                   print*,'histwrite2d is_sequential npstn ip name nptabij',npstn,ip,name,nptabij(ip)
+                                     IF(nptabij(ip).GE.klon_mpi_begin.AND. &
+                                        nptabij(ip).LE.klon_mpi_end) THEN
+                                       fieldok(ip)=buffer_omp(nptabij(ip)-klon_mpi_begin+1)
+                                     ENDIF
+                              ENDDO
+                       ENDIF
+     
+                       CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn,index2d)
+                  ENDIF
+                  
+                deallocate(index2d)
+                deallocate(fieldok)
+            ENDIF !levfiles
+      ENDDO
+!$OMP END MASTER   
+
+  END SUBROUTINE histwrite2d_phy
+
+
+! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE
+  SUBROUTINE histwrite3d_phy(var, field)
+  USE dimphy
+  USE mod_phys_lmdz_para
+
+  use ioipsl
+!Pour avoir nfiles, nidfiles tout Ã§a tout Ã§a...
+  USE phys_output_var_mod  
+  
+
+#ifdef CPP_XIOS
+! USE WXIOS
+#endif
+
+
+  IMPLICIT NONE
+  include 'dimensions.h'
+    
+!    integer,intent(in) :: nid
+!    logical,intent(in) :: lpoint
+!    character*(*), intent(IN) :: name
+!    integer, intent(in) :: itau
+!    real,dimension(:,:),intent(in) :: field  ! --> field(klon,:)
+
+      TYPE(ctrl_out), INTENT(IN) :: var
+      REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:)
+
+
+    REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp
+    REAL :: Field3d(iim,jj_nb,SIZE(field,2))
+    INTEGER :: ip, n, nlev, iff
+    INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d
+    REAL,ALLOCATABLE, DIMENSION(:,:) :: fieldok
+
+    IF (size(field,1)/=klon) CALL abort_gcm('iophy::histwrite3d','Field first dimension not equal to klon',1)
+    nlev=size(field,2)
+
+!   print*,'hist3d_phy mpi_rank npstn=',mpi_rank,npstn
+
+!   DO ip=1, npstn
+!    print*,'hist3d_phy mpi_rank nptabij',mpi_rank,nptabij(ip)
+!   ENDDO
+
+    CALL Gather_omp(field,buffer_omp)
+!$OMP MASTER
+    CALL grid1Dto2D_mpi(buffer_omp,field3d)
+
+
+! BOUCLE SUR LES FICHIERS
+      DO iff=1, nfiles
+            IF (var%flag(iff) <= lev_files(iff) .AND. clef_files(iff)) THEN
+                IF (.NOT.clef_stations(iff)) THEN
+                        ALLOCATE(index3d(iim*jj_nb*nlev))
+                        ALLOCATE(fieldok(iim*jj_nb,nlev))
+                        CALL histwrite(nid_files(iff),var%name,itau_iophy,Field3d,iim*jj_nb*nlev,index3d)
+#ifdef CPP_XIOS
+!                        IF (iff .EQ. 1) THEN
+!                              CALL wxios_write_3D(var%name, Field3d(:,:,1:klev))
+!                        ENDIF
+#endif
+                        
+                ELSE 
+                        nlev=size(field,2)
+                        ALLOCATE(index3d(npstn*nlev))
+                        ALLOCATE(fieldok(npstn,nlev))
+
+                        IF (is_sequential) THEN
+            !                  klon_mpi_begin=1
+            !                  klon_mpi_end=klon
+                              DO n=1, nlev
+                                    DO ip=1, npstn
+                                          fieldok(ip,n)=buffer_omp(nptabij(ip),n)
+                                    ENDDO
+                              ENDDO
+                        ELSE
+                              DO n=1, nlev
+                                    DO ip=1, npstn
+                                                IF(nptabij(ip).GE.klon_mpi_begin.AND. &
+                                                      nptabij(ip).LE.klon_mpi_end) THEN
+                                                fieldok(ip,n)=buffer_omp(nptabij(ip)-klon_mpi_begin+1,n)
+                                          ENDIF
+                                    ENDDO
+                              ENDDO
+                        ENDIF
+                        CALL histwrite(nid_files(iff),var%name,itau_iophy,fieldok,npstn*nlev,index3d)
+                  ENDIF 
+                  deallocate(index3d)
+                  deallocate(fieldok)
+            ENDIF
+      ENDDO
+!$OMP END MASTER   
+  END SUBROUTINE histwrite3d_phy
+  
+end module iophy
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/iostart.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/iostart.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/iostart.F90	(revision 17)
@@ -0,0 +1,508 @@
+MODULE iostart
+
+PRIVATE
+    INTEGER,SAVE :: nid_start 
+    INTEGER,SAVE :: nid_restart
+    
+    INTEGER,SAVE :: idim1,idim2,idim3,idim4
+    INTEGER,PARAMETER :: length=100
+    
+    INTERFACE get_field
+      MODULE PROCEDURE Get_field_r1,Get_field_r2,Get_field_r3
+    END INTERFACE get_field
+    
+    INTERFACE get_var
+      MODULE PROCEDURE get_var_r0,Get_var_r1,Get_var_r2,Get_var_r3
+    END INTERFACE get_var
+
+    INTERFACE put_field
+      MODULE PROCEDURE put_field_r1,put_field_r2,put_field_r3
+    END INTERFACE put_field
+
+    INTERFACE put_var
+      MODULE PROCEDURE put_var_r0,put_var_r1,put_var_r2,put_var_r3
+    END INTERFACE put_var
+
+    PUBLIC get_field,get_var,put_field,put_var
+    PUBLIC Open_startphy,close_startphy,open_restartphy,close_restartphy
+    
+CONTAINS
+
+  SUBROUTINE Open_startphy(filename)
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: filename
+    INTEGER          :: ierr
+
+    IF (is_mpi_root .AND. is_omp_root) THEN
+      ierr = NF90_OPEN (filename, NF90_NOWRITE,nid_start)
+      IF (ierr.NE.NF90_NOERR) THEN
+        write(6,*)' Pb d''ouverture du fichier '//filename
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+    ENDIF
+   
+  END SUBROUTINE Open_startphy
+
+  SUBROUTINE Close_startphy
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    INTEGER          :: ierr
+
+    IF (is_mpi_root .AND. is_omp_root) THEN
+        ierr = NF90_CLOSE (nid_start)
+    ENDIF
+
+  END SUBROUTINE close_startphy
+
+
+  FUNCTION Inquire_Field(Field_name)
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: Field_name
+    LOGICAL :: inquire_field
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
+      IF (ierr==NF90_NOERR) THEN
+        Inquire_field=.TRUE.
+      ELSE
+        Inquire_field=.FALSE.
+      ENDIF
+    ENDIF
+
+    CALL bcast(Inquire_field)
+
+  END FUNCTION Inquire_Field
+  
+ 
+  SUBROUTINE Get_Field_r1(field_name,field,found)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
+    REAL,INTENT(INOUT)               :: Field(:)
+    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
+
+    IF (PRESENT(found)) THEN
+      CALL Get_field_rgen(field_name,field,1,found)
+    ELSE
+      CALL Get_field_rgen(field_name,field,1)
+    ENDIF
+      
+  END SUBROUTINE Get_Field_r1
+  
+  SUBROUTINE Get_Field_r2(field_name,field,found)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
+    REAL,INTENT(INOUT)               :: Field(:,:)
+    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
+
+    IF (PRESENT(found)) THEN
+      CALL Get_field_rgen(field_name,field,size(field,2),found)
+    ELSE
+      CALL Get_field_rgen(field_name,field,size(field,2))
+    ENDIF
+
+      
+  END SUBROUTINE Get_Field_r2
+  
+  SUBROUTINE Get_Field_r3(field_name,field,found)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN)    :: Field_name
+    REAL,INTENT(INOUT)               :: Field(:,:,:)
+    LOGICAL,INTENT(OUT),OPTIONAL   :: found 
+
+    IF (PRESENT(found)) THEN
+      CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3),found)
+    ELSE
+      CALL Get_field_rgen(field_name,field,size(field,2)*size(field,3))
+    ENDIF
+      
+  END SUBROUTINE Get_Field_r3
+  
+  SUBROUTINE Get_field_rgen(field_name,field,field_size,found)
+  USE netcdf
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: Field_name
+    INTEGER          :: field_size
+    REAL             :: field(klon,field_size)
+    LOGICAL,OPTIONAL :: found
+    
+    REAL    :: field_glo(klon_glo,field_size)
+    LOGICAL :: tmp_found
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+  
+      ierr=NF90_INQ_VARID(nid_start,Field_name,varid)
+      
+      IF (ierr==NF90_NOERR) THEN
+        CALL body(field_glo)
+        tmp_found=.TRUE.
+      ELSE
+        tmp_found=.FALSE.
+      ENDIF
+    
+    ENDIF
+    
+    CALL bcast(tmp_found)
+
+    IF (tmp_found) THEN
+      CALL scatter(field_glo,field)
+    ENDIF
+    
+    IF (PRESENT(found)) THEN
+      found=tmp_found
+    ELSE
+      IF (.NOT. tmp_found) THEN
+        PRINT*, 'phyetat0: Le champ <'//field_name//'> est absent'
+        CALL abort
+      ENDIF
+    ENDIF
+ 
+    
+    CONTAINS
+     
+     SUBROUTINE body(field_glo)
+       REAL :: field_glo(klon_glo*field_size)
+         ierr=NF90_GET_VAR(nid_start,varid,field_glo)
+         IF (ierr/=NF90_NOERR) THEN
+           ! La variable exist dans le fichier mais la lecture a echouee. 
+           PRINT*, 'phyetat0: Lecture echouee pour <'//field_name//'>'
+
+           IF (field_name=='CLWCON' .OR. field_name=='RNEBCON' .OR. field_name=='RATQS') THEN
+              ! Essaye de lire le variable sur surface uniqument, comme fait avant
+              field_glo(:)=0.
+              ierr=NF90_GET_VAR(nid_start,varid,field_glo(1:klon_glo))
+              IF (ierr/=NF90_NOERR) THEN
+                 PRINT*, 'phyetat0: Lecture echouee aussi en 2D pour <'//field_name//'>'
+                 CALL abort
+              ELSE
+                 PRINT*, 'phyetat0: La variable <'//field_name//'> lu sur surface seulement'!, selon ancien format, le reste mis a zero'
+              END IF
+           ELSE
+              CALL abort
+           ENDIF
+         ENDIF
+
+     END SUBROUTINE body
+
+  END SUBROUTINE Get_field_rgen
+  
+
+  SUBROUTINE get_var_r0(var_name,var,found)
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(INOUT)             :: var
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+
+    REAL                         :: varout(1)
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_var_rgen(var_name,varout,size(varout),found)
+    ELSE
+      CALL Get_var_rgen(var_name,varout,size(varout))
+    ENDIF
+    var=varout(1)
+ 
+  END SUBROUTINE get_var_r0
+
+  SUBROUTINE get_var_r1(var_name,var,found)
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(INOUT)             :: var(:)
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_var_rgen(var_name,var,size(var),found)
+    ELSE
+      CALL Get_var_rgen(var_name,var,size(var))
+    ENDIF
+  
+  END SUBROUTINE get_var_r1
+
+  SUBROUTINE get_var_r2(var_name,var,found)
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(OUT)             :: var(:,:)
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_var_rgen(var_name,var,size(var),found)
+    ELSE
+      CALL Get_var_rgen(var_name,var,size(var))
+    ENDIF
+  
+  END SUBROUTINE get_var_r2
+
+  SUBROUTINE get_var_r3(var_name,var,found)
+  IMPLICIT NONE  
+    CHARACTER(LEN=*),INTENT(IN)  :: var_name
+    REAL,INTENT(INOUT)             :: var(:,:,:)
+    LOGICAL,OPTIONAL,INTENT(OUT) :: found
+    
+    IF (PRESENT(found)) THEN
+      CALL Get_var_rgen(var_name,var,size(var),found)
+    ELSE
+      CALL Get_var_rgen(var_name,var,size(var))
+    ENDIF
+  
+  END SUBROUTINE get_var_r3
+
+  SUBROUTINE Get_var_rgen(var_name,var,var_size,found)
+  USE netcdf
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    CHARACTER(LEN=*) :: var_name
+    INTEGER          :: var_size
+    REAL             :: var(var_size)
+    LOGICAL,OPTIONAL :: found
+    
+    LOGICAL :: tmp_found
+    INTEGER :: varid
+    INTEGER :: ierr
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+  
+      ierr=NF90_INQ_VARID(nid_start,var_name,varid)
+      
+      IF (ierr==NF90_NOERR) THEN
+        ierr=NF90_GET_VAR(nid_start,varid,var)
+        IF (ierr/=NF90_NOERR) THEN
+          PRINT*, 'phyetat0: Lecture echouee pour <'//var_name//'>'
+          CALL abort
+        ENDIF
+        tmp_found=.TRUE.
+      ELSE
+        tmp_found=.FALSE.
+      ENDIF
+    
+    ENDIF
+    
+    CALL bcast(tmp_found)
+
+    IF (tmp_found) THEN
+      CALL bcast(var)
+    ENDIF
+    
+    IF (PRESENT(found)) THEN
+      found=tmp_found
+    ELSE
+      IF (.NOT. tmp_found) THEN
+        PRINT*, 'phyetat0: La variable champ <'//var_name//'> est absente'
+        CALL abort
+      ENDIF
+    ENDIF
+
+  END SUBROUTINE Get_var_rgen
+
+
+  SUBROUTINE open_restartphy(filename)
+  USE netcdf
+  USE mod_phys_lmdz_para
+  USE mod_grid_phy_lmdz
+  USE dimphy
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(IN) :: filename
+    INTEGER                     :: ierr
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+      ierr = NF90_CREATE(filename, NF90_CLOBBER, nid_restart)
+      IF (ierr/=NF90_NOERR) THEN
+        write(6,*)' Pb d''ouverture du fichier '//filename
+        write(6,*)' ierr = ', ierr
+        CALL ABORT
+      ENDIF
+
+      ierr = NF90_PUT_ATT (nid_restart, NF90_GLOBAL, "title","Fichier redemmarage physique")
+
+      ierr = NF90_DEF_DIM (nid_restart, "index", length, idim1)
+      ierr = NF90_DEF_DIM (nid_restart, "points_physiques", klon_glo, idim2)
+      ierr = NF90_DEF_DIM (nid_restart, "horizon_vertical", klon_glo*klev, idim3)
+      ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4)
+
+      ierr = NF90_ENDDEF(nid_restart)
+    ENDIF
+
+  END SUBROUTINE open_restartphy
+  
+  SUBROUTINE close_restartphy
+  USE netcdf
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+    INTEGER          :: ierr
+
+    IF (is_mpi_root .AND. is_omp_root) THEN
+      ierr = NF90_CLOSE (nid_restart)
+    ENDIF
+ 
+  END SUBROUTINE close_restartphy
+
+  
+  SUBROUTINE put_field_r1(field_name,title,field)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  REAL,INTENT(IN)                :: field(:)
+  
+    CALL put_field_rgen(field_name,title,field,1)
+  
+  END SUBROUTINE put_field_r1
+
+  SUBROUTINE put_field_r2(field_name,title,field)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  REAL,INTENT(IN)                :: field(:,:)
+  
+    CALL put_field_rgen(field_name,title,field,size(field,2))
+  
+  END SUBROUTINE put_field_r2
+
+  SUBROUTINE put_field_r3(field_name,title,field)
+  IMPLICIT NONE
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  REAL,INTENT(IN)                :: field(:,:,:)
+  
+    CALL put_field_rgen(field_name,title,field,size(field,2)*size(field,3))
+  
+  END SUBROUTINE put_field_r3
+  
+  SUBROUTINE put_field_rgen(field_name,title,field,field_size)
+  USE netcdf
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+  CHARACTER(LEN=*),INTENT(IN)    :: field_name
+  CHARACTER(LEN=*),INTENT(IN)    :: title
+  INTEGER,INTENT(IN)             :: field_size
+  REAL,INTENT(IN)                :: field(klon,field_size)
+  
+  REAL                           :: field_glo(klon_glo,field_size)
+  INTEGER                        :: ierr
+  INTEGER                        :: nvarid
+  INTEGER                        :: idim
+   
+   
+    CALL gather(field,field_glo)
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+
+      IF (field_size==1) THEN
+        idim=idim2
+      ELSE IF (field_size==klev) THEN
+        idim=idim3
+      ELSE IF (field_size==klevp1) THEN
+        idim=idim4
+      ELSE
+        PRINT *, "erreur phyredem : probleme de dimension"
+        CALL ABORT
+      ENDIF
+         
+      ierr = NF90_REDEF (nid_restart)
+#ifdef NC_DOUBLE
+      ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid)
+#else
+      ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_FLOAT,(/ idim /),nvarid)
+#endif
+      IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
+      ierr = NF90_ENDDEF(nid_restart)
+      ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/)))
+    ENDIF
+    
+   END SUBROUTINE put_field_rgen  
+  
+   SUBROUTINE put_var_r0(var_name,title,var)
+   IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var
+     REAL                        :: varin(1)
+     
+     varin(1)=var
+     
+     CALL put_var_rgen(var_name,title,varin,size(varin))
+
+  END SUBROUTINE put_var_r0
+
+
+   SUBROUTINE put_var_r1(var_name,title,var)
+   IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var(:)
+     
+     CALL put_var_rgen(var_name,title,var,size(var))
+
+  END SUBROUTINE put_var_r1
+ 
+  SUBROUTINE put_var_r2(var_name,title,var)
+   IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var(:,:)
+     
+     CALL put_var_rgen(var_name,title,var,size(var))
+
+  END SUBROUTINE put_var_r2     
+  
+  SUBROUTINE put_var_r3(var_name,title,var)
+   IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     REAL,INTENT(IN)             :: var(:,:,:)
+     
+     CALL put_var_rgen(var_name,title,var,size(var))
+
+  END SUBROUTINE put_var_r3
+
+  SUBROUTINE put_var_rgen(var_name,title,var,var_size)
+  USE netcdf
+  USE dimphy
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+     CHARACTER(LEN=*),INTENT(IN) :: var_name
+     CHARACTER(LEN=*),INTENT(IN) :: title
+     INTEGER,INTENT(IN)          :: var_size
+     REAL,INTENT(IN)             :: var(var_size)
+     
+     INTEGER :: ierr
+     INTEGER :: nvarid
+         
+    IF (is_mpi_root .AND. is_omp_root) THEN
+
+      IF (var_size/=length) THEN
+        PRINT *, "erreur phyredem : probleme de dimension"
+        CALL abort
+      ENDIF
+      
+      ierr = NF90_REDEF (nid_restart)
+
+#ifdef NC_DOUBLE
+      ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid)
+#else
+      ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid)
+#endif
+      IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title)
+      ierr = NF90_ENDDEF(nid_restart)
+     
+      ierr = NF90_PUT_VAR(nid_restart,nvarid,var)
+
+    ENDIF
+    
+  END SUBROUTINE put_var_rgen     
+    
+END MODULE iostart
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/limit_read_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/limit_read_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/limit_read_mod.F90	(revision 17)
@@ -0,0 +1,343 @@
+!
+! $Header$
+!
+MODULE limit_read_mod
+!
+! This module reads the fichier "limit.nc" containing fields for surface forcing.
+!
+! Module subroutines :
+!  limit_read_frac    : call limit_read_tot and return the fractions
+!  limit_read_rug_alb : return rugosity and albedo, if coupled ocean call limit_read_tot first
+!  limit_read_sst     : return sea ice temperature   
+!  limit_read_tot     : read limit.nc and store the fields in local modules variables
+!
+  IMPLICIT NONE
+
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE, PRIVATE :: pctsrf
+!$OMP THREADPRIVATE(pctsrf)
+  REAL, ALLOCATABLE, DIMENSION(:),   SAVE, PRIVATE :: rugos
+!$OMP THREADPRIVATE(rugos)
+  REAL, ALLOCATABLE, DIMENSION(:),   SAVE, PRIVATE :: albedo
+!$OMP THREADPRIVATE(albedo)  
+  REAL, ALLOCATABLE, DIMENSION(:),   SAVE, PRIVATE :: sst
+!$OMP THREADPRIVATE(sst)  
+  LOGICAL,SAVE :: read_continents=.FALSE.
+!$OMP THREADPRIVATE(read_continents) 
+
+CONTAINS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!
+!! Public subroutines :
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE limit_read_frac(itime, dtime, jour, pctsrf_new, is_modified)
+!
+! This subroutine is called from "change_srf_frac" for case of 
+! ocean=force or from ocean_slab_frac for ocean=slab.
+! The fraction for all sub-surfaces at actual time step is returned.
+
+    USE dimphy
+    USE indice_sol_mod
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN) :: itime   ! time step
+    INTEGER, INTENT(IN) :: jour    ! current day
+    REAL   , INTENT(IN) :: dtime   ! length of time step
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon,nbsrf), INTENT(OUT) :: pctsrf_new  ! sub surface fractions
+    LOGICAL, INTENT(OUT)                     :: is_modified ! true if pctsrf is modified at this time step
+
+! End declaration
+!****************************************************************************************
+
+! 1) Read file limit.nc
+    CALL limit_read_tot(itime, dtime, jour, is_modified)
+
+! 2) Return the fraction read in limit_read_tot
+    pctsrf_new(:,:) = pctsrf(:,:)
+    
+  END SUBROUTINE limit_read_frac
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE limit_read_rug_alb(itime, dtime, jour, &
+       knon, knindex, &
+       rugos_out, alb_out)
+!
+! This subroutine is called from surf_land_bucket. 
+! The flag "ok_veget" must can not be true. If coupled run, "ocean=couple"
+! then this routine will call limit_read_tot.
+!
+    USE dimphy
+    USE surface_data
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN) :: itime                     ! numero du pas de temps courant
+    INTEGER, INTENT(IN) :: jour                      ! jour a lire dans l'annee
+    REAL   , INTENT(IN) :: dtime                     ! pas de temps de la physique (en s)
+    INTEGER, INTENT(IN) :: knon                      ! nomber of points on compressed grid
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex  ! grid point number for compressed grid
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT) :: rugos_out
+    REAL, DIMENSION(klon), INTENT(OUT) :: alb_out
+    
+! Local variables
+!****************************************************************************************
+    INTEGER :: i
+    LOGICAL :: is_modified
+!****************************************************************************************
+
+    IF (type_ocean == 'couple') THEN
+       ! limit.nc has not yet been read. Do it now!
+       CALL limit_read_tot(itime, dtime, jour, is_modified)
+    END IF
+
+    DO i=1,knon
+       rugos_out(i) = rugos(knindex(i))
+       alb_out(i)  = albedo(knindex(i))
+    END DO
+
+  END SUBROUTINE limit_read_rug_alb
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE limit_read_sst(knon, knindex, sst_out)
+!
+! This subroutine returns the sea surface temperature already read from limit.nc.
+!
+    USE dimphy, ONLY : klon
+
+    INTEGER, INTENT(IN)                  :: knon     ! nomber of points on compressed grid
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex  ! grid point number for compressed grid
+    REAL, DIMENSION(klon), INTENT(OUT)   :: sst_out
+
+    INTEGER :: i
+
+    PRINT *,'  Lluis: knon: ',knon,' sst_out: ',UBOUND(sst_out),' : ',UBOUND(sst), 'x', UBOUND(knindex)
+
+    DO i = 1, knon
+       sst_out(i) = sst(knindex(i))
+    END DO
+
+  END SUBROUTINE limit_read_sst
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!
+!! Private subroutine :
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE limit_read_tot(itime, dtime, jour, is_modified)
+!
+! Read everything needed from limit.nc
+!
+! 0) Initialize
+! 1) Open the file limit.nc, if it is time
+! 2) Read fraction, if not type_ocean=couple
+! 3) Read sea surface temperature, if not type_ocean=couple
+! 4) Read albedo and rugosity for land surface, only in case of no vegetation model
+! 5) Close file and distribuate variables to all processus
+
+    USE dimphy
+    USE mod_grid_phy_lmdz
+    USE mod_phys_lmdz_para
+    USE surface_data, ONLY : type_ocean, ok_veget
+    USE netcdf
+    USE indice_sol_mod
+
+    IMPLICIT NONE
+    
+    INCLUDE "iniprint.h"
+
+! In- and ouput arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN) :: itime   ! numero du pas de temps courant
+    INTEGER, INTENT(IN) :: jour    ! jour a lire dans l'annee
+    REAL   , INTENT(IN) :: dtime   ! pas de temps de la physique (en s)
+
+    LOGICAL, INTENT(OUT) :: is_modified  ! true if pctsrf is modified at this time step
+
+! Locals variables with attribute SAVE
+!****************************************************************************************
+! frequence de lecture des conditions limites (en pas de physique) 
+    INTEGER,SAVE                              :: lmt_pas
+!$OMP THREADPRIVATE(lmt_pas) 
+    LOGICAL, SAVE                             :: first_call=.TRUE.
+!$OMP THREADPRIVATE(first_call)  
+    INTEGER, SAVE                             :: jour_lu = -1
+!$OMP THREADPRIVATE(jour_lu)  
+! Locals variables
+!****************************************************************************************
+    INTEGER                                   :: nid, nvarid
+    INTEGER                                   :: ii, ierr
+    INTEGER, DIMENSION(2)                     :: start, epais
+    REAL, DIMENSION(klon_glo,nbsrf)           :: pct_glo  ! fraction at global grid
+    REAL, DIMENSION(klon_glo)                 :: sst_glo  ! sea-surface temperature at global grid
+    REAL, DIMENSION(klon_glo)                 :: rug_glo  ! rugosity at global grid
+    REAL, DIMENSION(klon_glo)                 :: alb_glo  ! albedo at global grid
+    CHARACTER(len=20)                         :: modname='limit_read_mod'     
+
+! End declaration
+!****************************************************************************************
+
+!****************************************************************************************
+! 0) Initialization
+!
+!****************************************************************************************
+    IF (first_call) THEN
+       ! calculate number of time steps for one day
+       lmt_pas = NINT(86400./dtime * 1.0)
+       
+       ! Allocate module save variables
+       IF ( type_ocean /= 'couple' ) THEN
+          ALLOCATE(pctsrf(klon,nbsrf), sst(klon), stat=ierr)
+          IF (ierr /= 0) CALL abort_gcm(modname, 'PB in allocating pctsrf and sst',1)
+       END IF
+
+       IF ( .NOT. ok_veget ) THEN
+          ALLOCATE(rugos(klon), albedo(klon), stat=ierr)
+          IF (ierr /= 0) CALL abort_gcm(modname, 'PB in allocating rugos and albedo',1)
+       END IF
+
+       first_call=.FALSE.
+    ENDIF
+  
+!****************************************************************************************
+! 1) Open the file limit.nc if it is the right moment to read, once a day.
+!    The file is read only by the master thread of the master mpi process(is_mpi_root)
+!
+!****************************************************************************************
+
+    is_modified = .FALSE.
+    IF (MOD(itime-1, lmt_pas) == 0 .OR. jour_lu /= jour ) THEN   ! time to read
+       jour_lu = jour
+       is_modified = .TRUE.
+!$OMP MASTER  ! Only master thread
+       IF (is_mpi_root) THEN ! Only master processus
+
+          ierr = NF90_OPEN ('limit.nc', NF90_NOWRITE, nid)
+          IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,&
+               'Pb d''ouverture du fichier de conditions aux limites',1)
+          
+          ! La tranche de donnees a lire:
+          start(1) = 1
+          start(2) = jour
+          epais(1) = klon_glo
+          epais(2) = 1
+
+
+!****************************************************************************************
+! 2) Read fraction if not type_ocean=couple
+!
+!****************************************************************************************
+
+          IF ( type_ocean /= 'couple') THEN
+!
+! Ocean fraction
+             ierr = NF90_INQ_VARID(nid, 'FOCE', nvarid)
+             IF (ierr /= NF90_NOERR) CALL abort_gcm(modname, 'Le champ <FOCE> est absent',1)
+             
+             ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_oce),start,epais)
+             IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour <FOCE>' ,1)
+!
+! Sea-ice fraction
+             ierr = NF90_INQ_VARID(nid, 'FSIC', nvarid)
+             IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ <FSIC> est absent',1)
+
+             ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_sic),start,epais)
+             IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour <FSIC>' ,1)
+
+
+! Read land and continentals fraction only if asked for
+             IF (read_continents .OR. itime == 1) THEN
+!
+! Land fraction
+                ierr = NF90_INQ_VARID(nid, 'FTER', nvarid)
+                IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ <FTER> est absent',1)
+                
+                ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_ter),start,epais)
+                IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour <FTER>',1)
+!
+! Continentale ice fraction
+                ierr = NF90_INQ_VARID(nid, 'FLIC', nvarid)
+                IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ <FLIC> est absent',1)
+
+                ierr = NF90_GET_VAR(nid,nvarid,pct_glo(:,is_lic),start,epais)
+                IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour <FLIC>',1)
+             END IF
+
+          END IF ! type_ocean /= couple
+
+!****************************************************************************************
+! 3) Read sea-surface temperature, if not coupled ocean
+!
+!****************************************************************************************
+          IF ( type_ocean /= 'couple') THEN
+
+             ierr = NF90_INQ_VARID(nid, 'SST', nvarid)
+             IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ <SST> est absent',1)
+
+             ierr = NF90_GET_VAR(nid,nvarid,sst_glo,start,epais)
+             IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour <SST>',1)
+          
+          END IF
+
+!****************************************************************************************
+! 4) Read albedo and rugosity for land surface, only in case of no vegetation model
+!
+!****************************************************************************************
+
+          IF (.NOT. ok_veget) THEN
+!
+! Read albedo
+             ierr = NF90_INQ_VARID(nid, 'ALB', nvarid)
+             IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ <ALB> est absent',1)
+
+             ierr = NF90_GET_VAR(nid,nvarid,alb_glo,start,epais)
+             IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour <ALB>',1)
+!
+! Read rugosity
+             ierr = NF90_INQ_VARID(nid, 'RUG', nvarid)
+             IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Le champ <RUG> est absent',1)
+
+             ierr = NF90_GET_VAR(nid,nvarid,rug_glo,start,epais)
+             IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Lecture echouee pour <RUG>',1)
+
+          END IF
+
+!****************************************************************************************
+! 5) Close file and distribuate variables to all processus
+!
+!****************************************************************************************
+          ierr = NF90_CLOSE(nid)
+          IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Pb when closing file', 1)
+       ENDIF ! is_mpi_root
+
+!$OMP END MASTER
+!$OMP BARRIER
+
+       IF ( type_ocean /= 'couple') THEN
+          CALL Scatter(sst_glo,sst)
+          CALL Scatter(pct_glo(:,is_oce),pctsrf(:,is_oce))
+          CALL Scatter(pct_glo(:,is_sic),pctsrf(:,is_sic))
+          IF (read_continents .OR. itime == 1) THEN
+             CALL Scatter(pct_glo(:,is_ter),pctsrf(:,is_ter))
+             CALL Scatter(pct_glo(:,is_lic),pctsrf(:,is_lic))
+          END IF
+       END IF
+
+       IF (.NOT. ok_veget) THEN
+          CALL Scatter(alb_glo, albedo)
+          CALL Scatter(rug_glo, rugos)
+       END IF
+
+    ENDIF ! time to read
+
+  END SUBROUTINE limit_read_tot
+
+
+END MODULE limit_read_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/limit_slab.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/limit_slab.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/limit_slab.F90	(revision 17)
@@ -0,0 +1,122 @@
+! $Header$
+
+SUBROUTINE limit_slab(itime, dtime, jour, lmt_bils, lmt_foce, diff_sst)
+
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE netcdf 
+  USE indice_sol_mod
+
+  IMPLICIT NONE
+
+  INCLUDE "temps.h"
+  INCLUDE "clesphys.h"
+  INCLUDE "dimensions.h"
+
+! In- and ouput arguments
+!****************************************************************************************
+  INTEGER, INTENT(IN) :: itime   ! numero du pas de temps courant
+  INTEGER, INTENT(IN) :: jour    ! jour a lire dans l'annee
+  REAL   , INTENT(IN) :: dtime   ! pas de temps de la physique (en s)
+  REAL, DIMENSION(klon), INTENT(OUT) :: lmt_bils, lmt_foce, diff_sst
+
+! Locals variables with attribute SAVE
+!****************************************************************************************
+  REAL, DIMENSION(:), ALLOCATABLE, SAVE :: bils_save, foce_save
+!$OMP THREADPRIVATE(bils_save, foce_save)
+
+! Locals variables
+!****************************************************************************************
+  INTEGER                  :: lmt_pas   
+  INTEGER                  :: nvarid, nid, ierr, i
+  INTEGER, DIMENSION(2)    :: start, epais 
+  REAL, DIMENSION(klon_glo):: bils_glo, foce_glo, sst_l_glo, sst_lp1_glo, diff_sst_glo
+  CHARACTER (len = 20)     :: modname = 'limit_slab'
+
+! End declaration
+!****************************************************************************************
+
+  ! calculate number of time steps for one day
+  lmt_pas = NINT(86400./dtime)
+  
+  IF (MOD(itime-1, lmt_pas) == 0) THEN   ! time to read
+     !$OMP MASTER  ! Only master thread
+     IF (is_mpi_root) THEN ! Only master processus
+        print*,'in limit_slab time to read, itime=',itime
+        
+        ierr = NF90_OPEN ('limit_slab.nc', NF90_NOWRITE, nid)
+        IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,&
+             'Pb in opening file limit_slab.nc',1)
+        
+        ! La tranche de donnees a lire:
+        start(1) = 1
+        start(2) = jour
+        epais(1) = klon_glo
+        epais(2) = 1
+
+!****************************************************************************************
+! 2) Read bils and ocean fraction
+!
+!****************************************************************************************
+!
+! Read bils_glo
+        ierr = NF90_INQ_VARID(nid, 'BILS_OCE', nvarid)
+        IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'The variable <BILS_OCE> is abstent',1)
+
+        ierr = NF90_GET_VAR(nid,nvarid,bils_glo,start,epais)
+        IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Reading of <BILS_OCE> failed',1)
+!
+! Read foce_glo
+        ierr = NF90_INQ_VARID(nid, 'FOCE', nvarid)
+        IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'The variable <FOCE> is abstent',1)
+
+        ierr = NF90_GET_VAR(nid,nvarid,foce_glo,start,epais)
+        IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Reading of <FOCE> failed',1)
+!
+! Read sst_glo for this day
+        ierr = NF90_INQ_VARID(nid, 'SST', nvarid)
+        IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'The variable <SST> is abstent',1)
+
+        ierr = NF90_GET_VAR(nid,nvarid,sst_l_glo,start,epais)
+        IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Reading of <SST> failed',1)
+
+! Read sst_glo for one day ahead
+        start(2) = jour + 1
+        IF (start(2) > 360) start(2)=1
+        ierr = NF90_GET_VAR(nid,nvarid,sst_lp1_glo,start,epais)
+        IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Reading of <SST> day+1 failed',1)
+
+! Calculate difference in temperature between this day and one ahead
+        DO i=1, klon_glo-1
+           diff_sst_glo(i) = sst_lp1_glo(i) - sst_l_glo(i)
+        END DO
+        diff_sst_glo(klon_glo) = sst_lp1_glo(klon_glo) - sst_l_glo(1)
+
+!****************************************************************************************
+! 5) Close file and distribuate variables to all processus
+!
+!****************************************************************************************
+        ierr = NF90_CLOSE(nid)
+        IF (ierr /= NF90_NOERR) CALL abort_gcm(modname,'Pb when closing file', 1)
+     ENDIF ! is_mpi_root
+
+!$OMP END MASTER
+       
+     IF (.NOT. ALLOCATED(bils_save)) THEN
+        ALLOCATE(bils_save(klon), foce_save(klon), stat=ierr)
+        IF (ierr /= 0) CALL abort_gcm('limit_slab', 'pb in allocation',1)
+     END IF
+
+     CALL Scatter(bils_glo, bils_save)
+     CALL Scatter(foce_glo, foce_save)
+     CALL Scatter(diff_sst_glo, diff_sst)
+     
+  ELSE ! not time to read
+     diff_sst(:) = 0.
+  ENDIF ! time to read
+
+  lmt_bils(:) = bils_save(:)
+  lmt_foce(:) = foce_save(:)
+  
+END SUBROUTINE limit_slab
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/lmdz_wrf_variables_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/lmdz_wrf_variables_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/lmdz_wrf_variables_mod.F90	(revision 17)
@@ -0,0 +1,159 @@
+MODULE lmdz_wrf_variables_mod
+! Module to initialize LMDZ variables to be accessible from WRF
+
+  IMPLICIT NONE
+
+! L. Fita, November 2013. Making them accessible. 
+    REAL, ALLOCATABLE, DIMENSION(:),   SAVE              :: albedo
+!$OMP THREADPRIVATE(albedo)  
+    REAL, ALLOCATABLE, DIMENSION(:),   SAVE              :: sst
+!$OMP THREADPRIVATE(sst)  
+!!    REAL, ALLOCATABLE, DIMENSION(:),   SAVE              :: snow
+!!!$OMP THREADPRIVATE(snow)  
+!    REAL, ALLOCATABLE, DIMENSION(:),   SAVE              :: run_off_lic
+!!$OMP THREADPRIVATE(run_off_lic)  
+  LOGICAL,SAVE :: read_continents=.FALSE.
+!$OMP THREADPRIVATE(read_continents) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: restart_runoff
+!$OMP THREADPRIVATE(restart_runoff) 
+!!    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: run_off_lic_0
+!!$OMP THREADPRIVATE(run_off_lic_0) 
+!    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: tsurf_lim
+!    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: z0_lim
+!    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: alb_lim
+    REAL, ALLOCATABLE, DIMENSION(:),   SAVE              :: phy_glo
+!$OMP THREADPRIVATE(phy_glo)  
+
+! This is already initialized by phys_state_var_mod
+!    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: pctsrf
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: pct_glo
+!$OMP THREADPRIVATE(pct_glo) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: sst_glo
+!$OMP THREADPRIVATE(sst_glo) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: alb_glo
+!$OMP THREADPRIVATE(alb_glo) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: rug_glo
+!$OMP THREADPRIVATE(rug_glo) 
+
+!!    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: qsol
+!$OMP THREADPRIVATE(qsol) 
+!!    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: fder
+!$OMP THREADPRIVATE(fder) 
+!!    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: snow
+!!$OMP THREADPRIVATE(snow) 
+!!    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: qsurf
+!$OMP THREADPRIVATE(qsurf) 
+!!    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: evap
+!$OMP THREADPRIVATE(evap) 
+!!    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: rugos
+!$OMP THREADPRIVATE(rugos) 
+!!    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: agesno
+!$OMP THREADPRIVATE(agesno) 
+!!    REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE            :: ftsoil
+!$OMP THREADPRIVATE(ftsoil) 
+
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: qsol_rst
+!$OMP THREADPRIVATE(qsol_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: fder_rst
+!$OMP THREADPRIVATE(fder_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: snow_rst
+!$OMP THREADPRIVATE(snow_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: qsurf_rst
+!$OMP THREADPRIVATE(qsurf_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: evap_rst
+!$OMP THREADPRIVATE(evap_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: rugos_rst
+!$OMP THREADPRIVATE(rugos_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: agesno_rst
+!$OMP THREADPRIVATE(agesno_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE            :: ftsoil_rst
+!$OMP THREADPRIVATE(ftsoil_rst) 
+
+  CONTAINS
+
+  SUBROUTINE lmdz_vars_init(klon)
+! Subroutine to initialize limit variables
+
+    USE mod_grid_phy_lmdz, ONLY: klon_glo
+    USE indice_sol_mod
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "dimsoil.h"
+
+    INTEGER, INTENT(IN)                                  :: klon
+
+    IF (ALLOCATED(albedo)) DEALLOCATE(albedo)
+    ALLOCATE(albedo(klon))
+    IF (ALLOCATED(sst)) DEALLOCATE(sst)
+    ALLOCATE(sst(klon))
+!!    IF (ALLOCATED(snow)) DEALLOCATE(snow)
+!!    ALLOCATE(snow(klon))
+!!    IF (ALLOCATED(run_off_lic)) DEALLOCATE(run_off_lic)
+!!    ALLOCATE(run_off_lic(klon))
+    IF (ALLOCATED(phy_glo)) DEALLOCATE(phy_glo)
+    ALLOCATE(phy_glo(klon))
+
+    IF (ALLOCATED(restart_runoff)) DEALLOCATE(restart_runoff)
+    ALLOCATE(restart_runoff(klon))
+!!    IF (ALLOCATED(run_off_lic_0)) DEALLOCATE(run_off_lic_0)
+!!    ALLOCATE(run_off_lic_0(klon))
+!    IF (ALLOCATED(tsurf_lim)) DEALLOCATE(tsurf_lim)
+!    ALLOCATE(tsurf_lim(klon))
+!    IF (ALLOCATED(z0_lim)) DEALLOCATE(z0_lim)
+!    ALLOCATE(z0_lim(klon))
+!    IF (ALLOCATED(alb_lim)) DEALLOCATE(alb_lim)
+!    ALLOCATE(alb_lim(klon))
+
+! This is already initialized by phys_state_var_mod
+!    IF (ALLOCATED(pctsrf)) DEALLOCATE(pctsrf)
+!    ALLOCATE(pctsrf(klon,nbsrf))
+    IF (ALLOCATED(pct_glo)) DEALLOCATE(pct_glo)
+    ALLOCATE(pct_glo(klon_glo,nbsrf))
+    IF (ALLOCATED(sst_glo)) DEALLOCATE(sst_glo)
+    ALLOCATE(sst_glo(klon_glo))
+    IF (ALLOCATED(alb_glo)) DEALLOCATE(alb_glo)
+    ALLOCATE(alb_glo(klon_glo))
+    IF (ALLOCATED(rug_glo)) DEALLOCATE(rug_glo)
+    ALLOCATE(rug_glo(klon_glo))
+
+!!    IF (ALLOCATED(qsol)) DEALLOCATE(qsol)
+!!    ALLOCATE(qsol(klon))
+!!    IF (ALLOCATED(fder)) DEALLOCATE(fder)
+!!    ALLOCATE(fder(klon))
+!!    IF (ALLOCATED(snow)) DEALLOCATE(snow)
+!!    ALLOCATE(snow(klon, nbsrf))
+!!    IF (ALLOCATED(qsurf)) DEALLOCATE(qsurf)
+!!    ALLOCATE(qsurf(klon, nbsrf))
+!!    IF (ALLOCATED(evap)) DEALLOCATE(evap)
+!!    ALLOCATE(evap(klon, nbsrf))
+!!    IF (ALLOCATED(rugos)) DEALLOCATE(rugos)
+!!    ALLOCATE(rugos(klon, nbsrf))
+!!    IF (ALLOCATED(agesno)) DEALLOCATE(agesno)
+!!    ALLOCATE(agesno(klon, nbsrf))
+!!    IF (ALLOCATED(ftsoil)) DEALLOCATE(ftsoil)
+!!    ALLOCATE(ftsoil(klon, nsoilmx, nbsrf))
+
+    IF (ALLOCATED(qsol_rst)) DEALLOCATE(qsol_rst)
+    ALLOCATE(qsol_rst(klon))
+    IF (ALLOCATED(fder_rst)) DEALLOCATE(fder_rst)
+    ALLOCATE(fder_rst(klon))
+    IF (ALLOCATED(snow_rst)) DEALLOCATE(snow_rst)
+    ALLOCATE(snow_rst(klon, nbsrf))
+    IF (ALLOCATED(qsurf_rst)) DEALLOCATE(qsurf_rst)
+    ALLOCATE(qsurf_rst(klon, nbsrf))
+    IF (ALLOCATED(evap_rst)) DEALLOCATE(evap_rst)
+    ALLOCATE(evap_rst(klon, nbsrf))
+    IF (ALLOCATED(rugos_rst)) DEALLOCATE(rugos_rst)
+    ALLOCATE(rugos_rst(klon, nbsrf))
+    IF (ALLOCATED(agesno_rst)) DEALLOCATE(agesno_rst)
+    ALLOCATE(agesno_rst(klon, nbsrf))
+    IF (ALLOCATED(ftsoil_rst)) DEALLOCATE(ftsoil_rst)
+    ALLOCATE(ftsoil_rst(klon, nsoilmx, nbsrf))
+
+    RETURN
+
+  END SUBROUTINE lmdz_vars_init
+
+END MODULE lmdz_wrf_variables_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/logic.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/logic.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/logic.h	(revision 17)
@@ -0,0 +1,25 @@
+!
+! $Id: logic.h 1520 2011-05-23 11:37:09Z emillour $
+!
+!
+! NB: keep items of different kinds in seperate common blocs to avoid
+!     "misaligned commons" issues
+!-----------------------------------------------------------------------
+! INCLUDE 'logic.h'
+
+      COMMON/logicl/ purmats,forward,leapf,apphys,                      &
+     &  statcl,conser,apdiss,apdelq,saison,ecripar,fxyhypb,ysinus       &
+     &  ,read_start,ok_guide,ok_strato,ok_gradsfile                     &
+     &  ,ok_limit,ok_etat0,grilles_gcm_netcdf,hybrid
+
+      COMMON/logici/ iflag_phys,iflag_trac
+      
+      LOGICAL purmats,forward,leapf,apphys,statcl,conser,               &
+     & apdiss,apdelq,saison,ecripar,fxyhypb,ysinus                      &
+     &  ,read_start,ok_guide,ok_strato,ok_gradsfile                     &
+     &  ,ok_limit,ok_etat0,grilles_gcm_netcdf
+      logical hybrid ! vertical coordinate is hybrid if true (sigma otherwise)
+                     ! (only used if disvert_type==2)
+
+      integer iflag_phys,iflag_trac
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/lsc_scav.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/lsc_scav.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/lsc_scav.F90	(revision 17)
@@ -0,0 +1,286 @@
+!$Id $
+
+SUBROUTINE lsc_scav(pdtime,it,iflag_lscav,oliq,flxr,flxs,rneb,beta_fisrt,  &
+                    beta_v1,pplay,paprs,t,tr_seri,d_tr_insc,          &
+                    d_tr_bcscav,d_tr_evap,qPrls) 
+  USE ioipsl
+  USE dimphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE traclmdz_mod
+  USE infotrac,ONLY : nbtr
+  USE comgeomphy
+  USE iophy
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : depot humide (lessivage et evaporation) de traceurs
+! Inspired by routines of Olivier Boucher (mars 1998)
+! author R. Pilon 10 octobre 2012
+! last modification 16/01/2013 (reformulation partie evaporation)
+!=====================================================================
+
+  include "dimensions.h"
+  include "chem.h"
+  include "YOMCST.h"
+  include "YOECUMF.h" 
+
+  REAL,INTENT(IN)                        :: pdtime ! time step (s)
+  INTEGER,INTENT(IN)                     :: it     ! tracer number
+  INTEGER,INTENT(IN)                     :: iflag_lscav ! LS scavenging param:
+!                                             3=Reddy_Boucher2004, 4=3+RPilon.
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxr     ! flux precipitant de pluie
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: flxs     ! flux precipitant de neige
+  REAL,INTENT(IN)                        :: oliq ! contenu en eau liquide dans le nuage (kg/kg)
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: rneb
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay    ! pression
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs    ! pression
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t        ! temperature
+! tracers
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)   :: tr_seri        ! q de traceur  
+  REAL,DIMENSION(klon,klev),INTENT(IN)        :: beta_fisrt     ! taux de conversion de l'eau cond
+  REAL,DIMENSION(klon,klev),INTENT(OUT)       :: beta_v1        ! -- (originale version)
+  REAL,DIMENSION(klon)                        :: his_dh         ! tendance de traceur integre verticalement
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_insc      ! tendance du traceur 
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_bcscav  ! tendance de traceur
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT)  :: d_tr_evap
+  REAL,DIMENSION(klon,nbtr),INTENT(OUT)       :: qPrls      !jyg: concentration tra dans pluie LS a la surf.
+  REAL :: dxin,dxev                              ! tendance temporaire de traceur incloud
+  REAL,DIMENSION(klon,klev) :: dxbc       ! tendance temporaire de traceur bc
+
+
+!  variables locales      
+ LOGICAL,SAVE :: debut=.true.
+!$OMP THREADPRIVATE(debut)
+!
+  REAL,PARAMETER :: henry=1.4  ! constante de Henry en mol/l/atm ~1.4 for gases
+  REAL           :: henry_t    !  constante de Henry a T t  (mol/l/atm)
+  REAL,PARAMETER :: kk=2900.   ! coefficient de dependence en T (K)
+  REAL :: f_a     !  rapport de la phase aqueuse a la phase gazeuse
+  REAL :: beta    !  taux de conversion de l'eau en pluie
+
+  INTEGER :: i, k
+  REAL,DIMENSION(klon,klev)    :: scav  !  water liquid content / fraction aqueuse du constituant
+  REAL,DIMENSION(klon,klev)    :: zrho
+  REAL,DIMENSION(klon,klev)    :: zdz
+  REAL,DIMENSION(klon,klev)    :: zmass ! layer mass
+
+  REAL           :: frac_ev       ! cste pour la reevaporation : dropplet shrinking
+!  frac_ev = frac_gas ou frac_aer
+  REAL,PARAMETER :: frac_gas=1.0  ! cste pour la reevaporation pour les gaz
+  REAL           :: frac_aer      ! cste pour la reevaporation pour les particules
+  REAL,DIMENSION(klon,klev) :: deltaP     ! P(i+1)-P(i)
+  REAL,DIMENSION(klon,klev) :: beta_ev    !  dP/P(i+1)
+
+!  101.325  m3/l x Pa/atm
+!  R        Pa.m3/mol/K
+!   cste de dissolution pour le depot humide
+  REAL,SAVE :: frac_fine_scav
+  REAL,SAVE :: frac_coar_scav
+!$OMP THREADPRIVATE(frac_fine_scav, frac_coar_scav)
+
+! below-cloud scav variables
+! aerosol : alpha_r=0.001, gas 0.001  (Pruppacher & Klett 1967)
+  REAL,SAVE :: alpha_r  !  coefficient d'impaction pour la pluie
+  REAL,SAVE :: alpha_s  !  coefficient d'impaction pour la neige  
+  REAL,SAVE :: R_r      !  mean raindrop radius (m) 
+  REAL,SAVE :: R_s      !  mean snow crystal radius (m)
+!$OMP THREADPRIVATE(alpha_r, alpha_s, R_r, R_s)
+  REAL           :: pr, ps, ice, water
+  real :: conserv
+!
+!!!!!!!!!!!!!!!!!!!! choix lessivage !!!!!!!!!!!!!!!!!!!!!!!!
+!!  logical,save  :: inscav_fisrt
+!!! $OMP THREADPRIVATE(inscav_first)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  IF (debut) THEN
+!
+!  inscav_fisrt=.true.
+!  call getin('inscav_fisrt',inscav_fisrt)
+!  if(inscav_fisrt) then 
+!   print*,'beta from fisrtilp.F90, beta = (z_cond - z_oliq)/z_cond, inscav_fisrt=',inscav_fisrt
+!  else
+!   print*,'beta from Reddy and Bocuher 2004 (original version), inscav_fisrt=',inscav_fisrt
+!  endif
+!
+      alpha_r=0.001        !  coefficient d'impaction pour la pluie
+      alpha_s=0.01         !  coefficient d'impaction pour la neige  
+      R_r=0.001            !  mean raindrop radius (m) 
+      R_s=0.001            !  mean snow crystal radius (m)
+      frac_fine_scav=0.7
+      frac_coar_scav=0.7
+!     frac_aer=0.5 ~ droplet size shrinks by evap
+      frac_aer=0.5
+!
+      OPEN(99,file='lsc_scav_param.data',status='old', &
+                form='formatted',err=9999)
+      READ(99,*,end=9998)  alpha_r
+      READ(99,*,end=9998)  alpha_s
+      READ(99,*,end=9998)  R_r
+      READ(99,*,end=9998)  R_s
+      READ(99,*,end=9998)  frac_fine_scav
+      READ(99,*,end=9998)  frac_coar_scav
+      READ(99,*,end=9998)  frac_aer
+9998  Continue
+      CLOSE(99)
+9999  Continue
+
+   print*,'alpha_r',alpha_r
+   print*,'alpha_s',alpha_s
+   print*,'R_r',R_r
+   print*,'R_s',R_s
+   print*,'frac_fine_scav',frac_fine_scav
+   print*,'frac_coar_scav',frac_coar_scav
+   print*,'frac_aer ev',frac_aer
+
+!
+  ENDIF !(debut)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! initialization
+  dxin=0.
+  dxev=0.
+  beta_ev=0.
+
+  DO i=1,klon
+   his_dh(i)=0.
+  ENDDO
+
+  DO k=1,klev
+   DO i=1, klon 
+    dxbc(i,k)=0.
+    beta_v1(i,k)=0.
+    deltaP(i,k)=0.
+   ENDDO
+  ENDDO
+
+  DO k=1,klev
+    DO i=1, klon
+     d_tr_insc(i,k,it)=0.
+     d_tr_bcscav(i,k,it)=0.
+     d_tr_evap(i,k,it)=0.
+    ENDDO
+  ENDDO
+
+!  pressure and size of the layer
+  DO k=klev-1, 1, -1
+   DO i=1, klon 
+     zrho(i,k)=pplay(i,k)/t(i,k)/RD   
+     zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
+     zmass(i,k)=(paprs(i,k)-paprs(i,k+1))/RG
+   ENDDO
+  ENDDO
+
+    IF (it.gt.1) THEN                               !  aerosol   
+      frac_ev=frac_aer
+    ELSE                                                !  gas
+      frac_ev=frac_gas
+    ENDIF
+
+    IF(it.gt.1) then  ! aerosol
+     DO k=1, klev
+      DO i=1, klon 
+       scav(i,k)=frac_fine_scav
+      ENDDO 
+     ENDDO
+    ELSE                  ! gas
+     DO k=1, klev
+      DO i=1, klon 
+       henry_t=henry*exp(-kk*(1./298.-1./t(i,k)))    !  mol/l/atm
+       f_a=henry_t/101.325*R*t(i,k)*oliq*zrho(i,k)/rho_water
+       scav(i,k)=f_a/(1.+f_a)
+      ENDDO 
+     ENDDO
+    ENDIF
+
+   DO k=klev-1, 1, -1
+    DO i=1, klon 
+!  incloud scavenging
+!   if(inscav_fisrt) then 
+   if (iflag_lscav .eq. 4) then
+      beta=beta_fisrt(i,k)*rneb(i,k)
+   else
+      beta=flxr(i,k)-flxr(i,k+1)+flxs(i,k)-flxs(i,k+1)
+!      beta=beta/zdz(i,k)/oliq/zrho(i,k)
+      beta=beta/zmass(i,k)/oliq
+      beta=MAX(0.,beta)
+   endif ! (iflag_lscav .eq. 4)
+   beta_v1(i,k)=beta    !! for output
+!
+      dxin=tr_seri(i,k,it)*(exp(-scav(i,k)*beta*pdtime)-1.)
+!      his_dh(i)=his_dh(i)-dxin*zrho(i,k)*zdz(i,k)/pdtime !  kg/m2/s
+      his_dh(i)=his_dh(i)-dxin*zmass(i,k)/pdtime !  kg/m2/s
+      d_tr_insc(i,k,it)=dxin
+
+!  below-cloud impaction
+    IF(it.eq.1) then
+      d_tr_bcscav(i,k,it)=0.
+    ELSE
+     pr=0.5*(flxr(i,k)+flxr(i,k+1))
+     ps=0.5*(flxs(i,k)+flxs(i,k+1))
+     water=pr*alpha_r/R_r/rho_water
+     ice=ps*alpha_s/R_s/rho_ice
+     dxbc(i,k)=-3./4.*tr_seri(i,k,it)*pdtime*(water+ice)
+!   add tracers from below cloud scav in his_dh
+     his_dh(i)=his_dh(i)-dxbc(i,k)*zmass(i,k)/pdtime !  kg/m2/s
+     d_tr_bcscav(i,k,it)=dxbc(i,k)
+    ENDIF
+
+!  reevaporation
+      deltaP(i,k)=flxr(i,k+1)+flxs(i,k+1)-flxr(i,k)-flxs(i,k)
+      deltaP(i,k)=max(deltaP(i,k),0.)
+
+      if(flxr(i,k+1)+flxs(i,k+1).gt.1.e-16) then
+       beta_ev(i,k)=deltaP(i,k)/(flxr(i,k+1)+flxs(i,k+1))
+      else
+       beta_ev(i,k)=0.
+      endif
+
+      beta_ev(i,k)=max(min(1.,beta_ev(i,k)),0.)
+
+!jyg
+      
+      if(abs(1-(1-frac_ev)*beta_ev(i,k)).gt.1.e-16) then
+! remove tracers from precipitation owing to release by evaporation in his_dh
+!      dxev=frac_ev*beta_ev(i,k)*his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k)) &
+      dxev=frac_ev*beta_ev(i,k)*his_dh(i) *pdtime/(zmass(i,k)) &
+                                      /(1 -(1-frac_ev)*beta_ev(i,k))
+       his_dh(i)=his_dh(i)*(1 - frac_ev*beta_ev(i,k) / (1 -(1-frac_ev)*beta_ev(i,k)))
+      else
+!       dxev=his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k))
+       dxev=his_dh(i) *pdtime/(zmass(i,k))
+       his_dh(i)=0.
+      endif
+!      print*,  k, 'beta_ev',beta_ev
+! remove tracers from precipitation owing to release by evaporation in his_dh
+!!      dxev=frac_ev*deltaP(i,k)*pdtime * his_dh(i) /(zrho(i,k)*zdz(i,k))
+!rplmd
+!!      dxev=frac_ev*deltaP(i,k)*his_dh(i) *pdtime/(zrho(i,k)*zdz(i,k)) &
+!!                                      /max(flxr(i,k)+flxs(i,k),1.e-16)
+
+
+      d_tr_evap(i,k,it)=dxev
+!!     tendency is further added in phytrac x = x + dx
+    ENDDO !!  do i
+   ENDDO  !! do k
+
+!jyg (20130114)
+   DO i = 1,klon
+     qPrls(i,it) = his_dh(i)/max(flxr(i,1)+flxs(i,1),1.e-16)
+   ENDDO
+!jyg end
+
+
+! test de conservation
+      conserv=0.
+!      DO k= klev,1,-1
+!        DO i=1, klon
+!         conserv=conserv+d_tr_insc(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG &
+!                +d_tr_bcscav(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG  &
+!                +d_tr_evap(i,k,it)*(paprs(i,k)-paprs(i,k+1))/RG
+!      if(it.eq.3) write(*,'(I2,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12,2X,a,e20.12)'),&
+!      k,'lsc conserv ',conserv,'insc',d_tr_insc(i,k,it),'bc',d_tr_bcscav(i,k,it),'ev',d_tr_evap(i,k,it)
+!       ENDDO
+!     ENDDO
+
+END SUBROUTINE lsc_scav
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/minmaxqfi.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/minmaxqfi.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/minmaxqfi.F90	(revision 17)
@@ -0,0 +1,33 @@
+!
+! $Id: minmaxqfi.F90 1279 2009-12-10 09:02:56Z fairhead $
+!
+SUBROUTINE minmaxqfi(zq,qmin,qmax,comment)
+  USE dimphy
+  IMPLICIT NONE
+
+! Entrees
+  REAL,DIMENSION(klon,klev), INTENT(IN)   :: zq
+  REAL,INTENT(IN)                         :: qmin,qmax
+  CHARACTER(LEN=*),INTENT(IN)             :: comment
+
+! Local  
+  INTEGER,DIMENSION(klon)     :: jadrs 
+  INTEGER                     :: i, jbad, k
+  
+  DO k = 1, klev
+     jbad = 0
+     DO i = 1, klon
+        IF (zq(i,k).GT.qmax .OR. zq(i,k).LT.qmin) THEN
+           jbad = jbad + 1
+           jadrs(jbad) = i
+        ENDIF
+     ENDDO
+     IF (jbad.GT.0) THEN
+        WRITE(*,*)comment
+        DO i = 1, jbad
+           WRITE(*,*) "i,k,q=", jadrs(i),k,zq(jadrs(i),k)
+        ENDDO
+     ENDIF
+  ENDDO
+  
+END SUBROUTINE minmaxqfi
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/misc_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/misc_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/misc_mod.F90	(revision 17)
@@ -0,0 +1,6 @@
+module misc_mod
+  integer,save :: itaumax
+  logical,save :: adjust
+  integer,save :: ItCount
+  logical,save :: debug
+end module misc_mod 
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/mkstat.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/mkstat.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/mkstat.F90	(revision 17)
@@ -0,0 +1,166 @@
+subroutine mkstats(ierr)
+
+ 
+!
+!  This program writes a stats.nc file from sums and sums of squares
+!  to means and standard deviations and also writes netcdf style
+!  file so that the data can be viewed easily.  The data file is
+!  overwritten in place.  
+!  SRL  21 May 1996
+!  Yann W. july 2003
+
+  use netcdf
+
+implicit none
+
+  INCLUDE 'netcdf.inc'
+
+#include "dimensions.h"
+#include "statto.h"
+
+integer,parameter :: iip1=iim+1
+integer,parameter :: jjp1=jjm+1
+integer :: ierr,nid,nbvar,i,ndims,lt,nvarid
+integer, dimension(4) :: id,varid,start,size
+integer, dimension(5) :: dimids
+character (len=50) :: name,nameout,units,title
+real, dimension(iip1,jjp1,llm) :: sum3d,square3d,mean3d,sd3d
+real, dimension(iip1,jjp1) :: sum2d,square2d,mean2d,sd2d
+real, dimension(istime) :: time
+real, dimension(jjp1) :: lat
+real, dimension(iip1) :: lon
+real, dimension(llm) :: alt
+logical :: lcopy=.true.
+!integer :: latid,lonid,altid,timeid
+integer :: meanid,sdid
+!integer, dimension(4) :: dimout
+
+! Incrementation of count for the last step, which is not done in wstats
+count(istime)=count(istime)+1
+
+ierr = NF_OPEN("stats.nc",NF_WRITE,nid)
+
+! We catch the id of dimensions of the stats file
+
+ierr= NF_INQ_DIMID(nid,"latitude",id(1))
+ierr= NF_INQ_DIMID(nid,"longitude",id(2))
+ierr= NF_INQ_DIMID(nid,"altitude",id(3))
+ierr= NF_INQ_DIMID(nid,"Time",id(4))
+
+ierr= NF_INQ_VARID(nid,"latitude",varid(1))
+ierr= NF_INQ_VARID(nid,"longitude",varid(2))
+ierr= NF_INQ_VARID(nid,"altitude",varid(3))
+ierr= NF_INQ_VARID(nid,"Time",varid(4))
+
+! Time initialisation
+
+do i=1,istime
+   time(i)=i*24./istime
+#ifdef NC_DOUBLE
+   ierr= NF_PUT_VARA_DOUBLE(nid,varid(4),i,1,time(i))
+#else
+   ierr= NF_PUT_VARA_REAL(nid,varid(4),i,1,time(i))
+#endif
+enddo
+
+! We catche the values of the variables
+
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VAR_DOUBLE(nid,varid(1),lat)
+         ierr = NF_GET_VAR_DOUBLE(nid,varid(2),lon)
+         ierr = NF_GET_VAR_DOUBLE(nid,varid(3),alt)
+#else
+         ierr = NF_GET_VAR_REAL(nid,varid(1),lat)
+         ierr = NF_GET_VAR_REAL(nid,varid(2),lon)
+         ierr = NF_GET_VAR_REAL(nid,varid(3),alt)
+#endif
+
+! We catch the number of variables in the stats file
+ierr = NF_INQ_NVARS(nid,nbvar)
+
+! to catche the "real" number of variables (without the "additionnal variables")
+nbvar=(nbvar-4)/2 
+
+do i=1,nbvar
+   varid=(i-1)*2+5
+
+   ! What's the variable's name?
+   ierr=NF_INQ_VARNAME(nid,varid,name)
+   write(*,*) "OK variable ",name
+   ! Its units?
+   units=" "
+   ierr=NF_GET_ATT_TEXT(nid,varid,"units",units)
+   ! Its title?
+   title=" "
+   ierr=NF_GET_ATT_TEXT(nid,varid,"title",title)
+   ! Its number of dimensions?   
+   ierr=NF_INQ_VARNDIMS(nid,varid,ndims)
+   ! Its values?
+
+   if(ndims==4) then ! lat, lon, alt & time
+
+!      dimout(1)=lonid
+!      dimout(2)=latid
+!      dimout(3)=altid
+!      dimout(4)=timeid
+
+      size=(/iip1,jjp1,llm,1/)
+      do lt=1,istime
+         start=(/1,1,1,lt/)
+         ! Extraction of the "source" variables
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(nid,varid,start,size,sum3d)
+         ierr = NF_GET_VARA_DOUBLE(nid,varid+1,start,size,square3d)
+#else
+         ierr = NF_GET_VARA_REAL(nid,varid,start,size,sum3d)
+         ierr = NF_GET_VARA_REAL(nid,varid+1,start,size,square3d)
+#endif
+         ! Calculation of these variables
+         mean3d=sum3d/count(lt)
+         sd3d=sqrt(max(0.,square3d/count(lt)-mean3d**2))
+         ! Writing of the variables
+#ifdef NC_DOUBLE
+         ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,mean3d)
+         ierr = NF_PUT_VARA_DOUBLE(nid,varid+1,start,size,sd3d)
+#else
+         ierr = NF_PUT_VARA_REAL(nid,varid,start,size,mean3d)
+         ierr = NF_PUT_VARA_REAL(nid,varid+1,start,size,sd3d)
+#endif
+      enddo
+
+    else if (ndims.eq.3) then
+
+!      dimout(1)=lonid
+!      dimout(2)=latid
+!      dimout(3)=timeid
+
+      size=(/iip1,jjp1,1,0/)
+      do lt=1,istime
+         start=(/1,1,lt,0/)
+         ! Extraction of the "source" variables
+#ifdef NC_DOUBLE
+         ierr = NF_GET_VARA_DOUBLE(nid,varid,start,size,sum2d)
+         ierr = NF_GET_VARA_DOUBLE(nid,varid+1,start,size,square2d)
+#else
+         ierr = NF_GET_VARA_REAL(nid,varid,start,size,sum2d)
+         ierr = NF_GET_VARA_REAL(nid,varid+1,start,size,square2d)
+#endif
+         ! Calculation of these variables
+         mean2d=sum2d/count(lt)
+         sd2d=sqrt(max(0.,square2d/count(lt)-mean2d**2))
+         ! Writing of the variables
+#ifdef NC_DOUBLE
+         ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,mean2d)
+         ierr = NF_PUT_VARA_DOUBLE(nid,varid+1,start,size,sd2d)
+#else
+         ierr = NF_PUT_VARA_REAL(nid,varid,start,size,mean2d)
+         ierr = NF_PUT_VARA_REAL(nid,varid+1,start,size,sd2d)
+#endif
+      enddo
+
+    endif 
+enddo
+
+ierr= NF_CLOSE(nid)
+
+end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_const_mpi.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_const_mpi.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_const_mpi.F90	(revision 17)
@@ -0,0 +1,16 @@
+MODULE mod_const_mpi
+
+  INTEGER :: COMM_LMDZ
+  INTEGER :: MPI_REAL_LMDZ
+ 
+
+CONTAINS 
+
+  SUBROUTINE Init_const_mpi
+  IMPLICIT NONE
+  
+    COMM_LMDZ=0
+    MPI_REAL_LMDZ=0
+  END SUBROUTINE Init_const_mpi
+
+END MODULE mod_const_mpi
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_grid_phy_lmdz.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_grid_phy_lmdz.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_grid_phy_lmdz.F90	(revision 17)
@@ -0,0 +1,454 @@
+!
+!$Id $
+!
+MODULE mod_grid_phy_lmdz
+
+  PUBLIC
+  PRIVATE :: grid1dTo2d_glo_igen, grid1dTo2d_glo_rgen, grid1dTo2d_glo_lgen, &
+             grid2dTo1d_glo_igen, grid2dTo1d_glo_rgen, grid2dTo1d_glo_lgen
+  
+  INTEGER,SAVE :: nbp_lon  ! == iim
+  INTEGER,SAVE :: nbp_lat  ! == jjmp1
+  INTEGER,SAVE :: nbp_lev  ! == llm
+  INTEGER,SAVE :: klon_glo
+
+  INTERFACE grid1dTo2d_glo
+    MODULE PROCEDURE grid1dTo2d_glo_i,grid1dTo2d_glo_i1,grid1dTo2d_glo_i2,grid1dTo2d_glo_i3, &
+                     grid1dTo2d_glo_r,grid1dTo2d_glo_r1,grid1dTo2d_glo_r2,grid1dTo2d_glo_r3, &
+		     grid1dTo2d_glo_l,grid1dTo2d_glo_l1,grid1dTo2d_glo_l2,grid1dTo2d_glo_l3
+   END INTERFACE 
+
+   INTERFACE grid2dTo1d_glo
+    MODULE PROCEDURE grid2dTo1d_glo_i,grid2dTo1d_glo_i1,grid2dTo1d_glo_i2,grid2dTo1d_glo_i3, &
+                     grid2dTo1d_glo_r,grid2dTo1d_glo_r1,grid2dTo1d_glo_r2,grid2dTo1d_glo_r3, &
+		     grid2dTo1d_glo_l,grid2dTo1d_glo_l1,grid2dTo1d_glo_l2,grid2dTo1d_glo_l3
+   END INTERFACE 
+ 
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! SUBROUTINE grid1dTo2d  !!  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+  SUBROUTINE Init_grid_phy_lmdz(iim,jjp1,llm)
+  IMPLICIT NONE
+  INTEGER, INTENT(in) :: iim
+  INTEGER, INTENT(in) :: jjp1
+  INTEGER, INTENT(in) :: llm
+  
+    nbp_lon=iim
+    nbp_lat=jjp1
+    nbp_lev=llm
+    klon_glo=(iim*jjp1)-2*(iim-1)
+
+  END SUBROUTINE Init_grid_phy_lmdz
+  
+  
+  SUBROUTINE grid1dTo2d_glo_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_glo_i
+  
+
+  SUBROUTINE grid1dTo2d_glo_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_glo_i1
+
+  SUBROUTINE grid1dTo2d_glo_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_glo_i2
+  
+  SUBROUTINE grid1dTo2d_glo_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_glo_i3
+
+
+  SUBROUTINE grid1dTo2d_glo_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_glo_r
+  
+
+  SUBROUTINE grid1dTo2d_glo_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_glo_r1
+
+  SUBROUTINE grid1dTo2d_glo_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_glo_r2
+  
+  SUBROUTINE grid1dTo2d_glo_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_glo_r3
+  
+  
+  
+  SUBROUTINE grid1dTo2d_glo_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_glo_l
+  
+
+  SUBROUTINE grid1dTo2d_glo_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_glo_l1
+
+  SUBROUTINE grid1dTo2d_glo_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_glo_l2
+  
+  SUBROUTINE grid1dTo2d_glo_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_glo_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_glo_l3  
+  
+    SUBROUTINE grid2dTo1d_glo_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_glo_i
+  
+
+  SUBROUTINE grid2dTo1d_glo_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_glo_i1
+
+  SUBROUTINE grid2dTo1d_glo_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_glo_i2
+  
+  SUBROUTINE grid2dTo1d_glo_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_glo_i3
+ 
+
+
+
+  SUBROUTINE grid2dTo1d_glo_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_glo_r
+  
+
+  SUBROUTINE grid2dTo1d_glo_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_glo_r1
+
+  SUBROUTINE grid2dTo1d_glo_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_glo_r2
+  
+  SUBROUTINE grid2dTo1d_glo_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_glo_r3
+
+
+
+  SUBROUTINE grid2dTo1d_glo_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_glo_l
+  
+
+  SUBROUTINE grid2dTo1d_glo_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_glo_l1
+
+  SUBROUTINE grid2dTo1d_glo_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_glo_l2
+  
+  SUBROUTINE grid2dTo1d_glo_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_glo_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_glo_l3
+
+!---------------------------------------------------------------- 
+!  Generic (private) fonctions
+!---------------------------------------------------------------- 
+  
+  SUBROUTINE grid1dTo2d_glo_igen(VarIn,VarOut,dimsize)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    
+    Offset=nbp_lon
+        
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=1,nbp_lon
+       VarOut(ij,i)=VarIn(1,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
+       VarOut(ij,i)=VarIn(klon_glo,i)
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE grid1dTo2d_glo_igen   
+
+
+  SUBROUTINE grid1dTo2d_glo_rgen(VarIn,VarOut,dimsize)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
+    REAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+   
+    Offset=nbp_lon
+        
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=1,nbp_lon
+       VarOut(ij,i)=VarIn(1,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
+       VarOut(ij,i)=VarIn(klon_glo,i)
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE grid1dTo2d_glo_rgen   
+
+  SUBROUTINE grid1dTo2d_glo_lgen(VarIn,VarOut,dimsize)
+
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(klon_glo,dimsize)       :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(nbp_lon*nbp_lat,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    Offset=nbp_lon
+        
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=1,nbp_lon
+       VarOut(ij,i)=VarIn(1,i)
+      ENDDO
+    ENDDO
+    
+    
+    DO i=1,dimsize
+      DO ij=nbp_lon*(nbp_lat-1)+1,nbp_lat*nbp_lon
+       VarOut(ij,i)=VarIn(klon_glo,i)
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE grid1dTo2d_glo_lgen     
+  
+  
+  SUBROUTINE grid2dTo1d_glo_igen(VarIn,VarOut,dimsize)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    DO i=1,dimsize
+      VarOut(1,i)=VarIn(1,i)
+    ENDDO
+    
+  END SUBROUTINE grid2dTo1d_glo_igen   
+  
+  SUBROUTINE grid2dTo1d_glo_rgen(VarIn,VarOut,dimsize)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    DO i=1,dimsize
+      VarOut(1,i)=VarIn(1,i)
+    ENDDO
+    
+  END SUBROUTINE grid2dTo1d_glo_rgen 
+    
+  SUBROUTINE grid2dTo1d_glo_lgen(VarIn,VarOut,dimsize)
+
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(nbp_lon*nbp_lat,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_glo
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    DO i=1,dimsize
+      VarOut(1,i)=VarIn(1,i)
+    ENDDO
+    
+  END SUBROUTINE grid2dTo1d_glo_lgen   
+
+END MODULE mod_grid_phy_lmdz
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_mpi_data.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_mpi_data.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_mpi_data.F90	(revision 17)
@@ -0,0 +1,209 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_mpi_data
+  USE mod_const_mpi
+  
+  INTEGER,SAVE :: ii_begin
+  INTEGER,SAVE :: ii_end
+  INTEGER,SAVE :: jj_begin
+  INTEGER,SAVE :: jj_end
+  INTEGER,SAVE :: jj_nb
+  INTEGER,SAVE :: ij_begin
+  INTEGER,SAVE :: ij_end
+  INTEGER,SAVE :: ij_nb
+  INTEGER,SAVE :: klon_mpi_begin
+  INTEGER,SAVE :: klon_mpi_end
+  INTEGER,SAVE :: klon_mpi
+  
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_nb
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: jj_para_end
+
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ii_para_end
+
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_nb
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: ij_para_end
+
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_nb
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_begin
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: klon_mpi_para_end 
+
+  
+  INTEGER,SAVE :: mpi_rank
+  INTEGER,SAVE :: mpi_size
+  INTEGER,SAVE :: mpi_root
+  LOGICAL,SAVE :: is_mpi_root
+  LOGICAL,SAVE :: is_using_mpi
+  
+  
+  LOGICAL,SAVE :: is_north_pole
+  LOGICAL,SAVE :: is_south_pole
+  INTEGER,SAVE :: COMM_LMDZ_PHY
+
+CONTAINS
+  
+  SUBROUTINE Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib)
+  USE mod_const_mpi, ONLY : COMM_LMDZ
+  IMPLICIT NONE
+    INTEGER,INTENT(in) :: iim
+    INTEGER,INTENT(in) :: jjp1
+    INTEGER,INTENT(in) :: nb_proc
+    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+    
+    INTEGER :: ierr
+    INTEGER :: klon_glo
+    INTEGER :: i
+    
+#ifdef CPP_MPI
+    is_using_mpi=.TRUE.
+#else
+    is_using_mpi=.FALSE.
+#endif
+    
+    if (iim.eq.1) then
+       klon_glo=1
+    else
+       klon_glo=iim*(jjp1-2)+2
+    endif
+
+    COMM_LMDZ_PHY=COMM_LMDZ
+
+    IF (is_using_mpi) THEN    
+#ifdef CPP_MPI
+      CALL MPI_COMM_SIZE(COMM_LMDZ_PHY,mpi_size,ierr)    
+      CALL MPI_COMM_RANK(COMM_LMDZ_PHY,mpi_rank,ierr)
+#endif
+    ELSE
+      mpi_size=1
+      mpi_rank=0
+    ENDIF
+    
+    IF (mpi_rank == 0) THEN
+      mpi_root = 0
+      is_mpi_root = .true.
+    ENDIF
+    
+    IF (mpi_rank == 0) THEN 
+      is_north_pole = .TRUE.
+    ELSE
+      is_north_pole = .FALSE.
+    ENDIF
+    
+    IF (mpi_rank == mpi_size-1) THEN
+      is_south_pole = .TRUE.
+    ELSE
+      is_south_pole = .FALSE.
+    ENDIF
+    
+    ALLOCATE(jj_para_nb(0:mpi_size-1))
+    ALLOCATE(jj_para_begin(0:mpi_size-1))
+    ALLOCATE(jj_para_end(0:mpi_size-1))
+    
+    ALLOCATE(ij_para_nb(0:mpi_size-1))
+    ALLOCATE(ij_para_begin(0:mpi_size-1))
+    ALLOCATE(ij_para_end(0:mpi_size-1))
+    
+    ALLOCATE(ii_para_begin(0:mpi_size-1))
+    ALLOCATE(ii_para_end(0:mpi_size-1))
+
+    ALLOCATE(klon_mpi_para_nb(0:mpi_size-1))
+    ALLOCATE(klon_mpi_para_begin(0:mpi_size-1))
+    ALLOCATE(klon_mpi_para_end(0:mpi_size-1))
+  
+    klon_mpi_para_nb(0:mpi_size-1)=distrib(0:nb_proc-1)
+
+    DO i=0,mpi_size-1
+      IF (i==0) THEN 
+        klon_mpi_para_begin(i)=1
+      ELSE 
+        klon_mpi_para_begin(i)=klon_mpi_para_end(i-1)+1
+      ENDIF
+        klon_mpi_para_end(i)=klon_mpi_para_begin(i)+klon_mpi_para_nb(i)-1
+    ENDDO
+
+
+    DO i=0,mpi_size-1
+      
+      IF (i==0) THEN
+        ij_para_begin(i) = 1
+      ELSE
+        ij_para_begin(i) = klon_mpi_para_begin(i)+iim-1
+      ENDIF
+
+      jj_para_begin(i) = (ij_para_begin(i)-1)/iim + 1
+      ii_para_begin(i) = MOD(ij_para_begin(i)-1,iim) + 1
+
+      
+      ij_para_end(i) = klon_mpi_para_end(i)+iim-1
+      jj_para_end(i) = (ij_para_end(i)-1)/iim + 1
+      ii_para_end(i) = MOD(ij_para_end(i)-1,iim) + 1
+
+
+      ij_para_nb(i) = ij_para_end(i)-ij_para_begin(i)+1
+      jj_para_nb(i) = jj_para_end(i)-jj_para_begin(i)+1
+         
+    ENDDO
+    PRINT *,'      ii_para_begin: ',ii_para_begin
+    PRINT *,'      ii_para_end: ',ii_para_end
+    PRINT *,'      jj_para_begin: ',jj_para_begin
+    PRINT *,'      jj_para_end: ',jj_para_end
+    PRINT *,'      ij_para_begin: ',ij_para_begin
+    PRINT *,'      ij_para_end: ',ij_para_end
+    PRINT *,'      ij_para_nb: ',ij_para_nb
+  
+    ii_begin = ii_para_begin(mpi_rank)
+    ii_end   = ii_para_end(mpi_rank)
+    jj_begin = jj_para_begin(mpi_rank)
+    jj_end   = jj_para_end(mpi_rank)
+    jj_nb    = jj_para_nb(mpi_rank)
+    ij_begin = ij_para_begin(mpi_rank)
+    ij_end   = ij_para_end(mpi_rank)
+    ij_nb    = ij_para_nb(mpi_rank)
+    klon_mpi_begin = klon_mpi_para_begin(mpi_rank)
+    klon_mpi_end   = klon_mpi_para_end(mpi_rank)
+    klon_mpi       = klon_mpi_para_nb(mpi_rank)
+
+    CALL Print_module_data
+    
+  END SUBROUTINE Init_phys_lmdz_mpi_data
+
+  SUBROUTINE print_module_data
+  IMPLICIT NONE
+  INCLUDE "iniprint.h" 
+  
+    WRITE(lunout,*) 'ii_begin =', ii_begin
+    WRITE(lunout,*) 'ii_end =', ii_end
+    WRITE(lunout,*) 'jj_begin =',jj_begin
+    WRITE(lunout,*) 'jj_end =', jj_end
+    WRITE(lunout,*) 'jj_nb =', jj_nb
+    WRITE(lunout,*) 'ij_begin =', ij_begin
+    WRITE(lunout,*) 'ij_end =', ij_end
+    WRITE(lunout,*) 'ij_nb =', ij_nb
+    WRITE(lunout,*) 'klon_mpi_begin =', klon_mpi_begin
+    WRITE(lunout,*) 'klon_mpi_end =', klon_mpi_end
+    WRITE(lunout,*) 'klon_mpi =', klon_mpi
+    WRITE(lunout,*) 'jj_para_nb =', jj_para_nb
+    WRITE(lunout,*) 'jj_para_begin =', jj_para_begin
+    WRITE(lunout,*) 'jj_para_end =', jj_para_end
+    WRITE(lunout,*) 'ii_para_begin =', ii_para_begin
+    WRITE(lunout,*) 'ii_para_end =', ii_para_end
+    WRITE(lunout,*) 'ij_para_nb =', ij_para_nb
+    WRITE(lunout,*) 'ij_para_begin =', ij_para_begin
+    WRITE(lunout,*) 'ij_para_end =', ij_para_end
+    WRITE(lunout,*) 'klon_mpi_para_nb =', klon_mpi_para_nb
+    WRITE(lunout,*) 'klon_mpi_para_begin =', klon_mpi_para_begin
+    WRITE(lunout,*) 'klon_mpi_para_end  =', klon_mpi_para_end 
+    WRITE(lunout,*) 'mpi_rank =', mpi_rank
+    WRITE(lunout,*) 'mpi_size =', mpi_size
+    WRITE(lunout,*) 'mpi_root =', mpi_root
+    WRITE(lunout,*) 'is_mpi_root =', is_mpi_root
+    WRITE(lunout,*) 'is_north_pole =', is_north_pole
+    WRITE(lunout,*) 'is_south_pole =', is_south_pole
+    WRITE(lunout,*) 'COMM_LMDZ_PHY =', COMM_LMDZ_PHY
+  
+  END SUBROUTINE print_module_data
+  
+END MODULE mod_phys_lmdz_mpi_data
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_mpi_transfert.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_mpi_transfert.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_mpi_transfert.F90	(revision 17)
@@ -0,0 +1,1902 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_mpi_transfert
+
+
+  INTERFACE bcast_mpi
+    MODULE PROCEDURE bcast_mpi_c,                                                     &
+                     bcast_mpi_i,bcast_mpi_i1,bcast_mpi_i2,bcast_mpi_i3,bcast_mpi_i4, &
+                     bcast_mpi_r,bcast_mpi_r1,bcast_mpi_r2,bcast_mpi_r3,bcast_mpi_r4, &
+		     bcast_mpi_l,bcast_mpi_l1,bcast_mpi_l2,bcast_mpi_l3,bcast_mpi_l4
+  END INTERFACE
+
+  INTERFACE scatter_mpi
+    MODULE PROCEDURE scatter_mpi_i,scatter_mpi_i1,scatter_mpi_i2,scatter_mpi_i3, &
+                     scatter_mpi_r,scatter_mpi_r1,scatter_mpi_r2,scatter_mpi_r3, &
+		     scatter_mpi_l,scatter_mpi_l1,scatter_mpi_l2,scatter_mpi_l3
+  END INTERFACE
+
+  
+  INTERFACE gather_mpi
+    MODULE PROCEDURE gather_mpi_i,gather_mpi_i1,gather_mpi_i2,gather_mpi_i3, &
+                     gather_mpi_r,gather_mpi_r1,gather_mpi_r2,gather_mpi_r3, &
+		     gather_mpi_l,gather_mpi_l1,gather_mpi_l2,gather_mpi_l3  
+  END INTERFACE
+  
+  INTERFACE scatter2D_mpi
+    MODULE PROCEDURE scatter2D_mpi_i,scatter2D_mpi_i1,scatter2D_mpi_i2,scatter2D_mpi_i3, &
+                     scatter2D_mpi_r,scatter2D_mpi_r1,scatter2D_mpi_r2,scatter2D_mpi_r3, &
+		     scatter2D_mpi_l,scatter2D_mpi_l1,scatter2D_mpi_l2,scatter2D_mpi_l3
+  END INTERFACE
+
+  INTERFACE gather2D_mpi
+    MODULE PROCEDURE gather2D_mpi_i,gather2D_mpi_i1,gather2D_mpi_i2,gather2D_mpi_i3, &
+                     gather2D_mpi_r,gather2D_mpi_r1,gather2D_mpi_r2,gather2D_mpi_r3, &
+		     gather2D_mpi_l,gather2D_mpi_l1,gather2D_mpi_l2,gather2D_mpi_l3
+  END INTERFACE 
+  
+  INTERFACE reduce_sum_mpi
+    MODULE PROCEDURE reduce_sum_mpi_i,reduce_sum_mpi_i1,reduce_sum_mpi_i2,reduce_sum_mpi_i3,reduce_sum_mpi_i4, &
+                     reduce_sum_mpi_r,reduce_sum_mpi_r1,reduce_sum_mpi_r2,reduce_sum_mpi_r3,reduce_sum_mpi_r4
+  END INTERFACE 
+
+ INTERFACE grid1dTo2d_mpi
+    MODULE PROCEDURE grid1dTo2d_mpi_i,grid1dTo2d_mpi_i1,grid1dTo2d_mpi_i2,grid1dTo2d_mpi_i3, &
+                     grid1dTo2d_mpi_r,grid1dTo2d_mpi_r1,grid1dTo2d_mpi_r2,grid1dTo2d_mpi_r3, &
+		     grid1dTo2d_mpi_l,grid1dTo2d_mpi_l1,grid1dTo2d_mpi_l2,grid1dTo2d_mpi_l3
+ END INTERFACE 
+
+ INTERFACE grid2dTo1d_mpi
+    MODULE PROCEDURE grid2dTo1d_mpi_i,grid2dTo1d_mpi_i1,grid2dTo1d_mpi_i2,grid2dTo1d_mpi_i3, &
+                     grid2dTo1d_mpi_r,grid2dTo1d_mpi_r1,grid2dTo1d_mpi_r2,grid2dTo1d_mpi_r3, &
+		     grid2dTo1d_mpi_l,grid2dTo1d_mpi_l1,grid2dTo1d_mpi_l2,grid2dTo1d_mpi_l3
+ END INTERFACE 
+    
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Broadcast --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! -- Les chaine de charactère -- !!
+
+  SUBROUTINE bcast_mpi_c(var1)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var1
+   
+    CALL bcast_mpi_cgen(Var1,len(Var1))
+
+  END SUBROUTINE bcast_mpi_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_mpi_i(var)
+  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var
+    
+    INTEGER               :: var_tmp(1)
+    
+    IF (is_mpi_root) var_tmp(1)=var
+    CALL bcast_mpi_igen(Var_tmp,1)
+    var=var_tmp(1)
+    
+  END SUBROUTINE bcast_mpi_i
+
+  SUBROUTINE bcast_mpi_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+
+    CALL bcast_mpi_igen(Var,size(Var))
+    
+  END SUBROUTINE bcast_mpi_i1
+
+  SUBROUTINE bcast_mpi_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_mpi_igen(Var,size(Var))
+  
+  END SUBROUTINE bcast_mpi_i2
+
+  SUBROUTINE bcast_mpi_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+   
+    CALL bcast_mpi_igen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_i3
+
+  SUBROUTINE bcast_mpi_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_mpi_igen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_i4
+
+
+!! -- Les reels -- !!
+
+  SUBROUTINE bcast_mpi_r(var)
+  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+    REAL               :: var_tmp(1)
+    
+    IF (is_mpi_root) var_tmp(1)=var
+    CALL bcast_mpi_rgen(Var_tmp,1)
+    var=var_tmp(1)   
+
+  END SUBROUTINE bcast_mpi_r
+
+  SUBROUTINE bcast_mpi_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_mpi_rgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_r1
+
+  SUBROUTINE bcast_mpi_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_mpi_rgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_r2
+
+  SUBROUTINE bcast_mpi_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+   
+    CALL bcast_mpi_rgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_r3
+
+  SUBROUTINE bcast_mpi_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_mpi_rgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_r4
+  
+!! -- Les booleans -- !!
+
+  SUBROUTINE bcast_mpi_l(var)
+  USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+    LOGICAL               :: var_tmp(1)
+    
+    IF (is_mpi_root) var_tmp(1)=var
+    CALL bcast_mpi_lgen(Var_tmp,1)
+    var=var_tmp(1)   
+
+  END SUBROUTINE bcast_mpi_l
+
+  SUBROUTINE bcast_mpi_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+    CALL bcast_mpi_lgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_l1
+
+  SUBROUTINE bcast_mpi_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL bcast_mpi_lgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_l2
+
+  SUBROUTINE bcast_mpi_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+   
+    CALL bcast_mpi_lgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_l3
+
+  SUBROUTINE bcast_mpi_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL bcast_mpi_lgen(Var,size(Var))
+
+  END SUBROUTINE bcast_mpi_l4
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_mpi_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL scatter_mpi_igen(VarIn,Varout,1)
+    
+  END SUBROUTINE scatter_mpi_i
+
+  SUBROUTINE scatter_mpi_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2))
+    
+  END SUBROUTINE scatter_mpi_i1
+  
+  SUBROUTINE scatter_mpi_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+
+  END SUBROUTINE scatter_mpi_i2
+
+  SUBROUTINE scatter_mpi_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL scatter_mpi_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+  
+  END SUBROUTINE scatter_mpi_i3
+
+
+  SUBROUTINE scatter_mpi_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL scatter_mpi_rgen(VarIn,Varout,1)
+  
+  END SUBROUTINE scatter_mpi_r
+
+  SUBROUTINE scatter_mpi_r1(VarIn, VarOut)
+  USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+  IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2))
+  
+  END SUBROUTINE scatter_mpi_r1
+  
+  SUBROUTINE scatter_mpi_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+  
+  END SUBROUTINE scatter_mpi_r2
+
+  SUBROUTINE scatter_mpi_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+      CALL scatter_mpi_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+  
+  END SUBROUTINE scatter_mpi_r3
+
+
+  SUBROUTINE scatter_mpi_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL scatter_mpi_lgen(VarIn,Varout,1)
+    
+  END SUBROUTINE scatter_mpi_l
+
+  SUBROUTINE scatter_mpi_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2))
+  
+  END SUBROUTINE scatter_mpi_l1
+  
+  SUBROUTINE scatter_mpi_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3))
+  
+  END SUBROUTINE scatter_mpi_l2
+
+  SUBROUTINE scatter_mpi_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+      CALL scatter_mpi_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4))
+  
+  END SUBROUTINE scatter_mpi_l3  
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+!!!!! --> Les entiers
+
+  SUBROUTINE gather_mpi_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL gather_mpi_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE gather_mpi_i
+  
+
+!!!!!
+
+  SUBROUTINE gather_mpi_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2))
+  
+  END SUBROUTINE gather_mpi_i1
+
+!!!!!
+  
+  SUBROUTINE gather_mpi_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+  
+  END SUBROUTINE gather_mpi_i2
+
+!!!!!
+
+  SUBROUTINE gather_mpi_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+      CALL gather_mpi_igen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+  
+  END SUBROUTINE gather_mpi_i3
+
+!!!!! --> Les reels
+
+  SUBROUTINE gather_mpi_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL gather_mpi_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE gather_mpi_r
+
+!!!!!
+
+  SUBROUTINE gather_mpi_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2))
+  
+  END SUBROUTINE gather_mpi_r1
+
+!!!!!
+  
+  SUBROUTINE gather_mpi_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+  
+  END SUBROUTINE gather_mpi_r2
+
+!!!!!
+
+  SUBROUTINE gather_mpi_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+      CALL gather_mpi_rgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+  
+  END SUBROUTINE gather_mpi_r3
+
+!!!!! --> Les booleen
+
+  SUBROUTINE gather_mpi_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+      CALL gather_mpi_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE gather_mpi_l
+
+!!!!!
+
+  SUBROUTINE gather_mpi_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2))
+  
+  END SUBROUTINE gather_mpi_l1
+
+!!!!!
+  
+  SUBROUTINE gather_mpi_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+      CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3))
+  
+  END SUBROUTINE gather_mpi_l2
+
+!!!!!
+
+  SUBROUTINE gather_mpi_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL gather_mpi_lgen(VarIn,VarOut,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4))
+  
+  END SUBROUTINE gather_mpi_l3
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter2D_mpi_i(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER,DIMENSION(klon_glo) :: Var_tmp    
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_i
+
+  SUBROUTINE scatter2D_mpi_i1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    INTEGER,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_i1
+
+  SUBROUTINE scatter2D_mpi_i2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_i2
+  
+  SUBROUTINE scatter2D_mpi_i3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    INTEGER,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter2D_mpi_i3
+
+
+
+  SUBROUTINE scatter2D_mpi_r(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL,DIMENSION(klon_glo) :: Var_tmp    
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_R
+
+
+  SUBROUTINE scatter2D_mpi_r1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_r1
+
+
+  SUBROUTINE scatter2D_mpi_r2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_r2
+  
+  SUBROUTINE scatter2D_mpi_r3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+ 
+  END SUBROUTINE scatter2D_mpi_r3
+  
+  
+  SUBROUTINE scatter2D_mpi_l(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_glo) :: Var_tmp    
+    
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_l
+
+
+  SUBROUTINE scatter2D_mpi_l1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,2)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+  
+  END SUBROUTINE scatter2D_mpi_l1
+
+
+  SUBROUTINE scatter2D_mpi_l2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3)) :: Var_tmp
+  
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_mpi_l2
+  
+  SUBROUTINE scatter2D_mpi_l3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,2),size(VarOut,3),size(VarOut,4)) :: Var_tmp
+
+    CALL grid2dTo1d_glo(VarIn,Var_tmp)
+    CALL scatter_mpi(Var_tmp,VarOut)
+ 
+  END SUBROUTINE scatter2D_mpi_l3
+  
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE gather2D_mpi_i(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_glo) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_i
+
+  SUBROUTINE gather2D_mpi_i1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_i1
+
+  SUBROUTINE gather2D_mpi_i2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_i2
+  
+  SUBROUTINE gather2D_mpi_i3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+ 
+    INTEGER,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_i3
+
+
+
+  SUBROUTINE gather2D_mpi_r(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_r
+
+  SUBROUTINE gather2D_mpi_r1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_r1
+
+  SUBROUTINE gather2D_mpi_r2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_r2
+  
+  SUBROUTINE gather2D_mpi_r3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_r3
+
+  
+  
+  SUBROUTINE gather2D_mpi_l(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_l
+
+  SUBROUTINE gather2D_mpi_l1(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,3)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_l1
+
+  SUBROUTINE gather2D_mpi_l2(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4)) :: Var_tmp
+
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_l2
+  
+  SUBROUTINE gather2D_mpi_l3(VarIn, VarOut)
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_glo,size(VarOut,3),SIZE(VarOut,4),SIZE(VarOut,5)) :: Var_tmp
+    
+    CALL gather_mpi(VarIn,Var_tmp)
+    CALL grid1dTo2d_glo(Var_tmp,VarOut)
+
+  END SUBROUTINE gather2D_mpi_l3
+  
+  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des reduce_sum   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE reduce_sum_mpi_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    INTEGER             :: VarIn_tmp(1)
+    INTEGER             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn    
+    CALL reduce_sum_mpi_igen(VarIn_tmp,Varout_tmp,1)
+    VarOut=VarOut_tmp(1)
+    
+  END SUBROUTINE reduce_sum_mpi_i
+
+  SUBROUTINE reduce_sum_mpi_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_i1
+
+  SUBROUTINE reduce_sum_mpi_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_i2
+
+  SUBROUTINE reduce_sum_mpi_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_i3
+
+  SUBROUTINE reduce_sum_mpi_i4(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_igen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_i4                  
+  
+  
+  SUBROUTINE reduce_sum_mpi_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    REAL             :: VarIn_tmp(1)
+    REAL             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn    
+    CALL reduce_sum_mpi_rgen(VarIn_tmp,Varout_tmp,1)
+    VarOut=VarOut_tmp(1)
+  
+  END SUBROUTINE reduce_sum_mpi_r
+
+  SUBROUTINE reduce_sum_mpi_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+     
+  END SUBROUTINE reduce_sum_mpi_r1
+
+  SUBROUTINE reduce_sum_mpi_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_r2
+
+  SUBROUTINE reduce_sum_mpi_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_r3
+
+  SUBROUTINE reduce_sum_mpi_r4(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL reduce_sum_mpi_rgen(VarIn,Varout,SIZE(VarIn))
+  
+  END SUBROUTINE reduce_sum_mpi_r4 
+  
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! SUBROUTINE grid1dTo2d  !!  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+  SUBROUTINE grid1dTo2d_mpi_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_mpi_i
+  
+
+  SUBROUTINE grid1dTo2d_mpi_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_mpi_i1
+
+  SUBROUTINE grid1dTo2d_mpi_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_mpi_i2
+  
+  SUBROUTINE grid1dTo2d_mpi_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_igen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_mpi_i3
+
+
+  SUBROUTINE grid1dTo2d_mpi_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_mpi_r
+  
+
+  SUBROUTINE grid1dTo2d_mpi_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_mpi_r1
+
+  SUBROUTINE grid1dTo2d_mpi_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_mpi_r2
+  
+  SUBROUTINE grid1dTo2d_mpi_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_rgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_mpi_r3
+  
+  
+  
+  SUBROUTINE grid1dTo2d_mpi_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid1dTo2d_mpi_l
+  
+
+  SUBROUTINE grid1dTo2d_mpi_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2))
+  
+  END SUBROUTINE grid1dTo2d_mpi_l1
+
+  SUBROUTINE grid1dTo2d_mpi_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3))
+  
+  END SUBROUTINE grid1dTo2d_mpi_l2
+  
+  SUBROUTINE grid1dTo2d_mpi_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:)     :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:)  :: VarOut
+    
+    CALL grid1dTo2d_mpi_lgen(VarIn,VarOut,size(VarIn,2)*size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid1dTo2d_mpi_l3
+
+
+  SUBROUTINE grid2dTo1d_mpi_i(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_mpi_i
+  
+
+  SUBROUTINE grid2dTo1d_mpi_i1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_mpi_i1
+
+  SUBROUTINE grid2dTo1d_mpi_i2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_mpi_i2
+  
+  SUBROUTINE grid2dTo1d_mpi_i3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_igen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_mpi_i3
+ 
+
+
+
+  SUBROUTINE grid2dTo1d_mpi_r(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_mpi_r
+  
+
+  SUBROUTINE grid2dTo1d_mpi_r1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_mpi_r1
+
+  SUBROUTINE grid2dTo1d_mpi_r2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_mpi_r2
+  
+  SUBROUTINE grid2dTo1d_mpi_r3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_rgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_mpi_r3
+
+
+
+  SUBROUTINE grid2dTo1d_mpi_l(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,1)
+  
+  END SUBROUTINE grid2dTo1d_mpi_l
+  
+
+  SUBROUTINE grid2dTo1d_mpi_l1(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3))
+  
+  END SUBROUTINE grid2dTo1d_mpi_l1
+
+
+
+  SUBROUTINE grid2dTo1d_mpi_l2(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4))
+  
+  END SUBROUTINE grid2dTo1d_mpi_l2
+
+  
+  SUBROUTINE grid2dTo1d_mpi_l3(VarIn,VarOut)  
+  IMPLICIT NONE  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:)  :: VarOut
+    
+    CALL grid2dTo1d_mpi_lgen(VarIn,VarOut,size(VarIn,3)*size(VarIn,4)*size(VarIn,5))
+  
+  END SUBROUTINE grid2dTo1d_mpi_l3
+
+               
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! DEFINITION DES FONCTIONS DE TRANSFERT GENERIQUES !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE bcast_mpi_cgen(var,nb)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    IMPLICIT NONE
+    
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+    
+#ifdef CPP_MPI
+    CALL MPI_BCAST(Var,nb,MPI_CHARACTER,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+        
+  END SUBROUTINE bcast_mpi_cgen
+
+
+      
+  SUBROUTINE bcast_mpi_igen(var,nb)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    IMPLICIT NONE
+    
+    INTEGER,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+
+#ifdef CPP_MPI
+    CALL MPI_BCAST(Var,nb,MPI_INTEGER,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+        
+  END SUBROUTINE bcast_mpi_igen
+
+
+
+  
+  SUBROUTINE bcast_mpi_rgen(var,nb)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    IMPLICIT NONE
+    
+    REAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+
+#ifdef CPP_MPI
+    CALL MPI_BCAST(Var,nb,MPI_REAL_LMDZ,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+    
+  END SUBROUTINE bcast_mpi_rgen
+  
+
+
+
+  SUBROUTINE bcast_mpi_lgen(var,nb)
+    USE mod_phys_lmdz_mpi_data ,  mpi_root_x=>mpi_root
+    IMPLICIT NONE
+    
+    LOGICAL,DIMENSION(nb),INTENT(INOUT) :: Var
+    INTEGER,INTENT(IN) :: nb
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) RETURN
+
+#ifdef CPP_MPI
+    CALL MPI_BCAST(Var,nb,MPI_LOGICAL,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+
+  END SUBROUTINE bcast_mpi_lgen
+
+  
+
+  SUBROUTINE scatter_mpi_igen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    INTEGER,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+    
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)
+          Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+      
+#ifdef CPP_MPI 
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_INTEGER,VarOut,klon_mpi*dimsize,   &
+                      MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+
+  END SUBROUTINE scatter_mpi_igen
+
+  SUBROUTINE scatter_mpi_rgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    REAL,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+    
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)
+          Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+      
+#ifdef CPP_MPI 
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_REAL_LMDZ,VarOut,klon_mpi*dimsize,   &
+                      MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr)
+
+#endif
+
+  END SUBROUTINE scatter_mpi_rgen
+
+  
+  SUBROUTINE scatter_mpi_lgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_glo,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    LOGICAL,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+    
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+        DO i=1,dimsize
+          VarTmp(Index:Index+nb-1)=VarIn(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)
+          Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+      
+#ifdef CPP_MPI
+    CALL MPI_SCATTERV(VarTmp,counts,displs,MPI_LOGICAL,VarOut,klon_mpi*dimsize,   &
+                      MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+
+  END SUBROUTINE scatter_mpi_lgen  
+
+
+
+
+  SUBROUTINE gather_mpi_igen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
+  
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    INTEGER,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+	Index=Index+nb*dimsize
+      ENDDO
+     
+    ENDIF
+    
+#ifdef CPP_MPI
+    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_INTEGER,VarTmp,counts,displs,   &
+                     MPI_INTEGER,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+
+		          
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1)
+	  Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+
+  END SUBROUTINE gather_mpi_igen  
+
+  SUBROUTINE gather_mpi_rgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
+  
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    REAL,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+	Index=Index+nb*dimsize
+      ENDDO
+    ENDIF
+    
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+#ifdef CPP_MPI
+    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_REAL_LMDZ,VarTmp,counts,displs,   &
+                      MPI_REAL_LMDZ,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+		          
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1)
+	  Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+
+  END SUBROUTINE gather_mpi_rgen  
+
+  SUBROUTINE gather_mpi_lgen(VarIn, VarOut, dimsize)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_glo,dimsize) :: VarOut
+  
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+
+    INTEGER,DIMENSION(0:mpi_size-1) :: displs
+    INTEGER,DIMENSION(0:mpi_size-1) :: counts
+    LOGICAL,DIMENSION(dimsize*klon_glo) :: VarTmp
+    INTEGER :: nb,i,index,rank
+    INTEGER :: ierr
+    
+    IF (.not.is_using_mpi) THEN
+      VarOut(:,:)=VarIn(:,:)
+      RETURN
+    ENDIF
+
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        displs(rank)=Index-1
+        counts(rank)=nb*dimsize
+	Index=Index+nb*dimsize
+      ENDDO
+    ENDIF
+    
+
+#ifdef CPP_MPI
+    CALL MPI_GATHERV(VarIn,klon_mpi*dimsize,MPI_LOGICAL,VarTmp,counts,displs,   &
+                      MPI_LOGICAL,mpi_root_x, COMM_LMDZ_PHY,ierr)
+#endif
+		          
+    IF (is_mpi_root) THEN
+      Index=1
+      DO rank=0,mpi_size-1
+        nb=klon_mpi_para_nb(rank)
+        DO i=1,dimsize
+          VarOut(klon_mpi_para_begin(rank):klon_mpi_para_end(rank),i)=VarTmp(Index:Index+nb-1)
+	  Index=Index+nb
+        ENDDO
+      ENDDO
+    ENDIF
+
+  END SUBROUTINE gather_mpi_lgen
+  
+
+
+  SUBROUTINE reduce_sum_mpi_igen(VarIn,VarOut,nb)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+   
+    INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn
+    INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER,INTENT(IN) :: nb
+    INTEGER :: ierr
+   
+    IF (.not.is_using_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+
+
+#ifdef CPP_MPI
+    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INTEGER,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+            
+  END SUBROUTINE reduce_sum_mpi_igen
+  
+  SUBROUTINE reduce_sum_mpi_rgen(VarIn,VarOut,nb)
+    USE mod_phys_lmdz_mpi_data , mpi_root_x=>mpi_root
+    USE mod_grid_phy_lmdz
+
+    IMPLICIT NONE
+
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif
+    
+    REAL,DIMENSION(nb),INTENT(IN) :: VarIn
+    REAL,DIMENSION(nb),INTENT(OUT) :: VarOut    
+    INTEGER,INTENT(IN) :: nb
+    INTEGER :: ierr
+ 
+    IF (.not.is_using_mpi) THEN
+      VarOut(:)=VarIn(:)
+      RETURN
+    ENDIF
+   
+#ifdef CPP_MPI
+    CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_LMDZ,MPI_SUM,mpi_root_x,COMM_LMDZ_PHY,ierr)
+#endif
+        
+  END SUBROUTINE reduce_sum_mpi_rgen
+
+
+
+  SUBROUTINE grid1dTo2d_mpi_igen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(klon_mpi,dimsize)       :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    
+    VarOut(1:nbp_lon,:)=0
+    VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=0
+    
+    offset=ii_begin
+    IF (is_north_pole) Offset=nbp_lon
+    
+    
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    IF (is_north_pole) THEN 
+      DO i=1,dimsize
+        DO ij=1,nbp_lon
+         VarOut(ij,i)=VarIn(1,i)
+	ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (is_south_pole) THEN 
+      DO i=1,dimsize
+        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
+         VarOut(ij,i)=VarIn(klon_mpi,i)
+	ENDDO
+      ENDDO
+    ENDIF
+
+  END SUBROUTINE grid1dTo2d_mpi_igen   
+
+
+  SUBROUTINE grid1dTo2d_mpi_rgen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(klon_mpi,dimsize)       :: VarIn
+    REAL,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    
+    VarOut(1:nbp_lon,:)=0
+    VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=0
+    
+    offset=ii_begin
+    IF (is_north_pole) Offset=nbp_lon
+    
+    
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    IF (is_north_pole) THEN 
+      DO i=1,dimsize
+        DO ij=1,nbp_lon
+         VarOut(ij,i)=VarIn(1,i)
+	ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (is_south_pole) THEN 
+      DO i=1,dimsize
+        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
+         VarOut(ij,i)=VarIn(klon_mpi,i)
+	ENDDO
+      ENDDO
+    ENDIF
+
+   END SUBROUTINE grid1dTo2d_mpi_rgen   
+
+
+
+  SUBROUTINE grid1dTo2d_mpi_lgen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(klon_mpi,dimsize)       :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(nbp_lon*jj_nb,dimsize)  :: VarOut
+    INTEGER :: i,ij,Offset
+
+    
+    VarOut(1:nbp_lon,:)=.FALSE.
+    VarOut(nbp_lon*(jj_nb-1)+1:nbp_lon*jj_nb,:)=.FALSE.
+    
+    offset=ii_begin
+    IF (is_north_pole) Offset=nbp_lon
+    
+    
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij+offset-1,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+    
+    
+    IF (is_north_pole) THEN 
+      DO i=1,dimsize
+        DO ij=1,nbp_lon
+         VarOut(ij,i)=VarIn(1,i)
+	ENDDO
+      ENDDO
+    ENDIF
+    
+    IF (is_south_pole) THEN 
+      DO i=1,dimsize
+        DO ij=nbp_lon*(jj_nb-1)+1,nbp_lon*jj_nb
+         VarOut(ij,i)=VarIn(klon_mpi,i)
+	ENDDO
+      ENDDO
+    ENDIF
+
+   END SUBROUTINE grid1dTo2d_mpi_lgen   
+
+  
+
+
+  SUBROUTINE grid2dTo1d_mpi_igen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=ii_begin
+    IF (is_north_pole) offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    IF (is_north_pole) THEN 
+      DO i=1,dimsize
+        VarOut(1,i)=VarIn(1,i)
+      ENDDO
+    ENDIF
+    
+    
+  END SUBROUTINE grid2dTo1d_mpi_igen   
+
+
+
+  SUBROUTINE grid2dTo1d_mpi_rgen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=ii_begin
+    IF (is_north_pole) offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    IF (is_north_pole) THEN 
+      DO i=1,dimsize
+         VarOut(1,i)=VarIn(1,i)
+      ENDDO
+    ENDIF
+    
+    
+  END SUBROUTINE grid2dTo1d_mpi_rgen   
+  
+
+  SUBROUTINE grid2dTo1d_mpi_lgen(VarIn,VarOut,dimsize)
+    USE mod_phys_lmdz_mpi_data
+    USE mod_grid_phy_lmdz
+    IMPLICIT NONE
+    
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN) ,DIMENSION(nbp_lon*jj_nb,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize)      :: VarOut
+    INTEGER :: i,ij,offset
+
+    offset=ii_begin
+    IF (is_north_pole) offset=nbp_lon
+
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=VarIn(ij+offset-1,i)
+      ENDDO
+    ENDDO
+
+    IF (is_north_pole) THEN 
+      DO i=1,dimsize
+        VarOut(1,i)=VarIn(1,i)
+      ENDDO
+    ENDIF
+    
+    
+  END SUBROUTINE grid2dTo1d_mpi_lgen   
+
+END MODULE mod_phys_lmdz_mpi_transfert
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_omp_data.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_omp_data.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_omp_data.F90	(revision 17)
@@ -0,0 +1,109 @@
+!
+!$Id: mod_phys_lmdz_omp_data.F90 1664 2012-10-09 13:29:15Z fairhead $
+!
+MODULE mod_phys_lmdz_omp_data
+
+  INTEGER,SAVE :: omp_size
+  INTEGER,SAVE :: omp_rank
+  LOGICAL,SAVE :: is_omp_root
+  LOGICAL,SAVE :: is_using_omp
+  
+  INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_nb
+  INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_begin
+  INTEGER,SAVE,DIMENSION(:),ALLOCATABLE :: klon_omp_para_end    
+  
+  INTEGER,SAVE :: klon_omp
+  INTEGER,SAVE :: klon_omp_begin
+  INTEGER,SAVE :: klon_omp_end
+!$OMP  THREADPRIVATE(omp_rank,klon_omp,is_omp_root,klon_omp_begin,klon_omp_end)
+
+CONTAINS
+  
+  SUBROUTINE Init_phys_lmdz_omp_data(klon_mpi)
+    USE dimphy
+    IMPLICIT NONE
+    INTEGER, INTENT(in) :: klon_mpi
+
+    INTEGER :: i
+
+    CHARACTER (LEN=20) :: modname='Init_phys_lmdz_omp_data'
+    CHARACTER (LEN=80) :: abort_message
+
+
+#ifdef CPP_OMP    
+    INTEGER :: OMP_GET_NUM_THREADS
+    EXTERNAL OMP_GET_NUM_THREADS
+    INTEGER :: OMP_GET_THREAD_NUM
+    EXTERNAL OMP_GET_THREAD_NUM
+#endif  
+
+#ifdef CPP_OMP
+!$OMP MASTER
+        is_using_omp=.TRUE.
+        omp_size=OMP_GET_NUM_THREADS()
+!$OMP END MASTER
+        omp_rank=OMP_GET_THREAD_NUM()    
+#else    
+    is_using_omp=.FALSE.
+    omp_size=1
+    omp_rank=0
+#endif
+
+   is_omp_root=.FALSE.
+!$OMP MASTER
+   IF (omp_rank==0) THEN
+     is_omp_root=.TRUE.
+   ELSE
+     abort_message = 'ANORMAL : OMP_MASTER /= 0'
+     CALL abort_gcm (modname,abort_message,1)
+   ENDIF
+!$OMP END MASTER
+
+
+!$OMP MASTER 
+    ALLOCATE(klon_omp_para_nb(0:omp_size-1))
+    ALLOCATE(klon_omp_para_begin(0:omp_size-1))
+    ALLOCATE(klon_omp_para_end(0:omp_size-1))
+    
+    DO i=0,omp_size-1
+      klon_omp_para_nb(i)=klon_mpi/omp_size
+      IF (i<MOD(klon_mpi,omp_size)) klon_omp_para_nb(i)=klon_omp_para_nb(i)+1
+    ENDDO
+    
+    klon_omp_para_begin(0) = 1
+    klon_omp_para_end(0) = klon_omp_para_nb(0)
+    
+    DO i=1,omp_size-1
+      klon_omp_para_begin(i)=klon_omp_para_end(i-1)+1
+      klon_omp_para_end(i)=klon_omp_para_begin(i)+klon_omp_para_nb(i)-1
+    ENDDO
+!$OMP END MASTER
+!$OMP BARRIER
+   
+    klon_omp=klon_omp_para_nb(omp_rank)
+    klon_omp_begin=klon_omp_para_begin(omp_rank)
+    klon_omp_end=klon_omp_para_end(omp_rank)
+    
+    CALL Print_module_data
+    
+  END SUBROUTINE Init_phys_lmdz_omp_data
+
+  SUBROUTINE Print_module_data
+  IMPLICIT NONE
+  INCLUDE "iniprint.h"
+
+!$OMP CRITICAL  
+  WRITE(lunout,*)'--------> TASK ',omp_rank
+  WRITE(lunout,*)'omp_size =',omp_size
+  WRITE(lunout,*)'omp_rank =',omp_rank
+  WRITE(lunout,*)'is_omp_root =',is_omp_root
+  WRITE(lunout,*)'klon_omp_para_nb =',klon_omp_para_nb
+  WRITE(lunout,*)'klon_omp_para_begin =',klon_omp_para_begin
+  WRITE(lunout,*)'klon_omp_para_end =',klon_omp_para_end    
+  WRITE(lunout,*)'klon_omp =',klon_omp
+  WRITE(lunout,*)'klon_omp_begin =',klon_omp_begin
+  WRITE(lunout,*)'klon_omp_end =',klon_omp_end    
+!$OMP END CRITICAL
+
+  END SUBROUTINE Print_module_data
+END MODULE mod_phys_lmdz_omp_data
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_omp_transfert.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_omp_transfert.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_omp_transfert.F90	(revision 17)
@@ -0,0 +1,1057 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_omp_transfert
+
+  PRIVATE
+  
+  INTEGER,PARAMETER :: grow_factor=1.5
+  INTEGER,PARAMETER :: size_min=1024
+  
+  CHARACTER(LEN=size_min),SAVE            :: buffer_c
+!  INTEGER,SAVE                            :: size_c=0
+  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:)   :: buffer_i
+  INTEGER,SAVE                            :: size_i=0
+  REAL,SAVE,ALLOCATABLE,DIMENSION(:)      :: buffer_r
+  INTEGER,SAVE                            :: size_r=0
+  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:)   :: buffer_l
+  INTEGER,SAVE                            :: size_l=0
+
+
+  
+  
+  INTERFACE bcast_omp
+    MODULE PROCEDURE bcast_omp_c,                                                     &
+                     bcast_omp_i,bcast_omp_i1,bcast_omp_i2,bcast_omp_i3,bcast_omp_i4, &
+                     bcast_omp_r,bcast_omp_r1,bcast_omp_r2,bcast_omp_r3,bcast_omp_r4, &
+		     bcast_omp_l,bcast_omp_l1,bcast_omp_l2,bcast_omp_l3,bcast_omp_l4
+  END INTERFACE
+
+  INTERFACE scatter_omp
+    MODULE PROCEDURE scatter_omp_i,scatter_omp_i1,scatter_omp_i2,scatter_omp_i3, &
+                     scatter_omp_r,scatter_omp_r1,scatter_omp_r2,scatter_omp_r3, &
+		     scatter_omp_l,scatter_omp_l1,scatter_omp_l2,scatter_omp_l3
+  END INTERFACE
+
+  
+  INTERFACE gather_omp
+    MODULE PROCEDURE gather_omp_i,gather_omp_i1,gather_omp_i2,gather_omp_i3, &
+                     gather_omp_r,gather_omp_r1,gather_omp_r2,gather_omp_r3, &
+		     gather_omp_l,gather_omp_l1,gather_omp_l2,gather_omp_l3  
+  END INTERFACE
+  
+  
+  INTERFACE reduce_sum_omp
+    MODULE PROCEDURE reduce_sum_omp_i,reduce_sum_omp_i1,reduce_sum_omp_i2,reduce_sum_omp_i3,reduce_sum_omp_i4, &
+                     reduce_sum_omp_r,reduce_sum_omp_r1,reduce_sum_omp_r2,reduce_sum_omp_r3,reduce_sum_omp_r4
+  END INTERFACE 
+
+
+  PUBLIC bcast_omp,scatter_omp,gather_omp,reduce_sum_omp
+
+CONTAINS
+
+  SUBROUTINE check_buffer_i(buff_size)
+  IMPLICIT NONE
+  INTEGER :: buff_size
+
+!$OMP BARRIER
+!$OMP MASTER
+    IF (buff_size>size_i) THEN
+      IF (ALLOCATED(buffer_i)) DEALLOCATE(buffer_i)
+      size_i=MAX(size_min,INT(grow_factor*buff_size))
+      ALLOCATE(buffer_i(size_i))
+    ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  
+  END SUBROUTINE check_buffer_i
+  
+  SUBROUTINE check_buffer_r(buff_size)
+  IMPLICIT NONE
+  INTEGER :: buff_size
+
+!$OMP BARRIER
+!$OMP MASTER
+    IF (buff_size>size_r) THEN
+      IF (ALLOCATED(buffer_r)) DEALLOCATE(buffer_r)
+      size_r=MAX(size_min,INT(grow_factor*buff_size))
+      ALLOCATE(buffer_r(size_r))
+    ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  
+  END SUBROUTINE check_buffer_r
+  
+  SUBROUTINE check_buffer_l(buff_size)
+  IMPLICIT NONE
+  INTEGER :: buff_size
+
+!$OMP BARRIER
+!$OMP MASTER
+    IF (buff_size>size_l) THEN
+      IF (ALLOCATED(buffer_l)) DEALLOCATE(buffer_l)
+      size_l=MAX(size_min,INT(grow_factor*buff_size))
+      ALLOCATE(buffer_l(size_l))
+    ENDIF
+!$OMP END MASTER
+!$OMP BARRIER
+  
+  END SUBROUTINE check_buffer_l
+    
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Broadcast --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! -- Les chaine de charactère -- !!
+
+  SUBROUTINE bcast_omp_c(var)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    
+    CALL bcast_omp_cgen(Var,len(Var),buffer_c)
+    
+  END SUBROUTINE bcast_omp_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_omp_i(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var
+    INTEGER :: Var_tmp(1)
+    
+    Var_tmp(1)=Var
+    CALL check_buffer_i(1)
+    CALL bcast_omp_igen(Var_tmp,1,buffer_i)
+    Var=Var_tmp(1)
+
+  END SUBROUTINE bcast_omp_i
+
+
+  SUBROUTINE bcast_omp_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
+
+  END SUBROUTINE bcast_omp_i1
+
+
+  SUBROUTINE bcast_omp_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
+
+  END SUBROUTINE bcast_omp_i2
+
+
+  SUBROUTINE bcast_omp_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
+
+  END SUBROUTINE bcast_omp_i3
+
+
+  SUBROUTINE bcast_omp_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL check_buffer_i(size(Var))
+    CALL bcast_omp_igen(Var,size(Var),buffer_i)
+
+  END SUBROUTINE bcast_omp_i4
+
+
+!! -- Les reels -- !!
+
+  SUBROUTINE bcast_omp_r(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+    REAL :: Var_tmp(1)
+    
+    Var_tmp(1)=Var
+    CALL check_buffer_r(1)
+    CALL bcast_omp_rgen(Var_tmp,1,buffer_r)
+    Var=Var_tmp(1)
+
+  END SUBROUTINE bcast_omp_r
+
+
+  SUBROUTINE bcast_omp_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
+
+  END SUBROUTINE bcast_omp_r1
+
+
+  SUBROUTINE bcast_omp_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
+
+  END SUBROUTINE bcast_omp_r2
+
+
+  SUBROUTINE bcast_omp_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
+
+  END SUBROUTINE bcast_omp_r3
+
+
+  SUBROUTINE bcast_omp_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL check_buffer_r(size(Var))
+    CALL bcast_omp_rgen(Var,size(Var),buffer_r)
+
+  END SUBROUTINE bcast_omp_r4
+
+  
+!! -- Les booleans -- !!
+
+  SUBROUTINE bcast_omp_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+    LOGICAL :: Var_tmp(1)
+    
+    Var_tmp(1)=Var
+    CALL check_buffer_l(1)
+    CALL bcast_omp_lgen(Var_tmp,1,buffer_l)
+    Var=Var_tmp(1)
+
+  END SUBROUTINE bcast_omp_l
+
+
+  SUBROUTINE bcast_omp_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
+
+  END SUBROUTINE bcast_omp_l1
+
+
+  SUBROUTINE bcast_omp_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
+
+  END SUBROUTINE bcast_omp_l2
+
+
+  SUBROUTINE bcast_omp_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
+
+  END SUBROUTINE bcast_omp_l3
+
+
+  SUBROUTINE bcast_omp_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+    CALL check_buffer_l(size(Var))
+    CALL bcast_omp_lgen(Var,size(Var),buffer_l)
+
+  END SUBROUTINE bcast_omp_l4
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_omp_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,1,buffer_i)
+    
+  END SUBROUTINE scatter_omp_i
+
+
+  SUBROUTINE scatter_omp_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2),buffer_i)
+    
+  END SUBROUTINE scatter_omp_i1
+  
+  
+  SUBROUTINE scatter_omp_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_i)
+
+  END SUBROUTINE scatter_omp_i2
+
+
+  SUBROUTINE scatter_omp_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL scatter_omp_igen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_i)
+  
+  END SUBROUTINE scatter_omp_i3
+
+
+
+
+  SUBROUTINE scatter_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,1,buffer_r)
+    
+  END SUBROUTINE scatter_omp_r
+
+
+  SUBROUTINE scatter_omp_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2),buffer_r)
+        
+  END SUBROUTINE scatter_omp_r1
+  
+  
+  SUBROUTINE scatter_omp_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_r)
+
+  END SUBROUTINE scatter_omp_r2
+
+
+  SUBROUTINE scatter_omp_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL scatter_omp_rgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_r)
+  
+  END SUBROUTINE scatter_omp_r3
+  
+
+
+  SUBROUTINE scatter_omp_l(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,1,buffer_l)
+    
+  END SUBROUTINE scatter_omp_l
+
+
+  SUBROUTINE scatter_omp_l1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2),buffer_l)
+    
+  END SUBROUTINE scatter_omp_l1
+  
+  
+  SUBROUTINE scatter_omp_l2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3),buffer_l)
+
+  END SUBROUTINE scatter_omp_l2
+
+
+  SUBROUTINE scatter_omp_l3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarIn))   
+    CALL scatter_omp_lgen(VarIn,Varout,Size(VarOut,2)*Size(VarOut,3)*Size(VarOut,4),buffer_l)
+  
+  END SUBROUTINE scatter_omp_l3  
+  
+
+  SUBROUTINE gather_omp_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,1,buffer_i)
+    
+  END SUBROUTINE gather_omp_i
+
+
+  SUBROUTINE gather_omp_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2),buffer_i)
+    
+  END SUBROUTINE gather_omp_i1
+
+
+  SUBROUTINE gather_omp_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_i)
+          
+  END SUBROUTINE gather_omp_i2
+  
+
+  SUBROUTINE gather_omp_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarOut))   
+    CALL gather_omp_igen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_i)
+    
+  END SUBROUTINE gather_omp_i3
+
+
+
+  SUBROUTINE gather_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_r(size(VarOut))   
+    CALL gather_omp_rgen(VarIn,Varout,1,buffer_r)
+    
+  END SUBROUTINE gather_omp_r
+
+
+  SUBROUTINE gather_omp_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    CALL Check_buffer_r(size(VarOut))   
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2),buffer_r)
+        
+  END SUBROUTINE gather_omp_r1
+
+
+  SUBROUTINE gather_omp_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarOut))   
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_r)
+    
+  END SUBROUTINE gather_omp_r2
+  
+
+  SUBROUTINE gather_omp_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    CALL Check_buffer_r(size(VarOut))       
+    CALL gather_omp_rgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_r)
+    
+  END SUBROUTINE gather_omp_r3
+
+
+  SUBROUTINE gather_omp_l(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,1,buffer_l)
+    
+  END SUBROUTINE gather_omp_l
+
+
+  SUBROUTINE gather_omp_l1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2),buffer_l)
+    
+  END SUBROUTINE gather_omp_l1
+
+
+  SUBROUTINE gather_omp_l2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3),buffer_l)
+    
+  END SUBROUTINE gather_omp_l2
+  
+
+  SUBROUTINE gather_omp_l3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    CALL Check_buffer_l(size(VarOut))   
+    CALL gather_omp_lgen(VarIn,Varout,Size(VarIn,2)*Size(VarIn,3)*Size(VarIn,4),buffer_l)
+    
+  END SUBROUTINE gather_omp_l3
+
+
+
+
+  SUBROUTINE reduce_sum_omp_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    INTEGER             :: VarIn_tmp(1)
+    INTEGER             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn
+    CALL Check_buffer_i(1)   
+    CALL reduce_sum_omp_igen(VarIn_tmp,Varout_tmp,1,buffer_i)
+    VarOut=VarOut_tmp(1)
+    
+  END SUBROUTINE reduce_sum_omp_i
+
+  SUBROUTINE reduce_sum_omp_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+   
+  END SUBROUTINE reduce_sum_omp_i1
+  
+  
+  SUBROUTINE reduce_sum_omp_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+  
+  END SUBROUTINE reduce_sum_omp_i2
+
+
+  SUBROUTINE reduce_sum_omp_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+  
+  END SUBROUTINE reduce_sum_omp_i3
+
+
+  SUBROUTINE reduce_sum_omp_i4(VarIn, VarOut)
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+  
+    CALL Check_buffer_i(size(VarIn))   
+    CALL reduce_sum_omp_igen(VarIn,Varout,Size(VarIn),buffer_i)
+  
+  END SUBROUTINE reduce_sum_omp_i4
+
+
+  SUBROUTINE reduce_sum_omp_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    REAL             :: VarIn_tmp(1)
+    REAL             :: VarOut_tmp(1)
+    
+    VarIn_tmp(1)=VarIn
+    CALL Check_buffer_r(1)   
+    CALL reduce_sum_omp_rgen(VarIn_tmp,Varout_tmp,1,buffer_r)
+    VarOut=VarOut_tmp(1)
+  
+  END SUBROUTINE reduce_sum_omp_r
+
+  SUBROUTINE reduce_sum_omp_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+   
+  END SUBROUTINE reduce_sum_omp_r1
+  
+  
+  SUBROUTINE reduce_sum_omp_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+  
+  END SUBROUTINE reduce_sum_omp_r2
+
+
+  SUBROUTINE reduce_sum_omp_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+  
+  END SUBROUTINE reduce_sum_omp_r3
+
+
+  SUBROUTINE reduce_sum_omp_r4(VarIn, VarOut)
+    IMPLICIT NONE
+
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+  
+    CALL Check_buffer_r(size(VarIn))   
+    CALL reduce_sum_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r)
+  
+  END SUBROUTINE reduce_sum_omp_r4
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!    LES ROUTINES GENERIQUES    !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE bcast_omp_cgen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+    CHARACTER(LEN=*),INTENT(INOUT) :: Buff
+    INTEGER,INTENT(IN) :: Nb
+    
+    INTEGER :: i
+  
+  !$OMP MASTER
+      Buff=Var
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var=Buff
+    ENDDO
+  !$OMP BARRIER      
+  
+  END SUBROUTINE bcast_omp_cgen
+
+
+      
+  SUBROUTINE bcast_omp_igen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Var
+    INTEGER,DIMENSION(Nb),INTENT(INOUT) :: Buff
+    INTEGER,INTENT(IN) :: Nb
+
+    INTEGER :: i
+    
+  !$OMP MASTER
+    DO i=1,Nb
+      Buff(i)=Var(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var(i)=Buff(i)
+    ENDDO
+  !$OMP BARRIER        
+
+  END SUBROUTINE bcast_omp_igen
+
+
+  SUBROUTINE bcast_omp_rgen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    REAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+    REAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+    INTEGER,INTENT(IN) :: Nb
+
+    INTEGER :: i
+    
+  !$OMP MASTER
+    DO i=1,Nb
+      Buff(i)=Var(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var(i)=Buff(i)
+    ENDDO
+  !$OMP BARRIER        
+
+  END SUBROUTINE bcast_omp_rgen
+
+  SUBROUTINE bcast_omp_lgen(Var,Nb,Buff)
+  IMPLICIT NONE
+    
+    LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Var
+    LOGICAL,DIMENSION(Nb),INTENT(INOUT) :: Buff
+    INTEGER,INTENT(IN) :: Nb
+  
+    INTEGER :: i
+    
+  !$OMP MASTER
+    DO i=1,Nb
+      Buff(i)=Var(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,Nb
+      Var(i)=Buff(i)
+    ENDDO
+  !$OMP BARRIER        
+
+  END SUBROUTINE bcast_omp_lgen
+
+
+  SUBROUTINE scatter_omp_igen(VarIn,VarOut,dimsize,Buff)
+    USE mod_phys_lmdz_omp_data
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+    IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
+    INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        Buff(ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+ 
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+ 
+  END SUBROUTINE scatter_omp_igen
+
+
+  SUBROUTINE scatter_omp_rgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
+    REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        Buff(ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+  END SUBROUTINE scatter_omp_rgen
+
+
+  SUBROUTINE scatter_omp_lgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_mpi,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_omp,dimsize) :: VarOut
+    LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+ !$OMP MASTER 
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        Buff(ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        VarOut(ij,i)=Buff(klon_omp_begin-1+ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+  END SUBROUTINE scatter_omp_lgen
+
+
+
+
+
+  SUBROUTINE gather_omp_igen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+    INTEGER,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=Buff(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+  END SUBROUTINE gather_omp_igen
+
+
+  SUBROUTINE gather_omp_rgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+    REAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=Buff(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+  END SUBROUTINE gather_omp_rgen
+
+
+  SUBROUTINE gather_omp_lgen(VarIn,VarOut,dimsize,Buff)
+  USE mod_phys_lmdz_omp_data
+  USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi 
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    LOGICAL,INTENT(IN),DIMENSION(klon_omp,dimsize) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(klon_mpi,dimsize) :: VarOut
+    LOGICAL,INTENT(INOUT),DIMENSION(klon_mpi,dimsize) :: Buff
+
+    INTEGER :: i,ij
+    
+    DO i=1,dimsize
+      DO ij=1,klon_omp
+        Buff(klon_omp_begin-1+ij,i)=VarIn(ij,i)
+      ENDDO
+    ENDDO
+  !$OMP BARRIER  
+
+
+  !$OMP MASTER
+    DO i=1,dimsize
+      DO ij=1,klon_mpi
+        VarOut(ij,i)=Buff(ij,i)
+      ENDDO
+    ENDDO  
+  !$OMP END MASTER
+  !$OMP BARRIER
+
+  END SUBROUTINE gather_omp_lgen
+
+
+  SUBROUTINE reduce_sum_omp_igen(VarIn,VarOut,dimsize,Buff)
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut
+    INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff
+
+    INTEGER :: i
+
+  !$OMP MASTER
+    Buff(:)=0
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  !$OMP CRITICAL     
+    DO i=1,dimsize
+      Buff(i)=Buff(i)+VarIn(i)
+    ENDDO
+  !$OMP END CRITICAL
+  !$OMP BARRIER  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      VarOut(i)=Buff(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  END SUBROUTINE reduce_sum_omp_igen
+
+  SUBROUTINE reduce_sum_omp_rgen(VarIn,VarOut,dimsize,Buff)
+  IMPLICIT NONE
+
+    INTEGER,INTENT(IN) :: dimsize
+    REAL,INTENT(IN),DIMENSION(dimsize) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(dimsize) :: VarOut
+    REAL,INTENT(INOUT),DIMENSION(dimsize) :: Buff
+
+    INTEGER :: i
+
+  !$OMP MASTER
+    Buff(:)=0
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  !$OMP CRITICAL     
+    DO i=1,dimsize
+      Buff(i)=Buff(i)+VarIn(i)
+    ENDDO
+  !$OMP END CRITICAL
+  !$OMP BARRIER  
+  
+  !$OMP MASTER
+    DO i=1,dimsize
+      VarOut(i)=Buff(i)
+    ENDDO
+  !$OMP END MASTER
+  !$OMP BARRIER
+  
+  END SUBROUTINE reduce_sum_omp_rgen
+
+END MODULE mod_phys_lmdz_omp_transfert
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_para.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_para.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_para.F90	(revision 17)
@@ -0,0 +1,113 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_para
+  USE mod_phys_lmdz_transfert_para
+  USE mod_phys_lmdz_mpi_data
+  USE mod_phys_lmdz_omp_data
+    
+  INTEGER,SAVE :: klon_loc
+  LOGICAL,SAVE :: is_sequential
+  LOGICAL,SAVE :: is_parallel
+  LOGICAL,SAVE :: is_master
+  
+!$OMP THREADPRIVATE(klon_loc,is_master)
+  
+CONTAINS
+
+  SUBROUTINE Init_phys_lmdz_para(iim,jjp1,nb_proc,distrib)
+  IMPLICIT NONE
+    INTEGER,INTENT(in) :: iim
+    INTEGER,INTENT(in) :: jjp1
+    INTEGER,INTENT(in) :: nb_proc
+    INTEGER,INTENT(in) :: distrib(0:nb_proc-1)
+
+    CALL Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib)
+!$OMP PARALLEL
+    CALL Init_phys_lmdz_omp_data(klon_mpi)
+    klon_loc=klon_omp
+    IF (is_mpi_root .AND. is_omp_root) THEN 
+       is_master=.TRUE.
+     ELSE
+       is_master=.FALSE.
+     ENDIF
+    CALL Test_transfert
+!$OMP END PARALLEL    
+     IF (is_using_mpi .OR. is_using_omp) THEN
+       is_sequential=.FALSE.
+       is_parallel=.TRUE.
+     ELSE
+       is_sequential=.TRUE.
+       is_parallel=.FALSE.
+     ENDIF
+      
+  END SUBROUTINE Init_phys_lmdz_para
+
+  SUBROUTINE Test_transfert
+  USE mod_grid_phy_lmdz
+  IMPLICIT NONE
+    INCLUDE "iniprint.h"
+ 
+    REAL :: Test_Field1d_glo(klon_glo,nbp_lev)
+    REAL :: tmp1d_glo(klon_glo,nbp_lev)
+    REAL :: Test_Field2d_glo(nbp_lon,nbp_lat,nbp_lev)
+    REAL :: tmp2d_glo(nbp_lon,nbp_lat,nbp_lev)
+    REAL :: Test_Field1d_loc(klon_loc,nbp_lev)
+    REAL :: Test_Field2d_loc(nbp_lon,jj_nb,nbp_lev)
+    REAL :: CheckSum
+    
+    INTEGER :: i,l
+
+    Test_Field1d_glo = 0.
+    Test_Field2d_glo = 0.
+    Test_Field1d_loc = 0.
+    Test_Field2d_loc = 0.
+  
+    IF (is_mpi_root) THEN
+!$OMP MASTER
+      DO l=1,nbp_lev
+        DO i=1,klon_glo
+!          Test_Field1d_glo(i,l)=MOD(i,10)+10*(l-1)
+           Test_Field1d_glo(i,l)=1
+        ENDDO
+      ENDDO
+!$OMP END MASTER  
+    ENDIF
+  
+    CALL Scatter(Test_Field1d_glo,Test_Field1d_loc)
+    CALL Gather(Test_Field1d_loc,tmp1d_glo)
+   
+    IF (is_mpi_root) THEN
+!$OMP MASTER  
+      Checksum=sum(Test_Field1d_glo-tmp1d_glo)
+      WRITE(lunout,*) "------> Checksum =",Checksum," MUST BE 0"
+!$OMP END MASTER
+    ENDIF
+    
+    CALL grid1dTo2d_glo(Test_Field1d_glo,Test_Field2d_glo)
+    CALL scatter2D(Test_Field2d_glo,Test_Field1d_loc)
+    CALL gather2d(Test_Field1d_loc,Test_Field2d_glo)
+    CALL grid2dTo1d_glo(Test_Field2d_glo,tmp1d_glo)
+
+    IF (is_mpi_root) THEN
+!$OMP MASTER  
+      Checksum=sum(Test_Field1d_glo-tmp1d_glo)
+      WRITE(lunout,*) "------> Checksum =",Checksum," MUST BE 0"
+!$OMP END MASTER
+    ENDIF
+
+    CALL bcast(Test_Field1d_glo)
+    CALL reduce_sum(Test_Field1d_glo,tmp1d_glo)
+
+    IF (is_mpi_root) THEN
+!$OMP MASTER  
+      Checksum=sum(Test_Field1d_glo*omp_size*mpi_size-tmp1d_glo)
+      WRITE(lunout,*) "------> Checksum =",Checksum," MUST BE 0"
+!$OMP END MASTER
+    ENDIF
+    
+     
+   END SUBROUTINE Test_transfert
+  
+END MODULE mod_phys_lmdz_para
+    
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_transfert_para.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_transfert_para.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_phys_lmdz_transfert_para.F90	(revision 17)
@@ -0,0 +1,1275 @@
+!
+!$Header$
+!
+MODULE mod_phys_lmdz_transfert_para
+
+  USE mod_phys_lmdz_mpi_transfert
+  USE mod_phys_lmdz_omp_transfert 
+
+
+
+  INTERFACE bcast
+    MODULE PROCEDURE bcast_c,                                     &
+                     bcast_i,bcast_i1,bcast_i2,bcast_i3,bcast_i4, &
+                     bcast_r,bcast_r1,bcast_r2,bcast_r3,bcast_r4, &
+		     bcast_l,bcast_l1,bcast_l2,bcast_l3,bcast_l4
+  END INTERFACE
+
+  INTERFACE scatter
+    MODULE PROCEDURE scatter_i,scatter_i1,scatter_i2,scatter_i3, &
+                     scatter_r,scatter_r1,scatter_r2,scatter_r3, &
+		     scatter_l,scatter_l1,scatter_l2,scatter_l3
+  END INTERFACE
+
+  
+  INTERFACE gather
+    MODULE PROCEDURE gather_i,gather_i1,gather_i2,gather_i3, &
+                     gather_r,gather_r1,gather_r2,gather_r3, &
+		     gather_l,gather_l1,gather_l2,gather_l3  
+  END INTERFACE
+  
+  INTERFACE scatter2D
+    MODULE PROCEDURE scatter2D_i,scatter2D_i1,scatter2D_i2,scatter2D_i3, &
+                     scatter2D_r,scatter2D_r1,scatter2D_r2,scatter2D_r3, &
+		     scatter2D_l,scatter2D_l1,scatter2D_l2,scatter2D_l3
+  END INTERFACE
+
+  INTERFACE gather2D
+    MODULE PROCEDURE gather2D_i,gather2D_i1,gather2D_i2,gather2D_i3, &
+                     gather2D_r,gather2D_r1,gather2D_r2,gather2D_r3, &
+		     gather2D_l,gather2D_l1,gather2D_l2,gather2D_l3
+  END INTERFACE 
+  
+  INTERFACE reduce_sum
+    MODULE PROCEDURE reduce_sum_i,reduce_sum_i1,reduce_sum_i2,reduce_sum_i3,reduce_sum_i4, &
+                     reduce_sum_r,reduce_sum_r1,reduce_sum_r2,reduce_sum_r3,reduce_sum_r4
+  END INTERFACE 
+
+   
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Broadcast --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! -- Les chaine de charactère -- !!
+
+  SUBROUTINE bcast_c(var)
+  IMPLICIT NONE
+    CHARACTER(LEN=*),INTENT(INOUT) :: Var
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_c
+
+!! -- Les entiers -- !!
+  
+  SUBROUTINE bcast_i(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i
+
+  SUBROUTINE bcast_i1(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i1
+
+
+  SUBROUTINE bcast_i2(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i2
+
+
+  SUBROUTINE bcast_i3(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i3
+
+
+  SUBROUTINE bcast_i4(var)
+  IMPLICIT NONE
+    INTEGER,INTENT(INOUT) :: Var(:,:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_i4
+
+ 
+!! -- Les reels -- !!
+  
+  SUBROUTINE bcast_r(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var
+
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r
+
+  SUBROUTINE bcast_r1(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r1
+
+
+  SUBROUTINE bcast_r2(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r2
+
+
+  SUBROUTINE bcast_r3(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r3
+
+
+  SUBROUTINE bcast_r4(var)
+  IMPLICIT NONE
+    REAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_r4 
+
+
+!! -- Les booleens -- !!
+  
+  SUBROUTINE bcast_l(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l
+
+  SUBROUTINE bcast_l1(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l1
+
+
+  SUBROUTINE bcast_l2(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l2
+
+
+  SUBROUTINE bcast_l3(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l3
+
+
+  SUBROUTINE bcast_l4(var)
+  IMPLICIT NONE
+    LOGICAL,INTENT(INOUT) :: Var(:,:,:,:)
+   
+!$OMP MASTER
+    CALL bcast_mpi(Var)
+!$OMP END MASTER
+    CALL bcast_omp(Var)
+    
+  END SUBROUTINE bcast_l4
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  SUBROUTINE scatter_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi) :: Var_tmp
+    
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_i
+
+
+  SUBROUTINE scatter_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_i1
+
+
+  SUBROUTINE scatter_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_i2
+
+
+  SUBROUTINE scatter_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter_i3
+
+
+  SUBROUTINE scatter_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi) :: Var_tmp
+    
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_r
+
+
+  SUBROUTINE scatter_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_r1
+
+
+  SUBROUTINE scatter_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_r2
+
+
+  SUBROUTINE scatter_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter_r3
+  
+  
+
+  SUBROUTINE scatter_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi) :: Var_tmp
+    
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_l
+
+
+  SUBROUTINE scatter_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_l1
+
+
+  SUBROUTINE scatter_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,Varout)
+    
+  END SUBROUTINE scatter_l2
+
+
+  SUBROUTINE scatter_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(Varout,2),SIZE(Varout,3),SIZE(Varout,4)) :: Var_tmp
+
+!$OMP MASTER
+      CALL scatter_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+      CALL scatter_omp(Var_tmp,VarOut)
+    
+  END SUBROUTINE scatter_l3
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ 
+!!!!! --> Les entiers
+
+  SUBROUTINE gather_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    INTEGER, DIMENSION(klon_mpi) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_i
+
+
+  SUBROUTINE gather_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,Varout)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_i1
+
+
+  SUBROUTINE gather_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_i2
+
+
+  SUBROUTINE gather_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_i3
+
+
+!!!!! --> Les reels
+
+  SUBROUTINE gather_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    REAL, DIMENSION(klon_mpi) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_r
+
+
+  SUBROUTINE gather_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_r1
+
+
+  SUBROUTINE gather_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_r2
+
+
+  SUBROUTINE gather_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_r3
+
+
+!!!!! --> Les booleens
+
+  SUBROUTINE gather_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_mpi) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_l
+
+
+  SUBROUTINE gather_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_l1
+
+
+  SUBROUTINE gather_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_l2
+
+
+  SUBROUTINE gather_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL, DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+    
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE gather_l3
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Scatter2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+!!!!! --> Les entiers
+
+  SUBROUTINE scatter2D_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_i
+
+
+  SUBROUTINE scatter2D_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_i1
+  
+
+  SUBROUTINE scatter2D_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_i2  
+
+
+  SUBROUTINE scatter2D_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_i3
+  
+
+!!!!! --> Les reels
+
+  SUBROUTINE scatter2D_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_r
+
+
+  SUBROUTINE scatter2D_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_r1
+  
+
+  SUBROUTINE scatter2D_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_r2  
+
+
+  SUBROUTINE scatter2D_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    REAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_r3
+    
+    
+!!!!! --> Les booleens
+
+
+  SUBROUTINE scatter2D_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_l
+
+
+  SUBROUTINE scatter2D_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_l1
+  
+
+  SUBROUTINE scatter2D_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_l2  
+
+
+  SUBROUTINE scatter2D_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarOut,2),SIZE(VarOut,3),SIZE(VarOut,4)) :: Var_tmp    
+
+!$OMP MASTER    
+    CALL scatter2D_mpi(VarIn,Var_tmp)
+!$OMP END MASTER
+    CALL scatter_omp(Var_tmp,VarOut)
+
+  END SUBROUTINE scatter2D_l3
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des Gather2D   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!!! --> Les entiers
+
+  SUBROUTINE gather2D_i(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_i
+  
+
+  SUBROUTINE gather2D_i1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_i1
+
+  
+  SUBROUTINE gather2D_i2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_i2
+
+
+  SUBROUTINE gather2D_i3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_i3
+
+
+!!!!! --> Les reels
+
+  SUBROUTINE gather2D_r(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_r
+  
+
+  SUBROUTINE gather2D_r1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_r1
+
+  
+  SUBROUTINE gather2D_r2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_r2
+
+
+  SUBROUTINE gather2D_r3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_r3
+  
+
+!!!!! --> Les booleens
+
+  SUBROUTINE gather2D_l(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_l
+  
+
+  SUBROUTINE gather2D_l1(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_l1
+
+  
+  SUBROUTINE gather2D_l2(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_l2
+
+
+  SUBROUTINE gather2D_l3(VarIn, VarOut)
+    USE mod_phys_lmdz_mpi_data, ONLY : klon_mpi
+    IMPLICIT NONE
+  
+    LOGICAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn
+    LOGICAL,INTENT(OUT),DIMENSION(:,:,:,:,:) :: VarOut
+    
+    LOGICAL,DIMENSION(klon_mpi,SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp
+
+    CALL gather_omp(VarIn,Var_tmp)
+!$OMP MASTER
+    CALL gather2D_mpi(Var_tmp,VarOut)
+!$OMP END MASTER    
+
+  END SUBROUTINE gather2D_l3
+  
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition des reduce_sum   --> 4D   !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! Les entiers
+
+  SUBROUTINE reduce_sum_i(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN)  :: VarIn
+    INTEGER,INTENT(OUT) :: VarOut
+    
+    INTEGER             :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i  
+
+
+  SUBROUTINE reduce_sum_i1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn))   :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i1  
+
+
+  SUBROUTINE reduce_sum_i2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i2  
+  
+
+  SUBROUTINE reduce_sum_i3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i3  
+
+
+  SUBROUTINE reduce_sum_i4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    INTEGER,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_i4  
+
+
+! Les reels
+
+  SUBROUTINE reduce_sum_r(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN)  :: VarIn
+    REAL,INTENT(OUT) :: VarOut
+    
+    REAL             :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r  
+
+
+  SUBROUTINE reduce_sum_r1(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn))   :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r1  
+
+
+  SUBROUTINE reduce_sum_r2(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r2  
+  
+
+  SUBROUTINE reduce_sum_r3(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r3  
+
+
+  SUBROUTINE reduce_sum_r4(VarIn, VarOut)
+    IMPLICIT NONE
+  
+    REAL,INTENT(IN),DIMENSION(:,:,:,:)  :: VarIn
+    REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut
+    
+    REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4))  :: Var_tmp
+           
+    CALL reduce_sum_omp(VarIn,Var_tmp)
+!$OMP MASTER      
+    CALL reduce_sum_mpi(Var_tmp,VarOut)
+!$OMP END MASTER
+  
+  END SUBROUTINE reduce_sum_r4  
+
+   
+END MODULE mod_phys_lmdz_transfert_para
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_surf_para.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_surf_para.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_surf_para.F90	(revision 17)
@@ -0,0 +1,350 @@
+MODULE mod_surf_para
+  IMPLICIT NONE
+  
+  INTERFACE gather_surf
+    MODULE PROCEDURE gather_surf_i,gather_surf_r
+  END INTERFACE gather_surf
+  
+  INTERFACE gather_surf_omp
+    MODULE PROCEDURE gather_surf_omp_i,gather_surf_omp_r
+  END INTERFACE gather_surf_omp
+
+  INTERFACE gather_surf_mpi
+    MODULE PROCEDURE gather_surf_mpi_i,gather_surf_mpi_r
+  END INTERFACE gather_surf_mpi
+
+  INTERFACE scatter_surf
+    MODULE PROCEDURE scatter_surf_i,scatter_surf_r
+  END INTERFACE scatter_surf
+  
+  INTERFACE scatter_surf_omp
+    MODULE PROCEDURE scatter_surf_omp_i,scatter_surf_omp_r
+  END INTERFACE scatter_surf_omp
+
+  INTERFACE scatter_surf_mpi
+    MODULE PROCEDURE scatter_surf_mpi_i,scatter_surf_mpi_r
+  END INTERFACE scatter_surf_mpi
+  
+  
+  INTEGER,SAVE             :: knon_omp
+  INTEGER,SAVE             :: knon_omp_begin
+  INTEGER,SAVE             :: knon_omp_end
+!$OMP THREADPRIVATE(knon_omp,knon_omp_begin,knon_omp_end)
+  INTEGER,ALLOCATABLE,SAVE :: knon_omp_para(:)
+  INTEGER,ALLOCATABLE,SAVE :: knon_omp_begin_para(:)
+  INTEGER,ALLOCATABLE,SAVE :: knon_omp_end_para(:)
+  
+  INTEGER,SAVE             :: knon_mpi
+  INTEGER,ALLOCATABLE,SAVE :: knon_mpi_para(:)
+  INTEGER,ALLOCATABLE,SAVE :: knon_mpi_begin_para(:)
+  INTEGER,ALLOCATABLE,SAVE :: knon_mpi_end_para(:)
+  
+  INTEGER,SAVE             :: knon_glo
+  INTEGER,SAVE,ALLOCATABLE :: knon_glo_para(:)  
+  INTEGER,ALLOCATABLE,SAVE :: knon_glo_begin_para(:)
+  INTEGER,ALLOCATABLE,SAVE :: knon_glo_end_para(:)
+  
+  
+CONTAINS
+
+  SUBROUTINE Init_surf_para(knon)
+  USE mod_phys_lmdz_para, mpi_rank_root=>mpi_root
+#ifdef CPP_MPI
+  INCLUDE 'mpif.h'
+#endif
+    INTEGER :: knon
+    INTEGER :: i,ierr
+    
+    knon_omp=knon
+    IF (is_omp_root) THEN
+      ALLOCATE(knon_omp_para(0:omp_size-1))
+      ALLOCATE(knon_omp_begin_para(0:omp_size-1))
+      ALLOCATE(knon_omp_end_para(0:omp_size-1))
+    ENDIF
+!$OMP BARRIER
+    knon_omp_para(omp_rank)=knon
+!$OMP BARRIER
+    IF (is_omp_root) THEN 
+      knon_omp_begin_para(0)=1
+      knon_omp_end_para(0)=knon_omp_para(0)
+      DO i=1,omp_size-1
+        knon_omp_begin_para(i)=knon_omp_end_para(i-1)+1
+        knon_omp_end_para(i)=knon_omp_begin_para(i)+knon_omp_para(i)-1
+      ENDDO
+    ENDIF 
+!$OMP BARRIER
+    knon_omp_begin=knon_omp_begin_para(omp_rank)
+    knon_omp_end=knon_omp_end_para(omp_rank)
+!$OMP BARRIER    
+    IF (is_omp_root) THEN
+      knon_mpi=sum(knon_omp_para)
+      ALLOCATE(knon_mpi_para(0:mpi_size-1))
+      ALLOCATE(knon_mpi_begin_para(0:mpi_size-1))
+      ALLOCATE(knon_mpi_end_para(0:mpi_size-1))
+      
+      ALLOCATE(knon_glo_para(0:mpi_size*omp_size-1))
+      ALLOCATE(knon_glo_begin_para(0:mpi_size*omp_size-1))
+      ALLOCATE(knon_glo_end_para(0:mpi_size*omp_size-1))
+      
+      IF (is_using_mpi) THEN
+#ifdef CPP_MPI
+        CALL MPI_ALLGather(knon_mpi,1,MPI_INTEGER,knon_mpi_para,1,MPI_INTEGER,COMM_LMDZ_PHY,ierr)
+        CALL MPI_ALLGather(knon_omp_para,omp_size,MPI_INTEGER,knon_glo_para,omp_size,MPI_INTEGER,COMM_LMDZ_PHY,ierr)
+#endif
+      ELSE
+        knon_mpi_para(:)=knon_mpi
+        knon_glo_para(:)=knon_omp_para(:)
+      ENDIF     
+      
+      knon_glo=sum(knon_mpi_para(:))
+      
+      knon_mpi_begin_para(0)=1
+      knon_mpi_end_para(0)=knon_mpi_para(0)
+      DO i=1,mpi_size-1
+        knon_mpi_begin_para(i)=knon_mpi_end_para(i-1)+1
+        knon_mpi_end_para(i)=knon_mpi_begin_para(i)+knon_mpi_para(i)-1
+      ENDDO
+      
+      knon_glo_begin_para(0)=1
+      knon_glo_end_para(0)=knon_glo_para(0)
+      DO i=1,mpi_size*omp_size-1
+        knon_glo_begin_para(i)=knon_glo_end_para(i-1)+1
+        knon_glo_end_para(i)= knon_glo_begin_para(i)+knon_glo_para(i)-1
+      ENDDO
+   ENDIF
+!$OMP BARRIER
+
+  END SUBROUTINE Init_surf_para
+
+ 
+  SUBROUTINE Finalize_surf_para
+  USE mod_phys_lmdz_para
+
+!$OMP BARRIER   
+   IF (is_omp_root) THEN
+      DEALLOCATE(knon_omp_para)
+      DEALLOCATE(knon_omp_begin_para)
+      DEALLOCATE(knon_omp_end_para)
+      DEALLOCATE(knon_mpi_para)
+      DEALLOCATE(knon_mpi_begin_para)
+      DEALLOCATE(knon_mpi_end_para)
+      DEALLOCATE(knon_glo_para)  
+      DEALLOCATE(knon_glo_begin_para)
+      DEALLOCATE(knon_glo_end_para)
+    ENDIF
+    
+  END SUBROUTINE Finalize_surf_para
+  
+  
+  SUBROUTINE gather_surf_i(FieldIn, FieldOut)
+  USE mod_phys_lmdz_para
+    INTEGER :: FieldIn(:)
+    INTEGER :: FieldOut(:)
+    INTEGER :: FieldTmp(knon_mpi)
+    
+    CALL gather_surf_omp_i(FieldIn,FieldTmp)
+    IF (is_omp_root) CALL gather_surf_mpi_i(FieldTmp,FieldOut)
+    
+  END SUBROUTINE gather_surf_i
+
+
+  SUBROUTINE gather_surf_omp_i(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para
+    INTEGER :: FieldIn(:)
+    INTEGER :: FieldOut(:)
+  
+    INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:)
+    
+    IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi))
+!$OMP BARRIER
+    Field_tmp(knon_omp_begin:knon_omp_end)=FieldIn(:)
+!$OMP BARRIER        
+    IF (is_omp_root) FieldOut(:)=Field_tmp(:)
+!$OMP BARRIER
+    IF (is_omp_root) DEALLOCATE(Field_tmp)
+    
+  END SUBROUTINE  gather_surf_omp_i
+  
+     
+  SUBROUTINE gather_surf_mpi_i(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para, mpi_rank_root => mpi_root
+#ifdef CPP_MPI
+  INCLUDE 'mpif.h'
+#endif
+    INTEGER :: FieldIn(:)
+    INTEGER :: FieldOut(:)
+    INTEGER :: ierr
+    
+    IF (is_using_mpi) THEN
+#ifdef CPP_MPI
+      CALL MPI_Gatherv(FieldIn,knon_mpi,MPI_INTEGER,                                &
+                       FieldOut,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER, &
+                       mpi_rank_root,COMM_LMDZ_PHY,ierr)
+#endif
+    ELSE
+      FieldOut(:)=FieldIn(:)
+    ENDIF
+  
+  END SUBROUTINE gather_surf_mpi_i
+  
+
+
+
+
+  SUBROUTINE gather_surf_r(FieldIn, FieldOut)
+  USE mod_phys_lmdz_para
+    REAL :: FieldIn(:)
+    REAL :: FieldOut(:)
+    REAL :: FieldTmp(knon_mpi)
+    
+    CALL gather_surf_omp_r(FieldIn,FieldTmp)
+    IF (is_omp_root) CALL gather_surf_mpi_r(FieldTmp,FieldOut)
+    
+  END SUBROUTINE gather_surf_r
+
+
+  SUBROUTINE gather_surf_omp_r(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para
+    REAL :: FieldIn(:)
+    REAL :: FieldOut(:)
+  
+    REAL,SAVE,ALLOCATABLE :: Field_tmp(:)
+    
+    IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi))
+!$OMP BARRIER
+    Field_tmp(knon_omp_begin:knon_omp_end)=FieldIn(:)
+!$OMP BARRIER        
+    IF (is_omp_root) FieldOut(:)=Field_tmp(:)
+!$OMP BARRIER
+    IF (is_omp_root) DEALLOCATE(Field_tmp)
+    
+  END SUBROUTINE  gather_surf_omp_r
+  
+     
+  SUBROUTINE gather_surf_mpi_r(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para, mpi_rank_root => mpi_root
+#ifdef CPP_MPI
+  INCLUDE 'mpif.h'
+#endif
+    REAL :: FieldIn(:)
+    REAL :: FieldOut(:)
+    REAL :: ierr
+    
+    IF (is_using_mpi) THEN
+#ifdef CPP_MPI
+      CALL MPI_Gatherv(FieldIn,knon_mpi,MPI_REAL_LMDZ,                                 &
+                       FieldOut,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_REAL_LMDZ,  &
+                       mpi_rank_root,COMM_LMDZ_PHY,ierr)            
+#endif
+    ELSE
+      FieldOut(:)=FieldIn(:)
+    ENDIF
+  
+  END SUBROUTINE gather_surf_mpi_r
+
+
+
+
+  SUBROUTINE scatter_surf_i(FieldIn, FieldOut)
+  USE mod_phys_lmdz_para
+    INTEGER :: FieldIn(:)
+    INTEGER :: FieldOut(:)
+    INTEGER :: FieldTmp(knon_mpi)
+    
+    IF (is_omp_root) CALL scatter_surf_mpi_i(FieldIn,FieldTmp)
+    CALL scatter_surf_omp_i(FieldTmp,FieldOut)
+    
+  END SUBROUTINE scatter_surf_i
+
+
+  SUBROUTINE scatter_surf_omp_i(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para
+    INTEGER :: FieldIn(:)
+    INTEGER :: FieldOut(:)
+  
+    INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:)
+    
+    IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi))
+    IF (is_omp_root) Field_tmp(:)=FieldIn(:)
+!$OMP BARRIER        
+    FieldOut(:)=Field_tmp(knon_omp_begin:knon_omp_end)
+!$OMP BARRIER
+    IF (is_omp_root) DEALLOCATE(Field_tmp)
+    
+  END SUBROUTINE  scatter_surf_omp_i
+  
+     
+  SUBROUTINE scatter_surf_mpi_i(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para, mpi_rank_root => mpi_root
+#ifdef CPP_MPI
+  INCLUDE 'mpif.h'
+#endif
+    INTEGER :: FieldIn(:)
+    INTEGER :: FieldOut(:)
+    INTEGER :: ierr
+    
+    IF (is_using_mpi) THEN
+#ifdef CPP_MPI
+      CALL MPI_Scatterv(FieldIn,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER,   &
+                        FieldOut,knon_mpi,MPI_INTEGER,                                &
+                        mpi_rank_root,COMM_LMDZ_PHY,ierr)
+#endif
+    ELSE
+      FieldOut(:)=FieldIn(:)
+    ENDIF
+  
+  END SUBROUTINE scatter_surf_mpi_i
+
+
+
+  SUBROUTINE scatter_surf_r(FieldIn, FieldOut)
+  USE mod_phys_lmdz_para
+    REAL :: FieldIn(:)
+    REAL :: FieldOut(:)
+    REAL :: FieldTmp(knon_mpi)
+    
+    IF (is_omp_root) CALL scatter_surf_mpi_r(FieldIn,FieldTmp)
+    CALL scatter_surf_omp_r(FieldTmp,FieldOut)
+    
+  END SUBROUTINE scatter_surf_r
+
+
+  SUBROUTINE scatter_surf_omp_r(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para
+    REAL :: FieldIn(:)
+    REAL :: FieldOut(:)
+  
+    INTEGER,SAVE,ALLOCATABLE :: Field_tmp(:)
+    
+    IF (is_omp_root) ALLOCATE(Field_tmp(knon_mpi))
+    IF (is_omp_root) Field_tmp(:)=FieldIn(:)
+!$OMP BARRIER        
+    FieldOut(:)=Field_tmp(knon_omp_begin:knon_omp_end)
+!$OMP BARRIER
+    IF (is_omp_root) DEALLOCATE(Field_tmp)
+    
+  END SUBROUTINE  scatter_surf_omp_r
+  
+     
+  SUBROUTINE scatter_surf_mpi_r(FieldIn,FieldOut)
+  USE mod_phys_lmdz_para, mpi_rank_root => mpi_root
+#ifdef CPP_MPI
+  INCLUDE 'mpif.h'
+#endif
+    REAL :: FieldIn(:)
+    REAL :: FieldOut(:)
+    INTEGER :: ierr
+    
+    IF (is_using_mpi) THEN
+#ifdef CPP_MPI
+      CALL MPI_Scatterv(FieldIn,knon_mpi_para,knon_mpi_begin_para(:)-1,MPI_INTEGER,   &
+                        FieldOut,knon_mpi,MPI_INTEGER,                                &
+                        mpi_rank_root,COMM_LMDZ_PHY,ierr)
+#endif
+    ELSE
+      FieldOut(:)=FieldIn(:)
+    ENDIF
+  
+  END SUBROUTINE scatter_surf_mpi_r
+
+END MODULE mod_surf_para
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_synchro_omp.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_synchro_omp.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/mod_synchro_omp.F90	(revision 17)
@@ -0,0 +1,34 @@
+MODULE mod_synchro_omp
+
+  LOGICAL,SAVE,ALLOCATABLE :: flag_omp(:)
+  
+CONTAINS
+
+  SUBROUTINE Init_synchro_omp
+  USE mod_phys_lmdz_para 
+  IMPLICIT NONE
+    
+    IF (is_omp_root) THEN
+      ALLOCATE(flag_omp(0:omp_size-1))
+      flag_omp(:)=.FALSE.
+    ENDIF
+!$OMP BARRIER
+
+  END SUBROUTINE Init_Synchro_omp
+  
+  SUBROUTINE Synchro_omp
+  USE mod_phys_lmdz_para
+  IMPLICIT NONE
+  
+    flag_omp(omp_rank)=.TRUE.
+!$OMP BARRIER
+    DO WHILE (.NOT. ALL(flag_omp))
+!$OMP BARRIER
+    ENDDO
+!$OMP BARRIER        
+    flag_omp(omp_rank)=.FALSE.
+!$OMP BARRIER
+
+   END SUBROUTINE Synchro_omp
+
+END MODULE mod_synchro_omp
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/module_model_constants.F.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/module_model_constants.F.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/module_model_constants.F.h	(revision 17)
@@ -0,0 +1,162 @@
+!WRF:MODEL_LAYER:CONSTANTS
+!
+!L. Fita, LMD. September 2013
+!! 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 :: n_ccn0       = 1.0E8
+!
+   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
+
+   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 ::  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.
+#ifdef HWRF
+       REAL , PARAMETER ::  fcm=0.0
+#else
+       REAL , PARAMETER ::  fcm=0.00003
+#endif
+       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
+#ifdef HWRF 
+       REAL , PARAMETER ::  z0max=0.01
+#else
+       REAL , PARAMETER ::  z0max=0.008
+#endif
+       REAL , PARAMETER ::  z0sea=0.001
+!#endif
+
+
+   !  Earth
+
+   !  The value for P2SI *must* be set to 1.0 for Earth
+   !  Although, now we may not need this declaration here (see above)
+   !REAL    , PARAMETER :: P2SI         = 1.0
+
+   !  Orbital constants:
+
+   INTEGER , PARAMETER :: PLANET_YEAR = 365
+   REAL , PARAMETER :: OBLIQUITY = 23.5
+   REAL , PARAMETER :: ECCENTRICITY = 0.014
+   REAL , PARAMETER :: SEMIMAJORAXIS = 1.0 ! In AU
+   ! Don't know the following values, so we'll fake them for now
+   REAL , PARAMETER :: zero_date = 0.0   ! Time of perihelion passage
+   !  Fraction into the year (from perhelion) of the
+   !  occurrence of the Northern Spring Equinox
+   REAL , PARAMETER :: EQUINOX_FRACTION= 0.0
+
+!L. Fita, LMD. September 2013
+! CONTAINS
+!   SUBROUTINE init_module_model_constants
+!   END SUBROUTINE init_module_model_constants
+! END MODULE module_model_constants
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/moy_undefSTD.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/moy_undefSTD.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/moy_undefSTD.F	(revision 17)
@@ -0,0 +1,126 @@
+!
+! $Id: moy_undefSTD.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE moy_undefSTD(itap,freq_outNMC,freq_moyNMC)
+      USE netcdf
+      USE dimphy
+      USE phys_state_var_mod ! Variables sauvegardees de la physique
+      IMPLICIT none
+c
+c====================================================================
+c
+c I. Musat : 09.2004
+c
+c Moyenne - a des frequences differentes - des valeurs bien definies
+c         (.NE.missing_val) des variables interpolees a un niveau de
+c         pression.
+c 1) les variables de type "day" (nout=1) ou "mth" (nout=2) sont sommees
+c    tous les pas de temps de la physique
+c
+c 2) les variables de type "NMC" (nout=3) sont calculees a partir
+c    des valeurs instantannees toutes les 6 heures
+c
+c
+c NB: mettre "inst(X)" dans le write_hist*NMC.h !
+c====================================================================
+cym#include "dimensions.h"
+cym      integer jjmp1
+cym      parameter (jjmp1=jjm+1-1/jjm)
+cym#include "dimphy.h"
+c
+c
+c variables Input
+c     INTEGER nlevSTD, klevSTD, itap
+c     PARAMETER(klevSTD=17)
+      INTEGER itap
+c
+c variables locales
+c     INTEGER i, k, nout, n
+c     PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
+      INTEGER i, k, n
+c     REAL dtime, freq_outNMC(nout), freq_moyNMC(nout)
+      REAL freq_outNMC(nout), freq_moyNMC(nout)
+c
+c variables Output
+c     REAL tnondef(klon,klevSTD,nout)
+c     REAL tsumSTD(klon,klevSTD,nout)
+c
+      REAL missing_val
+c
+      missing_val=nf90_fill_real
+c
+      DO n=1, nout
+c 
+c calcul 1 fois par jour
+c
+       IF(MOD(itap,NINT(freq_outNMC(n)/dtime)).EQ.0) THEN
+c
+        DO k=1, nlevSTD
+         DO i=1, klon
+          IF(tnondef(i,k,n).NE.(freq_moyNMC(n))) THEN
+           tsumSTD(i,k,n)=tsumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+cIM BEG
+          usumSTD(i,k,n)=usumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          vsumSTD(i,k,n)=vsumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          wsumSTD(i,k,n)=wsumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          phisumSTD(i,k,n)=phisumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          qsumSTD(i,k,n)=qsumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          rhsumSTD(i,k,n)=rhsumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          uvsumSTD(i,k,n)=uvsumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          vqsumSTD(i,k,n)=vqsumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          vTsumSTD(i,k,n)=vTsumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          wqsumSTD(i,k,n)=wqsumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          vphisumSTD(i,k,n)=vphisumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          wTsumSTD(i,k,n)=wTsumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          u2sumSTD(i,k,n)=u2sumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          v2sumSTD(i,k,n)=v2sumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          T2sumSTD(i,k,n)=T2sumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          O3sumSTD(i,k,n)=O3sumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+          O3daysumSTD(i,k,n)=O3daysumSTD(i,k,n)/
+     $     (freq_moyNMC(n)-tnondef(i,k,n))
+cIM END
+          ELSE
+           tsumSTD(i,k,n)=missing_val
+           usumSTD(i,k,n)=missing_val
+           vsumSTD(i,k,n)=missing_val
+           wsumSTD(i,k,n)=missing_val
+           phisumSTD(i,k,n)=missing_val
+           qsumSTD(i,k,n)=missing_val
+           rhsumSTD(i,k,n)=missing_val
+           uvsumSTD(i,k,n)=missing_val
+           vqsumSTD(i,k,n)=missing_val
+           vTsumSTD(i,k,n)=missing_val
+           wqsumSTD(i,k,n)=missing_val
+           vphisumSTD(i,k,n)=missing_val
+           wTsumSTD(i,k,n)=missing_val
+           u2sumSTD(i,k,n)=missing_val
+           v2sumSTD(i,k,n)=missing_val
+           T2sumSTD(i,k,n)=missing_val
+           O3sumSTD(i,k,n)=missing_val
+           O3daysumSTD(i,k,n)=missing_val
+          ENDIF !tnondef(i,k,n).NE.(freq_moyNMC(n))
+         ENDDO !i
+        ENDDO !k
+       ENDIF !MOD(itap,NINT(freq_outNMC(n)/dtime)).EQ.0
+c
+      ENDDO !n
+c
+      RETURN
+      END  
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/moy_undefSTD.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/moy_undefSTD.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/moy_undefSTD.F90	(revision 17)
@@ -0,0 +1,126 @@
+!
+! $Id: moy_undefSTD.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE moy_undefSTD(itap,freq_outNMC,freq_moyNMC)
+      USE netcdf
+      USE dimphy
+      USE phys_state_var_mod ! Variables sauvegardees de la physique
+      IMPLICIT none
+!c
+!c====================================================================
+!c
+!c I. Musat : 09.2004
+!c
+!c Moyenne - a des frequences differentes - des valeurs bien definies
+!c         (.NE.missing_val) des variables interpolees a un niveau de
+!c         pression.
+!c 1) les variables de type "day" (nout=1) ou "mth" (nout=2) sont sommees
+!c    tous les pas de temps de la physique
+!c
+!c 2) les variables de type "NMC" (nout=3) sont calculees a partir
+!c    des valeurs instantannees toutes les 6 heures
+!c
+!c
+!c NB: mettre "inst(X)" dans le write_hist*NMC.h !
+!c====================================================================
+!cym#include "dimensions.h"
+!cym      integer jjmp1
+!cym      parameter (jjmp1=jjm+1-1/jjm)
+!cym#include "dimphy.h"
+!c
+!c
+!c variables Input
+!c     INTEGER nlevSTD, klevSTD, itap
+!c     PARAMETER(klevSTD=17)
+      INTEGER itap
+!c
+!c variables locales
+!c     INTEGER i, k, nout, n
+!c     PARAMETER(nout=3) !nout=1 day/nout=2 mth/nout=3 NMC
+      INTEGER i, k, n
+!c     REAL dtime, freq_outNMC(nout), freq_moyNMC(nout)
+      REAL freq_outNMC(nout), freq_moyNMC(nout)
+!c
+!c variables Output
+!c     REAL tnondef(klon,klevSTD,nout)
+!c     REAL tsumSTD(klon,klevSTD,nout)
+!c
+      REAL missing_val
+!c
+      missing_val=nf90_fill_real
+!c
+      DO n=1, nout
+!c 
+!c calcul 1 fois par jour
+!c
+       IF(MOD(itap,NINT(freq_outNMC(n)/dtime)).EQ.0) THEN
+!c
+        DO k=1, nlevSTD
+         DO i=1, klon
+          IF(tnondef(i,k,n).NE.(freq_moyNMC(n))) THEN
+           tsumSTD(i,k,n)=tsumSTD(i,k,n)/                                            &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+!IM BEG
+          usumSTD(i,k,n)=usumSTD(i,k,n)/                                             &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          vsumSTD(i,k,n)=vsumSTD(i,k,n)/                                             &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          wsumSTD(i,k,n)=wsumSTD(i,k,n)/                                             &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          phisumSTD(i,k,n)=phisumSTD(i,k,n)/                                         &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          qsumSTD(i,k,n)=qsumSTD(i,k,n)/                                             &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          rhsumSTD(i,k,n)=rhsumSTD(i,k,n)/                                           &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          uvsumSTD(i,k,n)=uvsumSTD(i,k,n)/                                           &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          vqsumSTD(i,k,n)=vqsumSTD(i,k,n)/                                           &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          vTsumSTD(i,k,n)=vTsumSTD(i,k,n)/                                           &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          wqsumSTD(i,k,n)=wqsumSTD(i,k,n)/                                           &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          vphisumSTD(i,k,n)=vphisumSTD(i,k,n)/                                       &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          wTsumSTD(i,k,n)=wTsumSTD(i,k,n)/                                           &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          u2sumSTD(i,k,n)=u2sumSTD(i,k,n)/                                           &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          v2sumSTD(i,k,n)=v2sumSTD(i,k,n)/                                           &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          T2sumSTD(i,k,n)=T2sumSTD(i,k,n)/                                           &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          O3sumSTD(i,k,n)=O3sumSTD(i,k,n)/                                           &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+          O3daysumSTD(i,k,n)=O3daysumSTD(i,k,n)/                                     &
+       &     (freq_moyNMC(n)-tnondef(i,k,n))
+!IM END
+          ELSE
+           tsumSTD(i,k,n)=missing_val
+           usumSTD(i,k,n)=missing_val
+           vsumSTD(i,k,n)=missing_val
+           wsumSTD(i,k,n)=missing_val
+           phisumSTD(i,k,n)=missing_val
+           qsumSTD(i,k,n)=missing_val
+           rhsumSTD(i,k,n)=missing_val
+           uvsumSTD(i,k,n)=missing_val
+           vqsumSTD(i,k,n)=missing_val
+           vTsumSTD(i,k,n)=missing_val
+           wqsumSTD(i,k,n)=missing_val
+           vphisumSTD(i,k,n)=missing_val
+           wTsumSTD(i,k,n)=missing_val
+           u2sumSTD(i,k,n)=missing_val
+           v2sumSTD(i,k,n)=missing_val
+           T2sumSTD(i,k,n)=missing_val
+           O3sumSTD(i,k,n)=missing_val
+           O3daysumSTD(i,k,n)=missing_val
+          ENDIF !tnondef(i,k,n).NE.(freq_moyNMC(n))
+         ENDDO !i
+        ENDDO !k
+       ENDIF !MOD(itap,NINT(freq_outNMC(n)/dtime)).EQ.0
+!c
+      ENDDO !n
+!c
+      RETURN
+      END SUBROUTINE moy_undefSTD
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/moyglo_aire.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/moyglo_aire.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/moyglo_aire.F	(revision 17)
@@ -0,0 +1,161 @@
+!
+! $Header$
+!
+      SUBROUTINE moyglo_pondaire(nhori, champ, aire, 
+     .            ok_msk, msk, moyglo)
+c
+       USE dimphy
+       IMPLICIT none
+c
+c ==================================================================
+c I. Musat, 07.2004
+c
+c Calcul moyenne globale ponderee par l'aire totale, avec ou sans masque
+c
+c moyenne = Somme_(champ* aire)/Somme_aire
+c
+c ==================================================================
+c
+#include "dimensions.h"
+cym#include "dimphy.h"
+       INTEGER i, nhori
+       REAL champ(klon), aire(klon), msk(klon)
+       LOGICAL ok_msk 
+       REAL moyglo
+c
+c var locale
+       REAL airetot
+c
+c      PRINT*,'moyglo_pondaire nhori',nhori
+c
+       airetot=0.
+       moyglo=0.
+c
+       IF(ok_msk) THEN
+        DO i=1, nhori
+c        IF(msk(i).EQ.1.) THEN 
+         IF(msk(i).GT.0.) THEN 
+c
+c aire totale
+          airetot=airetot+aire(i)*msk(i)
+c
+c ponderation par la masse
+          moyglo=moyglo+champ(i)* aire(i)*msk(i) 
+         ENDIF
+        ENDDO
+c
+       ELSE !ok_msk
+        DO i=1, nhori
+c
+c aire totale
+          airetot=airetot+aire(i)
+c
+c ponderation par la masse
+          moyglo=moyglo+champ(i)* aire(i) 
+        ENDDO 
+c
+       ENDIF
+c 
+c moyenne ponderee par l'aire
+       moyglo=moyglo/airetot
+c
+       RETURN 
+       END
+c
+       SUBROUTINE moyglo_pondaima(nhori, nvert, champ,
+     . aire, pbord, moyglo)
+       USE dimphy
+       IMPLICIT none
+c ==================================================================
+c I. Musat, 07.2004
+c
+c Calcul moyenne globale ponderee par la masse d'air, divisee par l'aire
+c totale avec ou sans masque
+c
+c moyenne = Somme_(champ* masse_dair)/Somme_aire
+c
+c ==================================================================
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+       INTEGER i, k, nhori, nvert
+       REAL champ(klon,klev), aire(klon)
+       REAL pbord(klon,klev+1)
+       REAL moyglo
+c
+c var locale
+       REAL airetot
+c
+c      PRINT*,'moyglo_pondaima RG, nhori, nvert',RG,nhori,nvert
+c
+c ponderation par la masse
+       moyglo=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        moyglo=moyglo+
+     .  champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+c
+c aire totale
+       airetot=0.
+       DO i=1, nhori
+        airetot=airetot+aire(i)
+       ENDDO
+c
+c moyenne par mettre carre avec ponderation par la masse
+       moyglo=moyglo/airetot
+c
+      RETURN
+      END
+c
+       SUBROUTINE moyglo_pondmass(nhori, nvert, champ,
+     . aire, pbord, moyglo)
+       USE dimphy
+       IMPLICIT none
+c ==================================================================
+c I. Musat, 07.2004
+c
+c Calcul moyenne globale ponderee par la masse d'air, divisee par la
+c masse totale d'air, avec ou sans masque
+c
+c moyenne = Somme_(champ* masse_dair)/Somme_(masse_dair)
+c
+c ==================================================================
+#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+       INTEGER i, k, nhori, nvert
+       REAL champ(klon,klev), aire(klon)
+       REAL pbord(klon,klev+1)
+       REAL moyglo
+c
+c var locale
+       REAL massetot
+c
+c      PRINT*,'moyglo_pondmass RG, nhori, nvert',RG,nhori,nvert
+c
+c ponderation par la masse
+       moyglo=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        moyglo=moyglo+
+     .  champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+c
+c masse totale
+       massetot=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        massetot=massetot+
+     .  (pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+c
+c moyenne par mettre carre avec ponderation par la masse
+       moyglo=moyglo/massetot
+c
+      RETURN
+      END
+c
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/moyglo_aire.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/moyglo_aire.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/moyglo_aire.F90	(revision 17)
@@ -0,0 +1,161 @@
+!
+! $Header$
+!
+      SUBROUTINE moyglo_pondaire(nhori, champ, aire,                                 &
+       &            ok_msk, msk, moyglo)
+!c
+       USE dimphy
+       IMPLICIT none
+!c
+!c ==================================================================
+!c I. Musat, 07.2004
+!c
+!c Calcul moyenne globale ponderee par l'aire totale, avec ou sans masque
+!c
+!c moyenne = Somme_(champ* aire)/Somme_aire
+!c
+!c ==================================================================
+!c
+#include "dimensions.h"
+!cym#include "dimphy.h"
+       INTEGER i, nhori
+       REAL champ(klon), aire(klon), msk(klon)
+       LOGICAL ok_msk 
+       REAL moyglo
+!c
+!c var locale
+       REAL airetot
+!c
+!c      PRINT*,'moyglo_pondaire nhori',nhori
+!c
+       airetot=0.
+       moyglo=0.
+!c
+       IF(ok_msk) THEN
+        DO i=1, nhori
+!c        IF(msk(i).EQ.1.) THEN 
+         IF(msk(i).GT.0.) THEN 
+!c
+!c aire totale
+          airetot=airetot+aire(i)*msk(i)
+!c
+!c ponderation par la masse
+          moyglo=moyglo+champ(i)* aire(i)*msk(i) 
+         ENDIF
+        ENDDO
+!c
+       ELSE !ok_msk
+        DO i=1, nhori
+!c
+!c aire totale
+          airetot=airetot+aire(i)
+!c
+!c ponderation par la masse
+          moyglo=moyglo+champ(i)* aire(i) 
+        ENDDO 
+!c
+       ENDIF
+!c 
+!c moyenne ponderee par l'aire
+       moyglo=moyglo/airetot
+!c
+       RETURN 
+       END
+!c
+       SUBROUTINE moyglo_pondaima(nhori, nvert, champ,                               &
+       & aire, pbord, moyglo)
+       USE dimphy
+       IMPLICIT none
+!c ==================================================================
+!c I. Musat, 07.2004
+!c
+!c Calcul moyenne globale ponderee par la masse d'air, divisee par l'aire
+!c totale avec ou sans masque
+!c
+!c moyenne = Somme_(champ* masse_dair)/Somme_aire
+!c
+!c ==================================================================
+#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+       INTEGER i, k, nhori, nvert
+       REAL champ(klon,klev), aire(klon)
+       REAL pbord(klon,klev+1)
+       REAL moyglo
+!c
+!c var locale
+       REAL airetot
+!c
+!c      PRINT*,'moyglo_pondaima RG, nhori, nvert',RG,nhori,nvert
+!c
+!c ponderation par la masse
+       moyglo=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        moyglo=moyglo+                                                               &
+       &  champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+!c
+!c aire totale
+       airetot=0.
+       DO i=1, nhori
+        airetot=airetot+aire(i)
+       ENDDO
+!c
+!c moyenne par mettre carre avec ponderation par la masse
+       moyglo=moyglo/airetot
+!c
+      RETURN
+      END
+!c
+       SUBROUTINE moyglo_pondmass(nhori, nvert, champ,                               &
+       & aire, pbord, moyglo)
+       USE dimphy
+       IMPLICIT none
+!c ==================================================================
+!c I. Musat, 07.2004
+!c
+!c Calcul moyenne globale ponderee par la masse d'air, divisee par la
+!c masse totale d'air, avec ou sans masque
+!c
+!c moyenne = Somme_(champ* masse_dair)/Somme_(masse_dair)
+!c
+!c ==================================================================
+#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+       INTEGER i, k, nhori, nvert
+       REAL champ(klon,klev), aire(klon)
+       REAL pbord(klon,klev+1)
+       REAL moyglo
+!c
+!c var locale
+       REAL massetot
+!c
+!c      PRINT*,'moyglo_pondmass RG, nhori, nvert',RG,nhori,nvert
+!c
+!c ponderation par la masse
+       moyglo=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        moyglo=moyglo+                                                               &
+       &  champ(i,k)*(pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+!c
+!c masse totale
+       massetot=0.
+       DO k=1, nvert
+       DO i=1, nhori
+        massetot=massetot+                                                           &
+       &  (pbord(i,k)-pbord(i,k+1))/RG*aire(i)
+       ENDDO
+       ENDDO
+!c
+!c moyenne par mettre carre avec ponderation par la masse
+       moyglo=moyglo/massetot
+!c
+      RETURN
+      END
+!c
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/netcdf.inc
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/netcdf.inc	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/netcdf.inc	(revision 17)
@@ -0,0 +1,1726 @@
+!     NetCDF-3.
+!
+! netcdf version 3 fortran interface:
+!
+
+!
+! external netcdf data types:
+!
+      integer nf_byte
+      integer nf_int1
+      integer nf_char
+      integer nf_short
+      integer nf_int2
+      integer nf_int
+      integer nf_float
+      integer nf_real
+      integer nf_double
+
+      parameter (nf_byte = 1)
+      parameter (nf_int1 = nf_byte)
+      parameter (nf_char = 2)
+      parameter (nf_short = 3)
+      parameter (nf_int2 = nf_short)
+      parameter (nf_int = 4)
+      parameter (nf_float = 5)
+      parameter (nf_real = nf_float)
+      parameter (nf_double = 6)
+
+!
+! default fill values:
+!
+      integer           nf_fill_byte
+      integer           nf_fill_int1
+      integer           nf_fill_char
+      integer           nf_fill_short
+      integer           nf_fill_int2
+      integer           nf_fill_int
+      real              nf_fill_float
+      real              nf_fill_real
+      doubleprecision   nf_fill_double
+
+      parameter (nf_fill_byte = -127)
+      parameter (nf_fill_int1 = nf_fill_byte)
+      parameter (nf_fill_char = 0)
+      parameter (nf_fill_short = -32767)
+      parameter (nf_fill_int2 = nf_fill_short)
+      parameter (nf_fill_int = -2147483647)
+      parameter (nf_fill_float = 9.9692099683868690e+36)
+      parameter (nf_fill_real = nf_fill_float)
+      parameter (nf_fill_double = 9.9692099683868690d+36)
+
+!
+! mode flags for opening and creating a netcdf dataset:
+!
+      integer nf_nowrite
+      integer nf_write
+      integer nf_clobber
+      integer nf_noclobber
+      integer nf_fill
+      integer nf_nofill
+      integer nf_lock
+      integer nf_share
+      integer nf_64bit_offset
+      integer nf_sizehint_default
+      integer nf_align_chunk
+      integer nf_format_classic
+      integer nf_format_64bit
+
+      parameter (nf_nowrite = 0)
+      parameter (nf_write = 1)
+      parameter (nf_clobber = 0)
+      parameter (nf_noclobber = 4)
+      parameter (nf_fill = 0)
+      parameter (nf_nofill = 256)
+      parameter (nf_lock = 1024)
+      parameter (nf_share = 2048)
+      parameter (nf_64bit_offset = 512)
+      parameter (nf_sizehint_default = 0)
+      parameter (nf_align_chunk = -1)
+      parameter (nf_format_classic = 1)
+      parameter (nf_format_64bit = 2)
+
+!
+! size argument for defining an unlimited dimension:
+!
+      integer nf_unlimited
+      parameter (nf_unlimited = 0)
+
+!
+! global attribute id:
+!
+      integer nf_global
+      parameter (nf_global = 0)
+
+!
+! implementation limits:
+!
+      integer nf_max_dims
+      integer nf_max_attrs
+      integer nf_max_vars
+      integer nf_max_name
+      integer nf_max_var_dims
+
+      parameter (nf_max_dims = 1024)
+      parameter (nf_max_attrs = 8192)
+      parameter (nf_max_vars = 8192)
+      parameter (nf_max_name = 256)
+      parameter (nf_max_var_dims = nf_max_dims)
+
+!
+! error codes:
+!
+      integer nf_noerr
+      integer nf_ebadid
+      integer nf_eexist
+      integer nf_einval
+      integer nf_eperm
+      integer nf_enotindefine
+      integer nf_eindefine
+      integer nf_einvalcoords
+      integer nf_emaxdims
+      integer nf_enameinuse
+      integer nf_enotatt
+      integer nf_emaxatts
+      integer nf_ebadtype
+      integer nf_ebaddim
+      integer nf_eunlimpos
+      integer nf_emaxvars
+      integer nf_enotvar
+      integer nf_eglobal
+      integer nf_enotnc
+      integer nf_ests
+      integer nf_emaxname
+      integer nf_eunlimit
+      integer nf_enorecvars
+      integer nf_echar
+      integer nf_eedge
+      integer nf_estride
+      integer nf_ebadname
+      integer nf_erange
+      integer nf_enomem
+      integer nf_evarsize
+      integer nf_edimsize
+      integer nf_etrunc
+
+      parameter (nf_noerr = 0)
+      parameter (nf_ebadid = -33)
+      parameter (nf_eexist = -35)
+      parameter (nf_einval = -36)
+      parameter (nf_eperm = -37)
+      parameter (nf_enotindefine = -38)
+      parameter (nf_eindefine = -39)
+      parameter (nf_einvalcoords = -40)
+      parameter (nf_emaxdims = -41)
+      parameter (nf_enameinuse = -42)
+      parameter (nf_enotatt = -43)
+      parameter (nf_emaxatts = -44)
+      parameter (nf_ebadtype = -45)
+      parameter (nf_ebaddim = -46)
+      parameter (nf_eunlimpos = -47)
+      parameter (nf_emaxvars = -48)
+      parameter (nf_enotvar = -49)
+      parameter (nf_eglobal = -50)
+      parameter (nf_enotnc = -51)
+      parameter (nf_ests = -52)
+      parameter (nf_emaxname = -53)
+      parameter (nf_eunlimit = -54)
+      parameter (nf_enorecvars = -55)
+      parameter (nf_echar = -56)
+      parameter (nf_eedge = -57)
+      parameter (nf_estride = -58)
+      parameter (nf_ebadname = -59)
+      parameter (nf_erange = -60)
+      parameter (nf_enomem = -61)
+      parameter (nf_evarsize = -62)
+      parameter (nf_edimsize = -63)
+      parameter (nf_etrunc = -64)
+!
+! error handling modes:
+!
+      integer  nf_fatal
+      integer nf_verbose
+
+      parameter (nf_fatal = 1)
+      parameter (nf_verbose = 2)
+
+!
+! miscellaneous routines:
+!
+      character*80   nf_inq_libvers
+      external       nf_inq_libvers
+
+      character*80   nf_strerror
+!                         (integer             ncerr)
+      external       nf_strerror
+
+      logical        nf_issyserr
+!                         (integer             ncerr)
+      external       nf_issyserr
+
+!
+! control routines:
+!
+      integer         nf_inq_base_pe
+!                         (integer             ncid,
+!                          integer             pe)
+      external        nf_inq_base_pe
+
+      integer         nf_set_base_pe
+!                         (integer             ncid,
+!                          integer             pe)
+      external        nf_set_base_pe
+
+      integer         nf_create
+!                         (character*(*)       path,
+!                          integer             cmode,
+!                          integer             ncid)
+      external        nf_create
+
+      integer         nf__create
+!                         (character*(*)       path,
+!                          integer             cmode,
+!                          integer             initialsz,
+!                          integer             chunksizehint,
+!                          integer             ncid)
+      external        nf__create
+
+      integer         nf__create_mp
+!                         (character*(*)       path,
+!                          integer             cmode,
+!                          integer             initialsz,
+!                          integer             basepe,
+!                          integer             chunksizehint,
+!                          integer             ncid)
+      external        nf__create_mp
+
+      integer         nf_open
+!                         (character*(*)       path,
+!                          integer             mode,
+!                          integer             ncid)
+      external        nf_open
+
+      integer         nf__open
+!                         (character*(*)       path,
+!                          integer             mode,
+!                          integer             chunksizehint,
+!                          integer             ncid)
+      external        nf__open
+
+      integer         nf__open_mp
+!                         (character*(*)       path,
+!                          integer             mode,
+!                          integer             basepe,
+!                          integer             chunksizehint,
+!                          integer             ncid)
+      external        nf__open_mp
+
+      integer         nf_set_fill
+!                         (integer             ncid,
+!                          integer             fillmode,
+!                          integer             old_mode)
+      external        nf_set_fill
+
+      integer         nf_set_default_format
+!                          (integer             format,
+!                          integer             old_format)
+      external        nf_set_default_format
+
+      integer         nf_redef
+!                         (integer             ncid)
+      external        nf_redef
+
+      integer         nf_enddef
+!                         (integer             ncid)
+      external        nf_enddef
+
+      integer         nf__enddef
+!                         (integer             ncid,
+!                          integer             h_minfree,
+!                          integer             v_align,
+!                          integer             v_minfree,
+!                          integer             r_align)
+      external        nf__enddef
+
+      integer         nf_sync
+!                         (integer             ncid)
+      external        nf_sync
+
+      integer         nf_abort
+!                         (integer             ncid)
+      external        nf_abort
+
+      integer         nf_close
+!                         (integer             ncid)
+      external        nf_close
+
+      integer         nf_delete
+!                         (character*(*)       ncid)
+      external        nf_delete
+
+!
+! general inquiry routines:
+!
+
+      integer         nf_inq
+!                         (integer             ncid,
+!                          integer             ndims,
+!                          integer             nvars,
+!                          integer             ngatts,
+!                          integer             unlimdimid)
+      external        nf_inq
+
+      integer         nf_inq_ndims
+!                         (integer             ncid,
+!                          integer             ndims)
+      external        nf_inq_ndims
+
+      integer         nf_inq_nvars
+!                         (integer             ncid,
+!                          integer             nvars)
+      external        nf_inq_nvars
+
+      integer         nf_inq_natts
+!                         (integer             ncid,
+!                          integer             ngatts)
+      external        nf_inq_natts
+
+      integer         nf_inq_unlimdim
+!                         (integer             ncid,
+!                          integer             unlimdimid)
+      external        nf_inq_unlimdim
+
+      integer         nf_inq_format
+!                         (integer             ncid,
+!                          integer             format)
+      external        nf_inq_format
+
+!
+! dimension routines:
+!
+
+      integer         nf_def_dim
+!                         (integer             ncid,
+!                          character(*)        name,
+!                          integer             len,
+!                          integer             dimid)
+      external        nf_def_dim
+
+      integer         nf_inq_dimid
+!                         (integer             ncid,
+!                          character(*)        name,
+!                          integer             dimid)
+      external        nf_inq_dimid
+
+      integer         nf_inq_dim
+!                         (integer             ncid,
+!                          integer             dimid,
+!                          character(*)        name,
+!                          integer             len)
+      external        nf_inq_dim
+
+      integer         nf_inq_dimname
+!                         (integer             ncid,
+!                          integer             dimid,
+!                          character(*)        name)
+      external        nf_inq_dimname
+
+      integer         nf_inq_dimlen
+!                         (integer             ncid,
+!                          integer             dimid,
+!                          integer             len)
+      external        nf_inq_dimlen
+
+      integer         nf_rename_dim
+!                         (integer             ncid,
+!                          integer             dimid,
+!                          character(*)        name)
+      external        nf_rename_dim
+
+!
+! general attribute routines:
+!
+
+      integer         nf_inq_att
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype,
+!                          integer             len)
+      external        nf_inq_att
+
+      integer         nf_inq_attid
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             attnum)
+      external        nf_inq_attid
+
+      integer         nf_inq_atttype
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype)
+      external        nf_inq_atttype
+
+      integer         nf_inq_attlen
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             len)
+      external        nf_inq_attlen
+
+      integer         nf_inq_attname
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             attnum,
+!                          character(*)        name)
+      external        nf_inq_attname
+
+      integer         nf_copy_att
+!                         (integer             ncid_in,
+!                          integer             varid_in,
+!                          character(*)        name,
+!                          integer             ncid_out,
+!                          integer             varid_out)
+      external        nf_copy_att
+
+      integer         nf_rename_att
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        curname,
+!                          character(*)        newname)
+      external        nf_rename_att
+
+      integer         nf_del_att
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name)
+      external        nf_del_att
+
+!
+! attribute put/get routines:
+!
+
+      integer         nf_put_att_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             len,
+!                          character(*)        text)
+      external        nf_put_att_text
+
+      integer         nf_get_att_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          character(*)        text)
+      external        nf_get_att_text
+
+      integer         nf_put_att_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype,
+!                          integer             len,
+!                          nf_int1_t           i1vals(1))
+      external        nf_put_att_int1
+
+      integer         nf_get_att_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          nf_int1_t           i1vals(1))
+      external        nf_get_att_int1
+
+      integer         nf_put_att_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype,
+!                          integer             len,
+!                          nf_int2_t           i2vals(1))
+      external        nf_put_att_int2
+
+      integer         nf_get_att_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          nf_int2_t           i2vals(1))
+      external        nf_get_att_int2
+
+      integer         nf_put_att_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype,
+!                          integer             len,
+!                          integer             ivals(1))
+      external        nf_put_att_int
+
+      integer         nf_get_att_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             ivals(1))
+      external        nf_get_att_int
+
+      integer         nf_put_att_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype,
+!                          integer             len,
+!                          real                rvals(1))
+      external        nf_put_att_real
+
+      integer         nf_get_att_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          real                rvals(1))
+      external        nf_get_att_real
+
+      integer         nf_put_att_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             xtype,
+!                          integer             len,
+!                          double              dvals(1))
+      external        nf_put_att_double
+
+      integer         nf_get_att_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          double              dvals(1))
+      external        nf_get_att_double
+
+!
+! general variable routines:
+!
+
+      integer         nf_def_var
+!                         (integer             ncid,
+!                          character(*)        name,
+!                          integer             datatype,
+!                          integer             ndims,
+!                          integer             dimids(1),
+!                          integer             varid)
+      external        nf_def_var
+
+      integer         nf_inq_var
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name,
+!                          integer             datatype,
+!                          integer             ndims,
+!                          integer             dimids(1),
+!                          integer             natts)
+      external        nf_inq_var
+
+      integer         nf_inq_varid
+!                         (integer             ncid,
+!                          character(*)        name,
+!                          integer             varid)
+      external        nf_inq_varid
+
+      integer         nf_inq_varname
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name)
+      external        nf_inq_varname
+
+      integer         nf_inq_vartype
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             xtype)
+      external        nf_inq_vartype
+
+      integer         nf_inq_varndims
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             ndims)
+      external        nf_inq_varndims
+
+      integer         nf_inq_vardimid
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             dimids(1))
+      external        nf_inq_vardimid
+
+      integer         nf_inq_varnatts
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             natts)
+      external        nf_inq_varnatts
+
+      integer         nf_rename_var
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        name)
+      external        nf_rename_var
+
+      integer         nf_copy_var
+!                         (integer             ncid_in,
+!                          integer             varid,
+!                          integer             ncid_out)
+      external        nf_copy_var
+
+!
+! entire variable put/get routines:
+!
+
+      integer         nf_put_var_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        text)
+      external        nf_put_var_text
+
+      integer         nf_get_var_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          character(*)        text)
+      external        nf_get_var_text
+
+      integer         nf_put_var_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          nf_int1_t           i1vals(1))
+      external        nf_put_var_int1
+
+      integer         nf_get_var_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          nf_int1_t           i1vals(1))
+      external        nf_get_var_int1
+
+      integer         nf_put_var_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          nf_int2_t           i2vals(1))
+      external        nf_put_var_int2
+
+      integer         nf_get_var_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          nf_int2_t           i2vals(1))
+      external        nf_get_var_int2
+
+      integer         nf_put_var_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             ivals(1))
+      external        nf_put_var_int
+
+      integer         nf_get_var_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             ivals(1))
+      external        nf_get_var_int
+
+      integer         nf_put_var_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          real                rvals(1))
+      external        nf_put_var_real
+
+      integer         nf_get_var_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          real                rvals(1))
+      external        nf_get_var_real
+
+      integer         nf_put_var_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          doubleprecision     dvals(1))
+      external        nf_put_var_double
+
+      integer         nf_get_var_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          doubleprecision     dvals(1))
+      external        nf_get_var_double
+
+!
+! single variable put/get routines:
+!
+
+      integer         nf_put_var1_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          character*1         text)
+      external        nf_put_var1_text
+
+      integer         nf_get_var1_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          character*1         text)
+      external        nf_get_var1_text
+
+      integer         nf_put_var1_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          nf_int1_t           i1val)
+      external        nf_put_var1_int1
+
+      integer         nf_get_var1_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          nf_int1_t           i1val)
+      external        nf_get_var1_int1
+
+      integer         nf_put_var1_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          nf_int2_t           i2val)
+      external        nf_put_var1_int2
+
+      integer         nf_get_var1_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          nf_int2_t           i2val)
+      external        nf_get_var1_int2
+
+      integer         nf_put_var1_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          integer             ival)
+      external        nf_put_var1_int
+
+      integer         nf_get_var1_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          integer             ival)
+      external        nf_get_var1_int
+
+      integer         nf_put_var1_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          real                rval)
+      external        nf_put_var1_real
+
+      integer         nf_get_var1_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          real                rval)
+      external        nf_get_var1_real
+
+      integer         nf_put_var1_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          doubleprecision     dval)
+      external        nf_put_var1_double
+
+      integer         nf_get_var1_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             index(1),
+!                          doubleprecision     dval)
+      external        nf_get_var1_double
+
+!
+! variable array put/get routines:
+!
+
+      integer         nf_put_vara_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          character(*)        text)
+      external        nf_put_vara_text
+
+      integer         nf_get_vara_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          character(*)        text)
+      external        nf_get_vara_text
+
+      integer         nf_put_vara_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          nf_int1_t           i1vals(1))
+      external        nf_put_vara_int1
+
+      integer         nf_get_vara_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          nf_int1_t           i1vals(1))
+      external        nf_get_vara_int1
+
+      integer         nf_put_vara_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          nf_int2_t           i2vals(1))
+      external        nf_put_vara_int2
+
+      integer         nf_get_vara_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          nf_int2_t           i2vals(1))
+      external        nf_get_vara_int2
+
+      integer         nf_put_vara_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             ivals(1))
+      external        nf_put_vara_int
+
+      integer         nf_get_vara_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             ivals(1))
+      external        nf_get_vara_int
+
+      integer         nf_put_vara_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          real                rvals(1))
+      external        nf_put_vara_real
+
+      integer         nf_get_vara_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          real                rvals(1))
+      external        nf_get_vara_real
+
+      integer         nf_put_vara_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          doubleprecision     dvals(1))
+      external        nf_put_vara_double
+
+      integer         nf_get_vara_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          doubleprecision     dvals(1))
+      external        nf_get_vara_double
+
+!
+! strided variable put/get routines:
+!
+
+      integer         nf_put_vars_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          character(*)        text)
+      external        nf_put_vars_text
+
+      integer         nf_get_vars_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          character(*)        text)
+      external        nf_get_vars_text
+
+      integer         nf_put_vars_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          nf_int1_t           i1vals(1))
+      external        nf_put_vars_int1
+
+      integer         nf_get_vars_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          nf_int1_t           i1vals(1))
+      external        nf_get_vars_int1
+
+      integer         nf_put_vars_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          nf_int2_t           i2vals(1))
+      external        nf_put_vars_int2
+
+      integer         nf_get_vars_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          nf_int2_t           i2vals(1))
+      external        nf_get_vars_int2
+
+      integer         nf_put_vars_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             ivals(1))
+      external        nf_put_vars_int
+
+      integer         nf_get_vars_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             ivals(1))
+      external        nf_get_vars_int
+
+      integer         nf_put_vars_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          real                rvals(1))
+      external        nf_put_vars_real
+
+      integer         nf_get_vars_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          real                rvals(1))
+      external        nf_get_vars_real
+
+      integer         nf_put_vars_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          doubleprecision     dvals(1))
+      external        nf_put_vars_double
+
+      integer         nf_get_vars_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          doubleprecision     dvals(1))
+      external        nf_get_vars_double
+
+!
+! mapped variable put/get routines:
+!
+
+      integer         nf_put_varm_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          character(*)        text)
+      external        nf_put_varm_text
+
+      integer         nf_get_varm_text
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          character(*)        text)
+      external        nf_get_varm_text
+
+      integer         nf_put_varm_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          nf_int1_t           i1vals(1))
+      external        nf_put_varm_int1
+
+      integer         nf_get_varm_int1
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          nf_int1_t           i1vals(1))
+      external        nf_get_varm_int1
+
+      integer         nf_put_varm_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          nf_int2_t           i2vals(1))
+      external        nf_put_varm_int2
+
+      integer         nf_get_varm_int2
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          nf_int2_t           i2vals(1))
+      external        nf_get_varm_int2
+
+      integer         nf_put_varm_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          integer             ivals(1))
+      external        nf_put_varm_int
+
+      integer         nf_get_varm_int
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          integer             ivals(1))
+      external        nf_get_varm_int
+
+      integer         nf_put_varm_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          real                rvals(1))
+      external        nf_put_varm_real
+
+      integer         nf_get_varm_real
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          real                rvals(1))
+      external        nf_get_varm_real
+
+      integer         nf_put_varm_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          doubleprecision     dvals(1))
+      external        nf_put_varm_double
+
+      integer         nf_get_varm_double
+!                         (integer             ncid,
+!                          integer             varid,
+!                          integer             start(1),
+!                          integer             count(1),
+!                          integer             stride(1),
+!                          integer             imap(1),
+!                          doubleprecision     dvals(1))
+      external        nf_get_varm_double
+
+
+!     NetCDF-2.
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+! begin netcdf 2.4 backward compatibility:
+!
+
+!      
+! functions in the fortran interface
+!
+      integer nccre
+      integer ncopn
+      integer ncddef
+      integer ncdid
+      integer ncvdef
+      integer ncvid
+      integer nctlen
+      integer ncsfil
+
+      external nccre
+      external ncopn
+      external ncddef
+      external ncdid
+      external ncvdef
+      external ncvid
+      external nctlen
+      external ncsfil
+
+
+      integer ncrdwr
+      integer nccreat
+      integer ncexcl
+      integer ncindef
+      integer ncnsync
+      integer nchsync
+      integer ncndirty
+      integer nchdirty
+      integer nclink
+      integer ncnowrit
+      integer ncwrite
+      integer ncclob
+      integer ncnoclob
+      integer ncglobal
+      integer ncfill
+      integer ncnofill
+      integer maxncop
+      integer maxncdim
+      integer maxncatt
+      integer maxncvar
+      integer maxncnam
+      integer maxvdims
+      integer ncnoerr
+      integer ncebadid
+      integer ncenfile
+      integer nceexist
+      integer nceinval
+      integer nceperm
+      integer ncenotin
+      integer nceindef
+      integer ncecoord
+      integer ncemaxds
+      integer ncename
+      integer ncenoatt
+      integer ncemaxat
+      integer ncebadty
+      integer ncebadd
+      integer ncests
+      integer nceunlim
+      integer ncemaxvs
+      integer ncenotvr
+      integer nceglob
+      integer ncenotnc
+      integer ncfoobar
+      integer ncsyserr
+      integer ncfatal
+      integer ncverbos
+      integer ncentool
+
+
+!
+! netcdf data types:
+!
+      integer ncbyte
+      integer ncchar
+      integer ncshort
+      integer nclong
+      integer ncfloat
+      integer ncdouble
+
+      parameter(ncbyte = 1)
+      parameter(ncchar = 2)
+      parameter(ncshort = 3)
+      parameter(nclong = 4)
+      parameter(ncfloat = 5)
+      parameter(ncdouble = 6)
+
+!     
+!     masks for the struct nc flag field; passed in as 'mode' arg to
+!     nccreate and ncopen.
+!     
+
+!     read/write, 0 => readonly 
+      parameter(ncrdwr = 1)
+!     in create phase, cleared by ncendef 
+      parameter(nccreat = 2)
+!     on create destroy existing file 
+      parameter(ncexcl = 4)
+!     in define mode, cleared by ncendef 
+      parameter(ncindef = 8)
+!     synchronise numrecs on change (x'10')
+      parameter(ncnsync = 16)
+!     synchronise whole header on change (x'20')
+      parameter(nchsync = 32)
+!     numrecs has changed (x'40')
+      parameter(ncndirty = 64)  
+!     header info has changed (x'80')
+      parameter(nchdirty = 128)
+!     prefill vars on endef and increase of record, the default behavior
+      parameter(ncfill = 0)
+!     do not fill vars on endef and increase of record (x'100')
+      parameter(ncnofill = 256)
+!     isa link (x'8000')
+      parameter(nclink = 32768)
+
+!     
+!     'mode' arguments for nccreate and ncopen
+!     
+      parameter(ncnowrit = 0)
+      parameter(ncwrite = ncrdwr)
+      parameter(ncclob = nf_clobber)
+      parameter(ncnoclob = nf_noclobber)
+
+!     
+!     'size' argument to ncdimdef for an unlimited dimension
+!     
+      integer ncunlim
+      parameter(ncunlim = 0)
+
+!     
+!     attribute id to put/get a global attribute
+!     
+      parameter(ncglobal  = 0)
+
+!     
+!     advisory maximums:
+!     
+      parameter(maxncop = 64)
+      parameter(maxncdim = 1024)
+      parameter(maxncatt = 8192)
+      parameter(maxncvar = 8192)
+!     not enforced 
+      parameter(maxncnam = 256)
+      parameter(maxvdims = maxncdim)
+
+!     
+!     global netcdf error status variable
+!     initialized in error.c
+!     
+
+!     no error 
+      parameter(ncnoerr = nf_noerr)
+!     not a netcdf id 
+      parameter(ncebadid = nf_ebadid)
+!     too many netcdfs open 
+      parameter(ncenfile = -31)   ! nc_syserr
+!     netcdf file exists && ncnoclob
+      parameter(nceexist = nf_eexist)
+!     invalid argument 
+      parameter(nceinval = nf_einval)
+!     write to read only 
+      parameter(nceperm = nf_eperm)
+!     operation not allowed in data mode 
+      parameter(ncenotin = nf_enotindefine )   
+!     operation not allowed in define mode 
+      parameter(nceindef = nf_eindefine)   
+!     coordinates out of domain 
+      parameter(ncecoord = nf_einvalcoords)
+!     maxncdims exceeded 
+      parameter(ncemaxds = nf_emaxdims)
+!     string match to name in use 
+      parameter(ncename = nf_enameinuse)   
+!     attribute not found 
+      parameter(ncenoatt = nf_enotatt)
+!     maxncattrs exceeded 
+      parameter(ncemaxat = nf_emaxatts)
+!     not a netcdf data type 
+      parameter(ncebadty = nf_ebadtype)
+!     invalid dimension id 
+      parameter(ncebadd = nf_ebaddim)
+!     ncunlimited in the wrong index 
+      parameter(nceunlim = nf_eunlimpos)
+!     maxncvars exceeded 
+      parameter(ncemaxvs = nf_emaxvars)
+!     variable not found 
+      parameter(ncenotvr = nf_enotvar)
+!     action prohibited on ncglobal varid 
+      parameter(nceglob = nf_eglobal)
+!     not a netcdf file 
+      parameter(ncenotnc = nf_enotnc)
+      parameter(ncests = nf_ests)
+      parameter (ncentool = nf_emaxname) 
+      parameter(ncfoobar = 32)
+      parameter(ncsyserr = -31)
+
+!     
+!     global options variable. used to determine behavior of error handler.
+!     initialized in lerror.c
+!     
+      parameter(ncfatal = 1)
+      parameter(ncverbos = 2)
+
+!
+!     default fill values.  these must be the same as in the c interface.
+!
+      integer filbyte
+      integer filchar
+      integer filshort
+      integer fillong
+      real filfloat
+      doubleprecision fildoub
+
+      parameter (filbyte = -127)
+      parameter (filchar = 0)
+      parameter (filshort = -32767)
+      parameter (fillong = -2147483647)
+      parameter (filfloat = 9.9692099683868690e+36)
+      parameter (fildoub = 9.9692099683868690d+36)
+
+!     NetCDF-4.
+!     This is part of netCDF-4. Copyright 2006, UCAR, See COPYRIGHT
+!     file for distribution information.
+
+!     Netcdf version 4 fortran interface.
+
+!     $Id: netcdf4.inc,v 1.28 2010/05/25 13:53:02 ed Exp $
+
+!     New netCDF-4 types.
+      integer nf_ubyte
+      integer nf_ushort
+      integer nf_uint
+      integer nf_int64
+      integer nf_uint64
+      integer nf_string
+      integer nf_vlen
+      integer nf_opaque
+      integer nf_enum
+      integer nf_compound
+
+      parameter (nf_ubyte = 7)
+      parameter (nf_ushort = 8)
+      parameter (nf_uint = 9)
+      parameter (nf_int64 = 10)
+      parameter (nf_uint64 = 11)
+      parameter (nf_string = 12)
+      parameter (nf_vlen = 13)
+      parameter (nf_opaque = 14)
+      parameter (nf_enum = 15)
+      parameter (nf_compound = 16)
+
+!     New netCDF-4 fill values.
+      integer           nf_fill_ubyte
+      integer           nf_fill_ushort
+!      real              nf_fill_uint
+!      real              nf_fill_int64
+!      real              nf_fill_uint64
+      parameter (nf_fill_ubyte = 255)
+      parameter (nf_fill_ushort = 65535)
+
+!     New constants.
+      integer nf_format_netcdf4
+      parameter (nf_format_netcdf4 = 3)
+
+      integer nf_format_netcdf4_classic
+      parameter (nf_format_netcdf4_classic = 4)
+
+      integer nf_netcdf4
+      parameter (nf_netcdf4 = 4096)
+
+      integer nf_classic_model
+      parameter (nf_classic_model = 256)
+
+      integer nf_chunk_seq
+      parameter (nf_chunk_seq = 0)
+      integer nf_chunk_sub
+      parameter (nf_chunk_sub = 1)
+      integer nf_chunk_sizes
+      parameter (nf_chunk_sizes = 2)
+
+      integer nf_endian_native
+      parameter (nf_endian_native = 0)
+      integer nf_endian_little
+      parameter (nf_endian_little = 1)
+      integer nf_endian_big
+      parameter (nf_endian_big = 2)
+
+!     For NF_DEF_VAR_CHUNKING
+      integer nf_chunked
+      parameter (nf_chunked = 0)
+      integer nf_contiguous
+      parameter (nf_contiguous = 1)
+
+!     For NF_DEF_VAR_FLETCHER32
+      integer nf_nochecksum
+      parameter (nf_nochecksum = 0)
+      integer nf_fletcher32
+      parameter (nf_fletcher32 = 1)
+
+!     For NF_DEF_VAR_DEFLATE
+      integer nf_noshuffle
+      parameter (nf_noshuffle = 0)
+      integer nf_shuffle
+      parameter (nf_shuffle = 1)
+
+!     For NF_DEF_VAR_SZIP
+      integer nf_szip_ec_option_mask
+      parameter (nf_szip_ec_option_mask = 4)
+      integer nf_szip_nn_option_mask
+      parameter (nf_szip_nn_option_mask = 32)
+
+!     For parallel I/O.
+      integer nf_mpiio      
+      parameter (nf_mpiio = 8192)
+      integer nf_mpiposix
+      parameter (nf_mpiposix = 16384)
+      integer nf_pnetcdf
+      parameter (nf_pnetcdf = 32768)
+
+!     For NF_VAR_PAR_ACCESS.
+      integer nf_independent
+      parameter (nf_independent = 0)
+      integer nf_collective
+      parameter (nf_collective = 1)
+
+!     New error codes.
+      integer nf_ehdferr        ! Error at HDF5 layer. 
+      parameter (nf_ehdferr = -101)
+      integer nf_ecantread      ! Can't read. 
+      parameter (nf_ecantread = -102)
+      integer nf_ecantwrite     ! Can't write. 
+      parameter (nf_ecantwrite = -103)
+      integer nf_ecantcreate    ! Can't create. 
+      parameter (nf_ecantcreate = -104)
+      integer nf_efilemeta      ! Problem with file metadata. 
+      parameter (nf_efilemeta = -105)
+      integer nf_edimmeta       ! Problem with dimension metadata. 
+      parameter (nf_edimmeta = -106)
+      integer nf_eattmeta       ! Problem with attribute metadata. 
+      parameter (nf_eattmeta = -107)
+      integer nf_evarmeta       ! Problem with variable metadata. 
+      parameter (nf_evarmeta = -108)
+      integer nf_enocompound    ! Not a compound type. 
+      parameter (nf_enocompound = -109)
+      integer nf_eattexists     ! Attribute already exists. 
+      parameter (nf_eattexists = -110)
+      integer nf_enotnc4        ! Attempting netcdf-4 operation on netcdf-3 file.   
+      parameter (nf_enotnc4 = -111)
+      integer nf_estrictnc3     ! Attempting netcdf-4 operation on strict nc3 netcdf-4 file.   
+      parameter (nf_estrictnc3 = -112)
+      integer nf_enotnc3        ! Attempting netcdf-3 operation on netcdf-4 file.   
+      parameter (nf_enotnc3 = -113)
+      integer nf_enopar         ! Parallel operation on file opened for non-parallel access.   
+      parameter (nf_enopar = -114)
+      integer nf_eparinit       ! Error initializing for parallel access.   
+      parameter (nf_eparinit = -115)
+      integer nf_ebadgrpid      ! Bad group ID.   
+      parameter (nf_ebadgrpid = -116)
+      integer nf_ebadtypid      ! Bad type ID.   
+      parameter (nf_ebadtypid = -117)
+      integer nf_etypdefined    ! Type has already been defined and may not be edited. 
+      parameter (nf_etypdefined = -118)
+      integer nf_ebadfield      ! Bad field ID.   
+      parameter (nf_ebadfield = -119)
+      integer nf_ebadclass      ! Bad class.   
+      parameter (nf_ebadclass = -120)
+      integer nf_emaptype       ! Mapped access for atomic types only.   
+      parameter (nf_emaptype = -121)
+      integer nf_elatefill      ! Attempt to define fill value when data already exists. 
+      parameter (nf_elatefill = -122)
+      integer nf_elatedef       ! Attempt to define var properties, like deflate, after enddef. 
+      parameter (nf_elatedef = -123)
+      integer nf_edimscale      ! Probem with HDF5 dimscales. 
+      parameter (nf_edimscale = -124)
+      integer nf_enogrp       ! No group found.
+      parameter (nf_enogrp = -125)
+
+
+!     New functions.
+
+!     Parallel I/O.
+      integer nf_create_par
+      external nf_create_par
+
+      integer nf_open_par
+      external nf_open_par
+
+      integer nf_var_par_access
+      external nf_var_par_access
+
+!     Functions to handle groups.
+      integer nf_inq_ncid
+      external nf_inq_ncid
+
+      integer nf_inq_grps
+      external nf_inq_grps
+
+      integer nf_inq_grpname
+      external nf_inq_grpname
+
+      integer nf_inq_grpname_full
+      external nf_inq_grpname_full
+
+      integer nf_inq_grpname_len
+      external nf_inq_grpname_len
+
+      integer nf_inq_grp_parent
+      external nf_inq_grp_parent
+
+      integer nf_inq_grp_ncid
+      external nf_inq_grp_ncid
+
+      integer nf_inq_grp_full_ncid
+      external nf_inq_grp_full_ncid
+
+      integer nf_inq_varids
+      external nf_inq_varids
+
+      integer nf_inq_dimids
+      external nf_inq_dimids
+
+      integer nf_def_grp
+      external nf_def_grp
+
+!     New options for netCDF variables.
+      integer nf_def_var_deflate
+      external nf_def_var_deflate
+
+      integer nf_inq_var_deflate
+      external nf_inq_var_deflate
+
+      integer nf_def_var_fletcher32
+      external nf_def_var_fletcher32
+
+      integer nf_inq_var_fletcher32
+      external nf_inq_var_fletcher32
+
+      integer nf_def_var_chunking
+      external nf_def_var_chunking
+
+      integer nf_inq_var_chunking
+      external nf_inq_var_chunking
+
+      integer nf_def_var_fill
+      external nf_def_var_fill
+
+      integer nf_inq_var_fill
+      external nf_inq_var_fill
+
+      integer nf_def_var_endian
+      external nf_def_var_endian
+
+      integer nf_inq_var_endian
+      external nf_inq_var_endian
+
+!     User defined types.
+      integer nf_inq_typeids
+      external nf_inq_typeids
+
+      integer nf_inq_typeid
+      external nf_inq_typeid
+
+      integer nf_inq_type
+      external nf_inq_type
+
+      integer nf_inq_user_type
+      external nf_inq_user_type
+
+!     User defined types - compound types.
+      integer nf_def_compound
+      external nf_def_compound
+
+      integer nf_insert_compound
+      external nf_insert_compound
+
+      integer nf_insert_array_compound
+      external nf_insert_array_compound
+
+      integer nf_inq_compound
+      external nf_inq_compound
+
+      integer nf_inq_compound_name
+      external nf_inq_compound_name
+
+      integer nf_inq_compound_size
+      external nf_inq_compound_size
+
+      integer nf_inq_compound_nfields
+      external nf_inq_compound_nfields
+
+      integer nf_inq_compound_field
+      external nf_inq_compound_field
+
+      integer nf_inq_compound_fieldname
+      external nf_inq_compound_fieldname
+
+      integer nf_inq_compound_fieldindex
+      external nf_inq_compound_fieldindex
+
+      integer nf_inq_compound_fieldoffset
+      external nf_inq_compound_fieldoffset
+
+      integer nf_inq_compound_fieldtype
+      external nf_inq_compound_fieldtype
+
+      integer nf_inq_compound_fieldndims
+      external nf_inq_compound_fieldndims
+
+      integer nf_inq_compound_fielddim_sizes
+      external nf_inq_compound_fielddim_sizes
+
+!     User defined types - variable length arrays.
+      integer nf_def_vlen
+      external nf_def_vlen
+
+      integer nf_inq_vlen
+      external nf_inq_vlen
+
+      integer nf_free_vlen
+      external nf_free_vlen
+
+!     User defined types - enums.
+      integer nf_def_enum
+      external nf_def_enum
+
+      integer nf_insert_enum
+      external nf_insert_enum
+
+      integer nf_inq_enum
+      external nf_inq_enum
+
+      integer nf_inq_enum_member
+      external nf_inq_enum_member
+
+      integer nf_inq_enum_ident
+      external nf_inq_enum_ident
+
+!     User defined types - opaque.
+      integer nf_def_opaque
+      external nf_def_opaque
+
+      integer nf_inq_opaque
+      external nf_inq_opaque
+
+!     Write and read attributes of any type, including user defined
+!     types.
+      integer nf_put_att
+      external nf_put_att
+      integer nf_get_att
+      external nf_get_att
+
+!     Write and read variables of any type, including user defined
+!     types.
+      integer nf_put_var
+      external nf_put_var
+      integer nf_put_var1
+      external nf_put_var1
+      integer nf_put_vara
+      external nf_put_vara
+      integer nf_put_vars
+      external nf_put_vars
+      integer nf_get_var
+      external nf_get_var
+      integer nf_get_var1
+      external nf_get_var1
+      integer nf_get_vara
+      external nf_get_vara
+      integer nf_get_vars
+      external nf_get_vars
+
+!     64-bit int functions.
+      integer nf_put_var1_int64
+      external nf_put_var1_int64
+      integer nf_put_vara_int64
+      external nf_put_vara_int64
+      integer nf_put_vars_int64
+      external nf_put_vars_int64
+      integer nf_put_varm_int64
+      external nf_put_varm_int64
+      integer nf_put_var_int64
+      external nf_put_var_int64
+      integer nf_get_var1_int64
+      external nf_get_var1_int64
+      integer nf_get_vara_int64
+      external nf_get_vara_int64
+      integer nf_get_vars_int64
+      external nf_get_vars_int64
+      integer nf_get_varm_int64
+      external nf_get_varm_int64
+      integer nf_get_var_int64
+      external nf_get_var_int64
+
+!     For helping F77 users with VLENs.
+      integer nf_get_vlen_element
+      external nf_get_vlen_element
+      integer nf_put_vlen_element
+      external nf_put_vlen_element
+
+!     For dealing with file level chunk cache.
+      integer nf_set_chunk_cache
+      external nf_set_chunk_cache
+      integer nf_get_chunk_cache
+      external nf_get_chunk_cache
+
+!     For dealing with per variable chunk cache.
+      integer nf_set_var_chunk_cache
+      external nf_set_var_chunk_cache
+      integer nf_get_var_chunk_cache
+      external nf_get_var_chunk_cache
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/netcdf95.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/netcdf95.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/netcdf95.F90	(revision 17)
@@ -0,0 +1,17 @@
+! $Id$
+module netcdf95
+
+  ! Author: Lionel GUEZ
+  ! See:
+  ! http://www.lmd.jussieu.fr/~lglmd/NetCDF95
+
+  use nf95_def_var_m
+  use nf95_put_var_m
+  use nf95_get_var_m
+  use nf95_gw_var_m
+  use nf95_put_att_m
+  use nf95_get_att_m
+  use simple
+  use handle_err_m
+
+end module netcdf95
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/newmicro.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/newmicro.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/newmicro.F	(revision 17)
@@ -0,0 +1,605 @@
+! $Id: newmicro.F 1750 2013-04-25 15:27:27Z fairhead $
+
+
+!     
+      SUBROUTINE newmicro (ok_cdnc, bl95_b0, bl95_b1, 
+     .                  paprs, pplay,
+     .                  t, pqlwp, pclc, pcltau, pclemi,
+     .                  pch, pcl, pcm, pct, pctlwp,
+     .                  xflwp, xfiwp, xflwc, xfiwc,
+     .                  mass_solu_aero, mass_solu_aero_pi, 
+     .                  pcldtaupi, re, fl, reliq, reice)
+c
+      USE dimphy
+      USE phys_local_var_mod, only: scdnc,cldncl,reffclwtop,lcc,
+     .                              reffclws,reffclwc,cldnvi,lcc3d,
+     .                              lcc3dcon,lcc3dstra
+      USE phys_state_var_mod, only: rnebcon,clwcon
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+c            O.   Boucher (LMD/CNRS) mise a jour en 201212
+c Objet: Calculer epaisseur optique et emmissivite des nuages
+c======================================================================
+c Arguments:
+c ok_cdnc-input-L-flag pour calculer les rayons a partir des aerosols
+c
+c t-------input-R-temperature
+c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere dans la partie nuageuse (kg/kg)
+c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+c mass_solu_aero-----input-R-total mass concentration for all soluble aerosols[ug/m^3]
+c mass_solu_aero_pi--input-R-ditto, pre-industrial value
+c
+c bl95_b0-input-R-a PARAMETER, may be varied for tests (s-sea, l-land)
+c bl95_b1-input-R-a PARAMETER, may be varied for tests (    -"-      )
+c      
+c re------output-R-Cloud droplet effective radius multiplied by fl [um]
+c fl------output-R-Denominator to re, introduced to avoid problems in
+c                  the averaging of the output. fl is the fraction of liquid
+c                  water clouds within a grid cell           
+c
+c pcltau--output-R-epaisseur optique des nuages
+c pclemi--output-R-emissivite des nuages (0 a 1)
+c pcldtaupi-output-R-pre-industrial value of cloud optical thickness, 
+c
+c pcl-output-R-2D low-level cloud cover
+c pcm-output-R-2D mid-level cloud cover
+c pch-output-R-2D high-level cloud cover
+c pct-output-R-2D total cloud cover
+c======================================================================
+C
+#include "YOMCST.h"
+#include "nuage.h"
+#include "radepsi.h"
+#include "radopt.h"
+
+c choix de l'hypothese de recouvrememnt nuageuse
+      LOGICAL RANDOM, MAXIMUM_RANDOM, MAXIMUM
+      PARAMETER (RANDOM=.FALSE., MAXIMUM_RANDOM=.TRUE., MAXIMUM=.FALSE.)
+c
+      LOGICAL, SAVE :: FIRST=.TRUE.
+!$OMP THREADPRIVATE(FIRST)
+      INTEGER flag_max
+c
+c threshold PARAMETERs
+      REAL thres_tau,thres_neb
+      PARAMETER (thres_tau=0.3, thres_neb=0.001)
+c
+      REAL phase3d(klon, klev)
+      REAL tcc(klon), ftmp(klon), lcc_integrat(klon), height(klon)
+c
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL t(klon,klev)
+      REAL pclc(klon,klev)
+      REAL pqlwp(klon,klev)
+      REAL pcltau(klon,klev)
+      REAL pclemi(klon,klev)
+      REAL pcldtaupi(klon, klev)
+c
+      REAL pct(klon)
+      REAL pcl(klon)
+      REAL pcm(klon)
+      REAL pch(klon)
+      REAL pctlwp(klon)
+c
+      LOGICAL lo
+c
+!!Abderr modif JL mail du 19.01.2011 18:31
+!      REAL cetahb, cetamb
+!      PARAMETER (cetahb = 0.45, cetamb = 0.80)
+! Remplacer
+! cetahb*paprs(i,1) par  prmhc
+! cetamb*paprs(i,1) par  prlmc 
+      REAL prmhc    ! Pressure between medium and high level cloud in Pa
+      REAL prlmc    ! Pressure between low and medium level cloud in Pa
+      PARAMETER (prmhc = 440.*100., prlmc = 680.*100.)
+C
+      INTEGER i, k
+      REAL xflwp(klon), xfiwp(klon)
+      REAL xflwc(klon,klev), xfiwc(klon,klev)
+c
+      REAL radius
+c
+      REAL coef_froi, coef_chau
+      PARAMETER (coef_chau=0.13, coef_froi=0.09)
+c
+      REAL seuil_neb
+      PARAMETER (seuil_neb=0.001)
+c
+      INTEGER nexpo ! exponentiel pour glace/eau
+      PARAMETER (nexpo=6)
+c      PARAMETER (nexpo=1)
+
+      REAL rel, tc, rei
+      REAL k_ice0, k_ice, DF
+      PARAMETER (k_ice0=0.005) ! units=m2/g
+      PARAMETER (DF=1.66) ! diffusivity factor
+c
+cjq for the aerosol indirect effect
+cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+cjq      
+      REAL mass_solu_aero(klon, klev)    ! total mass concentration for all soluble aerosols [ug m-3]
+      REAL mass_solu_aero_pi(klon, klev) ! - " - (pre-industrial value)
+      REAL cdnc(klon, klev)     ! cloud droplet number concentration [m-3]
+      REAL re(klon, klev)       ! cloud droplet effective radius [um]
+      REAL cdnc_pi(klon, klev)     ! cloud droplet number concentration [m-3] (pi value)
+      REAL re_pi(klon, klev)       ! cloud droplet effective radius [um] (pi value)
+      
+      REAL fl(klon, klev)       ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell)
+      
+      LOGICAL ok_cdnc
+      REAL bl95_b0, bl95_b1     ! Parameter in B&L 95-Formula
+      
+cjq-end    
+cIM cf. CR:parametres supplementaires
+      REAL zclear(klon)
+      REAL zcloud(klon) 
+      REAL zcloudh(klon) 
+      REAL zcloudm(klon) 
+      REAL zcloudl(klon) 
+      REAL rhodz(klon, klev)  !--rho*dz pour la couche
+      REAL zrho(klon, klev)   !--rho pour la couche
+      REAL dh(klon, klev)     !--dz pour la couche
+      REAL zfice(klon, klev)
+      REAL rad_chaud(klon, klev) !--rayon pour les nuages chauds
+      REAL zflwp_var, zfiwp_var
+      REAL d_rei_dt
+
+! Abderrahmane oct 2009
+      Real reliq(klon, klev), reice(klon, klev)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH : 2011/05/24
+!
+! rei = ( rei_max - rei_min ) * T(Â°C) / 81.4 + rei_max
+! to be used for a temperature in celcius T(Â°C) < 0
+! rei=rei_min for T(Â°C) < -81.4
+!
+! Calcul de la pente de la relation entre rayon effective des cristaux
+! et la tempÃ©rature.
+! Pour retrouver les rÃ©sultats numÃ©riques de la version d'origine,
+! on impose 0.71 quand on est proche de 0.71
+c
+      d_rei_dt=(rei_max-rei_min)/81.4
+      if (abs(d_rei_dt-0.71)<1.e-4) d_rei_dt=0.71
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+c
+c Calculer l'epaisseur optique et l'emmissivite des nuages
+c     IM inversion des DO
+c
+      xflwp = 0.d0
+      xfiwp = 0.d0
+      xflwc = 0.d0
+      xfiwc = 0.d0
+c
+      reliq=0.
+      reice=0.
+c
+      DO k = 1, klev
+        DO i = 1, klon
+c-layer calculation
+          rhodz(i,k) = (paprs(i,k)-paprs(i,k+1))/RG  ! kg/m2
+          zrho(i,k)=pplay(i,k)/t(i,k)/RD             ! kg/m3
+          dh(i,k)=rhodz(i,k)/zrho(i,k)               ! m
+c-Fraction of ice in cloud using a linear transition
+          zfice(i,k) = 1.0 - (t(i,k)-t_glace_min) / 
+     &                       (t_glace_max-t_glace_min)
+          zfice(i,k) = MIN(MAX(zfice(i,k),0.0),1.0)
+c-IM Total Liquid/Ice water content                                    
+          xflwc(i,k) = (1.-zfice(i,k))*pqlwp(i,k)
+          xfiwc(i,k) = zfice(i,k)*pqlwp(i,k)
+         ENDDO
+      ENDDO
+
+      IF (ok_cdnc) THEN
+c
+c--we compute cloud properties as a function of the aerosol load
+c
+        DO k = 1, klev
+            DO i = 1, klon
+c
+c Formula "D" of Boucher and Lohmann, Tellus, 1995
+c Cloud droplet number concentration (CDNC) is restricted
+c to be within [20, 1000 cm^3]
+c
+c--present-day case
+                cdnc(i,k) = 10.**(bl95_b0+bl95_b1*
+     &               log(MAX(mass_solu_aero(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+                cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k)))
+c
+c--pre-industrial case
+                cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1*
+     &               log(MAX(mass_solu_aero_pi(i,k),1.e-4))/log(10.))
+     &               *1.e6 !-m-3
+                cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k)))
+c
+c--present-day case
+                rad_chaud(i,k) = 
+     &               1.1*((pqlwp(i,k)*pplay(i,k)/(RD * T(i,k)))  
+     &               /(4./3*RPI*1000.*cdnc(i,k)) )**(1./3.)
+                rad_chaud(i,k) = MAX(rad_chaud(i,k) * 1.e6, 5.) 
+c
+c--pre-industrial case
+                radius = 
+     &               1.1*((pqlwp(i,k)*pplay(i,k)/(RD * T(i,k)))  
+     &               /(4./3.*RPI*1000.*cdnc_pi(i,k)))**(1./3.)
+                radius = MAX(radius*1.e6, 5.) 
+c 
+c--pre-industrial case
+c--liquid/ice cloud water paths:
+                IF (pclc(i,k) .LE. seuil_neb) THEN
+c
+                pcldtaupi(i,k) = 0.0                  
+c
+                ELSE
+c                  
+                zflwp_var= 1000.*(1.-zfice(i,k))*pqlwp(i,k)/pclc(i,k)
+     &               *rhodz(i,k)
+                zfiwp_var= 1000.*zfice(i,k)*pqlwp(i,k)/pclc(i,k)
+     &               *rhodz(i,k)
+                tc = t(i,k)-273.15
+                rei = d_rei_dt*tc + rei_max
+                if (tc.le.-81.4) rei = rei_min
+c
+c-- cloud optical thickness :
+c [for liquid clouds, traditional formula, 
+c for ice clouds, Ebert & Curry (1992)] 
+c                  
+                if (zflwp_var.eq.0.) radius = 1. 
+                if (zfiwp_var.eq.0. .or. rei.le.0.) rei = 1. 
+                pcldtaupi(i,k) = 3.0/2.0 * zflwp_var / radius
+     &                 + zfiwp_var * (3.448e-03  + 2.431/rei)
+c
+                ENDIF
+c
+          ENDDO            
+        ENDDO
+c
+      ELSE !--not ok_cdnc
+c
+c-prescribed cloud droplet radius
+c
+         DO k = 1, MIN(3,klev)
+           DO i = 1, klon
+               rad_chaud(i,k) = rad_chau2
+           ENDDO            
+         ENDDO
+         DO k = MIN(3,klev)+1, klev
+           DO i = 1, klon
+               rad_chaud(i,k) = rad_chau1
+           ENDDO            
+         ENDDO
+
+      ENDIF !--ok_cdnc
+c
+c--computation of cloud optical depth and emissivity  
+c--in the general case
+c
+       DO k = 1, klev
+          DO i = 1, klon
+c
+             IF (pclc(i,k) .LE. seuil_neb) THEN
+c               
+c effective cloud droplet radius (microns) for liquid water clouds: 
+c For output diagnostics cloud droplet effective radius [um]
+c we multiply here with f * xl (fraction of liquid water
+c clouds in the grid cell) to avoid problems in the averaging of the output.
+c In the output of IOIPSL, derive the REAL cloud droplet 
+c effective radius as re/fl
+c
+                fl(i,k) = seuil_neb*(1.-zfice(i,k))            
+                re(i,k) = rad_chaud(i,k)*fl(i,k)
+                rel = 0.
+                rei = 0.
+                pclc(i,k)   = 0.0
+                pcltau(i,k) = 0.0
+                pclemi(i,k) = 0.0
+c
+             ELSE
+c
+c     -- liquid/ice cloud water paths:
+                  
+                zflwp_var= 1000.*(1.-zfice(i,k))*pqlwp(i,k)/pclc(i,k)
+     &               *rhodz(i,k)
+                zfiwp_var= 1000.*zfice(i,k)*pqlwp(i,k)/pclc(i,k)
+     &               *rhodz(i,k)
+c               
+c effective cloud droplet radius (microns) for liquid water clouds: 
+c For output diagnostics cloud droplet effective radius [um]
+c we multiply here with f * xl (fraction of liquid water
+c clouds in the grid cell) to avoid problems in the averaging of the output.
+c In the output of IOIPSL, derive the REAL cloud droplet 
+c effective radius as re/fl
+c 
+                fl(i,k) = pclc(i,k)*(1.-zfice(i,k))            
+                re(i,k) = rad_chaud(i,k)*fl(i,k)
+c 
+                rel = rad_chaud(i,k)
+c
+c for ice clouds: as a function of the ambiant temperature
+c [formula used by Iacobellis and Somerville (2000), with an 
+c asymptotical value of 3.5 microns at T<-81.4 C added to be 
+c consistent with observations of Heymsfield et al. 1986]:
+c 2011/05/24 : rei_min = 3.5 becomes a free PARAMETER as well as rei_max=61.29
+c
+                tc = t(i,k)-273.15
+                rei = d_rei_dt*tc + rei_max
+                if (tc.le.-81.4) rei = rei_min
+c
+c-- cloud optical thickness :
+c [for liquid clouds, traditional formula, 
+c for ice clouds, Ebert & Curry (1992)] 
+c                  
+                 if (zflwp_var.eq.0.) rel = 1. 
+                 if (zfiwp_var.eq.0. .or. rei.le.0.) rei = 1. 
+                 pcltau(i,k) = 3.0/2.0 * ( zflwp_var/rel )
+     &                 + zfiwp_var * (3.448e-03  + 2.431/rei)
+c
+c     -- cloud infrared emissivity:
+c     [the broadband infrared absorption coefficient is PARAMETERized
+c     as a function of the effective cld droplet radius]
+c     Ebert and Curry (1992) formula as used by Kiehl & Zender (1995):
+c
+                  k_ice = k_ice0 + 1.0/rei
+c                 
+                  pclemi(i,k) = 1.0
+     &                 - EXP( -coef_chau*zflwp_var - DF*k_ice*zfiwp_var)
+c
+             ENDIF
+c
+             reliq(i,k)=rel
+             reice(i,k)=rei 
+c
+             xflwp(i) = xflwp(i)+ xflwc(i,k) * rhodz(i,k)
+             xfiwp(i) = xfiwp(i)+ xfiwc(i,k) * rhodz(i,k)
+c
+          ENDDO
+       ENDDO
+c
+c--if cloud droplet radius is fixed, then pcldtaupi=pcltau
+c
+      IF (.NOT.ok_cdnc) THEN
+         DO k = 1, klev
+            DO i = 1, klon
+               pcldtaupi(i,k)=pcltau(i,k)
+            ENDDO
+         ENDDO               
+      ENDIF
+C     
+C     COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+c     IM cf. CR:test: calcul prenant ou non en compte le recouvrement
+c     initialisations
+c
+      DO i=1,klon
+         zclear(i)=1.
+         zcloud(i)=0.
+         zcloudh(i)=0.
+         zcloudm(i)=0.
+         zcloudl(i)=0.
+         pch(i)=1.0
+         pcm(i) = 1.0
+         pcl(i) = 1.0
+         pctlwp(i) = 0.0
+      ENDDO
+C
+c--calculation of liquid water path
+c
+      DO k = klev, 1, -1
+         DO i = 1, klon
+            pctlwp(i) = pctlwp(i)+ pqlwp(i,k)*rhodz(i,k)
+         ENDDO
+      ENDDO
+c     
+c--calculation of cloud properties with cloud overlap
+c
+      IF (NOVLP.EQ.1) THEN
+         DO k = klev, 1, -1
+            DO i = 1, klon
+               zclear(i)=zclear(i)*(1.-MAX(pclc(i,k),zcloud(i)))
+     &              /(1.-MIN(REAL(zcloud(i), kind=8),1.-ZEPSEC))
+               pct(i)=1.-zclear(i) 
+               IF (paprs(i,k).LT.prmhc) THEN
+                  pch(i) = pch(i)*(1.-MAX(pclc(i,k),zcloudh(i)))
+     &                 /(1.-MIN(REAL(zcloudh(i), kind=8),1.-ZEPSEC))
+                  zcloudh(i)=pclc(i,k)
+               ELSE IF (paprs(i,k).GE.prmhc .AND.
+     &                 paprs(i,k).LT.prlmc) THEN
+                  pcm(i) = pcm(i)*(1.-MAX(pclc(i,k),zcloudm(i)))
+     &                 /(1.-MIN(REAL(zcloudm(i), kind=8),1.-ZEPSEC))
+                  zcloudm(i)=pclc(i,k)
+               ELSE IF (paprs(i,k).GE.prlmc) THEN 
+                  pcl(i) = pcl(i)*(1.-MAX(pclc(i,k),zcloudl(i)))
+     &                 /(1.-MIN(REAL(zcloudl(i), kind=8),1.-ZEPSEC))
+                  zcloudl(i)=pclc(i,k)
+               endif
+               zcloud(i)=pclc(i,k)
+            ENDDO
+         ENDDO
+      ELSE IF (NOVLP.EQ.2) THEN
+         DO k = klev, 1, -1
+            DO i = 1, klon
+               zcloud(i)=MAX(pclc(i,k),zcloud(i))
+               pct(i)=zcloud(i)
+               IF (paprs(i,k).LT.prmhc) THEN
+                  pch(i) = MIN(pclc(i,k),pch(i))
+               ELSE IF (paprs(i,k).GE.prmhc .AND.
+     &                 paprs(i,k).LT.prlmc) THEN
+                  pcm(i) = MIN(pclc(i,k),pcm(i))
+               ELSE IF (paprs(i,k).GE.prlmc) THEN
+                  pcl(i) = MIN(pclc(i,k),pcl(i))
+               endif
+            ENDDO
+         ENDDO
+      ELSE IF (NOVLP.EQ.3) THEN
+         DO k = klev, 1, -1
+            DO i = 1, klon
+               zclear(i)=zclear(i)*(1.-pclc(i,k))
+               pct(i)=1-zclear(i)
+               IF (paprs(i,k).LT.prmhc) THEN
+                  pch(i) = pch(i)*(1.0-pclc(i,k))
+               ELSE IF (paprs(i,k).GE.prmhc .AND.
+     &                 paprs(i,k).LT.prlmc) THEN 
+                  pcm(i) = pcm(i)*(1.0-pclc(i,k))
+               ELSE IF (paprs(i,k).GE.prlmc) THEN
+                  pcl(i) = pcl(i)*(1.0-pclc(i,k))
+               endif
+            ENDDO
+         ENDDO
+      ENDIF
+C     
+      DO i = 1, klon
+         pch(i)=1.-pch(i)
+         pcm(i)=1.-pcm(i)
+         pcl(i)=1.-pcl(i)
+      ENDDO
+c
+c ========================================================
+c DIAGNOSTICS CALCULATION FOR CMIP5 PROTOCOL
+c ========================================================
+c change by Nicolas Yan (LSCE) 
+c Cloud Droplet Number Concentration (CDNC) : 3D variable
+c Fractionnal cover by liquid water cloud (LCC3D) : 3D variable
+c Cloud Droplet Number Concentration at top of cloud (CLDNCL) : 2D variable
+c Droplet effective radius at top of cloud (REFFCLWTOP) : 2D variable
+c Fractionnal cover by liquid water at top of clouds (LCC) : 2D variable
+c
+         IF (ok_cdnc) THEN
+c
+            DO k = 1, klev
+               DO i = 1, klon
+                  phase3d(i,k)=1-zfice(i,k)
+                  IF (pclc(i,k) .LE. seuil_neb) THEN
+                     lcc3d(i,k)=seuil_neb*phase3d(i,k)
+                  ELSE
+                     lcc3d(i,k)=pclc(i,k)*phase3d(i,k)
+                  ENDIF
+                  scdnc(i,k)=lcc3d(i,k)*cdnc(i,k) ! m-3
+               ENDDO
+            ENDDO
+c
+            DO i=1,klon
+               lcc(i)=0.
+               reffclwtop(i)=0.
+               cldncl(i)=0.
+               IF(RANDOM .OR. MAXIMUM_RANDOM) tcc(i) = 1.
+               IF(MAXIMUM) tcc(i) = 0.
+            ENDDO
+c
+            DO i=1,klon
+               DO k=klev-1,1,-1 !From TOA down
+c
+            ! Test, if the cloud optical depth exceeds the necessary
+            ! threshold:
+
+             IF (pcltau(i,k).GT.thres_tau 
+     .            .AND. pclc(i,k).GT.thres_neb) THEN
+
+                  IF (MAXIMUM) THEN
+                    IF (FIRST) THEN
+                       write(*,*)'Hypothese de recouvrement: MAXIMUM'
+                       FIRST=.FALSE.
+                    ENDIF
+                    flag_max= -1.
+                    ftmp(i) = MAX(tcc(i),pclc(i,k))
+                  ENDIF
+
+                  IF (RANDOM) THEN
+                    IF (FIRST) THEN
+                       write(*,*)'Hypothese de recouvrement: RANDOM'
+                       FIRST=.FALSE.
+                    ENDIF
+                    flag_max= 1.
+                    ftmp(i) = tcc(i) * (1-pclc(i,k))
+                  ENDIF
+
+                  IF (MAXIMUM_RANDOM) THEN
+                    IF (FIRST) THEN
+                       write(*,*)'Hypothese de recouvrement: MAXIMUM_
+     .                         RANDOM'
+                       FIRST=.FALSE.
+                    ENDIF
+                    flag_max= 1.
+                    ftmp(i) = tcc(i) *
+     .              (1. - MAX(pclc(i,k),pclc(i,k+1))) /
+     .              (1. - MIN(pclc(i,k+1),1.-thres_neb))
+                  ENDIF
+c Effective radius of cloud droplet at top of cloud (m)
+                  reffclwtop(i) = reffclwtop(i) + rad_chaud(i,k) * 
+     .           1.0E-06 * phase3d(i,k) * ( tcc(i) - ftmp(i))*flag_max
+c CDNC at top of cloud (m-3)
+                  cldncl(i) = cldncl(i) + cdnc(i,k) * phase3d(i,k) * 
+     .                 (tcc(i) - ftmp(i))*flag_max
+c Liquid Cloud Content at top of cloud
+                  lcc(i) = lcc(i) + phase3d(i,k) * (tcc(i)-ftmp(i))*
+     .                    flag_max
+c Total Cloud Content at top of cloud
+                  tcc(i)=ftmp(i)
+              
+          ENDIF ! is there a visible, not-too-small cloud?  
+          ENDDO ! loop over k
+c
+          IF (RANDOM .OR. MAXIMUM_RANDOM) tcc(i)=1.-tcc(i)
+c
+         ENDDO ! loop over i
+
+!! Convective and Stratiform Cloud Droplet Effective Radius (REFFCLWC  REFFCLWS)
+            DO i = 1, klon
+               DO k = 1, klev
+! Weight to be used for outputs: eau_liquide*couverture nuageuse
+                  lcc3dcon(i,k) =rnebcon(i,k)*phase3d(i,k)*clwcon(i,k)  ! eau liquide convective
+                  lcc3dstra(i,k)=pclc(i,k)*pqlwp(i,k)*phase3d(i,k)
+                  lcc3dstra(i,k)=lcc3dstra(i,k)-lcc3dcon(i,k)           ! eau liquide stratiforme
+                  lcc3dstra(i,k)=MAX(lcc3dstra(i,k),0.0)
+! Compute cloud droplet radius as above in meter
+                  radius=1.1*((pqlwp(i,k)*pplay(i,k)/(RD * T(i,k)))  
+     &               /(4./3*RPI*1000.*cdnc(i,k)) )**(1./3.)
+                  radius=MAX(radius, 5.e-6) 
+! Convective Cloud Droplet Effective Radius (REFFCLWC) : variable 3D
+                  reffclwc(i,k)=radius
+                  reffclwc(i,k)=reffclwc(i,k)*lcc3dcon(i,k)
+! Stratiform Cloud Droplet Effective Radius (REFFCLWS) : variable 3D
+                  reffclws(i,k)=radius
+                  reffclws(i,k)=reffclws(i,k)*lcc3dstra(i,k)
+               ENDDO !klev
+            ENDDO !klon 
+c
+c Column Integrated Cloud Droplet Number (CLDNVI) : variable 2D
+c
+            DO i = 1, klon
+               cldnvi(i)=0.
+               lcc_integrat(i)=0.
+               height(i)=0.
+               DO k = 1, klev
+                  cldnvi(i)=cldnvi(i)+cdnc(i,k)*lcc3d(i,k)*dh(i,k)
+                  lcc_integrat(i)=lcc_integrat(i)+lcc3d(i,k)*dh(i,k)
+                  height(i)=height(i)+dh(i,k)
+               ENDDO ! klev
+               lcc_integrat(i)=lcc_integrat(i)/height(i)
+               IF (lcc_integrat(i) .LE. 1.0E-03) THEN
+                  cldnvi(i)=cldnvi(i)*lcc(i)/seuil_neb
+               ELSE
+                  cldnvi(i)=cldnvi(i)*lcc(i)/lcc_integrat(i)
+               ENDIF
+            ENDDO ! klon
+            
+            DO i = 1, klon
+               DO k = 1, klev
+                IF (scdnc(i,k) .LE. 0.0)     scdnc(i,k)=0.0
+                IF (reffclws(i,k) .LE. 0.0)  reffclws(i,k)=0.0
+                IF (reffclwc(i,k) .LE. 0.0)  reffclwc(i,k)=0.0
+                IF (lcc3d(i,k) .LE. 0.0)     lcc3d(i,k)=0.0
+                IF (lcc3dcon(i,k) .LE. 0.0)  lcc3dcon(i,k)=0.0
+                IF (lcc3dstra(i,k) .LE. 0.0) lcc3dstra(i,k)=0.0
+               ENDDO
+               IF (reffclwtop(i) .LE. 0.0)  reffclwtop(i)=0.0
+               IF (cldncl(i) .LE. 0.0)      cldncl(i)=0.0
+               IF (cldnvi(i) .LE. 0.0)      cldnvi(i)=0.0
+               IF (lcc(i) .LE. 0.0)         lcc(i)=0.0
+            ENDDO
+c
+      ENDIF !ok_cdnc
+c
+      RETURN
+c
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/newmicro.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/newmicro.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/newmicro.F90	(revision 17)
@@ -0,0 +1,605 @@
+! $Id: newmicro.F 1750 2013-04-25 15:27:27Z fairhead $
+
+
+!     
+      SUBROUTINE newmicro (ok_cdnc, bl95_b0, bl95_b1,                                &
+       &                  paprs, pplay,                                              &
+       &                  t, pqlwp, pclc, pcltau, pclemi,                            &
+       &                  pch, pcl, pcm, pct, pctlwp,                                &
+       &                  xflwp, xfiwp, xflwc, xfiwc,                                &
+       &                  mass_solu_aero, mass_solu_aero_pi,                         &
+       &                  pcldtaupi, re, fl, reliq, reice)
+!c
+      USE dimphy
+      USE phys_local_var_mod, only: scdnc,cldncl,reffclwtop,lcc,                     &
+       &                              reffclws,reffclwc,cldnvi,lcc3d,                &
+       &                              lcc3dcon,lcc3dstra
+      USE phys_state_var_mod, only: rnebcon,clwcon
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+!c            O.   Boucher (LMD/CNRS) mise a jour en 201212
+!c Objet: Calculer epaisseur optique et emmissivite des nuages
+!c======================================================================
+!c Arguments:
+!c ok_cdnc-input-L-flag pour calculer les rayons a partir des aerosols
+!c
+!c t-------input-R-temperature
+!c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere dans la partie nuageuse (kg/kg)
+!c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+!c mass_solu_aero-----input-R-total mass concentration for all soluble aerosols[ug/m^3]
+!c mass_solu_aero_pi--input-R-ditto, pre-industrial value
+!c
+!c bl95_b0-input-R-a PARAMETER, may be varied for tests (s-sea, l-land)
+!c bl95_b1-input-R-a PARAMETER, may be varied for tests (    -"-      )
+!c      
+!c re------output-R-Cloud droplet effective radius multiplied by fl [um]
+!c fl------output-R-Denominator to re, introduced to avoid problems in
+!c                  the averaging of the output. fl is the fraction of liquid
+!c                  water clouds within a grid cell           
+!c
+!c pcltau--output-R-epaisseur optique des nuages
+!c pclemi--output-R-emissivite des nuages (0 a 1)
+!c pcldtaupi-output-R-pre-industrial value of cloud optical thickness, 
+!c
+!c pcl-output-R-2D low-level cloud cover
+!c pcm-output-R-2D mid-level cloud cover
+!c pch-output-R-2D high-level cloud cover
+!c pct-output-R-2D total cloud cover
+!c======================================================================
+!C
+#include "YOMCST.h"
+#include "nuage.h"
+#include "radepsi.h"
+#include "radopt.h"
+
+!c choix de l'hypothese de recouvrememnt nuageuse
+      LOGICAL RANDOM, MAXIMUM_RANDOM, MAXIMUM
+      PARAMETER (RANDOM=.FALSE., MAXIMUM_RANDOM=.TRUE., MAXIMUM=.FALSE.)
+!c
+      LOGICAL, SAVE :: FIRST=.TRUE.
+!$OMP THREADPRIVATE(FIRST)
+      INTEGER flag_max
+!c
+!c threshold PARAMETERs
+      REAL thres_tau,thres_neb
+      PARAMETER (thres_tau=0.3, thres_neb=0.001)
+!c
+      REAL phase3d(klon, klev)
+      REAL tcc(klon), ftmp(klon), lcc_integrat(klon), height(klon)
+!c
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL t(klon,klev)
+      REAL pclc(klon,klev)
+      REAL pqlwp(klon,klev)
+      REAL pcltau(klon,klev)
+      REAL pclemi(klon,klev)
+      REAL pcldtaupi(klon, klev)
+!c
+      REAL pct(klon)
+      REAL pcl(klon)
+      REAL pcm(klon)
+      REAL pch(klon)
+      REAL pctlwp(klon)
+!c
+      LOGICAL lo
+!c
+!!Abderr modif JL mail du 19.01.2011 18:31
+!      REAL cetahb, cetamb
+!      PARAMETER (cetahb = 0.45, cetamb = 0.80)
+! Remplacer
+! cetahb*paprs(i,1) par  prmhc
+! cetamb*paprs(i,1) par  prlmc 
+      REAL prmhc    ! Pressure between medium and high level cloud in Pa
+      REAL prlmc    ! Pressure between low and medium level cloud in Pa
+      PARAMETER (prmhc = 440.*100., prlmc = 680.*100.)
+!C
+      INTEGER i, k
+      REAL xflwp(klon), xfiwp(klon)
+      REAL xflwc(klon,klev), xfiwc(klon,klev)
+!c
+      REAL radius
+!c
+      REAL coef_froi, coef_chau
+      PARAMETER (coef_chau=0.13, coef_froi=0.09)
+!c
+      REAL seuil_neb
+      PARAMETER (seuil_neb=0.001)
+!c
+      INTEGER nexpo ! exponentiel pour glace/eau
+      PARAMETER (nexpo=6)
+!c      PARAMETER (nexpo=1)
+
+      REAL rel, tc, rei
+      REAL k_ice0, k_ice, DF
+      PARAMETER (k_ice0=0.005) ! units=m2/g
+      PARAMETER (DF=1.66) ! diffusivity factor
+!c
+!cjq for the aerosol indirect effect
+!cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+!cjq      
+      REAL mass_solu_aero(klon, klev)    ! total mass concentration for all soluble aerosols [ug m-3]
+      REAL mass_solu_aero_pi(klon, klev) ! - " - (pre-industrial value)
+      REAL cdnc(klon, klev)     ! cloud droplet number concentration [m-3]
+      REAL re(klon, klev)       ! cloud droplet effective radius [um]
+      REAL cdnc_pi(klon, klev)     ! cloud droplet number concentration [m-3] (pi value)
+      REAL re_pi(klon, klev)       ! cloud droplet effective radius [um] (pi value)
+      
+      REAL fl(klon, klev)       ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell)
+      
+      LOGICAL ok_cdnc
+      REAL bl95_b0, bl95_b1     ! Parameter in B&L 95-Formula
+      
+!cjq-end    
+!IM cf. CR:parametres supplementaires
+      REAL zclear(klon)
+      REAL zcloud(klon) 
+      REAL zcloudh(klon) 
+      REAL zcloudm(klon) 
+      REAL zcloudl(klon) 
+      REAL rhodz(klon, klev)  !--rho*dz pour la couche
+      REAL zrho(klon, klev)   !--rho pour la couche
+      REAL dh(klon, klev)     !--dz pour la couche
+      REAL zfice(klon, klev)
+      REAL rad_chaud(klon, klev) !--rayon pour les nuages chauds
+      REAL zflwp_var, zfiwp_var
+      REAL d_rei_dt
+
+! Abderrahmane oct 2009
+      Real reliq(klon, klev), reice(klon, klev)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH : 2011/05/24
+!
+! rei = ( rei_max - rei_min ) * T(Â°C) / 81.4 + rei_max
+! to be used for a temperature in celcius T(Â°C) < 0
+! rei=rei_min for T(Â°C) < -81.4
+!
+! Calcul de la pente de la relation entre rayon effective des cristaux
+! et la tempÃ©rature.
+! Pour retrouver les rÃ©sultats numÃ©riques de la version d'origine,
+! on impose 0.71 quand on est proche de 0.71
+!c
+      d_rei_dt=(rei_max-rei_min)/81.4
+      if (abs(d_rei_dt-0.71)<1.e-4) d_rei_dt=0.71
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+!c Calculer l'epaisseur optique et l'emmissivite des nuages
+!c     IM inversion des DO
+!c
+      xflwp = 0.d0
+      xfiwp = 0.d0
+      xflwc = 0.d0
+      xfiwc = 0.d0
+!c
+      reliq=0.
+      reice=0.
+!c
+      DO k = 1, klev
+        DO i = 1, klon
+!c-layer calculation
+          rhodz(i,k) = (paprs(i,k)-paprs(i,k+1))/RG  ! kg/m2
+          zrho(i,k)=pplay(i,k)/t(i,k)/RD             ! kg/m3
+          dh(i,k)=rhodz(i,k)/zrho(i,k)               ! m
+!c-Fraction of ice in cloud using a linear transition
+          zfice(i,k) = 1.0 - (t(i,k)-t_glace_min) /                                  &
+       &                       (t_glace_max-t_glace_min)
+          zfice(i,k) = MIN(MAX(zfice(i,k),0.0),1.0)
+!c-IM Total Liquid/Ice water content                                    
+          xflwc(i,k) = (1.-zfice(i,k))*pqlwp(i,k)
+          xfiwc(i,k) = zfice(i,k)*pqlwp(i,k)
+         ENDDO
+      ENDDO
+
+      IF (ok_cdnc) THEN
+!c
+!c--we compute cloud properties as a function of the aerosol load
+!c
+        DO k = 1, klev
+            DO i = 1, klon
+!c
+!c Formula "D" of Boucher and Lohmann, Tellus, 1995
+!c Cloud droplet number concentration (CDNC) is restricted
+!c to be within [20, 1000 cm^3]
+!c
+!c--present-day case
+                cdnc(i,k) = 10.**(bl95_b0+bl95_b1*                                   &
+       &               log(MAX(mass_solu_aero(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+                cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k)))
+!c
+!c--pre-industrial case
+                cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1*                                &
+       &               log(MAX(mass_solu_aero_pi(i,k),1.e-4))/log(10.))              &
+       &               *1.e6 !-m-3
+                cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k)))
+!c
+!c--present-day case
+                rad_chaud(i,k) =                                                     &
+       &               1.1*((pqlwp(i,k)*pplay(i,k)/(RD * T(i,k)))                    &
+       &               /(4./3*RPI*1000.*cdnc(i,k)) )**(1./3.)
+                rad_chaud(i,k) = MAX(rad_chaud(i,k) * 1.e6, 5.) 
+!c
+!c--pre-industrial case
+                radius =                                                             &
+       &               1.1*((pqlwp(i,k)*pplay(i,k)/(RD * T(i,k)))                    &
+       &               /(4./3.*RPI*1000.*cdnc_pi(i,k)))**(1./3.)
+                radius = MAX(radius*1.e6, 5.) 
+!c 
+!c--pre-industrial case
+!c--liquid/ice cloud water paths:
+                IF (pclc(i,k) .LE. seuil_neb) THEN
+!c
+                pcldtaupi(i,k) = 0.0                  
+!c
+                ELSE
+!c                  
+                zflwp_var= 1000.*(1.-zfice(i,k))*pqlwp(i,k)/pclc(i,k)                &
+       &               *rhodz(i,k)
+                zfiwp_var= 1000.*zfice(i,k)*pqlwp(i,k)/pclc(i,k)                     &
+       &               *rhodz(i,k)
+                tc = t(i,k)-273.15
+                rei = d_rei_dt*tc + rei_max
+                if (tc.le.-81.4) rei = rei_min
+!c
+!c-- cloud optical thickness :
+!c [for liquid clouds, traditional formula, 
+!c for ice clouds, Ebert & Curry (1992)] 
+!c                  
+                if (zflwp_var.eq.0.) radius = 1. 
+                if (zfiwp_var.eq.0. .or. rei.le.0.) rei = 1. 
+                pcldtaupi(i,k) = 3.0/2.0 * zflwp_var / radius                        &
+       &                 + zfiwp_var * (3.448e-03  + 2.431/rei)
+!c
+                ENDIF
+!c
+          ENDDO            
+        ENDDO
+!c
+      ELSE !--not ok_cdnc
+!c
+!c-prescribed cloud droplet radius
+!c
+         DO k = 1, MIN(3,klev)
+           DO i = 1, klon
+               rad_chaud(i,k) = rad_chau2
+           ENDDO            
+         ENDDO
+         DO k = MIN(3,klev)+1, klev
+           DO i = 1, klon
+               rad_chaud(i,k) = rad_chau1
+           ENDDO            
+         ENDDO
+
+      ENDIF !--ok_cdnc
+!c
+!c--computation of cloud optical depth and emissivity  
+!c--in the general case
+!c
+       DO k = 1, klev
+          DO i = 1, klon
+!c
+             IF (pclc(i,k) .LE. seuil_neb) THEN
+!c               
+!c effective cloud droplet radius (microns) for liquid water clouds: 
+!c For output diagnostics cloud droplet effective radius [um]
+!c we multiply here with f * xl (fraction of liquid water
+!c clouds in the grid cell) to avoid problems in the averaging of the output.
+!c In the output of IOIPSL, derive the REAL cloud droplet 
+!c effective radius as re/fl
+!c
+                fl(i,k) = seuil_neb*(1.-zfice(i,k))            
+                re(i,k) = rad_chaud(i,k)*fl(i,k)
+                rel = 0.
+                rei = 0.
+                pclc(i,k)   = 0.0
+                pcltau(i,k) = 0.0
+                pclemi(i,k) = 0.0
+!c
+             ELSE
+!c
+!c     -- liquid/ice cloud water paths:
+                  
+                zflwp_var= 1000.*(1.-zfice(i,k))*pqlwp(i,k)/pclc(i,k)                &
+       &               *rhodz(i,k)
+                zfiwp_var= 1000.*zfice(i,k)*pqlwp(i,k)/pclc(i,k)                     &
+       &               *rhodz(i,k)
+!c               
+!c effective cloud droplet radius (microns) for liquid water clouds: 
+!c For output diagnostics cloud droplet effective radius [um]
+!c we multiply here with f * xl (fraction of liquid water
+!c clouds in the grid cell) to avoid problems in the averaging of the output.
+!c In the output of IOIPSL, derive the REAL cloud droplet 
+!c effective radius as re/fl
+!c 
+                fl(i,k) = pclc(i,k)*(1.-zfice(i,k))            
+                re(i,k) = rad_chaud(i,k)*fl(i,k)
+!c 
+                rel = rad_chaud(i,k)
+!c
+!c for ice clouds: as a function of the ambiant temperature
+!c [formula used by Iacobellis and Somerville (2000), with an 
+!c asymptotical value of 3.5 microns at T<-81.4 C added to be 
+!c consistent with observations of Heymsfield et al. 1986]:
+!c 2011/05/24 : rei_min = 3.5 becomes a free PARAMETER as well as rei_max=61.29
+!c
+                tc = t(i,k)-273.15
+                rei = d_rei_dt*tc + rei_max
+                if (tc.le.-81.4) rei = rei_min
+!c
+!c-- cloud optical thickness :
+!c [for liquid clouds, traditional formula, 
+!c for ice clouds, Ebert & Curry (1992)] 
+!c                  
+                 if (zflwp_var.eq.0.) rel = 1. 
+                 if (zfiwp_var.eq.0. .or. rei.le.0.) rei = 1. 
+                 pcltau(i,k) = 3.0/2.0 * ( zflwp_var/rel )                           &
+       &                 + zfiwp_var * (3.448e-03  + 2.431/rei)
+!c
+!c     -- cloud infrared emissivity:
+!c     [the broadband infrared absorption coefficient is PARAMETERized
+!c     as a function of the effective cld droplet radius]
+!c     Ebert and Curry (1992) formula as used by Kiehl & Zender (1995):
+!c
+                  k_ice = k_ice0 + 1.0/rei
+!c                 
+                  pclemi(i,k) = 1.0                                                  &
+       &                 - EXP( -coef_chau*zflwp_var - DF*k_ice*zfiwp_var)
+!c
+             ENDIF
+!c
+             reliq(i,k)=rel
+             reice(i,k)=rei 
+!c
+             xflwp(i) = xflwp(i)+ xflwc(i,k) * rhodz(i,k)
+             xfiwp(i) = xfiwp(i)+ xfiwc(i,k) * rhodz(i,k)
+!c
+          ENDDO
+       ENDDO
+!c
+!c--if cloud droplet radius is fixed, then pcldtaupi=pcltau
+!c
+      IF (.NOT.ok_cdnc) THEN
+         DO k = 1, klev
+            DO i = 1, klon
+               pcldtaupi(i,k)=pcltau(i,k)
+            ENDDO
+         ENDDO               
+      ENDIF
+!C     
+!C     COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+!c     IM cf. CR:test: calcul prenant ou non en compte le recouvrement
+!c     initialisations
+!c
+      DO i=1,klon
+         zclear(i)=1.
+         zcloud(i)=0.
+         zcloudh(i)=0.
+         zcloudm(i)=0.
+         zcloudl(i)=0.
+         pch(i)=1.0
+         pcm(i) = 1.0
+         pcl(i) = 1.0
+         pctlwp(i) = 0.0
+      ENDDO
+!C
+!c--calculation of liquid water path
+!c
+      DO k = klev, 1, -1
+         DO i = 1, klon
+            pctlwp(i) = pctlwp(i)+ pqlwp(i,k)*rhodz(i,k)
+         ENDDO
+      ENDDO
+!c     
+!c--calculation of cloud properties with cloud overlap
+!c
+      IF (NOVLP.EQ.1) THEN
+         DO k = klev, 1, -1
+            DO i = 1, klon
+               zclear(i)=zclear(i)*(1.-MAX(pclc(i,k),zcloud(i)))                     &
+       &              /(1.-MIN(REAL(zcloud(i), kind=8),1.-ZEPSEC))
+               pct(i)=1.-zclear(i) 
+               IF (paprs(i,k).LT.prmhc) THEN
+                  pch(i) = pch(i)*(1.-MAX(pclc(i,k),zcloudh(i)))                     &
+       &                 /(1.-MIN(REAL(zcloudh(i), kind=8),1.-ZEPSEC))
+                  zcloudh(i)=pclc(i,k)
+               ELSE IF (paprs(i,k).GE.prmhc .AND.                                    &
+       &                 paprs(i,k).LT.prlmc) THEN
+                  pcm(i) = pcm(i)*(1.-MAX(pclc(i,k),zcloudm(i)))                     &
+       &                 /(1.-MIN(REAL(zcloudm(i), kind=8),1.-ZEPSEC))
+                  zcloudm(i)=pclc(i,k)
+               ELSE IF (paprs(i,k).GE.prlmc) THEN 
+                  pcl(i) = pcl(i)*(1.-MAX(pclc(i,k),zcloudl(i)))                     &
+       &                 /(1.-MIN(REAL(zcloudl(i), kind=8),1.-ZEPSEC))
+                  zcloudl(i)=pclc(i,k)
+               endif
+               zcloud(i)=pclc(i,k)
+            ENDDO
+         ENDDO
+      ELSE IF (NOVLP.EQ.2) THEN
+         DO k = klev, 1, -1
+            DO i = 1, klon
+               zcloud(i)=MAX(pclc(i,k),zcloud(i))
+               pct(i)=zcloud(i)
+               IF (paprs(i,k).LT.prmhc) THEN
+                  pch(i) = MIN(pclc(i,k),pch(i))
+               ELSE IF (paprs(i,k).GE.prmhc .AND.                                    &
+       &                 paprs(i,k).LT.prlmc) THEN
+                  pcm(i) = MIN(pclc(i,k),pcm(i))
+               ELSE IF (paprs(i,k).GE.prlmc) THEN
+                  pcl(i) = MIN(pclc(i,k),pcl(i))
+               endif
+            ENDDO
+         ENDDO
+      ELSE IF (NOVLP.EQ.3) THEN
+         DO k = klev, 1, -1
+            DO i = 1, klon
+               zclear(i)=zclear(i)*(1.-pclc(i,k))
+               pct(i)=1-zclear(i)
+               IF (paprs(i,k).LT.prmhc) THEN
+                  pch(i) = pch(i)*(1.0-pclc(i,k))
+               ELSE IF (paprs(i,k).GE.prmhc .AND.                                    &
+       &                 paprs(i,k).LT.prlmc) THEN 
+                  pcm(i) = pcm(i)*(1.0-pclc(i,k))
+               ELSE IF (paprs(i,k).GE.prlmc) THEN
+                  pcl(i) = pcl(i)*(1.0-pclc(i,k))
+               endif
+            ENDDO
+         ENDDO
+      ENDIF
+!C     
+      DO i = 1, klon
+         pch(i)=1.-pch(i)
+         pcm(i)=1.-pcm(i)
+         pcl(i)=1.-pcl(i)
+      ENDDO
+!c
+!c ========================================================
+!c DIAGNOSTICS CALCULATION FOR CMIP5 PROTOCOL
+!c ========================================================
+!c change by Nicolas Yan (LSCE) 
+!c Cloud Droplet Number Concentration (CDNC) : 3D variable
+!c Fractionnal cover by liquid water cloud (LCC3D) : 3D variable
+!c Cloud Droplet Number Concentration at top of cloud (CLDNCL) : 2D variable
+!c Droplet effective radius at top of cloud (REFFCLWTOP) : 2D variable
+!c Fractionnal cover by liquid water at top of clouds (LCC) : 2D variable
+!c
+         IF (ok_cdnc) THEN
+!c
+            DO k = 1, klev
+               DO i = 1, klon
+                  phase3d(i,k)=1-zfice(i,k)
+                  IF (pclc(i,k) .LE. seuil_neb) THEN
+                     lcc3d(i,k)=seuil_neb*phase3d(i,k)
+                  ELSE
+                     lcc3d(i,k)=pclc(i,k)*phase3d(i,k)
+                  ENDIF
+                  scdnc(i,k)=lcc3d(i,k)*cdnc(i,k) ! m-3
+               ENDDO
+            ENDDO
+!c
+            DO i=1,klon
+               lcc(i)=0.
+               reffclwtop(i)=0.
+               cldncl(i)=0.
+               IF(RANDOM .OR. MAXIMUM_RANDOM) tcc(i) = 1.
+               IF(MAXIMUM) tcc(i) = 0.
+            ENDDO
+!c
+            DO i=1,klon
+               DO k=klev-1,1,-1 !From TOA down
+!c
+            ! Test, if the cloud optical depth exceeds the necessary
+            ! threshold:
+
+             IF (pcltau(i,k).GT.thres_tau                                            &
+       &            .AND. pclc(i,k).GT.thres_neb) THEN
+
+                  IF (MAXIMUM) THEN
+                    IF (FIRST) THEN
+                       write(*,*)'Hypothese de recouvrement: MAXIMUM'
+                       FIRST=.FALSE.
+                    ENDIF
+                    flag_max= -1.
+                    ftmp(i) = MAX(tcc(i),pclc(i,k))
+                  ENDIF
+
+                  IF (RANDOM) THEN
+                    IF (FIRST) THEN
+                       write(*,*)'Hypothese de recouvrement: RANDOM'
+                       FIRST=.FALSE.
+                    ENDIF
+                    flag_max= 1.
+                    ftmp(i) = tcc(i) * (1-pclc(i,k))
+                  ENDIF
+
+                  IF (MAXIMUM_RANDOM) THEN
+                    IF (FIRST) THEN
+                       write(*,*)'Hypothese de recouvrement: MAXIMUM_                &
+       &                         RANDOM'
+                       FIRST=.FALSE.
+                    ENDIF
+                    flag_max= 1.
+                    ftmp(i) = tcc(i) *                                               &
+       &              (1. - MAX(pclc(i,k),pclc(i,k+1))) /                            &
+       &              (1. - MIN(pclc(i,k+1),1.-thres_neb))
+                  ENDIF
+!c Effective radius of cloud droplet at top of cloud (m)
+                  reffclwtop(i) = reffclwtop(i) + rad_chaud(i,k) *                   &
+       &           1.0E-06 * phase3d(i,k) * ( tcc(i) - ftmp(i))*flag_max
+!c CDNC at top of cloud (m-3)
+                  cldncl(i) = cldncl(i) + cdnc(i,k) * phase3d(i,k) *                 &
+       &                 (tcc(i) - ftmp(i))*flag_max
+!c Liquid Cloud Content at top of cloud
+                  lcc(i) = lcc(i) + phase3d(i,k) * (tcc(i)-ftmp(i))*                 &
+       &                    flag_max
+!c Total Cloud Content at top of cloud
+                  tcc(i)=ftmp(i)
+              
+          ENDIF ! is there a visible, not-too-small cloud?  
+          ENDDO ! loop over k
+!c
+          IF (RANDOM .OR. MAXIMUM_RANDOM) tcc(i)=1.-tcc(i)
+!c
+         ENDDO ! loop over i
+
+!! Convective and Stratiform Cloud Droplet Effective Radius (REFFCLWC  REFFCLWS)
+            DO i = 1, klon
+               DO k = 1, klev
+! Weight to be used for outputs: eau_liquide*couverture nuageuse
+                  lcc3dcon(i,k) =rnebcon(i,k)*phase3d(i,k)*clwcon(i,k)  ! eau liquide convective
+                  lcc3dstra(i,k)=pclc(i,k)*pqlwp(i,k)*phase3d(i,k)
+                  lcc3dstra(i,k)=lcc3dstra(i,k)-lcc3dcon(i,k)           ! eau liquide stratiforme
+                  lcc3dstra(i,k)=MAX(lcc3dstra(i,k),0.0)
+! Compute cloud droplet radius as above in meter
+                  radius=1.1*((pqlwp(i,k)*pplay(i,k)/(RD * T(i,k)))                  &
+       &               /(4./3*RPI*1000.*cdnc(i,k)) )**(1./3.)
+                  radius=MAX(radius, 5.e-6) 
+! Convective Cloud Droplet Effective Radius (REFFCLWC) : variable 3D
+                  reffclwc(i,k)=radius
+                  reffclwc(i,k)=reffclwc(i,k)*lcc3dcon(i,k)
+! Stratiform Cloud Droplet Effective Radius (REFFCLWS) : variable 3D
+                  reffclws(i,k)=radius
+                  reffclws(i,k)=reffclws(i,k)*lcc3dstra(i,k)
+               ENDDO !klev
+            ENDDO !klon 
+!c
+!c Column Integrated Cloud Droplet Number (CLDNVI) : variable 2D
+!c
+            DO i = 1, klon
+               cldnvi(i)=0.
+               lcc_integrat(i)=0.
+               height(i)=0.
+               DO k = 1, klev
+                  cldnvi(i)=cldnvi(i)+cdnc(i,k)*lcc3d(i,k)*dh(i,k)
+                  lcc_integrat(i)=lcc_integrat(i)+lcc3d(i,k)*dh(i,k)
+                  height(i)=height(i)+dh(i,k)
+               ENDDO ! klev
+               lcc_integrat(i)=lcc_integrat(i)/height(i)
+               IF (lcc_integrat(i) .LE. 1.0E-03) THEN
+                  cldnvi(i)=cldnvi(i)*lcc(i)/seuil_neb
+               ELSE
+                  cldnvi(i)=cldnvi(i)*lcc(i)/lcc_integrat(i)
+               ENDIF
+            ENDDO ! klon
+            
+            DO i = 1, klon
+               DO k = 1, klev
+                IF (scdnc(i,k) .LE. 0.0)     scdnc(i,k)=0.0
+                IF (reffclws(i,k) .LE. 0.0)  reffclws(i,k)=0.0
+                IF (reffclwc(i,k) .LE. 0.0)  reffclwc(i,k)=0.0
+                IF (lcc3d(i,k) .LE. 0.0)     lcc3d(i,k)=0.0
+                IF (lcc3dcon(i,k) .LE. 0.0)  lcc3dcon(i,k)=0.0
+                IF (lcc3dstra(i,k) .LE. 0.0) lcc3dstra(i,k)=0.0
+               ENDDO
+               IF (reffclwtop(i) .LE. 0.0)  reffclwtop(i)=0.0
+               IF (cldncl(i) .LE. 0.0)      cldncl(i)=0.0
+               IF (cldnvi(i) .LE. 0.0)      cldnvi(i)=0.0
+               IF (lcc(i) .LE. 0.0)         lcc(i)=0.0
+            ENDDO
+!c
+      ENDIF !ok_cdnc
+!c
+      RETURN
+!c
+      END SUBROUTINE newmicro
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_def_var_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_def_var_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_def_var_m.F90	(revision 17)
@@ -0,0 +1,102 @@
+! $Id$
+module nf95_def_var_m
+
+  ! The generic procedure name "nf90_def_var" applies to
+  ! "nf90_def_var_Scalar" but we cannot apply the generic procedure name
+  ! "nf95_def_var" to "nf95_def_var_scalar" because of the additional
+  ! optional argument.
+  ! "nf95_def_var_scalar" cannot be distinguished from "nf95_def_var_oneDim".
+
+  implicit none
+
+  interface nf95_def_var
+    module procedure nf95_def_var_oneDim, nf95_def_var_ManyDims
+  end interface
+
+  private
+  public nf95_def_var, nf95_def_var_scalar
+
+contains
+
+  subroutine nf95_def_var_scalar(ncid, name, xtype, varid, ncerr)
+
+    use netcdf, only: nf90_def_var
+    use handle_err_m, only: handle_err
+
+    integer,               intent( in) :: ncid
+    character (len = *),   intent( in) :: name
+    integer,               intent( in) :: xtype
+    integer,               intent(out) :: varid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_def_var(ncid, name, xtype, varid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_def_var_scalar " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_def_var_scalar
+
+  !***********************
+
+  subroutine nf95_def_var_oneDim(ncid, name, xtype, dimids, varid, ncerr)
+
+    use netcdf, only: nf90_def_var
+    use handle_err_m, only: handle_err
+
+    integer,               intent( in) :: ncid
+    character (len = *),   intent( in) :: name
+    integer,               intent( in) :: xtype
+    integer,               intent( in) :: dimids
+    integer,               intent(out) :: varid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_def_var(ncid, name, xtype, dimids, varid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_def_var_oneDim " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_def_var_oneDim
+
+  !***********************
+
+  subroutine nf95_def_var_ManyDims(ncid, name, xtype, dimids, varid, ncerr)
+
+    use netcdf, only: nf90_def_var
+    use handle_err_m, only: handle_err
+
+    integer,               intent( in) :: ncid
+    character (len = *),   intent( in) :: name
+    integer,               intent( in) :: xtype
+    integer, dimension(:), intent( in) :: dimids
+    integer,               intent(out) :: varid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_def_var(ncid, name, xtype, dimids, varid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_def_var_ManyDims " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_def_var_ManyDims
+
+end module nf95_def_var_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_get_att_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_get_att_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_get_att_m.F90	(revision 17)
@@ -0,0 +1,105 @@
+! $Id$
+module nf95_get_att_m
+
+  use handle_err_m, only: handle_err
+  use netcdf, only: nf90_get_att, nf90_noerr
+  use simple, only: nf95_inquire_attribute
+
+  implicit none
+
+  interface nf95_get_att
+     module procedure nf95_get_att_text, nf95_get_att_one_FourByteInt
+
+     ! The difference between the specific procedures is the type of
+     ! argument "values".
+  end interface
+
+  private
+  public nf95_get_att
+
+contains
+
+  subroutine nf95_get_att_text(ncid, varid, name, values, ncerr)
+
+    integer,                          intent( in) :: ncid, varid
+    character(len = *),               intent( in) :: name
+    character(len = *),               intent(out) :: values
+    integer, intent(out), optional:: ncerr
+
+    ! Variables local to the procedure:
+    integer ncerr_not_opt
+    integer att_len
+
+    !-------------------
+
+    ! Check that the length of "values" is large enough:
+    call nf95_inquire_attribute(ncid, varid, name, nclen=att_len, &
+         ncerr=ncerr_not_opt)
+    if (ncerr_not_opt == nf90_noerr) then
+       if (len(values) < att_len) then
+          print *, "nf95_get_att_text"
+          print *, "varid = ", varid
+          print *, "attribute name: ", name
+          print *, 'length of "values" is not large enough'
+          print *, "len(values) = ", len(values)
+          print *, "number of characters in attribute: ", att_len
+          stop 1
+       end if
+    end if
+
+    values = "" ! useless in NetCDF version 3.6.2 or better
+    ncerr_not_opt = nf90_get_att(ncid, varid, name, values)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_att_text " // trim(name), ncerr_not_opt, &
+            ncid, varid)
+    end if
+
+    if (att_len >= 1 .and. ncerr_not_opt == nf90_noerr) then
+       ! Remove null terminator, if any:
+       if (iachar(values(att_len:att_len)) == 0) values(att_len:att_len) = " "
+    end if
+
+  end subroutine nf95_get_att_text
+
+  !***********************
+
+  subroutine nf95_get_att_one_FourByteInt(ncid, varid, name, values, ncerr)
+
+    integer,                                    intent( in) :: ncid, varid
+    character(len = *),                         intent( in) :: name
+    integer ,               intent(out) :: values
+    integer, intent(out), optional:: ncerr
+
+    ! Variables local to the procedure:
+    integer ncerr_not_opt
+    integer att_len
+
+    !-------------------
+
+    ! Check that the attribute contains a single value:
+    call nf95_inquire_attribute(ncid, varid, name, nclen=att_len, &
+         ncerr=ncerr_not_opt)
+    if (ncerr_not_opt == nf90_noerr) then
+       if (att_len /= 1) then
+          print *, "nf95_get_att_one_FourByteInt"
+          print *, "varid = ", varid
+          print *, "attribute name: ", name
+          print *, 'the attribute does not contain a single value'
+          print *, "number of values in attribute: ", att_len
+          stop 1
+       end if
+    end if
+
+    ncerr_not_opt = nf90_get_att(ncid, varid, name, values)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_att_one_FourByteInt " // trim(name), &
+            ncerr_not_opt, ncid, varid)
+    end if
+
+  end subroutine nf95_get_att_one_FourByteInt
+
+end module nf95_get_att_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_get_var_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_get_var_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_get_var_m.F90	(revision 17)
@@ -0,0 +1,391 @@
+module nf95_get_var_m
+
+  use netcdf, only: nf90_get_var
+  use handle_err_m, only: handle_err
+
+  implicit none
+
+  interface nf95_get_var
+     module procedure nf95_get_var_FourByteReal, nf95_get_var_FourByteInt, &
+          nf95_get_var_1D_FourByteReal, nf95_get_var_1D_FourByteInt, &
+          nf95_get_var_2D_FourByteReal, &
+          nf95_get_var_3D_FourByteInt, &
+          nf95_get_var_3D_FourByteReal, &
+          nf95_get_var_4D_FourByteReal, &
+          nf95_get_var_5D_FourByteReal
+  end interface
+
+  private
+  public nf95_get_var
+
+contains
+
+  subroutine nf95_get_var_FourByteReal(ncid, varid, values, start, ncerr)
+
+    integer, intent(in) :: ncid, varid
+    real, intent(out) :: values
+    integer, dimension(:), optional, intent(in) :: start
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_FourByteInt(ncid, varid, values, start, ncerr)
+
+    integer, intent(in) :: ncid, varid
+    integer, intent(out) :: values
+    integer, dimension(:), optional, intent(in) :: start
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_FourByteInt
+
+  !***********************
+
+  subroutine nf95_get_var_1D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(out) :: values(:)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_1D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_1D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_1D_FourByteInt(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    integer, intent(out) :: values(:)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_1D_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_1D_FourByteInt
+
+  !***********************
+
+  subroutine nf95_get_var_1D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: eightByteReal
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal),     intent(out) :: values(:)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_1D_eightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_1D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_2D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    real , intent(out) :: values(:, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_2D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_2D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_2D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal), intent(out) :: values(:, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_2D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_2D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_3D_FourByteInt(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer, intent(in):: ncid, varid
+    integer, intent(out):: values(:, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_3D_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_3D_FourByteInt
+
+  !***********************
+
+  subroutine nf95_get_var_3D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    real , intent(out) :: values(:, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_3D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_3D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_3D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: eightByteReal
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal),     intent(out) :: values(:, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_3D_eightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_3D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_4D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer,                         intent(in) :: ncid, varid
+    real , intent(out) :: values(:, :, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_4D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_4D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_4D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+
+    integer, intent(in):: ncid, varid
+    real(kind = EightByteReal), intent(out):: values(:, :, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_4D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_4D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_5D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    integer, intent(in):: ncid, varid
+    real, intent(out):: values(:, :, :, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_5D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_5D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_get_var_5D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+
+    integer, intent(in):: ncid, varid
+    real(kind = EightByteReal), intent(out):: values(:, :, :, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_get_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_get_var_5D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_get_var_5D_EightByteReal
+
+end module nf95_get_var_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_gw_var_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_gw_var_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_gw_var_m.F90	(revision 17)
@@ -0,0 +1,336 @@
+! $Id$
+module nf95_gw_var_m
+
+  use nf95_get_var_m, only: NF95_GET_VAR
+  use simple, only: nf95_inquire_variable, nf95_inquire_dimension
+
+  implicit none
+
+  interface nf95_gw_var
+     ! "nf95_gw_var" stands for "NetCDF 1995 get whole variable".
+     ! These procedures read a whole NetCDF variable (coordinate or
+     ! primary) into an array.
+     ! The difference between the procedures is the rank and type of
+     ! argument "values".
+     ! The procedures do not check the type of the NetCDF variable.
+
+     ! Not including double precision procedures in the generic
+     ! interface because we use a compilation option that changes default
+     ! real precision.
+     module procedure nf95_gw_var_real_1d, nf95_gw_var_real_2d, &
+          nf95_gw_var_real_3d, nf95_gw_var_real_4d, nf95_gw_var_real_5d, &
+          nf95_gw_var_int_1d, nf95_gw_var_int_3d
+  end interface
+
+  private
+  public nf95_gw_var
+
+contains
+
+  subroutine nf95_gw_var_real_1d(ncid, varid, values)
+
+    ! Real type, the array has rank 1.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:)
+
+    ! Variables local to the procedure:
+    integer nclen
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 1) then
+       print *, "nf95_gw_var_real_1d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 1"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen))
+    if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_1d
+
+  !************************************
+
+  subroutine nf95_gw_var_real_2d(ncid, varid, values)
+
+    ! Real type, the array has rank 2.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:, :)
+
+    ! Variables local to the procedure:
+    integer nclen1, nclen2
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 2) then
+       print *, "nf95_gw_var_real_2d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 2"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
+    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen1, nclen2))
+    if (nclen1 /= 0 .and. nclen2 /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_2d
+
+  !************************************
+
+  subroutine nf95_gw_var_real_3d(ncid, varid, values)
+
+    ! Real type, the array has rank 3.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:, :, :)
+
+    ! Variables local to the procedure:
+    integer nclen1, nclen2, nclen3
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 3) then
+       print *, "nf95_gw_var_real_3d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 3"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
+    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
+    call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen1, nclen2, nclen3))
+    if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_3d
+
+  !************************************
+
+  subroutine nf95_gw_var_real_4d(ncid, varid, values)
+
+    ! Real type, the array has rank 4.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:, :, :, :)
+
+    ! Variables local to the procedure:
+    integer len_dim(4), i
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 4) then
+       print *, "nf95_gw_var_real_4d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 4"
+       stop 1
+    end if
+
+    do i = 1, 4
+       call nf95_inquire_dimension(ncid, dimids(i), nclen=len_dim(i))
+    end do
+    deallocate(dimids) ! pointer
+
+    allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4)))
+    if (all(len_dim /= 0)) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_4d
+
+  !************************************
+
+  subroutine nf95_gw_var_real_5d(ncid, varid, values)
+
+    ! Real type, the array has rank 5.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    real, pointer:: values(:, :, :, :, :)
+
+    ! Variables local to the procedure:
+    integer len_dim(5), i
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 5) then
+       print *, "nf95_gw_var_real_5d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 5"
+       stop 1
+    end if
+
+    do i = 1, 5
+       call nf95_inquire_dimension(ncid, dimids(i), nclen=len_dim(i))
+    end do
+    deallocate(dimids) ! pointer
+
+    allocate(values(len_dim(1), len_dim(2), len_dim(3), len_dim(4), len_dim(5)))
+    if (all(len_dim /= 0)) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_real_5d
+
+  !************************************
+
+!!$  subroutine nf95_gw_var_dble_1d(ncid, varid, values)
+!!$
+!!$    ! Double precision, the array has rank 1.
+!!$
+!!$    integer, intent(in):: ncid
+!!$    integer, intent(in):: varid
+!!$    double precision, pointer:: values(:)
+!!$
+!!$    ! Variables local to the procedure:
+!!$    integer nclen
+!!$    integer, pointer:: dimids(:)
+!!$
+!!$    !---------------------
+!!$
+!!$    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+!!$
+!!$    if (size(dimids) /= 1) then
+!!$       print *, "nf95_gw_var_dble_1d:"
+!!$       print *, "varid = ", varid
+!!$       print *, "rank of NetCDF variable is ", size(dimids), ", not 1"
+!!$        stop 1
+!!$    end if
+!!$
+!!$    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen)
+!!$    deallocate(dimids) ! pointer
+!!$
+!!$    allocate(values(nclen))
+!!$    if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values)
+!!$
+!!$  end subroutine nf95_gw_var_dble_1d
+!!$
+!!$  !************************************
+!!$
+!!$  subroutine nf95_gw_var_dble_3d(ncid, varid, values)
+!!$
+!!$    ! Double precision, the array has rank 3.
+!!$
+!!$    integer, intent(in):: ncid
+!!$    integer, intent(in):: varid
+!!$    double precision, pointer:: values(:, :, :)
+!!$
+!!$    ! Variables local to the procedure:
+!!$    integer nclen1, nclen2, nclen3
+!!$    integer, pointer:: dimids(:)
+!!$
+!!$    !---------------------
+!!$
+!!$    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+!!$
+!!$    if (size(dimids) /= 3) then
+!!$       print *, "nf95_gw_var_dble_3d:"
+!!$       print *, "varid = ", varid
+!!$       print *, "rank of NetCDF variable is ", size(dimids), ", not 3"
+!!$       stop 1
+!!$    end if
+!!$
+!!$    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
+!!$    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
+!!$    call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3)
+!!$    deallocate(dimids) ! pointer
+!!$
+!!$    allocate(values(nclen1, nclen2, nclen3))
+!!$    if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values)
+!!$
+!!$  end subroutine nf95_gw_var_dble_3d
+!!$
+  !************************************
+
+  subroutine nf95_gw_var_int_1d(ncid, varid, values)
+
+    ! Integer type, the array has rank 1.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    integer, pointer:: values(:)
+
+    ! Variables local to the procedure:
+    integer nclen
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 1) then
+       print *, "nf95_gw_var_int_1d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 1"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen))
+    if (nclen /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_int_1d
+
+  !************************************
+
+  subroutine nf95_gw_var_int_3d(ncid, varid, values)
+
+    ! Integer type, the array has rank 3.
+
+    integer, intent(in):: ncid
+    integer, intent(in):: varid
+    integer, pointer:: values(:, :, :)
+
+    ! Variables local to the procedure:
+    integer nclen1, nclen2, nclen3
+    integer, pointer:: dimids(:)
+
+    !---------------------
+
+    call nf95_inquire_variable(ncid, varid, dimids=dimids)
+
+    if (size(dimids) /= 3) then
+       print *, "nf95_gw_var_int_3d:"
+       print *, "varid = ", varid
+       print *, "rank of NetCDF variable is ", size(dimids), ", not 3"
+       stop 1
+    end if
+
+    call nf95_inquire_dimension(ncid, dimids(1), nclen=nclen1)
+    call nf95_inquire_dimension(ncid, dimids(2), nclen=nclen2)
+    call nf95_inquire_dimension(ncid, dimids(3), nclen=nclen3)
+    deallocate(dimids) ! pointer
+
+    allocate(values(nclen1, nclen2, nclen3))
+    if (nclen1 * nclen2 * nclen3 /= 0) call NF95_GET_VAR(ncid, varid, values)
+
+  end subroutine nf95_gw_var_int_3d
+
+end module nf95_gw_var_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_put_att_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_put_att_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_put_att_m.F90	(revision 17)
@@ -0,0 +1,67 @@
+! $Id$
+module nf95_put_att_m
+
+  implicit none
+
+  interface nf95_put_att
+     module procedure nf95_put_att_text, nf95_put_att_one_FourByteInt
+  end interface
+
+  private
+  public nf95_put_att
+
+contains
+
+  subroutine nf95_put_att_text(ncid, varid, name, values, ncerr)
+
+    use netcdf, only: nf90_put_att
+    use handle_err_m, only: handle_err
+
+    integer, intent(in) :: ncid, varid
+    character(len = *), intent(in) :: name
+    character(len = *), intent(in) :: values
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_att(ncid, varid, name, values)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_att_text", ncerr_not_opt, ncid, varid)
+    end if
+
+  end subroutine nf95_put_att_text
+
+  !************************************
+
+  subroutine nf95_put_att_one_FourByteInt(ncid, varid, name, values, ncerr)
+
+    use netcdf, only: nf90_put_att
+    use handle_err_m, only: handle_err
+    use typesizes, only: FourByteInt
+
+    integer, intent(in) :: ncid, varid
+    character(len = *), intent(in) :: name
+    integer(kind = FourByteInt), intent(in) :: values
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_att(ncid, varid, name, values)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_att_one_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_att_one_FourByteInt
+
+end module nf95_put_att_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_put_var_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_put_var_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/nf95_put_var_m.F90	(revision 17)
@@ -0,0 +1,335 @@
+! $Id$
+module nf95_put_var_m
+
+  implicit none
+
+  interface nf95_put_var
+     module procedure nf95_put_var_FourByteReal, nf95_put_var_FourByteInt, &
+          nf95_put_var_1D_FourByteReal, nf95_put_var_1D_FourByteInt, &
+          nf95_put_var_2D_FourByteReal, nf95_put_var_3D_FourByteReal, &
+          nf95_put_var_4D_FourByteReal
+  end interface
+
+  private
+  public nf95_put_var
+
+contains
+
+  subroutine nf95_put_var_FourByteReal(ncid, varid, values, start, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer, intent(in) :: ncid, varid
+    real, intent(in) :: values
+    integer, dimension(:), optional, intent(in) :: start
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_FourByteInt(ncid, varid, values, start, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer, intent(in) :: ncid, varid
+    integer, intent(in) :: values
+    integer, dimension(:), optional, intent(in) :: start
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_FourByteInt
+
+  !***********************
+
+  subroutine nf95_put_var_1D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(in) :: values(:)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_1D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_1D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_1D_FourByteInt(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    integer, intent(in) :: values(:)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_1D_FourByteInt", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_1D_FourByteInt
+
+  !***********************
+
+  subroutine nf95_put_var_1D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: eightByteReal
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal),     intent(in) :: values(:)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_1D_eightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_1D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_2D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(in) :: values(:, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_2D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_2D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_2D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal), intent(in) :: values(:, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_2D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_2D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_3D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(in) :: values(:, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_3D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_3D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_3D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: eightByteReal
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real (kind = EightByteReal),     intent(in) :: values(:, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_3D_eightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_3D_EightByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_4D_FourByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer,                         intent(in) :: ncid, varid
+    real, intent(in) :: values(:, :, :, :)
+    integer, dimension(:), optional, intent(in) :: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_4D_FourByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_4D_FourByteReal
+
+  !***********************
+
+  subroutine nf95_put_var_4D_EightByteReal(ncid, varid, values, start, &
+       count_nc, stride, map, ncerr)
+
+    use typesizes, only: EightByteReal
+    use netcdf, only: nf90_put_var
+    use handle_err_m, only: handle_err
+
+    integer, intent(in):: ncid, varid
+    real(kind = EightByteReal), intent(in):: values(:, :, :, :)
+    integer, dimension(:), optional, intent(in):: start, count_nc, stride, map
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_put_var(ncid, varid, values, start, count_nc, &
+         stride, map)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_put_var_4D_EightByteReal", ncerr_not_opt, ncid, &
+            varid)
+    end if
+
+  end subroutine nf95_put_var_4D_EightByteReal
+
+end module nf95_put_var_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/nflxtr.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/nflxtr.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/nflxtr.F90	(revision 17)
@@ -0,0 +1,159 @@
+!
+! $Id $
+!
+SUBROUTINE nflxtr(pdtime,pmfu,pmfd,pen_u,pde_u,pen_d,pde_d,pplay,paprs,x,dx) 
+  USE dimphy
+  IMPLICIT NONE 
+!=====================================================================
+! Objet : Melange convectif de traceurs a partir des flux de masse 
+! Date : 13/12/1996 -- 13/01/97
+! Auteur: O. Boucher (LOA) sur inspiration de Z. X. Li (LMD),
+!         Brinkop et Sausen (1996) et Boucher et al. (1996).
+! ATTENTION : meme si cette routine se veut la plus generale possible, 
+!             elle a herite de certaines notations et conventions du 
+!             schema de Tiedtke (1993).
+! 1. En particulier, les couches sont numerotees de haut en bas !!!
+!    Ceci est valable pour les flux
+!    mais pas pour les entrees x, pplay, paprs !!!!
+! 2. pmfu est positif, pmfd est negatif 
+! 3. Tous les flux d'entrainements et de detrainements sont positifs 
+!    contrairement au schema de Tiedtke d'ou les changements de signe!!!! 
+!=====================================================================
+!
+  include "YOMCST.h"
+  include "YOECUMF.h" 
+
+  REAL,INTENT(IN) :: pdtime  ! pdtphys
+!
+! les flux sont definis au 1/2 niveaux 
+! => pmfu(klev+1) et pmfd(klev+1) sont implicitement nuls
+!
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu  ! flux de masse dans le panache montant 
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfd  ! flux de masse dans le panache descendant
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_u ! flux entraine dans le panache montant
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_u ! flux detraine dans le panache montant
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_d ! flux entraine dans le panache descendant
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_d ! flux detraine dans le panache descendant
+
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay ! pression aux couches (bas en haut)
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs ! pression aux 1/2 couches (bas en haut)
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: x     ! q de traceur (bas en haut) 
+  REAL,DIMENSION(klon,klev),INTENT(INOUT) :: dx   ! tendance de traceur  (bas en haut)
+
+! flux convectifs mais en variables locales
+  REAL,DIMENSION(klon,klev+1) :: zmfu  ! copie de pmfu avec klev+1 = 0
+  REAL,DIMENSION(klon,klev+1) :: zmfd  ! copie de pmfd avec klev+1 = 0
+  REAL,DIMENSION(klon,klev)   :: zen_u
+  REAL,DIMENSION(klon,klev)   :: zde_u
+  REAL,DIMENSION(klon,klev)   :: zen_d
+  REAL,DIMENSION(klon,klev)   :: zde_d
+  REAL                        :: zmfe
+
+! variables locales      
+! les flux de x sont definis aux 1/2 niveaux 
+! xu et xd sont definis aux niveaux complets
+  REAL,DIMENSION(klon,klev)   :: xu      ! q de traceurs dans le panache montant
+  REAL,DIMENSION(klon,klev)   :: xd      ! q de traceurs dans le panache descendant
+  REAL,DIMENSION(klon,klev+1) :: zmfux   ! flux de x dans le panache montant
+  REAL,DIMENSION(klon,klev+1) :: zmfdx   ! flux de x dans le panache descendant
+  REAL,DIMENSION(klon,klev+1) :: zmfex   ! flux de x dans l'environnement 
+  INTEGER                     :: i, k 
+  REAL,PARAMETER              :: zmfmin=1.E-10
+
+! ==============================================
+! Extension des flux UP et DN sur klev+1 niveaux
+! ==============================================
+  DO k=1,klev
+     DO i=1,klon
+        zmfu(i,k)=pmfu(i,k)
+        zmfd(i,k)=pmfd(i,k)
+     ENDDO
+  ENDDO
+  DO i=1,klon
+     zmfu(i,klev+1)=0.
+     zmfd(i,klev+1)=0.
+  ENDDO
+! ==========================================
+! modif pour diagnostiquer les detrainements
+! ==========================================
+!   on privilegie l'ajustement de l'entrainement dans l'ascendance.
+
+  DO k=1, klev
+     DO i=1, klon
+        zen_d(i,k)=pen_d(i,k)
+        zde_u(i,k)=pde_u(i,k)
+        zde_d(i,k) =-zmfd(i,k+1)+zmfd(i,k)+zen_d(i,k)
+        zen_u(i,k) = zmfu(i,k+1)-zmfu(i,k)+zde_u(i,k)
+     ENDDO
+  ENDDO
+! =========================================
+! calcul des flux dans le panache montant
+! =========================================
+!
+! Dans la premiere couche, on prend q comme valeur de qu
+
+  DO i=1, klon
+     zmfux(i,1)=0.0 
+  ENDDO
+
+! Autres couches
+  DO k=1,klev
+     DO i=1, klon
+        IF ((zmfu(i,k+1)+zde_u(i,k)).lt.zmfmin) THEN
+           xu(i,k)=x(i,k)
+        ELSE
+           xu(i,k)=(zmfux(i,k)+zen_u(i,k)*x(i,k))/(zmfu(i,k+1)+zde_u(i,k))
+        ENDIF
+        zmfux(i,k+1)=zmfu(i,k+1)*xu(i,k)
+     ENDDO
+  ENDDO
+! ==========================================
+! calcul des flux dans le panache descendant
+! ==========================================
+   
+  DO i=1, klon
+     zmfdx(i,klev+1)=0.0 
+  ENDDO
+
+  DO k=klev,1,-1
+     DO i=1, klon
+        IF ((zde_d(i,k)-zmfd(i,k)).lt.zmfmin) THEN
+           xd(i,k)=x(i,k)
+        ELSE
+           xd(i,k)=(zmfdx(i,k+1)-zen_d(i,k)*x(i,k))/(zmfd(i,k)-zde_d(i,k))
+        ENDIF
+        zmfdx(i,k)=zmfd(i,k)*xd(i,k)
+     ENDDO
+  ENDDO
+! ===================================================
+! introduction du flux de retour dans l'environnement
+! ===================================================
+
+  DO k=2, klev
+     DO i=1, klon
+        zmfe=-zmfu(i,k)-zmfd(i,k)
+        IF (zmfe.le.0.) then
+           zmfex(i,k)= zmfe*x(i,k)
+        ELSE
+           zmfex(i,k)= zmfe*x(i,k-1)
+        ENDIF
+     ENDDO
+  ENDDO
+
+  DO i=1, klon
+     zmfex(i,1)=0.
+     zmfex(i,klev+1)=0.
+  ENDDO
+! ==========================
+! calcul final des tendances
+! ==========================
+  DO k=1, klev
+     DO i=1, klon
+        dx(i,k)=RG/(paprs(i,k)-paprs(i,k+1))*pdtime*  &
+             ( zmfux(i,k) - zmfux(i,k+1) +            &
+             zmfdx(i,k) - zmfdx(i,k+1) +              &
+             zmfex(i,k) - zmfex(i,k+1) )
+     ENDDO
+  ENDDO
+  
+END SUBROUTINE nflxtr
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/nuage.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/nuage.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/nuage.F	(revision 17)
@@ -0,0 +1,408 @@
+! $Id: nuage.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      SUBROUTINE nuage (paprs, pplay,
+     .                  t, pqlwp, pclc, pcltau, pclemi,
+     .                  pch, pcl, pcm, pct, pctlwp,
+     e                  ok_aie,
+     e                  mass_solu_aero, mass_solu_aero_pi, 
+     e                  bl95_b0, bl95_b1,
+     s                  cldtaupi, re, fl)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+c Objet: Calculer epaisseur optique et emmissivite des nuages
+c======================================================================
+c Arguments:
+c t-------input-R-temperature
+c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
+c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+c ok_aie--input-L-apply aerosol indirect effect or not
+c mass_solu_aero-----input-R-total mass concentration for all soluble aerosols[ug/m^3]
+c mass_solu_aero_pi--input-R-dito, pre-industrial value
+c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land)
+c bl95_b1-input-R-a parameter, may be varied for tests (    -"-      )
+c      
+c cldtaupi-output-R-pre-industrial value of cloud optical thickness, 
+c                   needed for the diagnostics of the aerosol indirect 
+c                   radiative forcing (see radlwsw)
+c re------output-R-Cloud droplet effective radius multiplied by fl [um]
+c fl------output-R-Denominator to re, introduced to avoid problems in
+c                  the averaging of the output. fl is the fraction of liquid
+c                  water clouds within a grid cell      
+c 
+c pcltau--output-R-epaisseur optique des nuages
+c pclemi--output-R-emissivite des nuages (0 a 1)
+c======================================================================
+C
+#include "YOMCST.h"
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+c
+      REAL pclc(klon,klev)
+      REAL pqlwp(klon,klev)
+      REAL pcltau(klon,klev), pclemi(klon,klev)
+c
+      REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
+c
+      LOGICAL lo
+c
+      REAL cetahb, cetamb
+      PARAMETER (cetahb = 0.45, cetamb = 0.80)
+C
+      INTEGER i, k
+      REAL zflwp, zradef, zfice, zmsac
+c
+      REAL radius, rad_froid, rad_chaud, rad_chau1, rad_chau2
+      PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
+ccc      PARAMETER (rad_chaud=15.0, rad_froid=35.0)
+c sintex initial      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
+      REAL coef, coef_froi, coef_chau
+      PARAMETER (coef_chau=0.13, coef_froi=0.09)
+      REAL seuil_neb, t_glace
+      PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      PARAMETER (nexpo=6)
+      
+cjq for the aerosol indirect effect
+cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+cjq      
+      LOGICAL ok_aie            ! Apply AIE or not?
+      
+      REAL mass_solu_aero(klon, klev)    ! total mass concentration for all soluble aerosols[ug m-3]
+      REAL mass_solu_aero_pi(klon, klev) ! - " - pre-industrial value
+      REAL cdnc(klon, klev)     ! cloud droplet number concentration [m-3]
+      REAL re(klon, klev)       ! cloud droplet effective radius [um]
+      REAL cdnc_pi(klon, klev)     ! cloud droplet number concentration [m-3] (pi value)
+      REAL re_pi(klon, klev)       ! cloud droplet effective radius [um] (pi value)
+      
+      REAL fl(klon, klev)  ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell)
+      
+      REAL bl95_b0, bl95_b1     ! Parameter in B&L 95-Formula
+      
+      REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag
+cjq-end      
+      
+ccc      PARAMETER (nexpo=1)
+c
+c Calculer l'epaisseur optique et l'emmissivite des nuages
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         rad_chaud = rad_chau1
+         IF (k.LE.3) rad_chaud = rad_chau2
+            
+         pclc(i,k) = MAX(pclc(i,k), seuil_neb)
+         zflwp = 1000.*pqlwp(i,k)/RG/pclc(i,k)
+     .          *(paprs(i,k)-paprs(i,k+1))
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+         zfice = zfice**nexpo
+         
+         IF (ok_aie) THEN
+            ! Formula "D" of Boucher and Lohmann, Tellus, 1995
+            !             
+            cdnc(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(mass_solu_aero(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            ! Cloud droplet number concentration (CDNC) is restricted
+            ! to be within [20, 1000 cm^3]
+            ! 
+            cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k)))
+            cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1*
+     .           log(MAX(mass_solu_aero_pi(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k)))
+            !            
+            !
+            ! air density: pplay(i,k) / (RD * zT(i,k)) 
+            ! factor 1.1: derive effective radius from volume-mean radius
+            ! factor 1000 is the water density
+            ! _chaud means that this is the CDR for liquid water clouds
+            !
+            rad_chaud = 
+     .           1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) )  
+     .               / (4./3. * RPI * 1000. * cdnc(i,k)) )**(1./3.)
+            !
+            ! Convert to um. CDR shall be at least 3 um.
+            !
+            rad_chaud = MAX(rad_chaud*1.e6, 3.) 
+            
+            ! For output diagnostics
+            !
+            ! Cloud droplet effective radius [um]
+            !
+            ! we multiply here with f * xl (fraction of liquid water
+            ! clouds in the grid cell) to avoid problems in the
+            ! averaging of the output.
+            ! In the output of IOIPSL, derive the real cloud droplet 
+            ! effective radius as re/fl
+            !
+            fl(i,k) = pclc(i,k)*(1.-zfice)            
+            re(i,k) = rad_chaud*fl(i,k)
+            
+            ! Pre-industrial cloud opt thickness
+            !
+            ! "radius" is calculated as rad_chaud above (plus the 
+            ! ice cloud contribution) but using cdnc_pi instead of
+            ! cdnc.
+            radius = MAX(1.1e6 * ( (pqlwp(i,k)*pplay(i,k)/(RD*T(i,k)))  
+     .                / (4./3.*RPI*1000.*cdnc_pi(i,k)) )**(1./3.), 
+     .               3.) * (1.-zfice) + rad_froid * zfice           
+            cldtaupi(i,k) = 3.0/2.0 * zflwp / radius
+     .           
+         ENDIF                  ! ok_aie
+         
+         radius = rad_chaud * (1.-zfice) + rad_froid * zfice
+         coef = coef_chau * (1.-zfice) + coef_froi * zfice
+         pcltau(i,k) = 3.0/2.0 * zflwp / radius
+         pclemi(i,k) = 1.0 - EXP( - coef * zflwp)
+         lo = (pclc(i,k) .LE. seuil_neb)
+         IF (lo) pclc(i,k) = 0.0
+         IF (lo) pcltau(i,k) = 0.0
+         IF (lo) pclemi(i,k) = 0.0
+         
+         IF (.NOT.ok_aie) cldtaupi(i,k)=pcltau(i,k)            
+      ENDDO
+      ENDDO
+ccc      DO k = 1, klev
+ccc      DO i = 1, klon
+ccc         t(i,k) = t(i,k)
+ccc         pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
+ccc         lo = pclc(i,k) .GT. (2.*1.e-5)
+ccc         zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1))
+ccc     .          /(rg*pclc(i,k))
+ccc         zradef = 10.0 + (1.-sigs(k))*45.0
+ccc         pcltau(i,k) = 1.5 * zflwp / zradef
+ccc         zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
+ccc         zmsac = 0.13*(1.0-zfice) + 0.08*zfice
+ccc         pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
+ccc         if (.NOT.lo) pclc(i,k) = 0.0
+ccc         if (.NOT.lo) pcltau(i,k) = 0.0
+ccc         if (.NOT.lo) pclemi(i,k) = 0.0
+ccc      ENDDO
+ccc      ENDDO
+cccccc      print*, 'pas de nuage dans le rayonnement'
+cccccc      DO k = 1, klev
+cccccc      DO i = 1, klon
+cccccc         pclc(i,k) = 0.0
+cccccc         pcltau(i,k) = 0.0
+cccccc         pclemi(i,k) = 0.0
+cccccc      ENDDO
+cccccc      ENDDO
+C
+C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+C
+      DO i = 1, klon
+         pct(i)=1.0
+         pch(i)=1.0
+         pcm(i) = 1.0
+         pcl(i) = 1.0
+         pctlwp(i) = 0.0
+      ENDDO
+C
+      DO k = klev, 1, -1
+      DO i = 1, klon
+         pctlwp(i) = pctlwp(i) 
+     .             + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+         pct(i) = pct(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).LE.cetahb*paprs(i,1))
+     .      pch(i) = pch(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.
+     .       pplay(i,k).LE.cetamb*paprs(i,1)) 
+     .      pcm(i) = pcm(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetamb*paprs(i,1))
+     .      pcl(i) = pcl(i)*(1.0-pclc(i,k))
+      ENDDO
+      ENDDO
+C
+      DO i = 1, klon
+         pct(i)=1.-pct(i)
+         pch(i)=1.-pch(i)
+         pcm(i)=1.-pcm(i)
+         pcl(i)=1.-pcl(i)
+      ENDDO
+C
+      RETURN
+      END
+      SUBROUTINE diagcld1(paprs,pplay,rain,snow,kbot,ktop,
+     .                   diafra,dialiq)
+      use dimphy
+      IMPLICIT none
+c
+c Laurent Li (LMD/CNRS), le 12 octobre 1998
+c                        (adaptation du code ECMWF)
+c
+c Dans certains cas, le schema pronostique des nuages n'est
+c pas suffisament performant. On a donc besoin de diagnostiquer
+c ces nuages. Je dois avouer que c'est une frustration.
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments d'entree:
+      REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche
+      REAL pplay(klon,klev) ! pression (Pa) au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (Kg/Kg)
+      REAL rain(klon) ! pluie convective (kg/m2/s)
+      REAL snow(klon) ! neige convective (kg/m2/s)
+      INTEGER ktop(klon) ! sommet de la convection
+      INTEGER kbot(klon) ! bas de la convection
+c
+c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+c
+c Constantes ajustables:
+      REAL CANVA, CANVB, CANVH
+      PARAMETER (CANVA=2.0, CANVB=0.3, CANVH=0.4)
+      REAL CCA, CCB, CCC
+      PARAMETER (CCA=0.125, CCB=1.5, CCC=0.8)
+      REAL CCFCT, CCSCAL
+      PARAMETER (CCFCT=0.400)
+      PARAMETER (CCSCAL=1.0E+11)
+      REAL CETAHB, CETAMB
+      PARAMETER (CETAHB=0.45, CETAMB=0.80)
+      REAL CCLWMR
+      PARAMETER (CCLWMR=1.E-04)
+      REAL ZEPSCR
+      PARAMETER (ZEPSCR=1.0E-10)
+c
+c Variables locales:
+      INTEGER i, k
+      REAL zcc(klon)
+c
+c Initialisation:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         diafra(i,k) = 0.0
+         dialiq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon ! Calculer la fraction nuageuse
+      zcc(i) = 0.0
+      IF((rain(i)+snow(i)).GT.0.) THEN
+         zcc(i)= CCA * LOG(MAX(ZEPSCR,(rain(i)+snow(i))*CCSCAL))-CCB
+         zcc(i)= MIN(CCC,MAX(0.0,zcc(i)))
+      ENDIF
+      ENDDO
+c
+      DO i = 1, klon ! pour traiter les enclumes
+      diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),zcc(i)*CCFCT)
+      IF ((zcc(i).GE.CANVH) .AND.
+     .    (pplay(i,ktop(i)).LE.CETAHB*paprs(i,1)))
+     . diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),
+     .                         MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB)))
+      dialiq(i,ktop(i))=CCLWMR*diafra(i,ktop(i))
+      ENDDO
+c
+      DO k = 1, klev ! nuages convectifs (sauf enclumes)
+      DO i = 1, klon
+      IF (k.LT.ktop(i) .AND. k.GE.kbot(i)) THEN
+         diafra(i,k)=MAX(diafra(i,k),zcc(i)*CCFCT)
+         dialiq(i,k)=CCLWMR*diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE diagcld2(paprs,pplay,t,q, diafra,dialiq)
+      use dimphy
+      IMPLICIT none
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments d'entree:
+      REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche
+      REAL pplay(klon,klev) ! pression (Pa) au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (Kg/Kg)
+c
+c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+c
+      REAL CETAMB
+      PARAMETER (CETAMB=0.80)
+      REAL CLOIA, CLOIB, CLOIC, CLOID
+      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.6, CLOID=5.0)
+ccc      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0)
+      REAL RGAMMAS
+      PARAMETER (RGAMMAS=0.05)
+      REAL CRHL
+      PARAMETER (CRHL=0.15)
+ccc      PARAMETER (CRHL=0.70)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+c
+c Variables locales:
+      INTEGER i, k, kb, invb(klon)
+      REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp
+      REAL zdelta, zcor
+c
+c Fonctions thermodynamiques:
+#include "YOETHF.h"
+#include "FCTTRE.h"
+c
+c Initialisation:
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         diafra(i,k) = 0.0
+         dialiq(i,k) = 0.0
+      ENDDO
+      ENDDO
+c
+      DO i = 1, klon
+         invb(i) = klev
+         zdthmin(i)=0.0
+      ENDDO
+
+      DO k = 2, klev/2-1
+      DO i = 1, klon
+         zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1))
+     .          - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+         zdthdp = zdthdp * CLOIA
+         IF (pplay(i,k).GT.CETAMB*paprs(i,1) .AND.
+     .       zdthdp.LT.zdthmin(i) ) THEN
+            zdthmin(i) = zdthdp
+            invb(i) = k
+         ENDIF
+      ENDDO
+      ENDDO
+
+      DO i = 1, klon
+         kb=invb(i)
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-t(i,kb)))
+           zqs= R2ES*FOEEW(t(i,kb),zdelta)/pplay(i,kb)
+           zqs=MIN(0.5,zqs)
+           zcor=1./(1.-RETV*zqs)
+           zqs=zqs*zcor
+         ELSE
+           IF (t(i,kb) .LT. t_coup) THEN
+              zqs = qsats(t(i,kb)) / pplay(i,kb)
+           ELSE
+              zqs = qsatl(t(i,kb)) / pplay(i,kb)
+           ENDIF
+         ENDIF
+         zcll = CLOIB * zdthmin(i) + CLOIC
+         zcll = MIN(1.0,MAX(0.0,zcll))
+         zrhb= q(i,kb)/zqs
+         IF (zcll.GT.0.0.AND.zrhb.LT.CRHL)
+     .   zcll=zcll*(1.-(CRHL-zrhb)*CLOID)
+         zcll=MIN(1.0,MAX(0.0,zcll))
+         diafra(i,kb) = MAX(diafra(i,kb),zcll)
+         dialiq(i,kb)= diafra(i,kb) * RGAMMAS*zqs
+      ENDDO
+c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/nuage.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/nuage.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/nuage.F90	(revision 17)
@@ -0,0 +1,410 @@
+! $Id: nuage.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+      SUBROUTINE nuage (paprs, pplay,                                                &
+       &                  t, pqlwp, pclc, pcltau, pclemi,                            &
+       &                  pch, pcl, pcm, pct, pctlwp,                                &
+       &                  ok_aie,                                                    &
+       &                  mass_solu_aero, mass_solu_aero_pi,                         &
+       &                  bl95_b0, bl95_b1,                                          &
+       &                  cldtaupi, re, fl)
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+!c Objet: Calculer epaisseur optique et emmissivite des nuages
+!c======================================================================
+!c Arguments:
+!c t-------input-R-temperature
+!c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
+!c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+!c ok_aie--input-L-apply aerosol indirect effect or not
+!c mass_solu_aero-----input-R-total mass concentration for all soluble aerosols[ug/m^3]
+!c mass_solu_aero_pi--input-R-dito, pre-industrial value
+!c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land)
+!c bl95_b1-input-R-a parameter, may be varied for tests (    -"-      )
+!c      
+!c cldtaupi-output-R-pre-industrial value of cloud optical thickness, 
+!c                   needed for the diagnostics of the aerosol indirect 
+!c                   radiative forcing (see radlwsw)
+!c re------output-R-Cloud droplet effective radius multiplied by fl [um]
+!c fl------output-R-Denominator to re, introduced to avoid problems in
+!c                  the averaging of the output. fl is the fraction of liquid
+!c                  water clouds within a grid cell      
+!c 
+!c pcltau--output-R-epaisseur optique des nuages
+!c pclemi--output-R-emissivite des nuages (0 a 1)
+!c======================================================================
+!C
+#include "YOMCST.h"
+!c
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+!c
+      REAL pclc(klon,klev)
+      REAL pqlwp(klon,klev)
+      REAL pcltau(klon,klev), pclemi(klon,klev)
+!c
+      REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
+!c
+      LOGICAL lo
+!c
+      REAL cetahb, cetamb
+      PARAMETER (cetahb = 0.45, cetamb = 0.80)
+!C
+      INTEGER i, k
+      REAL zflwp, zradef, zfice, zmsac
+!c
+      REAL radius, rad_froid, rad_chaud, rad_chau1, rad_chau2
+      PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
+!ccc      PARAMETER (rad_chaud=15.0, rad_froid=35.0)
+!c sintex initial      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
+      REAL coef, coef_froi, coef_chau
+      PARAMETER (coef_chau=0.13, coef_froi=0.09)
+      REAL seuil_neb, t_glace
+      PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      PARAMETER (nexpo=6)
+      
+!cjq for the aerosol indirect effect
+!cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+!cjq      
+      LOGICAL ok_aie            ! Apply AIE or not?
+      
+      REAL mass_solu_aero(klon, klev)    ! total mass concentration for all soluble aerosols[ug m-3]
+      REAL mass_solu_aero_pi(klon, klev) ! - " - pre-industrial value
+      REAL cdnc(klon, klev)     ! cloud droplet number concentration [m-3]
+      REAL re(klon, klev)       ! cloud droplet effective radius [um]
+      REAL cdnc_pi(klon, klev)     ! cloud droplet number concentration [m-3] (pi value)
+      REAL re_pi(klon, klev)       ! cloud droplet effective radius [um] (pi value)
+      
+      REAL fl(klon, klev)  ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell)
+      
+      REAL bl95_b0, bl95_b1     ! Parameter in B&L 95-Formula
+      
+      REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag
+!cjq-end      
+      
+!ccc      PARAMETER (nexpo=1)
+!c
+!c Calculer l'epaisseur optique et l'emmissivite des nuages
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         rad_chaud = rad_chau1
+         IF (k.LE.3) rad_chaud = rad_chau2
+            
+         pclc(i,k) = MAX(pclc(i,k), seuil_neb)
+         zflwp = 1000.*pqlwp(i,k)/RG/pclc(i,k)                                       &
+       &          *(paprs(i,k)-paprs(i,k+1))
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+         zfice = zfice**nexpo
+         
+         IF (ok_aie) THEN
+            ! Formula "D" of Boucher and Lohmann, Tellus, 1995
+            !             
+            cdnc(i,k) = 10.**(bl95_b0+bl95_b1*                                       &
+       &           log(MAX(mass_solu_aero(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            ! Cloud droplet number concentration (CDNC) is restricted
+            ! to be within [20, 1000 cm^3]
+            ! 
+            cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k)))
+            cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1*                                    &
+       &           log(MAX(mass_solu_aero_pi(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k)))
+            !            
+            !
+            ! air density: pplay(i,k) / (RD * zT(i,k)) 
+            ! factor 1.1: derive effective radius from volume-mean radius
+            ! factor 1000 is the water density
+            ! _chaud means that this is the CDR for liquid water clouds
+            !
+            rad_chaud =                                                              &
+       &           1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) )                &
+       &               / (4./3. * RPI * 1000. * cdnc(i,k)) )**(1./3.)
+            !
+            ! Convert to um. CDR shall be at least 3 um.
+            !
+            rad_chaud = MAX(rad_chaud*1.e6, 3.) 
+            
+            ! For output diagnostics
+            !
+            ! Cloud droplet effective radius [um]
+            !
+            ! we multiply here with f * xl (fraction of liquid water
+            ! clouds in the grid cell) to avoid problems in the
+            ! averaging of the output.
+            ! In the output of IOIPSL, derive the real cloud droplet 
+            ! effective radius as re/fl
+            !
+            fl(i,k) = pclc(i,k)*(1.-zfice)            
+            re(i,k) = rad_chaud*fl(i,k)
+            
+            ! Pre-industrial cloud opt thickness
+            !
+            ! "radius" is calculated as rad_chaud above (plus the 
+            ! ice cloud contribution) but using cdnc_pi instead of
+            ! cdnc.
+            radius = MAX(1.1e6 * ( (pqlwp(i,k)*pplay(i,k)/(RD*T(i,k)))               &
+       &                / (4./3.*RPI*1000.*cdnc_pi(i,k)) )**(1./3.),                 &
+       &               3.) * (1.-zfice) + rad_froid * zfice           
+            cldtaupi(i,k) = 3.0/2.0 * zflwp / radius                                 &
+       &           
+         ENDIF                  ! ok_aie
+         
+         radius = rad_chaud * (1.-zfice) + rad_froid * zfice
+         coef = coef_chau * (1.-zfice) + coef_froi * zfice
+         pcltau(i,k) = 3.0/2.0 * zflwp / radius
+         pclemi(i,k) = 1.0 - EXP( - coef * zflwp)
+         lo = (pclc(i,k) .LE. seuil_neb)
+         IF (lo) pclc(i,k) = 0.0
+         IF (lo) pcltau(i,k) = 0.0
+         IF (lo) pclemi(i,k) = 0.0
+         
+         IF (.NOT.ok_aie) cldtaupi(i,k)=pcltau(i,k)            
+      ENDDO
+      ENDDO
+!ccc      DO k = 1, klev
+!ccc      DO i = 1, klon
+!ccc         t(i,k) = t(i,k)
+!ccc         pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
+!ccc         lo = pclc(i,k) .GT. (2.*1.e-5)
+!ccc         zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1))
+!ccc     .          /(rg*pclc(i,k))
+!ccc         zradef = 10.0 + (1.-sigs(k))*45.0
+!ccc         pcltau(i,k) = 1.5 * zflwp / zradef
+!ccc         zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
+!ccc         zmsac = 0.13*(1.0-zfice) + 0.08*zfice
+!ccc         pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
+!ccc         if (.NOT.lo) pclc(i,k) = 0.0
+!ccc         if (.NOT.lo) pcltau(i,k) = 0.0
+!ccc         if (.NOT.lo) pclemi(i,k) = 0.0
+!ccc      ENDDO
+!ccc      ENDDO
+!cccccc      print*, 'pas de nuage dans le rayonnement'
+!cccccc      DO k = 1, klev
+!cccccc      DO i = 1, klon
+!cccccc         pclc(i,k) = 0.0
+!cccccc         pcltau(i,k) = 0.0
+!cccccc         pclemi(i,k) = 0.0
+!cccccc      ENDDO
+!cccccc      ENDDO
+!C
+!C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+!C
+      DO i = 1, klon
+         pct(i)=1.0
+         pch(i)=1.0
+         pcm(i) = 1.0
+         pcl(i) = 1.0
+         pctlwp(i) = 0.0
+      ENDDO
+!C
+      DO k = klev, 1, -1
+      DO i = 1, klon
+         pctlwp(i) = pctlwp(i)                                                       &
+       &             + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+         pct(i) = pct(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).LE.cetahb*paprs(i,1))                                        &
+       &      pch(i) = pch(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.                                   &
+       &       pplay(i,k).LE.cetamb*paprs(i,1))                                      &
+       &      pcm(i) = pcm(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetamb*paprs(i,1))                                        &
+       &      pcl(i) = pcl(i)*(1.0-pclc(i,k))
+      ENDDO
+      ENDDO
+!C
+      DO i = 1, klon
+         pct(i)=1.-pct(i)
+         pch(i)=1.-pch(i)
+         pcm(i)=1.-pcm(i)
+         pcl(i)=1.-pcl(i)
+      ENDDO
+!C
+      RETURN
+      END SUBROUTINE nuage
+
+      SUBROUTINE diagcld1(paprs,pplay,rain,snow,kbot,ktop,                           &
+       &                   diafra,dialiq)
+      use dimphy
+      IMPLICIT none
+!c
+!c Laurent Li (LMD/CNRS), le 12 octobre 1998
+!c                        (adaptation du code ECMWF)
+!c
+!c Dans certains cas, le schema pronostique des nuages n'est
+!c pas suffisament performant. On a donc besoin de diagnostiquer
+!c ces nuages. Je dois avouer que c'est une frustration.
+!c
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c
+!c Arguments d'entree:
+      REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche
+      REAL pplay(klon,klev) ! pression (Pa) au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (Kg/Kg)
+      REAL rain(klon) ! pluie convective (kg/m2/s)
+      REAL snow(klon) ! neige convective (kg/m2/s)
+      INTEGER ktop(klon) ! sommet de la convection
+      INTEGER kbot(klon) ! bas de la convection
+!c
+!c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+!c
+!c Constantes ajustables:
+      REAL CANVA, CANVB, CANVH
+      PARAMETER (CANVA=2.0, CANVB=0.3, CANVH=0.4)
+      REAL CCA, CCB, CCC
+      PARAMETER (CCA=0.125, CCB=1.5, CCC=0.8)
+      REAL CCFCT, CCSCAL
+      PARAMETER (CCFCT=0.400)
+      PARAMETER (CCSCAL=1.0E+11)
+      REAL CETAHB, CETAMB
+      PARAMETER (CETAHB=0.45, CETAMB=0.80)
+      REAL CCLWMR
+      PARAMETER (CCLWMR=1.E-04)
+      REAL ZEPSCR
+      PARAMETER (ZEPSCR=1.0E-10)
+!c
+!c Variables locales:
+      INTEGER i, k
+      REAL zcc(klon)
+!c
+!c Initialisation:
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         diafra(i,k) = 0.0
+         dialiq(i,k) = 0.0
+      ENDDO
+      ENDDO
+!c
+      DO i = 1, klon ! Calculer la fraction nuageuse
+      zcc(i) = 0.0
+      IF((rain(i)+snow(i)).GT.0.) THEN
+         zcc(i)= CCA * LOG(MAX(ZEPSCR,(rain(i)+snow(i))*CCSCAL))-CCB
+         zcc(i)= MIN(CCC,MAX(0.0,zcc(i)))
+      ENDIF
+      ENDDO
+!c
+      DO i = 1, klon ! pour traiter les enclumes
+      diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),zcc(i)*CCFCT)
+      IF ((zcc(i).GE.CANVH) .AND.                                                    &
+       &    (pplay(i,ktop(i)).LE.CETAHB*paprs(i,1)))                                 &
+       & diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),                                  &
+       &                         MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB)))
+      dialiq(i,ktop(i))=CCLWMR*diafra(i,ktop(i))
+      ENDDO
+!c
+      DO k = 1, klev ! nuages convectifs (sauf enclumes)
+      DO i = 1, klon
+      IF (k.LT.ktop(i) .AND. k.GE.kbot(i)) THEN
+         diafra(i,k)=MAX(diafra(i,k),zcc(i)*CCFCT)
+         dialiq(i,k)=CCLWMR*diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE diagcld1
+
+      SUBROUTINE diagcld2(paprs,pplay,t,q, diafra,dialiq)
+      use dimphy
+      IMPLICIT none
+!c
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c
+!c Arguments d'entree:
+      REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche
+      REAL pplay(klon,klev) ! pression (Pa) au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (Kg/Kg)
+!c
+!c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+!c
+      REAL CETAMB
+      PARAMETER (CETAMB=0.80)
+      REAL CLOIA, CLOIB, CLOIC, CLOID
+      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.6, CLOID=5.0)
+!ccc      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0)
+      REAL RGAMMAS
+      PARAMETER (RGAMMAS=0.05)
+      REAL CRHL
+      PARAMETER (CRHL=0.15)
+!ccc      PARAMETER (CRHL=0.70)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+!c
+!c Variables locales:
+      INTEGER i, k, kb, invb(klon)
+      REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp
+      REAL zdelta, zcor
+!c
+!c Fonctions thermodynamiques:
+#include "YOETHF.h"
+#include "FCTTRE.h"
+!c
+!c Initialisation:
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         diafra(i,k) = 0.0
+         dialiq(i,k) = 0.0
+      ENDDO
+      ENDDO
+!c
+      DO i = 1, klon
+         invb(i) = klev
+         zdthmin(i)=0.0
+      ENDDO
+
+      DO k = 2, klev/2-1
+      DO i = 1, klon
+         zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1))                        &
+       &          - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+         zdthdp = zdthdp * CLOIA
+         IF (pplay(i,k).GT.CETAMB*paprs(i,1) .AND.                                   &
+       &       zdthdp.LT.zdthmin(i) ) THEN
+            zdthmin(i) = zdthdp
+            invb(i) = k
+         ENDIF
+      ENDDO
+      ENDDO
+
+      DO i = 1, klon
+         kb=invb(i)
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-t(i,kb)))
+           zqs= R2ES*FOEEW(t(i,kb),zdelta)/pplay(i,kb)
+           zqs=MIN(0.5,zqs)
+           zcor=1./(1.-RETV*zqs)
+           zqs=zqs*zcor
+         ELSE
+           IF (t(i,kb) .LT. t_coup) THEN
+              zqs = qsats(t(i,kb)) / pplay(i,kb)
+           ELSE
+              zqs = qsatl(t(i,kb)) / pplay(i,kb)
+           ENDIF
+         ENDIF
+         zcll = CLOIB * zdthmin(i) + CLOIC
+         zcll = MIN(1.0,MAX(0.0,zcll))
+         zrhb= q(i,kb)/zqs
+         IF (zcll.GT.0.0.AND.zrhb.LT.CRHL)                                           &
+       &   zcll=zcll*(1.-(CRHL-zrhb)*CLOID)
+         zcll=MIN(1.0,MAX(0.0,zcll))
+         diafra(i,kb) = MAX(diafra(i,kb),zcll)
+         dialiq(i,kb)= diafra(i,kb) * RGAMMAS*zqs
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE diagcld2
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/nuage.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/nuage.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/nuage.h	(revision 17)
@@ -0,0 +1,9 @@
+!
+! $Id: nuage.h 1525 2011-05-25 10:55:27Z idelkadi $
+!
+      REAL rad_froid, rad_chau1, rad_chau2, t_glace_max, t_glace_min
+      REAL rei_min,rei_max
+
+      common /nuagecom/ rad_froid,rad_chau1, rad_chau2,t_glace_max,     &
+     &                  t_glace_min,rei_min,rei_max
+!$OMP THREADPRIVATE(/nuagecom/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/nuage_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/nuage_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/nuage_mod.F90	(revision 17)
@@ -0,0 +1,417 @@
+! $Id: nuage.F 1279 2009-12-10 09:02:56Z fairhead $
+!
+MODULE nuage_mod
+
+  CONTAINS
+
+      SUBROUTINE nuage (paprs, pplay,                                                &
+       &                  t, pqlwp, pclc, pcltau, pclemi,                            &
+       &                  pch, pcl, pcm, pct, pctlwp,                                &
+       &                  ok_aie,                                                    &
+       &                  mass_solu_aero, mass_solu_aero_pi,                         &
+       &                  bl95_b0, bl95_b1,                                          &
+       &                  cldtaupi, re, fl)
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930910
+!c Objet: Calculer epaisseur optique et emmissivite des nuages
+!c======================================================================
+!c Arguments:
+!c t-------input-R-temperature
+!c pqlwp---input-R-eau liquide nuageuse dans l'atmosphere (kg/kg)
+!c pclc----input-R-couverture nuageuse pour le rayonnement (0 a 1)
+!c ok_aie--input-L-apply aerosol indirect effect or not
+!c mass_solu_aero-----input-R-total mass concentration for all soluble aerosols[ug/m^3]
+!c mass_solu_aero_pi--input-R-dito, pre-industrial value
+!c bl95_b0-input-R-a parameter, may be varied for tests (s-sea, l-land)
+!c bl95_b1-input-R-a parameter, may be varied for tests (    -"-      )
+!c      
+!c cldtaupi-output-R-pre-industrial value of cloud optical thickness, 
+!c                   needed for the diagnostics of the aerosol indirect 
+!c                   radiative forcing (see radlwsw)
+!c re------output-R-Cloud droplet effective radius multiplied by fl [um]
+!c fl------output-R-Denominator to re, introduced to avoid problems in
+!c                  the averaging of the output. fl is the fraction of liquid
+!c                  water clouds within a grid cell      
+!c 
+!c pcltau--output-R-epaisseur optique des nuages
+!c pclemi--output-R-emissivite des nuages (0 a 1)
+!c======================================================================
+!C
+#include "YOMCST.h"
+!c
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+      REAL paprs(klon,klev+1), pplay(klon,klev)
+      REAL t(klon,klev)
+!c
+      REAL pclc(klon,klev)
+      REAL pqlwp(klon,klev)
+      REAL pcltau(klon,klev), pclemi(klon,klev)
+!c
+      REAL pct(klon), pctlwp(klon), pch(klon), pcl(klon), pcm(klon)
+!c
+      LOGICAL lo
+!c
+      REAL cetahb, cetamb
+      PARAMETER (cetahb = 0.45, cetamb = 0.80)
+!C
+      INTEGER i, k
+      REAL zflwp, zradef, zfice, zmsac
+!c
+      REAL radius, rad_froid, rad_chaud, rad_chau1, rad_chau2
+      PARAMETER (rad_chau1=13.0, rad_chau2=9.0, rad_froid=35.0)
+!ccc      PARAMETER (rad_chaud=15.0, rad_froid=35.0)
+!c sintex initial      PARAMETER (rad_chaud=10.0, rad_froid=30.0)
+      REAL coef, coef_froi, coef_chau
+      PARAMETER (coef_chau=0.13, coef_froi=0.09)
+      REAL seuil_neb, t_glace
+      PARAMETER (seuil_neb=0.001, t_glace=273.0-15.0)
+      INTEGER nexpo ! exponentiel pour glace/eau
+      PARAMETER (nexpo=6)
+      
+!cjq for the aerosol indirect effect
+!cjq introduced by Johannes Quaas (quaas@lmd.jussieu.fr), 27/11/2003
+!cjq      
+      LOGICAL ok_aie            ! Apply AIE or not?
+      
+      REAL mass_solu_aero(klon, klev)    ! total mass concentration for all soluble aerosols[ug m-3]
+      REAL mass_solu_aero_pi(klon, klev) ! - " - pre-industrial value
+      REAL cdnc(klon, klev)     ! cloud droplet number concentration [m-3]
+      REAL re(klon, klev)       ! cloud droplet effective radius [um]
+      REAL cdnc_pi(klon, klev)     ! cloud droplet number concentration [m-3] (pi value)
+      REAL re_pi(klon, klev)       ! cloud droplet effective radius [um] (pi value)
+      
+      REAL fl(klon, klev)  ! xliq * rneb (denominator to re; fraction of liquid water clouds within the grid cell)
+      
+      REAL bl95_b0, bl95_b1     ! Parameter in B&L 95-Formula
+      
+      REAL cldtaupi(klon, klev) ! pre-industrial cloud opt thickness for diag
+!cjq-end      
+      
+!ccc      PARAMETER (nexpo=1)
+!c
+!c Calculer l'epaisseur optique et l'emmissivite des nuages
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         rad_chaud = rad_chau1
+         IF (k.LE.3) rad_chaud = rad_chau2
+            
+         pclc(i,k) = MAX(pclc(i,k), seuil_neb)
+         zflwp = 1000.*pqlwp(i,k)/RG/pclc(i,k)                                       &
+       &          *(paprs(i,k)-paprs(i,k+1))
+         zfice = 1.0 - (t(i,k)-t_glace) / (273.13-t_glace)
+         zfice = MIN(MAX(zfice,0.0),1.0)
+         zfice = zfice**nexpo
+         
+         IF (ok_aie) THEN
+            ! Formula "D" of Boucher and Lohmann, Tellus, 1995
+            !             
+            cdnc(i,k) = 10.**(bl95_b0+bl95_b1*                                       &
+       &           log(MAX(mass_solu_aero(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            ! Cloud droplet number concentration (CDNC) is restricted
+            ! to be within [20, 1000 cm^3]
+            ! 
+            cdnc(i,k)=MIN(1000.e6,MAX(20.e6,cdnc(i,k)))
+            cdnc_pi(i,k) = 10.**(bl95_b0+bl95_b1*                                    &
+       &           log(MAX(mass_solu_aero_pi(i,k),1.e-4))/log(10.))*1.e6 !-m-3
+            cdnc_pi(i,k)=MIN(1000.e6,MAX(20.e6,cdnc_pi(i,k)))
+            !            
+            !
+            ! air density: pplay(i,k) / (RD * zT(i,k)) 
+            ! factor 1.1: derive effective radius from volume-mean radius
+            ! factor 1000 is the water density
+            ! _chaud means that this is the CDR for liquid water clouds
+            !
+            rad_chaud =                                                              &
+       &           1.1 * ( (pqlwp(i,k) * pplay(i,k) / (RD * T(i,k)) )                &
+       &               / (4./3. * RPI * 1000. * cdnc(i,k)) )**(1./3.)
+            !
+            ! Convert to um. CDR shall be at least 3 um.
+            !
+            rad_chaud = MAX(rad_chaud*1.e6, 3.) 
+            
+            ! For output diagnostics
+            !
+            ! Cloud droplet effective radius [um]
+            !
+            ! we multiply here with f * xl (fraction of liquid water
+            ! clouds in the grid cell) to avoid problems in the
+            ! averaging of the output.
+            ! In the output of IOIPSL, derive the real cloud droplet 
+            ! effective radius as re/fl
+            !
+            fl(i,k) = pclc(i,k)*(1.-zfice)            
+            re(i,k) = rad_chaud*fl(i,k)
+            
+            ! Pre-industrial cloud opt thickness
+            !
+            ! "radius" is calculated as rad_chaud above (plus the 
+            ! ice cloud contribution) but using cdnc_pi instead of
+            ! cdnc.
+            radius = MAX(1.1e6 * ( (pqlwp(i,k)*pplay(i,k)/(RD*T(i,k)))               &
+       &                / (4./3.*RPI*1000.*cdnc_pi(i,k)) )**(1./3.),                 &
+       &               3.) * (1.-zfice) + rad_froid * zfice           
+            cldtaupi(i,k) = 3.0/2.0 * zflwp / radius                                 &
+       &           
+         ENDIF                  ! ok_aie
+         
+         radius = rad_chaud * (1.-zfice) + rad_froid * zfice
+         coef = coef_chau * (1.-zfice) + coef_froi * zfice
+         pcltau(i,k) = 3.0/2.0 * zflwp / radius
+         pclemi(i,k) = 1.0 - EXP( - coef * zflwp)
+         lo = (pclc(i,k) .LE. seuil_neb)
+         IF (lo) pclc(i,k) = 0.0
+         IF (lo) pcltau(i,k) = 0.0
+         IF (lo) pclemi(i,k) = 0.0
+         
+         IF (.NOT.ok_aie) cldtaupi(i,k)=pcltau(i,k)            
+      ENDDO
+      ENDDO
+!ccc      DO k = 1, klev
+!ccc      DO i = 1, klon
+!ccc         t(i,k) = t(i,k)
+!ccc         pclc(i,k) = MAX( 1.e-5 , pclc(i,k) )
+!ccc         lo = pclc(i,k) .GT. (2.*1.e-5)
+!ccc         zflwp = pqlwp(i,k)*1000.*(paprs(i,k)-paprs(i,k+1))
+!ccc     .          /(rg*pclc(i,k))
+!ccc         zradef = 10.0 + (1.-sigs(k))*45.0
+!ccc         pcltau(i,k) = 1.5 * zflwp / zradef
+!ccc         zfice=1.0-MIN(MAX((t(i,k)-263.)/(273.-263.),0.0),1.0)
+!ccc         zmsac = 0.13*(1.0-zfice) + 0.08*zfice
+!ccc         pclemi(i,k) = 1.-EXP(-zmsac*zflwp)
+!ccc         if (.NOT.lo) pclc(i,k) = 0.0
+!ccc         if (.NOT.lo) pcltau(i,k) = 0.0
+!ccc         if (.NOT.lo) pclemi(i,k) = 0.0
+!ccc      ENDDO
+!ccc      ENDDO
+!cccccc      print*, 'pas de nuage dans le rayonnement'
+!cccccc      DO k = 1, klev
+!cccccc      DO i = 1, klon
+!cccccc         pclc(i,k) = 0.0
+!cccccc         pcltau(i,k) = 0.0
+!cccccc         pclemi(i,k) = 0.0
+!cccccc      ENDDO
+!cccccc      ENDDO
+!C
+!C COMPUTE CLOUD LIQUID PATH AND TOTAL CLOUDINESS
+!C
+      DO i = 1, klon
+         pct(i)=1.0
+         pch(i)=1.0
+         pcm(i) = 1.0
+         pcl(i) = 1.0
+         pctlwp(i) = 0.0
+      ENDDO
+!C
+      DO k = klev, 1, -1
+      DO i = 1, klon
+         pctlwp(i) = pctlwp(i)                                                       &
+       &             + pqlwp(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+         pct(i) = pct(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).LE.cetahb*paprs(i,1))                                        &
+       &      pch(i) = pch(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetahb*paprs(i,1) .AND.                                   &
+       &       pplay(i,k).LE.cetamb*paprs(i,1))                                      &
+       &      pcm(i) = pcm(i)*(1.0-pclc(i,k))
+         if (pplay(i,k).GT.cetamb*paprs(i,1))                                        &
+       &      pcl(i) = pcl(i)*(1.0-pclc(i,k))
+      ENDDO
+      ENDDO
+!C
+      DO i = 1, klon
+         pct(i)=1.-pct(i)
+         pch(i)=1.-pch(i)
+         pcm(i)=1.-pcm(i)
+         pcl(i)=1.-pcl(i)
+      ENDDO
+!C
+      RETURN
+      END SUBROUTINE nuage
+
+      SUBROUTINE diagcld1(paprs,pplay,rain,snow,kbot,ktop,                           &
+       &                   diafra,dialiq)
+      use dimphy
+      IMPLICIT none
+!c
+!c Laurent Li (LMD/CNRS), le 12 octobre 1998
+!c                        (adaptation du code ECMWF)
+!c
+!c Dans certains cas, le schema pronostique des nuages n'est
+!c pas suffisament performant. On a donc besoin de diagnostiquer
+!c ces nuages. Je dois avouer que c'est une frustration.
+!c
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c
+!c Arguments d'entree:
+      REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche
+      REAL pplay(klon,klev) ! pression (Pa) au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (Kg/Kg)
+      REAL rain(klon) ! pluie convective (kg/m2/s)
+      REAL snow(klon) ! neige convective (kg/m2/s)
+      INTEGER ktop(klon) ! sommet de la convection
+      INTEGER kbot(klon) ! bas de la convection
+!c
+!c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+!c
+!c Constantes ajustables:
+      REAL CANVA, CANVB, CANVH
+      PARAMETER (CANVA=2.0, CANVB=0.3, CANVH=0.4)
+      REAL CCA, CCB, CCC
+      PARAMETER (CCA=0.125, CCB=1.5, CCC=0.8)
+      REAL CCFCT, CCSCAL
+      PARAMETER (CCFCT=0.400)
+      PARAMETER (CCSCAL=1.0E+11)
+      REAL CETAHB, CETAMB
+      PARAMETER (CETAHB=0.45, CETAMB=0.80)
+      REAL CCLWMR
+      PARAMETER (CCLWMR=1.E-04)
+      REAL ZEPSCR
+      PARAMETER (ZEPSCR=1.0E-10)
+!c
+!c Variables locales:
+      INTEGER i, k
+      REAL zcc(klon)
+!c
+!c Initialisation:
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         diafra(i,k) = 0.0
+         dialiq(i,k) = 0.0
+      ENDDO
+      ENDDO
+!c
+      DO i = 1, klon ! Calculer la fraction nuageuse
+      zcc(i) = 0.0
+      IF((rain(i)+snow(i)).GT.0.) THEN
+         zcc(i)= CCA * LOG(MAX(ZEPSCR,(rain(i)+snow(i))*CCSCAL))-CCB
+         zcc(i)= MIN(CCC,MAX(0.0,zcc(i)))
+      ENDIF
+      ENDDO
+!c
+      DO i = 1, klon ! pour traiter les enclumes
+      diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),zcc(i)*CCFCT)
+      IF ((zcc(i).GE.CANVH) .AND.                                                    &
+       &    (pplay(i,ktop(i)).LE.CETAHB*paprs(i,1)))                                 &
+       & diafra(i,ktop(i)) = MAX(diafra(i,ktop(i)),                                  &
+       &                         MAX(zcc(i)*CCFCT,CANVA*(zcc(i)-CANVB)))
+      dialiq(i,ktop(i))=CCLWMR*diafra(i,ktop(i))
+      ENDDO
+!c
+      DO k = 1, klev ! nuages convectifs (sauf enclumes)
+      DO i = 1, klon
+      IF (k.LT.ktop(i) .AND. k.GE.kbot(i)) THEN
+         diafra(i,k)=MAX(diafra(i,k),zcc(i)*CCFCT)
+         dialiq(i,k)=CCLWMR*diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE diagcld1
+
+      SUBROUTINE diagcld2(paprs,pplay,t,q, diafra,dialiq)
+      use dimphy
+      IMPLICIT none
+!c
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c
+!c Arguments d'entree:
+      REAL paprs(klon,klev+1) ! pression (Pa) a inter-couche
+      REAL pplay(klon,klev) ! pression (Pa) au milieu de couche
+      REAL t(klon,klev) ! temperature (K)
+      REAL q(klon,klev) ! humidite specifique (Kg/Kg)
+!c
+!c Arguments de sortie:
+      REAL diafra(klon,klev) ! fraction nuageuse diagnostiquee
+      REAL dialiq(klon,klev) ! eau liquide nuageuse
+!c
+      REAL CETAMB
+      PARAMETER (CETAMB=0.80)
+      REAL CLOIA, CLOIB, CLOIC, CLOID
+      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.6, CLOID=5.0)
+!ccc      PARAMETER (CLOIA=1.0E+02, CLOIB=-10.00, CLOIC=-0.9, CLOID=5.0)
+      REAL RGAMMAS
+      PARAMETER (RGAMMAS=0.05)
+      REAL CRHL
+      PARAMETER (CRHL=0.15)
+!ccc      PARAMETER (CRHL=0.70)
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+!c
+!c Variables locales:
+      INTEGER i, k, kb, invb(klon)
+      REAL zqs, zrhb, zcll, zdthmin(klon), zdthdp
+      REAL zdelta, zcor
+!c
+!c Fonctions thermodynamiques:
+#include "YOETHF.h"
+#include "FCTTRE.h"
+!c
+!c Initialisation:
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         diafra(i,k) = 0.0
+         dialiq(i,k) = 0.0
+      ENDDO
+      ENDDO
+!c
+      DO i = 1, klon
+         invb(i) = klev
+         zdthmin(i)=0.0
+      ENDDO
+
+      DO k = 2, klev/2-1
+      DO i = 1, klon
+         zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1))                        &
+       &          - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+         zdthdp = zdthdp * CLOIA
+         IF (pplay(i,k).GT.CETAMB*paprs(i,1) .AND.                                   &
+       &       zdthdp.LT.zdthmin(i) ) THEN
+            zdthmin(i) = zdthdp
+            invb(i) = k
+         ENDIF
+      ENDDO
+      ENDDO
+
+      DO i = 1, klon
+         kb=invb(i)
+         IF (thermcep) THEN
+           zdelta=MAX(0.,SIGN(1.,RTT-t(i,kb)))
+           zqs= R2ES*FOEEW(t(i,kb),zdelta)/pplay(i,kb)
+           zqs=MIN(0.5,zqs)
+           zcor=1./(1.-RETV*zqs)
+           zqs=zqs*zcor
+         ELSE
+           IF (t(i,kb) .LT. t_coup) THEN
+              zqs = qsats(t(i,kb)) / pplay(i,kb)
+           ELSE
+              zqs = qsatl(t(i,kb)) / pplay(i,kb)
+           ENDIF
+         ENDIF
+         zcll = CLOIB * zdthmin(i) + CLOIC
+         zcll = MIN(1.0,MAX(0.0,zcll))
+         zrhb= q(i,kb)/zqs
+         IF (zcll.GT.0.0.AND.zrhb.LT.CRHL)                                           &
+       &   zcll=zcll*(1.-(CRHL-zrhb)*CLOID)
+         zcll=MIN(1.0,MAX(0.0,zcll))
+         diafra(i,kb) = MAX(diafra(i,kb),zcll)
+         dialiq(i,kb)= diafra(i,kb) * RGAMMAS*zqs
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE diagcld2
+
+END MODULE nuage_mod
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/o3_chem_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/o3_chem_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/o3_chem_m.F90	(revision 17)
@@ -0,0 +1,172 @@
+! $Id$
+module o3_chem_m
+
+  IMPLICIT none
+
+  private o3_prod
+
+contains
+
+  subroutine o3_chem(julien, gmtime, t_seri, zmasse, pdtphys, rlat, rlon, q)
+
+    ! This procedure evolves the ozone mass fraction through a time
+    ! step taking only chemistry into account.
+
+    ! All the 2-dimensional arrays are on the partial "physics" grid.
+    ! Their shape is "(/klon, llm/)".
+    ! Index "(i, :)" is for longitude "rlon(i)", latitude "rlat(i)".
+
+    use assert_m, only: assert
+    use dimphy, only: klon
+    use regr_pr_comb_coefoz_m, only: c_Mob, a4_mass, a2, r_het_interm
+
+    integer, intent(in):: julien ! jour julien, 1 <= julien <= 360
+    real, intent(in):: gmtime ! heure de la journée en fraction de jour
+    real, intent(in):: t_seri(:, :) ! (klon, llm) temperature, in K
+
+    real, intent(in):: zmasse(:, :) ! (klon, llm)
+    ! (column-density of mass of air in a cell, in kg m-2)
+    ! "zmasse(:, k)" is for layer "k".)
+
+    real, intent(in):: pdtphys ! time step for physics, in s
+
+    REAL, intent(in):: rlat(:), rlon(:)
+    ! (longitude and latitude of each horizontal position, in degrees)
+
+    real, intent(inout):: q(:, :) ! (klon, llm) mass fraction of ozone
+    ! "q(:, k)" is at middle of layer "k".)
+
+    ! Variables local to the procedure:
+    include "dimensions.h"
+    include "comconst.h"
+    ! (for "pi")
+    integer k
+
+    real c(klon, llm)
+    ! (constant term during a time step in the net mass production
+    ! rate of ozone by chemistry, per unit mass of air, in s-1)
+    ! "c(:, k)" is at middle of layer "k".)
+
+    real b(klon, llm)
+    ! (coefficient of "q" in the net mass production
+    ! rate of ozone by chemistry, per unit mass of air, in s-1)
+    ! "b(:, k)" is at middle of layer "k".)
+
+    real dq_o3_chem(klon, llm)
+    ! (variation of ozone mass fraction due to chemistry during a time step)
+    ! "dq_o3_chem(:, k)" is at middle of layer "k".)
+
+    real earth_long
+    ! (longitude vraie de la Terre dans son orbite solaire, par
+    ! rapport au point vernal (21 mars), en degrés)
+
+    real pmu0(klon) ! mean of cosine of solar zenith angle during "pdtphys"
+    real trash1
+    real trash2(klon)
+
+    !-------------------------------------------------------------
+
+    call assert(klon == (/size(q, 1), size(t_seri, 1), size(zmasse, 1), &
+         size(rlat), size(rlon)/), "o3_chem klon")
+    call assert(llm == (/size(q, 2), size(t_seri, 2), size(zmasse, 2)/), &
+         "o3_chem llm")
+
+    c = c_Mob + a4_mass * t_seri
+
+    ! Compute coefficient "b":
+
+    ! Heterogeneous chemistry is only at low temperature:
+    where (t_seri < 195.)
+       b = r_het_interm
+    elsewhere
+       b = 0.
+    end where
+
+    ! Heterogeneous chemistry is only during daytime:
+    call orbite(real(julien), earth_long, trash1)
+    call zenang(earth_long, gmtime, pdtphys, rlat, rlon, pmu0, trash2)
+    forall (k = 1: llm)
+       where (pmu0 <= cos(87. / 180. * pi)) b(:, k) = 0.
+    end forall
+
+    b = b + a2
+
+    ! Midpoint method:
+
+    ! Trial step to the midpoint:
+    dq_o3_chem = o3_prod(q, zmasse, c, b) * pdtphys  / 2
+    ! "Real" step across the whole interval:
+    dq_o3_chem = o3_prod(q + dq_o3_chem, zmasse, c, b) * pdtphys
+    q = q + dq_o3_chem
+
+    ! Confine the mass fraction:
+    q = min(max(q, 0.), .01)
+
+  end subroutine o3_chem
+
+  !*************************************************
+
+  function o3_prod(q, zmasse, c, b)
+
+    ! This function computes the production rate of ozone by chemistry.
+
+    ! All the 2-dimensional arrays are on the partial "physics" grid.
+    ! Their shape is "(/klon, llm/)".
+    ! Index "(i, :)" is for longitude "rlon(i)", latitude "rlat(i)".
+
+    use regr_pr_comb_coefoz_m, only: a6_mass
+    use assert_m, only: assert
+    use dimphy, only: klon
+
+    real, intent(in):: q(:, :) ! mass fraction of ozone
+    ! "q(:, k)" is at middle of layer "k".)
+
+    real, intent(in):: zmasse(:, :)
+    ! (column-density of mass of air in a layer, in kg m-2)
+    ! ("zmasse(:, k)" is for layer "k".)
+
+    real, intent(in):: c(:, :)
+    ! (constant term during a time step in the net mass production
+    ! rate of ozone by chemistry, per unit mass of air, in s-1)
+    ! "c(:, k)" is at middle of layer "k".)
+
+    real, intent(in):: b(:, :)
+    ! (coefficient of "q" in the net mass production rate of ozone by
+    ! chemistry, per unit mass of air, in s-1)
+    ! ("b(:, k)" is at middle of layer "k".)
+
+    include "dimensions.h"
+
+    real o3_prod(klon, llm)
+    ! (net mass production rate of ozone by chemistry, per unit mass
+    ! of air, in s-1)
+    ! ("o3_prod(:, k)" is at middle of layer "k".)
+
+    ! Variables local to the procedure:
+
+    real sigma_mass(klon, llm)
+    ! (mass column-density of ozone above point, in kg m-2)
+    ! ("sigma_mass(:, k)" is at middle of layer "k".)
+
+    integer k
+
+    !-------------------------------------------------------------------
+
+    call assert(klon == (/size(q, 1), size(zmasse, 1), size(c, 1), &
+         size(b, 1)/), "o3_prod 1")
+    call assert(llm == (/size(q, 2), size(zmasse, 2), size(c, 2), &
+         size(b, 2)/), "o3_prod 2")
+
+    ! Compute the column-density above the base of layer
+    ! "k", and, as a first approximation, take it as column-density
+    ! above the middle of layer "k":
+    sigma_mass(:, llm) = zmasse(:, llm) * q(:, llm) ! top layer
+    do k =  llm - 1, 1, -1
+       sigma_mass(:, k) = sigma_mass(:, k+1) + zmasse(:, k) * q(:, k)
+    end do
+
+    o3_prod = c + b * q + a6_mass * sigma_mass
+
+  end function o3_prod
+
+end module o3_chem_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/oasis.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/oasis.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/oasis.F90	(revision 17)
@@ -0,0 +1,457 @@
+!
+MODULE oasis
+!
+! This module contains subroutines for initialization, sending and receiving 
+! towards the coupler OASIS3. It also contains some parameters for the coupling.
+!
+! This module should always be compiled. With the coupler OASIS3 available the cpp key
+! CPP_COUPLE should be set and the entier of this file will then be compiled. 
+! In a forced mode CPP_COUPLE should not be defined and the compilation ends before 
+! the CONTAINS, without compiling the subroutines.
+!
+  USE dimphy 
+  USE mod_phys_lmdz_para
+  USE write_field_phy
+
+#ifdef CPP_COUPLE
+  USE mod_prism_proto
+  USE mod_prism_def_partition_proto
+  USE mod_prism_get_proto
+  USE mod_prism_put_proto
+#endif
+  
+  IMPLICIT NONE
+  
+  ! Id for fields sent to ocean
+  INTEGER, PARAMETER :: ids_tauxxu = 1
+  INTEGER, PARAMETER :: ids_tauyyu = 2
+  INTEGER, PARAMETER :: ids_tauzzu = 3
+  INTEGER, PARAMETER :: ids_tauxxv = 4
+  INTEGER, PARAMETER :: ids_tauyyv = 5
+  INTEGER, PARAMETER :: ids_tauzzv = 6
+  INTEGER, PARAMETER :: ids_windsp = 7
+  INTEGER, PARAMETER :: ids_shfice = 8
+  INTEGER, PARAMETER :: ids_shfoce = 9
+  INTEGER, PARAMETER :: ids_shftot = 10
+  INTEGER, PARAMETER :: ids_nsfice = 11
+  INTEGER, PARAMETER :: ids_nsfoce = 12
+  INTEGER, PARAMETER :: ids_nsftot = 13
+  INTEGER, PARAMETER :: ids_dflxdt = 14
+  INTEGER, PARAMETER :: ids_totrai = 15
+  INTEGER, PARAMETER :: ids_totsno = 16
+  INTEGER, PARAMETER :: ids_toteva = 17
+  INTEGER, PARAMETER :: ids_icevap = 18
+  INTEGER, PARAMETER :: ids_ocevap = 19
+  INTEGER, PARAMETER :: ids_calvin = 20
+  INTEGER, PARAMETER :: ids_liqrun = 21
+  INTEGER, PARAMETER :: ids_runcoa = 22
+  INTEGER, PARAMETER :: ids_rivflu = 23
+  INTEGER, PARAMETER :: ids_atmco2 = 24
+  INTEGER, PARAMETER :: ids_taumod = 25
+  INTEGER, PARAMETER :: maxsend    = 25  ! Maximum number of fields to send
+  
+  ! Id for fields received from ocean
+  INTEGER, PARAMETER :: idr_sisutw = 1
+  INTEGER, PARAMETER :: idr_icecov = 2
+  INTEGER, PARAMETER :: idr_icealw = 3
+  INTEGER, PARAMETER :: idr_icetem = 4
+  INTEGER, PARAMETER :: idr_curenx = 5
+  INTEGER, PARAMETER :: idr_cureny = 6
+  INTEGER, PARAMETER :: idr_curenz = 7
+  INTEGER, PARAMETER :: idr_oceco2 = 8
+  INTEGER, PARAMETER :: maxrecv    = 8  ! Maximum number of fields to receive
+  
+
+  TYPE, PUBLIC ::   FLD_CPL            ! Type for coupling field information
+     CHARACTER(len = 8) ::   name      ! Name of the coupling field   
+     LOGICAL            ::   action    ! To be exchanged or not
+     INTEGER            ::   nid       ! Id of the field
+  END TYPE FLD_CPL
+
+  TYPE(FLD_CPL), DIMENSION(maxsend), SAVE, PUBLIC :: infosend   ! Information for sending coupling fields
+  TYPE(FLD_CPL), DIMENSION(maxrecv), SAVE, PUBLIC :: inforecv   ! Information for receiving coupling fields
+  
+  LOGICAL,SAVE :: cpl_current
+!$OMP THREADPRIVATE(cpl_current)
+
+#ifdef CPP_COUPLE
+
+CONTAINS
+
+  SUBROUTINE inicma
+!************************************************************************************
+!**** *INICMA*  - Initialize coupled mode communication for atmosphere
+!                 and exchange some initial information with Oasis
+!
+!     Rewrite to take the PRISM/psmile library into account
+!     LF 09/2003
+!
+    USE IOIPSL
+    USE surface_data, ONLY : version_ocean
+    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
+
+    INCLUDE "dimensions.h"
+    INCLUDE "iniprint.h"
+
+! Local variables
+!************************************************************************************
+    INTEGER                            :: comp_id
+    INTEGER                            :: ierror, il_commlocal
+    INTEGER                            :: il_part_id
+    INTEGER, DIMENSION(3)              :: ig_paral
+    INTEGER, DIMENSION(2)              :: il_var_nodims
+    INTEGER, DIMENSION(4)              :: il_var_actual_shape
+    INTEGER                            :: il_var_type
+    INTEGER                            :: jf
+    CHARACTER (len = 6)                :: clmodnam
+    CHARACTER (len = 20)               :: modname = 'inicma'
+    CHARACTER (len = 80)               :: abort_message 
+    LOGICAL                            :: cpl_current_omp
+
+!*    1. Initializations
+!        ---------------
+!************************************************************************************
+    WRITE(lunout,*) ' '
+    WRITE(lunout,*) ' '
+    WRITE(lunout,*) ' ROUTINE INICMA'
+    WRITE(lunout,*) ' **************'
+    WRITE(lunout,*) ' '
+    WRITE(lunout,*) ' '
+
+!
+! Define the model name
+!
+    clmodnam = 'lmdz.x'       ! as in $NBMODEL in Cpl/Nam/namcouple.tmp
+
+
+!************************************************************************************
+! Define if coupling ocean currents or not
+!************************************************************************************
+!$OMP MASTER
+    cpl_current_omp = .FALSE.
+    CALL getin('cpl_current', cpl_current_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+    cpl_current = cpl_current_omp
+    WRITE(lunout,*) 'Couple ocean currents, cpl_current = ',cpl_current 
+
+!************************************************************************************
+! Define coupling variables
+!************************************************************************************
+
+! Atmospheric variables to send
+
+!$OMP MASTER
+    infosend(:)%action = .FALSE.
+
+    infosend(ids_tauxxu)%action = .TRUE. ; infosend(ids_tauxxu)%name = 'COTAUXXU'
+    infosend(ids_tauyyu)%action = .TRUE. ; infosend(ids_tauyyu)%name = 'COTAUYYU'
+    infosend(ids_tauzzu)%action = .TRUE. ; infosend(ids_tauzzu)%name = 'COTAUZZU'
+    infosend(ids_tauxxv)%action = .TRUE. ; infosend(ids_tauxxv)%name = 'COTAUXXV'
+    infosend(ids_tauyyv)%action = .TRUE. ; infosend(ids_tauyyv)%name = 'COTAUYYV'
+    infosend(ids_tauzzv)%action = .TRUE. ; infosend(ids_tauzzv)%name = 'COTAUZZV'
+    infosend(ids_windsp)%action = .TRUE. ; infosend(ids_windsp)%name = 'COWINDSP'
+    infosend(ids_shfice)%action = .TRUE. ; infosend(ids_shfice)%name = 'COSHFICE'
+    infosend(ids_nsfice)%action = .TRUE. ; infosend(ids_nsfice)%name = 'CONSFICE'
+    infosend(ids_dflxdt)%action = .TRUE. ; infosend(ids_dflxdt)%name = 'CODFLXDT'
+    infosend(ids_calvin)%action = .TRUE. ; infosend(ids_calvin)%name = 'COCALVIN'
+    
+    IF (version_ocean=='nemo') THEN
+        infosend(ids_shftot)%action = .TRUE. ; infosend(ids_shftot)%name = 'COQSRMIX'
+        infosend(ids_nsftot)%action = .TRUE. ; infosend(ids_nsftot)%name = 'COQNSMIX'
+        infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOTRAI'
+        infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOTSNO'
+        infosend(ids_toteva)%action = .TRUE. ; infosend(ids_toteva)%name = 'COTOTEVA'
+        infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COICEVAP'
+        infosend(ids_liqrun)%action = .TRUE. ; infosend(ids_liqrun)%name = 'COLIQRUN'
+        infosend(ids_taumod)%action = .TRUE. ; infosend(ids_taumod)%name = 'COTAUMOD'
+        IF (carbon_cycle_cpl) THEN
+            infosend(ids_atmco2)%action = .TRUE. ; infosend(ids_atmco2)%name = 'COATMCO2'
+        ENDIF
+        
+    ELSE IF (version_ocean=='opa8') THEN
+        infosend(ids_shfoce)%action = .TRUE. ; infosend(ids_shfoce)%name = 'COSHFOCE'
+        infosend(ids_nsfoce)%action = .TRUE. ; infosend(ids_nsfoce)%name = 'CONSFOCE'
+        infosend(ids_icevap)%action = .TRUE. ; infosend(ids_icevap)%name = 'COTFSICE'
+        infosend(ids_ocevap)%action = .TRUE. ; infosend(ids_ocevap)%name = 'COTFSOCE'
+        infosend(ids_totrai)%action = .TRUE. ; infosend(ids_totrai)%name = 'COTOLPSU'
+        infosend(ids_totsno)%action = .TRUE. ; infosend(ids_totsno)%name = 'COTOSPSU'
+        infosend(ids_runcoa)%action = .TRUE. ; infosend(ids_runcoa)%name = 'CORUNCOA'
+        infosend(ids_rivflu)%action = .TRUE. ; infosend(ids_rivflu)%name = 'CORIVFLU'
+   ENDIF
+        
+! Oceanic variables to receive
+
+   inforecv(:)%action = .FALSE.
+
+   inforecv(idr_sisutw)%action = .TRUE. ; inforecv(idr_sisutw)%name = 'SISUTESW'
+   inforecv(idr_icecov)%action = .TRUE. ; inforecv(idr_icecov)%name = 'SIICECOV'
+   inforecv(idr_icealw)%action = .TRUE. ; inforecv(idr_icealw)%name = 'SIICEALW'
+   inforecv(idr_icetem)%action = .TRUE. ; inforecv(idr_icetem)%name = 'SIICTEMW'
+   
+   IF (cpl_current ) THEN
+       inforecv(idr_curenx)%action = .TRUE. ; inforecv(idr_curenx)%name = 'CURRENTX'
+       inforecv(idr_cureny)%action = .TRUE. ; inforecv(idr_cureny)%name = 'CURRENTY'
+       inforecv(idr_curenz)%action = .TRUE. ; inforecv(idr_curenz)%name = 'CURRENTZ'
+   ENDIF
+
+   IF (carbon_cycle_cpl ) THEN
+       inforecv(idr_oceco2)%action = .TRUE. ; inforecv(idr_oceco2)%name = 'SICO2FLX'
+   ENDIF
+
+!************************************************************************************
+! Here we go: psmile initialisation
+!************************************************************************************
+    IF (is_sequential) THEN
+       CALL prism_init_comp_proto (comp_id, clmodnam, ierror)
+       
+       IF (ierror .NE. PRISM_Ok) THEN
+          abort_message=' Probleme init dans prism_init_comp '
+          CALL abort_gcm(modname,abort_message,1)
+       ELSE
+          WRITE(lunout,*) 'inicma : init psmile ok '
+       ENDIF
+    ENDIF
+
+    CALL prism_get_localcomm_proto (il_commlocal, ierror)
+!************************************************************************************
+! Domain decomposition
+!************************************************************************************
+    ig_paral(1) = 1                            ! apple partition for //
+    ig_paral(2) = (jj_begin-1)*iim+ii_begin-1  ! offset
+    ig_paral(3) = (jj_end*iim+ii_end) - (jj_begin*iim+ii_begin) + 1
+
+    IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+iim-1
+    WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3)
+    
+    ierror=PRISM_Ok
+    CALL prism_def_partition_proto (il_part_id, ig_paral, ierror)
+
+    IF (ierror .NE. PRISM_Ok) THEN
+       abort_message=' Probleme dans prism_def_partition '
+       CALL abort_gcm(modname,abort_message,1)
+    ELSE
+       WRITE(lunout,*) 'inicma : decomposition domaine psmile ok '
+    ENDIF
+
+    il_var_nodims(1) = 2
+    il_var_nodims(2) = 1
+
+    il_var_actual_shape(1) = 1
+    il_var_actual_shape(2) = iim
+    il_var_actual_shape(3) = 1
+    il_var_actual_shape(4) = jjm+1
+   
+    il_var_type = PRISM_Real
+
+!************************************************************************************
+! Oceanic Fields to receive
+! Loop over all possible variables
+!************************************************************************************
+    DO jf=1, maxrecv
+       IF (inforecv(jf)%action) THEN
+          CALL prism_def_var_proto(inforecv(jf)%nid, inforecv(jf)%name, il_part_id, &
+               il_var_nodims, PRISM_In, il_var_actual_shape, il_var_type, &
+               ierror)
+          IF (ierror .NE. PRISM_Ok) THEN
+             WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
+                  inforecv(jf)%name
+             abort_message=' Problem in call to prism_def_var_proto for fields to receive'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+    END DO
+    
+!************************************************************************************
+! Atmospheric Fields to send
+! Loop over all possible variables
+!************************************************************************************
+    DO jf=1,maxsend
+       IF (infosend(jf)%action) THEN
+          CALL prism_def_var_proto(infosend(jf)%nid, infosend(jf)%name, il_part_id, &
+               il_var_nodims, PRISM_Out, il_var_actual_shape, il_var_type, &
+               ierror)
+          IF (ierror .NE. PRISM_Ok) THEN
+             WRITE(lunout,*) 'inicma : Problem with prism_def_var_proto for field : ',&
+                  infosend(jf)%name
+             abort_message=' Problem in call to prism_def_var_proto for fields to send'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+    END DO
+    
+!************************************************************************************
+! End definition
+!************************************************************************************
+    CALL prism_enddef_proto(ierror)
+    IF (ierror .NE. PRISM_Ok) THEN
+       abort_message=' Problem in call to prism_endef_proto'
+       CALL abort_gcm(modname,abort_message,1)
+    ELSE
+       WRITE(lunout,*) 'inicma : endef psmile ok '
+    ENDIF
+
+!$OMP END MASTER
+    
+  END SUBROUTINE inicma
+
+!
+!************************************************************************************
+!
+
+  SUBROUTINE fromcpl(ktime, tab_get)
+! ======================================================================
+! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine reads the SST 
+! and Sea-Ice provided by the coupler. Adaptation to psmile library
+!======================================================================
+!
+    INCLUDE "dimensions.h"
+    INCLUDE "iniprint.h"
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                               ::  ktime
+
+! Output arguments
+!************************************************************************************
+    REAL, DIMENSION(iim, jj_nb,maxrecv), INTENT(OUT) :: tab_get
+
+! Local variables
+!************************************************************************************
+    INTEGER                       :: ierror, i
+    INTEGER                       :: istart,iend
+    CHARACTER (len = 20)          :: modname = 'fromcpl'
+    CHARACTER (len = 80)          :: abort_message 
+    REAL, DIMENSION(iim*jj_nb)    :: field
+
+!************************************************************************************
+    WRITE (lunout,*) ' '
+    WRITE (lunout,*) 'Fromcpl: Reading fields from CPL, ktime=',ktime
+    WRITE (lunout,*) ' '
+    
+    istart=ii_begin
+    IF (is_south_pole) THEN
+       iend=(jj_end-jj_begin)*iim+iim
+    ELSE
+       iend=(jj_end-jj_begin)*iim+ii_end
+    ENDIF
+    
+    DO i = 1, maxrecv
+      IF (inforecv(i)%action) THEN
+          field(:) = -99999.
+          CALL prism_get_proto(inforecv(i)%nid, ktime, field(istart:iend), ierror)
+          tab_get(:,:,i) = RESHAPE(field(:),(/iim,jj_nb/))
+       
+          IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Recvd .AND. &
+             ierror.NE.PRISM_FromRest &
+             .AND. ierror.NE.PRISM_Input .AND. ierror.NE.PRISM_RecvOut &
+             .AND. ierror.NE.PRISM_FromRestOut) THEN
+              WRITE (lunout,*)  'Error with receiving filed : ', inforecv(i)%name, ktime   
+              abort_message=' Problem in prism_get_proto '
+              CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+      ENDIF
+    END DO
+    
+    
+  END SUBROUTINE fromcpl
+
+!
+!************************************************************************************
+! 
+
+  SUBROUTINE intocpl(ktime, last, tab_put) 
+! ======================================================================
+! L. Fairhead (09/2003) adapted From L.Z.X Li: this subroutine provides the 
+! atmospheric coupling fields to the coupler with the psmile library.
+! IF last time step, writes output fields to binary files.
+! ======================================================================
+!
+! 
+    INCLUDE "dimensions.h"
+    INCLUDE "iniprint.h"
+! Input arguments
+!************************************************************************************
+    INTEGER, INTENT(IN)                              :: ktime
+    LOGICAL, INTENT(IN)                              :: last
+    REAL, DIMENSION(iim, jj_nb, maxsend), INTENT(IN) :: tab_put
+
+! Local variables
+!************************************************************************************
+    LOGICAL                          :: checkout
+    INTEGER                          :: istart,iend
+    INTEGER                          :: wstart,wend
+    INTEGER                          :: ierror, i
+    REAL, DIMENSION(iim*jj_nb)       :: field
+    CHARACTER (len = 20),PARAMETER   :: modname = 'intocpl'
+    CHARACTER (len = 80)             :: abort_message 
+
+!************************************************************************************
+    checkout=.FALSE.
+
+    WRITE(lunout,*) ' '
+    WRITE(lunout,*) 'Intocpl: sending fields to CPL, ktime= ', ktime
+    WRITE(lunout,*) 'last = ', last
+    WRITE(lunout,*)
+
+
+    istart=ii_begin
+    IF (is_south_pole) THEN
+       iend=(jj_end-jj_begin)*iim+iim
+    ELSE
+       iend=(jj_end-jj_begin)*iim+ii_end
+    ENDIF
+    
+    IF (checkout) THEN   
+       wstart=istart
+       wend=iend
+       IF (is_north_pole) wstart=istart+iim-1
+       IF (is_south_pole) wend=iend-iim+1
+       
+       DO i = 1, maxsend
+          IF (infosend(i)%action) THEN
+             field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
+             CALL writefield_phy(infosend(i)%name,field(wstart:wend),1)
+          END IF
+       END DO
+    END IF
+
+!************************************************************************************
+! PRISM_PUT
+!************************************************************************************
+
+    DO i = 1, maxsend
+      IF (infosend(i)%action) THEN
+          field = RESHAPE(tab_put(:,:,i),(/iim*jj_nb/))
+          CALL prism_put_proto(infosend(i)%nid, ktime, field(istart:iend), ierror)
+          
+          IF (ierror .NE. PRISM_Ok .AND. ierror.NE.PRISM_Sent .AND. ierror.NE.PRISM_ToRest &
+             .AND. ierror.NE.PRISM_LocTrans .AND. ierror.NE.PRISM_Output .AND. &
+             ierror.NE.PRISM_SentOut .AND. ierror.NE.PRISM_ToRestOut) THEN
+              WRITE (lunout,*) 'Error with sending field :', infosend(i)%name, ktime   
+              abort_message=' Problem in prism_put_proto '
+              CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+      ENDIF
+    END DO
+   
+!************************************************************************************
+! Finalize PSMILE for the case is_sequential, if parallel finalization is done 
+! from Finalize_parallel in dyn3dpar/parallel.F90
+!************************************************************************************
+
+    IF (last) THEN
+       IF (is_sequential) THEN 
+          CALL prism_terminate_proto(ierror)
+          IF (ierror .NE. PRISM_Ok) THEN
+             abort_message=' Problem in prism_terminate_proto '
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+    ENDIF
+    
+    
+  END SUBROUTINE intocpl
+
+#endif
+  
+END MODULE oasis
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ocean_cpl_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ocean_cpl_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ocean_cpl_mod.F90	(revision 17)
@@ -0,0 +1,324 @@
+!
+MODULE ocean_cpl_mod
+!
+! This module is used both for the sub-surface ocean and sea-ice for the case of a 
+! coupled model configuration, ocean=couple. 
+!
+
+  IMPLICIT NONE
+  PRIVATE
+
+  PUBLIC :: ocean_cpl_init, ocean_cpl_noice, ocean_cpl_ice
+
+!****************************************************************************************
+!
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_init(dtime, rlon, rlat)
+!
+! Allocate fields for this module and initailize the module mod_cpl
+!
+    USE dimphy,           ONLY : klon
+    USE cpl_mod
+
+! Input arguments
+!*************************************************************************************
+    REAL, INTENT(IN)                  :: dtime
+    REAL, DIMENSION(klon), INTENT(IN) :: rlon, rlat
+
+! Local variables
+!*************************************************************************************
+    INTEGER              :: error
+    CHARACTER (len = 80) :: abort_message
+    CHARACTER (len = 20) :: modname = 'ocean_cpl_init'
+
+! Initialize module cpl_init
+    CALL cpl_init(dtime, rlon, rlat)
+    
+  END SUBROUTINE ocean_cpl_init
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_noice( &
+       swnet, lwnet, alb1, &
+       windsp, fder_old, &
+       itime, dtime, knon, knindex, &
+       p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       AcoefH, AcoefQ, BcoefH, BcoefQ, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       ps, u1, v1, &
+       radsol, snow, agesno, &
+       qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+       tsurf_new, dflux_s, dflux_l)
+
+!
+! This subroutine treats the "open ocean", all grid points that are not entierly covered
+! by ice. The subroutine first receives fields from coupler, then some calculations at 
+! surface is done and finally it sends some fields to the coupler.
+!
+    USE dimphy,           ONLY : klon
+    USE cpl_mod
+    USE calcul_fluxs_mod
+    USE indice_sol_mod
+
+    INCLUDE "YOMCST.h"
+!    
+! Input arguments  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: swnet
+    REAL, DIMENSION(klon), INTENT(IN)        :: lwnet
+    REAL, DIMENSION(klon), INTENT(IN)        :: alb1   ! albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(IN)        :: windsp
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: cdragh, cdragm
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefH, AcoefQ, BcoefH, BcoefQ
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: flux_u1, flux_v1
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+
+! Local variables
+!****************************************************************************************
+    INTEGER               :: i
+    INTEGER, DIMENSION(1) :: iloc
+    REAL, DIMENSION(klon) :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon) :: fder_new
+    REAL, DIMENSION(klon) :: tsurf_cpl
+    REAL, DIMENSION(klon) :: u0_cpl, v0_cpl
+    REAL, DIMENSION(klon) :: u1_lay, v1_lay
+    LOGICAL               :: check=.FALSE.
+
+! End definitions
+!****************************************************************************************
+
+    IF (check) WRITE(*,*)' Entering ocean_cpl_noice'
+
+!****************************************************************************************
+! Receive sea-surface temperature(tsurf_cpl) from coupler
+!
+!****************************************************************************************
+    CALL cpl_receive_ocean_fields(knon, knindex, tsurf_cpl, u0_cpl, v0_cpl)
+
+!****************************************************************************************
+! Calculate fluxes at surface
+!
+!****************************************************************************************
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    agesno(:) = 0.
+
+    DO i = 1, knon
+       u1_lay(i) = u1(i) - u0_cpl(i)
+       v1_lay(i) = v1(i) - v0_cpl(i)
+    END DO
+
+    CALL calcul_fluxs(knon, is_oce, dtime, &
+         tsurf_cpl, p1lay, cal, beta, cdragh, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+! - Flux calculation at first modele level for U and V
+    CALL calcul_flux_wind(knon, dtime, &
+         u0_cpl, v0_cpl, u1, v1, cdragm, &
+         AcoefU, AcoefV, BcoefU, BcoefV, &
+         p1lay, temp_air, &
+         flux_u1, flux_v1)  
+
+!****************************************************************************************
+! Calculate fder : flux derivative (sensible and latente)
+!
+!****************************************************************************************
+    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
+    
+    iloc = MAXLOC(fder_new(1:klon))
+    IF (check .AND. fder_new(iloc(1))> 0.) THEN
+       WRITE(*,*)'**** Debug fder****'
+       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
+       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
+            dflux_s(iloc(1)), dflux_l(iloc(1))
+    ENDIF
+
+!****************************************************************************************
+! Send and cumulate fields to the coupler
+!
+!****************************************************************************************
+
+    CALL cpl_send_ocean_fields(itime, knon, knindex, &
+         swnet, lwnet, fluxlat, fluxsens, &
+         precip_rain, precip_snow, evap, tsurf_new, fder_new, alb1, flux_u1, flux_v1, windsp)
+    
+
+  END SUBROUTINE ocean_cpl_noice
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_cpl_ice( &
+       rlon, rlat, swnet, lwnet, alb1, &
+       fder_old, &
+       itime, dtime, knon, knindex, &
+       lafin, &
+       p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       AcoefH, AcoefQ, BcoefH, BcoefQ, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       ps, u1, v1, pctsrf, &
+       radsol, snow, qsurf, &
+       alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+       tsurf_new, dflux_s, dflux_l)
+!
+! This subroutine treats the ocean where there is ice. The subroutine first receives 
+! fields from coupler, then some calculations at surface is done and finally sends 
+! some fields to the coupler.
+!    
+    USE dimphy,           ONLY : klon
+    USE cpl_mod
+    USE calcul_fluxs_mod
+    USE indice_sol_mod
+
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    LOGICAL, INTENT(IN)                      :: lafin
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: swnet
+    REAL, DIMENSION(klon), INTENT(IN)        :: lwnet
+    REAL, DIMENSION(klon), INTENT(IN)        :: alb1   ! albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder_old
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: cdragh, cdragm
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefH, AcoefQ, BcoefH, BcoefQ
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
+
+! In/output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new, alb2_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: flux_u1, flux_v1
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+
+! Local variables
+!****************************************************************************************
+    INTEGER                 :: i
+    INTEGER, DIMENSION(1)   :: iloc
+    LOGICAL                 :: check=.FALSE.
+    REAL, PARAMETER         :: t_grnd=271.35
+    REAL, DIMENSION(klon)   :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)   :: tsurf_cpl, fder_new
+    REAL, DIMENSION(klon)   :: alb_cpl
+    REAL, DIMENSION(klon)   :: u0, v0
+    REAL, DIMENSION(klon)   :: u1_lay, v1_lay
+
+! End definitions
+!****************************************************************************************
+    
+    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
+
+!****************************************************************************************
+! Receive ocean temperature(tsurf_cpl) and albedo(alb_new) from coupler
+!
+!****************************************************************************************
+
+    CALL cpl_receive_seaice_fields(knon, knindex, &
+         tsurf_cpl, alb_cpl, u0, v0)
+
+    alb1_new(1:knon) = alb_cpl(1:knon)
+    alb2_new(1:knon) = alb_cpl(1:knon)    
+
+    
+!****************************************************************************************
+! Calculate fluxes at surface
+!
+!****************************************************************************************
+    cal = 0.
+    dif_grnd = 0.
+    beta = 1.0
+    
+    DO i = 1, knon
+       u1_lay(i) = u1(i) - u0(i)
+       v1_lay(i) = v1(i) - v0(i)
+    END DO
+
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+         tsurf_cpl, p1lay, cal, beta, cdragh, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+
+! - Flux calculation at first modele level for U and V
+    CALL calcul_flux_wind(knon, dtime, &
+         u0, v0, u1, v1, cdragm, &
+         AcoefU, AcoefV, BcoefU, BcoefV, &
+         p1lay, temp_air, &
+         flux_u1, flux_v1)  
+
+!****************************************************************************************
+! Calculate fder : flux derivative (sensible and latente)
+!
+!****************************************************************************************
+    fder_new(:) = fder_old(:) + dflux_s(:) + dflux_l(:)
+    
+    iloc = MAXLOC(fder_new(1:klon))
+    IF (check .AND. fder_new(iloc(1))> 0.) THEN
+       WRITE(*,*)'**** Debug fder ****'
+       WRITE(*,*)'max fder(',iloc(1),') = ',fder_new(iloc(1))
+       WRITE(*,*)'fder_old, dflux_s, dflux_l',fder_old(iloc(1)), &
+            dflux_s(iloc(1)), dflux_l(iloc(1))
+    ENDIF
+
+!****************************************************************************************
+! Send and cumulate fields to the coupler
+!
+!****************************************************************************************
+
+    CALL cpl_send_seaice_fields(itime, dtime, knon, knindex, &
+       pctsrf, lafin, rlon, rlat, &
+       swnet, lwnet, fluxlat, fluxsens, &
+       precip_rain, precip_snow, evap, tsurf_new, fder_new, alb1, flux_u1, flux_v1)
+ 
+
+  END SUBROUTINE ocean_cpl_ice
+!  
+!****************************************************************************************
+!
+END MODULE ocean_cpl_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ocean_forced_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ocean_forced_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ocean_forced_mod.F90	(revision 17)
@@ -0,0 +1,304 @@
+!
+MODULE ocean_forced_mod
+!
+! This module is used for both the sub-surfaces ocean and sea-ice for the case of a 
+! forced ocean,  "ocean=force".
+!
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_forced_noice( &
+       itime, dtime, jour, knon, knindex, &
+       p1lay, cdragh, cdragm, precip_rain, precip_snow, &
+       temp_air, spechum, &
+       AcoefH, AcoefQ, BcoefH, BcoefQ, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       ps, u1, v1, &
+       radsol, snow, agesno, & 
+       qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+       tsurf_new, dflux_s, dflux_l)
+!
+! This subroutine treats the "open ocean", all grid points that are not entierly covered
+! by ice.
+! The routine receives data from climatologie file limit.nc and does some calculations at the 
+! surface. 
+!
+    USE dimphy
+    USE calcul_fluxs_mod
+    USE limit_read_mod
+    USE indice_sol_mod
+
+!L. Fita, LMD. November, 2013
+    USE NOread_limit_sub_variables
+
+    INCLUDE "YOMCST.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: cdragh, cdragm
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefH, AcoefQ, BcoefH, BcoefQ
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno !? put to 0 in ocean
+  
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: flux_u1, flux_v1
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l
+
+! Local variables
+!****************************************************************************************
+    INTEGER                     :: i
+    REAL, DIMENSION(klon)       :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)       :: alb_neig, tsurf_lim, zx_sl
+    REAL, DIMENSION(klon)       :: u0, v0
+    REAL, DIMENSION(klon)       :: u1_lay, v1_lay
+    LOGICAL                     :: check=.FALSE.
+! Lluis
+    INTEGER                                              :: lp, lpt
+
+    lp = 885
+    lpt = 765
+
+!****************************************************************************************
+! Start calculation
+!****************************************************************************************
+    IF (check) WRITE(*,*)' Entering ocean_forced_noice'
+    
+!****************************************************************************************
+! 1)    
+! Read sea-surface temperature from file limit.nc
+!
+!****************************************************************************************
+! L. Fita, LMD. November 2013
+! Not needed! Using wrfinput, wrfbdy and wrflowinput instead
+!    ALLOCATE(tsurf_lim(klon))
+!    CALL limit_read_sst(knon,knindex,tsurf_lim)
+!    tsurf_lim = sst(knindex(1:knon))
+!    tsurf_lim = 283.15
+
+    DO i=1,knon
+      tsurf_lim(i) = tsurf_limit(knindex(i))
+    END DO
+
+    PRINT *,'   Lluis pt tsurf_limit_check tsurf_lim_____'
+    DO i=-10,10
+      PRINT *,lp+i,tsurf_limit(lp+i),tsurf_lim(lpt+i)
+    END DO
+
+    PRINT *,'Lluis in ocean_surface_mod lp= ',lp,' tsurf_limit: ',tsurf_limit(lp),   &
+      ' lpt: ',lpt,' tsurf_lim: ',tsurf_lim(lpt),' knindex: ',knindex(lpt)
+
+!****************************************************************************************
+! 2)
+! Flux calculation
+!
+!****************************************************************************************
+! Set some variables for calcul_fluxs
+    cal = 0.
+    beta = 1.
+    dif_grnd = 0.
+    alb_neig(:) = 0.
+    agesno(:) = 0.
+! Suppose zero surface speed
+    u0(:)=0.0
+    v0(:)=0.0
+    u1_lay(:) = u1(:) - u0(:)
+    v1_lay(:) = v1(:) - v0(:)
+
+    PRINT *,'  Lluis before calcul_fluxs tsurf_lim:', tsurf_lim(lpt),                &
+      ' tsurf_new: ', tsurf_new(lpt)
+! Calcul de tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l and qsurf
+    CALL calcul_fluxs(knon, is_oce, dtime, &
+         tsurf_lim, p1lay, cal, beta, cdragh, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    PRINT *,'  Lluis after calcul_fluxs tsurf_lim: ', tsurf_lim(lp),' tsurf_new: ',  &
+      tsurf_new(lpt)
+    PRINT *,'    Lluis i knindex tsurf_limit tsurf_lim tsurf_new ___________'
+    DO i=1,knon
+      PRINT *,i,knindex(i),tsurf_limit(knindex(i)),tsurf_lim(i),tsurf_new(i)
+    END DO
+
+! - Flux calculation at first modele level for U and V
+    CALL calcul_flux_wind(knon, dtime, &
+         u0, v0, u1, v1, cdragm, &
+         AcoefU, AcoefV, BcoefU, BcoefV, &
+         p1lay, temp_air, &
+         flux_u1, flux_v1)  
+
+  END SUBROUTINE ocean_forced_noice
+!
+!***************************************************************************************
+!
+  SUBROUTINE ocean_forced_ice( &
+       itime, dtime, jour, knon, knindex, &
+       tsurf_in, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       AcoefH, AcoefQ, BcoefH, BcoefQ, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       ps, u1, v1, &
+       radsol, snow, qsol, agesno, tsoil, &
+       qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+       tsurf_new, dflux_s, dflux_l)
+!
+! This subroutine treats the ocean where there is ice. 
+! The routine reads data from climatologie file and does flux calculations at the 
+! surface.
+!
+    USE dimphy
+    USE calcul_fluxs_mod
+    USE surface_data,     ONLY : calice, calsno, tau_gl
+    USE limit_read_mod
+    USE fonte_neige_mod,  ONLY : fonte_neige
+    USE indice_sol_mod
+
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf_in
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: cdragh, cdragm
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefH, AcoefQ, BcoefH, BcoefQ
+    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alb1_new  ! new albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alb2_new  ! new albedo in near IR interval
+    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)            :: flux_u1, flux_v1
+    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l      
+
+! Local variables
+!****************************************************************************************
+    LOGICAL                     :: check=.FALSE.
+    INTEGER                     :: i
+    REAL                        :: zfra
+    REAL, PARAMETER             :: t_grnd=271.35
+    REAL, DIMENSION(klon)       :: cal, beta, dif_grnd, capsol
+    REAL, DIMENSION(klon)       :: alb_neig, tsurf_tmp
+    REAL, DIMENSION(klon)       :: soilcap, soilflux
+    REAL, DIMENSION(klon)       :: u0, v0
+    REAL, DIMENSION(klon)       :: u1_lay, v1_lay
+
+!****************************************************************************************
+! Start calculation
+!****************************************************************************************
+    IF (check) WRITE(*,*)'Entering surface_seaice, knon=',knon 
+
+!****************************************************************************************
+! 1) 
+! Flux calculation : tsurf_new, evap, fluxlat, fluxsens, flux_u1, flux_v1
+!                    dflux_s, dflux_l and qsurf
+!****************************************************************************************
+    tsurf_tmp(:) = tsurf_in(:)
+
+! calculate the parameters cal, beta, capsol and dif_grnd
+    CALL calbeta(dtime, is_sic, knon, snow, qsol, beta, capsol, dif_grnd)
+
+    
+    IF (soil_model) THEN 
+! update tsoil and calculate soilcap and soilflux
+       CALL soil(dtime, is_sic, knon, snow, tsurf_tmp, tsoil,soilcap, soilflux)
+       cal(1:knon) = RCPD / soilcap(1:knon)
+       radsol(1:knon) = radsol(1:knon)  + soilflux(1:knon)
+       dif_grnd = 1.0 / tau_gl
+    ELSE 
+       dif_grnd = 1.0 / tau_gl
+       cal = RCPD * calice
+       WHERE (snow > 0.0) cal = RCPD * calsno 
+    ENDIF
+
+    beta = 1.0
+! Suppose zero surface speed
+    u0(:)=0.0
+    v0(:)=0.0
+    u1_lay(:) = u1(:) - u0(:)
+    v1_lay(:) = v1(:) - v0(:)
+    CALL calcul_fluxs(knon, is_sic, dtime, &
+         tsurf_tmp, p1lay, cal, beta, cdragh, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+! - Flux calculation at first modele level for U and V
+    CALL calcul_flux_wind(knon, dtime, &
+         u0, v0, u1, v1, cdragm, &
+         AcoefU, AcoefV, BcoefU, BcoefV, &
+         p1lay, temp_air, &
+         flux_u1, flux_v1)  
+
+!****************************************************************************************
+! 2)
+! Calculations due to snow and runoff
+!
+!****************************************************************************************
+    CALL fonte_neige( knon, is_sic, knindex, dtime, &
+         tsurf_tmp, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+    
+! Calculation of albedo at snow (alb_neig) and update the age of snow (agesno)
+! 
+    CALL albsno(klon, knon, dtime, agesno(:), alb_neig(:), precip_snow(:))  
+
+    WHERE (snow(1:knon) .LT. 0.0001) agesno(1:knon) = 0.
+
+    alb1_new(:) = 0.0
+    DO i=1, knon
+       zfra = MAX(0.0,MIN(1.0,snow(i)/(snow(i)+10.0)))
+       alb1_new(i) = alb_neig(i) * zfra +  0.6 * (1.0-zfra)
+    ENDDO
+
+    alb2_new(:) = alb1_new(:)
+
+  END SUBROUTINE ocean_forced_ice
+!
+!****************************************************************************************
+!
+END MODULE ocean_forced_mod
+
+
+
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ocean_slab_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ocean_slab_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ocean_slab_mod.F90	(revision 17)
@@ -0,0 +1,165 @@
+!
+MODULE ocean_slab_mod
+!
+! This module is used for both surface ocean and sea-ice when using the slab ocean,
+! "ocean=slab".
+!
+  IMPLICIT NONE
+  PRIVATE
+  PUBLIC :: ocean_slab_frac, ocean_slab_noice
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_frac(itime, dtime, jour, pctsrf, is_modified)
+
+    USE dimphy
+    USE limit_read_mod
+    USE surface_data
+    USE indice_sol_mod
+
+!    INCLUDE "clesphys.h"
+
+! Arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                        :: itime   ! numero du pas de temps courant
+    INTEGER, INTENT(IN)                        :: jour    ! jour a lire dans l'annee
+    REAL   , INTENT(IN)                        :: dtime   ! pas de temps de la physique (en s)
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT) :: pctsrf  ! sub-surface fraction
+    LOGICAL, INTENT(OUT)                       :: is_modified ! true if pctsrf is modified at this time step
+
+! Local variables
+!****************************************************************************************
+    CHARACTER (len = 80)   :: abort_message
+    CHARACTER (len = 20)   :: modname = 'ocean_slab_frac'
+
+
+    IF (version_ocean == 'sicOBS') THEN   
+! L. Fita, LMD. Ovember 2013. Removing reading from 'limit.nc'
+!!       CALL limit_read_frac(itime, dtime, jour, pctsrf, is_modified)
+      PRINT *,'  L. Fita. LMDZ+WRF: Already loaded, no limit.nc !'
+    ELSE
+       abort_message='Ocean slab model without forced sea-ice fractions has to be rewritten!!!'
+       CALL abort_gcm(modname,abort_message,1)
+! Here should sea-ice/ocean fraction either be calculated or returned if saved as a module varaiable 
+! (in the case the new fractions are calculated in ocean_slab_ice or ocean_slab_noice subroutines).  
+    END IF
+
+  END SUBROUTINE ocean_slab_frac
+!
+!****************************************************************************************
+!
+  SUBROUTINE ocean_slab_noice( & 
+       itime, dtime, jour, knon, knindex, &
+       p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       AcoefH, AcoefQ, BcoefH, BcoefQ, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       ps, u1, v1, tsurf_in, &
+       radsol, snow, agesno, &
+       qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+       tsurf_new, dflux_s, dflux_l, lmt_bils)
+    
+    USE dimphy
+    USE calcul_fluxs_mod
+    USE indice_sol_mod
+
+    INCLUDE "iniprint.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                  :: itime
+    INTEGER, INTENT(IN)                  :: jour
+    INTEGER, INTENT(IN)                  :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN) :: knindex
+    REAL, INTENT(IN)                     :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)    :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)    :: cdragh, cdragm
+    REAL, DIMENSION(klon), INTENT(IN)    :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)    :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefH, AcoefQ, BcoefH, BcoefQ
+    REAL, DIMENSION(klon), INTENT(IN)    :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)    :: ps
+    REAL, DIMENSION(klon), INTENT(IN)    :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)    :: tsurf_in
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT) :: radsol
+    REAL, DIMENSION(klon), INTENT(INOUT) :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT) :: agesno
+    
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)   :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)   :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)   :: flux_u1, flux_v1
+    REAL, DIMENSION(klon), INTENT(OUT)   :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)   :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)   :: lmt_bils
+
+! Local variables
+!****************************************************************************************
+    INTEGER               :: i
+    REAL, DIMENSION(klon) :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon) :: lmt_bils_oce, lmt_foce, diff_sst
+    REAL, DIMENSION(klon) :: u0, v0
+    REAL, DIMENSION(klon) :: u1_lay, v1_lay
+    REAL                  :: calc_bils_oce, deltat
+    REAL, PARAMETER       :: cyang=50.0 * 4.228e+06 ! capacite calorifique volumetrique de l'eau J/(m2 K)
+
+!****************************************************************************************
+! 1) Flux calculation
+!
+!****************************************************************************************
+    cal(:)      = 0.
+    beta(:)     = 1.
+    dif_grnd(:) = 0.
+    agesno(:)   = 0.
+    
+! Suppose zero surface speed
+    u0(:)=0.0
+    v0(:)=0.0
+    u1_lay(:) = u1(:) - u0(:)
+    v1_lay(:) = v1(:) - v0(:)
+
+    CALL calcul_fluxs(knon, is_oce, dtime, &
+         tsurf_in, p1lay, cal, beta, cdragh, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+! - Flux calculation at first modele level for U and V
+    CALL calcul_flux_wind(knon, dtime, &
+         u0, v0, u1, v1, cdragm, &
+         AcoefU, AcoefV, BcoefU, BcoefV, &
+         p1lay, temp_air, &
+         flux_u1, flux_v1)  
+
+!****************************************************************************************
+! 2) Get global variables lmt_bils and lmt_foce from file limit_slab.nc
+!
+!****************************************************************************************
+    CALL limit_slab(itime, dtime, jour, lmt_bils, lmt_foce, diff_sst)  ! global pour un processus
+
+    lmt_bils_oce(:) = 0.
+    WHERE (lmt_foce > 0.) 
+       lmt_bils_oce = lmt_bils / lmt_foce ! global 
+    END WHERE
+
+!****************************************************************************************
+! 3) Recalculate new temperature
+!
+!****************************************************************************************
+    DO i = 1, knon
+       calc_bils_oce = radsol(i) + fluxsens(i) + fluxlat(i)
+       deltat        = (calc_bils_oce - lmt_bils_oce(knindex(i)))*dtime/cyang +diff_sst(knindex(i))
+       tsurf_new(i)  = tsurf_in(i) + deltat
+    END DO
+
+  END SUBROUTINE ocean_slab_noice
+!
+!****************************************************************************************
+!
+END MODULE ocean_slab_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/open_climoz_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/open_climoz_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/open_climoz_m.F90	(revision 17)
@@ -0,0 +1,73 @@
+! $Id$
+module open_climoz_m
+
+  implicit none
+
+contains
+
+  subroutine open_climoz(ncid, press_in_edg)
+
+    ! This procedure should be called once per "gcm" run, by a single
+    ! thread of each MPI process.
+    ! The root MPI process opens "climoz_LMDZ.nc", reads the pressure
+    ! levels and broadcasts them to the other processes.
+
+    ! We assume that, in "climoz_LMDZ.nc", the pressure levels are in hPa
+    ! and in strictly ascending order.
+
+    use netcdf95, only: nf95_open, nf95_close, nf95_gw_var, nf95_inq_varid
+    use netcdf, only: nf90_nowrite
+
+    use mod_phys_lmdz_mpi_data, only: is_mpi_root
+    use mod_phys_lmdz_mpi_transfert, only: bcast_mpi ! broadcast
+
+    integer, intent(out):: ncid ! of "climoz_LMDZ.nc", OpenMP shared
+
+    real, pointer:: press_in_edg(:)
+    ! edges of pressure intervals for ozone climatology, in Pa, in strictly
+    ! ascending order, OpenMP shared
+
+    ! Variables local to the procedure:
+
+    real, pointer:: plev(:)
+    ! (pressure levels for ozone climatology, converted to Pa, in strictly
+    ! ascending order)
+
+    integer varid ! for NetCDF
+    integer n_plev ! number of pressure levels in the input data
+    integer k
+
+    !---------------------------------------
+
+    print *, "Call sequence information: open_climoz"
+
+    if (is_mpi_root) then
+       call nf95_open("climoz_LMDZ.nc", nf90_nowrite, ncid)
+
+       call nf95_inq_varid(ncid, "plev", varid)
+       call nf95_gw_var(ncid, varid, plev)
+       ! Convert from hPa to Pa because "paprs" and "pplay" are in Pa:
+       plev = plev * 100.
+       n_plev = size(plev)
+    end if
+
+    call bcast_mpi(n_plev)
+    if (.not. is_mpi_root) allocate(plev(n_plev))
+    call bcast_mpi(plev)
+    
+    ! Compute edges of pressure intervals:
+    allocate(press_in_edg(n_plev + 1))
+    if (is_mpi_root) then
+       press_in_edg(1) = 0.
+       ! We choose edges halfway in logarithm:
+       forall (k = 2:n_plev) press_in_edg(k) = sqrt(plev(k - 1) * plev(k))
+       press_in_edg(n_plev + 1) = huge(0.)
+       ! (infinity, but any value guaranteed to be greater than the
+       ! surface pressure would do)
+    end if
+    call bcast_mpi(press_in_edg)
+    deallocate(plev) ! pointer
+
+  end subroutine open_climoz
+
+end module open_climoz_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/orbite.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/orbite.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/orbite.F	(revision 17)
@@ -0,0 +1,325 @@
+!
+! $Header$
+!
+c======================================================================
+      SUBROUTINE orbite(xjour,longi,dist)
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818
+c Objet: pour un jour donne, calculer la longitude vraie de la terre
+c        (par rapport au point vernal-21 mars) dans son orbite solaire
+c        calculer aussi la distance terre-soleil (unite astronomique)
+c======================================================================
+c Arguments:
+c xjour--INPUT--R- jour de l'annee a compter du 1er janvier
+c longi--OUTPUT-R- longitude vraie en degres par rapport au point
+c                  vernal (21 mars) en degres
+c dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne)
+      REAL xjour, longi, dist
+c======================================================================
+#include "YOMCST.h"
+C
+C  -- Variables dynamiques locales
+      REAL pir,xl,xllp,xee,xse,xlam,dlamm,anm,ranm,anv,ranv
+C
+      pir = 4.0*ATAN(1.0) / 180.0
+      xl=R_peri+180.0
+      xllp=xl*pir
+      xee=R_ecc*R_ecc
+      xse=SQRT(1.0-xee)
+      xlam = (R_ecc/2.0+R_ecc*xee/8.0)*(1.0+xse)*SIN(xllp)
+     .     - xee/4.0*(0.5+xse)*SIN(2.0*xllp)
+     .     + R_ecc*xee/8.0*(1.0/3.0+xse)*SIN(3.0*xllp)
+      xlam=2.0*xlam/pir
+      dlamm=xlam+(xjour-81.0)
+      anm=dlamm-xl
+      ranm=anm*pir
+      xee=xee*R_ecc
+      ranv=ranm+(2.0*R_ecc-xee/4.0)*SIN(ranm)
+     .         +5.0/4.0*R_ecc*R_ecc*SIN(2.0*ranm)
+     .         +13.0/12.0*xee*SIN(3.0*ranm)
+c
+      anv=ranv/pir
+      longi=anv+xl
+C
+      dist = (1-R_ecc*R_ecc)
+     .      /(1+R_ecc*COS(pir*(longi-(R_peri+180.0))))
+      RETURN
+      END
+c======================================================================
+      SUBROUTINE angle(longi, lati, frac, muzero)
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur
+c        du soleil (cosinus de l'angle zinithal) moyenne sur la journee
+c======================================================================
+c Arguments:
+c longi----INPUT-R- la longitude vraie de la terre dans son plan 
+c                   solaire a partir de l'equinoxe de printemps (degre)
+c lati-----INPUT-R- la latitude d'un point sur la terre (degre)
+c frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee
+c                   par 24 heures (unite en fraction de 0 a 1)
+c muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur
+c                   la journee (0 a 1)
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+      REAL longi
+      REAL lati(klon), frac(klon), muzero(klon)
+#include "YOMCST.h"
+      REAL lat, omega, lon_sun, lat_sun
+      REAL pi_local, incl
+      INTEGER i
+c
+      pi_local = 4.0 * ATAN(1.0)
+      incl=R_incl * pi_local / 180.
+c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (sin(lon_sun)*SIN(incl) )
+c
+      DO i = 1, klon
+      lat = lati(i) * pi_local / 180.0
+c
+      IF ( lat .GE. (pi_local/2.+lat_sun)
+     .    .OR. lat.LE.(-pi_local/2.+lat_sun)) THEN
+         omega = 0.0   ! nuit polaire
+      ELSE IF ( lat.GE.(pi_local/2.-lat_sun)
+     .          .OR. lat.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local   ! journee polaire
+      ELSE
+         omega = -TAN(lat)*TAN(lat_sun)
+         omega = ACOS (omega)
+      ENDIF
+c
+      frac(i) = omega / pi_local
+c
+      IF (omega .GT. 0.0) THEN
+         muzero(i) = SIN(lat)*SIN(lat_sun)
+     .          + COS(lat)*COS(lat_sun)*SIN(omega) / omega
+      ELSE
+         muzero(i) = 0.0
+      ENDIF
+      ENDDO
+c
+      RETURN
+      END
+c====================================================================
+      SUBROUTINE zenang(longi,gmtime,pdtrad,lat,long,
+     s                  pmu0,frac)
+      USE dimphy
+      IMPLICIT none
+c=============================================================
+c Auteur : O. Boucher (LMD/CNRS)
+c          d'apres les routines zenith et angle de Z.X. Li 
+c Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
+c          et l'ensoleillement moyen entre gmtime1 et gmtime2 
+c          connaissant la declinaison, la latitude et la longitude.
+c Rque   : Different de la routine angle en ce sens que zenang 
+c          fournit des moyennes de pmu0 et non des valeurs 
+c          instantanees, du coup frac prend toutes les valeurs 
+c          entre 0 et 1.
+c Date   : premiere version le 13 decembre 1994
+c          revu pour  GCM  le 30 septembre 1996
+c===============================================================
+c longi : la longitude vraie de la terre dans son plan
+c                  solaire a partir de l'equinoxe de printemps (degre)
+c gmtime : temps universel en fraction de jour
+c pdtrad : pas de temps du rayonnement (secondes)
+c lat------INPUT : latitude en degres
+c long-----INPUT : longitude en degres
+c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad
+c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad
+c================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c================================================================
+      real, intent(in):: longi, gmtime, pdtrad
+      real lat(klon), long(klon), pmu0(klon), frac(klon)
+c================================================================
+      integer i
+      real gmtime1, gmtime2
+      real pi_local, deux_pi_local, incl
+      real omega1, omega2, omega
+c omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi.
+c omega : heure en radian du coucher de soleil 
+c -omega est donc l'heure en radian de lever du soleil
+      real omegadeb, omegafin
+      real zfrac1, zfrac2, z1_mu, z2_mu
+      real lat_sun          ! declinaison en radian
+      real lon_sun          ! longitude solaire en radian
+      real latr             ! latitude du pt de grille en radian
+c================================================================
+c
+      pi_local = 4.0 * ATAN(1.0)
+      deux_pi_local = 2.0 * pi_local
+      incl=R_incl * pi_local / 180.
+c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+c
+      gmtime1=gmtime*86400.
+      gmtime2=gmtime*86400.+pdtrad
+c
+      DO i = 1, klon
+c
+      latr = lat(i) * pi_local / 180.
+c
+c--pose probleme quand lat=+/-90 degres
+c
+c      omega = -TAN(latr)*TAN(lat_sun)
+c      omega = ACOS(omega)
+c      IF (latr.GE.(pi_local/2.+lat_sun)
+c     .    .OR. latr.LE.(-pi_local/2.+lat_sun)) THEN
+c         omega = 0.0       ! nuit polaire
+c      ENDIF
+c      IF (latr.GE.(pi_local/2.-lat_sun)
+c     .          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+c         omega = pi_local  ! journee polaire
+c      ENDIF
+c
+c--remplace par cela (le cas par defaut est different)
+c
+      omega=0.0  !--nuit polaire
+      IF (latr.GE.(pi_local/2.-lat_sun)
+     .          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local  ! journee polaire
+      ENDIF
+      IF (latr.LT.(pi_local/2.+lat_sun).AND.
+     .    latr.GT.(-pi_local/2.+lat_sun).AND.
+     .    latr.LT.(pi_local/2.-lat_sun).AND.
+     .    latr.GT.(-pi_local/2.-lat_sun)) THEN
+      omega = -TAN(latr)*TAN(lat_sun)
+      omega = ACOS(omega)
+      ENDIF
+c
+         omega1 = gmtime1 + long(i)*86400.0/360.0
+         omega1 = omega1 / 86400.0*deux_pi_local
+         omega1 = MOD (omega1+deux_pi_local, deux_pi_local)
+         omega1 = omega1 - pi_local
+c
+         omega2 = gmtime2 + long(i)*86400.0/360.0
+         omega2 = omega2 / 86400.0*deux_pi_local
+         omega2 = MOD (omega2+deux_pi_local, deux_pi_local)
+         omega2 = omega2 - pi_local
+c
+      IF (omega1.LE.omega2) THEN  !--on est dans la meme journee locale
+c
+      IF (omega2.LE.-omega .OR. omega1.GE.omega
+     .                     .OR. omega.LT.1e-5) THEN   !--nuit
+         frac(i)=0.0
+         pmu0(i)=0.0
+      ELSE                                              !--jour+nuit/jour
+        omegadeb=MAX(-omega,omega1)
+        omegafin=MIN(omega,omega2)
+        frac(i)=(omegafin-omegadeb)/(omega2-omega1)
+        pmu0(i)=SIN(latr)*SIN(lat_sun) + 
+     .          COS(latr)*COS(lat_sun)*
+     .          (SIN(omegafin)-SIN(omegadeb))/
+     .          (omegafin-omegadeb)        
+      ENDIF
+c
+      ELSE  !---omega1 GT omega2 -- a cheval sur deux journees
+c
+c-------------------entre omega1 et pi
+      IF (omega1.GE.omega) THEN  !--nuit
+         zfrac1=0.0
+         z1_mu =0.0
+      ELSE                       !--jour+nuit
+        omegadeb=MAX(-omega,omega1)
+        omegafin=omega
+        zfrac1=omegafin-omegadeb
+        z1_mu =SIN(latr)*SIN(lat_sun) +
+     .          COS(latr)*COS(lat_sun)*
+     .          (SIN(omegafin)-SIN(omegadeb))/
+     .          (omegafin-omegadeb)
+      ENDIF 
+c---------------------entre -pi et omega2
+      IF (omega2.LE.-omega) THEN   !--nuit
+         zfrac2=0.0
+         z2_mu =0.0
+      ELSE                         !--jour+nuit
+         omegadeb=-omega
+         omegafin=MIN(omega,omega2)
+         zfrac2=omegafin-omegadeb
+         z2_mu =SIN(latr)*SIN(lat_sun) +
+     .           COS(latr)*COS(lat_sun)*
+     .           (SIN(omegafin)-SIN(omegadeb))/
+     .           (omegafin-omegadeb)
+c
+      ENDIF
+c-----------------------moyenne 
+      frac(i)=(zfrac1+zfrac2)/(omega2+deux_pi_local-omega1)
+      pmu0(i)=(zfrac1*z1_mu+zfrac2*z2_mu)/MAX(zfrac1+zfrac2,1.E-10)
+c
+      ENDIF   !---comparaison omega1 et omega2
+c
+      ENDDO
+c
+      END
+c===================================================================
+      SUBROUTINE zenith (longi, gmtime, lat, long,
+     s                   pmu0, fract)
+      USE dimphy
+      IMPLICIT none
+c
+c Auteur(s): Z.X. Li (LMD/ENS)
+c
+c Objet: calculer le cosinus de l'angle zenithal du soleil en
+c        connaissant la declinaison du soleil, la latitude et la
+c        longitude du point sur la terre, et le temps universel
+c
+c Arguments d'entree:
+c     longi  : declinaison du soleil (en degres)
+c     gmtime : temps universel en second qui varie entre 0 et 86400
+c     lat    : latitude en degres
+c     long   : longitude en degres
+c Arguments de sortie:
+c     pmu0   : cosinus de l'angle zenithal
+c
+c====================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c====================================================================
+      REAL longi, gmtime
+      REAL lat(klon), long(klon), pmu0(klon), fract(klon)
+c=====================================================================
+      INTEGER n
+      REAL zpi, zpir, omega, zgmtime
+      REAL incl, lat_sun, lon_sun
+c----------------------------------------------------------------------
+      zpi = 4.0*ATAN(1.0)
+      zpir = zpi / 180.0
+      zgmtime=gmtime*86400.
+c
+      incl=R_incl * zpir
+c
+      lon_sun = longi * zpir
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+c
+c--initialisation a la nuit
+c
+      DO n =1, klon
+        pmu0(n)=0.
+        fract(n)=0.0
+      ENDDO
+c
+c 1 degre en longitude = 240 secondes en temps
+c
+      DO n = 1, klon
+         omega = zgmtime + long(n)*86400.0/360.0
+         omega = omega / 86400.0 * 2.0 * zpi
+         omega = MOD(omega + 2.0 * zpi, 2.0 * zpi)
+         omega = omega - zpi
+         pmu0(n) = sin(lat(n)*zpir) * sin(lat_sun)
+     .           + cos(lat(n)*zpir) * cos(lat_sun)
+     .           * cos(omega)
+         pmu0(n) = MAX (pmu0(n), 0.0)
+         IF (pmu0(n).GT.1.E-6) fract(n)=1.0
+      ENDDO
+c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/orbite.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/orbite.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/orbite.F90	(revision 17)
@@ -0,0 +1,325 @@
+!
+! $Header$
+!
+!c======================================================================
+      SUBROUTINE orbite(xjour,longi,dist)
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818
+!c Objet: pour un jour donne, calculer la longitude vraie de la terre
+!c        (par rapport au point vernal-21 mars) dans son orbite solaire
+!c        calculer aussi la distance terre-soleil (unite astronomique)
+!c======================================================================
+!c Arguments:
+!c xjour--INPUT--R- jour de l'annee a compter du 1er janvier
+!c longi--OUTPUT-R- longitude vraie en degres par rapport au point
+!c                  vernal (21 mars) en degres
+!c dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne)
+      REAL xjour, longi, dist
+!c======================================================================
+#include "YOMCST.h"
+!C
+!C  -- Variables dynamiques locales
+      REAL pir,xl,xllp,xee,xse,xlam,dlamm,anm,ranm,anv,ranv
+!C
+      pir = 4.0*ATAN(1.0) / 180.0
+      xl=R_peri+180.0
+      xllp=xl*pir
+      xee=R_ecc*R_ecc
+      xse=SQRT(1.0-xee)
+      xlam = (R_ecc/2.0+R_ecc*xee/8.0)*(1.0+xse)*SIN(xllp)                           &
+       &     - xee/4.0*(0.5+xse)*SIN(2.0*xllp)                                       &
+       &     + R_ecc*xee/8.0*(1.0/3.0+xse)*SIN(3.0*xllp)
+      xlam=2.0*xlam/pir
+      dlamm=xlam+(xjour-81.0)
+      anm=dlamm-xl
+      ranm=anm*pir
+      xee=xee*R_ecc
+      ranv=ranm+(2.0*R_ecc-xee/4.0)*SIN(ranm)                                        &
+       &         +5.0/4.0*R_ecc*R_ecc*SIN(2.0*ranm)                                  &
+       &         +13.0/12.0*xee*SIN(3.0*ranm)
+!c
+      anv=ranv/pir
+      longi=anv+xl
+!C
+      dist = (1-R_ecc*R_ecc)                                                         &
+       &      /(1+R_ecc*COS(pir*(longi-(R_peri+180.0))))
+      RETURN
+      END SUBROUTINE orbite
+!c======================================================================
+      SUBROUTINE angle(longi, lati, frac, muzero)
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+!c Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur
+!c        du soleil (cosinus de l'angle zinithal) moyenne sur la journee
+!c======================================================================
+!c Arguments:
+!c longi----INPUT-R- la longitude vraie de la terre dans son plan 
+!c                   solaire a partir de l'equinoxe de printemps (degre)
+!c lati-----INPUT-R- la latitude d'un point sur la terre (degre)
+!c frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee
+!c                   par 24 heures (unite en fraction de 0 a 1)
+!c muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur
+!c                   la journee (0 a 1)
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+      REAL longi
+      REAL lati(klon), frac(klon), muzero(klon)
+#include "YOMCST.h"
+      REAL lat, omega, lon_sun, lat_sun
+      REAL pi_local, incl
+      INTEGER i
+!c
+      pi_local = 4.0 * ATAN(1.0)
+      incl=R_incl * pi_local / 180.
+!c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (sin(lon_sun)*SIN(incl) )
+!c
+      DO i = 1, klon
+      lat = lati(i) * pi_local / 180.0
+!c
+      IF ( lat .GE. (pi_local/2.+lat_sun)                                            &
+       &    .OR. lat.LE.(-pi_local/2.+lat_sun)) THEN
+         omega = 0.0   ! nuit polaire
+      ELSE IF ( lat.GE.(pi_local/2.-lat_sun)                                         &
+       &          .OR. lat.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local   ! journee polaire
+      ELSE
+         omega = -TAN(lat)*TAN(lat_sun)
+         omega = ACOS (omega)
+      ENDIF
+!c
+      frac(i) = omega / pi_local
+!c
+      IF (omega .GT. 0.0) THEN
+         muzero(i) = SIN(lat)*SIN(lat_sun)                                           &
+       &          + COS(lat)*COS(lat_sun)*SIN(omega) / omega
+      ELSE
+         muzero(i) = 0.0
+      ENDIF
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE angle
+!c====================================================================
+      SUBROUTINE zenang(longi,gmtime,pdtrad,lat,long,                                &
+       &                  pmu0,frac)
+      USE dimphy
+      IMPLICIT none
+!c=============================================================
+!c Auteur : O. Boucher (LMD/CNRS)
+!c          d'apres les routines zenith et angle de Z.X. Li 
+!c Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
+!c          et l'ensoleillement moyen entre gmtime1 et gmtime2 
+!c          connaissant la declinaison, la latitude et la longitude.
+!c Rque   : Different de la routine angle en ce sens que zenang 
+!c          fournit des moyennes de pmu0 et non des valeurs 
+!c          instantanees, du coup frac prend toutes les valeurs 
+!c          entre 0 et 1.
+!c Date   : premiere version le 13 decembre 1994
+!c          revu pour  GCM  le 30 septembre 1996
+!c===============================================================
+!c longi : la longitude vraie de la terre dans son plan
+!c                  solaire a partir de l'equinoxe de printemps (degre)
+!c gmtime : temps universel en fraction de jour
+!c pdtrad : pas de temps du rayonnement (secondes)
+!c lat------INPUT : latitude en degres
+!c long-----INPUT : longitude en degres
+!c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad
+!c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad
+!c================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c================================================================
+      real, intent(in):: longi, gmtime, pdtrad
+      real lat(klon), long(klon), pmu0(klon), frac(klon)
+!c================================================================
+      integer i
+      real gmtime1, gmtime2
+      real pi_local, deux_pi_local, incl
+      real omega1, omega2, omega
+!c omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi.
+!c omega : heure en radian du coucher de soleil 
+!c -omega est donc l'heure en radian de lever du soleil
+      real omegadeb, omegafin
+      real zfrac1, zfrac2, z1_mu, z2_mu
+      real lat_sun          ! declinaison en radian
+      real lon_sun          ! longitude solaire en radian
+      real latr             ! latitude du pt de grille en radian
+!c================================================================
+!c
+      pi_local = 4.0 * ATAN(1.0)
+      deux_pi_local = 2.0 * pi_local
+      incl=R_incl * pi_local / 180.
+!c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+!c
+      gmtime1=gmtime*86400.
+      gmtime2=gmtime*86400.+pdtrad
+!c
+      DO i = 1, klon
+!c
+      latr = lat(i) * pi_local / 180.
+!c
+!c--pose probleme quand lat=+/-90 degres
+!c
+!c      omega = -TAN(latr)*TAN(lat_sun)
+!c      omega = ACOS(omega)
+!c      IF (latr.GE.(pi_local/2.+lat_sun)
+!c     .    .OR. latr.LE.(-pi_local/2.+lat_sun)) THEN
+!c         omega = 0.0       ! nuit polaire
+!c      ENDIF
+!c      IF (latr.GE.(pi_local/2.-lat_sun)
+!c     .          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+!c         omega = pi_local  ! journee polaire
+!c      ENDIF
+!c
+!c--remplace par cela (le cas par defaut est different)
+!c
+      omega=0.0  !--nuit polaire
+      IF (latr.GE.(pi_local/2.-lat_sun)                                              &
+       &          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local  ! journee polaire
+      ENDIF
+      IF (latr.LT.(pi_local/2.+lat_sun).AND.                                         &
+       &    latr.GT.(-pi_local/2.+lat_sun).AND.                                      &
+       &    latr.LT.(pi_local/2.-lat_sun).AND.                                       &
+       &    latr.GT.(-pi_local/2.-lat_sun)) THEN
+      omega = -TAN(latr)*TAN(lat_sun)
+      omega = ACOS(omega)
+      ENDIF
+!c
+         omega1 = gmtime1 + long(i)*86400.0/360.0
+         omega1 = omega1 / 86400.0*deux_pi_local
+         omega1 = MOD (omega1+deux_pi_local, deux_pi_local)
+         omega1 = omega1 - pi_local
+!c
+         omega2 = gmtime2 + long(i)*86400.0/360.0
+         omega2 = omega2 / 86400.0*deux_pi_local
+         omega2 = MOD (omega2+deux_pi_local, deux_pi_local)
+         omega2 = omega2 - pi_local
+!c
+      IF (omega1.LE.omega2) THEN  !--on est dans la meme journee locale
+!c
+      IF (omega2.LE.-omega .OR. omega1.GE.omega                                      &
+       &                     .OR. omega.LT.1e-5) THEN   !--nuit
+         frac(i)=0.0
+         pmu0(i)=0.0
+      ELSE                                              !--jour+nuit/jour
+        omegadeb=MAX(-omega,omega1)
+        omegafin=MIN(omega,omega2)
+        frac(i)=(omegafin-omegadeb)/(omega2-omega1)
+        pmu0(i)=SIN(latr)*SIN(lat_sun) +                                             &
+       &          COS(latr)*COS(lat_sun)*                                            &
+       &          (SIN(omegafin)-SIN(omegadeb))/                                     &
+       &          (omegafin-omegadeb)        
+      ENDIF
+!c
+      ELSE  !---omega1 GT omega2 -- a cheval sur deux journees
+!c
+!c-------------------entre omega1 et pi
+      IF (omega1.GE.omega) THEN  !--nuit
+         zfrac1=0.0
+         z1_mu =0.0
+      ELSE                       !--jour+nuit
+        omegadeb=MAX(-omega,omega1)
+        omegafin=omega
+        zfrac1=omegafin-omegadeb
+        z1_mu =SIN(latr)*SIN(lat_sun) +                                              &
+       &          COS(latr)*COS(lat_sun)*                                            &
+       &          (SIN(omegafin)-SIN(omegadeb))/                                     &
+       &          (omegafin-omegadeb)
+      ENDIF 
+!c---------------------entre -pi et omega2
+      IF (omega2.LE.-omega) THEN   !--nuit
+         zfrac2=0.0
+         z2_mu =0.0
+      ELSE                         !--jour+nuit
+         omegadeb=-omega
+         omegafin=MIN(omega,omega2)
+         zfrac2=omegafin-omegadeb
+         z2_mu =SIN(latr)*SIN(lat_sun) +                                             &
+       &           COS(latr)*COS(lat_sun)*                                           &
+       &           (SIN(omegafin)-SIN(omegadeb))/                                    &
+       &           (omegafin-omegadeb)
+!c
+      ENDIF
+!c-----------------------moyenne 
+      frac(i)=(zfrac1+zfrac2)/(omega2+deux_pi_local-omega1)
+      pmu0(i)=(zfrac1*z1_mu+zfrac2*z2_mu)/MAX(zfrac1+zfrac2,1.E-10)
+!c
+      ENDIF   !---comparaison omega1 et omega2
+!c
+      ENDDO
+!c
+      END SUBROUTINE zenang
+!c===================================================================
+      SUBROUTINE zenith (longi, gmtime, lat, long,                                   &
+       &                   pmu0, fract)
+      USE dimphy
+      IMPLICIT none
+!c
+!c Auteur(s): Z.X. Li (LMD/ENS)
+!c
+!c Objet: calculer le cosinus de l'angle zenithal du soleil en
+!c        connaissant la declinaison du soleil, la latitude et la
+!c        longitude du point sur la terre, et le temps universel
+!c
+!c Arguments d'entree:
+!c     longi  : declinaison du soleil (en degres)
+!c     gmtime : temps universel en second qui varie entre 0 et 86400
+!c     lat    : latitude en degres
+!c     long   : longitude en degres
+!c Arguments de sortie:
+!c     pmu0   : cosinus de l'angle zenithal
+!c
+!c====================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c====================================================================
+      REAL longi, gmtime
+      REAL lat(klon), long(klon), pmu0(klon), fract(klon)
+!c=====================================================================
+      INTEGER n
+      REAL zpi, zpir, omega, zgmtime
+      REAL incl, lat_sun, lon_sun
+!c----------------------------------------------------------------------
+      zpi = 4.0*ATAN(1.0)
+      zpir = zpi / 180.0
+      zgmtime=gmtime*86400.
+!c
+      incl=R_incl * zpir
+!c
+      lon_sun = longi * zpir
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+!c
+!c--initialisation a la nuit
+!c
+      DO n =1, klon
+        pmu0(n)=0.
+        fract(n)=0.0
+      ENDDO
+!c
+!c 1 degre en longitude = 240 secondes en temps
+!c
+      DO n = 1, klon
+         omega = zgmtime + long(n)*86400.0/360.0
+         omega = omega / 86400.0 * 2.0 * zpi
+         omega = MOD(omega + 2.0 * zpi, 2.0 * zpi)
+         omega = omega - zpi
+         pmu0(n) = sin(lat(n)*zpir) * sin(lat_sun)                                   &
+       &           + cos(lat(n)*zpir) * cos(lat_sun)                                 &
+       &           * cos(omega)
+         pmu0(n) = MAX (pmu0(n), 0.0)
+         IF (pmu0(n).GT.1.E-6) fract(n)=1.0
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE zenith
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/orbite_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/orbite_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/orbite_mod.F90	(revision 17)
@@ -0,0 +1,332 @@
+!
+! $Header$
+!
+MODULE orbite_mod
+
+  CONTAINS
+
+!c======================================================================
+      SUBROUTINE orbite(xjour,longi,dist)
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS) (adapte du GCM du LMD) date: 19930818
+!c Objet: pour un jour donne, calculer la longitude vraie de la terre
+!c        (par rapport au point vernal-21 mars) dans son orbite solaire
+!c        calculer aussi la distance terre-soleil (unite astronomique)
+!c======================================================================
+!c Arguments:
+!c xjour--INPUT--R- jour de l'annee a compter du 1er janvier
+!c longi--OUTPUT-R- longitude vraie en degres par rapport au point
+!c                  vernal (21 mars) en degres
+!c dist---OUTPUT-R- distance terre-soleil (par rapport a la moyenne)
+      REAL xjour, longi, dist
+!c======================================================================
+#include "YOMCST.h"
+!C
+!C  -- Variables dynamiques locales
+      REAL pir,xl,xllp,xee,xse,xlam,dlamm,anm,ranm,anv,ranv
+!C
+      pir = 4.0*ATAN(1.0) / 180.0
+      xl=R_peri+180.0
+      xllp=xl*pir
+      xee=R_ecc*R_ecc
+      xse=SQRT(1.0-xee)
+      xlam = (R_ecc/2.0+R_ecc*xee/8.0)*(1.0+xse)*SIN(xllp)                           &
+       &     - xee/4.0*(0.5+xse)*SIN(2.0*xllp)                                       &
+       &     + R_ecc*xee/8.0*(1.0/3.0+xse)*SIN(3.0*xllp)
+      xlam=2.0*xlam/pir
+      dlamm=xlam+(xjour-81.0)
+      anm=dlamm-xl
+      ranm=anm*pir
+      xee=xee*R_ecc
+      ranv=ranm+(2.0*R_ecc-xee/4.0)*SIN(ranm)                                        &
+       &         +5.0/4.0*R_ecc*R_ecc*SIN(2.0*ranm)                                  &
+       &         +13.0/12.0*xee*SIN(3.0*ranm)
+!c
+      anv=ranv/pir
+      longi=anv+xl
+!C
+      dist = (1-R_ecc*R_ecc)                                                         &
+       &      /(1+R_ecc*COS(pir*(longi-(R_peri+180.0))))
+      RETURN
+      END SUBROUTINE orbite
+!c======================================================================
+      SUBROUTINE angle(longi, lati, frac, muzero)
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X. Li (LMD/CNRS) date: 19930818
+!c Objet: Calculer la duree d'ensoleillement pour un jour et la hauteur
+!c        du soleil (cosinus de l'angle zinithal) moyenne sur la journee
+!c======================================================================
+!c Arguments:
+!c longi----INPUT-R- la longitude vraie de la terre dans son plan 
+!c                   solaire a partir de l'equinoxe de printemps (degre)
+!c lati-----INPUT-R- la latitude d'un point sur la terre (degre)
+!c frac-----OUTPUT-R la duree d'ensoleillement dans la journee divisee
+!c                   par 24 heures (unite en fraction de 0 a 1)
+!c muzero---OUTPUT-R la moyenne du cosinus de l'angle zinithal sur
+!c                   la journee (0 a 1)
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+      REAL longi
+      REAL lati(klon), frac(klon), muzero(klon)
+#include "YOMCST.h"
+      REAL lat, omega, lon_sun, lat_sun
+      REAL pi_local, incl
+      INTEGER i
+!c
+      pi_local = 4.0 * ATAN(1.0)
+      incl=R_incl * pi_local / 180.
+!c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (sin(lon_sun)*SIN(incl) )
+!c
+      DO i = 1, klon
+      lat = lati(i) * pi_local / 180.0
+!c
+      IF ( lat .GE. (pi_local/2.+lat_sun)                                            &
+       &    .OR. lat.LE.(-pi_local/2.+lat_sun)) THEN
+         omega = 0.0   ! nuit polaire
+      ELSE IF ( lat.GE.(pi_local/2.-lat_sun)                                         &
+       &          .OR. lat.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local   ! journee polaire
+      ELSE
+         omega = -TAN(lat)*TAN(lat_sun)
+         omega = ACOS (omega)
+      ENDIF
+!c
+      frac(i) = omega / pi_local
+!c
+      IF (omega .GT. 0.0) THEN
+         muzero(i) = SIN(lat)*SIN(lat_sun)                                           &
+       &          + COS(lat)*COS(lat_sun)*SIN(omega) / omega
+      ELSE
+         muzero(i) = 0.0
+      ENDIF
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE angle
+!c====================================================================
+      SUBROUTINE zenang(longi,gmtime,pdtrad,lat,long,                                &
+       &                  pmu0,frac)
+      USE dimphy
+      IMPLICIT none
+!c=============================================================
+!c Auteur : O. Boucher (LMD/CNRS)
+!c          d'apres les routines zenith et angle de Z.X. Li 
+!c Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
+!c          et l'ensoleillement moyen entre gmtime1 et gmtime2 
+!c          connaissant la declinaison, la latitude et la longitude.
+!c Rque   : Different de la routine angle en ce sens que zenang 
+!c          fournit des moyennes de pmu0 et non des valeurs 
+!c          instantanees, du coup frac prend toutes les valeurs 
+!c          entre 0 et 1.
+!c Date   : premiere version le 13 decembre 1994
+!c          revu pour  GCM  le 30 septembre 1996
+!c===============================================================
+!c longi : la longitude vraie de la terre dans son plan
+!c                  solaire a partir de l'equinoxe de printemps (degre)
+!c gmtime : temps universel en fraction de jour
+!c pdtrad : pas de temps du rayonnement (secondes)
+!c lat------INPUT : latitude en degres
+!c long-----INPUT : longitude en degres
+!c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad
+!c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad
+!c================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c================================================================
+      real, intent(in):: longi, gmtime, pdtrad
+      real lat(klon), long(klon), pmu0(klon), frac(klon)
+!c================================================================
+      integer i
+      real gmtime1, gmtime2
+      real pi_local, deux_pi_local, incl
+      real omega1, omega2, omega
+!c omega1, omega2 : temps 1 et 2 exprime en radian avec 0 a midi.
+!c omega : heure en radian du coucher de soleil 
+!c -omega est donc l'heure en radian de lever du soleil
+      real omegadeb, omegafin
+      real zfrac1, zfrac2, z1_mu, z2_mu
+      real lat_sun          ! declinaison en radian
+      real lon_sun          ! longitude solaire en radian
+      real latr             ! latitude du pt de grille en radian
+!c================================================================
+!c
+      pi_local = 4.0 * ATAN(1.0)
+      deux_pi_local = 2.0 * pi_local
+      incl=R_incl * pi_local / 180.
+!c
+      lon_sun = longi * pi_local / 180.0
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+!c
+      gmtime1=gmtime*86400.
+      gmtime2=gmtime*86400.+pdtrad
+!c
+      DO i = 1, klon
+!c
+      latr = lat(i) * pi_local / 180.
+!c
+!c--pose probleme quand lat=+/-90 degres
+!c
+!c      omega = -TAN(latr)*TAN(lat_sun)
+!c      omega = ACOS(omega)
+!c      IF (latr.GE.(pi_local/2.+lat_sun)
+!c     .    .OR. latr.LE.(-pi_local/2.+lat_sun)) THEN
+!c         omega = 0.0       ! nuit polaire
+!c      ENDIF
+!c      IF (latr.GE.(pi_local/2.-lat_sun)
+!c     .          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+!c         omega = pi_local  ! journee polaire
+!c      ENDIF
+!c
+!c--remplace par cela (le cas par defaut est different)
+!c
+      omega=0.0  !--nuit polaire
+      IF (latr.GE.(pi_local/2.-lat_sun)                                              &
+       &          .OR. latr.LE.(-pi_local/2.-lat_sun)) THEN
+         omega = pi_local  ! journee polaire
+      ENDIF
+      IF (latr.LT.(pi_local/2.+lat_sun).AND.                                         &
+       &    latr.GT.(-pi_local/2.+lat_sun).AND.                                      &
+       &    latr.LT.(pi_local/2.-lat_sun).AND.                                       &
+       &    latr.GT.(-pi_local/2.-lat_sun)) THEN
+      omega = -TAN(latr)*TAN(lat_sun)
+      omega = ACOS(omega)
+      ENDIF
+!c
+         omega1 = gmtime1 + long(i)*86400.0/360.0
+         omega1 = omega1 / 86400.0*deux_pi_local
+         omega1 = MOD (omega1+deux_pi_local, deux_pi_local)
+         omega1 = omega1 - pi_local
+!c
+         omega2 = gmtime2 + long(i)*86400.0/360.0
+         omega2 = omega2 / 86400.0*deux_pi_local
+         omega2 = MOD (omega2+deux_pi_local, deux_pi_local)
+         omega2 = omega2 - pi_local
+!c
+      IF (omega1.LE.omega2) THEN  !--on est dans la meme journee locale
+!c
+      IF (omega2.LE.-omega .OR. omega1.GE.omega                                      &
+       &                     .OR. omega.LT.1e-5) THEN   !--nuit
+         frac(i)=0.0
+         pmu0(i)=0.0
+      ELSE                                              !--jour+nuit/jour
+        omegadeb=MAX(-omega,omega1)
+        omegafin=MIN(omega,omega2)
+        frac(i)=(omegafin-omegadeb)/(omega2-omega1)
+        pmu0(i)=SIN(latr)*SIN(lat_sun) +                                             &
+       &          COS(latr)*COS(lat_sun)*                                            &
+       &          (SIN(omegafin)-SIN(omegadeb))/                                     &
+       &          (omegafin-omegadeb)        
+      ENDIF
+!c
+      ELSE  !---omega1 GT omega2 -- a cheval sur deux journees
+!c
+!c-------------------entre omega1 et pi
+      IF (omega1.GE.omega) THEN  !--nuit
+         zfrac1=0.0
+         z1_mu =0.0
+      ELSE                       !--jour+nuit
+        omegadeb=MAX(-omega,omega1)
+        omegafin=omega
+        zfrac1=omegafin-omegadeb
+        z1_mu =SIN(latr)*SIN(lat_sun) +                                              &
+       &          COS(latr)*COS(lat_sun)*                                            &
+       &          (SIN(omegafin)-SIN(omegadeb))/                                     &
+       &          (omegafin-omegadeb)
+      ENDIF 
+!c---------------------entre -pi et omega2
+      IF (omega2.LE.-omega) THEN   !--nuit
+         zfrac2=0.0
+         z2_mu =0.0
+      ELSE                         !--jour+nuit
+         omegadeb=-omega
+         omegafin=MIN(omega,omega2)
+         zfrac2=omegafin-omegadeb
+         z2_mu =SIN(latr)*SIN(lat_sun) +                                             &
+       &           COS(latr)*COS(lat_sun)*                                           &
+       &           (SIN(omegafin)-SIN(omegadeb))/                                    &
+       &           (omegafin-omegadeb)
+!c
+      ENDIF
+!c-----------------------moyenne 
+      frac(i)=(zfrac1+zfrac2)/(omega2+deux_pi_local-omega1)
+      pmu0(i)=(zfrac1*z1_mu+zfrac2*z2_mu)/MAX(zfrac1+zfrac2,1.E-10)
+!c
+      ENDIF   !---comparaison omega1 et omega2
+!c
+      ENDDO
+!c
+      END SUBROUTINE zenang
+!c===================================================================
+      SUBROUTINE zenith (longi, gmtime, lat, long,                                   &
+       &                   pmu0, fract)
+      USE dimphy
+      IMPLICIT none
+!c
+!c Auteur(s): Z.X. Li (LMD/ENS)
+!c
+!c Objet: calculer le cosinus de l'angle zenithal du soleil en
+!c        connaissant la declinaison du soleil, la latitude et la
+!c        longitude du point sur la terre, et le temps universel
+!c
+!c Arguments d'entree:
+!c     longi  : declinaison du soleil (en degres)
+!c     gmtime : temps universel en second qui varie entre 0 et 86400
+!c     lat    : latitude en degres
+!c     long   : longitude en degres
+!c Arguments de sortie:
+!c     pmu0   : cosinus de l'angle zenithal
+!c
+!c====================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c====================================================================
+      REAL longi, gmtime
+      REAL lat(klon), long(klon), pmu0(klon), fract(klon)
+!c=====================================================================
+      INTEGER n
+      REAL zpi, zpir, omega, zgmtime
+      REAL incl, lat_sun, lon_sun
+!c----------------------------------------------------------------------
+      zpi = 4.0*ATAN(1.0)
+      zpir = zpi / 180.0
+      zgmtime=gmtime*86400.
+!c
+      incl=R_incl * zpir
+!c
+      lon_sun = longi * zpir
+      lat_sun = ASIN (SIN(lon_sun)*SIN(incl) )
+!c
+!c--initialisation a la nuit
+!c
+      DO n =1, klon
+        pmu0(n)=0.
+        fract(n)=0.0
+      ENDDO
+!c
+!c 1 degre en longitude = 240 secondes en temps
+!c
+      DO n = 1, klon
+         omega = zgmtime + long(n)*86400.0/360.0
+         omega = omega / 86400.0 * 2.0 * zpi
+         omega = MOD(omega + 2.0 * zpi, 2.0 * zpi)
+         omega = omega - zpi
+         pmu0(n) = sin(lat(n)*zpir) * sin(lat_sun)                                   &
+       &           + cos(lat(n)*zpir) * cos(lat_sun)                                 &
+       &           * cos(omega)
+         pmu0(n) = MAX (pmu0(n), 0.0)
+         IF (pmu0(n).GT.1.E-6) fract(n)=1.0
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE zenith 
+
+END MODULE orbite_mod
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi.F	(revision 17)
@@ -0,0 +1,1844 @@
+!
+! $Id: orografi.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE drag_noro (nlon,nlev,dtime,paprs,pplay,
+     e                   pmea,pstd, psig, pgam, pthe,ppic,pval,
+     e                   kgwd,kdx,ktest,
+     e                   t, u, v,
+     s                   pulow, pvlow, pustr, pvstr,
+     s                   d_t, d_u, d_v)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Objet: Frottement de la montagne Interface
+c======================================================================
+c Arguments:
+c dtime---input-R- pas d'integration (s)
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c t-------input-R-temperature (K)
+c u-------input-R-vitesse horizontale (m/s)
+c v-------input-R-vitesse horizontale (m/s)
+c
+c d_t-----output-R-increment de la temperature             
+c d_u-----output-R-increment de la vitesse u
+c d_v-----output-R-increment de la vitesse v
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+c
+      INTEGER i, k, kgwd, kdx(nlon), ktest(nlon)
+c
+c Variables locales:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+c
+c initialiser les variables de sortie (pour securite)
+c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL orodrag(klon,klev,kgwd,kdx,ktest,
+     .            dtime,
+     .            papmh, papmf, zgeom,
+     .            pt, pu, pv,
+     .            pmea, pstd, psig, pgam, pthe, ppic,pval,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+cIM BUG  .                +rg*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+         pvstr(i)        = pvstr(i)
+cIM BUG  .                +rg*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE orodrag( nlon,nlev 
+     i                 , kgwd, kdx, ktest
+     r                 , ptsphy
+     r                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1
+     r                 , pmea, pstd, psig, pgamma, ptheta, ppic, pval
+c outputs
+     r                 , pulow,pvlow
+     r                 , pvom,pvol,pte )
+
+      USE dimphy
+      implicit none
+
+c
+c
+c**** *gwdrag* - does the gravity wave parametrization.
+c
+c     purpose.
+c     --------
+c
+c          this routine computes the physical tendencies of the
+c     prognostic variables u,v  and t due to  vertical transports by
+c     subgridscale orographically excited gravity waves
+c
+c**   interface.
+c     ----------
+c          called from *callpar*.
+c
+c          the routine takes its input from the long-term storage:
+c          u,v,t and p at t-1.
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c      implicit logical (l)
+c
+c     method.
+c     -------
+c
+c     externals.
+c     ----------
+      integer ismin, ismax
+      external ismin, ismax
+c
+c     reference.
+c     ----------
+c
+c     author.
+c     -------
+c     m.miller + b.ritter   e.c.m.w.f.     15/06/86.
+c
+c     f.lott + m. miller    e.c.m.w.f.     22/11/94
+c-----------------------------------------------------------------------
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+c
+cym      integer nlon, nlev, klevm1
+      integer nlon, nlev
+      integer kgwd, jl, ilevp1, jk, ji
+      real zdelp, ztemp, zforc, ztend
+      real rover, zb, zc, zconb, zabsv
+      real zzd1, ratio, zbet, zust,zvst, zdis
+      real  pte(nlon,nlev),
+     *      pvol(nlon,nlev),
+     *      pvom(nlon,nlev),
+     *      pulow(klon),
+     *      pvlow(klon)
+      real  pum1(nlon,nlev),
+     *      pvm1(nlon,nlev),
+     *      ptm1(nlon,nlev),
+     *      pmea(nlon),pstd(nlon),psig(nlon),
+     *      pgamma(nlon),ptheta(nlon),ppic(nlon),pval(nlon),
+     *      pgeom1(nlon,nlev),
+     *      papm1(nlon,nlev),
+     *      paphm1(nlon,nlev+1)
+c
+      integer  kdx(nlon),ktest(nlon)
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+      integer  isect(klon),
+     *         icrit(klon),
+     *         ikcrith(klon),
+     *         ikenvh(klon),
+     *         iknu(klon),
+     *         iknu2(klon),
+     *         ikcrit(klon),
+     *         ikhlim(klon)
+c
+      real   ztau(klon,klev+1),
+     $       ztauf(klon,klev+1),
+     *       zstab(klon,klev+1),
+     *       zvph(klon,klev+1),
+     *       zrho(klon,klev+1),
+     *       zri(klon,klev+1),
+     *       zpsi(klon,klev+1),
+     *       zzdep(klon,klev)
+      real   zdudt(klon),
+     *       zdvdt(klon),
+     *       zdtdt(klon),
+     *       zdedt(klon),
+     *       zvidis(klon),
+     *       znu(klon),
+     *       zd1(klon),
+     *       zd2(klon),
+     *       zdmod(klon)
+      real ztmst, ptsphy, zrtmst 
+c
+c------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+c     ztmst=twodt
+c     if(nstep.eq.nstart) ztmst=0.5*twodt
+cym      klevm1=klev-1
+      ztmst=ptsphy
+      zrtmst=1./ztmst
+c     ------------------------------------------------------------------
+c
+ 120  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.3   check whether row contains point for printing
+c                ---------------------------------------------
+c
+ 130  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.     precompute basic state variables.
+c*                ---------- ----- ----- ----------
+c*                define low level wind, project winds in plane of
+c*                low level wind, determine sector in which to take
+c*                the variance and set indicator for critical levels.
+c
+  200 continue
+c
+c
+c
+      call orosetup
+     *     ( nlon, ktest 
+     *     , ikcrit, ikcrith, icrit,  ikenvh,iknu,iknu2
+     *     , paphm1, papm1 , pum1   , pvm1 , ptm1 , pgeom1, pstd
+     *     , zrho  , zri   , zstab  , ztau , zvph , zpsi, zzdep
+     *     , pulow, pvlow 
+     *     , ptheta,pgamma,pmea,ppic,pval,znu  ,zd1,  zd2,  zdmod )
+c
+c
+c
+c***********************************************************
+c
+c
+c*         3.      compute low level stresses using subcritical and
+c*                 supercritical forms.computes anisotropy coefficient
+c*                 as measure of orographic twodimensionality.
+c
+  300 continue
+c
+      call gwstress
+     *    ( nlon  , nlev
+     *    , ktest , icrit, ikenvh, iknu
+     *    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic
+     *    , ztau 
+     *    , pgeom1,zdmod)
+c
+c
+c*         4.      compute stress profile.
+c*                 ------- ------ --------
+c
+  400 continue
+c
+c
+      call gwprofil
+     *       (  nlon , nlev
+     *       , kgwd   , kdx , ktest
+     *       , ikcrith, icrit
+     *       , paphm1, zrho   , zstab ,  zvph
+     *       , zri   , ztau   
+     *       , zdmod , psig  , pstd)
+c
+c
+c*         5.      compute tendencies.
+c*                 -------------------
+c
+  500 continue
+c
+c  explicit solution at all levels for the gravity wave
+c  implicit solution for the blocked levels
+
+      do 510 jl=kidia,kfdia
+      zvidis(jl)=0.0
+      zdudt(jl)=0.0
+      zdvdt(jl)=0.0
+      zdtdt(jl)=0.0
+  510 continue
+c
+      ilevp1=klev+1
+c
+c
+      do 524 jk=1,klev
+c
+c
+c     do 523 jl=1,kgwd
+c     ji=kdx(jl)
+c  Modif vectorisation 02/04/2004
+      do 523 ji=kidia,kfdia
+      if(ktest(ji).eq.1) then
+
+      zdelp=paphm1(ji,jk+1)-paphm1(ji,jk)
+      ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,ilevp1)*zdelp)
+      zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
+      zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
+c
+c controle des overshoots:
+c
+      zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2)+1.E-12
+      ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst+1.E-12
+      rover=0.25
+      if(zforc.ge.rover*ztend)then
+        zdudt(ji)=rover*ztend/zforc*zdudt(ji)
+        zdvdt(ji)=rover*ztend/zforc*zdvdt(ji)
+      endif
+c
+c fin du controle des overshoots
+c
+      if(jk.ge.ikenvh(ji)) then
+         zb=1.0-0.18*pgamma(ji)-0.04*pgamma(ji)**2
+         zc=0.48*pgamma(ji)+0.3*pgamma(ji)**2
+         zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji))
+         zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
+         zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2
+	     ratio=(cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji,jk))**2)/
+     *   (pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
+         zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv
+c
+c simplement oppose au vent
+c
+         zdudt(ji)=-pum1(ji,jk)/ztmst
+         zdvdt(ji)=-pvm1(ji,jk)/ztmst
+c
+c  projection dans la direction de l'axe principal de l'orographie
+cmod     zdudt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+cmod *              *cos(ptheta(ji)*rpi/180.)/ztmst
+cmod     zdvdt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+cmod *              *sin(ptheta(ji)*rpi/180.)/ztmst
+         zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet))
+         zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet))
+      end if
+      pvom(ji,jk)=zdudt(ji)
+      pvol(ji,jk)=zdvdt(ji)
+      zust=pum1(ji,jk)+ztmst*zdudt(ji)
+      zvst=pvm1(ji,jk)+ztmst*zdvdt(ji)
+      zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
+      zdedt(ji)=zdis/ztmst
+      zvidis(ji)=zvidis(ji)+zdis*zdelp
+      zdtdt(ji)=zdedt(ji)/rcpd
+c     pte(ji,jk)=zdtdt(ji)
+c
+c  ENCORE UN TRUC POUR EVITER LES EXPLOSIONS
+c
+      pte(ji,jk)=0.0
+
+      endif
+  523 continue
+
+  524 continue
+c
+c
+      return
+      end
+      SUBROUTINE orosetup
+     *         ( nlon   , ktest
+     *         , kkcrit, kkcrith, kcrit
+     *         , kkenvh, kknu  , kknu2
+     *         , paphm1, papm1 , pum1   , pvm1 , ptm1  , pgeom1, pstd
+     *         , prho  , pri   , pstab  , ptau , pvph  ,ppsi, pzdep
+     *         , pulow , pvlow  
+     *         , ptheta, pgamma, pmea, ppic, pval
+     *         , pnu  ,  pd1  ,  pd2  ,pdmod  )
+c
+c**** *gwsetup*
+c
+c     purpose.
+c     --------
+c
+c**   interface.
+c     ----------
+c          from *orodrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c        see ecmwf research department documentation of the "i.f.s."
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f.lott  for the new-gwdrag scheme november 1993
+c
+c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+c
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer nlon
+      integer jl, jk
+      real zdelp
+
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),
+     *        ktest(nlon),kkenvh(nlon)
+
+c
+      real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev),
+     *     pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev),
+     *     prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1),
+     *     ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1),
+     *     pzdep(nlon,klev)
+       real pulow(nlon),pvlow(nlon),ptheta(nlon),pgamma(nlon),pnu(nlon),
+     *     pd1(nlon),pd2(nlon),pdmod(nlon)
+      real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+c
+c
+      integer ilevm1, ilevm2, ilevh
+      real zcons1, zcons2,zcons3, zhgeo
+      real zu, zphi, zvt1,zvt2, zst, zvar, zdwind, zwind
+      real zstabm, zstabp, zrhom,  zrhop, alpha
+      real zggeenv, zggeom1,zgvar 
+      logical lo 
+      logical ll1(klon,klev+1)
+      integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon),
+     *        kentp(klon),ncount(klon)  
+c
+      real zhcrit(klon,klev),zvpf(klon,klev),
+     *     zdp(klon,klev)
+      real znorm(klon),zb(klon),zc(klon),
+     *      zulow(klon),zvlow(klon),znup(klon),znum(klon)
+c
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+c     print *,' entree gwsetup'
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+      ilevm1=klev-1
+      ilevm2=klev-2
+      ilevh =klev/3
+c
+      zcons1=1./rd
+cold  zcons2=g**2/cpd
+      zcons2=rg**2/rcpd
+cold  zcons3=1.5*api
+      zcons3=1.5*rpi
+c
+c
+c     ------------------------------------------------------------------
+c
+c*         2.
+c                --------------
+c
+ 200  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.1     define low level wind, project winds in plane of
+c*                 low level wind, determine sector in which to take
+c*                 the variance and set indicator for critical levels.
+c
+c
+c
+      do 2001 jl=kidia,kfdia
+      kknu(jl)    =klev
+      kknu2(jl)   =klev
+      kknub(jl)   =klev
+      kknul(jl)   =klev
+      pgamma(jl) =max(pgamma(jl),gtsec)
+      ll1(jl,klev+1)=.false.
+ 2001 continue
+c
+c Ajouter une initialisation (L. Li, le 23fev99):
+c
+      do jk=klev,ilevh,-1
+      do jl=kidia,kfdia
+      ll1(jl,jk)= .FALSE.
+      ENDDO
+      ENDDO
+c
+c*      define top of low level flow
+c       ----------------------------
+      do 2002 jk=klev,ilevh,-1
+      do 2003 jl=kidia,kfdia
+      lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr
+      if(lo) then
+        kkcrit(jl)=jk
+      endif
+      zhcrit(jl,jk)=ppic(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu(jl)=ilevh
+ 2003 continue
+ 2002 continue
+      do 2004 jk=klev,ilevh,-1
+      do 2005 jl=kidia,kfdia
+      zhcrit(jl,jk)=ppic(jl)-pval(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu2(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh
+ 2005 continue
+ 2004 continue
+      do 2006 jk=klev,ilevh,-1
+      do 2007 jl=kidia,kfdia
+      zhcrit(jl,jk)=amax1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl))
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknub(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknub(jl)=ilevh
+ 2007 continue
+ 2006 continue
+c
+      do 2010 jl=kidia,kfdia  
+      kknu(jl)=min(kknu(jl),nktopg)
+      kknu2(jl)=min(kknu2(jl),nktopg)
+      kknub(jl)=min(kknub(jl),nktopg)
+      kknul(jl)=klev
+ 2010 continue      
+c
+
+ 210  continue
+c
+c
+cc*     initialize various arrays
+c
+      do 2107 jl=kidia,kfdia
+      prho(jl,klev+1)  =0.0
+      pstab(jl,klev+1) =0.0
+      pstab(jl,1)      =0.0
+      pri(jl,klev+1)   =9999.0
+      ppsi(jl,klev+1)  =0.0
+      pri(jl,1)        =0.0
+      pvph(jl,1)       =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      zulow(jl)        =0.0
+      zvlow(jl)        =0.0
+      kkcrith(jl)      =klev
+      kkenvh(jl)       =klev
+      kentp(jl)        =klev
+      kcrit(jl)        =1
+      ncount(jl)       =0
+      ll1(jl,klev+1)   =.false.
+ 2107 continue
+c
+c*     define low-level flow
+c      ---------------------
+c
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))*
+     *  (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+        pstab(jl,jk)=max(pstab(jl,jk),gssec)
+      endif
+  222 continue
+  223 continue
+c
+c********************************************************************
+c
+c*     define blocked flow
+c      -------------------
+      do 2115 jk=klev,ilevh,-1
+      do 2116 jl=kidia,kfdia
+      if(jk.ge.kknub(jl).and.jk.le.kknul(jl)) then
+        pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      end if
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+      pvph(jl,klev+1)=znorm(jl)
+ 2110 continue
+c
+c*******  setup orography axes and define plane of profiles  *******
+c
+      do 2112 jl=kidia,kfdia
+      lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec)
+      if(lo) then
+        zu=pulow(jl)+2.*gvsec
+      else
+        zu=pulow(jl)
+      endif
+      zphi=atan(pvlow(jl)/zu)
+      ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi
+      zb(jl)=1.-0.18*pgamma(jl)-0.04*pgamma(jl)**2
+      zc(jl)=0.48*pgamma(jl)+0.3*pgamma(jl)**2
+      pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
+      pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1))
+      pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2)
+ 2112 continue
+c
+c  ************ define flow in plane of lowlevel stress *************
+c
+      do 213 jk=1,klev
+      do 212 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        zvt1       =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk)
+        zvt2       =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk)
+        zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
+      endif
+      ptau(jl,jk)  =0.0
+      pzdep(jl,jk) =0.0
+      ppsi(jl,jk)  =0.0
+      ll1(jl,jk)   =.false.
+  212 continue
+  213 continue
+      do 215 jk=2,klev
+      do 214 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+
+     *            (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1))
+     *            /zdp(jl,jk)
+        if(pvph(jl,jk).lt.gvsec) then
+          pvph(jl,jk)=gvsec
+          kcrit(jl)=jk
+        endif
+      endif
+  214 continue
+  215 continue
+c
+c
+c*         2.2     brunt-vaisala frequency and density at half levels.
+c
+  220 continue
+c
+      do 2211 jk=ilevh,klev
+      do 221 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      if(jk.ge.(kknub(jl)+1).and.jk.le.kknul(jl)) then
+           zst=zcons2/ptm1(jl,jk)*(1.-rcpd*prho(jl,jk)*
+     *                   (ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+           pstab(jl,klev+1)=pstab(jl,klev+1)+zst*zdp(jl,jk)
+           pstab(jl,klev+1)=max(pstab(jl,klev+1),gssec)
+           prho(jl,klev+1)=prho(jl,klev+1)+paphm1(jl,jk)*2.*zdp(jl,jk)
+     *                   *zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+      endif
+      endif
+  221 continue
+ 2211 continue
+c
+      do 2212 jl=kidia,kfdia
+        pstab(jl,klev+1)=pstab(jl,klev+1)/(papm1(jl,kknul(jl))
+     *                                          -papm1(jl,kknub(jl)))
+        prho(jl,klev+1)=prho(jl,klev+1)/(papm1(jl,kknul(jl))
+     *                                          -papm1(jl,kknub(jl)))
+        zvar=pstd(jl)
+ 2212 continue
+c
+c*         2.3     mean flow richardson number.
+c*                 and critical height for froude layer
+c
+  230 continue
+c
+      do 232 jk=2,klev
+      do 231 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec)
+        pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk)
+     *          /(rg*prho(jl,jk)*zdwind))**2
+        pri(jl,jk)=max(pri(jl,jk),grcrit)
+      endif
+  231 continue
+  232 continue
+  
+c
+c
+c*      define top of 'envelope' layer
+c       ----------------------------
+
+      do 233 jl=kidia,kfdia
+      pnu (jl)=0.0
+      znum(jl)=0.0
+ 233  continue
+      
+      do 234 jk=2,klev-1
+      do 234 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+       
+      if (jk.ge.kknub(jl)) then
+          
+            znum(jl)=pnu(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            pnu(jl) = pnu(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit)
+     *                          .and.(kkenvh(jl).eq.klev))
+     *      kkenvh(jl)=jk
+     
+      endif    
+
+      endif
+      
+ 234  continue
+      
+c  calculation of a dynamical mixing height for the breaking
+c  of gravity waves:
+
+              
+      do 235 jl=kidia,kfdia
+      znup(jl)=0.0
+      znum(jl)=0.0
+ 235  continue
+
+      do 236 jk=klev-1,2,-1
+      do 236 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+
+            znum(jl)=znup(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            znup(jl) = znup(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.rpi/2.).and.(znup(jl).gt.rpi/2.)
+     *                          .and.(kkcrith(jl).eq.klev))
+     *      kkcrith(jl)=jk
+     
+      endif
+      
+ 236  continue
+ 
+      do 237 jl=kidia,kfdia
+      kkcrith(jl)=min0(kkcrith(jl),kknu2(jl))
+      kkcrith(jl)=max0(kkcrith(jl),ilevh*2)
+ 237  continue         
+c
+c     directional info for flow blocking ************************* 
+c
+      do 251 jk=ilevh,klev    
+      do 252 jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+      lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec)
+      if(lo) then
+        zu=pum1(jl,jk)+2.*gvsec
+      else
+        zu=pum1(jl,jk)
+      endif
+       zphi=atan(pvm1(jl,jk)/zu)
+       ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi
+      end if
+ 252  continue
+ 251  continue
+c      forms the vertical 'leakiness' **************************
+
+      alpha=3.
+      
+      do 254  jk=ilevh,klev
+      do 253  jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+        zggeenv=amax1(1.,
+     *          (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)-1))/2.)      
+        zggeom1=amax1(pgeom1(jl,jk),1.)
+        zgvar=amax1(pstd(jl)*rg,1.)     
+cmod    pzdep(jl,jk)=sqrt((zggeenv-zggeom1)/(zggeom1+zgvar))      
+        pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,  jk))/
+     *               (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,klev))
+      end if
+ 253  continue
+ 254  continue
+
+ 260  continue
+
+      return
+      end
+      SUBROUTINE gwstress
+     *         (  nlon  , nlev
+     *         , ktest, kcrit, kkenvh
+     *         , kknu
+     *         , prho  , pstab , pvph  , pstd, psig
+     *         , pmea , ppic  , ptau  
+     *         , pgeom1 , pdmod )
+c
+c**** *gwstress*
+c
+c     purpose.
+c     --------
+c
+c**   interface.
+c     ----------
+c     call *gwstress*  from *gwdrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c        see ecmwf research department documentation of the "i.f.s."
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f. lott put the new gwd on ifs      22/11/93
+c
+c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer nlon, nlev
+      integer kcrit(nlon),
+     *        ktest(nlon),kkenvh(nlon),kknu(nlon)
+c
+      real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1),
+     *     pvph(nlon,nlev+1),
+     *     pgeom1(nlon,nlev),pstd(nlon)
+c
+      real psig(nlon)
+      real pmea(nlon),ppic(nlon)
+      real pdmod(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+      integer jl
+      real zblock, zvar, zeff
+      logical lo
+c
+c-----------------------------------------------------------------------
+c
+c*       0.3   functions
+c              ---------
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+ 100  continue
+c
+c*         3.1     gravity wave stress.
+c
+  300 continue
+c
+c
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      
+c  effective mountain height above the blocked flow
+  
+         if(kkenvh(jl).eq.klev)then
+         zblock=0.0 
+         else
+         zblock=(pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg          
+         endif
+      
+        zvar=ppic(jl)-pmea(jl)
+        zeff=amax1(0.,zvar-zblock)
+
+        ptau(jl,klev+1)=prho(jl,klev+1)*gkdrag*psig(jl)*zeff**2
+     *    /4./pstd(jl)*pvph(jl,klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1))
+
+c  too small value of stress or  low level flow include critical level
+c  or low level flow:  gravity wave stress nul.
+                
+        lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl))
+     *      .or.(pvph(jl,klev+1).lt.gvcrit)
+c       if(lo) ptau(jl,klev+1)=0.0
+      
+      else
+      
+          ptau(jl,klev+1)=0.0
+          
+      endif
+      
+  301 continue
+c
+      return
+      end
+      SUBROUTINE GWPROFIL
+     *         ( NLON, NLEV
+     *         , kgwd, kdx , ktest
+     *         , KKCRITH, KCRIT
+     *         , PAPHM1, PRHO   , PSTAB  , PVPH , PRI , PTAU
+     *         , pdmod   , psig , pvar)
+
+C**** *GWPROFIL*
+C
+C     PURPOSE.
+C     --------
+C
+C**   INTERFACE.
+C     ----------
+C          FROM *GWDRAG*
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C     ==== OUTPUTS ===
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD:
+C     -------
+C     THE STRESS PROFILE FOR GRAVITY WAVES IS COMPUTED AS FOLLOWS:
+C     IT IS CONSTANT (NO GWD) AT THE LEVELS BETWEEN THE GROUND
+C     AND THE TOP OF THE BLOCKED LAYER (KKENVH).
+C     IT DECREASES LINEARLY WITH HEIGHTS FROM THE TOP OF THE 
+C     BLOCKED LAYER TO 3*VAROR (kKNU), TO SIMULATES LEE WAVES OR 
+C     NONLINEAR GRAVITY WAVE BREAKING.
+C     ABOVE IT IS CONSTANT, EXCEPT WHEN THE WAVE ENCOUNTERS A CRITICAL
+C     LEVEL (KCRIT) OR WHEN IT BREAKS.
+C     
+C
+C
+C     EXTERNALS.
+C     ----------
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S."
+C
+C     AUTHOR.
+C     -------
+C
+C     MODIFICATIONS.
+C     --------------
+C     PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93)
+C-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+C
+
+C
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      integer nlon,nlev
+      INTEGER KKCRITH(NLON),KCRIT(NLON)
+     *       ,kdx(nlon) , ktest(nlon)
+
+C
+      REAL PAPHM1(NLON,NLEV+1), PSTAB(NLON,NLEV+1),
+     *     PRHO  (NLON,NLEV+1), PVPH (NLON,NLEV+1),
+     *     PRI   (NLON,NLEV+1), PTAU(NLON,NLEV+1)
+     
+      REAL pdmod (NLON) , psig(NLON),
+     *     pvar(NLON)
+     
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+C
+      integer ilevh, ji, kgwd, jl, jk
+      real zsqr, zalfa, zriw, zdel, zb, zalpha,zdz2n
+      real zdelp, zdelpt 
+      REAL ZDZ2 (KLON,KLEV) , ZNORM(KLON) , zoro(KLON)
+      REAL ZTAU (KLON,KLEV+1)
+C
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+c      print *,' entree gwprofil' 
+ 100  CONTINUE
+C
+C
+C*    COMPUTATIONAL CONSTANTS.
+C     ------------- ----------
+C
+      ilevh=KLEV/3
+C
+c     DO 400 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      DO 400 jl=kidia,kfdia
+      if (ktest(jl).eq.1) then
+      Zoro(JL)=Psig(JL)*Pdmod(JL)/4./max(pvar(jl),1.0)
+      ZTAU(JL,KLEV+1)=PTAU(JL,KLEV+1)
+      endif
+  400 CONTINUE
+  
+C
+      DO 430 JK=KLEV,2,-1
+C
+C
+C*         4.1    CONSTANT WAVE STRESS UNTIL TOP OF THE
+C                 BLOCKING LAYER.
+  410 CONTINUE
+C
+c     DO 411 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 411 jl=kidia,kfdia
+      if (ktest(jl).eq.1) then
+           IF(JK.GT.KKCRITH(JL)) THEN
+           PTAU(JL,JK)=ZTAU(JL,KLEV+1)
+C          ENDIF
+C          IF(JK.EQ.KKCRITH(JL)) THEN
+           ELSE                    
+           PTAU(JL,JK)=GRAHILO*ZTAU(JL,KLEV+1)
+           ENDIF
+      endif
+ 411  CONTINUE             
+C
+C*         4.15   CONSTANT SHEAR STRESS UNTIL THE TOP OF THE
+C                 LOW LEVEL FLOW LAYER.
+ 415  CONTINUE
+C        
+C
+C*         4.2    WAVE DISPLACEMENT AT NEXT LEVEL.
+C
+  420 CONTINUE
+C
+c     DO 421 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 421 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      IF(JK.LT.KKCRITH(JL)) THEN
+      ZNORM(JL)=gkdrag*PRHO(JL,JK)*SQRT(PSTAB(JL,JK))*PVPH(JL,JK)
+     *                                                    *zoro(jl)
+      ZDZ2(JL,JK)=PTAU(JL,JK+1)/max(ZNORM(JL),gssec)
+      ENDIF
+      endif
+  421 CONTINUE
+C
+C*         4.3    WAVE RICHARDSON NUMBER, NEW WAVE DISPLACEMENT
+C*                AND STRESS:  BREAKING EVALUATION AND CRITICAL 
+C                 LEVEL
+C
+                          
+c     DO 431 ji=1,kgwd
+c     jl=Kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 431 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+          IF(JK.LT.KKCRITH(JL)) THEN
+          IF((PTAU(JL,JK+1).LT.GTSEC).OR.(JK.LE.KCRIT(JL))) THEN
+            PTAU(JL,JK)=0.0
+          ELSE
+               ZSQR=SQRT(PRI(JL,JK))
+               ZALFA=SQRT(PSTAB(JL,JK)*ZDZ2(JL,JK))/PVPH(JL,JK)
+               ZRIW=PRI(JL,JK)*(1.-ZALFA)/(1+ZALFA*ZSQR)**2
+               IF(ZRIW.LT.GRCRIT) THEN
+                 ZDEL=4./ZSQR/GRCRIT+1./GRCRIT**2+4./GRCRIT
+                 ZB=1./GRCRIT+2./ZSQR
+                 ZALPHA=0.5*(-ZB+SQRT(ZDEL))
+                 ZDZ2N=(PVPH(JL,JK)*ZALPHA)**2/PSTAB(JL,JK)
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2N
+               ELSE
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2(JL,JK)
+               ENDIF
+            PTAU(JL,JK)=MIN(PTAU(JL,JK),PTAU(JL,JK+1))
+          ENDIF
+          ENDIF
+      endif
+  431 CONTINUE
+  
+  430 CONTINUE
+  440 CONTINUE
+  
+C  REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
+
+c     DO 530 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      ZTAU(JL,KKCRITH(JL))=PTAU(JL,KKCRITH(JL))
+      ZTAU(JL,NSTRA)=PTAU(JL,NSTRA)
+      endif
+ 530  CONTINUE      
+
+      DO 531 JK=1,KLEV
+      
+c     DO 532 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 532 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+                
+         IF(JK.GT.KKCRITH(JL))THEN
+
+          ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KLEV+1    )
+          ZDELPT=PAPHM1(JL,KKCRITH(JL))-PAPHM1(JL,KLEV+1    )
+          PTAU(JL,JK)=ZTAU(JL,KLEV+1    ) +
+     .                (ZTAU(JL,KKCRITH(JL))-ZTAU(JL,KLEV+1    ) )*
+     .                ZDELP/ZDELPT
+     
+        ENDIF
+            
+      endif
+ 532  CONTINUE    
+ 
+C  REORGANISATION IN THE STRATOSPHERE
+
+c     DO 533 ji=1,kgwd
+c     jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 533 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+
+         IF(JK.LT.NSTRA)THEN
+
+          ZDELP =PAPHM1(JL,NSTRA)
+          ZDELPT=PAPHM1(JL,JK)
+          PTAU(JL,JK)=ZTAU(JL,NSTRA)*ZDELPT/ZDELP 
+
+        ENDIF
+
+      endif
+ 533  CONTINUE
+
+C REORGANISATION IN THE TROPOSPHERE
+
+c      DO 534 ji=1,kgwd
+c      jl=kdx(ji)
+c  Modif vectorisation 02/04/2004
+      do 534 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+
+         IF(JK.LT.KKCRITH(JL).AND.JK.GT.NSTRA)THEN
+
+           ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KKCRITH(JL))
+           ZDELPT=PAPHM1(JL,NSTRA)-PAPHM1(JL,KKCRITH(JL))
+           PTAU(JL,JK)=ZTAU(JL,KKCRITH(JL)) +
+     *                 (ZTAU(JL,NSTRA)-ZTAU(JL,KKCRITH(JL)))*ZDELP
+     .                                                     /ZDELPT
+
+       ENDIF
+      endif
+ 534   CONTINUE
+
+ 
+ 531  CONTINUE        
+
+
+      RETURN
+      END
+      SUBROUTINE lift_noro (nlon,nlev,dtime,paprs,pplay,      
+     e                   plat,pmea,pstd, ppic,
+     e                   ktest,
+     e                   t, u, v,
+     s                   pulow, pvlow, pustr, pvstr,
+     s                   d_t, d_u, d_v)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Objet: Frottement de la montagne Interface
+c======================================================================
+c Arguments:
+c dtime---input-R- pas d'integration (s)
+c paprs---input-R-pression pour chaque inter-couche (en Pa)
+c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+c t-------input-R-temperature (K)
+c u-------input-R-vitesse horizontale (m/s)
+c v-------input-R-vitesse horizontale (m/s)
+c
+c d_t-----output-R-increment de la temperature
+c d_u-----output-R-increment de la vitesse u
+c d_v-----output-R-increment de la vitesse v
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL plat(nlon),pmea(nlon)
+      REAL pstd(nlon)
+      REAL ppic(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+c
+      INTEGER i, k, ktest(nlon)
+c
+c Variables locales:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+c
+c initialiser les variables de sortie (pour securite)
+c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+      CALL OROLIFT(klon,klev,ktest,
+     .            dtime,
+     .            papmh, zgeom,
+     .            pt, pu, pv,
+     .            plat,pmea, pstd, ppic,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+cIM BUG .                 +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+         pvstr(i)        = pvstr(i)
+cIM BUG .                 +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))
+     .                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+      SUBROUTINE OROLIFT( NLON,NLEV
+     I                 , KTEST
+     R                 , PTSPHY
+     R                 , PAPHM1,PGEOM1,PTM1,PUM1,PVM1
+     R                 , PLAT
+     R                 , PMEA, PVAROR, ppic
+C OUTPUTS
+     R                 , PULOW,PVLOW
+     R                 , PVOM,PVOL,PTE )
+
+C
+C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
+C
+C     PURPOSE.
+C     --------
+C
+C**   INTERFACE.
+C     ----------
+C          CALLED FROM *lift_noro
+C     ----------
+C
+C     AUTHOR.
+C     -------
+C     F.LOTT  LMD 22/11/95
+C
+      USE dimphy
+      implicit none
+C
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+C
+      integer nlon, nlev
+      REAL  PTE(NLON,NLEV),
+     *      PVOL(NLON,NLEV),
+     *      PVOM(NLON,NLEV),
+     *      PULOW(NLON),
+     *      PVLOW(NLON)
+      REAL  PUM1(NLON,NLEV),
+     *      PVM1(NLON,NLEV),
+     *      PTM1(NLON,NLEV),
+     *      PLAT(NLON),PMEA(NLON),
+     *      PVAROR(NLON),
+     *      ppic(NLON),
+     *      PGEOM1(NLON,NLEV),
+     *      PAPHM1(NLON,NLEV+1)
+C
+      INTEGER  KTEST(NLON)
+      real ptsphy
+C-----------------------------------------------------------------------
+C
+C*       0.2   LOCAL ARRAYS
+C              ------------
+      logical lifthigh
+cym      integer klevm1, jl, ilevh, jk
+      integer  jl, ilevh, jk
+      real zcons1, ztmst, zrtmst,zpi, zhgeo
+      real zdelp, zslow, zsqua, zscav, zbet
+      INTEGER  
+     *         IKNUB(klon),
+     *         IKNUL(klon)
+      LOGICAL LL1(KLON,KLEV+1)
+C
+      REAL   ZTAU(KLON,KLEV+1),
+     *       ZTAV(KLON,KLEV+1),
+     *       ZRHO(KLON,KLEV+1)
+      REAL   ZDUDT(KLON),
+     *       ZDVDT(KLON)
+      REAL ZHCRIT(KLON,KLEV)
+      CHARACTER (LEN=20) :: modname='orografi'
+      CHARACTER (LEN=80) :: abort_message
+C-----------------------------------------------------------------------
+C
+C*         1.1  INITIALIZATIONS
+C               ---------------
+
+      LIFTHIGH=.FALSE.
+
+      IF(NLON.NE.KLON.OR.NLEV.NE.KLEV)THEN
+        abort_message = 'pb dimension'
+        CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+      ZCONS1=1./RD
+cym      KLEVM1=KLEV-1
+      ZTMST=PTSPHY
+      ZRTMST=1./ZTMST
+      ZPI=ACOS(-1.)
+C
+      DO 1001 JL=kidia,kfdia
+      ZRHO(JL,KLEV+1)  =0.0
+      PULOW(JL)        =0.0
+      PVLOW(JL)        =0.0
+      iknub(JL)   =klev
+      iknul(JL)   =klev
+      ilevh=klev/3
+      ll1(jl,klev+1)=.false.
+      DO 1000 JK=1,KLEV
+      PVOM(JL,JK)=0.0
+      PVOL(JL,JK)=0.0
+      PTE (JL,JK)=0.0
+ 1000 CONTINUE
+ 1001 CONTINUE
+
+C
+C*         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
+C*                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
+C*                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
+C
+C
+C
+      DO 2006 JK=KLEV,1,-1
+      DO 2007 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZHCRIT(JL,JK)=amax1(Ppic(JL)-pmea(JL),100.)
+      ZHGEO=PGEOM1(JL,JK)/RG
+      ll1(JL,JK)=(ZHGEO.GT.ZHCRIT(JL,JK))
+      IF(ll1(JL,JK).neqv.ll1(JL,JK+1)) THEN
+        iknub(JL)=JK
+      ENDIF
+      ENDIF
+ 2007 CONTINUE
+ 2006 CONTINUE
+C
+      do 2010 jl=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      iknub(jl)=max(iknub(jl),klev/2)
+      iknul(jl)=max(iknul(jl),2*klev/3)
+      if(iknub(jl).gt.nktopg) iknub(jl)=nktopg
+      if(iknub(jl).eq.nktopg) iknul(jl)=klev
+      if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1
+      ENDIF
+ 2010 continue
+
+C     do 2011 jl=kidia,kfdia
+C     IF(KTEST(JL).EQ.1) THEN
+C       print *,' iknul= ',iknul(jl),'  iknub=',iknub(jl)
+C     ENDIF
+C2011 continue
+
+C     PRINT *,'  DANS OROLIFT: 2010'
+
+      DO 223 JK=KLEV,2,-1
+      DO 222 JL=kidia,kfdia
+        ZRHO(JL,JK)=2.*PAPHM1(JL,JK)*ZCONS1/(PTM1(JL,JK)+PTM1(JL,JK-1))
+  222 CONTINUE
+  223 CONTINUE
+C     PRINT *,'  DANS OROLIFT: 223'
+
+C********************************************************************
+C
+C*     DEFINE LOW LEVEL FLOW
+C      -------------------
+      DO 2115 JK=klev,1,-1
+      DO 2116 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then
+        pulow(JL)=pulow(JL)+PUM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        pvlow(JL)=pvlow(JL)+PVM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        zrho(JL,klev+1)=zrho(JL,klev+1)
+     *                 +zrho(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+      end if
+      ENDIF
+ 2116 CONTINUE
+ 2115 CONTINUE
+      DO 2110 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      pulow(JL)=pulow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      pvlow(JL)=pvlow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      zrho(JL,klev+1)=zrho(JL,klev+1)
+     *               /(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      ENDIF
+ 2110 CONTINUE
+
+
+200   CONTINUE
+
+C***********************************************************
+C
+C*         3.      COMPUTE MOUNTAIN LIFT
+C
+  300 CONTINUE
+C
+      DO 301 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+       ZTAU(JL,KLEV+1)= - GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*
+C    *                 (2*PVAROR(JL)+PMEA(JL))*
+     *                 2*PVAROR(JL)*
+     *                 SIN(ZPI/180.*PLAT(JL))*PVLOW(JL)
+       ZTAV(JL,KLEV+1)=   GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*
+C    *                 (2*PVAROR(JL)+PMEA(JL))*
+     *                 2*PVAROR(JL)*
+     *                 SIN(ZPI/180.*PLAT(JL))*PULOW(JL)
+      ELSE
+       ZTAU(JL,KLEV+1)=0.0
+       ZTAV(JL,KLEV+1)=0.0
+      ENDIF
+301   CONTINUE
+
+C
+C*         4.      COMPUTE LIFT PROFILE         
+C*                 --------------------   
+C
+
+  400 CONTINUE
+
+      DO 401 JK=1,KLEV
+      DO 401 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZTAU(JL,JK)=ZTAU(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ZTAV(JL,JK)=ZTAV(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ELSE
+      ZTAU(JL,JK)=0.0
+      ZTAV(JL,JK)=0.0
+      ENDIF
+401   CONTINUE
+C
+C
+C*         5.      COMPUTE TENDENCIES.
+C*                 -------------------
+      IF(LIFTHIGH)THEN
+C
+  500 CONTINUE
+C     PRINT *,'  DANS OROLIFT: 500'
+C
+C  EXPLICIT SOLUTION AT ALL LEVELS
+C
+      DO 524 JK=1,klev
+      DO 523 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+      ZDELP=PAPHM1(JL,JK+1)-PAPHM1(JL,JK)
+      ZDUDT(JL)=-RG*(ZTAU(JL,JK+1)-ZTAU(JL,JK))/ZDELP
+      ZDVDT(JL)=-RG*(ZTAV(JL,JK+1)-ZTAV(JL,JK))/ZDELP
+      ENDIF  
+  523 CONTINUE
+  524 CONTINUE
+C
+C  PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
+C
+      DO 530 JK=1,klev
+      DO 530 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+
+        ZSLOW=SQRT(PULOW(JL)**2+PVLOW(JL)**2)
+        ZSQUA=AMAX1(SQRT(PUM1(JL,JK)**2+PVM1(JL,JK)**2),GVSEC)
+        ZSCAV=-ZDUDT(JL)*PVM1(JL,JK)+ZDVDT(JL)*PUM1(JL,JK)
+        IF(ZSQUA.GT.GVSEC)THEN
+          PVOM(JL,JK)=-ZSCAV*PVM1(JL,JK)/ZSQUA**2
+          PVOL(JL,JK)= ZSCAV*PUM1(JL,JK)/ZSQUA**2
+        ELSE
+          PVOM(JL,JK)=0.0
+          PVOL(JL,JK)=0.0      
+        ENDIF  
+        ZSQUA=SQRT(PUM1(JL,JK)**2+PUM1(JL,JK)**2)               
+        IF(ZSQUA.LT.ZSLOW)THEN
+          PVOM(JL,JK)=ZSQUA/ZSLOW*PVOM(JL,JK)
+          PVOL(JL,JK)=ZSQUA/ZSLOW*PVOL(JL,JK)
+        ENDIF 
+
+      ENDIF  
+530   CONTINUE
+C
+C  6.  LOW LEVEL LIFT, SEMI IMPLICIT:
+C  ----------------------------------
+
+      ELSE
+
+        DO 601 JL=KIDIA,KFDIA
+        IF(KTEST(JL).EQ.1) THEN
+          DO JK=KLEV,IKNUB(JL),-1
+          ZBET=GKLIFT*2.*ROMEGA*SIN(ZPI/180.*PLAT(JL))*ztmst*
+     *        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,  JK))/
+     *        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,KLEV))
+          ZDUDT(JL)=-PUM1(JL,JK)/ztmst/(1+ZBET**2)
+          ZDVDT(JL)=-PVM1(JL,JK)/ztmst/(1+ZBET**2)
+          PVOM(JL,JK)= ZBET**2*ZDUDT(JL) - ZBET   *ZDVDT(JL)
+          PVOL(JL,JK)= ZBET   *ZDUDT(JL) + ZBET**2*ZDVDT(JL)    
+          ENDDO
+        ENDIF
+ 601    CONTINUE
+
+      ENDIF
+
+      RETURN
+      END
+
+
+      SUBROUTINE SUGWD(NLON,NLEV,paprs,pplay)
+      USE dimphy
+      USE mod_phys_lmdz_para
+      USE mod_grid_phy_lmdz
+c      USE parallel
+C
+C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
+C
+C     PURPOSE.
+C     --------
+C           INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
+C           GRAVITY WAVE DRAG PARAMETRIZATION.
+C
+C**   INTERFACE.
+C     ----------
+C        CALL *SUGWD* FROM *SUPHEC*
+C              -----        ------
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C        PSIG        : VERTICAL COORDINATE TABLE
+C        NLEV        : NUMBER OF MODEL LEVELS
+C
+C        IMPLICIT ARGUMENTS :
+C        --------------------
+C        COMMON YOEGWD
+C
+C     METHOD.
+C     -------
+C        SEE DOCUMENTATION
+C
+C     EXTERNALS.
+C     ----------
+C        NONE
+C
+C     REFERENCE.
+C     ----------
+C        ECMWF Research Department documentation of the IFS
+C
+C     AUTHOR.
+C     -------
+C        MARTIN MILLER             *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 90-01-01
+C     ------------------------------------------------------------------
+      implicit none
+C
+C     -----------------------------------------------------------------
+#include "YOEGWD.h"
+C      ----------------------------------------------------------------
+C
+      integer nlon,nlev, jk
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+      real zpr,zstra,zsigt,zpm1r
+      REAL :: pplay_glo(klon_glo,nlev)
+      REAL :: paprs_glo(klon_glo,nlev+1)
+
+C
+C*       1.    SET THE VALUES OF THE PARAMETERS
+C              --------------------------------
+C
+ 100  CONTINUE
+C
+      PRINT *,' DANS SUGWD NLEV=',NLEV
+      GHMAX=10000.
+C
+      ZPR=100000.
+      ZSTRA=0.1 
+      ZSIGT=0.94
+cold  ZPR=80000.
+cold  ZSIGT=0.85
+C
+      
+      CALL gather(pplay,pplay_glo)
+      CALL bcast(pplay_glo)
+      CALL gather(paprs,paprs_glo)
+      CALL bcast(paprs_glo)
+      
+            
+      DO 110 JK=1,NLEV
+      ZPM1R=pplay_glo((klon_glo/2)+1,jk)/paprs_glo((klon_glo/2)+1,1) 
+      IF(ZPM1R.GE.ZSIGT)THEN
+         nktopg=JK
+      ENDIF
+      ZPM1R=pplay_glo((klon_glo/2)+1,jk)/paprs_glo((klon_glo/2)+1,1) 
+      IF(ZPM1R.GE.ZSTRA)THEN
+         NSTRA=JK
+      ENDIF
+  110 CONTINUE
+
+
+c
+c  inversion car dans orodrag on compte les niveaux a l'envers
+      nktopg=nlev-nktopg+1
+      nstra=nlev-nstra
+      print *,' DANS SUGWD nktopg=', nktopg
+      print *,' DANS SUGWD nstra=', nstra
+C
+      GSIGCR=0.80
+C
+      GKDRAG=0.2 
+      GRAHILO=1.    
+      GRCRIT=0.01
+      GFRCRIT=1.0
+      GKWAKE=0.50 
+C
+      GKLIFT=0.50  
+      GVCRIT =0.0
+C
+C
+C      ----------------------------------------------------------------
+C
+C*       2.    SET VALUES OF SECURITY PARAMETERS
+C              ---------------------------------
+C
+ 200  CONTINUE
+C
+      GVSEC=0.10
+      GSSEC=1.E-12
+C
+      GTSEC=1.E-07
+C
+C      ----------------------------------------------------------------
+C
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi.F90	(revision 17)
@@ -0,0 +1,1865 @@
+!
+! $Id: orografi.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+MODULE orografi
+
+  CONTAINS
+
+      SUBROUTINE drag_noro (nlon,nlev,dtime,paprs,pplay,                             &
+       &                   pmea,pstd, psig, pgam, pthe,ppic,pval,                    &
+       &                   kgwd,kdx,ktest,                                           &
+       &                   t, u, v,                                                  &
+       &                   pulow, pvlow, pustr, pvstr,                               &
+       &                   d_t, d_u, d_v)
+!c
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+!c Objet: Frottement de la montagne Interface
+!c======================================================================
+!c Arguments:
+!c dtime---input-R- pas d'integration (s)
+!c paprs---input-R-pression pour chaque inter-couche (en Pa)
+!c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+!c t-------input-R-temperature (K)
+!c u-------input-R-vitesse horizontale (m/s)
+!c v-------input-R-vitesse horizontale (m/s)
+!c
+!c d_t-----output-R-increment de la temperature             
+!c d_u-----output-R-increment de la vitesse u
+!c d_v-----output-R-increment de la vitesse v
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c
+!c ARGUMENTS
+!c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+!c
+      INTEGER i, k, kgwd, kdx(nlon), ktest(nlon)
+!c
+!c Variables locales:
+!c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+!c
+!c initialiser les variables de sortie (pour securite)
+!c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+!c
+!c preparer les variables d'entree (attention: l'ordre des niveaux 
+!c verticaux augmente du haut vers le bas)
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)                                             &
+       &                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0                    &
+       &               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+!c
+!c appeler la routine principale
+!c
+      CALL orodrag(klon,klev,kgwd,kdx,ktest,                                         &
+       &            dtime,                                                           &
+       &            papmh, papmf, zgeom,                                             &
+       &            pt, pu, pv,                                                      &
+       &            pmea, pstd, psig, pgam, pthe, ppic,pval,                         &
+       &            pulow,pvlow,                                                     &
+       &            pdudt,pdvdt,pdtdt)
+!C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)                                                  &
+!IM BUG  .                +rg*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))                   &
+       &                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+         pvstr(i)        = pvstr(i)                                                  &
+!IM BUG  .                +rg*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))                   &
+       &                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+      ENDDO
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE drag_noro
+
+      SUBROUTINE orodrag( nlon,nlev                                                  &
+       &                 , kgwd, kdx, ktest                                          &
+       &                 , ptsphy                                                    &
+       &                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1                        &
+       &                 , pmea, pstd, psig, pgamma, ptheta, ppic, pval              &
+!c outputs                                                                           &
+       &                 , pulow,pvlow                                               &
+       &                 , pvom,pvol,pte )
+
+      USE dimphy
+      implicit none
+
+!c
+!c
+!c**** *gwdrag* - does the gravity wave parametrization.
+!c
+!c     purpose.
+!c     --------
+!c
+!c          this routine computes the physical tendencies of the
+!c     prognostic variables u,v  and t due to  vertical transports by
+!c     subgridscale orographically excited gravity waves
+!c
+!c**   interface.
+!c     ----------
+!c          called from *callpar*.
+!c
+!c          the routine takes its input from the long-term storage:
+!c          u,v,t and p at t-1.
+!c
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c     ==== outputs ===
+!c
+!c        implicit arguments :   none
+!c        --------------------
+!c
+!c      implicit logical (l)
+!c
+!c     method.
+!c     -------
+!c
+!c     externals.
+!c     ----------
+      integer ismin, ismax
+      external ismin, ismax
+!c
+!c     reference.
+!c     ----------
+!c
+!c     author.
+!c     -------
+!c     m.miller + b.ritter   e.c.m.w.f.     15/06/86.
+!c
+!c     f.lott + m. miller    e.c.m.w.f.     22/11/94
+!c-----------------------------------------------------------------------
+!c
+!c
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+!c-----------------------------------------------------------------------
+!c
+!c*       0.1   arguments
+!c              ---------
+!c
+!c
+!cym      integer nlon, nlev, klevm1
+      integer nlon, nlev
+      integer kgwd, jl, ilevp1, jk, ji
+      real zdelp, ztemp, zforc, ztend
+      real rover, zb, zc, zconb, zabsv
+      real zzd1, ratio, zbet, zust,zvst, zdis
+      real  pte(nlon,nlev),                                                          &
+       &      pvol(nlon,nlev),                                                       &
+       &      pvom(nlon,nlev),                                                       &
+       &      pulow(klon),                                                           &
+       &      pvlow(klon)
+      real  pum1(nlon,nlev),                                                         &
+       &      pvm1(nlon,nlev),                                                       &
+       &      ptm1(nlon,nlev),                                                       &
+       &      pmea(nlon),pstd(nlon),psig(nlon),                                      &
+       &      pgamma(nlon),ptheta(nlon),ppic(nlon),pval(nlon),                       &
+       &      pgeom1(nlon,nlev),                                                     &
+       &      papm1(nlon,nlev),                                                      &
+       &      paphm1(nlon,nlev+1)
+!c
+      integer  kdx(nlon),ktest(nlon)
+!c-----------------------------------------------------------------------
+!c
+!c*       0.2   local arrays
+!c              ------------
+      integer  isect(klon),                                                          &
+       &         icrit(klon),                                                        &
+       &         ikcrith(klon),                                                      &
+       &         ikenvh(klon),                                                       &
+       &         iknu(klon),                                                         &
+       &         iknu2(klon),                                                        &
+       &         ikcrit(klon),                                                       &
+       &         ikhlim(klon)
+!c
+      real   ztau(klon,klev+1),                                                      &
+       &       ztauf(klon,klev+1),                                                   &
+       &       zstab(klon,klev+1),                                                   &
+       &       zvph(klon,klev+1),                                                    &
+       &       zrho(klon,klev+1),                                                    &
+       &       zri(klon,klev+1),                                                     &
+       &       zpsi(klon,klev+1),                                                    &
+       &       zzdep(klon,klev)
+      real   zdudt(klon),                                                            &
+       &       zdvdt(klon),                                                          &
+       &       zdtdt(klon),                                                          &
+       &       zdedt(klon),                                                          &
+       &       zvidis(klon),                                                         &
+       &       znu(klon),                                                            &
+       &       zd1(klon),                                                            &
+       &       zd2(klon),                                                            &
+       &       zdmod(klon)
+      real ztmst, ptsphy, zrtmst 
+!c
+!c------------------------------------------------------------------
+!c
+!c*         1.    initialization
+!c                --------------
+!c
+ 100  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.1   computational constants
+!c                -----------------------
+!c
+ 110  continue
+!c
+!c     ztmst=twodt
+!c     if(nstep.eq.nstart) ztmst=0.5*twodt
+!cym      klevm1=klev-1
+      ztmst=ptsphy
+      zrtmst=1./ztmst
+!c     ------------------------------------------------------------------
+!c
+ 120  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.3   check whether row contains point for printing
+!c                ---------------------------------------------
+!c
+ 130  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         2.     precompute basic state variables.
+!c*                ---------- ----- ----- ----------
+!c*                define low level wind, project winds in plane of
+!c*                low level wind, determine sector in which to take
+!c*                the variance and set indicator for critical levels.
+!c
+  200 continue
+!c
+!c
+!c
+      call orosetup                                                                  &
+       &     ( nlon, ktest                                                           &
+       &     , ikcrit, ikcrith, icrit,  ikenvh,iknu,iknu2                            &
+       &     , paphm1, papm1 , pum1   , pvm1 , ptm1 , pgeom1, pstd                   &
+       &     , zrho  , zri   , zstab  , ztau , zvph , zpsi, zzdep                    &
+       &     , pulow, pvlow                                                          &
+       &     , ptheta,pgamma,pmea,ppic,pval,znu  ,zd1,  zd2,  zdmod )
+!c
+!c
+!c
+!c***********************************************************
+!c
+!c
+!c*         3.      compute low level stresses using subcritical and
+!c*                 supercritical forms.computes anisotropy coefficient
+!c*                 as measure of orographic twodimensionality.
+!c
+  300 continue
+!c
+      call gwstress                                                                  &
+       &    ( nlon  , nlev                                                           &
+       &    , ktest , icrit, ikenvh, iknu                                            &
+       &    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic                         &
+       &    , ztau                                                                   &
+       &    , pgeom1,zdmod)
+!c
+!c
+!c*         4.      compute stress profile.
+!c*                 ------- ------ --------
+!c
+  400 continue
+!c
+!c
+      call gwprofil                                                                  &
+       &       (  nlon , nlev                                                        &
+       &       , kgwd   , kdx , ktest                                                &
+       &       , ikcrith, icrit                                                      &
+       &       , paphm1, zrho   , zstab ,  zvph                                      &
+       &       , zri   , ztau                                                        &
+       &       , zdmod , psig  , pstd)
+!c
+!c
+!c*         5.      compute tendencies.
+!c*                 -------------------
+!c
+  500 continue
+!c
+!c  explicit solution at all levels for the gravity wave
+!c  implicit solution for the blocked levels
+
+      do 510 jl=kidia,kfdia
+      zvidis(jl)=0.0
+      zdudt(jl)=0.0
+      zdvdt(jl)=0.0
+      zdtdt(jl)=0.0
+  510 continue
+!c
+      ilevp1=klev+1
+!c
+!c
+      do 524 jk=1,klev
+!c
+!c
+!c     do 523 jl=1,kgwd
+!c     ji=kdx(jl)
+!c  Modif vectorisation 02/04/2004
+      do 523 ji=kidia,kfdia
+      if(ktest(ji).eq.1) then
+
+      zdelp=paphm1(ji,jk+1)-paphm1(ji,jk)
+      ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,ilevp1)*zdelp)
+      zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
+      zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
+!c
+!c controle des overshoots:
+!c
+      zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2)+1.E-12
+      ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst+1.E-12
+      rover=0.25
+      if(zforc.ge.rover*ztend)then
+        zdudt(ji)=rover*ztend/zforc*zdudt(ji)
+        zdvdt(ji)=rover*ztend/zforc*zdvdt(ji)
+      endif
+!c
+!c fin du controle des overshoots
+!c
+      if(jk.ge.ikenvh(ji)) then
+         zb=1.0-0.18*pgamma(ji)-0.04*pgamma(ji)**2
+         zc=0.48*pgamma(ji)+0.3*pgamma(ji)**2
+         zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji))
+         zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
+         zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2
+	     ratio=(cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji,jk))**2)/                    &
+       &   (pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
+         zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv
+!c
+!c simplement oppose au vent
+!c
+         zdudt(ji)=-pum1(ji,jk)/ztmst
+         zdvdt(ji)=-pvm1(ji,jk)/ztmst
+!c
+!c  projection dans la direction de l'axe principal de l'orographie
+!cmod     zdudt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+!cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+!cmod *              *cos(ptheta(ji)*rpi/180.)/ztmst
+!cmod     zdvdt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+!cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+!cmod *              *sin(ptheta(ji)*rpi/180.)/ztmst
+         zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet))
+         zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet))
+      end if
+      pvom(ji,jk)=zdudt(ji)
+      pvol(ji,jk)=zdvdt(ji)
+      zust=pum1(ji,jk)+ztmst*zdudt(ji)
+      zvst=pvm1(ji,jk)+ztmst*zdvdt(ji)
+      zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
+      zdedt(ji)=zdis/ztmst
+      zvidis(ji)=zvidis(ji)+zdis*zdelp
+      zdtdt(ji)=zdedt(ji)/rcpd
+!c     pte(ji,jk)=zdtdt(ji)
+!c
+!c  ENCORE UN TRUC POUR EVITER LES EXPLOSIONS
+!c
+      pte(ji,jk)=0.0
+
+      endif
+  523 continue
+
+  524 continue
+!c
+!c
+      return
+      end SUBROUTINE orodrag
+
+      SUBROUTINE orosetup                                                            &
+       &         ( nlon   , ktest                                                    &
+       &         , kkcrit, kkcrith, kcrit                                            &
+       &         , kkenvh, kknu  , kknu2                                             &
+       &         , paphm1, papm1 , pum1   , pvm1 , ptm1  , pgeom1, pstd              &
+       &         , prho  , pri   , pstab  , ptau , pvph  ,ppsi, pzdep                &
+       &         , pulow , pvlow                                                     &
+       &         , ptheta, pgamma, pmea, ppic, pval                                  &
+       &         , pnu  ,  pd1  ,  pd2  ,pdmod  )
+!c
+!c**** *gwsetup*
+!c
+!c     purpose.
+!c     --------
+!c
+!c**   interface.
+!c     ----------
+!c          from *orodrag*
+!c
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c     ==== outputs ===
+!c
+!c        implicit arguments :   none
+!c        --------------------
+!c
+!c     method.
+!c     -------
+!c
+!c
+!c     externals.
+!c     ----------
+!c
+!c
+!c     reference.
+!c     ----------
+!c
+!c        see ecmwf research department documentation of the "i.f.s."
+!c
+!c     author.
+!c     -------
+!c
+!c     modifications.
+!c     --------------
+!c     f.lott  for the new-gwdrag scheme november 1993
+!c
+!c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+!c
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+!c-----------------------------------------------------------------------
+!c
+!c*       0.1   arguments
+!c              ---------
+!c
+      integer nlon
+      integer jl, jk
+      real zdelp
+
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),                                &
+       &        ktest(nlon),kkenvh(nlon)
+
+!c
+      real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev),                     &
+       &     pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev),                      &
+       &     prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1),                  &
+       &     ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1),                  &
+       &     pzdep(nlon,klev)
+       real pulow(nlon),pvlow(nlon),ptheta(nlon),pgamma(nlon),pnu(nlon),             &
+       &     pd1(nlon),pd2(nlon),pdmod(nlon)
+      real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon)
+!c
+!c-----------------------------------------------------------------------
+!c
+!c*       0.2   local arrays
+!c              ------------
+!c
+!c
+      integer ilevm1, ilevm2, ilevh
+      real zcons1, zcons2,zcons3, zhgeo
+      real zu, zphi, zvt1,zvt2, zst, zvar, zdwind, zwind
+      real zstabm, zstabp, zrhom,  zrhop, alpha
+      real zggeenv, zggeom1,zgvar 
+      logical lo 
+      logical ll1(klon,klev+1)
+      integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon),                        &
+       &        kentp(klon),ncount(klon)  
+!c
+      real zhcrit(klon,klev),zvpf(klon,klev),                                        &
+       &     zdp(klon,klev)
+      real znorm(klon),zb(klon),zc(klon),                                            &
+       &      zulow(klon),zvlow(klon),znup(klon),znum(klon)
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.    initialization
+!c                --------------
+!c
+!c     print *,' entree gwsetup'
+ 100  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.1   computational constants
+!c                -----------------------
+!c
+ 110  continue
+!c
+      ilevm1=klev-1
+      ilevm2=klev-2
+      ilevh =klev/3
+!c
+      zcons1=1./rd
+!cold  zcons2=g**2/cpd
+      zcons2=rg**2/rcpd
+!cold  zcons3=1.5*api
+      zcons3=1.5*rpi
+!c
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         2.
+!c                --------------
+!c
+ 200  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         2.1     define low level wind, project winds in plane of
+!c*                 low level wind, determine sector in which to take
+!c*                 the variance and set indicator for critical levels.
+!c
+!c
+!c
+      do 2001 jl=kidia,kfdia
+      kknu(jl)    =klev
+      kknu2(jl)   =klev
+      kknub(jl)   =klev
+      kknul(jl)   =klev
+      pgamma(jl) =max(pgamma(jl),gtsec)
+      ll1(jl,klev+1)=.false.
+ 2001 continue
+!c
+!c Ajouter une initialisation (L. Li, le 23fev99):
+!c
+      do jk=klev,ilevh,-1
+      do jl=kidia,kfdia
+      ll1(jl,jk)= .FALSE.
+      ENDDO
+      ENDDO
+!c
+!c*      define top of low level flow
+!c       ----------------------------
+      do 2002 jk=klev,ilevh,-1
+      do 2003 jl=kidia,kfdia
+      lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr
+      if(lo) then
+        kkcrit(jl)=jk
+      endif
+      zhcrit(jl,jk)=ppic(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu(jl)=ilevh
+ 2003 continue
+ 2002 continue
+      do 2004 jk=klev,ilevh,-1
+      do 2005 jl=kidia,kfdia
+      zhcrit(jl,jk)=ppic(jl)-pval(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu2(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh
+ 2005 continue
+ 2004 continue
+      do 2006 jk=klev,ilevh,-1
+      do 2007 jl=kidia,kfdia
+      zhcrit(jl,jk)=amax1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl))
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknub(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknub(jl)=ilevh
+ 2007 continue
+ 2006 continue
+!c
+      do 2010 jl=kidia,kfdia  
+      kknu(jl)=min(kknu(jl),nktopg)
+      kknu2(jl)=min(kknu2(jl),nktopg)
+      kknub(jl)=min(kknub(jl),nktopg)
+      kknul(jl)=klev
+ 2010 continue      
+!c
+
+ 210  continue
+!c
+!c
+!cc*     initialize various arrays
+!c
+      do 2107 jl=kidia,kfdia
+      prho(jl,klev+1)  =0.0
+      pstab(jl,klev+1) =0.0
+      pstab(jl,1)      =0.0
+      pri(jl,klev+1)   =9999.0
+      ppsi(jl,klev+1)  =0.0
+      pri(jl,1)        =0.0
+      pvph(jl,1)       =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      zulow(jl)        =0.0
+      zvlow(jl)        =0.0
+      kkcrith(jl)      =klev
+      kkenvh(jl)       =klev
+      kentp(jl)        =klev
+      kcrit(jl)        =1
+      ncount(jl)       =0
+      ll1(jl,klev+1)   =.false.
+ 2107 continue
+!c
+!c*     define low-level flow
+!c      ---------------------
+!c
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))*                          &
+       &  (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+        pstab(jl,jk)=max(pstab(jl,jk),gssec)
+      endif
+  222 continue
+  223 continue
+!c
+!c********************************************************************
+!c
+!c*     define blocked flow
+!c      -------------------
+      do 2115 jk=klev,ilevh,-1
+      do 2116 jl=kidia,kfdia
+      if(jk.ge.kknub(jl).and.jk.le.kknul(jl)) then
+        pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      end if
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+      pvph(jl,klev+1)=znorm(jl)
+ 2110 continue
+!c
+!c*******  setup orography axes and define plane of profiles  *******
+!c
+      do 2112 jl=kidia,kfdia
+      lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec)
+      if(lo) then
+        zu=pulow(jl)+2.*gvsec
+      else
+        zu=pulow(jl)
+      endif
+      zphi=atan(pvlow(jl)/zu)
+      ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi
+      zb(jl)=1.-0.18*pgamma(jl)-0.04*pgamma(jl)**2
+      zc(jl)=0.48*pgamma(jl)+0.3*pgamma(jl)**2
+      pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
+      pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1))
+      pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2)
+ 2112 continue
+!c
+!c  ************ define flow in plane of lowlevel stress *************
+!c
+      do 213 jk=1,klev
+      do 212 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        zvt1       =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk)
+        zvt2       =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk)
+        zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
+      endif
+      ptau(jl,jk)  =0.0
+      pzdep(jl,jk) =0.0
+      ppsi(jl,jk)  =0.0
+      ll1(jl,jk)   =.false.
+  212 continue
+  213 continue
+      do 215 jk=2,klev
+      do 214 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+                     &
+       &            (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1))                      &
+       &            /zdp(jl,jk)
+        if(pvph(jl,jk).lt.gvsec) then
+          pvph(jl,jk)=gvsec
+          kcrit(jl)=jk
+        endif
+      endif
+  214 continue
+  215 continue
+!c
+!c
+!c*         2.2     brunt-vaisala frequency and density at half levels.
+!c
+  220 continue
+!c
+      do 2211 jk=ilevh,klev
+      do 221 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      if(jk.ge.(kknub(jl)+1).and.jk.le.kknul(jl)) then
+           zst=zcons2/ptm1(jl,jk)*(1.-rcpd*prho(jl,jk)*                              &
+       &                   (ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+           pstab(jl,klev+1)=pstab(jl,klev+1)+zst*zdp(jl,jk)
+           pstab(jl,klev+1)=max(pstab(jl,klev+1),gssec)
+           prho(jl,klev+1)=prho(jl,klev+1)+paphm1(jl,jk)*2.*zdp(jl,jk)               &
+       &                   *zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+      endif
+      endif
+  221 continue
+ 2211 continue
+!c
+      do 2212 jl=kidia,kfdia
+        pstab(jl,klev+1)=pstab(jl,klev+1)/(papm1(jl,kknul(jl))                       &
+       &                                          -papm1(jl,kknub(jl)))
+        prho(jl,klev+1)=prho(jl,klev+1)/(papm1(jl,kknul(jl))                         &
+       &                                          -papm1(jl,kknub(jl)))
+        zvar=pstd(jl)
+ 2212 continue
+!c
+!c*         2.3     mean flow richardson number.
+!c*                 and critical height for froude layer
+!c
+  230 continue
+!c
+      do 232 jk=2,klev
+      do 231 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec)
+        pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk)                                          &
+       &          /(rg*prho(jl,jk)*zdwind))**2
+        pri(jl,jk)=max(pri(jl,jk),grcrit)
+      endif
+  231 continue
+  232 continue
+  
+!c
+!c
+!c*      define top of 'envelope' layer
+!c       ----------------------------
+
+      do 233 jl=kidia,kfdia
+      pnu (jl)=0.0
+      znum(jl)=0.0
+ 233  continue
+      
+!      do 234 jk=2,klev-1
+!      do 234 jl=kidia,kfdia
+! L. Fita. July 2013
+      DO jk=2,klev-1
+      DO jl=kidia,kfdia
+
+      
+      if(ktest(jl).eq.1) then
+       
+      if (jk.ge.kknub(jl)) then
+          
+            znum(jl)=pnu(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/                     &
+       &            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            pnu(jl) = pnu(jl) + (zdelp/rg)*                                          &
+       &            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit)                        &
+       &                          .and.(kkenvh(jl).eq.klev)) THEN                        
+             kkenvh(jl)=jk                                                          
+            endif    
+
+      endif
+      END IF
+      
+! 234  continue
+      END DO
+      END DO
+      
+!c  calculation of a dynamical mixing height for the breaking
+!c  of gravity waves:
+
+              
+      do 235 jl=kidia,kfdia
+      znup(jl)=0.0
+      znum(jl)=0.0
+ 235  continue
+
+!      do 236 jk=klev-1,2,-1
+!      do 236 jl=kidia,kfdia
+! L. Fita, July 2013
+      DO jk=klev-1,2,-1
+      DO jl=kidia,kfdia
+
+      
+      if(ktest(jl).eq.1) then
+
+            znum(jl)=znup(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/                     &
+       &            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            znup(jl) = znup(jl) + (zdelp/rg)*                                        &
+       &            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.rpi/2.).and.(znup(jl).gt.rpi/2.)                         &
+       &                          .and.(kkcrith(jl).eq.klev)) THEN                       
+              kkcrith(jl)=jk                                                         
+            endif
+      
+      END IF
+! 236  continue
+      END DO
+      END DO
+ 
+      do 237 jl=kidia,kfdia
+      kkcrith(jl)=min0(kkcrith(jl),kknu2(jl))
+      kkcrith(jl)=max0(kkcrith(jl),ilevh*2)
+ 237  continue         
+!c
+!c     directional info for flow blocking ************************* 
+!c
+      do 251 jk=ilevh,klev    
+      do 252 jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+      lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec)
+      if(lo) then
+        zu=pum1(jl,jk)+2.*gvsec
+      else
+        zu=pum1(jl,jk)
+      endif
+       zphi=atan(pvm1(jl,jk)/zu)
+       ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi
+      end if
+ 252  continue
+ 251  continue
+!c      forms the vertical 'leakiness' **************************
+
+      alpha=3.
+      
+      do 254  jk=ilevh,klev
+      do 253  jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+        zggeenv=amax1(1.,                                                            &
+       &          (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)-1))/2.)      
+        zggeom1=amax1(pgeom1(jl,jk),1.)
+        zgvar=amax1(pstd(jl)*rg,1.)     
+!cmod    pzdep(jl,jk)=sqrt((zggeenv-zggeom1)/(zggeom1+zgvar))      
+        pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,  jk))/                      &
+       &               (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,klev))
+      end if
+ 253  continue
+ 254  continue
+
+ 260  continue
+
+      return
+      end SUBROUTINE orosetup
+
+      SUBROUTINE gwstress                                                            &
+       &         (  nlon  , nlev                                                     &
+       &         , ktest, kcrit, kkenvh                                              &
+       &         , kknu                                                              &
+       &         , prho  , pstab , pvph  , pstd, psig                                &
+       &         , pmea , ppic  , ptau                                               &
+       &         , pgeom1 , pdmod )
+!c
+!c**** *gwstress*
+!c
+!c     purpose.
+!c     --------
+!c
+!c**   interface.
+!c     ----------
+!c     call *gwstress*  from *gwdrag*
+!c
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c     ==== outputs ===
+!c
+!c        implicit arguments :   none
+!c        --------------------
+!c
+!c     method.
+!c     -------
+!c
+!c
+!c     externals.
+!c     ----------
+!c
+!c
+!c     reference.
+!c     ----------
+!c
+!c        see ecmwf research department documentation of the "i.f.s."
+!c
+!c     author.
+!c     -------
+!c
+!c     modifications.
+!c     --------------
+!c     f. lott put the new gwd on ifs      22/11/93
+!c
+!c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+!c-----------------------------------------------------------------------
+!c
+!c*       0.1   arguments
+!c              ---------
+!c
+      integer nlon, nlev
+      integer kcrit(nlon),                                                           &
+       &        ktest(nlon),kkenvh(nlon),kknu(nlon)
+!c
+      real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1),                   &
+       &     pvph(nlon,nlev+1),                                                      &
+       &     pgeom1(nlon,nlev),pstd(nlon)
+!c
+      real psig(nlon)
+      real pmea(nlon),ppic(nlon)
+      real pdmod(nlon)
+!c
+!c-----------------------------------------------------------------------
+!c
+!c*       0.2   local arrays
+!c              ------------
+      integer jl
+      real zblock, zvar, zeff
+      logical lo
+!c
+!c-----------------------------------------------------------------------
+!c
+!c*       0.3   functions
+!c              ---------
+!c     ------------------------------------------------------------------
+!c
+!c*         1.    initialization
+!c                --------------
+!c
+ 100  continue
+!c
+!c*         3.1     gravity wave stress.
+!c
+  300 continue
+!c
+!c
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      
+!c  effective mountain height above the blocked flow
+  
+         if(kkenvh(jl).eq.klev)then
+         zblock=0.0 
+         else
+         zblock=(pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg          
+         endif
+      
+        zvar=ppic(jl)-pmea(jl)
+        zeff=amax1(0.,zvar-zblock)
+
+        ptau(jl,klev+1)=prho(jl,klev+1)*gkdrag*psig(jl)*zeff**2                      &
+       &    /4./pstd(jl)*pvph(jl,klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1))
+
+!c  too small value of stress or  low level flow include critical level
+!c  or low level flow:  gravity wave stress nul.
+                
+        lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl))                     &
+       &      .or.(pvph(jl,klev+1).lt.gvcrit)
+!c       if(lo) ptau(jl,klev+1)=0.0
+      
+      else
+      
+          ptau(jl,klev+1)=0.0
+          
+      endif
+      
+  301 continue
+!c
+      return
+      end SUBROUTINE gwstress
+
+      SUBROUTINE GWPROFIL                                                            &
+       &         ( NLON, NLEV                                                        &
+       &         , kgwd, kdx , ktest                                                 &
+       &         , KKCRITH, KCRIT                                                    &
+       &         , PAPHM1, PRHO   , PSTAB  , PVPH , PRI , PTAU                       &
+       &         , pdmod   , psig , pvar)
+
+!C**** *GWPROFIL*
+!C
+!C     PURPOSE.
+!C     --------
+!C
+!C**   INTERFACE.
+!C     ----------
+!C          FROM *GWDRAG*
+!C
+!C        EXPLICIT ARGUMENTS :
+!C        --------------------
+!C     ==== INPUTS ===
+!C     ==== OUTPUTS ===
+!C
+!C        IMPLICIT ARGUMENTS :   NONE
+!C        --------------------
+!C
+!C     METHOD:
+!C     -------
+!C     THE STRESS PROFILE FOR GRAVITY WAVES IS COMPUTED AS FOLLOWS:
+!C     IT IS CONSTANT (NO GWD) AT THE LEVELS BETWEEN THE GROUND
+!C     AND THE TOP OF THE BLOCKED LAYER (KKENVH).
+!C     IT DECREASES LINEARLY WITH HEIGHTS FROM THE TOP OF THE 
+!C     BLOCKED LAYER TO 3*VAROR (kKNU), TO SIMULATES LEE WAVES OR 
+!C     NONLINEAR GRAVITY WAVE BREAKING.
+!C     ABOVE IT IS CONSTANT, EXCEPT WHEN THE WAVE ENCOUNTERS A CRITICAL
+!C     LEVEL (KCRIT) OR WHEN IT BREAKS.
+!C     
+!C
+!C
+!C     EXTERNALS.
+!C     ----------
+!C
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S."
+!C
+!C     AUTHOR.
+!C     -------
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C     PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93)
+!C-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+!C
+
+!C
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+!C-----------------------------------------------------------------------
+!C
+!C*       0.1   ARGUMENTS
+!C              ---------
+!C
+      integer nlon,nlev
+      INTEGER KKCRITH(NLON),KCRIT(NLON)                                              &
+       &       ,kdx(nlon) , ktest(nlon)
+
+!C
+      REAL PAPHM1(NLON,NLEV+1), PSTAB(NLON,NLEV+1),                                  &
+       &     PRHO  (NLON,NLEV+1), PVPH (NLON,NLEV+1),                                &
+       &     PRI   (NLON,NLEV+1), PTAU(NLON,NLEV+1)                                  
+      REAL pdmod (NLON) , psig(NLON),                                                &
+       &     pvar(NLON)                                                              
+!C-----------------------------------------------------------------------
+!C
+!C*       0.2   LOCAL ARRAYS
+!C              ------------
+!C
+      integer ilevh, ji, kgwd, jl, jk
+      real zsqr, zalfa, zriw, zdel, zb, zalpha,zdz2n
+      real zdelp, zdelpt 
+      REAL ZDZ2 (KLON,KLEV) , ZNORM(KLON) , zoro(KLON)
+      REAL ZTAU (KLON,KLEV+1)
+!C
+!C-----------------------------------------------------------------------
+!C
+!C*         1.    INITIALIZATION
+!C                --------------
+!C
+!c      print *,' entree gwprofil' 
+ 100  CONTINUE
+!C
+!C
+!C*    COMPUTATIONAL CONSTANTS.
+!C     ------------- ----------
+!C
+      ilevh=KLEV/3
+!C
+!c     DO 400 ji=1,kgwd
+!c     jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      DO 400 jl=kidia,kfdia
+      if (ktest(jl).eq.1) then
+      Zoro(JL)=Psig(JL)*Pdmod(JL)/4./max(pvar(jl),1.0)
+      ZTAU(JL,KLEV+1)=PTAU(JL,KLEV+1)
+      endif
+  400 CONTINUE
+  
+!C
+      DO 430 JK=KLEV,2,-1
+!C
+!C
+!C*         4.1    CONSTANT WAVE STRESS UNTIL TOP OF THE
+!C                 BLOCKING LAYER.
+  410 CONTINUE
+!C
+!c     DO 411 ji=1,kgwd
+!c     jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 411 jl=kidia,kfdia
+      if (ktest(jl).eq.1) then
+           IF(JK.GT.KKCRITH(JL)) THEN
+           PTAU(JL,JK)=ZTAU(JL,KLEV+1)
+!C          ENDIF
+!C          IF(JK.EQ.KKCRITH(JL)) THEN
+           ELSE                    
+           PTAU(JL,JK)=GRAHILO*ZTAU(JL,KLEV+1)
+           ENDIF
+      endif
+ 411  CONTINUE             
+!C
+!C*         4.15   CONSTANT SHEAR STRESS UNTIL THE TOP OF THE
+!C                 LOW LEVEL FLOW LAYER.
+ 415  CONTINUE
+!C        
+!C
+!C*         4.2    WAVE DISPLACEMENT AT NEXT LEVEL.
+!C
+  420 CONTINUE
+!C
+!c     DO 421 ji=1,kgwd
+!c     jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 421 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      IF(JK.LT.KKCRITH(JL)) THEN
+      ZNORM(JL)=gkdrag*PRHO(JL,JK)*SQRT(PSTAB(JL,JK))*PVPH(JL,JK)                    &
+       &                                                    *zoro(jl)
+      ZDZ2(JL,JK)=PTAU(JL,JK+1)/max(ZNORM(JL),gssec)
+      ENDIF
+      endif
+  421 CONTINUE
+!C
+!C*         4.3    WAVE RICHARDSON NUMBER, NEW WAVE DISPLACEMENT
+!C*                AND STRESS:  BREAKING EVALUATION AND CRITICAL 
+!C                 LEVEL
+!C
+                          
+!c     DO 431 ji=1,kgwd
+!c     jl=Kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 431 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+          IF(JK.LT.KKCRITH(JL)) THEN
+          IF((PTAU(JL,JK+1).LT.GTSEC).OR.(JK.LE.KCRIT(JL))) THEN
+            PTAU(JL,JK)=0.0
+          ELSE
+               ZSQR=SQRT(PRI(JL,JK))
+               ZALFA=SQRT(PSTAB(JL,JK)*ZDZ2(JL,JK))/PVPH(JL,JK)
+               ZRIW=PRI(JL,JK)*(1.-ZALFA)/(1+ZALFA*ZSQR)**2
+               IF(ZRIW.LT.GRCRIT) THEN
+                 ZDEL=4./ZSQR/GRCRIT+1./GRCRIT**2+4./GRCRIT
+                 ZB=1./GRCRIT+2./ZSQR
+                 ZALPHA=0.5*(-ZB+SQRT(ZDEL))
+                 ZDZ2N=(PVPH(JL,JK)*ZALPHA)**2/PSTAB(JL,JK)
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2N
+               ELSE
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2(JL,JK)
+               ENDIF
+            PTAU(JL,JK)=MIN(PTAU(JL,JK),PTAU(JL,JK+1))
+          ENDIF
+          ENDIF
+      endif
+  431 CONTINUE
+  
+  430 CONTINUE
+  440 CONTINUE
+  
+!C  REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
+
+!c     DO 530 ji=1,kgwd
+!c     jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      ZTAU(JL,KKCRITH(JL))=PTAU(JL,KKCRITH(JL))
+      ZTAU(JL,NSTRA)=PTAU(JL,NSTRA)
+      endif
+ 530  CONTINUE      
+
+      DO 531 JK=1,KLEV
+      
+!c     DO 532 ji=1,kgwd
+!c     jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 532 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+                
+         IF(JK.GT.KKCRITH(JL))THEN
+
+          ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KLEV+1    )
+          ZDELPT=PAPHM1(JL,KKCRITH(JL))-PAPHM1(JL,KLEV+1    )
+          PTAU(JL,JK)=ZTAU(JL,KLEV+1    ) +                                          &
+       &                (ZTAU(JL,KKCRITH(JL))-ZTAU(JL,KLEV+1    ) )*                 &
+       &                ZDELP/ZDELPT
+         ENDIF
+            
+      endif
+ 532  CONTINUE    
+ 
+!C  REORGANISATION IN THE STRATOSPHERE
+
+!c     DO 533 ji=1,kgwd
+!c     jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 533 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+
+         IF(JK.LT.NSTRA)THEN
+
+          ZDELP =PAPHM1(JL,NSTRA)
+          ZDELPT=PAPHM1(JL,JK)
+          PTAU(JL,JK)=ZTAU(JL,NSTRA)*ZDELPT/ZDELP 
+
+        ENDIF
+
+      endif
+ 533  CONTINUE
+
+!C REORGANISATION IN THE TROPOSPHERE
+
+!c      DO 534 ji=1,kgwd
+!c      jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 534 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+
+         IF(JK.LT.KKCRITH(JL).AND.JK.GT.NSTRA)THEN
+
+           ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KKCRITH(JL))
+           ZDELPT=PAPHM1(JL,NSTRA)-PAPHM1(JL,KKCRITH(JL))
+           PTAU(JL,JK)=ZTAU(JL,KKCRITH(JL)) +                                        &
+       &                 (ZTAU(JL,NSTRA)-ZTAU(JL,KKCRITH(JL)))*ZDELP                 &
+       &                                                     /ZDELPT
+
+       ENDIF
+      endif
+ 534   CONTINUE
+
+ 
+ 531  CONTINUE        
+
+
+      RETURN
+      END SUBROUTINE GWPROFIL
+
+      SUBROUTINE lift_noro (nlon,nlev,dtime,paprs,pplay,                             &
+       &                   plat,pmea,pstd, ppic,                                     &
+       &                   ktest,                                                    &
+       &                   t, u, v,                                                  &
+       &                   pulow, pvlow, pustr, pvstr,                               &
+       &                   d_t, d_u, d_v)
+!c
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+!c Objet: Frottement de la montagne Interface
+!c======================================================================
+!c Arguments:
+!c dtime---input-R- pas d'integration (s)
+!c paprs---input-R-pression pour chaque inter-couche (en Pa)
+!c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+!c t-------input-R-temperature (K)
+!c u-------input-R-vitesse horizontale (m/s)
+!c v-------input-R-vitesse horizontale (m/s)
+!c
+!c d_t-----output-R-increment de la temperature
+!c d_u-----output-R-increment de la vitesse u
+!c d_v-----output-R-increment de la vitesse v
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c
+!c ARGUMENTS
+!c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL plat(nlon),pmea(nlon)
+      REAL pstd(nlon)
+      REAL ppic(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+!c
+      INTEGER i, k, ktest(nlon)
+!c
+!c Variables locales:
+!c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+!c
+!c initialiser les variables de sortie (pour securite)
+!c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+!c
+!c preparer les variables d'entree (attention: l'ordre des niveaux 
+!c verticaux augmente du haut vers le bas)
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)                                             &
+       &                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0                    &
+       &               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+!c
+!c appeler la routine principale
+!c
+      CALL OROLIFT(klon,klev,ktest,                                                  &
+       &            dtime,                                                           &
+       &            papmh, zgeom,                                                    &
+       &            pt, pu, pv,                                                      &
+       &            plat,pmea, pstd, ppic,                                           &
+       &            pulow,pvlow,                                                     &
+       &            pdudt,pdvdt,pdtdt)
+!C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)                                                  &
+!IM BUG .                 +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))                   &
+       &                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+         pvstr(i)        = pvstr(i)                                                  &
+!IM BUG .                 +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))                   &
+       &                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+      ENDDO
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE lift_noro
+
+      SUBROUTINE OROLIFT( NLON,NLEV                                                  &
+       &                 , KTEST                                                     &
+       &                 , PTSPHY                                                    &
+       &                 , PAPHM1,PGEOM1,PTM1,PUM1,PVM1                              &
+       &                 , PLAT                                                      &
+       &                 , PMEA, PVAROR, ppic                                        &
+!C OUTPUTS                                                                           &
+       &                 , PULOW,PVLOW                                               &
+       &                 , PVOM,PVOL,PTE )
+
+!C
+!C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
+!C
+!C     PURPOSE.
+!C     --------
+!C
+!C**   INTERFACE.
+!C     ----------
+!C          CALLED FROM *lift_noro
+!C     ----------
+!C
+!C     AUTHOR.
+!C     -------
+!C     F.LOTT  LMD 22/11/95
+!C
+      USE dimphy
+      implicit none
+!C
+!C
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+!C-----------------------------------------------------------------------
+!C
+!C*       0.1   ARGUMENTS
+!C              ---------
+!C
+!C
+      integer nlon, nlev
+      REAL  PTE(NLON,NLEV),                                                          &
+       &      PVOL(NLON,NLEV),                                                       &
+       &      PVOM(NLON,NLEV),                                                       &
+       &      PULOW(NLON),                                                           &
+       &      PVLOW(NLON)
+      REAL  PUM1(NLON,NLEV),                                                         &
+       &      PVM1(NLON,NLEV),                                                       &
+       &      PTM1(NLON,NLEV),                                                       &
+       &      PLAT(NLON),PMEA(NLON),                                                 &
+       &      PVAROR(NLON),                                                          &
+       &      ppic(NLON),                                                            &
+       &      PGEOM1(NLON,NLEV),                                                     &
+       &      PAPHM1(NLON,NLEV+1)
+!C
+      INTEGER  KTEST(NLON)
+      real ptsphy
+!C-----------------------------------------------------------------------
+!C
+!C*       0.2   LOCAL ARRAYS
+!C              ------------
+      logical lifthigh
+!cym      integer klevm1, jl, ilevh, jk
+      integer  jl, ilevh, jk
+      real zcons1, ztmst, zrtmst,zpi, zhgeo
+      real zdelp, zslow, zsqua, zscav, zbet
+      INTEGER                                                                        &
+       &         IKNUB(klon),                                                        &
+       &         IKNUL(klon)
+      LOGICAL LL1(KLON,KLEV+1)
+!C
+      REAL   ZTAU(KLON,KLEV+1),                                                      &
+       &       ZTAV(KLON,KLEV+1),                                                    &
+       &       ZRHO(KLON,KLEV+1)
+      REAL   ZDUDT(KLON),                                                            &
+       &       ZDVDT(KLON)
+      REAL ZHCRIT(KLON,KLEV)
+      CHARACTER (LEN=20) :: modname='orografi'
+      CHARACTER (LEN=80) :: abort_message
+!C-----------------------------------------------------------------------
+!C
+!C*         1.1  INITIALIZATIONS
+!C               ---------------
+
+      LIFTHIGH=.FALSE.
+
+      IF(NLON.NE.KLON.OR.NLEV.NE.KLEV)THEN
+        abort_message = 'pb dimension'
+        CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+      ZCONS1=1./RD
+!cym      KLEVM1=KLEV-1
+      ZTMST=PTSPHY
+      ZRTMST=1./ZTMST
+      ZPI=ACOS(-1.)
+!C
+      DO 1001 JL=kidia,kfdia
+      ZRHO(JL,KLEV+1)  =0.0
+      PULOW(JL)        =0.0
+      PVLOW(JL)        =0.0
+      iknub(JL)   =klev
+      iknul(JL)   =klev
+      ilevh=klev/3
+      ll1(jl,klev+1)=.false.
+      DO 1000 JK=1,KLEV
+      PVOM(JL,JK)=0.0
+      PVOL(JL,JK)=0.0
+      PTE (JL,JK)=0.0
+ 1000 CONTINUE
+ 1001 CONTINUE
+
+!C
+!C*         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
+!C*                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
+!C*                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
+!C
+!C
+!C
+      DO 2006 JK=KLEV,1,-1
+      DO 2007 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZHCRIT(JL,JK)=amax1(Ppic(JL)-pmea(JL),100.)
+      ZHGEO=PGEOM1(JL,JK)/RG
+      ll1(JL,JK)=(ZHGEO.GT.ZHCRIT(JL,JK))
+      IF(ll1(JL,JK).neqv.ll1(JL,JK+1)) THEN
+        iknub(JL)=JK
+      ENDIF
+      ENDIF
+ 2007 CONTINUE
+ 2006 CONTINUE
+!C
+      do 2010 jl=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      iknub(jl)=max(iknub(jl),klev/2)
+      iknul(jl)=max(iknul(jl),2*klev/3)
+      if(iknub(jl).gt.nktopg) iknub(jl)=nktopg
+      if(iknub(jl).eq.nktopg) iknul(jl)=klev
+      if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1
+      ENDIF
+ 2010 continue
+
+!C     do 2011 jl=kidia,kfdia
+!C     IF(KTEST(JL).EQ.1) THEN
+!C       print *,' iknul= ',iknul(jl),'  iknub=',iknub(jl)
+!C     ENDIF
+!C2011 continue
+
+!C     PRINT *,'  DANS OROLIFT: 2010'
+
+      DO 223 JK=KLEV,2,-1
+      DO 222 JL=kidia,kfdia
+        ZRHO(JL,JK)=2.*PAPHM1(JL,JK)*ZCONS1/(PTM1(JL,JK)+PTM1(JL,JK-1))
+  222 CONTINUE
+  223 CONTINUE
+!C     PRINT *,'  DANS OROLIFT: 223'
+
+!C********************************************************************
+!C
+!C*     DEFINE LOW LEVEL FLOW
+!C      -------------------
+      DO 2115 JK=klev,1,-1
+      DO 2116 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then
+        pulow(JL)=pulow(JL)+PUM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        pvlow(JL)=pvlow(JL)+PVM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        zrho(JL,klev+1)=zrho(JL,klev+1)                                              &
+       &                 +zrho(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+      end if
+      ENDIF
+ 2116 CONTINUE
+ 2115 CONTINUE
+      DO 2110 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      pulow(JL)=pulow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      pvlow(JL)=pvlow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      zrho(JL,klev+1)=zrho(JL,klev+1)                                                &
+       &               /(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      ENDIF
+ 2110 CONTINUE
+
+
+200   CONTINUE
+
+!C***********************************************************
+!C
+!C*         3.      COMPUTE MOUNTAIN LIFT
+!C
+  300 CONTINUE
+!C
+      DO 301 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+       ZTAU(JL,KLEV+1)= - GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*                          &
+!C    *                 (2*PVAROR(JL)+PMEA(JL))*                                     &
+       &                 2*PVAROR(JL)*                                               &
+       &                 SIN(ZPI/180.*PLAT(JL))*PVLOW(JL)
+       ZTAV(JL,KLEV+1)=   GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*                          &
+!C    *                 (2*PVAROR(JL)+PMEA(JL))*                                     &
+       &                 2*PVAROR(JL)*                                               &
+       &                 SIN(ZPI/180.*PLAT(JL))*PULOW(JL)
+      ELSE
+       ZTAU(JL,KLEV+1)=0.0
+       ZTAV(JL,KLEV+1)=0.0
+      ENDIF
+301   CONTINUE
+
+!C
+!C*         4.      COMPUTE LIFT PROFILE         
+!C*                 --------------------   
+!C
+
+  400 CONTINUE
+
+      DO 401 JK=1,KLEV
+      DO 401 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZTAU(JL,JK)=ZTAU(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ZTAV(JL,JK)=ZTAV(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ELSE
+      ZTAU(JL,JK)=0.0
+      ZTAV(JL,JK)=0.0
+      ENDIF
+401   CONTINUE
+!C
+!C
+!C*         5.      COMPUTE TENDENCIES.
+!C*                 -------------------
+      IF(LIFTHIGH)THEN
+!C
+  500 CONTINUE
+!C     PRINT *,'  DANS OROLIFT: 500'
+!C
+!C  EXPLICIT SOLUTION AT ALL LEVELS
+!C
+      DO 524 JK=1,klev
+      DO 523 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+      ZDELP=PAPHM1(JL,JK+1)-PAPHM1(JL,JK)
+      ZDUDT(JL)=-RG*(ZTAU(JL,JK+1)-ZTAU(JL,JK))/ZDELP
+      ZDVDT(JL)=-RG*(ZTAV(JL,JK+1)-ZTAV(JL,JK))/ZDELP
+      ENDIF  
+  523 CONTINUE
+  524 CONTINUE
+!C
+!C  PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
+!C
+      DO 530 JK=1,klev
+      DO 530 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+
+        ZSLOW=SQRT(PULOW(JL)**2+PVLOW(JL)**2)
+        ZSQUA=AMAX1(SQRT(PUM1(JL,JK)**2+PVM1(JL,JK)**2),GVSEC)
+        ZSCAV=-ZDUDT(JL)*PVM1(JL,JK)+ZDVDT(JL)*PUM1(JL,JK)
+        IF(ZSQUA.GT.GVSEC)THEN
+          PVOM(JL,JK)=-ZSCAV*PVM1(JL,JK)/ZSQUA**2
+          PVOL(JL,JK)= ZSCAV*PUM1(JL,JK)/ZSQUA**2
+        ELSE
+          PVOM(JL,JK)=0.0
+          PVOL(JL,JK)=0.0      
+        ENDIF  
+        ZSQUA=SQRT(PUM1(JL,JK)**2+PUM1(JL,JK)**2)               
+        IF(ZSQUA.LT.ZSLOW)THEN
+          PVOM(JL,JK)=ZSQUA/ZSLOW*PVOM(JL,JK)
+          PVOL(JL,JK)=ZSQUA/ZSLOW*PVOL(JL,JK)
+        ENDIF 
+
+      ENDIF  
+530   CONTINUE
+!C
+!C  6.  LOW LEVEL LIFT, SEMI IMPLICIT:
+!C  ----------------------------------
+
+      ELSE
+
+        DO 601 JL=KIDIA,KFDIA
+        IF(KTEST(JL).EQ.1) THEN
+          DO JK=KLEV,IKNUB(JL),-1
+          ZBET=GKLIFT*2.*ROMEGA*SIN(ZPI/180.*PLAT(JL))*ztmst*                        &
+       &        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,  JK))/                            &
+       &        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,KLEV))
+          ZDUDT(JL)=-PUM1(JL,JK)/ztmst/(1+ZBET**2)
+          ZDVDT(JL)=-PVM1(JL,JK)/ztmst/(1+ZBET**2)
+          PVOM(JL,JK)= ZBET**2*ZDUDT(JL) - ZBET   *ZDVDT(JL)
+          PVOL(JL,JK)= ZBET   *ZDUDT(JL) + ZBET**2*ZDVDT(JL)    
+          ENDDO
+        ENDIF
+ 601    CONTINUE
+
+      ENDIF
+
+      RETURN
+      END SUBROUTINE OROLIFT
+
+
+      SUBROUTINE SUGWD(NLON,NLEV,paprs,pplay)
+      USE dimphy
+      USE mod_phys_lmdz_para
+      USE mod_grid_phy_lmdz
+!c      USE parallel
+!C
+!C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
+!C
+!C     PURPOSE.
+!C     --------
+!C           INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
+!C           GRAVITY WAVE DRAG PARAMETRIZATION.
+!C
+!C**   INTERFACE.
+!C     ----------
+!C        CALL *SUGWD* FROM *SUPHEC*
+!C              -----        ------
+!C
+!C        EXPLICIT ARGUMENTS :
+!C        --------------------
+!C        PSIG        : VERTICAL COORDINATE TABLE
+!C        NLEV        : NUMBER OF MODEL LEVELS
+!C
+!C        IMPLICIT ARGUMENTS :
+!C        --------------------
+!C        COMMON YOEGWD
+!C
+!C     METHOD.
+!C     -------
+!C        SEE DOCUMENTATION
+!C
+!C     EXTERNALS.
+!C     ----------
+!C        NONE
+!C
+!C     REFERENCE.
+!C     ----------
+!C        ECMWF Research Department documentation of the IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        MARTIN MILLER             *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 90-01-01
+!C     ------------------------------------------------------------------
+      implicit none
+!C
+!C     -----------------------------------------------------------------
+#include "YOEGWD.h"
+!C      ----------------------------------------------------------------
+!C
+      integer nlon,nlev, jk
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+      real zpr,zstra,zsigt,zpm1r
+      REAL :: pplay_glo(klon_glo,nlev)
+      REAL :: paprs_glo(klon_glo,nlev+1)
+
+!C
+!C*       1.    SET THE VALUES OF THE PARAMETERS
+!C              --------------------------------
+!C
+ 100  CONTINUE
+!C
+      PRINT *,' DANS SUGWD NLEV=',NLEV
+      GHMAX=10000.
+!C
+      ZPR=100000.
+      ZSTRA=0.1 
+      ZSIGT=0.94
+!cold  ZPR=80000.
+!cold  ZSIGT=0.85
+!C
+      
+      CALL gather(pplay,pplay_glo)
+      CALL bcast(pplay_glo)
+      CALL gather(paprs,paprs_glo)
+      CALL bcast(paprs_glo)
+      
+            
+      DO 110 JK=1,NLEV
+      ZPM1R=pplay_glo((klon_glo/2)+1,jk)/paprs_glo((klon_glo/2)+1,1) 
+      IF(ZPM1R.GE.ZSIGT)THEN
+         nktopg=JK
+      ENDIF
+      ZPM1R=pplay_glo((klon_glo/2)+1,jk)/paprs_glo((klon_glo/2)+1,1) 
+      IF(ZPM1R.GE.ZSTRA)THEN
+         NSTRA=JK
+      ENDIF
+  110 CONTINUE
+
+
+!c
+!c  inversion car dans orodrag on compte les niveaux a l'envers
+      nktopg=nlev-nktopg+1
+      nstra=nlev-nstra
+      print *,' DANS SUGWD nktopg=', nktopg
+      print *,' DANS SUGWD nstra=', nstra
+!C
+      GSIGCR=0.80
+!C
+      GKDRAG=0.2 
+      GRAHILO=1.    
+      GRCRIT=0.01
+      GFRCRIT=1.0
+      GKWAKE=0.50 
+!C
+      GKLIFT=0.50  
+      GVCRIT =0.0
+!C
+!C
+!C      ----------------------------------------------------------------
+!C
+!C*       2.    SET VALUES OF SECURITY PARAMETERS
+!C              ---------------------------------
+!C
+ 200  CONTINUE
+!C
+      GVSEC=0.10
+      GSSEC=1.E-12
+!C
+      GTSEC=1.E-07
+!C
+!C      ----------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE SUGWD
+
+END MODULE orografi
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi_mod.F90	(revision 17)
@@ -0,0 +1,1865 @@
+!
+! $Id: orografi.F 1403 2010-07-01 09:02:53Z fairhead $
+!
+MODULE orografi_mod
+
+  CONTAINS
+
+      SUBROUTINE drag_noro (nlon,nlev,dtime,paprs,pplay,                             &
+       &                   pmea,pstd, psig, pgam, pthe,ppic,pval,                    &
+       &                   kgwd,kdx,ktest,                                           &
+       &                   t, u, v,                                                  &
+       &                   pulow, pvlow, pustr, pvstr,                               &
+       &                   d_t, d_u, d_v)
+!c
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+!c Objet: Frottement de la montagne Interface
+!c======================================================================
+!c Arguments:
+!c dtime---input-R- pas d'integration (s)
+!c paprs---input-R-pression pour chaque inter-couche (en Pa)
+!c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+!c t-------input-R-temperature (K)
+!c u-------input-R-vitesse horizontale (m/s)
+!c v-------input-R-vitesse horizontale (m/s)
+!c
+!c d_t-----output-R-increment de la temperature             
+!c d_u-----output-R-increment de la vitesse u
+!c d_v-----output-R-increment de la vitesse v
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c
+!c ARGUMENTS
+!c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+!c
+      INTEGER i, k, kgwd, kdx(nlon), ktest(nlon)
+!c
+!c Variables locales:
+!c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+!c
+!c initialiser les variables de sortie (pour securite)
+!c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+!c
+!c preparer les variables d'entree (attention: l'ordre des niveaux 
+!c verticaux augmente du haut vers le bas)
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)                                             &
+       &                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0                    &
+       &               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+!c
+!c appeler la routine principale
+!c
+      CALL orodrag(klon,klev,kgwd,kdx,ktest,                                         &
+       &            dtime,                                                           &
+       &            papmh, papmf, zgeom,                                             &
+       &            pt, pu, pv,                                                      &
+       &            pmea, pstd, psig, pgam, pthe, ppic,pval,                         &
+       &            pulow,pvlow,                                                     &
+       &            pdudt,pdvdt,pdtdt)
+!C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)                                                  &
+!IM BUG  .                +rg*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))                   &
+       &                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+         pvstr(i)        = pvstr(i)                                                  &
+!IM BUG  .                +rg*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))                   &
+       &                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+      ENDDO
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE drag_noro
+
+      SUBROUTINE orodrag( nlon,nlev                                                  &
+       &                 , kgwd, kdx, ktest                                          &
+       &                 , ptsphy                                                    &
+       &                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1                        &
+       &                 , pmea, pstd, psig, pgamma, ptheta, ppic, pval              &
+!c outputs                                                                           &
+       &                 , pulow,pvlow                                               &
+       &                 , pvom,pvol,pte )
+
+      USE dimphy
+      implicit none
+
+!c
+!c
+!c**** *gwdrag* - does the gravity wave parametrization.
+!c
+!c     purpose.
+!c     --------
+!c
+!c          this routine computes the physical tendencies of the
+!c     prognostic variables u,v  and t due to  vertical transports by
+!c     subgridscale orographically excited gravity waves
+!c
+!c**   interface.
+!c     ----------
+!c          called from *callpar*.
+!c
+!c          the routine takes its input from the long-term storage:
+!c          u,v,t and p at t-1.
+!c
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c     ==== outputs ===
+!c
+!c        implicit arguments :   none
+!c        --------------------
+!c
+!c      implicit logical (l)
+!c
+!c     method.
+!c     -------
+!c
+!c     externals.
+!c     ----------
+      integer ismin, ismax
+      external ismin, ismax
+!c
+!c     reference.
+!c     ----------
+!c
+!c     author.
+!c     -------
+!c     m.miller + b.ritter   e.c.m.w.f.     15/06/86.
+!c
+!c     f.lott + m. miller    e.c.m.w.f.     22/11/94
+!c-----------------------------------------------------------------------
+!c
+!c
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+!c-----------------------------------------------------------------------
+!c
+!c*       0.1   arguments
+!c              ---------
+!c
+!c
+!cym      integer nlon, nlev, klevm1
+      integer nlon, nlev
+      integer kgwd, jl, ilevp1, jk, ji
+      real zdelp, ztemp, zforc, ztend
+      real rover, zb, zc, zconb, zabsv
+      real zzd1, ratio, zbet, zust,zvst, zdis
+      real  pte(nlon,nlev),                                                          &
+       &      pvol(nlon,nlev),                                                       &
+       &      pvom(nlon,nlev),                                                       &
+       &      pulow(klon),                                                           &
+       &      pvlow(klon)
+      real  pum1(nlon,nlev),                                                         &
+       &      pvm1(nlon,nlev),                                                       &
+       &      ptm1(nlon,nlev),                                                       &
+       &      pmea(nlon),pstd(nlon),psig(nlon),                                      &
+       &      pgamma(nlon),ptheta(nlon),ppic(nlon),pval(nlon),                       &
+       &      pgeom1(nlon,nlev),                                                     &
+       &      papm1(nlon,nlev),                                                      &
+       &      paphm1(nlon,nlev+1)
+!c
+      integer  kdx(nlon),ktest(nlon)
+!c-----------------------------------------------------------------------
+!c
+!c*       0.2   local arrays
+!c              ------------
+      integer  isect(klon),                                                          &
+       &         icrit(klon),                                                        &
+       &         ikcrith(klon),                                                      &
+       &         ikenvh(klon),                                                       &
+       &         iknu(klon),                                                         &
+       &         iknu2(klon),                                                        &
+       &         ikcrit(klon),                                                       &
+       &         ikhlim(klon)
+!c
+      real   ztau(klon,klev+1),                                                      &
+       &       ztauf(klon,klev+1),                                                   &
+       &       zstab(klon,klev+1),                                                   &
+       &       zvph(klon,klev+1),                                                    &
+       &       zrho(klon,klev+1),                                                    &
+       &       zri(klon,klev+1),                                                     &
+       &       zpsi(klon,klev+1),                                                    &
+       &       zzdep(klon,klev)
+      real   zdudt(klon),                                                            &
+       &       zdvdt(klon),                                                          &
+       &       zdtdt(klon),                                                          &
+       &       zdedt(klon),                                                          &
+       &       zvidis(klon),                                                         &
+       &       znu(klon),                                                            &
+       &       zd1(klon),                                                            &
+       &       zd2(klon),                                                            &
+       &       zdmod(klon)
+      real ztmst, ptsphy, zrtmst 
+!c
+!c------------------------------------------------------------------
+!c
+!c*         1.    initialization
+!c                --------------
+!c
+ 100  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.1   computational constants
+!c                -----------------------
+!c
+ 110  continue
+!c
+!c     ztmst=twodt
+!c     if(nstep.eq.nstart) ztmst=0.5*twodt
+!cym      klevm1=klev-1
+      ztmst=ptsphy
+      zrtmst=1./ztmst
+!c     ------------------------------------------------------------------
+!c
+ 120  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.3   check whether row contains point for printing
+!c                ---------------------------------------------
+!c
+ 130  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         2.     precompute basic state variables.
+!c*                ---------- ----- ----- ----------
+!c*                define low level wind, project winds in plane of
+!c*                low level wind, determine sector in which to take
+!c*                the variance and set indicator for critical levels.
+!c
+  200 continue
+!c
+!c
+!c
+      call orosetup                                                                  &
+       &     ( nlon, ktest                                                           &
+       &     , ikcrit, ikcrith, icrit,  ikenvh,iknu,iknu2                            &
+       &     , paphm1, papm1 , pum1   , pvm1 , ptm1 , pgeom1, pstd                   &
+       &     , zrho  , zri   , zstab  , ztau , zvph , zpsi, zzdep                    &
+       &     , pulow, pvlow                                                          &
+       &     , ptheta,pgamma,pmea,ppic,pval,znu  ,zd1,  zd2,  zdmod )
+!c
+!c
+!c
+!c***********************************************************
+!c
+!c
+!c*         3.      compute low level stresses using subcritical and
+!c*                 supercritical forms.computes anisotropy coefficient
+!c*                 as measure of orographic twodimensionality.
+!c
+  300 continue
+!c
+      call gwstress                                                                  &
+       &    ( nlon  , nlev                                                           &
+       &    , ktest , icrit, ikenvh, iknu                                            &
+       &    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic                         &
+       &    , ztau                                                                   &
+       &    , pgeom1,zdmod)
+!c
+!c
+!c*         4.      compute stress profile.
+!c*                 ------- ------ --------
+!c
+  400 continue
+!c
+!c
+      call gwprofil                                                                  &
+       &       (  nlon , nlev                                                        &
+       &       , kgwd   , kdx , ktest                                                &
+       &       , ikcrith, icrit                                                      &
+       &       , paphm1, zrho   , zstab ,  zvph                                      &
+       &       , zri   , ztau                                                        &
+       &       , zdmod , psig  , pstd)
+!c
+!c
+!c*         5.      compute tendencies.
+!c*                 -------------------
+!c
+  500 continue
+!c
+!c  explicit solution at all levels for the gravity wave
+!c  implicit solution for the blocked levels
+
+      do 510 jl=kidia,kfdia
+      zvidis(jl)=0.0
+      zdudt(jl)=0.0
+      zdvdt(jl)=0.0
+      zdtdt(jl)=0.0
+  510 continue
+!c
+      ilevp1=klev+1
+!c
+!c
+      do 524 jk=1,klev
+!c
+!c
+!c     do 523 jl=1,kgwd
+!c     ji=kdx(jl)
+!c  Modif vectorisation 02/04/2004
+      do 523 ji=kidia,kfdia
+      if(ktest(ji).eq.1) then
+
+      zdelp=paphm1(ji,jk+1)-paphm1(ji,jk)
+      ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,ilevp1)*zdelp)
+      zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
+      zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
+!c
+!c controle des overshoots:
+!c
+      zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2)+1.E-12
+      ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst+1.E-12
+      rover=0.25
+      if(zforc.ge.rover*ztend)then
+        zdudt(ji)=rover*ztend/zforc*zdudt(ji)
+        zdvdt(ji)=rover*ztend/zforc*zdvdt(ji)
+      endif
+!c
+!c fin du controle des overshoots
+!c
+      if(jk.ge.ikenvh(ji)) then
+         zb=1.0-0.18*pgamma(ji)-0.04*pgamma(ji)**2
+         zc=0.48*pgamma(ji)+0.3*pgamma(ji)**2
+         zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji))
+         zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
+         zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2
+	     ratio=(cos(zpsi(ji,jk))**2+pgamma(ji)*sin(zpsi(ji,jk))**2)/                    &
+       &   (pgamma(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
+         zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv
+!c
+!c simplement oppose au vent
+!c
+         zdudt(ji)=-pum1(ji,jk)/ztmst
+         zdvdt(ji)=-pvm1(ji,jk)/ztmst
+!c
+!c  projection dans la direction de l'axe principal de l'orographie
+!cmod     zdudt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+!cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+!cmod *              *cos(ptheta(ji)*rpi/180.)/ztmst
+!cmod     zdvdt(ji)=-(pum1(ji,jk)*cos(ptheta(ji)*rpi/180.)
+!cmod *              +pvm1(ji,jk)*sin(ptheta(ji)*rpi/180.))
+!cmod *              *sin(ptheta(ji)*rpi/180.)/ztmst
+         zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet))
+         zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet))
+      end if
+      pvom(ji,jk)=zdudt(ji)
+      pvol(ji,jk)=zdvdt(ji)
+      zust=pum1(ji,jk)+ztmst*zdudt(ji)
+      zvst=pvm1(ji,jk)+ztmst*zdvdt(ji)
+      zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
+      zdedt(ji)=zdis/ztmst
+      zvidis(ji)=zvidis(ji)+zdis*zdelp
+      zdtdt(ji)=zdedt(ji)/rcpd
+!c     pte(ji,jk)=zdtdt(ji)
+!c
+!c  ENCORE UN TRUC POUR EVITER LES EXPLOSIONS
+!c
+      pte(ji,jk)=0.0
+
+      endif
+  523 continue
+
+  524 continue
+!c
+!c
+      return
+      end SUBROUTINE orodrag
+
+      SUBROUTINE orosetup                                                            &
+       &         ( nlon   , ktest                                                    &
+       &         , kkcrit, kkcrith, kcrit                                            &
+       &         , kkenvh, kknu  , kknu2                                             &
+       &         , paphm1, papm1 , pum1   , pvm1 , ptm1  , pgeom1, pstd              &
+       &         , prho  , pri   , pstab  , ptau , pvph  ,ppsi, pzdep                &
+       &         , pulow , pvlow                                                     &
+       &         , ptheta, pgamma, pmea, ppic, pval                                  &
+       &         , pnu  ,  pd1  ,  pd2  ,pdmod  )
+!c
+!c**** *gwsetup*
+!c
+!c     purpose.
+!c     --------
+!c
+!c**   interface.
+!c     ----------
+!c          from *orodrag*
+!c
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c     ==== outputs ===
+!c
+!c        implicit arguments :   none
+!c        --------------------
+!c
+!c     method.
+!c     -------
+!c
+!c
+!c     externals.
+!c     ----------
+!c
+!c
+!c     reference.
+!c     ----------
+!c
+!c        see ecmwf research department documentation of the "i.f.s."
+!c
+!c     author.
+!c     -------
+!c
+!c     modifications.
+!c     --------------
+!c     f.lott  for the new-gwdrag scheme november 1993
+!c
+!c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+!c
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+!c-----------------------------------------------------------------------
+!c
+!c*       0.1   arguments
+!c              ---------
+!c
+      integer nlon
+      integer jl, jk
+      real zdelp
+
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),                                &
+       &        ktest(nlon),kkenvh(nlon)
+
+!c
+      real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev),                     &
+       &     pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev),                      &
+       &     prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1),                  &
+       &     ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1),                  &
+       &     pzdep(nlon,klev)
+       real pulow(nlon),pvlow(nlon),ptheta(nlon),pgamma(nlon),pnu(nlon),             &
+       &     pd1(nlon),pd2(nlon),pdmod(nlon)
+      real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon)
+!c
+!c-----------------------------------------------------------------------
+!c
+!c*       0.2   local arrays
+!c              ------------
+!c
+!c
+      integer ilevm1, ilevm2, ilevh
+      real zcons1, zcons2,zcons3, zhgeo
+      real zu, zphi, zvt1,zvt2, zst, zvar, zdwind, zwind
+      real zstabm, zstabp, zrhom,  zrhop, alpha
+      real zggeenv, zggeom1,zgvar 
+      logical lo 
+      logical ll1(klon,klev+1)
+      integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon),                        &
+       &        kentp(klon),ncount(klon)  
+!c
+      real zhcrit(klon,klev),zvpf(klon,klev),                                        &
+       &     zdp(klon,klev)
+      real znorm(klon),zb(klon),zc(klon),                                            &
+       &      zulow(klon),zvlow(klon),znup(klon),znum(klon)
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.    initialization
+!c                --------------
+!c
+!c     print *,' entree gwsetup'
+ 100  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.1   computational constants
+!c                -----------------------
+!c
+ 110  continue
+!c
+      ilevm1=klev-1
+      ilevm2=klev-2
+      ilevh =klev/3
+!c
+      zcons1=1./rd
+!cold  zcons2=g**2/cpd
+      zcons2=rg**2/rcpd
+!cold  zcons3=1.5*api
+      zcons3=1.5*rpi
+!c
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         2.
+!c                --------------
+!c
+ 200  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         2.1     define low level wind, project winds in plane of
+!c*                 low level wind, determine sector in which to take
+!c*                 the variance and set indicator for critical levels.
+!c
+!c
+!c
+      do 2001 jl=kidia,kfdia
+      kknu(jl)    =klev
+      kknu2(jl)   =klev
+      kknub(jl)   =klev
+      kknul(jl)   =klev
+      pgamma(jl) =max(pgamma(jl),gtsec)
+      ll1(jl,klev+1)=.false.
+ 2001 continue
+!c
+!c Ajouter une initialisation (L. Li, le 23fev99):
+!c
+      do jk=klev,ilevh,-1
+      do jl=kidia,kfdia
+      ll1(jl,jk)= .FALSE.
+      ENDDO
+      ENDDO
+!c
+!c*      define top of low level flow
+!c       ----------------------------
+      do 2002 jk=klev,ilevh,-1
+      do 2003 jl=kidia,kfdia
+      lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr
+      if(lo) then
+        kkcrit(jl)=jk
+      endif
+      zhcrit(jl,jk)=ppic(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu(jl)=ilevh
+ 2003 continue
+ 2002 continue
+      do 2004 jk=klev,ilevh,-1
+      do 2005 jl=kidia,kfdia
+      zhcrit(jl,jk)=ppic(jl)-pval(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu2(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh
+ 2005 continue
+ 2004 continue
+      do 2006 jk=klev,ilevh,-1
+      do 2007 jl=kidia,kfdia
+      zhcrit(jl,jk)=amax1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl))
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknub(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknub(jl)=ilevh
+ 2007 continue
+ 2006 continue
+!c
+      do 2010 jl=kidia,kfdia  
+      kknu(jl)=min(kknu(jl),nktopg)
+      kknu2(jl)=min(kknu2(jl),nktopg)
+      kknub(jl)=min(kknub(jl),nktopg)
+      kknul(jl)=klev
+ 2010 continue      
+!c
+
+ 210  continue
+!c
+!c
+!cc*     initialize various arrays
+!c
+      do 2107 jl=kidia,kfdia
+      prho(jl,klev+1)  =0.0
+      pstab(jl,klev+1) =0.0
+      pstab(jl,1)      =0.0
+      pri(jl,klev+1)   =9999.0
+      ppsi(jl,klev+1)  =0.0
+      pri(jl,1)        =0.0
+      pvph(jl,1)       =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      zulow(jl)        =0.0
+      zvlow(jl)        =0.0
+      kkcrith(jl)      =klev
+      kkenvh(jl)       =klev
+      kentp(jl)        =klev
+      kcrit(jl)        =1
+      ncount(jl)       =0
+      ll1(jl,klev+1)   =.false.
+ 2107 continue
+!c
+!c*     define low-level flow
+!c      ---------------------
+!c
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))*                          &
+       &  (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+        pstab(jl,jk)=max(pstab(jl,jk),gssec)
+      endif
+  222 continue
+  223 continue
+!c
+!c********************************************************************
+!c
+!c*     define blocked flow
+!c      -------------------
+      do 2115 jk=klev,ilevh,-1
+      do 2116 jl=kidia,kfdia
+      if(jk.ge.kknub(jl).and.jk.le.kknul(jl)) then
+        pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      end if
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknub(jl)))
+      znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+      pvph(jl,klev+1)=znorm(jl)
+ 2110 continue
+!c
+!c*******  setup orography axes and define plane of profiles  *******
+!c
+      do 2112 jl=kidia,kfdia
+      lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec)
+      if(lo) then
+        zu=pulow(jl)+2.*gvsec
+      else
+        zu=pulow(jl)
+      endif
+      zphi=atan(pvlow(jl)/zu)
+      ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi
+      zb(jl)=1.-0.18*pgamma(jl)-0.04*pgamma(jl)**2
+      zc(jl)=0.48*pgamma(jl)+0.3*pgamma(jl)**2
+      pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
+      pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))*cos(ppsi(jl,klev+1))
+      pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2)
+ 2112 continue
+!c
+!c  ************ define flow in plane of lowlevel stress *************
+!c
+      do 213 jk=1,klev
+      do 212 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        zvt1       =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk)
+        zvt2       =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk)
+        zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
+      endif
+      ptau(jl,jk)  =0.0
+      pzdep(jl,jk) =0.0
+      ppsi(jl,jk)  =0.0
+      ll1(jl,jk)   =.false.
+  212 continue
+  213 continue
+      do 215 jk=2,klev
+      do 214 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+                     &
+       &            (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1))                      &
+       &            /zdp(jl,jk)
+        if(pvph(jl,jk).lt.gvsec) then
+          pvph(jl,jk)=gvsec
+          kcrit(jl)=jk
+        endif
+      endif
+  214 continue
+  215 continue
+!c
+!c
+!c*         2.2     brunt-vaisala frequency and density at half levels.
+!c
+  220 continue
+!c
+      do 2211 jk=ilevh,klev
+      do 221 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      if(jk.ge.(kknub(jl)+1).and.jk.le.kknul(jl)) then
+           zst=zcons2/ptm1(jl,jk)*(1.-rcpd*prho(jl,jk)*                              &
+       &                   (ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+           pstab(jl,klev+1)=pstab(jl,klev+1)+zst*zdp(jl,jk)
+           pstab(jl,klev+1)=max(pstab(jl,klev+1),gssec)
+           prho(jl,klev+1)=prho(jl,klev+1)+paphm1(jl,jk)*2.*zdp(jl,jk)               &
+       &                   *zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+      endif
+      endif
+  221 continue
+ 2211 continue
+!c
+      do 2212 jl=kidia,kfdia
+        pstab(jl,klev+1)=pstab(jl,klev+1)/(papm1(jl,kknul(jl))                       &
+       &                                          -papm1(jl,kknub(jl)))
+        prho(jl,klev+1)=prho(jl,klev+1)/(papm1(jl,kknul(jl))                         &
+       &                                          -papm1(jl,kknub(jl)))
+        zvar=pstd(jl)
+ 2212 continue
+!c
+!c*         2.3     mean flow richardson number.
+!c*                 and critical height for froude layer
+!c
+  230 continue
+!c
+      do 232 jk=2,klev
+      do 231 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec)
+        pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk)                                          &
+       &          /(rg*prho(jl,jk)*zdwind))**2
+        pri(jl,jk)=max(pri(jl,jk),grcrit)
+      endif
+  231 continue
+  232 continue
+  
+!c
+!c
+!c*      define top of 'envelope' layer
+!c       ----------------------------
+
+      do 233 jl=kidia,kfdia
+      pnu (jl)=0.0
+      znum(jl)=0.0
+ 233  continue
+      
+!      do 234 jk=2,klev-1
+!      do 234 jl=kidia,kfdia
+! L. Fita. July 2013
+      DO jk=2,klev-1
+      DO jl=kidia,kfdia
+
+      
+      if(ktest(jl).eq.1) then
+       
+      if (jk.ge.kknub(jl)) then
+          
+            znum(jl)=pnu(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/                     &
+       &            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            pnu(jl) = pnu(jl) + (zdelp/rg)*                                          &
+       &            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit)                        &
+       &                          .and.(kkenvh(jl).eq.klev)) THEN                        
+             kkenvh(jl)=jk                                                          
+            endif    
+
+      endif
+      END IF
+      
+! 234  continue
+      END DO
+      END DO
+      
+!c  calculation of a dynamical mixing height for the breaking
+!c  of gravity waves:
+
+              
+      do 235 jl=kidia,kfdia
+      znup(jl)=0.0
+      znum(jl)=0.0
+ 235  continue
+
+!      do 236 jk=klev-1,2,-1
+!      do 236 jl=kidia,kfdia
+! L. Fita, July 2013
+      DO jk=klev-1,2,-1
+      DO jl=kidia,kfdia
+
+      
+      if(ktest(jl).eq.1) then
+
+            znum(jl)=znup(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/                     &
+       &            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            znup(jl) = znup(jl) + (zdelp/rg)*                                        &
+       &            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.rpi/2.).and.(znup(jl).gt.rpi/2.)                         &
+       &                          .and.(kkcrith(jl).eq.klev)) THEN                       
+              kkcrith(jl)=jk                                                         
+            endif
+      
+      END IF
+! 236  continue
+      END DO
+      END DO
+ 
+      do 237 jl=kidia,kfdia
+      kkcrith(jl)=min0(kkcrith(jl),kknu2(jl))
+      kkcrith(jl)=max0(kkcrith(jl),ilevh*2)
+ 237  continue         
+!c
+!c     directional info for flow blocking ************************* 
+!c
+      do 251 jk=ilevh,klev    
+      do 252 jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+      lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec)
+      if(lo) then
+        zu=pum1(jl,jk)+2.*gvsec
+      else
+        zu=pum1(jl,jk)
+      endif
+       zphi=atan(pvm1(jl,jk)/zu)
+       ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi
+      end if
+ 252  continue
+ 251  continue
+!c      forms the vertical 'leakiness' **************************
+
+      alpha=3.
+      
+      do 254  jk=ilevh,klev
+      do 253  jl=kidia,kfdia
+      if(jk.ge.kkenvh(jl)) then
+        zggeenv=amax1(1.,                                                            &
+       &          (pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)-1))/2.)      
+        zggeom1=amax1(pgeom1(jl,jk),1.)
+        zgvar=amax1(pstd(jl)*rg,1.)     
+!cmod    pzdep(jl,jk)=sqrt((zggeenv-zggeom1)/(zggeom1+zgvar))      
+        pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,  jk))/                      &
+       &               (pgeom1(jl,kkenvh(jl)-1)-pgeom1(jl,klev))
+      end if
+ 253  continue
+ 254  continue
+
+ 260  continue
+
+      return
+      end SUBROUTINE orosetup
+
+      SUBROUTINE gwstress                                                            &
+       &         (  nlon  , nlev                                                     &
+       &         , ktest, kcrit, kkenvh                                              &
+       &         , kknu                                                              &
+       &         , prho  , pstab , pvph  , pstd, psig                                &
+       &         , pmea , ppic  , ptau                                               &
+       &         , pgeom1 , pdmod )
+!c
+!c**** *gwstress*
+!c
+!c     purpose.
+!c     --------
+!c
+!c**   interface.
+!c     ----------
+!c     call *gwstress*  from *gwdrag*
+!c
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c     ==== outputs ===
+!c
+!c        implicit arguments :   none
+!c        --------------------
+!c
+!c     method.
+!c     -------
+!c
+!c
+!c     externals.
+!c     ----------
+!c
+!c
+!c     reference.
+!c     ----------
+!c
+!c        see ecmwf research department documentation of the "i.f.s."
+!c
+!c     author.
+!c     -------
+!c
+!c     modifications.
+!c     --------------
+!c     f. lott put the new gwd on ifs      22/11/93
+!c
+!c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+!c-----------------------------------------------------------------------
+!c
+!c*       0.1   arguments
+!c              ---------
+!c
+      integer nlon, nlev
+      integer kcrit(nlon),                                                           &
+       &        ktest(nlon),kkenvh(nlon),kknu(nlon)
+!c
+      real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1),                   &
+       &     pvph(nlon,nlev+1),                                                      &
+       &     pgeom1(nlon,nlev),pstd(nlon)
+!c
+      real psig(nlon)
+      real pmea(nlon),ppic(nlon)
+      real pdmod(nlon)
+!c
+!c-----------------------------------------------------------------------
+!c
+!c*       0.2   local arrays
+!c              ------------
+      integer jl
+      real zblock, zvar, zeff
+      logical lo
+!c
+!c-----------------------------------------------------------------------
+!c
+!c*       0.3   functions
+!c              ---------
+!c     ------------------------------------------------------------------
+!c
+!c*         1.    initialization
+!c                --------------
+!c
+ 100  continue
+!c
+!c*         3.1     gravity wave stress.
+!c
+  300 continue
+!c
+!c
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      
+!c  effective mountain height above the blocked flow
+  
+         if(kkenvh(jl).eq.klev)then
+         zblock=0.0 
+         else
+         zblock=(pgeom1(jl,kkenvh(jl))+pgeom1(jl,kkenvh(jl)+1))/2./rg          
+         endif
+      
+        zvar=ppic(jl)-pmea(jl)
+        zeff=amax1(0.,zvar-zblock)
+
+        ptau(jl,klev+1)=prho(jl,klev+1)*gkdrag*psig(jl)*zeff**2                      &
+       &    /4./pstd(jl)*pvph(jl,klev+1)*pdmod(jl)*sqrt(pstab(jl,klev+1))
+
+!c  too small value of stress or  low level flow include critical level
+!c  or low level flow:  gravity wave stress nul.
+                
+        lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl))                     &
+       &      .or.(pvph(jl,klev+1).lt.gvcrit)
+!c       if(lo) ptau(jl,klev+1)=0.0
+      
+      else
+      
+          ptau(jl,klev+1)=0.0
+          
+      endif
+      
+  301 continue
+!c
+      return
+      end SUBROUTINE gwstress
+
+      SUBROUTINE GWPROFIL                                                            &
+       &         ( NLON, NLEV                                                        &
+       &         , kgwd, kdx , ktest                                                 &
+       &         , KKCRITH, KCRIT                                                    &
+       &         , PAPHM1, PRHO   , PSTAB  , PVPH , PRI , PTAU                       &
+       &         , pdmod   , psig , pvar)
+
+!C**** *GWPROFIL*
+!C
+!C     PURPOSE.
+!C     --------
+!C
+!C**   INTERFACE.
+!C     ----------
+!C          FROM *GWDRAG*
+!C
+!C        EXPLICIT ARGUMENTS :
+!C        --------------------
+!C     ==== INPUTS ===
+!C     ==== OUTPUTS ===
+!C
+!C        IMPLICIT ARGUMENTS :   NONE
+!C        --------------------
+!C
+!C     METHOD:
+!C     -------
+!C     THE STRESS PROFILE FOR GRAVITY WAVES IS COMPUTED AS FOLLOWS:
+!C     IT IS CONSTANT (NO GWD) AT THE LEVELS BETWEEN THE GROUND
+!C     AND THE TOP OF THE BLOCKED LAYER (KKENVH).
+!C     IT DECREASES LINEARLY WITH HEIGHTS FROM THE TOP OF THE 
+!C     BLOCKED LAYER TO 3*VAROR (kKNU), TO SIMULATES LEE WAVES OR 
+!C     NONLINEAR GRAVITY WAVE BREAKING.
+!C     ABOVE IT IS CONSTANT, EXCEPT WHEN THE WAVE ENCOUNTERS A CRITICAL
+!C     LEVEL (KCRIT) OR WHEN IT BREAKS.
+!C     
+!C
+!C
+!C     EXTERNALS.
+!C     ----------
+!C
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE "I.F.S."
+!C
+!C     AUTHOR.
+!C     -------
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C     PASSAGE OF THE NEW GWDRAG TO I.F.S. (F. LOTT, 22/11/93)
+!C-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+!C
+
+!C
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+!C-----------------------------------------------------------------------
+!C
+!C*       0.1   ARGUMENTS
+!C              ---------
+!C
+      integer nlon,nlev
+      INTEGER KKCRITH(NLON),KCRIT(NLON)                                              &
+       &       ,kdx(nlon) , ktest(nlon)
+
+!C
+      REAL PAPHM1(NLON,NLEV+1), PSTAB(NLON,NLEV+1),                                  &
+       &     PRHO  (NLON,NLEV+1), PVPH (NLON,NLEV+1),                                &
+       &     PRI   (NLON,NLEV+1), PTAU(NLON,NLEV+1)                                  
+      REAL pdmod (NLON) , psig(NLON),                                                &
+       &     pvar(NLON)                                                              
+!C-----------------------------------------------------------------------
+!C
+!C*       0.2   LOCAL ARRAYS
+!C              ------------
+!C
+      integer ilevh, ji, kgwd, jl, jk
+      real zsqr, zalfa, zriw, zdel, zb, zalpha,zdz2n
+      real zdelp, zdelpt 
+      REAL ZDZ2 (KLON,KLEV) , ZNORM(KLON) , zoro(KLON)
+      REAL ZTAU (KLON,KLEV+1)
+!C
+!C-----------------------------------------------------------------------
+!C
+!C*         1.    INITIALIZATION
+!C                --------------
+!C
+!c      print *,' entree gwprofil' 
+ 100  CONTINUE
+!C
+!C
+!C*    COMPUTATIONAL CONSTANTS.
+!C     ------------- ----------
+!C
+      ilevh=KLEV/3
+!C
+!c     DO 400 ji=1,kgwd
+!c     jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      DO 400 jl=kidia,kfdia
+      if (ktest(jl).eq.1) then
+      Zoro(JL)=Psig(JL)*Pdmod(JL)/4./max(pvar(jl),1.0)
+      ZTAU(JL,KLEV+1)=PTAU(JL,KLEV+1)
+      endif
+  400 CONTINUE
+  
+!C
+      DO 430 JK=KLEV,2,-1
+!C
+!C
+!C*         4.1    CONSTANT WAVE STRESS UNTIL TOP OF THE
+!C                 BLOCKING LAYER.
+  410 CONTINUE
+!C
+!c     DO 411 ji=1,kgwd
+!c     jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 411 jl=kidia,kfdia
+      if (ktest(jl).eq.1) then
+           IF(JK.GT.KKCRITH(JL)) THEN
+           PTAU(JL,JK)=ZTAU(JL,KLEV+1)
+!C          ENDIF
+!C          IF(JK.EQ.KKCRITH(JL)) THEN
+           ELSE                    
+           PTAU(JL,JK)=GRAHILO*ZTAU(JL,KLEV+1)
+           ENDIF
+      endif
+ 411  CONTINUE             
+!C
+!C*         4.15   CONSTANT SHEAR STRESS UNTIL THE TOP OF THE
+!C                 LOW LEVEL FLOW LAYER.
+ 415  CONTINUE
+!C        
+!C
+!C*         4.2    WAVE DISPLACEMENT AT NEXT LEVEL.
+!C
+  420 CONTINUE
+!C
+!c     DO 421 ji=1,kgwd
+!c     jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 421 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      IF(JK.LT.KKCRITH(JL)) THEN
+      ZNORM(JL)=gkdrag*PRHO(JL,JK)*SQRT(PSTAB(JL,JK))*PVPH(JL,JK)                    &
+       &                                                    *zoro(jl)
+      ZDZ2(JL,JK)=PTAU(JL,JK+1)/max(ZNORM(JL),gssec)
+      ENDIF
+      endif
+  421 CONTINUE
+!C
+!C*         4.3    WAVE RICHARDSON NUMBER, NEW WAVE DISPLACEMENT
+!C*                AND STRESS:  BREAKING EVALUATION AND CRITICAL 
+!C                 LEVEL
+!C
+                          
+!c     DO 431 ji=1,kgwd
+!c     jl=Kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 431 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+          IF(JK.LT.KKCRITH(JL)) THEN
+          IF((PTAU(JL,JK+1).LT.GTSEC).OR.(JK.LE.KCRIT(JL))) THEN
+            PTAU(JL,JK)=0.0
+          ELSE
+               ZSQR=SQRT(PRI(JL,JK))
+               ZALFA=SQRT(PSTAB(JL,JK)*ZDZ2(JL,JK))/PVPH(JL,JK)
+               ZRIW=PRI(JL,JK)*(1.-ZALFA)/(1+ZALFA*ZSQR)**2
+               IF(ZRIW.LT.GRCRIT) THEN
+                 ZDEL=4./ZSQR/GRCRIT+1./GRCRIT**2+4./GRCRIT
+                 ZB=1./GRCRIT+2./ZSQR
+                 ZALPHA=0.5*(-ZB+SQRT(ZDEL))
+                 ZDZ2N=(PVPH(JL,JK)*ZALPHA)**2/PSTAB(JL,JK)
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2N
+               ELSE
+                 PTAU(JL,JK)=ZNORM(JL)*ZDZ2(JL,JK)
+               ENDIF
+            PTAU(JL,JK)=MIN(PTAU(JL,JK),PTAU(JL,JK+1))
+          ENDIF
+          ENDIF
+      endif
+  431 CONTINUE
+  
+  430 CONTINUE
+  440 CONTINUE
+  
+!C  REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
+
+!c     DO 530 ji=1,kgwd
+!c     jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      ZTAU(JL,KKCRITH(JL))=PTAU(JL,KKCRITH(JL))
+      ZTAU(JL,NSTRA)=PTAU(JL,NSTRA)
+      endif
+ 530  CONTINUE      
+
+      DO 531 JK=1,KLEV
+      
+!c     DO 532 ji=1,kgwd
+!c     jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 532 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+                
+         IF(JK.GT.KKCRITH(JL))THEN
+
+          ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KLEV+1    )
+          ZDELPT=PAPHM1(JL,KKCRITH(JL))-PAPHM1(JL,KLEV+1    )
+          PTAU(JL,JK)=ZTAU(JL,KLEV+1    ) +                                          &
+       &                (ZTAU(JL,KKCRITH(JL))-ZTAU(JL,KLEV+1    ) )*                 &
+       &                ZDELP/ZDELPT
+         ENDIF
+            
+      endif
+ 532  CONTINUE    
+ 
+!C  REORGANISATION IN THE STRATOSPHERE
+
+!c     DO 533 ji=1,kgwd
+!c     jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 533 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+
+         IF(JK.LT.NSTRA)THEN
+
+          ZDELP =PAPHM1(JL,NSTRA)
+          ZDELPT=PAPHM1(JL,JK)
+          PTAU(JL,JK)=ZTAU(JL,NSTRA)*ZDELPT/ZDELP 
+
+        ENDIF
+
+      endif
+ 533  CONTINUE
+
+!C REORGANISATION IN THE TROPOSPHERE
+
+!c      DO 534 ji=1,kgwd
+!c      jl=kdx(ji)
+!c  Modif vectorisation 02/04/2004
+      do 534 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+
+         IF(JK.LT.KKCRITH(JL).AND.JK.GT.NSTRA)THEN
+
+           ZDELP=PAPHM1(JL,JK)-PAPHM1(JL,KKCRITH(JL))
+           ZDELPT=PAPHM1(JL,NSTRA)-PAPHM1(JL,KKCRITH(JL))
+           PTAU(JL,JK)=ZTAU(JL,KKCRITH(JL)) +                                        &
+       &                 (ZTAU(JL,NSTRA)-ZTAU(JL,KKCRITH(JL)))*ZDELP                 &
+       &                                                     /ZDELPT
+
+       ENDIF
+      endif
+ 534   CONTINUE
+
+ 
+ 531  CONTINUE        
+
+
+      RETURN
+      END SUBROUTINE GWPROFIL
+
+      SUBROUTINE lift_noro (nlon,nlev,dtime,paprs,pplay,                             &
+       &                   plat,pmea,pstd, ppic,                                     &
+       &                   ktest,                                                    &
+       &                   t, u, v,                                                  &
+       &                   pulow, pvlow, pustr, pvstr,                               &
+       &                   d_t, d_u, d_v)
+!c
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+!c Objet: Frottement de la montagne Interface
+!c======================================================================
+!c Arguments:
+!c dtime---input-R- pas d'integration (s)
+!c paprs---input-R-pression pour chaque inter-couche (en Pa)
+!c pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+!c t-------input-R-temperature (K)
+!c u-------input-R-vitesse horizontale (m/s)
+!c v-------input-R-vitesse horizontale (m/s)
+!c
+!c d_t-----output-R-increment de la temperature
+!c d_u-----output-R-increment de la vitesse u
+!c d_v-----output-R-increment de la vitesse v
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c
+!c ARGUMENTS
+!c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL plat(nlon),pmea(nlon)
+      REAL pstd(nlon)
+      REAL ppic(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+!c
+      INTEGER i, k, ktest(nlon)
+!c
+!c Variables locales:
+!c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+!c
+!c initialiser les variables de sortie (pour securite)
+!c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+!c
+!c preparer les variables d'entree (attention: l'ordre des niveaux 
+!c verticaux augmente du haut vers le bas)
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)                                             &
+       &                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0                    &
+       &               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+!c
+!c appeler la routine principale
+!c
+      CALL OROLIFT(klon,klev,ktest,                                                  &
+       &            dtime,                                                           &
+       &            papmh, zgeom,                                                    &
+       &            pt, pu, pv,                                                      &
+       &            plat,pmea, pstd, ppic,                                           &
+       &            pulow,pvlow,                                                     &
+       &            pdudt,pdvdt,pdtdt)
+!C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)                                                  &
+!IM BUG .                 +RG*pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))                   &
+       &                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+         pvstr(i)        = pvstr(i)                                                  &
+!IM BUG .                 +RG*pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))                   &
+       &                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/RG
+      ENDDO
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE lift_noro
+
+      SUBROUTINE OROLIFT( NLON,NLEV                                                  &
+       &                 , KTEST                                                     &
+       &                 , PTSPHY                                                    &
+       &                 , PAPHM1,PGEOM1,PTM1,PUM1,PVM1                              &
+       &                 , PLAT                                                      &
+       &                 , PMEA, PVAROR, ppic                                        &
+!C OUTPUTS                                                                           &
+       &                 , PULOW,PVLOW                                               &
+       &                 , PVOM,PVOL,PTE )
+
+!C
+!C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
+!C
+!C     PURPOSE.
+!C     --------
+!C
+!C**   INTERFACE.
+!C     ----------
+!C          CALLED FROM *lift_noro
+!C     ----------
+!C
+!C     AUTHOR.
+!C     -------
+!C     F.LOTT  LMD 22/11/95
+!C
+      USE dimphy
+      implicit none
+!C
+!C
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+!C-----------------------------------------------------------------------
+!C
+!C*       0.1   ARGUMENTS
+!C              ---------
+!C
+!C
+      integer nlon, nlev
+      REAL  PTE(NLON,NLEV),                                                          &
+       &      PVOL(NLON,NLEV),                                                       &
+       &      PVOM(NLON,NLEV),                                                       &
+       &      PULOW(NLON),                                                           &
+       &      PVLOW(NLON)
+      REAL  PUM1(NLON,NLEV),                                                         &
+       &      PVM1(NLON,NLEV),                                                       &
+       &      PTM1(NLON,NLEV),                                                       &
+       &      PLAT(NLON),PMEA(NLON),                                                 &
+       &      PVAROR(NLON),                                                          &
+       &      ppic(NLON),                                                            &
+       &      PGEOM1(NLON,NLEV),                                                     &
+       &      PAPHM1(NLON,NLEV+1)
+!C
+      INTEGER  KTEST(NLON)
+      real ptsphy
+!C-----------------------------------------------------------------------
+!C
+!C*       0.2   LOCAL ARRAYS
+!C              ------------
+      logical lifthigh
+!cym      integer klevm1, jl, ilevh, jk
+      integer  jl, ilevh, jk
+      real zcons1, ztmst, zrtmst,zpi, zhgeo
+      real zdelp, zslow, zsqua, zscav, zbet
+      INTEGER                                                                        &
+       &         IKNUB(klon),                                                        &
+       &         IKNUL(klon)
+      LOGICAL LL1(KLON,KLEV+1)
+!C
+      REAL   ZTAU(KLON,KLEV+1),                                                      &
+       &       ZTAV(KLON,KLEV+1),                                                    &
+       &       ZRHO(KLON,KLEV+1)
+      REAL   ZDUDT(KLON),                                                            &
+       &       ZDVDT(KLON)
+      REAL ZHCRIT(KLON,KLEV)
+      CHARACTER (LEN=20) :: modname='orografi'
+      CHARACTER (LEN=80) :: abort_message
+!C-----------------------------------------------------------------------
+!C
+!C*         1.1  INITIALIZATIONS
+!C               ---------------
+
+      LIFTHIGH=.FALSE.
+
+      IF(NLON.NE.KLON.OR.NLEV.NE.KLEV)THEN
+        abort_message = 'pb dimension'
+        CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+      ZCONS1=1./RD
+!cym      KLEVM1=KLEV-1
+      ZTMST=PTSPHY
+      ZRTMST=1./ZTMST
+      ZPI=ACOS(-1.)
+!C
+      DO 1001 JL=kidia,kfdia
+      ZRHO(JL,KLEV+1)  =0.0
+      PULOW(JL)        =0.0
+      PVLOW(JL)        =0.0
+      iknub(JL)   =klev
+      iknul(JL)   =klev
+      ilevh=klev/3
+      ll1(jl,klev+1)=.false.
+      DO 1000 JK=1,KLEV
+      PVOM(JL,JK)=0.0
+      PVOL(JL,JK)=0.0
+      PTE (JL,JK)=0.0
+ 1000 CONTINUE
+ 1001 CONTINUE
+
+!C
+!C*         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
+!C*                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
+!C*                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
+!C
+!C
+!C
+      DO 2006 JK=KLEV,1,-1
+      DO 2007 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZHCRIT(JL,JK)=amax1(Ppic(JL)-pmea(JL),100.)
+      ZHGEO=PGEOM1(JL,JK)/RG
+      ll1(JL,JK)=(ZHGEO.GT.ZHCRIT(JL,JK))
+      IF(ll1(JL,JK).neqv.ll1(JL,JK+1)) THEN
+        iknub(JL)=JK
+      ENDIF
+      ENDIF
+ 2007 CONTINUE
+ 2006 CONTINUE
+!C
+      do 2010 jl=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      iknub(jl)=max(iknub(jl),klev/2)
+      iknul(jl)=max(iknul(jl),2*klev/3)
+      if(iknub(jl).gt.nktopg) iknub(jl)=nktopg
+      if(iknub(jl).eq.nktopg) iknul(jl)=klev
+      if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1
+      ENDIF
+ 2010 continue
+
+!C     do 2011 jl=kidia,kfdia
+!C     IF(KTEST(JL).EQ.1) THEN
+!C       print *,' iknul= ',iknul(jl),'  iknub=',iknub(jl)
+!C     ENDIF
+!C2011 continue
+
+!C     PRINT *,'  DANS OROLIFT: 2010'
+
+      DO 223 JK=KLEV,2,-1
+      DO 222 JL=kidia,kfdia
+        ZRHO(JL,JK)=2.*PAPHM1(JL,JK)*ZCONS1/(PTM1(JL,JK)+PTM1(JL,JK-1))
+  222 CONTINUE
+  223 CONTINUE
+!C     PRINT *,'  DANS OROLIFT: 223'
+
+!C********************************************************************
+!C
+!C*     DEFINE LOW LEVEL FLOW
+!C      -------------------
+      DO 2115 JK=klev,1,-1
+      DO 2116 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then
+        pulow(JL)=pulow(JL)+PUM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        pvlow(JL)=pvlow(JL)+PVM1(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+        zrho(JL,klev+1)=zrho(JL,klev+1)                                              &
+       &                 +zrho(JL,JK)*(PAPHM1(JL,JK+1)-PAPHM1(JL,JK))
+      end if
+      ENDIF
+ 2116 CONTINUE
+ 2115 CONTINUE
+      DO 2110 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      pulow(JL)=pulow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      pvlow(JL)=pvlow(JL)/(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      zrho(JL,klev+1)=zrho(JL,klev+1)                                                &
+       &               /(PAPHM1(JL,iknul(jl)+1)-PAPHM1(JL,iknub(jl)))
+      ENDIF
+ 2110 CONTINUE
+
+
+200   CONTINUE
+
+!C***********************************************************
+!C
+!C*         3.      COMPUTE MOUNTAIN LIFT
+!C
+  300 CONTINUE
+!C
+      DO 301 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+       ZTAU(JL,KLEV+1)= - GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*                          &
+!C    *                 (2*PVAROR(JL)+PMEA(JL))*                                     &
+       &                 2*PVAROR(JL)*                                               &
+       &                 SIN(ZPI/180.*PLAT(JL))*PVLOW(JL)
+       ZTAV(JL,KLEV+1)=   GKLIFT*ZRHO(JL,KLEV+1)*2.*ROMEGA*                          &
+!C    *                 (2*PVAROR(JL)+PMEA(JL))*                                     &
+       &                 2*PVAROR(JL)*                                               &
+       &                 SIN(ZPI/180.*PLAT(JL))*PULOW(JL)
+      ELSE
+       ZTAU(JL,KLEV+1)=0.0
+       ZTAV(JL,KLEV+1)=0.0
+      ENDIF
+301   CONTINUE
+
+!C
+!C*         4.      COMPUTE LIFT PROFILE         
+!C*                 --------------------   
+!C
+
+  400 CONTINUE
+
+      DO 401 JK=1,KLEV
+      DO 401 JL=kidia,kfdia
+      IF(KTEST(JL).EQ.1) THEN
+      ZTAU(JL,JK)=ZTAU(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ZTAV(JL,JK)=ZTAV(JL,KLEV+1)*PAPHM1(JL,JK)/PAPHM1(JL,KLEV+1)
+      ELSE
+      ZTAU(JL,JK)=0.0
+      ZTAV(JL,JK)=0.0
+      ENDIF
+401   CONTINUE
+!C
+!C
+!C*         5.      COMPUTE TENDENCIES.
+!C*                 -------------------
+      IF(LIFTHIGH)THEN
+!C
+  500 CONTINUE
+!C     PRINT *,'  DANS OROLIFT: 500'
+!C
+!C  EXPLICIT SOLUTION AT ALL LEVELS
+!C
+      DO 524 JK=1,klev
+      DO 523 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+      ZDELP=PAPHM1(JL,JK+1)-PAPHM1(JL,JK)
+      ZDUDT(JL)=-RG*(ZTAU(JL,JK+1)-ZTAU(JL,JK))/ZDELP
+      ZDVDT(JL)=-RG*(ZTAV(JL,JK+1)-ZTAV(JL,JK))/ZDELP
+      ENDIF  
+  523 CONTINUE
+  524 CONTINUE
+!C
+!C  PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
+!C
+      DO 530 JK=1,klev
+      DO 530 JL=KIDIA,KFDIA
+      IF(KTEST(JL).EQ.1) THEN
+
+        ZSLOW=SQRT(PULOW(JL)**2+PVLOW(JL)**2)
+        ZSQUA=AMAX1(SQRT(PUM1(JL,JK)**2+PVM1(JL,JK)**2),GVSEC)
+        ZSCAV=-ZDUDT(JL)*PVM1(JL,JK)+ZDVDT(JL)*PUM1(JL,JK)
+        IF(ZSQUA.GT.GVSEC)THEN
+          PVOM(JL,JK)=-ZSCAV*PVM1(JL,JK)/ZSQUA**2
+          PVOL(JL,JK)= ZSCAV*PUM1(JL,JK)/ZSQUA**2
+        ELSE
+          PVOM(JL,JK)=0.0
+          PVOL(JL,JK)=0.0      
+        ENDIF  
+        ZSQUA=SQRT(PUM1(JL,JK)**2+PUM1(JL,JK)**2)               
+        IF(ZSQUA.LT.ZSLOW)THEN
+          PVOM(JL,JK)=ZSQUA/ZSLOW*PVOM(JL,JK)
+          PVOL(JL,JK)=ZSQUA/ZSLOW*PVOL(JL,JK)
+        ENDIF 
+
+      ENDIF  
+530   CONTINUE
+!C
+!C  6.  LOW LEVEL LIFT, SEMI IMPLICIT:
+!C  ----------------------------------
+
+      ELSE
+
+        DO 601 JL=KIDIA,KFDIA
+        IF(KTEST(JL).EQ.1) THEN
+          DO JK=KLEV,IKNUB(JL),-1
+          ZBET=GKLIFT*2.*ROMEGA*SIN(ZPI/180.*PLAT(JL))*ztmst*                        &
+       &        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,  JK))/                            &
+       &        (PGEOM1(JL,IKNUB(JL)-1)-PGEOM1(JL,KLEV))
+          ZDUDT(JL)=-PUM1(JL,JK)/ztmst/(1+ZBET**2)
+          ZDVDT(JL)=-PVM1(JL,JK)/ztmst/(1+ZBET**2)
+          PVOM(JL,JK)= ZBET**2*ZDUDT(JL) - ZBET   *ZDVDT(JL)
+          PVOL(JL,JK)= ZBET   *ZDUDT(JL) + ZBET**2*ZDVDT(JL)    
+          ENDDO
+        ENDIF
+ 601    CONTINUE
+
+      ENDIF
+
+      RETURN
+      END SUBROUTINE OROLIFT
+
+
+      SUBROUTINE SUGWD(NLON,NLEV,paprs,pplay)
+      USE dimphy
+      USE mod_phys_lmdz_para
+      USE mod_grid_phy_lmdz
+!c      USE parallel
+!C
+!C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
+!C
+!C     PURPOSE.
+!C     --------
+!C           INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
+!C           GRAVITY WAVE DRAG PARAMETRIZATION.
+!C
+!C**   INTERFACE.
+!C     ----------
+!C        CALL *SUGWD* FROM *SUPHEC*
+!C              -----        ------
+!C
+!C        EXPLICIT ARGUMENTS :
+!C        --------------------
+!C        PSIG        : VERTICAL COORDINATE TABLE
+!C        NLEV        : NUMBER OF MODEL LEVELS
+!C
+!C        IMPLICIT ARGUMENTS :
+!C        --------------------
+!C        COMMON YOEGWD
+!C
+!C     METHOD.
+!C     -------
+!C        SEE DOCUMENTATION
+!C
+!C     EXTERNALS.
+!C     ----------
+!C        NONE
+!C
+!C     REFERENCE.
+!C     ----------
+!C        ECMWF Research Department documentation of the IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        MARTIN MILLER             *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 90-01-01
+!C     ------------------------------------------------------------------
+      implicit none
+!C
+!C     -----------------------------------------------------------------
+#include "YOEGWD.h"
+!C      ----------------------------------------------------------------
+!C
+      integer nlon,nlev, jk
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+      real zpr,zstra,zsigt,zpm1r
+      REAL :: pplay_glo(klon_glo,nlev)
+      REAL :: paprs_glo(klon_glo,nlev+1)
+
+!C
+!C*       1.    SET THE VALUES OF THE PARAMETERS
+!C              --------------------------------
+!C
+ 100  CONTINUE
+!C
+      PRINT *,' DANS SUGWD NLEV=',NLEV
+      GHMAX=10000.
+!C
+      ZPR=100000.
+      ZSTRA=0.1 
+      ZSIGT=0.94
+!cold  ZPR=80000.
+!cold  ZSIGT=0.85
+!C
+      
+      CALL gather(pplay,pplay_glo)
+      CALL bcast(pplay_glo)
+      CALL gather(paprs,paprs_glo)
+      CALL bcast(paprs_glo)
+      
+            
+      DO 110 JK=1,NLEV
+      ZPM1R=pplay_glo((klon_glo/2)+1,jk)/paprs_glo((klon_glo/2)+1,1) 
+      IF(ZPM1R.GE.ZSIGT)THEN
+         nktopg=JK
+      ENDIF
+      ZPM1R=pplay_glo((klon_glo/2)+1,jk)/paprs_glo((klon_glo/2)+1,1) 
+      IF(ZPM1R.GE.ZSTRA)THEN
+         NSTRA=JK
+      ENDIF
+  110 CONTINUE
+
+
+!c
+!c  inversion car dans orodrag on compte les niveaux a l'envers
+      nktopg=nlev-nktopg+1
+      nstra=nlev-nstra
+      print *,' DANS SUGWD nktopg=', nktopg
+      print *,' DANS SUGWD nstra=', nstra
+!C
+      GSIGCR=0.80
+!C
+      GKDRAG=0.2 
+      GRAHILO=1.    
+      GRCRIT=0.01
+      GFRCRIT=1.0
+      GKWAKE=0.50 
+!C
+      GKLIFT=0.50  
+      GVCRIT =0.0
+!C
+!C
+!C      ----------------------------------------------------------------
+!C
+!C*       2.    SET VALUES OF SECURITY PARAMETERS
+!C              ---------------------------------
+!C
+ 200  CONTINUE
+!C
+      GVSEC=0.10
+      GSSEC=1.E-12
+!C
+      GTSEC=1.E-07
+!C
+!C      ----------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE SUGWD
+
+END MODULE orografi_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi_strato.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi_strato.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi_strato.F	(revision 17)
@@ -0,0 +1,2060 @@
+      SUBROUTINE drag_noro_strato (nlon,nlev,dtime,paprs,pplay,
+     e                   pmea,pstd, psig, pgam, pthe,ppic,pval,
+     e                   kgwd,kdx,ktest,
+     e                   t, u, v,
+     s                   pulow, pvlow, pustr, pvstr,
+     s                   d_t, d_u, d_v)
+c
+      USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Object: Mountain drag interface. Made necessary because:
+C 1. in the LMD-GCM Layers are from bottom to top,
+C    contrary to most European GCM.
+c 2. the altitude above ground of each model layers
+c    needs to be known (variable zgeom)
+c======================================================================
+c Explicit Arguments:
+c ==================
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c dtime---input-R-Time-step (s)
+c paprs---input-R-Pressure in semi layers    (Pa)
+c pplay---input-R-Pressure model-layers      (Pa)
+c t-------input-R-temperature (K)
+c u-------input-R-Horizontal wind (m/s)
+c v-------input-R-Meridional wind (m/s)
+c pmea----input-R-Mean Orography (m)
+C pstd----input-R-SSO standard deviation (m)
+c psig----input-R-SSO slope
+c pgam----input-R-SSO Anisotropy
+c pthe----input-R-SSO Angle
+c ppic----input-R-SSO Peacks elevation (m)
+c pval----input-R-SSO Valleys elevation (m)
+c
+c kgwd- -input-I: Total nb of points where the orography schemes are active
+c ktest--input-I: Flags to indicate active points
+c kdx----input-I: Locate the physical location of an active point.
+
+c pulow, pvlow -output-R: Low-level wind
+c pustr, pvstr -output-R: Surface stress due to SSO drag      (Pa)
+c
+c d_t-----output-R: T increment            
+c d_u-----output-R: U increment              
+c d_v-----output-R: V increment              
+c
+c Implicit Arguments:
+c ===================
+c
+c iim--common-I: Number of longitude intervals
+c jjm--common-I: Number of latitude intervals
+c klon-common-I: Number of points seen by the physics
+c                (iim+1)*(jjm+1) for instance
+c klev-common-I: Number of vertical layers
+c======================================================================
+c Local Variables:
+c ================
+c
+c zgeom-----R: Altitude of layer above ground
+c pt, pu, pv --R: t u v from top to bottom
+c pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom) 
+c papmf: pressure at model layer (from top to bottom)
+c papmh: pressure at model 1/2 layer (from top to bottom)
+c 
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+c
+c  ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+      REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+c
+      INTEGER i, k, kgwd,  kdx(nlon), ktest(nlon)
+c
+c LOCAL VARIABLES:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+      CHARACTER (LEN=20) :: modname='orografi_strato'
+      CHARACTER (LEN=80) :: abort_message
+c
+c INITIALIZE OUTPUT VARIABLES 
+c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c PREPARE INPUT VARIABLES FOR ORODRAG (i.e., ORDERED FROM TOP TO BOTTOM)
+C CALCULATE LAYERS HEIGHT ABOVE GROUND)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c CALL SSO DRAG ROUTINES        
+c
+      CALL orodrag_strato(klon,klev,kgwd,kdx,ktest,
+     .            dtime,
+     .            papmh, papmf, zgeom,
+     .            pt, pu, pv,
+     .            pmea, pstd, psig, pgam, pthe, ppic,pval,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+C COMPUTE INCREMENTS AND STRESS FROM TENDENCIES
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+     .                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+         pvstr(i)        = pvstr(i)
+     .                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
+
+      SUBROUTINE orodrag_strato( nlon,nlev 
+     i                 , kgwd,  kdx, ktest
+     r                 , ptsphy
+     r                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1
+     r                 , pmea, pstd, psig, pgam, pthe, ppic, pval
+c outputs
+     r                 , pulow,pvlow
+     r                 , pvom,pvol,pte )
+      
+      USE dimphy
+      IMPLICIT NONE
+c
+c
+c**** *orodrag* - does the SSO drag  parametrization.
+c
+c     purpose.
+c     --------
+c
+c     this routine computes the physical tendencies of the
+c     prognostic variables u,v  and t due to  vertical transports by
+c     subgridscale orographically excited gravity waves, and to
+c     low level blocked flow drag.
+c
+c**   interface.
+c     ----------
+c          called from *drag_noro*.
+c
+c          the routine takes its input from the long-term storage:
+c          u,v,t and p at t-1.
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c
+c kgwd- -input-I: Total nb of points where the orography schemes are active
+c ktest--input-I: Flags to indicate active points
+c kdx----input-I: Locate the physical location of an active point.
+c ptsphy--input-R-Time-step (s)
+c paphm1--input-R: pressure at model 1/2 layer
+c papm1---input-R: pressure at model layer
+c pgeom1--input-R: Altitude of layer above ground
+c ptm1, pum1, pvm1--R-: t, u and v
+c pmea----input-R-Mean Orography (m)
+C pstd----input-R-SSO standard deviation (m)
+c psig----input-R-SSO slope
+c pgam----input-R-SSO Anisotropy
+c pthe----input-R-SSO Angle
+c ppic----input-R-SSO Peacks elevation (m)
+c pval----input-R-SSO Valleys elevation (m)
+
+      integer nlon,nlev,kgwd
+      real ptsphy
+
+c     ==== outputs ===
+c pulow, pvlow -output-R: Low-level wind
+c
+c pte -----output-R: T tendency
+c pvom-----output-R: U tendency
+c pvol-----output-R: V tendency
+c
+c
+c Implicit Arguments:
+c ===================
+c
+c klon-common-I: Number of points seen by the physics
+c klev-common-I: Number of vertical layers
+c
+c     method.
+c     -------
+c
+c     externals.
+c     ----------
+      integer ismin, ismax
+      external ismin, ismax
+c
+c     reference.
+c     ----------
+c
+c     author.
+c     -------
+c     m.miller + b.ritter   e.c.m.w.f.     15/06/86.
+c
+c     f.lott + m. miller    e.c.m.w.f.     22/11/94
+c-----------------------------------------------------------------------
+c
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+c
+      real  pte(nlon,nlev),
+     *      pvol(nlon,nlev),
+     *      pvom(nlon,nlev),
+     *      pulow(nlon),
+     *      pvlow(nlon)
+      real  pum1(nlon,nlev),
+     *      pvm1(nlon,nlev),
+     *      ptm1(nlon,nlev),
+     *      pmea(nlon),pstd(nlon),psig(nlon),
+     *      pgam(nlon),pthe(nlon),ppic(nlon),pval(nlon),
+     *      pgeom1(nlon,nlev),
+     *      papm1(nlon,nlev),
+     *      paphm1(nlon,nlev+1)
+c
+      integer  kdx(nlon),ktest(nlon)
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+      integer  isect(klon),
+     *         icrit(klon),
+     *         ikcrith(klon),
+     *         ikenvh(klon),
+     *         iknu(klon),
+     *         iknu2(klon),
+     *         ikcrit(klon),
+     *         ikhlim(klon)
+c
+      real   ztau(klon,klev+1),
+     *       zstab(klon,klev+1),
+     *       zvph(klon,klev+1),
+     *       zrho(klon,klev+1),
+     *       zri(klon,klev+1),
+     *       zpsi(klon,klev+1),
+     *       zzdep(klon,klev)
+      real   zdudt(klon),
+     *       zdvdt(klon),
+     *       zdtdt(klon),
+     *       zdedt(klon),
+     *       zvidis(klon),
+     *       ztfr(klon),
+     *       znu(klon),
+     *       zd1(klon),
+     *       zd2(klon),
+     *       zdmod(klon)
+
+
+c local quantities:
+
+      integer jl,jk,ji
+      real ztmst,zdelp,ztemp,zforc,ztend,rover                
+      real zb,zc,zconb,zabsv,zzd1,ratio,zbet,zust,zvst,zdis
+   
+c
+c------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+c        print *,' in orodrag'
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+c     ztmst=twodt
+c     if(nstep.eq.nstart) ztmst=0.5*twodt
+      ztmst=ptsphy
+c     ------------------------------------------------------------------
+c
+ 120  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.3   check whether row contains point for printing
+c                ---------------------------------------------
+c
+ 130  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.     precompute basic state variables.
+c*                ---------- ----- ----- ----------
+c*                define low level wind, project winds in plane of
+c*                low level wind, determine sector in which to take
+c*                the variance and set indicator for critical levels.
+c
+
+  200 continue
+c
+c
+c
+      call orosetup_strato
+     *     ( nlon, nlev , ktest 
+     *     , ikcrit, ikcrith, icrit, isect, ikhlim, ikenvh,iknu,iknu2
+     *     , paphm1, papm1 , pum1   , pvm1 , ptm1 , pgeom1, pstd
+     *     , zrho  , zri   , zstab  , ztau , zvph , zpsi, zzdep
+     *     , pulow, pvlow 
+     *     , pthe,pgam,pmea,ppic,pval,znu  ,zd1,  zd2,  zdmod )
+
+
+c
+c
+c
+c***********************************************************
+c
+c
+c*         3.      compute low level stresses using subcritical and
+c*                 supercritical forms.computes anisotropy coefficient
+c*                 as measure of orographic twodimensionality.
+c
+  300 continue
+c
+      call gwstress_strato
+     *    ( nlon  , nlev
+     *    , ikcrit, isect, ikhlim, ktest, ikcrith, icrit, ikenvh, iknu
+     *    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic, pval
+     *    , ztfr   , ztau 
+     *    , pgeom1,pgam,zd1,zd2,zdmod,znu)
+
+c
+c
+c*         4.      compute stress profile including
+c                  trapped waves, wave breaking,
+c                  linear decay in stratosphere.
+c
+  400 continue
+c
+c
+
+      call gwprofil_strato
+     *       (  nlon , nlev
+     *       , kgwd   , kdx  , ktest
+     *       , ikcrit, ikcrith, icrit  , ikenvh, iknu
+     *       ,iknu2 , paphm1, zrho   , zstab , ztfr   , zvph
+     *       , zri   , ztau 
+ 
+     *       , zdmod , znu    , psig  , pgam , pstd , ppic , pval)
+
+c
+c*         5.      Compute tendencies from waves stress profile.
+c                  Compute low level blocked flow drag. 
+c*                 --------------------------------------------
+c
+  500 continue
+
+      
+c
+c  explicit solution at all levels for the gravity wave
+c  implicit solution for the blocked levels
+
+      do 510 jl=kidia,kfdia
+      zvidis(jl)=0.0
+      zdudt(jl)=0.0
+      zdvdt(jl)=0.0
+      zdtdt(jl)=0.0
+  510 continue
+c
+
+      do 524 jk=1,klev
+c
+
+C  WAVE STRESS 
+C-------------
+c
+c
+      do 523 ji=kidia,kfdia
+
+      if(ktest(ji).eq.1) then
+
+      zdelp=paphm1(ji,jk+1)-paphm1(ji,jk)
+      ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,klev+1)*zdelp)
+
+      zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
+      zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
+c
+c Control Overshoots
+c
+
+      if(jk.ge.nstra)then
+        rover=0.10
+        if(abs(zdudt(ji)).gt.rover*abs(pum1(ji,jk))/ztmst)
+     C    zdudt(ji)=rover*abs(pum1(ji,jk))/ztmst*
+     C              zdudt(ji)/(abs(zdudt(ji))+1.E-10)
+        if(abs(zdvdt(ji)).gt.rover*abs(pvm1(ji,jk))/ztmst)
+     C    zdvdt(ji)=rover*abs(pvm1(ji,jk))/ztmst*
+     C              zdvdt(ji)/(abs(zdvdt(ji))+1.E-10)
+      endif 
+
+      rover=0.25
+      zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2)        
+      ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst                      
+
+      if(zforc.ge.rover*ztend)then
+        zdudt(ji)=rover*ztend/zforc*zdudt(ji)
+        zdvdt(ji)=rover*ztend/zforc*zdvdt(ji)
+      endif
+c
+c BLOCKED FLOW DRAG:
+C -----------------
+c
+      if(jk.gt.ikenvh(ji)) then
+         zb=1.0-0.18*pgam(ji)-0.04*pgam(ji)**2
+         zc=0.48*pgam(ji)+0.3*pgam(ji)**2
+         zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji))
+         zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
+         zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2
+         ratio=(cos(zpsi(ji,jk))**2+pgam(ji)*sin(zpsi(ji,jk))**2)/
+     *   (pgam(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
+         zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv
+c
+c OPPOSED TO THE WIND
+c
+         zdudt(ji)=-pum1(ji,jk)/ztmst
+         zdvdt(ji)=-pvm1(ji,jk)/ztmst
+c
+c PERPENDICULAR TO THE SSO MAIN AXIS:
+C                            
+cmod     zdudt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.))
+cmod *              *cos(pthe(ji)*rpi/180.)/ztmst
+cmod     zdvdt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.)
+cmod *              +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.))
+cmod *              *sin(pthe(ji)*rpi/180.)/ztmst
+C
+         zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet))
+         zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet))
+      end if
+      pvom(ji,jk)=zdudt(ji)
+      pvol(ji,jk)=zdvdt(ji)
+      zust=pum1(ji,jk)+ztmst*zdudt(ji)
+      zvst=pvm1(ji,jk)+ztmst*zdvdt(ji)
+      zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
+      zdedt(ji)=zdis/ztmst
+      zvidis(ji)=zvidis(ji)+zdis*zdelp
+      zdtdt(ji)=zdedt(ji)/rcpd
+c
+c  NO TENDENCIES ON TEMPERATURE .....
+c
+c  Instead of, pte(ji,jk)=zdtdt(ji), due to mechanical dissipation
+c
+      pte(ji,jk)=0.0
+
+      endif
+
+  523 continue
+  524 continue
+c
+c
+  501 continue
+
+      return
+      end
+      SUBROUTINE orosetup_strato
+     *         ( nlon   , nlev  , ktest
+     *         , kkcrit, kkcrith, kcrit, ksect , kkhlim
+     *         , kkenvh, kknu  , kknu2
+     *         , paphm1, papm1 , pum1   , pvm1 , ptm1  , pgeom1, pstd
+     *         , prho  , pri   , pstab  , ptau , pvph  ,ppsi, pzdep
+     *         , pulow , pvlow  
+     *         , ptheta, pgam, pmea, ppic, pval
+     *         , pnu  ,  pd1  ,  pd2  ,pdmod  )
+C
+c**** *gwsetup*
+c
+c     purpose.
+c     --------
+c     SET-UP THE ESSENTIAL PARAMETERS OF THE SSO DRAG SCHEME:
+C     DEPTH OF LOW WBLOCKED LAYER, LOW-LEVEL FLOW, BACKGROUND
+C     STRATIFICATION.....
+c
+c**   interface.
+c     ----------
+c          from *orodrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c 
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c ktest--input-I: Flags to indicate active points
+c
+c ptsphy--input-R-Time-step (s)
+c paphm1--input-R: pressure at model 1/2 layer
+c papm1---input-R: pressure at model layer
+c pgeom1--input-R: Altitude of layer above ground
+c ptm1, pum1, pvm1--R-: t, u and v
+c pmea----input-R-Mean Orography (m)
+C pstd----input-R-SSO standard deviation (m)
+c psig----input-R-SSO slope
+c pgam----input-R-SSO Anisotropy
+c pthe----input-R-SSO Angle
+c ppic----input-R-SSO Peacks elevation (m)
+c pval----input-R-SSO Valleys elevation (m)
+
+c     ==== outputs ===
+c pulow, pvlow -output-R: Low-level wind
+c kkcrit----I-: Security value for top of low level flow
+c kcrit-----I-: Critical level 
+c ksect-----I-: Not used
+c kkhlim----I-: Not used
+c kkenvh----I-: Top of blocked flow layer
+c kknu------I-: Layer that sees mountain peacks
+c kknu2-----I-: Layer that sees mountain peacks above mountain mean
+c kknub-----I-: Layer that sees mountain mean above valleys
+c prho------R-: Density at 1/2 layers
+c pri-------R-: Background Richardson Number, Wind shear measured along GW stress
+c pstab-----R-: Brunt-Vaisala freq. at 1/2 layers
+c pvph------R-: Wind in  plan of GW stress, Half levels.
+c ppsi------R-: Angle between low level wind and SS0 main axis.
+c pd1-------R-| Compared the ratio of the stress
+c pd2-------R-| that is along the wind to that Normal to it.
+c               pdi define the plane of low level stress
+c               compared to the low level wind.
+c see p. 108 Lott & Miller (1997).                      
+c pdmod-----R-: Norme of pdi
+
+c     === local arrays ===
+c
+c zvpf------R-: Wind projected in the plan of the low-level stress.
+
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c        see ecmwf research department documentation of the "i.f.s."
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f.lott  for the new-gwdrag scheme november 1993
+c
+c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+c
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer nlon,nlev
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon),
+     *        kkhlim(nlon),ktest(nlon),kkenvh(nlon)
+
+c
+      real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev),
+     *     pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev),
+     *     prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1),
+     *     ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1),
+     *     pzdep(nlon,klev)
+       real pulow(nlon),pvlow(nlon),ptheta(nlon),pgam(nlon),pnu(nlon),
+     *     pd1(nlon),pd2(nlon),pdmod(nlon)
+      real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+c
+c
+      integer ilevh ,jl,jk
+      real zcons1,zcons2,zhgeo,zu,zphi
+      real zvt1,zvt2,zdwind,zwind,zdelp
+      real zstabm,zstabp,zrhom,zrhop
+      logical lo 
+      logical ll1(klon,klev+1)
+      integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon),
+     *        kentp(klon),ncount(klon)  
+c
+      real zhcrit(klon,klev),zvpf(klon,klev),
+     *     zdp(klon,klev)
+      real znorm(klon),zb(klon),zc(klon),
+     *      zulow(klon),zvlow(klon),znup(klon),znum(klon)
+c       
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+c       PRINT *,' in orosetup'
+ 100  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         1.1   computational constants
+c                -----------------------
+c
+ 110  continue
+c
+      ilevh =klev/3
+c
+      zcons1=1./rd
+      zcons2=rg**2/rcpd
+c
+c
+c     ------------------------------------------------------------------
+c
+c*         2.
+c                --------------
+c
+ 200  continue
+c
+c     ------------------------------------------------------------------
+c
+c*         2.1     define low level wind, project winds in plane of
+c*                 low level wind, determine sector in which to take
+c*                 the variance and set indicator for critical levels.
+c
+c
+c
+      do 2001 jl=kidia,kfdia
+      kknu(jl)    =klev
+      kknu2(jl)   =klev
+      kknub(jl)   =klev
+      kknul(jl)   =klev
+      pgam(jl) =max(pgam(jl),gtsec)
+      ll1(jl,klev+1)=.false.
+ 2001 continue
+c
+c Ajouter une initialisation (L. Li, le 23fev99):
+c
+      do jk=klev,ilevh,-1
+      do jl=kidia,kfdia
+      ll1(jl,jk)= .false.
+      ENDDO
+      ENDDO
+c
+c*      define top of low level flow
+c       ----------------------------
+      do 2002 jk=klev,ilevh,-1
+      do 2003 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr
+      if(lo) then
+        kkcrit(jl)=jk
+      endif
+      zhcrit(jl,jk)=ppic(jl)-pval(jl)           
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu(jl)=ilevh
+      endif
+ 2003 continue
+ 2002 continue
+      do 2004 jk=klev,ilevh,-1
+      do 2005 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zhcrit(jl,jk)=ppic(jl)-pmea(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu2(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh
+      endif
+ 2005 continue
+ 2004 continue
+      do 2006 jk=klev,ilevh,-1
+      do 2007 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zhcrit(jl,jk)=amin1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl))
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknub(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknub(jl)=ilevh
+      endif
+ 2007 continue
+ 2006 continue
+c
+      do 2010 jl=kidia,kfdia  
+      if(ktest(jl).eq.1) then
+      kknu(jl)=min(kknu(jl),nktopg)
+      kknu2(jl)=min(kknu2(jl),nktopg)
+      kknub(jl)=min(kknub(jl),nktopg)
+      kknul(jl)=klev
+      endif
+ 2010 continue      
+c
+ 210  continue
+c
+cc*     initialize various arrays
+c
+      do 2107 jl=kidia,kfdia
+      prho(jl,klev+1)  =0.0
+cym correction en attendant mieux
+      prho(jl,1)  =0.0      
+      pstab(jl,klev+1) =0.0
+      pstab(jl,1)      =0.0
+      pri(jl,klev+1)   =9999.0
+      ppsi(jl,klev+1)  =0.0
+      pri(jl,1)        =0.0
+      pvph(jl,1)       =0.0
+      pvph(jl,klev+1)  =0.0
+cym correction en attendant mieux
+cym      pvph(jl,klev)    =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      zulow(jl)        =0.0
+      zvlow(jl)        =0.0
+      kkcrith(jl)      =klev
+      kkenvh(jl)       =klev
+      kentp(jl)        =klev
+      kcrit(jl)        =1
+      ncount(jl)       =0
+      ll1(jl,klev+1)   =.false.
+ 2107 continue
+c
+c*     define flow density and stratification (rho and N2)
+c      at semi layers.
+c      -------------------------------------------------------
+c
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))*
+     *  (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+        pstab(jl,jk)=max(pstab(jl,jk),gssec)
+      endif
+  222 continue
+  223 continue
+c
+c********************************************************************
+c
+c*     define Low level flow (between ground and peacks-valleys)
+c      ---------------------------------------------------------
+      do 2115 jk=klev,ilevh,-1
+      do 2116 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+      if(jk.ge.kknu2(jl).and.jk.le.kknul(jl)) then
+        pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pstab(jl,klev+1)=pstab(jl,klev+1)
+     c                   +pstab(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        prho(jl,klev+1)=prho(jl,klev+1)
+     c                   +prho(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      end if
+      endif
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+      pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+      pvph(jl,klev+1)=znorm(jl)
+      pstab(jl,klev+1)=pstab(jl,klev+1)
+     c                /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      prho(jl,klev+1)=prho(jl,klev+1)
+     c                /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      endif
+ 2110 continue
+
+c
+c*******  setup orography orientation relative to the low level
+C       wind and define parameters of the Anisotropic wave stress.
+c
+      do 2112 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec)
+        if(lo) then
+          zu=pulow(jl)+2.*gvsec
+        else
+          zu=pulow(jl)
+        endif
+        zphi=atan(pvlow(jl)/zu)
+        ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi
+        zb(jl)=1.-0.18*pgam(jl)-0.04*pgam(jl)**2
+        zc(jl)=0.48*pgam(jl)+0.3*pgam(jl)**2
+        pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
+        pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))
+     *                         *cos(ppsi(jl,klev+1))
+        pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2)
+      endif
+ 2112 continue
+c
+c  ************ projet flow in plane of lowlevel stress *************
+C  ************ Find critical levels...                 *************
+c
+      do 213 jk=1,klev
+      do 212 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        zvt1       =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk)
+        zvt2       =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk)
+        zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
+      endif
+      ptau(jl,jk)  =0.0
+      pzdep(jl,jk) =0.0
+      ppsi(jl,jk)  =0.0
+      ll1(jl,jk)   =.false.
+  212 continue
+  213 continue
+      do 215 jk=2,klev
+      do 214 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+
+     *            (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1))
+     *            /zdp(jl,jk)
+        if(pvph(jl,jk).lt.gvsec) then
+          pvph(jl,jk)=gvsec
+          kcrit(jl)=jk
+        endif
+      endif
+  214 continue
+  215 continue
+c
+c*         2.3     mean flow richardson number.
+c
+  230 continue
+c
+      do 232 jk=2,klev
+      do 231 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec)
+        pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk)
+     *          /(rg*prho(jl,jk)*zdwind))**2
+        pri(jl,jk)=max(pri(jl,jk),grcrit)
+      endif
+  231 continue
+  232 continue
+  
+c
+c
+c*      define top of 'envelope' layer
+c       ----------------------------
+
+      do 233 jl=kidia,kfdia
+      pnu (jl)=0.0
+      znum(jl)=0.0
+ 233  continue
+      
+      do 234 jk=2,klev-1
+      do 234 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+       
+      if (jk.ge.kknu2(jl)) then
+          
+            znum(jl)=pnu(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            pnu(jl) = pnu(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit)
+     *                          .and.(kkenvh(jl).eq.klev))
+     *      kkenvh(jl)=jk
+     
+      endif    
+
+      endif
+      
+ 234  continue
+      
+c  calculation of a dynamical mixing height for when the waves
+C  BREAK AT LOW LEVEL: The drag will be repartited over
+C  a depths that depends on waves vertical wavelength,
+C  not just between two adjacent model layers.
+c  of gravity waves:
+
+      do 235 jl=kidia,kfdia
+      znup(jl)=0.0
+      znum(jl)=0.0
+ 235  continue
+
+      do 236 jk=klev-1,2,-1
+      do 236 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+
+            znum(jl)=znup(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/
+     *            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            znup(jl) = znup(jl) + (zdelp/rg)*
+     *            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.rpi/4.).and.(znup(jl).gt.rpi/4.)
+     *                          .and.(kkcrith(jl).eq.klev))
+     *      kkcrith(jl)=jk
+     
+      endif
+      
+ 236  continue
+ 
+      do 237 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      kkcrith(jl)=max0(kkcrith(jl),ilevh*2)
+      kkcrith(jl)=max0(kkcrith(jl),kknu(jl))
+      if(kcrit(jl).ge.kkcrith(jl))kcrit(jl)=1
+      endif
+ 237  continue         
+c
+c     directional info for flow blocking ************************* 
+c
+      do 251 jk=1,klev    
+      do 252 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec)
+      if(lo) then
+        zu=pum1(jl,jk)+2.*gvsec
+      else
+        zu=pum1(jl,jk)
+      endif
+       zphi=atan(pvm1(jl,jk)/zu)
+       ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi
+      endif
+ 252  continue
+ 251  continue
+
+c      forms the vertical 'leakiness' **************************
+
+      do 254  jk=ilevh,klev
+      do 253  jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      pzdep(jl,jk)=0
+      if(jk.ge.kkenvh(jl).and.kkenvh(jl).ne.klev) then
+        pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl)  )-pgeom1(jl,  jk))/
+     *               (pgeom1(jl,kkenvh(jl)  )-pgeom1(jl,klev))
+      end if
+      endif
+ 253  continue
+ 254  continue
+
+      return
+      end
+      SUBROUTINE gwstress_strato
+     *         (  nlon  , nlev
+     *         , kkcrit, ksect, kkhlim, ktest, kkcrith, kcrit, kkenvh
+     *         , kknu
+     *         , prho  , pstab , pvph  , pstd, psig
+     *         , pmea , ppic , pval  , ptfr  , ptau  
+     *         , pgeom1 , pgamma , pd1  , pd2   , pdmod , pnu )
+c
+c**** *gwstress*
+c
+c     purpose.
+c     --------
+c  Compute the surface stress due to Gravity Waves, according
+c  to the Phillips (1979) theory of 3-D flow above 
+c  anisotropic elliptic ridges.
+
+C  The stress is reduced two account for cut-off flow over
+C  hill.  The flow only see that part of the ridge located
+c  above the blocked layer (see zeff).
+c
+c**   interface.
+c     ----------
+c     call *gwstress*  from *gwdrag*
+c
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c     ==== outputs ===
+c
+c        implicit arguments :   none
+c        --------------------
+c
+c     method.
+c     -------
+c
+c
+c     externals.
+c     ----------
+c
+c
+c     reference.
+c     ----------
+c
+c   LOTT and MILLER (1997)  &  LOTT (1999)
+c
+c     author.
+c     -------
+c
+c     modifications.
+c     --------------
+c     f. lott put the new gwd on ifs      22/11/93
+c
+c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+c-----------------------------------------------------------------------
+c
+c*       0.1   arguments
+c              ---------
+c
+      integer nlon,nlev
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon),
+     *        kkhlim(nlon),ktest(nlon),kkenvh(nlon),kknu(nlon)
+c
+      real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1),
+     *     pvph(nlon,nlev+1),ptfr(nlon),
+     *     pgeom1(nlon,nlev),pstd(nlon)
+c
+      real pd1(nlon),pd2(nlon),pnu(nlon),psig(nlon),pgamma(nlon)
+      real pmea(nlon),ppic(nlon),pval(nlon)
+      real pdmod(nlon)
+c
+c-----------------------------------------------------------------------
+c
+c*       0.2   local arrays
+c              ------------
+c  zeff--real: effective height seen by the flow when there is blocking
+
+      integer jl
+      real zeff  
+c
+c-----------------------------------------------------------------------
+c
+c*       0.3   functions
+c              ---------
+c     ------------------------------------------------------------------
+c
+c*         1.    initialization
+c                --------------
+c
+c      PRINT *,' in gwstress'
+ 100  continue
+c
+c*         3.1     gravity wave stress.
+c
+  300 continue
+c
+c
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      
+c  effective mountain height above the blocked flow
+  
+         zeff=ppic(jl)-pval(jl)
+         if(kkenvh(jl).lt.klev)then
+         zeff=amin1(GFRCRIT*pvph(jl,klev+1)/sqrt(pstab(jl,klev+1))
+     c              ,zeff)
+         endif
+
+      
+        ptau(jl,klev+1)=gkdrag*prho(jl,klev+1)
+     *     *psig(jl)*pdmod(jl)/4./pstd(jl)
+     *     *pvph(jl,klev+1)*sqrt(pstab(jl,klev+1))
+     *     *zeff**2
+
+
+c  too small value of stress or  low level flow include critical level
+c  or low level flow:  gravity wave stress nul.
+                
+c       lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl))
+c    *      .or.(pvph(jl,klev+1).lt.gvcrit)
+c       if(lo) ptau(jl,klev+1)=0.0
+      
+c      print *,jl,ptau(jl,klev+1)
+
+      else
+      
+          ptau(jl,klev+1)=0.0
+          
+      endif
+
+  301 continue
+
+c      write(21)(ptau(jl,klev+1),jl=kidia,kfdia)
+ 
+      return
+      end
+
+      subroutine gwprofil_strato
+     *         ( nlon, nlev
+     *         , kgwd ,kdx  , ktest
+     *         , kkcrit, kkcrith, kcrit ,  kkenvh, kknu,kknu2
+     *         , paphm1, prho   , pstab , ptfr , pvph , pri , ptau
+     *         , pdmod   , pnu   , psig ,pgamma, pstd, ppic,pval)
+
+C**** *gwprofil*
+C
+C     purpose.
+C     --------
+C
+C**   interface.
+C     ----------
+C          from *gwdrag*
+C
+C        explicit arguments :
+C        --------------------
+C     ==== inputs ===
+C
+C     ==== outputs ===
+C
+C        implicit arguments :   none
+C        --------------------
+C
+C     method:
+C     -------
+C     the stress profile for gravity waves is computed as follows:
+C     it decreases linearly with heights from the ground 
+C     to the low-level indicated by kkcrith,
+C     to simulates lee waves or 
+C     low-level gravity wave breaking.
+C     above it is constant, except when the waves encounter a critical
+C     level (kcrit) or when they break.
+C     The stress is also uniformly distributed above the level
+C     nstra.                                          
+C
+      USE dimphy
+      IMPLICIT NONE
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      integer nlon,nlev,kgwd
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon)
+     *       ,kdx(nlon),ktest(nlon)
+     *       ,kkenvh(nlon),kknu(nlon),kknu2(nlon)
+C
+      real paphm1(nlon,nlev+1), pstab(nlon,nlev+1),
+     *     prho  (nlon,nlev+1), pvph (nlon,nlev+1),
+     *     pri   (nlon,nlev+1), ptfr (nlon), ptau(nlon,nlev+1)
+     
+      real pdmod (nlon) , pnu (nlon) , psig(nlon),
+     *     pgamma(nlon) , pstd(nlon) , ppic(nlon), pval(nlon)
+     
+C-----------------------------------------------------------------------
+C
+C*       0.2   local arrays
+C              ------------
+C
+      integer jl,jk
+      real zsqr,zalfa,zriw,zdel,zb,zalpha,zdz2n,zdelp,zdelpt
+
+      real zdz2 (klon,klev) , znorm(klon) , zoro(klon)
+      real ztau (klon,klev+1)
+C
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+C      print *,' entree gwprofil' 
+ 100  CONTINUE
+C
+C
+C*    COMPUTATIONAL CONSTANTS.
+C     ------------- ----------
+C
+      do 400 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+      zoro(jl)=psig(jl)*pdmod(jl)/4./pstd(jl)
+      ztau(jl,klev+1)=ptau(jl,klev+1)
+c     print *,jl,ptau(jl,klev+1)
+      ztau(jl,kkcrith(jl))=grahilo*ptau(jl,klev+1)
+      endif
+  400 continue
+  
+C
+      do 430 jk=klev+1,1,-1
+C
+C
+C*         4.1    constant shear stress until top of the
+C                 low-level breaking/trapped layer
+  410 CONTINUE
+C
+      do 411 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+           if(jk.gt.kkcrith(jl)) then
+           zdelp=paphm1(jl,jk)-paphm1(jl,klev+1) 
+           zdelpt=paphm1(jl,kkcrith(jl))-paphm1(jl,klev+1) 
+           ptau(jl,jk)=ztau(jl,klev+1)+zdelp/zdelpt*
+     c                 (ztau(jl,kkcrith(jl))-ztau(jl,klev+1))
+           else                    
+           ptau(jl,jk)=ztau(jl,kkcrith(jl))
+           endif
+       endif
+ 411  continue             
+C
+C*         4.15   constant shear stress until the top of the
+C                 low level flow layer.
+ 415  continue
+C        
+C
+C*         4.2    wave displacement at next level.
+C
+  420 continue
+C
+  430 continue
+
+C
+C*         4.4    wave richardson number, new wave displacement
+C*                and stress:  breaking evaluation and critical 
+C                 level
+C
+                          
+      do 440 jk=klev,1,-1
+
+      do 441 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+      znorm(jl)=prho(jl,jk)*sqrt(pstab(jl,jk))*pvph(jl,jk)
+      zdz2(jl,jk)=ptau(jl,jk)/amax1(znorm(jl),gssec)/zoro(jl)
+      endif
+  441 continue
+
+      do 442 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+          if(jk.lt.kkcrith(jl)) then
+          if((ptau(jl,jk+1).lt.gtsec).or.(jk.le.kcrit(jl))) then
+             ptau(jl,jk)=0.0
+          else
+               zsqr=sqrt(pri(jl,jk))
+               zalfa=sqrt(pstab(jl,jk)*zdz2(jl,jk))/pvph(jl,jk)
+               zriw=pri(jl,jk)*(1.-zalfa)/(1+zalfa*zsqr)**2
+               if(zriw.lt.grcrit) then
+C                 print *,' breaking!!!',ptau(jl,jk)
+                  zdel=4./zsqr/grcrit+1./grcrit**2+4./grcrit
+                  zb=1./grcrit+2./zsqr
+                  zalpha=0.5*(-zb+sqrt(zdel))
+                  zdz2n=(pvph(jl,jk)*zalpha)**2/pstab(jl,jk)
+                  ptau(jl,jk)=znorm(jl)*zdz2n*zoro(jl)
+               endif
+                
+               ptau(jl,jk)=amin1(ptau(jl,jk),ptau(jl,jk+1))
+                  
+          endif
+          endif
+      endif
+  442 continue
+  440 continue
+
+C  REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
+
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+         ztau(jl,kkcrith(jl)-1)=ptau(jl,kkcrith(jl)-1)
+         ztau(jl,nstra)=ptau(jl,nstra)
+      endif
+ 530  continue      
+
+      do 531 jk=1,klev
+      
+      do 532 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+                
+         if(jk.gt.kkcrith(jl)-1)then
+
+          zdelp=paphm1(jl,jk)-paphm1(jl,klev+1    )
+          zdelpt=paphm1(jl,kkcrith(jl)-1)-paphm1(jl,klev+1    )
+          ptau(jl,jk)=ztau(jl,klev+1    ) +
+     .                (ztau(jl,kkcrith(jl)-1)-ztau(jl,klev+1    ) )*
+     .                zdelp/zdelpt
+     
+        endif
+      endif
+            
+ 532  continue    
+ 
+C  REORGANISATION AT THE MODEL TOP....
+
+      do 533 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+
+         if(jk.lt.nstra)then
+
+          zdelp =paphm1(jl,nstra)
+          zdelpt=paphm1(jl,jk)
+          ptau(jl,jk)=ztau(jl,nstra)*zdelpt/zdelp 
+c         ptau(jl,jk)=ztau(jl,nstra)                
+
+        endif
+
+      endif
+
+ 533  continue
+
+ 
+ 531  continue        
+
+
+ 123   format(i4,1x,20(f6.3,1x))
+
+
+      return
+      end
+      subroutine lift_noro_strato (nlon,nlev,dtime,paprs,pplay,      
+     i                   plat,pmea,pstd, psig, pgam, pthe, ppic,pval,
+     i                   kgwd,kdx,ktest,
+     i                   t, u, v,
+     o                   pulow, pvlow, pustr, pvstr,
+     o                   d_t, d_u, d_v)
+c
+      USE dimphy
+      implicit none
+c======================================================================
+c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+c Object: Mountain lift interface (enhanced vortex stretching).
+c         Made necessary because:
+C 1. in the LMD-GCM Layers are from bottom to top,
+C    contrary to most European GCM.
+c 2. the altitude above ground of each model layers
+c    needs to be known (variable zgeom)
+c======================================================================
+c Explicit Arguments:
+c ==================
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c dtime---input-R-Time-step (s)
+c paprs---input-R-Pressure in semi layers    (Pa)
+c pplay---input-R-Pressure model-layers      (Pa)
+c t-------input-R-temperature (K)
+c u-------input-R-Horizontal wind (m/s)
+c v-------input-R-Meridional wind (m/s)
+c pmea----input-R-Mean Orography (m)
+C pstd----input-R-SSO standard deviation (m)
+c psig----input-R-SSO slope
+c pgam----input-R-SSO Anisotropy
+c pthe----input-R-SSO Angle
+c ppic----input-R-SSO Peacks elevation (m)
+c pval----input-R-SSO Valleys elevation (m)
+c
+c kgwd- -input-I: Total nb of points where the orography schemes are active
+c ktest--input-I: Flags to indicate active points
+c kdx----input-I: Locate the physical location of an active point.
+
+c pulow, pvlow -output-R: Low-level wind
+c pustr, pvstr -output-R: Surface stress due to SSO drag      (Pa)
+c
+c d_t-----output-R: T increment
+c d_u-----output-R: U increment
+c d_v-----output-R: V increment
+c
+c Implicit Arguments:
+c ===================
+c
+c iim--common-I: Number of longitude intervals
+c jjm--common-I: Number of latitude intervals
+c klon-common-I: Number of points seen by the physics
+c                (iim+1)*(jjm+1) for instance
+c klev-common-I: Number of vertical layers
+c======================================================================
+c Local Variables:
+c ================
+c
+c zgeom-----R: Altitude of layer above ground
+c pt, pu, pv --R: t u v from top to bottom
+c pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom)
+c papmf: pressure at model layer (from top to bottom)
+c papmh: pressure at model 1/2 layer (from top to bottom)
+c
+c======================================================================
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+c
+c ARGUMENTS
+c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL plat(nlon),pmea(nlon)
+      REAL pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+c
+      INTEGER i, k, kgwd,  kdx(nlon), ktest(nlon)
+c
+c Variables locales:
+c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+c
+c initialiser les variables de sortie (pour securite)
+c
+
+c     print *,'in lift_noro'
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+c
+c preparer les variables d'entree (attention: l'ordre des niveaux 
+c verticaux augmente du haut vers le bas)
+c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)
+     .                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0
+     .               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+c
+c appeler la routine principale
+c
+
+      CALL OROLIFT_strato(klon,klev,kgwd,kdx,ktest,
+     .            dtime,
+     .            papmh, papmf, zgeom,
+     .            pt, pu, pv,
+     .            plat,pmea, pstd, psig, pgam, pthe, ppic,pval,
+     .            pulow,pvlow,
+     .            pdudt,pdvdt,pdtdt)
+C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)
+     .                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+         pvstr(i)        = pvstr(i)
+     .                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+      ENDDO
+      ENDDO
+
+c     print *,' out lift_noro'
+c
+      RETURN
+      END
+      subroutine orolift_strato( nlon,nlev
+     I                 , kgwd, kdx, ktest
+     R                 , ptsphy
+     R                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1
+     R                 , plat
+     R                 , pmea, pstd, psig, pgam, pthe,ppic,pval
+C OUTPUTS
+     R                 , pulow,pvlow
+     R                 , pvom,pvol,pte )
+
+C
+C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
+C
+C     PURPOSE.
+C     --------
+C this routine computes the physical tendencies of the
+C prognostic variables u,v  when enhanced vortex stretching
+C is needed.
+C
+C**   INTERFACE.
+C     ----------
+C          CALLED FROM *lift_noro
+c        explicit arguments :
+c        --------------------
+c     ==== inputs ===
+c nlon----input-I-Total number of horizontal points that get into physics
+c nlev----input-I-Number of vertical levels
+c
+c kgwd- -input-I: Total nb of points where the orography schemes are active
+c ktest--input-I: Flags to indicate active points
+c kdx----input-I: Locate the physical location of an active point.
+c ptsphy--input-R-Time-step (s)
+c paphm1--input-R: pressure at model 1/2 layer
+c papm1---input-R: pressure at model layer
+c pgeom1--input-R: Altitude of layer above ground
+c ptm1, pum1, pvm1--R-: t, u and v
+c pmea----input-R-Mean Orography (m)
+C pstd----input-R-SSO standard deviation (m)
+c psig----input-R-SSO slope
+c pgam----input-R-SSO Anisotropy
+c pthe----input-R-SSO Angle
+c ppic----input-R-SSO Peacks elevation (m)
+c pval----input-R-SSO Valleys elevation (m)
+c plat----input-R-Latitude (degree)
+c
+c     ==== outputs ===
+c pulow, pvlow -output-R: Low-level wind
+c
+c pte -----output-R: T tendency
+c pvom-----output-R: U tendency
+c pvol-----output-R: V tendency
+c
+c
+c Implicit Arguments:
+c ===================
+c
+c klon-common-I: Number of points seen by the physics
+c klev-common-I: Number of vertical layers
+c
+
+C     ----------
+C
+C     AUTHOR.
+C     -------
+C     F.LOTT  LMD 22/11/95
+C
+       USE dimphy
+       implicit none
+C
+C
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+C
+      integer nlon,nlev,kgwd
+      real ptsphy
+      real  pte(nlon,nlev),
+     *      pvol(nlon,nlev),
+     *      pvom(nlon,nlev),
+     *      pulow(nlon),
+     *      pvlow(nlon)
+      real  pum1(nlon,nlev),
+     *      pvm1(nlon,nlev),
+     *      ptm1(nlon,nlev),
+     *      plat(nlon),pmea(nlon),
+     *      pstd(nlon),psig(nlon),pgam(nlon),
+     *      pthe(nlon),ppic(nlon),pval(nlon),
+     *      pgeom1(nlon,nlev),
+     *      papm1(nlon,nlev),
+     *      paphm1(nlon,nlev+1)
+C
+      INTEGER  KDX(NLON),KTEST(NLON)
+C-----------------------------------------------------------------------
+C
+C*       0.2   local arrays
+
+      integer jl,ilevh,jk
+      real zhgeo,zdelp,zslow,zsqua,zscav,zbet
+C              ------------
+      integer  iknub(klon),
+     *         iknul(klon)
+      logical ll1(klon,klev+1)
+C
+      real   ztau(klon,klev+1),
+     *       ztav(klon,klev+1),
+     *       zrho(klon,klev+1)
+      real   zdudt(klon),
+     *       zdvdt(klon)
+      real zhcrit(klon,klev)
+
+      logical lifthigh
+      real zcons1,ztmst
+      CHARACTER (LEN=20) :: modname='orolift_strato'
+      CHARACTER (LEN=80) :: abort_message
+
+
+C-----------------------------------------------------------------------
+C
+C*         1.1  initialisations
+C               ---------------
+
+      lifthigh=.false.
+
+      if(nlon.ne.klon.or.nlev.ne.klev) then
+        abort_message = 'pb dimension'
+        CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+      zcons1=1./rd
+      ztmst=ptsphy
+C
+      do 1001 jl=kidia,kfdia
+      zrho(jl,klev+1)  =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      iknub(JL)   =klev
+      iknul(JL)   =klev
+      ilevh=klev/3
+      ll1(jl,klev+1)=.false.
+      do 1000 jk=1,klev
+      pvom(jl,jk)=0.0
+      pvol(jl,jk)=0.0
+      pte (jl,jk)=0.0
+ 1000 continue
+ 1001 continue
+
+C
+C*         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
+C*                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
+C*                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
+C
+C
+C
+      do 2006 jk=klev,1,-1
+      do 2007 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zhcrit(jl,jk)=amax1(ppic(jl)-pval(jl),100.)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        iknub(jl)=jk
+      endif
+      endif
+ 2007 continue
+ 2006 continue
+C
+
+      do 2010 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      iknub(jl)=max(iknub(jl),klev/2)
+      iknul(jl)=max(iknul(jl),2*klev/3)
+      if(iknub(jl).gt.nktopg) iknub(jl)=nktopg
+      if(iknub(jl).eq.nktopg) iknul(jl)=klev
+      if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1
+      endif
+ 2010 continue
+
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+        zrho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+  222 continue
+  223 continue
+c     print *,'  dans orolift: 223'
+
+C********************************************************************
+C
+c*     define low level flow
+C      -------------------
+      do 2115 jk=klev,1,-1
+      do 2116 jl=kidia,kfdia
+      if(ktest(jl).eq.1) THEN
+      if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then
+        pulow(JL)=pulow(JL)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(JL)=pvlow(JL)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        zrho(JL,klev+1)=zrho(JL,klev+1)
+     *                 +zrho(JL,JK)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      endif
+      endif
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      pulow(JL)=pulow(JL)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      pvlow(JL)=pvlow(JL)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      zrho(JL,klev+1)=zrho(Jl,klev+1)
+     *               /(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      endif
+ 2110 continue
+
+
+200   continue
+
+C***********************************************************
+C
+C*         3.      COMPUTE MOUNTAIN LIFT
+C
+  300 continue
+C
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+       ztau(jl,klev+1)= - gklift*zrho(jl,klev+1)*2.*romega*
+c    *                 (2*pstd(jl)+pmea(jl))*
+     *                 2*pstd(jl)*
+     *                 sin(rpi/180.*plat(jl))*pvlow(jl)
+       ztav(jl,klev+1)=   gklift*zrho(jl,klev+1)*2.*romega*
+c    *                 (2*pstd(jl)+pmea(jl))*
+     *                 2*pstd(jl)*
+     *                 sin(rpi/180.*plat(jl))*pulow(jl)
+      else
+       ztau(jl,klev+1)=0.0
+       ztav(jl,klev+1)=0.0
+      endif
+301   continue
+
+C
+C*         4.      COMPUTE LIFT PROFILE         
+C*                 --------------------   
+C
+
+  400 continue
+
+      do 401 jk=1,klev
+      do 401 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      ztau(jl,jk)=ztau(jl,klev+1)*paphm1(jl,jk)/paphm1(jl,klev+1)
+      ztav(jl,jk)=ztav(jl,klev+1)*paphm1(jl,jk)/paphm1(jl,klev+1)
+      else
+      ztau(jl,jk)=0.0
+      ztav(jl,jk)=0.0
+      endif
+401   continue
+C
+C
+C*         5.      COMPUTE TENDENCIES.
+C*                 -------------------
+      if(lifthigh)then
+C
+  500 continue
+C
+C  EXPLICIT SOLUTION AT ALL LEVELS
+C
+      do 524 jk=1,klev
+      do 523 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+      zdudt(jl)=-rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp
+      zdvdt(jl)=-rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp
+      endif  
+  523 continue
+  524 continue
+C
+C  PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
+C
+      do 530 jk=1,klev
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+        zslow=sqrt(pulow(jl)**2+pvlow(jl)**2)
+        zsqua=amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2),gvsec)
+        zscav=-zdudt(jl)*pvm1(jl,jk)+zdvdt(jl)*pum1(jl,jk)
+        if(zsqua.gt.gvsec)then
+          pvom(jl,jk)=-zscav*pvm1(jl,jk)/zsqua**2
+          pvol(jl,jk)= zscav*pum1(jl,jk)/zsqua**2
+        else
+          pvom(jl,jk)=0.0
+          pvol(jl,jk)=0.0      
+        endif  
+        zsqua=sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2)               
+        if(zsqua.lt.zslow)then
+          pvom(jl,jk)=zsqua/zslow*pvom(jl,jk)
+          pvol(jl,jk)=zsqua/zslow*pvol(jl,jk)
+        endif 
+
+      endif  
+530   continue
+C
+C  6.  LOW LEVEL LIFT, SEMI IMPLICIT:
+C  ----------------------------------
+
+      else
+
+        do 601 jl=kidia,kfdia
+        if(ktest(jl).eq.1) then
+          do jk=klev,iknub(jl),-1
+          zbet=gklift*2.*romega*sin(rpi/180.*plat(jl))*ztmst*
+     *        (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,  jk))/
+     *        (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,klev))
+          zdudt(jl)=-pum1(jl,jk)/ztmst/(1+zbet**2)
+          zdvdt(jl)=-pvm1(jl,jk)/ztmst/(1+zbet**2)
+          pvom(jl,jk)= zbet**2*zdudt(jl) - zbet   *zdvdt(jl)
+          pvol(jl,jk)= zbet   *zdudt(jl) + zbet**2*zdvdt(jl)    
+          enddo
+        endif
+ 601    continue
+
+      endif
+
+c     print *,' out orolift'
+
+      return
+      end
+      SUBROUTINE SUGWD_strato(NLON,NLEV,paprs,pplay)
+C     
+C
+C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
+C
+C     PURPOSE.
+C     --------
+C           INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
+C           GRAVITY WAVE DRAG PARAMETRIZATION.
+C    VERY IMPORTANT:
+C    ______________
+C           THIS ROUTINE SET_UP THE "TUNABLE PARAMETERS" OF THE
+C           VARIOUS SSO SCHEMES
+C
+C**   INTERFACE.
+C     ----------
+C        CALL *SUGWD* FROM *SUPHEC*
+C              -----        ------
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C        PAPRS,PPLAY : Pressure at semi and full model levels
+C        NLEV        : number of model levels
+c        NLON        : number of points treated in the physics
+C
+C        IMPLICIT ARGUMENTS :
+C        --------------------
+C        COMMON YOEGWD
+C-GFRCRIT-R:  Critical Non-dimensional mountain Height
+C             (HNC in (1),    LOTT 1999)
+C-GKWAKE--R:  Bluff-body drag coefficient for low level wake
+C             (Cd in (2),     LOTT 1999)
+C-GRCRIT--R:  Critical Richardson Number 
+C             (Ric, End of first column p791 of LOTT 1999) 
+C-GKDRAG--R:  Gravity wave drag coefficient
+C             (G in (3),      LOTT 1999)
+C-GKLIFT--R:  Mountain Lift coefficient
+C             (Cl in (4),     LOTT 1999)
+C-GHMAX---R:  Not used
+C-GRAHILO-R:  Set-up the trapped waves fraction
+C             (Beta , End of first column,  LOTT 1999)
+C
+C-GSIGCR--R:  Security value for blocked flow depth
+C-NKTOPG--I:  Security value for blocked flow level
+C-nstra----I:  An estimate to qualify the upper levels of
+C             the model where one wants to impose strees
+C             profiles
+C-GSSECC--R:  Security min value for low-level B-V frequency
+C-GTSEC---R:  Security min value for anisotropy and GW stress.
+C-GVSEC---R:  Security min value for ulow
+C         
+C
+C     METHOD.
+C     -------
+C        SEE DOCUMENTATION
+C
+C     EXTERNALS.
+C     ----------
+C        NONE
+C
+C     REFERENCE.
+C     ----------
+C     Lott, 1999: Alleviation of stationary biases in a GCM through...
+C                 Monthly Weather Review, 127, pp 788-801.
+C
+C     AUTHOR.
+C     -------
+C        FRANCOIS LOTT        *LMD*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 90-01-01 (MARTIN MILLER, ECMWF)
+C        LAST:  99-07-09     (FRANCOIS LOTT,LMD)
+C     ------------------------------------------------------------------
+      USE dimphy
+      USE mod_phys_lmdz_para
+      USE mod_grid_phy_lmdz
+      IMPLICIT NONE
+C
+C     -----------------------------------------------------------------
+#include "YOEGWD.h"
+C      ----------------------------------------------------------------
+C
+C  ARGUMENTS
+      integer nlon,nlev
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+C
+      INTEGER JK
+      REAL ZPR,ZTOP,ZSIGT,ZPM1R
+      REAL :: pplay_glo(klon_glo,nlev)
+      REAL :: paprs_glo(klon_glo,nlev+1)
+
+C
+C*       1.    SET THE VALUES OF THE PARAMETERS
+C              --------------------------------
+C
+ 100  CONTINUE
+C
+      PRINT *,' DANS SUGWD NLEV=',NLEV
+      GHMAX=10000.
+C
+      ZPR=100000.
+      ZTOP=0.001 
+      ZSIGT=0.94
+cold  ZPR=80000.
+cold  ZSIGT=0.85
+C
+      CALL gather(pplay,pplay_glo)
+      CALL bcast(pplay_glo)
+      CALL gather(paprs,paprs_glo)
+      CALL bcast(paprs_glo)
+
+      DO 110 JK=1,NLEV
+      ZPM1R=pplay_glo(klon_glo/2+1,jk)/paprs_glo(klon_glo/2+1,1) 
+      IF(ZPM1R.GE.ZSIGT)THEN
+         nktopg=JK
+      ENDIF
+      ZPM1R=pplay_glo(klon_glo/2+1,jk)/paprs_glo(klon_glo/2+1,1) 
+      IF(ZPM1R.GE.ZTOP)THEN
+         nstra=JK
+      ENDIF
+  110 CONTINUE
+c
+c  inversion car dans orodrag on compte les niveaux a l'envers
+      nktopg=nlev-nktopg+1
+      nstra=nlev-nstra
+      print *,' DANS SUGWD nktopg=', nktopg
+      print *,' DANS SUGWD nstra=', nstra
+C
+      GSIGCR=0.80
+C
+      GKDRAG=0.1875
+      GRAHILO=0.1   
+      GRCRIT=1.00 
+      GFRCRIT=1.00
+      GKWAKE=0.50
+C
+      GKLIFT=0.25
+      GVCRIT =0.1
+
+      WRITE(UNIT=6,FMT='('' *** SSO essential constants ***'')')
+      WRITE(UNIT=6,FMT='('' *** SPECIFIED IN SUGWD ***'')')
+      WRITE(UNIT=6,FMT='('' Gravity wave ct '',E13.7,'' '')')GKDRAG
+      WRITE(UNIT=6,FMT='('' Trapped/total wave dag '',E13.7,'' '')')
+     S      GRAHILO
+      WRITE(UNIT=6,FMT='('' Critical Richardson   = '',E13.7,'' '')')
+     S                  GRCRIT
+      WRITE(UNIT=6,FMT='('' Critical Froude'',e13.7)') GFRCRIT
+      WRITE(UNIT=6,FMT='('' Low level Wake bluff cte'',e13.7)') GKWAKE
+      WRITE(UNIT=6,FMT='('' Low level lift  cte'',e13.7)') GKLIFT
+
+C
+C
+C      ----------------------------------------------------------------
+C
+C*       2.    SET VALUES OF SECURITY PARAMETERS
+C              ---------------------------------
+C
+ 200  CONTINUE
+C
+      GVSEC=0.10
+      GSSEC=0.0001
+C
+      GTSEC=0.00001
+C
+      RETURN
+      END
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi_strato.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi_strato.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi_strato.F90	(revision 17)
@@ -0,0 +1,2054 @@
+      SUBROUTINE drag_noro_strato (nlon,nlev,dtime,paprs,pplay,                      &
+       &                   pmea,pstd, psig, pgam, pthe,ppic,pval,                    &
+       &                   kgwd,kdx,ktest,                                           &
+       &                   t, u, v,                                                  &
+       &                   pulow, pvlow, pustr, pvstr,                               &
+       &                   d_t, d_u, d_v)
+!c
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+!c Object: Mountain drag interface. Made necessary because:
+!C 1. in the LMD-GCM Layers are from bottom to top,
+!C    contrary to most European GCM.
+!c 2. the altitude above ground of each model layers
+!c    needs to be known (variable zgeom)
+!c======================================================================
+!c Explicit Arguments:
+!c ==================
+!c nlon----input-I-Total number of horizontal points that get into physics
+!c nlev----input-I-Number of vertical levels
+!c dtime---input-R-Time-step (s)
+!c paprs---input-R-Pressure in semi layers    (Pa)
+!c pplay---input-R-Pressure model-layers      (Pa)
+!c t-------input-R-temperature (K)
+!c u-------input-R-Horizontal wind (m/s)
+!c v-------input-R-Meridional wind (m/s)
+!c pmea----input-R-Mean Orography (m)
+!C pstd----input-R-SSO standard deviation (m)
+!c psig----input-R-SSO slope
+!c pgam----input-R-SSO Anisotropy
+!c pthe----input-R-SSO Angle
+!c ppic----input-R-SSO Peacks elevation (m)
+!c pval----input-R-SSO Valleys elevation (m)
+!c
+!c kgwd- -input-I: Total nb of points where the orography schemes are active
+!c ktest--input-I: Flags to indicate active points
+!c kdx----input-I: Locate the physical location of an active point.
+
+!c pulow, pvlow -output-R: Low-level wind
+!c pustr, pvstr -output-R: Surface stress due to SSO drag      (Pa)
+!c
+!c d_t-----output-R: T increment            
+!c d_u-----output-R: U increment              
+!c d_v-----output-R: V increment              
+!c
+!c Implicit Arguments:
+!c ===================
+!c
+!c iim--common-I: Number of longitude intervals
+!c jjm--common-I: Number of latitude intervals
+!c klon-common-I: Number of points seen by the physics
+!c                (iim+1)*(jjm+1) for instance
+!c klev-common-I: Number of vertical layers
+!c======================================================================
+!c Local Variables:
+!c ================
+!c
+!c zgeom-----R: Altitude of layer above ground
+!c pt, pu, pv --R: t u v from top to bottom
+!c pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom) 
+!c papmf: pressure at model layer (from top to bottom)
+!c papmh: pressure at model 1/2 layer (from top to bottom)
+!c 
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+!c
+!c  ARGUMENTS
+!c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+      REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+!c
+      INTEGER i, k, kgwd,  kdx(nlon), ktest(nlon)
+!c
+!c LOCAL VARIABLES:
+!c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+      CHARACTER (LEN=20) :: modname='orografi_strato'
+      CHARACTER (LEN=80) :: abort_message
+!c
+!c INITIALIZE OUTPUT VARIABLES 
+!c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+!c
+!c PREPARE INPUT VARIABLES FOR ORODRAG (i.e., ORDERED FROM TOP TO BOTTOM)
+!C CALCULATE LAYERS HEIGHT ABOVE GROUND)
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)                                             &
+       &                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0                    &
+       &               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+!c
+!c CALL SSO DRAG ROUTINES        
+!c
+      CALL orodrag_strato(klon,klev,kgwd,kdx,ktest,                                  &
+       &            dtime,                                                           &
+       &            papmh, papmf, zgeom,                                             &
+       &            pt, pu, pv,                                                      &
+       &            pmea, pstd, psig, pgam, pthe, ppic,pval,                         &
+       &            pulow,pvlow,                                                     &
+       &            pdudt,pdvdt,pdtdt)
+!C
+!C COMPUTE INCREMENTS AND STRESS FROM TENDENCIES
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)                                                  &
+       &                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+         pvstr(i)        = pvstr(i)                                                  &
+       &                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+      ENDDO
+      ENDDO
+!c
+      RETURN
+      END
+
+      SUBROUTINE orodrag_strato( nlon,nlev                                           &
+       &                 , kgwd,  kdx, ktest                                         &
+       &                 , ptsphy                                                    &
+       &                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1                        &
+       &                 , pmea, pstd, psig, pgam, pthe, ppic, pval                  &
+!c outputs                                                                           &
+       &                 , pulow,pvlow                                               &
+       &                 , pvom,pvol,pte )
+      
+      USE dimphy
+      IMPLICIT NONE
+!c
+!c
+!c**** *orodrag* - does the SSO drag  parametrization.
+!c
+!c     purpose.
+!c     --------
+!c
+!c     this routine computes the physical tendencies of the
+!c     prognostic variables u,v  and t due to  vertical transports by
+!c     subgridscale orographically excited gravity waves, and to
+!c     low level blocked flow drag.
+!c
+!c**   interface.
+!c     ----------
+!c          called from *drag_noro*.
+!c
+!c          the routine takes its input from the long-term storage:
+!c          u,v,t and p at t-1.
+!c
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c nlon----input-I-Total number of horizontal points that get into physics
+!c nlev----input-I-Number of vertical levels
+!c
+!c kgwd- -input-I: Total nb of points where the orography schemes are active
+!c ktest--input-I: Flags to indicate active points
+!c kdx----input-I: Locate the physical location of an active point.
+!c ptsphy--input-R-Time-step (s)
+!c paphm1--input-R: pressure at model 1/2 layer
+!c papm1---input-R: pressure at model layer
+!c pgeom1--input-R: Altitude of layer above ground
+!c ptm1, pum1, pvm1--R-: t, u and v
+!c pmea----input-R-Mean Orography (m)
+!C pstd----input-R-SSO standard deviation (m)
+!c psig----input-R-SSO slope
+!c pgam----input-R-SSO Anisotropy
+!c pthe----input-R-SSO Angle
+!c ppic----input-R-SSO Peacks elevation (m)
+!c pval----input-R-SSO Valleys elevation (m)
+
+      integer nlon,nlev,kgwd
+      real ptsphy
+
+!c     ==== outputs ===
+!c pulow, pvlow -output-R: Low-level wind
+!c
+!c pte -----output-R: T tendency
+!c pvom-----output-R: U tendency
+!c pvol-----output-R: V tendency
+!c
+!c
+!c Implicit Arguments:
+!c ===================
+!c
+!c klon-common-I: Number of points seen by the physics
+!c klev-common-I: Number of vertical layers
+!c
+!c     method.
+!c     -------
+!c
+!c     externals.
+!c     ----------
+      integer ismin, ismax
+      external ismin, ismax
+!c
+!c     reference.
+!c     ----------
+!c
+!c     author.
+!c     -------
+!c     m.miller + b.ritter   e.c.m.w.f.     15/06/86.
+!c
+!c     f.lott + m. miller    e.c.m.w.f.     22/11/94
+!c-----------------------------------------------------------------------
+!c
+!c
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+!c-----------------------------------------------------------------------
+!c
+!c*       0.1   arguments
+!c              ---------
+!c
+!c
+      real  pte(nlon,nlev),                                                          &
+       &      pvol(nlon,nlev),                                                       &
+       &      pvom(nlon,nlev),                                                       &
+       &      pulow(nlon),                                                           &
+       &      pvlow(nlon)
+      real  pum1(nlon,nlev),                                                         &
+       &      pvm1(nlon,nlev),                                                       &
+       &      ptm1(nlon,nlev),                                                       &
+       &      pmea(nlon),pstd(nlon),psig(nlon),                                      &
+       &      pgam(nlon),pthe(nlon),ppic(nlon),pval(nlon),                           &
+       &      pgeom1(nlon,nlev),                                                     &
+       &      papm1(nlon,nlev),                                                      &
+       &      paphm1(nlon,nlev+1)
+!c
+      integer  kdx(nlon),ktest(nlon)
+!c-----------------------------------------------------------------------
+!c
+!c*       0.2   local arrays
+!c              ------------
+      integer  isect(klon),                                                          &
+       &         icrit(klon),                                                        &
+       &         ikcrith(klon),                                                      &
+       &         ikenvh(klon),                                                       &
+       &         iknu(klon),                                                         &
+       &         iknu2(klon),                                                        &
+       &         ikcrit(klon),                                                       &
+       &         ikhlim(klon)
+!c
+      real   ztau(klon,klev+1),                                                      &
+       &       zstab(klon,klev+1),                                                   &
+       &       zvph(klon,klev+1),                                                    &
+       &       zrho(klon,klev+1),                                                    &
+       &       zri(klon,klev+1),                                                     &
+       &       zpsi(klon,klev+1),                                                    &
+       &       zzdep(klon,klev)
+      real   zdudt(klon),                                                            &
+       &       zdvdt(klon),                                                          &
+       &       zdtdt(klon),                                                          &
+       &       zdedt(klon),                                                          &
+       &       zvidis(klon),                                                         &
+       &       ztfr(klon),                                                           &
+       &       znu(klon),                                                            &
+       &       zd1(klon),                                                            &
+       &       zd2(klon),                                                            &
+       &       zdmod(klon)
+
+
+!c local quantities:
+
+      integer jl,jk,ji
+      real ztmst,zdelp,ztemp,zforc,ztend,rover                
+      real zb,zc,zconb,zabsv,zzd1,ratio,zbet,zust,zvst,zdis
+   
+!c
+!c------------------------------------------------------------------
+!c
+!c*         1.    initialization
+!c                --------------
+!c
+!c        print *,' in orodrag'
+ 100  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.1   computational constants
+!c                -----------------------
+!c
+ 110  continue
+!c
+!c     ztmst=twodt
+!c     if(nstep.eq.nstart) ztmst=0.5*twodt
+      ztmst=ptsphy
+!c     ------------------------------------------------------------------
+!c
+ 120  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.3   check whether row contains point for printing
+!c                ---------------------------------------------
+!c
+ 130  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         2.     precompute basic state variables.
+!c*                ---------- ----- ----- ----------
+!c*                define low level wind, project winds in plane of
+!c*                low level wind, determine sector in which to take
+!c*                the variance and set indicator for critical levels.
+!c
+
+  200 continue
+!c
+!c
+!c
+      call orosetup_strato                                                           &
+       &     ( nlon, nlev , ktest                                                    &
+       &     , ikcrit, ikcrith, icrit, isect, ikhlim, ikenvh,iknu,iknu2              &
+       &     , paphm1, papm1 , pum1   , pvm1 , ptm1 , pgeom1, pstd                   &
+       &     , zrho  , zri   , zstab  , ztau , zvph , zpsi, zzdep                    &
+       &     , pulow, pvlow                                                          &
+       &     , pthe,pgam,pmea,ppic,pval,znu  ,zd1,  zd2,  zdmod )
+
+
+!c
+!c
+!c
+!c***********************************************************
+!c
+!c
+!c*         3.      compute low level stresses using subcritical and
+!c*                 supercritical forms.computes anisotropy coefficient
+!c*                 as measure of orographic twodimensionality.
+!c
+  300 continue
+!c
+      call gwstress_strato                                                           &
+       &    ( nlon  , nlev                                                           &
+       &    , ikcrit, isect, ikhlim, ktest, ikcrith, icrit, ikenvh, iknu             &
+       &    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic, pval                   &
+       &    , ztfr   , ztau                                                          &
+       &    , pgeom1,pgam,zd1,zd2,zdmod,znu)
+
+!c
+!c
+!c*         4.      compute stress profile including
+!c                  trapped waves, wave breaking,
+!c                  linear decay in stratosphere.
+!c
+  400 continue
+!c
+!c
+
+      call gwprofil_strato                                                           &
+       &       (  nlon , nlev                                                        &
+       &       , kgwd   , kdx  , ktest                                               &
+       &       , ikcrit, ikcrith, icrit  , ikenvh, iknu                              &
+       &       ,iknu2 , paphm1, zrho   , zstab , ztfr   , zvph                       &
+       &       , zri   , ztau                                                        &
+       &       , zdmod , znu    , psig  , pgam , pstd , ppic , pval)
+
+!c
+!c*         5.      Compute tendencies from waves stress profile.
+!c                  Compute low level blocked flow drag. 
+!c*                 --------------------------------------------
+!c
+  500 continue
+
+      
+!c
+!c  explicit solution at all levels for the gravity wave
+!c  implicit solution for the blocked levels
+
+      do 510 jl=kidia,kfdia
+      zvidis(jl)=0.0
+      zdudt(jl)=0.0
+      zdvdt(jl)=0.0
+      zdtdt(jl)=0.0
+  510 continue
+!c
+
+      do 524 jk=1,klev
+!c
+
+!C  WAVE STRESS 
+!C-------------
+!c
+!c
+      do 523 ji=kidia,kfdia
+
+      if(ktest(ji).eq.1) then
+
+      zdelp=paphm1(ji,jk+1)-paphm1(ji,jk)
+      ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,klev+1)*zdelp)
+
+      zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
+      zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
+!c
+!c Control Overshoots
+!c
+
+      if(jk.ge.nstra)then
+        rover=0.10
+        if(abs(zdudt(ji)).gt.rover*abs(pum1(ji,jk))/ztmst)                           &
+       &    zdudt(ji)=rover*abs(pum1(ji,jk))/ztmst*                                  &
+       &              zdudt(ji)/(abs(zdudt(ji))+1.E-10)
+        if(abs(zdvdt(ji)).gt.rover*abs(pvm1(ji,jk))/ztmst)                           &
+       &    zdvdt(ji)=rover*abs(pvm1(ji,jk))/ztmst*                                  &
+       &              zdvdt(ji)/(abs(zdvdt(ji))+1.E-10)
+      endif 
+
+      rover=0.25
+      zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2)        
+      ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst                      
+
+      if(zforc.ge.rover*ztend)then
+        zdudt(ji)=rover*ztend/zforc*zdudt(ji)
+        zdvdt(ji)=rover*ztend/zforc*zdvdt(ji)
+      endif
+!c
+!c BLOCKED FLOW DRAG:
+!C -----------------
+!c
+      if(jk.gt.ikenvh(ji)) then
+         zb=1.0-0.18*pgam(ji)-0.04*pgam(ji)**2
+         zc=0.48*pgam(ji)+0.3*pgam(ji)**2
+         zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji))
+         zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
+         zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2
+         ratio=(cos(zpsi(ji,jk))**2+pgam(ji)*sin(zpsi(ji,jk))**2)/                   &
+       &   (pgam(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
+         zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv
+!c
+!c OPPOSED TO THE WIND
+!c
+         zdudt(ji)=-pum1(ji,jk)/ztmst
+         zdvdt(ji)=-pvm1(ji,jk)/ztmst
+!c
+!c PERPENDICULAR TO THE SSO MAIN AXIS:
+!C                            
+!cmod     zdudt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.)
+!cmod *              +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.))
+!cmod *              *cos(pthe(ji)*rpi/180.)/ztmst
+!cmod     zdvdt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.)
+!cmod *              +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.))
+!cmod *              *sin(pthe(ji)*rpi/180.)/ztmst
+!C
+         zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet))
+         zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet))
+      end if
+      pvom(ji,jk)=zdudt(ji)
+      pvol(ji,jk)=zdvdt(ji)
+      zust=pum1(ji,jk)+ztmst*zdudt(ji)
+      zvst=pvm1(ji,jk)+ztmst*zdvdt(ji)
+      zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
+      zdedt(ji)=zdis/ztmst
+      zvidis(ji)=zvidis(ji)+zdis*zdelp
+      zdtdt(ji)=zdedt(ji)/rcpd
+!c
+!c  NO TENDENCIES ON TEMPERATURE .....
+!c
+!c  Instead of, pte(ji,jk)=zdtdt(ji), due to mechanical dissipation
+!c
+      pte(ji,jk)=0.0
+
+      endif
+
+  523 continue
+  524 continue
+!c
+!c
+  501 continue
+
+      return
+      end
+      SUBROUTINE orosetup_strato                                                     &
+       &         ( nlon   , nlev  , ktest                                            &
+       &         , kkcrit, kkcrith, kcrit, ksect , kkhlim                            &
+       &         , kkenvh, kknu  , kknu2                                             &
+       &         , paphm1, papm1 , pum1   , pvm1 , ptm1  , pgeom1, pstd              &
+       &         , prho  , pri   , pstab  , ptau , pvph  ,ppsi, pzdep                &
+       &         , pulow , pvlow                                                     &
+       &         , ptheta, pgam, pmea, ppic, pval                                    &
+       &         , pnu  ,  pd1  ,  pd2  ,pdmod  )
+!C
+!c**** *gwsetup*
+!c
+!c     purpose.
+!c     --------
+!c     SET-UP THE ESSENTIAL PARAMETERS OF THE SSO DRAG SCHEME:
+!C     DEPTH OF LOW WBLOCKED LAYER, LOW-LEVEL FLOW, BACKGROUND
+!C     STRATIFICATION.....
+!c
+!c**   interface.
+!c     ----------
+!c          from *orodrag*
+!c
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c 
+!c nlon----input-I-Total number of horizontal points that get into physics
+!c nlev----input-I-Number of vertical levels
+!c ktest--input-I: Flags to indicate active points
+!c
+!c ptsphy--input-R-Time-step (s)
+!c paphm1--input-R: pressure at model 1/2 layer
+!c papm1---input-R: pressure at model layer
+!c pgeom1--input-R: Altitude of layer above ground
+!c ptm1, pum1, pvm1--R-: t, u and v
+!c pmea----input-R-Mean Orography (m)
+!C pstd----input-R-SSO standard deviation (m)
+!c psig----input-R-SSO slope
+!c pgam----input-R-SSO Anisotropy
+!c pthe----input-R-SSO Angle
+!c ppic----input-R-SSO Peacks elevation (m)
+!c pval----input-R-SSO Valleys elevation (m)
+
+!c     ==== outputs ===
+!c pulow, pvlow -output-R: Low-level wind
+!c kkcrit----I-: Security value for top of low level flow
+!c kcrit-----I-: Critical level 
+!c ksect-----I-: Not used
+!c kkhlim----I-: Not used
+!c kkenvh----I-: Top of blocked flow layer
+!c kknu------I-: Layer that sees mountain peacks
+!c kknu2-----I-: Layer that sees mountain peacks above mountain mean
+!c kknub-----I-: Layer that sees mountain mean above valleys
+!c prho------R-: Density at 1/2 layers
+!c pri-------R-: Background Richardson Number, Wind shear measured along GW stress
+!c pstab-----R-: Brunt-Vaisala freq. at 1/2 layers
+!c pvph------R-: Wind in  plan of GW stress, Half levels.
+!c ppsi------R-: Angle between low level wind and SS0 main axis.
+!c pd1-------R-| Compared the ratio of the stress
+!c pd2-------R-| that is along the wind to that Normal to it.
+!c               pdi define the plane of low level stress
+!c               compared to the low level wind.
+!c see p. 108 Lott & Miller (1997).                      
+!c pdmod-----R-: Norme of pdi
+
+!c     === local arrays ===
+!c
+!c zvpf------R-: Wind projected in the plan of the low-level stress.
+
+!c     ==== outputs ===
+!c
+!c        implicit arguments :   none
+!c        --------------------
+!c
+!c     method.
+!c     -------
+!c
+!c
+!c     externals.
+!c     ----------
+!c
+!c
+!c     reference.
+!c     ----------
+!c
+!c        see ecmwf research department documentation of the "i.f.s."
+!c
+!c     author.
+!c     -------
+!c
+!c     modifications.
+!c     --------------
+!c     f.lott  for the new-gwdrag scheme november 1993
+!c
+!c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+!c
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+!c-----------------------------------------------------------------------
+!c
+!c*       0.1   arguments
+!c              ---------
+!c
+      integer nlon,nlev
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon),                    &
+       &        kkhlim(nlon),ktest(nlon),kkenvh(nlon)
+
+!c
+      real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev),                     &
+       &     pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev),                      &
+       &     prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1),                  &
+       &     ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1),                  &
+       &     pzdep(nlon,klev)
+       real pulow(nlon),pvlow(nlon),ptheta(nlon),pgam(nlon),pnu(nlon),               &
+       &     pd1(nlon),pd2(nlon),pdmod(nlon)
+      real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon)
+!c
+!c-----------------------------------------------------------------------
+!c
+!c*       0.2   local arrays
+!c              ------------
+!c
+!c
+      integer ilevh ,jl,jk
+      real zcons1,zcons2,zhgeo,zu,zphi
+      real zvt1,zvt2,zdwind,zwind,zdelp
+      real zstabm,zstabp,zrhom,zrhop
+      logical lo 
+      logical ll1(klon,klev+1)
+      integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon),                        &
+       &        kentp(klon),ncount(klon)  
+!c
+      real zhcrit(klon,klev),zvpf(klon,klev),                                        &
+       &     zdp(klon,klev)
+      real znorm(klon),zb(klon),zc(klon),                                            &
+       &      zulow(klon),zvlow(klon),znup(klon),znum(klon)
+!c       
+!c     ------------------------------------------------------------------
+!c
+!c*         1.    initialization
+!c                --------------
+!c
+!c       PRINT *,' in orosetup'
+ 100  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.1   computational constants
+!c                -----------------------
+!c
+ 110  continue
+!c
+      ilevh =klev/3
+!c
+      zcons1=1./rd
+      zcons2=rg**2/rcpd
+!c
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         2.
+!c                --------------
+!c
+ 200  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         2.1     define low level wind, project winds in plane of
+!c*                 low level wind, determine sector in which to take
+!c*                 the variance and set indicator for critical levels.
+!c
+!c
+!c
+      do 2001 jl=kidia,kfdia
+      kknu(jl)    =klev
+      kknu2(jl)   =klev
+      kknub(jl)   =klev
+      kknul(jl)   =klev
+      pgam(jl) =max(pgam(jl),gtsec)
+      ll1(jl,klev+1)=.false.
+ 2001 continue
+!c
+!c Ajouter une initialisation (L. Li, le 23fev99):
+!c
+      do jk=klev,ilevh,-1
+      do jl=kidia,kfdia
+      ll1(jl,jk)= .false.
+      ENDDO
+      ENDDO
+!c
+!c*      define top of low level flow
+!c       ----------------------------
+      do 2002 jk=klev,ilevh,-1
+      do 2003 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr
+      if(lo) then
+        kkcrit(jl)=jk
+      endif
+      zhcrit(jl,jk)=ppic(jl)-pval(jl)           
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu(jl)=ilevh
+      endif
+ 2003 continue
+ 2002 continue
+      do 2004 jk=klev,ilevh,-1
+      do 2005 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zhcrit(jl,jk)=ppic(jl)-pmea(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu2(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh
+      endif
+ 2005 continue
+ 2004 continue
+      do 2006 jk=klev,ilevh,-1
+      do 2007 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zhcrit(jl,jk)=amin1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl))
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknub(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknub(jl)=ilevh
+      endif
+ 2007 continue
+ 2006 continue
+!c
+      do 2010 jl=kidia,kfdia  
+      if(ktest(jl).eq.1) then
+      kknu(jl)=min(kknu(jl),nktopg)
+      kknu2(jl)=min(kknu2(jl),nktopg)
+      kknub(jl)=min(kknub(jl),nktopg)
+      kknul(jl)=klev
+      endif
+ 2010 continue      
+!c
+ 210  continue
+!c
+!cc*     initialize various arrays
+!c
+      do 2107 jl=kidia,kfdia
+      prho(jl,klev+1)  =0.0
+!cym correction en attendant mieux
+      prho(jl,1)  =0.0      
+      pstab(jl,klev+1) =0.0
+      pstab(jl,1)      =0.0
+      pri(jl,klev+1)   =9999.0
+      ppsi(jl,klev+1)  =0.0
+      pri(jl,1)        =0.0
+      pvph(jl,1)       =0.0
+      pvph(jl,klev+1)  =0.0
+!cym correction en attendant mieux
+!cym      pvph(jl,klev)    =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      zulow(jl)        =0.0
+      zvlow(jl)        =0.0
+      kkcrith(jl)      =klev
+      kkenvh(jl)       =klev
+      kentp(jl)        =klev
+      kcrit(jl)        =1
+      ncount(jl)       =0
+      ll1(jl,klev+1)   =.false.
+ 2107 continue
+!c
+!c*     define flow density and stratification (rho and N2)
+!c      at semi layers.
+!c      -------------------------------------------------------
+!c
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))*                          &
+       &  (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+        pstab(jl,jk)=max(pstab(jl,jk),gssec)
+      endif
+  222 continue
+  223 continue
+!c
+!c********************************************************************
+!c
+!c*     define Low level flow (between ground and peacks-valleys)
+!c      ---------------------------------------------------------
+      do 2115 jk=klev,ilevh,-1
+      do 2116 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+      if(jk.ge.kknu2(jl).and.jk.le.kknul(jl)) then
+        pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pstab(jl,klev+1)=pstab(jl,klev+1)                                            &
+       &                   +pstab(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        prho(jl,klev+1)=prho(jl,klev+1)                                              &
+       &                   +prho(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      end if
+      endif
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+      pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+      pvph(jl,klev+1)=znorm(jl)
+      pstab(jl,klev+1)=pstab(jl,klev+1)                                              &
+       &                /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      prho(jl,klev+1)=prho(jl,klev+1)                                                &
+       &                /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      endif
+ 2110 continue
+
+!c
+!c*******  setup orography orientation relative to the low level
+!C       wind and define parameters of the Anisotropic wave stress.
+!c
+      do 2112 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec)
+        if(lo) then
+          zu=pulow(jl)+2.*gvsec
+        else
+          zu=pulow(jl)
+        endif
+        zphi=atan(pvlow(jl)/zu)
+        ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi
+        zb(jl)=1.-0.18*pgam(jl)-0.04*pgam(jl)**2
+        zc(jl)=0.48*pgam(jl)+0.3*pgam(jl)**2
+        pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
+        pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))                                 &
+       &                         *cos(ppsi(jl,klev+1))
+        pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2)
+      endif
+ 2112 continue
+!c
+!c  ************ projet flow in plane of lowlevel stress *************
+!C  ************ Find critical levels...                 *************
+!c
+      do 213 jk=1,klev
+      do 212 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        zvt1       =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk)
+        zvt2       =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk)
+        zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
+      endif
+      ptau(jl,jk)  =0.0
+      pzdep(jl,jk) =0.0
+      ppsi(jl,jk)  =0.0
+      ll1(jl,jk)   =.false.
+  212 continue
+  213 continue
+      do 215 jk=2,klev
+      do 214 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+                     &
+       &            (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1))                      &
+       &            /zdp(jl,jk)
+        if(pvph(jl,jk).lt.gvsec) then
+          pvph(jl,jk)=gvsec
+          kcrit(jl)=jk
+        endif
+      endif
+  214 continue
+  215 continue
+!c
+!c*         2.3     mean flow richardson number.
+!c
+  230 continue
+!c
+      do 232 jk=2,klev
+      do 231 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec)
+        pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk)                                          &
+       &          /(rg*prho(jl,jk)*zdwind))**2
+        pri(jl,jk)=max(pri(jl,jk),grcrit)
+      endif
+  231 continue
+  232 continue
+  
+!c
+!c
+!c*      define top of 'envelope' layer
+!c       ----------------------------
+
+      do 233 jl=kidia,kfdia
+      pnu (jl)=0.0
+      znum(jl)=0.0
+ 233  continue
+      
+      do 234 jk=2,klev-1
+      do 234 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+       
+      if (jk.ge.kknu2(jl)) then
+          
+            znum(jl)=pnu(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/                     &
+       &            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            pnu(jl) = pnu(jl) + (zdelp/rg)*                                          &
+       &            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit)                        &
+       &                          .and.(kkenvh(jl).eq.klev))                         &
+       &      kkenvh(jl)=jk
+      endif    
+
+      endif
+      
+ 234  continue
+      
+!c  calculation of a dynamical mixing height for when the waves
+!C  BREAK AT LOW LEVEL: The drag will be repartited over
+!C  a depths that depends on waves vertical wavelength,
+!C  not just between two adjacent model layers.
+!c  of gravity waves:
+
+      do 235 jl=kidia,kfdia
+      znup(jl)=0.0
+      znum(jl)=0.0
+ 235  continue
+
+      do 236 jk=klev-1,2,-1
+      do 236 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+
+            znum(jl)=znup(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/                     &
+       &            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            znup(jl) = znup(jl) + (zdelp/rg)*                                        &
+       &            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.rpi/4.).and.(znup(jl).gt.rpi/4.)                         &
+       &                          .and.(kkcrith(jl).eq.klev))                        &
+       &      kkcrith(jl)=jk
+      endif
+      
+ 236  continue
+ 
+      do 237 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      kkcrith(jl)=max0(kkcrith(jl),ilevh*2)
+      kkcrith(jl)=max0(kkcrith(jl),kknu(jl))
+      if(kcrit(jl).ge.kkcrith(jl))kcrit(jl)=1
+      endif
+ 237  continue         
+!c
+!c     directional info for flow blocking ************************* 
+!c
+      do 251 jk=1,klev    
+      do 252 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec)
+      if(lo) then
+        zu=pum1(jl,jk)+2.*gvsec
+      else
+        zu=pum1(jl,jk)
+      endif
+       zphi=atan(pvm1(jl,jk)/zu)
+       ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi
+      endif
+ 252  continue
+ 251  continue
+
+!c      forms the vertical 'leakiness' **************************
+
+      do 254  jk=ilevh,klev
+      do 253  jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      pzdep(jl,jk)=0
+      if(jk.ge.kkenvh(jl).and.kkenvh(jl).ne.klev) then
+        pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl)  )-pgeom1(jl,  jk))/                      &
+       &               (pgeom1(jl,kkenvh(jl)  )-pgeom1(jl,klev))
+      end if
+      endif
+ 253  continue
+ 254  continue
+
+      return
+      end
+      SUBROUTINE gwstress_strato                                                     &
+       &         (  nlon  , nlev                                                     &
+       &         , kkcrit, ksect, kkhlim, ktest, kkcrith, kcrit, kkenvh              &
+       &         , kknu                                                              &
+       &         , prho  , pstab , pvph  , pstd, psig                                &
+       &         , pmea , ppic , pval  , ptfr  , ptau                                &
+       &         , pgeom1 , pgamma , pd1  , pd2   , pdmod , pnu )
+!c
+!c**** *gwstress*
+!c
+!c     purpose.
+!c     --------
+!c  Compute the surface stress due to Gravity Waves, according
+!c  to the Phillips (1979) theory of 3-D flow above 
+!c  anisotropic elliptic ridges.
+
+!C  The stress is reduced two account for cut-off flow over
+!C  hill.  The flow only see that part of the ridge located
+!c  above the blocked layer (see zeff).
+!c
+!c**   interface.
+!c     ----------
+!c     call *gwstress*  from *gwdrag*
+!c
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c     ==== outputs ===
+!c
+!c        implicit arguments :   none
+!c        --------------------
+!c
+!c     method.
+!c     -------
+!c
+!c
+!c     externals.
+!c     ----------
+!c
+!c
+!c     reference.
+!c     ----------
+!c
+!c   LOTT and MILLER (1997)  &  LOTT (1999)
+!c
+!c     author.
+!c     -------
+!c
+!c     modifications.
+!c     --------------
+!c     f. lott put the new gwd on ifs      22/11/93
+!c
+!c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+!c-----------------------------------------------------------------------
+!c
+!c*       0.1   arguments
+!c              ---------
+!c
+      integer nlon,nlev
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon),                    &
+       &        kkhlim(nlon),ktest(nlon),kkenvh(nlon),kknu(nlon)
+!c
+      real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1),                   &
+       &     pvph(nlon,nlev+1),ptfr(nlon),                                           &
+       &     pgeom1(nlon,nlev),pstd(nlon)
+!c
+      real pd1(nlon),pd2(nlon),pnu(nlon),psig(nlon),pgamma(nlon)
+      real pmea(nlon),ppic(nlon),pval(nlon)
+      real pdmod(nlon)
+!c
+!c-----------------------------------------------------------------------
+!c
+!c*       0.2   local arrays
+!c              ------------
+!c  zeff--real: effective height seen by the flow when there is blocking
+
+      integer jl
+      real zeff  
+!c
+!c-----------------------------------------------------------------------
+!c
+!c*       0.3   functions
+!c              ---------
+!c     ------------------------------------------------------------------
+!c
+!c*         1.    initialization
+!c                --------------
+!c
+!c      PRINT *,' in gwstress'
+ 100  continue
+!c
+!c*         3.1     gravity wave stress.
+!c
+  300 continue
+!c
+!c
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      
+!c  effective mountain height above the blocked flow
+  
+         zeff=ppic(jl)-pval(jl)
+         if(kkenvh(jl).lt.klev)then
+         zeff=amin1(GFRCRIT*pvph(jl,klev+1)/sqrt(pstab(jl,klev+1))                   &
+       &              ,zeff)
+         endif
+
+      
+        ptau(jl,klev+1)=gkdrag*prho(jl,klev+1)                                       &
+       &     *psig(jl)*pdmod(jl)/4./pstd(jl)                                         &
+       &     *pvph(jl,klev+1)*sqrt(pstab(jl,klev+1))                                 &
+       &     *zeff**2
+
+
+!c  too small value of stress or  low level flow include critical level
+!c  or low level flow:  gravity wave stress nul.
+                
+!c       lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl))
+!c    *      .or.(pvph(jl,klev+1).lt.gvcrit)
+!c       if(lo) ptau(jl,klev+1)=0.0
+      
+!c      print *,jl,ptau(jl,klev+1)
+
+      else
+      
+          ptau(jl,klev+1)=0.0
+          
+      endif
+
+  301 continue
+
+!c      write(21)(ptau(jl,klev+1),jl=kidia,kfdia)
+ 
+      return
+      end
+
+      subroutine gwprofil_strato                                                     &
+       &         ( nlon, nlev                                                        &
+       &         , kgwd ,kdx  , ktest                                                &
+       &         , kkcrit, kkcrith, kcrit ,  kkenvh, kknu,kknu2                      &
+       &         , paphm1, prho   , pstab , ptfr , pvph , pri , ptau                 &
+       &         , pdmod   , pnu   , psig ,pgamma, pstd, ppic,pval)
+
+!C**** *gwprofil*
+!C
+!C     purpose.
+!C     --------
+!C
+!C**   interface.
+!C     ----------
+!C          from *gwdrag*
+!C
+!C        explicit arguments :
+!C        --------------------
+!C     ==== inputs ===
+!C
+!C     ==== outputs ===
+!C
+!C        implicit arguments :   none
+!C        --------------------
+!C
+!C     method:
+!C     -------
+!C     the stress profile for gravity waves is computed as follows:
+!C     it decreases linearly with heights from the ground 
+!C     to the low-level indicated by kkcrith,
+!C     to simulates lee waves or 
+!C     low-level gravity wave breaking.
+!C     above it is constant, except when the waves encounter a critical
+!C     level (kcrit) or when they break.
+!C     The stress is also uniformly distributed above the level
+!C     nstra.                                          
+!C
+      USE dimphy
+      IMPLICIT NONE
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+!C-----------------------------------------------------------------------
+!C
+!C*       0.1   ARGUMENTS
+!C              ---------
+!C
+      integer nlon,nlev,kgwd
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon)                                 &
+       &       ,kdx(nlon),ktest(nlon)                                                &
+       &       ,kkenvh(nlon),kknu(nlon),kknu2(nlon)
+!C
+      real paphm1(nlon,nlev+1), pstab(nlon,nlev+1),                                  &
+       &     prho  (nlon,nlev+1), pvph (nlon,nlev+1),                                &
+       &     pri   (nlon,nlev+1), ptfr (nlon), ptau(nlon,nlev+1)                     
+      real pdmod (nlon) , pnu (nlon) , psig(nlon),                                   &
+       &     pgamma(nlon) , pstd(nlon) , ppic(nlon), pval(nlon)                      &
+       &!C-----------------------------------------------------------------------
+!C
+!C*       0.2   local arrays
+!C              ------------
+!C
+      integer jl,jk
+      real zsqr,zalfa,zriw,zdel,zb,zalpha,zdz2n,zdelp,zdelpt
+
+      real zdz2 (klon,klev) , znorm(klon) , zoro(klon)
+      real ztau (klon,klev+1)
+!C
+!C-----------------------------------------------------------------------
+!C
+!C*         1.    INITIALIZATION
+!C                --------------
+!C
+!C      print *,' entree gwprofil' 
+ 100  CONTINUE
+!C
+!C
+!C*    COMPUTATIONAL CONSTANTS.
+!C     ------------- ----------
+!C
+      do 400 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+      zoro(jl)=psig(jl)*pdmod(jl)/4./pstd(jl)
+      ztau(jl,klev+1)=ptau(jl,klev+1)
+!c     print *,jl,ptau(jl,klev+1)
+      ztau(jl,kkcrith(jl))=grahilo*ptau(jl,klev+1)
+      endif
+  400 continue
+  
+!C
+      do 430 jk=klev+1,1,-1
+!C
+!C
+!C*         4.1    constant shear stress until top of the
+!C                 low-level breaking/trapped layer
+  410 CONTINUE
+!C
+      do 411 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+           if(jk.gt.kkcrith(jl)) then
+           zdelp=paphm1(jl,jk)-paphm1(jl,klev+1) 
+           zdelpt=paphm1(jl,kkcrith(jl))-paphm1(jl,klev+1) 
+           ptau(jl,jk)=ztau(jl,klev+1)+zdelp/zdelpt*                                 &
+       &                 (ztau(jl,kkcrith(jl))-ztau(jl,klev+1))
+           else                    
+           ptau(jl,jk)=ztau(jl,kkcrith(jl))
+           endif
+       endif
+ 411  continue             
+!C
+!C*         4.15   constant shear stress until the top of the
+!C                 low level flow layer.
+ 415  continue
+!C        
+!C
+!C*         4.2    wave displacement at next level.
+!C
+  420 continue
+!C
+  430 continue
+
+!C
+!C*         4.4    wave richardson number, new wave displacement
+!C*                and stress:  breaking evaluation and critical 
+!C                 level
+!C
+                          
+      do 440 jk=klev,1,-1
+
+      do 441 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+      znorm(jl)=prho(jl,jk)*sqrt(pstab(jl,jk))*pvph(jl,jk)
+      zdz2(jl,jk)=ptau(jl,jk)/amax1(znorm(jl),gssec)/zoro(jl)
+      endif
+  441 continue
+
+      do 442 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+          if(jk.lt.kkcrith(jl)) then
+          if((ptau(jl,jk+1).lt.gtsec).or.(jk.le.kcrit(jl))) then
+             ptau(jl,jk)=0.0
+          else
+               zsqr=sqrt(pri(jl,jk))
+               zalfa=sqrt(pstab(jl,jk)*zdz2(jl,jk))/pvph(jl,jk)
+               zriw=pri(jl,jk)*(1.-zalfa)/(1+zalfa*zsqr)**2
+               if(zriw.lt.grcrit) then
+!C                 print *,' breaking!!!',ptau(jl,jk)
+                  zdel=4./zsqr/grcrit+1./grcrit**2+4./grcrit
+                  zb=1./grcrit+2./zsqr
+                  zalpha=0.5*(-zb+sqrt(zdel))
+                  zdz2n=(pvph(jl,jk)*zalpha)**2/pstab(jl,jk)
+                  ptau(jl,jk)=znorm(jl)*zdz2n*zoro(jl)
+               endif
+                
+               ptau(jl,jk)=amin1(ptau(jl,jk),ptau(jl,jk+1))
+                  
+          endif
+          endif
+      endif
+  442 continue
+  440 continue
+
+!C  REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
+
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+         ztau(jl,kkcrith(jl)-1)=ptau(jl,kkcrith(jl)-1)
+         ztau(jl,nstra)=ptau(jl,nstra)
+      endif
+ 530  continue      
+
+      do 531 jk=1,klev
+      
+      do 532 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+                
+         if(jk.gt.kkcrith(jl)-1)then
+
+          zdelp=paphm1(jl,jk)-paphm1(jl,klev+1    )
+          zdelpt=paphm1(jl,kkcrith(jl)-1)-paphm1(jl,klev+1    )
+          ptau(jl,jk)=ztau(jl,klev+1    ) +                                          &
+       &                (ztau(jl,kkcrith(jl)-1)-ztau(jl,klev+1    ) )*               &
+       &                zdelp/zdelpt
+         endif
+      endif
+            
+ 532  continue    
+ 
+!C  REORGANISATION AT THE MODEL TOP....
+
+      do 533 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+
+         if(jk.lt.nstra)then
+
+          zdelp =paphm1(jl,nstra)
+          zdelpt=paphm1(jl,jk)
+          ptau(jl,jk)=ztau(jl,nstra)*zdelpt/zdelp 
+!c         ptau(jl,jk)=ztau(jl,nstra)                
+
+        endif
+
+      endif
+
+ 533  continue
+
+ 
+ 531  continue        
+
+
+ 123   format(i4,1x,20(f6.3,1x))
+
+
+      return
+      end
+      subroutine lift_noro_strato (nlon,nlev,dtime,paprs,pplay,                      &
+       &                   plat,pmea,pstd, psig, pgam, pthe, ppic,pval,              &
+       &                   kgwd,kdx,ktest,                                           &
+       &                   t, u, v,                                                  &
+       &                   pulow, pvlow, pustr, pvstr,                               &
+       &                   d_t, d_u, d_v)
+!c
+      USE dimphy
+      implicit none
+!c======================================================================
+!c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+!c Object: Mountain lift interface (enhanced vortex stretching).
+!c         Made necessary because:
+!C 1. in the LMD-GCM Layers are from bottom to top,
+!C    contrary to most European GCM.
+!c 2. the altitude above ground of each model layers
+!c    needs to be known (variable zgeom)
+!c======================================================================
+!c Explicit Arguments:
+!c ==================
+!c nlon----input-I-Total number of horizontal points that get into physics
+!c nlev----input-I-Number of vertical levels
+!c dtime---input-R-Time-step (s)
+!c paprs---input-R-Pressure in semi layers    (Pa)
+!c pplay---input-R-Pressure model-layers      (Pa)
+!c t-------input-R-temperature (K)
+!c u-------input-R-Horizontal wind (m/s)
+!c v-------input-R-Meridional wind (m/s)
+!c pmea----input-R-Mean Orography (m)
+!C pstd----input-R-SSO standard deviation (m)
+!c psig----input-R-SSO slope
+!c pgam----input-R-SSO Anisotropy
+!c pthe----input-R-SSO Angle
+!c ppic----input-R-SSO Peacks elevation (m)
+!c pval----input-R-SSO Valleys elevation (m)
+!c
+!c kgwd- -input-I: Total nb of points where the orography schemes are active
+!c ktest--input-I: Flags to indicate active points
+!c kdx----input-I: Locate the physical location of an active point.
+
+!c pulow, pvlow -output-R: Low-level wind
+!c pustr, pvstr -output-R: Surface stress due to SSO drag      (Pa)
+!c
+!c d_t-----output-R: T increment
+!c d_u-----output-R: U increment
+!c d_v-----output-R: V increment
+!c
+!c Implicit Arguments:
+!c ===================
+!c
+!c iim--common-I: Number of longitude intervals
+!c jjm--common-I: Number of latitude intervals
+!c klon-common-I: Number of points seen by the physics
+!c                (iim+1)*(jjm+1) for instance
+!c klev-common-I: Number of vertical layers
+!c======================================================================
+!c Local Variables:
+!c ================
+!c
+!c zgeom-----R: Altitude of layer above ground
+!c pt, pu, pv --R: t u v from top to bottom
+!c pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom)
+!c papmf: pressure at model layer (from top to bottom)
+!c papmh: pressure at model 1/2 layer (from top to bottom)
+!c
+!c======================================================================
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+!c
+!c ARGUMENTS
+!c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL plat(nlon),pmea(nlon)
+      REAL pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+!c
+      INTEGER i, k, kgwd,  kdx(nlon), ktest(nlon)
+!c
+!c Variables locales:
+!c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+!c
+!c initialiser les variables de sortie (pour securite)
+!c
+
+!c     print *,'in lift_noro'
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+!c
+!c preparer les variables d'entree (attention: l'ordre des niveaux 
+!c verticaux augmente du haut vers le bas)
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)                                             &
+       &                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0                    &
+       &               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+!c
+!c appeler la routine principale
+!c
+
+      CALL OROLIFT_strato(klon,klev,kgwd,kdx,ktest,                                  &
+       &            dtime,                                                           &
+       &            papmh, papmf, zgeom,                                             &
+       &            pt, pu, pv,                                                      &
+       &            plat,pmea, pstd, psig, pgam, pthe, ppic,pval,                    &
+       &            pulow,pvlow,                                                     &
+       &            pdudt,pdvdt,pdtdt)
+!C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)                                                  &
+       &                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+         pvstr(i)        = pvstr(i)                                                  &
+       &                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+      ENDDO
+      ENDDO
+
+!c     print *,' out lift_noro'
+!c
+      RETURN
+      END
+      subroutine orolift_strato( nlon,nlev                                           &
+       &                 , kgwd, kdx, ktest                                          &
+       &                 , ptsphy                                                    &
+       &                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1                        &
+       &                 , plat                                                      &
+       &                 , pmea, pstd, psig, pgam, pthe,ppic,pval                    &
+!C OUTPUTS                                                                           &
+       &                 , pulow,pvlow                                               &
+       &                 , pvom,pvol,pte )
+
+!C
+!C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
+!C
+!C     PURPOSE.
+!C     --------
+!C this routine computes the physical tendencies of the
+!C prognostic variables u,v  when enhanced vortex stretching
+!C is needed.
+!C
+!C**   INTERFACE.
+!C     ----------
+!C          CALLED FROM *lift_noro
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c nlon----input-I-Total number of horizontal points that get into physics
+!c nlev----input-I-Number of vertical levels
+!c
+!c kgwd- -input-I: Total nb of points where the orography schemes are active
+!c ktest--input-I: Flags to indicate active points
+!c kdx----input-I: Locate the physical location of an active point.
+!c ptsphy--input-R-Time-step (s)
+!c paphm1--input-R: pressure at model 1/2 layer
+!c papm1---input-R: pressure at model layer
+!c pgeom1--input-R: Altitude of layer above ground
+!c ptm1, pum1, pvm1--R-: t, u and v
+!c pmea----input-R-Mean Orography (m)
+!C pstd----input-R-SSO standard deviation (m)
+!c psig----input-R-SSO slope
+!c pgam----input-R-SSO Anisotropy
+!c pthe----input-R-SSO Angle
+!c ppic----input-R-SSO Peacks elevation (m)
+!c pval----input-R-SSO Valleys elevation (m)
+!c plat----input-R-Latitude (degree)
+!c
+!c     ==== outputs ===
+!c pulow, pvlow -output-R: Low-level wind
+!c
+!c pte -----output-R: T tendency
+!c pvom-----output-R: U tendency
+!c pvol-----output-R: V tendency
+!c
+!c
+!c Implicit Arguments:
+!c ===================
+!c
+!c klon-common-I: Number of points seen by the physics
+!c klev-common-I: Number of vertical layers
+!c
+
+!C     ----------
+!C
+!C     AUTHOR.
+!C     -------
+!C     F.LOTT  LMD 22/11/95
+!C
+       USE dimphy
+       implicit none
+!C
+!C
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+!C-----------------------------------------------------------------------
+!C
+!C*       0.1   ARGUMENTS
+!C              ---------
+!C
+!C
+      integer nlon,nlev,kgwd
+      real ptsphy
+      real  pte(nlon,nlev),                                                          &
+       &      pvol(nlon,nlev),                                                       &
+       &      pvom(nlon,nlev),                                                       &
+       &      pulow(nlon),                                                           &
+       &      pvlow(nlon)
+      real  pum1(nlon,nlev),                                                         &
+       &      pvm1(nlon,nlev),                                                       &
+       &      ptm1(nlon,nlev),                                                       &
+       &      plat(nlon),pmea(nlon),                                                 &
+       &      pstd(nlon),psig(nlon),pgam(nlon),                                      &
+       &      pthe(nlon),ppic(nlon),pval(nlon),                                      &
+       &      pgeom1(nlon,nlev),                                                     &
+       &      papm1(nlon,nlev),                                                      &
+       &      paphm1(nlon,nlev+1)
+!C
+      INTEGER  KDX(NLON),KTEST(NLON)
+!C-----------------------------------------------------------------------
+!C
+!C*       0.2   local arrays
+
+      integer jl,ilevh,jk
+      real zhgeo,zdelp,zslow,zsqua,zscav,zbet
+!C              ------------
+      integer  iknub(klon),                                                          &
+       &         iknul(klon)
+      logical ll1(klon,klev+1)
+!C
+      real   ztau(klon,klev+1),                                                      &
+       &       ztav(klon,klev+1),                                                    &
+       &       zrho(klon,klev+1)
+      real   zdudt(klon),                                                            &
+       &       zdvdt(klon)
+      real zhcrit(klon,klev)
+
+      logical lifthigh
+      real zcons1,ztmst
+      CHARACTER (LEN=20) :: modname='orolift_strato'
+      CHARACTER (LEN=80) :: abort_message
+
+
+!C-----------------------------------------------------------------------
+!C
+!C*         1.1  initialisations
+!C               ---------------
+
+      lifthigh=.false.
+
+      if(nlon.ne.klon.or.nlev.ne.klev) then
+        abort_message = 'pb dimension'
+        CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+      zcons1=1./rd
+      ztmst=ptsphy
+!C
+      do 1001 jl=kidia,kfdia
+      zrho(jl,klev+1)  =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      iknub(JL)   =klev
+      iknul(JL)   =klev
+      ilevh=klev/3
+      ll1(jl,klev+1)=.false.
+      do 1000 jk=1,klev
+      pvom(jl,jk)=0.0
+      pvol(jl,jk)=0.0
+      pte (jl,jk)=0.0
+ 1000 continue
+ 1001 continue
+
+!C
+!C*         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
+!C*                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
+!C*                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
+!C
+!C
+!C
+      do 2006 jk=klev,1,-1
+      do 2007 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zhcrit(jl,jk)=amax1(ppic(jl)-pval(jl),100.)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        iknub(jl)=jk
+      endif
+      endif
+ 2007 continue
+ 2006 continue
+!C
+
+      do 2010 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      iknub(jl)=max(iknub(jl),klev/2)
+      iknul(jl)=max(iknul(jl),2*klev/3)
+      if(iknub(jl).gt.nktopg) iknub(jl)=nktopg
+      if(iknub(jl).eq.nktopg) iknul(jl)=klev
+      if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1
+      endif
+ 2010 continue
+
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+        zrho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+  222 continue
+  223 continue
+!c     print *,'  dans orolift: 223'
+
+!C********************************************************************
+!C
+!c*     define low level flow
+!C      -------------------
+      do 2115 jk=klev,1,-1
+      do 2116 jl=kidia,kfdia
+      if(ktest(jl).eq.1) THEN
+      if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then
+        pulow(JL)=pulow(JL)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(JL)=pvlow(JL)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        zrho(JL,klev+1)=zrho(JL,klev+1)                                              &
+       &                 +zrho(JL,JK)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      endif
+      endif
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      pulow(JL)=pulow(JL)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      pvlow(JL)=pvlow(JL)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      zrho(JL,klev+1)=zrho(Jl,klev+1)                                                &
+       &               /(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      endif
+ 2110 continue
+
+
+200   continue
+
+!C***********************************************************
+!C
+!C*         3.      COMPUTE MOUNTAIN LIFT
+!C
+  300 continue
+!C
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+       ztau(jl,klev+1)= - gklift*zrho(jl,klev+1)*2.*romega*                          &
+!c    *                 (2*pstd(jl)+pmea(jl))*                                       &
+       &                 2*pstd(jl)*                                                 &
+       &                 sin(rpi/180.*plat(jl))*pvlow(jl)
+       ztav(jl,klev+1)=   gklift*zrho(jl,klev+1)*2.*romega*                          &
+!c    *                 (2*pstd(jl)+pmea(jl))*                                       &
+       &                 2*pstd(jl)*                                                 &
+       &                 sin(rpi/180.*plat(jl))*pulow(jl)
+      else
+       ztau(jl,klev+1)=0.0
+       ztav(jl,klev+1)=0.0
+      endif
+301   continue
+
+!C
+!C*         4.      COMPUTE LIFT PROFILE         
+!C*                 --------------------   
+!C
+
+  400 continue
+
+      do 401 jk=1,klev
+      do 401 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      ztau(jl,jk)=ztau(jl,klev+1)*paphm1(jl,jk)/paphm1(jl,klev+1)
+      ztav(jl,jk)=ztav(jl,klev+1)*paphm1(jl,jk)/paphm1(jl,klev+1)
+      else
+      ztau(jl,jk)=0.0
+      ztav(jl,jk)=0.0
+      endif
+401   continue
+!C
+!C
+!C*         5.      COMPUTE TENDENCIES.
+!C*                 -------------------
+      if(lifthigh)then
+!C
+  500 continue
+!C
+!C  EXPLICIT SOLUTION AT ALL LEVELS
+!C
+      do 524 jk=1,klev
+      do 523 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+      zdudt(jl)=-rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp
+      zdvdt(jl)=-rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp
+      endif  
+  523 continue
+  524 continue
+!C
+!C  PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
+!C
+      do 530 jk=1,klev
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+        zslow=sqrt(pulow(jl)**2+pvlow(jl)**2)
+        zsqua=amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2),gvsec)
+        zscav=-zdudt(jl)*pvm1(jl,jk)+zdvdt(jl)*pum1(jl,jk)
+        if(zsqua.gt.gvsec)then
+          pvom(jl,jk)=-zscav*pvm1(jl,jk)/zsqua**2
+          pvol(jl,jk)= zscav*pum1(jl,jk)/zsqua**2
+        else
+          pvom(jl,jk)=0.0
+          pvol(jl,jk)=0.0      
+        endif  
+        zsqua=sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2)               
+        if(zsqua.lt.zslow)then
+          pvom(jl,jk)=zsqua/zslow*pvom(jl,jk)
+          pvol(jl,jk)=zsqua/zslow*pvol(jl,jk)
+        endif 
+
+      endif  
+530   continue
+!C
+!C  6.  LOW LEVEL LIFT, SEMI IMPLICIT:
+!C  ----------------------------------
+
+      else
+
+        do 601 jl=kidia,kfdia
+        if(ktest(jl).eq.1) then
+          do jk=klev,iknub(jl),-1
+          zbet=gklift*2.*romega*sin(rpi/180.*plat(jl))*ztmst*                        &
+       &        (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,  jk))/                            &
+       &        (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,klev))
+          zdudt(jl)=-pum1(jl,jk)/ztmst/(1+zbet**2)
+          zdvdt(jl)=-pvm1(jl,jk)/ztmst/(1+zbet**2)
+          pvom(jl,jk)= zbet**2*zdudt(jl) - zbet   *zdvdt(jl)
+          pvol(jl,jk)= zbet   *zdudt(jl) + zbet**2*zdvdt(jl)    
+          enddo
+        endif
+ 601    continue
+
+      endif
+
+!c     print *,' out orolift'
+
+      return
+      end
+      SUBROUTINE SUGWD_strato(NLON,NLEV,paprs,pplay)
+!C     
+!C
+!C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
+!C
+!C     PURPOSE.
+!C     --------
+!C           INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
+!C           GRAVITY WAVE DRAG PARAMETRIZATION.
+!C    VERY IMPORTANT:
+!C    ______________
+!C           THIS ROUTINE SET_UP THE "TUNABLE PARAMETERS" OF THE
+!C           VARIOUS SSO SCHEMES
+!C
+!C**   INTERFACE.
+!C     ----------
+!C        CALL *SUGWD* FROM *SUPHEC*
+!C              -----        ------
+!C
+!C        EXPLICIT ARGUMENTS :
+!C        --------------------
+!C        PAPRS,PPLAY : Pressure at semi and full model levels
+!C        NLEV        : number of model levels
+!c        NLON        : number of points treated in the physics
+!C
+!C        IMPLICIT ARGUMENTS :
+!C        --------------------
+!C        COMMON YOEGWD
+!C-GFRCRIT-R:  Critical Non-dimensional mountain Height
+!C             (HNC in (1),    LOTT 1999)
+!C-GKWAKE--R:  Bluff-body drag coefficient for low level wake
+!C             (Cd in (2),     LOTT 1999)
+!C-GRCRIT--R:  Critical Richardson Number 
+!C             (Ric, End of first column p791 of LOTT 1999) 
+!C-GKDRAG--R:  Gravity wave drag coefficient
+!C             (G in (3),      LOTT 1999)
+!C-GKLIFT--R:  Mountain Lift coefficient
+!C             (Cl in (4),     LOTT 1999)
+!C-GHMAX---R:  Not used
+!C-GRAHILO-R:  Set-up the trapped waves fraction
+!C             (Beta , End of first column,  LOTT 1999)
+!C
+!C-GSIGCR--R:  Security value for blocked flow depth
+!C-NKTOPG--I:  Security value for blocked flow level
+!C-nstra----I:  An estimate to qualify the upper levels of
+!C             the model where one wants to impose strees
+!C             profiles
+!C-GSSECC--R:  Security min value for low-level B-V frequency
+!C-GTSEC---R:  Security min value for anisotropy and GW stress.
+!C-GVSEC---R:  Security min value for ulow
+!C         
+!C
+!C     METHOD.
+!C     -------
+!C        SEE DOCUMENTATION
+!C
+!C     EXTERNALS.
+!C     ----------
+!C        NONE
+!C
+!C     REFERENCE.
+!C     ----------
+!C     Lott, 1999: Alleviation of stationary biases in a GCM through...
+!C                 Monthly Weather Review, 127, pp 788-801.
+!C
+!C     AUTHOR.
+!C     -------
+!C        FRANCOIS LOTT        *LMD*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 90-01-01 (MARTIN MILLER, ECMWF)
+!C        LAST:  99-07-09     (FRANCOIS LOTT,LMD)
+!C     ------------------------------------------------------------------
+      USE dimphy
+      USE mod_phys_lmdz_para
+      USE mod_grid_phy_lmdz
+      IMPLICIT NONE
+!C
+!C     -----------------------------------------------------------------
+#include "YOEGWD.h"
+!C      ----------------------------------------------------------------
+!C
+!C  ARGUMENTS
+      integer nlon,nlev
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+!C
+      INTEGER JK
+      REAL ZPR,ZTOP,ZSIGT,ZPM1R
+      REAL :: pplay_glo(klon_glo,nlev)
+      REAL :: paprs_glo(klon_glo,nlev+1)
+
+!C
+!C*       1.    SET THE VALUES OF THE PARAMETERS
+!C              --------------------------------
+!C
+ 100  CONTINUE
+!C
+      PRINT *,' DANS SUGWD NLEV=',NLEV
+      GHMAX=10000.
+!C
+      ZPR=100000.
+      ZTOP=0.001 
+      ZSIGT=0.94
+!cold  ZPR=80000.
+!cold  ZSIGT=0.85
+!C
+      CALL gather(pplay,pplay_glo)
+      CALL bcast(pplay_glo)
+      CALL gather(paprs,paprs_glo)
+      CALL bcast(paprs_glo)
+
+      DO 110 JK=1,NLEV
+      ZPM1R=pplay_glo(klon_glo/2+1,jk)/paprs_glo(klon_glo/2+1,1) 
+      IF(ZPM1R.GE.ZSIGT)THEN
+         nktopg=JK
+      ENDIF
+      ZPM1R=pplay_glo(klon_glo/2+1,jk)/paprs_glo(klon_glo/2+1,1) 
+      IF(ZPM1R.GE.ZTOP)THEN
+         nstra=JK
+      ENDIF
+  110 CONTINUE
+!c
+!c  inversion car dans orodrag on compte les niveaux a l'envers
+      nktopg=nlev-nktopg+1
+      nstra=nlev-nstra
+      print *,' DANS SUGWD nktopg=', nktopg
+      print *,' DANS SUGWD nstra=', nstra
+!C
+      GSIGCR=0.80
+!C
+      GKDRAG=0.1875
+      GRAHILO=0.1   
+      GRCRIT=1.00 
+      GFRCRIT=1.00
+      GKWAKE=0.50
+!C
+      GKLIFT=0.25
+      GVCRIT =0.1
+
+      WRITE(UNIT=6,FMT='('' *** SSO essential constants ***'')')
+      WRITE(UNIT=6,FMT='('' *** SPECIFIED IN SUGWD ***'')')
+      WRITE(UNIT=6,FMT='('' Gravity wave ct '',E13.7,'' '')')GKDRAG
+      WRITE(UNIT=6,FMT='('' Trapped/total wave dag '',E13.7,'' '')')                 &
+       &      GRAHILO
+      WRITE(UNIT=6,FMT='('' Critical Richardson   = '',E13.7,'' '')')                &
+       &                  GRCRIT
+      WRITE(UNIT=6,FMT='('' Critical Froude'',e13.7)') GFRCRIT
+      WRITE(UNIT=6,FMT='('' Low level Wake bluff cte'',e13.7)') GKWAKE
+      WRITE(UNIT=6,FMT='('' Low level lift  cte'',e13.7)') GKLIFT
+
+!C
+!C
+!C      ----------------------------------------------------------------
+!C
+!C*       2.    SET VALUES OF SECURITY PARAMETERS
+!C              ---------------------------------
+!C
+ 200  CONTINUE
+!C
+      GVSEC=0.10
+      GSSEC=0.0001
+!C
+      GTSEC=0.00001
+!C
+      RETURN
+      END
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi_strato_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi_strato_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/orografi_strato_mod.F90	(revision 17)
@@ -0,0 +1,2069 @@
+! L. Fita. August 2013
+
+MODULE orografi_strato_mod
+
+  CONTAINS
+
+      SUBROUTINE drag_noro_strato (nlon,nlev,dtime,paprs,pplay,                      &
+       &                   pmea,pstd, psig, pgam, pthe,ppic,pval,                    &
+       &                   kgwd,kdx,ktest,                                           &
+       &                   t, u, v,                                                  &
+       &                   pulow, pvlow, pustr, pvstr,                               &
+       &                   d_t, d_u, d_v)
+!c
+      USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+!c Object: Mountain drag interface. Made necessary because:
+!C 1. in the LMD-GCM Layers are from bottom to top,
+!C    contrary to most European GCM.
+!c 2. the altitude above ground of each model layers
+!c    needs to be known (variable zgeom)
+!c======================================================================
+!c Explicit Arguments:
+!c ==================
+!c nlon----input-I-Total number of horizontal points that get into physics
+!c nlev----input-I-Number of vertical levels
+!c dtime---input-R-Time-step (s)
+!c paprs---input-R-Pressure in semi layers    (Pa)
+!c pplay---input-R-Pressure model-layers      (Pa)
+!c t-------input-R-temperature (K)
+!c u-------input-R-Horizontal wind (m/s)
+!c v-------input-R-Meridional wind (m/s)
+!c pmea----input-R-Mean Orography (m)
+!C pstd----input-R-SSO standard deviation (m)
+!c psig----input-R-SSO slope
+!c pgam----input-R-SSO Anisotropy
+!c pthe----input-R-SSO Angle
+!c ppic----input-R-SSO Peacks elevation (m)
+!c pval----input-R-SSO Valleys elevation (m)
+!c
+!c kgwd- -input-I: Total nb of points where the orography schemes are active
+!c ktest--input-I: Flags to indicate active points
+!c kdx----input-I: Locate the physical location of an active point.
+
+!c pulow, pvlow -output-R: Low-level wind
+!c pustr, pvstr -output-R: Surface stress due to SSO drag      (Pa)
+!c
+!c d_t-----output-R: T increment            
+!c d_u-----output-R: U increment              
+!c d_v-----output-R: V increment              
+!c
+!c Implicit Arguments:
+!c ===================
+!c
+!c iim--common-I: Number of longitude intervals
+!c jjm--common-I: Number of latitude intervals
+!c klon-common-I: Number of points seen by the physics
+!c                (iim+1)*(jjm+1) for instance
+!c klev-common-I: Number of vertical layers
+!c======================================================================
+!c Local Variables:
+!c ================
+!c
+!c zgeom-----R: Altitude of layer above ground
+!c pt, pu, pv --R: t u v from top to bottom
+!c pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom) 
+!c papmf: pressure at model layer (from top to bottom)
+!c papmh: pressure at model 1/2 layer (from top to bottom)
+!c 
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+!c
+!c  ARGUMENTS
+!c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+      REAL pmea(nlon),pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+!c
+      INTEGER i, k, kgwd,  kdx(nlon), ktest(nlon)
+!c
+!c LOCAL VARIABLES:
+!c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+      CHARACTER (LEN=20) :: modname='orografi_strato'
+      CHARACTER (LEN=80) :: abort_message
+!c
+!c INITIALIZE OUTPUT VARIABLES 
+!c
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+!c
+!c PREPARE INPUT VARIABLES FOR ORODRAG (i.e., ORDERED FROM TOP TO BOTTOM)
+!C CALCULATE LAYERS HEIGHT ABOVE GROUND)
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)                                             &
+       &                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0                    &
+       &               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+!c
+!c CALL SSO DRAG ROUTINES        
+!c
+      CALL orodrag_strato(klon,klev,kgwd,kdx,ktest,                                  &
+       &            dtime,                                                           &
+       &            papmh, papmf, zgeom,                                             &
+       &            pt, pu, pv,                                                      &
+       &            pmea, pstd, psig, pgam, pthe, ppic,pval,                         &
+       &            pulow,pvlow,                                                     &
+       &            pdudt,pdvdt,pdtdt)
+!C
+!C COMPUTE INCREMENTS AND STRESS FROM TENDENCIES
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)                                                  &
+       &                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+         pvstr(i)        = pvstr(i)                                                  &
+       &                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+      ENDDO
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE drag_noro_strato
+
+      SUBROUTINE orodrag_strato( nlon,nlev                                           &
+       &                 , kgwd,  kdx, ktest                                         &
+       &                 , ptsphy                                                    &
+       &                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1                        &
+       &                 , pmea, pstd, psig, pgam, pthe, ppic, pval                  &
+!c outputs                                                                           &
+       &                 , pulow,pvlow                                               &
+       &                 , pvom,pvol,pte )
+      
+      USE dimphy
+      IMPLICIT NONE
+!c
+!c
+!c**** *orodrag* - does the SSO drag  parametrization.
+!c
+!c     purpose.
+!c     --------
+!c
+!c     this routine computes the physical tendencies of the
+!c     prognostic variables u,v  and t due to  vertical transports by
+!c     subgridscale orographically excited gravity waves, and to
+!c     low level blocked flow drag.
+!c
+!c**   interface.
+!c     ----------
+!c          called from *drag_noro*.
+!c
+!c          the routine takes its input from the long-term storage:
+!c          u,v,t and p at t-1.
+!c
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c nlon----input-I-Total number of horizontal points that get into physics
+!c nlev----input-I-Number of vertical levels
+!c
+!c kgwd- -input-I: Total nb of points where the orography schemes are active
+!c ktest--input-I: Flags to indicate active points
+!c kdx----input-I: Locate the physical location of an active point.
+!c ptsphy--input-R-Time-step (s)
+!c paphm1--input-R: pressure at model 1/2 layer
+!c papm1---input-R: pressure at model layer
+!c pgeom1--input-R: Altitude of layer above ground
+!c ptm1, pum1, pvm1--R-: t, u and v
+!c pmea----input-R-Mean Orography (m)
+!C pstd----input-R-SSO standard deviation (m)
+!c psig----input-R-SSO slope
+!c pgam----input-R-SSO Anisotropy
+!c pthe----input-R-SSO Angle
+!c ppic----input-R-SSO Peacks elevation (m)
+!c pval----input-R-SSO Valleys elevation (m)
+
+      integer nlon,nlev,kgwd
+      real ptsphy
+
+!c     ==== outputs ===
+!c pulow, pvlow -output-R: Low-level wind
+!c
+!c pte -----output-R: T tendency
+!c pvom-----output-R: U tendency
+!c pvol-----output-R: V tendency
+!c
+!c
+!c Implicit Arguments:
+!c ===================
+!c
+!c klon-common-I: Number of points seen by the physics
+!c klev-common-I: Number of vertical layers
+!c
+!c     method.
+!c     -------
+!c
+!c     externals.
+!c     ----------
+      integer ismin, ismax
+      external ismin, ismax
+!c
+!c     reference.
+!c     ----------
+!c
+!c     author.
+!c     -------
+!c     m.miller + b.ritter   e.c.m.w.f.     15/06/86.
+!c
+!c     f.lott + m. miller    e.c.m.w.f.     22/11/94
+!c-----------------------------------------------------------------------
+!c
+!c
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+!c-----------------------------------------------------------------------
+!c
+!c*       0.1   arguments
+!c              ---------
+!c
+!c
+      real  pte(nlon,nlev),                                                          &
+       &      pvol(nlon,nlev),                                                       &
+       &      pvom(nlon,nlev),                                                       &
+       &      pulow(nlon),                                                           &
+       &      pvlow(nlon)
+      real  pum1(nlon,nlev),                                                         &
+       &      pvm1(nlon,nlev),                                                       &
+       &      ptm1(nlon,nlev),                                                       &
+       &      pmea(nlon),pstd(nlon),psig(nlon),                                      &
+       &      pgam(nlon),pthe(nlon),ppic(nlon),pval(nlon),                           &
+       &      pgeom1(nlon,nlev),                                                     &
+       &      papm1(nlon,nlev),                                                      &
+       &      paphm1(nlon,nlev+1)
+!c
+      integer  kdx(nlon),ktest(nlon)
+!c-----------------------------------------------------------------------
+!c
+!c*       0.2   local arrays
+!c              ------------
+      integer  isect(klon),                                                          &
+       &         icrit(klon),                                                        &
+       &         ikcrith(klon),                                                      &
+       &         ikenvh(klon),                                                       &
+       &         iknu(klon),                                                         &
+       &         iknu2(klon),                                                        &
+       &         ikcrit(klon),                                                       &
+       &         ikhlim(klon)
+!c
+      real   ztau(klon,klev+1),                                                      &
+       &       zstab(klon,klev+1),                                                   &
+       &       zvph(klon,klev+1),                                                    &
+       &       zrho(klon,klev+1),                                                    &
+       &       zri(klon,klev+1),                                                     &
+       &       zpsi(klon,klev+1),                                                    &
+       &       zzdep(klon,klev)
+      real   zdudt(klon),                                                            &
+       &       zdvdt(klon),                                                          &
+       &       zdtdt(klon),                                                          &
+       &       zdedt(klon),                                                          &
+       &       zvidis(klon),                                                         &
+       &       ztfr(klon),                                                           &
+       &       znu(klon),                                                            &
+       &       zd1(klon),                                                            &
+       &       zd2(klon),                                                            &
+       &       zdmod(klon)
+
+
+!c local quantities:
+
+      integer jl,jk,ji
+      real ztmst,zdelp,ztemp,zforc,ztend,rover                
+      real zb,zc,zconb,zabsv,zzd1,ratio,zbet,zust,zvst,zdis
+   
+!c
+!c------------------------------------------------------------------
+!c
+!c*         1.    initialization
+!c                --------------
+!c
+!c        print *,' in orodrag'
+ 100  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.1   computational constants
+!c                -----------------------
+!c
+ 110  continue
+!c
+!c     ztmst=twodt
+!c     if(nstep.eq.nstart) ztmst=0.5*twodt
+      ztmst=ptsphy
+!c     ------------------------------------------------------------------
+!c
+ 120  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.3   check whether row contains point for printing
+!c                ---------------------------------------------
+!c
+ 130  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         2.     precompute basic state variables.
+!c*                ---------- ----- ----- ----------
+!c*                define low level wind, project winds in plane of
+!c*                low level wind, determine sector in which to take
+!c*                the variance and set indicator for critical levels.
+!c
+
+  200 continue
+!c
+!c
+!c
+      call orosetup_strato                                                           &
+       &     ( nlon, nlev , ktest                                                    &
+       &     , ikcrit, ikcrith, icrit, isect, ikhlim, ikenvh,iknu,iknu2              &
+       &     , paphm1, papm1 , pum1   , pvm1 , ptm1 , pgeom1, pstd                   &
+       &     , zrho  , zri   , zstab  , ztau , zvph , zpsi, zzdep                    &
+       &     , pulow, pvlow                                                          &
+       &     , pthe,pgam,pmea,ppic,pval,znu  ,zd1,  zd2,  zdmod )
+
+
+!c
+!c
+!c
+!c***********************************************************
+!c
+!c
+!c*         3.      compute low level stresses using subcritical and
+!c*                 supercritical forms.computes anisotropy coefficient
+!c*                 as measure of orographic twodimensionality.
+!c
+  300 continue
+!c
+      call gwstress_strato                                                           &
+       &    ( nlon  , nlev                                                           &
+       &    , ikcrit, isect, ikhlim, ktest, ikcrith, icrit, ikenvh, iknu             &
+       &    , zrho  , zstab, zvph  , pstd,  psig, pmea, ppic, pval                   &
+       &    , ztfr   , ztau                                                          &
+       &    , pgeom1,pgam,zd1,zd2,zdmod,znu)
+
+!c
+!c
+!c*         4.      compute stress profile including
+!c                  trapped waves, wave breaking,
+!c                  linear decay in stratosphere.
+!c
+  400 continue
+!c
+!c
+
+      call gwprofil_strato                                                           &
+       &       (  nlon , nlev                                                        &
+       &       , kgwd   , kdx  , ktest                                               &
+       &       , ikcrit, ikcrith, icrit  , ikenvh, iknu                              &
+       &       ,iknu2 , paphm1, zrho   , zstab , ztfr   , zvph                       &
+       &       , zri   , ztau                                                        &
+       &       , zdmod , znu    , psig  , pgam , pstd , ppic , pval)
+
+!c
+!c*         5.      Compute tendencies from waves stress profile.
+!c                  Compute low level blocked flow drag. 
+!c*                 --------------------------------------------
+!c
+  500 continue
+
+      
+!c
+!c  explicit solution at all levels for the gravity wave
+!c  implicit solution for the blocked levels
+
+      do 510 jl=kidia,kfdia
+      zvidis(jl)=0.0
+      zdudt(jl)=0.0
+      zdvdt(jl)=0.0
+      zdtdt(jl)=0.0
+  510 continue
+!c
+
+      do 524 jk=1,klev
+!c
+
+!C  WAVE STRESS 
+!C-------------
+!c
+!c
+      do 523 ji=kidia,kfdia
+
+      if(ktest(ji).eq.1) then
+
+      zdelp=paphm1(ji,jk+1)-paphm1(ji,jk)
+      ztemp=-rg*(ztau(ji,jk+1)-ztau(ji,jk))/(zvph(ji,klev+1)*zdelp)
+
+      zdudt(ji)=(pulow(ji)*zd1(ji)-pvlow(ji)*zd2(ji))*ztemp/zdmod(ji)
+      zdvdt(ji)=(pvlow(ji)*zd1(ji)+pulow(ji)*zd2(ji))*ztemp/zdmod(ji)
+!c
+!c Control Overshoots
+!c
+
+      if(jk.ge.nstra)then
+        rover=0.10
+        if(abs(zdudt(ji)).gt.rover*abs(pum1(ji,jk))/ztmst)                           &
+       &    zdudt(ji)=rover*abs(pum1(ji,jk))/ztmst*                                  &
+       &              zdudt(ji)/(abs(zdudt(ji))+1.E-10)
+        if(abs(zdvdt(ji)).gt.rover*abs(pvm1(ji,jk))/ztmst)                           &
+       &    zdvdt(ji)=rover*abs(pvm1(ji,jk))/ztmst*                                  &
+       &              zdvdt(ji)/(abs(zdvdt(ji))+1.E-10)
+      endif 
+
+      rover=0.25
+      zforc=sqrt(zdudt(ji)**2+zdvdt(ji)**2)        
+      ztend=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/ztmst                      
+
+      if(zforc.ge.rover*ztend)then
+        zdudt(ji)=rover*ztend/zforc*zdudt(ji)
+        zdvdt(ji)=rover*ztend/zforc*zdvdt(ji)
+      endif
+!c
+!c BLOCKED FLOW DRAG:
+!C -----------------
+!c
+      if(jk.gt.ikenvh(ji)) then
+         zb=1.0-0.18*pgam(ji)-0.04*pgam(ji)**2
+         zc=0.48*pgam(ji)+0.3*pgam(ji)**2
+         zconb=2.*ztmst*gkwake*psig(ji)/(4.*pstd(ji))
+         zabsv=sqrt(pum1(ji,jk)**2+pvm1(ji,jk)**2)/2.
+         zzd1=zb*cos(zpsi(ji,jk))**2+zc*sin(zpsi(ji,jk))**2
+         ratio=(cos(zpsi(ji,jk))**2+pgam(ji)*sin(zpsi(ji,jk))**2)/                   &
+       &   (pgam(ji)*cos(zpsi(ji,jk))**2+sin(zpsi(ji,jk))**2)
+         zbet=max(0.,2.-1./ratio)*zconb*zzdep(ji,jk)*zzd1*zabsv
+!c
+!c OPPOSED TO THE WIND
+!c
+         zdudt(ji)=-pum1(ji,jk)/ztmst
+         zdvdt(ji)=-pvm1(ji,jk)/ztmst
+!c
+!c PERPENDICULAR TO THE SSO MAIN AXIS:
+!C                            
+!cmod     zdudt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.)
+!cmod *              +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.))
+!cmod *              *cos(pthe(ji)*rpi/180.)/ztmst
+!cmod     zdvdt(ji)=-(pum1(ji,jk)*cos(pthe(ji)*rpi/180.)
+!cmod *              +pvm1(ji,jk)*sin(pthe(ji)*rpi/180.))
+!cmod *              *sin(pthe(ji)*rpi/180.)/ztmst
+!C
+         zdudt(ji)=zdudt(ji)*(zbet/(1.+zbet))
+         zdvdt(ji)=zdvdt(ji)*(zbet/(1.+zbet))
+      end if
+      pvom(ji,jk)=zdudt(ji)
+      pvol(ji,jk)=zdvdt(ji)
+      zust=pum1(ji,jk)+ztmst*zdudt(ji)
+      zvst=pvm1(ji,jk)+ztmst*zdvdt(ji)
+      zdis=0.5*(pum1(ji,jk)**2+pvm1(ji,jk)**2-zust**2-zvst**2)
+      zdedt(ji)=zdis/ztmst
+      zvidis(ji)=zvidis(ji)+zdis*zdelp
+      zdtdt(ji)=zdedt(ji)/rcpd
+!c
+!c  NO TENDENCIES ON TEMPERATURE .....
+!c
+!c  Instead of, pte(ji,jk)=zdtdt(ji), due to mechanical dissipation
+!c
+      pte(ji,jk)=0.0
+
+      endif
+
+  523 continue
+  524 continue
+!c
+!c
+  501 continue
+
+      return
+      end SUBROUTINE orodrag_strato
+
+      SUBROUTINE orosetup_strato                                                     &
+       &         ( nlon   , nlev  , ktest                                            &
+       &         , kkcrit, kkcrith, kcrit, ksect , kkhlim                            &
+       &         , kkenvh, kknu  , kknu2                                             &
+       &         , paphm1, papm1 , pum1   , pvm1 , ptm1  , pgeom1, pstd              &
+       &         , prho  , pri   , pstab  , ptau , pvph  ,ppsi, pzdep                &
+       &         , pulow , pvlow                                                     &
+       &         , ptheta, pgam, pmea, ppic, pval                                    &
+       &         , pnu  ,  pd1  ,  pd2  ,pdmod  )
+!C
+!c**** *gwsetup*
+!c
+!c     purpose.
+!c     --------
+!c     SET-UP THE ESSENTIAL PARAMETERS OF THE SSO DRAG SCHEME:
+!C     DEPTH OF LOW WBLOCKED LAYER, LOW-LEVEL FLOW, BACKGROUND
+!C     STRATIFICATION.....
+!c
+!c**   interface.
+!c     ----------
+!c          from *orodrag*
+!c
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c 
+!c nlon----input-I-Total number of horizontal points that get into physics
+!c nlev----input-I-Number of vertical levels
+!c ktest--input-I: Flags to indicate active points
+!c
+!c ptsphy--input-R-Time-step (s)
+!c paphm1--input-R: pressure at model 1/2 layer
+!c papm1---input-R: pressure at model layer
+!c pgeom1--input-R: Altitude of layer above ground
+!c ptm1, pum1, pvm1--R-: t, u and v
+!c pmea----input-R-Mean Orography (m)
+!C pstd----input-R-SSO standard deviation (m)
+!c psig----input-R-SSO slope
+!c pgam----input-R-SSO Anisotropy
+!c pthe----input-R-SSO Angle
+!c ppic----input-R-SSO Peacks elevation (m)
+!c pval----input-R-SSO Valleys elevation (m)
+
+!c     ==== outputs ===
+!c pulow, pvlow -output-R: Low-level wind
+!c kkcrit----I-: Security value for top of low level flow
+!c kcrit-----I-: Critical level 
+!c ksect-----I-: Not used
+!c kkhlim----I-: Not used
+!c kkenvh----I-: Top of blocked flow layer
+!c kknu------I-: Layer that sees mountain peacks
+!c kknu2-----I-: Layer that sees mountain peacks above mountain mean
+!c kknub-----I-: Layer that sees mountain mean above valleys
+!c prho------R-: Density at 1/2 layers
+!c pri-------R-: Background Richardson Number, Wind shear measured along GW stress
+!c pstab-----R-: Brunt-Vaisala freq. at 1/2 layers
+!c pvph------R-: Wind in  plan of GW stress, Half levels.
+!c ppsi------R-: Angle between low level wind and SS0 main axis.
+!c pd1-------R-| Compared the ratio of the stress
+!c pd2-------R-| that is along the wind to that Normal to it.
+!c               pdi define the plane of low level stress
+!c               compared to the low level wind.
+!c see p. 108 Lott & Miller (1997).                      
+!c pdmod-----R-: Norme of pdi
+
+!c     === local arrays ===
+!c
+!c zvpf------R-: Wind projected in the plan of the low-level stress.
+
+!c     ==== outputs ===
+!c
+!c        implicit arguments :   none
+!c        --------------------
+!c
+!c     method.
+!c     -------
+!c
+!c
+!c     externals.
+!c     ----------
+!c
+!c
+!c     reference.
+!c     ----------
+!c
+!c        see ecmwf research department documentation of the "i.f.s."
+!c
+!c     author.
+!c     -------
+!c
+!c     modifications.
+!c     --------------
+!c     f.lott  for the new-gwdrag scheme november 1993
+!c
+!c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+!c
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+!c-----------------------------------------------------------------------
+!c
+!c*       0.1   arguments
+!c              ---------
+!c
+      integer nlon,nlev
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon),                    &
+       &        kkhlim(nlon),ktest(nlon),kkenvh(nlon)
+
+!c
+      real paphm1(nlon,klev+1),papm1(nlon,klev),pum1(nlon,klev),                     &
+       &     pvm1(nlon,klev),ptm1(nlon,klev),pgeom1(nlon,klev),                      &
+       &     prho(nlon,klev+1),pri(nlon,klev+1),pstab(nlon,klev+1),                  &
+       &     ptau(nlon,klev+1),pvph(nlon,klev+1),ppsi(nlon,klev+1),                  &
+       &     pzdep(nlon,klev)
+       real pulow(nlon),pvlow(nlon),ptheta(nlon),pgam(nlon),pnu(nlon),               &
+       &     pd1(nlon),pd2(nlon),pdmod(nlon)
+      real pstd(nlon),pmea(nlon),ppic(nlon),pval(nlon)
+!c
+!c-----------------------------------------------------------------------
+!c
+!c*       0.2   local arrays
+!c              ------------
+!c
+!c
+      integer ilevh ,jl,jk
+      real zcons1,zcons2,zhgeo,zu,zphi
+      real zvt1,zvt2,zdwind,zwind,zdelp
+      real zstabm,zstabp,zrhom,zrhop
+      logical lo 
+      logical ll1(klon,klev+1)
+      integer kknu(klon),kknu2(klon),kknub(klon),kknul(klon),                        &
+       &        kentp(klon),ncount(klon)  
+!c
+      real zhcrit(klon,klev),zvpf(klon,klev),                                        &
+       &     zdp(klon,klev)
+      real znorm(klon),zb(klon),zc(klon),                                            &
+       &      zulow(klon),zvlow(klon),znup(klon),znum(klon)
+!c       
+!c     ------------------------------------------------------------------
+!c
+!c*         1.    initialization
+!c                --------------
+!c
+!c       PRINT *,' in orosetup'
+ 100  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         1.1   computational constants
+!c                -----------------------
+!c
+ 110  continue
+!c
+      ilevh =klev/3
+!c
+      zcons1=1./rd
+      zcons2=rg**2/rcpd
+!c
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         2.
+!c                --------------
+!c
+ 200  continue
+!c
+!c     ------------------------------------------------------------------
+!c
+!c*         2.1     define low level wind, project winds in plane of
+!c*                 low level wind, determine sector in which to take
+!c*                 the variance and set indicator for critical levels.
+!c
+!c
+!c
+      do 2001 jl=kidia,kfdia
+      kknu(jl)    =klev
+      kknu2(jl)   =klev
+      kknub(jl)   =klev
+      kknul(jl)   =klev
+      pgam(jl) =max(pgam(jl),gtsec)
+      ll1(jl,klev+1)=.false.
+ 2001 continue
+!c
+!c Ajouter une initialisation (L. Li, le 23fev99):
+!c
+      do jk=klev,ilevh,-1
+      do jl=kidia,kfdia
+      ll1(jl,jk)= .false.
+      ENDDO
+      ENDDO
+!c
+!c*      define top of low level flow
+!c       ----------------------------
+      do 2002 jk=klev,ilevh,-1
+      do 2003 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      lo=(paphm1(jl,jk)/paphm1(jl,klev+1)).ge.gsigcr
+      if(lo) then
+        kkcrit(jl)=jk
+      endif
+      zhcrit(jl,jk)=ppic(jl)-pval(jl)           
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu(jl)=ilevh
+      endif
+ 2003 continue
+ 2002 continue
+      do 2004 jk=klev,ilevh,-1
+      do 2005 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zhcrit(jl,jk)=ppic(jl)-pmea(jl)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknu2(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknu2(jl)=ilevh
+      endif
+ 2005 continue
+ 2004 continue
+      do 2006 jk=klev,ilevh,-1
+      do 2007 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zhcrit(jl,jk)=amin1(ppic(jl)-pmea(jl),pmea(jl)-pval(jl))
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        kknub(jl)=jk
+      endif
+      if(.not.ll1(jl,ilevh))kknub(jl)=ilevh
+      endif
+ 2007 continue
+ 2006 continue
+!c
+      do 2010 jl=kidia,kfdia  
+      if(ktest(jl).eq.1) then
+      kknu(jl)=min(kknu(jl),nktopg)
+      kknu2(jl)=min(kknu2(jl),nktopg)
+      kknub(jl)=min(kknub(jl),nktopg)
+      kknul(jl)=klev
+      endif
+ 2010 continue      
+!c
+ 210  continue
+!c
+!cc*     initialize various arrays
+!c
+      do 2107 jl=kidia,kfdia
+      prho(jl,klev+1)  =0.0
+!cym correction en attendant mieux
+      prho(jl,1)  =0.0      
+      pstab(jl,klev+1) =0.0
+      pstab(jl,1)      =0.0
+      pri(jl,klev+1)   =9999.0
+      ppsi(jl,klev+1)  =0.0
+      pri(jl,1)        =0.0
+      pvph(jl,1)       =0.0
+      pvph(jl,klev+1)  =0.0
+!cym correction en attendant mieux
+!cym      pvph(jl,klev)    =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      zulow(jl)        =0.0
+      zvlow(jl)        =0.0
+      kkcrith(jl)      =klev
+      kkenvh(jl)       =klev
+      kentp(jl)        =klev
+      kcrit(jl)        =1
+      ncount(jl)       =0
+      ll1(jl,klev+1)   =.false.
+ 2107 continue
+!c
+!c*     define flow density and stratification (rho and N2)
+!c      at semi layers.
+!c      -------------------------------------------------------
+!c
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        prho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+        pstab(jl,jk)=2.*zcons2/(ptm1(jl,jk)+ptm1(jl,jk-1))*                          &
+       &  (1.-rcpd*prho(jl,jk)*(ptm1(jl,jk)-ptm1(jl,jk-1))/zdp(jl,jk))
+        pstab(jl,jk)=max(pstab(jl,jk),gssec)
+      endif
+  222 continue
+  223 continue
+!c
+!c********************************************************************
+!c
+!c*     define Low level flow (between ground and peacks-valleys)
+!c      ---------------------------------------------------------
+      do 2115 jk=klev,ilevh,-1
+      do 2116 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+      if(jk.ge.kknu2(jl).and.jk.le.kknul(jl)) then
+        pulow(jl)=pulow(jl)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(jl)=pvlow(jl)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pstab(jl,klev+1)=pstab(jl,klev+1)                                            &
+       &                   +pstab(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        prho(jl,klev+1)=prho(jl,klev+1)                                              &
+       &                   +prho(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      end if
+      endif
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+      pulow(jl)=pulow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      pvlow(jl)=pvlow(jl)/(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      znorm(jl)=max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+      pvph(jl,klev+1)=znorm(jl)
+      pstab(jl,klev+1)=pstab(jl,klev+1)                                              &
+       &                /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      prho(jl,klev+1)=prho(jl,klev+1)                                                &
+       &                /(paphm1(jl,kknul(jl)+1)-paphm1(jl,kknu2(jl)))
+      endif
+ 2110 continue
+
+!c
+!c*******  setup orography orientation relative to the low level
+!C       wind and define parameters of the Anisotropic wave stress.
+!c
+      do 2112 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        lo=(pulow(jl).lt.gvsec).and.(pulow(jl).ge.-gvsec)
+        if(lo) then
+          zu=pulow(jl)+2.*gvsec
+        else
+          zu=pulow(jl)
+        endif
+        zphi=atan(pvlow(jl)/zu)
+        ppsi(jl,klev+1)=ptheta(jl)*rpi/180.-zphi
+        zb(jl)=1.-0.18*pgam(jl)-0.04*pgam(jl)**2
+        zc(jl)=0.48*pgam(jl)+0.3*pgam(jl)**2
+        pd1(jl)=zb(jl)-(zb(jl)-zc(jl))*(sin(ppsi(jl,klev+1))**2)
+        pd2(jl)=(zb(jl)-zc(jl))*sin(ppsi(jl,klev+1))                                 &
+       &                         *cos(ppsi(jl,klev+1))
+        pdmod(jl)=sqrt(pd1(jl)**2+pd2(jl)**2)
+      endif
+ 2112 continue
+!c
+!c  ************ projet flow in plane of lowlevel stress *************
+!C  ************ Find critical levels...                 *************
+!c
+      do 213 jk=1,klev
+      do 212 jl=kidia,kfdia
+      if(ktest(jl).eq.1)  then
+        zvt1       =pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk)
+        zvt2       =-pvlow(jl)*pum1(jl,jk)+pulow(jl)*pvm1(jl,jk)
+        zvpf(jl,jk)=(zvt1*pd1(jl)+zvt2*pd2(jl))/(znorm(jl)*pdmod(jl))
+      endif
+      ptau(jl,jk)  =0.0
+      pzdep(jl,jk) =0.0
+      ppsi(jl,jk)  =0.0
+      ll1(jl,jk)   =.false.
+  212 continue
+  213 continue
+      do 215 jk=2,klev
+      do 214 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdp(jl,jk)=papm1(jl,jk)-papm1(jl,jk-1)
+        pvph(jl,jk)=((paphm1(jl,jk)-papm1(jl,jk-1))*zvpf(jl,jk)+                     &
+       &            (papm1(jl,jk)-paphm1(jl,jk))*zvpf(jl,jk-1))                      &
+       &            /zdp(jl,jk)
+        if(pvph(jl,jk).lt.gvsec) then
+          pvph(jl,jk)=gvsec
+          kcrit(jl)=jk
+        endif
+      endif
+  214 continue
+  215 continue
+!c
+!c*         2.3     mean flow richardson number.
+!c
+  230 continue
+!c
+      do 232 jk=2,klev
+      do 231 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+        zdwind=max(abs(zvpf(jl,jk)-zvpf(jl,jk-1)),gvsec)
+        pri(jl,jk)=pstab(jl,jk)*(zdp(jl,jk)                                          &
+       &          /(rg*prho(jl,jk)*zdwind))**2
+        pri(jl,jk)=max(pri(jl,jk),grcrit)
+      endif
+  231 continue
+  232 continue
+  
+!c
+!c
+!c*      define top of 'envelope' layer
+!c       ----------------------------
+
+      do 233 jl=kidia,kfdia
+      pnu (jl)=0.0
+      znum(jl)=0.0
+ 233  continue
+      
+      do 234 jk=2,klev-1
+      do 234 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+       
+      if (jk.ge.kknu2(jl)) then
+          
+            znum(jl)=pnu(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/                     &
+       &            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            pnu(jl) = pnu(jl) + (zdelp/rg)*                                          &
+       &            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.gfrcrit).and.(pnu(jl).gt.gfrcrit)                        &
+       &                          .and.(kkenvh(jl).eq.klev))                         &
+       &      kkenvh(jl)=jk
+      endif    
+
+      endif
+      
+ 234  continue
+      
+!c  calculation of a dynamical mixing height for when the waves
+!C  BREAK AT LOW LEVEL: The drag will be repartited over
+!C  a depths that depends on waves vertical wavelength,
+!C  not just between two adjacent model layers.
+!c  of gravity waves:
+
+      do 235 jl=kidia,kfdia
+      znup(jl)=0.0
+      znum(jl)=0.0
+ 235  continue
+
+      do 236 jk=klev-1,2,-1
+      do 236 jl=kidia,kfdia
+      
+      if(ktest(jl).eq.1) then
+
+            znum(jl)=znup(jl)
+            zwind=(pulow(jl)*pum1(jl,jk)+pvlow(jl)*pvm1(jl,jk))/                     &
+       &            max(sqrt(pulow(jl)**2+pvlow(jl)**2),gvsec)
+            zwind=max(sqrt(zwind**2),gvsec)
+            zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+            zstabm=sqrt(max(pstab(jl,jk  ),gssec))
+            zstabp=sqrt(max(pstab(jl,jk+1),gssec))
+            zrhom=prho(jl,jk  )
+            zrhop=prho(jl,jk+1)
+            znup(jl) = znup(jl) + (zdelp/rg)*                                        &
+       &            ((zstabp/zrhop+zstabm/zrhom)/2.)/zwind     
+            if((znum(jl).le.rpi/4.).and.(znup(jl).gt.rpi/4.)                         &
+       &                          .and.(kkcrith(jl).eq.klev))                        &
+       &      kkcrith(jl)=jk
+      endif
+      
+ 236  continue
+ 
+      do 237 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      kkcrith(jl)=max0(kkcrith(jl),ilevh*2)
+      kkcrith(jl)=max0(kkcrith(jl),kknu(jl))
+      if(kcrit(jl).ge.kkcrith(jl))kcrit(jl)=1
+      endif
+ 237  continue         
+!c
+!c     directional info for flow blocking ************************* 
+!c
+      do 251 jk=1,klev    
+      do 252 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      lo=(pum1(jl,jk).lt.gvsec).and.(pum1(jl,jk).ge.-gvsec)
+      if(lo) then
+        zu=pum1(jl,jk)+2.*gvsec
+      else
+        zu=pum1(jl,jk)
+      endif
+       zphi=atan(pvm1(jl,jk)/zu)
+       ppsi(jl,jk)=ptheta(jl)*rpi/180.-zphi
+      endif
+ 252  continue
+ 251  continue
+
+!c      forms the vertical 'leakiness' **************************
+
+      do 254  jk=ilevh,klev
+      do 253  jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      pzdep(jl,jk)=0
+      if(jk.ge.kkenvh(jl).and.kkenvh(jl).ne.klev) then
+        pzdep(jl,jk)=(pgeom1(jl,kkenvh(jl)  )-pgeom1(jl,  jk))/                      &
+       &               (pgeom1(jl,kkenvh(jl)  )-pgeom1(jl,klev))
+      end if
+      endif
+ 253  continue
+ 254  continue
+
+      return
+      end SUBROUTINE orosetup_strato
+
+      SUBROUTINE gwstress_strato                                                     &
+       &         (  nlon  , nlev                                                     &
+       &         , kkcrit, ksect, kkhlim, ktest, kkcrith, kcrit, kkenvh              &
+       &         , kknu                                                              &
+       &         , prho  , pstab , pvph  , pstd, psig                                &
+       &         , pmea , ppic , pval  , ptfr  , ptau                                &
+       &         , pgeom1 , pgamma , pd1  , pd2   , pdmod , pnu )
+!c
+!c**** *gwstress*
+!c
+!c     purpose.
+!c     --------
+!c  Compute the surface stress due to Gravity Waves, according
+!c  to the Phillips (1979) theory of 3-D flow above 
+!c  anisotropic elliptic ridges.
+
+!C  The stress is reduced two account for cut-off flow over
+!C  hill.  The flow only see that part of the ridge located
+!c  above the blocked layer (see zeff).
+!c
+!c**   interface.
+!c     ----------
+!c     call *gwstress*  from *gwdrag*
+!c
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c     ==== outputs ===
+!c
+!c        implicit arguments :   none
+!c        --------------------
+!c
+!c     method.
+!c     -------
+!c
+!c
+!c     externals.
+!c     ----------
+!c
+!c
+!c     reference.
+!c     ----------
+!c
+!c   LOTT and MILLER (1997)  &  LOTT (1999)
+!c
+!c     author.
+!c     -------
+!c
+!c     modifications.
+!c     --------------
+!c     f. lott put the new gwd on ifs      22/11/93
+!c
+!c-----------------------------------------------------------------------
+      USE dimphy
+      implicit none
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+!c-----------------------------------------------------------------------
+!c
+!c*       0.1   arguments
+!c              ---------
+!c
+      integer nlon,nlev
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon),ksect(nlon),                    &
+       &        kkhlim(nlon),ktest(nlon),kkenvh(nlon),kknu(nlon)
+!c
+      real prho(nlon,nlev+1),pstab(nlon,nlev+1),ptau(nlon,nlev+1),                   &
+       &     pvph(nlon,nlev+1),ptfr(nlon),                                           &
+       &     pgeom1(nlon,nlev),pstd(nlon)
+!c
+      real pd1(nlon),pd2(nlon),pnu(nlon),psig(nlon),pgamma(nlon)
+      real pmea(nlon),ppic(nlon),pval(nlon)
+      real pdmod(nlon)
+!c
+!c-----------------------------------------------------------------------
+!c
+!c*       0.2   local arrays
+!c              ------------
+!c  zeff--real: effective height seen by the flow when there is blocking
+
+      integer jl
+      real zeff  
+!c
+!c-----------------------------------------------------------------------
+!c
+!c*       0.3   functions
+!c              ---------
+!c     ------------------------------------------------------------------
+!c
+!c*         1.    initialization
+!c                --------------
+!c
+!c      PRINT *,' in gwstress'
+ 100  continue
+!c
+!c*         3.1     gravity wave stress.
+!c
+  300 continue
+!c
+!c
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      
+!c  effective mountain height above the blocked flow
+  
+         zeff=ppic(jl)-pval(jl)
+         if(kkenvh(jl).lt.klev)then
+         zeff=amin1(GFRCRIT*pvph(jl,klev+1)/sqrt(pstab(jl,klev+1))                   &
+       &              ,zeff)
+         endif
+
+      
+        ptau(jl,klev+1)=gkdrag*prho(jl,klev+1)                                       &
+       &     *psig(jl)*pdmod(jl)/4./pstd(jl)                                         &
+       &     *pvph(jl,klev+1)*sqrt(pstab(jl,klev+1))                                 &
+       &     *zeff**2
+
+
+!c  too small value of stress or  low level flow include critical level
+!c  or low level flow:  gravity wave stress nul.
+                
+!c       lo=(ptau(jl,klev+1).lt.gtsec).or.(kcrit(jl).ge.kknu(jl))
+!c    *      .or.(pvph(jl,klev+1).lt.gvcrit)
+!c       if(lo) ptau(jl,klev+1)=0.0
+      
+!c      print *,jl,ptau(jl,klev+1)
+
+      else
+      
+          ptau(jl,klev+1)=0.0
+          
+      endif
+
+  301 continue
+
+!c      write(21)(ptau(jl,klev+1),jl=kidia,kfdia)
+ 
+      return
+      end SUBROUTINE gwstress_strato
+
+      subroutine gwprofil_strato                                                     &
+       &         ( nlon, nlev                                                        &
+       &         , kgwd ,kdx  , ktest                                                &
+       &         , kkcrit, kkcrith, kcrit ,  kkenvh, kknu,kknu2                      &
+       &         , paphm1, prho   , pstab , ptfr , pvph , pri , ptau                 &
+       &         , pdmod   , pnu   , psig ,pgamma, pstd, ppic,pval)
+
+!C**** *gwprofil*
+!C
+!C     purpose.
+!C     --------
+!C
+!C**   interface.
+!C     ----------
+!C          from *gwdrag*
+!C
+!C        explicit arguments :
+!C        --------------------
+!C     ==== inputs ===
+!C
+!C     ==== outputs ===
+!C
+!C        implicit arguments :   none
+!C        --------------------
+!C
+!C     method:
+!C     -------
+!C     the stress profile for gravity waves is computed as follows:
+!C     it decreases linearly with heights from the ground 
+!C     to the low-level indicated by kkcrith,
+!C     to simulates lee waves or 
+!C     low-level gravity wave breaking.
+!C     above it is constant, except when the waves encounter a critical
+!C     level (kcrit) or when they break.
+!C     The stress is also uniformly distributed above the level
+!C     nstra.                                          
+!C
+      USE dimphy
+      IMPLICIT NONE
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+
+!C-----------------------------------------------------------------------
+!C
+!C*       0.1   ARGUMENTS
+!C              ---------
+!C
+      integer nlon,nlev,kgwd
+      integer kkcrit(nlon),kkcrith(nlon),kcrit(nlon)                                 &
+       &       ,kdx(nlon),ktest(nlon)                                                &
+       &       ,kkenvh(nlon),kknu(nlon),kknu2(nlon)
+!C
+      real paphm1(nlon,nlev+1), pstab(nlon,nlev+1),                                  &
+       &     prho  (nlon,nlev+1), pvph (nlon,nlev+1),                                &
+       &     pri   (nlon,nlev+1), ptfr (nlon), ptau(nlon,nlev+1)                     
+      real pdmod (nlon) , pnu (nlon) , psig(nlon),                                   &
+       &     pgamma(nlon) , pstd(nlon) , ppic(nlon), pval(nlon)
+
+!C-----------------------------------------------------------------------
+!C
+!C*       0.2   local arrays
+!C              ------------
+!C
+      integer jl,jk
+      real zsqr,zalfa,zriw,zdel,zb,zalpha,zdz2n,zdelp,zdelpt
+
+      real zdz2 (klon,klev) , znorm(klon) , zoro(klon)
+      real ztau (klon,klev+1)
+!C
+!C-----------------------------------------------------------------------
+!C
+!C*         1.    INITIALIZATION
+!C                --------------
+!C
+!C      print *,' entree gwprofil' 
+ 100  CONTINUE
+!C
+!C
+!C*    COMPUTATIONAL CONSTANTS.
+!C     ------------- ----------
+!C
+      do 400 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+      zoro(jl)=psig(jl)*pdmod(jl)/4./pstd(jl)
+      ztau(jl,klev+1)=ptau(jl,klev+1)
+!c     print *,jl,ptau(jl,klev+1)
+      ztau(jl,kkcrith(jl))=grahilo*ptau(jl,klev+1)
+      endif
+  400 continue
+  
+!C
+      do 430 jk=klev+1,1,-1
+!C
+!C
+!C*         4.1    constant shear stress until top of the
+!C                 low-level breaking/trapped layer
+  410 CONTINUE
+!C
+      do 411 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+           if(jk.gt.kkcrith(jl)) then
+           zdelp=paphm1(jl,jk)-paphm1(jl,klev+1) 
+           zdelpt=paphm1(jl,kkcrith(jl))-paphm1(jl,klev+1) 
+           ptau(jl,jk)=ztau(jl,klev+1)+zdelp/zdelpt*                                 &
+       &                 (ztau(jl,kkcrith(jl))-ztau(jl,klev+1))
+           else                    
+           ptau(jl,jk)=ztau(jl,kkcrith(jl))
+           endif
+       endif
+ 411  continue             
+!C
+!C*         4.15   constant shear stress until the top of the
+!C                 low level flow layer.
+ 415  continue
+!C        
+!C
+!C*         4.2    wave displacement at next level.
+!C
+  420 continue
+!C
+  430 continue
+
+!C
+!C*         4.4    wave richardson number, new wave displacement
+!C*                and stress:  breaking evaluation and critical 
+!C                 level
+!C
+                          
+      do 440 jk=klev,1,-1
+
+      do 441 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+      znorm(jl)=prho(jl,jk)*sqrt(pstab(jl,jk))*pvph(jl,jk)
+      zdz2(jl,jk)=ptau(jl,jk)/amax1(znorm(jl),gssec)/zoro(jl)
+      endif
+  441 continue
+
+      do 442 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+          if(jk.lt.kkcrith(jl)) then
+          if((ptau(jl,jk+1).lt.gtsec).or.(jk.le.kcrit(jl))) then
+             ptau(jl,jk)=0.0
+          else
+               zsqr=sqrt(pri(jl,jk))
+               zalfa=sqrt(pstab(jl,jk)*zdz2(jl,jk))/pvph(jl,jk)
+               zriw=pri(jl,jk)*(1.-zalfa)/(1+zalfa*zsqr)**2
+               if(zriw.lt.grcrit) then
+!C                 print *,' breaking!!!',ptau(jl,jk)
+                  zdel=4./zsqr/grcrit+1./grcrit**2+4./grcrit
+                  zb=1./grcrit+2./zsqr
+                  zalpha=0.5*(-zb+sqrt(zdel))
+                  zdz2n=(pvph(jl,jk)*zalpha)**2/pstab(jl,jk)
+                  ptau(jl,jk)=znorm(jl)*zdz2n*zoro(jl)
+               endif
+                
+               ptau(jl,jk)=amin1(ptau(jl,jk),ptau(jl,jk+1))
+                  
+          endif
+          endif
+      endif
+  442 continue
+  440 continue
+
+!C  REORGANISATION OF THE STRESS PROFILE AT LOW LEVEL
+
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+         ztau(jl,kkcrith(jl)-1)=ptau(jl,kkcrith(jl)-1)
+         ztau(jl,nstra)=ptau(jl,nstra)
+      endif
+ 530  continue      
+
+      do 531 jk=1,klev
+      
+      do 532 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+                
+         if(jk.gt.kkcrith(jl)-1)then
+
+          zdelp=paphm1(jl,jk)-paphm1(jl,klev+1    )
+          zdelpt=paphm1(jl,kkcrith(jl)-1)-paphm1(jl,klev+1    )
+          ptau(jl,jk)=ztau(jl,klev+1    ) +                                          &
+       &                (ztau(jl,kkcrith(jl)-1)-ztau(jl,klev+1    ) )*               &
+       &                zdelp/zdelpt
+         endif
+      endif
+            
+ 532  continue    
+ 
+!C  REORGANISATION AT THE MODEL TOP....
+
+      do 533 jl=kidia,kfdia
+      if(ktest(jl).eq.1)then
+
+         if(jk.lt.nstra)then
+
+          zdelp =paphm1(jl,nstra)
+          zdelpt=paphm1(jl,jk)
+          ptau(jl,jk)=ztau(jl,nstra)*zdelpt/zdelp 
+!c         ptau(jl,jk)=ztau(jl,nstra)                
+
+        endif
+
+      endif
+
+ 533  continue
+
+ 
+ 531  continue        
+
+
+ 123   format(i4,1x,20(f6.3,1x))
+
+
+      return
+      end subroutine gwprofil_strato
+
+      subroutine lift_noro_strato (nlon,nlev,dtime,paprs,pplay,                      &
+       &                   plat,pmea,pstd, psig, pgam, pthe, ppic,pval,              &
+       &                   kgwd,kdx,ktest,                                           &
+       &                   t, u, v,                                                  &
+       &                   pulow, pvlow, pustr, pvstr,                               &
+       &                   d_t, d_u, d_v)
+!c
+      USE dimphy
+      implicit none
+!c======================================================================
+!c Auteur(s): F.Lott (LMD/CNRS) date: 19950201
+!c Object: Mountain lift interface (enhanced vortex stretching).
+!c         Made necessary because:
+!C 1. in the LMD-GCM Layers are from bottom to top,
+!C    contrary to most European GCM.
+!c 2. the altitude above ground of each model layers
+!c    needs to be known (variable zgeom)
+!c======================================================================
+!c Explicit Arguments:
+!c ==================
+!c nlon----input-I-Total number of horizontal points that get into physics
+!c nlev----input-I-Number of vertical levels
+!c dtime---input-R-Time-step (s)
+!c paprs---input-R-Pressure in semi layers    (Pa)
+!c pplay---input-R-Pressure model-layers      (Pa)
+!c t-------input-R-temperature (K)
+!c u-------input-R-Horizontal wind (m/s)
+!c v-------input-R-Meridional wind (m/s)
+!c pmea----input-R-Mean Orography (m)
+!C pstd----input-R-SSO standard deviation (m)
+!c psig----input-R-SSO slope
+!c pgam----input-R-SSO Anisotropy
+!c pthe----input-R-SSO Angle
+!c ppic----input-R-SSO Peacks elevation (m)
+!c pval----input-R-SSO Valleys elevation (m)
+!c
+!c kgwd- -input-I: Total nb of points where the orography schemes are active
+!c ktest--input-I: Flags to indicate active points
+!c kdx----input-I: Locate the physical location of an active point.
+
+!c pulow, pvlow -output-R: Low-level wind
+!c pustr, pvstr -output-R: Surface stress due to SSO drag      (Pa)
+!c
+!c d_t-----output-R: T increment
+!c d_u-----output-R: U increment
+!c d_v-----output-R: V increment
+!c
+!c Implicit Arguments:
+!c ===================
+!c
+!c iim--common-I: Number of longitude intervals
+!c jjm--common-I: Number of latitude intervals
+!c klon-common-I: Number of points seen by the physics
+!c                (iim+1)*(jjm+1) for instance
+!c klev-common-I: Number of vertical layers
+!c======================================================================
+!c Local Variables:
+!c ================
+!c
+!c zgeom-----R: Altitude of layer above ground
+!c pt, pu, pv --R: t u v from top to bottom
+!c pdtdt, pdudt, pdvdt --R: t u v tendencies (from top to bottom)
+!c papmf: pressure at model layer (from top to bottom)
+!c papmh: pressure at model 1/2 layer (from top to bottom)
+!c
+!c======================================================================
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+!c
+!c ARGUMENTS
+!c
+      INTEGER nlon,nlev
+      REAL dtime
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL plat(nlon),pmea(nlon)
+      REAL pstd(nlon),psig(nlon),pgam(nlon),pthe(nlon)
+      REAL ppic(nlon),pval(nlon)
+      REAL pulow(nlon),pvlow(nlon),pustr(nlon),pvstr(nlon)
+      REAL t(nlon,nlev), u(nlon,nlev), v(nlon,nlev)
+      REAL d_t(nlon,nlev), d_u(nlon,nlev), d_v(nlon,nlev)
+!c
+      INTEGER i, k, kgwd,  kdx(nlon), ktest(nlon)
+!c
+!c Variables locales:
+!c
+      REAL zgeom(klon,klev)
+      REAL pdtdt(klon,klev), pdudt(klon,klev), pdvdt(klon,klev)
+      REAL pt(klon,klev), pu(klon,klev), pv(klon,klev)
+      REAL papmf(klon,klev),papmh(klon,klev+1)
+!c
+!c initialiser les variables de sortie (pour securite)
+!c
+
+!c     print *,'in lift_noro'
+      DO i = 1,klon
+         pulow(i) = 0.0
+         pvlow(i) = 0.0
+         pustr(i) = 0.0
+         pvstr(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+         pdudt(i,k)=0.0
+         pdvdt(i,k)=0.0
+         pdtdt(i,k)=0.0
+      ENDDO
+      ENDDO
+!c
+!c preparer les variables d'entree (attention: l'ordre des niveaux 
+!c verticaux augmente du haut vers le bas)
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         pt(i,k) = t(i,klev-k+1) 
+         pu(i,k) = u(i,klev-k+1)
+         pv(i,k) = v(i,klev-k+1)
+         papmf(i,k) = pplay(i,klev-k+1)
+      ENDDO
+      ENDDO
+      DO k = 1, klev+1
+      DO i = 1, klon
+         papmh(i,k) = paprs(i,klev-k+2)
+      ENDDO
+      ENDDO
+      DO i = 1, klon
+         zgeom(i,klev) = RD * pt(i,klev)                                             &
+       &                  * LOG(papmh(i,klev+1)/papmf(i,klev))
+      ENDDO
+      DO k = klev-1, 1, -1
+      DO i = 1, klon
+         zgeom(i,k) = zgeom(i,k+1) + RD * (pt(i,k)+pt(i,k+1))/2.0                    &
+       &               * LOG(papmf(i,k+1)/papmf(i,k))
+      ENDDO
+      ENDDO
+!c
+!c appeler la routine principale
+!c
+
+      CALL OROLIFT_strato(klon,klev,kgwd,kdx,ktest,                                  &
+       &            dtime,                                                           &
+       &            papmh, papmf, zgeom,                                             &
+       &            pt, pu, pv,                                                      &
+       &            plat,pmea, pstd, psig, pgam, pthe, ppic,pval,                    &
+       &            pulow,pvlow,                                                     &
+       &            pdudt,pdvdt,pdtdt)
+!C
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,klev+1-k) = dtime*pdudt(i,k)
+         d_v(i,klev+1-k) = dtime*pdvdt(i,k)
+         d_t(i,klev+1-k) = dtime*pdtdt(i,k)
+         pustr(i)        = pustr(i)                                                  &
+       &                    +pdudt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+         pvstr(i)        = pvstr(i)                                                  &
+       &                    +pdvdt(i,k)*(papmh(i,k+1)-papmh(i,k))/rg
+      ENDDO
+      ENDDO
+
+!c     print *,' out lift_noro'
+!c
+      RETURN
+      END subroutine lift_noro_strato
+
+      subroutine orolift_strato( nlon,nlev                                           &
+       &                 , kgwd, kdx, ktest                                          &
+       &                 , ptsphy                                                    &
+       &                 , paphm1,papm1,pgeom1,ptm1,pum1,pvm1                        &
+       &                 , plat                                                      &
+       &                 , pmea, pstd, psig, pgam, pthe,ppic,pval                    &
+!C OUTPUTS                                                                           &
+       &                 , pulow,pvlow                                               &
+       &                 , pvom,pvol,pte )
+
+!C
+!C**** *OROLIFT: SIMULATE THE GEOSTROPHIC LIFT.
+!C
+!C     PURPOSE.
+!C     --------
+!C this routine computes the physical tendencies of the
+!C prognostic variables u,v  when enhanced vortex stretching
+!C is needed.
+!C
+!C**   INTERFACE.
+!C     ----------
+!C          CALLED FROM *lift_noro
+!c        explicit arguments :
+!c        --------------------
+!c     ==== inputs ===
+!c nlon----input-I-Total number of horizontal points that get into physics
+!c nlev----input-I-Number of vertical levels
+!c
+!c kgwd- -input-I: Total nb of points where the orography schemes are active
+!c ktest--input-I: Flags to indicate active points
+!c kdx----input-I: Locate the physical location of an active point.
+!c ptsphy--input-R-Time-step (s)
+!c paphm1--input-R: pressure at model 1/2 layer
+!c papm1---input-R: pressure at model layer
+!c pgeom1--input-R: Altitude of layer above ground
+!c ptm1, pum1, pvm1--R-: t, u and v
+!c pmea----input-R-Mean Orography (m)
+!C pstd----input-R-SSO standard deviation (m)
+!c psig----input-R-SSO slope
+!c pgam----input-R-SSO Anisotropy
+!c pthe----input-R-SSO Angle
+!c ppic----input-R-SSO Peacks elevation (m)
+!c pval----input-R-SSO Valleys elevation (m)
+!c plat----input-R-Latitude (degree)
+!c
+!c     ==== outputs ===
+!c pulow, pvlow -output-R: Low-level wind
+!c
+!c pte -----output-R: T tendency
+!c pvom-----output-R: U tendency
+!c pvol-----output-R: V tendency
+!c
+!c
+!c Implicit Arguments:
+!c ===================
+!c
+!c klon-common-I: Number of points seen by the physics
+!c klev-common-I: Number of vertical layers
+!c
+
+!C     ----------
+!C
+!C     AUTHOR.
+!C     -------
+!C     F.LOTT  LMD 22/11/95
+!C
+       USE dimphy
+       implicit none
+!C
+!C
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOEGWD.h"
+!C-----------------------------------------------------------------------
+!C
+!C*       0.1   ARGUMENTS
+!C              ---------
+!C
+!C
+      integer nlon,nlev,kgwd
+      real ptsphy
+      real  pte(nlon,nlev),                                                          &
+       &      pvol(nlon,nlev),                                                       &
+       &      pvom(nlon,nlev),                                                       &
+       &      pulow(nlon),                                                           &
+       &      pvlow(nlon)
+      real  pum1(nlon,nlev),                                                         &
+       &      pvm1(nlon,nlev),                                                       &
+       &      ptm1(nlon,nlev),                                                       &
+       &      plat(nlon),pmea(nlon),                                                 &
+       &      pstd(nlon),psig(nlon),pgam(nlon),                                      &
+       &      pthe(nlon),ppic(nlon),pval(nlon),                                      &
+       &      pgeom1(nlon,nlev),                                                     &
+       &      papm1(nlon,nlev),                                                      &
+       &      paphm1(nlon,nlev+1)
+!C
+      INTEGER  KDX(NLON),KTEST(NLON)
+!C-----------------------------------------------------------------------
+!C
+!C*       0.2   local arrays
+
+      integer jl,ilevh,jk
+      real zhgeo,zdelp,zslow,zsqua,zscav,zbet
+!C              ------------
+      integer  iknub(klon),                                                          &
+       &         iknul(klon)
+      logical ll1(klon,klev+1)
+!C
+      real   ztau(klon,klev+1),                                                      &
+       &       ztav(klon,klev+1),                                                    &
+       &       zrho(klon,klev+1)
+      real   zdudt(klon),                                                            &
+       &       zdvdt(klon)
+      real zhcrit(klon,klev)
+
+      logical lifthigh
+      real zcons1,ztmst
+      CHARACTER (LEN=20) :: modname='orolift_strato'
+      CHARACTER (LEN=80) :: abort_message
+
+
+!C-----------------------------------------------------------------------
+!C
+!C*         1.1  initialisations
+!C               ---------------
+
+      lifthigh=.false.
+
+      if(nlon.ne.klon.or.nlev.ne.klev) then
+        abort_message = 'pb dimension'
+        CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+      zcons1=1./rd
+      ztmst=ptsphy
+!C
+      do 1001 jl=kidia,kfdia
+      zrho(jl,klev+1)  =0.0
+      pulow(jl)        =0.0
+      pvlow(jl)        =0.0
+      iknub(JL)   =klev
+      iknul(JL)   =klev
+      ilevh=klev/3
+      ll1(jl,klev+1)=.false.
+      do 1000 jk=1,klev
+      pvom(jl,jk)=0.0
+      pvol(jl,jk)=0.0
+      pte (jl,jk)=0.0
+ 1000 continue
+ 1001 continue
+
+!C
+!C*         2.1     DEFINE LOW LEVEL WIND, PROJECT WINDS IN PLANE OF
+!C*                 LOW LEVEL WIND, DETERMINE SECTOR IN WHICH TO TAKE
+!C*                 THE VARIANCE AND SET INDICATOR FOR CRITICAL LEVELS.
+!C
+!C
+!C
+      do 2006 jk=klev,1,-1
+      do 2007 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zhcrit(jl,jk)=amax1(ppic(jl)-pval(jl),100.)
+      zhgeo=pgeom1(jl,jk)/rg
+      ll1(jl,jk)=(zhgeo.gt.zhcrit(jl,jk))
+      if(ll1(jl,jk).neqv.ll1(jl,jk+1)) then
+        iknub(jl)=jk
+      endif
+      endif
+ 2007 continue
+ 2006 continue
+!C
+
+      do 2010 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      iknub(jl)=max(iknub(jl),klev/2)
+      iknul(jl)=max(iknul(jl),2*klev/3)
+      if(iknub(jl).gt.nktopg) iknub(jl)=nktopg
+      if(iknub(jl).eq.nktopg) iknul(jl)=klev
+      if(iknub(jl).eq.iknul(jl)) iknub(jl)=iknul(jl)-1
+      endif
+ 2010 continue
+
+      do 223 jk=klev,2,-1
+      do 222 jl=kidia,kfdia
+        zrho(jl,jk)=2.*paphm1(jl,jk)*zcons1/(ptm1(jl,jk)+ptm1(jl,jk-1))
+  222 continue
+  223 continue
+!c     print *,'  dans orolift: 223'
+
+!C********************************************************************
+!C
+!c*     define low level flow
+!C      -------------------
+      do 2115 jk=klev,1,-1
+      do 2116 jl=kidia,kfdia
+      if(ktest(jl).eq.1) THEN
+      if(jk.ge.iknub(jl).and.jk.le.iknul(jl)) then
+        pulow(JL)=pulow(JL)+pum1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        pvlow(JL)=pvlow(JL)+pvm1(jl,jk)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+        zrho(JL,klev+1)=zrho(JL,klev+1)                                              &
+       &                 +zrho(JL,JK)*(paphm1(jl,jk+1)-paphm1(jl,jk))
+      endif
+      endif
+ 2116 continue
+ 2115 continue
+      do 2110 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      pulow(JL)=pulow(JL)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      pvlow(JL)=pvlow(JL)/(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      zrho(JL,klev+1)=zrho(Jl,klev+1)                                                &
+       &               /(paphm1(jl,iknul(jl)+1)-paphm1(jl,iknub(jl)))
+      endif
+ 2110 continue
+
+
+200   continue
+
+!C***********************************************************
+!C
+!C*         3.      COMPUTE MOUNTAIN LIFT
+!C
+  300 continue
+!C
+      do 301 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+       ztau(jl,klev+1)= - gklift*zrho(jl,klev+1)*2.*romega*                          &
+!c    *                 (2*pstd(jl)+pmea(jl))*                                       &
+       &                 2*pstd(jl)*                                                 &
+       &                 sin(rpi/180.*plat(jl))*pvlow(jl)
+       ztav(jl,klev+1)=   gklift*zrho(jl,klev+1)*2.*romega*                          &
+!c    *                 (2*pstd(jl)+pmea(jl))*                                       &
+       &                 2*pstd(jl)*                                                 &
+       &                 sin(rpi/180.*plat(jl))*pulow(jl)
+      else
+       ztau(jl,klev+1)=0.0
+       ztav(jl,klev+1)=0.0
+      endif
+301   continue
+
+!C
+!C*         4.      COMPUTE LIFT PROFILE         
+!C*                 --------------------   
+!C
+
+  400 continue
+
+      do 401 jk=1,klev
+      do 401 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      ztau(jl,jk)=ztau(jl,klev+1)*paphm1(jl,jk)/paphm1(jl,klev+1)
+      ztav(jl,jk)=ztav(jl,klev+1)*paphm1(jl,jk)/paphm1(jl,klev+1)
+      else
+      ztau(jl,jk)=0.0
+      ztav(jl,jk)=0.0
+      endif
+401   continue
+!C
+!C
+!C*         5.      COMPUTE TENDENCIES.
+!C*                 -------------------
+      if(lifthigh)then
+!C
+  500 continue
+!C
+!C  EXPLICIT SOLUTION AT ALL LEVELS
+!C
+      do 524 jk=1,klev
+      do 523 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+      zdelp=paphm1(jl,jk+1)-paphm1(jl,jk)
+      zdudt(jl)=-rg*(ztau(jl,jk+1)-ztau(jl,jk))/zdelp
+      zdvdt(jl)=-rg*(ztav(jl,jk+1)-ztav(jl,jk))/zdelp
+      endif  
+  523 continue
+  524 continue
+!C
+!C  PROJECT PERPENDICULARLY TO U NOT TO DESTROY ENERGY
+!C
+      do 530 jk=1,klev
+      do 530 jl=kidia,kfdia
+      if(ktest(jl).eq.1) then
+
+        zslow=sqrt(pulow(jl)**2+pvlow(jl)**2)
+        zsqua=amax1(sqrt(pum1(jl,jk)**2+pvm1(jl,jk)**2),gvsec)
+        zscav=-zdudt(jl)*pvm1(jl,jk)+zdvdt(jl)*pum1(jl,jk)
+        if(zsqua.gt.gvsec)then
+          pvom(jl,jk)=-zscav*pvm1(jl,jk)/zsqua**2
+          pvol(jl,jk)= zscav*pum1(jl,jk)/zsqua**2
+        else
+          pvom(jl,jk)=0.0
+          pvol(jl,jk)=0.0      
+        endif  
+        zsqua=sqrt(pum1(jl,jk)**2+pum1(jl,jk)**2)               
+        if(zsqua.lt.zslow)then
+          pvom(jl,jk)=zsqua/zslow*pvom(jl,jk)
+          pvol(jl,jk)=zsqua/zslow*pvol(jl,jk)
+        endif 
+
+      endif  
+530   continue
+!C
+!C  6.  LOW LEVEL LIFT, SEMI IMPLICIT:
+!C  ----------------------------------
+
+      else
+
+        do 601 jl=kidia,kfdia
+        if(ktest(jl).eq.1) then
+          do jk=klev,iknub(jl),-1
+          zbet=gklift*2.*romega*sin(rpi/180.*plat(jl))*ztmst*                        &
+       &        (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,  jk))/                            &
+       &        (pgeom1(jl,iknub(jl)-1)-pgeom1(jl,klev))
+          zdudt(jl)=-pum1(jl,jk)/ztmst/(1+zbet**2)
+          zdvdt(jl)=-pvm1(jl,jk)/ztmst/(1+zbet**2)
+          pvom(jl,jk)= zbet**2*zdudt(jl) - zbet   *zdvdt(jl)
+          pvol(jl,jk)= zbet   *zdudt(jl) + zbet**2*zdvdt(jl)    
+          enddo
+        endif
+ 601    continue
+
+      endif
+
+!c     print *,' out orolift'
+
+      return
+      end subroutine orolift_strato
+
+      SUBROUTINE SUGWD_strato(NLON,NLEV,paprs,pplay)
+!C     
+!C
+!C**** *SUGWD* INITIALIZE COMMON YOEGWD CONTROLLING GRAVITY WAVE DRAG
+!C
+!C     PURPOSE.
+!C     --------
+!C           INITIALIZE YOEGWD, THE COMMON THAT CONTROLS THE
+!C           GRAVITY WAVE DRAG PARAMETRIZATION.
+!C    VERY IMPORTANT:
+!C    ______________
+!C           THIS ROUTINE SET_UP THE "TUNABLE PARAMETERS" OF THE
+!C           VARIOUS SSO SCHEMES
+!C
+!C**   INTERFACE.
+!C     ----------
+!C        CALL *SUGWD* FROM *SUPHEC*
+!C              -----        ------
+!C
+!C        EXPLICIT ARGUMENTS :
+!C        --------------------
+!C        PAPRS,PPLAY : Pressure at semi and full model levels
+!C        NLEV        : number of model levels
+!c        NLON        : number of points treated in the physics
+!C
+!C        IMPLICIT ARGUMENTS :
+!C        --------------------
+!C        COMMON YOEGWD
+!C-GFRCRIT-R:  Critical Non-dimensional mountain Height
+!C             (HNC in (1),    LOTT 1999)
+!C-GKWAKE--R:  Bluff-body drag coefficient for low level wake
+!C             (Cd in (2),     LOTT 1999)
+!C-GRCRIT--R:  Critical Richardson Number 
+!C             (Ric, End of first column p791 of LOTT 1999) 
+!C-GKDRAG--R:  Gravity wave drag coefficient
+!C             (G in (3),      LOTT 1999)
+!C-GKLIFT--R:  Mountain Lift coefficient
+!C             (Cl in (4),     LOTT 1999)
+!C-GHMAX---R:  Not used
+!C-GRAHILO-R:  Set-up the trapped waves fraction
+!C             (Beta , End of first column,  LOTT 1999)
+!C
+!C-GSIGCR--R:  Security value for blocked flow depth
+!C-NKTOPG--I:  Security value for blocked flow level
+!C-nstra----I:  An estimate to qualify the upper levels of
+!C             the model where one wants to impose strees
+!C             profiles
+!C-GSSECC--R:  Security min value for low-level B-V frequency
+!C-GTSEC---R:  Security min value for anisotropy and GW stress.
+!C-GVSEC---R:  Security min value for ulow
+!C         
+!C
+!C     METHOD.
+!C     -------
+!C        SEE DOCUMENTATION
+!C
+!C     EXTERNALS.
+!C     ----------
+!C        NONE
+!C
+!C     REFERENCE.
+!C     ----------
+!C     Lott, 1999: Alleviation of stationary biases in a GCM through...
+!C                 Monthly Weather Review, 127, pp 788-801.
+!C
+!C     AUTHOR.
+!C     -------
+!C        FRANCOIS LOTT        *LMD*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 90-01-01 (MARTIN MILLER, ECMWF)
+!C        LAST:  99-07-09     (FRANCOIS LOTT,LMD)
+!C     ------------------------------------------------------------------
+      USE dimphy
+      USE mod_phys_lmdz_para
+      USE mod_grid_phy_lmdz
+      IMPLICIT NONE
+!C
+!C     -----------------------------------------------------------------
+#include "YOEGWD.h"
+!C      ----------------------------------------------------------------
+!C
+!C  ARGUMENTS
+      integer nlon,nlev
+      REAL paprs(nlon,nlev+1)
+      REAL pplay(nlon,nlev)
+!C
+      INTEGER JK
+      REAL ZPR,ZTOP,ZSIGT,ZPM1R
+      REAL :: pplay_glo(klon_glo,nlev)
+      REAL :: paprs_glo(klon_glo,nlev+1)
+
+!C
+!C*       1.    SET THE VALUES OF THE PARAMETERS
+!C              --------------------------------
+!C
+ 100  CONTINUE
+!C
+      PRINT *,' DANS SUGWD NLEV=',NLEV
+      GHMAX=10000.
+!C
+      ZPR=100000.
+      ZTOP=0.001 
+      ZSIGT=0.94
+!cold  ZPR=80000.
+!cold  ZSIGT=0.85
+!C
+      CALL gather(pplay,pplay_glo)
+      CALL bcast(pplay_glo)
+      CALL gather(paprs,paprs_glo)
+      CALL bcast(paprs_glo)
+
+      DO 110 JK=1,NLEV
+      ZPM1R=pplay_glo(klon_glo/2+1,jk)/paprs_glo(klon_glo/2+1,1) 
+      IF(ZPM1R.GE.ZSIGT)THEN
+         nktopg=JK
+      ENDIF
+      ZPM1R=pplay_glo(klon_glo/2+1,jk)/paprs_glo(klon_glo/2+1,1) 
+      IF(ZPM1R.GE.ZTOP)THEN
+         nstra=JK
+      ENDIF
+  110 CONTINUE
+!c
+!c  inversion car dans orodrag on compte les niveaux a l'envers
+      nktopg=nlev-nktopg+1
+      nstra=nlev-nstra
+      print *,' DANS SUGWD nktopg=', nktopg
+      print *,' DANS SUGWD nstra=', nstra
+!C
+      GSIGCR=0.80
+!C
+      GKDRAG=0.1875
+      GRAHILO=0.1   
+      GRCRIT=1.00 
+      GFRCRIT=1.00
+      GKWAKE=0.50
+!C
+      GKLIFT=0.25
+      GVCRIT =0.1
+
+      WRITE(UNIT=6,FMT='('' *** SSO essential constants ***'')')
+      WRITE(UNIT=6,FMT='('' *** SPECIFIED IN SUGWD ***'')')
+      WRITE(UNIT=6,FMT='('' Gravity wave ct '',E13.7,'' '')')GKDRAG
+      WRITE(UNIT=6,FMT='('' Trapped/total wave dag '',E13.7,'' '')')                 &
+       &      GRAHILO
+      WRITE(UNIT=6,FMT='('' Critical Richardson   = '',E13.7,'' '')')                &
+       &                  GRCRIT
+      WRITE(UNIT=6,FMT='('' Critical Froude'',e13.7)') GFRCRIT
+      WRITE(UNIT=6,FMT='('' Low level Wake bluff cte'',e13.7)') GKWAKE
+      WRITE(UNIT=6,FMT='('' Low level lift  cte'',e13.7)') GKLIFT
+
+!C
+!C
+!C      ----------------------------------------------------------------
+!C
+!C*       2.    SET VALUES OF SECURITY PARAMETERS
+!C              ---------------------------------
+!C
+ 200  CONTINUE
+!C
+      GVSEC=0.10
+      GSSEC=0.0001
+!C
+      GTSEC=0.00001
+!C
+      RETURN
+      END SUBROUTINE SUGWD_strato
+
+END MODULE orografi_strato_mod
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/output_lmdz_NOmodule.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/output_lmdz_NOmodule.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/output_lmdz_NOmodule.F90	(revision 17)
@@ -0,0 +1,749 @@
+MODULE output_lmdz_NOmodule
+! Module to define that variables which are not included in any module as SAVE variables
+
+  IMPLICIT NONE
+
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: agesno ! nbsrf
+!$OMP THREADPRIVATE(agesno) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: ale_wake ! 1D
+!$OMP THREADPRIVATE(ale_wake) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: alp_wake ! 1D
+!$OMP THREADPRIVATE(alp_wake) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: beta_prec
+!$OMP THREADPRIVATE(beta_prec) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: bils ! 1D
+!$OMP THREADPRIVATE(bils) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: cdragh ! 1D
+!$OMP THREADPRIVATE(cdragh) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: cdragm ! 1D
+!$OMP THREADPRIVATE(cdragm) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: cldh ! 1D
+!$OMP THREADPRIVATE(cldh) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: cldl ! 1D
+!$OMP THREADPRIVATE(cldl) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: cldm ! 1D
+!$OMP THREADPRIVATE(cldm) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: cldq ! 1D
+!$OMP THREADPRIVATE(cldq) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: cldt ! 1D
+!$OMP THREADPRIVATE(cldt) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: cldemi
+!$OMP THREADPRIVATE(cldemi) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: cldfra
+!$OMP THREADPRIVATE(cldfra) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: cldtau
+!$OMP THREADPRIVATE(cldtau) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: dnwd
+!$OMP THREADPRIVATE(dnwd) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: dnwd0
+!$OMP THREADPRIVATE(dnwd0) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: dthmin ! 1D
+!$OMP THREADPRIVATE(dthmin) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: evap ! 1D
+!$OMP THREADPRIVATE(evap) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: evap_pot ! nbsrf
+!$OMP THREADPRIVATE(evap_pot) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: evap_srf ! nbsrf
+!$OMP THREADPRIVATE(evap_srf) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: evappot_srf ! nbsrf
+!$OMP THREADPRIVATE(evappot_srf) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: fder ! 1D
+!$OMP THREADPRIVATE(fder) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: fevap ! nbsrf
+!$OMP THREADPRIVATE(fevap) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: fiwc
+!$OMP THREADPRIVATE(fiwc) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: fiwp ! 1D
+!$OMP THREADPRIVATE(fiwp) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: fl
+!$OMP THREADPRIVATE(fl) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: fluxlat ! nbsrf
+!$OMP THREADPRIVATE(fluxlat) 
+    REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE            :: fluxt ! 3D nbsrf
+!$OMP THREADPRIVATE(fluxt) 
+    REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE            :: fluxu ! 3D nbsrf
+!$OMP THREADPRIVATE(fluxu) 
+    REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE            :: fluxv ! 3D nbsrf
+!$OMP THREADPRIVATE(fluxv) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: flwc
+!$OMP THREADPRIVATE(flwc) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: fraca ! z-stagg
+!$OMP THREADPRIVATE(fraca) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: frugs ! nbsrf
+!$OMP THREADPRIVATE(frugs) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: flwp ! 1D
+!$OMP THREADPRIVATE(flwp) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: fsollw ! nbsrf
+!$OMP THREADPRIVATE(fsollw) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: fsolsw ! nbsrf
+!$OMP THREADPRIVATE(fsolsw) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: fsolw ! nbsrf
+!$OMP THREADPRIVATE(fsolw)
+    INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE           :: lambda_th
+!$OMP THREADPRIVATE(lambda_th)  
+    INTEGER, ALLOCATABLE, DIMENSION(:), SAVE             :: lmax_th ! 1D
+!$OMP THREADPRIVATE(lmax_th)  
+    INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE           :: mc
+!$OMP THREADPRIVATE(mc)  
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: omega
+!$OMP THREADPRIVATE(omega) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: plcl ! 1D
+!$OMP THREADPRIVATE(plcl) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: plfc ! 1D
+!$OMP THREADPRIVATE(plfc) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: pmfd
+!$OMP THREADPRIVATE(pmfd) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: pmflxr ! stag
+!$OMP THREADPRIVATE(pmflxr) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: pmflxs ! stag
+!$OMP THREADPRIVATE(pmflxs) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: pmfu
+!$OMP THREADPRIVATE(pmfu) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: prfl ! stag
+!$OMP THREADPRIVATE(prfl) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: prw ! 1D
+!$OMP THREADPRIVATE(prw) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: psfl
+!$OMP THREADPRIVATE(psfl) 
+    LOGICAL, ALLOCATABLE, DIMENSION(:,:), SAVE           :: ptconv
+!$OMP THREADPRIVATE(ptconv) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: qsat2m ! 1D
+!$OMP THREADPRIVATE(qsat2m)
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: qsol
+!$OMP THREADPRIVATE(qsol) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: qsol_d
+!$OMP THREADPRIVATE(qsol_d) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: rain_lsc ! 1D
+!$OMP THREADPRIVATE(rain_lsc) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: re
+!$OMP THREADPRIVATE(re) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: ref_ice
+!$OMP THREADPRIVATE(ref_ice) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: ref_liq
+!$OMP THREADPRIVATE(ref_liq) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: rh2m ! 1D
+!$OMP THREADPRIVATE(rh2m)
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: rneb
+!$OMP THREADPRIVATE(rneb) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: s_lcl ! 1D
+!$OMP THREADPRIVATE(s_lcl) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: s_pblh ! 1D
+!$OMP THREADPRIVATE(s_pblh) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: s_pblt ! 1D
+!$OMP THREADPRIVATE(s_pblt)
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: s_therm ! 1D
+!$OMP THREADPRIVATE(s_therm) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: sens ! 1D
+!$OMP THREADPRIVATE(sens) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: slp ! 1D
+!$OMP THREADPRIVATE(slp) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: snow_lsc ! 1D
+!$OMP THREADPRIVATE(snow_lsc) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: t2m ! nbsrf
+!$OMP THREADPRIVATE(t2m) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: theta
+!$OMP THREADPRIVATE(theta) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: tpot ! 1D
+!$OMP THREADPRIVATE(tpot) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: tpote ! 1D
+!$OMP THREADPRIVATE(tpote) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: ue ! 1D
+!$OMP THREADPRIVATE(ue) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: upwd
+!$OMP THREADPRIVATE(upwd) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: uq ! 1D
+!$OMP THREADPRIVATE(uq) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: ve ! 1D
+!$OMP THREADPRIVATE(ve) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: Vprecip ! stag
+!$OMP THREADPRIVATE(Vprecip) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: vq ! 1D
+!$OMP THREADPRIVATE(vq) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: wake_omg
+!$OMP THREADPRIVATE(wake_omg) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: wake_h ! 1D
+!$OMP THREADPRIVATE(wake_h) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: weak_inversion ! 1D
+!$OMP THREADPRIVATE(weak_inversion) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: wbeff ! 1D
+!$OMP THREADPRIVATE(wbeff) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: wdtrainA
+!$OMP THREADPRIVATE(wdtrainA) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: wdtrainM
+!$OMP THREADPRIVATE(wdtrainM) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: wfbilo ! nbsrf
+!$OMP THREADPRIVATE(wfbilo) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: wfbils ! nbsrf
+!$OMP THREADPRIVATE(wfbils) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: zmasse
+!$OMP THREADPRIVATE(zmasse) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zmax_th ! 1D
+!$OMP THREADPRIVATE(zmax_th) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: zphi
+!$OMP THREADPRIVATE(zphi) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zq2m ! 1D
+!$OMP THREADPRIVATE(zq2m) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zt2m ! 1D
+!$OMP THREADPRIVATE(zt2m) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zu10m ! 1D
+!$OMP THREADPRIVATE(zu10m) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zustar ! 1D
+!$OMP THREADPRIVATE(zustar) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zv10m ! 1D
+!$OMP THREADPRIVATE(zv10m) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: zx_rh
+!$OMP THREADPRIVATE(zx_rh) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zxffonte ! 1D
+!$OMP THREADPRIVATE(zxffonte) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zxfluxlat ! 1D
+!$OMP THREADPRIVATE(zxfluxlat) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zxfqcalving ! 1D
+!$OMP THREADPRIVATE(zxfqcalving) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zxfqfonte ! 1D
+!$OMP THREADPRIVATE(zxfqfonte) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zxqsurf ! 1D
+!$OMP THREADPRIVATE(zxqsurf) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zxrugs ! 1D
+!$OMP THREADPRIVATE(zxrugs) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zxsnow ! 1D
+!$OMP THREADPRIVATE(zxsnow) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: zxtsol ! 1D
+!$OMP THREADPRIVATE(zxtsol) 
+
+  CONTAINS
+
+  SUBROUTINE init_ovars_lmdz_NOmodule(klon,klev,nbsrf)
+! Subroutine to activate all the output variables without module
+!! cat output_lmdz_NOmodule.F90 | grep SAVE | awk '{print "    IF (ALLOCATED("$6")) DEALLOCATE("$6")\n    ALLOCATE("$6"(klon,klev))\n"}'>> output_lmdz_NOmodule.F90
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: klon, klev, nbsrf
+
+    IF (ALLOCATED(agesno)) DEALLOCATE(agesno)
+    ALLOCATE(agesno(klon,nbsrf))
+
+    IF (ALLOCATED(ale_wake)) DEALLOCATE(ale_wake)
+    ALLOCATE(ale_wake(klon))
+
+    IF (ALLOCATED(alp_wake)) DEALLOCATE(alp_wake)
+    ALLOCATE(alp_wake(klon))
+
+    IF (ALLOCATED(beta_prec)) DEALLOCATE(beta_prec)
+    ALLOCATE(beta_prec(klon,klev))
+
+    IF (ALLOCATED(bils)) DEALLOCATE(bils)
+    ALLOCATE(bils(klon))
+
+    IF (ALLOCATED(cdragh)) DEALLOCATE(cdragh)
+    ALLOCATE(cdragh(klon))
+
+    IF (ALLOCATED(cdragm)) DEALLOCATE(cdragm)
+    ALLOCATE(cdragm(klon))
+
+    IF (ALLOCATED(cldh)) DEALLOCATE(cldh)
+    ALLOCATE(cldh(klon))
+
+    IF (ALLOCATED(cldl)) DEALLOCATE(cldl)
+    ALLOCATE(cldl(klon))
+
+    IF (ALLOCATED(cldm)) DEALLOCATE(cldm)
+    ALLOCATE(cldm(klon))
+
+    IF (ALLOCATED(cldq)) DEALLOCATE(cldq)
+    ALLOCATE(cldq(klon))
+
+    IF (ALLOCATED(cldt)) DEALLOCATE(cldt)
+    ALLOCATE(cldt(klon))
+
+    IF (ALLOCATED(cldemi)) DEALLOCATE(cldemi)
+    ALLOCATE(cldemi(klon,klev))
+
+    IF (ALLOCATED(cldfra)) DEALLOCATE(cldfra)
+    ALLOCATE(cldfra(klon,klev))
+
+    IF (ALLOCATED(cldtau)) DEALLOCATE(cldtau)
+    ALLOCATE(cldtau(klon,klev))
+
+    IF (ALLOCATED(dnwd)) DEALLOCATE(dnwd)
+    ALLOCATE(dnwd(klon,klev))
+
+    IF (ALLOCATED(dnwd0)) DEALLOCATE(dnwd0)
+    ALLOCATE(dnwd0(klon,klev))
+
+    IF (ALLOCATED(dthmin)) DEALLOCATE(dthmin)
+    ALLOCATE(dthmin(klon))
+
+    IF (ALLOCATED(evap)) DEALLOCATE(evap)
+    ALLOCATE(evap(klon))
+
+    IF (ALLOCATED(evap_pot)) DEALLOCATE(evap_pot)
+    ALLOCATE(evap_pot(klon,nbsrf))
+
+    IF (ALLOCATED(evap_srf)) DEALLOCATE(evap_srf)
+    ALLOCATE(evap_srf(klon,nbsrf))
+
+    IF (ALLOCATED(evappot_srf)) DEALLOCATE(evappot_srf)
+    ALLOCATE(evappot_srf(klon,nbsrf))
+
+    IF (ALLOCATED(fder)) DEALLOCATE(fder)
+    ALLOCATE(fder(klon))
+
+    IF (ALLOCATED(fevap)) DEALLOCATE(fevap)
+    ALLOCATE(fevap(klon,nbsrf))
+
+    IF (ALLOCATED(fiwc)) DEALLOCATE(fiwc)
+    ALLOCATE(fiwc(klon,klev))
+
+    IF (ALLOCATED(fiwp)) DEALLOCATE(fiwp)
+    ALLOCATE(fiwp(klon))
+
+    IF (ALLOCATED(fl)) DEALLOCATE(fl)
+    ALLOCATE(fl(klon,klev))
+
+    IF (ALLOCATED(fluxlat)) DEALLOCATE(fluxlat)
+    ALLOCATE(fluxlat(klon,nbsrf))
+
+    IF (ALLOCATED(fluxt)) DEALLOCATE(fluxt)
+    ALLOCATE(fluxt(klon,klev,nbsrf))
+
+    IF (ALLOCATED(fluxu)) DEALLOCATE(fluxu)
+    ALLOCATE(fluxu(klon,klev,nbsrf))
+
+    IF (ALLOCATED(fluxv)) DEALLOCATE(fluxv)
+    ALLOCATE(fluxv(klon,klev,nbsrf))
+
+    IF (ALLOCATED(flwp)) DEALLOCATE(flwp)
+    ALLOCATE(flwp(klon))
+
+    IF (ALLOCATED(flwc)) DEALLOCATE(flwc)
+    ALLOCATE(flwc(klon,klev))
+
+    IF (ALLOCATED(fraca)) DEALLOCATE(fraca)
+    ALLOCATE(fraca(klon,klev+1))
+
+    IF (ALLOCATED(frugs)) DEALLOCATE(frugs)
+    ALLOCATE(frugs(klon,nbsrf))
+
+    IF (ALLOCATED(fsollw)) DEALLOCATE(fsollw)
+    ALLOCATE(fsollw(klon,nbsrf))
+
+    IF (ALLOCATED(fsolsw)) DEALLOCATE(fsolsw)
+    ALLOCATE(fsolsw(klon,nbsrf))
+
+    IF (ALLOCATED(fsolw)) DEALLOCATE(fsolw)
+    ALLOCATE(fsolw(klon,nbsrf))
+
+    IF (ALLOCATED(lambda_th)) DEALLOCATE(lambda_th)
+    ALLOCATE(lambda_th(klon,klev))
+
+    IF (ALLOCATED(lmax_th)) DEALLOCATE(lmax_th)
+    ALLOCATE(lmax_th(klon))
+
+    IF (ALLOCATED(mc)) DEALLOCATE(mc)
+    ALLOCATE(mc(klon,klev))
+
+    IF (ALLOCATED(omega)) DEALLOCATE(omega)
+    ALLOCATE(omega(klon,klev))
+
+    IF (ALLOCATED(plcl)) DEALLOCATE(plcl)
+    ALLOCATE(plcl(klon))
+
+    IF (ALLOCATED(plfc)) DEALLOCATE(plfc)
+    ALLOCATE(plfc(klon))
+
+    IF (ALLOCATED(pmfd)) DEALLOCATE(pmfd)
+    ALLOCATE(pmfd(klon,klev))
+
+    IF (ALLOCATED(pmflxr)) DEALLOCATE(pmflxr)
+    ALLOCATE(pmflxr(klon,klev+1))
+
+    IF (ALLOCATED(pmflxs)) DEALLOCATE(pmflxs)
+    ALLOCATE(pmflxs(klon,klev+1))
+
+    IF (ALLOCATED(pmfu)) DEALLOCATE(pmfu)
+    ALLOCATE(pmfu(klon,klev))
+
+    IF (ALLOCATED(prfl)) DEALLOCATE(prfl)
+    ALLOCATE(prfl(klon,klev+1))
+
+    IF (ALLOCATED(prw)) DEALLOCATE(prw)
+    ALLOCATE(prw(klon))
+
+    IF (ALLOCATED(psfl)) DEALLOCATE(psfl)
+    ALLOCATE(psfl(klon,klev+1))
+
+    IF (ALLOCATED(ptconv)) DEALLOCATE(ptconv)
+    ALLOCATE(ptconv(klon,klev))
+
+    IF (ALLOCATED(qsat2m)) DEALLOCATE(qsat2m)
+    ALLOCATE(qsat2m(klon))
+
+    IF (ALLOCATED(qsol)) DEALLOCATE(qsol)
+    ALLOCATE(qsol(klon))
+
+    IF (ALLOCATED(qsol_d)) DEALLOCATE(qsol_d)
+    ALLOCATE(qsol_d(klon,nbsrf))
+
+    IF (ALLOCATED(rain_lsc)) DEALLOCATE(rain_lsc)
+    ALLOCATE(rain_lsc(klon))
+
+    IF (ALLOCATED(re)) DEALLOCATE(re)
+    ALLOCATE(re(klon,klev))
+
+    IF (ALLOCATED(ref_ice)) DEALLOCATE(ref_ice)
+    ALLOCATE(ref_ice(klon,klev))
+
+    IF (ALLOCATED(ref_liq)) DEALLOCATE(ref_liq)
+    ALLOCATE(ref_liq(klon,klev))
+
+    IF (ALLOCATED(rh2m)) DEALLOCATE(rh2m)
+    ALLOCATE(rh2m(klon))
+
+    IF (ALLOCATED(rneb)) DEALLOCATE(rneb)
+    ALLOCATE(rneb(klon,klev))
+
+    IF (ALLOCATED(s_lcl)) DEALLOCATE(s_lcl)
+    ALLOCATE(s_lcl(klon))
+
+    IF (ALLOCATED(s_pblh)) DEALLOCATE(s_pblh)
+    ALLOCATE(s_pblh(klon))
+
+    IF (ALLOCATED(s_pblt)) DEALLOCATE(s_pblt)
+    ALLOCATE(s_pblt(klon))
+
+    IF (ALLOCATED(s_therm)) DEALLOCATE(s_therm)
+    ALLOCATE(s_therm(klon))
+
+    IF (ALLOCATED(sens)) DEALLOCATE(sens)
+    ALLOCATE(sens(klon))
+
+    IF (ALLOCATED(slp)) DEALLOCATE(slp)
+    ALLOCATE(slp(klon))
+
+    IF (ALLOCATED(snow_lsc)) DEALLOCATE(snow_lsc)
+    ALLOCATE(snow_lsc(klon))
+
+    IF (ALLOCATED(t2m)) DEALLOCATE(t2m)
+    ALLOCATE(t2m(klon,nbsrf))
+
+    IF (ALLOCATED(theta)) DEALLOCATE(theta)
+    ALLOCATE(theta(klon,klev))
+
+    IF (ALLOCATED(tpot)) DEALLOCATE(tpot)
+    ALLOCATE(tpot(klon))
+
+    IF (ALLOCATED(tpote)) DEALLOCATE(tpote)
+    ALLOCATE(tpote(klon))
+
+    IF (ALLOCATED(ue)) DEALLOCATE(ue)
+    ALLOCATE(ue(klon))
+
+    IF (ALLOCATED(upwd)) DEALLOCATE(upwd)
+    ALLOCATE(upwd(klon,klev))
+
+    IF (ALLOCATED(uq)) DEALLOCATE(uq)
+    ALLOCATE(uq(klon))
+
+    IF (ALLOCATED(ve)) DEALLOCATE(ve)
+    ALLOCATE(ve(klon))
+
+    IF (ALLOCATED(Vprecip)) DEALLOCATE(Vprecip)
+    ALLOCATE(Vprecip(klon,klev+1))
+
+    IF (ALLOCATED(vq)) DEALLOCATE(vq)
+    ALLOCATE(vq(klon))
+
+    IF (ALLOCATED(wake_omg)) DEALLOCATE(wake_omg)
+    ALLOCATE(wake_omg(klon,klev))
+
+    IF (ALLOCATED(wake_h)) DEALLOCATE(wake_h)
+    ALLOCATE(wake_h(klon))
+
+    IF (ALLOCATED(weak_inversion)) DEALLOCATE(weak_inversion)
+    ALLOCATE(weak_inversion(klon))
+
+    IF (ALLOCATED(wbeff)) DEALLOCATE(wbeff)
+    ALLOCATE(wbeff(klon))
+
+    IF (ALLOCATED(wdtrainA)) DEALLOCATE(wdtrainA)
+    ALLOCATE(wdtrainA(klon,klev))
+
+    IF (ALLOCATED(wdtrainM)) DEALLOCATE(wdtrainM)
+    ALLOCATE(wdtrainM(klon,klev))
+
+    IF (ALLOCATED(wfbilo)) DEALLOCATE(wfbilo)
+    ALLOCATE(wfbilo(klon,nbsrf))
+
+    IF (ALLOCATED(wfbils)) DEALLOCATE(wfbils)
+    ALLOCATE(wfbils(klon,nbsrf))
+
+    IF (ALLOCATED(zmasse)) DEALLOCATE(zmasse)
+    ALLOCATE(zmasse(klon,klev))
+
+    IF (ALLOCATED(zmax_th)) DEALLOCATE(zmax_th)
+    ALLOCATE(zmax_th(klon))
+
+    IF (ALLOCATED(zphi)) DEALLOCATE(zphi)
+    ALLOCATE(zphi(klon,klev))
+
+    IF (ALLOCATED(zq2m)) DEALLOCATE(zq2m)
+    ALLOCATE(zq2m(klon))
+
+    IF (ALLOCATED(zt2m)) DEALLOCATE(zt2m)
+    ALLOCATE(zt2m(klon))
+
+    IF (ALLOCATED(zu10m)) DEALLOCATE(zu10m)
+    ALLOCATE(zu10m(klon))
+
+    IF (ALLOCATED(zustar)) DEALLOCATE(zustar)
+    ALLOCATE(zustar(klon))
+
+    IF (ALLOCATED(zv10m)) DEALLOCATE(zv10m)
+    ALLOCATE(zv10m(klon))
+
+    IF (ALLOCATED(zx_rh)) DEALLOCATE(zx_rh)
+    ALLOCATE(zx_rh(klon,klev))
+
+    IF (ALLOCATED(zxffonte)) DEALLOCATE(zxffonte)
+    ALLOCATE(zxffonte(klon))
+
+    IF (ALLOCATED(zxfluxlat)) DEALLOCATE(zxfluxlat)
+    ALLOCATE(zxfluxlat(klon))
+
+    IF (ALLOCATED(zxfqcalving)) DEALLOCATE(zxfqcalving)
+    ALLOCATE(zxfqcalving(klon))
+
+    IF (ALLOCATED(zxfqfonte)) DEALLOCATE(zxfqfonte)
+    ALLOCATE(zxfqfonte(klon))
+
+    IF (ALLOCATED(zxqsurf)) DEALLOCATE(zxqsurf)
+    ALLOCATE(zxqsurf(klon))
+
+    IF (ALLOCATED(zxrugs)) DEALLOCATE(zxrugs)
+    ALLOCATE(zxrugs(klon))
+
+    IF (ALLOCATED(zxsnow)) DEALLOCATE(zxsnow)
+    ALLOCATE(zxsnow(klon))
+
+    IF (ALLOCATED(zxtsol)) DEALLOCATE(zxtsol)
+    ALLOCATE(zxtsol(klon))
+
+  END SUBROUTINE init_ovars_lmdz_NOmodule
+
+  SUBROUTINE end_ovars_lmdz_NOmodule()
+! Subroutine to de-activate all the output variables without module
+
+    IMPLICIT NONE
+
+    IF (ALLOCATED(agesno)) DEALLOCATE(agesno)
+
+    IF (ALLOCATED(ale_wake)) DEALLOCATE(ale_wake)
+
+    IF (ALLOCATED(alp_wake)) DEALLOCATE(alp_wake)
+
+    IF (ALLOCATED(beta_prec)) DEALLOCATE(beta_prec)
+
+    IF (ALLOCATED(bils)) DEALLOCATE(bils)
+
+    IF (ALLOCATED(cdragh)) DEALLOCATE(cdragh)
+
+    IF (ALLOCATED(cdragm)) DEALLOCATE(cdragm)
+
+    IF (ALLOCATED(cldh)) DEALLOCATE(cldh)
+
+    IF (ALLOCATED(cldl)) DEALLOCATE(cldl)
+
+    IF (ALLOCATED(cldm)) DEALLOCATE(cldm)
+
+    IF (ALLOCATED(cldq)) DEALLOCATE(cldq)
+
+    IF (ALLOCATED(cldt)) DEALLOCATE(cldt)
+
+    IF (ALLOCATED(cldemi)) DEALLOCATE(cldemi)
+
+    IF (ALLOCATED(cldfra)) DEALLOCATE(cldfra)
+
+    IF (ALLOCATED(cldtau)) DEALLOCATE(cldtau)
+
+    IF (ALLOCATED(dnwd)) DEALLOCATE(dnwd)
+
+    IF (ALLOCATED(dnwd0)) DEALLOCATE(dnwd0)
+
+    IF (ALLOCATED(dthmin)) DEALLOCATE(dthmin)
+
+    IF (ALLOCATED(evap)) DEALLOCATE(evap)
+
+    IF (ALLOCATED(evap_pot)) DEALLOCATE(evap_pot)
+
+    IF (ALLOCATED(evap_srf)) DEALLOCATE(evap_srf)
+
+    IF (ALLOCATED(evappot_srf)) DEALLOCATE(evappot_srf)
+
+    IF (ALLOCATED(fder)) DEALLOCATE(fder)
+
+    IF (ALLOCATED(fevap)) DEALLOCATE(fevap)
+
+    IF (ALLOCATED(fiwc)) DEALLOCATE(fiwc)
+
+    IF (ALLOCATED(fiwp)) DEALLOCATE(fiwp)
+
+    IF (ALLOCATED(fl)) DEALLOCATE(fl)
+
+    IF (ALLOCATED(fluxlat)) DEALLOCATE(fluxlat)
+
+    IF (ALLOCATED(fluxt)) DEALLOCATE(fluxt)
+
+    IF (ALLOCATED(fluxu)) DEALLOCATE(fluxu)
+
+    IF (ALLOCATED(fluxv)) DEALLOCATE(fluxv)
+
+    IF (ALLOCATED(flwp)) DEALLOCATE(flwp)
+
+    IF (ALLOCATED(flwc)) DEALLOCATE(flwc)
+
+    IF (ALLOCATED(fraca)) DEALLOCATE(fraca)
+
+    IF (ALLOCATED(frugs)) DEALLOCATE(frugs)
+
+    IF (ALLOCATED(fsollw)) DEALLOCATE(fsollw)
+
+    IF (ALLOCATED(fsolsw)) DEALLOCATE(fsolsw)
+
+    IF (ALLOCATED(fsolw)) DEALLOCATE(fsolw)
+
+    IF (ALLOCATED(lambda_th)) DEALLOCATE(lambda_th)
+
+    IF (ALLOCATED(lmax_th)) DEALLOCATE(lmax_th)
+
+    IF (ALLOCATED(mc)) DEALLOCATE(mc)
+
+    IF (ALLOCATED(omega)) DEALLOCATE(omega)
+
+    IF (ALLOCATED(plcl)) DEALLOCATE(plcl)
+
+    IF (ALLOCATED(plfc)) DEALLOCATE(plfc)
+
+    IF (ALLOCATED(pmfd)) DEALLOCATE(pmfd)
+
+    IF (ALLOCATED(pmflxr)) DEALLOCATE(pmflxr)
+
+    IF (ALLOCATED(pmflxs)) DEALLOCATE(pmflxs)
+
+    IF (ALLOCATED(pmfu)) DEALLOCATE(pmfu)
+
+    IF (ALLOCATED(prfl)) DEALLOCATE(prfl)
+
+    IF (ALLOCATED(prw)) DEALLOCATE(prw)
+
+    IF (ALLOCATED(psfl)) DEALLOCATE(psfl)
+
+    IF (ALLOCATED(ptconv)) DEALLOCATE(ptconv)
+
+    IF (ALLOCATED(qsat2m)) DEALLOCATE(qsat2m)
+
+    IF (ALLOCATED(qsol)) DEALLOCATE(qsol)
+
+    IF (ALLOCATED(qsol_d)) DEALLOCATE(qsol_d)
+
+    IF (ALLOCATED(rain_lsc)) DEALLOCATE(rain_lsc)
+
+    IF (ALLOCATED(re)) DEALLOCATE(re)
+
+    IF (ALLOCATED(ref_ice)) DEALLOCATE(ref_ice)
+
+    IF (ALLOCATED(ref_liq)) DEALLOCATE(ref_liq)
+
+    IF (ALLOCATED(rh2m)) DEALLOCATE(rh2m)
+
+    IF (ALLOCATED(rneb)) DEALLOCATE(rneb)
+
+    IF (ALLOCATED(s_lcl)) DEALLOCATE(s_lcl)
+
+    IF (ALLOCATED(s_pblh)) DEALLOCATE(s_pblh)
+
+    IF (ALLOCATED(s_pblt)) DEALLOCATE(s_pblt)
+
+    IF (ALLOCATED(s_therm)) DEALLOCATE(s_therm)
+
+    IF (ALLOCATED(sens)) DEALLOCATE(sens)
+
+    IF (ALLOCATED(slp)) DEALLOCATE(slp)
+
+    IF (ALLOCATED(snow_lsc)) DEALLOCATE(snow_lsc)
+
+    IF (ALLOCATED(t2m)) DEALLOCATE(t2m)
+
+    IF (ALLOCATED(theta)) DEALLOCATE(theta)
+
+    IF (ALLOCATED(tpot)) DEALLOCATE(tpot)
+
+    IF (ALLOCATED(tpote)) DEALLOCATE(tpote)
+
+    IF (ALLOCATED(ue)) DEALLOCATE(ue)
+
+    IF (ALLOCATED(upwd)) DEALLOCATE(upwd)
+
+    IF (ALLOCATED(uq)) DEALLOCATE(uq)
+
+    IF (ALLOCATED(ve)) DEALLOCATE(ve)
+
+    IF (ALLOCATED(Vprecip)) DEALLOCATE(Vprecip)
+
+    IF (ALLOCATED(vq)) DEALLOCATE(vq)
+
+    IF (ALLOCATED(wake_omg)) DEALLOCATE(wake_omg)
+
+    IF (ALLOCATED(wake_h)) DEALLOCATE(wake_h)
+
+    IF (ALLOCATED(weak_inversion)) DEALLOCATE(weak_inversion)
+
+    IF (ALLOCATED(wbeff)) DEALLOCATE(wbeff)
+
+    IF (ALLOCATED(wdtrainA)) DEALLOCATE(wdtrainA)
+
+    IF (ALLOCATED(wdtrainM)) DEALLOCATE(wdtrainM)
+
+    IF (ALLOCATED(wfbilo)) DEALLOCATE(wfbilo)
+
+    IF (ALLOCATED(wfbils)) DEALLOCATE(wfbils)
+
+    IF (ALLOCATED(zmasse)) DEALLOCATE(zmasse)
+
+    IF (ALLOCATED(zmax_th)) DEALLOCATE(zmax_th)
+
+    IF (ALLOCATED(zphi)) DEALLOCATE(zphi)
+
+    IF (ALLOCATED(zq2m)) DEALLOCATE(zq2m)
+
+    IF (ALLOCATED(zt2m)) DEALLOCATE(zt2m)
+
+    IF (ALLOCATED(zu10m)) DEALLOCATE(zu10m)
+
+    IF (ALLOCATED(zustar)) DEALLOCATE(zustar)
+
+    IF (ALLOCATED(zv10m)) DEALLOCATE(zv10m)
+
+    IF (ALLOCATED(zx_rh)) DEALLOCATE(zx_rh)
+
+    IF (ALLOCATED(zxffonte)) DEALLOCATE(zxffonte)
+
+    IF (ALLOCATED(zxfluxlat)) DEALLOCATE(zxfluxlat)
+
+    IF (ALLOCATED(zxfqcalving)) DEALLOCATE(zxfqcalving)
+
+    IF (ALLOCATED(zxfqfonte)) DEALLOCATE(zxfqfonte)
+
+    IF (ALLOCATED(zxqsurf)) DEALLOCATE(zxqsurf)
+
+    IF (ALLOCATED(zxrugs)) DEALLOCATE(zxrugs)
+
+    IF (ALLOCATED(zxsnow)) DEALLOCATE(zxsnow)
+
+    IF (ALLOCATED(zxtsol)) DEALLOCATE(zxtsol)
+
+  END SUBROUTINE end_ovars_lmdz_NOmodule
+
+
+END MODULE output_lmdz_NOmodule
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ozonecm_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ozonecm_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ozonecm_m.F90	(revision 17)
@@ -0,0 +1,92 @@
+! $Header$
+module ozonecm_m
+
+  IMPLICIT NONE
+
+contains
+
+  function ozonecm(rlat, paprs, rjour)
+
+    ! The ozone climatology is based on an analytic formula which fits the
+    ! Krueger and Mintzner (1976) profile, as well as the variations with
+    ! altitude and latitude of the maximum ozone concentrations and the total
+    ! column ozone concentration of Keating and Young (1986). The analytic
+    ! formula have been established by J.-F. Royer (CRNM, Meteo France), who
+    ! also provided us the code.
+
+    ! A. J. Krueger and R. A. Minzner, A Mid-Latitude Ozone Model for the
+    ! 1976 U.S. Standard Atmosphere, J. Geophys. Res., 81, 4477, (1976).
+
+    ! Keating, G. M. and D. F. Young, 1985: Interim reference models for the
+    ! middle atmosphere, Handbook for MAP, vol. 16, 205-229.
+
+    USE dimphy, only: klon, klev
+    use assert_m, only: assert
+
+    REAL, INTENT (IN) :: rlat(:) ! (klon)
+    REAL, INTENT (IN) :: paprs(:, :) ! (klon,klev+1)
+    REAL, INTENT (IN) :: rjour
+
+    REAL ozonecm(klon,klev)
+    ! "ozonecm(j, k)" is the column-density of ozone in cell "(j, k)", that is
+    ! between interface "k" and interface "k + 1", in kDU.
+
+    ! Variables local to the procedure:
+
+    REAL tozon ! equivalent pressure of ozone above interface "k", in Pa
+    real pi, pl
+    INTEGER i, k
+
+    REAL field(klon,klev+1)
+    ! "field(:, k)" is the column-density of ozone between interface
+    ! "k" and the top of the atmosphere (interface "llm + 1"), in kDU.
+
+    real, PARAMETER:: ps=101325.
+    REAL, parameter:: an = 360., zo3q3 = 4E-8
+    REAL, parameter:: dobson_unit = 2.1415E-5 ! in kg m-2
+    REAL gms, zslat, zsint, zcost, z, ppm, qpm, a
+    REAL asec, bsec, aprim, zo3a3
+
+    !----------------------------------------------------------
+
+    call assert((/size(rlat), size(paprs, 1)/) == klon, "ozonecm klon")
+    call assert(size(paprs, 2) == klev + 1, "ozonecm klev")
+
+    pi = 4. * atan(1.)
+    DO k = 1, klev
+       DO i = 1, klon
+          zslat = sin(pi / 180. * rlat(i))
+          zsint = sin(2 * pi * (rjour + 15.) / an)
+          zcost = cos(2 * pi * (rjour + 15.) / an)
+          z = 0.0531 + zsint * (-0.001595+0.009443*zslat) &
+               + zcost * (-0.001344-0.00346*zslat) &
+               + zslat**2 * (.056222 + zslat**2 &
+               * (-.037609+.012248*zsint+.00521*zcost+.008890*zslat))
+          zo3a3 = zo3q3/ps/2.
+          z = z - zo3q3*ps
+          gms = z
+          ppm = 800. - (500.*zslat+150.*zcost)*zslat
+          qpm = 1.74E-5 - (7.5E-6*zslat+1.7E-6*zcost)*zslat
+          bsec = 2650. + 5000.*zslat**2
+          a = 4.0*(bsec)**(3./2.)*(ppm)**(3./2.)*(1.0+(bsec/ps)**(3./2.))
+          a = a/(bsec**(3./2.)+ppm**(3./2.))**2
+          aprim = (2.666666*qpm*ppm-a*gms)/(1.0-a)
+          aprim = amax1(0., aprim)
+          asec = (gms-aprim)*(1.0+(bsec/ps)**(3./2.))
+          asec = amax1(0.0, asec)
+          aprim = gms - asec/(1.+(bsec/ps)**(3./2.))
+          pl = paprs(i, k)
+          tozon = aprim / (1. + 3. * (ppm / pl)**2) &
+               + asec / (1. + (bsec / pl)**(3./2.)) + zo3a3 * pl * pl
+          ! Convert from Pa to kDU:
+          field(i, k) = tozon / 9.81 / dobson_unit / 1e3
+       END DO
+    END DO
+
+    field(:,klev+1) = 0.
+    forall (k = 1: klev) ozonecm(:,k) = field(:,k) - field(:,k+1)
+    ozonecm = max(ozonecm, 1e-12)
+
+  END function ozonecm
+
+end module ozonecm_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/paramet.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/paramet.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/paramet.h	(revision 17)
@@ -0,0 +1,29 @@
+!
+! $Header$
+!
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+!-----------------------------------------------------------------------
+!   INCLUDE 'paramet.h'
+
+      INTEGER  iip1,iip2,iip3,jjp1,llmp1,llmp2,llmm1
+      INTEGER  kftd,ip1jm,ip1jmp1,ip1jmi1,ijp1llm
+      INTEGER  ijmllm,mvar
+      INTEGER jcfil,jcfllm
+
+      PARAMETER( iip1= iim+1,iip2=iim+2,iip3=iim+3                       &
+     &    ,jjp1=jjm+1-1/jjm)
+      PARAMETER( llmp1 = llm+1,  llmp2 = llm+2, llmm1 = llm-1 )
+      PARAMETER( kftd  = iim/2 -ndm )
+      PARAMETER( ip1jm  = iip1*jjm,  ip1jmp1= iip1*jjp1 )
+      PARAMETER( ip1jmi1= ip1jm - iip1 )
+      PARAMETER( ijp1llm= ip1jmp1 * llm, ijmllm= ip1jm * llm )
+      PARAMETER( mvar= ip1jmp1*( 2*llm+1) + ijmllm )
+      PARAMETER( jcfil=jjm/2+5, jcfllm=jcfil*llm )
+
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/pbl_surface_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/pbl_surface_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/pbl_surface_mod.F90	(revision 17)
@@ -0,0 +1,1542 @@
+!
+! $Id: pbl_surface_mod.F90 1795 2013-07-18 08:20:28Z emillour $
+!
+MODULE pbl_surface_mod
+!
+! Planetary Boundary Layer and Surface module
+!
+! This module manage the calculation of turbulent diffusion in the boundary layer 
+! and all interactions towards the differents sub-surfaces.
+!
+!
+  USE dimphy
+  USE mod_phys_lmdz_para,  ONLY : mpi_size
+  USE ioipsl
+  USE surface_data,        ONLY : type_ocean, ok_veget
+  USE surf_land_mod,       ONLY : surf_land
+  USE surf_landice_mod,    ONLY : surf_landice
+  USE surf_ocean_mod,      ONLY : surf_ocean
+  USE surf_seaice_mod,     ONLY : surf_seaice
+  USE cpl_mod,             ONLY : gath2cpl
+  USE climb_hq_mod,        ONLY : climb_hq_down, climb_hq_up
+  USE climb_wind_mod,      ONLY : climb_wind_down, climb_wind_up
+  USE coef_diff_turb_mod,  ONLY : coef_diff_turb
+  USE control_mod
+
+
+  IMPLICIT NONE
+
+! Declaration of variables saved in restart file
+! L. Fita, removing 'PRIVATE' flag i norder to be accessed by WRF. LMD, November 2013
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: qsol   ! water height in the soil (mm)
+!  REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: qsol   ! water height in the soil (mm)
+!$OMP THREADPRIVATE(qsol)
+  REAL, ALLOCATABLE, DIMENSION(:), PRIVATE, SAVE     :: fder   ! flux drift
+!  REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: fder   ! flux drift
+!$OMP THREADPRIVATE(fder)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: snow   ! snow at surface
+!  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: snow   ! snow at surface
+!$OMP THREADPRIVATE(snow)
+!  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: qsurf  ! humidity at surface
+  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: qsurf  ! humidity at surface
+!$OMP THREADPRIVATE(qsurf)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: evap   ! evaporation at surface
+!  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: evap   ! evaporation at surface
+!$OMP THREADPRIVATE(evap)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: rugos  ! rugosity at surface (m)
+!  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: rugos  ! rugosity at surface (m)
+!$OMP THREADPRIVATE(rugos)
+  REAL, ALLOCATABLE, DIMENSION(:,:), PRIVATE, SAVE   :: agesno ! age of snow at surface
+!  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: agesno ! age of snow at surface
+!$OMP THREADPRIVATE(agesno)
+! Correction pour le cas AMMA (PRIVATE)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: ftsoil ! soil temperature
+!  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: ftsoil ! soil temperature
+!$OMP THREADPRIVATE(ftsoil)
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE pbl_surface_init(qsol_rst, fder_rst, snow_rst, qsurf_rst,&
+       evap_rst, rugos_rst, agesno_rst, ftsoil_rst)
+
+! This routine should be called after the restart file has been read.
+! This routine initialize the restart variables and does some validation tests
+! for the index of the different surfaces and tests the choice of type of ocean.
+
+    USE indice_sol_mod
+
+    INCLUDE "dimsoil.h"
+    INCLUDE "iniprint.h"
+ 
+! Input variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(IN)                 :: qsol_rst
+    REAL, DIMENSION(klon), INTENT(IN)                 :: fder_rst
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: snow_rst
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: qsurf_rst
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: evap_rst
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: rugos_rst
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN)          :: agesno_rst
+    REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(IN) :: ftsoil_rst
+
+  
+! Local variables
+!****************************************************************************************
+    INTEGER                       :: ierr
+    CHARACTER(len=80)             :: abort_message
+    CHARACTER(len = 20)           :: modname = 'pbl_surface_init'
+    
+
+!****************************************************************************************
+! Allocate and initialize module variables with fields read from restart file.
+!
+!****************************************************************************************    
+    ALLOCATE(qsol(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+    ALLOCATE(fder(klon), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+    ALLOCATE(snow(klon,nbsrf), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+    ALLOCATE(qsurf(klon,nbsrf), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+    ALLOCATE(evap(klon,nbsrf), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+    ALLOCATE(rugos(klon,nbsrf), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+    ALLOCATE(agesno(klon,nbsrf), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+    ALLOCATE(ftsoil(klon,nsoilmx,nbsrf), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('pbl_surface_init', 'pb in allocation',1)
+
+
+    qsol(:)       = qsol_rst(:)
+    fder(:)       = fder_rst(:)
+    snow(:,:)     = snow_rst(:,:)
+    qsurf(:,:)    = qsurf_rst(:,:)
+    evap(:,:)     = evap_rst(:,:)
+    rugos(:,:)    = rugos_rst(:,:)
+    agesno(:,:)   = agesno_rst(:,:)
+    ftsoil(:,:,:) = ftsoil_rst(:,:,:)
+
+
+!****************************************************************************************
+! Test for sub-surface indices
+!
+!****************************************************************************************
+    IF (is_ter /= 1) THEN 
+      WRITE(lunout,*)" *** Warning ***"
+      WRITE(lunout,*)" is_ter n'est pas le premier surface, is_ter = ",is_ter
+      WRITE(lunout,*)"or on doit commencer par les surfaces continentales"
+      abort_message="voir ci-dessus"
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    IF ( is_oce > is_sic ) THEN
+      WRITE(lunout,*)' *** Warning ***'
+      WRITE(lunout,*)' Pour des raisons de sequencement dans le code'
+      WRITE(lunout,*)' l''ocean doit etre traite avant la banquise'
+      WRITE(lunout,*)' or is_oce = ',is_oce, '> is_sic = ',is_sic
+      abort_message='voir ci-dessus'
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+    IF ( is_lic > is_sic ) THEN
+      WRITE(lunout,*)' *** Warning ***'
+      WRITE(lunout,*)' Pour des raisons de sequencement dans le code'
+      WRITE(lunout,*)' la glace contineltalle doit etre traite avant la glace de mer'
+      WRITE(lunout,*)' or is_lic = ',is_lic, '> is_sic = ',is_sic
+      abort_message='voir ci-dessus'
+      CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+!****************************************************************************************
+! Validation of ocean mode
+!
+!****************************************************************************************
+
+    IF (type_ocean /= 'slab  ' .AND. type_ocean /= 'force ' .AND. type_ocean /= 'couple') THEN
+       WRITE(lunout,*)' *** Warning ***'
+       WRITE(lunout,*)'Option couplage pour l''ocean = ', type_ocean
+       abort_message='option pour l''ocean non valable'
+       CALL abort_gcm(modname,abort_message,1)
+    ENDIF
+
+  END SUBROUTINE pbl_surface_init
+!  
+!****************************************************************************************
+!  
+
+  SUBROUTINE pbl_surface( &
+       dtime,     date0,     itap,     jour,          &
+       debut,     lafin,                              &
+       rlon,      rlat,      rugoro,   rmu0,          &
+       rain_f,    snow_f,    solsw_m,  sollw_m,       &
+       t,         q,         u,        v,             &
+       pplay,     paprs,     pctsrf,                  &
+       ts,        alb1,      alb2,ustar, u10m, v10m,  &
+       lwdown_m,  cdragh,    cdragm,   zu1,    zv1,   &
+       alb1_m,    alb2_m,    zxsens,   zxevap,        &
+       zxtsol,    zxfluxlat, zt2m,     qsat2m,        &
+       d_t,       d_q,       d_u,      d_v, d_t_diss, & 
+       zcoefh,    zcoefm,    slab_wfbils,             &
+       qsol_d,    zq2m,      s_pblh,   s_plcl,        &
+       s_capCL,   s_oliqCL,  s_cteiCL, s_pblT,        &
+       s_therm,   s_trmb1,   s_trmb2,  s_trmb3,       &
+       zxrugs,zustar,zu10m,  zv10m,    fder_print,    &
+       zxqsurf,   rh2m,      zxfluxu,  zxfluxv,       &
+       rugos_d,   agesno_d,  sollw,    solsw,         &
+       d_ts,      evap_d,    fluxlat,  t2m,           &
+       wfbils,    wfbilo,    flux_t,   flux_u, flux_v,&
+       dflux_t,   dflux_q,   zxsnow,                  &
+       zxfluxt,   zxfluxq,   q2m,      flux_q, tke    )
+!****************************************************************************************
+! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+! Objet: interface de "couche limite" (diffusion verticale)
+!
+!AA REM:
+!AA-----
+!AA Tout ce qui a trait au traceurs est dans phytrac maintenant
+!AA pour l'instant le calcul de la couche limite pour les traceurs
+!AA se fait avec cltrac et ne tient pas compte de la differentiation
+!AA des sous-fraction de sol.
+!AA REM bis :
+!AA----------
+!AA Pour pouvoir extraire les coefficient d'echanges et le vent 
+!AA dans la premiere couche, 3 champs supplementaires ont ete crees
+!AA zcoefh, zu1 et zv1. Pour l'instant nous avons moyenne les valeurs
+!AA de ces trois champs sur les 4 subsurfaces du modele. Dans l'avenir 
+!AA si les informations des subsurfaces doivent etre prises en compte
+!AA il faudra sortir ces memes champs en leur ajoutant une dimension, 
+!AA c'est a dire nbsrf (nbre de subsurface).
+!
+! Arguments:
+!
+! dtime----input-R- interval du temps (secondes)
+! itap-----input-I- numero du pas de temps
+! date0----input-R- jour initial
+! t--------input-R- temperature (K)
+! q--------input-R- vapeur d'eau (kg/kg)
+! u--------input-R- vitesse u
+! v--------input-R- vitesse v
+! ts-------input-R- temperature du sol (en Kelvin)
+! paprs----input-R- pression a intercouche (Pa)
+! pplay----input-R- pression au milieu de couche (Pa)
+! rlat-----input-R- latitude en degree
+! rugos----input-R- longeur de rugosite (en m)
+!
+! d_t------output-R- le changement pour "t"
+! d_q------output-R- le changement pour "q"
+! d_u------output-R- le changement pour "u"
+! d_v------output-R- le changement pour "v"
+! d_ts-----output-R- le changement pour "ts"
+! flux_t---output-R- flux de chaleur sensible (CpT) J/m**2/s (W/m**2)
+!                    (orientation positive vers le bas)
+! tke---input/output-R- tke (kg/m**2/s)
+! flux_q---output-R- flux de vapeur d'eau (kg/m**2/s)
+! flux_u---output-R- tension du vent X: (kg m/s)/(m**2 s) ou Pascal
+! flux_v---output-R- tension du vent Y: (kg m/s)/(m**2 s) ou Pascal
+! dflux_t--output-R- derive du flux sensible
+! dflux_q--output-R- derive du flux latent
+! zu1------output-R- le vent dans la premiere couche
+! zv1------output-R- le vent dans la premiere couche
+! trmb1----output-R- deep_cape
+! trmb2----output-R- inhibition 
+! trmb3----output-R- Point Omega
+! cteiCL---output-R- Critere d'instab d'entrainmt des nuages de CL
+! plcl-----output-R- Niveau de condensation
+! pblh-----output-R- HCL
+! pblT-----output-R- T au nveau HCL
+!
+    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send
+    USE indice_sol_mod
+
+    IMPLICIT NONE
+
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "FCTTRE.h"
+    INCLUDE "clesphys.h"
+    INCLUDE "compbl.h"
+    INCLUDE "dimensions.h"
+    INCLUDE "YOETHF.h"
+    INCLUDE "temps.h"
+!****************************************************************************************
+! Declarations specifiques pour le 1D. A reprendre 
+! Input variables
+!****************************************************************************************
+    REAL,                         INTENT(IN)        :: dtime   ! time interval (s)
+    REAL,                         INTENT(IN)        :: date0   ! initial day
+    INTEGER,                      INTENT(IN)        :: itap    ! time step
+    INTEGER,                      INTENT(IN)        :: jour    ! current day of the year
+    LOGICAL,                      INTENT(IN)        :: debut   ! true if first run step
+    LOGICAL,                      INTENT(IN)        :: lafin   ! true if last run step
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rlon    ! longitudes in degrees
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rlat    ! latitudes in degrees
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rugoro  ! rugosity length
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rmu0    ! cosine of solar zenith angle
+    REAL, DIMENSION(klon),        INTENT(IN)        :: rain_f  ! rain fall
+    REAL, DIMENSION(klon),        INTENT(IN)        :: snow_f  ! snow fall
+    REAL, DIMENSION(klon),        INTENT(IN)        :: solsw_m ! net shortwave radiation at mean surface
+    REAL, DIMENSION(klon),        INTENT(IN)        :: sollw_m ! net longwave radiation at mean surface
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: t       ! temperature (K)
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: q       ! water vapour (kg/kg)
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: u       ! u speed
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: v       ! v speed
+    REAL, DIMENSION(klon,klev),   INTENT(IN)        :: pplay   ! mid-layer pression (Pa)
+    REAL, DIMENSION(klon,klev+1), INTENT(IN)        :: paprs   ! pression between layers (Pa) 
+    REAL, DIMENSION(klon, nbsrf), INTENT(IN)        :: pctsrf  ! sub-surface fraction
+
+! Input/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: ts      ! temperature at surface (K)
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: alb1    ! albedo in visible SW interval
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: alb2    ! albedo in near infra-red SW interval
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: ustar   ! u* (m/s)
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: u10m    ! u speed at 10m
+    REAL, DIMENSION(klon, nbsrf), INTENT(INOUT)     :: v10m    ! v speed at 10m
+    REAL, DIMENSION(klon, klev+1, nbsrf+1), INTENT(INOUT) :: tke 
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: lwdown_m   ! Downcoming longwave radiation
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: cdragh     ! drag coefficient for T and Q
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: cdragm     ! drag coefficient for wind
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zu1        ! u wind speed in first layer
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zv1        ! v wind speed in first layer
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: alb1_m     ! mean albedo in visible SW interval
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: alb2_m     ! mean albedo in near IR SW interval
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxsens     ! sensible heat flux at surface with inversed sign 
+                                                                  ! (=> positive sign upwards)
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxevap     ! water vapour flux at surface, positiv upwards
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxtsol     ! temperature at surface, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxfluxlat  ! latent flux, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zt2m       ! temperature at 2m, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: qsat2m
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_t        ! change in temperature 
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_t_diss       ! change in temperature 
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_q        ! change in water vapour
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_u        ! change in u speed
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: d_v        ! change in v speed
+    REAL, DIMENSION(klon, klev,nbsrf+1),  INTENT(OUT)       :: zcoefh     ! coef for turbulent diffusion of T and Q, mean for each grid point
+    REAL, DIMENSION(klon, klev,nbsrf+1),  INTENT(OUT)       :: zcoefm     ! coef for turbulent diffusion of U and V (?), mean for each grid point
+
+! Output only for diagnostics
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: slab_wfbils! heat balance at surface only for slab at ocean points
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: qsol_d     ! water height in the soil (mm)
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zq2m       ! water vapour at 2m, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_pblh     ! height of the planetary boundary layer(HPBL)
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_plcl     ! condensation level
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_capCL    ! CAPE of PBL
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_oliqCL   ! liquid water intergral of PBL
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_cteiCL   ! cloud top instab. crit. of PBL
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_pblT     ! temperature at PBLH
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_therm    ! thermal virtual temperature excess
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb1    ! deep cape, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb2    ! inhibition, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: s_trmb3    ! point Omega, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxrugs     ! rugosity at surface (m), mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zustar     ! u*
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zu10m      ! u speed at 10m, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zv10m      ! v speed at 10m, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: fder_print ! fder for printing (=fder(i) + dflux_t(i) + dflux_q(i))
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: zxqsurf    ! humidity at surface, mean for each grid point
+    REAL, DIMENSION(klon),        INTENT(OUT)       :: rh2m       ! relative humidity at 2m
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: zxfluxu    ! u wind tension, mean for each grid point
+    REAL, DIMENSION(klon, klev),  INTENT(OUT)       :: zxfluxv    ! v wind tension, mean for each grid point
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: rugos_d    ! rugosity length (m)
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: agesno_d   ! age of snow at surface
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: solsw      ! net shortwave radiation at surface 
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: sollw      ! net longwave radiation at surface
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: d_ts       ! change in temperature at surface
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: evap_d     ! evaporation at surface
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: fluxlat    ! latent flux
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: t2m        ! temperature at 2 meter height
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: wfbils     ! heat balance at surface
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)       :: wfbilo     ! water balance at surface
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_t     ! sensible heat flux (CpT) J/m**2/s (W/m**2)
+                                                                  ! positve orientation downwards
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_u     ! u wind tension (kg m/s)/(m**2 s) or Pascal
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_v     ! v wind tension (kg m/s)/(m**2 s) or Pascal
+
+! Output not needed
+    REAL, DIMENSION(klon),       INTENT(OUT)        :: dflux_t    ! change of sensible heat flux 
+    REAL, DIMENSION(klon),       INTENT(OUT)        :: dflux_q    ! change of water vapour flux
+    REAL, DIMENSION(klon),       INTENT(OUT)        :: zxsnow     ! snow at surface, mean for each grid point
+    REAL, DIMENSION(klon, klev), INTENT(OUT)        :: zxfluxt    ! sensible heat flux, mean for each grid point
+    REAL, DIMENSION(klon, klev), INTENT(OUT)        :: zxfluxq    ! water vapour flux, mean for each grid point
+    REAL, DIMENSION(klon, nbsrf),INTENT(OUT)        :: q2m        ! water vapour at 2 meter height
+    REAL, DIMENSION(klon, klev, nbsrf), INTENT(OUT) :: flux_q     ! water vapour flux(latent flux) (kg/m**2/s)
+
+
+! Local variables with attribute SAVE
+!****************************************************************************************
+    INTEGER, SAVE                            :: nhoridbg, nidbg   ! variables for IOIPSL
+!$OMP THREADPRIVATE(nhoridbg, nidbg)
+    LOGICAL, SAVE                            :: debugindex=.FALSE.
+!$OMP THREADPRIVATE(debugindex)
+    LOGICAL, SAVE                            :: first_call=.TRUE.
+!$OMP THREADPRIVATE(first_call)
+    CHARACTER(len=8), DIMENSION(nbsrf), SAVE :: cl_surf
+!$OMP THREADPRIVATE(cl_surf)
+
+! Other local variables
+!****************************************************************************************
+    INTEGER                            :: i, k, nsrf 
+    INTEGER                            :: knon, j
+    INTEGER                            :: idayref
+    INTEGER , DIMENSION(klon)          :: ni
+    REAL                               :: zx_alf1, zx_alf2 !valeur ambiante par extrapola
+    REAL                               :: amn, amx
+    REAL                               :: f1 ! fraction de longeurs visibles parmi tout SW intervalle
+    REAL, DIMENSION(klon)              :: r_co2_ppm     ! taux CO2 atmosphere
+    REAL, DIMENSION(klon)              :: yts, yrugos, ypct, yz0_new
+    REAL, DIMENSION(klon)              :: yalb, yalb1, yalb2
+    REAL, DIMENSION(klon)              :: yu1, yv1,ytoto
+    REAL, DIMENSION(klon)              :: ysnow, yqsurf, yagesno, yqsol
+    REAL, DIMENSION(klon)              :: yrain_f, ysnow_f
+    REAL, DIMENSION(klon)              :: ysolsw, ysollw
+    REAL, DIMENSION(klon)              :: yfder
+    REAL, DIMENSION(klon)              :: yrugoro
+    REAL, DIMENSION(klon)              :: yfluxlat
+    REAL, DIMENSION(klon)              :: y_d_ts
+    REAL, DIMENSION(klon)              :: y_flux_t1, y_flux_q1
+    REAL, DIMENSION(klon)              :: y_dflux_t, y_dflux_q
+    REAL, DIMENSION(klon)              :: y_flux_u1, y_flux_v1
+    REAL, DIMENSION(klon)              :: yt2m, yq2m, yu10m
+    REAL, DIMENSION(klon)              :: yustar
+    REAL, DIMENSION(klon)              :: ywindsp
+    REAL, DIMENSION(klon)              :: yt10m, yq10m
+    REAL, DIMENSION(klon)              :: ypblh
+    REAL, DIMENSION(klon)              :: ylcl
+    REAL, DIMENSION(klon)              :: ycapCL
+    REAL, DIMENSION(klon)              :: yoliqCL
+    REAL, DIMENSION(klon)              :: ycteiCL
+    REAL, DIMENSION(klon)              :: ypblT
+    REAL, DIMENSION(klon)              :: ytherm
+    REAL, DIMENSION(klon)              :: ytrmb1
+    REAL, DIMENSION(klon)              :: ytrmb2
+    REAL, DIMENSION(klon)              :: ytrmb3
+    REAL, DIMENSION(klon)              :: uzon, vmer
+    REAL, DIMENSION(klon)              :: tair1, qair1, tairsol
+    REAL, DIMENSION(klon)              :: psfce, patm
+    REAL, DIMENSION(klon)              :: qairsol, zgeo1
+    REAL, DIMENSION(klon)              :: rugo1
+    REAL, DIMENSION(klon)              :: yfluxsens
+    REAL, DIMENSION(klon)              :: AcoefH, AcoefQ, BcoefH, BcoefQ
+    REAL, DIMENSION(klon)              :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon)              :: ypsref
+    REAL, DIMENSION(klon)              :: yevap, ytsurf_new, yalb1_new, yalb2_new
+    REAL, DIMENSION(klon)              :: ztsol
+    REAL, DIMENSION(klon)              :: alb_m  ! mean albedo for whole SW interval
+    REAL, DIMENSION(klon,klev)         :: y_d_t, y_d_q, y_d_t_diss
+    REAL, DIMENSION(klon,klev)         :: y_d_u, y_d_v
+    REAL, DIMENSION(klon,klev)         :: y_flux_t, y_flux_q
+    REAL, DIMENSION(klon,klev)         :: y_flux_u, y_flux_v
+    REAL, DIMENSION(klon,klev)         :: ycoefh, ycoefm,ycoefq
+    REAL, DIMENSION(klon)              :: ycdragh, ycdragm
+    REAL, DIMENSION(klon,klev)         :: yu, yv
+    REAL, DIMENSION(klon,klev)         :: yt, yq
+    REAL, DIMENSION(klon,klev)         :: ypplay, ydelp
+    REAL, DIMENSION(klon,klev)         :: delp
+    REAL, DIMENSION(klon,klev+1)       :: ypaprs
+    REAL, DIMENSION(klon,klev+1)       :: ytke
+    REAL, DIMENSION(klon,nsoilmx)      :: ytsoil
+    CHARACTER(len=80)                  :: abort_message
+    CHARACTER(len=20)                  :: modname = 'pbl_surface'
+    LOGICAL, PARAMETER                 :: zxli=.FALSE. ! utiliser un jeu de fonctions simples
+    LOGICAL, PARAMETER                 :: check=.FALSE.
+    REAL, DIMENSION(klon)              :: Kech_h       ! Coefficient d'echange pour l'energie
+
+! For debugging with IOIPSL
+    INTEGER, DIMENSION(iim*(jjm+1))    :: ndexbg
+    REAL                               :: zjulian
+    REAL, DIMENSION(klon)              :: tabindx
+    REAL, DIMENSION(iim,jjm+1)         :: zx_lon, zx_lat
+    REAL, DIMENSION(iim,jjm+1)         :: debugtab
+
+
+    REAL, DIMENSION(klon,nbsrf)        :: pblh         ! height of the planetary boundary layer
+    REAL, DIMENSION(klon,nbsrf)        :: plcl         ! condensation level
+    REAL, DIMENSION(klon,nbsrf)        :: capCL
+    REAL, DIMENSION(klon,nbsrf)        :: oliqCL
+    REAL, DIMENSION(klon,nbsrf)        :: cteiCL
+    REAL, DIMENSION(klon,nbsrf)        :: pblT
+    REAL, DIMENSION(klon,nbsrf)        :: therm
+    REAL, DIMENSION(klon,nbsrf)        :: trmb1        ! deep cape
+    REAL, DIMENSION(klon,nbsrf)        :: trmb2        ! inhibition
+    REAL, DIMENSION(klon,nbsrf)        :: trmb3        ! point Omega
+    REAL, DIMENSION(klon,nbsrf)        :: zx_rh2m, zx_qsat2m
+    REAL, DIMENSION(klon,nbsrf)        :: zx_t1
+    REAL, DIMENSION(klon, nbsrf)       :: alb          ! mean albedo for whole SW interval
+    REAL, DIMENSION(klon)              :: ylwdown      ! jg : temporary (ysollwdown)
+
+    REAL                               :: zx_qs1, zcor1, zdelta1 
+
+!****************************************************************************************
+! Declarations specifiques pour le 1D. A reprendre 
+!****************************************************************************************
+  REAL  :: fsens,flat
+  LOGICAL :: ok_flux_surf ! initialized during first_call below
+  COMMON /flux_arp/fsens,flat,ok_flux_surf
+! End of declarations
+!****************************************************************************************
+! Lluis
+  INTEGER                                                :: lpt, lp
+
+  lp = 885
+!****************************************************************************************
+! 1) Initialisation and validation tests 
+!    Only done first time entering this subroutine
+!
+!****************************************************************************************
+
+    PRINT *,'  Lluis in pbl_surface: ts ',lp,ts(lp,:)
+
+    IF (first_call) THEN
+       first_call=.FALSE.
+      
+       ! Initialize ok_flux_surf (for 1D model)
+       if (klon>1) ok_flux_surf=.FALSE.
+       
+       ! Initilize debug IO
+       IF (debugindex .AND. mpi_size==1) THEN 
+          ! initialize IOIPSL output
+          idayref = day_ini
+          CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)
+          CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,zx_lon)
+          DO i = 1, iim
+             zx_lon(i,1) = rlon(i+1)
+             zx_lon(i,jjm+1) = rlon(i+1)
+          ENDDO
+          CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,zx_lat)
+          CALL histbeg("sous_index", iim,zx_lon(:,1),jjm+1,zx_lat(1,:), &
+               1,iim,1,jjm+1, &
+               itau_phy,zjulian,dtime,nhoridbg,nidbg) 
+          ! no vertical axis
+          cl_surf(1)='ter'
+          cl_surf(2)='lic'
+          cl_surf(3)='oce'
+          cl_surf(4)='sic'
+          DO nsrf=1,nbsrf
+             CALL histdef(nidbg, cl_surf(nsrf),cl_surf(nsrf), "-",iim, &
+                  jjm+1,nhoridbg, 1, 1, 1, -99, 32, "inst", dtime,dtime) 
+          END DO
+
+          CALL histend(nidbg)
+          CALL histsync(nidbg)
+
+       END IF
+       
+    ENDIF
+          
+!****************************************************************************************
+! Force soil water content to qsol0 if qsol0>0 and VEGET=F (use bucket
+! instead of ORCHIDEE)
+    IF (qsol0>0.) THEN
+      PRINT*,'WARNING : On impose qsol=',qsol0
+      qsol(:)=qsol0
+    ENDIF
+!****************************************************************************************
+
+!****************************************************************************************
+! 2) Initialization to zero 
+!    Done for all local variables that will be compressed later
+!    and argument with INTENT(OUT)
+!****************************************************************************************
+    cdragh = 0.0  ; cdragm = 0.0     ; dflux_t = 0.0   ; dflux_q = 0.0
+    ypct = 0.0    ; yts = 0.0        ; ysnow = 0.0
+    zv1 = 0.0     ; yqsurf = 0.0     ; yalb1 = 0.0     ; yalb2 = 0.0    
+    yrain_f = 0.0 ; ysnow_f = 0.0    ; yfder = 0.0     ; ysolsw = 0.0    
+    ysollw = 0.0  ; yrugos = 0.0     ; yu1 = 0.0    
+    yv1 = 0.0     ; ypaprs = 0.0     ; ypplay = 0.0
+    ydelp = 0.0   ; yu = 0.0         ; yv = 0.0        ; yt = 0.0         
+    yq = 0.0      ; y_dflux_t = 0.0  ; y_dflux_q = 0.0 
+    yrugoro = 0.0 ; ywindsp = 0.0   
+    d_ts = 0.0    ; yfluxlat=0.0     ; flux_t = 0.0    ; flux_q = 0.0     
+    flux_u = 0.0  ; flux_v = 0.0     ; d_t = 0.0       ; d_q = 0.0      
+    d_t_diss= 0.0 ;d_u = 0.0     ; d_v = 0.0        ; yqsol = 0.0    
+    ytherm = 0.0  ; ytke=0.
+    
+    tke(:,:,is_ave)=0.
+    IF (iflag_pbl<20.or.iflag_pbl>=30) THEN
+       zcoefh(:,:,:) = 0.0
+       zcoefh(:,1,:) = 999999. ! zcoefh(:,k=1) should never be used
+       zcoefm(:,:,:) = 0.0
+       zcoefm(:,1,:) = 999999. !
+    ELSE
+      zcoefm(:,:,is_ave)=0.
+      zcoefh(:,:,is_ave)=0.
+    ENDIF
+    ytsoil = 999999. 
+
+    rh2m(:)        = 0.
+    qsat2m(:)      = 0.
+!****************************************************************************************
+! 3) - Calculate pressure thickness of each layer
+!    - Calculate the wind at first layer
+!    - Mean calculations of albedo
+!    - Calculate net radiance at sub-surface
+!****************************************************************************************
+    DO k = 1, klev
+       DO i = 1, klon
+          delp(i,k) = paprs(i,k)-paprs(i,k+1)
+       ENDDO
+    ENDDO
+
+!****************************************************************************************
+! Test for rugos........ from physiq.. A la fin plutot???
+!
+!****************************************************************************************
+
+    zxrugs(:) = 0.0
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          rugos(i,nsrf) = MAX(rugos(i,nsrf),0.000015)
+          zxrugs(i) = zxrugs(i) + rugos(i,nsrf)*pctsrf(i,nsrf)
+       ENDDO
+    ENDDO
+    PRINT *,'    Lluis after rugos: ts ',lp,ts(lp,:), ' rugos: ', rugos(lp,:),       &
+      ' alb1: ',alb1(550,:)
+! Mean calculations of albedo
+!
+! Albedo at sub-surface
+! * alb1 : albedo in visible SW interval
+! * alb2 : albedo in near infrared SW interval
+! * alb  : mean albedo for whole SW interval
+!
+! Mean albedo for grid point
+! * alb1_m : albedo in visible SW interval
+! * alb2_m : albedo in near infrared SW interval
+! * alb_m  : mean albedo at whole SW interval
+
+    alb1_m(:) = 0.0
+    alb2_m(:) = 0.0
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          alb1_m(i) = alb1_m(i) + alb1(i,nsrf) * pctsrf(i,nsrf)
+          alb2_m(i) = alb2_m(i) + alb2(i,nsrf) * pctsrf(i,nsrf)
+       ENDDO
+    ENDDO
+    PRINT *,'    Lluis after rugos: ts ',lp,ts(lp,:), ' rugos: ', rugos(lp,:),       &
+      ' alb1: ',alb1(550,:)
+! We here suppose the fraction f1 of incoming radiance of visible radiance 
+! as a fraction of all shortwave radiance 
+    f1 = 0.5 
+!    f1 = 1    ! put f1=1 to recreate old calculations
+
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          alb(i,nsrf) = f1*alb1(i,nsrf) + (1-f1)*alb2(i,nsrf)
+       ENDDO
+    ENDDO
+
+    DO i = 1, klon
+       alb_m(i) = f1*alb1_m(i) + (1-f1)*alb2_m(i)
+    END DO
+
+! Calculation of mean temperature at surface grid points
+    ztsol(:) = 0.0
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          ztsol(i) = ztsol(i) + ts(i,nsrf)*pctsrf(i,nsrf)
+       ENDDO
+    ENDDO
+    PRINT *,'  Lluis ztsol ',lp,' : ',ztsol(lp)
+
+! Linear distrubution on sub-surface of long- and shortwave net radiance
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          sollw(i,nsrf) = sollw_m(i) + 4.0*RSIGMA*ztsol(i)**3 * (ztsol(i)-ts(i,nsrf))
+          solsw(i,nsrf) = solsw_m(i) * (1.-alb(i,nsrf)) / (1.-alb_m(i))
+       ENDDO
+    ENDDO
+    PRINT *,'  Lluis ',lp,' sollw: ',sollw(lp,:),' solsw: ',solsw(lp,:)
+
+
+! Downwelling longwave radiation at mean surface
+    lwdown_m(:) = 0.0
+    DO i = 1, klon
+       lwdown_m(i) = sollw_m(i) + RSIGMA*ztsol(i)**4
+    ENDDO
+    PRINT *,'  Lluis ',lp,' lwdown_m: ',lwdown_m(lp)
+
+!****************************************************************************************
+! 4) Loop over different surfaces
+!
+! Only points containing a fraction of the sub surface will be threated.
+! 
+!****************************************************************************************
+   
+    loop_nbsrf: DO nsrf = 1, nbsrf
+
+! Search for index(ni) and size(knon) of domaine to treat
+       ni(:) = 0
+       knon  = 0
+! Lluis
+       lpt = 1
+       DO i = 1, klon
+          IF (pctsrf(i,nsrf) > 0.) THEN
+             knon = knon + 1
+             ni(knon) = i
+! Lluis
+             IF (i == lp) lpt = knon
+          ENDIF
+       ENDDO
+
+       ! write index, with IOIPSL
+       IF (debugindex .AND. mpi_size==1) THEN 
+          tabindx(:)=0.
+          DO i=1,knon
+             tabindx(i)=REAL(i)
+          END DO
+          debugtab(:,:) = 0.
+          ndexbg(:) = 0
+          CALL gath2cpl(tabindx,debugtab,knon,ni)
+          CALL histwrite(nidbg,cl_surf(nsrf),itap,debugtab,iim*(jjm+1), ndexbg)
+       ENDIF
+       
+!****************************************************************************************
+! 5) Compress variables 
+!
+!****************************************************************************************
+
+       PRINT *,'    Lluis nsrf j i rugos yts_________'
+       DO j = 1, knon
+          i = ni(j)
+          ypct(j)    = pctsrf(i,nsrf)
+          yts(j)     = ts(i,nsrf)
+          ysnow(j)   = snow(i,nsrf)
+          yqsurf(j)  = qsurf(i,nsrf)
+          yalb(j)    = alb(i,nsrf)
+          yalb1(j)   = alb1(i,nsrf)
+          yalb2(j)   = alb2(i,nsrf)
+          yrain_f(j) = rain_f(i)
+          ysnow_f(j) = snow_f(i)
+          yagesno(j) = agesno(i,nsrf)
+          yfder(j)   = fder(i)
+          ysolsw(j)  = solsw(i,nsrf)
+          ysollw(j)  = sollw(i,nsrf)
+          yrugos(j)  = rugos(i,nsrf)
+          PRINT *,nsrf,j,i,rugos(i,nsrf),yts(i)
+          yrugoro(j) = rugoro(i)
+          yu1(j)     = u(i,1)
+          yv1(j)     = v(i,1)
+          ypaprs(j,klev+1) = paprs(i,klev+1)
+          ywindsp(j) = SQRT(u10m(i,nsrf)**2 + v10m(i,nsrf)**2 )
+       END DO
+       PRINT *,'  Lluis ', lpt,' yts: ',yts(lpt)
+
+       DO k = 1, klev
+          DO j = 1, knon
+             i = ni(j)
+             ypaprs(j,k) = paprs(i,k)
+             ypplay(j,k) = pplay(i,k)
+             ydelp(j,k)  = delp(i,k)
+             ytke(j,k)   = tke(i,k,nsrf)
+             yu(j,k) = u(i,k)
+             yv(j,k) = v(i,k)
+             yt(j,k) = t(i,k)
+             yq(j,k) = q(i,k)
+          ENDDO
+       ENDDO
+
+       DO k = 1, nsoilmx
+          DO j = 1, knon
+             i = ni(j)
+             ytsoil(j,k) = ftsoil(i,k,nsrf)
+          END DO
+       END DO
+       PRINT *,'  Lluis ', lpt,' ytsoil: ',ytsoil(lpt,:),' ftsoil: ',ftsoil(ni(lpt),:,nsrf)
+
+       ! qsol(water height in soil) only for bucket continental model
+       IF ( nsrf .EQ. is_ter .AND. .NOT. ok_veget ) THEN 
+          DO j = 1, knon
+             i = ni(j)
+             yqsol(j) = qsol(i)
+          END DO
+       ENDIF
+       PRINT *,'  Lluis ',lpt,' yqsol: ',yqsol(lpt)
+       
+!****************************************************************************************
+! 6a) Calculate coefficients for turbulent diffusion at surface, cdragh et cdragm.
+!
+!****************************************************************************************
+
+       PRINT *,'  Lluis before clcdrag: yrugos 1:', yrugos(1),' lpt: ',yrugos(lpt),  &
+         ' yts: ',yts(lpt), ' yalb: ',yalb(lpt)
+       CALL clcdrag( knon, nsrf, ypaprs, ypplay, & 
+            yu(:,1), yv(:,1), yt(:,1), yq(:,1), &
+            yts, yqsurf, yrugos, &
+            ycdragm, ycdragh )
+
+!****************************************************************************************
+! 6b) Calculate coefficients for turbulent diffusion in the atmosphere, ycoefm et ycoefm.
+!
+!****************************************************************************************
+
+       CALL coef_diff_turb(dtime, nsrf, knon, ni,  &
+            ypaprs, ypplay, yu, yv, yq, yt, yts, yrugos, yqsurf, ycdragm, &
+            ycoefm, ycoefh, ytke)
+      PRINT *,'  Lluis after coef_diff_turb lpt: ',lpt,' k ycoefm ycoefh ytke ____'
+      DO k=1,klev
+        PRINT *,k,ycoefm(lpt,k),ycoefh(lpt,k),ytke(lpt,k)
+      END DO
+       IF (iflag_pbl>=20.AND.iflag_pbl<30) THEN
+! In this case, coef_diff_turb is called for the Cd only
+       DO k = 2, klev
+          DO j = 1, knon
+             i = ni(j)
+             ycoefh(j,k)   = zcoefh(i,k,nsrf)
+             ycoefm(j,k)   = zcoefm(i,k,nsrf)
+          ENDDO
+       ENDDO
+       ENDIF
+       
+!****************************************************************************************
+! 
+! 8) "La descente" - "The downhill"
+!  
+!  climb_hq_down and climb_wind_down calculate the coefficients
+!  Ccoef_X et Dcoef_X for X=[H, Q, U, V].
+!  Only the coefficients at surface for H and Q are returned.
+!
+!****************************************************************************************
+
+      PRINT *,'  Lluis before climb_hq_down knon: ',lpt,' dtime: ',dtime,      &  
+        ' AcoefH: ',AcoefH(lpt),' AcoefQ: ',AcoefQ(lpt),' BcoefH: ',BcoefH(lpt),&
+        ' BcoefQ: ',BcoefQ(lpt)
+      PRINT *,'  Lluis before k ycoefh ypaprs ypplay ydelp yt yq ____'
+      DO k=1,klev
+        PRINT *,k,ycoefh(lpt,k),ypaprs(lpt,k),ypplay(lpt,k),ydelp(lpt,k),     &
+          yt(lpt,k),yq(lpt,k)
+      END DO
+! - Calculate the coefficients Ccoef_H, Ccoef_Q, Dcoef_H and Dcoef_Q 
+       CALL climb_hq_down(knon, ycoefh, ypaprs, ypplay, &
+            ydelp, yt, yq, dtime, &
+            AcoefH, AcoefQ, BcoefH, BcoefQ)
+
+! - Calculate the coefficients Ccoef_U, Ccoef_V, Dcoef_U and Dcoef_V
+       CALL climb_wind_down(knon, dtime, ycoefm, ypplay, ypaprs, yt, ydelp, yu, yv, &
+            AcoefU, AcoefV, BcoefU, BcoefV)
+      
+      PRINT *,'  Lluis after climb_hq_down knon: ',lpt,' ycoefh: ',ycoefh(lpt,1),&
+        ' ypaprs: ',ypaprs(lpt,1),' ypplay: ',ypplay(lpt,1),' ydelp: ',         &
+        ydelp(lpt,1),' yt: ',yt(lpt,1),' yq: ',yq(lpt,1),' dtime: ',dtime,      & 
+        ' AcoefH: ',AcoefH(lpt),' AcoefQ: ',AcoefQ(lpt),' BcoefH: ',BcoefH(lpt),&
+        ' BcoefQ: ',BcoefQ(lpt)
+
+!****************************************************************************************
+! 9) Small calculations
+!
+!****************************************************************************************
+
+! - Reference pressure is given the values at surface level          
+       ypsref(:) = ypaprs(:,1)  
+
+! - CO2 field on 2D grid to be sent to ORCHIDEE
+!   Transform to compressed field
+       IF (carbon_cycle_cpl) THEN
+          DO i=1,knon
+             r_co2_ppm(i) = co2_send(ni(i))
+          END DO
+       ELSE
+          r_co2_ppm(:) = co2_ppm     ! Constant field
+       END IF
+
+!****************************************************************************************
+!
+! Calulate t2m and q2m for the case of calculation at land grid points 
+! t2m and q2m are needed as input to ORCHIDEE
+!
+!****************************************************************************************
+       IF (nsrf == is_ter) THEN
+
+          DO i = 1, knon
+             zgeo1(i) = RD * yt(i,1) / (0.5*(ypaprs(i,1)+ypplay(i,1))) &
+                  * (ypaprs(i,1)-ypplay(i,1))
+          END DO
+
+          ! Calculate the temperature et relative humidity at 2m and the wind at 10m 
+          CALL stdlevvar(klon, knon, is_ter, zxli, &
+               yu(:,1), yv(:,1), yt(:,1), yq(:,1), zgeo1, &
+               yts, yqsurf, yrugos, ypaprs(:,1), ypplay(:,1), &
+               yt2m, yq2m, yt10m, yq10m, yu10m, yustar)
+          
+       END IF
+
+!****************************************************************************************
+!
+! 10) Switch selon current surface
+!     It is necessary to start with the continental surfaces because the ocean
+!     needs their run-off.
+!
+!****************************************************************************************
+       SELECT CASE(nsrf)
+     
+       CASE(is_ter)
+          ! ylwdown : to be removed, calculation is now done at land surface in surf_land
+          ylwdown(:)=0.0
+          DO i=1,knon
+             ylwdown(i)=lwdown_m(ni(i))
+          END DO
+          PRINT *,'  Lluis before surf_land lpt=',lpt,' yts', yts(lpt),' yq: ',yq(lpt,1)
+          CALL surf_land(itap, dtime, date0, jour, knon, ni,&
+               rlon, rlat, &
+               debut, lafin, ydelp(:,1), r_co2_ppm, ysolsw, ysollw, yalb, &
+               yts, ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               AcoefH, AcoefQ, BcoefH, BcoefQ, & 
+               AcoefU, AcoefV, BcoefU, BcoefV, & 
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               ylwdown, yq2m, yt2m, &
+               ysnow, yqsol, yagesno, ytsoil, &
+               yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
+               yqsurf, ytsurf_new, y_dflux_t, y_dflux_q, &
+               y_flux_u1, y_flux_v1 )
+               
+     
+       CASE(is_lic)
+          CALL surf_landice(itap, dtime, knon, ni, &
+               ysolsw, ysollw, yts, ypplay(:,1), &
+               ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               AcoefH, AcoefQ, BcoefH, BcoefQ, &
+               AcoefU, AcoefV, BcoefU, BcoefV, &
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               ysnow, yqsurf, yqsol, yagesno, &
+               ytsoil, yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
+               ytsurf_new, y_dflux_t, y_dflux_q, &
+               y_flux_u1, y_flux_v1)
+          
+       CASE(is_oce)
+          PRINT *,'  Lluis before surf_ocean lpt= ',lpt,' yts: ', yts(lpt),         &
+            ' pctsrf: ',pctsrf(lpt,:),' ytsurf_new: ',ytsurf_new(lpt)
+          CALL surf_ocean(rlon, rlat, ysolsw, ysollw, yalb1, &
+               yrugos, ywindsp, rmu0, yfder, yts, &
+               itap, dtime, jour, knon, ni, &
+               ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               AcoefH, AcoefQ, BcoefH, BcoefQ, &
+               AcoefU, AcoefV, BcoefU, BcoefV, &
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               ysnow, yqsurf, yagesno, &
+               yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
+               ytsurf_new, y_dflux_t, y_dflux_q, slab_wfbils, &
+               y_flux_u1, y_flux_v1)
+          PRINT *,'  Lluis after surf_ocean lpt= ',lpt,' yts: ', yts(lpt),          &
+            ' pctsrf: ',pctsrf(lpt,:),' ytsurf_new: ',ytsurf_new(lpt), 'ypct: ',    &
+            ypct(lpt)
+!          PRINT *,'     i yts  . pctsrf : ytsurf_new_________'
+!          DO i=1,knon
+!            PRINT *,'    ',i,yts(i), ' . ', pctsrf(i,:),' : ',ytsurf_new(i)
+!          END DO
+          
+       CASE(is_sic)
+          CALL surf_seaice( &
+               rlon, rlat, ysolsw, ysollw, yalb1, yfder, &
+               itap, dtime, jour, knon, ni, &
+               lafin, &
+               yts, ypplay(:,1), ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),&
+               AcoefH, AcoefQ, BcoefH, BcoefQ, &
+               AcoefU, AcoefV, BcoefU, BcoefV, &
+               ypsref, yu1, yv1, yrugoro, pctsrf, &
+               ysnow, yqsurf, yqsol, yagesno, ytsoil, &
+               yz0_new, yalb1_new, yalb2_new, yevap, yfluxsens, yfluxlat, &
+               ytsurf_new, y_dflux_t, y_dflux_q, &
+               y_flux_u1, y_flux_v1)
+          
+
+       CASE DEFAULT
+          WRITE(lunout,*) 'Surface index = ', nsrf
+          abort_message = 'Surface index not valid'
+          CALL abort_gcm(modname,abort_message,1)
+       END SELECT
+
+
+!****************************************************************************************
+! 11) - Calcul the increment of surface temperature
+!
+!****************************************************************************************
+       y_d_ts(1:knon)   = ytsurf_new(1:knon) - yts(1:knon)
+
+       PRINT *,'  Lluis nsrf: ',nsrf,' lpt: ',lpt,' ytsurf_new: ',ytsurf_new(lpt),   &
+         ' yts: ',yts(lpt),' y_d_ts: ',y_d_ts(lpt)
+ 
+!****************************************************************************************
+!
+! 12) "La remontee" - "The uphill"
+!
+!  The fluxes (y_flux_X) and tendancy (y_d_X) are calculated 
+!  for X=H, Q, U and V, for all vertical levels.
+!
+!****************************************************************************************
+! H and Q
+       IF (ok_flux_surf) THEN
+          PRINT *,'pbl_surface: fsens flat RLVTT=',fsens,flat,RLVTT
+          y_flux_t1(:) =  fsens
+          y_flux_q1(:) =  flat/RLVTT
+          yfluxlat(:) =  flat
+
+          Kech_h(:) = ycdragh(:) * (1.0+SQRT(yu(:,1)**2+yv(:,1)**2)) * &
+               ypplay(:,1)/(RD*yt(:,1))
+          ytoto(:)=(1./RCPD)*(AcoefH(:)+BcoefH(:)*y_flux_t1(:)*dtime)
+          ytsurf_new(:)=ytoto(:)-y_flux_t1(:)/(Kech_h(:)*RCPD)
+          y_d_ts(:) = ytsurf_new(:) - yts(:) 
+
+       ELSE
+          y_flux_t1(:) =  yfluxsens(:)
+          y_flux_q1(:) = -yevap(:)
+       ENDIF
+
+       CALL climb_hq_up(knon, dtime, yt, yq, &
+            y_flux_q1, y_flux_t1, ypaprs, ypplay, &
+            y_flux_q(:,:), y_flux_t(:,:), y_d_q(:,:), y_d_t(:,:))    
+       
+
+       CALL climb_wind_up(knon, dtime, yu, yv, y_flux_u1, y_flux_v1, &
+            y_flux_u, y_flux_v, y_d_u, y_d_v)
+
+
+     y_d_t_diss(:,:)=0.
+     IF (iflag_pbl>=20 .and. iflag_pbl<30) THEN
+        CALL yamada_c(knon,dtime,ypaprs,ypplay &
+    &   ,yu,yv,yt,y_d_u,y_d_v,y_d_t,ycdragm,ytke,ycoefm,ycoefh,ycoefq,y_d_t_diss,yustar &
+    &   ,iflag_pbl,nsrf)
+     ENDIF
+!     print*,'yamada_c OK'
+
+       DO j = 1, knon
+          y_dflux_t(j) = y_dflux_t(j) * ypct(j)
+          y_dflux_q(j) = y_dflux_q(j) * ypct(j)
+       ENDDO
+
+!****************************************************************************************
+! 13) Transform variables for output format : 
+!     - Decompress
+!     - Multiply with pourcentage of current surface
+!     - Cumulate in global variable
+!
+!****************************************************************************************
+
+       DO k = 1, klev
+          DO j = 1, knon
+             i = ni(j)
+             y_d_t_diss(j,k)  = y_d_t_diss(j,k) * ypct(j)
+             y_d_t(j,k)  = y_d_t(j,k) * ypct(j)
+             y_d_q(j,k)  = y_d_q(j,k) * ypct(j)
+             y_d_u(j,k)  = y_d_u(j,k) * ypct(j)
+             y_d_v(j,k)  = y_d_v(j,k) * ypct(j)
+
+             flux_t(i,k,nsrf) = y_flux_t(j,k)
+             flux_q(i,k,nsrf) = y_flux_q(j,k)
+             flux_u(i,k,nsrf) = y_flux_u(j,k)
+             flux_v(i,k,nsrf) = y_flux_v(j,k)
+
+
+          ENDDO
+       ENDDO
+
+!      print*,'Dans pbl OK1'
+
+       evap(:,nsrf) = - flux_q(:,1,nsrf)
+       
+       alb1(:, nsrf) = 0.
+       alb2(:, nsrf) = 0.
+       snow(:, nsrf) = 0.
+       qsurf(:, nsrf) = 0.
+       rugos(:, nsrf) = 0.
+       fluxlat(:,nsrf) = 0.
+       DO j = 1, knon
+          i = ni(j)
+          d_ts(i,nsrf) = y_d_ts(j)
+          alb1(i,nsrf) = yalb1_new(j)  
+          alb2(i,nsrf) = yalb2_new(j)
+          snow(i,nsrf) = ysnow(j)  
+          qsurf(i,nsrf) = yqsurf(j)
+          rugos(i,nsrf) = yz0_new(j)
+          fluxlat(i,nsrf) = yfluxlat(j)
+          agesno(i,nsrf) = yagesno(j)  
+          cdragh(i) = cdragh(i) + ycdragh(j)*ypct(j)
+          cdragm(i) = cdragm(i) + ycdragm(j)*ypct(j)
+          dflux_t(i) = dflux_t(i) + y_dflux_t(j)
+          dflux_q(i) = dflux_q(i) + y_dflux_q(j)
+       END DO
+
+!      print*,'Dans pbl OK2'
+
+       DO k = 2, klev
+          DO j = 1, knon
+             i = ni(j)
+             tke(i,k,nsrf)    = ytke(j,k)
+             zcoefh(i,k,nsrf) = ycoefh(j,k)
+             zcoefm(i,k,nsrf) = ycoefm(j,k)
+             tke(i,k,is_ave) = tke(i,k,is_ave) + ytke(j,k)*ypct(j)
+             zcoefh(i,k,is_ave) = zcoefh(i,k,is_ave) + ycoefh(j,k)*ypct(j)
+             zcoefm(i,k,is_ave) = zcoefm(i,k,is_ave) + ycoefm(j,k)*ypct(j)
+          END DO
+       END DO
+
+!      print*,'Dans pbl OK3'
+
+       IF ( nsrf .EQ. is_ter ) THEN 
+          DO j = 1, knon
+             i = ni(j)
+             qsol(i) = yqsol(j)
+          END DO
+       END IF
+       
+       ftsoil(:,:,nsrf) = 0.
+       DO k = 1, nsoilmx
+          DO j = 1, knon
+             i = ni(j)
+             ftsoil(i, k, nsrf) = ytsoil(j,k)
+          END DO
+       END DO
+       
+       
+       DO k = 1, klev
+          DO j = 1, knon
+             i = ni(j)
+             d_t_diss(i,k) = d_t_diss(i,k) + y_d_t_diss(j,k)
+             d_t(i,k) = d_t(i,k) + y_d_t(j,k)
+             d_q(i,k) = d_q(i,k) + y_d_q(j,k)
+             d_u(i,k) = d_u(i,k) + y_d_u(j,k)
+             d_v(i,k) = d_v(i,k) + y_d_v(j,k)
+          END DO
+       END DO
+
+!      print*,'Dans pbl OK4'
+    PRINT *,'  Lluis before diagnostics: lp= ',lp,' ts ',lp,ts(lp,:)
+
+!****************************************************************************************
+! 14) Calculate the temperature et relative humidity at 2m and the wind at 10m 
+!     Call HBTM
+!
+!****************************************************************************************
+       t2m(:,nsrf)    = 0.
+       q2m(:,nsrf)    = 0.
+       ustar(:,nsrf)   = 0.
+       u10m(:,nsrf)   = 0.
+       v10m(:,nsrf)   = 0.
+       pblh(:,nsrf)   = 0.        ! Hauteur de couche limite
+       plcl(:,nsrf)   = 0.        ! Niveau de condensation de la CLA
+       capCL(:,nsrf)  = 0.        ! CAPE de couche limite
+       oliqCL(:,nsrf) = 0.        ! eau_liqu integree de couche limite
+       cteiCL(:,nsrf) = 0.        ! cloud top instab. crit. couche limite
+       pblt(:,nsrf)   = 0.        ! T a la Hauteur de couche limite
+       therm(:,nsrf)  = 0.
+       trmb1(:,nsrf)  = 0.        ! deep_cape
+       trmb2(:,nsrf)  = 0.        ! inhibition 
+       trmb3(:,nsrf)  = 0.        ! Point Omega
+
+#undef T2m     
+#define T2m     
+#ifdef T2m
+! Calculations of diagnostic t,q at 2m and u, v at 10m
+
+!      print*,'Dans pbl OK41'
+!      print*,'tair1,yt(:,1),y_d_t(:,1)'
+!      print*, tair1,yt(:,1),y_d_t(:,1)
+       DO j=1, knon
+          i = ni(j)
+          uzon(j) = yu(j,1) + y_d_u(j,1)
+          vmer(j) = yv(j,1) + y_d_v(j,1)
+          tair1(j) = yt(j,1) + y_d_t(j,1) + y_d_t_diss(j,1)
+          qair1(j) = yq(j,1) + y_d_q(j,1)
+          zgeo1(j) = RD * tair1(j) / (0.5*(ypaprs(j,1)+ypplay(j,1))) &
+               * (ypaprs(j,1)-ypplay(j,1))
+          tairsol(j) = yts(j) + y_d_ts(j)
+          rugo1(j) = yrugos(j)
+          IF(nsrf.EQ.is_oce) THEN
+             rugo1(j) = rugos(i,nsrf)
+          ENDIF
+          psfce(j)=ypaprs(j,1)
+          patm(j)=ypplay(j,1)
+          qairsol(j) = yqsurf(j)
+       END DO
+       
+!      print*,'Dans pbl OK42A'
+!      print*,'tair1,yt(:,1),y_d_t(:,1)'
+!      print*, tair1,yt(:,1),y_d_t(:,1)
+
+! Calculate the temperature et relative humidity at 2m and the wind at 10m 
+       CALL stdlevvar(klon, knon, nsrf, zxli, &
+            uzon, vmer, tair1, qair1, zgeo1, &
+            tairsol, qairsol, rugo1, psfce, patm, &
+            yt2m, yq2m, yt10m, yq10m, yu10m, yustar)
+!      print*,'Dans pbl OK42B'
+
+       DO j=1, knon
+          i = ni(j)
+          t2m(i,nsrf)=yt2m(j)
+          q2m(i,nsrf)=yq2m(j)
+          
+          ! u10m, v10m : composantes du vent a 10m sans spirale de Ekman
+          ustar(i,nsrf)=yustar(j)
+          u10m(i,nsrf)=(yu10m(j) * uzon(j))/SQRT(uzon(j)**2+vmer(j)**2)
+          v10m(i,nsrf)=(yu10m(j) * vmer(j))/SQRT(uzon(j)**2+vmer(j)**2)
+
+       END DO
+
+!      print*,'Dans pbl OK43'
+!IM Calcule de l'humidite relative a 2m (rh2m) pour diagnostique
+!IM Ajoute dependance type surface
+       IF (thermcep) THEN
+          DO j = 1, knon
+             i=ni(j)
+             zdelta1 = MAX(0.,SIGN(1., rtt-yt2m(j) ))
+             zx_qs1  = r2es * FOEEW(yt2m(j),zdelta1)/paprs(i,1)
+             zx_qs1  = MIN(0.5,zx_qs1)
+             zcor1   = 1./(1.-RETV*zx_qs1)
+             zx_qs1  = zx_qs1*zcor1
+             
+             rh2m(i)   = rh2m(i)   + yq2m(j)/zx_qs1 * pctsrf(i,nsrf)
+             qsat2m(i) = qsat2m(i) + zx_qs1  * pctsrf(i,nsrf)
+          END DO
+       END IF
+
+!   print*,'OK pbl 5'
+       CALL HBTM(knon, ypaprs, ypplay, &
+            yt2m,yt10m,yq2m,yq10m,yustar, &
+            y_flux_t,y_flux_q,yu,yv,yt,yq, &
+            ypblh,ycapCL,yoliqCL,ycteiCL,ypblT, &
+            ytherm,ytrmb1,ytrmb2,ytrmb3,ylcl)
+       
+       DO j=1, knon
+          i = ni(j)
+          pblh(i,nsrf)   = ypblh(j)
+          plcl(i,nsrf)   = ylcl(j)
+          capCL(i,nsrf)  = ycapCL(j)
+          oliqCL(i,nsrf) = yoliqCL(j)
+          cteiCL(i,nsrf) = ycteiCL(j)
+          pblT(i,nsrf)   = ypblT(j)
+          therm(i,nsrf)  = ytherm(j)
+          trmb1(i,nsrf)  = ytrmb1(j)
+          trmb2(i,nsrf)  = ytrmb2(j)
+          trmb3(i,nsrf)  = ytrmb3(j)
+       END DO
+       
+!   print*,'OK pbl 6'
+#else 
+! T2m not defined
+! No calculation
+       PRINT*,' Warning !!! No T2m calculation. Output is set to zero.'
+#endif
+
+!****************************************************************************************
+! 15) End of loop over different surfaces
+!
+!****************************************************************************************
+    END DO loop_nbsrf
+
+    PRINT *,'  Lluis after loop soil types: lp= ',lp,' ts ',lp,ts(lp,:)
+
+!****************************************************************************************
+! 16) Calculate the mean value over all sub-surfaces for som variables
+!
+!****************************************************************************************
+    
+!   print*,'OK pbl 7'
+    zxfluxt(:,:) = 0.0 ; zxfluxq(:,:) = 0.0
+    zxfluxu(:,:) = 0.0 ; zxfluxv(:,:) = 0.0
+    DO nsrf = 1, nbsrf
+       DO k = 1, klev
+          DO i = 1, klon
+             zxfluxt(i,k) = zxfluxt(i,k) + flux_t(i,k,nsrf) * pctsrf(i,nsrf)
+             zxfluxq(i,k) = zxfluxq(i,k) + flux_q(i,k,nsrf) * pctsrf(i,nsrf)
+             zxfluxu(i,k) = zxfluxu(i,k) + flux_u(i,k,nsrf) * pctsrf(i,nsrf)
+             zxfluxv(i,k) = zxfluxv(i,k) + flux_v(i,k,nsrf) * pctsrf(i,nsrf)
+          END DO
+       END DO
+    END DO
+
+!   print*,'OK pbl 8'
+    DO i = 1, klon
+       zxsens(i)     = - zxfluxt(i,1) ! flux de chaleur sensible au sol
+       zxevap(i)     = - zxfluxq(i,1) ! flux d'evaporation au sol
+       fder_print(i) = fder(i) + dflux_t(i) + dflux_q(i)
+    ENDDO
+   
+!
+! Incrementer la temperature du sol
+!
+    zxtsol(:) = 0.0  ; zxfluxlat(:) = 0.0
+    zt2m(:) = 0.0    ; zq2m(:) = 0.0 
+    zustar(:)=0.0 ; zu10m(:) = 0.0   ; zv10m(:) = 0.0
+    s_pblh(:) = 0.0  ; s_plcl(:) = 0.0 
+    s_capCL(:) = 0.0 ; s_oliqCL(:) = 0.0
+    s_cteiCL(:) = 0.0; s_pblT(:) = 0.0
+    s_therm(:) = 0.0 ; s_trmb1(:) = 0.0
+    s_trmb2(:) = 0.0 ; s_trmb3(:) = 0.0
+    
+!   print*,'OK pbl 9'
+    
+    PRINT *,'  Lluis adding tendencies: lp= ',lp,' nsrf ts d_ts_______'
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon          
+          IF (i == lp) PRINT *,nsrf,ts(i,nsrf),d_ts(i,nsrf)
+          ts(i,nsrf) = ts(i,nsrf) + d_ts(i,nsrf)
+          
+          wfbils(i,nsrf) = ( solsw(i,nsrf) + sollw(i,nsrf) &
+               + flux_t(i,1,nsrf) + fluxlat(i,nsrf) ) * pctsrf(i,nsrf)
+          wfbilo(i,nsrf) = (evap(i,nsrf) - (rain_f(i) + snow_f(i))) * &
+               pctsrf(i,nsrf)
+
+          zxtsol(i)    = zxtsol(i)    + ts(i,nsrf)      * pctsrf(i,nsrf)
+          zxfluxlat(i) = zxfluxlat(i) + fluxlat(i,nsrf) * pctsrf(i,nsrf)
+          
+          zt2m(i)  = zt2m(i)  + t2m(i,nsrf)  * pctsrf(i,nsrf)
+          zq2m(i)  = zq2m(i)  + q2m(i,nsrf)  * pctsrf(i,nsrf)
+          zustar(i) = zustar(i) + ustar(i,nsrf) * pctsrf(i,nsrf)
+          zu10m(i) = zu10m(i) + u10m(i,nsrf) * pctsrf(i,nsrf)
+          zv10m(i) = zv10m(i) + v10m(i,nsrf) * pctsrf(i,nsrf)
+
+          s_pblh(i)   = s_pblh(i)   + pblh(i,nsrf)  * pctsrf(i,nsrf)
+          s_plcl(i)   = s_plcl(i)   + plcl(i,nsrf)  * pctsrf(i,nsrf)
+          s_capCL(i)  = s_capCL(i)  + capCL(i,nsrf) * pctsrf(i,nsrf)
+          s_oliqCL(i) = s_oliqCL(i) + oliqCL(i,nsrf)* pctsrf(i,nsrf)
+          s_cteiCL(i) = s_cteiCL(i) + cteiCL(i,nsrf)* pctsrf(i,nsrf)
+          s_pblT(i)   = s_pblT(i)   + pblT(i,nsrf)  * pctsrf(i,nsrf)
+          s_therm(i)  = s_therm(i)  + therm(i,nsrf) * pctsrf(i,nsrf)
+          s_trmb1(i)  = s_trmb1(i)  + trmb1(i,nsrf) * pctsrf(i,nsrf)
+          s_trmb2(i)  = s_trmb2(i)  + trmb2(i,nsrf) * pctsrf(i,nsrf)
+          s_trmb3(i)  = s_trmb3(i)  + trmb3(i,nsrf) * pctsrf(i,nsrf)
+       END DO
+    END DO
+!   print*,'OK pbl 10'
+
+    IF (check) THEN
+       amn=MIN(ts(1,is_ter),1000.)
+       amx=MAX(ts(1,is_ter),-1000.)
+       DO i=2, klon
+          amn=MIN(ts(i,is_ter),amn)
+          amx=MAX(ts(i,is_ter),amx)
+       ENDDO
+       PRINT*,' debut apres d_ts min max ftsol(ts)',itap,amn,amx
+    ENDIF
+
+!jg ?
+!!$!
+!!$! If a sub-surface does not exsist for a grid point, the mean value for all 
+!!$! sub-surfaces is distributed.
+!!$!
+!!$    DO nsrf = 1, nbsrf
+!!$       DO i = 1, klon
+!!$          IF ((pctsrf_new(i,nsrf) .LT. epsfra) .OR. (t2m(i,nsrf).EQ.0.)) THEN
+!!$             ts(i,nsrf)     = zxtsol(i)
+!!$             t2m(i,nsrf)    = zt2m(i)
+!!$             q2m(i,nsrf)    = zq2m(i)
+!!$             u10m(i,nsrf)   = zu10m(i)
+!!$             v10m(i,nsrf)   = zv10m(i)
+!!$
+!!$! Les variables qui suivent sont plus utilise, donc peut-etre pas la peine a les mettre ajour
+!!$             pblh(i,nsrf)   = s_pblh(i)
+!!$             plcl(i,nsrf)   = s_plcl(i)
+!!$             capCL(i,nsrf)  = s_capCL(i)
+!!$             oliqCL(i,nsrf) = s_oliqCL(i) 
+!!$             cteiCL(i,nsrf) = s_cteiCL(i)
+!!$             pblT(i,nsrf)   = s_pblT(i)
+!!$             therm(i,nsrf)  = s_therm(i)
+!!$             trmb1(i,nsrf)  = s_trmb1(i)
+!!$             trmb2(i,nsrf)  = s_trmb2(i)
+!!$             trmb3(i,nsrf)  = s_trmb3(i)
+!!$          ENDIF
+!!$       ENDDO
+!!$    ENDDO
+
+    PRINT *,'  Lluis last ts: ',ts(lp,:)
+
+    DO i = 1, klon
+       fder(i) = - 4.0*RSIGMA*zxtsol(i)**3 
+    ENDDO
+    
+    zxqsurf(:) = 0.0
+    zxsnow(:)  = 0.0
+    DO nsrf = 1, nbsrf
+       DO i = 1, klon
+          zxqsurf(i) = zxqsurf(i) + qsurf(i,nsrf) * pctsrf(i,nsrf)
+          zxsnow(i)  = zxsnow(i)  + snow(i,nsrf)  * pctsrf(i,nsrf)
+       END DO
+    END DO
+
+! Premier niveau de vent sortie dans physiq.F
+    zu1(:) = u(:,1)
+    zv1(:) = v(:,1)
+
+! Some of the module declared variables are returned for printing in physiq.F
+    qsol_d(:)     = qsol(:)
+    evap_d(:,:)   = evap(:,:)
+    rugos_d(:,:)  = rugos(:,:) 
+    agesno_d(:,:) = agesno(:,:)
+
+
+  END SUBROUTINE pbl_surface
+!
+!****************************************************************************************
+!
+  SUBROUTINE pbl_surface_final(qsol_rst, fder_rst, snow_rst, qsurf_rst, &
+       evap_rst, rugos_rst, agesno_rst, ftsoil_rst)
+
+    USE indice_sol_mod
+
+    INCLUDE "dimsoil.h"
+
+! Ouput variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)                 :: qsol_rst
+    REAL, DIMENSION(klon), INTENT(OUT)                 :: fder_rst
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: snow_rst
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: qsurf_rst
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: evap_rst
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: rugos_rst
+    REAL, DIMENSION(klon, nbsrf), INTENT(OUT)          :: agesno_rst
+    REAL, DIMENSION(klon, nsoilmx, nbsrf), INTENT(OUT) :: ftsoil_rst
+
+ 
+!****************************************************************************************
+! Return module variables for writing to restart file
+!
+!****************************************************************************************    
+    qsol_rst(:)       = qsol(:)
+    fder_rst(:)       = fder(:)
+    snow_rst(:,:)     = snow(:,:)
+    qsurf_rst(:,:)    = qsurf(:,:)
+    evap_rst(:,:)     = evap(:,:)
+    rugos_rst(:,:)    = rugos(:,:)
+    agesno_rst(:,:)   = agesno(:,:)
+    ftsoil_rst(:,:,:) = ftsoil(:,:,:)
+
+!****************************************************************************************
+! Deallocate module variables
+!
+!****************************************************************************************
+!   DEALLOCATE(qsol, fder, snow, qsurf, evap, rugos, agesno, ftsoil)
+    IF (ALLOCATED(qsol)) DEALLOCATE(qsol)
+    IF (ALLOCATED(fder)) DEALLOCATE(fder)
+    IF (ALLOCATED(snow)) DEALLOCATE(snow)
+    IF (ALLOCATED(qsurf)) DEALLOCATE(qsurf)
+    IF (ALLOCATED(evap)) DEALLOCATE(evap)
+    IF (ALLOCATED(rugos)) DEALLOCATE(rugos)
+    IF (ALLOCATED(agesno)) DEALLOCATE(agesno)
+    IF (ALLOCATED(ftsoil)) DEALLOCATE(ftsoil)
+
+  END SUBROUTINE pbl_surface_final
+!  
+!****************************************************************************************
+! 
+  SUBROUTINE pbl_surface_newfrac(itime, pctsrf_new, pctsrf_old, tsurf, alb1, alb2, ustar, u10m, v10m, tke)
+
+    ! Give default values where new fraction has appread
+
+    USE indice_sol_mod
+
+    INCLUDE "dimsoil.h"
+    INCLUDE "clesphys.h"
+    INCLUDE "compbl.h"
+
+! Input variables
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf_new, pctsrf_old
+
+! InOutput variables
+!****************************************************************************************
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: tsurf
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: alb1, alb2
+    REAL, DIMENSION(klon,nbsrf), INTENT(INOUT)        :: ustar,u10m, v10m
+    REAL, DIMENSION(klon,klev+1,nbsrf), INTENT(INOUT) :: tke
+
+! Local variables
+!****************************************************************************************
+    INTEGER           :: nsrf, nsrf_comp1, nsrf_comp2, nsrf_comp3, i
+    CHARACTER(len=80) :: abort_message
+    CHARACTER(len=20) :: modname = 'pbl_surface_newfrac'
+    INTEGER, DIMENSION(nbsrf) :: nfois=0, mfois=0, pfois=0
+!
+! All at once !! 
+!****************************************************************************************
+    
+    DO nsrf = 1, nbsrf
+       ! First decide complement sub-surfaces
+       SELECT CASE (nsrf)
+       CASE(is_oce)
+          nsrf_comp1=is_sic
+          nsrf_comp2=is_ter
+          nsrf_comp3=is_lic
+       CASE(is_sic)
+          nsrf_comp1=is_oce
+          nsrf_comp2=is_ter
+          nsrf_comp3=is_lic
+       CASE(is_ter)
+          nsrf_comp1=is_lic
+          nsrf_comp2=is_oce
+          nsrf_comp3=is_sic
+       CASE(is_lic)
+          nsrf_comp1=is_ter
+          nsrf_comp2=is_oce
+          nsrf_comp3=is_sic
+       END SELECT
+
+       ! Initialize all new fractions
+       DO i=1, klon
+          IF (pctsrf_new(i,nsrf) > 0. .AND. pctsrf_old(i,nsrf) == 0.) THEN
+             
+             IF (pctsrf_old(i,nsrf_comp1) > 0.) THEN
+                ! Use the complement sub-surface, keeping the continents unchanged
+                qsurf(i,nsrf) = qsurf(i,nsrf_comp1)
+                evap(i,nsrf)  = evap(i,nsrf_comp1)
+                rugos(i,nsrf) = rugos(i,nsrf_comp1)
+                tsurf(i,nsrf) = tsurf(i,nsrf_comp1)
+                alb1(i,nsrf)  = alb1(i,nsrf_comp1)
+                alb2(i,nsrf)  = alb2(i,nsrf_comp1)
+                ustar(i,nsrf)  = ustar(i,nsrf_comp1)
+                u10m(i,nsrf)  = u10m(i,nsrf_comp1)
+                v10m(i,nsrf)  = v10m(i,nsrf_comp1)
+                if (iflag_pbl > 1) then
+                 tke(i,:,nsrf) = tke(i,:,nsrf_comp1)
+                endif
+                mfois(nsrf) = mfois(nsrf) + 1
+             ELSE
+                ! The continents have changed. The new fraction receives the mean sum of the existent fractions
+                qsurf(i,nsrf) = qsurf(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + qsurf(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
+                evap(i,nsrf)  = evap(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + evap(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
+                rugos(i,nsrf) = rugos(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + rugos(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
+                tsurf(i,nsrf) = tsurf(i,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + tsurf(i,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
+                alb1(i,nsrf)  = alb1(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + alb1(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
+                alb2(i,nsrf)  = alb2(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + alb2(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
+                ustar(i,nsrf)  = ustar(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + ustar(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
+                u10m(i,nsrf)  = u10m(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + u10m(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
+                v10m(i,nsrf)  = v10m(i,nsrf_comp2) *pctsrf_old(i,nsrf_comp2) + v10m(i,nsrf_comp3) *pctsrf_old(i,nsrf_comp3)
+                if (iflag_pbl > 1) then
+                 tke(i,:,nsrf) = tke(i,:,nsrf_comp2)*pctsrf_old(i,nsrf_comp2) + tke(i,:,nsrf_comp3)*pctsrf_old(i,nsrf_comp3)
+                endif
+            
+                ! Security abort. This option has never been tested. To test, comment the following line.
+!                abort_message='The fraction of the continents have changed!'
+!                CALL abort_gcm(modname,abort_message,1)
+                nfois(nsrf) = nfois(nsrf) + 1
+             END IF
+             snow(i,nsrf)     = 0.
+             agesno(i,nsrf)   = 0.
+             ftsoil(i,:,nsrf) = tsurf(i,nsrf)
+          ELSE
+             pfois(nsrf) = pfois(nsrf)+ 1
+          END IF
+       END DO
+       
+    END DO
+
+  END SUBROUTINE pbl_surface_newfrac
+
+!  
+!****************************************************************************************
+!  
+
+END MODULE pbl_surface_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phyaqua.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phyaqua.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phyaqua.F	(revision 17)
@@ -0,0 +1,909 @@
+! Routines complementaires pour la physique planetaire.
+
+
+      subroutine iniaqua(nlon,latfi,lonfi,iflag_phys)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Creation d'un etat initial et de conditions aux limites 
+!  (resp startphy.nc et limit.nc) pour des configurations idealisees 
+! du modele LMDZ dans sa version terrestre.
+!  iflag_phys est un parametre qui controle
+!  iflag_phys = N  
+!    de 100 a 199 : aqua planetes avec SST forcees
+!                 N-100 determine le type de SSTs
+!    de 200 a 299 : terra planetes avec Ts calcule
+!        
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      USE comgeomphy, only : rlatd,rlond
+      USE dimphy, only : klon
+      USE surface_data, only : type_ocean,ok_veget
+      USE pbl_surface_mod, only : pbl_surface_init
+      USE fonte_neige_mod, only : fonte_neige_init
+      USE phys_state_var_mod
+      USE control_mod, only : dayref,nday,iphysiq
+      USE indice_sol_mod
+
+      USE IOIPSL 
+      IMPLICIT NONE
+
+#include "dimensions.h"
+!   #include "dimphy.h"
+!   #include "YOMCST.h"
+#include "comconst.h"
+#include "clesphys.h"
+#include "dimsoil.h"
+#include "temps.h"
+
+      integer,intent(in) :: nlon,iflag_phys
+cIM ajout latfi, lonfi
+      real,intent(in) :: lonfi(nlon),latfi(nlon)
+
+      INTEGER type_profil,type_aqua
+
+c  Ajouts initialisation des surfaces
+      REAL :: run_off_lic_0(nlon)
+      REAL :: qsolsrf(nlon,nbsrf),snsrf(nlon,nbsrf)
+      REAL :: frugs(nlon,nbsrf)
+      REAL :: agesno(nlon,nbsrf)
+      REAL :: tsoil(nlon,nsoilmx,nbsrf)
+      REAL :: tslab(nlon), seaice(nlon)
+      REAL evap(nlon,nbsrf),fder(nlon)
+
+
+
+c    Arguments :
+c    -----------
+
+!      integer radpas  
+      integer it,unit,i,k,itap
+
+      real airefi,zcufi,zcvfi
+
+      real rugos,albedo
+      REAL tsurf
+      REAL time,timestep,day,day0
+      real qsol_f,qsol(nlon)
+      real rugsrel(nlon)
+!      real zmea(nlon),zstd(nlon),zsig(nlon)
+!      real zgam(nlon),zthe(nlon),zpic(nlon),zval(nlon)
+!      real rlon(nlon),rlat(nlon)
+      logical alb_ocean
+!      integer demih_pas
+
+      CHARACTER*80 ans,file_forctl, file_fordat, file_start
+      character*100 file,var
+      character*2 cnbl
+
+      REAL phy_nat(nlon,360)
+      REAL phy_alb(nlon,360)
+      REAL phy_sst(nlon,360)
+      REAL phy_bil(nlon,360)
+      REAL phy_rug(nlon,360)
+      REAL phy_ice(nlon,360)
+      REAL phy_fter(nlon,360)
+      REAL phy_foce(nlon,360)
+      REAL phy_fsic(nlon,360)
+      REAL phy_flic(nlon,360)
+
+      integer, save::  read_climoz=0 ! read ozone climatology
+
+! intermediate variables to use getin
+      integer :: nbapp_rad_omp
+      real :: co2_ppm_omp,solaire_omp
+      logical :: alb_ocean_omp
+      real :: rugos_omp
+!-------------------------------------------------------------------------
+!  declaration pour l'appel a phyredem
+!-------------------------------------------------------------------------
+
+!      real pctsrf(nlon,nbsrf),ftsol(nlon,nbsrf)
+      real falbe(nlon,nbsrf),falblw(nlon,nbsrf)
+!      real pbl_tke(nlon,llm,nbsrf)
+!      real rain_fall(nlon),snow_fall(nlon)
+!      real solsw(nlon), sollw(nlon),radsol(nlon)
+!      real t_ancien(nlon,llm),q_ancien(nlon,llm),rnebcon(nlon,llm)
+!      real ratqs(nlon,llm)
+!      real clwcon(nlon,llm)
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles )
+
+
+c-----------------------------------------------------------------------
+c   dynamial tendencies :
+c   ---------------------
+
+      INTEGER l,ierr,aslun
+
+      REAL longitude,latitude
+      REAL paire 
+
+      DATA latitude,longitude/48.,0./
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! INITIALISATIONS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!-----------------------------------------------------------------------
+!    Initialisations  des constantes
+!    -------------------------------
+
+
+      type_aqua=iflag_phys/100
+      type_profil=iflag_phys-type_aqua*100
+      print*,'iniaqua:type_aqua, type_profil',type_aqua, type_profil
+
+      if (klon.ne.nlon) then
+        write(*,*)"iniaqua: klon=",klon," nlon=",nlon
+        stop'probleme de dimensions dans iniaqua'
+      endif
+      call phys_state_var_init(read_climoz)
+
+
+      read_climoz=0
+      day0=217.
+      day=day0
+      it=0
+      time=0.
+
+cIM ajout latfi, lonfi
+      rlatd=latfi
+      rlond=lonfi
+      rlat=rlatd*180./pi
+      rlon=rlond*180./pi
+
+!-----------------------------------------------------------------------
+!  initialisations de la physique
+!-----------------------------------------------------------------------
+
+         day_ini=dayref
+         day_end=day_ini+nday
+         airefi=1.
+         zcufi=1.
+         zcvfi=1.
+!$OMP MASTER
+      nbapp_rad_omp=24
+      CALL getin('nbapp_rad',nbapp_rad_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+      nbapp_rad=nbapp_rad_omp
+
+!---------------------------------------------------------------------
+c Creation des conditions aux limites:
+c ------------------------------------
+! Initialisations des constantes
+! Ajouter les manquants dans planete.def... (albedo etc)
+!$OMP MASTER
+      co2_ppm_omp=348.
+      CALL getin('co2_ppm',co2_ppm_omp)
+      solaire_omp=1365.
+      CALL getin('solaire',solaire_omp)
+!      CALL getin('albedo',albedo) ! albedo is set below, depending on type_aqua
+      alb_ocean_omp=.true.
+      CALL getin('alb_ocean',alb_ocean_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+      co2_ppm=co2_ppm_omp
+      solaire=solaire_omp
+      alb_ocean=alb_ocean_omp
+
+      radsol=0.
+      qsol_f=10.
+
+c  Conditions aux limites:
+c  -----------------------
+
+      qsol(:)    = qsol_f
+      rugsrel = 0.0    ! (rugsrel = rugoro)
+      rugoro = 0.0
+      u_ancien = 0.0
+      v_ancien = 0.0
+      agesno  = 50.0
+! Relief plat
+      zmea = 0.
+      zstd = 0.
+      zsig = 0.
+      zgam = 0.
+      zthe = 0.
+      zpic = 0.
+      zval = 0.
+
+! Une seule surface
+      pctsrf=0.
+      if (type_aqua==1) then
+         rugos=1.e-4
+         albedo=0.19
+         pctsrf(:,is_oce)=1.
+      else if (type_aqua==2) then
+         rugos=0.03
+         albedo=0.1
+         pctsrf(:,is_ter)=1.
+      endif
+
+!$OMP MASTER
+      rugos_omp=rugos
+      CALL getin('rugos',rugos_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+      rugos=rugos_omp
+      zmasq(:)=pctsrf(:,is_oce)
+
+! pctsrf_pot(:,is_oce) = 1. - zmasq(:)
+! pctsrf_pot(:,is_sic) = 1. - zmasq(:)
+
+! Si alb_ocean on calcule un albedo oceanique moyen
+!  if (alb_ocean) then
+! Voir pourquoi on avait ca.
+!          CALL ini_alb_oce(phy_alb)
+!      else 
+      phy_alb(:,:) = albedo ! albedo land only (old value condsurf_jyg=0.3)
+!      endif !alb_ocean
+      
+      do i=1,360
+cIM Terraplanete   phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2
+cIM ajout calcul profil sst selon le cas considere (cf. FBr)
+
+      phy_nat(:,i) = 1.0    ! 0=ocean libre, 1=land, 2=glacier, 3=banquise
+      phy_bil(:,i) = 1.0    ! ne sert que pour les slab_ocean
+      phy_rug(:,i) = rugos  ! longueur rugosite utilisee sur land only 
+      phy_ice(:,i) = 0.0    ! fraction de glace (?)
+      phy_fter(:,i) = pctsrf(:,is_ter)  ! fraction de glace (?)
+      phy_foce(:,i) = pctsrf(:,is_oce)  ! fraction de glace (?)
+      phy_fsic(:,i) = pctsrf(:,is_sic)  ! fraction de glace (?)
+      phy_flic(:,i) = pctsrf(:,is_lic)  ! fraction de glace (?)
+      enddo
+cIM calcul profil sst
+      call profil_sst(nlon, rlatd, type_profil, phy_sst)
+
+      call writelim
+     s   (klon,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,
+     s    phy_fter,phy_foce,phy_flic,phy_fsic)
+
+
+!---------------------------------------------------------------------
+c Ecriture de l'etat initial:
+c ---------------------------
+
+C
+C Ecriture etat initial physique
+C
+      timestep   = dtvr * FLOAT(iphysiq)
+      radpas    = NINT (daysec/timestep/ FLOAT(nbapp_rad) )
+
+      DO i = 1, longcles
+       clesphy0(i) = 0.
+      ENDDO
+      clesphy0(1) = FLOAT( iflag_con )
+      clesphy0(2) = FLOAT( nbapp_rad )
+c     IF( cycle_diurne  ) clesphy0(3) =  1. 
+      clesphy0(3)=1. ! cycle_diurne
+      clesphy0(4)=1. ! soil_model
+      clesphy0(5)=1. ! new_oliq
+      clesphy0(6)=0. ! ok_orodr
+      clesphy0(7)=0. ! ok_orolf
+      clesphy0(8)=0. ! ok_limitvrai
+
+
+c=======================================================================
+c  Profils initiaux
+c=======================================================================
+
+! On initialise les temperatures de surfaces comme les sst
+      do i=1,nlon
+         ftsol(i,:)=phy_sst(i,1)
+         tsoil(i,:,:)=phy_sst(i,1)
+         tslab(i)=phy_sst(i,1)
+      enddo
+
+      falbe(:,:)=albedo
+      falblw(:,:)=albedo
+      rain_fall(:)=0.
+      snow_fall(:)=0.
+      solsw(:)=0.
+      sollw(:)=0.
+      radsol(:)=0.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  intialisation bidon mais pas grave
+      t_ancien(:,:)=0.
+      q_ancien(:,:)=0.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      rnebcon=0.
+      ratqs=0.
+      clwcon=0.
+      pbl_tke=1.e-8
+
+! variables supplementaires pour appel a plb_surface_init
+      fder(:)=0.
+      seaice(:)=0.
+      run_off_lic_0=0.
+      evap=0.
+
+
+! Initialisations necessaires avant phyredem
+      type_ocean = "force"
+      call fonte_neige_init(run_off_lic_0)
+      qsolsrf(:,:)=qsol(1) ! humidite du sol des sous surface
+      snsrf(:,:)=0.        ! couverture de neige des sous surface
+      frugs(:,:)=rugos        ! couverture de neige des sous surface
+
+
+      call pbl_surface_init(qsol, fder, snsrf, qsolsrf,
+     .     evap, frugs, agesno, tsoil)
+
+        print*,'iniaqua: before phyredem'
+
+      falb1=albedo
+      falb2=albedo
+      zmax0=0.
+      f0=0.
+      ema_work1=0.
+      ema_work2=0.
+      wake_deltat=0.
+      wake_deltaq=0.
+      wake_s=0.
+      wake_cstar=0.
+      wake_pe=0.
+      wake_fip=0.
+      fm_therm=0.
+      entr_therm=0.
+      detr_therm=0.
+
+
+      CALL phyredem ("startphy.nc")
+
+        print*,'iniaqua: after phyredem'
+      call phys_state_var_end
+
+      return
+      end
+
+
+c====================================================================
+c====================================================================
+      SUBROUTINE zenang_an(cycle_diurne,gmtime,rlat,rlon,rmu0,fract)
+      USE dimphy
+      IMPLICIT none
+c====================================================================
+c=============================================================
+c         CALL zenang(cycle_diurne,gmtime,rlat,rlon,rmu0,fract)
+c Auteur : A. Campoy et F. Hourdin
+c Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
+c          et l'ensoleillement moyen entre gmtime1 et gmtime2 
+c          connaissant la declinaison, la latitude et la longitude.
+c 
+c   Dans cette version particuliere, on calcule le rayonnement
+c  moyen sur l'annÃ©e Ã  chaque latitude.
+c   angle zenithal calculÃ© pour obtenir un 
+c   Fit polynomial de  l'ensoleillement moyen au sommet de l'atmosphere
+c   en moyenne annuelle.
+c   SpÃ©cifique de la terre. UtilisÃ© pour les aqua planetes.
+c
+c Rque   : Different de la routine angle en ce sens que zenang 
+c          fournit des moyennes de pmu0 et non des valeurs 
+c          instantanees, du coup frac prend toutes les valeurs 
+c          entre 0 et 1.
+c Date   : premiere version le 13 decembre 1994
+c          revu pour  GCM  le 30 septembre 1996
+c===============================================================
+c longi----INPUT : la longitude vraie de la terre dans son plan
+c                  solaire a partir de l'equinoxe de printemps (degre)
+c gmtime---INPUT : temps universel en fraction de jour
+c pdtrad---INPUT : pas de temps du rayonnement (secondes)
+c lat------INPUT : latitude en degres
+c long-----INPUT : longitude en degres
+c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad
+c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad
+c================================================================
+#include "YOMCST.h"
+c================================================================
+      logical cycle_diurne
+      real  gmtime
+      real rlat(klon), rlon(klon), rmu0(klon), fract(klon)
+c================================================================
+      integer i
+      real gmtime1, gmtime2
+      real pi_local
+
+
+      real rmu0m(klon),rmu0a(klon)
+c
+
+      pi_local = 4.0 * ATAN(1.0)
+
+c================================================================
+c  Calcul de l'angle zenithal moyen sur la journee
+c================================================================
+
+      DO i=1,klon
+        fract(i)=1. 
+!  Calcule du flux moyen
+        IF (abs(rlat(i)).LE.28.75) THEN
+           rmu0m(i)=(210.1924+206.6059*cos(0.0174533*rlat(i))**2)/1365.
+        ELSEIF (abs(rlat(i)).LE.43.75) THEN
+          rmu0m(i)=(187.4562+236.1853*cos(0.0174533*rlat(i))**2)/1365.
+        ELSEIF (abs(rlat(i)).LE.71.25) THEN
+          rmu0m(i)=(162.4439+284.1192*cos(0.0174533*rlat(i))**2)/1365.
+        ELSE
+          rmu0m(i)=(172.8125+183.7673*cos(0.0174533*rlat(i))**2)/1365.
+        ENDIF
+      ENDDO
+
+c================================================================
+!  Avec ou sans cycle diurne
+c================================================================
+
+      IF (cycle_diurne) THEN
+
+!  On redecompose flux  au sommet suivant un cycle diurne idealise
+!  identique a toutes les latitudes.
+
+         DO i=1,klon
+           rmu0a(i)=2.*rmu0m(i)*sqrt(2.)*pi_local/(4.-pi_local)
+           rmu0(i)=rmu0a(i)*abs(sin(pi_local*gmtime+pi_local*
+     &      rlon(i)/360.))-rmu0a(i)/sqrt(2.)
+         ENDDO
+
+         DO i=1,klon
+           IF (rmu0(i).LE.0.) THEN
+              rmu0(i)=0.
+              fract(i)=0.
+           ELSE
+              fract(i)=1.
+           ENDIF
+         ENDDO
+
+!  Affichage de l'angel zenitale
+!     print*,'************************************'
+!     print*,'************************************'
+!     print*,'************************************'
+!     print*,'latitude=',rlat(i),'longitude=',rlon(i)
+!     print*,'rmu0m=',rmu0m(i)
+!     print*,'rmu0a=',rmu0a(i)
+!     print*,'rmu0=',rmu0(i)
+                                                               
+      ELSE
+
+        DO i=1,klon
+           fract(i)=0.5
+           rmu0(i)=rmu0m(i)*2.
+        ENDDO
+
+      ENDIF
+
+      RETURN
+      END
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      subroutine writelim
+     s   (klon,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,
+     s    phy_fter,phy_foce,phy_flic,phy_fsic)
+c
+      use mod_phys_lmdz_para, only: is_mpi_root,is_omp_root
+      use mod_grid_phy_lmdz, only : klon_glo
+      use mod_phys_lmdz_transfert_para, only : gather
+!#include "dimensions.h"
+!#include "dimphy.h"
+#include "netcdf.inc"
+ 
+      integer,intent(in) :: klon
+      real,intent(in) :: phy_nat(klon,360)
+      real,intent(in) :: phy_alb(klon,360)
+      real,intent(in) :: phy_sst(klon,360)
+      real,intent(in) :: phy_bil(klon,360)
+      real,intent(in) :: phy_rug(klon,360)
+      real,intent(in) :: phy_ice(klon,360)
+      real,intent(in) :: phy_fter(klon,360)
+      real,intent(in) :: phy_foce(klon,360)
+      real,intent(in) :: phy_flic(klon,360)
+      real,intent(in) :: phy_fsic(klon,360)
+
+      real :: phy_glo(klon_glo,360) ! temporary variable, to store phy_***(:)
+                                    ! on the whole physics grid 
+      INTEGER ierr
+      INTEGER dimfirst(3)
+      INTEGER dimlast(3)
+c
+      INTEGER nid, ndim, ntim
+      INTEGER dims(2), debut(2), epais(2)
+      INTEGER id_tim
+      INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB
+      INTEGER id_FTER,id_FOCE,id_FSIC,id_FLIC
+ 
+      if (is_mpi_root.and.is_omp_root) then
+      
+        PRINT*, 'writelim: Ecriture du fichier limit'
+c
+        ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid)
+c
+        ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30,
+     .                       "Fichier conditions aux limites")
+!!        ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim)
+        ierr = NF_DEF_DIM (nid, "points_physiques", klon_glo, ndim)
+        ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim)
+c
+        dims(1) = ndim
+        dims(2) = ntim
+c
+ccc      ierr = NF_DEF_VAR (nid, "TEMPS", NF_DOUBLE, 1,ntim, id_tim)
+        ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim)
+        ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17,
+     .                        "Jour dans l annee")
+ccc      ierr = NF_DEF_VAR (nid, "NAT", NF_DOUBLE, 2,dims, id_NAT)
+        ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT)
+        ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23,
+     .                        "Nature du sol (0,1,2,3)")
+ccc      ierr = NF_DEF_VAR (nid, "SST", NF_DOUBLE, 2,dims, id_SST)
+        ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST)
+        ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35,
+     .                        "Temperature superficielle de la mer")
+ccc      ierr = NF_DEF_VAR (nid, "BILS", NF_DOUBLE, 2,dims, id_BILS)
+        ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS)
+        ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32,
+     .                        "Reference flux de chaleur au sol")
+ccc      ierr = NF_DEF_VAR (nid, "ALB", NF_DOUBLE, 2,dims, id_ALB)
+        ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB)
+        ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19,
+     .                        "Albedo a la surface")
+ccc      ierr = NF_DEF_VAR (nid, "RUG", NF_DOUBLE, 2,dims, id_RUG)
+        ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG)
+        ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8,
+     .                        "Rugosite")
+
+        ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 2,dims, id_FTER)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FTER, "title", 8,"Frac. Terre")
+        ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 2,dims, id_FOCE)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FOCE, "title", 8,"Frac. Terre")
+        ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 2,dims, id_FSIC)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FSIC, "title", 8,"Frac. Terre")
+        ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 2,dims, id_FLIC)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FLIC, "title", 8,"Frac. Terre")
+c
+        ierr = NF_ENDDEF(nid)
+c
+
+! write the 'times'
+        do k=1,360
+#ifdef NC_DOUBLE
+          ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k))
+#else
+          ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k))
+#endif
+        enddo
+
+      endif ! of if (is_mpi_root.and.is_omp_root)
+
+! write the fields, after having collected them on master
+
+      call gather(phy_nat,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_NAT,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_NAT,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_nat"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_sst,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_SST,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_SST,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_sst"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_bil,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_BILS,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_BILS,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_bil"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_alb,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_ALB,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_ALB,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_alb"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_rug,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_RUG,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_RUG,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_rug"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_fter,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_FTER,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_FTER,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_fter"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_foce,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_FOCE,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_FOCE,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_foce"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_fsic,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_FSIC,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_FSIC,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_fsic"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_flic,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_FLIC,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_FLIC,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_flic"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+!  close file:
+      if (is_mpi_root.and.is_omp_root) then
+        ierr = NF_CLOSE(nid)
+      endif
+
+      end
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      SUBROUTINE profil_sst(nlon, rlatd, type_profil, phy_sst)
+      use dimphy
+      IMPLICIT none
+c
+      INTEGER nlon, type_profil, i, k, j
+      REAL :: rlatd(nlon), phy_sst(nlon, 360) 
+      INTEGER imn, imx, amn, amx, kmn, kmx
+      INTEGER p, pplus, nlat_max
+      parameter (nlat_max=72)
+      REAL x_anom_sst(nlat_max)
+c
+      if (klon.ne.nlon) stop'probleme de dimensions dans iniaqua'
+      do i=1,360
+c      phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2
+
+c Rajout fbrlmd
+
+      if(type_profil.EQ.1)then
+c     MÃ©thode 1 "Control" faible plateau Ã  l'Equateur
+      do j=1,klon
+       phy_sst(j,i)=273.+27.*(1-sin(1.5*rlatd(j))**2)
+c        PI/3=1.047197551
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+      if(type_profil.EQ.2)then
+c     MÃ©thode 2 "Flat" fort plateau Ã  l'Equateur
+      do j=1,klon
+       phy_sst(j,i)=273.+27.*(1-sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+
+      if (type_profil.EQ.3) then
+c     MÃ©thode 3 "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+0.5*27.*(2-sin(1.5*rlatd(j))**2
+     &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.4) then
+c     MÃ©thode 4 : MÃ©thode 3 + SST+2 "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+0.5*29.*(2-sin(1.5*rlatd(j))**2
+     &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.5) then
+c     MÃ©thode 5 : MÃ©thode 3 + +2K "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+2.+0.5*27.*(2-sin(1.5*rlatd(j))**2
+     &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.+2.
+        endif
+
+      enddo
+      endif
+
+      if(type_profil.EQ.6)then
+c     MÃ©thode 6 "cst" valeur constante de SST
+      do j=1,klon
+       phy_sst(j,i)=288.
+      enddo
+      endif
+
+
+        if(type_profil.EQ.7)then
+c     MÃ©thode 7 "cst" valeur constante de SST +2
+      do j=1,klon
+       phy_sst(j,i)=288.+2.
+      enddo
+      endif
+
+        p=0
+        if(type_profil.EQ.8)then
+c     MÃ©thode 8 profil anomalies SST du modÃšle couplÃ© AR4
+       do j=1,klon
+         if (rlatd(j).EQ.rlatd(j-1)) then
+       phy_sst(j,i)=273.+x_anom_sst(pplus)
+     &     +0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5*rlatd(j))**4)
+          if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+            phy_sst(j,i)=273.+x_anom_sst(pplus)
+          endif
+        else
+          p=p+1
+          pplus=73-p
+        phy_sst(j,i)=273.+x_anom_sst(pplus)
+     &     +0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5*rlatd(j))**4)
+          if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+            phy_sst(j,i)=273.+x_anom_sst(pplus)
+          endif
+          write (*,*) rlatd(j),x_anom_sst(pplus),phy_sst(j,i)
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.9) then
+c     MÃ©thode 5 : MÃ©thode 3 + -2K "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.-2.+0.5*27.*(2-sin(1.5*rlatd(j))**2
+     &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.-2.
+        endif
+      enddo
+      endif
+
+
+      if (type_profil.EQ.10) then
+c     MÃ©thode 10 : MÃ©thode 3 + +4K "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+4.+0.5*27.*(2-sin(1.5*rlatd(j))**2
+     &                 -sin(1.5*rlatd(j))**4)
+        if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.+4.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.11) then
+c     MÃ©thode 11 : MÃ©thode 3 + 4CO2 "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+0.5*27.*(2-sin(1.5*rlatd(j))**2
+     &                 -sin(1.5*rlatd(j))**4)
+        if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.12) then
+c     MÃ©thode 12 : MÃ©thode 10 + 4CO2 "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+4.+0.5*27.*(2-sin(1.5*rlatd(j))**2
+     &                 -sin(1.5*rlatd(j))**4)
+        if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.+4.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.13) then
+c     MÃ©thode 13 "Qmax" plateau rÃ©el Ã  l'Equateur augmentÃ© !
+      do j=1,klon
+        phy_sst(j,i)=273.+0.5*29.*(2-sin(1.5*rlatd(j))**2
+     &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.14) then
+c     MÃ©thode 13 "Qmax2K" plateau rÃ©el Ã  l'Equateur augmentÃ© +2K !
+      do j=1,klon
+        phy_sst(j,i)=273.+2.+0.5*29.*(2-sin(1.5*rlatd(j))**2
+     &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      enddo
+
+cIM beg : verif profil SST: phy_sst
+       amn=MIN(phy_sst(1,1),1000.)
+       amx=MAX(phy_sst(1,1),-1000.)
+       DO k=1, 360
+       DO i=2, nlon
+        IF(phy_sst(i,k).LT.amn) THEN
+         amn=phy_sst(i,k)
+         imn=i
+         kmn=k
+        ENDIF
+        IF(phy_sst(i,k).GT.amx) THEN
+         amx=phy_sst(i,k)
+         imx=i
+         kmx=k
+        ENDIF
+       ENDDO
+       ENDDO
+c
+       PRINT*,' debut avant writelim min max phy_sst',imn,kmn,amn,
+     & imx,kmx,amx
+cIM end : verif profil SST: phy_sst
+
+       return 
+       end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phyaqua.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phyaqua.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phyaqua.F90	(revision 17)
@@ -0,0 +1,914 @@
+! Routines complementaires pour la physique planetaire.
+
+
+      SUBROUTINE iniaqua(nlon,latfi,lonfi,iflag_phys)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Creation d'un etat initial et de conditions aux limites 
+!  (resp startphy.nc et limit.nc) pour des configurations idealisees 
+! du modele LMDZ dans sa version terrestre.
+!  iflag_phys est un parametre qui controle
+!  iflag_phys = N  
+!    de 100 a 199 : aqua planetes avec SST forcees
+!                 N-100 determine le type de SSTs
+!    de 200 a 299 : terra planetes avec Ts calcule
+!        
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      USE comgeomphy, only : rlatd,rlond
+      USE dimphy, only : klon
+      USE surface_data, only : type_ocean,ok_veget
+      USE pbl_surface_mod, only : pbl_surface_init
+      USE fonte_neige_mod, only : fonte_neige_init
+      USE phys_state_var_mod
+      USE control_mod, only : dayref,nday,iphysiq
+      USE indice_sol_mod
+
+      USE IOIPSL 
+      IMPLICIT NONE
+
+#include "dimensions.h"
+!   #include "dimphy.h"
+!   #include "YOMCST.h"
+#include "comconst.h"
+#include "clesphys.h"
+#include "dimsoil.h"
+#include "temps.h"
+
+      integer,intent(in) :: nlon,iflag_phys
+!IM ajout latfi, lonfi
+      real,intent(in) :: lonfi(nlon),latfi(nlon)
+
+      INTEGER type_profil,type_aqua
+
+!c  Ajouts initialisation des surfaces
+      REAL :: run_off_lic_0(nlon)
+      REAL :: qsolsrf(nlon,nbsrf),snsrf(nlon,nbsrf)
+      REAL :: frugs(nlon,nbsrf)
+      REAL :: agesno(nlon,nbsrf)
+      REAL :: tsoil(nlon,nsoilmx,nbsrf)
+      REAL :: tslab(nlon), seaice(nlon)
+      REAL evap(nlon,nbsrf),fder(nlon)
+
+
+
+!c    Arguments :
+!c    -----------
+
+!      integer radpas  
+      integer it,unit,i,k,itap
+
+      real airefi,zcufi,zcvfi
+
+      real rugos,albedo
+      REAL tsurf
+      REAL time,timestep,day,day0
+      real qsol_f,qsol(nlon)
+      real rugsrel(nlon)
+!      real zmea(nlon),zstd(nlon),zsig(nlon)
+!      real zgam(nlon),zthe(nlon),zpic(nlon),zval(nlon)
+!      real rlon(nlon),rlat(nlon)
+      logical alb_ocean
+!      integer demih_pas
+
+      CHARACTER*80 ans,file_forctl, file_fordat, file_start
+      character*100 file,var
+      character*2 cnbl
+
+      REAL phy_nat(nlon,360)
+      REAL phy_alb(nlon,360)
+      REAL phy_sst(nlon,360)
+      REAL phy_bil(nlon,360)
+      REAL phy_rug(nlon,360)
+      REAL phy_ice(nlon,360)
+      REAL phy_fter(nlon,360)
+      REAL phy_foce(nlon,360)
+      REAL phy_fsic(nlon,360)
+      REAL phy_flic(nlon,360)
+
+      integer, save::  read_climoz=0 ! read ozone climatology
+
+! intermediate variables to use getin
+      integer :: nbapp_rad_omp
+      real :: co2_ppm_omp,solaire_omp
+      logical :: alb_ocean_omp
+      real :: rugos_omp
+!-------------------------------------------------------------------------
+!  declaration pour l'appel a phyredem
+!-------------------------------------------------------------------------
+
+!      real pctsrf(nlon,nbsrf),ftsol(nlon,nbsrf)
+      real falbe(nlon,nbsrf),falblw(nlon,nbsrf)
+!      real pbl_tke(nlon,llm,nbsrf)
+!      real rain_fall(nlon),snow_fall(nlon)
+!      real solsw(nlon), sollw(nlon),radsol(nlon)
+!      real t_ancien(nlon,llm),q_ancien(nlon,llm),rnebcon(nlon,llm)
+!      real ratqs(nlon,llm)
+!      real clwcon(nlon,llm)
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles )
+
+
+!c-----------------------------------------------------------------------
+!c   dynamial tendencies :
+!c   ---------------------
+
+      INTEGER l,ierr,aslun
+
+      REAL longitude,latitude
+      REAL paire 
+
+      DATA latitude,longitude/48.,0./
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! INITIALISATIONS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!-----------------------------------------------------------------------
+!    Initialisations  des constantes
+!    -------------------------------
+
+      type_aqua=iflag_phys/100
+      type_profil=iflag_phys-type_aqua*100
+      print*,'iniaqua:type_aqua, type_profil',type_aqua, type_profil
+
+      if (klon.ne.nlon) then
+        write(*,*)"iniaqua: klon=",klon," nlon=",nlon
+        stop'probleme de dimensions dans iniaqua'
+      endif
+      call phys_state_var_init(read_climoz)
+
+
+      read_climoz=0
+      day0=217.
+      day=day0
+      it=0
+      time=0.
+
+!IM ajout latfi, lonfi
+      rlatd=latfi
+      rlond=lonfi
+!L. Fita, LMD. September 2013
+      pi = ACOS(-1.)
+      rlat=rlatd*180./pi
+      rlon=rlond*180./pi
+
+!-----------------------------------------------------------------------
+!  initialisations de la physique
+!-----------------------------------------------------------------------
+
+         day_ini=dayref
+         day_end=day_ini+nday
+         airefi=1.
+         zcufi=1.
+         zcvfi=1.
+!$OMP MASTER
+      nbapp_rad_omp=24
+      CALL getin('nbapp_rad',nbapp_rad_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+      nbapp_rad=nbapp_rad_omp
+
+!---------------------------------------------------------------------
+!c Creation des conditions aux limites:
+!c ------------------------------------
+! Initialisations des constantes
+! Ajouter les manquants dans planete.def... (albedo etc)
+!$OMP MASTER
+      co2_ppm_omp=348.
+      CALL getin('co2_ppm',co2_ppm_omp)
+      solaire_omp=1365.
+      CALL getin('solaire',solaire_omp)
+!      CALL getin('albedo',albedo) ! albedo is set below, depending on type_aqua
+      alb_ocean_omp=.true.
+      CALL getin('alb_ocean',alb_ocean_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+      co2_ppm=co2_ppm_omp
+      solaire=solaire_omp
+      alb_ocean=alb_ocean_omp
+
+      radsol=0.
+      qsol_f=10.
+
+!c  Conditions aux limites:
+!c  -----------------------
+
+      qsol(:)    = qsol_f
+      rugsrel = 0.0    ! (rugsrel = rugoro)
+      rugoro = 0.0
+      u_ancien = 0.0
+      v_ancien = 0.0
+      agesno  = 50.0
+! Relief plat
+      zmea = 0.
+      zstd = 0.
+      zsig = 0.
+      zgam = 0.
+      zthe = 0.
+      zpic = 0.
+      zval = 0.
+
+! Une seule surface
+      pctsrf=0.
+      if (type_aqua==1) then
+         rugos=1.e-4
+         albedo=0.19
+         pctsrf(:,is_oce)=1.
+      else if (type_aqua==2) then
+         rugos=0.03
+         albedo=0.1
+         pctsrf(:,is_ter)=1.
+      endif
+
+!$OMP MASTER
+      rugos_omp=rugos
+      CALL getin('rugos',rugos_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+      rugos=rugos_omp
+      zmasq(:)=pctsrf(:,is_oce)
+
+! pctsrf_pot(:,is_oce) = 1. - zmasq(:)
+! pctsrf_pot(:,is_sic) = 1. - zmasq(:)
+
+! Si alb_ocean on calcule un albedo oceanique moyen
+!  if (alb_ocean) then
+! Voir pourquoi on avait ca.
+!          CALL ini_alb_oce(phy_alb)
+!      else 
+      phy_alb(:,:) = albedo ! albedo land only (old value condsurf_jyg=0.3)
+!      endif !alb_ocean
+      
+      do i=1,360
+!IM Terraplanete   phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2
+!IM ajout calcul profil sst selon le cas considere (cf. FBr)
+
+      phy_nat(:,i) = 1.0    ! 0=ocean libre, 1=land, 2=glacier, 3=banquise
+      phy_bil(:,i) = 1.0    ! ne sert que pour les slab_ocean
+      phy_rug(:,i) = rugos  ! longueur rugosite utilisee sur land only 
+      phy_ice(:,i) = 0.0    ! fraction de glace (?)
+      phy_fter(:,i) = pctsrf(:,is_ter)  ! fraction de glace (?)
+      phy_foce(:,i) = pctsrf(:,is_oce)  ! fraction de glace (?)
+      phy_fsic(:,i) = pctsrf(:,is_sic)  ! fraction de glace (?)
+      phy_flic(:,i) = pctsrf(:,is_lic)  ! fraction de glace (?)
+      enddo
+!IM calcul profil sst
+      call profil_sst(nlon, rlatd, type_profil, phy_sst)
+
+      call writelim                                                                  &
+       &   (klon,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,                    &
+       &    phy_fter,phy_foce,phy_flic,phy_fsic)
+
+
+!---------------------------------------------------------------------
+!c Ecriture de l'etat initial:
+!c ---------------------------
+
+!C
+!C Ecriture etat initial physique
+!C
+      timestep   = dtvr * FLOAT(iphysiq)
+      radpas    = NINT (daysec/timestep/ FLOAT(nbapp_rad) )
+
+      DO i = 1, longcles
+       clesphy0(i) = 0.
+      ENDDO
+      clesphy0(1) = FLOAT( iflag_con )
+      clesphy0(2) = FLOAT( nbapp_rad )
+!c     IF( cycle_diurne  ) clesphy0(3) =  1. 
+      clesphy0(3)=1. ! cycle_diurne
+      clesphy0(4)=1. ! soil_model
+      clesphy0(5)=1. ! new_oliq
+      clesphy0(6)=0. ! ok_orodr
+      clesphy0(7)=0. ! ok_orolf
+      clesphy0(8)=0. ! ok_limitvrai
+
+
+!c=======================================================================
+!c  Profils initiaux
+!c=======================================================================
+
+! On initialise les temperatures de surfaces comme les sst
+      do i=1,nlon
+         ftsol(i,:)=phy_sst(i,1)
+         tsoil(i,:,:)=phy_sst(i,1)
+         tslab(i)=phy_sst(i,1)
+      enddo
+
+      falbe(:,:)=albedo
+      falblw(:,:)=albedo
+      rain_fall(:)=0.
+      snow_fall(:)=0.
+      solsw(:)=0.
+      sollw(:)=0.
+      radsol(:)=0.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  intialisation bidon mais pas grave
+      t_ancien(:,:)=0.
+      q_ancien(:,:)=0.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      rnebcon=0.
+      ratqs=0.
+      clwcon=0.
+      pbl_tke=1.e-8
+
+! variables supplementaires pour appel a plb_surface_init
+      fder(:)=0.
+      seaice(:)=0.
+      run_off_lic_0=0.
+      evap=0.
+
+
+! Initialisations necessaires avant phyredem
+      type_ocean = "force"
+      call fonte_neige_init(run_off_lic_0)
+      qsolsrf(:,:)=qsol(1) ! humidite du sol des sous surface
+      snsrf(:,:)=0.        ! couverture de neige des sous surface
+      frugs(:,:)=rugos        ! couverture de neige des sous surface
+
+
+      call pbl_surface_init(qsol, fder, snsrf, qsolsrf,                              &
+       &     evap, frugs, agesno, tsoil)
+
+        print*,'iniaqua: before phyredem'
+
+      falb1=albedo
+      falb2=albedo
+      zmax0=0.
+      f0=0.
+      ema_work1=0.
+      ema_work2=0.
+      wake_deltat=0.
+      wake_deltaq=0.
+      wake_s=0.
+      wake_cstar=0.
+      wake_pe=0.
+      wake_fip=0.
+      fm_therm=0.
+      entr_therm=0.
+      detr_therm=0.
+
+
+      CALL phyredem ("startphy.nc")
+
+        print*,'iniaqua: after phyredem'
+      call phys_state_var_end
+
+      return
+      end SUBROUTINE iniaqua
+
+
+!c====================================================================
+!c====================================================================
+      SUBROUTINE zenang_an(cycle_diurne,gmtime,rlat,rlon,rmu0,fract)
+      USE dimphy
+      IMPLICIT none
+!c====================================================================
+!c=============================================================
+!c         CALL zenang(cycle_diurne,gmtime,rlat,rlon,rmu0,fract)
+!c Auteur : A. Campoy et F. Hourdin
+!c Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
+!c          et l'ensoleillement moyen entre gmtime1 et gmtime2 
+!c          connaissant la declinaison, la latitude et la longitude.
+!c 
+!c   Dans cette version particuliere, on calcule le rayonnement
+!c  moyen sur l'annÃ©e Ã  chaque latitude.
+!c   angle zenithal calculÃ© pour obtenir un 
+!c   Fit polynomial de  l'ensoleillement moyen au sommet de l'atmosphere
+!c   en moyenne annuelle.
+!c   SpÃ©cifique de la terre. UtilisÃ© pour les aqua planetes.
+!c
+!c Rque   : Different de la routine angle en ce sens que zenang 
+!c          fournit des moyennes de pmu0 et non des valeurs 
+!c          instantanees, du coup frac prend toutes les valeurs 
+!c          entre 0 et 1.
+!c Date   : premiere version le 13 decembre 1994
+!c          revu pour  GCM  le 30 septembre 1996
+!c===============================================================
+!c longi----INPUT : la longitude vraie de la terre dans son plan
+!c                  solaire a partir de l'equinoxe de printemps (degre)
+!c gmtime---INPUT : temps universel en fraction de jour
+!c pdtrad---INPUT : pas de temps du rayonnement (secondes)
+!c lat------INPUT : latitude en degres
+!c long-----INPUT : longitude en degres
+!c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad
+!c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad
+!c================================================================
+#include "YOMCST.h"
+!c================================================================
+      logical cycle_diurne
+      real  gmtime
+      real rlat(klon), rlon(klon), rmu0(klon), fract(klon)
+!c================================================================
+      integer i
+      real gmtime1, gmtime2
+      real pi_local
+
+
+      real rmu0m(klon),rmu0a(klon)
+!c
+
+      pi_local = 4.0 * ATAN(1.0)
+
+!c================================================================
+!c  Calcul de l'angle zenithal moyen sur la journee
+!c================================================================
+
+      DO i=1,klon
+        fract(i)=1. 
+!  Calcule du flux moyen
+        IF (abs(rlat(i)).LE.28.75) THEN
+           rmu0m(i)=(210.1924+206.6059*cos(0.0174533*rlat(i))**2)/1365.
+        ELSEIF (abs(rlat(i)).LE.43.75) THEN
+          rmu0m(i)=(187.4562+236.1853*cos(0.0174533*rlat(i))**2)/1365.
+        ELSEIF (abs(rlat(i)).LE.71.25) THEN
+          rmu0m(i)=(162.4439+284.1192*cos(0.0174533*rlat(i))**2)/1365.
+        ELSE
+          rmu0m(i)=(172.8125+183.7673*cos(0.0174533*rlat(i))**2)/1365.
+        ENDIF
+      ENDDO
+
+!c================================================================
+!  Avec ou sans cycle diurne
+!c================================================================
+
+      IF (cycle_diurne) THEN
+
+!  On redecompose flux  au sommet suivant un cycle diurne idealise
+!  identique a toutes les latitudes.
+
+         DO i=1,klon
+           rmu0a(i)=2.*rmu0m(i)*sqrt(2.)*pi_local/(4.-pi_local)
+           rmu0(i)=rmu0a(i)*abs(sin(pi_local*gmtime+pi_local*                        &
+       &      rlon(i)/360.))-rmu0a(i)/sqrt(2.)
+         ENDDO
+
+         DO i=1,klon
+           IF (rmu0(i).LE.0.) THEN
+              rmu0(i)=0.
+              fract(i)=0.
+           ELSE
+              fract(i)=1.
+           ENDIF
+         ENDDO
+
+!  Affichage de l'angel zenitale
+!     print*,'************************************'
+!     print*,'************************************'
+!     print*,'************************************'
+!     print*,'latitude=',rlat(i),'longitude=',rlon(i)
+!     print*,'rmu0m=',rmu0m(i)
+!     print*,'rmu0a=',rmu0a(i)
+!     print*,'rmu0=',rmu0(i)
+                                                               
+      ELSE
+
+        DO i=1,klon
+           fract(i)=0.5
+           rmu0(i)=rmu0m(i)*2.
+        ENDDO
+
+      ENDIF
+
+      RETURN
+      END SUBROUTINE zenang_an
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      SUBROUTINE writelim                                                            &
+       &   (klon,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,                    &
+       &    phy_fter,phy_foce,phy_flic,phy_fsic)
+!c
+      use mod_phys_lmdz_para, only: is_mpi_root,is_omp_root
+      use mod_grid_phy_lmdz, only : klon_glo
+      use mod_phys_lmdz_transfert_para, only : gather
+!L. Fita, LMD. September 2013
+      USE netcdf
+!#include "dimensions.h"
+!#include "dimphy.h"
+!L. Fita, LMD. September 2013
+#include "netcdf.inc"
+ 
+      integer,intent(in) :: klon
+      real,intent(in) :: phy_nat(klon,360)
+      real,intent(in) :: phy_alb(klon,360)
+      real,intent(in) :: phy_sst(klon,360)
+      real,intent(in) :: phy_bil(klon,360)
+      real,intent(in) :: phy_rug(klon,360)
+      real,intent(in) :: phy_ice(klon,360)
+      real,intent(in) :: phy_fter(klon,360)
+      real,intent(in) :: phy_foce(klon,360)
+      real,intent(in) :: phy_flic(klon,360)
+      real,intent(in) :: phy_fsic(klon,360)
+
+      real :: phy_glo(klon_glo,360) ! temporary variable, to store phy_***(:)
+                                    ! on the whole physics grid 
+      INTEGER ierr
+      INTEGER dimfirst(3)
+      INTEGER dimlast(3)
+!c
+      INTEGER nid, ndim, ntim
+      INTEGER dims(2), debut(2), epais(2)
+      INTEGER id_tim
+      INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB
+      INTEGER id_FTER,id_FOCE,id_FSIC,id_FLIC
+ 
+      if (is_mpi_root.and.is_omp_root) then
+      
+        PRINT*, 'writelim: Ecriture du fichier limit'
+!c
+        ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid)
+!c
+        ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30,                         &
+       &                       "Fichier conditions aux limites")
+        PRINT *,'    Writting title: ',nid,ierr
+!!        ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim)
+        ierr = NF_DEF_DIM (nid, "points_physiques", klon_glo, ndim)
+        ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim)
+!c
+        dims(1) = ndim
+        dims(2) = ntim
+!c
+!ccc      ierr = NF_DEF_VAR (nid, "TEMPS", NF_DOUBLE, 1,ntim, id_tim)
+        ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim)
+        ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17,                            &
+       &                        "Jour dans l annee")
+!ccc      ierr = NF_DEF_VAR (nid, "NAT", NF_DOUBLE, 2,dims, id_NAT)
+        ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT)
+        ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23,                            &
+       &                        "Nature du sol (0,1,2,3)")
+!ccc      ierr = NF_DEF_VAR (nid, "SST", NF_DOUBLE, 2,dims, id_SST)
+        ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST)
+        ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35,                            &
+       &                        "Temperature superficielle de la mer")
+!ccc      ierr = NF_DEF_VAR (nid, "BILS", NF_DOUBLE, 2,dims, id_BILS)
+        ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS)
+        ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32,                           &
+       &                        "Reference flux de chaleur au sol")
+!ccc      ierr = NF_DEF_VAR (nid, "ALB", NF_DOUBLE, 2,dims, id_ALB)
+        ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB)
+        ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19,                            &
+       &                        "Albedo a la surface")
+!ccc      ierr = NF_DEF_VAR (nid, "RUG", NF_DOUBLE, 2,dims, id_RUG)
+        ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG)
+        ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8,                             &
+       &                        "Rugosite")
+
+        ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 2,dims, id_FTER)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FTER, "title", 8,"Frac. Terre")
+        ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 2,dims, id_FOCE)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FOCE, "title", 8,"Frac. Terre")
+        ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 2,dims, id_FSIC)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FSIC, "title", 8,"Frac. Terre")
+        ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 2,dims, id_FLIC)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FLIC, "title", 8,"Frac. Terre")
+!c
+        ierr = NF_ENDDEF(nid)
+!c
+
+! write the 'times'
+        do k=1,360
+#ifdef NC_DOUBLE
+          ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k))
+#else
+          ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k))
+#endif
+        enddo
+
+      endif ! of if (is_mpi_root.and.is_omp_root)
+
+! write the fields, after having collected them on master
+
+      call gather(phy_nat,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_NAT,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_NAT,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_nat"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_sst,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_SST,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_SST,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_sst"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_bil,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_BILS,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_BILS,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_bil"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_alb,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_ALB,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_ALB,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_alb"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_rug,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_RUG,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_RUG,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_rug"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_fter,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_FTER,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_FTER,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_fter"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_foce,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_FOCE,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_FOCE,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_foce"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_fsic,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_FSIC,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_FSIC,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_fsic"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_flic,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_FLIC,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_FLIC,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_flic"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+!  close file:
+      if (is_mpi_root.and.is_omp_root) then
+        ierr = NF_CLOSE(nid)
+      endif
+
+      end SUBROUTINE writelim
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      SUBROUTINE profil_sst(nlon, rlatd, type_profil, phy_sst)
+      use dimphy
+      IMPLICIT none
+!c
+      INTEGER nlon, type_profil, i, k, j
+      REAL :: rlatd(nlon), phy_sst(nlon, 360) 
+      INTEGER imn, imx, amn, amx, kmn, kmx
+      INTEGER p, pplus, nlat_max
+      parameter (nlat_max=72)
+      REAL x_anom_sst(nlat_max)
+!c
+      if (klon.ne.nlon) stop'probleme de dimensions dans iniaqua'
+      do i=1,360
+!c      phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2
+
+!c Rajout fbrlmd
+
+      if(type_profil.EQ.1)then
+!c     MÃ©thode 1 "Control" faible plateau Ã  l'Equateur
+      do j=1,klon
+       phy_sst(j,i)=273.+27.*(1-sin(1.5*rlatd(j))**2)
+!c        PI/3=1.047197551
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+      if(type_profil.EQ.2)then
+!c     MÃ©thode 2 "Flat" fort plateau Ã  l'Equateur
+      do j=1,klon
+       phy_sst(j,i)=273.+27.*(1-sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+
+      if (type_profil.EQ.3) then
+!c     MÃ©thode 3 "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+0.5*27.*(2-sin(1.5*rlatd(j))**2                            &
+       &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.4) then
+!c     MÃ©thode 4 : MÃ©thode 3 + SST+2 "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+0.5*29.*(2-sin(1.5*rlatd(j))**2                            &
+       &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.5) then
+!c     MÃ©thode 5 : MÃ©thode 3 + +2K "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+2.+0.5*27.*(2-sin(1.5*rlatd(j))**2                         &
+       &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.+2.
+        endif
+
+      enddo
+      endif
+
+      if(type_profil.EQ.6)then
+!c     MÃ©thode 6 "cst" valeur constante de SST
+      do j=1,klon
+       phy_sst(j,i)=288.
+      enddo
+      endif
+
+
+        if(type_profil.EQ.7)then
+!c     MÃ©thode 7 "cst" valeur constante de SST +2
+      do j=1,klon
+       phy_sst(j,i)=288.+2.
+      enddo
+      endif
+
+        p=0
+        if(type_profil.EQ.8)then
+!c     MÃ©thode 8 profil anomalies SST du modÃšle couplÃ© AR4
+       do j=1,klon
+         if (rlatd(j).EQ.rlatd(j-1)) then
+       phy_sst(j,i)=273.+x_anom_sst(pplus)                                           &
+       &     +0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5*rlatd(j))**4)
+          if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+            phy_sst(j,i)=273.+x_anom_sst(pplus)
+          endif
+        else
+          p=p+1
+          pplus=73-p
+        phy_sst(j,i)=273.+x_anom_sst(pplus)                                          &
+       &     +0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5*rlatd(j))**4)
+          if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+            phy_sst(j,i)=273.+x_anom_sst(pplus)
+          endif
+          write (*,*) rlatd(j),x_anom_sst(pplus),phy_sst(j,i)
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.9) then
+!c     MÃ©thode 5 : MÃ©thode 3 + -2K "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.-2.+0.5*27.*(2-sin(1.5*rlatd(j))**2                         &
+       &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.-2.
+        endif
+      enddo
+      endif
+
+
+      if (type_profil.EQ.10) then
+!c     MÃ©thode 10 : MÃ©thode 3 + +4K "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+4.+0.5*27.*(2-sin(1.5*rlatd(j))**2                         &
+       &                 -sin(1.5*rlatd(j))**4)
+        if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.+4.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.11) then
+!c     MÃ©thode 11 : MÃ©thode 3 + 4CO2 "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+0.5*27.*(2-sin(1.5*rlatd(j))**2                            &
+       &                 -sin(1.5*rlatd(j))**4)
+        if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.12) then
+!c     MÃ©thode 12 : MÃ©thode 10 + 4CO2 "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+4.+0.5*27.*(2-sin(1.5*rlatd(j))**2                         &
+       &                 -sin(1.5*rlatd(j))**4)
+        if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.+4.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.13) then
+!c     MÃ©thode 13 "Qmax" plateau rÃ©el Ã  l'Equateur augmentÃ© !
+      do j=1,klon
+        phy_sst(j,i)=273.+0.5*29.*(2-sin(1.5*rlatd(j))**2                            &
+       &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.14) then
+!c     MÃ©thode 13 "Qmax2K" plateau rÃ©el Ã  l'Equateur augmentÃ© +2K !
+      do j=1,klon
+        phy_sst(j,i)=273.+2.+0.5*29.*(2-sin(1.5*rlatd(j))**2                         &
+       &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      enddo
+
+!IM beg : verif profil SST: phy_sst
+       amn=MIN(phy_sst(1,1),1000.)
+       amx=MAX(phy_sst(1,1),-1000.)
+       DO k=1, 360
+       DO i=2, nlon
+        IF(phy_sst(i,k).LT.amn) THEN
+         amn=phy_sst(i,k)
+         imn=i
+         kmn=k
+        ENDIF
+        IF(phy_sst(i,k).GT.amx) THEN
+         amx=phy_sst(i,k)
+         imx=i
+         kmx=k
+        ENDIF
+       ENDDO
+       ENDDO
+!c
+       PRINT*,' debut avant writelim min max phy_sst',imn,kmn,amn,                   &
+       & imx,kmx,amx
+!IM end : verif profil SST: phy_sst
+
+       return 
+       end SUBROUTINE profil_sst
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phyaqua_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phyaqua_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phyaqua_mod.F90	(revision 17)
@@ -0,0 +1,917 @@
+! Routines complementaires pour la physique planetaire.
+
+MODULE phyaqua_mod
+
+  CONTAINS
+
+      subroutine iniaqua(nlon,latfi,lonfi,iflag_phys)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  Creation d'un etat initial et de conditions aux limites 
+!  (resp startphy.nc et limit.nc) pour des configurations idealisees 
+! du modele LMDZ dans sa version terrestre.
+!  iflag_phys est un parametre qui controle
+!  iflag_phys = N  
+!    de 100 a 199 : aqua planetes avec SST forcees
+!                 N-100 determine le type de SSTs
+!    de 200 a 299 : terra planetes avec Ts calcule
+!        
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      USE comgeomphy, only : rlatd,rlond
+      USE dimphy, only : klon
+      USE surface_data, only : type_ocean,ok_veget
+      USE pbl_surface_mod, only : pbl_surface_init
+      USE fonte_neige_mod, only : fonte_neige_init
+      USE phys_state_var_mod
+      USE control_mod, only : dayref,nday,iphysiq
+      USE indice_sol_mod
+
+      USE IOIPSL 
+      IMPLICIT NONE
+
+#include "dimensions.h"
+!   #include "dimphy.h"
+!   #include "YOMCST.h"
+#include "comconst.h"
+#include "clesphys.h"
+#include "dimsoil.h"
+#include "temps.h"
+
+      integer,intent(in) :: nlon,iflag_phys
+!IM ajout latfi, lonfi
+      real,intent(in) :: lonfi(nlon),latfi(nlon)
+
+      INTEGER type_profil,type_aqua
+
+!c  Ajouts initialisation des surfaces
+      REAL :: run_off_lic_0(nlon)
+      REAL :: qsolsrf(nlon,nbsrf),snsrf(nlon,nbsrf)
+      REAL :: frugs(nlon,nbsrf)
+      REAL :: agesno(nlon,nbsrf)
+      REAL :: tsoil(nlon,nsoilmx,nbsrf)
+      REAL :: tslab(nlon), seaice(nlon)
+      REAL evap(nlon,nbsrf),fder(nlon)
+
+
+
+!c    Arguments :
+!c    -----------
+
+!      integer radpas  
+      integer it,unit,i,k,itap
+
+      real airefi,zcufi,zcvfi
+
+      real rugos,albedo
+      REAL tsurf
+      REAL time,timestep,day,day0
+      real qsol_f,qsol(nlon)
+      real rugsrel(nlon)
+!      real zmea(nlon),zstd(nlon),zsig(nlon)
+!      real zgam(nlon),zthe(nlon),zpic(nlon),zval(nlon)
+!      real rlon(nlon),rlat(nlon)
+      logical alb_ocean
+!      integer demih_pas
+
+      CHARACTER*80 ans,file_forctl, file_fordat, file_start
+      character*100 file,var
+      character*2 cnbl
+
+      REAL phy_nat(nlon,360)
+      REAL phy_alb(nlon,360)
+      REAL phy_sst(nlon,360)
+      REAL phy_bil(nlon,360)
+      REAL phy_rug(nlon,360)
+      REAL phy_ice(nlon,360)
+      REAL phy_fter(nlon,360)
+      REAL phy_foce(nlon,360)
+      REAL phy_fsic(nlon,360)
+      REAL phy_flic(nlon,360)
+
+      integer, save::  read_climoz=0 ! read ozone climatology
+
+! intermediate variables to use getin
+      integer :: nbapp_rad_omp
+      real :: co2_ppm_omp,solaire_omp
+      logical :: alb_ocean_omp
+      real :: rugos_omp
+!-------------------------------------------------------------------------
+!  declaration pour l'appel a phyredem
+!-------------------------------------------------------------------------
+
+!      real pctsrf(nlon,nbsrf),ftsol(nlon,nbsrf)
+      real falbe(nlon,nbsrf),falblw(nlon,nbsrf)
+!      real pbl_tke(nlon,llm,nbsrf)
+!      real rain_fall(nlon),snow_fall(nlon)
+!      real solsw(nlon), sollw(nlon),radsol(nlon)
+!      real t_ancien(nlon,llm),q_ancien(nlon,llm),rnebcon(nlon,llm)
+!      real ratqs(nlon,llm)
+!      real clwcon(nlon,llm)
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles )
+
+
+!c-----------------------------------------------------------------------
+!c   dynamial tendencies :
+!c   ---------------------
+
+      INTEGER l,ierr,aslun
+
+      REAL longitude,latitude
+      REAL paire 
+
+      DATA latitude,longitude/48.,0./
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! INITIALISATIONS
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!-----------------------------------------------------------------------
+!    Initialisations  des constantes
+!    -------------------------------
+
+
+      type_aqua=iflag_phys/100
+      type_profil=iflag_phys-type_aqua*100
+      print*,'iniaqua:type_aqua, type_profil',type_aqua, type_profil
+
+      if (klon.ne.nlon) then
+        write(*,*)"iniaqua: klon=",klon," nlon=",nlon
+        stop'probleme de dimensions dans iniaqua'
+      endif
+      call phys_state_var_init(read_climoz)
+
+
+      read_climoz=0
+      day0=217.
+      day=day0
+      it=0
+      time=0.
+
+!IM ajout latfi, lonfi
+      rlatd=latfi
+      rlond=lonfi
+      rlat=rlatd*180./pi
+      rlon=rlond*180./pi
+
+!-----------------------------------------------------------------------
+!  initialisations de la physique
+!-----------------------------------------------------------------------
+
+         day_ini=dayref
+         day_end=day_ini+nday
+         airefi=1.
+         zcufi=1.
+         zcvfi=1.
+!$OMP MASTER
+      nbapp_rad_omp=24
+      CALL getin('nbapp_rad',nbapp_rad_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+      nbapp_rad=nbapp_rad_omp
+
+!---------------------------------------------------------------------
+!c Creation des conditions aux limites:
+!c ------------------------------------
+! Initialisations des constantes
+! Ajouter les manquants dans planete.def... (albedo etc)
+!$OMP MASTER
+      co2_ppm_omp=348.
+      CALL getin('co2_ppm',co2_ppm_omp)
+      solaire_omp=1365.
+      CALL getin('solaire',solaire_omp)
+!      CALL getin('albedo',albedo) ! albedo is set below, depending on type_aqua
+      alb_ocean_omp=.true.
+      CALL getin('alb_ocean',alb_ocean_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+      co2_ppm=co2_ppm_omp
+      solaire=solaire_omp
+      alb_ocean=alb_ocean_omp
+
+      radsol=0.
+      qsol_f=10.
+
+!c  Conditions aux limites:
+!c  -----------------------
+
+      qsol(:)    = qsol_f
+      rugsrel = 0.0    ! (rugsrel = rugoro)
+      rugoro = 0.0
+      u_ancien = 0.0
+      v_ancien = 0.0
+      agesno  = 50.0
+! Relief plat
+      zmea = 0.
+      zstd = 0.
+      zsig = 0.
+      zgam = 0.
+      zthe = 0.
+      zpic = 0.
+      zval = 0.
+
+! Une seule surface
+      pctsrf=0.
+      if (type_aqua==1) then
+         rugos=1.e-4
+         albedo=0.19
+         pctsrf(:,is_oce)=1.
+      else if (type_aqua==2) then
+         rugos=0.03
+         albedo=0.1
+         pctsrf(:,is_ter)=1.
+      endif
+
+!$OMP MASTER
+      rugos_omp=rugos
+      CALL getin('rugos',rugos_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+      rugos=rugos_omp
+      zmasq(:)=pctsrf(:,is_oce)
+
+! pctsrf_pot(:,is_oce) = 1. - zmasq(:)
+! pctsrf_pot(:,is_sic) = 1. - zmasq(:)
+
+! Si alb_ocean on calcule un albedo oceanique moyen
+!  if (alb_ocean) then
+! Voir pourquoi on avait ca.
+!          CALL ini_alb_oce(phy_alb)
+!      else 
+      phy_alb(:,:) = albedo ! albedo land only (old value condsurf_jyg=0.3)
+!      endif !alb_ocean
+      
+      do i=1,360
+!IM Terraplanete   phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2
+!IM ajout calcul profil sst selon le cas considere (cf. FBr)
+
+      phy_nat(:,i) = 1.0    ! 0=ocean libre, 1=land, 2=glacier, 3=banquise
+      phy_bil(:,i) = 1.0    ! ne sert que pour les slab_ocean
+      phy_rug(:,i) = rugos  ! longueur rugosite utilisee sur land only 
+      phy_ice(:,i) = 0.0    ! fraction de glace (?)
+      phy_fter(:,i) = pctsrf(:,is_ter)  ! fraction de glace (?)
+      phy_foce(:,i) = pctsrf(:,is_oce)  ! fraction de glace (?)
+      phy_fsic(:,i) = pctsrf(:,is_sic)  ! fraction de glace (?)
+      phy_flic(:,i) = pctsrf(:,is_lic)  ! fraction de glace (?)
+      enddo
+!IM calcul profil sst
+      call profil_sst(nlon, rlatd, type_profil, phy_sst)
+
+      call writelim                                                                  &
+       &   (klon,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,                    &
+       &    phy_fter,phy_foce,phy_flic,phy_fsic)
+
+
+!---------------------------------------------------------------------
+!c Ecriture de l'etat initial:
+!c ---------------------------
+
+!C
+!C Ecriture etat initial physique
+!C
+      timestep   = dtvr * FLOAT(iphysiq)
+      radpas    = NINT (daysec/timestep/ FLOAT(nbapp_rad) )
+
+      DO i = 1, longcles
+       clesphy0(i) = 0.
+      ENDDO
+      clesphy0(1) = FLOAT( iflag_con )
+      clesphy0(2) = FLOAT( nbapp_rad )
+!c     IF( cycle_diurne  ) clesphy0(3) =  1. 
+      clesphy0(3)=1. ! cycle_diurne
+      clesphy0(4)=1. ! soil_model
+      clesphy0(5)=1. ! new_oliq
+      clesphy0(6)=0. ! ok_orodr
+      clesphy0(7)=0. ! ok_orolf
+      clesphy0(8)=0. ! ok_limitvrai
+
+
+!c=======================================================================
+!c  Profils initiaux
+!c=======================================================================
+
+! On initialise les temperatures de surfaces comme les sst
+      do i=1,nlon
+         ftsol(i,:)=phy_sst(i,1)
+         tsoil(i,:,:)=phy_sst(i,1)
+         tslab(i)=phy_sst(i,1)
+      enddo
+
+      falbe(:,:)=albedo
+      falblw(:,:)=albedo
+      rain_fall(:)=0.
+      snow_fall(:)=0.
+      solsw(:)=0.
+      sollw(:)=0.
+      radsol(:)=0.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  intialisation bidon mais pas grave
+      t_ancien(:,:)=0.
+      q_ancien(:,:)=0.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      rnebcon=0.
+      ratqs=0.
+      clwcon=0.
+      pbl_tke=1.e-8
+
+! variables supplementaires pour appel a plb_surface_init
+      fder(:)=0.
+      seaice(:)=0.
+      run_off_lic_0=0.
+      evap=0.
+
+
+! Initialisations necessaires avant phyredem
+      type_ocean = "force"
+      call fonte_neige_init(run_off_lic_0)
+      qsolsrf(:,:)=qsol(1) ! humidite du sol des sous surface
+      snsrf(:,:)=0.        ! couverture de neige des sous surface
+      frugs(:,:)=rugos        ! couverture de neige des sous surface
+
+
+      call pbl_surface_init(qsol, fder, snsrf, qsolsrf,                              &
+       &     evap, frugs, agesno, tsoil)
+
+        print*,'iniaqua: before phyredem'
+
+      falb1=albedo
+      falb2=albedo
+      zmax0=0.
+      f0=0.
+      ema_work1=0.
+      ema_work2=0.
+      wake_deltat=0.
+      wake_deltaq=0.
+      wake_s=0.
+      wake_cstar=0.
+      wake_pe=0.
+      wake_fip=0.
+      fm_therm=0.
+      entr_therm=0.
+      detr_therm=0.
+
+
+      CALL phyredem ("startphy.nc")
+
+        print*,'iniaqua: after phyredem'
+      call phys_state_var_end
+
+      return
+
+      end SUBROUTINE iniaqua
+
+!c====================================================================
+!c====================================================================
+      SUBROUTINE zenang_an(cycle_diurne,gmtime,rlat,rlon,rmu0,fract)
+      USE dimphy
+      IMPLICIT none
+!c====================================================================
+!c=============================================================
+!c         CALL zenang(cycle_diurne,gmtime,rlat,rlon,rmu0,fract)
+!c Auteur : A. Campoy et F. Hourdin
+!c Objet  : calculer les valeurs moyennes du cos de l'angle zenithal
+!c          et l'ensoleillement moyen entre gmtime1 et gmtime2 
+!c          connaissant la declinaison, la latitude et la longitude.
+!c 
+!c   Dans cette version particuliere, on calcule le rayonnement
+!c  moyen sur l'annÃ©e Ã  chaque latitude.
+!c   angle zenithal calculÃ© pour obtenir un 
+!c   Fit polynomial de  l'ensoleillement moyen au sommet de l'atmosphere
+!c   en moyenne annuelle.
+!c   SpÃ©cifique de la terre. UtilisÃ© pour les aqua planetes.
+!c
+!c Rque   : Different de la routine angle en ce sens que zenang 
+!c          fournit des moyennes de pmu0 et non des valeurs 
+!c          instantanees, du coup frac prend toutes les valeurs 
+!c          entre 0 et 1.
+!c Date   : premiere version le 13 decembre 1994
+!c          revu pour  GCM  le 30 septembre 1996
+!c===============================================================
+!c longi----INPUT : la longitude vraie de la terre dans son plan
+!c                  solaire a partir de l'equinoxe de printemps (degre)
+!c gmtime---INPUT : temps universel en fraction de jour
+!c pdtrad---INPUT : pas de temps du rayonnement (secondes)
+!c lat------INPUT : latitude en degres
+!c long-----INPUT : longitude en degres
+!c pmu0-----OUTPUT: angle zenithal moyen entre gmtime et gmtime+pdtrad
+!c frac-----OUTPUT: ensoleillement moyen entre gmtime et gmtime+pdtrad
+!c================================================================
+#include "YOMCST.h"
+!c================================================================
+      logical cycle_diurne
+      real  gmtime
+      real rlat(klon), rlon(klon), rmu0(klon), fract(klon)
+!c================================================================
+      integer i
+      real gmtime1, gmtime2
+      real pi_local
+
+
+      real rmu0m(klon),rmu0a(klon)
+!c
+
+      pi_local = 4.0 * ATAN(1.0)
+
+!c================================================================
+!c  Calcul de l'angle zenithal moyen sur la journee
+!c================================================================
+
+      DO i=1,klon
+        fract(i)=1. 
+!  Calcule du flux moyen
+        IF (abs(rlat(i)).LE.28.75) THEN
+           rmu0m(i)=(210.1924+206.6059*cos(0.0174533*rlat(i))**2)/1365.
+        ELSEIF (abs(rlat(i)).LE.43.75) THEN
+          rmu0m(i)=(187.4562+236.1853*cos(0.0174533*rlat(i))**2)/1365.
+        ELSEIF (abs(rlat(i)).LE.71.25) THEN
+          rmu0m(i)=(162.4439+284.1192*cos(0.0174533*rlat(i))**2)/1365.
+        ELSE
+          rmu0m(i)=(172.8125+183.7673*cos(0.0174533*rlat(i))**2)/1365.
+        ENDIF
+      ENDDO
+
+!c================================================================
+!  Avec ou sans cycle diurne
+!c================================================================
+
+      IF (cycle_diurne) THEN
+
+!  On redecompose flux  au sommet suivant un cycle diurne idealise
+!  identique a toutes les latitudes.
+
+         DO i=1,klon
+           rmu0a(i)=2.*rmu0m(i)*sqrt(2.)*pi_local/(4.-pi_local)
+           rmu0(i)=rmu0a(i)*abs(sin(pi_local*gmtime+pi_local*                        &
+       &      rlon(i)/360.))-rmu0a(i)/sqrt(2.)
+         ENDDO
+
+         DO i=1,klon
+           IF (rmu0(i).LE.0.) THEN
+              rmu0(i)=0.
+              fract(i)=0.
+           ELSE
+              fract(i)=1.
+           ENDIF
+         ENDDO
+
+!  Affichage de l'angel zenitale
+!     print*,'************************************'
+!     print*,'************************************'
+!     print*,'************************************'
+!     print*,'latitude=',rlat(i),'longitude=',rlon(i)
+!     print*,'rmu0m=',rmu0m(i)
+!     print*,'rmu0a=',rmu0a(i)
+!     print*,'rmu0=',rmu0(i)
+                                                               
+      ELSE
+
+        DO i=1,klon
+           fract(i)=0.5
+           rmu0(i)=rmu0m(i)*2.
+        ENDDO
+
+      ENDIF
+
+      RETURN
+      END SUBROUTINE zenang_an
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      subroutine writelim                                                            &
+       &   (klon,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,                    &
+       &    phy_fter,phy_foce,phy_flic,phy_fsic)
+!c
+      use mod_phys_lmdz_para, only: is_mpi_root,is_omp_root
+      use mod_grid_phy_lmdz, only : klon_glo
+      use mod_phys_lmdz_transfert_para, only : gather
+
+!L. Fita July 2013 
+      use netcdf
+!#include "dimensions.h"
+!#include "dimphy.h"
+ 
+      integer,intent(in) :: klon
+      real,intent(in) :: phy_nat(klon,360)
+      real,intent(in) :: phy_alb(klon,360)
+      real,intent(in) :: phy_sst(klon,360)
+      real,intent(in) :: phy_bil(klon,360)
+      real,intent(in) :: phy_rug(klon,360)
+      real,intent(in) :: phy_ice(klon,360)
+      real,intent(in) :: phy_fter(klon,360)
+      real,intent(in) :: phy_foce(klon,360)
+      real,intent(in) :: phy_flic(klon,360)
+      real,intent(in) :: phy_fsic(klon,360)
+
+      real :: phy_glo(klon_glo,360) ! temporary variable, to store phy_***(:)
+                                    ! on the whole physics grid 
+      INTEGER ierr
+      INTEGER dimfirst(3)
+      INTEGER dimlast(3)
+!c
+      INTEGER nid, ndim, ntim
+      INTEGER dims(2), debut(2), epais(2)
+      INTEGER id_tim
+      INTEGER id_NAT, id_SST, id_BILS, id_RUG, id_ALB
+      INTEGER id_FTER,id_FOCE,id_FSIC,id_FLIC
+ 
+      if (is_mpi_root.and.is_omp_root) then
+      
+        PRINT*, 'writelim: Ecriture du fichier limit'
+!c
+        ierr = NF_CREATE ("limit.nc", NF_CLOBBER, nid)
+!c
+        ierr = NF_PUT_ATT_TEXT (nid, NF_GLOBAL, "title", 30,                         &
+       &                       "Fichier conditions aux limites")
+!!        ierr = NF_DEF_DIM (nid, "points_physiques", klon, ndim)
+        ierr = NF_DEF_DIM (nid, "points_physiques", klon_glo, ndim)
+        ierr = NF_DEF_DIM (nid, "time", NF_UNLIMITED, ntim)
+!c
+        dims(1) = ndim
+        dims(2) = ntim
+!c
+!ccc      ierr = NF_DEF_VAR (nid, "TEMPS", NF_DOUBLE, 1,ntim, id_tim)
+        ierr = NF_DEF_VAR (nid, "TEMPS", NF_FLOAT, 1,ntim, id_tim)
+        ierr = NF_PUT_ATT_TEXT (nid, id_tim, "title", 17,                            &
+       &                        "Jour dans l annee")
+!ccc      ierr = NF_DEF_VAR (nid, "NAT", NF_DOUBLE, 2,dims, id_NAT)
+        ierr = NF_DEF_VAR (nid, "NAT", NF_FLOAT, 2,dims, id_NAT)
+        ierr = NF_PUT_ATT_TEXT (nid, id_NAT, "title", 23,                            &
+       &                        "Nature du sol (0,1,2,3)")
+!ccc      ierr = NF_DEF_VAR (nid, "SST", NF_DOUBLE, 2,dims, id_SST)
+        ierr = NF_DEF_VAR (nid, "SST", NF_FLOAT, 2,dims, id_SST)
+        ierr = NF_PUT_ATT_TEXT (nid, id_SST, "title", 35,                            &
+       &                        "Temperature superficielle de la mer")
+!ccc      ierr = NF_DEF_VAR (nid, "BILS", NF_DOUBLE, 2,dims, id_BILS)
+        ierr = NF_DEF_VAR (nid, "BILS", NF_FLOAT, 2,dims, id_BILS)
+        ierr = NF_PUT_ATT_TEXT (nid, id_BILS, "title", 32,                           &
+       &                        "Reference flux de chaleur au sol")
+!ccc      ierr = NF_DEF_VAR (nid, "ALB", NF_DOUBLE, 2,dims, id_ALB)
+        ierr = NF_DEF_VAR (nid, "ALB", NF_FLOAT, 2,dims, id_ALB)
+        ierr = NF_PUT_ATT_TEXT (nid, id_ALB, "title", 19,                            &
+       &                        "Albedo a la surface")
+!ccc      ierr = NF_DEF_VAR (nid, "RUG", NF_DOUBLE, 2,dims, id_RUG)
+        ierr = NF_DEF_VAR (nid, "RUG", NF_FLOAT, 2,dims, id_RUG)
+        ierr = NF_PUT_ATT_TEXT (nid, id_RUG, "title", 8,                             &
+       &                        "Rugosite")
+
+        ierr = NF_DEF_VAR (nid, "FTER", NF_FLOAT, 2,dims, id_FTER)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FTER, "title", 8,"Frac. Terre")
+        ierr = NF_DEF_VAR (nid, "FOCE", NF_FLOAT, 2,dims, id_FOCE)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FOCE, "title", 8,"Frac. Terre")
+        ierr = NF_DEF_VAR (nid, "FSIC", NF_FLOAT, 2,dims, id_FSIC)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FSIC, "title", 8,"Frac. Terre")
+        ierr = NF_DEF_VAR (nid, "FLIC", NF_FLOAT, 2,dims, id_FLIC)
+        ierr = NF_PUT_ATT_TEXT (nid, id_FLIC, "title", 8,"Frac. Terre")
+!c
+        ierr = NF_ENDDEF(nid)
+!c
+
+! write the 'times'
+        do k=1,360
+#ifdef NC_DOUBLE
+          ierr = NF_PUT_VAR1_DOUBLE (nid,id_tim,k,DBLE(k))
+#else
+          ierr = NF_PUT_VAR1_REAL (nid,id_tim,k,FLOAT(k))
+#endif
+        enddo
+
+      endif ! of if (is_mpi_root.and.is_omp_root)
+
+! write the fields, after having collected them on master
+
+      call gather(phy_nat,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_NAT,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_NAT,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_nat"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_sst,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_SST,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_SST,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_sst"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_bil,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_BILS,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_BILS,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_bil"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_alb,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_ALB,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_ALB,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_alb"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_rug,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_RUG,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_RUG,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_rug"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_fter,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_FTER,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_FTER,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_fter"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_foce,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_FOCE,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_FOCE,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_foce"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_fsic,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_FSIC,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_FSIC,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_fsic"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+      call gather(phy_flic,phy_glo)
+      if (is_mpi_root.and.is_omp_root) then
+#ifdef NC_DOUBLE
+        ierr=NF_PUT_VAR_DOUBLE(nid,id_FLIC,phy_glo)
+#else
+        ierr=NF_PUT_VAR_REAL(nid,id_FLIC,phy_glo)
+#endif
+        if(ierr.ne.NF_NOERR) then
+          write(*,*) "writelim error with phy_flic"
+          write(*,*) NF_STRERROR(ierr)
+        endif
+      endif
+
+!  close file:
+      if (is_mpi_root.and.is_omp_root) then
+        ierr = NF_CLOSE(nid)
+      endif
+
+      end SUBROUTINE writelim
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      SUBROUTINE profil_sst(nlon, rlatd, type_profil, phy_sst)
+      use dimphy
+      IMPLICIT none
+!c
+      INTEGER nlon, type_profil, i, k, j
+      REAL :: rlatd(nlon), phy_sst(nlon, 360) 
+      INTEGER imn, imx, amn, amx, kmn, kmx
+      INTEGER p, pplus, nlat_max
+      parameter (nlat_max=72)
+      REAL x_anom_sst(nlat_max)
+!c
+      if (klon.ne.nlon) stop'probleme de dimensions dans iniaqua'
+      do i=1,360
+!c      phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2
+
+!c Rajout fbrlmd
+
+      if(type_profil.EQ.1)then
+!c     MÃ©thode 1 "Control" faible plateau Ã  l'Equateur
+      do j=1,klon
+       phy_sst(j,i)=273.+27.*(1-sin(1.5*rlatd(j))**2)
+!c        PI/3=1.047197551
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+      if(type_profil.EQ.2)then
+!c     MÃ©thode 2 "Flat" fort plateau Ã  l'Equateur
+      do j=1,klon
+       phy_sst(j,i)=273.+27.*(1-sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+
+      if (type_profil.EQ.3) then
+!c     MÃ©thode 3 "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+0.5*27.*(2-sin(1.5*rlatd(j))**2                            &
+       &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.4) then
+!c     MÃ©thode 4 : MÃ©thode 3 + SST+2 "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+0.5*29.*(2-sin(1.5*rlatd(j))**2                            &
+       &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.5) then
+!c     MÃ©thode 5 : MÃ©thode 3 + +2K "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+2.+0.5*27.*(2-sin(1.5*rlatd(j))**2                         &
+       &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.+2.
+        endif
+
+      enddo
+      endif
+
+      if(type_profil.EQ.6)then
+!c     MÃ©thode 6 "cst" valeur constante de SST
+      do j=1,klon
+       phy_sst(j,i)=288.
+      enddo
+      endif
+
+
+        if(type_profil.EQ.7)then
+!c     MÃ©thode 7 "cst" valeur constante de SST +2
+      do j=1,klon
+       phy_sst(j,i)=288.+2.
+      enddo
+      endif
+
+        p=0
+        if(type_profil.EQ.8)then
+!c     MÃ©thode 8 profil anomalies SST du modÃšle couplÃ© AR4
+       do j=1,klon
+         if (rlatd(j).EQ.rlatd(j-1)) then
+       phy_sst(j,i)=273.+x_anom_sst(pplus)                                           &
+       &     +0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5*rlatd(j))**4)
+          if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+            phy_sst(j,i)=273.+x_anom_sst(pplus)
+          endif
+        else
+          p=p+1
+          pplus=73-p
+        phy_sst(j,i)=273.+x_anom_sst(pplus)                                          &
+       &     +0.5*27.*(2-sin(1.5*rlatd(j))**2-sin(1.5*rlatd(j))**4)
+          if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+            phy_sst(j,i)=273.+x_anom_sst(pplus)
+          endif
+          write (*,*) rlatd(j),x_anom_sst(pplus),phy_sst(j,i)
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.9) then
+!c     MÃ©thode 5 : MÃ©thode 3 + -2K "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.-2.+0.5*27.*(2-sin(1.5*rlatd(j))**2                         &
+       &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.-2.
+        endif
+      enddo
+      endif
+
+
+      if (type_profil.EQ.10) then
+!c     MÃ©thode 10 : MÃ©thode 3 + +4K "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+4.+0.5*27.*(2-sin(1.5*rlatd(j))**2                         &
+       &                 -sin(1.5*rlatd(j))**4)
+        if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.+4.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.11) then
+!c     MÃ©thode 11 : MÃ©thode 3 + 4CO2 "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+0.5*27.*(2-sin(1.5*rlatd(j))**2                            &
+       &                 -sin(1.5*rlatd(j))**4)
+        if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.12) then
+!c     MÃ©thode 12 : MÃ©thode 10 + 4CO2 "Qobs" plateau rÃ©el Ã  l'Equateur
+      do j=1,klon
+        phy_sst(j,i)=273.+4.+0.5*27.*(2-sin(1.5*rlatd(j))**2                         &
+       &                 -sin(1.5*rlatd(j))**4)
+        if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.+4.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.13) then
+!c     MÃ©thode 13 "Qmax" plateau rÃ©el Ã  l'Equateur augmentÃ© !
+      do j=1,klon
+        phy_sst(j,i)=273.+0.5*29.*(2-sin(1.5*rlatd(j))**2                            &
+       &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      if (type_profil.EQ.14) then
+!c     MÃ©thode 13 "Qmax2K" plateau rÃ©el Ã  l'Equateur augmentÃ© +2K !
+      do j=1,klon
+        phy_sst(j,i)=273.+2.+0.5*29.*(2-sin(1.5*rlatd(j))**2                         &
+       &                 -sin(1.5*rlatd(j))**4)
+      if((rlatd(j).GT.1.0471975).OR.(rlatd(j).LT.-1.0471975))then
+         phy_sst(j,i)=273.
+        endif
+      enddo
+      endif
+
+      enddo
+
+!IM beg : verif profil SST: phy_sst
+       amn=MIN(phy_sst(1,1),1000.)
+       amx=MAX(phy_sst(1,1),-1000.)
+       DO k=1, 360
+       DO i=2, nlon
+        IF(phy_sst(i,k).LT.amn) THEN
+         amn=phy_sst(i,k)
+         imn=i
+         kmn=k
+        ENDIF
+        IF(phy_sst(i,k).GT.amx) THEN
+         amx=phy_sst(i,k)
+         imx=i
+         kmx=k
+        ENDIF
+       ENDDO
+       ENDDO
+!c
+       PRINT*,' debut avant writelim min max phy_sst',imn,kmn,amn,                   &
+       & imx,kmx,amx
+!IM end : verif profil SST: phy_sst
+
+       return 
+       end SUBROUTINE profil_sst
+
+END MODULE phyaqua_mod
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phyetat0.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phyetat0.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phyetat0.F	(revision 17)
@@ -0,0 +1,1105 @@
+!
+! $Id: phyetat0.F 1795 2013-07-18 08:20:28Z emillour $
+!
+c
+c
+      SUBROUTINE phyetat0 (fichnom,
+     .           clesphy0,
+     .           tabcntr0)
+
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE iophy
+      USE ocean_cpl_mod,    ONLY : ocean_cpl_init
+      USE fonte_neige_mod,  ONLY : fonte_neige_init
+      USE pbl_surface_mod,  ONLY : pbl_surface_init
+      USE surface_data,     ONLY : type_ocean
+      USE phys_state_var_mod
+      USE iostart
+      USE write_field_phy
+      USE infotrac
+      USE traclmdz_mod,    ONLY : traclmdz_from_restart
+      USE carbon_cycle_mod,ONLY :
+     &     carbon_cycle_tr, carbon_cycle_cpl, co2_send
+      USE indice_sol_mod
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Lecture de l'etat initial pour la physique
+c======================================================================
+#include "dimensions.h"
+#include "netcdf.inc"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "temps.h"
+#include "thermcell.h"
+#include "compbl.h"
+c======================================================================
+      CHARACTER*(*) fichnom
+
+c les variables globales lues dans le fichier restart
+
+      REAL tsoil(klon,nsoilmx,nbsrf)
+      REAL tslab(klon), seaice(klon)
+      REAL qsurf(klon,nbsrf)
+      REAL qsol(klon)
+      REAL snow(klon,nbsrf)
+      REAL evap(klon,nbsrf)
+      real fder(klon)
+      REAL frugs(klon,nbsrf)
+      REAL agesno(klon,nbsrf)
+      REAL run_off_lic_0(klon)
+      REAL fractint(klon)
+      REAL trs(klon,nbtr)
+
+      CHARACTER*6 ocean_in
+      LOGICAL ok_veget_in
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles )
+c
+      REAL xmin, xmax
+c
+      INTEGER nid, nvarid
+      INTEGER ierr, i, nsrf, isoil ,k
+      INTEGER length
+      PARAMETER (length=100)
+      INTEGER it, iiq
+      REAL tab_cntrl(length), tabcntr0(length)
+      CHARACTER*7 str7
+      CHARACTER*2 str2
+      LOGICAL :: found
+
+c FH1D
+c     real iolat(jjm+1)
+      real iolat(jjm+1-1/(iim*jjm))
+c
+c Ouvrir le fichier contenant l'etat initial:
+c
+
+     
+      CALL open_startphy(fichnom)
+      
+
+c
+c Lecture des parametres de controle:
+c
+      CALL get_var("controle",tab_cntrl)
+       
+c
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! Les constantes de la physiques sont lues dans la physique seulement.
+! Les egalites du type
+!             tab_cntrl( 5 )=clesphy0(1)
+! sont remplacees par
+!             clesphy0(1)=tab_cntrl( 5 )
+! On inverse aussi la logique.
+! On remplit les tab_cntrl avec les parametres lus dans les .def
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+         DO i = 1, length
+           tabcntr0( i ) = tab_cntrl( i )
+         ENDDO
+c
+         tab_cntrl(1)=dtime
+         tab_cntrl(2)=radpas
+
+c co2_ppm : value from the previous time step
+         IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN
+            co2_ppm = tab_cntrl(3)
+            RCO2    = co2_ppm * 1.0e-06  * 44.011/28.97 
+c ELSE : keep value from .def
+         END IF
+
+c co2_ppm0 : initial value of atmospheric CO2 (from create_etat0_limit.e .def)
+         co2_ppm0   = tab_cntrl(16)
+
+         solaire_etat0      = tab_cntrl(4)
+         tab_cntrl(5)=iflag_con
+         tab_cntrl(6)=nbapp_rad
+
+         if (cycle_diurne) tab_cntrl( 7) =1.
+         if (soil_model) tab_cntrl( 8) =1.
+         if (new_oliq) tab_cntrl( 9) =1.
+         if (ok_orodr) tab_cntrl(10) =1.
+         if (ok_orolf) tab_cntrl(11) =1.
+         if (ok_limitvrai) tab_cntrl(12) =1.
+
+
+      itau_phy = tab_cntrl(15)
+
+       
+      clesphy0(1)=tab_cntrl( 5 )
+      clesphy0(2)=tab_cntrl( 6 )
+      clesphy0(3)=tab_cntrl( 7 )
+      clesphy0(4)=tab_cntrl( 8 )
+      clesphy0(5)=tab_cntrl( 9 )
+      clesphy0(6)=tab_cntrl( 10 )
+      clesphy0(7)=tab_cntrl( 11 )
+      clesphy0(8)=tab_cntrl( 12 )
+
+c
+c Lecture des latitudes (coordonnees):
+c
+      CALL get_field("latitude",rlat)
+
+c
+c Lecture des longitudes (coordonnees):
+c
+      CALL get_field("longitude",rlon)
+
+C
+C
+C Lecture du masque terre mer
+C
+      CALL get_field("masque",zmasq,found)
+      IF (.NOT. found) THEN
+        PRINT*, 'phyetat0: Le champ <masque> est absent'
+        PRINT *, 'fichier startphy non compatible avec phyetat0'
+      ENDIF
+
+       
+C Lecture des fractions pour chaque sous-surface
+C
+C initialisation des sous-surfaces
+C
+      pctsrf = 0.
+C
+C fraction de terre
+C
+
+      CALL get_field("FTER",pctsrf(:,is_ter),found)
+      IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FTER> est absent'
+
+C
+C fraction de glace de terre
+C
+      CALL get_field("FLIC",pctsrf(:,is_lic),found)
+      IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FLIC> est absent'
+
+C
+C fraction d'ocean
+C
+      CALL get_field("FOCE",pctsrf(:,is_oce),found)
+      IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FOCE> est absent'
+
+C
+C fraction glace de mer
+C
+      CALL get_field("FSIC",pctsrf(:,is_sic),found)
+      IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FSIC> est absent'
+
+C
+C  Verification de l'adequation entre le masque et les sous-surfaces
+C
+      fractint( 1 : klon) = pctsrf(1 : klon, is_ter) 
+     $    + pctsrf(1 : klon, is_lic)
+      DO i = 1 , klon
+        IF ( abs(fractint(i) - zmasq(i) ) .GT. EPSFRA ) THEN
+            WRITE(*,*) 'phyetat0: attention fraction terre pas ', 
+     $          'coherente ', i, zmasq(i), pctsrf(i, is_ter)
+     $          ,pctsrf(i, is_lic)
+            WRITE(*,*) 'Je force la coherence zmasq=fractint'
+            zmasq(i) = fractint(i)
+        ENDIF 
+      END DO 
+      fractint (1 : klon) =  pctsrf(1 : klon, is_oce) 
+     $    + pctsrf(1 : klon, is_sic)
+      DO i = 1 , klon
+        IF ( abs( fractint(i) - (1. - zmasq(i))) .GT. EPSFRA ) THEN
+            WRITE(*,*) 'phyetat0 attention fraction ocean pas ', 
+     $          'coherente ', i, zmasq(i) , pctsrf(i, is_oce)
+     $          ,pctsrf(i, is_sic)
+            WRITE(*,*) 'Je force la coherence zmasq=fractint'
+            zmasq(i) = fractint(i)
+        ENDIF 
+      END DO 
+
+C
+c Lecture des temperatures du sol:
+c
+
+       CALL get_field("TS",ftsol(:,1),found)
+       IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <TS> est absent'
+         PRINT*, '          Mais je vais essayer de lire TS**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           CALL get_field("TS"//str2,ftsol(:,nsrf))
+
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(ftsol(i,nsrf),xmin)
+              xmax = MAX(ftsol(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Temperature du sol TS**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <TS> est present'
+         PRINT*, '          J ignore donc les autres temperatures TS**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(ftsol(i,1),xmin)
+            xmax = MAX(ftsol(i,1),xmax)
+         ENDDO
+         PRINT*,'Temperature du sol <TS>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            ftsol(i,nsrf) = ftsol(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+c Lecture des temperatures du sol profond:
+c
+      DO nsrf = 1, nbsrf
+        DO isoil=1, nsoilmx
+          IF (isoil.GT.99 .AND. nsrf.GT.99) THEN
+            PRINT*, "Trop de couches ou sous-mailles"
+            CALL abort
+          ENDIF
+          WRITE(str7,'(i2.2,"srf",i2.2)') isoil, nsrf
+          
+          CALL get_field('Tsoil'//str7,tsoil(:,isoil,nsrf),found)
+          IF (.NOT. found) THEN
+            PRINT*, "phyetat0: Le champ <Tsoil"//str7//"> est absent"
+            PRINT*, "          Il prend donc la valeur de surface"
+            DO i=1, klon
+               tsoil(i,isoil,nsrf)=ftsol(i,nsrf)
+            ENDDO
+          ENDIF
+        ENDDO
+      ENDDO
+c
+c Lecture de l'humidite de l'air juste au dessus du sol:
+c
+
+      CALL get_field("QS",qsurf(:,1),found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <QS> est absent'
+         PRINT*, '          Mais je vais essayer de lire QS**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           CALL get_field("QS"//str2,qsurf(:,nsrf))
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(qsurf(i,nsrf),xmin)
+              xmax = MAX(qsurf(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Humidite pres du sol QS**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <QS> est present'
+         PRINT*, '          J ignore donc les autres humidites QS**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(qsurf(i,1),xmin)
+            xmax = MAX(qsurf(i,1),xmax)
+         ENDDO
+         PRINT*,'Humidite pres du sol <QS>', xmin, xmax
+         DO nsrf = 2, nbsrf
+           DO i = 1, klon
+             qsurf(i,nsrf) = qsurf(i,1)
+           ENDDO
+         ENDDO
+      ENDIF
+
+C
+C Eau dans le sol (pour le modele de sol "bucket")
+C
+      CALL get_field("QSOL",qsol,found)
+      IF (.NOT. found) THEN
+        PRINT*, 'phyetat0: Le champ <QSOL> est absent'
+        PRINT*, '          Valeur par defaut nulle'
+          qsol(:)=0.
+      ENDIF
+
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+        xmin = MIN(qsol(i),xmin)
+        xmax = MAX(qsol(i),xmax)
+      ENDDO
+      PRINT*,'Eau dans le sol (mm) <QSOL>', xmin, xmax
+
+c
+c Lecture de neige au sol:
+c
+
+      CALL get_field("SNOW",snow(:,1),found)
+      IF (.NOT. found) THEN
+        PRINT*, 'phyetat0: Le champ <SNOW> est absent'
+        PRINT*, '          Mais je vais essayer de lire SNOW**'
+        DO nsrf = 1, nbsrf
+          IF (nsrf.GT.99) THEN
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+          ENDIF
+          WRITE(str2,'(i2.2)') nsrf
+          CALL get_field( "SNOW"//str2,snow(:,nsrf))
+          xmin = 1.0E+20
+          xmax = -1.0E+20
+          DO i = 1, klon
+            xmin = MIN(snow(i,nsrf),xmin)
+            xmax = MAX(snow(i,nsrf),xmax)
+          ENDDO
+          PRINT*,'Neige du sol SNOW**:', nsrf, xmin, xmax
+        ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <SNOW> est present'
+         PRINT*, '          J ignore donc les autres neiges SNOW**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(snow(i,1),xmin)
+            xmax = MAX(snow(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <SNOW>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            snow(i,nsrf) = snow(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture de albedo de l'interval visible au sol:
+c
+      CALL get_field("ALBE",falb1(:,1),found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <ALBE> est absent'
+         PRINT*, '          Mais je vais essayer de lire ALBE**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           CALL get_field("ALBE"//str2,falb1(:,nsrf))
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(falb1(i,nsrf),xmin)
+              xmax = MAX(falb1(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Albedo du sol ALBE**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <ALBE> est present'
+         PRINT*, '          J ignore donc les autres ALBE**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(falb1(i,1),xmin)
+            xmax = MAX(falb1(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <ALBE>', xmin, xmax
+         DO nsrf = 2, nbsrf
+           DO i = 1, klon
+            falb1(i,nsrf) = falb1(i,1)
+           ENDDO
+         ENDDO
+      ENDIF
+
+c
+c Lecture de albedo au sol dans l'interval proche infra-rouge:
+c
+      CALL get_field("ALBLW",falb2(:,1),found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <ALBLW> est absent'
+         PRINT*, '          Mais je vais prendre ALBE**'
+         DO nsrf = 1, nbsrf
+           DO i = 1, klon
+             falb2(i,nsrf) = falb1(i,nsrf)
+           ENDDO
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <ALBLW> est present'
+         PRINT*, '          J ignore donc les autres ALBLW**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(falb2(i,1),xmin)
+            xmax = MAX(falb2(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <ALBLW>', xmin, xmax
+         DO nsrf = 2, nbsrf
+           DO i = 1, klon
+             falb2(i,nsrf) = falb2(i,1)
+           ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture de evaporation:  
+c
+      CALL get_field("EVAP",evap(:,1),found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <EVAP> est absent'
+         PRINT*, '          Mais je vais essayer de lire EVAP**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           CALL get_field("EVAP"//str2, evap(:,nsrf))
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(evap(i,nsrf),xmin)
+              xmax = MAX(evap(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'evap du sol EVAP**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <EVAP> est present'
+         PRINT*, '          J ignore donc les autres EVAP**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(evap(i,1),xmin)
+            xmax = MAX(evap(i,1),xmax)
+         ENDDO
+         PRINT*,'Evap du sol <EVAP>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            evap(i,nsrf) = evap(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+c
+c Lecture precipitation liquide:
+c
+      CALL get_field("rain_f",rain_fall)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(rain_fall(i),xmin)
+         xmax = MAX(rain_fall(i),xmax)
+      ENDDO
+      PRINT*,'Precipitation liquide rain_f:', xmin, xmax
+c
+c Lecture precipitation solide:
+c
+      CALL get_field("snow_f",snow_fall)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(snow_fall(i),xmin)
+         xmax = MAX(snow_fall(i),xmax)
+      ENDDO
+      PRINT*,'Precipitation solide snow_f:', xmin, xmax
+c
+c Lecture rayonnement solaire au sol:
+c
+      CALL get_field("solsw",solsw,found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <solsw> est absent'
+         PRINT*, 'mis a zero'
+         solsw(:) = 0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(solsw(i),xmin)
+         xmax = MAX(solsw(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement solaire au sol solsw:', xmin, xmax
+c
+c Lecture rayonnement IF au sol:
+c
+      CALL get_field("sollw",sollw,found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <sollw> est absent'
+         PRINT*, 'mis a zero'
+         sollw = 0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(sollw(i),xmin)
+         xmax = MAX(sollw(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement IF au sol sollw:', xmin, xmax
+      
+c
+c Lecture derive des flux:
+c
+      CALL get_field("fder",fder,found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <fder> est absent'
+         PRINT*, 'mis a zero'
+         fder = 0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(fder(i),xmin)
+         xmax = MAX(fder(i),xmax)
+      ENDDO
+      PRINT*,'Derive des flux fder:', xmin, xmax
+
+c
+c Lecture du rayonnement net au sol:
+c
+      CALL get_field("RADS",radsol)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(radsol(i),xmin)
+         xmax = MAX(radsol(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement net au sol radsol:', xmin, xmax
+c
+c Lecture de la longueur de rugosite 
+c
+c
+      CALL get_field("RUG",frugs(:,1),found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <RUG> est absent'
+         PRINT*, '          Mais je vais essayer de lire RUG**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           CALL get_field("RUG"//str2,frugs(:,nsrf))
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(frugs(i,nsrf),xmin)
+              xmax = MAX(frugs(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'rugosite du sol RUG**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <RUG> est present'
+         PRINT*, '          J ignore donc les autres RUG**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(frugs(i,1),xmin)
+            xmax = MAX(frugs(i,1),xmax)
+         ENDDO
+         PRINT*,'rugosite <RUG>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            frugs(i,nsrf) = frugs(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+c Lecture de l'age de la neige:
+c
+      CALL get_field("AGESNO",agesno(:,1),found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <AGESNO> est absent'
+         PRINT*, '          Mais je vais essayer de lire AGESNO**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+           CALL get_field("AGESNO"//str2,agesno(:,nsrf),found)
+           IF (.NOT. found) THEN
+              PRINT*, "phyetat0: Le champ <AGESNO"//str2//"> est absent"
+              agesno = 50.0
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(agesno(i,nsrf),xmin)
+              xmax = MAX(agesno(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Age de la neige AGESNO**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <AGESNO> est present'
+         PRINT*, '          J ignore donc les autres AGESNO**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(agesno(i,1),xmin)
+            xmax = MAX(agesno(i,1),xmax)
+         ENDDO
+         PRINT*,'Age de la neige <AGESNO>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            agesno(i,nsrf) = agesno(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+c
+      CALL get_field("ZMEA", zmea)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zmea(i),xmin)
+         xmax = MAX(zmea(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zmea:', xmin, xmax
+c
+c
+      CALL get_field("ZSTD",zstd)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zstd(i),xmin)
+         xmax = MAX(zstd(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zstd:', xmin, xmax
+c
+c
+      CALL get_field("ZSIG",zsig)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zsig(i),xmin)
+         xmax = MAX(zsig(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zsig:', xmin, xmax
+c
+c
+      CALL get_field("ZGAM",zgam)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zgam(i),xmin)
+         xmax = MAX(zgam(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zgam:', xmin, xmax
+c
+c
+      CALL get_field("ZTHE",zthe)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zthe(i),xmin)
+         xmax = MAX(zthe(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zthe:', xmin, xmax
+c
+c
+      CALL get_field("ZPIC",zpic)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zpic(i),xmin)
+         xmax = MAX(zpic(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zpic:', xmin, xmax
+c
+      CALL get_field("ZVAL",zval)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zval(i),xmin)
+         xmax = MAX(zval(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zval:', xmin, xmax
+c
+c
+      CALL get_field("RUGSREL",rugoro)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(rugoro(i),xmin)
+         xmax = MAX(rugoro(i),xmax)
+      ENDDO
+      PRINT*,'Rugosite relief (ecart-type) rugsrel:', xmin, xmax
+c
+c
+     
+c
+      ancien_ok = .TRUE.
+
+      CALL get_field("TANCIEN",t_ancien,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <TANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ENDIF
+
+
+      CALL get_field("QANCIEN",q_ancien,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <QANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ENDIF
+
+      CALL get_field("UANCIEN",u_ancien,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <UANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ENDIF
+
+      CALL get_field("VANCIEN",v_ancien,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <VANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ENDIF
+
+      clwcon=0.
+      CALL get_field("CLWCON",clwcon,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ CLWCON est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(clwcon)
+      xmax = MAXval(clwcon)
+      PRINT*,'Eau liquide convective (ecart-type) clwcon:', xmin, xmax
+c
+      rnebcon = 0.
+      CALL get_field("RNEBCON",rnebcon,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ RNEBCON est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(rnebcon)
+      xmax = MAXval(rnebcon)
+      PRINT*,'Nebulosite convective (ecart-type) rnebcon:', xmin, xmax
+
+c
+c Lecture ratqs
+c
+      ratqs=0.
+      CALL get_field("RATQS",ratqs,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <RATQS> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(ratqs)
+      xmax = MAXval(ratqs)
+      PRINT*,'(ecart-type) ratqs:', xmin, xmax
+c
+c Lecture run_off_lic_0
+c
+      CALL get_field("RUNOFFLIC0",run_off_lic_0,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <RUNOFFLIC0> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         run_off_lic_0 = 0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(run_off_lic_0)
+      xmax = MAXval(run_off_lic_0)
+      PRINT*,'(ecart-type) run_off_lic_0:', xmin, xmax
+
+
+c Lecture de l'energie cinetique turbulente
+c
+
+      IF (iflag_pbl>1) then
+        DO nsrf = 1, nbsrf
+          IF (nsrf.GT.99) THEN
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+          ENDIF
+          WRITE(str2,'(i2.2)') nsrf
+          CALL get_field("TKE"//str2,pbl_tke(:,1:klev+1,nsrf),found)
+          IF (.NOT. found) THEN
+            PRINT*, "phyetat0: <TKE"//str2//"> est absent"
+            pbl_tke(:,:,nsrf)=1.e-8
+          ENDIF
+          xmin = 1.0E+20
+          xmax = -1.0E+20
+          DO k = 1, klev+1
+            DO i = 1, klon
+              xmin = MIN(pbl_tke(i,k,nsrf),xmin)
+              xmax = MAX(pbl_tke(i,k,nsrf),xmax)
+            ENDDO
+          ENDDO
+          PRINT*,'Temperature du sol TKE**:', nsrf, xmin, xmax
+        ENDDO
+      ENDIF
+c
+c zmax0
+      CALL get_field("ZMAX0",zmax0,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <ZMAX0> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        zmax0=40.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(zmax0)
+      xmax = MAXval(zmax0)
+      PRINT*,'(ecart-type) zmax0:', xmin, xmax
+c
+c           f0(ig)=1.e-5
+c f0
+      CALL get_field("F0",f0,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <f0> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         f0=1.e-5
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(f0)
+      xmax = MAXval(f0)
+      PRINT*,'(ecart-type) f0:', xmin, xmax
+c
+c ema_work1
+c
+      CALL get_field("EMA_WORK1",ema_work1,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <EMA_WORK1> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        ema_work1=0.
+      ELSE
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO k = 1, klev
+          DO i = 1, klon
+            xmin = MIN(ema_work1(i,k),xmin)
+            xmax = MAX(ema_work1(i,k),xmax)
+          ENDDO
+        ENDDO
+        PRINT*,'ema_work1:', xmin, xmax
+      ENDIF
+c
+c ema_work2
+c
+      CALL get_field("EMA_WORK2",ema_work2,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <EMA_WORK2> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        ema_work2=0.
+      ELSE
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO k = 1, klev
+          DO i = 1, klon
+            xmin = MIN(ema_work2(i,k),xmin)
+            xmax = MAX(ema_work2(i,k),xmax)
+          ENDDO
+        ENDDO
+        PRINT*,'ema_work2:', xmin, xmax
+      ENDIF
+c
+c wake_deltat
+c
+      CALL get_field("WAKE_DELTAT",wake_deltat,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <WAKE_DELTAT> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        wake_deltat=0.
+      ELSE
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO k = 1, klev
+          DO i = 1, klon
+            xmin = MIN(wake_deltat(i,k),xmin)
+            xmax = MAX(wake_deltat(i,k),xmax)
+          ENDDO
+        ENDDO
+        PRINT*,'wake_deltat:', xmin, xmax
+      ENDIF
+c
+c wake_deltaq
+c   
+      CALL get_field("WAKE_DELTAQ",wake_deltaq,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <WAKE_DELTAQ> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        wake_deltaq=0.
+      ELSE
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO k = 1, klev
+          DO i = 1, klon
+            xmin = MIN(wake_deltaq(i,k),xmin)
+            xmax = MAX(wake_deltaq(i,k),xmax)
+          ENDDO
+        ENDDO
+        PRINT*,'wake_deltaq:', xmin, xmax
+      ENDIF
+c
+c wake_s
+c
+      CALL get_field("WAKE_S",wake_s,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <WAKE_S> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        wake_s=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_s)
+      xmax = MAXval(wake_s)
+      PRINT*,'(ecart-type) wake_s:', xmin, xmax
+c
+c wake_cstar
+c
+      CALL get_field("WAKE_CSTAR",wake_cstar,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <WAKE_CSTAR> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         wake_cstar=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_cstar)
+      xmax = MAXval(wake_cstar)
+      PRINT*,'(ecart-type) wake_cstar:', xmin, xmax
+c
+c wake_pe
+c
+      CALL get_field("WAKE_PE",wake_pe,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <WAKE_PE> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         wake_pe=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_pe)
+      xmax = MAXval(wake_pe)
+      PRINT*,'(ecart-type) wake_pe:', xmin, xmax
+c
+c wake_fip
+c
+      CALL get_field("WAKE_FIP",wake_fip,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <WAKE_FIP> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         wake_fip=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_fip)
+      xmax = MAXval(wake_fip)
+      PRINT*,'(ecart-type) wake_fip:', xmin, xmax
+c
+c  thermiques
+c
+
+      CALL get_field("FM_THERM",fm_therm,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <fm_therm> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         fm_therm=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(fm_therm)
+      xmax = MAXval(fm_therm)
+      PRINT*,'(ecart-type) fm_therm:', xmin, xmax
+
+      CALL get_field("ENTR_THERM",entr_therm,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <entr_therm> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         entr_therm=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(entr_therm)
+      xmax = MAXval(entr_therm)
+      PRINT*,'(ecart-type) entr_therm:', xmin, xmax
+
+      CALL get_field("DETR_THERM",detr_therm,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <detr_therm> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         detr_therm=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(detr_therm)
+      xmax = MAXval(detr_therm)
+      PRINT*,'(ecart-type) detr_therm:', xmin, xmax
+
+
+
+c
+c Read and send field trs to traclmdz
+c
+      IF (type_trac == 'lmdz') THEN
+         DO it=1,nbtr
+            iiq=niadv(it+2)
+            CALL get_field("trs_"//tname(iiq),trs(:,it),found)
+            IF (.NOT. found) THEN
+               PRINT*, 
+     $           "phyetat0: Le champ <trs_"//tname(iiq)//"> est absent"
+               PRINT*, "Depart legerement fausse. Mais je continue"
+               trs(:,it) = 0.
+            ENDIF
+            xmin = 1.0E+20
+            xmax = -1.0E+20
+            xmin = MINval(trs(:,it))
+            xmax = MAXval(trs(:,it))
+            PRINT*,"(ecart-type) trs_"//tname(iiq)//" :", xmin, xmax
+
+         END DO
+         CALL traclmdz_from_restart(trs)
+
+         IF (carbon_cycle_cpl) THEN
+            ALLOCATE(co2_send(klon), stat=ierr)
+            IF (ierr /= 0) CALL abort_gcm
+     &           ('phyetat0','pb allocation co2_send',1)
+            CALL get_field("co2_send",co2_send,found)
+            IF (.NOT. found) THEN
+               PRINT*,"phyetat0: Le champ <co2_send> est absent"
+               PRINT*,"Initialisation uniforme a co2_ppm=",co2_ppm
+               co2_send(:) = co2_ppm
+            END IF
+         END IF
+      END IF
+
+
+c on ferme le fichier
+      CALL close_startphy
+
+      CALL init_iophy_new(rlat,rlon)
+      	
+
+c
+c Initialize module pbl_surface_mod 
+c
+      CALL pbl_surface_init(qsol, fder, snow, qsurf,
+     $     evap, frugs, agesno, tsoil)
+
+c Initialize module ocean_cpl_mod for the case of coupled ocean
+      IF ( type_ocean == 'couple' ) THEN
+         CALL ocean_cpl_init(dtime, rlon, rlat)
+      ENDIF
+c
+c Initilialize module fonte_neige_mod      
+c
+      CALL fonte_neige_init(run_off_lic_0)
+
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phyetat0.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phyetat0.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phyetat0.F90	(revision 17)
@@ -0,0 +1,1196 @@
+!
+! $Id: phyetat0.F 1795 2013-07-18 08:20:28Z emillour $
+!
+!c
+!c
+      SUBROUTINE phyetat0 (fichnom,                                                  &
+       &           clesphy0,                                                         &
+       &           tabcntr0)
+
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE iophy
+      USE ocean_cpl_mod,    ONLY : ocean_cpl_init
+      USE fonte_neige_mod,  ONLY : fonte_neige_init
+      USE pbl_surface_mod,  ONLY : pbl_surface_init
+      USE surface_data,     ONLY : type_ocean
+      USE phys_state_var_mod
+      USE iostart
+      USE write_field_phy
+      USE infotrac
+      USE traclmdz_mod,    ONLY : traclmdz_from_restart
+      USE carbon_cycle_mod,ONLY :                                                    &
+       &     carbon_cycle_tr, carbon_cycle_cpl, co2_send
+      USE indice_sol_mod
+!L. Fita. August, 2013
+      USE netcdf
+
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+!c Objet: Lecture de l'etat initial pour la physique
+!c======================================================================
+#include "dimensions.h"
+!L. Fita. August, 2013
+!#include "netcdf.inc"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "temps.h"
+#include "thermcell.h"
+#include "compbl.h"
+!c======================================================================
+      CHARACTER*(*) fichnom
+
+!c les variables globales lues dans le fichier restart
+
+      REAL tsoil(klon,nsoilmx,nbsrf)
+      REAL tslab(klon), seaice(klon)
+      REAL qsurf(klon,nbsrf)
+      REAL qsol(klon)
+      REAL snow(klon,nbsrf)
+      REAL evap(klon,nbsrf)
+      real fder(klon)
+      REAL frugs(klon,nbsrf)
+      REAL agesno(klon,nbsrf)
+      REAL run_off_lic_0(klon)
+      REAL fractint(klon)
+      REAL trs(klon,nbtr)
+
+      CHARACTER*6 ocean_in
+      LOGICAL ok_veget_in
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles )
+!c
+      REAL xmin, xmax
+!c
+      INTEGER nid, nvarid
+      INTEGER ierr, i, nsrf, isoil ,k
+      INTEGER length
+      PARAMETER (length=100)
+      INTEGER it, iiq
+      REAL tab_cntrl(length), tabcntr0(length)
+      CHARACTER*7 str7
+      CHARACTER*2 str2
+      LOGICAL :: found
+
+!c FH1D
+!c     real iolat(jjm+1)
+      real iolat(jjm+1-1/(iim*jjm))
+
+!L. Fita, LMDZ March 2014. Removing reading of initial conditions
+      LOGICAL read_flag
+
+      read_flag=.FALSE.
+
+      PRINT *,'  Lluis in phyetat0 ftsol',ftsol(550,:),' read_flag: ',read_flag
+
+!c
+!c Ouvrir le fichier contenant l'etat initial:
+!c
+!                                                                                     &
+!       &      CALL open_startphy(fichnom)
+      
+
+!c
+!c Lecture des parametres de controle:
+!c
+!      CALL get_var("controle",tab_cntrl)
+       
+!c
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique
+! Les constantes de la physiques sont lues dans la physique seulement.
+! Les egalites du type
+!             tab_cntrl( 5 )=clesphy0(1)
+! sont remplacees par
+!             clesphy0(1)=tab_cntrl( 5 )
+! On inverse aussi la logique.
+! On remplit les tab_cntrl avec les parametres lus dans les .def
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+         DO i = 1, length
+           tabcntr0( i ) = tab_cntrl( i )
+         ENDDO
+!c
+         tab_cntrl(1)=dtime
+         tab_cntrl(2)=radpas
+
+!c co2_ppm : value from the previous time step
+         IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN
+            co2_ppm = tab_cntrl(3)
+            RCO2    = co2_ppm * 1.0e-06  * 44.011/28.97 
+!c ELSE : keep value from .def
+         END IF
+
+!c co2_ppm0 : initial value of atmospheric CO2 (from create_etat0_limit.e .def)
+         co2_ppm0   = tab_cntrl(16)
+
+         solaire_etat0      = tab_cntrl(4)
+         tab_cntrl(5)=iflag_con
+         tab_cntrl(6)=nbapp_rad
+
+         if (cycle_diurne) tab_cntrl( 7) =1.
+         if (soil_model) tab_cntrl( 8) =1.
+         if (new_oliq) tab_cntrl( 9) =1.
+         if (ok_orodr) tab_cntrl(10) =1.
+         if (ok_orolf) tab_cntrl(11) =1.
+         if (ok_limitvrai) tab_cntrl(12) =1.
+
+
+      itau_phy = tab_cntrl(15)
+
+       
+      clesphy0(1)=tab_cntrl( 5 )
+      clesphy0(2)=tab_cntrl( 6 )
+      clesphy0(3)=tab_cntrl( 7 )
+      clesphy0(4)=tab_cntrl( 8 )
+      clesphy0(5)=tab_cntrl( 9 )
+      clesphy0(6)=tab_cntrl( 10 )
+      clesphy0(7)=tab_cntrl( 11 )
+      clesphy0(8)=tab_cntrl( 12 )
+
+! L. Fita, LMD. March 2014. Removing adquisition of the variables
+      reading_file: IF (read_flag) THEN
+
+!c
+!c Lecture des latitudes (coordonnees):
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("latitude",rlat)
+
+!c
+!c Lecture des longitudes (coordonnees):
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("longitude",rlon)
+
+!C
+!C
+!C Lecture du masque terre mer
+!C
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("masque",zmasq,found)
+      found=.True.
+      IF (.NOT. found) THEN
+        PRINT*, 'phyetat0: Le champ <masque> est absent'
+        PRINT *, 'fichier startphy non compatible avec phyetat0'
+      ENDIF
+
+       
+!C Lecture des fractions pour chaque sous-surface
+!C
+!C initialisation des sous-surfaces
+!C
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!      pctsrf = 0.
+!C
+!C fraction de terre
+!C
+
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("FTER",pctsrf(:,is_ter),found)
+      IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FTER> est absent'
+
+!C
+!C fraction de glace de terre
+!C
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("FLIC",pctsrf(:,is_lic),found)
+      IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FLIC> est absent'
+
+!C
+!C fraction d'ocean
+!C
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("FOCE",pctsrf(:,is_oce),found)
+      IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FOCE> est absent'
+
+!C
+!C fraction glace de mer
+!C
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("FSIC",pctsrf(:,is_sic),found)
+      IF (.NOT. found) PRINT*, 'phyetat0: Le champ <FSIC> est absent'
+
+!C
+!C  Verification de l'adequation entre le masque et les sous-surfaces
+!C
+      fractint( 1 : klon) = pctsrf(1 : klon, is_ter)                                 &
+       &    + pctsrf(1 : klon, is_lic)
+      DO i = 1 , klon
+        IF ( abs(fractint(i) - zmasq(i) ) .GT. EPSFRA ) THEN
+            WRITE(*,*) 'phyetat0: attention fraction terre pas ',                    &
+       &          'coherente ', i, zmasq(i), pctsrf(i, is_ter)                       &
+       &          ,pctsrf(i, is_lic)
+            WRITE(*,*) 'Je force la coherence zmasq=fractint'
+            zmasq(i) = fractint(i)
+        ENDIF 
+      END DO 
+      fractint (1 : klon) =  pctsrf(1 : klon, is_oce)                                &
+       &    + pctsrf(1 : klon, is_sic)
+      DO i = 1 , klon
+        IF ( abs( fractint(i) - (1. - zmasq(i))) .GT. EPSFRA ) THEN
+            WRITE(*,*) 'phyetat0 attention fraction ocean pas ',                     &
+       &          'coherente ', i, zmasq(i) , pctsrf(i, is_oce)                      &
+       &          ,pctsrf(i, is_sic)
+            WRITE(*,*) 'Je force la coherence zmasq=fractint'
+            zmasq(i) = fractint(i)
+        ENDIF 
+      END DO 
+
+!C
+!c Lecture des temperatures du sol:
+!c
+
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!       CALL get_field("TS",ftsol(:,1),found)
+       IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <TS> est absent'
+         PRINT*, '          Mais je vais essayer de lire TS**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!           CALL get_field("TS"//str2,ftsol(:,nsrf))
+
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(ftsol(i,nsrf),xmin)
+              xmax = MAX(ftsol(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Temperature du sol TS**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <TS> est present'
+         PRINT*, '          J ignore donc les autres temperatures TS**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(ftsol(i,1),xmin)
+            xmax = MAX(ftsol(i,1),xmax)
+         ENDDO
+         PRINT*,'Temperature du sol <TS>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            ftsol(i,nsrf) = ftsol(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+!c
+!c Lecture des temperatures du sol profond:
+!c
+      DO nsrf = 1, nbsrf
+        DO isoil=1, nsoilmx
+          IF (isoil.GT.99 .AND. nsrf.GT.99) THEN
+            PRINT*, "Trop de couches ou sous-mailles"
+            CALL abort
+          ENDIF
+          WRITE(str7,'(i2.2,"srf",i2.2)') isoil, nsrf
+          
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!          CALL get_field('Tsoil'//str7,tsoil(:,isoil,nsrf),found)
+          IF (.NOT. found) THEN
+            PRINT*, "phyetat0: Le champ <Tsoil"//str7//"> est absent"
+            PRINT*, "          Il prend donc la valeur de surface"
+            DO i=1, klon
+               tsoil(i,isoil,nsrf)=ftsol(i,nsrf)
+            ENDDO
+          ENDIF
+        ENDDO
+      ENDDO
+!c
+!c Lecture de l'humidite de l'air juste au dessus du sol:
+!c
+
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("QS",qsurf(:,1),found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <QS> est absent'
+         PRINT*, '          Mais je vais essayer de lire QS**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!           CALL get_field("QS"//str2,qsurf(:,nsrf))
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(qsurf(i,nsrf),xmin)
+              xmax = MAX(qsurf(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Humidite pres du sol QS**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <QS> est present'
+         PRINT*, '          J ignore donc les autres humidites QS**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(qsurf(i,1),xmin)
+            xmax = MAX(qsurf(i,1),xmax)
+         ENDDO
+         PRINT*,'Humidite pres du sol <QS>', xmin, xmax
+         DO nsrf = 2, nbsrf
+           DO i = 1, klon
+             qsurf(i,nsrf) = qsurf(i,1)
+           ENDDO
+         ENDDO
+      ENDIF
+
+!C
+!C Eau dans le sol (pour le modele de sol "bucket")
+!C
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("QSOL",qsol,found)
+      IF (.NOT. found) THEN
+        PRINT*, 'phyetat0: Le champ <QSOL> est absent'
+        PRINT*, '          Valeur par defaut nulle'
+          qsol(:)=0.
+      ENDIF
+
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+        xmin = MIN(qsol(i),xmin)
+        xmax = MAX(qsol(i),xmax)
+      ENDDO
+      PRINT*,'Eau dans le sol (mm) <QSOL>', xmin, xmax
+
+!c
+!c Lecture de neige au sol:
+!c
+
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("SNOW",snow(:,1),found)
+      IF (.NOT. found) THEN
+        PRINT*, 'phyetat0: Le champ <SNOW> est absent'
+        PRINT*, '          Mais je vais essayer de lire SNOW**'
+        DO nsrf = 1, nbsrf
+          IF (nsrf.GT.99) THEN
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+          ENDIF
+          WRITE(str2,'(i2.2)') nsrf
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!          CALL get_field( "SNOW"//str2,snow(:,nsrf))
+          xmin = 1.0E+20
+          xmax = -1.0E+20
+          DO i = 1, klon
+            xmin = MIN(snow(i,nsrf),xmin)
+            xmax = MAX(snow(i,nsrf),xmax)
+          ENDDO
+          PRINT*,'Neige du sol SNOW**:', nsrf, xmin, xmax
+        ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <SNOW> est present'
+         PRINT*, '          J ignore donc les autres neiges SNOW**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(snow(i,1),xmin)
+            xmax = MAX(snow(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <SNOW>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            snow(i,nsrf) = snow(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+!c
+!c Lecture de albedo de l'interval visible au sol:
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("ALBE",falb1(:,1),found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <ALBE> est absent'
+         PRINT*, '          Mais je vais essayer de lire ALBE**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!           CALL get_field("ALBE"//str2,falb1(:,nsrf))
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(falb1(i,nsrf),xmin)
+              xmax = MAX(falb1(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Albedo du sol ALBE**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <ALBE> est present'
+         PRINT*, '          J ignore donc les autres ALBE**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(falb1(i,1),xmin)
+            xmax = MAX(falb1(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <ALBE>', xmin, xmax
+         DO nsrf = 2, nbsrf
+           DO i = 1, klon
+            falb1(i,nsrf) = falb1(i,1)
+           ENDDO
+         ENDDO
+      ENDIF
+
+!c
+!c Lecture de albedo au sol dans l'interval proche infra-rouge:
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("ALBLW",falb2(:,1),found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <ALBLW> est absent'
+         PRINT*, '          Mais je vais prendre ALBE**'
+         DO nsrf = 1, nbsrf
+           DO i = 1, klon
+             falb2(i,nsrf) = falb1(i,nsrf)
+           ENDDO
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <ALBLW> est present'
+         PRINT*, '          J ignore donc les autres ALBLW**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(falb2(i,1),xmin)
+            xmax = MAX(falb2(i,1),xmax)
+         ENDDO
+         PRINT*,'Neige du sol <ALBLW>', xmin, xmax
+         DO nsrf = 2, nbsrf
+           DO i = 1, klon
+             falb2(i,nsrf) = falb2(i,1)
+           ENDDO
+         ENDDO
+      ENDIF
+!c
+!c Lecture de evaporation:  
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("EVAP",evap(:,1),found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <EVAP> est absent'
+         PRINT*, '          Mais je vais essayer de lire EVAP**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!           CALL get_field("EVAP"//str2, evap(:,nsrf))
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(evap(i,nsrf),xmin)
+              xmax = MAX(evap(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'evap du sol EVAP**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <EVAP> est present'
+         PRINT*, '          J ignore donc les autres EVAP**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(evap(i,1),xmin)
+            xmax = MAX(evap(i,1),xmax)
+         ENDDO
+         PRINT*,'Evap du sol <EVAP>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            evap(i,nsrf) = evap(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+!c
+!c Lecture precipitation liquide:
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("rain_f",rain_fall)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(rain_fall(i),xmin)
+         xmax = MAX(rain_fall(i),xmax)
+      ENDDO
+      PRINT*,'Precipitation liquide rain_f:', xmin, xmax
+!c
+!c Lecture precipitation solide:
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("snow_f",snow_fall)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(snow_fall(i),xmin)
+         xmax = MAX(snow_fall(i),xmax)
+      ENDDO
+      PRINT*,'Precipitation solide snow_f:', xmin, xmax
+!c
+!c Lecture rayonnement solaire au sol:
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("solsw",solsw,found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <solsw> est absent'
+         PRINT*, 'mis a zero'
+         solsw(:) = 0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(solsw(i),xmin)
+         xmax = MAX(solsw(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement solaire au sol solsw:', xmin, xmax
+!c
+!c Lecture rayonnement IF au sol:
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("sollw",sollw,found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <sollw> est absent'
+         PRINT*, 'mis a zero'
+         sollw = 0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(sollw(i),xmin)
+         xmax = MAX(sollw(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement IF au sol sollw:', xmin, xmax
+      
+!c
+!c Lecture derive des flux:
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("fder",fder,found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <fder> est absent'
+         PRINT*, 'mis a zero'
+         fder = 0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(fder(i),xmin)
+         xmax = MAX(fder(i),xmax)
+      ENDDO
+      PRINT*,'Derive des flux fder:', xmin, xmax
+
+!c
+!c Lecture du rayonnement net au sol:
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("RADS",radsol)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(radsol(i),xmin)
+         xmax = MAX(radsol(i),xmax)
+      ENDDO
+      PRINT*,'Rayonnement net au sol radsol:', xmin, xmax
+!c
+!c Lecture de la longueur de rugosite 
+!c
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("RUG",frugs(:,1),found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <RUG> est absent'
+         PRINT*, '          Mais je vais essayer de lire RUG**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!           CALL get_field("RUG"//str2,frugs(:,nsrf))
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(frugs(i,nsrf),xmin)
+              xmax = MAX(frugs(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'rugosite du sol RUG**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <RUG> est present'
+         PRINT*, '          J ignore donc les autres RUG**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(frugs(i,1),xmin)
+            xmax = MAX(frugs(i,1),xmax)
+         ENDDO
+         PRINT*,'rugosite <RUG>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            frugs(i,nsrf) = frugs(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+!c
+!c Lecture de l'age de la neige:
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("AGESNO",agesno(:,1),found)
+      IF (.NOT. found) THEN
+         PRINT*, 'phyetat0: Le champ <AGESNO> est absent'
+         PRINT*, '          Mais je vais essayer de lire AGESNO**'
+         DO nsrf = 1, nbsrf
+           IF (nsrf.GT.99) THEN
+             PRINT*, "Trop de sous-mailles"
+             CALL abort
+           ENDIF
+           WRITE(str2,'(i2.2)') nsrf
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!           CALL get_field("AGESNO"//str2,agesno(:,nsrf),found)
+           IF (.NOT. found) THEN
+              PRINT*, "phyetat0: Le champ <AGESNO"//str2//"> est absent"
+              agesno = 50.0
+           ENDIF
+           xmin = 1.0E+20
+           xmax = -1.0E+20
+           DO i = 1, klon
+              xmin = MIN(agesno(i,nsrf),xmin)
+              xmax = MAX(agesno(i,nsrf),xmax)
+           ENDDO
+           PRINT*,'Age de la neige AGESNO**:', nsrf, xmin, xmax
+         ENDDO
+      ELSE
+         PRINT*, 'phyetat0: Le champ <AGESNO> est present'
+         PRINT*, '          J ignore donc les autres AGESNO**'
+         xmin = 1.0E+20
+         xmax = -1.0E+20
+         DO i = 1, klon
+            xmin = MIN(agesno(i,1),xmin)
+            xmax = MAX(agesno(i,1),xmax)
+         ENDDO
+         PRINT*,'Age de la neige <AGESNO>', xmin, xmax
+         DO nsrf = 2, nbsrf
+         DO i = 1, klon
+            agesno(i,nsrf) = agesno(i,1)
+         ENDDO
+         ENDDO
+      ENDIF
+
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("ZMEA", zmea)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zmea(i),xmin)
+         xmax = MAX(zmea(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zmea:', xmin, xmax
+!c
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("ZSTD",zstd)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zstd(i),xmin)
+         xmax = MAX(zstd(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zstd:', xmin, xmax
+!c
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("ZSIG",zsig)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zsig(i),xmin)
+         xmax = MAX(zsig(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zsig:', xmin, xmax
+!c
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("ZGAM",zgam)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zgam(i),xmin)
+         xmax = MAX(zgam(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zgam:', xmin, xmax
+!c
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("ZTHE",zthe)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zthe(i),xmin)
+         xmax = MAX(zthe(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zthe:', xmin, xmax
+!c
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("ZPIC",zpic)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zpic(i),xmin)
+         xmax = MAX(zpic(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zpic:', xmin, xmax
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("ZVAL",zval)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(zval(i),xmin)
+         xmax = MAX(zval(i),xmax)
+      ENDDO
+      PRINT*,'OROGRAPHIE SOUS-MAILLE zval:', xmin, xmax
+!c
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("RUGSREL",rugoro)
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      DO i = 1, klon
+         xmin = MIN(rugoro(i),xmin)
+         xmax = MAX(rugoro(i),xmax)
+      ENDDO
+      PRINT*,'Rugosite relief (ecart-type) rugsrel:', xmin, xmax
+!c
+!c                                                                                   &
+       &!c
+      ancien_ok = .TRUE.
+
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("TANCIEN",t_ancien,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <TANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ENDIF
+
+
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("QANCIEN",q_ancien,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <QANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ENDIF
+
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("UANCIEN",u_ancien,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <UANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ENDIF
+
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("VANCIEN",v_ancien,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <VANCIEN> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         ancien_ok = .FALSE.
+      ENDIF
+
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!      clwcon=0.
+!!      CALL get_field("CLWCON",clwcon,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ CLWCON est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(clwcon)
+      xmax = MAXval(clwcon)
+      PRINT*,'Eau liquide convective (ecart-type) clwcon:', xmin, xmax
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!      rnebcon = 0.
+!!      CALL get_field("RNEBCON",rnebcon,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ RNEBCON est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(rnebcon)
+      xmax = MAXval(rnebcon)
+      PRINT*,'Nebulosite convective (ecart-type) rnebcon:', xmin, xmax
+
+!c
+!c Lecture ratqs
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!      ratqs=0.
+!!      CALL get_field("RATQS",ratqs,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <RATQS> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(ratqs)
+      xmax = MAXval(ratqs)
+      PRINT*,'(ecart-type) ratqs:', xmin, xmax
+!c
+!c Lecture run_off_lic_0
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("RUNOFFLIC0",run_off_lic_0,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <RUNOFFLIC0> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         run_off_lic_0 = 0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(run_off_lic_0)
+      xmax = MAXval(run_off_lic_0)
+      PRINT*,'(ecart-type) run_off_lic_0:', xmin, xmax
+
+
+!c Lecture de l'energie cinetique turbulente
+!c
+
+      IF (iflag_pbl>1) then
+        DO nsrf = 1, nbsrf
+          IF (nsrf.GT.99) THEN
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+          ENDIF
+          WRITE(str2,'(i2.2)') nsrf
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!          CALL get_field("TKE"//str2,pbl_tke(:,1:klev+1,nsrf),found)
+          IF (.NOT. found) THEN
+            PRINT*, "phyetat0: <TKE"//str2//"> est absent"
+            pbl_tke(:,:,nsrf)=1.e-8
+          ENDIF
+          xmin = 1.0E+20
+          xmax = -1.0E+20
+          DO k = 1, klev+1
+            DO i = 1, klon
+              xmin = MIN(pbl_tke(i,k,nsrf),xmin)
+              xmax = MAX(pbl_tke(i,k,nsrf),xmax)
+            ENDDO
+          ENDDO
+          PRINT*,'Temperature du sol TKE**:', nsrf, xmin, xmax
+        ENDDO
+      ENDIF
+!c
+!c zmax0
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("ZMAX0",zmax0,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <ZMAX0> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        zmax0=40.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(zmax0)
+      xmax = MAXval(zmax0)
+      PRINT*,'(ecart-type) zmax0:', xmin, xmax
+!c
+!c           f0(ig)=1.e-5
+!c f0
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("F0",f0,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <f0> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         f0=1.e-5
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(f0)
+      xmax = MAXval(f0)
+      PRINT*,'(ecart-type) f0:', xmin, xmax
+!c
+!c ema_work1
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("EMA_WORK1",ema_work1,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <EMA_WORK1> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        ema_work1=0.
+      ELSE
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO k = 1, klev
+          DO i = 1, klon
+            xmin = MIN(ema_work1(i,k),xmin)
+            xmax = MAX(ema_work1(i,k),xmax)
+          ENDDO
+        ENDDO
+        PRINT*,'ema_work1:', xmin, xmax
+      ENDIF
+!c
+!c ema_work2
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("EMA_WORK2",ema_work2,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <EMA_WORK2> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        ema_work2=0.
+      ELSE
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO k = 1, klev
+          DO i = 1, klon
+            xmin = MIN(ema_work2(i,k),xmin)
+            xmax = MAX(ema_work2(i,k),xmax)
+          ENDDO
+        ENDDO
+        PRINT*,'ema_work2:', xmin, xmax
+      ENDIF
+!c
+!c wake_deltat
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("WAKE_DELTAT",wake_deltat,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <WAKE_DELTAT> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        wake_deltat=0.
+      ELSE
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO k = 1, klev
+          DO i = 1, klon
+            xmin = MIN(wake_deltat(i,k),xmin)
+            xmax = MAX(wake_deltat(i,k),xmax)
+          ENDDO
+        ENDDO
+        PRINT*,'wake_deltat:', xmin, xmax
+      ENDIF
+!c
+!c wake_deltaq
+!c   
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("WAKE_DELTAQ",wake_deltaq,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <WAKE_DELTAQ> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        wake_deltaq=0.
+      ELSE
+        xmin = 1.0E+20
+        xmax = -1.0E+20
+        DO k = 1, klev
+          DO i = 1, klon
+            xmin = MIN(wake_deltaq(i,k),xmin)
+            xmax = MAX(wake_deltaq(i,k),xmax)
+          ENDDO
+        ENDDO
+        PRINT*,'wake_deltaq:', xmin, xmax
+      ENDIF
+!c
+!c wake_s
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("WAKE_S",wake_s,found)
+      IF (.NOT. found) THEN
+        PRINT*, "phyetat0: Le champ <WAKE_S> est absent"
+        PRINT*, "Depart legerement fausse. Mais je continue"
+        wake_s=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_s)
+      xmax = MAXval(wake_s)
+      PRINT*,'(ecart-type) wake_s:', xmin, xmax
+!c
+!c wake_cstar
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("WAKE_CSTAR",wake_cstar,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <WAKE_CSTAR> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         wake_cstar=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_cstar)
+      xmax = MAXval(wake_cstar)
+      PRINT*,'(ecart-type) wake_cstar:', xmin, xmax
+!c
+!c wake_pe
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("WAKE_PE",wake_pe,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <WAKE_PE> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         wake_pe=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_pe)
+      xmax = MAXval(wake_pe)
+      PRINT*,'(ecart-type) wake_pe:', xmin, xmax
+!c
+!c wake_fip
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("WAKE_FIP",wake_fip,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <WAKE_FIP> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         wake_fip=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(wake_fip)
+      xmax = MAXval(wake_fip)
+      PRINT*,'(ecart-type) wake_fip:', xmin, xmax
+!c
+!c  thermiques
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("FM_THERM",fm_therm,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <fm_therm> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         fm_therm=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(fm_therm)
+      xmax = MAXval(fm_therm)
+      PRINT*,'(ecart-type) fm_therm:', xmin, xmax
+
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("ENTR_THERM",entr_therm,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <entr_therm> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         entr_therm=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(entr_therm)
+      xmax = MAXval(entr_therm)
+      PRINT*,'(ecart-type) entr_therm:', xmin, xmax
+
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL get_field("DETR_THERM",detr_therm,found)
+      IF (.NOT. found) THEN
+         PRINT*, "phyetat0: Le champ <detr_therm> est absent"
+         PRINT*, "Depart legerement fausse. Mais je continue"
+         detr_therm=0.
+      ENDIF
+      xmin = 1.0E+20
+      xmax = -1.0E+20
+      xmin = MINval(detr_therm)
+      xmax = MAXval(detr_therm)
+      PRINT*,'(ecart-type) detr_therm:', xmin, xmax
+
+
+
+!c
+!c Read and send field trs to traclmdz
+!c
+      IF (type_trac == 'lmdz') THEN
+         DO it=1,nbtr
+            iiq=niadv(it+2)
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!            CALL get_field("trs_"//tname(iiq),trs(:,it),found)
+            IF (.NOT. found) THEN
+               PRINT*,                                                               &
+       &           "phyetat0: Le champ <trs_"//tname(iiq)//"> est absent"
+               PRINT*, "Depart legerement fausse. Mais je continue"
+               trs(:,it) = 0.
+            ENDIF
+            xmin = 1.0E+20
+            xmax = -1.0E+20
+            xmin = MINval(trs(:,it))
+            xmax = MAXval(trs(:,it))
+            PRINT*,"(ecart-type) trs_"//tname(iiq)//" :", xmin, xmax
+
+         END DO
+         CALL traclmdz_from_restart(trs)
+
+         IF (carbon_cycle_cpl) THEN
+            ALLOCATE(co2_send(klon), stat=ierr)
+            IF (ierr /= 0) CALL abort_gcm                                            &
+       &           ('phyetat0','pb allocation co2_send',1)
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!            CALL get_field("co2_send",co2_send,found)
+            IF (.NOT. found) THEN
+               PRINT*,"phyetat0: Le champ <co2_send> est absent"
+               PRINT*,"Initialisation uniforme a co2_ppm=",co2_ppm
+               co2_send(:) = co2_ppm
+            END IF
+         END IF
+      END IF
+
+
+!c on ferme le fichier
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!      CALL close_startphy
+      ELSE
+        PRINT *,'  startphy not readed!'
+
+      END IF reading_file
+
+      PRINT *,'  Lluis before init_iophy_new: ftsol: ',ftsol(550,:)
+
+! L. Fita, LMD. Called inside the non-used if
+!! 
+      trs=0.
+      CALL traclmdz_from_restart(trs)
+
+      CALL init_iophy_new(rlat,rlon)
+      	
+      PRINT *,'  Lluis after init_iophy_new: ftsol: ',ftsol(550,:)
+
+!c
+!c Initialize module pbl_surface_mod 
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL pbl_surface_init(qsol, fder, snow, qsurf,                                 &
+!!       &     evap, frugs, agesno, tsoil)
+
+!c Initialize module ocean_cpl_mod for the case of coupled ocean
+      IF ( type_ocean == 'couple' ) THEN
+         CALL ocean_cpl_init(dtime, rlon, rlat)
+      ENDIF
+!c
+!c Initilialize module fonte_neige_mod      
+!c
+! L. Fita, LMD. November 2013. Removing adquisition of the variables
+!!      CALL fonte_neige_init(run_off_lic_0)
+
+      PRINT *,'  Lluis leaving phyetat0 ftsol: ',ftsol(550,:)
+
+      RETURN
+      END SUBROUTINE phyetat0
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phyredem.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phyredem.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phyredem.F	(revision 17)
@@ -0,0 +1,356 @@
+!
+! $Id: phyredem.F 1795 2013-07-18 08:20:28Z emillour $
+!
+c
+      SUBROUTINE phyredem (fichnom)
+
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE fonte_neige_mod,  ONLY : fonte_neige_final
+      USE pbl_surface_mod,  ONLY : pbl_surface_final
+      USE phys_state_var_mod
+      USE iostart
+      USE traclmdz_mod, ONLY : traclmdz_to_restart
+      USE infotrac
+      USE control_mod
+      USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send
+      USE indice_sol_mod
+
+      IMPLICIT none
+c======================================================================
+c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+c Objet: Ecriture de l'etat de redemarrage pour la physique
+c======================================================================
+#include "netcdf.inc"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "temps.h"
+#include "thermcell.h"
+#include "compbl.h"
+c======================================================================
+      CHARACTER*(*) fichnom
+
+c les variables globales ecrites dans le fichier restart
+
+      
+      REAL tsoil(klon,nsoilmx,nbsrf)
+      REAL tslab(klon), seaice(klon)
+      REAL qsurf(klon,nbsrf)
+      REAL qsol(klon)
+      REAL snow(klon,nbsrf)
+      REAL evap(klon,nbsrf)
+      real fder(klon)
+      REAL frugs(klon,nbsrf)
+      REAL agesno(klon,nbsrf)
+      REAL run_off_lic_0(klon)
+      REAL trs(klon,nbtr)
+c
+      INTEGER nid, nvarid, idim1, idim2, idim3
+      INTEGER ierr
+      INTEGER length
+      PARAMETER (length=100)
+      REAL tab_cntrl(length)
+c
+      INTEGER isoil, nsrf
+      CHARACTER (len=7) :: str7
+      CHARACTER (len=2) :: str2
+      INTEGER           :: it, iiq
+      
+c======================================================================
+c 
+c Get variables which will be written to restart file from module 
+c pbl_surface_mod
+      CALL pbl_surface_final(qsol, fder, snow, qsurf, 
+     $     evap, frugs, agesno, tsoil)
+
+c Get a variable calculated in module fonte_neige_mod
+      CALL fonte_neige_final(run_off_lic_0)
+
+c======================================================================
+
+      CALL open_restartphy(fichnom)
+      
+      DO ierr = 1, length
+         tab_cntrl(ierr) = 0.0
+      ENDDO
+      tab_cntrl(1) = dtime
+      tab_cntrl(2) = radpas
+c co2_ppm : current value of atmospheric CO2
+      tab_cntrl(3) = co2_ppm
+      tab_cntrl(4) = solaire
+      tab_cntrl(5) = iflag_con
+      tab_cntrl(6) = nbapp_rad
+
+      IF( cycle_diurne ) tab_cntrl( 7 ) = 1.
+      IF(   soil_model ) tab_cntrl( 8 ) = 1.
+      IF(     new_oliq ) tab_cntrl( 9 ) = 1.
+      IF(     ok_orodr ) tab_cntrl(10 ) = 1.
+      IF(     ok_orolf ) tab_cntrl(11 ) = 1.
+
+      tab_cntrl(13) = day_end
+      tab_cntrl(14) = annee_ref
+      tab_cntrl(15) = itau_phy
+
+c co2_ppm0 : initial value of atmospheric CO2
+      tab_cntrl(16) = co2_ppm0
+c
+      CALL put_var("controle","Parametres de controle",tab_cntrl)
+c
+
+      CALL put_field("longitude",
+     .               "Longitudes de la grille physique",rlon)
+     
+      CALL put_field("latitude","Latitudes de la grille physique",rlat)
+
+c
+C PB ajout du masque terre/mer
+C
+      CALL put_field("masque","masque terre mer",zmasq)
+
+c BP ajout des fraction de chaque sous-surface
+C
+C 1. fraction de terre 
+C
+      CALL put_field("FTER","fraction de continent",pctsrf(:,is_ter))
+C 
+C 2. Fraction de glace de terre
+C 
+      CALL put_field("FLIC","fraction glace de terre",pctsrf(:,is_lic))
+C
+C 3. fraction ocean
+C
+      CALL put_field("FOCE","fraction ocean",pctsrf(:,is_oce))
+C
+C 4. Fraction glace de mer
+C
+      CALL put_field("FSIC","fraction glace mer",pctsrf(:,is_sic))
+C
+C
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("TS"//str2,"Temperature de surface No."//str2,
+     .                    ftsol(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+        DO isoil=1, nsoilmx
+          IF (isoil.LE.99 .AND. nsrf.LE.99) THEN
+            WRITE(str7,'(i2.2,"srf",i2.2)') isoil,nsrf
+            CALL put_field("Tsoil"//str7,"Temperature du sol No."//str7,
+     .                     tsoil(:,isoil,nsrf))
+          ELSE
+            PRINT*, "Trop de couches"
+            CALL abort
+          ENDIF
+        ENDDO
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("QS"//str2,"Humidite de surface No."//str2,
+     .                   qsurf(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      END DO
+C
+      CALL put_field("QSOL","Eau dans le sol (mm)",qsol)
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("ALBE"//str2,"albedo de surface No."//str2,
+     .                   falb1(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("ALBLW"//str2,"albedo LW de surface No."//str2,
+     .                   falb2(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+c
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("EVAP"//str2,"Evaporation de surface No."//str2
+     .                   ,evap(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("SNOW"//str2,"Neige de surface No."//str2,
+     .                   snow(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+
+c
+      CALL put_field("RADS","Rayonnement net a la surface",radsol)
+c
+      CALL put_field("solsw","Rayonnement solaire a la surface",solsw)
+c
+      CALL put_field("sollw","Rayonnement IF a la surface",sollw)
+c
+      CALL put_field("fder","Derive de flux",fder)
+c
+      CALL put_field("rain_f","precipitation liquide",rain_fall)
+c
+      CALL put_field("snow_f", "precipitation solide",snow_fall)
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("RUG"//str2,"rugosite de surface No."//str2,
+     .         frugs(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+            WRITE(str2,'(i2.2)') nsrf
+            CALL put_field("AGESNO"//str2,
+     .                     "Age de la neige surface No."//str2,
+     .                     agesno(:,nsrf))
+        ELSE
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+        ENDIF
+      ENDDO
+c
+      CALL put_field("ZMEA","ZMEA",zmea)
+c
+      CALL put_field("ZSTD","ZSTD",zstd)
+      
+      CALL put_field("ZSIG","ZSIG",zsig)
+      
+      CALL put_field("ZGAM","ZGAM",zgam)
+      
+      CALL put_field("ZTHE","ZTHE",zthe)
+      
+      CALL put_field("ZPIC","ZPIC",zpic)
+      
+      CALL put_field("ZVAL","ZVAL",zval)
+      
+      CALL put_field("RUGSREL","RUGSREL",rugoro)
+      
+      CALL put_field("TANCIEN","TANCIEN",t_ancien)
+      
+      CALL put_field("QANCIEN","QANCIEN",q_ancien)
+
+      CALL put_field("UANCIEN","",u_ancien)
+
+      CALL put_field("VANCIEN","",v_ancien)
+
+      CALL put_field("RUGMER","Longueur de rugosite sur mer",
+     .               frugs(:,is_oce))
+      
+      CALL put_field("CLWCON","Eau liquide convective",clwcon)
+      
+      CALL put_field("RNEBCON","Nebulosite convective",rnebcon)
+      
+      CALL put_field("RATQS", "Ratqs",ratqs)
+c
+c run_off_lic_0
+c
+      CALL put_field("RUNOFFLIC0","Runofflic0",run_off_lic_0)
+c
+c
+!!!!!!!!!!!!!!!!!!!! DEB TKE PBL !!!!!!!!!!!!!!!!!!!!!!!!!
+c
+      IF (iflag_pbl>1) then
+        DO nsrf = 1, nbsrf
+          IF (nsrf.LE.99) THEN
+            WRITE(str2,'(i2.2)') nsrf
+            CALL put_field("TKE"//str2,"Energ. Cineti. Turb."//str2,
+     .                     pbl_tke(:,1:klev+1,nsrf))
+          ELSE
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+          ENDIF
+        ENDDO
+      ENDIF
+
+!!!!!!!!!!!!!!!!!!!! FIN TKE PBL !!!!!!!!!!!!!!!!!!!!!!!!!
+cIM ajout zmax0, f0, ema_work1, ema_work2
+cIM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_pe, wake_fip
+      
+      CALL put_field("ZMAX0","ZMAX0",zmax0)
+      
+      CALL put_field("F0","F0",f0)
+      
+      CALL put_field("EMA_WORK1","EMA_WORK1",ema_work1)
+      
+      CALL put_field("EMA_WORK2","EMA_WORK2",ema_work2)
+      
+c wake_deltat
+      CALL put_field("WAKE_DELTAT","WAKE_DELTAT",wake_deltat)
+
+      CALL put_field("WAKE_DELTAQ","WAKE_DELTAQ",wake_deltaq)
+      
+      CALL put_field("WAKE_S","WAKE_S",wake_s)
+      
+      CALL put_field("WAKE_CSTAR","WAKE_CSTAR",wake_cstar)
+      
+      CALL put_field("WAKE_PE","WAKE_PE",wake_pe)
+
+      CALL put_field("WAKE_FIP","WAKE_FIP",wake_fip)
+
+c thermiques
+
+      CALL put_field("FM_THERM","FM_THERM",fm_therm)
+
+      CALL put_field("ENTR_THERM","ENTR_THERM",entr_therm)
+
+      CALL put_field("DETR_THERM","DETR_THERM",detr_therm)
+
+! trs from traclmdz_mod
+      IF (type_trac == 'lmdz') THEN
+         CALL traclmdz_to_restart(trs)
+         DO it=1,nbtr
+            iiq=niadv(it+2)
+            CALL put_field("trs_"//tname(iiq),"",trs(:,it))
+         END DO
+         IF (carbon_cycle_cpl) THEN
+            IF (.NOT. ALLOCATED(co2_send)) THEN
+               ! This is the case of create_etat0_limit, ce0l
+               ALLOCATE(co2_send(klon))
+               co2_send(:) = co2_ppm0
+            END IF
+            CALL put_field("co2_send","co2_ppm for coupling",co2_send)
+         END IF
+      END IF
+
+      CALL close_restartphy
+!$OMP BARRIER
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phyredem.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phyredem.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phyredem.F90	(revision 17)
@@ -0,0 +1,355 @@
+!
+! $Id: phyredem.F 1795 2013-07-18 08:20:28Z emillour $
+!
+!c
+      SUBROUTINE phyredem (fichnom)
+
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE fonte_neige_mod,  ONLY : fonte_neige_final
+      USE pbl_surface_mod,  ONLY : pbl_surface_final
+      USE phys_state_var_mod
+      USE iostart
+      USE traclmdz_mod, ONLY : traclmdz_to_restart
+      USE infotrac
+      USE control_mod
+      USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, co2_send
+      USE indice_sol_mod
+
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+!c Objet: Ecriture de l'etat de redemarrage pour la physique
+!c======================================================================
+      include "netcdf.inc"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "temps.h"
+#include "thermcell.h"
+#include "compbl.h"
+!c======================================================================
+      CHARACTER*(*) fichnom
+
+!c les variables globales ecrites dans le fichier restart
+
+      
+      REAL tsoil(klon,nsoilmx,nbsrf)
+      REAL tslab(klon), seaice(klon)
+      REAL qsurf(klon,nbsrf)
+      REAL qsol(klon)
+      REAL snow(klon,nbsrf)
+      REAL evap(klon,nbsrf)
+      real fder(klon)
+      REAL frugs(klon,nbsrf)
+      REAL agesno(klon,nbsrf)
+      REAL run_off_lic_0(klon)
+      REAL trs(klon,nbtr)
+!c
+      INTEGER nid, nvarid, idim1, idim2, idim3
+      INTEGER ierr
+      INTEGER length
+      PARAMETER (length=100)
+      REAL tab_cntrl(length)
+!c
+      INTEGER isoil, nsrf
+      CHARACTER (len=7) :: str7
+      CHARACTER (len=2) :: str2
+      INTEGER           :: it, iiq
+      
+!c======================================================================
+!c 
+!c Get variables which will be written to restart file from module 
+!c pbl_surface_mod
+      CALL pbl_surface_final(qsol, fder, snow, qsurf,                                &
+       &     evap, frugs, agesno, tsoil)
+
+!c Get a variable calculated in module fonte_neige_mod
+      CALL fonte_neige_final(run_off_lic_0)
+
+!c======================================================================
+
+      CALL open_restartphy(fichnom)
+      
+      DO ierr = 1, length
+         tab_cntrl(ierr) = 0.0
+      ENDDO
+      tab_cntrl(1) = dtime
+      tab_cntrl(2) = radpas
+!c co2_ppm : current value of atmospheric CO2
+      tab_cntrl(3) = co2_ppm
+      tab_cntrl(4) = solaire
+      tab_cntrl(5) = iflag_con
+      tab_cntrl(6) = nbapp_rad
+
+      IF( cycle_diurne ) tab_cntrl( 7 ) = 1.
+      IF(   soil_model ) tab_cntrl( 8 ) = 1.
+      IF(     new_oliq ) tab_cntrl( 9 ) = 1.
+      IF(     ok_orodr ) tab_cntrl(10 ) = 1.
+      IF(     ok_orolf ) tab_cntrl(11 ) = 1.
+
+      tab_cntrl(13) = day_end
+      tab_cntrl(14) = annee_ref
+      tab_cntrl(15) = itau_phy
+
+!c co2_ppm0 : initial value of atmospheric CO2
+      tab_cntrl(16) = co2_ppm0
+!c
+      CALL put_var("controle","Parametres de controle",tab_cntrl)
+!c
+
+      CALL put_field("longitude",                                                    &
+       &               "Longitudes de la grille physique",rlon)                      
+      CALL put_field("latitude","Latitudes de la grille physique",rlat)
+
+!c
+!C PB ajout du masque terre/mer
+!C
+      CALL put_field("masque","masque terre mer",zmasq)
+
+!c BP ajout des fraction de chaque sous-surface
+!C
+!C 1. fraction de terre 
+!C
+      CALL put_field("FTER","fraction de continent",pctsrf(:,is_ter))
+!C 
+!C 2. Fraction de glace de terre
+!C 
+      CALL put_field("FLIC","fraction glace de terre",pctsrf(:,is_lic))
+!C
+!C 3. fraction ocean
+!C
+      CALL put_field("FOCE","fraction ocean",pctsrf(:,is_oce))
+!C
+!C 4. Fraction glace de mer
+!C
+      CALL put_field("FSIC","fraction glace mer",pctsrf(:,is_sic))
+!C
+!C
+!c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("TS"//str2,"Temperature de surface No."//str2,              &
+       &                    ftsol(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+!c
+      DO nsrf = 1, nbsrf
+        DO isoil=1, nsoilmx
+          IF (isoil.LE.99 .AND. nsrf.LE.99) THEN
+            WRITE(str7,'(i2.2,"srf",i2.2)') isoil,nsrf
+            CALL put_field("Tsoil"//str7,"Temperature du sol No."//str7,             &
+       &                     tsoil(:,isoil,nsrf))
+          ELSE
+            PRINT*, "Trop de couches"
+            CALL abort
+          ENDIF
+        ENDDO
+      ENDDO
+!c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("QS"//str2,"Humidite de surface No."//str2,                 &
+       &                   qsurf(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      END DO
+!C
+      CALL put_field("QSOL","Eau dans le sol (mm)",qsol)
+!c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("ALBE"//str2,"albedo de surface No."//str2,                 &
+       &                   falb1(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("ALBLW"//str2,"albedo LW de surface No."//str2,             &
+       &                   falb2(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+!c
+!c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("EVAP"//str2,"Evaporation de surface No."//str2             &
+       &                   ,evap(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+
+!c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+          WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("SNOW"//str2,"Neige de surface No."//str2,                  &
+       &                   snow(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+
+!c
+      CALL put_field("RADS","Rayonnement net a la surface",radsol)
+!c
+      CALL put_field("solsw","Rayonnement solaire a la surface",solsw)
+!c
+      CALL put_field("sollw","Rayonnement IF a la surface",sollw)
+!c
+      CALL put_field("fder","Derive de flux",fder)
+!c
+      CALL put_field("rain_f","precipitation liquide",rain_fall)
+!c
+      CALL put_field("snow_f", "precipitation solide",snow_fall)
+!c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+        WRITE(str2,'(i2.2)') nsrf
+          CALL put_field("RUG"//str2,"rugosite de surface No."//str2,                &
+       &         frugs(:,nsrf))
+        ELSE
+          PRINT*, "Trop de sous-mailles"
+          CALL abort
+        ENDIF
+      ENDDO
+!c
+      DO nsrf = 1, nbsrf
+        IF (nsrf.LE.99) THEN
+            WRITE(str2,'(i2.2)') nsrf
+            CALL put_field("AGESNO"//str2,                                           &
+       &                     "Age de la neige surface No."//str2,                    &
+       &                     agesno(:,nsrf))
+        ELSE
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+        ENDIF
+      ENDDO
+!c
+      CALL put_field("ZMEA","ZMEA",zmea)
+!c
+      CALL put_field("ZSTD","ZSTD",zstd)
+      
+      CALL put_field("ZSIG","ZSIG",zsig)
+      
+      CALL put_field("ZGAM","ZGAM",zgam)
+      
+      CALL put_field("ZTHE","ZTHE",zthe)
+      
+      CALL put_field("ZPIC","ZPIC",zpic)
+      
+      CALL put_field("ZVAL","ZVAL",zval)
+      
+      CALL put_field("RUGSREL","RUGSREL",rugoro)
+      
+      CALL put_field("TANCIEN","TANCIEN",t_ancien)
+      
+      CALL put_field("QANCIEN","QANCIEN",q_ancien)
+
+      CALL put_field("UANCIEN","",u_ancien)
+
+      CALL put_field("VANCIEN","",v_ancien)
+
+      CALL put_field("RUGMER","Longueur de rugosite sur mer",                        &
+       &               frugs(:,is_oce))
+      
+      CALL put_field("CLWCON","Eau liquide convective",clwcon)
+      
+      CALL put_field("RNEBCON","Nebulosite convective",rnebcon)
+      
+      CALL put_field("RATQS", "Ratqs",ratqs)
+!c
+!c run_off_lic_0
+!c
+      CALL put_field("RUNOFFLIC0","Runofflic0",run_off_lic_0)
+!c
+!c
+!!!!!!!!!!!!!!!!!!!! DEB TKE PBL !!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+      IF (iflag_pbl>1) then
+        DO nsrf = 1, nbsrf
+          IF (nsrf.LE.99) THEN
+            WRITE(str2,'(i2.2)') nsrf
+            CALL put_field("TKE"//str2,"Energ. Cineti. Turb."//str2,                 &
+       &                     pbl_tke(:,1:klev+1,nsrf))
+          ELSE
+            PRINT*, "Trop de sous-mailles"
+            CALL abort
+          ENDIF
+        ENDDO
+      ENDIF
+
+!!!!!!!!!!!!!!!!!!!! FIN TKE PBL !!!!!!!!!!!!!!!!!!!!!!!!!
+!IM ajout zmax0, f0, ema_work1, ema_work2
+!IM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_pe, wake_fip
+      
+      CALL put_field("ZMAX0","ZMAX0",zmax0)
+      
+      CALL put_field("F0","F0",f0)
+      
+      CALL put_field("EMA_WORK1","EMA_WORK1",ema_work1)
+      
+      CALL put_field("EMA_WORK2","EMA_WORK2",ema_work2)
+      
+!c wake_deltat
+      CALL put_field("WAKE_DELTAT","WAKE_DELTAT",wake_deltat)
+
+      CALL put_field("WAKE_DELTAQ","WAKE_DELTAQ",wake_deltaq)
+      
+      CALL put_field("WAKE_S","WAKE_S",wake_s)
+      
+      CALL put_field("WAKE_CSTAR","WAKE_CSTAR",wake_cstar)
+      
+      CALL put_field("WAKE_PE","WAKE_PE",wake_pe)
+
+      CALL put_field("WAKE_FIP","WAKE_FIP",wake_fip)
+
+!c thermiques
+
+      CALL put_field("FM_THERM","FM_THERM",fm_therm)
+
+      CALL put_field("ENTR_THERM","ENTR_THERM",entr_therm)
+
+      CALL put_field("DETR_THERM","DETR_THERM",detr_therm)
+
+! trs from traclmdz_mod
+      IF (type_trac == 'lmdz') THEN
+         CALL traclmdz_to_restart(trs)
+         DO it=1,nbtr
+            iiq=niadv(it+2)
+            CALL put_field("trs_"//tname(iiq),"",trs(:,it))
+         END DO
+         IF (carbon_cycle_cpl) THEN
+            IF (.NOT. ALLOCATED(co2_send)) THEN
+               ! This is the case of create_etat0_limit, ce0l
+               ALLOCATE(co2_send(klon))
+               co2_send(:) = co2_ppm0
+            END IF
+            CALL put_field("co2_send","co2_ppm for coupling",co2_send)
+         END IF
+      END IF
+
+      CALL close_restartphy
+!$OMP BARRIER
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_cal_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_cal_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_cal_mod.F90	(revision 17)
@@ -0,0 +1,41 @@
+! $Id:$
+MODULE phys_cal_mod
+! This module contains information on the calendar at the actual time step
+
+  SAVE
+
+  INTEGER :: year_cur      ! current year
+  INTEGER :: mth_cur       ! current month
+  INTEGER :: day_cur       ! current day
+  INTEGER :: days_elapsed  ! number of whole days since start of the simulation 
+  INTEGER :: mth_len       ! number of days in the current month
+  REAL    :: hour
+  REAL    :: jD_1jan
+  REAL    :: jH_1jan
+  REAL    :: xjour
+
+
+CONTAINS
+  
+  SUBROUTINE phys_cal_update(jD_cur, jH_cur)
+    ! This subroutine updates the module saved variables.
+
+    USE IOIPSL
+    
+    REAL, INTENT(IN) :: jD_cur ! jour courant a l'appel de la physique (jour julien)
+    REAL, INTENT(IN) :: jH_cur ! heure courante a l'appel de la physique (jour julien)
+    
+    CALL ju2ymds(jD_cur+jH_cur, year_cur, mth_cur, day_cur, hour)
+    CALL ymds2ju(year_cur, 1, 1, 0., jD_1jan)
+    
+    jH_1jan = jD_1jan - int (jD_1jan)
+    jD_1jan = int (jD_1jan) 
+    xjour = jD_cur - jD_1jan
+    days_elapsed = jD_cur - jD_1jan
+
+    ! Get lenght of acutual month
+    mth_len = ioget_mon_len(year_cur,mth_cur)
+
+  END SUBROUTINE phys_cal_update
+
+END MODULE phys_cal_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_local_var_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_local_var_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_local_var_mod.F90	(revision 17)
@@ -0,0 +1,372 @@
+!
+! $Id: phys_local_var_mod.F90 1795 2013-07-18 08:20:28Z emillour $
+!
+      MODULE phys_local_var_mod
+
+! Variables locales pour effectuer les appels en serie
+!======================================================================
+!
+!
+!======================================================================
+! Declaration des variables
+
+      REAL, SAVE, ALLOCATABLE :: t_seri(:,:), q_seri(:,:)
+      !$OMP THREADPRIVATE(t_seri, q_seri)
+      REAL, SAVE, ALLOCATABLE :: ql_seri(:,:),qs_seri(:,:)
+      !$OMP THREADPRIVATE(ql_seri,qs_seri)
+      REAL, SAVE, ALLOCATABLE :: u_seri(:,:), v_seri(:,:)
+      !$OMP THREADPRIVATE(u_seri, v_seri)
+
+      REAL, SAVE, ALLOCATABLE :: tr_seri(:,:,:)
+      !$OMP THREADPRIVATE(tr_seri)
+      REAL, SAVE, ALLOCATABLE :: d_t_dyn(:,:), d_q_dyn(:,:)
+      !$OMP THREADPRIVATE(d_t_dyn, d_q_dyn)
+      REAL, SAVE, ALLOCATABLE :: d_u_dyn(:,:), d_v_dyn(:,:)
+      !$OMP THREADPRIVATE(d_u_dyn, d_v_dyn)
+!!!!
+      REAL, SAVE, ALLOCATABLE :: d_tr_dyn(:,:,:)
+      !$OMP THREADPRIVATE(d_tr_dyn)
+!!!!
+      REAL, SAVE, ALLOCATABLE :: d_t_con(:,:),d_q_con(:,:)
+      !$OMP THREADPRIVATE(d_t_con,d_q_con)
+      REAL, SAVE, ALLOCATABLE :: d_u_con(:,:),d_v_con(:,:)
+      !$OMP THREADPRIVATE(d_u_con,d_v_con)
+      REAL, SAVE, ALLOCATABLE :: d_t_wake(:,:),d_q_wake(:,:)
+      !$OMP THREADPRIVATE( d_t_wake,d_q_wake)
+      REAL, SAVE, ALLOCATABLE :: d_t_lsc(:,:),d_q_lsc(:,:),d_ql_lsc(:,:)
+      !$OMP THREADPRIVATE(d_t_lsc,d_q_lsc,d_ql_lsc)
+      REAL, SAVE, ALLOCATABLE :: d_t_ajsb(:,:), d_q_ajsb(:,:)
+      !$OMP THREADPRIVATE(d_t_ajsb, d_q_ajsb)
+      REAL, SAVE, ALLOCATABLE :: d_t_ajs(:,:), d_q_ajs(:,:)
+      !$OMP THREADPRIVATE(d_t_ajs, d_q_ajs)
+      REAL, SAVE, ALLOCATABLE :: d_u_ajs(:,:), d_v_ajs(:,:)
+      !$OMP THREADPRIVATE(d_u_ajs, d_v_ajs)
+      REAL, SAVE, ALLOCATABLE :: d_t_eva(:,:),d_q_eva(:,:)
+      !$OMP THREADPRIVATE(d_t_eva,d_q_eva)
+      REAL, SAVE, ALLOCATABLE :: d_t_lscst(:,:),d_q_lscst(:,:)
+      !$OMP THREADPRIVATE(d_t_lscst,d_q_lscst)
+      REAL, SAVE, ALLOCATABLE :: d_t_lscth(:,:),d_q_lscth(:,:)
+      !$OMP THREADPRIVATE(d_t_lscth,d_q_lscth)
+      REAL, SAVE, ALLOCATABLE :: plul_th(:),plul_st(:)
+      !$OMP THREADPRIVATE(plul_th,plul_st)
+!tendances dues a oro et lif
+      REAL, SAVE, ALLOCATABLE :: d_t_oli(:,:)
+      !$OMP THREADPRIVATE(d_t_oli)
+      REAL, SAVE, ALLOCATABLE :: d_u_oli(:,:), d_v_oli(:,:)
+      !$OMP THREADPRIVATE(d_u_oli, d_v_oli)
+      REAL, SAVE, ALLOCATABLE :: d_t_vdf(:,:), d_q_vdf(:,:), d_t_diss(:,:)
+      !$OMP THREADPRIVATE( d_t_vdf, d_q_vdf,d_t_diss)
+      REAL, SAVE, ALLOCATABLE :: d_u_vdf(:,:), d_v_vdf(:,:)
+      !$OMP THREADPRIVATE(d_u_vdf, d_v_vdf)
+      REAL, SAVE, ALLOCATABLE :: d_t_oro(:,:)
+      !$OMP THREADPRIVATE(d_t_oro)
+      REAL, SAVE, ALLOCATABLE :: d_u_oro(:,:), d_v_oro(:,:)
+      !$OMP THREADPRIVATE(d_u_oro, d_v_oro)
+      REAL, SAVE, ALLOCATABLE :: d_t_lif(:,:)
+      !$OMP THREADPRIVATE(d_t_lif)
+      REAL, SAVE, ALLOCATABLE :: d_u_lif(:,:), d_v_lif(:,:)
+      !$OMP THREADPRIVATE(d_u_lif, d_v_lif)
+! Tendances Ondes de G non oro (runs strato).
+      REAL, SAVE, ALLOCATABLE :: d_u_hin(:,:)
+      !$OMP THREADPRIVATE(d_u_hin)
+      REAL, SAVE, ALLOCATABLE :: d_v_hin(:,:)
+      !$OMP THREADPRIVATE(d_v_hin)
+      REAL, SAVE, ALLOCATABLE :: d_t_hin(:,:)
+      !$OMP THREADPRIVATE(d_t_hin)
+
+! tendance du a la conersion Ec -> E thermique
+      REAL, SAVE, ALLOCATABLE :: d_t_ec(:,:)
+      !$OMP THREADPRIVATE(d_t_ec)
+      REAL, SAVE, ALLOCATABLE :: d_ts(:,:), d_tr(:,:,:)
+      !$OMP THREADPRIVATE(d_ts, d_tr)
+
+! diagnostique pour le rayonnement
+      REAL, SAVE, ALLOCATABLE :: topswad_aero(:),  solswad_aero(:)      ! diag
+      !$OMP THREADPRIVATE(topswad_aero,solswad_aero)
+      REAL, SAVE, ALLOCATABLE :: topswai_aero(:),  solswai_aero(:)      ! diag
+      !$OMP THREADPRIVATE(topswai_aero,solswai_aero)
+      REAL, SAVE, ALLOCATABLE :: topswad0_aero(:), solswad0_aero(:)     ! diag
+      !$OMP THREADPRIVATE(topswad0_aero,solswad0_aero)
+      REAL, SAVE, ALLOCATABLE :: topsw_aero(:,:),  solsw_aero(:,:)      ! diag
+      !$OMP THREADPRIVATE(topsw_aero,solsw_aero)
+      REAL, SAVE, ALLOCATABLE :: topsw0_aero(:,:), solsw0_aero(:,:)     ! diag
+      !$OMP THREADPRIVATE(topsw0_aero,solsw0_aero)
+      REAL, SAVE, ALLOCATABLE :: topswcf_aero(:,:),  solswcf_aero(:,:)  ! diag
+      !$OMP THREADPRIVATE(topswcf_aero,solswcf_aero)
+      REAL, SAVE, ALLOCATABLE :: tausum_aero(:,:,:) 
+      !$OMP THREADPRIVATE(tausum_aero) 
+      REAL, SAVE, ALLOCATABLE :: tau3d_aero(:,:,:,:) 
+      !$OMP THREADPRIVATE(tau3d_aero) 
+      REAL, SAVE, ALLOCATABLE :: scdnc(:,:)
+      !$OMP THREADPRIVATE(scdnc)
+      REAL, SAVE, ALLOCATABLE :: cldncl(:)
+      !$OMP THREADPRIVATE(cldncl)
+      REAL, SAVE, ALLOCATABLE :: reffclwtop(:)
+      !$OMP THREADPRIVATE(reffclwtop)
+      REAL, SAVE, ALLOCATABLE :: lcc(:)
+      !$OMP THREADPRIVATE(lcc)
+      REAL, SAVE, ALLOCATABLE :: reffclws(:,:)
+      !$OMP THREADPRIVATE(reffclws)
+      REAL, SAVE, ALLOCATABLE :: reffclwc(:,:)
+      !$OMP THREADPRIVATE(reffclwc)
+      REAL, SAVE, ALLOCATABLE :: cldnvi(:) 
+      !$OMP THREADPRIVATE(cldnvi)
+      REAL, SAVE, ALLOCATABLE :: lcc3d(:,:)
+      !$OMP THREADPRIVATE(lcc3d)
+      REAL, SAVE, ALLOCATABLE :: lcc3dcon(:,:)
+      !$OMP THREADPRIVATE(lcc3dcon)
+      REAL, SAVE, ALLOCATABLE :: lcc3dstra(:,:)
+      !$OMP THREADPRIVATE(lcc3dstra)
+      REAL, SAVE, ALLOCATABLE :: od550aer(:) 
+      !$OMP THREADPRIVATE(od550aer) 
+      REAL, SAVE, ALLOCATABLE :: absvisaer(:) 
+      !$OMP THREADPRIVATE(absvisaer) 
+      REAL, SAVE, ALLOCATABLE :: od865aer(:) 
+      !$OMP THREADPRIVATE(od865aer) 
+      REAL, SAVE, ALLOCATABLE :: ec550aer(:,:) 
+      !$OMP THREADPRIVATE(ec550aer) 
+      REAL, SAVE, ALLOCATABLE :: od550lt1aer(:) 
+      !$OMP THREADPRIVATE(od550lt1aer) 
+      REAL, SAVE, ALLOCATABLE :: sconcso4(:) 
+      !$OMP THREADPRIVATE(sconcso4) 
+      REAL, SAVE, ALLOCATABLE :: sconcoa(:) 
+      !$OMP THREADPRIVATE(sconcoa) 
+      REAL, SAVE, ALLOCATABLE :: sconcbc(:) 
+      !$OMP THREADPRIVATE(sconcbc) 
+      REAL, SAVE, ALLOCATABLE :: sconcss(:) 
+      !$OMP THREADPRIVATE(sconcss) 
+      REAL, SAVE, ALLOCATABLE :: sconcdust(:) 
+      !$OMP THREADPRIVATE(sconcdust) 
+      REAL, SAVE, ALLOCATABLE :: concso4(:,:) 
+      !$OMP THREADPRIVATE(concso4) 
+      REAL, SAVE, ALLOCATABLE :: concoa(:,:) 
+      !$OMP THREADPRIVATE(concoa) 
+      REAL, SAVE, ALLOCATABLE :: concbc(:,:) 
+      !$OMP THREADPRIVATE(concbc) 
+      REAL, SAVE, ALLOCATABLE :: concss(:,:) 
+      !$OMP THREADPRIVATE(concss) 
+      REAL, SAVE, ALLOCATABLE :: concdust(:,:) 
+      !$OMP THREADPRIVATE(concdust) 
+      REAL, SAVE, ALLOCATABLE :: loadso4(:) 
+      !$OMP THREADPRIVATE(loadso4) 
+      REAL, SAVE, ALLOCATABLE :: loadoa(:) 
+      !$OMP THREADPRIVATE(loadoa) 
+      REAL, SAVE, ALLOCATABLE :: loadbc(:) 
+      !$OMP THREADPRIVATE(loadbc) 
+      REAL, SAVE, ALLOCATABLE :: loadss(:) 
+      !$OMP THREADPRIVATE(loadss) 
+      REAL, SAVE, ALLOCATABLE :: loaddust(:) 
+      !$OMP THREADPRIVATE(loaddust) 
+      REAL, SAVE, ALLOCATABLE :: load_tmp1(:) 
+      !$OMP THREADPRIVATE(load_tmp1) 
+      REAL, SAVE, ALLOCATABLE :: load_tmp2(:) 
+      !$OMP THREADPRIVATE(load_tmp2) 
+      REAL, SAVE, ALLOCATABLE :: load_tmp3(:) 
+      !$OMP THREADPRIVATE(load_tmp3) 
+      REAL, SAVE, ALLOCATABLE :: load_tmp4(:) 
+      !$OMP THREADPRIVATE(load_tmp4) 
+      REAL, SAVE, ALLOCATABLE :: load_tmp5(:) 
+      !$OMP THREADPRIVATE(load_tmp5) 
+      REAL, SAVE, ALLOCATABLE :: load_tmp6(:) 
+      !$OMP THREADPRIVATE(load_tmp6) 
+      REAL, SAVE, ALLOCATABLE :: load_tmp7(:) 
+      !$OMP THREADPRIVATE(load_tmp7) 
+
+!IM ajout variables CFMIP2/CMIP5
+      REAL,ALLOCATABLE,SAVE :: topswad_aerop(:), solswad_aerop(:)
+!$OMP THREADPRIVATE(topswad_aerop, solswad_aerop)
+      REAL,ALLOCATABLE,SAVE :: topswai_aerop(:), solswai_aerop(:)
+!$OMP THREADPRIVATE(topswai_aerop, solswai_aerop)
+      REAL,ALLOCATABLE,SAVE :: topswad0_aerop(:), solswad0_aerop(:)
+!$OMP THREADPRIVATE(topswad0_aerop, solswad0_aerop)
+      REAL,ALLOCATABLE,SAVE :: topsw_aerop(:,:), topsw0_aerop(:,:)  
+!$OMP THREADPRIVATE(topsw_aerop, topsw0_aerop)
+      REAL,ALLOCATABLE,SAVE :: solsw_aerop(:,:), solsw0_aerop(:,:)
+!$OMP THREADPRIVATE(solsw_aerop, solsw0_aerop)
+      REAL,ALLOCATABLE,SAVE :: topswcf_aerop(:,:), solswcf_aerop(:,:)
+!$OMP THREADPRIVATE(topswcf_aerop, solswcf_aerop)
+
+CONTAINS
+
+!======================================================================
+SUBROUTINE phys_local_var_init
+USE dimphy
+USE infotrac, ONLY : nbtr
+USE aero_mod
+USE indice_sol_mod
+
+IMPLICIT NONE
+      allocate(t_seri(klon,klev),q_seri(klon,klev),ql_seri(klon,klev),qs_seri(klon,klev))
+      allocate(u_seri(klon,klev),v_seri(klon,klev))
+
+      allocate(tr_seri(klon,klev,nbtr))
+      allocate(d_t_dyn(klon,klev),d_q_dyn(klon,klev))
+      allocate(d_u_dyn(klon,klev),d_v_dyn(klon,klev))
+      allocate(d_tr_dyn(klon,klev,nbtr))                   !RomP
+      allocate(d_t_con(klon,klev),d_q_con(klon,klev))
+      allocate(d_u_con(klon,klev),d_v_con(klon,klev))
+      allocate(d_t_wake(klon,klev),d_q_wake(klon,klev))
+      allocate(d_t_lsc(klon,klev),d_q_lsc(klon,klev))
+      allocate(d_ql_lsc(klon,klev))
+      allocate(d_t_ajsb(klon,klev),d_q_ajsb(klon,klev))
+      allocate(d_t_ajs(klon,klev),d_q_ajs(klon,klev))
+      allocate(d_u_ajs(klon,klev),d_v_ajs(klon,klev))
+      allocate(d_t_eva(klon,klev),d_q_eva(klon,klev))
+      allocate(d_t_lscst(klon,klev),d_q_lscst(klon,klev))
+      allocate(d_t_lscth(klon,klev),d_q_lscth(klon,klev))
+      allocate(plul_st(klon),plul_th(klon))
+      allocate(d_t_vdf(klon,klev),d_q_vdf(klon,klev),d_t_diss(klon,klev))
+      allocate(d_u_vdf(klon,klev),d_v_vdf(klon,klev))
+      allocate(d_t_oli(klon,klev),d_t_oro(klon,klev))
+      allocate(d_u_oli(klon,klev),d_v_oli(klon,klev))
+      allocate(d_u_oro(klon,klev),d_v_oro(klon,klev))
+      allocate(d_t_lif(klon,klev),d_t_ec(klon,klev))
+      allocate(d_u_lif(klon,klev),d_v_lif(klon,klev))
+      allocate(d_ts(klon,nbsrf), d_tr(klon,klev,nbtr))
+      allocate(topswad_aero(klon), solswad_aero(klon))
+      allocate(topswai_aero(klon), solswai_aero(klon))
+      allocate(topswad0_aero(klon), solswad0_aero(klon))
+      allocate(topsw_aero(klon,naero_grp), solsw_aero(klon,naero_grp))
+      allocate(topsw0_aero(klon,naero_grp), solsw0_aero(klon,naero_grp))
+      allocate(topswcf_aero(klon,3), solswcf_aero(klon,3))
+      allocate(d_u_hin(klon,klev),d_v_hin(klon,klev),d_t_hin(klon,klev))
+      allocate(tausum_aero(klon,nwave,naero_spc))
+      allocate(tau3d_aero(klon,klev,nwave,naero_spc)) 
+      allocate(scdnc(klon, klev))
+      allocate(cldncl(klon))
+      allocate(reffclwtop(klon))
+      allocate(lcc(klon))
+      allocate(reffclws(klon, klev))
+      allocate(reffclwc(klon, klev))
+      allocate(cldnvi(klon))
+      allocate(lcc3d(klon, klev))
+      allocate(lcc3dcon(klon, klev))
+      allocate(lcc3dstra(klon, klev))
+      allocate(od550aer(klon))	 
+      allocate(od865aer(klon))	 
+      allocate(absvisaer(klon))	 
+      allocate(ec550aer(klon,klev))
+      allocate(od550lt1aer(klon))	 	 
+      allocate(sconcso4(klon))
+      allocate(sconcoa(klon))
+      allocate(sconcbc(klon))
+      allocate(sconcss(klon))
+      allocate(sconcdust(klon))
+      allocate(concso4(klon,klev))
+      allocate(concoa(klon,klev))
+      allocate(concbc(klon,klev))
+      allocate(concss(klon,klev))
+      allocate(concdust(klon,klev))
+      allocate(loadso4(klon))
+      allocate(loadoa(klon))
+      allocate(loadbc(klon))
+      allocate(loadss(klon))
+      allocate(loaddust(klon))
+      allocate(load_tmp1(klon))
+      allocate(load_tmp2(klon))
+      allocate(load_tmp3(klon))
+      allocate(load_tmp4(klon))
+      allocate(load_tmp5(klon))
+      allocate(load_tmp6(klon))
+      allocate(load_tmp7(klon))
+
+!IM ajout variables CFMIP2/CMIP5
+      ALLOCATE(topswad_aerop(klon), solswad_aerop(klon))
+      ALLOCATE(topswai_aerop(klon), solswai_aerop(klon))
+      ALLOCATE(topswad0_aerop(klon), solswad0_aerop(klon))
+      ALLOCATE(topsw_aerop(klon,naero_grp), topsw0_aerop(klon,naero_grp))
+      ALLOCATE(solsw_aerop(klon,naero_grp), solsw0_aerop(klon,naero_grp))
+      ALLOCATE(topswcf_aerop(klon,naero_grp), solswcf_aerop(klon,naero_grp))
+
+END SUBROUTINE phys_local_var_init
+
+!======================================================================
+SUBROUTINE phys_local_var_end
+USE dimphy
+USE indice_sol_mod
+IMPLICIT NONE
+      deallocate(t_seri,q_seri,ql_seri,qs_seri)
+      deallocate(u_seri,v_seri)
+
+      deallocate(tr_seri)
+      deallocate(d_t_dyn,d_q_dyn)
+      deallocate(d_u_dyn,d_v_dyn)
+      deallocate(d_tr_dyn)                      !RomP
+      deallocate(d_t_con,d_q_con)
+      deallocate(d_u_con,d_v_con)
+      deallocate(d_t_wake,d_q_wake)
+      deallocate(d_t_lsc,d_q_lsc)
+      deallocate(d_ql_lsc)
+      deallocate(d_t_ajsb,d_q_ajsb)
+      deallocate(d_t_ajs,d_q_ajs)
+      deallocate(d_u_ajs,d_v_ajs)
+      deallocate(d_t_eva,d_q_eva)
+      deallocate(d_t_lscst,d_q_lscst)
+      deallocate(d_t_lscth,d_q_lscth)
+      deallocate(plul_st,plul_th)
+      deallocate(d_t_vdf,d_q_vdf,d_t_diss)
+      deallocate(d_u_vdf,d_v_vdf)
+      deallocate(d_t_oli,d_t_oro)
+      deallocate(d_u_oli,d_v_oli)
+      deallocate(d_u_oro,d_v_oro)
+      deallocate(d_t_lif,d_t_ec)
+      deallocate(d_u_lif,d_v_lif)
+      deallocate(d_ts, d_tr)
+      deallocate(topswad_aero,solswad_aero)
+      deallocate(topswai_aero,solswai_aero)
+      deallocate(topswad0_aero,solswad0_aero)
+      deallocate(topsw_aero,solsw_aero)
+      deallocate(topsw0_aero,solsw0_aero)
+      deallocate(topswcf_aero,solswcf_aero)
+      deallocate(tausum_aero) 
+      deallocate(tau3d_aero) 
+      deallocate(scdnc)
+      deallocate(cldncl)
+      deallocate(reffclwtop)
+      deallocate(lcc)
+      deallocate(reffclws)
+      deallocate(reffclwc)
+      deallocate(cldnvi)
+      deallocate(lcc3d)
+      deallocate(lcc3dcon)
+      deallocate(lcc3dstra)
+      deallocate(od550aer)	 
+      deallocate(od865aer)
+      deallocate(absvisaer)
+      deallocate(ec550aer)
+      deallocate(od550lt1aer)
+      deallocate(sconcso4) 
+      deallocate(sconcoa) 
+      deallocate(sconcbc) 
+      deallocate(sconcss) 
+      deallocate(sconcdust) 
+      deallocate(concso4) 
+      deallocate(concoa) 
+      deallocate(concbc) 
+      deallocate(concss) 
+      deallocate(concdust) 
+      deallocate(loadso4) 
+      deallocate(loadoa) 
+      deallocate(loadbc) 
+      deallocate(loadss) 
+      deallocate(loaddust) 
+      deallocate(load_tmp1)
+      deallocate(load_tmp2)
+      deallocate(load_tmp3)
+      deallocate(load_tmp4)
+      deallocate(load_tmp5)
+      deallocate(load_tmp6)
+      deallocate(load_tmp7)
+      deallocate(d_u_hin,d_v_hin,d_t_hin)
+
+!IM ajout variables CFMIP2/CMIP5
+      deallocate(topswad_aerop, solswad_aerop)
+      deallocate(topswai_aerop, solswai_aerop)
+      deallocate(topswad0_aerop, solswad0_aerop)
+      deallocate(topsw_aerop, topsw0_aerop)
+      deallocate(solsw_aerop, solsw0_aerop)
+      deallocate(topswcf_aerop, solswcf_aerop)
+
+END SUBROUTINE phys_local_var_end
+
+END MODULE phys_local_var_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_output_ctrlout_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_output_ctrlout_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_output_ctrlout_mod.F90	(revision 17)
@@ -0,0 +1,1119 @@
+MODULE phys_output_ctrlout_mod
+
+  USE phys_output_var_mod
+  USE indice_sol_mod
+  USE aero_mod, only : naero_spc,name_aero
+
+
+
+  IMPLICIT NONE
+      INTEGER, PRIVATE :: i
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Definition pour chaque variable du niveau d ecriture dans chaque fichier,
+!! de son nom, de sa description, de son unitÃ© et du type d'Ã©criture.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!/ histmth, histday, histhf, histins /),'!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  CHARACTER(len=20), dimension(nfiles) :: TEF = type_ecri_files
+
+!!! Comosantes de la coordonnee sigma-hybride
+!!! Ap et Bp
+  TYPE(ctrl_out), SAVE :: o_Ahyb = ctrl_out((/ 1, 1, 1, 1, 1, 1 /), &
+	'Ap', '', '', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_Bhyb = ctrl_out((/ 1, 1, 1, 1, 1, 1 /), &
+	'Bp', '', '', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_Alt = ctrl_out((/ 1, 1, 1, 1, 1, 1 /), &
+	'Alt', '', '', (/ ('', i=1, 6) /))
+
+!!! 1D
+  TYPE(ctrl_out), SAVE :: o_phis = ctrl_out((/ 1, 1, 10, 5, 1, 1 /), &
+	'phis', 'Surface geop.height', 'm2/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_aire = ctrl_out((/ 1, 1, 10,  10, 1, 1 /), &
+	'aire', 'Grid area', '-', (/ 'once', 'once', 'once', 'once', 'once', 'once' /))
+  TYPE(ctrl_out), SAVE :: o_contfracATM = ctrl_out((/ 10, 1,  1, 10, 10, 10 /), &
+	'contfracATM', '% sfce ter+lic', '-', &
+      (/ "once", "once", "once", "once", "once", "once" /))
+  TYPE(ctrl_out), SAVE :: o_contfracOR = ctrl_out((/ 10, 1,  1, 10, 10, 10 /), &
+	'contfracOR', '% sfce terre OR', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_aireTER = ctrl_out((/ 10, 10, 1, 10, 10, 10 /), &
+	'aireTER', 'Grid area CONT', '-', (/ ('', i=1, 6) /))
+
+!!! 2D
+  TYPE(ctrl_out), SAVE :: o_flat = ctrl_out((/ 5, 1, 10, 10, 5, 10 /), &
+	'flat', 'Latent heat flux', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_slp = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'slp', 'Sea Level Pressure', 'Pa', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tsol = ctrl_out((/ 1, 1, 1, 5, 10, 10 /), &
+	'tsol', 'Surface Temperature', 'K', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_t2m = ctrl_out((/ 1, 1, 1, 5, 10, 10 /), &
+	't2m', 'Temperature 2m', 'K', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_t2m_min = ctrl_out((/ 1, 1, 10, 10, 10, 10 /), &
+	't2m_min', 'Temp 2m min', 'K', &
+      (/ "t_min(X)", "t_min(X)", "t_min(X)", "t_min(X)", "t_min(X)", "t_min(X)" /))
+  TYPE(ctrl_out), SAVE :: o_t2m_max = ctrl_out((/ 1, 1, 10, 10, 10, 10 /), &
+	't2m_max', 'Temp 2m max', 'K', &
+      (/ "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)" /))
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_t2m_srf = (/ &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /), &
+	't2m_ter', "Temp 2m "//clnsurf(1), "K", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /), &
+	't2m_lic', "Temp 2m "//clnsurf(2), "K", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /), &
+	't2m_oce', "Temp 2m "//clnsurf(3), "K", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /), &
+	't2m_sic', "Temp 2m "//clnsurf(4), "K", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE :: o_wind10m = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'wind10m', '10-m wind speed', 'm/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_wind10max = ctrl_out((/ 10, 1, 10, 10, 10, 10 /), &
+	'wind10max', '10m wind speed max', 'm/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_sicf = ctrl_out((/ 1, 1, 10, 10, 10, 10 /), &
+	'sicf', 'Sea-ice fraction', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_q2m = ctrl_out((/ 1, 1, 1, 5, 10, 10 /), &
+	'q2m', 'Specific humidity 2m', 'kg/kg', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ustar = ctrl_out((/ 1, 1, 1, 5, 10, 10 /), &
+	'ustar', 'Friction velocity', 'm/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_u10m = ctrl_out((/ 1, 1, 1, 5, 10, 10 /), &
+	'u10m', 'Vent zonal 10m', 'm/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_v10m = ctrl_out((/ 1, 1, 1, 5, 10, 10 /), &
+	'v10m', 'Vent meridien 10m', 'm/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_psol = ctrl_out((/ 1, 1, 1, 5, 10, 10 /), &
+	'psol', 'Surface Pressure', 'Pa', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_qsurf = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'qsurf', 'Surface Air humidity', 'kg/kg', (/ ('', i=1, 6) /))
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_ustar_srf     = (/ &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'ustar_ter', &
+      "Friction velocity "//clnsurf(1),"m/s", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'ustar_lic', &
+      "Friction velocity "//clnsurf(2),"m/s", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'ustar_oce', &
+      "Friction velocity "//clnsurf(3),"m/s", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'ustar_sic', &
+      "Friction velocity "//clnsurf(4),"m/s", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_u10m_srf     = (/ &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'u10m_ter', &
+      "Vent Zonal 10m "//clnsurf(1),"m/s", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'u10m_lic', &
+      "Vent Zonal 10m "//clnsurf(2),"m/s", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'u10m_oce', &
+      "Vent Zonal 10m "//clnsurf(3),"m/s", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'u10m_sic', &
+      "Vent Zonal 10m "//clnsurf(4),"m/s", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_v10m_srf     = (/ &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'v10m_ter', &
+      "Vent meredien 10m "//clnsurf(1),"m/s", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'v10m_lic', &
+      "Vent meredien 10m "//clnsurf(2),"m/s", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'v10m_oce', &
+      "Vent meredien 10m "//clnsurf(3),"m/s", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 6, 10, 10, 10, 10 /),'v10m_sic', &
+      "Vent meredien 10m "//clnsurf(4),"m/s", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE :: o_qsol = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'qsol', 'Soil watter content', 'mm', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ndayrain = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'ndayrain', 'Number of dayrain(liq+sol)', '-', &
+      (/ "inst(X)", "inst(X)", "inst(X)", "inst(X)", "inst(X)", "inst(X)" /))
+  TYPE(ctrl_out), SAVE :: o_precip = ctrl_out((/ 1, 1, 1, 10, 5, 10 /), &
+	'precip', 'Precip Totale liq+sol', 'kg/(s*m2)', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_plul = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'plul', 'Large-scale Precip.', 'kg/(s*m2)', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_pluc = ctrl_out((/ 1, 1, 1, 10, 5, 10 /), &
+	'pluc', 'Convective Precip.', 'kg/(s*m2)', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_snow = ctrl_out((/ 1, 1, 10, 10, 5, 10 /), &
+	'snow', 'Snow fall', 'kg/(s*m2)', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_evap = ctrl_out((/ 1, 1, 10, 10, 10, 10 /), &
+	'evap', 'Evaporat', 'kg/(s*m2)', (/ ('', i=1, 6) /))
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_evap_srf     = (/ &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'evap_ter', &
+      "evaporation at surface "//clnsurf(1),"kg/(s*m2)", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'evap_lic', &
+      "evaporation at surface "//clnsurf(2),"kg/(s*m2)", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'evap_oce', &
+      "evaporation at surface "//clnsurf(3),"kg/(s*m2)", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'evap_sic', &
+      "evaporation at surface "//clnsurf(4),"kg/(s*m2)", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE :: o_msnow = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'msnow', 'Surface snow amount', 'kg/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_fsnow = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'fsnow', 'Surface snow area fraction', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tops = ctrl_out((/ 1, 1, 10, 10, 10, 10 /), &
+	'tops', 'Solar rad. at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tops0 = ctrl_out((/ 1, 5, 10, 10, 10, 10 /), &
+	'tops0', 'CS Solar rad. at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_topl = ctrl_out((/ 1, 1, 10, 5, 10, 10 /), &
+	'topl', 'IR rad. at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_topl0 = ctrl_out((/ 1, 5, 10, 10, 10, 10 /), &
+	'topl0', 'IR rad. at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_SWupTOA = ctrl_out((/ 1, 4, 10, 10, 10, 10 /), &
+	'SWupTOA', 'SWup at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_SWupTOAclr = ctrl_out((/ 1, 4, 10, 10, 10, 10 /), &
+	'SWupTOAclr', 'SWup clear sky at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_SWdnTOA = ctrl_out((/ 1, 4, 10, 10, 10, 10 /), &
+	'SWdnTOA', 'SWdn at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_SWdnTOAclr = ctrl_out((/ 1, 4, 10, 10, 10, 10 /), &
+	'SWdnTOAclr', 'SWdn clear sky at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_nettop = ctrl_out((/ 1, 4, 10, 10, 10, 10 /), &
+	'nettop', 'Net dn radiatif flux at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_SWup200 = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'SWup200', 'SWup at 200mb', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_SWup200clr = ctrl_out((/ 10, 1, 10, 10, 10, 10 /), &
+	'SWup200clr', 'SWup clear sky at 200mb', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_SWdn200 = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'SWdn200', 'SWdn at 200mb', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_SWdn200clr = ctrl_out((/ 10, 1, 10, 10, 10, 10 /), &
+	'SWdn200clr', 'SWdn clear sky at 200mb', 'W/m2', (/ ('', i=1, 6) /))
+
+  ! arajouter
+  !  type(ctrl_out),save :: o_LWupTOA     = ctrl_out((/ 1, 4, 10, 10, 10, 10 /),'LWupTOA', &
+  !	(/ ('', i=1, 6) /))
+  !  type(ctrl_out),save :: o_LWupTOAclr  = ctrl_out((/ 1, 4, 10, 10, 10, 10 /),'LWupTOAclr', &
+  !	(/ ('', i=1, 6) /))
+  !  type(ctrl_out),save :: o_LWdnTOA     = ctrl_out((/ 1, 4, 10, 10, 10, 10 /),'LWdnTOA', &
+  !	(/ ('', i=1, 6) /))
+  !  type(ctrl_out),save :: o_LWdnTOAclr  = ctrl_out((/ 1, 4, 10, 10, 10, 10 /),'LWdnTOAclr', &
+  !	(/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_LWup200 = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'LWup200', 'LWup at 200mb', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_LWup200clr = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'LWup200clr', 'LWup clear sky at 200mb', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_LWdn200 = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'LWdn200', 'LWdn at 200mb', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_LWdn200clr = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'LWdn200clr', 'LWdn clear sky at 200mb', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_sols = ctrl_out((/ 1, 1, 10, 10, 10, 10 /), &
+	'sols', 'Solar rad. at surf.', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_sols0 = ctrl_out((/ 1, 5, 10, 10, 10, 10 /), &
+	'sols0', 'Solar rad. at surf.', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_soll = ctrl_out((/ 1, 1, 10, 10, 10, 10 /), &
+	'soll', 'IR rad. at surface', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_soll0 = ctrl_out((/ 1, 5, 10, 10, 10, 10 /), &
+	'soll0', 'IR rad. at surface', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_radsol = ctrl_out((/ 1, 7, 10, 10, 10, 10 /), &
+	'radsol', 'Rayonnement au sol', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_SWupSFC = ctrl_out((/ 1, 4, 10, 10, 5, 10 /), &
+	'SWupSFC', 'SWup at surface', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_SWupSFCclr = ctrl_out((/ 1, 4, 10, 10, 5, 10 /), &
+	'SWupSFCclr', 'SWup clear sky at surface', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_SWdnSFC = ctrl_out((/ 1, 1, 10, 10, 5, 10 /), &
+	'SWdnSFC', 'SWdn at surface', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_SWdnSFCclr = ctrl_out((/ 1, 4, 10, 10, 5, 10 /), &
+	'SWdnSFCclr', 'SWdn clear sky at surface', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_LWupSFC = ctrl_out((/ 1, 4, 10, 10, 5, 10 /), &
+	'LWupSFC', 'Upwd. IR rad. at surface', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_LWupSFCclr = ctrl_out((/ 1, 4, 10, 10, 5, 10 /), &
+	'LWupSFCclr', 'CS Upwd. IR rad. at surface', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_LWdnSFC = ctrl_out((/ 1, 4, 10, 10, 5, 10 /), &
+	'LWdnSFC', 'Down. IR rad. at surface', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_LWdnSFCclr = ctrl_out((/ 1, 4, 10, 10, 5, 10 /), &
+	'LWdnSFCclr', 'Down. CS IR rad. at surface', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_bils = ctrl_out((/ 1, 2, 10, 5, 10, 10 /), &
+	'bils', 'Surf. total heat flux', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_bils_tke = ctrl_out((/ 1, 2, 10, 5, 10, 10 /), &
+	'bils_tke', 'Surf. total heat flux', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_bils_diss = ctrl_out((/ 1, 2, 10, 5, 10, 10 /), &
+	'bils_diss', 'Surf. total heat flux', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_bils_ec = ctrl_out((/ 1, 2, 10, 5, 10, 10 /), &
+	'bils_ec', 'Surf. total heat flux', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_bils_kinetic = ctrl_out((/ 1, 2, 10, 5, 10, 10 /), &
+	'bils_kinetic', 'Surf. total heat flux', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_bils_enthalp = ctrl_out((/ 1, 2, 10, 5, 10, 10 /), &
+	'bils_enthalp', 'Surf. total heat flux', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_bils_latent = ctrl_out((/ 1, 2, 10, 5, 10, 10 /), &
+	'bils_latent', 'Surf. total heat flux', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_sens = ctrl_out((/ 1, 1, 10, 10, 5, 10 /), &
+	'sens', 'Sensible heat flux', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_fder = ctrl_out((/ 1, 2, 10, 10, 10, 10 /), &
+	'fder', 'Heat flux derivation', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ffonte = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'ffonte', 'Thermal flux for snow melting', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_fqcalving = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'fqcalving', 'Ice Calving', 'kg/m2/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_fqfonte = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'fqfonte', 'Land ice melt', 'kg/m2/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_taux = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'taux', 'Zonal wind stress', 'Pa', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tauy = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'tauy', 'Meridional wind stress', 'Pa', (/ ('', i=1, 6) /))
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_taux_srf = (/           &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'taux_ter',             &
+      "Zonal wind stress"//clnsurf(1), "Pa", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'taux_lic',             &
+      "Zonal wind stress"//clnsurf(2), "Pa", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'taux_oce',             &
+      "Zonal wind stress"//clnsurf(3), "Pa", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'taux_sic',             &
+      "Zonal wind stress"//clnsurf(4), "Pa", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_tauy_srf     = (/             &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tauy_ter',                   &
+      "Meridional wind stress "//clnsurf(1),"Pa", (/ ('', i=1, 6) /)),  &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tauy_lic',                   &
+      "Meridional wind stress "//clnsurf(2),"Pa", (/ ('', i=1, 6) /)),  &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tauy_oce',                   &
+      "Meridional wind stress "//clnsurf(3),"Pa", (/ ('', i=1, 6) /)),  &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tauy_sic',                   &
+      "Meridional wind stress "//clnsurf(4),"Pa", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_pourc_srf    = (/ &
+      ctrl_out((/ 1, 7, 10, 10, 10, 10 /),'pourc_ter',      &
+      "% "//clnsurf(1),"%", (/ ('', i=1, 6) /)),            &
+      ctrl_out((/ 1, 7, 10, 10, 10, 10 /),'pourc_lic',      &
+      "% "//clnsurf(2),"%", (/ ('', i=1, 6) /)),            &
+      ctrl_out((/ 1, 7, 10, 10, 10, 10 /),'pourc_oce',      &
+      "% "//clnsurf(3),"%", (/ ('', i=1, 6) /)),            &
+      ctrl_out((/ 1, 7, 10, 10, 10, 10 /),'pourc_sic',      &
+      "% "//clnsurf(4),"%", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_fract_srf    = (/ &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'fract_ter',      &
+      "Fraction "//clnsurf(1),"1", (/ ('', i=1, 6) /)),     &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'fract_lic',      &
+      "Fraction "//clnsurf(2),"1", (/ ('', i=1, 6) /)),     &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'fract_oce',      &
+      "Fraction "//clnsurf(3),"1", (/ ('', i=1, 6) /)),     &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'fract_sic',      &
+      "Fraction "//clnsurf(4),"1", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_tsol_srf     = (/ &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tsol_ter',       &
+      "Temperature "//clnsurf(1),"K", (/ ('', i=1, 6) /)),  &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tsol_lic',       &
+      "Temperature "//clnsurf(2),"K", (/ ('', i=1, 6) /)),  &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tsol_oce',       &
+      "Temperature "//clnsurf(3),"K", (/ ('', i=1, 6) /)),  &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'tsol_sic',       &
+      "Temperature "//clnsurf(4),"K", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_evappot_srf  = (/ &
+      ctrl_out((/ 1, 6, 10, 10, 10, 10 /),'evappot_ter',    &
+      "Temperature"//clnsurf(1),"K", (/ ('', i=1, 6) /)),   &
+      ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'evappot_lic',    &
+      "Temperature"//clnsurf(2),"K", (/ ('', i=1, 6) /)),   &
+      ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'evappot_oce',    &
+      "Temperature"//clnsurf(3),"K", (/ ('', i=1, 6) /)),   &
+      ctrl_out((/ 4, 6, 10, 10, 10, 10 /),'evappot_sic',    &
+      "Temperature"//clnsurf(4),"K", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_sens_srf     = (/          &
+      ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'sens_ter',                 &
+      "Sensible heat flux "//clnsurf(1),"W/m2", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'sens_lic',                 &
+      "Sensible heat flux "//clnsurf(2),"W/m2", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'sens_oce',                 &
+      "Sensible heat flux "//clnsurf(3),"W/m2", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'sens_sic',                 &
+      "Sensible heat flux "//clnsurf(4),"W/m2", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_lat_srf      = (/        &
+      ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'lat_ter',                &
+      "Latent heat flux "//clnsurf(1),"W/m2", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'lat_lic',                &
+      "Latent heat flux "//clnsurf(2),"W/m2", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'lat_oce',                &
+      "Latent heat flux "//clnsurf(3),"W/m2", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 6, 10, 7, 10, 10 /),'lat_sic',                &
+      "Latent heat flux "//clnsurf(4),"W/m2", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_flw_srf      = (/ &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'flw_ter',       &
+      "LW "//clnsurf(1),"W/m2", (/ ('', i=1, 6) /)),        &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'flw_lic',       &
+      "LW "//clnsurf(2),"W/m2", (/ ('', i=1, 6) /)),        &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'flw_oce',       &
+      "LW "//clnsurf(3),"W/m2", (/ ('', i=1, 6) /)),        &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'flw_sic',       &
+      "LW "//clnsurf(4),"W/m2", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_fsw_srf      = (/ &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'fsw_ter',       &
+      "SW "//clnsurf(1),"W/m2", (/ ('', i=1, 6) /)),        &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'fsw_lic',       &
+      "SW "//clnsurf(2),"W/m2", (/ ('', i=1, 6) /)),        &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'fsw_oce',       &
+      "SW "//clnsurf(3),"W/m2", (/ ('', i=1, 6) /)),        &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'fsw_sic',       &
+      "SW "//clnsurf(4),"W/m2", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_wbils_srf    = (/ &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbils_ter',     &
+      "Bilan sol "//clnsurf(1),"W/m2", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbils_lic',     &
+      "Bilan sol "//clnsurf(2),"W/m2", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbils_oce',     &
+      "Bilan sol "//clnsurf(3),"W/m2", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbils_sic',     &
+      "Bilan sol "//clnsurf(4),"W/m2", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_wbilo_srf    = (/      &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbilo_ter',          &
+      "Bilan eau "//clnsurf(1),"kg/(m2*s)", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbilo_lic',          &
+      "Bilan eau "//clnsurf(2),"kg/(m2*s)", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbilo_oce',          &
+      "Bilan eau "//clnsurf(3),"kg/(m2*s)", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'wbilo_sic',          &
+      "Bilan eau "//clnsurf(4),"kg/(m2*s)", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE :: o_cdrm = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'cdrm', 'Momentum drag coef.', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_cdrh = ctrl_out((/ 1, 10, 10, 7, 10, 10 /), &
+	'cdrh', 'Heat drag coef.', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_cldl = ctrl_out((/ 1, 1, 10, 10, 10, 10 /), &
+	'cldl', 'Low-level cloudiness', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_cldm = ctrl_out((/ 1, 1, 10, 10, 10, 10 /), &
+	'cldm', 'Mid-level cloudiness', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_cldh = ctrl_out((/ 1, 1, 10, 10, 10, 10 /), &
+	'cldh', 'High-level cloudiness', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_cldt = ctrl_out((/ 1, 1, 2, 10, 5, 10 /), &
+	'cldt', 'Total cloudiness', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_cldq = ctrl_out((/ 1, 1, 10, 10, 10, 10 /), &
+	'cldq', 'Cloud liquid water path', 'kg/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_lwp = ctrl_out((/ 1, 5, 10, 10, 10, 10 /), &
+	'lwp', 'Cloud water path', 'kg/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_iwp = ctrl_out((/ 1, 5, 10, 10, 10, 10 /), &
+	'iwp', 'Cloud ice water path', 'kg/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ue = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'ue', 'Zonal energy transport', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ve = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	've', 'Merid energy transport', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_uq = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'uq', 'Zonal humidity transport', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_vq = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'vq', 'Merid humidity transport', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_cape = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'cape', 'Conv avlbl pot ener', 'J/kg', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_pbase = ctrl_out((/ 1, 5, 10, 10, 10, 10 /), &
+	'pbase', 'Cld base pressure', 'Pa', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ptop = ctrl_out((/ 1, 5, 10, 10, 10, 10 /), &
+	'ptop', 'Cld top pressure', 'Pa', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_fbase = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'fbase', 'Cld base mass flux', 'kg/m2/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_plcl = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'plcl', 'Lifting Condensation Level', 'hPa', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_plfc = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'plfc', 'Level of Free Convection', 'hPa', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_wbeff = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	'wbeff', 'Conv. updraft velocity at LFC (<100)', 'm/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_prw = ctrl_out((/ 1, 1, 10, 10, 10, 10 /), &
+	'prw', 'Precipitable water', 'kg/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_s_pblh = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	's_pblh', 'Boundary Layer Height', 'm', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_s_pblt = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	's_pblt', 't at Boundary Layer Height', 'K', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_s_lcl = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	's_lcl', 'Condensation level', 'm', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_s_therm = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	's_therm', 'Exces du thermique', 'K', (/ ('', i=1, 6) /))
+  !IM : Les champs suivants (s_capCL, s_oliqCL, s_cteiCL, s_trmb1, s_trmb2, s_trmb3) ne sont pas definis dans HBTM.F
+  ! type(ctrl_out),save :: o_s_capCL      = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_capCL', &
+!	(/ ('', i=1, 6) /))
+  ! type(ctrl_out),save :: o_s_oliqCL     = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_oliqCL', &
+!	(/ ('', i=1, 6) /))
+  ! type(ctrl_out),save :: o_s_cteiCL     = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_cteiCL', &
+!	(/ ('', i=1, 6) /))
+  ! type(ctrl_out),save :: o_s_trmb1      = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_trmb1', &
+!	(/ ('', i=1, 6) /))
+  ! type(ctrl_out),save :: o_s_trmb2      = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_trmb2', &
+!	(/ ('', i=1, 6) /))
+  ! type(ctrl_out),save :: o_s_trmb3      = ctrl_out((/ 1, 10, 10, 10, 10, 10 /),'s_trmb3', &
+	!(/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_slab_bils = ctrl_out((/ 1, 1, 10, 10, 10, 10 /), &
+	'slab_bils_oce', 'Bilan au sol sur ocean slab', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ale_bl = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'ale_bl', 'ALE BL', 'm2/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_alp_bl = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'alp_bl', 'ALP BL', 'm2/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ale_wk = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'ale_wk', 'ALE WK', 'm2/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_alp_wk = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'alp_wk', 'ALP WK', 'm2/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ale = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'ale', 'ALE', 'm2/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_alp = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'alp', 'ALP', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_cin = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'cin', 'Convective INhibition', 'm2/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_wape = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'wape', '', '', (/ ('', i=1, 6) /))
+
+!!! nrlmd le 10/04/2012
+
+!-------Spectre de thermiques de type 2 au LCL
+  TYPE(ctrl_out), SAVE :: o_n2 = ctrl_out((/ 1, 1, 1, 6, 10, 10 /), &
+	'n2', 'Nombre de panaches de type 2', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_s2 = ctrl_out((/ 1, 1, 1, 6, 10, 10 /), &
+	's2', 'Surface moyenne des panaches de type 2', 'm2', (/ ('', i=1, 6) /))
+                                                                             
+!-------DÃ©clenchement stochastique                                           
+  TYPE(ctrl_out), SAVE :: o_proba_notrig = ctrl_out((/ 1, 1, 1, 6, 10, 10 /), &
+	'proba_notrig', &
+                         'ProbabilitÃ© de non-dÃ©clenchement', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_random_notrig = ctrl_out((/ 1, 1, 1, 6, 10, 10 /), &
+	'random_notrig', &
+                         'Tirage alÃ©atoire de non-dÃ©clenchement', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ale_bl_stat = ctrl_out((/ 1, 1, 1, 6, 10, 10 /), &
+	'ale_bl_stat', &
+       'ALE_BL_STAT', 'm2/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ale_bl_trig = ctrl_out((/ 1, 1, 1, 6, 10, 10 /), &
+	'ale_bl_trig', &
+       'ALE_BL_STAT + Condition P>Pseuil', 'm2/s2', (/ ('', i=1, 6) /))
+
+!-------Fermeture statistique
+  TYPE(ctrl_out), SAVE :: o_alp_bl_det = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'alp_bl_det', 'ALP_BL_DET', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_alp_bl_fluct_m = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'alp_bl_fluct_m', 'ALP_BL_FLUCT_M', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_alp_bl_fluct_tke = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'alp_bl_fluct_tke', 'ALP_BL_FLUCT_TKE', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_alp_bl_conv = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'alp_bl_conv', 'ALP_BL_CONV', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_alp_bl_stat = ctrl_out((/ 1, 1, 1, 10, 10, 10 /), &
+	'alp_bl_stat', 'ALP_BL_STAT', 'W/m2', (/ ('', i=1, 6) /))
+
+!!! fin nrlmd le 10/04/2012
+
+  ! Champs interpolles sur des niveaux de pression ??? a faire correctement
+
+  TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_uSTDlevs     = (/                    &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u850', "Zonal wind 1hPa", "m/s",     &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u700', "Zonal wind 2hPa", "m/s",     &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u500', "Zonal wind 3hPa", "m/s",     &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u200', "Zonal wind 4hPa", "m/s",     &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u100', "Zonal wind 5hPa", "m/s",     &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u50', "Zonal wind 6hPa", "m/s",     &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'u10', "Zonal wind 7hPa", "m/s",     &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_vSTDlevs     = (/                     &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v850', "Meridional wind 1hPa", "m/s", &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)),  &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v700', "Meridional wind 2hPa", "m/s", &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)),  &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v500', "Meridional wind 3hPa", "m/s", &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)),  &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v200', "Meridional wind 4hPa", "m/s", &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)),  &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v100', "Meridional wind 5hPa", "m/s", &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)),  &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v50', "Meridional wind 6hPa", "m/s",  &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)),  &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'v10', "Meridional wind 7hPa", "m/s",  &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_wSTDlevs     = (/                    &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w850', "Vertical wind 1hPa", "Pa/s", &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w700', "Vertical wind 2hPa", "Pa/s", &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w500', "Vertical wind 3hPa", "Pa/s", &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w200', "Vertical wind 4hPa", "Pa/s", &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w100', "Vertical wind 5hPa", "Pa/s", &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w50', "Vertical wind 6hPa", "Pa/s",  &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'w10', "Vertical wind 7hPa", "Pa/s",  &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_tSTDlevs     = (/                    &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t850', "Temperature 1hPa", "K",      &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t700', "Temperature 2hPa", "K",      &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t500', "Temperature 3hPa", "K",      &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t200', "Temperature 4hPa", "K",      &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t100', "Temperature 5hPa", "K",      &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t50',  "Temperature 6hPa", "K",      &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'t10',  "Temperature 7hPa", "K",      &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_qSTDlevs     = (/                             &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q850', "Specific humidity 1hPa",              &
+      "kg/kg", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q700', "Specific humidity 2hPa",              &
+      "kg/kg", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q500', "Specific humidity 3hPa",              &
+      "kg/kg", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q200', "Specific humidity 4hPa",              &
+      "kg/kg", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q100', "Specific humidity 5hPa",              &
+      "kg/kg", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q50', "Specific humidity 6hPa",               &
+      "kg/kg", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'q10', "Specific humidity 7hPa",               &
+      "kg/kg", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(7) :: o_zSTDlevs   = (/                           &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z850', "Geopotential height 1hPa",        &
+      "m", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z700', "Geopotential height 2hPa",        &
+      "m", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z500', "Geopotential height 3hPa",        &
+      "m", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z200', "Geopotential height 4hPa",        &
+      "m", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z100', "Geopotential height 5hPa",        &
+      "m", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z50', "Geopotential height 6hPa",         &
+      "m", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)), &
+      ctrl_out((/ 1, 7, 7, 10, 10, 10 /),'z10', "Geopotential height 7hPa",         &
+      "m", (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /)) /)
+
+  TYPE(ctrl_out), SAVE :: o_t_oce_sic = ctrl_out((/ 1, 10, 10, 10, 10, 10 /), &
+	't_oce_sic', 'Temp mixte oce-sic', 'K', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_weakinv = ctrl_out((/ 10, 1, 10, 10, 10, 10 /), &
+	'weakinv', 'Weak inversion', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dthmin = ctrl_out((/ 10, 1, 10, 10, 10, 10 /), &
+	'dthmin', 'dTheta mini', 'K/m', (/ ('', i=1, 6) /))
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_u10_srf      = (/ &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'u10_ter', "", "", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'u10_lic', "", "", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'u10_oce', "", "", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'u10_sic', "", "", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_v10_srf      = (/ &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'v10_ter', "", "", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'v10_lic', "", "", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'v10_oce', "", "", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'v10_sic', "", "", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE :: o_cldtau = ctrl_out((/ 10, 5, 10, 10, 10, 10 /), &
+	'cldtau', 'Cloud optical thickness', '1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_cldemi = ctrl_out((/ 10, 5, 10, 10, 10, 10 /), &
+	'cldemi', 'Cloud optical emissivity', '1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rh2m = ctrl_out((/ 5, 5, 10, 10, 10, 10 /), &
+	'rh2m', 'Relative humidity at 2m', '%', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rh2m_min = ctrl_out((/ 10, 5, 10, 10, 10, 10 /), &
+	'rh2m_min', 'Min Relative humidity at 2m', '%',                        &
+      (/ 't_min(X)', 't_min(X)', 't_min(X)', 't_min(X)', 't_min(X)', 't_min(X)' /))
+  TYPE(ctrl_out), SAVE :: o_rh2m_max = ctrl_out((/ 10, 5, 10, 10, 10, 10 /), &
+	'rh2m_max', 'Max Relative humidity at 2m', '%',                        &
+      (/ 't_max(X)', 't_max(X)', 't_max(X)', 't_max(X)', 't_max(X)', 't_max(X)' /))
+  TYPE(ctrl_out), SAVE :: o_qsat2m = ctrl_out((/ 10, 5, 10, 10, 10, 10 /), &
+	'qsat2m', 'Saturant humidity at 2m', '%', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tpot = ctrl_out((/ 10, 5, 10, 10, 10, 10 /), &
+	'tpot', 'Surface air potential temperature', 'K', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tpote = ctrl_out((/ 10, 5, 10, 10, 10, 10 /), &
+	'tpote', &
+      'Surface air equivalent potential temperature', 'K', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tke = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'tke ', 'TKE', 'm2/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tke_max = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'tke_max', 'TKE max', 'm2/s2',                                        &
+      (/ 't_max(X)', 't_max(X)', 't_max(X)', 't_max(X)', 't_max(X)', 't_max(X)' /))
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_tke_srf      = (/             &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_ter',                   &
+      "Max Turb. Kinetic Energy "//clnsurf(1),"-", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_lic',                   &
+      "Max Turb. Kinetic Energy "//clnsurf(2),"-", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_oce',                   &
+      "Max Turb. Kinetic Energy "//clnsurf(3),"-", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_sic',                   &
+      "Max Turb. Kinetic Energy "//clnsurf(4),"-", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_tke_max_srf  = (/                                  &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_max_ter',                                    &
+      "Max Turb. Kinetic Energy "//clnsurf(1),"-",                                           &
+      (/ "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)" /)), &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_max_lic',                                    &
+      "Max Turb. Kinetic Energy "//clnsurf(2),"-",                                           &
+      (/ "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)" /)), &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_max_oce',                                    &
+      "Max Turb. Kinetic Energy "//clnsurf(3),"-",                                           &
+      (/ "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)" /)), &
+      ctrl_out((/ 10, 4, 10, 10, 10, 10 /),'tke_max_sic',                                    &
+      "Max Turb. Kinetic Energy "//clnsurf(4),"-",                                           &
+      (/ "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)" /)) /)
+
+  TYPE(ctrl_out), SAVE :: o_kz = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'kz', 'Kz melange', 'm2/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_kz_max = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'kz_max', 'Kz melange max', 'm2/s',                                  &
+      (/ 't_max(X)', 't_max(X)', 't_max(X)', 't_max(X)', 't_max(X)', 't_max(X)' /))
+  TYPE(ctrl_out), SAVE :: o_SWnetOR = ctrl_out((/ 10, 10, 2, 10, 10, 10 /), &
+	'SWnetOR', 'Sfce net SW radiation OR', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_SWdownOR = ctrl_out((/ 10, 10, 2, 10, 10, 10 /), &
+	'SWdownOR', 'Sfce incident SW radiation OR', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_LWdownOR = ctrl_out((/ 10, 10, 2, 10, 10, 10 /), &
+	'LWdownOR', 'Sfce incident LW radiation OR', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_snowl = ctrl_out((/ 10, 1, 10, 10, 10, 10 /), &
+	'snowl', 'Solid Large-scale Precip.', 'kg/(m2*s)', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_cape_max = ctrl_out((/ 10, 1, 10, 10, 10, 10 /), &
+	'cape_max', 'CAPE max.', 'J/kg',                                       &
+      (/ "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)", "t_max(X)" /))
+  TYPE(ctrl_out), SAVE :: o_solldown = ctrl_out((/ 10, 1, 10, 10, 10, 10 /), &
+	'solldown', 'Down. IR rad. at surface', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtsvdfo = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'dtsvdfo', 'Boundary-layer dTs(o)', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtsvdft = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'dtsvdft', 'Boundary-layer dTs(t)', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtsvdfg = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'dtsvdfg', 'Boundary-layer dTs(g)', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtsvdfi = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'dtsvdfi', 'Boundary-layer dTs(g)', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rugs = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'rugs', 'rugosity', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_topswad = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'topswad', 'ADE at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_topswad0 = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'topswad0', 'ADE clear-sky at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_topswai = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'topswai', 'AIE at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_solswad = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'solswad', 'ADE at SRF', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_solswad0 = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'solswad0', 'ADE clear-sky at SRF', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_solswai = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'solswai', 'AIE at SFR', 'W/m2', (/ ('', i=1, 6) /))
+
+!  type(ctrl_out),save,dimension(10) :: o_tausumaero  = (/ ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_ASBCM', &
+!	(/ ('', i=1, 6) /)), &
+  type(ctrl_out),save,dimension(11) :: o_tausumaero  =                           & 
+    (/ ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_ASBCM',                        &
+      "Aerosol Optical depth at 550 nm "//name_aero(1),"1", (/ ('', i=1, 6) /)), &
+       ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_ASPOMM',                       &
+      "Aerosol Optical depth at 550 nm "//name_aero(2),"1", (/ ('', i=1, 6) /)), &
+       ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_ASSO4M',                       &
+      "Aerosol Optical depth at 550 nm "//name_aero(3),"1", (/ ('', i=1, 6) /)), &
+       ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_CSSO4M',                       &
+      "Aerosol Optical depth at 550 nm "//name_aero(4),"1", (/ ('', i=1, 6) /)), &
+       ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_SSSSM',                        &
+      "Aerosol Optical depth at 550 nm "//name_aero(5),"1", (/ ('', i=1, 6) /)), &
+       ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_ASSSM',                        &
+      "Aerosol Optical depth at 550 nm "//name_aero(6),"1", (/ ('', i=1, 6) /)), &
+       ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_CSSSM',                        &
+      "Aerosol Optical depth at 550 nm "//name_aero(7),"1", (/ ('', i=1, 6) /)), &
+       ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_CIDUSTM',                      &
+      "Aerosol Optical depth at 550 nm "//name_aero(8),"1", (/ ('', i=1, 6) /)), &
+       ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_AIBCM',                        &
+      "Aerosol Optical depth at 550 nm "//name_aero(9),"1", (/ ('', i=1, 6) /)), &
+       ctrl_out((/ 2, 6, 10, 10, 10, 10 /),'OD550_AIPOMM',                       &
+      "Aerosol Optical depth at 550 nm "//name_aero(10),"1", (/ ('', i=1, 6) /)),&
+       ctrl_out((/ 2, 2, 10, 10, 10, 10 /),'OD550_STRAT',                        &
+      "Aerosol Optical depth at 550 nm "//name_aero(11),"1", (/ ('', i=1, 6) /)) /)
+  TYPE(ctrl_out), SAVE :: o_od550aer = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'od550aer', 'Total aerosol optical depth at 550nm', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_od865aer = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'od865aer', 'Total aerosol optical depth at 870nm', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_absvisaer = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'absvisaer', 'Absorption aerosol visible optical depth', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_od550lt1aer = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'od550lt1aer', 'Fine mode optical depth', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_sconcso4 = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'sconcso4', 'Surface Concentration of Sulfate ', 'kg/m3', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_sconcoa = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'sconcoa', 'Surface Concentration of Organic Aerosol ', 'kg/m3', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_sconcbc = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'sconcbc', 'Surface Concentration of Black Carbon ', 'kg/m3', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_sconcss = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'sconcss', 'Surface Concentration of Sea Salt ', 'kg/m3', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_sconcdust = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'sconcdust', 'Surface Concentration of Dust ', 'kg/m3', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_concso4 = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'concso4', 'Concentration of Sulfate ', 'kg/m3', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_concoa = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'concoa', 'Concentration of Organic Aerosol ', 'kg/m3', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_concbc = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'concbc', 'Concentration of Black Carbon ', 'kg/m3', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_concss = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'concss', 'Concentration of Sea Salt ', 'kg/m3', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_concdust = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'concdust', 'Concentration of Dust ', 'kg/m3', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_loadso4 = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'loadso4', 'Column Load of Sulfate ', 'kg/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_loadoa = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'loadoa', 'Column Load of Organic Aerosol ', 'kg/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_loadbc = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'loadbc', 'Column Load of Black Carbon ', 'kg/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_loadss = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'loadss', 'Column Load of Sea Salt ', 'kg/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_loaddust = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'loaddust', 'Column Load of Dust ', 'kg/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swtoaas_nat = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swtoaas_nat', 'Natural aerosol radiative forcing all-sky at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swsrfas_nat = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swsrfas_nat', 'Natural aerosol radiative forcing all-sky at SRF', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swtoacs_nat = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swtoacs_nat', 'Natural aerosol radiative forcing clear-sky at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swsrfcs_nat = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swsrfcs_nat', 'Natural aerosol radiative forcing clear-sky at SRF', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swtoaas_ant = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swtoaas_ant', 'Anthropogenic aerosol radiative forcing all-sky at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swsrfas_ant = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swsrfas_ant', 'Anthropogenic aerosol radiative forcing all-sky at SRF', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swtoacs_ant = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swtoacs_ant', 'Anthropogenic aerosol radiative forcing clear-sky at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swsrfcs_ant = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swsrfcs_ant', 'Anthropogenic aerosol radiative forcing clear-sky at SRF', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swtoacf_nat = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swtoacf_nat', 'Natural aerosol impact on cloud radiative forcing at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swsrfcf_nat = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swsrfcf_nat', 'Natural aerosol impact on cloud radiative forcing  at SRF', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swtoacf_ant = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swtoacf_ant', 'Anthropogenic aerosol impact on cloud radiative forcing at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swsrfcf_ant = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swsrfcf_ant', 'Anthropogenic aerosol impact on cloud radiative forcing at SRF', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swtoacf_zero = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swtoacf_zero', 'Cloud radiative forcing (allsky-clearsky fluxes) at TOA', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_swsrfcf_zero = ctrl_out((/ 4, 6, 10, 10, 10, 10 /), &
+	'swsrfcf_zero', 'Cloud radiative forcing (allsky-clearsky fluxes) at SRF', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_cldncl = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'cldncl', 'CDNC at top of liquid water cloud', 'm-3', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_reffclwtop = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'reffclwtop', 'Droplet effective radius at top of liquid water cloud', 'm', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_cldnvi = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'cldnvi', 'Column Integrated Cloud Droplet Number', 'm-2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_lcc = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'lcc', 'Cloud liquid fraction at top of cloud', '1', (/ ('', i=1, 6) /))
+
+
+!!!!!!!!!!!!!!!!!!!!!! 3D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
+  TYPE(ctrl_out), SAVE :: o_ec550aer = ctrl_out((/ 2, 6, 10, 10, 10, 10 /), &
+	'ec550aer', 'Extinction at 550nm', 'm^-1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_lwcon = ctrl_out((/ 2, 5, 10, 10, 10, 10 /), &
+	'lwcon', 'Cloud liquid water content', 'kg/kg', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_iwcon = ctrl_out((/ 2, 5, 10, 10, 10, 10 /), &
+	'iwcon', 'Cloud ice water content', 'kg/kg', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_temp = ctrl_out((/ 2, 3, 4, 10, 10, 10 /), &
+	'temp', 'Air temperature', 'K', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_theta = ctrl_out((/ 2, 3, 4, 10, 10, 10 /), &
+	'theta', 'Potential air temperature', 'K', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ovap = ctrl_out((/ 2, 3, 4, 10, 10, 10 /), &
+	'ovap', 'Specific humidity', 'kg/kg', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ovapinit = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'ovapinit', 'Specific humidity (begin of timestep)', 'kg/kg', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_oliq = ctrl_out((/ 2, 3, 4, 10, 10, 10 /), &
+	'oliq', 'Condensed water', 'kg/kg', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_wvapp = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'wvapp', '', '', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_geop = ctrl_out((/ 2, 3, 10, 10, 10, 10 /), &
+	'geop', 'Geopotential height', 'm2/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_vitu = ctrl_out((/ 2, 3, 4, 6, 10, 10 /), &
+	'vitu', 'Zonal wind', 'm/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_vitv = ctrl_out((/ 2, 3, 4, 6, 10, 10 /), &
+	'vitv', 'Meridional wind', 'm/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_vitw = ctrl_out((/ 2, 3, 10, 6, 10, 10 /), &
+	'vitw', 'Vertical wind', 'Pa/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_pres = ctrl_out((/ 2, 3, 10, 10, 10, 10 /), &
+	'pres', 'Air pressure', 'Pa', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_paprs = ctrl_out((/ 2, 3, 10, 10, 10, 10 /), &
+	'paprs', 'Air pressure Inter-Couches', 'Pa', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_mass = ctrl_out((/ 2, 3, 10, 10, 10, 10 /), &
+	'mass', 'Masse Couches', 'kg/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_zfull = ctrl_out((/ 2, 3, 10, 10, 10, 10 /), &
+	'zfull', 'Altitude of full pressure levels', 'm', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_zhalf = ctrl_out((/ 2, 3, 10, 10, 10, 10 /), &
+	'zhalf', 'Altitude of half pressure levels', 'm', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rneb = ctrl_out((/ 2, 5, 10, 10, 10, 10 /), &
+	'rneb', 'Cloud fraction', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rnebcon = ctrl_out((/ 2, 5, 10, 10, 10, 10 /), &
+	'rnebcon', 'Convective Cloud Fraction', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rnebls = ctrl_out((/ 2, 5, 10, 10, 10, 10 /), &
+	'rnebls', 'LS Cloud fraction', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rhum = ctrl_out((/ 2, 5, 10, 10, 10, 10 /), &
+	'rhum', 'Relative humidity', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ozone = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'ozone', 'Ozone mole fraction', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ozone_light = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'ozone_daylight', 'Daylight ozone mole fraction', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_upwd = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'upwd', 'saturated updraft', 'kg/m2/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtphy = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'dtphy', 'Physics dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dqphy = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'dqphy', 'Physics dQ', '(kg/kg)/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_pr_con_l = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'pr_con_l', 'Convective precipitation lic', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_pr_con_i = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'pr_con_i', 'Convective precipitation ice', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_pr_lsc_l = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'pr_lsc_l', 'Large scale precipitation lic', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_pr_lsc_i = ctrl_out((/ 2, 10, 10, 10, 10, 10 /), &
+	'pr_lsc_i', 'Large scale precipitation ice', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_re = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	're', 'Cloud droplet effective radius', 'um', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_fl = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	'fl', 'Denominator of Cloud droplet effective radius', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_scdnc = ctrl_out((/ 2,  6, 10, 10, 10, 10 /), &
+	'scdnc', 'Cloud droplet number concentration', 'm-3', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_reffclws = ctrl_out((/ 2,  6, 10, 10, 10, 10 /), &
+	'reffclws', 'Stratiform Cloud Droplet Effective Radius (aerosol diags.)', 'm', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_reffclwc = ctrl_out((/ 2,  6, 10, 10, 10, 10 /), &
+	'reffclwc', 'Convective Cloud Droplet Effective Radius (aerosol diags.)', 'm', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_lcc3d = ctrl_out((/ 2,  6, 10, 10, 10, 10 /), &
+	'lcc3d', 'Cloud liquid fraction', '1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_lcc3dcon = ctrl_out((/ 2,  6, 10, 10, 10, 10 /), &
+	'lcc3dcon', 'Convective cloud liquid fraction', '1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_lcc3dstra = ctrl_out((/ 2,  6, 10, 10, 10, 10 /), &
+	'lcc3dstra', 'Stratiform cloud liquid fraction', '1', (/ ('', i=1, 6) /))
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_albe_srf     = (/ &
+      ctrl_out((/ 3, 7, 10, 7, 10, 10 /),'albe_ter', "Albedo VIS surf. "//clnsurf(1),"-", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 3, 7, 10, 7, 10, 10 /),'albe_lic', "Albedo VIS surf. "//clnsurf(2),"-", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 3, 7, 10, 7, 10, 10 /),'albe_oce', "Albedo VIS surf. "//clnsurf(3),"-", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 3, 7, 10, 7, 10, 10 /),'albe_sic', "Albedo VIS surf. "//clnsurf(4),"-", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_ages_srf     = (/ &
+      ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'ages_ter', "Snow age", "day", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 3, 10, 10, 10, 10, 10 /),'ages_lic', "Snow age", "day", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 10, 10, 10, 10, 10, 10 /),'ages_oce',"Snow age", "day", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 3, 10, 10, 10, 10, 10 /),'ages_sic',"Snow age", "day", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_rugs_srf     = (/ &
+      ctrl_out((/ 3, 6, 10, 10, 10, 10 /),'rugs_ter', "Surface roughness "//clnsurf(1),"m", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 3, 6, 10, 10, 10, 10 /),'rugs_lic', "Surface roughness "//clnsurf(2),"m", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 3, 6, 10, 10, 10, 10 /),'rugs_oce', "Surface roughness "//clnsurf(3),"m", (/ ('', i=1, 6) /)), &
+      ctrl_out((/ 3, 6, 10, 10, 10, 10 /),'rugs_sic', "Surface roughness "//clnsurf(4),"m", (/ ('', i=1, 6) /)) /)
+
+  TYPE(ctrl_out), SAVE :: o_alb1 = ctrl_out((/ 3, 10, 10, 10, 10, 10 /), &
+	'alb1', 'Surface VIS albedo', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_alb2 = ctrl_out((/ 3, 10, 10, 10, 10, 10 /), &
+	'alb2', 'Surface Near IR albedo', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_clwcon = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'clwcon', 'Convective Cloud Liquid water content', 'kg/kg', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_Ma = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'Ma', 'undilute adiab updraft', 'kg/m2/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dnwd = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dnwd', 'saturated downdraft', 'kg/m2/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dnwd0 = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dnwd0', 'unsat. downdraft', 'kg/m2/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_mc = ctrl_out((/ 4, 5, 10, 10, 10, 10 /), &
+	'mc', 'Convective mass flux', 'kg/m2/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ftime_con = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'ftime_con', 'Fraction of time convection Occurs', ' ',                 &
+      (/ 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)', 'inst(X)' /))
+  TYPE(ctrl_out), SAVE :: o_dtdyn = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtdyn', 'Dynamics dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dqdyn = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dqdyn', 'Dynamics dQ', '(kg/kg)/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dudyn = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dudyn', 'Dynamics dU', 'm/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dvdyn = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dvdyn', 'Dynamics dV', 'm/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtcon = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtcon', 'Convection dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ducon = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'ducon', 'Convection du', 'm/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dvcon = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dvcon', 'Convection dv', 'm/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dqcon = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dqcon', 'Convection dQ', '(kg/kg)/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtwak = ctrl_out((/ 4, 5, 10, 10, 10, 10 /), &
+	'dtwak', 'Wake dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dqwak = ctrl_out((/ 4, 5, 10, 10, 10, 10 /), &
+	'dqwak', 'Wake dQ', '(kg/kg)/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_wake_h = ctrl_out((/ 4, 5, 10, 10, 10, 10 /), &
+	'wake_h', 'wake_h', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_wake_s = ctrl_out((/ 4, 5, 10, 10, 10, 10 /), &
+	'wake_s', 'wake_s', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_wake_deltat = ctrl_out((/ 4, 5, 10, 10, 10, 10 /), &
+	'wake_deltat', 'wake_deltat', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_wake_deltaq = ctrl_out((/ 4, 5, 10, 10, 10, 10 /), &
+	'wake_deltaq', 'wake_deltaq', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_wake_omg = ctrl_out((/ 4, 5, 10, 10, 10, 10 /), &
+	'wake_omg', 'wake_omg', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_wdtrainA = ctrl_out((/ 4, 1, 10,  4,  1, 10 /), &
+	'wdtrainA', 'precipitation from AA', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_wdtrainM = ctrl_out((/ 4, 1, 10,  4,  1, 10 /), &
+	'wdtrainM', 'precipitation from mixture', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_Vprecip = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'Vprecip', 'precipitation vertical profile', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ftd = ctrl_out((/ 4, 5, 10, 10, 10, 10 /), &
+	'ftd', 'tend temp due aux descentes precip', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_fqd = ctrl_out((/ 4, 5, 10, 10, 10, 10 /), &
+	'fqd', 'tend vap eau due aux descentes precip', '-', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtlsc = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtlsc', 'Condensation dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtlschr = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtlschr', 'Large-scale condensational heating rate', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dqlsc = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dqlsc', 'Condensation dQ', '(kg/kg)/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_beta_prec = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'beta_prec', 'LS Conversion rate to prec', '(kg/kg)/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtvdf = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtvdf', 'Boundary-layer dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtdis = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtdis', 'TKE dissipation dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dqvdf = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dqvdf', 'Boundary-layer dQ', '(kg/kg)/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dteva = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dteva', 'Reevaporation dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dqeva = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dqeva', 'Reevaporation dQ', '(kg/kg)/s', (/ ('', i=1, 6) /))
+
+!!!!!!!!!!!!!!!! Specifique thermiques
+  TYPE(ctrl_out), SAVE :: o_dqlscth = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'dqlscth', 'dQ therm.', '(kg/kg)/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dqlscst = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'dqlscst', 'dQ strat.', '(kg/kg)/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtlscth = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'dtlscth', 'dQ therm.', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtlscst = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'dtlscst', 'dQ strat.', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_plulth = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'plulth', 'Rainfall therm.', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_plulst = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'plulst', 'Rainfall strat.', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_lmaxth = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'lmaxth', "Upper level thermals", "", (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ptconvth = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'ptconvth', 'POINTS CONVECTIFS therm.', ' ', (/ ('', i=1, 6) /))
+!!!!!!!!!!!!!!!!!!!!!!!!
+  TYPE(ctrl_out), SAVE :: o_ptconv = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'ptconv', 'POINTS CONVECTIFS', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ratqs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'ratqs', 'RATQS', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtthe = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtthe', 'Thermal dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_f_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'f_th', 'Thermal plume mass flux', 'kg/(m2*s)', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_e_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'e_th', 'Thermal plume entrainment', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_w_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'w_th', 'Thermal plume vertical velocity', 'm/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_lambda_th = ctrl_out((/ 10, 10, 10, 10, 10, 10 /), &
+	'lambda_th', 'Thermal plume vertical velocity', 'm/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ftime_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'ftime_th', 'Fraction of time Shallow convection occurs', ' ', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_q_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'q_th', 'Thermal plume total humidity', 'kg/kg', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_a_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'a_th', "Thermal plume fraction", "", (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_d_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'd_th', 'Thermal plume detrainment', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_f0_th = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'f0_th', 'Thermal closure mass flux', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_zmax_th = ctrl_out((/ 4,  4,  4,  5, 10, 10 /), &
+	'zmax_th', 'Thermal plume height', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dqthe = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dqthe', 'Thermal dQ', '(kg/kg)/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtajs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtajs', 'Dry adjust. dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dqajs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dqajs', 'Dry adjust. dQ', '(kg/kg)/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtswr = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtswr', 'SW radiation dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtsw0 = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtsw0', 'CS SW radiation dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtlwr = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtlwr', 'LW radiation dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtlw0 = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtlw0', 'CS LW radiation dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtec = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtec', 'Cinetic dissip dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_duvdf = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'duvdf', 'Boundary-layer dU', 'm/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dvvdf = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dvvdf', 'Boundary-layer dV', 'm/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_duoro = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'duoro', 'Orography dU', 'm/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dvoro = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dvoro', 'Orography dV', 'm/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dulif = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dulif', 'Orography dU', 'm/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dvlif = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dvlif', 'Orography dV', 'm/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_duhin = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'duhin', 'Hines GWD dU', 'm/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dvhin = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dvhin', 'Hines GWD dV', 'm/s2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtoro = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtoro', 'Orography dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dtlif = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dtlif', 'Orography dT', 'K/s', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dthin = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dthin', 'Hines GWD dT', 'K/s', (/ ('', i=1, 6) /))
+
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_trac(:)
+  TYPE(ctrl_out), SAVE, ALLOCATABLE :: o_trac_cum(:)
+  TYPE(ctrl_out), SAVE :: o_rsu = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'rsu', 'SW upward radiation', 'W m-2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rsd = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'rsd', 'SW downward radiation', 'W m-2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rlu = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'rlu', 'LW upward radiation', 'W m-2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rld = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'rld', 'LW downward radiation', 'W m-2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rsucs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'rsucs', 'SW CS upward radiation', 'W m-2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rsdcs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'rsdcs', 'SW CS downward radiation', 'W m-2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rlucs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'rlucs', 'LW CS upward radiation', 'W m-2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rldcs = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'rldcs', 'LW CS downward radiation', 'W m-2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tnt = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'tnt', 'Tendency of air temperature', 'K s-1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tntc = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'tntc', 'Tendency of air temperature due to Moist Convection', 'K s-1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tntr = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'tntr', 'Air temperature tendency due to Radiative heating', 'K s-1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tntscpbl = ctrl_out((/ 4, 10, 10, 10, 10, 10 /),                  &
+	'tntscpbl', 'Air temperature tendency due to St cloud and precipitation and BL mixing', &
+      'K s-1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tnhus = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'tnhus', 'Tendency of specific humidity', 's-1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tnhusc = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'tnhusc', 'Tendency of specific humidity due to convection', 's-1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_tnhusscpbl = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'tnhusscpbl', 'Tendency of Specific humidity due to ST cl, precip and BL mixing', 's-1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_evu = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'evu', 'Eddy viscosity coefficient for Momentum Variables', 'm2 s-1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_h2o = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'h2o', 'Mass Fraction of Water', '1', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_mcd = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'mcd', 'Downdraft COnvective Mass Flux', 'kg/(m2*s)', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_dmc = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'dmc', 'Deep COnvective Mass Flux', 'kg/(m2*s)', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ref_liq = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'ref_liq', 'Effective radius of convective cloud liquid water particle', 'm', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_ref_ice = ctrl_out((/ 4, 10, 10, 10, 10, 10 /), &
+	'ref_ice', 'Effective radius of startiform cloud ice particle', 'm', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rsut4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	'rsut4co2', 'TOA Out SW in 4xCO2 atmosphere', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rlut4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	'rlut4co2', 'TOA Out LW in 4xCO2 atmosphere', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rsutcs4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	'rsutcs4co2', 'TOA Out CS SW in 4xCO2 atmosphere', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rlutcs4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	'rlutcs4co2', 'TOA Out CS LW in 4xCO2 atmosphere', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rsu4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	'rsu4co2', 'Upwelling SW 4xCO2 atmosphere', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rlu4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	'rlu4co2', 'Upwelling LW 4xCO2 atmosphere', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rsucs4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	'rsucs4co2', 'Upwelling CS SW 4xCO2 atmosphere', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rlucs4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	'rlucs4co2', 'Upwelling CS LW 4xCO2 atmosphere', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rsd4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	'rsd4co2', 'Downwelling SW 4xCO2 atmosphere', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rld4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	'rld4co2', 'Downwelling LW 4xCO2 atmosphere', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rsdcs4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	'rsdcs4co2', 'Downwelling CS SW 4xCO2 atmosphere', 'W/m2', (/ ('', i=1, 6) /))
+  TYPE(ctrl_out), SAVE :: o_rldcs4co2 = ctrl_out((/ 5, 10, 10, 10, 10, 10 /), &
+	'rldcs4co2', 'Downwelling CS LW 4xCO2 atmosphere', 'W/m2', (/ ('', i=1, 6) /))
+
+END MODULE phys_output_ctrlout_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_output_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_output_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_output_mod.F90	(revision 17)
@@ -0,0 +1,1138 @@
+! $Id: phys_output_mod.F90 1795 2013-07-18 08:20:28Z emillour $
+!
+! Abderrahmane 12 2007
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!! Ecreture des Sorties du modele dans les fichiers Netcdf :
+! histmth.nc : moyennes mensuelles
+! histday.nc : moyennes journalieres
+! histhf.nc  : moyennes toutes les 3 heures
+! histins.nc : valeurs instantanees
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MODULE phys_output_mod 
+  USE indice_sol_mod
+  USE phys_output_var_mod
+  USE phys_output_ctrlout_mod
+  USE aero_mod, only : naero_spc,name_aero
+
+  IMPLICIT NONE
+
+  PRIVATE histdef2d, histdef3d, conf_physoutputs
+
+  REAL, PRIVATE, SAVE                :: zdtime
+  !$OMP THREADPRIVATE(zdtime)
+
+
+
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!! Ouverture des fichier et definition des variable de sortie !!!!!!!!
+  !! histbeg, histvert et histdef
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
+
+  SUBROUTINE phys_output_open(rlon,rlat,pim,tabij,ipt,jpt,plon,plat, &
+       jjmp1,nlevSTD,clevSTD,nbteta, &
+       ctetaSTD, dtime, ok_veget, &
+       type_ocean, iflag_pbl,ok_mensuel,ok_journe, &
+       ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, read_climoz, &
+       phys_out_filestations, &
+       new_aod, aerosol_couple, flag_aerosol_strat)   
+
+    USE iophy 
+    USE dimphy
+    USE infotrac
+    USE ioipsl
+    USE phys_cal_mod, only : hour
+    USE mod_phys_lmdz_para
+    USE aero_mod, only : naero_spc,name_aero
+
+    IMPLICIT NONE
+    include "dimensions.h"
+    include "temps.h"
+    include "clesphys.h"
+    include "thermcell.h"
+    include "comvert.h"
+    include "iniprint.h"
+
+    real,dimension(klon),intent(in) :: rlon
+    real,dimension(klon),intent(in) :: rlat
+    INTEGER, intent(in)             :: pim
+    INTEGER, DIMENSION(pim)            :: tabij
+    INTEGER,dimension(pim), intent(in) :: ipt, jpt
+    REAL,dimension(pim), intent(in) :: plat, plon
+    REAL,dimension(pim,2) :: plat_bounds, plon_bounds
+
+    INTEGER                               :: jjmp1
+    INTEGER                               :: nbteta, nlevSTD, radpas
+    LOGICAL                               :: ok_mensuel, ok_journe, ok_hf, ok_instan
+    LOGICAL                               :: ok_LES,ok_ade,ok_aie,flag_aerosol_strat
+    LOGICAL                               :: new_aod, aerosol_couple
+    INTEGER, intent(in)::  read_climoz ! read ozone climatology
+    !     Allowed values are 0, 1 and 2
+    !     0: do not read an ozone climatology
+    !     1: read a single ozone climatology that will be used day and night
+    !     2: read two ozone climatologies, the average day and night
+    !     climatology and the daylight climatology
+
+    REAL                                  :: dtime
+    INTEGER                               :: idayref
+    REAL                                  :: zjulian
+    REAL, DIMENSION(klev)                 :: Ahyb, Bhyb, Alt
+    CHARACTER(LEN=4), DIMENSION(nlevSTD)  :: clevSTD
+    INTEGER                               :: nsrf, k, iq, iiq, iff, i, j, ilev
+    INTEGER                               :: naero
+    LOGICAL                               :: ok_veget
+    INTEGER                               :: iflag_pbl
+    CHARACTER(LEN=4)                      :: bb2
+    CHARACTER(LEN=2)                      :: bb3
+    CHARACTER(LEN=6)                      :: type_ocean
+    CHARACTER(LEN=3)                      :: ctetaSTD(nbteta)
+    REAL, DIMENSION(nfiles)               :: ecrit_files
+    CHARACTER(LEN=20), DIMENSION(nfiles)  :: phys_out_filenames
+    INTEGER, DIMENSION(iim*jjmp1)         ::  ndex2d
+    INTEGER, DIMENSION(iim*jjmp1*klev)    :: ndex3d
+    INTEGER                               :: imin_ins, imax_ins
+    INTEGER                               :: jmin_ins, jmax_ins
+    INTEGER, DIMENSION(nfiles)            :: phys_out_levmin, phys_out_levmax
+    INTEGER, DIMENSION(nfiles)            :: phys_out_filelevels
+    CHARACTER(LEN=20), DIMENSION(nfiles)  :: chtimestep   = (/ 'DefFreq', 'DefFreq','DefFreq', 'DefFreq', 'DefFreq', 'DefFreq' /)
+    LOGICAL, DIMENSION(nfiles)            :: phys_out_filekeys
+    LOGICAL, DIMENSION(nfiles)            :: phys_out_filestations
+
+!!!!!!!!!! stockage dans une region limitee pour chaque fichier !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    !                 entre [phys_out_lonmin,phys_out_lonmax] et [phys_out_latmin,phys_out_latmax]
+
+    LOGICAL, DIMENSION(nfiles), SAVE  :: phys_out_regfkey       = (/ .FALSE., .FALSE., .FALSE.,  .FALSE., .FALSE., .FALSE. /)
+    REAL, DIMENSION(nfiles), SAVE     :: phys_out_lonmin        = (/   -180.,   -180.,   -180.,    -180.,   -180.,   -180. /)
+    REAL, DIMENSION(nfiles), SAVE     :: phys_out_lonmax        = (/    180.,    180.,    180.,     180.,    180.,    180. /)
+    REAL, DIMENSION(nfiles), SAVE     :: phys_out_latmin        = (/    -90.,    -90.,    -90.,     -90.,    -90.,    -90. /)
+    REAL, DIMENSION(nfiles), SAVE     :: phys_out_latmax        = (/     90.,     90.,     90.,     90.,     90.,     90. /)
+
+!Lluis
+    INTEGER ix,iy,lp,il,jl
+
+    WRITE(lunout,*) 'Debut phys_output_mod.F90'
+    ! Initialisations (Valeurs par defaut
+
+    IF (.NOT. ALLOCATED(o_trac)) ALLOCATE(o_trac(nqtot))
+    IF (.NOT. ALLOCATED(o_trac_cum)) ALLOCATE(o_trac_cum(nqtot))
+
+    levmax = (/ klev, klev, klev, klev, klev, klev /)
+
+    phys_out_filenames(1) = 'histmth'
+    phys_out_filenames(2) = 'histday'
+    phys_out_filenames(3) = 'histhf'
+    phys_out_filenames(4) = 'histins'
+    phys_out_filenames(5) = 'histLES'
+    phys_out_filenames(6) = 'histstn'
+
+    type_ecri(1) = 'ave(X)'
+    type_ecri(2) = 'ave(X)'
+    type_ecri(3) = 'ave(X)'
+    type_ecri(4) = 'inst(X)'
+    type_ecri(5) = 'ave(X)'
+    type_ecri(6) = 'inst(X)'
+
+    clef_files(1) = ok_mensuel
+    clef_files(2) = ok_journe
+    clef_files(3) = ok_hf
+    clef_files(4) = ok_instan
+    clef_files(5) = ok_LES
+    clef_files(6) = ok_instan
+
+    !sortir des fichiers "stations" si clef_stations(:)=.TRUE.
+    clef_stations(1) = .FALSE.
+    clef_stations(2) = .FALSE.
+    clef_stations(3) = .FALSE.
+    clef_stations(4) = .FALSE.
+    clef_stations(5) = .FALSE.
+    clef_stations(6) = .FALSE.
+
+    lev_files(1) = lev_histmth
+    lev_files(2) = lev_histday
+    lev_files(3) = lev_histhf
+    lev_files(4) = lev_histins
+    lev_files(5) = lev_histLES
+    lev_files(6) = lev_histins
+
+    ecrit_files(1) = ecrit_mth
+    ecrit_files(2) = ecrit_day
+    ecrit_files(3) = ecrit_hf
+    ecrit_files(4) = ecrit_ins
+    ecrit_files(5) = ecrit_LES
+    ecrit_files(6) = ecrit_ins
+
+    !! Lectures des parametres de sorties dans physiq.def
+
+    CALL getin('phys_out_regfkey',phys_out_regfkey)
+    CALL getin('phys_out_lonmin',phys_out_lonmin)
+    CALL getin('phys_out_lonmax',phys_out_lonmax)
+    CALL getin('phys_out_latmin',phys_out_latmin)
+    CALL getin('phys_out_latmax',phys_out_latmax)
+    phys_out_levmin(:)=levmin(:)
+    CALL getin('phys_out_levmin',levmin)
+    phys_out_levmax(:)=levmax(:)
+    CALL getin('phys_out_levmax',levmax)
+    CALL getin('phys_out_filenames',phys_out_filenames)
+    phys_out_filekeys(:)=clef_files(:)
+    CALL getin('phys_out_filekeys',clef_files)
+    phys_out_filestations(:)=clef_stations(:)
+    CALL getin('phys_out_filestations',clef_stations)
+    phys_out_filelevels(:)=lev_files(:)
+    CALL getin('phys_out_filelevels',lev_files)
+    CALL getin('phys_out_filetimesteps',chtimestep)
+    phys_out_filetypes(:)=type_ecri(:)
+    CALL getin('phys_out_filetypes',type_ecri)
+
+    type_ecri_files(:)=type_ecri(:)
+
+    WRITE(lunout,*)'phys_out_lonmin=',phys_out_lonmin
+    WRITE(lunout,*)'phys_out_lonmax=',phys_out_lonmax
+    WRITE(lunout,*)'phys_out_latmin=',phys_out_latmin
+    WRITE(lunout,*)'phys_out_latmax=',phys_out_latmax
+    WRITE(lunout,*)'phys_out_filenames=',phys_out_filenames
+    WRITE(lunout,*)'phys_out_filetypes=',type_ecri
+    WRITE(lunout,*)'phys_out_filekeys=',clef_files
+    WRITE(lunout,*)'phys_out_filestations=',clef_stations
+    WRITE(lunout,*)'phys_out_filelevels=',lev_files
+
+!!!!!!!!!!!!!!!!!!!!!!! Boucle sur les fichiers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Appel de histbeg et histvert pour creer le fichier et les niveaux verticaux !!
+    ! Appel des histbeg pour definir les variables (nom, moy ou inst, freq de sortie ..
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    zdtime = dtime         ! Frequence ou l on moyenne
+
+    ! Calcul des Ahyb, Bhyb et Alt
+    DO k=1,klev
+       Ahyb(k)=(ap(k)+ap(k+1))/2.
+       Bhyb(k)=(bp(k)+bp(k+1))/2.
+       Alt(k)=log(preff/presnivs(k))*8.
+    ENDDO
+    !          if(prt_level.ge.1) then
+    WRITE(lunout,*)'Ap Hybrid = ',Ahyb(1:klev)
+    WRITE(lunout,*)'Bp Hybrid = ',Bhyb(1:klev)
+    WRITE(lunout,*)'Alt approx des couches pour une haut d echelle de 8km = ',Alt(1:klev)
+    !          endif
+    DO iff=1,nfiles
+
+       ! Calculate ecrit_files for all files
+       IF ( chtimestep(iff).eq.'DefFreq' ) then
+          ! Par defaut ecrit_files = (ecrit_mensuel ecrit_jour ecrit_hf ...)*86400.
+          ecrit_files(iff)=ecrit_files(iff)*86400.
+       ELSE
+          CALL convers_timesteps(chtimestep(iff),dtime,ecrit_files(iff)) 
+       ENDIF
+       WRITE(lunout,*)'ecrit_files(',iff,')= ',ecrit_files(iff)
+
+       zoutm(iff) = ecrit_files(iff) ! Frequence ou l on ecrit en seconde
+
+       IF (clef_files(iff)) THEN
+
+          idayref = day_ref
+!          CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)       
+! correction pour l heure initiale                               !jyg 
+!                                                                !jyg 
+          CALL ymds2ju(annee_ref, 1, idayref, hour, zjulian)         !jyg
+! correction pour l heure initiale                               !jyg 
+!                                                                !jyg 
+!!!      CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian)       !jyg 
+! correction pour l heure initiale                               !jyg 
+!                                                                !jyg 
+!      CALL ymds2ju(annee_ref, 1, idayref, hour, zjulian)         !jyg
+
+!!!!!!!!!!!!!!!!! Traitement dans le cas ou l'on veut stocker sur un domaine limite !!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+          IF (phys_out_regfkey(iff)) then
+
+             imin_ins=1
+             imax_ins=iim
+             jmin_ins=1
+             jmax_ins=jjmp1
+
+             ! correction abderr        
+             do i=1,iim
+                WRITE(lunout,*)'io_lon(i)=',io_lon(i)
+                IF (io_lon(i).le.phys_out_lonmin(iff)) imin_ins=i
+                IF (io_lon(i).le.phys_out_lonmax(iff)) imax_ins=i+1
+             enddo
+
+             do j=1,jjmp1
+                WRITE(lunout,*)'io_lat(j)=',io_lat(j)
+                IF (io_lat(j).ge.phys_out_latmin(iff)) jmax_ins=j+1
+                IF (io_lat(j).ge.phys_out_latmax(iff)) jmin_ins=j
+             enddo
+
+             WRITE(lunout,*)'On stoke le fichier histoire numero ',iff,' sur ', &
+                  imin_ins,imax_ins,jmin_ins,jmax_ins
+             WRITE(lunout,*)'longitudes : ', &
+                  io_lon(imin_ins),io_lon(imax_ins), &
+                  'latitudes : ', &
+                  io_lat(jmax_ins),io_lat(jmin_ins)
+
+             CALL histbeg(phys_out_filenames(iff),iim,io_lon,jjmp1,io_lat, &
+                  imin_ins,imax_ins-imin_ins+1, &
+                  jmin_ins,jmax_ins-jmin_ins+1, &
+                  itau_phy,zjulian,dtime,nhorim(iff),nid_files(iff))
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+             !IM fichiers stations
+          else IF (clef_stations(iff)) THEN
+
+             WRITE(lunout,*)'phys_output_mod phys_out_filenames=',phys_out_filenames(iff)
+
+             CALL histbeg_phy_all(rlon,rlat,pim,tabij,ipt,jpt,plon,plat,plon_bounds,plat_bounds, &
+                  phys_out_filenames(iff), &
+                  itau_phy,zjulian,dtime,nhorim(iff),nid_files(iff))
+          else
+             CALL histbeg_phy(phys_out_filenames(iff),itau_phy,zjulian,dtime,nhorim(iff),nid_files(iff))
+          endif
+
+          CALL histvert(nid_files(iff), "presnivs", "Vertical levels", "Pa", &
+               levmax(iff) - levmin(iff) + 1, &
+               presnivs(levmin(iff):levmax(iff)), nvertm(iff),"down")
+
+!!!!!!!!!!!!! Traitement des champs 3D pour histhf !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!! A Revoir plus tard !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+          !          IF (iff.eq.3.and.lev_files(iff).ge.4) THEN
+          !          CALL histbeg_phy("histhf3d",itau_phy, &
+          !     &                     zjulian, dtime, &
+          !     &                     nhorim, nid_hf3d)
+
+          !         CALL histvert(nid_hf3d, "presnivs", &
+          !     &                 "Vertical levels", "mb", &
+          !     &                 klev, presnivs/100., nvertm)
+          !          ENDIF
+          !
+!!!! Composentes de la coordonnee sigma-hybride 
+          CALL histvert(nid_files(iff), "Ahyb","Ahyb comp of Hyb Cord ", "Pa", &
+               levmax(iff) - levmin(iff) + 1,Ahyb,nvertap(iff))
+
+          CALL histvert(nid_files(iff), "Bhyb","Bhyb comp of Hyb Cord", " ", &
+               levmax(iff) - levmin(iff) + 1,Bhyb,nvertbp(iff))
+
+          CALL histvert(nid_files(iff), "Alt","Height approx for scale heigh of 8km at levels", "Km", &
+               levmax(iff) - levmin(iff) + 1,Alt,nvertAlt(iff))
+
+          !   CALL histvert(nid_files(iff), "preff","Reference pressure", "Pa", &
+          !                 1,preff,nvertp0(iff))
+!!! Champs 1D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    CALL histdef2d(iff,o_aire)
+    CALL histdef2d(iff,o_contfracATM)
+
+!!! Champs 2D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    CALL histdef2d(iff,o_phis)
+    CALL histdef2d(iff,o_contfracOR)
+    CALL histdef2d(iff,o_aireTER)
+    CALL histdef2d(iff,o_flat)
+    CALL histdef2d(iff,o_slp)
+    CALL histdef2d(iff,o_tsol)
+    CALL histdef2d(iff,o_t2m)
+    CALL histdef2d(iff,o_t2m_min)
+    CALL histdef2d(iff,o_t2m_max)
+    CALL histdef2d(iff,o_wind10m)
+    CALL histdef2d(iff,o_wind10max)
+    CALL histdef2d(iff,o_sicf)
+    CALL histdef2d(iff,o_q2m)
+    CALL histdef2d(iff,o_ustar)
+    CALL histdef2d(iff,o_u10m)
+    CALL histdef2d(iff,o_v10m)
+    CALL histdef2d(iff,o_psol)
+    CALL histdef2d(iff,o_qsurf)
+
+    IF (.NOT. ok_veget) THEN
+      CALL histdef2d(iff,o_qsol)
+    ENDIF
+    CALL histdef2d(iff,o_ndayrain)
+    CALL histdef2d(iff,o_precip)
+    CALL histdef2d(iff,o_plul)
+    CALL histdef2d(iff,o_pluc)
+    CALL histdef2d(iff,o_snow)
+    CALL histdef2d(iff,o_msnow)
+    CALL histdef2d(iff,o_fsnow)
+    CALL histdef2d(iff,o_evap)
+    CALL histdef2d(iff,o_tops)
+    CALL histdef2d(iff,o_tops0)
+    CALL histdef2d(iff,o_topl)
+    CALL histdef2d(iff,o_topl0)
+    CALL histdef2d(iff,o_SWupTOA)
+    CALL histdef2d(iff,o_SWupTOAclr)
+    CALL histdef2d(iff,o_SWdnTOA)
+    CALL histdef2d(iff,o_SWdnTOAclr)
+    CALL histdef2d(iff,o_nettop)
+    CALL histdef2d(iff,o_SWup200)
+    CALL histdef2d(iff,o_SWup200clr)
+    CALL histdef2d(iff,o_SWdn200)
+    CALL histdef2d(iff,o_SWdn200clr)
+    CALL histdef2d(iff,o_LWup200)
+    CALL histdef2d(iff,o_LWup200clr)
+    CALL histdef2d(iff,o_LWdn200)
+    CALL histdef2d(iff,o_LWdn200clr)
+    CALL histdef2d(iff,o_sols)
+    CALL histdef2d(iff,o_sols0)
+    CALL histdef2d(iff,o_soll)
+    CALL histdef2d(iff,o_radsol)
+    CALL histdef2d(iff,o_soll0)
+    CALL histdef2d(iff,o_SWupSFC)
+    CALL histdef2d(iff,o_SWupSFCclr)
+    CALL histdef2d(iff,o_SWdnSFC)
+    CALL histdef2d(iff,o_SWdnSFCclr)
+    CALL histdef2d(iff,o_LWupSFC)
+    CALL histdef2d(iff,o_LWdnSFC)
+    CALL histdef2d(iff,o_LWupSFCclr)
+    CALL histdef2d(iff,o_LWdnSFCclr)
+    CALL histdef2d(iff,o_bils)
+    CALL histdef2d(iff,o_bils_ec)
+    CALL histdef2d(iff,o_bils_tke)
+    CALL histdef2d(iff,o_bils_diss)
+    CALL histdef2d(iff,o_bils_kinetic)
+    CALL histdef2d(iff,o_bils_enthalp)
+    CALL histdef2d(iff,o_bils_latent)
+    CALL histdef2d(iff,o_sens)
+    CALL histdef2d(iff,o_fder)
+    CALL histdef2d(iff,o_ffonte)
+    CALL histdef2d(iff,o_fqcalving)
+    CALL histdef2d(iff,o_fqfonte)
+    CALL histdef2d(iff,o_taux)
+    CALL histdef2d(iff,o_tauy)
+
+    DO nsrf = 1, nbsrf
+      CALL histdef2d(iff,o_pourc_srf(nsrf))
+      CALL histdef2d(iff,o_fract_srf(nsrf))
+      CALL histdef2d(iff, o_taux_srf(nsrf))
+      CALL histdef2d(iff, o_tauy_srf(nsrf))
+      CALL histdef2d(iff, o_tsol_srf(nsrf))
+      CALL histdef2d(iff, o_evappot_srf(nsrf))
+      CALL histdef2d(iff, o_ustar_srf(nsrf))
+      CALL histdef2d(iff, o_u10m_srf(nsrf))
+      CALL histdef2d(iff, o_evap_srf(nsrf))
+      CALL histdef2d(iff, o_v10m_srf(nsrf))
+      CALL histdef2d(iff, o_t2m_srf(nsrf))
+      CALL histdef2d(iff, o_sens_srf(nsrf))
+      CALL histdef2d(iff, o_lat_srf(nsrf))
+      CALL histdef2d(iff, o_flw_srf(nsrf))
+      CALL histdef2d(iff, o_fsw_srf(nsrf))
+      CALL histdef2d(iff, o_wbils_srf(nsrf))
+      CALL histdef2d(iff, o_wbilo_srf(nsrf))
+      IF (iflag_pbl>1 ) then
+            CALL histdef2d(iff, o_tke_srf(nsrf))
+            CALL histdef2d(iff, o_tke_max_srf(nsrf))
+      ENDIF
+
+      CALL histdef2d(iff, o_albe_srf(nsrf))
+      CALL histdef2d(iff, o_rugs_srf(nsrf))
+      CALL histdef2d(iff, o_ages_srf(nsrf))
+    END DO
+
+    IF (new_aod .AND. (.NOT. aerosol_couple)) THEN
+      IF (ok_ade.OR.ok_aie) THEN
+          CALL histdef2d(iff,o_od550aer)
+          CALL histdef2d(iff,o_od865aer)
+          CALL histdef2d(iff,o_absvisaer)
+          CALL histdef2d(iff,o_od550lt1aer)
+          CALL histdef2d(iff,o_sconcso4)
+          CALL histdef2d(iff,o_sconcoa)
+          CALL histdef2d(iff,o_sconcbc)
+          CALL histdef2d(iff,o_sconcss)
+          CALL histdef2d(iff,o_sconcdust)
+          CALL histdef3d(iff,o_concso4)
+          CALL histdef3d(iff,o_concoa)
+          CALL histdef3d(iff,o_concbc)
+          CALL histdef3d(iff,o_concss)
+          CALL histdef3d(iff,o_concdust)
+          CALL histdef2d(iff,o_loadso4)
+          CALL histdef2d(iff,o_loadoa)
+          CALL histdef2d(iff,o_loadbc)
+          CALL histdef2d(iff,o_loadss)
+          CALL histdef2d(iff,o_loaddust)
+!--STRAT AER
+      ENDIF
+      IF (ok_ade.OR.ok_aie.OR.flag_aerosol_strat) THEN
+        DO naero = 1, naero_spc
+          CALL histdef2d(iff, o_tausumaero(naero))
+        END DO
+      ENDIF
+    ENDIF
+
+    IF (ok_ade) THEN
+      CALL histdef2d(iff,o_topswad)
+      CALL histdef2d(iff,o_topswad0)
+      CALL histdef2d(iff,o_solswad)
+      CALL histdef2d(iff,o_solswad0)
+      CALL histdef2d(iff,o_swtoaas_nat)
+      CALL histdef2d(iff,o_swsrfas_nat)
+      CALL histdef2d(iff,o_swtoacs_nat)
+      CALL histdef2d(iff,o_swsrfcs_nat)
+      CALL histdef2d(iff,o_swtoaas_ant)
+      CALL histdef2d(iff,o_swsrfas_ant)
+      CALL histdef2d(iff,o_swtoacs_ant)
+      CALL histdef2d(iff,o_swsrfcs_ant)
+
+      IF (.NOT. aerosol_couple) THEN 
+            CALL histdef2d(iff,o_swtoacf_nat)
+            CALL histdef2d(iff,o_swsrfcf_nat)
+            CALL histdef2d(iff,o_swtoacf_ant)
+            CALL histdef2d(iff,o_swsrfcf_ant)
+            CALL histdef2d(iff,o_swtoacf_zero)
+            CALL histdef2d(iff,o_swsrfcf_zero)
+      ENDIF
+    ENDIF
+
+    IF (ok_aie) THEN
+      CALL histdef2d(iff,o_topswai)
+      CALL histdef2d(iff,o_solswai)
+                  !Cloud droplet number concentration
+      CALL histdef3d(iff,o_scdnc)
+      CALL histdef2d(iff,o_cldncl)
+      CALL histdef3d(iff,o_reffclws)
+      CALL histdef3d(iff,o_reffclwc)
+      CALL histdef2d(iff,o_cldnvi)
+      CALL histdef3d(iff,o_lcc3d)
+      CALL histdef3d(iff,o_lcc3dcon)
+      CALL histdef3d(iff,o_lcc3dstra)
+      CALL histdef2d(iff,o_lcc)
+      CALL histdef2d(iff,o_reffclwtop)
+    ENDIF
+    CALL histdef2d(iff,o_alb1)
+    CALL histdef2d(iff,o_alb2)
+    CALL histdef2d(iff,o_cdrm)
+    CALL histdef2d(iff,o_cdrh)
+    CALL histdef2d(iff,o_cldl)
+    CALL histdef2d(iff,o_cldm)
+    CALL histdef2d(iff,o_cldh)
+    CALL histdef2d(iff,o_cldt)
+    CALL histdef2d(iff,o_cldq)
+    CALL histdef2d(iff,o_lwp)
+    CALL histdef2d(iff,o_iwp)
+    CALL histdef2d(iff,o_ue)
+    CALL histdef2d(iff,o_ve)
+    CALL histdef2d(iff,o_uq)
+    CALL histdef2d(iff,o_vq)
+
+    IF(iflag_con.GE.3) THEN ! sb
+      CALL histdef2d(iff,o_cape)
+      CALL histdef2d(iff,o_pbase)
+      CALL histdef2d(iff,o_ptop)
+      CALL histdef2d(iff,o_fbase)
+      IF (iflag_con /= 30) THEN
+            CALL histdef2d(iff,o_plcl)
+            CALL histdef2d(iff,o_plfc)
+            CALL histdef2d(iff,o_wbeff)
+      ENDIF
+      CALL histdef2d(iff,o_cape_max)
+      CALL histdef3d(iff,o_upwd)
+      CALL histdef3d(iff,o_Ma)
+      CALL histdef3d(iff,o_dnwd)
+      CALL histdef3d(iff,o_dnwd0)
+      CALL histdef3d(iff,o_mc)
+      CALL histdef2d(iff,o_ftime_con)
+    ENDIF !iflag_con .GE. 3
+    CALL histdef2d(iff,o_prw)
+    CALL histdef2d(iff,o_s_pblh)
+    CALL histdef2d(iff,o_s_pblt)
+    CALL histdef2d(iff,o_s_lcl)
+    CALL histdef2d(iff,o_s_therm)
+          !IM : Les champs suivants (s_oliqCL, s_cteiCL, s_trmb1, s_trmb2, s_trmb3) ne sont pas definis dans HBTM.F
+          !CALL histdef2d(iff, &
+          !o_s_capCL%flag,o_s_capCL%name, "Conv avlbl pot enerfor ABL", "J/m2" )
+          !CALL histdef2d(iff, &
+          !o_s_oliqCL%flag,o_s_oliqCL%name, "Liq Water in BL", "kg/m2")
+          !CALL histdef2d(iff, &
+          !o_s_cteiCL%flag,o_s_cteiCL%name, "Instability criteria(ABL)", "K")
+          !CALL histdef2d(iff, &
+          !o_s_trmb1%flag,o_s_trmb1%name, "deep_cape(HBTM2)", "J/m2")
+          !CALL histdef2d(iff, &
+          !o_s_trmb2%flag,o_s_trmb2%name, "inhibition (HBTM2)", "J/m2")
+          !CALL histdef2d(iff, &
+          !o_s_trmb3%flag,o_s_trmb3%name, "Point Omega (HBTM2)", "m")
+
+          ! Champs interpolles sur des niveaux de pression
+
+          ! Attention a reverifier
+
+    ilev=0        
+    DO k=1, nlevSTD
+      bb2=clevSTD(k)
+      IF(bb2.EQ."850".OR.bb2.EQ."700".OR.bb2.EQ."500".OR.bb2.EQ."200" &
+                  .OR.bb2.EQ."100".OR.bb2.EQ."50".OR.bb2.EQ."10")THEN
+            ilev=ilev+1
+            !     print*,'ilev k bb2 flag name ',ilev,k, bb2,o_uSTDlevs(ilev)%flag,o_uSTDlevs(ilev)%name
+            CALL histdef2d(iff,o_uSTDlevs(ilev))
+            CALL histdef2d(iff,o_vSTDlevs(ilev))
+            CALL histdef2d(iff,o_wSTDlevs(ilev))
+            CALL histdef2d(iff,o_zSTDlevs(ilev))
+            CALL histdef2d(iff,o_qSTDlevs(ilev))
+            CALL histdef2d(iff,o_tSTDlevs(ilev))
+      ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR."500".OR.bb2.EQ."200".OR.bb2.EQ."50".OR.bb2.EQ."10")
+    ENDDO
+
+    CALL histdef2d(iff,o_t_oce_sic)
+
+    IF (type_ocean=='slab') THEN
+      CALL histdef2d(iff,o_slab_bils)
+    ENDIF
+
+    ! Couplage conv-CL
+    IF (iflag_con.GE.3) THEN
+      IF (iflag_coupl>=1) THEN
+            CALL histdef2d(iff,o_ale_bl)
+            CALL histdef2d(iff,o_alp_bl)
+      ENDIF
+    ENDIF !(iflag_con.GE.3)
+
+    CALL histdef2d(iff,o_weakinv)
+    CALL histdef2d(iff,o_dthmin)
+
+    CALL histdef2d(iff,o_rh2m)
+    CALL histdef2d(iff,o_rh2m_min)
+    CALL histdef2d(iff,o_rh2m_max)
+
+    CALL histdef2d(iff,o_qsat2m)
+    CALL histdef2d(iff,o_tpot)
+    CALL histdef2d(iff,o_tpote)
+    CALL histdef2d(iff,o_SWnetOR)
+    CALL histdef2d(iff,o_SWdownOR)
+    CALL histdef2d(iff,o_LWdownOR)
+    CALL histdef2d(iff,o_snowl)
+    CALL histdef2d(iff,o_solldown)
+    CALL histdef2d(iff,o_dtsvdfo)
+    CALL histdef2d(iff,o_dtsvdft)
+    CALL histdef2d(iff,o_dtsvdfg)
+    CALL histdef2d(iff,o_dtsvdfi)
+    CALL histdef2d(iff,o_rugs)
+
+          ! Champs 3D:
+    CALL histdef3d(iff,o_ec550aer)
+    CALL histdef3d(iff,o_lwcon)
+    CALL histdef3d(iff,o_iwcon)
+    CALL histdef3d(iff,o_temp)
+    CALL histdef3d(iff,o_theta)
+    CALL histdef3d(iff,o_ovap)
+    CALL histdef3d(iff,o_oliq)
+    CALL histdef3d(iff,o_ovapinit)
+    CALL histdef3d(iff,o_geop)
+    CALL histdef3d(iff,o_vitu)
+    CALL histdef3d(iff,o_vitv)
+    CALL histdef3d(iff,o_vitw)
+    CALL histdef3d(iff,o_pres)
+    CALL histdef3d(iff,o_paprs)
+    CALL histdef3d(iff,o_mass)
+    CALL histdef3d(iff,o_zfull)
+    CALL histdef3d(iff,o_zhalf)
+    CALL histdef3d(iff,o_rneb)
+    CALL histdef3d(iff,o_rnebcon)
+    CALL histdef3d(iff,o_rnebls)
+    CALL histdef3d(iff,o_rhum)
+    CALL histdef3d(iff,o_ozone)
+
+    IF (read_climoz == 2) THEN
+      CALL histdef3d(iff,o_ozone_light)
+    END IF
+
+    CALL histdef3d(iff,o_dtphy)
+    CALL histdef3d(iff,o_dqphy)
+    CALL histdef3d(iff,o_cldtau)
+    CALL histdef3d(iff,o_cldemi)
+!IM: bug ?? dimensionnement variables (klon,klev+1) pmflxr, pmflxs, prfl, psfl
+    CALL histdef3d(iff,o_pr_con_l)
+    CALL histdef3d(iff,o_pr_con_i)
+    CALL histdef3d(iff,o_pr_lsc_l)
+    CALL histdef3d(iff,o_pr_lsc_i)
+!Cloud droplet effective radius
+    CALL histdef3d(iff,o_re)
+    CALL histdef3d(iff,o_fl)
+!FH Sorties pour la couche limite
+    IF (iflag_pbl>1) THEN
+      CALL histdef3d(iff,o_tke)
+      CALL histdef3d(iff,o_tke_max)
+    ENDIF
+    CALL histdef3d(iff,o_kz)
+    CALL histdef3d(iff,o_kz_max)
+    CALL histdef3d(iff,o_clwcon)
+    CALL histdef3d(iff,o_dtdyn)
+    CALL histdef3d(iff,o_dqdyn)
+    CALL histdef3d(iff,o_dudyn)
+    CALL histdef3d(iff,o_dvdyn)
+    CALL histdef3d(iff,o_dtcon)
+    CALL histdef3d(iff,o_ducon)
+    CALL histdef3d(iff,o_dvcon)
+    CALL histdef3d(iff,o_dqcon)
+
+! Wakes
+    IF(iflag_con.EQ.3) THEN
+      IF (iflag_wake >= 1) THEN
+            CALL histdef2d(iff,o_ale_wk)
+            CALL histdef2d(iff,o_alp_wk)
+            CALL histdef2d(iff,o_ale)
+            CALL histdef2d(iff,o_alp)
+            CALL histdef2d(iff,o_cin)
+            CALL histdef2d(iff,o_wape)
+            CALL histdef2d(iff,o_wake_h)
+            CALL histdef2d(iff,o_wake_s)
+            CALL histdef3d(iff,o_dtwak)
+            CALL histdef3d(iff,o_dqwak)
+            CALL histdef3d(iff,o_wake_deltat)
+            CALL histdef3d(iff,o_wake_deltaq)
+            CALL histdef3d(iff,o_wake_omg)
+      ENDIF
+!!! RomP             CALL histdef3d(iff,o_Vprecip%flag,o_Vprecip%name, "precipitation vertical profile", "-")
+      CALL histdef3d(iff,o_ftd)
+      CALL histdef3d(iff,o_fqd)
+    ENDIF !(iflag_con.EQ.3)
+
+    IF(iflag_con.GE.3) THEN   !  RomP >>>
+      CALL histdef3d(iff,o_wdtrainA)
+      CALL histdef3d(iff,o_wdtrainM)
+      CALL histdef3d(iff,o_Vprecip)
+    ENDIF !(iflag_con.GE.3)   ! <<< RomP
+
+!!! nrlmd le 10/04/2012
+
+    IF (iflag_trig_bl>=1) THEN
+      CALL histdef2d(iff,o_n2)
+      CALL histdef2d(iff,o_s2)
+      CALL histdef2d(iff,o_proba_notrig)
+      CALL histdef2d(iff,o_random_notrig)
+      CALL histdef2d(iff,o_ale_bl_trig)
+      CALL histdef2d(iff,o_ale_bl_stat)
+    ENDIF  !(iflag_trig_bl>=1)
+
+    IF (iflag_clos_bl>=1) THEN
+      CALL histdef2d(iff,o_alp_bl_det)
+      CALL histdef2d(iff,o_alp_bl_fluct_m)
+      CALL histdef2d(iff,o_alp_bl_fluct_tke)
+      CALL histdef2d(iff,o_alp_bl_conv)
+      CALL histdef2d(iff,o_alp_bl_stat)
+    ENDIF  !(iflag_clos_bl>=1)
+
+!!! fin nrlmd le 10/04/2012
+    CALL histdef3d(iff,o_dtlsc)
+    CALL histdef3d(iff,o_dtlschr)
+    CALL histdef3d(iff,o_dqlsc)
+    CALL histdef3d(iff,o_beta_prec)
+    CALL histdef3d(iff,o_dtvdf)
+    CALL histdef3d(iff,o_dtdis)
+    CALL histdef3d(iff,o_dqvdf)
+    CALL histdef3d(iff,o_dteva)
+    CALL histdef3d(iff,o_dqeva)
+    CALL histdef3d(iff,o_ptconv)
+    CALL histdef3d(iff,o_ratqs)
+    CALL histdef3d(iff,o_dtthe)
+
+    IF (iflag_thermals.ge.1) THEN
+      CALL histdef3d(iff,o_dqlscth)
+      CALL histdef3d(iff,o_dqlscst)
+      CALL histdef3d(iff,o_dtlscth)
+      CALL histdef3d(iff,o_dtlscst)
+      CALL histdef2d(iff,o_plulth)
+      CALL histdef2d(iff,o_plulst)
+      CALL histdef2d(iff,o_lmaxth)
+      CALL histdef3d(iff,o_ptconvth)
+      CALL histdef3d(iff,o_f_th)
+      CALL histdef3d(iff,o_e_th)
+      CALL histdef3d(iff,o_w_th)
+      CALL histdef3d(iff,o_lambda_th)
+      CALL histdef2d(iff,o_ftime_th)
+      CALL histdef3d(iff,o_q_th)
+      CALL histdef3d(iff,o_a_th)
+      CALL histdef3d(iff,o_d_th)
+      CALL histdef2d(iff,o_f0_th)
+      CALL histdef2d(iff,o_zmax_th)
+      CALL histdef3d(iff,o_dqthe)
+    ENDIF !iflag_thermals.ge.1
+
+    CALL histdef3d(iff,o_dtajs)
+    CALL histdef3d(iff,o_dqajs)
+    CALL histdef3d(iff,o_dtswr)
+    CALL histdef3d(iff,o_dtsw0)
+    CALL histdef3d(iff,o_dtlwr)
+    CALL histdef3d(iff,o_dtlw0)
+    CALL histdef3d(iff,o_dtec)
+    CALL histdef3d(iff,o_duvdf)
+    CALL histdef3d(iff,o_dvvdf)
+
+    IF (ok_orodr) THEN
+      CALL histdef3d(iff,o_duoro)
+      CALL histdef3d(iff,o_dvoro)
+      CALL histdef3d(iff,o_dtoro)
+    ENDIF
+
+    IF (ok_orolf) THEN
+      CALL histdef3d(iff,o_dulif)
+      CALL histdef3d(iff,o_dvlif)
+      CALL histdef3d(iff,o_dtlif)
+    ENDIF
+
+    IF (ok_hines) then
+      CALL histdef3d(iff,o_duhin)
+      CALL histdef3d(iff,o_dvhin)
+      CALL histdef3d(iff,o_dthin)
+    ENDIF
+
+    CALL histdef3d(iff,o_rsu)
+    CALL histdef3d(iff,o_rsd)
+    CALL histdef3d(iff,o_rlu)
+    CALL histdef3d(iff,o_rld)
+    CALL histdef3d(iff,o_rsucs)
+    CALL histdef3d(iff,o_rsdcs)
+    CALL histdef3d(iff,o_rlucs)
+    CALL histdef3d(iff,o_rldcs)
+    CALL histdef3d(iff,o_tnt)
+    CALL histdef3d(iff,o_tntc)
+    CALL histdef3d(iff,o_tntr)
+    CALL histdef3d(iff,o_tntscpbl)
+    CALL histdef3d(iff,o_tnhus)
+    CALL histdef3d(iff,o_tnhusc)
+    CALL histdef3d(iff,o_tnhusscpbl)
+    CALL histdef3d(iff,o_evu)
+    CALL histdef3d(iff,o_h2o)
+    CALL histdef3d(iff,o_mcd)
+    CALL histdef3d(iff,o_dmc)
+    CALL histdef3d(iff,o_ref_liq)
+    CALL histdef3d(iff,o_ref_ice)
+
+    IF (RCO2_per.NE.RCO2_act.OR.RCH4_per.NE.RCH4_act.OR. &
+               RN2O_per.NE.RN2O_act.OR.RCFC11_per.NE.RCFC11_act.OR. &
+               RCFC12_per.NE.RCFC12_act) THEN
+      CALL histdef2d(iff,o_rsut4co2)
+      CALL histdef2d(iff,o_rlut4co2)
+      CALL histdef2d(iff,o_rsutcs4co2)
+      CALL histdef2d(iff,o_rlutcs4co2)
+      CALL histdef3d(iff,o_rsu4co2)
+      CALL histdef3d(iff,o_rlu4co2)
+      CALL histdef3d(iff,o_rsucs4co2)
+      CALL histdef3d(iff,o_rlucs4co2)
+      CALL histdef3d(iff,o_rsd4co2)
+      CALL histdef3d(iff,o_rld4co2)
+      CALL histdef3d(iff,o_rsdcs4co2)
+      CALL histdef3d(iff,o_rldcs4co2)
+
+    ENDIF
+
+
+      IF (nqtot>=3) THEN
+            DO iq=3,nqtot  
+            iiq=niadv(iq)
+            o_trac(iq-2) = ctrl_out((/ 4, 5, 1, 1, 1, 10 /),tname(iiq),'Tracer '//ttext(iiq), "-",&
+                  (/ '', '', '', '', '', '' /))
+            CALL histdef3d(iff, o_trac(iq-2))
+            o_trac_cum(iq-2) = ctrl_out((/ 3, 4, 10, 10, 10, 10 /),'cum'//tname(iiq),&
+                  'Cumulated tracer '//ttext(iiq), "-", (/ '', '', '', '', '', '' /))
+            CALL histdef2d(iff, o_trac_cum(iq-2))
+            ENDDO
+      ENDIF
+
+      CALL histend(nid_files(iff))
+
+      ndex2d = 0
+      ndex3d = 0
+
+    ENDIF ! clef_files
+
+    ENDDO !  iff
+
+    ! Updated write frequencies due to phys_out_filetimesteps. 
+    ! Write frequencies are now in seconds.  
+    ecrit_mth = ecrit_files(1)
+    ecrit_day = ecrit_files(2)
+    ecrit_hf  = ecrit_files(3)
+    ecrit_ins = ecrit_files(4)
+    ecrit_LES = ecrit_files(5)
+    ecrit_ins = ecrit_files(6)
+
+    WRITE(lunout,*)'swaero_diag=',swaero_diag
+    WRITE(lunout,*)'Fin phys_output_mod.F90'
+  end SUBROUTINE phys_output_open
+
+  SUBROUTINE histdef2d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar)
+
+    USE ioipsl
+    USE dimphy
+    USE mod_phys_lmdz_para
+    USE iophy
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "temps.h"
+    INCLUDE "clesphys.h"
+
+    INTEGER                          :: iff
+    LOGICAL                          :: lpoint
+    INTEGER, DIMENSION(nfiles)       :: flag_var
+    CHARACTER(LEN=20)                 :: nomvar
+    CHARACTER(LEN=*)                 :: titrevar
+    CHARACTER(LEN=*)                 :: unitvar
+
+    REAL zstophym
+
+    IF (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') THEN
+       zstophym=zoutm(iff)
+    ELSE
+       zstophym=zdtime
+    ENDIF
+
+    ! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
+    CALL conf_physoutputs(nomvar,flag_var)
+
+    IF(.NOT.lpoint) THEN  
+       IF ( flag_var(iff)<=lev_files(iff) ) THEN
+          CALL histdef (nid_files(iff),nomvar,titrevar,unitvar, &
+               iim,jj_nb,nhorim(iff), 1,1,1, -99, 32, &
+               type_ecri(iff), zstophym,zoutm(iff))                
+       ENDIF
+    ELSE
+       IF ( flag_var(iff)<=lev_files(iff) ) THEN
+          CALL histdef (nid_files(iff),nomvar,titrevar,unitvar, &
+               npstn,1,nhorim(iff), 1,1,1, -99, 32, &
+               type_ecri(iff), zstophym,zoutm(iff))                
+       ENDIF
+    ENDIF
+
+    ! Set swaero_diag=true if at least one of the concerned variables are defined 
+    IF (nomvar=='topswad' .OR. nomvar=='topswai' .OR. nomvar=='solswad' .OR. nomvar=='solswai' ) THEN
+       IF  ( flag_var(iff)<=lev_files(iff) ) THEN
+          swaero_diag=.TRUE.
+       END IF
+    END IF
+  END SUBROUTINE histdef2d_old
+
+  SUBROUTINE histdef2d (iff,var)
+
+    USE ioipsl
+    USE dimphy
+    USE mod_phys_lmdz_para
+    USE iophy
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "temps.h"
+    INCLUDE "clesphys.h"
+
+    INTEGER                          :: iff
+    TYPE(ctrl_out)                   :: var
+
+    REAL zstophym
+    CHARACTER(LEN=20) :: typeecrit
+
+    ! ug On récupère le type écrit de la structure:
+    !       Assez moche, à refaire si meilleure méthode...
+    IF (INDEX(var%type_ecrit(iff), "once") > 0) THEN
+       typeecrit = 'once'
+    ELSE IF(INDEX(var%type_ecrit(iff), "t_min") > 0) THEN
+       typeecrit = 't_min(X)'
+    ELSE IF(INDEX(var%type_ecrit(iff), "t_max") > 0) THEN
+       typeecrit = 't_max(X)'
+    ELSE IF(INDEX(var%type_ecrit(iff), "inst") > 0) THEN
+       typeecrit = 'inst(X)'
+    ELSE
+       typeecrit = type_ecri_files(iff)
+    ENDIF
+
+    IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
+       zstophym=zoutm(iff)
+    ELSE
+       zstophym=zdtime
+    ENDIF
+
+    ! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
+    CALL conf_physoutputs(var%name, var%flag)
+
+    IF(.NOT.clef_stations(iff)) THEN  
+       IF ( var%flag(iff)<=lev_files(iff) ) THEN
+          CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
+               iim,jj_nb,nhorim(iff), 1,1,1, -99, 32, &
+               typeecrit, zstophym,zoutm(iff))                
+       ENDIF
+    ELSE
+       IF ( var%flag(iff)<=lev_files(iff)) THEN
+          CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
+               npstn,1,nhorim(iff), 1,1,1, -99, 32, &
+               typeecrit, zstophym,zoutm(iff))                
+       ENDIF
+    ENDIF
+
+    ! Set swaero_diag=true if at least one of the concerned variables are defined 
+    IF (var%name=='topswad' .OR. var%name=='topswai' .OR. var%name=='solswad' .OR. var%name=='solswai' ) THEN
+       IF  ( var%flag(iff)<=lev_files(iff) ) THEN
+          swaero_diag=.TRUE.
+       END IF
+    END IF
+  END SUBROUTINE histdef2d
+
+  SUBROUTINE histdef3d_old (iff,lpoint,flag_var,nomvar,titrevar,unitvar)
+
+    USE ioipsl
+    USE dimphy
+    USE mod_phys_lmdz_para
+    USE iophy
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "temps.h"
+!    INCLUDE "indicesol.h"
+    INCLUDE "clesphys.h"
+
+    INTEGER                          :: iff
+    LOGICAL                          :: lpoint
+    INTEGER, DIMENSION(nfiles)       :: flag_var
+    CHARACTER(LEN=20)                 :: nomvar
+    CHARACTER(LEN=*)                 :: titrevar
+    CHARACTER(LEN=*)                 :: unitvar
+
+    REAL zstophym
+
+    ! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
+    CALL conf_physoutputs(nomvar,flag_var)
+
+    IF (type_ecri(iff)=='inst(X)'.OR.type_ecri(iff)=='once') THEN
+       zstophym=zoutm(iff)
+    ELSE
+       zstophym=zdtime
+    ENDIF
+
+    IF(.NOT.lpoint) THEN
+       IF ( flag_var(iff)<=lev_files(iff) ) THEN
+          CALL histdef (nid_files(iff), nomvar, titrevar, unitvar, &
+               iim, jj_nb, nhorim(iff), klev, levmin(iff), &
+               levmax(iff)-levmin(iff)+1, nvertm(iff), 32, type_ecri(iff), &
+               zstophym, zoutm(iff))
+       ENDIF
+    ELSE
+       IF ( flag_var(iff)<=lev_files(iff) ) THEN
+          CALL histdef (nid_files(iff), nomvar, titrevar, unitvar, &
+               npstn,1,nhorim(iff), klev, levmin(iff), &
+               levmax(iff)-levmin(iff)+1, nvertm(iff), 32, &
+               type_ecri(iff), zstophym,zoutm(iff))
+       ENDIF
+    ENDIF
+  END SUBROUTINE histdef3d_old
+
+  SUBROUTINE histdef3d (iff,var)
+
+    USE ioipsl
+    USE dimphy
+    USE mod_phys_lmdz_para
+    USE iophy
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "temps.h"
+    INCLUDE "clesphys.h"
+
+    INTEGER                          :: iff
+    TYPE(ctrl_out)                   :: var
+
+    REAL zstophym
+    CHARACTER(LEN=20) :: typeecrit
+
+    ! ug On récupère le type écrit de la structure:
+    !       Assez moche, à refaire si meilleure méthode...
+    IF (INDEX(var%type_ecrit(iff), "once") > 0) THEN
+       typeecrit = 'once'
+    ELSE IF(INDEX(var%type_ecrit(iff), "t_min") > 0) THEN
+       typeecrit = 't_min(X)'
+    ELSE IF(INDEX(var%type_ecrit(iff), "t_max") > 0) THEN
+       typeecrit = 't_max(X)'
+    ELSE IF(INDEX(var%type_ecrit(iff), "inst") > 0) THEN
+       typeecrit = 'inst(X)'
+    ELSE
+       typeecrit = type_ecri_files(iff)
+    ENDIF
+
+
+    ! Appel a la lecture des noms et niveau d'ecriture des variables dans output.def
+    CALL conf_physoutputs(var%name,var%flag)
+
+    IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN
+       zstophym=zoutm(iff)
+    ELSE
+       zstophym=zdtime
+    ENDIF
+
+    IF(.NOT.clef_stations(iff)) THEN
+       IF ( var%flag(iff)<=lev_files(iff) ) THEN
+          CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
+               iim, jj_nb, nhorim(iff), klev, levmin(iff), &
+               levmax(iff)-levmin(iff)+1, nvertm(iff), 32, typeecrit, &
+               zstophym, zoutm(iff))
+       ENDIF
+    ELSE
+       IF ( var%flag(iff)<=lev_files(iff)) THEN
+          CALL histdef (nid_files(iff), var%name, var%description, var%unit, &
+               npstn,1,nhorim(iff), klev, levmin(iff), &
+               levmax(iff)-levmin(iff)+1, nvertm(iff), 32, &
+               typeecrit, zstophym,zoutm(iff))
+       ENDIF
+    ENDIF
+  END SUBROUTINE histdef3d
+
+  SUBROUTINE conf_physoutputs(nam_var,flag_var)
+!!! Lecture des noms et niveau de sortie des variables dans output.def
+    !   en utilisant les routines getin de IOIPSL  
+    use ioipsl
+
+    IMPLICIT NONE
+
+    include 'iniprint.h'
+
+    CHARACTER(LEN=20)                :: nam_var
+    INTEGER, DIMENSION(nfiles)      :: flag_var
+
+    IF(prt_level>10) WRITE(lunout,*)'Avant getin: nam_var flag_var ',nam_var,flag_var(:)
+    CALL getin('flag_'//nam_var,flag_var)
+    CALL getin('name_'//nam_var,nam_var)
+    IF(prt_level>10) WRITE(lunout,*)'Apres getin: nam_var flag_var ',nam_var,flag_var(:)
+
+  END SUBROUTINE conf_physoutputs
+
+  SUBROUTINE convers_timesteps(str,dtime,timestep)
+
+    use ioipsl
+    USE phys_cal_mod
+
+    IMPLICIT NONE
+
+    CHARACTER(LEN=20)   :: str
+    CHARACTER(LEN=10)   :: type
+    INTEGER             :: ipos,il
+    real                :: ttt,xxx,timestep,dayseconde,dtime
+    parameter (dayseconde=86400.)
+    include "temps.h"
+    include "comconst.h"
+    include "iniprint.h"
+
+    ipos=scan(str,'0123456789.',.TRUE.)
+    !  
+    il=len_trim(str)
+    WRITE(lunout,*)ipos,il
+    read(str(1:ipos),*) ttt
+    WRITE(lunout,*)ttt
+    type=str(ipos+1:il)
+
+
+    IF ( il == ipos ) then
+       type='day'
+    endif
+
+    IF ( type == 'day'.or.type == 'days'.or.type == 'jours'.or.type == 'jour' ) timestep = ttt * dayseconde
+    IF ( type == 'mounths'.or.type == 'mth'.or.type == 'mois' ) then
+       WRITE(lunout,*)'annee_ref,day_ref mon_len',annee_ref,day_ref,mth_len
+       timestep = ttt * dayseconde * mth_len
+    endif
+    IF ( type == 'hours'.or.type == 'hr'.or.type == 'heurs') timestep = ttt * dayseconde / 24.
+    IF ( type == 'mn'.or.type == 'minutes'  ) timestep = ttt * 60.
+    IF ( type == 's'.or.type == 'sec'.or.type == 'secondes'   ) timestep = ttt
+    IF ( type == 'TS' ) timestep = ttt * dtime
+
+    WRITE(lunout,*)'type =      ',type
+    WRITE(lunout,*)'nb j/h/m =  ',ttt
+    WRITE(lunout,*)'timestep(s)=',timestep
+
+  END SUBROUTINE convers_timesteps
+
+END MODULE phys_output_mod
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_output_var_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_output_var_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_output_var_mod.F90	(revision 17)
@@ -0,0 +1,83 @@
+!
+! phys_local_var_mod.F90 1327 2010-03-17 15:33:56Z idelkadi $
+
+      MODULE phys_output_var_mod
+
+      use dimphy
+! Variables outputs pour les ecritures des sorties
+!======================================================================
+!
+!
+!======================================================================
+! Declaration des variables
+
+      REAL, SAVE, ALLOCATABLE :: snow_o(:), zfra_o(:)
+!$OMP THREADPRIVATE(snow_o, zfra_o)
+      INTEGER, SAVE, ALLOCATABLE ::  itau_con(:)       ! Nombre de pas ou rflag <= 1
+!$OMP THREADPRIVATE(itau_con)
+      REAL, ALLOCATABLE :: bils_ec(:) ! Contribution of energy conservation
+      REAL, ALLOCATABLE :: bils_tke(:) ! Contribution of energy conservation
+      REAL, ALLOCATABLE :: bils_diss(:) ! Contribution of energy conservation
+      REAL, ALLOCATABLE :: bils_kinetic(:) ! bilan de chaleur au sol, kinetic
+      REAL, ALLOCATABLE :: bils_enthalp(:) ! bilan de chaleur au sol
+      REAL, ALLOCATABLE :: bils_latent(:) ! bilan de chaleur au sol
+!$OMP THREADPRIVATE(bils_ec,bils_tke,bils_diss,bils_kinetic,bils_enthalp,bils_latent)
+
+! ug Plein de variables venues de phys_output_mod
+      INTEGER, PARAMETER                           :: nfiles = 6
+      LOGICAL, DIMENSION(nfiles), SAVE             :: clef_files
+      LOGICAL, DIMENSION(nfiles), SAVE             :: clef_stations
+      INTEGER, DIMENSION(nfiles), SAVE             :: lev_files
+      INTEGER, DIMENSION(nfiles), SAVE             :: nid_files
+      INTEGER, DIMENSION(nfiles), SAVE  :: nnid_files
+!$OMP THREADPRIVATE(clef_files, clef_stations, lev_files,nid_files,nnid_files)
+      INTEGER, DIMENSION(nfiles), SAVE :: nnhorim
+
+      INTEGER, DIMENSION(nfiles), SAVE :: nhorim, nvertm
+      INTEGER, DIMENSION(nfiles), SAVE :: nvertap, nvertbp, nvertAlt
+      REAL, DIMENSION(nfiles), SAVE                :: zoutm
+      CHARACTER(LEN=20), DIMENSION(nfiles), SAVE   :: type_ecri
+!$OMP THREADPRIVATE(nnhorim, nhorim, nvertm, zoutm,type_ecri)
+      CHARACTER(LEN=20), DIMENSION(nfiles), SAVE  :: type_ecri_files, phys_out_filetypes
+!$OMP THREADPRIVATE(type_ecri_files, phys_out_filetypes)
+
+ ! swaero_diag : flag indicates if it is necessary to do calculation for some aerosol diagnostics
+      LOGICAL, SAVE                                :: swaero_diag=.FALSE.
+!$OMP THREADPRIVATE(swaero_diag)
+
+      INTEGER, SAVE:: levmin(nfiles) = 1
+      INTEGER, SAVE:: levmax(nfiles)
+!$OMP THREADPRIVATE(levmin, levmax)
+
+  TYPE ctrl_out
+     INTEGER,DIMENSION(nfiles)            :: flag
+     CHARACTER(len=20)                    :: name
+     CHARACTER(len=150)                   :: description
+     CHARACTER(len=20)                    :: unit
+     CHARACTER(len=20),DIMENSION(nfiles)  :: type_ecrit
+  END TYPE ctrl_out
+CONTAINS
+
+!======================================================================
+SUBROUTINE phys_output_var_init
+use dimphy
+
+IMPLICIT NONE
+
+      allocate(snow_o(klon), zfra_o(klon))
+      allocate(itau_con(klon))
+      allocate (bils_ec(klon),bils_tke(klon),bils_diss(klon),bils_kinetic(klon),bils_enthalp(klon),bils_latent(klon))
+
+END SUBROUTINE phys_output_var_init
+
+!======================================================================
+SUBROUTINE phys_output_var_end
+use dimphy
+IMPLICIT NONE
+
+      deallocate(snow_o,zfra_o,itau_con)
+      deallocate (bils_ec,bils_tke,bils_diss,bils_kinetic,bils_enthalp,bils_latent)
+
+END SUBROUTINE phys_output_var_end
+
+END MODULE phys_output_var_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_output_write_new.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_output_write_new.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_output_write_new.h	(revision 17)
@@ -0,0 +1,792 @@
+      itau_w = itau_phy + itap + start_time * day_step / iphysiq
+      ! ug On transmet le pas de temps Ã  iophy pour que les mÃ©thodes histwrite y aient accÃšs:
+      itau_iophy = itau_w
+
+      PRINT *,'Lluis on phys_output_write_new.h itap: ',itap,' itau_phy: ',itau_phy
+      PRINT *,'  Lluis. start_time: ', start_time,' day_step: ', day_step
+      PRINT *,'  iphysiq: ',iphysiq,' itau_w: ',itau_w
+
+             ndex2d = 0
+             ndex3d = 0
+!!! Champs 1D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      CALL histwrite_phy(o_phis, pphis)
+      CALL histwrite_phy(o_aire, airephy)
+
+      DO i=1, klon
+            zx_tmp_fi2d(i)=pctsrf(i,is_ter)+pctsrf(i,is_lic)
+      ENDDO
+      CALL histwrite_phy(o_contfracATM, zx_tmp_fi2d)
+      CALL histwrite_phy(o_contfracOR, pctsrf(:,is_ter))
+      CALL histwrite_phy(o_aireTER, paire_ter)
+!!! Champs 2D !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      CALL histwrite_phy(o_flat, zxfluxlat)
+      CALL histwrite_phy(o_slp, slp)
+      CALL histwrite_phy(o_tsol, zxtsol)
+      CALL histwrite_phy(o_t2m, zt2m)
+      CALL histwrite_phy(o_t2m_min, zt2m)
+      CALL histwrite_phy(o_t2m_max, zt2m)
+
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO
+      CALL histwrite_phy(o_wind10m, zx_tmp_fi2d)
+
+      DO i=1, klon
+       zx_tmp_fi2d(i)=SQRT(zu10m(i)*zu10m(i)+zv10m(i)*zv10m(i))
+      ENDDO
+      CALL histwrite_phy(o_wind10max, zx_tmp_fi2d)
+
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = pctsrf(i,is_sic)
+      ENDDO
+      CALL histwrite_phy(o_sicf, zx_tmp_fi2d)
+      CALL histwrite_phy(o_q2m, zq2m)
+      CALL histwrite_phy(o_ustar, zustar)
+      CALL histwrite_phy(o_u10m, zu10m)
+      CALL histwrite_phy(o_v10m, zv10m)
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = paprs(i,1)
+      ENDDO
+      CALL histwrite_phy(o_psol, zx_tmp_fi2d)
+      CALL histwrite_phy(o_mass, zmasse)
+      CALL histwrite_phy(o_qsurf, zxqsurf)
+
+      IF (.NOT. ok_veget) THEN
+            CALL histwrite_phy(o_qsol, qsol)
+      ENDIF
+
+       DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_fall(i) + snow_fall(i)
+       ENDDO
+      CALL histwrite_phy(o_precip, zx_tmp_fi2d)
+      CALL histwrite_phy(o_ndayrain, nday_rain)
+       DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_lsc(i) + snow_lsc(i)
+       ENDDO
+      CALL histwrite_phy(o_plul, zx_tmp_fi2d)
+      DO i = 1, klon
+         zx_tmp_fi2d(i) = rain_con(i) + snow_con(i)
+      ENDDO
+      CALL histwrite_phy(o_pluc, zx_tmp_fi2d)
+      CALL histwrite_phy(o_snow, snow_fall)
+      CALL histwrite_phy(o_msnow, snow_o)
+      CALL histwrite_phy(o_fsnow, zfra_o)
+      CALL histwrite_phy(o_evap, evap)
+      CALL histwrite_phy(o_tops, topsw)
+      CALL histwrite_phy(o_tops0, topsw0)
+      CALL histwrite_phy(o_topl, toplw)
+      CALL histwrite_phy(o_topl0, toplw0)
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, klevp1 )
+      CALL histwrite_phy(o_SWupTOA, zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, klevp1 )
+      CALL histwrite_phy(o_SWupTOAclr, zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, klevp1 )
+      CALL histwrite_phy(o_SWdnTOA, zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, klevp1 )
+      CALL histwrite_phy(o_SWdnTOAclr, zx_tmp_fi2d)
+      zx_tmp_fi2d(:) = topsw(:)-toplw(:)
+      CALL histwrite_phy(o_nettop, zx_tmp_fi2d)
+      CALL histwrite_phy(o_SWup200, SWup200)
+      CALL histwrite_phy(o_SWup200clr, SWup200clr)
+      CALL histwrite_phy(o_SWdn200, SWdn200)
+      CALL histwrite_phy(o_SWdn200clr, SWdn200clr)
+      CALL histwrite_phy(o_LWup200, LWup200)
+      CALL histwrite_phy(o_LWup200clr, LWup200clr)
+      CALL histwrite_phy(o_LWdn200, LWdn200)
+      CALL histwrite_phy(o_LWdn200clr, LWdn200clr)
+      CALL histwrite_phy(o_sols, solsw)
+      CALL histwrite_phy(o_sols0, solsw0)
+      CALL histwrite_phy(o_soll, sollw)
+      CALL histwrite_phy(o_radsol, radsol)
+      CALL histwrite_phy(o_soll0, sollw0)
+      zx_tmp_fi2d(1 : klon) = swup ( 1 : klon, 1 )
+      CALL histwrite_phy(o_SWupSFC, zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = swup0 ( 1 : klon, 1 )
+      CALL histwrite_phy(o_SWupSFCclr, zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = swdn ( 1 : klon, 1 )
+      CALL histwrite_phy(o_SWdnSFC, zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = swdn0 ( 1 : klon, 1 )
+      CALL histwrite_phy(o_SWdnSFCclr, zx_tmp_fi2d)
+      zx_tmp_fi2d(1:klon)=sollwdown(1:klon)-sollw(1:klon)
+      CALL histwrite_phy(o_LWupSFC, zx_tmp_fi2d)
+      CALL histwrite_phy(o_LWdnSFC, sollwdown)
+
+       sollwdownclr(1:klon) = -1.*lwdn0(1:klon,1)
+      zx_tmp_fi2d(1:klon)=sollwdownclr(1:klon)-sollw0(1:klon)
+      CALL histwrite_phy(o_LWupSFCclr, zx_tmp_fi2d)
+      CALL histwrite_phy(o_LWdnSFCclr, sollwdownclr)
+
+      CALL histwrite_phy(o_bils, bils)
+      CALL histwrite_phy(o_bils_diss, bils_diss)
+      CALL histwrite_phy(o_bils_ec, bils_ec)
+      CALL histwrite_phy(o_bils_tke, bils_tke)
+      CALL histwrite_phy(o_bils_kinetic, bils_kinetic)
+      CALL histwrite_phy(o_bils_latent, bils_latent)
+      CALL histwrite_phy(o_bils_enthalp, bils_enthalp)
+
+      zx_tmp_fi2d(1:klon)=-1*sens(1:klon)
+      CALL histwrite_phy(o_sens, zx_tmp_fi2d)
+      CALL histwrite_phy(o_fder, fder)
+      CALL histwrite_phy(o_ffonte, zxffonte)
+      CALL histwrite_phy(o_fqcalving, zxfqcalving)
+      CALL histwrite_phy(o_fqfonte, zxfqfonte)
+         zx_tmp_fi2d=0.
+         do nsrf=1,nbsrf
+          zx_tmp_fi2d(:)=zx_tmp_fi2d(:)+pctsrf(:,nsrf)*fluxu(:,1,nsrf)
+         enddo
+      CALL histwrite_phy(o_taux, zx_tmp_fi2d)
+         zx_tmp_fi2d=0.
+         do nsrf=1,nbsrf
+          zx_tmp_fi2d(:)=zx_tmp_fi2d(:)+pctsrf(:,nsrf)*fluxv(:,1,nsrf)
+         enddo
+      CALL histwrite_phy(o_tauy, zx_tmp_fi2d)
+         DO nsrf = 1, nbsrf
+!           IF(nsrf.GE.2) THEN
+            zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)*100.
+      CALL histwrite_phy(o_pourc_srf(nsrf), zx_tmp_fi2d)
+          zx_tmp_fi2d(1 : klon) = pctsrf( 1 : klon, nsrf)
+      CALL histwrite_phy(o_fract_srf(nsrf), zx_tmp_fi2d)
+!         ENDIF !nsrf.GT.2
+        zx_tmp_fi2d(1 : klon) = fluxu( 1 : klon, 1, nsrf)
+      CALL histwrite_phy(o_taux_srf(nsrf), zx_tmp_fi2d)
+        zx_tmp_fi2d(1 : klon) = fluxv( 1 : klon, 1, nsrf)
+      CALL histwrite_phy(o_tauy_srf(nsrf), zx_tmp_fi2d)
+        zx_tmp_fi2d(1 : klon) = ftsol( 1 : klon, nsrf)
+      CALL histwrite_phy(o_tsol_srf(nsrf), zx_tmp_fi2d)
+        zx_tmp_fi2d(1 : klon) = evap_pot( 1 : klon, nsrf)
+      CALL histwrite_phy(o_evappot_srf(nsrf), zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = ustar(1 : klon, nsrf)
+      CALL histwrite_phy(o_ustar_srf(nsrf), zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = u10m(1 : klon, nsrf)
+      CALL histwrite_phy(o_u10m_srf(nsrf), zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = v10m(1 : klon, nsrf)
+      CALL histwrite_phy(o_v10m_srf(nsrf), zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = t2m(1 : klon, nsrf)
+      CALL histwrite_phy(o_t2m_srf(nsrf), zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = fevap(1 : klon, nsrf)
+      CALL histwrite_phy(o_evap_srf(nsrf), zx_tmp_fi2d)
+       zx_tmp_fi2d(1 : klon) = fluxt( 1 : klon, 1, nsrf)
+      CALL histwrite_phy(o_sens_srf(nsrf), zx_tmp_fi2d)
+        zx_tmp_fi2d(1 : klon) = fluxlat( 1 : klon, nsrf)
+      CALL histwrite_phy(o_lat_srf(nsrf), zx_tmp_fi2d)
+        zx_tmp_fi2d(1 : klon) = fsollw( 1 : klon, nsrf)
+      CALL histwrite_phy(o_flw_srf(nsrf), zx_tmp_fi2d)
+        zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, nsrf)
+      CALL histwrite_phy(o_fsw_srf(nsrf), zx_tmp_fi2d)
+        zx_tmp_fi2d(1 : klon) = wfbils( 1 : klon, nsrf)
+      CALL histwrite_phy(o_wbils_srf(nsrf), zx_tmp_fi2d)
+        zx_tmp_fi2d(1 : klon) = wfbilo( 1 : klon, nsrf)
+      CALL histwrite_phy(o_wbilo_srf(nsrf), zx_tmp_fi2d)
+
+      IF (iflag_pbl>1) THEN
+       CALL histwrite_phy(o_tke_srf(nsrf), pbl_tke(:,1:klev,nsrf))
+       CALL histwrite_phy(o_tke_max_srf(nsrf), pbl_tke(:,1:klev,nsrf))
+      ENDIF
+
+      ENDDO
+      CALL histwrite_phy(o_cdrm, cdragm)
+      CALL histwrite_phy(o_cdrh, cdragh)
+      CALL histwrite_phy(o_cldl, cldl)
+      CALL histwrite_phy(o_cldm, cldm)
+      CALL histwrite_phy(o_cldh, cldh)
+      CALL histwrite_phy(o_cldt, cldt)
+      CALL histwrite_phy(o_cldq, cldq)
+      zx_tmp_fi2d(1:klon) = flwp(1:klon)
+      CALL histwrite_phy(o_lwp, zx_tmp_fi2d)
+      zx_tmp_fi2d(1:klon) = fiwp(1:klon)
+      CALL histwrite_phy(o_iwp, zx_tmp_fi2d)
+      CALL histwrite_phy(o_ue, ue)
+      CALL histwrite_phy(o_ve, ve)
+      CALL histwrite_phy(o_uq, uq)
+      CALL histwrite_phy(o_vq, vq)
+      IF(iflag_con.GE.3) THEN ! sb
+            CALL histwrite_phy(o_cape, cape)
+            CALL histwrite_phy(o_pbase, ema_pcb)
+            CALL histwrite_phy(o_ptop, ema_pct)
+            CALL histwrite_phy(o_fbase, ema_cbmf)
+
+            IF (iflag_con /= 30) THEN
+                  CALL histwrite_phy(o_plcl, plcl)
+                  CALL histwrite_phy(o_plfc, plfc)
+                  CALL histwrite_phy(o_wbeff, wbeff)
+            ENDIF
+
+            CALL histwrite_phy(o_cape_max, cape)
+            CALL histwrite_phy(o_upwd, upwd)
+            CALL histwrite_phy(o_Ma, Ma)
+            CALL histwrite_phy(o_dnwd, dnwd)
+            CALL histwrite_phy(o_dnwd0, dnwd0)
+              zx_tmp_fi2d=float(itau_con)/float(itap)
+            CALL histwrite_phy(o_ftime_con, zx_tmp_fi2d)
+
+            IF (iflag_thermals>=1) THEN
+               zx_tmp_fi3d=dnwd+dnwd0+upwd+fm_therm(:,1:klev)
+            ELSE
+               zx_tmp_fi3d=dnwd+dnwd0+upwd
+            ENDIF
+            CALL histwrite_phy(o_mc, zx_tmp_fi3d)
+      ENDIF !iflag_con .GE. 3
+
+      CALL histwrite_phy(o_prw, prw)
+      CALL histwrite_phy(o_s_pblh, s_pblh)
+      CALL histwrite_phy(o_s_pblt, s_pblt)
+      CALL histwrite_phy(o_s_lcl, s_lcl)
+      CALL histwrite_phy(o_s_therm, s_therm)
+
+
+! ANCIENNE METHODE
+        DO iff=1,nfiles
+              ll=0
+        DO k=1, nlevSTD
+         bb2=clevSTD(k) 
+         IF(bb2.EQ."850".OR.bb2.EQ."700".OR.                                         &
+       &      bb2.EQ."500".OR.bb2.EQ."200".OR.                                       &
+       &      bb2.EQ."100".OR.                                                       &
+       &      bb2.EQ."50".OR.bb2.EQ."10") THEN
+
+! a refaire correctement !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+          ll=ll+1
+      CALL histwrite_phy(o_uSTDlevs(ll),uwriteSTD(:,k,iff), iff)
+      CALL histwrite_phy(o_vSTDlevs(ll),vwriteSTD(:,k,iff), iff)
+      CALL histwrite_phy(o_wSTDlevs(ll),wwriteSTD(:,k,iff), iff)
+      CALL histwrite_phy(o_zSTDlevs(ll),phiwriteSTD(:,k,iff), iff)
+      CALL histwrite_phy(o_qSTDlevs(ll),qwriteSTD(:,k,iff), iff)
+      CALL histwrite_phy(o_tSTDlevs(ll),twriteSTD(:,k,iff), iff)
+!       IF (o_uSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN
+!       CALL histwrite_phy(nid_files(iff),clef_stations(iff),
+!     $o_uSTDlevs(ll)%name,
+!     &                    itau_w,uwriteSTD(:,k,iff))
+!       ENDIF
+
+ !      IF (o_vSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN
+!      CALL histwrite_phy(nid_files(iff),clef_stations(iff),
+!     $o_vSTDlevs(ll)%name,  
+!     &                   itau_w,vwriteSTD(:,k,iff))
+!       ENDIF
+
+!       IF (o_wSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN
+!      CALL histwrite_phy(nid_files(iff),clef_stations(iff),
+!     $o_wSTDlevs(ll)%name,
+!     &                    itau_w,wwriteSTD(:,k,iff))
+!       ENDIF
+
+!       IF (o_zSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN
+!      CALL histwrite_phy(nid_files(iff),clef_stations(iff),
+!     $o_zSTDlevs(ll)%name,
+!     &               itau_w,phiwriteSTD(:,k,iff))
+!      ENDIF
+
+ !      IF (o_qSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN
+!      CALL histwrite_phy(nid_files(iff),clef_stations(iff),
+!     $o_qSTDlevs(ll)%name,
+!     &                   itau_w, qwriteSTD(:,k,iff))
+!       ENDIF
+
+ !      IF (o_tSTDlevs(ll)%flag(iff)<=lev_files(iff)) THEN
+!      CALL histwrite_phy(nid_files(iff),clef_stations(iff),
+!     $o_tSTDlevs(ll)%name,
+!     &                   itau_w, twriteSTD(:,k,iff))
+ !      ENDIF
+
+       ENDIF !(bb2.EQ."850".OR.bb2.EQ."700".OR.
+       ENDDO
+   	   ENDDO
+! /ANCIENNE METHODE       
+
+
+      DO i=1, klon
+       IF (pctsrf(i,is_oce).GT.epsfra.OR.                                            &
+       &     pctsrf(i,is_sic).GT.epsfra) THEN
+        zx_tmp_fi2d(i) = (ftsol(i, is_oce) * pctsrf(i,is_oce)+                       &
+       &                   ftsol(i, is_sic) * pctsrf(i,is_sic))/                     &
+       &                   (pctsrf(i,is_oce)+pctsrf(i,is_sic))
+       ELSE
+        zx_tmp_fi2d(i) = 273.15
+       ENDIF
+      ENDDO
+      CALL histwrite_phy(o_t_oce_sic, zx_tmp_fi2d)
+! Couplage convection-couche limite
+      IF (iflag_con.GE.3) THEN
+            IF (iflag_coupl>=1) THEN
+                  CALL histwrite_phy(o_ale_bl, ale_bl)
+                  CALL histwrite_phy(o_alp_bl, alp_bl)
+            ENDIF !iflag_coupl>=1
+      ENDIF !(iflag_con.GE.3)
+! Wakes
+      IF (iflag_con.EQ.3) THEN
+            IF (iflag_wake>=1) THEN
+            CALL histwrite_phy(o_ale_wk, ale_wake)
+            CALL histwrite_phy(o_alp_wk, alp_wake)
+            CALL histwrite_phy(o_ale, ale)
+            CALL histwrite_phy(o_alp, alp)
+            CALL histwrite_phy(o_cin, cin)
+            CALL histwrite_phy(o_WAPE, wake_pe)
+            CALL histwrite_phy(o_wake_h, wake_h)
+            CALL histwrite_phy(o_wake_s, wake_s)
+            CALL histwrite_phy(o_wake_deltat, wake_deltat)
+            CALL histwrite_phy(o_wake_deltaq, wake_deltaq)
+            CALL histwrite_phy(o_wake_omg, wake_omg)
+                  zx_tmp_fi3d(1:klon,1:klev)=d_t_wake(1:klon,1:klev)                 &
+       &                                        /pdtphys
+            CALL histwrite_phy(o_dtwak, zx_tmp_fi3d)
+                  zx_tmp_fi3d(1:klon,1:klev)=d_q_wake(1:klon,1:klev)                 &
+       &                                        /pdtphys
+            CALL histwrite_phy(o_dqwak, zx_tmp_fi3d)
+            ENDIF ! iflag_wake>=1
+            CALL histwrite_phy(o_Vprecip, Vprecip)
+            CALL histwrite_phy(o_ftd, ftd)
+            CALL histwrite_phy(o_fqd, fqd)
+      ELSEIF (iflag_con.EQ.30) THEN
+! sortie RomP convection descente insaturee iflag_con=30
+            CALL histwrite_phy(o_Vprecip, Vprecip)
+            CALL histwrite_phy(o_wdtrainA, wdtrainA)
+            CALL histwrite_phy(o_wdtrainM, wdtrainM)
+      ENDIF !(iflag_con.EQ.3.or.iflag_con.EQ.30)
+
+!!! nrlmd le 10/04/2012
+      IF (iflag_trig_bl>=1) THEN
+            CALL histwrite_phy(o_n2, n2)
+            CALL histwrite_phy(o_s2, s2)
+            CALL histwrite_phy(o_proba_notrig, proba_notrig)
+            CALL histwrite_phy(o_random_notrig, random_notrig)
+            CALL histwrite_phy(o_ale_bl_stat, ale_bl_stat)
+            CALL histwrite_phy(o_ale_bl_trig, ale_bl_trig)
+      ENDIF  !(iflag_trig_bl>=1)
+      
+      IF (iflag_clos_bl>=1) THEN
+            CALL histwrite_phy(o_alp_bl_det, alp_bl_det)
+            CALL histwrite_phy(o_alp_bl_fluct_m, alp_bl_fluct_m)
+            CALL histwrite_phy(o_alp_bl_fluct_tke, alp_bl_fluct_tke)
+            CALL histwrite_phy(o_alp_bl_conv, alp_bl_conv)
+            CALL histwrite_phy(o_alp_bl_stat, alp_bl_stat)
+      ENDIF  !(iflag_clos_bl>=1)
+!!! fin nrlmd le 10/04/2012
+
+      IF (type_ocean=='slab ') THEN
+            CALL histwrite_phy(o_slab_bils, slab_wfbils)
+      ENDIF !type_ocean == force/slab
+
+      CALL histwrite_phy(o_weakinv, weak_inversion)
+      CALL histwrite_phy(o_dthmin, dthmin)
+      CALL histwrite_phy(o_cldtau, cldtau)
+      CALL histwrite_phy(o_cldemi, cldemi)
+      CALL histwrite_phy(o_pr_con_l, pmflxr(:,1:klev))
+      CALL histwrite_phy(o_pr_con_i, pmflxs(:,1:klev))
+      CALL histwrite_phy(o_pr_lsc_l, prfl(:,1:klev))
+      CALL histwrite_phy(o_pr_lsc_i, psfl(:,1:klev))
+      CALL histwrite_phy(o_re, re)
+      CALL histwrite_phy(o_fl, fl)
+      DO i=1, klon
+       zx_tmp_fi2d(i)=MIN(100.,rh2m(i)*100.)
+      ENDDO
+      CALL histwrite_phy(o_rh2m, zx_tmp_fi2d)
+
+      DO i=1, klon
+       zx_tmp_fi2d(i)=MIN(100.,rh2m(i)*100.)
+      ENDDO
+      CALL histwrite_phy(o_rh2m_min, zx_tmp_fi2d)
+      DO i=1, klon
+       zx_tmp_fi2d(i)=MIN(100.,rh2m(i)*100.)
+      ENDDO
+      CALL histwrite_phy(o_rh2m_max, zx_tmp_fi2d)
+
+      CALL histwrite_phy(o_qsat2m, qsat2m)
+      CALL histwrite_phy(o_tpot, tpot)
+      CALL histwrite_phy(o_tpote, tpote)
+      zx_tmp_fi2d(1 : klon) = fsolsw( 1 : klon, is_ter)
+      CALL histwrite_phy(o_SWnetOR,  zx_tmp_fi2d)
+      zx_tmp_fi2d(1:klon) = solsw(1:klon)/(1.-albsol1(1:klon))
+      CALL histwrite_phy(o_SWdownOR,  zx_tmp_fi2d)
+      CALL histwrite_phy(o_LWdownOR, sollwdown)
+      CALL histwrite_phy(o_snowl, snow_lsc)
+      CALL histwrite_phy(o_solldown, sollwdown)
+      CALL histwrite_phy(o_dtsvdfo, d_ts(:,is_oce))
+      CALL histwrite_phy(o_dtsvdft, d_ts(:,is_ter))
+      CALL histwrite_phy(o_dtsvdfg,  d_ts(:,is_lic))
+      CALL histwrite_phy(o_dtsvdfi, d_ts(:,is_sic))
+      CALL histwrite_phy(o_rugs, zxrugs)
+! OD550 per species
+      IF (new_aod .and. (.not. aerosol_couple)) THEN
+          IF (ok_ade.OR.ok_aie) THEN
+      CALL histwrite_phy(o_od550aer, od550aer)
+      CALL histwrite_phy(o_od865aer, od865aer)
+      CALL histwrite_phy(o_absvisaer, absvisaer)
+      CALL histwrite_phy(o_od550lt1aer, od550lt1aer)
+      CALL histwrite_phy(o_sconcso4, sconcso4)
+      CALL histwrite_phy(o_sconcoa, sconcoa)
+      CALL histwrite_phy(o_sconcbc, sconcbc)
+      CALL histwrite_phy(o_sconcss, sconcss)
+      CALL histwrite_phy(o_sconcdust, sconcdust)
+      CALL histwrite_phy(o_concso4, concso4)
+      CALL histwrite_phy(o_concoa, concoa)
+      CALL histwrite_phy(o_concbc, concbc)
+      CALL histwrite_phy(o_concss, concss)
+      CALL histwrite_phy(o_concdust, concdust)
+      CALL histwrite_phy(o_loadso4, loadso4)
+      CALL histwrite_phy(o_loadoa, loadoa)
+      CALL histwrite_phy(o_loadbc, loadbc)
+      CALL histwrite_phy(o_loadss, loadss)
+      CALL histwrite_phy(o_loaddust, loaddust)
+          DO naero = 1, naero_spc
+      CALL histwrite_phy(o_tausumaero(naero),                                        &
+       & tausum_aero(:,2,naero) )
+          END DO
+          endif
+      ENDIF
+       IF (ok_ade) THEN
+      CALL histwrite_phy(o_topswad, topswad_aero)
+      CALL histwrite_phy(o_topswad0, topswad0_aero)
+      CALL histwrite_phy(o_solswad, solswad_aero)
+      CALL histwrite_phy(o_solswad0, solswad0_aero)
+!====MS forcing diagnostics
+        if (new_aod) then	       
+      CALL histwrite_phy(o_swtoaas_nat, topsw_aero(:,1))
+      CALL histwrite_phy(o_swsrfas_nat, solsw_aero(:,1))
+      CALL histwrite_phy(o_swtoacs_nat, topsw0_aero(:,1))
+      CALL histwrite_phy(o_swsrfcs_nat, solsw0_aero(:,1))
+!ant
+      CALL histwrite_phy(o_swtoaas_ant, topsw_aero(:,2))
+      CALL histwrite_phy(o_swsrfas_ant, solsw_aero(:,2))
+      CALL histwrite_phy(o_swtoacs_ant, topsw0_aero(:,2))
+      CALL histwrite_phy(o_swsrfcs_ant, solsw0_aero(:,2))
+!cf
+        if (.not. aerosol_couple) then
+      CALL histwrite_phy(o_swtoacf_nat, topswcf_aero(:,1))
+      CALL histwrite_phy(o_swsrfcf_nat, solswcf_aero(:,1))
+      CALL histwrite_phy(o_swtoacf_ant, topswcf_aero(:,2))
+      CALL histwrite_phy(o_swsrfcf_ant, solswcf_aero(:,2))
+      CALL histwrite_phy(o_swtoacf_zero,topswcf_aero(:,3))
+      CALL histwrite_phy(o_swsrfcf_zero,solswcf_aero(:,3))
+        endif
+	endif ! new_aod
+!====MS forcing diagnostics
+       ENDIF
+       IF (ok_aie) THEN
+      CALL histwrite_phy(o_topswai, topswai_aero)
+      CALL histwrite_phy(o_solswai, solswai_aero)
+      CALL histwrite_phy(o_scdnc, scdnc)
+      CALL histwrite_phy(o_cldncl, cldncl)
+      CALL histwrite_phy(o_reffclws, reffclws)
+      CALL histwrite_phy(o_reffclwc, reffclwc)
+      CALL histwrite_phy(o_cldnvi, cldnvi)
+      CALL histwrite_phy(o_lcc, lcc)
+      CALL histwrite_phy(o_lcc3d, lcc3d)
+      CALL histwrite_phy(o_lcc3dcon, lcc3dcon)
+      CALL histwrite_phy(o_lcc3dstra, lcc3dstra)
+      CALL histwrite_phy(o_reffclwtop, reffclwtop)
+       ENDIF
+! Champs 3D:
+       IF (ok_ade .OR. ok_aie) then
+      CALL histwrite_phy(o_ec550aer, ec550aer)
+       ENDIF
+      CALL histwrite_phy(o_lwcon, flwc)
+      CALL histwrite_phy(o_iwcon, fiwc)
+      CALL histwrite_phy(o_temp, t_seri)
+      CALL histwrite_phy(o_theta, theta)
+      CALL histwrite_phy(o_ovapinit, qx(:,:,ivap))
+      CALL histwrite_phy(o_ovap, q_seri)
+      CALL histwrite_phy(o_oliq, ql_seri)
+      CALL histwrite_phy(o_geop, zphi)
+      CALL histwrite_phy(o_vitu, u_seri)
+      CALL histwrite_phy(o_vitv, v_seri)
+      CALL histwrite_phy(o_vitw, omega)
+      CALL histwrite_phy(o_pres, pplay)
+      CALL histwrite_phy(o_paprs, paprs(:,1:klev))
+         DO i=1, klon
+          zx_tmp_fi3d1(i,1)= pphis(i)/RG
+!020611   zx_tmp_fi3d(i,1)= pphis(i)/RG
+         ENDDO
+         DO k=1, klev
+!020611        DO k=1, klev-1
+         DO i=1, klon
+!020611         zx_tmp_fi3d(i,k+1)= zx_tmp_fi3d(i,k) - (t_seri(i,k) *RD * 
+          zx_tmp_fi3d1(i,k+1)= zx_tmp_fi3d1(i,k) - (t_seri(i,k) *RD *                &
+       &    (paprs(i,k+1) - paprs(i,k))) / ( pplay(i,k) * RG ) 
+         ENDDO
+         ENDDO
+      CALL histwrite_phy(o_zfull,zx_tmp_fi3d1(:,2:klevp1))
+!020611    $o_zfull%name,itau_w,zx_tmp_fi3d)
+         DO i=1, klon
+          zx_tmp_fi3d(i,1)= pphis(i)/RG - (                                          &
+       &    (t_seri(i,1)+zxtsol(i))/2. *RD *                                         &
+       &    (pplay(i,1) - paprs(i,1)))/((paprs(i,1)+pplay(i,1))/2. * RG)
+         ENDDO
+         DO k=1, klev-1
+         DO i=1, klon
+          zx_tmp_fi3d(i,k+1)= zx_tmp_fi3d(i,k) - (                                   &
+       &    (t_seri(i,k)+t_seri(i,k+1))/2. *RD *                                     &
+       &    (pplay(i,k+1) - pplay(i,k))) / ( paprs(i,k) * RG ) 
+         ENDDO
+         ENDDO
+      CALL histwrite_phy(o_zhalf, zx_tmp_fi3d)
+      CALL histwrite_phy(o_rneb, cldfra)
+      CALL histwrite_phy(o_rnebcon, rnebcon)
+      CALL histwrite_phy(o_rnebls, rneb)
+      CALL histwrite_phy(o_rhum, zx_rh)
+      CALL histwrite_phy(o_ozone, wo(:, :, 1)                                        &
+       & * dobson_u * 1e3 / zmasse / rmo3 * rmd)
+      IF (read_climoz == 2) THEN
+      CALL histwrite_phy(o_ozone_light, wo(:, :, 2)                                  &
+       & * dobson_u * 1e3 / zmasse / rmo3 * rmd)
+      ENDIF
+      CALL histwrite_phy(o_dtphy, d_t)
+      CALL histwrite_phy(o_dqphy,  d_qx(:,:,ivap))
+        DO nsrf=1, nbsrf
+        zx_tmp_fi2d(1 : klon) = falb1( 1 : klon, nsrf)
+      CALL histwrite_phy(o_albe_srf(nsrf), zx_tmp_fi2d)
+        zx_tmp_fi2d(1 : klon) = frugs( 1 : klon, nsrf)
+      CALL histwrite_phy(o_rugs_srf(nsrf), zx_tmp_fi2d)
+        zx_tmp_fi2d(1 : klon) = agesno( 1 : klon, nsrf)
+      CALL histwrite_phy(o_ages_srf(nsrf), zx_tmp_fi2d)
+        ENDDO !nsrf=1, nbsrf
+      CALL histwrite_phy(o_alb1, albsol1)
+      CALL histwrite_phy(o_alb2, albsol2)
+!FH Sorties pour la couche limite
+      if (iflag_pbl>1) then
+      zx_tmp_fi3d=0.
+      do nsrf=1,nbsrf
+         do k=1,klev
+          zx_tmp_fi3d(:,k)=zx_tmp_fi3d(:,k)                                          &
+       &    +pctsrf(:,nsrf)*pbl_tke(:,k,nsrf)
+         enddo
+      enddo
+      CALL histwrite_phy(o_tke, zx_tmp_fi3d)
+
+      CALL histwrite_phy(o_tke_max, zx_tmp_fi3d)
+
+      endif
+      CALL histwrite_phy(o_kz, coefh(:,:,is_ave))
+
+      CALL histwrite_phy(o_kz_max, coefh(:,:,is_ave))
+
+      CALL histwrite_phy(o_clwcon, clwcon0)
+      CALL histwrite_phy(o_dtdyn, d_t_dyn)
+      CALL histwrite_phy(o_dqdyn, d_q_dyn)
+      CALL histwrite_phy(o_dudyn, d_u_dyn)
+      CALL histwrite_phy(o_dvdyn, d_v_dyn)
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dtcon, zx_tmp_fi3d)
+      if(iflag_thermals.eq.1)then
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys +                    &
+       &                           d_t_ajsb(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_tntc, zx_tmp_fi3d)
+      else if(iflag_thermals.gt.1.and.iflag_wake.EQ.1)then
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys +                    &
+       &                           d_t_ajs(1:klon,1:klev)/pdtphys +                  &
+       &                           d_t_wake(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_tntc, zx_tmp_fi3d)
+      endif
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_con(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_ducon, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_con(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dvcon, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dqcon, zx_tmp_fi3d)
+      if(iflag_thermals.eq.1)then
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_tnhusc, zx_tmp_fi3d)
+      else if(iflag_thermals.gt.1.and.iflag_wake.EQ.1)then
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys +                    &
+       &                           d_q_ajs(1:klon,1:klev)/pdtphys +                  &
+       &                           d_q_wake(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_tnhusc, zx_tmp_fi3d)
+      endif
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_lsc(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dtlsc, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon, 1:klev)=(d_t_lsc(1:klon,1:klev)+                           &
+       &                           d_t_eva(1:klon,1:klev))/pdtphys
+      CALL histwrite_phy(o_dtlschr, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dqlsc, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=beta_prec(1:klon,1:klev)
+      CALL histwrite_phy(o_beta_prec, zx_tmp_fi3d)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Sorties specifiques a la separation thermiques/non thermiques
+       if (iflag_thermals>=1) then
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_lscth(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dtlscth, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_lscst(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dtlscst, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_lscth(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dqlscth, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_lscst(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dqlscst, zx_tmp_fi3d)
+      CALL histwrite_phy(o_plulth, plul_th)
+      CALL histwrite_phy(o_plulst, plul_st)
+      do k=1,klev
+      do i=1,klon
+          if (ptconvth(i,k)) then
+           zx_tmp_fi3d(i,k)=1.
+          else
+           zx_tmp_fi3d(i,k)=0.
+          endif
+      enddo
+      enddo
+      CALL histwrite_phy(o_ptconvth, zx_tmp_fi3d)
+      do i=1,klon
+           zx_tmp_fi2d(1:klon)=lmax_th(:)
+      enddo
+      CALL histwrite_phy(o_lmaxth, zx_tmp_fi2d)
+      endif ! iflag_thermals>=1
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_vdf(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dtvdf, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_diss(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dtdis, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_vdf(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dqvdf, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_eva(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dteva, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_eva(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dqeva, zx_tmp_fi3d)
+      zpt_conv = 0.
+      where (ptconv) zpt_conv = 1.
+      CALL histwrite_phy(o_ptconv, zpt_conv)
+      CALL histwrite_phy(o_ratqs, ratqs)
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ajs(1:klon,1:klev)/pdtphys -                    &
+       &                           d_t_ajsb(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dtthe, zx_tmp_fi3d)
+       IF (iflag_thermals>=1) THEN
+! Pour l instant 0 a y reflichir pour les thermiques
+         zx_tmp_fi2d=0. 
+      CALL histwrite_phy(o_ftime_th, zx_tmp_fi2d)
+      CALL histwrite_phy(o_f_th, fm_therm)
+      CALL histwrite_phy(o_e_th, entr_therm)
+      CALL histwrite_phy(o_w_th, zw2)
+      CALL histwrite_phy(o_q_th, zqasc)
+      CALL histwrite_phy(o_a_th, fraca)
+      CALL histwrite_phy(o_d_th, detr_therm)
+      CALL histwrite_phy(o_f0_th, f0)
+      CALL histwrite_phy(o_zmax_th, zmax_th)
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajs(1:klon,1:klev)/pdtphys -                    &
+       &                           d_q_ajsb(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dqthe, zx_tmp_fi3d)
+      ENDIF !iflag_thermals
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ajsb(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dtajs, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_ajsb(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dqajs, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)/RDAY
+      CALL histwrite_phy(o_dtswr, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=heat0(1:klon,1:klev)/RDAY
+      CALL histwrite_phy(o_dtsw0, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool(1:klon,1:klev)/RDAY
+      CALL histwrite_phy(o_dtlwr, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=-1.*cool0(1:klon,1:klev)/RDAY
+      CALL histwrite_phy(o_dtlw0, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_ec(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dtec, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_vdf(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_duvdf, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_vdf(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dvvdf, zx_tmp_fi3d)
+       IF (ok_orodr) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_oro(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_duoro, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_oro(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dvoro, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_oro(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dtoro, zx_tmp_fi3d)
+       ENDIF
+       
+        IF (ok_orolf) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_lif(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dulif, zx_tmp_fi3d)
+       ENDIF
+       
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_lif(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dvlif, zx_tmp_fi3d)
+      
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_lif(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dtlif, zx_tmp_fi3d)
+      
+       IF (ok_hines) THEN
+      zx_tmp_fi3d(1:klon,1:klev)=d_u_hin(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_duhin, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_v_hin(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dvhin, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_t_hin(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_dthin, zx_tmp_fi3d)
+        ENDIF
+      CALL histwrite_phy(o_rsu, swup)
+      CALL histwrite_phy(o_rsd, swdn)
+      CALL histwrite_phy(o_rlu, lwup)
+      CALL histwrite_phy(o_rld, lwdn)
+      CALL histwrite_phy(o_rsucs, swup0)
+      CALL histwrite_phy(o_rsdcs, swdn0)
+      CALL histwrite_phy(o_rlucs, lwup0)
+      CALL histwrite_phy(o_rldcs, lwdn0)
+      zx_tmp_fi3d(1:klon,1:klev)=d_t(1:klon,1:klev)+                                 &
+       &d_t_dyn(1:klon,1:klev)
+      CALL histwrite_phy(o_tnt, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=heat(1:klon,1:klev)/RDAY -                          &
+       &cool(1:klon,1:klev)/RDAY
+      CALL histwrite_phy(o_tntr, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)= (d_t_lsc(1:klon,1:klev)+                           &
+       &                             d_t_eva(1:klon,1:klev)+                         &
+       &                             d_t_vdf(1:klon,1:klev))/pdtphys
+      CALL histwrite_phy(o_tntscpbl, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_qx(1:klon,1:klev,ivap)+                           &
+       &d_q_dyn(1:klon,1:klev)
+      CALL histwrite_phy(o_tnhus, zx_tmp_fi3d)
+      zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys+                     &
+       &                           d_q_eva(1:klon,1:klev)/pdtphys
+      CALL histwrite_phy(o_tnhusscpbl, zx_tmp_fi3d)
+      CALL histwrite_phy(o_evu, coefm(:,:,is_ave))
+      zx_tmp_fi3d(1:klon,1:klev)=q_seri(1:klon,1:klev)+                              &
+       &                           ql_seri(1:klon,1:klev) 
+      CALL histwrite_phy(o_h2o, zx_tmp_fi3d)
+       if (iflag_con >= 3) then
+             zx_tmp_fi3d(1:klon,1:klev)=-1 * (dnwd(1:klon,1:klev)+                   &
+       &            dnwd0(1:klon,1:klev)) 
+      CALL histwrite_phy(o_mcd, zx_tmp_fi3d)
+             zx_tmp_fi3d(1:klon,1:klev)=upwd(1:klon,1:klev) +                        &
+       &            dnwd(1:klon,1:klev)+ dnwd0(1:klon,1:klev) 
+      CALL histwrite_phy(o_dmc, zx_tmp_fi3d)
+       else if (iflag_con == 2) then
+      CALL histwrite_phy(o_mcd,  pmfd)
+      CALL histwrite_phy(o_dmc,  pmfu + pmfd)
+       end if
+      CALL histwrite_phy(o_ref_liq, ref_liq)
+      CALL histwrite_phy(o_ref_ice, ref_ice)
+      if (RCO2_per.NE.RCO2_act.OR.RCH4_per.NE.RCH4_act.OR.                           &
+       & RN2O_per.NE.RN2O_act.OR.RCFC11_per.NE.RCFC11_act.OR.                        &
+       & RCFC12_per.NE.RCFC12_act) THEN
+      zx_tmp_fi2d(1 : klon) = swupp ( 1 : klon, klevp1 )
+      CALL histwrite_phy(o_rsut4co2, zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = lwupp ( 1 : klon, klevp1 )
+      CALL histwrite_phy(o_rlut4co2, zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = swup0p ( 1 : klon, klevp1 )
+      CALL histwrite_phy(o_rsutcs4co2, zx_tmp_fi2d)
+      zx_tmp_fi2d(1 : klon) = lwup0p ( 1 : klon, klevp1 )
+      CALL histwrite_phy(o_rlutcs4co2, zx_tmp_fi2d)
+      CALL histwrite_phy(o_rsu4co2, swupp)
+      CALL histwrite_phy(o_rlu4co2, lwupp)
+      CALL histwrite_phy(o_rsucs4co2, swup0p)
+      CALL histwrite_phy(o_rlucs4co2, lwup0p)
+      CALL histwrite_phy(o_rsd4co2, swdnp)
+      CALL histwrite_phy(o_rld4co2, lwdnp)
+      CALL histwrite_phy(o_rsdcs4co2, swdn0p)
+      CALL histwrite_phy(o_rldcs4co2, lwdn0p)
+      endif
+        if (nqtot.GE.3) THEN
+         DO iq=3,nqtot
+      CALL histwrite_phy(o_trac(iq-2), qx(:,:,iq))
+         ENDDO
+         DO iq=3,nqtot
+         zx_tmp_fi2d=0.
+         do k=1,klev
+            zx_tmp_fi2d(:)=zx_tmp_fi2d(:)+zmasse(:,k)*qx(:,k,iq)
+         enddo
+      CALL histwrite_phy(o_trac_cum(iq-2), zx_tmp_fi2d)
+         ENDDO
+        endif
+!       ENDIF ! clef_files
+
+      DO iff=1,nfiles
+          IF (ok_sync .AND. clef_files(iff)) THEN
+!$OMP MASTER
+              CALL histsync(nid_files(iff))
+!$OMP END MASTER
+          ENDIF
+      END DO
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_state_var_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_state_var_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phys_state_var_mod.F90	(revision 17)
@@ -0,0 +1,633 @@
+!
+! $Id: phys_state_var_mod.F90 1795 2013-07-18 08:20:28Z emillour $
+!
+      MODULE phys_state_var_mod
+! Variables sauvegardees pour le startphy.nc
+!======================================================================
+!
+!
+!======================================================================
+! Declaration des variables
+      USE dimphy
+      INTEGER, PARAMETER :: nlevSTD=17
+      INTEGER, PARAMETER :: nlevSTD8=8
+      INTEGER, PARAMETER :: nlevSTD3=3
+      INTEGER, PARAMETER :: nout=3
+      INTEGER, PARAMETER :: napisccp=1
+      INTEGER, SAVE :: radpas
+!$OMP THREADPRIVATE(radpas)
+      REAL, SAVE :: dtime, solaire_etat0
+!$OMP THREADPRIVATE(dtime, solaire_etat0)
+
+      REAL, ALLOCATABLE, SAVE :: rlat(:), rlon(:), pctsrf(:,:)
+!$OMP THREADPRIVATE(rlat, rlon, pctsrf)
+      REAL, ALLOCATABLE, SAVE :: ftsol(:,:)
+!$OMP THREADPRIVATE(ftsol)
+!      character(len=6), SAVE :: ocean
+!!!!!!$OMP THREADPRIVATE(ocean)
+!      logical, SAVE :: ok_veget 
+!!!!!!$OMP THREADPRIVATE(ok_veget)
+      REAL, ALLOCATABLE, SAVE :: falb1(:,:), falb2(:,:)
+!$OMP THREADPRIVATE(falb1, falb2)
+      REAL, ALLOCATABLE, SAVE :: rain_fall(:), snow_fall(:)
+!$OMP THREADPRIVATE( rain_fall, snow_fall)
+      REAL, ALLOCATABLE, SAVE :: solsw(:), sollw(:)
+!$OMP THREADPRIVATE(solsw, sollw)
+      REAL, ALLOCATABLE, SAVE :: radsol(:)
+!$OMP THREADPRIVATE(radsol)
+
+!clesphy0 param physiq
+!
+! Parametres de l'Orographie a l'Echelle Sous-Maille (OESM):
+!
+      REAL, ALLOCATABLE, SAVE :: zmea(:), zstd(:), zsig(:), zgam(:)
+!$OMP THREADPRIVATE(zmea, zstd, zsig, zgam)
+      REAL, ALLOCATABLE, SAVE :: zthe(:), zpic(:), zval(:)
+!$OMP THREADPRIVATE(zthe, zpic, zval)
+!     REAL tabcntr0(100)
+      REAL, ALLOCATABLE, SAVE :: rugoro(:)
+!$OMP THREADPRIVATE(rugoro)
+      REAL, ALLOCATABLE, SAVE :: t_ancien(:,:), q_ancien(:,:)
+!$OMP THREADPRIVATE(t_ancien, q_ancien)
+      REAL, ALLOCATABLE, SAVE :: u_ancien(:,:), v_ancien(:,:)
+!$OMP THREADPRIVATE(u_ancien, v_ancien)
+!!! RomP >>>
+      REAL, ALLOCATABLE, SAVE :: tr_ancien(:,:,:)
+!$OMP THREADPRIVATE(tr_ancien)
+!!! RomP <<<
+      LOGICAL, SAVE :: ancien_ok
+!$OMP THREADPRIVATE(ancien_ok)
+      REAL, ALLOCATABLE, SAVE :: clwcon(:,:),rnebcon(:,:)
+!$OMP THREADPRIVATE(clwcon,rnebcon)
+      REAL, ALLOCATABLE, SAVE :: ratqs(:,:)
+!$OMP THREADPRIVATE(ratqs)
+      REAL, ALLOCATABLE, SAVE :: pbl_tke(:,:,:) ! turb kinetic energy
+      REAL, ALLOCATABLE, SAVE :: coefh(:,:,:) ! Kz enthalpie
+      REAL, ALLOCATABLE, SAVE :: coefm(:,:,:) ! Kz momentum
+!$OMP THREADPRIVATE(pbl_tke, coefh,coefm)
+      REAL, ALLOCATABLE, SAVE :: zmax0(:), f0(:) ! 
+!$OMP THREADPRIVATE(zmax0,f0)
+      REAL, ALLOCATABLE, SAVE :: ema_work1(:,:), ema_work2(:,:)
+!$OMP THREADPRIVATE(ema_work1,ema_work2)
+      REAL, ALLOCATABLE, SAVE :: entr_therm(:,:), fm_therm(:,:)
+!$OMP THREADPRIVATE(entr_therm,fm_therm)
+      REAL, ALLOCATABLE, SAVE :: detr_therm(:,:)
+!$OMP THREADPRIVATE(detr_therm)
+!IM 150408
+!     pour phsystoke avec thermiques
+      REAL,ALLOCATABLE,SAVE :: clwcon0th(:,:),rnebcon0th(:,:)
+!$OMP THREADPRIVATE(clwcon0th,rnebcon0th)
+! radiation outputs
+      REAL,ALLOCATABLE,SAVE :: swdn0(:,:), swdn(:,:)
+!$OMP THREADPRIVATE(swdn0,swdn)
+      REAL,ALLOCATABLE,SAVE :: swup0(:,:), swup(:,:)
+!$OMP THREADPRIVATE(swup0,swup)
+      REAL,ALLOCATABLE,SAVE :: SWdn200clr(:), SWdn200(:)
+!$OMP THREADPRIVATE(SWdn200clr,SWdn200)
+      REAL,ALLOCATABLE,SAVE :: SWup200clr(:), SWup200(:)
+!$OMP THREADPRIVATE(SWup200clr,SWup200)
+      REAL,ALLOCATABLE,SAVE :: lwdn0(:,:), lwdn(:,:)
+!$OMP THREADPRIVATE(lwdn0,lwdn)
+      REAL,ALLOCATABLE,SAVE :: lwup0(:,:), lwup(:,:)
+!$OMP THREADPRIVATE(lwup0,lwup)
+      REAL,ALLOCATABLE,SAVE :: LWdn200clr(:), LWdn200(:)
+!$OMP THREADPRIVATE(LWdn200clr,LWdn200)
+      REAL,ALLOCATABLE,SAVE :: LWup200clr(:), LWup200(:)
+!$OMP THREADPRIVATE(LWup200clr,LWup200)
+      REAL,ALLOCATABLE,SAVE :: LWdnTOA(:), LWdnTOAclr(:)
+!$OMP THREADPRIVATE(LWdnTOA,LWdnTOAclr)
+! pressure level
+      REAL,ALLOCATABLE,SAVE :: tsumSTD(:,:,:)
+!$OMP THREADPRIVATE(tsumSTD)
+      REAL,ALLOCATABLE,SAVE :: usumSTD(:,:,:), vsumSTD(:,:,:)
+!$OMP THREADPRIVATE(usumSTD,vsumSTD)
+      REAL,ALLOCATABLE,SAVE :: wsumSTD(:,:,:), phisumSTD(:,:,:)
+!$OMP THREADPRIVATE(wsumSTD,phisumSTD)
+      REAL,ALLOCATABLE,SAVE :: qsumSTD(:,:,:), rhsumSTD(:,:,:)
+!$OMP THREADPRIVATE(qsumSTD,rhsumSTD)
+      REAL,ALLOCATABLE,SAVE :: tnondef(:,:,:) 
+!$OMP THREADPRIVATE(tnondef)
+      REAL,ALLOCATABLE,SAVE :: uvsumSTD(:,:,:)
+!$OMP THREADPRIVATE(uvsumSTD)
+      REAL,ALLOCATABLE,SAVE :: vqsumSTD(:,:,:)
+!$OMP THREADPRIVATE(vqsumSTD)
+      REAL,ALLOCATABLE,SAVE :: vTsumSTD(:,:,:)
+!$OMP THREADPRIVATE(vTsumSTD)
+      REAL,ALLOCATABLE,SAVE :: wqsumSTD(:,:,:)
+!$OMP THREADPRIVATE(wqsumSTD)
+      REAL,ALLOCATABLE,SAVE :: vphisumSTD(:,:,:)
+!$OMP THREADPRIVATE(vphisumSTD)
+      REAL,ALLOCATABLE,SAVE :: wTsumSTD(:,:,:)
+!$OMP THREADPRIVATE(wTsumSTD)
+      REAL,ALLOCATABLE,SAVE :: u2sumSTD(:,:,:)
+!$OMP THREADPRIVATE(u2sumSTD)
+      REAL,ALLOCATABLE,SAVE :: v2sumSTD(:,:,:)
+!$OMP THREADPRIVATE(v2sumSTD)
+      REAL,ALLOCATABLE,SAVE :: T2sumSTD(:,:,:)
+!$OMP THREADPRIVATE(T2sumSTD)
+      REAL,ALLOCATABLE,SAVE :: O3sumSTD(:,:,:), O3daysumSTD(:,:,:)
+!$OMP THREADPRIVATE(O3sumSTD,O3daysumSTD) 
+!IM begin
+      REAL,ALLOCATABLE,SAVE :: wlevSTD(:,:), ulevSTD(:,:), vlevSTD(:,:)
+!$OMP THREADPRIVATE(wlevSTD,ulevSTD,vlevSTD)
+      REAL,ALLOCATABLE,SAVE :: tlevSTD(:,:), qlevSTD(:,:), rhlevSTD(:,:)
+!$OMP THREADPRIVATE(tlevSTD,qlevSTD,rhlevSTD)
+      REAL,ALLOCATABLE,SAVE :: philevSTD(:,:)
+!$OMP THREADPRIVATE(philevSTD)
+      REAL,ALLOCATABLE,SAVE :: uvSTD(:,:)
+!$OMP THREADPRIVATE(uvSTD)
+      REAL,ALLOCATABLE,SAVE :: vqSTD(:,:)
+!$OMP THREADPRIVATE(vqSTD)
+      REAL,ALLOCATABLE,SAVE :: vTSTD(:,:)
+!$OMP THREADPRIVATE(vTSTD)
+      REAL,ALLOCATABLE,SAVE :: wqSTD(:,:)
+!$OMP THREADPRIVATE(wqSTD)
+      REAL,ALLOCATABLE,SAVE :: vphiSTD(:,:)
+!$OMP THREADPRIVATE(vphiSTD)
+      REAL,ALLOCATABLE,SAVE :: wTSTD(:,:)
+!$OMP THREADPRIVATE(wTSTD)
+      REAL,ALLOCATABLE,SAVE :: u2STD(:,:)
+!$OMP THREADPRIVATE(u2STD)
+      REAL,ALLOCATABLE,SAVE :: v2STD(:,:) 
+!$OMP THREADPRIVATE(v2STD)
+      REAL,ALLOCATABLE,SAVE :: T2STD(:,:)
+!$OMP THREADPRIVATE(T2STD)
+      REAL,ALLOCATABLE,SAVE :: O3STD(:,:), O3daySTD(:,:)
+!$OMP THREADPRIVATE(O3STD,O3daySTD)
+!IM end
+      INTEGER,ALLOCATABLE,SAVE :: seed_old(:,:)
+!$OMP THREADPRIVATE(seed_old)
+      REAL,ALLOCATABLE,SAVE :: zuthe(:),zvthe(:)
+!$OMP THREADPRIVATE(zuthe,zvthe)
+      REAL,ALLOCATABLE,SAVE :: alb_neig(:)
+!$OMP THREADPRIVATE(alb_neig)
+!cloud base mass flux
+      REAL,ALLOCATABLE,SAVE :: ema_cbmf(:)
+!$OMP THREADPRIVATE(ema_cbmf)
+!cloud base pressure & cloud top pressure
+      REAL,ALLOCATABLE,SAVE :: ema_pcb(:), ema_pct(:)
+!$OMP THREADPRIVATE(ema_pcb,ema_pct)
+      REAL,ALLOCATABLE,SAVE :: Ma(:,:)        ! undilute upward mass flux
+!$OMP THREADPRIVATE(Ma)
+      REAL,ALLOCATABLE,SAVE :: qcondc(:,:)    ! in-cld water content from convect
+!$OMP THREADPRIVATE(qcondc)
+      REAL,ALLOCATABLE,SAVE :: wd(:) ! sb
+!$OMP THREADPRIVATE(wd)
+      REAL,ALLOCATABLE,SAVE :: sigd(:)
+!$OMP THREADPRIVATE(sigd)
+!
+      REAL,ALLOCATABLE,SAVE :: cin(:)
+!$OMP THREADPRIVATE(cin)
+! ftd : differential heating between wake and environment
+      REAL,ALLOCATABLE,SAVE :: ftd(:,:)
+!$OMP THREADPRIVATE(ftd)
+! fqd : differential moistening between wake and environment
+      REAL,ALLOCATABLE,SAVE :: fqd(:,:)     
+!$OMP THREADPRIVATE(fqd)
+!34EK
+! -- Variables de controle de ALE et ALP
+!ALE : Energie disponible pour soulevement : utilisee par la 
+!      convection d'Emanuel pour le declenchement et la regulation
+      REAL,ALLOCATABLE,SAVE :: ALE(:)
+!$OMP THREADPRIVATE(ALE)
+!ALP : Puissance  disponible pour soulevement
+      REAL,ALLOCATABLE,SAVE :: ALP(:)
+!$OMP THREADPRIVATE(ALP)
+!
+! nouvelles variables pour le couplage convection-couche limite
+      REAL,ALLOCATABLE,SAVE :: Ale_bl(:)
+!$OMP THREADPRIVATE(Ale_bl)
+      REAL,ALLOCATABLE,SAVE :: Alp_bl(:)
+!$OMP THREADPRIVATE(Alp_bl)
+      INTEGER,ALLOCATABLE,SAVE :: lalim_conv(:)
+!$OMP THREADPRIVATE(lalim_conv)
+      REAL,ALLOCATABLE,SAVE :: wght_th(:,:)
+!$OMP THREADPRIVATE(wght_th)
+!
+! variables de la wake
+! wake_deltat : ecart de temperature avec la zone non perturbee
+! wake_deltaq : ecart d'humidite avec la zone non perturbee
+! wake_Cstar  : vitesse d'etalement de la poche
+! wake_s      : fraction surfacique occupee par la poche froide
+! wake_pe     : wake potential energy - WAPE
+! wake_fip    : Gust Front Impinging power - ALP
+! dt_wake, dq_wake: LS tendencies due to wake
+      REAL,ALLOCATABLE,SAVE :: wake_deltat(:,:)
+!$OMP THREADPRIVATE(wake_deltat)
+      REAL,ALLOCATABLE,SAVE :: wake_deltaq(:,:)
+!$OMP THREADPRIVATE(wake_deltaq)
+      REAL,ALLOCATABLE,SAVE :: wake_Cstar(:)
+!$OMP THREADPRIVATE(wake_Cstar)
+      REAL,ALLOCATABLE,SAVE :: wake_s(:)
+!$OMP THREADPRIVATE(wake_s)
+      REAL,ALLOCATABLE,SAVE :: wake_pe(:)
+!$OMP THREADPRIVATE(wake_pe)
+      REAL,ALLOCATABLE,SAVE :: wake_fip(:)
+!$OMP THREADPRIVATE(wake_fip)
+      REAL,ALLOCATABLE,SAVE :: dt_wake(:,:)
+!$OMP THREADPRIVATE(dt_wake)
+      REAL,ALLOCATABLE,SAVE :: dq_wake(:,:)
+!$OMP THREADPRIVATE(dq_wake)
+!
+! pfrac_impa : Produits des coefs lessivage impaction
+! pfrac_nucl : Produits des coefs lessivage nucleation
+! pfrac_1nucl: Produits des coefs lessi nucl (alpha = 1) 
+      REAL,ALLOCATABLE,SAVE :: pfrac_impa(:,:), pfrac_nucl(:,:)
+!$OMP THREADPRIVATE(pfrac_impa,pfrac_nucl)
+      REAL,ALLOCATABLE,SAVE :: pfrac_1nucl(:,:)
+!$OMP THREADPRIVATE(pfrac_1nucl)
+!
+      REAL,ALLOCATABLE,SAVE :: total_rain(:), nday_rain(:)  
+!$OMP THREADPRIVATE(total_rain,nday_rain)
+      REAL,ALLOCATABLE,SAVE :: paire_ter(:)
+!$OMP THREADPRIVATE(paire_ter)
+! albsol1: albedo du sol total pour SW visible
+! albsol2: albedo du sol total pour SW proche IR
+      REAL,ALLOCATABLE,SAVE :: albsol1(:), albsol2(:)
+!$OMP THREADPRIVATE(albsol1,albsol2)
+
+      REAL, ALLOCATABLE, SAVE:: wo(:, :, :)
+      ! column-density of ozone in a layer, in kilo-Dobsons
+      ! Third dimension has size 1 or 2.
+      ! "wo(:, :, 1)" is for the average day-night field, 
+      ! "wo(:, :, 2)" is for daylight time.
+      !$OMP THREADPRIVATE(wo)
+
+! heat : chauffage solaire
+! heat0: chauffage solaire ciel clair
+! cool : refroidissement infrarouge
+! cool0 : refroidissement infrarouge ciel clair
+! sollwdown : downward LW flux at surface
+! sollwdownclr : downward CS LW flux at surface
+! toplwdown : downward CS LW flux at TOA
+! toplwdownclr : downward CS LW flux at TOA
+      REAL,ALLOCATABLE,SAVE :: clwcon0(:,:),rnebcon0(:,:)
+!$OMP THREADPRIVATE(clwcon0,rnebcon0)
+      REAL,ALLOCATABLE,SAVE :: heat(:,:)   
+!$OMP THREADPRIVATE(heat)
+      REAL,ALLOCATABLE,SAVE :: heat0(:,:)
+!$OMP THREADPRIVATE(heat0)
+      REAL,ALLOCATABLE,SAVE :: cool(:,:)
+!$OMP THREADPRIVATE(cool)
+      REAL,ALLOCATABLE,SAVE :: cool0(:,:)
+!$OMP THREADPRIVATE(cool0)
+      REAL,ALLOCATABLE,SAVE :: topsw(:), toplw(:)
+!$OMP THREADPRIVATE(topsw,toplw)
+      REAL,ALLOCATABLE,SAVE :: sollwdown(:)
+!$OMP THREADPRIVATE(sollwdown)
+      REAL,ALLOCATABLE,SAVE :: sollwdownclr(:)
+!$OMP THREADPRIVATE(sollwdownclr)
+      REAL,ALLOCATABLE,SAVE :: toplwdown(:)
+!$OMP THREADPRIVATE(toplwdown)
+      REAL,ALLOCATABLE,SAVE :: toplwdownclr(:)
+!$OMP THREADPRIVATE(toplwdownclr)
+      REAL,ALLOCATABLE,SAVE :: topsw0(:),toplw0(:),solsw0(:),sollw0(:)
+!$OMP THREADPRIVATE(topsw0,toplw0,solsw0,sollw0)
+      REAL,ALLOCATABLE,SAVE :: albpla(:)
+!$OMP THREADPRIVATE(albpla)
+
+!IM ajout variables CFMIP2/CMIP5
+      REAL,ALLOCATABLE,SAVE :: heatp(:,:), coolp(:,:)
+!$OMP THREADPRIVATE(heatp, coolp)
+      REAL,ALLOCATABLE,SAVE :: heat0p(:,:), cool0p(:,:)
+!$OMP THREADPRIVATE(heat0p, cool0p)
+      REAL,ALLOCATABLE,SAVE :: radsolp(:), topswp(:), toplwp(:)
+!$OMP THREADPRIVATE(radsolp, topswp, toplwp)
+      REAL,ALLOCATABLE,SAVE :: albplap(:)
+!$OMP THREADPRIVATE(albplap)
+      REAL,ALLOCATABLE,SAVE :: solswp(:), sollwp(:)
+!$OMP THREADPRIVATE(solswp, sollwp)
+      REAL,ALLOCATABLE,SAVE :: sollwdownp(:)
+!$OMP THREADPRIVATE(sollwdownp)
+      REAL,ALLOCATABLE,SAVE :: topsw0p(:),toplw0p(:)
+      REAL,ALLOCATABLE,SAVE :: solsw0p(:),sollw0p(:)
+!$OMP THREADPRIVATE(topsw0p,toplw0p,solsw0p,sollw0p)
+      REAL,ALLOCATABLE,SAVE :: lwdn0p(:,:), lwdnp(:,:)
+      REAL,ALLOCATABLE,SAVE :: lwup0p(:,:), lwupp(:,:)
+!$OMP THREADPRIVATE(lwdn0p, lwdnp, lwup0p, lwupp)
+      REAL,ALLOCATABLE,SAVE :: swdn0p(:,:), swdnp(:,:)
+      REAL,ALLOCATABLE,SAVE :: swup0p(:,:), swupp(:,:)
+!$OMP THREADPRIVATE(swdn0p, swdnp, swup0p, swupp)
+
+! pbase : cloud base pressure
+! bbase : cloud base buoyancy
+      REAL,ALLOCATABLE,SAVE :: cape(:)
+!$OMP THREADPRIVATE(cape)
+      REAL,ALLOCATABLE,SAVE :: pbase(:)
+!$OMP THREADPRIVATE(pbase)
+      REAL,ALLOCATABLE,SAVE :: bbase(:)
+!$OMP THREADPRIVATE(bbase)
+!
+      REAL,SAVE,ALLOCATABLE :: zqasc(:,:)
+!$OMP THREADPRIVATE( zqasc)
+      INTEGER,ALLOCATABLE,SAVE :: ibas_con(:), itop_con(:)
+!$OMP THREADPRIVATE(ibas_con,itop_con)
+      REAL,SAVE,ALLOCATABLE :: rain_con(:)
+!$OMP THREADPRIVATE(rain_con)
+      REAL,SAVE,ALLOCATABLE :: snow_con(:)
+!$OMP THREADPRIVATE(snow_con)
+!
+      REAL,SAVE,ALLOCATABLE :: rlonPOS(:)
+!$OMP THREADPRIVATE(rlonPOS)
+      REAL,SAVE,ALLOCATABLE :: newsst(:)
+!$OMP THREADPRIVATE(newsst)
+      REAL,SAVE,ALLOCATABLE :: ustar(:,:),u10m(:,:), v10m(:,:)
+!$OMP THREADPRIVATE(ustar,u10m,v10m)
+!
+! ok_ade=T -ADE=topswad-topsw
+! ok_aie=T ->
+!       ok_ade=T -AIE=topswai-topswad
+!       ok_ade=F -AIE=topswai-topsw
+!
+!topswad, solswad : Aerosol direct effect
+      REAL,SAVE,ALLOCATABLE :: topswad(:), solswad(:)
+!$OMP THREADPRIVATE(topswad,solswad)
+!topswai, solswai : Aerosol indirect effect
+      REAL,SAVE,ALLOCATABLE :: topswai(:), solswai(:)
+!$OMP THREADPRIVATE(topswai,solswai)
+
+      REAL,SAVE,ALLOCATABLE :: tau_aero(:,:,:,:), piz_aero(:,:,:,:), cg_aero(:,:,:,:)
+!$OMP THREADPRIVATE(tau_aero, piz_aero, cg_aero)
+      REAL,SAVE,ALLOCATABLE :: ccm(:,:,:)
+!$OMP THREADPRIVATE(ccm)
+
+!!! nrlmd le 10/04/2012
+      REAL,SAVE,ALLOCATABLE :: ale_bl_trig(:)
+!$OMP THREADPRIVATE(ale_bl_trig)
+!!! fin nrlmd le 10/04/2012
+
+CONTAINS
+
+!======================================================================
+SUBROUTINE phys_state_var_init(read_climoz)
+USE dimphy
+USE control_mod
+USE aero_mod
+USE infotrac, ONLY : nbtr
+USE indice_sol_mod
+IMPLICIT NONE
+
+integer, intent(in)::  read_climoz
+! read ozone climatology
+! Allowed values are 0, 1 and 2
+! 0: do not read an ozone climatology
+! 1: read a single ozone climatology that will be used day and night
+! 2: read two ozone climatologies, the average day and night
+! climatology and the daylight climatology
+
+      ALLOCATE(rlat(klon), rlon(klon))
+      ALLOCATE(pctsrf(klon,nbsrf))
+      ALLOCATE(ftsol(klon,nbsrf))
+      ALLOCATE(falb1(klon,nbsrf))
+      ALLOCATE(falb2(klon,nbsrf))
+      ALLOCATE(rain_fall(klon))
+      ALLOCATE(snow_fall(klon))
+      ALLOCATE(solsw(klon), sollw(klon))
+      ALLOCATE(radsol(klon))
+      ALLOCATE(zmea(klon), zstd(klon), zsig(klon), zgam(klon))
+      ALLOCATE(zthe(klon), zpic(klon), zval(klon))
+
+      ALLOCATE(rugoro(klon))
+      ALLOCATE(t_ancien(klon,klev), q_ancien(klon,klev))
+      ALLOCATE(u_ancien(klon,klev), v_ancien(klon,klev))
+!!! Rom P >>>
+      ALLOCATE(tr_ancien(klon,klev,nbtr))
+!!! Rom P <<<
+      ALLOCATE(clwcon(klon,klev),rnebcon(klon,klev))
+      ALLOCATE(ratqs(klon,klev))
+      ALLOCATE(pbl_tke(klon,klev+1,nbsrf+1))
+      ALLOCATE(coefh(klon,klev+1,nbsrf+1))
+      ALLOCATE(coefm(klon,klev+1,nbsrf+1))
+      ALLOCATE(zmax0(klon), f0(klon))
+      ALLOCATE(ema_work1(klon,klev), ema_work2(klon,klev))
+      ALLOCATE(entr_therm(klon,klev), fm_therm(klon,klev+1))
+      ALLOCATE(detr_therm(klon,klev))
+!     pour phsystoke avec thermiques
+      ALLOCATE(clwcon0th(klon,klev),rnebcon0th(klon,klev))
+! radiation outputs
+      ALLOCATE(swdn0(klon,klevp1), swdn(klon,klevp1))
+      ALLOCATE(swup0(klon,klevp1), swup(klon,klevp1))
+      ALLOCATE(lwdn0(klon,klevp1), lwdn(klon,klevp1))
+      ALLOCATE(lwup0(klon,klevp1), lwup(klon,klevp1))
+      ALLOCATE(SWdn200clr(klon), SWdn200(klon))
+      ALLOCATE(SWup200clr(klon), SWup200(klon))
+      ALLOCATE(LWdn200clr(klon), LWdn200(klon))
+      ALLOCATE(LWup200clr(klon), LWup200(klon))
+      ALLOCATE(LWdnTOA(klon), LWdnTOAclr(klon))
+! pressure level
+      ALLOCATE(tsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(usumSTD(klon,nlevSTD,nout), vsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(wsumSTD(klon,nlevSTD,nout), phisumSTD(klon,nlevSTD,nout))
+      ALLOCATE(qsumSTD(klon,nlevSTD,nout), rhsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(tnondef(klon,nlevSTD,nout))
+      ALLOCATE(uvsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(vqsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(vTsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(wqsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(vphisumSTD(klon,nlevSTD,nout))
+      ALLOCATE(wTsumSTD(klon,nlevSTD,nout))
+      ALLOCATE(u2sumSTD(klon,nlevSTD,nout))
+      ALLOCATE(v2sumSTD(klon,nlevSTD,nout))
+      ALLOCATE(T2sumSTD(klon,nlevSTD,nout))
+      ALLOCATE(O3sumSTD(klon,nlevSTD,nout))
+      ALLOCATE(O3daysumSTD(klon,nlevSTD,nout))
+!IM beg
+      ALLOCATE(wlevSTD(klon,nlevSTD), ulevSTD(klon,nlevSTD), vlevSTD(klon,nlevSTD))
+      ALLOCATE(tlevSTD(klon,nlevSTD), qlevSTD(klon,nlevSTD), rhlevSTD(klon,nlevSTD))
+      ALLOCATE(philevSTD(klon,nlevSTD))
+      ALLOCATE(uvSTD(klon,nlevSTD),vqSTD(klon,nlevSTD))
+      ALLOCATE(vTSTD(klon,nlevSTD),wqSTD(klon,nlevSTD))
+      ALLOCATE(vphiSTD(klon,nlevSTD),wTSTD(klon,nlevSTD))
+      ALLOCATE(u2STD(klon,nlevSTD),v2STD(klon,nlevSTD))
+      ALLOCATE(T2STD(klon,nlevSTD))
+      ALLOCATE(O3STD(klon,nlevSTD))
+      ALLOCATE(O3daySTD(klon,nlevSTD))
+!IM end
+      ALLOCATE(seed_old(klon,napisccp))
+      ALLOCATE(zuthe(klon),zvthe(klon))
+      ALLOCATE(alb_neig(klon))
+!cloud base mass flux
+      ALLOCATE(ema_cbmf(klon))
+!cloud base pressure & cloud top pressure
+      ALLOCATE(ema_pcb(klon), ema_pct(klon))
+!
+      ALLOCATE(Ma(klon,klev))
+      ALLOCATE(qcondc(klon,klev))
+      ALLOCATE(wd(klon))
+      ALLOCATE(sigd(klon))
+      ALLOCATE(cin(klon), ALE(klon), ALP(klon))
+      ALLOCATE(ftd(klon,klev), fqd(klon,klev))
+      ALLOCATE(Ale_bl(klon))
+      ALLOCATE(Alp_bl(klon))
+      ALLOCATE(lalim_conv(klon))
+      ALLOCATE(wght_th(klon,klev))
+      ALLOCATE(wake_deltat(klon,klev), wake_deltaq(klon,klev))
+      ALLOCATE(wake_Cstar(klon), wake_s(klon))
+      ALLOCATE(wake_pe(klon), wake_fip(klon))
+      ALLOCATE(dt_wake(klon,klev), dq_wake(klon,klev))
+      ALLOCATE(pfrac_impa(klon,klev), pfrac_nucl(klon,klev))
+      ALLOCATE(pfrac_1nucl(klon,klev))
+      ALLOCATE(total_rain(klon), nday_rain(klon))
+      ALLOCATE(paire_ter(klon))
+      ALLOCATE(albsol1(klon), albsol2(klon))
+
+      if (read_climoz <= 1) then
+         ALLOCATE(wo(klon,klev, 1))
+      else
+         ! read_climoz == 2
+         ALLOCATE(wo(klon,klev, 2))
+      end if
+      
+      ALLOCATE(clwcon0(klon,klev),rnebcon0(klon,klev))
+      ALLOCATE(heat(klon,klev), heat0(klon,klev)) 
+      ALLOCATE(cool(klon,klev), cool0(klon,klev))
+      ALLOCATE(topsw(klon), toplw(klon))
+      ALLOCATE(sollwdown(klon), sollwdownclr(klon))
+      ALLOCATE(toplwdown(klon), toplwdownclr(klon))
+      ALLOCATE(topsw0(klon),toplw0(klon),solsw0(klon),sollw0(klon))
+      ALLOCATE(albpla(klon))
+!IM ajout variables CFMIP2/CMIP5
+      ALLOCATE(heatp(klon,klev), coolp(klon,klev))
+      ALLOCATE(heat0p(klon,klev), cool0p(klon,klev))
+      ALLOCATE(radsolp(klon), topswp(klon), toplwp(klon))
+      ALLOCATE(albplap(klon))
+      ALLOCATE(solswp(klon), sollwp(klon))
+      ALLOCATE(sollwdownp(klon))
+      ALLOCATE(topsw0p(klon),toplw0p(klon))
+      ALLOCATE(solsw0p(klon),sollw0p(klon))
+      ALLOCATE(lwdn0p(klon,klevp1), lwdnp(klon,klevp1))
+      ALLOCATE(lwup0p(klon,klevp1), lwupp(klon,klevp1))
+      ALLOCATE(swdn0p(klon,klevp1), swdnp(klon,klevp1))
+      ALLOCATE(swup0p(klon,klevp1), swupp(klon,klevp1))
+
+      ALLOCATE(cape(klon))
+      ALLOCATE(pbase(klon),bbase(klon))
+      ALLOCATE(zqasc(klon,klev))
+      ALLOCATE(ibas_con(klon), itop_con(klon))
+      ALLOCATE(rain_con(klon), snow_con(klon))
+      ALLOCATE(rlonPOS(klon))
+      ALLOCATE(newsst(klon))
+      ALLOCATE(ustar(klon,nbsrf),u10m(klon,nbsrf), v10m(klon,nbsrf))
+      ALLOCATE(topswad(klon), solswad(klon))
+      ALLOCATE(topswai(klon), solswai(klon))
+      ALLOCATE(tau_aero(klon,klev,naero_grp,nbands),piz_aero(klon,klev,naero_grp,nbands),cg_aero(klon,klev,naero_grp,nbands))
+      ALLOCATE(ccm(klon,klev,nbands))
+
+!!! nrlmd le 10/04/2012
+      ALLOCATE(ale_bl_trig(klon))
+!!! fin nrlmd le 10/04/2012
+
+END SUBROUTINE phys_state_var_init
+
+!======================================================================
+SUBROUTINE phys_state_var_end
+USE dimphy
+USE control_mod
+USE indice_sol_mod
+IMPLICIT NONE
+
+      deallocate(rlat, rlon, pctsrf, ftsol, falb1, falb2)
+      deallocate(rain_fall, snow_fall, solsw, sollw, radsol)
+      deallocate(zmea, zstd, zsig, zgam)
+      deallocate(zthe, zpic, zval)
+      deallocate(rugoro, t_ancien, q_ancien, clwcon, rnebcon)
+      deallocate(        u_ancien, v_ancien                 )
+      deallocate(        tr_ancien)                           !RomP
+      deallocate(ratqs, pbl_tke,coefh,coefm)
+      deallocate(zmax0, f0)
+      deallocate(ema_work1, ema_work2)
+      deallocate(entr_therm, fm_therm)
+      deallocate(detr_therm)
+      deallocate(clwcon0th, rnebcon0th)
+! radiation outputs
+      deallocate(swdn0, swdn)
+      deallocate(swup0, swup)
+      deallocate(lwdn0, lwdn)
+      deallocate(lwup0, lwup)
+      deallocate(SWdn200clr, SWdn200)
+      deallocate(SWup200clr, SWup200)
+      deallocate(LWdn200clr, LWdn200)
+      deallocate(LWup200clr, LWup200)
+      deallocate(LWdnTOA, LWdnTOAclr)
+! pressure level
+      deallocate(tsumSTD)
+      deallocate(usumSTD, vsumSTD)
+      deallocate(wsumSTD, phisumSTD)
+      deallocate(tnondef)
+      deallocate(qsumSTD, rhsumSTD)
+      deallocate(uvsumSTD)
+      deallocate(vqsumSTD)
+      deallocate(vTsumSTD)
+      deallocate(wqsumSTD)
+      deallocate(vphisumSTD)
+      deallocate(wTsumSTD)
+      deallocate(u2sumSTD)
+      deallocate(v2sumSTD)
+      deallocate(T2sumSTD)
+      deallocate(O3sumSTD)
+      deallocate(O3daysumSTD)
+!IM beg
+      deallocate(wlevSTD,ulevSTD,vlevSTD,tlevSTD,qlevSTD,rhlevSTD,philevSTD)
+      deallocate(uvSTD,vqSTD,vTSTD,wqSTD,vphiSTD,wTSTD,u2STD,v2STD,T2STD,O3STD,O3daySTD)
+!IM end
+      deallocate(seed_old)
+      deallocate(zuthe, zvthe)
+      deallocate(alb_neig)
+      deallocate(ema_cbmf)
+      deallocate(ema_pcb, ema_pct)
+      deallocate(Ma, qcondc)
+      deallocate(wd, sigd)
+      deallocate(cin, ALE, ALP)
+      deallocate(ftd, fqd)
+      deallocate(Ale_bl, Alp_bl)
+      deallocate(lalim_conv, wght_th)
+      deallocate(wake_deltat, wake_deltaq)
+      deallocate(wake_Cstar, wake_s, wake_pe, wake_fip)
+      deallocate(dt_wake, dq_wake)
+      deallocate(pfrac_impa, pfrac_nucl)
+      deallocate(pfrac_1nucl)
+      deallocate(total_rain, nday_rain)
+      deallocate(paire_ter)
+      deallocate(albsol1, albsol2)
+      deallocate(wo)
+      deallocate(clwcon0,rnebcon0)
+      deallocate(heat, heat0) 
+      deallocate(cool, cool0)
+      deallocate(topsw, toplw)
+      deallocate(sollwdown, sollwdownclr)
+      deallocate(toplwdown, toplwdownclr)
+      deallocate(topsw0,toplw0,solsw0,sollw0)
+      deallocate(albpla)
+!IM ajout variables CFMIP2/CMIP5
+      deallocate(heatp, coolp)
+      deallocate(heat0p, cool0p)
+      deallocate(radsolp, topswp, toplwp)
+      deallocate(albplap)
+      deallocate(solswp, sollwp)
+      deallocate(sollwdownp)
+      deallocate(topsw0p,toplw0p)
+      deallocate(solsw0p,sollw0p)
+      deallocate(lwdn0p, lwdnp)
+      deallocate(lwup0p, lwupp)
+      deallocate(swdn0p, swdnp)
+      deallocate(swup0p, swupp)
+      deallocate(cape)
+      deallocate(pbase,bbase)
+      deallocate(zqasc)
+      deallocate(ibas_con, itop_con)
+      deallocate(rain_con, snow_con)
+      deallocate(rlonPOS)
+      deallocate(newsst)
+      deallocate(ustar,u10m, v10m)
+      deallocate(topswad, solswad)
+      deallocate(topswai, solswai)
+      deallocate(tau_aero,piz_aero,cg_aero)
+      deallocate(ccm)
+       
+!!! nrlmd le 10/04/2012
+      deallocate(ale_bl_trig)
+!!! fin nrlmd le 10/04/2012
+
+END SUBROUTINE phys_state_var_end
+
+      END MODULE phys_state_var_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/physiq.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/physiq.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/physiq.F90	(revision 17)
@@ -0,0 +1,4351 @@
+! $Id: physiq.F 1795 2013-07-18 08:20:28Z emillour $
+!c#define IO_DEBUG
+
+      SUBROUTINE physiq (nlon,nlev,                                                  &
+       &            debut,lafin,jD_cur, jH_cur,pdtphys,                              &
+       &            paprs,pplay,pphi,pphis,presnivs,clesphy0,                        &
+       &            u,v,t,qx,                                                        &
+       &            flxmass_w,                                                       &
+       &            d_u, d_v, d_t, d_qx, d_ps                                        &
+       &            , dudyn                                                          &
+       &            , PVteta)
+
+      USE ioipsl, only: histbeg, histvert, histdef, histend, histsync,               &
+       &     histwrite, ju2ymds, ymds2ju, ioget_year_len
+      USE comgeomphy
+      USE phys_cal_mod
+      USE write_field_phy
+      USE dimphy
+      USE infotrac
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      USE iophy
+      USE misc_mod, mydebug=>debug
+      USE vampir
+!L. Fita, LMD. November 2013
+!      USE pbl_surface_mod, ONLY : pbl_surface
+!      USE pbl_surface_mod, ONLY : pbl_surface, pbl_surface_init
+      USE pbl_surface_mod
+      USE change_srf_frac_mod
+      USE surface_data,     ONLY : type_ocean, ok_veget
+      USE phys_local_var_mod ! Variables internes non sauvegardees de la physique
+      USE phys_state_var_mod ! Variables sauvegardees de la physique
+      USE phys_output_var_mod ! Variables pour les ecritures des sorties
+      USE fonte_neige_mod, ONLY  : fonte_neige_get_vars, fonte_neige_init
+      USE phys_output_mod
+      USE phys_output_ctrlout_mod
+      USE iophy
+      use open_climoz_m, only: open_climoz ! ozone climatology from a file
+      use regr_pr_av_m, only: regr_pr_av
+      use netcdf95, only: nf95_close
+!IM for NMC files
+!c     use netcdf, only: nf90_fill_real
+      use netcdf
+      use mod_phys_lmdz_mpi_data, only: is_mpi_root
+      USE aero_mod
+      use ozonecm_m, only: ozonecm ! ozone of J.-F. Royer
+      use conf_phys_m, only: conf_phys
+      use radlwsw_m, only: radlwsw
+      USE control_mod
+#ifdef REPROBUS
+      USE CHEM_REP, ONLY : Init_chem_rep_xjour
+#endif
+      USE indice_sol_mod
+
+!IM stations CFMIP
+      USE CFMIP_point_locations
+
+!L. Fita. July 2013
+      USE orografi
+      USE orografi_strato_mod
+      USE diagphy_mod
+!      USE orbite_mod, ONLY : angle
+      USE phyaqua_mod, ONLY: zenang_an
+      USE nuage_mod, ONLY : diagcld1
+
+! L. Fita, LMD. November 2013. 
+!!      USE wrf_lmdz_mod
+!!      USE module_lmdz_variables, ONLY: neige_initialize, limit_initialize 
+!!      USE physiq_limit_variables_mod
+!!      USE physiq_limit_variables_mod
+      USE lmdz_wrf_variables_mod
+! L. Fita, LMD. January 2014
+!   Defining with SAVE statement all that variables that should appear in the output
+      USE output_lmdz_NOmodule
+
+      IMPLICIT none
+!>======================================================================
+!!
+!! Auteur(s) Z.X. Li (LMD/CNRS) date: 19930818
+!!
+!! Objet: Moniteur general de la physique du modele
+!!AA      Modifications quant aux traceurs :
+!!AA                  -  uniformisation des parametrisations ds phytrac
+!!AA                  -  stockage des moyennes des champs necessaires
+!!AA                     en mode traceur off-line 
+!!======================================================================
+!!   CLEFS CPP POUR LES IO
+!!   =====================
+#define histNMC
+!c#define histISCCP
+!!======================================================================
+!!    modif   ( P. Le Van ,  12/10/98 )
+!!
+!!  Arguments:
+!!
+!! nlon----input-I-nombre de points horizontaux
+!! nlev----input-I-nombre de couches verticales, doit etre egale a klev
+!! debut---input-L-variable logique indiquant le premier passage
+!! lafin---input-L-variable logique indiquant le dernier passage
+!! jD_cur       -R-jour courant a l'appel de la physique (jour julien)
+!! jH_cur       -R-heure courante a l'appel de la physique (jour julien)
+!! pdtphys-input-R-pas d'integration pour la physique (seconde)
+!! paprs---input-R-pression pour chaque inter-couche (en Pa)
+!! pplay---input-R-pression pour le mileu de chaque couche (en Pa)
+!! pphi----input-R-geopotentiel de chaque couche (g z) (reference sol)
+!! pphis---input-R-geopotentiel du sol
+!! presnivs-input_R_pressions approximat. des milieux couches ( en PA)
+!! u-------input-R-vitesse dans la direction X (de O a E) en m/s
+!! v-------input-R-vitesse Y (de S a N) en m/s
+!! t-------input-R-temperature (K)
+!! qx------input-R-humidite specifique (kg/kg) et d'autres traceurs
+!! d_t_dyn-input-R-tendance dynamique pour "t" (K/s)
+!! d_q_dyn-input-R-tendance dynamique pour "q" (kg/kg/s)
+!! flxmass_w -input-R- flux de masse verticale
+!! d_u-----output-R-tendance physique de "u" (m/s/s)
+!! d_v-----output-R-tendance physique de "v" (m/s/s)
+!! d_t-----output-R-tendance physique de "t" (K/s)
+!! d_qx----output-R-tendance physique de "qx" (kg/kg/s)
+!! d_ps----output-R-tendance physique de la pression au sol
+!!IM
+!! PVteta--output-R-vorticite potentielle a des thetas constantes
+!!======================================================================
+#include "dimensions.h"
+      integer jjmp1
+      parameter (jjmp1=jjm+1-1/jjm)
+      integer iip1
+      parameter (iip1=iim+1)
+
+#include "regdim.h"
+#include "dimsoil.h"
+#include "clesphys.h"
+#include "temps.h"
+#include "iniprint.h"
+#include "thermcell.h"
+!c======================================================================
+      LOGICAL ok_cvl  ! pour activer le nouveau driver pour convection KE
+      PARAMETER (ok_cvl=.TRUE.)
+      LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface
+      PARAMETER (ok_gust=.FALSE.)
+      integer iflag_radia     ! active ou non le rayonnement (MPL)
+      save iflag_radia
+!$OMP THREADPRIVATE(iflag_radia)
+!c======================================================================
+      LOGICAL check ! Verifier la conservation du modele en eau
+      PARAMETER (check=.FALSE.)
+      LOGICAL ok_stratus ! Ajouter artificiellement les stratus
+      PARAMETER (ok_stratus=.FALSE.)
+!c======================================================================
+      REAL amn, amx
+      INTEGER igout
+!c======================================================================
+!c Clef controlant l'activation du cycle diurne:
+!ccc      LOGICAL cycle_diurne
+!ccc      PARAMETER (cycle_diurne=.FALSE.)
+!c======================================================================
+!c Modele thermique du sol, a activer pour le cycle diurne:
+!ccc      LOGICAL soil_model
+!ccc      PARAMETER (soil_model=.FALSE.)
+!c======================================================================
+!c Dans les versions precedentes, l'eau liquide nuageuse utilisee dans
+!c le calcul du rayonnement est celle apres la precipitation des nuages.
+!c Si cette cle new_oliq est activee, ce sera une valeur moyenne entre
+!c la condensation et la precipitation. Cette cle augmente les impacts
+!c radiatifs des nuages.
+!ccc      LOGICAL new_oliq
+!ccc      PARAMETER (new_oliq=.FALSE.)
+!c======================================================================
+!c Clefs controlant deux parametrisations de l'orographie:
+!cc      LOGICAL ok_orodr
+!ccc      PARAMETER (ok_orodr=.FALSE.)
+!ccc      LOGICAL ok_orolf
+!ccc      PARAMETER (ok_orolf=.FALSE.)
+!c======================================================================
+      LOGICAL ok_journe ! sortir le fichier journalier
+      save ok_journe
+!$OMP THREADPRIVATE(ok_journe)
+!c
+      LOGICAL ok_mensuel ! sortir le fichier mensuel
+      save ok_mensuel
+!$OMP THREADPRIVATE(ok_mensuel)
+!c
+      LOGICAL ok_instan ! sortir le fichier instantane
+      save ok_instan
+!$OMP THREADPRIVATE(ok_instan)
+!c
+      LOGICAL ok_LES ! sortir le fichier LES 
+      save ok_LES                            
+!$OMP THREADPRIVATE(ok_LES)                  
+!c
+      LOGICAL callstats ! sortir le fichier stats 
+      save callstats                            
+!$OMP THREADPRIVATE(callstats)                  
+!c
+      LOGICAL ok_region ! sortir le fichier regional
+      PARAMETER (ok_region=.FALSE.)
+!c======================================================================
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      real weak_inversion(klon),dthmin(klon)
+      real seuil_inversion
+      save seuil_inversion
+!$OMP THREADPRIVATE(seuil_inversion)
+      integer iflag_ratqs
+      save iflag_ratqs
+!$OMP THREADPRIVATE(iflag_ratqs)
+      real facteur
+
+      REAL zz,znum,zden
+      REAL wmax_th(klon)
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL zmax_th(klon)
+      REAL tau_overturning_th(klon)
+
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      integer lmax_th(klon)
+      integer limbas(klon)
+      real ratqscth(klon,klev)
+      real ratqsdiff(klon,klev)
+      real zqsatth(klon,klev)
+
+!c======================================================================
+!c
+      INTEGER ivap          ! indice de traceurs pour vapeur d'eau
+      PARAMETER (ivap=1)
+      INTEGER iliq          ! indice de traceurs pour eau liquide
+      PARAMETER (iliq=2)
+
+!c
+!c
+!c Variables argument:
+!c
+      INTEGER nlon
+      INTEGER nlev
+      REAL, intent(in):: jD_cur, jH_cur
+
+      REAL pdtphys
+      LOGICAL debut, lafin
+      REAL paprs(klon,klev+1)
+      REAL pplay(klon,klev)
+      REAL pphi(klon,klev)
+      REAL pphis(klon)
+      REAL presnivs(klev)
+      REAL znivsig(klev)
+      real pir
+
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL t(klon,klev),theta(klon,klev),thetal(klon,klev)
+      REAL t(klon,klev),thetal(klon,klev)
+
+!c thetal: ligne suivante a decommenter si vous avez les fichiers     MPL 20130625
+!c fth_fonctions.F90 et parkind1.F90
+!c sinon thetal=theta
+!c     REAL fth_thetae,fth_thetav,fth_thetal
+      REAL qx(klon,klev,nqtot)
+      REAL flxmass_w(klon,klev)
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL omega(klon,klev) ! vitesse verticale en Pa/s
+      REAL d_u(klon,klev)
+      REAL d_v(klon,klev)
+      REAL d_t(klon,klev)
+      REAL d_qx(klon,klev,nqtot)
+      REAL d_ps(klon)
+! Variables pour le transport convectif
+      real da(klon,klev),phi(klon,klev,klev),mp(klon,klev)
+! Variables pour le lessivage convectif
+! RomP >>> 
+      real phi2(klon,klev,klev)
+      real d1a(klon,klev),dam(klon,klev)
+      real ev(klon,klev),ep(klon,klev)
+      real clw(klon,klev),elij(klon,klev,klev)
+      real epmlmMm(klon,klev,klev),eplaMm(klon,klev)
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      real wdtrainA(klon,klev),wdtrainM(klon,klev)
+
+! RomP <<<
+!IM definition dynamique o_trac dans phys_output_open
+!      type(ctrl_out) :: o_trac(nqtot)
+!c
+!IM Amip2 PV a theta constante 
+!c
+      INTEGER nbteta
+      PARAMETER(nbteta=3)
+      CHARACTER*3 ctetaSTD(nbteta)
+      DATA ctetaSTD/'350','380','405'/
+      SAVE ctetaSTD
+!$OMP THREADPRIVATE(ctetaSTD)
+      REAL rtetaSTD(nbteta)
+      DATA rtetaSTD/350., 380., 405./
+      SAVE rtetaSTD
+!$OMP THREADPRIVATE(rtetaSTD)     
+!c
+      REAL PVteta(klon,nbteta)
+      REAL zx_tmp_3dte(iim,jjmp1,nbteta)
+!c
+!MI Amip2 PV a theta constante
+
+!cym      INTEGER klevp1, klevm1
+!cym      PARAMETER(klevp1=klev+1,klevm1=klev-1)
+!cym#include "raddim.h"
+!c
+!c
+!IM Amip2
+!c variables a une pression donnee
+!c
+#include "declare_STDlev.h"
+!c
+      CHARACTER*4 bb2
+      CHARACTER*2 bb3
+!c
+#include "radopt.h"
+!c
+!c
+!c prw: precipitable water
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      real prw(klon)
+
+      REAL convliq(klon,klev)  ! eau liquide nuageuse convective
+      REAL convfra(klon,klev)  ! fraction nuageuse convective
+
+      REAL cldl_c(klon),cldm_c(klon),cldh_c(klon) !nuages bas, moyen et haut
+      REAL cldt_c(klon),cldq_c(klon) !nuage total, eau liquide integree
+      REAL cldl_s(klon),cldm_s(klon),cldh_s(klon) !nuages bas, moyen et haut
+      REAL cldt_s(klon),cldq_s(klon) !nuage total, eau liquide integree
+
+      INTEGER linv, kp1
+!c flwp, fiwp = Liquid Water Path & Ice Water Path (kg/m2)
+!c flwc, fiwc = Liquid Water Content & Ice Water Content (kg/kg)
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL flwp(klon), fiwp(klon)
+!      REAL flwc(klon,klev), fiwc(klon,klev)
+      REAL flwp_c(klon), fiwp_c(klon)
+      REAL flwc_c(klon,klev), fiwc_c(klon,klev)
+      REAL flwp_s(klon), fiwp_s(klon)
+      REAL flwc_s(klon,klev), fiwc_s(klon,klev)
+
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL evap_pot(klon,nbsrf)
+
+!IM ISCCP simulator v3.4
+!c dans clesphys.h top_height, overlap
+!cv3.4
+      INTEGER debug, debugcol
+!cym      INTEGER npoints
+!cym      PARAMETER(npoints=klon) 
+!c
+      INTEGER sunlit(klon) !sunlit=1 if day; sunlit=0 if night
+      INTEGER nregISCtot
+      PARAMETER(nregISCtot=1) 
+!c
+!c imin_debut, nbpti, jmin_debut, nbptj : parametres pour sorties sur 1 region rectangulaire
+!c y compris pour 1 point
+!c imin_debut : indice minimum de i; nbpti : nombre de points en direction i (longitude)
+!c jmin_debut : indice minimum de j; nbptj : nombre de points en direction j (latitude)
+      INTEGER imin_debut, nbpti
+      INTEGER jmin_debut, nbptj 
+!IM parametres ISCCP BEG
+      INTEGER nbapp_isccp
+!     INTEGER nbapp_isccp,isccppas
+!     PARAMETER(isccppas=6) !appel du simulateurs tous les 6pas de temps de la physique
+!                           !i.e. toutes les 3 heures 
+      INTEGER n
+      INTEGER ifreq_isccp(napisccp), freqin_pdt(napisccp)
+      DATA ifreq_isccp/3/
+      SAVE ifreq_isccp
+!$OMP THREADPRIVATE(ifreq_isccp)
+      CHARACTER*5 typinout(napisccp)
+      DATA typinout/'i3od'/
+      SAVE typinout
+!$OMP THREADPRIVATE(typinout)
+!IM verif boxptop BEG
+      CHARACTER*1 verticaxe(napisccp)
+      DATA verticaxe/'1'/ 
+      SAVE verticaxe
+!$OMP THREADPRIVATE(verticaxe)
+!IM verif boxptop END
+      INTEGER nvlev(napisccp)
+!c     INTEGER nvlev
+      REAL t1, aa
+      REAL seed_re(klon,napisccp)
+!cym !!!! A voir plus tard 
+!cym      INTEGER iphy(iim,jjmp1)
+!IM parametres ISCCP END
+!c
+!c ncol = nb. de sous-colonnes pour chaque maille du GCM 
+!c ncolmx = No. max. de sous-colonnes pour chaque maille du GCM 
+!c      INTEGER ncol(napisccp), ncolmx, seed(klon,napisccp)
+      INTEGER,SAVE :: ncol(napisccp)
+!$OMP THREADPRIVATE(ncol)
+      INTEGER ncolmx, seed(klon,napisccp)
+      REAL nbsunlit(nregISCtot,klon,napisccp)  !nbsunlit : moyenne de sunlit
+!c     PARAMETER(ncolmx=1500)
+      PARAMETER(ncolmx=300)
+!c
+!IM verif boxptop BEG
+      REAL vertlev(ncolmx,napisccp)
+!IM verif boxptop END
+!c
+      REAL,SAVE :: tautab_omp(0:255),tautab(0:255)
+      INTEGER,SAVE :: invtau_omp(-20:45000),invtau(-20:45000)
+!$OMP THREADPRIVATE(tautab,invtau)
+      REAL emsfc_lw
+      PARAMETER(emsfc_lw=0.99)
+!c     REAL    ran0                      ! type for random number fuction
+!c
+      REAL cldtot(klon,klev)
+!c variables de haut en bas pour le simulateur ISCCP
+      REAL dtau_s(klon,klev) !tau nuages startiformes
+      REAL dtau_c(klon,klev) !tau nuages convectifs
+      REAL dem_s(klon,klev)  !emissivite nuages startiformes 
+      REAL dem_c(klon,klev)  !emissivite nuages convectifs
+!c
+!c variables de haut en bas pour le simulateur ISCCP
+      REAL pfull(klon,klev)
+      REAL phalf(klon,klev+1)
+      REAL qv(klon,klev)
+      REAL cc(klon,klev)
+      REAL conv(klon,klev)
+      REAL dtau_sH2B(klon,klev)
+      REAL dtau_cH2B(klon,klev)
+      REAL at(klon,klev)
+      REAL dem_sH2B(klon,klev)
+      REAL dem_cH2B(klon,klev)
+!c
+      INTEGER kmax, lmax, lmax3
+      PARAMETER(kmax=8, lmax=8, lmax3=3)
+      INTEGER kmaxm1, lmaxm1
+      PARAMETER(kmaxm1=kmax-1, lmaxm1=lmax-1)
+      INTEGER iimx7, jjmx7, jjmp1x7
+      PARAMETER(iimx7=iim*kmaxm1, jjmx7=jjm*lmaxm1,                                  &
+       &jjmp1x7=jjmp1*lmaxm1)
+!c
+!c output from ISCCP simulator
+      REAL fq_isccp(klon,kmaxm1,lmaxm1,napisccp)
+      REAL fq_is_true(klon,kmaxm1,lmaxm1,napisccp)
+      REAL totalcldarea(klon,napisccp) 
+      REAL meanptop(klon,napisccp)
+      REAL meantaucld(klon,napisccp)
+      REAL boxtau(klon,ncolmx,napisccp)
+      REAL boxptop(klon,ncolmx,napisccp) 
+      REAL zx_tmp_fi3d_bx(klon,ncolmx)
+      REAL zx_tmp_3d_bx(iim,jjmp1,ncolmx)
+!c
+      REAL cld_fi3d(klon,lmax3)
+      REAL cld_3d(iim,jjmp1,lmax3)
+!c
+      INTEGER iw, iwmax
+      REAL wmin, pas_w
+!c     PARAMETER(wmin=-100.,pas_w=10.,iwmax=30)
+!IM 051005     PARAMETER(wmin=-200.,pas_w=10.,iwmax=40)
+      PARAMETER(wmin=-100.,pas_w=10.,iwmax=20)
+      REAL o500(klon)
+!c
+
+!c sorties ISCCP
+
+      integer nid_isccp
+      save nid_isccp        
+!$OMP THREADPRIVATE(nid_isccp)
+
+      REAL zx_tau(kmaxm1), zx_pc(lmaxm1), zx_o500(iwmax)
+      DATA zx_tau/0.0, 0.3, 1.3, 3.6, 9.4, 23., 60./
+      SAVE zx_tau
+      DATA zx_pc/180., 310., 440., 560., 680., 800., 1000./
+      SAVE zx_pc
+!$OMP THREADPRIVATE(zx_tau,zx_pc)
+!c cldtopres pression au sommet des nuages
+      REAL cldtopres(lmaxm1), cldtopres3(lmax3)
+      DATA cldtopres/180., 310., 440., 560., 680., 800., 1000./
+      DATA cldtopres3/440., 680., 1000./
+      SAVE cldtopres,cldtopres3
+!$OMP THREADPRIVATE(cldtopres,cldtopres3)
+!IM 051005 BEG
+      INTEGER komega, nhoriRD 
+
+!c taulev: numero du niveau de tau dans les sorties ISCCP
+      CHARACTER *4 taulev(kmaxm1)
+!c     DATA taulev/'tau1','tau2','tau3','tau4','tau5','tau6','tau7'/
+      DATA taulev/'tau0','tau1','tau2','tau3','tau4','tau5','tau6'/
+      CHARACTER *3 pclev(lmaxm1)
+      DATA pclev/'pc1','pc2','pc3','pc4','pc5','pc6','pc7'/
+      SAVE taulev,pclev
+!$OMP THREADPRIVATE(taulev,pclev)
+!c
+!c cnameisccp
+      CHARACTER *29 cnameisccp(lmaxm1,kmaxm1)
+!IM bad 151205     DATA cnameisccp/'pc< 50hPa, tau< 0.3', 
+      DATA cnameisccp/'pc= 50-180hPa, tau< 0.3',                                     &
+       &                'pc= 180-310hPa, tau< 0.3',                                  &
+       &                'pc= 310-440hPa, tau< 0.3',                                  &
+       &                'pc= 440-560hPa, tau< 0.3',                                  &
+       &                'pc= 560-680hPa, tau< 0.3',                                  &
+       &                'pc= 680-800hPa, tau< 0.3',                                  &
+       &                'pc= 800-1000hPa, tau< 0.3',                                 &
+       &                'pc= 50-180hPa, tau= 0.3-1.3',                               &
+       &                'pc= 180-310hPa, tau= 0.3-1.3',                              &
+       &                'pc= 310-440hPa, tau= 0.3-1.3',                              &
+       &                'pc= 440-560hPa, tau= 0.3-1.3',                              &
+       &                'pc= 560-680hPa, tau= 0.3-1.3',                              &
+       &                'pc= 680-800hPa, tau= 0.3-1.3',                              &
+       &                'pc= 800-1000hPa, tau= 0.3-1.3',                             &
+       &                'pc= 50-180hPa, tau= 1.3-3.6',                               &
+       &                'pc= 180-310hPa, tau= 1.3-3.6',                              &
+       &                'pc= 310-440hPa, tau= 1.3-3.6',                              &
+       &                'pc= 440-560hPa, tau= 1.3-3.6',                              &
+       &                'pc= 560-680hPa, tau= 1.3-3.6',                              &
+       &                'pc= 680-800hPa, tau= 1.3-3.6',                              &
+       &                'pc= 800-1000hPa, tau= 1.3-3.6',                             &
+       &                'pc= 50-180hPa, tau= 3.6-9.4',                               &
+       &                'pc= 180-310hPa, tau= 3.6-9.4',                              &
+       &                'pc= 310-440hPa, tau= 3.6-9.4',                              &
+       &                'pc= 440-560hPa, tau= 3.6-9.4',                              &
+       &                'pc= 560-680hPa, tau= 3.6-9.4',                              &
+       &                'pc= 680-800hPa, tau= 3.6-9.4',                              &
+       &                'pc= 800-1000hPa, tau= 3.6-9.4',                             &
+       &                'pc= 50-180hPa, tau= 9.4-23',                                &
+       &                'pc= 180-310hPa, tau= 9.4-23',                               &
+       &                'pc= 310-440hPa, tau= 9.4-23',                               &
+       &                'pc= 440-560hPa, tau= 9.4-23',                               &
+       &                'pc= 560-680hPa, tau= 9.4-23',                               &
+       &                'pc= 680-800hPa, tau= 9.4-23',                               &
+       &                'pc= 800-1000hPa, tau= 9.4-23',                              &
+       &                'pc= 50-180hPa, tau= 23-60',                                 &
+       &                'pc= 180-310hPa, tau= 23-60',                                &
+       &                'pc= 310-440hPa, tau= 23-60',                                &
+       &                'pc= 440-560hPa, tau= 23-60',                                &
+       &                'pc= 560-680hPa, tau= 23-60',                                &
+       &                'pc= 680-800hPa, tau= 23-60',                                &
+       &                'pc= 800-1000hPa, tau= 23-60',                               &
+       &                'pc= 50-180hPa, tau> 60.',                                   &
+       &                'pc= 180-310hPa, tau> 60.',                                  &
+       &                'pc= 310-440hPa, tau> 60.',                                  &
+       &                'pc= 440-560hPa, tau> 60.',                                  &
+       &                'pc= 560-680hPa, tau> 60.',                                  &
+       &                'pc= 680-800hPa, tau> 60.',                                  &
+       &                'pc= 800-1000hPa, tau> 60.'/
+       SAVE cnameisccp
+!$OMP THREADPRIVATE(cnameisccp)
+!c
+!c     REAL zx_lonx7(iimx7), zx_latx7(jjmp1x7)
+!c     INTEGER nhorix7
+!IM: region='3d' <==> sorties en global
+      CHARACTER*3 region
+      PARAMETER(region='3d')
+!c
+!IM ISCCP simulator v3.4
+!c
+      logical ok_hf
+!c
+      integer nid_hf, nid_hf3d
+      save ok_hf, nid_hf, nid_hf3d
+!$OMP THREADPRIVATE(ok_hf, nid_hf, nid_hf3d)
+!c  QUESTION : noms de variables ?
+
+      INTEGER        longcles
+      PARAMETER    ( longcles = 20 )
+      REAL clesphy0( longcles      )
+!c
+!c Variables propres a la physique
+      INTEGER itap
+      SAVE itap                   ! compteur pour la physique
+!$OMP THREADPRIVATE(itap)
+!c
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      real slp(klon) ! sea level pressure
+!c
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL fevap(klon,nbsrf)
+!      REAL fluxlat(klon,nbsrf)
+!c
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL qsol(klon)
+      REAL,save ::  solarlong0
+!$OMP THREADPRIVATE(solarlong0)
+
+!c
+!c  Parametres de l'Orographie a l'Echelle Sous-Maille (OESM):
+!c
+!IM 141004     REAL zulow(klon),zvlow(klon),zustr(klon), zvstr(klon)
+      REAL zulow(klon),zvlow(klon)
+!c
+      INTEGER igwd,idx(klon),itest(klon)
+!c
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL agesno(klon,nbsrf)
+
+!c
+!c      REAL,allocatable,save :: run_off_lic_0(:)
+!cc$OMP THREADPRIVATE(run_off_lic_0)
+!cym      SAVE run_off_lic_0
+!cKE43
+!c Variables liees a la convection de K. Emanuel (sb):
+!c
+      REAL bas, top             ! cloud base and top levels
+      SAVE bas
+      SAVE top
+!$OMP THREADPRIVATE(bas, top)
+
+      REAL wdn(klon), tdn(klon), qdn(klon)
+!c
+!c=================================================================================================
+!cCR04.12.07: on ajoute les nouvelles variables du nouveau schema de convection avec poches froides
+!c Variables li\'ees \`a la poche froide (jyg)
+
+      REAL mip(klon,klev)  ! mass flux shed by the adiab ascent at each level
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL Vprecip(klon,klev+1)   ! precipitation vertical profile
+!c
+      REAL wape_prescr, fip_prescr
+      INTEGER it_wape_prescr
+      SAVE wape_prescr, fip_prescr, it_wape_prescr
+!$OMP THREADPRIVATE(wape_prescr, fip_prescr, it_wape_prescr)
+!c
+!c variables supplementaires de concvl
+      REAL Tconv(klon,klev)
+      REAL ment(klon,klev,klev),sij(klon,klev,klev)
+      REAL dd_t(klon,klev),dd_q(klon,klev)
+
+      real, save :: alp_bl_prescr=0.
+      real, save :: ale_bl_prescr=0.
+
+      real, save :: ale_max=1000.
+      real, save :: alp_max=2.
+
+      real, save :: wake_s_min_lsp=0.1
+
+!$OMP THREADPRIVATE(alp_bl_prescr,ale_bl_prescr)
+!$OMP THREADPRIVATE(ale_max,alp_max)
+!$OMP THREADPRIVATE(wake_s_min_lsp)
+
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      real ale_wake(klon)
+!      real alp_wake(klon)
+
+      real ok_wk_lsp(klon)
+
+!cRC
+!c Variables li\'ees \`a la poche froide (jyg et rr)
+!c Version diagnostique pour l'instant : pas de r\'etroaction sur la convection
+
+      REAL t_wake(klon,klev),q_wake(klon,klev) ! wake pour la convection
+
+      REAL wake_dth(klon,klev)        ! wake : temp pot difference
+
+      REAL wake_d_deltat_gw(klon,klev)! wake : delta T tendency due to Gravity Wave (/s)
+      REAL wake_omgbdth(klon,klev)    ! Wake : flux of Delta_Theta transported by LS omega
+      REAL wake_dp_omgb(klon,klev)    ! Wake : vertical gradient of large scale omega
+      REAL wake_dtKE(klon,klev)       ! Wake : differential heating (wake - unpertubed) CONV
+      REAL wake_dqKE(klon,klev)       ! Wake : differential moistening (wake - unpertubed) CONV
+      REAL wake_dtPBL(klon,klev)      ! Wake : differential heating (wake - unpertubed) PBL
+      REAL wake_dqPBL(klon,klev)      ! Wake : differential moistening (wake - unpertubed) PBL
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL wake_omg(klon,klev)        ! Wake : velocity difference (wake - unpertubed)
+      REAL wake_ddeltat(klon,klev),wake_ddeltaq(klon,klev)
+      REAL wake_dp_deltomg(klon,klev) ! Wake : gradient vertical de wake_omg
+      REAL wake_spread(klon,klev)     ! spreading term in wake_delt
+!c
+!cpourquoi y'a pas de save??
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL wake_h(klon)               ! Wake : hauteur de la poche froide
+!c
+      INTEGER wake_k(klon)            ! Wake sommet
+!c
+      REAL t_undi(klon,klev)               ! temperature moyenne dans la zone non perturbee
+      REAL q_undi(klon,klev)               ! humidite moyenne dans la zone non perturbee
+!c
+!cjyg
+!ccc      REAL wake_pe(klon)              ! Wake potential energy - WAPE 
+
+      REAL wake_gfl(klon)             ! Gust Front Length
+      REAL wake_dens(klon)
+!c
+!c
+      REAL dt_dwn(klon,klev)
+      REAL dq_dwn(klon,klev)
+      REAL wdt_PBL(klon,klev)
+      REAL udt_PBL(klon,klev)
+      REAL wdq_PBL(klon,klev)
+      REAL udq_PBL(klon,klev)
+      REAL M_dwn(klon,klev)
+      REAL M_up(klon,klev)
+      REAL dt_a(klon,klev)
+      REAL dq_a(klon,klev)
+      REAL, SAVE :: alp_offset
+!$OMP THREADPRIVATE(alp_offset)
+
+!c
+!cRR:fin declarations poches froides
+!c=======================================================================================================
+
+      REAL zw2(klon,klev+1)
+
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL fraca(klon,klev+1)        
+      REAL ztv(klon,klev),ztva(klon,klev)
+      REAL zpspsk(klon,klev)
+      REAL ztla(klon,klev),zqla(klon,klev) 
+      REAL zthl(klon,klev)
+
+!ccc nrlmd le 10/04/2012
+
+!c--------Stochastic Boundary Layer Triggering: ALE_BL--------
+!c---Propri\'et\'es du thermiques au LCL 
+      real zlcl_th(klon)                                     ! Altitude du LCL calcul\'e continument (pcon dans thermcell_main.F90)
+      real fraca0(klon)                                      ! Fraction des thermiques au LCL
+      real w0(klon)                                          ! Vitesse des thermiques au LCL
+      real w_conv(klon)                                      ! Vitesse verticale de grande \'echelle au LCL
+      real tke0(klon,klev+1)                                 ! TKE au dÃ©but du pas de temps
+      real therm_tke_max0(klon)                              ! TKE dans les thermiques au LCL 
+      real env_tke_max0(klon)                                ! TKE dans l'environnement au LCL 
+
+!c---Spectre de thermiques de type 2 au LCL
+      real n2(klon),s2(klon)
+      real ale_bl_stat(klon)
+
+!c---D\'eclenchement stochastique
+      integer :: tau_trig(klon)
+      real proba_notrig(klon)
+      real random_notrig(klon)
+
+!c--------Statistical Boundary Layer Closure: ALP_BL--------
+!c---Profils de TKE dans et hors du thermique
+      real pbl_tke_input(klon,klev+1,nbsrf)
+      real therm_tke_max(klon,klev)                          ! Profil de TKE dans les thermiques
+      real env_tke_max(klon,klev)                            ! Profil de TKE dans l'environnement
+
+!c---Fermeture statistique
+      real alp_bl_det(klon)                                     ! ALP d\'terministe du thermique unique
+      real alp_bl_fluct_m(klon)                                 ! ALP li\'ee aux fluctuations de flux de masse sous-nuageux
+      real alp_bl_fluct_tke(klon)                               ! ALP li\'ee aux fluctuations d'\'energie cin\'etique sous-nuageuse 
+      real alp_bl_conv(klon)                                    ! ALP li\'ee \`a grande \'echelle
+      real alp_bl_stat(klon)                                    ! ALP totale
+
+!ccc fin nrlmd le 10/04/2012
+
+!c Variables locales pour la couche limite (al1):
+!c
+!cAl1      REAL pblh(klon)           ! Hauteur de couche limite
+!cAl1      SAVE pblh
+!c34EK
+!c
+!c Variables locales:
+!c
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL cdragh(klon) ! drag coefficient pour T and Q
+!      REAL cdragm(klon) ! drag coefficient pour vent
+!cAA
+!cAA  Pour phytrac 
+      REAL u1(klon)             ! vents dans la premiere couche U
+      REAL v1(klon)             ! vents dans la premiere couche V
+
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule\n
+!      REAL zxffonte(klon), zxfqcalving(klon),zxfqfonte(klon)
+
+!@$$      LOGICAL offline           ! Controle du stockage ds "physique"
+!@$$      PARAMETER (offline=.false.)
+!@$$      INTEGER physid
+      REAL frac_impa(klon,klev) ! fractions d'aerosols lessivees (impaction)
+      REAL frac_nucl(klon,klev) ! idem (nucleation)
+! RomP >>> 
+      REAL beta_prec_fisrt(klon,klev) ! taux de conv de l'eau cond (fisrt)
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL beta_prec(klon,klev)       ! taux de conv de l'eau cond (utilise)
+! RomP <<<
+      INTEGER       :: iii
+      REAL          :: calday
+
+!IM cf FH pour Tiedtke 080604
+      REAL rain_tiedtke(klon),snow_tiedtke(klon)
+!c
+!IM 050204 END
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL evap(klon), devap(klon) ! evaporation et sa derivee
+      REAL devap(klon) ! evaporation et sa derivee
+
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL sens(klon), dsens(klon) ! chaleur sensible et sa derivee
+      REAL dsens(klon) ! chaleur sensible et sa derivee
+
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL bils(klon) ! bilan de chaleur au sol
+!      REAL wfbilo(klon,nbsrf) ! bilan d'eau, pour chaque
+!C                             ! type de sous-surface et pondere par la fraction
+!      REAL wfbils(klon,nbsrf) ! bilan de chaleur au sol, pour chaque
+!C                             ! type de sous-surface et pondere par la fraction
+      REAL slab_wfbils(klon)  ! bilan de chaleur au sol pour le cas de slab, sur les points d'ocean
+
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL fder(klon)         
+!      REAL ve(klon) ! integr. verticale du transport meri. de l'energie
+!      REAL vq(klon) ! integr. verticale du transport meri. de l'eau
+!      REAL ue(klon) ! integr. verticale du transport zonal de l'energie
+!      REAL uq(klon) ! integr. verticale du transport zonal de l'eau
+!c
+
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL frugs(klon,nbsrf)
+!      REAL zxrugs(klon) ! longueur de rugosite
+!c
+!c Conditions aux limites
+!c
+!
+      REAL :: day_since_equinox
+! Date de l'equinoxe de printemps
+      INTEGER, parameter :: mth_eq=3, day_eq=21
+      REAL :: jD_eq
+
+      LOGICAL, parameter :: new_orbit = .true.
+
+!c
+      INTEGER lmt_pas
+      SAVE lmt_pas                ! frequence de mise a jour
+!$OMP THREADPRIVATE(lmt_pas) 
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      real zmasse(klon, llm),exner(klon, llm) 
+      real exner(klon, llm) 
+!C     (column-density of mass of air in a cell, in kg m-2)
+      real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
+
+!IM sorties
+      REAL un_jour
+      PARAMETER(un_jour=86400.)
+!c======================================================================
+!c
+!c Declaration des procedures appelees
+!c
+      EXTERNAL angle     ! calculer angle zenithal du soleil
+      EXTERNAL alboc     ! calculer l'albedo sur ocean
+      EXTERNAL ajsec     ! ajustement sec
+      EXTERNAL conlmd    ! convection (schema LMD)
+!cKE43
+      EXTERNAL conema3  ! convect4.3
+      EXTERNAL fisrtilp  ! schema de condensation a grande echelle (pluie)
+!cAA 
+      EXTERNAL fisrtilp_tr ! schema de condensation a grande echelle (pluie)
+!c                          ! stockage des coefficients necessaires au
+!c                          ! lessivage OFF-LINE et ON-LINE
+      EXTERNAL hgardfou  ! verifier les temperatures
+      EXTERNAL nuage     ! calculer les proprietes radiatives
+!CC      EXTERNAL o3cm      ! initialiser l'ozone
+      EXTERNAL orbite    ! calculer l'orbite terrestre
+      EXTERNAL phyetat0  ! lire l'etat initial de la physique
+      EXTERNAL phyredem  ! ecrire l'etat de redemarrage de la physique
+      EXTERNAL suphel    ! initialiser certaines constantes
+      EXTERNAL transp    ! transport total de l'eau et de l'energie
+      EXTERNAL ecribina  ! ecrire le fichier binaire global
+      EXTERNAL ecribins  ! ecrire le fichier binaire global
+      EXTERNAL ecrirega  ! ecrire le fichier binaire regional
+      EXTERNAL ecriregs  ! ecrire le fichier binaire regional
+!IM
+      EXTERNAL haut2bas  !variables de haut en bas
+      EXTERNAL ini_undefSTD  !initialise a 0 une variable a 1 niveau de pression
+      EXTERNAL undefSTD      !somme les valeurs definies d'1 var a 1 niveau de pression
+!c     EXTERNAL moy_undefSTD  !moyenne d'1 var a 1 niveau de pression
+!c     EXTERNAL moyglo_aire   !moyenne globale d'1 var ponderee par l'aire de la maille (moyglo_pondaire)
+!c                            !par la masse/airetot (moyglo_pondaima) et la vraie masse (moyglo_pondmass)
+!c
+!c Variables locales
+!c
+      REAL rhcl(klon,klev)    ! humiditi relative ciel clair
+      REAL dialiq(klon,klev)  ! eau liquide nuageuse
+      REAL diafra(klon,klev)  ! fraction nuageuse
+      REAL cldliq(klon,klev)  ! eau liquide nuageuse
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL cldfra(klon,klev)  ! fraction nuageuse
+!      REAL cldtau(klon,klev)  ! epaisseur optique
+!      REAL cldemi(klon,klev)  ! emissivite infrarouge
+!c
+!CXXX PB 
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+      REAL fluxq(klon,klev, nbsrf)   ! flux turbulent d'humidite
+!      REAL fluxt(klon,klev, nbsrf)   ! flux turbulent de chaleur
+!      REAL fluxu(klon,klev, nbsrf)   ! flux turbulent de vitesse u
+!      REAL fluxv(klon,klev, nbsrf)   ! flux turbulent de vitesse v
+!c
+      REAL zxfluxt(klon, klev)
+      REAL zxfluxq(klon, klev)
+      REAL zxfluxu(klon, klev)
+      REAL zxfluxv(klon, klev)
+!CXXX
+!c
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL fsollw(klon, nbsrf)   ! bilan flux IR pour chaque sous surface
+!      REAL fsolsw(klon, nbsrf)   ! flux solaire absorb. pour chaque sous surface
+!c Le rayonnement n'est pas calcule tous les pas, il faut donc
+!c                      sauvegarder les sorties du rayonnement
+!cym      SAVE  heat,cool,albpla,topsw,toplw,solsw,sollw,sollwdown
+!cym      SAVE  sollwdownclr, toplwdown, toplwdownclr
+!cym      SAVE  topsw0,toplw0,solsw0,sollw0, heat0, cool0
+!c
+      INTEGER itaprad
+      SAVE itaprad
+!$OMP THREADPRIVATE(itaprad)
+!c
+      REAL conv_q(klon,klev) ! convergence de l'humidite (kg/kg/s)
+      REAL conv_t(klon,klev) ! convergence de la temperature(K/s)
+!c
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL cldl(klon),cldm(klon),cldh(klon) !nuages bas, moyen et haut
+!      REAL cldt(klon),cldq(klon) !nuage total, eau liquide integree
+!c
+!      REAL zxtsol(klon), zxqsurf(klon), zxsnow(klon), zxfluxlat(klon)
+      REAL zxsnow_dummy(klon)
+!c
+      REAL dist, rmu0(klon), fract(klon)
+      REAL zdtime, zlongi
+!c
+      CHARACTER*2 str2
+      CHARACTER*2 iqn
+!c
+      REAL qcheck
+      REAL z_avant(klon), z_apres(klon), z_factor(klon)
+      LOGICAL zx_ajustq
+!c
+      REAL za, zb
+      REAL zx_t, zx_qs, zdelta, zcor, zfra, zlvdcp, zlsdcp
+      real zqsat(klon,klev)
+      INTEGER i, k, iq, ig, j, nsrf, ll, l, iiq, iff
+      REAL t_coup
+      PARAMETER (t_coup=234.0)
+!c
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL zphi(klon,klev)
+!cym A voir plus tard !!
+!cym      REAL zx_relief(iim,jjmp1)
+!cym      REAL zx_aire(iim,jjmp1)
+!c
+!c Grandeurs de sorties
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL s_pblh(klon), s_lcl(klon), s_capCL(klon)
+!      REAL s_oliqCL(klon), s_cteiCL(klon), s_pblt(klon)
+!      REAL s_therm(klon), s_trmb1(klon), s_trmb2(klon)
+      REAL s_capCL(klon)
+      REAL s_oliqCL(klon), s_cteiCL(klon)
+      REAL s_trmb1(klon), s_trmb2(klon)
+      REAL s_trmb3(klon)
+!cKE43
+!c Variables locales pour la convection de K. Emanuel (sb):
+!c
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL upwd(klon,klev)      ! saturated updraft mass flux
+!      REAL dnwd(klon,klev)      ! saturated downdraft mass flux
+!      REAL dnwd0(klon,klev)     ! unsaturated downdraft mass flux
+      REAL tvp(klon,klev)       ! virtual temp of lifted parcel
+!      REAL plcl(klon)           ! Lifting Condensation Level
+!      REAL plfc(klon)           ! Level of Free Convection
+!      REAL wbeff(klon)          ! saturated updraft velocity at LFC
+      CHARACTER*40 capemaxcels  !max(CAPE)
+
+      REAL rflag(klon)          ! flag fonctionnement de convect
+      INTEGER iflagctrl(klon)          ! flag fonctionnement de convect
+
+!c -- convect43:
+      INTEGER ntra              ! nb traceurs pour convect4.3
+      REAL pori_con(klon)    ! pressure at the origin level of lifted parcel
+      REAL dtma_con(klon),dtlcl_con(klon)
+      REAL dtvpdt1(klon,klev), dtvpdq1(klon,klev)
+      REAL dplcldt(klon), dplcldr(klon)
+!c?     .     condm_con(klon,klev),conda_con(klon,klev),
+!c?     .     mr_con(klon,klev),ep_con(klon,klev)
+!c?     .    ,sadiab(klon,klev),wadiab(klon,klev)
+!c --
+!c34EK
+!c
+!c Variables du changement
+!c
+!c con: convection
+!c lsc: condensation a grande echelle (Large-Scale-Condensation)
+!c ajs: ajustement sec
+!c eva: evaporation de l'eau liquide nuageuse
+!c vdf: couche limite (Vertical DiFfusion)
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL rneb(klon,klev)
+
+! tendance nulles
+      REAL du0(klon,klev),dv0(klon,klev),dq0(klon,klev),dql0(klon,klev)
+
+!c
+!*********************************************************
+!*     declarations
+      
+!*********************************************************
+!IM 081204 END
+!c
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL pmfu(klon,klev), pmfd(klon,klev)
+      REAL pen_u(klon,klev), pen_d(klon,klev)
+      REAL pde_u(klon,klev), pde_d(klon,klev)
+      INTEGER kcbot(klon), kctop(klon), kdtop(klon)
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL pmflxr(klon,klev+1), pmflxs(klon,klev+1)
+!      REAL prfl(klon,klev+1), psfl(klon,klev+1)
+!c
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL rain_lsc(klon)
+!      REAL snow_lsc(klon)
+!c
+      REAL ratqsc(klon,klev)
+      real ratqsbas,ratqshaut,tau_ratqs
+      save ratqsbas,ratqshaut,tau_ratqs
+!$OMP THREADPRIVATE(ratqsbas,ratqshaut,tau_ratqs)
+      real zpt_conv(klon,klev)
+
+!c Parametres lies au nouveau schema de nuages (SB, PDF)
+      real fact_cldcon
+      real facttemps
+      logical ok_newmicro
+      save ok_newmicro
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      real ref_liq(klon,klev), ref_ice(klon,klev)
+
+!$OMP THREADPRIVATE(ok_newmicro)
+      save fact_cldcon,facttemps
+!$OMP THREADPRIVATE(fact_cldcon,facttemps)
+
+      integer iflag_cldcon
+      save iflag_cldcon
+!$OMP THREADPRIVATE(iflag_cldcon)
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      logical ptconv(klon,klev)
+!IM cf. AM 081204 BEG
+      logical ptconvth(klon,klev)
+!IM cf. AM 081204 END
+!c
+!c Variables liees a l'ecriture de la bande histoire physique
+!c
+!c======================================================================
+!c
+!IM cf. AM 081204 BEG
+!c   declarations pour sortir sur une sous-region
+      integer imin_ins,imax_ins,jmin_ins,jmax_ins
+      save imin_ins,imax_ins,jmin_ins,jmax_ins
+!$OMP THREADPRIVATE(imin_ins,imax_ins,jmin_ins,jmax_ins)
+!c      real lonmin_ins,lonmax_ins,latmin_ins
+!c     s  ,latmax_ins
+!c     data lonmin_ins,lonmax_ins,latmin_ins
+!c    s  ,latmax_ins/
+!c valeurs initiales     s   -5.,20.,41.,55./   
+!c    s   100.,130.,-20.,20./
+!c    s   -180.,180.,-90.,90./
+!c======================================================================
+!IM cf. AM 081204 END
+
+!c
+      integer itau_w   ! pas de temps ecriture = itap + itau_phy
+!c
+!c
+!c Variables locales pour effectuer les appels en serie
+!c
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule\n
+!      REAL zx_rh(klon,klev)
+!IM RH a 2m (la surface)
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL rh2m(klon), qsat2m(klon)
+!      REAL tpot(klon), tpote(klon)
+      REAL Lheat
+
+      INTEGER        length
+      PARAMETER    ( length = 100 )
+      REAL tabcntr0( length       )
+!c
+      INTEGER ndex2d(iim*jjmp1),ndex3d(iim*jjmp1*klev)
+!IM
+      INTEGER ndex2d1(iwmax)
+!c
+!IM AMIP2 BEG
+      REAL moyglo, mountor
+!IM 141004 BEG
+      REAL zustrdr(klon), zvstrdr(klon)
+      REAL zustrli(klon), zvstrli(klon)
+      REAL zustrph(klon), zvstrph(klon)
+      REAL zustrhi(klon), zvstrhi(klon)
+      REAL aam, torsfc
+!IM 141004 END
+!IM 190504 BEG
+      INTEGER ij, imp1jmp1
+      PARAMETER(imp1jmp1=(iim+1)*jjmp1)
+!cym A voir plus tard
+      REAL zx_tmp(imp1jmp1), airedyn(iim+1,jjmp1)
+      REAL padyn(iim+1,jjmp1,klev+1)
+      REAL dudyn(iim+1,jjmp1,klev)
+      REAL rlatdyn(iim+1,jjmp1)
+!IM 190504 END
+      LOGICAL ok_msk
+      REAL msk(klon)
+!IM 
+      REAL airetot, pi
+!cym A voir plus tard
+!cym      REAL zm_wo(jjmp1, klev)
+!IM AMIP2 END
+!c
+      REAL zx_tmp_fi2d(klon)      ! variable temporaire grille physique
+      REAL zx_tmp_fi3d(klon,klev) ! variable temporaire pour champs 3D 
+      REAL zx_tmp_fi3d1(klon,klev+1) !variable temporaire pour champs 3D (kelvp1)
+      REAL(KIND=8) zx_tmp2_fi3d(klon,klev) ! variable temporaire pour champs 3D 
+      REAL zx_tmp_2d(iim,jjmp1), zx_tmp_3d(iim,jjmp1,klev)
+      REAL zx_lon(iim,jjmp1), zx_lat(iim,jjmp1)
+!c
+      INTEGER nid_day, nid_mth, nid_ins, nid_mthnmc, nid_daynmc
+      INTEGER nid_hfnmc, nid_day_seri, nid_ctesGCM
+      SAVE nid_day, nid_mth, nid_ins, nid_mthnmc, nid_daynmc
+      SAVE nid_hfnmc, nid_day_seri, nid_ctesGCM
+!$OMP THREADPRIVATE(nid_day, nid_mth, nid_ins)
+!$OMP THREADPRIVATE(nid_mthnmc, nid_daynmc, nid_hfnmc)
+!$OMP THREADPRIVATE(nid_day_seri,nid_ctesGCM)
+!c
+!IM 280405 BEG
+      INTEGER nid_bilKPins, nid_bilKPave
+      SAVE nid_bilKPins, nid_bilKPave
+!$OMP THREADPRIVATE(nid_bilKPins, nid_bilKPave)
+!c
+      REAL ve_lay(klon,klev) ! transport meri. de l'energie a chaque niveau vert.
+      REAL vq_lay(klon,klev) ! transport meri. de l'eau a chaque niveau vert.
+      REAL ue_lay(klon,klev) ! transport zonal de l'energie a chaque niveau vert.
+      REAL uq_lay(klon,klev) ! transport zonal de l'eau a chaque niveau vert.
+!c
+      INTEGER nhori, nvert, nvert1, nvert3
+      REAL zsto, zsto1, zsto2
+      REAL zstophy, zstorad, zstohf, zstoday, zstomth, zout
+      REAL zcals(napisccp), zcalh(napisccp), zoutj(napisccp)
+      REAL zout_isccp(napisccp)
+      SAVE zcals, zcalh, zoutj, zout_isccp
+!$OMP THREADPRIVATE(zcals, zcalh, zoutj, zout_isccp)
+
+      real zjulian
+      save zjulian
+!$OMP THREADPRIVATE(zjulian)
+
+      character*20 modname
+      character*80 abort_message
+      logical ok_sync
+      real date0
+      integer idayref
+
+!C essai writephys
+      integer fid_day, fid_mth, fid_ins
+      parameter (fid_ins = 1, fid_day = 2, fid_mth = 3) 
+      integer prof2d_on, prof3d_on, prof2d_av, prof3d_av
+      parameter (prof2d_on = 1, prof3d_on = 2,                                       &
+       &           prof2d_av = 3, prof3d_av = 4)
+      character*30 nom_fichier
+      character*40 varname
+      character*40 vartitle
+      character*20 varunits
+!C     Variables liees au bilan d'energie et d'enthalpi
+      REAL ztsol(klon)
+      REAL      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot                           &
+       &        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+      SAVE      h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot                           &
+       &        , h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot
+!$OMP THREADPRIVATE(h_vcol_tot, h_dair_tot, h_qw_tot, h_ql_tot,
+!$OMP+              h_qs_tot, qw_tot, ql_tot, qs_tot , ec_tot)
+      REAL      d_h_vcol, d_h_dair, d_qt, d_qw, d_ql, d_qs, d_ec
+      REAL      d_h_vcol_phy
+      REAL      fs_bound, fq_bound
+      SAVE      d_h_vcol_phy
+!$OMP THREADPRIVATE(d_h_vcol_phy)
+      REAL      zero_v(klon)
+      CHARACTER*15 ztit
+      INTEGER   ip_ebil  ! PRINT level for energy conserv. diag.
+      SAVE      ip_ebil
+      DATA      ip_ebil/0/
+!$OMP THREADPRIVATE(ip_ebil)
+      INTEGER   if_ebil ! level for energy conserv. dignostics
+      SAVE      if_ebil
+!$OMP THREADPRIVATE(if_ebil)
+!c+jld ec_conser
+      REAL ZRCPD
+!c-jld ec_conser
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL t2m(klon,nbsrf)  ! temperature a 2m
+      REAL q2m(klon,nbsrf)  ! humidite a 2m
+
+!IM: t2m, q2m, ustar, u10m, v10m et t2mincels, t2maxcels
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL zt2m(klon), zq2m(klon)             !temp., hum. 2m moyenne s/ 1 maille
+!      REAL zustar(klon),zu10m(klon), zv10m(klon)  ! u* et vents a 10m moyennes s/1 maille
+      CHARACTER*40 t2mincels, t2maxcels       !t2m min., t2m max
+      CHARACTER*40 tinst, tave, typeval
+      REAL cldtaupi(klon,klev)  ! Cloud optical thickness for pre-industrial (pi) aerosols
+
+! L. Fita, LMD. January 2014. Defined in output_lmdz_NOmodule
+!      REAL re(klon, klev)       ! Cloud droplet effective radius
+!      REAL fl(klon, klev)  ! denominator of re
+
+      REAL re_top(klon), fl_top(klon) ! CDR at top of liquid water clouds
+
+      ! Aerosol optical properties
+      CHARACTER*4, DIMENSION(naero_grp) :: rfname 
+      REAL, DIMENSION(klon)          :: aerindex     ! POLDER aerosol index
+      REAL, DIMENSION(klon,klev)     :: mass_solu_aero    ! total mass concentration for all soluble aerosols[ug/m3]
+      REAL, DIMENSION(klon,klev)     :: mass_solu_aero_pi ! - " - (pre-industrial value)
+      INTEGER :: naero ! aerosol species 
+
+      ! Parameters
+      LOGICAL ok_ade, ok_aie    ! Apply aerosol (in)direct effects or not
+      LOGICAL ok_cdnc          ! ok cloud droplet number concentration (O. Boucher 01-2013)
+      REAL bl95_b0, bl95_b1   ! Parameter in Boucher and Lohmann (1995)
+      SAVE ok_ade, ok_aie, ok_cdnc, bl95_b0, bl95_b1
+!$OMP THREADPRIVATE(ok_ade, ok_aie, ok_cdnc, bl95_b0, bl95_b1)
+      LOGICAL, SAVE :: aerosol_couple ! true  : calcul des aerosols dans INCA
+                                      ! false : lecture des aerosol dans un fichier
+!$OMP THREADPRIVATE(aerosol_couple)    
+      INTEGER, SAVE :: flag_aerosol 
+!$OMP THREADPRIVATE(flag_aerosol) 
+      LOGICAL, SAVE :: new_aod
+!$OMP THREADPRIVATE(new_aod) 
+!c
+!c--STRAT AEROSOL
+      LOGICAL, SAVE :: flag_aerosol_strat
+!$OMP THREADPRIVATE(flag_aerosol_strat)
+!cc-fin STRAT AEROSOL
+!c
+!c Declaration des constantes et des fonctions thermodynamiques
+!c
+      LOGICAL,SAVE :: first=.true.
+!$OMP THREADPRIVATE(first)
+
+      integer iunit
+
+      integer, save::  read_climoz ! read ozone climatology
+!C     (let it keep the default OpenMP shared attribute)
+!C     Allowed values are 0, 1 and 2
+!C     0: do not read an ozone climatology
+!C     1: read a single ozone climatology that will be used day and night
+!C     2: read two ozone climatologies, the average day and night
+!C     climatology and the daylight climatology
+
+      integer, save:: ncid_climoz ! NetCDF file containing ozone climatologies
+!C     (let it keep the default OpenMP shared attribute)
+
+      real, pointer, save:: press_climoz(:)
+!C     (let it keep the default OpenMP shared attribute)
+!     edges of pressure intervals for ozone climatologies, in Pa, in strictly
+!     ascending order
+
+      integer, save:: co3i = 0
+!     time index in NetCDF file of current ozone fields
+!$OMP THREADPRIVATE(co3i) 
+
+      integer ro3i
+!     required time index in NetCDF file for the ozone fields, between 1
+!     and 360
+
+      INTEGER ierr
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+!IM 100106 BEG : pouvoir sortir les ctes de la physique
+#include "conema3.h"
+#include "fisrtilp.h"
+#include "nuage.h"
+#include "compbl.h"
+!IM 100106 END : pouvoir sortir les ctes de la physique
+!c
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c Declarations pour Simulateur COSP
+!c============================================================
+      real :: mr_ozone(klon,klev)
+
+!IM sorties fichier 1D paramLMDZ_phy.nc
+      REAL :: zx_tmp_0d(1,1)
+      INTEGER, PARAMETER :: np=1
+      REAL,dimension(klon_glo)        :: rlat_glo
+      REAL,dimension(klon_glo)        :: rlon_glo
+      REAL gbils(1), gevap(1), gevapt(1), glat(1), gnet0(1), gnet(1)
+      REAL grain(1), gtsol(1), gt2m(1), gprw(1)
+
+!IM stations CFMIP
+      INTEGER, SAVE :: nCFMIP
+!$OMP THREADPRIVATE(nCFMIP)
+      INTEGER, PARAMETER :: npCFMIP=120
+      INTEGER, ALLOCATABLE, SAVE :: tabCFMIP(:)
+      REAL, ALLOCATABLE, SAVE :: lonCFMIP(:), latCFMIP(:)
+!$OMP THREADPRIVATE(tabCFMIP, lonCFMIP, latCFMIP) 
+      INTEGER, ALLOCATABLE, SAVE :: tabijGCM(:)
+      REAL, ALLOCATABLE, SAVE :: lonGCM(:), latGCM(:)
+!$OMP THREADPRIVATE(tabijGCM, lonGCM, latGCM)
+      INTEGER, ALLOCATABLE, SAVE :: iGCM(:), jGCM(:)
+!$OMP THREADPRIVATE(iGCM, jGCM)
+      logical, dimension(nfiles)            :: phys_out_filestations
+      logical, parameter :: lNMC=.FALSE.
+
+!IM betaCRF
+      REAL, SAVE :: pfree, beta_pbl, beta_free
+!$OMP THREADPRIVATE(pfree, beta_pbl, beta_free)
+      REAL, SAVE :: lon1_beta,  lon2_beta, lat1_beta, lat2_beta
+!$OMP THREADPRIVATE(lon1_beta,  lon2_beta, lat1_beta, lat2_beta)
+      LOGICAL, SAVE :: mskocean_beta
+!$OMP THREADPRIVATE(mskocean_beta)
+      REAL, dimension(klon, klev) :: beta         ! facteur sur cldtaurad et cldemirad pour evaluer les retros liees aux CRF
+      REAL, dimension(klon, klev) :: cldtaurad    ! epaisseur optique pour radlwsw pour tester "CRF off"
+      REAL, dimension(klon, klev) :: cldtaupirad  ! epaisseur optique pour radlwsw pour tester "CRF off"
+      REAL, dimension(klon, klev) :: cldemirad    ! emissivite pour radlwsw pour tester "CRF off"
+      REAL, dimension(klon, klev) :: cldfrarad    ! fraction nuageuse
+
+      INTEGER :: nbtr_tmp ! Number of tracer inside concvl
+      REAL, dimension(klon,klev) :: sh_in ! Specific humidity entering in phytrac
+      integer iostat
+
+! Lluis
+      INTEGER                                            :: llp
+      llp = 644
+
+!c======================================================================
+! Gestion calendrier : mise a jour du module phys_cal_mod
+!
+      CALL phys_cal_update(jD_cur,jH_cur)
+      PRINT *,'  Lluis physiq: jD_cur: ',jD_cur, ' jH_cur: ',jH_cur, &
+        ' days_elapsed: ',days_elapsed
+
+!c======================================================================
+! Ecriture eventuelle d'un profil verticale en entree de la physique.
+! Utilise notamment en 1D mais peut etre active egalement en 3D
+! en imposant la valeur de igout.
+!c======================================================================
+
+      if (prt_level.ge.1) then
+! Lluis
+!          igout=klon/2+1/klon
+          igout=llp
+         write(lunout,*) 'DEBUT DE PHYSIQ !!!!!!!!!!!!!!!!!!!!'
+         write(lunout,*)                                                             &
+       & 'nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys'
+         write(lunout,*)                                                             &
+       &  nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur,pdtphys 
+
+         write(lunout,*) 'paprs, play, phi, u, v, t'
+         do k=1,klev
+            write(lunout,*) paprs(igout,k),pplay(igout,k),pphi(igout,k),             &
+       &   u(igout,k),v(igout,k),t(igout,k)
+         enddo
+         write(lunout,*) 'ovap (g/kg),  oliq (g/kg)'
+         do k=1,klev
+            write(lunout,*) qx(igout,k,1)*1000,qx(igout,k,2)*1000.
+         enddo
+      endif
+
+!c======================================================================
+
+!cym => necessaire pour iflag_con != 2    
+      pmfd(:,:) = 0.
+      pen_u(:,:) = 0.
+      pen_d(:,:) = 0.
+      pde_d(:,:) = 0.
+      pde_u(:,:) = 0.
+      aam=0.
+
+      torsfc=0.
+
+      forall (k=1: llm) zmasse(:, k) = (paprs(:, k)-paprs(:, k+1)) / rg
+
+      if (first) then 
+      
+!cCR:nvelles variables convection/poches froides
+      
+      print*, '================================================='
+      print*, 'Allocation des variables locales et sauvegardees'
+
+      call phys_local_var_init
+
+!c
+      pasphys=pdtphys
+!c     appel a la lecture du run.def physique
+      call conf_phys(ok_journe, ok_mensuel,                                          &
+       &     ok_instan, ok_hf,                                                       &
+       &     ok_LES,                                                                 &
+       &     callstats,                                                              &
+       &     solarlong0,seuil_inversion,                                             &
+       &     fact_cldcon, facttemps,ok_newmicro,iflag_radia,                         &
+       &     iflag_cldcon,iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs,                  &
+       &     ok_ade, ok_aie, ok_cdnc, aerosol_couple,                                &
+       &     flag_aerosol, flag_aerosol_strat, new_aod,                              &
+       &     bl95_b0, bl95_b1,                                                       &
+!c     nv flags pour la convection et les poches froides                             &
+       &     read_climoz,                                                            &
+       &     alp_offset)
+
+
+!!      call phys_state_var_init(read_climoz)
+      call phys_output_var_init
+
+
+!L. Fita, LMD. November 2013
+! Initializing
+! Variables have been already initialilzed from the WRF variables. 
+!   Using on purpose subroutines from physiq_limit_variables_mod
+!!      CALL neige_initialize()
+!!      CALL limit_initialize()
+!!      CALL vars_limit_init(klon)
+
+! L. Fita, LMD January 2014. Initializing output variables
+      CALL init_ovars_lmdz_NOmodule(klon,klev,nbsrf)
+
+! Allocating restart variables
+!      ALLOCATE(qsol(klon))
+!      ALLOCATE(fder(klon))
+!      ALLOCATE(snow(klon, nbsrf))
+!      ALLOCATE(qsurf(klon, nbsrf))
+!      ALLOCATE(evap(klon, nbsrf))
+!      ALLOCATE(rugos(klon, nbsrf))
+!      ALLOCATE(agesno(klon, nbsrf))
+!      ALLOCATE(ftsoil(klon, nsoilmx, nbsrf))
+!!      ALLOCATE(restart_runoff(klon))
+
+!      CALL pbl_surface_init(qsol_rst, fder_rst, snow_rst, qsurf_rst, evap_rst,       &
+!        rugos_rst, agesno_rst, ftsoil_rst)
+!      CALL fonte_neige_init(restart_runoff)
+!      qsol=qsol_rst
+
+      print*, '================================================='
+!c
+          dnwd0=0.0
+          ftd=0.0
+          fqd=0.0
+          cin=0.
+!cym Attention pbase pas initialise dans concvl !!!!
+          pbase=0
+!IM 180608
+
+        itau_con=0
+        first=.false.
+
+      endif  ! first
+
+       modname = 'physiq'
+!IM
+      IF (ip_ebil_phy.ge.1) THEN
+        DO i=1,klon
+          zero_v(i)=0.
+        END DO 
+      END IF 
+      ok_sync=.TRUE.
+
+      IF (debut) THEN
+         CALL suphel ! initialiser constantes et parametres phys.
+      ENDIF
+
+      if(prt_level.ge.1) print*,'CONVERGENCE PHYSIQUE THERM 1 '
+
+
+!c======================================================================
+! Gestion calendrier : mise a jour du module phys_cal_mod
+!
+!c     CALL phys_cal_update(jD_cur,jH_cur)
+
+!c
+!c Si c'est le debut, il faut initialiser plusieurs choses
+!c          ********
+!c
+
+       IF (debut) THEN
+!rv
+!cCRinitialisation de wght_th et lalim_conv pour la definition de la couche alimentation 
+!cde la convection a partir des caracteristiques du thermique
+         wght_th(:,:)=1.
+         lalim_conv(:)=1 
+!cRC
+         ustar(:,:)=0.
+         u10m(:,:)=0.
+         v10m(:,:)=0.
+         rain_con(:)=0.
+         snow_con(:)=0.
+         topswai(:)=0.
+         topswad(:)=0.
+         solswai(:)=0.
+         solswad(:)=0.
+
+         wmax_th(:)=0.
+         tau_overturning_th(:)=0.
+
+         IF (type_trac == 'inca') THEN
+            ! jg : initialisation jusqu'au ces variables sont dans restart
+            ccm(:,:,:) = 0.
+            tau_aero(:,:,:,:) = 0.
+            piz_aero(:,:,:,:) = 0.
+            cg_aero(:,:,:,:) = 0.
+         END IF
+
+         rnebcon0(:,:) = 0.0
+         clwcon0(:,:) = 0.0
+         rnebcon(:,:) = 0.0
+         clwcon(:,:) = 0.0
+
+!IM      
+         IF (ip_ebil_phy.ge.1) d_h_vcol_phy=0.
+!c
+      print*,'iflag_coupl,iflag_clos,iflag_wake',                                    &
+       &   iflag_coupl,iflag_clos,iflag_wake
+      print*,'CYCLE_DIURNE', cycle_diurne
+!c
+      IF (iflag_con.EQ.2.AND.iflag_cldcon.GT.-1) THEN
+         abort_message = 'Tiedtke needs iflag_cldcon=-2 or -1'
+         CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+!c
+      IF(ok_isccp.AND.iflag_con.LE.2) THEN
+         abort_message = 'ISCCP-like outputs may be available for KE                 &
+       &(iflag_con >= 3); for Tiedtke (iflag_con=-2) put ok_isccp=n'
+         CALL abort_gcm (modname,abort_message,1)
+      ENDIF
+!c
+!c Initialiser les compteurs:
+!c
+         itap    = 0
+         itaprad = 0
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Un petit travail \`a faire ici.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+         if (iflag_pbl>1) then
+             PRINT*, "Using method MELLOR&YAMADA" 
+         endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH 2008/05/02 changement lie a la lecture de nbapp_rad dans phylmd plutot que
+! dyn3d
+! Attention : la version precedente n'etait pas tres propre.
+! Il se peut qu'il faille prendre une valeur differente de nbapp_rad
+! pour obtenir le meme resultat.
+         dtime=pdtphys
+         radpas = NINT( 86400./dtime/nbapp_rad)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+         CALL phyetat0 ("startphy.nc",clesphy0,tabcntr0)
+
+         IF (klon_glo==1) THEN
+         coefh=0. ; coefm=0. ; pbl_tke=0.
+         coefh(:,2,:)=1.e-2 ; coefm(:,2,:)=1.e-2 ; pbl_tke(:,2,:)=1.e-2
+         PRINT*,'FH WARNING : lignes a supprimer'
+         ENDIF
+!IM begin
+          print*,'physiq: clwcon rnebcon ratqs',clwcon(1,1),rnebcon(1,1)             &
+       &,ratqs(1,1)
+!IM end
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+!C on remet le calendrier a zero
+!c
+         IF (raz_date .eq. 1) THEN
+           itau_phy = 0
+         ENDIF
+
+!IM cf. AM 081204 BEG
+         PRINT*,'cycle_diurne3 =',cycle_diurne
+!IM cf. AM 081204 END
+!c
+         CALL printflag( tabcntr0,radpas,ok_journe,                                  &
+       &                    ok_instan, ok_region )
+!c
+         IF (ABS(dtime-pdtphys).GT.0.001) THEN
+            WRITE(lunout,*) 'Pas physique n est pas correct',dtime,                  &
+       &                        pdtphys
+            abort_message='Pas physique n est pas correct '
+!           call abort_gcm(modname,abort_message,1)
+            dtime=pdtphys
+         ENDIF
+         IF (nlon .NE. klon) THEN
+            WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon,               &
+       &                      klon
+            abort_message='nlon et klon ne sont pas coherents'
+            call abort_gcm(modname,abort_message,1)
+         ENDIF
+         IF (nlev .NE. klev) THEN
+            WRITE(lunout,*)'nlev et klev ne sont pas coherents', nlev,               &
+       &                       klev
+            abort_message='nlev et klev ne sont pas coherents'
+            call abort_gcm(modname,abort_message,1)
+         ENDIF
+!c
+         IF (dtime*REAL(radpas).GT.21600..AND.cycle_diurne) THEN 
+           WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant'
+           WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne"
+           abort_message='Nbre d appels au rayonnement insuffisant'
+           call abort_gcm(modname,abort_message,1)
+         ENDIF
+         WRITE(lunout,*)"Clef pour la convection, iflag_con=", iflag_con
+         WRITE(lunout,*)"Clef pour le driver de la convection, ok_cvl=",             &
+       &                   ok_cvl
+!c
+!cKE43
+!c Initialisation pour la convection de K.E. (sb):
+         IF (iflag_con.GE.3) THEN
+
+         WRITE(lunout,*)"*** Convection de Kerry Emanuel 4.3  "
+         WRITE(lunout,*)                                                             &
+       &      "On va utiliser le melange convectif des traceurs qui"
+         WRITE(lunout,*)"est calcule dans convect4.3"
+         WRITE(lunout,*)" !!! penser aux logical flags de phytrac"
+
+          DO i = 1, klon
+           ema_cbmf(i) = 0.
+           ema_pcb(i)  = 0.
+           ema_pct(i)  = 0.
+!c          ema_workcbmf(i) = 0.
+          ENDDO
+!IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>BEG
+          DO i = 1, klon
+           ibas_con(i) = 1
+           itop_con(i) = 1
+          ENDDO
+!IM15/11/02 rajout initialisation ibas_con,itop_con cf. SB =>END
+!c===============================================================================
+!cCR:04.12.07: initialisations poches froides
+!c Controle de ALE et ALP pour la fermeture convective (jyg)
+          if (iflag_wake>=1) then
+            CALL ini_wake(0.,0.,it_wape_prescr,wape_prescr,fip_prescr                &
+       &                  ,alp_bl_prescr, ale_bl_prescr)
+!c 11/09/06 rajout initialisation ALE et ALP du wake et PBL(YU)
+!c        print*,'apres ini_wake iflag_cldcon=', iflag_cldcon
+          endif
+
+        do i = 1,klon
+         Ale_bl(i)=0.
+         Alp_bl(i)=0.
+        enddo
+
+!c================================================================================
+!IM stations CFMIP
+      nCFMIP=npCFMIP
+      OPEN(98,file='npCFMIP_param.data',status='old',                                &
+       &          form='formatted',iostat=iostat)
+            if (iostat == 0) then
+      READ(98,*,end=998) nCFMIP
+998   CONTINUE
+      CLOSE(98)
+      CONTINUE
+      IF(nCFMIP.GT.npCFMIP) THEN
+       print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler'
+       CALL abort
+      else
+       print*,'physiq npCFMIP=',npCFMIP,'nCFMIP=',nCFMIP
+      ENDIF
+
+!c
+      ALLOCATE(tabCFMIP(nCFMIP))
+      ALLOCATE(lonCFMIP(nCFMIP), latCFMIP(nCFMIP))
+      ALLOCATE(tabijGCM(nCFMIP))
+      ALLOCATE(lonGCM(nCFMIP), latGCM(nCFMIP))
+      ALLOCATE(iGCM(nCFMIP), jGCM(nCFMIP))
+!c
+!c lecture des nCFMIP stations CFMIP, de leur numero 
+!c et des coordonnees geographiques lonCFMIP, latCFMIP
+!c
+         CALL read_CFMIP_point_locations(nCFMIP, tabCFMIP,                           &
+       &lonCFMIP, latCFMIP)
+!c
+!c identification des
+!c 1) coordonnees lonGCM, latGCM des points CFMIP dans la grille de LMDZ
+!c 2) indices points tabijGCM de la grille physique 1d sur klon points
+!c 3) indices iGCM, jGCM de la grille physique 2d
+!c
+         CALL LMDZ_CFMIP_point_locations(nCFMIP, lonCFMIP, latCFMIP,                 &
+       &tabijGCM, lonGCM, latGCM, iGCM, jGCM)
+!c
+            else
+               ALLOCATE(tabijGCM(0))
+               ALLOCATE(lonGCM(0), latGCM(0))
+               ALLOCATE(iGCM(0), jGCM(0))
+            end if
+         else
+            ALLOCATE(tabijGCM(0))
+            ALLOCATE(lonGCM(0), latGCM(0))
+            ALLOCATE(iGCM(0), jGCM(0))
+         ENDIF
+ 
+           DO i=1,klon
+             rugoro(i) = f_rugoro * MAX(1.0e-05, zstd(i)*zsig(i)/2.0)
+           ENDDO
+
+!c34EK
+         IF (ok_orodr) THEN
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH sans doute a enlever de finitivement ou, si on le garde, l'activer
+! justement quand ok_orodr = false.
+! ce rugoro est utilise par la couche limite et fait double emploi
+! avec les param\'etrisations sp\'ecifiques de Francois Lott.
+!           DO i=1,klon
+!             rugoro(i) = MAX(1.0e-05, zstd(i)*zsig(i)/2.0)
+!           ENDDO
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+           IF (ok_strato) THEN
+             CALL SUGWD_strato(klon,klev,paprs,pplay)
+           ELSE
+             CALL SUGWD(klon,klev,paprs,pplay)
+           ENDIF
+           
+           DO i=1,klon
+             zuthe(i)=0.
+             zvthe(i)=0.
+             if(zstd(i).gt.10.)then
+               zuthe(i)=(1.-zgam(i))*cos(zthe(i))
+               zvthe(i)=(1.-zgam(i))*sin(zthe(i))
+             endif
+           ENDDO
+         ENDIF
+!c
+!c
+         lmt_pas = NINT(86400./dtime * 1.0)   ! tous les jours
+         WRITE(lunout,*)'La frequence de lecture surface est de ',                   &
+       &                   lmt_pas
+!c
+      capemaxcels = 't_max(X)'
+      t2mincels = 't_min(X)'
+      t2maxcels = 't_max(X)'
+      tinst = 'inst(X)'
+      tave = 'ave(X)'
+!IM cf. AM 081204 BEG
+      write(lunout,*)'AVANT HIST IFLAG_CON=',iflag_con
+!IM cf. AM 081204 END
+!c
+!c=============================================================
+!c   Initialisation des sorties
+!c=============================================================
+
+#ifdef CPP_IOIPSL
+
+!$OMP MASTER
+       call phys_output_open(rlon,rlat,nCFMIP,tabijGCM,                              &
+       &                       iGCM,jGCM,lonGCM,latGCM,                              &
+       &                       jjmp1,nlevSTD,clevSTD,                                &
+       &                       nbteta, ctetaSTD, dtime,ok_veget,                     &
+       &                       type_ocean,iflag_pbl,ok_mensuel,ok_journe,            &
+       &                       ok_hf,ok_instan,ok_LES,ok_ade,ok_aie,                 &
+       &                       read_climoz, phys_out_filestations,                   &
+       &                       new_aod, aerosol_couple,                              &
+       &                       flag_aerosol_strat )
+!$OMP END MASTER
+!$OMP BARRIER
+
+#ifdef histISCCP
+#include "ini_histISCCP.h"
+#endif
+
+#ifdef histNMC
+#include "ini_histhfNMC.h"
+#include "ini_histdayNMC.h"
+#include "ini_histmthNMC.h"
+#endif
+
+#include "ini_histday_seri.h"
+
+#include "ini_paramLMDZ_phy.h"
+
+#endif
+         ecrit_reg = ecrit_reg * un_jour
+         ecrit_tra = ecrit_tra * un_jour
+       
+!cXXXPB Positionner date0 pour initialisation de ORCHIDEE
+      date0 = jD_ref 
+      WRITE(*,*) 'physiq date0 : ',date0
+!c
+!c
+!c
+!c Prescrire l'ozone dans l'atmosphere
+!c
+!c
+!cc         DO i = 1, klon
+!cc         DO k = 1, klev
+!cc            CALL o3cm (paprs(i,k)/100.,paprs(i,k+1)/100., wo(i,k),20)
+!cc         ENDDO
+!cc         ENDDO
+!c
+      IF (type_trac == 'inca') THEN
+#ifdef INCA
+         CALL VTe(VTphysiq)
+         CALL VTb(VTinca)
+!         iii = MOD(NINT(xjour),360)
+!         calday = REAL(iii) + jH_cur
+         calday = REAL(days_elapsed) + jH_cur
+         WRITE(lunout,*) 'initial time chemini', days_elapsed, calday
+
+         CALL chemini(                                                               &
+       &                   rg,                                                       &
+       &                   ra,                                                       &
+       &                   airephy,                                                  &
+       &                   rlat,                                                     &
+       &                   rlon,                                                     &
+       &                   presnivs,                                                 &
+       &                   calday,                                                   &
+       &                   klon,                                                     &
+       &                   nqtot,                                                    &
+       &                   pdtphys,                                                  &
+       &                   annee_ref,                                                &
+       &                   day_ref,                                                  &
+       &                   itau_phy)
+
+         CALL VTe(VTinca)
+         CALL VTb(VTphysiq)
+#endif
+      END IF
+!c
+!c
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Nouvelle initialisation pour le rayonnement RRTM
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      call iniradia(klon,klev,paprs(1,1:klev+1))
+
+!$OMP single
+      if (read_climoz >= 1) then
+         call open_climoz(ncid_climoz, press_climoz)
+      END IF
+!$OMP end single
+!c
+!IM betaCRF
+      pfree=70000. !Pa
+      beta_pbl=1.
+      beta_free=1.
+      lon1_beta=-180.
+      lon2_beta=+180.
+      lat1_beta=90.
+      lat2_beta=-90.
+      mskocean_beta=.FALSE.
+
+      OPEN(99,file='beta_crf.data',status='old',                                     &
+       &          form='formatted',err=9999)
+      READ(99,*,end=9998) pfree
+      READ(99,*,end=9998) beta_pbl
+      READ(99,*,end=9998) beta_free
+      READ(99,*,end=9998) lon1_beta
+      READ(99,*,end=9998) lon2_beta
+      READ(99,*,end=9998) lat1_beta
+      READ(99,*,end=9998) lat2_beta
+      READ(99,*,end=9998) mskocean_beta
+9998  Continue
+      CLOSE(99)
+9999  Continue
+      WRITE(*,*)'pfree=',pfree
+      WRITE(*,*)'beta_pbl=',beta_pbl
+      WRITE(*,*)'beta_free=',beta_free
+      WRITE(*,*)'lon1_beta=',lon1_beta
+      WRITE(*,*)'lon2_beta=',lon2_beta
+      WRITE(*,*)'lat1_beta=',lat1_beta
+      WRITE(*,*)'lat2_beta=',lat2_beta
+      WRITE(*,*)'mskocean_beta=',mskocean_beta
+      ENDIF
+!
+!   ****************     Fin  de   IF ( debut  )   ***************
+!
+!
+! Incrementer le compteur de la physique
+!
+      itap   = itap + 1
+!c
+!
+! Update fraction of the sub-surfaces (pctsrf) and 
+! initialize, where a new fraction has appeared, all variables depending 
+! on the surface fraction.
+!
+      CALL change_srf_frac(itap, dtime, days_elapsed+1,                              &
+       &     pctsrf, falb1, falb2, ftsol, ustar, u10m, v10m, pbl_tke)
+
+! Update time and other variables in Reprobus
+      IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+         CALL Init_chem_rep_xjour(jD_cur-jD_ref+day_ref)
+         print*,'xjour equivalent rjourvrai',jD_cur-jD_ref+day_ref
+         CALL Rtime(debut)
+#endif
+      END IF
+
+
+! Tendances bidons pour les processus qui n'affectent pas certaines
+! variables.
+      du0(:,:)=0.
+      dv0(:,:)=0.
+      dq0(:,:)=0.
+      dql0(:,:)=0.
+!c
+!c Mettre a zero des variables de sortie (pour securite)
+!c
+      DO i = 1, klon
+         d_ps(i) = 0.0
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+         d_t(i,k) = 0.0
+         d_u(i,k) = 0.0
+         d_v(i,k) = 0.0
+      ENDDO
+      ENDDO
+      DO iq = 1, nqtot
+      DO k = 1, klev
+      DO i = 1, klon
+         d_qx(i,k,iq) = 0.0
+      ENDDO
+      ENDDO
+      ENDDO
+      da(:,:)=0.
+      mp(:,:)=0.
+      phi(:,:,:)=0.
+! RomP >>>
+      phi2(:,:,:)=0.
+      beta_prec_fisrt(:,:)=0.
+      beta_prec(:,:)=0.
+      epmlmMm(:,:,:)=0.
+      eplaMm(:,:)=0.
+      d1a(:,:)=0.
+      dam(:,:)=0.
+          pmflxr=0.
+          pmflxs=0.
+! RomP <<<
+
+!c
+!c Ne pas affecter les valeurs entrees de u, v, h, et q
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k)  = t(i,k)
+         u_seri(i,k)  = u(i,k)
+         v_seri(i,k)  = v(i,k)
+         q_seri(i,k)  = qx(i,k,ivap)
+         ql_seri(i,k) = qx(i,k,iliq)
+         qs_seri(i,k) = 0.
+      ENDDO
+      ENDDO
+      tke0(:,:)=pbl_tke(:,:,is_ave)
+      IF (nqtot.GE.3) THEN
+      DO iq = 3, nqtot
+      DO  k = 1, klev
+      DO  i = 1, klon
+         tr_seri(i,k,iq-2) = qx(i,k,iq)
+      ENDDO
+      ENDDO
+      ENDDO
+      ELSE
+      DO k = 1, klev
+      DO i = 1, klon
+         tr_seri(i,k,1) = 0.0
+      ENDDO
+      ENDDO
+      ENDIF
+!C
+      DO i = 1, klon
+        ztsol(i) = 0.
+      ENDDO
+      DO nsrf = 1, nbsrf
+        DO i = 1, klon
+          ztsol(i) = ztsol(i) + ftsol(i,nsrf)*pctsrf(i,nsrf)
+        ENDDO
+      ENDDO
+!IM
+      IF (ip_ebil_phy.ge.1) THEN 
+        ztit='after dynamic'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,1,1,dtime                             &
+       &      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay              &
+       &      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+!C     Comme les tendances de la physique sont ajoute dans la dynamique,
+!C     on devrait avoir que la variation d'entalpie par la dynamique
+!C     est egale a la variation de la physique au pas de temps precedent.
+!C     Donc la somme de ces 2 variations devrait etre nulle.
+        call diagphy(airephy,ztit,ip_ebil_phy                                        &
+       &      , zero_v, zero_v, zero_v, zero_v, zero_v                               &
+       &      , zero_v, zero_v, zero_v, ztsol                                        &
+       &      , d_h_vcol+d_h_vcol_phy, d_qt, 0.                                      &
+       &      , fs_bound, fq_bound )
+      END IF 
+
+!c Diagnostiquer la tendance dynamique
+!c
+      IF (ancien_ok) THEN
+         DO k = 1, klev
+         DO i = 1, klon
+            d_u_dyn(i,k) = (u_seri(i,k)-u_ancien(i,k))/dtime
+            d_v_dyn(i,k) = (v_seri(i,k)-v_ancien(i,k))/dtime
+            d_t_dyn(i,k) = (t_seri(i,k)-t_ancien(i,k))/dtime
+            d_q_dyn(i,k) = (q_seri(i,k)-q_ancien(i,k))/dtime
+         ENDDO
+         ENDDO
+!!! RomP >>>   td dyn traceur
+       IF (nqtot.GE.3) THEN
+          DO iq = 3, nqtot
+          DO k = 1, klev
+          DO i = 1, klon
+            d_tr_dyn(i,k,iq-2)=                                                      &
+       &       (tr_seri(i,k,iq-2)-tr_ancien(i,k,iq-2))/dtime
+!         iiq=niadv(iq)
+!         print*,i,k," d_tr_dyn",d_tr_dyn(i,k,iq-2),"tra:",iq,tname(iiq)
+          ENDDO
+          ENDDO
+          ENDDO
+       ENDIF
+!!! RomP <<<
+      ELSE
+         DO k = 1, klev
+         DO i = 1, klon
+            d_u_dyn(i,k) = 0.0
+            d_v_dyn(i,k) = 0.0
+            d_t_dyn(i,k) = 0.0
+            d_q_dyn(i,k) = 0.0
+         ENDDO
+         ENDDO
+!!! RomP >>>   td dyn traceur
+        IF (nqtot.GE.3) THEN
+          DO iq = 3, nqtot
+          DO k = 1, klev
+          DO i = 1, klon
+            d_tr_dyn(i,k,iq-2)= 0.0
+          ENDDO
+          ENDDO
+          ENDDO
+       ENDIF
+!!! RomP <<<
+         ancien_ok = .TRUE.
+      ENDIF
+!c
+!c Ajouter le geopotentiel du sol:
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         zphi(i,k) = pphi(i,k) + pphis(i)
+      ENDDO
+      ENDDO
+!c
+!c Verifier les temperatures
+!c
+!IM BEG
+      IF (check) THEN
+       amn=MIN(ftsol(1,is_ter),1000.)
+       amx=MAX(ftsol(1,is_ter),-1000.)
+       DO i=2, klon
+        amn=MIN(ftsol(i,is_ter),amn)
+        amx=MAX(ftsol(i,is_ter),amx)
+       ENDDO
+!c
+       PRINT*,' debut avant hgardfou min max ftsol',itap,amn,amx
+      ENDIF !(check) THEN
+
+!IM END
+!c
+
+      CALL hgardfou(t_seri,ftsol,'debutphy')
+!c
+!IM BEG
+      IF (check) THEN
+       amn=MIN(ftsol(1,is_ter),1000.)
+       amx=MAX(ftsol(1,is_ter),-1000.)
+       DO i=2, klon
+        amn=MIN(ftsol(i,is_ter),amn)
+        amx=MAX(ftsol(i,is_ter),amx)
+       ENDDO
+!c
+       PRINT*,' debut apres hgardfou min max ftsol',itap,amn,amx
+      ENDIF !(check) THEN
+
+!IM END
+!c
+!c Mettre en action les conditions aux limites (albedo, sst, etc.).
+!c Prescrire l'ozone et calculer l'albedo sur l'ocean.
+!c
+      if (read_climoz >= 1) then
+!C        Ozone from a file
+!        Update required ozone index:
+         ro3i = int((days_elapsed + jh_cur - jh_1jan)                                &
+       &        / ioget_year_len(year_cur) * 360.) + 1
+         if (ro3i == 361) ro3i = 360
+!C        (This should never occur, except perhaps because of roundup
+!C        error. See documentation.)
+         if (ro3i /= co3i) then
+!C           Update ozone field:
+            if (read_climoz == 1) then
+               call regr_pr_av(ncid_climoz, (/"tro3"/), julien=ro3i,                 &
+       &              press_in_edg=press_climoz, paprs=paprs, v3=wo)
+            else
+!C              read_climoz == 2
+               call regr_pr_av(ncid_climoz,                                          &
+       &              (/"tro3         ", "tro3_daylight"/),                          &
+       &              julien=ro3i, press_in_edg=press_climoz, paprs=paprs,           &
+       &              v3=wo)
+            end if
+!           Convert from mole fraction of ozone to column density of ozone in a
+!           cell, in kDU:
+            forall (l = 1: read_climoz) wo(:, :, l) = wo(:, :, l)                    &
+       &           * rmo3 / rmd * zmasse / dobson_u / 1e3
+!C           (By regridding ozone values for LMDZ only once every 360th of
+!C           year, we have already neglected the variation of pressure in one
+!C           360th of year. So do not recompute "wo" at each time step even if
+!C           "zmasse" changes a little.)
+            co3i = ro3i
+         end if
+      elseif (MOD(itap-1,lmt_pas) == 0) THEN
+!C        Once per day, update ozone from Royer:
+         wo(:, :, 1) = ozonecm(rlat, paprs, rjour=real(days_elapsed+1))
+      ENDIF
+
+!c
+!c Re-evaporer l'eau liquide nuageuse
+!c
+      DO k = 1, klev  ! re-evaporation de l'eau liquide nuageuse
+      DO i = 1, klon
+         zlvdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+!c        zlsdcp=RLSTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+         zlsdcp=RLVTT/RCPD/(1.0+RVTMP2*q_seri(i,k))
+         zdelta = MAX(0.,SIGN(1.,RTT-t_seri(i,k)))
+         zb = MAX(0.0,ql_seri(i,k))
+         za = - MAX(0.0,ql_seri(i,k))                                                &
+       &                  * (zlvdcp*(1.-zdelta)+zlsdcp*zdelta)
+         t_seri(i,k) = t_seri(i,k) + za
+         q_seri(i,k) = q_seri(i,k) + zb
+         ql_seri(i,k) = 0.0
+         d_t_eva(i,k) = za
+         d_q_eva(i,k) = zb
+      ENDDO
+      ENDDO
+!IM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after reevap'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,1,dtime                             &
+       &      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay              &
+       &      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(airephy,ztit,ip_ebil_phy                                       &
+       &      , zero_v, zero_v, zero_v, zero_v, zero_v                               &
+       &      , zero_v, zero_v, zero_v, ztsol                                        &
+       &      , d_h_vcol, d_qt, d_ec                                                 &
+       &      , fs_bound, fq_bound )
+!C
+      END IF 
+
+!c
+!c=========================================================================
+! Calculs de l'orbite.
+! Necessaires pour le rayonnement et la surface (calcul de l'albedo).
+! doit donc etre plac\'e avant radlwsw et pbl_surface
+
+!!!   jyg 17 Sep 2010 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      call ymds2ju(year_cur, mth_eq, day_eq,0., jD_eq)
+      day_since_equinox = (jD_cur + jH_cur) - jD_eq
+!
+!   choix entre calcul de la longitude solaire vraie ou valeur fixee a 
+!   solarlong0
+      if (solarlong0<-999.) then
+       if (new_orbit) then
+! calcul selon la routine utilisee pour les planetes
+        call solarlong(day_since_equinox, zlongi, dist)
+       else
+! calcul selon la routine utilisee pour l'AR4
+        CALL orbite(REAL(days_elapsed+1),zlongi,dist)
+       endif
+      else
+           zlongi=solarlong0  ! longitude solaire vraie
+           dist=1.            ! distance au soleil / moyenne 
+      endif
+      if(prt_level.ge.1)                                                &
+       &    write(lunout,*)'Longitude solaire ',zlongi,solarlong0,dist,&
+       ' jD_cur: ',jD_cur,' jH_cur: ',jH_cur,' days_elapsed: ', &
+       REAL(days_elapsed+1)
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Calcul de l'ensoleillement :
+! ============================
+! Pour une solarlong0=1000., on calcule un ensoleillement moyen sur
+! l'annee a partir d'une formule analytique.
+! Cet ensoleillement est sym\'etrique autour de l'\'equateur et
+! non nul aux poles.
+      IF (abs(solarlong0-1000.)<1.e-4) then
+         PRINT *,' Lluis calling zenang_an'
+         call zenang_an(cycle_diurne,jH_cur,rlat,rlon,rmu0,fract)
+      ELSE
+!  Avec ou sans cycle diurne
+         IF (cycle_diurne) THEN
+           zdtime=dtime*REAL(radpas) ! pas de temps du rayonnement (s)
+           CALL zenang(zlongi,jH_cur,zdtime,rlat,rlon,rmu0,fract)
+           PRINT *,'  Lluis: radpas: ',radpas,' fract: ',fract(llp),  &
+             ' zdtime: ',zdtime,' jH_cur: ',jH_cur,' rmu0: ',rmu0(llp),&
+             ' dtime: ',dtime,' nbapp_rad: ',nbapp_rad
+           PRINT *,' Lluis @rlat@: ',rlat
+           PRINT *,' Lluis @rlon@: ',rlon
+           PRINT *,' Lluis @rmu0@: ',rmu0
+           PRINT *,' Lluis @fract@: ',fract
+         ELSE
+           CALL angle(zlongi, rlat, fract, rmu0)
+         ENDIF
+      ENDIF
+      PRINT *,'  Lluis zenang_an rlat: ',rlat(llp), ' rlon:',rlon(llp), &
+        ' rmu0: ',rmu0(llp),' fract: ',fract(llp),' jH_cur: ',jH_cur,  &
+        ' cycle_diurne: ',cycle_diurne
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+        call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!c Appel au pbl_surface : Planetary Boudary Layer et Surface
+!c Cela implique tous les interactions des sous-surfaces et la partie diffusion 
+!c turbulent du couche limit. 
+!c 
+!c Certains varibales de sorties de pbl_surface sont utiliser que pour 
+!c ecriture des fihiers hist_XXXX.nc, ces sont :
+!c   qsol,      zq2m,      s_pblh,  s_lcl,
+!c   s_capCL,   s_oliqCL,  s_cteiCL,s_pblT,
+!c   s_therm,   s_trmb1,   s_trmb2, s_trmb3,
+!c   zxrugs,    zu10m,     zv10m,   fder,
+!c   zxqsurf,   rh2m,      zxfluxu, zxfluxv,
+!c   frugs,     agesno,    fsollw,  fsolsw,
+!c   d_ts,      fevap,     fluxlat, t2m,
+!c   wfbils,    wfbilo,    fluxt,   fluxu, fluxv,
+!c
+!c Certains ne sont pas utiliser du tout : 
+!c   dsens, devap, zxsnow, zxfluxt, zxfluxq, q2m, fluxq
+!c
+
+!c Calcul de l'humidite de saturation au niveau du sol
+
+
+
+      if (iflag_pbl/=0) then
+
+      PRINT *,'  Lluis before pbl_surface qsol: ',qsol(llp),    &
+        ' rmu0: ',rmu0(llp),' jH_cur: ',jH_cur
+
+      CALL pbl_surface(                                                              &
+       &     dtime,     date0,     itap,    days_elapsed+1,                          &
+       &     debut,     lafin,                                                       &
+       &     rlon,      rlat,      rugoro,  rmu0,                                    &
+       &     rain_fall, snow_fall, solsw,   sollw,                                   &
+       &     t_seri,    q_seri,    u_seri,  v_seri,                                  &
+       &     pplay,     paprs,     pctsrf,                                           &
+       &     ftsol,     falb1,     falb2,   ustar, u10m,   v10m,                     &
+       &     sollwdown, cdragh,    cdragm,  u1,    v1,                               &
+       &     albsol1,   albsol2,   sens,    evap,                                    &
+       &     zxtsol,    zxfluxlat, zt2m,    qsat2m,                                  &
+       &     d_t_vdf,   d_q_vdf,   d_u_vdf, d_v_vdf, d_t_diss,                       &
+       &     coefh,     coefm,     slab_wfbils,                                      &
+       &     qsol,      zq2m,      s_pblh,  s_lcl,                                   &
+       &     s_capCL,   s_oliqCL,  s_cteiCL,s_pblT,                                  &
+       &     s_therm,   s_trmb1,   s_trmb2, s_trmb3,                                 &
+       &     zxrugs,    zustar, zu10m,     zv10m,   fder,                            &
+       &     zxqsurf,   rh2m,      zxfluxu, zxfluxv,                                 &
+       &     frugs,     agesno,    fsollw,  fsolsw,                                  &
+       &     d_ts,      fevap,     fluxlat, t2m,                                     &
+       &     wfbils,    wfbilo,    fluxt,   fluxu,  fluxv,                           &
+       &     dsens,     devap,     zxsnow,                                           &
+       &     zxfluxt,   zxfluxq,   q2m,     fluxq, pbl_tke )
+
+      PRINT *,'  Lluis after pbl_surface qsol: ',qsol(llp),    &
+        ' rmu0: ',rmu0(llp),' jH_cur: ',jH_cur
+
+!-----------------------------------------------------------------------------------------
+! ajout des tendances de la diffusion turbulente
+      CALL add_phys_tend                                                             &
+       &     (d_u_vdf,d_v_vdf,d_t_vdf+d_t_diss,d_q_vdf,dql0,'vdf')
+!-----------------------------------------------------------------------------------------
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+        call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+         CALL evappot(klon,nbsrf,ftsol,pplay(:,1),cdragh,                            &
+       &      t_seri(:,1),q_seri(:,1),u_seri(:,1),v_seri(:,1),evap_pot)
+
+
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after surface_main'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime                             &
+       &      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay              &
+       &      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(airephy,ztit,ip_ebil_phy                                       &
+       &      , zero_v, zero_v, zero_v, zero_v, sens                                 &
+       &      , evap  , zero_v, zero_v, ztsol                                        &
+       &      , d_h_vcol, d_qt, d_ec                                                 &
+       &      , fs_bound, fq_bound )
+      END IF 
+
+      ENDIF
+!c =================================================================== c
+!c   Calcul de Qsat
+
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = t_seri(i,k)
+         IF (thermcep) THEN
+            zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
+            zx_qs  = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
+            zx_qs  = MIN(0.5,zx_qs)
+            zcor   = 1./(1.-retv*zx_qs)
+            zx_qs  = zx_qs*zcor
+         ELSE
+           IF (zx_t.LT.t_coup) THEN
+              zx_qs = qsats(zx_t)/pplay(i,k)
+           ELSE
+              zx_qs = qsatl(zx_t)/pplay(i,k)
+           ENDIF
+         ENDIF
+         zqsat(i,k)=zx_qs
+      ENDDO
+      ENDDO
+
+      if (prt_level.ge.1) then
+      write(lunout,*) 'L   qsat (g/kg) avant clouds_gno'
+      write(lunout,'(i4,f15.4)') (k,1000.*zqsat(igout,k),k=1,klev)
+      endif
+!c
+!c Appeler la convection (au choix)
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         conv_q(i,k) = d_q_dyn(i,k)                                                  &
+       &               + d_q_vdf(i,k)/dtime
+         conv_t(i,k) = d_t_dyn(i,k)                                                  &
+       &               + d_t_vdf(i,k)/dtime
+      ENDDO
+      ENDDO
+      IF (check) THEN
+         za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy)
+         WRITE(lunout,*) "avantcon=", za
+      ENDIF
+      zx_ajustq = .FALSE.
+      IF (iflag_con.EQ.2) zx_ajustq=.TRUE.
+      IF (zx_ajustq) THEN
+         DO i = 1, klon
+            z_avant(i) = 0.0
+         ENDDO
+         DO k = 1, klev
+         DO i = 1, klon
+            z_avant(i) = z_avant(i) + (q_seri(i,k)+ql_seri(i,k))                     &
+       &                        *(paprs(i,k)-paprs(i,k+1))/RG
+         ENDDO
+         ENDDO
+      ENDIF
+
+!c Calcule de vitesse verticale a partir de flux de masse verticale
+      DO k = 1, klev
+         DO i = 1, klon
+            omega(i,k) = RG*flxmass_w(i,k) / airephy(i)
+         END DO
+      END DO
+      if (prt_level.ge.1) write(lunout,*) 'omega(igout, :) = ',                      &
+       &     omega(igout, :)
+
+      IF (iflag_con.EQ.1) THEN
+        abort_message ='reactiver le call conlmd dans physiq.F'
+        CALL abort_gcm (modname,abort_message,1)
+!c     CALL conlmd (dtime, paprs, pplay, t_seri, q_seri, conv_q,
+!c    .             d_t_con, d_q_con,
+!c    .             rain_con, snow_con, ibas_con, itop_con)
+      ELSE IF (iflag_con.EQ.2) THEN
+      CALL conflx(dtime, paprs, pplay, t_seri, q_seri,                               &
+       &            conv_t, conv_q, -evap, omega,                                    &
+       &            d_t_con, d_q_con, rain_con, snow_con,                            &
+       &            pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,                          &
+       &            kcbot, kctop, kdtop, pmflxr, pmflxs)
+      d_u_con = 0.
+      d_v_con = 0.
+
+      WHERE (rain_con < 0.) rain_con = 0.
+      WHERE (snow_con < 0.) snow_con = 0.
+      DO i = 1, klon
+         ibas_con(i) = klev+1 - kcbot(i)
+         itop_con(i) = klev+1 - kctop(i)
+      ENDDO
+      ELSE IF (iflag_con.GE.3) THEN
+!c nb of tracers for the KE convection:
+!c MAF la partie traceurs est faite dans phytrac
+!c on met ntra=1 pour limiter les appels mais on peut
+!c supprimer les calculs / ftra.
+              ntra = 1
+
+!c=====================================================================================
+!cajout pour la parametrisation des poches froides: 
+!ccalcul de t_wake et t_undi: si pas de poches froides, t_wake=t_undi=t_seri 
+      do k=1,klev
+            do i=1,klon
+             if (iflag_wake>=1) then
+             t_wake(i,k) = t_seri(i,k)                                               &
+       &           +(1-wake_s(i))*wake_deltat(i,k)
+             q_wake(i,k) = q_seri(i,k)                                               &
+       &           +(1-wake_s(i))*wake_deltaq(i,k)
+             t_undi(i,k) = t_seri(i,k)                                               &
+       &           -wake_s(i)*wake_deltat(i,k)
+             q_undi(i,k) = q_seri(i,k)                                               &
+       &           -wake_s(i)*wake_deltaq(i,k)
+             else
+             t_wake(i,k) = t_seri(i,k)
+             q_wake(i,k) = q_seri(i,k)
+             t_undi(i,k) = t_seri(i,k)
+             q_undi(i,k) = q_seri(i,k)
+             endif
+            enddo
+         enddo
+      
+!cc--   Calcul de l'energie disponible ALE (J/kg) et de la puissance disponible ALP (W/m2)
+!cc--    pour le soulevement des particules dans le modele convectif
+!c
+      do i = 1,klon
+        ALE(i) = 0.
+        ALP(i) = 0.
+      enddo
+!c
+!ccalcul de ale_wake et alp_wake
+       if (iflag_wake>=1) then
+         if (itap .le. it_wape_prescr) then
+          do i = 1,klon
+           ale_wake(i) = wape_prescr
+           alp_wake(i) = fip_prescr
+          enddo
+         else
+          do i = 1,klon
+!cjyg  ALE=WAPE au lieu de ALE = 1/2 Cstar**2
+!ccc           ale_wake(i) = 0.5*wake_cstar(i)**2
+           ale_wake(i) = wake_pe(i)
+           alp_wake(i) = wake_fip(i)
+          enddo
+         endif
+       else
+         do i = 1,klon
+           ale_wake(i) = 0.
+           alp_wake(i) = 0.
+         enddo
+       endif
+!ccombinaison avec ale et alp de couche limite: constantes si pas de couplage, valeurs calculees
+!cdans le thermique sinon
+       if (iflag_coupl.eq.0) then
+          if (debut.and.prt_level.gt.9)                                              &
+       &                     WRITE(lunout,*)'ALE et ALP imposes'
+          do i = 1,klon
+!con ne couple que ale
+!c           ALE(i) = max(ale_wake(i),Ale_bl(i))
+            ALE(i) = max(ale_wake(i),ale_bl_prescr)
+!con ne couple que alp
+!c           ALP(i) = alp_wake(i) + Alp_bl(i)
+            ALP(i) = alp_wake(i) + alp_bl_prescr
+          enddo
+       else
+         IF(prt_level>9)WRITE(lunout,*)'ALE et ALP couples au thermique'
+!         do i = 1,klon
+!             ALE(i) = max(ale_wake(i),Ale_bl(i))
+! avant        ALP(i) = alp_wake(i) + Alp_bl(i)
+!             ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb
+!         write(20,*)'ALE',ALE(i),Ale_bl(i),ale_wake(i)
+!         write(21,*)'ALP',ALP(i),Alp_bl(i),alp_wake(i)
+!         enddo
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Modif FH 2010/04/27. Sans doute temporaire.
+! Deux options pour le alp_offset : constant si >?? 0 ou proportionnel ??a
+! w si <0
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+       do i = 1,klon
+          ALE(i) = max(ale_wake(i),Ale_bl(i))
+!ccc nrlmd le 10/04/2012----------Stochastic triggering--------------
+          if (iflag_trig_bl.ge.1) then
+             ALE(i) = max(ale_wake(i),Ale_bl_trig(i))
+          endif
+!ccc fin nrlmd le 10/04/2012
+          if (alp_offset>=0.) then
+            ALP(i) = alp_wake(i) + Alp_bl(i) + alp_offset ! modif sb
+          else
+            ALP(i)=alp_wake(i)+Alp_bl(i)+alp_offset*min(omega(i,6),0.)
+            if (alp(i)<0.) then
+               print*,'ALP ',alp(i),alp_wake(i)                                      &
+       &         ,Alp_bl(i),alp_offset*min(omega(i,6),0.)
+            endif
+          endif
+       enddo
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+       endif
+       do i=1,klon
+          if (alp(i)>alp_max) then
+             IF(prt_level>9)WRITE(lunout,*)                             &
+       &       'WARNING SUPER ALP (seuil=',alp_max,                                  &
+       &       '): i, alp, alp_wake,ale',i,alp(i),alp_wake(i),ale(i)
+             alp(i)=alp_max
+          endif
+          if (ale(i)>ale_max) then
+             IF(prt_level>9)WRITE(lunout,*)                             &
+       &       'WARNING SUPER ALE (seuil=',ale_max,                                  &
+       &       '): i, alp, alp_wake,ale',i,ale(i),ale_wake(i),alp(i)
+             ale(i)=ale_max
+          endif
+       enddo
+
+!cfin calcul ale et alp
+!c=================================================================================================
+
+
+!c sb, oct02:
+!c Schema de convection modularise et vectorise:
+!c (driver commun aux versions 3 et 4)
+!c
+          IF (ok_cvl) THEN ! new driver for convectL
+
+             IF (type_trac == 'repr') THEN
+                nbtr_tmp=ntra
+             ELSE
+                nbtr_tmp=nbtr
+             END IF
+          CALL concvl (iflag_con,iflag_clos,                                         &
+       &        dtime,paprs,pplay,t_undi,q_undi,                                     &
+       &        t_wake,q_wake,wake_s,                                                &
+       &        u_seri,v_seri,tr_seri,nbtr_tmp,                                      &
+       &        ALE,ALP,                                                             &
+       &        ema_work1,ema_work2,                                                 &
+       &        d_t_con,d_q_con,d_u_con,d_v_con,d_tr,                                &
+       &        rain_con, snow_con, ibas_con, itop_con, sigd,                        &
+       &        ema_cbmf,plcl,plfc,wbeff,upwd,dnwd,dnwd0,                            &
+       &        Ma,mip,Vprecip,cape,cin,tvp,Tconv,iflagctrl,                         &
+       &        pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd,               &
+! RomP >>>
+!!     .        pmflxr,pmflxs,da,phi,mp,
+!!     .        ftd,fqd,lalim_conv,wght_th)                                          &
+       &        pmflxr,pmflxs,da,phi,mp,phi2,d1a,dam,sij,clw,elij,                   &
+       &        ftd,fqd,lalim_conv,wght_th,                                          &
+       &        ev, ep,epmlmMm,eplaMm,                                               &
+       &        wdtrainA,wdtrainM)
+! RomP <<<
+
+!IM begin
+!c       print*,'physiq: cin pbase dnwd0 ftd fqd ',cin(1),pbase(1),
+!c    .dnwd0(1,1),ftd(1,1),fqd(1,1)
+!IM end
+!IM cf. FH
+              clwcon0=qcondc
+              pmfu(:,:)=upwd(:,:)+dnwd(:,:)
+
+              do i = 1, klon
+                if (iflagctrl(i).le.1) itau_con(i)=itau_con(i)+1
+              enddo
+
+          ELSE ! ok_cvl
+
+!c MAF conema3 ne contient pas les traceurs
+          CALL conema3 (dtime,                                                       &
+       &        paprs,pplay,t_seri,q_seri,                                           &
+       &        u_seri,v_seri,tr_seri,ntra,                                          &
+       &        ema_work1,ema_work2,                                                 &
+       &        d_t_con,d_q_con,d_u_con,d_v_con,d_tr,                                &
+       &        rain_con, snow_con, ibas_con, itop_con,                              &
+       &        upwd,dnwd,dnwd0,bas,top,                                             &
+       &        Ma,cape,tvp,rflag,                                                   &
+       &        pbase                                                                &
+       &        ,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr                               &
+       &        ,clwcon0)
+
+          ENDIF ! ok_cvl
+
+!c
+!c Correction precip
+          rain_con = rain_con * cvl_corr
+          snow_con = snow_con * cvl_corr
+!c
+
+           IF (.NOT. ok_gust) THEN
+           do i = 1, klon
+            wd(i)=0.0
+           enddo
+           ENDIF
+
+!c =================================================================== c
+!c Calcul des proprietes des nuages convectifs
+!c
+
+!c   calcul des proprietes des nuages convectifs
+             clwcon0(:,:)=fact_cldcon*clwcon0(:,:)
+             call clouds_gno                                                         &
+       &       (klon,klev,q_seri,zqsat,clwcon0,ptconv,ratqsc,rnebcon0)
+
+!c =================================================================== c
+
+          DO i = 1, klon
+           itop_con(i) = min(max(itop_con(i),1),klev)
+           ibas_con(i) = min(max(ibas_con(i),1),itop_con(i))
+          ENDDO
+
+          DO i = 1, klon
+            ema_pcb(i)  = paprs(i,ibas_con(i))
+          ENDDO
+          DO i = 1, klon
+! L'idicage de itop_con peut cacher un pb potentiel
+! FH sous la dictee de JYG, CR
+            ema_pct(i)  = paprs(i,itop_con(i)+1)
+
+            if (itop_con(i).gt.klev-3) then
+              if(prt_level >= 9) then
+                write(lunout,*)'La convection monte trop haut '
+                write(lunout,*)'itop_con(,',i,',)=',itop_con(i)
+              endif
+            endif
+          ENDDO     
+      ELSE IF (iflag_con.eq.0) THEN
+          write(lunout,*) 'On n appelle pas la convection'
+          clwcon0=0.
+          rnebcon0=0.
+          d_t_con=0.
+          d_q_con=0.
+          d_u_con=0.
+          d_v_con=0.
+          rain_con=0.
+          snow_con=0.
+          bas=1
+          top=1
+      ELSE
+          WRITE(lunout,*) "iflag_con non-prevu", iflag_con
+          CALL abort
+      ENDIF
+
+!c     CALL homogene(paprs, q_seri, d_q_con, u_seri,v_seri,
+!c    .              d_u_con, d_v_con)
+
+!-----------------------------------------------------------------------------------------
+! ajout des tendances de la diffusion turbulente
+      CALL add_phys_tend(d_u_con,d_v_con,d_t_con,d_q_con,dql0,'con')
+!-----------------------------------------------------------------------------------------
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+        call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+!IM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after convect'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime                             &
+       &      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay              &
+       &      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(airephy,ztit,ip_ebil_phy                                       &
+       &      , zero_v, zero_v, zero_v, zero_v, zero_v                               &
+       &      , zero_v, rain_con, snow_con, ztsol                                    &
+       &      , d_h_vcol, d_qt, d_ec                                                 &
+       &      , fs_bound, fq_bound )
+      END IF 
+!C
+      IF (check) THEN
+          za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy)
+          WRITE(lunout,*)"aprescon=", za
+          zx_t = 0.0
+          za = 0.0
+          DO i = 1, klon
+            za = za + airephy(i)/REAL(klon)
+            zx_t = zx_t + (rain_con(i)+                                              &
+       &                   snow_con(i))*airephy(i)/REAL(klon)
+          ENDDO
+          zx_t = zx_t/za*dtime
+          WRITE(lunout,*)"Precip=", zx_t
+      ENDIF
+      IF (zx_ajustq) THEN
+          DO i = 1, klon
+            z_apres(i) = 0.0
+          ENDDO
+          DO k = 1, klev
+            DO i = 1, klon
+              z_apres(i) = z_apres(i) + (q_seri(i,k)+ql_seri(i,k))                   &
+       &            *(paprs(i,k)-paprs(i,k+1))/RG
+            ENDDO
+          ENDDO
+          DO i = 1, klon
+            z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*dtime)               &
+       &          /z_apres(i)
+          ENDDO
+          DO k = 1, klev
+            DO i = 1, klon
+              IF (z_factor(i).GT.(1.0+1.0E-08) .OR.                                  &
+       &            z_factor(i).LT.(1.0-1.0E-08)) THEN
+                  q_seri(i,k) = q_seri(i,k) * z_factor(i)
+              ENDIF
+            ENDDO
+          ENDDO
+      ENDIF
+      zx_ajustq=.FALSE.
+
+!c
+!c=============================================================================
+!cRR:Evolution de la poche froide: on ne fait pas de separation wake/env 
+!cpour la couche limite diffuse pour l instant
+!c
+      if (iflag_wake>=1) then
+      DO k=1,klev
+        DO i=1,klon
+          dt_dwn(i,k)  = ftd(i,k) 
+          wdt_PBL(i,k) = 0.
+          dq_dwn(i,k)  = fqd(i,k) 
+          wdq_PBL(i,k) = 0.
+          M_dwn(i,k)   = dnwd0(i,k)
+          M_up(i,k)    = upwd(i,k)
+          dt_a(i,k)    = d_t_con(i,k)/dtime - ftd(i,k) 
+          udt_PBL(i,k) = 0.
+          dq_a(i,k)    = d_q_con(i,k)/dtime - fqd(i,k)
+          udq_PBL(i,k) = 0.
+        ENDDO
+      ENDDO
+
+      if (iflag_wake==2) then
+        ok_wk_lsp(:)=max(sign(1.,wake_s(:)-wake_s_min_lsp),0.)
+        DO k = 1,klev
+         dt_dwn(:,k)= dt_dwn(:,k)+                                                   &
+       &            ok_wk_lsp(:)*(d_t_eva(:,k)+d_t_lsc(:,k))/dtime
+         dq_dwn(:,k)= dq_dwn(:,k)+                                                   &
+       &            ok_wk_lsp(:)*(d_q_eva(:,k)+d_q_lsc(:,k))/dtime
+        ENDDO
+      endif
+!c
+!ccalcul caracteristiques de la poche froide
+      call calWAKE (paprs,pplay,dtime                                                &
+       &               ,t_seri,q_seri,omega                                          &
+       &               ,dt_dwn,dq_dwn,M_dwn,M_up                                     &
+       &               ,dt_a,dq_a,sigd                                               &
+       &               ,wdt_PBL,wdq_PBL                                              &
+       &               ,udt_PBL,udq_PBL                                              &
+       &               ,wake_deltat,wake_deltaq,wake_dth                             &
+       &               ,wake_h,wake_s,wake_dens                                      &
+       &               ,wake_pe,wake_fip,wake_gfl                                    &
+       &               ,dt_wake,dq_wake                                              &
+       &               ,wake_k, t_undi,q_undi                                        &
+       &               ,wake_omgbdth,wake_dp_omgb                                    &
+       &               ,wake_dtKE,wake_dqKE                                          &
+       &               ,wake_dtPBL,wake_dqPBL                                        &
+       &               ,wake_omg,wake_dp_deltomg                                     &
+       &               ,wake_spread,wake_Cstar,wake_d_deltat_gw                      &
+       &               ,wake_ddeltat,wake_ddeltaq)
+!c
+!-----------------------------------------------------------------------------------------
+! ajout des tendances des poches froides
+! Faire rapidement disparaitre l'ancien dt_wake pour garder un d_t_wake
+! coherent avec les autres d_t_...
+      d_t_wake(:,:)=dt_wake(:,:)*dtime
+      d_q_wake(:,:)=dq_wake(:,:)*dtime
+      CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,'wake')
+!-----------------------------------------------------------------------------------------
+
+      endif
+!c
+!c===================================================================
+!cJYG
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after wake'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime                             &
+       &      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay              &
+       &      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+        call diagphy(airephy,ztit,ip_ebil_phy                                        &
+       &      , zero_v, zero_v, zero_v, zero_v, zero_v                               &
+       &      , zero_v, zero_v, zero_v, ztsol                                        &
+       &      , d_h_vcol, d_qt, d_ec                                                 &
+       &      , fs_bound, fq_bound )
+      END IF 
+
+!c      print*,'apres callwake iflag_cldcon=', iflag_cldcon
+!c
+!c===================================================================
+!c Convection seche (thermiques ou ajustement)
+!c===================================================================
+!c
+       call stratocu_if(klon,klev,pctsrf,paprs, pplay,t_seri                         &
+       & ,seuil_inversion,weak_inversion,dthmin)
+
+
+
+      d_t_ajsb(:,:)=0.
+      d_q_ajsb(:,:)=0.
+      d_t_ajs(:,:)=0.
+      d_u_ajs(:,:)=0.
+      d_v_ajs(:,:)=0.
+      d_q_ajs(:,:)=0.
+      clwcon0th(:,:)=0.
+!c
+!c      fm_therm(:,:)=0.
+!c      entr_therm(:,:)=0.
+!c      detr_therm(:,:)=0.
+!c
+      IF(prt_level>9)WRITE(lunout,*)                                                 &
+       &    'AVANT LA CONVECTION SECHE , iflag_thermals='                            &
+       &   ,iflag_thermals,'   nsplit_thermals=',nsplit_thermals
+      if(iflag_thermals.lt.0) then
+!c  Rien
+!c  ====
+         IF(prt_level>9)WRITE(lunout,*)'pas de convection'
+
+
+      else
+
+!c  Thermiques
+!c  ==========
+         IF(prt_level>9)WRITE(lunout,*)'JUSTE AVANT , iflag_thermals='               &
+       &   ,iflag_thermals,'   nsplit_thermals=',nsplit_thermals
+
+
+!ccc nrlmd le 10/04/2012
+         DO k=1,klev+1
+           DO i=1,klon
+           pbl_tke_input(i,k,is_oce)=pbl_tke(i,k,is_oce)
+           pbl_tke_input(i,k,is_ter)=pbl_tke(i,k,is_ter)
+           pbl_tke_input(i,k,is_lic)=pbl_tke(i,k,is_lic)
+           pbl_tke_input(i,k,is_sic)=pbl_tke(i,k,is_sic)
+           ENDDO
+         ENDDO
+!ccc fin nrlmd le 10/04/2012
+
+         if (iflag_thermals>=1) then
+         call calltherm(pdtphys                                                      &
+       &      ,pplay,paprs,pphi,weak_inversion                                       &
+       &      ,u_seri,v_seri,t_seri,q_seri,zqsat,debut                               &
+       &      ,d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs                                       &
+       &      ,fm_therm,entr_therm,detr_therm                                        &
+       &      ,zqasc,clwcon0th,lmax_th,ratqscth                                      &
+       &      ,ratqsdiff,zqsatth                                                     &
+!con rajoute ale et alp, et les caracteristiques de la couche alim                   &
+       &      ,Ale_bl,Alp_bl,lalim_conv,wght_th, zmax0, f0, zw2,fraca                &
+       &      ,ztv,zpspsk,ztla,zthl                                                  &
+!ccc nrlmd le 10/04/2012                                                             &
+       &      ,pbl_tke_input,pctsrf,omega,airephy                                    &
+       &      ,zlcl_th,fraca0,w0,w_conv,therm_tke_max0,env_tke_max0                  &
+       &      ,n2,s2,ale_bl_stat                                                     &
+       &      ,therm_tke_max,env_tke_max                                             &
+       &      ,alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke                            &
+       &      ,alp_bl_conv,alp_bl_stat                                               &
+!ccc fin nrlmd le 10/04/2012                                                         &
+       &      ,zqla,ztva )
+
+!ccc nrlmd le 10/04/2012
+!c-----------Stochastic triggering-----------
+      if (iflag_trig_bl.ge.1) then
+!c
+        IF (prt_level .GE. 10) THEN
+         print *,'cin, ale_bl_stat, alp_bl_stat ',                                   &
+       &            cin, ale_bl_stat, alp_bl_stat
+        ENDIF
+
+!c----Initialisations
+      do i=1,klon
+      proba_notrig(i)=1.
+      random_notrig(i)=1e6*ale_bl_stat(i)-int(1e6*ale_bl_stat(i))
+        if ( ale_bl_trig(i) .lt. abs(cin(i))+1.e-10 ) then 
+        tau_trig(i)=tau_trig_shallow
+        else
+        tau_trig(i)=tau_trig_deep
+        endif
+      enddo
+!c
+        IF (prt_level .GE. 10) THEN
+         print *,'random_notrig, tau_trig ',                                         &
+       &            random_notrig, tau_trig
+          print *,'s_trig,s2,n2 ',                                                   &
+       &             s_trig,s2,n2
+        ENDIF
+
+!c----Tirage al\'eatoire et calcul de ale_bl_trig
+      do i=1,klon
+        if ( (ale_bl_stat(i) .gt. abs(cin(i))+1.e-10) )  then
+        proba_notrig(i)=(1.-exp(-s_trig/s2(i)))**                                    &
+       &                  (n2(i)*dtime/tau_trig(i))
+!c        print *, 'proba_notrig(i) ',proba_notrig(i)
+          if (random_notrig(i) .ge. proba_notrig(i)) then 
+          ale_bl_trig(i)=ale_bl_stat(i)
+          else
+          ale_bl_trig(i)=0.
+          endif
+        else
+        proba_notrig(i)=1.
+        random_notrig(i)=0.
+        ale_bl_trig(i)=0.
+        endif
+      enddo
+!c
+        IF (prt_level .GE. 10) THEN
+         print *,'proba_notrig, ale_bl_trig ',                                       &
+       &            proba_notrig, ale_bl_trig
+        ENDIF
+
+      endif !(iflag_trig_bl)
+
+!c-----------Statistical closure-----------
+      if (iflag_clos_bl.ge.1) then 
+
+        do i=1,klon
+        alp_bl(i)=alp_bl_stat(i)
+        enddo
+
+      else
+
+      alp_bl_stat(:)=0.
+
+      endif !(iflag_clos_bl)
+
+        IF (prt_level .GE. 10) THEN
+         print *,'ale_bl_trig, alp_bl_stat ',ale_bl_trig, alp_bl_stat
+        ENDIF
+
+!ccc fin nrlmd le 10/04/2012
+
+! ----------------------------------------------------------------------
+! Transport de la TKE par les panaches thermiques.
+! FH : 2010/02/01
+!     if (iflag_pbl.eq.10) then
+!     call thermcell_dtke(klon,klev,nbsrf,pdtphys,fm_therm,entr_therm,
+!    s           rg,paprs,pbl_tke)
+!     endif
+! ----------------------------------------------------------------------
+!IM/FH: 2011/02/23 
+! Couplage Thermiques/Emanuel seulement si T<0
+      if (iflag_coupl==2) then
+        print*,'Couplage Thermiques/Emanuel seulement si T<0'
+        do i=1,klon
+           if (t_seri(i,lmax_th(i))>273.) then
+              Ale_bl(i)=0.
+           endif
+        enddo
+      endif
+
+      do i=1,klon
+         zmax_th(i)=pphi(i,lmax_th(i))/rg
+      enddo
+
+         endif
+
+
+!c  Ajustement sec
+!c  ==============
+
+! Dans le cas o\`u on active les thermiques, on fait partir l'ajustement
+! a partir du sommet des thermiques.
+! Dans le cas contraire, on demarre au niveau 1.
+
+         if (iflag_thermals.ge.13.or.iflag_thermals.eq.0) then
+
+         if(iflag_thermals.eq.0) then
+            IF(prt_level>9)WRITE(lunout,*)'ajsec'
+            limbas(:)=1
+         else
+            limbas(:)=lmax_th(:)
+         endif
+  
+! Attention : le call ajsec_convV2 n'est maintenu que momentanneement
+! pour des test de convergence numerique.
+! Le nouveau ajsec est a priori mieux, meme pour le cas 
+! iflag_thermals = 0 (l'ancienne version peut faire des tendances
+! non nulles numeriquement pour des mailles non concernees.
+
+         if (iflag_thermals.eq.0) then
+            CALL ajsec_convV2(paprs, pplay, t_seri,q_seri                            &
+       &      , d_t_ajsb, d_q_ajsb)
+         else
+            CALL ajsec(paprs, pplay, t_seri,q_seri,limbas                            &
+       &      , d_t_ajsb, d_q_ajsb)
+         endif
+
+!-----------------------------------------------------------------------------------------
+! ajout des tendances de l'ajustement sec ou des thermiques
+      CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,'ajsb')
+         d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:)
+         d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:)
+
+!-----------------------------------------------------------------------------------------
+
+         endif
+
+      endif
+!c
+!c===================================================================
+!IM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after dry_adjust'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime                             &
+       &      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay              &
+       &      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+        call diagphy(airephy,ztit,ip_ebil_phy                                        &
+       &      , zero_v, zero_v, zero_v, zero_v, zero_v                               &
+       &      , zero_v, zero_v, zero_v, ztsol                                        &
+       &      , d_h_vcol, d_qt, d_ec                                                 &
+       &      , fs_bound, fq_bound )
+      END IF 
+
+
+!c-------------------------------------------------------------------------
+! Computation of ratqs, the width (normalized) of the subrid scale 
+! water distribution
+      CALL  calcratqs(klon,klev,prt_level,lunout,                                    &
+       &     iflag_ratqs,iflag_con,iflag_cldcon,pdtphys,                             &
+       &     ratqsbas,ratqshaut,tau_ratqs,fact_cldcon,                               &
+       &     ptconv,ptconvth,clwcon0th, rnebcon0th,                                  &
+       &     paprs,pplay,q_seri,zqsat,fm_therm,                                      &
+       &     ratqs,ratqsc)
+
+
+!c
+!c Appeler le processus de condensation a grande echelle
+!c et le processus de precipitation
+!c-------------------------------------------------------------------------
+      IF (prt_level .GE.10) THEN
+       print *,' ->fisrtilp '
+      ENDIF
+!c-------------------------------------------------------------------------
+      CALL fisrtilp(dtime,paprs,pplay,                                               &
+       &           t_seri, q_seri,ptconv,ratqs,                                      &
+       &           d_t_lsc, d_q_lsc, d_ql_lsc, rneb, cldliq,                         &
+       &           rain_lsc, snow_lsc,                                               &
+       &           pfrac_impa, pfrac_nucl, pfrac_1nucl,                              &
+       &           frac_impa, frac_nucl, beta_prec_fisrt,                            &
+       &           prfl, psfl, rhcl,                                                 &
+       &           zqasc, fraca,ztv,zpspsk,ztla,zthl,iflag_cldcon )
+
+      WHERE (rain_lsc < 0) rain_lsc = 0.
+      WHERE (snow_lsc < 0) snow_lsc = 0.
+!-----------------------------------------------------------------------------------------
+! ajout des tendances de la diffusion turbulente
+      CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,'lsc')
+!-----------------------------------------------------------------------------------------
+      DO k = 1, klev
+      DO i = 1, klon
+         cldfra(i,k) = rneb(i,k)
+         IF (.NOT.new_oliq) cldliq(i,k) = ql_seri(i,k)
+      ENDDO
+      ENDDO
+      IF (check) THEN
+         za = qcheck(klon,klev,paprs,q_seri,ql_seri,airephy)
+         WRITE(lunout,*)"apresilp=", za
+         zx_t = 0.0
+         za = 0.0
+         DO i = 1, klon
+            za = za + airephy(i)/REAL(klon)
+            zx_t = zx_t + (rain_lsc(i)                                               &
+       &                  + snow_lsc(i))*airephy(i)/REAL(klon)
+        ENDDO
+         zx_t = zx_t/za*dtime
+         WRITE(lunout,*)"Precip=", zx_t
+      ENDIF
+!IM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after fisrt'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime                             &
+       &      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay              &
+       &      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+        call diagphy(airephy,ztit,ip_ebil_phy                                        &
+       &      , zero_v, zero_v, zero_v, zero_v, zero_v                               &
+       &      , zero_v, rain_lsc, snow_lsc, ztsol                                    &
+       &      , d_h_vcol, d_qt, d_ec                                                 &
+       &      , fs_bound, fq_bound )
+      END IF 
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+        call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+!c
+!c-------------------------------------------------------------------
+!c  PRESCRIPTION DES NUAGES POUR LE RAYONNEMENT
+!c-------------------------------------------------------------------
+
+!c 1. NUAGES CONVECTIFS
+!c
+!IM cf FH
+!c     IF (iflag_cldcon.eq.-1) THEN ! seulement pour Tiedtke
+      IF (iflag_cldcon.le.-1) THEN ! seulement pour Tiedtke
+       snow_tiedtke=0.
+!c     print*,'avant calcul de la pseudo precip '
+!c     print*,'iflag_cldcon',iflag_cldcon
+       if (iflag_cldcon.eq.-1) then
+          rain_tiedtke=rain_con
+       else
+!c       print*,'calcul de la pseudo precip '
+          rain_tiedtke=0.
+!c         print*,'calcul de la pseudo precip 0'
+          do k=1,klev
+          do i=1,klon
+             if (d_q_con(i,k).lt.0.) then
+                rain_tiedtke(i)=rain_tiedtke(i)-d_q_con(i,k)/pdtphys                 &
+       &         *(paprs(i,k)-paprs(i,k+1))/rg
+             endif
+          enddo
+          enddo
+       endif
+!c
+!c     call dump2d(iim,jjm,rain_tiedtke(2:klon-1),'PSEUDO PRECIP ')
+!c
+
+!c Nuages diagnostiques pour Tiedtke
+      CALL diagcld1(paprs,pplay,                                                     &
+!IM cf FH  .             rain_con,snow_con,ibas_con,itop_con,                       &
+       &             rain_tiedtke,snow_tiedtke,ibas_con,itop_con,                    &
+       &             diafra,dialiq)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (diafra(i,k).GT.cldfra(i,k)) THEN
+         cldliq(i,k) = dialiq(i,k)
+         cldfra(i,k) = diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+
+      ELSE IF (iflag_cldcon.ge.3) THEN
+!c  On prend pour les nuages convectifs le max du calcul de la
+!c  convection et du calcul du pas de temps precedent diminue d'un facteur
+!c  facttemps
+      facteur = pdtphys *facttemps
+      do k=1,klev
+         do i=1,klon
+            rnebcon(i,k)=rnebcon(i,k)*facteur
+            if (rnebcon0(i,k)*clwcon0(i,k).gt.rnebcon(i,k)*clwcon(i,k))              &
+       &      then
+                rnebcon(i,k)=rnebcon0(i,k)
+                clwcon(i,k)=clwcon0(i,k)
+            endif
+         enddo
+      enddo
+
+!c
+!cjq - introduce the aerosol direct and first indirect radiative forcings
+!cjq - Johannes Quaas, 27/11/2003 (quaas@lmd.jussieu.fr)
+      IF (flag_aerosol .gt. 0) THEN
+         IF (.NOT. aerosol_couple)                                                   &
+       &        CALL readaerosol_optic(                                              &
+       &        debut, new_aod, flag_aerosol, itap, jD_cur-jD_ref,                   &
+       &        pdtphys, pplay, paprs, t_seri, rhcl, presnivs,                       &
+       &        mass_solu_aero, mass_solu_aero_pi,                                   &
+       &        tau_aero, piz_aero, cg_aero,                                         &
+       &        tausum_aero, tau3d_aero)
+      ELSE
+         tausum_aero(:,:,:) = 0.
+         tau_aero(:,:,:,:) = 0.
+         piz_aero(:,:,:,:) = 0.
+         cg_aero(:,:,:,:)  = 0.
+      ENDIF
+!c
+!c--STRAT AEROSOL
+!c--updates tausum_aero,tau_aero,piz_aero,cg_aero
+      IF (flag_aerosol_strat) THEN
+         PRINT *,'appel a readaerosolstrat', mth_cur
+         CALL readaerosolstrato(debut)
+      ENDIF
+!c--fin STRAT AEROSOL
+
+!IM calcul nuages par le simulateur ISCCP
+!c
+#ifdef histISCCP
+      IF (ok_isccp) THEN
+!c
+!IM lecture invtau, tautab des fichiers formattes
+!c
+      IF (debut) THEN
+!$OMP MASTER
+!c
+      open(99,file='tautab.formatted', FORM='FORMATTED')
+      read(99,'(f30.20)') tautab_omp
+      close(99)
+!c
+      open(99,file='invtau.formatted',form='FORMATTED')
+      read(99,'(i10)') invtau_omp
+
+!c     print*,'calcul_simulISCCP invtau_omp',invtau_omp
+!c     write(6,'(a,8i10)') 'invtau_omp',(invtau_omp(i),i=1,100)
+
+      close(99)
+!$OMP END MASTER
+!$OMP BARRIER 
+      tautab=tautab_omp
+      invtau=invtau_omp
+!c
+      ENDIF !debut
+!c
+!IM appel simulateur toutes les  NINT(freq_ISCCP/dtime) heures
+       IF (MOD(itap,NINT(freq_ISCCP/dtime)).EQ.0) THEN
+#include "calcul_simulISCCP.h"
+       ENDIF !(MOD(itap,NINT(freq_ISCCP/dtime))
+      ENDIF !ok_isccp
+#endif
+
+!c   On prend la somme des fractions nuageuses et des contenus en eau
+
+      if (iflag_cldcon>=5) then
+
+        do k=1,klev
+         ptconvth(:,k)=fm_therm(:,k+1)>0.
+        enddo
+
+       if (iflag_coupl==4) then
+
+! Dans le cas iflag_coupl==4, on prend la somme des convertures
+! convectives et lsc dans la partie des thermiques
+! Le controle par iflag_coupl est peut etre provisoire.
+         do k=1,klev
+            do i=1,klon
+               if (ptconv(i,k).and.ptconvth(i,k)) then
+                   cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k)
+                   cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.)
+               else if (ptconv(i,k)) then
+                   cldfra(i,k)=rnebcon(i,k)
+                   cldliq(i,k)=rnebcon(i,k)*clwcon(i,k)
+               endif
+            enddo
+         enddo
+
+         else if (iflag_coupl==5) then
+         do k=1,klev
+            do i=1,klon
+               cldfra(i,k)=min(cldfra(i,k)+rnebcon(i,k),1.)
+               cldliq(i,k)=cldliq(i,k)+rnebcon(i,k)*clwcon(i,k)
+            enddo
+         enddo
+
+         else
+
+! Si on est sur un point touche par la convection profonde et pas
+! par les thermiques, on prend la couverture nuageuse et l'eau nuageuse
+! de la convection profonde.
+
+!IM/FH: 2011/02/23 
+! definition des points sur lesquels ls thermiques sont actifs
+
+         do k=1,klev
+            do i=1,klon
+               if (ptconv(i,k).and. .not. ptconvth(i,k)) then
+                   cldfra(i,k)=rnebcon(i,k)
+                   cldliq(i,k)=rnebcon(i,k)*clwcon(i,k)
+               endif
+            enddo
+         enddo
+
+        endif
+
+      else
+
+! Ancienne version
+      cldfra(:,:)=min(max(cldfra(:,:),rnebcon(:,:)),1.)
+      cldliq(:,:)=cldliq(:,:)+rnebcon(:,:)*clwcon(:,:)
+      endif
+
+      ENDIF
+
+!     plulsc(:)=0.
+!     do k=1,klev,-1
+!        do i=1,klon
+!              zzz=prfl(:,k)+psfl(:,k)
+!           if (.not.ptconvth.zzz.gt.0.)
+!        enddo prfl, psfl,
+!     enddo
+!c
+!c 2. NUAGES STARTIFORMES
+!c
+      IF (ok_stratus) THEN
+      CALL diagcld2(paprs,pplay,t_seri,q_seri, diafra,dialiq)
+      DO k = 1, klev
+      DO i = 1, klon
+      IF (diafra(i,k).GT.cldfra(i,k)) THEN
+         cldliq(i,k) = dialiq(i,k)
+         cldfra(i,k) = diafra(i,k)
+      ENDIF
+      ENDDO
+      ENDDO
+      ENDIF
+!c
+!c Precipitation totale
+!c
+      DO i = 1, klon
+         rain_fall(i) = rain_con(i) + rain_lsc(i)
+         snow_fall(i) = snow_con(i) + snow_lsc(i)
+      ENDDO
+!IM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit="after diagcld"
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime                             &
+       &      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay              &
+       &      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+        call diagphy(airephy,ztit,ip_ebil_phy                                        &
+       &      , zero_v, zero_v, zero_v, zero_v, zero_v                               &
+       &      , zero_v, zero_v, zero_v, ztsol                                        &
+       &      , d_h_vcol, d_qt, d_ec                                                 &
+       &      , fs_bound, fq_bound )
+      END IF 
+!c
+!c Calculer l'humidite relative pour diagnostique
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         zx_t = t_seri(i,k)
+         IF (thermcep) THEN
+            zdelta = MAX(0.,SIGN(1.,rtt-zx_t))
+            zx_qs  = r2es * FOEEW(zx_t,zdelta)/pplay(i,k)
+            zx_qs  = MIN(0.5,zx_qs)
+            zcor   = 1./(1.-retv*zx_qs)
+            zx_qs  = zx_qs*zcor
+         ELSE
+           IF (zx_t.LT.t_coup) THEN
+              zx_qs = qsats(zx_t)/pplay(i,k)
+           ELSE
+              zx_qs = qsatl(zx_t)/pplay(i,k)
+           ENDIF
+         ENDIF
+         zx_rh(i,k) = q_seri(i,k)/zx_qs
+         zqsat(i,k)=zx_qs
+      ENDDO
+      ENDDO
+
+!IM Calcul temp.potentielle a 2m (tpot) et temp. potentielle 
+!c   equivalente a 2m (tpote) pour diagnostique
+!c
+      DO i = 1, klon
+       tpot(i)=zt2m(i)*(100000./paprs(i,1))**RKAPPA
+       IF (thermcep) THEN
+        IF(zt2m(i).LT.RTT) then
+         Lheat=RLSTT
+        ELSE
+         Lheat=RLVTT
+        ENDIF
+       ELSE
+        IF (zt2m(i).LT.RTT) THEN
+         Lheat=RLSTT
+        ELSE
+         Lheat=RLVTT
+        ENDIF
+       ENDIF
+       tpote(i) = tpot(i)*                                                           &
+       & EXP((Lheat *qsat2m(i))/(RCPD*zt2m(i)))
+      ENDDO
+
+      IF (type_trac == 'inca') THEN
+#ifdef INCA
+         CALL VTe(VTphysiq)
+         CALL VTb(VTinca)
+         calday = REAL(days_elapsed + 1) + jH_cur
+
+         call chemtime(itap+itau_phy-1, date0, dtime)
+         IF (config_inca == 'aero') THEN
+            CALL AEROSOL_METEO_CALC(                                                 &
+       &           calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs,                       &
+       &           prfl,psfl,pctsrf,airephy,rlat,rlon,u10m,v10m)
+         END IF
+
+         zxsnow_dummy(:) = 0.0
+
+         CALL chemhook_begin (calday,                                                &
+       &                          days_elapsed+1,                                    &
+       &                          jH_cur,                                            &
+       &                          pctsrf(1,1),                                       &
+       &                          rlat,                                              &
+       &                          rlon,                                              &
+       &                          airephy,                                           &
+       &                          paprs,                                             &
+       &                          pplay,                                             &
+       &                          coefh(:,:,is_ave),                                 &
+       &                          pphi,                                              &
+       &                          t_seri,                                            &
+       &                          u,                                                 &
+       &                          v,                                                 &
+       &                          wo(:, :, 1),                                       &
+       &                          q_seri,                                            &
+       &                          zxtsol,                                            &
+       &                          zxsnow_dummy,                                      &
+       &                          solsw,                                             &
+       &                          albsol1,                                           &
+       &                          rain_fall,                                         &
+       &                          snow_fall,                                         &
+       &                          itop_con,                                          &
+       &                          ibas_con,                                          &
+       &                          cldfra,                                            &
+       &                          iim,                                               &
+       &                          jjm,                                               &
+       &                          tr_seri,                                           &
+       &                          ftsol,                                             &
+       &                          paprs,                                             &
+       &                          cdragh,                                            &
+       &                          cdragm,                                            &
+       &                          pctsrf,                                            &
+       &                          pdtphys,                                           &
+       &                            itap)
+
+         CALL VTe(VTinca)
+         CALL VTb(VTphysiq)
+#endif 
+      END IF !type_trac = inca
+!c     
+!c Calculer les parametres optiques des nuages et quelques
+!c parametres pour diagnostiques:
+!c
+
+      IF (aerosol_couple) THEN 
+         mass_solu_aero(:,:)    = ccm(:,:,1) 
+         mass_solu_aero_pi(:,:) = ccm(:,:,2) 
+      END IF
+
+      if (ok_newmicro) then
+      CALL newmicro (ok_cdnc, bl95_b0, bl95_b1,                                      &
+       &              paprs, pplay, t_seri, cldliq, cldfra,                          &
+       &              cldtau, cldemi, cldh, cldl, cldm, cldt, cldq,                  &
+       &              flwp, fiwp, flwc, fiwc,                                        &
+       &              mass_solu_aero, mass_solu_aero_pi,                             &
+       &              cldtaupi, re, fl, ref_liq, ref_ice) 
+      else
+      CALL nuage (paprs, pplay,                                                      &
+       &            t_seri, cldliq, cldfra, cldtau, cldemi,                          &
+       &            cldh, cldl, cldm, cldt, cldq,                                    &
+       &            ok_aie,                                                          &
+       &            mass_solu_aero, mass_solu_aero_pi,                               &
+       &            bl95_b0, bl95_b1,                                                &
+       &            cldtaupi, re, fl)
+      endif
+!c
+!IM betaCRF
+!c
+      cldtaurad   = cldtau
+      cldtaupirad = cldtaupi
+      cldemirad   = cldemi                                                           &
+       &!c
+      if(lon1_beta.EQ.-180..AND.lon2_beta.EQ.180..AND.                               &
+       &lat1_beta.EQ.90..AND.lat2_beta.EQ.-90.) THEN
+!c
+!c global
+!c
+       DO k=1, klev
+       DO i=1, klon
+        if (pplay(i,k).GE.pfree) THEN
+         beta(i,k) = beta_pbl
+        else
+         beta(i,k) = beta_free
+        endif
+        if (mskocean_beta) THEN
+         beta(i,k) = beta(i,k) * pctsrf(i,is_oce)
+        endif
+        cldtaurad(i,k)   = cldtau(i,k) * beta(i,k)
+        cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k)
+        cldemirad(i,k)   = cldemi(i,k) * beta(i,k)
+        cldfrarad(i,k)   = cldfra(i,k) * beta(i,k)
+       ENDDO
+       ENDDO 
+!c
+      else
+!c
+!c regional
+!c
+       DO k=1, klev
+       DO i=1,klon
+!c
+        if (rlon(i).ge.lon1_beta.AND.rlon(i).le.lon2_beta.AND.                       &
+       &      rlat(i).le.lat1_beta.AND.rlat(i).ge.lat2_beta) THEN
+         if (pplay(i,k).GE.pfree) THEN
+          beta(i,k) = beta_pbl
+         else
+          beta(i,k) = beta_free
+         endif
+         if (mskocean_beta) THEN
+          beta(i,k) = beta(i,k) * pctsrf(i,is_oce)
+         endif
+        cldtaurad(i,k)   = cldtau(i,k) * beta(i,k)
+        cldtaupirad(i,k) = cldtaupi(i,k) * beta(i,k)
+        cldemirad(i,k)   = cldemi(i,k) * beta(i,k)
+        cldfrarad(i,k)   = cldfra(i,k) * beta(i,k)
+        endif
+!c
+       ENDDO
+       ENDDO
+!c
+      endif
+!c
+!c Appeler le rayonnement mais calculer tout d'abord l'albedo du sol.
+!c
+      IF (MOD(itaprad,radpas).EQ.0) THEN
+
+      DO i = 1, klon
+         albsol1(i) = falb1(i,is_oce) * pctsrf(i,is_oce)                             &
+       &             + falb1(i,is_lic) * pctsrf(i,is_lic)                            &
+       &             + falb1(i,is_ter) * pctsrf(i,is_ter)                            &
+       &             + falb1(i,is_sic) * pctsrf(i,is_sic)
+         albsol2(i) = falb2(i,is_oce) * pctsrf(i,is_oce)                             &
+       &               + falb2(i,is_lic) * pctsrf(i,is_lic)                          &
+       &               + falb2(i,is_ter) * pctsrf(i,is_ter)                          &
+       &               + falb2(i,is_sic) * pctsrf(i,is_sic)
+      ENDDO
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+        call writefield_phy('q_seri',q_seri,llm)
+      endif
+      
+      IF (aerosol_couple) THEN 
+#ifdef INCA
+         CALL radlwsw_inca                                                           &
+       &        (kdlon,kflev,dist, rmu0, fract, solaire,                             &
+       &        paprs, pplay,zxtsol,albsol1, albsol2, t_seri,q_seri,                 &
+       &        wo(:, :, 1),                                                         &
+       &        cldfrarad, cldemirad, cldtaurad,                                     &
+       &        heat,heat0,cool,cool0,radsol,albpla,                                 &
+       &        topsw,toplw,solsw,sollw,                                             &
+       &        sollwdown,                                                           &
+       &        topsw0,toplw0,solsw0,sollw0,                                         &
+       &        lwdn0, lwdn, lwup0, lwup,                                            &
+       &        swdn0, swdn, swup0, swup,                                            &
+       &        ok_ade, ok_aie,                                                      &
+       &        tau_aero, piz_aero, cg_aero,                                         &
+       &        topswad_aero, solswad_aero,                                          &
+       &        topswad0_aero, solswad0_aero,                                        &
+       &        topsw_aero, topsw0_aero,                                             &
+       &        solsw_aero, solsw0_aero,                                             &
+       &        cldtaupirad,                                                         &
+       &        topswai_aero, solswai_aero)
+            
+#endif
+      ELSE
+!c
+!IM calcul radiatif pour le cas actuel
+!c
+       RCO2 = RCO2_act
+       RCH4 = RCH4_act
+       RN2O = RN2O_act
+       RCFC11 = RCFC11_act
+       RCFC12 = RCFC12_act
+!c
+      IF (prt_level .GE.10) THEN
+       print *,' ->radlwsw, number 1 '
+      ENDIF
+!c
+      PRINT *,'  Lluis before calling radlwsw rmu0: ',rmu0(llp),   &
+        ' dist: ',dist,' frac: ',fract(llp),' jH_cur: ',jH_cur
+         CALL radlwsw                                                                &
+       &        (dist, rmu0, fract,                                                  &
+       &        paprs, pplay,zxtsol,albsol1, albsol2,                                &
+       &        t_seri,q_seri,wo,                                                    &
+       &        cldfrarad, cldemirad, cldtaurad,                                     &
+       &        ok_ade.OR.flag_aerosol_strat, ok_aie, flag_aerosol,                  &
+       &        flag_aerosol_strat,                                                  &
+       &        tau_aero, piz_aero, cg_aero,                                         &
+       &        cldtaupirad,new_aod,                                                 &
+       &        zqsat, flwc, fiwc,                                                   &
+       &        heat,heat0,cool,cool0,radsol,albpla,                                 &
+       &        topsw,toplw,solsw,sollw,                                             &
+       &        sollwdown,                                                           &
+       &        topsw0,toplw0,solsw0,sollw0,                                         &
+       &        lwdn0, lwdn, lwup0, lwup,                                            &
+       &        swdn0, swdn, swup0, swup,                                            &
+       &        topswad_aero, solswad_aero,                                          &
+       &        topswai_aero, solswai_aero,                                          &
+       &        topswad0_aero, solswad0_aero,                                        &
+       &        topsw_aero, topsw0_aero,                                             &
+       &        solsw_aero, solsw0_aero,                                             &
+       &        topswcf_aero, solswcf_aero)
+      PRINT *,'  Lluis after calling radlwsw rmu0: ',rmu0(llp),   &
+        ' dist: ',dist,' frac: ',fract(llp),' jH_cur: ',jH_cur
+         
+!c
+!IM 2eme calcul radiatif pour le cas perturbe ou au moins un
+!IM des taux doit etre different du taux actuel
+!IM Par defaut on a les taux perturbes egaux aux taux actuels
+!c
+
+      if (ok_4xCO2atm) then
+       if (RCO2_per.NE.RCO2_act.OR.RCH4_per.NE.RCH4_act.OR.                          &
+       &RN2O_per.NE.RN2O_act.OR.RCFC11_per.NE.RCFC11_act.OR.                         &
+       &RCFC12_per.NE.RCFC12_act) THEN
+!c
+       RCO2 = RCO2_per
+       RCH4 = RCH4_per
+       RN2O = RN2O_per
+       RCFC11 = RCFC11_per
+       RCFC12 = RCFC12_per
+!c
+      IF (prt_level .GE.10) THEN
+       print *,' ->radlwsw, number 2 '
+      ENDIF
+!c
+         CALL radlwsw                                                                &
+       &        (dist, rmu0, fract,                                                  &
+       &        paprs, pplay,zxtsol,albsol1, albsol2,                                &
+       &        t_seri,q_seri,wo,                                                    &
+       &        cldfra, cldemi, cldtau,                                              &
+       &        ok_ade.OR.flag_aerosol_strat, ok_aie, flag_aerosol,                  &
+       &        flag_aerosol_strat,                                                  &
+       &        tau_aero, piz_aero, cg_aero,                                         &
+       &        cldtaupi,new_aod,                                                    &
+       &        zqsat, flwc, fiwc,                                                   &
+       &        heatp,heat0p,coolp,cool0p,radsolp,albplap,                           &
+       &        topswp,toplwp,solswp,sollwp,                                         &
+       &        sollwdownp,                                                          &
+       &        topsw0p,toplw0p,solsw0p,sollw0p,                                     &
+       &        lwdn0p, lwdnp, lwup0p, lwupp,                                        &
+       &        swdn0p, swdnp, swup0p, swupp,                                        &
+       &        topswad_aerop, solswad_aerop,                                        &
+       &        topswai_aerop, solswai_aerop,                                        &
+       &        topswad0_aerop, solswad0_aerop,                                      &
+       &        topsw_aerop, topsw0_aerop,                                           &
+       &        solsw_aerop, solsw0_aerop,                                           &
+       &        topswcf_aerop, solswcf_aerop)
+       endif
+      endif
+!c
+      ENDIF ! aerosol_couple
+      itaprad = 0
+      ENDIF ! MOD(itaprad,radpas)
+      itaprad = itaprad + 1
+
+      IF (iflag_radia.eq.0) THEN
+         IF (prt_level.ge.9) THEN
+            PRINT *,'--------------------------------------------------'
+            PRINT *,'>>>> ATTENTION rayonnement desactive pour ce cas'
+            PRINT *,'>>>>           heat et cool mis a zero '
+            PRINT *,'--------------------------------------------------'
+         END IF
+         heat=0.
+         cool=0.
+         sollw=0.   ! MPL 01032011
+         solsw=0.
+         radsol=0.
+         swup=0.    ! MPL 27102011 pour les fichiers AMMA_profiles et AMMA_scalars
+         swup0=0.
+         swdn=0.
+         swdn0=0.
+         lwup=0.
+         lwup0=0.
+         lwdn=0.
+         lwdn0=0.
+      END IF
+
+!c
+!c Ajouter la tendance des rayonnements (tous les pas)
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         t_seri(i,k) = t_seri(i,k)                                                   &
+       &               + (heat(i,k)-cool(i,k)) * dtime/RDAY
+      ENDDO
+      ENDDO
+!c
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+        call writefield_phy('q_seri',q_seri,llm)
+      endif
+ 
+!IM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after rad'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime                             &
+       &      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay              &
+       &      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+        call diagphy(airephy,ztit,ip_ebil_phy                                        &
+       &      , topsw, toplw, solsw, sollw, zero_v                                   &
+       &      , zero_v, zero_v, zero_v, ztsol                                        &
+       &      , d_h_vcol, d_qt, d_ec                                                 &
+       &      , fs_bound, fq_bound )
+      END IF 
+!c
+!c
+!c Calculer l'hydrologie de la surface
+!c
+!c      CALL hydrol(dtime,pctsrf,rain_fall, snow_fall, zxevap,
+!c     .            agesno, ftsol,fqsurf,fsnow, ruis)
+!c
+
+!c
+!c Calculer le bilan du sol et la derive de temperature (couplage)
+!c
+      DO i = 1, klon
+!c         bils(i) = radsol(i) - sens(i) - evap(i)*RLVTT
+!c a la demande de JLD
+         bils(i) = radsol(i) - sens(i) + zxfluxlat(i)
+      ENDDO
+!c
+!cmoddeblott(jan95)
+!c Appeler le programme de parametrisation de l'orographie
+!c a l'echelle sous-maille:
+!c
+      IF (prt_level .GE.10) THEN
+       print *,' call orography ? ', ok_orodr
+      ENDIF
+!c
+      IF (ok_orodr) THEN
+!c
+!c  selection des points pour lesquels le shema est actif:
+        igwd=0
+        DO i=1,klon
+        itest(i)=0
+!c        IF ((zstd(i).gt.10.0)) THEN
+        IF (((zpic(i)-zmea(i)).GT.100.).AND.(zstd(i).GT.10.0)) THEN
+          itest(i)=1
+          igwd=igwd+1
+          idx(igwd)=i
+        ENDIF
+        ENDDO
+!c        igwdim=MAX(1,igwd)
+!c
+        IF (ok_strato) THEN
+        
+          CALL drag_noro_strato(klon,klev,dtime,paprs,pplay,                         &
+       &                   zmea,zstd, zsig, zgam, zthe,zpic,zval,                    &
+       &                   igwd,idx,itest,                                           &
+       &                   t_seri, u_seri, v_seri,                                   &
+       &                   zulow, zvlow, zustrdr, zvstrdr,                           &
+       &                   d_t_oro, d_u_oro, d_v_oro)
+
+       ELSE
+        CALL drag_noro(klon,klev,dtime,paprs,pplay,                                  &
+       &                   zmea,zstd, zsig, zgam, zthe,zpic,zval,                    &
+       &                   igwd,idx,itest,                                           &
+       &                   t_seri, u_seri, v_seri,                                   &
+       &                   zulow, zvlow, zustrdr, zvstrdr,                           &
+       &                   d_t_oro, d_u_oro, d_v_oro)
+       ENDIF
+!c
+!c  ajout des tendances
+!-----------------------------------------------------------------------------------------
+! ajout des tendances de la trainee de l'orographie
+      CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,'oro')
+!-----------------------------------------------------------------------------------------
+!c
+      ENDIF ! fin de test sur ok_orodr
+!c
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+        call writefield_phy('q_seri',q_seri,llm)
+      endif
+      
+      IF (ok_orolf) THEN
+!c
+!c  selection des points pour lesquels le shema est actif:
+        igwd=0
+        DO i=1,klon
+        itest(i)=0
+        IF ((zpic(i)-zmea(i)).GT.100.) THEN
+          itest(i)=1
+          igwd=igwd+1
+          idx(igwd)=i
+        ENDIF
+        ENDDO
+!c        igwdim=MAX(1,igwd)
+!c
+        IF (ok_strato) THEN
+
+          CALL lift_noro_strato(klon,klev,dtime,paprs,pplay,                         &
+       &                   rlat,zmea,zstd,zpic,zgam,zthe,zpic,zval,                  &
+       &                   igwd,idx,itest,                                           &
+       &                   t_seri, u_seri, v_seri,                                   &
+       &                   zulow, zvlow, zustrli, zvstrli,                           &
+       &                   d_t_lif, d_u_lif, d_v_lif               )
+        
+        ELSE
+          CALL lift_noro(klon,klev,dtime,paprs,pplay,                                &
+       &                   rlat,zmea,zstd,zpic,                                      &
+       &                   itest,                                                    &
+       &                   t_seri, u_seri, v_seri,                                   &
+       &                   zulow, zvlow, zustrli, zvstrli,                           &
+       &                   d_t_lif, d_u_lif, d_v_lif)
+       ENDIF
+!c   
+!-----------------------------------------------------------------------------------------
+! ajout des tendances de la portance de l'orographie
+      CALL add_phys_tend(d_u_lif,d_v_lif,d_t_lif,dq0,dql0,'lif')
+!-----------------------------------------------------------------------------------------
+!c
+      ENDIF ! fin de test sur ok_orolf
+!C  HINES GWD PARAMETRIZATION
+
+       IF (ok_hines) then
+
+         CALL hines_gwd(klon,klev,dtime,paprs,pplay,                                 &
+       &                  rlat,t_seri,u_seri,v_seri,                                 &
+       &                  zustrhi,zvstrhi,                                           &
+       &                  d_t_hin, d_u_hin, d_v_hin)
+!c
+!c  ajout des tendances
+        CALL add_phys_tend(d_u_hin,d_v_hin,d_t_hin,dq0,dql0,'hin')
+
+      ENDIF
+!c
+
+!c
+!IM cf. FLott BEG
+!C STRESS NECESSAIRES: TOUTE LA PHYSIQUE
+
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+	call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+      DO i = 1, klon
+        zustrph(i)=0.
+        zvstrph(i)=0.
+      ENDDO
+      DO k = 1, klev
+      DO i = 1, klon
+       zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/dtime*                             &
+       &            (paprs(i,k)-paprs(i,k+1))/rg
+       zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/dtime*                             &
+       &            (paprs(i,k)-paprs(i,k+1))/rg
+      ENDDO
+      ENDDO
+!c
+!IM calcul composantes axiales du moment angulaire et couple des montagnes
+!c
+!      IF (is_sequential .and. ok_orodr) THEN 
+!        CALL aaam_bud (27,klon,klev,jD_cur-jD_ref,jH_cur,                            &
+!       &                 ra,rg,romega,                                               &
+!       &                 rlat,rlon,pphis,                                            &
+!       &                 zustrdr,zustrli,zustrph,                                    &
+!       &                 zvstrdr,zvstrli,zvstrph,                                    &
+!       &                 paprs,u,v,                                                  &
+!       &                 aam, torsfc)
+!       ENDIF
+!IM cf. FLott END
+!IM
+      IF (ip_ebil_phy.ge.2) THEN 
+        ztit='after orography'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,2,2,dtime                             &
+       &      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay              &
+       &      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+         call diagphy(airephy,ztit,ip_ebil_phy                                       &
+       &      , zero_v, zero_v, zero_v, zero_v, zero_v                               &
+       &      , zero_v, zero_v, zero_v, ztsol                                        &
+       &      , d_h_vcol, d_qt, d_ec                                                 &
+       &      , fs_bound, fq_bound )
+      END IF 
+!c
+!c
+!====================================================================
+! Interface Simulateur COSP (Calipso, ISCCP, MISR, ..)
+!====================================================================
+! Abderrahmane 24.08.09
+
+      IF (ok_cosp) THEN
+! adeclarer 
+#ifdef CPP_COSP
+       IF (MOD(itap,NINT(freq_cosp/dtime)).EQ.0) THEN
+
+       print*,'freq_cosp',freq_cosp
+          mr_ozone=wo(:, :, 1) * dobson_u * 1e3 / zmasse
+!       print*,'Dans physiq.F avant appel cosp ref_liq,ref_ice=',
+!     s        ref_liq,ref_ice
+          call phys_cosp(itap,dtime,freq_cosp,                                       &
+       &                   ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP,                   &
+       &                   ecrit_mth,ecrit_day,ecrit_hf,                             &
+       &                   klon,klev,rlon,rlat,presnivs,overlap,                     &
+       &                   ref_liq,ref_ice,                                          &
+       &                   pctsrf(:,is_ter)+pctsrf(:,is_lic),                        &
+       &                   zu10m,zv10m,pphis,                                        &
+       &                   zphi,paprs(:,1:klev),pplay,zxtsol,t_seri,                 &
+       &                   qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc,              &
+       &                   prfl(:,1:klev),psfl(:,1:klev),                            &
+       &                   pmflxr(:,1:klev),pmflxs(:,1:klev),                        &
+       &                   mr_ozone,cldtau, cldemi)
+
+!     L          calipso2D,calipso3D,cfadlidar,parasolrefl,atb,betamol,
+!     L          cfaddbze,clcalipso2,dbze,cltlidarradar,
+!     M          clMISR,
+!     R          clisccp2,boxtauisccp,boxptopisccp,tclisccp,ctpisccp,
+!     I          tauisccp,albisccp,meantbisccp,meantbclrisccp)
+
+         ENDIF
+
+#endif
+       ENDIF  !ok_cosp
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!cAA
+!cAA Installation de l'interface online-offline pour traceurs
+!cAA
+!c====================================================================
+!c   Calcul  des tendances traceurs
+!c====================================================================
+!C
+
+       IF (type_trac=='repr') THEN
+          sh_in(:,:) = q_seri(:,:)
+       ELSE
+          sh_in(:,:) = qx(:,:,ivap)
+       END IF
+
+      call phytrac (                                                                 &
+       &     itap,     days_elapsed+1,    jH_cur,   debut,                           &
+       &     lafin,    dtime,     u, v,     t,                                       &
+       &     paprs,    pplay,     pmfu,     pmfd,                                    &
+       &     pen_u,    pde_u,     pen_d,    pde_d,                                   &
+       &     cdragh,   coefh(:,:,is_ave),     fm_therm, entr_therm,                  &
+       &     u1,       v1,        ftsol,    pctsrf,                                  &
+       &     ustar,     u10m,      v10m,                                             &
+       &     rlat,     rlon,                                                         &
+       &     frac_impa,frac_nucl, beta_prec_fisrt,beta_prec,                         &
+       &     presnivs, pphis,     pphi,     albsol1,                                 &
+       &     sh_in,    rhcl,      cldfra,   rneb,                                    &
+       &     diafra,   cldliq,    itop_con, ibas_con,                                &
+       &     pmflxr,   pmflxs,    prfl,     psfl,                                    &
+       &     da,       phi,       mp,       upwd,                                    &
+       &     phi2,     d1a,       dam,      sij,                                     &
+       &     wdtrainA, wdtrainM,  sigd,     clw,elij,                                &
+       &     ev,       ep,        epmlmMm,  eplaMm,                                  &
+       &     dnwd,     aerosol_couple,      flxmass_w,                               &
+       &     tau_aero, piz_aero,  cg_aero,  ccm,                                     &
+       &     rfname,                                                                 &
+       &     d_tr_dyn,                                                               &
+       &     tr_seri)
+
+      IF (offline) THEN
+
+       IF (prt_level.ge.9)                                                           &
+       &    print*,'Attention on met a 0 les thermiques pour phystoke'
+	 call phystokenc (                                                                  &
+       &                   nlon,klev,pdtphys,rlon,rlat,                              &
+       &                   t,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d,                 &
+       &                   fm_therm,entr_therm,                                      &
+       &                   cdragh,coefh(:,:,is_ave),u1,v1,ftsol,pctsrf,              &
+       &                   frac_impa, frac_nucl,                                     &
+       &                   pphis,airephy,dtime,itap,                                 &
+       &                   qx(:,:,ivap),da,phi,mp,upwd,dnwd)
+
+
+      ENDIF
+
+!c
+!c Calculer le transport de l'eau et de l'energie (diagnostique)
+!c
+      CALL transp (paprs,zxtsol,                                                     &
+       &                   t_seri, q_seri, u_seri, v_seri, zphi,                     &
+       &                   ve, vq, ue, uq)
+!c
+!IM global posePB BEG
+      IF(1.EQ.0) THEN
+!c
+      CALL transp_lay (paprs,zxtsol,                                                 &
+       &                   t_seri, q_seri, u_seri, v_seri, zphi,                     &
+       &                   ve_lay, vq_lay, ue_lay, uq_lay)
+!c
+      ENDIF !(1.EQ.0) THEN
+!IM global posePB END
+!c Accumuler les variables a stocker dans les fichiers histoire:
+!c
+
+!================================================================
+! Conversion of kinetic and potential energy into heat, for
+! parameterisation of subgrid-scale motions
+!================================================================
+
+      d_t_ec(:,:)=0.
+      forall (k=1: llm) exner(:, k) = (pplay(:, k)/paprs(:,1))**RKAPPA
+      CALL ener_conserv(klon,klev,pdtphys,u,v,t,qx(:,:,ivap),                        &
+       &        u_seri,v_seri,t_seri,q_seri,pbl_tke(:,:,is_ave)-tke0(:,:),           &
+       &        zmasse,exner,d_t_ec)
+      t_seri(:,:)=t_seri(:,:)+d_t_ec(:,:)
+
+!IM
+      IF (ip_ebil_phy.ge.1) THEN 
+        ztit='after physic'
+        CALL diagetpq(airephy,ztit,ip_ebil_phy,1,1,dtime                             &
+       &      , t_seri,q_seri,ql_seri,qs_seri,u_seri,v_seri,paprs,pplay              &
+       &      , d_h_vcol, d_qt, d_qw, d_ql, d_qs, d_ec)
+!C     Comme les tendances de la physique sont ajoute dans la dynamique,
+!C     on devrait avoir que la variation d'entalpie par la dynamique
+!C     est egale a la variation de la physique au pas de temps precedent.
+!C     Donc la somme de ces 2 variations devrait etre nulle.
+
+        call diagphy(airephy,ztit,ip_ebil_phy                                        &
+       &      , topsw, toplw, solsw, sollw, sens                                     &
+       &      , evap, rain_fall, snow_fall, ztsol                                    &
+       &      , d_h_vcol, d_qt, d_ec                                                 &
+       &      , fs_bound, fq_bound )
+!C
+      d_h_vcol_phy=d_h_vcol
+!C
+      END IF 
+      PRINT *,'Lluis Reaching the SORTIES point'
+
+!C
+!c=======================================================================
+!c   SORTIES
+!c=======================================================================
+
+!IM Interpolation sur les niveaux de pression du NMC
+!c   -------------------------------------------------
+!c
+#include "calcul_STDlev.h"
+!c
+!c slp sea level pressure
+      slp(:) = paprs(:,1)*exp(pphis(:)/(RD*t_seri(:,1)))
+!c
+!ccc prw = eau precipitable
+      DO i = 1, klon
+       prw(i) = 0.
+       DO k = 1, klev
+        prw(i) = prw(i) +                                                            &
+       &           q_seri(i,k)*(paprs(i,k)-paprs(i,k+1))/RG
+       ENDDO
+      ENDDO
+!c
+!IM initialisation + calculs divers diag AMIP2
+!c
+#include "calcul_divers.h"
+!c
+      IF (type_trac == 'inca') THEN
+#ifdef INCA
+         CALL VTe(VTphysiq)
+         CALL VTb(VTinca)
+
+         CALL chemhook_end (                                                         &
+       &                        dtime,                                               &
+       &                        pplay,                                               &
+       &                        t_seri,                                              &
+       &                        tr_seri,                                             &
+       &                        nbtr,                                                &
+       &                        paprs,                                               &
+       &                        q_seri,                                              &
+       &                        airephy,                                             &
+       &                        pphi,                                                &
+       &                        pphis,                                               &
+       &                        zx_rh)
+
+         CALL VTe(VTinca)
+         CALL VTb(VTphysiq)
+#endif
+      END IF
+
+
+!c
+!c Convertir les incrementations en tendances
+!c
+      IF (prt_level .GE.10) THEN
+        print *,'Convertir les incrementations en tendances '
+      ENDIF
+!c
+      if (mydebug) then
+        call writefield_phy('u_seri',u_seri,llm)
+        call writefield_phy('v_seri',v_seri,llm)
+        call writefield_phy('t_seri',t_seri,llm)
+        call writefield_phy('q_seri',q_seri,llm)
+      endif
+
+      DO k = 1, klev
+      DO i = 1, klon
+         d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime
+         d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime
+         d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime
+         d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime
+         d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime
+      ENDDO
+      ENDDO
+!c
+      IF (nqtot.GE.3) THEN
+      DO iq = 3, nqtot
+      DO  k = 1, klev
+      DO  i = 1, klon
+         d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime
+      ENDDO
+      ENDDO
+      ENDDO
+      ENDIF
+!c
+!IM rajout diagnostiques bilan KP pour analyse MJO par Jun-Ichi Yano
+!IM global posePB#include "write_bilKP_ins.h"
+!IM global posePB#include "write_bilKP_ave.h"
+!c
+
+!c Sauvegarder les valeurs de t et q a la fin de la physique:
+!c
+      DO k = 1, klev
+      DO i = 1, klon
+         u_ancien(i,k) = u_seri(i,k)
+         v_ancien(i,k) = v_seri(i,k)
+         t_ancien(i,k) = t_seri(i,k)
+         q_ancien(i,k) = q_seri(i,k)
+      ENDDO
+      ENDDO
+
+!!! RomP >>>
+      IF (nqtot.GE.3) THEN
+        DO iq = 3, nqtot
+        DO k = 1, klev
+        DO i = 1, klon
+           tr_ancien(i,k,iq-2) = tr_seri(i,k,iq-2)
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDIF
+!!! RomP <<<
+!==========================================================================
+! Sorties des tendances pour un point particulier
+! a utiliser en 1D, avec igout=1 ou en 3D sur un point particulier
+! pour le debug
+! La valeur de igout est attribuee plus haut dans le programme
+!==========================================================================
+
+      if (prt_level.ge.1) then
+      write(lunout,*) 'FIN DE PHYSIQ !!!!!!!!!!!!!!!!!!!!'
+      write(lunout,*)                                                                &
+       & 'nlon,klev,nqtot,debut,lafin,jD_cur, jH_cur, pdtphys pct tlos'
+      write(lunout,*)                                                                &
+       &  nlon,klev,nqtot,debut,lafin, jD_cur, jH_cur ,pdtphys,                      &
+       &  pctsrf(igout,is_ter), pctsrf(igout,is_lic),pctsrf(igout,is_oce),           &
+       &  pctsrf(igout,is_sic)
+      write(lunout,*) 'd_t_dyn,d_t_con,d_t_lsc,d_t_ajsb,d_t_ajs,d_t_eva'
+      do k=1,klev
+         write(lunout,*) d_t_dyn(igout,k),d_t_con(igout,k),                          &
+       &   d_t_lsc(igout,k),d_t_ajsb(igout,k),d_t_ajs(igout,k),                      &
+       &   d_t_eva(igout,k)
+      enddo
+      write(lunout,*) 'cool,heat'
+      do k=1,klev
+         write(lunout,*) cool(igout,k),heat(igout,k)
+      enddo
+
+      write(lunout,*) 'd_t_oli,d_t_vdf,d_t_oro,d_t_lif,d_t_ec'
+      do k=1,klev
+         write(lunout,*) d_t_oli(igout,k),d_t_vdf(igout,k),                          &
+       & d_t_oro(igout,k),d_t_lif(igout,k),d_t_ec(igout,k)
+      enddo
+
+      write(lunout,*) 'd_ps ',d_ps(igout)
+      write(lunout,*) 'd_u, d_v, d_t, d_qx1, d_qx2 '
+      do k=1,klev,klon
+         write(lunout,*) d_u(igout,k),d_v(igout,k),d_t(igout,k),                     &
+       &  d_qx(igout,k,1),d_qx(igout,k,2)
+      enddo
+      endif
+
+!==========================================================================
+
+!c============================================================
+!c   Calcul de la temperature potentielle
+!c============================================================
+      DO k = 1, klev
+      DO i = 1, klon
+!cJYG/IM theta en debut du pas de temps
+!cJYG/IM       theta(i,k)=t(i,k)*(100000./pplay(i,k))**(RD/RCPD)
+!cJYG/IM theta en fin de pas de temps de physique
+        theta(i,k)=t_seri(i,k)*(100000./pplay(i,k))**(RD/RCPD)
+!c thetal: 2 lignes suivantes a decommenter si vous avez les fichiers     MPL 20130625
+!c fth_fonctions.F90 et parkind1.F90
+!c sinon thetal=theta
+!c       thetal(i,k)=fth_thetal(pplay(i,k),t_seri(i,k),q_seri(i,k),
+!c    :         ql_seri(i,k))
+        thetal(i,k)=theta(i,k)
+      ENDDO
+      ENDDO
+!c
+
+!c 22.03.04 BEG
+!c=============================================================
+!c   Ecriture des sorties
+!c=============================================================
+#ifdef CPP_IOIPSL
+ 
+!c Recupere des varibles calcule dans differents modules
+!c pour ecriture dans histxxx.nc 
+
+      ! Get some variables from module fonte_neige_mod
+!L. Fita, LMD. November 2013
+!! It is not working after removing starphy.nc and limit.nc?
+      CALL fonte_neige_get_vars(pctsrf,                                              &
+       &     zxfqcalving, zxfqfonte, zxffonte)
+
+
+
+!c=============================================================
+! Separation entre thermiques et non thermiques dans les sorties
+! de fisrtilp
+!c=============================================================
+
+      if (iflag_thermals>=1) then
+      d_t_lscth=0.
+      d_t_lscst=0.
+      d_q_lscth=0.
+      d_q_lscst=0.
+      do k=1,klev
+         do i=1,klon
+            if (ptconvth(i,k)) then
+                d_t_lscth(i,k)=d_t_eva(i,k)+d_t_lsc(i,k)
+                d_q_lscth(i,k)=d_q_eva(i,k)+d_q_lsc(i,k)
+            else
+                d_t_lscst(i,k)=d_t_eva(i,k)+d_t_lsc(i,k)
+                d_q_lscst(i,k)=d_q_eva(i,k)+d_q_lsc(i,k)
+            endif
+         enddo
+      enddo
+
+      do i=1,klon
+      plul_st(i)=prfl(i,lmax_th(i)+1)+psfl(i,lmax_th(i)+1)
+      plul_th(i)=prfl(i,1)+psfl(i,1)
+      enddo
+      endif
+
+      PRINT *,'  Lluis WRITING outputs! itap: ',itap,' itau_phy: ',itau_phy,         &
+        ' itau_w: ',itau_w
+      PRINT *,'  Lluis writting outputs qsol: ',qsol(llp),    &
+        ' ftsol: ',ftsol(llp,:)
+
+#include "phys_output_write_new.h"
+
+
+#ifdef histISCCP
+#include "write_histISCCP.h"
+#endif
+
+      PRINT *,'  Lluis WRITING histfiles!'
+
+#ifdef histNMC
+#include "write_histhfNMC.h"
+#include "write_histdayNMC.h"
+#include "write_histmthNMC.h"
+#endif
+
+#include "write_histday_seri.h"
+
+#include "write_paramLMDZ_phy.h"
+
+#endif
+
+!c 22.03.04 END
+!c
+!c====================================================================
+!c Si c'est la fin, il faut conserver l'etat de redemarrage
+!c====================================================================
+!c
+
+!c        -----------------------------------------------------------------
+!c        WSTATS: Saving statistics
+!c        -----------------------------------------------------------------
+!c        ("stats" stores and accumulates 8 key variables in file "stats.nc"
+!c        which can later be used to make the statistic files of the run:
+!c        "stats")          only possible in 3D runs !
+
+         
+         IF (callstats) THEN
+
+           call wstats(klon,o_psol%name,"Surface pressure","Pa"                      &
+       &                 ,2,paprs(:,1))
+           call wstats(klon,o_tsol%name,"Surface temperature","K",                   &
+       &                 2,zxtsol)
+           zx_tmp_fi2d(:) = rain_fall(:) + snow_fall(:)
+           call wstats(klon,o_precip%name,"Precip Totale liq+sol",                   &
+       &                 "kg/(s*m2)",2,zx_tmp_fi2d)
+           zx_tmp_fi2d(:) = rain_lsc(:) + snow_lsc(:)
+           call wstats(klon,o_plul%name,"Large-scale Precip",                        &
+       &                 "kg/(s*m2)",2,zx_tmp_fi2d)
+           zx_tmp_fi2d(:) = rain_con(:) + snow_con(:)
+           call wstats(klon,o_pluc%name,"Convective Precip",                         &
+       &                 "kg/(s*m2)",2,zx_tmp_fi2d)
+           call wstats(klon,o_sols%name,"Solar rad. at surf.",                       &
+       &                 "W/m2",2,solsw)
+           call wstats(klon,o_soll%name,"IR rad. at surf.",                          &
+       &                 "W/m2",2,sollw)
+          zx_tmp_fi2d(:) = topsw(:)-toplw(:)
+          call wstats(klon,o_nettop%name,"Net dn radiatif flux at TOA",              &
+       &                 "W/m2",2,zx_tmp_fi2d)
+
+
+
+           call wstats(klon,o_temp%name,"Air temperature","K",                       &
+       &                 3,t_seri)
+           call wstats(klon,o_vitu%name,"Zonal wind","m.s-1",                        &
+       &                 3,u_seri)
+           call wstats(klon,o_vitv%name,"Meridional wind",                           &
+       &                "m.s-1",3,v_seri)
+           call wstats(klon,o_vitw%name,"Vertical wind",                             &
+       &                "m.s-1",3,omega)
+           call wstats(klon,o_ovap%name,"Specific humidity", "kg/kg",                &
+       &                 3,q_seri)
+ 
+
+
+           IF(lafin) THEN
+             write (*,*) "Writing stats..."
+             call mkstats(ierr)
+           ENDIF
+
+         ENDIF !if callstats
+
+      IF (lafin) THEN
+         itau_phy = itau_phy + itap
+         CALL phyredem ("restartphy.nc")
+!         open(97,form="unformatted",file="finbin")
+!         write(97) u_seri,v_seri,t_seri,q_seri
+!         close(97)
+!$OMP MASTER
+         if (read_climoz >= 1) then
+            if (is_mpi_root) then
+               call nf95_close(ncid_climoz)
+            end if
+            deallocate(press_climoz) ! pointer
+         end if
+!$OMP END MASTER
+      ENDIF
+      
+!      first=.false.
+
+! Lluis
+  PRINT *,'  Lluis: ',klev,'  UBOUNDS: ',UBOUND(t_seri), UBOUND(u_seri),             &
+    UBOUND(d_q_con), UBOUND(d_t_con)
+  PRINT *,'  Lluis llp ',llp,' itap: ',itap,' zlev t_seri u_seri d_q_con d_t_con_____'
+  DO i=1,klev
+     PRINT *,i,t_seri(llp,i), u_seri(llp,i), d_q_con(llp,i), d_t_con(llp,i)
+  END DO 
+
+
+      RETURN
+      END SUBROUTINE physiq
+
+      FUNCTION qcheck(klon,klev,paprs,q,ql,aire)
+      IMPLICIT none
+!c
+!c Calculer et imprimer l'eau totale. A utiliser pour verifier
+!c la conservation de l'eau
+!c
+#include "YOMCST.h"
+      INTEGER klon,klev
+      REAL paprs(klon,klev+1), q(klon,klev), ql(klon,klev)
+      REAL aire(klon)
+      REAL qtotal, zx, qcheck
+      INTEGER i, k
+!c
+      zx = 0.0
+      DO i = 1, klon
+         zx = zx + aire(i)
+      ENDDO
+      qtotal = 0.0
+      DO k = 1, klev
+      DO i = 1, klon
+         qtotal = qtotal + (q(i,k)+ql(i,k)) * aire(i)                                &
+       &                     *(paprs(i,k)-paprs(i,k+1))/RG
+      ENDDO
+      ENDDO
+!c
+      qcheck = qtotal/zx
+!c
+      RETURN
+      END
+
+      SUBROUTINE gr_fi_ecrit(nfield,nlon,iim,jjmp1,fi,ecrit)
+      IMPLICIT none
+!c
+!c Tranformer une variable de la grille physique a
+!c la grille d'ecriture
+!c
+      INTEGER nfield,nlon,iim,jjmp1, jjm
+      REAL fi(nlon,nfield), ecrit(iim*jjmp1,nfield)
+!c
+      INTEGER i, n, ig
+!c
+      jjm = jjmp1 - 1
+      DO n = 1, nfield
+         DO i=1,iim
+            ecrit(i,n) = fi(1,n)
+            ecrit(i+jjm*iim,n) = fi(nlon,n)
+         ENDDO
+         DO ig = 1, nlon - 2
+           ecrit(iim+ig,n) = fi(1+ig,n)
+         ENDDO
+      ENDDO
+      RETURN
+      END SUBROUTINE gr_fi_ecrit
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/physiq_limit_variables_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/physiq_limit_variables_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/physiq_limit_variables_mod.F90	(revision 17)
@@ -0,0 +1,93 @@
+MODULE physiq_limit_variables_mod
+! L. Fita, November 2013. Making them accessible. Since wrfinput/wrfbdy/wrfrst/wrflow files are been used
+
+  IMPLICIT NONE
+
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: restart_runoff
+!$OMP THREADPRIVATE(restart_runoff) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: qsol_rst
+!$OMP THREADPRIVATE(qsol_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: fder_rst
+!$OMP THREADPRIVATE(fder_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: snow_rst
+!$OMP THREADPRIVATE(snow_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: qsurf_rst
+!$OMP THREADPRIVATE(qsurf_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: evap_rst
+!$OMP THREADPRIVATE(evap_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: rugos_rst
+!$OMP THREADPRIVATE(rugos_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: agesno_rst
+!$OMP THREADPRIVATE(agesno_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE            :: ftsoil_rst
+!$OMP THREADPRIVATE(ftsoil_rst) 
+
+  CONTAINS
+
+  SUBROUTINE vars_limit()
+! Do not do nothing. 
+
+    IMPLICIT NONE
+
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: restart_runoff
+!$OMP THREADPRIVATE(restart_runoff) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: qsol_rst
+!$OMP THREADPRIVATE(qsol_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE                :: fder_rst
+!$OMP THREADPRIVATE(fder_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: snow_rst
+!$OMP THREADPRIVATE(snow_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: qsurf_rst
+!$OMP THREADPRIVATE(qsurf_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: evap_rst
+!$OMP THREADPRIVATE(evap_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: rugos_rst
+!$OMP THREADPRIVATE(rugos_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE              :: agesno_rst
+!$OMP THREADPRIVATE(agesno_rst) 
+    REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE            :: ftsoil_rst
+!$OMP THREADPRIVATE(ftsoil_rst) 
+
+  END SUBROUTINE
+
+  SUBROUTINE vars_limit_init(klon)
+! Subroutine to initialize limit variables
+
+    USE mod_grid_phy_lmdz, ONLY: klon_glo
+    USE indice_sol_mod
+
+    IMPLICIT NONE
+
+    INCLUDE "dimensions.h"
+    INCLUDE "dimsoil.h"
+
+    INTEGER, INTENT(IN)                                  :: klon
+
+!!    IF (ALLOCATED(restart_runoff)) DEALLOCATE(restart_runoff)
+    ALLOCATE(restart_runoff(klon))
+
+!!    IF (ALLOCATED(qsol_rst)) DEALLOCATE(qsol_rst)
+    ALLOCATE(qsol_rst(klon))
+!!    IF (ALLOCATED(fder_rst)) DEALLOCATE(fder_rst)
+    ALLOCATE(fder_rst(klon))
+!!    IF (ALLOCATED(snow_rst)) DEALLOCATE(snow_rst)
+    ALLOCATE(snow_rst(klon, nbsrf))
+!!    IF (ALLOCATED(qsurf_rst)) DEALLOCATE(qsurf_rst)
+    ALLOCATE(qsurf_rst(klon, nbsrf))
+!!    IF (ALLOCATED(evap_rst)) DEALLOCATE(evap_rst)
+    ALLOCATE(evap_rst(klon, nbsrf))
+!!    IF (ALLOCATED(rugos_rst)) DEALLOCATE(rugos_rst)
+    ALLOCATE(rugos_rst(klon, nbsrf))
+!!    IF (ALLOCATED(agesno_rst)) DEALLOCATE(agesno_rst)
+    ALLOCATE(agesno_rst(klon, nbsrf))
+!!    IF (ALLOCATED(ftsoil_rst)) DEALLOCATE(ftsoil_rst)
+    ALLOCATE(ftsoil_rst(klon, nsoilmx, nbsrf))
+
+    PRINT *,'  Lluis in var_limit_init 315 qsurf_rst: ',qsurf_rst(315,:),   &
+      'qsol_rst: ',qsol_rst(315)
+
+    RETURN
+
+  END SUBROUTINE vars_limit_init
+
+END MODULE physiq_limit_variables_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phystokenc.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phystokenc.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phystokenc.F90	(revision 17)
@@ -0,0 +1,363 @@
+SUBROUTINE phystokenc (nlon,nlev,pdtphys,rlon,rlat, &
+     pt,pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
+     pfm_therm,pentr_therm, &
+     cdragh, pcoefh,yu1,yv1,ftsol,pctsrf, &
+     frac_impa,frac_nucl, &
+     pphis,paire,dtime,itap, &
+     psh, pda, pphi, pmp, pupwd, pdnwd)
+  
+  USE ioipsl
+  USE dimphy
+  USE infotrac, ONLY : nqtot
+  USE iophy
+  USE control_mod
+  USE indice_sol_mod
+  
+  IMPLICIT NONE
+  
+!======================================================================
+! Auteur(s) FH
+! Objet: Ecriture des variables pour transport offline
+!
+!======================================================================
+  INCLUDE "dimensions.h"
+  INCLUDE "tracstoke.h"
+  INCLUDE "iniprint.h"
+!======================================================================
+
+! Arguments:
+!
+  REAL,DIMENSION(klon,klev), INTENT(IN)     :: psh   ! humidite specifique
+  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pda
+  REAL,DIMENSION(klon,klev,klev), INTENT(IN):: pphi
+  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pmp
+  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pupwd ! saturated updraft mass flux
+  REAL,DIMENSION(klon,klev), INTENT(IN)     :: pdnwd ! saturated downdraft mass flux
+
+!   EN ENTREE:
+!   ==========
+!
+!   divers:
+!   -------
+!
+  INTEGER nlon ! nombre de points horizontaux
+  INTEGER nlev ! nombre de couches verticales
+  REAL pdtphys ! pas d'integration pour la physique (seconde)
+  INTEGER itap
+  INTEGER, SAVE :: physid
+!$OMP THREADPRIVATE(physid)
+
+!   convection:
+!   -----------
+!
+  REAL pmfu(klon,klev)  ! flux de masse dans le panache montant
+  REAL pmfd(klon,klev)  ! flux de masse dans le panache descendant
+  REAL pen_u(klon,klev) ! flux entraine dans le panache montant
+  REAL pde_u(klon,klev) ! flux detraine dans le panache montant
+  REAL pen_d(klon,klev) ! flux entraine dans le panache descendant
+  REAL pde_d(klon,klev) ! flux detraine dans le panache descendant
+  REAL pt(klon,klev)
+  REAL,ALLOCATABLE,SAVE :: t(:,:)
+!$OMP THREADPRIVATE(t)
+!
+  REAL rlon(klon), rlat(klon), dtime
+  REAL zx_tmp_3d(iim,jjm+1,klev),zx_tmp_2d(iim,jjm+1)
+
+!   Couche limite:
+!   --------------
+!
+  REAL cdragh(klon)          ! cdrag
+  REAL pcoefh(klon,klev)     ! coeff melange CL
+  REAL pcoefh_buf(klon,klev) ! coeff melange CL + cdrag
+  REAL yv1(klon)
+  REAL yu1(klon),pphis(klon),paire(klon)
+
+!   Les Thermiques : (Abderr 25 11 02)
+!   ---------------
+  REAL, INTENT(IN) ::  pfm_therm(klon,klev+1)
+  REAL pentr_therm(klon,klev)
+  
+  REAL,ALLOCATABLE,SAVE :: entr_therm(:,:)
+  REAL,ALLOCATABLE,SAVE :: fm_therm(:,:)
+!$OMP THREADPRIVATE(entr_therm)
+!$OMP THREADPRIVATE(fm_therm)
+!
+!   Lessivage:
+!   ----------
+!
+  REAL frac_impa(klon,klev)
+  REAL frac_nucl(klon,klev)
+!
+! Arguments necessaires pour les sources et puits de traceur
+!
+  REAL ftsol(klon,nbsrf)  ! Temperature du sol (surf)(Kelvin)
+  REAL pctsrf(klon,nbsrf) ! Pourcentage de sol f(nature du sol)
+!======================================================================
+!
+  INTEGER i, k, kk
+  REAL,ALLOCATABLE,SAVE :: mfu(:,:)  ! flux de masse dans le panache montant
+  REAL,ALLOCATABLE,SAVE :: mfd(:,:)  ! flux de masse dans le panache descendant
+  REAL,ALLOCATABLE,SAVE :: en_u(:,:) ! flux entraine dans le panache montant
+  REAL,ALLOCATABLE,SAVE :: de_u(:,:) ! flux detraine dans le panache montant
+  REAL,ALLOCATABLE,SAVE :: en_d(:,:) ! flux entraine dans le panache descendant
+  REAL,ALLOCATABLE,SAVE :: de_d(:,:) ! flux detraine dans le panache descendant
+  REAL,ALLOCATABLE,SAVE :: coefh(:,:) ! flux detraine dans le panache descendant
+  
+  REAL,ALLOCATABLE,SAVE :: pyu1(:)
+  REAL,ALLOCATABLE,SAVE :: pyv1(:)
+  REAL,ALLOCATABLE,SAVE :: pftsol(:,:)
+  REAL,ALLOCATABLE,SAVE :: ppsrf(:,:)
+!$OMP THREADPRIVATE(mfu,mfd,en_u,de_u,en_d,de_d,coefh)
+!$OMP THREADPRIVATE(pyu1,pyv1,pftsol,ppsrf)
+
+
+  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: sh  
+  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: da
+  REAL,DIMENSION(:,:,:), ALLOCATABLE,SAVE   :: phi
+  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: mp
+  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: upwd
+  REAL,DIMENSION(:,:), ALLOCATABLE,SAVE     :: dnwd
+  
+  REAL, SAVE :: dtcum
+  INTEGER, SAVE:: iadvtr=0
+!$OMP THREADPRIVATE(dtcum,iadvtr)
+  REAL zmin,zmax
+  LOGICAL ok_sync
+  CHARACTER(len=12) :: nvar
+  logical, parameter :: lstokenc=.FALSE.
+!
+!======================================================================
+
+  iadvtr=iadvtr+1
+
+! Dans le meme vecteur on recombine le drag et les coeff d'echange
+  pcoefh_buf(:,1)      = cdragh(:)
+  pcoefh_buf(:,2:klev) = pcoefh(:,2:klev)
+  
+  ok_sync = .TRUE.
+
+! Initialization done only once
+!======================================================================
+  IF (iadvtr==1) THEN
+     ALLOCATE( t(klon,klev))
+     ALLOCATE( mfu(klon,klev))  
+     ALLOCATE( mfd(klon,klev))  
+     ALLOCATE( en_u(klon,klev)) 
+     ALLOCATE( de_u(klon,klev)) 
+     ALLOCATE( en_d(klon,klev)) 
+     ALLOCATE( de_d(klon,klev)) 
+     ALLOCATE( coefh(klon,klev)) 
+     ALLOCATE( entr_therm(klon,klev))
+     ALLOCATE( fm_therm(klon,klev))
+     ALLOCATE( pyu1(klon))
+     ALLOCATE( pyv1(klon))
+     ALLOCATE( pftsol(klon,nbsrf))
+     ALLOCATE( ppsrf(klon,nbsrf))
+     
+     ALLOCATE(sh(klon,klev)) 
+     ALLOCATE(da(klon,klev)) 
+     ALLOCATE(phi(klon,klev,klev)) 
+     ALLOCATE(mp(klon,klev)) 
+     ALLOCATE(upwd(klon,klev)) 
+     ALLOCATE(dnwd(klon,klev)) 
+
+     CALL initphysto('phystoke', dtime, dtime*istphy,dtime*istphy,physid)
+     
+     ! Write field phis and aire only once
+     CALL histwrite_phy(physid,lstokenc,"phis",itap,pphis)
+     CALL histwrite_phy(physid,lstokenc,"aire",itap,paire)
+     CALL histwrite_phy(physid,lstokenc,"longitudes",itap,rlon)
+     CALL histwrite_phy(physid,lstokenc,"latitudes",itap,rlat)
+
+  END IF
+  
+  
+! Set to zero cumulating fields
+!======================================================================
+  IF (MOD(iadvtr,istphy)==1.OR.istphy==1) THEN
+     WRITE(lunout,*)'reinitialisation des champs cumules a iadvtr=',iadvtr
+     mfu(:,:)=0.
+     mfd(:,:)=0.
+     en_u(:,:)=0.
+     de_u(:,:)=0.
+     en_d(:,:)=0.
+     de_d(:,:)=0.
+     coefh(:,:)=0.
+     t(:,:)=0.
+     fm_therm(:,:)=0.
+     entr_therm(:,:)=0.
+     pyv1(:)=0.
+     pyu1(:)=0.
+     pftsol(:,:)=0.
+     ppsrf(:,:)=0.
+     sh(:,:)=0.
+     da(:,:)=0.
+     phi(:,:,:)=0.
+     mp(:,:)=0.
+     upwd(:,:)=0.
+     dnwd(:,:)=0.
+     dtcum=0.
+  ENDIF
+  
+
+! Cumulate fields at each time step
+!======================================================================
+  DO k=1,klev
+     DO i=1,klon
+        mfu(i,k)=mfu(i,k)+pmfu(i,k)*pdtphys
+        mfd(i,k)=mfd(i,k)+pmfd(i,k)*pdtphys
+        en_u(i,k)=en_u(i,k)+pen_u(i,k)*pdtphys
+        de_u(i,k)=de_u(i,k)+pde_u(i,k)*pdtphys
+        en_d(i,k)=en_d(i,k)+pen_d(i,k)*pdtphys
+        de_d(i,k)=de_d(i,k)+pde_d(i,k)*pdtphys
+        coefh(i,k)=coefh(i,k)+pcoefh_buf(i,k)*pdtphys
+        t(i,k)=t(i,k)+pt(i,k)*pdtphys
+        fm_therm(i,k)=fm_therm(i,k)+pfm_therm(i,k)*pdtphys
+        entr_therm(i,k)=entr_therm(i,k)+pentr_therm(i,k)*pdtphys
+        sh(i,k) = sh(i,k) + psh(i,k)*pdtphys
+        da(i,k) = da(i,k) + pda(i,k)*pdtphys
+        mp(i,k) = mp(i,k) + pmp(i,k)*pdtphys
+        upwd(i,k) = upwd(i,k) + pupwd(i,k)*pdtphys
+        dnwd(i,k) = dnwd(i,k) + pdnwd(i,k)*pdtphys
+     ENDDO
+  ENDDO
+
+  DO kk=1,klev
+     DO k=1,klev
+        DO i=1,klon
+           phi(i,k,kk) = phi(i,k,kk) + pphi(i,k,kk)*pdtphys
+        END DO
+     END DO
+  END DO
+
+  DO i=1,klon
+     pyv1(i)=pyv1(i)+yv1(i)*pdtphys
+     pyu1(i)=pyu1(i)+yu1(i)*pdtphys
+  END DO
+  DO k=1,nbsrf
+     DO i=1,klon
+        pftsol(i,k)=pftsol(i,k)+ftsol(i,k)*pdtphys
+        ppsrf(i,k)=ppsrf(i,k)+pctsrf(i,k)*pdtphys
+     ENDDO
+  ENDDO
+  
+! Add time step to cumulated time
+  dtcum=dtcum+pdtphys
+  
+
+! Write fields to file, if it is time to do so
+!======================================================================
+  IF(MOD(iadvtr,istphy)==0) THEN 
+
+     ! normalize with time period
+     DO k=1,klev
+        DO i=1,klon
+           mfu(i,k)=mfu(i,k)/dtcum
+           mfd(i,k)=mfd(i,k)/dtcum
+           en_u(i,k)=en_u(i,k)/dtcum
+           de_u(i,k)=de_u(i,k)/dtcum
+           en_d(i,k)=en_d(i,k)/dtcum
+           de_d(i,k)=de_d(i,k)/dtcum
+           coefh(i,k)=coefh(i,k)/dtcum
+           t(i,k)=t(i,k)/dtcum	
+           fm_therm(i,k)=fm_therm(i,k)/dtcum
+           entr_therm(i,k)=entr_therm(i,k)/dtcum
+           sh(i,k)=sh(i,k)/dtcum
+           da(i,k)=da(i,k)/dtcum
+           mp(i,k)=mp(i,k)/dtcum
+           upwd(i,k)=upwd(i,k)/dtcum
+           dnwd(i,k)=dnwd(i,k)/dtcum
+        ENDDO
+     ENDDO
+     DO kk=1,klev
+        DO k=1,klev
+           DO i=1,klon
+              phi(i,k,kk) = phi(i,k,kk)/dtcum
+           END DO
+        END DO
+     END DO
+     DO i=1,klon
+        pyv1(i)=pyv1(i)/dtcum
+        pyu1(i)=pyu1(i)/dtcum
+     END DO
+     DO k=1,nbsrf
+        DO i=1,klon
+           pftsol(i,k)=pftsol(i,k)/dtcum
+           ppsrf(i,k)=ppsrf(i,k)/dtcum
+        ENDDO
+     ENDDO
+
+     ! write fields
+     CALL histwrite_phy(physid,lstokenc,"t",itap,t)
+     CALL histwrite_phy(physid,lstokenc,"mfu",itap,mfu)
+     CALL histwrite_phy(physid,lstokenc,"mfd",itap,mfd)
+     CALL histwrite_phy(physid,lstokenc,"en_u",itap,en_u)
+     CALL histwrite_phy(physid,lstokenc,"de_u",itap,de_u)
+     CALL histwrite_phy(physid,lstokenc,"en_d",itap,en_d)
+     CALL histwrite_phy(physid,lstokenc,"de_d",itap,de_d)
+     CALL histwrite_phy(physid,lstokenc,"coefh",itap,coefh)	
+     CALL histwrite_phy(physid,lstokenc,"fm_th",itap,fm_therm)
+     CALL histwrite_phy(physid,lstokenc,"en_th",itap,entr_therm)
+     CALL histwrite_phy(physid,lstokenc,"frac_impa",itap,frac_impa)
+     CALL histwrite_phy(physid,lstokenc,"frac_nucl",itap,frac_nucl)
+     CALL histwrite_phy(physid,lstokenc,"pyu1",itap,pyu1)
+     CALL histwrite_phy(physid,lstokenc,"pyv1",itap,pyv1)
+     CALL histwrite_phy(physid,lstokenc,"ftsol1",itap,pftsol(:,1))
+     CALL histwrite_phy(physid,lstokenc,"ftsol2",itap,pftsol(:,2))
+     CALL histwrite_phy(physid,lstokenc,"ftsol3",itap,pftsol(:,3))
+     CALL histwrite_phy(physid,lstokenc,"ftsol4",itap,pftsol(:,4))
+     CALL histwrite_phy(physid,lstokenc,"psrf1",itap,ppsrf(:,1))
+     CALL histwrite_phy(physid,lstokenc,"psrf2",itap,ppsrf(:,2))
+     CALL histwrite_phy(physid,lstokenc,"psrf3",itap,ppsrf(:,3))
+     CALL histwrite_phy(physid,lstokenc,"psrf4",itap,ppsrf(:,4))
+     CALL histwrite_phy(physid,lstokenc,"sh",itap,sh)
+     CALL histwrite_phy(physid,lstokenc,"da",itap,da)
+     CALL histwrite_phy(physid,lstokenc,"mp",itap,mp)
+     CALL histwrite_phy(physid,lstokenc,"upwd",itap,upwd)
+     CALL histwrite_phy(physid,lstokenc,"dnwd",itap,dnwd)
+
+
+! phi
+     DO k=1,klev
+        IF (k<10) THEN
+           WRITE(nvar,'(i1)') k
+        ELSE IF (k<100) THEN
+           WRITE(nvar,'(i2)') k
+        ELSE
+           WRITE(nvar,'(i3)') k
+        END IF
+        nvar='phi_lev'//trim(nvar)
+        
+        CALL histwrite_phy(physid,lstokenc,nvar,itap,phi(:,:,k))
+     END DO
+     
+     ! Syncronize file
+!$OMP MASTER
+     IF (ok_sync) CALL histsync(physid)
+!$OMP END MASTER
+     
+     
+     ! Calculate min and max values for some fields (coefficients de lessivage)
+     zmin=1e33
+     zmax=-1e33
+     DO k=1,klev
+        DO i=1,klon
+           zmax=MAX(zmax,frac_nucl(i,k))
+           zmin=MIN(zmin,frac_nucl(i,k))
+        ENDDO
+     ENDDO
+     WRITE(lunout,*)'------ coefs de lessivage (min et max) --------'
+     WRITE(lunout,*)'facteur de nucleation ',zmin,zmax
+     zmin=1e33
+     zmax=-1e33
+     DO k=1,klev
+        DO i=1,klon
+           zmax=MAX(zmax,frac_impa(i,k))
+           zmin=MIN(zmin,frac_impa(i,k))
+        ENDDO
+     ENDDO
+     WRITE(lunout,*)'facteur d impaction ',zmin,zmax
+     
+  ENDIF ! IF(MOD(iadvtr,istphy)==0)
+
+END SUBROUTINE phystokenc
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/phytrac.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/phytrac.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/phytrac.F90	(revision 17)
@@ -0,0 +1,706 @@
+!$Id $
+
+SUBROUTINE phytrac(                            &
+     nstep,     julien,   gmtime,   debutphy,  &
+     lafin,     pdtphys,  u, v,     t_seri,    &
+     paprs,     pplay,    pmfu,     pmfd,      &
+     pen_u,     pde_u,    pen_d,    pde_d,     &
+     cdragh,    coefh,    fm_therm, entr_therm,&
+     yu1,       yv1,      ftsol,    pctsrf,    &
+     ustar,     u10m,      v10m,               &
+     xlat,      xlon,                          &
+     frac_impa,frac_nucl,beta_fisrt,beta_v1,   &
+     presnivs,  pphis,    pphi,     albsol,    &
+     sh,        rh,       cldfra,   rneb,      &
+     diafra,    cldliq,   itop_con, ibas_con,  &
+     pmflxr,    pmflxs,   prfl,     psfl,      &
+     da,        phi,      mp,       upwd,      &
+     phi2,      d1a,      dam,      sij,       &   ! RomP
+     wdtrainA,  wdtrainM, sigd,     clw,elij,  &   ! RomP 
+     evap,      ep,       epmlmMm,  eplaMm,    &   ! RomP
+     dnwd,      aerosol_couple,     flxmass_w, &
+     tau_aero,  piz_aero,  cg_aero, ccm,       &
+     rfname,                                   &
+     d_tr_dyn,                                 &   ! RomP
+     tr_seri)         
+!
+!======================================================================
+! Auteur(s) FH
+! Objet: Moniteur general des tendances traceurs
+! Modification R. Pilon 01 janvier 2012 transport+scavenging KE scheme : cvltr
+! Modification R. Pilon 10 octobre 2012 large scale scavenging incloud_scav + bc_scav
+!======================================================================
+
+  USE ioipsl
+  USE phys_cal_mod, only : hour
+  USE phys_output_mod, only : convers_timesteps
+  USE dimphy
+  USE infotrac
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+  USE comgeomphy
+  USE iophy
+  USE traclmdz_mod
+  USE tracinca_mod
+  USE tracreprobus_mod
+  USE control_mod
+  USE indice_sol_mod
+
+  IMPLICIT NONE
+
+  INCLUDE "YOMCST.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "clesphys.h"
+  INCLUDE "temps.h"
+  INCLUDE "paramet.h"
+  INCLUDE "thermcell.h"
+  INCLUDE "iniprint.h"
+!==========================================================================
+!                   -- ARGUMENT DESCRIPTION --
+!==========================================================================
+
+! Input arguments
+!----------------
+!Configuration grille,temps:
+  INTEGER,INTENT(IN) :: nstep      ! Appel physique
+  INTEGER,INTENT(IN) :: julien     ! Jour julien
+  REAL,INTENT(IN)    :: gmtime     ! Heure courante
+  REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
+  LOGICAL,INTENT(IN) :: debutphy   ! le flag de l'initialisation de la physique
+  LOGICAL,INTENT(IN) :: lafin      ! le flag de la fin de la physique
+  
+  REAL,DIMENSION(klon),INTENT(IN) :: xlat    ! latitudes pour chaque point 
+  REAL,DIMENSION(klon),INTENT(IN) :: xlon    ! longitudes pour chaque point 
+!
+!Physique: 
+!--------
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: u       ! variable not used 
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: v       ! variable not used 
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: rh      ! humidite relative
+  REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: pphi    ! geopotentiel
+  REAL,DIMENSION(klon),INTENT(IN)        :: pphis
+  REAL,DIMENSION(klev),INTENT(IN)        :: presnivs 
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: cldliq  ! eau liquide nuageuse
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: cldfra  ! fraction nuageuse (tous les nuages)
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: diafra  ! fraction nuageuse (convection ou stratus artificiels)
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: rneb    ! fraction nuageuse (grande echelle)
+!
+  REAL                                   :: ql_incl ! contenu en eau liquide nuageuse dans le nuage ! ql_incl=oliq/rneb
+  REAL,DIMENSION(klon,klev),INTENT(IN)   :: beta_fisrt ! taux de conversion de l'eau cond (de fisrtilp)
+  REAL,DIMENSION(klon,klev),INTENT(out)  :: beta_v1    ! -- (originale version)
+
+!
+  INTEGER,DIMENSION(klon),INTENT(IN)     :: itop_con
+  INTEGER,DIMENSION(klon),INTENT(IN)     :: ibas_con
+  REAL,DIMENSION(klon),INTENT(IN)        :: albsol  ! albedo surface
+!
+!Dynamique
+!--------
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN)    :: d_tr_dyn
+!
+!Convection:
+!----------
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu  ! flux de masse dans le panache montant
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfd  ! flux de masse dans le panache descendant
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_u ! flux entraine dans le panache montant
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_u ! flux detraine dans le panache montant
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pen_d ! flux entraine dans le panache descendant
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: pde_d ! flux detraine dans le panache descendant
+
+!...Tiedke     
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: pmflxr, pmflxs ! Flux precipitant de pluie, neige aux interfaces [convection]
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: prfl, psfl ! Flux precipitant de pluie, neige aux interfaces [large-scale]
+
+  LOGICAL,INTENT(IN)                       :: aerosol_couple
+  REAL,DIMENSION(klon,klev),INTENT(IN)     :: flxmass_w
+  REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: tau_aero
+  REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: piz_aero
+  REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: cg_aero
+  CHARACTER(len=4),DIMENSION(9),INTENT(IN) :: rfname 
+  REAL,DIMENSION(klon,klev,2),INTENT(IN)   :: ccm 
+!... K.Emanuel
+  REAL,DIMENSION(klon,klev),INTENT(IN)     :: da
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN):: phi
+! RomP >>>
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: d1a,dam
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: phi2
+!
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainA
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: wdtrainM
+  REAL,DIMENSION(klon),INTENT(IN)           :: sigd
+! ---- RomP flux entraine, detraine et precipitant kerry Emanuel
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: evap
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: ep
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: sij
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: elij
+  REAL,DIMENSION(klon,klev,klev),INTENT(IN) :: epmlmMm
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: eplaMm
+  REAL,DIMENSION(klon,klev),INTENT(IN)      :: clw
+! RomP <<<
+
+!
+  REAL,DIMENSION(klon,klev),INTENT(IN)     :: mp
+  REAL,DIMENSION(klon,klev),INTENT(IN)     :: upwd      ! saturated updraft mass flux
+  REAL,DIMENSION(klon,klev),INTENT(IN)     :: dnwd      ! saturated downdraft mass flux
+!
+!Thermiques:
+!----------
+  REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: fm_therm
+  REAL,DIMENSION(klon,klev),INTENT(IN)     :: entr_therm
+!
+!Couche limite:
+!--------------
+!
+  REAL,DIMENSION(klon),INTENT(IN)      :: cdragh ! coeff drag pour T et Q
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: coefh  ! coeff melange CL (m**2/s)
+  REAL,DIMENSION(klon),INTENT(IN)      :: ustar,u10m,v10m ! u* & vent a 10m (m/s)
+  REAL,DIMENSION(klon),INTENT(IN)      :: yu1    ! vents au premier niveau
+  REAL,DIMENSION(klon),INTENT(IN)      :: yv1    ! vents au premier niveau
+!
+!Lessivage:
+!----------
+!
+! pour le ON-LINE
+!
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: frac_impa ! fraction d'aerosols non impactes
+  REAL,DIMENSION(klon,klev),INTENT(IN) :: frac_nucl ! fraction d'aerosols non nuclees
+
+! Arguments necessaires pour les sources et puits de traceur:
+  REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol  ! Temperature du sol (surf)(Kelvin)
+  REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol (nature du sol)
+
+
+! Output argument
+!----------------
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri ! Concentration Traceur [U/KgA]
+  REAL,DIMENSION(klon,klev)                    :: sourceBE 
+!=======================================================================================
+!                        -- LOCAL VARIABLES --
+!=======================================================================================
+
+  INTEGER :: i, k, it
+  INTEGER :: nsplit
+
+!Sources et Reservoirs de traceurs (ex:Radon):
+!--------------------------------------------
+!
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: source  ! a voir lorsque le flux de surface est prescrit
+!$OMP THREADPRIVATE(source)
+
+!
+!Entrees/Sorties: (cf ini_histrac.h et write_histrac.h)  
+!---------------
+  INTEGER                   :: iiq, ierr
+  INTEGER                   :: nhori, nvert
+  REAL                      :: zsto, zout, zjulian
+  INTEGER,SAVE              :: nid_tra     ! pointe vers le fichier histrac.nc         
+!$OMP THREADPRIVATE(nid_tra)
+  REAL,DIMENSION(klon)      :: zx_tmp_fi2d ! variable temporaire grille physique
+  INTEGER                   :: itau_w      ! pas de temps ecriture = nstep + itau_phy
+  LOGICAL,PARAMETER         :: ok_sync=.TRUE.
+  CHARACTER(len=20),save    :: chtratimestep,chtratimestep_omp
+!$OMP THREADPRIVATE(chtratimestep)
+!
+! Nature du traceur
+!------------------
+  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: aerosol  ! aerosol(it) = true  => aerosol => lessivage
+!$OMP THREADPRIVATE(aerosol)                        ! aerosol(it) = false => gaz
+  REAL,DIMENSION(klon,klev)             :: delp     ! epaisseur de couche (Pa)
+!
+! Tendances de traceurs (Td) et flux de traceurs:
+!------------------------
+  REAL,DIMENSION(klon,klev)      :: d_tr     ! Td dans l'atmosphere
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_cl  ! Td couche limite/traceur
+  REAL,DIMENSION(klon,nbtr)      :: d_tr_dry ! Td depot sec/traceur (1st layer)  jyg
+  REAL,DIMENSION(klon,nbtr)      :: flux_tr_dry ! depot sec/traceur (surface)    jyg
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_dec                            !RomP
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_cv  ! Td convection/traceur
+! RomP >>>
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_insc
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_bcscav
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_evapls
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_ls
+  REAL,DIMENSION(klon,nbtr)      :: qPrls      !jyg: concentration tra dans pluie LS a la surf.
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_trsp
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_sscav
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_sat
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_uscav
+  REAL,DIMENSION(klon,klev,nbtr) :: qPr,qDi ! concentration tra dans pluie,air descente insaturee
+  REAL,DIMENSION(klon,klev,nbtr) :: qPa,qMel
+  REAL,DIMENSION(klon,klev,nbtr) :: qTrdi,dtrcvMA ! conc traceur descente air insaturee et td convective MA
+  REAL,DIMENSION(klon,klev)      :: Mint
+  REAL,DIMENSION(klon,klev,nbtr) :: zmfd1a
+  REAL,DIMENSION(klon,klev,nbtr) :: zmfdam
+  REAL,DIMENSION(klon,klev,nbtr) :: zmfphi2
+! RomP <<<
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_th  ! Td thermique
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_lessi_impa ! Td du lessivage par impaction
+  REAL,DIMENSION(klon,klev,nbtr) :: d_tr_lessi_nucl ! Td du lessivage par nucleation
+!
+! Physique
+!---------- 
+  REAL,DIMENSION(klon,klev,nbtr) :: flestottr ! flux de lessivage dans chaque couche 
+  REAL,DIMENSION(klon,klev)      :: zmasse    ! densit\E9 atmosph\E9rique Kg/m2
+  REAL,DIMENSION(klon,klev)      :: ztra_th
+!PhH
+  REAL,DIMENSION(klon,klev)      :: zrho
+  REAL,DIMENSION(klon,klev)      :: zdz
+  REAL                           :: evaplsc,dx,beta ! variable pour lessivage Genthon
+  REAL,DIMENSION(klon)           :: his_dh          ! ---
+! in-cloud scav variables
+  REAL           :: ql_incloud_ref     ! ref value of in-cloud condensed water content
+  
+!Controles:
+!---------
+  LOGICAL,SAVE :: couchelimite=.TRUE.
+  LOGICAL,SAVE :: convection=.TRUE.
+  LOGICAL,SAVE :: lessivage
+!$OMP THREADPRIVATE(couchelimite,convection,lessivage)
+
+  CHARACTER(len=8),DIMENSION(nbtr) :: solsym
+!RomP >>>
+  INTEGER,SAVE  :: iflag_lscav_omp,iflag_lscav
+  LOGICAL,SAVE  :: convscav_omp,convscav
+
+  PRINT *,'  Lluis in phytrac type_trac: ',type_trac
+
+!$OMP THREADPRIVATE(iflag_lscav,convscav)
+!RomP <<<
+!######################################################################
+!                    -- INITIALIZATION --
+!######################################################################
+  DO k=1,klev
+     DO i=1,klon
+      sourceBE(i,k)=0.
+      Mint(i,k)=0.
+      zrho(i,k)=0.
+      zdz(i,k)=0.
+     END DO
+  END DO
+
+  DO it=1, nbtr
+   DO k=1,klev
+    DO i=1,klon
+    d_tr_insc(i,k,it)=0.
+    d_tr_bcscav(i,k,it)=0.
+    d_tr_evapls(i,k,it)=0.
+    d_tr_ls(i,k,it)=0.
+    d_tr_cv(i,k,it)=0.
+    d_tr_cl(i,k,it)=0.
+    d_tr_trsp(i,k,it)=0.
+    d_tr_sscav(i,k,it)=0.
+    d_tr_sat(i,k,it)=0.
+    d_tr_uscav(i,k,it)=0.
+    d_tr_lessi_impa(i,k,it)=0.
+    d_tr_lessi_nucl(i,k,it)=0.
+    qDi(i,k,it)=0.
+    qPr(i,k,it)=0.
+    qPa(i,k,it)=0.
+    qMel(i,k,it)=0.
+    qTrdi(i,k,it)=0.
+    dtrcvMA(i,k,it)=0.
+    zmfd1a(i,k,it)=0.
+    zmfdam(i,k,it)=0.
+    zmfphi2(i,k,it)=0.
+    END DO
+   END DO
+  END DO
+  IF (debutphy) THEN
+!!jyg
+!$OMP MASTER
+   chtratimestep_omp='DefFreq'
+   CALL getin('tra_time_step',chtratimestep_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+   chtratimestep=chtratimestep_omp
+   IF (chtratimestep .NE. 'DefFreq') THEN
+     call convers_timesteps(chtratimestep,pdtphys,ecrit_tra)
+   ENDIF
+!RomP >>>
+!
+!Config Key  = convscav
+!Config Desc = Convective scavenging switch: 0=off, 1=on.
+!Config Def  = .false.
+!Config Help = 
+!
+!$OMP MASTER
+  convscav_omp=.false.
+  call getin('convscav', convscav_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+  convscav=convscav_omp
+  print*,'phytrac passage dans routine conv avec lessivage', convscav
+!
+!Config Key  = iflag_lscav
+!Config Desc = Large scale scavenging parametrization: 0=none, 1=old(Genthon92),
+!              2=1+PHeinrich, 3=Reddy_Boucher2004, 4=3+RPilon.
+!Config Def  = 1
+!Config Help = 
+!
+!$OMP MASTER
+  iflag_lscav_omp=1
+  call getin('iflag_lscav', iflag_lscav_omp)
+!$OMP END MASTER
+!$OMP BARRIER
+  iflag_lscav=iflag_lscav_omp
+!
+  SELECT CASE(iflag_lscav)
+  CASE(0)
+   PRINT*, 'Large scale scavenging: none'
+  CASE(1)
+   PRINT*, 'Large scale scavenging: C. Genthon, Tellus(1992), 44B, 371-389'
+  CASE(2)
+   PRINT*, 'Large scale scavenging: C. Genthon, modified P. Heinrich'
+  CASE(3)
+   PRINT*, 'Large scale scavenging: M. Shekkar Reddy and O. Boucher, JGR(2004), 109, D14202'
+  CASE(4)
+   PRINT*, 'Large scale scavenging: Reddy and Boucher, modified R. Pilon'
+  END SELECT
+!RomP <<<
+     WRITE(*,*) 'FIRST TIME IN PHYTRAC : pdtphys(sec) = ',pdtphys,'ecrit_tra (sec) = ',ecrit_tra
+     ALLOCATE( source(klon,nbtr), stat=ierr)
+     IF (ierr /= 0) CALL abort_gcm('phytrac', 'pb in allocation 1',1)
+     
+     ALLOCATE( aerosol(nbtr), stat=ierr)
+     IF (ierr /= 0) CALL abort_gcm('phytrac', 'pb in allocation 2',1)
+     
+
+     ! Initialize module for specific tracers
+     SELECT CASE(type_trac)
+     CASE('lmdz')
+        CALL traclmdz_init(pctsrf, xlat, xlon, ftsol, tr_seri, t_seri, pplay, sh, pdtphys, aerosol, lessivage)
+        PRINT *,'  Lluis ALLOCATED trs: ',ALLOCATED(trs)
+
+     CASE('inca')
+        source(:,:)=0.
+        CALL tracinca_init(aerosol,lessivage)
+     CASE('repr')
+        source(:,:)=0.
+     END SELECT
+!
+! Initialize diagnostic output
+! ----------------------------
+#ifdef CPP_IOIPSL
+     INCLUDE "ini_histrac.h"
+#endif
+  END IF ! of IF (debutphy)
+!############################################ END INITIALIZATION #######
+
+  DO k=1,klev
+     DO i=1,klon
+        zmasse(i,k)=(paprs(i,k)-paprs(i,k+1))/rg
+     END DO
+  END DO
+!
+  IF (id_be .GT. 0) THEN
+  DO k=1,klev
+     DO i=1,klon
+        sourceBE(i,k)=srcbe(i,k)       !RomP  -> pour sortie histrac
+     END DO
+  END DO
+  ENDIF
+
+!===============================================================================
+!    -- Do specific treatment according to chemestry model or local LMDZ tracers
+!      
+!===============================================================================
+  SELECT CASE(type_trac)
+  CASE('lmdz')
+     !    -- Traitement des traceurs avec traclmdz
+     CALL traclmdz(nstep, julien, gmtime, pdtphys, t_seri, paprs, pplay, &
+          cdragh,  coefh, yu1, yv1, ftsol, pctsrf, xlat, xlon,couchelimite,sh, &
+          rh, pphi, ustar, u10m, v10m, &
+!!          tr_seri, source, solsym, d_tr_cl, zmasse)                      !RomP
+          tr_seri, source, solsym, d_tr_cl,d_tr_dec, zmasse)               !RomP
+  CASE('inca')
+     !    -- CHIMIE INCA  config_inca = aero or chem --
+
+     CALL tracinca(&
+          nstep,    julien,   gmtime,         lafin,     &
+          pdtphys,  t_seri,   paprs,          pplay,     &
+          pmfu,     ftsol,    pctsrf,         pphis,     &
+          pphi,     albsol,   sh,             rh,        &
+          cldfra,   rneb,     diafra,         cldliq,    &
+          itop_con, ibas_con, pmflxr,         pmflxs,    &
+          prfl,     psfl,     aerosol_couple, flxmass_w, &
+          tau_aero, piz_aero, cg_aero,        ccm,       &
+          rfname,                                        &
+          tr_seri,  source,   solsym)      
+
+  CASE('repr')
+     !   -- CHIMIE REPROBUS --
+
+     CALL tracreprobus(pdtphys, gmtime, debutphy, julien, &
+          presnivs, xlat, xlon, pphis, pphi, &
+          t_seri, pplay, paprs, sh , &
+          tr_seri, solsym)
+     
+  END SELECT
+!======================================================================
+!       -- Calcul de l'effet de la convection --
+!======================================================================
+
+  IF (convection) THEN
+     DO it=1, nbtr
+        IF ( conv_flg(it) == 0 ) CYCLE
+        IF (iflag_con.LT.2) THEN
+           d_tr_cv(:,:,it)=0.
+        ELSE IF (iflag_con.EQ.2) THEN
+!..Tiedke
+           CALL nflxtr(pdtphys, pmfu, pmfd, pen_u, pde_u, pen_d, pde_d, &
+                pplay, paprs, tr_seri(:,:,it), d_tr_cv(:,:,it))
+! RomP >>>                
+        ELSE   
+!..K.Emanuel                  !RomP modif arg
+        if (convscav.and.aerosol(it)) then    ! lessivage convectif pour aerosol
+!
+          CALL cvltr(pdtphys, da, phi,phi2,d1a,dam, mp,ep,              &
+               sigd,sij,clw,elij,epmlmMm,eplaMm,                        &
+               pmflxr,pmflxs,evap,t_seri,wdtrainA,wdtrainM,             &   
+               paprs,it,tr_seri,upwd,dnwd,itop_con,ibas_con,            &
+               d_tr_cv,d_tr_trsp,d_tr_sscav,d_tr_sat,d_tr_uscav,qDi,qPr,&
+               qPa,qMel,qTrdi,dtrcvMA,Mint,                             &
+               zmfd1a,zmfphi2,zmfdam)
+        else  !pas de lessivage convectif ou n'est pas un aerosol
+           CALL cvltrorig(it,pdtphys, da, phi,mp,paprs,pplay,tr_seri,&
+                    upwd,dnwd,d_tr_cv)
+        endif
+        END IF
+! RomP <<<
+
+        DO k = 1, klev
+           DO i = 1, klon        
+              tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cv(i,k,it)
+           END DO
+        END DO
+
+        CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'convection it = '//solsym(it))
+             
+     END DO ! nbtr
+  END IF ! convection
+
+!======================================================================
+!    -- Calcul de l'effet des thermiques --
+!======================================================================
+
+  DO it=1,nbtr
+     DO k=1,klev
+        DO i=1,klon
+           d_tr_th(i,k,it)=0.
+           tr_seri(i,k,it)=MAX(tr_seri(i,k,it),0.)
+           tr_seri(i,k,it)=MIN(tr_seri(i,k,it),1.e10)
+        END DO
+     END DO
+  END DO
+  
+  IF (iflag_thermals.GT.0) THEN   
+     nsplit=10
+     DO it=1, nbtr
+        DO isplit=1,nsplit
+
+           CALL dqthermcell(klon,klev,pdtphys/nsplit, &
+                fm_therm,entr_therm,zmasse, &
+                tr_seri(1:klon,1:klev,it),d_tr,ztra_th)
+
+           DO k=1,klev
+              DO i=1,klon
+                 d_tr(i,k)=pdtphys*d_tr(i,k)/nsplit
+                 d_tr_th(i,k,it)=d_tr_th(i,k,it)+d_tr(i,k)
+                 tr_seri(i,k,it)=MAX(tr_seri(i,k,it)+d_tr(i,k),0.)
+              END DO
+           END DO
+        END DO ! nsplit
+     END DO ! it
+  END IF ! Thermiques
+
+!======================================================================
+!     -- Calcul de l'effet de la couche limite --
+!======================================================================
+
+  IF (couchelimite) THEN
+
+     DO k = 1, klev
+        DO i = 1, klon
+           delp(i,k) = paprs(i,k)-paprs(i,k+1)
+        END DO
+     END DO
+
+     DO it=1, nbtr
+        
+        IF( pbl_flg(it) /= 0 ) THEN
+        
+           CALL cltrac(pdtphys, coefh,t_seri,       &
+                tr_seri(:,:,it), source(:,it),      &
+                paprs, pplay, delp,                 &
+                d_tr_cl(:,:,it),d_tr_dry(:,it),flux_tr_dry(:,it))
+           
+           DO k = 1, klev
+              DO i = 1, klon
+                 tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it)
+              END DO
+           END DO
+        END IF
+
+     END DO
+     
+  END IF ! couche limite
+
+
+!======================================================================
+!   Calcul de l'effet de la precipitation grande echelle
+!======================================================================
+  IF (lessivage) THEN
+
+   ql_incloud_ref = 10.e-4
+   ql_incloud_ref =  5.e-4
+
+
+! calcul du contenu en eau liquide au sein du nuage
+     ql_incl = ql_incloud_ref
+! choix du lessivage
+!
+  IF (iflag_lscav .EQ. 3 .OR. iflag_lscav .EQ. 4) THEN
+! ********  Olivier Boucher version (3) possibly with modified ql_incl (4)
+!
+   DO it = 1, nbtr
+!  incloud scavenging and removal by large scale rain ! orig : ql_incl was replaced by 0.5e-3 kg/kg
+! the value 0.5e-3 kg/kg is from Giorgi and Chameides (1986), JGR
+! Liu (2001) proposed to use 1.5e-3 kg/kg
+
+    CALL lsc_scav(pdtphys,it,iflag_lscav,ql_incl,prfl,psfl,rneb,beta_fisrt,  &
+                  beta_v1,pplay,paprs,t_seri,tr_seri,d_tr_insc,   &
+                  d_tr_bcscav,d_tr_evapls,qPrls)
+
+!large scale scavenging tendency
+   DO k = 1, klev
+    DO i = 1, klon
+    d_tr_ls(i,k,it)=d_tr_insc(i,k,it)+d_tr_bcscav(i,k,it)+d_tr_evapls(i,k,it)
+    tr_seri(i,k,it)=tr_seri(i,k,it)+d_tr_ls(i,k,it)
+    ENDDO
+   ENDDO
+     CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'lsc scav it = '//solsym(it))
+   END DO  !tr
+
+ ELSE IF (iflag_lscav .EQ. 2) THEN ! frac_impa, frac_nucl
+! *********   modified  old version
+
+     d_tr_lessi_nucl(:,:,:) = 0. 
+     d_tr_lessi_impa(:,:,:) = 0.
+     flestottr(:,:,:) = 0. 
+! Tendance des aerosols nuclees et impactes 
+     DO it = 1, nbtr
+        IF (aerosol(it)) THEN
+        his_dh(:)=0.
+           DO k = 1, klev
+              DO i = 1, klon
+!PhH
+              zrho(i,k)=pplay(i,k)/t_seri(i,k)/RD
+              zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG
+!
+              END DO
+           END DO
+
+          DO k=klev-1, 1, -1
+            DO i=1, klon
+!             d_tr_ls(i,k,it)=tr_seri(i,k,it)*(frac_impa(i,k)*frac_nucl(i,k)-1.)
+             dx=d_tr_ls(i,k,it)
+             his_dh(i)=his_dh(i)-dx*zrho(i,k)*zdz(i,k)/pdtphys !  kg/m2/s
+             evaplsc = prfl(i,k) - prfl(i,k+1) + psfl(i,k) - psfl(i,k+1)
+! Evaporation Partielle -> Liberation Partielle 0.5*evap
+            IF ( evaplsc .LT.0..and.abs(prfl(i,k+1)+psfl(i,k+1)).gt.1.e-10) THEN
+                evaplsc = (-evaplsc)/(prfl(i,k+1)+psfl(i,k+1))
+! evaplsc est donc positif, his_dh(i) est positif
+!--------------  
+             d_tr_evapls(i,k,it)=0.5*evaplsc*(d_tr_lessi_nucl(i,k+1,it) &
+                                  +d_tr_lessi_impa(i,k+1,it))
+!-------------   d_tr_evapls(i,k,it)=-0.5*evaplsc*(d_tr_lsc(i,k+1,it))
+             beta=0.5*evaplsc
+              if ((prfl(i,k)+psfl(i,k)).lt.1.e-10) THEN
+               beta=1.0*evaplsc
+              endif
+            dx=beta*his_dh(i)/zrho(i,k)/zdz(i,k)*pdtphys
+            his_dh(i)=(1.-beta)*his_dh(i)   ! tracer from
+            d_tr_evapls(i,k,it)=dx
+            ENDIF
+            d_tr_ls(i,k,it)=tr_seri(i,k,it)*(frac_impa(i,k)*frac_nucl(i,k)-1.) &
+                            +d_tr_evapls(i,k,it)
+
+!--------------
+                 d_tr_lessi_nucl(i,k,it) = d_tr_lessi_nucl(i,k,it) +    &
+                      ( 1 - frac_nucl(i,k) )*tr_seri(i,k,it)
+                 d_tr_lessi_impa(i,k,it) = d_tr_lessi_impa(i,k,it) +    &
+                      ( 1 - frac_impa(i,k) )*tr_seri(i,k,it)
+!
+! Flux lessivage total 
+                 flestottr(i,k,it) = flestottr(i,k,it) -   &
+                      ( d_tr_lessi_nucl(i,k,it)   +        &
+                      d_tr_lessi_impa(i,k,it) ) *          &
+                      ( paprs(i,k)-paprs(i,k+1) ) /        &
+                      (RG * pdtphys)
+!! Mise a jour des traceurs due a l'impaction,nucleation 
+!                 tr_seri(i,k,it)=tr_seri(i,k,it)*frac_impa(i,k)*frac_nucl(i,k)
+!!  calcul de la tendance liee au lessivage stratiforme
+!                 d_tr_ls(i,k,it)=tr_seri(i,k,it)*&
+!                                (1.-1./(frac_impa(i,k)*frac_nucl(i,k)))
+!--------------
+              END DO
+           END DO
+        END IF
+     END DO
+! *********   end modified old version
+
+ ELSE IF (iflag_lscav .EQ. 1) THEN ! frac_impa, frac_nucl
+! *********    old version
+
+     d_tr_lessi_nucl(:,:,:) = 0. 
+     d_tr_lessi_impa(:,:,:) = 0.
+     flestottr(:,:,:) = 0. 
+!=========================
+! LESSIVAGE LARGE SCALE : 
+!=========================
+
+! Tendance des aerosols nuclees et impactes 
+! -----------------------------------------
+     DO it = 1, nbtr
+        IF (aerosol(it)) THEN
+           DO k = 1, klev
+              DO i = 1, klon
+                 d_tr_lessi_nucl(i,k,it) = d_tr_lessi_nucl(i,k,it) +    &
+                      ( 1 - frac_nucl(i,k) )*tr_seri(i,k,it)
+                 d_tr_lessi_impa(i,k,it) = d_tr_lessi_impa(i,k,it) +    &
+                      ( 1 - frac_impa(i,k) )*tr_seri(i,k,it)
+
+!
+! Flux lessivage total 
+! ------------------------------------------------------------
+                 flestottr(i,k,it) = flestottr(i,k,it) -   &
+                      ( d_tr_lessi_nucl(i,k,it)   +        &
+                      d_tr_lessi_impa(i,k,it) ) *          &
+                      ( paprs(i,k)-paprs(i,k+1) ) /        &
+                      (RG * pdtphys)
+!
+! Mise a jour des traceurs due a l'impaction,nucleation 
+! ----------------------------------------------------------------------
+                 tr_seri(i,k,it)=tr_seri(i,k,it)*frac_impa(i,k)*frac_nucl(i,k)
+              END DO
+           END DO
+        END IF
+     END DO
+     
+! *********   end old version
+  ENDIF  !  iflag_lscav . EQ. 1, 2, 3 or 4
+!
+  END IF !  lessivage
+
+!=============================================================
+!   Ecriture des sorties
+!=============================================================
+#ifdef CPP_IOIPSL
+  INCLUDE "write_histrac.h"
+#endif
+
+END SUBROUTINE phytrac
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/planete.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/planete.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/planete.h	(revision 17)
@@ -0,0 +1,13 @@
+!c-----------------------------------------------------------------------
+!c INCLUDE planet.h
+
+      COMMON/planet/aphelie,periheli,year_day,peri_day,                 &
+     &       obliquit,                                                  &
+     &       timeperi,e_elips,p_elips,unitastr
+
+      REAL aphelie,periheli,year_day,peri_day,                          &
+     &     obliquit,                                                    &
+     &       timeperi,e_elips,p_elips,unitastr
+
+!c-----------------------------------------------------------------------
+!$OMP THREADPRIVATE(/planet/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/plevel.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/plevel.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/plevel.F	(revision 17)
@@ -0,0 +1,132 @@
+!
+! $Header$
+!
+c================================================================
+c================================================================
+      SUBROUTINE plevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
+c================================================================
+c================================================================
+      USE netcdf
+      USE dimphy
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cy#include "dimphy.h"
+
+c================================================================
+c
+c Interpoler des champs 3-D u, v et g du modele a un niveau de
+c pression donnee (pres)
+c
+c INPUT:  ilon ----- nombre de points
+c         ilev ----- nombre de couches
+c         lnew ----- true si on doit reinitialiser les poids
+c         pgcm ----- pressions modeles
+c         pres ----- pression vers laquelle on interpolle
+c         Qgcm ----- champ GCM
+c         Qpres ---- champ interpolle au niveau pres
+c
+c================================================================
+c
+c   arguments :
+c   -----------
+
+      INTEGER ilon, ilev
+      logical lnew
+
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres
+      REAL Qpres(ilon)
+
+c   local :
+c   -------
+
+cym      INTEGER lt(klon), lb(klon)
+cym      REAL ptop, pbot, aist(klon), aisb(klon)
+
+cym      save lt,lb,ptop,pbot,aist,aisb
+      INTEGER,ALLOCATABLE,SAVE,DIMENSION(:) :: lt,lb
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: aist,aisb
+c$OMP THREADPRIVATE(lt,lb,aist,aisb)      
+      REAL,SAVE :: ptop, pbot
+c$OMP THREADPRIVATE(ptop, pbot)      
+      LOGICAL,SAVE :: first = .true.
+c$OMP THREADPRIVATE(first)
+      INTEGER i, k
+c
+      REAL missing_val
+c
+      missing_val=nf90_fill_real
+c
+      if (first) then
+        allocate(lt(klon),lb(klon),aist(klon),aisb(klon))
+	first=.false.
+      endif
+      
+c=====================================================================
+      if (lnew) then
+c   on rï¿œnitialise les rï¿œndicages et les poids
+c=====================================================================
+
+
+c Chercher les 2 couches les plus proches du niveau a obtenir
+c
+c Eventuellement, faire l'extrapolation a partir des deux couches
+c les plus basses ou les deux couches les plus hautes:
+      DO 130 i = 1, klon
+         IF ( ABS(pres-pgcm(i,ilev) ) .LT.
+     .        ABS(pres-pgcm(i,1)) ) THEN
+            lt(i) = ilev     ! 2
+            lb(i) = ilev-1   ! 1
+         ELSE
+            lt(i) = 2
+            lb(i) = 1
+         ENDIF
+  130 CONTINUE
+      DO 150 k = 1, ilev-1
+         DO 140 i = 1, klon
+            pbot = pgcm(i,k)
+            ptop = pgcm(i,k+1)
+            IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
+               lt(i) = k+1
+               lb(i) = k
+            ENDIF
+  140    CONTINUE
+  150 CONTINUE
+c
+c Interpolation lineaire:
+c
+      DO i = 1, klon
+c interpolation en logarithme de pression:
+c
+c ...   Modif . P. Le Van    ( 20/01/98) ....
+c       Modif Frï¿œï¿œic Hourdin (3/01/02)
+
+        aist(i) = LOG( pgcm(i,lb(i))/ pres )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
+        aisb(i) = LOG( pres / pgcm(i,lt(i)) )
+     .       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
+      enddo
+
+
+      endif ! lnew
+
+c======================================================================
+c    inteprollation
+c======================================================================
+
+      do i=1,klon
+         Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
+      enddo
+c
+c Je mets les vents a zero quand je rencontre une montagne
+      do i = 1, klon
+         if (pgcm(i,1).LT.pres) THEN
+            Qpres(i)=missing_val
+         endif
+      enddo
+
+c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/plevel.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/plevel.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/plevel.F90	(revision 17)
@@ -0,0 +1,132 @@
+!
+! $Header$
+!
+!c================================================================
+!c================================================================
+      SUBROUTINE plevel(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres)
+!c================================================================
+!c================================================================
+      USE netcdf
+      USE dimphy
+      IMPLICIT none
+
+!cym#include "dimensions.h"
+!cy#include "dimphy.h"
+
+!c================================================================
+!c
+!c Interpoler des champs 3-D u, v et g du modele a un niveau de
+!c pression donnee (pres)
+!c
+!c INPUT:  ilon ----- nombre de points
+!c         ilev ----- nombre de couches
+!c         lnew ----- true si on doit reinitialiser les poids
+!c         pgcm ----- pressions modeles
+!c         pres ----- pression vers laquelle on interpolle
+!c         Qgcm ----- champ GCM
+!c         Qpres ---- champ interpolle au niveau pres
+!c
+!c================================================================
+!c
+!c   arguments :
+!c   -----------
+
+      INTEGER ilon, ilev
+      logical lnew
+
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres
+      REAL Qpres(ilon)
+
+!c   local :
+!c   -------
+
+!cym      INTEGER lt(klon), lb(klon)
+!cym      REAL ptop, pbot, aist(klon), aisb(klon)
+
+!cym      save lt,lb,ptop,pbot,aist,aisb
+      INTEGER,ALLOCATABLE,SAVE,DIMENSION(:) :: lt,lb
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: aist,aisb
+!$OMP THREADPRIVATE(lt,lb,aist,aisb)      
+      REAL,SAVE :: ptop, pbot
+!$OMP THREADPRIVATE(ptop, pbot)      
+      LOGICAL,SAVE :: first = .true.
+!$OMP THREADPRIVATE(first)
+      INTEGER i, k
+!c
+      REAL missing_val
+!c
+      missing_val=nf90_fill_real
+!c
+      if (first) then
+        allocate(lt(klon),lb(klon),aist(klon),aisb(klon))
+	first=.false.
+      endif
+      
+!c=====================================================================
+      if (lnew) then
+!c   on rinitialise les rindicages et les poids
+!c=====================================================================
+
+
+!c Chercher les 2 couches les plus proches du niveau a obtenir
+!c
+!c Eventuellement, faire l'extrapolation a partir des deux couches
+!c les plus basses ou les deux couches les plus hautes:
+      DO 130 i = 1, klon
+         IF ( ABS(pres-pgcm(i,ilev) ) .LT.                                           &
+       &        ABS(pres-pgcm(i,1)) ) THEN
+            lt(i) = ilev     ! 2
+            lb(i) = ilev-1   ! 1
+         ELSE
+            lt(i) = 2
+            lb(i) = 1
+         ENDIF
+  130 CONTINUE
+      DO 150 k = 1, ilev-1
+         DO 140 i = 1, klon
+            pbot = pgcm(i,k)
+            ptop = pgcm(i,k+1)
+            IF (ptop.LE.pres .AND. pbot.GE.pres) THEN
+               lt(i) = k+1
+               lb(i) = k
+            ENDIF
+  140    CONTINUE
+  150 CONTINUE
+!c
+!c Interpolation lineaire:
+!c
+      DO i = 1, klon
+!c interpolation en logarithme de pression:
+!c
+!c ...   Modif . P. Le Van    ( 20/01/98) ....
+!c       Modif Frederic Hourdin (3/01/02)
+
+        aist(i) = LOG( pgcm(i,lb(i))/ pres )                                         &
+       &       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) )
+        aisb(i) = LOG( pres / pgcm(i,lt(i)) )                                        &
+       &       / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)))
+      enddo
+
+
+      endif ! lnew
+
+!c======================================================================
+!c    inteprollation
+!c======================================================================
+
+      do i=1,klon
+         Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i)
+      enddo
+!c
+!c Je mets les vents a zero quand je rencontre une montagne
+      do i = 1, klon
+         if (pgcm(i,1).LT.pres) THEN
+            Qpres(i)=missing_val
+         endif
+      enddo
+
+!c
+      RETURN
+      END SUBROUTINE plevel
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/plevel_new.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/plevel_new.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/plevel_new.F	(revision 17)
@@ -0,0 +1,138 @@
+!
+! $Header: /home/cvsroot/LMDZ4/libf/phylmd/plevel.F,v 1.1.1.1.10.1 2006/08/17 15:41:51 fairhead Exp $
+!
+c================================================================
+c================================================================
+      SUBROUTINE plevel_new(ilon,ilev,klevSTD,lnew,pgcm,pres,Qgcm,Qpres)
+c================================================================
+c================================================================
+      USE netcdf
+      USE dimphy
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cy#include "dimphy.h"
+
+c================================================================
+c
+c Interpoler des champs 3-D u, v et g du modele a un niveau de
+c pression donnee (pres)
+c
+c INPUT:  ilon ----- nombre de points
+c         ilev ----- nombre de couches
+c         lnew ----- true si on doit reinitialiser les poids
+c         pgcm ----- pressions modeles
+c         pres ----- pression vers laquelle on interpolle
+c         Qgcm ----- champ GCM
+c         Qpres ---- champ interpolle au niveau pres
+c
+c================================================================
+c
+c   arguments :
+c   -----------
+
+      INTEGER ilon, ilev, klevSTD
+      logical lnew
+      
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres(klevSTD)
+      REAL Qpres(ilon, klevSTD)
+
+c   local :
+c   -------
+
+cym      INTEGER lt(klon), lb(klon)
+cym      REAL ptop, pbot, aist(klon), aisb(klon)
+
+cym      save lt,lb,ptop,pbot,aist,aisb
+      INTEGER,ALLOCATABLE,SAVE,DIMENSION(:,:) :: lt,lb
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: aist,aisb
+c$OMP THREADPRIVATE(lt,lb,aist,aisb)      
+      REAL,SAVE :: ptop, pbot
+c$OMP THREADPRIVATE(ptop, pbot)      
+      LOGICAL,SAVE :: first = .true.
+      INTEGER :: nlev
+c$OMP THREADPRIVATE(first)
+      INTEGER i, k
+c
+      REAL missing_val
+c
+      missing_val=nf90_fill_real
+c
+      if (first) then
+         allocate(lt(klon,klevSTD),lb(klon,klevSTD))
+         allocate(aist(klon,klevSTD),aisb(klon, klevSTD))
+         first=.false.
+      endif
+      
+c=====================================================================
+      if (lnew) then
+c   on reinitialise les reindicages et les poids
+c=====================================================================
+
+
+c Chercher les 2 couches les plus proches du niveau a obtenir
+c
+c Eventuellement, faire l'extrapolation a partir des deux couches
+c les plus basses ou les deux couches les plus hautes:
+c
+c
+         DO nlev = 1, klevSTD
+            DO i = 1, klon
+               IF ( ABS(pres(nlev)-pgcm(i,ilev) ) .LT.
+     &              ABS(pres(nlev)-pgcm(i,1)) ) THEN
+                  lt(i,nlev) = ilev  ! 2
+                  lb(i,nlev) = ilev-1 ! 1
+               ELSE
+                  lt(i,nlev) = 2
+                  lb(i,nlev) = 1
+               ENDIF
+            ENDDO
+            DO k = 1, ilev-1
+               DO i = 1, klon
+                  pbot = pgcm(i,k)
+                  ptop = pgcm(i,k+1)
+                  IF (ptop.LE.pres(nlev) .AND. pbot.GE.pres(nlev)) THEN
+                     lt(i,nlev) = k+1
+                     lb(i,nlev) = k
+                  ENDIF
+               ENDDO
+            ENDDO
+            
+c     Interpolation lineaire:
+            DO i = 1, klon
+c     interpolation en logarithme de pression:
+c     
+c     ...   Modif . P. Le Van    ( 20/01/98) ....
+c     Modif Frederic Hourdin (3/01/02)
+
+               aist(i,nlev) = LOG( pgcm(i,lb(i,nlev))/ pres(nlev) )
+     &              / LOG( pgcm(i,lb(i,nlev))/ pgcm(i,lt(i,nlev)) )
+               aisb(i,nlev) = LOG( pres(nlev) / pgcm(i,lt(i,nlev)) )
+     &              / LOG( pgcm(i,lb(i,nlev))/ pgcm(i,lt(i,nlev)))
+            ENDDO
+         ENDDO
+
+      ENDIF ! lnew
+
+c======================================================================
+c    inteprollation
+c    ET je mets les vents a zero quand je rencontre une montagne
+c======================================================================
+
+      DO nlev = 1, klevSTD
+         DO i=1,klon
+            IF (pgcm(i,1).LT.pres(nlev)) THEN
+               Qpres(i,nlev) = missing_val
+            ELSE
+               Qpres(i,nlev) = 
+     &              Qgcm(i,lb(i,nlev))*aisb(i,nlev) +
+     &              Qgcm(i,lt(i,nlev))*aist(i,nlev)
+            ENDIF
+         ENDDO
+      ENDDO
+
+c     
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/plevel_new.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/plevel_new.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/plevel_new.F90	(revision 17)
@@ -0,0 +1,138 @@
+!
+! $Header: /home/cvsroot/LMDZ4/libf/phylmd/plevel.F,v 1.1.1.1.10.1 2006/08/17 15:41:51 fairhead Exp $
+!
+!c================================================================
+!c================================================================
+      SUBROUTINE plevel_new(ilon,ilev,klevSTD,lnew,pgcm,pres,Qgcm,Qpres)
+!c================================================================
+!c================================================================
+      USE netcdf
+      USE dimphy
+      IMPLICIT none
+
+!cym#include "dimensions.h"
+!cy#include "dimphy.h"
+
+!c================================================================
+!c
+!c Interpoler des champs 3-D u, v et g du modele a un niveau de
+!c pression donnee (pres)
+!c
+!c INPUT:  ilon ----- nombre de points
+!c         ilev ----- nombre de couches
+!c         lnew ----- true si on doit reinitialiser les poids
+!c         pgcm ----- pressions modeles
+!c         pres ----- pression vers laquelle on interpolle
+!c         Qgcm ----- champ GCM
+!c         Qpres ---- champ interpolle au niveau pres
+!c
+!c================================================================
+!c
+!c   arguments :
+!c   -----------
+
+      INTEGER ilon, ilev, klevSTD
+      logical lnew
+      
+      REAL pgcm(ilon,ilev)
+      REAL Qgcm(ilon,ilev)
+      real pres(klevSTD)
+      REAL Qpres(ilon, klevSTD)
+
+!c   local :
+!c   -------
+
+!cym      INTEGER lt(klon), lb(klon)
+!cym      REAL ptop, pbot, aist(klon), aisb(klon)
+
+!cym      save lt,lb,ptop,pbot,aist,aisb
+      INTEGER,ALLOCATABLE,SAVE,DIMENSION(:,:) :: lt,lb
+      REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: aist,aisb
+!$OMP THREADPRIVATE(lt,lb,aist,aisb)      
+      REAL,SAVE :: ptop, pbot
+!$OMP THREADPRIVATE(ptop, pbot)      
+      LOGICAL,SAVE :: first = .true.
+      INTEGER :: nlev
+!$OMP THREADPRIVATE(first)
+      INTEGER i, k
+!c
+      REAL missing_val
+!c
+      missing_val=nf90_fill_real
+!c
+      if (first) then
+         allocate(lt(klon,klevSTD),lb(klon,klevSTD))
+         allocate(aist(klon,klevSTD),aisb(klon, klevSTD))
+         first=.false.
+      endif
+      
+!c=====================================================================
+      if (lnew) then
+!c   on reinitialise les reindicages et les poids
+!c=====================================================================
+
+
+!c Chercher les 2 couches les plus proches du niveau a obtenir
+!c
+!c Eventuellement, faire l'extrapolation a partir des deux couches
+!c les plus basses ou les deux couches les plus hautes:
+!c
+!c
+         DO nlev = 1, klevSTD
+            DO i = 1, klon
+               IF ( ABS(pres(nlev)-pgcm(i,ilev) ) .LT.                               &
+       &              ABS(pres(nlev)-pgcm(i,1)) ) THEN
+                  lt(i,nlev) = ilev  ! 2
+                  lb(i,nlev) = ilev-1 ! 1
+               ELSE
+                  lt(i,nlev) = 2
+                  lb(i,nlev) = 1
+               ENDIF
+            ENDDO
+            DO k = 1, ilev-1
+               DO i = 1, klon
+                  pbot = pgcm(i,k)
+                  ptop = pgcm(i,k+1)
+                  IF (ptop.LE.pres(nlev) .AND. pbot.GE.pres(nlev)) THEN
+                     lt(i,nlev) = k+1
+                     lb(i,nlev) = k
+                  ENDIF
+               ENDDO
+            ENDDO
+            
+!c     Interpolation lineaire:
+            DO i = 1, klon
+!c     interpolation en logarithme de pression:
+!c     
+!c     ...   Modif . P. Le Van    ( 20/01/98) ....
+!c     Modif Frederic Hourdin (3/01/02)
+
+               aist(i,nlev) = LOG( pgcm(i,lb(i,nlev))/ pres(nlev) )                  &
+       &              / LOG( pgcm(i,lb(i,nlev))/ pgcm(i,lt(i,nlev)) )
+               aisb(i,nlev) = LOG( pres(nlev) / pgcm(i,lt(i,nlev)) )                 &
+       &              / LOG( pgcm(i,lb(i,nlev))/ pgcm(i,lt(i,nlev)))
+            ENDDO
+         ENDDO
+
+      ENDIF ! lnew
+
+!c======================================================================
+!c    inteprollation
+!c    ET je mets les vents a zero quand je rencontre une montagne
+!c======================================================================
+
+      DO nlev = 1, klevSTD
+         DO i=1,klon
+            IF (pgcm(i,1).LT.pres(nlev)) THEN
+               Qpres(i,nlev) = missing_val
+            ELSE
+               Qpres(i,nlev) =                                                       &
+       &              Qgcm(i,lb(i,nlev))*aisb(i,nlev) +                              &
+       &              Qgcm(i,lt(i,nlev))*aist(i,nlev)
+            ENDIF
+         ENDDO
+      ENDDO
+
+!c     
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/pres2lev_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/pres2lev_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/pres2lev_mod.F90	(revision 17)
@@ -0,0 +1,80 @@
+! $Id: pres2lev.F 1179 2009-06-11 14:18:47Z jghattas $
+!
+MODULE pres2lev_mod
+
+CONTAINS 
+
+!******************************************************
+SUBROUTINE pres2lev(varo,varn,lmo,lmn,po,pn,ni,nj,ok_invertp)
+!
+! interpolation lineaire pour passer
+! a une nouvelle discretisation verticale pour
+! les variables de GCM
+! Francois Forget (01/1995)
+! MOdif remy roca 12/97 pour passer de pres2sig
+! Modif F.Codron 07/08 po en 3D
+!**********************************************************
+
+  IMPLICIT NONE
+
+!   Declarations:
+! ==============
+!
+!  ARGUMENTS
+!  """""""""
+  LOGICAL, INTENT(IN) :: ok_invertp
+  INTEGER, INTENT(IN) :: lmo ! dimensions ancienne couches
+  INTEGER, INTENT(IN) :: lmn ! dimensions nouvelle couches
+  
+  REAL, INTENT(IN) :: po(ni*nj,lmo) ! niveau de pression ancienne grille
+  REAL, INTENT(IN) :: pn(ni*nj,lmn) ! niveau de pression nouvelle grille
+
+  INTEGER, INTENT(IN) :: ni,nj ! nombre de point horizontal
+
+  REAL, INTENT(IN)  :: varo(ni*nj,lmo) ! var dans l'ancienne grille
+  REAL, INTENT(OUT) :: varn(ni*nj,lmn) ! var dans la nouvelle grille
+
+  REAL :: zvaro(ni*nj,lmo),zpo(ni*nj,lmo)
+
+! Autres variables
+! """"""""""""""""
+  INTEGER ::  ln ,lo, k
+  REAL    :: coef
+
+
+! Inversion de l'ordre des niveaux verticaux
+  IF (ok_invertp) THEN
+    DO lo=1,lmo
+      DO k=1,ni*nj
+        zpo(k,lo)=po(k,lmo+1-lo)
+        zvaro(k,lo)=varo(k,lmo+1-lo)
+      ENDDO
+    ENDDO
+  ELSE
+    DO lo=1,lmo
+      DO k=1,ni*nj
+        zpo(k,lo)=po(k,lo)
+        zvaro(k,lo)=varo(k,lo)
+      ENDDO
+    ENDDO
+  ENDIF 
+
+  DO ln=1,lmn
+    DO lo=1,lmo-1
+      DO k=1,ni*nj
+        IF (pn(k,ln) >= zpo(k,1) ) THEN
+          varn(k,ln) = zvaro(k,1)
+        ELSE IF (pn(k,ln) <= zpo(k,lmo)) THEN
+          varn(k,ln) = zvaro(k,lmo)
+        ELSE IF ( pn(k,ln) <= zpo(k,lo) .AND. pn(k,ln) > zpo(k,lo+1) ) THEN
+          coef = (pn(k,ln)-zpo(k,lo)) / (zpo(k,lo+1)-zpo(k,lo))
+          varn(k,ln) = zvaro(k,lo) + coef*(zvaro(k,lo+1)-zvaro(k,lo))
+        ENDIF
+         
+      ENDDO  
+    ENDDO
+  ENDDO                
+
+END SUBROUTINE pres2lev    
+
+END MODULE pres2lev_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/press_coefoz_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/press_coefoz_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/press_coefoz_m.F90	(revision 17)
@@ -0,0 +1,74 @@
+! $Id$
+module press_coefoz_m
+
+  implicit none
+
+  real, pointer, save:: plev(:)
+  ! (pressure level of Mobidic input data, converted to Pa, in strictly
+  ! ascending order)
+
+  real, allocatable, save:: press_in_edg(:)
+  ! (edges of pressure intervals for Mobidic input data, in Pa, in strictly
+  ! ascending order)
+
+contains
+
+  subroutine press_coefoz
+
+    ! This procedure is called once per "gcm" run.
+    ! A single thread of the root process reads the pressure levels
+    ! from "coefoz_LMDZ.nc" and broadcasts them to the other processes.
+
+    ! We assume that, in "coefoz_LMDZ.nc", the pressure levels are in hPa
+    ! and in strictly ascending order.
+
+    use netcdf95, only: nf95_open, nf95_close, nf95_gw_var, nf95_inq_varid
+    use netcdf, only: nf90_nowrite
+
+    use mod_phys_lmdz_mpi_data, only: is_mpi_root
+    use mod_phys_lmdz_mpi_transfert, only: bcast_mpi ! broadcast
+
+    ! Variables local to the procedure:
+    integer ncid, varid ! for NetCDF
+    integer n_plev ! number of pressure levels in the input data
+    integer k
+
+    !---------------------------------------
+
+    !$omp single
+    print *, "Call sequence information: press_coefoz"
+
+    if (is_mpi_root) then
+       call nf95_open("coefoz_LMDZ.nc", nf90_nowrite, ncid)
+
+       call nf95_inq_varid(ncid, "plev", varid)
+       call nf95_gw_var(ncid, varid, plev)
+       ! Convert from hPa to Pa because "paprs" and "pplay" are in Pa:
+       plev = plev * 100.
+       n_plev = size(plev)
+
+       call nf95_close(ncid)
+    end if
+
+    call bcast_mpi(n_plev)
+    if (.not. is_mpi_root) allocate(plev(n_plev))
+    call bcast_mpi(plev)
+    
+    ! Compute edges of pressure intervals:
+    allocate(press_in_edg(n_plev + 1))
+    if (is_mpi_root) then
+       press_in_edg(1) = 0.
+       ! We choose edges halfway in logarithm:
+       DO k = 2,n_plev
+          press_in_edg(k) = SQRT(plev(k - 1) * plev(k))
+       ENDDO
+       press_in_edg(n_plev + 1) = huge(0.)
+       ! (infinity, but any value guaranteed to be greater than the
+       ! surface pressure would do)
+    end if
+    call bcast_mpi(press_in_edg)
+    !$omp end single
+
+  end subroutine press_coefoz
+
+end module press_coefoz_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/print_debug_phys.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/print_debug_phys.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/print_debug_phys.F90	(revision 17)
@@ -0,0 +1,20 @@
+SUBROUTINE print_debug_phys (i,debug_lev,text)
+
+use dimphy
+use phys_local_var_mod
+use phys_state_var_mod
+IMPLICIT NONE
+integer i,debug_lev
+CHARACTER*(*) text
+
+
+integer k
+
+print*,'PLANTAGE POUR LE POINT i=',i,text
+print*,'l    u, v, T, q, ql'
+DO k = 1, klev
+   write(*,'(i3,2f8.4,3f14.4,2e14.2)') k,rlon(i),rlat(i),u_seri(i,k),v_seri(i,k),t_seri(i,k),q_seri(i,k),ql_seri(i,k)
+ENDDO
+
+RETURN
+END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/printflag.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/printflag.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/printflag.F	(revision 17)
@@ -0,0 +1,183 @@
+!
+! $Header$
+!
+       SUBROUTINE  printflag( tabcntr0, radpas, 
+     ,                        ok_journe,ok_instan,ok_region        )
+c
+
+c
+c      Auteur :  P. Le Van 
+
+       IMPLICIT NONE
+
+       REAL tabcntr0( 100 )
+       LOGICAL cycle_diurn0,soil_model0,new_oliq0,ok_orodr0
+       LOGICAL ok_orolf0,ok_limitvr0
+       LOGICAL ok_journe,ok_instan,ok_region
+       INTEGER radpas , radpas0
+c
+#include "clesphys.h"
+c
+c
+       PRINT 100
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT *,' ********   Choix  des principales  cles de la physique 
+     ,   *********'
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT 100
+       PRINT 10, cycle_diurne,  soil_model  
+       PRINT 100
+
+       IF   (    iflag_con.EQ. 1 )   THEN
+           PRINT *,' *****           Shema  convection   LMD            
+     ,          ******'
+       ELSE IF ( iflag_con.EQ. 2 )   THEN
+           PRINT *,' *****           Shema  convection  Tiedtke  
+     ,          ******'
+       ELSE IF ( iflag_con.GE. 3 )   THEN
+           PRINT *,' *****           Shema  convection    Emanuel      
+     ,          ******'
+       ENDIF
+       PRINT 100
+
+       PRINT 11, new_oliq, ok_orodr, ok_orolf   
+       PRINT 100
+
+       PRINT 7,  ok_limitvrai   
+       PRINT 100
+
+       PRINT 12, nbapp_rad
+       PRINT 100
+
+       PRINT 8, radpas
+       PRINT 100
+
+       PRINT 4,ok_journe,ok_instan,ok_region
+       PRINT 100
+       PRINT 100
+c
+c
+        cycle_diurn0  = .FALSE.
+        soil_model0   = .FALSE.
+        new_oliq0     = .FALSE.
+        ok_orodr0     = .FALSE.
+        ok_orolf0     = .FALSE.
+        ok_limitvr0   = .FALSE.
+
+        IF( tabcntr0( 7 ).EQ. 1. )   cycle_diurn0 = .TRUE.
+        IF( tabcntr0( 8 ).EQ. 1. )    soil_model0 = .TRUE.
+        IF( tabcntr0( 9 ).EQ. 1. )      new_oliq0 = .TRUE.
+        IF( tabcntr0(10 ).EQ. 1. )      ok_orodr0 = .TRUE.
+        IF( tabcntr0(11 ).EQ. 1. )      ok_orolf0 = .TRUE.
+        IF( tabcntr0(12 ).EQ. 1. )    ok_limitvr0 = .TRUE.
+
+        PRINT *,' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+     ,$$$$$$$$$$$$$'
+        PRINT 100
+c
+       IF( INT( tabcntr0( 5 ) ) .NE. iflag_con  )   THEN
+        PRINT 20, INT(tabcntr0(5)), iflag_con
+        PRINT 100
+       ENDIF
+
+       IF( INT( tabcntr0( 6 ) ) .NE. nbapp_rad  )   THEN
+        PRINT 21,  INT(tabcntr0(6)), nbapp_rad
+!        radpas0  = NINT( 86400./tabcntr0(1)/INT( tabcntr0(6) ) )
+        PRINT 100
+!        PRINT 22, radpas0, radpas
+        PRINT 100
+       ENDIF
+
+       IF( cycle_diurn0.AND..NOT.cycle_diurne.OR..NOT.cycle_diurn0.AND.
+     ,        cycle_diurne )     THEN
+        PRINT 13, cycle_diurn0, cycle_diurne
+        PRINT 100
+       ENDIF
+
+       IF( soil_model0.AND..NOT.soil_model.OR..NOT.soil_model0.AND.
+     ,        soil_model )     THEN
+        PRINT 14, soil_model0, soil_model
+        PRINT 100
+       ENDIF
+
+       IF( new_oliq0.AND..NOT.new_oliq.OR..NOT.new_oliq0.AND.
+     ,        new_oliq )     THEN
+        PRINT 16, new_oliq0, new_oliq
+        PRINT 100
+       ENDIF
+
+       IF( ok_orodr0.AND..NOT.ok_orodr.OR..NOT.ok_orodr0.AND.
+     ,        ok_orodr )     THEN
+        PRINT 15, ok_orodr0, ok_orodr
+        PRINT 100
+       ENDIF
+
+       IF( ok_orolf0.AND..NOT.ok_orolf.OR..NOT.ok_orolf0.AND.
+     ,        ok_orolf )     THEN
+        PRINT 17, ok_orolf0, ok_orolf
+        PRINT 100
+       ENDIF
+
+       IF( ok_limitvr0.AND..NOT.ok_limitvrai.OR..NOT.ok_limitvr0.
+     ,     AND.ok_limitvrai )     THEN
+        PRINT 18, ok_limitvr0, ok_limitvrai
+        PRINT 100
+       ENDIF
+
+       PRINT 100
+       PRINT *,' *******************************************************
+     ,************'
+       PRINT 100
+
+ 4    FORMAT(2x,5("*"),'  ok_journe= ',l3,3x,',ok_instan = ',
+     , l3,3x,',ok_region = ',l3,3x,5("*") )
+
+ 7     FORMAT(2x,5("*"),15x,'      ok_limitvrai   = ',l3,16x,5("*") )
+
+ 8     FORMAT(2x,'*****             radpas    =                      ' ,
+     , i4,6x,' *****')
+
+ 10    FORMAT(2x,5("*"),'    Cycle_diurne = ',l3,4x,', Soil_model = ',
+     , l3,12x,6("*") )
+
+
+ 11    FORMAT(2x,5("*"),'  new_oliq = ',l3,3x,', Ok_orodr = ',
+     , l3,3x,', Ok_orolf = ',l3,3x,5("*") )
+
+
+ 12    FORMAT(2x,'*****  Nb d appels /jour des routines de rayonn. = ' ,
+     , i4,6x,' *****')
+
+ 13    FORMAT(2x,'$$$$$$$$   Attention !!  cycle_diurne  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 14    FORMAT(2x,'$$$$$$$$   Attention !!    soil_model  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 15    FORMAT(2x,'$$$$$$$$   Attention !!      ok_orodr  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 16    FORMAT(2x,'$$$$$$$$   Attention !!      new_oliq  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 17    FORMAT(2x,'$$$$$$$$   Attention !!      ok_orolf  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 18    FORMAT(2x,'$$$$$$$$   Attention !!  ok_limitvrai  different  sur',
+     , /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 20    FORMAT(/2x,'$$$$$$$$   Attention !!    iflag_con  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 21    FORMAT(2x,'$$$$$$$$   Attention !!     nbapp_rad  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 22    FORMAT(2x,'$$$$$$$$   Attention !!        radpas  different  sur',
+     , /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 100   FORMAT(/)
+
+       RETURN
+       END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/printflag.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/printflag.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/printflag.F90	(revision 17)
@@ -0,0 +1,183 @@
+!
+! $Header$
+!
+       SUBROUTINE  printflag( tabcntr0, radpas,                                      &
+       &                        ok_journe,ok_instan,ok_region        )
+!c
+
+!c
+!c      Auteur :  P. Le Van 
+
+       IMPLICIT NONE
+
+       REAL tabcntr0( 100 )
+       LOGICAL cycle_diurn0,soil_model0,new_oliq0,ok_orodr0
+       LOGICAL ok_orolf0,ok_limitvr0
+       LOGICAL ok_journe,ok_instan,ok_region
+       INTEGER radpas , radpas0
+!c
+#include "clesphys.h"
+!c
+!c
+       PRINT 100
+       PRINT *,' *******************************************************' //         &
+       &'************'
+       PRINT *,' ********   Choix  des principales  cles de la physique ' //         &
+       &   '*********'
+       PRINT *,' *******************************************************' //         &
+       &'************'
+       PRINT 100
+       PRINT 10, cycle_diurne,  soil_model  
+       PRINT 100
+
+       IF   (    iflag_con.EQ. 1 )   THEN
+           PRINT *,' *****           Shema  convection   LMD                        '&
+       &//'           ******'
+       ELSE IF ( iflag_con.EQ. 2 )   THEN
+           PRINT *,' *****           Shema  convection  Tiedtke                     '&
+       &//'           ******'
+       ELSE IF ( iflag_con.GE. 3 )   THEN
+           PRINT *,' *****           Shema  convection    Emanuel                   '&
+       &//'           ******'
+       ENDIF
+       PRINT 100
+
+       PRINT 11, new_oliq, ok_orodr, ok_orolf   
+       PRINT 100
+
+       PRINT 7,  ok_limitvrai   
+       PRINT 100
+
+       PRINT 12, nbapp_rad
+       PRINT 100
+
+       PRINT 8, radpas
+       PRINT 100
+
+       PRINT 4,ok_journe,ok_instan,ok_region
+       PRINT 100
+       PRINT 100
+!c
+!c
+        cycle_diurn0  = .FALSE.
+        soil_model0   = .FALSE.
+        new_oliq0     = .FALSE.
+        ok_orodr0     = .FALSE.
+        ok_orolf0     = .FALSE.
+        ok_limitvr0   = .FALSE.
+
+        IF( tabcntr0( 7 ).EQ. 1. )   cycle_diurn0 = .TRUE.
+        IF( tabcntr0( 8 ).EQ. 1. )    soil_model0 = .TRUE.
+        IF( tabcntr0( 9 ).EQ. 1. )      new_oliq0 = .TRUE.
+        IF( tabcntr0(10 ).EQ. 1. )      ok_orodr0 = .TRUE.
+        IF( tabcntr0(11 ).EQ. 1. )      ok_orolf0 = .TRUE.
+        IF( tabcntr0(12 ).EQ. 1. )    ok_limitvr0 = .TRUE.
+
+        PRINT *,' $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$'           &
+       &// '$$$$$$$$$$$$$'
+        PRINT 100
+!c
+       IF( INT( tabcntr0( 5 ) ) .NE. iflag_con  )   THEN
+        PRINT 20, INT(tabcntr0(5)), iflag_con
+        PRINT 100
+       ENDIF
+
+       IF( INT( tabcntr0( 6 ) ) .NE. nbapp_rad  )   THEN
+        PRINT 21,  INT(tabcntr0(6)), nbapp_rad
+!        radpas0  = NINT( 86400./tabcntr0(1)/INT( tabcntr0(6) ) )
+        PRINT 100
+!        PRINT 22, radpas0, radpas
+        PRINT 100
+       ENDIF
+
+       IF( cycle_diurn0.AND..NOT.cycle_diurne.OR..NOT.cycle_diurn0.AND.              &
+       &        cycle_diurne )     THEN
+        PRINT 13, cycle_diurn0, cycle_diurne
+        PRINT 100
+       ENDIF
+
+       IF( soil_model0.AND..NOT.soil_model.OR..NOT.soil_model0.AND.                  &
+       &        soil_model )     THEN
+        PRINT 14, soil_model0, soil_model
+        PRINT 100
+       ENDIF
+
+       IF( new_oliq0.AND..NOT.new_oliq.OR..NOT.new_oliq0.AND.                        &
+       &        new_oliq )     THEN
+        PRINT 16, new_oliq0, new_oliq
+        PRINT 100
+       ENDIF
+
+       IF( ok_orodr0.AND..NOT.ok_orodr.OR..NOT.ok_orodr0.AND.                        &
+       &        ok_orodr )     THEN
+        PRINT 15, ok_orodr0, ok_orodr
+        PRINT 100
+       ENDIF
+
+       IF( ok_orolf0.AND..NOT.ok_orolf.OR..NOT.ok_orolf0.AND.                        &
+       &        ok_orolf )     THEN
+        PRINT 17, ok_orolf0, ok_orolf
+        PRINT 100
+       ENDIF
+
+       IF( ok_limitvr0.AND..NOT.ok_limitvrai.OR..NOT.ok_limitvr0                     &
+       &     .AND.ok_limitvrai )     THEN
+        PRINT 18, ok_limitvr0, ok_limitvrai
+        PRINT 100
+       ENDIF
+
+       PRINT 100
+       PRINT *,' *******************************************************'//          &
+       &'************'
+       PRINT 100
+
+ 4    FORMAT(2x,5("*"),'  ok_journe= ',l3,3x,',ok_instan = ',                        &
+       & l3,3x,',ok_region = ',l3,3x,5("*") )
+
+ 7     FORMAT(2x,5("*"),15x,'      ok_limitvrai   = ',l3,16x,5("*") )
+
+ 8     FORMAT(2x,'*****             radpas    =                      ' ,             &
+       & i4,6x,' *****')
+
+ 10    FORMAT(2x,5("*"),'    Cycle_diurne = ',l3,4x,', Soil_model = ',               &
+       & l3,12x,6("*") )
+
+
+ 11    FORMAT(2x,5("*"),'  new_oliq = ',l3,3x,', Ok_orodr = ',                       &
+       & l3,3x,', Ok_orolf = ',l3,3x,5("*") )
+
+
+ 12    FORMAT(2x,'*****  Nb d appels /jour des routines de rayonn. = ' ,             &
+       & i4,6x,' *****')
+
+ 13    FORMAT(2x,'$$$$$$$$   Attention !!  cycle_diurne  different  sur',            &
+       & /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 14    FORMAT(2x,'$$$$$$$$   Attention !!    soil_model  different  sur',            &
+       & /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 15    FORMAT(2x,'$$$$$$$$   Attention !!      ok_orodr  different  sur',            &
+       & /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 16    FORMAT(2x,'$$$$$$$$   Attention !!      new_oliq  different  sur',            &
+       & /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 17    FORMAT(2x,'$$$$$$$$   Attention !!      ok_orolf  different  sur',            &
+       & /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 18    FORMAT(2x,'$$$$$$$$   Attention !!  ok_limitvrai  different  sur',            &
+       & /1x,10x,' startphy = ',l3,2x,' et  run.def = ',l3)
+
+ 20    FORMAT(/2x,'$$$$$$$$   Attention !!    iflag_con  different  sur',            &
+       & /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 21    FORMAT(2x,'$$$$$$$$   Attention !!     nbapp_rad  different  sur',            &
+       & /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 22    FORMAT(2x,'$$$$$$$$   Attention !!        radpas  different  sur',            &
+       & /1x,10x,' startphy = ',i3,2x,' et  run.def = ',i3 )
+
+ 100   FORMAT(/)
+
+       RETURN
+       END SUBROUTINE printflag
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/q_sat.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/q_sat.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/q_sat.F	(revision 17)
@@ -0,0 +1,72 @@
+!
+! $Header$
+!
+c
+c
+
+      subroutine q_sat(np,temp,pres,qsat)
+c
+      IMPLICIT none
+c======================================================================
+c Autheur(s): Z.X. Li (LMD/CNRS)
+c  reecriture vectorisee par F. Hourdin.
+c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
+c======================================================================
+c Arguments:
+c kelvin---input-R: temperature en Kelvin
+c millibar--input-R: pression en mb
+c
+c q_sat----output-R: vapeur d'eau saturante en kg/kg
+c======================================================================
+c
+      integer np
+      REAL temp(np),pres(np),qsat(np)
+c
+      REAL r2es
+      PARAMETER (r2es=611.14 *18.0153/28.9644)
+c
+      REAL r3les, r3ies, r3es
+      PARAMETER (R3LES=17.269)
+      PARAMETER (R3IES=21.875)
+c
+      REAL r4les, r4ies, r4es
+      PARAMETER (R4LES=35.86)
+      PARAMETER (R4IES=7.66)
+c
+      REAL rtt
+      PARAMETER (rtt=273.16)
+c
+      REAL retv
+      PARAMETER (retv=28.9644/18.0153 - 1.0)
+
+      real zqsat
+      integer ip
+c
+C     ------------------------------------------------------------------
+c
+c
+
+      do ip=1,np
+
+c      write(*,*)'kelvin,millibar=',kelvin,millibar
+c       write(*,*)'temp,pres=',temp(ip),pres(ip)
+c
+         IF (temp(ip) .LE. rtt) THEN
+            r3es = r3ies
+            r4es = r4ies
+         ELSE
+            r3es = r3les
+            r4es = r4les
+         ENDIF
+c
+         zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es))
+         zqsat=MIN(0.5,ZQSAT)
+         zqsat=zqsat/(1.-retv *zqsat)
+c
+         qsat(ip)= zqsat
+c      write(*,*)'qsat=',qsat(ip)
+
+      enddo
+c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/q_sat.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/q_sat.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/q_sat.F90	(revision 17)
@@ -0,0 +1,69 @@
+!
+! $Header$
+!
+!c
+!c
+
+      subroutine q_sat(np,temp,pres,qsat)
+!c
+      IMPLICIT none
+!c======================================================================
+!c Autheur(s): Z.X. Li (LMD/CNRS)
+!c  reecriture vectorisee par F. Hourdin.
+!c Objet: calculer la vapeur d'eau saturante (formule Centre Euro.)
+!c======================================================================
+!c Arguments:
+!c kelvin---input-R: temperature en Kelvin
+!c millibar--input-R: pression en mb
+!c
+!c q_sat----output-R: vapeur d'eau saturante en kg/kg
+!c======================================================================
+!c
+      integer np
+      REAL temp(np),pres(np),qsat(np)
+!c
+      REAL, PARAMETER                                    :: r2es=611.14 *18.0153/28.9644
+!c
+      REAL r3es
+      REAL, PARAMETER                                    :: R3LES=17.269
+      REAL, PARAMETER                                    :: R3IES=21.875
+!c
+      REAL r4es
+      REAL, PARAMETER                                    :: R4LES=35.86
+      REAL, PARAMETER                                    :: R4IES=7.66
+!c
+      REAL, PARAMETER                                    :: rtt=273.16
+!c
+      REAL, PARAMETER                                    :: retv=28.9644/18.0153 - 1.0
+
+      real zqsat
+      integer ip
+!c
+!C     ------------------------------------------------------------------
+!c
+!c
+
+      do ip=1,np
+
+!c      write(*,*)'kelvin,millibar=',kelvin,millibar
+!c       write(*,*)'temp,pres=',temp(ip),pres(ip)
+!c
+         IF (temp(ip) .LE. rtt) THEN
+            r3es = r3ies
+            r4es = r4ies
+         ELSE
+            r3es = r3les
+            r4es = r4les
+         ENDIF
+!c
+         zqsat=r2es/pres(ip)*EXP(r3es*(temp(ip)-rtt)/(temp(ip)-r4es))
+         zqsat=MIN(0.5,ZQSAT)
+         zqsat=zqsat/(1.-retv *zqsat)
+!c
+         qsat(ip)= zqsat
+!c      write(*,*)'qsat=',qsat(ip)
+
+      enddo
+!c
+      RETURN
+      END subroutine q_sat
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/raddim.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/raddim.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/raddim.h	(revision 17)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      INTEGER kdlon, kflev
+      PARAMETER (kdlon=149,kflev=klev)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/raddimlw.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/raddimlw.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/raddimlw.h	(revision 17)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+      INTEGER NUA
+      PARAMETER (NUA=24)
+      INTEGER NTRA
+      PARAMETER (NTRA=15)
+      INTEGER Ninter
+      PARAMETER (Ninter=6)
+      INTEGER NG1, NG1P1
+      PARAMETER (NG1=2, NG1P1=NG1+1)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/radepsi.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/radepsi.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/radepsi.h	(revision 17)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+      REAL(KIND=8) ZEELOG, ZEPSC, ZEPSCO, ZEPSCQ, ZEPSCT, ZEPSCW
+      REAL(KIND=8) ZEPSEC, ZEPSCR
+      PARAMETER (ZEELOG = 1.E-07) !1.e-10 (not good for 32-bit machines)
+      PARAMETER (ZEPSC  = 1.E-20)
+      PARAMETER (ZEPSCO = 1.E-10)
+      PARAMETER (ZEPSCQ = 1.E-10)
+      PARAMETER (ZEPSCT = 1.E-20)
+      PARAMETER (ZEPSCW = 1.E-20)
+      PARAMETER (ZEPSEC = 1.0E-12)
+      PARAMETER (ZEPSCR = 1.0E-10)
+!c
+      REAL(KIND=8) REPSCT
+      PARAMETER (REPSCT=1.0E-10)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/radiation_AR4.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/radiation_AR4.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/radiation_AR4.F	(revision 17)
@@ -0,0 +1,6080 @@
+cIM ctes ds clesphys.h   SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, 
+      SUBROUTINE SW_LMDAR4(PSCT, PRMU0, PFRAC, 
+     S              PPMB, PDP, 
+     S              PPSOL, PALBD, PALBP,
+     S              PTAVE, PWV, PQS, POZON, PAER,
+     S              PCLDSW, PTAU, POMEGA, PCG,
+     S              PHEAT, PHEAT0,
+     S              PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,
+     S              ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,
+     S              tauae, pizae, cgae,
+     s              PTAUA, POMEGAA,
+     S              PTOPSWAD,PSOLSWAD,PTOPSWAI,PSOLSWAI,
+     J              ok_ade, ok_aie )
+      USE dimphy      
+      IMPLICIT none
+
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "YOMCST.h"
+#include "iniprint.h"
+C
+C     ------------------------------------------------------------------
+C
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
+C          2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL  (SW1S)
+C          3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL  (SW2S)
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        95-01-01   J.-J. MORCRETTE  Direct/Diffuse Albedo
+c        03-11-27   J. QUAAS Introduce aerosol forcings (based on BOUCHER)
+C     ------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      REAL(KIND=8) PSCT  ! constante solaire (valeur conseillee: 1370)
+cIM ctes ds clesphys.h   REAL(KIND=8) RCO2  ! concentration CO2 (IPCC: 353.E-06*44.011/28.97)
+#include "clesphys.h"
+C
+      REAL(KIND=8) PPSOL(KDLON)        ! SURFACE PRESSURE (PA)
+      REAL(KIND=8) PDP(KDLON,KFLEV)    ! LAYER THICKNESS (PA)
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+C
+      REAL(KIND=8) PRMU0(KDLON)  ! COSINE OF ZENITHAL ANGLE
+      REAL(KIND=8) PFRAC(KDLON)  ! fraction de la journee
+C
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)  ! LAYER TEMPERATURE (K)
+      REAL(KIND=8) PWV(KDLON,KFLEV)    ! SPECIFIC HUMIDITY (KG/KG)
+      REAL(KIND=8) PQS(KDLON,KFLEV)    ! SATURATED WATER VAPOUR (KG/KG)
+      REAL(KIND=8) POZON(KDLON,KFLEV)  ! OZONE CONCENTRATION (KG/KG)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
+C
+      REAL(KIND=8) PALBD(KDLON,2)  ! albedo du sol (lumiere diffuse)
+      REAL(KIND=8) PALBP(KDLON,2)  ! albedo du sol (lumiere parallele)
+C
+      REAL(KIND=8) PCLDSW(KDLON,KFLEV)    ! CLOUD FRACTION
+      REAL(KIND=8) PTAU(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS
+      REAL(KIND=8) PCG(KDLON,2,KFLEV)     ! ASYMETRY FACTOR
+      REAL(KIND=8) POMEGA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+C
+      REAL(KIND=8) PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
+      REAL(KIND=8) PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
+      REAL(KIND=8) PALBPLA(KDLON)     ! PLANETARY ALBEDO
+      REAL(KIND=8) PTOPSW(KDLON)      ! SHORTWAVE FLUX AT T.O.A.
+      REAL(KIND=8) PSOLSW(KDLON)      ! SHORTWAVE FLUX AT SURFACE
+      REAL(KIND=8) PTOPSW0(KDLON)     ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
+      REAL(KIND=8) PSOLSW0(KDLON)     ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
+C
+C* LOCAL VARIABLES:
+C
+      real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
+
+      REAL(KIND=8) ZOZ(KDLON,KFLEV)
+!     column-density of ozone in layer, in kilo-Dobsons
+
+      REAL(KIND=8) ZAKI(KDLON,2)     
+      REAL(KIND=8) ZCLD(KDLON,KFLEV)
+      REAL(KIND=8) ZCLEAR(KDLON) 
+      REAL(KIND=8) ZDSIG(KDLON,KFLEV)
+      REAL(KIND=8) ZFACT(KDLON)
+      REAL(KIND=8) ZFD(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFDOWN(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFU(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFUP(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRMU(KDLON)
+      REAL(KIND=8) ZSEC(KDLON)
+      REAL(KIND=8) ZUD(KDLON,5,KFLEV+1)
+      REAL(KIND=8) ZCLDSW0(KDLON,KFLEV)
+c
+      REAL(KIND=8) ZFSUP(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFSDN(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1)
+C
+      INTEGER inu, jl, jk, i, k, kpl1
+c
+      INTEGER swpas  ! Every swpas steps, sw is calculated
+      PARAMETER(swpas=1)
+c
+      INTEGER itapsw
+      LOGICAL appel1er
+      DATA itapsw /0/
+      DATA appel1er /.TRUE./
+      SAVE itapsw,appel1er
+c$OMP THREADPRIVATE(appel1er)
+c$OMP THREADPRIVATE(itapsw)
+cjq-Introduced for aerosol forcings
+      real(kind=8) flag_aer
+      logical ok_ade, ok_aie    ! use aerosol forcings or not?
+      real(kind=8) tauae(kdlon,kflev,2)  ! aerosol optical properties
+      real(kind=8) pizae(kdlon,kflev,2)  ! (see aeropt.F)
+      real(kind=8) cgae(kdlon,kflev,2)   ! -"-
+      REAL(KIND=8) PTAUA(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS (pre-industrial value)
+      REAL(KIND=8) POMEGAA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+      REAL(KIND=8) PTOPSWAD(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
+      REAL(KIND=8) PSOLSWAD(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
+      REAL(KIND=8) PTOPSWAI(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
+      REAL(KIND=8) PSOLSWAI(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
+cjq - Fluxes including aerosol effects
+      REAL(KIND=8),allocatable,save :: ZFSUPAD(:,:)
+c$OMP THREADPRIVATE(ZFSUPAD)
+      REAL(KIND=8),allocatable,save :: ZFSDNAD(:,:)
+c$OMP THREADPRIVATE(ZFSDNAD)
+      REAL(KIND=8),allocatable,save :: ZFSUPAI(:,:)
+c$OMP THREADPRIVATE(ZFSUPAI)
+      REAL(KIND=8),allocatable,save :: ZFSDNAI(:,:)
+c$OMP THREADPRIVATE(ZFSDNAI)
+      logical initialized
+cym      SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes
+!rv
+      save flag_aer
+c$OMP THREADPRIVATE(flag_aer)
+      data initialized/.false./
+      save initialized
+c$OMP THREADPRIVATE(initialized)
+cjq-end
+      REAL tmp_
+      if(.not.initialized) then
+        flag_aer=0.
+        initialized=.TRUE.
+        allocate(ZFSUPAD(KDLON,KFLEV+1))
+        allocate(ZFSDNAD(KDLON,KFLEV+1))
+        allocate(ZFSUPAI(KDLON,KFLEV+1))
+        allocate(ZFSDNAI(KDLON,KFLEV+1))
+
+        ZFSUPAD(:,:)=0.
+        ZFSDNAD(:,:)=0.
+        ZFSUPAI(:,:)=0.
+        ZFSDNAI(:,:)=0.
+      endif
+
+      IF (appel1er) THEN
+         WRITE(lunout,*) 'SW calling frequency : ', swpas
+         WRITE(lunout,*) "   In general, it should be 1"
+         appel1er = .FALSE.
+      ENDIF
+C     ------------------------------------------------------------------
+      IF (MOD(itapsw,swpas).EQ.0) THEN
+c
+      tmp_ = 1./( dobson_u * 1e3 * RG)
+!cdir collapse
+      DO JK = 1 , KFLEV
+        DO JL = 1, KDLON
+          ZCLDSW0(JL,JK) = 0.0
+          ZOZ(JL,JK) = POZON(JL,JK)*tmp_*PDP(JL,JK)
+        ENDDO
+      ENDDO
+C
+C
+c clear-sky:
+cIM ctes ds clesphys.h  CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL,
+      CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S_LMDAR4(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S_LMDAR4(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S     ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP0(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      
+      flag_aer=0.0
+      CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S_LMDAR4(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S_LMDAR4(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S    ZFDOWN, ZFUP)
+
+c cloudy-sky:
+      
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      
+c      
+      IF (ok_ade) THEN
+c
+c cloudy-sky + aerosol dir OB
+      flag_aer=1.0
+      CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S_LMDAR4(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S_LMDAR4(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
+     S     PWV, PQS,
+     S    ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUPAD(JL,JK) = ZFSUP(JL,JK) 
+         ZFSDNAD(JL,JK) = ZFSDN(JL,JK) 
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO 
+      
+      ENDIF ! ok_ade
+      
+      IF (ok_aie) THEN
+         
+cjq   cloudy-sky + aerosol direct + aerosol indirect
+      flag_aer=1.0
+      CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,
+     S         PRMU0,PFRAC,PTAVE,PWV,
+     S         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S_LMDAR4(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,
+     S     ZFD, ZFU)
+      INU = 2
+      CALL SW2S_LMDAR4(INU,
+     S     PAER, flag_aer, tauae, pizae, cgae,
+     S     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
+     S     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,
+     S     PWV, PQS,
+     S    ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUPAI(JL,JK) = ZFSUP(JL,JK) 
+         ZFSDNAI(JL,JK) = ZFSDN(JL,JK)          
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      ENDIF ! ok_aie      
+cjq -end
+      
+      itapsw = 0
+      ENDIF
+      itapsw = itapsw + 1
+C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))
+     .                     -(ZFSDN(i,k)-ZFSDN(i,kpl1))
+            PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))
+     .                     -(ZFSDN0(i,k)-ZFSDN0(i,kpl1))
+            PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20)
+c
+         PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1)
+         PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1)
+c
+         PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1)
+         PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1)
+c-OB
+         PSOLSWAD(i) = ZFSDNAD(i,1) - ZFSUPAD(i,1)
+         PTOPSWAD(i) = ZFSDNAD(i,KFLEV+1) - ZFSUPAD(i,KFLEV+1)
+c
+         PSOLSWAI(i) = ZFSDNAI(i,1) - ZFSUPAI(i,1)
+         PTOPSWAI(i) = ZFSDNAI(i,KFLEV+1) - ZFSUPAI(i,KFLEV+1)
+c-fin 
+      ENDDO
+C
+      RETURN
+      END
+c
+cIM ctes ds clesphys.h   SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
+      SUBROUTINE SWU_LMDAR4 (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
+     S                PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT,
+     S                PRMU,PSEC,PUD)
+      USE dimphy
+      USE radiation_AR4_param, only :
+     S     ZPDH2O,ZPDUMG,ZPRH2O,ZPRUMG,RTDH2O,RTDUMG,RTH2O,RTUMG
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+#include "YOMCST.h"
+C
+C* ARGUMENTS:
+C
+      REAL(KIND=8) PSCT
+cIM ctes ds clesphys.h   REAL(KIND=8) RCO2
+#include "clesphys.h"
+      REAL(KIND=8) PCLDSW(KDLON,KFLEV)
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1)
+      REAL(KIND=8) PPSOL(KDLON)
+      REAL(KIND=8) PRMU0(KDLON)
+      REAL(KIND=8) PFRAC(KDLON)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)
+      REAL(KIND=8) PWV(KDLON,KFLEV)
+C
+      REAL(KIND=8) PAKI(KDLON,2)
+      REAL(KIND=8) PCLD(KDLON,KFLEV)
+      REAL(KIND=8) PCLEAR(KDLON)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) PFACT(KDLON)
+      REAL(KIND=8) PRMU(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+      REAL(KIND=8) PUD(KDLON,5,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND(2)
+      REAL(KIND=8) ZC1J(KDLON,KFLEV+1)
+      REAL(KIND=8) ZCLEAR(KDLON)
+      REAL(KIND=8) ZCLOUD(KDLON)
+      REAL(KIND=8) ZN175(KDLON)
+      REAL(KIND=8) ZN190(KDLON)
+      REAL(KIND=8) ZO175(KDLON)
+      REAL(KIND=8) ZO190(KDLON)
+      REAL(KIND=8) ZSIGN(KDLON)
+      REAL(KIND=8) ZR(KDLON,2) 
+      REAL(KIND=8) ZSIGO(KDLON)
+      REAL(KIND=8) ZUD(KDLON,2)
+      REAL(KIND=8) ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW
+      INTEGER jl, jk, jkp1, jkl, jklp1, ja
+C
+C     ------------------------------------------------------------------
+C
+C*         1.     COMPUTES AMOUNTS OF ABSORBERS
+C                 -----------------------------
+C
+ 100  CONTINUE
+C
+      IIND(1)=1
+      IIND(2)=2
+C      
+C
+C*         1.1    INITIALIZES QUANTITIES
+C                 ----------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      PUD(JL,1,KFLEV+1)=0.
+      PUD(JL,2,KFLEV+1)=0.
+      PUD(JL,3,KFLEV+1)=0.
+      PUD(JL,4,KFLEV+1)=0.
+      PUD(JL,5,KFLEV+1)=0.
+      PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT
+      PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
+      PSEC(JL)=1./PRMU(JL)
+      ZC1J(JL,KFLEV+1)=0.
+ 111  CONTINUE
+C
+C*          1.3    AMOUNTS OF ABSORBERS
+C                  --------------------
+C
+ 130  CONTINUE
+C
+      DO 131 JL= 1, KDLON
+      ZUD(JL,1) = 0.
+      ZUD(JL,2) = 0.
+      ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.)
+      ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.)
+      ZSIGO(JL) = PPSOL(JL)
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 131  CONTINUE
+C
+      DO 133 JK = 1 , KFLEV
+      JKP1 = JK + 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL+1
+      DO 132 JL = 1, KDLON
+      ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O
+      ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG
+      ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZSIGN(JL) = 100. * PPMB(JL,JKP1)
+      PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)
+      ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)
+      ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)
+      ZDSCO2 = ZO175(JL) - ZN175(JL)
+      ZDSH2O = ZO190(JL) - ZN190(JL)
+      PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)
+     .             * ZDSH2O * ZWH2O  * ZRTH
+      PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)
+     .             * ZDSCO2 * RCO2 * ZRTU
+      ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O)
+      PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW
+      PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)
+      ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)
+      ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)
+      ZSIGO(JL) = ZSIGN(JL)
+      ZO175(JL) = ZN175(JL)
+      ZO190(JL) = ZN190(JL)
+C      
+      IF (NOVLP.EQ.1) THEN
+         ZCLEAR(JL)=ZCLEAR(JL)
+     S               *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))
+     S               /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDSW(JL,JKL)
+      ELSE IF (NOVLP.EQ.2) THEN
+         ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 132  CONTINUE
+ 133  CONTINUE
+      DO 134 JL=1, KDLON
+      PCLEAR(JL)=1.-ZC1J(JL,1)
+ 134  CONTINUE
+      DO 136 JK=1,KFLEV
+      DO 135 JL=1, KDLON
+      IF (PCLEAR(JL).LT.1.) THEN
+         PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))
+      ELSE
+         PCLD(JL,JK)=0.
+      END IF
+ 135  CONTINUE
+ 136  CONTINUE           
+C      
+C
+C*         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
+C                 -----------------------------------------------
+C
+ 140  CONTINUE
+C
+      DO 142 JA = 1,2
+      DO 141 JL = 1, KDLON
+      ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)
+ 141  CONTINUE
+ 142  CONTINUE
+C
+      CALL SWTT1_LMDAR4(2, 2, IIND, ZUD, ZR)
+C
+      DO 144 JA = 1,2
+      DO 143 JL = 1, KDLON
+      PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)
+ 143  CONTINUE
+ 144  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SW1S_LMDAR4 ( KNU
+     S  ,  PAER  , flag_aer, tauae, pizae, cgae
+     S  ,  PALBD , PALBP, PCG  , PCLD , PCLEAR, PCLDSW
+     S  ,  PDSIG , POMEGA, POZ  , PRMU , PSEC , PTAU  , PUD  
+     S  ,  PFD   , PFU)
+      USE dimphy
+      USE radiation_AR4_param, only : RSUN, RRAY
+      USE infotrac, ONLY : type_trac
+#ifdef REPROBUS
+      USE CHEM_REP, ONLY : RSUNTIME, ok_SUNTIME
+#endif
+
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"i
+#include "iniprint.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
+C     CONTINUUM SCATTERING
+C          2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+C     ------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      INTEGER KNU
+c-OB
+      real(kind=8) flag_aer
+      real(kind=8) tauae(kdlon,kflev,2)
+      real(kind=8) pizae(kdlon,kflev,2)
+      real(kind=8) cgae(kdlon,kflev,2)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)
+      REAL(KIND=8) PALBD(KDLON,2)
+      REAL(KIND=8) PALBP(KDLON,2)
+      REAL(KIND=8) PCG(KDLON,2,KFLEV)  
+      REAL(KIND=8) PCLD(KDLON,KFLEV)
+      REAL(KIND=8) PCLDSW(KDLON,KFLEV)
+      REAL(KIND=8) PCLEAR(KDLON)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) POMEGA(KDLON,2,KFLEV)
+      REAL(KIND=8) POZ(KDLON,KFLEV)
+      REAL(KIND=8) PRMU(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+      REAL(KIND=8) PTAU(KDLON,2,KFLEV)
+      REAL(KIND=8) PUD(KDLON,5,KFLEV+1)
+C
+      REAL(KIND=8) PFD(KDLON,KFLEV+1)
+      REAL(KIND=8) PFU(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND(4)
+C      
+      REAL(KIND=8) ZCGAZ(KDLON,KFLEV) 
+      REAL(KIND=8) ZDIFF(KDLON)
+      REAL(KIND=8) ZDIRF(KDLON)        
+      REAL(KIND=8) ZPIZAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZRAYL(KDLON)
+      REAL(KIND=8) ZRAY1(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRAY2(KDLON,KFLEV+1)
+      REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1)
+      REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRK(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRMUE(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRMU0(KDLON,KFLEV+1)
+      REAL(KIND=8) ZR(KDLON,4)
+      REAL(KIND=8) ZTAUAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZTRA1(KDLON,KFLEV+1)
+      REAL(KIND=8) ZTRA2(KDLON,KFLEV+1)
+      REAL(KIND=8) ZW(KDLON,4)
+C
+      INTEGER jl, jk, k, jaj, ikm1, ikl
+
+C If running with Reporbus, overwrite default values of RSUN. 
+C Otherwise keep default values from radiation_AR4_param module.  
+      IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+         IF (ok_SUNTIME) THEN
+            RSUN(1) = RSUNTIME(1)
+            RSUN(2) = RSUNTIME(2)
+         ENDIF
+         WRITE(lunout,*)'RSUN(1): ',RSUN(1)
+#endif
+      END IF
+
+C     ------------------------------------------------------------------
+C
+C*         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
+C                 ----------------------- ------------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+C                 -----------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      ZRAYL(JL) =  RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL)
+     S          * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL)
+     S          * (RRAY(KNU,5) + PRMU(JL) *  RRAY(KNU,6)       ))))
+ 111  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    CONTINUUM SCATTERING CALCULATIONS
+C                ---------------------------------
+C
+ 200  CONTINUE
+C
+C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+C                --------------------------------
+C  
+ 210  CONTINUE
+C
+      CALL SWCLR_LMDAR4 ( KNU
+     S  , PAER   , flag_aer, tauae, pizae, cgae
+     S  , PALBP  , PDSIG , ZRAYL, PSEC
+     S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
+     S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+C
+C
+C*         2.2   CLOUDY FRACTION OF THE COLUMN
+C                -----------------------------
+C
+ 220  CONTINUE
+C
+      CALL SWR_LMDAR4 ( KNU
+     S  , PALBD ,PCG   ,PCLD  ,PDSIG ,POMEGA,ZRAYL
+     S  , PSEC  ,PTAU
+     S  , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ  ,ZRK,ZRMUE
+     S  , ZTAUAZ,ZTRA1 ,ZTRA2)
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    OZONE ABSORPTION
+C                ----------------
+C
+ 300  CONTINUE
+C
+      IIND(1)=1
+      IIND(2)=3
+      IIND(3)=1
+      IIND(4)=3
+C      
+C
+C*         3.1   DOWNWARD FLUXES
+C                ---------------
+C
+ 310  CONTINUE
+C
+      JAJ = 2
+C
+      DO 311 JL = 1, KDLON
+      ZW(JL,1)=0.
+      ZW(JL,2)=0.
+      ZW(JL,3)=0.
+      ZW(JL,4)=0.
+      PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1)
+     S     + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU)
+ 311  CONTINUE
+      DO 314 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 312 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL)
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+ 312  CONTINUE
+C
+      CALL SWTT1_LMDAR4(KNU, 4, IIND, ZW, ZR)
+C
+      DO 313 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL)
+      PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
+     S                  +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 313  CONTINUE
+ 314  CONTINUE
+C
+C
+C*         3.2   UPWARD FLUXES
+C                -------------
+C
+ 320  CONTINUE
+C
+      DO 325 JL = 1, KDLON
+      PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU)
+     S               + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU))
+     S          * RSUN(KNU)
+ 325  CONTINUE
+C
+      DO 328 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 326 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKM1)*1.66
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKM1)*1.66
+ 326  CONTINUE
+C
+      CALL SWTT1_LMDAR4(KNU, 4, IIND, ZW, ZR)
+C
+      DO 327 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK)
+      PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
+     S                 +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 327  CONTINUE
+ 328  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SW2S_LMDAR4 ( KNU
+     S  ,  PAER  , flag_aer, tauae, pizae, cgae
+     S  ,  PAKI, PALBD, PALBP, PCG   , PCLD, PCLEAR, PCLDSW
+     S  ,  PDSIG ,POMEGA,POZ , PRMU , PSEC  , PTAU
+     S  ,  PUD   ,PWV , PQS
+     S  ,  PFDOWN,PFUP                                            )
+      USE dimphy
+      USE radiation_AR4_param, only : RSUN, RRAY
+      USE infotrac, ONLY : type_trac
+#ifdef REPROBUS
+      use CHEM_REP, only : RSUNTIME, ok_SUNTIME
+#endif
+
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C
+C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
+C     SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
+C     CONTINUUM SCATTERING
+C          2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
+C     A GREY MOLECULAR ABSORPTION
+C          3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
+C     OF ABSORBERS
+C          4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
+C          5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+c-OB
+      real(kind=8) flag_aer
+      real(kind=8) tauae(kdlon,kflev,2)
+      real(kind=8) pizae(kdlon,kflev,2)
+      real(kind=8) cgae(kdlon,kflev,2)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)
+      REAL(KIND=8) PAKI(KDLON,2)
+      REAL(KIND=8) PALBD(KDLON,2)
+      REAL(KIND=8) PALBP(KDLON,2)
+      REAL(KIND=8) PCG(KDLON,2,KFLEV)
+      REAL(KIND=8) PCLD(KDLON,KFLEV)
+      REAL(KIND=8) PCLDSW(KDLON,KFLEV)
+      REAL(KIND=8) PCLEAR(KDLON)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) POMEGA(KDLON,2,KFLEV)
+      REAL(KIND=8) POZ(KDLON,KFLEV)
+      REAL(KIND=8) PQS(KDLON,KFLEV)
+      REAL(KIND=8) PRMU(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+      REAL(KIND=8) PTAU(KDLON,2,KFLEV)
+      REAL(KIND=8) PUD(KDLON,5,KFLEV+1)
+      REAL(KIND=8) PWV(KDLON,KFLEV)
+C
+      REAL(KIND=8) PFDOWN(KDLON,KFLEV+1)
+      REAL(KIND=8) PFUP(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER IIND2(2), IIND3(3)
+      REAL(KIND=8) ZCGAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZFD(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFU(KDLON,KFLEV+1) 
+      REAL(KIND=8) ZG(KDLON)
+      REAL(KIND=8) ZGG(KDLON)
+      REAL(KIND=8) ZPIZAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZRAYL(KDLON)
+      REAL(KIND=8) ZRAY1(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRAY2(KDLON,KFLEV+1)
+      REAL(KIND=8) ZREF(KDLON)
+      REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1)
+      REAL(KIND=8) ZRE1(KDLON)
+      REAL(KIND=8) ZRE2(KDLON)
+      REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRK(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRL(KDLON,8)
+      REAL(KIND=8) ZRMUE(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRMU0(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRMUZ(KDLON)
+      REAL(KIND=8) ZRNEB(KDLON)
+      REAL(KIND=8) ZRUEF(KDLON,8)
+      REAL(KIND=8) ZR1(KDLON) 
+      REAL(KIND=8) ZR2(KDLON,2)
+      REAL(KIND=8) ZR3(KDLON,3)
+      REAL(KIND=8) ZR4(KDLON)
+      REAL(KIND=8) ZR21(KDLON)
+      REAL(KIND=8) ZR22(KDLON)
+      REAL(KIND=8) ZS(KDLON)
+      REAL(KIND=8) ZTAUAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZTO1(KDLON)
+      REAL(KIND=8) ZTR(KDLON,2,KFLEV+1)
+      REAL(KIND=8) ZTRA1(KDLON,KFLEV+1)
+      REAL(KIND=8) ZTRA2(KDLON,KFLEV+1)
+      REAL(KIND=8) ZTR1(KDLON)
+      REAL(KIND=8) ZTR2(KDLON)
+      REAL(KIND=8) ZW(KDLON)   
+      REAL(KIND=8) ZW1(KDLON)
+      REAL(KIND=8) ZW2(KDLON,2)
+      REAL(KIND=8) ZW3(KDLON,3)
+      REAL(KIND=8) ZW4(KDLON)
+      REAL(KIND=8) ZW5(KDLON)
+C
+      INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
+      INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
+      REAL(KIND=8) ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11
+
+C If running with Reporbus, overwrite default values of RSUN. 
+C Otherwise keep default values from radiation_AR4_param module.  
+      IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+         IF (ok_SUNTIME) THEN
+            RSUN(1)=RSUNTIME(1)
+            RSUN(2)=RSUNTIME(2)
+         END IF
+#endif
+      END IF
+
+C
+
+C
+C     ------------------------------------------------------------------
+C
+C*         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
+C                 -------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+C                 -----------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 111 JL = 1, KDLON
+      ZRMUM1 = 1. - PRMU(JL)
+      ZRAYL(JL) =  RRAY(KNU,1) + ZRMUM1   * (RRAY(KNU,2) + ZRMUM1
+     S          * (RRAY(KNU,3) + ZRMUM1   * (RRAY(KNU,4) + ZRMUM1
+     S          * (RRAY(KNU,5) + ZRMUM1   *  RRAY(KNU,6)     ))))
+ 111  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    CONTINUUM SCATTERING CALCULATIONS
+C                ---------------------------------
+C
+ 200  CONTINUE
+C
+C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+C                --------------------------------
+C  
+ 210  CONTINUE
+C
+      CALL SWCLR_LMDAR4 ( KNU
+     S  , PAER   , flag_aer, tauae, pizae, cgae
+     S  , PALBP  , PDSIG , ZRAYL, PSEC 
+     S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
+     S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+C
+C
+C*         2.2   CLOUDY FRACTION OF THE COLUMN
+C                -----------------------------
+C
+ 220  CONTINUE
+C
+      CALL SWR_LMDAR4 ( KNU
+     S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, ZRAYL
+     S  , PSEC  , PTAU
+     S  , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ  , ZRK, ZRMUE
+     S  , ZTAUAZ, ZTRA1 , ZTRA2)
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
+C                ------------------------------------------------------
+C
+ 300  CONTINUE
+C
+      JN = 2
+C
+      DO 361 JABS=1,2
+C
+C
+C*         3.1  SURFACE CONDITIONS
+C               ------------------
+C
+ 310  CONTINUE
+C
+      DO 311 JL = 1, KDLON
+      ZREFZ(JL,2,1) = PALBD(JL,KNU)
+      ZREFZ(JL,1,1) = PALBD(JL,KNU)
+ 311  CONTINUE
+C
+C
+C*         3.2  INTRODUCING CLOUD EFFECTS
+C               -------------------------
+C
+ 320  CONTINUE
+C
+      DO 324 JK = 2 , KFLEV+1
+      JKM1 = JK - 1
+      IKL=KFLEV+1-JKM1
+      DO 322 JL = 1, KDLON
+      ZRNEB(JL) = PCLD(JL,JKM1)
+      IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN
+         ZWH2O=MAX(PWV(JL,JKM1),ZEELOG)
+         ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG))
+         ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O
+         ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG)
+      ELSE
+         ZAA=PUD(JL,JABS,JKM1)
+         ZBB=ZAA
+      END IF
+      ZRKI = PAKI(JL,JABS)
+      ZS(JL) = EXP(-ZRKI * ZAA * 1.66)
+      ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK))
+      ZTR1(JL) = 0.
+      ZRE1(JL) = 0.
+      ZTR2(JL) = 0.
+      ZRE2(JL) = 0.
+C
+      ZW(JL)= POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL)
+     S               + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1)
+     S               + ZBB * ZRKI
+
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
+     S              + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1)
+      ZW(JL) = ZR21(JL) / ZTO1(JL)
+      ZREF(JL) = ZREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = ZRMUE(JL,JK)
+ 322  CONTINUE
+C
+      CALL SWDE_LMDAR4(ZGG, ZREF, ZRMUZ, ZTO1, ZW,
+     S          ZRE1, ZRE2, ZTR1, ZTR2)
+C
+      DO 323 JL = 1, KDLON
+C
+      ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)
+     S               + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)
+     S               * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL)
+     S               + ZRNEB(JL) * ZRE1(JL)
+C
+      ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL)
+     S              + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL))
+C
+      ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1)
+     S                  +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1)
+     S             /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL)
+     S             + ZRNEB(JL) * ZRE2(JL)
+C
+      ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL)
+     S              + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1)
+     S              * ZREFZ(JL,1,JKM1)))
+     S              * ZG(JL) * (1. -ZRNEB(JL))
+C
+ 323  CONTINUE
+ 324  CONTINUE
+C
+C*         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C               -------------------------------------------------
+C
+ 330  CONTINUE
+C
+      DO 351 JREF=1,2
+C
+      JN = JN + 1
+C
+      DO 331 JL = 1, KDLON
+      ZRJ(JL,JN,KFLEV+1) = 1.
+      ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1)
+ 331  CONTINUE
+C
+      DO 333 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 332 JL = 1, KDLON
+      ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL)
+      ZRJ(JL,JN,JKL) = ZRE11
+      ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL)
+ 332  CONTINUE
+ 333  CONTINUE
+ 351  CONTINUE
+ 361  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         4.    INVERT GREY AND CONTINUUM FLUXES
+C                --------------------------------
+C
+ 400  CONTINUE
+C
+C
+C*         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
+C                ---------------------------------------------
+C
+ 410  CONTINUE
+C
+      DO 414 JK = 1 , KFLEV+1
+      DO 413 JAJ = 1 , 5 , 2
+      JAJP = JAJ + 1
+      DO 412 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)=        ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK)
+      ZRK(JL,JAJ,JK)=        ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK)
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 412  CONTINUE
+ 413  CONTINUE
+ 414  CONTINUE
+C
+      DO 417 JK = 1 , KFLEV+1
+      DO 416 JAJ = 2 , 6 , 2
+      DO 415 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 415  CONTINUE
+ 416  CONTINUE
+ 417  CONTINUE
+C
+C*         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
+C                 ---------------------------------------------
+C
+ 420  CONTINUE
+C
+      DO 437 JK = 1 , KFLEV+1
+      JKKI = 1
+      DO 425 JAJ = 1 , 2
+      IIND2(1)=JAJ
+      IIND2(2)=JAJ
+      DO 424 JN = 1 , 2
+      JN2J = JN + 2 * JAJ
+      JKKP4 = JKKI + 4
+C
+C*         4.2.1  EFFECTIVE ABSORBER AMOUNTS
+C                 --------------------------
+C
+ 4210 CONTINUE
+C
+      DO 4211 JL = 1, KDLON
+      ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK))
+     S                               / PAKI(JL,JAJ)
+      ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK))
+     S                               / PAKI(JL,JAJ)
+ 4211 CONTINUE
+C
+C*         4.2.2  TRANSMISSION FUNCTION
+C                 ---------------------
+C
+ 4220 CONTINUE
+C
+      CALL SWTT1_LMDAR4(KNU, 2, IIND2, ZW2, ZR2)
+C
+      DO 4221 JL = 1, KDLON
+      ZRL(JL,JKKI) = ZR2(JL,1)
+      ZRUEF(JL,JKKI) = ZW2(JL,1)
+      ZRL(JL,JKKP4) = ZR2(JL,2)
+      ZRUEF(JL,JKKP4) = ZW2(JL,2)
+ 4221 CONTINUE
+C
+      JKKI=JKKI+1
+ 424  CONTINUE
+ 425  CONTINUE
+C
+C*         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
+C                 ------------------------------------------------------
+C
+ 430  CONTINUE
+C
+      DO 431 JL = 1, KDLON
+      PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)
+     S              + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)
+      PFUP(JL,JK)   = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)
+     S              + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)
+ 431  CONTINUE
+ 437  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
+C                ----------------------------------------
+C
+ 500  CONTINUE
+C
+C
+C*         5.1   DOWNWARD FLUXES
+C                ---------------
+C
+ 510  CONTINUE
+C
+      JAJ = 2
+      IIND3(1)=1
+      IIND3(2)=2
+      IIND3(3)=3
+C      
+      DO 511 JL = 1, KDLON
+      ZW3(JL,1)=0.
+      ZW3(JL,2)=0.
+      ZW3(JL,3)=0.
+      ZW4(JL)  =0.
+      ZW5(JL)  =0.
+      ZR4(JL)  =1.
+      ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1)
+ 511  CONTINUE
+      DO 514 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 512 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKL)/ZRMU0(JL,IKL)
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKL)/ZRMU0(JL,IKL)
+ 512  CONTINUE
+C
+      CALL SWTT1_LMDAR4(KNU, 3, IIND3, ZW3, ZR3)
+C
+      DO 513 JL = 1, KDLON
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
+     S            * ZRJ0(JL,JAJ,IKL)
+ 513  CONTINUE
+ 514  CONTINUE
+C
+C
+C*         5.2   UPWARD FLUXES
+C                -------------
+C
+ 520  CONTINUE
+C
+      DO 525 JL = 1, KDLON
+      ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)
+ 525  CONTINUE
+C
+      DO 528 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 526 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKM1)*1.66
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKM1)*1.66
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKM1)*1.66
+ 526  CONTINUE
+C
+      CALL SWTT1_LMDAR4(KNU, 3, IIND3, ZW3, ZR3)
+C
+      DO 527 JL = 1, KDLON
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
+     S           * ZRK0(JL,JAJ,JK)
+ 527  CONTINUE
+ 528  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
+C                 --------------------------------------------------
+C
+ 600  CONTINUE
+      IABS=3
+C
+C*         6.1    DOWNWARD FLUXES
+C                 ---------------
+C
+ 610  CONTINUE
+      DO 611 JL = 1, KDLON
+      ZW1(JL)=0.
+      ZW4(JL)=0.
+      ZW5(JL)=0.
+      ZR1(JL)=0.
+      PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1)
+     S                   + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU)
+ 611  CONTINUE
+C
+      DO 614 JK = 1 , KFLEV
+      IKL=KFLEV+1-JK
+      DO 612 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL)
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL)
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 612  CONTINUE
+C
+      CALL SWTT_LMDAR4(KNU, IABS, ZW1, ZR1)
+C
+      DO 613 JL = 1, KDLON
+      PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL)
+     S                     +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU)
+ 613  CONTINUE
+ 614  CONTINUE
+C
+C
+C*         6.2    UPWARD FLUXES
+C                 -------------
+C
+ 620  CONTINUE
+      DO 621 JL = 1, KDLON
+      PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1)
+     S                 +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU)
+ 621  CONTINUE
+C
+      DO 624 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 622 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL  ,IKM1)*1.66
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66
+C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 622  CONTINUE
+C
+      CALL SWTT_LMDAR4(KNU, IABS, ZW1, ZR1)
+C
+      DO 623 JL = 1, KDLON
+      PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK)
+     S                 +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU)
+ 623  CONTINUE
+ 624  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWCLR_LMDAR4  ( KNU
+     S  , PAER  , flag_aer, tauae, pizae, cgae
+     S  , PALBP , PDSIG , PRAYL , PSEC
+     S  , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ  
+     S  , PRK   , PRMU0 , PTAUAZ, PTRA1 , PTRA2                   )
+      USE dimphy
+      USE radiation_AR4_param, only : TAUA, RPIZA, RCGA
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+C     CLEAR-SKY COLUMN
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 94-11-15
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+c-OB
+      real(kind=8) flag_aer
+      real(kind=8) tauae(kdlon,kflev,2)
+      real(kind=8) pizae(kdlon,kflev,2)
+      real(kind=8) cgae(kdlon,kflev,2)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)
+      REAL(KIND=8) PALBP(KDLON,2)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) PRAYL(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+C
+      REAL(KIND=8) PCGAZ(KDLON,KFLEV)     
+      REAL(KIND=8) PPIZAZ(KDLON,KFLEV)
+      REAL(KIND=8) PRAY1(KDLON,KFLEV+1)
+      REAL(KIND=8) PRAY2(KDLON,KFLEV+1)
+      REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1)
+      REAL(KIND=8) PRJ(KDLON,6,KFLEV+1)
+      REAL(KIND=8) PRK(KDLON,6,KFLEV+1)
+      REAL(KIND=8) PRMU0(KDLON,KFLEV+1)
+      REAL(KIND=8) PTAUAZ(KDLON,KFLEV)
+      REAL(KIND=8) PTRA1(KDLON,KFLEV+1)
+      REAL(KIND=8) PTRA2(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      REAL(KIND=8) ZC0I(KDLON,KFLEV+1)       
+      REAL(KIND=8) ZCLE0(KDLON,KFLEV)
+      REAL(KIND=8) ZCLEAR(KDLON)
+      REAL(KIND=8) ZR21(KDLON)
+      REAL(KIND=8) ZR23(KDLON)
+      REAL(KIND=8) ZSS0(KDLON)
+      REAL(KIND=8) ZSCAT(KDLON)
+      REAL(KIND=8) ZTR(KDLON,2,KFLEV+1)
+C
+      INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
+      REAL(KIND=8) ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE
+      REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1
+      REAL(KIND=8) ZBMU0, ZBMU1, ZRE11
+C
+
+C     ------------------------------------------------------------------
+C
+C*         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
+C                --------------------------------------------
+C
+ 100  CONTINUE
+C
+!cdir collapse
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+C
+      DO 108 JK = 1 , KFLEV
+c-OB
+c      DO 104 JL = 1, KDLON
+c      PCGAZ(JL,JK) = 0.
+c      PPIZAZ(JL,JK) =  0.
+c      PTAUAZ(JL,JK) = 0.
+c 104  CONTINUE
+c-OB
+c      DO 106 JAE=1,5
+c      DO 105 JL = 1, KDLON
+c      PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
+c     S        +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
+c      PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
+c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
+c      PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JK,JAE)
+c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
+c 105  CONTINUE
+c 106  CONTINUE
+c-OB
+      DO 105 JL = 1, KDLON
+      PTAUAZ(JL,JK)=flag_aer * tauae(JL,JK,KNU)
+      PPIZAZ(JL,JK)=flag_aer * pizae(JL,JK,KNU)
+      PCGAZ (JL,JK)=flag_aer * cgae(JL,JK,KNU)
+ 105  CONTINUE
+C
+      IF (flag_aer.GT.0) THEN
+c-OB
+      DO 107 JL = 1, KDLON
+c         PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
+c         PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK))
+         ZGAR = PCGAZ(JL,JK)
+         ZFF = ZGAR * ZGAR
+         PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF)
+         PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)
+         PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF)
+     S                       / (1. - PPIZAZ(JL,JK) * ZFF)
+ 107  CONTINUE
+      ELSE
+      DO JL = 1, KDLON
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         PTAUAZ(JL,JK) = ZTRAY
+         PCGAZ(JL,JK) = 0.
+         PPIZAZ(JL,JK) = 1.-REPSCT
+      END DO
+      END IF   ! check flag_aer
+c     107  CONTINUE
+c      PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
+c     $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
+c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
+C
+ 108  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+C                ----------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC0I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZSCAT(JL) = 0.
+ 201  CONTINUE
+C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+C
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
+     S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF
+ 202  CONTINUE
+C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+c     
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
+     S                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF                  
+ 204  CONTINUE
+ 205  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+C                -----------------------------------------------
+C
+ 300  CONTINUE
+C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBP(JL,KNU)
+      PREFZ(JL,1,1) = PALBP(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.1  EQUIVALENT ZENITH ANGLE
+C               -----------------------
+C
+ 310  CONTINUE
+C
+      ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL)
+     S            + ZC0I(JL,JK) * 1.66
+      PRMU0(JL,JK) = 1./ZMUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+C               ----------------------------------------------------
+C
+ 320  CONTINUE
+C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+C
+C
+C
+      PREFZ(JL,1,JK) = (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+C
+      ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+C
+      PREFZ(JL,2,JK) = (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1) )
+C
+      ZTR(JL,2,JKM1) = PTRA1(JL,JKM1) 
+C
+ 342  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66
+      PRMU0(JL,1)=1./ZMUE
+ 347  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C                 -------------------------------------------------
+C
+ 350  CONTINUE
+C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+C
+      ELSE
+C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+C
+      END IF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWR_LMDAR4 ( KNU
+     S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, PRAYL
+     S  , PSEC  , PTAU
+     S  , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ  , PRK , PRMUE
+     S  , PTAUAZ, PTRA1 , PTRA2 )
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+C     CONTINUUM SCATTERING
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
+C     OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU
+      REAL(KIND=8) PALBD(KDLON,2)
+      REAL(KIND=8) PCG(KDLON,2,KFLEV)
+      REAL(KIND=8) PCLD(KDLON,KFLEV)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) POMEGA(KDLON,2,KFLEV)
+      REAL(KIND=8) PRAYL(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+      REAL(KIND=8) PTAU(KDLON,2,KFLEV)
+C
+      REAL(KIND=8) PRAY1(KDLON,KFLEV+1)
+      REAL(KIND=8) PRAY2(KDLON,KFLEV+1)
+      REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1)
+      REAL(KIND=8) PRJ(KDLON,6,KFLEV+1)
+      REAL(KIND=8) PRK(KDLON,6,KFLEV+1)
+      REAL(KIND=8) PRMUE(KDLON,KFLEV+1)
+      REAL(KIND=8) PCGAZ(KDLON,KFLEV)
+      REAL(KIND=8) PPIZAZ(KDLON,KFLEV)
+      REAL(KIND=8) PTAUAZ(KDLON,KFLEV)
+      REAL(KIND=8) PTRA1(KDLON,KFLEV+1)
+      REAL(KIND=8) PTRA2(KDLON,KFLEV+1)
+C
+C* LOCAL VARIABLES:
+C
+      REAL(KIND=8) ZC1I(KDLON,KFLEV+1)
+      REAL(KIND=8) ZCLEQ(KDLON,KFLEV)
+      REAL(KIND=8) ZCLEAR(KDLON)
+      REAL(KIND=8) ZCLOUD(KDLON)
+      REAL(KIND=8) ZGG(KDLON)
+      REAL(KIND=8) ZREF(KDLON)
+      REAL(KIND=8) ZRE1(KDLON)
+      REAL(KIND=8) ZRE2(KDLON)
+      REAL(KIND=8) ZRMUZ(KDLON)
+      REAL(KIND=8) ZRNEB(KDLON)
+      REAL(KIND=8) ZR21(KDLON)
+      REAL(KIND=8) ZR22(KDLON)
+      REAL(KIND=8) ZR23(KDLON)
+      REAL(KIND=8) ZSS1(KDLON)
+      REAL(KIND=8) ZTO1(KDLON)
+      REAL(KIND=8) ZTR(KDLON,2,KFLEV+1)
+      REAL(KIND=8) ZTR1(KDLON)
+      REAL(KIND=8) ZTR2(KDLON)
+      REAL(KIND=8) ZW(KDLON)
+C
+      INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
+      REAL(KIND=8) ZFACOA, ZFACOC, ZCORAE, ZCORCD
+      REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1
+      REAL(KIND=8) ZMU1, ZRE11, ZBMU0, ZBMU1
+C
+C     ------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+C                ----------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC1I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZCLOUD(JL) = 0.
+ 201  CONTINUE
+C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
+     S                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
+     S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+C
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
+     S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 202  CONTINUE
+C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
+     S                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
+     S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+c     
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)
+     S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
+     S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 204  CONTINUE
+ 205  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+C                -----------------------------------------------
+C
+ 300  CONTINUE
+C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBD(JL,KNU)
+      PREFZ(JL,1,1) = PALBD(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+      ZRNEB(JL)= PCLD(JL,JKM1)
+      ZRE1(JL)=0.
+      ZTR1(JL)=0.
+      ZRE2(JL)=0.
+      ZTR2(JL)=0.
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.1  EQUIVALENT ZENITH ANGLE
+C               -----------------------
+C
+ 310  CONTINUE
+C
+      ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)
+     S            + ZC1I(JL,JK) * 1.66
+      PRMUE(JL,JK) = 1./ZMUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+C               ----------------------------------------------------
+C
+ 320  CONTINUE
+C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+c      PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
+C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
+     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.3  EFFECT OF CLOUD LAYER
+C               ---------------------
+C
+ 330  CONTINUE
+C
+      ZW(JL) = POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL)
+     S         + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
+     S              + (1. - ZR22(JL)) * PCGAZ(JL,JKM1)
+C Modif PhD - JJM 19/03/96 pour erreurs arrondis
+C machine
+C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
+      IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN
+         ZW(JL)=1.
+      ELSE
+         ZW(JL) = ZR21(JL) / ZTO1(JL)
+      END IF
+      ZREF(JL) = PREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = PRMUE(JL,JK)
+ 342  CONTINUE
+C
+      CALL SWDE_LMDAR4(ZGG  , ZREF  , ZRMUZ , ZTO1 , ZW,
+     S          ZRE1 , ZRE2  , ZTR1  , ZTR2)
+C
+      DO 345 JL = 1, KDLON
+C
+      PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+     S               + ZRNEB(JL) * ZRE2(JL)
+C
+      ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)
+     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+     S               * (1.-ZRNEB(JL))
+C
+      PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
+     S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
+     S               * PTRA2(JL,JKM1) )
+     S               + ZRNEB(JL) * ZRE1(JL)
+C
+      ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)
+     S               + PTRA1(JL,JKM1) * (1.-ZRNEB(JL))
+C
+ 345  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66
+      PRMUE(JL,1)=1./ZMUE
+ 347  CONTINUE
+C
+C
+C     ------------------------------------------------------------------
+C
+C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+C                 -------------------------------------------------
+C
+ 350  CONTINUE
+C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+C
+      ELSE
+C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+C
+      END IF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE SWDE_LMDAR4 (PGG,PREF,PRMUZ,PTO1,PW,
+     S                 PRE1,PRE2,PTR1,PTR2)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
+C     LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
+C
+C     METHOD.
+C     -------
+C
+C          STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C     ------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      REAL(KIND=8) PGG(KDLON)   ! ASSYMETRY FACTOR
+      REAL(KIND=8) PREF(KDLON)  ! REFLECTIVITY OF THE UNDERLYING LAYER
+      REAL(KIND=8) PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE
+      REAL(KIND=8) PTO1(KDLON)  ! OPTICAL THICKNESS
+      REAL(KIND=8) PW(KDLON)    ! SINGLE SCATTERING ALBEDO
+      REAL(KIND=8) PRE1(KDLON)  ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL(KIND=8) PRE2(KDLON)  ! LAYER REFLECTIVITY
+      REAL(KIND=8) PTR1(KDLON)  ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL(KIND=8) PTR2(KDLON)  ! LAYER TRANSMISSIVITY
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER jl
+      REAL(KIND=8) ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM
+      REAL(KIND=8) ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG
+      REAL(KIND=8) ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B,
+     $     ZAM2B
+      REAL(KIND=8) ZA11, ZA12, ZA13, ZA21, ZA22, ZA23
+      REAL(KIND=8) ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A
+      REAL(KIND=8) ZRI0B, ZRI1B
+      REAL(KIND=8) ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B
+      REAL(KIND=8) ZRI0C, ZRI1C, ZRI0D, ZRI1D
+C     ------------------------------------------------------------------
+C
+C*         1.      DELTA-EDDINGTON CALCULATIONS
+C
+ 100  CONTINUE
+C
+      DO 131 JL   =   1, KDLON
+C
+C*         1.1     SET UP THE DELTA-MODIFIED PARAMETERS
+C
+ 110  CONTINUE
+C
+      ZFF = PGG(JL)*PGG(JL)
+      ZGP = PGG(JL)/(1.+PGG(JL))
+      ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL)
+      ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF)
+      ZDT = 2./3.
+      ZX1 = 1.-ZWCP*ZGP
+      ZWM = 1.-ZWCP
+      ZRM2 =  PRMUZ(JL) * PRMUZ(JL)
+      ZRK = SQRT(3.*ZWM*ZX1)
+      ZX2 = 4.*(1.-ZRK*ZRK*ZRM2)
+      ZRP=ZRK/ZX1
+      ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2
+      ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2
+      ZARG=MIN(ZTOP/PRMUZ(JL),200._8)
+      ZEXMU0=EXP(-ZARG)
+      ZARG2=MIN(ZRK*ZTOP,200._8)
+      ZEXKP=EXP(ZARG2)
+      ZEXKM = 1./ZEXKP
+      ZXP2P = 1.+ZDT*ZRP
+      ZXM2P = 1.-ZDT*ZRP
+      ZAP2B = ZALPHA+ZDT*ZBETA
+      ZAM2B = ZALPHA-ZDT*ZBETA
+C
+C*         1.2     WITHOUT REFLECTION FROM THE UNDERLYING LAYER
+C
+ 120  CONTINUE
+C
+      ZA11 = ZXP2P
+      ZA12 = ZXM2P
+      ZA13 = ZAP2B
+      ZA22 = ZXP2P*ZEXKP
+      ZA21 = ZXM2P*ZEXKM
+      ZA23 = ZAM2B*ZEXMU0
+      ZDENA = ZA11 * ZA22 - ZA21 * ZA12
+      ZC1A = (ZA22*ZA13-ZA12*ZA23)/ZDENA
+      ZC2A = (ZA11*ZA23-ZA21*ZA13)/ZDENA
+      ZRI0A = ZC1A+ZC2A-ZALPHA
+      ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
+      PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL)
+      ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0
+      ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0
+      PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL)
+C
+C*         1.3     WITH REFLECTION FROM THE UNDERLYING LAYER
+C
+ 130  CONTINUE
+C
+      ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM
+      ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP
+      ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) )
+      ZDENB = ZA11 * ZB22 - ZB21 * ZA12
+      ZC1B = (ZB22*ZA13-ZA12*ZB23)/ZDENB
+      ZC2B = (ZA11*ZB23-ZB21*ZA13)/ZDENB
+      ZRI0C = ZC1B+ZC2B-ZALPHA
+      ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
+      PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL)
+      ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0
+      ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0
+      PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL)
+C
+ 131  CONTINUE
+      RETURN
+      END
+      SUBROUTINE SWTT_LMDAR4 (KNU,KA,PU,PTR)
+      USE dimphy
+      USE radiation_AR4_param, only : APAD, BPAD, D
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+C     AND HORNER'S ALGORITHM.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS
+C
+      INTEGER KNU     ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KA      ! INDEX OF THE ABSORBER
+      REAL(KIND=8) PU(KDLON)  ! ABSORBER AMOUNT
+C
+      REAL(KIND=8) PTR(KDLON) ! TRANSMISSION FUNCTION
+C
+C* LOCAL VARIABLES:
+C
+      REAL(KIND=8) ZR1(KDLON), ZR2(KDLON)
+      INTEGER jl, i,j
+C
+
+C
+C-----------------------------------------------------------------------
+C
+C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+C
+ 100  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL)
+     S      * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL)
+     S      * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL)
+     S      * ( APAD(KNU,KA,7) ))))))
+C
+      ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL)
+     S      * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL)
+     S      * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL)
+     S      * ( BPAD(KNU,KA,7) ))))))
+C     
+C
+C*         2.      ADD THE BACKGROUND TRANSMISSION
+C
+ 200  CONTINUE
+C
+C
+      PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA)
+ 201  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE SWTT1_LMDAR4(KNU,KABS,KIND, PU, PTR)
+      USE dimphy
+      USE radiation_AR4_param, only : APAD, BPAD, D
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+C     AND HORNER'S ALGORITHM.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 95-01-20
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KNU          ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KABS         ! NUMBER OF ABSORBERS
+      INTEGER KIND(KABS)   ! INDICES OF THE ABSORBERS
+      REAL(KIND=8) PU(KDLON,KABS)  ! ABSORBER AMOUNT
+C
+      REAL(KIND=8) PTR(KDLON,KABS) ! TRANSMISSION FUNCTION
+C
+C* LOCAL VARIABLES:
+C
+      REAL(KIND=8) ZR1(KDLON)
+      REAL(KIND=8) ZR2(KDLON)
+      REAL(KIND=8) ZU(KDLON)
+      INTEGER jl, ja, i, j, ia
+C
+
+C-----------------------------------------------------------------------
+C
+C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+C
+ 100  CONTINUE
+C
+      DO 202 JA = 1,KABS
+      IA=KIND(JA)
+      DO 201 JL = 1, KDLON
+      ZU(JL) = PU(JL,JA)
+      ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL)
+     S      * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL)
+     S      * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL)
+     S      * ( APAD(KNU,IA,7) ))))))
+C
+      ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)
+     S      * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL)
+     S      * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL)
+     S      * ( BPAD(KNU,IA,7) ))))))
+C     
+C
+C*         2.      ADD THE BACKGROUND TRANSMISSION
+C
+ 200  CONTINUE
+C
+      PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA) 
+ 201  CONTINUE
+ 202  CONTINUE
+C
+      RETURN
+      END
+cIM ctes ds clesphys.h   SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
+      SUBROUTINE LW_LMDAR4(
+     .              PPMB, PDP,
+     .              PPSOL,PDT0,PEMIS,
+     .              PTL, PTAVE, PWV, POZON, PAER,
+     .              PCLDLD,PCLDLU,
+     .              PVIEW,
+     .              PCOLR, PCOLR0,
+     .              PTOPLW,PSOLLW,PTOPLW0,PSOLLW0,
+     .              psollwdown,
+cIM  .              psollwdown,psollwdownclr,
+cIM  .              ptoplwdown,ptoplwdownclr)
+     .              plwup, plwdn, plwup0, plwdn0)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+#include "iniprint.h"
+C
+C-----------------------------------------------------------------------
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+C     ABSORBERS.
+C          2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+C          3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+C     BOUNDARIES.
+C          4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+C          5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+cIM ctes ds clesphys.h
+c     REAL(KIND=8) RCO2   ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97)
+c     REAL(KIND=8) RCH4   ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97)
+c     REAL(KIND=8) RN2O   ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97)
+c     REAL(KIND=8) RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97)
+c     REAL(KIND=8) RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97)
+#include "clesphys.h"
+      REAL(KIND=8) PCLDLD(KDLON,KFLEV)  ! DOWNWARD EFFECTIVE CLOUD COVER
+      REAL(KIND=8) PCLDLU(KDLON,KFLEV)  ! UPWARD EFFECTIVE CLOUD COVER
+      REAL(KIND=8) PDP(KDLON,KFLEV)     ! LAYER PRESSURE THICKNESS (Pa)
+      REAL(KIND=8) PDT0(KDLON)          ! SURFACE TEMPERATURE DISCONTINUITY (K)
+      REAL(KIND=8) PEMIS(KDLON)         ! SURFACE EMISSIVITY
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1)  ! HALF LEVEL PRESSURE (mb)
+      REAL(KIND=8) PPSOL(KDLON)         ! SURFACE PRESSURE (Pa)
+      REAL(KIND=8) POZON(KDLON,KFLEV)   ! O3 mass fraction
+      REAL(KIND=8) PTL(KDLON,KFLEV+1)   ! HALF LEVEL TEMPERATURE (K)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)  ! OPTICAL THICKNESS OF THE AEROSOLS
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)   ! LAYER TEMPERATURE (K)
+      REAL(KIND=8) PVIEW(KDLON)         ! COSECANT OF VIEWING ANGLE
+      REAL(KIND=8) PWV(KDLON,KFLEV)     ! SPECIFIC HUMIDITY (kg/kg)
+C
+      REAL(KIND=8) PCOLR(KDLON,KFLEV)   ! LONG-WAVE TENDENCY (K/day)
+      REAL(KIND=8) PCOLR0(KDLON,KFLEV)  ! LONG-WAVE TENDENCY (K/day) clear-sky
+      REAL(KIND=8) PTOPLW(KDLON)        ! LONGWAVE FLUX AT T.O.A.
+      REAL(KIND=8) PSOLLW(KDLON)        ! LONGWAVE FLUX AT SURFACE
+      REAL(KIND=8) PTOPLW0(KDLON)       ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
+      REAL(KIND=8) PSOLLW0(KDLON)       ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
+c Rajout LF
+      real(kind=8) psollwdown(kdlon)    ! LONGWAVE downwards flux at surface
+c Rajout IM
+cIM   real(kind=8) psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at surface
+cIM   real(kind=8) ptoplwdown(kdlon)    ! LONGWAVE downwards flux at T.O.A.
+cIM   real(kind=8) ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at T.O.A.
+cIM
+      REAL(KIND=8) plwup(KDLON,KFLEV+1)  ! LW up total sky
+      REAL(KIND=8) plwup0(KDLON,KFLEV+1) ! LW up clear sky
+      REAL(KIND=8) plwdn(KDLON,KFLEV+1)  ! LW down total sky
+      REAL(KIND=8) plwdn0(KDLON,KFLEV+1) ! LW down clear sky
+C-------------------------------------------------------------------------
+      REAL(KIND=8) ZABCU(KDLON,NUA,3*KFLEV+1)
+
+      REAL(KIND=8) ZOZ(KDLON,KFLEV)
+!     equivalent pressure of ozone in a layer, in Pa
+
+cym      REAL(KIND=8) ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down)
+cym      REAL(KIND=8) ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+cym      REAL(KIND=8) ZBINT(KDLON,KFLEV+1)            ! Intermediate variable
+cym      REAL(KIND=8) ZBSUI(KDLON)                    ! Intermediate variable
+cym      REAL(KIND=8) ZCTS(KDLON,KFLEV)               ! Intermediate variable
+cym      REAL(KIND=8) ZCNTRB(KDLON,KFLEV+1,KFLEV+1)   ! Intermediate variable
+cym      SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
+      REAL(KIND=8),allocatable,save :: ZFLUX(:,:,:) ! RADIATIVE FLUXES (1:up; 2:down)
+      REAL(KIND=8),allocatable,save :: ZFLUC(:,:,:) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL(KIND=8),allocatable,save :: ZBINT(:,:)            ! Intermediate variable
+      REAL(KIND=8),allocatable,save :: ZBSUI(:)                    ! Intermediate variable
+      REAL(KIND=8),allocatable,save :: ZCTS(:,:)               ! Intermediate variable
+      REAL(KIND=8),allocatable,save :: ZCNTRB(:,:,:)   ! Intermediate variable
+c$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB)
+c
+      INTEGER ilim, i, k, kpl1
+C
+      INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
+      PARAMETER (lw0pas=1)
+      INTEGER lwpas  ! Every lwpas steps, cloudy-sky is done
+      PARAMETER (lwpas=1)
+c
+      INTEGER itaplw0, itaplw
+      LOGICAL appel1er
+      SAVE appel1er, itaplw0, itaplw
+c$OMP THREADPRIVATE(appel1er, itaplw0, itaplw)
+      DATA appel1er /.TRUE./
+      DATA itaplw0,itaplw /0,0/
+
+C     ------------------------------------------------------------------
+      IF (appel1er) THEN
+         WRITE(lunout,*) "LW clear-sky calling frequency: ", lw0pas
+         WRITE(lunout,*) "LW cloudy-sky calling frequency: ", lwpas
+         WRITE(lunout,*) "   In general, they should be 1"
+cym
+	 allocate(ZFLUX(KDLON,2,KFLEV+1) )
+         allocate(ZFLUC(KDLON,2,KFLEV+1) )
+         allocate(ZBINT(KDLON,KFLEV+1))
+         allocate(ZBSUI(KDLON))
+         allocate(ZCTS(KDLON,KFLEV))
+         allocate(ZCNTRB(KDLON,KFLEV+1,KFLEV+1))
+         appel1er=.FALSE.
+      ENDIF
+C
+      IF (MOD(itaplw0,lw0pas).EQ.0) THEN
+c     Compute equivalent pressure of ozone from mass fraction:
+      DO k = 1, KFLEV
+         DO i = 1, KDLON
+            ZOZ(i,k) = POZON(i,k)*PDP(i,k)
+         ENDDO
+      ENDDO
+cIM ctes ds clesphys.h   CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
+      CALL LWU_LMDAR4(
+     S         PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU)
+      CALL LWBV_LMDAR4(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU,
+     S          ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB)
+      itaplw0 = 0
+      ENDIF
+      itaplw0 = itaplw0 + 1
+C
+      IF (MOD(itaplw,lwpas).EQ.0) THEN
+      CALL LWC_LMDAR4(ILIM,PCLDLD,PCLDLU,PEMIS,
+     S         ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB,
+     S         ZFLUX)
+      itaplw = 0
+      ENDIF
+      itaplw = itaplw + 1
+C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1)
+     .                 - ZFLUX(i,1,k)-   ZFLUX(i,2,k)
+            PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1)
+     .                 - ZFLUC(i,1,k)-   ZFLUC(i,2,k)
+            PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1)
+         PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1)
+c
+         PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1)
+         PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1)
+         psollwdown(i) = -ZFLUX(i,2,1)
+c
+cIM attention aux signes !; LWtop >0, LWdn < 0
+         DO k = 1, KFLEV+1
+           plwup(i,k) = ZFLUX(i,1,k)
+           plwup0(i,k) = ZFLUC(i,1,k)
+           plwdn(i,k) = ZFLUX(i,2,k)
+           plwdn0(i,k) = ZFLUC(i,2,k)
+         ENDDO
+      ENDDO
+C     ------------------------------------------------------------------
+      RETURN
+      END
+cIM ctes ds clesphys.h   SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
+      SUBROUTINE LWU_LMDAR4(
+     S               PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV,
+     S               PABCU)
+      USE dimphy
+      USE radiation_AR4_param, only : TREF, RT1, RAER, AT, BT, OCT
+      USE infotrac, ONLY : type_trac
+#ifdef REPROBUS
+      USE CHEM_REP, ONLY: RCH42D,
+     $                    RN2O2D,
+     $                    RCFC112D,
+     $                    RCFC122D,
+     $                    ok_Rtime2D
+#endif
+
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     PURPOSE.
+C     --------
+C           COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
+C           TEMPERATURE EFFECTS
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+C     ABSORBERS.
+C
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 404 modified) - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+cIM ctes ds clesphys.h
+c     REAL(KIND=8) RCO2
+c     REAL(KIND=8) RCH4, RN2O, RCFC11, RCFC12
+#include "clesphys.h"
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)
+      REAL(KIND=8) PDP(KDLON,KFLEV)
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1)
+      REAL(KIND=8) PPSOL(KDLON)
+      REAL(KIND=8) POZ(KDLON,KFLEV)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)
+      REAL(KIND=8) PVIEW(KDLON)
+      REAL(KIND=8) PWV(KDLON,KFLEV)
+C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+C
+C-----------------------------------------------------------------------
+C* LOCAL VARIABLES:
+      REAL(KIND=8) ZABLY(KDLON,NUA,3*KFLEV+1)
+      REAL(KIND=8) ZDUC(KDLON,3*KFLEV+1)
+      REAL(KIND=8) ZPHIO(KDLON)
+      REAL(KIND=8) ZPSC2(KDLON)
+      REAL(KIND=8) ZPSC3(KDLON)
+      REAL(KIND=8) ZPSH1(KDLON)
+      REAL(KIND=8) ZPSH2(KDLON)
+      REAL(KIND=8) ZPSH3(KDLON)
+      REAL(KIND=8) ZPSH4(KDLON)
+      REAL(KIND=8) ZPSH5(KDLON)
+      REAL(KIND=8) ZPSH6(KDLON)
+      REAL(KIND=8) ZPSIO(KDLON)
+      REAL(KIND=8) ZTCON(KDLON)
+      REAL(KIND=8) ZPHM6(KDLON)
+      REAL(KIND=8) ZPSM6(KDLON)
+      REAL(KIND=8) ZPHN6(KDLON)
+      REAL(KIND=8) ZPSN6(KDLON)
+      REAL(KIND=8) ZSSIG(KDLON,3*KFLEV+1)
+      REAL(KIND=8) ZTAVI(KDLON)
+      REAL(KIND=8) ZUAER(KDLON,Ninter)
+      REAL(KIND=8) ZXOZ(KDLON)
+      REAL(KIND=8) ZXWV(KDLON)
+C
+      INTEGER jl, jk, jkj, jkjr, jkjp, ig1
+      INTEGER jki, jkip1, ja, jj
+      INTEGER jkl, jkp1, jkk, jkjpn
+      INTEGER jae1, jae2, jae3, jae, jjpn
+      INTEGER ir, jc, jcp1
+      REAL(KIND=8) zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
+      REAL(KIND=8) zfppw, ztx, ztx2, zzably
+      REAL(KIND=8) zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
+      REAL(KIND=8) zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
+      REAL(KIND=8) zcac8, zcbc8
+      REAL(KIND=8) zalup, zdiff
+c
+      REAL(KIND=8) PVGCO2, PVGH2O, PVGO3
+C
+      REAL(KIND=8) R10E  ! DECIMAL/NATURAL LOG.FACTOR
+      PARAMETER (R10E=0.4342945)
+
+C-----------------------------------------------------------------------
+c
+      IF (LEVOIGT) THEN
+         PVGCO2= 60.
+         PVGH2O= 30.
+         PVGO3 =400.
+      ELSE
+         PVGCO2= 0.
+         PVGH2O= 0.
+         PVGO3 = 0.
+      ENDIF
+C
+C
+C*         2.    PRESSURE OVER GAUSS SUB-LEVELS
+C                ------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      ZSSIG(JL, 1 ) = PPMB(JL,1) * 100.
+ 201  CONTINUE
+C
+      DO 206 JK = 1 , KFLEV
+      JKJ=(JK-1)*NG1P1+1
+      JKJR = JKJ
+      JKJP = JKJ + NG1P1
+      DO 203 JL = 1, KDLON
+      ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100.
+ 203  CONTINUE
+      DO 205 IG1=1,NG1
+      JKJ=JKJ+1
+      DO 204 JL = 1, KDLON
+      ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5
+     S  + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5
+ 204  CONTINUE
+ 205  CONTINUE
+ 206  CONTINUE
+C
+C-----------------------------------------------------------------------
+C
+C
+C*         4.    PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
+C                --------------------------------------------------
+C
+ 400  CONTINUE
+C
+      DO 402 JKI=1,3*KFLEV
+      JKIP1=JKI+1
+      DO 401 JL = 1, KDLON
+      ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5
+      ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1))
+     S                                 /(10.*RG)
+ 401  CONTINUE
+ 402  CONTINUE
+C
+      DO 406 JK = 1 , KFLEV
+      JKP1=JK+1
+      JKL = KFLEV+1 - JK
+      DO 403 JL = 1, KDLON
+      ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO )
+ 403  CONTINUE
+      JKJ=(JK-1)*NG1P1+1
+      JKJPN=JKJ+NG1
+      DO 405 JKK=JKJ,JKJPN
+      DO 404 JL = 1, KDLON
+      ZDPM = ZABLY(JL,3,JKK)
+      ZUPM = ZABLY(JL,5,JKK)             * ZDPM / 101325.
+      ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325.
+      ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325.
+      ZUPMO3  = ( ZABLY(JL,5,JKK) + PVGO3  ) * ZDPM / 101325.
+      ZDUC(JL,JKK) = ZDPM
+      ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM
+      ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3
+      ZU6 = ZXWV(JL) * ZUPM
+      ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL))
+      ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O
+      ZABLY(JL,11,JKK) = ZU6 * ZFPPW
+      ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW)
+      ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2
+      ZABLY(JL,8,JKK) = RCO2 * ZDPM
+ 404  CONTINUE
+ 405  CONTINUE
+ 406  CONTINUE
+C
+C-----------------------------------------------------------------------
+C
+C
+C*         5.    CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
+C                --------------------------------------------------
+C
+ 500  CONTINUE
+C
+      DO 502 JA = 1, NUA
+      DO 501 JL = 1, KDLON
+      PABCU(JL,JA,3*KFLEV+1) = 0.
+  501 CONTINUE
+  502 CONTINUE
+C
+      DO 529 JK = 1 , KFLEV
+      JJ=(JK-1)*NG1P1+1
+      JJPN=JJ+NG1
+      JKL=KFLEV+1-JK
+C
+C
+C*         5.1  CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
+C               --------------------------------------------------
+C
+ 510  CONTINUE
+C
+      JAE1=3*KFLEV+1-JJ
+      JAE2=3*KFLEV+1-(JJ+1)
+      JAE3=3*KFLEV+1-JJPN
+      DO 512 JAE=1,5
+      DO 511 JL = 1, KDLON
+      ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1)
+     S      +RAER(JAE,2)*PAER(JL,JKL,2)+RAER(JAE,3)*PAER(JL,JKL,3)
+     S      +RAER(JAE,4)*PAER(JL,JKL,4)+RAER(JAE,5)*PAER(JL,JKL,5))
+     S      /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3))
+ 511  CONTINUE
+ 512  CONTINUE
+C
+C
+C
+C*         5.2  INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
+C               --------------------------------------------------
+C
+ 520  CONTINUE
+C
+      DO 521 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.))
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3)
+      ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0._8), 6._8)
+      ZCAH1=AT(1,1)+ZUP*(AT(1,2)+ZUP*(AT(1,3)))
+      ZCBH1=BT(1,1)+ZUP*(BT(1,2)+ZUP*(BT(1,3)))
+      ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 )
+      ZCAH2=AT(2,1)+ZUP*(AT(2,2)+ZUP*(AT(2,3)))
+      ZCBH2=BT(2,1)+ZUP*(BT(2,2)+ZUP*(BT(2,3)))
+      ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 )
+      ZCAH3=AT(3,1)+ZUP*(AT(3,2)+ZUP*(AT(3,3)))
+      ZCBH3=BT(3,1)+ZUP*(BT(3,2)+ZUP*(BT(3,3)))
+      ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 )
+      ZCAH4=AT(4,1)+ZUP*(AT(4,2)+ZUP*(AT(4,3)))
+      ZCBH4=BT(4,1)+ZUP*(BT(4,2)+ZUP*(BT(4,3)))
+      ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 )
+      ZCAH5=AT(5,1)+ZUP*(AT(5,2)+ZUP*(AT(5,3)))
+      ZCBH5=BT(5,1)+ZUP*(BT(5,2)+ZUP*(BT(5,3)))
+      ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 )
+      ZCAH6=AT(6,1)+ZUP*(AT(6,2)+ZUP*(AT(6,3)))
+      ZCBH6=BT(6,1)+ZUP*(BT(6,2)+ZUP*(BT(6,3)))
+      ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 )
+      ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 )
+      ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 )
+      ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 )
+      ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 )
+ 521  CONTINUE
+C
+      DO 522 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3)
+      ZALUP = R10E * LOG ( ZZABLY )
+      ZUP   = MAX( 0._8, 5.0 + 0.5 * ZALUP )
+      ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP
+      ZCAC8=AT(8,1)+ZUP*(AT(8,2)+ZUP*(AT(8,3)))
+      ZCBC8=BT(8,1)+ZUP*(BT(8,2)+ZUP*(BT(8,3)))
+      ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 )
+      ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2)
+      ZPSIO(JL) = EXP( 2.* (OCT(3)*ZTX+OCT(4)*ZTX2))
+ 522  CONTINUE
+C
+      DO 524 JKK=JJ,JJPN
+      JC=3*KFLEV+1-JKK
+      JCP1=JC+1
+      DO 523 JL = 1, KDLON
+      ZDIFF = PVIEW(JL)
+      PABCU(JL,10,JC)=PABCU(JL,10,JCP1)
+     S                +ZABLY(JL,10,JC)           *ZDIFF
+      PABCU(JL,11,JC)=PABCU(JL,11,JCP1)
+     S                +ZABLY(JL,11,JC)*ZTCON(JL)*ZDIFF
+C
+      PABCU(JL,12,JC)=PABCU(JL,12,JCP1)
+     S                +ZABLY(JL,12,JC)*ZPHIO(JL)*ZDIFF
+      PABCU(JL,13,JC)=PABCU(JL,13,JCP1)
+     S                +ZABLY(JL,13,JC)*ZPSIO(JL)*ZDIFF
+C
+      PABCU(JL,7,JC)=PABCU(JL,7,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC2(JL)*ZDIFF
+      PABCU(JL,8,JC)=PABCU(JL,8,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+      PABCU(JL,9,JC)=PABCU(JL,9,JCP1)
+     S               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+C
+      PABCU(JL,1,JC)=PABCU(JL,1,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH1(JL)*ZDIFF
+      PABCU(JL,2,JC)=PABCU(JL,2,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH2(JL)*ZDIFF
+      PABCU(JL,3,JC)=PABCU(JL,3,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH5(JL)*ZDIFF
+      PABCU(JL,4,JC)=PABCU(JL,4,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH3(JL)*ZDIFF
+      PABCU(JL,5,JC)=PABCU(JL,5,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH4(JL)*ZDIFF
+      PABCU(JL,6,JC)=PABCU(JL,6,JCP1)
+     S               +ZABLY(JL,6,JC)*ZPSH6(JL)*ZDIFF
+C
+      PABCU(JL,14,JC)=PABCU(JL,14,JCP1)
+     S                +ZUAER(JL,1)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,15,JC)=PABCU(JL,15,JCP1)
+     S                +ZUAER(JL,2)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,16,JC)=PABCU(JL,16,JCP1)
+     S                +ZUAER(JL,3)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,17,JC)=PABCU(JL,17,JCP1)
+     S                +ZUAER(JL,4)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,18,JC)=PABCU(JL,18,JCP1)
+     S                +ZUAER(JL,5)    *ZDUC(JL,JC)*ZDIFF
+C
+C
+
+      IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+         IF (ok_Rtime2D) THEN
+            PABCU(JL,19,JC)=PABCU(JL,19,JCP1)
+     S           +ZABLY(JL,8,JC)*RCH42D(JL,JC)/RCO2*ZPHM6(JL)*ZDIFF
+            PABCU(JL,20,JC)=PABCU(JL,20,JCP1)
+     S           +ZABLY(JL,9,JC)*RCH42D(JL,JC)/RCO2*ZPSM6(JL)*ZDIFF
+            PABCU(JL,21,JC)=PABCU(JL,21,JCP1)
+     S           +ZABLY(JL,8,JC)*RN2O2D(JL,JC)/RCO2*ZPHN6(JL)*ZDIFF
+            PABCU(JL,22,JC)=PABCU(JL,22,JCP1)
+     S           +ZABLY(JL,9,JC)*RN2O2D(JL,JC)/RCO2*ZPSN6(JL)*ZDIFF
+C
+            PABCU(JL,23,JC)=PABCU(JL,23,JCP1)
+     S           +ZABLY(JL,8,JC)*RCFC112D(JL,JC)/RCO2         *ZDIFF
+            PABCU(JL,24,JC)=PABCU(JL,24,JCP1)
+     S           +ZABLY(JL,8,JC)*RCFC122D(JL,JC)/RCO2         *ZDIFF
+         ELSE
+            ! Same calculation as for type_trac /= repr
+            PABCU(JL,19,JC)=PABCU(JL,19,JCP1)
+     S           +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF
+            PABCU(JL,20,JC)=PABCU(JL,20,JCP1)
+     S           +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF
+            PABCU(JL,21,JC)=PABCU(JL,21,JCP1)
+     S           +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF
+            PABCU(JL,22,JC)=PABCU(JL,22,JCP1)
+     S           +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF
+C     
+            PABCU(JL,23,JC)=PABCU(JL,23,JCP1)
+     S               +ZABLY(JL,8,JC)*RCFC11/RCO2         *ZDIFF
+            PABCU(JL,24,JC)=PABCU(JL,24,JCP1)
+     S           +ZABLY(JL,8,JC)*RCFC12/RCO2         *ZDIFF
+         END IF
+#endif
+      ELSE
+         PABCU(JL,19,JC)=PABCU(JL,19,JCP1)
+     S        +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF
+         PABCU(JL,20,JC)=PABCU(JL,20,JCP1)
+     S               +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF
+         PABCU(JL,21,JC)=PABCU(JL,21,JCP1)
+     S        +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF
+         PABCU(JL,22,JC)=PABCU(JL,22,JCP1)
+     S        +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF
+C     
+         PABCU(JL,23,JC)=PABCU(JL,23,JCP1)
+     S        +ZABLY(JL,8,JC)*RCFC11/RCO2         *ZDIFF
+         PABCU(JL,24,JC)=PABCU(JL,24,JCP1)
+     S        +ZABLY(JL,8,JC)*RCFC12/RCO2         *ZDIFF
+      END IF
+      
+ 523  CONTINUE
+ 524  CONTINUE
+C
+ 529  CONTINUE
+C
+C
+      RETURN
+      END
+      SUBROUTINE LWBV_LMDAR4(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU,
+     S                PFLUC,PBINT,PBSUI,PCTS,PCNTRB)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C     PURPOSE.
+C     --------
+C           TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
+C           VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
+C           SAVING
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+C          2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+C     BOUNDARIES.
+C          3. COMPUTES THE CLEAR-SKY COOLING RATES.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
+C                                          MEMORY)
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+      INTEGER KLIM
+C
+      REAL(KIND=8) PDP(KDLON,KFLEV)
+      REAL(KIND=8) PDT0(KDLON)
+      REAL(KIND=8) PEMIS(KDLON)
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1)
+      REAL(KIND=8) PTL(KDLON,KFLEV+1)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)
+C
+      REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1)
+C     
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1)
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1)
+      REAL(KIND=8) PBSUI(KDLON)
+      REAL(KIND=8) PCTS(KDLON,KFLEV)
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1)
+C
+C-------------------------------------------------------------------------
+C
+C* LOCAL VARIABLES:
+      REAL(KIND=8) ZB(KDLON,Ninter,KFLEV+1)
+      REAL(KIND=8) ZBSUR(KDLON,Ninter)
+      REAL(KIND=8) ZBTOP(KDLON,Ninter)
+      REAL(KIND=8) ZDBSL(KDLON,Ninter,KFLEV*2)
+      REAL(KIND=8) ZGA(KDLON,8,2,KFLEV)
+      REAL(KIND=8) ZGB(KDLON,8,2,KFLEV)
+      REAL(KIND=8) ZGASUR(KDLON,8,2)
+      REAL(KIND=8) ZGBSUR(KDLON,8,2)
+      REAL(KIND=8) ZGATOP(KDLON,8,2)
+      REAL(KIND=8) ZGBTOP(KDLON,8,2)
+C
+      INTEGER nuaer, ntraer
+C     ------------------------------------------------------------------
+C* COMPUTES PLANCK FUNCTIONS:
+       CALL LWB_LMDAR4(PDT0,PTAVE,PTL,
+     S          ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,
+     S          ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP)
+C     ------------------------------------------------------------------
+C* PERFORMS THE VERTICAL INTEGRATION:
+      NUAER = NUA
+      NTRAER = NTRA
+      CALL LWV_LMDAR4(NUAER,NTRAER, KLIM
+     R  , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE
+     R  , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP
+     S  , PCNTRB,PCTS,PFLUC)
+C     ------------------------------------------------------------------
+      RETURN
+      END
+      SUBROUTINE LWC_LMDAR4(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC,
+     R               PBINT,PBSUIN,PCTS,PCNTRB,
+     S               PFLUX)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+C
+C     PURPOSE.
+C     --------
+C           INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
+C           RADIANCES
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C PBINT  : (KDLON,0:KFLEV)     ; HALF LEVEL PLANCK FUNCTION
+C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+C PCLDLD : (KDLON,KFLEV)       ; DOWNWARD EFFECTIVE CLOUD FRACTION
+C PCLDLU : (KDLON,KFLEV)       ; UPWARD EFFECTIVE CLOUD FRACTION
+C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
+C PCTS   : (KDLON,KFLEV)       ; CLEAR-SKY LAYER COOLING-TO-SPACE
+C PEMIS  : (KDLON)             ; SURFACE EMISSIVITY
+C PFLUC
+C     ==== OUTPUTS ===
+C PFLUX(KDLON,2,KFLEV)         ; RADIATIVE FLUXES :
+C                     1  ==>  UPWARD   FLUX TOTAL
+C                     2  ==>  DOWNWARD FLUX TOTAL
+C
+C     METHOD.
+C     -------
+C
+C          1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
+C          2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
+C          3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
+C     CLOUDS
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 231 to 233)  - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+      INTEGER klim
+      REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1)   ! HALF LEVEL PLANCK FUNCTION
+      REAL(KIND=8) PBSUIN(KDLON)          ! SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE
+      REAL(KIND=8) PCTS(KDLON,KFLEV)      ! CLEAR-SKY LAYER COOLING-TO-SPACE
+c
+      REAL(KIND=8) PCLDLD(KDLON,KFLEV)
+      REAL(KIND=8) PCLDLU(KDLON,KFLEV)
+      REAL(KIND=8) PEMIS(KDLON)
+C
+      REAL(KIND=8) PFLUX(KDLON,2,KFLEV+1)
+C-----------------------------------------------------------------------
+C* LOCAL VARIABLES:
+      INTEGER IMX(KDLON), IMXP(KDLON)
+C
+      REAL(KIND=8) ZCLEAR(KDLON),ZCLOUD(KDLON),
+     $     ZDNF(KDLON,KFLEV+1,KFLEV+1)
+     S  , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON)
+     S  , ZUPF(KDLON,KFLEV+1,KFLEV+1)
+      REAL(KIND=8) ZCLM(KDLON,KFLEV+1,KFLEV+1)
+C
+      INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
+      INTEGER jk1, jk2, jkc, jkcp1, jcloud
+      INTEGER imxm1, imxp1
+      REAL(KIND=8) zcfrac
+C     ------------------------------------------------------------------
+C
+C*         1.     INITIALIZATION
+C                 --------------
+C
+ 100  CONTINUE
+C
+      IMAXC = 0
+C
+      DO 101 JL = 1, KDLON
+      IMX(JL)=0
+      IMXP(JL)=0
+      ZCLOUD(JL) = 0.
+ 101  CONTINUE
+C
+C*         1.1    SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
+C                 -------------------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      IMX1=IMX(JL)
+      IMX2=JK
+      IF (PCLDLU(JL,JK).GT.ZEPSC) THEN
+         IMXP(JL)=IMX2
+      ELSE
+         IMXP(JL)=IMX1
+      END IF
+      IMAXC=MAX(IMXP(JL),IMAXC)
+      IMX(JL)=IMXP(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+CGM*******
+      IMAXC=KFLEV
+CGM*******
+C
+      DO 114 JK = 1 , KFLEV+1
+      DO 113 JL = 1, KDLON
+      PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
+      PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
+ 113  CONTINUE
+ 114  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
+C                  ---------------------------------------
+C
+      IF (IMAXC.GT.0) THEN
+C
+         IMXP1 = IMAXC + 1
+         IMXM1 = IMAXC - 1
+C
+C*         2.0     INITIALIZE TO CLEAR-SKY FLUXES
+C                  ------------------------------
+C
+ 200  CONTINUE
+C
+         DO 203 JK1=1,KFLEV+1
+         DO 202 JK2=1,KFLEV+1
+         DO 201 JL = 1, KDLON
+         ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
+         ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
+ 201     CONTINUE
+ 202     CONTINUE
+ 203     CONTINUE
+C
+C*         2.1     FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
+C                  ----------------------------------------------
+C
+ 210  CONTINUE
+C
+         DO 213 JKC = 1 , IMAXC
+         JCLOUD=JKC
+         JKCP1=JCLOUD+1
+C
+C*         2.1.1   ABOVE THE CLOUD
+C                  ---------------
+C
+ 2110 CONTINUE
+C
+         DO 2115 JK=JKCP1,KFLEV+1
+         JKM1=JK-1
+         DO 2111 JL = 1, KDLON
+         ZFU(JL)=0.
+ 2111    CONTINUE
+         IF (JK .GT. JKCP1) THEN
+            DO 2113 JKJ=JKCP1,JKM1
+            DO 2112 JL = 1, KDLON
+            ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
+ 2112       CONTINUE
+ 2113       CONTINUE
+         END IF
+C
+         DO 2114 JL = 1, KDLON
+         ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
+ 2114    CONTINUE
+ 2115    CONTINUE
+C
+C*         2.1.2   BELOW THE CLOUD
+C                  ---------------
+C
+ 2120 CONTINUE
+C
+         DO 2125 JK=1,JCLOUD
+         JKP1=JK+1
+         DO 2121 JL = 1, KDLON
+         ZFD(JL)=0.
+ 2121    CONTINUE
+C
+         IF (JK .LT. JCLOUD) THEN
+            DO 2123 JKJ=JKP1,JCLOUD
+            DO 2122 JL = 1, KDLON
+            ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
+ 2122       CONTINUE
+ 2123       CONTINUE
+         END IF
+         DO 2124 JL = 1, KDLON
+         ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
+ 2124    CONTINUE
+ 2125    CONTINUE
+C
+ 213     CONTINUE
+C
+C
+C*         2.2     CLOUD COVER MATRIX
+C                  ------------------
+C
+C*    ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
+C     HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
+C
+ 220  CONTINUE
+C
+      DO 223 JK1 = 1 , KFLEV+1
+      DO 222 JK2 = 1 , KFLEV+1
+      DO 221 JL = 1, KDLON
+      ZCLM(JL,JK1,JK2) = 0.
+ 221  CONTINUE
+ 222  CONTINUE
+ 223  CONTINUE
+C
+C
+C
+C*         2.4     CLOUD COVER BELOW THE LEVEL OF CALCULATION
+C                  ------------------------------------------
+C
+ 240  CONTINUE
+C
+      DO 244 JK1 = 2 , KFLEV+1
+      DO 241 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 241  CONTINUE
+      DO 243 JK = JK1 - 1 , 1 , -1
+      DO 242 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))
+     *                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLU(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 242  CONTINUE
+ 243  CONTINUE
+ 244  CONTINUE
+C
+C
+C*         2.5     CLOUD COVER ABOVE THE LEVEL OF CALCULATION
+C                  ------------------------------------------
+C
+ 250  CONTINUE
+C
+      DO 254 JK1 = 1 , KFLEV
+      DO 251 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 251  CONTINUE
+      DO 253 JK = JK1 , KFLEV
+      DO 252 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))
+     *                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLD(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 252  CONTINUE
+ 253  CONTINUE
+ 254  CONTINUE
+C
+C
+C
+C*         3.      FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
+C                  ----------------------------------------------
+C
+ 300  CONTINUE
+C
+C*         3.1     DOWNWARD FLUXES
+C                  ---------------
+C
+ 310  CONTINUE
+C
+      DO 311 JL = 1, KDLON
+      PFLUX(JL,2,KFLEV+1) = 0.
+ 311  CONTINUE
+C
+      DO 317 JK1 = KFLEV , 1 , -1
+C
+C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+C
+      DO 312 JL = 1, KDLON
+      ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1)
+ 312  CONTINUE
+C
+C*                 CONTRIBUTION FROM ADJACENT CLOUD
+C
+      DO 313 JL = 1, KDLON
+      ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
+ 313  CONTINUE
+C
+C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+C
+      DO 315 JK = KFLEV-1 , JK1 , -1
+      DO 314 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
+      ZFD(JL) =  ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
+ 314  CONTINUE
+ 315  CONTINUE
+C
+      DO 316 JL = 1, KDLON
+      PFLUX(JL,2,JK1) = ZFD (JL)
+ 316  CONTINUE
+C
+ 317  CONTINUE
+C
+C
+C
+C
+C*         3.2     UPWARD FLUX AT THE SURFACE
+C                  --------------------------
+C
+ 320  CONTINUE
+C
+      DO 321 JL = 1, KDLON
+      PFLUX(JL,1,1) = PEMIS(JL)*PBSUIN(JL)-(1.-PEMIS(JL))*PFLUX(JL,2,1)
+ 321  CONTINUE
+C
+C
+C
+C*         3.3     UPWARD FLUXES
+C                  -------------
+C
+ 330  CONTINUE
+C
+      DO 337 JK1 = 2 , KFLEV+1
+C
+C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+C
+      DO 332 JL = 1, KDLON
+      ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
+ 332  CONTINUE
+C
+C*                 CONTRIBUTION FROM ADJACENT CLOUD
+C
+      DO 333 JL = 1, KDLON
+      ZFU(JL) =  ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
+ 333  CONTINUE
+C
+C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+C
+      DO 335 JK = 2 , JK1-1
+      DO 334 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
+      ZFU(JL) =  ZFU(JL) + ZCFRAC * ZUPF(JL,JK  ,JK1)
+ 334  CONTINUE
+ 335  CONTINUE
+C
+      DO 336 JL = 1, KDLON
+      PFLUX(JL,1,JK1) = ZFU (JL)
+ 336  CONTINUE
+C
+ 337  CONTINUE
+C
+C
+      END IF
+C
+C
+C*         2.3     END OF CLOUD EFFECT COMPUTATIONS
+C
+ 230  CONTINUE
+C
+      IF (.NOT.LEVOIGT) THEN
+        DO 231 JL = 1, KDLON
+        ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM)
+ 231    CONTINUE
+        DO 233 JK = KLIM+1 , KFLEV+1
+        DO 232 JL = 1, KDLON
+        ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+        PFLUX(JL,1,JK) = ZFN10(JL)
+        PFLUX(JL,2,JK) = 0.0
+ 232    CONTINUE
+ 233    CONTINUE
+      ENDIF
+C
+      RETURN
+      END
+      SUBROUTINE LWB_LMDAR4(PDT0,PTAVE,PTL
+     S  , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL
+     S  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP)
+      USE dimphy
+      USE radiation_AR4_param, only : TINTP, XP, GA, GB
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           COMPUTES PLANCK FUNCTIONS
+C
+C        EXPLICIT ARGUMENTS :
+C        --------------------
+C     ==== INPUTS ===
+C PDT0   : (KDLON)             ; SURFACE TEMPERATURE DISCONTINUITY
+C PTAVE  : (KDLON,KFLEV)       ; TEMPERATURE
+C PTL    : (KDLON,0:KFLEV)     ; HALF LEVEL TEMPERATURE
+C     ==== OUTPUTS ===
+C PB     : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
+C PBINT  : (KDLON,KFLEV+1)     ; HALF LEVEL PLANCK FUNCTION
+C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+C PBSUR  : (KDLON,Ninter)        ; SURFACE SPECTRAL PLANCK FUNCTION
+C PBTOP  : (KDLON,Ninter)        ; TOP SPECTRAL PLANCK FUNCTION
+C PDBSL  : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
+C PGA    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+C PGB    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+C PGASUR, PGBSUR (KDLON,8,2)   ; SURFACE PADE APPROXIMANTS
+C PGATOP, PGBTOP (KDLON,8,2)   ; T.O.A. PADE APPROXIMANTS
+C
+C        IMPLICIT ARGUMENTS :   NONE
+C        --------------------
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
+C     FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS           "
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C
+C-----------------------------------------------------------------------
+C
+C ARGUMENTS:
+C
+      REAL(KIND=8) PDT0(KDLON)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)
+      REAL(KIND=8) PTL(KDLON,KFLEV+1)
+C
+      REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
+      REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL(KIND=8) PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION
+      REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+C
+C-------------------------------------------------------------------------
+C*  LOCAL VARIABLES:
+      INTEGER INDB(KDLON),INDS(KDLON)
+      REAL(KIND=8) ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON)
+c
+      INTEGER jk, jl, ic, jnu, jf, jg
+      INTEGER jk1, jk2
+      INTEGER k, j, ixtox, indto, ixtx, indt
+      INTEGER indsu, indtp
+      REAL(KIND=8) zdsto1, zdstox, zdst1, zdstx
+c
+C* Quelques parametres:
+      REAL(KIND=8) TSTAND
+      PARAMETER (TSTAND=250.0)
+      REAL(KIND=8) TSTP
+      PARAMETER (TSTP=12.5)
+      INTEGER MXIXT
+      PARAMETER (MXIXT=10)
+C
+C* Used Data Block:
+c     REAL*8 TINTP(11)
+c     SAVE TINTP
+cc$OMP THREADPRIVATE(TINTP)
+c     REAL*8 GA(11,16,3), GB(11,16,3)
+c     SAVE GA, GB
+cc$OMP THREADPRIVATE(GA, GB)
+c     REAL*8 XP(6,6)
+c     SAVE XP
+cc$OMP THREADPRIVATE(XP)
+c
+c     DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
+c    S             262.5, 275., 287.5, 300., 312.5 /
+C-----------------------------------------------------------------------
+C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
+C
+C
+C
+C
+C-- R.D. -- G = - 0.2 SLA
+C
+C
+C----- INTERVAL = 1 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 1, 1,IC),IC=1,3) /
+C    S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
+C     DATA (GB( 1, 1,IC),IC=1,3) /
+C    S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
+C     DATA (GA( 1, 2,IC),IC=1,3) /
+C    S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
+C     DATA (GB( 1, 2,IC),IC=1,3) /
+C    S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 2, 1,IC),IC=1,3) /
+C    S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
+C     DATA (GB( 2, 1,IC),IC=1,3) /
+C    S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
+C     DATA (GA( 2, 2,IC),IC=1,3) /
+C    S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
+C     DATA (GB( 2, 2,IC),IC=1,3) /
+C    S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 3, 1,IC),IC=1,3) /
+C    S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
+C     DATA (GB( 3, 1,IC),IC=1,3) /
+C    S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
+C     DATA (GA( 3, 2,IC),IC=1,3) /
+C    S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
+C     DATA (GB( 3, 2,IC),IC=1,3) /
+C    S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 4, 1,IC),IC=1,3) /
+C    S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
+C     DATA (GB( 4, 1,IC),IC=1,3) /
+C    S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
+C     DATA (GA( 4, 2,IC),IC=1,3) /
+C    S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
+C     DATA (GB( 4, 2,IC),IC=1,3) /
+C    S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 5, 1,IC),IC=1,3) /
+C    S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
+C     DATA (GB( 5, 1,IC),IC=1,3) /
+C    S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
+C     DATA (GA( 5, 2,IC),IC=1,3) /
+C    S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
+C     DATA (GB( 5, 2,IC),IC=1,3) /
+C    S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 6, 1,IC),IC=1,3) /
+C    S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
+C     DATA (GB( 6, 1,IC),IC=1,3) /
+C    S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
+C     DATA (GA( 6, 2,IC),IC=1,3) /
+C    S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
+C     DATA (GB( 6, 2,IC),IC=1,3) /
+C    S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 7, 1,IC),IC=1,3) /
+C    S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
+C     DATA (GB( 7, 1,IC),IC=1,3) /
+C    S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
+C     DATA (GA( 7, 2,IC),IC=1,3) /
+C    S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
+C     DATA (GB( 7, 2,IC),IC=1,3) /
+C    S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 8, 1,IC),IC=1,3) /
+C    S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
+C     DATA (GB( 8, 1,IC),IC=1,3) /
+C    S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
+C     DATA (GA( 8, 2,IC),IC=1,3) /
+C    S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
+C     DATA (GB( 8, 2,IC),IC=1,3) /
+C    S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 9, 1,IC),IC=1,3) /
+C    S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
+C     DATA (GB( 9, 1,IC),IC=1,3) /
+C    S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
+C     DATA (GA( 9, 2,IC),IC=1,3) /
+C    S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
+C     DATA (GB( 9, 2,IC),IC=1,3) /
+C    S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA(10, 1,IC),IC=1,3) /
+C    S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
+C     DATA (GB(10, 1,IC),IC=1,3) /
+C    S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
+C     DATA (GA(10, 2,IC),IC=1,3) /
+C    S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
+C     DATA (GB(10, 2,IC),IC=1,3) /
+C    S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 1 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA(11, 1,IC),IC=1,3) /
+C    S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
+C     DATA (GB(11, 1,IC),IC=1,3) /
+C    S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
+C     DATA (GA(11, 2,IC),IC=1,3) /
+C    S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
+C     DATA (GB(11, 2,IC),IC=1,3) /
+C    S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
+C
+C
+C
+C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
+C
+C
+C
+C
+C--- R.D.  ---  G = 0.02 + 0.50 / ( 1 + 4.5 U )
+C
+C
+C----- INTERVAL = 2 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 1, 3,IC),IC=1,3) /
+C    S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
+C     DATA (GB( 1, 3,IC),IC=1,3) /
+C    S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
+C     DATA (GA( 1, 4,IC),IC=1,3) /
+C    S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
+C     DATA (GB( 1, 4,IC),IC=1,3) /
+C    S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 2, 3,IC),IC=1,3) /
+C    S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
+C     DATA (GB( 2, 3,IC),IC=1,3) /
+C    S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
+C     DATA (GA( 2, 4,IC),IC=1,3) /
+C    S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
+C     DATA (GB( 2, 4,IC),IC=1,3) /
+C    S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 3, 3,IC),IC=1,3) /
+C    S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
+C     DATA (GB( 3, 3,IC),IC=1,3) /
+C    S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
+C     DATA (GA( 3, 4,IC),IC=1,3) /
+C    S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
+C     DATA (GB( 3, 4,IC),IC=1,3) /
+C    S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 4, 3,IC),IC=1,3) /
+C    S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
+C     DATA (GB( 4, 3,IC),IC=1,3) /
+C    S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
+C     DATA (GA( 4, 4,IC),IC=1,3) /
+C    S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
+C     DATA (GB( 4, 4,IC),IC=1,3) /
+C    S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 5, 3,IC),IC=1,3) /
+C    S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
+C     DATA (GB( 5, 3,IC),IC=1,3) /
+C    S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
+C     DATA (GA( 5, 4,IC),IC=1,3) /
+C    S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
+C     DATA (GB( 5, 4,IC),IC=1,3) /
+C    S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 6, 3,IC),IC=1,3) /
+C    S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
+C     DATA (GB( 6, 3,IC),IC=1,3) /
+C    S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
+C     DATA (GA( 6, 4,IC),IC=1,3) /
+C    S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
+C     DATA (GB( 6, 4,IC),IC=1,3) /
+C    S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 7, 3,IC),IC=1,3) /
+C    S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
+C     DATA (GB( 7, 3,IC),IC=1,3) /
+C    S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
+C     DATA (GA( 7, 4,IC),IC=1,3) /
+C    S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
+C     DATA (GB( 7, 4,IC),IC=1,3) /
+C    S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 8, 3,IC),IC=1,3) /
+C    S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
+C     DATA (GB( 8, 3,IC),IC=1,3) /
+C    S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
+C     DATA (GA( 8, 4,IC),IC=1,3) /
+C    S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
+C     DATA (GB( 8, 4,IC),IC=1,3) /
+C    S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 9, 3,IC),IC=1,3) /
+C    S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
+C     DATA (GB( 9, 3,IC),IC=1,3) /
+C    S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
+C     DATA (GA( 9, 4,IC),IC=1,3) /
+C    S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
+C     DATA (GB( 9, 4,IC),IC=1,3) /
+C    S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA(10, 3,IC),IC=1,3) /
+C    S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
+C     DATA (GB(10, 3,IC),IC=1,3) /
+C    S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
+C     DATA (GA(10, 4,IC),IC=1,3) /
+C    S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
+C     DATA (GB(10, 4,IC),IC=1,3) /
+C    S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA(11, 3,IC),IC=1,3) /
+C    S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
+C     DATA (GB(11, 3,IC),IC=1,3) /
+C    S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
+C     DATA (GA(11, 4,IC),IC=1,3) /
+C    S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
+C     DATA (GB(11, 4,IC),IC=1,3) /
+C    S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C
+C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
+C
+C
+C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
+C
+C
+C
+C--- G = 3.875E-03 ---------------
+C
+C----- INTERVAL = 3 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 1, 7,IC),IC=1,3) /
+C    S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
+C     DATA (GB( 1, 7,IC),IC=1,3) /
+C    S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
+C     DATA (GA( 1, 8,IC),IC=1,3) /
+C    S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
+C     DATA (GB( 1, 8,IC),IC=1,3) /
+C    S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 2, 7,IC),IC=1,3) /
+C    S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
+C     DATA (GB( 2, 7,IC),IC=1,3) /
+C    S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
+C     DATA (GA( 2, 8,IC),IC=1,3) /
+C    S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
+C     DATA (GB( 2, 8,IC),IC=1,3) /
+C    S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 3, 7,IC),IC=1,3) /
+C    S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
+C     DATA (GB( 3, 7,IC),IC=1,3) /
+C    S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
+C     DATA (GA( 3, 8,IC),IC=1,3) /
+C    S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
+C     DATA (GB( 3, 8,IC),IC=1,3) /
+C    S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 4, 7,IC),IC=1,3) /
+C    S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
+C     DATA (GB( 4, 7,IC),IC=1,3) /
+C    S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
+C     DATA (GA( 4, 8,IC),IC=1,3) /
+C    S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
+C     DATA (GB( 4, 8,IC),IC=1,3) /
+C    S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 5, 7,IC),IC=1,3) /
+C    S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
+C     DATA (GB( 5, 7,IC),IC=1,3) /
+C    S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
+C     DATA (GA( 5, 8,IC),IC=1,3) /
+C    S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
+C     DATA (GB( 5, 8,IC),IC=1,3) /
+C    S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 6, 7,IC),IC=1,3) /
+C    S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
+C     DATA (GB( 6, 7,IC),IC=1,3) /
+C    S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
+C     DATA (GA( 6, 8,IC),IC=1,3) /
+C    S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
+C     DATA (GB( 6, 8,IC),IC=1,3) /
+C    S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 7, 7,IC),IC=1,3) /
+C    S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
+C     DATA (GB( 7, 7,IC),IC=1,3) /
+C    S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
+C     DATA (GA( 7, 8,IC),IC=1,3) /
+C    S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
+C     DATA (GB( 7, 8,IC),IC=1,3) /
+C    S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 8, 7,IC),IC=1,3) /
+C    S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
+C     DATA (GB( 8, 7,IC),IC=1,3) /
+C    S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
+C     DATA (GA( 8, 8,IC),IC=1,3) /
+C    S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
+C     DATA (GB( 8, 8,IC),IC=1,3) /
+C    S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 9, 7,IC),IC=1,3) /
+C    S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
+C     DATA (GB( 9, 7,IC),IC=1,3) /
+C    S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
+C     DATA (GA( 9, 8,IC),IC=1,3) /
+C    S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
+C     DATA (GB( 9, 8,IC),IC=1,3) /
+C    S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA(10, 7,IC),IC=1,3) /
+C    S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
+C     DATA (GB(10, 7,IC),IC=1,3) /
+C    S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
+C     DATA (GA(10, 8,IC),IC=1,3) /
+C    S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
+C     DATA (GB(10, 8,IC),IC=1,3) /
+C    S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 3 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA(11, 7,IC),IC=1,3) /
+C    S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
+C     DATA (GB(11, 7,IC),IC=1,3) /
+C    S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
+C     DATA (GA(11, 8,IC),IC=1,3) /
+C    S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
+C     DATA (GB(11, 8,IC),IC=1,3) /
+C    S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
+C
+C
+C-- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
+C
+C-- G = 3.6E-03
+C
+C----- INTERVAL = 4 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 1, 9,IC),IC=1,3) /
+C    S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
+C     DATA (GB( 1, 9,IC),IC=1,3) /
+C    S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
+C     DATA (GA( 1,10,IC),IC=1,3) /
+C    S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
+C     DATA (GB( 1,10,IC),IC=1,3) /
+C    S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 2, 9,IC),IC=1,3) /
+C    S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
+C     DATA (GB( 2, 9,IC),IC=1,3) /
+C    S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
+C     DATA (GA( 2,10,IC),IC=1,3) /
+C    S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
+C     DATA (GB( 2,10,IC),IC=1,3) /
+C    S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 3, 9,IC),IC=1,3) /
+C    S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
+C     DATA (GB( 3, 9,IC),IC=1,3) /
+C    S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
+C     DATA (GA( 3,10,IC),IC=1,3) /
+C    S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
+C     DATA (GB( 3,10,IC),IC=1,3) /
+C    S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 4, 9,IC),IC=1,3) /
+C    S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
+C     DATA (GB( 4, 9,IC),IC=1,3) /
+C    S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
+C     DATA (GA( 4,10,IC),IC=1,3) /
+C    S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
+C     DATA (GB( 4,10,IC),IC=1,3) /
+C    S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 5, 9,IC),IC=1,3) /
+C    S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
+C     DATA (GB( 5, 9,IC),IC=1,3) /
+C    S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
+C     DATA (GA( 5,10,IC),IC=1,3) /
+C    S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
+C     DATA (GB( 5,10,IC),IC=1,3) /
+C    S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 6, 9,IC),IC=1,3) /
+C    S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
+C     DATA (GB( 6, 9,IC),IC=1,3) /
+C    S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
+C     DATA (GA( 6,10,IC),IC=1,3) /
+C    S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
+C     DATA (GB( 6,10,IC),IC=1,3) /
+C    S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 7, 9,IC),IC=1,3) /
+C    S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
+C     DATA (GB( 7, 9,IC),IC=1,3) /
+C    S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
+C     DATA (GA( 7,10,IC),IC=1,3) /
+C    S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
+C     DATA (GB( 7,10,IC),IC=1,3) /
+C    S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 8, 9,IC),IC=1,3) /
+C    S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
+C     DATA (GB( 8, 9,IC),IC=1,3) /
+C    S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
+C     DATA (GA( 8,10,IC),IC=1,3) /
+C    S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
+C     DATA (GB( 8,10,IC),IC=1,3) /
+C    S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA( 9, 9,IC),IC=1,3) /
+C    S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
+C     DATA (GB( 9, 9,IC),IC=1,3) /
+C    S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
+C     DATA (GA( 9,10,IC),IC=1,3) /
+C    S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
+C     DATA (GB( 9,10,IC),IC=1,3) /
+C    S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA(10, 9,IC),IC=1,3) /
+C    S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
+C     DATA (GB(10, 9,IC),IC=1,3) /
+C    S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
+C     DATA (GA(10,10,IC),IC=1,3) /
+C    S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
+C     DATA (GB(10,10,IC),IC=1,3) /
+C    S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+C     DATA (GA(11, 9,IC),IC=1,3) /
+C    S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
+C     DATA (GB(11, 9,IC),IC=1,3) /
+C    S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
+C     DATA (GA(11,10,IC),IC=1,3) /
+C    S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
+C     DATA (GB(11,10,IC),IC=1,3) /
+C    S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
+C
+C
+C
+C-- H2O -- WEAKER PARTS OF THE STRONG BANDS  -- FROM ABS225 ----
+C
+C-- WATER VAPOR --- 350 - 500 CM-1
+C
+C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
+C
+C----- INTERVAL = 5 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 1, 5,IC),IC=1,3) /
+C    S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
+C     DATA (GB( 1, 5,IC),IC=1,3) /
+C    S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
+C     DATA (GA( 1, 6,IC),IC=1,3) /
+C    S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
+C     DATA (GB( 1, 6,IC),IC=1,3) /
+C    S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 2, 5,IC),IC=1,3) /
+C    S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
+C     DATA (GB( 2, 5,IC),IC=1,3) /
+C    S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
+C     DATA (GA( 2, 6,IC),IC=1,3) /
+C    S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
+C     DATA (GB( 2, 6,IC),IC=1,3) /
+C    S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 3, 5,IC),IC=1,3) /
+C    S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
+C     DATA (GB( 3, 5,IC),IC=1,3) /
+C    S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
+C     DATA (GA( 3, 6,IC),IC=1,3) /
+C    S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
+C     DATA (GB( 3, 6,IC),IC=1,3) /
+C    S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 4, 5,IC),IC=1,3) /
+C    S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
+C     DATA (GB( 4, 5,IC),IC=1,3) /
+C    S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
+C     DATA (GA( 4, 6,IC),IC=1,3) /
+C    S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
+C     DATA (GB( 4, 6,IC),IC=1,3) /
+C    S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 5, 5,IC),IC=1,3) /
+C    S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
+C     DATA (GB( 5, 5,IC),IC=1,3) /
+C    S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
+C     DATA (GA( 5, 6,IC),IC=1,3) /
+C    S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
+C     DATA (GB( 5, 6,IC),IC=1,3) /
+C    S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 6, 5,IC),IC=1,3) /
+C    S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
+C     DATA (GB( 6, 5,IC),IC=1,3) /
+C    S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
+C     DATA (GA( 6, 6,IC),IC=1,3) /
+C    S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
+C     DATA (GB( 6, 6,IC),IC=1,3) /
+C    S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 7, 5,IC),IC=1,3) /
+C    S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
+C     DATA (GB( 7, 5,IC),IC=1,3) /
+C    S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
+C     DATA (GA( 7, 6,IC),IC=1,3) /
+C    S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
+C     DATA (GB( 7, 6,IC),IC=1,3) /
+C    S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 8, 5,IC),IC=1,3) /
+C    S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
+C     DATA (GB( 8, 5,IC),IC=1,3) /
+C    S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
+C     DATA (GA( 8, 6,IC),IC=1,3) /
+C    S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
+C     DATA (GB( 8, 6,IC),IC=1,3) /
+C    S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 9, 5,IC),IC=1,3) /
+C    S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
+C     DATA (GB( 9, 5,IC),IC=1,3) /
+C    S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
+C     DATA (GA( 9, 6,IC),IC=1,3) /
+C    S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
+C     DATA (GB( 9, 6,IC),IC=1,3) /
+C    S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA(10, 5,IC),IC=1,3) /
+C    S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
+C     DATA (GB(10, 5,IC),IC=1,3) /
+C    S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
+C     DATA (GA(10, 6,IC),IC=1,3) /
+C    S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
+C     DATA (GB(10, 6,IC),IC=1,3) /
+C    S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
+C
+C----- INTERVAL = 5 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA(11, 5,IC),IC=1,3) /
+C    S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
+C     DATA (GB(11, 5,IC),IC=1,3) /
+C    S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
+C     DATA (GA(11, 6,IC),IC=1,3) /
+C    S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
+C     DATA (GB(11, 6,IC),IC=1,3) /
+C    S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
+C
+C
+C
+C
+C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
+C--- G = 0.0
+C
+C
+C----- INTERVAL = 6 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 1,11,IC),IC=1,3) /
+C    S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
+C     DATA (GB( 1,11,IC),IC=1,3) /
+C    S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
+C     DATA (GA( 1,12,IC),IC=1,3) /
+C    S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
+C     DATA (GB( 1,12,IC),IC=1,3) /
+C    S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 2,11,IC),IC=1,3) /
+C    S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
+C     DATA (GB( 2,11,IC),IC=1,3) /
+C    S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
+C     DATA (GA( 2,12,IC),IC=1,3) /
+C    S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
+C     DATA (GB( 2,12,IC),IC=1,3) /
+C    S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 3,11,IC),IC=1,3) /
+C    S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
+C     DATA (GB( 3,11,IC),IC=1,3) /
+C    S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
+C     DATA (GA( 3,12,IC),IC=1,3) /
+C    S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
+C     DATA (GB( 3,12,IC),IC=1,3) /
+C    S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 4,11,IC),IC=1,3) /
+C    S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
+C     DATA (GB( 4,11,IC),IC=1,3) /
+C    S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
+C     DATA (GA( 4,12,IC),IC=1,3) /
+C    S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
+C     DATA (GB( 4,12,IC),IC=1,3) /
+C    S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 5,11,IC),IC=1,3) /
+C    S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
+C     DATA (GB( 5,11,IC),IC=1,3) /
+C    S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
+C     DATA (GA( 5,12,IC),IC=1,3) /
+C    S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
+C     DATA (GB( 5,12,IC),IC=1,3) /
+C    S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 6,11,IC),IC=1,3) /
+C    S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
+C     DATA (GB( 6,11,IC),IC=1,3) /
+C    S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
+C     DATA (GA( 6,12,IC),IC=1,3) /
+C    S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
+C     DATA (GB( 6,12,IC),IC=1,3) /
+C    S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 7,11,IC),IC=1,3) /
+C    S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
+C     DATA (GB( 7,11,IC),IC=1,3) /
+C    S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
+C     DATA (GA( 7,12,IC),IC=1,3) /
+C    S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
+C     DATA (GB( 7,12,IC),IC=1,3) /
+C    S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 8,11,IC),IC=1,3) /
+C    S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
+C     DATA (GB( 8,11,IC),IC=1,3) /
+C    S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
+C     DATA (GA( 8,12,IC),IC=1,3) /
+C    S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
+C     DATA (GB( 8,12,IC),IC=1,3) /
+C    S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA( 9,11,IC),IC=1,3) /
+C    S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
+C     DATA (GB( 9,11,IC),IC=1,3) /
+C    S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
+C     DATA (GA( 9,12,IC),IC=1,3) /
+C    S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
+C     DATA (GB( 9,12,IC),IC=1,3) /
+C    S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA(10,11,IC),IC=1,3) /
+C    S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
+C     DATA (GB(10,11,IC),IC=1,3) /
+C    S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
+C     DATA (GA(10,12,IC),IC=1,3) /
+C    S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
+C     DATA (GB(10,12,IC),IC=1,3) /
+C    S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 6 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+C     DATA (GA(11,11,IC),IC=1,3) /
+C    S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
+C     DATA (GB(11,11,IC),IC=1,3) /
+C    S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
+C     DATA (GA(11,12,IC),IC=1,3) /
+C    S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
+C     DATA (GB(11,12,IC),IC=1,3) /
+C    S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C-- END WATER VAPOR
+C
+C
+C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
+C
+C
+C
+C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9)  , X/T,  9
+C
+C----- INTERVAL = 2 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+C     DATA (GA( 1,13,IC),IC=1,3) /
+C    S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
+C     DATA (GB( 1,13,IC),IC=1,3) /
+C    S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
+C     DATA (GA( 1,14,IC),IC=1,3) /
+C    S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
+C     DATA (GB( 1,14,IC),IC=1,3) /
+C    S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+C     DATA (GA( 2,13,IC),IC=1,3) /
+C    S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
+C     DATA (GB( 2,13,IC),IC=1,3) /
+C    S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
+C     DATA (GA( 2,14,IC),IC=1,3) /
+C    S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
+C     DATA (GB( 2,14,IC),IC=1,3) /
+C    S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+C     DATA (GA( 3,13,IC),IC=1,3) /
+C    S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
+C     DATA (GB( 3,13,IC),IC=1,3) /
+C    S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
+C     DATA (GA( 3,14,IC),IC=1,3) /
+C    S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
+C     DATA (GB( 3,14,IC),IC=1,3) /
+C    S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+C     DATA (GA( 4,13,IC),IC=1,3) /
+C    S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
+C     DATA (GB( 4,13,IC),IC=1,3) /
+C    S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
+C     DATA (GA( 4,14,IC),IC=1,3) /
+C    S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
+C     DATA (GB( 4,14,IC),IC=1,3) /
+C    S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+C     DATA (GA( 5,13,IC),IC=1,3) /
+C    S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
+C     DATA (GB( 5,13,IC),IC=1,3) /
+C    S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
+C     DATA (GA( 5,14,IC),IC=1,3) /
+C    S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
+C     DATA (GB( 5,14,IC),IC=1,3) /
+C    S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+C     DATA (GA( 6,13,IC),IC=1,3) /
+C    S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
+C     DATA (GB( 6,13,IC),IC=1,3) /
+C    S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
+C     DATA (GA( 6,14,IC),IC=1,3) /
+C    S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
+C     DATA (GB( 6,14,IC),IC=1,3) /
+C    S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+C     DATA (GA( 7,13,IC),IC=1,3) /
+C    S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
+C     DATA (GB( 7,13,IC),IC=1,3) /
+C    S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
+C     DATA (GA( 7,14,IC),IC=1,3) /
+C    S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
+C     DATA (GB( 7,14,IC),IC=1,3) /
+C    S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+C     DATA (GA( 8,13,IC),IC=1,3) /
+C    S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
+C     DATA (GB( 8,13,IC),IC=1,3) /
+C    S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
+C     DATA (GA( 8,14,IC),IC=1,3) /
+C    S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
+C     DATA (GB( 8,14,IC),IC=1,3) /
+C    S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+C     DATA (GA( 9,13,IC),IC=1,3) /
+C    S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
+C     DATA (GB( 9,13,IC),IC=1,3) /
+C    S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
+C     DATA (GA( 9,14,IC),IC=1,3) /
+C    S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
+C     DATA (GB( 9,14,IC),IC=1,3) /
+C    S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+C     DATA (GA(10,13,IC),IC=1,3) /
+C    S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
+C     DATA (GB(10,13,IC),IC=1,3) /
+C    S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
+C     DATA (GA(10,14,IC),IC=1,3) /
+C    S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
+C     DATA (GB(10,14,IC),IC=1,3) /
+C    S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
+C
+C----- INTERVAL = 2 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+C     DATA (GA(11,13,IC),IC=1,3) /
+C    S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
+C     DATA (GB(11,13,IC),IC=1,3) /
+C    S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
+C     DATA (GA(11,14,IC),IC=1,3) /
+C    S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
+C     DATA (GB(11,14,IC),IC=1,3) /
+C    S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
+C
+C
+C
+C
+C
+C
+C
+C
+C
+C
+C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
+C
+C
+C-- G = 0.0
+C
+C
+C----- INTERVAL = 4 ----- T =  187.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 1,15,IC),IC=1,3) /
+C    S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
+C     DATA (GB( 1,15,IC),IC=1,3) /
+C    S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
+C     DATA (GA( 1,16,IC),IC=1,3) /
+C    S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
+C     DATA (GB( 1,16,IC),IC=1,3) /
+C    S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  200.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 2,15,IC),IC=1,3) /
+C    S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
+C     DATA (GB( 2,15,IC),IC=1,3) /
+C    S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
+C     DATA (GA( 2,16,IC),IC=1,3) /
+C    S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
+C     DATA (GB( 2,16,IC),IC=1,3) /
+C    S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  212.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 3,15,IC),IC=1,3) /
+C    S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
+C     DATA (GB( 3,15,IC),IC=1,3) /
+C    S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
+C     DATA (GA( 3,16,IC),IC=1,3) /
+C    S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
+C     DATA (GB( 3,16,IC),IC=1,3) /
+C    S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  225.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 4,15,IC),IC=1,3) /
+C    S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
+C     DATA (GB( 4,15,IC),IC=1,3) /
+C    S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
+C     DATA (GA( 4,16,IC),IC=1,3) /
+C    S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
+C     DATA (GB( 4,16,IC),IC=1,3) /
+C    S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  237.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 5,15,IC),IC=1,3) /
+C    S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
+C     DATA (GB( 5,15,IC),IC=1,3) /
+C    S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
+C     DATA (GA( 5,16,IC),IC=1,3) /
+C    S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
+C     DATA (GB( 5,16,IC),IC=1,3) /
+C    S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  250.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 6,15,IC),IC=1,3) /
+C    S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
+C     DATA (GB( 6,15,IC),IC=1,3) /
+C    S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
+C     DATA (GA( 6,16,IC),IC=1,3) /
+C    S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
+C     DATA (GB( 6,16,IC),IC=1,3) /
+C    S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  262.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 7,15,IC),IC=1,3) /
+C    S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
+C     DATA (GB( 7,15,IC),IC=1,3) /
+C    S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
+C     DATA (GA( 7,16,IC),IC=1,3) /
+C    S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
+C     DATA (GB( 7,16,IC),IC=1,3) /
+C    S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  275.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 8,15,IC),IC=1,3) /
+C    S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
+C     DATA (GB( 8,15,IC),IC=1,3) /
+C    S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
+C     DATA (GA( 8,16,IC),IC=1,3) /
+C    S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
+C     DATA (GB( 8,16,IC),IC=1,3) /
+C    S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  287.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA( 9,15,IC),IC=1,3) /
+C    S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
+C     DATA (GB( 9,15,IC),IC=1,3) /
+C    S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
+C     DATA (GA( 9,16,IC),IC=1,3) /
+C    S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
+C     DATA (GB( 9,16,IC),IC=1,3) /
+C    S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  300.0
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA(10,15,IC),IC=1,3) /
+C    S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
+C     DATA (GB(10,15,IC),IC=1,3) /
+C    S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
+C     DATA (GA(10,16,IC),IC=1,3) /
+C    S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
+C     DATA (GB(10,16,IC),IC=1,3) /
+C    S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
+C
+C----- INTERVAL = 4 ----- T =  312.5
+C
+C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+C     DATA (GA(11,15,IC),IC=1,3) /
+C    S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
+C     DATA (GB(11,15,IC),IC=1,3) /
+C    S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
+C     DATA (GA(11,16,IC),IC=1,3) /
+C    S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
+C     DATA (GB(11,16,IC),IC=1,3) /
+C    S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
+C
+C     ------------------------------------------------------------------
+C     DATA (( XP(  J,K),J=1,6),       K=1,6) /
+C    S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
+C    S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
+C    S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
+C    S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
+C    S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
+C    S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
+C    S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
+C    S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
+C    S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
+C    S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
+C    S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
+C    S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
+
+C
+C
+C*         1.0     PLANCK FUNCTIONS AND GRADIENTS
+C                  ------------------------------
+C
+ 100  CONTINUE
+C
+!cdir collapse
+      DO 102 JK = 1 , KFLEV+1
+      DO 101 JL = 1, KDLON
+      PBINT(JL,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+      DO 103 JL = 1, KDLON
+      PBSUIN(JL) = 0.
+ 103  CONTINUE
+C
+      DO 141 JNU=1,Ninter
+C
+C
+C*         1.1   LEVELS FROM SURFACE TO KFLEV
+C                ----------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
+     S       +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
+     S       )))))
+      PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
+      PB(JL,JNU,JK)= ZRES(JL)
+      ZBLEV(JL,JK) = ZRES(JL)
+      ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
+      ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
+     S     +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
+     S       )))))
+      ZBLAY(JL,JK) = ZRES2(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+C
+C
+C*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
+C                ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 121 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
+      ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
+     S    +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
+     S       )))))
+      ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
+     S    +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
+     S       )))))
+      PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
+      PB(JL,JNU,KFLEV+1)= ZRES(JL)
+      ZBLEV(JL,KFLEV+1) = ZRES(JL)
+      PBTOP(JL,JNU) = ZRES(JL)
+      PBSUR(JL,JNU) = ZRES2(JL)
+      PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
+ 121  CONTINUE
+C
+C
+C*         1.3   GRADIENTS IN SUB-LAYERS
+C                -----------------------
+C
+ 130  CONTINUE
+C
+      DO 132 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 131 JL = 1, KDLON
+      PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK  ) - ZBLEV(JL,JK)
+      PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
+ 131  CONTINUE
+ 132  CONTINUE
+C
+ 141  CONTINUE
+C
+C*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
+C                ---------------------------------------------
+C
+ 200  CONTINUE
+C
+C
+ 210  CONTINUE
+C
+      DO 211 JL=1, KDLON
+      ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP
+      IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) )
+      ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP
+      IF (ZDSTOX.LT.0.5) THEN
+         INDTO=IXTOX
+      ELSE
+         INDTO=IXTOX+1
+      END IF
+      INDB(JL)=INDTO
+      ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDS(JL)=INDT
+ 211  CONTINUE
+C
+      DO 214 JF=1,2
+      DO 213 JG=1, 8
+      DO 212 JL=1, KDLON
+      INDSU=INDS(JL)
+      PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
+      PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
+      INDTP=INDB(JL)
+      PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
+      PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
+ 212  CONTINUE
+ 213  CONTINUE
+ 214  CONTINUE
+C
+ 220  CONTINUE
+C
+      DO 225 JK=1,KFLEV
+      DO 221 JL=1, KDLON
+      ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDB(JL)=INDT
+ 221  CONTINUE
+C
+      DO 224 JF=1,2
+      DO 223 JG=1, 8
+      DO 222 JL=1, KDLON
+      INDT=INDB(JL)
+      PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
+      PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
+ 222  CONTINUE
+ 223  CONTINUE
+ 224  CONTINUE
+ 225  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE LWV_LMDAR4(KUAER,KTRAER, KLIM
+     R  , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCNTRB,PCTS,PFLUC)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
+C           FLUXES OR RADIANCES
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
+C     CONTRIBUTIONS BY -  THE NEARBY LAYERS
+C                      -  THE DISTANT LAYERS
+C                      -  THE BOUNDARY TERMS
+C          2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS:
+      INTEGER KUAER,KTRAER, KLIM
+C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+      REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
+      REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV) ! TEMPERATURE
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGASUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGATOP(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS
+C
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+      REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+C-----------------------------------------------------------------------
+C LOCAL VARIABLES:
+      REAL(KIND=8) ZADJD(KDLON,KFLEV+1)
+      REAL(KIND=8) ZADJU(KDLON,KFLEV+1)
+      REAL(KIND=8) ZDBDT(KDLON,Ninter,KFLEV)
+      REAL(KIND=8) ZDISD(KDLON,KFLEV+1)
+      REAL(KIND=8) ZDISU(KDLON,KFLEV+1)
+C
+      INTEGER jk, jl
+C-----------------------------------------------------------------------
+C
+      DO 112 JK=1,KFLEV+1
+      DO 111 JL=1, KDLON
+      ZADJD(JL,JK)=0.
+      ZADJU(JL,JK)=0.
+      ZDISD(JL,JK)=0.
+      ZDISU(JL,JK)=0.
+ 111  CONTINUE
+ 112  CONTINUE
+C
+      DO 114 JK=1,KFLEV
+      DO 113 JL=1, KDLON
+      PCTS(JL,JK)=0.
+ 113  CONTINUE
+ 114  CONTINUE
+C
+C* CONTRIBUTION FROM ADJACENT LAYERS
+C
+      CALL LWVN_LMDAR4(KUAER,KTRAER
+     R  , PABCU,PDBSL,PGA,PGB
+     S  , ZADJD,ZADJU,PCNTRB,ZDBDT)
+C* CONTRIBUTION FROM DISTANT LAYERS
+C
+      CALL LWVD_LMDAR4(KUAER,KTRAER
+     R  , PABCU,ZDBDT,PGA,PGB
+     S  , PCNTRB,ZDISD,ZDISU)
+C
+C* EXCHANGE WITH THE BOUNDARIES
+C
+      CALL LWVB_LMDAR4(KUAER,KTRAER, KLIM
+     R  , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP
+     R  , ZDISD,ZDISU,PEMIS,PPMB
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCTS,PFLUC)
+C
+C
+      RETURN
+      END
+      SUBROUTINE LWVB_LMDAR4(KUAER,KTRAER, KLIM
+     R  , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP
+     R  , PDISD,PDISU,PEMIS,PPMB
+     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
+     S  , PCTS,PFLUC)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+#include "radopt.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
+C           INTEGRATION
+C
+C     METHOD.
+C     -------
+C
+C          1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
+C     ATMOSPHERE
+C          2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
+C     TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
+C          3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C        Voigt lines (loop 2413 to 2427)  - JJM & PhD - 01/96
+C-----------------------------------------------------------------------
+C
+C*       0.1   ARGUMENTS
+C              ---------
+C
+      INTEGER KUAER,KTRAER, KLIM
+C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL(KIND=8) PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
+      REAL(KIND=8) PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL(KIND=8) PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! PRESSURE MB
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+C
+      REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+C
+C* LOCAL VARIABLES:
+C
+      REAL(KIND=8) ZBGND(KDLON)
+      REAL(KIND=8) ZFD(KDLON)
+      REAL(KIND=8)  ZFN10(KDLON)
+      REAL(KIND=8) ZFU(KDLON)
+      REAL(KIND=8)  ZTT(KDLON,NTRA)
+      REAL(KIND=8) ZTT1(KDLON,NTRA)
+      REAL(KIND=8) ZTT2(KDLON,NTRA)
+      REAL(KIND=8)  ZUU(KDLON,NUA) 
+      REAL(KIND=8) ZCNSOL(KDLON)
+      REAL(KIND=8) ZCNTOP(KDLON)
+C
+      INTEGER jk, jl, ja
+      INTEGER jstra, jstru
+      INTEGER ind1, ind2, ind3, ind4, in, jlim
+      REAL(KIND=8) zctstr
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 122 JA=1,NTRA
+      DO 121 JL=1, KDLON
+      ZTT (JL,JA)=1.0
+      ZTT1(JL,JA)=1.0
+      ZTT2(JL,JA)=1.0
+ 121  CONTINUE
+ 122  CONTINUE
+C
+      DO 124 JA=1,NUA
+      DO 123 JL=1, KDLON
+      ZUU(JL,JA)=1.0
+ 123  CONTINUE
+ 124  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+C
+C
+C*         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
+C                  -----------------------------------
+C
+ 230  CONTINUE
+C
+      DO 235 JK = 1 , KFLEV
+      IN=(JK-1)*NG1P1+1
+C
+      DO 232 JA=1,KUAER
+      DO 231 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,IN)
+ 231  CONTINUE
+ 232  CONTINUE
+C
+C
+      CALL LWTT_LMDAR4(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
+C
+      DO 234 JL = 1, KDLON
+      ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
+     2      +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     3      +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     4      +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     5      +PBTOP(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
+     6      +PBTOP(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 234  CONTINUE
+C
+ 235  CONTINUE
+C
+      JK = KFLEV+1
+      IN=(JK-1)*NG1P1+1
+C
+      DO 236 JL = 1, KDLON
+      ZCNTOP(JL)= PBTOP(JL,1)
+     1   + PBTOP(JL,2)
+     2   + PBTOP(JL,3)
+     3   + PBTOP(JL,4)
+     4   + PBTOP(JL,5)
+     5   + PBTOP(JL,6)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 236  CONTINUE
+C
+C*         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
+C                  ---------------------------------------
+C
+ 240  CONTINUE
+C
+C
+C*         2.4.1   INITIALIZATION
+C                  --------------
+C
+ 2410 CONTINUE
+C
+      JLIM = KFLEV
+C
+      IF (.NOT.LEVOIGT) THEN
+      DO 2412 JK = KFLEV,1,-1
+      IF(PPMB(1,JK).LT.10.0) THEN
+         JLIM=JK
+      ENDIF   
+ 2412 CONTINUE
+      ENDIF
+      KLIM=JLIM
+C
+      IF (.NOT.LEVOIGT) THEN
+        DO 2414 JA=1,KTRAER
+        DO 2413 JL=1, KDLON
+        ZTT1(JL,JA)=1.0
+ 2413   CONTINUE
+ 2414   CONTINUE
+C
+C*         2.4.2   LOOP OVER LAYERS ABOVE 10 HPA
+C                  -----------------------------
+C
+ 2420   CONTINUE
+C
+        DO 2427 JSTRA = KFLEV,JLIM,-1
+        JSTRU=(JSTRA-1)*NG1P1+1
+C
+        DO 2423 JA=1,KUAER
+        DO 2422 JL=1, KDLON
+        ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
+ 2422   CONTINUE
+ 2423   CONTINUE
+C
+C
+        CALL LWTT_LMDAR4(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
+C
+        DO 2424 JL = 1, KDLON
+        ZCTSTR =
+     1   (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))
+     1       *(ZTT1(JL,1)           *ZTT1(JL,10)
+     1       - ZTT (JL,1)           *ZTT (JL,10))
+     2  +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))
+     2       *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11)
+     2       - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11))
+     3  +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))
+     3       *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12)
+     3       - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12))
+     4  +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))
+     4       *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13)
+     4       - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13))
+     5  +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))
+     5       *(ZTT1(JL,3)           *ZTT1(JL,14)
+     5       - ZTT (JL,3)           *ZTT (JL,14))
+     6  +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))
+     6       *(ZTT1(JL,6)           *ZTT1(JL,15)
+     6       - ZTT (JL,6)           *ZTT (JL,15))
+        PCTS(JL,JSTRA)=ZCTSTR*0.5
+ 2424   CONTINUE
+        DO 2426 JA=1,KTRAER
+        DO 2425 JL=1, KDLON
+        ZTT1(JL,JA)=ZTT(JL,JA)
+ 2425   CONTINUE
+ 2426   CONTINUE
+ 2427   CONTINUE
+      ENDIF
+C Mise a zero de securite pour PCTS en cas de LEVOIGT
+      IF(LEVOIGT)THEN
+        DO 2429 JSTRA = 1,KFLEV
+        DO 2428 JL = 1, KDLON
+          PCTS(JL,JSTRA)=0.
+ 2428   CONTINUE
+ 2429   CONTINUE
+      ENDIF
+C
+C
+C*         2.5     EXCHANGE WITH LOWER LIMIT
+C                  -------------------------
+C
+ 250  CONTINUE
+C
+      DO 251 JL = 1, KDLON
+      ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))
+     S               *PFLUC(JL,2,1)-PBINT(JL,1)
+ 251  CONTINUE
+C
+      JK = 1
+      IN=(JK-1)*NG1P1+1
+C
+      DO 252 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)
+     1 +PBSUR(JL,2)
+     2 +PBSUR(JL,3)
+     3 +PBSUR(JL,4)
+     4 +PBSUR(JL,5)
+     5 +PBSUR(JL,6)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 252  CONTINUE
+C
+      DO 257 JK = 2 , KFLEV+1
+      IN=(JK-1)*NG1P1+1
+C
+C
+      DO 255 JA=1,KUAER
+      DO 254 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
+ 254  CONTINUE
+ 255  CONTINUE
+C
+C
+      CALL LWTT_LMDAR4(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
+C
+      DO 256 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
+     2      +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     3      +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     4      +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     5      +PBSUR(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
+     6      +PBSUR(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 256  CONTINUE
+C
+C
+ 257  CONTINUE
+C
+C
+C
+C*         2.7     CLEAR-SKY FLUXES
+C                  ----------------
+C
+ 270  CONTINUE
+C
+      IF (.NOT.LEVOIGT) THEN
+      DO 271 JL = 1, KDLON
+      ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
+ 271  CONTINUE
+      DO 273 JK = JLIM+1,KFLEV+1
+      DO 272 JL = 1, KDLON
+      ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+      PFLUC(JL,1,JK) = ZFN10(JL)
+      PFLUC(JL,2,JK) = 0.
+ 272  CONTINUE
+ 273  CONTINUE
+      ENDIF
+C
+C     ------------------------------------------------------------------
+C
+      RETURN
+      END
+      SUBROUTINE LWVD_LMDAR4(KUAER,KTRAER
+     S  , PABCU,PDBDT
+     R  , PGA,PGB
+     S  , PCNTRB,PDISD,PDISU)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+C     CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C* ARGUMENTS:
+C
+      INTEGER KUAER,KTRAER
+C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+C
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
+      REAL(KIND=8) PDISD(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+      REAL(KIND=8) PDISU(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+C
+C* LOCAL VARIABLES:
+C
+      REAL(KIND=8) ZGLAYD(KDLON)
+      REAL(KIND=8) ZGLAYU(KDLON)
+      REAL(KIND=8) ZTT(KDLON,NTRA)
+      REAL(KIND=8) ZTT1(KDLON,NTRA)
+      REAL(KIND=8) ZTT2(KDLON,NTRA)
+C
+      INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
+      INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
+      INTEGER ind1, ind2, ind3, ind4, itt
+      REAL(KIND=8) zww, zdzxdg, zdzxmg
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+C                  ------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1, KFLEV+1
+      DO 111 JL = 1, KDLON
+      PDISD(JL,JK) = 0.
+      PDISU(JL,JK) = 0.
+  111 CONTINUE
+  112 CONTINUE
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+C
+      DO 122 JA = 1, NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+  121 CONTINUE
+  122 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+C
+C
+C*         2.2     CONTRIBUTION FROM DISTANT LAYERS
+C                  ---------------------------------
+C
+ 220  CONTINUE
+C
+C
+C*         2.2.1   DISTANT AND ABOVE LAYERS
+C                  ------------------------
+C
+ 2210 CONTINUE
+C
+C
+C
+C*         2.2.2   FIRST UPPER LEVEL
+C                  -----------------
+C
+ 2220 CONTINUE
+C
+      DO 225 JK = 1 , KFLEV-1
+      IKP1=JK+1
+      IKN=(JK-1)*NG1P1+1
+      IKD1= JK  *NG1P1+1
+C
+      CALL LWTTM_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK)
+     2          , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
+C
+C
+C
+C*         2.2.3   HIGHER UP
+C                  ---------
+C
+ 2230 CONTINUE
+C
+      ITT=1
+      DO 224 JKJ=IKP1,KFLEV
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IKJP1=JKJ+1
+      IKD2= JKJ  *NG1P1+1
+C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
+     2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
+      ELSE
+         CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
+     2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
+      ENDIF
+C
+      DO 2235 JA = 1, KTRAER
+      DO 2234 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2234 CONTINUE
+ 2235 CONTINUE
+C
+      DO 2236 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)
+     S   +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S   +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S   +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S   +PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)
+     S   +PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZWW
+      ZDZXDG=ZGLAYD(JL)
+      PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
+      PCNTRB(JL,JK,IKJP1)=ZDZXDG
+ 2236 CONTINUE
+C
+C
+ 224  CONTINUE
+ 225  CONTINUE
+C
+C
+C*         2.2.4   DISTANT AND BELOW LAYERS
+C                  ------------------------
+C
+ 2240 CONTINUE
+C
+C
+C
+C*         2.2.5   FIRST LOWER LEVEL
+C                  -----------------
+C
+ 2250 CONTINUE
+C
+      DO 228 JK=3,KFLEV+1
+      IKN=(JK-1)*NG1P1+1
+      IKM1=JK-1
+      IKJ=JK-2
+      IKU1= IKJ  *NG1P1+1
+C
+C
+      CALL LWTTM_LMDAR4(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)
+     2          , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
+C
+C
+C
+C*         2.2.6   DOWN BELOW
+C                  ----------
+C
+ 2260 CONTINUE
+C
+      ITT=1
+      DO 227 JLK=1,IKJ
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IJKL=IKM1-JLK
+      IKU2=(IJKL-1)*NG1P1+1
+C
+C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
+     2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
+      ELSE
+         CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
+     2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
+      ENDIF
+C
+      DO 2265 JA = 1, KTRAER
+      DO 2264 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2264 CONTINUE
+ 2265 CONTINUE
+C
+      DO 2266 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)
+     S   +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S   +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S   +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S   +PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)
+     S   +PDBDT(JL,6,IJKL)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZWW
+      ZDZXMG=ZGLAYU(JL)
+      PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
+      PCNTRB(JL,JK,IJKL)=ZDZXMG
+ 2266 CONTINUE
+C
+C
+ 227  CONTINUE
+ 228  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE LWVN_LMDAR4(KUAER,KTRAER
+     R  , PABCU,PDBSL,PGA,PGB
+     S  , PADJD,PADJU,PCNTRB,PDBDT)
+       USE dimphy
+      USE radiation_AR4_param, only : WG1
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
+C           TO GIVE LONGWAVE FLUXES OR RADIANCES
+C
+C     METHOD.
+C     -------
+C
+C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+C     CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 89-07-14
+C-----------------------------------------------------------------------
+C
+C* ARGUMENTS:
+C
+      INTEGER KUAER,KTRAER
+C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+C
+      REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) !  LAYER PLANCK FUNCTION GRADIENT
+C
+C* LOCAL ARRAYS:
+C
+      REAL(KIND=8) ZGLAYD(KDLON)
+      REAL(KIND=8) ZGLAYU(KDLON)
+      REAL(KIND=8) ZTT(KDLON,NTRA)
+      REAL(KIND=8) ZTT1(KDLON,NTRA)
+      REAL(KIND=8) ZTT2(KDLON,NTRA)
+      REAL(KIND=8) ZUU(KDLON,NUA)
+C
+      INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
+      INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
+      REAL(KIND=8) zwtr
+c
+
+C-----------------------------------------------------------------------
+C
+C*         1.    INITIALIZATION
+C                --------------
+C
+ 100  CONTINUE
+C
+C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+C                  ------------------------------
+C
+ 110  CONTINUE
+C
+      DO 112 JK = 1 , KFLEV+1
+      DO 111 JL = 1, KDLON
+      PADJD(JL,JK) = 0.
+      PADJU(JL,JK) = 0.
+ 111  CONTINUE
+ 112  CONTINUE
+C
+C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+C                  ---------------------------------
+C
+ 120  CONTINUE
+C
+      DO 122 JA = 1 , NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+ 121  CONTINUE
+ 122  CONTINUE
+C
+      DO 124 JA = 1 , NUA
+      DO 123 JL = 1, KDLON
+      ZUU(JL,JA) = 0.
+ 123  CONTINUE
+ 124  CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.      VERTICAL INTEGRATION
+C                  --------------------
+C
+ 200  CONTINUE
+C
+C
+C*         2.1     CONTRIBUTION FROM ADJACENT LAYERS
+C                  ---------------------------------
+C
+ 210  CONTINUE
+C
+      DO 215 JK = 1 , KFLEV
+C
+C*         2.1.1   DOWNWARD LAYERS
+C                  ---------------
+C
+ 2110 CONTINUE
+C
+      IM12 = 2 * (JK - 1)
+      IND = (JK - 1) * NG1P1 + 1
+      IXD = IND
+      INU = JK * NG1P1 + 1
+      IXU = IND
+C
+      DO 2111 JL = 1, KDLON
+      ZGLAYD(JL) = 0.
+      ZGLAYU(JL) = 0.
+ 2111 CONTINUE
+C
+      DO 213 JG = 1 , NG1
+      IBS = IM12 + JG
+      IDD = IXD + JG
+      DO 2113 JA = 1 , KUAER
+      DO 2112 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
+ 2112 CONTINUE
+ 2113 CONTINUE
+C
+C
+      CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+C
+      DO 2114 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
+     S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
+     S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
+ 2114 CONTINUE
+C
+C*         2.1.2   DOWNWARD LAYERS
+C                  ---------------
+C
+ 2120 CONTINUE
+C
+      IMU = IXU + JG
+      DO 2122 JA = 1 , KUAER
+      DO 2121 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
+ 2121 CONTINUE
+ 2122 CONTINUE
+C
+C
+      CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+C
+      DO 2123 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
+     S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
+     S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
+     S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
+     S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
+     S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
+ 2123 CONTINUE
+C
+ 213  CONTINUE
+C
+      DO 214 JL = 1, KDLON
+      PADJD(JL,JK) = ZGLAYD(JL)
+      PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
+      PADJU(JL,JK+1) = ZGLAYU(JL)
+      PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
+      PCNTRB(JL,JK  ,JK) = 0.0
+ 214  CONTINUE
+C
+ 215  CONTINUE
+C
+      DO 218 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 217 JNU = 1 , Ninter
+      DO 216 JL = 1, KDLON
+      PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
+ 216  CONTINUE
+ 217  CONTINUE
+ 218  CONTINUE
+C
+      RETURN
+C
+      END
+      SUBROUTINE LWTT_LMDAR4(PGA,PGB,PUU, PTT)
+       USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C-----------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C
+C-----------------------------------------------------------------------
+      REAL(KIND=8) O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL(KIND=8) RPIALF0
+      PARAMETER (RPIALF0=2.0)
+C
+C* ARGUMENTS:
+C
+      REAL(KIND=8) PUU(KDLON,NUA)
+      REAL(KIND=8) PTT(KDLON,NTRA)
+      REAL(KIND=8) PGA(KDLON,8,2)
+      REAL(KIND=8) PGB(KDLON,8,2)
+C
+C* LOCAL VARIABLES:
+C
+      REAL(KIND=8) zz, zxd, zxn
+      REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
+      REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
+      REAL(KIND=8) zx, zy, zsq1, zsq2, zvxy, zuxy
+      REAL(KIND=8) zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
+      REAL(KIND=8) zsqn21, zodn21, zsqh42, zodh42
+      REAL(KIND=8) zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
+      REAL(KIND=8) zuu11, zuu12, za11, za12
+      INTEGER jl, ja
+C     ------------------------------------------------------------------
+C
+C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+C                 -----------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+!cdir collapse
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU(JL,JA))
+c     ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
+c     ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
+c     PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+C                 ---------------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+C
+C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+C
+      ZPU   = 0.002 * PUU(JL,10)
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   =  PUU(JL,11)
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+C
+C-  OZONE ABSORPTION
+C
+      ZX = PUU(JL,12)
+      ZY = PUU(JL,13)
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = PUU(JL,17) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+C
+C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+C
+C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+c     NEXOTIC=1
+c     IF (NEXOTIC.EQ.1) THEN
+      ZXCH4 = PUU(JL,19)
+      ZYCH4 = PUU(JL,20)
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+C
+C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXN2O = PUU(JL,21)
+      ZYN2O = PUU(JL,22)
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+C
+C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+C
+C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+C
+C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA11 = 2. * PUU(JL,23) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+C
+C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA12 = 2. * PUU(JL,24) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+C
+      ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10
+      ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - PUU(JL,14) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 )
+ 201  CONTINUE
+C
+      RETURN
+      END
+      SUBROUTINE LWTTM_LMDAR4(PGA,PGB,PUU1,PUU2, PTT)
+      USE dimphy
+      IMPLICIT none
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+cym#include "raddim.h"
+#include "raddimlw.h"
+C
+C     ------------------------------------------------------------------
+C     PURPOSE.
+C     --------
+C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+C     INTERVALS.
+C
+C     METHOD.
+C     -------
+C
+C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+C
+C     REFERENCE.
+C     ----------
+C
+C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+C
+C     AUTHOR.
+C     -------
+C        JEAN-JACQUES MORCRETTE  *ECMWF*
+C
+C     MODIFICATIONS.
+C     --------------
+C        ORIGINAL : 88-12-15
+C
+C-----------------------------------------------------------------------
+      REAL(KIND=8) O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL(KIND=8) RPIALF0
+      PARAMETER (RPIALF0=2.0)
+C
+C* ARGUMENTS:
+C
+      REAL(KIND=8) PGA(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
+      REAL(KIND=8) PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
+      REAL(KIND=8) PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS
+C
+C* LOCAL VARIABLES:
+C
+      INTEGER ja, jl
+      REAL(KIND=8) zz, zxd, zxn
+      REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
+      REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
+      REAL(KIND=8) zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
+      REAL(KIND=8) zxch4, zych4, zsqh41, zodh41
+      REAL(KIND=8) zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
+      REAL(KIND=8) zsqn22, zodn22, za11, zttf11, za12, zttf12
+      REAL(KIND=8) zuu11, zuu12
+C     ------------------------------------------------------------------
+C
+C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+C                 -----------------------------------------------
+C
+ 100  CONTINUE
+C
+C
+
+!CDIR ON_ADB(PUU1)
+!CDIR ON_ADB(PUU2)
+!CDIR COLLAPSE
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU1(JL,JA) - PUU2(JL,JA))
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+C
+C     ------------------------------------------------------------------
+C
+C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+C                 ---------------------------------------------------
+C
+ 200  CONTINUE
+C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+C
+C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+C
+      ZPU   = 0.002 * (PUU1(JL,10) - PUU2(JL,10))
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   = (PUU1(JL,11) - PUU2(JL,11))
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+C
+C-  OZONE ABSORPTION
+C
+      ZX = (PUU1(JL,12) - PUU2(JL,12))
+      ZY = (PUU1(JL,13) - PUU2(JL,13))
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+C
+C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+C
+C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))
+      ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+C
+C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZXN2O = (PUU1(JL,21) - PUU2(JL,21))
+      ZYN2O = (PUU1(JL,22) - PUU2(JL,22))
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+C
+C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+C
+C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+C
+C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+C
+C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+C
+      ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+C
+      ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10
+      ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -
+     S         ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )
+ 201  CONTINUE
+C
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/radiation_AR4.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/radiation_AR4.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/radiation_AR4.F90	(revision 17)
@@ -0,0 +1,6103 @@
+!IM ctes ds clesphys.h   SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, 
+MODULE radiation_AR4
+
+  CONTAINS
+
+      SUBROUTINE SW_LMDAR4(PSCT, PRMU0, PFRAC,                                       &
+       &              PPMB, PDP,                                                     &
+       &              PPSOL, PALBD, PALBP,                                           &
+       &              PTAVE, PWV, PQS, POZON, PAER,                                  &
+       &              PCLDSW, PTAU, POMEGA, PCG,                                     &
+       &              PHEAT, PHEAT0,                                                 &
+       &              PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,                         &
+       &              ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,                                     &
+       &              tauae, pizae, cgae,                                            &
+       &              PTAUA, POMEGAA,                                                &
+       &              PTOPSWAD,PSOLSWAD,PTOPSWAI,PSOLSWAI,                           &
+       &              ok_ade, ok_aie )
+      USE dimphy      
+      IMPLICIT none
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "YOMCST.h"
+#include "iniprint.h"
+!C
+!C     ------------------------------------------------------------------
+!C
+!C     PURPOSE.
+!C     --------
+!C
+!C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+!C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
+!C          2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL  (SW1S)
+!C          3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL  (SW2S)
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+!C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        95-01-01   J.-J. MORCRETTE  Direct/Diffuse Albedo
+!c        03-11-27   J. QUAAS Introduce aerosol forcings (based on BOUCHER)
+!C     ------------------------------------------------------------------
+!C
+!C* ARGUMENTS:
+!C
+      REAL(KIND=8) PSCT  ! constante solaire (valeur conseillee: 1370)
+!IM ctes ds clesphys.h   REAL(KIND=8) RCO2  ! concentration CO2 (IPCC: 353.E-06*44.011/28.97)
+#include "clesphys.h"
+!C
+      REAL(KIND=8) PPSOL(KDLON)        ! SURFACE PRESSURE (PA)
+      REAL(KIND=8) PDP(KDLON,KFLEV)    ! LAYER THICKNESS (PA)
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+!C
+      REAL(KIND=8) PRMU0(KDLON)  ! COSINE OF ZENITHAL ANGLE
+      REAL(KIND=8) PFRAC(KDLON)  ! fraction de la journee
+!C
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)  ! LAYER TEMPERATURE (K)
+      REAL(KIND=8) PWV(KDLON,KFLEV)    ! SPECIFIC HUMIDITY (KG/KG)
+      REAL(KIND=8) PQS(KDLON,KFLEV)    ! SATURATED WATER VAPOUR (KG/KG)
+      REAL(KIND=8) POZON(KDLON,KFLEV)  ! OZONE CONCENTRATION (KG/KG)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
+!C
+      REAL(KIND=8) PALBD(KDLON,2)  ! albedo du sol (lumiere diffuse)
+      REAL(KIND=8) PALBP(KDLON,2)  ! albedo du sol (lumiere parallele)
+!C
+      REAL(KIND=8) PCLDSW(KDLON,KFLEV)    ! CLOUD FRACTION
+      REAL(KIND=8) PTAU(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS
+      REAL(KIND=8) PCG(KDLON,2,KFLEV)     ! ASYMETRY FACTOR
+      REAL(KIND=8) POMEGA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+!C
+      REAL(KIND=8) PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
+      REAL(KIND=8) PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
+      REAL(KIND=8) PALBPLA(KDLON)     ! PLANETARY ALBEDO
+      REAL(KIND=8) PTOPSW(KDLON)      ! SHORTWAVE FLUX AT T.O.A.
+      REAL(KIND=8) PSOLSW(KDLON)      ! SHORTWAVE FLUX AT SURFACE
+      REAL(KIND=8) PTOPSW0(KDLON)     ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
+      REAL(KIND=8) PSOLSW0(KDLON)     ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
+!C
+!C* LOCAL VARIABLES:
+!C
+      real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
+
+      REAL(KIND=8) ZOZ(KDLON,KFLEV)
+!     column-density of ozone in layer, in kilo-Dobsons
+
+      REAL(KIND=8) ZAKI(KDLON,2)     
+      REAL(KIND=8) ZCLD(KDLON,KFLEV)
+      REAL(KIND=8) ZCLEAR(KDLON) 
+      REAL(KIND=8) ZDSIG(KDLON,KFLEV)
+      REAL(KIND=8) ZFACT(KDLON)
+      REAL(KIND=8) ZFD(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFDOWN(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFU(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFUP(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRMU(KDLON)
+      REAL(KIND=8) ZSEC(KDLON)
+      REAL(KIND=8) ZUD(KDLON,5,KFLEV+1)
+      REAL(KIND=8) ZCLDSW0(KDLON,KFLEV)
+!c
+      REAL(KIND=8) ZFSUP(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFSDN(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1)
+!C
+      INTEGER inu, jl, jk, i, k, kpl1
+!c
+      INTEGER swpas  ! Every swpas steps, sw is calculated
+      PARAMETER(swpas=1)
+!c
+      INTEGER itapsw
+      LOGICAL appel1er
+      DATA itapsw /0/
+      DATA appel1er /.TRUE./
+      SAVE itapsw,appel1er
+!$OMP THREADPRIVATE(appel1er)
+!$OMP THREADPRIVATE(itapsw)
+!cjq-Introduced for aerosol forcings
+      real(kind=8) flag_aer
+      logical ok_ade, ok_aie    ! use aerosol forcings or not?
+      real(kind=8) tauae(kdlon,kflev,2)  ! aerosol optical properties
+      real(kind=8) pizae(kdlon,kflev,2)  ! (see aeropt.F)
+      real(kind=8) cgae(kdlon,kflev,2)   ! -"-
+      REAL(KIND=8) PTAUA(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS (pre-industrial value)
+      REAL(KIND=8) POMEGAA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+      REAL(KIND=8) PTOPSWAD(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
+      REAL(KIND=8) PSOLSWAD(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
+      REAL(KIND=8) PTOPSWAI(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
+      REAL(KIND=8) PSOLSWAI(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
+!cjq - Fluxes including aerosol effects
+      REAL(KIND=8),allocatable,save :: ZFSUPAD(:,:)
+!$OMP THREADPRIVATE(ZFSUPAD)
+      REAL(KIND=8),allocatable,save :: ZFSDNAD(:,:)
+!$OMP THREADPRIVATE(ZFSDNAD)
+      REAL(KIND=8),allocatable,save :: ZFSUPAI(:,:)
+!$OMP THREADPRIVATE(ZFSUPAI)
+      REAL(KIND=8),allocatable,save :: ZFSDNAI(:,:)
+!$OMP THREADPRIVATE(ZFSDNAI)
+      logical initialized
+!cym      SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes
+!rv
+      save flag_aer
+!$OMP THREADPRIVATE(flag_aer)
+      data initialized/.false./
+      save initialized
+!$OMP THREADPRIVATE(initialized)
+!cjq-end
+      REAL tmp_
+      if(.not.initialized) then
+        flag_aer=0.
+        initialized=.TRUE.
+        allocate(ZFSUPAD(KDLON,KFLEV+1))
+        allocate(ZFSDNAD(KDLON,KFLEV+1))
+        allocate(ZFSUPAI(KDLON,KFLEV+1))
+        allocate(ZFSDNAI(KDLON,KFLEV+1))
+
+        ZFSUPAD(:,:)=0.
+        ZFSDNAD(:,:)=0.
+        ZFSUPAI(:,:)=0.
+        ZFSDNAI(:,:)=0.
+      endif
+
+      IF (appel1er) THEN
+         WRITE(lunout,*) 'SW calling frequency : ', swpas
+         WRITE(lunout,*) "   In general, it should be 1"
+         appel1er = .FALSE.
+      ENDIF
+!C     ------------------------------------------------------------------
+      IF (MOD(itapsw,swpas).EQ.0) THEN
+!c
+      tmp_ = 1./( dobson_u * 1e3 * RG)
+!cdir collapse
+      DO JK = 1 , KFLEV
+        DO JL = 1, KDLON
+          ZCLDSW0(JL,JK) = 0.0
+          ZOZ(JL,JK) = POZON(JL,JK)*tmp_*PDP(JL,JK)
+        ENDDO
+      ENDDO
+!C
+!C
+!c clear-sky:
+!IM ctes ds clesphys.h  CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL,
+      CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,                                       &
+       &         PRMU0,PFRAC,PTAVE,PWV,                                              &
+       &         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,                               &
+       &     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,                              &
+       &     ZFD, ZFU)
+      INU = 2
+      CALL SW2S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,                         &
+       &     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,                              &
+       &     PWV, PQS,                                                               &
+       &     ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP0(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      
+      flag_aer=0.0
+      CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,                                        &
+       &         PRMU0,PFRAC,PTAVE,PWV,                                              &
+       &         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,                                &
+       &     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,                              &
+       &     ZFD, ZFU)
+      INU = 2
+      CALL SW2S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,                          &
+       &     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,                              &
+       &     PWV, PQS,                                                               &
+       &    ZFDOWN, ZFUP)
+
+!c cloudy-sky:
+      
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      
+!c      
+      IF (ok_ade) THEN
+!c
+!c cloudy-sky + aerosol dir OB
+      flag_aer=1.0
+      CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,                                        &
+       &         PRMU0,PFRAC,PTAVE,PWV,                                              &
+       &         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,                                &
+       &     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,                              &
+       &     ZFD, ZFU)
+      INU = 2
+      CALL SW2S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,                          &
+       &     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,                              &
+       &     PWV, PQS,                                                               &
+       &    ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUPAD(JL,JK) = ZFSUP(JL,JK) 
+         ZFSDNAD(JL,JK) = ZFSDN(JL,JK) 
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO 
+      
+      ENDIF ! ok_ade
+      
+      IF (ok_aie) THEN
+         
+!cjq   cloudy-sky + aerosol direct + aerosol indirect
+      flag_aer=1.0
+      CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,                                        &
+       &         PRMU0,PFRAC,PTAVE,PWV,                                              &
+       &         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,                                &
+       &     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,                            &
+       &     ZFD, ZFU)
+      INU = 2
+      CALL SW2S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,                          &
+       &     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,                            &
+       &     PWV, PQS,                                                               &
+       &    ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUPAI(JL,JK) = ZFSUP(JL,JK) 
+         ZFSDNAI(JL,JK) = ZFSDN(JL,JK)          
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      ENDIF ! ok_aie      
+!cjq -end
+      
+      itapsw = 0
+      ENDIF
+      itapsw = itapsw + 1
+!C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))                                 &
+       &                     -(ZFSDN(i,k)-ZFSDN(i,kpl1))
+            PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))                              &
+       &                     -(ZFSDN0(i,k)-ZFSDN0(i,kpl1))
+            PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20)
+!c
+         PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1)
+         PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1)
+!c
+         PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1)
+         PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1)
+!c-OB
+         PSOLSWAD(i) = ZFSDNAD(i,1) - ZFSUPAD(i,1)
+         PTOPSWAD(i) = ZFSDNAD(i,KFLEV+1) - ZFSUPAD(i,KFLEV+1)
+!c
+         PSOLSWAI(i) = ZFSDNAI(i,1) - ZFSUPAI(i,1)
+         PTOPSWAI(i) = ZFSDNAI(i,KFLEV+1) - ZFSUPAI(i,KFLEV+1)
+!c-fin 
+      ENDDO
+!C
+      RETURN
+      END SUBROUTINE SW_LMDAR4
+!c
+!IM ctes ds clesphys.h   SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
+      SUBROUTINE SWU_LMDAR4 (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,                     &
+       &                PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT,                      &
+       &                PRMU,PSEC,PUD)
+      USE dimphy
+      USE radiation_AR4_param, only :                                                &
+       &     ZPDH2O,ZPDUMG,ZPRH2O,ZPRUMG,RTDH2O,RTDUMG,RTH2O,RTUMG
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+#include "YOMCST.h"
+!C
+!C* ARGUMENTS:
+!C
+      REAL(KIND=8) PSCT
+!IM ctes ds clesphys.h   REAL(KIND=8) RCO2
+#include "clesphys.h"
+      REAL(KIND=8) PCLDSW(KDLON,KFLEV)
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1)
+      REAL(KIND=8) PPSOL(KDLON)
+      REAL(KIND=8) PRMU0(KDLON)
+      REAL(KIND=8) PFRAC(KDLON)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)
+      REAL(KIND=8) PWV(KDLON,KFLEV)
+!C
+      REAL(KIND=8) PAKI(KDLON,2)
+      REAL(KIND=8) PCLD(KDLON,KFLEV)
+      REAL(KIND=8) PCLEAR(KDLON)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) PFACT(KDLON)
+      REAL(KIND=8) PRMU(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+      REAL(KIND=8) PUD(KDLON,5,KFLEV+1)
+!C
+!C* LOCAL VARIABLES:
+!C
+      INTEGER IIND(2)
+      REAL(KIND=8) ZC1J(KDLON,KFLEV+1)
+      REAL(KIND=8) ZCLEAR(KDLON)
+      REAL(KIND=8) ZCLOUD(KDLON)
+      REAL(KIND=8) ZN175(KDLON)
+      REAL(KIND=8) ZN190(KDLON)
+      REAL(KIND=8) ZO175(KDLON)
+      REAL(KIND=8) ZO190(KDLON)
+      REAL(KIND=8) ZSIGN(KDLON)
+      REAL(KIND=8) ZR(KDLON,2) 
+      REAL(KIND=8) ZSIGO(KDLON)
+      REAL(KIND=8) ZUD(KDLON,2)
+      REAL(KIND=8) ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW
+      INTEGER jl, jk, jkp1, jkl, jklp1, ja
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         1.     COMPUTES AMOUNTS OF ABSORBERS
+!C                 -----------------------------
+!C
+ 100  CONTINUE
+!C
+      IIND(1)=1
+      IIND(2)=2
+!C      
+!C
+!C*         1.1    INITIALIZES QUANTITIES
+!C                 ----------------------
+!C
+ 110  CONTINUE
+!C
+      DO 111 JL = 1, KDLON
+      PUD(JL,1,KFLEV+1)=0.
+      PUD(JL,2,KFLEV+1)=0.
+      PUD(JL,3,KFLEV+1)=0.
+      PUD(JL,4,KFLEV+1)=0.
+      PUD(JL,5,KFLEV+1)=0.
+      PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT
+      PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
+      PSEC(JL)=1./PRMU(JL)
+      ZC1J(JL,KFLEV+1)=0.
+ 111  CONTINUE
+!C
+!C*          1.3    AMOUNTS OF ABSORBERS
+!C                  --------------------
+!C
+ 130  CONTINUE
+!C
+      DO 131 JL= 1, KDLON
+      ZUD(JL,1) = 0.
+      ZUD(JL,2) = 0.
+      ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.)
+      ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.)
+      ZSIGO(JL) = PPSOL(JL)
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 131  CONTINUE
+!C
+      DO 133 JK = 1 , KFLEV
+      JKP1 = JK + 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL+1
+      DO 132 JL = 1, KDLON
+      ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O
+      ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG
+      ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZSIGN(JL) = 100. * PPMB(JL,JKP1)
+      PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)
+      ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)
+      ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)
+      ZDSCO2 = ZO175(JL) - ZN175(JL)
+      ZDSH2O = ZO190(JL) - ZN190(JL)
+      PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)                   &
+       &             * ZDSH2O * ZWH2O  * ZRTH
+      PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)                   &
+       &             * ZDSCO2 * RCO2 * ZRTU
+      ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O)
+      PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW
+      PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)
+      ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)
+      ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)
+      ZSIGO(JL) = ZSIGN(JL)
+      ZO175(JL) = ZN175(JL)
+      ZO190(JL) = ZN190(JL)
+!C      
+      IF (NOVLP.EQ.1) THEN
+         ZCLEAR(JL)=ZCLEAR(JL)                                                       &
+       &               *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))                          &
+       &               /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDSW(JL,JKL)
+      ELSE IF (NOVLP.EQ.2) THEN
+         ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 132  CONTINUE
+ 133  CONTINUE
+      DO 134 JL=1, KDLON
+      PCLEAR(JL)=1.-ZC1J(JL,1)
+ 134  CONTINUE
+      DO 136 JK=1,KFLEV
+      DO 135 JL=1, KDLON
+      IF (PCLEAR(JL).LT.1.) THEN
+         PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))
+      ELSE
+         PCLD(JL,JK)=0.
+      END IF
+ 135  CONTINUE
+ 136  CONTINUE           
+!C      
+!C
+!C*         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
+!C                 -----------------------------------------------
+!C
+ 140  CONTINUE
+!C
+      DO 142 JA = 1,2
+      DO 141 JL = 1, KDLON
+      ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)
+ 141  CONTINUE
+ 142  CONTINUE
+!C
+      CALL SWTT1_LMDAR4(2, 2, IIND, ZUD, ZR)
+!C
+      DO 144 JA = 1,2
+      DO 143 JL = 1, KDLON
+      PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)
+ 143  CONTINUE
+ 144  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE SWU_LMDAR4
+
+      SUBROUTINE SW1S_LMDAR4 ( KNU                                                   &
+       &  ,  PAER  , flag_aer, tauae, pizae, cgae                                    &
+       &  ,  PALBD , PALBP, PCG  , PCLD , PCLEAR, PCLDSW                             &
+       &  ,  PDSIG , POMEGA, POZ  , PRMU , PSEC , PTAU  , PUD                        &
+       &  ,  PFD   , PFU)
+      USE dimphy
+      USE radiation_AR4_param, only : RSUN, RRAY
+      USE infotrac, ONLY : type_trac
+#ifdef REPROBUS
+      USE CHEM_REP, ONLY : RSUNTIME, ok_SUNTIME
+#endif
+
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"i
+#include "iniprint.h"
+!C
+!C     ------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C
+!C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+!C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
+!C     CONTINUUM SCATTERING
+!C          2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+!C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+!C     ------------------------------------------------------------------
+!C
+!C* ARGUMENTS:
+!C
+      INTEGER KNU
+!c-OB
+      real(kind=8) flag_aer
+      real(kind=8) tauae(kdlon,kflev,2)
+      real(kind=8) pizae(kdlon,kflev,2)
+      real(kind=8) cgae(kdlon,kflev,2)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)
+      REAL(KIND=8) PALBD(KDLON,2)
+      REAL(KIND=8) PALBP(KDLON,2)
+      REAL(KIND=8) PCG(KDLON,2,KFLEV)  
+      REAL(KIND=8) PCLD(KDLON,KFLEV)
+      REAL(KIND=8) PCLDSW(KDLON,KFLEV)
+      REAL(KIND=8) PCLEAR(KDLON)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) POMEGA(KDLON,2,KFLEV)
+      REAL(KIND=8) POZ(KDLON,KFLEV)
+      REAL(KIND=8) PRMU(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+      REAL(KIND=8) PTAU(KDLON,2,KFLEV)
+      REAL(KIND=8) PUD(KDLON,5,KFLEV+1)
+!C
+      REAL(KIND=8) PFD(KDLON,KFLEV+1)
+      REAL(KIND=8) PFU(KDLON,KFLEV+1)
+!C
+!C* LOCAL VARIABLES:
+!C
+      INTEGER IIND(4)
+!C      
+      REAL(KIND=8) ZCGAZ(KDLON,KFLEV) 
+      REAL(KIND=8) ZDIFF(KDLON)
+      REAL(KIND=8) ZDIRF(KDLON)        
+      REAL(KIND=8) ZPIZAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZRAYL(KDLON)
+      REAL(KIND=8) ZRAY1(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRAY2(KDLON,KFLEV+1)
+      REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1)
+      REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRK(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRMUE(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRMU0(KDLON,KFLEV+1)
+      REAL(KIND=8) ZR(KDLON,4)
+      REAL(KIND=8) ZTAUAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZTRA1(KDLON,KFLEV+1)
+      REAL(KIND=8) ZTRA2(KDLON,KFLEV+1)
+      REAL(KIND=8) ZW(KDLON,4)
+!C
+      INTEGER jl, jk, k, jaj, ikm1, ikl
+
+!C If running with Reporbus, overwrite default values of RSUN. 
+!C Otherwise keep default values from radiation_AR4_param module.  
+      IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+         IF (ok_SUNTIME) THEN
+            RSUN(1) = RSUNTIME(1)
+            RSUN(2) = RSUNTIME(2)
+         ENDIF
+         WRITE(lunout,*)'RSUN(1): ',RSUN(1)
+#endif
+      END IF
+
+!C     ------------------------------------------------------------------
+!C
+!C*         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
+!C                 ----------------------- ------------------
+!C
+ 100  CONTINUE
+!C
+!C
+!C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+!C                 -----------------------------------------
+!C
+ 110  CONTINUE
+!C
+      DO 111 JL = 1, KDLON
+      ZRAYL(JL) =  RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL)                  &
+       &          * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL)                &
+       &          * (RRAY(KNU,5) + PRMU(JL) *  RRAY(KNU,6)       ))))
+ 111  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.    CONTINUUM SCATTERING CALCULATIONS
+!C                ---------------------------------
+!C
+ 200  CONTINUE
+!C
+!C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+!C                --------------------------------
+!C  
+ 210  CONTINUE
+!C
+      CALL SWCLR_LMDAR4 ( KNU                                                        &
+       &  , PAER   , flag_aer, tauae, pizae, cgae                                    &
+       &  , PALBP  , PDSIG , ZRAYL, PSEC                                             &
+       &  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0                              &
+       &  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+!C
+!C
+!C*         2.2   CLOUDY FRACTION OF THE COLUMN
+!C                -----------------------------
+!C
+ 220  CONTINUE
+!C
+      CALL SWR_LMDAR4 ( KNU                                                          &
+       &  , PALBD ,PCG   ,PCLD  ,PDSIG ,POMEGA,ZRAYL                                 &
+       &  , PSEC  ,PTAU                                                              &
+       &  , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ  ,ZRK,ZRMUE                       &
+       &  , ZTAUAZ,ZTRA1 ,ZTRA2)
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.    OZONE ABSORPTION
+!C                ----------------
+!C
+ 300  CONTINUE
+!C
+      IIND(1)=1
+      IIND(2)=3
+      IIND(3)=1
+      IIND(4)=3
+!C      
+!C
+!C*         3.1   DOWNWARD FLUXES
+!C                ---------------
+!C
+ 310  CONTINUE
+!C
+      JAJ = 2
+!C
+      DO 311 JL = 1, KDLON
+      ZW(JL,1)=0.
+      ZW(JL,2)=0.
+      ZW(JL,3)=0.
+      ZW(JL,4)=0.
+      PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1)                           &
+       &     + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU)
+ 311  CONTINUE
+      DO 314 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 312 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL)
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+ 312  CONTINUE
+!C
+      CALL SWTT1_LMDAR4(KNU, 4, IIND, ZW, ZR)
+!C
+      DO 313 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL)
+      PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL)                                     &
+       &                  +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 313  CONTINUE
+ 314  CONTINUE
+!C
+!C
+!C*         3.2   UPWARD FLUXES
+!C                -------------
+!C
+ 320  CONTINUE
+!C
+      DO 325 JL = 1, KDLON
+      PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU)                           &
+       &               + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU))                        &
+       &          * RSUN(KNU)
+ 325  CONTINUE
+!C
+      DO 328 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 326 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKM1)*1.66
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKM1)*1.66
+ 326  CONTINUE
+!C
+      CALL SWTT1_LMDAR4(KNU, 4, IIND, ZW, ZR)
+!C
+      DO 327 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK)
+      PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL)                                      &
+       &                 +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 327  CONTINUE
+ 328  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE SW1S_LMDAR4
+      SUBROUTINE SW2S_LMDAR4 ( KNU                                                   &
+       &  ,  PAER  , flag_aer, tauae, pizae, cgae                                    &
+       &  ,  PAKI, PALBD, PALBP, PCG   , PCLD, PCLEAR, PCLDSW                        &
+       &  ,  PDSIG ,POMEGA,POZ , PRMU , PSEC  , PTAU                                 &
+       &  ,  PUD   ,PWV , PQS                                                        &
+       &  ,  PFDOWN,PFUP                                            )
+      USE dimphy
+      USE radiation_AR4_param, only : RSUN, RRAY
+      USE infotrac, ONLY : type_trac
+#ifdef REPROBUS
+      use CHEM_REP, only : RSUNTIME, ok_SUNTIME
+#endif
+
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "radepsi.h"
+!C
+!C     ------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C
+!C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
+!C     SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
+!C     CONTINUUM SCATTERING
+!C          2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
+!C     A GREY MOLECULAR ABSORPTION
+!C          3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
+!C     OF ABSORBERS
+!C          4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
+!C          5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+!C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+!C     ------------------------------------------------------------------
+!C* ARGUMENTS:
+!C
+      INTEGER KNU
+!c-OB
+      real(kind=8) flag_aer
+      real(kind=8) tauae(kdlon,kflev,2)
+      real(kind=8) pizae(kdlon,kflev,2)
+      real(kind=8) cgae(kdlon,kflev,2)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)
+      REAL(KIND=8) PAKI(KDLON,2)
+      REAL(KIND=8) PALBD(KDLON,2)
+      REAL(KIND=8) PALBP(KDLON,2)
+      REAL(KIND=8) PCG(KDLON,2,KFLEV)
+      REAL(KIND=8) PCLD(KDLON,KFLEV)
+      REAL(KIND=8) PCLDSW(KDLON,KFLEV)
+      REAL(KIND=8) PCLEAR(KDLON)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) POMEGA(KDLON,2,KFLEV)
+      REAL(KIND=8) POZ(KDLON,KFLEV)
+      REAL(KIND=8) PQS(KDLON,KFLEV)
+      REAL(KIND=8) PRMU(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+      REAL(KIND=8) PTAU(KDLON,2,KFLEV)
+      REAL(KIND=8) PUD(KDLON,5,KFLEV+1)
+      REAL(KIND=8) PWV(KDLON,KFLEV)
+!C
+      REAL(KIND=8) PFDOWN(KDLON,KFLEV+1)
+      REAL(KIND=8) PFUP(KDLON,KFLEV+1)
+!C
+!C* LOCAL VARIABLES:
+!C
+      INTEGER IIND2(2), IIND3(3)
+      REAL(KIND=8) ZCGAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZFD(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFU(KDLON,KFLEV+1) 
+      REAL(KIND=8) ZG(KDLON)
+      REAL(KIND=8) ZGG(KDLON)
+      REAL(KIND=8) ZPIZAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZRAYL(KDLON)
+      REAL(KIND=8) ZRAY1(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRAY2(KDLON,KFLEV+1)
+      REAL(KIND=8) ZREF(KDLON)
+      REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1)
+      REAL(KIND=8) ZRE1(KDLON)
+      REAL(KIND=8) ZRE2(KDLON)
+      REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRK(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRL(KDLON,8)
+      REAL(KIND=8) ZRMUE(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRMU0(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRMUZ(KDLON)
+      REAL(KIND=8) ZRNEB(KDLON)
+      REAL(KIND=8) ZRUEF(KDLON,8)
+      REAL(KIND=8) ZR1(KDLON) 
+      REAL(KIND=8) ZR2(KDLON,2)
+      REAL(KIND=8) ZR3(KDLON,3)
+      REAL(KIND=8) ZR4(KDLON)
+      REAL(KIND=8) ZR21(KDLON)
+      REAL(KIND=8) ZR22(KDLON)
+      REAL(KIND=8) ZS(KDLON)
+      REAL(KIND=8) ZTAUAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZTO1(KDLON)
+      REAL(KIND=8) ZTR(KDLON,2,KFLEV+1)
+      REAL(KIND=8) ZTRA1(KDLON,KFLEV+1)
+      REAL(KIND=8) ZTRA2(KDLON,KFLEV+1)
+      REAL(KIND=8) ZTR1(KDLON)
+      REAL(KIND=8) ZTR2(KDLON)
+      REAL(KIND=8) ZW(KDLON)   
+      REAL(KIND=8) ZW1(KDLON)
+      REAL(KIND=8) ZW2(KDLON,2)
+      REAL(KIND=8) ZW3(KDLON,3)
+      REAL(KIND=8) ZW4(KDLON)
+      REAL(KIND=8) ZW5(KDLON)
+!C
+      INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
+      INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
+      REAL(KIND=8) ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11
+
+!C If running with Reporbus, overwrite default values of RSUN. 
+!C Otherwise keep default values from radiation_AR4_param module.  
+      IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+         IF (ok_SUNTIME) THEN
+            RSUN(1)=RSUNTIME(1)
+            RSUN(2)=RSUNTIME(2)
+         END IF
+#endif
+      END IF
+
+!C
+
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
+!C                 -------------------------------------------
+!C
+ 100  CONTINUE
+!C
+!C
+!C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+!C                 -----------------------------------------
+!C
+ 110  CONTINUE
+!C
+      DO 111 JL = 1, KDLON
+      ZRMUM1 = 1. - PRMU(JL)
+      ZRAYL(JL) =  RRAY(KNU,1) + ZRMUM1   * (RRAY(KNU,2) + ZRMUM1                    &
+       &          * (RRAY(KNU,3) + ZRMUM1   * (RRAY(KNU,4) + ZRMUM1                  &
+       &          * (RRAY(KNU,5) + ZRMUM1   *  RRAY(KNU,6)     ))))
+ 111  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.    CONTINUUM SCATTERING CALCULATIONS
+!C                ---------------------------------
+!C
+ 200  CONTINUE
+!C
+!C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+!C                --------------------------------
+!C  
+ 210  CONTINUE
+!C
+      CALL SWCLR_LMDAR4 ( KNU                                                        &
+       &  , PAER   , flag_aer, tauae, pizae, cgae                                    &
+       &  , PALBP  , PDSIG , ZRAYL, PSEC                                             &
+       &  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0                              &
+       &  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+!C
+!C
+!C*         2.2   CLOUDY FRACTION OF THE COLUMN
+!C                -----------------------------
+!C
+ 220  CONTINUE
+!C
+      CALL SWR_LMDAR4 ( KNU                                                          &
+       &  , PALBD , PCG   , PCLD , PDSIG, POMEGA, ZRAYL                              &
+       &  , PSEC  , PTAU                                                             &
+       &  , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ  , ZRK, ZRMUE                  &
+       &  , ZTAUAZ, ZTRA1 , ZTRA2)
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
+!C                ------------------------------------------------------
+!C
+ 300  CONTINUE
+!C
+      JN = 2
+!C
+      DO 361 JABS=1,2
+!C
+!C
+!C*         3.1  SURFACE CONDITIONS
+!C               ------------------
+!C
+ 310  CONTINUE
+!C
+      DO 311 JL = 1, KDLON
+      ZREFZ(JL,2,1) = PALBD(JL,KNU)
+      ZREFZ(JL,1,1) = PALBD(JL,KNU)
+ 311  CONTINUE
+!C
+!C
+!C*         3.2  INTRODUCING CLOUD EFFECTS
+!C               -------------------------
+!C
+ 320  CONTINUE
+!C
+      DO 324 JK = 2 , KFLEV+1
+      JKM1 = JK - 1
+      IKL=KFLEV+1-JKM1
+      DO 322 JL = 1, KDLON
+      ZRNEB(JL) = PCLD(JL,JKM1)
+      IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN
+         ZWH2O=MAX(PWV(JL,JKM1),ZEELOG)
+         ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG))
+         ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O
+         ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG)
+      ELSE
+         ZAA=PUD(JL,JABS,JKM1)
+         ZBB=ZAA
+      END IF
+      ZRKI = PAKI(JL,JABS)
+      ZS(JL) = EXP(-ZRKI * ZAA * 1.66)
+      ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK))
+      ZTR1(JL) = 0.
+      ZRE1(JL) = 0.
+      ZTR2(JL) = 0.
+      ZRE2(JL) = 0.
+!C
+      ZW(JL)= POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL)                                          &
+       &               + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1)                           &
+       &               + ZBB * ZRKI
+
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)                                          &
+       &              + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1)
+      ZW(JL) = ZR21(JL) / ZTO1(JL)
+      ZREF(JL) = ZREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = ZRMUE(JL,JK)
+ 322  CONTINUE
+!C
+      CALL SWDE_LMDAR4(ZGG, ZREF, ZRMUZ, ZTO1, ZW,                                   &
+       &          ZRE1, ZRE2, ZTR1, ZTR2)
+!C
+      DO 323 JL = 1, KDLON
+!C
+      ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)                              &
+       &               + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)                           &
+       &               * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL)                          &
+       &               + ZRNEB(JL) * ZRE1(JL)
+!C
+      ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL)                                              &
+       &              + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL))
+!C
+      ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1)                                  &
+       &                  +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1)            &
+       &             /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL)            &
+       &             + ZRNEB(JL) * ZRE2(JL)
+!C
+      ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL)                                           &
+       &              + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1)                           &
+       &              * ZREFZ(JL,1,JKM1)))                                           &
+       &              * ZG(JL) * (1. -ZRNEB(JL))
+!C
+ 323  CONTINUE
+ 324  CONTINUE
+!C
+!C*         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+!C               -------------------------------------------------
+!C
+ 330  CONTINUE
+!C
+      DO 351 JREF=1,2
+!C
+      JN = JN + 1
+!C
+      DO 331 JL = 1, KDLON
+      ZRJ(JL,JN,KFLEV+1) = 1.
+      ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1)
+ 331  CONTINUE
+!C
+      DO 333 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 332 JL = 1, KDLON
+      ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL)
+      ZRJ(JL,JN,JKL) = ZRE11
+      ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL)
+ 332  CONTINUE
+ 333  CONTINUE
+ 351  CONTINUE
+ 361  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         4.    INVERT GREY AND CONTINUUM FLUXES
+!C                --------------------------------
+!C
+ 400  CONTINUE
+!C
+!C
+!C*         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
+!C                ---------------------------------------------
+!C
+ 410  CONTINUE
+!C
+      DO 414 JK = 1 , KFLEV+1
+      DO 413 JAJ = 1 , 5 , 2
+      JAJP = JAJ + 1
+      DO 412 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)=        ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK)
+      ZRK(JL,JAJ,JK)=        ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK)
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 412  CONTINUE
+ 413  CONTINUE
+ 414  CONTINUE
+!C
+      DO 417 JK = 1 , KFLEV+1
+      DO 416 JAJ = 2 , 6 , 2
+      DO 415 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 415  CONTINUE
+ 416  CONTINUE
+ 417  CONTINUE
+!C
+!C*         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
+!C                 ---------------------------------------------
+!C
+ 420  CONTINUE
+!C
+      DO 437 JK = 1 , KFLEV+1
+      JKKI = 1
+      DO 425 JAJ = 1 , 2
+      IIND2(1)=JAJ
+      IIND2(2)=JAJ
+      DO 424 JN = 1 , 2
+      JN2J = JN + 2 * JAJ
+      JKKP4 = JKKI + 4
+!C
+!C*         4.2.1  EFFECTIVE ABSORBER AMOUNTS
+!C                 --------------------------
+!C
+ 4210 CONTINUE
+!C
+      DO 4211 JL = 1, KDLON
+      ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK))                              &
+       &                               / PAKI(JL,JAJ)
+      ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK))                              &
+       &                               / PAKI(JL,JAJ)
+ 4211 CONTINUE
+!C
+!C*         4.2.2  TRANSMISSION FUNCTION
+!C                 ---------------------
+!C
+ 4220 CONTINUE
+!C
+      CALL SWTT1_LMDAR4(KNU, 2, IIND2, ZW2, ZR2)
+!C
+      DO 4221 JL = 1, KDLON
+      ZRL(JL,JKKI) = ZR2(JL,1)
+      ZRUEF(JL,JKKI) = ZW2(JL,1)
+      ZRL(JL,JKKP4) = ZR2(JL,2)
+      ZRUEF(JL,JKKP4) = ZW2(JL,2)
+ 4221 CONTINUE
+!C
+      JKKI=JKKI+1
+ 424  CONTINUE
+ 425  CONTINUE
+!C
+!C*         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
+!C                 ------------------------------------------------------
+!C
+ 430  CONTINUE
+!C
+      DO 431 JL = 1, KDLON
+      PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)                           &
+       &              + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)
+      PFUP(JL,JK)   = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)                           &
+       &              + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)
+ 431  CONTINUE
+ 437  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
+!C                ----------------------------------------
+!C
+ 500  CONTINUE
+!C
+!C
+!C*         5.1   DOWNWARD FLUXES
+!C                ---------------
+!C
+ 510  CONTINUE
+!C
+      JAJ = 2
+      IIND3(1)=1
+      IIND3(2)=2
+      IIND3(3)=3
+!C      
+      DO 511 JL = 1, KDLON
+      ZW3(JL,1)=0.
+      ZW3(JL,2)=0.
+      ZW3(JL,3)=0.
+      ZW4(JL)  =0.
+      ZW5(JL)  =0.
+      ZR4(JL)  =1.
+      ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1)
+ 511  CONTINUE
+      DO 514 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 512 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKL)/ZRMU0(JL,IKL)
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKL)/ZRMU0(JL,IKL)
+ 512  CONTINUE
+!C
+      CALL SWTT1_LMDAR4(KNU, 3, IIND3, ZW3, ZR3)
+!C
+      DO 513 JL = 1, KDLON
+!C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)                            &
+       &            * ZRJ0(JL,JAJ,IKL)
+ 513  CONTINUE
+ 514  CONTINUE
+!C
+!C
+!C*         5.2   UPWARD FLUXES
+!C                -------------
+!C
+ 520  CONTINUE
+!C
+      DO 525 JL = 1, KDLON
+      ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)
+ 525  CONTINUE
+!C
+      DO 528 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 526 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKM1)*1.66
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKM1)*1.66
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKM1)*1.66
+ 526  CONTINUE
+!C
+      CALL SWTT1_LMDAR4(KNU, 3, IIND3, ZW3, ZR3)
+!C
+      DO 527 JL = 1, KDLON
+!C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)                             &
+       &           * ZRK0(JL,JAJ,JK)
+ 527  CONTINUE
+ 528  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
+!C                 --------------------------------------------------
+!C
+ 600  CONTINUE
+      IABS=3
+!C
+!C*         6.1    DOWNWARD FLUXES
+!C                 ---------------
+!C
+ 610  CONTINUE
+      DO 611 JL = 1, KDLON
+      ZW1(JL)=0.
+      ZW4(JL)=0.
+      ZW5(JL)=0.
+      ZR1(JL)=0.
+      PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1)                       &
+       &                   + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU)
+ 611  CONTINUE
+!C
+      DO 614 JK = 1 , KFLEV
+      IKL=KFLEV+1-JK
+      DO 612 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL)
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL)
+!C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 612  CONTINUE
+!C
+      CALL SWTT_LMDAR4(KNU, IABS, ZW1, ZR1)
+!C
+      DO 613 JL = 1, KDLON
+      PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL)               &
+       &                     +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU)
+ 613  CONTINUE
+ 614  CONTINUE
+!C
+!C
+!C*         6.2    UPWARD FLUXES
+!C                 -------------
+!C
+ 620  CONTINUE
+      DO 621 JL = 1, KDLON
+      PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1)                     &
+       &                 +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU)
+ 621  CONTINUE
+!C
+      DO 624 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 622 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL  ,IKM1)*1.66
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66
+!C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 622  CONTINUE
+!C
+      CALL SWTT_LMDAR4(KNU, IABS, ZW1, ZR1)
+!C
+      DO 623 JL = 1, KDLON
+      PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK)                   &
+       &                 +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU)
+ 623  CONTINUE
+ 624  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE SW2S_LMDAR4
+
+      SUBROUTINE SWCLR_LMDAR4  ( KNU                                                 &
+       &  , PAER  , flag_aer, tauae, pizae, cgae                                     &
+       &  , PALBP , PDSIG , PRAYL , PSEC                                             &
+       &  , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ                              &
+       &  , PRK   , PRMU0 , PTAUAZ, PTRA1 , PTRA2                   )
+      USE dimphy
+      USE radiation_AR4_param, only : TAUA, RPIZA, RCGA
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+!C
+!C     ------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+!C     CLEAR-SKY COLUMN
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+!C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 94-11-15
+!C     ------------------------------------------------------------------
+!C* ARGUMENTS:
+!C
+      INTEGER KNU
+!c-OB
+      real(kind=8) flag_aer
+      real(kind=8) tauae(kdlon,kflev,2)
+      real(kind=8) pizae(kdlon,kflev,2)
+      real(kind=8) cgae(kdlon,kflev,2)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)
+      REAL(KIND=8) PALBP(KDLON,2)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) PRAYL(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+!C
+      REAL(KIND=8) PCGAZ(KDLON,KFLEV)     
+      REAL(KIND=8) PPIZAZ(KDLON,KFLEV)
+      REAL(KIND=8) PRAY1(KDLON,KFLEV+1)
+      REAL(KIND=8) PRAY2(KDLON,KFLEV+1)
+      REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1)
+      REAL(KIND=8) PRJ(KDLON,6,KFLEV+1)
+      REAL(KIND=8) PRK(KDLON,6,KFLEV+1)
+      REAL(KIND=8) PRMU0(KDLON,KFLEV+1)
+      REAL(KIND=8) PTAUAZ(KDLON,KFLEV)
+      REAL(KIND=8) PTRA1(KDLON,KFLEV+1)
+      REAL(KIND=8) PTRA2(KDLON,KFLEV+1)
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) ZC0I(KDLON,KFLEV+1)       
+      REAL(KIND=8) ZCLE0(KDLON,KFLEV)
+      REAL(KIND=8) ZCLEAR(KDLON)
+      REAL(KIND=8) ZR21(KDLON)
+      REAL(KIND=8) ZR23(KDLON)
+      REAL(KIND=8) ZSS0(KDLON)
+      REAL(KIND=8) ZSCAT(KDLON)
+      REAL(KIND=8) ZTR(KDLON,2,KFLEV+1)
+!C
+      INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
+      REAL(KIND=8) ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE
+      REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1
+      REAL(KIND=8) ZBMU0, ZBMU1, ZRE11
+!C
+
+!C     ------------------------------------------------------------------
+!C
+!C*         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
+!C                --------------------------------------------
+!C
+ 100  CONTINUE
+!C
+!cdir collapse
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+!C
+      DO 108 JK = 1 , KFLEV
+!c-OB
+!c      DO 104 JL = 1, KDLON
+!c      PCGAZ(JL,JK) = 0.
+!c      PPIZAZ(JL,JK) =  0.
+!c      PTAUAZ(JL,JK) = 0.
+!c 104  CONTINUE
+!c-OB
+!c      DO 106 JAE=1,5
+!c      DO 105 JL = 1, KDLON
+!c      PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
+!c     S        +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
+!c      PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
+!c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
+!c      PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JK,JAE)
+!c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
+!c 105  CONTINUE
+!c 106  CONTINUE
+!c-OB
+      DO 105 JL = 1, KDLON
+      PTAUAZ(JL,JK)=flag_aer * tauae(JL,JK,KNU)
+      PPIZAZ(JL,JK)=flag_aer * pizae(JL,JK,KNU)
+      PCGAZ (JL,JK)=flag_aer * cgae(JL,JK,KNU)
+ 105  CONTINUE
+!C
+      IF (flag_aer.GT.0) THEN
+!c-OB
+      DO 107 JL = 1, KDLON
+!c         PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
+!c         PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK))
+         ZGAR = PCGAZ(JL,JK)
+         ZFF = ZGAR * ZGAR
+         PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF)
+         PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)
+         PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF)                    &
+       &                       / (1. - PPIZAZ(JL,JK) * ZFF)
+ 107  CONTINUE
+      ELSE
+      DO JL = 1, KDLON
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         PTAUAZ(JL,JK) = ZTRAY
+         PCGAZ(JL,JK) = 0.
+         PPIZAZ(JL,JK) = 1.-REPSCT
+      END DO
+      END IF   ! check flag_aer
+!c     107  CONTINUE
+!c      PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
+!c     $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
+!c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
+!C
+ 108  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+!C                ----------------------------------------------
+!C
+ 200  CONTINUE
+!C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC0I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZSCAT(JL) = 0.
+ 201  CONTINUE
+!C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+!C
+      IF (NOVLP.EQ.1) THEN
+!c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)                                                     &
+       &                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))                             &
+       &                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+!C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+!c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF
+ 202  CONTINUE
+!C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+!c     
+      IF (NOVLP.EQ.1) THEN
+!c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)                                                     &
+       &                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))                             &
+       &                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+!C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+!c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF                  
+ 204  CONTINUE
+ 205  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+!C                -----------------------------------------------
+!C
+ 300  CONTINUE
+!C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBP(JL,KNU)
+      PREFZ(JL,1,1) = PALBP(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+!C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.1  EQUIVALENT ZENITH ANGLE
+!C               -----------------------
+!C
+ 310  CONTINUE
+!C
+      ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL)                                             &
+       &            + ZC0I(JL,JK) * 1.66
+      PRMU0(JL,JK) = 1./ZMUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+!C               ----------------------------------------------------
+!C
+ 320  CONTINUE
+!C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE                              &
+       &       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+!C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1                              &
+       &       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+!C
+!C
+!C
+      PREFZ(JL,1,JK) = (PRAY1(JL,JKM1)                                               &
+       &               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)                           &
+       &               * PTRA2(JL,JKM1)                                              &
+       &               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+!C
+      ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1)                                               &
+       &               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+!C
+      PREFZ(JL,2,JK) = (PRAY1(JL,JKM1)                                               &
+       &               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)                           &
+       &               * PTRA2(JL,JKM1) )
+!C
+      ZTR(JL,2,JKM1) = PTRA1(JL,JKM1) 
+!C
+ 342  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66
+      PRMU0(JL,1)=1./ZMUE
+ 347  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+!C                 -------------------------------------------------
+!C
+ 350  CONTINUE
+!C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+!C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+!C
+      ELSE
+!C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+!C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+!C
+      END IF
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE SWCLR_LMDAR4
+
+      SUBROUTINE SWR_LMDAR4 ( KNU                                                    &
+       &  , PALBD , PCG   , PCLD , PDSIG, POMEGA, PRAYL                              &
+       &  , PSEC  , PTAU                                                             &
+       &  , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ  , PRK , PRMUE                 &
+       &  , PTAUAZ, PTRA1 , PTRA2 )
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+!C
+!C     ------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+!C     CONTINUUM SCATTERING
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
+!C     OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+!C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C     ------------------------------------------------------------------
+!C* ARGUMENTS:
+!C
+      INTEGER KNU
+      REAL(KIND=8) PALBD(KDLON,2)
+      REAL(KIND=8) PCG(KDLON,2,KFLEV)
+      REAL(KIND=8) PCLD(KDLON,KFLEV)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) POMEGA(KDLON,2,KFLEV)
+      REAL(KIND=8) PRAYL(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+      REAL(KIND=8) PTAU(KDLON,2,KFLEV)
+!C
+      REAL(KIND=8) PRAY1(KDLON,KFLEV+1)
+      REAL(KIND=8) PRAY2(KDLON,KFLEV+1)
+      REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1)
+      REAL(KIND=8) PRJ(KDLON,6,KFLEV+1)
+      REAL(KIND=8) PRK(KDLON,6,KFLEV+1)
+      REAL(KIND=8) PRMUE(KDLON,KFLEV+1)
+      REAL(KIND=8) PCGAZ(KDLON,KFLEV)
+      REAL(KIND=8) PPIZAZ(KDLON,KFLEV)
+      REAL(KIND=8) PTAUAZ(KDLON,KFLEV)
+      REAL(KIND=8) PTRA1(KDLON,KFLEV+1)
+      REAL(KIND=8) PTRA2(KDLON,KFLEV+1)
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) ZC1I(KDLON,KFLEV+1)
+      REAL(KIND=8) ZCLEQ(KDLON,KFLEV)
+      REAL(KIND=8) ZCLEAR(KDLON)
+      REAL(KIND=8) ZCLOUD(KDLON)
+      REAL(KIND=8) ZGG(KDLON)
+      REAL(KIND=8) ZREF(KDLON)
+      REAL(KIND=8) ZRE1(KDLON)
+      REAL(KIND=8) ZRE2(KDLON)
+      REAL(KIND=8) ZRMUZ(KDLON)
+      REAL(KIND=8) ZRNEB(KDLON)
+      REAL(KIND=8) ZR21(KDLON)
+      REAL(KIND=8) ZR22(KDLON)
+      REAL(KIND=8) ZR23(KDLON)
+      REAL(KIND=8) ZSS1(KDLON)
+      REAL(KIND=8) ZTO1(KDLON)
+      REAL(KIND=8) ZTR(KDLON,2,KFLEV+1)
+      REAL(KIND=8) ZTR1(KDLON)
+      REAL(KIND=8) ZTR2(KDLON)
+      REAL(KIND=8) ZW(KDLON)
+!C
+      INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
+      REAL(KIND=8) ZFACOA, ZFACOC, ZCORAE, ZCORCD
+      REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1
+      REAL(KIND=8) ZMU1, ZRE11, ZBMU0, ZBMU1
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         1.    INITIALIZATION
+!C                --------------
+!C
+ 100  CONTINUE
+!C
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+!C                ----------------------------------------------
+!C
+ 200  CONTINUE
+!C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC1I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZCLOUD(JL) = 0.
+ 201  CONTINUE
+!C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)                             &
+       &                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))                                &
+       &               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+!C
+      IF (NOVLP.EQ.1) THEN
+!c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)                                                     &
+       &                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))                            &
+       &                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+!C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+!c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 202  CONTINUE
+!C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)                             &
+       &                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))                                &
+       &               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+!c     
+      IF (NOVLP.EQ.1) THEN
+!c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)                                                     &
+       &                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))                            &
+       &                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+!C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+!c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 204  CONTINUE
+ 205  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+!C                -----------------------------------------------
+!C
+ 300  CONTINUE
+!C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBD(JL,KNU)
+      PREFZ(JL,1,1) = PALBD(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+!C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+      ZRNEB(JL)= PCLD(JL,JKM1)
+      ZRE1(JL)=0.
+      ZTR1(JL)=0.
+      ZRE2(JL)=0.
+      ZTR2(JL)=0.
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.1  EQUIVALENT ZENITH ANGLE
+!C               -----------------------
+!C
+ 310  CONTINUE
+!C
+      ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)                                             &
+       &            + ZC1I(JL,JK) * 1.66
+      PRMUE(JL,JK) = 1./ZMUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+!C               ----------------------------------------------------
+!C
+ 320  CONTINUE
+!C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE                              &
+       &       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+!c      PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
+!C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1                              &
+       &       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.3  EFFECT OF CLOUD LAYER
+!C               ---------------------
+!C
+ 330  CONTINUE
+!C
+      ZW(JL) = POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL)                                            &
+       &         + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)                                          &
+       &              + (1. - ZR22(JL)) * PCGAZ(JL,JKM1)
+!C Modif PhD - JJM 19/03/96 pour erreurs arrondis
+!C machine
+!C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
+      IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN
+         ZW(JL)=1.
+      ELSE
+         ZW(JL) = ZR21(JL) / ZTO1(JL)
+      END IF
+      ZREF(JL) = PREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = PRMUE(JL,JK)
+ 342  CONTINUE
+!C
+      CALL SWDE_LMDAR4(ZGG  , ZREF  , ZRMUZ , ZTO1 , ZW,                             &
+       &          ZRE1 , ZRE2  , ZTR1  , ZTR2)
+!C
+      DO 345 JL = 1, KDLON
+!C
+      PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)                              &
+       &               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)                           &
+       &               * PTRA2(JL,JKM1)                                              &
+       &               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))                       &
+       &               + ZRNEB(JL) * ZRE2(JL)
+!C
+      ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)                        &
+       &               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))                       &
+       &               * (1.-ZRNEB(JL))
+!C
+      PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)                              &
+       &               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)                           &
+       &               * PTRA2(JL,JKM1) )                                            &
+       &               + ZRNEB(JL) * ZRE1(JL)
+!C
+      ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)                                          &
+       &               + PTRA1(JL,JKM1) * (1.-ZRNEB(JL))
+!C
+ 345  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66
+      PRMUE(JL,1)=1./ZMUE
+ 347  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+!C                 -------------------------------------------------
+!C
+ 350  CONTINUE
+!C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+!C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+!C
+      ELSE
+!C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+!C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+!C
+      END IF
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE SWR_LMDAR4
+
+      SUBROUTINE SWDE_LMDAR4 (PGG,PREF,PRMUZ,PTO1,PW,                                &
+       &                 PRE1,PRE2,PTR1,PTR2)
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+!C
+!C     ------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
+!C     LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 88-12-15
+!C     ------------------------------------------------------------------
+!C* ARGUMENTS:
+!C
+      REAL(KIND=8) PGG(KDLON)   ! ASSYMETRY FACTOR
+      REAL(KIND=8) PREF(KDLON)  ! REFLECTIVITY OF THE UNDERLYING LAYER
+      REAL(KIND=8) PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE
+      REAL(KIND=8) PTO1(KDLON)  ! OPTICAL THICKNESS
+      REAL(KIND=8) PW(KDLON)    ! SINGLE SCATTERING ALBEDO
+      REAL(KIND=8) PRE1(KDLON)  ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL(KIND=8) PRE2(KDLON)  ! LAYER REFLECTIVITY
+      REAL(KIND=8) PTR1(KDLON)  ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL(KIND=8) PTR2(KDLON)  ! LAYER TRANSMISSIVITY
+!C
+!C* LOCAL VARIABLES:
+!C
+      INTEGER jl
+      REAL(KIND=8) ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM
+      REAL(KIND=8) ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG
+      REAL(KIND=8) ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B,                 &
+       &     ZAM2B
+      REAL(KIND=8) ZA11, ZA12, ZA13, ZA21, ZA22, ZA23
+      REAL(KIND=8) ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A
+      REAL(KIND=8) ZRI0B, ZRI1B
+      REAL(KIND=8) ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B
+      REAL(KIND=8) ZRI0C, ZRI1C, ZRI0D, ZRI1D
+!C     ------------------------------------------------------------------
+!C
+!C*         1.      DELTA-EDDINGTON CALCULATIONS
+!C
+ 100  CONTINUE
+!C
+      DO 131 JL   =   1, KDLON
+!C
+!C*         1.1     SET UP THE DELTA-MODIFIED PARAMETERS
+!C
+ 110  CONTINUE
+!C
+      ZFF = PGG(JL)*PGG(JL)
+      ZGP = PGG(JL)/(1.+PGG(JL))
+      ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL)
+      ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF)
+      ZDT = 2./3.
+      ZX1 = 1.-ZWCP*ZGP
+      ZWM = 1.-ZWCP
+      ZRM2 =  PRMUZ(JL) * PRMUZ(JL)
+      ZRK = SQRT(3.*ZWM*ZX1)
+      ZX2 = 4.*(1.-ZRK*ZRK*ZRM2)
+      ZRP=ZRK/ZX1
+      ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2
+      ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2
+      ZARG=MIN(ZTOP/PRMUZ(JL),200._8)
+      ZEXMU0=EXP(-ZARG)
+      ZARG2=MIN(ZRK*ZTOP,200._8)
+      ZEXKP=EXP(ZARG2)
+      ZEXKM = 1./ZEXKP
+      ZXP2P = 1.+ZDT*ZRP
+      ZXM2P = 1.-ZDT*ZRP
+      ZAP2B = ZALPHA+ZDT*ZBETA
+      ZAM2B = ZALPHA-ZDT*ZBETA
+!C
+!C*         1.2     WITHOUT REFLECTION FROM THE UNDERLYING LAYER
+!C
+ 120  CONTINUE
+!C
+      ZA11 = ZXP2P
+      ZA12 = ZXM2P
+      ZA13 = ZAP2B
+      ZA22 = ZXP2P*ZEXKP
+      ZA21 = ZXM2P*ZEXKM
+      ZA23 = ZAM2B*ZEXMU0
+      ZDENA = ZA11 * ZA22 - ZA21 * ZA12
+      ZC1A = (ZA22*ZA13-ZA12*ZA23)/ZDENA
+      ZC2A = (ZA11*ZA23-ZA21*ZA13)/ZDENA
+      ZRI0A = ZC1A+ZC2A-ZALPHA
+      ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
+      PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL)
+      ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0
+      ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0
+      PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL)
+!C
+!C*         1.3     WITH REFLECTION FROM THE UNDERLYING LAYER
+!C
+ 130  CONTINUE
+!C
+      ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM
+      ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP
+      ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) )
+      ZDENB = ZA11 * ZB22 - ZB21 * ZA12
+      ZC1B = (ZB22*ZA13-ZA12*ZB23)/ZDENB
+      ZC2B = (ZA11*ZB23-ZB21*ZA13)/ZDENB
+      ZRI0C = ZC1B+ZC2B-ZALPHA
+      ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
+      PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL)
+      ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0
+      ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0
+      PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL)
+!C
+ 131  CONTINUE
+      RETURN
+      END SUBROUTINE SWDE_LMDAR4 
+
+      SUBROUTINE SWTT_LMDAR4 (KNU,KA,PU,PTR)
+      USE dimphy
+      USE radiation_AR4_param, only : APAD, BPAD, D
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+!C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+!C     INTERVALS.
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+!C     AND HORNER'S ALGORITHM.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 88-12-15
+!C-----------------------------------------------------------------------
+!C
+!C* ARGUMENTS
+!C
+      INTEGER KNU     ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KA      ! INDEX OF THE ABSORBER
+      REAL(KIND=8) PU(KDLON)  ! ABSORBER AMOUNT
+!C
+      REAL(KIND=8) PTR(KDLON) ! TRANSMISSION FUNCTION
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) ZR1(KDLON), ZR2(KDLON)
+      INTEGER jl, i,j
+!C
+
+!C
+!C-----------------------------------------------------------------------
+!C
+!C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+!C
+ 100  CONTINUE
+!C
+      DO 201 JL = 1, KDLON
+      ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL)                   &
+       &      * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL)                 &
+       &      * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL)                 &
+       &      * ( APAD(KNU,KA,7) ))))))
+!C
+      ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL)                   &
+       &      * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL)                 &
+       &      * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL)                 &
+       &      * ( BPAD(KNU,KA,7) ))))))
+!C     
+!C
+!C*         2.      ADD THE BACKGROUND TRANSMISSION
+!C
+ 200  CONTINUE
+!C
+!C
+      PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA)
+ 201  CONTINUE
+!C
+      RETURN
+      END SUBROUTINE SWTT_LMDAR4
+
+      SUBROUTINE SWTT1_LMDAR4(KNU,KABS,KIND, PU, PTR)
+      USE dimphy
+      USE radiation_AR4_param, only : APAD, BPAD, D
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+!C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+!C     INTERVALS.
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+!C     AND HORNER'S ALGORITHM.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 95-01-20
+!C-----------------------------------------------------------------------
+!C* ARGUMENTS:
+!C
+      INTEGER KNU          ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KABS         ! NUMBER OF ABSORBERS
+      INTEGER KIND(KABS)   ! INDICES OF THE ABSORBERS
+      REAL(KIND=8) PU(KDLON,KABS)  ! ABSORBER AMOUNT
+!C
+      REAL(KIND=8) PTR(KDLON,KABS) ! TRANSMISSION FUNCTION
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) ZR1(KDLON)
+      REAL(KIND=8) ZR2(KDLON)
+      REAL(KIND=8) ZU(KDLON)
+      INTEGER jl, ja, i, j, ia
+!C
+
+!C-----------------------------------------------------------------------
+!C
+!C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+!C
+ 100  CONTINUE
+!C
+      DO 202 JA = 1,KABS
+      IA=KIND(JA)
+      DO 201 JL = 1, KDLON
+      ZU(JL) = PU(JL,JA)
+      ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL)                   &
+       &      * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL)                 &
+       &      * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL)                 &
+       &      * ( APAD(KNU,IA,7) ))))))
+!C
+      ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)                   &
+       &      * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL)                 &
+       &      * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL)                 &
+       &      * ( BPAD(KNU,IA,7) ))))))
+!C     
+!C
+!C*         2.      ADD THE BACKGROUND TRANSMISSION
+!C
+ 200  CONTINUE
+!C
+      PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA) 
+ 201  CONTINUE
+ 202  CONTINUE
+!C
+      RETURN
+      END SUBROUTINE SWTT1_LMDAR4
+
+!IM ctes ds clesphys.h   SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
+      SUBROUTINE LW_LMDAR4(                                                          &
+       &              PPMB, PDP,                                                     &
+       &              PPSOL,PDT0,PEMIS,                                              &
+       &              PTL, PTAVE, PWV, POZON, PAER,                                  &
+       &              PCLDLD,PCLDLU,                                                 &
+       &              PVIEW,                                                         &
+       &              PCOLR, PCOLR0,                                                 &
+       &              PTOPLW,PSOLLW,PTOPLW0,PSOLLW0,                                 &
+       &              psollwdown,                                                    &
+!IM  .              psollwdown,psollwdownclr,
+!IM  .              ptoplwdown,ptoplwdownclr)                                        &
+       &              plwup, plwdn, plwup0, plwdn0)
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+#include "iniprint.h"
+!C
+!C-----------------------------------------------------------------------
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+!C     ABSORBERS.
+!C          2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+!C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+!C          3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+!C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+!C     BOUNDARIES.
+!C          4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+!C          5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
+!C
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C-----------------------------------------------------------------------
+!IM ctes ds clesphys.h
+!c     REAL(KIND=8) RCO2   ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97)
+!c     REAL(KIND=8) RCH4   ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97)
+!c     REAL(KIND=8) RN2O   ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97)
+!c     REAL(KIND=8) RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97)
+!c     REAL(KIND=8) RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97)
+#include "clesphys.h"
+      REAL(KIND=8) PCLDLD(KDLON,KFLEV)  ! DOWNWARD EFFECTIVE CLOUD COVER
+      REAL(KIND=8) PCLDLU(KDLON,KFLEV)  ! UPWARD EFFECTIVE CLOUD COVER
+      REAL(KIND=8) PDP(KDLON,KFLEV)     ! LAYER PRESSURE THICKNESS (Pa)
+      REAL(KIND=8) PDT0(KDLON)          ! SURFACE TEMPERATURE DISCONTINUITY (K)
+      REAL(KIND=8) PEMIS(KDLON)         ! SURFACE EMISSIVITY
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1)  ! HALF LEVEL PRESSURE (mb)
+      REAL(KIND=8) PPSOL(KDLON)         ! SURFACE PRESSURE (Pa)
+      REAL(KIND=8) POZON(KDLON,KFLEV)   ! O3 mass fraction
+      REAL(KIND=8) PTL(KDLON,KFLEV+1)   ! HALF LEVEL TEMPERATURE (K)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)  ! OPTICAL THICKNESS OF THE AEROSOLS
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)   ! LAYER TEMPERATURE (K)
+      REAL(KIND=8) PVIEW(KDLON)         ! COSECANT OF VIEWING ANGLE
+      REAL(KIND=8) PWV(KDLON,KFLEV)     ! SPECIFIC HUMIDITY (kg/kg)
+!C
+      REAL(KIND=8) PCOLR(KDLON,KFLEV)   ! LONG-WAVE TENDENCY (K/day)
+      REAL(KIND=8) PCOLR0(KDLON,KFLEV)  ! LONG-WAVE TENDENCY (K/day) clear-sky
+      REAL(KIND=8) PTOPLW(KDLON)        ! LONGWAVE FLUX AT T.O.A.
+      REAL(KIND=8) PSOLLW(KDLON)        ! LONGWAVE FLUX AT SURFACE
+      REAL(KIND=8) PTOPLW0(KDLON)       ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
+      REAL(KIND=8) PSOLLW0(KDLON)       ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
+!c Rajout LF
+      real(kind=8) psollwdown(kdlon)    ! LONGWAVE downwards flux at surface
+!c Rajout IM
+!IM   real(kind=8) psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at surface
+!IM   real(kind=8) ptoplwdown(kdlon)    ! LONGWAVE downwards flux at T.O.A.
+!IM   real(kind=8) ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at T.O.A.
+!IM
+      REAL(KIND=8) plwup(KDLON,KFLEV+1)  ! LW up total sky
+      REAL(KIND=8) plwup0(KDLON,KFLEV+1) ! LW up clear sky
+      REAL(KIND=8) plwdn(KDLON,KFLEV+1)  ! LW down total sky
+      REAL(KIND=8) plwdn0(KDLON,KFLEV+1) ! LW down clear sky
+!C-------------------------------------------------------------------------
+      REAL(KIND=8) ZABCU(KDLON,NUA,3*KFLEV+1)
+
+      REAL(KIND=8) ZOZ(KDLON,KFLEV)
+!     equivalent pressure of ozone in a layer, in Pa
+
+!cym      REAL(KIND=8) ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down)
+!cym      REAL(KIND=8) ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+!cym      REAL(KIND=8) ZBINT(KDLON,KFLEV+1)            ! Intermediate variable
+!cym      REAL(KIND=8) ZBSUI(KDLON)                    ! Intermediate variable
+!cym      REAL(KIND=8) ZCTS(KDLON,KFLEV)               ! Intermediate variable
+!cym      REAL(KIND=8) ZCNTRB(KDLON,KFLEV+1,KFLEV+1)   ! Intermediate variable
+!cym      SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
+      REAL(KIND=8),allocatable,save :: ZFLUX(:,:,:) ! RADIATIVE FLUXES (1:up; 2:down)
+      REAL(KIND=8),allocatable,save :: ZFLUC(:,:,:) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL(KIND=8),allocatable,save :: ZBINT(:,:)            ! Intermediate variable
+      REAL(KIND=8),allocatable,save :: ZBSUI(:)                    ! Intermediate variable
+      REAL(KIND=8),allocatable,save :: ZCTS(:,:)               ! Intermediate variable
+      REAL(KIND=8),allocatable,save :: ZCNTRB(:,:,:)   ! Intermediate variable
+!$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB)
+!c
+      INTEGER ilim, i, k, kpl1
+!C
+      INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
+      PARAMETER (lw0pas=1)
+      INTEGER lwpas  ! Every lwpas steps, cloudy-sky is done
+      PARAMETER (lwpas=1)
+!c
+      INTEGER itaplw0, itaplw
+      LOGICAL appel1er
+      SAVE appel1er, itaplw0, itaplw
+!$OMP THREADPRIVATE(appel1er, itaplw0, itaplw)
+      DATA appel1er /.TRUE./
+      DATA itaplw0,itaplw /0,0/
+
+!C     ------------------------------------------------------------------
+      IF (appel1er) THEN
+         WRITE(lunout,*) "LW clear-sky calling frequency: ", lw0pas
+         WRITE(lunout,*) "LW cloudy-sky calling frequency: ", lwpas
+         WRITE(lunout,*) "   In general, they should be 1"
+!cym
+	 allocate(ZFLUX(KDLON,2,KFLEV+1) )
+         allocate(ZFLUC(KDLON,2,KFLEV+1) )
+         allocate(ZBINT(KDLON,KFLEV+1))
+         allocate(ZBSUI(KDLON))
+         allocate(ZCTS(KDLON,KFLEV))
+         allocate(ZCNTRB(KDLON,KFLEV+1,KFLEV+1))
+         appel1er=.FALSE.
+      ENDIF
+!C
+      IF (MOD(itaplw0,lw0pas).EQ.0) THEN
+!c     Compute equivalent pressure of ozone from mass fraction:
+      DO k = 1, KFLEV
+         DO i = 1, KDLON
+            ZOZ(i,k) = POZON(i,k)*PDP(i,k)
+         ENDDO
+      ENDDO
+!IM ctes ds clesphys.h   CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
+      CALL LWU_LMDAR4(                                                               &
+       &         PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU)
+      CALL LWBV_LMDAR4(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU,                     &
+       &          ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB)
+      itaplw0 = 0
+      ENDIF
+      itaplw0 = itaplw0 + 1
+!C
+      IF (MOD(itaplw,lwpas).EQ.0) THEN
+      CALL LWC_LMDAR4(ILIM,PCLDLD,PCLDLU,PEMIS,                                      &
+       &         ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB,                                      &
+       &         ZFLUX)
+      itaplw = 0
+      ENDIF
+      itaplw = itaplw + 1
+!C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1)                             &
+       &                 - ZFLUX(i,1,k)-   ZFLUX(i,2,k)
+            PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1)                            &
+       &                 - ZFLUC(i,1,k)-   ZFLUC(i,2,k)
+            PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1)
+         PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1)
+!c
+         PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1)
+         PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1)
+         psollwdown(i) = -ZFLUX(i,2,1)
+!c
+!IM attention aux signes !; LWtop >0, LWdn < 0
+         DO k = 1, KFLEV+1
+           plwup(i,k) = ZFLUX(i,1,k)
+           plwup0(i,k) = ZFLUC(i,1,k)
+           plwdn(i,k) = ZFLUX(i,2,k)
+           plwdn0(i,k) = ZFLUC(i,2,k)
+         ENDDO
+      ENDDO
+!C     ------------------------------------------------------------------
+      RETURN
+      END SUBROUTINE LW_LMDAR4
+
+!IM ctes ds clesphys.h   SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
+      SUBROUTINE LWU_LMDAR4(                                                         &
+       &               PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV,                      &
+       &               PABCU)
+      USE dimphy
+      USE radiation_AR4_param, only : TREF, RT1, RAER, AT, BT, OCT
+      USE infotrac, ONLY : type_trac
+#ifdef REPROBUS
+      USE CHEM_REP, ONLY: RCH42D,                                                    &
+       &                    RN2O2D,                                                  &
+       &                    RCFC112D,                                                &
+       &                    RCFC122D,                                                &
+       &                    ok_Rtime2D
+#endif
+
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+#include "radepsi.h"
+#include "radopt.h"
+!C
+!C     PURPOSE.
+!C     --------
+!C           COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
+!C           TEMPERATURE EFFECTS
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+!C     ABSORBERS.
+!C
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        Voigt lines (loop 404 modified) - JJM & PhD - 01/96
+!C-----------------------------------------------------------------------
+!C* ARGUMENTS:
+!IM ctes ds clesphys.h
+!c     REAL(KIND=8) RCO2
+!c     REAL(KIND=8) RCH4, RN2O, RCFC11, RCFC12
+#include "clesphys.h"
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)
+      REAL(KIND=8) PDP(KDLON,KFLEV)
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1)
+      REAL(KIND=8) PPSOL(KDLON)
+      REAL(KIND=8) POZ(KDLON,KFLEV)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)
+      REAL(KIND=8) PVIEW(KDLON)
+      REAL(KIND=8) PWV(KDLON,KFLEV)
+!C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+!C
+!C-----------------------------------------------------------------------
+!C* LOCAL VARIABLES:
+      REAL(KIND=8) ZABLY(KDLON,NUA,3*KFLEV+1)
+      REAL(KIND=8) ZDUC(KDLON,3*KFLEV+1)
+      REAL(KIND=8) ZPHIO(KDLON)
+      REAL(KIND=8) ZPSC2(KDLON)
+      REAL(KIND=8) ZPSC3(KDLON)
+      REAL(KIND=8) ZPSH1(KDLON)
+      REAL(KIND=8) ZPSH2(KDLON)
+      REAL(KIND=8) ZPSH3(KDLON)
+      REAL(KIND=8) ZPSH4(KDLON)
+      REAL(KIND=8) ZPSH5(KDLON)
+      REAL(KIND=8) ZPSH6(KDLON)
+      REAL(KIND=8) ZPSIO(KDLON)
+      REAL(KIND=8) ZTCON(KDLON)
+      REAL(KIND=8) ZPHM6(KDLON)
+      REAL(KIND=8) ZPSM6(KDLON)
+      REAL(KIND=8) ZPHN6(KDLON)
+      REAL(KIND=8) ZPSN6(KDLON)
+      REAL(KIND=8) ZSSIG(KDLON,3*KFLEV+1)
+      REAL(KIND=8) ZTAVI(KDLON)
+      REAL(KIND=8) ZUAER(KDLON,Ninter)
+      REAL(KIND=8) ZXOZ(KDLON)
+      REAL(KIND=8) ZXWV(KDLON)
+!C
+      INTEGER jl, jk, jkj, jkjr, jkjp, ig1
+      INTEGER jki, jkip1, ja, jj
+      INTEGER jkl, jkp1, jkk, jkjpn
+      INTEGER jae1, jae2, jae3, jae, jjpn
+      INTEGER ir, jc, jcp1
+      REAL(KIND=8) zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
+      REAL(KIND=8) zfppw, ztx, ztx2, zzably
+      REAL(KIND=8) zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
+      REAL(KIND=8) zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
+      REAL(KIND=8) zcac8, zcbc8
+      REAL(KIND=8) zalup, zdiff
+!c
+      REAL(KIND=8) PVGCO2, PVGH2O, PVGO3
+!C
+      REAL(KIND=8) R10E  ! DECIMAL/NATURAL LOG.FACTOR
+      PARAMETER (R10E=0.4342945)
+
+!C-----------------------------------------------------------------------
+!c
+      IF (LEVOIGT) THEN
+         PVGCO2= 60.
+         PVGH2O= 30.
+         PVGO3 =400.
+      ELSE
+         PVGCO2= 0.
+         PVGH2O= 0.
+         PVGO3 = 0.
+      ENDIF
+!C
+!C
+!C*         2.    PRESSURE OVER GAUSS SUB-LEVELS
+!C                ------------------------------
+!C
+ 200  CONTINUE
+!C
+      DO 201 JL = 1, KDLON
+      ZSSIG(JL, 1 ) = PPMB(JL,1) * 100.
+ 201  CONTINUE
+!C
+      DO 206 JK = 1 , KFLEV
+      JKJ=(JK-1)*NG1P1+1
+      JKJR = JKJ
+      JKJP = JKJ + NG1P1
+      DO 203 JL = 1, KDLON
+      ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100.
+ 203  CONTINUE
+      DO 205 IG1=1,NG1
+      JKJ=JKJ+1
+      DO 204 JL = 1, KDLON
+      ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5                             &
+       &  + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5
+ 204  CONTINUE
+ 205  CONTINUE
+ 206  CONTINUE
+!C
+!C-----------------------------------------------------------------------
+!C
+!C
+!C*         4.    PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
+!C                --------------------------------------------------
+!C
+ 400  CONTINUE
+!C
+      DO 402 JKI=1,3*KFLEV
+      JKIP1=JKI+1
+      DO 401 JL = 1, KDLON
+      ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5
+      ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1))                                &
+       &                                 /(10.*RG)
+ 401  CONTINUE
+ 402  CONTINUE
+!C
+      DO 406 JK = 1 , KFLEV
+      JKP1=JK+1
+      JKL = KFLEV+1 - JK
+      DO 403 JL = 1, KDLON
+      ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO )
+ 403  CONTINUE
+      JKJ=(JK-1)*NG1P1+1
+      JKJPN=JKJ+NG1
+      DO 405 JKK=JKJ,JKJPN
+      DO 404 JL = 1, KDLON
+      ZDPM = ZABLY(JL,3,JKK)
+      ZUPM = ZABLY(JL,5,JKK)             * ZDPM / 101325.
+      ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325.
+      ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325.
+      ZUPMO3  = ( ZABLY(JL,5,JKK) + PVGO3  ) * ZDPM / 101325.
+      ZDUC(JL,JKK) = ZDPM
+      ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM
+      ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3
+      ZU6 = ZXWV(JL) * ZUPM
+      ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL))
+      ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O
+      ZABLY(JL,11,JKK) = ZU6 * ZFPPW
+      ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW)
+      ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2
+      ZABLY(JL,8,JKK) = RCO2 * ZDPM
+ 404  CONTINUE
+ 405  CONTINUE
+ 406  CONTINUE
+!C
+!C-----------------------------------------------------------------------
+!C
+!C
+!C*         5.    CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
+!C                --------------------------------------------------
+!C
+ 500  CONTINUE
+!C
+      DO 502 JA = 1, NUA
+      DO 501 JL = 1, KDLON
+      PABCU(JL,JA,3*KFLEV+1) = 0.
+  501 CONTINUE
+  502 CONTINUE
+!C
+      DO 529 JK = 1 , KFLEV
+      JJ=(JK-1)*NG1P1+1
+      JJPN=JJ+NG1
+      JKL=KFLEV+1-JK
+!C
+!C
+!C*         5.1  CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
+!C               --------------------------------------------------
+!C
+ 510  CONTINUE
+!C
+      JAE1=3*KFLEV+1-JJ
+      JAE2=3*KFLEV+1-(JJ+1)
+      JAE3=3*KFLEV+1-JJPN
+      DO 512 JAE=1,5
+      DO 511 JL = 1, KDLON
+      ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1)                                    &
+       &      +RAER(JAE,2)*PAER(JL,JKL,2)+RAER(JAE,3)*PAER(JL,JKL,3)                 &
+       &      +RAER(JAE,4)*PAER(JL,JKL,4)+RAER(JAE,5)*PAER(JL,JKL,5))                &
+       &      /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3))
+ 511  CONTINUE
+ 512  CONTINUE
+!C
+!C
+!C
+!C*         5.2  INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
+!C               --------------------------------------------------
+!C
+ 520  CONTINUE
+!C
+      DO 521 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.))
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3)
+      ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0._8), 6._8)
+      ZCAH1=AT(1,1)+ZUP*(AT(1,2)+ZUP*(AT(1,3)))
+      ZCBH1=BT(1,1)+ZUP*(BT(1,2)+ZUP*(BT(1,3)))
+      ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 )
+      ZCAH2=AT(2,1)+ZUP*(AT(2,2)+ZUP*(AT(2,3)))
+      ZCBH2=BT(2,1)+ZUP*(BT(2,2)+ZUP*(BT(2,3)))
+      ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 )
+      ZCAH3=AT(3,1)+ZUP*(AT(3,2)+ZUP*(AT(3,3)))
+      ZCBH3=BT(3,1)+ZUP*(BT(3,2)+ZUP*(BT(3,3)))
+      ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 )
+      ZCAH4=AT(4,1)+ZUP*(AT(4,2)+ZUP*(AT(4,3)))
+      ZCBH4=BT(4,1)+ZUP*(BT(4,2)+ZUP*(BT(4,3)))
+      ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 )
+      ZCAH5=AT(5,1)+ZUP*(AT(5,2)+ZUP*(AT(5,3)))
+      ZCBH5=BT(5,1)+ZUP*(BT(5,2)+ZUP*(BT(5,3)))
+      ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 )
+      ZCAH6=AT(6,1)+ZUP*(AT(6,2)+ZUP*(AT(6,3)))
+      ZCBH6=BT(6,1)+ZUP*(BT(6,2)+ZUP*(BT(6,3)))
+      ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 )
+      ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 )
+      ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 )
+      ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 )
+      ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 )
+ 521  CONTINUE
+!C
+      DO 522 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3)
+      ZALUP = R10E * LOG ( ZZABLY )
+      ZUP   = MAX( 0._8, 5.0 + 0.5 * ZALUP )
+      ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP
+      ZCAC8=AT(8,1)+ZUP*(AT(8,2)+ZUP*(AT(8,3)))
+      ZCBC8=BT(8,1)+ZUP*(BT(8,2)+ZUP*(BT(8,3)))
+      ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 )
+      ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2)
+      ZPSIO(JL) = EXP( 2.* (OCT(3)*ZTX+OCT(4)*ZTX2))
+ 522  CONTINUE
+!C
+      DO 524 JKK=JJ,JJPN
+      JC=3*KFLEV+1-JKK
+      JCP1=JC+1
+      DO 523 JL = 1, KDLON
+      ZDIFF = PVIEW(JL)
+      PABCU(JL,10,JC)=PABCU(JL,10,JCP1)                                              &
+       &                +ZABLY(JL,10,JC)           *ZDIFF
+      PABCU(JL,11,JC)=PABCU(JL,11,JCP1)                                              &
+       &                +ZABLY(JL,11,JC)*ZTCON(JL)*ZDIFF
+!C
+      PABCU(JL,12,JC)=PABCU(JL,12,JCP1)                                              &
+       &                +ZABLY(JL,12,JC)*ZPHIO(JL)*ZDIFF
+      PABCU(JL,13,JC)=PABCU(JL,13,JCP1)                                              &
+       &                +ZABLY(JL,13,JC)*ZPSIO(JL)*ZDIFF
+!C
+      PABCU(JL,7,JC)=PABCU(JL,7,JCP1)                                                &
+       &               +ZABLY(JL,9,JC)*ZPSC2(JL)*ZDIFF
+      PABCU(JL,8,JC)=PABCU(JL,8,JCP1)                                                &
+       &               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+      PABCU(JL,9,JC)=PABCU(JL,9,JCP1)                                                &
+       &               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+!C
+      PABCU(JL,1,JC)=PABCU(JL,1,JCP1)                                                &
+       &               +ZABLY(JL,6,JC)*ZPSH1(JL)*ZDIFF
+      PABCU(JL,2,JC)=PABCU(JL,2,JCP1)                                                &
+       &               +ZABLY(JL,6,JC)*ZPSH2(JL)*ZDIFF
+      PABCU(JL,3,JC)=PABCU(JL,3,JCP1)                                                &
+       &               +ZABLY(JL,6,JC)*ZPSH5(JL)*ZDIFF
+      PABCU(JL,4,JC)=PABCU(JL,4,JCP1)                                                &
+       &               +ZABLY(JL,6,JC)*ZPSH3(JL)*ZDIFF
+      PABCU(JL,5,JC)=PABCU(JL,5,JCP1)                                                &
+       &               +ZABLY(JL,6,JC)*ZPSH4(JL)*ZDIFF
+      PABCU(JL,6,JC)=PABCU(JL,6,JCP1)                                                &
+       &               +ZABLY(JL,6,JC)*ZPSH6(JL)*ZDIFF
+!C
+      PABCU(JL,14,JC)=PABCU(JL,14,JCP1)                                              &
+       &                +ZUAER(JL,1)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,15,JC)=PABCU(JL,15,JCP1)                                              &
+       &                +ZUAER(JL,2)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,16,JC)=PABCU(JL,16,JCP1)                                              &
+       &                +ZUAER(JL,3)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,17,JC)=PABCU(JL,17,JCP1)                                              &
+       &                +ZUAER(JL,4)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,18,JC)=PABCU(JL,18,JCP1)                                              &
+       &                +ZUAER(JL,5)    *ZDUC(JL,JC)*ZDIFF
+!C
+!C
+
+      IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+         IF (ok_Rtime2D) THEN
+            PABCU(JL,19,JC)=PABCU(JL,19,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RCH42D(JL,JC)/RCO2*ZPHM6(JL)*ZDIFF
+            PABCU(JL,20,JC)=PABCU(JL,20,JCP1)                                        &
+       &           +ZABLY(JL,9,JC)*RCH42D(JL,JC)/RCO2*ZPSM6(JL)*ZDIFF
+            PABCU(JL,21,JC)=PABCU(JL,21,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RN2O2D(JL,JC)/RCO2*ZPHN6(JL)*ZDIFF
+            PABCU(JL,22,JC)=PABCU(JL,22,JCP1)                                        &
+       &           +ZABLY(JL,9,JC)*RN2O2D(JL,JC)/RCO2*ZPSN6(JL)*ZDIFF
+!C
+            PABCU(JL,23,JC)=PABCU(JL,23,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RCFC112D(JL,JC)/RCO2         *ZDIFF
+            PABCU(JL,24,JC)=PABCU(JL,24,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RCFC122D(JL,JC)/RCO2         *ZDIFF
+         ELSE
+            ! Same calculation as for type_trac /= repr
+            PABCU(JL,19,JC)=PABCU(JL,19,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF
+            PABCU(JL,20,JC)=PABCU(JL,20,JCP1)                                        &
+       &           +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF
+            PABCU(JL,21,JC)=PABCU(JL,21,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF
+            PABCU(JL,22,JC)=PABCU(JL,22,JCP1)                                        &
+       &           +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF
+!C     
+            PABCU(JL,23,JC)=PABCU(JL,23,JCP1)                                        &
+       &               +ZABLY(JL,8,JC)*RCFC11/RCO2         *ZDIFF
+            PABCU(JL,24,JC)=PABCU(JL,24,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RCFC12/RCO2         *ZDIFF
+         END IF
+#endif
+      ELSE
+         PABCU(JL,19,JC)=PABCU(JL,19,JCP1)                                           &
+       &        +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF
+         PABCU(JL,20,JC)=PABCU(JL,20,JCP1)                                           &
+       &               +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF
+         PABCU(JL,21,JC)=PABCU(JL,21,JCP1)                                           &
+       &        +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF
+         PABCU(JL,22,JC)=PABCU(JL,22,JCP1)                                           &
+       &        +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF
+!C     
+         PABCU(JL,23,JC)=PABCU(JL,23,JCP1)                                           &
+       &        +ZABLY(JL,8,JC)*RCFC11/RCO2         *ZDIFF
+         PABCU(JL,24,JC)=PABCU(JL,24,JCP1)                                           &
+       &        +ZABLY(JL,8,JC)*RCFC12/RCO2         *ZDIFF
+      END IF
+      
+ 523  CONTINUE
+ 524  CONTINUE
+!C
+ 529  CONTINUE
+!C
+!C
+      RETURN
+      END SUBROUTINE LWU_LMDAR4
+
+      SUBROUTINE LWBV_LMDAR4(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU,               &
+       &                PFLUC,PBINT,PBSUI,PCTS,PCNTRB)
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+!C
+!C     PURPOSE.
+!C     --------
+!C           TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
+!C           VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
+!C           SAVING
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+!C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+!C          2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+!C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+!C     BOUNDARIES.
+!C          3. COMPUTES THE CLEAR-SKY COOLING RATES.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
+!C                                          MEMORY)
+!C-----------------------------------------------------------------------
+!C* ARGUMENTS:
+      INTEGER KLIM
+!C
+      REAL(KIND=8) PDP(KDLON,KFLEV)
+      REAL(KIND=8) PDT0(KDLON)
+      REAL(KIND=8) PEMIS(KDLON)
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1)
+      REAL(KIND=8) PTL(KDLON,KFLEV+1)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)
+!C
+      REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1)
+!C     
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1)
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1)
+      REAL(KIND=8) PBSUI(KDLON)
+      REAL(KIND=8) PCTS(KDLON,KFLEV)
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1)
+!C
+!C-------------------------------------------------------------------------
+!C
+!C* LOCAL VARIABLES:
+      REAL(KIND=8) ZB(KDLON,Ninter,KFLEV+1)
+      REAL(KIND=8) ZBSUR(KDLON,Ninter)
+      REAL(KIND=8) ZBTOP(KDLON,Ninter)
+      REAL(KIND=8) ZDBSL(KDLON,Ninter,KFLEV*2)
+      REAL(KIND=8) ZGA(KDLON,8,2,KFLEV)
+      REAL(KIND=8) ZGB(KDLON,8,2,KFLEV)
+      REAL(KIND=8) ZGASUR(KDLON,8,2)
+      REAL(KIND=8) ZGBSUR(KDLON,8,2)
+      REAL(KIND=8) ZGATOP(KDLON,8,2)
+      REAL(KIND=8) ZGBTOP(KDLON,8,2)
+!C
+      INTEGER nuaer, ntraer
+!C     ------------------------------------------------------------------
+!C* COMPUTES PLANCK FUNCTIONS:
+       CALL LWB_LMDAR4(PDT0,PTAVE,PTL,                                               &
+       &          ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,                                  &
+       &          ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP)
+!C     ------------------------------------------------------------------
+!C* PERFORMS THE VERTICAL INTEGRATION:
+      NUAER = NUA
+      NTRAER = NTRA
+      CALL LWV_LMDAR4(NUAER,NTRAER, KLIM                                             &
+       &  , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE                  &
+       &  , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP                                      &
+       &  , PCNTRB,PCTS,PFLUC)
+!C     ------------------------------------------------------------------
+      RETURN
+      END SUBROUTINE LWBV_LMDAR4
+
+      SUBROUTINE LWC_LMDAR4(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC,                          &
+       &               PBINT,PBSUIN,PCTS,PCNTRB,                                     &
+       &               PFLUX)
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+!C
+!C     PURPOSE.
+!C     --------
+!C           INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
+!C           RADIANCES
+!C
+!C        EXPLICIT ARGUMENTS :
+!C        --------------------
+!C     ==== INPUTS ===
+!C PBINT  : (KDLON,0:KFLEV)     ; HALF LEVEL PLANCK FUNCTION
+!C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+!C PCLDLD : (KDLON,KFLEV)       ; DOWNWARD EFFECTIVE CLOUD FRACTION
+!C PCLDLU : (KDLON,KFLEV)       ; UPWARD EFFECTIVE CLOUD FRACTION
+!C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
+!C PCTS   : (KDLON,KFLEV)       ; CLEAR-SKY LAYER COOLING-TO-SPACE
+!C PEMIS  : (KDLON)             ; SURFACE EMISSIVITY
+!C PFLUC
+!C     ==== OUTPUTS ===
+!C PFLUX(KDLON,2,KFLEV)         ; RADIATIVE FLUXES :
+!C                     1  ==>  UPWARD   FLUX TOTAL
+!C                     2  ==>  DOWNWARD FLUX TOTAL
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
+!C          2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
+!C          3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
+!C     CLOUDS
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        Voigt lines (loop 231 to 233)  - JJM & PhD - 01/96
+!C-----------------------------------------------------------------------
+!C* ARGUMENTS:
+      INTEGER klim
+      REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1)   ! HALF LEVEL PLANCK FUNCTION
+      REAL(KIND=8) PBSUIN(KDLON)          ! SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE
+      REAL(KIND=8) PCTS(KDLON,KFLEV)      ! CLEAR-SKY LAYER COOLING-TO-SPACE
+!c
+      REAL(KIND=8) PCLDLD(KDLON,KFLEV)
+      REAL(KIND=8) PCLDLU(KDLON,KFLEV)
+      REAL(KIND=8) PEMIS(KDLON)
+!C
+      REAL(KIND=8) PFLUX(KDLON,2,KFLEV+1)
+!C-----------------------------------------------------------------------
+!C* LOCAL VARIABLES:
+      INTEGER IMX(KDLON), IMXP(KDLON)
+!C
+      REAL(KIND=8) ZCLEAR(KDLON),ZCLOUD(KDLON),                                      &
+       &     ZDNF(KDLON,KFLEV+1,KFLEV+1)                                             &
+       &  , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON)                                     &
+       &  , ZUPF(KDLON,KFLEV+1,KFLEV+1)
+      REAL(KIND=8) ZCLM(KDLON,KFLEV+1,KFLEV+1)
+!C
+      INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
+      INTEGER jk1, jk2, jkc, jkcp1, jcloud
+      INTEGER imxm1, imxp1
+      REAL(KIND=8) zcfrac
+!C     ------------------------------------------------------------------
+!C
+!C*         1.     INITIALIZATION
+!C                 --------------
+!C
+ 100  CONTINUE
+!C
+      IMAXC = 0
+!C
+      DO 101 JL = 1, KDLON
+      IMX(JL)=0
+      IMXP(JL)=0
+      ZCLOUD(JL) = 0.
+ 101  CONTINUE
+!C
+!C*         1.1    SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
+!C                 -------------------------------------------
+!C
+ 110  CONTINUE
+!C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      IMX1=IMX(JL)
+      IMX2=JK
+      IF (PCLDLU(JL,JK).GT.ZEPSC) THEN
+         IMXP(JL)=IMX2
+      ELSE
+         IMXP(JL)=IMX1
+      END IF
+      IMAXC=MAX(IMXP(JL),IMAXC)
+      IMX(JL)=IMXP(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+!CGM*******
+      IMAXC=KFLEV
+!CGM*******
+!C
+      DO 114 JK = 1 , KFLEV+1
+      DO 113 JL = 1, KDLON
+      PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
+      PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
+ 113  CONTINUE
+ 114  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.      EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
+!C                  ---------------------------------------
+!C
+      IF (IMAXC.GT.0) THEN
+!C
+         IMXP1 = IMAXC + 1
+         IMXM1 = IMAXC - 1
+!C
+!C*         2.0     INITIALIZE TO CLEAR-SKY FLUXES
+!C                  ------------------------------
+!C
+ 200  CONTINUE
+!C
+         DO 203 JK1=1,KFLEV+1
+         DO 202 JK2=1,KFLEV+1
+         DO 201 JL = 1, KDLON
+         ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
+         ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
+ 201     CONTINUE
+ 202     CONTINUE
+ 203     CONTINUE
+!C
+!C*         2.1     FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
+!C                  ----------------------------------------------
+!C
+ 210  CONTINUE
+!C
+         DO 213 JKC = 1 , IMAXC
+         JCLOUD=JKC
+         JKCP1=JCLOUD+1
+!C
+!C*         2.1.1   ABOVE THE CLOUD
+!C                  ---------------
+!C
+ 2110 CONTINUE
+!C
+         DO 2115 JK=JKCP1,KFLEV+1
+         JKM1=JK-1
+         DO 2111 JL = 1, KDLON
+         ZFU(JL)=0.
+ 2111    CONTINUE
+         IF (JK .GT. JKCP1) THEN
+            DO 2113 JKJ=JKCP1,JKM1
+            DO 2112 JL = 1, KDLON
+            ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
+ 2112       CONTINUE
+ 2113       CONTINUE
+         END IF
+!C
+         DO 2114 JL = 1, KDLON
+         ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
+ 2114    CONTINUE
+ 2115    CONTINUE
+!C
+!C*         2.1.2   BELOW THE CLOUD
+!C                  ---------------
+!C
+ 2120 CONTINUE
+!C
+         DO 2125 JK=1,JCLOUD
+         JKP1=JK+1
+         DO 2121 JL = 1, KDLON
+         ZFD(JL)=0.
+ 2121    CONTINUE
+!C
+         IF (JK .LT. JCLOUD) THEN
+            DO 2123 JKJ=JKP1,JCLOUD
+            DO 2122 JL = 1, KDLON
+            ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
+ 2122       CONTINUE
+ 2123       CONTINUE
+         END IF
+         DO 2124 JL = 1, KDLON
+         ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
+ 2124    CONTINUE
+ 2125    CONTINUE
+!C
+ 213     CONTINUE
+!C
+!C
+!C*         2.2     CLOUD COVER MATRIX
+!C                  ------------------
+!C
+!C*    ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
+!C     HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
+!C
+ 220  CONTINUE
+!C
+      DO 223 JK1 = 1 , KFLEV+1
+      DO 222 JK2 = 1 , KFLEV+1
+      DO 221 JL = 1, KDLON
+      ZCLM(JL,JK1,JK2) = 0.
+ 221  CONTINUE
+ 222  CONTINUE
+ 223  CONTINUE
+!C
+!C
+!C
+!C*         2.4     CLOUD COVER BELOW THE LEVEL OF CALCULATION
+!C                  ------------------------------------------
+!C
+ 240  CONTINUE
+!C
+      DO 244 JK1 = 2 , KFLEV+1
+      DO 241 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 241  CONTINUE
+      DO 243 JK = JK1 - 1 , 1 , -1
+      DO 242 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+!c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))                   &
+       &                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLU(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+!c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+!c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 242  CONTINUE
+ 243  CONTINUE
+ 244  CONTINUE
+!C
+!C
+!C*         2.5     CLOUD COVER ABOVE THE LEVEL OF CALCULATION
+!C                  ------------------------------------------
+!C
+ 250  CONTINUE
+!C
+      DO 254 JK1 = 1 , KFLEV
+      DO 251 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 251  CONTINUE
+      DO 253 JK = JK1 , KFLEV
+      DO 252 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+!c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))                   &
+       &                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLD(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+!c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+!c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 252  CONTINUE
+ 253  CONTINUE
+ 254  CONTINUE
+!C
+!C
+!C
+!C*         3.      FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
+!C                  ----------------------------------------------
+!C
+ 300  CONTINUE
+!C
+!C*         3.1     DOWNWARD FLUXES
+!C                  ---------------
+!C
+ 310  CONTINUE
+!C
+      DO 311 JL = 1, KDLON
+      PFLUX(JL,2,KFLEV+1) = 0.
+ 311  CONTINUE
+!C
+      DO 317 JK1 = KFLEV , 1 , -1
+!C
+!C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+!C
+      DO 312 JL = 1, KDLON
+      ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1)
+ 312  CONTINUE
+!C
+!C*                 CONTRIBUTION FROM ADJACENT CLOUD
+!C
+      DO 313 JL = 1, KDLON
+      ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
+ 313  CONTINUE
+!C
+!C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+!C
+      DO 315 JK = KFLEV-1 , JK1 , -1
+      DO 314 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
+      ZFD(JL) =  ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
+ 314  CONTINUE
+ 315  CONTINUE
+!C
+      DO 316 JL = 1, KDLON
+      PFLUX(JL,2,JK1) = ZFD (JL)
+ 316  CONTINUE
+!C
+ 317  CONTINUE
+!C
+!C
+!C
+!C
+!C*         3.2     UPWARD FLUX AT THE SURFACE
+!C                  --------------------------
+!C
+ 320  CONTINUE
+!C
+      DO 321 JL = 1, KDLON
+      PFLUX(JL,1,1) = PEMIS(JL)*PBSUIN(JL)-(1.-PEMIS(JL))*PFLUX(JL,2,1)
+ 321  CONTINUE
+!C
+!C
+!C
+!C*         3.3     UPWARD FLUXES
+!C                  -------------
+!C
+ 330  CONTINUE
+!C
+      DO 337 JK1 = 2 , KFLEV+1
+!C
+!C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+!C
+      DO 332 JL = 1, KDLON
+      ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
+ 332  CONTINUE
+!C
+!C*                 CONTRIBUTION FROM ADJACENT CLOUD
+!C
+      DO 333 JL = 1, KDLON
+      ZFU(JL) =  ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
+ 333  CONTINUE
+!C
+!C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+!C
+      DO 335 JK = 2 , JK1-1
+      DO 334 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
+      ZFU(JL) =  ZFU(JL) + ZCFRAC * ZUPF(JL,JK  ,JK1)
+ 334  CONTINUE
+ 335  CONTINUE
+!C
+      DO 336 JL = 1, KDLON
+      PFLUX(JL,1,JK1) = ZFU (JL)
+ 336  CONTINUE
+!C
+ 337  CONTINUE
+!C
+!C
+      END IF
+!C
+!C
+!C*         2.3     END OF CLOUD EFFECT COMPUTATIONS
+!C
+ 230  CONTINUE
+!C
+      IF (.NOT.LEVOIGT) THEN
+        DO 231 JL = 1, KDLON
+        ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM)
+ 231    CONTINUE
+        DO 233 JK = KLIM+1 , KFLEV+1
+        DO 232 JL = 1, KDLON
+        ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+        PFLUX(JL,1,JK) = ZFN10(JL)
+        PFLUX(JL,2,JK) = 0.0
+ 232    CONTINUE
+ 233    CONTINUE
+      ENDIF
+!C
+      RETURN
+      END SUBROUTINE LWC_LMDAR4
+
+      SUBROUTINE LWB_LMDAR4(PDT0,PTAVE,PTL                                           &
+       &  , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL                                        &
+       &  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP)
+      USE dimphy
+      USE radiation_AR4_param, only : TINTP, XP, GA, GB
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           COMPUTES PLANCK FUNCTIONS
+!C
+!C        EXPLICIT ARGUMENTS :
+!C        --------------------
+!C     ==== INPUTS ===
+!C PDT0   : (KDLON)             ; SURFACE TEMPERATURE DISCONTINUITY
+!C PTAVE  : (KDLON,KFLEV)       ; TEMPERATURE
+!C PTL    : (KDLON,0:KFLEV)     ; HALF LEVEL TEMPERATURE
+!C     ==== OUTPUTS ===
+!C PB     : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
+!C PBINT  : (KDLON,KFLEV+1)     ; HALF LEVEL PLANCK FUNCTION
+!C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+!C PBSUR  : (KDLON,Ninter)        ; SURFACE SPECTRAL PLANCK FUNCTION
+!C PBTOP  : (KDLON,Ninter)        ; TOP SPECTRAL PLANCK FUNCTION
+!C PDBSL  : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
+!C PGA    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+!C PGB    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+!C PGASUR, PGBSUR (KDLON,8,2)   ; SURFACE PADE APPROXIMANTS
+!C PGATOP, PGBTOP (KDLON,8,2)   ; T.O.A. PADE APPROXIMANTS
+!C
+!C        IMPLICIT ARGUMENTS :   NONE
+!C        --------------------
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
+!C     FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS           "
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C
+!C-----------------------------------------------------------------------
+!C
+!C ARGUMENTS:
+!C
+      REAL(KIND=8) PDT0(KDLON)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)
+      REAL(KIND=8) PTL(KDLON,KFLEV+1)
+!C
+      REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
+      REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL(KIND=8) PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION
+      REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+!C
+!C-------------------------------------------------------------------------
+!C*  LOCAL VARIABLES:
+      INTEGER INDB(KDLON),INDS(KDLON)
+      REAL(KIND=8) ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON)
+!c
+      INTEGER jk, jl, ic, jnu, jf, jg
+      INTEGER jk1, jk2
+      INTEGER k, j, ixtox, indto, ixtx, indt
+      INTEGER indsu, indtp
+      REAL(KIND=8) zdsto1, zdstox, zdst1, zdstx
+!c
+!C* Quelques parametres:
+      REAL(KIND=8) TSTAND
+      PARAMETER (TSTAND=250.0)
+      REAL(KIND=8) TSTP
+      PARAMETER (TSTP=12.5)
+      INTEGER MXIXT
+      PARAMETER (MXIXT=10)
+!C
+!C* Used Data Block:
+!c     REAL*8 TINTP(11)
+!c     SAVE TINTP
+!cc$OMP THREADPRIVATE(TINTP)
+!c     REAL*8 GA(11,16,3), GB(11,16,3)
+!c     SAVE GA, GB
+!cc$OMP THREADPRIVATE(GA, GB)
+!c     REAL*8 XP(6,6)
+!c     SAVE XP
+!cc$OMP THREADPRIVATE(XP)
+!c
+!c     DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
+!c    S             262.5, 275., 287.5, 300., 312.5 /
+!C-----------------------------------------------------------------------
+!C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
+!C
+!C
+!C
+!C
+!C-- R.D. -- G = - 0.2 SLA
+!C
+!C
+!C----- INTERVAL = 1 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 1, 1,IC),IC=1,3) /
+!C    S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
+!C     DATA (GB( 1, 1,IC),IC=1,3) /
+!C    S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
+!C     DATA (GA( 1, 2,IC),IC=1,3) /
+!C    S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
+!C     DATA (GB( 1, 2,IC),IC=1,3) /
+!C    S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 2, 1,IC),IC=1,3) /
+!C    S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
+!C     DATA (GB( 2, 1,IC),IC=1,3) /
+!C    S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
+!C     DATA (GA( 2, 2,IC),IC=1,3) /
+!C    S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
+!C     DATA (GB( 2, 2,IC),IC=1,3) /
+!C    S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 3, 1,IC),IC=1,3) /
+!C    S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
+!C     DATA (GB( 3, 1,IC),IC=1,3) /
+!C    S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
+!C     DATA (GA( 3, 2,IC),IC=1,3) /
+!C    S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
+!C     DATA (GB( 3, 2,IC),IC=1,3) /
+!C    S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 4, 1,IC),IC=1,3) /
+!C    S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
+!C     DATA (GB( 4, 1,IC),IC=1,3) /
+!C    S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
+!C     DATA (GA( 4, 2,IC),IC=1,3) /
+!C    S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
+!C     DATA (GB( 4, 2,IC),IC=1,3) /
+!C    S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 5, 1,IC),IC=1,3) /
+!C    S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
+!C     DATA (GB( 5, 1,IC),IC=1,3) /
+!C    S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
+!C     DATA (GA( 5, 2,IC),IC=1,3) /
+!C    S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
+!C     DATA (GB( 5, 2,IC),IC=1,3) /
+!C    S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 6, 1,IC),IC=1,3) /
+!C    S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
+!C     DATA (GB( 6, 1,IC),IC=1,3) /
+!C    S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
+!C     DATA (GA( 6, 2,IC),IC=1,3) /
+!C    S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
+!C     DATA (GB( 6, 2,IC),IC=1,3) /
+!C    S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 7, 1,IC),IC=1,3) /
+!C    S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
+!C     DATA (GB( 7, 1,IC),IC=1,3) /
+!C    S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
+!C     DATA (GA( 7, 2,IC),IC=1,3) /
+!C    S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
+!C     DATA (GB( 7, 2,IC),IC=1,3) /
+!C    S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 8, 1,IC),IC=1,3) /
+!C    S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
+!C     DATA (GB( 8, 1,IC),IC=1,3) /
+!C    S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
+!C     DATA (GA( 8, 2,IC),IC=1,3) /
+!C    S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
+!C     DATA (GB( 8, 2,IC),IC=1,3) /
+!C    S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 9, 1,IC),IC=1,3) /
+!C    S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
+!C     DATA (GB( 9, 1,IC),IC=1,3) /
+!C    S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
+!C     DATA (GA( 9, 2,IC),IC=1,3) /
+!C    S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
+!C     DATA (GB( 9, 2,IC),IC=1,3) /
+!C    S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA(10, 1,IC),IC=1,3) /
+!C    S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
+!C     DATA (GB(10, 1,IC),IC=1,3) /
+!C    S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
+!C     DATA (GA(10, 2,IC),IC=1,3) /
+!C    S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
+!C     DATA (GB(10, 2,IC),IC=1,3) /
+!C    S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA(11, 1,IC),IC=1,3) /
+!C    S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
+!C     DATA (GB(11, 1,IC),IC=1,3) /
+!C    S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
+!C     DATA (GA(11, 2,IC),IC=1,3) /
+!C    S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
+!C     DATA (GB(11, 2,IC),IC=1,3) /
+!C    S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
+!C
+!C
+!C
+!C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
+!C
+!C
+!C
+!C
+!C--- R.D.  ---  G = 0.02 + 0.50 / ( 1 + 4.5 U )
+!C
+!C
+!C----- INTERVAL = 2 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 1, 3,IC),IC=1,3) /
+!C    S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
+!C     DATA (GB( 1, 3,IC),IC=1,3) /
+!C    S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
+!C     DATA (GA( 1, 4,IC),IC=1,3) /
+!C    S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
+!C     DATA (GB( 1, 4,IC),IC=1,3) /
+!C    S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 2, 3,IC),IC=1,3) /
+!C    S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
+!C     DATA (GB( 2, 3,IC),IC=1,3) /
+!C    S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
+!C     DATA (GA( 2, 4,IC),IC=1,3) /
+!C    S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
+!C     DATA (GB( 2, 4,IC),IC=1,3) /
+!C    S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 3, 3,IC),IC=1,3) /
+!C    S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
+!C     DATA (GB( 3, 3,IC),IC=1,3) /
+!C    S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
+!C     DATA (GA( 3, 4,IC),IC=1,3) /
+!C    S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
+!C     DATA (GB( 3, 4,IC),IC=1,3) /
+!C    S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 4, 3,IC),IC=1,3) /
+!C    S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
+!C     DATA (GB( 4, 3,IC),IC=1,3) /
+!C    S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
+!C     DATA (GA( 4, 4,IC),IC=1,3) /
+!C    S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
+!C     DATA (GB( 4, 4,IC),IC=1,3) /
+!C    S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 5, 3,IC),IC=1,3) /
+!C    S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
+!C     DATA (GB( 5, 3,IC),IC=1,3) /
+!C    S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
+!C     DATA (GA( 5, 4,IC),IC=1,3) /
+!C    S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
+!C     DATA (GB( 5, 4,IC),IC=1,3) /
+!C    S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 6, 3,IC),IC=1,3) /
+!C    S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
+!C     DATA (GB( 6, 3,IC),IC=1,3) /
+!C    S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
+!C     DATA (GA( 6, 4,IC),IC=1,3) /
+!C    S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
+!C     DATA (GB( 6, 4,IC),IC=1,3) /
+!C    S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 7, 3,IC),IC=1,3) /
+!C    S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
+!C     DATA (GB( 7, 3,IC),IC=1,3) /
+!C    S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
+!C     DATA (GA( 7, 4,IC),IC=1,3) /
+!C    S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
+!C     DATA (GB( 7, 4,IC),IC=1,3) /
+!C    S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 8, 3,IC),IC=1,3) /
+!C    S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
+!C     DATA (GB( 8, 3,IC),IC=1,3) /
+!C    S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
+!C     DATA (GA( 8, 4,IC),IC=1,3) /
+!C    S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
+!C     DATA (GB( 8, 4,IC),IC=1,3) /
+!C    S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 9, 3,IC),IC=1,3) /
+!C    S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
+!C     DATA (GB( 9, 3,IC),IC=1,3) /
+!C    S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
+!C     DATA (GA( 9, 4,IC),IC=1,3) /
+!C    S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
+!C     DATA (GB( 9, 4,IC),IC=1,3) /
+!C    S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA(10, 3,IC),IC=1,3) /
+!C    S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
+!C     DATA (GB(10, 3,IC),IC=1,3) /
+!C    S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
+!C     DATA (GA(10, 4,IC),IC=1,3) /
+!C    S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
+!C     DATA (GB(10, 4,IC),IC=1,3) /
+!C    S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA(11, 3,IC),IC=1,3) /
+!C    S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
+!C     DATA (GB(11, 3,IC),IC=1,3) /
+!C    S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
+!C     DATA (GA(11, 4,IC),IC=1,3) /
+!C    S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
+!C     DATA (GB(11, 4,IC),IC=1,3) /
+!C    S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
+!C
+!C
+!C
+!C
+!C
+!C
+!C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
+!C
+!C
+!C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
+!C
+!C
+!C
+!C--- G = 3.875E-03 ---------------
+!C
+!C----- INTERVAL = 3 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 1, 7,IC),IC=1,3) /
+!C    S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
+!C     DATA (GB( 1, 7,IC),IC=1,3) /
+!C    S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
+!C     DATA (GA( 1, 8,IC),IC=1,3) /
+!C    S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
+!C     DATA (GB( 1, 8,IC),IC=1,3) /
+!C    S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 2, 7,IC),IC=1,3) /
+!C    S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
+!C     DATA (GB( 2, 7,IC),IC=1,3) /
+!C    S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
+!C     DATA (GA( 2, 8,IC),IC=1,3) /
+!C    S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
+!C     DATA (GB( 2, 8,IC),IC=1,3) /
+!C    S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 3, 7,IC),IC=1,3) /
+!C    S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
+!C     DATA (GB( 3, 7,IC),IC=1,3) /
+!C    S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
+!C     DATA (GA( 3, 8,IC),IC=1,3) /
+!C    S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
+!C     DATA (GB( 3, 8,IC),IC=1,3) /
+!C    S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 4, 7,IC),IC=1,3) /
+!C    S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
+!C     DATA (GB( 4, 7,IC),IC=1,3) /
+!C    S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
+!C     DATA (GA( 4, 8,IC),IC=1,3) /
+!C    S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
+!C     DATA (GB( 4, 8,IC),IC=1,3) /
+!C    S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 5, 7,IC),IC=1,3) /
+!C    S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
+!C     DATA (GB( 5, 7,IC),IC=1,3) /
+!C    S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
+!C     DATA (GA( 5, 8,IC),IC=1,3) /
+!C    S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
+!C     DATA (GB( 5, 8,IC),IC=1,3) /
+!C    S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 6, 7,IC),IC=1,3) /
+!C    S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
+!C     DATA (GB( 6, 7,IC),IC=1,3) /
+!C    S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
+!C     DATA (GA( 6, 8,IC),IC=1,3) /
+!C    S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
+!C     DATA (GB( 6, 8,IC),IC=1,3) /
+!C    S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 7, 7,IC),IC=1,3) /
+!C    S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
+!C     DATA (GB( 7, 7,IC),IC=1,3) /
+!C    S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
+!C     DATA (GA( 7, 8,IC),IC=1,3) /
+!C    S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
+!C     DATA (GB( 7, 8,IC),IC=1,3) /
+!C    S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 8, 7,IC),IC=1,3) /
+!C    S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
+!C     DATA (GB( 8, 7,IC),IC=1,3) /
+!C    S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
+!C     DATA (GA( 8, 8,IC),IC=1,3) /
+!C    S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
+!C     DATA (GB( 8, 8,IC),IC=1,3) /
+!C    S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 9, 7,IC),IC=1,3) /
+!C    S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
+!C     DATA (GB( 9, 7,IC),IC=1,3) /
+!C    S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
+!C     DATA (GA( 9, 8,IC),IC=1,3) /
+!C    S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
+!C     DATA (GB( 9, 8,IC),IC=1,3) /
+!C    S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA(10, 7,IC),IC=1,3) /
+!C    S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
+!C     DATA (GB(10, 7,IC),IC=1,3) /
+!C    S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
+!C     DATA (GA(10, 8,IC),IC=1,3) /
+!C    S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
+!C     DATA (GB(10, 8,IC),IC=1,3) /
+!C    S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA(11, 7,IC),IC=1,3) /
+!C    S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
+!C     DATA (GB(11, 7,IC),IC=1,3) /
+!C    S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
+!C     DATA (GA(11, 8,IC),IC=1,3) /
+!C    S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
+!C     DATA (GB(11, 8,IC),IC=1,3) /
+!C    S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
+!C
+!C
+!C-- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
+!C
+!C-- G = 3.6E-03
+!C
+!C----- INTERVAL = 4 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 1, 9,IC),IC=1,3) /
+!C    S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
+!C     DATA (GB( 1, 9,IC),IC=1,3) /
+!C    S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
+!C     DATA (GA( 1,10,IC),IC=1,3) /
+!C    S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
+!C     DATA (GB( 1,10,IC),IC=1,3) /
+!C    S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 2, 9,IC),IC=1,3) /
+!C    S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
+!C     DATA (GB( 2, 9,IC),IC=1,3) /
+!C    S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
+!C     DATA (GA( 2,10,IC),IC=1,3) /
+!C    S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
+!C     DATA (GB( 2,10,IC),IC=1,3) /
+!C    S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 3, 9,IC),IC=1,3) /
+!C    S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
+!C     DATA (GB( 3, 9,IC),IC=1,3) /
+!C    S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
+!C     DATA (GA( 3,10,IC),IC=1,3) /
+!C    S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
+!C     DATA (GB( 3,10,IC),IC=1,3) /
+!C    S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 4, 9,IC),IC=1,3) /
+!C    S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
+!C     DATA (GB( 4, 9,IC),IC=1,3) /
+!C    S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
+!C     DATA (GA( 4,10,IC),IC=1,3) /
+!C    S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
+!C     DATA (GB( 4,10,IC),IC=1,3) /
+!C    S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 5, 9,IC),IC=1,3) /
+!C    S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
+!C     DATA (GB( 5, 9,IC),IC=1,3) /
+!C    S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
+!C     DATA (GA( 5,10,IC),IC=1,3) /
+!C    S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
+!C     DATA (GB( 5,10,IC),IC=1,3) /
+!C    S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 6, 9,IC),IC=1,3) /
+!C    S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
+!C     DATA (GB( 6, 9,IC),IC=1,3) /
+!C    S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
+!C     DATA (GA( 6,10,IC),IC=1,3) /
+!C    S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
+!C     DATA (GB( 6,10,IC),IC=1,3) /
+!C    S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 7, 9,IC),IC=1,3) /
+!C    S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
+!C     DATA (GB( 7, 9,IC),IC=1,3) /
+!C    S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
+!C     DATA (GA( 7,10,IC),IC=1,3) /
+!C    S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
+!C     DATA (GB( 7,10,IC),IC=1,3) /
+!C    S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 8, 9,IC),IC=1,3) /
+!C    S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
+!C     DATA (GB( 8, 9,IC),IC=1,3) /
+!C    S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
+!C     DATA (GA( 8,10,IC),IC=1,3) /
+!C    S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
+!C     DATA (GB( 8,10,IC),IC=1,3) /
+!C    S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 9, 9,IC),IC=1,3) /
+!C    S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
+!C     DATA (GB( 9, 9,IC),IC=1,3) /
+!C    S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
+!C     DATA (GA( 9,10,IC),IC=1,3) /
+!C    S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
+!C     DATA (GB( 9,10,IC),IC=1,3) /
+!C    S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA(10, 9,IC),IC=1,3) /
+!C    S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
+!C     DATA (GB(10, 9,IC),IC=1,3) /
+!C    S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
+!C     DATA (GA(10,10,IC),IC=1,3) /
+!C    S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
+!C     DATA (GB(10,10,IC),IC=1,3) /
+!C    S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA(11, 9,IC),IC=1,3) /
+!C    S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
+!C     DATA (GB(11, 9,IC),IC=1,3) /
+!C    S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
+!C     DATA (GA(11,10,IC),IC=1,3) /
+!C    S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
+!C     DATA (GB(11,10,IC),IC=1,3) /
+!C    S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
+!C
+!C
+!C
+!C-- H2O -- WEAKER PARTS OF THE STRONG BANDS  -- FROM ABS225 ----
+!C
+!C-- WATER VAPOR --- 350 - 500 CM-1
+!C
+!C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
+!C
+!C----- INTERVAL = 5 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 1, 5,IC),IC=1,3) /
+!C    S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
+!C     DATA (GB( 1, 5,IC),IC=1,3) /
+!C    S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
+!C     DATA (GA( 1, 6,IC),IC=1,3) /
+!C    S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
+!C     DATA (GB( 1, 6,IC),IC=1,3) /
+!C    S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 2, 5,IC),IC=1,3) /
+!C    S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
+!C     DATA (GB( 2, 5,IC),IC=1,3) /
+!C    S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
+!C     DATA (GA( 2, 6,IC),IC=1,3) /
+!C    S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
+!C     DATA (GB( 2, 6,IC),IC=1,3) /
+!C    S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 3, 5,IC),IC=1,3) /
+!C    S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
+!C     DATA (GB( 3, 5,IC),IC=1,3) /
+!C    S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
+!C     DATA (GA( 3, 6,IC),IC=1,3) /
+!C    S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
+!C     DATA (GB( 3, 6,IC),IC=1,3) /
+!C    S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 4, 5,IC),IC=1,3) /
+!C    S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
+!C     DATA (GB( 4, 5,IC),IC=1,3) /
+!C    S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
+!C     DATA (GA( 4, 6,IC),IC=1,3) /
+!C    S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
+!C     DATA (GB( 4, 6,IC),IC=1,3) /
+!C    S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 5, 5,IC),IC=1,3) /
+!C    S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
+!C     DATA (GB( 5, 5,IC),IC=1,3) /
+!C    S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
+!C     DATA (GA( 5, 6,IC),IC=1,3) /
+!C    S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
+!C     DATA (GB( 5, 6,IC),IC=1,3) /
+!C    S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 6, 5,IC),IC=1,3) /
+!C    S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
+!C     DATA (GB( 6, 5,IC),IC=1,3) /
+!C    S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
+!C     DATA (GA( 6, 6,IC),IC=1,3) /
+!C    S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
+!C     DATA (GB( 6, 6,IC),IC=1,3) /
+!C    S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 7, 5,IC),IC=1,3) /
+!C    S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
+!C     DATA (GB( 7, 5,IC),IC=1,3) /
+!C    S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
+!C     DATA (GA( 7, 6,IC),IC=1,3) /
+!C    S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
+!C     DATA (GB( 7, 6,IC),IC=1,3) /
+!C    S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 8, 5,IC),IC=1,3) /
+!C    S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
+!C     DATA (GB( 8, 5,IC),IC=1,3) /
+!C    S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
+!C     DATA (GA( 8, 6,IC),IC=1,3) /
+!C    S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
+!C     DATA (GB( 8, 6,IC),IC=1,3) /
+!C    S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 9, 5,IC),IC=1,3) /
+!C    S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
+!C     DATA (GB( 9, 5,IC),IC=1,3) /
+!C    S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
+!C     DATA (GA( 9, 6,IC),IC=1,3) /
+!C    S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
+!C     DATA (GB( 9, 6,IC),IC=1,3) /
+!C    S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA(10, 5,IC),IC=1,3) /
+!C    S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
+!C     DATA (GB(10, 5,IC),IC=1,3) /
+!C    S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
+!C     DATA (GA(10, 6,IC),IC=1,3) /
+!C    S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
+!C     DATA (GB(10, 6,IC),IC=1,3) /
+!C    S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA(11, 5,IC),IC=1,3) /
+!C    S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
+!C     DATA (GB(11, 5,IC),IC=1,3) /
+!C    S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
+!C     DATA (GA(11, 6,IC),IC=1,3) /
+!C    S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
+!C     DATA (GB(11, 6,IC),IC=1,3) /
+!C    S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
+!C
+!C
+!C
+!C
+!C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
+!C--- G = 0.0
+!C
+!C
+!C----- INTERVAL = 6 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 1,11,IC),IC=1,3) /
+!C    S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
+!C     DATA (GB( 1,11,IC),IC=1,3) /
+!C    S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
+!C     DATA (GA( 1,12,IC),IC=1,3) /
+!C    S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
+!C     DATA (GB( 1,12,IC),IC=1,3) /
+!C    S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 2,11,IC),IC=1,3) /
+!C    S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
+!C     DATA (GB( 2,11,IC),IC=1,3) /
+!C    S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
+!C     DATA (GA( 2,12,IC),IC=1,3) /
+!C    S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
+!C     DATA (GB( 2,12,IC),IC=1,3) /
+!C    S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 3,11,IC),IC=1,3) /
+!C    S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
+!C     DATA (GB( 3,11,IC),IC=1,3) /
+!C    S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
+!C     DATA (GA( 3,12,IC),IC=1,3) /
+!C    S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
+!C     DATA (GB( 3,12,IC),IC=1,3) /
+!C    S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 4,11,IC),IC=1,3) /
+!C    S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
+!C     DATA (GB( 4,11,IC),IC=1,3) /
+!C    S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
+!C     DATA (GA( 4,12,IC),IC=1,3) /
+!C    S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
+!C     DATA (GB( 4,12,IC),IC=1,3) /
+!C    S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 5,11,IC),IC=1,3) /
+!C    S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
+!C     DATA (GB( 5,11,IC),IC=1,3) /
+!C    S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
+!C     DATA (GA( 5,12,IC),IC=1,3) /
+!C    S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
+!C     DATA (GB( 5,12,IC),IC=1,3) /
+!C    S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 6,11,IC),IC=1,3) /
+!C    S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
+!C     DATA (GB( 6,11,IC),IC=1,3) /
+!C    S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
+!C     DATA (GA( 6,12,IC),IC=1,3) /
+!C    S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
+!C     DATA (GB( 6,12,IC),IC=1,3) /
+!C    S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 7,11,IC),IC=1,3) /
+!C    S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
+!C     DATA (GB( 7,11,IC),IC=1,3) /
+!C    S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
+!C     DATA (GA( 7,12,IC),IC=1,3) /
+!C    S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
+!C     DATA (GB( 7,12,IC),IC=1,3) /
+!C    S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 8,11,IC),IC=1,3) /
+!C    S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
+!C     DATA (GB( 8,11,IC),IC=1,3) /
+!C    S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
+!C     DATA (GA( 8,12,IC),IC=1,3) /
+!C    S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
+!C     DATA (GB( 8,12,IC),IC=1,3) /
+!C    S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 9,11,IC),IC=1,3) /
+!C    S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
+!C     DATA (GB( 9,11,IC),IC=1,3) /
+!C    S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
+!C     DATA (GA( 9,12,IC),IC=1,3) /
+!C    S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
+!C     DATA (GB( 9,12,IC),IC=1,3) /
+!C    S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA(10,11,IC),IC=1,3) /
+!C    S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
+!C     DATA (GB(10,11,IC),IC=1,3) /
+!C    S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
+!C     DATA (GA(10,12,IC),IC=1,3) /
+!C    S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
+!C     DATA (GB(10,12,IC),IC=1,3) /
+!C    S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA(11,11,IC),IC=1,3) /
+!C    S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
+!C     DATA (GB(11,11,IC),IC=1,3) /
+!C    S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
+!C     DATA (GA(11,12,IC),IC=1,3) /
+!C    S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
+!C     DATA (GB(11,12,IC),IC=1,3) /
+!C    S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
+!C
+!C
+!C
+!C
+!C
+!C-- END WATER VAPOR
+!C
+!C
+!C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
+!C
+!C
+!C
+!C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9)  , X/T,  9
+!C
+!C----- INTERVAL = 2 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 1,13,IC),IC=1,3) /
+!C    S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
+!C     DATA (GB( 1,13,IC),IC=1,3) /
+!C    S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
+!C     DATA (GA( 1,14,IC),IC=1,3) /
+!C    S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
+!C     DATA (GB( 1,14,IC),IC=1,3) /
+!C    S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 2,13,IC),IC=1,3) /
+!C    S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
+!C     DATA (GB( 2,13,IC),IC=1,3) /
+!C    S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
+!C     DATA (GA( 2,14,IC),IC=1,3) /
+!C    S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
+!C     DATA (GB( 2,14,IC),IC=1,3) /
+!C    S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 3,13,IC),IC=1,3) /
+!C    S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
+!C     DATA (GB( 3,13,IC),IC=1,3) /
+!C    S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
+!C     DATA (GA( 3,14,IC),IC=1,3) /
+!C    S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
+!C     DATA (GB( 3,14,IC),IC=1,3) /
+!C    S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 4,13,IC),IC=1,3) /
+!C    S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
+!C     DATA (GB( 4,13,IC),IC=1,3) /
+!C    S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
+!C     DATA (GA( 4,14,IC),IC=1,3) /
+!C    S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
+!C     DATA (GB( 4,14,IC),IC=1,3) /
+!C    S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 5,13,IC),IC=1,3) /
+!C    S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
+!C     DATA (GB( 5,13,IC),IC=1,3) /
+!C    S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
+!C     DATA (GA( 5,14,IC),IC=1,3) /
+!C    S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
+!C     DATA (GB( 5,14,IC),IC=1,3) /
+!C    S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 6,13,IC),IC=1,3) /
+!C    S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
+!C     DATA (GB( 6,13,IC),IC=1,3) /
+!C    S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
+!C     DATA (GA( 6,14,IC),IC=1,3) /
+!C    S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
+!C     DATA (GB( 6,14,IC),IC=1,3) /
+!C    S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 7,13,IC),IC=1,3) /
+!C    S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
+!C     DATA (GB( 7,13,IC),IC=1,3) /
+!C    S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
+!C     DATA (GA( 7,14,IC),IC=1,3) /
+!C    S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
+!C     DATA (GB( 7,14,IC),IC=1,3) /
+!C    S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 8,13,IC),IC=1,3) /
+!C    S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
+!C     DATA (GB( 8,13,IC),IC=1,3) /
+!C    S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
+!C     DATA (GA( 8,14,IC),IC=1,3) /
+!C    S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
+!C     DATA (GB( 8,14,IC),IC=1,3) /
+!C    S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 9,13,IC),IC=1,3) /
+!C    S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
+!C     DATA (GB( 9,13,IC),IC=1,3) /
+!C    S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
+!C     DATA (GA( 9,14,IC),IC=1,3) /
+!C    S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
+!C     DATA (GB( 9,14,IC),IC=1,3) /
+!C    S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA(10,13,IC),IC=1,3) /
+!C    S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
+!C     DATA (GB(10,13,IC),IC=1,3) /
+!C    S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
+!C     DATA (GA(10,14,IC),IC=1,3) /
+!C    S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
+!C     DATA (GB(10,14,IC),IC=1,3) /
+!C    S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA(11,13,IC),IC=1,3) /
+!C    S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
+!C     DATA (GB(11,13,IC),IC=1,3) /
+!C    S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
+!C     DATA (GA(11,14,IC),IC=1,3) /
+!C    S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
+!C     DATA (GB(11,14,IC),IC=1,3) /
+!C    S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
+!C
+!C
+!C
+!C
+!C
+!C
+!C
+!C
+!C
+!C
+!C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
+!C
+!C
+!C-- G = 0.0
+!C
+!C
+!C----- INTERVAL = 4 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 1,15,IC),IC=1,3) /
+!C    S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
+!C     DATA (GB( 1,15,IC),IC=1,3) /
+!C    S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
+!C     DATA (GA( 1,16,IC),IC=1,3) /
+!C    S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
+!C     DATA (GB( 1,16,IC),IC=1,3) /
+!C    S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 2,15,IC),IC=1,3) /
+!C    S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
+!C     DATA (GB( 2,15,IC),IC=1,3) /
+!C    S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
+!C     DATA (GA( 2,16,IC),IC=1,3) /
+!C    S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
+!C     DATA (GB( 2,16,IC),IC=1,3) /
+!C    S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 3,15,IC),IC=1,3) /
+!C    S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
+!C     DATA (GB( 3,15,IC),IC=1,3) /
+!C    S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
+!C     DATA (GA( 3,16,IC),IC=1,3) /
+!C    S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
+!C     DATA (GB( 3,16,IC),IC=1,3) /
+!C    S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 4,15,IC),IC=1,3) /
+!C    S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
+!C     DATA (GB( 4,15,IC),IC=1,3) /
+!C    S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
+!C     DATA (GA( 4,16,IC),IC=1,3) /
+!C    S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
+!C     DATA (GB( 4,16,IC),IC=1,3) /
+!C    S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 5,15,IC),IC=1,3) /
+!C    S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
+!C     DATA (GB( 5,15,IC),IC=1,3) /
+!C    S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
+!C     DATA (GA( 5,16,IC),IC=1,3) /
+!C    S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
+!C     DATA (GB( 5,16,IC),IC=1,3) /
+!C    S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 6,15,IC),IC=1,3) /
+!C    S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
+!C     DATA (GB( 6,15,IC),IC=1,3) /
+!C    S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
+!C     DATA (GA( 6,16,IC),IC=1,3) /
+!C    S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
+!C     DATA (GB( 6,16,IC),IC=1,3) /
+!C    S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 7,15,IC),IC=1,3) /
+!C    S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
+!C     DATA (GB( 7,15,IC),IC=1,3) /
+!C    S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
+!C     DATA (GA( 7,16,IC),IC=1,3) /
+!C    S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
+!C     DATA (GB( 7,16,IC),IC=1,3) /
+!C    S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 8,15,IC),IC=1,3) /
+!C    S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
+!C     DATA (GB( 8,15,IC),IC=1,3) /
+!C    S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
+!C     DATA (GA( 8,16,IC),IC=1,3) /
+!C    S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
+!C     DATA (GB( 8,16,IC),IC=1,3) /
+!C    S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 9,15,IC),IC=1,3) /
+!C    S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
+!C     DATA (GB( 9,15,IC),IC=1,3) /
+!C    S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
+!C     DATA (GA( 9,16,IC),IC=1,3) /
+!C    S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
+!C     DATA (GB( 9,16,IC),IC=1,3) /
+!C    S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA(10,15,IC),IC=1,3) /
+!C    S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
+!C     DATA (GB(10,15,IC),IC=1,3) /
+!C    S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
+!C     DATA (GA(10,16,IC),IC=1,3) /
+!C    S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
+!C     DATA (GB(10,16,IC),IC=1,3) /
+!C    S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA(11,15,IC),IC=1,3) /
+!C    S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
+!C     DATA (GB(11,15,IC),IC=1,3) /
+!C    S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
+!C     DATA (GA(11,16,IC),IC=1,3) /
+!C    S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
+!C     DATA (GB(11,16,IC),IC=1,3) /
+!C    S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
+!C
+!C     ------------------------------------------------------------------
+!C     DATA (( XP(  J,K),J=1,6),       K=1,6) /
+!C    S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
+!C    S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
+!C    S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
+!C    S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
+!C    S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
+!C    S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
+!C    S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
+!C    S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
+!C    S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
+!C    S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
+!C    S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
+!C    S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
+
+!C
+!C
+!C*         1.0     PLANCK FUNCTIONS AND GRADIENTS
+!C                  ------------------------------
+!C
+ 100  CONTINUE
+!C
+!cdir collapse
+      DO 102 JK = 1 , KFLEV+1
+      DO 101 JL = 1, KDLON
+      PBINT(JL,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+      DO 103 JL = 1, KDLON
+      PBSUIN(JL) = 0.
+ 103  CONTINUE
+!C
+      DO 141 JNU=1,Ninter
+!C
+!C
+!C*         1.1   LEVELS FROM SURFACE TO KFLEV
+!C                ----------------------------
+!C
+ 110  CONTINUE
+!C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)                     &
+       &       +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)             &
+       &       )))))
+      PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
+      PB(JL,JNU,JK)= ZRES(JL)
+      ZBLEV(JL,JK) = ZRES(JL)
+      ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
+      ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)                    &
+       &     +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)            &
+       &       )))))
+      ZBLAY(JL,JK) = ZRES2(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+!C
+!C
+!C*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
+!C                ---------------------------------
+!C
+ 120  CONTINUE
+!C
+      DO 121 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
+      ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)                     &
+       &    +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)                &
+       &       )))))
+      ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)                  &
+       &    +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)             &
+       &       )))))
+      PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
+      PB(JL,JNU,KFLEV+1)= ZRES(JL)
+      ZBLEV(JL,KFLEV+1) = ZRES(JL)
+      PBTOP(JL,JNU) = ZRES(JL)
+      PBSUR(JL,JNU) = ZRES2(JL)
+      PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
+ 121  CONTINUE
+!C
+!C
+!C*         1.3   GRADIENTS IN SUB-LAYERS
+!C                -----------------------
+!C
+ 130  CONTINUE
+!C
+      DO 132 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 131 JL = 1, KDLON
+      PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK  ) - ZBLEV(JL,JK)
+      PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
+ 131  CONTINUE
+ 132  CONTINUE
+!C
+ 141  CONTINUE
+!C
+!C*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
+!C                ---------------------------------------------
+!C
+ 200  CONTINUE
+!C
+!C
+ 210  CONTINUE
+!C
+      DO 211 JL=1, KDLON
+      ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP
+      IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) )
+      ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP
+      IF (ZDSTOX.LT.0.5) THEN
+         INDTO=IXTOX
+      ELSE
+         INDTO=IXTOX+1
+      END IF
+      INDB(JL)=INDTO
+      ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDS(JL)=INDT
+ 211  CONTINUE
+!C
+      DO 214 JF=1,2
+      DO 213 JG=1, 8
+      DO 212 JL=1, KDLON
+      INDSU=INDS(JL)
+      PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
+      PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
+      INDTP=INDB(JL)
+      PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
+      PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
+ 212  CONTINUE
+ 213  CONTINUE
+ 214  CONTINUE
+!C
+ 220  CONTINUE
+!C
+      DO 225 JK=1,KFLEV
+      DO 221 JL=1, KDLON
+      ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDB(JL)=INDT
+ 221  CONTINUE
+!C
+      DO 224 JF=1,2
+      DO 223 JG=1, 8
+      DO 222 JL=1, KDLON
+      INDT=INDB(JL)
+      PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
+      PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
+ 222  CONTINUE
+ 223  CONTINUE
+ 224  CONTINUE
+ 225  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE LWB_LMDAR4
+
+      SUBROUTINE LWV_LMDAR4(KUAER,KTRAER, KLIM                                       &
+       &  , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE                 &
+       &  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP                                      &
+       &  , PCNTRB,PCTS,PFLUC)
+       USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
+!C           FLUXES OR RADIANCES
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
+!C     CONTRIBUTIONS BY -  THE NEARBY LAYERS
+!C                      -  THE DISTANT LAYERS
+!C                      -  THE BOUNDARY TERMS
+!C          2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C-----------------------------------------------------------------------
+!C
+!C* ARGUMENTS:
+      INTEGER KUAER,KTRAER, KLIM
+!C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+      REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
+      REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV) ! TEMPERATURE
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGASUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGATOP(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS
+!C
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+      REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+!C-----------------------------------------------------------------------
+!C LOCAL VARIABLES:
+      REAL(KIND=8) ZADJD(KDLON,KFLEV+1)
+      REAL(KIND=8) ZADJU(KDLON,KFLEV+1)
+      REAL(KIND=8) ZDBDT(KDLON,Ninter,KFLEV)
+      REAL(KIND=8) ZDISD(KDLON,KFLEV+1)
+      REAL(KIND=8) ZDISU(KDLON,KFLEV+1)
+!C
+      INTEGER jk, jl
+!C-----------------------------------------------------------------------
+!C
+      DO 112 JK=1,KFLEV+1
+      DO 111 JL=1, KDLON
+      ZADJD(JL,JK)=0.
+      ZADJU(JL,JK)=0.
+      ZDISD(JL,JK)=0.
+      ZDISU(JL,JK)=0.
+ 111  CONTINUE
+ 112  CONTINUE
+!C
+      DO 114 JK=1,KFLEV
+      DO 113 JL=1, KDLON
+      PCTS(JL,JK)=0.
+ 113  CONTINUE
+ 114  CONTINUE
+!C
+!C* CONTRIBUTION FROM ADJACENT LAYERS
+!C
+      CALL LWVN_LMDAR4(KUAER,KTRAER                                                  &
+       &  , PABCU,PDBSL,PGA,PGB                                                      &
+       &  , ZADJD,ZADJU,PCNTRB,ZDBDT)
+!C* CONTRIBUTION FROM DISTANT LAYERS
+!C
+      CALL LWVD_LMDAR4(KUAER,KTRAER                                                  &
+       &  , PABCU,ZDBDT,PGA,PGB                                                      &
+       &  , PCNTRB,ZDISD,ZDISU)
+!C
+!C* EXCHANGE WITH THE BOUNDARIES
+!C
+      CALL LWVB_LMDAR4(KUAER,KTRAER, KLIM                                            &
+       &  , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP                            &
+       &  , ZDISD,ZDISU,PEMIS,PPMB                                                   &
+       &  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP                                      &
+       &  , PCTS,PFLUC)
+!C
+!C
+      RETURN
+      END SUBROUTINE LWV_LMDAR4
+
+      SUBROUTINE LWVB_LMDAR4(KUAER,KTRAER, KLIM                                      &
+       &  , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP                             &
+       &  , PDISD,PDISU,PEMIS,PPMB                                                   &
+       &  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP                                      &
+       &  , PCTS,PFLUC)
+       USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+#include "radopt.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
+!C           INTEGRATION
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
+!C     ATMOSPHERE
+!C          2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
+!C     TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
+!C          3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        Voigt lines (loop 2413 to 2427)  - JJM & PhD - 01/96
+!C-----------------------------------------------------------------------
+!C
+!C*       0.1   ARGUMENTS
+!C              ---------
+!C
+      INTEGER KUAER,KTRAER, KLIM
+!C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL(KIND=8) PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
+      REAL(KIND=8) PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL(KIND=8) PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! PRESSURE MB
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+!C
+      REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) ZBGND(KDLON)
+      REAL(KIND=8) ZFD(KDLON)
+      REAL(KIND=8)  ZFN10(KDLON)
+      REAL(KIND=8) ZFU(KDLON)
+      REAL(KIND=8)  ZTT(KDLON,NTRA)
+      REAL(KIND=8) ZTT1(KDLON,NTRA)
+      REAL(KIND=8) ZTT2(KDLON,NTRA)
+      REAL(KIND=8)  ZUU(KDLON,NUA) 
+      REAL(KIND=8) ZCNSOL(KDLON)
+      REAL(KIND=8) ZCNTOP(KDLON)
+!C
+      INTEGER jk, jl, ja
+      INTEGER jstra, jstru
+      INTEGER ind1, ind2, ind3, ind4, in, jlim
+      REAL(KIND=8) zctstr
+!C-----------------------------------------------------------------------
+!C
+!C*         1.    INITIALIZATION
+!C                --------------
+!C
+ 100  CONTINUE
+!C
+!C
+!C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+!C                  ---------------------------------
+!C
+ 120  CONTINUE
+!C
+      DO 122 JA=1,NTRA
+      DO 121 JL=1, KDLON
+      ZTT (JL,JA)=1.0
+      ZTT1(JL,JA)=1.0
+      ZTT2(JL,JA)=1.0
+ 121  CONTINUE
+ 122  CONTINUE
+!C
+      DO 124 JA=1,NUA
+      DO 123 JL=1, KDLON
+      ZUU(JL,JA)=1.0
+ 123  CONTINUE
+ 124  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.      VERTICAL INTEGRATION
+!C                  --------------------
+!C
+ 200  CONTINUE
+!C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+!C
+!C
+!C*         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
+!C                  -----------------------------------
+!C
+ 230  CONTINUE
+!C
+      DO 235 JK = 1 , KFLEV
+      IN=(JK-1)*NG1P1+1
+!C
+      DO 232 JA=1,KUAER
+      DO 231 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,IN)
+ 231  CONTINUE
+ 232  CONTINUE
+!C
+!C
+      CALL LWTT_LMDAR4(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
+!C
+      DO 234 JL = 1, KDLON
+      ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1)          *ZTT(JL,10)                          &
+       &      +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)                            &
+       &      +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)                            &
+       &      +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)                            &
+       &      +PBTOP(JL,5)*ZTT(JL,3)          *ZTT(JL,14)                            &
+       &      +PBTOP(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 234  CONTINUE
+!C
+ 235  CONTINUE
+!C
+      JK = KFLEV+1
+      IN=(JK-1)*NG1P1+1
+!C
+      DO 236 JL = 1, KDLON
+      ZCNTOP(JL)= PBTOP(JL,1)                                                        &
+       &   + PBTOP(JL,2)                                                             &
+       &   + PBTOP(JL,3)                                                             &
+       &   + PBTOP(JL,4)                                                             &
+       &   + PBTOP(JL,5)                                                             &
+       &   + PBTOP(JL,6)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 236  CONTINUE
+!C
+!C*         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
+!C                  ---------------------------------------
+!C
+ 240  CONTINUE
+!C
+!C
+!C*         2.4.1   INITIALIZATION
+!C                  --------------
+!C
+ 2410 CONTINUE
+!C
+      JLIM = KFLEV
+!C
+      IF (.NOT.LEVOIGT) THEN
+      DO 2412 JK = KFLEV,1,-1
+      IF(PPMB(1,JK).LT.10.0) THEN
+         JLIM=JK
+      ENDIF   
+ 2412 CONTINUE
+      ENDIF
+      KLIM=JLIM
+!C
+      IF (.NOT.LEVOIGT) THEN
+        DO 2414 JA=1,KTRAER
+        DO 2413 JL=1, KDLON
+        ZTT1(JL,JA)=1.0
+ 2413   CONTINUE
+ 2414   CONTINUE
+!C
+!C*         2.4.2   LOOP OVER LAYERS ABOVE 10 HPA
+!C                  -----------------------------
+!C
+ 2420   CONTINUE
+!C
+        DO 2427 JSTRA = KFLEV,JLIM,-1
+        JSTRU=(JSTRA-1)*NG1P1+1
+!C
+        DO 2423 JA=1,KUAER
+        DO 2422 JL=1, KDLON
+        ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
+ 2422   CONTINUE
+ 2423   CONTINUE
+!C
+!C
+        CALL LWTT_LMDAR4(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
+!C
+        DO 2424 JL = 1, KDLON
+        ZCTSTR =                                                                     &
+       &   (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))                                         &
+       &       *(ZTT1(JL,1)           *ZTT1(JL,10)                                   &
+       &       - ZTT (JL,1)           *ZTT (JL,10))                                  &
+       &  +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))                                         &
+       &       *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11)                                   &
+       &       - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11))                                  &
+       &  +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))                                         &
+       &       *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12)                                   &
+       &       - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12))                                  &
+       &  +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))                                         &
+       &       *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13)                                   &
+       &       - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13))                                  &
+       &  +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))                                         &
+       &       *(ZTT1(JL,3)           *ZTT1(JL,14)                                   &
+       &       - ZTT (JL,3)           *ZTT (JL,14))                                  &
+       &  +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))                                         &
+       &       *(ZTT1(JL,6)           *ZTT1(JL,15)                                   &
+       &       - ZTT (JL,6)           *ZTT (JL,15))
+        PCTS(JL,JSTRA)=ZCTSTR*0.5
+ 2424   CONTINUE
+        DO 2426 JA=1,KTRAER
+        DO 2425 JL=1, KDLON
+        ZTT1(JL,JA)=ZTT(JL,JA)
+ 2425   CONTINUE
+ 2426   CONTINUE
+ 2427   CONTINUE
+      ENDIF
+!C Mise a zero de securite pour PCTS en cas de LEVOIGT
+      IF(LEVOIGT)THEN
+        DO 2429 JSTRA = 1,KFLEV
+        DO 2428 JL = 1, KDLON
+          PCTS(JL,JSTRA)=0.
+ 2428   CONTINUE
+ 2429   CONTINUE
+      ENDIF
+!C
+!C
+!C*         2.5     EXCHANGE WITH LOWER LIMIT
+!C                  -------------------------
+!C
+ 250  CONTINUE
+!C
+      DO 251 JL = 1, KDLON
+      ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))                                   &
+       &               *PFLUC(JL,2,1)-PBINT(JL,1)
+ 251  CONTINUE
+!C
+      JK = 1
+      IN=(JK-1)*NG1P1+1
+!C
+      DO 252 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)                                                         &
+       & +PBSUR(JL,2)                                                                &
+       & +PBSUR(JL,3)                                                                &
+       & +PBSUR(JL,4)                                                                &
+       & +PBSUR(JL,5)                                                                &
+       & +PBSUR(JL,6)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 252  CONTINUE
+!C
+      DO 257 JK = 2 , KFLEV+1
+      IN=(JK-1)*NG1P1+1
+!C
+!C
+      DO 255 JA=1,KUAER
+      DO 254 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
+ 254  CONTINUE
+ 255  CONTINUE
+!C
+!C
+      CALL LWTT_LMDAR4(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
+!C
+      DO 256 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1)          *ZTT(JL,10)                          &
+       &      +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)                            &
+       &      +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)                            &
+       &      +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)                            &
+       &      +PBSUR(JL,5)*ZTT(JL,3)          *ZTT(JL,14)                            &
+       &      +PBSUR(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 256  CONTINUE
+!C
+!C
+ 257  CONTINUE
+!C
+!C
+!C
+!C*         2.7     CLEAR-SKY FLUXES
+!C                  ----------------
+!C
+ 270  CONTINUE
+!C
+      IF (.NOT.LEVOIGT) THEN
+      DO 271 JL = 1, KDLON
+      ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
+ 271  CONTINUE
+      DO 273 JK = JLIM+1,KFLEV+1
+      DO 272 JL = 1, KDLON
+      ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+      PFLUC(JL,1,JK) = ZFN10(JL)
+      PFLUC(JL,2,JK) = 0.
+ 272  CONTINUE
+ 273  CONTINUE
+      ENDIF
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE LWVB_LMDAR4
+
+      SUBROUTINE LWVD_LMDAR4(KUAER,KTRAER                                            &
+       &  , PABCU,PDBDT                                                              &
+       &  , PGA,PGB                                                                  &
+       &  , PCNTRB,PDISD,PDISU)
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+!C     CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C-----------------------------------------------------------------------
+!C* ARGUMENTS:
+!C
+      INTEGER KUAER,KTRAER
+!C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+!C
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
+      REAL(KIND=8) PDISD(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+      REAL(KIND=8) PDISU(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) ZGLAYD(KDLON)
+      REAL(KIND=8) ZGLAYU(KDLON)
+      REAL(KIND=8) ZTT(KDLON,NTRA)
+      REAL(KIND=8) ZTT1(KDLON,NTRA)
+      REAL(KIND=8) ZTT2(KDLON,NTRA)
+!C
+      INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
+      INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
+      INTEGER ind1, ind2, ind3, ind4, itt
+      REAL(KIND=8) zww, zdzxdg, zdzxmg
+!C
+!C*         1.    INITIALIZATION
+!C                --------------
+!C
+ 100  CONTINUE
+!C
+!C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+!C                  ------------------------------
+!C
+ 110  CONTINUE
+!C
+      DO 112 JK = 1, KFLEV+1
+      DO 111 JL = 1, KDLON
+      PDISD(JL,JK) = 0.
+      PDISU(JL,JK) = 0.
+  111 CONTINUE
+  112 CONTINUE
+!C
+!C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+!C                  ---------------------------------
+!C
+ 120  CONTINUE
+!C
+!C
+      DO 122 JA = 1, NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+  121 CONTINUE
+  122 CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.      VERTICAL INTEGRATION
+!C                  --------------------
+!C
+ 200  CONTINUE
+!C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+!C
+!C
+!C*         2.2     CONTRIBUTION FROM DISTANT LAYERS
+!C                  ---------------------------------
+!C
+ 220  CONTINUE
+!C
+!C
+!C*         2.2.1   DISTANT AND ABOVE LAYERS
+!C                  ------------------------
+!C
+ 2210 CONTINUE
+!C
+!C
+!C
+!C*         2.2.2   FIRST UPPER LEVEL
+!C                  -----------------
+!C
+ 2220 CONTINUE
+!C
+      DO 225 JK = 1 , KFLEV-1
+      IKP1=JK+1
+      IKN=(JK-1)*NG1P1+1
+      IKD1= JK  *NG1P1+1
+!C
+      CALL LWTTM_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK)                                 &
+       &          , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
+!C
+!C
+!C
+!C*         2.2.3   HIGHER UP
+!C                  ---------
+!C
+ 2230 CONTINUE
+!C
+      ITT=1
+      DO 224 JKJ=IKP1,KFLEV
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IKJP1=JKJ+1
+      IKD2= JKJ  *NG1P1+1
+!C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)                             &
+       &             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
+      ELSE
+         CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)                             &
+       &             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
+      ENDIF
+!C
+      DO 2235 JA = 1, KTRAER
+      DO 2234 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2234 CONTINUE
+ 2235 CONTINUE
+!C
+      DO 2236 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)                             &
+       &   +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)                           &
+       &   +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)                           &
+       &   +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)                           &
+       &   +PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)                           &
+       &   +PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZWW
+      ZDZXDG=ZGLAYD(JL)
+      PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
+      PCNTRB(JL,JK,IKJP1)=ZDZXDG
+ 2236 CONTINUE
+!C
+!C
+ 224  CONTINUE
+ 225  CONTINUE
+!C
+!C
+!C*         2.2.4   DISTANT AND BELOW LAYERS
+!C                  ------------------------
+!C
+ 2240 CONTINUE
+!C
+!C
+!C
+!C*         2.2.5   FIRST LOWER LEVEL
+!C                  -----------------
+!C
+ 2250 CONTINUE
+!C
+      DO 228 JK=3,KFLEV+1
+      IKN=(JK-1)*NG1P1+1
+      IKM1=JK-1
+      IKJ=JK-2
+      IKU1= IKJ  *NG1P1+1
+!C
+!C
+      CALL LWTTM_LMDAR4(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)                                &
+       &          , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
+!C
+!C
+!C
+!C*         2.2.6   DOWN BELOW
+!C                  ----------
+!C
+ 2260 CONTINUE
+!C
+      ITT=1
+      DO 227 JLK=1,IKJ
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IJKL=IKM1-JLK
+      IKU2=(IJKL-1)*NG1P1+1
+!C
+!C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)                           &
+       &             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
+      ELSE
+         CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)                           &
+       &             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
+      ENDIF
+!C
+      DO 2265 JA = 1, KTRAER
+      DO 2264 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2264 CONTINUE
+ 2265 CONTINUE
+!C
+      DO 2266 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)                            &
+       &   +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)                          &
+       &   +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)                          &
+       &   +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)                          &
+       &   +PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)                          &
+       &   +PDBDT(JL,6,IJKL)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZWW
+      ZDZXMG=ZGLAYU(JL)
+      PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
+      PCNTRB(JL,JK,IJKL)=ZDZXMG
+ 2266 CONTINUE
+!C
+!C
+ 227  CONTINUE
+ 228  CONTINUE
+!C
+      RETURN
+      END SUBROUTINE LWVD_LMDAR4
+
+      SUBROUTINE LWVN_LMDAR4(KUAER,KTRAER                                            &
+       &  , PABCU,PDBSL,PGA,PGB                                                      &
+       &  , PADJD,PADJU,PCNTRB,PDBDT)
+       USE dimphy
+      USE radiation_AR4_param, only : WG1
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
+!C           TO GIVE LONGWAVE FLUXES OR RADIANCES
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+!C     CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C-----------------------------------------------------------------------
+!C
+!C* ARGUMENTS:
+!C
+      INTEGER KUAER,KTRAER
+!C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+!C
+      REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) !  LAYER PLANCK FUNCTION GRADIENT
+!C
+!C* LOCAL ARRAYS:
+!C
+      REAL(KIND=8) ZGLAYD(KDLON)
+      REAL(KIND=8) ZGLAYU(KDLON)
+      REAL(KIND=8) ZTT(KDLON,NTRA)
+      REAL(KIND=8) ZTT1(KDLON,NTRA)
+      REAL(KIND=8) ZTT2(KDLON,NTRA)
+      REAL(KIND=8) ZUU(KDLON,NUA)
+!C
+      INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
+      INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
+      REAL(KIND=8) zwtr
+!c
+
+!C-----------------------------------------------------------------------
+!C
+!C*         1.    INITIALIZATION
+!C                --------------
+!C
+ 100  CONTINUE
+!C
+!C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+!C                  ------------------------------
+!C
+ 110  CONTINUE
+!C
+      DO 112 JK = 1 , KFLEV+1
+      DO 111 JL = 1, KDLON
+      PADJD(JL,JK) = 0.
+      PADJU(JL,JK) = 0.
+ 111  CONTINUE
+ 112  CONTINUE
+!C
+!C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+!C                  ---------------------------------
+!C
+ 120  CONTINUE
+!C
+      DO 122 JA = 1 , NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+ 121  CONTINUE
+ 122  CONTINUE
+!C
+      DO 124 JA = 1 , NUA
+      DO 123 JL = 1, KDLON
+      ZUU(JL,JA) = 0.
+ 123  CONTINUE
+ 124  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.      VERTICAL INTEGRATION
+!C                  --------------------
+!C
+ 200  CONTINUE
+!C
+!C
+!C*         2.1     CONTRIBUTION FROM ADJACENT LAYERS
+!C                  ---------------------------------
+!C
+ 210  CONTINUE
+!C
+      DO 215 JK = 1 , KFLEV
+!C
+!C*         2.1.1   DOWNWARD LAYERS
+!C                  ---------------
+!C
+ 2110 CONTINUE
+!C
+      IM12 = 2 * (JK - 1)
+      IND = (JK - 1) * NG1P1 + 1
+      IXD = IND
+      INU = JK * NG1P1 + 1
+      IXU = IND
+!C
+      DO 2111 JL = 1, KDLON
+      ZGLAYD(JL) = 0.
+      ZGLAYU(JL) = 0.
+ 2111 CONTINUE
+!C
+      DO 213 JG = 1 , NG1
+      IBS = IM12 + JG
+      IDD = IXD + JG
+      DO 2113 JA = 1 , KUAER
+      DO 2112 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
+ 2112 CONTINUE
+ 2113 CONTINUE
+!C
+!C
+      CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+!C
+      DO 2114 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)                            &
+       &    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)                          &
+       &    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)                          &
+       &    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)                          &
+       &    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)                          &
+       &    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
+ 2114 CONTINUE
+!C
+!C*         2.1.2   DOWNWARD LAYERS
+!C                  ---------------
+!C
+ 2120 CONTINUE
+!C
+      IMU = IXU + JG
+      DO 2122 JA = 1 , KUAER
+      DO 2121 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
+ 2121 CONTINUE
+ 2122 CONTINUE
+!C
+!C
+      CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+!C
+      DO 2123 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)                            &
+       &    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)                          &
+       &    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)                          &
+       &    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)                          &
+       &    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)                          &
+       &    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
+ 2123 CONTINUE
+!C
+ 213  CONTINUE
+!C
+      DO 214 JL = 1, KDLON
+      PADJD(JL,JK) = ZGLAYD(JL)
+      PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
+      PADJU(JL,JK+1) = ZGLAYU(JL)
+      PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
+      PCNTRB(JL,JK  ,JK) = 0.0
+ 214  CONTINUE
+!C
+ 215  CONTINUE
+!C
+      DO 218 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 217 JNU = 1 , Ninter
+      DO 216 JL = 1, KDLON
+      PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
+ 216  CONTINUE
+ 217  CONTINUE
+ 218  CONTINUE
+!C
+      RETURN
+!C
+      END SUBROUTINE LWVN_LMDAR4
+
+      SUBROUTINE LWTT_LMDAR4(PGA,PGB,PUU, PTT)
+       USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+!C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+!C     INTERVALS.
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+!C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+!C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+!C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+!C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 88-12-15
+!C
+!C-----------------------------------------------------------------------
+      REAL(KIND=8) O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL(KIND=8) RPIALF0
+      PARAMETER (RPIALF0=2.0)
+!C
+!C* ARGUMENTS:
+!C
+      REAL(KIND=8) PUU(KDLON,NUA)
+      REAL(KIND=8) PTT(KDLON,NTRA)
+      REAL(KIND=8) PGA(KDLON,8,2)
+      REAL(KIND=8) PGB(KDLON,8,2)
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) zz, zxd, zxn
+      REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
+      REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
+      REAL(KIND=8) zx, zy, zsq1, zsq2, zvxy, zuxy
+      REAL(KIND=8) zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
+      REAL(KIND=8) zsqn21, zodn21, zsqh42, zodh42
+      REAL(KIND=8) zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
+      REAL(KIND=8) zuu11, zuu12, za11, za12
+      INTEGER jl, ja
+!C     ------------------------------------------------------------------
+!C
+!C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+!C                 -----------------------------------------------
+!C
+ 100  CONTINUE
+!C
+!C
+!cdir collapse
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU(JL,JA))
+!c     ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
+!c     ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
+!c     PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+!C                 ---------------------------------------------------
+!C
+ 200  CONTINUE
+!C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+!C
+!C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+!C
+      ZPU   = 0.002 * PUU(JL,10)
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   =  PUU(JL,11)
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+!C
+!C-  OZONE ABSORPTION
+!C
+      ZX = PUU(JL,12)
+      ZY = PUU(JL,13)
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = PUU(JL,17) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+!C
+!C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+!C
+!C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+!c     NEXOTIC=1
+!c     IF (NEXOTIC.EQ.1) THEN
+      ZXCH4 = PUU(JL,19)
+      ZYCH4 = PUU(JL,20)
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+!C
+!C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZXN2O = PUU(JL,21)
+      ZYN2O = PUU(JL,22)
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+!C
+!C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+!C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+!C
+!C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+!C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+!C
+!C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZA11 = 2. * PUU(JL,23) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+!C
+!C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZA12 = 2. * PUU(JL,24) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+!C
+      ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10
+      ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - PUU(JL,14) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 )
+ 201  CONTINUE
+!C
+      RETURN
+      END SUBROUTINE LWTT_LMDAR4
+
+      SUBROUTINE LWTTM_LMDAR4(PGA,PGB,PUU1,PUU2, PTT)
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+!C
+!C     ------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+!C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+!C     INTERVALS.
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+!C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+!C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+!C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+!C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 88-12-15
+!C
+!C-----------------------------------------------------------------------
+      REAL(KIND=8) O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL(KIND=8) RPIALF0
+      PARAMETER (RPIALF0=2.0)
+!C
+!C* ARGUMENTS:
+!C
+      REAL(KIND=8) PGA(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
+      REAL(KIND=8) PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
+      REAL(KIND=8) PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS
+!C
+!C* LOCAL VARIABLES:
+!C
+      INTEGER ja, jl
+      REAL(KIND=8) zz, zxd, zxn
+      REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
+      REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
+      REAL(KIND=8) zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
+      REAL(KIND=8) zxch4, zych4, zsqh41, zodh41
+      REAL(KIND=8) zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
+      REAL(KIND=8) zsqn22, zodn22, za11, zttf11, za12, zttf12
+      REAL(KIND=8) zuu11, zuu12
+!C     ------------------------------------------------------------------
+!C
+!C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+!C                 -----------------------------------------------
+!C
+ 100  CONTINUE
+!C
+!C
+
+!CDIR ON_ADB(PUU1)
+!CDIR ON_ADB(PUU2)
+!CDIR COLLAPSE
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU1(JL,JA) - PUU2(JL,JA))
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+!C                 ---------------------------------------------------
+!C
+ 200  CONTINUE
+!C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+!C
+!C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+!C
+      ZPU   = 0.002 * (PUU1(JL,10) - PUU2(JL,10))
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   = (PUU1(JL,11) - PUU2(JL,11))
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+!C
+!C-  OZONE ABSORPTION
+!C
+      ZX = (PUU1(JL,12) - PUU2(JL,12))
+      ZY = (PUU1(JL,13) - PUU2(JL,13))
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+!C
+!C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+!C
+!C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))
+      ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+!C
+!C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZXN2O = (PUU1(JL,21) - PUU2(JL,21))
+      ZYN2O = (PUU1(JL,22) - PUU2(JL,22))
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+!C
+!C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+!C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+!C
+!C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+!C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+!C
+!C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+!C
+!C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+!C
+      ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10
+      ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -                        &
+       &         ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )
+ 201  CONTINUE
+!C
+      RETURN
+      END SUBROUTINE LWTTM_LMDAR4
+
+END MODULE radiation_AR4
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/radiation_AR4_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/radiation_AR4_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/radiation_AR4_mod.F90	(revision 17)
@@ -0,0 +1,6103 @@
+!IM ctes ds clesphys.h   SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC, 
+MODULE radiation_AR4_mod
+
+  CONTAINS
+
+      SUBROUTINE SW_LMDAR4(PSCT, PRMU0, PFRAC,                                       &
+       &              PPMB, PDP,                                                     &
+       &              PPSOL, PALBD, PALBP,                                           &
+       &              PTAVE, PWV, PQS, POZON, PAER,                                  &
+       &              PCLDSW, PTAU, POMEGA, PCG,                                     &
+       &              PHEAT, PHEAT0,                                                 &
+       &              PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,                         &
+       &              ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,                                     &
+       &              tauae, pizae, cgae,                                            &
+       &              PTAUA, POMEGAA,                                                &
+       &              PTOPSWAD,PSOLSWAD,PTOPSWAI,PSOLSWAI,                           &
+       &              ok_ade, ok_aie )
+      USE dimphy      
+      IMPLICIT none
+
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "YOMCST.h"
+#include "iniprint.h"
+!C
+!C     ------------------------------------------------------------------
+!C
+!C     PURPOSE.
+!C     --------
+!C
+!C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+!C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
+!C          2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL  (SW1S)
+!C          3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL  (SW2S)
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+!C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        95-01-01   J.-J. MORCRETTE  Direct/Diffuse Albedo
+!c        03-11-27   J. QUAAS Introduce aerosol forcings (based on BOUCHER)
+!C     ------------------------------------------------------------------
+!C
+!C* ARGUMENTS:
+!C
+      REAL(KIND=8) PSCT  ! constante solaire (valeur conseillee: 1370)
+!IM ctes ds clesphys.h   REAL(KIND=8) RCO2  ! concentration CO2 (IPCC: 353.E-06*44.011/28.97)
+#include "clesphys.h"
+!C
+      REAL(KIND=8) PPSOL(KDLON)        ! SURFACE PRESSURE (PA)
+      REAL(KIND=8) PDP(KDLON,KFLEV)    ! LAYER THICKNESS (PA)
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+!C
+      REAL(KIND=8) PRMU0(KDLON)  ! COSINE OF ZENITHAL ANGLE
+      REAL(KIND=8) PFRAC(KDLON)  ! fraction de la journee
+!C
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)  ! LAYER TEMPERATURE (K)
+      REAL(KIND=8) PWV(KDLON,KFLEV)    ! SPECIFIC HUMIDITY (KG/KG)
+      REAL(KIND=8) PQS(KDLON,KFLEV)    ! SATURATED WATER VAPOUR (KG/KG)
+      REAL(KIND=8) POZON(KDLON,KFLEV)  ! OZONE CONCENTRATION (KG/KG)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
+!C
+      REAL(KIND=8) PALBD(KDLON,2)  ! albedo du sol (lumiere diffuse)
+      REAL(KIND=8) PALBP(KDLON,2)  ! albedo du sol (lumiere parallele)
+!C
+      REAL(KIND=8) PCLDSW(KDLON,KFLEV)    ! CLOUD FRACTION
+      REAL(KIND=8) PTAU(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS
+      REAL(KIND=8) PCG(KDLON,2,KFLEV)     ! ASYMETRY FACTOR
+      REAL(KIND=8) POMEGA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+!C
+      REAL(KIND=8) PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
+      REAL(KIND=8) PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
+      REAL(KIND=8) PALBPLA(KDLON)     ! PLANETARY ALBEDO
+      REAL(KIND=8) PTOPSW(KDLON)      ! SHORTWAVE FLUX AT T.O.A.
+      REAL(KIND=8) PSOLSW(KDLON)      ! SHORTWAVE FLUX AT SURFACE
+      REAL(KIND=8) PTOPSW0(KDLON)     ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
+      REAL(KIND=8) PSOLSW0(KDLON)     ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
+!C
+!C* LOCAL VARIABLES:
+!C
+      real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
+
+      REAL(KIND=8) ZOZ(KDLON,KFLEV)
+!     column-density of ozone in layer, in kilo-Dobsons
+
+      REAL(KIND=8) ZAKI(KDLON,2)     
+      REAL(KIND=8) ZCLD(KDLON,KFLEV)
+      REAL(KIND=8) ZCLEAR(KDLON) 
+      REAL(KIND=8) ZDSIG(KDLON,KFLEV)
+      REAL(KIND=8) ZFACT(KDLON)
+      REAL(KIND=8) ZFD(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFDOWN(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFU(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFUP(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRMU(KDLON)
+      REAL(KIND=8) ZSEC(KDLON)
+      REAL(KIND=8) ZUD(KDLON,5,KFLEV+1)
+      REAL(KIND=8) ZCLDSW0(KDLON,KFLEV)
+!c
+      REAL(KIND=8) ZFSUP(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFSDN(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1)
+!C
+      INTEGER inu, jl, jk, i, k, kpl1
+!c
+      INTEGER swpas  ! Every swpas steps, sw is calculated
+      PARAMETER(swpas=1)
+!c
+      INTEGER itapsw
+      LOGICAL appel1er
+      DATA itapsw /0/
+      DATA appel1er /.TRUE./
+      SAVE itapsw,appel1er
+!$OMP THREADPRIVATE(appel1er)
+!$OMP THREADPRIVATE(itapsw)
+!cjq-Introduced for aerosol forcings
+      real(kind=8) flag_aer
+      logical ok_ade, ok_aie    ! use aerosol forcings or not?
+      real(kind=8) tauae(kdlon,kflev,2)  ! aerosol optical properties
+      real(kind=8) pizae(kdlon,kflev,2)  ! (see aeropt.F)
+      real(kind=8) cgae(kdlon,kflev,2)   ! -"-
+      REAL(KIND=8) PTAUA(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS (pre-industrial value)
+      REAL(KIND=8) POMEGAA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+      REAL(KIND=8) PTOPSWAD(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
+      REAL(KIND=8) PSOLSWAD(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
+      REAL(KIND=8) PTOPSWAI(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
+      REAL(KIND=8) PSOLSWAI(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
+!cjq - Fluxes including aerosol effects
+      REAL(KIND=8),allocatable,save :: ZFSUPAD(:,:)
+!$OMP THREADPRIVATE(ZFSUPAD)
+      REAL(KIND=8),allocatable,save :: ZFSDNAD(:,:)
+!$OMP THREADPRIVATE(ZFSDNAD)
+      REAL(KIND=8),allocatable,save :: ZFSUPAI(:,:)
+!$OMP THREADPRIVATE(ZFSUPAI)
+      REAL(KIND=8),allocatable,save :: ZFSDNAI(:,:)
+!$OMP THREADPRIVATE(ZFSDNAI)
+      logical initialized
+!cym      SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes
+!rv
+      save flag_aer
+!$OMP THREADPRIVATE(flag_aer)
+      data initialized/.false./
+      save initialized
+!$OMP THREADPRIVATE(initialized)
+!cjq-end
+      REAL tmp_
+      if(.not.initialized) then
+        flag_aer=0.
+        initialized=.TRUE.
+        allocate(ZFSUPAD(KDLON,KFLEV+1))
+        allocate(ZFSDNAD(KDLON,KFLEV+1))
+        allocate(ZFSUPAI(KDLON,KFLEV+1))
+        allocate(ZFSDNAI(KDLON,KFLEV+1))
+
+        ZFSUPAD(:,:)=0.
+        ZFSDNAD(:,:)=0.
+        ZFSUPAI(:,:)=0.
+        ZFSDNAI(:,:)=0.
+      endif
+
+      IF (appel1er) THEN
+         WRITE(lunout,*) 'SW calling frequency : ', swpas
+         WRITE(lunout,*) "   In general, it should be 1"
+         appel1er = .FALSE.
+      ENDIF
+!C     ------------------------------------------------------------------
+      IF (MOD(itapsw,swpas).EQ.0) THEN
+!c
+      tmp_ = 1./( dobson_u * 1e3 * RG)
+!cdir collapse
+      DO JK = 1 , KFLEV
+        DO JL = 1, KDLON
+          ZCLDSW0(JL,JK) = 0.0
+          ZOZ(JL,JK) = POZON(JL,JK)*tmp_*PDP(JL,JK)
+        ENDDO
+      ENDDO
+!C
+!C
+!c clear-sky:
+!IM ctes ds clesphys.h  CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL,
+      CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,                                       &
+       &         PRMU0,PFRAC,PTAVE,PWV,                                              &
+       &         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,                               &
+       &     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,                              &
+       &     ZFD, ZFU)
+      INU = 2
+      CALL SW2S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,                         &
+       &     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,                              &
+       &     PWV, PQS,                                                               &
+       &     ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP0(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      
+      flag_aer=0.0
+      CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,                                        &
+       &         PRMU0,PFRAC,PTAVE,PWV,                                              &
+       &         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,                                &
+       &     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,                              &
+       &     ZFD, ZFU)
+      INU = 2
+      CALL SW2S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,                          &
+       &     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,                              &
+       &     PWV, PQS,                                                               &
+       &    ZFDOWN, ZFUP)
+
+!c cloudy-sky:
+      
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      
+!c      
+      IF (ok_ade) THEN
+!c
+!c cloudy-sky + aerosol dir OB
+      flag_aer=1.0
+      CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,                                        &
+       &         PRMU0,PFRAC,PTAVE,PWV,                                              &
+       &         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,                                &
+       &     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,                              &
+       &     ZFD, ZFU)
+      INU = 2
+      CALL SW2S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,                          &
+       &     ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,                              &
+       &     PWV, PQS,                                                               &
+       &    ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUPAD(JL,JK) = ZFSUP(JL,JK) 
+         ZFSDNAD(JL,JK) = ZFSDN(JL,JK) 
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO 
+      
+      ENDIF ! ok_ade
+      
+      IF (ok_aie) THEN
+         
+!cjq   cloudy-sky + aerosol direct + aerosol indirect
+      flag_aer=1.0
+      CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,                                        &
+       &         PRMU0,PFRAC,PTAVE,PWV,                                              &
+       &         ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+      INU = 1
+      CALL SW1S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,                                &
+       &     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,                            &
+       &     ZFD, ZFU)
+      INU = 2
+      CALL SW2S_LMDAR4(INU,                                                          &
+       &     PAER, flag_aer, tauae, pizae, cgae,                                     &
+       &     ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,                          &
+       &     ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,                            &
+       &     PWV, PQS,                                                               &
+       &    ZFDOWN, ZFUP)
+      DO JK = 1 , KFLEV+1
+      DO JL = 1, KDLON
+         ZFSUPAI(JL,JK) = ZFSUP(JL,JK) 
+         ZFSDNAI(JL,JK) = ZFSDN(JL,JK)          
+         ZFSUP(JL,JK) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+         ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+      ENDDO
+      ENDDO
+      ENDIF ! ok_aie      
+!cjq -end
+      
+      itapsw = 0
+      ENDIF
+      itapsw = itapsw + 1
+!C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))                                 &
+       &                     -(ZFSDN(i,k)-ZFSDN(i,kpl1))
+            PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))                              &
+       &                     -(ZFSDN0(i,k)-ZFSDN0(i,kpl1))
+            PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20)
+!c
+         PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1)
+         PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1)
+!c
+         PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1)
+         PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1)
+!c-OB
+         PSOLSWAD(i) = ZFSDNAD(i,1) - ZFSUPAD(i,1)
+         PTOPSWAD(i) = ZFSDNAD(i,KFLEV+1) - ZFSUPAD(i,KFLEV+1)
+!c
+         PSOLSWAI(i) = ZFSDNAI(i,1) - ZFSUPAI(i,1)
+         PTOPSWAI(i) = ZFSDNAI(i,KFLEV+1) - ZFSUPAI(i,KFLEV+1)
+!c-fin 
+      ENDDO
+!C
+      RETURN
+      END SUBROUTINE SW_LMDAR4
+!c
+!IM ctes ds clesphys.h   SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
+      SUBROUTINE SWU_LMDAR4 (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,                     &
+       &                PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT,                      &
+       &                PRMU,PSEC,PUD)
+      USE dimphy
+      USE radiation_AR4_param, only :                                                &
+       &     ZPDH2O,ZPDUMG,ZPRH2O,ZPRUMG,RTDH2O,RTDUMG,RTH2O,RTUMG
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+#include "YOMCST.h"
+!C
+!C* ARGUMENTS:
+!C
+      REAL(KIND=8) PSCT
+!IM ctes ds clesphys.h   REAL(KIND=8) RCO2
+#include "clesphys.h"
+      REAL(KIND=8) PCLDSW(KDLON,KFLEV)
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1)
+      REAL(KIND=8) PPSOL(KDLON)
+      REAL(KIND=8) PRMU0(KDLON)
+      REAL(KIND=8) PFRAC(KDLON)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)
+      REAL(KIND=8) PWV(KDLON,KFLEV)
+!C
+      REAL(KIND=8) PAKI(KDLON,2)
+      REAL(KIND=8) PCLD(KDLON,KFLEV)
+      REAL(KIND=8) PCLEAR(KDLON)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) PFACT(KDLON)
+      REAL(KIND=8) PRMU(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+      REAL(KIND=8) PUD(KDLON,5,KFLEV+1)
+!C
+!C* LOCAL VARIABLES:
+!C
+      INTEGER IIND(2)
+      REAL(KIND=8) ZC1J(KDLON,KFLEV+1)
+      REAL(KIND=8) ZCLEAR(KDLON)
+      REAL(KIND=8) ZCLOUD(KDLON)
+      REAL(KIND=8) ZN175(KDLON)
+      REAL(KIND=8) ZN190(KDLON)
+      REAL(KIND=8) ZO175(KDLON)
+      REAL(KIND=8) ZO190(KDLON)
+      REAL(KIND=8) ZSIGN(KDLON)
+      REAL(KIND=8) ZR(KDLON,2) 
+      REAL(KIND=8) ZSIGO(KDLON)
+      REAL(KIND=8) ZUD(KDLON,2)
+      REAL(KIND=8) ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW
+      INTEGER jl, jk, jkp1, jkl, jklp1, ja
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         1.     COMPUTES AMOUNTS OF ABSORBERS
+!C                 -----------------------------
+!C
+ 100  CONTINUE
+!C
+      IIND(1)=1
+      IIND(2)=2
+!C      
+!C
+!C*         1.1    INITIALIZES QUANTITIES
+!C                 ----------------------
+!C
+ 110  CONTINUE
+!C
+      DO 111 JL = 1, KDLON
+      PUD(JL,1,KFLEV+1)=0.
+      PUD(JL,2,KFLEV+1)=0.
+      PUD(JL,3,KFLEV+1)=0.
+      PUD(JL,4,KFLEV+1)=0.
+      PUD(JL,5,KFLEV+1)=0.
+      PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT
+      PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
+      PSEC(JL)=1./PRMU(JL)
+      ZC1J(JL,KFLEV+1)=0.
+ 111  CONTINUE
+!C
+!C*          1.3    AMOUNTS OF ABSORBERS
+!C                  --------------------
+!C
+ 130  CONTINUE
+!C
+      DO 131 JL= 1, KDLON
+      ZUD(JL,1) = 0.
+      ZUD(JL,2) = 0.
+      ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.)
+      ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.)
+      ZSIGO(JL) = PPSOL(JL)
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 131  CONTINUE
+!C
+      DO 133 JK = 1 , KFLEV
+      JKP1 = JK + 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL+1
+      DO 132 JL = 1, KDLON
+      ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O
+      ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG
+      ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZSIGN(JL) = 100. * PPMB(JL,JKP1)
+      PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)
+      ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)
+      ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)
+      ZDSCO2 = ZO175(JL) - ZN175(JL)
+      ZDSH2O = ZO190(JL) - ZN190(JL)
+      PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)                   &
+       &             * ZDSH2O * ZWH2O  * ZRTH
+      PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)                   &
+       &             * ZDSCO2 * RCO2 * ZRTU
+      ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O)
+      PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW
+      PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)
+      ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)
+      ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)
+      ZSIGO(JL) = ZSIGN(JL)
+      ZO175(JL) = ZN175(JL)
+      ZO190(JL) = ZN190(JL)
+!C      
+      IF (NOVLP.EQ.1) THEN
+         ZCLEAR(JL)=ZCLEAR(JL)                                                       &
+       &               *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))                          &
+       &               /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDSW(JL,JKL)
+      ELSE IF (NOVLP.EQ.2) THEN
+         ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1J(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 132  CONTINUE
+ 133  CONTINUE
+      DO 134 JL=1, KDLON
+      PCLEAR(JL)=1.-ZC1J(JL,1)
+ 134  CONTINUE
+      DO 136 JK=1,KFLEV
+      DO 135 JL=1, KDLON
+      IF (PCLEAR(JL).LT.1.) THEN
+         PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))
+      ELSE
+         PCLD(JL,JK)=0.
+      END IF
+ 135  CONTINUE
+ 136  CONTINUE           
+!C      
+!C
+!C*         1.4    COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
+!C                 -----------------------------------------------
+!C
+ 140  CONTINUE
+!C
+      DO 142 JA = 1,2
+      DO 141 JL = 1, KDLON
+      ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)
+ 141  CONTINUE
+ 142  CONTINUE
+!C
+      CALL SWTT1_LMDAR4(2, 2, IIND, ZUD, ZR)
+!C
+      DO 144 JA = 1,2
+      DO 143 JL = 1, KDLON
+      PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)
+ 143  CONTINUE
+ 144  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE SWU_LMDAR4
+
+      SUBROUTINE SW1S_LMDAR4 ( KNU                                                   &
+       &  ,  PAER  , flag_aer, tauae, pizae, cgae                                    &
+       &  ,  PALBD , PALBP, PCG  , PCLD , PCLEAR, PCLDSW                             &
+       &  ,  PDSIG , POMEGA, POZ  , PRMU , PSEC , PTAU  , PUD                        &
+       &  ,  PFD   , PFU)
+      USE dimphy
+      USE radiation_AR4_param, only : RSUN, RRAY
+      USE infotrac, ONLY : type_trac
+#ifdef REPROBUS
+      USE CHEM_REP, ONLY : RSUNTIME, ok_SUNTIME
+#endif
+
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"i
+#include "iniprint.h"
+!C
+!C     ------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C
+!C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+!C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
+!C     CONTINUUM SCATTERING
+!C          2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+!C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+!C     ------------------------------------------------------------------
+!C
+!C* ARGUMENTS:
+!C
+      INTEGER KNU
+!c-OB
+      real(kind=8) flag_aer
+      real(kind=8) tauae(kdlon,kflev,2)
+      real(kind=8) pizae(kdlon,kflev,2)
+      real(kind=8) cgae(kdlon,kflev,2)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)
+      REAL(KIND=8) PALBD(KDLON,2)
+      REAL(KIND=8) PALBP(KDLON,2)
+      REAL(KIND=8) PCG(KDLON,2,KFLEV)  
+      REAL(KIND=8) PCLD(KDLON,KFLEV)
+      REAL(KIND=8) PCLDSW(KDLON,KFLEV)
+      REAL(KIND=8) PCLEAR(KDLON)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) POMEGA(KDLON,2,KFLEV)
+      REAL(KIND=8) POZ(KDLON,KFLEV)
+      REAL(KIND=8) PRMU(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+      REAL(KIND=8) PTAU(KDLON,2,KFLEV)
+      REAL(KIND=8) PUD(KDLON,5,KFLEV+1)
+!C
+      REAL(KIND=8) PFD(KDLON,KFLEV+1)
+      REAL(KIND=8) PFU(KDLON,KFLEV+1)
+!C
+!C* LOCAL VARIABLES:
+!C
+      INTEGER IIND(4)
+!C      
+      REAL(KIND=8) ZCGAZ(KDLON,KFLEV) 
+      REAL(KIND=8) ZDIFF(KDLON)
+      REAL(KIND=8) ZDIRF(KDLON)        
+      REAL(KIND=8) ZPIZAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZRAYL(KDLON)
+      REAL(KIND=8) ZRAY1(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRAY2(KDLON,KFLEV+1)
+      REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1)
+      REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRK(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRMUE(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRMU0(KDLON,KFLEV+1)
+      REAL(KIND=8) ZR(KDLON,4)
+      REAL(KIND=8) ZTAUAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZTRA1(KDLON,KFLEV+1)
+      REAL(KIND=8) ZTRA2(KDLON,KFLEV+1)
+      REAL(KIND=8) ZW(KDLON,4)
+!C
+      INTEGER jl, jk, k, jaj, ikm1, ikl
+
+!C If running with Reporbus, overwrite default values of RSUN. 
+!C Otherwise keep default values from radiation_AR4_param module.  
+      IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+         IF (ok_SUNTIME) THEN
+            RSUN(1) = RSUNTIME(1)
+            RSUN(2) = RSUNTIME(2)
+         ENDIF
+         WRITE(lunout,*)'RSUN(1): ',RSUN(1)
+#endif
+      END IF
+
+!C     ------------------------------------------------------------------
+!C
+!C*         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
+!C                 ----------------------- ------------------
+!C
+ 100  CONTINUE
+!C
+!C
+!C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+!C                 -----------------------------------------
+!C
+ 110  CONTINUE
+!C
+      DO 111 JL = 1, KDLON
+      ZRAYL(JL) =  RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL)                  &
+       &          * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL)                &
+       &          * (RRAY(KNU,5) + PRMU(JL) *  RRAY(KNU,6)       ))))
+ 111  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.    CONTINUUM SCATTERING CALCULATIONS
+!C                ---------------------------------
+!C
+ 200  CONTINUE
+!C
+!C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+!C                --------------------------------
+!C  
+ 210  CONTINUE
+!C
+      CALL SWCLR_LMDAR4 ( KNU                                                        &
+       &  , PAER   , flag_aer, tauae, pizae, cgae                                    &
+       &  , PALBP  , PDSIG , ZRAYL, PSEC                                             &
+       &  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0                              &
+       &  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+!C
+!C
+!C*         2.2   CLOUDY FRACTION OF THE COLUMN
+!C                -----------------------------
+!C
+ 220  CONTINUE
+!C
+      CALL SWR_LMDAR4 ( KNU                                                          &
+       &  , PALBD ,PCG   ,PCLD  ,PDSIG ,POMEGA,ZRAYL                                 &
+       &  , PSEC  ,PTAU                                                              &
+       &  , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ  ,ZRK,ZRMUE                       &
+       &  , ZTAUAZ,ZTRA1 ,ZTRA2)
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.    OZONE ABSORPTION
+!C                ----------------
+!C
+ 300  CONTINUE
+!C
+      IIND(1)=1
+      IIND(2)=3
+      IIND(3)=1
+      IIND(4)=3
+!C      
+!C
+!C*         3.1   DOWNWARD FLUXES
+!C                ---------------
+!C
+ 310  CONTINUE
+!C
+      JAJ = 2
+!C
+      DO 311 JL = 1, KDLON
+      ZW(JL,1)=0.
+      ZW(JL,2)=0.
+      ZW(JL,3)=0.
+      ZW(JL,4)=0.
+      PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1)                           &
+       &     + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU)
+ 311  CONTINUE
+      DO 314 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 312 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL)
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+ 312  CONTINUE
+!C
+      CALL SWTT1_LMDAR4(KNU, 4, IIND, ZW, ZR)
+!C
+      DO 313 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL)
+      PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL)                                     &
+       &                  +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 313  CONTINUE
+ 314  CONTINUE
+!C
+!C
+!C*         3.2   UPWARD FLUXES
+!C                -------------
+!C
+ 320  CONTINUE
+!C
+      DO 325 JL = 1, KDLON
+      PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU)                           &
+       &               + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU))                        &
+       &          * RSUN(KNU)
+ 325  CONTINUE
+!C
+      DO 328 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 326 JL = 1, KDLON
+      ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKM1)*1.66
+      ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66
+      ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKM1)*1.66
+ 326  CONTINUE
+!C
+      CALL SWTT1_LMDAR4(KNU, 4, IIND, ZW, ZR)
+!C
+      DO 327 JL = 1, KDLON
+      ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK)
+      ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK)
+      PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL)                                      &
+       &                 +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)
+ 327  CONTINUE
+ 328  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE SW1S_LMDAR4
+      SUBROUTINE SW2S_LMDAR4 ( KNU                                                   &
+       &  ,  PAER  , flag_aer, tauae, pizae, cgae                                    &
+       &  ,  PAKI, PALBD, PALBP, PCG   , PCLD, PCLEAR, PCLDSW                        &
+       &  ,  PDSIG ,POMEGA,POZ , PRMU , PSEC  , PTAU                                 &
+       &  ,  PUD   ,PWV , PQS                                                        &
+       &  ,  PFDOWN,PFUP                                            )
+      USE dimphy
+      USE radiation_AR4_param, only : RSUN, RRAY
+      USE infotrac, ONLY : type_trac
+#ifdef REPROBUS
+      use CHEM_REP, only : RSUNTIME, ok_SUNTIME
+#endif
+
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "radepsi.h"
+!C
+!C     ------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C
+!C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
+!C     SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
+!C     CONTINUUM SCATTERING
+!C          2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
+!C     A GREY MOLECULAR ABSORPTION
+!C          3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
+!C     OF ABSORBERS
+!C          4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
+!C          5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+!C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
+!C     ------------------------------------------------------------------
+!C* ARGUMENTS:
+!C
+      INTEGER KNU
+!c-OB
+      real(kind=8) flag_aer
+      real(kind=8) tauae(kdlon,kflev,2)
+      real(kind=8) pizae(kdlon,kflev,2)
+      real(kind=8) cgae(kdlon,kflev,2)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)
+      REAL(KIND=8) PAKI(KDLON,2)
+      REAL(KIND=8) PALBD(KDLON,2)
+      REAL(KIND=8) PALBP(KDLON,2)
+      REAL(KIND=8) PCG(KDLON,2,KFLEV)
+      REAL(KIND=8) PCLD(KDLON,KFLEV)
+      REAL(KIND=8) PCLDSW(KDLON,KFLEV)
+      REAL(KIND=8) PCLEAR(KDLON)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) POMEGA(KDLON,2,KFLEV)
+      REAL(KIND=8) POZ(KDLON,KFLEV)
+      REAL(KIND=8) PQS(KDLON,KFLEV)
+      REAL(KIND=8) PRMU(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+      REAL(KIND=8) PTAU(KDLON,2,KFLEV)
+      REAL(KIND=8) PUD(KDLON,5,KFLEV+1)
+      REAL(KIND=8) PWV(KDLON,KFLEV)
+!C
+      REAL(KIND=8) PFDOWN(KDLON,KFLEV+1)
+      REAL(KIND=8) PFUP(KDLON,KFLEV+1)
+!C
+!C* LOCAL VARIABLES:
+!C
+      INTEGER IIND2(2), IIND3(3)
+      REAL(KIND=8) ZCGAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZFD(KDLON,KFLEV+1)
+      REAL(KIND=8) ZFU(KDLON,KFLEV+1) 
+      REAL(KIND=8) ZG(KDLON)
+      REAL(KIND=8) ZGG(KDLON)
+      REAL(KIND=8) ZPIZAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZRAYL(KDLON)
+      REAL(KIND=8) ZRAY1(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRAY2(KDLON,KFLEV+1)
+      REAL(KIND=8) ZREF(KDLON)
+      REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1)
+      REAL(KIND=8) ZRE1(KDLON)
+      REAL(KIND=8) ZRE2(KDLON)
+      REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRK(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1)
+      REAL(KIND=8) ZRL(KDLON,8)
+      REAL(KIND=8) ZRMUE(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRMU0(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRMUZ(KDLON)
+      REAL(KIND=8) ZRNEB(KDLON)
+      REAL(KIND=8) ZRUEF(KDLON,8)
+      REAL(KIND=8) ZR1(KDLON) 
+      REAL(KIND=8) ZR2(KDLON,2)
+      REAL(KIND=8) ZR3(KDLON,3)
+      REAL(KIND=8) ZR4(KDLON)
+      REAL(KIND=8) ZR21(KDLON)
+      REAL(KIND=8) ZR22(KDLON)
+      REAL(KIND=8) ZS(KDLON)
+      REAL(KIND=8) ZTAUAZ(KDLON,KFLEV)
+      REAL(KIND=8) ZTO1(KDLON)
+      REAL(KIND=8) ZTR(KDLON,2,KFLEV+1)
+      REAL(KIND=8) ZTRA1(KDLON,KFLEV+1)
+      REAL(KIND=8) ZTRA2(KDLON,KFLEV+1)
+      REAL(KIND=8) ZTR1(KDLON)
+      REAL(KIND=8) ZTR2(KDLON)
+      REAL(KIND=8) ZW(KDLON)   
+      REAL(KIND=8) ZW1(KDLON)
+      REAL(KIND=8) ZW2(KDLON,2)
+      REAL(KIND=8) ZW3(KDLON,3)
+      REAL(KIND=8) ZW4(KDLON)
+      REAL(KIND=8) ZW5(KDLON)
+!C
+      INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
+      INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
+      REAL(KIND=8) ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11
+
+!C If running with Reporbus, overwrite default values of RSUN. 
+!C Otherwise keep default values from radiation_AR4_param module.  
+      IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+         IF (ok_SUNTIME) THEN
+            RSUN(1)=RSUNTIME(1)
+            RSUN(2)=RSUNTIME(2)
+         END IF
+#endif
+      END IF
+
+!C
+
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         1.     SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
+!C                 -------------------------------------------
+!C
+ 100  CONTINUE
+!C
+!C
+!C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
+!C                 -----------------------------------------
+!C
+ 110  CONTINUE
+!C
+      DO 111 JL = 1, KDLON
+      ZRMUM1 = 1. - PRMU(JL)
+      ZRAYL(JL) =  RRAY(KNU,1) + ZRMUM1   * (RRAY(KNU,2) + ZRMUM1                    &
+       &          * (RRAY(KNU,3) + ZRMUM1   * (RRAY(KNU,4) + ZRMUM1                  &
+       &          * (RRAY(KNU,5) + ZRMUM1   *  RRAY(KNU,6)     ))))
+ 111  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.    CONTINUUM SCATTERING CALCULATIONS
+!C                ---------------------------------
+!C
+ 200  CONTINUE
+!C
+!C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN
+!C                --------------------------------
+!C  
+ 210  CONTINUE
+!C
+      CALL SWCLR_LMDAR4 ( KNU                                                        &
+       &  , PAER   , flag_aer, tauae, pizae, cgae                                    &
+       &  , PALBP  , PDSIG , ZRAYL, PSEC                                             &
+       &  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0                              &
+       &  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
+!C
+!C
+!C*         2.2   CLOUDY FRACTION OF THE COLUMN
+!C                -----------------------------
+!C
+ 220  CONTINUE
+!C
+      CALL SWR_LMDAR4 ( KNU                                                          &
+       &  , PALBD , PCG   , PCLD , PDSIG, POMEGA, ZRAYL                              &
+       &  , PSEC  , PTAU                                                             &
+       &  , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ  , ZRK, ZRMUE                  &
+       &  , ZTAUAZ, ZTRA1 , ZTRA2)
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.    SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
+!C                ------------------------------------------------------
+!C
+ 300  CONTINUE
+!C
+      JN = 2
+!C
+      DO 361 JABS=1,2
+!C
+!C
+!C*         3.1  SURFACE CONDITIONS
+!C               ------------------
+!C
+ 310  CONTINUE
+!C
+      DO 311 JL = 1, KDLON
+      ZREFZ(JL,2,1) = PALBD(JL,KNU)
+      ZREFZ(JL,1,1) = PALBD(JL,KNU)
+ 311  CONTINUE
+!C
+!C
+!C*         3.2  INTRODUCING CLOUD EFFECTS
+!C               -------------------------
+!C
+ 320  CONTINUE
+!C
+      DO 324 JK = 2 , KFLEV+1
+      JKM1 = JK - 1
+      IKL=KFLEV+1-JKM1
+      DO 322 JL = 1, KDLON
+      ZRNEB(JL) = PCLD(JL,JKM1)
+      IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN
+         ZWH2O=MAX(PWV(JL,JKM1),ZEELOG)
+         ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG))
+         ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O
+         ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG)
+      ELSE
+         ZAA=PUD(JL,JABS,JKM1)
+         ZBB=ZAA
+      END IF
+      ZRKI = PAKI(JL,JABS)
+      ZS(JL) = EXP(-ZRKI * ZAA * 1.66)
+      ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK))
+      ZTR1(JL) = 0.
+      ZRE1(JL) = 0.
+      ZTR2(JL) = 0.
+      ZRE2(JL) = 0.
+!C
+      ZW(JL)= POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL)                                          &
+       &               + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1)                           &
+       &               + ZBB * ZRKI
+
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)                                          &
+       &              + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1)
+      ZW(JL) = ZR21(JL) / ZTO1(JL)
+      ZREF(JL) = ZREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = ZRMUE(JL,JK)
+ 322  CONTINUE
+!C
+      CALL SWDE_LMDAR4(ZGG, ZREF, ZRMUZ, ZTO1, ZW,                                   &
+       &          ZRE1, ZRE2, ZTR1, ZTR2)
+!C
+      DO 323 JL = 1, KDLON
+!C
+      ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)                              &
+       &               + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)                           &
+       &               * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL)                          &
+       &               + ZRNEB(JL) * ZRE1(JL)
+!C
+      ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL)                                              &
+       &              + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL))
+!C
+      ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1)                                  &
+       &                  +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1)            &
+       &             /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL)            &
+       &             + ZRNEB(JL) * ZRE2(JL)
+!C
+      ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL)                                           &
+       &              + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1)                           &
+       &              * ZREFZ(JL,1,JKM1)))                                           &
+       &              * ZG(JL) * (1. -ZRNEB(JL))
+!C
+ 323  CONTINUE
+ 324  CONTINUE
+!C
+!C*         3.3  REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+!C               -------------------------------------------------
+!C
+ 330  CONTINUE
+!C
+      DO 351 JREF=1,2
+!C
+      JN = JN + 1
+!C
+      DO 331 JL = 1, KDLON
+      ZRJ(JL,JN,KFLEV+1) = 1.
+      ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1)
+ 331  CONTINUE
+!C
+      DO 333 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 332 JL = 1, KDLON
+      ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL)
+      ZRJ(JL,JN,JKL) = ZRE11
+      ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL)
+ 332  CONTINUE
+ 333  CONTINUE
+ 351  CONTINUE
+ 361  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         4.    INVERT GREY AND CONTINUUM FLUXES
+!C                --------------------------------
+!C
+ 400  CONTINUE
+!C
+!C
+!C*         4.1   UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
+!C                ---------------------------------------------
+!C
+ 410  CONTINUE
+!C
+      DO 414 JK = 1 , KFLEV+1
+      DO 413 JAJ = 1 , 5 , 2
+      JAJP = JAJ + 1
+      DO 412 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)=        ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK)
+      ZRK(JL,JAJ,JK)=        ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK)
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 412  CONTINUE
+ 413  CONTINUE
+ 414  CONTINUE
+!C
+      DO 417 JK = 1 , KFLEV+1
+      DO 416 JAJ = 2 , 6 , 2
+      DO 415 JL = 1, KDLON
+      ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
+      ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
+ 415  CONTINUE
+ 416  CONTINUE
+ 417  CONTINUE
+!C
+!C*         4.2    EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
+!C                 ---------------------------------------------
+!C
+ 420  CONTINUE
+!C
+      DO 437 JK = 1 , KFLEV+1
+      JKKI = 1
+      DO 425 JAJ = 1 , 2
+      IIND2(1)=JAJ
+      IIND2(2)=JAJ
+      DO 424 JN = 1 , 2
+      JN2J = JN + 2 * JAJ
+      JKKP4 = JKKI + 4
+!C
+!C*         4.2.1  EFFECTIVE ABSORBER AMOUNTS
+!C                 --------------------------
+!C
+ 4210 CONTINUE
+!C
+      DO 4211 JL = 1, KDLON
+      ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK))                              &
+       &                               / PAKI(JL,JAJ)
+      ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK))                              &
+       &                               / PAKI(JL,JAJ)
+ 4211 CONTINUE
+!C
+!C*         4.2.2  TRANSMISSION FUNCTION
+!C                 ---------------------
+!C
+ 4220 CONTINUE
+!C
+      CALL SWTT1_LMDAR4(KNU, 2, IIND2, ZW2, ZR2)
+!C
+      DO 4221 JL = 1, KDLON
+      ZRL(JL,JKKI) = ZR2(JL,1)
+      ZRUEF(JL,JKKI) = ZW2(JL,1)
+      ZRL(JL,JKKP4) = ZR2(JL,2)
+      ZRUEF(JL,JKKP4) = ZW2(JL,2)
+ 4221 CONTINUE
+!C
+      JKKI=JKKI+1
+ 424  CONTINUE
+ 425  CONTINUE
+!C
+!C*         4.3    UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
+!C                 ------------------------------------------------------
+!C
+ 430  CONTINUE
+!C
+      DO 431 JL = 1, KDLON
+      PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)                           &
+       &              + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)
+      PFUP(JL,JK)   = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)                           &
+       &              + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)
+ 431  CONTINUE
+ 437  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         5.    MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
+!C                ----------------------------------------
+!C
+ 500  CONTINUE
+!C
+!C
+!C*         5.1   DOWNWARD FLUXES
+!C                ---------------
+!C
+ 510  CONTINUE
+!C
+      JAJ = 2
+      IIND3(1)=1
+      IIND3(2)=2
+      IIND3(3)=3
+!C      
+      DO 511 JL = 1, KDLON
+      ZW3(JL,1)=0.
+      ZW3(JL,2)=0.
+      ZW3(JL,3)=0.
+      ZW4(JL)  =0.
+      ZW5(JL)  =0.
+      ZR4(JL)  =1.
+      ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1)
+ 511  CONTINUE
+      DO 514 JK = 1 , KFLEV
+      IKL = KFLEV+1-JK
+      DO 512 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL)
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKL)/ZRMU0(JL,IKL)
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKL)/ZRMU0(JL,IKL)
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKL)/ZRMU0(JL,IKL)
+ 512  CONTINUE
+!C
+      CALL SWTT1_LMDAR4(KNU, 3, IIND3, ZW3, ZR3)
+!C
+      DO 513 JL = 1, KDLON
+!C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)                            &
+       &            * ZRJ0(JL,JAJ,IKL)
+ 513  CONTINUE
+ 514  CONTINUE
+!C
+!C
+!C*         5.2   UPWARD FLUXES
+!C                -------------
+!C
+ 520  CONTINUE
+!C
+      DO 525 JL = 1, KDLON
+      ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)
+ 525  CONTINUE
+!C
+      DO 528 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 526 JL = 1, KDLON
+      ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66
+      ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66
+      ZW3(JL,3)=ZW3(JL,3)+POZ(JL,  IKM1)*1.66
+      ZW4(JL)  =ZW4(JL)  +PUD(JL,4,IKM1)*1.66
+      ZW5(JL)  =ZW5(JL)  +PUD(JL,5,IKM1)*1.66
+ 526  CONTINUE
+!C
+      CALL SWTT1_LMDAR4(KNU, 3, IIND3, ZW3, ZR3)
+!C
+      DO 527 JL = 1, KDLON
+!C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+      ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)                             &
+       &           * ZRK0(JL,JAJ,JK)
+ 527  CONTINUE
+ 528  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         6.     INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
+!C                 --------------------------------------------------
+!C
+ 600  CONTINUE
+      IABS=3
+!C
+!C*         6.1    DOWNWARD FLUXES
+!C                 ---------------
+!C
+ 610  CONTINUE
+      DO 611 JL = 1, KDLON
+      ZW1(JL)=0.
+      ZW4(JL)=0.
+      ZW5(JL)=0.
+      ZR1(JL)=0.
+      PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1)                       &
+       &                   + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU)
+ 611  CONTINUE
+!C
+      DO 614 JK = 1 , KFLEV
+      IKL=KFLEV+1-JK
+      DO 612 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL,  IKL)/ZRMUE(JL,IKL)
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL)
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL)
+!C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 612  CONTINUE
+!C
+      CALL SWTT_LMDAR4(KNU, IABS, ZW1, ZR1)
+!C
+      DO 613 JL = 1, KDLON
+      PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL)               &
+       &                     +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU)
+ 613  CONTINUE
+ 614  CONTINUE
+!C
+!C
+!C*         6.2    UPWARD FLUXES
+!C                 -------------
+!C
+ 620  CONTINUE
+      DO 621 JL = 1, KDLON
+      PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1)                     &
+       &                 +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU)
+ 621  CONTINUE
+!C
+      DO 624 JK = 2 , KFLEV+1
+      IKM1=JK-1
+      DO 622 JL = 1, KDLON
+      ZW1(JL) = ZW1(JL)+POZ(JL  ,IKM1)*1.66
+      ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66
+      ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66
+!C     ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
+ 622  CONTINUE
+!C
+      CALL SWTT_LMDAR4(KNU, IABS, ZW1, ZR1)
+!C
+      DO 623 JL = 1, KDLON
+      PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK)                   &
+       &                 +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU)
+ 623  CONTINUE
+ 624  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE SW2S_LMDAR4
+
+      SUBROUTINE SWCLR_LMDAR4  ( KNU                                                 &
+       &  , PAER  , flag_aer, tauae, pizae, cgae                                     &
+       &  , PALBP , PDSIG , PRAYL , PSEC                                             &
+       &  , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ                              &
+       &  , PRK   , PRMU0 , PTAUAZ, PTRA1 , PTRA2                   )
+      USE dimphy
+      USE radiation_AR4_param, only : TAUA, RPIZA, RCGA
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+!C
+!C     ------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+!C     CLEAR-SKY COLUMN
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+!C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 94-11-15
+!C     ------------------------------------------------------------------
+!C* ARGUMENTS:
+!C
+      INTEGER KNU
+!c-OB
+      real(kind=8) flag_aer
+      real(kind=8) tauae(kdlon,kflev,2)
+      real(kind=8) pizae(kdlon,kflev,2)
+      real(kind=8) cgae(kdlon,kflev,2)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)
+      REAL(KIND=8) PALBP(KDLON,2)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) PRAYL(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+!C
+      REAL(KIND=8) PCGAZ(KDLON,KFLEV)     
+      REAL(KIND=8) PPIZAZ(KDLON,KFLEV)
+      REAL(KIND=8) PRAY1(KDLON,KFLEV+1)
+      REAL(KIND=8) PRAY2(KDLON,KFLEV+1)
+      REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1)
+      REAL(KIND=8) PRJ(KDLON,6,KFLEV+1)
+      REAL(KIND=8) PRK(KDLON,6,KFLEV+1)
+      REAL(KIND=8) PRMU0(KDLON,KFLEV+1)
+      REAL(KIND=8) PTAUAZ(KDLON,KFLEV)
+      REAL(KIND=8) PTRA1(KDLON,KFLEV+1)
+      REAL(KIND=8) PTRA2(KDLON,KFLEV+1)
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) ZC0I(KDLON,KFLEV+1)       
+      REAL(KIND=8) ZCLE0(KDLON,KFLEV)
+      REAL(KIND=8) ZCLEAR(KDLON)
+      REAL(KIND=8) ZR21(KDLON)
+      REAL(KIND=8) ZR23(KDLON)
+      REAL(KIND=8) ZSS0(KDLON)
+      REAL(KIND=8) ZSCAT(KDLON)
+      REAL(KIND=8) ZTR(KDLON,2,KFLEV+1)
+!C
+      INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
+      REAL(KIND=8) ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE
+      REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1
+      REAL(KIND=8) ZBMU0, ZBMU1, ZRE11
+!C
+
+!C     ------------------------------------------------------------------
+!C
+!C*         1.    OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
+!C                --------------------------------------------
+!C
+ 100  CONTINUE
+!C
+!cdir collapse
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+!C
+      DO 108 JK = 1 , KFLEV
+!c-OB
+!c      DO 104 JL = 1, KDLON
+!c      PCGAZ(JL,JK) = 0.
+!c      PPIZAZ(JL,JK) =  0.
+!c      PTAUAZ(JL,JK) = 0.
+!c 104  CONTINUE
+!c-OB
+!c      DO 106 JAE=1,5
+!c      DO 105 JL = 1, KDLON
+!c      PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
+!c     S        +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
+!c      PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
+!c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
+!c      PCGAZ(JL,JK) =  PCGAZ(JL,JK) +PAER(JL,JK,JAE)
+!c     S        * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
+!c 105  CONTINUE
+!c 106  CONTINUE
+!c-OB
+      DO 105 JL = 1, KDLON
+      PTAUAZ(JL,JK)=flag_aer * tauae(JL,JK,KNU)
+      PPIZAZ(JL,JK)=flag_aer * pizae(JL,JK,KNU)
+      PCGAZ (JL,JK)=flag_aer * cgae(JL,JK,KNU)
+ 105  CONTINUE
+!C
+      IF (flag_aer.GT.0) THEN
+!c-OB
+      DO 107 JL = 1, KDLON
+!c         PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
+!c         PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK))
+         ZGAR = PCGAZ(JL,JK)
+         ZFF = ZGAR * ZGAR
+         PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF)
+         PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)
+         PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF)                    &
+       &                       / (1. - PPIZAZ(JL,JK) * ZFF)
+ 107  CONTINUE
+      ELSE
+      DO JL = 1, KDLON
+         ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
+         PTAUAZ(JL,JK) = ZTRAY
+         PCGAZ(JL,JK) = 0.
+         PPIZAZ(JL,JK) = 1.-REPSCT
+      END DO
+      END IF   ! check flag_aer
+!c     107  CONTINUE
+!c      PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
+!c     $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
+!c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
+!C
+ 108  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+!C                ----------------------------------------------
+!C
+ 200  CONTINUE
+!C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC0I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZSCAT(JL) = 0.
+ 201  CONTINUE
+!C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+!C
+      IF (NOVLP.EQ.1) THEN
+!c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)                                                     &
+       &                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))                             &
+       &                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+!C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+!c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF
+ 202  CONTINUE
+!C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZSS0(JL) = 1.-ZR21(JL)
+      ZCLE0(JL,JKL) = ZSS0(JL)
+!c     
+      IF (NOVLP.EQ.1) THEN
+!c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)                                                     &
+       &                  *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))                             &
+       &                  /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
+         ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZSCAT(JL) = ZSS0(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+!C* maximum
+         ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+!c* random
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
+         ZSCAT(JL) = 1.0 - ZCLEAR(JL)
+         ZC0I(JL,JKL) = ZSCAT(JL)
+      END IF                  
+ 204  CONTINUE
+ 205  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+!C                -----------------------------------------------
+!C
+ 300  CONTINUE
+!C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBP(JL,KNU)
+      PREFZ(JL,1,1) = PALBP(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+!C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.1  EQUIVALENT ZENITH ANGLE
+!C               -----------------------
+!C
+ 310  CONTINUE
+!C
+      ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL)                                             &
+       &            + ZC0I(JL,JK) * 1.66
+      PRMU0(JL,JK) = 1./ZMUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+!C               ----------------------------------------------------
+!C
+ 320  CONTINUE
+!C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE                              &
+       &       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+!C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1                              &
+       &       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+!C
+!C
+!C
+      PREFZ(JL,1,JK) = (PRAY1(JL,JKM1)                                               &
+       &               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)                           &
+       &               * PTRA2(JL,JKM1)                                              &
+       &               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+!C
+      ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1)                                               &
+       &               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
+!C
+      PREFZ(JL,2,JK) = (PRAY1(JL,JKM1)                                               &
+       &               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)                           &
+       &               * PTRA2(JL,JKM1) )
+!C
+      ZTR(JL,2,JKM1) = PTRA1(JL,JKM1) 
+!C
+ 342  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66
+      PRMU0(JL,1)=1./ZMUE
+ 347  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+!C                 -------------------------------------------------
+!C
+ 350  CONTINUE
+!C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+!C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+!C
+      ELSE
+!C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+!C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+!C
+      END IF
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE SWCLR_LMDAR4
+
+      SUBROUTINE SWR_LMDAR4 ( KNU                                                    &
+       &  , PALBD , PCG   , PCLD , PDSIG, POMEGA, PRAYL                              &
+       &  , PSEC  , PTAU                                                             &
+       &  , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ  , PRK , PRMUE                 &
+       &  , PTAUAZ, PTRA1 , PTRA2 )
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+!C
+!C     ------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
+!C     CONTINUUM SCATTERING
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
+!C     OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+!C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C     ------------------------------------------------------------------
+!C* ARGUMENTS:
+!C
+      INTEGER KNU
+      REAL(KIND=8) PALBD(KDLON,2)
+      REAL(KIND=8) PCG(KDLON,2,KFLEV)
+      REAL(KIND=8) PCLD(KDLON,KFLEV)
+      REAL(KIND=8) PDSIG(KDLON,KFLEV)
+      REAL(KIND=8) POMEGA(KDLON,2,KFLEV)
+      REAL(KIND=8) PRAYL(KDLON)
+      REAL(KIND=8) PSEC(KDLON)
+      REAL(KIND=8) PTAU(KDLON,2,KFLEV)
+!C
+      REAL(KIND=8) PRAY1(KDLON,KFLEV+1)
+      REAL(KIND=8) PRAY2(KDLON,KFLEV+1)
+      REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1)
+      REAL(KIND=8) PRJ(KDLON,6,KFLEV+1)
+      REAL(KIND=8) PRK(KDLON,6,KFLEV+1)
+      REAL(KIND=8) PRMUE(KDLON,KFLEV+1)
+      REAL(KIND=8) PCGAZ(KDLON,KFLEV)
+      REAL(KIND=8) PPIZAZ(KDLON,KFLEV)
+      REAL(KIND=8) PTAUAZ(KDLON,KFLEV)
+      REAL(KIND=8) PTRA1(KDLON,KFLEV+1)
+      REAL(KIND=8) PTRA2(KDLON,KFLEV+1)
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) ZC1I(KDLON,KFLEV+1)
+      REAL(KIND=8) ZCLEQ(KDLON,KFLEV)
+      REAL(KIND=8) ZCLEAR(KDLON)
+      REAL(KIND=8) ZCLOUD(KDLON)
+      REAL(KIND=8) ZGG(KDLON)
+      REAL(KIND=8) ZREF(KDLON)
+      REAL(KIND=8) ZRE1(KDLON)
+      REAL(KIND=8) ZRE2(KDLON)
+      REAL(KIND=8) ZRMUZ(KDLON)
+      REAL(KIND=8) ZRNEB(KDLON)
+      REAL(KIND=8) ZR21(KDLON)
+      REAL(KIND=8) ZR22(KDLON)
+      REAL(KIND=8) ZR23(KDLON)
+      REAL(KIND=8) ZSS1(KDLON)
+      REAL(KIND=8) ZTO1(KDLON)
+      REAL(KIND=8) ZTR(KDLON,2,KFLEV+1)
+      REAL(KIND=8) ZTR1(KDLON)
+      REAL(KIND=8) ZTR2(KDLON)
+      REAL(KIND=8) ZW(KDLON)
+!C
+      INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
+      REAL(KIND=8) ZFACOA, ZFACOC, ZCORAE, ZCORCD
+      REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1
+      REAL(KIND=8) ZMU1, ZRE11, ZBMU0, ZBMU1
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         1.    INITIALIZATION
+!C                --------------
+!C
+ 100  CONTINUE
+!C
+      DO 103 JK = 1 , KFLEV+1
+      DO 102 JA = 1 , 6
+      DO 101 JL = 1, KDLON
+      PRJ(JL,JA,JK) = 0.
+      PRK(JL,JA,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+ 103  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
+!C                ----------------------------------------------
+!C
+ 200  CONTINUE
+!C
+      DO 201 JL = 1, KDLON
+      ZR23(JL) = 0.
+      ZC1I(JL,KFLEV+1) = 0.
+      ZCLEAR(JL) = 1.
+      ZCLOUD(JL) = 0.
+ 201  CONTINUE
+!C
+      JK = 1
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 202 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)                             &
+       &                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))                                &
+       &               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+!C
+      IF (NOVLP.EQ.1) THEN
+!c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)                                                     &
+       &                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))                            &
+       &                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+!C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+!c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 202  CONTINUE
+!C
+      DO 205 JK = 2 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 204 JL = 1, KDLON
+      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
+      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)                             &
+       &                                 * PCG(JL,KNU,JKL)
+      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
+      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
+      ZR21(JL) = EXP(-ZCORAE   )
+      ZR22(JL) = EXP(-ZCORCD   )
+      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))                                &
+       &               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
+      ZCLEQ(JL,JKL) = ZSS1(JL)
+!c     
+      IF (NOVLP.EQ.1) THEN
+!c* maximum-random
+         ZCLEAR(JL) = ZCLEAR(JL)                                                     &
+       &                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))                            &
+       &                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = ZSS1(JL)
+      ELSE IF (NOVLP.EQ.2) THEN
+!C* maximum
+         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+!c* random
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZC1I(JL,JKL) = ZCLOUD(JL)
+      END IF
+ 204  CONTINUE
+ 205  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
+!C                -----------------------------------------------
+!C
+ 300  CONTINUE
+!C
+      DO 301 JL = 1, KDLON
+      PRAY1(JL,KFLEV+1) = 0.
+      PRAY2(JL,KFLEV+1) = 0.
+      PREFZ(JL,2,1) = PALBD(JL,KNU)
+      PREFZ(JL,1,1) = PALBD(JL,KNU)
+      PTRA1(JL,KFLEV+1) = 1.
+      PTRA2(JL,KFLEV+1) = 1.
+ 301  CONTINUE
+!C
+      DO 346 JK = 2 , KFLEV+1
+      JKM1 = JK-1
+      DO 342 JL = 1, KDLON
+      ZRNEB(JL)= PCLD(JL,JKM1)
+      ZRE1(JL)=0.
+      ZTR1(JL)=0.
+      ZRE2(JL)=0.
+      ZTR2(JL)=0.
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.1  EQUIVALENT ZENITH ANGLE
+!C               -----------------------
+!C
+ 310  CONTINUE
+!C
+      ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)                                             &
+       &            + ZC1I(JL,JK) * 1.66
+      PRMUE(JL,JK) = 1./ZMUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
+!C               ----------------------------------------------------
+!C
+ 320  CONTINUE
+!C
+      ZGAP = PCGAZ(JL,JKM1)
+      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
+      ZWW = PPIZAZ(JL,JKM1)
+      ZTO = PTAUAZ(JL,JKM1)
+      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE                              &
+       &       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
+      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
+      PTRA1(JL,JKM1) = 1. / ZDEN
+!c      PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
+!C
+      ZMU1 = 0.5
+      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
+      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1                              &
+       &       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
+      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
+      PTRA2(JL,JKM1) = 1. / ZDEN1
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.3  EFFECT OF CLOUD LAYER
+!C               ---------------------
+!C
+ 330  CONTINUE
+!C
+      ZW(JL) = POMEGA(JL,KNU,JKM1)
+      ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL)                                            &
+       &         + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
+      ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
+      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
+      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)                                          &
+       &              + (1. - ZR22(JL)) * PCGAZ(JL,JKM1)
+!C Modif PhD - JJM 19/03/96 pour erreurs arrondis
+!C machine
+!C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
+      IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN
+         ZW(JL)=1.
+      ELSE
+         ZW(JL) = ZR21(JL) / ZTO1(JL)
+      END IF
+      ZREF(JL) = PREFZ(JL,1,JKM1)
+      ZRMUZ(JL) = PRMUE(JL,JK)
+ 342  CONTINUE
+!C
+      CALL SWDE_LMDAR4(ZGG  , ZREF  , ZRMUZ , ZTO1 , ZW,                             &
+       &          ZRE1 , ZRE2  , ZTR1  , ZTR2)
+!C
+      DO 345 JL = 1, KDLON
+!C
+      PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)                              &
+       &               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)                           &
+       &               * PTRA2(JL,JKM1)                                              &
+       &               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))                       &
+       &               + ZRNEB(JL) * ZRE2(JL)
+!C
+      ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)                        &
+       &               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))                       &
+       &               * (1.-ZRNEB(JL))
+!C
+      PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)                              &
+       &               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)                           &
+       &               * PTRA2(JL,JKM1) )                                            &
+       &               + ZRNEB(JL) * ZRE1(JL)
+!C
+      ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)                                          &
+       &               + PTRA1(JL,JKM1) * (1.-ZRNEB(JL))
+!C
+ 345  CONTINUE
+ 346  CONTINUE
+      DO 347 JL = 1, KDLON
+      ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66
+      PRMUE(JL,1)=1./ZMUE
+ 347  CONTINUE
+!C
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
+!C                 -------------------------------------------------
+!C
+ 350  CONTINUE
+!C
+      IF (KNU.EQ.1) THEN
+      JAJ = 2
+      DO 351 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
+ 351  CONTINUE
+!C
+      DO 353 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 352 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
+ 352  CONTINUE
+ 353  CONTINUE
+ 354  CONTINUE
+!C
+      ELSE
+!C
+      DO 358 JAJ = 1 , 2
+      DO 355 JL = 1, KDLON
+      PRJ(JL,JAJ,KFLEV+1) = 1.
+      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
+ 355  CONTINUE
+!C
+      DO 357 JK = 1 , KFLEV
+      JKL = KFLEV+1 - JK
+      JKLP1 = JKL + 1
+      DO 356 JL = 1, KDLON
+      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
+      PRJ(JL,JAJ,JKL) = ZRE11
+      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
+ 356  CONTINUE
+ 357  CONTINUE
+ 358  CONTINUE
+!C
+      END IF
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE SWR_LMDAR4
+
+      SUBROUTINE SWDE_LMDAR4 (PGG,PREF,PRMUZ,PTO1,PW,                                &
+       &                 PRE1,PRE2,PTR1,PTR2)
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+!C
+!C     ------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
+!C     LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 88-12-15
+!C     ------------------------------------------------------------------
+!C* ARGUMENTS:
+!C
+      REAL(KIND=8) PGG(KDLON)   ! ASSYMETRY FACTOR
+      REAL(KIND=8) PREF(KDLON)  ! REFLECTIVITY OF THE UNDERLYING LAYER
+      REAL(KIND=8) PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE
+      REAL(KIND=8) PTO1(KDLON)  ! OPTICAL THICKNESS
+      REAL(KIND=8) PW(KDLON)    ! SINGLE SCATTERING ALBEDO
+      REAL(KIND=8) PRE1(KDLON)  ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL(KIND=8) PRE2(KDLON)  ! LAYER REFLECTIVITY
+      REAL(KIND=8) PTR1(KDLON)  ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
+      REAL(KIND=8) PTR2(KDLON)  ! LAYER TRANSMISSIVITY
+!C
+!C* LOCAL VARIABLES:
+!C
+      INTEGER jl
+      REAL(KIND=8) ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM
+      REAL(KIND=8) ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG
+      REAL(KIND=8) ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B,                 &
+       &     ZAM2B
+      REAL(KIND=8) ZA11, ZA12, ZA13, ZA21, ZA22, ZA23
+      REAL(KIND=8) ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A
+      REAL(KIND=8) ZRI0B, ZRI1B
+      REAL(KIND=8) ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B
+      REAL(KIND=8) ZRI0C, ZRI1C, ZRI0D, ZRI1D
+!C     ------------------------------------------------------------------
+!C
+!C*         1.      DELTA-EDDINGTON CALCULATIONS
+!C
+ 100  CONTINUE
+!C
+      DO 131 JL   =   1, KDLON
+!C
+!C*         1.1     SET UP THE DELTA-MODIFIED PARAMETERS
+!C
+ 110  CONTINUE
+!C
+      ZFF = PGG(JL)*PGG(JL)
+      ZGP = PGG(JL)/(1.+PGG(JL))
+      ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL)
+      ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF)
+      ZDT = 2./3.
+      ZX1 = 1.-ZWCP*ZGP
+      ZWM = 1.-ZWCP
+      ZRM2 =  PRMUZ(JL) * PRMUZ(JL)
+      ZRK = SQRT(3.*ZWM*ZX1)
+      ZX2 = 4.*(1.-ZRK*ZRK*ZRM2)
+      ZRP=ZRK/ZX1
+      ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2
+      ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2
+      ZARG=MIN(ZTOP/PRMUZ(JL),200._8)
+      ZEXMU0=EXP(-ZARG)
+      ZARG2=MIN(ZRK*ZTOP,200._8)
+      ZEXKP=EXP(ZARG2)
+      ZEXKM = 1./ZEXKP
+      ZXP2P = 1.+ZDT*ZRP
+      ZXM2P = 1.-ZDT*ZRP
+      ZAP2B = ZALPHA+ZDT*ZBETA
+      ZAM2B = ZALPHA-ZDT*ZBETA
+!C
+!C*         1.2     WITHOUT REFLECTION FROM THE UNDERLYING LAYER
+!C
+ 120  CONTINUE
+!C
+      ZA11 = ZXP2P
+      ZA12 = ZXM2P
+      ZA13 = ZAP2B
+      ZA22 = ZXP2P*ZEXKP
+      ZA21 = ZXM2P*ZEXKM
+      ZA23 = ZAM2B*ZEXMU0
+      ZDENA = ZA11 * ZA22 - ZA21 * ZA12
+      ZC1A = (ZA22*ZA13-ZA12*ZA23)/ZDENA
+      ZC2A = (ZA11*ZA23-ZA21*ZA13)/ZDENA
+      ZRI0A = ZC1A+ZC2A-ZALPHA
+      ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
+      PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL)
+      ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0
+      ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0
+      PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL)
+!C
+!C*         1.3     WITH REFLECTION FROM THE UNDERLYING LAYER
+!C
+ 130  CONTINUE
+!C
+      ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM
+      ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP
+      ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) )
+      ZDENB = ZA11 * ZB22 - ZB21 * ZA12
+      ZC1B = (ZB22*ZA13-ZA12*ZB23)/ZDENB
+      ZC2B = (ZA11*ZB23-ZB21*ZA13)/ZDENB
+      ZRI0C = ZC1B+ZC2B-ZALPHA
+      ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
+      PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL)
+      ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0
+      ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0
+      PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL)
+!C
+ 131  CONTINUE
+      RETURN
+      END SUBROUTINE SWDE_LMDAR4 
+
+      SUBROUTINE SWTT_LMDAR4 (KNU,KA,PU,PTR)
+      USE dimphy
+      USE radiation_AR4_param, only : APAD, BPAD, D
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+!C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+!C     INTERVALS.
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+!C     AND HORNER'S ALGORITHM.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 88-12-15
+!C-----------------------------------------------------------------------
+!C
+!C* ARGUMENTS
+!C
+      INTEGER KNU     ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KA      ! INDEX OF THE ABSORBER
+      REAL(KIND=8) PU(KDLON)  ! ABSORBER AMOUNT
+!C
+      REAL(KIND=8) PTR(KDLON) ! TRANSMISSION FUNCTION
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) ZR1(KDLON), ZR2(KDLON)
+      INTEGER jl, i,j
+!C
+
+!C
+!C-----------------------------------------------------------------------
+!C
+!C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+!C
+ 100  CONTINUE
+!C
+      DO 201 JL = 1, KDLON
+      ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL)                   &
+       &      * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL)                 &
+       &      * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL)                 &
+       &      * ( APAD(KNU,KA,7) ))))))
+!C
+      ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL)                   &
+       &      * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL)                 &
+       &      * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL)                 &
+       &      * ( BPAD(KNU,KA,7) ))))))
+!C     
+!C
+!C*         2.      ADD THE BACKGROUND TRANSMISSION
+!C
+ 200  CONTINUE
+!C
+!C
+      PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA)
+ 201  CONTINUE
+!C
+      RETURN
+      END SUBROUTINE SWTT_LMDAR4
+
+      SUBROUTINE SWTT1_LMDAR4(KNU,KABS,KIND, PU, PTR)
+      USE dimphy
+      USE radiation_AR4_param, only : APAD, BPAD, D
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+!C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
+!C     INTERVALS.
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
+!C     AND HORNER'S ALGORITHM.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 95-01-20
+!C-----------------------------------------------------------------------
+!C* ARGUMENTS:
+!C
+      INTEGER KNU          ! INDEX OF THE SPECTRAL INTERVAL
+      INTEGER KABS         ! NUMBER OF ABSORBERS
+      INTEGER KIND(KABS)   ! INDICES OF THE ABSORBERS
+      REAL(KIND=8) PU(KDLON,KABS)  ! ABSORBER AMOUNT
+!C
+      REAL(KIND=8) PTR(KDLON,KABS) ! TRANSMISSION FUNCTION
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) ZR1(KDLON)
+      REAL(KIND=8) ZR2(KDLON)
+      REAL(KIND=8) ZU(KDLON)
+      INTEGER jl, ja, i, j, ia
+!C
+
+!C-----------------------------------------------------------------------
+!C
+!C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
+!C
+ 100  CONTINUE
+!C
+      DO 202 JA = 1,KABS
+      IA=KIND(JA)
+      DO 201 JL = 1, KDLON
+      ZU(JL) = PU(JL,JA)
+      ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL)                   &
+       &      * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL)                 &
+       &      * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL)                 &
+       &      * ( APAD(KNU,IA,7) ))))))
+!C
+      ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)                   &
+       &      * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL)                 &
+       &      * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL)                 &
+       &      * ( BPAD(KNU,IA,7) ))))))
+!C     
+!C
+!C*         2.      ADD THE BACKGROUND TRANSMISSION
+!C
+ 200  CONTINUE
+!C
+      PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA) 
+ 201  CONTINUE
+ 202  CONTINUE
+!C
+      RETURN
+      END SUBROUTINE SWTT1_LMDAR4
+
+!IM ctes ds clesphys.h   SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
+      SUBROUTINE LW_LMDAR4(                                                          &
+       &              PPMB, PDP,                                                     &
+       &              PPSOL,PDT0,PEMIS,                                              &
+       &              PTL, PTAVE, PWV, POZON, PAER,                                  &
+       &              PCLDLD,PCLDLU,                                                 &
+       &              PVIEW,                                                         &
+       &              PCOLR, PCOLR0,                                                 &
+       &              PTOPLW,PSOLLW,PTOPLW0,PSOLLW0,                                 &
+       &              psollwdown,                                                    &
+!IM  .              psollwdown,psollwdownclr,
+!IM  .              ptoplwdown,ptoplwdownclr)                                        &
+       &              plwup, plwdn, plwup0, plwdn0)
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+#include "iniprint.h"
+!C
+!C-----------------------------------------------------------------------
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+!C     ABSORBERS.
+!C          2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+!C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+!C          3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+!C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+!C     BOUNDARIES.
+!C          4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+!C          5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
+!C
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C-----------------------------------------------------------------------
+!IM ctes ds clesphys.h
+!c     REAL(KIND=8) RCO2   ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97)
+!c     REAL(KIND=8) RCH4   ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97)
+!c     REAL(KIND=8) RN2O   ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97)
+!c     REAL(KIND=8) RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97)
+!c     REAL(KIND=8) RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97)
+#include "clesphys.h"
+      REAL(KIND=8) PCLDLD(KDLON,KFLEV)  ! DOWNWARD EFFECTIVE CLOUD COVER
+      REAL(KIND=8) PCLDLU(KDLON,KFLEV)  ! UPWARD EFFECTIVE CLOUD COVER
+      REAL(KIND=8) PDP(KDLON,KFLEV)     ! LAYER PRESSURE THICKNESS (Pa)
+      REAL(KIND=8) PDT0(KDLON)          ! SURFACE TEMPERATURE DISCONTINUITY (K)
+      REAL(KIND=8) PEMIS(KDLON)         ! SURFACE EMISSIVITY
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1)  ! HALF LEVEL PRESSURE (mb)
+      REAL(KIND=8) PPSOL(KDLON)         ! SURFACE PRESSURE (Pa)
+      REAL(KIND=8) POZON(KDLON,KFLEV)   ! O3 mass fraction
+      REAL(KIND=8) PTL(KDLON,KFLEV+1)   ! HALF LEVEL TEMPERATURE (K)
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)  ! OPTICAL THICKNESS OF THE AEROSOLS
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)   ! LAYER TEMPERATURE (K)
+      REAL(KIND=8) PVIEW(KDLON)         ! COSECANT OF VIEWING ANGLE
+      REAL(KIND=8) PWV(KDLON,KFLEV)     ! SPECIFIC HUMIDITY (kg/kg)
+!C
+      REAL(KIND=8) PCOLR(KDLON,KFLEV)   ! LONG-WAVE TENDENCY (K/day)
+      REAL(KIND=8) PCOLR0(KDLON,KFLEV)  ! LONG-WAVE TENDENCY (K/day) clear-sky
+      REAL(KIND=8) PTOPLW(KDLON)        ! LONGWAVE FLUX AT T.O.A.
+      REAL(KIND=8) PSOLLW(KDLON)        ! LONGWAVE FLUX AT SURFACE
+      REAL(KIND=8) PTOPLW0(KDLON)       ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
+      REAL(KIND=8) PSOLLW0(KDLON)       ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
+!c Rajout LF
+      real(kind=8) psollwdown(kdlon)    ! LONGWAVE downwards flux at surface
+!c Rajout IM
+!IM   real(kind=8) psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at surface
+!IM   real(kind=8) ptoplwdown(kdlon)    ! LONGWAVE downwards flux at T.O.A.
+!IM   real(kind=8) ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at T.O.A.
+!IM
+      REAL(KIND=8) plwup(KDLON,KFLEV+1)  ! LW up total sky
+      REAL(KIND=8) plwup0(KDLON,KFLEV+1) ! LW up clear sky
+      REAL(KIND=8) plwdn(KDLON,KFLEV+1)  ! LW down total sky
+      REAL(KIND=8) plwdn0(KDLON,KFLEV+1) ! LW down clear sky
+!C-------------------------------------------------------------------------
+      REAL(KIND=8) ZABCU(KDLON,NUA,3*KFLEV+1)
+
+      REAL(KIND=8) ZOZ(KDLON,KFLEV)
+!     equivalent pressure of ozone in a layer, in Pa
+
+!cym      REAL(KIND=8) ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down)
+!cym      REAL(KIND=8) ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+!cym      REAL(KIND=8) ZBINT(KDLON,KFLEV+1)            ! Intermediate variable
+!cym      REAL(KIND=8) ZBSUI(KDLON)                    ! Intermediate variable
+!cym      REAL(KIND=8) ZCTS(KDLON,KFLEV)               ! Intermediate variable
+!cym      REAL(KIND=8) ZCNTRB(KDLON,KFLEV+1,KFLEV+1)   ! Intermediate variable
+!cym      SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
+      REAL(KIND=8),allocatable,save :: ZFLUX(:,:,:) ! RADIATIVE FLUXES (1:up; 2:down)
+      REAL(KIND=8),allocatable,save :: ZFLUC(:,:,:) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL(KIND=8),allocatable,save :: ZBINT(:,:)            ! Intermediate variable
+      REAL(KIND=8),allocatable,save :: ZBSUI(:)                    ! Intermediate variable
+      REAL(KIND=8),allocatable,save :: ZCTS(:,:)               ! Intermediate variable
+      REAL(KIND=8),allocatable,save :: ZCNTRB(:,:,:)   ! Intermediate variable
+!$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB)
+!c
+      INTEGER ilim, i, k, kpl1
+!C
+      INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
+      PARAMETER (lw0pas=1)
+      INTEGER lwpas  ! Every lwpas steps, cloudy-sky is done
+      PARAMETER (lwpas=1)
+!c
+      INTEGER itaplw0, itaplw
+      LOGICAL appel1er
+      SAVE appel1er, itaplw0, itaplw
+!$OMP THREADPRIVATE(appel1er, itaplw0, itaplw)
+      DATA appel1er /.TRUE./
+      DATA itaplw0,itaplw /0,0/
+
+!C     ------------------------------------------------------------------
+      IF (appel1er) THEN
+         WRITE(lunout,*) "LW clear-sky calling frequency: ", lw0pas
+         WRITE(lunout,*) "LW cloudy-sky calling frequency: ", lwpas
+         WRITE(lunout,*) "   In general, they should be 1"
+!cym
+	 allocate(ZFLUX(KDLON,2,KFLEV+1) )
+         allocate(ZFLUC(KDLON,2,KFLEV+1) )
+         allocate(ZBINT(KDLON,KFLEV+1))
+         allocate(ZBSUI(KDLON))
+         allocate(ZCTS(KDLON,KFLEV))
+         allocate(ZCNTRB(KDLON,KFLEV+1,KFLEV+1))
+         appel1er=.FALSE.
+      ENDIF
+!C
+      IF (MOD(itaplw0,lw0pas).EQ.0) THEN
+!c     Compute equivalent pressure of ozone from mass fraction:
+      DO k = 1, KFLEV
+         DO i = 1, KDLON
+            ZOZ(i,k) = POZON(i,k)*PDP(i,k)
+         ENDDO
+      ENDDO
+!IM ctes ds clesphys.h   CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
+      CALL LWU_LMDAR4(                                                               &
+       &         PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU)
+      CALL LWBV_LMDAR4(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU,                     &
+       &          ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB)
+      itaplw0 = 0
+      ENDIF
+      itaplw0 = itaplw0 + 1
+!C
+      IF (MOD(itaplw,lwpas).EQ.0) THEN
+      CALL LWC_LMDAR4(ILIM,PCLDLD,PCLDLU,PEMIS,                                      &
+       &         ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB,                                      &
+       &         ZFLUX)
+      itaplw = 0
+      ENDIF
+      itaplw = itaplw + 1
+!C
+      DO k = 1, KFLEV
+         kpl1 = k+1
+         DO i = 1, KDLON
+            PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1)                             &
+       &                 - ZFLUX(i,1,k)-   ZFLUX(i,2,k)
+            PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k)
+            PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1)                            &
+       &                 - ZFLUC(i,1,k)-   ZFLUC(i,2,k)
+            PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+         ENDDO
+      ENDDO
+      DO i = 1, KDLON
+         PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1)
+         PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1)
+!c
+         PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1)
+         PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1)
+         psollwdown(i) = -ZFLUX(i,2,1)
+!c
+!IM attention aux signes !; LWtop >0, LWdn < 0
+         DO k = 1, KFLEV+1
+           plwup(i,k) = ZFLUX(i,1,k)
+           plwup0(i,k) = ZFLUC(i,1,k)
+           plwdn(i,k) = ZFLUX(i,2,k)
+           plwdn0(i,k) = ZFLUC(i,2,k)
+         ENDDO
+      ENDDO
+!C     ------------------------------------------------------------------
+      RETURN
+      END SUBROUTINE LW_LMDAR4
+
+!IM ctes ds clesphys.h   SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
+      SUBROUTINE LWU_LMDAR4(                                                         &
+       &               PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV,                      &
+       &               PABCU)
+      USE dimphy
+      USE radiation_AR4_param, only : TREF, RT1, RAER, AT, BT, OCT
+      USE infotrac, ONLY : type_trac
+#ifdef REPROBUS
+      USE CHEM_REP, ONLY: RCH42D,                                                    &
+       &                    RN2O2D,                                                  &
+       &                    RCFC112D,                                                &
+       &                    RCFC122D,                                                &
+       &                    ok_Rtime2D
+#endif
+
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+#include "radepsi.h"
+#include "radopt.h"
+!C
+!C     PURPOSE.
+!C     --------
+!C           COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
+!C           TEMPERATURE EFFECTS
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
+!C     ABSORBERS.
+!C
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        Voigt lines (loop 404 modified) - JJM & PhD - 01/96
+!C-----------------------------------------------------------------------
+!C* ARGUMENTS:
+!IM ctes ds clesphys.h
+!c     REAL(KIND=8) RCO2
+!c     REAL(KIND=8) RCH4, RN2O, RCFC11, RCFC12
+#include "clesphys.h"
+      REAL(KIND=8) PAER(KDLON,KFLEV,5)
+      REAL(KIND=8) PDP(KDLON,KFLEV)
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1)
+      REAL(KIND=8) PPSOL(KDLON)
+      REAL(KIND=8) POZ(KDLON,KFLEV)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)
+      REAL(KIND=8) PVIEW(KDLON)
+      REAL(KIND=8) PWV(KDLON,KFLEV)
+!C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+!C
+!C-----------------------------------------------------------------------
+!C* LOCAL VARIABLES:
+      REAL(KIND=8) ZABLY(KDLON,NUA,3*KFLEV+1)
+      REAL(KIND=8) ZDUC(KDLON,3*KFLEV+1)
+      REAL(KIND=8) ZPHIO(KDLON)
+      REAL(KIND=8) ZPSC2(KDLON)
+      REAL(KIND=8) ZPSC3(KDLON)
+      REAL(KIND=8) ZPSH1(KDLON)
+      REAL(KIND=8) ZPSH2(KDLON)
+      REAL(KIND=8) ZPSH3(KDLON)
+      REAL(KIND=8) ZPSH4(KDLON)
+      REAL(KIND=8) ZPSH5(KDLON)
+      REAL(KIND=8) ZPSH6(KDLON)
+      REAL(KIND=8) ZPSIO(KDLON)
+      REAL(KIND=8) ZTCON(KDLON)
+      REAL(KIND=8) ZPHM6(KDLON)
+      REAL(KIND=8) ZPSM6(KDLON)
+      REAL(KIND=8) ZPHN6(KDLON)
+      REAL(KIND=8) ZPSN6(KDLON)
+      REAL(KIND=8) ZSSIG(KDLON,3*KFLEV+1)
+      REAL(KIND=8) ZTAVI(KDLON)
+      REAL(KIND=8) ZUAER(KDLON,Ninter)
+      REAL(KIND=8) ZXOZ(KDLON)
+      REAL(KIND=8) ZXWV(KDLON)
+!C
+      INTEGER jl, jk, jkj, jkjr, jkjp, ig1
+      INTEGER jki, jkip1, ja, jj
+      INTEGER jkl, jkp1, jkk, jkjpn
+      INTEGER jae1, jae2, jae3, jae, jjpn
+      INTEGER ir, jc, jcp1
+      REAL(KIND=8) zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
+      REAL(KIND=8) zfppw, ztx, ztx2, zzably
+      REAL(KIND=8) zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
+      REAL(KIND=8) zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
+      REAL(KIND=8) zcac8, zcbc8
+      REAL(KIND=8) zalup, zdiff
+!c
+      REAL(KIND=8) PVGCO2, PVGH2O, PVGO3
+!C
+      REAL(KIND=8) R10E  ! DECIMAL/NATURAL LOG.FACTOR
+      PARAMETER (R10E=0.4342945)
+
+!C-----------------------------------------------------------------------
+!c
+      IF (LEVOIGT) THEN
+         PVGCO2= 60.
+         PVGH2O= 30.
+         PVGO3 =400.
+      ELSE
+         PVGCO2= 0.
+         PVGH2O= 0.
+         PVGO3 = 0.
+      ENDIF
+!C
+!C
+!C*         2.    PRESSURE OVER GAUSS SUB-LEVELS
+!C                ------------------------------
+!C
+ 200  CONTINUE
+!C
+      DO 201 JL = 1, KDLON
+      ZSSIG(JL, 1 ) = PPMB(JL,1) * 100.
+ 201  CONTINUE
+!C
+      DO 206 JK = 1 , KFLEV
+      JKJ=(JK-1)*NG1P1+1
+      JKJR = JKJ
+      JKJP = JKJ + NG1P1
+      DO 203 JL = 1, KDLON
+      ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100.
+ 203  CONTINUE
+      DO 205 IG1=1,NG1
+      JKJ=JKJ+1
+      DO 204 JL = 1, KDLON
+      ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5                             &
+       &  + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5
+ 204  CONTINUE
+ 205  CONTINUE
+ 206  CONTINUE
+!C
+!C-----------------------------------------------------------------------
+!C
+!C
+!C*         4.    PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
+!C                --------------------------------------------------
+!C
+ 400  CONTINUE
+!C
+      DO 402 JKI=1,3*KFLEV
+      JKIP1=JKI+1
+      DO 401 JL = 1, KDLON
+      ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5
+      ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1))                                &
+       &                                 /(10.*RG)
+ 401  CONTINUE
+ 402  CONTINUE
+!C
+      DO 406 JK = 1 , KFLEV
+      JKP1=JK+1
+      JKL = KFLEV+1 - JK
+      DO 403 JL = 1, KDLON
+      ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ )
+      ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO )
+ 403  CONTINUE
+      JKJ=(JK-1)*NG1P1+1
+      JKJPN=JKJ+NG1
+      DO 405 JKK=JKJ,JKJPN
+      DO 404 JL = 1, KDLON
+      ZDPM = ZABLY(JL,3,JKK)
+      ZUPM = ZABLY(JL,5,JKK)             * ZDPM / 101325.
+      ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325.
+      ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325.
+      ZUPMO3  = ( ZABLY(JL,5,JKK) + PVGO3  ) * ZDPM / 101325.
+      ZDUC(JL,JKK) = ZDPM
+      ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM
+      ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3
+      ZU6 = ZXWV(JL) * ZUPM
+      ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL))
+      ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O
+      ZABLY(JL,11,JKK) = ZU6 * ZFPPW
+      ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW)
+      ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2
+      ZABLY(JL,8,JKK) = RCO2 * ZDPM
+ 404  CONTINUE
+ 405  CONTINUE
+ 406  CONTINUE
+!C
+!C-----------------------------------------------------------------------
+!C
+!C
+!C*         5.    CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
+!C                --------------------------------------------------
+!C
+ 500  CONTINUE
+!C
+      DO 502 JA = 1, NUA
+      DO 501 JL = 1, KDLON
+      PABCU(JL,JA,3*KFLEV+1) = 0.
+  501 CONTINUE
+  502 CONTINUE
+!C
+      DO 529 JK = 1 , KFLEV
+      JJ=(JK-1)*NG1P1+1
+      JJPN=JJ+NG1
+      JKL=KFLEV+1-JK
+!C
+!C
+!C*         5.1  CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
+!C               --------------------------------------------------
+!C
+ 510  CONTINUE
+!C
+      JAE1=3*KFLEV+1-JJ
+      JAE2=3*KFLEV+1-(JJ+1)
+      JAE3=3*KFLEV+1-JJPN
+      DO 512 JAE=1,5
+      DO 511 JL = 1, KDLON
+      ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1)                                    &
+       &      +RAER(JAE,2)*PAER(JL,JKL,2)+RAER(JAE,3)*PAER(JL,JKL,3)                 &
+       &      +RAER(JAE,4)*PAER(JL,JKL,4)+RAER(JAE,5)*PAER(JL,JKL,5))                &
+       &      /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3))
+ 511  CONTINUE
+ 512  CONTINUE
+!C
+!C
+!C
+!C*         5.2  INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
+!C               --------------------------------------------------
+!C
+ 520  CONTINUE
+!C
+      DO 521 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.))
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3)
+      ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0._8), 6._8)
+      ZCAH1=AT(1,1)+ZUP*(AT(1,2)+ZUP*(AT(1,3)))
+      ZCBH1=BT(1,1)+ZUP*(BT(1,2)+ZUP*(BT(1,3)))
+      ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 )
+      ZCAH2=AT(2,1)+ZUP*(AT(2,2)+ZUP*(AT(2,3)))
+      ZCBH2=BT(2,1)+ZUP*(BT(2,2)+ZUP*(BT(2,3)))
+      ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 )
+      ZCAH3=AT(3,1)+ZUP*(AT(3,2)+ZUP*(AT(3,3)))
+      ZCBH3=BT(3,1)+ZUP*(BT(3,2)+ZUP*(BT(3,3)))
+      ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 )
+      ZCAH4=AT(4,1)+ZUP*(AT(4,2)+ZUP*(AT(4,3)))
+      ZCBH4=BT(4,1)+ZUP*(BT(4,2)+ZUP*(BT(4,3)))
+      ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 )
+      ZCAH5=AT(5,1)+ZUP*(AT(5,2)+ZUP*(AT(5,3)))
+      ZCBH5=BT(5,1)+ZUP*(BT(5,2)+ZUP*(BT(5,3)))
+      ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 )
+      ZCAH6=AT(6,1)+ZUP*(AT(6,2)+ZUP*(AT(6,3)))
+      ZCBH6=BT(6,1)+ZUP*(BT(6,2)+ZUP*(BT(6,3)))
+      ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 )
+      ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 )
+      ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 )
+      ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 )
+      ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 )
+ 521  CONTINUE
+!C
+      DO 522 JL = 1, KDLON
+      ZTAVI(JL)=PTAVE(JL,JKL)
+      ZTX=ZTAVI(JL)-TREF
+      ZTX2=ZTX*ZTX
+      ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3)
+      ZALUP = R10E * LOG ( ZZABLY )
+      ZUP   = MAX( 0._8, 5.0 + 0.5 * ZALUP )
+      ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP
+      ZCAC8=AT(8,1)+ZUP*(AT(8,2)+ZUP*(AT(8,3)))
+      ZCBC8=BT(8,1)+ZUP*(BT(8,2)+ZUP*(BT(8,3)))
+      ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 )
+      ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2)
+      ZPSIO(JL) = EXP( 2.* (OCT(3)*ZTX+OCT(4)*ZTX2))
+ 522  CONTINUE
+!C
+      DO 524 JKK=JJ,JJPN
+      JC=3*KFLEV+1-JKK
+      JCP1=JC+1
+      DO 523 JL = 1, KDLON
+      ZDIFF = PVIEW(JL)
+      PABCU(JL,10,JC)=PABCU(JL,10,JCP1)                                              &
+       &                +ZABLY(JL,10,JC)           *ZDIFF
+      PABCU(JL,11,JC)=PABCU(JL,11,JCP1)                                              &
+       &                +ZABLY(JL,11,JC)*ZTCON(JL)*ZDIFF
+!C
+      PABCU(JL,12,JC)=PABCU(JL,12,JCP1)                                              &
+       &                +ZABLY(JL,12,JC)*ZPHIO(JL)*ZDIFF
+      PABCU(JL,13,JC)=PABCU(JL,13,JCP1)                                              &
+       &                +ZABLY(JL,13,JC)*ZPSIO(JL)*ZDIFF
+!C
+      PABCU(JL,7,JC)=PABCU(JL,7,JCP1)                                                &
+       &               +ZABLY(JL,9,JC)*ZPSC2(JL)*ZDIFF
+      PABCU(JL,8,JC)=PABCU(JL,8,JCP1)                                                &
+       &               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+      PABCU(JL,9,JC)=PABCU(JL,9,JCP1)                                                &
+       &               +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
+!C
+      PABCU(JL,1,JC)=PABCU(JL,1,JCP1)                                                &
+       &               +ZABLY(JL,6,JC)*ZPSH1(JL)*ZDIFF
+      PABCU(JL,2,JC)=PABCU(JL,2,JCP1)                                                &
+       &               +ZABLY(JL,6,JC)*ZPSH2(JL)*ZDIFF
+      PABCU(JL,3,JC)=PABCU(JL,3,JCP1)                                                &
+       &               +ZABLY(JL,6,JC)*ZPSH5(JL)*ZDIFF
+      PABCU(JL,4,JC)=PABCU(JL,4,JCP1)                                                &
+       &               +ZABLY(JL,6,JC)*ZPSH3(JL)*ZDIFF
+      PABCU(JL,5,JC)=PABCU(JL,5,JCP1)                                                &
+       &               +ZABLY(JL,6,JC)*ZPSH4(JL)*ZDIFF
+      PABCU(JL,6,JC)=PABCU(JL,6,JCP1)                                                &
+       &               +ZABLY(JL,6,JC)*ZPSH6(JL)*ZDIFF
+!C
+      PABCU(JL,14,JC)=PABCU(JL,14,JCP1)                                              &
+       &                +ZUAER(JL,1)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,15,JC)=PABCU(JL,15,JCP1)                                              &
+       &                +ZUAER(JL,2)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,16,JC)=PABCU(JL,16,JCP1)                                              &
+       &                +ZUAER(JL,3)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,17,JC)=PABCU(JL,17,JCP1)                                              &
+       &                +ZUAER(JL,4)    *ZDUC(JL,JC)*ZDIFF
+      PABCU(JL,18,JC)=PABCU(JL,18,JCP1)                                              &
+       &                +ZUAER(JL,5)    *ZDUC(JL,JC)*ZDIFF
+!C
+!C
+
+      IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+         IF (ok_Rtime2D) THEN
+            PABCU(JL,19,JC)=PABCU(JL,19,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RCH42D(JL,JC)/RCO2*ZPHM6(JL)*ZDIFF
+            PABCU(JL,20,JC)=PABCU(JL,20,JCP1)                                        &
+       &           +ZABLY(JL,9,JC)*RCH42D(JL,JC)/RCO2*ZPSM6(JL)*ZDIFF
+            PABCU(JL,21,JC)=PABCU(JL,21,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RN2O2D(JL,JC)/RCO2*ZPHN6(JL)*ZDIFF
+            PABCU(JL,22,JC)=PABCU(JL,22,JCP1)                                        &
+       &           +ZABLY(JL,9,JC)*RN2O2D(JL,JC)/RCO2*ZPSN6(JL)*ZDIFF
+!C
+            PABCU(JL,23,JC)=PABCU(JL,23,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RCFC112D(JL,JC)/RCO2         *ZDIFF
+            PABCU(JL,24,JC)=PABCU(JL,24,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RCFC122D(JL,JC)/RCO2         *ZDIFF
+         ELSE
+            ! Same calculation as for type_trac /= repr
+            PABCU(JL,19,JC)=PABCU(JL,19,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF
+            PABCU(JL,20,JC)=PABCU(JL,20,JCP1)                                        &
+       &           +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF
+            PABCU(JL,21,JC)=PABCU(JL,21,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF
+            PABCU(JL,22,JC)=PABCU(JL,22,JCP1)                                        &
+       &           +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF
+!C     
+            PABCU(JL,23,JC)=PABCU(JL,23,JCP1)                                        &
+       &               +ZABLY(JL,8,JC)*RCFC11/RCO2         *ZDIFF
+            PABCU(JL,24,JC)=PABCU(JL,24,JCP1)                                        &
+       &           +ZABLY(JL,8,JC)*RCFC12/RCO2         *ZDIFF
+         END IF
+#endif
+      ELSE
+         PABCU(JL,19,JC)=PABCU(JL,19,JCP1)                                           &
+       &        +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF
+         PABCU(JL,20,JC)=PABCU(JL,20,JCP1)                                           &
+       &               +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF
+         PABCU(JL,21,JC)=PABCU(JL,21,JCP1)                                           &
+       &        +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF
+         PABCU(JL,22,JC)=PABCU(JL,22,JCP1)                                           &
+       &        +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF
+!C     
+         PABCU(JL,23,JC)=PABCU(JL,23,JCP1)                                           &
+       &        +ZABLY(JL,8,JC)*RCFC11/RCO2         *ZDIFF
+         PABCU(JL,24,JC)=PABCU(JL,24,JCP1)                                           &
+       &        +ZABLY(JL,8,JC)*RCFC12/RCO2         *ZDIFF
+      END IF
+      
+ 523  CONTINUE
+ 524  CONTINUE
+!C
+ 529  CONTINUE
+!C
+!C
+      RETURN
+      END SUBROUTINE LWU_LMDAR4
+
+      SUBROUTINE LWBV_LMDAR4(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU,               &
+       &                PFLUC,PBINT,PBSUI,PCTS,PCNTRB)
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+!C
+!C     PURPOSE.
+!C     --------
+!C           TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
+!C           VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
+!C           SAVING
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
+!C     GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
+!C          2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
+!C     TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
+!C     BOUNDARIES.
+!C          3. COMPUTES THE CLEAR-SKY COOLING RATES.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
+!C                                          MEMORY)
+!C-----------------------------------------------------------------------
+!C* ARGUMENTS:
+      INTEGER KLIM
+!C
+      REAL(KIND=8) PDP(KDLON,KFLEV)
+      REAL(KIND=8) PDT0(KDLON)
+      REAL(KIND=8) PEMIS(KDLON)
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1)
+      REAL(KIND=8) PTL(KDLON,KFLEV+1)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)
+!C
+      REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1)
+!C     
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1)
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1)
+      REAL(KIND=8) PBSUI(KDLON)
+      REAL(KIND=8) PCTS(KDLON,KFLEV)
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1)
+!C
+!C-------------------------------------------------------------------------
+!C
+!C* LOCAL VARIABLES:
+      REAL(KIND=8) ZB(KDLON,Ninter,KFLEV+1)
+      REAL(KIND=8) ZBSUR(KDLON,Ninter)
+      REAL(KIND=8) ZBTOP(KDLON,Ninter)
+      REAL(KIND=8) ZDBSL(KDLON,Ninter,KFLEV*2)
+      REAL(KIND=8) ZGA(KDLON,8,2,KFLEV)
+      REAL(KIND=8) ZGB(KDLON,8,2,KFLEV)
+      REAL(KIND=8) ZGASUR(KDLON,8,2)
+      REAL(KIND=8) ZGBSUR(KDLON,8,2)
+      REAL(KIND=8) ZGATOP(KDLON,8,2)
+      REAL(KIND=8) ZGBTOP(KDLON,8,2)
+!C
+      INTEGER nuaer, ntraer
+!C     ------------------------------------------------------------------
+!C* COMPUTES PLANCK FUNCTIONS:
+       CALL LWB_LMDAR4(PDT0,PTAVE,PTL,                                               &
+       &          ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,                                  &
+       &          ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP)
+!C     ------------------------------------------------------------------
+!C* PERFORMS THE VERTICAL INTEGRATION:
+      NUAER = NUA
+      NTRAER = NTRA
+      CALL LWV_LMDAR4(NUAER,NTRAER, KLIM                                             &
+       &  , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE                  &
+       &  , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP                                      &
+       &  , PCNTRB,PCTS,PFLUC)
+!C     ------------------------------------------------------------------
+      RETURN
+      END SUBROUTINE LWBV_LMDAR4
+
+      SUBROUTINE LWC_LMDAR4(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC,                          &
+       &               PBINT,PBSUIN,PCTS,PCNTRB,                                     &
+       &               PFLUX)
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "radepsi.h"
+#include "radopt.h"
+!C
+!C     PURPOSE.
+!C     --------
+!C           INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
+!C           RADIANCES
+!C
+!C        EXPLICIT ARGUMENTS :
+!C        --------------------
+!C     ==== INPUTS ===
+!C PBINT  : (KDLON,0:KFLEV)     ; HALF LEVEL PLANCK FUNCTION
+!C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+!C PCLDLD : (KDLON,KFLEV)       ; DOWNWARD EFFECTIVE CLOUD FRACTION
+!C PCLDLU : (KDLON,KFLEV)       ; UPWARD EFFECTIVE CLOUD FRACTION
+!C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
+!C PCTS   : (KDLON,KFLEV)       ; CLEAR-SKY LAYER COOLING-TO-SPACE
+!C PEMIS  : (KDLON)             ; SURFACE EMISSIVITY
+!C PFLUC
+!C     ==== OUTPUTS ===
+!C PFLUX(KDLON,2,KFLEV)         ; RADIATIVE FLUXES :
+!C                     1  ==>  UPWARD   FLUX TOTAL
+!C                     2  ==>  DOWNWARD FLUX TOTAL
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
+!C          2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
+!C          3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
+!C     CLOUDS
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        Voigt lines (loop 231 to 233)  - JJM & PhD - 01/96
+!C-----------------------------------------------------------------------
+!C* ARGUMENTS:
+      INTEGER klim
+      REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1)   ! HALF LEVEL PLANCK FUNCTION
+      REAL(KIND=8) PBSUIN(KDLON)          ! SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE
+      REAL(KIND=8) PCTS(KDLON,KFLEV)      ! CLEAR-SKY LAYER COOLING-TO-SPACE
+!c
+      REAL(KIND=8) PCLDLD(KDLON,KFLEV)
+      REAL(KIND=8) PCLDLU(KDLON,KFLEV)
+      REAL(KIND=8) PEMIS(KDLON)
+!C
+      REAL(KIND=8) PFLUX(KDLON,2,KFLEV+1)
+!C-----------------------------------------------------------------------
+!C* LOCAL VARIABLES:
+      INTEGER IMX(KDLON), IMXP(KDLON)
+!C
+      REAL(KIND=8) ZCLEAR(KDLON),ZCLOUD(KDLON),                                      &
+       &     ZDNF(KDLON,KFLEV+1,KFLEV+1)                                             &
+       &  , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON)                                     &
+       &  , ZUPF(KDLON,KFLEV+1,KFLEV+1)
+      REAL(KIND=8) ZCLM(KDLON,KFLEV+1,KFLEV+1)
+!C
+      INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
+      INTEGER jk1, jk2, jkc, jkcp1, jcloud
+      INTEGER imxm1, imxp1
+      REAL(KIND=8) zcfrac
+!C     ------------------------------------------------------------------
+!C
+!C*         1.     INITIALIZATION
+!C                 --------------
+!C
+ 100  CONTINUE
+!C
+      IMAXC = 0
+!C
+      DO 101 JL = 1, KDLON
+      IMX(JL)=0
+      IMXP(JL)=0
+      ZCLOUD(JL) = 0.
+ 101  CONTINUE
+!C
+!C*         1.1    SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
+!C                 -------------------------------------------
+!C
+ 110  CONTINUE
+!C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      IMX1=IMX(JL)
+      IMX2=JK
+      IF (PCLDLU(JL,JK).GT.ZEPSC) THEN
+         IMXP(JL)=IMX2
+      ELSE
+         IMXP(JL)=IMX1
+      END IF
+      IMAXC=MAX(IMXP(JL),IMAXC)
+      IMX(JL)=IMXP(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+!CGM*******
+      IMAXC=KFLEV
+!CGM*******
+!C
+      DO 114 JK = 1 , KFLEV+1
+      DO 113 JL = 1, KDLON
+      PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
+      PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
+ 113  CONTINUE
+ 114  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.      EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
+!C                  ---------------------------------------
+!C
+      IF (IMAXC.GT.0) THEN
+!C
+         IMXP1 = IMAXC + 1
+         IMXM1 = IMAXC - 1
+!C
+!C*         2.0     INITIALIZE TO CLEAR-SKY FLUXES
+!C                  ------------------------------
+!C
+ 200  CONTINUE
+!C
+         DO 203 JK1=1,KFLEV+1
+         DO 202 JK2=1,KFLEV+1
+         DO 201 JL = 1, KDLON
+         ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
+         ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
+ 201     CONTINUE
+ 202     CONTINUE
+ 203     CONTINUE
+!C
+!C*         2.1     FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
+!C                  ----------------------------------------------
+!C
+ 210  CONTINUE
+!C
+         DO 213 JKC = 1 , IMAXC
+         JCLOUD=JKC
+         JKCP1=JCLOUD+1
+!C
+!C*         2.1.1   ABOVE THE CLOUD
+!C                  ---------------
+!C
+ 2110 CONTINUE
+!C
+         DO 2115 JK=JKCP1,KFLEV+1
+         JKM1=JK-1
+         DO 2111 JL = 1, KDLON
+         ZFU(JL)=0.
+ 2111    CONTINUE
+         IF (JK .GT. JKCP1) THEN
+            DO 2113 JKJ=JKCP1,JKM1
+            DO 2112 JL = 1, KDLON
+            ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
+ 2112       CONTINUE
+ 2113       CONTINUE
+         END IF
+!C
+         DO 2114 JL = 1, KDLON
+         ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
+ 2114    CONTINUE
+ 2115    CONTINUE
+!C
+!C*         2.1.2   BELOW THE CLOUD
+!C                  ---------------
+!C
+ 2120 CONTINUE
+!C
+         DO 2125 JK=1,JCLOUD
+         JKP1=JK+1
+         DO 2121 JL = 1, KDLON
+         ZFD(JL)=0.
+ 2121    CONTINUE
+!C
+         IF (JK .LT. JCLOUD) THEN
+            DO 2123 JKJ=JKP1,JCLOUD
+            DO 2122 JL = 1, KDLON
+            ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
+ 2122       CONTINUE
+ 2123       CONTINUE
+         END IF
+         DO 2124 JL = 1, KDLON
+         ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
+ 2124    CONTINUE
+ 2125    CONTINUE
+!C
+ 213     CONTINUE
+!C
+!C
+!C*         2.2     CLOUD COVER MATRIX
+!C                  ------------------
+!C
+!C*    ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
+!C     HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
+!C
+ 220  CONTINUE
+!C
+      DO 223 JK1 = 1 , KFLEV+1
+      DO 222 JK2 = 1 , KFLEV+1
+      DO 221 JL = 1, KDLON
+      ZCLM(JL,JK1,JK2) = 0.
+ 221  CONTINUE
+ 222  CONTINUE
+ 223  CONTINUE
+!C
+!C
+!C
+!C*         2.4     CLOUD COVER BELOW THE LEVEL OF CALCULATION
+!C                  ------------------------------------------
+!C
+ 240  CONTINUE
+!C
+      DO 244 JK1 = 2 , KFLEV+1
+      DO 241 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 241  CONTINUE
+      DO 243 JK = JK1 - 1 , 1 , -1
+      DO 242 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+!c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))                   &
+       &                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLU(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+!c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+!c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 242  CONTINUE
+ 243  CONTINUE
+ 244  CONTINUE
+!C
+!C
+!C*         2.5     CLOUD COVER ABOVE THE LEVEL OF CALCULATION
+!C                  ------------------------------------------
+!C
+ 250  CONTINUE
+!C
+      DO 254 JK1 = 1 , KFLEV
+      DO 251 JL = 1, KDLON
+      ZCLEAR(JL)=1.
+      ZCLOUD(JL)=0.
+ 251  CONTINUE
+      DO 253 JK = JK1 , KFLEV
+      DO 252 JL = 1, KDLON
+      IF (NOVLP.EQ.1) THEN
+!c* maximum-random       
+         ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))                   &
+       &                        /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
+         ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
+         ZCLOUD(JL) = PCLDLD(JL,JK)
+      ELSE IF (NOVLP.EQ.2) THEN 
+!c* maximum      
+         ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      ELSE IF (NOVLP.EQ.3) THEN
+!c* random      
+         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK))
+         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
+         ZCLM(JL,JK1,JK) = ZCLOUD(JL)
+      END IF
+ 252  CONTINUE
+ 253  CONTINUE
+ 254  CONTINUE
+!C
+!C
+!C
+!C*         3.      FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
+!C                  ----------------------------------------------
+!C
+ 300  CONTINUE
+!C
+!C*         3.1     DOWNWARD FLUXES
+!C                  ---------------
+!C
+ 310  CONTINUE
+!C
+      DO 311 JL = 1, KDLON
+      PFLUX(JL,2,KFLEV+1) = 0.
+ 311  CONTINUE
+!C
+      DO 317 JK1 = KFLEV , 1 , -1
+!C
+!C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+!C
+      DO 312 JL = 1, KDLON
+      ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1)
+ 312  CONTINUE
+!C
+!C*                 CONTRIBUTION FROM ADJACENT CLOUD
+!C
+      DO 313 JL = 1, KDLON
+      ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
+ 313  CONTINUE
+!C
+!C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+!C
+      DO 315 JK = KFLEV-1 , JK1 , -1
+      DO 314 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
+      ZFD(JL) =  ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
+ 314  CONTINUE
+ 315  CONTINUE
+!C
+      DO 316 JL = 1, KDLON
+      PFLUX(JL,2,JK1) = ZFD (JL)
+ 316  CONTINUE
+!C
+ 317  CONTINUE
+!C
+!C
+!C
+!C
+!C*         3.2     UPWARD FLUX AT THE SURFACE
+!C                  --------------------------
+!C
+ 320  CONTINUE
+!C
+      DO 321 JL = 1, KDLON
+      PFLUX(JL,1,1) = PEMIS(JL)*PBSUIN(JL)-(1.-PEMIS(JL))*PFLUX(JL,2,1)
+ 321  CONTINUE
+!C
+!C
+!C
+!C*         3.3     UPWARD FLUXES
+!C                  -------------
+!C
+ 330  CONTINUE
+!C
+      DO 337 JK1 = 2 , KFLEV+1
+!C
+!C*                 CONTRIBUTION FROM CLEAR-SKY FRACTION
+!C
+      DO 332 JL = 1, KDLON
+      ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
+ 332  CONTINUE
+!C
+!C*                 CONTRIBUTION FROM ADJACENT CLOUD
+!C
+      DO 333 JL = 1, KDLON
+      ZFU(JL) =  ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
+ 333  CONTINUE
+!C
+!C*                 CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
+!C
+      DO 335 JK = 2 , JK1-1
+      DO 334 JL = 1, KDLON
+      ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
+      ZFU(JL) =  ZFU(JL) + ZCFRAC * ZUPF(JL,JK  ,JK1)
+ 334  CONTINUE
+ 335  CONTINUE
+!C
+      DO 336 JL = 1, KDLON
+      PFLUX(JL,1,JK1) = ZFU (JL)
+ 336  CONTINUE
+!C
+ 337  CONTINUE
+!C
+!C
+      END IF
+!C
+!C
+!C*         2.3     END OF CLOUD EFFECT COMPUTATIONS
+!C
+ 230  CONTINUE
+!C
+      IF (.NOT.LEVOIGT) THEN
+        DO 231 JL = 1, KDLON
+        ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM)
+ 231    CONTINUE
+        DO 233 JK = KLIM+1 , KFLEV+1
+        DO 232 JL = 1, KDLON
+        ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+        PFLUX(JL,1,JK) = ZFN10(JL)
+        PFLUX(JL,2,JK) = 0.0
+ 232    CONTINUE
+ 233    CONTINUE
+      ENDIF
+!C
+      RETURN
+      END SUBROUTINE LWC_LMDAR4
+
+      SUBROUTINE LWB_LMDAR4(PDT0,PTAVE,PTL                                           &
+       &  , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL                                        &
+       &  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP)
+      USE dimphy
+      USE radiation_AR4_param, only : TINTP, XP, GA, GB
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           COMPUTES PLANCK FUNCTIONS
+!C
+!C        EXPLICIT ARGUMENTS :
+!C        --------------------
+!C     ==== INPUTS ===
+!C PDT0   : (KDLON)             ; SURFACE TEMPERATURE DISCONTINUITY
+!C PTAVE  : (KDLON,KFLEV)       ; TEMPERATURE
+!C PTL    : (KDLON,0:KFLEV)     ; HALF LEVEL TEMPERATURE
+!C     ==== OUTPUTS ===
+!C PB     : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
+!C PBINT  : (KDLON,KFLEV+1)     ; HALF LEVEL PLANCK FUNCTION
+!C PBSUIN : (KDLON)             ; SURFACE PLANCK FUNCTION
+!C PBSUR  : (KDLON,Ninter)        ; SURFACE SPECTRAL PLANCK FUNCTION
+!C PBTOP  : (KDLON,Ninter)        ; TOP SPECTRAL PLANCK FUNCTION
+!C PDBSL  : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
+!C PGA    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+!C PGB    : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
+!C PGASUR, PGBSUR (KDLON,8,2)   ; SURFACE PADE APPROXIMANTS
+!C PGATOP, PGBTOP (KDLON,8,2)   ; T.O.A. PADE APPROXIMANTS
+!C
+!C        IMPLICIT ARGUMENTS :   NONE
+!C        --------------------
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
+!C     FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS           "
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C
+!C-----------------------------------------------------------------------
+!C
+!C ARGUMENTS:
+!C
+      REAL(KIND=8) PDT0(KDLON)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV)
+      REAL(KIND=8) PTL(KDLON,KFLEV+1)
+!C
+      REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
+      REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL(KIND=8) PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION
+      REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
+      REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+!C
+!C-------------------------------------------------------------------------
+!C*  LOCAL VARIABLES:
+      INTEGER INDB(KDLON),INDS(KDLON)
+      REAL(KIND=8) ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1)
+      REAL(KIND=8) ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON)
+!c
+      INTEGER jk, jl, ic, jnu, jf, jg
+      INTEGER jk1, jk2
+      INTEGER k, j, ixtox, indto, ixtx, indt
+      INTEGER indsu, indtp
+      REAL(KIND=8) zdsto1, zdstox, zdst1, zdstx
+!c
+!C* Quelques parametres:
+      REAL(KIND=8) TSTAND
+      PARAMETER (TSTAND=250.0)
+      REAL(KIND=8) TSTP
+      PARAMETER (TSTP=12.5)
+      INTEGER MXIXT
+      PARAMETER (MXIXT=10)
+!C
+!C* Used Data Block:
+!c     REAL*8 TINTP(11)
+!c     SAVE TINTP
+!cc$OMP THREADPRIVATE(TINTP)
+!c     REAL*8 GA(11,16,3), GB(11,16,3)
+!c     SAVE GA, GB
+!cc$OMP THREADPRIVATE(GA, GB)
+!c     REAL*8 XP(6,6)
+!c     SAVE XP
+!cc$OMP THREADPRIVATE(XP)
+!c
+!c     DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
+!c    S             262.5, 275., 287.5, 300., 312.5 /
+!C-----------------------------------------------------------------------
+!C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
+!C
+!C
+!C
+!C
+!C-- R.D. -- G = - 0.2 SLA
+!C
+!C
+!C----- INTERVAL = 1 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 1, 1,IC),IC=1,3) /
+!C    S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
+!C     DATA (GB( 1, 1,IC),IC=1,3) /
+!C    S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
+!C     DATA (GA( 1, 2,IC),IC=1,3) /
+!C    S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
+!C     DATA (GB( 1, 2,IC),IC=1,3) /
+!C    S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 2, 1,IC),IC=1,3) /
+!C    S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
+!C     DATA (GB( 2, 1,IC),IC=1,3) /
+!C    S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
+!C     DATA (GA( 2, 2,IC),IC=1,3) /
+!C    S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
+!C     DATA (GB( 2, 2,IC),IC=1,3) /
+!C    S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 3, 1,IC),IC=1,3) /
+!C    S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
+!C     DATA (GB( 3, 1,IC),IC=1,3) /
+!C    S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
+!C     DATA (GA( 3, 2,IC),IC=1,3) /
+!C    S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
+!C     DATA (GB( 3, 2,IC),IC=1,3) /
+!C    S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 4, 1,IC),IC=1,3) /
+!C    S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
+!C     DATA (GB( 4, 1,IC),IC=1,3) /
+!C    S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
+!C     DATA (GA( 4, 2,IC),IC=1,3) /
+!C    S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
+!C     DATA (GB( 4, 2,IC),IC=1,3) /
+!C    S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 5, 1,IC),IC=1,3) /
+!C    S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
+!C     DATA (GB( 5, 1,IC),IC=1,3) /
+!C    S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
+!C     DATA (GA( 5, 2,IC),IC=1,3) /
+!C    S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
+!C     DATA (GB( 5, 2,IC),IC=1,3) /
+!C    S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 6, 1,IC),IC=1,3) /
+!C    S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
+!C     DATA (GB( 6, 1,IC),IC=1,3) /
+!C    S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
+!C     DATA (GA( 6, 2,IC),IC=1,3) /
+!C    S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
+!C     DATA (GB( 6, 2,IC),IC=1,3) /
+!C    S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 7, 1,IC),IC=1,3) /
+!C    S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
+!C     DATA (GB( 7, 1,IC),IC=1,3) /
+!C    S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
+!C     DATA (GA( 7, 2,IC),IC=1,3) /
+!C    S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
+!C     DATA (GB( 7, 2,IC),IC=1,3) /
+!C    S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 8, 1,IC),IC=1,3) /
+!C    S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
+!C     DATA (GB( 8, 1,IC),IC=1,3) /
+!C    S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
+!C     DATA (GA( 8, 2,IC),IC=1,3) /
+!C    S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
+!C     DATA (GB( 8, 2,IC),IC=1,3) /
+!C    S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 9, 1,IC),IC=1,3) /
+!C    S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
+!C     DATA (GB( 9, 1,IC),IC=1,3) /
+!C    S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
+!C     DATA (GA( 9, 2,IC),IC=1,3) /
+!C    S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
+!C     DATA (GB( 9, 2,IC),IC=1,3) /
+!C    S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA(10, 1,IC),IC=1,3) /
+!C    S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
+!C     DATA (GB(10, 1,IC),IC=1,3) /
+!C    S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
+!C     DATA (GA(10, 2,IC),IC=1,3) /
+!C    S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
+!C     DATA (GB(10, 2,IC),IC=1,3) /
+!C    S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 1 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA(11, 1,IC),IC=1,3) /
+!C    S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
+!C     DATA (GB(11, 1,IC),IC=1,3) /
+!C    S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
+!C     DATA (GA(11, 2,IC),IC=1,3) /
+!C    S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
+!C     DATA (GB(11, 2,IC),IC=1,3) /
+!C    S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
+!C
+!C
+!C
+!C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
+!C
+!C
+!C
+!C
+!C--- R.D.  ---  G = 0.02 + 0.50 / ( 1 + 4.5 U )
+!C
+!C
+!C----- INTERVAL = 2 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 1, 3,IC),IC=1,3) /
+!C    S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
+!C     DATA (GB( 1, 3,IC),IC=1,3) /
+!C    S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
+!C     DATA (GA( 1, 4,IC),IC=1,3) /
+!C    S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
+!C     DATA (GB( 1, 4,IC),IC=1,3) /
+!C    S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 2, 3,IC),IC=1,3) /
+!C    S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
+!C     DATA (GB( 2, 3,IC),IC=1,3) /
+!C    S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
+!C     DATA (GA( 2, 4,IC),IC=1,3) /
+!C    S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
+!C     DATA (GB( 2, 4,IC),IC=1,3) /
+!C    S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 3, 3,IC),IC=1,3) /
+!C    S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
+!C     DATA (GB( 3, 3,IC),IC=1,3) /
+!C    S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
+!C     DATA (GA( 3, 4,IC),IC=1,3) /
+!C    S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
+!C     DATA (GB( 3, 4,IC),IC=1,3) /
+!C    S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 4, 3,IC),IC=1,3) /
+!C    S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
+!C     DATA (GB( 4, 3,IC),IC=1,3) /
+!C    S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
+!C     DATA (GA( 4, 4,IC),IC=1,3) /
+!C    S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
+!C     DATA (GB( 4, 4,IC),IC=1,3) /
+!C    S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 5, 3,IC),IC=1,3) /
+!C    S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
+!C     DATA (GB( 5, 3,IC),IC=1,3) /
+!C    S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
+!C     DATA (GA( 5, 4,IC),IC=1,3) /
+!C    S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
+!C     DATA (GB( 5, 4,IC),IC=1,3) /
+!C    S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 6, 3,IC),IC=1,3) /
+!C    S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
+!C     DATA (GB( 6, 3,IC),IC=1,3) /
+!C    S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
+!C     DATA (GA( 6, 4,IC),IC=1,3) /
+!C    S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
+!C     DATA (GB( 6, 4,IC),IC=1,3) /
+!C    S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 7, 3,IC),IC=1,3) /
+!C    S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
+!C     DATA (GB( 7, 3,IC),IC=1,3) /
+!C    S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
+!C     DATA (GA( 7, 4,IC),IC=1,3) /
+!C    S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
+!C     DATA (GB( 7, 4,IC),IC=1,3) /
+!C    S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 8, 3,IC),IC=1,3) /
+!C    S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
+!C     DATA (GB( 8, 3,IC),IC=1,3) /
+!C    S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
+!C     DATA (GA( 8, 4,IC),IC=1,3) /
+!C    S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
+!C     DATA (GB( 8, 4,IC),IC=1,3) /
+!C    S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 9, 3,IC),IC=1,3) /
+!C    S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
+!C     DATA (GB( 9, 3,IC),IC=1,3) /
+!C    S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
+!C     DATA (GA( 9, 4,IC),IC=1,3) /
+!C    S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
+!C     DATA (GB( 9, 4,IC),IC=1,3) /
+!C    S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA(10, 3,IC),IC=1,3) /
+!C    S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
+!C     DATA (GB(10, 3,IC),IC=1,3) /
+!C    S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
+!C     DATA (GA(10, 4,IC),IC=1,3) /
+!C    S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
+!C     DATA (GB(10, 4,IC),IC=1,3) /
+!C    S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA(11, 3,IC),IC=1,3) /
+!C    S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
+!C     DATA (GB(11, 3,IC),IC=1,3) /
+!C    S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
+!C     DATA (GA(11, 4,IC),IC=1,3) /
+!C    S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
+!C     DATA (GB(11, 4,IC),IC=1,3) /
+!C    S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
+!C
+!C
+!C
+!C
+!C
+!C
+!C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
+!C
+!C
+!C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
+!C
+!C
+!C
+!C--- G = 3.875E-03 ---------------
+!C
+!C----- INTERVAL = 3 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 1, 7,IC),IC=1,3) /
+!C    S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
+!C     DATA (GB( 1, 7,IC),IC=1,3) /
+!C    S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
+!C     DATA (GA( 1, 8,IC),IC=1,3) /
+!C    S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
+!C     DATA (GB( 1, 8,IC),IC=1,3) /
+!C    S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 2, 7,IC),IC=1,3) /
+!C    S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
+!C     DATA (GB( 2, 7,IC),IC=1,3) /
+!C    S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
+!C     DATA (GA( 2, 8,IC),IC=1,3) /
+!C    S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
+!C     DATA (GB( 2, 8,IC),IC=1,3) /
+!C    S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 3, 7,IC),IC=1,3) /
+!C    S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
+!C     DATA (GB( 3, 7,IC),IC=1,3) /
+!C    S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
+!C     DATA (GA( 3, 8,IC),IC=1,3) /
+!C    S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
+!C     DATA (GB( 3, 8,IC),IC=1,3) /
+!C    S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 4, 7,IC),IC=1,3) /
+!C    S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
+!C     DATA (GB( 4, 7,IC),IC=1,3) /
+!C    S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
+!C     DATA (GA( 4, 8,IC),IC=1,3) /
+!C    S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
+!C     DATA (GB( 4, 8,IC),IC=1,3) /
+!C    S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 5, 7,IC),IC=1,3) /
+!C    S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
+!C     DATA (GB( 5, 7,IC),IC=1,3) /
+!C    S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
+!C     DATA (GA( 5, 8,IC),IC=1,3) /
+!C    S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
+!C     DATA (GB( 5, 8,IC),IC=1,3) /
+!C    S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 6, 7,IC),IC=1,3) /
+!C    S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
+!C     DATA (GB( 6, 7,IC),IC=1,3) /
+!C    S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
+!C     DATA (GA( 6, 8,IC),IC=1,3) /
+!C    S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
+!C     DATA (GB( 6, 8,IC),IC=1,3) /
+!C    S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 7, 7,IC),IC=1,3) /
+!C    S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
+!C     DATA (GB( 7, 7,IC),IC=1,3) /
+!C    S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
+!C     DATA (GA( 7, 8,IC),IC=1,3) /
+!C    S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
+!C     DATA (GB( 7, 8,IC),IC=1,3) /
+!C    S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 8, 7,IC),IC=1,3) /
+!C    S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
+!C     DATA (GB( 8, 7,IC),IC=1,3) /
+!C    S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
+!C     DATA (GA( 8, 8,IC),IC=1,3) /
+!C    S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
+!C     DATA (GB( 8, 8,IC),IC=1,3) /
+!C    S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 9, 7,IC),IC=1,3) /
+!C    S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
+!C     DATA (GB( 9, 7,IC),IC=1,3) /
+!C    S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
+!C     DATA (GA( 9, 8,IC),IC=1,3) /
+!C    S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
+!C     DATA (GB( 9, 8,IC),IC=1,3) /
+!C    S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA(10, 7,IC),IC=1,3) /
+!C    S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
+!C     DATA (GB(10, 7,IC),IC=1,3) /
+!C    S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
+!C     DATA (GA(10, 8,IC),IC=1,3) /
+!C    S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
+!C     DATA (GB(10, 8,IC),IC=1,3) /
+!C    S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 3 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA(11, 7,IC),IC=1,3) /
+!C    S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
+!C     DATA (GB(11, 7,IC),IC=1,3) /
+!C    S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
+!C     DATA (GA(11, 8,IC),IC=1,3) /
+!C    S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
+!C     DATA (GB(11, 8,IC),IC=1,3) /
+!C    S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
+!C
+!C
+!C-- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
+!C
+!C-- G = 3.6E-03
+!C
+!C----- INTERVAL = 4 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 1, 9,IC),IC=1,3) /
+!C    S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
+!C     DATA (GB( 1, 9,IC),IC=1,3) /
+!C    S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
+!C     DATA (GA( 1,10,IC),IC=1,3) /
+!C    S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
+!C     DATA (GB( 1,10,IC),IC=1,3) /
+!C    S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 2, 9,IC),IC=1,3) /
+!C    S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
+!C     DATA (GB( 2, 9,IC),IC=1,3) /
+!C    S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
+!C     DATA (GA( 2,10,IC),IC=1,3) /
+!C    S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
+!C     DATA (GB( 2,10,IC),IC=1,3) /
+!C    S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 3, 9,IC),IC=1,3) /
+!C    S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
+!C     DATA (GB( 3, 9,IC),IC=1,3) /
+!C    S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
+!C     DATA (GA( 3,10,IC),IC=1,3) /
+!C    S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
+!C     DATA (GB( 3,10,IC),IC=1,3) /
+!C    S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 4, 9,IC),IC=1,3) /
+!C    S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
+!C     DATA (GB( 4, 9,IC),IC=1,3) /
+!C    S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
+!C     DATA (GA( 4,10,IC),IC=1,3) /
+!C    S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
+!C     DATA (GB( 4,10,IC),IC=1,3) /
+!C    S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 5, 9,IC),IC=1,3) /
+!C    S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
+!C     DATA (GB( 5, 9,IC),IC=1,3) /
+!C    S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
+!C     DATA (GA( 5,10,IC),IC=1,3) /
+!C    S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
+!C     DATA (GB( 5,10,IC),IC=1,3) /
+!C    S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 6, 9,IC),IC=1,3) /
+!C    S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
+!C     DATA (GB( 6, 9,IC),IC=1,3) /
+!C    S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
+!C     DATA (GA( 6,10,IC),IC=1,3) /
+!C    S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
+!C     DATA (GB( 6,10,IC),IC=1,3) /
+!C    S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 7, 9,IC),IC=1,3) /
+!C    S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
+!C     DATA (GB( 7, 9,IC),IC=1,3) /
+!C    S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
+!C     DATA (GA( 7,10,IC),IC=1,3) /
+!C    S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
+!C     DATA (GB( 7,10,IC),IC=1,3) /
+!C    S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 8, 9,IC),IC=1,3) /
+!C    S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
+!C     DATA (GB( 8, 9,IC),IC=1,3) /
+!C    S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
+!C     DATA (GA( 8,10,IC),IC=1,3) /
+!C    S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
+!C     DATA (GB( 8,10,IC),IC=1,3) /
+!C    S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA( 9, 9,IC),IC=1,3) /
+!C    S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
+!C     DATA (GB( 9, 9,IC),IC=1,3) /
+!C    S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
+!C     DATA (GA( 9,10,IC),IC=1,3) /
+!C    S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
+!C     DATA (GB( 9,10,IC),IC=1,3) /
+!C    S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA(10, 9,IC),IC=1,3) /
+!C    S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
+!C     DATA (GB(10, 9,IC),IC=1,3) /
+!C    S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
+!C     DATA (GA(10,10,IC),IC=1,3) /
+!C    S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
+!C     DATA (GB(10,10,IC),IC=1,3) /
+!C    S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   28   37   45
+!C     DATA (GA(11, 9,IC),IC=1,3) /
+!C    S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
+!C     DATA (GB(11, 9,IC),IC=1,3) /
+!C    S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
+!C     DATA (GA(11,10,IC),IC=1,3) /
+!C    S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
+!C     DATA (GB(11,10,IC),IC=1,3) /
+!C    S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
+!C
+!C
+!C
+!C-- H2O -- WEAKER PARTS OF THE STRONG BANDS  -- FROM ABS225 ----
+!C
+!C-- WATER VAPOR --- 350 - 500 CM-1
+!C
+!C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
+!C
+!C----- INTERVAL = 5 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 1, 5,IC),IC=1,3) /
+!C    S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
+!C     DATA (GB( 1, 5,IC),IC=1,3) /
+!C    S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
+!C     DATA (GA( 1, 6,IC),IC=1,3) /
+!C    S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
+!C     DATA (GB( 1, 6,IC),IC=1,3) /
+!C    S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 2, 5,IC),IC=1,3) /
+!C    S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
+!C     DATA (GB( 2, 5,IC),IC=1,3) /
+!C    S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
+!C     DATA (GA( 2, 6,IC),IC=1,3) /
+!C    S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
+!C     DATA (GB( 2, 6,IC),IC=1,3) /
+!C    S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 3, 5,IC),IC=1,3) /
+!C    S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
+!C     DATA (GB( 3, 5,IC),IC=1,3) /
+!C    S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
+!C     DATA (GA( 3, 6,IC),IC=1,3) /
+!C    S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
+!C     DATA (GB( 3, 6,IC),IC=1,3) /
+!C    S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 4, 5,IC),IC=1,3) /
+!C    S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
+!C     DATA (GB( 4, 5,IC),IC=1,3) /
+!C    S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
+!C     DATA (GA( 4, 6,IC),IC=1,3) /
+!C    S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
+!C     DATA (GB( 4, 6,IC),IC=1,3) /
+!C    S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 5, 5,IC),IC=1,3) /
+!C    S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
+!C     DATA (GB( 5, 5,IC),IC=1,3) /
+!C    S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
+!C     DATA (GA( 5, 6,IC),IC=1,3) /
+!C    S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
+!C     DATA (GB( 5, 6,IC),IC=1,3) /
+!C    S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 6, 5,IC),IC=1,3) /
+!C    S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
+!C     DATA (GB( 6, 5,IC),IC=1,3) /
+!C    S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
+!C     DATA (GA( 6, 6,IC),IC=1,3) /
+!C    S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
+!C     DATA (GB( 6, 6,IC),IC=1,3) /
+!C    S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 7, 5,IC),IC=1,3) /
+!C    S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
+!C     DATA (GB( 7, 5,IC),IC=1,3) /
+!C    S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
+!C     DATA (GA( 7, 6,IC),IC=1,3) /
+!C    S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
+!C     DATA (GB( 7, 6,IC),IC=1,3) /
+!C    S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 8, 5,IC),IC=1,3) /
+!C    S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
+!C     DATA (GB( 8, 5,IC),IC=1,3) /
+!C    S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
+!C     DATA (GA( 8, 6,IC),IC=1,3) /
+!C    S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
+!C     DATA (GB( 8, 6,IC),IC=1,3) /
+!C    S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 9, 5,IC),IC=1,3) /
+!C    S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
+!C     DATA (GB( 9, 5,IC),IC=1,3) /
+!C    S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
+!C     DATA (GA( 9, 6,IC),IC=1,3) /
+!C    S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
+!C     DATA (GB( 9, 6,IC),IC=1,3) /
+!C    S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA(10, 5,IC),IC=1,3) /
+!C    S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
+!C     DATA (GB(10, 5,IC),IC=1,3) /
+!C    S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
+!C     DATA (GA(10, 6,IC),IC=1,3) /
+!C    S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
+!C     DATA (GB(10, 6,IC),IC=1,3) /
+!C    S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
+!C
+!C----- INTERVAL = 5 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA(11, 5,IC),IC=1,3) /
+!C    S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
+!C     DATA (GB(11, 5,IC),IC=1,3) /
+!C    S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
+!C     DATA (GA(11, 6,IC),IC=1,3) /
+!C    S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
+!C     DATA (GB(11, 6,IC),IC=1,3) /
+!C    S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
+!C
+!C
+!C
+!C
+!C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
+!C--- G = 0.0
+!C
+!C
+!C----- INTERVAL = 6 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 1,11,IC),IC=1,3) /
+!C    S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
+!C     DATA (GB( 1,11,IC),IC=1,3) /
+!C    S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
+!C     DATA (GA( 1,12,IC),IC=1,3) /
+!C    S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
+!C     DATA (GB( 1,12,IC),IC=1,3) /
+!C    S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 2,11,IC),IC=1,3) /
+!C    S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
+!C     DATA (GB( 2,11,IC),IC=1,3) /
+!C    S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
+!C     DATA (GA( 2,12,IC),IC=1,3) /
+!C    S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
+!C     DATA (GB( 2,12,IC),IC=1,3) /
+!C    S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 3,11,IC),IC=1,3) /
+!C    S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
+!C     DATA (GB( 3,11,IC),IC=1,3) /
+!C    S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
+!C     DATA (GA( 3,12,IC),IC=1,3) /
+!C    S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
+!C     DATA (GB( 3,12,IC),IC=1,3) /
+!C    S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 4,11,IC),IC=1,3) /
+!C    S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
+!C     DATA (GB( 4,11,IC),IC=1,3) /
+!C    S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
+!C     DATA (GA( 4,12,IC),IC=1,3) /
+!C    S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
+!C     DATA (GB( 4,12,IC),IC=1,3) /
+!C    S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 5,11,IC),IC=1,3) /
+!C    S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
+!C     DATA (GB( 5,11,IC),IC=1,3) /
+!C    S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
+!C     DATA (GA( 5,12,IC),IC=1,3) /
+!C    S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
+!C     DATA (GB( 5,12,IC),IC=1,3) /
+!C    S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 6,11,IC),IC=1,3) /
+!C    S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
+!C     DATA (GB( 6,11,IC),IC=1,3) /
+!C    S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
+!C     DATA (GA( 6,12,IC),IC=1,3) /
+!C    S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
+!C     DATA (GB( 6,12,IC),IC=1,3) /
+!C    S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 7,11,IC),IC=1,3) /
+!C    S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
+!C     DATA (GB( 7,11,IC),IC=1,3) /
+!C    S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
+!C     DATA (GA( 7,12,IC),IC=1,3) /
+!C    S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
+!C     DATA (GB( 7,12,IC),IC=1,3) /
+!C    S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 8,11,IC),IC=1,3) /
+!C    S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
+!C     DATA (GB( 8,11,IC),IC=1,3) /
+!C    S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
+!C     DATA (GA( 8,12,IC),IC=1,3) /
+!C    S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
+!C     DATA (GB( 8,12,IC),IC=1,3) /
+!C    S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA( 9,11,IC),IC=1,3) /
+!C    S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
+!C     DATA (GB( 9,11,IC),IC=1,3) /
+!C    S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
+!C     DATA (GA( 9,12,IC),IC=1,3) /
+!C    S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
+!C     DATA (GB( 9,12,IC),IC=1,3) /
+!C    S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA(10,11,IC),IC=1,3) /
+!C    S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
+!C     DATA (GB(10,11,IC),IC=1,3) /
+!C    S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
+!C     DATA (GA(10,12,IC),IC=1,3) /
+!C    S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
+!C     DATA (GB(10,12,IC),IC=1,3) /
+!C    S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 6 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 35 40 45
+!C     DATA (GA(11,11,IC),IC=1,3) /
+!C    S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
+!C     DATA (GB(11,11,IC),IC=1,3) /
+!C    S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
+!C     DATA (GA(11,12,IC),IC=1,3) /
+!C    S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
+!C     DATA (GB(11,12,IC),IC=1,3) /
+!C    S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
+!C
+!C
+!C
+!C
+!C
+!C-- END WATER VAPOR
+!C
+!C
+!C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
+!C
+!C
+!C
+!C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9)  , X/T,  9
+!C
+!C----- INTERVAL = 2 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 1,13,IC),IC=1,3) /
+!C    S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
+!C     DATA (GB( 1,13,IC),IC=1,3) /
+!C    S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
+!C     DATA (GA( 1,14,IC),IC=1,3) /
+!C    S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
+!C     DATA (GB( 1,14,IC),IC=1,3) /
+!C    S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 2,13,IC),IC=1,3) /
+!C    S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
+!C     DATA (GB( 2,13,IC),IC=1,3) /
+!C    S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
+!C     DATA (GA( 2,14,IC),IC=1,3) /
+!C    S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
+!C     DATA (GB( 2,14,IC),IC=1,3) /
+!C    S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 3,13,IC),IC=1,3) /
+!C    S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
+!C     DATA (GB( 3,13,IC),IC=1,3) /
+!C    S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
+!C     DATA (GA( 3,14,IC),IC=1,3) /
+!C    S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
+!C     DATA (GB( 3,14,IC),IC=1,3) /
+!C    S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 4,13,IC),IC=1,3) /
+!C    S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
+!C     DATA (GB( 4,13,IC),IC=1,3) /
+!C    S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
+!C     DATA (GA( 4,14,IC),IC=1,3) /
+!C    S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
+!C     DATA (GB( 4,14,IC),IC=1,3) /
+!C    S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 5,13,IC),IC=1,3) /
+!C    S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
+!C     DATA (GB( 5,13,IC),IC=1,3) /
+!C    S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
+!C     DATA (GA( 5,14,IC),IC=1,3) /
+!C    S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
+!C     DATA (GB( 5,14,IC),IC=1,3) /
+!C    S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 6,13,IC),IC=1,3) /
+!C    S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
+!C     DATA (GB( 6,13,IC),IC=1,3) /
+!C    S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
+!C     DATA (GA( 6,14,IC),IC=1,3) /
+!C    S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
+!C     DATA (GB( 6,14,IC),IC=1,3) /
+!C    S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 7,13,IC),IC=1,3) /
+!C    S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
+!C     DATA (GB( 7,13,IC),IC=1,3) /
+!C    S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
+!C     DATA (GA( 7,14,IC),IC=1,3) /
+!C    S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
+!C     DATA (GB( 7,14,IC),IC=1,3) /
+!C    S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 8,13,IC),IC=1,3) /
+!C    S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
+!C     DATA (GB( 8,13,IC),IC=1,3) /
+!C    S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
+!C     DATA (GA( 8,14,IC),IC=1,3) /
+!C    S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
+!C     DATA (GB( 8,14,IC),IC=1,3) /
+!C    S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA( 9,13,IC),IC=1,3) /
+!C    S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
+!C     DATA (GB( 9,13,IC),IC=1,3) /
+!C    S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
+!C     DATA (GA( 9,14,IC),IC=1,3) /
+!C    S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
+!C     DATA (GB( 9,14,IC),IC=1,3) /
+!C    S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA(10,13,IC),IC=1,3) /
+!C    S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
+!C     DATA (GB(10,13,IC),IC=1,3) /
+!C    S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
+!C     DATA (GA(10,14,IC),IC=1,3) /
+!C    S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
+!C     DATA (GB(10,14,IC),IC=1,3) /
+!C    S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
+!C
+!C----- INTERVAL = 2 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION   1 30 38 45
+!C     DATA (GA(11,13,IC),IC=1,3) /
+!C    S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
+!C     DATA (GB(11,13,IC),IC=1,3) /
+!C    S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
+!C     DATA (GA(11,14,IC),IC=1,3) /
+!C    S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
+!C     DATA (GB(11,14,IC),IC=1,3) /
+!C    S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
+!C
+!C
+!C
+!C
+!C
+!C
+!C
+!C
+!C
+!C
+!C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
+!C
+!C
+!C-- G = 0.0
+!C
+!C
+!C----- INTERVAL = 4 ----- T =  187.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 1,15,IC),IC=1,3) /
+!C    S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
+!C     DATA (GB( 1,15,IC),IC=1,3) /
+!C    S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
+!C     DATA (GA( 1,16,IC),IC=1,3) /
+!C    S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
+!C     DATA (GB( 1,16,IC),IC=1,3) /
+!C    S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  200.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 2,15,IC),IC=1,3) /
+!C    S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
+!C     DATA (GB( 2,15,IC),IC=1,3) /
+!C    S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
+!C     DATA (GA( 2,16,IC),IC=1,3) /
+!C    S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
+!C     DATA (GB( 2,16,IC),IC=1,3) /
+!C    S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  212.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 3,15,IC),IC=1,3) /
+!C    S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
+!C     DATA (GB( 3,15,IC),IC=1,3) /
+!C    S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
+!C     DATA (GA( 3,16,IC),IC=1,3) /
+!C    S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
+!C     DATA (GB( 3,16,IC),IC=1,3) /
+!C    S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  225.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 4,15,IC),IC=1,3) /
+!C    S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
+!C     DATA (GB( 4,15,IC),IC=1,3) /
+!C    S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
+!C     DATA (GA( 4,16,IC),IC=1,3) /
+!C    S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
+!C     DATA (GB( 4,16,IC),IC=1,3) /
+!C    S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  237.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 5,15,IC),IC=1,3) /
+!C    S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
+!C     DATA (GB( 5,15,IC),IC=1,3) /
+!C    S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
+!C     DATA (GA( 5,16,IC),IC=1,3) /
+!C    S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
+!C     DATA (GB( 5,16,IC),IC=1,3) /
+!C    S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  250.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 6,15,IC),IC=1,3) /
+!C    S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
+!C     DATA (GB( 6,15,IC),IC=1,3) /
+!C    S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
+!C     DATA (GA( 6,16,IC),IC=1,3) /
+!C    S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
+!C     DATA (GB( 6,16,IC),IC=1,3) /
+!C    S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  262.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 7,15,IC),IC=1,3) /
+!C    S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
+!C     DATA (GB( 7,15,IC),IC=1,3) /
+!C    S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
+!C     DATA (GA( 7,16,IC),IC=1,3) /
+!C    S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
+!C     DATA (GB( 7,16,IC),IC=1,3) /
+!C    S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  275.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 8,15,IC),IC=1,3) /
+!C    S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
+!C     DATA (GB( 8,15,IC),IC=1,3) /
+!C    S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
+!C     DATA (GA( 8,16,IC),IC=1,3) /
+!C    S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
+!C     DATA (GB( 8,16,IC),IC=1,3) /
+!C    S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  287.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA( 9,15,IC),IC=1,3) /
+!C    S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
+!C     DATA (GB( 9,15,IC),IC=1,3) /
+!C    S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
+!C     DATA (GA( 9,16,IC),IC=1,3) /
+!C    S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
+!C     DATA (GB( 9,16,IC),IC=1,3) /
+!C    S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  300.0
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA(10,15,IC),IC=1,3) /
+!C    S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
+!C     DATA (GB(10,15,IC),IC=1,3) /
+!C    S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
+!C     DATA (GA(10,16,IC),IC=1,3) /
+!C    S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
+!C     DATA (GB(10,16,IC),IC=1,3) /
+!C    S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
+!C
+!C----- INTERVAL = 4 ----- T =  312.5
+!C
+!C-- INDICES FOR PADE APPROXIMATION     1   15   29   45
+!C     DATA (GA(11,15,IC),IC=1,3) /
+!C    S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
+!C     DATA (GB(11,15,IC),IC=1,3) /
+!C    S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
+!C     DATA (GA(11,16,IC),IC=1,3) /
+!C    S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
+!C     DATA (GB(11,16,IC),IC=1,3) /
+!C    S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
+!C
+!C     ------------------------------------------------------------------
+!C     DATA (( XP(  J,K),J=1,6),       K=1,6) /
+!C    S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
+!C    S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
+!C    S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
+!C    S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
+!C    S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
+!C    S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
+!C    S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
+!C    S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
+!C    S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
+!C    S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
+!C    S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
+!C    S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
+
+!C
+!C
+!C*         1.0     PLANCK FUNCTIONS AND GRADIENTS
+!C                  ------------------------------
+!C
+ 100  CONTINUE
+!C
+!cdir collapse
+      DO 102 JK = 1 , KFLEV+1
+      DO 101 JL = 1, KDLON
+      PBINT(JL,JK) = 0.
+ 101  CONTINUE
+ 102  CONTINUE
+      DO 103 JL = 1, KDLON
+      PBSUIN(JL) = 0.
+ 103  CONTINUE
+!C
+      DO 141 JNU=1,Ninter
+!C
+!C
+!C*         1.1   LEVELS FROM SURFACE TO KFLEV
+!C                ----------------------------
+!C
+ 110  CONTINUE
+!C
+      DO 112 JK = 1 , KFLEV
+      DO 111 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)                     &
+       &       +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)             &
+       &       )))))
+      PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
+      PB(JL,JNU,JK)= ZRES(JL)
+      ZBLEV(JL,JK) = ZRES(JL)
+      ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
+      ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)                    &
+       &     +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)            &
+       &       )))))
+      ZBLAY(JL,JK) = ZRES2(JL)
+ 111  CONTINUE
+ 112  CONTINUE
+!C
+!C
+!C*         1.2   TOP OF THE ATMOSPHERE AND SURFACE
+!C                ---------------------------------
+!C
+ 120  CONTINUE
+!C
+      DO 121 JL = 1, KDLON
+      ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
+      ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
+      ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)                     &
+       &    +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)                &
+       &       )))))
+      ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)                  &
+       &    +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)             &
+       &       )))))
+      PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
+      PB(JL,JNU,KFLEV+1)= ZRES(JL)
+      ZBLEV(JL,KFLEV+1) = ZRES(JL)
+      PBTOP(JL,JNU) = ZRES(JL)
+      PBSUR(JL,JNU) = ZRES2(JL)
+      PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
+ 121  CONTINUE
+!C
+!C
+!C*         1.3   GRADIENTS IN SUB-LAYERS
+!C                -----------------------
+!C
+ 130  CONTINUE
+!C
+      DO 132 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 131 JL = 1, KDLON
+      PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK  ) - ZBLEV(JL,JK)
+      PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
+ 131  CONTINUE
+ 132  CONTINUE
+!C
+ 141  CONTINUE
+!C
+!C*         2.0   CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
+!C                ---------------------------------------------
+!C
+ 200  CONTINUE
+!C
+!C
+ 210  CONTINUE
+!C
+      DO 211 JL=1, KDLON
+      ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP
+      IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) )
+      ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP
+      IF (ZDSTOX.LT.0.5) THEN
+         INDTO=IXTOX
+      ELSE
+         INDTO=IXTOX+1
+      END IF
+      INDB(JL)=INDTO
+      ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDS(JL)=INDT
+ 211  CONTINUE
+!C
+      DO 214 JF=1,2
+      DO 213 JG=1, 8
+      DO 212 JL=1, KDLON
+      INDSU=INDS(JL)
+      PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
+      PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
+      INDTP=INDB(JL)
+      PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
+      PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
+ 212  CONTINUE
+ 213  CONTINUE
+ 214  CONTINUE
+!C
+ 220  CONTINUE
+!C
+      DO 225 JK=1,KFLEV
+      DO 221 JL=1, KDLON
+      ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
+      IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
+      ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
+      IF (ZDSTX.LT.0.5) THEN
+         INDT=IXTX
+      ELSE
+         INDT=IXTX+1
+      END IF
+      INDB(JL)=INDT
+ 221  CONTINUE
+!C
+      DO 224 JF=1,2
+      DO 223 JG=1, 8
+      DO 222 JL=1, KDLON
+      INDT=INDB(JL)
+      PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
+      PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
+ 222  CONTINUE
+ 223  CONTINUE
+ 224  CONTINUE
+ 225  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE LWB_LMDAR4
+
+      SUBROUTINE LWV_LMDAR4(KUAER,KTRAER, KLIM                                       &
+       &  , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE                 &
+       &  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP                                      &
+       &  , PCNTRB,PCTS,PFLUC)
+       USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+#include "YOMCST.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
+!C           FLUXES OR RADIANCES
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
+!C     CONTRIBUTIONS BY -  THE NEARBY LAYERS
+!C                      -  THE DISTANT LAYERS
+!C                      -  THE BOUNDARY TERMS
+!C          2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C-----------------------------------------------------------------------
+!C
+!C* ARGUMENTS:
+      INTEGER KUAER,KTRAER, KLIM
+!C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
+      REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
+      REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
+      REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+      REAL(KIND=8) PTAVE(KDLON,KFLEV) ! TEMPERATURE
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGASUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGATOP(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS
+!C
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+      REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+!C-----------------------------------------------------------------------
+!C LOCAL VARIABLES:
+      REAL(KIND=8) ZADJD(KDLON,KFLEV+1)
+      REAL(KIND=8) ZADJU(KDLON,KFLEV+1)
+      REAL(KIND=8) ZDBDT(KDLON,Ninter,KFLEV)
+      REAL(KIND=8) ZDISD(KDLON,KFLEV+1)
+      REAL(KIND=8) ZDISU(KDLON,KFLEV+1)
+!C
+      INTEGER jk, jl
+!C-----------------------------------------------------------------------
+!C
+      DO 112 JK=1,KFLEV+1
+      DO 111 JL=1, KDLON
+      ZADJD(JL,JK)=0.
+      ZADJU(JL,JK)=0.
+      ZDISD(JL,JK)=0.
+      ZDISU(JL,JK)=0.
+ 111  CONTINUE
+ 112  CONTINUE
+!C
+      DO 114 JK=1,KFLEV
+      DO 113 JL=1, KDLON
+      PCTS(JL,JK)=0.
+ 113  CONTINUE
+ 114  CONTINUE
+!C
+!C* CONTRIBUTION FROM ADJACENT LAYERS
+!C
+      CALL LWVN_LMDAR4(KUAER,KTRAER                                                  &
+       &  , PABCU,PDBSL,PGA,PGB                                                      &
+       &  , ZADJD,ZADJU,PCNTRB,ZDBDT)
+!C* CONTRIBUTION FROM DISTANT LAYERS
+!C
+      CALL LWVD_LMDAR4(KUAER,KTRAER                                                  &
+       &  , PABCU,ZDBDT,PGA,PGB                                                      &
+       &  , PCNTRB,ZDISD,ZDISU)
+!C
+!C* EXCHANGE WITH THE BOUNDARIES
+!C
+      CALL LWVB_LMDAR4(KUAER,KTRAER, KLIM                                            &
+       &  , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP                            &
+       &  , ZDISD,ZDISU,PEMIS,PPMB                                                   &
+       &  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP                                      &
+       &  , PCTS,PFLUC)
+!C
+!C
+      RETURN
+      END SUBROUTINE LWV_LMDAR4
+
+      SUBROUTINE LWVB_LMDAR4(KUAER,KTRAER, KLIM                                      &
+       &  , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP                             &
+       &  , PDISD,PDISU,PEMIS,PPMB                                                   &
+       &  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP                                      &
+       &  , PCTS,PFLUC)
+       USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+#include "radopt.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
+!C           INTEGRATION
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
+!C     ATMOSPHERE
+!C          2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
+!C     TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
+!C          3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C        Voigt lines (loop 2413 to 2427)  - JJM & PhD - 01/96
+!C-----------------------------------------------------------------------
+!C
+!C*       0.1   ARGUMENTS
+!C              ---------
+!C
+      INTEGER KUAER,KTRAER, KLIM
+!C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
+      REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
+      REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
+      REAL(KIND=8) PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
+      REAL(KIND=8) PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
+      REAL(KIND=8) PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL(KIND=8) PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
+      REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY
+      REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! PRESSURE MB
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
+      REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+      REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
+!C
+      REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
+      REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) ZBGND(KDLON)
+      REAL(KIND=8) ZFD(KDLON)
+      REAL(KIND=8)  ZFN10(KDLON)
+      REAL(KIND=8) ZFU(KDLON)
+      REAL(KIND=8)  ZTT(KDLON,NTRA)
+      REAL(KIND=8) ZTT1(KDLON,NTRA)
+      REAL(KIND=8) ZTT2(KDLON,NTRA)
+      REAL(KIND=8)  ZUU(KDLON,NUA) 
+      REAL(KIND=8) ZCNSOL(KDLON)
+      REAL(KIND=8) ZCNTOP(KDLON)
+!C
+      INTEGER jk, jl, ja
+      INTEGER jstra, jstru
+      INTEGER ind1, ind2, ind3, ind4, in, jlim
+      REAL(KIND=8) zctstr
+!C-----------------------------------------------------------------------
+!C
+!C*         1.    INITIALIZATION
+!C                --------------
+!C
+ 100  CONTINUE
+!C
+!C
+!C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+!C                  ---------------------------------
+!C
+ 120  CONTINUE
+!C
+      DO 122 JA=1,NTRA
+      DO 121 JL=1, KDLON
+      ZTT (JL,JA)=1.0
+      ZTT1(JL,JA)=1.0
+      ZTT2(JL,JA)=1.0
+ 121  CONTINUE
+ 122  CONTINUE
+!C
+      DO 124 JA=1,NUA
+      DO 123 JL=1, KDLON
+      ZUU(JL,JA)=1.0
+ 123  CONTINUE
+ 124  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.      VERTICAL INTEGRATION
+!C                  --------------------
+!C
+ 200  CONTINUE
+!C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+!C
+!C
+!C*         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
+!C                  -----------------------------------
+!C
+ 230  CONTINUE
+!C
+      DO 235 JK = 1 , KFLEV
+      IN=(JK-1)*NG1P1+1
+!C
+      DO 232 JA=1,KUAER
+      DO 231 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,IN)
+ 231  CONTINUE
+ 232  CONTINUE
+!C
+!C
+      CALL LWTT_LMDAR4(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
+!C
+      DO 234 JL = 1, KDLON
+      ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1)          *ZTT(JL,10)                          &
+       &      +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)                            &
+       &      +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)                            &
+       &      +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)                            &
+       &      +PBTOP(JL,5)*ZTT(JL,3)          *ZTT(JL,14)                            &
+       &      +PBTOP(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 234  CONTINUE
+!C
+ 235  CONTINUE
+!C
+      JK = KFLEV+1
+      IN=(JK-1)*NG1P1+1
+!C
+      DO 236 JL = 1, KDLON
+      ZCNTOP(JL)= PBTOP(JL,1)                                                        &
+       &   + PBTOP(JL,2)                                                             &
+       &   + PBTOP(JL,3)                                                             &
+       &   + PBTOP(JL,4)                                                             &
+       &   + PBTOP(JL,5)                                                             &
+       &   + PBTOP(JL,6)
+      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
+      PFLUC(JL,2,JK)=ZFD(JL)
+ 236  CONTINUE
+!C
+!C*         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
+!C                  ---------------------------------------
+!C
+ 240  CONTINUE
+!C
+!C
+!C*         2.4.1   INITIALIZATION
+!C                  --------------
+!C
+ 2410 CONTINUE
+!C
+      JLIM = KFLEV
+!C
+      IF (.NOT.LEVOIGT) THEN
+      DO 2412 JK = KFLEV,1,-1
+      IF(PPMB(1,JK).LT.10.0) THEN
+         JLIM=JK
+      ENDIF   
+ 2412 CONTINUE
+      ENDIF
+      KLIM=JLIM
+!C
+      IF (.NOT.LEVOIGT) THEN
+        DO 2414 JA=1,KTRAER
+        DO 2413 JL=1, KDLON
+        ZTT1(JL,JA)=1.0
+ 2413   CONTINUE
+ 2414   CONTINUE
+!C
+!C*         2.4.2   LOOP OVER LAYERS ABOVE 10 HPA
+!C                  -----------------------------
+!C
+ 2420   CONTINUE
+!C
+        DO 2427 JSTRA = KFLEV,JLIM,-1
+        JSTRU=(JSTRA-1)*NG1P1+1
+!C
+        DO 2423 JA=1,KUAER
+        DO 2422 JL=1, KDLON
+        ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
+ 2422   CONTINUE
+ 2423   CONTINUE
+!C
+!C
+        CALL LWTT_LMDAR4(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
+!C
+        DO 2424 JL = 1, KDLON
+        ZCTSTR =                                                                     &
+       &   (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))                                         &
+       &       *(ZTT1(JL,1)           *ZTT1(JL,10)                                   &
+       &       - ZTT (JL,1)           *ZTT (JL,10))                                  &
+       &  +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))                                         &
+       &       *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11)                                   &
+       &       - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11))                                  &
+       &  +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))                                         &
+       &       *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12)                                   &
+       &       - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12))                                  &
+       &  +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))                                         &
+       &       *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13)                                   &
+       &       - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13))                                  &
+       &  +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))                                         &
+       &       *(ZTT1(JL,3)           *ZTT1(JL,14)                                   &
+       &       - ZTT (JL,3)           *ZTT (JL,14))                                  &
+       &  +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))                                         &
+       &       *(ZTT1(JL,6)           *ZTT1(JL,15)                                   &
+       &       - ZTT (JL,6)           *ZTT (JL,15))
+        PCTS(JL,JSTRA)=ZCTSTR*0.5
+ 2424   CONTINUE
+        DO 2426 JA=1,KTRAER
+        DO 2425 JL=1, KDLON
+        ZTT1(JL,JA)=ZTT(JL,JA)
+ 2425   CONTINUE
+ 2426   CONTINUE
+ 2427   CONTINUE
+      ENDIF
+!C Mise a zero de securite pour PCTS en cas de LEVOIGT
+      IF(LEVOIGT)THEN
+        DO 2429 JSTRA = 1,KFLEV
+        DO 2428 JL = 1, KDLON
+          PCTS(JL,JSTRA)=0.
+ 2428   CONTINUE
+ 2429   CONTINUE
+      ENDIF
+!C
+!C
+!C*         2.5     EXCHANGE WITH LOWER LIMIT
+!C                  -------------------------
+!C
+ 250  CONTINUE
+!C
+      DO 251 JL = 1, KDLON
+      ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))                                   &
+       &               *PFLUC(JL,2,1)-PBINT(JL,1)
+ 251  CONTINUE
+!C
+      JK = 1
+      IN=(JK-1)*NG1P1+1
+!C
+      DO 252 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)                                                         &
+       & +PBSUR(JL,2)                                                                &
+       & +PBSUR(JL,3)                                                                &
+       & +PBSUR(JL,4)                                                                &
+       & +PBSUR(JL,5)                                                                &
+       & +PBSUR(JL,6)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 252  CONTINUE
+!C
+      DO 257 JK = 2 , KFLEV+1
+      IN=(JK-1)*NG1P1+1
+!C
+!C
+      DO 255 JA=1,KUAER
+      DO 254 JL=1, KDLON
+      ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
+ 254  CONTINUE
+ 255  CONTINUE
+!C
+!C
+      CALL LWTT_LMDAR4(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
+!C
+      DO 256 JL = 1, KDLON
+      ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1)          *ZTT(JL,10)                          &
+       &      +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)                            &
+       &      +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)                            &
+       &      +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)                            &
+       &      +PBSUR(JL,5)*ZTT(JL,3)          *ZTT(JL,14)                            &
+       &      +PBSUR(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
+      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
+      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
+      PFLUC(JL,1,JK)=ZFU(JL)
+ 256  CONTINUE
+!C
+!C
+ 257  CONTINUE
+!C
+!C
+!C
+!C*         2.7     CLEAR-SKY FLUXES
+!C                  ----------------
+!C
+ 270  CONTINUE
+!C
+      IF (.NOT.LEVOIGT) THEN
+      DO 271 JL = 1, KDLON
+      ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
+ 271  CONTINUE
+      DO 273 JK = JLIM+1,KFLEV+1
+      DO 272 JL = 1, KDLON
+      ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
+      PFLUC(JL,1,JK) = ZFN10(JL)
+      PFLUC(JL,2,JK) = 0.
+ 272  CONTINUE
+ 273  CONTINUE
+      ENDIF
+!C
+!C     ------------------------------------------------------------------
+!C
+      RETURN
+      END SUBROUTINE LWVB_LMDAR4
+
+      SUBROUTINE LWVD_LMDAR4(KUAER,KTRAER                                            &
+       &  , PABCU,PDBDT                                                              &
+       &  , PGA,PGB                                                                  &
+       &  , PCNTRB,PDISD,PDISU)
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+!C     CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C-----------------------------------------------------------------------
+!C* ARGUMENTS:
+!C
+      INTEGER KUAER,KTRAER
+!C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+!C
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
+      REAL(KIND=8) PDISD(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+      REAL(KIND=8) PDISU(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) ZGLAYD(KDLON)
+      REAL(KIND=8) ZGLAYU(KDLON)
+      REAL(KIND=8) ZTT(KDLON,NTRA)
+      REAL(KIND=8) ZTT1(KDLON,NTRA)
+      REAL(KIND=8) ZTT2(KDLON,NTRA)
+!C
+      INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
+      INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
+      INTEGER ind1, ind2, ind3, ind4, itt
+      REAL(KIND=8) zww, zdzxdg, zdzxmg
+!C
+!C*         1.    INITIALIZATION
+!C                --------------
+!C
+ 100  CONTINUE
+!C
+!C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+!C                  ------------------------------
+!C
+ 110  CONTINUE
+!C
+      DO 112 JK = 1, KFLEV+1
+      DO 111 JL = 1, KDLON
+      PDISD(JL,JK) = 0.
+      PDISU(JL,JK) = 0.
+  111 CONTINUE
+  112 CONTINUE
+!C
+!C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+!C                  ---------------------------------
+!C
+ 120  CONTINUE
+!C
+!C
+      DO 122 JA = 1, NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+  121 CONTINUE
+  122 CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.      VERTICAL INTEGRATION
+!C                  --------------------
+!C
+ 200  CONTINUE
+!C
+      IND1=0
+      IND3=0
+      IND4=1
+      IND2=1
+!C
+!C
+!C*         2.2     CONTRIBUTION FROM DISTANT LAYERS
+!C                  ---------------------------------
+!C
+ 220  CONTINUE
+!C
+!C
+!C*         2.2.1   DISTANT AND ABOVE LAYERS
+!C                  ------------------------
+!C
+ 2210 CONTINUE
+!C
+!C
+!C
+!C*         2.2.2   FIRST UPPER LEVEL
+!C                  -----------------
+!C
+ 2220 CONTINUE
+!C
+      DO 225 JK = 1 , KFLEV-1
+      IKP1=JK+1
+      IKN=(JK-1)*NG1P1+1
+      IKD1= JK  *NG1P1+1
+!C
+      CALL LWTTM_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK)                                 &
+       &          , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
+!C
+!C
+!C
+!C*         2.2.3   HIGHER UP
+!C                  ---------
+!C
+ 2230 CONTINUE
+!C
+      ITT=1
+      DO 224 JKJ=IKP1,KFLEV
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IKJP1=JKJ+1
+      IKD2= JKJ  *NG1P1+1
+!C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)                             &
+       &             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
+      ELSE
+         CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)                             &
+       &             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
+      ENDIF
+!C
+      DO 2235 JA = 1, KTRAER
+      DO 2234 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2234 CONTINUE
+ 2235 CONTINUE
+!C
+      DO 2236 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)                             &
+       &   +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)                           &
+       &   +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)                           &
+       &   +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)                           &
+       &   +PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)                           &
+       &   +PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZWW
+      ZDZXDG=ZGLAYD(JL)
+      PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
+      PCNTRB(JL,JK,IKJP1)=ZDZXDG
+ 2236 CONTINUE
+!C
+!C
+ 224  CONTINUE
+ 225  CONTINUE
+!C
+!C
+!C*         2.2.4   DISTANT AND BELOW LAYERS
+!C                  ------------------------
+!C
+ 2240 CONTINUE
+!C
+!C
+!C
+!C*         2.2.5   FIRST LOWER LEVEL
+!C                  -----------------
+!C
+ 2250 CONTINUE
+!C
+      DO 228 JK=3,KFLEV+1
+      IKN=(JK-1)*NG1P1+1
+      IKM1=JK-1
+      IKJ=JK-2
+      IKU1= IKJ  *NG1P1+1
+!C
+!C
+      CALL LWTTM_LMDAR4(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)                                &
+       &          , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
+!C
+!C
+!C
+!C*         2.2.6   DOWN BELOW
+!C                  ----------
+!C
+ 2260 CONTINUE
+!C
+      ITT=1
+      DO 227 JLK=1,IKJ
+      IF(ITT.EQ.1) THEN
+         ITT=2
+      ELSE
+         ITT=1
+      ENDIF
+      IJKL=IKM1-JLK
+      IKU2=(IJKL-1)*NG1P1+1
+!C
+!C
+      IF(ITT.EQ.1) THEN
+         CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)                           &
+       &             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
+      ELSE
+         CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)                           &
+       &             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
+      ENDIF
+!C
+      DO 2265 JA = 1, KTRAER
+      DO 2264 JL = 1, KDLON
+      ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
+ 2264 CONTINUE
+ 2265 CONTINUE
+!C
+      DO 2266 JL = 1, KDLON
+      ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)                            &
+       &   +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)                          &
+       &   +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)                          &
+       &   +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)                          &
+       &   +PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)                          &
+       &   +PDBDT(JL,6,IJKL)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZWW
+      ZDZXMG=ZGLAYU(JL)
+      PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
+      PCNTRB(JL,JK,IJKL)=ZDZXMG
+ 2266 CONTINUE
+!C
+!C
+ 227  CONTINUE
+ 228  CONTINUE
+!C
+      RETURN
+      END SUBROUTINE LWVD_LMDAR4
+
+      SUBROUTINE LWVN_LMDAR4(KUAER,KTRAER                                            &
+       &  , PABCU,PDBSL,PGA,PGB                                                      &
+       &  , PADJD,PADJU,PCNTRB,PDBDT)
+       USE dimphy
+      USE radiation_AR4_param, only : WG1
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
+!C           TO GIVE LONGWAVE FLUXES OR RADIANCES
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
+!C     CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 89-07-14
+!C-----------------------------------------------------------------------
+!C
+!C* ARGUMENTS:
+!C
+      INTEGER KUAER,KTRAER
+!C
+      REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
+      REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
+      REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
+!C
+      REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
+      REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
+      REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) !  LAYER PLANCK FUNCTION GRADIENT
+!C
+!C* LOCAL ARRAYS:
+!C
+      REAL(KIND=8) ZGLAYD(KDLON)
+      REAL(KIND=8) ZGLAYU(KDLON)
+      REAL(KIND=8) ZTT(KDLON,NTRA)
+      REAL(KIND=8) ZTT1(KDLON,NTRA)
+      REAL(KIND=8) ZTT2(KDLON,NTRA)
+      REAL(KIND=8) ZUU(KDLON,NUA)
+!C
+      INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
+      INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
+      REAL(KIND=8) zwtr
+!c
+
+!C-----------------------------------------------------------------------
+!C
+!C*         1.    INITIALIZATION
+!C                --------------
+!C
+ 100  CONTINUE
+!C
+!C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
+!C                  ------------------------------
+!C
+ 110  CONTINUE
+!C
+      DO 112 JK = 1 , KFLEV+1
+      DO 111 JL = 1, KDLON
+      PADJD(JL,JK) = 0.
+      PADJU(JL,JK) = 0.
+ 111  CONTINUE
+ 112  CONTINUE
+!C
+!C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
+!C                  ---------------------------------
+!C
+ 120  CONTINUE
+!C
+      DO 122 JA = 1 , NTRA
+      DO 121 JL = 1, KDLON
+      ZTT (JL,JA) = 1.0
+      ZTT1(JL,JA) = 1.0
+      ZTT2(JL,JA) = 1.0
+ 121  CONTINUE
+ 122  CONTINUE
+!C
+      DO 124 JA = 1 , NUA
+      DO 123 JL = 1, KDLON
+      ZUU(JL,JA) = 0.
+ 123  CONTINUE
+ 124  CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.      VERTICAL INTEGRATION
+!C                  --------------------
+!C
+ 200  CONTINUE
+!C
+!C
+!C*         2.1     CONTRIBUTION FROM ADJACENT LAYERS
+!C                  ---------------------------------
+!C
+ 210  CONTINUE
+!C
+      DO 215 JK = 1 , KFLEV
+!C
+!C*         2.1.1   DOWNWARD LAYERS
+!C                  ---------------
+!C
+ 2110 CONTINUE
+!C
+      IM12 = 2 * (JK - 1)
+      IND = (JK - 1) * NG1P1 + 1
+      IXD = IND
+      INU = JK * NG1P1 + 1
+      IXU = IND
+!C
+      DO 2111 JL = 1, KDLON
+      ZGLAYD(JL) = 0.
+      ZGLAYU(JL) = 0.
+ 2111 CONTINUE
+!C
+      DO 213 JG = 1 , NG1
+      IBS = IM12 + JG
+      IDD = IXD + JG
+      DO 2113 JA = 1 , KUAER
+      DO 2112 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
+ 2112 CONTINUE
+ 2113 CONTINUE
+!C
+!C
+      CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+!C
+      DO 2114 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)                            &
+       &    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)                          &
+       &    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)                          &
+       &    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)                          &
+       &    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)                          &
+       &    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
+ 2114 CONTINUE
+!C
+!C*         2.1.2   DOWNWARD LAYERS
+!C                  ---------------
+!C
+ 2120 CONTINUE
+!C
+      IMU = IXU + JG
+      DO 2122 JA = 1 , KUAER
+      DO 2121 JL = 1, KDLON
+      ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
+ 2121 CONTINUE
+ 2122 CONTINUE
+!C
+!C
+      CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
+!C
+      DO 2123 JL = 1, KDLON
+      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)                            &
+       &    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)                          &
+       &    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)                          &
+       &    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)                          &
+       &    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)                          &
+       &    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
+      ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
+ 2123 CONTINUE
+!C
+ 213  CONTINUE
+!C
+      DO 214 JL = 1, KDLON
+      PADJD(JL,JK) = ZGLAYD(JL)
+      PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
+      PADJU(JL,JK+1) = ZGLAYU(JL)
+      PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
+      PCNTRB(JL,JK  ,JK) = 0.0
+ 214  CONTINUE
+!C
+ 215  CONTINUE
+!C
+      DO 218 JK = 1 , KFLEV
+      JK2 = 2 * JK
+      JK1 = JK2 - 1
+      DO 217 JNU = 1 , Ninter
+      DO 216 JL = 1, KDLON
+      PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
+ 216  CONTINUE
+ 217  CONTINUE
+ 218  CONTINUE
+!C
+      RETURN
+!C
+      END SUBROUTINE LWVN_LMDAR4
+
+      SUBROUTINE LWTT_LMDAR4(PGA,PGB,PUU, PTT)
+       USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+!C
+!C-----------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+!C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+!C     INTERVALS.
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+!C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+!C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+!C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+!C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 88-12-15
+!C
+!C-----------------------------------------------------------------------
+      REAL(KIND=8) O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL(KIND=8) RPIALF0
+      PARAMETER (RPIALF0=2.0)
+!C
+!C* ARGUMENTS:
+!C
+      REAL(KIND=8) PUU(KDLON,NUA)
+      REAL(KIND=8) PTT(KDLON,NTRA)
+      REAL(KIND=8) PGA(KDLON,8,2)
+      REAL(KIND=8) PGB(KDLON,8,2)
+!C
+!C* LOCAL VARIABLES:
+!C
+      REAL(KIND=8) zz, zxd, zxn
+      REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
+      REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
+      REAL(KIND=8) zx, zy, zsq1, zsq2, zvxy, zuxy
+      REAL(KIND=8) zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
+      REAL(KIND=8) zsqn21, zodn21, zsqh42, zodh42
+      REAL(KIND=8) zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
+      REAL(KIND=8) zuu11, zuu12, za11, za12
+      INTEGER jl, ja
+!C     ------------------------------------------------------------------
+!C
+!C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+!C                 -----------------------------------------------
+!C
+ 100  CONTINUE
+!C
+!C
+!cdir collapse
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU(JL,JA))
+!c     ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
+!c     ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
+!c     PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+!C                 ---------------------------------------------------
+!C
+ 200  CONTINUE
+!C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+!C
+!C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+!C
+      ZPU   = 0.002 * PUU(JL,10)
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   =  PUU(JL,11)
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+!C
+!C-  OZONE ABSORPTION
+!C
+      ZX = PUU(JL,12)
+      ZY = PUU(JL,13)
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = PUU(JL,17) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+!C
+!C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+!C
+!C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+!c     NEXOTIC=1
+!c     IF (NEXOTIC.EQ.1) THEN
+      ZXCH4 = PUU(JL,19)
+      ZYCH4 = PUU(JL,20)
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+!C
+!C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZXN2O = PUU(JL,21)
+      ZYN2O = PUU(JL,22)
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+!C
+!C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+!C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+!C
+!C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+!C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+!C
+!C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZA11 = 2. * PUU(JL,23) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+!C
+!C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZA12 = 2. * PUU(JL,24) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+!C
+      ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10
+      ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - PUU(JL,14) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 )
+ 201  CONTINUE
+!C
+      RETURN
+      END SUBROUTINE LWTT_LMDAR4
+
+      SUBROUTINE LWTTM_LMDAR4(PGA,PGB,PUU1,PUU2, PTT)
+      USE dimphy
+      IMPLICIT none
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!cym#include "raddim.h"
+#include "raddimlw.h"
+!C
+!C     ------------------------------------------------------------------
+!C     PURPOSE.
+!C     --------
+!C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
+!C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
+!C     INTERVALS.
+!C
+!C     METHOD.
+!C     -------
+!C
+!C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
+!C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
+!C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
+!C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
+!C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
+!C
+!C     REFERENCE.
+!C     ----------
+!C
+!C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
+!C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
+!C
+!C     AUTHOR.
+!C     -------
+!C        JEAN-JACQUES MORCRETTE  *ECMWF*
+!C
+!C     MODIFICATIONS.
+!C     --------------
+!C        ORIGINAL : 88-12-15
+!C
+!C-----------------------------------------------------------------------
+      REAL(KIND=8) O1H, O2H
+      PARAMETER (O1H=2230.)
+      PARAMETER (O2H=100.)
+      REAL(KIND=8) RPIALF0
+      PARAMETER (RPIALF0=2.0)
+!C
+!C* ARGUMENTS:
+!C
+      REAL(KIND=8) PGA(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PGB(KDLON,8,2) ! PADE APPROXIMANTS
+      REAL(KIND=8) PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
+      REAL(KIND=8) PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
+      REAL(KIND=8) PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS
+!C
+!C* LOCAL VARIABLES:
+!C
+      INTEGER ja, jl
+      REAL(KIND=8) zz, zxd, zxn
+      REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
+      REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
+      REAL(KIND=8) zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
+      REAL(KIND=8) zxch4, zych4, zsqh41, zodh41
+      REAL(KIND=8) zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
+      REAL(KIND=8) zsqn22, zodn22, za11, zttf11, za12, zttf12
+      REAL(KIND=8) zuu11, zuu12
+!C     ------------------------------------------------------------------
+!C
+!C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
+!C                 -----------------------------------------------
+!C
+ 100  CONTINUE
+!C
+!C
+
+!CDIR ON_ADB(PUU1)
+!CDIR ON_ADB(PUU2)
+!CDIR COLLAPSE
+      DO 130 JA = 1 , 8
+      DO 120 JL = 1, KDLON
+      ZZ      =SQRT(PUU1(JL,JA) - PUU2(JL,JA))
+      ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )
+      ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )
+      PTT(JL,JA)=ZXN      /ZXD
+  120 CONTINUE
+  130 CONTINUE
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
+!C                 ---------------------------------------------------
+!C
+ 200  CONTINUE
+!C
+      DO 201 JL = 1, KDLON
+      PTT(JL, 9) = PTT(JL, 8)
+!C
+!C-  CONTINUUM ABSORPTION: E- AND P-TYPE
+!C
+      ZPU   = 0.002 * (PUU1(JL,10) - PUU2(JL,10))
+      ZPU10 = 112. * ZPU
+      ZPU11 = 6.25 * ZPU
+      ZPU12 = 5.00 * ZPU
+      ZPU13 = 80.0 * ZPU
+      ZEU   = (PUU1(JL,11) - PUU2(JL,11))
+      ZEU10 =  12. * ZEU
+      ZEU11 = 6.25 * ZEU
+      ZEU12 = 5.00 * ZEU
+      ZEU13 = 80.0 * ZEU
+!C
+!C-  OZONE ABSORPTION
+!C
+      ZX = (PUU1(JL,12) - PUU2(JL,12))
+      ZY = (PUU1(JL,13) - PUU2(JL,13))
+      ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
+      ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
+      ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
+      ZVXY = RPIALF0 * ZY / (2. * ZX)
+      ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12
+      ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
+      ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
+!C
+!C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
+!C
+!C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))
+      ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
+      ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
+      ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
+      ZODH41 = ZVXY * ZSQH41
+!C
+!C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZXN2O = (PUU1(JL,21) - PUU2(JL,21))
+      ZYN2O = (PUU1(JL,22) - PUU2(JL,22))
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
+      ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
+      ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
+      ZODN21 = ZVXY * ZSQN21
+!C
+!C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
+!C
+      ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
+      ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
+      ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
+      ZODH42 = ZVXY * ZSQH42
+!C
+!C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
+!C
+      ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
+      ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
+      ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
+      ZODN22 = ZVXY * ZSQN22
+!C
+!C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05
+      ZTTF11 = 1. - ZA11 * 0.003225
+!C
+!C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
+!C
+      ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05
+      ZTTF12 = 1. - ZA12 * 0.003225
+!C
+      ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10
+      ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -                        &
+       &         ZODH41 - ZODN21
+      PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )
+      PTT(JL,11) = EXP( ZUU11 )
+      PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
+      PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
+      PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
+      PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )
+ 201  CONTINUE
+!C
+      RETURN
+      END SUBROUTINE LWTTM_LMDAR4
+
+END MODULE radiation_AR4_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/radiation_ar4_param.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/radiation_ar4_param.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/radiation_ar4_param.F90	(revision 17)
@@ -0,0 +1,241 @@
+MODULE radiation_ar4_param
+
+ REAL*8, parameter :: ZPDH2O = 0.8
+ REAL*8, parameter :: ZPDUMG = 0.75
+ REAL*8, parameter :: ZPRH2O = 30000.0
+ REAL*8, parameter :: ZPRUMG = 30000.0
+ REAL*8, parameter :: RTDH2O = 0.40
+ REAL*8, parameter :: RTDUMG = 0.375
+ REAL*8, parameter :: RTH2O = 240.0
+ REAL*8, parameter :: RTUMG = 240.0
+
+ REAL*8, dimension(2), parameter :: WG1 = (/1.0, 1.0/)
+ REAL*8, dimension(11), parameter :: TINTP = (/ 187.5, 200., 212.5, 225., 237.5, 250., 262.5, 275., 287.5, 300., 312.5 /)
+
+ real*8, dimension(11,16,3), parameter :: GA = reshape ( (/                                                                &
+ 0.63499072E-02, 0.65566348E-02, 0.67849730E-02, 0.70481947E-02, 0.73585943E-02, 0.77242818E-02, 0.81472693E-02, 0.86227527E-02,&
+ 0.91396814E-02, 0.96825438E-02, 0.10233955E-01, 0.77266491E-02, 0.81323287E-02, 0.86507620E-02, 0.92776391E-02, 0.99806312E-02,&
+ 0.10709803E-01, 0.11414739E-01, 0.12058772E-01, 0.12623992E-01, 0.13108146E-01, 0.13518390E-01, 0.11644593E+01, 0.11747203E+01,&
+ 0.11837872E+01, 0.11918561E+01, 0.11990757E+01, 0.12055643E+01, 0.12114186E+01, 0.12167192E+01, 0.12215344E+01, 0.12259226E+01,&
+ 0.12299344E+01, 0.12006968E+01, 0.12108196E+01, 0.12196717E+01, 0.12274493E+01, 0.12343189E+01, 0.12404147E+01, 0.12458431E+01,&
+ 0.12506907E+01, 0.12550299E+01, 0.12589256E+01, 0.12624402E+01, 0.15750172E+00, 0.16174076E+00, 0.16548628E+00, 0.16881124E+00,&
+ 0.17177839E+00, 0.17443933E+00, 0.17683622E+00, 0.17900375E+00, 0.18097099E+00, 0.18276283E+00, 0.18440117E+00, 0.17770551E+00,&
+ 0.18176757E+00, 0.18527967E+00, 0.18833348E+00, 0.19100108E+00, 0.19334122E+00, 0.19540288E+00, 0.19722732E+00, 0.19884918E+00,&
+ 0.20029696E+00, 0.20159300E+00, 0.10192131E+02, 0.97258602E+01, 0.92992890E+01, 0.89154021E+01, 0.85730084E+01, 0.82685838E+01,&
+ 0.79978921E+01, 0.77568055E+01, 0.75416266E+01, 0.73491694E+01, 0.71767400E+01, 0.92439050E+01, 0.87567422E+01, 0.83270144E+01,&
+ 0.79528337E+01, 0.76286839E+01, 0.73477879E+01, 0.71035818E+01, 0.68903312E+01, 0.67032875E+01, 0.65386461E+01, 0.63934377E+01,&
+ 0.24870635E+02, 0.24725591E+02, 0.24600320E+02, 0.24487300E+02, 0.24384935E+02, 0.24292341E+02, 0.24208572E+02, 0.24132642E+02,&
+ 0.24063614E+02, 0.24000649E+02, 0.23943021E+02, 0.24586283E+02, 0.24441465E+02, 0.24311657E+02, 0.24196167E+02, 0.24093406E+02,&
+ 0.24001597E+02, 0.23919098E+02, 0.23844511E+02, 0.23776708E+02, 0.23714816E+02, 0.23658197E+02, 0.11990218E+02, 0.10904073E+02,&
+ 0.89126838E+01, 0.85622405E+01, 0.94892164E+01, 0.13580937E+02,-0.32050918E+03,-0.37133165E+01, 0.18890836E+00, 0.14209226E+01,&
+ 0.19817679E+01, 0.79709806E+01, 0.75400737E+01, 0.81804377E+01, 0.10564339E+02, 0.46896789E+02,-0.30926524E+01, 0.85742941E+00,&
+ 0.19164038E+01, 0.23513199E+01, 0.25566644E+01, 0.26555181E+01, 0.87668459E-01, 0.83754276E-01, 0.80460283E-01, 0.77659686E-01,&
+ 0.75257056E-01, 0.73179175E-01, 0.71369063E-01, 0.69781812E-01, 0.68381606E-01, 0.67139539E-01, 0.66032012E-01, 0.74878820E-01,&
+ 0.71650966E-01, 0.68979615E-01, 0.66745345E-01, 0.64857571E-01, 0.63248495E-01, 0.61866970E-01, 0.60673632E-01, 0.59637277E-01,&
+ 0.58732178E-01, 0.57936092E-01, 0.13230067E+02, 0.13213564E+02, 0.13209140E+02, 0.13213894E+02, 0.13225963E+02, 0.13243806E+02,&
+ 0.13266104E+02, 0.13291782E+02, 0.13319961E+02, 0.13349927E+02, 0.13381108E+02, 0.13183816E+02, 0.13189991E+02, 0.13209485E+02,&
+ 0.13238789E+02, 0.13275017E+02, 0.13316096E+02, 0.13360555E+02, 0.13407324E+02, 0.13455544E+02, 0.13504450E+02, 0.13553282E+02,&
+-0.99506586E-03,-0.10184169E-02,-0.10404730E-02,-0.10621792E-02,-0.10847662E-02,-0.11094726E-02,-0.11372949E-02,-0.11687683E-02,&
+-0.12038314E-02,-0.12418367E-02,-0.12817135E-02,-0.11661515E-02,-0.11886130E-02,-0.12139929E-02,-0.12445811E-02,-0.12807672E-02,&
+-0.13208251E-02,-0.13619034E-02,-0.14014165E-02,-0.14378639E-02,-0.14708488E-02,-0.15006791E-02, 0.41243390E+00, 0.43407282E+00,&
+ 0.45331413E+00, 0.47048604E+00, 0.48586286E+00, 0.49968044E+00, 0.51214132E+00, 0.52341830E+00, 0.53365803E+00, 0.54298448E+00,&
+ 0.55150227E+00, 0.48318936E+00, 0.50501827E+00, 0.52409502E+00, 0.54085277E+00, 0.55565422E+00, 0.56878618E+00, 0.58047395E+00,&
+ 0.59089894E+00, 0.60021475E+00, 0.60856112E+00, 0.61607594E+00,-0.22159303E-01,-0.22748917E-01,-0.23269898E-01,-0.23732392E-01,&
+-0.24145123E-01,-0.24515269E-01,-0.24848690E-01,-0.25150210E-01,-0.25423873E-01,-0.25673139E-01,-0.25901055E-01,-0.24972399E-01,&
+-0.25537247E-01,-0.26025624E-01,-0.26450280E-01,-0.26821236E-01,-0.27146657E-01,-0.27433354E-01,-0.27687065E-01,-0.27912608E-01,&
+-0.28113944E-01,-0.28294180E-01, 0.80737799E+01, 0.79171158E+01, 0.77609605E+01, 0.76087371E+01, 0.74627112E+01, 0.73239981E+01,&
+ 0.71929934E+01, 0.70697065E+01, 0.69539626E+01, 0.68455144E+01, 0.67441020E+01, 0.77425778E+01, 0.75443460E+01, 0.73526151E+01,&
+ 0.71711188E+01, 0.70015571E+01, 0.68442532E+01, 0.66987996E+01, 0.65644820E+01, 0.64405267E+01, 0.63262376E+01, 0.62210701E+01,&
+ 0.10542131E+02, 0.10515895E+02, 0.10492949E+02, 0.10472049E+02, 0.10452961E+02, 0.10435562E+02, 0.10419710E+02, 0.10405247E+02,&
+ 0.10392022E+02, 0.10379892E+02, 0.10368736E+02, 0.10490353E+02, 0.10463512E+02, 0.10439183E+02, 0.10417324E+02, 0.10397704E+02,&
+ 0.10380038E+02, 0.10364052E+02, 0.10349509E+02, 0.10336215E+02, 0.10324018E+02, 0.10312808E+02,-0.12823142E+01,-0.10571588E+01,&
+-0.74864953E+00,-0.58705980E+00,-0.49305772E+00,-0.51461431E+00, 0.12373350E+02, 0.44809588E+00, 0.46548918E+00, 0.59121475E+00,&
+ 0.74676119E+00,-0.74805226E+00,-0.56252739E+00,-0.46188072E+00,-0.40712065E+00,-0.15295996E+01, 0.43555255E+00, 0.50380874E+00,&
+ 0.68537352E+00, 0.89437630E+00, 0.11127003E+01, 0.13329782E+01, 0.13845511E+01, 0.13187042E+01, 0.12644396E+01, 0.12191543E+01,&
+ 0.11809511E+01, 0.11484154E+01, 0.11204723E+01, 0.10962918E+01, 0.10752229E+01, 0.10567474E+01, 0.10404465E+01, 0.11718758E+01,&
+ 0.11216131E+01, 0.10809473E+01, 0.10476396E+01, 0.10200373E+01, 0.99692726E+00, 0.97740923E+00, 0.96080188E+00, 0.94657562E+00,&
+ 0.93430511E+00, 0.92363528E+00, 0.22042132E+02, 0.22107298E+02, 0.22180915E+02, 0.22259478E+02, 0.22341039E+02, 0.22424247E+02,&
+ 0.22508089E+02, 0.22591771E+02, 0.22674661E+02, 0.22756246E+02, 0.22836093E+02, 0.22169501E+02, 0.22270075E+02, 0.22379193E+02,&
+ 0.22492992E+02, 0.22608508E+02, 0.22723843E+02, 0.22837837E+02, 0.22949751E+02, 0.23059032E+02, 0.23165146E+02, 0.23267456E+02,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00,&
+ 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00, 0.00000000E+00 /) &
+ , (/ 11,16,3 /) )
+
+ real*8, dimension(11,16,3), parameter :: GB = reshape ( (/                                                                     &
+ 0.63499072E-02, 0.65566348E-02, 0.67849730E-02, 0.70481947E-02, 0.73585943E-02, 0.77242818E-02, 0.81472693E-02, 0.86227527E-02,&
+ 0.91396814E-02, 0.96825438E-02, 0.10233955E-01, 0.77266491E-02, 0.81323287E-02, 0.86507620E-02, 0.92776391E-02, 0.99806312E-02,&
+ 0.10709803E-01, 0.11414739E-01, 0.12058772E-01, 0.12623992E-01, 0.13108146E-01, 0.13518390E-01, 0.11644593E+01, 0.11747203E+01,&
+ 0.11837872E+01, 0.11918561E+01, 0.11990757E+01, 0.12055643E+01, 0.12114186E+01, 0.12167192E+01, 0.12215344E+01, 0.12259226E+01,&
+ 0.12299344E+01, 0.12006968E+01, 0.12108196E+01, 0.12196717E+01, 0.12274493E+01, 0.12343189E+01, 0.12404147E+01, 0.12458431E+01,&
+ 0.12506907E+01, 0.12550299E+01, 0.12589256E+01, 0.12624402E+01, 0.15750172E+00, 0.16174076E+00, 0.16548628E+00, 0.16881124E+00,&
+ 0.17177839E+00, 0.17443933E+00, 0.17683622E+00, 0.17900375E+00, 0.18097099E+00, 0.18276283E+00, 0.18440117E+00, 0.17770551E+00,&
+ 0.18176757E+00, 0.18527967E+00, 0.18833348E+00, 0.19100108E+00, 0.19334122E+00, 0.19540288E+00, 0.19722732E+00, 0.19884918E+00,&
+ 0.20029696E+00, 0.20159300E+00, 0.10192131E+02, 0.97258602E+01, 0.92992890E+01, 0.89154021E+01, 0.85730084E+01, 0.82685838E+01,&
+ 0.79978921E+01, 0.77568055E+01, 0.75416266E+01, 0.73491694E+01, 0.71767400E+01, 0.92439050E+01, 0.87567422E+01, 0.83270144E+01,&
+ 0.79528337E+01, 0.76286839E+01, 0.73477879E+01, 0.71035818E+01, 0.68903312E+01, 0.67032875E+01, 0.65386461E+01, 0.63934377E+01,&
+ 0.24870635E+02, 0.24725591E+02, 0.24600320E+02, 0.24487300E+02, 0.24384935E+02, 0.24292341E+02, 0.24208572E+02, 0.24132642E+02,&
+ 0.24063614E+02, 0.24000649E+02, 0.23943021E+02, 0.24586283E+02, 0.24441465E+02, 0.24311657E+02, 0.24196167E+02, 0.24093406E+02,&
+ 0.24001597E+02, 0.23919098E+02, 0.23844511E+02, 0.23776708E+02, 0.23714816E+02, 0.23658197E+02, 0.11990218E+02, 0.10904073E+02,&
+ 0.89126838E+01, 0.85622405E+01, 0.94892164E+01, 0.13580937E+02,-0.32050918E+03,-0.37133165E+01, 0.18890836E+00, 0.14209226E+01,&
+ 0.19817679E+01, 0.79709806E+01, 0.75400737E+01, 0.81804377E+01, 0.10564339E+02, 0.46896789E+02,-0.30926524E+01, 0.85742941E+00,&
+ 0.19164038E+01, 0.23513199E+01, 0.25566644E+01, 0.26555181E+01, 0.87668459E-01, 0.83754276E-01, 0.80460283E-01, 0.77659686E-01,&
+ 0.75257056E-01, 0.73179175E-01, 0.71369063E-01, 0.69781812E-01, 0.68381606E-01, 0.67139539E-01, 0.66032012E-01, 0.74878820E-01,&
+ 0.71650966E-01, 0.68979615E-01, 0.66745345E-01, 0.64857571E-01, 0.63248495E-01, 0.61866970E-01, 0.60673632E-01, 0.59637277E-01,&
+ 0.58732178E-01, 0.57936092E-01, 0.13230067E+02, 0.13213564E+02, 0.13209140E+02, 0.13213894E+02, 0.13225963E+02, 0.13243806E+02,&
+ 0.13266104E+02, 0.13291782E+02, 0.13319961E+02, 0.13349927E+02, 0.13381108E+02, 0.13183816E+02, 0.13189991E+02, 0.13209485E+02,&
+ 0.13238789E+02, 0.13275017E+02, 0.13316096E+02, 0.13360555E+02, 0.13407324E+02, 0.13455544E+02, 0.13504450E+02, 0.13553282E+02,&
+ 0.97222852E-01, 0.98862238E-01, 0.10061504E+00, 0.10256222E+00, 0.10475952E+00, 0.10720986E+00, 0.10985370E+00, 0.11257633E+00,&
+ 0.11522980E+00, 0.11766343E+00, 0.11975320E+00, 0.10681591E+00, 0.10921298E+00, 0.11198225E+00, 0.11487826E+00, 0.11751113E+00,&
+ 0.11951535E+00, 0.12069945E+00, 0.12108524E+00, 0.12084229E+00, 0.12019005E+00, 0.11932684E+00, 0.10346097E+01, 0.10433655E+01,&
+ 0.10511933E+01, 0.10582150E+01, 0.10645317E+01, 0.10702313E+01, 0.10753907E+01, 0.10800762E+01, 0.10843446E+01, 0.10882439E+01,&
+ 0.10918144E+01, 0.10626130E+01, 0.10716026E+01, 0.10795108E+01, 0.10865006E+01, 0.10927103E+01, 0.10982489E+01, 0.11032019E+01,&
+ 0.11076379E+01, 0.11116160E+01, 0.11151910E+01, 0.11184188E+01, 0.38103212E+00, 0.38913800E+00, 0.39613651E+00, 0.40222421E+00,&
+ 0.40756010E+00, 0.41226954E+00, 0.41645142E+00, 0.42018474E+00, 0.42353379E+00, 0.42655211E+00, 0.42928533E+00, 0.41646579E+00,&
+ 0.42345095E+00, 0.42937476E+00, 0.43444062E+00, 0.43880316E+00, 0.44258354E+00, 0.44587882E+00, 0.44876776E+00, 0.45131451E+00,&
+ 0.45357095E+00, 0.45557797E+00, 0.82623280E+01, 0.81072291E+01, 0.79523834E+01, 0.78012527E+01, 0.76561458E+01, 0.75182174E+01,&
+ 0.73878952E+01, 0.72652133E+01, 0.71500151E+01, 0.70420667E+01, 0.69411177E+01, 0.79342219E+01, 0.77373458E+01, 0.75467334E+01,&
+ 0.73661786E+01, 0.71974319E+01, 0.70408543E+01, 0.68960649E+01, 0.67623672E+01, 0.66389989E+01, 0.65252707E+01, 0.64206412E+01,&
+ 0.10656640E+02, 0.10630910E+02, 0.10608399E+02, 0.10587891E+02, 0.10569156E+02, 0.10552075E+02, 0.10536510E+02, 0.10522307E+02,&
+ 0.10509317E+02, 0.10497402E+02, 0.10486443E+02, 0.10605856E+02, 0.10579514E+02, 0.10555632E+02, 0.10534169E+02, 0.10514900E+02,&
+ 0.10497547E+02, 0.10481842E+02, 0.10467553E+02, 0.10454488E+02, 0.10442501E+02, 0.10431483E+02, 0.26681588E+02, 0.24728346E+02,&
+ 0.20551342E+02, 0.19955244E+02, 0.22227100E+02, 0.31770288E+02,-0.74061287E+03,-0.81329826E+01, 0.90279822E+00, 0.37532746E+01,&
+ 0.50437916E+01, 0.18377807E+02, 0.17643148E+02, 0.19296161E+02, 0.24951120E+02, 0.10957372E+03,-0.67432659E+01, 0.24550746E+01,&
+ 0.49089917E+01, 0.59008712E+01, 0.63532616E+01, 0.65558627E+01, 0.23203798E+01, 0.22288925E+01, 0.21515593E+01, 0.20855896E+01,&
+ 0.20288489E+01, 0.19796791E+01, 0.19367778E+01, 0.18991112E+01, 0.18658501E+01, 0.18363226E+01, 0.18099779E+01, 0.20206726E+01,&
+ 0.19441824E+01, 0.18807257E+01, 0.18275618E+01, 0.17825910E+01, 0.17442308E+01, 0.17112809E+01, 0.16828137E+01, 0.16580908E+01,&
+ 0.16365014E+01, 0.16175164E+01, 0.22051750E+02, 0.22116850E+02, 0.22190410E+02, 0.22268925E+02, 0.22350445E+02, 0.22433617E+02,&
+ 0.22517429E+02, 0.22601086E+02, 0.22683956E+02, 0.22765522E+02, 0.22845354E+02, 0.22178972E+02, 0.22279484E+02, 0.22388551E+02,&
+ 0.22502309E+02, 0.22617792E+02, 0.22733099E+02, 0.22847071E+02, 0.22958967E+02, 0.23068234E+02, 0.23174336E+02, 0.23276638E+02,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01,&
+ 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01, 0.10000000E+01 /) &
+  , (/ 11,16,3 /) )
+
+      real*8, dimension(6,6), parameter :: XP = reshape ( (/  &
+      0.46430621E+02,  0.12928299E+03,  0.20732648E+03,  0.31398411E+03,  0.18373177E+03, -0.11412303E+03, &
+      0.73604774E+02,  0.27887914E+03,  0.27076947E+03, -0.57322111E+02, -0.64742459E+02,  0.87238280E+02, &
+      0.37050866E+02,  0.20498759E+03,  0.37558029E+03,  0.17401171E+03, -0.13350302E+03, -0.37651795E+02, &
+      0.14930141E+02,  0.89161160E+02,  0.17793062E+03,  0.93433860E+02, -0.70646020E+02, -0.26373150E+02, &
+      0.40386780E+02,  0.10855270E+03,  0.50755010E+02, -0.31496190E+02,  0.12791300E+00,  0.18017770E+01, &
+      0.90811926E+01,  0.75073923E+02,  0.24654438E+03,  0.39332612E+03,  0.29385281E+03,  0.89107921E+02 /) , (/ 6,6 /) )
+
+! If running with Reporbus type_trac=repr, values of RSUN might be overritten in radiation_AR4
+      REAL*8, dimension(2) :: RSUN = (/ 0.441676 , 0.558324 /)
+      REAL*8, dimension(2,6), parameter :: RRAY = reshape ( &
+         (/ .428937E-01, .697200E-02,&
+            .890743E+00, .173297E-01,&
+           -.288555E+01,-.850903E-01,&
+            .522744E+01, .248261E+00,&
+           -.469173E+01,-.302031E+00,&
+            .161645E+01, .129662E+00 /) , (/2,6/) )
+
+      REAL*8, dimension(2,5), parameter :: TAUA = reshape ( &
+      (/ 0.730719, 0.730719, 0.912819, 0.912819, 0.725059, &
+         0.725059, 0.745405, 0.745405, 0.682188, 0.682188 /),(/2,5/) )
+      REAL*8, dimension(2,5), parameter :: RPIZA = reshape ( &
+      (/ 0.872212, 0.872212, 0.982545, 0.982545, 0.623143,   &
+         0.623143, 0.944887, 0.944887, 0.997975, 0.997975 /),(/2,5/) )
+      REAL*8, dimension(2,5), parameter :: RCGA = reshape (  &
+      (/ 0.647596, 0.647596, 0.739002, 0.739002, 0.580845,   &
+         0.580845, 0.662657, 0.662657, 0.624246, 0.624246 /),(/2,5/) )
+
+      REAL*8, dimension(2,3,7), parameter :: APAD = reshape (  &
+          (/ 0.912418292E+05, 0.376655383E-08, 0.000000000E-00,&
+             0.739646016E-08, 0.925887084E-04, 0.410177786E+03,&
+             0.723613782E+05, 0.978576773E-04, 0.000000000E-00,&
+             0.131849595E-03, 0.129353723E-01, 0.672595424E+02,&
+             0.596037057E+04, 0.387714006E+00, 0.000000000E-00,&
+             0.437772681E+00, 0.800821928E+00, 0.000000000E-00,&
+             0.000000000E-00, 0.118461660E+03, 0.000000000E-00,&
+             0.151345118E+03, 0.242715973E+02, 0.000000000E-00,&
+             0.000000000E-00, 0.119079797E+04, 0.000000000E-00,&
+             0.233628890E+04, 0.878331486E+02, 0.000000000E-00,&
+             0.000000000E-00, 0.293353397E+03, 0.000000000E-00,&
+             0.797219934E+03, 0.191559725E+02, 0.000000000E-00,&
+             0.000000000E-00, 0.000000000E+00, 0.000000000E-00,&
+             0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /) , (/2,3,7/) )
+      REAL*8, dimension(2,3,7), parameter :: BPAD = reshape (  &
+          (/ 0.912418292E+05, 0.376655383E-08, 0.000000000E-00,&
+             0.739646016E-08, 0.925887084E-04, 0.410177786E+03,&
+             0.724555318E+05, 0.979023421E-04, 0.000000000E-00,&
+             0.131861712E-03, 0.131812683E-01, 0.731185438E+02,&
+             0.602593328E+04, 0.388611139E+00, 0.000000000E-00,&
+             0.437949001E+00, 0.812706117E+00, 0.100000000E+01,&
+             0.100000000E+01, 0.120291383E+03, 0.000000000E-00,&
+             0.151692730E+03, 0.249863591E+02, 0.000000000E+00,&
+             0.000000000E-00, 0.130531005E+04, 0.000000000E-00,&
+             0.237071130E+04, 0.931071925E+02, 0.000000000E+00,&
+             0.000000000E-00, 0.415049409E+03, 0.000000000E-00,&
+             0.867914360E+03, 0.252233437E+02, 0.000000000E+00,&
+             0.000000000E-00, 0.100000000E+01, 0.000000000E-00,&
+             0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /) , (/2,3,7/) )
+      REAL*8, dimension(2,3), parameter :: D = reshape ( &
+       (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.8 /) , (/2,3/) )
+
+      REAL*8, parameter :: TREF = 250.0
+      REAL*8, dimension(2), parameter :: RT1 = (/ -0.577350269, +0.577350269 /)
+      REAL*8, dimension(5,5), parameter :: RAER= reshape ( &
+        (/ .038520, .037196, .040532, .054934, .038520 &
+         , .12613 , .18313 , .10357 , .064106, .126130 &
+         , .012579, .013649, .018652, .025181, .012579 &
+         , .011890, .016142, .021105, .028908, .011890 &
+         , .013792, .026810, .052203, .066338, .013792 /) , (/5,5/) )
+
+      REAL*8, dimension(8,3), parameter :: AT= reshape ( &
+       (/ 0.298199E-02,0.143676E-01,0.197861E-01,0.289560E-01,&
+          0.103800E-01,0.868859E-02,0.250073E-03,0.307423E-01,&
+          -.394023E-03,0.366501E-02,0.315541E-02,-.208807E-02,&
+          0.436296E-02,-.972752E-03,0.455875E-03,0.110879E-02,&
+          0.319566E-04,-.160822E-02,-.174547E-02,-.121943E-02,&
+          -.161431E-02,0.000000E-00,0.109242E-03,-.322172E-03 /) , (/8,3/) )
+
+      REAL*8, dimension(8,3), parameter :: BT= reshape ( &
+       (/ -0.106432E-04,-0.553979E-04,-0.877012E-04,-0.165960E-03,&
+          -0.276744E-04,-0.278412E-04, 0.199846E-05,-0.108482E-03,&
+           0.660324E-06,-0.101701E-04, 0.513302E-04, 0.157704E-03,&
+          -0.327381E-04,-0.713940E-06,-0.216313E-05, 0.258096E-05,&
+           0.174356E-06, 0.920868E-05, 0.523138E-06,-0.146427E-04,&
+           0.127646E-04 ,0.117469E-05, 0.175991E-06,-0.814575E-06 /) , (/8,3/) )
+
+      REAL*8, dimension(4), parameter :: OCT = (/ -.326E-03, -.102E-05, .137E-02, -.535E-05 /)
+
+ end module radiation_AR4_param
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/radio_decay.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/radio_decay.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/radio_decay.F90	(revision 17)
@@ -0,0 +1,59 @@
+!
+! $Id $
+!
+SUBROUTINE radio_decay(id_rn,id_pb,radio,rnpb,dtime,tautr,tr,d_tr) 
+!
+! Caluclate radioactive decay for all tracers with radio(it)=true
+!
+  USE dimphy
+  USE infotrac, ONLY : nbtr
+  IMPLICIT NONE
+!-----------------------------------------------------------------------
+! Auteur(s): AA + CG (LGGE/CNRS) Date 24-06-94
+! Objet: Calcul de la tendance radioactive des traceurs type radioelements
+!        Cas particulier pour le couple radon-plomb : Le radon decroit en plomb
+!-----------------------------------------------------------------------
+!
+! Entrees
+!
+  INTEGER,INTENT(IN)                        :: id_rn, id_pb
+  LOGICAL,DIMENSION(nbtr),INTENT(IN)        :: radio ! .true. = traceur radioactif  
+  LOGICAL,INTENT(IN)                        :: rnpb  ! .true. = decroissance RN = source PB
+  REAL,INTENT(IN)                           :: dtime ! Pas de temps physique (secondes)
+  REAL,DIMENSION(nbtr),INTENT(IN)           :: tautr ! Constante de decroissance radioactive
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr    ! Concentrations traceurs U/kgA
+!
+! Sortie
+!
+  REAL,DIMENSION(klon,klev,nbtr),INTENT(OUT) :: d_tr  ! Tendance de decroissance radioactive
+!
+! Locales
+!
+  INTEGER  :: i,k,it
+
+
+  DO it = 1,nbtr
+     d_tr(:,:,it) = 0.
+     IF ( radio(it) ) THEN
+        IF (tautr(it) .GT. 0.) THEN
+           DO k = 1,klev
+              DO i = 1,klon
+                 d_tr(i,k,it) = - tr(i,k,it) * dtime / tautr(it)
+              END DO
+           END DO
+        END IF
+     END IF
+  END DO
+
+!-------------------------------------------------------
+! Cas particulier radon (id_rn) => plomb (id_pb)
+!-------------------------------------------------------
+  IF ( rnpb ) THEN
+     DO k = 1,klev
+        DO i = 1,klon
+           d_tr(i,k,id_pb) = d_tr(i,k,id_pb) - d_tr(i,k,id_rn)
+        ENDDO
+     ENDDO
+  ENDIF
+
+END SUBROUTINE radio_decay
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/radlwsw_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/radlwsw_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/radlwsw_m.F90	(revision 17)
@@ -0,0 +1,482 @@
+module radlwsw_m
+
+  IMPLICIT NONE
+
+contains
+
+SUBROUTINE radlwsw( &
+   dist, rmu0, fract, &
+   paprs, pplay,tsol,alb1, alb2, &
+   t,q,wo,&
+   cldfra, cldemi, cldtaupd,&
+   ok_ade, ok_aie, flag_aerosol,&
+   flag_aerosol_strat,&
+   tau_aero, piz_aero, cg_aero,&
+   cldtaupi, new_aod, &
+   qsat, flwc, fiwc, &
+   heat,heat0,cool,cool0,radsol,albpla,&
+   topsw,toplw,solsw,sollw,&
+   sollwdown,&
+   topsw0,toplw0,solsw0,sollw0,&
+   lwdn0, lwdn, lwup0, lwup,&
+   swdn0, swdn, swup0, swup,&
+   topswad_aero, solswad_aero,&
+   topswai_aero, solswai_aero, &
+   topswad0_aero, solswad0_aero,&
+   topsw_aero, topsw0_aero,&
+   solsw_aero, solsw0_aero, &
+   topswcf_aero, solswcf_aero)
+
+
+
+  USE DIMPHY
+  USE assert_m, ONLY : assert
+  USE infotrac, ONLY : type_trac
+#ifdef REPROBUS
+  USE CHEM_REP, ONLY : solaireTIME, ok_SUNTIME, ndimozon
+#endif
+! L. Fita
+  USE radiation_AR4_mod
+
+  !======================================================================
+  ! Auteur(s): Z.X. Li (LMD/CNRS) date: 19960719
+  ! Objet: interface entre le modele et les rayonnements
+  ! Arguments:
+  ! dist-----input-R- distance astronomique terre-soleil
+  ! rmu0-----input-R- cosinus de l'angle zenithal
+  ! fract----input-R- duree d'ensoleillement normalisee
+  ! co2_ppm--input-R- concentration du gaz carbonique (en ppm)
+  ! paprs----input-R- pression a inter-couche (Pa)
+  ! pplay----input-R- pression au milieu de couche (Pa)
+  ! tsol-----input-R- temperature du sol (en K)
+  ! alb1-----input-R- albedo du sol(entre 0 et 1) dans l'interval visible 
+  ! alb2-----input-R- albedo du sol(entre 0 et 1) dans l'interval proche infra-rouge   
+  ! t--------input-R- temperature (K)
+  ! q--------input-R- vapeur d'eau (en kg/kg)
+  ! cldfra---input-R- fraction nuageuse (entre 0 et 1)
+  ! cldtaupd---input-R- epaisseur optique des nuages dans le visible (present-day value)
+  ! cldemi---input-R- emissivite des nuages dans l'IR (entre 0 et 1)
+  ! ok_ade---input-L- apply the Aerosol Direct Effect or not?
+  ! ok_aie---input-L- apply the Aerosol Indirect Effect or not?
+  ! flag_aerosol-input-I- aerosol flag from 0 to 6
+  ! flag_aerosol_strat-input-I- use stratospheric aerosols flag (T/F)
+  ! tau_ae, piz_ae, cg_ae-input-R- aerosol optical properties (calculated in aeropt.F)
+  ! cldtaupi-input-R- epaisseur optique des nuages dans le visible
+  !                   calculated for pre-industrial (pi) aerosol concentrations, i.e. with smaller
+  !                   droplet concentration, thus larger droplets, thus generally cdltaupi cldtaupd
+  !                   it is needed for the diagnostics of the aerosol indirect radiative forcing      
+  !
+  ! heat-----output-R- echauffement atmospherique (visible) (K/jour)
+  ! cool-----output-R- refroidissement dans l'IR (K/jour)
+  ! radsol---output-R- bilan radiatif net au sol (W/m**2) (+ vers le bas)
+  ! albpla---output-R- albedo planetaire (entre 0 et 1)
+  ! topsw----output-R- flux solaire net au sommet de l'atm.
+  ! toplw----output-R- ray. IR montant au sommet de l'atmosphere
+  ! solsw----output-R- flux solaire net a la surface
+  ! sollw----output-R- ray. IR montant a la surface
+  ! solswad---output-R- ray. solaire net absorbe a la surface (aerosol dir)
+  ! topswad---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol dir)
+  ! solswai---output-R- ray. solaire net absorbe a la surface (aerosol ind)
+  ! topswai---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol ind)
+  !
+  ! ATTENTION: swai and swad have to be interpreted in the following manner:
+  ! ---------
+  ! ok_ade=F & ok_aie=F -both are zero
+  ! ok_ade=T & ok_aie=F -aerosol direct forcing is F_{AD} = topsw-topswad
+  !                        indirect is zero
+  ! ok_ade=F & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai
+  !                        direct is zero
+  ! ok_ade=T & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai
+  !                        aerosol direct forcing is F_{AD} = topswai-topswad
+  !
+  
+  !======================================================================
+  
+  ! ====================================================================
+  ! Adapte au modele de chimie INCA par Celine Deandreis & Anne Cozic -- 2009
+  ! 1 = ZERO    
+  ! 2 = AER total    
+  ! 3 = NAT    
+  ! 4 = BC    
+  ! 5 = SO4    
+  ! 6 = POM    
+  ! 7 = DUST    
+  ! 8 = SS    
+  ! 9 = NO3    
+  ! 
+  ! ====================================================================
+  include "YOETHF.h"
+  include "YOMCST.h"
+  include "clesphys.h"
+  include "iniprint.h"
+
+! Input arguments
+  REAL,    INTENT(in)  :: dist
+  REAL,    INTENT(in)  :: rmu0(KLON), fract(KLON)
+  REAL,    INTENT(in)  :: paprs(KLON,KLEV+1), pplay(KLON,KLEV)
+  REAL,    INTENT(in)  :: alb1(KLON), alb2(KLON), tsol(KLON)
+  REAL,    INTENT(in)  :: t(KLON,KLEV), q(KLON,KLEV)
+
+  REAL, INTENT(in):: wo(:, :, :) ! dimension(KLON,KLEV, 1 or 2)
+  ! column-density of ozone in a layer, in kilo-Dobsons
+  ! "wo(:, :, 1)" is for the average day-night field, 
+  ! "wo(:, :, 2)" is for daylight time.
+
+  LOGICAL, INTENT(in)  :: ok_ade, ok_aie                                 ! switches whether to use aerosol direct (indirect) effects or not
+  INTEGER, INTENT(in)  :: flag_aerosol                                   ! takes value 0 (no aerosol) or 1 to 6 (aerosols)
+  LOGICAL, INTENT(in)  :: flag_aerosol_strat                             ! use stratospheric aerosols
+  REAL,    INTENT(in)  :: cldfra(KLON,KLEV), cldemi(KLON,KLEV), cldtaupd(KLON,KLEV)
+  REAL,    INTENT(in)  :: tau_aero(KLON,KLEV,9,2)                        ! aerosol optical properties (see aeropt.F)
+  REAL,    INTENT(in)  :: piz_aero(KLON,KLEV,9,2)                        ! aerosol optical properties (see aeropt.F)
+  REAL,    INTENT(in)  :: cg_aero(KLON,KLEV,9,2)                         ! aerosol optical properties (see aeropt.F)
+  REAL,    INTENT(in)  :: cldtaupi(KLON,KLEV)                            ! cloud optical thickness for pre-industrial aerosol concentrations
+  LOGICAL, INTENT(in)  :: new_aod                                        ! flag pour retrouver les resultats exacts de l'AR4 dans le cas ou l'on ne travaille qu'avec les sulfates
+  REAL,    INTENT(in)  :: qsat(klon,klev) ! Variable pour iflag_rrtm=1
+  REAL,    INTENT(in)  :: flwc(klon,klev) ! Variable pour iflag_rrtm=1
+  REAL,    INTENT(in)  :: fiwc(klon,klev) ! Variable pour iflag_rrtm=1
+
+! Output arguments
+  REAL,    INTENT(out) :: heat(KLON,KLEV), cool(KLON,KLEV)
+  REAL,    INTENT(out) :: heat0(KLON,KLEV), cool0(KLON,KLEV)
+  REAL,    INTENT(out) :: radsol(KLON), topsw(KLON), toplw(KLON)
+  REAL,    INTENT(out) :: solsw(KLON), sollw(KLON), albpla(KLON)
+  REAL,    INTENT(out) :: topsw0(KLON), toplw0(KLON), solsw0(KLON), sollw0(KLON)
+  REAL,    INTENT(out) :: sollwdown(KLON)
+  REAL,    INTENT(out) :: swdn(KLON,kflev+1),swdn0(KLON,kflev+1)
+  REAL,    INTENT(out) :: swup(KLON,kflev+1),swup0(KLON,kflev+1)
+  REAL,    INTENT(out) :: lwdn(KLON,kflev+1),lwdn0(KLON,kflev+1)
+  REAL,    INTENT(out) :: lwup(KLON,kflev+1),lwup0(KLON,kflev+1)
+  REAL,    INTENT(out) :: topswad_aero(KLON), solswad_aero(KLON)         ! output: aerosol direct forcing at TOA and surface
+  REAL,    INTENT(out) :: topswai_aero(KLON), solswai_aero(KLON)         ! output: aerosol indirect forcing atTOA and surface
+  REAL, DIMENSION(klon), INTENT(out)    :: topswad0_aero 
+  REAL, DIMENSION(klon), INTENT(out)    :: solswad0_aero
+  REAL, DIMENSION(kdlon,9), INTENT(out) :: topsw_aero
+  REAL, DIMENSION(kdlon,9), INTENT(out) :: topsw0_aero
+  REAL, DIMENSION(kdlon,9), INTENT(out) :: solsw_aero
+  REAL, DIMENSION(kdlon,9), INTENT(out) :: solsw0_aero
+  REAL, DIMENSION(kdlon,3), INTENT(out) :: topswcf_aero
+  REAL, DIMENSION(kdlon,3), INTENT(out) :: solswcf_aero
+
+! Local variables
+  REAL(KIND=8) ZFSUP(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFSDN(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFLUP(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFLDN(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFLUP0(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFLDN0(KDLON,KFLEV+1)
+  REAL(KIND=8) zx_alpha1, zx_alpha2
+  INTEGER k, kk, i, j, iof, nb_gr
+  REAL(KIND=8) PSCT
+  REAL(KIND=8) PALBD(kdlon,2), PALBP(kdlon,2)
+  REAL(KIND=8) PEMIS(kdlon), PDT0(kdlon), PVIEW(kdlon)
+  REAL(KIND=8) PPSOL(kdlon), PDP(kdlon,KLEV)
+  REAL(KIND=8) PTL(kdlon,kflev+1), PPMB(kdlon,kflev+1)
+  REAL(KIND=8) PTAVE(kdlon,kflev)
+  REAL(KIND=8) PWV(kdlon,kflev), PQS(kdlon,kflev)
+
+  real(kind=8) POZON(kdlon, kflev, size(wo, 3)) ! mass fraction of ozone
+  ! "POZON(:, :, 1)" is for the average day-night field, 
+  ! "POZON(:, :, 2)" is for daylight time.
+
+  REAL(KIND=8) PAER(kdlon,kflev,5)
+  REAL(KIND=8) PCLDLD(kdlon,kflev)
+  REAL(KIND=8) PCLDLU(kdlon,kflev)
+  REAL(KIND=8) PCLDSW(kdlon,kflev)
+  REAL(KIND=8) PTAU(kdlon,2,kflev)
+  REAL(KIND=8) POMEGA(kdlon,2,kflev)
+  REAL(KIND=8) PCG(kdlon,2,kflev)
+  REAL(KIND=8) zfract(kdlon), zrmu0(kdlon), zdist
+  REAL(KIND=8) zheat(kdlon,kflev), zcool(kdlon,kflev)
+  REAL(KIND=8) zheat0(kdlon,kflev), zcool0(kdlon,kflev)
+  REAL(KIND=8) ztopsw(kdlon), ztoplw(kdlon)
+  REAL(KIND=8) zsolsw(kdlon), zsollw(kdlon), zalbpla(kdlon)
+  REAL(KIND=8) zsollwdown(kdlon)
+  REAL(KIND=8) ztopsw0(kdlon), ztoplw0(kdlon)
+  REAL(KIND=8) zsolsw0(kdlon), zsollw0(kdlon)
+  REAL(KIND=8) zznormcp
+  REAL(KIND=8) tauaero(kdlon,kflev,9,2)                     ! aer opt properties
+  REAL(KIND=8) pizaero(kdlon,kflev,9,2)
+  REAL(KIND=8) cgaero(kdlon,kflev,9,2)
+  REAL(KIND=8) PTAUA(kdlon,2,kflev)                         ! present-day value of cloud opt thickness (PTAU is pre-industrial value), local use
+  REAL(KIND=8) POMEGAA(kdlon,2,kflev)                       ! dito for single scatt albedo
+  REAL(KIND=8) ztopswadaero(kdlon), zsolswadaero(kdlon)     ! Aerosol direct forcing at TOAand surface
+  REAL(KIND=8) ztopswad0aero(kdlon), zsolswad0aero(kdlon)   ! Aerosol direct forcing at TOAand surface
+  REAL(KIND=8) ztopswaiaero(kdlon), zsolswaiaero(kdlon)     ! dito, indirect
+  REAL(KIND=8) ztopsw_aero(kdlon,9), ztopsw0_aero(kdlon,9)
+  REAL(KIND=8) zsolsw_aero(kdlon,9), zsolsw0_aero(kdlon,9)
+  REAL(KIND=8) ztopswcf_aero(kdlon,3), zsolswcf_aero(kdlon,3)     
+  real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
+
+  call assert(size(wo, 1) == klon, size(wo, 2) == klev, "radlwsw wo")
+  ! initialisation
+  tauaero(:,:,:,:)=0.
+  pizaero(:,:,:,:)=0.
+  cgaero(:,:,:,:)=0.
+  
+  !
+  !-------------------------------------------
+  nb_gr = KLON / kdlon
+  IF (nb_gr*kdlon .NE. KLON) THEN
+      PRINT*, "kdlon mauvais:", KLON, kdlon, nb_gr
+      CALL abort
+  ENDIF
+  IF (kflev .NE. KLEV) THEN
+      PRINT*, "kflev differe de KLEV, kflev, KLEV"
+      CALL abort
+  ENDIF
+  !-------------------------------------------
+  DO k = 1, KLEV
+    DO i = 1, KLON
+      heat(i,k)=0.
+      cool(i,k)=0.
+      heat0(i,k)=0.
+      cool0(i,k)=0.
+    ENDDO
+  ENDDO
+  !
+  zdist = dist
+  !
+  PSCT = solaire/zdist/zdist
+
+  IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+     if(ok_SUNTIME) PSCT = solaireTIME/zdist/zdist
+     print*,'Constante solaire: ',PSCT*zdist*zdist
+#endif
+  END IF
+
+  DO j = 1, nb_gr
+    iof = kdlon*(j-1)
+    DO i = 1, kdlon
+      zfract(i) = fract(iof+i)
+      zrmu0(i) = rmu0(iof+i)
+      PALBD(i,1) = alb1(iof+i)
+      PALBD(i,2) = alb2(iof+i)
+      PALBP(i,1) = alb1(iof+i)
+      PALBP(i,2) = alb2(iof+i)
+      PEMIS(i) = 1.0 
+      PVIEW(i) = 1.66
+      PPSOL(i) = paprs(iof+i,1)
+      zx_alpha1 = (paprs(iof+i,1)-pplay(iof+i,2))/(pplay(iof+i,1)-pplay(iof+i,2))
+      zx_alpha2 = 1.0 - zx_alpha1
+      PTL(i,1) = t(iof+i,1) * zx_alpha1 + t(iof+i,2) * zx_alpha2
+      PTL(i,KLEV+1) = t(iof+i,KLEV)
+      PDT0(i) = tsol(iof+i) - PTL(i,1)
+    ENDDO
+    DO k = 2, kflev
+      DO i = 1, kdlon
+        PTL(i,k) = (t(iof+i,k)+t(iof+i,k-1))*0.5
+      ENDDO
+    ENDDO
+    DO k = 1, kflev
+      DO i = 1, kdlon
+        PDP(i,k) = paprs(iof+i,k)-paprs(iof+i,k+1)
+        PTAVE(i,k) = t(iof+i,k)
+        PWV(i,k) = MAX (q(iof+i,k), 1.0e-12)
+        PQS(i,k) = PWV(i,k)
+        POZON(i,k, :) = wo(iof+i, k, :) * RG * dobson_u * 1e3 &
+             / (paprs(iof+i, k) - paprs(iof+i, k+1))
+        PCLDLD(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
+        PCLDLU(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
+        PCLDSW(i,k) = cldfra(iof+i,k)
+        PTAU(i,1,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! 1e-12 serait instable
+        PTAU(i,2,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! pour 32-bit machines
+        POMEGA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAU(i,1,k))
+        POMEGA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAU(i,2,k))
+        PCG(i,1,k) = 0.865
+        PCG(i,2,k) = 0.910
+        !-
+        ! Introduced for aerosol indirect forcings.
+        ! The following values use the cloud optical thickness calculated from
+        ! present-day aerosol concentrations whereas the quantities without the
+        ! "A" at the end are for pre-industial (natural-only) aerosol concentrations
+        !
+        PTAUA(i,1,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! 1e-12 serait instable
+        PTAUA(i,2,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! pour 32-bit machines
+        POMEGAA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAUA(i,1,k))
+        POMEGAA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAUA(i,2,k))
+      ENDDO
+    ENDDO
+
+    IF (type_trac == 'repr') THEN
+#ifdef REPROBUS
+       ndimozon = size(wo, 3)
+       CALL RAD_INTERACTIF(POZON,iof)
+#endif
+    END IF
+
+    !
+    DO k = 1, kflev+1
+      DO i = 1, kdlon
+        PPMB(i,k) = paprs(iof+i,k)/100.0
+      ENDDO
+    ENDDO
+    !
+    DO kk = 1, 5
+      DO k = 1, kflev
+        DO i = 1, kdlon
+          PAER(i,k,kk) = 1.0E-15
+        ENDDO
+      ENDDO
+    ENDDO
+    DO k = 1, kflev
+      DO i = 1, kdlon
+        tauaero(i,k,:,1)=tau_aero(iof+i,k,:,1)
+        pizaero(i,k,:,1)=piz_aero(iof+i,k,:,1)
+        cgaero(i,k,:,1) =cg_aero(iof+i,k,:,1)
+        tauaero(i,k,:,2)=tau_aero(iof+i,k,:,2)
+        pizaero(i,k,:,2)=piz_aero(iof+i,k,:,2)
+        cgaero(i,k,:,2) =cg_aero(iof+i,k,:,2)
+      ENDDO
+    ENDDO
+
+!
+!===== iflag_rrtm ================================================
+!      
+    IF (iflag_rrtm == 0) THEN
+       ! Old radiation scheme, used for AR4 runs
+       ! average day-night ozone for longwave
+       CALL LW_LMDAR4(&
+            PPMB, PDP,&
+            PPSOL,PDT0,PEMIS,&
+            PTL, PTAVE, PWV, POZON(:, :, 1), PAER,&
+            PCLDLD,PCLDLU,&
+            PVIEW,&
+            zcool, zcool0,&
+            ztoplw,zsollw,ztoplw0,zsollw0,&
+            zsollwdown,&
+            ZFLUP, ZFLDN, ZFLUP0,ZFLDN0)
+
+       ! daylight ozone, if we have it, for short wave
+       IF (.NOT. new_aod) THEN 
+          ! use old version
+          CALL SW_LMDAR4(PSCT, zrmu0, zfract,&
+               PPMB, PDP, &
+               PPSOL, PALBD, PALBP,&
+               PTAVE, PWV, PQS, POZON(:, :, size(wo, 3)), PAER,&
+               PCLDSW, PTAU, POMEGA, PCG,&
+               zheat, zheat0,&
+               zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0,&
+               ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,&
+               tauaero(:,:,5,:), pizaero(:,:,5,:), cgaero(:,:,5,:),& 
+               PTAUA, POMEGAA,&
+               ztopswadaero,zsolswadaero,&
+               ztopswaiaero,zsolswaiaero,& 
+               ok_ade, ok_aie) 
+          
+       ELSE ! new_aod=T         
+          CALL SW_AEROAR4(PSCT, zrmu0, zfract,&
+               PPMB, PDP,&
+               PPSOL, PALBD, PALBP,&
+               PTAVE, PWV, PQS, POZON(:, :, size(wo, 3)), PAER,&
+               PCLDSW, PTAU, POMEGA, PCG,&
+               zheat, zheat0,&
+               zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0,&
+               ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,&
+               tauaero, pizaero, cgaero, &
+               PTAUA, POMEGAA,&
+               ztopswadaero,zsolswadaero,&
+               ztopswad0aero,zsolswad0aero,&
+               ztopswaiaero,zsolswaiaero, & 
+               ztopsw_aero,ztopsw0_aero,&
+               zsolsw_aero,zsolsw0_aero,&
+               ztopswcf_aero,zsolswcf_aero, & 
+               ok_ade, ok_aie, flag_aerosol,flag_aerosol_strat) 
+       ENDIF
+
+    ELSE  
+!===== iflag_rrtm=1, on passe dans SW via RECMWFL ===============
+       WRITE(lunout,*) "Option iflag_rrtm=T ne fonctionne pas encore !!!"
+       CALL abort_gcm('radlwsw','iflag_rrtm=T not valid',1) 
+
+    ENDIF ! iflag_rrtm
+!======================================================================
+
+    DO i = 1, kdlon
+      radsol(iof+i) = zsolsw(i) + zsollw(i)
+      topsw(iof+i) = ztopsw(i)
+      toplw(iof+i) = ztoplw(i)
+      solsw(iof+i) = zsolsw(i)
+      sollw(iof+i) = zsollw(i)
+      sollwdown(iof+i) = zsollwdown(i)
+      DO k = 1, kflev+1
+        lwdn0 ( iof+i,k)   = ZFLDN0 ( i,k)
+        lwdn  ( iof+i,k)   = ZFLDN  ( i,k)
+        lwup0 ( iof+i,k)   = ZFLUP0 ( i,k)
+        lwup  ( iof+i,k)   = ZFLUP  ( i,k)
+      ENDDO
+      topsw0(iof+i) = ztopsw0(i)
+      toplw0(iof+i) = ztoplw0(i)
+      solsw0(iof+i) = zsolsw0(i)
+      sollw0(iof+i) = zsollw0(i)
+      albpla(iof+i) = zalbpla(i)
+
+      DO k = 1, kflev+1
+        swdn0 ( iof+i,k)   = ZFSDN0 ( i,k)
+        swdn  ( iof+i,k)   = ZFSDN  ( i,k)
+        swup0 ( iof+i,k)   = ZFSUP0 ( i,k)
+        swup  ( iof+i,k)   = ZFSUP  ( i,k)
+      ENDDO
+    ENDDO
+    !-transform the aerosol forcings, if they have
+    ! to be calculated
+    IF (ok_ade) THEN
+        DO i = 1, kdlon
+          topswad_aero(iof+i) = ztopswadaero(i)
+          topswad0_aero(iof+i) = ztopswad0aero(i)
+          solswad_aero(iof+i) = zsolswadaero(i)
+          solswad0_aero(iof+i) = zsolswad0aero(i)
+! MS the following lines seem to be wrong, why is iof on right hand side???
+!          topsw_aero(iof+i,:) = ztopsw_aero(iof+i,:)
+!          topsw0_aero(iof+i,:) = ztopsw0_aero(iof+i,:)
+!          solsw_aero(iof+i,:) = zsolsw_aero(iof+i,:)
+!          solsw0_aero(iof+i,:) = zsolsw0_aero(iof+i,:)
+          topsw_aero(iof+i,:) = ztopsw_aero(i,:)
+          topsw0_aero(iof+i,:) = ztopsw0_aero(i,:)
+          solsw_aero(iof+i,:) = zsolsw_aero(i,:)
+          solsw0_aero(iof+i,:) = zsolsw0_aero(i,:)
+          topswcf_aero(iof+i,:) = ztopswcf_aero(i,:)
+          solswcf_aero(iof+i,:) = zsolswcf_aero(i,:)          
+        ENDDO
+    ELSE
+        DO i = 1, kdlon
+          topswad_aero(iof+i) = 0.0
+          solswad_aero(iof+i) = 0.0
+          topswad0_aero(iof+i) = 0.0
+          solswad0_aero(iof+i) = 0.0
+          topsw_aero(iof+i,:) = 0.
+          topsw0_aero(iof+i,:) =0.
+          solsw_aero(iof+i,:) = 0.
+          solsw0_aero(iof+i,:) = 0.
+        ENDDO
+    ENDIF
+    IF (ok_aie) THEN
+        DO i = 1, kdlon
+          topswai_aero(iof+i) = ztopswaiaero(i)
+          solswai_aero(iof+i) = zsolswaiaero(i)
+        ENDDO
+    ELSE
+        DO i = 1, kdlon
+          topswai_aero(iof+i) = 0.0
+          solswai_aero(iof+i) = 0.0
+        ENDDO
+    ENDIF
+    DO k = 1, kflev
+      DO i = 1, kdlon
+        !        scale factor to take into account the difference between
+        !        dry air and watter vapour scpecifi! heat capacity
+        zznormcp=1.0+RVTMP2*PWV(i,k)
+        heat(iof+i,k) = zheat(i,k)/zznormcp
+        cool(iof+i,k) = zcool(i,k)/zznormcp
+        heat0(iof+i,k) = zheat0(i,k)/zznormcp
+        cool0(iof+i,k) = zcool0(i,k)/zznormcp
+      ENDDO
+    ENDDO
+
+ ENDDO ! j = 1, nb_gr
+
+END SUBROUTINE radlwsw
+
+end module radlwsw_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/radopt.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/radopt.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/radopt.h	(revision 17)
@@ -0,0 +1,9 @@
+!
+! $Header$
+!
+      LOGICAL LEVOIGT
+      PARAMETER (LEVOIGT=.FALSE.)
+      INTEGER NOVLP
+      PARAMETER (NOVLP=1)
+      INTEGER KAER
+      PARAMETER (KAER=0)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/read_map2D.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/read_map2D.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/read_map2D.F90	(revision 17)
@@ -0,0 +1,80 @@
+SUBROUTINE read_map2D(filename, varname, timestep, inverse, varout)
+! Open file and read one variable for one timestep.
+! Return variable for the given timestep. 
+  USE dimphy
+  USE netcdf
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+
+
+  IMPLICIT NONE
+
+! Input arguments
+  CHARACTER(len=*), INTENT(IN)  :: filename     ! name of file to read
+  CHARACTER(len=*), INTENT(IN)  :: varname      ! name of variable in file
+  INTEGER, INTENT(IN)           :: timestep     ! actual timestep
+  LOGICAL, INTENT(IN)           :: inverse      ! TRUE if latitude needs to be inversed
+! Output argument
+  REAL, DIMENSION(klon), INTENT(OUT) :: varout  ! The variable read from file for the given timestep
+
+! Local variables
+  INTEGER :: j
+  INTEGER :: nid, nvarid, ierr
+  INTEGER, DIMENSION(3) :: start, count
+  CHARACTER(len=20)     :: modname='read_map2D'
+
+  REAL, DIMENSION(nbp_lon,nbp_lat) :: var_glo2D     ! 2D global 
+  REAL, DIMENSION(nbp_lon,nbp_lat) :: var_glo2D_tmp ! 2D global
+  REAL, DIMENSION(klon_glo)        :: var_glo1D     ! 1D global
+  INCLUDE "iniprint.h"
+
+! Read variable from file. Done by master process MPI and master thread OpenMP
+  IF (is_mpi_root .AND. is_omp_root) THEN
+     ierr = NF90_OPEN(trim(filename), NF90_NOWRITE, nid)
+     IF (ierr /= NF90_NOERR) CALL write_err_mess('Problem in opening file')
+
+     ierr = NF90_INQ_VARID(nid, trim(varname), nvarid)
+     IF (ierr /= NF90_NOERR) CALL write_err_mess('The variable is absent in file')
+     
+     start=(/1,1,timestep/)
+     count=(/nbp_lon,nbp_lat,1/)
+     ierr = NF90_GET_VAR(nid, nvarid, var_glo2D,start,count)
+     IF (ierr /= NF90_NOERR) CALL write_err_mess('Problem in reading varaiable')
+
+     ierr = NF90_CLOSE(nid)
+     IF (ierr /= NF90_NOERR) CALL write_err_mess('Problem in closing file')
+
+     ! Inverse latitude order
+     IF (inverse) THEN
+        var_glo2D_tmp(:,:) = var_glo2D(:,:)
+        DO j=1, nbp_lat
+           var_glo2D(:,j) = var_glo2D_tmp(:,nbp_lat-j+1)
+        END DO
+     END IF
+
+     ! Transform the global field from 2D to 1D
+     CALL grid2Dto1D_glo(var_glo2D,var_glo1D)
+
+     WRITE(lunout,*) 'in read_map2D, filename = ', trim(filename)
+     WRITE(lunout,*) 'in read_map2D, varname  = ', trim(varname)
+     WRITE(lunout,*) 'in read_map2D, timestep = ', timestep
+  ENDIF
+
+! Scatter gloabl 1D variable to all processes
+  CALL scatter(var_glo1D, varout)
+
+  CONTAINS
+    SUBROUTINE write_err_mess(err_mess)
+
+      CHARACTER(len=*), INTENT(IN) :: err_mess
+      INCLUDE "iniprint.h"
+      
+      WRITE(lunout,*) 'Error in read_map2D, filename = ', trim(filename)
+      WRITE(lunout,*) 'Error in read_map2D, varname  = ', trim(varname)
+      WRITE(lunout,*) 'Error in read_map2D, timestep = ', timestep
+
+      CALL abort_gcm(modname, err_mess, 1)
+
+    END SUBROUTINE write_err_mess
+
+END SUBROUTINE read_map2D
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/readaerosol.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/readaerosol.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/readaerosol.F90	(revision 17)
@@ -0,0 +1,591 @@
+! $Id: readaerosol.F90 1665 2012-10-09 13:35:26Z fairhead $
+!
+MODULE readaerosol_mod
+
+  REAL, SAVE :: not_valid=-333.
+
+CONTAINS
+
+SUBROUTINE readaerosol(name_aero, type, filename, iyr_in, klev_src, pt_ap, pt_b, pt_out, psurf, load)
+
+!****************************************************************************************
+! This routine will read the aersosol from file. 
+!
+! Read a year data with get_aero_fromfile depending on aer_type : 
+! - actuel   : read year 1980
+! - preind   : read natural data
+! - scenario : read one or two years and do eventually linare time interpolation
+!
+! Return pointer, pt_out, to the year read or result from interpolation
+!****************************************************************************************
+  USE dimphy
+
+  IMPLICIT NONE
+
+ INCLUDE "iniprint.h"
+
+  ! Input arguments
+  CHARACTER(len=7), INTENT(IN) :: name_aero
+  CHARACTER(len=*), INTENT(IN) :: type  ! actuel, annuel, scenario or preind
+  CHARACTER(len=8), INTENT(IN) :: filename
+  INTEGER, INTENT(IN)          :: iyr_in
+
+  ! Output
+  INTEGER, INTENT(OUT)            :: klev_src
+  REAL, POINTER, DIMENSION(:)     :: pt_ap        ! Pointer for describing the vertical levels      
+  REAL, POINTER, DIMENSION(:)     :: pt_b         ! Pointer for describing the vertical levels      
+  REAL, POINTER, DIMENSION(:,:,:) :: pt_out       ! The massvar distributions, DIMENSION(klon, klev_src, 12)
+  REAL, DIMENSION(klon,12), INTENT(OUT) :: psurf  ! Surface pression for 12 months
+  REAL, DIMENSION(klon,12), INTENT(OUT) :: load   ! Aerosol mass load in each column for 12 months
+
+  ! Local variables
+  CHARACTER(len=4)                :: cyear
+  REAL, POINTER, DIMENSION(:,:,:) :: pt_2
+  REAL, DIMENSION(klon,12)        :: psurf2, load2
+  REAL                            :: p0           ! Reference pressure
+  INTEGER                         :: iyr1, iyr2, klev_src2
+  INTEGER                         :: it, k, i
+  LOGICAL, PARAMETER              :: lonlyone=.FALSE.
+
+!****************************************************************************************
+! Read data depending on aer_type
+!
+!****************************************************************************************
+
+  IF (type == 'actuel') THEN
+! Read and return data for year 1980
+!****************************************************************************************
+     cyear='1980'
+     ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
+     ! pt_out has dimensions (klon, klev_src, 12)
+     CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load)
+     
+
+  ELSE IF (type == 'preind') THEN
+! Read and return data from file with suffix .nat
+!****************************************************************************************     
+     cyear='.nat'
+     ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
+     ! pt_out has dimensions (klon, klev_src, 12)
+     CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load)
+     
+  ELSE IF (type == 'annuel') THEN
+! Read and return data from scenario annual files
+!****************************************************************************************     
+     WRITE(cyear,'(I4)') iyr_in
+     WRITE(lunout,*) 'get_aero 3 iyr_in=', iyr_in,'   ',cyear
+     ! get_aero_fromfile returns pt_out allocated and initialized with data for nbr_tsteps month 
+     ! pt_out has dimensions (klon, klev_src, 12)
+     CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load)
+     
+  ELSE IF (type == 'scenario') THEN
+! Read data depending on actual year and interpolate if necessary
+!****************************************************************************************
+     IF (iyr_in .LT. 1850) THEN
+        cyear='.nat'
+        WRITE(lunout,*) 'get_aero 1 iyr_in=', iyr_in,'   ',cyear
+        ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
+        ! pt_out has dimensions (klon, klev_src, 12)
+        CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load)
+        
+     ELSE IF (iyr_in .GE. 2100) THEN
+        cyear='2100'
+        WRITE(lunout,*) 'get_aero 2 iyr_in=', iyr_in,'   ',cyear
+        ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
+        ! pt_out has dimensions (klon, klev_src, 12)
+        CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load)
+        
+     ELSE
+        ! Read data from 2 decades and interpolate to actual year
+        ! a) from actual 10-yr-period
+        IF (iyr_in.LT.1900) THEN
+           iyr1 = 1850
+           iyr2 = 1900
+        ELSE IF (iyr_in.GE.1900.AND.iyr_in.LT.1920) THEN
+           iyr1 = 1900
+           iyr2 = 1920
+        ELSE 
+           iyr1 = INT(iyr_in/10)*10
+           iyr2 = INT(1+iyr_in/10)*10
+        ENDIF
+        
+        WRITE(cyear,'(I4)') iyr1
+        WRITE(lunout,*) 'get_aero 3 iyr_in=', iyr_in,'   ',cyear
+        ! get_aero_fromfile returns pt_out allocated and initialized with data for 12 month 
+        ! pt_out has dimensions (klon, klev_src, 12)
+        CALL get_aero_fromfile(name_aero, cyear, filename, klev_src, pt_ap, pt_b, p0, pt_out, psurf, load)
+        
+        ! If to read two decades:
+        IF (.NOT.lonlyone) THEN 
+           
+           ! b) from the next following one
+           WRITE(cyear,'(I4)') iyr2
+           WRITE(lunout,*) 'get_aero 4 iyr_in=', iyr_in,'   ',cyear
+           
+           NULLIFY(pt_2)
+           ! get_aero_fromfile returns pt_2 allocated and initialized with data for 12 month 
+           ! pt_2 has dimensions (klon, klev_src, 12)
+           CALL get_aero_fromfile(name_aero, cyear, filename, klev_src2, pt_ap, pt_b, p0, pt_2, psurf2, load2)
+           ! Test for same number of vertical levels
+           IF (klev_src /= klev_src2) THEN
+              WRITE(lunout,*) 'Two aerosols files with different number of vertical levels is not allowded'
+              CALL abort_gcm('readaersosol','Error in number of vertical levels',1)
+           END IF
+           
+           ! Linare interpolate to the actual year:
+           DO it=1,12
+              DO k=1,klev_src
+                 DO i = 1, klon
+                    pt_out(i,k,it) = &
+                         pt_out(i,k,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * &
+                         (pt_out(i,k,it) - pt_2(i,k,it))
+                 END DO
+              END DO
+
+              DO i = 1, klon
+                 psurf(i,it) = &
+                      psurf(i,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * &
+                      (psurf(i,it) - psurf2(i,it))
+
+                 load(i,it) = &
+                      load(i,it) - REAL(iyr_in-iyr1)/REAL(iyr2-iyr1) * &
+                      (load(i,it) - load2(i,it))
+              END DO
+           END DO
+
+           ! Deallocate pt_2 no more needed
+           DEALLOCATE(pt_2)
+           
+        END IF ! lonlyone
+     END IF ! iyr_in .LT. 1850
+
+  ELSE
+     WRITE(lunout,*)'This option is not implemented : aer_type = ', type,' name_aero=',name_aero
+     CALL abort_gcm('readaerosol','Error : aer_type parameter not accepted',1)
+  END IF ! type
+
+
+END SUBROUTINE readaerosol
+
+
+  SUBROUTINE get_aero_fromfile(varname, cyr, filename, klev_src, pt_ap, pt_b, p0, pt_year, psurf_out, load_out)
+!****************************************************************************************
+! Read 12 month aerosol from file and distribute to local process on physical grid. 
+! Vertical levels, klev_src, may differ from model levels if new file format.
+!
+! For mpi_root and master thread :
+! 1) Open file 
+! 2) Find vertical dimension klev_src
+! 3) Read field month by month
+! 4) Close file  
+! 5) Transform the global field from 2D(iim, jjp+1) to 1D(klon_glo)
+!     - Also the levels and the latitudes have to be inversed
+!
+! For all processes and threads :
+! 6) Scatter global field(klon_glo) to local process domain(klon)
+! 7) Test for negative values
+!****************************************************************************************
+
+    USE netcdf
+    USE dimphy
+    USE mod_grid_phy_lmdz
+    USE mod_phys_lmdz_para
+    USE iophy, ONLY : io_lon, io_lat
+
+    IMPLICIT NONE
+      
+    INCLUDE "dimensions.h"      
+    INCLUDE "iniprint.h"
+
+! Input argumets
+    CHARACTER(len=7), INTENT(IN)          :: varname
+    CHARACTER(len=4), INTENT(IN)          :: cyr
+    CHARACTER(len=8), INTENT(IN)          :: filename
+
+! Output arguments
+    INTEGER, INTENT(OUT)                  :: klev_src     ! Number of vertical levels in file
+    REAL, POINTER, DIMENSION(:)           :: pt_ap        ! Pointer for describing the vertical levels      
+    REAL, POINTER, DIMENSION(:)           :: pt_b         ! Pointer for describing the vertical levels      
+    REAL                                  :: p0           ! Reference pressure value
+    REAL, POINTER, DIMENSION(:,:,:)       :: pt_year      ! Pointer-variabale from file, 12 month, grid : klon,klev_src
+    REAL, DIMENSION(klon,12), INTENT(OUT) :: psurf_out    ! Surface pression for 12 months
+    REAL, DIMENSION(klon,12), INTENT(OUT) :: load_out     ! Aerosol mass load in each column
+    INTEGER                               :: nbr_tsteps   ! number of month in file read
+
+! Local variables
+    CHARACTER(len=30)     :: fname
+    CHARACTER(len=30)     :: cvar
+    INTEGER               :: ncid, dimid, varid
+    INTEGER               :: imth, i, j, k, ierr
+    REAL                  :: npole, spole
+    REAL, ALLOCATABLE, DIMENSION(:,:,:)   :: varmth
+    REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: varyear       ! Global variable read from file, 12 month
+    REAL, ALLOCATABLE, DIMENSION(:,:,:)   :: varyear_glo1D !(klon_glo, klev_src, 12)
+    REAL, ALLOCATABLE, DIMENSION(:)       :: varktmp
+
+    REAL, DIMENSION(iim,jjm+1,12)         :: psurf_glo2D   ! Surface pression for 12 months on dynamics global grid
+    REAL, DIMENSION(klon_glo,12)          :: psurf_glo1D   ! -"- on physical global grid
+    REAL, DIMENSION(iim,jjm+1,12)         :: load_glo2D    ! Load for 12 months on dynamics global grid
+    REAL, DIMENSION(klon_glo,12)          :: load_glo1D    ! -"- on physical global grid
+    REAL, DIMENSION(iim,jjm+1)            :: vartmp
+    REAL, DIMENSION(iim)                  :: lon_src              ! longitudes in file
+    REAL, DIMENSION(jjm+1)                :: lat_src, lat_src_inv ! latitudes in file
+    LOGICAL                               :: new_file             ! true if new file format detected
+    LOGICAL                               :: invert_lat           ! true if the field has to be inverted for latitudes
+
+
+    ! Deallocate pointers
+    IF (ASSOCIATED(pt_ap)) DEALLOCATE(pt_ap)
+    IF (ASSOCIATED(pt_b))  DEALLOCATE(pt_b)
+
+    IF (is_mpi_root .AND. is_omp_root) THEN
+
+! 1) Open file 
+!****************************************************************************************
+! Add suffix to filename
+       fname = trim(filename)//cyr//'.nc'
+  
+       WRITE(lunout,*) 'reading variable ',TRIM(varname),' in file ', TRIM(fname)
+       CALL check_err( nf90_open(TRIM(fname), NF90_NOWRITE, ncid), "pb open "//trim(varname) )
+
+! Test for equal longitudes and latitudes in file and model
+!****************************************************************************************
+       ! Read and test longitudes
+       CALL check_err( nf90_inq_varid(ncid, 'lon', varid),"pb inq lon" )
+       CALL check_err( nf90_get_var(ncid, varid, lon_src(:)),"pb get lon" )
+       
+       IF (maxval(ABS(lon_src - io_lon)) > 0.001) THEN
+          WRITE(lunout,*) 'Problem in longitudes read from file : ',TRIM(fname)
+          WRITE(lunout,*) 'longitudes in file ', TRIM(fname),' : ', lon_src
+          WRITE(lunout,*) 'longitudes in model :', io_lon
+          
+          CALL abort_gcm('get_aero_fromfile', 'longitudes are not the same in file and model',1)
+       END IF
+
+       ! Read and test latitudes
+       CALL check_err( nf90_inq_varid(ncid, 'lat', varid),"pb inq lat" )
+       CALL check_err( nf90_get_var(ncid, varid, lat_src(:)),"pb get lat" )
+
+       ! Invert source latitudes
+       DO j = 1, jjm+1
+          lat_src_inv(j) = lat_src(jjm+1 +1 -j)
+       END DO
+
+       IF (maxval(ABS(lat_src - io_lat)) < 0.001) THEN
+          ! Latitudes are the same
+          invert_lat=.FALSE.
+       ELSE IF (maxval(ABS(lat_src_inv - io_lat)) < 0.001) THEN
+          ! Inverted source latitudes correspond to model latitudes
+          WRITE(lunout,*) 'latitudes will be inverted for file : ',TRIM(fname)
+          invert_lat=.TRUE.
+       ELSE
+          WRITE(lunout,*) 'Problem in latitudes read from file : ',TRIM(fname)
+          WRITE(lunout,*) 'latitudes in file ', TRIM(fname),' : ', lat_src      
+          WRITE(lunout,*) 'latitudes in model :', io_lat
+          CALL abort_gcm('get_aero_fromfile', 'latitudes do not correspond between file and model',1)
+       END IF
+
+
+! 2) Check if old or new file is avalabale.
+!    New type of file should contain the dimension 'lev'
+!    Old type of file should contain the dimension 'PRESNIVS'
+!****************************************************************************************
+       ierr = nf90_inq_dimid(ncid, 'lev', dimid) 
+       IF (ierr /= NF90_NOERR) THEN
+          ! Coordinate axe lev not found. Check for presnivs.
+          ierr = nf90_inq_dimid(ncid, 'PRESNIVS', dimid)
+          IF (ierr /= NF90_NOERR) THEN
+             ! Dimension PRESNIVS not found either
+             CALL abort_gcm('get_aero_fromfile', 'dimension lev or presnivs not in file',1)
+          ELSE 
+             ! Old file found
+             new_file=.FALSE.
+             WRITE(lunout,*) 'Vertical interpolation for ',TRIM(varname),' will not be done'
+          END IF
+       ELSE
+          ! New file found
+          new_file=.TRUE.
+          WRITE(lunout,*) 'Vertical interpolation for ',TRIM(varname),' will be done'
+       END IF
+       
+! 2) Find vertical dimension klev_src
+!****************************************************************************************
+       CALL check_err( nf90_inquire_dimension(ncid, dimid, len = klev_src),"pb inq dim for PRESNIVS or lev" )
+       
+     ! Allocate variables depending on the number of vertical levels
+       ALLOCATE(varmth(iim, jjm+1, klev_src), varyear(iim, jjm+1, klev_src, 12), stat=ierr)
+       IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 1',1)
+
+       ALLOCATE(pt_ap(klev_src), pt_b(klev_src), varktmp(klev_src), stat=ierr)
+       IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 2',1)
+
+! 3) Read all variables from file
+!    There is 2 options for the file structure :
+!    new_file=TRUE  : read varyear, ps, pt_ap and pt_b
+!    new_file=FALSE : read varyear month by month
+!****************************************************************************************
+
+       IF (new_file) THEN
+! ++) Check number of month in file opened
+!**************************************************************************************************
+       ierr = nf90_inq_dimid(ncid, 'TIME',dimid)
+       CALL check_err( nf90_inquire_dimension(ncid, dimid, len = nbr_tsteps),"pb inq dim TIME" )
+!       IF (nbr_tsteps /= 12 .AND. nbr_tsteps /= 14) THEN
+       IF (nbr_tsteps /= 12 ) THEN
+         CALL abort_gcm('get_aero_fromfile', 'not the right number of months in aerosol file read (should be 12 for the moment)',1)
+       ENDIF
+
+! ++) Read the aerosol concentration month by month and concatenate to total variable varyear
+!****************************************************************************************
+          ! Get variable id
+          CALL check_err( nf90_inq_varid(ncid, TRIM(varname), varid),"pb inq var "//TRIM(varname) )
+          
+          ! Get the variable
+          CALL check_err( nf90_get_var(ncid, varid, varyear(:,:,:,:)),"pb get var "//TRIM(varname) )
+          
+! ++) Read surface pression, 12 month in one variable
+!****************************************************************************************
+          ! Get variable id
+          CALL check_err( nf90_inq_varid(ncid, "ps", varid),"pb inq var ps" )
+          ! Get the variable
+          CALL check_err( nf90_get_var(ncid, varid, psurf_glo2D),"pb get var ps" )
+          
+! ++) Read mass load, 12 month in one variable
+!****************************************************************************************
+          ! Get variable id
+          CALL check_err( nf90_inq_varid(ncid, "load_"//TRIM(varname), varid) ,"pb inq var load_"//TRIM(varname))
+          ! Get the variable
+          CALL check_err( nf90_get_var(ncid, varid, load_glo2D),"pb get var load_"//TRIM(varname) )
+          
+! ++) Read ap
+!****************************************************************************************
+          ! Get variable id
+          CALL check_err( nf90_inq_varid(ncid, "ap", varid),"pb inq var ap" )
+          ! Get the variable
+          CALL check_err( nf90_get_var(ncid, varid, pt_ap),"pb get var ap" )
+
+! ++) Read b
+!****************************************************************************************
+          ! Get variable id
+          CALL check_err( nf90_inq_varid(ncid, "b", varid),"pb inq var b" )
+          ! Get the variable
+          CALL check_err( nf90_get_var(ncid, varid, pt_b),"pb get var b" )
+
+! ++) Read p0 : reference pressure
+!****************************************************************************************
+          ! Get variable id
+          CALL check_err( nf90_inq_varid(ncid, "p0", varid),"pb inq var p0" )
+          ! Get the variable
+          CALL check_err( nf90_get_var(ncid, varid, p0),"pb get var p0" )
+          
+
+       ELSE  ! old file
+
+! ++) Read the aerosol concentration month by month and concatenate to total variable varyear
+!****************************************************************************************
+          DO imth=1, 12
+             IF (imth.EQ.1) THEN
+                cvar=TRIM(varname)//'JAN'
+             ELSE IF (imth.EQ.2) THEN
+                cvar=TRIM(varname)//'FEB'
+             ELSE IF (imth.EQ.3) THEN
+                cvar=TRIM(varname)//'MAR'
+             ELSE IF (imth.EQ.4) THEN
+                cvar=TRIM(varname)//'APR'
+             ELSE IF (imth.EQ.5) THEN
+                cvar=TRIM(varname)//'MAY'
+             ELSE IF (imth.EQ.6) THEN
+                cvar=TRIM(varname)//'JUN'
+             ELSE IF (imth.EQ.7) THEN
+                cvar=TRIM(varname)//'JUL'
+             ELSE IF (imth.EQ.8) THEN
+                cvar=TRIM(varname)//'AUG'
+             ELSE IF (imth.EQ.9) THEN
+                cvar=TRIM(varname)//'SEP'
+             ELSE IF (imth.EQ.10) THEN
+                cvar=TRIM(varname)//'OCT'
+             ELSE IF (imth.EQ.11) THEN
+                cvar=TRIM(varname)//'NOV'
+             ELSE IF (imth.EQ.12) THEN
+                cvar=TRIM(varname)//'DEC'
+             END IF
+             
+             ! Get variable id
+             CALL check_err( nf90_inq_varid(ncid, TRIM(cvar), varid),"pb inq var "//TRIM(cvar) )
+             
+             ! Get the variable
+             CALL check_err( nf90_get_var(ncid, varid, varmth),"pb get var "//TRIM(cvar) )
+             
+             ! Store in variable for the whole year
+             varyear(:,:,:,imth)=varmth(:,:,:)
+             
+          END DO
+          
+          ! Putting dummy 
+          psurf_glo2D(:,:,:) = not_valid
+          load_glo2D(:,:,:)  = not_valid
+          pt_ap(:) = not_valid
+          pt_b(:)  = not_valid
+
+       END IF
+
+! 4) Close file  
+!****************************************************************************************
+       CALL check_err( nf90_close(ncid),"pb in close" )
+     
+
+! 5) Transform the global field from 2D(iim, jjp+1) to 1D(klon_glo)
+!****************************************************************************************
+! Test if vertical levels have to be inversed
+
+       IF ((pt_b(1) < pt_b(klev_src)) .OR. .NOT. new_file) THEN
+!          WRITE(lunout,*) 'Vertical axis in file ',TRIM(fname), ' needs to be inverted'
+!          WRITE(lunout,*) 'before pt_ap = ', pt_ap
+!          WRITE(lunout,*) 'before pt_b = ', pt_b
+          
+          ! Inverse vertical levels for varyear 
+          DO imth=1, 12
+             varmth(:,:,:) = varyear(:,:,:,imth) ! use varmth temporarly
+             DO k=1, klev_src
+                DO j=1, jjm+1
+                   DO i=1,iim 
+                      varyear(i,j,k,imth) = varmth(i,j,klev_src+1-k)
+                   END DO
+                END DO
+             END DO
+          END DO
+           
+          ! Inverte vertical axes for pt_ap and pt_b
+          varktmp(:) = pt_ap(:)
+          DO k=1, klev_src
+             pt_ap(k) = varktmp(klev_src+1-k)
+          END DO
+
+          varktmp(:) = pt_b(:)
+          DO k=1, klev_src
+             pt_b(k) = varktmp(klev_src+1-k)
+          END DO
+          WRITE(lunout,*) 'after pt_ap = ', pt_ap
+          WRITE(lunout,*) 'after pt_b = ', pt_b
+
+       ELSE 
+          WRITE(lunout,*) 'Vertical axis in file ',TRIM(fname), ' is ok, no vertical inversion is done'
+          WRITE(lunout,*) 'pt_ap = ', pt_ap
+          WRITE(lunout,*) 'pt_b = ', pt_b
+       END IF
+
+!     - Invert latitudes if necessary
+       DO imth=1, 12
+          IF (invert_lat) THEN
+
+             ! Invert latitudes for the variable
+             varmth(:,:,:) = varyear(:,:,:,imth) ! use varmth temporarly
+             DO k=1,klev_src
+                DO j=1,jjm+1
+                   DO i=1,iim
+                      varyear(i,j,k,imth) = varmth(i,jjm+1+1-j,k)
+                   END DO
+                END DO
+             END DO
+             
+             ! Invert latitudes for surface pressure
+             vartmp(:,:) = psurf_glo2D(:,:,imth)
+             DO j=1, jjm+1
+                DO i=1,iim
+                   psurf_glo2D(i,j,imth)= vartmp(i,jjm+1+1-j)
+                END DO
+             END DO
+             
+             ! Invert latitudes for the load
+             vartmp(:,:) = load_glo2D(:,:,imth)
+             DO j=1, jjm+1
+                DO i=1,iim
+                   load_glo2D(i,j,imth)= vartmp(i,jjm+1+1-j)
+                END DO
+             END DO
+          END IF ! invert_lat
+             
+          ! Do zonal mead at poles and distribut at whole first and last latitude
+          DO k=1, klev_src
+             npole=0.  ! North pole, j=1
+             spole=0.  ! South pole, j=jjm+1         
+             DO i=1,iim
+                npole = npole + varyear(i,1,k,imth)
+                spole = spole + varyear(i,jjm+1,k,imth)
+             END DO
+             npole = npole/REAL(iim)
+             spole = spole/REAL(iim)
+             varyear(:,1,    k,imth) = npole
+             varyear(:,jjm+1,k,imth) = spole
+          END DO
+       END DO ! imth
+       
+       ALLOCATE(varyear_glo1D(klon_glo, klev_src, 12), stat=ierr)
+       IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 3',1)
+       
+       ! Transform from 2D to 1D field
+       CALL grid2Dto1D_glo(varyear,varyear_glo1D)
+       CALL grid2Dto1D_glo(psurf_glo2D,psurf_glo1D)
+       CALL grid2Dto1D_glo(load_glo2D,load_glo1D)
+
+    ELSE
+      ALLOCATE(varyear_glo1D(0,0,0))        
+    END IF ! is_mpi_root .AND. is_omp_root
+
+!$OMP BARRIER
+  
+! 6) Distribute to all processes
+!    Scatter global field(klon_glo) to local process domain(klon)
+!    and distribute klev_src to all processes
+!****************************************************************************************
+
+    ! Distribute klev_src
+    CALL bcast(klev_src)
+
+    ! Allocate and distribute pt_ap and pt_b
+    IF (.NOT. ASSOCIATED(pt_ap)) THEN  ! if pt_ap is allocated also pt_b is allocated
+       ALLOCATE(pt_ap(klev_src), pt_b(klev_src), stat=ierr)
+       IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 4',1)
+    END IF
+    CALL bcast(pt_ap)
+    CALL bcast(pt_b)
+
+    ! Allocate space for output pointer variable at local process
+    IF (ASSOCIATED(pt_year)) DEALLOCATE(pt_year)
+    ALLOCATE(pt_year(klon, klev_src, 12), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('get_aero_fromfile', 'pb in allocation 5',1)
+
+    ! Scatter global field to local domain at local process
+    CALL scatter(varyear_glo1D, pt_year)
+    CALL scatter(psurf_glo1D, psurf_out)
+    CALL scatter(load_glo1D,  load_out)
+
+! 7) Test for negative values
+!****************************************************************************************
+    IF (MINVAL(pt_year) < 0.) THEN
+       WRITE(lunout,*) 'Warning! Negative values read from file :', fname
+    END IF
+
+  END SUBROUTINE get_aero_fromfile
+
+
+  SUBROUTINE check_err(status,text)
+    USE netcdf
+    IMPLICIT NONE
+
+    INCLUDE "iniprint.h"
+    INTEGER, INTENT (IN) :: status
+    CHARACTER(len=*), INTENT (IN), OPTIONAL :: text
+
+    IF (status /= NF90_NOERR) THEN
+       WRITE(lunout,*) 'Error in get_aero_fromfile, netcdf error code = ',status
+       IF (PRESENT(text)) THEN
+          WRITE(lunout,*) 'Error in get_aero_fromfile : ',text
+       END IF
+       CALL abort_gcm('get_aero_fromfile',trim(nf90_strerror(status)),1)
+    END IF
+
+  END SUBROUTINE check_err
+
+
+END MODULE readaerosol_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/readaerosol_interp.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/readaerosol_interp.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/readaerosol_interp.F90	(revision 17)
@@ -0,0 +1,581 @@
+! $Id$
+!
+SUBROUTINE readaerosol_interp(id_aero, itap, pdtphys, r_day, first, pplay, paprs, t_seri, mass_out, pi_mass_out, load_src)
+!
+! This routine will return the mass concentration at actual day(mass_out) and 
+! the pre-industrial values(pi_mass_out) for aerosol corresponding to "id_aero".
+! The mass concentrations for all aerosols are saved in this routine but each
+! call to this routine only treats the aerosol "id_aero".
+!
+! 1) Read in data for the whole year, only at first time step
+! 2) Interpolate to the actual day, only at new day
+! 3) Interpolate to the model vertical grid (target grid), only at new day
+! 4) Test for negative mass values
+
+  USE ioipsl
+  USE dimphy, ONLY : klev,klon
+  USE mod_phys_lmdz_para, ONLY : mpi_rank  
+  USE readaerosol_mod
+  USE aero_mod, ONLY : naero_spc, name_aero
+  USE write_field_phy
+  USE phys_cal_mod
+  USE pres2lev_mod
+
+  IMPLICIT NONE
+
+  INCLUDE "YOMCST.h"
+  INCLUDE "chem.h"      
+  INCLUDE "temps.h"      
+  INCLUDE "clesphys.h"
+  INCLUDE "iniprint.h"
+  INCLUDE "dimensions.h"
+  INCLUDE "comvert.h"
+!
+! Input:
+!****************************************************************************************
+  INTEGER, INTENT(IN)                    :: id_aero! Identity number for the aerosol to treat
+  INTEGER, INTENT(IN)                    :: itap   ! Physic step count
+  REAL, INTENT(IN)                       :: pdtphys! Physic day step
+  REAL, INTENT(IN)                       :: r_day  ! Day of integration
+  LOGICAL, INTENT(IN)                    :: first  ! First model timestep 
+  REAL, DIMENSION(klon,klev), INTENT(IN) :: pplay  ! pression at model mid-layers
+  REAL, DIMENSION(klon,klev+1),INTENT(IN):: paprs  ! pression between model layers
+  REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri ! air temperature
+!      
+! Output:      
+!****************************************************************************************
+  REAL, INTENT(OUT) :: mass_out(klon,klev)    ! Mass of aerosol (monthly mean data,from file) [ug AIBCM/m3]
+  REAL, INTENT(OUT) :: pi_mass_out(klon,klev) ! Mass of preindustrial aerosol (monthly mean data,from file) [ug AIBCM/m3]
+  REAL, INTENT(OUT) :: load_src(klon) ! Load of aerosol (monthly mean data,from file) [kg/m3]
+!      
+! Local Variables:
+!****************************************************************************************
+  INTEGER                         :: i, k, ierr
+  INTEGER                         :: iday, iyr, lmt_pas
+!  INTEGER                         :: im, day1, day2, im2
+  INTEGER                         :: im, im2
+  REAL                            :: day1, day2
+  INTEGER                         :: pi_klev_src ! Only for testing purpose
+  INTEGER, SAVE                   :: klev_src    ! Number of vertical levles in source field
+!$OMP THREADPRIVATE(klev_src)
+
+  REAL                              :: zrho      ! Air density [kg/m3]
+  REAL                              :: volm      ! Volyme de melange [kg/kg]
+  REAL, DIMENSION(klon)             :: psurf_day, pi_psurf_day
+  REAL, DIMENSION(klon)             :: pi_load_src  ! Mass load at source grid
+  REAL, DIMENSION(klon)             :: load_tgt, load_tgt_test
+  REAL, DIMENSION(klon,klev)        :: delp ! pressure difference in each model layer
+
+  REAL, ALLOCATABLE, DIMENSION(:,:)            :: pplay_src ! pression mid-layer at source levels
+  REAL, ALLOCATABLE, DIMENSION(:,:)            :: tmp1, tmp2  ! Temporary variables
+  REAL, ALLOCATABLE, DIMENSION(:,:,:,:), SAVE  :: var_year    ! VAR in right dimension for the total year
+  REAL, ALLOCATABLE, DIMENSION(:,:,:,:), SAVE  :: pi_var_year ! pre-industrial VAR, -"-
+!$OMP THREADPRIVATE(var_year,pi_var_year)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE     :: var_day     ! VAR interpolated to the actual day and model grid
+  REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE     :: pi_var_day  ! pre-industrial VAR, -"-
+!$OMP THREADPRIVATE(var_day,pi_var_day)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE    :: psurf_year, pi_psurf_year ! surface pressure for the total year
+!$OMP THREADPRIVATE(psurf_year, pi_psurf_year)
+  REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE    :: load_year, pi_load_year   ! load in the column for the total year
+!$OMP THREADPRIVATE(load_year, pi_load_year)
+
+  REAL, DIMENSION(:,:,:), POINTER   :: pt_tmp      ! Pointer allocated in readaerosol
+  REAL, POINTER, DIMENSION(:), SAVE :: pt_ap, pt_b ! Pointer for describing the vertical levels 
+!$OMP THREADPRIVATE(pt_ap, pt_b)
+  INTEGER, SAVE                     :: nbr_tsteps ! number of time steps in file read
+  REAL, DIMENSION(14), SAVE         :: month_len, month_start, month_mid
+!$OMP THREADPRIVATE(nbr_tsteps, month_len, month_start, month_mid)
+  REAL                              :: jDay
+
+  LOGICAL            :: lnewday      ! Indicates if first time step at a new day
+  LOGICAL            :: OLDNEWDAY
+  LOGICAL,SAVE       :: vert_interp  ! Indicates if vertical interpolation will be done
+  LOGICAL,SAVE       :: debug=.FALSE.! Debugging in this subroutine
+!$OMP THREADPRIVATE(vert_interp, debug)
+  CHARACTER(len=8)      :: type
+  CHARACTER(len=8)      :: filename
+
+
+!****************************************************************************************
+! Initialization
+!
+!****************************************************************************************
+
+! Calculation to find if it is a new day
+
+  IF(mpi_rank == 0 .AND. debug )then
+     PRINT*,'CONTROL PANEL REGARDING TIME STEPING'
+  ENDIF
+
+  ! Use phys_cal_mod
+  iday= day_cur
+  iyr = year_cur
+  im  = mth_cur
+
+!  iday = INT(r_day)
+!  iyr  = iday/360
+!  iday = iday-iyr*360         ! day of the actual year
+!  iyr  = iyr + annee_ref      ! year of the run   
+!  im   = iday/30 +1           ! the actual month
+  CALL ymds2ju(iyr, im, iday, 0., jDay)
+!   CALL ymds2ju(iyr, im, iday-(im-1)*30, 0., jDay)
+
+
+  IF(MOD(itap-1,NINT(86400./pdtphys)) == 0)THEN
+     lnewday=.TRUE.
+  ELSE
+     lnewday=.FALSE.
+  ENDIF
+
+  IF(mpi_rank == 0 .AND. debug)then
+     ! 0.02 is about 0.5/24, namly less than half an hour
+     OLDNEWDAY = (r_day-REAL(iday) < 0.02)
+     ! Once per day, update aerosol fields
+     lmt_pas = NINT(86400./pdtphys)
+     PRINT*,'r_day-REAL(iday) =',r_day-REAL(iday) 
+     PRINT*,'itap =',itap
+     PRINT*,'pdtphys =',pdtphys
+     PRINT*,'lmt_pas =',lmt_pas
+     PRINT*,'iday =',iday
+     PRINT*,'r_day =',r_day
+     PRINT*,'day_cur =',day_cur
+     PRINT*,'mth_cur =',mth_cur
+     PRINT*,'year_cur =',year_cur
+     PRINT*,'NINT(86400./pdtphys) =',NINT(86400./pdtphys)
+     PRINT*,'MOD(0,1) =',MOD(0,1)
+     PRINT*,'lnewday =',lnewday
+     PRINT*,'OLDNEWDAY =',OLDNEWDAY
+  ENDIF
+
+  IF (.NOT. ALLOCATED(var_day)) THEN
+     ALLOCATE( var_day(klon, klev, naero_spc), stat=ierr)
+     IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 1',1)
+     ALLOCATE( pi_var_day(klon, klev, naero_spc), stat=ierr)
+     IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 2',1)
+
+     ALLOCATE( psurf_year(klon, 12, naero_spc), pi_psurf_year(klon, 12, naero_spc), stat=ierr)
+     IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 3',1)
+
+     ALLOCATE( load_year(klon, 12, naero_spc), pi_load_year(klon, 12, naero_spc), stat=ierr)
+     IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 4',1)
+
+     lnewday=.TRUE.
+
+     NULLIFY(pt_ap)
+     NULLIFY(pt_b)
+  END IF
+
+!****************************************************************************************
+! 1) Read in data : corresponding to the actual year and preindustrial data. 
+!    Only for the first day of the year.
+!
+!****************************************************************************************
+  IF ( (first .OR. iday==0) .AND. lnewday ) THEN 
+     NULLIFY(pt_tmp)
+
+     ! Reading values corresponding to the closest year taking into count the choice of aer_type. 
+     ! For aer_type=scenario interpolation between 2 data sets is done in readaerosol.
+     ! If aer_type=mix1, mix2 or mix3, the run type and file name depends on the aerosol.
+     IF (aer_type=='preind' .OR. aer_type=='actuel' .OR. aer_type=='annuel' .OR. aer_type=='scenario') THEN
+        ! Standard case
+        filename='aerosols'
+        type=aer_type
+     ELSE IF (aer_type == 'mix1') THEN
+        ! Special case using a mix of decenal sulfate file and annual aerosols(all aerosols except sulfate)
+        IF (name_aero(id_aero) == 'SO4') THEN
+           filename='so4.run '
+           type='scenario'
+        ELSE
+           filename='aerosols'
+           type='annuel'
+        END IF
+     ELSE  IF (aer_type == 'mix2') THEN
+        ! Special case using a mix of decenal sulfate file and natrual aerosols
+        IF (name_aero(id_aero) == 'SO4') THEN
+           filename='so4.run '
+           type='scenario'
+        ELSE
+           filename='aerosols'
+           type='preind'
+        END IF
+     ELSE  IF (aer_type == 'mix3') THEN
+        ! Special case using a mix of annual sulfate file and natrual aerosols
+        IF (name_aero(id_aero) == 'SO4') THEN
+           filename='aerosols'
+           type='annuel'
+        ELSE
+           filename='aerosols' 
+           type='preind'
+        END IF
+     ELSE
+        CALL abort_gcm('readaerosol_interp', 'this aer_type not supported',1)
+     END IF
+
+     CALL readaerosol(name_aero(id_aero), type, filename, iyr, klev_src, pt_ap, pt_b, pt_tmp, &
+          psurf_year(:,:,id_aero), load_year(:,:,id_aero))
+     IF (.NOT. ALLOCATED(var_year)) THEN
+        ALLOCATE(var_year(klon, klev_src, 12, naero_spc), stat=ierr)
+        IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 5',1)
+     END IF
+     var_year(:,:,:,id_aero) = pt_tmp(:,:,:)
+
+     ! Reading values corresponding to the preindustrial concentrations.
+     type='preind'
+     CALL readaerosol(name_aero(id_aero), type, filename, iyr, pi_klev_src, pt_ap, pt_b, pt_tmp, &
+          pi_psurf_year(:,:,id_aero), pi_load_year(:,:,id_aero))
+
+     ! klev_src must be the same in both files. 
+     ! Also supposing pt_ap and pt_b to be the same in the 2 files without testing. 
+     IF (pi_klev_src /= klev_src) THEN
+        WRITE(lunout,*) 'Error! All forcing files for the same aerosol must have the same vertical dimension'
+        WRITE(lunout,*) 'Aerosol : ', name_aero(id_aero)
+        CALL abort_gcm('readaerosol_interp','Differnt vertical axes in aerosol forcing files',1)
+     END IF
+
+     IF (.NOT. ALLOCATED(pi_var_year)) THEN
+        ALLOCATE(pi_var_year(klon, klev_src, 12, naero_spc), stat=ierr)
+        IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 6',1)
+     END IF
+     pi_var_year(:,:,:,id_aero) = pt_tmp(:,:,:)
+    
+     IF (debug) THEN
+        CALL writefield_phy('var_year_jan',var_year(:,:,1,id_aero),klev_src)
+        CALL writefield_phy('var_year_dec',var_year(:,:,12,id_aero),klev_src)
+        CALL writefield_phy('psurf_src',psurf_year(:,:,id_aero),1)
+        CALL writefield_phy('pi_psurf_src',pi_psurf_year(:,:,id_aero),1)
+        CALL writefield_phy('load_year_src',load_year(:,:,id_aero),1)
+        CALL writefield_phy('pi_load_year_src',pi_load_year(:,:,id_aero),1)
+     END IF
+
+     ! Pointer no more useful, deallocate. 
+     DEALLOCATE(pt_tmp)
+
+     ! Test if vertical interpolation will be needed.
+     IF (psurf_year(1,1,id_aero)==not_valid .OR. pi_psurf_year(1,1,id_aero)==not_valid ) THEN
+        ! Pressure=not_valid indicates old file format, see module readaerosol
+        vert_interp = .FALSE.
+
+        ! If old file format, both psurf_year and pi_psurf_year must be not_valid
+        IF (  psurf_year(1,1,id_aero) /= pi_psurf_year(1,1,id_aero) ) THEN
+           WRITE(lunout,*) 'Warning! All forcing files for the same aerosol must have the same structure'
+           CALL abort_gcm('readaerosol_interp', 'The aerosol files have not the same format',1)
+        END IF
+        
+        IF (klev /= klev_src) THEN
+           WRITE(lunout,*) 'Old format of aerosol file do not allowed vertical interpolation'
+           CALL abort_gcm('readaerosol_interp', 'Old aerosol file not possible',1)
+        END IF
+
+     ELSE 
+        vert_interp = .TRUE.
+     END IF
+
+!    Calendar initialisation
+!
+     DO i = 2, 13
+       month_len(i) = REAL(ioget_mon_len(year_cur, i-1))
+       CALL ymds2ju(year_cur, i-1, 1, 0.0, month_start(i))
+     ENDDO
+     month_len(1) = REAL(ioget_mon_len(year_cur-1, 12))
+     CALL ymds2ju(year_cur-1, 12, 1, 0.0, month_start(1))
+     month_len(14) = REAL(ioget_mon_len(year_cur+1, 1))
+     CALL ymds2ju(year_cur+1, 1, 1, 0.0, month_start(14))
+     month_mid(:) = month_start (:) + month_len(:)/2.
+     
+     if (debug) then
+       write(lunout,*)' month_len = ',month_len
+       write(lunout,*)' month_mid = ',month_mid
+     endif
+
+  END IF  ! IF ( (first .OR. iday==0) .AND. lnewday ) THEN 
+  
+!****************************************************************************************
+! - 2) Interpolate to the actual day.
+! - 3) Interpolate to the model vertical grid.
+!
+!****************************************************************************************
+
+  IF (lnewday) THEN ! only if new day
+!****************************************************************************************
+! 2) Interpolate to the actual day
+! 
+!****************************************************************************************
+    ! Find which months and days to use for time interpolation
+     nbr_tsteps = 12
+     IF (nbr_tsteps == 12) then
+       IF (jDay < month_mid(im+1)) THEN
+          im2=im-1
+          day2 = month_mid(im2+1)
+          day1 = month_mid(im+1)
+          IF (im2 <= 0) THEN
+             ! the month is january, thus the month before december
+             im2=12
+          END IF
+       ELSE
+          ! the second half of the month
+          im2=im+1
+          day2 = month_mid(im+1)
+          day1 = month_mid(im2+1)
+          IF (im2 > 12) THEN
+             ! the month is december, the following thus january
+             im2=1
+          ENDIF
+       END IF
+     ELSE IF (nbr_tsteps == 14) then
+       im = im + 1
+       IF (jDay < month_mid(im)) THEN
+          ! in the first half of the month use month before and actual month
+          im2=im-1
+          day2 = month_mid(im2)
+          day1 = month_mid(im)
+       ELSE
+          ! the second half of the month
+          im2=im+1
+          day2 = month_mid(im)
+          day1 = month_mid(im2)
+       END IF
+     ELSE
+       CALL abort_gcm('readaerosol_interp', 'number of months undefined',1)
+     ENDIF
+     if (debug) then
+       write(lunout,*)' jDay, day1, day2, im, im2 = ', jDay, day1, day2, im, im2
+     endif
+
+ 
+     ! Time interpolation, still on vertical source grid
+     ALLOCATE(tmp1(klon,klev_src), tmp2(klon,klev_src),stat=ierr)
+     IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 7',1)
+
+     ALLOCATE(pplay_src(klon,klev_src), stat=ierr)
+     IF (ierr /= 0) CALL abort_gcm('readaerosol_interp', 'pb in allocation 8',1)
+     
+
+     DO k=1,klev_src
+        DO i=1,klon 
+           tmp1(i,k) = &
+                var_year(i,k,im2,id_aero) - (jDay-day2)/(day1-day2) * &
+                (var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero))
+           
+           tmp2(i,k) = &
+                pi_var_year(i,k,im2,id_aero) - (jDay-day2)/(day1-day2) * &
+                (pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero))
+        END DO
+     END DO
+
+     ! Time interpolation for pressure at surface, still on vertical source grid
+     DO i=1,klon 
+        psurf_day(i) = &
+             psurf_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * &
+             (psurf_year(i,im2,id_aero) - psurf_year(i,im,id_aero))
+        
+        pi_psurf_day(i) = &
+             pi_psurf_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * &
+             (pi_psurf_year(i,im2,id_aero) - pi_psurf_year(i,im,id_aero))
+     END DO
+
+     ! Time interpolation for the load, still on vertical source grid
+     DO i=1,klon 
+        load_src(i) = &
+             load_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * &
+             (load_year(i,im2,id_aero) - load_year(i,im,id_aero))
+        
+        pi_load_src(i) = &
+             pi_load_year(i,im2,id_aero) - (jDay-day2)/(day1-day2) * &
+             (pi_load_year(i,im2,id_aero) - pi_load_year(i,im,id_aero))
+     END DO
+
+!****************************************************************************************
+! 3) Interpolate to the model vertical grid (target grid)
+!
+!****************************************************************************************
+
+     IF (vert_interp) THEN
+
+        ! - Interpolate variable tmp1 (on source grid) to var_day (on target grid)
+        !********************************************************************************
+        ! a) calculate pression at vertical levels for the source grid using the
+        !    hybrid-sigma coordinates ap and b and the surface pressure, variables from file.
+        DO k = 1, klev_src
+           DO i = 1, klon
+              pplay_src(i,k)= pt_ap(k) + pt_b(k)*psurf_day(i)
+           END DO
+        END DO
+        
+        IF (debug) THEN
+           CALL writefield_phy('psurf_day_src',psurf_day(:),1)
+           CALL writefield_phy('pplay_src',pplay_src(:,:),klev_src)
+           CALL writefield_phy('pplay',pplay(:,:),klev)
+           CALL writefield_phy('day_src',tmp1,klev_src)
+           CALL writefield_phy('pi_day_src',tmp2,klev_src)
+        END IF
+
+        ! b) vertical interpolation on pressure leveles
+        CALL pres2lev(tmp1(:,:), var_day(:,:,id_aero), klev_src, klev, pplay_src, pplay, &
+             1, klon, .FALSE.)
+        
+        IF (debug) CALL writefield_phy('day_tgt',var_day(:,:,id_aero),klev)
+        
+        ! c) adjust to conserve total aerosol mass load in the vertical pillar
+        !    Calculate the load in the actual pillar and compare with the load
+        !    read from aerosol file.
+        
+        ! Find the pressure difference in each model layer
+        DO k = 1, klev
+           DO i = 1, klon
+              delp(i,k) = paprs(i,k) - paprs (i,k+1)
+           END DO
+        END DO
+
+        ! Find the mass load in the actual pillar, on target grid
+        load_tgt(:) = 0.
+        DO k= 1, klev
+           DO i = 1, klon
+              zrho = pplay(i,k)/t_seri(i,k)/RD       ! [kg/m3]
+              volm = var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg]
+              load_tgt(i) = load_tgt(i) + 1/RG * volm *delp(i,k)
+           END DO
+        END DO
+        
+        ! Adjust, uniform
+        DO k = 1, klev
+           DO i = 1, klon
+              var_day(i,k,id_aero) = var_day(i,k,id_aero)*load_src(i)/load_tgt(i) 
+           END DO
+        END DO
+        
+        IF (debug) THEN
+           load_tgt_test(:) = 0.
+           DO k= 1, klev
+              DO i = 1, klon
+                 zrho = pplay(i,k)/t_seri(i,k)/RD       ! [kg/m3]
+                 volm = var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg]
+                 load_tgt_test(i) = load_tgt_test(i) + 1/RG * volm*delp(i,k)
+              END DO
+           END DO
+           
+           CALL writefield_phy('day_tgt2',var_day(:,:,id_aero),klev)
+           CALL writefield_phy('load_tgt',load_tgt(:),1)
+           CALL writefield_phy('load_tgt_test',load_tgt_test(:),1)
+           CALL writefield_phy('load_src',load_src(:),1)
+        END IF
+
+        ! - Interpolate variable tmp2 (source grid) to pi_var_day (target grid)
+        !********************************************************************************
+        ! a) calculate pression at vertical levels at source grid    
+        DO k = 1, klev_src
+           DO i = 1, klon
+              pplay_src(i,k)= pt_ap(k) + pt_b(k)*pi_psurf_day(i)
+           END DO
+        END DO
+
+        IF (debug) THEN
+           CALL writefield_phy('pi_psurf_day_src',pi_psurf_day(:),1)
+           CALL writefield_phy('pi_pplay_src',pplay_src(:,:),klev_src)
+        END IF
+
+        ! b) vertical interpolation on pressure leveles
+        CALL pres2lev(tmp2(:,:), pi_var_day(:,:,id_aero), klev_src, klev, pplay_src, pplay, &
+             1, klon, .FALSE.)
+
+        IF (debug) CALL writefield_phy('pi_day_tgt',pi_var_day(:,:,id_aero),klev)
+
+        ! c) adjust to conserve total aerosol mass load in the vertical pillar
+        !    Calculate the load in the actual pillar and compare with the load
+        !    read from aerosol file.
+
+        ! Find the load in the actual pillar, on target grid
+        load_tgt(:) = 0.
+        DO k = 1, klev
+           DO i = 1, klon
+              zrho = pplay(i,k)/t_seri(i,k)/RD          ! [kg/m3]
+              volm = pi_var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg]
+              load_tgt(i) = load_tgt(i) + 1/RG * volm * delp(i,k)
+           END DO
+        END DO
+
+        DO k = 1, klev
+           DO i = 1, klon
+              pi_var_day(i,k,id_aero) = pi_var_day(i,k,id_aero)*pi_load_src(i)/load_tgt(i)
+           END DO
+        END DO
+
+        IF (debug) THEN
+           load_tgt_test(:) = 0.
+           DO k = 1, klev
+              DO i = 1, klon
+                 zrho = pplay(i,k)/t_seri(i,k)/RD          ! [kg/m3]
+                 volm = pi_var_day(i,k,id_aero)*1.E-9/zrho ! [kg/kg]
+                 load_tgt_test(i) = load_tgt_test(i) + 1/RG * volm * delp(i,k)
+              END DO
+           END DO
+           CALL writefield_phy('pi_day_tgt2',pi_var_day(:,:,id_aero),klev)
+           CALL writefield_phy('pi_load_tgt',load_tgt(:),1)
+           CALL writefield_phy('pi_load_tgt_test',load_tgt_test(:),1)
+           CALL writefield_phy('pi_load_src',pi_load_src(:),1)
+        END IF
+
+
+     ELSE   ! No vertical interpolation done
+
+        var_day(:,:,id_aero)    = tmp1(:,:)
+        pi_var_day(:,:,id_aero) = tmp2(:,:)
+
+     END IF ! vert_interp
+
+
+     ! Deallocation
+     DEALLOCATE(tmp1, tmp2, pplay_src, stat=ierr)
+
+!****************************************************************************************
+! 4) Test for negative mass values
+!
+!****************************************************************************************
+     IF (MINVAL(var_day(:,:,id_aero)) < 0.) THEN
+        DO k=1,klev
+           DO i=1,klon 
+              ! Test for var_day
+              IF (var_day(i,k,id_aero) < 0.) THEN
+                 IF (jDay-day2 < 0.) WRITE(lunout,*) 'jDay-day2=',jDay-day2
+                 IF (var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero) < 0.) THEN
+                    WRITE(lunout,*) trim(name_aero(id_aero)),'(i,k,im2)-', &
+                         trim(name_aero(id_aero)),'(i,k,im)=',           &
+                         var_year(i,k,im2,id_aero) - var_year(i,k,im,id_aero)
+                 END IF
+                 WRITE(lunout,*) 'stop for aerosol : ',name_aero(id_aero)
+                 WRITE(lunout,*) 'day1, day2, jDay = ', day1, day2, jDay 
+                 CALL abort_gcm('readaerosol_interp','Error in interpolation 1',1)
+              END IF
+           END DO 
+        END DO
+     END IF
+
+     IF (MINVAL(pi_var_day(:,:,id_aero)) < 0. ) THEN
+        DO k=1, klev
+           DO i=1,klon
+              ! Test for pi_var_day
+              IF (pi_var_day(i,k,id_aero) < 0.) THEN
+                 IF (jDay-day2 < 0.) WRITE(lunout,*) 'jDay-day2=',jDay-day2
+                 IF (pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero) < 0.) THEN
+                    WRITE(lunout,*) trim(name_aero(id_aero)),'(i,k,im2)-', &
+                         trim(name_aero(id_aero)),'(i,k,im)=',           &
+                         pi_var_year(i,k,im2,id_aero) - pi_var_year(i,k,im,id_aero)
+                 END IF
+                 
+                 WRITE(lunout,*) 'stop for aerosol : ',name_aero(id_aero)
+                 CALL abort_gcm('readaerosol_interp','Error in interpolation 2',1)
+              END IF
+           END DO
+        END DO
+     END IF
+
+  END IF ! lnewday
+
+!****************************************************************************************
+! Copy output from saved variables
+!
+!****************************************************************************************
+
+  mass_out(:,:)    = var_day(:,:,id_aero) 
+  pi_mass_out(:,:) = pi_var_day(:,:,id_aero)
+  
+END SUBROUTINE readaerosol_interp
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/readaerosol_optic.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/readaerosol_optic.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/readaerosol_optic.F90	(revision 17)
@@ -0,0 +1,224 @@
+! $Id$
+!
+SUBROUTINE readaerosol_optic(debut, new_aod, flag_aerosol, itap, rjourvrai, &
+     pdtphys, pplay, paprs, t_seri, rhcl, presnivs, &
+     mass_solu_aero, mass_solu_aero_pi, &
+     tau_aero, piz_aero, cg_aero, &
+     tausum_aero, tau3d_aero )
+
+! This routine will :
+! 1) recevie the aerosols(already read and interpolated) corresponding to flag_aerosol
+! 2) calculate the optical properties for the aerosols
+!
+  
+  USE dimphy
+  USE aero_mod
+  USE phys_local_var_mod, only: sconcso4,sconcoa,sconcbc,sconcss,sconcdust, &
+      concso4,concoa,concbc,concss,concdust,loadso4,loadoa,loadbc,loadss,loaddust, &
+      load_tmp1,load_tmp2,load_tmp3,load_tmp4,load_tmp5,load_tmp6,load_tmp7
+  IMPLICIT NONE
+
+! Input arguments
+!****************************************************************************************
+  LOGICAL, INTENT(IN)                      :: debut
+  LOGICAL, INTENT(IN)                      :: new_aod
+  INTEGER, INTENT(IN)                      :: flag_aerosol
+  INTEGER, INTENT(IN)                      :: itap
+  REAL, INTENT(IN)                         :: rjourvrai
+  REAL, INTENT(IN)                         :: pdtphys
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: pplay
+  REAL, DIMENSION(klon,klev+1), INTENT(IN) :: paprs
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: t_seri
+  REAL, DIMENSION(klon,klev), INTENT(IN)   :: rhcl   ! humidite relative ciel clair
+  REAL, DIMENSION(klev), INTENT(IN)        :: presnivs
+
+! Output arguments
+!****************************************************************************************
+  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero    ! Total mass for all soluble aerosols
+  REAL, DIMENSION(klon,klev), INTENT(OUT)     :: mass_solu_aero_pi !     -"-     preindustrial values
+  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: tau_aero    ! Aerosol optical thickness
+  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: piz_aero    ! Single scattering albedo aerosol
+  REAL, DIMENSION(klon,klev,naero_grp,nbands), INTENT(OUT) :: cg_aero     ! asymmetry parameter aerosol
+  REAL, DIMENSION(klon,nwave,naero_spc), INTENT(OUT)       :: tausum_aero
+  REAL, DIMENSION(klon,klev,nwave,naero_spc), INTENT(OUT)  :: tau3d_aero
+
+! Local variables
+!****************************************************************************************
+  REAL, DIMENSION(klon)        :: aerindex ! POLDER aerosol index 
+  REAL, DIMENSION(klon,klev)   :: sulfate  ! SO4 aerosol concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: bcsol    ! BC soluble concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: bcins    ! BC insoluble concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: pomsol   ! POM soluble concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: pomins   ! POM insoluble concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: cidust    ! DUST aerosol concentration  [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: sscoarse  ! SS Coarse concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: sssupco   ! SS Super Coarse concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: ssacu     ! SS Acumulation concentration [ug/m3]
+  REAL, DIMENSION(klon,klev)   :: sulfate_pi
+  REAL, DIMENSION(klon,klev)   :: bcsol_pi
+  REAL, DIMENSION(klon,klev)   :: bcins_pi
+  REAL, DIMENSION(klon,klev)   :: pomsol_pi
+  REAL, DIMENSION(klon,klev)   :: pomins_pi
+  REAL, DIMENSION(klon,klev)   :: cidust_pi
+  REAL, DIMENSION(klon,klev)   :: sscoarse_pi
+  REAL, DIMENSION(klon,klev)   :: sssupco_pi
+  REAL, DIMENSION(klon,klev)   :: ssacu_pi
+  REAL, DIMENSION(klon,klev)   :: pdel
+  REAL, DIMENSION(klon,klev,naero_spc) :: m_allaer
+  REAL, DIMENSION(klon,klev,naero_spc) :: m_allaer_pi !RAF  
+!  REAL, DIMENSION(klon,naero_tot)      :: fractnat_allaer !RAF delete??
+
+  INTEGER :: k, i
+  
+!****************************************************************************************
+! 1) Get aerosol mass
+!    
+!****************************************************************************************
+! Read and interpolate sulfate
+  IF ( flag_aerosol .EQ. 1 .OR. &
+       flag_aerosol .EQ. 6 ) THEN 
+
+     CALL readaerosol_interp(id_ASSO4M, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sulfate, sulfate_pi,loadso4)
+  ELSE
+     sulfate(:,:) = 0. ; sulfate_pi(:,:) = 0.
+     loadso4=0.
+  END IF
+
+! Read and interpolate bcsol and bcins
+  IF ( flag_aerosol .EQ. 2 .OR. &
+       flag_aerosol .EQ. 6 ) THEN 
+
+     ! Get bc aerosol distribution 
+     CALL readaerosol_interp(id_ASBCM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcsol, bcsol_pi, load_tmp1 )
+     CALL readaerosol_interp(id_AIBCM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, bcins, bcins_pi, load_tmp2 )
+     loadbc(:)=load_tmp1(:)+load_tmp2(:)
+  ELSE
+     bcsol(:,:) = 0. ; bcsol_pi(:,:) = 0.
+     bcins(:,:) = 0. ; bcins_pi(:,:) = 0.
+     loadbc=0.
+  END IF
+
+
+! Read and interpolate pomsol and pomins
+  IF ( flag_aerosol .EQ. 3 .OR. &
+       flag_aerosol .EQ. 6 ) THEN
+
+     CALL readaerosol_interp(id_ASPOMM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomsol, pomsol_pi, load_tmp3)
+     CALL readaerosol_interp(id_AIPOMM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, pomins, pomins_pi, load_tmp4)
+     loadoa(:)=load_tmp3(:)+load_tmp4(:)
+  ELSE
+     pomsol(:,:) = 0. ; pomsol_pi(:,:) = 0.
+     pomins(:,:) = 0. ; pomins_pi(:,:) = 0.
+     loadoa=0.
+  END IF
+
+
+! Read and interpolate csssm, ssssm, assssm
+  IF (flag_aerosol .EQ. 4 .OR. &
+      flag_aerosol .EQ. 6 ) THEN 
+
+      CALL readaerosol_interp(id_SSSSM ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sssupco, sssupco_pi, load_tmp5) 
+      CALL readaerosol_interp(id_CSSSM ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, sscoarse,sscoarse_pi, load_tmp6) 
+      CALL readaerosol_interp(id_ASSSM ,itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, ssacu, ssacu_pi, load_tmp7) 
+     loadss(:)=load_tmp5(:)+load_tmp6(:)+load_tmp7(:)
+  ELSE
+     sscoarse(:,:) = 0. ; sscoarse_pi(:,:) = 0. 
+     ssacu(:,:)    = 0. ; ssacu_pi(:,:) = 0. 
+     sssupco(:,:)  = 0. ; sssupco_pi = 0. 
+     loadss=0.
+  ENDIF
+
+! Read and interpolate cidustm
+  IF (flag_aerosol .EQ. 5 .OR.  &
+      flag_aerosol .EQ. 6 ) THEN 
+
+      CALL readaerosol_interp(id_CIDUSTM, itap, pdtphys, rjourvrai, debut, pplay, paprs, t_seri, cidust, cidust_pi, loaddust) 
+
+  ELSE
+      cidust(:,:) = 0. ; cidust_pi(:,:) = 0. 
+      loaddust=0.
+  ENDIF
+
+!
+! Store all aerosols in one variable
+!
+  m_allaer(:,:,id_ASBCM)  = bcsol(:,:)        ! ASBCM
+  m_allaer(:,:,id_ASPOMM) = pomsol(:,:)       ! ASPOMM
+  m_allaer(:,:,id_ASSO4M) = sulfate(:,:)      ! ASSO4M (= SO4) 
+  m_allaer(:,:,id_CSSO4M) = 0.                ! CSSO4M 
+  m_allaer(:,:,id_SSSSM)  = sssupco(:,:)      ! SSSSM
+  m_allaer(:,:,id_CSSSM)  = sscoarse(:,:)     ! CSSSM
+  m_allaer(:,:,id_ASSSM)  = ssacu(:,:)        ! ASSSM
+  m_allaer(:,:,id_CIDUSTM)= cidust(:,:)       ! CIDUSTM
+  m_allaer(:,:,id_AIBCM)  = bcins(:,:)        ! AIBCM
+  m_allaer(:,:,id_AIPOMM) = pomins(:,:)       ! AIPOMM
+
+!RAF
+  m_allaer_pi(:,:,1)  = bcsol_pi(:,:)        ! ASBCM pre-ind
+  m_allaer_pi(:,:,2)  = pomsol_pi(:,:)       ! ASPOMM pre-ind
+  m_allaer_pi(:,:,3)  = sulfate_pi(:,:)      ! ASSO4M (= SO4) pre-ind
+  m_allaer_pi(:,:,4)  = 0.                ! CSSO4M pre-ind
+  m_allaer_pi(:,:,5)  = sssupco_pi(:,:)      ! SSSSM pre-ind
+  m_allaer_pi(:,:,6)  = sscoarse_pi(:,:)     ! CSSSM pre-ind
+  m_allaer_pi(:,:,7)  = ssacu_pi(:,:)        ! ASSSM pre-ind
+  m_allaer_pi(:,:,8)  = cidust_pi(:,:)       ! CIDUSTM pre-ind
+  m_allaer_pi(:,:,9)  = bcins_pi(:,:)        ! AIBCM pre-ind
+  m_allaer_pi(:,:,10) = pomins_pi(:,:)       ! AIPOMM pre-ind
+
+!
+! Calculate the total mass of all soluble aersosols
+!
+  mass_solu_aero(:,:)    = sulfate(:,:)    + bcsol(:,:)    + pomsol(:,:) !   + &
+!       sscoarse(:,:)    + ssacu(:,:)    + sssupco(:,:) 
+  mass_solu_aero_pi(:,:) = sulfate_pi(:,:) + bcsol_pi(:,:) + pomsol_pi(:,:) ! + &
+!       sscoarse_pi(:,:) + ssacu_pi(:,:) + sssupco_pi(:,:)
+
+!****************************************************************************************
+! 2) Calculate optical properties for the aerosols
+!
+!****************************************************************************************
+  DO k = 1, klev
+     DO i = 1, klon
+        pdel(i,k) = paprs(i,k) - paprs (i,k+1)
+     END DO
+  END DO
+
+  IF (new_aod) THEN 
+
+! RAF delete??     fractnat_allaer(:,:) = 0.
+! RAF fractnat_allaer -> m_allaer_pi
+
+     CALL aeropt_2bands( &
+          pdel, m_allaer, pdtphys, rhcl, & 
+          tau_aero, piz_aero, cg_aero,   &
+          m_allaer_pi, flag_aerosol, &
+          pplay, t_seri, presnivs) 
+     
+     ! aeropt_5wv only for validation and diagnostics.
+     CALL aeropt_5wv(                    &
+          pdel, m_allaer,                &
+          pdtphys, rhcl, aerindex,       & 
+          flag_aerosol, pplay, t_seri,   &
+          tausum_aero, tau3d_aero, presnivs)
+  ELSE
+
+     CALL aeropt(pplay, paprs, t_seri, sulfate, rhcl, &
+          tau_aero(:,:,id_ASSO4M,:), piz_aero(:,:,id_ASSO4M,:), cg_aero(:,:,id_ASSO4M,:), aerindex)
+     
+  END IF
+
+
+! Diagnostics calculation for CMIP5 protocol
+  sconcso4(:)=m_allaer(:,1,id_ASSO4M)*1.e-9
+  sconcoa(:)=(m_allaer(:,1,id_ASPOMM)+m_allaer(:,1,id_AIPOMM))*1.e-9
+  sconcbc(:)=(m_allaer(:,1,id_ASBCM)+m_allaer(:,1,id_AIBCM))*1.e-9
+  sconcss(:)=(m_allaer(:,1,id_ASSSM)+m_allaer(:,1,id_CSSSM)+m_allaer(:,1,id_SSSSM))*1.e-9
+  sconcdust(:)=m_allaer(:,1,id_CIDUSTM)*1.e-9
+  concso4(:,:)=m_allaer(:,:,id_ASSO4M)*1.e-9
+  concoa(:,:)=(m_allaer(:,:,id_ASPOMM)+m_allaer(:,:,id_AIPOMM))*1.e-9
+  concbc(:,:)=(m_allaer(:,:,id_ASBCM)+m_allaer(:,:,id_AIBCM))*1.e-9
+  concss(:,:)=(m_allaer(:,:,id_ASSSM)+m_allaer(:,:,id_CSSSM)+m_allaer(:,:,id_SSSSM))*1.e-9
+  concdust(:,:)=m_allaer(:,:,id_CIDUSTM)*1.e-9
+
+
+END SUBROUTINE readaerosol_optic
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/readaerosolstrato.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/readaerosolstrato.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/readaerosolstrato.F90	(revision 17)
@@ -0,0 +1,172 @@
+subroutine readaerosolstrato(debut)
+
+    use netcdf95, only: nf95_close, nf95_gw_var, nf95_inq_dimid, & 
+                        nf95_inq_varid, nf95_open
+    use netcdf, only: nf90_get_var, nf90_noerr, nf90_nowrite
+
+    USE phys_cal_mod, ONLY : mth_cur
+    USE mod_grid_phy_lmdz
+    USE mod_phys_lmdz_mpi_data, ONLY :  is_mpi_root
+    USE mod_phys_lmdz_para 
+    USE phys_state_var_mod
+    USE phys_local_var_mod
+    USE aero_mod
+    USE dimphy
+
+    implicit none
+
+    include "YOMCST.h"
+    include "dimensions.h"
+
+! Variable input
+    logical debut
+
+! Variables locales
+    integer n_lat   ! number of latitudes in the input data
+    integer n_lon   ! number of longitudes in the input data
+    integer n_lev   ! number of levels in the input data
+    integer n_month ! number of months in the input data
+    real, pointer:: latitude(:)
+    real, pointer:: longitude(:)
+    real, pointer:: time(:)
+    real, pointer:: lev(:)
+    integer i, k, band, wave
+    integer, save :: mth_pre
+
+    real, allocatable, dimension(:,:), save :: tau_aer_strat
+!$OMP THREADPRIVATE(tau_aer_strat)
+
+! Champs reconstitues
+    real, allocatable:: tauaerstrat(:, :, :, :)
+    real, allocatable:: tauaerstrat_mois(:, :, :)
+    real, allocatable:: tauaerstrat_mois_glo(:, :)
+    real, allocatable:: tauaerstrat_mois_glo_bands(:,:,:)
+
+! For NetCDF:
+    integer ncid_in  ! IDs for input files
+    integer varid, ncerr
+
+! Stratospheric aerosols optical properties
+! alpha_strat over the 2 bands is normalised by the 550 nm extinction coefficient
+! alpha_strat_wave is *not* normalised by the 550 nm extinction coefficient
+    real, dimension(nbands) :: alpha_strat, piz_strat, cg_strat
+    data alpha_strat/0.9922547, 0.7114912 /
+    data piz_strat  /0.9999998, 0.99762493/
+    data cg_strat   /0.73107845,0.73229635/
+    real, dimension(nwave) :: alpha_strat_wave
+    data alpha_strat_wave/3.36780953,3.34667683,3.20444202,3.0293026,2.82108808/
+
+!--------------------------------------------------------
+
+    IF (.not.ALLOCATED(tau_aer_strat)) ALLOCATE(tau_aer_strat(klon,klev))
+
+    IF (is_mpi_root) THEN
+
+    IF (debut.OR.mth_cur.NE.mth_pre) THEN
+
+    IF (nbands.NE.2) THEN 
+        print *,'nbands doit etre egal a 2 dans readaerosolstrat'
+        STOP
+    ENDIF
+
+    CALL nf95_open("taustrat.nc", nf90_nowrite, ncid_in)
+
+    CALL nf95_inq_varid(ncid_in, "LEV", varid)
+    CALL nf95_gw_var(ncid_in, varid, lev)
+    n_lev = size(lev)
+    IF (n_lev.NE.klev) THEN 
+       print *,'Le nombre de niveaux n est pas egal a klev'
+       STOP
+    ENDIF
+
+    CALL nf95_inq_varid(ncid_in, "LAT", varid)
+    CALL nf95_gw_var(ncid_in, varid, latitude)
+    n_lat = size(latitude)
+    print *, 'LAT aerosol strato=', n_lat, latitude
+    IF (n_lat.NE.jjm+1) THEN 
+       print *,'Le nombre de lat n est pas egal a jjm+1'
+       STOP
+    ENDIF
+
+    CALL nf95_inq_varid(ncid_in, "LON", varid)
+    CALL nf95_gw_var(ncid_in, varid, longitude)
+    n_lon = size(longitude)
+    print *, 'LON aerosol strato=', n_lon, longitude
+    IF (n_lon.NE.iim) THEN 
+       print *,'Le nombre de lon n est pas egal a iim'
+       STOP
+    ENDIF
+
+    CALL nf95_inq_varid(ncid_in, "TIME", varid)
+    CALL nf95_gw_var(ncid_in, varid, time)
+    n_month = size(time)
+    print *, 'TIME aerosol strato=', n_month, time
+    IF (n_month.NE.12) THEN 
+       print *,'Le nombre de month n est pas egal a 12'
+       STOP
+    ENDIF
+
+    ALLOCATE(tauaerstrat(n_lon, n_lat, n_lev, n_month))
+    ALLOCATE(tauaerstrat_mois(n_lon, n_lat, n_lev))
+    ALLOCATE(tauaerstrat_mois_glo(klon_glo, n_lev))
+    ALLOCATE(tauaerstrat_mois_glo_bands(klon_glo, n_lev,nbands))
+
+!--reading stratospheric AOD at 550 nm
+    CALL nf95_inq_varid(ncid_in, "TAUSTRAT", varid)
+    ncerr = nf90_get_var(ncid_in, varid, tauaerstrat)
+    print *,'code erreur readaerosolstrato=', ncerr, varid
+
+    CALL nf95_close(ncid_in)
+
+!---select the correct month
+    IF (mth_cur.LT.1.OR.mth_cur.GT.12) THEN
+      print *,'probleme avec le mois dans readaerosolstrat =', mth_cur
+    ENDIF
+    tauaerstrat_mois(:,:,:) = tauaerstrat(:,:,:,mth_cur)
+
+!---reduce to a klon_glo grid 
+    CALL grid2dTo1d_glo(tauaerstrat_mois,tauaerstrat_mois_glo)
+
+!--scatter on all proc
+    CALL scatter(tauaerstrat_mois_glo,tau_aer_strat)
+
+    DEALLOCATE(tauaerstrat)
+    DEALLOCATE(tauaerstrat_mois)
+    DEALLOCATE(tauaerstrat_mois_glo)
+  
+    mth_pre=mth_cur
+
+    ENDIF !--debut ou nouveau mois
+
+    ENDIF !--is_mpi_root
+
+!--total vertical aod at the 5 wavelengths
+    DO wave=1, nwave
+    DO k=1, klev
+    tausum_aero(:,wave,id_strat)=tausum_aero(:,wave,id_strat)+tau_aer_strat(:,k)*alpha_strat_wave(wave)/alpha_strat_wave(2)
+    ENDDO
+    ENDDO
+
+!--weighted average for cg, piz and tau, adding strat aerosols on top of tropospheric ones
+    DO band=1, nbands
+!--anthropogenic aerosols bands 1 and 2
+    cg_aero(:,:,3,band)  = ( cg_aero(:,:,3,band)*piz_aero(:,:,3,band)*tau_aero(:,:,3,band) +          &
+                             cg_strat(band)*piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:) ) /  &
+                             MAX( piz_aero(:,:,3,band)*tau_aero(:,:,3,band) +                         &
+                                  piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:), 1.e-15 )
+    piz_aero(:,:,3,band)  = ( piz_aero(:,:,3,band)*tau_aero(:,:,3,band) +                             &
+                              piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:) ) /                &
+                              MAX( tau_aero(:,:,3,band) + alpha_strat(band)*tau_aer_strat(:,:), 1.e-15 )
+    tau_aero(:,:,3,band)  = tau_aero(:,:,3,band) + alpha_strat(band)*tau_aer_strat(:,:)
+!--natural aerosols bands 1 and 2
+    cg_aero(:,:,2,band)  = ( cg_aero(:,:,2,band)*piz_aero(:,:,2,band)*tau_aero(:,:,2,band) +          &
+                             cg_strat(band)*piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:) ) /  &
+                             MAX( piz_aero(:,:,2,band)*tau_aero(:,:,2,band) +                         &
+                                  piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:), 1.e-15 )
+    piz_aero(:,:,2,band)  = ( piz_aero(:,:,2,band)*tau_aero(:,:,2,band) +                             & 
+                              piz_strat(band)*alpha_strat(band)*tau_aer_strat(:,:) ) /                &
+                              MAX( tau_aero(:,:,2,band) + alpha_strat(band)*tau_aer_strat(:,:),1.e-15 )
+    tau_aero(:,:,2,band)  = tau_aero(:,:,2,band) + alpha_strat(band)*tau_aer_strat(:,:)
+    ENDDO
+
+end subroutine readaerosolstrato
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/regdim.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/regdim.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/regdim.h	(revision 17)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+      INTEGER i1_deb, i1_fin
+      INTEGER i2_deb, i2_fin
+!ccc      PARAMETER (i1_deb=21, i1_fin=40)
+!ccc      PARAMETER (i2_deb=41, i2_fin=44)
+!cccc      PARAMETER (i1_deb=47, i1_fin=77)
+!cccc      PARAMETER (i2_deb=78, i2_fin=79)
+      PARAMETER (i1_deb=16, i1_fin=30)
+      PARAMETER (i2_deb=31, i2_fin=33)
+!c
+      INTEGER j_deb, j_fin
+!ccc      PARAMETER (j_deb=29, j_fin=61)
+!cccc      PARAMETER (j_deb=21, j_fin=51)
+      PARAMETER (j_deb=18, j_fin=39)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/regr1_lint_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/regr1_lint_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/regr1_lint_m.F90	(revision 17)
@@ -0,0 +1,98 @@
+! $Id$
+module regr1_lint_m
+
+  ! Author: Lionel GUEZ
+
+  implicit none
+
+  interface regr1_lint
+     ! Each procedure regrids by linear interpolation.
+     ! The regridding operation is done on the first dimension of the
+     ! input array.
+     ! The difference betwwen the procedures is the rank of the first argument.
+     module procedure regr11_lint, regr12_lint
+  end interface
+
+  private
+  public regr1_lint
+
+contains
+
+  function regr11_lint(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 1.
+
+    use assert_eq_m, only: assert_eq
+    use interpolation, only: hunt !!, polint
+
+    real, intent(in):: vs(:)
+    ! (values of the function at source points "xs")
+
+    real, intent(in):: xs(:)
+    ! (abscissas of points in source grid, in strictly monotonic order)
+
+    real, intent(in):: xt(:)
+    ! (abscissas of points in target grid)
+
+    real vt(size(xt)) ! values of the function on the target grid
+
+    ! Variables local to the procedure:
+    integer is, it, ns
+    integer is_b ! "is" bound between 1 and "ns - 1"
+
+    !--------------------------------------
+
+    ns = assert_eq(size(vs), size(xs), "regr11_lint ns")
+
+    is = -1 ! go immediately to bisection on first call to "hunt"
+
+    do it = 1, size(xt)
+       call hunt(xs, xt(it), is)
+       is_b = min(max(is, 1), ns - 1)
+!!       call polint(xs(is_b:is_b+1), vs(is_b:is_b+1), xt(it), vt(it))
+       vt(it) = ((xs(is_b+1) - xt(it)) * vs(is_b) &
+            + (xt(it) - xs(is_b)) * vs(is_b+1)) / (xs(is_b+1) - xs(is_b))
+    end do
+
+  end function regr11_lint
+
+  !*********************************************************
+
+  function regr12_lint(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 2.
+
+    use assert_eq_m, only: assert_eq
+    use interpolation, only: hunt
+
+    real, intent(in):: vs(:, :)
+    ! (values of the function at source points "xs")
+
+    real, intent(in):: xs(:)
+    ! (abscissas of points in source grid, in strictly monotonic order)
+
+    real, intent(in):: xt(:)
+    ! (abscissas of points in target grid)
+
+    real vt(size(xt), size(vs, 2)) ! values of the function on the target grid
+
+    ! Variables local to the procedure:
+    integer is, it, ns
+    integer is_b ! "is" bound between 1 and "ns - 1"
+
+    !--------------------------------------
+
+    ns = assert_eq(size(vs, 1), size(xs), "regr12_lint ns")
+
+    is = -1 ! go immediately to bisection on first call to "hunt"
+
+    do it = 1, size(xt)
+       call hunt(xs, xt(it), is)
+       is_b = min(max(is, 1), ns - 1)
+       vt(it, :) = ((xs(is_b+1) - xt(it)) * vs(is_b, :) &
+            + (xt(it) - xs(is_b)) * vs(is_b+1, :)) / (xs(is_b+1) - xs(is_b))
+    end do
+
+  end function regr12_lint
+
+end module regr1_lint_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/regr1_step_av_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/regr1_step_av_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/regr1_step_av_m.F90	(revision 17)
@@ -0,0 +1,268 @@
+! $Id$
+module regr1_step_av_m
+
+  ! Author: Lionel GUEZ
+
+  implicit none
+
+  interface regr1_step_av
+
+     ! Each procedure regrids a step function by averaging it.
+     ! The regridding operation is done on the first dimension of the
+     ! input array.
+     ! Source grid contains edges of steps.
+     ! Target grid contains positions of cell edges.
+     ! The target grid should be included in the source grid: no
+     ! extrapolation is allowed.
+     ! The difference between the procedures is the rank of the first argument.
+
+     module procedure regr11_step_av, regr12_step_av, regr13_step_av, &
+          regr14_step_av
+  end interface
+
+  private
+  public regr1_step_av
+
+contains
+
+  function regr11_step_av(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 1.
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+    use interpolation, only: locate
+
+    real, intent(in):: vs(:) ! values of steps on the source grid
+    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
+
+    real, intent(in):: xs(:)
+    ! (edges of of steps on the source grid, in strictly increasing order)
+
+    real, intent(in):: xt(:)
+    ! (edges of cells of the target grid, in strictly increasing order)
+
+    real vt(size(xt) - 1) ! average values on the target grid
+    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
+
+    ! Variables local to the procedure:
+    integer is, it, ns, nt
+    real left_edge
+
+    !---------------------------------------------
+
+    ns = assert_eq(size(vs), size(xs) - 1, "regr11_step_av ns")
+    nt = size(xt) - 1
+    ! Quick check on sort order:
+    call assert(xs(1) < xs(2), "regr11_step_av xs bad order")
+    call assert(xt(1) < xt(2), "regr11_step_av xt bad order")
+
+    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
+         "regr11_step_av extrapolation")
+
+    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+    do it = 1, nt
+       ! 1 <= is <= ns
+       ! xs(is) <= xt(it) < xs(is + 1)
+       ! Compute "vt(it)":
+       left_edge = xt(it)
+       vt(it) = 0.
+       do while (xs(is + 1) < xt(it + 1))
+          ! 1 <= is <= ns - 1
+          vt(it) = vt(it) + (xs(is + 1) - left_edge) * vs(is)
+          is = is + 1
+          left_edge = xs(is)
+       end do
+       ! 1 <= is <= ns
+       vt(it) = (vt(it) + (xt(it + 1) - left_edge) * vs(is)) &
+            / (xt(it + 1) - xt(it))
+       if (xs(is + 1) == xt(it + 1)) is = is + 1
+       ! 1 <= is <= ns .or. it == nt
+    end do
+
+  end function regr11_step_av
+
+  !********************************************
+
+  function regr12_step_av(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 2.
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+    use interpolation, only: locate
+
+    real, intent(in):: vs(:, :) ! values of steps on the source grid
+    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
+
+    real, intent(in):: xs(:)
+    ! (edges of steps on the source grid, in strictly increasing order)
+
+    real, intent(in):: xt(:)
+    ! (edges of cells of the target grid, in strictly increasing order)
+
+    real vt(size(xt) - 1, size(vs, 2)) ! average values on the target grid
+    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
+
+    ! Variables local to the procedure:
+    integer is, it, ns, nt
+    real left_edge
+
+    !---------------------------------------------
+
+    ns = assert_eq(size(vs, 1), size(xs) - 1, "regr12_step_av ns")
+    nt = size(xt) - 1
+
+    ! Quick check on sort order:
+    call assert(xs(1) < xs(2), "regr12_step_av xs bad order")
+    call assert(xt(1) < xt(2), "regr12_step_av xt bad order")
+
+    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
+         "regr12_step_av extrapolation")
+
+    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+    do it = 1, nt
+       ! 1 <= is <= ns
+       ! xs(is) <= xt(it) < xs(is + 1)
+       ! Compute "vt(it, :)":
+       left_edge = xt(it)
+       vt(it, :) = 0.
+       do while (xs(is + 1) < xt(it + 1))
+          ! 1 <= is <= ns - 1
+          vt(it, :) = vt(it, :) + (xs(is + 1) - left_edge) * vs(is, :)
+          is = is + 1
+          left_edge = xs(is)
+       end do
+       ! 1 <= is <= ns
+       vt(it, :) = (vt(it, :) + (xt(it + 1) - left_edge) * vs(is, :)) &
+            / (xt(it + 1) - xt(it))
+       if (xs(is + 1) == xt(it + 1)) is = is + 1
+       ! 1 <= is <= ns .or. it == nt
+    end do
+
+  end function regr12_step_av
+
+  !********************************************
+
+  function regr13_step_av(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 3.
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+    use interpolation, only: locate
+
+    real, intent(in):: vs(:, :, :) ! values of steps on the source grid
+    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
+
+    real, intent(in):: xs(:)
+    ! (edges of steps on the source grid, in strictly increasing order)
+
+    real, intent(in):: xt(:)
+    ! (edges of cells of the target grid, in strictly increasing order)
+
+    real vt(size(xt) - 1, size(vs, 2), size(vs, 3)) 
+    ! (average values on the target grid)
+    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
+
+    ! Variables local to the procedure:
+    integer is, it, ns, nt
+    real left_edge
+
+    !---------------------------------------------
+
+    ns = assert_eq(size(vs, 1), size(xs) - 1, "regr13_step_av ns")
+    nt = size(xt) - 1
+
+    ! Quick check on sort order:
+    call assert(xs(1) < xs(2), "regr13_step_av xs bad order")
+    call assert(xt(1) < xt(2), "regr13_step_av xt bad order")
+
+    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
+         "regr13_step_av extrapolation")
+
+    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+    do it = 1, nt
+       ! 1 <= is <= ns
+       ! xs(is) <= xt(it) < xs(is + 1)
+       ! Compute "vt(it, :, :)":
+       left_edge = xt(it)
+       vt(it, :, :) = 0.
+       do while (xs(is + 1) < xt(it + 1))
+          ! 1 <= is <= ns - 1
+          vt(it, :, :) = vt(it, :, :) + (xs(is + 1) - left_edge) * vs(is, :, :)
+          is = is + 1
+          left_edge = xs(is)
+       end do
+       ! 1 <= is <= ns
+       vt(it, :, :) = (vt(it, :, :) &
+            + (xt(it + 1) - left_edge) * vs(is, :, :)) / (xt(it + 1) - xt(it))
+       if (xs(is + 1) == xt(it + 1)) is = is + 1
+       ! 1 <= is <= ns .or. it == nt
+    end do
+
+  end function regr13_step_av
+
+  !********************************************
+
+  function regr14_step_av(vs, xs, xt) result(vt)
+
+    ! "vs" has rank 4.
+
+    use assert_eq_m, only: assert_eq
+    use assert_m, only: assert
+    use interpolation, only: locate
+
+    real, intent(in):: vs(:, :, :, :) ! values of steps on the source grid
+    ! (Step "is" is between "xs(is)" and "xs(is + 1)".)
+
+    real, intent(in):: xs(:)
+    ! (edges of steps on the source grid, in strictly increasing order)
+
+    real, intent(in):: xt(:)
+    ! (edges of cells of the target grid, in strictly increasing order)
+
+    real vt(size(xt) - 1, size(vs, 2), size(vs, 3), size(vs, 4))
+    ! (average values on the target grid)
+    ! (Cell "it" is between "xt(it)" and "xt(it + 1)".)
+
+    ! Variables local to the procedure:
+    integer is, it, ns, nt
+    real left_edge
+
+    !---------------------------------------------
+
+    ns = assert_eq(size(vs, 1), size(xs) - 1, "regr14_step_av ns")
+    nt = size(xt) - 1
+
+    ! Quick check on sort order:
+    call assert(xs(1) < xs(2), "regr14_step_av xs bad order")
+    call assert(xt(1) < xt(2), "regr14_step_av xt bad order")
+
+    call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), &
+         "regr14_step_av extrapolation")
+
+    is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation
+    do it = 1, nt
+       ! 1 <= is <= ns
+       ! xs(is) <= xt(it) < xs(is + 1)
+       ! Compute "vt(it, :, :, :)":
+       left_edge = xt(it)
+       vt(it, :, :, :) = 0.
+       do while (xs(is + 1) < xt(it + 1))
+          ! 1 <= is <= ns - 1
+          vt(it, :, :, :) = vt(it, :, :, :) + (xs(is + 1) - left_edge) &
+               * vs(is, :, :, :)
+          is = is + 1
+          left_edge = xs(is)
+       end do
+       ! 1 <= is <= ns
+       vt(it, :, :, :) = (vt(it, :, :, :) + (xt(it + 1) - left_edge) &
+            * vs(is, :, :, :)) / (xt(it + 1) - xt(it))
+       if (xs(is + 1) == xt(it + 1)) is = is + 1
+       ! 1 <= is <= ns .or. it == nt
+    end do
+
+  end function regr14_step_av
+
+end module regr1_step_av_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/regr_pr_av_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/regr_pr_av_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/regr_pr_av_m.F90	(revision 17)
@@ -0,0 +1,122 @@
+! $Id$
+module regr_pr_av_m
+
+  ! Author: Lionel GUEZ
+
+  implicit none
+
+contains
+
+  subroutine regr_pr_av(ncid, name, julien, press_in_edg, paprs, v3)
+
+    ! "regr_pr_av" stands for "regrid pressure averaging".
+    ! In this procedure:
+    ! -- the root process reads 2D latitude-pressure fields from a
+    !    NetCDF file, at a given day.
+    ! -- the fields are packed to the LMDZ horizontal "physics"
+    !    grid and scattered to all threads of all processes;
+    ! -- in all the threads of all the processes, the fields are regridded in
+    !    pressure to the LMDZ vertical grid.
+    ! We assume that, in the input file, the fields have 3 dimensions:
+    ! latitude, pressure, julian day.
+    ! We assume that the input fields are already on the "rlatu"
+    ! latitudes, except that latitudes are in ascending order in the input
+    ! file.
+    ! We assume that all the inputs fields have the same coordinates.
+
+    ! The target vertical LMDZ grid is the grid of layer boundaries.
+    ! Regridding in pressure is done by averaging a step function of pressure.
+
+    ! All the fields are regridded as a single multi-dimensional array
+    ! so it saves CPU time to call this procedure once for several NetCDF
+    ! variables rather than several times, each time for a single
+    ! NetCDF variable.
+
+    use dimphy, only: klon
+    use netcdf95, only: nf95_inq_varid, handle_err
+    use netcdf, only: nf90_get_var
+    use assert_m, only: assert
+    use assert_eq_m, only: assert_eq
+    use regr1_step_av_m, only: regr1_step_av
+    use mod_phys_lmdz_mpi_data, only: is_mpi_root
+
+    use mod_phys_lmdz_transfert_para, only: scatter2d
+    ! (pack to the LMDZ horizontal "physics" grid and scatter)
+
+    integer, intent(in):: ncid ! NetCDF ID of the file
+    character(len=*), intent(in):: name(:) ! of the NetCDF variables
+    integer, intent(in):: julien ! jour julien, 1 <= julien <= 360
+
+    real, intent(in):: press_in_edg(:)
+    ! edges of pressure intervals for input data, in Pa, in strictly
+    ! ascending order
+
+    real, intent(in):: paprs(:, :) ! (klon, llm + 1)
+    ! (pression pour chaque inter-couche, en Pa)
+
+    real, intent(out):: v3(:, :, :) ! (klon, llm, size(name))
+    ! regridded fields on the partial "physics" grid
+    ! "v3(i, k, l)" is at longitude "xlon(i)", latitude
+    ! "xlat(i)", in pressure interval "[paprs(i, k+1), paprs(i, k)]",
+    ! for NetCDF variable "name(l)".
+
+    ! Variables local to the procedure:
+
+    include "dimensions.h"
+    integer varid, ncerr ! for NetCDF
+
+    real  v1(iim, jjm + 1, size(press_in_edg) - 1, size(name))
+    ! input fields at day "julien", on the global "dynamics" horizontal grid
+    ! First dimension is for longitude.
+    ! The values are the same for all longitudes.
+    ! "v1(:, j, k, l)" is at latitude "rlatu(j)", for
+    ! pressure interval "[press_in_edg(k), press_in_edg(k+1)]" and
+    ! NetCDF variable "name(l)".
+
+    real v2(klon, size(press_in_edg) - 1, size(name))
+    ! fields scattered to the partial "physics" horizontal grid
+    ! "v2(i, k, l)" is at longitude "xlon(i)", latitude "xlat(i)",
+    ! for pressure interval "[press_in_edg(k), press_in_edg(k+1)]" and
+    ! NetCDF variable "name(l)".
+
+    integer i, n_var
+
+    !--------------------------------------------
+
+    call assert(size(v3, 1) == klon, size(v3, 2) == llm, "regr_pr_av v3 klon")
+    n_var = assert_eq(size(name), size(v3, 3), "regr_pr_av v3 n_var")
+    call assert(shape(paprs) == (/klon, llm+1/), "regr_pr_av paprs")
+
+    !$omp master
+    if (is_mpi_root) then
+       do i = 1, n_var
+          call nf95_inq_varid(ncid, trim(name(i)), varid)
+          
+          ! Get data at the right day from the input file:
+          ncerr = nf90_get_var(ncid, varid, v1(1, :, :, i), &
+               start=(/1, 1, julien/))
+          call handle_err("regr_pr_av nf90_get_var " // trim(name(i)), ncerr, &
+               ncid)
+       end do
+       
+       ! Latitudes are in ascending order in the input file while
+       ! "rlatu" is in descending order so we need to invert order:
+       v1(1, :, :, :) = v1(1, jjm+1:1:-1, :, :)
+
+       ! Duplicate on all longitudes:
+       v1(2:, :, :, :) = spread(v1(1, :, :, :), dim=1, ncopies=iim-1)
+    end if
+    !$omp end master
+
+    call scatter2d(v1, v2)
+
+    ! Regrid in pressure at each horizontal position:
+    do i = 1, klon
+       v3(i, llm:1:-1, :) = regr1_step_av(v2(i, :, :), press_in_edg, &
+            paprs(i, llm+1:1:-1))
+       ! (invert order of indices because "paprs" is in descending order)
+    end do
+
+  end subroutine regr_pr_av
+
+end module regr_pr_av_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/regr_pr_comb_coefoz_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/regr_pr_comb_coefoz_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/regr_pr_comb_coefoz_m.F90	(revision 17)
@@ -0,0 +1,163 @@
+! $Id$
+module regr_pr_comb_coefoz_m
+
+  implicit none
+
+  ! The five module variables declared here are on the partial
+  ! "physics" grid.
+  ! The value of each variable for index "(i, k)" is at longitude
+  ! "rlon(i)", latitude "rlat(i)" and middle of layer "k".
+
+  real, allocatable, save:: c_Mob(:, :)
+  ! (sum of Mobidic terms in the net mass production rate of ozone
+  ! by chemistry, per unit mass of air, in s-1)
+
+  real, allocatable, save:: a2(:, :)
+  ! (derivative of mass production rate of ozone per unit mass of
+  ! air with respect to ozone mass fraction, in s-1)
+
+  real, allocatable, save:: a4_mass(:, :)
+  ! (derivative of mass production rate of ozone per unit mass of
+  ! air with respect to temperature, in s-1 K-1)
+
+  real, allocatable, save:: a6_mass(:, :)
+  ! (derivative of mass production rate of ozone per unit mass of
+  ! air with respect to mass column-density of ozone above, in m2 s-1 kg-1)
+
+  real, allocatable, save:: r_het_interm(:, :)
+  ! (net mass production rate by heterogeneous chemistry, per unit
+  ! mass of ozone, corrected for chlorine content and latitude, but
+  ! not for temperature and sun direction, in s-1)
+
+  !$omp threadprivate(c_Mob, a2, a4_mass, a6_mass, r_het_interm)
+
+contains
+
+  subroutine alloc_coefoz
+
+    ! This procedure is called once per run.
+    ! It allocates module variables.
+
+    use dimphy, only: klon
+
+    ! Variables local to the procedure:
+    include "dimensions.h"
+
+    !---------------------------------------
+
+    !$omp master
+    print *, "Call sequence information: alloc_coefoz"
+    !$omp end master
+    allocate(c_Mob(klon, llm), a2(klon, llm), a4_mass(klon, llm))
+    allocate(a6_mass(klon, llm), r_het_interm(klon, llm))
+
+  end subroutine alloc_coefoz
+
+  !*******************************************************
+
+  subroutine regr_pr_comb_coefoz(julien, rlat, paprs, pplay)
+
+    ! "regr_pr_comb_coefoz" stands for "regrid pressure combine
+    ! coefficients ozone".
+
+    ! In this subroutine:
+    ! -- the master thread of the root process reads from a file all
+    !    eight coefficients for ozone chemistry, at the current day;
+    ! -- the coefficients are packed to the "physics" horizontal grid
+    !    and scattered to all threads of all processes;
+    ! -- in all the threads of all the processes, the coefficients are
+    !    regridded in pressure to the LMDZ vertical grid;
+    ! -- in all the threads of all the processes, the eight
+    !    coefficients are combined to define the five module variables.
+
+    use netcdf95, only: nf95_open, nf95_close
+    use netcdf, only: nf90_nowrite
+    use assert_m, only: assert
+    use dimphy, only: klon
+    use mod_phys_lmdz_mpi_data, only: is_mpi_root
+    use regr_pr_av_m, only: regr_pr_av
+    use regr_pr_int_m, only: regr_pr_int
+    use press_coefoz_m, only: press_in_edg, plev
+
+    integer, intent(in):: julien ! jour julien, 1 <= julien <= 360
+
+    REAL, intent(in):: rlat(:)
+    ! (latitude on the partial "physics" grid, in degrees)
+
+    real, intent(in):: paprs(:, :) ! (klon, llm + 1)
+    ! (pression pour chaque inter-couche, en Pa)
+
+    real, intent(in):: pplay(:, :) ! (klon, llm)
+    ! (pression pour le mileu de chaque couche, en Pa)
+
+    ! Variables local to the procedure:
+
+    include "dimensions.h"
+    integer ncid ! for NetCDF
+
+    real coefoz(klon, llm, 7)
+    ! (temporary storage for 7 ozone coefficients)
+    ! (On the partial "physics" grid.
+    ! "coefoz(i, k, :)" is at longitude "rlon(i)", latitude "rlat(i)",
+    ! middle of layer "k".)
+
+    real a6(klon, llm)
+    ! (derivative of "P_net_Mob" with respect to column-density of ozone
+    ! above, in cm2 s-1)
+    ! (On the partial "physics" grid.
+    ! "a6(i, k)" is at longitude "rlon(i)", latitude "rlat(i)",
+    ! middle of layer "k".)
+
+    real, parameter:: amu = 1.6605402e-27 ! atomic mass unit, in kg
+
+    real, parameter:: Clx = 3.8e-9
+    ! (total chlorine content in the upper stratosphere)
+
+    integer k
+
+    !------------------------------------
+
+    !!print *, "Call sequence information: regr_pr_comb_coefoz"
+    call assert((/size(rlat), size(paprs, 1), size(pplay, 1)/) == klon, &
+         "regr_pr_comb_coefoz klon")
+    call assert((/size(paprs, 2) - 1, size(pplay, 2)/) == llm, &
+         "regr_pr_comb_coefoz llm")
+
+    !$omp master
+    if (is_mpi_root) call nf95_open("coefoz_LMDZ.nc", nf90_nowrite, ncid)
+    !$omp end master
+
+    call regr_pr_av(ncid, (/"a2       ", "a4       ", "a6       ", &
+         "P_net_Mob", "r_Mob    ", "temp_Mob ", "R_Het    "/), julien, &
+         press_in_edg, paprs, coefoz)
+    a2 = coefoz(:, :, 1)
+    a4_mass = coefoz(:, :, 2) * 48. / 29.
+
+    ! Compute "a6_mass" avoiding underflow, do not divide by 1e4
+    ! before dividing by molecular mass:
+    a6_mass = coefoz(:, :, 3) / (1e4 * 29. * amu)
+    ! (factor 1e4: conversion from cm2 to m2)
+
+    ! We can overwrite "coefoz(:, :, 1)", which was saved to "a2":
+    call regr_pr_int(ncid, "Sigma_Mob", julien, plev, pplay, top_value=0., &
+         v3=coefoz(:, :, 1))
+
+    ! Combine coefficients to get "c_Mob":
+    c_mob = (coefoz(:, :, 4) - a2 * coefoz(:, :, 5) &
+         - coefoz(:, :, 3) * coefoz(:, :, 1)) * 48. / 29. &
+         - a4_mass * coefoz(:, :, 6)
+
+    r_het_interm = coefoz(:, :, 7)
+    ! Heterogeneous chemistry is only at high latitudes:
+    forall (k = 1: llm)
+       where (abs(rlat) <= 45.) r_het_interm(:, k) = 0.
+    end forall
+    r_het_interm = r_het_interm * (Clx / 3.8e-9)**2
+
+    !$omp master
+    if (is_mpi_root) call nf95_close(ncid)
+    !$omp end master
+
+  end subroutine regr_pr_comb_coefoz
+
+end module regr_pr_comb_coefoz_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/regr_pr_int_m.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/regr_pr_int_m.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/regr_pr_int_m.F90	(revision 17)
@@ -0,0 +1,106 @@
+! $Id$
+module regr_pr_int_m
+
+  ! Author: Lionel GUEZ
+
+  implicit none
+
+contains
+
+  subroutine regr_pr_int(ncid, name, julien, plev, pplay, top_value, v3)
+
+    ! "regr_pr_int" stands for "regrid pressure interpolation".
+    ! In this procedure:
+    ! -- the root process reads a 2D latitude-pressure field from a
+    !    NetCDF file, at a given day.
+    ! -- the field is packed to the LMDZ horizontal "physics"
+    !    grid and scattered to all threads of all processes;
+    ! -- in all the threads of all the processes, the field is regridded in
+    !    pressure to the LMDZ vertical grid.
+    ! We assume that, in the input file, the field has 3 dimensions:
+    ! latitude, pressure, julian day.
+    ! We assume that latitudes are in ascending order in the input file.
+    ! The target vertical LMDZ grid is the grid of mid-layers.
+    ! Regridding is by linear interpolation.
+
+    use dimphy, only: klon
+    use netcdf95, only: nf95_inq_varid, handle_err
+    use netcdf, only: nf90_get_var
+    use assert_m, only: assert
+    use regr1_lint_m, only: regr1_lint
+    use mod_phys_lmdz_mpi_data, only: is_mpi_root
+
+    use mod_phys_lmdz_transfert_para, only: scatter2d
+    ! (pack to the LMDZ horizontal "physics" grid and scatter)
+
+    integer, intent(in):: ncid ! NetCDF ID of the file
+    character(len=*), intent(in):: name ! of the NetCDF variable
+    integer, intent(in):: julien ! jour julien, 1 <= julien <= 360
+
+    real, intent(in):: plev(:)
+    ! (pressure level of input data, in Pa, in strictly ascending order)
+
+    real, intent(in):: pplay(:, :) ! (klon, llm)
+    ! (pression pour le mileu de chaque couche, en Pa)
+
+    real, intent(in):: top_value
+    ! (extra value of field at 0 pressure)
+
+    real, intent(out):: v3(:, :) ! (klon, llm)
+    ! (regridded field on the partial "physics" grid)
+    ! ("v3(i, k)" is at longitude "xlon(i)", latitude
+    ! "xlat(i)", middle of layer "k".)
+
+    ! Variables local to the procedure:
+
+    include "dimensions.h"
+    integer varid, ncerr ! for NetCDF
+
+    real  v1(iim, jjm + 1, 0:size(plev))
+    ! (input field at day "julien", on the global "dynamics" horizontal grid)
+    ! (First dimension is for longitude.
+    ! The value is the same for all longitudes.
+    ! "v1(:, j, k >=1)" is at latitude "rlatu(j)" and pressure "plev(k)".)
+
+    real v2(klon, 0:size(plev))
+    ! (field scattered to the partial "physics" horizontal grid)
+    ! "v2(i, k >= 1)" is at longitude "xlon(i)", latitude "xlat(i)"
+    ! and pressure "plev(k)".)
+
+    integer i
+
+    !--------------------------------------------
+
+    call assert(shape(v3) == (/klon, llm/), "regr_pr_int v3")
+    call assert(shape(pplay) == (/klon, llm/), "regr_pr_int pplay")
+
+    !$omp master
+    if (is_mpi_root) then
+       call nf95_inq_varid(ncid, name, varid)
+
+       ! Get data at the right day from the input file:
+       ncerr = nf90_get_var(ncid, varid, v1(1, :, 1:), start=(/1, 1, julien/))
+       call handle_err("regr_pr_int nf90_get_var " // name, ncerr, ncid)
+       ! Latitudes are in ascending order in the input file while
+       ! "rlatu" is in descending order so we need to invert order:
+       v1(1, :, 1:) = v1(1, jjm+1:1:-1, 1:)
+
+       ! Complete "v1" with the value at 0 pressure:
+       v1(1, :, 0) = top_value
+
+       ! Duplicate on all longitudes:
+       v1(2:, :, :) = spread(v1(1, :, :), dim=1, ncopies=iim-1)
+    end if
+    !$omp end master
+
+    call scatter2d(v1, v2)
+
+    ! Regrid in pressure at each horizontal position:
+    do i = 1, klon
+       v3(i, llm:1:-1) = regr1_lint(v2(i, :), (/0., plev/), pplay(i, llm:1:-1))
+       ! (invert order of indices because "pplay" is in descending order)
+    end do
+
+  end subroutine regr_pr_int
+
+end module regr_pr_int_m
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/screenc.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/screenc.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/screenc.F90	(revision 17)
@@ -0,0 +1,84 @@
+!
+! $Header$
+!
+      SUBROUTINE screenc(klon, knon, nsrf, zxli, &
+                         speed, temp, q_zref, zref, &
+                         ts, qsurf, rugos, psol, &
+                         ustar, testar, qstar, okri, ri1, &
+                         pref, delu, delte, delq)
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+! 
+! Objet : calcul "correcteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-----------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! speed---input-R- module du vent au 1er niveau du modele
+! temp----input-R- temperature de l'air au 1er niveau du modele
+! q_zref--input-R- humidite relative au 1er niveau du modele
+! zref----input-R- altitude de reference
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! psol----input-R- pression au sol
+! ustar---input-R- facteur d'echelle pour le vent
+! testar--input-R- facteur d'echelle pour la temperature potentielle
+! qstar---input-R- facteur d'echelle pour l'humidite relative
+! okri----input-L- TRUE si on veut tester le nb. Richardson entre la sfce 
+!                  et zref par rapport au Ri entre la sfce et la 1ere couche
+! ri1-----input-R- nb. Richardson entre la surface et la 1ere couche 
+!
+! pref----input-R- pression au niveau de reference
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli, okri 
+      REAL, dimension(klon), intent(in) :: speed, temp, q_zref
+      REAL, intent(in) :: zref
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos, psol
+      REAL, dimension(klon), intent(in) :: ustar, testar, qstar, ri1         
+!
+      REAL, dimension(klon), intent(out) :: pref, delu, delte, delq 
+!-----------------------------------------------------------------------
+      include "YOMCST.h"
+!
+! Variables locales  
+      INTEGER :: i 
+      REAL, dimension(klon) :: cdram, cdrah, cdran, zri1, gref
+!
+!------------------------------------------------------------------------- 
+      DO i=1, knon
+        gref(i) = zref*RG
+      ENDDO 
+!
+! Richardson at reference level 
+!
+      CALL coefcdrag (klon, knon, nsrf, zxli, &
+                    speed, temp, q_zref, gref, &
+                    psol, ts, qsurf, rugos, &
+                    okri, ri1, &
+                    cdram, cdrah, cdran, zri1, &
+                    pref)
+!
+      DO i = 1, knon
+        delu(i) = ustar(i)/sqrt(cdram(i))
+        delte(i)= (testar(i)* sqrt(cdram(i)))/ &
+                   cdrah(i)
+        delq(i)= (qstar(i)* sqrt(cdram(i)))/ &
+                  cdrah(i)
+      ENDDO 
+!
+      RETURN 
+      END SUBROUTINE screenc
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/screenp.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/screenp.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/screenp.F90	(revision 17)
@@ -0,0 +1,109 @@
+!
+! $Header$
+!
+      SUBROUTINE screenp(klon, knon, nsrf, &
+     &                   speed, tair, qair, &
+     &                   ts, qsurf, rugos, lmon, &
+     &                   ustar, testar, qstar, zref, &
+     &                   delu, delte, delq) 
+      IMPLICIT none
+!-------------------------------------------------------------------------
+!
+! Objet : calcul "predicteur" des anomalies du vent, de la temperature 
+!         potentielle et de l'humidite relative au niveau de reference zref et 
+!         par rapport au 1er niveau (pour u) ou a la surface (pour theta et q) 
+!         a partir des relations de Dyer-Businger.
+!
+! Reference : Hess, Colman et McAvaney (1995)
+!
+! I. Musat, 01.07.2002
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
+! speed---input-R- module du vent au 1er niveau du modele
+! tair----input-R- temperature de l'air au 1er niveau du modele
+! qair----input-R- humidite relative au 1er niveau du modele
+! ts------input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! lmon----input-R- longueur de Monin-Obukov
+! ustar---input-R- facteur d'echelle pour le vent
+! testar--input-R- facteur d'echelle pour la temperature potentielle
+! qstar---input-R- facteur d'echelle pour l'humidite relative
+! zref----input-R- altitude de reference
+!
+! delu----input-R- anomalie du vent par rapport au 1er niveau
+! delte---input-R- anomalie de la temperature potentielle par rapport a la surface
+! delq----input-R- anomalie de l'humidite relative par rapport a la surface
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      REAL, dimension(klon), intent(in) :: speed, tair, qair
+      REAL, dimension(klon), intent(in) :: ts, qsurf, rugos
+      DOUBLE PRECISION, dimension(klon), intent(in) :: lmon
+      REAL, dimension(klon), intent(in) :: ustar, testar, qstar
+      REAL, intent(in) :: zref
+!
+      REAL, dimension(klon), intent(out) :: delu, delte, delq
+!
+!-------------------------------------------------------------------------
+! Variables locales et constantes :
+      REAL, PARAMETER :: RKAR=0.40
+      INTEGER :: i
+      REAL :: xtmp, xtmp0
+!-------------------------------------------------------------------------
+      DO i = 1, knon
+!
+        IF (lmon(i).GE.0.) THEN
+!
+! STABLE CASE
+!
+          IF (speed(i).GT.1.5.AND.lmon(i).LE.1.0                        &
+     &                      .AND. rugos(i).LE.1.0) THEN
+            delu(i) = (ustar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) + &
+                      min(5.d0, 5.0 *(zref - rugos(i))/lmon(i)))
+            delte(i) = (testar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) + &
+                       min(5.d0, 5.0 * (zref - rugos(i))/lmon(i)))
+            delq(i) = (qstar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) + &
+                      min(5.d0, 5.0 * (zref - rugos(i))/lmon(i)))
+          ELSE
+            delu(i)  = 0.1 * speed(i)
+            delte(i) = 0.1 * (tair(i) - ts(i) )
+            delq(i)  = 0.1 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+          ENDIF
+        ELSE  
+!
+! UNSTABLE CASE
+!
+          IF (speed(i).GT.5.0.AND.abs(lmon(i)).LE.50.0) THEN
+            xtmp = (1. - 16. * (zref/lmon(i)))**(1./4.)
+            xtmp0 = (1. - 16. * (rugos(i)/lmon(i)))**(1./4.)
+            delu(i) = (ustar(i)/RKAR)* &
+                      (log(zref/(rugos(i))+1.) & 
+                      - 2.*log(0.5*(1. + xtmp)) &
+                      + 2.*log(0.5*(1. + xtmp0)) &
+                      - log(0.5*(1. + xtmp*xtmp)) &
+                      + log(0.5*(1. + xtmp0*xtmp0)) &
+                      + 2.*atan(xtmp) - 2.*atan(xtmp0))
+            delte(i) = (testar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) &
+                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
+                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
+            delq(i)  = (qstar(i)/RKAR)* &
+                       (log(zref/(rugos(i))+1.) &
+                       - 2.0 * log(0.5*(1. + xtmp*xtmp)) & 
+                       + 2.0 * log(0.5*(1. + xtmp0*xtmp0)))
+          ELSE
+            delu(i)  = 0.5 * speed(i)
+            delte(i) = 0.5 * (tair(i) - ts(i) )
+            delq(i)  = 0.5 * (max(qair(i),0.0) - max(qsurf(i),0.0))
+          ENDIF
+        ENDIF
+!
+      ENDDO
+      RETURN
+      END SUBROUTINE screenp
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/serre.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/serre.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/serre.h	(revision 17)
@@ -0,0 +1,11 @@
+!
+! $Header$
+!
+!c
+!c
+!c..include serre.h
+!c
+       REAL clon,clat,transx,transy,alphax,alphay,pxo,pyo,              &
+     &  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
+       COMMON/serre/clon,clat,transx,transy,alphax,alphay,pxo,pyo ,     &
+     &  grossismx, grossismy, dzoomx, dzoomy,taux,tauy
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/simple.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/simple.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/simple.F90	(revision 17)
@@ -0,0 +1,361 @@
+! $Id$
+module simple
+
+  use handle_err_m, only: handle_err
+  
+  implicit none
+
+  private handle_err
+
+contains
+
+  subroutine nf95_open(path, mode, ncid, chunksize, ncerr)
+
+    use netcdf, only: nf90_open
+
+    character(len=*), intent(in):: path
+    integer, intent(in):: mode
+    integer, intent(out):: ncid
+    integer, intent(inout), optional:: chunksize
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_open(path, mode, ncid, chunksize)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_open " // path, ncerr_not_opt)
+    end if
+
+  end subroutine nf95_open
+
+  !************************
+
+  subroutine nf95_inq_dimid(ncid, name, dimid, ncerr)
+
+    use netcdf, only: nf90_inq_dimid
+
+    integer,             intent(in) :: ncid
+    character (len = *), intent(in) :: name
+    integer,             intent(out) :: dimid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inq_dimid(ncid, name, dimid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inq_dimid " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_inq_dimid
+
+  !************************
+
+  subroutine nf95_inquire_dimension(ncid, dimid, name, nclen, ncerr)
+
+    use netcdf, only: nf90_inquire_dimension
+
+    integer,                       intent( in) :: ncid, dimid
+    character (len = *), optional, intent(out) :: name
+    integer,             optional, intent(out) :: nclen
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inquire_dimension(ncid, dimid, name, nclen)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inquire_dimension", ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_inquire_dimension
+
+  !************************
+
+  subroutine nf95_inq_varid(ncid, name, varid, ncerr)
+
+    use netcdf, only: nf90_inq_varid
+
+    integer,             intent(in) :: ncid
+    character(len=*), intent(in):: name
+    integer,             intent(out) :: varid
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inq_varid(ncid, name, varid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inq_varid, name = " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_inq_varid
+
+  !************************
+
+  subroutine nf95_inquire_variable(ncid, varid, name, xtype, ndims, dimids, &
+       nAtts, ncerr)
+
+    ! In "nf90_inquire_variable", "dimids" is an assumed-size array.
+    ! This is not optimal.
+    ! We are in the classical case of an array the size of which is
+    ! unknown in the calling procedure, before the call.
+    ! Here we use a better solution: a pointer argument array.
+    ! This procedure associates and defines "dimids" if it is present.
+
+    use netcdf, only: nf90_inquire_variable, nf90_max_var_dims
+
+    integer, intent(in):: ncid, varid
+    character(len = *), optional, intent(out):: name
+    integer, optional, intent(out) :: xtype, ndims
+    integer, dimension(:), optional, pointer :: dimids
+    integer, optional, intent(out) :: nAtts
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+    integer dimids_local(nf90_max_var_dims)
+    integer ndims_not_opt
+
+    !-------------------
+
+    if (present(dimids)) then
+       ncerr_not_opt = nf90_inquire_variable(ncid, varid, name, xtype, &
+            ndims_not_opt, dimids_local, nAtts)
+       allocate(dimids(ndims_not_opt)) ! also works if ndims_not_opt == 0
+       dimids = dimids_local(:ndims_not_opt)
+       if (present(ndims)) ndims = ndims_not_opt
+    else
+       ncerr_not_opt = nf90_inquire_variable(ncid, varid, name, xtype, ndims, &
+            nAtts=nAtts)
+    end if
+
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inquire_variable", ncerr_not_opt, ncid, varid)
+    end if
+
+  end subroutine nf95_inquire_variable
+
+  !************************
+
+  subroutine nf95_create(path, cmode, ncid, initialsize, chunksize, ncerr)
+    
+    use netcdf, only: nf90_create
+
+    character (len = *), intent(in   ) :: path
+    integer,             intent(in   ) :: cmode
+    integer,             intent(  out) :: ncid
+    integer, optional,   intent(in   ) :: initialsize
+    integer, optional,   intent(inout) :: chunksize
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_create(path, cmode, ncid, initialsize, chunksize)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_create " // path, ncerr_not_opt)
+    end if
+
+  end subroutine nf95_create
+
+  !************************
+
+  subroutine nf95_def_dim(ncid, name, nclen, dimid, ncerr)
+
+    use netcdf, only: nf90_def_dim
+
+    integer,             intent( in) :: ncid
+    character (len = *), intent( in) :: name
+    integer,             intent( in) :: nclen
+    integer,             intent(out) :: dimid
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_def_dim(ncid, name, nclen, dimid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_def_dim " // name, ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_def_dim
+
+  !***********************
+
+  subroutine nf95_redef(ncid, ncerr)
+
+    use netcdf, only: nf90_redef
+
+    integer, intent( in) :: ncid
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_redef(ncid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_redef", ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_redef
+  
+  !***********************
+
+  subroutine nf95_enddef(ncid, h_minfree, v_align, v_minfree, r_align, ncerr)
+
+    use netcdf, only: nf90_enddef
+
+    integer,           intent( in) :: ncid
+    integer, optional, intent( in) :: h_minfree, v_align, v_minfree, r_align
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_enddef(ncid, h_minfree, v_align, v_minfree, r_align)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_enddef", ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_enddef
+
+  !***********************
+
+  subroutine nf95_close(ncid, ncerr)
+
+    use netcdf, only: nf90_close
+
+    integer, intent( in) :: ncid
+    integer, intent(out), optional :: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_close(ncid)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_close", ncerr_not_opt)
+    end if
+
+  end subroutine nf95_close
+
+  !***********************
+
+  subroutine nf95_copy_att(ncid_in, varid_in, name, ncid_out, varid_out, ncerr)
+
+    use netcdf, only: nf90_copy_att
+
+    integer, intent( in):: ncid_in,  varid_in
+    character(len=*), intent( in):: name
+    integer, intent( in):: ncid_out, varid_out
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_copy_att(ncid_in, varid_in, name, ncid_out, varid_out)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_copy_att " // name, ncerr_not_opt, ncid_out)
+    end if
+
+  end subroutine nf95_copy_att
+
+  !***********************
+
+  subroutine nf95_inquire_attribute(ncid, varid, name, xtype, nclen, attnum, &
+       ncerr)
+
+    use netcdf, only: nf90_inquire_attribute
+
+    integer,             intent( in)           :: ncid, varid
+    character (len = *), intent( in)           :: name
+    integer,             intent(out), optional :: xtype, nclen, attnum
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inquire_attribute(ncid, varid, name, xtype, nclen, &
+         attnum)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inquire_attribute " // name, ncerr_not_opt, &
+            ncid, varid)
+    end if
+
+  end subroutine nf95_inquire_attribute
+
+  !***********************
+
+  subroutine nf95_inquire(ncid, nDimensions, nVariables, nAttributes, &
+       unlimitedDimId, formatNum, ncerr)
+
+    use netcdf, only: nf90_inquire
+
+    integer,           intent( in) :: ncid
+    integer, optional, intent(out) :: nDimensions, nVariables, nAttributes
+    integer, optional, intent(out) :: unlimitedDimId, formatNum
+    integer, intent(out), optional:: ncerr
+
+    ! Variable local to the procedure:
+    integer ncerr_not_opt
+
+    !-------------------
+
+    ncerr_not_opt = nf90_inquire(ncid, nDimensions, nVariables, nAttributes, &
+         unlimitedDimId, formatNum)
+    if (present(ncerr)) then
+       ncerr = ncerr_not_opt
+    else
+       call handle_err("nf95_inquire", ncerr_not_opt, ncid)
+    end if
+
+  end subroutine nf95_inquire
+
+end module simple
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/soil.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/soil.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/soil.F90	(revision 17)
@@ -0,0 +1,280 @@
+!
+! $Header$
+!
+SUBROUTINE soil(ptimestep, indice, knon, snow, ptsrf, &
+     ptsoil, pcapcal, pfluxgrd)
+  
+  USE dimphy
+  USE mod_phys_lmdz_para
+  USE indice_sol_mod
+
+  IMPLICIT NONE
+
+!=======================================================================
+!
+!   Auteur:  Frederic Hourdin     30/01/92
+!   -------
+!
+!   Object:  Computation of : the soil temperature evolution
+!   -------                   the surfacic heat capacity "Capcal"
+!                            the surface conduction flux pcapcal
+!
+!
+!   Method: Implicit time integration
+!   -------
+!   Consecutive ground temperatures are related by:
+!           T(k+1) = C(k) + D(k)*T(k)  (*)
+!   The coefficients C and D are computed at the t-dt time-step.
+!   Routine structure:
+!   1) C and D coefficients are computed from the old temperature
+!   2) new temperatures are computed using (*)
+!   3) C and D coefficients are computed from the new temperature
+!      profile for the t+dt time-step
+!   4) the coefficients A and B are computed where the diffusive
+!      fluxes at the t+dt time-step is given by
+!             Fdiff = A + B Ts(t+dt)
+!      or     Fdiff = F0 + Capcal (Ts(t+dt)-Ts(t))/dt
+!             with F0 = A + B (Ts(t))
+!                 Capcal = B*dt
+!           
+!   Interface:
+!   ----------
+!
+!   Arguments:
+!   ----------
+!   ptimestep            physical timestep (s)
+!   indice               sub-surface index
+!   snow(klon)           snow
+!   ptsrf(klon)          surface temperature at time-step t (K)
+!   ptsoil(klon,nsoilmx) temperature inside the ground (K)
+!   pcapcal(klon)        surfacic specific heat (W*m-2*s*K-1)
+!   pfluxgrd(klon)       surface diffusive flux from ground (Wm-2)
+!   
+!=======================================================================
+  INCLUDE "YOMCST.h"
+  INCLUDE "dimsoil.h"
+  INCLUDE "comsoil.h"
+  INCLUDE "iniprint.h"
+!-----------------------------------------------------------------------
+! Arguments
+! ---------
+  REAL, INTENT(IN)                     :: ptimestep
+  INTEGER, INTENT(IN)                  :: indice, knon
+  REAL, DIMENSION(klon), INTENT(IN)    :: snow
+  REAL, DIMENSION(klon), INTENT(IN)    :: ptsrf
+  
+  REAL, DIMENSION(klon,nsoilmx), INTENT(INOUT) :: ptsoil
+  REAL, DIMENSION(klon), INTENT(OUT)           :: pcapcal
+  REAL, DIMENSION(klon), INTENT(OUT)           :: pfluxgrd
+
+!-----------------------------------------------------------------------
+! Local variables
+! ---------------
+  INTEGER                             :: ig, jk, ierr
+  REAL                                :: min_period,dalph_soil
+  REAL, DIMENSION(nsoilmx)            :: zdz2
+  REAL                                :: z1s
+  REAL, DIMENSION(klon)               :: ztherm_i
+  REAL, DIMENSION(klon,nsoilmx,nbsrf) :: C_coef, D_coef
+
+! Local saved variables
+! ---------------------
+  REAL, SAVE                     :: lambda
+!$OMP THREADPRIVATE(lambda)
+  REAL, DIMENSION(nsoilmx), SAVE :: dz1, dz2
+!$OMP THREADPRIVATE(dz1,dz2)
+  LOGICAL, SAVE                  :: firstcall=.TRUE.
+!$OMP THREADPRIVATE(firstcall)
+    
+!-----------------------------------------------------------------------
+!   Depthts:
+!   --------
+  REAL fz,rk,fz1,rk1,rk2
+  fz(rk)=fz1*(dalph_soil**rk-1.)/(dalph_soil-1.)
+
+
+!-----------------------------------------------------------------------
+! Calculation of some constants
+! NB! These constants do not depend on the sub-surfaces
+!-----------------------------------------------------------------------
+
+  IF (firstcall) THEN
+!-----------------------------------------------------------------------
+!   ground levels 
+!   grnd=z/l where l is the skin depth of the diurnal cycle:
+!-----------------------------------------------------------------------
+
+     min_period=1800. ! en secondes
+     dalph_soil=2.    ! rapport entre les epaisseurs de 2 couches succ.
+!$OMP MASTER
+     IF (is_mpi_root) THEN
+        OPEN(99,file='soil.def',status='old',form='formatted',iostat=ierr)
+        IF (ierr == 0) THEN ! Read file only if it exists
+           READ(99,*) min_period
+           READ(99,*) dalph_soil
+           WRITE(lunout,*)'Discretization for the soil model'
+           WRITE(lunout,*)'First level e-folding depth',min_period, &
+                '   dalph',dalph_soil
+           CLOSE(99)
+        END IF
+     ENDIF
+!$OMP END MASTER
+     CALL bcast(min_period)
+     CALL bcast(dalph_soil)
+
+!   la premiere couche represente un dixieme de cycle diurne
+     fz1=SQRT(min_period/3.14)
+     
+     DO jk=1,nsoilmx
+        rk1=jk
+        rk2=jk-1
+        dz2(jk)=fz(rk1)-fz(rk2)
+     ENDDO
+     DO jk=1,nsoilmx-1
+        rk1=jk+.5
+        rk2=jk-.5
+        dz1(jk)=1./(fz(rk1)-fz(rk2))
+     ENDDO
+     lambda=fz(.5)*dz1(1)
+     WRITE(lunout,*)'full layers, intermediate layers (seconds)'
+     DO jk=1,nsoilmx
+        rk=jk
+        rk1=jk+.5
+        rk2=jk-.5
+        WRITE(lunout,*)'fz=', &
+             fz(rk1)*fz(rk2)*3.14,fz(rk)*fz(rk)*3.14
+     ENDDO
+
+     firstcall =.FALSE.
+  END IF
+
+
+!-----------------------------------------------------------------------
+!   Calcul de l'inertie thermique a partir de la variable rnat.
+!   on initialise a inertie_ice meme au-dessus d'un point de mer au cas 
+!   ou le point de mer devienne point de glace au pas suivant
+!   on corrige si on a un point de terre avec ou sans glace
+!
+!-----------------------------------------------------------------------
+  IF (indice == is_sic) THEN
+     DO ig = 1, knon
+        ztherm_i(ig)   = inertie_ice
+        IF (snow(ig) > 0.0) ztherm_i(ig)   = inertie_sno
+     ENDDO
+  ELSE IF (indice == is_lic) THEN
+     DO ig = 1, knon
+        ztherm_i(ig)   = inertie_ice
+        IF (snow(ig) > 0.0) ztherm_i(ig)   = inertie_sno
+     ENDDO
+  ELSE IF (indice == is_ter) THEN
+     DO ig = 1, knon
+        ztherm_i(ig)   = inertie_sol
+        IF (snow(ig) > 0.0) ztherm_i(ig)   = inertie_sno
+     ENDDO
+  ELSE IF (indice == is_oce) THEN
+     DO ig = 1, knon
+        ztherm_i(ig)   = inertie_ice
+     ENDDO
+  ELSE
+     WRITE(lunout,*) "valeur d indice non prevue", indice
+     CALL abort
+  ENDIF
+
+
+!-----------------------------------------------------------------------
+! 1)
+! Calculation of Cgrf and Dgrd coefficients using soil temperature from 
+! previous time step.
+!
+! These variables are recalculated on the local compressed grid instead 
+! of saved in restart file.
+!-----------------------------------------------------------------------
+  DO jk=1,nsoilmx
+     zdz2(jk)=dz2(jk)/ptimestep
+  ENDDO
+  
+  DO ig=1,knon
+     z1s = zdz2(nsoilmx)+dz1(nsoilmx-1)
+     C_coef(ig,nsoilmx-1,indice)= &
+          zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s
+     D_coef(ig,nsoilmx-1,indice)=dz1(nsoilmx-1)/z1s
+  ENDDO
+  
+  DO jk=nsoilmx-1,2,-1
+     DO ig=1,knon
+        z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) &
+             *(1.-D_coef(ig,jk,indice)))
+        C_coef(ig,jk-1,indice)= &
+             (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s
+        D_coef(ig,jk-1,indice)=dz1(jk-1)*z1s
+     ENDDO
+  ENDDO
+
+!-----------------------------------------------------------------------
+! 2)
+! Computation of the soil temperatures using the Cgrd and Dgrd
+! coefficient computed above
+!
+!-----------------------------------------------------------------------
+
+!    Surface temperature
+  DO ig=1,knon
+     ptsoil(ig,1)=(lambda*C_coef(ig,1,indice)+ptsrf(ig))/  &
+          (lambda*(1.-D_coef(ig,1,indice))+1.)
+  ENDDO
+  
+!   Other temperatures
+  DO jk=1,nsoilmx-1
+     DO ig=1,knon
+        ptsoil(ig,jk+1)=C_coef(ig,jk,indice)+D_coef(ig,jk,indice) &
+             *ptsoil(ig,jk)
+     ENDDO
+  ENDDO
+
+  IF (indice == is_sic) THEN
+     DO ig = 1 , knon
+        ptsoil(ig,nsoilmx) = RTT - 1.8
+     END DO
+  ENDIF
+
+!-----------------------------------------------------------------------
+! 3)
+! Calculate the Cgrd and Dgrd coefficient corresponding to actual soil 
+! temperature
+!-----------------------------------------------------------------------
+  DO ig=1,knon
+     z1s = zdz2(nsoilmx)+dz1(nsoilmx-1)
+     C_coef(ig,nsoilmx-1,indice) = zdz2(nsoilmx)*ptsoil(ig,nsoilmx)/z1s
+     D_coef(ig,nsoilmx-1,indice) = dz1(nsoilmx-1)/z1s
+  ENDDO
+  
+  DO jk=nsoilmx-1,2,-1
+     DO ig=1,knon
+        z1s = 1./(zdz2(jk)+dz1(jk-1)+dz1(jk) &
+             *(1.-D_coef(ig,jk,indice)))
+        C_coef(ig,jk-1,indice) = &
+             (ptsoil(ig,jk)*zdz2(jk)+dz1(jk)*C_coef(ig,jk,indice)) * z1s
+        D_coef(ig,jk-1,indice) = dz1(jk-1)*z1s
+     ENDDO
+  ENDDO
+
+!-----------------------------------------------------------------------
+! 4)
+! Computation of the surface diffusive flux from ground and
+! calorific capacity of the ground
+!-----------------------------------------------------------------------
+  DO ig=1,knon
+     pfluxgrd(ig) = ztherm_i(ig)*dz1(1)* &
+          (C_coef(ig,1,indice)+(D_coef(ig,1,indice)-1.)*ptsoil(ig,1))
+     pcapcal(ig)  = ztherm_i(ig)* &
+          (dz2(1)+ptimestep*(1.-D_coef(ig,1,indice))*dz1(1))
+     z1s = lambda*(1.-D_coef(ig,1,indice))+1.
+     pcapcal(ig)  = pcapcal(ig)/z1s
+     pfluxgrd(ig) = pfluxgrd(ig) &
+          + pcapcal(ig) * (ptsoil(ig,1) * z1s &
+          - lambda * C_coef(ig,1,indice) &
+          - ptsrf(ig)) &
+          /ptimestep
+  ENDDO
+    
+END SUBROUTINE soil
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/solarlong.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/solarlong.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/solarlong.F	(revision 17)
@@ -0,0 +1,134 @@
+      SUBROUTINE solarlong(pday,psollong,pdist_sol)
+
+      USE ioipsl
+
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Objet:
+c   ------
+c
+c      Calcul de la distance soleil-planete et de la declinaison
+c   en fonction du jour de l'annee.
+c
+c
+c   Methode:
+c   --------
+c
+c      Calcul complet de l'elipse
+c
+c   Interface:
+c   ----------
+c
+c      Uncommon comprenant les parametres orbitaux.
+c
+c   Arguments:
+c   ----------
+c
+c   Input:
+c   ------
+c   pday          jour de l'annee (le jour 0 correspondant a l'equinoxe)
+c   lwrite        clef logique pour sorties de controle
+c
+c   Output:
+c   -------
+c   pdist_sol     distance entre le soleil et la planete
+c                 ( en unite astronomique pour utiliser la constante 
+c                  solaire terrestre 1370 Wm-2 )
+c   pdecli        declinaison ( en radians )
+c
+c=======================================================================
+c-----------------------------------------------------------------------
+c   Declarations:
+c   -------------
+
+#include "planete.h"
+#include "YOMCST.h"
+      include 'iniprint.h'
+
+c arguments:
+c ----------
+
+      REAL pday,pdist_sol,pdecli,psollong
+      LOGICAL lwrite
+
+c Local:
+c ------
+
+      REAL zanom,xref,zx0,zdx,zteta,zz,pi
+      INTEGER iter
+      REAL :: pyear_day,pperi_day
+      REAL :: jD_eq, jD_peri
+      LOGICAL,SAVE :: first=.TRUE.
+c$OMP THREADPRIVATE(first)
+
+c-----------------------------------------------------------------------
+c calcul de l'angle polaire et de la distance au soleil :
+c -------------------------------------------------------
+
+c   Initialisation eventuelle:
+      if(first) then
+        call ioget_calendar(pyear_day)
+        call ymds2ju(2000, 3, 21, 0., jD_eq)
+        call ymds2ju(2001, 1, 4, 0., jD_peri)
+        pperi_day = jD_peri - jD_eq
+        pperi_day = R_peri + 180.
+        write(lunout,*)' Number of days in a year = ',pyear_day
+c         call iniorbit(249.22,206.66,669.,485.,25.2)
+         call iniorbit(152.59,146.61,pyear_day,pperi_day,R_incl)
+         first=.FALSE.
+      endif
+
+c  calcul de l'zanomalie moyenne
+
+      zz=(pday-peri_day)/year_day
+      pi=2.*asin(1.)
+      zanom=2.*pi*(zz-nint(zz))
+      xref=abs(zanom)
+
+c  resolution de l'equation horaire  zx0 - e * sin (zx0) = xref
+c  methode de Newton
+
+!      zx0=xref+e_elips*sin(xref)
+      zx0=xref+R_ecc*sin(xref)
+      DO 110 iter=1,10
+!         zdx=-(zx0-e_elips*sin(zx0)-xref)/(1.-e_elips*cos(zx0))
+         zdx=-(zx0-R_ecc*sin(zx0)-xref)/(1.-R_ecc*cos(zx0))
+         if(abs(zdx).le.(1.e-7)) goto 120
+         zx0=zx0+zdx
+110   continue
+120   continue
+      zx0=zx0+zdx
+      if(zanom.lt.0.) zx0=-zx0
+
+c zteta est la longitude solaire
+
+!      zteta=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.))
+      zteta=2.*atan(sqrt((1.+R_ecc)/(1.-R_ecc))*tan(zx0/2.))
+
+      psollong=zteta-timeperi
+
+      IF(psollong.LT.0.) psollong=psollong+2.*pi
+      IF(psollong.GT.2.*pi) psollong=psollong-2.*pi
+
+      psollong = psollong * 180. / pi
+
+c distance soleil
+
+      pdist_sol = (1-R_ecc*R_ecc)
+     &      /(1+R_ecc*COS(pi/180.*(psollong-(R_peri+180.0))))
+!      pdist_sol = (1-e_elips*e_elips)
+!     &      /(1+e_elips*COS(pi/180.*(psollong-(R_peri+180.0))))
+c-----------------------------------------------------------------------
+c   sorties eventuelles:
+c   ---------------------
+
+c     IF (lwrite) THEN
+c        PRINT*,'jour de l"annee   :',pday
+c        PRINT*,'distance au soleil (en unite astronomique) :',pdist_sol
+c        PRINT*,'declinaison (en degres) :',pdecli*180./pi
+c     ENDIF
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/solarlong.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/solarlong.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/solarlong.F90	(revision 17)
@@ -0,0 +1,134 @@
+      SUBROUTINE solarlong(pday,psollong,pdist_sol)
+
+      USE ioipsl
+
+      IMPLICIT NONE
+
+!c=======================================================================
+!c
+!c   Objet:
+!c   ------
+!c
+!c      Calcul de la distance soleil-planete et de la declinaison
+!c   en fonction du jour de l'annee.
+!c
+!c
+!c   Methode:
+!c   --------
+!c
+!c      Calcul complet de l'elipse
+!c
+!c   Interface:
+!c   ----------
+!c
+!c      Uncommon comprenant les parametres orbitaux.
+!c
+!c   Arguments:
+!c   ----------
+!c
+!c   Input:
+!c   ------
+!c   pday          jour de l'annee (le jour 0 correspondant a l'equinoxe)
+!c   lwrite        clef logique pour sorties de controle
+!c
+!c   Output:
+!c   -------
+!c   pdist_sol     distance entre le soleil et la planete
+!c                 ( en unite astronomique pour utiliser la constante 
+!c                  solaire terrestre 1370 Wm-2 )
+!c   pdecli        declinaison ( en radians )
+!c
+!c=======================================================================
+!c-----------------------------------------------------------------------
+!c   Declarations:
+!c   -------------
+
+#include "planete.h"
+#include "YOMCST.h"
+      include 'iniprint.h'
+
+!c arguments:
+!c ----------
+
+      REAL pday,pdist_sol,pdecli,psollong
+      LOGICAL lwrite
+
+!c Local:
+!c ------
+
+      REAL zanom,xref,zx0,zdx,zteta,zz,pi
+      INTEGER iter
+      REAL :: pyear_day,pperi_day
+      REAL :: jD_eq, jD_peri
+      LOGICAL,SAVE :: first=.TRUE.
+!$OMP THREADPRIVATE(first)
+
+!c-----------------------------------------------------------------------
+!c calcul de l'angle polaire et de la distance au soleil :
+!c -------------------------------------------------------
+
+!c   Initialisation eventuelle:
+      if(first) then
+        call ioget_calendar(pyear_day)
+        call ymds2ju(2000, 3, 21, 0., jD_eq)
+        call ymds2ju(2001, 1, 4, 0., jD_peri)
+        pperi_day = jD_peri - jD_eq
+        pperi_day = R_peri + 180.
+        write(lunout,*)' Number of days in a year = ',pyear_day
+!c         call iniorbit(249.22,206.66,669.,485.,25.2)
+         call iniorbit(152.59,146.61,pyear_day,pperi_day,R_incl)
+         first=.FALSE.
+      endif
+
+!c  calcul de l'zanomalie moyenne
+
+      zz=(pday-peri_day)/year_day
+      pi=2.*asin(1.)
+      zanom=2.*pi*(zz-nint(zz))
+      xref=abs(zanom)
+
+!c  resolution de l'equation horaire  zx0 - e * sin (zx0) = xref
+!c  methode de Newton
+
+!      zx0=xref+e_elips*sin(xref)
+      zx0=xref+R_ecc*sin(xref)
+      DO 110 iter=1,10
+!         zdx=-(zx0-e_elips*sin(zx0)-xref)/(1.-e_elips*cos(zx0))
+         zdx=-(zx0-R_ecc*sin(zx0)-xref)/(1.-R_ecc*cos(zx0))
+         if(abs(zdx).le.(1.e-7)) goto 120
+         zx0=zx0+zdx
+110   continue
+120   continue
+      zx0=zx0+zdx
+      if(zanom.lt.0.) zx0=-zx0
+
+!c zteta est la longitude solaire
+
+!      zteta=2.*atan(sqrt((1.+e_elips)/(1.-e_elips))*tan(zx0/2.))
+      zteta=2.*atan(sqrt((1.+R_ecc)/(1.-R_ecc))*tan(zx0/2.))
+
+      psollong=zteta-timeperi
+
+      IF(psollong.LT.0.) psollong=psollong+2.*pi
+      IF(psollong.GT.2.*pi) psollong=psollong-2.*pi
+
+      psollong = psollong * 180. / pi
+
+!c distance soleil
+
+      pdist_sol = (1-R_ecc*R_ecc)                                                    &
+       &      /(1+R_ecc*COS(pi/180.*(psollong-(R_peri+180.0))))
+!      pdist_sol = (1-e_elips*e_elips)
+!     &      /(1+e_elips*COS(pi/180.*(psollong-(R_peri+180.0))))
+!c-----------------------------------------------------------------------
+!c   sorties eventuelles:
+!c   ---------------------
+
+!c     IF (lwrite) THEN
+!c        PRINT*,'jour de l"annee   :',pday
+!c        PRINT*,'distance au soleil (en unite astronomique) :',pdist_sol
+!c        PRINT*,'declinaison (en degres) :',pdecli*180./pi
+!c     ENDIF
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/statto.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/statto.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/statto.h	(revision 17)
@@ -0,0 +1,34 @@
+
+!  statto:
+!     This include file controls the production of statistics.
+!     Some variables could be set in a namelist, but it is easier to
+!     do it here since arrays can then be dimensioned using parameters
+!     and values shouldn't have to change too often.   SRL
+
+!     Calculate stats every istats physics timesteps, starting at first
+!     call.  If istats=0 then don't do statistics at all.  Check value
+!     if number of physics timesteps changes.
+	integer istats
+
+!     Calculate itime independent sums and sums of squares,
+!     example, istat=1,istime=1 gives a single time mean
+	integer, parameter :: istime=12
+
+!     Number of 2D and 3D variables on which to do statistics.
+	integer n2dvar, n3dvar
+	parameter (n2dvar = 8, n3dvar = 5)
+
+!     Units for writing stats header and data
+	integer usdata
+
+!     count tab to know the variable record
+        integer count(istime)
+
+!     Record of the number of stores made for each time.
+	integer nstore(istime)
+
+! Size of the "controle" array
+        integer, parameter :: cntrlsize=15
+
+!       common /sttcom/ dummy,nstore,istats,usdata
+        common /sttcom/ nstore,istats,usdata,count
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/stdlevvar.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/stdlevvar.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/stdlevvar.F90	(revision 17)
@@ -0,0 +1,278 @@
+!
+! $Header$
+!
+      SUBROUTINE stdlevvar(klon, knon, nsrf, zxli, &
+                           u1, v1, t1, q1, z1, &
+                           ts1, qsurf, rugos, psol, pat1, &
+                           t_2m, q_2m, t_10m, q_10m, u_10m, ustar)
+      IMPLICIT NONE
+!-------------------------------------------------------------------------
+!
+! Objet : calcul de la temperature et l'humidite relative a 2m et du 
+!         module du vent a 10m a partir des relations de Dyer-Businger et
+!         des equations de Louis.
+!
+! Reference : Hess, Colman et McAvaney (1995)        
+!
+! I. Musat, 01.07.2002
+!
+!AM On rajoute en sortie t et q a 10m pr le calcule d'hbtm2 dans clmain
+!
+!-------------------------------------------------------------------------
+!
+! klon----input-I- dimension de la grille physique (= nb_pts_latitude X nb_pts_longitude)
+! knon----input-I- nombre de points pour un type de surface
+! nsrf----input-I- indice pour le type de surface; voir indice_sol_mod.F90
+! zxli----input-L- TRUE si calcul des cdrags selon Laurent Li
+! u1------input-R- vent zonal au 1er niveau du modele
+! v1------input-R- vent meridien au 1er niveau du modele
+! t1------input-R- temperature de l'air au 1er niveau du modele
+! q1------input-R- humidite relative au 1er niveau du modele
+! z1------input-R- geopotentiel au 1er niveau du modele
+! ts1-----input-R- temperature de l'air a la surface
+! qsurf---input-R- humidite relative a la surface
+! rugos---input-R- rugosite
+! psol----input-R- pression au sol
+! pat1----input-R- pression au 1er niveau du modele
+!
+! t_2m---output-R- temperature de l'air a 2m
+! q_2m---output-R- humidite relative a 2m
+! u_10m--output-R- vitesse du vent a 10m
+!AM
+! t_10m--output-R- temperature de l'air a 10m
+! q_10m--output-R- humidite specifique a 10m
+! ustar--output-R- u*
+!
+      INTEGER, intent(in) :: klon, knon, nsrf
+      LOGICAL, intent(in) :: zxli
+      REAL, dimension(klon), intent(in) :: u1, v1, t1, q1, z1, ts1
+      REAL, dimension(klon), intent(in) :: qsurf, rugos
+      REAL, dimension(klon), intent(in) :: psol, pat1
+!
+      REAL, dimension(klon), intent(out) :: t_2m, q_2m, ustar
+      REAL, dimension(klon), intent(out) :: u_10m, t_10m, q_10m
+!-------------------------------------------------------------------------
+      include "YOMCST.h"
+!IM PLUS
+      include "YOETHF.h"
+!
+! Quelques constantes et options:
+!
+! RKAR : constante de von Karman
+      REAL, PARAMETER :: RKAR=0.40
+! niter : nombre iterations calcul "corrector"
+!     INTEGER, parameter :: niter=6, ncon=niter-1
+      INTEGER, parameter :: niter=2, ncon=niter-1
+!
+! Variables locales
+      INTEGER :: i, n
+      REAL :: zref
+      REAL, dimension(klon) :: speed
+! tpot : temperature potentielle
+      REAL, dimension(klon) :: tpot
+      REAL, dimension(klon) :: zri1, cdran
+      REAL, dimension(klon) :: cdram, cdrah
+! ri1 : nb. de Richardson entre la surface --> la 1ere couche
+      REAL, dimension(klon) :: ri1 
+      REAL, dimension(klon) :: testar, qstar
+      REAL, dimension(klon) :: zdte, zdq   
+! lmon : longueur de Monin-Obukhov selon Hess, Colman and McAvaney 
+      DOUBLE PRECISION, dimension(klon) :: lmon
+      DOUBLE PRECISION, parameter :: eps=1.0D-20
+      REAL, dimension(klon) :: delu, delte, delq
+      REAL, dimension(klon) :: u_zref, te_zref, q_zref  
+      REAL, dimension(klon) :: temp, pref
+      LOGICAL :: okri
+      REAL, dimension(klon) :: u_zref_p, te_zref_p, temp_p, q_zref_p
+!convertgence
+      REAL, dimension(klon) :: te_zref_con, q_zref_con
+      REAL, dimension(klon) :: u_zref_c, te_zref_c, temp_c, q_zref_c
+      REAL, dimension(klon) :: ok_pred, ok_corr
+!     REAL, dimension(klon) :: conv_te, conv_q
+!------------------------------------------------------------------------- 
+      DO i=1, knon
+       speed(i)=SQRT(u1(i)**2+v1(i)**2)
+       ri1(i) = 0.0
+      ENDDO
+!
+      okri=.FALSE.
+      CALL coefcdrag(klon, knon, nsrf, zxli, &
+ &                   speed, t1, q1, z1, psol, &
+ &                   ts1, qsurf, rugos, okri, ri1,  &         
+ &                   cdram, cdrah, cdran, zri1, pref)            
+!
+!---------Star variables----------------------------------------------------
+!
+      DO i = 1, knon
+        ri1(i) = zri1(i)
+        tpot(i) = t1(i)* (psol(i)/pat1(i))**RKAPPA
+        ustar(i) = sqrt(cdram(i) * speed(i) * speed(i))
+        zdte(i) = tpot(i) - ts1(i)
+        zdq(i) = max(q1(i),0.0) - max(qsurf(i),0.0)
+!
+!
+!IM BUG BUG BUG       zdte(i) = max(zdte(i),1.e-10)
+        zdte(i) = sign(max(abs(zdte(i)),1.e-10),zdte(i))
+!
+        testar(i) = (cdrah(i) * zdte(i) * speed(i))/ustar(i)
+        qstar(i) = (cdrah(i) * zdq(i) * speed(i))/ustar(i)
+        lmon(i) = (ustar(i) * ustar(i) * tpot(i))/ &
+ &                (RKAR * RG * testar(i))
+      ENDDO
+!
+!----------First aproximation of variables at zref --------------------------
+      zref = 2.0
+      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
+ &                 ts1, qsurf, rugos, lmon, &
+ &                 ustar, testar, qstar, zref, &
+ &                 delu, delte, delq)
+!
+      DO i = 1, knon
+        u_zref(i) = delu(i)
+        q_zref(i) = max(qsurf(i),0.0) + delq(i)
+        te_zref(i) = ts1(i) + delte(i)
+        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
+        q_zref_p(i) = q_zref(i)
+!       te_zref_p(i) = te_zref(i)
+        temp_p(i) = temp(i)
+      ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector calculation ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screenc(klon, knon, nsrf, zxli, &
+ &                   u_zref, temp, q_zref, zref, &
+ &                   ts1, qsurf, rugos, psol, &           
+ &                   ustar, testar, qstar, okri, ri1, &
+ &                   pref, delu, delte, delq) 
+!
+        DO i = 1, knon
+          u_zref(i) = delu(i)
+          q_zref(i) = delq(i) + max(qsurf(i),0.0)
+          te_zref(i) = delte(i) + ts1(i) 
+!
+! return to normal temperature
+!
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                 (1 + RVTMP2 * max(q_zref(i),0.0))
+!
+!IM +++
+!         IF(temp(i).GT.350.) THEN
+!           WRITE(*,*) 'temp(i) GT 350 K !!',i,nsrf,temp(i)
+!         ENDIF
+!IM ---
+!
+        IF(n.EQ.ncon) THEN
+          te_zref_con(i) = te_zref(i)
+          q_zref_con(i) = q_zref(i)
+        ENDIF 
+!
+        ENDDO 
+!
+      ENDDO 
+!
+! verifier le critere de convergence : 0.25% pour te_zref et 5% pour qe_zref
+!
+!       DO i = 1, knon
+!         conv_te(i) = (te_zref(i) - te_zref_con(i))/te_zref_con(i)
+!         conv_q(i) = (q_zref(i) - q_zref_con(i))/q_zref_con(i)
+!IM +++
+!         IF(abs(conv_te(i)).GE.0.0025.AND.abs(conv_q(i)).GE.0.05) THEN
+!           PRINT*,'DIV','i=',i,te_zref_con(i),te_zref(i),conv_te(i), &
+!           q_zref_con(i),q_zref(i),conv_q(i)
+!         ENDIF
+!IM ---
+!       ENDDO
+!
+      DO i = 1, knon
+        q_zref_c(i) = q_zref(i)
+        temp_c(i) = temp(i)
+!
+!       IF(zri1(i).LT.0.) THEN
+!         IF(nsrf.EQ.1) THEN
+!           ok_pred(i)=1.
+!           ok_corr(i)=0.
+!         ELSE
+!           ok_pred(i)=0.
+!           ok_corr(i)=1.
+!         ENDIF
+!       ELSE
+!         ok_pred(i)=0.
+!         ok_corr(i)=1.
+!       ENDIF
+!
+        ok_pred(i)=0.
+        ok_corr(i)=1.
+!
+        t_2m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
+        q_2m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
+!IM +++
+!       IF(n.EQ.niter) THEN
+!       IF(t_2m(i).LT.t1(i).AND.t_2m(i).LT.ts1(i)) THEN
+!         PRINT*,' BAD t2m LT ',i,nsrf,t_2m(i),t1(i),ts1(i) 
+!       ELSEIF(t_2m(i).GT.t1(i).AND.t_2m(i).GT.ts1(i)) THEN
+!         PRINT*,' BAD t2m GT ',i,nsrf,t_2m(i),t1(i),ts1(i) 
+!       ENDIF
+!       ENDIF
+!IM ---
+      ENDDO
+!
+!
+!----------First aproximation of variables at zref --------------------------
+!
+      zref = 10.0
+      CALL screenp(klon, knon, nsrf, speed, tpot, q1, &
+ &                 ts1, qsurf, rugos, lmon, &
+ &                 ustar, testar, qstar, zref, &
+ &                 delu, delte, delq)
+!
+      DO i = 1, knon
+        u_zref(i) = delu(i)
+        q_zref(i) = max(qsurf(i),0.0) + delq(i)
+        te_zref(i) = ts1(i) + delte(i)
+        temp(i) = te_zref(i) * (psol(i)/pat1(i))**(-RKAPPA)
+!       temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                 (1 + RVTMP2 * max(q_zref(i),0.0))
+        u_zref_p(i) = u_zref(i)
+      ENDDO
+!
+! Iteration of the variables at the reference level zref : corrector ; see Hess & McAvaney, 1995 
+!
+      DO n = 1, niter
+!
+        okri=.TRUE.
+        CALL screenc(klon, knon, nsrf, zxli, &
+ &                   u_zref, temp, q_zref, zref, &
+ &                   ts1, qsurf, rugos, psol, &
+ &                   ustar, testar, qstar, okri, ri1, &
+ &                   pref, delu, delte, delq)
+!
+        DO i = 1, knon
+          u_zref(i) = delu(i)
+          q_zref(i) = delq(i) + max(qsurf(i),0.0)
+          te_zref(i) = delte(i) + ts1(i)
+          temp(i) = te_zref(i) * (psol(i)/pref(i))**(-RKAPPA)
+!         temp(i) = te_zref(i) - (zref* RG)/RCPD/ &
+!                   (1 + RVTMP2 * max(q_zref(i),0.0))
+        ENDDO 
+!
+      ENDDO
+!
+      DO i = 1, knon
+        u_zref_c(i) = u_zref(i)
+!
+        u_10m(i) = u_zref_p(i) * ok_pred(i) + u_zref_c(i) * ok_corr(i)
+!
+!AM
+        q_zref_c(i) = q_zref(i)
+        temp_c(i) = temp(i)
+        t_10m(i) = temp_p(i) * ok_pred(i) + temp_c(i) * ok_corr(i)
+        q_10m(i) = q_zref_p(i) * ok_pred(i) + q_zref_c(i) * ok_corr(i)
+!MA
+      ENDDO
+! 
+      RETURN
+      END subroutine stdlevvar
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/stratocu_if.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/stratocu_if.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/stratocu_if.F90	(revision 17)
@@ -0,0 +1,80 @@
+  SUBROUTINE stratocu_if(klon,klev,pctsrf,paprs, pplay,t &
+,seuil_inversion,weak_inversion,dthmin)
+
+  USE indice_sol_mod
+
+IMPLICIT NONE
+
+!======================================================================
+! J'introduit un peu de diffusion sauf dans les endroits
+! ou une forte inversion est presente
+! On peut dire qu'il represente la convection peu profonde
+!
+! Arguments:
+! klon-----input-I- nombre de points a traiter
+! paprs----input-R- pression a chaque intercouche (en Pa)
+! pplay----input-R- pression au milieu de chaque couche (en Pa)
+! t--------input-R- temperature (K)
+!
+! weak_inversion-----logical
+!======================================================================
+!
+! Arguments:
+!
+    INTEGER, INTENT(IN)                       :: klon,klev
+    REAL, DIMENSION(klon, klev+1), INTENT(IN) ::  paprs
+    REAL, DIMENSION(klon, klev), INTENT(IN)   ::  pplay
+    REAL, DIMENSION(klon, 4), INTENT(IN)   ::  pctsrf
+    REAL, DIMENSION(klon, klev), INTENT(IN)   :: t
+    
+    REAL, DIMENSION(klon), INTENT(OUT)  :: weak_inversion
+!
+! Quelques constantes et options:
+!
+    REAL seuil_inversion ! au-dela l'inversion est consideree trop faible
+!    PARAMETER (seuil=-0.1)
+
+!
+! Variables locales:
+!
+    INTEGER i, k, invb(klon)
+    REAL zl2(klon)
+    REAL dthmin(klon), zdthdp
+
+    INCLUDE "YOMCST.h"
+
+!
+! Chercher la zone d'inversion forte
+!
+
+    DO i = 1, klon
+       invb(i) = klev
+       dthmin(i)=0.0
+    ENDDO
+    DO k = 2, klev/2-1
+       DO i = 1, klon
+          zdthdp = (t(i,k)-t(i,k+1))/(pplay(i,k)-pplay(i,k+1)) &
+               - RD * 0.5*(t(i,k)+t(i,k+1))/RCPD/paprs(i,k+1)
+          zdthdp = zdthdp * 100.0
+          IF (pplay(i,k).GT.0.8*paprs(i,1) .AND. &
+               zdthdp.LT.dthmin(i) ) THEN
+             dthmin(i) = zdthdp
+             invb(i) = k
+          ENDIF
+       ENDDO
+    ENDDO
+
+
+!
+! Introduire une diffusion:
+!
+    DO i = 1, klon
+       IF ( (pctsrf(i,is_oce) < 0.5) .OR. &
+          (invb(i) == klev) .OR. (dthmin(i) > seuil_inversion) ) THEN 
+          weak_inversion(i)=1.
+       ELSE
+          weak_inversion(i)=0.
+       ENDIF
+    ENDDO
+
+  END SUBROUTINE stratocu_if
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/suphel.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/suphel.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/suphel.F	(revision 17)
@@ -0,0 +1,211 @@
+!
+! $Header$
+!
+      SUBROUTINE suphel
+C
+#include "YOMCST.h"
+#include "YOETHF.h"
+cIM cf. JLD
+       LOGICAL firstcall
+       SAVE firstcall
+c$OMP THREADPRIVATE(firstcall)
+       DATA firstcall /.TRUE./
+       
+       IF (firstcall) THEN
+         PRINT*, 'suphel initialise les constantes du GCM'
+         firstcall = .FALSE.
+       ELSE
+         PRINT*, 'suphel DEJA APPELE '
+         RETURN
+       ENDIF
+C      -----------------------------------------------------------------
+C
+C*       1.    DEFINE FUNDAMENTAL CONSTANTS.
+C              -----------------------------
+C
+      WRITE(UNIT=6,FMT='(''0*** Constants of the ICM   ***'')')
+      RPI=2.*ASIN(1.)
+      RCLUM=299792458.
+      RHPLA=6.6260755E-34
+      RKBOL=1.380658E-23
+      RNAVO=6.0221367E+23
+      WRITE(UNIT=6,FMT='('' *** Fundamental constants ***'')')
+      WRITE(UNIT=6,FMT='(''           PI = '',E13.7,'' -'')')RPI
+      WRITE(UNIT=6,FMT='(''            c = '',E13.7,''m s-1'')')
+     S RCLUM
+      WRITE(UNIT=6,FMT='(''            h = '',E13.7,''J s'')')
+     S RHPLA
+      WRITE(UNIT=6,FMT='(''            K = '',E13.7,''J K-1'')')
+     S RKBOL
+      WRITE(UNIT=6,FMT='(''            N = '',E13.7,''mol-1'')')
+     S RNAVO
+C
+C     ----------------------------------------------------------------
+C
+C*       2.    DEFINE ASTRONOMICAL CONSTANTS.
+C              ------------------------------
+C
+      RDAY=86400.
+      REA=149597870000.
+      REPSM=0.409093
+C
+      RSIYEA=365.25*RDAY*2.*RPI/6.283076
+      RSIDAY=RDAY/(1.+RDAY/RSIYEA)
+      ROMEGA=2.*RPI/RSIDAY
+c
+c exp1      R_ecc = 0.05
+c exp1      R_peri = 102.04
+c exp1      R_incl = 22.5
+c exp1      print*, 'Parametres orbitaux modifies'
+c ref      R_ecc = 0.016724
+c ref      R_peri = 102.04
+c ref      R_incl = 23.5
+c
+cIM 161002 : pour avoir les ctes AMIP II
+cIM 161002   R_ecc = 0.016724
+cIM 161002   R_peri = 102.04
+cIM 161002   R_incl = 23.5
+cIM on mets R_ecc, R_peri, R_incl dans conf_phys.F90
+c     R_ecc = 0.016715
+c     R_peri = 102.7
+c     R_incl = 23.441
+c
+      WRITE(UNIT=6,FMT='('' *** Astronomical constants ***'')')
+      WRITE(UNIT=6,FMT='(''          day = '',E13.7,'' s'')')RDAY
+      WRITE(UNIT=6,FMT='('' half g. axis = '',E13.7,'' m'')')REA
+      WRITE(UNIT=6,FMT='('' mean anomaly = '',E13.7,'' -'')')REPSM
+      WRITE(UNIT=6,FMT='('' sideral year = '',E13.7,'' s'')')RSIYEA
+      WRITE(UNIT=6,FMT='(''  sideral day = '',E13.7,'' s'')')RSIDAY
+      WRITE(UNIT=6,FMT='(''        omega = '',E13.7,'' s-1'')')
+     S                  ROMEGA
+c     write(unit=6,fmt='('' excentricite = '',e13.7,''-'')')R_ecc
+c     write(unit=6,fmt='(''     equinoxe = '',e13.7,''-'')')R_peri
+c     write(unit=6,fmt='(''  inclinaison = '',e13.7,''-'')')R_incl
+C
+C     ------------------------------------------------------------------
+C
+C*       3.    DEFINE GEOIDE.
+C              --------------
+C
+      RG=9.80665
+      RA=6371229.
+      R1SA=SNGL(1.D0/DBLE(RA))
+      WRITE(UNIT=6,FMT='('' ***         Geoide         ***'')')
+      WRITE(UNIT=6,FMT='(''      Gravity = '',E13.7,'' m s-2'')')
+     S      RG
+      WRITE(UNIT=6,FMT='('' Earth radius = '',E13.7,'' m'')')RA
+      WRITE(UNIT=6,FMT='('' Inverse E.R. = '',E13.7,'' m'')')R1SA
+C
+C     -----------------------------------------------------------------
+C
+C*       4.    DEFINE RADIATION CONSTANTS.
+C              ---------------------------
+C
+c z.x.li      RSIGMA=2. * RPI**5 * RKBOL**4 /(15.* RCLUM**2 * RHPLA**3)
+      rsigma = 2.*rpi**5 * (rkbol/rhpla)**3 * rkbol/rclum/rclum/15.
+cIM init. dans conf_phys.F90   RI0=1365.
+      WRITE(UNIT=6,FMT='('' ***        Radiation       ***'')')
+      WRITE(UNIT=6,FMT='('' Stefan-Bol.  = '',E13.7,'' W m-2 K-4''
+     S )')  RSIGMA
+cIM init. dans conf_phys.F90   WRITE(UNIT=6,FMT='('' Solar const. = '',E13.7,'' W m-2'')')
+cIM init. dans conf_phys.F90  S      RI0
+C
+C     -----------------------------------------------------------------
+C
+C*       5.    DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE.
+C              ------------------------------------------
+C
+      R=RNAVO*RKBOL
+      RMD=28.9644
+      RMO3=47.9942
+      RMV=18.0153
+      RD=1000.*R/RMD
+      RV=1000.*R/RMV
+      RCPD=3.5*RD
+      RCVD=RCPD-RD
+      RCPV=4. *RV
+      RCVV=RCPV-RV
+      RKAPPA=RD/RCPD
+      RETV=RV/RD-1.
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, gas     ***'')')
+      WRITE(UNIT=6,FMT='('' Perfect gas  = '',e13.7)') R
+      WRITE(UNIT=6,FMT='('' Dry air mass = '',e13.7)') RMD
+      WRITE(UNIT=6,FMT='('' Ozone   mass = '',e13.7)') RMO3
+      WRITE(UNIT=6,FMT='('' Vapour  mass = '',e13.7)') RMV
+      WRITE(UNIT=6,FMT='('' Dry air cst. = '',e13.7)') RD
+      WRITE(UNIT=6,FMT='('' Vapour  cst. = '',e13.7)') RV
+      WRITE(UNIT=6,FMT='(''         Cpd  = '',e13.7)') RCPD
+      WRITE(UNIT=6,FMT='(''         Cvd  = '',e13.7)') RCVD
+      WRITE(UNIT=6,FMT='(''         Cpv  = '',e13.7)') RCPV
+      WRITE(UNIT=6,FMT='(''         Cvv  = '',e13.7)') RCVV
+      WRITE(UNIT=6,FMT='(''      Rd/Cpd  = '',e13.7)') RKAPPA
+      WRITE(UNIT=6,FMT='(''     Rv/Rd-1  = '',e13.7)') RETV
+C
+C     ----------------------------------------------------------------
+C
+C*       6.    DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE.
+C              ---------------------------------------------
+C
+      RCW=RCPV
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, liquid  ***'')')
+      WRITE(UNIT=6,FMT='(''         Cw   = '',E13.7)') RCW
+C
+C     ----------------------------------------------------------------
+C
+C*       7.    DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE.
+C              --------------------------------------------
+C
+      RCS=RCPV
+      WRITE(UNIT=6,FMT='('' *** thermodynamic, solid   ***'')')
+      WRITE(UNIT=6,FMT='(''         Cs   = '',E13.7)') RCS
+C
+C     ----------------------------------------------------------------
+C
+C*       8.    DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE.
+C              ----------------------------------------------------
+C
+      RTT=273.16
+      RLVTT=2.5008E+6
+      RLSTT=2.8345E+6
+      RLMLT=RLSTT-RLVTT
+      RATM=100000.
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, trans.  ***'')')
+      WRITE(UNIT=6,FMT='('' Fusion point  = '',E13.7)') RTT
+      WRITE(UNIT=6,FMT='(''        RLvTt  = '',E13.7)') RLVTT
+      WRITE(UNIT=6,FMT='(''        RLsTt  = '',E13.7)') RLSTT
+      WRITE(UNIT=6,FMT='(''        RLMlt  = '',E13.7)') RLMLT
+      WRITE(UNIT=6,FMT='('' Normal press. = '',E13.7)') RATM
+      WRITE(UNIT=6,FMT='('' Latent heat :  '')')
+C
+C     ----------------------------------------------------------------
+C
+C*       9.    SATURATED VAPOUR PRESSURE.
+C              --------------------------
+C
+      RESTT=611.14
+      RGAMW=(RCW-RCPV)/RV
+      RBETW=RLVTT/RV+RGAMW*RTT
+      RALPW=LOG(RESTT)+RBETW/RTT+RGAMW*LOG(RTT)
+      RGAMS=(RCS-RCPV)/RV
+      RBETS=RLSTT/RV+RGAMS*RTT
+      RALPS=LOG(RESTT)+RBETS/RTT+RGAMS*LOG(RTT)
+      RGAMD=RGAMS-RGAMW
+      RBETD=RBETS-RBETW
+      RALPD=RALPS-RALPW
+C
+C     ------------------------------------------------------------------
+c
+c calculer les constantes pour les fonctions thermodynamiques
+c
+      RVTMP2=RCPV/RCPD-1.
+      RHOH2O=RATM/100.
+      R2ES=RESTT*RD/RV
+      R3LES=17.269
+      R3IES=21.875
+      R4LES=35.86
+      R4IES=7.66
+      R5LES=R3LES*(RTT-R4LES)
+      R5IES=R3IES*(RTT-R4IES)
+C
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/suphel.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/suphel.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/suphel.F90	(revision 17)
@@ -0,0 +1,235 @@
+!
+! $Header$
+!
+      SUBROUTINE suphel
+
+!L. Fita, LMD. September 2013
+       IMPLICIT NONE
+
+!C
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "../share/module_model_constants.F.h"
+!IM cf. JLD
+       LOGICAL firstcall
+       SAVE firstcall
+!$OMP THREADPRIVATE(firstcall)
+       DATA firstcall /.TRUE./
+       
+       IF (firstcall) THEN
+         PRINT*, 'suphel initialise les constantes du GCM'
+         firstcall = .FALSE.
+       ELSE
+         PRINT*, 'suphel DEJA APPELE '
+         RETURN
+       ENDIF
+!C      -----------------------------------------------------------------
+!C
+!C*       1.    DEFINE FUNDAMENTAL CONSTANTS.
+!C              -----------------------------
+!C
+      WRITE(UNIT=6,FMT='(''0*** Constants of the ICM   ***'')')
+      RPI=2.*ASIN(1.)
+      RCLUM=299792458.
+      RHPLA=6.6260755E-34
+      RKBOL=1.380658E-23
+      RNAVO=6.0221367E+23
+      WRITE(UNIT=6,FMT='('' *** Fundamental constants ***'')')
+      WRITE(UNIT=6,FMT='(''           PI = '',E13.7,'' -'')')RPI
+      WRITE(UNIT=6,FMT='(''            c = '',E13.7,''m s-1'')')                     &
+       & RCLUM
+      WRITE(UNIT=6,FMT='(''            h = '',E13.7,''J s'')')                       &
+       & RHPLA
+      WRITE(UNIT=6,FMT='(''            K = '',E13.7,''J K-1'')')                     &
+       & RKBOL
+      WRITE(UNIT=6,FMT='(''            N = '',E13.7,''mol-1'')')                     &
+       & RNAVO
+!C
+!C     ----------------------------------------------------------------
+!C
+!C*       2.    DEFINE ASTRONOMICAL CONSTANTS.
+!C              ------------------------------
+!C
+      RDAY=86400.
+      REA=149597870000.
+      REPSM=0.409093
+!C
+      RSIYEA=365.25*RDAY*2.*RPI/6.283076
+      RSIDAY=RDAY/(1.+RDAY/RSIYEA)
+      ROMEGA=2.*RPI/RSIDAY
+!c
+!c exp1      R_ecc = 0.05
+!c exp1      R_peri = 102.04
+!c exp1      R_incl = 22.5
+!c exp1      print*, 'Parametres orbitaux modifies'
+!c ref      R_ecc = 0.016724
+!c ref      R_peri = 102.04
+!c ref      R_incl = 23.5
+!c
+!IM 161002 : pour avoir les ctes AMIP II
+!IM 161002   R_ecc = 0.016724
+!IM 161002   R_peri = 102.04
+!IM 161002   R_incl = 23.5
+!IM on mets R_ecc, R_peri, R_incl dans conf_phys.F90
+!c     R_ecc = 0.016715
+!c     R_peri = 102.7
+!c     R_incl = 23.441
+!c
+      WRITE(UNIT=6,FMT='('' *** Astronomical constants ***'')')
+      WRITE(UNIT=6,FMT='(''          day = '',E13.7,'' s'')')RDAY
+      WRITE(UNIT=6,FMT='('' half g. axis = '',E13.7,'' m'')')REA
+      WRITE(UNIT=6,FMT='('' mean anomaly = '',E13.7,'' -'')')REPSM
+      WRITE(UNIT=6,FMT='('' sideral year = '',E13.7,'' s'')')RSIYEA
+      WRITE(UNIT=6,FMT='(''  sideral day = '',E13.7,'' s'')')RSIDAY
+      WRITE(UNIT=6,FMT='(''        omega = '',E13.7,'' s-1'')')                      &
+       &                  ROMEGA
+!c     write(unit=6,fmt='('' excentricite = '',e13.7,''-'')')R_ecc
+!c     write(unit=6,fmt='(''     equinoxe = '',e13.7,''-'')')R_peri
+!c     write(unit=6,fmt='(''  inclinaison = '',e13.7,''-'')')R_incl
+!C
+!C     ------------------------------------------------------------------
+!C
+!C*       3.    DEFINE GEOIDE.
+!C              --------------
+!C
+!L. Fita, LMD. September 2013
+!      RG=9.80665
+!      RA=6371229.
+
+      RG=g
+      RA=1.d0/reradius
+      R1SA=SNGL(1.D0/DBLE(RA))
+      WRITE(UNIT=6,FMT='('' ***         Geoide         ***'')')
+      WRITE(UNIT=6,FMT='(''      Gravity = '',E13.7,'' m s-2'')')                    &
+       &      RG
+      WRITE(UNIT=6,FMT='('' Earth radius = '',E13.7,'' m'')')RA
+      WRITE(UNIT=6,FMT='('' Inverse E.R. = '',E13.7,'' m'')')R1SA
+!C
+!C     -----------------------------------------------------------------
+!C
+!C*       4.    DEFINE RADIATION CONSTANTS.
+!C              ---------------------------
+!C
+!c z.x.li      RSIGMA=2. * RPI**5 * RKBOL**4 /(15.* RCLUM**2 * RHPLA**3)
+!L. Fita, LMD. September 2013
+!      rsigma = 2.*rpi**5 * (rkbol/rhpla)**3 * rkbol/rclum/rclum/15.
+      rsigma = STBOLT
+!IM init. dans conf_phys.F90   RI0=1365.
+      WRITE(UNIT=6,FMT='('' ***        Radiation       ***'')')
+      WRITE(UNIT=6,FMT='('' Stefan-Bol.  = '',E13.7,'' W m-2 K-4''                   &
+       & )')  RSIGMA
+!IM init. dans conf_phys.F90   WRITE(UNIT=6,FMT='('' Solar const. = '',E13.7,'' W m-2'')')
+!IM init. dans conf_phys.F90  S      RI0
+!C
+!C     -----------------------------------------------------------------
+!C
+!C*       5.    DEFINE THERMODYNAMIC CONSTANTS, GAS PHASE.
+!C              ------------------------------------------
+!C
+      R=RNAVO*RKBOL
+!L. Fita, LMD. September 2013
+!      RMD=28.9644
+      RMD = mwdry
+      RMO3=47.9942
+      RMV=18.0153
+!L. Fita, LMD. September 2013
+!      RD=1000.*R/RMD
+!      RV=1000.*R/RMV
+!      RCPD=3.5*RD
+      RD = r_d
+      RV = r_v
+      RCPD = cp
+      RCVD=RCPD-RD
+      RCPV=4. *RV
+      RCVV=RCPV-RV
+      RKAPPA=RD/RCPD
+      RETV=RV/RD-1.
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, gas     ***'')')
+      WRITE(UNIT=6,FMT='('' Perfect gas  = '',e13.7)') R
+      WRITE(UNIT=6,FMT='('' Dry air mass = '',e13.7)') RMD
+      WRITE(UNIT=6,FMT='('' Ozone   mass = '',e13.7)') RMO3
+      WRITE(UNIT=6,FMT='('' Vapour  mass = '',e13.7)') RMV
+      WRITE(UNIT=6,FMT='('' Dry air cst. = '',e13.7)') RD
+      WRITE(UNIT=6,FMT='('' Vapour  cst. = '',e13.7)') RV
+      WRITE(UNIT=6,FMT='(''         Cpd  = '',e13.7)') RCPD
+      WRITE(UNIT=6,FMT='(''         Cvd  = '',e13.7)') RCVD
+      WRITE(UNIT=6,FMT='(''         Cpv  = '',e13.7)') RCPV
+      WRITE(UNIT=6,FMT='(''         Cvv  = '',e13.7)') RCVV
+      WRITE(UNIT=6,FMT='(''      Rd/Cpd  = '',e13.7)') RKAPPA
+      WRITE(UNIT=6,FMT='(''     Rv/Rd-1  = '',e13.7)') RETV
+!C
+!C     ----------------------------------------------------------------
+!C
+!C*       6.    DEFINE THERMODYNAMIC CONSTANTS, LIQUID PHASE.
+!C              ---------------------------------------------
+!C
+      RCW=RCPV
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, liquid  ***'')')
+      WRITE(UNIT=6,FMT='(''         Cw   = '',E13.7)') RCW
+!C
+!C     ----------------------------------------------------------------
+!C
+!C*       7.    DEFINE THERMODYNAMIC CONSTANTS, SOLID PHASE.
+!C              --------------------------------------------
+!C
+      RCS=RCPV
+      WRITE(UNIT=6,FMT='('' *** thermodynamic, solid   ***'')')
+      WRITE(UNIT=6,FMT='(''         Cs   = '',E13.7)') RCS
+!C
+!C     ----------------------------------------------------------------
+!C
+!C*       8.    DEFINE THERMODYNAMIC CONSTANTS, TRANSITION OF PHASE.
+!C              ----------------------------------------------------
+!C
+!L. Fita, LMD. September 2013
+!      RTT=273.16
+      RTT = SVPT0
+      RLVTT=2.5008E+6
+      RLSTT=2.8345E+6
+      RLMLT=RLSTT-RLVTT
+      RATM=100000.
+      WRITE(UNIT=6,FMT='('' *** Thermodynamic, trans.  ***'')')
+      WRITE(UNIT=6,FMT='('' Fusion point  = '',E13.7)') RTT
+      WRITE(UNIT=6,FMT='(''        RLvTt  = '',E13.7)') RLVTT
+      WRITE(UNIT=6,FMT='(''        RLsTt  = '',E13.7)') RLSTT
+      WRITE(UNIT=6,FMT='(''        RLMlt  = '',E13.7)') RLMLT
+      WRITE(UNIT=6,FMT='('' Normal press. = '',E13.7)') RATM
+      WRITE(UNIT=6,FMT='('' Latent heat :  '')')
+!C
+!C     ----------------------------------------------------------------
+!C
+!C*       9.    SATURATED VAPOUR PRESSURE.
+!C              --------------------------
+!C
+!L. Fita, LMD. September 2013
+!      RESTT=611.14
+      RESTT = SVP1*1000.
+      RGAMW=(RCW-RCPV)/RV
+      RBETW=RLVTT/RV+RGAMW*RTT
+      RALPW=LOG(RESTT)+RBETW/RTT+RGAMW*LOG(RTT)
+      RGAMS=(RCS-RCPV)/RV
+      RBETS=RLSTT/RV+RGAMS*RTT
+      RALPS=LOG(RESTT)+RBETS/RTT+RGAMS*LOG(RTT)
+      RGAMD=RGAMS-RGAMW
+      RBETD=RBETS-RBETW
+      RALPD=RALPS-RALPW
+!C
+!C     ------------------------------------------------------------------
+!c
+!c calculer les constantes pour les fonctions thermodynamiques
+!c
+      RVTMP2=RCPV/RCPD-1.
+      RHOH2O=RATM/100.
+      R2ES=RESTT*RD/RV
+      R3LES=17.269
+      R3IES=21.875
+      R4LES=35.86
+      R4IES=7.66
+      R5LES=R3LES*(RTT-R4LES)
+      R5IES=R3IES*(RTT-R4IES)
+
+      PRINT *,'Lluis exiting suphel!!!!'
+
+!C
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_land_bucket_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_land_bucket_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_land_bucket_mod.F90	(revision 17)
@@ -0,0 +1,207 @@
+!
+MODULE surf_land_bucket_mod
+!
+! Surface land bucket module
+!
+! This module is used when no external land model is choosen.
+!
+  IMPLICIT NONE
+
+CONTAINS
+
+  SUBROUTINE surf_land_bucket(itime, jour, knon, knindex, debut, dtime,&
+       tsurf, p1lay, tq_cdrag, precip_rain, precip_snow, temp_air, &
+       spechum, petAcoef, peqAcoef, petBcoef, peqBcoef, pref, &
+       u1, v1, rugoro, swnet, lwnet, &
+       snow, qsol, agesno, tsoil, &
+       qsurf, z0_new, alb1_new, alb2_new, evap, &
+       fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l)
+
+    USE limit_read_mod
+    USE surface_data
+    USE fonte_neige_mod
+    USE calcul_fluxs_mod
+    USE cpl_mod
+    USE dimphy
+    USE comgeomphy
+    USE mod_grid_phy_lmdz
+    USE mod_phys_lmdz_para
+    USE indice_sol_mod
+
+
+!L. Fita, LMD. November, 2013
+    USE NOread_limit_sub_variables
+
+!****************************************************************************************
+! Bucket calculations for surface. 
+!
+    INCLUDE "clesphys.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+
+! Input variables  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    LOGICAL, INTENT(IN)                     :: debut
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)       :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)       :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)       :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)       :: pref
+    REAL, DIMENSION(klon), INTENT(IN)       :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
+    REAL, DIMENSION(klon), INTENT(IN)       :: swnet, lwnet
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new, alb2_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon) :: soilcap, soilflux
+    REAL, DIMENSION(klon) :: cal, beta, dif_grnd, capsol
+    REAL, DIMENSION(klon) :: alb_neig, alb_lim
+    REAL, DIMENSION(klon) :: zfra
+    REAL, DIMENSION(klon) :: radsol       ! total net radiance at surface
+    REAL, DIMENSION(klon) :: u0, v0, u1_lay, v1_lay
+    REAL, DIMENSION(klon) :: dummy_riverflow,dummy_coastalflow 
+    INTEGER               :: i
+
+! Lluis
+    INTEGER               :: lpt
+
+    lpt=MIN(498,knon)
+
+!L. Fita. LMD November 2013. 
+!!  REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: rugos  ! rugosity at surface (m)
+!    ALLOCATE(z0_lim(klon))
+!    ALLOCATE(alb_lim(klon))
+!
+!****************************************************************************************
+
+
+!
+!* Read from limit.nc : albedo(alb_lim), length of rugosity(z0_new)
+!
+!L. Fita, LMD. November 2013. Not any more. Using 'wrflowinput_d[nn]' instead
+!    CALL limit_read_rug_alb(itime, dtime, jour,&
+!         knon, knindex, &
+!         z0_new, alb_lim)
+!!    z0_new=rugos(knindex(1:knon),1)
+!!    alb_lim=albedo
+!!    z0_new = 0.4
+!!    alb_lim = 0.7
+    
+    z0_new(1:knon) = z0_limit(knindex(1:knon))
+    alb_lim(1:knon) = alb_limit(knindex(1:knon))
+!
+!* Calcultaion of fluxes 
+!
+
+! calculate total absorbed radiance at surface
+       radsol(:) = 0.0
+       radsol(1:knon) = swnet(1:knon) + lwnet(1:knon)
+
+! calculate constants
+    CALL calbeta(dtime, is_ter, knon, snow, qsol, beta, capsol, dif_grnd)
+    if (type_veget=='betaclim') then
+       CALL calbeta_clim(knon,jour,rlatd(knindex(:)),beta)
+    endif
+       
+! calculate temperature, heat capacity and conduction flux in soil
+    IF (soil_model) THEN 
+       CALL soil(dtime, is_ter, knon, snow, tsurf, tsoil, soilcap, soilflux)
+       DO i=1, knon
+          cal(i) = RCPD / soilcap(i)
+          radsol(i) = radsol(i)  + soilflux(i)
+       END DO
+    ELSE 
+       cal(:) = RCPD * capsol(:)
+       IF (klon_glo .EQ. 1) THEN
+         cal(:) = 0.
+       ENDIF
+    ENDIF
+    
+! Suppose zero surface speed
+    u0(:)=0.0
+    v0(:)=0.0
+    u1_lay(:) = u1(:) - u0(:)
+    v1_lay(:) = v1(:) - v0(:)
+
+    CALL calcul_fluxs(knon, is_ter, dtime, &
+         tsurf, p1lay, cal, beta, tq_cdrag, pref, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         petAcoef, peqAcoef, petBcoef, peqBcoef, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+    
+!
+!* Calculate snow height, run_off, age of snow
+!      
+
+    CALL fonte_neige( knon, is_ter, knindex, dtime, &
+         tsurf, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+!
+!* Calculate the age of snow
+!
+    CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+    
+    WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+    
+    DO i=1, knon
+       zfra(i) = MAX(0.0,MIN(1.0, snow(i)/(snow(i)+10.0)))
+       alb_lim(i)  = alb_neig(i) *zfra(i) + alb_lim(i)*(1.0-zfra(i))
+    END DO
+
+
+!
+!* Return albedo : 
+!    alb1_new and alb2_new are here given the same values
+!
+    alb1_new(:) = 0.0
+    alb2_new(:) = 0.0
+    alb1_new(1:knon) = alb_lim(1:knon)
+    alb2_new(1:knon) = alb_lim(1:knon)
+       
+!
+!* Calculate the rugosity
+!
+    DO i = 1, knon
+       z0_new(i) = MAX(1.5e-05,SQRT(z0_new(i)**2 + rugoro(i)**2))
+    END DO
+
+!* Send to coupler
+!  The run-off from river and coast are not calculated in the bucket modele.
+!  For testing purpose of the coupled modele we put the run-off to zero.
+    IF (type_ocean=='couple') THEN
+       dummy_riverflow(:)   = 0.0
+       dummy_coastalflow(:) = 0.0
+       CALL cpl_send_land_fields(itime, knon, knindex, &
+            dummy_riverflow, dummy_coastalflow)
+    ENDIF
+
+!
+!* End
+!
+  END SUBROUTINE surf_land_bucket
+!
+!****************************************************************************************
+!
+END MODULE surf_land_bucket_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_land_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_land_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_land_mod.F90	(revision 17)
@@ -0,0 +1,183 @@
+!
+MODULE surf_land_mod
+  
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!  
+  SUBROUTINE surf_land(itime, dtime, date0, jour, knon, knindex, &
+       rlon, rlat, &
+       debut, lafin, zlev, ccanopy, swnet, lwnet, albedo, &
+       tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       AcoefH, AcoefQ, BcoefH, BcoefQ, &
+       AcoefU, AcoefV, BcoefU, BcoefV, & 
+       pref, u1, v1, rugoro, pctsrf, &
+       lwdown_m, q2m, t2m, &
+       snow, qsol, agesno, tsoil, &
+       z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
+       qsurf, tsurf_new, dflux_s, dflux_l, &
+       flux_u1, flux_v1 ) 
+
+    USE dimphy
+    USE surface_data, ONLY    : ok_veget
+
+#ifdef ORCHIDEE_NOOPENMP
+    USE surf_land_orchidee_noopenmp_mod
+#else
+    USE surf_land_orchidee_mod
+#endif
+    USE surf_land_bucket_mod
+    USE calcul_fluxs_mod
+    USE indice_sol_mod
+
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+
+! Input variables  
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, INTENT(IN)                        :: date0
+    REAL, DIMENSION(klon), INTENT(IN)       :: rlon, rlat
+    LOGICAL, INTENT(IN)                     :: debut, lafin
+    REAL, INTENT(IN)                        :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)       :: zlev, ccanopy
+    REAL, DIMENSION(klon), INTENT(IN)       :: swnet, lwnet
+    REAL, DIMENSION(klon), INTENT(IN)       :: albedo  ! albedo for whole short-wave interval
+    REAL, DIMENSION(klon), INTENT(IN)       :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)       :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)       :: cdragh, cdragm
+    REAL, DIMENSION(klon), INTENT(IN)       :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)       :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)       :: AcoefH, AcoefQ, BcoefH, BcoefQ
+    REAL, DIMENSION(klon), INTENT(IN)       :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)       :: pref   ! pressure reference
+    REAL, DIMENSION(klon), INTENT(IN)       :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)       :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN) :: pctsrf
+    REAL, DIMENSION(klon), INTENT(IN)       :: lwdown_m  ! downwelling longwave radiation at mean surface
+                                                         ! corresponds to previous sollwdown
+    REAL, DIMENSION(klon), INTENT(IN)       :: q2m, t2m
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new ! albdeo for shortwave interval 1(visible)
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb2_new ! albedo for shortwave interval 2(near infrared)
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap
+    REAL, DIMENSION(klon), INTENT(OUT)       :: fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: flux_u1, flux_v1  ! flux for U and V at first model level
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon) :: p1lay_tmp
+    REAL, DIMENSION(klon) :: pref_tmp
+    REAL, DIMENSION(klon) :: swdown     ! downwelling shortwave radiation at land surface
+    REAL, DIMENSION(klon) :: lwdown     ! downwelling longwave radiation at land surface
+    REAL, DIMENSION(klon) :: epot_air           ! potential air temperature
+    REAL, DIMENSION(klon) :: tsol_rad, emis_new ! output from interfsol not used
+    REAL, DIMENSION(klon) :: u0, v0     ! surface speed
+    INTEGER               :: i
+
+! Lluis
+    INTEGER                                              :: lpt
+    lpt = 1
+
+!**************************************************************************************** 
+! Choice between call to vegetation model (ok_veget=true) or simple calculation below
+!
+!****************************************************************************************
+   IF (ok_veget) THEN
+!****************************************************************************************
+!  Call model sechiba in model ORCHIDEE
+!
+!****************************************************************************************
+       p1lay_tmp(:)      = 0.0
+       pref_tmp(:)       = 0.0
+       p1lay_tmp(1:knon) = p1lay(1:knon)/100.
+       pref_tmp(1:knon)  = pref(1:knon)/100.
+! 
+!* Calculate incoming flux for SW and LW interval: swdown, lwdown
+!
+       swdown(:) = 0.0
+       lwdown(:) = 0.0
+       DO i = 1, knon
+          swdown(i) = swnet(i)/(1-albedo(i))
+          lwdown(i) = lwnet(i) + RSIGMA*tsurf(i)**4
+       END DO
+!
+!* Calculate potential air temperature
+!
+       epot_air(:) = 0.0
+       DO i = 1, knon
+          epot_air(i) = RCPD*temp_air(i)*(pref(i)/p1lay(i))**RKAPPA
+       END DO
+
+       ! temporary for keeping same results using lwdown_m instead of lwdown
+       CALL surf_land_orchidee(itime, dtime, date0, knon, &
+            knindex, rlon, rlat, pctsrf, &
+            debut, lafin, &
+            zlev,  u1, v1, temp_air, spechum, epot_air, ccanopy, & 
+            cdragh, AcoefH, AcoefQ, BcoefH, BcoefQ, &
+            precip_rain, precip_snow, lwdown_m, swnet, swdown, &
+            pref_tmp, q2m, t2m, &
+            evap, fluxsens, fluxlat, &              
+            tsol_rad, tsurf_new, alb1_new, alb2_new, &
+            emis_new, z0_new, qsurf)       
+
+!  
+!* Add contribution of relief to surface roughness
+!  
+       DO i=1,knon
+          z0_new(i) = MAX(1.5e-05,SQRT(z0_new(i)**2 + rugoro(i)**2))
+       ENDDO
+
+    ELSE  ! not ok_veget
+!****************************************************************************************
+! No extern vegetation model choosen, call simple bucket calculations instead.
+!
+!****************************************************************************************
+       PRINT *,'  Lluis before surf_land_bucket tsurf: ',tsurf(lpt), qsol(lpt)
+       CALL surf_land_bucket(itime, jour, knon, knindex, debut, dtime,&
+            tsurf, p1lay, cdragh, precip_rain, precip_snow, temp_air, &
+            spechum, AcoefH, AcoefQ, BcoefH, BcoefQ, pref, &
+            u1, v1, rugoro, swnet, lwnet, &
+            snow, qsol, agesno, tsoil, &
+            qsurf, z0_new, alb1_new, alb2_new, evap, &
+            fluxsens, fluxlat, tsurf_new, dflux_s, dflux_l)
+       PRINT *,'  Lluis after surf_land_bucket tsurf: ',tsurf(lpt), qsol(lpt)
+
+    ENDIF ! ok_veget
+
+!****************************************************************************************
+! Calculation for all land models
+! - Flux calculation at first modele level for U and V
+!****************************************************************************************
+! Suppose zero surface speed
+    u0(:)=0.0
+    v0(:)=0.0
+    CALL calcul_flux_wind(knon, dtime, &
+         u0, v0, u1, v1, cdragm, &
+         AcoefU, AcoefV, BcoefU, BcoefV, &
+         p1lay, temp_air, &
+         flux_u1, flux_v1)
+    
+  END SUBROUTINE surf_land
+!
+!****************************************************************************************
+!  
+END MODULE surf_land_mod
+!
+!****************************************************************************************
+!  
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_land_orchidee_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_land_orchidee_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_land_orchidee_mod.F90	(revision 17)
@@ -0,0 +1,649 @@
+!
+MODULE surf_land_orchidee_mod
+#ifndef ORCHIDEE_NOOPENMP
+!
+! This module controles the interface towards the model ORCHIDEE
+!
+! Subroutines in this module : surf_land_orchidee
+!                              Init_orchidee_index
+!                              Get_orchidee_communicator
+!                              Init_neighbours
+
+  USE dimphy
+#ifdef CPP_VEGET
+  USE intersurf     ! module d'ORCHIDEE
+#endif
+  USE cpl_mod,      ONLY : cpl_send_land_fields
+  USE surface_data, ONLY : type_ocean
+  USE comgeomphy,   ONLY : cuphy, cvphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para, mpi_root_rank=>mpi_root
+
+  IMPLICIT NONE
+
+  PRIVATE
+  PUBLIC  :: surf_land_orchidee
+
+  LOGICAL, ALLOCATABLE, SAVE :: flag_omp(:)
+CONTAINS
+!
+!****************************************************************************************
+!  
+  SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, &
+       knindex, rlon, rlat, pctsrf, &
+       debut, lafin, &
+       plev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
+       tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       precip_rain, precip_snow, lwdown, swnet, swdown, &
+       ps, q2m, t2m, &
+       evap, fluxsens, fluxlat, &              
+       tsol_rad, tsurf_new, alb1_new, alb2_new, &
+       emis_new, z0_new, qsurf)
+
+    USE mod_surf_para
+    USE mod_synchro_omp
+    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl
+    USE indice_sol_mod
+
+!    
+! Cette routine sert d'interface entre le modele atmospherique et le 
+! modele de sol continental. Appel a sechiba
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps
+!   dtime        pas de temps de la physique (en s)
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points de la surface a traiter
+!   knindex      index des points de la surface a traiter
+!   rlon         longitudes de la grille entiere
+!   rlat         latitudes de la grille entiere
+!   pctsrf       tableau des fractions de surface de chaque maille
+!   debut        logical: 1er appel a la physique (lire les restart)
+!   lafin        logical: dernier appel a la physique (ecrire les restart)
+!                     (si false calcul simplifie des fluxs sur les continents)
+!   plev         hauteur de la premiere couche (Pa)      
+!   u1_lay       vitesse u 1ere couche
+!   v1_lay       vitesse v 1ere couche
+!   temp_air     temperature de l'air 1ere couche
+!   spechum      humidite specifique 1ere couche
+!   epot_air     temp pot de l'air
+!   ccanopy      concentration CO2 canopee, correspond au co2_send de 
+!                carbon_cycle_mod ou valeur constant co2_ppm
+!   tq_cdrag     cdrag
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   precip_rain  precipitation liquide
+!   precip_snow  precipitation solide
+!   lwdown       flux IR descendant a la surface
+!   swnet        flux solaire net
+!   swdown       flux solaire entrant a la surface
+!   ps           pression au sol
+!   radsol       rayonnement net aus sol (LW + SW)
+!   
+!
+! output:
+!   evap         evaporation totale
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   tsol_rad     
+!   tsurf_new    temperature au sol
+!   alb1_new     albedo in visible SW interval
+!   alb2_new     albedo in near IR interval
+!   emis_new     emissivite
+!   z0_new       surface roughness
+!   qsurf        air moisture at surface
+!
+    INCLUDE "temps.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "dimensions.h"
+  
+!
+! Parametres d'entree
+!****************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    REAL, INTENT(IN)                          :: dtime
+    REAL, INTENT(IN)                          :: date0
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    LOGICAL, INTENT(IN)                       :: debut, lafin
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)   :: pctsrf
+    REAL, DIMENSION(klon), INTENT(IN)         :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)         :: plev
+    REAL, DIMENSION(klon), INTENT(IN)         :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)         :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)         :: epot_air, ccanopy
+    REAL, DIMENSION(klon), INTENT(IN)         :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)         :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)         :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)         :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)         :: lwdown, swnet, swdown, ps
+    REAL, DIMENSION(klon), INTENT(IN)         :: q2m, t2m
+
+! Parametres de sortie
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)        :: evap, fluxsens, fluxlat, qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)        :: tsol_rad, tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)        :: alb1_new, alb2_new
+    REAL, DIMENSION(klon), INTENT(OUT)        :: emis_new, z0_new
+
+! Local
+!****************************************************************************************
+    INTEGER                                   :: ij, jj, igrid, ireal, index
+    INTEGER                                   :: error
+    REAL, DIMENSION(klon)                     :: swdown_vrai
+    CHARACTER (len = 20)                      :: modname = 'surf_land_orchidee'
+    CHARACTER (len = 80)                      :: abort_message
+    LOGICAL,SAVE                              :: check = .FALSE.
+    !$OMP THREADPRIVATE(check)
+
+! type de couplage dans sechiba
+!  character (len=10)   :: coupling = 'implicit' 
+! drapeaux controlant les appels dans SECHIBA
+!  type(control_type), save   :: control_in
+! Preserved albedo
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: albedo_keep, zlev
+    !$OMP THREADPRIVATE(albedo_keep,zlev)
+! coordonnees geographiques
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: lalo
+    !$OMP THREADPRIVATE(lalo)
+! pts voisins
+    INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours
+    !$OMP THREADPRIVATE(neighbours)
+! fractions continents
+    REAL,ALLOCATABLE, DIMENSION(:), SAVE      :: contfrac
+    !$OMP THREADPRIVATE(contfrac)
+! resolution de la grille
+    REAL, ALLOCATABLE, DIMENSION (:,:), SAVE  :: resolution
+    !$OMP THREADPRIVATE(resolution)
+
+    REAL, ALLOCATABLE, DIMENSION (:,:), SAVE  :: lon_scat, lat_scat  
+    !$OMP THREADPRIVATE(lon_scat,lat_scat)
+
+    LOGICAL, SAVE                             :: lrestart_read = .TRUE.
+    !$OMP THREADPRIVATE(lrestart_read)
+    LOGICAL, SAVE                             :: lrestart_write = .FALSE.
+    !$OMP THREADPRIVATE(lrestart_write)
+
+    REAL, DIMENSION(knon,2)                   :: albedo_out
+
+! Pb de nomenclature
+    REAL, DIMENSION(klon)                     :: petA_orc, peqA_orc
+    REAL, DIMENSION(klon)                     :: petB_orc, peqB_orc
+! Pb de correspondances de grilles
+    INTEGER, DIMENSION(:), SAVE, ALLOCATABLE  :: ig, jg
+    !$OMP THREADPRIVATE(ig,jg)
+    INTEGER :: indi, indj
+    INTEGER, SAVE, ALLOCATABLE,DIMENSION(:)   :: ktindex
+    !$OMP THREADPRIVATE(ktindex)
+
+! Essai cdrag
+    REAL, DIMENSION(klon)                     :: cdrag
+    INTEGER,SAVE                              :: offset
+    !$OMP THREADPRIVATE(offset)
+
+    REAL, DIMENSION(klon_glo)                 :: rlon_g,rlat_g
+    INTEGER, SAVE                             :: orch_comm
+    !$OMP THREADPRIVATE(orch_comm)
+
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: coastalflow
+    !$OMP THREADPRIVATE(coastalflow)
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: riverflow
+    !$OMP THREADPRIVATE(riverflow)
+    
+    INTEGER :: orch_omp_rank
+    INTEGER :: orch_omp_size
+!
+! Fin definition
+!****************************************************************************************
+
+    IF (check) WRITE(lunout,*)'Entree ', modname
+  
+! Initialisation
+  
+    IF (debut) THEN
+! Test of coherence between variable ok_veget and cpp key CPP_VEGET
+#ifndef CPP_VEGET
+       abort_message='Pb de coherence: ok_veget = .true. mais CPP_VEGET = .false.'
+       CALL abort_gcm(modname,abort_message,1)
+#endif
+
+       CALL Init_surf_para(knon)
+       ALLOCATE(ktindex(knon))
+       IF ( .NOT. ALLOCATED(albedo_keep)) THEN
+!ym          ALLOCATE(albedo_keep(klon))
+!ym bizarre que non alloué en knon precedement
+          ALLOCATE(albedo_keep(knon))
+          ALLOCATE(zlev(knon))
+       ENDIF
+! Pb de correspondances de grilles
+       ALLOCATE(ig(klon))
+       ALLOCATE(jg(klon))
+       ig(1) = 1
+       jg(1) = 1
+       indi = 0
+       indj = 2
+       DO igrid = 2, klon - 1
+          indi = indi + 1
+          IF ( indi > iim) THEN
+             indi = 1
+             indj = indj + 1
+          ENDIF
+          ig(igrid) = indi
+          jg(igrid) = indj
+       ENDDO
+       ig(klon) = 1
+       jg(klon) = jjm + 1
+
+       IF ((.NOT. ALLOCATED(lalo))) THEN
+          ALLOCATE(lalo(knon,2), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lalo'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       IF ((.NOT. ALLOCATED(lon_scat))) THEN
+          ALLOCATE(lon_scat(iim,jjm+1), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lon_scat'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       IF ((.NOT. ALLOCATED(lat_scat))) THEN
+          ALLOCATE(lat_scat(iim,jjm+1), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lat_scat'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       lon_scat = 0.
+       lat_scat = 0.
+       DO igrid = 1, knon
+          index = knindex(igrid)
+          lalo(igrid,2) = rlon(index)
+          lalo(igrid,1) = rlat(index)
+       ENDDO
+
+       
+       
+       CALL Gather(rlon,rlon_g)
+       CALL Gather(rlat,rlat_g)
+
+       IF (is_mpi_root) THEN
+          index = 1
+          DO jj = 2, jjm
+             DO ij = 1, iim
+                index = index + 1
+                lon_scat(ij,jj) = rlon_g(index)
+                lat_scat(ij,jj) = rlat_g(index)
+             ENDDO
+          ENDDO
+          lon_scat(:,1) = lon_scat(:,2)
+          lat_scat(:,1) = rlat_g(1)
+          lon_scat(:,jjm+1) = lon_scat(:,2)
+          lat_scat(:,jjm+1) = rlat_g(klon_glo)
+       ENDIF
+   
+       CALL bcast(lon_scat)
+       CALL bcast(lat_scat)
+!
+! Allouer et initialiser le tableau des voisins et des fraction de continents
+!
+       IF ( (.NOT.ALLOCATED(neighbours))) THEN
+          ALLOCATE(neighbours(knon,8), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation neighbours'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       neighbours = -1.
+       IF (( .NOT. ALLOCATED(contfrac))) THEN
+          ALLOCATE(contfrac(knon), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation contfrac'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+
+       DO igrid = 1, knon
+          ireal = knindex(igrid)
+          contfrac(igrid) = pctsrf(ireal,is_ter)
+       ENDDO
+
+
+       CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter))
+
+!
+!  Allocation et calcul resolutions
+       IF ( (.NOT.ALLOCATED(resolution))) THEN
+          ALLOCATE(resolution(knon,2), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation resolution'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       DO igrid = 1, knon
+          ij = knindex(igrid)
+          resolution(igrid,1) = cuphy(ij)
+          resolution(igrid,2) = cvphy(ij)
+       ENDDO
+     
+       ALLOCATE(coastalflow(klon), stat = error)
+       IF (error /= 0) THEN
+          abort_message='Pb allocation coastalflow'
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+       
+       ALLOCATE(riverflow(klon), stat = error)
+       IF (error /= 0) THEN
+          abort_message='Pb allocation riverflow'
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+!
+! carbon_cycle_cpl not possible with this interface and version of ORHCHIDEE
+!
+       IF (carbon_cycle_cpl) THEN
+          abort_message='carbon_cycle_cpl not yet possible with this interface of ORCHIDEE'
+          CALL abort_gcm(modname,abort_message,1)
+       END IF
+       
+    ENDIF                          ! (fin debut) 
+ 
+
+! 
+! Appel a la routine sols continentaux
+!
+    IF (lafin) lrestart_write = .TRUE.
+    IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write
+     
+    petA_orc(1:knon) = petBcoef(1:knon) * dtime
+    petB_orc(1:knon) = petAcoef(1:knon)
+    peqA_orc(1:knon) = peqBcoef(1:knon) * dtime
+    peqB_orc(1:knon) = peqAcoef(1:knon)
+
+    cdrag = 0.
+    cdrag(1:knon) = tq_cdrag(1:knon)
+
+! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/287.05*temp_air(1:knon))*9.80665)
+    zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG)
+
+
+! PF et PASB
+!   where(cdrag > 0.01) 
+!     cdrag = 0.01
+!   endwhere
+!  write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag)
+
+  
+    IF (debut) THEN
+       CALL Init_orchidee_index(knon,knindex,offset,ktindex)
+       CALL Get_orchidee_communicator(orch_comm,orch_omp_size,orch_omp_rank)
+       CALL Init_synchro_omp
+       
+       IF (knon > 0) THEN
+#ifdef CPP_VEGET
+         CALL Init_intersurf(nbp_lon,nbp_lat,knon,ktindex,offset,orch_omp_size,orch_omp_rank,orch_comm)
+#endif
+       ENDIF
+
+       
+       IF (knon > 0) THEN
+
+#ifdef CPP_VEGET
+          CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, knon, ktindex, dtime, &
+               lrestart_read, lrestart_write, lalo, &
+               contfrac, neighbours, resolution, date0, &
+               zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
+               cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
+               precip_rain, precip_snow, lwdown, swnet, swdown, ps, &
+               evap, fluxsens, fluxlat, coastalflow, riverflow, &
+               tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
+               lon_scat, lat_scat, q2m, t2m)
+#endif         
+       ENDIF
+
+       CALL Synchro_omp
+
+       albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
+
+    ENDIF
+
+    
+!  swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon))
+    swdown_vrai(1:knon) = swdown(1:knon)
+
+    IF (knon > 0) THEN
+#ifdef CPP_VEGET    
+       CALL intersurf_main (itime+itau_phy, iim, jjm+1, knon, ktindex, dtime,  &
+            lrestart_read, lrestart_write, lalo, &
+            contfrac, neighbours, resolution, date0, &
+            zlev,  u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
+            cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
+            precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), &
+            evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
+            tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
+            lon_scat, lat_scat, q2m, t2m)
+#endif       
+    ENDIF
+
+    CALL Synchro_omp
+    
+    albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
+
+!* Send to coupler
+!
+    IF (type_ocean=='couple') THEN
+       CALL cpl_send_land_fields(itime, knon, knindex, &
+            riverflow, coastalflow)
+    ENDIF
+
+    alb1_new(1:knon) = albedo_out(1:knon,1) 
+    alb2_new(1:knon) = albedo_out(1:knon,2)
+
+! Convention orchidee: positif vers le haut
+    fluxsens(1:knon) = -1. * fluxsens(1:knon)
+    fluxlat(1:knon)  = -1. * fluxlat(1:knon)
+    
+!  evap     = -1. * evap
+
+    IF (debut) lrestart_read = .FALSE.
+    
+    IF (debut) CALL Finalize_surf_para
+
+    
+  END SUBROUTINE surf_land_orchidee
+!
+!****************************************************************************************
+!
+  SUBROUTINE Init_orchidee_index(knon,knindex,offset,ktindex)
+  USE mod_surf_para
+  USE mod_grid_phy_lmdz
+  
+    INTEGER,INTENT(IN)    :: knon
+    INTEGER,INTENT(IN)    :: knindex(klon)    
+    INTEGER,INTENT(OUT)   :: offset
+    INTEGER,INTENT(OUT)   :: ktindex(klon)
+    
+    INTEGER               :: ktindex_glo(knon_glo)
+    INTEGER               :: offset_para(0:omp_size*mpi_size-1)
+    INTEGER               :: LastPoint
+    INTEGER               :: task
+    
+    ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1
+    
+    CALL gather_surf(ktindex(1:knon),ktindex_glo) 
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+      LastPoint=0
+      DO Task=0,mpi_size*omp_size-1
+        IF (knon_glo_para(Task)>0) THEN
+           offset_para(task)= LastPoint-MOD(LastPoint,nbp_lon)
+           LastPoint=ktindex_glo(knon_glo_end_para(task))
+        ENDIF
+      ENDDO
+    ENDIF
+    
+    CALL bcast(offset_para)
+    
+    offset=offset_para(omp_size*mpi_rank+omp_rank)
+    
+    ktindex(1:knon)=ktindex(1:knon)-offset
+
+  END SUBROUTINE Init_orchidee_index
+
+!
+!************************* ***************************************************************
+! 
+
+  SUBROUTINE Get_orchidee_communicator(orch_comm,orch_omp_size,orch_omp_rank)
+  USE  mod_surf_para
+      
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif    
+
+    INTEGER,INTENT(OUT) :: orch_comm
+    INTEGER,INTENT(OUT) :: orch_omp_size
+    INTEGER,INTENT(OUT) :: orch_omp_rank
+    INTEGER             :: color
+    INTEGER             :: i,ierr
+!
+! End definition
+!****************************************************************************************
+    
+    
+    IF (is_omp_root) THEN          
+      
+      IF (knon_mpi==0) THEN 
+         color = 0
+      ELSE 
+         color = 1
+      ENDIF
+    
+#ifdef CPP_MPI    
+      CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr)
+#endif
+    
+    ENDIF
+    CALL bcast_omp(orch_comm)
+    
+    IF (knon_mpi /= 0) THEN
+      orch_omp_size=0
+      DO i=0,omp_size-1
+        IF (knon_omp_para(i) /=0) THEN
+          orch_omp_size=orch_omp_size+1
+          IF (i==omp_rank) orch_omp_rank=orch_omp_size-1
+        ENDIF
+      ENDDO
+    ENDIF
+   
+    
+  END SUBROUTINE Get_orchidee_communicator
+!
+!****************************************************************************************
+!  
+
+  SUBROUTINE Init_neighbours(knon,neighbours,knindex,pctsrf)
+    USE mod_grid_phy_lmdz
+    USE mod_surf_para    
+    USE indice_sol_mod
+
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif    
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: knindex
+    REAL, DIMENSION(klon), INTENT(IN)       :: pctsrf
+    
+! Output arguments
+!****************************************************************************************
+    INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: i, igrid, jj, ij, iglob
+    INTEGER                              :: ierr, ireal, index
+    INTEGER, DIMENSION(8,3)              :: off_ini
+    INTEGER, DIMENSION(8)                :: offset  
+    INTEGER, DIMENSION(nbp_lon,nbp_lat)  :: correspond
+    INTEGER, DIMENSION(knon_glo)         :: ktindex_glo
+    INTEGER, DIMENSION(knon_glo,8)       :: neighbours_glo
+    REAL, DIMENSION(klon_glo)            :: pctsrf_glo
+    INTEGER                              :: ktindex(klon)
+!
+! End definition
+!****************************************************************************************
+
+    ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin-1)+(klon_omp_begin-1)+nbp_lon-1
+    
+    CALL gather_surf(ktindex(1:knon),ktindex_glo)
+    CALL gather(pctsrf,pctsrf_glo)
+    
+    IF (is_mpi_root .AND. is_omp_root) THEN
+      neighbours_glo(:,:)=-1
+!  Initialisation des offset    
+!
+! offset bord ouest
+       off_ini(1,1) = - nbp_lon   ; off_ini(2,1) = - nbp_lon + 1     ; off_ini(3,1) = 1
+       off_ini(4,1) = nbp_lon + 1 ; off_ini(5,1) = nbp_lon           ; off_ini(6,1) = 2 * nbp_lon - 1
+       off_ini(7,1) = nbp_lon -1  ; off_ini(8,1) = - 1 
+! offset point normal
+       off_ini(1,2) = - nbp_lon   ; off_ini(2,2) = - nbp_lon + 1     ; off_ini(3,2) = 1
+       off_ini(4,2) = nbp_lon + 1 ; off_ini(5,2) = nbp_lon           ; off_ini(6,2) = nbp_lon - 1
+       off_ini(7,2) = -1          ; off_ini(8,2) = - nbp_lon - 1
+! offset bord   est
+       off_ini(1,3) = - nbp_lon   ; off_ini(2,3) = - 2 * nbp_lon + 1 ; off_ini(3,3) = - nbp_lon + 1
+       off_ini(4,3) =  1          ; off_ini(5,3) = nbp_lon           ; off_ini(6,3) = nbp_lon - 1
+       off_ini(7,3) = -1          ; off_ini(8,3) = - nbp_lon - 1
+!
+!
+! Attention aux poles
+!
+       DO igrid = 1, knon_glo
+          index = ktindex_glo(igrid)
+          jj = INT((index - 1)/nbp_lon) + 1
+          ij = index - (jj - 1) * nbp_lon
+          correspond(ij,jj) = igrid
+       ENDDO
+       
+       DO igrid = 1, knon_glo
+          iglob = ktindex_glo(igrid)
+          
+          IF (MOD(iglob, nbp_lon) == 1) THEN
+             offset = off_ini(:,1)
+          ELSE IF(MOD(iglob, nbp_lon) == 0) THEN
+             offset = off_ini(:,3)
+          ELSE
+             offset = off_ini(:,2)
+          ENDIF
+          
+          DO i = 1, 8
+             index = iglob + offset(i)
+             ireal = (MIN(MAX(1, index - nbp_lon + 1), klon_glo))
+             IF (pctsrf_glo(ireal) > EPSFRA) THEN
+                jj = INT((index - 1)/nbp_lon) + 1
+                ij = index - (jj - 1) * nbp_lon
+                neighbours_glo(igrid, i) = correspond(ij, jj)
+             ENDIF
+          ENDDO
+       ENDDO
+
+    ENDIF
+    
+    DO i = 1, 8
+      CALL scatter_surf(neighbours_glo(:,i),neighbours(1:knon,i))
+    ENDDO
+  END SUBROUTINE Init_neighbours
+
+!
+!****************************************************************************************
+!
+#endif
+END MODULE surf_land_orchidee_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_land_orchidee_noopenmp_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_land_orchidee_noopenmp_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_land_orchidee_noopenmp_mod.F90	(revision 17)
@@ -0,0 +1,781 @@
+!
+! $Header$
+!
+MODULE surf_land_orchidee_noopenmp_mod
+!
+! This module is compiled only if CPP key ORCHIDEE_NOOPENMP is defined.
+! This module should be used with ORCHIDEE sequentiel or parallele MPI version (not MPI-OpenMP mixte)
+
+#ifdef ORCHIDEE_NOOPENMP
+!
+! This module controles the interface towards the model ORCHIDEE
+!
+! Subroutines in this module : surf_land_orchidee
+!                              Init_orchidee_index
+!                              Get_orchidee_communicator
+!                              Init_neighbours
+  USE dimphy
+#ifdef CPP_VEGET
+  USE intersurf     ! module d'ORCHIDEE
+#endif
+  USE cpl_mod,      ONLY : cpl_send_land_fields
+  USE surface_data, ONLY : type_ocean
+  USE comgeomphy,   ONLY : cuphy, cvphy
+  USE mod_grid_phy_lmdz
+  USE mod_phys_lmdz_para
+
+  IMPLICIT NONE
+
+  PRIVATE
+  PUBLIC  :: surf_land_orchidee
+
+CONTAINS
+!
+!****************************************************************************************
+!  
+  SUBROUTINE surf_land_orchidee(itime, dtime, date0, knon, &
+       knindex, rlon, rlat, pctsrf, &
+       debut, lafin, &
+       plev,  u1_lay, v1_lay, temp_air, spechum, epot_air, ccanopy, & 
+       tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, &
+       precip_rain, precip_snow, lwdown, swnet, swdown, &
+       ps, q2m, t2m, &
+       evap, fluxsens, fluxlat, &              
+       tsol_rad, tsurf_new, alb1_new, alb2_new, &
+       emis_new, z0_new, qsurf)
+!    
+! Cette routine sert d'interface entre le modele atmospherique et le 
+! modele de sol continental. Appel a sechiba
+!
+! L. Fairhead 02/2000
+!
+! input:
+!   itime        numero du pas de temps
+!   dtime        pas de temps de la physique (en s)
+!   nisurf       index de la surface a traiter (1 = sol continental)
+!   knon         nombre de points de la surface a traiter
+!   knindex      index des points de la surface a traiter
+!   rlon         longitudes de la grille entiere
+!   rlat         latitudes de la grille entiere
+!   pctsrf       tableau des fractions de surface de chaque maille
+!   debut        logical: 1er appel a la physique (lire les restart)
+!   lafin        logical: dernier appel a la physique (ecrire les restart)
+!                     (si false calcul simplifie des fluxs sur les continents)
+!   plev         hauteur de la premiere couche (Pa)      
+!   u1_lay       vitesse u 1ere couche
+!   v1_lay       vitesse v 1ere couche
+!   temp_air     temperature de l'air 1ere couche
+!   spechum      humidite specifique 1ere couche
+!   epot_air     temp pot de l'air
+!   ccanopy      concentration CO2 canopee, correspond au co2_send de 
+!                carbon_cycle_mod ou valeur constant co2_ppm
+!   tq_cdrag     cdrag
+!   petAcoef     coeff. A de la resolution de la CL pour t
+!   peqAcoef     coeff. A de la resolution de la CL pour q
+!   petBcoef     coeff. B de la resolution de la CL pour t
+!   peqBcoef     coeff. B de la resolution de la CL pour q
+!   precip_rain  precipitation liquide
+!   precip_snow  precipitation solide
+!   lwdown       flux IR descendant a la surface
+!   swnet        flux solaire net
+!   swdown       flux solaire entrant a la surface
+!   ps           pression au sol
+!   radsol       rayonnement net aus sol (LW + SW)
+!   
+!
+! output:
+!   evap         evaporation totale
+!   fluxsens     flux de chaleur sensible
+!   fluxlat      flux de chaleur latente
+!   tsol_rad     
+!   tsurf_new    temperature au sol
+!   alb1_new     albedo in visible SW interval
+!   alb2_new     albedo in near IR interval
+!   emis_new     emissivite
+!   z0_new       surface roughness
+!   qsurf        air moisture at surface
+!
+    USE carbon_cycle_mod, ONLY : carbon_cycle_cpl, fco2_land_inst, fco2_lu_inst
+    USE indice_sol_mod
+    IMPLICIT NONE
+
+    INCLUDE "temps.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "iniprint.h"
+    INCLUDE "dimensions.h"
+  
+!
+! Parametres d'entree
+!****************************************************************************************
+    INTEGER, INTENT(IN)                       :: itime
+    REAL, INTENT(IN)                          :: dtime
+    REAL, INTENT(IN)                          :: date0
+    INTEGER, INTENT(IN)                       :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)      :: knindex
+    LOGICAL, INTENT(IN)                       :: debut, lafin
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)   :: pctsrf
+    REAL, DIMENSION(klon), INTENT(IN)         :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)         :: plev
+    REAL, DIMENSION(klon), INTENT(IN)         :: u1_lay, v1_lay
+    REAL, DIMENSION(klon), INTENT(IN)         :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)         :: epot_air, ccanopy
+    REAL, DIMENSION(klon), INTENT(IN)         :: tq_cdrag
+    REAL, DIMENSION(klon), INTENT(IN)         :: petAcoef, peqAcoef
+    REAL, DIMENSION(klon), INTENT(IN)         :: petBcoef, peqBcoef
+    REAL, DIMENSION(klon), INTENT(IN)         :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)         :: lwdown, swnet, swdown, ps
+    REAL, DIMENSION(klon), INTENT(IN)         :: q2m, t2m
+
+! Parametres de sortie
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)        :: evap, fluxsens, fluxlat, qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)        :: tsol_rad, tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)        :: alb1_new, alb2_new
+    REAL, DIMENSION(klon), INTENT(OUT)        :: emis_new, z0_new
+
+! Local
+!****************************************************************************************
+    INTEGER                                   :: ij, jj, igrid, ireal, index
+    INTEGER                                   :: error
+    INTEGER, SAVE                             :: nb_fields_cpl ! number of fields for the climate-carbon coupling (between ATM and ORCHIDEE). 
+    REAL, SAVE, ALLOCATABLE, DIMENSION(:,:)   :: fields_cpl    ! Fluxes for the climate-carbon coupling
+    REAL, DIMENSION(klon)                     :: swdown_vrai
+    CHARACTER (len = 20)                      :: modname = 'surf_land_orchidee'
+    CHARACTER (len = 80)                      :: abort_message
+    LOGICAL,SAVE                              :: check = .FALSE.
+    !$OMP THREADPRIVATE(check)
+
+! type de couplage dans sechiba
+!  character (len=10)   :: coupling = 'implicit' 
+! drapeaux controlant les appels dans SECHIBA
+!  type(control_type), save   :: control_in
+! Preserved albedo
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: albedo_keep, zlev
+    !$OMP THREADPRIVATE(albedo_keep,zlev)
+! coordonnees geographiques
+    REAL, ALLOCATABLE, DIMENSION(:,:), SAVE   :: lalo
+    !$OMP THREADPRIVATE(lalo)
+! pts voisins
+    INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours
+    !$OMP THREADPRIVATE(neighbours)
+! fractions continents
+    REAL,ALLOCATABLE, DIMENSION(:), SAVE      :: contfrac
+    !$OMP THREADPRIVATE(contfrac)
+! resolution de la grille
+    REAL, ALLOCATABLE, DIMENSION (:,:), SAVE  :: resolution
+    !$OMP THREADPRIVATE(resolution)
+
+    REAL, ALLOCATABLE, DIMENSION (:,:), SAVE  :: lon_scat, lat_scat  
+    !$OMP THREADPRIVATE(lon_scat,lat_scat)
+
+    LOGICAL, SAVE                             :: lrestart_read = .TRUE.
+    !$OMP THREADPRIVATE(lrestart_read)
+    LOGICAL, SAVE                             :: lrestart_write = .FALSE.
+    !$OMP THREADPRIVATE(lrestart_write)
+
+    REAL, DIMENSION(knon,2)                   :: albedo_out
+    !$OMP THREADPRIVATE(albedo_out)
+
+! Pb de nomenclature
+    REAL, DIMENSION(klon)                     :: petA_orc, peqA_orc
+    REAL, DIMENSION(klon)                     :: petB_orc, peqB_orc
+! Pb de correspondances de grilles
+    INTEGER, DIMENSION(:), SAVE, ALLOCATABLE  :: ig, jg
+    !$OMP THREADPRIVATE(ig,jg)
+    INTEGER :: indi, indj
+    INTEGER, SAVE, ALLOCATABLE,DIMENSION(:)   :: ktindex
+    !$OMP THREADPRIVATE(ktindex)
+
+! Essai cdrag
+    REAL, DIMENSION(klon)                     :: cdrag
+    INTEGER,SAVE                              :: offset
+    !$OMP THREADPRIVATE(offset)
+
+    REAL, DIMENSION(klon_glo)                 :: rlon_g,rlat_g
+    INTEGER, SAVE                             :: orch_comm
+    !$OMP THREADPRIVATE(orch_comm)
+
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: coastalflow
+    !$OMP THREADPRIVATE(coastalflow)
+    REAL, ALLOCATABLE, DIMENSION(:), SAVE     :: riverflow
+    !$OMP THREADPRIVATE(riverflow)
+!
+! Fin definition
+!****************************************************************************************
+#ifdef CPP_VEGET
+
+    IF (check) WRITE(lunout,*)'Entree ', modname
+  
+! Initialisation
+  
+    IF (debut) THEN
+! Test de coherence
+#ifndef ORCH_NEW
+       ! Compilation avec orchidee nouvelle version necessaire avec carbon_cycle_cpl=y
+       IF (carbon_cycle_cpl) THEN
+          abort_message='You must define preprossing key ORCH_NEW when running carbon_cycle_cpl=y'
+          CALL abort_gcm(modname,abort_message,1)
+       END IF
+#endif
+       ALLOCATE(ktindex(knon))
+       IF ( .NOT. ALLOCATED(albedo_keep)) THEN
+          ALLOCATE(albedo_keep(klon))
+          ALLOCATE(zlev(knon))
+       ENDIF
+! Pb de correspondances de grilles
+       ALLOCATE(ig(klon))
+       ALLOCATE(jg(klon))
+       ig(1) = 1
+       jg(1) = 1
+       indi = 0
+       indj = 2
+       DO igrid = 2, klon - 1
+          indi = indi + 1
+          IF ( indi > iim) THEN
+             indi = 1
+             indj = indj + 1
+          ENDIF
+          ig(igrid) = indi
+          jg(igrid) = indj
+       ENDDO
+       ig(klon) = 1
+       jg(klon) = jjm + 1
+
+       IF ((.NOT. ALLOCATED(lalo))) THEN
+          ALLOCATE(lalo(knon,2), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lalo'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       IF ((.NOT. ALLOCATED(lon_scat))) THEN
+          ALLOCATE(lon_scat(iim,jjm+1), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lon_scat'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       IF ((.NOT. ALLOCATED(lat_scat))) THEN
+          ALLOCATE(lat_scat(iim,jjm+1), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation lat_scat'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       lon_scat = 0.
+       lat_scat = 0.
+       DO igrid = 1, knon
+          index = knindex(igrid)
+          lalo(igrid,2) = rlon(index)
+          lalo(igrid,1) = rlat(index)
+       ENDDO
+
+       
+       
+       CALL Gather(rlon,rlon_g)
+       CALL Gather(rlat,rlat_g)
+
+       IF (is_mpi_root) THEN
+          index = 1
+          DO jj = 2, jjm
+             DO ij = 1, iim
+                index = index + 1
+                lon_scat(ij,jj) = rlon_g(index)
+                lat_scat(ij,jj) = rlat_g(index)
+             ENDDO
+          ENDDO
+          lon_scat(:,1) = lon_scat(:,2)
+          lat_scat(:,1) = rlat_g(1)
+          lon_scat(:,jjm+1) = lon_scat(:,2)
+          lat_scat(:,jjm+1) = rlat_g(klon_glo)
+       ENDIF
+
+       CALL bcast(lon_scat) 
+       CALL bcast(lat_scat) 
+
+!
+! Allouer et initialiser le tableau des voisins et des fraction de continents
+!
+       IF ( (.NOT.ALLOCATED(neighbours))) THEN
+          ALLOCATE(neighbours(knon,8), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation neighbours'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       neighbours = -1.
+       IF (( .NOT. ALLOCATED(contfrac))) THEN
+          ALLOCATE(contfrac(knon), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation contfrac'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+
+       DO igrid = 1, knon
+          ireal = knindex(igrid)
+          contfrac(igrid) = pctsrf(ireal,is_ter)
+       ENDDO
+
+
+       CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter))
+
+!
+!  Allocation et calcul resolutions
+       IF ( (.NOT.ALLOCATED(resolution))) THEN
+          ALLOCATE(resolution(knon,2), stat = error)
+          IF (error /= 0) THEN
+             abort_message='Pb allocation resolution'
+             CALL abort_gcm(modname,abort_message,1)
+          ENDIF
+       ENDIF
+       DO igrid = 1, knon
+          ij = knindex(igrid)
+          resolution(igrid,1) = cuphy(ij)
+          resolution(igrid,2) = cvphy(ij)
+       ENDDO
+     
+       ALLOCATE(coastalflow(klon), stat = error)
+       IF (error /= 0) THEN
+          abort_message='Pb allocation coastalflow'
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+       
+       ALLOCATE(riverflow(klon), stat = error)
+       IF (error /= 0) THEN
+          abort_message='Pb allocation riverflow'
+          CALL abort_gcm(modname,abort_message,1)
+       ENDIF
+
+!
+! Allocate variables needed for carbon_cycle_mod
+       IF ( carbon_cycle_cpl ) THEN
+          nb_fields_cpl=2
+       ELSE
+          nb_fields_cpl=1
+       END IF
+
+
+       IF (carbon_cycle_cpl) THEN
+          ALLOCATE(fco2_land_inst(klon),stat=error)
+          IF (error /= 0)  CALL abort_gcm(modname,'Pb in allocation fco2_land_inst',1)
+          
+          ALLOCATE(fco2_lu_inst(klon),stat=error)
+          IF(error /=0) CALL abort_gcm(modname,'Pb in allocation fco2_lu_inst',1)
+       END IF
+
+       ALLOCATE(fields_cpl(klon,nb_fields_cpl), stat = error)
+       IF (error /= 0) CALL abort_gcm(modname,'Pb in allocation fields_cpl',1)
+
+    ENDIF                          ! (fin debut) 
+
+! 
+! Appel a la routine sols continentaux
+!
+    IF (lafin) lrestart_write = .TRUE.
+    IF (check) WRITE(lunout,*)'lafin ',lafin,lrestart_write
+    
+    petA_orc(1:knon) = petBcoef(1:knon) * dtime
+    petB_orc(1:knon) = petAcoef(1:knon)
+    peqA_orc(1:knon) = peqBcoef(1:knon) * dtime
+    peqB_orc(1:knon) = peqAcoef(1:knon)
+
+    cdrag = 0.
+    cdrag(1:knon) = tq_cdrag(1:knon)
+
+! zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/287.05*temp_air(1:knon))*9.80665)
+    zlev(1:knon) = (100.*plev(1:knon))/((ps(1:knon)/RD*temp_air(1:knon))*RG)
+
+
+! PF et PASB
+!   where(cdrag > 0.01) 
+!     cdrag = 0.01
+!   endwhere
+!  write(*,*)'Cdrag = ',minval(cdrag),maxval(cdrag)
+
+!
+! Init Orchidee
+!
+!  if (pole_nord) then 
+!    offset=0
+!    ktindex(:)=ktindex(:)+iim-1
+!  else
+!    offset = klon_mpi_begin-1+iim-1
+!    ktindex(:)=ktindex(:)+MOD(offset,iim)
+!    offset=offset-MOD(offset,iim)
+!  endif
+  
+    IF (debut) THEN
+       CALL Get_orchidee_communicator(knon,orch_comm)
+       IF (knon /=0) THEN
+          CALL Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex)
+
+#ifndef CPP_MPI
+          ! Interface for ORCHIDEE compiled in sequential mode(without preprocessing flag CPP_MPI)
+          CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, knon, ktindex, dtime, &
+               lrestart_read, lrestart_write, lalo, &
+               contfrac, neighbours, resolution, date0, &
+               zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
+               cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
+               precip_rain, precip_snow, lwdown, swnet, swdown, ps, &
+               evap, fluxsens, fluxlat, coastalflow, riverflow, &
+               tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
+               lon_scat, lat_scat, q2m, t2m &
+#ifdef ORCH_NEW
+               , nb_fields_cpl, fields_cpl)
+#else
+               )
+#endif
+
+#else          
+          ! Interface for ORCHIDEE version 1.9 or later(1.9.2, 1.9.3, 1.9.4, 1.9.5) compiled in parallel mode(with preprocessing flag CPP_MPI)
+          CALL intersurf_main (itime+itau_phy-1, iim, jjm+1, offset, knon, ktindex, & 
+               orch_comm, dtime, lrestart_read, lrestart_write, lalo, &
+               contfrac, neighbours, resolution, date0, &
+               zlev,  u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
+               cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
+               precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown(1:knon), ps(1:knon), &
+               evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
+               tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
+               lon_scat, lat_scat, q2m, t2m &
+#ifdef ORCH_NEW
+               , nb_fields_cpl, fields_cpl(1:knon,:))
+#else
+               )
+#endif
+#endif
+          
+       ENDIF
+
+       albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
+
+    ENDIF
+
+!  swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon))
+    swdown_vrai(1:knon) = swdown(1:knon)
+
+    IF (knon /=0) THEN
+#ifndef CPP_MPI
+       ! Interface for ORCHIDEE compiled in sequential mode(without preprocessing flag CPP_MPI)
+       CALL intersurf_main (itime+itau_phy, iim, jjm+1, knon, ktindex, dtime, &
+            lrestart_read, lrestart_write, lalo, &
+            contfrac, neighbours, resolution, date0, &
+            zlev,  u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, &
+            cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, &
+            precip_rain, precip_snow, lwdown, swnet, swdown_vrai, ps, &
+            evap, fluxsens, fluxlat, coastalflow, riverflow, &
+            tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, &
+            lon_scat, lat_scat, q2m, t2m &
+#ifdef ORCH_NEW
+            , nb_fields_cpl, fields_cpl)
+#else
+            )
+#endif
+#else
+       ! Interface for ORCHIDEE version 1.9 or later compiled in parallel mode(with preprocessing flag CPP_MPI)
+       CALL intersurf_main (itime+itau_phy, iim, jjm+1,offset, knon, ktindex, & 
+            orch_comm,dtime, lrestart_read, lrestart_write, lalo, &
+            contfrac, neighbours, resolution, date0, &
+            zlev,  u1_lay(1:knon), v1_lay(1:knon), spechum(1:knon), temp_air(1:knon), epot_air(1:knon), ccanopy(1:knon), &
+            cdrag(1:knon), petA_orc(1:knon), peqA_orc(1:knon), petB_orc(1:knon), peqB_orc(1:knon), &
+            precip_rain(1:knon), precip_snow(1:knon), lwdown(1:knon), swnet(1:knon), swdown_vrai(1:knon), ps(1:knon), &
+            evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), &
+            tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), &
+            lon_scat, lat_scat, q2m, t2m &
+#ifdef ORCH_NEW
+            , nb_fields_cpl, fields_cpl(1:knon,:))
+#else
+            )
+#endif
+#endif
+    ENDIF
+
+    albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2.
+
+!* Send to coupler
+!
+    IF (type_ocean=='couple') THEN
+       CALL cpl_send_land_fields(itime, knon, knindex, &
+            riverflow, coastalflow)
+    ENDIF
+
+    alb1_new(1:knon) = albedo_out(1:knon,1) 
+    alb2_new(1:knon) = albedo_out(1:knon,2)
+
+! Convention orchidee: positif vers le haut
+    fluxsens(1:knon) = -1. * fluxsens(1:knon)
+    fluxlat(1:knon)  = -1. * fluxlat(1:knon)
+    
+!  evap     = -1. * evap
+
+    IF (debut) lrestart_read = .FALSE.
+
+! Decompress variables for the module carbon_cycle_mod
+    IF (carbon_cycle_cpl) THEN
+       fco2_land_inst(:)=0.
+       fco2_lu_inst(:)=0.
+       
+       DO igrid = 1, knon
+          ireal = knindex(igrid)
+          fco2_land_inst(ireal) = fields_cpl(igrid,1)
+          fco2_lu_inst(ireal)   = fields_cpl(igrid,2)
+       END DO
+    END IF
+
+#endif    
+  END SUBROUTINE surf_land_orchidee
+!
+!****************************************************************************************
+!
+  SUBROUTINE Init_orchidee_index(knon,orch_comm,knindex,offset,ktindex)
+    
+    INCLUDE "dimensions.h"
+
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif    
+
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                   :: knon
+    INTEGER, INTENT(IN)                   :: orch_comm
+    INTEGER, DIMENSION(klon), INTENT(IN)  :: knindex
+
+! Output arguments
+!****************************************************************************************
+    INTEGER, INTENT(OUT)                  :: offset
+    INTEGER, DIMENSION(knon), INTENT(OUT) :: ktindex
+
+! Local varables
+!****************************************************************************************
+#ifdef CPP_MPI
+    INTEGER, DIMENSION(MPI_STATUS_SIZE)   :: status
+#endif
+
+    INTEGER                               :: MyLastPoint
+    INTEGER                               :: LastPoint
+    INTEGER                               :: mpi_rank_orch
+    INTEGER                               :: mpi_size_orch
+    INTEGER                               :: ierr 
+!
+! End definition
+!****************************************************************************************
+
+    MyLastPoint=klon_mpi_begin-1+knindex(knon)+iim-1
+    
+    IF (is_parallel) THEN
+#ifdef CPP_MPI    
+       CALL MPI_COMM_SIZE(orch_comm,mpi_size_orch,ierr)
+       CALL MPI_COMM_RANK(orch_comm,mpi_rank_orch,ierr)
+#endif
+    ELSE
+       mpi_rank_orch=0
+       mpi_size_orch=1
+    ENDIF
+
+    IF (is_parallel) THEN
+       IF (mpi_rank_orch /= 0) THEN
+#ifdef CPP_MPI
+          CALL MPI_RECV(LastPoint,1,MPI_INTEGER,mpi_rank_orch-1,1234,orch_comm,status,ierr)
+#endif
+       ENDIF
+       
+       IF (mpi_rank_orch /= mpi_size_orch-1) THEN
+#ifdef CPP_MPI
+          CALL MPI_SEND(MyLastPoint,1,MPI_INTEGER,mpi_rank_orch+1,1234,orch_comm,ierr)  
+#endif
+       ENDIF
+    ENDIF
+    
+    IF (mpi_rank_orch == 0) THEN 
+       offset=0
+    ELSE
+       offset=LastPoint-MOD(LastPoint,iim)
+    ENDIF
+    
+    ktindex(1:knon)=knindex(1:knon)+(klon_mpi_begin+iim-1)-offset-1	
+    
+
+  END SUBROUTINE  Init_orchidee_index
+!
+!****************************************************************************************
+! 
+  SUBROUTINE Get_orchidee_communicator(knon,orch_comm)
+    
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif    
+
+
+    INTEGER,INTENT(IN)  :: knon
+    INTEGER,INTENT(OUT) :: orch_comm
+    
+    INTEGER             :: color
+    INTEGER             :: ierr
+!
+! End definition
+!****************************************************************************************
+
+    IF (knon==0) THEN 
+       color = 0
+    ELSE 
+       color = 1
+    ENDIF
+    
+#ifdef CPP_MPI    
+    CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr)
+#endif
+    
+  END SUBROUTINE Get_orchidee_communicator
+!
+!****************************************************************************************
+!  
+  SUBROUTINE Init_neighbours(knon,neighbours,ktindex,pctsrf)
+    
+    USE indice_sol_mod
+
+    INCLUDE "dimensions.h"
+#ifdef CPP_MPI
+    INCLUDE 'mpif.h'
+#endif    
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                     :: knon
+    INTEGER, DIMENSION(klon), INTENT(IN)    :: ktindex
+    REAL, DIMENSION(klon), INTENT(IN)       :: pctsrf
+    
+! Output arguments
+!****************************************************************************************
+    INTEGER, DIMENSION(knon,8), INTENT(OUT) :: neighbours
+
+! Local variables
+!****************************************************************************************
+    INTEGER                              :: knon_g
+    INTEGER                              :: i, igrid, jj, ij, iglob
+    INTEGER                              :: ierr, ireal, index
+    INTEGER                              :: var_tmp
+    INTEGER, DIMENSION(0:mpi_size-1)     :: knon_nb
+    INTEGER, DIMENSION(0:mpi_size-1)     :: displs
+    INTEGER, DIMENSION(8,3)              :: off_ini
+    INTEGER, DIMENSION(8)                :: offset  
+    INTEGER, DIMENSION(knon)             :: ktindex_p
+    INTEGER, DIMENSION(iim,jjm+1)        :: correspond
+    INTEGER, ALLOCATABLE, DIMENSION(:)   :: ktindex_g
+    INTEGER, ALLOCATABLE, DIMENSION(:,:) :: neighbours_g
+    REAL, DIMENSION(klon_glo)            :: pctsrf_g
+    
+!
+! End definition
+!****************************************************************************************
+
+    IF (is_sequential) THEN
+       knon_nb(:)=knon
+    ELSE  
+       
+#ifdef CPP_MPI  
+       CALL MPI_GATHER(knon,1,MPI_INTEGER,knon_nb,1,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
+#endif
+       
+    ENDIF
+    
+    IF (is_mpi_root) THEN
+       knon_g=SUM(knon_nb(:))
+       ALLOCATE(ktindex_g(knon_g))
+       ALLOCATE(neighbours_g(knon_g,8))
+       neighbours_g(:,:)=-1
+       displs(0)=0
+       DO i=1,mpi_size-1
+          displs(i)=displs(i-1)+knon_nb(i-1)
+       ENDDO
+   ELSE
+       ALLOCATE(neighbours_g(1,8))
+   ENDIF
+    
+    ktindex_p(1:knon)=ktindex(1:knon)+klon_mpi_begin-1+iim-1
+    
+    IF (is_sequential) THEN
+       ktindex_g(:)=ktindex_p(:)
+    ELSE
+       
+#ifdef CPP_MPI  
+       CALL MPI_GATHERV(ktindex_p,knon,MPI_INTEGER,ktindex_g,knon_nb,&
+            displs,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr)
+#endif
+       
+    ENDIF
+    
+    CALL Gather(pctsrf,pctsrf_g)
+    
+    IF (is_mpi_root) THEN
+!  Initialisation des offset    
+!
+! offset bord ouest
+       off_ini(1,1) = - iim  ; off_ini(2,1) = - iim + 1; off_ini(3,1) = 1
+       off_ini(4,1) = iim + 1; off_ini(5,1) = iim      ; off_ini(6,1) = 2 * iim - 1
+       off_ini(7,1) = iim -1 ; off_ini(8,1) = - 1
+! offset point normal
+       off_ini(1,2) = - iim  ; off_ini(2,2) = - iim + 1; off_ini(3,2) = 1
+       off_ini(4,2) = iim + 1; off_ini(5,2) = iim      ; off_ini(6,2) = iim - 1
+       off_ini(7,2) = -1     ; off_ini(8,2) = - iim - 1
+! offset bord   est
+       off_ini(1,3) = - iim; off_ini(2,3) = - 2 * iim + 1; off_ini(3,3) = - iim + 1
+       off_ini(4,3) =  1   ; off_ini(5,3) = iim          ; off_ini(6,3) = iim - 1
+       off_ini(7,3) = -1   ; off_ini(8,3) = - iim - 1
+!
+!
+! Attention aux poles
+!
+       DO igrid = 1, knon_g
+          index = ktindex_g(igrid)
+          jj = INT((index - 1)/iim) + 1
+          ij = index - (jj - 1) * iim
+          correspond(ij,jj) = igrid
+       ENDDO
+       
+       DO igrid = 1, knon_g
+          iglob = ktindex_g(igrid)
+          IF (MOD(iglob, iim) == 1) THEN
+             offset = off_ini(:,1)
+          ELSE IF(MOD(iglob, iim) == 0) THEN
+             offset = off_ini(:,3)
+          ELSE
+             offset = off_ini(:,2)
+          ENDIF
+          DO i = 1, 8
+             index = iglob + offset(i)
+             ireal = (MIN(MAX(1, index - iim + 1), klon_glo))
+             IF (pctsrf_g(ireal) > EPSFRA) THEN
+                jj = INT((index - 1)/iim) + 1
+                ij = index - (jj - 1) * iim
+                neighbours_g(igrid, i) = correspond(ij, jj)
+             ENDIF
+          ENDDO
+       ENDDO
+
+    ENDIF
+    
+    DO i=1,8
+       IF (is_sequential) THEN
+          neighbours(:,i)=neighbours_g(:,i)
+       ELSE
+#ifdef CPP_MPI
+          IF (knon > 0) THEN
+             ! knon>0, scattter global field neighbours_g from master process to local process
+             CALL MPI_SCATTERV(neighbours_g(:,i),knon_nb,displs,MPI_INTEGER,neighbours(:,i),knon,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr) 
+          ELSE
+             ! knon=0, no need to save the field for this process
+             CALL MPI_SCATTERV(neighbours_g(:,i),knon_nb,displs,MPI_INTEGER,var_tmp,knon,MPI_INTEGER,0,COMM_LMDZ_PHY,ierr) 
+          END IF
+#endif
+       ENDIF
+    ENDDO
+    
+  END SUBROUTINE Init_neighbours
+!
+!****************************************************************************************
+!
+
+#endif
+END MODULE surf_land_orchidee_noopenmp_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_landice_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_landice_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_landice_mod.F90	(revision 17)
@@ -0,0 +1,206 @@
+!
+MODULE surf_landice_mod
+  
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE surf_landice(itime, dtime, knon, knindex, &
+       swnet, lwnet, tsurf, p1lay, &
+       cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       AcoefH, AcoefQ, BcoefH, BcoefQ, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       ps, u1, v1, rugoro, pctsrf, &
+       snow, qsurf, qsol, agesno, &
+       tsoil, z0_new, alb1, alb2, evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, &
+       flux_u1, flux_v1)
+
+    USE dimphy
+    USE surface_data,     ONLY : type_ocean, calice, calsno
+    USE fonte_neige_mod,  ONLY : fonte_neige, run_off_lic
+    USE cpl_mod,          ONLY : cpl_send_landice_fields
+    USE calcul_fluxs_mod
+    USE phys_output_var_mod
+    USE indice_sol_mod
+
+!    INCLUDE "indicesol.h"
+    INCLUDE "dimsoil.h"
+    INCLUDE "YOMCST.h"
+    INCLUDE "clesphys.h"
+
+! Input variables 
+!****************************************************************************************
+    INTEGER, INTENT(IN)                           :: itime, knon
+    INTEGER, DIMENSION(klon), INTENT(in)          :: knindex
+    REAL, INTENT(in)                              :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)             :: swnet ! net shortwave radiance
+    REAL, DIMENSION(klon), INTENT(IN)             :: lwnet ! net longwave radiance
+    REAL, DIMENSION(klon), INTENT(IN)             :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)             :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)             :: cdragh, cdragm
+    REAL, DIMENSION(klon), INTENT(IN)             :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)             :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)             :: AcoefH, AcoefQ
+    REAL, DIMENSION(klon), INTENT(IN)             :: BcoefH, BcoefQ
+    REAL, DIMENSION(klon), INTENT(IN)             :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)             :: ps
+    REAL, DIMENSION(klon), INTENT(IN)             :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)             :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)       :: pctsrf
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)            :: qsurf
+    REAL, DIMENSION(klon), INTENT(OUT)            :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alb1  ! new albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(OUT)            :: alb2  ! new albedo in near IR interval
+    REAL, DIMENSION(klon), INTENT(OUT)            :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)            :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)            :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)            :: flux_u1, flux_v1
+
+! Local variables
+!****************************************************************************************
+    REAL, DIMENSION(klon)    :: soilcap, soilflux
+    REAL, DIMENSION(klon)    :: cal, beta, dif_grnd
+    REAL, DIMENSION(klon)    :: zfra, alb_neig
+    REAL, DIMENSION(klon)    :: radsol
+    REAL, DIMENSION(klon)    :: u0, v0, u1_lay, v1_lay
+    INTEGER                  :: i,j
+
+! End definition
+!****************************************************************************************
+!
+! Initialize output variables
+    alb2(:) = 999999.
+    alb1(:) = 999999.
+
+!****************************************************************************************
+! Calculate total absorbed radiance at surface
+!
+!****************************************************************************************
+    radsol(:) = 0.0
+    radsol(1:knon) = swnet(1:knon) + lwnet(1:knon)
+
+!****************************************************************************************
+! Soil calculations
+! 
+!****************************************************************************************
+    IF (soil_model) THEN 
+       CALL soil(dtime, is_lic, knon, snow, tsurf, tsoil, soilcap, soilflux)
+       cal(1:knon) = RCPD / soilcap(1:knon)
+       radsol(1:knon)  = radsol(1:knon) + soilflux(1:knon)
+    ELSE 
+       cal = RCPD * calice
+       WHERE (snow > 0.0) cal = RCPD * calsno
+    ENDIF
+
+
+!****************************************************************************************
+! Calulate fluxes
+!
+!****************************************************************************************
+    beta(:) = 1.0
+    dif_grnd(:) = 0.0
+
+! Suppose zero surface speed
+    u0(:)=0.0
+    v0(:)=0.0
+    u1_lay(:) = u1(:) - u0(:)
+    v1_lay(:) = v1(:) - v0(:)
+
+    CALL calcul_fluxs(knon, is_lic, dtime, &
+         tsurf, p1lay, cal, beta, cdragh, ps, &
+         precip_rain, precip_snow, snow, qsurf,  &
+         radsol, dif_grnd, temp_air, spechum, u1_lay, v1_lay, &
+         AcoefH, AcoefQ, BcoefH, BcoefQ, &
+         tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l)
+
+    CALL calcul_flux_wind(knon, dtime, &
+         u0, v0, u1, v1, cdragm, &
+         AcoefU, AcoefV, BcoefU, BcoefV, &
+         p1lay, temp_air, &
+         flux_u1, flux_v1)
+
+!****************************************************************************************
+! Calculate snow height, age, run-off,..
+!    
+!****************************************************************************************
+    CALL fonte_neige( knon, is_lic, knindex, dtime, &
+         tsurf, precip_rain, precip_snow, &
+         snow, qsol, tsurf_new, evap)
+
+
+!****************************************************************************************
+! Calculate albedo
+!
+!****************************************************************************************
+    CALL albsno(klon,knon,dtime,agesno(:),alb_neig(:), precip_snow(:))  
+    WHERE (snow(1 : knon) .LT. 0.0001) agesno(1 : knon) = 0.
+    zfra(1:knon) = MAX(0.0,MIN(1.0,snow(1:knon)/(snow(1:knon)+10.0)))
+    alb1(1:knon) = alb_neig(1:knon)*zfra(1:knon) + &
+         0.6 * (1.0-zfra(1:knon))
+!
+!IM: plusieurs choix/tests sur l'albedo des "glaciers continentaux"
+!       alb1(1 : knon)  = 0.6 !IM cf FH/GK 
+!       alb1(1 : knon)  = 0.82
+!       alb1(1 : knon)  = 0.77 !211003 Ksta0.77
+!       alb1(1 : knon)  = 0.8 !KstaTER0.8 & LMD_ARMIP5
+!IM: KstaTER0.77 & LMD_ARMIP6    
+
+! Attantion: alb1 and alb2 are the same!
+    alb1(1:knon)  = 0.77
+    alb2(1:knon)  = alb1(1:knon)
+
+
+!****************************************************************************************
+! Rugosity
+!
+!****************************************************************************************
+    z0_new(:) = MAX(1.E-3,rugoro(:))
+
+!****************************************************************************************
+! Send run-off on land-ice to coupler if coupled ocean.
+! run_off_lic has been calculated in fonte_neige
+!
+!****************************************************************************************
+    IF (type_ocean=='couple') THEN
+       CALL cpl_send_landice_fields(itime, knon, knindex, run_off_lic)
+    ENDIF
+  
+!****************************************************************************************
+       snow_o=0.
+       zfra_o = 0.
+       DO j = 1, knon
+           i = knindex(j)
+           snow_o(i) = snow(j) 
+           zfra_o(i) = zfra(j)
+       ENDDO
+
+!****************************************************************************************
+       snow_o=0.
+       zfra_o = 0.
+       DO j = 1, knon
+           i = knindex(j)
+           snow_o(i) = snow(j)
+           zfra_o(i) = zfra(j)
+       ENDDO
+
+
+  END SUBROUTINE surf_landice
+!
+!****************************************************************************************
+!
+END MODULE surf_landice_mod
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_ocean_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_ocean_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_ocean_mod.F90	(revision 17)
@@ -0,0 +1,181 @@
+!
+MODULE surf_ocean_mod
+
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE surf_ocean(rlon, rlat, swnet, lwnet, alb1, &
+       rugos, windsp, rmu0, fder, tsurf_in, &
+       itime, dtime, jour, knon, knindex, &
+       p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       AcoefH, AcoefQ, BcoefH, BcoefQ, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       ps, u1, v1, rugoro, pctsrf, &
+       snow, qsurf, agesno, &
+       z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, lmt_bils, &
+       flux_u1, flux_v1)
+
+  USE dimphy
+  USE surface_data, ONLY     : type_ocean
+  USE ocean_forced_mod, ONLY : ocean_forced_noice
+  USE ocean_slab_mod, ONLY   : ocean_slab_noice
+  USE ocean_cpl_mod, ONLY    : ocean_cpl_noice
+  USE indice_sol_mod
+!
+! This subroutine will make a call to ocean_XXX_noice according to the ocean mode (force, 
+! slab or couple). The calculations of albedo and rugosity for the ocean surface are 
+! done in here because they are identical for the different modes of ocean. 
+
+
+    INCLUDE "YOMCST.h"
+
+! Input variables
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: swnet  ! net shortwave radiation at surface  
+    REAL, DIMENSION(klon), INTENT(IN)        :: lwnet  ! net longwave radiation at surface  
+    REAL, DIMENSION(klon), INTENT(IN)        :: alb1   ! albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugos
+    REAL, DIMENSION(klon), INTENT(IN)        :: windsp
+    REAL, DIMENSION(klon), INTENT(IN)        :: rmu0  
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder
+    REAL, DIMENSION(klon), INTENT(IN)        :: tsurf_in
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: cdragh
+    REAL, DIMENSION(klon), INTENT(IN)        :: cdragm
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefH, AcoefQ, BcoefH, BcoefQ
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
+
+! In/Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: snow
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: qsurf
+    REAL, DIMENSION(klon), INTENT(INOUT)     :: agesno
+
+! Output variables
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new  ! new albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb2_new  ! new albedo in near IR interval
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: lmt_bils
+    REAL, DIMENSION(klon), INTENT(OUT)       :: flux_u1, flux_v1
+
+! Local variables
+!****************************************************************************************
+    INTEGER               :: i
+    REAL                  :: tmp
+    REAL, PARAMETER       :: cepdu2=(0.1)**2
+    REAL, DIMENSION(klon) :: alb_eau
+    REAL, DIMENSION(klon) :: radsol
+
+! Lluis
+    INTEGER                                              :: lp
+
+    lp = 498
+
+! End definition
+!****************************************************************************************
+
+    PRINT *,'  Lluis in surf_ocean_mod lp: ',lp,' type_ocean: ',type_ocean,          &
+      ' tsurf_in: ',tsurf_in(lp)
+
+!****************************************************************************************
+! Calculate total net radiance at surface
+!
+!****************************************************************************************
+    radsol(:) = 0.0
+    radsol(1:knon) = swnet(1:knon) + lwnet(1:knon)
+
+!****************************************************************************************
+! Switch according to type of ocean (couple, slab or forced)
+!****************************************************************************************
+    SELECT CASE(type_ocean)
+    CASE('couple')
+       CALL ocean_cpl_noice( &
+            swnet, lwnet, alb1, &
+            windsp, fder, & 
+            itime, dtime, knon, knindex, &
+            p1lay, cdragh, cdragm, precip_rain, precip_snow,temp_air,spechum,& 
+            AcoefH, AcoefQ, BcoefH, BcoefQ, &
+            AcoefU, AcoefV, BcoefU, BcoefV, &
+            ps, u1, v1, &
+            radsol, snow, agesno, &
+            qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+            tsurf_new, dflux_s, dflux_l)
+
+    CASE('slab')
+       CALL ocean_slab_noice( &
+            itime, dtime, jour, knon, knindex, &
+            p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,&
+            AcoefH, AcoefQ, BcoefH, BcoefQ, &
+            AcoefU, AcoefV, BcoefU, BcoefV, &
+            ps, u1, v1, tsurf_in, &
+            radsol, snow, agesno, &
+            qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+            tsurf_new, dflux_s, dflux_l, lmt_bils)
+       
+    CASE('force')
+
+       PRINT *,'  Lluis before ocean_forced_noice tsurf_new: ',tsurf_new(lp)
+       CALL ocean_forced_noice( &
+            itime, dtime, jour, knon, knindex, &
+            p1lay, cdragh, cdragm, precip_rain, precip_snow, &
+            temp_air, spechum, &
+            AcoefH, AcoefQ, BcoefH, BcoefQ, &
+            AcoefU, AcoefV, BcoefU, BcoefV, &
+            ps, u1, v1, &
+            radsol, snow, agesno, &
+            qsurf, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+            tsurf_new, dflux_s, dflux_l)
+       PRINT *,'  Lluis after ocean_forced_noice tsurf_new: ',tsurf_new(lp)
+    END SELECT
+
+!****************************************************************************************
+! Calculate albedo
+!
+!****************************************************************************************
+    IF ( MINVAL(rmu0) == MAXVAL(rmu0) .AND. MINVAL(rmu0) == -999.999 ) THEN
+       CALL alboc(REAL(jour),rlat,alb_eau)
+    ELSE  ! diurnal cycle
+       CALL alboc_cd(rmu0,alb_eau)
+    ENDIF
+
+    DO i =1, knon
+       alb1_new(i) = alb_eau(knindex(i))
+    ENDDO
+    alb2_new(1:knon) = alb1_new(1:knon)
+
+!****************************************************************************************
+! Calculate the rugosity
+!
+!****************************************************************************************
+    DO i = 1, knon
+       tmp = MAX(cepdu2,u1(i)**2+v1(i)**2)
+       z0_new(i) = 0.018*cdragm(i) * (u1(i)**2+v1(i)**2)/RG  &
+            +  0.11*14e-6 / SQRT(cdragm(i) * tmp)
+       z0_new(i) = MAX(1.5e-05,z0_new(i))
+    ENDDO   
+!
+!****************************************************************************************
+!    
+  END SUBROUTINE surf_ocean
+!
+!****************************************************************************************
+!
+END MODULE surf_ocean_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_seaice_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_seaice_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/surf_seaice_mod.F90	(revision 17)
@@ -0,0 +1,146 @@
+!
+MODULE surf_seaice_mod
+
+  IMPLICIT NONE
+
+CONTAINS
+!
+!****************************************************************************************
+!
+  SUBROUTINE surf_seaice( & 
+       rlon, rlat, swnet, lwnet, alb1, fder, &
+       itime, dtime, jour, knon, knindex, &
+       lafin, &
+       tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum, &
+       AcoefH, AcoefQ, BcoefH, BcoefQ, &
+       AcoefU, AcoefV, BcoefU, BcoefV, &
+       ps, u1, v1, rugoro, pctsrf, &
+       snow, qsurf, qsol, agesno, tsoil, &
+       z0_new, alb1_new, alb2_new, evap, fluxsens, fluxlat, &
+       tsurf_new, dflux_s, dflux_l, &
+       flux_u1, flux_v1)
+
+  USE dimphy
+  USE surface_data
+  USE ocean_forced_mod, ONLY : ocean_forced_ice
+  USE ocean_cpl_mod, ONLY    : ocean_cpl_ice
+  USE indice_sol_mod
+
+!
+! This subroutine will make a call to ocean_XXX_ice according to the ocean mode (force, 
+! slab or couple). The calculation of rugosity for the sea-ice surface is also done
+! in here because it is the same calculation for the different modes of ocean.
+!
+    INCLUDE "dimsoil.h"
+
+! Input arguments
+!****************************************************************************************
+    INTEGER, INTENT(IN)                      :: itime, jour, knon
+    INTEGER, DIMENSION(klon), INTENT(IN)     :: knindex
+    LOGICAL, INTENT(IN)                      :: lafin
+    REAL, INTENT(IN)                         :: dtime
+    REAL, DIMENSION(klon), INTENT(IN)        :: rlon, rlat
+    REAL, DIMENSION(klon), INTENT(IN)        :: swnet  ! net shortwave radiation at surface  
+    REAL, DIMENSION(klon), INTENT(IN)        :: lwnet  ! net longwave radiation at surface  
+    REAL, DIMENSION(klon), INTENT(IN)        :: alb1   ! albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(IN)        :: fder
+    REAL, DIMENSION(klon), INTENT(IN)        :: tsurf
+    REAL, DIMENSION(klon), INTENT(IN)        :: p1lay
+    REAL, DIMENSION(klon), INTENT(IN)        :: cdragh, cdragm
+    REAL, DIMENSION(klon), INTENT(IN)        :: precip_rain, precip_snow
+    REAL, DIMENSION(klon), INTENT(IN)        :: temp_air, spechum
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefH, AcoefQ, BcoefH, BcoefQ
+    REAL, DIMENSION(klon), INTENT(IN)        :: AcoefU, AcoefV, BcoefU, BcoefV
+    REAL, DIMENSION(klon), INTENT(IN)        :: ps
+    REAL, DIMENSION(klon), INTENT(IN)        :: u1, v1
+    REAL, DIMENSION(klon), INTENT(IN)        :: rugoro
+    REAL, DIMENSION(klon,nbsrf), INTENT(IN)  :: pctsrf
+
+! In/Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: snow, qsurf, qsol
+    REAL, DIMENSION(klon), INTENT(INOUT)          :: agesno
+    REAL, DIMENSION(klon, nsoilmx), INTENT(INOUT) :: tsoil
+
+! Output arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon), INTENT(OUT)       :: z0_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb1_new  ! new albedo in visible SW interval
+    REAL, DIMENSION(klon), INTENT(OUT)       :: alb2_new  ! new albedo in near IR interval
+    REAL, DIMENSION(klon), INTENT(OUT)       :: evap, fluxsens, fluxlat
+    REAL, DIMENSION(klon), INTENT(OUT)       :: tsurf_new
+    REAL, DIMENSION(klon), INTENT(OUT)       :: dflux_s, dflux_l      
+    REAL, DIMENSION(klon), INTENT(OUT)       :: flux_u1, flux_v1
+
+! Local arguments
+!****************************************************************************************
+    REAL, DIMENSION(klon)  :: radsol
+
+!
+! End definitions
+!****************************************************************************************
+
+
+!****************************************************************************************
+! Calculate total net radiance at surface
+!
+!****************************************************************************************
+    radsol(:) = 0.0
+    radsol(1:knon) = swnet(1:knon) + lwnet(1:knon)
+
+!****************************************************************************************
+! Switch according to type of ocean (couple, slab or forced)
+!
+!****************************************************************************************
+    IF (type_ocean == 'couple') THEN
+       
+       CALL ocean_cpl_ice( &
+            rlon, rlat, swnet, lwnet, alb1, & 
+            fder, & 
+            itime, dtime, knon, knindex, &
+            lafin,&
+            p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,&
+            AcoefH, AcoefQ, BcoefH, BcoefQ, &
+            AcoefU, AcoefV, BcoefU, BcoefV, &
+            ps, u1, v1, pctsrf, &
+            radsol, snow, qsurf, &
+            alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+            tsurf_new, dflux_s, dflux_l)
+       
+    ELSE IF (type_ocean == 'force' .OR. (type_ocean == 'slab' .AND. version_ocean=='sicOBS')) THEN
+       CALL ocean_forced_ice( &
+            itime, dtime, jour, knon, knindex, &
+            tsurf, p1lay, cdragh, cdragm, precip_rain, precip_snow, temp_air, spechum,&
+            AcoefH, AcoefQ, BcoefH, BcoefQ, &
+            AcoefU, AcoefV, BcoefU, BcoefV, &
+            ps, u1, v1, &
+            radsol, snow, qsol, agesno, tsoil, &
+            qsurf, alb1_new, alb2_new, evap, fluxsens, fluxlat, flux_u1, flux_v1, &
+            tsurf_new, dflux_s, dflux_l)
+
+    ELSE IF (type_ocean == 'slab') THEN
+!!$       CALL ocean_slab_ice( & 
+!!$          itime, dtime, jour, knon, knindex, &
+!!$          debut, &
+!!$          tsurf, p1lay, cdragh, precip_rain, precip_snow, temp_air, spechum,&
+!!$          AcoefH, AcoefQ, BcoefH, BcoefQ, &
+!!$          ps, u1, v1, pctsrf, &
+!!$          radsol, snow, qsurf, qsol, agesno, tsoil, &
+!!$          alb1_new, alb2_new, evap, fluxsens, fluxlat, &
+!!$          tsurf_new, dflux_s, dflux_l)
+
+    END IF
+
+!****************************************************************************************
+! Calculate rugosity
+!
+!****************************************************************************************
+    z0_new = 0.002
+    z0_new = SQRT(z0_new**2+rugoro**2)
+
+  END SUBROUTINE surf_seaice
+!
+!****************************************************************************************
+!
+END MODULE surf_seaice_mod
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/surface_data.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/surface_data.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/surface_data.F90	(revision 17)
@@ -0,0 +1,22 @@
+!
+! $Header$
+!
+MODULE surface_data
+
+  REAL, PARAMETER        :: calice=1.0/(5.1444e+06*0.15)
+  REAL, PARAMETER        :: tau_gl=86400.*5.
+  REAL, PARAMETER        :: calsno=1./(2.3867e+06*.15)
+  
+  LOGICAL, SAVE          :: ok_veget      ! true for use of vegetation model ORCHIDEE
+  CHARACTER(len=10), SAVE :: type_veget    ! orchidee/y/bucket/n/betaclim
+  !$OMP THREADPRIVATE(ok_veget)
+
+  CHARACTER(len=6), SAVE :: type_ocean    ! force/slab/couple
+  !$OMP THREADPRIVATE(type_ocean)
+
+  ! if type_ocean=couple : version_ocean=opa8 ou nemo
+  ! if type_ocean=slab   : version_ocean=sicOBS
+  CHARACTER(len=6), SAVE :: version_ocean 
+  !$OMP THREADPRIVATE(version_ocean)
+
+END MODULE surface_data
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/sw_aeroAR4.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/sw_aeroAR4.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/sw_aeroAR4.F90	(revision 17)
@@ -0,0 +1,643 @@
+!
+! $Id$
+!
+SUBROUTINE SW_AEROAR4(PSCT, PRMU0, PFRAC, &
+     PPMB, PDP, &
+     PPSOL, PALBD, PALBP,&
+     PTAVE, PWV, PQS, POZON, PAER,&
+     PCLDSW, PTAU, POMEGA, PCG,&
+     PHEAT, PHEAT0,&
+     PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,&
+     ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,&
+     tauaero, pizaero, cgaero,&
+     PTAUA, POMEGAA,&
+     PTOPSWADAERO,PSOLSWADAERO,&
+     PTOPSWAD0AERO,PSOLSWAD0AERO,&
+     PTOPSWAIAERO,PSOLSWAIAERO,&
+     PTOPSWAERO,PTOPSW0AERO,&
+     PSOLSWAERO,PSOLSW0AERO,&
+     PTOPSWCFAERO,PSOLSWCFAERO,&
+     ok_ade, ok_aie, flag_aerosol, flag_aerosol_strat )
+
+  USE dimphy
+  USE phys_output_mod, ONLY : swaero_diag
+! L. Fita. August 2013
+  USE radiation_AR4_mod
+
+  IMPLICIT NONE
+
+#include "YOMCST.h"
+#include "clesphys.h"
+#include "iniprint.h"
+  !
+  !     ------------------------------------------------------------------
+  !
+  !     PURPOSE.
+  !     --------
+  !
+  !          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
+  !     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
+  !
+  !     METHOD.
+  !     -------
+  !
+  !          1. COMPUTES ABSORBER AMOUNTS                 (SWU)
+  !          2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL  (SW1S)
+  !          3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL  (SW2S)
+  !
+  !     REFERENCE.
+  !     ----------
+  !
+  !        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
+  !        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
+  !
+  !     AUTHOR.
+  !     -------
+  !        JEAN-JACQUES MORCRETTE  *ECMWF*
+  !
+  !     MODIFICATIONS.
+  !     --------------
+  !        ORIGINAL : 89-07-14
+  !        1995-01-01  J.-J. MORCRETTE  Direct/Diffuse Albedo
+  !        2003-11-27  J. QUAAS Introduce aerosol forcings (based on BOUCHER)
+  !        2009-04     A. COZIC - C.DEANDREIS Indroduce NAT/BC/POM/DUST/SS aerosol forcing
+  !        2012-09     O. BOUCHER - reorganise aerosol cases with ok_ade, ok_aie, flag_aerosol
+  !     ------------------------------------------------------------------
+  !
+  !* ARGUMENTS:
+  !
+  REAL(KIND=8) PSCT  ! constante solaire (valeur conseillee: 1370)
+
+  REAL(KIND=8) PPSOL(KDLON)        ! SURFACE PRESSURE (PA)
+  REAL(KIND=8) PDP(KDLON,KFLEV)    ! LAYER THICKNESS (PA)
+  REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
+
+  REAL(KIND=8) PRMU0(KDLON)  ! COSINE OF ZENITHAL ANGLE
+  REAL(KIND=8) PFRAC(KDLON)  ! fraction de la journee
+
+  REAL(KIND=8) PTAVE(KDLON,KFLEV)  ! LAYER TEMPERATURE (K)
+  REAL(KIND=8) PWV(KDLON,KFLEV)    ! SPECIFI! HUMIDITY (KG/KG)
+  REAL(KIND=8) PQS(KDLON,KFLEV)    ! SATURATED WATER VAPOUR (KG/KG)
+  REAL(KIND=8) POZON(KDLON,KFLEV)  ! OZONE CONCENTRATION (KG/KG)
+  REAL(KIND=8) PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
+
+  REAL(KIND=8) PALBD(KDLON,2)  ! albedo du sol (lumiere diffuse)
+  REAL(KIND=8) PALBP(KDLON,2)  ! albedo du sol (lumiere parallele)
+
+  REAL(KIND=8) PCLDSW(KDLON,KFLEV)    ! CLOUD FRACTION
+  REAL(KIND=8) PTAU(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS (pre-industrial value)
+  REAL(KIND=8) PCG(KDLON,2,KFLEV)     ! ASYMETRY FACTOR
+  REAL(KIND=8) POMEGA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+
+  REAL(KIND=8) PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
+  REAL(KIND=8) PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
+  REAL(KIND=8) PALBPLA(KDLON)     ! PLANETARY ALBEDO
+  REAL(KIND=8) PTOPSW(KDLON)      ! SHORTWAVE FLUX AT T.O.A.
+  REAL(KIND=8) PSOLSW(KDLON)      ! SHORTWAVE FLUX AT SURFACE
+  REAL(KIND=8) PTOPSW0(KDLON)     ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
+  REAL(KIND=8) PSOLSW0(KDLON)     ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
+  !
+  !* LOCAL VARIABLES:
+  !
+  real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
+
+  REAL(KIND=8) ZOZ(KDLON,KFLEV)
+  ! column-density of ozone in layer, in kilo-Dobsons
+
+  REAL(KIND=8) ZAKI(KDLON,2)     
+  REAL(KIND=8) ZCLD(KDLON,KFLEV)
+  REAL(KIND=8) ZCLEAR(KDLON) 
+  REAL(KIND=8) ZDSIG(KDLON,KFLEV)
+  REAL(KIND=8) ZFACT(KDLON)
+  REAL(KIND=8) ZFD(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFDOWN(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFU(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFUP(KDLON,KFLEV+1)
+  REAL(KIND=8) ZRMU(KDLON)
+  REAL(KIND=8) ZSEC(KDLON)
+  REAL(KIND=8) ZUD(KDLON,5,KFLEV+1)
+  REAL(KIND=8) ZCLDSW0(KDLON,KFLEV)
+
+  REAL(KIND=8) ZFSUP(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFSDN(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1)
+  REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1)
+
+  INTEGER inu, jl, jk, i, k, kpl1
+
+  INTEGER swpas  ! Every swpas steps, sw is calculated
+  PARAMETER(swpas=1)
+
+  INTEGER, SAVE :: itapsw = 0
+  !$OMP THREADPRIVATE(itapsw)
+  LOGICAL, SAVE :: appel1er = .TRUE.
+  !$OMP THREADPRIVATE(appel1er)
+  LOGICAL, SAVE :: initialized = .FALSE.
+  !$OMP THREADPRIVATE(initialized)
+
+  !jq-local flag introduced for aerosol forcings
+  REAL(KIND=8), SAVE :: flag_aer
+  !$OMP THREADPRIVATE(flag_aer)
+
+  LOGICAL ok_ade, ok_aie    ! use aerosol forcings or not?
+  LOGICAL flag_aerosol_strat ! use stratospehric aerosols
+  INTEGER flag_aerosol      ! global flag for aerosol 0 (no aerosol) or 1-5 (aerosols)
+  REAL(KIND=8) tauaero(kdlon,kflev,9,2)  ! aerosol optical properties
+  REAL(KIND=8) pizaero(kdlon,kflev,9,2)  ! (see aeropt.F)
+  REAL(KIND=8) cgaero(kdlon,kflev,9,2)   ! -"-
+  REAL(KIND=8) PTAUA(KDLON,2,KFLEV)    ! CLOUD OPTICAL THICKNESS (present-day value)
+  REAL(KIND=8) POMEGAA(KDLON,2,KFLEV)  ! SINGLE SCATTERING ALBEDO
+  REAL(KIND=8) PTOPSWADAERO(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
+  REAL(KIND=8) PSOLSWADAERO(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
+  REAL(KIND=8) PTOPSWAD0AERO(KDLON)    ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
+  REAL(KIND=8) PSOLSWAD0AERO(KDLON)    ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
+  REAL(KIND=8) PTOPSWAIAERO(KDLON)     ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
+  REAL(KIND=8) PSOLSWAIAERO(KDLON)     ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
+  REAL(KIND=8) PTOPSWAERO(KDLON,9)     ! SW TOA AS DRF nat & ant 
+  REAL(KIND=8) PTOPSW0AERO(KDLON,9)    ! SW SRF AS DRF nat & ant 
+  REAL(KIND=8) PSOLSWAERO(KDLON,9)     ! SW TOA CS DRF nat & ant
+  REAL(KIND=8) PSOLSW0AERO(KDLON,9)    ! SW SRF CS DRF nat & ant
+  REAL(KIND=8) PTOPSWCFAERO(KDLON,3)   !  SW TOA AS cloudRF nat & ant 
+  REAL(KIND=8) PSOLSWCFAERO(KDLON,3)   !  SW SRF AS cloudRF nat & ant 
+
+  !jq - Fluxes including aerosol effects
+  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAD_AERO(:,:)
+  !$OMP THREADPRIVATE(ZFSUPAD_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAD_AERO(:,:)
+  !$OMP THREADPRIVATE(ZFSDNAD_AERO)
+  !jq - Fluxes including aerosol effects
+  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAD0_AERO(:,:)
+  !$OMP THREADPRIVATE(ZFSUPAD0_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAD0_AERO(:,:)
+  !$OMP THREADPRIVATE(ZFSDNAD0_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSUPAI_AERO(:,:)
+  !$OMP THREADPRIVATE(ZFSUPAI_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE :: ZFSDNAI_AERO(:,:)
+  !$OMP THREADPRIVATE(ZFSDNAI_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE ::  ZFSUP_AERO(:,:,:)
+  !$OMP THREADPRIVATE(ZFSUP_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE ::  ZFSDN_AERO(:,:,:)
+  !$OMP THREADPRIVATE(ZFSDN_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE ::  ZFSUP0_AERO(:,:,:)
+  !$OMP THREADPRIVATE(ZFSUP0_AERO)
+  REAL(KIND=8),ALLOCATABLE,SAVE ::  ZFSDN0_AERO(:,:,:)
+  !$OMP THREADPRIVATE(ZFSDN0_AERO)
+
+! Key to define the aerosol effect acting on climate
+! OB: AEROSOLFEEDBACK_ACTIVE is now a LOGICAL
+! TRUE: fluxes use natural and/or anthropogenic aerosols according to ok_ade and ok_aie, DEFAULT
+! FALSE: fluxes use no aerosols (case 1)
+
+  LOGICAL,SAVE :: AEROSOLFEEDBACK_ACTIVE = .TRUE.
+!$OMP THREADPRIVATE(AEROSOLFEEDBACK_ACTIVE)  
+
+      CHARACTER (LEN=20) :: modname='sw_aeroAR4'
+      CHARACTER (LEN=80) :: abort_message
+
+  IF(.NOT.initialized) THEN
+     flag_aer=0.
+     initialized=.TRUE.
+     ALLOCATE(ZFSUPAD_AERO(KDLON,KFLEV+1))
+     ALLOCATE(ZFSDNAD_AERO(KDLON,KFLEV+1))
+     ALLOCATE(ZFSUPAD0_AERO(KDLON,KFLEV+1))
+     ALLOCATE(ZFSDNAD0_AERO(KDLON,KFLEV+1))
+     ALLOCATE(ZFSUPAI_AERO(KDLON,KFLEV+1))
+     ALLOCATE(ZFSDNAI_AERO(KDLON,KFLEV+1))
+!-OB decrease size of these arrays to what is needed
+!                | direct effect 
+!ind effect      | no aerosol   natural  total
+!natural (PTAU)  |   1            3       2     --ZFSUP/ZFSDN
+!total (PTAUA)   |                5       4     --ZFSUP/ZFSDN
+!no cloud        |   1            3       2     --ZFSUP0/ZFSDN0
+! so we need which case when ? 
+! ok_ade and ok_aie = 4-5, 4-2 and 2 
+! ok_ade and not ok_aie = 2-3 and 2 
+! not ok_ade and ok_aie = 5-3 and 5 
+! not ok_ade and not ok_aie = 3 
+! therefore the cases have the folliwng switches 
+! 3 = not ok_ade or not ok_aie 
+! 4 = ok_ade and ok_aie 
+! 2 = ok_ade 
+! 5 = ok_aie 
+     ALLOCATE(ZFSUP_AERO (KDLON,KFLEV+1,5))
+     ALLOCATE(ZFSDN_AERO (KDLON,KFLEV+1,5))
+     ALLOCATE(ZFSUP0_AERO(KDLON,KFLEV+1,3))
+     ALLOCATE(ZFSDN0_AERO(KDLON,KFLEV+1,3))
+! end OB modif
+     ZFSUPAD_AERO(:,:)=0.
+     ZFSDNAD_AERO(:,:)=0.
+     ZFSUPAD0_AERO(:,:)=0.
+     ZFSDNAD0_AERO(:,:)=0.
+     ZFSUPAI_AERO(:,:)=0.
+     ZFSDNAI_AERO(:,:)=0.
+     ZFSUP_AERO (:,:,:)=0.
+     ZFSDN_AERO (:,:,:)=0.
+     ZFSUP0_AERO(:,:,:)=0.
+     ZFSDN0_AERO(:,:,:)=0.
+  ENDIF
+
+  IF (appel1er) THEN
+     WRITE(lunout,*)'SW calling frequency : ', swpas
+     WRITE(lunout,*) "   In general, it should be 1"
+     appel1er = .FALSE.
+  ENDIF
+  !     ------------------------------------------------------------------
+  IF (MOD(itapsw,swpas).EQ.0) THEN
+
+     DO JK = 1 , KFLEV
+        DO JL = 1, KDLON
+           ZCLDSW0(JL,JK) = 0.0
+           ZOZ(JL,JK) = POZON(JL,JK)*46.6968/RG &
+                *PDP(JL,JK)*(101325.0/PPSOL(JL))
+        ENDDO
+     ENDDO
+
+! clear sky with no aerosols at all is computed IF ACTIVEFEEDBACK_ACTIVE is false or for extended diag
+     IF ( swaero_diag .or. .not. AEROSOLFEEDBACK_ACTIVE .OR. flag_aerosol .EQ. 0 ) THEN    
+
+     ! clear-sky: zero aerosol effect
+     flag_aer=0.0
+     CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,&
+          PRMU0,PFRAC,PTAVE,PWV,&
+          ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+     INU = 1
+     CALL SW1S_LMDAR4(INU,PAER, flag_aer, &
+          tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),&
+          PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,&
+          ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+          ZFD, ZFU)
+     INU = 2
+     CALL SW2S_LMDAR4(INU, PAER, flag_aer, &
+          tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),&
+          ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,&
+          ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+          PWV, PQS,&
+          ZFDOWN, ZFUP)
+     DO JK = 1 , KFLEV+1
+        DO JL = 1, KDLON
+           ZFSUP0_AERO(JL,JK,1) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+           ZFSDN0_AERO(JL,JK,1) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+        ENDDO
+     ENDDO
+     ENDIF ! swaero_diag .or. .not. AEROSOLFEEDBACK_ACTIVE
+
+! cloudy sky with no aerosols at all is either computed IF no indirect effect is asked for, or for extended diag
+     IF ( swaero_diag .or. .not. AEROSOLFEEDBACK_ACTIVE .OR. flag_aerosol .EQ. 0 ) THEN    
+     ! cloudy-sky: zero aerosol effect
+     flag_aer=0.0
+     CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
+          PRMU0,PFRAC,PTAVE,PWV,&
+          ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+     INU = 1
+     CALL SW1S_LMDAR4(INU, PAER, flag_aer, &
+          tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),&
+          PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+          ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+          ZFD, ZFU)
+     INU = 2
+     CALL SW2S_LMDAR4(INU, PAER, flag_aer, &
+          tauaero(:,:,1,:), pizaero(:,:,1,:), cgaero(:,:,1,:),&
+          ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+          ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+          PWV, PQS,&
+          ZFDOWN, ZFUP)
+
+     DO JK = 1 , KFLEV+1
+        DO JL = 1, KDLON
+           ZFSUP_AERO(JL,JK,1) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+           ZFSDN_AERO(JL,JK,1) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+        ENDDO
+     ENDDO
+     ENDIF ! swaero_diag .or. .not. AEROSOLFEEDBACK_ACTIVE
+
+     IF (flag_aerosol .GT. 0 .OR. flag_aerosol_strat) THEN
+
+     IF (ok_ade.and.swaero_diag .or. .not. ok_ade) THEN
+
+        ! clear sky direct effect natural aerosol
+        ! CAS AER (3)
+        flag_aer=1.0
+        CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,&
+             PRMU0,PFRAC,PTAVE,PWV,&
+             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+        INU = 1
+        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
+             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             ZFD, ZFU)
+        INU = 2
+        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
+             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             PWV, PQS,&
+             ZFDOWN, ZFUP)
+
+        DO JK = 1 , KFLEV+1
+           DO JL = 1, KDLON
+              ZFSUP0_AERO(JL,JK,3) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+              ZFSDN0_AERO(JL,JK,3) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+           ENDDO
+        ENDDO
+     ENDIF !--end not swaero_diag or not ok_ade
+
+     IF (ok_ade) THEN
+
+        ! clear sky direct effect of total aerosol
+        ! CAS AER (2)
+        flag_aer=1.0
+        CALL SWU_LMDAR4(PSCT,ZCLDSW0,PPMB,PPSOL,&
+             PRMU0,PFRAC,PTAVE,PWV,&
+             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+        INU = 1
+        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
+             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             ZFD, ZFU)
+        INU = 2
+        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
+             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             PWV, PQS,&
+             ZFDOWN, ZFUP)
+
+        DO JK = 1 , KFLEV+1
+           DO JL = 1, KDLON
+              ZFSUP0_AERO(JL,JK,2) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL) 
+              ZFSDN0_AERO(JL,JK,2) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 
+           ENDDO
+        ENDDO
+
+        ! cloudy-sky with natural aerosols for indirect effect 
+        ! but total aerosols for direct effect
+        ! PTAU
+        ! CAS AER (2)
+        flag_aer=1.0
+        CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
+             PRMU0,PFRAC,PTAVE,PWV,&
+             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+        INU = 1
+        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
+             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             ZFD, ZFU)
+        INU = 2
+        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
+             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             PWV, PQS,&
+             ZFDOWN, ZFUP)
+
+        DO JK = 1 , KFLEV+1
+           DO JL = 1, KDLON
+              ZFSUP_AERO(JL,JK,2) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL) 
+              ZFSDN_AERO(JL,JK,2) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 
+           ENDDO
+        ENDDO
+
+     ENDIF !-end ok_ade
+
+     IF ( .not. ok_ade .or. .not. ok_aie ) THEN
+
+        ! cloudy-sky with natural aerosols for indirect effect 
+        ! and natural aerosols for direct effect
+        ! PTAU
+        ! CAS AER (3)
+        ! cloudy-sky direct effect natural aerosol
+        flag_aer=1.0
+        CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
+             PRMU0,PFRAC,PTAVE,PWV,&
+             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+        INU = 1
+        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
+             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             ZFD, ZFU)
+        INU = 2
+        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
+             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,&
+             PWV, PQS,&
+             ZFDOWN, ZFUP)
+
+        DO JK = 1 , KFLEV+1
+           DO JL = 1, KDLON
+              ZFSUP_AERO(JL,JK,3) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+              ZFSDN_AERO(JL,JK,3) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
+           ENDDO
+        ENDDO
+
+     ENDIF  !--true/false or false/true
+
+     IF (ok_ade .and. ok_aie) THEN
+
+        ! cloudy-sky with total aerosols for indirect effect 
+        ! and total aerosols for direct effect
+        ! PTAUA
+        ! CAS AER (2)
+        flag_aer=1.0
+        CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
+             PRMU0,PFRAC,PTAVE,PWV,&
+             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+        INU = 1
+        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
+             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,&
+             ZFD, ZFU)
+        INU = 2
+        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,2,:), pizaero(:,:,2,:), cgaero(:,:,2,:),&
+             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,&
+             PWV, PQS,&
+             ZFDOWN, ZFUP)
+
+        DO JK = 1 , KFLEV+1
+           DO JL = 1, KDLON
+              ZFSUP_AERO(JL,JK,4) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+              ZFSDN_AERO(JL,JK,4) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 
+           ENDDO
+        ENDDO
+  
+      ENDIF ! ok_ade .and. ok_aie
+
+     IF (ok_aie) THEN
+        ! cloudy-sky with total aerosols for indirect effect 
+        ! and natural aerosols for direct effect
+        ! PTAUA
+        ! CAS AER (3)
+        flag_aer=1.0
+        CALL SWU_LMDAR4(PSCT,PCLDSW,PPMB,PPSOL,&
+             PRMU0,PFRAC,PTAVE,PWV,&
+             ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
+        INU = 1
+        CALL SW1S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
+             PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,&
+             ZFD, ZFU)
+        INU = 2
+        CALL SW2S_LMDAR4(INU, PAER, flag_aer,&
+             tauaero(:,:,3,:), pizaero(:,:,3,:), cgaero(:,:,3,:),&
+             ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,&
+             ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,&
+             PWV, PQS,&
+             ZFDOWN, ZFUP)
+  
+        DO JK = 1 , KFLEV+1
+           DO JL = 1, KDLON
+              ZFSUP_AERO(JL,JK,5) = (ZFUP(JL,JK)   + ZFU(JL,JK)) * ZFACT(JL)
+              ZFSDN_AERO(JL,JK,5) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL) 
+           ENDDO
+        ENDDO
+
+     ENDIF ! ok_aie      
+
+     ENDIF !--if flag_aerosol GT 0 OR flag_aerosol_strat
+
+     itapsw = 0
+  ENDIF
+  itapsw = itapsw + 1
+
+  IF  ( AEROSOLFEEDBACK_ACTIVE .AND. (flag_aerosol .GT. 0 .OR. flag_aerosol_strat) ) THEN
+  IF ( ok_ade .and. ok_aie  ) THEN
+    ZFSUP(:,:) =    ZFSUP_AERO(:,:,4)
+    ZFSDN(:,:) =    ZFSDN_AERO(:,:,4)
+    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,2)
+    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,2)
+  ENDIF
+
+  IF ( ok_ade .and. (.not. ok_aie) )  THEN
+    ZFSUP(:,:) =    ZFSUP_AERO(:,:,2)
+    ZFSDN(:,:) =    ZFSDN_AERO(:,:,2)
+    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,2)
+    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,2)
+  ENDIF
+
+  IF ( (.not. ok_ade) .and. ok_aie  )  THEN
+    ZFSUP(:,:) =    ZFSUP_AERO(:,:,5)
+    ZFSDN(:,:) =    ZFSDN_AERO(:,:,5)
+    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,3)
+    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,3)
+  ENDIF
+
+  IF ((.not. ok_ade) .and. (.not. ok_aie)) THEN
+    ZFSUP(:,:) =    ZFSUP_AERO(:,:,3)
+    ZFSDN(:,:) =    ZFSDN_AERO(:,:,3)
+    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,3)
+    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,3)
+  ENDIF
+
+! MS the following allows to compute the forcing diagostics without
+! letting the aerosol forcing act on the meteorology
+! SEE logic above
+  ELSE 
+    ZFSUP(:,:) =    ZFSUP_AERO(:,:,1)
+    ZFSDN(:,:) =    ZFSDN_AERO(:,:,1)
+    ZFSUP0(:,:) =   ZFSUP0_AERO(:,:,1)
+    ZFSDN0(:,:) =   ZFSDN0_AERO(:,:,1)
+  ENDIF
+
+! Now computes heating rates
+  DO k = 1, KFLEV
+     kpl1 = k+1
+     DO i = 1, KDLON
+        PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))-(ZFSDN(i,k)-ZFSDN(i,kpl1))
+        PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k)
+        PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))-(ZFSDN0(i,k)-ZFSDN0(i,kpl1))
+        PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k)
+     ENDDO
+  ENDDO
+
+  DO i = 1, KDLON
+! effective SW surface albedo calculation
+     PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20)
+     
+! clear sky net fluxes at TOA and SRF
+     PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1)
+     PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1)
+
+! cloudy sky net fluxes at TOA and SRF
+     PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1)
+     PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1)
+
+! net anthropogenic forcing direct and 1st indirect effect diagnostics
+! requires a natural aerosol field read and used 
+! Difference of net fluxes from double call to radiation
+
+IF (ok_ade) THEN
+
+! indices 1: natural; 2 anthropogenic 
+
+! TOA/SRF all sky natural forcing
+     PSOLSWAERO(i,1) = (ZFSDN_AERO(i,1,3) - ZFSUP_AERO(i,1,3))-(ZFSDN_AERO(i,1,1) - ZFSUP_AERO(i,1,1))
+     PTOPSWAERO(i,1) = (ZFSDN_AERO(i,KFLEV+1,3) - ZFSUP_AERO(i,KFLEV+1,3))- (ZFSDN_AERO(i,KFLEV+1,1) - ZFSUP_AERO(i,KFLEV+1,1))
+
+! TOA/SRF clear sky natural forcing
+     PSOLSW0AERO(i,1) = (ZFSDN0_AERO(i,1,3) - ZFSUP0_AERO(i,1,3))-(ZFSDN0_AERO(i,1,1) - ZFSUP0_AERO(i,1,1))
+     PTOPSW0AERO(i,1) = (ZFSDN0_AERO(i,KFLEV+1,3) - ZFSUP0_AERO(i,KFLEV+1,3))-(ZFSDN0_AERO(i,KFLEV+1,1) - ZFSUP0_AERO(i,KFLEV+1,1))
+
+   IF (ok_aie) THEN 
+
+! TOA/SRF all sky anthropogenic forcing
+     PSOLSWAERO(i,2) = (ZFSDN_AERO(i,1,4) - ZFSUP_AERO(i,1,4))-(ZFSDN_AERO(i,1,5) - ZFSUP_AERO(i,1,5))
+     PTOPSWAERO(i,2) = (ZFSDN_AERO(i,KFLEV+1,4) - ZFSUP_AERO(i,KFLEV+1,4))- (ZFSDN_AERO(i,KFLEV+1,5) - ZFSUP_AERO(i,KFLEV+1,5))
+
+   ELSE 
+
+! TOA/SRF all sky anthropogenic forcing
+     PSOLSWAERO(i,2) = (ZFSDN_AERO(i,1,2) - ZFSUP_AERO(i,1,2))-(ZFSDN_AERO(i,1,3) - ZFSUP_AERO(i,1,3))
+     PTOPSWAERO(i,2) = (ZFSDN_AERO(i,KFLEV+1,2) - ZFSUP_AERO(i,KFLEV+1,2))- (ZFSDN_AERO(i,KFLEV+1,3) - ZFSUP_AERO(i,KFLEV+1,3))
+
+   ENDIF
+
+! TOA/SRF clear sky anthropogenic forcing
+     PSOLSW0AERO(i,2) = (ZFSDN0_AERO(i,1,2) - ZFSUP0_AERO(i,1,2))-(ZFSDN0_AERO(i,1,3) - ZFSUP0_AERO(i,1,3))
+     PTOPSW0AERO(i,2) = (ZFSDN0_AERO(i,KFLEV+1,2) - ZFSUP0_AERO(i,KFLEV+1,2))-(ZFSDN0_AERO(i,KFLEV+1,3) - ZFSUP0_AERO(i,KFLEV+1,3))
+
+! direct anthropogenic forcing , as in old LMDzT, however differences of net fluxes
+     PSOLSWADAERO(i) = PSOLSWAERO(i,2)
+     PTOPSWADAERO(i) = PTOPSWAERO(i,2)
+     PSOLSWAD0AERO(i) = PSOLSW0AERO(i,2)
+     PTOPSWAD0AERO(i) = PTOPSW0AERO(i,2)
+
+! OB: these diagnostics may not always work but who need them
+! Cloud forcing indices 1: natural; 2 anthropogenic; 3: zero aerosol direct effect
+! Instantaneously computed cloudy sky direct aerosol effect, cloud forcing due to aerosols above clouds
+! natural
+     PSOLSWCFAERO(i,1) = PSOLSWAERO(i,1) - PSOLSW0AERO(i,1)
+     PTOPSWCFAERO(i,1) = PTOPSWAERO(i,1) - PTOPSW0AERO(i,1)
+
+! Instantaneously computed cloudy SKY DIRECT aerosol effect, cloud forcing due to aerosols above clouds
+! anthropogenic
+     PSOLSWCFAERO(i,2) = PSOLSWAERO(i,2) - PSOLSW0AERO(i,2)
+     PTOPSWCFAERO(i,2) = PTOPSWAERO(i,2) - PTOPSW0AERO(i,2)
+
+! Cloudforcing without aerosol
+! zero
+     PSOLSWCFAERO(i,3) = (ZFSDN_AERO(i,1,1) - ZFSUP_AERO(i,1,1))-(ZFSDN0_AERO(i,1,1) - ZFSUP0_AERO(i,1,1))
+     PTOPSWCFAERO(i,3) = (ZFSDN_AERO(i,KFLEV+1,1) - ZFSUP_AERO(i,KFLEV+1,1))- (ZFSDN0_AERO(i,KFLEV+1,1) - ZFSUP0_AERO(i,KFLEV+1,1))
+
+ENDIF
+
+IF (ok_aie) THEN
+   IF (ok_ade) THEN 
+     PSOLSWAIAERO(i) = (ZFSDN_AERO(i,1,4) - ZFSUP_AERO(i,1,4))-(ZFSDN_AERO(i,1,2) - ZFSUP_AERO(i,1,2))
+     PTOPSWAIAERO(i) = (ZFSDN_AERO(i,KFLEV+1,4) - ZFSUP_AERO(i,KFLEV+1,4))-(ZFSDN_AERO(i,KFLEV+1,2) - ZFSUP_AERO(i,KFLEV+1,2))
+   ELSE 
+     PSOLSWAIAERO(i) = (ZFSDN_AERO(i,1,5) - ZFSUP_AERO(i,1,5))-(ZFSDN_AERO(i,1,3) - ZFSUP_AERO(i,1,3))
+     PTOPSWAIAERO(i) = (ZFSDN_AERO(i,KFLEV+1,5) - ZFSUP_AERO(i,KFLEV+1,5))-(ZFSDN_AERO(i,KFLEV+1,3) - ZFSUP_AERO(i,KFLEV+1,3))
+   ENDIF
+ENDIF
+
+ENDDO
+
+END SUBROUTINE SW_AEROAR4
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/temps.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/temps.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/temps.h	(revision 17)
@@ -0,0 +1,26 @@
+!
+! $Id: temps.h 1795 2013-07-18 08:20:28Z emillour $
+!
+!  ATTENTION!!!!: ce fichier include est compatible format fixe/format libre
+!                 veillez  n'utiliser que des ! pour les commentaires
+!                 et  bien positionner les & des lignes de continuation
+!                 (les placer en colonne 6 et en colonne 73)
+!
+!
+! jD_ref = jour julien de la date de reference (lancement de l'experience)
+! hD_ref = "heure" julienne de la date de reference
+!-----------------------------------------------------------------------
+! INCLUDE 'temps.h'
+
+      COMMON/temps/ dt, jD_ref, jH_ref, start_time,                     &
+     &             day_ini, day_end, annee_ref, day_ref,                &
+     &             itau_dyn, itau_phy, itaufin, calend
+
+
+      INTEGER   itaufin
+      INTEGER itau_dyn, itau_phy 
+      INTEGER day_ini, day_end, annee_ref, day_ref
+      REAL      dt, jD_ref, jH_ref, start_time
+      CHARACTER (len=10) :: calend
+
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell.F	(revision 17)
@@ -0,0 +1,1284 @@
+!
+! $Id: thermcell.F 1517 2011-05-10 13:07:35Z jghattas $
+!
+      SUBROUTINE calcul_sec(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi,zlev
+     s                  ,pu,pv,pt,po
+     s                  ,zmax,wmax,zw2,lmix
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di
+      REAL tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+c$OMP THREADPRIVATE(idetr)
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+c RC 
+      real zmax(klon),zw,zw2(klon,klev+1),ztva(klon,klev)
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+!      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+!      integer isplit,nsplit
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+c$OMP THREADPRIVATE(isplit)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+ 
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real zalim(klon)
+      integer lalim(klon)
+      real norme(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical therm
+      logical first
+      data first /.false./
+      save first
+c$OMP THREADPRIVATE(first)
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      character (len=20) :: modname='calcul_sec'
+      character (len=80) :: abort_message
+
+
+!      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec
+      save ncorrec
+      data ncorrec/0/
+c$OMP THREADPRIVATE(ncorrec)
+      
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+c       print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+c       print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c      print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c      print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      therm=.false.
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k+1
+               therm=.true.
+            endif
+          enddo
+      enddo
+climitation de la valeur du lentr
+c      do ig=1,ngrid
+c         lentr(ig)=min(5,lentr(ig))
+c      enddo
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+cinitialisations
+      do ig=1,ngrid
+         zalim(ig)=0.
+         norme(ig)=0.
+         lalim(ig)=1
+      enddo
+      do k=1,klev-1
+         do ig=1,ngrid
+       zalim(ig)=zalim(ig)+zlev(ig,k)*MAX(0.,(ztv(ig,k)-ztv(ig,k+1))
+     s          /(zlev(ig,k+1)-zlev(ig,k)))
+c     s         *(zlev(ig,k+1)-zlev(ig,k))
+       norme(ig)=norme(ig)+MAX(0.,(ztv(ig,k)-ztv(ig,k+1))
+     s          /(zlev(ig,k+1)-zlev(ig,k)))
+c    s          *(zlev(ig,k+1)-zlev(ig,k))
+         enddo
+       enddo
+       do ig=1,ngrid
+          if (norme(ig).gt.1.e-10) then
+             zalim(ig)=max(10.*zalim(ig)/norme(ig),zlev(ig,2))
+c             zalim(ig)=min(zalim(ig),zlev(ig,lentr(ig)))
+          endif
+       enddo
+cdétermination du lalim correspondant
+      do k=1,klev-1
+         do ig=1,ngrid
+      if ((zalim(ig).gt.zlev(ig,k)).and.(zalim(ig).le.zlev(ig,k+1))) 
+     s   then
+         lalim(ig)=k
+      endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.lt.lentr(ig)) then 
+                 entr_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)
+c     s                           *(zlev(ig,l+1)-zlev(ig,l))
+     s                           *sqrt(zlev(ig,l+1))
+cautre def
+c                entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
+c     s                         /zlev(ig,lentr(ig)+2)))**(3./2.)
+            endif
+         enddo
+      enddo
+cnouveau test
+c      if (therm) then
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.le.lalim(ig)
+     s          .and.zalim(ig).gt.1.e-10) then 
+c            if (l.le.lentr(ig)) then 
+c               entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
+c     s                         /zalim(ig)))**(3./2.)
+c               write(10,*)zlev(ig,l),entr_star(ig,l)
+            endif
+         enddo
+      enddo
+c      endif
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+c Calcul entrainement normalise
+      do ig=1,ngrid 
+         if (entr_star_tot(ig).gt.1.e-10) then
+c         do l=1,lentr(ig)
+          do l=1,klev
+cdef possibles pour entr_star: zdthetadz, dthetadz, zdtheta 
+            entr_star(ig,l)=entr_star(ig,l)/entr_star_tot(ig)
+         enddo
+         endif
+      enddo
+c
+c      print*,'fin calcul entr_star'
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+cRC
+c      print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c      print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.entr_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=entr_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+     s                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+ctest
+               if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then
+c                  print*,'pb linter'
+               endif
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               if (zw2(ig,l+1).lt.0.) then
+c                  print*,'pb1 zw2<0'
+               endif
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+c      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+c         lmax(ig)=lalim(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+c         do l=nlay,lalim(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            lmax(ig)=1
+            lmin(ig)=1
+            lentr(ig)=1
+            lalim(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+c                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+      do ig=1,ngrid
+c      write(8,*)zmax(ig),lmax(ig),lentr(ig),lmin(ig)
+      enddo
+con stope après les calculs de zmax et wmax
+      RETURN
+
+c      print*,'avant fermeture'
+c Fermeture,determination de f
+cAttention! entrainement normalisé ou pas?
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+c             do k=lmin(ig),lalim(ig) 
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+c Nouvelle fermeture
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect
+     s             *entr_star2(ig))
+c     s            *entr_star_tot(ig)
+ctest
+c             if (first) then
+             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+     s             *wmax(ig))
+c             endif
+         endif
+         f0(ig)=f(ig)
+c         first=.true.
+      enddo
+c      print*,'apres fermeture'
+con stoppe après la fermeture
+      RETURN
+c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+con stoppe après le calcul de entr
+c      RETURN
+cCR:test pour entrainer moins que la masse
+c       do ig=1,ngrid
+c          do l=1,lentr(ig)
+c             if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then
+c                entr(ig,l+1)=entr(ig,l+1)+entr(ig,l)
+c     s                       -0.9*masse(ig,l)/ptimestep
+c                entr(ig,l)=0.9*masse(ig,l)/ptimestep
+c             endif
+c          enddo
+c       enddo
+cCR: fin test
+c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+cRC
+
+
+c      print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+c                   print*,'pb l_mix*zlev<0'
+                  endif
+cCR: test: nouvelle def de lambda
+c                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  if (zw2(ig,l).gt.1.e-10) then
+                  larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
+                  else
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  endif
+cRC
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c      print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)
+     s        then
+c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+            else
+            zmix(ig)=zlev(ig,lmix(ig))
+c            print*,'pb zmix'
+            endif
+         else 
+         zmix(ig)=0.
+         endif
+ctest
+         if ((zmax(ig)-zmix(ig)).lt.0.) then
+            zmix(ig)=0.99*zmax(ig)
+c            print*,'pb zmix>zmax'
+         endif
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+c                   print*,'pb xxx'
+                   xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+      
+c      print*,'fin calcul fraca'
+c      print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+              abort_message = 'fracd trop petit'
+              CALL abort_gcm (modname,abort_message,1)
+
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+c      print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+cCR:redefinition du entr
+       do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                fm(ig,l+1)=fm(ig,l)+entr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+cRC
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/tho
+         entr0=entr0+ptimestep*(entr-entr0)/tho
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+c      print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+cdeja fait
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+c            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+c                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+c            endif
+c         enddo
+c      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+#define troisD
+#ifdef troisD
+c       if (sorties) then
+c      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+c      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+c      print*,'19 OK convect8'
+      return
+      end
+
+      SUBROUTINE fermeture_seche(ngrid,nlay
+     s                ,pplay,pplev,pphi,zlev,rhobarz,f0,zpspsk
+     s                ,alim_star,zh,zo,lentr,lmin,nu_min,nu_max,r_aspect
+     s                ,zmax,wmax)
+
+      USE dimphy
+      IMPLICIT NONE
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+      INTEGER ngrid,nlay
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+      real zlev(klon,klev+1)
+      real alim_star(klon,klev)
+      real f0(klon)
+      integer lentr(klon)
+      integer lmin(klon)
+      real zmax(klon)
+      real wmax(klon)
+      real nu_min
+      real nu_max
+      real r_aspect
+      real rhobarz(klon,klev+1)
+      REAL zh(klon,klev)
+      real zo(klon,klev)
+      real zpspsk(klon,klev)
+
+      integer ig,l
+
+      real f_star(klon,klev+1)
+      real detr_star(klon,klev)
+      real entr_star(klon,klev)
+      real zw2(klon,klev+1)
+      real linter(klon)
+      integer lmix(klon)
+      integer lmax(klon)
+      real zlevinter(klon)
+      real wa_moy(klon,klev+1)
+      real wmaxa(klon)
+      REAL ztv(klon,klev)
+      REAL ztva(klon,klev)
+      real nu(klon,klev)
+!      real zmax0_sec(klon)
+!      save zmax0_sec
+       REAL, SAVE, ALLOCATABLE :: zmax0_sec(:)
+c$OMP THREADPRIVATE(zmax0_sec)
+      logical, save :: first = .true.
+c$OMP THREADPRIVATE(first)
+
+      if (first) then
+        allocate(zmax0_sec(klon))
+        first=.false.
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+      ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+      ztv(ig,l)=ztv(ig,l)*(1.+RETV*zo(ig,l))
+         enddo
+      enddo
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.alim_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=alim_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s         (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then
+cestimation du detrainement a partir de la geometrie du pas precedent
+ctests sur la definition du detr
+             nu(ig,l)=(nu_min+nu_max)/2.
+     s         *(1.-(nu_max-nu_min)/(nu_max+nu_min)
+     s  *tanh((((ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l))/0.0005)))
+         
+             detr_star(ig,l)=rhobarz(ig,l)
+     s                      *sqrt(zw2(ig,l)) 
+     s                       /(r_aspect*zmax0_sec(ig))*
+c     s                       /(r_aspect*zmax0(ig))*
+     s                      (sqrt(nu(ig,l)*zlev(ig,l+1)
+     s                /sqrt(zw2(ig,l)))
+     s                     -sqrt(nu(ig,l)*zlev(ig,l)
+     s                /sqrt(zw2(ig,l))))
+         detr_star(ig,l)=detr_star(ig,l)/f0(ig)
+         if ((detr_star(ig,l)).gt.f_star(ig,l)) then
+              detr_star(ig,l)=f_star(ig,l)
+         endif
+         entr_star(ig,l)=0.9*detr_star(ig,l)
+             if ((l.lt.lentr(ig))) then
+                 entr_star(ig,l)=0.
+c                 detr_star(ig,l)=0.
+             endif 
+c           print*,'ok detr_star'
+cprise en compte du detrainement dans le calcul du flux
+             f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)
+     s                      -detr_star(ig,l)
+ctest sur le signe de f_star
+       if ((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10) then 
+cAM on melange Tl et qt du thermique
+          ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+(entr_star(ig,l)
+     s                    +alim_star(ig,l))
+     s                    *ztv(ig,l))/(f_star(ig,l+1)+detr_star(ig,l))
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)
+     s                     /(f_star(ig,l+1)+detr_star(ig,l)))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+        endif
+c
+            if (zw2(ig,l+1).lt.0.) then 
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+c              print*,'linter=',linter(ig)
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+c     print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+             lmin(ig)=1
+             lentr(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+c                 print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+cpour le cas ou on prend tjs lmin=1
+c       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1))
+       zmax0_sec(ig)=zmax(ig)
+      enddo
+       
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell.F90	(revision 17)
@@ -0,0 +1,1284 @@
+!
+! $Id: thermcell.F 1517 2011-05-10 13:07:35Z jghattas $
+!
+      SUBROUTINE calcul_sec(ngrid,nlay,ptimestep                                     &
+       &                  ,pplay,pplev,pphi,zlev                                     &
+       &                  ,pu,pv,pt,po                                               &
+       &                  ,zmax,wmax,zw2,lmix                                        &
+!c    s                  ,pu_therm,pv_therm                                          &
+       &                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+!c=======================================================================
+!c
+!c   Calcul du transport verticale dans la couche limite en presence
+!c   de "thermiques" explicitement representes
+!c
+!c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+!c
+!c   le thermique est supposé homogène et dissipé par mélange avec
+!c   son environnement. la longueur l_mix contrôle l'efficacité du
+!c   mélange
+!c
+!c   Le calcul du transport des différentes espèces se fait en prenant
+!c   en compte:
+!c     1. un flux de masse montant
+!c     2. un flux de masse descendant
+!c     3. un entrainement
+!c     4. un detrainement
+!c
+!c=======================================================================
+
+!c-----------------------------------------------------------------------
+!c   declarations:
+!c   -------------
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+!c   arguments:
+!c   ----------
+
+      INTEGER ngrid,nlay,w2di
+      REAL tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+!$OMP THREADPRIVATE(idetr)
+!c   local:
+!c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+!c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+!c RC 
+      real zmax(klon),zw,zw2(klon,klev+1),ztva(klon,klev)
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+!      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+!      integer isplit,nsplit
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+!$OMP THREADPRIVATE(isplit)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+!c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+ 
+!cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real zalim(klon)
+      integer lalim(klon)
+      real norme(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical therm
+      logical first
+      data first /.false./
+      save first
+!$OMP THREADPRIVATE(first)
+!cRC
+
+      character*2 str2
+      character*10 str10
+
+      character (len=20) :: modname='calcul_sec'
+      character (len=80) :: abort_message
+
+
+!      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec
+      save ncorrec
+      data ncorrec/0/
+!$OMP THREADPRIVATE(ncorrec)
+      
+!c
+!c-----------------------------------------------------------------------
+!c   initialisation:
+!c   ---------------
+!c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+!c
+!c-----------------------------------------------------------------------
+!c   incrementation eventuelle de tendances precedentes:
+!c   ---------------------------------------------------
+
+!c       print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+!c       print*,'1 OK convect8'
+!c                       --------------------
+!c
+!c
+!c                       + + + + + + + + + + +
+!c
+!c
+!c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+!c  wh,wt,wo ...
+!c
+!c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+!c
+!c
+!c                       --------------------   zlev(1)
+!c                       \\\\\\\\\\\\\\\\\\\\
+!c
+!c
+
+!c-----------------------------------------------------------------------
+!c   Calcul des altitudes des couches
+!c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+!c      print*,'2 OK convect8'
+!c-----------------------------------------------------------------------
+!c   Calcul des densites
+!c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+!c      print*,'3 OK convect8'
+!c------------------------------------------------------------------
+!c   Calcul de w2, quarre de w a partir de la cape
+!c   a partir de w2, on calcule wa, vitesse de l'ascendance
+!c
+!c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+!c   w2 est stoke dans wa
+!c
+!c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+!c   independants par couches que pour calculer l'entrainement
+!c   a la base et la hauteur max de l'ascendance.
+!c
+!c   Indicages:
+!c   l'ascendance provenant du niveau k traverse l'interface l avec
+!c   une vitesse wa(k,l).
+!c
+!c                       --------------------
+!c
+!c                       + + + + + + + + + + 
+!c
+!c  wa(k,l)   ----       --------------------    l
+!c             /\
+!c            /||\       + + + + + + + + + + 
+!c             ||
+!c             ||        --------------------
+!c             ||
+!c             ||        + + + + + + + + + + 
+!c             ||
+!c             ||        --------------------
+!c             ||__
+!c             |___      + + + + + + + + + +     k
+!c
+!c                       --------------------
+!c
+!c
+!c
+!c------------------------------------------------------------------
+
+!cCR: ponderation entrainement des couches instables
+!cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+!c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+!con ne considere que les premieres couches instables
+      therm=.false.
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.                                        &
+       &          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k+1
+               therm=.true.
+            endif
+          enddo
+      enddo
+!climitation de la valeur du lentr
+!c      do ig=1,ngrid
+!c         lentr(ig)=min(5,lentr(ig))
+!c      enddo
+!c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+!cinitialisations
+      do ig=1,ngrid
+         zalim(ig)=0.
+         norme(ig)=0.
+         lalim(ig)=1
+      enddo
+      do k=1,klev-1
+         do ig=1,ngrid
+       zalim(ig)=zalim(ig)+zlev(ig,k)*MAX(0.,(ztv(ig,k)-ztv(ig,k+1))                 &
+       &          /(zlev(ig,k+1)-zlev(ig,k)))
+!c     s         *(zlev(ig,k+1)-zlev(ig,k))
+       norme(ig)=norme(ig)+MAX(0.,(ztv(ig,k)-ztv(ig,k+1))                            &
+       &          /(zlev(ig,k+1)-zlev(ig,k)))
+!c    s          *(zlev(ig,k+1)-zlev(ig,k))
+         enddo
+       enddo
+       do ig=1,ngrid
+          if (norme(ig).gt.1.e-10) then
+             zalim(ig)=max(10.*zalim(ig)/norme(ig),zlev(ig,2))
+!c             zalim(ig)=min(zalim(ig),zlev(ig,lentr(ig)))
+          endif
+       enddo
+!cdétermination du lalim correspondant
+      do k=1,klev-1
+         do ig=1,ngrid
+      if ((zalim(ig).gt.zlev(ig,k)).and.(zalim(ig).le.zlev(ig,k+1)))                 &
+       &   then
+         lalim(ig)=k
+      endif
+         enddo
+      enddo
+!c
+!c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.                                        &
+       &          l.ge.lmin(ig).and.l.lt.lentr(ig)) then 
+                 entr_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)                     &
+!c     s                           *(zlev(ig,l+1)-zlev(ig,l))                        &
+       &                           *sqrt(zlev(ig,l+1))
+!cautre def
+!c                entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
+!c     s                         /zlev(ig,lentr(ig)+2)))**(3./2.)
+            endif
+         enddo
+      enddo
+!cnouveau test
+!c      if (therm) then
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.                                        &
+       &          l.ge.lmin(ig).and.l.le.lalim(ig)                                   &
+       &          .and.zalim(ig).gt.1.e-10) then 
+!c            if (l.le.lentr(ig)) then 
+!c               entr_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
+!c     s                         /zalim(ig)))**(3./2.)
+!c               write(10,*)zlev(ig,l),entr_star(ig,l)
+            endif
+         enddo
+      enddo
+!c      endif
+!c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+!c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+!c Calcul entrainement normalise
+      do ig=1,ngrid 
+         if (entr_star_tot(ig).gt.1.e-10) then
+!c         do l=1,lentr(ig)
+          do l=1,klev
+!cdef possibles pour entr_star: zdthetadz, dthetadz, zdtheta 
+            entr_star(ig,l)=entr_star(ig,l)/entr_star_tot(ig)
+         enddo
+         endif
+      enddo
+!c
+!c      print*,'fin calcul entr_star'
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+!cRC
+!c      print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+!cCR
+            f_star(ig,k)=0.
+!cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+!c      print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+!cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)                                             &
+       &         .and.entr_star(ig,l).gt.1.e-10                                      &
+       &         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=entr_star(ig,l)
+!ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)                 &
+       &                     *(zlev(ig,l+1)-zlev(ig,l))                              &
+       &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.                                       &
+       &               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)                 &
+       &                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+               &
+       &                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)                  &
+       &                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+!c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+!ctest
+               if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then
+!c                  print*,'pb linter'
+               endif
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))                                 &
+       &           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               if (zw2(ig,l+1).lt.0.) then
+!c                  print*,'pb1 zw2<0'
+               endif
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+!c      print*,'fin calcul zw2'
+!c
+!c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+!c         lmax(ig)=lalim(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+!c         do l=nlay,lalim(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+!c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            lmax(ig)=1
+            lmin(ig)=1
+            lentr(ig)=1
+            lalim(ig)=1
+         endif
+      enddo 
+!c    
+!c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+!c                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+!c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*                     &
+       &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)               &
+       &    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+      do ig=1,ngrid
+!c      write(8,*)zmax(ig),lmax(ig),lentr(ig),lmin(ig)
+      enddo
+!con stope après les calculs de zmax et wmax
+      RETURN
+
+!c      print*,'avant fermeture'
+!c Fermeture,determination de f
+!cAttention! entrainement normalisé ou pas?
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+!c             do k=lmin(ig),lalim(ig) 
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2                     &
+       &                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+!c Nouvelle fermeture
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect                             &
+       &             *entr_star2(ig))
+!c     s            *entr_star_tot(ig)
+!ctest
+!c             if (first) then
+             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)                      &
+       &             *wmax(ig))
+!c             endif
+         endif
+         f0(ig)=f(ig)
+!c         first=.true.
+      enddo
+!c      print*,'apres fermeture'
+!con stoppe après la fermeture
+      RETURN
+!c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+!con stoppe après le calcul de entr
+!c      RETURN
+!cCR:test pour entrainer moins que la masse
+!c       do ig=1,ngrid
+!c          do l=1,lentr(ig)
+!c             if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then
+!c                entr(ig,l+1)=entr(ig,l+1)+entr(ig,l)
+!c     s                       -0.9*masse(ig,l)/ptimestep
+!c                entr(ig,l)=0.9*masse(ig,l)/ptimestep
+!c             endif
+!c          enddo
+!c       enddo
+!cCR: fin test
+!c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+!cRC
+
+
+!c      print*,'9 OK convect8'
+!c     print*,'WA1 ',wa_moy
+
+!c   determination de l'indice du debut de la mixed layer ou w decroit
+
+!c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+!c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+!c   d'une couche est égale à la hauteur de la couche alimentante.
+!c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+!c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect                                     &
+       &         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+!c              if (idetr.eq.0) then
+!c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+!c                   print*,'pb l_mix*zlev<0'
+                  endif
+!cCR: test: nouvelle def de lambda
+!c                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  if (zw2(ig,l).gt.1.e-10) then
+                  larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
+                  else
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  endif
+!cRC
+!c              else if (idetr.eq.1) then
+!c                 larg_detr(ig,l)=larg_cons(ig,l)
+!c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+!c              else if (idetr.eq.2) then
+!c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c    s            *sqrt(wa_moy(ig,l))
+!c              else if (idetr.eq.4) then
+!c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c    s            *wa_moy(ig,l)
+!c              endif
+            endif
+         enddo
+       enddo
+
+!c      print*,'10 OK convect8'
+!c     print*,'WA2 ',wa_moy
+!c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+!c   compte de l'epluchage du thermique.
+!c
+!cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+!c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                             &
+       &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))                         &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)              &
+       &        then
+!c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                          &
+       &        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)                   &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))                  &
+       &        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                          &
+       &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))                         &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+            else
+            zmix(ig)=zlev(ig,lmix(ig))
+!c            print*,'pb zmix'
+            endif
+         else 
+         zmix(ig)=0.
+         endif
+!ctest
+         if ((zmax(ig)-zmix(ig)).lt.0.) then
+            zmix(ig)=0.99*zmax(ig)
+!c            print*,'pb zmix>zmax'
+         endif
+      enddo
+!c
+!c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.                                          &
+       &          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+!c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+!c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))                         &
+       &            /(r_aspect*zmax(ig))
+!c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+!c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+!cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/                   &
+       &     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)                        &
+       &    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)              &
+       &    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+!c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+!ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+!c                   print*,'pb xxx'
+                   xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+!c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+      
+!c      print*,'fin calcul fraca'
+!c      print*,'11 OK convect8'
+!c     print*,'Ea3 ',wa_moy
+!c------------------------------------------------------------------
+!c   Calcul de fracd, wd
+!c   somme wa - wd = 0
+!c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+!cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)                   &
+       &            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+!c                 write(1,*)'ajustement fm, l',l
+              endif
+!c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+!cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+              abort_message = 'fracd trop petit'
+              CALL abort_gcm (modname,abort_message,1)
+
+            else
+!c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+!c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+!c      print*,'12 OK convect8'
+!c     print*,'WA4 ',wa_moy
+!cc------------------------------------------------------------------
+!c   calcul du transport vertical
+!c------------------------------------------------------------------
+
+      go to 4444
+!c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)                                   &
+       &      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+!c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+!c    s         ,fm(ig,l+1)*ptimestep
+!c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+!c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+!c    s         ,entr(ig,l)*ptimestep
+!c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+!c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+!c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10                                            &
+       &         .or..not.masse(ig,l).le.1.e4) then
+!c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+!c    s         ,'   M=',masse(ig,l)
+!c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+!c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+!c     print*,'zlev(ig,l+1),zlev(ig,l)'
+!c    s                ,zlev(ig,l+1),zlev(ig,l)
+!c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+!c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+!c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+!c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+!cCR:redefinition du entr
+       do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+!c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                fm(ig,l+1)=fm(ig,l)+entr(ig,l)
+                detr(ig,l)=0.
+!c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+!cRC
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/tho
+         entr0=entr0+ptimestep*(entr-entr0)/tho
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca                &
+       &    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca                &
+       &    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse                      &
+       &    ,fraca,zmax                                                              &
+       &    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+!c     print*,'13 OK convect8'
+!c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+!c     do l=1,nlay
+!c        do ig=1,ngrid
+!c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+!c     print*,'WARN!!! ig=',ig,'  l=',l
+!c    s         ,'   pdtadj=',pdtadj(ig,l)
+!c           endif
+!c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+!c     print*,'WARN!!! ig=',ig,'  l=',l
+!c    s         ,'   pdoadj=',pdoadj(ig,l)
+!c           endif
+!c        enddo
+!c      enddo
+
+!c      print*,'14 OK convect8'
+!c------------------------------------------------------------------
+!c   Calculs pour les sorties
+!c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)                                             &
+       &      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+!cdeja fait
+!c      do l=1,nlay
+!c         do ig=1,ngrid
+!c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+!c            if (detr(ig,l).lt.0.) then
+!c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+!c                detr(ig,l)=0.
+!c     print*,'WARNING !!! detrainement negatif ',ig,l
+!c            endif
+!c         enddo
+!c      enddo
+
+!c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+!c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+!c   recalcul des flux en diagnostique...
+!c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+#define troisD
+#ifdef troisD
+!c       if (sorties) then
+!c      print*,'Debut des wrgradsfi'
+
+!c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+!c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+!cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+!c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+!c     print*,'18 OK convect8'
+!c      endif
+!c      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+!c     if(wa_moy(1,4).gt.1.e-10) stop
+
+!c      print*,'19 OK convect8'
+      return
+      end SUBROUTINE calcul_sec
+
+      SUBROUTINE fermeture_seche(ngrid,nlay                                          &
+       &                ,pplay,pplev,pphi,zlev,rhobarz,f0,zpspsk                     &
+       &                ,alim_star,zh,zo,lentr,lmin,nu_min,nu_max,r_aspect           &
+       &                ,zmax,wmax)
+
+      USE dimphy
+      IMPLICIT NONE
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+      INTEGER ngrid,nlay
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+      real zlev(klon,klev+1)
+      real alim_star(klon,klev)
+      real f0(klon)
+      integer lentr(klon)
+      integer lmin(klon)
+      real zmax(klon)
+      real wmax(klon)
+      real nu_min
+      real nu_max
+      real r_aspect
+      real rhobarz(klon,klev+1)
+      REAL zh(klon,klev)
+      real zo(klon,klev)
+      real zpspsk(klon,klev)
+
+      integer ig,l
+
+      real f_star(klon,klev+1)
+      real detr_star(klon,klev)
+      real entr_star(klon,klev)
+      real zw2(klon,klev+1)
+      real linter(klon)
+      integer lmix(klon)
+      integer lmax(klon)
+      real zlevinter(klon)
+      real wa_moy(klon,klev+1)
+      real wmaxa(klon)
+      REAL ztv(klon,klev)
+      REAL ztva(klon,klev)
+      real nu(klon,klev)
+!      real zmax0_sec(klon)
+!      save zmax0_sec
+       REAL, SAVE, ALLOCATABLE :: zmax0_sec(:)
+!$OMP THREADPRIVATE(zmax0_sec)
+      logical, save :: first = .true.
+!$OMP THREADPRIVATE(first)
+
+      if (first) then
+        allocate(zmax0_sec(klon))
+        first=.false.
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+      ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+      ztv(ig,l)=ztv(ig,l)*(1.+RETV*zo(ig,l))
+         enddo
+      enddo
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)                                             &
+       &         .and.alim_star(ig,l).gt.1.e-10                                      &
+       &         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=alim_star(ig,l)
+!ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)                 &
+       &                     *(zlev(ig,l+1)-zlev(ig,l))                              &
+       &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+            else if ((zw2(ig,l).ge.1e-10).and.                                       &
+       &         (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then
+!cestimation du detrainement a partir de la geometrie du pas precedent
+!ctests sur la definition du detr
+             nu(ig,l)=(nu_min+nu_max)/2.                                             &
+       &         *(1.-(nu_max-nu_min)/(nu_max+nu_min)                                &
+       &  *tanh((((ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l))/0.0005)))
+         
+             detr_star(ig,l)=rhobarz(ig,l)                                           &
+       &                      *sqrt(zw2(ig,l))                                       &
+       &                       /(r_aspect*zmax0_sec(ig))*                            &
+!c     s                       /(r_aspect*zmax0(ig))*                                &
+       &                      (sqrt(nu(ig,l)*zlev(ig,l+1)                            &
+       &                /sqrt(zw2(ig,l)))                                            &
+       &                     -sqrt(nu(ig,l)*zlev(ig,l)                               &
+       &                /sqrt(zw2(ig,l))))
+         detr_star(ig,l)=detr_star(ig,l)/f0(ig)
+         if ((detr_star(ig,l)).gt.f_star(ig,l)) then
+              detr_star(ig,l)=f_star(ig,l)
+         endif
+         entr_star(ig,l)=0.9*detr_star(ig,l)
+             if ((l.lt.lentr(ig))) then
+                 entr_star(ig,l)=0.
+!c                 detr_star(ig,l)=0.
+             endif 
+!c           print*,'ok detr_star'
+!cprise en compte du detrainement dans le calcul du flux
+             f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)             &
+       &                      -detr_star(ig,l)
+!ctest sur le signe de f_star
+       if ((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10) then 
+!cAM on melange Tl et qt du thermique
+          ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+(entr_star(ig,l)                     &
+       &                    +alim_star(ig,l))                                        &
+       &                    *ztv(ig,l))/(f_star(ig,l+1)+detr_star(ig,l))
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)                                   &
+       &                     /(f_star(ig,l+1)+detr_star(ig,l)))**2+                  &
+       &                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)                  &
+       &                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+        endif
+!c
+            if (zw2(ig,l+1).lt.0.) then 
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))                                 &
+       &           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+!c              print*,'linter=',linter(ig)
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+!c     print*,'fin calcul zw2'
+!c
+!c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+!c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+             lmin(ig)=1
+             lentr(ig)=1
+         endif
+      enddo 
+!c    
+!c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+!c                 print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+!c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*                     &
+       &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)               &
+       &    -zlev(ig,lmax(ig)))
+!cpour le cas ou on prend tjs lmin=1
+!c       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1))
+       zmax0_sec(ig)=zmax(ig)
+      enddo
+       
+      RETURN
+      END SUBROUTINE fermeture_seche
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell.h	(revision 17)
@@ -0,0 +1,30 @@
+      integer            :: iflag_thermals,nsplit_thermals
+
+!!! nrlmd le 10/04/2012
+      integer            :: iflag_trig_bl,iflag_clos_bl
+      integer            :: tau_trig_shallow,tau_trig_deep
+      real               :: s_trig
+!!! fin nrlmd le 10/04/2012
+
+      real,parameter     :: r_aspect_thermals=2.,l_mix_thermals=30.
+      real               :: alp_bl_k
+      real               :: tau_thermals
+      integer,parameter  :: w2di_thermals=0
+      integer            :: isplit
+
+      integer            :: iflag_coupl,iflag_clos,iflag_wake
+      integer            :: iflag_thermals_ed,iflag_thermals_optflux
+
+      common/ctherm1/iflag_thermals,nsplit_thermals
+      common/ctherm2/tau_thermals,alp_bl_k
+      common/ctherm4/iflag_coupl,iflag_clos,iflag_wake
+      common/ctherm5/iflag_thermals_ed,iflag_thermals_optflux
+
+!!! nrlmd le 10/04/2012
+      common/ctherm6/iflag_trig_bl,iflag_clos_bl
+      common/ctherm7/tau_trig_shallow,tau_trig_deep
+      common/ctherm8/s_trig
+!!! fin nrlmd le 10/04/2012
+
+!$OMP THREADPRIVATE(/ctherm1/,/ctherm2/,/ctherm4/,/ctherm5/)
+!$OMP THREADPRIVATE(/ctherm6/,/ctherm7/,/ctherm8/)
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcellV0_main.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcellV0_main.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcellV0_main.F90	(revision 17)
@@ -0,0 +1,2101 @@
+!
+! $Id$
+!
+      SUBROUTINE thermcellV0_main(itap,ngrid,nlay,ptimestep  &
+     &                  ,pplay,pplev,pphi,debut  &
+     &                  ,pu,pv,pt,po  &
+     &                  ,pduadj,pdvadj,pdtadj,pdoadj  &
+     &                  ,fm0,entr0,detr0,zqta,zqla,lmax  &
+     &                  ,ratqscth,ratqsdiff,zqsatth  &
+     &                  ,r_aspect,l_mix,tau_thermals &
+     &                  ,Ale_bl,Alp_bl,lalim_conv,wght_th &
+     &                  ,zmax0, f0,zw2,fraca)
+
+      USE dimphy
+      USE comgeomphy , ONLY:rlond,rlatd
+      IMPLICIT NONE
+
+!=======================================================================
+!   Auteurs: Frederic Hourdin, Catherine Rio, Anne Mathieu
+!   Version du 09.02.07
+!   Calcul du transport vertical dans la couche limite en presence
+!   de "thermiques" explicitement representes avec processus nuageux
+!
+!   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+!
+!   le thermique est supposé homogène et dissipé par mélange avec
+!   son environnement. la longueur l_mix contrôle l'efficacité du
+!   mélange
+!
+!   Le calcul du transport des différentes espèces se fait en prenant
+!   en compte:
+!     1. un flux de masse montant
+!     2. un flux de masse descendant
+!     3. un entrainement
+!     4. un detrainement
+!
+!=======================================================================
+
+!-----------------------------------------------------------------------
+!   declarations:
+!   -------------
+
+#include "dimensions.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+#include "iniprint.h"
+
+!   arguments:
+!   ----------
+
+!IM 140508
+      INTEGER itap
+
+      INTEGER ngrid,nlay,w2di
+      real tau_thermals
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+!   local:
+!   ------
+
+      integer icount
+      data icount/0/
+      save icount
+!$OMP THREADPRIVATE(icount)
+
+      integer,save :: igout=1
+!$OMP THREADPRIVATE(igout)
+      integer,save :: lunout1=6
+!$OMP THREADPRIVATE(lunout1)
+      integer,save :: lev_out=10
+!$OMP THREADPRIVATE(lev_out)
+
+      INTEGER ig,k,l,ll
+      real zsortie1d(klon)
+      INTEGER lmax(klon),lmin(klon),lalim(klon)
+      INTEGER lmix(klon)
+      INTEGER lmix_bis(klon)
+      real linter(klon)
+      real zmix(klon)
+      real zmax(klon),zw2(klon,klev+1),ztva(klon,klev),zw_est(klon,klev+1)
+!      real fraca(klon,klev)
+
+      real zmax_sec(klon)
+!on garde le zmax du pas de temps precedent
+      real zmax0(klon)
+!FH/IM     save zmax0
+
+      real lambda
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      real deltaz(klon,klev)
+      REAL zh(klon,klev)
+      real zthl(klon,klev),zdthladj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      real zl(klon,klev)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zta(klon,klev)
+      real zha(klon,klev)
+      real fraca(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev),wth3(klon,klev)
+      real q2(klon,klev)
+! FH probleme de dimensionnement avec l'allocation dynamique
+!     common/comtherm/thetath2,wth2
+    
+      real ratqscth(klon,klev)
+      real var
+      real vardiff
+      real ratqsdiff(klon,klev)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+      real wmax(klon)
+      real wmax_sec(klon)
+      real fm0(klon,klev+1),entr0(klon,klev),detr0(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev),detr(klon,klev)
+
+      real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev)
+!niveau de condensation
+      integer nivcon(klon)
+      real zcon(klon)
+      REAL CHI
+      real zcon2(klon)
+      real pcon(klon)
+      real zqsat(klon,klev)
+      real zqsatth(klon,klev) 
+
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real detr_star(klon,klev)
+      real alim_star_tot(klon),alim_star2(klon)
+      real alim_star(klon,klev)
+      real f(klon), f0(klon)
+!FH/IM     save f0
+      real zlevinter(klon)
+      logical debut
+       real seuil
+
+! Declaration uniquement pour les sorties dans thermcell_out3d.
+! Inutilise en 3D
+      real wthl(klon,klev)
+      real wthv(klon,klev)
+      real wq(klon,klev)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+!
+      !nouvelles variables pour la convection
+      real Ale_bl(klon)
+      real Alp_bl(klon)
+      real alp_int(klon)
+      real ale_int(klon)
+      integer n_int(klon)
+      real fm_tot(klon)
+      real wght_th(klon,klev)
+      integer lalim_conv(klon)
+!v1d     logical therm
+!v1d     save therm
+
+      character*2 str2
+      character*10 str10
+
+      character (len=20) :: modname='thermcellV0_main'
+      character (len=80) :: abort_message
+
+      EXTERNAL SCOPY
+!
+
+!-----------------------------------------------------------------------
+!   initialisation:
+!   ---------------
+!
+
+      seuil=0.25
+
+      if (debut)  then
+         fm0=0.
+         entr0=0.
+         detr0=0.
+
+
+#undef wrgrads_thermcell
+#ifdef wrgrads_thermcell
+! Initialisation des sorties grads pour les thermiques.
+! Pour l'instant en 1D sur le point igout.
+! Utilise par thermcell_out3d.h
+         str10='therm'
+         call inigrads(1,1,rlond(igout),1.,-180.,180.,jjm, &
+     &   rlatd(igout),-90.,90.,1.,llm,pplay(igout,:),1.,   &
+     &   ptimestep,str10,'therm ')
+#endif
+
+
+
+      endif
+
+      fm=0. ; entr=0. ; detr=0.
+
+      icount=icount+1
+
+!IM 090508 beg
+!print*,'====================================================================='
+!print*,'====================================================================='
+!print*,' PAS ',icount,' PAS ',icount,' PAS ',icount,' PAS ',icount
+!print*,'====================================================================='
+!print*,'====================================================================='
+!IM 090508 end
+
+      if (prt_level.ge.1) print*,'thermcell_main V4'
+
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+!
+!Initialisation
+!
+     if (prt_level.ge.10)write(lunout,*)                                &
+    &     'WARNING thermcell_main f0=max(f0,1.e-2)'
+     do ig=1,klon
+         f0(ig)=max(f0(ig),1.e-2)
+     enddo
+
+!-----------------------------------------------------------------------
+! Calcul de T,q,ql a partir de Tl et qT dans l environnement
+!   --------------------------------------------------------------------
+!
+      CALL thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay,  &
+     &           pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lev_out)
+       
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_env'
+
+!------------------------------------------------------------------------
+!                       --------------------
+!
+!
+!                       + + + + + + + + + + +
+!
+!
+!  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+!  wh,wt,wo ...
+!
+!                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+!
+!
+!                       --------------------   zlev(1)
+!                       \\\\\\\\\\\\\\\\\\\\
+!
+!
+
+!-----------------------------------------------------------------------
+!   Calcul des altitudes des couches
+!-----------------------------------------------------------------------
+
+      do l=2,nlay
+         zlev(:,l)=0.5*(pphi(:,l)+pphi(:,l-1))/RG
+      enddo
+         zlev(:,1)=0.
+         zlev(:,nlay+1)=(2.*pphi(:,klev)-pphi(:,klev-1))/RG
+      do l=1,nlay
+         zlay(:,l)=pphi(:,l)/RG
+      enddo
+!calcul de l epaisseur des couches
+      do l=1,nlay
+         deltaz(:,l)=zlev(:,l+1)-zlev(:,l)
+      enddo
+
+!     print*,'2 OK convect8'
+!-----------------------------------------------------------------------
+!   Calcul des densites
+!-----------------------------------------------------------------------
+
+      do l=1,nlay
+         rho(:,l)=pplay(:,l)/(zpspsk(:,l)*RD*ztv(:,l))
+      enddo
+
+!IM
+     if (prt_level.ge.10)write(lunout,*)                                &
+    &    'WARNING thermcell_main rhobarz(:,1)=rho(:,1)'
+      rhobarz(:,1)=rho(:,1)
+
+      do l=2,nlay
+         rhobarz(:,l)=0.5*(rho(:,l)+rho(:,l-1))
+      enddo
+
+!calcul de la masse
+      do l=1,nlay
+         masse(:,l)=(pplev(:,l)-pplev(:,l+1))/RG
+      enddo
+
+      if (prt_level.ge.1) print*,'thermcell_main apres initialisation'
+
+!------------------------------------------------------------------
+!
+!             /|\
+!    --------  |  F_k+1 -------   
+!                              ----> D_k
+!             /|\              <---- E_k , A_k
+!    --------  |  F_k --------- 
+!                              ----> D_k-1
+!                              <---- E_k-1 , A_k-1
+!
+!
+!
+!
+!
+!    ---------------------------
+!
+!    ----- F_lmax+1=0 ----------         \
+!            lmax     (zmax)              |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |  E
+!    ---------------------------          |  D
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------  \       |
+!            lalim                 |      |
+!    ---------------------------   |      |
+!                                  |      |
+!    ---------------------------   |      |
+!                                  | A    |
+!    ---------------------------   |      |
+!                                  |      |
+!    ---------------------------   |      |
+!    lmin  (=1 pour le moment)     |      |
+!    ----- F_lmin=0 ------------  /      /
+!
+!    ---------------------------
+!    //////////////////////////
+!
+!
+!=============================================================================
+!  Calculs initiaux ne faisant pas intervenir les changements de phase
+!=============================================================================
+
+!------------------------------------------------------------------
+!  1. alim_star est le profil vertical de l'alimentation à la base du
+!     panache thermique, calculé à partir de la flotabilité de l'air sec
+!  2. lmin et lalim sont les indices inferieurs et superieurs de alim_star
+!------------------------------------------------------------------
+!
+      entr_star=0. ; detr_star=0. ; alim_star=0. ; alim_star_tot=0.
+      CALL thermcellV0_init(ngrid,nlay,ztv,zlay,zlev,  &
+     &                    lalim,lmin,alim_star,alim_star_tot,lev_out)
+
+call testV0_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_init lmin  ')
+call testV0_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_init lalim ')
+
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_init'
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_main 1'
+         write(lunout1,*) 'lmin ',lmin(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) ' ig l alim_star thetav'
+         write(lunout1,'(i6,i4,2e15.5)') (igout,l,alim_star(igout,l) &
+     &   ,ztv(igout,l),l=1,lalim(igout)+4)
+      endif
+
+!v1d      do ig=1,klon
+!v1d     if (alim_star(ig,1).gt.1.e-10) then
+!v1d     therm=.true.
+!v1d     endif
+!v1d      enddo
+!-----------------------------------------------------------------------------
+!  3. wmax_sec et zmax_sec sont les vitesses et altitudes maximum d'un
+!     panache sec conservatif (e=d=0) alimente selon alim_star 
+!     Il s'agit d'un calcul de type CAPE
+!     zmax_sec est utilisé pour déterminer la géométrie du thermique.
+!------------------------------------------------------------------------------
+!
+      CALL thermcellV0_dry(ngrid,nlay,zlev,pphi,ztv,alim_star,  &
+     &                      lalim,lmin,zmax_sec,wmax_sec,lev_out)
+
+call testV0_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry  lmin  ')
+call testV0_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry  lalim ')
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_dry'
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_main 1b'
+         write(lunout1,*) 'lmin ',lmin(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) ' ig l alim_star entr_star detr_star f_star '
+         write(lunout1,'(i6,i4,e15.5)') (igout,l,alim_star(igout,l) &
+     &    ,l=1,lalim(igout)+4)
+      endif
+
+
+
+!---------------------------------------------------------------------------------
+!calcul du melange et des variables dans le thermique
+!--------------------------------------------------------------------------------
+!
+      if (prt_level.ge.1) print*,'avant thermcell_plume ',lev_out
+!IM 140508   CALL thermcell_plume(ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,  &
+      CALL thermcellV0_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,  &
+     &           zlev,pplev,pphi,zpspsk,l_mix,r_aspect,alim_star,alim_star_tot,  &
+     &           lalim,zmax_sec,f0,detr_star,entr_star,f_star,ztva,  &
+     &           ztla,zqla,zqta,zha,zw2,zw_est,zqsatth,lmix,lmix_bis,linter &
+     &            ,lev_out,lunout1,igout)
+      if (prt_level.ge.1) print*,'apres thermcell_plume ',lev_out
+
+      call testV0_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lalim ')
+      call testV0_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lmix  ')
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_plume'
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_main 2'
+         write(lunout1,*) 'lmin ',lmin(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) ' ig l alim_star entr_star detr_star f_star '
+         write(lunout1,'(i6,i4,4e15.5)') (igout,l,alim_star(igout,l),entr_star(igout,l),detr_star(igout,l) &
+     &    ,f_star(igout,l+1),l=1,nint(linter(igout))+5)
+      endif
+
+!-------------------------------------------------------------------------------
+! Calcul des caracteristiques du thermique:zmax,zmix,wmax
+!-------------------------------------------------------------------------------
+!
+      CALL thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,zw2,  &
+     &           zlev,lmax,zmax,zmax0,zmix,wmax,lev_out)
+
+
+      call testV0_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lalim ')
+      call testV0_ltherm(ngrid,nlay,pplev,pplay,lmin ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmin  ')
+      call testV0_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmix  ')
+      call testV0_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmax  ')
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_height'
+
+!-------------------------------------------------------------------------------
+! Fermeture,determination de f
+!-------------------------------------------------------------------------------
+!
+!avant closure: on redéfinit lalim, alim_star_tot et alim_star
+!       do ig=1,klon
+!       do l=2,lalim(ig)
+!       alim_star(ig,l)=entr_star(ig,l)
+!       entr_star(ig,l)=0.
+!       enddo
+!       enddo
+
+      CALL thermcellV0_closure(ngrid,nlay,r_aspect,ptimestep,rho,  &
+     &   zlev,lalim,alim_star,alim_star_tot,zmax_sec,wmax_sec,zmax,wmax,f,lev_out)
+
+      if(prt_level.ge.1)print*,'thermcell_closure apres thermcell_closure'
+
+      if (tau_thermals>1.) then
+         lambda=exp(-ptimestep/tau_thermals)
+         f0=(1.-lambda)*f+lambda*f0
+      else
+         f0=f
+      endif
+
+! Test valable seulement en 1D mais pas genant
+      if (.not. (f0(1).ge.0.) ) then
+        abort_message = 'Dans thermcell_main f0(1).lt.0 '
+        CALL abort_gcm (modname,abort_message,1)
+      endif
+
+!-------------------------------------------------------------------------------
+!deduction des flux
+!-------------------------------------------------------------------------------
+
+      CALL thermcell_flux2(ngrid,nlay,ptimestep,masse, &
+     &       lalim,lmax,alim_star,  &
+     &       entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr,  &
+     &       detr,zqla,lev_out,lunout1,igout)
+!IM 060508    &       detr,zqla,zmax,lev_out,lunout,igout)
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_flux'
+      call testV0_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lalim ')
+      call testV0_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lmax  ')
+
+!------------------------------------------------------------------
+!   On ne prend pas directement les profils issus des calculs precedents
+!   mais on s'autorise genereusement une relaxation vers ceci avec
+!   une constante de temps tau_thermals (typiquement 1800s).
+!------------------------------------------------------------------
+
+      if (tau_thermals>1.) then
+         lambda=exp(-ptimestep/tau_thermals)
+         fm0=(1.-lambda)*fm+lambda*fm0
+         entr0=(1.-lambda)*entr+lambda*entr0
+!        detr0=(1.-lambda)*detr+lambda*detr0
+      else
+         fm0=fm
+         entr0=entr
+         detr0=detr
+      endif
+
+!c------------------------------------------------------------------
+!   calcul du transport vertical
+!------------------------------------------------------------------
+
+      call thermcell_dq(ngrid,nlay,1,ptimestep,fm0,entr0,masse,  &
+     &                    zthl,zdthladj,zta,lev_out)
+      call thermcell_dq(ngrid,nlay,1,ptimestep,fm0,entr0,masse,  &
+     &                   po,pdoadj,zoa,lev_out)
+
+!------------------------------------------------------------------
+! Calcul de la fraction de l'ascendance
+!------------------------------------------------------------------
+      do ig=1,klon
+         fraca(ig,1)=0.
+         fraca(ig,nlay+1)=0.
+      enddo
+      do l=2,nlay
+         do ig=1,klon
+            if (zw2(ig,l).gt.1.e-10) then
+            fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l))
+            else
+            fraca(ig,l)=0.
+            endif
+         enddo
+      enddo
+     
+!------------------------------------------------------------------
+!  calcul du transport vertical du moment horizontal
+!------------------------------------------------------------------
+
+!IM 090508  
+      if (1.eq.1) then
+!IM 070508 vers. _dq       
+!     if (1.eq.0) then
+
+
+! Calcul du transport de V tenant compte d'echange par gradient
+! de pression horizontal avec l'environnement
+
+         call thermcell_dv2(ngrid,nlay,ptimestep,fm0,entr0,masse  &
+     &    ,fraca,zmax  &
+     &    ,zu,zv,pduadj,pdvadj,zua,zva,lev_out)
+!IM 050508    &    ,zu,zv,pduadj,pdvadj,zua,zva,igout,lev_out)
+      else
+
+! calcul purement conservatif pour le transport de V
+         call thermcell_dq(ngrid,nlay,1,ptimestep,fm0,entr0,masse  &
+     &    ,zu,pduadj,zua,lev_out)
+         call thermcell_dq(ngrid,nlay,1,ptimestep,fm0,entr0,masse  &
+     &    ,zv,pdvadj,zva,lev_out)
+      endif
+
+!     print*,'13 OK convect8'
+      do l=1,nlay
+         do ig=1,ngrid
+           pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l)  
+         enddo
+      enddo
+
+      if (prt_level.ge.1) print*,'14 OK convect8'
+!------------------------------------------------------------------
+!   Calculs de diagnostiques pour les sorties
+!------------------------------------------------------------------
+!calcul de fraca pour les sorties
+      
+      if (sorties) then
+      if (prt_level.ge.1) print*,'14a OK convect8'
+! calcul du niveau de condensation
+! initialisation
+      do ig=1,ngrid
+         nivcon(ig)=0
+         zcon(ig)=0.
+      enddo 
+!nouveau calcul
+      do ig=1,ngrid
+      CHI=zh(ig,1)/(1669.0-122.0*zo(ig,1)/zqsat(ig,1)-zh(ig,1))
+      pcon(ig)=pplay(ig,1)*(zo(ig,1)/zqsat(ig,1))**CHI
+      enddo
+!IM   do k=1,nlay
+      do k=1,nlay-1
+         do ig=1,ngrid
+         if ((pcon(ig).le.pplay(ig,k))  &
+     &      .and.(pcon(ig).gt.pplay(ig,k+1))) then
+            zcon2(ig)=zlay(ig,k)-(pcon(ig)-pplay(ig,k))/(RG*rho(ig,k))/100.
+         endif
+         enddo
+      enddo
+!IM
+      do ig=1,ngrid
+        if (pcon(ig).le.pplay(ig,nlay)) then 
+           zcon2(ig)=zlay(ig,nlay)-(pcon(ig)-pplay(ig,nlay))/(RG*rho(ig,nlay))/100.
+           abort_message = 'thermcellV0_main: les thermiques vont trop haut '
+           CALL abort_gcm (modname,abort_message,1)
+        endif
+      enddo
+      if (prt_level.ge.1) print*,'14b OK convect8'
+      do k=nlay,1,-1
+         do ig=1,ngrid
+            if (zqla(ig,k).gt.1e-10) then
+               nivcon(ig)=k
+               zcon(ig)=zlev(ig,k)
+            endif
+         enddo
+      enddo
+      if (prt_level.ge.1) print*,'14c OK convect8'
+!calcul des moments
+!initialisation
+      do l=1,nlay
+         do ig=1,ngrid
+            q2(ig,l)=0.
+            wth2(ig,l)=0.
+            wth3(ig,l)=0.
+            ratqscth(ig,l)=0.
+            ratqsdiff(ig,l)=0.
+         enddo
+      enddo      
+      if (prt_level.ge.1) print*,'14d OK convect8'
+      if (prt_level.ge.10)write(lunout,*)                                &
+    &     'WARNING thermcell_main wth2=0. si zw2 > 1.e-10'
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=fraca(ig,l)
+            zf2=zf/(1.-zf)
+!
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2
+            if(zw2(ig,l).gt.1.e-10) then
+             wth2(ig,l)=zf2*(zw2(ig,l))**2
+            else
+             wth2(ig,l)=0.
+            endif
+!           print*,'wth2=',wth2(ig,l)
+            wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l))  &
+     &                *zw2(ig,l)*zw2(ig,l)*zw2(ig,l)
+            q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+!test: on calcul q2/po=ratqsc
+            ratqscth(ig,l)=sqrt(max(q2(ig,l),1.e-6)/(po(ig,l)*1000.))
+         enddo
+      enddo
+
+      if (prt_level.ge.10) then
+          print*,'14e OK convect8 ig,l,zf,zf2',ig,l,zf,zf2
+          ig=igout
+          do l=1,nlay
+             print*,'14f OK convect8 ig,l,zha zh zpspsk ',ig,l,zha(ig,l),zh(ig,l),zpspsk(ig,l)
+          enddo
+          do l=1,nlay
+             print*,'14g OK convect8 ig,l,po',ig,l,po(ig,l)
+          enddo
+      endif
+
+      do ig=1,ngrid
+      alp_int(ig)=0.
+      ale_int(ig)=0.
+      n_int(ig)=0
+      enddo
+!
+      do l=1,nlay
+      do ig=1,ngrid
+       if(l.LE.lmax(ig)) THEN
+        alp_int(ig)=alp_int(ig)+0.5*rhobarz(ig,l)*wth3(ig,l)
+        ale_int(ig)=ale_int(ig)+0.5*zw2(ig,l)**2
+        n_int(ig)=n_int(ig)+1
+       endif
+      enddo
+      enddo
+!      print*,'avant calcul ale et alp' 
+!calcul de ALE et ALP pour la convection
+      do ig=1,ngrid
+!      Alp_bl(ig)=0.5*rhobarz(ig,lmix_bis(ig))*wth3(ig,lmix(ig))
+!          Alp_bl(ig)=0.5*rhobarz(ig,nivcon(ig))*wth3(ig,nivcon(ig))
+!      Alp_bl(ig)=0.5*rhobarz(ig,lmix(ig))*wth3(ig,lmix(ig)) 
+!     &           *0.1
+!valeur integree de alp_bl * 0.5:
+       if (n_int(ig).gt.0) then
+       Alp_bl(ig)=0.5*alp_int(ig)/n_int(ig)
+!       if (Alp_bl(ig).lt.0.) then
+!       Alp_bl(ig)=0.
+       endif
+!       endif
+!         write(18,*),'rhobarz,wth3,Alp',rhobarz(ig,nivcon(ig)),
+!     s               wth3(ig,nivcon(ig)),Alp_bl(ig)
+!            write(18,*),'ALP_BL',Alp_bl(ig),lmix(ig)
+!      Ale_bl(ig)=0.5*zw2(ig,lmix_bis(ig))**2
+!      if (nivcon(ig).eq.1) then
+!       Ale_bl(ig)=0.
+!       else
+!valeur max de ale_bl:
+       Ale_bl(ig)=0.5*zw2(ig,lmix(ig))**2 
+!     & /2.
+!     & *0.1
+!        Ale_bl(ig)=0.5*zw2(ig,lmix_bis(ig))**2 
+!       if (n_int(ig).gt.0) then
+!       Ale_bl(ig)=ale_int(ig)/n_int(ig)
+!        Ale_bl(ig)=4.
+!       endif
+!       endif
+!            Ale_bl(ig)=0.5*wth2(ig,lmix_bis(ig))
+!          Ale_bl(ig)=wth2(ig,nivcon(ig))
+!          write(19,*),'wth2,ALE_BL',wth2(ig,nivcon(ig)),Ale_bl(ig)
+      enddo
+!test:calcul de la ponderation des couches pour KE
+!initialisations
+!      print*,'ponderation'
+      do ig=1,ngrid
+           fm_tot(ig)=0.
+      enddo
+       do ig=1,ngrid
+        do k=1,klev
+           wght_th(ig,k)=1.
+        enddo
+       enddo
+       do ig=1,ngrid
+!         lalim_conv(ig)=lmix_bis(ig)
+!la hauteur de la couche alim_conv = hauteur couche alim_therm
+         lalim_conv(ig)=lalim(ig)
+!         zentr(ig)=zlev(ig,lalim(ig))
+      enddo
+      do ig=1,ngrid
+        do k=1,lalim_conv(ig)
+           fm_tot(ig)=fm_tot(ig)+fm(ig,k)
+        enddo
+      enddo
+      do ig=1,ngrid
+        do k=1,lalim_conv(ig)
+           if (fm_tot(ig).gt.1.e-10) then
+!           wght_th(ig,k)=fm(ig,k)/fm_tot(ig)
+           endif
+!on pondere chaque couche par a*
+             if (alim_star(ig,k).gt.1.e-10) then
+             wght_th(ig,k)=alim_star(ig,k)
+             else
+             wght_th(ig,k)=1.
+             endif
+        enddo
+      enddo
+!      print*,'apres wght_th'
+!test pour prolonger la convection
+      do ig=1,ngrid
+!v1d  if ((alim_star(ig,1).lt.1.e-10).and.(therm)) then
+      if ((alim_star(ig,1).lt.1.e-10)) then
+      lalim_conv(ig)=1
+      wght_th(ig,1)=1.
+!      print*,'lalim_conv ok',lalim_conv(ig),wght_th(ig,1)
+      endif
+      enddo
+
+!calcul du ratqscdiff
+      if (prt_level.ge.1) print*,'14e OK convect8'
+      var=0.
+      vardiff=0.
+      ratqsdiff(:,:)=0.
+      do ig=1,ngrid
+         do l=1,lalim(ig)
+            var=var+alim_star(ig,l)*zqta(ig,l)*1000.
+         enddo
+      enddo
+      if (prt_level.ge.1) print*,'14f OK convect8'
+      do ig=1,ngrid
+          do l=1,lalim(ig)
+          zf=fraca(ig,l)
+          zf2=zf/(1.-zf)
+          vardiff=vardiff+alim_star(ig,l)  &
+     &           *(zqta(ig,l)*1000.-var)**2
+!         ratqsdiff=ratqsdiff+alim_star(ig,l)*
+!     s          (zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+          enddo
+      enddo
+      if (prt_level.ge.1) print*,'14g OK convect8'
+      do l=1,nlay
+         do ig=1,ngrid
+            ratqsdiff(ig,l)=sqrt(vardiff)/(po(ig,l)*1000.)   
+!           write(11,*)'ratqsdiff=',ratqsdiff(ig,l)
+         enddo
+      enddo 
+!--------------------------------------------------------------------    
+!
+!ecriture des fichiers sortie
+!     print*,'15 OK convect8'
+
+      if (prt_level.ge.1) print*,'thermcell_main sorties 3D'
+#ifdef wrgrads_thermcell
+#include "thermcell_out3d.h"
+#endif
+
+      endif
+
+      if (prt_level.ge.1) print*,'thermcell_main FIN  OK'
+
+!     if(icount.eq.501) stop'au pas 301 dans thermcell_main'
+      return
+      end
+
+!-----------------------------------------------------------------------------
+
+      subroutine testV0_ltherm(klon,klev,pplev,pplay,long,seuil,ztv,po,ztva,zqla,f_star,zw2,comment)
+      IMPLICIT NONE
+#include "iniprint.h"
+
+      integer i, k, klon,klev
+      real pplev(klon,klev+1),pplay(klon,klev)
+      real ztv(klon,klev)
+      real po(klon,klev)
+      real ztva(klon,klev)
+      real zqla(klon,klev)
+      real f_star(klon,klev)
+      real zw2(klon,klev)
+      integer long(klon)
+      real seuil
+      character*21 comment
+
+      if (prt_level.ge.1) THEN
+       print*,'WARNING !!! TEST ',comment
+      endif
+      return
+
+!  test sur la hauteur des thermiques ...
+         do i=1,klon
+!IMtemp           if (pplay(i,long(i)).lt.seuil*pplev(i,1)) then
+           if (prt_level.ge.10) then
+               print*,'WARNING ',comment,' au point ',i,' K= ',long(i)
+               print*,'  K  P(MB)  THV(K)     Qenv(g/kg)THVA        QLA(g/kg)   F*        W2'
+               do k=1,klev
+                  write(6,'(i3,7f10.3)') k,pplay(i,k),ztv(i,k),1000*po(i,k),ztva(i,k),1000*zqla(i,k),f_star(i,k),zw2(i,k)
+               enddo
+           endif
+         enddo
+
+
+      return
+      end
+
+!==============================================================================
+      SUBROUTINE thermcellV0_closure(ngrid,nlay,r_aspect,ptimestep,rho,  &
+     &   zlev,lalim,alim_star,alim_star_tot,zmax_sec,wmax_sec,zmax,wmax,f,lev_out)
+
+!-------------------------------------------------------------------------
+!thermcell_closure: fermeture, determination de f
+!-------------------------------------------------------------------------
+      IMPLICIT NONE
+
+#include "iniprint.h"
+#include "thermcell.h"
+      INTEGER ngrid,nlay
+      INTEGER ig,k       
+      REAL r_aspect,ptimestep
+      integer lev_out                           ! niveau pour les print
+
+      INTEGER lalim(ngrid)
+      REAL alim_star(ngrid,nlay)
+      REAL alim_star_tot(ngrid)
+      REAL rho(ngrid,nlay)
+      REAL zlev(ngrid,nlay)
+      REAL zmax(ngrid),zmax_sec(ngrid)
+      REAL wmax(ngrid),wmax_sec(ngrid)
+      real zdenom
+
+      REAL alim_star2(ngrid)
+
+      REAL f(ngrid)
+
+      character (len=20) :: modname='thermcellV0_main'
+      character (len=80) :: abort_message
+
+      do ig=1,ngrid
+         alim_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (alim_star(ig,1).LT.1.e-10) then
+            f(ig)=0.
+         else   
+             do k=1,lalim(ig)
+                alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2  &
+     &                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+             zdenom=max(500.,zmax(ig))*r_aspect*alim_star2(ig)
+             if (zdenom<1.e-14) then
+                print*,'ig=',ig
+                print*,'alim_star2',alim_star2(ig)
+                print*,'zmax',zmax(ig)
+                print*,'r_aspect',r_aspect
+                print*,'zdenom',zdenom
+                print*,'alim_star',alim_star(ig,:)
+                print*,'zmax_sec',zmax_sec(ig)
+                print*,'wmax_sec',wmax_sec(ig)
+                abort_message = 'zdenom<1.e-14'
+                CALL abort_gcm (modname,abort_message,1)
+             endif
+             if ((zmax_sec(ig).gt.1.e-10).and.(iflag_thermals_ed.eq.0)) then 
+             f(ig)=wmax_sec(ig)*alim_star_tot(ig)/(max(500.,zmax_sec(ig))*r_aspect  &
+     &             *alim_star2(ig))
+!            f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/  &
+!    &                     zmax_sec(ig))*wmax_sec(ig))
+             if(prt_level.GE.10) write(lunout,*)'closure dry',f(ig),wmax_sec(ig),alim_star_tot(ig),zmax_sec(ig)
+             else
+             f(ig)=wmax(ig)*alim_star_tot(ig)/zdenom
+!            f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/  &
+!     &                     zmax(ig))*wmax(ig))
+             if(prt_level.GE.10) print*,'closure moist',f(ig),wmax(ig),alim_star_tot(ig),zmax(ig)
+             endif
+         endif
+!         f0(ig)=f(ig)
+      enddo
+      if (prt_level.ge.1) print*,'apres fermeture'
+
+!
+      return
+      end
+!==============================================================================
+      SUBROUTINE thermcellV0_plume(itap,ngrid,klev,ptimestep,ztv,zthl,po,zl,rhobarz,  &
+     &           zlev,pplev,pphi,zpspsk,l_mix,r_aspect,alim_star,alim_star_tot,  &
+     &           lalim,zmax_sec,f0,detr_star,entr_star,f_star,ztva,  &
+     &           ztla,zqla,zqta,zha,zw2,w_est,zqsatth,lmix,lmix_bis,linter &
+     &           ,lev_out,lunout1,igout)
+
+!--------------------------------------------------------------------------
+!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance
+!--------------------------------------------------------------------------
+
+      IMPLICIT NONE
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+#include "iniprint.h"
+#include "thermcell.h"
+
+      INTEGER itap
+      INTEGER lunout1,igout
+      INTEGER ngrid,klev
+      REAL ptimestep
+      REAL ztv(ngrid,klev)
+      REAL zthl(ngrid,klev)
+      REAL po(ngrid,klev)
+      REAL zl(ngrid,klev)
+      REAL rhobarz(ngrid,klev)
+      REAL zlev(ngrid,klev+1)
+      REAL pplev(ngrid,klev+1)
+      REAL pphi(ngrid,klev)
+      REAL zpspsk(ngrid,klev)
+      REAL alim_star(ngrid,klev)
+      REAL zmax_sec(ngrid)
+      REAL f0(ngrid)
+      REAL l_mix
+      REAL r_aspect
+      INTEGER lalim(ngrid)
+      integer lev_out                           ! niveau pour les print
+      real zcon2(ngrid)
+    
+      real alim_star_tot(ngrid)
+
+      REAL ztva(ngrid,klev)
+      REAL ztla(ngrid,klev)
+      REAL zqla(ngrid,klev)
+      REAL zqla0(ngrid,klev)
+      REAL zqta(ngrid,klev)
+      REAL zha(ngrid,klev)
+
+      REAL detr_star(ngrid,klev)
+      REAL coefc
+      REAL detr_stara(ngrid,klev)
+      REAL detr_starb(ngrid,klev)
+      REAL detr_starc(ngrid,klev)
+      REAL detr_star0(ngrid,klev)
+      REAL detr_star1(ngrid,klev)
+      REAL detr_star2(ngrid,klev)
+
+      REAL entr_star(ngrid,klev)
+      REAL entr_star1(ngrid,klev)
+      REAL entr_star2(ngrid,klev)
+      REAL detr(ngrid,klev)
+      REAL entr(ngrid,klev)
+
+      REAL zw2(ngrid,klev+1)
+      REAL w_est(ngrid,klev+1)
+      REAL f_star(ngrid,klev+1)
+      REAL wa_moy(ngrid,klev+1)
+
+      REAL ztva_est(ngrid,klev)
+      REAL zqla_est(ngrid,klev)
+      REAL zqsatth(ngrid,klev)
+      REAL zta_est(ngrid,klev)
+
+      REAL linter(ngrid)
+      INTEGER lmix(ngrid)
+      INTEGER lmix_bis(ngrid)
+      REAL    wmaxa(ngrid)
+
+      INTEGER ig,l,k
+
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef,qsatbef
+      real dqsat_dT,DT,num,denom
+      REAL REPS,RLvCp,DDT0
+      PARAMETER (DDT0=.01)
+      logical Zsat
+      REAL fact_gamma,fact_epsilon
+      REAL c2(ngrid,klev)
+
+      Zsat=.false.
+! Initialisation
+      RLvCp = RLVTT/RCPD
+     
+      if (iflag_thermals_ed==0) then
+         fact_gamma=1.
+         fact_epsilon=1.
+      else if (iflag_thermals_ed==1)  then
+         fact_gamma=1.
+         fact_epsilon=1.
+      else if (iflag_thermals_ed==2)  then
+         fact_gamma=1.
+         fact_epsilon=2.
+      endif
+
+      do l=1,klev
+         do ig=1,ngrid
+            zqla_est(ig,l)=0.
+            ztva_est(ig,l)=ztva(ig,l)
+            zqsatth(ig,l)=0.
+         enddo
+      enddo
+
+!CR: attention test couche alim
+!     do l=2,klev
+!     do ig=1,ngrid
+!        alim_star(ig,l)=0.
+!     enddo
+!     enddo
+!AM:initialisations du thermique
+      do k=1,klev
+         do ig=1,ngrid
+            ztva(ig,k)=ztv(ig,k)
+            ztla(ig,k)=zthl(ig,k)
+            zqla(ig,k)=0.
+            zqta(ig,k)=po(ig,k)
+!
+            ztva(ig,k) = ztla(ig,k)*zpspsk(ig,k)+RLvCp*zqla(ig,k)
+            ztva(ig,k) = ztva(ig,k)/zpspsk(ig,k)
+            zha(ig,k) = ztva(ig,k)
+!
+         enddo
+      enddo 
+      do k=1,klev
+        do ig=1,ngrid
+           detr_star(ig,k)=0.
+           entr_star(ig,k)=0.
+
+           detr_stara(ig,k)=0.
+           detr_starb(ig,k)=0.
+           detr_starc(ig,k)=0.
+           detr_star0(ig,k)=0.
+           zqla0(ig,k)=0.
+           detr_star1(ig,k)=0.
+           detr_star2(ig,k)=0.
+           entr_star1(ig,k)=0.
+           entr_star2(ig,k)=0.
+
+           detr(ig,k)=0.
+           entr(ig,k)=0.
+        enddo
+      enddo
+      if (prt_level.ge.1) print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            w_est(ig,k)=0.
+            f_star(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+      if (prt_level.ge.1) print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmix(ig)=1
+         lmix_bis(ig)=2
+         wmaxa(ig)=0.
+      enddo
+
+!-----------------------------------------------------------------------------------
+!boucle de calcul de la vitesse verticale dans le thermique
+!-----------------------------------------------------------------------------------
+      do l=1,klev-1
+         do ig=1,ngrid
+
+
+
+! Calcul dans la premiere couche active du thermique (ce qu'on teste
+! en disant que la couche est instable et que w2 en bas de la couche
+! est nulle.
+
+            if (ztv(ig,l).gt.ztv(ig,l+1)  &
+     &         .and.alim_star(ig,l).gt.1.e-10  &
+     &         .and.zw2(ig,l).lt.1e-10) then
+
+
+! Le panache va prendre au debut les caracteristiques de l'air contenu
+! dans cette couche.
+               ztla(ig,l)=zthl(ig,l) 
+               zqta(ig,l)=po(ig,l)
+               zqla(ig,l)=zl(ig,l)
+               f_star(ig,l+1)=alim_star(ig,l)
+
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)  &
+     &                     *(zlev(ig,l+1)-zlev(ig,l))  &
+     &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               w_est(ig,l+1)=zw2(ig,l+1)
+!
+
+
+            else if ((zw2(ig,l).ge.1e-10).and.  &
+     &         (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then
+!estimation du detrainement a partir de la geometrie du pas precedent
+!tests sur la definition du detr
+!calcul de detr_star et entr_star
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH le test miraculeux de Catherine ? Le bout du tunel ?
+!               w_est(ig,3)=zw2(ig,2)*  &
+!    &                   ((f_star(ig,2))**2)  &
+!    &                   /(f_star(ig,2)+alim_star(ig,2))**2+  &
+!    &                   2.*RG*(ztva(ig,1)-ztv(ig,2))/ztv(ig,2)  &
+!    &                   *(zlev(ig,3)-zlev(ig,2))
+!     if (l.gt.2) then
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+
+! Premier calcul de la vitesse verticale a partir de la temperature
+! potentielle virtuelle
+
+! FH CESTQUOI CA ????
+#define int1d2
+!#undef int1d2
+#ifdef int1d2
+      if (l.ge.2) then
+#else
+      if (l.gt.2) then
+#endif
+
+      if (1.eq.1) then
+          w_est(ig,3)=zw2(ig,2)* &
+     &      ((f_star(ig,2))**2) &
+     &      /(f_star(ig,2)+alim_star(ig,2))**2+ &
+     &      2.*RG*(ztva(ig,2)-ztv(ig,2))/ztv(ig,2) &
+!     &      *1./3. &
+     &      *(zlev(ig,3)-zlev(ig,2))
+       endif
+
+
+!---------------------------------------------------------------------------
+!calcul de l entrainement et du detrainement lateral
+!---------------------------------------------------------------------------
+!
+!test:estimation de ztva_new_est sans entrainement
+
+               Tbef=ztla(ig,l-1)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+               qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)
+               qsatbef=MIN(0.5,qsatbef)
+               zcor=1./(1.-retv*qsatbef)
+               qsatbef=qsatbef*zcor
+               Zsat = (max(0.,zqta(ig,l-1)-qsatbef) .gt. 1.e-10)
+               if (Zsat) then
+               qlbef=max(0.,zqta(ig,l-1)-qsatbef)
+               DT = 0.5*RLvCp*qlbef
+               do while (abs(DT).gt.DDT0)
+                 Tbef=Tbef+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+                 qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)
+                 qsatbef=MIN(0.5,qsatbef)
+                 zcor=1./(1.-retv*qsatbef)
+                 qsatbef=qsatbef*zcor
+                 qlbef=zqta(ig,l-1)-qsatbef
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef)
+                 dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor)
+                 num=-Tbef+ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 DT=num/denom
+               enddo
+                 zqla_est(ig,l) = max(0.,zqta(ig,l-1)-qsatbef) 
+               endif
+        ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l)
+        ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l)
+        zta_est(ig,l)=ztva_est(ig,l)
+        ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1)  &
+     &      -zqla_est(ig,l))-zqla_est(ig,l))
+
+             w_est(ig,l+1)=zw2(ig,l)*  &
+     &                   ((f_star(ig,l))**2)  &
+     &                   /(f_star(ig,l)+alim_star(ig,l))**2+  &
+     &                   2.*RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+!     &                   *1./3. &
+     &                   *(zlev(ig,l+1)-zlev(ig,l))
+             if (w_est(ig,l+1).lt.0.) then
+                w_est(ig,l+1)=zw2(ig,l)
+             endif
+!
+!calcul du detrainement
+!=======================
+
+!CR:on vire les modifs
+         if (iflag_thermals_ed==0) then
+
+! Modifications du calcul du detrainement.
+! Dans la version de la these de Catherine, on passe brusquement
+! de la version seche a la version nuageuse pour le detrainement
+! ce qui peut occasioner des oscillations.
+! dans la nouvelle version, on commence par calculer un detrainement sec.
+! Puis un autre en cas de nuages.
+! Puis on combine les deux lineairement en fonction de la quantite d'eau.
+
+#define int1d3
+!#undef int1d3
+#define RIO_TH
+#ifdef RIO_TH
+!1. Cas non nuageux
+! 1.1 on est sous le zmax_sec et w croit
+          if ((w_est(ig,l+1).gt.w_est(ig,l)).and.  &
+     &       (zlev(ig,l+1).lt.zmax_sec(ig)).and.  &
+#ifdef int1d3
+     &       (zqla_est(ig,l).lt.1.e-10)) then 
+#else
+     &       (zqla(ig,l-1).lt.1.e-10)) then 
+#endif
+             detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1)  &
+     &       *sqrt(w_est(ig,l+1))*sqrt(l_mix*zlev(ig,l+1))  &
+     &       -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(l_mix*zlev(ig,l)))  &
+     &       /(r_aspect*zmax_sec(ig)))
+             detr_stara(ig,l)=detr_star(ig,l)
+
+       if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l',ig,l
+
+! 1.2 on est sous le zmax_sec et w decroit
+          else if ((zlev(ig,l+1).lt.zmax_sec(ig)).and.  &
+#ifdef int1d3
+     &            (zqla_est(ig,l).lt.1.e-10)) then
+#else
+     &            (zqla(ig,l-1).lt.1.e-10)) then
+#endif
+             detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig))  &
+     &       /(rhobarz(ig,lmix(ig))*wmaxa(ig))*  &
+     &       (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1))  &
+     &       *((zmax_sec(ig)-zlev(ig,l+1))/  &
+     &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.  &
+     &       -rhobarz(ig,l)*sqrt(w_est(ig,l))  &
+     &       *((zmax_sec(ig)-zlev(ig,l))/  &
+     &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.)
+             detr_starb(ig,l)=detr_star(ig,l)
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 2: ig, l',ig,l
+
+          else
+
+! 1.3 dans les autres cas
+             detr_star(ig,l)=0.002*f0(ig)*f_star(ig,l)  &
+     &                      *(zlev(ig,l+1)-zlev(ig,l))
+             detr_starc(ig,l)=detr_star(ig,l)
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 3 n: ig, l',ig, l
+             
+          endif
+
+#else
+
+! 1.1 on est sous le zmax_sec et w croit
+          if ((w_est(ig,l+1).gt.w_est(ig,l)).and.  &
+     &       (zlev(ig,l+1).lt.zmax_sec(ig)) ) then
+             detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1)  &
+     &       *sqrt(w_est(ig,l+1))*sqrt(l_mix*zlev(ig,l+1))  &
+     &       -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(l_mix*zlev(ig,l)))  &
+     &       /(r_aspect*zmax_sec(ig)))
+
+       if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l', ig, l
+
+! 1.2 on est sous le zmax_sec et w decroit
+          else if ((zlev(ig,l+1).lt.zmax_sec(ig)) ) then
+             detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig))  &
+     &       /(rhobarz(ig,lmix(ig))*wmaxa(ig))*  &
+     &       (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1))  &
+     &       *((zmax_sec(ig)-zlev(ig,l+1))/  &
+     &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.  &
+     &       -rhobarz(ig,l)*sqrt(w_est(ig,l))  &
+     &       *((zmax_sec(ig)-zlev(ig,l))/  &
+     &       ((zmax_sec(ig)-zlev(ig,lmix(ig)))))**2.)
+       if (prt_level.ge.20) print*,'coucou calcul detr 1: ig, l', ig, l
+
+          else
+             detr_star=0.
+          endif
+
+! 1.3 dans les autres cas
+          detr_starc(ig,l)=0.002*f0(ig)*f_star(ig,l)  &
+     &                      *(zlev(ig,l+1)-zlev(ig,l))
+
+          coefc=min(zqla(ig,l-1)/1.e-3,1.)
+          if (zlev(ig,l+1).ge.zmax_sec(ig)) coefc=1.
+          coefc=1.
+! il semble qu'il soit important de baser le calcul sur
+! zqla_est(ig,l-1) plutot que sur zqla_est(ig,l)
+          detr_star(ig,l)=detr_starc(ig,l)*coefc+detr_star(ig,l)*(1.-coefc)
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 2: ig, l', ig, l
+
+#endif
+
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 444: ig, l', ig, l
+!IM 730508 beg
+!        if(itap.GE.7200) THEN
+!         print*,'th_plume ig,l,itap,zqla_est=',ig,l,itap,zqla_est(ig,l)
+!        endif
+!IM 730508 end
+         
+         zqla0(ig,l)=zqla_est(ig,l)
+         detr_star0(ig,l)=detr_star(ig,l)
+!IM 060508 beg
+!         if(detr_star(ig,l).GT.1.) THEN
+!          print*,'th_plumeBEF ig l detr_star detr_starc coefc',ig,l,detr_star(ig,l) &
+!   &      ,detr_starc(ig,l),coefc
+!         endif
+!IM 060508 end
+!IM 160508 beg
+!IM 160508       IF (f0(ig).NE.0.) THEN
+           detr_star(ig,l)=detr_star(ig,l)/f0(ig)
+!IM 160508       ELSE IF(detr_star(ig,l).EQ.0.) THEN
+!IM 160508        print*,'WARNING1  : th_plume f0=0, detr_star=0: ig, l, itap',ig,l,itap
+!IM 160508       ELSE
+!IM 160508        print*,'WARNING2  : th_plume f0=0, ig, l, itap, detr_star',ig,l,itap,detr_star(ig,l)
+!IM 160508       ENDIF
+!IM 160508 end
+!IM 060508 beg
+!        if(detr_star(ig,l).GT.1.) THEN
+!         print*,'th_plumeAFT ig l detr_star f0 1/f0',ig,l,detr_star(ig,l),f0(ig), &
+!   &     REAL(1)/f0(ig)
+!        endif
+!IM 060508 end
+        if (prt_level.ge.20) print*,'coucou calcul detr 445: ig, l', ig, l
+!
+!calcul de entr_star
+
+! #undef test2
+! #ifdef test2
+! La version test2 destabilise beaucoup le modele.
+! Il semble donc que ca aide d'avoir un entrainement important sous
+! le nuage.
+!         if (zqla_est(ig,l-1).ge.1.e-10.and.l.gt.lalim(ig)) then
+!          entr_star(ig,l)=0.4*detr_star(ig,l)
+!         else
+!          entr_star(ig,l)=0.
+!         endif
+! #else
+!
+! Deplacement du calcul de entr_star pour eviter d'avoir aussi
+! entr_star > fstar.
+! Redeplacer suite a la transformation du cas detr>f
+! FH
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 446: ig, l', ig, l
+#define int1d
+!FH 070508 #define int1d4
+!#undef int1d4
+! L'option int1d4 correspond au choix dans le cas ou le detrainement
+! devient trop grand.
+
+#ifdef int1d
+
+#ifdef int1d4
+#else
+       detr_star(ig,l)=min(detr_star(ig,l),f_star(ig,l))
+!FH 070508 plus
+       detr_star(ig,l)=min(detr_star(ig,l),1.)
+#endif
+
+       entr_star(ig,l)=max(0.4*detr_star(ig,l)-alim_star(ig,l),0.)
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 447: ig, l', ig, l
+#ifdef int1d4
+! Si le detrainement excede le flux en bas + l'entrainement, le thermique
+! doit disparaitre.
+       if (detr_star(ig,l)>f_star(ig,l)+entr_star(ig,l)) then
+          detr_star(ig,l)=f_star(ig,l)+entr_star(ig,l)
+          f_star(ig,l+1)=0.
+          linter(ig)=l+1
+          zw2(ig,l+1)=-1.e-10
+       endif
+#endif
+
+
+#else
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 448: ig, l', ig, l
+        if(l.gt.lalim(ig)) then
+         entr_star(ig,l)=0.4*detr_star(ig,l)
+        else
+
+! FH :
+! Cette ligne doit permettre de garantir qu'on a toujours un flux = 1
+! en haut de la couche d'alimentation.
+! A remettre en questoin a la premiere occasion mais ca peut aider a 
+! ecrire un code robuste.
+! Que ce soit avec ca ou avec l'ancienne facon de faire (e* = 0 mais
+! d* non nul) on a une discontinuité de e* ou d* en haut de la couche
+! d'alimentation, ce qui n'est pas forcement heureux.
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 449: ig, l', ig, l
+#undef pre_int1c
+#ifdef pre_int1c
+         entr_star(ig,l)=max(detr_star(ig,l)-alim_star(ig,l),0.)
+         detr_star(ig,l)=entr_star(ig,l)
+#else
+         entr_star(ig,l)=0.
+#endif
+
+        endif
+
+#endif
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 440: ig, l', ig, l
+        entr_star1(ig,l)=entr_star(ig,l)
+        detr_star1(ig,l)=detr_star(ig,l)
+!
+
+#ifdef int1d
+#else
+        if (detr_star(ig,l).gt.f_star(ig,l)) then
+
+!  Ce test est là entre autres parce qu'on passe par des valeurs
+!  delirantes de detr_star.
+!  ca vaut sans doute le coup de verifier pourquoi.
+
+           detr_star(ig,l)=f_star(ig,l)
+#ifdef pre_int1c
+           if (l.gt.lalim(ig)+1) then
+               entr_star(ig,l)=0.
+               alim_star(ig,l)=0.
+! FH ajout pour forcer a stoper le thermique juste sous le sommet
+! de la couche (voir calcul de finter)
+               zw2(ig,l+1)=-1.e-10
+               linter(ig)=l+1
+            else
+               entr_star(ig,l)=0.4*detr_star(ig,l)
+            endif
+#else
+           entr_star(ig,l)=0.4*detr_star(ig,l)
+#endif
+        endif
+#endif
+
+      else !l > 2
+         detr_star(ig,l)=0.
+         entr_star(ig,l)=0.
+      endif
+
+        entr_star2(ig,l)=entr_star(ig,l)
+        detr_star2(ig,l)=detr_star(ig,l)
+        if (prt_level.ge.20) print*,'coucou calcul detr 450: ig, l', ig, l
+
+       endif  ! iflag_thermals_ed==0
+
+!CR:nvlle def de entr_star et detr_star
+      if (iflag_thermals_ed>=1) then
+!      if (l.lt.lalim(ig)) then
+!      if (l.lt.2) then 
+!        entr_star(ig,l)=0.
+!        detr_star(ig,l)=0.
+!      else
+!      if (0.001.gt.(RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l))/(2.*w_est(ig,l+1)))) then 
+!         entr_star(ig,l)=0.001*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+!      else
+!         entr_star(ig,l)=  &
+!     &                f_star(ig,l)/(2.*w_est(ig,l+1))        &
+!     &                *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l))   &
+!     &                *(zlev(ig,l+1)-zlev(ig,l))
+
+ 
+         entr_star(ig,l)=MAX(0.*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)),  &          
+     &                f_star(ig,l)/(2.*w_est(ig,l+1))        &
+     &                *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)   &
+     &                *(zlev(ig,l+1)-zlev(ig,l))) &
+     &                +0.0001*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+
+        if (((ztva_est(ig,l)-ztv(ig,l)).gt.1.e-10).and.(l.le.lmix_bis(ig))) then
+            alim_star_tot(ig)=alim_star_tot(ig)+entr_star(ig,l)
+            lalim(ig)=lmix_bis(ig)
+            if(prt_level.GE.10) print*,'alim_star_tot',alim_star_tot(ig),entr_star(ig,l)
+        endif
+
+        if (((ztva_est(ig,l)-ztv(ig,l)).gt.1.e-10).and.(l.le.lmix_bis(ig))) then
+!        c2(ig,l)=2500000.*zqla_est(ig,l)/(1004.*zta_est(ig,l))
+         c2(ig,l)=0.001
+         detr_star(ig,l)=MAX(0.*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)),  &
+     &                c2(ig,l)*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) &
+     &                -f_star(ig,l)/(2.*w_est(ig,l+1))       &
+     &                *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)       &
+     &                *(zlev(ig,l+1)-zlev(ig,l)))                    &
+     &                +0.0001*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+
+       else
+!         c2(ig,l)=2500000.*zqla_est(ig,l)/(1004.*zta_est(ig,l))
+          c2(ig,l)=0.003
+
+         detr_star(ig,l)=MAX(0.*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)),  &
+     &                c2(ig,l)*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l)) &
+     &                -f_star(ig,l)/(2.*w_est(ig,l+1))       &
+     &                *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)       &
+     &                *(zlev(ig,l+1)-zlev(ig,l))) &
+     &                +0.0002*f_star(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+       endif
+         
+           
+!        detr_star(ig,l)=detr_star(ig,l)*3.
+!        if (l.lt.lalim(ig)) then
+!          entr_star(ig,l)=0.
+!        endif
+!        if (l.lt.2) then
+!          entr_star(ig,l)=0.
+!          detr_star(ig,l)=0.
+!        endif
+
+
+!      endif 
+!      else if ((ztva_est(ig,l)-ztv(ig,l)).gt.1.e-10) then
+!      entr_star(ig,l)=MAX(0.,0.8*f_star(ig,l)/(2.*w_est(ig,l+1))        &
+!     &                *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l))   &
+!     &                *(zlev(ig,l+1)-zlev(ig,l))
+!      detr_star(ig,l)=0.002*f_star(ig,l)                         &
+!     &                *(zlev(ig,l+1)-zlev(ig,l))
+!      else
+!      entr_star(ig,l)=0.001*f_star(ig,l)                         &
+!     &                *(zlev(ig,l+1)-zlev(ig,l))
+!      detr_star(ig,l)=MAX(0.,-0.2*f_star(ig,l)/(2.*w_est(ig,l+1))       &
+!     &                *RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l))       &
+!     &                *(zlev(ig,l+1)-zlev(ig,l))                      &
+!     &                +0.002*f_star(ig,l)                             &
+!     &                *(zlev(ig,l+1)-zlev(ig,l))
+!      endif
+
+      endif   ! iflag_thermals_ed==1
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH inutile si on conserve comme on l'a fait plus haut entr=detr
+! dans la couche d'alimentation
+!pas d entrainement dans la couche alim
+!      if ((l.le.lalim(ig))) then
+!           entr_star(ig,l)=0.
+!      endif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!prise en compte du detrainement et de l entrainement dans le calcul du flux
+
+      f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)  &
+     &              -detr_star(ig,l)
+
+!test sur le signe de f_star
+        if (prt_level.ge.20) print*,'coucou calcul detr 451: ig, l', ig, l
+       if (f_star(ig,l+1).gt.1.e-10) then 
+!----------------------------------------------------------------------------
+!calcul de la vitesse verticale en melangeant Tl et qt du thermique
+!---------------------------------------------------------------------------
+!
+       Zsat=.false.
+       ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+  &
+     &            (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l))  &
+     &            /(f_star(ig,l+1)+detr_star(ig,l))
+!
+       zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+  &
+     &            (alim_star(ig,l)+entr_star(ig,l))*po(ig,l))  &
+     &            /(f_star(ig,l+1)+detr_star(ig,l))
+!  
+               Tbef=ztla(ig,l)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+               qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)               
+               qsatbef=MIN(0.5,qsatbef)
+               zcor=1./(1.-retv*qsatbef)
+               qsatbef=qsatbef*zcor
+               Zsat = (max(0.,zqta(ig,l)-qsatbef) .gt. 1.e-10)
+               if (Zsat) then
+               qlbef=max(0.,zqta(ig,l)-qsatbef)
+               DT = 0.5*RLvCp*qlbef
+               do while (abs(DT).gt.DDT0)
+                 Tbef=Tbef+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+                 qsatbef= R2ES * FOEEW(Tbef,zdelta)/pplev(ig,l)
+                 qsatbef=MIN(0.5,qsatbef)
+                 zcor=1./(1.-retv*qsatbef)
+                 qsatbef=qsatbef*zcor
+                 qlbef=zqta(ig,l)-qsatbef
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef)
+                 dqsat_dT=FOEDE(Tbef,zdelta,zcvm5,qsatbef,zcor)
+                 num=-Tbef+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 DT=num/denom
+              enddo
+                 zqla(ig,l) = max(0.,qlbef) 
+              endif
+!    
+        if (prt_level.ge.20) print*,'coucou calcul detr 4512: ig, l', ig, l
+! on ecrit de maniere conservative (sat ou non)
+!          T = Tl +Lv/Cp ql
+           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+!on rajoute le calcul de zha pour diagnostiques (temp potentielle)
+           zha(ig,l) = ztva(ig,l)
+           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)  &
+     &              -zqla(ig,l))-zqla(ig,l))
+
+!on ecrit zqsat 
+           zqsatth(ig,l)=qsatbef  
+!calcul de vitesse
+           zw2(ig,l+1)=zw2(ig,l)*  &
+     &                 ((f_star(ig,l))**2)  &
+!  Tests de Catherine
+!     &                 /(f_star(ig,l+1)+detr_star(ig,l))**2+             &
+     &      /(f_star(ig,l+1)+detr_star(ig,l)-entr_star(ig,l)*(1.-fact_epsilon))**2+ &
+     &                 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+     &                 *fact_gamma &
+     &                 *(zlev(ig,l+1)-zlev(ig,l))
+!prise en compte des forces de pression que qd flottabilité<0
+!              zw2(ig,l+1)=zw2(ig,l)*  &
+!     &            1./(1.+2.*entr_star(ig,l)/f_star(ig,l)) + &        
+!     &                 (f_star(ig,l))**2 &
+!     &                 /(f_star(ig,l)+entr_star(ig,l))**2+ &
+!     &                 (f_star(ig,l)-2.*entr_star(ig,l))**2/(f_star(ig,l)+2.*entr_star(ig,l))**2+  &        
+!     &                 /(f_star(ig,l+1)+detr_star(ig,l)-entr_star(ig,l)*(1.-2.))**2+ &
+!     &                 /(f_star(ig,l)**2+2.*2.*detr_star(ig,l)*f_star(ig,l)+2.*entr_star(ig,l)*f_star(ig,l))+ &
+!     &                 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+!     &                 *1./3. &
+!     &                 *(zlev(ig,l+1)-zlev(ig,l))
+          
+!        write(30,*),l+1,zw2(ig,l+1)-zw2(ig,l), &
+!     &              -2.*entr_star(ig,l)/f_star(ig,l)*zw2(ig,l), &
+!     &               2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+
+ 
+!             zw2(ig,l+1)=zw2(ig,l)*  &
+!     &                 (2.-2.*entr_star(ig,l)/f_star(ig,l)) &  
+!     &                 -zw2(ig,l-1)+  &        
+!     &                 2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+!     &                 *1./3. &
+!     &                 *(zlev(ig,l+1)-zlev(ig,l))             
+
+            endif
+        endif
+        if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l
+!
+!initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max 
+
+            if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then
+                print*,'On tombe sur le cas particulier de thermcell_plume'
+                zw2(ig,l+1)=0.
+                linter(ig)=l+1
+            endif
+
+!        if ((zw2(ig,l).gt.0.).and. (zw2(ig,l+1).le.0.)) then
+        if (zw2(ig,l+1).lt.0.) then 
+           linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))  &
+     &               -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+           zw2(ig,l+1)=0.
+        endif
+
+           wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) 
+
+        if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!   lmix est le niveau de la couche ou w (wa_moy) est maximum
+!on rajoute le calcul de lmix_bis
+            if (zqla(ig,l).lt.1.e-10) then
+               lmix_bis(ig)=l+1
+            endif
+            lmix(ig)=l+1
+            wmaxa(ig)=wa_moy(ig,l+1)
+        endif
+        enddo
+      enddo
+
+!on remplace a* par e* ds premiere couche
+!      if (iflag_thermals_ed.ge.1) then
+!       do ig=1,ngrid
+!       do l=2,klev
+!          if (l.lt.lalim(ig)) then
+!             alim_star(ig,l)=entr_star(ig,l)
+!          endif
+!       enddo
+!       enddo
+!       do ig=1,ngrid
+!          lalim(ig)=lmix_bis(ig)
+!       enddo
+!      endif
+       if (iflag_thermals_ed.ge.1) then
+          do ig=1,ngrid
+             do l=2,lalim(ig)
+                alim_star(ig,l)=entr_star(ig,l)
+                entr_star(ig,l)=0.
+             enddo
+           enddo
+       endif
+        if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l
+
+!     print*,'thermcell_plume OK'
+
+      return 
+      end
+!==============================================================================
+       SUBROUTINE thermcellV0_dry(ngrid,nlay,zlev,pphi,ztv,alim_star,  &
+     &                            lalim,lmin,zmax,wmax,lev_out)
+
+!--------------------------------------------------------------------------
+!thermcell_dry: calcul de zmax et wmax du thermique sec
+!--------------------------------------------------------------------------
+       IMPLICIT NONE
+#include "YOMCST.h"       
+#include "iniprint.h"
+       INTEGER l,ig
+
+       INTEGER ngrid,nlay
+       REAL zlev(ngrid,nlay+1)
+       REAL pphi(ngrid,nlay)
+       REAl ztv(ngrid,nlay)
+       REAL alim_star(ngrid,nlay)
+       INTEGER lalim(ngrid)
+      integer lev_out                           ! niveau pour les print
+
+       REAL zmax(ngrid)
+       REAL wmax(ngrid)
+
+!variables locales
+       REAL zw2(ngrid,nlay+1)
+       REAL f_star(ngrid,nlay+1)
+       REAL ztva(ngrid,nlay+1)
+       REAL wmaxa(ngrid)
+       REAL wa_moy(ngrid,nlay+1)
+       REAL linter(ngrid),zlevinter(ngrid)
+       INTEGER lmix(ngrid),lmax(ngrid),lmin(ngrid)
+
+!initialisations
+       do ig=1,ngrid
+          do l=1,nlay+1
+             zw2(ig,l)=0.
+             wa_moy(ig,l)=0.
+          enddo
+       enddo
+       do ig=1,ngrid
+          do l=1,nlay
+             ztva(ig,l)=ztv(ig,l)
+          enddo
+       enddo
+       do ig=1,ngrid
+          wmax(ig)=0.
+          wmaxa(ig)=0.
+       enddo
+!calcul de la vitesse a partir de la CAPE en melangeant thetav
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! A eliminer
+! Ce if complique etait fait pour reperer la premiere couche instable
+! Ici, c'est lmin.
+!
+!       do l=1,nlay-2
+!         do ig=1,ngrid
+!            if (ztv(ig,l).gt.ztv(ig,l+1)  &
+!     &         .and.alim_star(ig,l).gt.1.e-10  &
+!     &         .and.zw2(ig,l).lt.1e-10) then
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+! Calcul des F^*, integrale verticale de E^*
+       f_star(:,1)=0.
+       do l=1,nlay
+          f_star(:,l+1)=f_star(:,l)+alim_star(:,l)
+       enddo
+
+! niveau (reel) auquel zw2 s'annule FH :n'etait pas initialise
+       linter(:)=0.
+
+! couche la plus haute concernee par le thermique. 
+       lmax(:)=1
+
+! Le niveau linter est une variable continue qui se trouve dans la couche
+! lmax
+
+       do l=1,nlay-2
+         do ig=1,ngrid
+            if (l.eq.lmin(ig).and.lalim(ig).gt.1) then
+
+!------------------------------------------------------------------------
+!  Calcul de la vitesse en haut de la premiere couche instable.
+!  Premiere couche du panache thermique
+!------------------------------------------------------------------------
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)  &
+     &                     *(zlev(ig,l+1)-zlev(ig,l))  &
+     &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+
+!------------------------------------------------------------------------
+! Tant que la vitesse en bas de la couche et la somme du flux de masse
+! et de l'entrainement (c'est a dire le flux de masse en haut) sont
+! positifs, on calcul
+! 1. le flux de masse en haut  f_star(ig,l+1)
+! 2. la temperature potentielle virtuelle dans la couche ztva(ig,l)
+! 3. la vitesse au carré en haut zw2(ig,l+1)
+!------------------------------------------------------------------------
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  A eliminer : dans cette version, si zw2 est > 0 on a un therique.
+!  et donc, au dessus, f_star(ig,l+1) est forcement suffisamment 
+!  grand puisque on n'a pas de detrainement.
+!  f_star est une fonction croissante.
+!  c'est donc vraiment sur zw2 uniquement qu'il faut faire le test.
+!           else if ((zw2(ig,l).ge.1e-10).and.  &
+!    &               (f_star(ig,l)+alim_star(ig,l).gt.1.e-10)) then
+!              f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+            else if (zw2(ig,l).ge.1e-10) then
+
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+alim_star(ig,l)  &
+     &                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+  &
+     &                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+     &                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+! determination de zmax continu par interpolation lineaire
+!------------------------------------------------------------------------
+
+            if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then
+!               print*,'On tombe sur le cas particulier de thermcell_dry'
+                zw2(ig,l+1)=0.
+                linter(ig)=l+1
+                lmax(ig)=l
+            endif
+
+            if (zw2(ig,l+1).lt.0.) then
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))  &
+     &           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmax(ig)=l
+            endif
+
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+       if (prt_level.ge.1) print*,'fin calcul zw2'
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! A eliminer :
+! Ce calcul de lmax est fait en meme temps que celui de linter, plus haut
+! Calcul de la couche correspondant a la hauteur du thermique
+!      do ig=1,ngrid
+!         lmax(ig)=lalim(ig)
+!      enddo
+!      do ig=1,ngrid
+!         do l=nlay,lalim(ig)+1,-1
+!            if (zw2(ig,l).le.1.e-10) then
+!               lmax(ig)=l-1
+!            endif
+!         enddo
+!      enddo
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!    
+! Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+! calcul de zlevinter
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH A eliminer
+! Simplification
+!          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*  &
+!     &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)  &
+!     &    -zlev(ig,lmax(ig)))
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+          zlevinter(ig)=zlev(ig,lmax(ig)) + &
+     &    (linter(ig)-lmax(ig))*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))
+           zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+! Verification que lalim<=lmax
+      do ig=1,ngrid
+         if(lalim(ig)>lmax(ig)) then
+           if ( prt_level > 1 ) THEN
+            print*,'WARNING thermcell_dry ig=',ig,'  lalim=',lalim(ig),'  lmax(ig)=',lmax(ig)
+           endif
+           lmax(ig)=lalim(ig)
+         endif
+      enddo
+      
+      RETURN
+      END
+!==============================================================================
+      SUBROUTINE thermcellV0_init(ngrid,nlay,ztv,zlay,zlev,  &
+     &                  lalim,lmin,alim_star,alim_star_tot,lev_out)
+
+!----------------------------------------------------------------------
+!thermcell_init: calcul du profil d alimentation du thermique
+!----------------------------------------------------------------------
+      IMPLICIT NONE
+#include "iniprint.h"
+#include "thermcell.h"
+
+      INTEGER l,ig
+!arguments d entree
+      INTEGER ngrid,nlay
+      REAL ztv(ngrid,nlay)
+      REAL zlay(ngrid,nlay)
+      REAL zlev(ngrid,nlay+1)
+!arguments de sortie
+      INTEGER lalim(ngrid)
+      INTEGER lmin(ngrid)
+      REAL alim_star(ngrid,nlay)
+      REAL alim_star_tot(ngrid)
+      integer lev_out                           ! niveau pour les print
+      
+      REAL zzalim(ngrid)
+!CR: ponderation entrainement des couches instables
+!def des alim_star tels que alim=f*alim_star      
+
+      do l=1,nlay
+         do ig=1,ngrid 
+            alim_star(ig,l)=0.
+         enddo
+      enddo
+! determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lalim(ig)=1
+      enddo
+
+      if (iflag_thermals_ed.ge.1) then
+!si la premiÃšre couche est instable, on declenche un thermique
+         do ig=1,ngrid
+            if (ztv(ig,1).gt.ztv(ig,2)) then
+               lmin(ig)=1
+               lalim(ig)=2
+               alim_star(ig,1)=1.
+               alim_star_tot(ig)=alim_star(ig,1)
+               if(prt_level.GE.10) print*,'init',alim_star(ig,1),alim_star_tot(ig)
+            else
+                lmin(ig)=1
+                lalim(ig)=1
+                alim_star(ig,1)=0.
+                alim_star_tot(ig)=0. 
+            endif
+         enddo
+ 
+         else
+!else iflag_thermals_ed=0 ancienne def de l alim 
+
+!on ne considere que les premieres couches instables
+      do l=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.  &
+     &          ztv(ig,l+1).le.ztv(ig,l+2)) then
+               lalim(ig)=l+1
+            endif
+          enddo
+      enddo
+
+! determination du lmin: couche d ou provient le thermique
+
+      do ig=1,ngrid
+! FH initialisation de lmin a nlay plutot que 1.
+!        lmin(ig)=nlay
+         lmin(ig)=1
+      enddo
+      do l=nlay,2,-1
+         do ig=1,ngrid
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+!
+      zzalim(:)=0.
+      do l=1,nlay-1
+         do ig=1,ngrid 
+             if (l<lalim(ig)) then
+                zzalim(ig)=zzalim(ig)+zlay(ig,l)*(ztv(ig,l)-ztv(ig,l+1))
+             endif
+          enddo
+      enddo
+      do ig=1,ngrid
+          if (lalim(ig)>1) then
+             zzalim(ig)=zlay(ig,1)+zzalim(ig)/(ztv(ig,1)-ztv(ig,lalim(ig)))
+          else
+             zzalim(ig)=zlay(ig,1)
+          endif
+      enddo
+
+      if(prt_level.GE.10) print*,'ZZALIM LALIM ',zzalim,lalim,zlay(1,lalim(1))
+
+! definition de l'entrainement des couches
+      if (1.eq.1) then
+      do l=1,nlay-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.  &
+     &          l.ge.lmin(ig).and.l.lt.lalim(ig)) then
+!def possibles pour alim_star: zdthetadz, dthetadz, zdtheta
+             alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)  &
+     &                       *sqrt(zlev(ig,l+1)) 
+            endif
+         enddo
+      enddo
+      else
+      do l=1,nlay-1
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.  &
+     &          l.ge.lmin(ig).and.l.lt.lalim(ig)) then
+             alim_star(ig,l)=max(3.*zzalim(ig)-zlay(ig,l),0.) &
+     &        *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+         enddo
+      enddo
+      endif
+      
+! pas de thermique si couche 1 stable
+      do ig=1,ngrid
+!CRnouveau test
+        if (alim_star(ig,1).lt.1.e-10) then 
+            do l=1,nlay
+                alim_star(ig,l)=0.
+            enddo
+            lmin(ig)=1
+         endif
+      enddo 
+! calcul de l alimentation totale
+      do ig=1,ngrid
+         alim_star_tot(ig)=0.
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
+         enddo
+      enddo
+!
+! Calcul entrainement normalise
+      do l=1,nlay 
+         do ig=1,ngrid 
+            if (alim_star_tot(ig).gt.1.e-10) then
+               alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
+            endif
+         enddo
+      enddo
+       
+!on remet alim_star_tot a 1
+      do ig=1,ngrid 
+         alim_star_tot(ig)=1.
+      enddo
+
+      endif
+!endif iflag_thermals_ed
+      return 
+      end  
+!==============================================================================
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_closure.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_closure.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_closure.F90	(revision 17)
@@ -0,0 +1,82 @@
+!
+! $Header$
+!
+      SUBROUTINE thermcell_closure(ngrid,nlay,r_aspect,ptimestep,rho,  &
+     &   zlev,lalim,alim_star,f_star,zmax,wmax,f,lev_out)
+
+!-------------------------------------------------------------------------
+!thermcell_closure: fermeture, determination de f
+!
+! Modification 7 septembre 2009
+! 1. On enleve alim_star_tot des arguments pour le recalculer et etre ainis
+! coherent avec l'integrale au numerateur.
+! 2. On ne garde qu'une version des couples wmax,zmax et wmax_sec,zmax_sec
+! l'idee etant que le choix se fasse a l'appel de thermcell_closure
+! 3. Vectorisation en mettant les boucles en l l'exterieur avec des if
+!-------------------------------------------------------------------------
+      IMPLICIT NONE
+
+#include "iniprint.h"
+#include "thermcell.h"
+INTEGER ngrid,nlay
+INTEGER ig,k       
+REAL r_aspect,ptimestep
+integer lev_out                           ! niveau pour les print
+
+INTEGER lalim(ngrid)
+REAL alim_star(ngrid,nlay)
+REAL f_star(ngrid,nlay+1)
+REAL rho(ngrid,nlay)
+REAL zlev(ngrid,nlay)
+REAL zmax(ngrid)
+REAL wmax(ngrid)
+REAL zdenom(ngrid)
+REAL alim_star2(ngrid)
+REAL f(ngrid)
+
+REAL alim_star_tot(ngrid)
+INTEGER llmax
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!print*,'THERMCELL CLOSURE 26E'
+
+alim_star2(:)=0.
+alim_star_tot(:)=0.
+f(:)=0.
+
+! Indice vertical max (max de lalim) atteint par les thermiques sur le domaine
+llmax=1
+do ig=1,ngrid
+   if (lalim(ig)>llmax) llmax=lalim(ig)
+enddo
+
+
+! Calcul des integrales sur la verticale de alim_star et de
+!   alim_star^2/(rho dz)
+do k=1,llmax-1
+   do ig=1,ngrid
+      if (k<lalim(ig)) then
+         alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2  &
+&                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+         alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,k)
+      endif
+   enddo
+enddo
+
+
+do ig=1,ngrid
+   if (alim_star2(ig)>1.e-10) then
+      f(ig)=wmax(ig)*alim_star_tot(ig)/  &
+&     (max(500.,zmax(ig))*r_aspect*alim_star2(ig))
+   endif
+enddo
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! TESTS POUR UNE NOUVELLE FERMETURE DANS LAQUELLE ALIM_STAR NE SERAIT
+! PAS NORMALISE
+!           f(ig)=f(ig)*f_star(ig,2)/(f_star(ig,lalim(ig)))
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_condens.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_condens.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_condens.F90	(revision 17)
@@ -0,0 +1,81 @@
+subroutine thermcell_condens(klon,active,zpspsk,pplev,ztla,zqta,zqla)
+implicit none
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+
+!====================================================================
+! DECLARATIONS
+!====================================================================
+
+! Arguments
+INTEGER klon
+REAL zpspsk(klon),pplev(klon)
+REAL ztla(klon),zqta(klon),zqla(klon)
+LOGICAL active(klon)
+
+! Variables locales
+INTEGER ig,iter
+REAL Tbef(klon),DT(klon)
+REAL tdelta,qsatbef,zcor,qlbef,zdelta,zcvm5,dqsat,num,denom,dqsat_dT
+logical Zsat
+REAL RLvCp
+REAL, SAVE :: DDT0=.01
+LOGICAL afaire(klon),tout_converge
+
+!====================================================================
+! INITIALISATIONS
+!====================================================================
+
+RLvCp = RLVTT/RCPD
+tout_converge=.false.
+afaire(:)=.false.
+DT(:)=0.
+
+
+!====================================================================
+! Routine a vectoriser en copiant active dans converge et en mettant
+! la boucle sur les iterations a l'exterieur est en mettant
+! converge= false des que la convergence est atteinte.
+!====================================================================
+
+do ig=1,klon
+   if (active(ig)) then
+               Tbef(ig)=ztla(ig)*zpspsk(ig)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+               qsatbef= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig)
+               qsatbef=MIN(0.5,qsatbef)
+               zcor=1./(1.-retv*qsatbef)
+               qsatbef=qsatbef*zcor
+               qlbef=max(0.,zqta(ig)-qsatbef)
+               DT(ig) = 0.5*RLvCp*qlbef
+     endif
+enddo
+
+do iter=1,10
+    afaire(:)=abs(DT(:)).gt.DDT0
+    do ig=1,klon
+               if (afaire(ig)) then
+                 Tbef(ig)=Tbef(ig)+DT(ig)
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 qsatbef= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig)
+                 qsatbef=MIN(0.5,qsatbef)
+                 zcor=1./(1.-retv*qsatbef)
+                 qsatbef=qsatbef*zcor
+                 qlbef=zqta(ig)-qsatbef
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef)
+                 dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef,zcor)
+                 num=-Tbef(ig)+ztla(ig)*zpspsk(ig)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 zqla(ig) = max(0.,zqta(ig)-qsatbef) 
+                 DT(ig)=num/denom
+               endif
+    enddo
+enddo
+
+return
+end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_dq.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_dq.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_dq.F90	(revision 17)
@@ -0,0 +1,317 @@
+      subroutine thermcell_dq(ngrid,nlay,impl,ptimestep,fm,entr,  &
+     &           masse,q,dq,qa,lev_out)
+      implicit none
+
+#include "iniprint.h"
+!=======================================================================
+!
+!   Calcul du transport verticale dans la couche limite en presence
+!   de "thermiques" explicitement representes
+!   calcul du dq/dt une fois qu'on connait les ascendances
+!
+! Modif 2013/01/04 (FH hourdin@lmd.jussieu.fr)
+!  Introduction of an implicit computation of vertical advection in
+!  the environment of thermal plumes in thermcell_dq
+!  impl =     0 : explicit, 1 : implicit, -1 : old version
+!
+!=======================================================================
+
+      integer ngrid,nlay,impl
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+      integer lev_out                           ! niveau pour les print
+
+      real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1)
+
+      real zzm
+
+      integer ig,k
+      real cfl
+
+      real qold(ngrid,nlay),fqa(ngrid,nlay+1)
+      integer niter,iter
+      CHARACTER (LEN=20) :: modname='thermcell_dq'
+      CHARACTER (LEN=80) :: abort_message
+
+
+! Old explicite scheme
+      if (impl==-1) then
+         call thermcell_dq_o(ngrid,nlay,ptimestep,fm,entr,  &
+     &           masse,q,dq,qa,lev_out)
+         return
+      endif
+
+! Calcul du critere CFL pour l'advection dans la subsidence
+      cfl = 0.
+      do k=1,nlay
+         do ig=1,ngrid
+            zzm=masse(ig,k)/ptimestep
+            cfl=max(cfl,fm(ig,k)/zzm)
+            if (entr(ig,k).gt.zzm) then
+               print*,'entr dt > m ',entr(ig,k)*ptimestep,masse(ig,k)
+               abort_message = ''
+               CALL abort_gcm (modname,abort_message,1)
+            endif
+         enddo
+      enddo
+
+      qold=q
+
+
+      if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0'
+
+!   calcul du detrainement
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+!           print*,'Q2 DQ ',detr(ig,k),fm(ig,k),entr(ig,k)
+!test
+            if (detr(ig,k).lt.0.) then
+               entr(ig,k)=entr(ig,k)-detr(ig,k)
+               detr(ig,k)=0.
+!               print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k),
+!     s         'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k)
+            endif
+            if (fm(ig,k+1).lt.0.) then
+!               print*,'fm2<0!!!'
+            endif
+            if (entr(ig,k).lt.0.) then
+!               print*,'entr2<0!!!'
+            endif
+         enddo
+      enddo
+
+! Computation of tracer concentrations in the ascending plume
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.  &
+     &         1.e-5*masse(ig,k)) then
+         qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))  &
+     &         /(fm(ig,k+1)+detr(ig,k))
+            else
+               qa(ig,k)=q(ig,k)
+            endif
+            if (qa(ig,k).lt.0.) then
+!               print*,'qa<0!!!'
+            endif
+            if (q(ig,k).lt.0.) then
+!               print*,'q<0!!!'
+            endif
+         enddo
+      enddo
+
+! Plume vertical flux
+      do k=2,nlay-1
+         fqa(:,k)=fm(:,k)*qa(:,k-1)
+      enddo
+      fqa(:,1)=0. ; fqa(:,nlay)=0.
+
+
+! Trace species evolution
+   if (impl==0) then
+      do k=1,nlay-1
+         q(:,k)=q(:,k)+(fqa(:,k)-fqa(:,k+1)-fm(:,k)*q(:,k)+fm(:,k+1)*q(:,k+1)) &
+     &               *ptimestep/masse(:,k)
+      enddo
+   else
+      do k=nlay-1,1,-1
+         q(:,k)=(masse(:,k)*q(:,k)/ptimestep+fqa(:,k)-fqa(:,k+1)+fm(:,k+1)*q(:,k+1)) &
+     &               /(fm(:,k)+masse(:,k)/ptimestep)
+      enddo
+   endif
+
+! Tendencies
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(q(ig,k)-qold(ig,k))/ptimestep
+            q(ig,k)=qold(ig,k)
+         enddo
+      enddo
+
+return
+end
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Obsolete version kept for convergence with Cmip5 NPv3.1 simulations
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      subroutine thermcell_dq_o(ngrid,nlay,ptimestep,fm,entr,  &
+     &           masse,q,dq,qa,lev_out)
+      implicit none
+
+#include "iniprint.h"
+!=======================================================================
+!
+!   Calcul du transport verticale dans la couche limite en presence
+!   de "thermiques" explicitement representes
+!   calcul du dq/dt une fois qu'on connait les ascendances
+!
+!=======================================================================
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+      integer lev_out                           ! niveau pour les print
+
+      real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1)
+
+      real zzm
+
+      integer ig,k
+      real cfl
+
+      real qold(ngrid,nlay)
+      real ztimestep
+      integer niter,iter
+      CHARACTER (LEN=20) :: modname='thermcell_dq'
+      CHARACTER (LEN=80) :: abort_message
+
+
+
+! Calcul du critere CFL pour l'advection dans la subsidence
+      cfl = 0.
+      do k=1,nlay
+         do ig=1,ngrid
+            zzm=masse(ig,k)/ptimestep
+            cfl=max(cfl,fm(ig,k)/zzm)
+            if (entr(ig,k).gt.zzm) then
+               print*,'entr dt > m ',entr(ig,k)*ptimestep,masse(ig,k)
+               abort_message = ''
+               CALL abort_gcm (modname,abort_message,1)
+            endif
+         enddo
+      enddo
+
+!IM 090508     print*,'CFL CFL CFL CFL ',cfl
+
+#undef CFL
+#ifdef CFL
+! On subdivise le calcul en niter pas de temps.
+      niter=int(cfl)+1
+#else
+      niter=1
+#endif
+
+      ztimestep=ptimestep/niter
+      qold=q
+
+
+do iter=1,niter
+      if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0'
+
+!   calcul du detrainement
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+!           print*,'Q2 DQ ',detr(ig,k),fm(ig,k),entr(ig,k)
+!test
+            if (detr(ig,k).lt.0.) then
+               entr(ig,k)=entr(ig,k)-detr(ig,k)
+               detr(ig,k)=0.
+!               print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k),
+!     s         'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k)
+            endif
+            if (fm(ig,k+1).lt.0.) then
+!               print*,'fm2<0!!!'
+            endif
+            if (entr(ig,k).lt.0.) then
+!               print*,'entr2<0!!!'
+            endif
+         enddo
+      enddo
+
+!   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ztimestep.gt.  &
+     &         1.e-5*masse(ig,k)) then
+         qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))  &
+     &         /(fm(ig,k+1)+detr(ig,k))
+            else
+               qa(ig,k)=q(ig,k)
+            endif
+            if (qa(ig,k).lt.0.) then
+!               print*,'qa<0!!!'
+            endif
+            if (q(ig,k).lt.0.) then
+!               print*,'q<0!!!'
+            endif
+         enddo
+      enddo
+
+! Calcul du flux subsident
+
+      do k=2,nlay
+         do ig=1,ngrid
+#undef centre
+#ifdef centre
+             wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
+#else
+
+#define plusqueun
+#ifdef plusqueun
+! Schema avec advection sur plus qu'une maille.
+            zzm=masse(ig,k)/ztimestep
+            if (fm(ig,k)>zzm) then
+               wqd(ig,k)=zzm*q(ig,k)+(fm(ig,k)-zzm)*q(ig,k+1)
+            else
+               wqd(ig,k)=fm(ig,k)*q(ig,k)
+            endif
+#else
+            wqd(ig,k)=fm(ig,k)*q(ig,k)
+#endif
+#endif
+
+            if (wqd(ig,k).lt.0.) then
+!               print*,'wqd<0!!!'
+            endif
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+     
+
+! Calcul des tendances
+      do k=1,nlay
+         do ig=1,ngrid
+            q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)  &
+     &               -wqd(ig,k)+wqd(ig,k+1))  &
+     &               *ztimestep/masse(ig,k)
+!            if (dq(ig,k).lt.0.) then
+!               print*,'dq<0!!!'
+!            endif
+         enddo
+      enddo
+
+
+enddo
+
+
+! Calcul des tendances
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(q(ig,k)-qold(ig,k))/ptimestep
+            q(ig,k)=qold(ig,k)
+         enddo
+      enddo
+
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_dry.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_dry.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_dry.F90	(revision 17)
@@ -0,0 +1,166 @@
+!
+! $Id: thermcell_dry.F90 1403 2010-07-01 09:02:53Z fairhead $
+!
+       SUBROUTINE thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star,  &
+     &                            lalim,lmin,zmax,wmax,lev_out)
+
+!--------------------------------------------------------------------------
+!thermcell_dry: calcul de zmax et wmax du thermique sec
+! Calcul de la vitesse maximum et de la hauteur maximum pour un panache
+! ascendant avec une fonction d'alimentation alim_star et sans changement 
+! de phase.
+! Le calcul pourrait etre sans doute simplifier.
+! La temperature potentielle virtuelle dans la panache ascendant est
+! la temperature potentielle virtuelle pondÃ©rÃ©e par alim_star.
+!--------------------------------------------------------------------------
+
+       IMPLICIT NONE
+#include "YOMCST.h"       
+#include "iniprint.h"
+       INTEGER l,ig
+
+       INTEGER ngrid,nlay
+       REAL zlev(ngrid,nlay+1)
+       REAL pphi(ngrid,nlay)
+       REAl ztv(ngrid,nlay)
+       REAL alim_star(ngrid,nlay)
+       INTEGER lalim(ngrid)
+      integer lev_out                           ! niveau pour les print
+
+       REAL zmax(ngrid)
+       REAL wmax(ngrid)
+
+!variables locales
+       REAL zw2(ngrid,nlay+1)
+       REAL f_star(ngrid,nlay+1)
+       REAL ztva(ngrid,nlay+1)
+       REAL wmaxa(ngrid)
+       REAL wa_moy(ngrid,nlay+1)
+       REAL linter(ngrid),zlevinter(ngrid)
+       INTEGER lmix(ngrid),lmax(ngrid),lmin(ngrid)
+      CHARACTER (LEN=20) :: modname='thermcell_dry'
+      CHARACTER (LEN=80) :: abort_message
+
+!initialisations
+       do ig=1,ngrid
+          do l=1,nlay+1
+             zw2(ig,l)=0.
+             wa_moy(ig,l)=0.
+          enddo
+       enddo
+       do ig=1,ngrid
+          do l=1,nlay
+             ztva(ig,l)=ztv(ig,l)
+          enddo
+       enddo
+       do ig=1,ngrid
+          wmax(ig)=0.
+          wmaxa(ig)=0.
+       enddo
+!calcul de la vitesse a partir de la CAPE en melangeant thetav
+
+
+! Calcul des F^*, integrale verticale de E^*
+       f_star(:,1)=0.
+       do l=1,nlay
+          f_star(:,l+1)=f_star(:,l)+alim_star(:,l)
+       enddo
+
+! niveau (reel) auquel zw2 s'annule FH :n'etait pas initialise
+       linter(:)=0.
+
+! couche la plus haute concernee par le thermique. 
+       lmax(:)=1
+
+! Le niveau linter est une variable continue qui se trouve dans la couche
+! lmax
+
+       do l=1,nlay-2
+         do ig=1,ngrid
+            if (l.eq.lmin(ig).and.lalim(ig).gt.1) then
+
+!------------------------------------------------------------------------
+!  Calcul de la vitesse en haut de la premiere couche instable.
+!  Premiere couche du panache thermique
+!------------------------------------------------------------------------
+
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)  &
+     &                     *(zlev(ig,l+1)-zlev(ig,l))  &
+     &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+
+!------------------------------------------------------------------------
+! Tant que la vitesse en bas de la couche et la somme du flux de masse
+! et de l'entrainement (c'est a dire le flux de masse en haut) sont
+! positifs, on calcul
+! 1. le flux de masse en haut  f_star(ig,l+1)
+! 2. la temperature potentielle virtuelle dans la couche ztva(ig,l)
+! 3. la vitesse au carré en haut zw2(ig,l+1)
+!------------------------------------------------------------------------
+
+            else if (zw2(ig,l).ge.1e-10) then
+
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+alim_star(ig,l)  &
+     &                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+  &
+     &                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+     &                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+! determination de zmax continu par interpolation lineaire
+!------------------------------------------------------------------------
+
+            if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then
+!               stop'On tombe sur le cas particulier de thermcell_dry'
+!               print*,'On tombe sur le cas particulier de thermcell_dry'
+                zw2(ig,l+1)=0.
+                linter(ig)=l+1
+                lmax(ig)=l
+            endif
+
+            if (zw2(ig,l+1).lt.0.) then
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))  &
+     &           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmax(ig)=l
+            endif
+
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+       if (prt_level.ge.1) print*,'fin calcul zw2'
+!
+! Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+! calcul de zlevinter
+          zlevinter(ig)=zlev(ig,lmax(ig)) + &
+     &    (linter(ig)-lmax(ig))*(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))
+           zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_dv2.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_dv2.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_dv2.F90	(revision 17)
@@ -0,0 +1,193 @@
+      subroutine thermcell_dv2(ngrid,nlay,ptimestep,fm,entr,masse  &
+     &    ,fraca,larga  &
+     &    ,u,v,du,dv,ua,va,lev_out)
+      implicit none
+
+#include "iniprint.h"
+!=======================================================================
+!
+!   Calcul du transport verticale dans la couche limite en presence
+!   de "thermiques" explicitement representes
+!   calcul du dq/dt une fois qu'on connait les ascendances
+!
+! Vectorisation, FH : 2010/03/08
+!
+!=======================================================================
+
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+      integer lev_out                           ! niveau pour les print
+
+      real qa(ngrid,nlay),detr(ngrid,nlay),zf,zf2
+      real wvd(ngrid,nlay+1),wud(ngrid,nlay+1)
+      real gamma0(ngrid,nlay+1),gamma(ngrid,nlay+1)
+      real ue(ngrid,nlay),ve(ngrid,nlay)
+      LOGICAL ltherm(ngrid,nlay)
+      real dua(ngrid,nlay),dva(ngrid,nlay)
+      integer iter
+
+      integer ig,k,nlarga0
+
+!-------------------------------------------------------------------------
+
+!   calcul du detrainement
+!---------------------------
+
+!      print*,'THERMCELL DV2 OPTIMISE 3'
+
+      nlarga0=0.
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+!   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+         ue(ig,1)=u(ig,1)
+         ve(ig,1)=v(ig,1)
+      enddo
+
+      IF(prt_level>9)WRITE(lunout,*)                                    &
+     &      'WARNING on initialise gamma(1:ngrid,1)=0.'
+      gamma(1:ngrid,1)=0.
+      do k=2,nlay
+         do ig=1,ngrid
+            ltherm(ig,k)=(fm(ig,k+1)+detr(ig,k))*ptimestep > 1.e-5*masse(ig,k)
+            if(ltherm(ig,k).and.larga(ig)>0.) then
+               gamma0(ig,k)=masse(ig,k)  &
+     &         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )  &
+     &         *0.5/larga(ig)  &
+     &         *1.
+            else
+               gamma0(ig,k)=0.
+            endif
+            if (ltherm(ig,k).and.larga(ig)<=0.) nlarga0=nlarga0+1
+         enddo
+      enddo
+
+      gamma(:,:)=0.
+
+      do k=2,nlay
+
+         do ig=1,ngrid
+            if (ltherm(ig,k)) then
+               dua(ig,k)=ua(ig,k-1)-u(ig,k-1)
+               dva(ig,k)=va(ig,k-1)-v(ig,k-1)
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               ue(ig,k)=u(ig,k)
+               ve(ig,k)=v(ig,k)
+            endif
+         enddo
+
+
+! Debut des iterations
+!----------------------
+do iter=1,5
+         do ig=1,ngrid
+! Pour memoire : calcul prenant en compte la fraction reelle
+!              zf=0.5*(fraca(ig,k)+fraca(ig,k+1))
+!              zf2=1./(1.-zf)
+! Calcul avec fraction infiniement petite
+               zf=0.
+               zf2=1.
+
+!  la première fois on multiplie le coefficient de freinage
+!  par le module du vent dans la couche en dessous.
+!  Mais pourquoi donc ???
+               if (ltherm(ig,k)) then
+!   On choisit une relaxation lineaire.
+!                 gamma(ig,k)=gamma0(ig,k)
+!   On choisit une relaxation quadratique.
+                  gamma(ig,k)=gamma0(ig,k)*sqrt(dua(ig,k)**2+dva(ig,k)**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)  &
+     &               +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k))  &
+     &               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2  &
+     &                 +gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)  &
+     &               +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k))  &
+     &               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2  &
+     &                 +gamma(ig,k))
+!                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua(ig,k),dva(ig,k)
+                  dua(ig,k)=ua(ig,k)-u(ig,k)
+                  dva(ig,k)=va(ig,k)-v(ig,k)
+                  ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2
+                  ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2
+               endif
+         enddo
+! Fin des iterations
+!--------------------
+enddo
+
+      enddo ! k=2,nlay
+
+
+! Calcul du flux vertical de moment dans l'environnement.
+!---------------------------------------------------------
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*ue(ig,k)
+            wvd(ig,k)=fm(ig,k)*ve(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+! calcul des tendances.
+!-----------------------
+      do k=1,nlay
+         do ig=1,ngrid
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)  &
+     &               -(entr(ig,k)+gamma(ig,k))*ue(ig,k)  &
+     &               -wud(ig,k)+wud(ig,k+1))  &
+     &               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)  &
+     &               -(entr(ig,k)+gamma(ig,k))*ve(ig,k)  &
+     &               -wvd(ig,k)+wvd(ig,k+1))  &
+     &               /masse(ig,k)
+         enddo
+      enddo
+
+
+! Sorties eventuelles.
+!----------------------
+
+   if(prt_level.GE.10) then
+      do k=1,nlay
+         do ig=1,ngrid
+           print*,'th_dv2 ig k gamma entr detr ua ue va ve wud wvd masse',ig,k,gamma(ig,k), &
+     &   entr(ig,k),detr(ig,k),ua(ig,k),ue(ig,k),va(ig,k),ve(ig,k),wud(ig,k),wvd(ig,k),wud(ig,k+1),wvd(ig,k+1), &
+     &   masse(ig,k)
+         enddo
+      enddo
+   endif
+!
+     if (nlarga0>0) then
+          print*,'WARNING !!!!!! DANS THERMCELL_DV2 '
+          print*,nlarga0,' points pour lesquels laraga=0. dans un thermique'
+          print*,'Il faudrait decortiquer ces points'
+     endif
+
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_env.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_env.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_env.F90	(revision 17)
@@ -0,0 +1,98 @@
+      SUBROUTINE thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay,  &
+     &           pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,pqsat,lev_out)
+
+!--------------------------------------------------------------
+!thermcell_env: calcule les caracteristiques de l environnement
+!necessaires au calcul des proprietes dans le thermique
+!--------------------------------------------------------------
+
+      IMPLICIT NONE
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"      
+#include "iniprint.h"
+
+      INTEGER ngrid,nlay
+      REAL po(ngrid,nlay)
+      REAL pt(ngrid,nlay)
+      REAL pu(ngrid,nlay)
+      REAL pv(ngrid,nlay)
+      REAL pplay(ngrid,nlay)
+      REAL pplev(ngrid,nlay+1)
+      integer lev_out                           ! niveau pour les print
+
+      REAL zo(ngrid,nlay)
+      REAL zl(ngrid,nlay)
+      REAL zh(ngrid,nlay)
+      REAL ztv(ngrid,nlay)
+      REAL zthl(ngrid,nlay)
+      REAL zpspsk(ngrid,nlay)
+      REAL zu(ngrid,nlay)
+      REAL zv(ngrid,nlay)
+      REAL pqsat(ngrid,nlay)
+
+      INTEGER ig,ll
+
+      real dqsat_dT
+      real RLvCp
+
+logical mask(ngrid,nlay)
+
+
+!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+! Initialisations :
+!------------------
+
+mask(:,:)=.true.
+RLvCp = RLVTT/RCPD
+
+!
+! calcul des caracteristiques de l environnement
+       DO  ll=1,nlay
+         DO ig=1,ngrid
+            zo(ig,ll)=po(ig,ll)
+            zl(ig,ll)=0.
+            zh(ig,ll)=pt(ig,ll)
+         EndDO
+       EndDO
+!
+!
+! Condensation :
+!---------------
+! Calcul de l'humidite a saturation et de la condensation
+
+call thermcell_qsat(ngrid*nlay,mask,pplev,pt,po,pqsat)
+DO ll=1,nlay
+   DO ig=1,ngrid
+      zl(ig,ll) = max(0.,po(ig,ll)-pqsat(ig,ll))
+      zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)         !   T = Tl + Lv/Cp ql
+      zo(ig,ll) = po(ig,ll)-zl(ig,ll)
+   ENDDO
+ENDDO
+!
+!
+!-----------------------------------------------------------------------
+
+      if (prt_level.ge.1) print*,'0 OK convect8'
+
+      DO ll=1,nlay
+         DO ig=1,ngrid
+             zpspsk(ig,ll)=(pplay(ig,ll)/100000.)**RKAPPA
+             zu(ig,ll)=pu(ig,ll)
+             zv(ig,ll)=pv(ig,ll)
+!attention zh est maintenant le profil de T et plus le profil de theta !
+! Quelle horreur ! A eviter.
+!
+!   T-> Theta
+            ztv(ig,ll)=zh(ig,ll)/zpspsk(ig,ll)
+!Theta_v
+            ztv(ig,ll)=ztv(ig,ll)*(1.+RETV*(zo(ig,ll))-zl(ig,ll))
+!Thetal
+            zthl(ig,ll)=pt(ig,ll)/zpspsk(ig,ll)
+!            
+         ENDDO
+      ENDDO
+ 
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_flux2.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_flux2.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_flux2.F90	(revision 17)
@@ -0,0 +1,516 @@
+!
+! $Id: thermcell_flux2.F90 1403 2010-07-01 09:02:53Z fairhead $
+!
+      SUBROUTINE thermcell_flux2(ngrid,klev,ptimestep,masse, &
+     &       lalim,lmax,alim_star,  &
+     &       entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr,  &
+     &       detr,zqla,lev_out,lunout1,igout)
+!IM 060508    &       detr,zqla,zmax,lev_out,lunout,igout)
+
+
+!---------------------------------------------------------------------------
+!thermcell_flux: deduction des flux
+!---------------------------------------------------------------------------
+
+      IMPLICIT NONE
+#include "iniprint.h"
+#include "thermcell.h"
+      
+      INTEGER ig,l
+      INTEGER ngrid,klev
+      
+      REAL alim_star(ngrid,klev),entr_star(ngrid,klev)
+      REAL detr_star(ngrid,klev)
+      REAL zw2(ngrid,klev+1)
+      REAL zlev(ngrid,klev+1)
+      REAL masse(ngrid,klev)
+      REAL ptimestep
+      REAL rhobarz(ngrid,klev)
+      REAL f(ngrid)
+      INTEGER lmax(ngrid)
+      INTEGER lalim(ngrid)
+      REAL zqla(ngrid,klev)
+      REAL zmax(ngrid)
+
+      integer ncorecfm1,ncorecfm2,ncorecfm3,ncorecalpha
+      integer ncorecfm4,ncorecfm5,ncorecfm6,ncorecfm7,ncorecfm8
+      
+
+      REAL entr(ngrid,klev),detr(ngrid,klev)
+      REAL fm(ngrid,klev+1)
+      REAL zfm
+
+      integer igout,lout
+      integer lev_out
+      integer lunout1
+
+      REAL f_old,ddd0,eee0,ddd,eee,zzz
+
+      REAL fomass_max,alphamax
+      save fomass_max,alphamax
+
+      logical check_debug,labort_gcm
+
+      character (len=20) :: modname='thermcell_flux2'
+      character (len=80) :: abort_message
+
+      fomass_max=0.5
+      alphamax=0.7
+
+      ncorecfm1=0
+      ncorecfm2=0
+      ncorecfm3=0
+      ncorecfm4=0
+      ncorecfm5=0
+      ncorecfm6=0
+      ncorecfm7=0
+      ncorecfm8=0
+      ncorecalpha=0
+
+!initialisation
+      fm(:,:)=0.
+      
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_flux 0'
+         write(lunout1,*) 'flux base ',f(igout)
+         write(lunout1,*) 'lmax ',lmax(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) 'ig= ',igout
+         write(lunout1,*) ' l E*    A*     D*  '
+         write(lunout1,'(i4,3e15.5)') (l,entr_star(igout,l),alim_star(igout,l),detr_star(igout,l) &
+     &    ,l=1,lmax(igout))
+      endif
+
+
+!-------------------------------------------------------------------------
+! Verification de la nullite des entrainement et detrainement au dessus
+! de lmax(ig)
+! Active uniquement si check_debug=.true. ou prt_level>=10
+!-------------------------------------------------------------------------
+
+      check_debug=.false..or.prt_level>=10
+
+      if (check_debug) then
+      do l=1,klev
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+               if (entr_star(ig,l).gt.1.) then
+                    print*,'WARNING thermcell_flux 1 ig,l,lmax(ig)',ig,l,lmax(ig)
+                    print*,'entr_star(ig,l)',entr_star(ig,l)
+                    print*,'alim_star(ig,l)',alim_star(ig,l)
+                    print*,'detr_star(ig,l)',detr_star(ig,l)
+               endif
+            else
+               if (abs(entr_star(ig,l))+abs(alim_star(ig,l))+abs(detr_star(ig,l)).gt.0.) then
+                    print*,'cas 1 : ig,l,lmax(ig)',ig,l,lmax(ig)
+                    print*,'entr_star(ig,l)',entr_star(ig,l)
+                    print*,'alim_star(ig,l)',alim_star(ig,l)
+                    print*,'detr_star(ig,l)',detr_star(ig,l)
+                    abort_message = ''
+                    labort_gcm=.true.
+                    CALL abort_gcm (modname,abort_message,1)
+               endif
+            endif
+         enddo
+      enddo
+      endif
+
+!-------------------------------------------------------------------------
+! Multiplication par le flux de masse issu de la femreture
+!-------------------------------------------------------------------------
+
+      do l=1,klev
+         entr(:,l)=f(:)*(entr_star(:,l)+alim_star(:,l))
+         detr(:,l)=f(:)*detr_star(:,l)
+      enddo
+
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_flux 1'
+         write(lunout1,*) 'flux base ',f(igout)
+         write(lunout1,*) 'lmax ',lmax(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) 'ig= ',igout
+         write(lunout1,*) ' l   E    D     W2'
+         write(lunout1,'(i4,3e15.5)') (l,entr(igout,l),detr(igout,l) &
+     &    ,zw2(igout,l+1),l=1,lmax(igout))
+      endif
+
+      fm(:,1)=0.
+      do l=1,klev
+         do ig=1,ngrid
+            if (l.lt.lmax(ig)) then
+               fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l)
+            elseif(l.eq.lmax(ig)) then
+               fm(ig,l+1)=0.
+               detr(ig,l)=fm(ig,l)+entr(ig,l)
+            else
+               fm(ig,l+1)=0.
+            endif
+         enddo
+      enddo
+
+
+
+! Test provisoire : pour comprendre pourquoi on corrige plein de fois 
+! le cas fm6, on commence par regarder une premiere fois avant les
+! autres corrections.
+
+      do l=1,klev
+         do ig=1,ngrid
+            if (detr(ig,l).gt.fm(ig,l)) then
+               ncorecfm8=ncorecfm8+1
+!              igout=ig
+            endif
+         enddo
+      enddo
+
+!      if (prt_level.ge.10) &
+!    &    call printflux(ngrid,klev,lunout1,igout,f,lmax,lalim, &
+!    &    ptimestep,masse,entr,detr,fm,'2  ')
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH Version en cours de test;
+! par rapport a thermcell_flux, on fait une grande boucle sur "l"
+! et on modifie le flux avec tous les contrï¿œles appliques d'affilee
+! pour la meme couche
+! Momentanement, on duplique le calcule du flux pour pouvoir comparer
+! les flux avant et apres modif
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      do l=1,klev
+
+         do ig=1,ngrid
+            if (l.lt.lmax(ig)) then
+               fm(ig,l+1)=fm(ig,l)+entr(ig,l)-detr(ig,l)
+            elseif(l.eq.lmax(ig)) then
+               fm(ig,l+1)=0.
+               detr(ig,l)=fm(ig,l)+entr(ig,l)
+            else
+               fm(ig,l+1)=0.
+            endif
+         enddo
+
+
+!-------------------------------------------------------------------------
+! Verification de la positivite des flux de masse
+!-------------------------------------------------------------------------
+
+!     do l=1,klev
+         do ig=1,ngrid
+            if (fm(ig,l+1).lt.0.) then
+!              print*,'fm1<0',l+1,lmax(ig),fm(ig,l+1)
+                ncorecfm1=ncorecfm1+1
+               fm(ig,l+1)=fm(ig,l)
+               detr(ig,l)=entr(ig,l)
+            endif
+         enddo
+!     enddo
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-------------------------------------------------------------------------
+!Test sur fraca croissant
+!-------------------------------------------------------------------------
+      if (iflag_thermals_optflux==0) then 
+!     do l=1,klev
+         do ig=1,ngrid
+          if (l.ge.lalim(ig).and.l.le.lmax(ig) &
+     &    .and.(zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10) ) then
+!  zzz est le flux en l+1 a frac constant
+             zzz=fm(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1)  &
+     &                          /(rhobarz(ig,l)*zw2(ig,l))
+             if (fm(ig,l+1).gt.zzz) then
+                detr(ig,l)=detr(ig,l)+fm(ig,l+1)-zzz
+                fm(ig,l+1)=zzz
+                ncorecfm4=ncorecfm4+1
+             endif
+          endif
+        enddo
+!     enddo
+      endif
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+
+!-------------------------------------------------------------------------
+!test sur flux de masse croissant
+!-------------------------------------------------------------------------
+      if (iflag_thermals_optflux==0) then
+!     do l=1,klev
+         do ig=1,ngrid
+            if ((fm(ig,l+1).gt.fm(ig,l)).and.(l.gt.lalim(ig))) then
+              f_old=fm(ig,l+1)
+              fm(ig,l+1)=fm(ig,l)
+              detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1)
+               ncorecfm5=ncorecfm5+1
+            endif
+         enddo
+!     enddo
+      endif
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!fin 1.eq.0
+!-------------------------------------------------------------------------
+!detr ne peut pas etre superieur a fm
+!-------------------------------------------------------------------------
+
+      if(1.eq.1) then
+
+!     do l=1,klev
+
+
+
+         labort_gcm=.false.
+         do ig=1,ngrid
+            if (entr(ig,l)<0.) then
+               labort_gcm=.true.
+               igout=ig
+               lout=l
+            endif
+         enddo
+
+         if (labort_gcm) then
+            print*,'N1 ig,l,entr',igout,lout,entr(igout,lout)
+            abort_message = 'entr negatif'
+            CALL abort_gcm (modname,abort_message,1)
+         endif
+
+         do ig=1,ngrid
+            if (detr(ig,l).gt.fm(ig,l)) then
+               ncorecfm6=ncorecfm6+1
+               detr(ig,l)=fm(ig,l)
+               entr(ig,l)=fm(ig,l+1)
+
+! Dans le cas ou on est au dessus de la couche d'alimentation et que le
+! detrainement est plus fort que le flux de masse, on stope le thermique.
+!test:on commente
+!               if (l.gt.lalim(ig)) then
+!                  lmax(ig)=l
+!                  fm(ig,l+1)=0.
+!                  entr(ig,l)=0.
+!               else
+!                  ncorecfm7=ncorecfm7+1
+!               endif
+            endif
+
+            if(l.gt.lmax(ig)) then
+               detr(ig,l)=0.
+               fm(ig,l+1)=0.
+               entr(ig,l)=0.
+            endif
+         enddo
+
+         labort_gcm=.false.
+         do ig=1,ngrid
+            if (entr(ig,l).lt.0.) then
+               labort_gcm=.true.
+               igout=ig
+            endif
+         enddo
+         if (labort_gcm) then
+            ig=igout
+            print*,'ig,l,lmax(ig)',ig,l,lmax(ig)
+            print*,'entr(ig,l)',entr(ig,l)
+            print*,'fm(ig,l)',fm(ig,l)
+            abort_message = 'probleme dans thermcell flux'
+            CALL abort_gcm (modname,abort_message,1)
+         endif
+
+
+!     enddo
+      endif
+
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-------------------------------------------------------------------------
+!fm ne peut pas etre negatif
+!-------------------------------------------------------------------------
+
+!     do l=1,klev
+         do ig=1,ngrid
+            if (fm(ig,l+1).lt.0.) then
+               detr(ig,l)=detr(ig,l)+fm(ig,l+1)
+               fm(ig,l+1)=0.
+               ncorecfm2=ncorecfm2+1
+            endif
+         enddo
+
+         labort_gcm=.false.
+         do ig=1,ngrid
+            if (detr(ig,l).lt.0.) then
+               labort_gcm=.true.
+               igout=ig
+            endif
+        enddo
+        if (labort_gcm) then
+               ig=igout
+               print*,'cas 2 : ig,l,lmax(ig)',ig,l,lmax(ig)
+               print*,'detr(ig,l)',detr(ig,l)
+               print*,'fm(ig,l)',fm(ig,l)
+               abort_message = 'probleme dans thermcell flux'
+               CALL abort_gcm (modname,abort_message,1)
+        endif
+!    enddo
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+!-----------------------------------------------------------------------
+!la fraction couverte ne peut pas etre superieure a 1            
+!-----------------------------------------------------------------------
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! FH Partie a revisiter.
+! Il semble qu'etaient codees ici deux optiques dans le cas
+! F/ (rho *w) > 1
+! soit limiter la hauteur du thermique en considerant que c'est 
+! la derniere chouche, soit limiter F a rho w.
+! Dans le second cas, il faut en fait limiter a un peu moins
+! que ca parce qu'on a des 1 / ( 1 -alpha) un peu plus loin
+! dans thermcell_main et qu'il semble de toutes facons deraisonable
+! d'avoir des fractions de 1..
+! Ci dessous, et dans l'etat actuel, le premier des  deux if est
+! sans doute inutile.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!    do l=1,klev
+        do ig=1,ngrid
+           if (zw2(ig,l+1).gt.1.e-10) then
+           zfm=rhobarz(ig,l+1)*zw2(ig,l+1)*alphamax
+           if ( fm(ig,l+1) .gt. zfm) then
+              f_old=fm(ig,l+1)
+              fm(ig,l+1)=zfm
+!             zw2(ig,l+1)=0.
+!             zqla(ig,l+1)=0.
+              detr(ig,l)=detr(ig,l)+f_old-fm(ig,l+1)
+!             lmax(ig)=l+1
+!             zmax(ig)=zlev(ig,lmax(ig))
+!             print*,'alpha>1',l+1,lmax(ig)
+              ncorecalpha=ncorecalpha+1
+           endif
+           endif
+        enddo
+!    enddo
+!
+
+
+      if (prt_level.ge.10) &
+     &   write(lunout1,'(i4,4e14.4)') l,masse(igout,l)/ptimestep, &
+     &     entr(igout,l),detr(igout,l),fm(igout,l+1)
+
+! Fin de la grande boucle sur les niveaux verticaux
+      enddo
+
+!      if (prt_level.ge.10) &
+!    &    call printflux(ngrid,klev,lunout1,igout,f,lmax,lalim, &
+!    &    ptimestep,masse,entr,detr,fm,'8  ')
+
+
+!-----------------------------------------------------------------------
+! On fait en sorte que la quantite totale d'air entraine dans le 
+! panache ne soit pas trop grande comparee a la masse de la maille
+!-----------------------------------------------------------------------
+
+      if (1.eq.1) then
+      labort_gcm=.false.
+      do l=1,klev-1
+         do ig=1,ngrid
+            eee0=entr(ig,l)
+            ddd0=detr(ig,l)
+            eee=entr(ig,l)-masse(ig,l)*fomass_max/ptimestep
+            ddd=detr(ig,l)-eee
+            if (eee.gt.0.) then
+                ncorecfm3=ncorecfm3+1
+                entr(ig,l)=entr(ig,l)-eee
+                if ( ddd.gt.0.) then
+!   l'entrainement est trop fort mais l'exces peut etre compense par une
+!   diminution du detrainement)
+                   detr(ig,l)=ddd
+                else
+!   l'entrainement est trop fort mais l'exces doit etre compense en partie
+!   par un entrainement plus fort dans la couche superieure
+                   if(l.eq.lmax(ig)) then
+                      detr(ig,l)=fm(ig,l)+entr(ig,l)
+                   else
+                      if(l.ge.lmax(ig).and.0.eq.1) then
+                         igout=ig
+                         lout=l
+                         labort_gcm=.true.
+                      endif
+                      entr(ig,l+1)=entr(ig,l+1)-ddd
+                      detr(ig,l)=0.
+                      fm(ig,l+1)=fm(ig,l)+entr(ig,l)
+                      detr(ig,l)=0.
+                   endif
+                endif
+            endif
+         enddo
+      enddo
+      if (labort_gcm) then
+                         ig=igout
+                         l=lout
+                         print*,'ig,l',ig,l
+                         print*,'eee0',eee0
+                         print*,'ddd0',ddd0
+                         print*,'eee',eee
+                         print*,'ddd',ddd
+                         print*,'entr',entr(ig,l)
+                         print*,'detr',detr(ig,l)
+                         print*,'masse',masse(ig,l)
+                         print*,'fomass_max',fomass_max
+                         print*,'masse(ig,l)*fomass_max/ptimestep',masse(ig,l)*fomass_max/ptimestep
+                         print*,'ptimestep',ptimestep
+                         print*,'lmax(ig)',lmax(ig)
+                         print*,'fm(ig,l+1)',fm(ig,l+1)
+                         print*,'fm(ig,l)',fm(ig,l)
+                         abort_message = 'probleme dans thermcell_flux'
+                         CALL abort_gcm (modname,abort_message,1)
+      endif
+      endif
+!                  
+!              ddd=detr(ig)-entre
+!on s assure que tout s annule bien en zmax
+      do ig=1,ngrid
+         fm(ig,lmax(ig)+1)=0.
+         entr(ig,lmax(ig))=0.
+         detr(ig,lmax(ig))=fm(ig,lmax(ig))+entr(ig,lmax(ig))
+      enddo
+
+!-----------------------------------------------------------------------
+! Impression du nombre de bidouilles qui ont ete necessaires
+!-----------------------------------------------------------------------
+
+!IM 090508 beg
+!     if (ncorecfm1+ncorecfm2+ncorecfm3+ncorecfm4+ncorecfm5+ncorecalpha > 0 ) then
+!
+!         print*,'PB thermcell : on a du coriger ',ncorecfm1,'x fm1',&
+!   &     ncorecfm2,'x fm2',ncorecfm3,'x fm3 et', &
+!   &     ncorecfm4,'x fm4',ncorecfm5,'x fm5 et', &
+!   &     ncorecfm6,'x fm6', &
+!   &     ncorecfm7,'x fm7', &
+!   &     ncorecfm8,'x fm8', &
+!   &     ncorecalpha,'x alpha'
+!     endif
+!IM 090508 end
+
+!      if (prt_level.ge.10) &
+!    &    call printflux(ngrid,klev,lunout1,igout,f,lmax,lalim, &
+!    &    ptimestep,masse,entr,detr,fm,'fin')
+
+
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_height.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_height.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_height.F90	(revision 17)
@@ -0,0 +1,163 @@
+      SUBROUTINE thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,  &
+     &           zw2,zlev,lmax,zmax,zmax0,zmix,wmax,lev_out)                            
+
+!-----------------------------------------------------------------------------
+!thermcell_height: calcul des caracteristiques du thermique: zmax,wmax,zmix
+!-----------------------------------------------------------------------------
+      IMPLICIT NONE
+#include "iniprint.h"
+#include "thermcell.h"
+
+      INTEGER ig,l
+      INTEGER ngrid,nlay
+      INTEGER lalim(ngrid),lmin(ngrid)
+      INTEGER lmix(ngrid)
+      REAL linter(ngrid)
+      integer lev_out                           ! niveau pour les print
+
+      REAL zw2(ngrid,nlay+1)
+      REAL zlev(ngrid,nlay+1)
+
+      REAL wmax(ngrid)
+      INTEGER lmax(ngrid)
+      REAL zmax(ngrid)
+      REAL zmax0(ngrid)
+      REAL zmix(ngrid)
+      REAL num(ngrid)
+      REAL denom(ngrid)
+
+      REAL zlevinter(ngrid)
+
+!calcul de la hauteur max du thermique
+      do ig=1,ngrid
+         lmax(ig)=lalim(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lalim(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+
+! On traite le cas particulier qu'il faudrait éviter ou le thermique
+! atteind le haut du modele ...
+      do ig=1,ngrid
+      if ( zw2(ig,nlay) > 1.e-10 ) then
+          print*,'WARNING !!!!! W2 thermiques non nul derniere couche '
+          lmax(ig)=nlay
+      endif
+      enddo
+
+! pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+             lmax(ig)=1
+             lmin(ig)=1
+             lalim(ig)=1
+         endif
+      enddo 
+!    
+! Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+
+      if (iflag_thermals_ed.ge.1) then
+
+         num(:)=0.
+         denom(:)=0.
+         do ig=1,ngrid
+          do l=1,nlay
+             num(ig)=num(ig)+zw2(ig,l)*zlev(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+             denom(ig)=denom(ig)+zw2(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+          enddo
+       enddo
+       do ig=1,ngrid
+       if (denom(ig).gt.1.e-10) then
+          zmax(ig)=2.*num(ig)/denom(ig)
+          zmax0(ig)=zmax(ig)
+       endif 
+       enddo
+
+       else
+
+      do  ig=1,ngrid
+! calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*  &
+     &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)  &
+     &    -zlev(ig,lmax(ig)))
+!pour le cas ou on prend tjs lmin=1
+!       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1))
+       zmax0(ig)=zmax(ig)
+      enddo
+
+
+      endif
+!endif iflag_thermals_ed
+!
+! def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1) then
+! test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
+     &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))  &
+     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
+     &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)  &
+     &        then
+!             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
+     &        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)  &
+     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
+     &        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))  &
+     &        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))  &
+     &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))  &
+     &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))  &
+     &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+              else
+              zmix(ig)=zlev(ig,lmix(ig))
+              print*,'pb zmix'
+              endif
+          else 
+              zmix(ig)=0.
+          endif
+!test
+         if ((zmax(ig)-zmix(ig)).le.0.) then
+            zmix(ig)=0.9*zmax(ig)
+!            print*,'pb zmix>zmax'
+         endif
+      enddo
+!
+! calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,nlay
+            if (zmix(ig).ge.zlev(ig,l).and.  &
+     &          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+!
+      return 
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_main.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_main.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_main.F90	(revision 17)
@@ -0,0 +1,1274 @@
+!
+! $Id: thermcell_main.F90 1795 2013-07-18 08:20:28Z emillour $
+!
+      SUBROUTINE thermcell_main(itap,ngrid,nlay,ptimestep  &
+     &                  ,pplay,pplev,pphi,debut  &
+     &                  ,pu,pv,pt,po  &
+     &                  ,pduadj,pdvadj,pdtadj,pdoadj  &
+     &                  ,fm0,entr0,detr0,zqta,zqla,lmax  &
+     &                  ,ratqscth,ratqsdiff,zqsatth  &
+     &                  ,Ale_bl,Alp_bl,lalim_conv,wght_th &
+     &                  ,zmax0, f0,zw2,fraca,ztv &
+     &                  ,zpspsk,ztla,zthl &
+!!! nrlmd le 10/04/2012
+     &                  ,pbl_tke,pctsrf,omega,airephy &
+     &                  ,zlcl,fraca0,w0,w_conv,therm_tke_max0,env_tke_max0 &
+     &                  ,n2,s2,ale_bl_stat &
+     &                  ,therm_tke_max,env_tke_max &
+     &                  ,alp_bl_det,alp_bl_fluct_m,alp_bl_fluct_tke &
+     &                  ,alp_bl_conv,alp_bl_stat &
+!!! fin nrlmd le 10/04/2012
+     &                  ,ztva  )
+
+      USE dimphy
+      USE ioipsl
+      USE comgeomphy , ONLY:rlond,rlatd
+      USE indice_sol_mod
+      IMPLICIT NONE
+
+!=======================================================================
+!   Auteurs: Frederic Hourdin, Catherine Rio, Anne Mathieu
+!   Version du 09.02.07
+!   Calcul du transport vertical dans la couche limite en presence
+!   de "thermiques" explicitement representes avec processus nuageux
+!
+!   Reecriture a partir d'un listing papier a Habas, le 14/02/00
+!
+!   le thermique est suppose homogene et dissipe par melange avec
+!   son environnement. la longueur l_mix controle l'efficacite du
+!   melange
+!
+!   Le calcul du transport des differentes especes se fait en prenant
+!   en compte:
+!     1. un flux de masse montant
+!     2. un flux de masse descendant
+!     3. un entrainement
+!     4. un detrainement
+!
+! Modif 2013/01/04 (FH hourdin@lmd.jussieu.fr)
+!    Introduction of an implicit computation of vertical advection in
+!    the environment of thermal plumes in thermcell_dq
+!    impl =     0 : explicit, 1 : implicit, -1 : old version
+!    controled by iflag_thermals =
+!       15, 16 run with impl=-1 : numerical convergence with NPv3
+!       17, 18 run with impl=1  : more stable
+!    15 and 17 correspond to the activation of the stratocumulus "bidouille"
+!
+!=======================================================================
+
+
+!-----------------------------------------------------------------------
+!   declarations:
+!   -------------
+
+#include "dimensions.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+#include "iniprint.h"
+#include "thermcell.h"
+
+!   arguments:
+!   ----------
+
+!IM 140508
+      INTEGER itap
+
+      INTEGER ngrid,nlay
+      real ptimestep
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+!   local:
+!   ------
+
+      integer icount
+
+      integer, save :: dvdq=1,dqimpl=-1
+!$OMP THREADPRIVATE(dvdq,dqimpl)
+      data icount/0/
+      save icount
+!$OMP THREADPRIVATE(icount)
+
+      integer,save :: igout=1
+!$OMP THREADPRIVATE(igout)
+      integer,save :: lunout1=6
+!$OMP THREADPRIVATE(lunout1)
+      integer,save :: lev_out=10
+!$OMP THREADPRIVATE(lev_out)
+
+      REAL susqr2pi, Reuler
+
+      INTEGER ig,k,l,ll,ierr
+      real zsortie1d(klon)
+      INTEGER lmax(klon),lmin(klon),lalim(klon)
+      INTEGER lmix(klon)
+      INTEGER lmix_bis(klon)
+      real linter(klon)
+      real zmix(klon)
+      real zmax(klon),zw2(klon,klev+1),ztva(klon,klev),zw_est(klon,klev+1),ztva_est(klon,klev)
+!      real fraca(klon,klev)
+
+      real zmax_sec(klon)
+!on garde le zmax du pas de temps precedent
+      real zmax0(klon)
+!FH/IM     save zmax0
+
+      real lambda
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      real deltaz(klon,klev)
+      REAL zh(klon,klev)
+      real zthl(klon,klev),zdthladj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      real zl(klon,klev)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zta(klon,klev)
+      real zha(klon,klev)
+      real fraca(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev),wth3(klon,klev)
+      real q2(klon,klev)
+! FH probleme de dimensionnement avec l'allocation dynamique
+!     common/comtherm/thetath2,wth2
+      real wq(klon,klev)
+      real wthl(klon,klev)
+      real wthv(klon,klev)
+    
+      real ratqscth(klon,klev)
+      real var
+      real vardiff
+      real ratqsdiff(klon,klev)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+      real wmax(klon)
+      real wmax_tmp(klon)
+      real wmax_sec(klon)
+      real fm0(klon,klev+1),entr0(klon,klev),detr0(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev),detr(klon,klev)
+
+      real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev)
+!niveau de condensation
+      integer nivcon(klon)
+      real zcon(klon)
+      REAL CHI
+      real zcon2(klon)
+      real pcon(klon)
+      real zqsat(klon,klev)
+      real zqsatth(klon,klev) 
+
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real detr_star(klon,klev)
+      real alim_star_tot(klon)
+      real alim_star(klon,klev)
+      real alim_star_clos(klon,klev)
+      real f(klon), f0(klon)
+!FH/IM     save f0
+      real zlevinter(klon)
+      logical debut
+       real seuil
+      real csc(klon,klev)
+
+!!! nrlmd le 10/04/2012
+
+!------Entrées
+      real pbl_tke(klon,klev+1,nbsrf)
+      real pctsrf(klon,nbsrf)
+      real omega(klon,klev)
+      real airephy(klon)
+!------Sorties
+      real zlcl(klon),fraca0(klon),w0(klon),w_conv(klon)
+      real therm_tke_max0(klon),env_tke_max0(klon)
+      real n2(klon),s2(klon)
+      real ale_bl_stat(klon)
+      real therm_tke_max(klon,klev),env_tke_max(klon,klev)
+      real alp_bl_det(klon),alp_bl_fluct_m(klon),alp_bl_fluct_tke(klon),alp_bl_conv(klon),alp_bl_stat(klon)
+!------Local
+      integer nsrf
+      real rhobarz0(klon)                    ! Densité au LCL
+      logical ok_lcl(klon)                   ! Existence du LCL des thermiques
+      integer klcl(klon)                     ! Niveau du LCL
+      real interp(klon)                      ! Coef d'interpolation pour le LCL
+!--Triggering
+      real Su                                ! Surface unité: celle d'un updraft élémentaire
+      parameter(Su=4e4)
+      real hcoef                             ! Coefficient directeur pour le calcul de s2
+      parameter(hcoef=1)
+      real hmincoef                          ! Coefficient directeur pour l'ordonnée à l'origine pour le calcul de s2 
+      parameter(hmincoef=0.3)
+      real eps1                              ! Fraction de surface occupée par la population 1 : eps1=n1*s1/(fraca0*Sd)
+      parameter(eps1=0.3)
+      real hmin(ngrid)                       ! Ordonnée à l'origine pour le calcul de s2
+      real zmax_moy(ngrid)                   ! Hauteur moyenne des thermiques : zmax_moy = zlcl + 0.33 (zmax-zlcl)
+      real zmax_moy_coef
+      parameter(zmax_moy_coef=0.33)
+      real depth(klon)                       ! Epaisseur moyenne du cumulus
+      real w_max(klon)                       ! Vitesse max statistique 
+      real s_max(klon)
+!--Closure
+      real pbl_tke_max(klon,klev)            ! Profil de TKE moyenne 
+      real pbl_tke_max0(klon)                ! TKE moyenne au LCL
+      real w_ls(klon,klev)                   ! Vitesse verticale grande échelle (m/s)
+      real coef_m                            ! On considère un rendement pour alp_bl_fluct_m
+      parameter(coef_m=1.)
+      real coef_tke                          ! On considère un rendement pour alp_bl_fluct_tke
+      parameter(coef_tke=1.)
+
+!!! fin nrlmd le 10/04/2012
+
+!
+      !nouvelles variables pour la convection
+      real Ale_bl(klon)
+      real Alp_bl(klon)
+      real alp_int(klon),dp_int(klon),zdp
+      real ale_int(klon)
+      integer n_int(klon)
+      real fm_tot(klon)
+      real wght_th(klon,klev)
+      integer lalim_conv(klon)
+!v1d     logical therm
+!v1d     save therm
+
+      character*2 str2
+      character*10 str10
+
+      character (len=20) :: modname='thermcell_main'
+      character (len=80) :: abort_message
+
+      EXTERNAL SCOPY
+!
+
+!-----------------------------------------------------------------------
+!   initialisation:
+!   ---------------
+!
+
+      seuil=0.25
+
+      if (debut)  then
+!        call getin('dvdq',dvdq)
+!        call getin('dqimpl',dqimpl)
+
+         if (iflag_thermals==15.or.iflag_thermals==16) then
+            dvdq=0
+            dqimpl=-1
+         else
+            dvdq=1
+            dqimpl=1
+         endif
+
+         fm0=0.
+         entr0=0.
+         detr0=0.
+
+
+#undef wrgrads_thermcell
+#ifdef wrgrads_thermcell
+! Initialisation des sorties grads pour les thermiques.
+! Pour l'instant en 1D sur le point igout.
+! Utilise par thermcell_out3d.h
+         str10='therm'
+         call inigrads(1,1,rlond(igout),1.,-180.,180.,jjm, &
+     &   rlatd(igout),-90.,90.,1.,llm,pplay(igout,:),1.,   &
+     &   ptimestep,str10,'therm ')
+#endif
+
+
+
+      endif
+
+      fm=0. ; entr=0. ; detr=0.
+
+
+      icount=icount+1
+
+!IM 090508 beg
+!print*,'====================================================================='
+!print*,'====================================================================='
+!print*,' PAS ',icount,' PAS ',icount,' PAS ',icount,' PAS ',icount
+!print*,'====================================================================='
+!print*,'====================================================================='
+!IM 090508 end
+
+      if (prt_level.ge.1) print*,'thermcell_main V4'
+
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+!
+!     write(lunout,*)'WARNING thermcell_main f0=max(f0,1.e-2)'
+     do ig=1,klon
+         f0(ig)=max(f0(ig),1.e-2)
+         zmax0(ig)=max(zmax0(ig),40.)
+!IMmarche pas ?!       if (f0(ig)<1.e-2) f0(ig)=1.e-2
+     enddo
+
+      if (prt_level.ge.20) then
+       do ig=1,ngrid
+          print*,'th_main ig f0',ig,f0(ig)
+       enddo
+      endif
+!-----------------------------------------------------------------------
+! Calcul de T,q,ql a partir de Tl et qT dans l environnement
+!   --------------------------------------------------------------------
+!
+      CALL thermcell_env(ngrid,nlay,po,pt,pu,pv,pplay,  &
+     &           pplev,zo,zh,zl,ztv,zthl,zu,zv,zpspsk,zqsat,lev_out)
+       
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_env'
+
+!------------------------------------------------------------------------
+!                       --------------------
+!
+!
+!                       + + + + + + + + + + +
+!
+!
+!  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+!  wh,wt,wo ...
+!
+!                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+!
+!
+!                       --------------------   zlev(1)
+!                       \\\\\\\\\\\\\\\\\\\\
+!
+!
+
+!-----------------------------------------------------------------------
+!   Calcul des altitudes des couches
+!-----------------------------------------------------------------------
+
+      do l=2,nlay
+         zlev(:,l)=0.5*(pphi(:,l)+pphi(:,l-1))/RG
+      enddo
+         zlev(:,1)=0.
+         zlev(:,nlay+1)=(2.*pphi(:,klev)-pphi(:,klev-1))/RG
+      do l=1,nlay
+         zlay(:,l)=pphi(:,l)/RG
+      enddo
+!calcul de l epaisseur des couches
+      do l=1,nlay
+         deltaz(:,l)=zlev(:,l+1)-zlev(:,l)
+      enddo
+
+!     print*,'2 OK convect8'
+!-----------------------------------------------------------------------
+!   Calcul des densites
+!-----------------------------------------------------------------------
+
+     rho(:,:)=pplay(:,:)/(zpspsk(:,:)*RD*ztv(:,:))
+
+     if (prt_level.ge.10)write(lunout,*)                                &
+    &    'WARNING thermcell_main rhobarz(:,1)=rho(:,1)'
+      rhobarz(:,1)=rho(:,1)
+
+      do l=2,nlay
+         rhobarz(:,l)=0.5*(rho(:,l)+rho(:,l-1))
+      enddo
+
+!calcul de la masse
+      do l=1,nlay
+         masse(:,l)=(pplev(:,l)-pplev(:,l+1))/RG
+      enddo
+
+      if (prt_level.ge.1) print*,'thermcell_main apres initialisation'
+
+!------------------------------------------------------------------
+!
+!             /|\
+!    --------  |  F_k+1 -------   
+!                              ----> D_k
+!             /|\              <---- E_k , A_k
+!    --------  |  F_k --------- 
+!                              ----> D_k-1
+!                              <---- E_k-1 , A_k-1
+!
+!
+!
+!
+!
+!    ---------------------------
+!
+!    ----- F_lmax+1=0 ----------         \
+!            lmax     (zmax)              |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------          |
+!                                         |  E
+!    ---------------------------          |  D
+!                                         |
+!    ---------------------------          |
+!                                         |
+!    ---------------------------  \       |
+!            lalim                 |      |
+!    ---------------------------   |      |
+!                                  |      |
+!    ---------------------------   |      |
+!                                  | A    |
+!    ---------------------------   |      |
+!                                  |      |
+!    ---------------------------   |      |
+!    lmin  (=1 pour le moment)     |      |
+!    ----- F_lmin=0 ------------  /      /
+!
+!    ---------------------------
+!    //////////////////////////
+!
+!
+!=============================================================================
+!  Calculs initiaux ne faisant pas intervenir les changements de phase
+!=============================================================================
+
+!------------------------------------------------------------------
+!  1. alim_star est le profil vertical de l'alimentation a la base du
+!     panache thermique, calcule a partir de la flotabilite de l'air sec
+!  2. lmin et lalim sont les indices inferieurs et superieurs de alim_star
+!------------------------------------------------------------------
+!
+      entr_star=0. ; detr_star=0. ; alim_star=0. ; alim_star_tot=0.
+      lmin=1
+
+!-----------------------------------------------------------------------------
+!  3. wmax_sec et zmax_sec sont les vitesses et altitudes maximum d'un
+!     panache sec conservatif (e=d=0) alimente selon alim_star 
+!     Il s'agit d'un calcul de type CAPE
+!     zmax_sec est utilise pour determiner la geometrie du thermique.
+!------------------------------------------------------------------------------
+!---------------------------------------------------------------------------------
+!calcul du melange et des variables dans le thermique
+!--------------------------------------------------------------------------------
+!
+      if (prt_level.ge.1) print*,'avant thermcell_plume ',lev_out
+!IM 140508   CALL thermcell_plume(ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,  &
+
+! Gestion temporaire de plusieurs appels à thermcell_plume au travers
+! de la variable iflag_thermals
+
+!      print*,'THERM thermcell_main iflag_thermals_ed=',iflag_thermals_ed
+      if (iflag_thermals_ed<=9) then
+!         print*,'THERM NOUVELLE/NOUVELLE Arnaud'
+         CALL thermcell_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,&
+     &    zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
+     &    lalim,f0,detr_star,entr_star,f_star,csc,ztva,  &
+     &    ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
+     &    ,lev_out,lunout1,igout)
+
+      elseif (iflag_thermals_ed>9) then
+!        print*,'THERM RIO et al 2010, version d Arnaud'
+         CALL thermcellV1_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,&
+     &    zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
+     &    lalim,f0,detr_star,entr_star,f_star,csc,ztva,  &
+     &    ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
+     &    ,lev_out,lunout1,igout)
+
+      endif
+
+      if (prt_level.ge.1) print*,'apres thermcell_plume ',lev_out
+
+      call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lalim ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_plum lmix  ')
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_plume'
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_main 2'
+         write(lunout1,*) 'lmin ',lmin(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) ' ig l alim_star entr_star detr_star f_star '
+         write(lunout1,'(i6,i4,4e15.5)') (igout,l,alim_star(igout,l),entr_star(igout,l),detr_star(igout,l) &
+     &    ,f_star(igout,l+1),l=1,nint(linter(igout))+5)
+      endif
+
+!-------------------------------------------------------------------------------
+! Calcul des caracteristiques du thermique:zmax,zmix,wmax
+!-------------------------------------------------------------------------------
+!
+      CALL thermcell_height(ngrid,nlay,lalim,lmin,linter,lmix,zw2,  &
+     &           zlev,lmax,zmax,zmax0,zmix,wmax,lev_out)
+! Attention, w2 est transforme en sa racine carree dans cette routine
+! Le probleme vient du fait que linter et lmix sont souvent égaux à 1.
+      wmax_tmp=0.
+      do  l=1,nlay
+         wmax_tmp(:)=max(wmax_tmp(:),zw2(:,l))
+      enddo
+!     print*,"ZMAX ",lalim,lmin,linter,lmix,lmax,zmax,zmax0,zmix,wmax
+
+
+
+      call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lalim ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmin ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmin  ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmix ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmix  ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_heig lmax  ')
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_height'
+
+!-------------------------------------------------------------------------------
+! Fermeture,determination de f
+!-------------------------------------------------------------------------------
+!
+!
+!!      write(lunout,*)'THERM NOUVEAU XXXXX'
+      CALL thermcell_dry(ngrid,nlay,zlev,pphi,ztv,alim_star,  &
+    &                      lalim,lmin,zmax_sec,wmax_sec,lev_out)
+
+call test_ltherm(ngrid,nlay,pplev,pplay,lmin,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry  lmin  ')
+call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_dry  lalim ')
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_dry'
+      if (prt_level.ge.10) then
+         write(lunout1,*) 'Dans thermcell_main 1b'
+         write(lunout1,*) 'lmin ',lmin(igout)
+         write(lunout1,*) 'lalim ',lalim(igout)
+         write(lunout1,*) ' ig l alim_star entr_star detr_star f_star '
+         write(lunout1,'(i6,i4,e15.5)') (igout,l,alim_star(igout,l) &
+     &    ,l=1,lalim(igout)+4)
+      endif
+
+
+
+
+! Choix de la fonction d'alimentation utilisee pour la fermeture.
+! Apparemment sans importance
+      alim_star_clos(:,:)=alim_star(:,:)
+      alim_star_clos(:,:)=entr_star(:,:)+alim_star(:,:)
+
+! Appel avec la version seche
+      CALL thermcell_closure(ngrid,nlay,r_aspect_thermals,ptimestep,rho,  &
+     &   zlev,lalim,alim_star_clos,f_star,zmax_sec,wmax_sec,f,lev_out)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Appel avec les zmax et wmax tenant compte de la condensation
+! Semble moins bien marcher
+!     CALL thermcell_closure(ngrid,nlay,r_aspect_thermals,ptimestep,rho,  &
+!    &   zlev,lalim,alim_star,f_star,zmax,wmax,f,lev_out)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      if(prt_level.ge.1)print*,'thermcell_closure apres thermcell_closure'
+
+      if (tau_thermals>1.) then
+         lambda=exp(-ptimestep/tau_thermals)
+         f0=(1.-lambda)*f+lambda*f0
+      else
+         f0=f
+      endif
+
+! Test valable seulement en 1D mais pas genant
+      if (.not. (f0(1).ge.0.) ) then
+              abort_message = '.not. (f0(1).ge.0.)'
+              CALL abort_gcm (modname,abort_message,1)
+      endif
+
+!-------------------------------------------------------------------------------
+!deduction des flux
+!-------------------------------------------------------------------------------
+
+      CALL thermcell_flux2(ngrid,nlay,ptimestep,masse, &
+     &       lalim,lmax,alim_star,  &
+     &       entr_star,detr_star,f,rhobarz,zlev,zw2,fm,entr,  &
+     &       detr,zqla,lev_out,lunout1,igout)
+!IM 060508    &       detr,zqla,zmax,lev_out,lunout,igout)
+
+      if (prt_level.ge.1) print*,'thermcell_main apres thermcell_flux'
+      call test_ltherm(ngrid,nlay,pplev,pplay,lalim,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lalim ')
+      call test_ltherm(ngrid,nlay,pplev,pplay,lmax ,seuil,ztv,po,ztva,zqla,f_star,zw2,'thermcell_flux lmax  ')
+
+!------------------------------------------------------------------
+!   On ne prend pas directement les profils issus des calculs precedents
+!   mais on s'autorise genereusement une relaxation vers ceci avec
+!   une constante de temps tau_thermals (typiquement 1800s).
+!------------------------------------------------------------------
+
+      if (tau_thermals>1.) then
+         lambda=exp(-ptimestep/tau_thermals)
+         fm0=(1.-lambda)*fm+lambda*fm0
+         entr0=(1.-lambda)*entr+lambda*entr0
+         detr0=(1.-lambda)*detr+lambda*detr0
+      else
+         fm0=fm
+         entr0=entr
+         detr0=detr
+      endif
+
+!c------------------------------------------------------------------
+!   calcul du transport vertical
+!------------------------------------------------------------------
+
+      call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse,  &
+     &                    zthl,zdthladj,zta,lev_out)
+      call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse,  &
+     &                   po,pdoadj,zoa,lev_out)
+
+!------------------------------------------------------------------
+! Calcul de la fraction de l'ascendance
+!------------------------------------------------------------------
+      do ig=1,klon
+         fraca(ig,1)=0.
+         fraca(ig,nlay+1)=0.
+      enddo
+      do l=2,nlay
+         do ig=1,klon
+            if (zw2(ig,l).gt.1.e-10) then
+            fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l))
+            else
+            fraca(ig,l)=0.
+            endif
+         enddo
+      enddo
+     
+!------------------------------------------------------------------
+!  calcul du transport vertical du moment horizontal
+!------------------------------------------------------------------
+
+!IM 090508  
+      if (dvdq == 0 ) then
+
+! Calcul du transport de V tenant compte d'echange par gradient
+! de pression horizontal avec l'environnement
+
+         call thermcell_dv2(ngrid,nlay,ptimestep,fm0,entr0,masse  &
+!    &    ,fraca*dvdq,zmax &
+     &    ,fraca,zmax &
+     &    ,zu,zv,pduadj,pdvadj,zua,zva,lev_out)
+
+      else
+
+! calcul purement conservatif pour le transport de V
+         call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse  &
+     &    ,zu,pduadj,zua,lev_out)
+         call thermcell_dq(ngrid,nlay,dqimpl,ptimestep,fm0,entr0,masse  &
+     &    ,zv,pdvadj,zva,lev_out)
+
+      endif
+
+!     print*,'13 OK convect8'
+      do l=1,nlay
+         do ig=1,ngrid
+           pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l)  
+         enddo
+      enddo
+
+      if (prt_level.ge.1) print*,'14 OK convect8'
+!------------------------------------------------------------------
+!   Calculs de diagnostiques pour les sorties
+!------------------------------------------------------------------
+!calcul de fraca pour les sorties
+      
+      if (sorties) then
+      if (prt_level.ge.1) print*,'14a OK convect8'
+! calcul du niveau de condensation
+! initialisation
+      do ig=1,ngrid
+         nivcon(ig)=0
+         zcon(ig)=0.
+      enddo 
+!nouveau calcul
+      do ig=1,ngrid
+      CHI=zh(ig,1)/(1669.0-122.0*zo(ig,1)/zqsat(ig,1)-zh(ig,1))
+      pcon(ig)=pplay(ig,1)*(zo(ig,1)/zqsat(ig,1))**CHI
+      enddo
+!IM   do k=1,nlay
+      do k=1,nlay-1
+         do ig=1,ngrid
+         if ((pcon(ig).le.pplay(ig,k))  &
+     &      .and.(pcon(ig).gt.pplay(ig,k+1))) then
+            zcon2(ig)=zlay(ig,k)-(pcon(ig)-pplay(ig,k))/(RG*rho(ig,k))/100.
+         endif
+         enddo
+      enddo
+!IM
+      ierr=0
+      do ig=1,ngrid
+        if (pcon(ig).le.pplay(ig,nlay)) then 
+           zcon2(ig)=zlay(ig,nlay)-(pcon(ig)-pplay(ig,nlay))/(RG*rho(ig,nlay))/100.
+           ierr=1
+        endif
+      enddo
+      if (ierr==1) then
+           abort_message = 'thermcellV0_main: les thermiques vont trop haut '
+           CALL abort_gcm (modname,abort_message,1)
+      endif
+
+      if (prt_level.ge.1) print*,'14b OK convect8'
+      do k=nlay,1,-1
+         do ig=1,ngrid
+            if (zqla(ig,k).gt.1e-10) then
+               nivcon(ig)=k
+               zcon(ig)=zlev(ig,k)
+            endif
+         enddo
+      enddo
+      if (prt_level.ge.1) print*,'14c OK convect8'
+!calcul des moments
+!initialisation
+      do l=1,nlay
+         do ig=1,ngrid
+            q2(ig,l)=0.
+            wth2(ig,l)=0.
+            wth3(ig,l)=0.
+            ratqscth(ig,l)=0.
+            ratqsdiff(ig,l)=0.
+         enddo
+      enddo      
+      if (prt_level.ge.1) print*,'14d OK convect8'
+      if (prt_level.ge.10)write(lunout,*)                                &
+    &     'WARNING thermcell_main wth2=0. si zw2 > 1.e-10'
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=fraca(ig,l)
+            zf2=zf/(1.-zf)
+!
+            thetath2(ig,l)=zf2*(ztla(ig,l)-zthl(ig,l))**2
+            if(zw2(ig,l).gt.1.e-10) then
+             wth2(ig,l)=zf2*(zw2(ig,l))**2
+            else
+             wth2(ig,l)=0.
+            endif
+            wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l))  &
+     &                *zw2(ig,l)*zw2(ig,l)*zw2(ig,l)
+            q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+!test: on calcul q2/po=ratqsc
+            ratqscth(ig,l)=sqrt(max(q2(ig,l),1.e-6)/(po(ig,l)*1000.))
+         enddo
+      enddo
+!calcul des flux: q, thetal et thetav
+      do l=1,nlay
+         do ig=1,ngrid
+      wq(ig,l)=fraca(ig,l)*zw2(ig,l)*(zqta(ig,l)*1000.-po(ig,l)*1000.)
+      wthl(ig,l)=fraca(ig,l)*zw2(ig,l)*(ztla(ig,l)-zthl(ig,l))
+      wthv(ig,l)=fraca(ig,l)*zw2(ig,l)*(ztva(ig,l)-ztv(ig,l))
+         enddo
+      enddo
+!
+
+!!! nrlmd le 10/04/2012
+
+!------------Test sur le LCL des thermiques
+    do ig=1,ngrid
+      ok_lcl(ig)=.false.
+      if ( (pcon(ig) .gt. pplay(ig,klev-1)) .and. (pcon(ig) .lt. pplay(ig,1)) ) ok_lcl(ig)=.true.
+    enddo
+
+!------------Localisation des niveaux entourant le LCL et du coef d'interpolation
+    do l=1,nlay-1
+      do ig=1,ngrid
+        if (ok_lcl(ig)) then 
+          if ((pplay(ig,l) .ge. pcon(ig)) .and. (pplay(ig,l+1) .le. pcon(ig))) then
+          klcl(ig)=l
+          interp(ig)=(pcon(ig)-pplay(ig,klcl(ig)))/(pplay(ig,klcl(ig)+1)-pplay(ig,klcl(ig)))
+          endif
+        endif
+      enddo
+    enddo
+
+!------------Hauteur des thermiques
+!!jyg le 27/04/2012
+!!    do ig =1,ngrid
+!!    rhobarz0(ig)=rhobarz(ig,klcl(ig))+(rhobarz(ig,klcl(ig)+1) &
+!! &               -rhobarz(ig,klcl(ig)))*interp(ig)
+!!    zlcl(ig)=(pplev(ig,1)-pcon(ig))/(rhobarz0(ig)*RG)
+!!    zmax(ig)=pphi(ig,lmax(ig))/rg
+!!      if ( (.not.ok_lcl(ig)) .or. (zlcl(ig).gt.zmax(ig)) ) zlcl(ig)=zmax(ig) ! Si zclc > zmax alors on pose zlcl = zmax
+!!    enddo
+    do ig =1,ngrid
+     zmax(ig)=pphi(ig,lmax(ig))/rg
+     if (ok_lcl(ig)) then 
+      rhobarz0(ig)=rhobarz(ig,klcl(ig))+(rhobarz(ig,klcl(ig)+1) &
+ &               -rhobarz(ig,klcl(ig)))*interp(ig)
+      zlcl(ig)=(pplev(ig,1)-pcon(ig))/(rhobarz0(ig)*RG)
+      zlcl(ig)=min(zlcl(ig),zmax(ig))   ! Si zlcl > zmax alors on pose zlcl = zmax
+     else
+      rhobarz0(ig)=0.
+      zlcl(ig)=zmax(ig)
+     endif
+    enddo
+!!jyg fin
+
+!------------Calcul des propriétés du thermique au LCL 
+  IF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) THEN 
+
+  !-----Initialisation de la TKE moyenne 
+   do l=1,nlay
+    do ig=1,ngrid
+     pbl_tke_max(ig,l)=0.
+    enddo
+   enddo
+
+!-----Calcul de la TKE moyenne 
+   do nsrf=1,nbsrf
+    do l=1,nlay
+     do ig=1,ngrid
+     pbl_tke_max(ig,l)=pctsrf(ig,nsrf)*pbl_tke(ig,l,nsrf)+pbl_tke_max(ig,l)
+     enddo
+    enddo
+   enddo
+
+!-----Initialisations des TKE dans et hors des thermiques 
+   do l=1,nlay
+    do ig=1,ngrid
+    therm_tke_max(ig,l)=pbl_tke_max(ig,l)
+    env_tke_max(ig,l)=pbl_tke_max(ig,l)
+    enddo
+   enddo
+
+!-----Calcul de la TKE transportée par les thermiques : therm_tke_max
+   call thermcell_tke_transport(ngrid,nlay,ptimestep,fm0,entr0,  &
+  &           rg,pplev,therm_tke_max)
+!   print *,' thermcell_tke_transport -> '   !!jyg
+
+!-----Calcul des profils verticaux de TKE hors thermiques : env_tke_max, et de la vitesse verticale grande échelle : W_ls
+   do l=1,nlay
+    do ig=1,ngrid
+     pbl_tke_max(ig,l)=fraca(ig,l)*therm_tke_max(ig,l)+(1.-fraca(ig,l))*env_tke_max(ig,l)         !  Recalcul de TKE moyenne aprés transport de TKE_TH
+     env_tke_max(ig,l)=(pbl_tke_max(ig,l)-fraca(ig,l)*therm_tke_max(ig,l))/(1.-fraca(ig,l))       !  Recalcul de TKE dans  l'environnement aprés transport de TKE_TH
+     w_ls(ig,l)=-1.*omega(ig,l)/(RG*rhobarz(ig,l))                                                !  Vitesse verticale de grande échelle
+    enddo
+   enddo
+!    print *,' apres w_ls = '   !!jyg
+
+  do ig=1,ngrid
+   if (ok_lcl(ig)) then
+     fraca0(ig)=fraca(ig,klcl(ig))+(fraca(ig,klcl(ig)+1) &
+ &             -fraca(ig,klcl(ig)))*interp(ig)
+     w0(ig)=zw2(ig,klcl(ig))+(zw2(ig,klcl(ig)+1) &
+ &         -zw2(ig,klcl(ig)))*interp(ig)
+     w_conv(ig)=w_ls(ig,klcl(ig))+(w_ls(ig,klcl(ig)+1) &
+ &             -w_ls(ig,klcl(ig)))*interp(ig)
+     therm_tke_max0(ig)=therm_tke_max(ig,klcl(ig)) &
+ &                     +(therm_tke_max(ig,klcl(ig)+1)-therm_tke_max(ig,klcl(ig)))*interp(ig)
+     env_tke_max0(ig)=env_tke_max(ig,klcl(ig))+(env_tke_max(ig,klcl(ig)+1) &
+ &                   -env_tke_max(ig,klcl(ig)))*interp(ig)
+     pbl_tke_max0(ig)=pbl_tke_max(ig,klcl(ig))+(pbl_tke_max(ig,klcl(ig)+1) &
+ &                   -pbl_tke_max(ig,klcl(ig)))*interp(ig)
+     if (therm_tke_max0(ig).ge.20.) therm_tke_max0(ig)=20.
+     if (env_tke_max0(ig).ge.20.) env_tke_max0(ig)=20.
+     if (pbl_tke_max0(ig).ge.20.) pbl_tke_max0(ig)=20.
+   else 
+     fraca0(ig)=0.
+     w0(ig)=0.
+!!jyg le 27/04/2012
+!!     zlcl(ig)=0.
+!!
+   endif
+  enddo
+
+  ENDIF ! IF ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) )
+!  print *,'ENDIF  ( (iflag_trig_bl.ge.1) .or. (iflag_clos_bl.ge.1) ) '    !!jyg
+
+!------------Triggering------------------
+  IF (iflag_trig_bl.ge.1) THEN 
+
+!-----Initialisations
+   depth(:)=0.
+   n2(:)=0.
+   s2(:)=0.
+   s_max(:)=0.
+
+!-----Epaisseur du nuage (depth) et détermination de la queue du spectre de panaches (n2,s2) et du panache le plus gros (s_max)
+   do ig=1,ngrid
+     zmax_moy(ig)=zlcl(ig)+zmax_moy_coef*(zmax(ig)-zlcl(ig))
+     depth(ig)=zmax_moy(ig)-zlcl(ig)
+     hmin(ig)=hmincoef*zlcl(ig)
+     if (depth(ig).ge.10.) then 
+       s2(ig)=(hcoef*depth(ig)+hmin(ig))**2
+       n2(ig)=(1.-eps1)*fraca0(ig)*airephy(ig)/s2(ig)
+!!
+!!jyg le 27/04/2012
+!!       s_max(ig)=s2(ig)*log(n2(ig))
+!!       if (n2(ig) .lt. 1) s_max(ig)=0.
+       s_max(ig)=s2(ig)*log(max(n2(ig),1.))
+!!fin jyg
+     else
+       s2(ig)=0.
+       n2(ig)=0.
+       s_max(ig)=0.
+     endif
+   enddo
+!   print *,'avant Calcul de Wmax '    !!jyg
+
+!-----Calcul de Wmax et ALE_BL_STAT associée
+!!jyg le 30/04/2012
+!!   do ig=1,ngrid
+!!     if ( (depth(ig).ge.10.) .and. (s_max(ig).gt.1.) ) then
+!!     w_max(ig)=w0(ig)*(1.+sqrt(2.*log(s_max(ig)/su)-log(2.*3.14)-log(2.*log(s_max(ig)/su)-log(2.*3.14))))
+!!     ale_bl_stat(ig)=0.5*w_max(ig)**2
+!!     else
+!!     w_max(ig)=0.
+!!     ale_bl_stat(ig)=0.
+!!     endif
+!!   enddo
+   susqr2pi=su*sqrt(2.*Rpi)
+   Reuler=exp(1.)
+   do ig=1,ngrid
+     if ( (depth(ig).ge.10.) .and. (s_max(ig).gt.susqr2pi*Reuler) ) then
+      w_max(ig)=w0(ig)*(1.+sqrt(2.*log(s_max(ig)/susqr2pi)-log(2.*log(s_max(ig)/susqr2pi))))
+      ale_bl_stat(ig)=0.5*w_max(ig)**2
+     else
+      w_max(ig)=0.
+      ale_bl_stat(ig)=0.
+     endif
+   enddo
+
+  ENDIF ! iflag_trig_bl
+!  print *,'ENDIF  iflag_trig_bl'    !!jyg
+
+!------------Closure------------------
+
+  IF (iflag_clos_bl.ge.1) THEN 
+
+!-----Calcul de ALP_BL_STAT
+  do ig=1,ngrid
+  alp_bl_det(ig)=0.5*coef_m*rhobarz0(ig)*(w0(ig)**3)*fraca0(ig)*(1.-2.*fraca0(ig))/((1.-fraca0(ig))**2)
+  alp_bl_fluct_m(ig)=1.5*rhobarz0(ig)*fraca0(ig)*(w_conv(ig)+coef_m*w0(ig))* &
+ &                   (w0(ig)**2)
+  alp_bl_fluct_tke(ig)=3.*coef_m*rhobarz0(ig)*w0(ig)*fraca0(ig)*(therm_tke_max0(ig)-env_tke_max0(ig)) &
+ &                    +3.*rhobarz0(ig)*w_conv(ig)*pbl_tke_max0(ig)
+    if (iflag_clos_bl.ge.2) then 
+    alp_bl_conv(ig)=1.5*coef_m*rhobarz0(ig)*fraca0(ig)*(fraca0(ig)/(1.-fraca0(ig)))*w_conv(ig)* &
+ &                   (w0(ig)**2)
+    else
+    alp_bl_conv(ig)=0.
+    endif
+  alp_bl_stat(ig)=alp_bl_det(ig)+alp_bl_fluct_m(ig)+alp_bl_fluct_tke(ig)+alp_bl_conv(ig)
+  enddo
+
+!-----Sécurité ALP infinie
+  do ig=1,ngrid
+   if (fraca0(ig).gt.0.98) alp_bl_stat(ig)=2.
+  enddo
+
+  ENDIF ! (iflag_clos_bl.ge.1)
+
+!!! fin nrlmd le 10/04/2012
+
+      if (prt_level.ge.10) then
+         ig=igout
+         do l=1,nlay
+            print*,'14f OK convect8 ig,l,zha zh zpspsk ',ig,l,zha(ig,l),zh(ig,l),zpspsk(ig,l)
+            print*,'14g OK convect8 ig,l,po',ig,l,po(ig,l)
+         enddo
+      endif
+
+!      print*,'avant calcul ale et alp' 
+!calcul de ALE et ALP pour la convection
+      Alp_bl(:)=0.
+      Ale_bl(:)=0.
+!          print*,'ALE,ALP ,l,zw2(ig,l),Ale_bl(ig),Alp_bl(ig)'
+      do l=1,nlay
+      do ig=1,ngrid
+           Alp_bl(ig)=max(Alp_bl(ig),0.5*rhobarz(ig,l)*wth3(ig,l) )
+           Ale_bl(ig)=max(Ale_bl(ig),0.5*zw2(ig,l)**2)
+!          print*,'ALE,ALP',l,zw2(ig,l),Ale_bl(ig),Alp_bl(ig)
+      enddo
+      enddo
+
+!test:calcul de la ponderation des couches pour KE
+!initialisations
+
+      fm_tot(:)=0.
+      wght_th(:,:)=1.
+      lalim_conv(:)=lalim(:)
+
+      do k=1,klev
+         do ig=1,ngrid
+            if (k<=lalim_conv(ig)) fm_tot(ig)=fm_tot(ig)+fm(ig,k)
+         enddo
+      enddo
+
+! assez bizarre car, si on est dans la couche d'alim et que alim_star et
+! plus petit que 1.e-10, on prend wght_th=1.
+      do k=1,klev
+         do ig=1,ngrid
+            if (k<=lalim_conv(ig).and.alim_star(ig,k)>1.e-10) then
+               wght_th(ig,k)=alim_star(ig,k)
+            endif
+         enddo
+      enddo
+
+!      print*,'apres wght_th'
+!test pour prolonger la convection
+      do ig=1,ngrid
+!v1d  if ((alim_star(ig,1).lt.1.e-10).and.(therm)) then
+      if ((alim_star(ig,1).lt.1.e-10)) then
+      lalim_conv(ig)=1
+      wght_th(ig,1)=1.
+!      print*,'lalim_conv ok',lalim_conv(ig),wght_th(ig,1)
+      endif
+      enddo
+
+!------------------------------------------------------------------------
+! Modif CR/FH 20110310 : Alp integree sur la verticale.
+! Integrale verticale de ALP.
+! wth3 etant aux niveaux inter-couches, on utilise d play comme masse des
+! couches
+!------------------------------------------------------------------------
+
+      alp_int(:)=0.
+      dp_int(:)=0.
+      do l=2,nlay
+        do ig=1,ngrid
+           if(l.LE.lmax(ig)) THEN
+           zdp=pplay(ig,l-1)-pplay(ig,l)
+           alp_int(ig)=alp_int(ig)+0.5*rhobarz(ig,l)*wth3(ig,l)*zdp
+           dp_int(ig)=dp_int(ig)+zdp
+           endif
+        enddo
+      enddo
+
+      if (iflag_coupl>=3 .and. iflag_coupl<=5) then
+      do ig=1,ngrid
+!valeur integree de alp_bl * 0.5:
+        if (dp_int(ig)>0.) then
+        Alp_bl(ig)=alp_int(ig)/dp_int(ig)
+        endif
+      enddo!
+      endif
+
+
+! Facteur multiplicatif sur Alp_bl
+      Alp_bl(:)=alp_bl_k*Alp_bl(:)
+
+!------------------------------------------------------------------------
+
+
+!calcul du ratqscdiff
+      if (prt_level.ge.1) print*,'14e OK convect8'
+      var=0.
+      vardiff=0.
+      ratqsdiff(:,:)=0.
+
+      do l=1,klev
+         do ig=1,ngrid
+            if (l<=lalim(ig)) then
+            var=var+alim_star(ig,l)*zqta(ig,l)*1000.
+            endif
+         enddo
+      enddo
+
+      if (prt_level.ge.1) print*,'14f OK convect8'
+
+      do l=1,klev
+         do ig=1,ngrid
+            if (l<=lalim(ig)) then
+               zf=fraca(ig,l)
+               zf2=zf/(1.-zf)
+               vardiff=vardiff+alim_star(ig,l)*(zqta(ig,l)*1000.-var)**2
+            endif
+         enddo
+      enddo
+
+      if (prt_level.ge.1) print*,'14g OK convect8'
+      do l=1,nlay
+         do ig=1,ngrid
+            ratqsdiff(ig,l)=sqrt(vardiff)/(po(ig,l)*1000.)   
+!           write(11,*)'ratqsdiff=',ratqsdiff(ig,l)
+         enddo
+      enddo 
+!--------------------------------------------------------------------    
+!
+!ecriture des fichiers sortie
+!     print*,'15 OK convect8 CCCCCCCCCCCCCCCCCCc'
+
+#ifdef wrgrads_thermcell
+      if (prt_level.ge.1) print*,'thermcell_main sorties 3D'
+#include "thermcell_out3d.h"
+#endif
+
+      endif
+
+      if (prt_level.ge.1) print*,'thermcell_main FIN  OK'
+
+      return
+      end
+
+!-----------------------------------------------------------------------------
+
+      subroutine test_ltherm(klon,klev,pplev,pplay,long,seuil,ztv,po,ztva,zqla,f_star,zw2,comment)
+      IMPLICIT NONE
+#include "iniprint.h"
+
+      integer i, k, klon,klev
+      real pplev(klon,klev+1),pplay(klon,klev)
+      real ztv(klon,klev)
+      real po(klon,klev)
+      real ztva(klon,klev)
+      real zqla(klon,klev)
+      real f_star(klon,klev)
+      real zw2(klon,klev)
+      integer long(klon)
+      real seuil
+      character*21 comment
+
+      if (prt_level.ge.1) THEN
+       print*,'WARNING !!! TEST ',comment
+      endif
+      return
+
+!  test sur la hauteur des thermiques ...
+         do i=1,klon
+!IMtemp           if (pplay(i,long(i)).lt.seuil*pplev(i,1)) then
+           if (prt_level.ge.10) then
+               print*,'WARNING ',comment,' au point ',i,' K= ',long(i)
+               print*,'  K  P(MB)  THV(K)     Qenv(g/kg)THVA        QLA(g/kg)   F*        W2'
+               do k=1,klev
+                  write(6,'(i3,7f10.3)') k,pplay(i,k),ztv(i,k),1000*po(i,k),ztva(i,k),1000*zqla(i,k),f_star(i,k),zw2(i,k)
+               enddo
+           endif
+         enddo
+
+
+      return
+      end
+
+!!! nrlmd le 10/04/2012                          Transport de la TKE par le thermique moyen pour la fermeture en ALP 
+!                                                         On transporte pbl_tke pour donner therm_tke
+!                                          Copie conforme de la subroutine DTKE dans physiq.F écrite par Frederic Hourdin
+      subroutine thermcell_tke_transport(ngrid,nlay,ptimestep,fm0,entr0,  &
+     &           rg,pplev,therm_tke_max)
+      implicit none
+
+#include "iniprint.h"
+!=======================================================================
+!
+!   Calcul du transport verticale dans la couche limite en presence
+!   de "thermiques" explicitement representes
+!   calcul du dq/dt une fois qu'on connait les ascendances
+!
+!=======================================================================
+
+      integer ngrid,nlay,nsrf
+
+      real ptimestep
+      real masse0(ngrid,nlay),fm0(ngrid,nlay+1),pplev(ngrid,nlay+1)
+      real entr0(ngrid,nlay),rg
+      real therm_tke_max(ngrid,nlay)
+      real detr0(ngrid,nlay)
+
+
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay)
+      real q(ngrid,nlay)
+      integer lev_out                           ! niveau pour les print
+
+      real qa(ngrid,nlay),detr(ngrid,nlay),wqd(ngrid,nlay+1)
+
+      real zzm
+
+      integer ig,k
+      integer isrf
+
+
+      lev_out=0
+
+
+      if (prt_level.ge.1) print*,'Q2 THERMCEL_DQ 0'
+
+!   calcul du detrainement
+      do k=1,nlay
+         detr0(:,k)=fm0(:,k)-fm0(:,k+1)+entr0(:,k)
+         masse0(:,k)=(pplev(:,k)-pplev(:,k+1))/RG
+      enddo
+
+
+! Decalage vertical des entrainements et detrainements.
+      masse(:,1)=0.5*masse0(:,1)
+      entr(:,1)=0.5*entr0(:,1)
+      detr(:,1)=0.5*detr0(:,1)
+      fm(:,1)=0.
+      do k=1,nlay-1
+         masse(:,k+1)=0.5*(masse0(:,k)+masse0(:,k+1))
+         entr(:,k+1)=0.5*(entr0(:,k)+entr0(:,k+1))
+         detr(:,k+1)=0.5*(detr0(:,k)+detr0(:,k+1))
+         fm(:,k+1)=fm(:,k)+entr(:,k)-detr(:,k)
+      enddo
+      fm(:,nlay+1)=0.
+
+!!! nrlmd le 16/09/2010
+!   calcul de la valeur dans les ascendances
+!       do ig=1,ngrid
+!          qa(ig,1)=q(ig,1)
+!       enddo
+!!! 
+
+!do isrf=1,nsrf
+
+!   q(:,:)=therm_tke(:,:,isrf)
+   q(:,:)=therm_tke_max(:,:)
+!!! nrlmd le 16/09/2010
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+      enddo
+!!!
+
+    if (1==1) then
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.  &
+     &         1.e-5*masse(ig,k)) then
+         qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))  &
+     &         /(fm(ig,k+1)+detr(ig,k))
+            else
+               qa(ig,k)=q(ig,k)
+            endif
+            if (qa(ig,k).lt.0.) then
+!               print*,'qa<0!!!'
+            endif
+            if (q(ig,k).lt.0.) then
+!               print*,'q<0!!!'
+            endif
+         enddo
+      enddo
+
+! Calcul du flux subsident
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wqd(ig,k)=fm(ig,k)*q(ig,k)
+            if (wqd(ig,k).lt.0.) then
+!               print*,'wqd<0!!!'
+            endif
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+
+! Calcul des tendances
+      do k=1,nlay
+         do ig=1,ngrid
+            q(ig,k)=q(ig,k)+(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)  &
+     &               -wqd(ig,k)+wqd(ig,k+1))  &
+     &               *ptimestep/masse(ig,k)
+         enddo
+      enddo
+
+ endif
+
+   therm_tke_max(:,:)=q(:,:)
+
+      return
+!!! fin nrlmd le 10/04/2012
+     end
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_old.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_old.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_old.F	(revision 17)
@@ -0,0 +1,6154 @@
+      SUBROUTINE thermcell_2002(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di
+      REAL tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+c$OMP THREADPRIVATE(idetr)
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmax(klon,klev+1),lmaxa(klon),lmix(klon)
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+c$OMP THREADPRIVATE(isplit)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+      real wmax(klon,klev),wmaxa(klon)
+
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+      character (len=2) :: str2
+      character (len=10) :: str10
+
+      character (len=20) :: modname='thermcell2002'
+      character (len=80) :: abort_message
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+c$OMP THREADPRIVATE(ncorrec)
+
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+      print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+c     print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c     print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c     print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+
+      do k=1,nlay-1
+         do ig=1,ngrid
+            wa(ig,k,k)=0.
+            wa(ig,k,k+1)=2.*RG*(ztv(ig,k)-ztv(ig,k+1))/ztv(ig,k+1)
+     s      *(zlev(ig,k+1)-zlev(ig,k))
+         enddo
+         do l=k+1,nlay-1
+            do ig=1,ngrid
+               wa(ig,k,l+1)=wa(ig,k,l)+
+     s         2.*RG*(ztv(ig,k)-ztv(ig,l))/ztv(ig,l)
+     s         *(zlev(ig,l+1)-zlev(ig,l))
+            enddo
+         enddo
+         do ig=1,ngrid
+            wa(ig,k,nlay+1)=0.
+         enddo
+      enddo
+
+c     print*,'4 OK convect8'
+c Calcul de la couche correspondant a la hauteur du thermique
+      do k=1,nlay-1
+         do ig=1,ngrid
+            lmax(ig,k)=k
+         enddo
+         do l=nlay,k+1,-1
+            do ig=1,ngrid
+               if(wa(ig,k,l).le.1.e-10) lmax(ig,k)=l-1
+            enddo
+         enddo
+      enddo
+
+c     print*,'5 OK convect8'
+c   Calcule du w max du thermique
+      do k=1,nlay
+      do ig=1,ngrid
+         wmax(ig,k)=0.
+      enddo
+      enddo
+
+      do k=1,nlay-1
+         do l=k,nlay
+            do ig=1,ngrid
+               if (l.le.lmax(ig,k)) then
+                  wa(ig,k,l)=sqrt(wa(ig,k,l))
+                  wmax(ig,k)=max(wmax(ig,k),wa(ig,k,l))
+               else
+                  wa(ig,k,l)=0.
+               endif
+            enddo
+         enddo
+      enddo
+
+      do k=1,nlay-1
+         do ig=1,ngrid
+             pu_therm(ig,k)=sqrt(wmax(ig,k))
+             pv_therm(ig,k)=sqrt(wmax(ig,k))
+         enddo
+      enddo
+
+c     print*,'6 OK convect8'
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=500.
+      enddo
+c     print*,'LMAX LMAX LMAX '
+      do k=1,nlay-1
+         do  ig=1,ngrid
+            zmax(ig)=max(zmax(ig),zlev(ig,lmax(ig,k))-zlev(ig,k))
+         enddo
+c     print*,k,lmax(1,k)
+      enddo
+c     print*,'ZMAX ZMAX ZMAX ',zmax
+c      call dump2d(iim,jjm-1,zmax(2:ngrid-1),'ZMAX      ')
+
+c   Calcul de l'entrainement.
+c   Le rapport d'aspect relie la largeur de l'ascendance a l'epaisseur
+c   de la couche d'alimentation en partant du principe que la vitesse
+c   maximum dans l'ascendance est la vitesse d'entrainement horizontale.
+      do k=1,nlay
+         do ig=1,ngrid
+            zzz=rho(ig,k)*wmax(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+     s    /(zmax(ig)*r_aspect)
+            if(w2di.eq.2) then
+               entr(ig,k)=entr(ig,k)+
+     s         ptimestep*(zzz-entr(ig,k))/tho
+            else
+               entr(ig,k)=zzz
+            endif
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+
+c     print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c     print*,'8 OK convect8'
+      do ig=1,ngrid
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+
+      do l=1,nlay-2
+         do ig=1,ngrid
+c           if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1)) then
+c         print*,'COUCOU ',l,zw2(ig,l),ztv(ig,l),ztv(ig,l+1)
+            if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1)
+     s       .and.entr(ig,l).gt.1.e-10) then
+c        print*,'COUCOU cas 1'
+c   Initialisation de l'ascendance
+c              lmix(ig)=1
+               ztva(ig,l)=ztv(ig,l)
+               fmc(ig,l)=0.
+               fmc(ig,l+1)=entr(ig,l)
+               zw2(ig,l)=0.
+c     if (.not.ztv(ig,l+1).gt.150.) then
+c     print*,'ig,l+1,ztv(ig,l+1)'
+c     print*, ig,l+1,ztv(ig,l+1)
+c     endif
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s         *(zlev(ig,l+1)-zlev(ig,l))
+               larg_detr(ig,l)=0.
+            else if (zw2(ig,l).ge.1.e-10.and.
+     .               fmc(ig,l)+entr(ig,l).gt.1.e-10) then
+c   Incrementation...
+               fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+c     if (.not.fmc(ig,l+1).gt.1.e-15) then
+c     print*,'ig,l+1,fmc(ig,l+1)'
+c     print*, ig,l+1,fmc(ig,l+1)
+c     print*,'Fmc ',(fmc(ig,ll),ll=1,klev+1)
+c     print*,'W2 ',(zw2(ig,ll),ll=1,klev+1)
+c     print*,'Tv ',(ztv(ig,ll),ll=1,klev)
+c     print*,'Entr ',(entr(ig,ll),ll=1,klev)
+c     endif
+               ztva(ig,l)=(fmc(ig,l)*ztva(ig,l-1)+entr(ig,l)*ztv(ig,l))
+     s          /fmc(ig,l+1)
+c  mise a jour de la vitesse ascendante (l'air entraine de la couche
+c  consideree commence avec une vitesse nulle).
+               zw2(ig,l+1)=zw2(ig,l)*(fmc(ig,l)/fmc(ig,l+1))**2+
+     s         2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s         *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+            if (zw2(ig,l+1).lt.0.) then
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+c        print*,'COUCOU cas 2 LMIX=',lmix(ig),wa_moy(ig,l+1),wmaxa(ig)
+         enddo
+      enddo
+
+c     print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c     print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+               if(l.gt.lmix(ig)) then
+                  xxx(ig,l)=(lmaxa(ig)+1.-l) / (lmaxa(ig)+1.-lmix(ig))
+           if (idetr.eq.0) then
+               fraca(ig,l)=fraca(ig,lmix(ig))
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fraca(ig,lmix(ig))*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fraca(ig,lmix(ig))*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fraca(ig,lmix(ig))*xxx(ig,l)**2
+           endif
+               endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo
+
+c     print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+              abort_message = 'fracd trop petit'
+              CALL abort_gcm (modname,abort_message,1) 
+           else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+c     print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/tho
+         entr0=entr0+ptimestep*(entr-entr0)/tho
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+c     print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+c     print*,'19 OK convect8'
+      return
+      end
+
+      SUBROUTINE thermcell_cld(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi,zlev,debut
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0,zqla,lmax
+     s                  ,zmax_sec,wmax_sec,zw_sec,lmix_sec
+     s                  ,ratqscth,ratqsdiff
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di
+      REAL tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+c$OMP THREADPRIVATE(idetr)
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon)
+      real alpha
+      save alpha
+      data alpha/1./
+c$OMP THREADPRIVATE(alpha)
+
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+      real zmax_sec(klon)
+      real zmax_sec2(klon)
+      real zw_sec(klon,klev+1)
+      INTEGER lmix_sec(klon)
+      real w_est(klon,klev+1)
+con garde le zmax du pas de temps precedent
+c      real zmax0(klon)
+c      save zmax0
+c      real zmix0(klon)
+c      save zmix0 
+      REAL, SAVE, ALLOCATABLE :: zmax0(:), zmix0(:)
+c$OMP THREADPRIVATE(zmax0, zmix0)
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      real deltaz(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      real zthl(klon,klev),zdthladj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      real zl(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zta(klon,klev)
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev),wth3(klon,klev)
+      real q2(klon,klev)
+      real dtheta(klon,klev)
+!      common/comtherm/thetath2,wth2
+    
+      real ratqscth(klon,klev)
+      real sum
+      real sumdiff
+      real ratqsdiff(klon,klev)
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+c$OMP THREADPRIVATE(isplit)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wmax_sec(klon)
+      real wmax_sec2(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real massetot(klon,klev)
+      real detr0(klon,klev)
+      real alim0(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef(klon),qsatbef(klon)
+      real dqsat_dT,DT,num,denom
+      REAL REPS,RLvCp,DDT0
+      real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev)
+cCR niveau de condensation
+      real nivcon(klon)
+      real zcon(klon)
+      real zqsat(klon,klev)
+      real zqsatth(klon,klev) 
+      PARAMETER (DDT0=.01)
+
+
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real detr_star(klon,klev)
+      real alim_star_tot(klon),alim_star2(klon)
+      real entr_star_tot(klon)
+      real detr_star_tot(klon)
+      real alim_star(klon,klev)
+      real alim(klon,klev)
+      real nu(klon,klev)
+      real nu_e(klon,klev)
+      real nu_min
+      real nu_max
+      real nu_r
+      real f(klon)
+c      real f(klon), f0(klon)
+c     save f0
+      REAL,SAVE, ALLOCATABLE :: f0(:)
+c$OMP THREADPRIVATE(f0)
+
+      real f_old
+      real zlevinter(klon)
+      logical, save :: first = .true.
+c$OMP THREADPRIVATE(first)
+c      data first /.false./
+c      save first
+      logical nuage
+c      save nuage
+      logical boucle
+      logical therm
+      logical debut
+      logical rale
+      integer test(klon)
+      integer signe_zw2
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      character (len=20) :: modname='thermcell_cld'
+      character (len=80) :: abort_message
+
+      LOGICAL vtest(klon),down
+      LOGICAL Zsat(klon)
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+c$OMP THREADPRIVATE(ncorrec)
+
+c
+
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+      if (first) then
+        allocate(zmix0(klon))
+        allocate(zmax0(klon))
+        allocate(f0(klon))
+        first=.false.
+      endif
+
+       sorties=.false.
+c     print*,'NOUVEAU DETR PLUIE '
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c Initialisation
+      RLvCp = RLVTT/RCPD
+      REPS  = RD/RV
+cinitialisations de zqsat
+      DO ll=1,nlay
+         DO ig=1,ngrid
+            zqsat(ig,ll)=0.
+            zqsatth(ig,ll)=0.
+         ENDDO
+      ENDDO
+c
+con met le first a true pour le premier passage de la journée
+      do ig=1,klon
+            test(ig)=0
+      enddo
+      if (debut) then
+         do ig=1,klon
+            test(ig)=1
+            f0(ig)=0.
+            zmax0(ig)=0.
+         enddo
+      endif
+      do ig=1,klon      
+         if ((.not.debut).and.(f0(ig).lt.1.e-10)) then
+            test(ig)=1
+         endif
+      enddo 
+c     do ig=1,klon
+c        print*,'test(ig)',test(ig),zmax0(ig)
+c     enddo
+      nuage=.false.
+c-----------------------------------------------------------------------
+cAM Calcul de T,q,ql a partir de Tl et qT
+c   ---------------------------------------------------
+c
+c Pr Tprec=Tl calcul de qsat 
+c Si qsat>qT T=Tl, q=qT
+c Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) 
+c On cherche DDT < DDT0
+c
+c defaut
+       DO  ll=1,nlay
+         DO ig=1,ngrid
+            zo(ig,ll)=po(ig,ll)
+            zl(ig,ll)=0.
+            zh(ig,ll)=pt(ig,ll)
+         EndDO
+       EndDO
+       do ig=1,ngrid
+          Zsat(ig)=.false.
+       enddo
+c
+c
+       DO ll=1,nlay
+c les points insatures sont definitifs
+         DO ig=1,ngrid
+            Tbef(ig)=pt(ig,ll)
+            zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+            qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+            qsatbef(ig)=MIN(0.5,qsatbef(ig))
+            zcor=1./(1.-retv*qsatbef(ig))
+            qsatbef(ig)=qsatbef(ig)*zcor
+            Zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig)) .gt. 1.e-10)
+         EndDO
+
+         DO ig=1,ngrid
+           if (Zsat(ig).and.(1.eq.1)) then
+            qlbef=max(0.,po(ig,ll)-qsatbef(ig))
+c si sature: ql est surestime, d'ou la sous-relax
+            DT = 0.5*RLvCp*qlbef
+c            write(18,*),'DT0=',DT
+c on pourra enchainer 2 ou 3 calculs sans Do while
+            do while (abs(DT).gt.DDT0)
+c il faut verifier si c,a conserve quand on repasse en insature ...
+              Tbef(ig)=Tbef(ig)+DT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+              qsatbef(ig)=MIN(0.5,qsatbef(ig))
+              zcor=1./(1.-retv*qsatbef(ig))
+              qsatbef(ig)=qsatbef(ig)*zcor
+c on veut le signe de qlbef
+              qlbef=po(ig,ll)-qsatbef(ig)
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+              zcor=1./(1.-retv*qsatbef(ig))
+              dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+              num=-Tbef(ig)+pt(ig,ll)+RLvCp*qlbef
+              denom=1.+RLvCp*dqsat_dT
+              if (denom.lt.1.e-10) then
+                  print*,'pb denom'
+              endif
+              DT=num/denom
+            enddo
+c on ecrit de maniere conservative (sat ou non)
+            zl(ig,ll) = max(0.,qlbef)
+c          T = Tl +Lv/Cp ql
+            zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)
+            zo(ig,ll) = po(ig,ll)-zl(ig,ll)
+           endif
+con ecrit zqsat 
+            zqsat(ig,ll)=qsatbef(ig)     
+         EndDO
+       EndDO
+cAM fin
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+c     print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+             zpspsk(ig,l)=(pplay(ig,l)/100000.)**RKAPPA
+c            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+c            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+c            zo(ig,l)=po(ig,l)
+c            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+cAM attention zh est maintenant le profil de T et plus le profil de theta !
+c
+c   T-> Theta
+            ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+cAM Theta_v
+            ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l))
+     s           -zl(ig,l))
+cAM Thetal
+            zthl(ig,l)=pt(ig,l)/zpspsk(ig,l)
+c            
+1015     CONTINUE
+1010  CONTINUE
+
+c     print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+ccalcul de deltaz
+      do l=1,nlay
+         do ig=1,ngrid
+            deltaz(ig,l)=zlev(ig,l+1)-zlev(ig,l)
+         enddo
+      enddo
+
+c     print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+c            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+             rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*ztv(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+cCr:ajout:calcul de la masse
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+c     print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des alim_star tels que alim=f*alim_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            alim_star(ig,l)=0.
+            alim(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      therm=.false.
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k+1
+               therm=.true.
+            endif
+          enddo
+      enddo
+c
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.lt.lentr(ig)) then
+cdef possibles pour alim_star: zdthetadz, dthetadz, zdtheta
+             alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)
+c     s                       *(zlev(ig,l+1)-zlev(ig,l))
+     s                       *sqrt(zlev(ig,l+1))
+c             alim_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
+c     s                         /zlev(ig,lentr(ig)+2)))**(3./2.) 
+            endif
+         enddo
+      enddo
+      
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+c         if (lmin(ig).gt.1) then
+cCRnouveau test
+        if (alim_star(ig,1).lt.1.e-10) then 
+            do l=1,klev
+                alim_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         alim_star_tot(ig)=0.
+         entr_star_tot(ig)=0.
+         detr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,k)
+         enddo
+      enddo
+c
+c Calcul entrainement normalise
+      do ig=1,ngrid 
+         if (alim_star_tot(ig).gt.1.e-10) then
+c         do l=1,lentr(ig)
+          do l=1,klev
+cdef possibles pour entr_star: zdthetadz, dthetadz, zdtheta 
+            alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
+         enddo
+         endif
+      enddo
+       
+c     print*,'fin calcul alim_star'
+
+cAM:initialisations
+      do k=1,nlay
+         do ig=1,ngrid
+            ztva(ig,k)=ztv(ig,k)
+            ztla(ig,k)=zthl(ig,k)
+            zqla(ig,k)=0.
+            zqta(ig,k)=po(ig,k)
+            Zsat(ig) =.false.
+         enddo
+      enddo 
+      do k=1,klev
+        do ig=1,ngrid
+           detr_star(ig,k)=0.
+           entr_star(ig,k)=0.
+           detr(ig,k)=0.
+           entr(ig,k)=0.
+        enddo
+      enddo
+c     print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+cn     print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+      nu_min=l_mix
+      nu_max=1000.
+c      do ig=1,ngrid
+c      nu_max=wmax_sec(ig)
+c      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            nu(ig,k)=0.
+            nu_e(ig,k)=0.
+         enddo
+      enddo
+cCalcul de l'excès de température du à la diffusion turbulente
+      do ig=1,ngrid
+         do l=1,klev
+            dtheta(ig,l)=0.
+         enddo
+       enddo
+      do ig=1,ngrid
+         do l=1,lentr(ig)-1
+      dtheta(ig,l)=sqrt(10.*0.4*zlev(ig,l+1)**2*1.
+     s          *((ztv(ig,l+1)-ztv(ig,l))/(zlev(ig,l+1)-zlev(ig,l)))**2)
+         enddo
+       enddo
+c      do l=1,nlay-2
+      do l=1,klev-1
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.alim_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+cAM
+ctest:on rajoute un excès de T dans couche alim
+c               ztla(ig,l)=zthl(ig,l)+dtheta(ig,l)
+               ztla(ig,l)=zthl(ig,l) 
+ctest: on rajoute un excès de q dans la couche alim
+c               zqta(ig,l)=po(ig,l)+0.001
+               zqta(ig,l)=po(ig,l)
+               zqla(ig,l)=zl(ig,l)
+cAM
+               f_star(ig,l+1)=alim_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               w_est(ig,l+1)=zw2(ig,l+1)
+               larg_detr(ig,l)=0.
+c     print*,'coucou boucle 1'
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s         (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then
+c     print*,'coucou boucle 2'
+cestimation du detrainement a partir de la geometrie du pas precedent
+      if ((test(ig).eq.1).or.((.not.debut).and.(f0(ig).lt.1.e-10))) then
+                  detr_star(ig,l)=0.
+                  entr_star(ig,l)=0.
+c     print*,'coucou test(ig)',test(ig),f0(ig),zmax0(ig)
+             else
+c     print*,'coucou debut detr'
+ctests sur la definition du detr
+        if (zqla(ig,l-1).gt.1.e-10) then
+           nuage=.true.
+        endif 
+
+             w_est(ig,l+1)=zw2(ig,l)*
+     s                   ((f_star(ig,l))**2)
+     s                   /(f_star(ig,l)+alim_star(ig,l))**2+
+     s                   2.*RG*(ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l)
+     s                   *(zlev(ig,l+1)-zlev(ig,l))
+             if (w_est(ig,l+1).lt.0.) then
+                w_est(ig,l+1)=zw2(ig,l)
+             endif
+      if (l.gt.2) then
+             if ((w_est(ig,l+1).gt.w_est(ig,l)).and.
+     s           (zlev(ig,l+1).lt.zmax_sec(ig)).and.
+     s            (zqla(ig,l-1).lt.1.e-10)) then 
+             detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1)
+     s                *sqrt(w_est(ig,l+1))*sqrt(nu(ig,l)*zlev(ig,l+1))
+     s       -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(nu(ig,l)*zlev(ig,l)))
+     s       /(r_aspect*zmax_sec(ig)))
+             else if ((zlev(ig,l+1).lt.zmax_sec(ig)).and.
+     s                (zqla(ig,l-1).lt.1.e-10)) then
+       detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig))
+     s /(rhobarz(ig,lmix(ig))*wmaxa(ig))*
+     s (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1))
+     s *((zmax_sec(ig)-zlev(ig,l+1))/((zmax_sec(ig)-zlev(ig,lmix(ig)))))
+     s **2.
+     s -rhobarz(ig,l)*sqrt(w_est(ig,l))
+     s *((zmax_sec(ig)-zlev(ig,l))/((zmax_sec(ig)-zlev(ig,lmix(ig)))))
+     s **2.)
+             else
+       detr_star(ig,l)=0.002*f0(ig)*f_star(ig,l)
+     s                *(zlev(ig,l+1)-zlev(ig,l))
+             
+             endif
+        else
+        detr_star(ig,l)=0.
+        endif
+       
+         detr_star(ig,l)=detr_star(ig,l)/f0(ig)
+         if (nuage) then
+         entr_star(ig,l)=0.4*detr_star(ig,l)
+         else
+         entr_star(ig,l)=0.4*detr_star(ig,l)
+         endif
+
+             if ((detr_star(ig,l)).gt.f_star(ig,l)) then
+              detr_star(ig,l)=f_star(ig,l)
+c              entr_star(ig,l)=0.
+              endif
+
+             if ((l.lt.lentr(ig))) then
+                 entr_star(ig,l)=0.
+c                 detr_star(ig,l)=0.
+             endif  
+
+c           print*,'ok detr_star'
+      endif
+cprise en compte du detrainement dans le calcul du flux
+             f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)
+     s                      -detr_star(ig,l)
+ctest
+c             if (f_star(ig,l+1).lt.0.) then
+c                f_star(ig,l+1)=0.
+c                entr_star(ig,l)=0.
+c                detr_star(ig,l)=f_star(ig,l)+alim_star(ig,l)
+c             endif
+ctest sur le signe de f_star
+       if (f_star(ig,l+1).gt.1.e-10) then 
+c                 then
+ctest
+c         if (((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10)) then
+cAM on melange Tl et qt du thermique
+con rajoute un excès de T dans la couche alim
+c               if (l.lt.lentr(ig)) then
+c           ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+
+c     s     (alim_star(ig,l)+entr_star(ig,l))*(zthl(ig,l)+dtheta(ig,l)))
+c     s     /(f_star(ig,l+1)+detr_star(ig,l))
+c               else
+               ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+
+     s                    (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l))
+     s                 /(f_star(ig,l+1)+detr_star(ig,l))
+c     s                    /(f_star(ig,l+1)) 
+c               endif
+con rajoute un excès de q dans la couche alim
+c               if (l.lt.lentr(ig)) then
+c               zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+
+c     s           (alim_star(ig,l)+entr_star(ig,l))*(po(ig,l)+0.001))
+c     s                 /(f_star(ig,l+1)+detr_star(ig,l))
+c               else
+               zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+
+     s                    (alim_star(ig,l)+entr_star(ig,l))*po(ig,l))
+     s                 /(f_star(ig,l+1)+detr_star(ig,l))
+c     s                   /(f_star(ig,l+1))
+c               endif
+cAM on en deduit thetav et ql du thermique
+cCR test
+c               Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
+               Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+               qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)  
+               qsatbef(ig)=MIN(0.5,qsatbef(ig))
+               zcor=1./(1.-retv*qsatbef(ig))
+               qsatbef(ig)=qsatbef(ig)*zcor
+             Zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig)) .gt. 1.e-10)
+
+           if (Zsat(ig).and.(1.eq.1)) then
+              qlbef=max(0.,zqta(ig,l)-qsatbef(ig))
+              DT = 0.5*RLvCp*qlbef
+c             write(17,*)'DT0=',DT
+              do while (abs(DT).gt.DDT0)
+c                 print*,'aie'
+                 Tbef(ig)=Tbef(ig)+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)
+                 qsatbef(ig)=MIN(0.5,qsatbef(ig))
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 qsatbef(ig)=qsatbef(ig)*zcor
+                 qlbef=zqta(ig,l)-qsatbef(ig)
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+                 num=-Tbef(ig)+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 if (denom.lt.1.e-10) then
+                    print*,'pb denom'
+                 endif
+                 DT=num/denom
+c                 write(17,*)'DT=',DT
+              enddo
+              zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
+              zqla(ig,l) = max(0.,qlbef) 
+c              zqla(ig,l)=0.
+             endif
+c             zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
+c      
+c on ecrit de maniere conservative (sat ou non)
+c          T = Tl +Lv/Cp ql
+cCR rq utilisation de humidite specifique ou rapport de melange?
+           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+con rajoute le calcul de zha pour diagnostiques (temp potentielle)
+           zha(ig,l) = ztva(ig,l)
+c           if (l.lt.lentr(ig)) then
+c           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+c     s              -zqla(ig,l))-zqla(ig,l)) + 0.1
+c           else
+           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+     s              -zqla(ig,l))-zqla(ig,l))
+c           endif
+c           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+c     s                 /(1.-retv*zqla(ig,l))
+c           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+c           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+c     s                 /(1.-retv*zqta(ig,l))
+c     s              -zqla(ig,l)/(1.-retv*zqla(ig,l)))
+c     s              -zqla(ig,l)/(1.-retv*zqla(ig,l)))
+c       write(13,*)zqla(ig,l),zqla(ig,l)/(1.-retv*zqla(ig,l))
+con ecrit zqsat 
+           zqsatth(ig,l)=qsatbef(ig)  
+c        enddo
+c        DO ig=1,ngrid
+c           if (zw2(ig,l).ge.1.e-10.and.
+c     s               f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then
+c  mise a jour de la vitesse ascendante (l'air entraine de la couche
+c  consideree commence avec une vitesse nulle).
+c
+c            if (f_star(ig,l+1).gt.1.e-10) then
+            zw2(ig,l+1)=zw2(ig,l)*
+c     s                  ((f_star(ig,l)-detr_star(ig,l))**2)
+c     s                  /f_star(ig,l+1)**2+
+     s                   ((f_star(ig,l))**2)
+     s                   /(f_star(ig,l+1)+detr_star(ig,l))**2+
+c     s                    /(f_star(ig,l+1))**2+           
+     s                   2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                   *(zlev(ig,l+1)-zlev(ig,l))
+c     s                   *(f_star(ig,l)/f_star(ig,l+1))**2
+
+            endif
+        endif
+c
+            if (zw2(ig,l+1).lt.0.) then 
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+c              print*,'linter=',linter(ig)
+c          else if ((zw2(ig,l+1).lt.1.e-10).and.(zw2(ig,l+1).ge.0.)) then
+c               linter(ig)=l+1
+c               print*,'linter=l',zw2(ig,l),zw2(ig,l+1)
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+c            wa_moy(ig,l+1)=zw2(ig,l+1) 
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+             lmin(ig)=1
+             lentr(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+cpour le cas ou on prend tjs lmin=1
+c       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1))
+       zmax0(ig)=zmax(ig)
+       write(11,*)'ig,lmax,linter',ig,lmax(ig),linter(ig)
+       write(12,*)'ig,zlevinter,zmax',ig,zmax(ig),zlevinter(ig)
+      enddo
+
+cCalcul de zmax_sec et wmax_sec
+      call fermeture_seche(ngrid,nlay
+     s                  ,pplay,pplev,pphi,zlev,rhobarz,f0,zpspsk
+     s                  ,alim,zh,zo,lentr,lmin,nu_min,nu_max,r_aspect
+     s                  ,zmax_sec2,wmax_sec2)
+
+      print*,'avant fermeture'
+c Fermeture,determination de f
+c en lmax f=d-e
+      do ig=1,ngrid
+c      entr_star(ig,lmax(ig))=0.
+c      f_star(ig,lmax(ig)+1)=0.
+c      detr_star(ig,lmax(ig))=f_star(ig,lmax(ig))+entr_star(ig,lmax(ig))
+c     s                       +alim_star(ig,lmax(ig))
+      enddo
+c
+      do ig=1,ngrid
+         alim_star2(ig)=0.
+      enddo
+ccalcul de entr_star_tot
+      do ig=1,ngrid
+         do k=1,lmix(ig)
+            entr_star_tot(ig)=entr_star_tot(ig)
+c     s                        +entr_star(ig,k)
+     s                        +alim_star(ig,k)
+c     s                        -detr_star(ig,k)
+            detr_star_tot(ig)=detr_star_tot(ig)
+c     s                        +alim_star(ig,k)
+     s                        -detr_star(ig,k)
+     s                        +entr_star(ig,k)
+         enddo
+      enddo
+      
+      do ig=1,ngrid
+         if (alim_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else   
+c             do k=lmin(ig),lentr(ig)
+             do k=1,lentr(ig)
+                alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+             if ((zmax_sec(ig).gt.1.e-10).and.(1.eq.1)) then 
+             f(ig)=wmax_sec(ig)/(max(500.,zmax_sec(ig))*r_aspect
+     s             *alim_star2(ig))
+             f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/
+     s                     zmax_sec(ig))*wmax_sec(ig))
+             else
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect*alim_star2(ig))
+            f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/
+     s                     zmax(ig))*wmax(ig))
+             endif
+         endif
+         f0(ig)=f(ig)
+      enddo
+      print*,'apres fermeture'
+c Calcul de l'entrainement
+         do ig=1,ngrid 
+            do k=1,klev
+            alim(ig,k)=f(ig)*alim_star(ig,k)
+         enddo
+      enddo
+cCR:test pour entrainer moins que la masse
+c       do ig=1,ngrid
+c          do l=1,lentr(ig)
+c             if ((alim(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then
+c                alim(ig,l+1)=alim(ig,l+1)+alim(ig,l)
+c     s                       -0.9*masse(ig,l)/ptimestep
+c                alim(ig,l)=0.9*masse(ig,l)/ptimestep
+c             endif
+c          enddo
+c       enddo
+c calcul du détrainement
+         do ig=1,klon
+             do k=1,klev
+            detr(ig,k)=f(ig)*detr_star(ig,k)
+            if (detr(ig,k).lt.0.) then
+c               print*,'detr1<0!!!'
+            endif
+            enddo
+            do k=1,klev
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+            if (entr(ig,k).lt.0.) then
+c               print*,'entr1<0!!!'
+            endif
+         enddo
+      enddo
+c
+c       do ig=1,ngrid
+c          do l=1,klev
+c          if (((detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep).gt.
+c     s          (masse(ig,l))) then  
+c      print*,'d2+e2+a2>m2','ig=',ig,'l=',l,'lmax(ig)=',lmax(ig),'d+e+a='
+c     s,(detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep,'m=',masse(ig,l)
+c      endif
+c      enddo
+c      enddo
+c Calcul des flux
+
+      do ig=1,ngrid
+         do l=1,lmax(ig)
+c         do l=1,klev
+c             fmc(ig,l+1)=f(ig)*f_star(ig,l+1)
+            fmc(ig,l+1)=fmc(ig,l)+alim(ig,l)+entr(ig,l)-detr(ig,l)
+c        print*,'??!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig),
+c     s  'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l),
+c     s  'f+1=',fmc(ig,l+1)
+          if (fmc(ig,l+1).lt.0.) then
+               print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1)
+               fmc(ig,l+1)=fmc(ig,l)
+               detr(ig,l)=alim(ig,l)+entr(ig,l)
+c               fmc(ig,l+1)=0.
+c               print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1)
+            endif
+c       if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then
+c          f_old=fmc(ig,l+1)
+c          fmc(ig,l+1)=fmc(ig,l)
+c          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
+c       endif
+       
+c        if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then
+c          f_old=fmc(ig,l+1)
+c          fmc(ig,l+1)=fmc(ig,l)
+c          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l)
+c       endif
+crajout du test sur alpha croissant
+cif test
+c       if (1.eq.0) then
+
+       if (l.eq.klev) then
+          print*,'THERMCELL PB ig=',ig,'   l=',l
+          abort_message = 'THERMCELL PB'
+          CALL abort_gcm (modname,abort_message,1)
+       endif
+!       if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and.
+!     s     (l.ge.lentr(ig)).and.
+       if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and.
+     s         (l.ge.lentr(ig)) ) then
+          if ( ((fmc(ig,l+1)/(rhobarz(ig,l+1)*zw2(ig,l+1))).gt.
+     s     (fmc(ig,l)/(rhobarz(ig,l)*zw2(ig,l))))) then
+           f_old=fmc(ig,l+1)
+           fmc(ig,l+1)=fmc(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1)
+     s                          /(rhobarz(ig,l)*zw2(ig,l))
+           detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) 
+c           detr(ig,l)=(fmc(ig,l+1)-fmc(ig,l))/(0.4-1.)
+c           entr(ig,l)=0.4*detr(ig,l)
+c           entr(ig,l)=fmc(ig,l+1)-fmc(ig,l)+detr(ig,l)
+        endif
+        endif
+        if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then
+          f_old=fmc(ig,l+1)
+          fmc(ig,l+1)=fmc(ig,l)
+          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
+       endif
+       if (detr(ig,l).gt.fmc(ig,l)) then
+               detr(ig,l)=fmc(ig,l)
+               entr(ig,l)=fmc(ig,l+1)-alim(ig,l)
+        endif
+       if (fmc(ig,l+1).lt.0.) then
+               detr(ig,l)=detr(ig,l)+fmc(ig,l+1)
+               fmc(ig,l+1)=0.
+               print*,'fmc2<0',l+1,lmax(ig)
+            endif
+            
+ctest pour ne pas avoir f=0 et d=e/=0
+c       if (fmc(ig,l+1).lt.1.e-10) then
+c          detr(ig,l+1)=0.
+c          entr(ig,l+1)=0.
+c          zqla(ig,l+1)=0.
+c          zw2(ig,l+1)=0.
+c          lmax(ig)=l+1
+c          zmax(ig)=zlev(ig,lmax(ig))
+c       endif 
+        if (zw2(ig,l+1).gt.1.e-10) then
+       if ((((fmc(ig,l+1))/(rhobarz(ig,l+1)*zw2(ig,l+1))).gt.
+     s      1.)) then
+          f_old=fmc(ig,l+1)
+          fmc(ig,l+1)=rhobarz(ig,l+1)*zw2(ig,l+1)
+          zw2(ig,l+1)=0.
+          zqla(ig,l+1)=0.
+          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
+         lmax(ig)=l+1
+          zmax(ig)=zlev(ig,lmax(ig))
+          print*,'alpha>1',l+1,lmax(ig)
+       endif
+        endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cendif test
+c      endif
+      enddo
+      enddo
+      do ig=1,ngrid
+c         if (fmc(ig,lmax(ig)+1).ne.0.) then
+         fmc(ig,lmax(ig)+1)=0.
+         entr(ig,lmax(ig))=0.
+         detr(ig,lmax(ig))=fmc(ig,lmax(ig))+entr(ig,lmax(ig))
+     s                     +alim(ig,lmax(ig))
+c         endif
+      enddo
+ctest sur le signe de fmc
+       do ig=1,ngrid
+         do l=1,klev+1
+            if (fmc(ig,l).lt.0.) then
+         print*,'fm1<0!!!','ig=',ig,'l=',l,'a=',alim(ig,l-1),'e='
+     s ,entr(ig,l-1),'f=',fmc(ig,l-1),'d=',detr(ig,l-1),'f+1=',fmc(ig,l)
+            endif
+         enddo
+       enddo
+ctest de verification
+      do ig=1,ngrid
+       do l=1,lmax(ig)
+       if ((abs(fmc(ig,l+1)-fmc(ig,l)-alim(ig,l)-entr(ig,l)+detr(ig,l)))
+     s           .gt.1.e-4) then
+c      print*,'pbcm!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig),
+c     s  'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l),
+c     s  'f+1=',fmc(ig,l+1)
+       endif
+       if (detr(ig,l).lt.0.) then
+          print*,'detrdemi<0!!!'
+       endif
+         enddo
+      enddo
+c
+cRC
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)
+     s        then
+c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+              else
+              zmix(ig)=zlev(ig,lmix(ig))
+              print*,'pb zmix'
+              endif
+          else 
+              zmix(ig)=0.
+          endif
+ctest
+         if ((zmax(ig)-zmix(ig)).le.0.) then
+            zmix(ig)=0.9*zmax(ig)
+c            print*,'pb zmix>zmax'
+         endif
+      enddo
+      do ig=1,klon
+         zmix0(ig)=zmix(ig)
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+cne devrait pas arriver!!!!!
+      do ig=1,ngrid
+       do l=1,klev
+          if (detr(ig,l).gt.(fmc(ig,l)+alim(ig,l))+entr(ig,l)) then
+             print*,'detr2>fmc2!!!','ig=',ig,'l=',l,'d=',detr(ig,l),
+     s             'f=',fmc(ig,l),'lmax=',lmax(ig)
+c             detr(ig,l)=fmc(ig,l)+alim(ig,l)+entr(ig,l)
+c             entr(ig,l)=0.
+c             fmc(ig,l+1)=0.
+c             zw2(ig,l+1)=0.     
+c             zqla(ig,l+1)=0.
+           print*,'pb!fm=0 et f_star>0',l,lmax(ig)        
+c             lmax(ig)=l
+          endif
+       enddo
+      enddo
+      do ig=1,ngrid
+         do l=lmax(ig)+1,klev+1
+c            fmc(ig,l)=0.
+c            detr(ig,l)=0.
+c            entr(ig,l)=0.
+c            zw2(ig,l)=0.
+c            zqla(ig,l)=0.
+         enddo
+      enddo
+
+cCalcul du detrainement lors du premier passage
+c     print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig).and.(test(ig).eq.1)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig).and.(test(ig).eq.1)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+                   print*,'pb l_mix*zlev<0'
+                  endif
+cCR: test: nouvelle def de lambda
+c                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  if (zw2(ig,l).gt.1.e-10) then
+                  larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
+                  else
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  endif
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+         endif
+         enddo
+       enddo
+
+c     print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   cal1cul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1..and.(test(ig).eq.1)) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          if (test(ig).eq.1) then
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+          endif
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1..and.(test(ig).eq.1)) then
+               if (l.gt.lmix(ig)) then
+ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+c                   print*,'pb xxx'
+                    xxx(ig,l)=(lmax(ig)+1.-l)/(lmax(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+
+      print*,'fin calcul fraca'
+c     print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              if (test(ig).eq.1) then
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (alim(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+              endif
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1.and.(test(ig).eq.1)) then
+              abort_message = 'fracd trop petit'
+              CALL abort_gcm (modname,abort_message,1)
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay+1
+         do ig=1,ngrid
+            if (test(ig).eq.0) then
+              fm(ig,l)=fmc(ig,l)
+            endif
+         enddo
+      enddo 
+   
+cfin du first
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+      print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+      print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+     s         ,fm(ig,l+1)*ptimestep
+     s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if((alim(ig,l)+entr(ig,l))*ptimestep.gt.masse(ig,l)) then
+      print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+     s         ,(entr(ig,l)+alim(ig,l))*ptimestep
+     s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.alim(ig,l).ge.0..or..not.alim(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+cCR:redefinition du entr
+cCR:test:on ne change pas la def du entr mais la def du fm
+       do l=1,nlay
+         do ig=1,ngrid
+            if (test(ig).eq.1) then
+            detr(ig,l)=fm(ig,l)+alim(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                fm(ig,l+1)=fm(ig,l)+alim(ig,l)
+                detr(ig,l)=0.
+c                write(11,*)'l,ig,entr',l,ig,entr(ig,l)
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+            endif
+         enddo
+      enddo
+cRC
+
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/tho
+         entr0=entr0+ptimestep*(alim+entr-entr0)/tho
+      else
+         fm0=fm
+         entr0=alim+entr
+         detr0=detr
+         alim0=alim
+c         zoa=zqta
+c         entr0=alim
+      endif
+
+      if (1.eq.1) then
+c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+c     .    ,zh,zdhadj,zha)
+c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+c     .    ,zo,pdoadj,zoa)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse,
+     .                    zthl,zdthladj,zta)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse,
+     .                   po,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+cCalcul des moments
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+c            zf2=zf/(1.-zf)
+c            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+c            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+c         enddo
+c      enddo
+
+
+
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+c            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+           pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l)  
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+      print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+ccalcul de fraca pour les sorties
+      do l=2,klev
+         do ig=1,klon
+            if (zw2(ig,l).gt.1.e-10) then
+            fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l))
+            else
+            fraca(ig,l)=0.
+            endif
+         enddo
+      enddo
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+c CR calcul du niveau de condensation
+c initialisation
+      do ig=1,ngrid
+         nivcon(ig)=0.
+         zcon(ig)=0.
+      enddo 
+      do k=nlay,1,-1
+         do ig=1,ngrid
+            if (zqla(ig,k).gt.1e-10) then
+               nivcon(ig)=k
+               zcon(ig)=zlev(ig,k)
+            endif
+c            if (zcon(ig).gt.1.e-10) then
+c               nuage=.true.
+c            else 
+c               nuage=.false.
+c            endif
+         enddo
+      enddo
+      
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=fraca(ig,l)
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2
+            wth2(ig,l)=zf2*(zw2(ig,l))**2
+c           print*,'wth2=',wth2(ig,l)
+            wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l))
+     s                *zw2(ig,l)*zw2(ig,l)*zw2(ig,l)
+            q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+ctest: on calcul q2/po=ratqsc
+c            if (nuage) then
+            ratqscth(ig,l)=sqrt(q2(ig,l))/(po(ig,l)*1000.)
+c            else
+c            ratqscth(ig,l)=0.
+c            endif
+         enddo
+      enddo
+ccalcul du ratqscdiff
+      sum=0.
+      sumdiff=0.
+      ratqsdiff(:,:)=0.
+      do ig=1,ngrid
+         do l=1,lentr(ig)
+            sum=sum+alim_star(ig,l)*zqta(ig,l)*1000.
+         enddo
+      enddo
+      do ig=1,ngrid
+          do l=1,lentr(ig)
+          zf=fraca(ig,l)
+          zf2=zf/(1.-zf)
+       sumdiff=sumdiff+alim_star(ig,l)
+     s           *(zqta(ig,l)*1000.-sum)**2
+c      ratqsdiff=ratqsdiff+alim_star(ig,l)*
+c     s          (zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+          enddo
+      enddo
+      do l=1,klev
+      do ig=1,ngrid
+      ratqsdiff(ig,l)=sqrt(sumdiff)/(po(ig,l)*1000.)   
+c      write(11,*)'ratqsdiff=',ratqsdiff(ig,l)
+      enddo
+      enddo     
+cdeja fait
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+c            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+c                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+c            endif
+c         enddo
+c      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1       
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+c         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+c         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+c         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+c         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+c         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+c         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,w_est,'w_est      ','w_est      ')
+con sort les moments
+         call wrgradsfi(1,nlay,thetath2,'zh2       ','zh2       ')
+         call wrgradsfi(1,nlay,wth2,'w2       ','w2       ')
+         call wrgradsfi(1,nlay,wth3,'w3       ','w3       ')
+         call wrgradsfi(1,nlay,q2,'q2       ','q2       ')
+         call wrgradsfi(1,nlay,dtheta,'dT       ','dT       ')
+c
+         call wrgradsfi(1,nlay,zw_sec,'zw_sec       ','zw_sec       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+         call wrgradsfi(1,nlay,nu,'nu       ','nu       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,zoa,'zoa        ','zoa        ')
+c         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+c         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cAM:nouveaux diagnostiques
+         call wrgradsfi(1,nlay,zthl,'zthl        ','zthl        ')
+         call wrgradsfi(1,nlay,zta,'zta        ','zta        ')
+         call wrgradsfi(1,nlay,zl,'zl        ','zl        ')
+         call wrgradsfi(1,nlay,zdthladj,'zdthladj    ',
+     s        'zdthladj    ')
+         call wrgradsfi(1,nlay,ztla,'ztla      ','ztla      ')
+         call wrgradsfi(1,nlay,zqta,'zqta      ','zqta      ')
+         call wrgradsfi(1,nlay,zqla,'zqla      ','zqla      ')
+         call wrgradsfi(1,nlay,deltaz,'deltaz      ','deltaz      ')
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')
+      call wrgradsfi(1,nlay,detr_star  ,'detr_star   ','detr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,nlay,zqsat    ,'zqsat   ','zqsat   ')
+      call wrgradsfi(1,nlay,zqsatth    ,'qsath   ','qsath   ')
+      call wrgradsfi(1,nlay,alim_star    ,'alim_star   ','alim_star   ')
+      call wrgradsfi(1,nlay,alim    ,'alim   ','alim   ')
+      call wrgradsfi(1,1,f,'f      ','f      ')
+      call wrgradsfi(1,1,alim_star_tot,'a_s_t      ','a_s_t      ')
+      call wrgradsfi(1,1,alim_star2,'a_2      ','a_2      ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmax_sec,'z_sec      ','z_sec      ')
+c      call wrgradsfi(1,1,zmax_sec2,'zz_se      ','zz_se      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      call wrgradsfi(1,1,nivcon,'nivcon      ','nivcon      ')
+      call wrgradsfi(1,1,zcon,'zcon      ','zcon      ')
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      call wrgradsfi(1,1,wmax_sec,'w_sec      ','w_sec      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+           str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+      print*,'19 OK convect8'
+      return
+      end
+      SUBROUTINE thermcell_eau(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di
+      REAL tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+c$OMP THREADPRIVATE(idetr)
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      real zthl(klon,klev),zdthladj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      real zl(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zta(klon,klev)
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+c$OMP THREADPRIVATE(isplit)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef(klon),qsatbef(klon)
+      real dqsat_dT,DT,num,denom
+      REAL REPS,RLvCp,DDT0
+      real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev)
+ 
+      PARAMETER (DDT0=.01)
+
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical first
+      data first /.false./
+      save first
+c$OMP THREADPRIVATE(first)
+
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      character (len=20) :: modname='thermcell_eau'
+      character (len=80) :: abort_message
+
+      LOGICAL vtest(klon),down
+      LOGICAL Zsat(klon)
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+c$OMP THREADPRIVATE(ncorrec)
+
+c
+
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c Initialisation
+      RLvCp = RLVTT/RCPD
+      REPS  = RD/RV
+c
+c-----------------------------------------------------------------------
+cAM Calcul de T,q,ql a partir de Tl et qT
+c   ---------------------------------------------------
+c
+c Pr Tprec=Tl calcul de qsat 
+c Si qsat>qT T=Tl, q=qT
+c Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) 
+c On cherche DDT < DDT0
+c
+c defaut
+       DO  ll=1,nlay
+         DO ig=1,ngrid
+            zo(ig,ll)=po(ig,ll)
+            zl(ig,ll)=0.
+            zh(ig,ll)=pt(ig,ll)
+         EndDO
+       EndDO
+       do ig=1,ngrid
+          Zsat(ig)=.false.
+       enddo
+c
+c
+       DO ll=1,nlay
+c les points insatures sont definitifs
+         DO ig=1,ngrid
+            Tbef(ig)=pt(ig,ll)
+            zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+            qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+            qsatbef(ig)=MIN(0.5,qsatbef(ig))
+            zcor=1./(1.-retv*qsatbef(ig))
+            qsatbef(ig)=qsatbef(ig)*zcor
+            Zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig)) .gt. 0.00001)
+         EndDO
+
+         DO ig=1,ngrid
+           if (Zsat(ig)) then
+            qlbef=max(0.,po(ig,ll)-qsatbef(ig))
+c si sature: ql est surestime, d'ou la sous-relax
+            DT = 0.5*RLvCp*qlbef
+c on pourra enchainer 2 ou 3 calculs sans Do while
+            do while (DT.gt.DDT0)
+c il faut verifier si c,a conserve quand on repasse en insature ...
+              Tbef(ig)=Tbef(ig)+DT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+              qsatbef(ig)=MIN(0.5,qsatbef(ig))
+              zcor=1./(1.-retv*qsatbef(ig))
+              qsatbef(ig)=qsatbef(ig)*zcor
+c on veut le signe de qlbef
+              qlbef=po(ig,ll)-qsatbef(ig)
+c          dqsat_dT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+              zcor=1./(1.-retv*qsatbef(ig))
+              dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+              num=-Tbef(ig)+pt(ig,ll)+RLvCp*qlbef
+              denom=1.+RLvCp*dqsat_dT
+              DT=num/denom
+            enddo
+c on ecrit de maniere conservative (sat ou non)
+            zl(ig,ll) = max(0.,qlbef)
+c          T = Tl +Lv/Cp ql
+            zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)
+            zo(ig,ll) = po(ig,ll)-zl(ig,ll)
+           endif
+         EndDO
+       EndDO
+cAM fin
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+      print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+c            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+c            zo(ig,l)=po(ig,l)
+c            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+cAM attention zh est maintenant le profil de T et plus le profil de theta !
+c
+c   T-> Theta
+            ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+cAM Theta_v
+            ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l))
+     s           -zl(ig,l))
+cAM Thetal
+            zthl(ig,l)=pt(ig,l)/zpspsk(ig,l)
+c            
+1015     CONTINUE
+1010  CONTINUE
+
+c     print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c     print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+c            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+             rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*ztv(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c     print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      do k=nlay-1,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).lt.ztv(ig,k+2)) then
+               lentr(ig)=k
+            endif
+          enddo
+      enddo
+    
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.le.lentr(ig)) then 
+                 entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))*
+     s                          (zlev(ig,l+1)-zlev(ig,l))
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+c
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+cRC
+cAM:initialisations
+      do k=1,nlay
+         do ig=1,ngrid
+            ztva(ig,k)=ztv(ig,k)
+            ztla(ig,k)=zthl(ig,k)
+            zqla(ig,k)=0.
+            zqta(ig,k)=po(ig,k)
+            Zsat(ig) =.false.
+         enddo
+      enddo
+c
+c     print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c     print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.entr_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+cAM
+               ztla(ig,l)=zthl(ig,l)
+               zqta(ig,l)=po(ig,l)
+               zqla(ig,l)=zl(ig,l)
+cAM
+               f_star(ig,l+1)=entr_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+c
+cAM on melange Tl et qt du thermique
+               ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+entr_star(ig,l)
+     s                    *zthl(ig,l))/f_star(ig,l+1)
+               zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+entr_star(ig,l)
+     s                    *po(ig,l))/f_star(ig,l+1)
+c
+c               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+c     s                    *ztv(ig,l))/f_star(ig,l+1)
+c
+cAM on en deduit thetav et ql du thermique
+               Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+               qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)
+               qsatbef(ig)=MIN(0.5,qsatbef(ig))
+               zcor=1./(1.-retv*qsatbef(ig))
+               qsatbef(ig)=qsatbef(ig)*zcor
+               Zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig)) .gt. 0.00001)
+            endif
+         enddo
+         DO ig=1,ngrid
+           if (Zsat(ig)) then
+              qlbef=max(0.,zqta(ig,l)-qsatbef(ig))
+              DT = 0.5*RLvCp*qlbef
+              do while (DT.gt.DDT0)
+                 Tbef(ig)=Tbef(ig)+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)
+                 qsatbef(ig)=MIN(0.5,qsatbef(ig))
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 qsatbef(ig)=qsatbef(ig)*zcor
+                 qlbef=zqta(ig,l)-qsatbef(ig)
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+                 num=-Tbef(ig)+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 DT=num/denom
+              enddo
+              zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
+           endif
+c on ecrit de maniere conservative (sat ou non)
+c          T = Tl +Lv/Cp ql
+           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+     s              -zqla(ig,l))-zqla(ig,l))
+
+        enddo
+        DO ig=1,ngrid
+           if (zw2(ig,l).ge.1.e-10.and.
+     s               f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then
+c  mise a jour de la vitesse ascendante (l'air entraine de la couche
+c  consideree commence avec une vitesse nulle).
+c
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+            lmin(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=500.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+c Fermeture,determination de f
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+c Nouvelle fermeture
+             f(ig)=wmax(ig)/(zmax(ig)*r_aspect*entr_star2(ig))
+     s             *entr_star_tot(ig)
+ctest
+             if (first) then
+             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+     s             *wmax(ig))
+             endif
+         endif
+         f0(ig)=f(ig)
+         first=.true.
+      enddo
+
+c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+cRC
+
+
+c     print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c     print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+         else 
+         zmix(ig)=0.
+         endif
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+
+c     print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+              abort_message = 'fracd trop petit'
+              CALL abort_gcm (modname,abort_message,1)
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+c     print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/tho
+         entr0=entr0+ptimestep*(entr-entr0)/tho
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+c     .    ,zh,zdhadj,zha)
+c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+c     .    ,zo,pdoadj,zoa)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zthl,zdthladj,zta)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,po,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+c            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+           pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l)  
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+c     print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cAM:nouveaux diagnostiques
+         call wrgradsfi(1,nlay,zthl,'zthl        ','zthl        ')
+         call wrgradsfi(1,nlay,zta,'zta        ','zta        ')
+         call wrgradsfi(1,nlay,zl,'zl        ','zl        ')
+         call wrgradsfi(1,nlay,zdthladj,'zdthladj    ',
+     s        'zdthladj    ')
+         call wrgradsfi(1,nlay,ztla,'ztla      ','ztla      ')
+         call wrgradsfi(1,nlay,zqta,'zqta      ','zqta      ')
+         call wrgradsfi(1,nlay,zqla,'zqla      ','zqla      ')
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+c     print*,'19 OK convect8'
+      return
+      end
+
+      SUBROUTINE thermcell(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di
+      REAL tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+c$OMP THREADPRIVATE(idetr)
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+c$OMP THREADPRIVATE(isplit)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical first
+      data first /.false./
+      save first
+c$OMP THREADPRIVATE(first)
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      character (len=20) :: modname='thermcell'
+      character (len=80) :: abort_message
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+c$OMP THREADPRIVATE(ncorrec)
+      
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+       print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+       print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c      print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c      print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k
+            endif
+          enddo
+      enddo
+    
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.le.lentr(ig)) then 
+                 entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))*
+     s                           (zlev(ig,l+1)-zlev(ig,l))
+            endif
+         enddo
+      enddo
+c pas de thermique si couches 1->5 stables
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+c
+      print*,'fin calcul entr_star'
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+cRC
+c      print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c      print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.entr_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=entr_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+     s                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+ctest
+               if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then
+                  print*,'pb linter'
+               endif
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               if (zw2(ig,l+1).lt.0.) then
+                  print*,'pb1 zw2<0'
+               endif
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couches 1->5 stables
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            lmax(ig)=1
+            lmin(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+      print*,'avant fermeture'
+c Fermeture,determination de f
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+c Nouvelle fermeture
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect
+     s             *entr_star2(ig))*entr_star_tot(ig)
+ctest
+c             if (first) then
+c             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+c     s             *wmax(ig))
+c             endif
+         endif
+c         f0(ig)=f(ig)
+c         first=.true.
+      enddo
+      print*,'apres fermeture'
+
+c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+cRC
+
+
+c      print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+                   print*,'pb l_mix*zlev<0'
+                  endif
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c      print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)
+     s        then
+c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+            else
+            zmix(ig)=zlev(ig,lmix(ig))
+            print*,'pb zmix'
+            endif
+         else 
+         zmix(ig)=0.
+         endif
+ctest
+         if ((zmax(ig)-zmix(ig)).lt.0.) then
+            zmix(ig)=0.99*zmax(ig)
+c            print*,'pb zmix>zmax'
+         endif
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+c                   print*,'pb xxx'
+                   xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+      
+      print*,'fin calcul fraca'
+c      print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+              abort_message = 'fracd trop petit'
+              CALL abort_gcm (modname,abort_message,1)
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+      print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+cCR:redefinition du entr
+       do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+cRC
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/tho
+         entr0=entr0+ptimestep*(entr-entr0)/tho
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+      print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+cdeja fait
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+c            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+c                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+c            endif
+c         enddo
+c      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+#define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+      print*,'19 OK convect8'
+      return
+      end
+
+      subroutine dqthermcell(ngrid,nlay,ptimestep,fm,entr,
+     .           masse,q,dq,qa)
+      USE dimphy
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1)
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+ctest
+            if (detr(ig,k).lt.0.) then
+               entr(ig,k)=entr(ig,k)-detr(ig,k)
+               detr(ig,k)=0.
+c               print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k),
+c     s         'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k)
+            endif
+            if (fm(ig,k+1).lt.0.) then
+c               print*,'fm2<0!!!'
+            endif
+            if (entr(ig,k).lt.0.) then
+c               print*,'entr2<0!!!'
+            endif
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+         qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))
+     s         /(fm(ig,k+1)+detr(ig,k))
+            else
+               qa(ig,k)=q(ig,k)
+            endif
+            if (qa(ig,k).lt.0.) then
+c               print*,'qa<0!!!'
+            endif
+            if (q(ig,k).lt.0.) then
+c               print*,'q<0!!!'
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+c             wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
+            wqd(ig,k)=fm(ig,k)*q(ig,k)
+            if (wqd(ig,k).lt.0.) then
+c               print*,'wqd<0!!!'
+            endif
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+     
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)
+     s               -wqd(ig,k)+wqd(ig,k+1))
+     s               /masse(ig,k)
+c            if (dq(ig,k).lt.0.) then
+c               print*,'dq<0!!!'
+c            endif
+         enddo
+      enddo
+
+      return
+      end
+      subroutine dvthermcell(ngrid,nlay,ptimestep,fm,entr,masse
+     .    ,fraca,larga
+     .    ,u,v,du,dv,ua,va)
+      USE dimphy
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev)
+      real wvd(klon,klev+1),wud(klon,klev+1)
+      real gamma0,gamma(klon,klev+1)
+      real dua,dva
+      integer iter
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+c   On itère sur la valeur du coeff de freinage.
+c              gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+               gamma0=masse(ig,k)
+     s         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )
+     s         *0.5/larga(ig)
+c              gamma0=0.
+c   la première fois on multiplie le coefficient de freinage
+c   par le module du vent dans la couche en dessous.
+               dua=ua(ig,k-1)-u(ig,k-1)
+               dva=va(ig,k-1)-v(ig,k-1)
+               do iter=1,5
+                  gamma(ig,k)=gamma0*sqrt(dua**2+dva**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)
+     s               +(entr(ig,k)+gamma(ig,k))*u(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)
+     s               +(entr(ig,k)+gamma(ig,k))*v(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k))
+c                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
+                  dua=ua(ig,k)-u(ig,k)
+                  dva=va(ig,k)-v(ig,k)
+               enddo
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               gamma(ig,k)=0.
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*u(ig,k)
+            wvd(ig,k)=fm(ig,k)*v(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*u(ig,k)
+     s               -wud(ig,k)+wud(ig,k+1))
+     s               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*v(ig,k)
+     s               -wvd(ig,k)+wvd(ig,k+1))
+     s               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
+      subroutine dqthermcell2(ngrid,nlay,ptimestep,fm,entr,masse,frac
+     .    ,q,dq,qa)
+      USE dimphy
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay),frac(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1)
+      real qe(klon,klev),zf,zf2
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+         qe(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+               zf=0.5*(frac(ig,k)+frac(ig,k+1))
+               zf2=1./(1.-zf)
+               qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+zf2*entr(ig,k)*q(ig,k))
+     s         /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2)
+               qe(ig,k)=(q(ig,k)-zf*qa(ig,k))*zf2
+            else
+               qa(ig,k)=q(ig,k)
+               qe(ig,k)=q(ig,k)
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+c             wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
+            wqd(ig,k)=fm(ig,k)*qe(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*qe(ig,k)
+     s               -wqd(ig,k)+wqd(ig,k+1))
+     s               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
+      subroutine dvthermcell2(ngrid,nlay,ptimestep,fm,entr,masse
+     .    ,fraca,larga
+     .    ,u,v,du,dv,ua,va)
+      use dimphy
+      implicit none
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c   calcul du dq/dt une fois qu'on connait les ascendances
+c
+c=======================================================================
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),zf,zf2
+      real wvd(klon,klev+1),wud(klon,klev+1)
+      real gamma0,gamma(klon,klev+1)
+      real ue(klon,klev),ve(klon,klev)
+      real dua,dva
+      integer iter
+
+      integer ig,k
+
+c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+         ue(ig,1)=u(ig,1)
+         ve(ig,1)=v(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.
+     s         1.e-5*masse(ig,k)) then
+c   On itère sur la valeur du coeff de freinage.
+c              gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+               gamma0=masse(ig,k)
+     s         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )
+     s         *0.5/larga(ig)
+     s         *1.
+c    s         *0.5
+c              gamma0=0.
+               zf=0.5*(fraca(ig,k)+fraca(ig,k+1))
+               zf=0.
+               zf2=1./(1.-zf)
+c   la première fois on multiplie le coefficient de freinage
+c   par le module du vent dans la couche en dessous.
+               dua=ua(ig,k-1)-u(ig,k-1)
+               dva=va(ig,k-1)-v(ig,k-1)
+               do iter=1,5
+c   On choisit une relaxation lineaire.
+                  gamma(ig,k)=gamma0
+c   On choisit une relaxation quadratique.
+                  gamma(ig,k)=gamma0*sqrt(dua**2+dva**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)
+     s               +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2
+     s                 +gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)
+     s               +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k))
+     s               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2
+     s                 +gamma(ig,k))
+c                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
+                  dua=ua(ig,k)-u(ig,k)
+                  dva=va(ig,k)-v(ig,k)
+                  ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2
+                  ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2
+               enddo
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               ue(ig,k)=u(ig,k)
+               ve(ig,k)=v(ig,k)
+               gamma(ig,k)=0.
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*ue(ig,k)
+            wvd(ig,k)=fm(ig,k)*ve(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*ue(ig,k)
+     s               -wud(ig,k)+wud(ig,k+1))
+     s               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)
+     s               -(entr(ig,k)+gamma(ig,k))*ve(ig,k)
+     s               -wvd(ig,k)+wvd(ig,k+1))
+     s               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end
+      SUBROUTINE thermcell_sec(ngrid,nlay,ptimestep
+     s                  ,pplay,pplev,pphi,zlev
+     s                  ,pu,pv,pt,po
+     s                  ,pduadj,pdvadj,pdtadj,pdoadj
+     s                  ,fm0,entr0
+c    s                  ,pu_therm,pv_therm
+     s                  ,r_aspect,l_mix,w2di,tho)
+
+      use dimphy
+      IMPLICIT NONE
+
+c=======================================================================
+c
+c   Calcul du transport verticale dans la couche limite en presence
+c   de "thermiques" explicitement representes
+c
+c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+c
+c   le thermique est supposé homogène et dissipé par mélange avec
+c   son environnement. la longueur l_mix contrôle l'efficacité du
+c   mélange
+c
+c   Le calcul du transport des différentes espèces se fait en prenant
+c   en compte:
+c     1. un flux de masse montant
+c     2. un flux de masse descendant
+c     3. un entrainement
+c     4. un detrainement
+c
+c=======================================================================
+
+c-----------------------------------------------------------------------
+c   declarations:
+c   -------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+c   arguments:
+c   ----------
+
+      INTEGER ngrid,nlay,w2di
+      REAL tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+c$OMP THREADPRIVATE(idetr)
+
+c   local:
+c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+c$OMP THREADPRIVATE(isplit)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical first
+      data first /.false./
+      save first
+c$OMP THREADPRIVATE(first)
+cRC
+
+      character*2 str2
+      character*10 str10
+
+      character (len=20) :: modname='thermcell_sec'
+      character (len=80) :: abort_message
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+c$OMP THREADPRIVATE(ncorrec)
+      
+c
+c-----------------------------------------------------------------------
+c   initialisation:
+c   ---------------
+c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+c
+c-----------------------------------------------------------------------
+c   incrementation eventuelle de tendances precedentes:
+c   ---------------------------------------------------
+
+c       print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+c       print*,'1 OK convect8'
+c                       --------------------
+c
+c
+c                       + + + + + + + + + + +
+c
+c
+c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+c  wh,wt,wo ...
+c
+c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+c
+c
+c                       --------------------   zlev(1)
+c                       \\\\\\\\\\\\\\\\\\\\
+c
+c
+
+c-----------------------------------------------------------------------
+c   Calcul des altitudes des couches
+c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+c      print*,'2 OK convect8'
+c-----------------------------------------------------------------------
+c   Calcul des densites
+c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+c      print*,'3 OK convect8'
+c------------------------------------------------------------------
+c   Calcul de w2, quarre de w a partir de la cape
+c   a partir de w2, on calcule wa, vitesse de l'ascendance
+c
+c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+c   w2 est stoke dans wa
+c
+c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+c   independants par couches que pour calculer l'entrainement
+c   a la base et la hauteur max de l'ascendance.
+c
+c   Indicages:
+c   l'ascendance provenant du niveau k traverse l'interface l avec
+c   une vitesse wa(k,l).
+c
+c                       --------------------
+c
+c                       + + + + + + + + + + 
+c
+c  wa(k,l)   ----       --------------------    l
+c             /\
+c            /||\       + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||
+c             ||        + + + + + + + + + + 
+c             ||
+c             ||        --------------------
+c             ||__
+c             |___      + + + + + + + + + +     k
+c
+c                       --------------------
+c
+c
+c
+c------------------------------------------------------------------
+
+cCR: ponderation entrainement des couches instables
+cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+con ne considere que les premieres couches instables
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.
+     s          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k
+            endif
+          enddo
+      enddo
+    
+c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+c
+c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.
+     s          l.ge.lmin(ig).and.l.le.lentr(ig)) then 
+                 entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))*
+c     s                           (zlev(ig,l+1)-zlev(ig,l))
+     s                           *sqrt(zlev(ig,l+1))
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+c
+c      print*,'fin calcul entr_star'
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+cRC
+c      print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+cCR
+            f_star(ig,k)=0.
+cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+c      print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)
+     s         .and.entr_star(ig,l).gt.1.e-10
+     s         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=entr_star(ig,l)
+ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+     s                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.
+     s               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+     s                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+
+     s                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+     s                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+ctest
+               if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then
+c                  print*,'pb linter'
+               endif
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))
+     s           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               if (zw2(ig,l+1).lt.0.) then
+c                  print*,'pb1 zw2<0'
+               endif
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+c      print*,'fin calcul zw2'
+c
+c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+            lmin(ig)=1
+         endif
+      enddo 
+c    
+c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+c                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*
+     s    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)
+     s    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+c      print*,'avant fermeture'
+c Fermeture,determination de f
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2
+     s                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+c Nouvelle fermeture
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect
+     s             *entr_star2(ig))*entr_star_tot(ig)
+ctest
+c             if (first) then
+c             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+c     s             *wmax(ig))
+c             endif
+         endif
+c         f0(ig)=f(ig)
+c         first=.true.
+      enddo
+c      print*,'apres fermeture'
+
+c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+cCR:test pour entrainer moins que la masse
+       do ig=1,ngrid
+          do l=1,lentr(ig)
+             if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then
+                entr(ig,l+1)=entr(ig,l+1)+entr(ig,l)
+     s                       -0.9*masse(ig,l)/ptimestep
+                entr(ig,l)=0.9*masse(ig,l)/ptimestep
+             endif
+          enddo
+       enddo
+cCR: fin test
+c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+cRC
+
+
+c      print*,'9 OK convect8'
+c     print*,'WA1 ',wa_moy
+
+c   determination de l'indice du debut de la mixed layer ou w decroit
+
+c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+c   d'une couche est égale à la hauteur de la couche alimentante.
+c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect
+     s         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+c              if (idetr.eq.0) then
+c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+c                   print*,'pb l_mix*zlev<0'
+                  endif
+cCR: test: nouvelle def de lambda
+c                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  if (zw2(ig,l).gt.1.e-10) then
+                  larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
+                  else
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  endif
+cRC
+c              else if (idetr.eq.1) then
+c                 larg_detr(ig,l)=larg_cons(ig,l)
+c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+c              else if (idetr.eq.2) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *sqrt(wa_moy(ig,l))
+c              else if (idetr.eq.4) then
+c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+c    s            *wa_moy(ig,l)
+c              endif
+            endif
+         enddo
+       enddo
+
+c      print*,'10 OK convect8'
+c     print*,'WA2 ',wa_moy
+c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+c   compte de l'epluchage du thermique.
+c
+cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)
+     s        then
+c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))
+     s        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))
+     s        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))
+     s        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))
+     s        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+            else
+            zmix(ig)=zlev(ig,lmix(ig))
+c            print*,'pb zmix'
+            endif
+         else 
+         zmix(ig)=0.
+         endif
+ctest
+         if ((zmax(ig)-zmix(ig)).lt.0.) then
+            zmix(ig)=0.99*zmax(ig)
+c            print*,'pb zmix>zmax'
+         endif
+      enddo
+c
+c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.
+     s          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))
+     s            /(r_aspect*zmax(ig))
+c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/
+     s     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)
+     s    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)
+     s    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+c                   print*,'pb xxx'
+                   xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+      
+c      print*,'fin calcul fraca'
+c      print*,'11 OK convect8'
+c     print*,'Ea3 ',wa_moy
+c------------------------------------------------------------------
+c   Calcul de fracd, wd
+c   somme wa - wd = 0
+c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)
+     s            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+c                 write(1,*)'ajustement fm, l',l
+              endif
+c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+              abort_message = 'fracd trop petit'
+              CALL abort_gcm (modname,abort_message,1)
+            else
+c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+c      print*,'12 OK convect8'
+c     print*,'WA4 ',wa_moy
+cc------------------------------------------------------------------
+c   calcul du transport vertical
+c------------------------------------------------------------------
+
+      go to 4444
+c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)
+     s      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+c    s         ,fm(ig,l+1)*ptimestep
+c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+c    s         ,entr(ig,l)*ptimestep
+c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10
+     s         .or..not.masse(ig,l).le.1.e4) then
+c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+c    s         ,'   M=',masse(ig,l)
+c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+c     print*,'zlev(ig,l+1),zlev(ig,l)'
+c    s                ,zlev(ig,l+1),zlev(ig,l)
+c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+cCR:redefinition du entr
+       do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+cRC
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/tho
+         entr0=entr0+ptimestep*(entr-entr0)/tho
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca
+     .    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,fraca,zmax
+     .    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+     .    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+c     print*,'13 OK convect8'
+c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+c     do l=1,nlay
+c        do ig=1,ngrid
+c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdtadj=',pdtadj(ig,l)
+c           endif
+c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+c     print*,'WARN!!! ig=',ig,'  l=',l
+c    s         ,'   pdoadj=',pdoadj(ig,l)
+c           endif
+c        enddo
+c      enddo
+
+c      print*,'14 OK convect8'
+c------------------------------------------------------------------
+c   Calculs pour les sorties
+c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)
+     s      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+cdeja fait
+c      do l=1,nlay
+c         do ig=1,ngrid
+c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+c            if (detr(ig,l).lt.0.) then
+c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+c                detr(ig,l)=0.
+c     print*,'WARNING !!! detrainement negatif ',ig,l
+c            endif
+c         enddo
+c      enddo
+
+c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+c   recalcul des flux en diagnostique...
+c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+c     print*,'18 OK convect8'
+c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+c     if(wa_moy(1,4).gt.1.e-10) stop
+
+c      print*,'19 OK convect8'
+      return
+      end
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_old.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_old.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_old.F90	(revision 17)
@@ -0,0 +1,6158 @@
+      SUBROUTINE thermcell_2002(ngrid,nlay,ptimestep                                 &
+       &                  ,pplay,pplev,pphi                                          &
+       &                  ,pu,pv,pt,po                                               &
+       &                  ,pduadj,pdvadj,pdtadj,pdoadj                               &
+       &                  ,fm0,entr0                                                 &
+!c    s                  ,pu_therm,pv_therm                                          &
+       &                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+!c=======================================================================
+!c
+!c   Calcul du transport verticale dans la couche limite en presence
+!c   de "thermiques" explicitement representes
+!c
+!c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+!c
+!c   le thermique est supposé homogène et dissipé par mélange avec
+!c   son environnement. la longueur l_mix contrôle l'efficacité du
+!c   mélange
+!c
+!c   Le calcul du transport des différentes espèces se fait en prenant
+!c   en compte:
+!c     1. un flux de masse montant
+!c     2. un flux de masse descendant
+!c     3. un entrainement
+!c     4. un detrainement
+!c
+!c=======================================================================
+
+!c-----------------------------------------------------------------------
+!c   declarations:
+!c   -------------
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+!c   arguments:
+!c   ----------
+
+      INTEGER ngrid,nlay,w2di
+      REAL tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+!$OMP THREADPRIVATE(idetr)
+
+!c   local:
+!c   ------
+
+      INTEGER ig,k,l,lmax(klon,klev+1),lmaxa(klon),lmix(klon)
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+!$OMP THREADPRIVATE(isplit)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+      real wmax(klon,klev),wmaxa(klon)
+
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+      character (len=2) :: str2
+      character (len=10) :: str10
+
+      character (len=20) :: modname='thermcell2002'
+      character (len=80) :: abort_message
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+!$OMP THREADPRIVATE(ncorrec)
+
+!c
+!c-----------------------------------------------------------------------
+!c   initialisation:
+!c   ---------------
+!c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+!c
+!c-----------------------------------------------------------------------
+!c   incrementation eventuelle de tendances precedentes:
+!c   ---------------------------------------------------
+
+      print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+!c     print*,'1 OK convect8'
+!c                       --------------------
+!c
+!c
+!c                       + + + + + + + + + + +
+!c
+!c
+!c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+!c  wh,wt,wo ...
+!c
+!c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+!c
+!c
+!c                       --------------------   zlev(1)
+!c                       \\\\\\\\\\\\\\\\\\\\
+!c
+!c
+
+!c-----------------------------------------------------------------------
+!c   Calcul des altitudes des couches
+!c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+!c     print*,'2 OK convect8'
+!c-----------------------------------------------------------------------
+!c   Calcul des densites
+!c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+!c     print*,'3 OK convect8'
+!c------------------------------------------------------------------
+!c   Calcul de w2, quarre de w a partir de la cape
+!c   a partir de w2, on calcule wa, vitesse de l'ascendance
+!c
+!c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+!c   w2 est stoke dans wa
+!c
+!c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+!c   independants par couches que pour calculer l'entrainement
+!c   a la base et la hauteur max de l'ascendance.
+!c
+!c   Indicages:
+!c   l'ascendance provenant du niveau k traverse l'interface l avec
+!c   une vitesse wa(k,l).
+!c
+!c                       --------------------
+!c
+!c                       + + + + + + + + + + 
+!c
+!c  wa(k,l)   ----       --------------------    l
+!c             /\
+!c            /||\       + + + + + + + + + + 
+!c             ||
+!c             ||        --------------------
+!c             ||
+!c             ||        + + + + + + + + + + 
+!c             ||
+!c             ||        --------------------
+!c             ||__
+!c             |___      + + + + + + + + + +     k
+!c
+!c                       --------------------
+!c
+!c
+!c
+!c------------------------------------------------------------------
+
+
+      do k=1,nlay-1
+         do ig=1,ngrid
+            wa(ig,k,k)=0.
+            wa(ig,k,k+1)=2.*RG*(ztv(ig,k)-ztv(ig,k+1))/ztv(ig,k+1)                   &
+       &      *(zlev(ig,k+1)-zlev(ig,k))
+         enddo
+         do l=k+1,nlay-1
+            do ig=1,ngrid
+               wa(ig,k,l+1)=wa(ig,k,l)+                                              &
+       &         2.*RG*(ztv(ig,k)-ztv(ig,l))/ztv(ig,l)                               &
+       &         *(zlev(ig,l+1)-zlev(ig,l))
+            enddo
+         enddo
+         do ig=1,ngrid
+            wa(ig,k,nlay+1)=0.
+         enddo
+      enddo
+
+!c     print*,'4 OK convect8'
+!c Calcul de la couche correspondant a la hauteur du thermique
+      do k=1,nlay-1
+         do ig=1,ngrid
+            lmax(ig,k)=k
+         enddo
+         do l=nlay,k+1,-1
+            do ig=1,ngrid
+               if(wa(ig,k,l).le.1.e-10) lmax(ig,k)=l-1
+            enddo
+         enddo
+      enddo
+
+!c     print*,'5 OK convect8'
+!c   Calcule du w max du thermique
+      do k=1,nlay
+      do ig=1,ngrid
+         wmax(ig,k)=0.
+      enddo
+      enddo
+
+      do k=1,nlay-1
+         do l=k,nlay
+            do ig=1,ngrid
+               if (l.le.lmax(ig,k)) then
+                  wa(ig,k,l)=sqrt(wa(ig,k,l))
+                  wmax(ig,k)=max(wmax(ig,k),wa(ig,k,l))
+               else
+                  wa(ig,k,l)=0.
+               endif
+            enddo
+         enddo
+      enddo
+
+      do k=1,nlay-1
+         do ig=1,ngrid
+             pu_therm(ig,k)=sqrt(wmax(ig,k))
+             pv_therm(ig,k)=sqrt(wmax(ig,k))
+         enddo
+      enddo
+
+!c     print*,'6 OK convect8'
+!c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=500.
+      enddo
+!c     print*,'LMAX LMAX LMAX '
+      do k=1,nlay-1
+         do  ig=1,ngrid
+            zmax(ig)=max(zmax(ig),zlev(ig,lmax(ig,k))-zlev(ig,k))
+         enddo
+!c     print*,k,lmax(1,k)
+      enddo
+!c     print*,'ZMAX ZMAX ZMAX ',zmax
+!c      call dump2d(iim,jjm-1,zmax(2:ngrid-1),'ZMAX      ')
+
+!c   Calcul de l'entrainement.
+!c   Le rapport d'aspect relie la largeur de l'ascendance a l'epaisseur
+!c   de la couche d'alimentation en partant du principe que la vitesse
+!c   maximum dans l'ascendance est la vitesse d'entrainement horizontale.
+      do k=1,nlay
+         do ig=1,ngrid
+            zzz=rho(ig,k)*wmax(ig,k)*(zlev(ig,k+1)-zlev(ig,k))                       &
+       &    /(zmax(ig)*r_aspect)
+            if(w2di.eq.2) then
+               entr(ig,k)=entr(ig,k)+                                                &
+       &         ptimestep*(zzz-entr(ig,k))/tho
+            else
+               entr(ig,k)=zzz
+            endif
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+
+!c     print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+!c     print*,'8 OK convect8'
+      do ig=1,ngrid
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+
+      do l=1,nlay-2
+         do ig=1,ngrid
+!c           if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1)) then
+!c         print*,'COUCOU ',l,zw2(ig,l),ztv(ig,l),ztv(ig,l+1)
+            if (zw2(ig,l).lt.1.e-10.and.ztv(ig,l).gt.ztv(ig,l+1)                     &
+       &       .and.entr(ig,l).gt.1.e-10) then
+!c        print*,'COUCOU cas 1'
+!c   Initialisation de l'ascendance
+!c              lmix(ig)=1
+               ztva(ig,l)=ztv(ig,l)
+               fmc(ig,l)=0.
+               fmc(ig,l+1)=entr(ig,l)
+               zw2(ig,l)=0.
+!c     if (.not.ztv(ig,l+1).gt.150.) then
+!c     print*,'ig,l+1,ztv(ig,l+1)'
+!c     print*, ig,l+1,ztv(ig,l+1)
+!c     endif
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)                 &
+       &         *(zlev(ig,l+1)-zlev(ig,l))
+               larg_detr(ig,l)=0.
+            else if (zw2(ig,l).ge.1.e-10.and.                                        &
+       &               fmc(ig,l)+entr(ig,l).gt.1.e-10) then
+!c   Incrementation...
+               fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+!c     if (.not.fmc(ig,l+1).gt.1.e-15) then
+!c     print*,'ig,l+1,fmc(ig,l+1)'
+!c     print*, ig,l+1,fmc(ig,l+1)
+!c     print*,'Fmc ',(fmc(ig,ll),ll=1,klev+1)
+!c     print*,'W2 ',(zw2(ig,ll),ll=1,klev+1)
+!c     print*,'Tv ',(ztv(ig,ll),ll=1,klev)
+!c     print*,'Entr ',(entr(ig,ll),ll=1,klev)
+!c     endif
+               ztva(ig,l)=(fmc(ig,l)*ztva(ig,l-1)+entr(ig,l)*ztv(ig,l))              &
+       &          /fmc(ig,l+1)
+!c  mise a jour de la vitesse ascendante (l'air entraine de la couche
+!c  consideree commence avec une vitesse nulle).
+               zw2(ig,l+1)=zw2(ig,l)*(fmc(ig,l)/fmc(ig,l+1))**2+                     &
+       &         2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)                              &
+       &         *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+            if (zw2(ig,l+1).lt.0.) then
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+!c        print*,'COUCOU cas 2 LMIX=',lmix(ig),wa_moy(ig,l+1),wmaxa(ig)
+         enddo
+      enddo
+
+!c     print*,'9 OK convect8'
+!c     print*,'WA1 ',wa_moy
+
+!c   determination de l'indice du debut de la mixed layer ou w decroit
+
+!c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+!c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+!c   d'une couche est égale à la hauteur de la couche alimentante.
+!c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+!c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect                                     &
+       &         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+!c              if (idetr.eq.0) then
+!c  cette option est finalement en dur.
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c              else if (idetr.eq.1) then
+!c                 larg_detr(ig,l)=larg_cons(ig,l)
+!c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+!c              else if (idetr.eq.2) then
+!c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c    s            *sqrt(wa_moy(ig,l))
+!c              else if (idetr.eq.4) then
+!c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c    s            *wa_moy(ig,l)
+!c              endif
+            endif
+         enddo
+       enddo
+
+!c     print*,'10 OK convect8'
+!c     print*,'WA2 ',wa_moy
+!c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+!c   compte de l'epluchage du thermique.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+!c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))                         &
+       &            /(r_aspect*zmax(ig))
+               if(l.gt.lmix(ig)) then
+                  xxx(ig,l)=(lmaxa(ig)+1.-l) / (lmaxa(ig)+1.-lmix(ig))
+           if (idetr.eq.0) then
+               fraca(ig,l)=fraca(ig,lmix(ig))
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fraca(ig,lmix(ig))*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fraca(ig,lmix(ig))*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fraca(ig,lmix(ig))*xxx(ig,l)**2
+           endif
+               endif
+!c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+!c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo
+
+!c     print*,'11 OK convect8'
+!c     print*,'Ea3 ',wa_moy
+!c------------------------------------------------------------------
+!c   Calcul de fracd, wd
+!c   somme wa - wd = 0
+!c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+              abort_message = 'fracd trop petit'
+              CALL abort_gcm (modname,abort_message,1) 
+           else
+!c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+!c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+!c     print*,'12 OK convect8'
+!c     print*,'WA4 ',wa_moy
+!cc------------------------------------------------------------------
+!c   calcul du transport vertical
+!c------------------------------------------------------------------
+
+      go to 4444
+!c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)                                   &
+       &      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+!c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+!c    s         ,fm(ig,l+1)*ptimestep
+!c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+!c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+!c    s         ,entr(ig,l)*ptimestep
+!c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+!c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+!c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10                                            &
+       &         .or..not.masse(ig,l).le.1.e4) then
+!c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+!c    s         ,'   M=',masse(ig,l)
+!c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+!c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+!c     print*,'zlev(ig,l+1),zlev(ig,l)'
+!c    s                ,zlev(ig,l+1),zlev(ig,l)
+!c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+!c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+!c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+!c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/tho
+         entr0=entr0+ptimestep*(entr-entr0)/tho
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca                &
+       &    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca                &
+       &    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse                      &
+       &    ,fraca,zmax                                                              &
+       &    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+!c     print*,'13 OK convect8'
+!c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+!c     do l=1,nlay
+!c        do ig=1,ngrid
+!c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+!c     print*,'WARN!!! ig=',ig,'  l=',l
+!c    s         ,'   pdtadj=',pdtadj(ig,l)
+!c           endif
+!c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+!c     print*,'WARN!!! ig=',ig,'  l=',l
+!c    s         ,'   pdoadj=',pdoadj(ig,l)
+!c           endif
+!c        enddo
+!c      enddo
+
+!c     print*,'14 OK convect8'
+!c------------------------------------------------------------------
+!c   Calculs pour les sorties
+!c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)                                             &
+       &      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+!c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+
+!c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+!c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+!c   recalcul des flux en diagnostique...
+!c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+!c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+!c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+!c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+
+!c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+!c     print*,'18 OK convect8'
+!c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+!c     if(wa_moy(1,4).gt.1.e-10) stop
+
+!c     print*,'19 OK convect8'
+      return
+      end SUBROUTINE thermcell_2002
+
+      SUBROUTINE thermcell_cld(ngrid,nlay,ptimestep                                  &
+       &                  ,pplay,pplev,pphi,zlev,debut                               &
+       &                  ,pu,pv,pt,po                                               &
+       &                  ,pduadj,pdvadj,pdtadj,pdoadj                               &
+       &                  ,fm0,entr0,zqla,lmax                                       &
+       &                  ,zmax_sec,wmax_sec,zw_sec,lmix_sec                         &
+       &                  ,ratqscth,ratqsdiff                                        &
+!c    s                  ,pu_therm,pv_therm                                          &
+       &                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+!c=======================================================================
+!c
+!c   Calcul du transport verticale dans la couche limite en presence
+!c   de "thermiques" explicitement representes
+!c
+!c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+!c
+!c   le thermique est supposé homogène et dissipé par mélange avec
+!c   son environnement. la longueur l_mix contrôle l'efficacité du
+!c   mélange
+!c
+!c   Le calcul du transport des différentes espèces se fait en prenant
+!c   en compte:
+!c     1. un flux de masse montant
+!c     2. un flux de masse descendant
+!c     3. un entrainement
+!c     4. un detrainement
+!c
+!c=======================================================================
+
+!c-----------------------------------------------------------------------
+!c   declarations:
+!c   -------------
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+!c   arguments:
+!c   ----------
+
+      INTEGER ngrid,nlay,w2di
+      REAL tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+!$OMP THREADPRIVATE(idetr)
+
+!c   local:
+!c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+!c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon)
+      real alpha
+      save alpha
+      data alpha/1./
+!$OMP THREADPRIVATE(alpha)
+
+!c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+      real zmax_sec(klon)
+      real zmax_sec2(klon)
+      real zw_sec(klon,klev+1)
+      INTEGER lmix_sec(klon)
+      real w_est(klon,klev+1)
+!con garde le zmax du pas de temps precedent
+!c      real zmax0(klon)
+!c      save zmax0
+!c      real zmix0(klon)
+!c      save zmix0 
+      REAL, SAVE, ALLOCATABLE :: zmax0(:), zmix0(:)
+!$OMP THREADPRIVATE(zmax0, zmix0)
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      real deltaz(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      real zthl(klon,klev),zdthladj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      real zl(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zta(klon,klev)
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev),wth3(klon,klev)
+      real q2(klon,klev)
+      real dtheta(klon,klev)
+!      common/comtherm/thetath2,wth2
+    
+      real ratqscth(klon,klev)
+      real sum
+      real sumdiff
+      real ratqsdiff(klon,klev)
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+!$OMP THREADPRIVATE(isplit)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+!c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wmax_sec(klon)
+      real wmax_sec2(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real massetot(klon,klev)
+      real detr0(klon,klev)
+      real alim0(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef(klon),qsatbef(klon)
+      real dqsat_dT,DT,num,denom
+      REAL REPS,RLvCp,DDT0
+      real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev)
+!cCR niveau de condensation
+      real nivcon(klon)
+      real zcon(klon)
+      real zqsat(klon,klev)
+      real zqsatth(klon,klev) 
+      PARAMETER (DDT0=.01)
+
+
+!cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real detr_star(klon,klev)
+      real alim_star_tot(klon),alim_star2(klon)
+      real entr_star_tot(klon)
+      real detr_star_tot(klon)
+      real alim_star(klon,klev)
+      real alim(klon,klev)
+      real nu(klon,klev)
+      real nu_e(klon,klev)
+      real nu_min
+      real nu_max
+      real nu_r
+      real f(klon)
+!c      real f(klon), f0(klon)
+!c     save f0
+      REAL,SAVE, ALLOCATABLE :: f0(:)
+!$OMP THREADPRIVATE(f0)
+
+      real f_old
+      real zlevinter(klon)
+      logical, save :: first = .true.
+!$OMP THREADPRIVATE(first)
+!c      data first /.false./
+!c      save first
+      logical nuage
+!c      save nuage
+      logical boucle
+      logical therm
+      logical debut
+      logical rale
+      integer test(klon)
+      integer signe_zw2
+!cRC
+
+      character*2 str2
+      character*10 str10
+
+      character (len=20) :: modname='thermcell_cld'
+      character (len=80) :: abort_message
+
+      LOGICAL vtest(klon),down
+      LOGICAL Zsat(klon)
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+!$OMP THREADPRIVATE(ncorrec)
+
+!c
+
+!c-----------------------------------------------------------------------
+!c   initialisation:
+!c   ---------------
+!c
+      if (first) then
+        allocate(zmix0(klon))
+        allocate(zmax0(klon))
+        allocate(f0(klon))
+        first=.false.
+      endif
+
+       sorties=.false.
+!c     print*,'NOUVEAU DETR PLUIE '
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+!c
+!c Initialisation
+      RLvCp = RLVTT/RCPD
+      REPS  = RD/RV
+!cinitialisations de zqsat
+      DO ll=1,nlay
+         DO ig=1,ngrid
+            zqsat(ig,ll)=0.
+            zqsatth(ig,ll)=0.
+         ENDDO
+      ENDDO
+!c
+!con met le first a true pour le premier passage de la journée
+      do ig=1,klon
+            test(ig)=0
+      enddo
+      if (debut) then
+         do ig=1,klon
+            test(ig)=1
+            f0(ig)=0.
+            zmax0(ig)=0.
+         enddo
+      endif
+      do ig=1,klon      
+         if ((.not.debut).and.(f0(ig).lt.1.e-10)) then
+            test(ig)=1
+         endif
+      enddo 
+!c     do ig=1,klon
+!c        print*,'test(ig)',test(ig),zmax0(ig)
+!c     enddo
+      nuage=.false.
+!c-----------------------------------------------------------------------
+!cAM Calcul de T,q,ql a partir de Tl et qT
+!c   ---------------------------------------------------
+!c
+!c Pr Tprec=Tl calcul de qsat 
+!c Si qsat>qT T=Tl, q=qT
+!c Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) 
+!c On cherche DDT < DDT0
+!c
+!c defaut
+       DO  ll=1,nlay
+         DO ig=1,ngrid
+            zo(ig,ll)=po(ig,ll)
+            zl(ig,ll)=0.
+            zh(ig,ll)=pt(ig,ll)
+         EndDO
+       EndDO
+       do ig=1,ngrid
+          Zsat(ig)=.false.
+       enddo
+!c
+!c
+       DO ll=1,nlay
+!c les points insatures sont definitifs
+         DO ig=1,ngrid
+            Tbef(ig)=pt(ig,ll)
+            zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+            qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+            qsatbef(ig)=MIN(0.5,qsatbef(ig))
+            zcor=1./(1.-retv*qsatbef(ig))
+            qsatbef(ig)=qsatbef(ig)*zcor
+            Zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig)) .gt. 1.e-10)
+         EndDO
+
+         DO ig=1,ngrid
+           if (Zsat(ig).and.(1.eq.1)) then
+            qlbef=max(0.,po(ig,ll)-qsatbef(ig))
+!c si sature: ql est surestime, d'ou la sous-relax
+            DT = 0.5*RLvCp*qlbef
+!c            write(18,*),'DT0=',DT
+!c on pourra enchainer 2 ou 3 calculs sans Do while
+            do while (abs(DT).gt.DDT0)
+!c il faut verifier si c,a conserve quand on repasse en insature ...
+              Tbef(ig)=Tbef(ig)+DT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+              qsatbef(ig)=MIN(0.5,qsatbef(ig))
+              zcor=1./(1.-retv*qsatbef(ig))
+              qsatbef(ig)=qsatbef(ig)*zcor
+!c on veut le signe de qlbef
+              qlbef=po(ig,ll)-qsatbef(ig)
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+              zcor=1./(1.-retv*qsatbef(ig))
+              dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+              num=-Tbef(ig)+pt(ig,ll)+RLvCp*qlbef
+              denom=1.+RLvCp*dqsat_dT
+              if (denom.lt.1.e-10) then
+                  print*,'pb denom'
+              endif
+              DT=num/denom
+            enddo
+!c on ecrit de maniere conservative (sat ou non)
+            zl(ig,ll) = max(0.,qlbef)
+!c          T = Tl +Lv/Cp ql
+            zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)
+            zo(ig,ll) = po(ig,ll)-zl(ig,ll)
+           endif
+!con ecrit zqsat 
+            zqsat(ig,ll)=qsatbef(ig)     
+         EndDO
+       EndDO
+!cAM fin
+!c
+!c-----------------------------------------------------------------------
+!c   incrementation eventuelle de tendances precedentes:
+!c   ---------------------------------------------------
+
+!c     print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+             zpspsk(ig,l)=(pplay(ig,l)/100000.)**RKAPPA
+!c            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+!c            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+!c            zo(ig,l)=po(ig,l)
+!c            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+!cAM attention zh est maintenant le profil de T et plus le profil de theta !
+!c
+!c   T-> Theta
+            ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+!cAM Theta_v
+            ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l))                                  &
+       &           -zl(ig,l))
+!cAM Thetal
+            zthl(ig,l)=pt(ig,l)/zpspsk(ig,l)
+!c            
+1015     CONTINUE
+1010  CONTINUE
+
+!c     print*,'1 OK convect8'
+!c                       --------------------
+!c
+!c
+!c                       + + + + + + + + + + +
+!c
+!c
+!c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+!c  wh,wt,wo ...
+!c
+!c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+!c
+!c
+!c                       --------------------   zlev(1)
+!c                       \\\\\\\\\\\\\\\\\\\\
+!c
+!c
+
+!c-----------------------------------------------------------------------
+!c   Calcul des altitudes des couches
+!c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+!ccalcul de deltaz
+      do l=1,nlay
+         do ig=1,ngrid
+            deltaz(ig,l)=zlev(ig,l+1)-zlev(ig,l)
+         enddo
+      enddo
+
+!c     print*,'2 OK convect8'
+!c-----------------------------------------------------------------------
+!c   Calcul des densites
+!c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+!c            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+             rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*ztv(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+!cCr:ajout:calcul de la masse
+      do l=1,nlay
+         do ig=1,ngrid
+!c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+!c     print*,'3 OK convect8'
+!c------------------------------------------------------------------
+!c   Calcul de w2, quarre de w a partir de la cape
+!c   a partir de w2, on calcule wa, vitesse de l'ascendance
+!c
+!c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+!c   w2 est stoke dans wa
+!c
+!c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+!c   independants par couches que pour calculer l'entrainement
+!c   a la base et la hauteur max de l'ascendance.
+!c
+!c   Indicages:
+!c   l'ascendance provenant du niveau k traverse l'interface l avec
+!c   une vitesse wa(k,l).
+!c
+!c                       --------------------
+!c
+!c                       + + + + + + + + + + 
+!c
+!c  wa(k,l)   ----       --------------------    l
+!c             /\
+!c            /||\       + + + + + + + + + + 
+!c             ||
+!c             ||        --------------------
+!c             ||
+!c             ||        + + + + + + + + + + 
+!c             ||
+!c             ||        --------------------
+!c             ||__
+!c             |___      + + + + + + + + + +     k
+!c
+!c                       --------------------
+!c
+!c
+!c
+!c------------------------------------------------------------------
+
+!cCR: ponderation entrainement des couches instables
+!cdef des alim_star tels que alim=f*alim_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            alim_star(ig,l)=0.
+            alim(ig,l)=0.
+         enddo
+      enddo
+!c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+!con ne considere que les premieres couches instables
+      therm=.false.
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.                                        &
+       &          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k+1
+               therm=.true.
+            endif
+          enddo
+      enddo
+!c
+!c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+!c
+!c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.                                        &
+       &          l.ge.lmin(ig).and.l.lt.lentr(ig)) then
+!cdef possibles pour alim_star: zdthetadz, dthetadz, zdtheta
+             alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)                         &
+!c     s                       *(zlev(ig,l+1)-zlev(ig,l))                            &
+       &                       *sqrt(zlev(ig,l+1))
+!c             alim_star(ig,l)=zlev(ig,l+1)*(1.-(zlev(ig,l+1)
+!c     s                         /zlev(ig,lentr(ig)+2)))**(3./2.) 
+            endif
+         enddo
+      enddo
+      
+!c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+!c         if (lmin(ig).gt.1) then
+!cCRnouveau test
+        if (alim_star(ig,1).lt.1.e-10) then 
+            do l=1,klev
+                alim_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+!c calcul de l entrainement total
+      do ig=1,ngrid
+         alim_star_tot(ig)=0.
+         entr_star_tot(ig)=0.
+         detr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,k)
+         enddo
+      enddo
+!c
+!c Calcul entrainement normalise
+      do ig=1,ngrid 
+         if (alim_star_tot(ig).gt.1.e-10) then
+!c         do l=1,lentr(ig)
+          do l=1,klev
+!cdef possibles pour entr_star: zdthetadz, dthetadz, zdtheta 
+            alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
+         enddo
+         endif
+      enddo
+       
+!c     print*,'fin calcul alim_star'
+
+!cAM:initialisations
+      do k=1,nlay
+         do ig=1,ngrid
+            ztva(ig,k)=ztv(ig,k)
+            ztla(ig,k)=zthl(ig,k)
+            zqla(ig,k)=0.
+            zqta(ig,k)=po(ig,k)
+            Zsat(ig) =.false.
+         enddo
+      enddo 
+      do k=1,klev
+        do ig=1,ngrid
+           detr_star(ig,k)=0.
+           entr_star(ig,k)=0.
+           detr(ig,k)=0.
+           entr(ig,k)=0.
+        enddo
+      enddo
+!c     print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+!cCR
+            f_star(ig,k)=0.
+!cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+!cn     print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+      nu_min=l_mix
+      nu_max=1000.
+!c      do ig=1,ngrid
+!c      nu_max=wmax_sec(ig)
+!c      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            nu(ig,k)=0.
+            nu_e(ig,k)=0.
+         enddo
+      enddo
+!cCalcul de l'excès de température du à la diffusion turbulente
+      do ig=1,ngrid
+         do l=1,klev
+            dtheta(ig,l)=0.
+         enddo
+       enddo
+      do ig=1,ngrid
+         do l=1,lentr(ig)-1
+      dtheta(ig,l)=sqrt(10.*0.4*zlev(ig,l+1)**2*1.                                   &
+       &          *((ztv(ig,l+1)-ztv(ig,l))/(zlev(ig,l+1)-zlev(ig,l)))**2)
+         enddo
+       enddo
+!c      do l=1,nlay-2
+      do l=1,klev-1
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)                                             &
+       &         .and.alim_star(ig,l).gt.1.e-10                                      &
+       &         .and.zw2(ig,l).lt.1e-10) then
+!cAM
+!ctest:on rajoute un excès de T dans couche alim
+!c               ztla(ig,l)=zthl(ig,l)+dtheta(ig,l)
+               ztla(ig,l)=zthl(ig,l) 
+!ctest: on rajoute un excès de q dans la couche alim
+!c               zqta(ig,l)=po(ig,l)+0.001
+               zqta(ig,l)=po(ig,l)
+               zqla(ig,l)=zl(ig,l)
+!cAM
+               f_star(ig,l+1)=alim_star(ig,l)
+!ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)                 &
+       &                     *(zlev(ig,l+1)-zlev(ig,l))                              &
+       &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               w_est(ig,l+1)=zw2(ig,l+1)
+               larg_detr(ig,l)=0.
+!c     print*,'coucou boucle 1'
+            else if ((zw2(ig,l).ge.1e-10).and.                                       &
+       &         (f_star(ig,l)+alim_star(ig,l)).gt.1.e-10) then
+!c     print*,'coucou boucle 2'
+!cestimation du detrainement a partir de la geometrie du pas precedent
+      if ((test(ig).eq.1).or.((.not.debut).and.(f0(ig).lt.1.e-10))) then
+                  detr_star(ig,l)=0.
+                  entr_star(ig,l)=0.
+!c     print*,'coucou test(ig)',test(ig),f0(ig),zmax0(ig)
+             else
+!c     print*,'coucou debut detr'
+!ctests sur la definition du detr
+        if (zqla(ig,l-1).gt.1.e-10) then
+           nuage=.true.
+        endif 
+
+             w_est(ig,l+1)=zw2(ig,l)*                                                &
+       &                   ((f_star(ig,l))**2)                                       &
+       &                   /(f_star(ig,l)+alim_star(ig,l))**2+                       &
+       &                   2.*RG*(ztva(ig,l-1)-ztv(ig,l))/ztv(ig,l)                  &
+       &                   *(zlev(ig,l+1)-zlev(ig,l))
+             if (w_est(ig,l+1).lt.0.) then
+                w_est(ig,l+1)=zw2(ig,l)
+             endif
+      if (l.gt.2) then
+             if ((w_est(ig,l+1).gt.w_est(ig,l)).and.                                 &
+       &           (zlev(ig,l+1).lt.zmax_sec(ig)).and.                               &
+       &            (zqla(ig,l-1).lt.1.e-10)) then 
+             detr_star(ig,l)=MAX(0.,(rhobarz(ig,l+1)                                 &
+       &                *sqrt(w_est(ig,l+1))*sqrt(nu(ig,l)*zlev(ig,l+1))             &
+       &       -rhobarz(ig,l)*sqrt(w_est(ig,l))*sqrt(nu(ig,l)*zlev(ig,l)))           &
+       &       /(r_aspect*zmax_sec(ig)))
+             else if ((zlev(ig,l+1).lt.zmax_sec(ig)).and.                            &
+       &                (zqla(ig,l-1).lt.1.e-10)) then
+       detr_star(ig,l)=-f0(ig)*f_star(ig,lmix(ig))                                   &
+       & /(rhobarz(ig,lmix(ig))*wmaxa(ig))*                                          &
+       & (rhobarz(ig,l+1)*sqrt(w_est(ig,l+1))                                        &
+       & *((zmax_sec(ig)-zlev(ig,l+1))/((zmax_sec(ig)-zlev(ig,lmix(ig)))))           &
+       & **2.                                                                        &
+       & -rhobarz(ig,l)*sqrt(w_est(ig,l))                                            &
+       & *((zmax_sec(ig)-zlev(ig,l))/((zmax_sec(ig)-zlev(ig,lmix(ig)))))             &
+       & **2.)
+             else
+       detr_star(ig,l)=0.002*f0(ig)*f_star(ig,l)                                     &
+       &                *(zlev(ig,l+1)-zlev(ig,l))
+             
+             endif
+        else
+        detr_star(ig,l)=0.
+        endif
+       
+         detr_star(ig,l)=detr_star(ig,l)/f0(ig)
+         if (nuage) then
+         entr_star(ig,l)=0.4*detr_star(ig,l)
+         else
+         entr_star(ig,l)=0.4*detr_star(ig,l)
+         endif
+
+             if ((detr_star(ig,l)).gt.f_star(ig,l)) then
+              detr_star(ig,l)=f_star(ig,l)
+!c              entr_star(ig,l)=0.
+              endif
+
+             if ((l.lt.lentr(ig))) then
+                 entr_star(ig,l)=0.
+!c                 detr_star(ig,l)=0.
+             endif  
+
+!c           print*,'ok detr_star'
+      endif
+!cprise en compte du detrainement dans le calcul du flux
+             f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)             &
+       &                      -detr_star(ig,l)
+!ctest
+!c             if (f_star(ig,l+1).lt.0.) then
+!c                f_star(ig,l+1)=0.
+!c                entr_star(ig,l)=0.
+!c                detr_star(ig,l)=f_star(ig,l)+alim_star(ig,l)
+!c             endif
+!ctest sur le signe de f_star
+       if (f_star(ig,l+1).gt.1.e-10) then 
+!c                 then
+!ctest
+!c         if (((f_star(ig,l+1)+detr_star(ig,l)).gt.1.e-10)) then
+!cAM on melange Tl et qt du thermique
+!con rajoute un excès de T dans la couche alim
+!c               if (l.lt.lentr(ig)) then
+!c           ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+
+!c     s     (alim_star(ig,l)+entr_star(ig,l))*(zthl(ig,l)+dtheta(ig,l)))
+!c     s     /(f_star(ig,l+1)+detr_star(ig,l))
+!c               else
+               ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+                                &
+       &                    (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l))            &
+       &                 /(f_star(ig,l+1)+detr_star(ig,l))
+!c     s                    /(f_star(ig,l+1)) 
+!c               endif
+!con rajoute un excès de q dans la couche alim
+!c               if (l.lt.lentr(ig)) then
+!c               zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+
+!c     s           (alim_star(ig,l)+entr_star(ig,l))*(po(ig,l)+0.001))
+!c     s                 /(f_star(ig,l+1)+detr_star(ig,l))
+!c               else
+               zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+                                &
+       &                    (alim_star(ig,l)+entr_star(ig,l))*po(ig,l))              &
+       &                 /(f_star(ig,l+1)+detr_star(ig,l))
+!c     s                   /(f_star(ig,l+1))
+!c               endif
+!cAM on en deduit thetav et ql du thermique
+!cCR test
+!c               Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
+               Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+               qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)  
+               qsatbef(ig)=MIN(0.5,qsatbef(ig))
+               zcor=1./(1.-retv*qsatbef(ig))
+               qsatbef(ig)=qsatbef(ig)*zcor
+             Zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig)) .gt. 1.e-10)
+
+           if (Zsat(ig).and.(1.eq.1)) then
+              qlbef=max(0.,zqta(ig,l)-qsatbef(ig))
+              DT = 0.5*RLvCp*qlbef
+!c             write(17,*)'DT0=',DT
+              do while (abs(DT).gt.DDT0)
+!c                 print*,'aie'
+                 Tbef(ig)=Tbef(ig)+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)
+                 qsatbef(ig)=MIN(0.5,qsatbef(ig))
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 qsatbef(ig)=qsatbef(ig)*zcor
+                 qlbef=zqta(ig,l)-qsatbef(ig)
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+                 num=-Tbef(ig)+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 if (denom.lt.1.e-10) then
+                    print*,'pb denom'
+                 endif
+                 DT=num/denom
+!c                 write(17,*)'DT=',DT
+              enddo
+              zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
+              zqla(ig,l) = max(0.,qlbef) 
+!c              zqla(ig,l)=0.
+             endif
+!c             zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
+!c      
+!c on ecrit de maniere conservative (sat ou non)
+!c          T = Tl +Lv/Cp ql
+!cCR rq utilisation de humidite specifique ou rapport de melange?
+           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+!con rajoute le calcul de zha pour diagnostiques (temp potentielle)
+           zha(ig,l) = ztva(ig,l)
+!c           if (l.lt.lentr(ig)) then
+!c           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+!c     s              -zqla(ig,l))-zqla(ig,l)) + 0.1
+!c           else
+           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)                              &
+       &              -zqla(ig,l))-zqla(ig,l))
+!c           endif
+!c           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+!c     s                 /(1.-retv*zqla(ig,l))
+!c           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+!c           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)
+!c     s                 /(1.-retv*zqta(ig,l))
+!c     s              -zqla(ig,l)/(1.-retv*zqla(ig,l)))
+!c     s              -zqla(ig,l)/(1.-retv*zqla(ig,l)))
+!c       write(13,*)zqla(ig,l),zqla(ig,l)/(1.-retv*zqla(ig,l))
+!con ecrit zqsat 
+           zqsatth(ig,l)=qsatbef(ig)  
+!c        enddo
+!c        DO ig=1,ngrid
+!c           if (zw2(ig,l).ge.1.e-10.and.
+!c     s               f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then
+!c  mise a jour de la vitesse ascendante (l'air entraine de la couche
+!c  consideree commence avec une vitesse nulle).
+!c
+!c            if (f_star(ig,l+1).gt.1.e-10) then
+            zw2(ig,l+1)=zw2(ig,l)*                                                   &
+!c     s                  ((f_star(ig,l)-detr_star(ig,l))**2)
+!c     s                  /f_star(ig,l+1)**2+                                        &
+       &                   ((f_star(ig,l))**2)                                       &
+       &                   /(f_star(ig,l+1)+detr_star(ig,l))**2+                     &
+!c     s                    /(f_star(ig,l+1))**2+                                    &
+       &                   2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)                    &
+       &                   *(zlev(ig,l+1)-zlev(ig,l))
+!c     s                   *(f_star(ig,l)/f_star(ig,l+1))**2
+
+            endif
+        endif
+!c
+            if (zw2(ig,l+1).lt.0.) then 
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))                                 &
+       &           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+!c              print*,'linter=',linter(ig)
+!c          else if ((zw2(ig,l+1).lt.1.e-10).and.(zw2(ig,l+1).ge.0.)) then
+!c               linter(ig)=l+1
+!c               print*,'linter=l',zw2(ig,l),zw2(ig,l+1)
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+!c            wa_moy(ig,l+1)=zw2(ig,l+1) 
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+      print*,'fin calcul zw2'
+!c
+!c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+!c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+             lmin(ig)=1
+             lentr(ig)=1
+         endif
+      enddo 
+!c    
+!c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+!c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*                     &
+       &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)               &
+       &    -zlev(ig,lmax(ig)))
+!cpour le cas ou on prend tjs lmin=1
+!c       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,1))
+       zmax0(ig)=zmax(ig)
+       write(11,*)'ig,lmax,linter',ig,lmax(ig),linter(ig)
+       write(12,*)'ig,zlevinter,zmax',ig,zmax(ig),zlevinter(ig)
+      enddo
+
+!cCalcul de zmax_sec et wmax_sec
+      call fermeture_seche(ngrid,nlay                                                &
+       &                  ,pplay,pplev,pphi,zlev,rhobarz,f0,zpspsk                   &
+       &                  ,alim,zh,zo,lentr,lmin,nu_min,nu_max,r_aspect              &
+       &                  ,zmax_sec2,wmax_sec2)
+
+      print*,'avant fermeture'
+!c Fermeture,determination de f
+!c en lmax f=d-e
+      do ig=1,ngrid
+!c      entr_star(ig,lmax(ig))=0.
+!c      f_star(ig,lmax(ig)+1)=0.
+!c      detr_star(ig,lmax(ig))=f_star(ig,lmax(ig))+entr_star(ig,lmax(ig))
+!c     s                       +alim_star(ig,lmax(ig))
+      enddo
+!c
+      do ig=1,ngrid
+         alim_star2(ig)=0.
+      enddo
+!ccalcul de entr_star_tot
+      do ig=1,ngrid
+         do k=1,lmix(ig)
+            entr_star_tot(ig)=entr_star_tot(ig)                                      &
+!c     s                        +entr_star(ig,k)                                     &
+       &                        +alim_star(ig,k)
+!c     s                        -detr_star(ig,k)
+            detr_star_tot(ig)=detr_star_tot(ig)                                      &
+!c     s                        +alim_star(ig,k)                                     &
+       &                        -detr_star(ig,k)                                     &
+       &                        +entr_star(ig,k)
+         enddo
+      enddo
+      
+      do ig=1,ngrid
+         if (alim_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else   
+!c             do k=lmin(ig),lentr(ig)
+             do k=1,lentr(ig)
+                alim_star2(ig)=alim_star2(ig)+alim_star(ig,k)**2                     &
+       &                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+             if ((zmax_sec(ig).gt.1.e-10).and.(1.eq.1)) then 
+             f(ig)=wmax_sec(ig)/(max(500.,zmax_sec(ig))*r_aspect                     &
+       &             *alim_star2(ig))
+             f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/                             &
+       &                     zmax_sec(ig))*wmax_sec(ig))
+             else
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect*alim_star2(ig))
+            f(ig)=f(ig)+(f0(ig)-f(ig))*exp((-ptimestep/                              &
+       &                     zmax(ig))*wmax(ig))
+             endif
+         endif
+         f0(ig)=f(ig)
+      enddo
+      print*,'apres fermeture'
+!c Calcul de l'entrainement
+         do ig=1,ngrid 
+            do k=1,klev
+            alim(ig,k)=f(ig)*alim_star(ig,k)
+         enddo
+      enddo
+!cCR:test pour entrainer moins que la masse
+!c       do ig=1,ngrid
+!c          do l=1,lentr(ig)
+!c             if ((alim(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then
+!c                alim(ig,l+1)=alim(ig,l+1)+alim(ig,l)
+!c     s                       -0.9*masse(ig,l)/ptimestep
+!c                alim(ig,l)=0.9*masse(ig,l)/ptimestep
+!c             endif
+!c          enddo
+!c       enddo
+!c calcul du détrainement
+         do ig=1,klon
+             do k=1,klev
+            detr(ig,k)=f(ig)*detr_star(ig,k)
+            if (detr(ig,k).lt.0.) then
+!c               print*,'detr1<0!!!'
+            endif
+            enddo
+            do k=1,klev
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+            if (entr(ig,k).lt.0.) then
+!c               print*,'entr1<0!!!'
+            endif
+         enddo
+      enddo
+!c
+!c       do ig=1,ngrid
+!c          do l=1,klev
+!c          if (((detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep).gt.
+!c     s          (masse(ig,l))) then  
+!c      print*,'d2+e2+a2>m2','ig=',ig,'l=',l,'lmax(ig)=',lmax(ig),'d+e+a='
+!c     s,(detr(ig,l)+entr(ig,l)+alim(ig,l))*ptimestep,'m=',masse(ig,l)
+!c      endif
+!c      enddo
+!c      enddo
+!c Calcul des flux
+
+      do ig=1,ngrid
+         do l=1,lmax(ig)
+!c         do l=1,klev
+!c             fmc(ig,l+1)=f(ig)*f_star(ig,l+1)
+            fmc(ig,l+1)=fmc(ig,l)+alim(ig,l)+entr(ig,l)-detr(ig,l)
+!c        print*,'??!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig),
+!c     s  'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l),
+!c     s  'f+1=',fmc(ig,l+1)
+          if (fmc(ig,l+1).lt.0.) then
+               print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1)
+               fmc(ig,l+1)=fmc(ig,l)
+               detr(ig,l)=alim(ig,l)+entr(ig,l)
+!c               fmc(ig,l+1)=0.
+!c               print*,'fmc1<0',l+1,lmax(ig),fmc(ig,l+1)
+            endif
+!c       if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then
+!c          f_old=fmc(ig,l+1)
+!c          fmc(ig,l+1)=fmc(ig,l)
+!c          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
+!c       endif
+       
+!c        if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then
+!c          f_old=fmc(ig,l+1)
+!c          fmc(ig,l+1)=fmc(ig,l)
+!c          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l)
+!c       endif
+!crajout du test sur alpha croissant
+!cif test
+!c       if (1.eq.0) then
+
+       if (l.eq.klev) then
+          print*,'THERMCELL PB ig=',ig,'   l=',l
+          abort_message = 'THERMCELL PB'
+          CALL abort_gcm (modname,abort_message,1)
+       endif
+!       if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and.
+!     s     (l.ge.lentr(ig)).and.
+       if ((zw2(ig,l+1).gt.1.e-10).and.(zw2(ig,l).gt.1.e-10).and.                    &
+       &         (l.ge.lentr(ig)) ) then
+          if ( ((fmc(ig,l+1)/(rhobarz(ig,l+1)*zw2(ig,l+1))).gt.                      &
+       &     (fmc(ig,l)/(rhobarz(ig,l)*zw2(ig,l))))) then
+           f_old=fmc(ig,l+1)
+           fmc(ig,l+1)=fmc(ig,l)*rhobarz(ig,l+1)*zw2(ig,l+1)                         &
+       &                          /(rhobarz(ig,l)*zw2(ig,l))
+           detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1) 
+!c           detr(ig,l)=(fmc(ig,l+1)-fmc(ig,l))/(0.4-1.)
+!c           entr(ig,l)=0.4*detr(ig,l)
+!c           entr(ig,l)=fmc(ig,l+1)-fmc(ig,l)+detr(ig,l)
+        endif
+        endif
+        if ((fmc(ig,l+1).gt.fmc(ig,l)).and.(l.gt.lentr(ig))) then
+          f_old=fmc(ig,l+1)
+          fmc(ig,l+1)=fmc(ig,l)
+          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
+       endif
+       if (detr(ig,l).gt.fmc(ig,l)) then
+               detr(ig,l)=fmc(ig,l)
+               entr(ig,l)=fmc(ig,l+1)-alim(ig,l)
+        endif
+       if (fmc(ig,l+1).lt.0.) then
+               detr(ig,l)=detr(ig,l)+fmc(ig,l+1)
+               fmc(ig,l+1)=0.
+               print*,'fmc2<0',l+1,lmax(ig)
+            endif
+            
+!ctest pour ne pas avoir f=0 et d=e/=0
+!c       if (fmc(ig,l+1).lt.1.e-10) then
+!c          detr(ig,l+1)=0.
+!c          entr(ig,l+1)=0.
+!c          zqla(ig,l+1)=0.
+!c          zw2(ig,l+1)=0.
+!c          lmax(ig)=l+1
+!c          zmax(ig)=zlev(ig,lmax(ig))
+!c       endif 
+        if (zw2(ig,l+1).gt.1.e-10) then
+       if ((((fmc(ig,l+1))/(rhobarz(ig,l+1)*zw2(ig,l+1))).gt.                        &
+       &      1.)) then
+          f_old=fmc(ig,l+1)
+          fmc(ig,l+1)=rhobarz(ig,l+1)*zw2(ig,l+1)
+          zw2(ig,l+1)=0.
+          zqla(ig,l+1)=0.
+          detr(ig,l)=detr(ig,l)+f_old-fmc(ig,l+1)
+         lmax(ig)=l+1
+          zmax(ig)=zlev(ig,lmax(ig))
+          print*,'alpha>1',l+1,lmax(ig)
+       endif
+        endif
+!c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+!cendif test
+!c      endif
+      enddo
+      enddo
+      do ig=1,ngrid
+!c         if (fmc(ig,lmax(ig)+1).ne.0.) then
+         fmc(ig,lmax(ig)+1)=0.
+         entr(ig,lmax(ig))=0.
+         detr(ig,lmax(ig))=fmc(ig,lmax(ig))+entr(ig,lmax(ig))                        &
+       &                     +alim(ig,lmax(ig))
+!c         endif
+      enddo
+!ctest sur le signe de fmc
+       do ig=1,ngrid
+         do l=1,klev+1
+            if (fmc(ig,l).lt.0.) then
+         print*,'fm1<0!!!','ig=',ig,'l=',l,'a=',alim(ig,l-1),'e='                    &
+       & ,entr(ig,l-1),'f=',fmc(ig,l-1),'d=',detr(ig,l-1),'f+1=',fmc(ig,l)
+            endif
+         enddo
+       enddo
+!ctest de verification
+      do ig=1,ngrid
+       do l=1,lmax(ig)
+       if ((abs(fmc(ig,l+1)-fmc(ig,l)-alim(ig,l)-entr(ig,l)+detr(ig,l)))             &
+       &           .gt.1.e-4) then
+!c      print*,'pbcm!!','ig=',ig,'l=',l,'lmax=',lmax(ig),'lmix=',lmix(ig),
+!c     s  'e=',entr(ig,l),'d=',detr(ig,l),'a=',alim(ig,l),'f=',fmc(ig,l),
+!c     s  'f+1=',fmc(ig,l+1)
+       endif
+       if (detr(ig,l).lt.0.) then
+          print*,'detrdemi<0!!!'
+       endif
+         enddo
+      enddo
+!c
+!cRC
+!cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+!c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                             &
+       &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))                         &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)              &
+       &        then
+!c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                          &
+       &        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)                   &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))                  &
+       &        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                          &
+       &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))                         &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+              else
+              zmix(ig)=zlev(ig,lmix(ig))
+              print*,'pb zmix'
+              endif
+          else 
+              zmix(ig)=0.
+          endif
+!ctest
+         if ((zmax(ig)-zmix(ig)).le.0.) then
+            zmix(ig)=0.9*zmax(ig)
+!c            print*,'pb zmix>zmax'
+         endif
+      enddo
+      do ig=1,klon
+         zmix0(ig)=zmix(ig)
+      enddo
+!c
+!c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.                                          &
+       &          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+!c
+!cne devrait pas arriver!!!!!
+      do ig=1,ngrid
+       do l=1,klev
+          if (detr(ig,l).gt.(fmc(ig,l)+alim(ig,l))+entr(ig,l)) then
+             print*,'detr2>fmc2!!!','ig=',ig,'l=',l,'d=',detr(ig,l),                 &
+       &             'f=',fmc(ig,l),'lmax=',lmax(ig)
+!c             detr(ig,l)=fmc(ig,l)+alim(ig,l)+entr(ig,l)
+!c             entr(ig,l)=0.
+!c             fmc(ig,l+1)=0.
+!c             zw2(ig,l+1)=0.     
+!c             zqla(ig,l+1)=0.
+           print*,'pb!fm=0 et f_star>0',l,lmax(ig)        
+!c             lmax(ig)=l
+          endif
+       enddo
+      enddo
+      do ig=1,ngrid
+         do l=lmax(ig)+1,klev+1
+!c            fmc(ig,l)=0.
+!c            detr(ig,l)=0.
+!c            entr(ig,l)=0.
+!c            zw2(ig,l)=0.
+!c            zqla(ig,l)=0.
+         enddo
+      enddo
+
+!cCalcul du detrainement lors du premier passage
+!c     print*,'9 OK convect8'
+!c     print*,'WA1 ',wa_moy
+
+!c   determination de l'indice du debut de la mixed layer ou w decroit
+
+!c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+!c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+!c   d'une couche est égale à la hauteur de la couche alimentante.
+!c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+!c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig).and.(test(ig).eq.1)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect                                     &
+       &         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig).and.(test(ig).eq.1)) then
+!c              if (idetr.eq.0) then
+!c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+                   print*,'pb l_mix*zlev<0'
+                  endif
+!cCR: test: nouvelle def de lambda
+!c                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  if (zw2(ig,l).gt.1.e-10) then
+                  larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
+                  else
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  endif
+!c              else if (idetr.eq.1) then
+!c                 larg_detr(ig,l)=larg_cons(ig,l)
+!c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+!c              else if (idetr.eq.2) then
+!c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c    s            *sqrt(wa_moy(ig,l))
+!c              else if (idetr.eq.4) then
+!c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c    s            *wa_moy(ig,l)
+!c              endif
+         endif
+         enddo
+       enddo
+
+!c     print*,'10 OK convect8'
+!c     print*,'WA2 ',wa_moy
+!c   cal1cul de la fraction de la maille concernée par l'ascendance en tenant
+!c   compte de l'epluchage du thermique.
+!c
+!c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1..and.(test(ig).eq.1)) then
+!c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))                         &
+       &            /(r_aspect*zmax(ig))
+!c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+!c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+!cCR: calcul de fracazmix
+       do ig=1,ngrid
+          if (test(ig).eq.1) then
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/                   &
+       &     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)                        &
+       &    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)              &
+       &    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+          endif
+       enddo
+!c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1..and.(test(ig).eq.1)) then
+               if (l.gt.lmix(ig)) then
+!ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+!c                   print*,'pb xxx'
+                    xxx(ig,l)=(lmax(ig)+1.-l)/(lmax(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+!c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+
+      print*,'fin calcul fraca'
+!c     print*,'11 OK convect8'
+!c     print*,'Ea3 ',wa_moy
+!c------------------------------------------------------------------
+!c   Calcul de fracd, wd
+!c   somme wa - wd = 0
+!c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              if (test(ig).eq.1) then
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+!cCR:test
+              if (alim(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)                   &
+       &            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+!c                 write(1,*)'ajustement fm, l',l
+              endif
+!c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+!cRC
+              endif
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1.and.(test(ig).eq.1)) then
+              abort_message = 'fracd trop petit'
+              CALL abort_gcm (modname,abort_message,1)
+            else
+!c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay+1
+         do ig=1,ngrid
+            if (test(ig).eq.0) then
+              fm(ig,l)=fmc(ig,l)
+            endif
+         enddo
+      enddo 
+   
+!cfin du first
+      do l=1,nlay
+         do ig=1,ngrid
+!c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+      print*,'12 OK convect8'
+!c     print*,'WA4 ',wa_moy
+!cc------------------------------------------------------------------
+!c   calcul du transport vertical
+!c------------------------------------------------------------------
+
+      go to 4444
+!c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)                                   &
+       &      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+      print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='                                   &
+       &         ,fm(ig,l+1)*ptimestep                                               &
+       &         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if((alim(ig,l)+entr(ig,l))*ptimestep.gt.masse(ig,l)) then
+      print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='                                    &
+       &         ,(entr(ig,l)+alim(ig,l))*ptimestep                                  &
+       &         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+!c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+!c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10                                            &
+       &         .or..not.masse(ig,l).le.1.e4) then
+!c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+!c    s         ,'   M=',masse(ig,l)
+!c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+!c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+!c     print*,'zlev(ig,l+1),zlev(ig,l)'
+!c    s                ,zlev(ig,l+1),zlev(ig,l)
+!c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+!c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.alim(ig,l).ge.0..or..not.alim(ig,l).le.10.) then
+!c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+!c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+!cCR:redefinition du entr
+!cCR:test:on ne change pas la def du entr mais la def du fm
+       do l=1,nlay
+         do ig=1,ngrid
+            if (test(ig).eq.1) then
+            detr(ig,l)=fm(ig,l)+alim(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+!c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                fm(ig,l+1)=fm(ig,l)+alim(ig,l)
+                detr(ig,l)=0.
+!c                write(11,*)'l,ig,entr',l,ig,entr(ig,l)
+!c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+            endif
+         enddo
+      enddo
+!cRC
+
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/tho
+         entr0=entr0+ptimestep*(alim+entr-entr0)/tho
+      else
+         fm0=fm
+         entr0=alim+entr
+         detr0=detr
+         alim0=alim
+!c         zoa=zqta
+!c         entr0=alim
+      endif
+
+      if (1.eq.1) then
+!c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+!c     .    ,zh,zdhadj,zha)
+!c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+!c     .    ,zo,pdoadj,zoa)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse,                      &
+       &                    zthl,zdthladj,zta)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse,                      &
+       &                   po,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca                &
+       &    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca                &
+       &    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse                      &
+       &    ,fraca,zmax                                                              &
+       &    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zv,pdvadj,zva)
+      endif
+
+!cCalcul des moments
+!c      do l=1,nlay
+!c         do ig=1,ngrid
+!c            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+!c            zf2=zf/(1.-zf)
+!c            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+!c            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+!c         enddo
+!c      enddo
+
+
+
+
+
+
+!c     print*,'13 OK convect8'
+!c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+!c            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+           pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l)  
+         enddo
+      enddo
+
+
+!c     do l=1,nlay
+!c        do ig=1,ngrid
+!c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+!c     print*,'WARN!!! ig=',ig,'  l=',l
+!c    s         ,'   pdtadj=',pdtadj(ig,l)
+!c           endif
+!c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+!c     print*,'WARN!!! ig=',ig,'  l=',l
+!c    s         ,'   pdoadj=',pdoadj(ig,l)
+!c           endif
+!c        enddo
+!c      enddo
+
+      print*,'14 OK convect8'
+!c------------------------------------------------------------------
+!c   Calculs pour les sorties
+!c------------------------------------------------------------------
+!ccalcul de fraca pour les sorties
+      do l=2,klev
+         do ig=1,klon
+            if (zw2(ig,l).gt.1.e-10) then
+            fraca(ig,l)=fm(ig,l)/(rhobarz(ig,l)*zw2(ig,l))
+            else
+            fraca(ig,l)=0.
+            endif
+         enddo
+      enddo
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)                                             &
+       &      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+!c CR calcul du niveau de condensation
+!c initialisation
+      do ig=1,ngrid
+         nivcon(ig)=0.
+         zcon(ig)=0.
+      enddo 
+      do k=nlay,1,-1
+         do ig=1,ngrid
+            if (zqla(ig,k).gt.1e-10) then
+               nivcon(ig)=k
+               zcon(ig)=zlev(ig,k)
+            endif
+!c            if (zcon(ig).gt.1.e-10) then
+!c               nuage=.true.
+!c            else 
+!c               nuage=.false.
+!c            endif
+         enddo
+      enddo
+      
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=fraca(ig,l)
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l)/zpspsk(ig,l))**2
+            wth2(ig,l)=zf2*(zw2(ig,l))**2
+!c           print*,'wth2=',wth2(ig,l)
+            wth3(ig,l)=zf2*(1-2.*fraca(ig,l))/(1-fraca(ig,l))                        &
+       &                *zw2(ig,l)*zw2(ig,l)*zw2(ig,l)
+            q2(ig,l)=zf2*(zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+!ctest: on calcul q2/po=ratqsc
+!c            if (nuage) then
+            ratqscth(ig,l)=sqrt(q2(ig,l))/(po(ig,l)*1000.)
+!c            else
+!c            ratqscth(ig,l)=0.
+!c            endif
+         enddo
+      enddo
+!ccalcul du ratqscdiff
+      sum=0.
+      sumdiff=0.
+      ratqsdiff(:,:)=0.
+      do ig=1,ngrid
+         do l=1,lentr(ig)
+            sum=sum+alim_star(ig,l)*zqta(ig,l)*1000.
+         enddo
+      enddo
+      do ig=1,ngrid
+          do l=1,lentr(ig)
+          zf=fraca(ig,l)
+          zf2=zf/(1.-zf)
+       sumdiff=sumdiff+alim_star(ig,l)                                               &
+       &           *(zqta(ig,l)*1000.-sum)**2
+!c      ratqsdiff=ratqsdiff+alim_star(ig,l)*
+!c     s          (zqta(ig,l)*1000.-po(ig,l)*1000.)**2
+          enddo
+      enddo
+      do l=1,klev
+      do ig=1,ngrid
+      ratqsdiff(ig,l)=sqrt(sumdiff)/(po(ig,l)*1000.)   
+!c      write(11,*)'ratqsdiff=',ratqsdiff(ig,l)
+      enddo
+      enddo     
+!cdeja fait
+!c      do l=1,nlay
+!c         do ig=1,ngrid
+!c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+!c            if (detr(ig,l).lt.0.) then
+!c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+!c                detr(ig,l)=0.
+!c     print*,'WARNING !!! detrainement negatif ',ig,l
+!c            endif
+!c         enddo
+!c      enddo
+
+!c     print*,'15 OK convect8'
+
+      isplit=isplit+1       
+
+
+!c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+!c   recalcul des flux en diagnostique...
+!c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+!c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+!c      print*,'16 OK convect8'
+!c         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+!c         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+!c         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+!c         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+!c      print*,'WA6 ',wa_moy
+!c         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+!c         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,w_est,'w_est      ','w_est      ')
+!con sort les moments
+         call wrgradsfi(1,nlay,thetath2,'zh2       ','zh2       ')
+         call wrgradsfi(1,nlay,wth2,'w2       ','w2       ')
+         call wrgradsfi(1,nlay,wth3,'w3       ','w3       ')
+         call wrgradsfi(1,nlay,q2,'q2       ','q2       ')
+         call wrgradsfi(1,nlay,dtheta,'dT       ','dT       ')
+!c
+         call wrgradsfi(1,nlay,zw_sec,'zw_sec       ','zw_sec       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+         call wrgradsfi(1,nlay,nu,'nu       ','nu       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,zoa,'zoa        ','zoa        ')
+!c         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+!c         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+!cAM:nouveaux diagnostiques
+         call wrgradsfi(1,nlay,zthl,'zthl        ','zthl        ')
+         call wrgradsfi(1,nlay,zta,'zta        ','zta        ')
+         call wrgradsfi(1,nlay,zl,'zl        ','zl        ')
+         call wrgradsfi(1,nlay,zdthladj,'zdthladj    ',                              &
+       &        'zdthladj    ')
+         call wrgradsfi(1,nlay,ztla,'ztla      ','ztla      ')
+         call wrgradsfi(1,nlay,zqta,'zqta      ','zqta      ')
+         call wrgradsfi(1,nlay,zqla,'zqla      ','zqla      ')
+         call wrgradsfi(1,nlay,deltaz,'deltaz      ','deltaz      ')
+!cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')
+      call wrgradsfi(1,nlay,detr_star  ,'detr_star   ','detr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,nlay,zqsat    ,'zqsat   ','zqsat   ')
+      call wrgradsfi(1,nlay,zqsatth    ,'qsath   ','qsath   ')
+      call wrgradsfi(1,nlay,alim_star    ,'alim_star   ','alim_star   ')
+      call wrgradsfi(1,nlay,alim    ,'alim   ','alim   ')
+      call wrgradsfi(1,1,f,'f      ','f      ')
+      call wrgradsfi(1,1,alim_star_tot,'a_s_t      ','a_s_t      ')
+      call wrgradsfi(1,1,alim_star2,'a_2      ','a_2      ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmax_sec,'z_sec      ','z_sec      ')
+!c      call wrgradsfi(1,1,zmax_sec2,'zz_se      ','zz_se      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      call wrgradsfi(1,1,nivcon,'nivcon      ','nivcon      ')
+      call wrgradsfi(1,1,zcon,'zcon      ','zcon      ')
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      call wrgradsfi(1,1,wmax_sec,'w_sec      ','w_sec      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+!c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+           str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+!c     print*,'18 OK convect8'
+!c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+!c     if(wa_moy(1,4).gt.1.e-10) stop
+
+      print*,'19 OK convect8'
+      return
+      end SUBROUTINE thermcell_cld
+
+      SUBROUTINE thermcell_eau(ngrid,nlay,ptimestep                                  &
+       &                  ,pplay,pplev,pphi                                          &
+       &                  ,pu,pv,pt,po                                               &
+       &                  ,pduadj,pdvadj,pdtadj,pdoadj                               &
+       &                  ,fm0,entr0                                                 &
+!c    s                  ,pu_therm,pv_therm                                          &
+       &                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+!c=======================================================================
+!c
+!c   Calcul du transport verticale dans la couche limite en presence
+!c   de "thermiques" explicitement representes
+!c
+!c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+!c
+!c   le thermique est supposé homogène et dissipé par mélange avec
+!c   son environnement. la longueur l_mix contrôle l'efficacité du
+!c   mélange
+!c
+!c   Le calcul du transport des différentes espèces se fait en prenant
+!c   en compte:
+!c     1. un flux de masse montant
+!c     2. un flux de masse descendant
+!c     3. un entrainement
+!c     4. un detrainement
+!c
+!c=======================================================================
+
+!c-----------------------------------------------------------------------
+!c   declarations:
+!c   -------------
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+!c   arguments:
+!c   ----------
+
+      INTEGER ngrid,nlay,w2di
+      REAL tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+!$OMP THREADPRIVATE(idetr)
+
+!c   local:
+!c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+!c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+!c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      real zthl(klon,klev),zdthladj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      real zl(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zta(klon,klev)
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+!$OMP THREADPRIVATE(isplit)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+!c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef(klon),qsatbef(klon)
+      real dqsat_dT,DT,num,denom
+      REAL REPS,RLvCp,DDT0
+      real ztla(klon,klev),zqla(klon,klev),zqta(klon,klev)
+ 
+      PARAMETER (DDT0=.01)
+
+!cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical first
+      data first /.false./
+      save first
+!$OMP THREADPRIVATE(first)
+
+!cRC
+
+      character*2 str2
+      character*10 str10
+
+      character (len=20) :: modname='thermcell_eau'
+      character (len=80) :: abort_message
+
+      LOGICAL vtest(klon),down
+      LOGICAL Zsat(klon)
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+!$OMP THREADPRIVATE(ncorrec)
+
+!c
+
+!c-----------------------------------------------------------------------
+!c   initialisation:
+!c   ---------------
+!c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+!c
+!c Initialisation
+      RLvCp = RLVTT/RCPD
+      REPS  = RD/RV
+!c
+!c-----------------------------------------------------------------------
+!cAM Calcul de T,q,ql a partir de Tl et qT
+!c   ---------------------------------------------------
+!c
+!c Pr Tprec=Tl calcul de qsat 
+!c Si qsat>qT T=Tl, q=qT
+!c Sinon DDT=(-Tprec+Tl+RLVCP (qT-qsat(T')) / (1+RLVCP dqsat/dt) 
+!c On cherche DDT < DDT0
+!c
+!c defaut
+       DO  ll=1,nlay
+         DO ig=1,ngrid
+            zo(ig,ll)=po(ig,ll)
+            zl(ig,ll)=0.
+            zh(ig,ll)=pt(ig,ll)
+         EndDO
+       EndDO
+       do ig=1,ngrid
+          Zsat(ig)=.false.
+       enddo
+!c
+!c
+       DO ll=1,nlay
+!c les points insatures sont definitifs
+         DO ig=1,ngrid
+            Tbef(ig)=pt(ig,ll)
+            zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+            qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+            qsatbef(ig)=MIN(0.5,qsatbef(ig))
+            zcor=1./(1.-retv*qsatbef(ig))
+            qsatbef(ig)=qsatbef(ig)*zcor
+            Zsat(ig) = (max(0.,po(ig,ll)-qsatbef(ig)) .gt. 0.00001)
+         EndDO
+
+         DO ig=1,ngrid
+           if (Zsat(ig)) then
+            qlbef=max(0.,po(ig,ll)-qsatbef(ig))
+!c si sature: ql est surestime, d'ou la sous-relax
+            DT = 0.5*RLvCp*qlbef
+!c on pourra enchainer 2 ou 3 calculs sans Do while
+            do while (DT.gt.DDT0)
+!c il faut verifier si c,a conserve quand on repasse en insature ...
+              Tbef(ig)=Tbef(ig)+DT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,ll)
+              qsatbef(ig)=MIN(0.5,qsatbef(ig))
+              zcor=1./(1.-retv*qsatbef(ig))
+              qsatbef(ig)=qsatbef(ig)*zcor
+!c on veut le signe de qlbef
+              qlbef=po(ig,ll)-qsatbef(ig)
+!c          dqsat_dT
+              zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+              zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+              zcor=1./(1.-retv*qsatbef(ig))
+              dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+              num=-Tbef(ig)+pt(ig,ll)+RLvCp*qlbef
+              denom=1.+RLvCp*dqsat_dT
+              DT=num/denom
+            enddo
+!c on ecrit de maniere conservative (sat ou non)
+            zl(ig,ll) = max(0.,qlbef)
+!c          T = Tl +Lv/Cp ql
+            zh(ig,ll) = pt(ig,ll)+RLvCp*zl(ig,ll)
+            zo(ig,ll) = po(ig,ll)-zl(ig,ll)
+           endif
+         EndDO
+       EndDO
+!cAM fin
+!c
+!c-----------------------------------------------------------------------
+!c   incrementation eventuelle de tendances precedentes:
+!c   ---------------------------------------------------
+
+      print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+!c            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+!c            zo(ig,l)=po(ig,l)
+!c            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+!cAM attention zh est maintenant le profil de T et plus le profil de theta !
+!c
+!c   T-> Theta
+            ztv(ig,l)=zh(ig,l)/zpspsk(ig,l)
+!cAM Theta_v
+            ztv(ig,l)=ztv(ig,l)*(1.+RETV*(zo(ig,l))                                  &
+       &           -zl(ig,l))
+!cAM Thetal
+            zthl(ig,l)=pt(ig,l)/zpspsk(ig,l)
+!c            
+1015     CONTINUE
+1010  CONTINUE
+
+!c     print*,'1 OK convect8'
+!c                       --------------------
+!c
+!c
+!c                       + + + + + + + + + + +
+!c
+!c
+!c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+!c  wh,wt,wo ...
+!c
+!c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+!c
+!c
+!c                       --------------------   zlev(1)
+!c                       \\\\\\\\\\\\\\\\\\\\
+!c
+!c
+
+!c-----------------------------------------------------------------------
+!c   Calcul des altitudes des couches
+!c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+!c     print*,'2 OK convect8'
+!c-----------------------------------------------------------------------
+!c   Calcul des densites
+!c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+!c            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+             rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*ztv(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+!c     print*,'3 OK convect8'
+!c------------------------------------------------------------------
+!c   Calcul de w2, quarre de w a partir de la cape
+!c   a partir de w2, on calcule wa, vitesse de l'ascendance
+!c
+!c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+!c   w2 est stoke dans wa
+!c
+!c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+!c   independants par couches que pour calculer l'entrainement
+!c   a la base et la hauteur max de l'ascendance.
+!c
+!c   Indicages:
+!c   l'ascendance provenant du niveau k traverse l'interface l avec
+!c   une vitesse wa(k,l).
+!c
+!c                       --------------------
+!c
+!c                       + + + + + + + + + + 
+!c
+!c  wa(k,l)   ----       --------------------    l
+!c             /\
+!c            /||\       + + + + + + + + + + 
+!c             ||
+!c             ||        --------------------
+!c             ||
+!c             ||        + + + + + + + + + + 
+!c             ||
+!c             ||        --------------------
+!c             ||__
+!c             |___      + + + + + + + + + +     k
+!c
+!c                       --------------------
+!c
+!c
+!c
+!c------------------------------------------------------------------
+
+!cCR: ponderation entrainement des couches instables
+!cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+!c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+!con ne considere que les premieres couches instables
+      do k=nlay-1,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.                                        &
+       &          ztv(ig,k+1).lt.ztv(ig,k+2)) then
+               lentr(ig)=k
+            endif
+          enddo
+      enddo
+    
+!c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+!c
+!c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.                                        &
+       &          l.ge.lmin(ig).and.l.le.lentr(ig)) then 
+                 entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))*                            &
+       &                          (zlev(ig,l+1)-zlev(ig,l))
+            endif
+         enddo
+      enddo
+!c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+!c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+!c
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+!cRC
+!cAM:initialisations
+      do k=1,nlay
+         do ig=1,ngrid
+            ztva(ig,k)=ztv(ig,k)
+            ztla(ig,k)=zthl(ig,k)
+            zqla(ig,k)=0.
+            zqta(ig,k)=po(ig,k)
+            Zsat(ig) =.false.
+         enddo
+      enddo
+!c
+!c     print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+!cCR
+            f_star(ig,k)=0.
+!cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+!c     print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+!cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)                                             &
+       &         .and.entr_star(ig,l).gt.1.e-10                                      &
+       &         .and.zw2(ig,l).lt.1e-10) then
+!cAM
+               ztla(ig,l)=zthl(ig,l)
+               zqta(ig,l)=po(ig,l)
+               zqla(ig,l)=zl(ig,l)
+!cAM
+               f_star(ig,l+1)=entr_star(ig,l)
+!ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)                 &
+       &                     *(zlev(ig,l+1)-zlev(ig,l))                              &
+       &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.                                       &
+       &               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+!c
+!cAM on melange Tl et qt du thermique
+               ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+entr_star(ig,l)                 &
+       &                    *zthl(ig,l))/f_star(ig,l+1)
+               zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+entr_star(ig,l)                 &
+       &                    *po(ig,l))/f_star(ig,l+1)
+!c
+!c               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)
+!c     s                    *ztv(ig,l))/f_star(ig,l+1)
+!c
+!cAM on en deduit thetav et ql du thermique
+               Tbef(ig)=ztla(ig,l)*zpspsk(ig,l)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+               qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)
+               qsatbef(ig)=MIN(0.5,qsatbef(ig))
+               zcor=1./(1.-retv*qsatbef(ig))
+               qsatbef(ig)=qsatbef(ig)*zcor
+               Zsat(ig) = (max(0.,zqta(ig,l)-qsatbef(ig)) .gt. 0.00001)
+            endif
+         enddo
+         DO ig=1,ngrid
+           if (Zsat(ig)) then
+              qlbef=max(0.,zqta(ig,l)-qsatbef(ig))
+              DT = 0.5*RLvCp*qlbef
+              do while (DT.gt.DDT0)
+                 Tbef(ig)=Tbef(ig)+DT
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 qsatbef(ig)= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig,l)
+                 qsatbef(ig)=MIN(0.5,qsatbef(ig))
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 qsatbef(ig)=qsatbef(ig)*zcor
+                 qlbef=zqta(ig,l)-qsatbef(ig)
+
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef(ig))
+                 dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef(ig),zcor)
+                 num=-Tbef(ig)+ztla(ig,l)*zpspsk(ig,l)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 DT=num/denom
+              enddo
+              zqla(ig,l) = max(0.,zqta(ig,l)-qsatbef(ig))
+           endif
+!c on ecrit de maniere conservative (sat ou non)
+!c          T = Tl +Lv/Cp ql
+           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)                              &
+       &              -zqla(ig,l))-zqla(ig,l))
+
+        enddo
+        DO ig=1,ngrid
+           if (zw2(ig,l).ge.1.e-10.and.                                              &
+       &               f_star(ig,l)+entr_star(ig,l).gt.1.e-10) then
+!c  mise a jour de la vitesse ascendante (l'air entraine de la couche
+!c  consideree commence avec une vitesse nulle).
+!c
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+               &
+       &                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)                  &
+       &                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+!c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))                                 &
+       &           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+!c
+!c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+!c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+            lmin(ig)=1
+         endif
+      enddo 
+!c    
+!c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=500.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+!c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*                     &
+       &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)               &
+       &    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+!c Fermeture,determination de f
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2                     &
+       &                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+!c Nouvelle fermeture
+             f(ig)=wmax(ig)/(zmax(ig)*r_aspect*entr_star2(ig))                       &
+       &             *entr_star_tot(ig)
+!ctest
+             if (first) then
+             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)                      &
+       &             *wmax(ig))
+             endif
+         endif
+         f0(ig)=f(ig)
+         first=.true.
+      enddo
+
+!c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+!c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+!cRC
+
+
+!c     print*,'9 OK convect8'
+!c     print*,'WA1 ',wa_moy
+
+!c   determination de l'indice du debut de la mixed layer ou w decroit
+
+!c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+!c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+!c   d'une couche est égale à la hauteur de la couche alimentante.
+!c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+!c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect                                     &
+       &         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+!c              if (idetr.eq.0) then
+!c  cette option est finalement en dur.
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c              else if (idetr.eq.1) then
+!c                 larg_detr(ig,l)=larg_cons(ig,l)
+!c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+!c              else if (idetr.eq.2) then
+!c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c    s            *sqrt(wa_moy(ig,l))
+!c              else if (idetr.eq.4) then
+!c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c    s            *wa_moy(ig,l)
+!c              endif
+            endif
+         enddo
+       enddo
+
+!c     print*,'10 OK convect8'
+!c     print*,'WA2 ',wa_moy
+!c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+!c   compte de l'epluchage du thermique.
+!c
+!cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                          &
+       &        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)                   &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))                  &
+       &        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                          &
+       &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))                         &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+         else 
+         zmix(ig)=0.
+         endif
+      enddo
+!c
+!c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.                                          &
+       &          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+!c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+!c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))                         &
+       &            /(r_aspect*zmax(ig))
+!c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+!c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+!cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/                   &
+       &     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)                        &
+       &    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)              &
+       &    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+!c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+!c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+
+!c     print*,'11 OK convect8'
+!c     print*,'Ea3 ',wa_moy
+!c------------------------------------------------------------------
+!c   Calcul de fracd, wd
+!c   somme wa - wd = 0
+!c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+!cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)                   &
+       &            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+!c                 write(1,*)'ajustement fm, l',l
+              endif
+!c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+!cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+              abort_message = 'fracd trop petit'
+              CALL abort_gcm (modname,abort_message,1)
+            else
+!c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+!c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+!c     print*,'12 OK convect8'
+!c     print*,'WA4 ',wa_moy
+!cc------------------------------------------------------------------
+!c   calcul du transport vertical
+!c------------------------------------------------------------------
+
+      go to 4444
+!c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)                                   &
+       &      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+!c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+!c    s         ,fm(ig,l+1)*ptimestep
+!c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+!c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+!c    s         ,entr(ig,l)*ptimestep
+!c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+!c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+!c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10                                            &
+       &         .or..not.masse(ig,l).le.1.e4) then
+!c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+!c    s         ,'   M=',masse(ig,l)
+!c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+!c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+!c     print*,'zlev(ig,l+1),zlev(ig,l)'
+!c    s                ,zlev(ig,l+1),zlev(ig,l)
+!c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+!c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+!c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+!c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/tho
+         entr0=entr0+ptimestep*(entr-entr0)/tho
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+!c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+!c     .    ,zh,zdhadj,zha)
+!c         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse
+!c     .    ,zo,pdoadj,zoa)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zthl,zdthladj,zta)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,po,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca                &
+       &    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca                &
+       &    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse                      &
+       &    ,fraca,zmax                                                              &
+       &    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+!c     print*,'13 OK convect8'
+!c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+!c            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+           pdtadj(ig,l)=zdthladj(ig,l)*zpspsk(ig,l)  
+         enddo
+      enddo
+
+
+!c     do l=1,nlay
+!c        do ig=1,ngrid
+!c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+!c     print*,'WARN!!! ig=',ig,'  l=',l
+!c    s         ,'   pdtadj=',pdtadj(ig,l)
+!c           endif
+!c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+!c     print*,'WARN!!! ig=',ig,'  l=',l
+!c    s         ,'   pdoadj=',pdoadj(ig,l)
+!c           endif
+!c        enddo
+!c      enddo
+
+!c     print*,'14 OK convect8'
+!c------------------------------------------------------------------
+!c   Calculs pour les sorties
+!c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)                                             &
+       &      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+!c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+
+!c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+!c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+!c   recalcul des flux en diagnostique...
+!c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+!c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+!c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+!c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+!cAM:nouveaux diagnostiques
+         call wrgradsfi(1,nlay,zthl,'zthl        ','zthl        ')
+         call wrgradsfi(1,nlay,zta,'zta        ','zta        ')
+         call wrgradsfi(1,nlay,zl,'zl        ','zl        ')
+         call wrgradsfi(1,nlay,zdthladj,'zdthladj    ',                              &
+       &        'zdthladj    ')
+         call wrgradsfi(1,nlay,ztla,'ztla      ','ztla      ')
+         call wrgradsfi(1,nlay,zqta,'zqta      ','zqta      ')
+         call wrgradsfi(1,nlay,zqla,'zqla      ','zqla      ')
+!cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+!c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+!c     print*,'18 OK convect8'
+!c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+!c     if(wa_moy(1,4).gt.1.e-10) stop
+
+!c     print*,'19 OK convect8'
+      return
+      end SUBROUTINE thermcell_eau
+
+      SUBROUTINE thermcell(ngrid,nlay,ptimestep                                      &
+       &                  ,pplay,pplev,pphi                                          &
+       &                  ,pu,pv,pt,po                                               &
+       &                  ,pduadj,pdvadj,pdtadj,pdoadj                               &
+       &                  ,fm0,entr0                                                 &
+!c    s                  ,pu_therm,pv_therm                                          &
+       &                  ,r_aspect,l_mix,w2di,tho)
+
+      USE dimphy
+      IMPLICIT NONE
+
+!c=======================================================================
+!c
+!c   Calcul du transport verticale dans la couche limite en presence
+!c   de "thermiques" explicitement representes
+!c
+!c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+!c
+!c   le thermique est supposé homogène et dissipé par mélange avec
+!c   son environnement. la longueur l_mix contrôle l'efficacité du
+!c   mélange
+!c
+!c   Le calcul du transport des différentes espèces se fait en prenant
+!c   en compte:
+!c     1. un flux de masse montant
+!c     2. un flux de masse descendant
+!c     3. un entrainement
+!c     4. un detrainement
+!c
+!c=======================================================================
+
+!c-----------------------------------------------------------------------
+!c   declarations:
+!c   -------------
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+!c   arguments:
+!c   ----------
+
+      INTEGER ngrid,nlay,w2di
+      REAL tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+!$OMP THREADPRIVATE(idetr)
+
+!c   local:
+!c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+!c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+!c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+!$OMP THREADPRIVATE(isplit)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+!c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+!cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical first
+      data first /.false./
+      save first
+!$OMP THREADPRIVATE(first)
+!cRC
+
+      character*2 str2
+      character*10 str10
+
+      character (len=20) :: modname='thermcell'
+      character (len=80) :: abort_message
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+!$OMP THREADPRIVATE(ncorrec)
+      
+!c
+!c-----------------------------------------------------------------------
+!c   initialisation:
+!c   ---------------
+!c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+!c
+!c-----------------------------------------------------------------------
+!c   incrementation eventuelle de tendances precedentes:
+!c   ---------------------------------------------------
+
+       print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+       print*,'1 OK convect8'
+!c                       --------------------
+!c
+!c
+!c                       + + + + + + + + + + +
+!c
+!c
+!c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+!c  wh,wt,wo ...
+!c
+!c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+!c
+!c
+!c                       --------------------   zlev(1)
+!c                       \\\\\\\\\\\\\\\\\\\\
+!c
+!c
+
+!c-----------------------------------------------------------------------
+!c   Calcul des altitudes des couches
+!c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+!c      print*,'2 OK convect8'
+!c-----------------------------------------------------------------------
+!c   Calcul des densites
+!c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+!c      print*,'3 OK convect8'
+!c------------------------------------------------------------------
+!c   Calcul de w2, quarre de w a partir de la cape
+!c   a partir de w2, on calcule wa, vitesse de l'ascendance
+!c
+!c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+!c   w2 est stoke dans wa
+!c
+!c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+!c   independants par couches que pour calculer l'entrainement
+!c   a la base et la hauteur max de l'ascendance.
+!c
+!c   Indicages:
+!c   l'ascendance provenant du niveau k traverse l'interface l avec
+!c   une vitesse wa(k,l).
+!c
+!c                       --------------------
+!c
+!c                       + + + + + + + + + + 
+!c
+!c  wa(k,l)   ----       --------------------    l
+!c             /\
+!c            /||\       + + + + + + + + + + 
+!c             ||
+!c             ||        --------------------
+!c             ||
+!c             ||        + + + + + + + + + + 
+!c             ||
+!c             ||        --------------------
+!c             ||__
+!c             |___      + + + + + + + + + +     k
+!c
+!c                       --------------------
+!c
+!c
+!c
+!c------------------------------------------------------------------
+
+!cCR: ponderation entrainement des couches instables
+!cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+!c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+!con ne considere que les premieres couches instables
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.                                        &
+       &          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k
+            endif
+          enddo
+      enddo
+    
+!c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+!c
+!c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.                                        &
+       &          l.ge.lmin(ig).and.l.le.lentr(ig)) then 
+                 entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))*                            &
+       &                           (zlev(ig,l+1)-zlev(ig,l))
+            endif
+         enddo
+      enddo
+!c pas de thermique si couches 1->5 stables
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+!c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+!c
+      print*,'fin calcul entr_star'
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+!cRC
+!c      print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+!cCR
+            f_star(ig,k)=0.
+!cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+!c      print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+!cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)                                             &
+       &         .and.entr_star(ig,l).gt.1.e-10                                      &
+       &         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=entr_star(ig,l)
+!ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)                 &
+       &                     *(zlev(ig,l+1)-zlev(ig,l))                              &
+       &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.                                       &
+       &               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)                 &
+       &                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+               &
+       &                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)                  &
+       &                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+!c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+!ctest
+               if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then
+                  print*,'pb linter'
+               endif
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))                                 &
+       &           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               if (zw2(ig,l+1).lt.0.) then
+                  print*,'pb1 zw2<0'
+               endif
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+      print*,'fin calcul zw2'
+!c
+!c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+!c pas de thermique si couches 1->5 stables
+      do ig=1,ngrid
+         if (lmin(ig).gt.5) then
+            lmax(ig)=1
+            lmin(ig)=1
+         endif
+      enddo 
+!c    
+!c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+!c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*                     &
+       &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)               &
+       &    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+      print*,'avant fermeture'
+!c Fermeture,determination de f
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2                     &
+       &                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+!c Nouvelle fermeture
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect                             &
+       &             *entr_star2(ig))*entr_star_tot(ig)
+!ctest
+!c             if (first) then
+!c             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+!c     s             *wmax(ig))
+!c             endif
+         endif
+!c         f0(ig)=f(ig)
+!c         first=.true.
+      enddo
+      print*,'apres fermeture'
+
+!c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+!c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+!cRC
+
+
+!c      print*,'9 OK convect8'
+!c     print*,'WA1 ',wa_moy
+
+!c   determination de l'indice du debut de la mixed layer ou w decroit
+
+!c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+!c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+!c   d'une couche est égale à la hauteur de la couche alimentante.
+!c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+!c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect                                     &
+       &         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+!c              if (idetr.eq.0) then
+!c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+                   print*,'pb l_mix*zlev<0'
+                  endif
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c              else if (idetr.eq.1) then
+!c                 larg_detr(ig,l)=larg_cons(ig,l)
+!c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+!c              else if (idetr.eq.2) then
+!c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c    s            *sqrt(wa_moy(ig,l))
+!c              else if (idetr.eq.4) then
+!c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c    s            *wa_moy(ig,l)
+!c              endif
+            endif
+         enddo
+       enddo
+
+!c      print*,'10 OK convect8'
+!c     print*,'WA2 ',wa_moy
+!c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+!c   compte de l'epluchage du thermique.
+!c
+!cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+!c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                             &
+       &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))                         &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)              &
+       &        then
+!c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                          &
+       &        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)                   &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))                  &
+       &        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                          &
+       &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))                         &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+            else
+            zmix(ig)=zlev(ig,lmix(ig))
+            print*,'pb zmix'
+            endif
+         else 
+         zmix(ig)=0.
+         endif
+!ctest
+         if ((zmax(ig)-zmix(ig)).lt.0.) then
+            zmix(ig)=0.99*zmax(ig)
+!c            print*,'pb zmix>zmax'
+         endif
+      enddo
+!c
+!c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.                                          &
+       &          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+!c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+!c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))                         &
+       &            /(r_aspect*zmax(ig))
+!c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+!c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+!cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/                   &
+       &     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)                        &
+       &    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)              &
+       &    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+!c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+!ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+!c                   print*,'pb xxx'
+                   xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+!c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+      
+      print*,'fin calcul fraca'
+!c      print*,'11 OK convect8'
+!c     print*,'Ea3 ',wa_moy
+!c------------------------------------------------------------------
+!c   Calcul de fracd, wd
+!c   somme wa - wd = 0
+!c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+!cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)                   &
+       &            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+!c                 write(1,*)'ajustement fm, l',l
+              endif
+!c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+!cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+              abort_message = 'fracd trop petit'
+              CALL abort_gcm (modname,abort_message,1)
+            else
+!c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+!c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+      print*,'12 OK convect8'
+!c     print*,'WA4 ',wa_moy
+!cc------------------------------------------------------------------
+!c   calcul du transport vertical
+!c------------------------------------------------------------------
+
+      go to 4444
+!c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)                                   &
+       &      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+!c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+!c    s         ,fm(ig,l+1)*ptimestep
+!c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+!c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+!c    s         ,entr(ig,l)*ptimestep
+!c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+!c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+!c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10                                            &
+       &         .or..not.masse(ig,l).le.1.e4) then
+!c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+!c    s         ,'   M=',masse(ig,l)
+!c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+!c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+!c     print*,'zlev(ig,l+1),zlev(ig,l)'
+!c    s                ,zlev(ig,l+1),zlev(ig,l)
+!c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+!c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+!c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+!c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+!cCR:redefinition du entr
+       do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+!c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+!cRC
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/tho
+         entr0=entr0+ptimestep*(entr-entr0)/tho
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca                &
+       &    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca                &
+       &    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse                      &
+       &    ,fraca,zmax                                                              &
+       &    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+!c     print*,'13 OK convect8'
+!c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+!c     do l=1,nlay
+!c        do ig=1,ngrid
+!c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+!c     print*,'WARN!!! ig=',ig,'  l=',l
+!c    s         ,'   pdtadj=',pdtadj(ig,l)
+!c           endif
+!c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+!c     print*,'WARN!!! ig=',ig,'  l=',l
+!c    s         ,'   pdoadj=',pdoadj(ig,l)
+!c           endif
+!c        enddo
+!c      enddo
+
+      print*,'14 OK convect8'
+!c------------------------------------------------------------------
+!c   Calculs pour les sorties
+!c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)                                             &
+       &      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+!cdeja fait
+!c      do l=1,nlay
+!c         do ig=1,ngrid
+!c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+!c            if (detr(ig,l).lt.0.) then
+!c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+!c                detr(ig,l)=0.
+!c     print*,'WARNING !!! detrainement negatif ',ig,l
+!c            endif
+!c         enddo
+!c      enddo
+
+!c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+!c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+!c   recalcul des flux en diagnostique...
+!c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+#define troisD
+#ifdef troisD
+!c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+!c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+!c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+!cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+!c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+!c     print*,'18 OK convect8'
+!c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+!c     if(wa_moy(1,4).gt.1.e-10) stop
+
+      print*,'19 OK convect8'
+      return
+      end SUBROUTINE thermcell
+
+      SUBROUTINE dqthermcell(ngrid,nlay,ptimestep,fm,entr,                           &
+       &           masse,q,dq,qa)
+      USE dimphy
+      implicit none
+
+!c=======================================================================
+!c
+!c   Calcul du transport verticale dans la couche limite en presence
+!c   de "thermiques" explicitement representes
+!c   calcul du dq/dt une fois qu'on connait les ascendances
+!c
+!c=======================================================================
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1)
+
+      integer ig,k
+
+!c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+!ctest
+            if (detr(ig,k).lt.0.) then
+               entr(ig,k)=entr(ig,k)-detr(ig,k)
+               detr(ig,k)=0.
+!c               print*,'detr2<0!!!','ig=',ig,'k=',k,'f=',fm(ig,k),
+!c     s         'f+1=',fm(ig,k+1),'e=',entr(ig,k),'d=',detr(ig,k)
+            endif
+            if (fm(ig,k+1).lt.0.) then
+!c               print*,'fm2<0!!!'
+            endif
+            if (entr(ig,k).lt.0.) then
+!c               print*,'entr2<0!!!'
+            endif
+         enddo
+      enddo
+
+!c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.                                &
+       &         1.e-5*masse(ig,k)) then
+         qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+entr(ig,k)*q(ig,k))                           &
+       &         /(fm(ig,k+1)+detr(ig,k))
+            else
+               qa(ig,k)=q(ig,k)
+            endif
+            if (qa(ig,k).lt.0.) then
+!c               print*,'qa<0!!!'
+            endif
+            if (q(ig,k).lt.0.) then
+!c               print*,'q<0!!!'
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+!c             wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
+            wqd(ig,k)=fm(ig,k)*q(ig,k)
+            if (wqd(ig,k).lt.0.) then
+!c               print*,'wqd<0!!!'
+            endif
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*q(ig,k)                         &
+       &               -wqd(ig,k)+wqd(ig,k+1))                                       &
+       &               /masse(ig,k)
+!c            if (dq(ig,k).lt.0.) then
+!c               print*,'dq<0!!!'
+!c            endif
+         enddo
+      enddo
+
+      return
+      end SUBROUTINE dqthermcell
+
+      SUBROUTINE dvthermcell(ngrid,nlay,ptimestep,fm,entr,masse                      &
+       &    ,fraca,larga                                                             &
+       &    ,u,v,du,dv,ua,va)
+      USE dimphy
+      implicit none
+
+!c=======================================================================
+!c
+!c   Calcul du transport verticale dans la couche limite en presence
+!c   de "thermiques" explicitement representes
+!c   calcul du dq/dt une fois qu'on connait les ascendances
+!c
+!c=======================================================================
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev)
+      real wvd(klon,klev+1),wud(klon,klev+1)
+      real gamma0,gamma(klon,klev+1)
+      real dua,dva
+      integer iter
+
+      integer ig,k
+
+!c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+!c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.                                &
+       &         1.e-5*masse(ig,k)) then
+!c   On itère sur la valeur du coeff de freinage.
+!c              gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+               gamma0=masse(ig,k)                                                    &
+       &         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )                            &
+       &         *0.5/larga(ig)
+!c              gamma0=0.
+!c   la première fois on multiplie le coefficient de freinage
+!c   par le module du vent dans la couche en dessous.
+               dua=ua(ig,k-1)-u(ig,k-1)
+               dva=va(ig,k-1)-v(ig,k-1)
+               do iter=1,5
+                  gamma(ig,k)=gamma0*sqrt(dua**2+dva**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)                                      &
+       &               +(entr(ig,k)+gamma(ig,k))*u(ig,k))                            &
+       &               /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)                                      &
+       &               +(entr(ig,k)+gamma(ig,k))*v(ig,k))                            &
+       &               /(fm(ig,k+1)+detr(ig,k)+gamma(ig,k))
+!c                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
+                  dua=ua(ig,k)-u(ig,k)
+                  dva=va(ig,k)-v(ig,k)
+               enddo
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               gamma(ig,k)=0.
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*u(ig,k)
+            wvd(ig,k)=fm(ig,k)*v(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)                              &
+       &               -(entr(ig,k)+gamma(ig,k))*u(ig,k)                             &
+       &               -wud(ig,k)+wud(ig,k+1))                                       &
+       &               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)                              &
+       &               -(entr(ig,k)+gamma(ig,k))*v(ig,k)                             &
+       &               -wvd(ig,k)+wvd(ig,k+1))                                       &
+       &               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end SUBROUTINE dvthermcell
+
+      SUBROUTINE dqthermcell2(ngrid,nlay,ptimestep,fm,entr,masse,frac                &
+       &    ,q,dq,qa)
+      USE dimphy
+      implicit none
+
+!c=======================================================================
+!c
+!c   Calcul du transport verticale dans la couche limite en presence
+!c   de "thermiques" explicitement representes
+!c   calcul du dq/dt une fois qu'on connait les ascendances
+!c
+!c=======================================================================
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real entr(ngrid,nlay),frac(ngrid,nlay)
+      real q(ngrid,nlay)
+      real dq(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),wqd(klon,klev+1)
+      real qe(klon,klev),zf,zf2
+
+      integer ig,k
+
+!c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+!c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         qa(ig,1)=q(ig,1)
+         qe(ig,1)=q(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.                                &
+       &         1.e-5*masse(ig,k)) then
+               zf=0.5*(frac(ig,k)+frac(ig,k+1))
+               zf2=1./(1.-zf)
+               qa(ig,k)=(fm(ig,k)*qa(ig,k-1)+zf2*entr(ig,k)*q(ig,k))                 &
+       &         /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2)
+               qe(ig,k)=(q(ig,k)-zf*qa(ig,k))*zf2
+            else
+               qa(ig,k)=q(ig,k)
+               qe(ig,k)=q(ig,k)
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+!c             wqd(ig,k)=fm(ig,k)*0.5*(q(ig,k-1)+q(ig,k))
+            wqd(ig,k)=fm(ig,k)*qe(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wqd(ig,1)=0.
+         wqd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            dq(ig,k)=(detr(ig,k)*qa(ig,k)-entr(ig,k)*qe(ig,k)                        &
+       &               -wqd(ig,k)+wqd(ig,k+1))                                       &
+       &               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end SUBROUTINE dqthermcell2
+
+      SUBROUTINE dvthermcell2(ngrid,nlay,ptimestep,fm,entr,masse                     &
+       &    ,fraca,larga                                                             &
+       &    ,u,v,du,dv,ua,va)
+      use dimphy
+      implicit none
+
+!c=======================================================================
+!c
+!c   Calcul du transport verticale dans la couche limite en presence
+!c   de "thermiques" explicitement representes
+!c   calcul du dq/dt une fois qu'on connait les ascendances
+!c
+!c=======================================================================
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+
+      integer ngrid,nlay
+
+      real ptimestep
+      real masse(ngrid,nlay),fm(ngrid,nlay+1)
+      real fraca(ngrid,nlay+1)
+      real larga(ngrid)
+      real entr(ngrid,nlay)
+      real u(ngrid,nlay)
+      real ua(ngrid,nlay)
+      real du(ngrid,nlay)
+      real v(ngrid,nlay)
+      real va(ngrid,nlay)
+      real dv(ngrid,nlay)
+
+      real qa(klon,klev),detr(klon,klev),zf,zf2
+      real wvd(klon,klev+1),wud(klon,klev+1)
+      real gamma0,gamma(klon,klev+1)
+      real ue(klon,klev),ve(klon,klev)
+      real dua,dva
+      integer iter
+
+      integer ig,k
+
+!c   calcul du detrainement
+
+      do k=1,nlay
+         do ig=1,ngrid
+            detr(ig,k)=fm(ig,k)-fm(ig,k+1)+entr(ig,k)
+         enddo
+      enddo
+
+!c   calcul de la valeur dans les ascendances
+      do ig=1,ngrid
+         ua(ig,1)=u(ig,1)
+         va(ig,1)=v(ig,1)
+         ue(ig,1)=u(ig,1)
+         ve(ig,1)=v(ig,1)
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            if ((fm(ig,k+1)+detr(ig,k))*ptimestep.gt.                                &
+       &         1.e-5*masse(ig,k)) then
+!c   On itère sur la valeur du coeff de freinage.
+!c              gamma0=rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k))
+               gamma0=masse(ig,k)                                                    &
+       &         *sqrt( 0.5*(fraca(ig,k+1)+fraca(ig,k)) )                            &
+       &         *0.5/larga(ig)                                                      &
+       &         *1.
+!c    s         *0.5
+!c              gamma0=0.
+               zf=0.5*(fraca(ig,k)+fraca(ig,k+1))
+               zf=0.
+               zf2=1./(1.-zf)
+!c   la première fois on multiplie le coefficient de freinage
+!c   par le module du vent dans la couche en dessous.
+               dua=ua(ig,k-1)-u(ig,k-1)
+               dva=va(ig,k-1)-v(ig,k-1)
+               do iter=1,5
+!c   On choisit une relaxation lineaire.
+                  gamma(ig,k)=gamma0
+!c   On choisit une relaxation quadratique.
+                  gamma(ig,k)=gamma0*sqrt(dua**2+dva**2)
+                  ua(ig,k)=(fm(ig,k)*ua(ig,k-1)                                      &
+       &               +(zf2*entr(ig,k)+gamma(ig,k))*u(ig,k))                        &
+       &               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2                     &
+       &                 +gamma(ig,k))
+                  va(ig,k)=(fm(ig,k)*va(ig,k-1)                                      &
+       &               +(zf2*entr(ig,k)+gamma(ig,k))*v(ig,k))                        &
+       &               /(fm(ig,k+1)+detr(ig,k)+entr(ig,k)*zf*zf2                     &
+       &                 +gamma(ig,k))
+!c                 print*,k,ua(ig,k),va(ig,k),u(ig,k),v(ig,k),dua,dva
+                  dua=ua(ig,k)-u(ig,k)
+                  dva=va(ig,k)-v(ig,k)
+                  ue(ig,k)=(u(ig,k)-zf*ua(ig,k))*zf2
+                  ve(ig,k)=(v(ig,k)-zf*va(ig,k))*zf2
+               enddo
+            else
+               ua(ig,k)=u(ig,k)
+               va(ig,k)=v(ig,k)
+               ue(ig,k)=u(ig,k)
+               ve(ig,k)=v(ig,k)
+               gamma(ig,k)=0.
+            endif
+         enddo
+      enddo
+
+      do k=2,nlay
+         do ig=1,ngrid
+            wud(ig,k)=fm(ig,k)*ue(ig,k)
+            wvd(ig,k)=fm(ig,k)*ve(ig,k)
+         enddo
+      enddo
+      do ig=1,ngrid
+         wud(ig,1)=0.
+         wud(ig,nlay+1)=0.
+         wvd(ig,1)=0.
+         wvd(ig,nlay+1)=0.
+      enddo
+
+      do k=1,nlay
+         do ig=1,ngrid
+            du(ig,k)=((detr(ig,k)+gamma(ig,k))*ua(ig,k)                              &
+       &               -(entr(ig,k)+gamma(ig,k))*ue(ig,k)                            &
+       &               -wud(ig,k)+wud(ig,k+1))                                       &
+       &               /masse(ig,k)
+            dv(ig,k)=((detr(ig,k)+gamma(ig,k))*va(ig,k)                              &
+       &               -(entr(ig,k)+gamma(ig,k))*ve(ig,k)                            &
+       &               -wvd(ig,k)+wvd(ig,k+1))                                       &
+       &               /masse(ig,k)
+         enddo
+      enddo
+
+      return
+      end SUBROUTINE dvthermcell2
+
+      SUBROUTINE thermcell_sec(ngrid,nlay,ptimestep                                  &
+       &                  ,pplay,pplev,pphi,zlev                                     &
+       &                  ,pu,pv,pt,po                                               &
+       &                  ,pduadj,pdvadj,pdtadj,pdoadj                               &
+       &                  ,fm0,entr0                                                 &
+!c    s                  ,pu_therm,pv_therm                                          &
+       &                  ,r_aspect,l_mix,w2di,tho)
+
+      use dimphy
+      IMPLICIT NONE
+
+!c=======================================================================
+!c
+!c   Calcul du transport verticale dans la couche limite en presence
+!c   de "thermiques" explicitement representes
+!c
+!c   Réécriture à partir d'un listing papier à Habas, le 14/02/00
+!c
+!c   le thermique est supposé homogène et dissipé par mélange avec
+!c   son environnement. la longueur l_mix contrôle l'efficacité du
+!c   mélange
+!c
+!c   Le calcul du transport des différentes espèces se fait en prenant
+!c   en compte:
+!c     1. un flux de masse montant
+!c     2. un flux de masse descendant
+!c     3. un entrainement
+!c     4. un detrainement
+!c
+!c=======================================================================
+
+!c-----------------------------------------------------------------------
+!c   declarations:
+!c   -------------
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+#include "YOMCST.h"
+
+!c   arguments:
+!c   ----------
+
+      INTEGER ngrid,nlay,w2di
+      REAL tho
+      real ptimestep,l_mix,r_aspect
+      REAL pt(ngrid,nlay),pdtadj(ngrid,nlay)
+      REAL pu(ngrid,nlay),pduadj(ngrid,nlay)
+      REAL pv(ngrid,nlay),pdvadj(ngrid,nlay)
+      REAL po(ngrid,nlay),pdoadj(ngrid,nlay)
+      REAL pplay(ngrid,nlay),pplev(ngrid,nlay+1)
+      real pphi(ngrid,nlay)
+
+      integer idetr
+      save idetr
+      data idetr/3/
+!$OMP THREADPRIVATE(idetr)
+
+!c   local:
+!c   ------
+
+      INTEGER ig,k,l,lmaxa(klon),lmix(klon)
+      real zsortie1d(klon)
+!c CR: on remplace lmax(klon,klev+1)
+      INTEGER lmax(klon),lmin(klon),lentr(klon)
+      real linter(klon)
+      real zmix(klon), fracazmix(klon) 
+!c RC 
+      real zmax(klon),zw,zz,zw2(klon,klev+1),ztva(klon,klev),zzz
+
+      real zlev(klon,klev+1),zlay(klon,klev)
+      REAL zh(klon,klev),zdhadj(klon,klev)
+      REAL ztv(klon,klev)
+      real zu(klon,klev),zv(klon,klev),zo(klon,klev)
+      REAL wh(klon,klev+1)
+      real wu(klon,klev+1),wv(klon,klev+1),wo(klon,klev+1)
+      real zla(klon,klev+1)
+      real zwa(klon,klev+1)
+      real zld(klon,klev+1)
+      real zwd(klon,klev+1)
+      real zsortie(klon,klev)
+      real zva(klon,klev)
+      real zua(klon,klev)
+      real zoa(klon,klev)
+
+      real zha(klon,klev)
+      real wa_moy(klon,klev+1)
+      real fraca(klon,klev+1)
+      real fracc(klon,klev+1)
+      real zf,zf2
+      real thetath2(klon,klev),wth2(klon,klev)
+!      common/comtherm/thetath2,wth2
+
+      real count_time
+      integer isplit,nsplit,ialt
+      parameter (nsplit=10)
+      data isplit/0/
+      save isplit
+!$OMP THREADPRIVATE(isplit)
+
+      logical sorties
+      real rho(klon,klev),rhobarz(klon,klev+1),masse(klon,klev)
+      real zpspsk(klon,klev)
+
+!c     real wmax(klon,klev),wmaxa(klon)
+      real wmax(klon),wmaxa(klon)
+      real wa(klon,klev,klev+1)
+      real wd(klon,klev+1)
+      real larg_part(klon,klev,klev+1)
+      real fracd(klon,klev+1)
+      real xxx(klon,klev+1)
+      real larg_cons(klon,klev+1)
+      real larg_detr(klon,klev+1)
+      real fm0(klon,klev+1),entr0(klon,klev),detr(klon,klev)
+      real pu_therm(klon,klev),pv_therm(klon,klev)
+      real fm(klon,klev+1),entr(klon,klev)
+      real fmc(klon,klev+1)
+
+!cCR:nouvelles variables
+      real f_star(klon,klev+1),entr_star(klon,klev)
+      real entr_star_tot(klon),entr_star2(klon)
+      real f(klon), f0(klon)
+      real zlevinter(klon)
+      logical first
+      data first /.false./
+      save first
+!$OMP THREADPRIVATE(first)
+!cRC
+
+      character*2 str2
+      character*10 str10
+
+      character (len=20) :: modname='thermcell_sec'
+      character (len=80) :: abort_message
+
+      LOGICAL vtest(klon),down
+
+      EXTERNAL SCOPY
+
+      integer ncorrec,ll
+      save ncorrec
+      data ncorrec/0/
+!$OMP THREADPRIVATE(ncorrec)
+      
+!c
+!c-----------------------------------------------------------------------
+!c   initialisation:
+!c   ---------------
+!c
+       sorties=.true.
+      IF(ngrid.NE.klon) THEN
+         PRINT*
+         PRINT*,'STOP dans convadj'
+         PRINT*,'ngrid    =',ngrid
+         PRINT*,'klon  =',klon
+      ENDIF
+!c
+!c-----------------------------------------------------------------------
+!c   incrementation eventuelle de tendances precedentes:
+!c   ---------------------------------------------------
+
+!c       print*,'0 OK convect8'
+
+      DO 1010 l=1,nlay
+         DO 1015 ig=1,ngrid
+            zpspsk(ig,l)=(pplay(ig,l)/pplev(ig,1))**RKAPPA
+            zh(ig,l)=pt(ig,l)/zpspsk(ig,l)
+            zu(ig,l)=pu(ig,l)
+            zv(ig,l)=pv(ig,l)
+            zo(ig,l)=po(ig,l)
+            ztv(ig,l)=zh(ig,l)*(1.+0.61*zo(ig,l))
+1015     CONTINUE
+1010  CONTINUE
+
+!c       print*,'1 OK convect8'
+!c                       --------------------
+!c
+!c
+!c                       + + + + + + + + + + +
+!c
+!c
+!c  wa, fraca, wd, fracd --------------------   zlev(2), rhobarz
+!c  wh,wt,wo ...
+!c
+!c                       + + + + + + + + + + +  zh,zu,zv,zo,rho
+!c
+!c
+!c                       --------------------   zlev(1)
+!c                       \\\\\\\\\\\\\\\\\\\\
+!c
+!c
+
+!c-----------------------------------------------------------------------
+!c   Calcul des altitudes des couches
+!c-----------------------------------------------------------------------
+
+      do l=2,nlay
+         do ig=1,ngrid
+            zlev(ig,l)=0.5*(pphi(ig,l)+pphi(ig,l-1))/RG
+         enddo
+      enddo
+      do ig=1,ngrid
+         zlev(ig,1)=0.
+         zlev(ig,nlay+1)=(2.*pphi(ig,klev)-pphi(ig,klev-1))/RG
+      enddo
+      do l=1,nlay
+         do ig=1,ngrid
+            zlay(ig,l)=pphi(ig,l)/RG
+         enddo
+      enddo
+
+!c      print*,'2 OK convect8'
+!c-----------------------------------------------------------------------
+!c   Calcul des densites
+!c-----------------------------------------------------------------------
+
+      do l=1,nlay
+         do ig=1,ngrid
+            rho(ig,l)=pplay(ig,l)/(zpspsk(ig,l)*RD*zh(ig,l))
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            rhobarz(ig,l)=0.5*(rho(ig,l)+rho(ig,l-1))
+         enddo
+      enddo
+
+      do k=1,nlay
+         do l=1,nlay+1
+            do ig=1,ngrid
+               wa(ig,k,l)=0.
+            enddo
+         enddo
+      enddo
+
+!c      print*,'3 OK convect8'
+!c------------------------------------------------------------------
+!c   Calcul de w2, quarre de w a partir de la cape
+!c   a partir de w2, on calcule wa, vitesse de l'ascendance
+!c
+!c   ATTENTION: Dans cette version, pour cause d'economie de memoire,
+!c   w2 est stoke dans wa
+!c
+!c   ATTENTION: dans convect8, on n'utilise le calcule des wa
+!c   independants par couches que pour calculer l'entrainement
+!c   a la base et la hauteur max de l'ascendance.
+!c
+!c   Indicages:
+!c   l'ascendance provenant du niveau k traverse l'interface l avec
+!c   une vitesse wa(k,l).
+!c
+!c                       --------------------
+!c
+!c                       + + + + + + + + + + 
+!c
+!c  wa(k,l)   ----       --------------------    l
+!c             /\
+!c            /||\       + + + + + + + + + + 
+!c             ||
+!c             ||        --------------------
+!c             ||
+!c             ||        + + + + + + + + + + 
+!c             ||
+!c             ||        --------------------
+!c             ||__
+!c             |___      + + + + + + + + + +     k
+!c
+!c                       --------------------
+!c
+!c
+!c
+!c------------------------------------------------------------------
+
+!cCR: ponderation entrainement des couches instables
+!cdef des entr_star tels que entr=f*entr_star      
+      do l=1,klev
+         do ig=1,ngrid 
+            entr_star(ig,l)=0.
+         enddo
+      enddo
+!c determination de la longueur de la couche d entrainement
+      do ig=1,ngrid
+         lentr(ig)=1
+      enddo
+
+!con ne considere que les premieres couches instables
+      do k=nlay-2,1,-1
+         do ig=1,ngrid
+            if (ztv(ig,k).gt.ztv(ig,k+1).and.                                        &
+       &          ztv(ig,k+1).le.ztv(ig,k+2)) then
+               lentr(ig)=k
+            endif
+          enddo
+      enddo
+    
+!c determination du lmin: couche d ou provient le thermique
+      do ig=1,ngrid
+         lmin(ig)=1
+      enddo
+      do ig=1,ngrid
+         do l=nlay,2,-1
+            if (ztv(ig,l-1).gt.ztv(ig,l)) then
+               lmin(ig)=l-1
+            endif
+         enddo
+      enddo
+!c
+!c definition de l'entrainement des couches
+      do l=1,klev-1
+         do ig=1,ngrid 
+            if (ztv(ig,l).gt.ztv(ig,l+1).and.                                        &
+       &          l.ge.lmin(ig).and.l.le.lentr(ig)) then 
+                 entr_star(ig,l)=(ztv(ig,l)-ztv(ig,l+1))**                           &
+!c     s                           (zlev(ig,l+1)-zlev(ig,l))                         &
+       &                           sqrt(zlev(ig,l+1))
+            endif
+         enddo
+      enddo
+!c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            do l=1,klev
+               entr_star(ig,l)=0.
+            enddo
+         endif
+      enddo 
+!c calcul de l entrainement total
+      do ig=1,ngrid
+         entr_star_tot(ig)=0.
+      enddo
+      do ig=1,ngrid
+         do k=1,klev
+            entr_star_tot(ig)=entr_star_tot(ig)+entr_star(ig,k)
+         enddo
+      enddo
+!c
+!c      print*,'fin calcul entr_star'
+      do k=1,klev
+         do ig=1,ngrid 
+            ztva(ig,k)=ztv(ig,k)
+         enddo
+      enddo
+!cRC
+!c      print*,'7 OK convect8'
+      do k=1,klev+1
+         do ig=1,ngrid
+            zw2(ig,k)=0.
+            fmc(ig,k)=0.
+!cCR
+            f_star(ig,k)=0.
+!cRC
+            larg_cons(ig,k)=0.
+            larg_detr(ig,k)=0.
+            wa_moy(ig,k)=0.
+         enddo
+      enddo
+
+!c      print*,'8 OK convect8'
+      do ig=1,ngrid
+         linter(ig)=1.
+         lmaxa(ig)=1
+         lmix(ig)=1
+         wmaxa(ig)=0.
+      enddo
+
+!cCR: 
+      do l=1,nlay-2
+         do ig=1,ngrid
+            if (ztv(ig,l).gt.ztv(ig,l+1)                                             &
+       &         .and.entr_star(ig,l).gt.1.e-10                                      &
+       &         .and.zw2(ig,l).lt.1e-10) then
+               f_star(ig,l+1)=entr_star(ig,l)
+!ctest:calcul de dteta
+               zw2(ig,l+1)=2.*RG*(ztv(ig,l)-ztv(ig,l+1))/ztv(ig,l+1)                 &
+       &                     *(zlev(ig,l+1)-zlev(ig,l))                              &
+       &                     *0.4*pphi(ig,l)/(pphi(ig,l+1)-pphi(ig,l))
+               larg_detr(ig,l)=0.
+            else if ((zw2(ig,l).ge.1e-10).and.                                       &
+       &               (f_star(ig,l)+entr_star(ig,l).gt.1.e-10)) then
+               f_star(ig,l+1)=f_star(ig,l)+entr_star(ig,l)
+               ztva(ig,l)=(f_star(ig,l)*ztva(ig,l-1)+entr_star(ig,l)                 &
+       &                    *ztv(ig,l))/f_star(ig,l+1)
+               zw2(ig,l+1)=zw2(ig,l)*(f_star(ig,l)/f_star(ig,l+1))**2+               &
+       &                     2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)                  &
+       &                     *(zlev(ig,l+1)-zlev(ig,l))
+            endif
+!c determination de zmax continu par interpolation lineaire
+            if (zw2(ig,l+1).lt.0.) then
+!ctest
+               if (abs(zw2(ig,l+1)-zw2(ig,l)).lt.1e-10) then
+!c                  print*,'pb linter'
+               endif
+               linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))                                 &
+       &           -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+               zw2(ig,l+1)=0.
+               lmaxa(ig)=l
+            else
+               if (zw2(ig,l+1).lt.0.) then
+!c                  print*,'pb1 zw2<0'
+               endif
+               wa_moy(ig,l+1)=sqrt(zw2(ig,l+1))
+            endif
+            if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!c   lmix est le niveau de la couche ou w (wa_moy) est maximum
+               lmix(ig)=l+1
+               wmaxa(ig)=wa_moy(ig,l+1)
+            endif
+         enddo
+      enddo
+!c      print*,'fin calcul zw2'
+!c
+!c Calcul de la couche correspondant a la hauteur du thermique
+      do ig=1,ngrid
+         lmax(ig)=lentr(ig)
+      enddo
+      do ig=1,ngrid
+         do l=nlay,lentr(ig)+1,-1
+            if (zw2(ig,l).le.1.e-10) then
+               lmax(ig)=l-1
+            endif
+         enddo
+      enddo
+!c pas de thermique si couche 1 stable
+      do ig=1,ngrid
+         if (lmin(ig).gt.1) then
+            lmax(ig)=1
+            lmin(ig)=1
+         endif
+      enddo 
+!c    
+!c Determination de zw2 max
+      do ig=1,ngrid
+         wmax(ig)=0.
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if (l.le.lmax(ig)) then
+                if (zw2(ig,l).lt.0.)then
+!c                  print*,'pb2 zw2<0'
+                endif
+                zw2(ig,l)=sqrt(zw2(ig,l))
+                wmax(ig)=max(wmax(ig),zw2(ig,l))
+            else
+                 zw2(ig,l)=0.
+            endif
+          enddo
+      enddo
+
+!c   Longueur caracteristique correspondant a la hauteur des thermiques.
+      do  ig=1,ngrid
+         zmax(ig)=0.
+         zlevinter(ig)=zlev(ig,1)
+      enddo
+      do  ig=1,ngrid
+!c calcul de zlevinter
+          zlevinter(ig)=(zlev(ig,lmax(ig)+1)-zlev(ig,lmax(ig)))*                     &
+       &    linter(ig)+zlev(ig,lmax(ig))-lmax(ig)*(zlev(ig,lmax(ig)+1)               &
+       &    -zlev(ig,lmax(ig)))
+       zmax(ig)=max(zmax(ig),zlevinter(ig)-zlev(ig,lmin(ig)))
+      enddo
+
+!c      print*,'avant fermeture'
+!c Fermeture,determination de f
+      do ig=1,ngrid
+         entr_star2(ig)=0.
+      enddo
+      do ig=1,ngrid
+         if (entr_star_tot(ig).LT.1.e-10) then
+            f(ig)=0.
+         else
+             do k=lmin(ig),lentr(ig)
+                entr_star2(ig)=entr_star2(ig)+entr_star(ig,k)**2                     &
+       &                    /(rho(ig,k)*(zlev(ig,k+1)-zlev(ig,k)))
+             enddo
+!c Nouvelle fermeture
+             f(ig)=wmax(ig)/(max(500.,zmax(ig))*r_aspect                             &
+       &             *entr_star2(ig))*entr_star_tot(ig)
+!ctest
+!c             if (first) then
+!c             f(ig)=f(ig)+(f0(ig)-f(ig))*exp(-ptimestep/zmax(ig)
+!c     s             *wmax(ig))
+!c             endif
+         endif
+!c         f0(ig)=f(ig)
+!c         first=.true.
+      enddo
+!c      print*,'apres fermeture'
+
+!c Calcul de l'entrainement
+       do k=1,klev
+         do ig=1,ngrid 
+            entr(ig,k)=f(ig)*entr_star(ig,k)
+         enddo
+      enddo
+!cCR:test pour entrainer moins que la masse
+       do ig=1,ngrid
+          do l=1,lentr(ig)
+             if ((entr(ig,l)*ptimestep).gt.(0.9*masse(ig,l))) then
+                entr(ig,l+1)=entr(ig,l+1)+entr(ig,l)                                 &
+       &                       -0.9*masse(ig,l)/ptimestep
+                entr(ig,l)=0.9*masse(ig,l)/ptimestep
+             endif
+          enddo
+       enddo
+!cCR: fin test
+!c Calcul des flux
+      do ig=1,ngrid
+         do l=1,lmax(ig)-1
+            fmc(ig,l+1)=fmc(ig,l)+entr(ig,l)
+         enddo
+      enddo
+
+!cRC
+
+
+!c      print*,'9 OK convect8'
+!c     print*,'WA1 ',wa_moy
+
+!c   determination de l'indice du debut de la mixed layer ou w decroit
+
+!c   calcul de la largeur de chaque ascendance dans le cas conservatif.
+!c   dans ce cas simple, on suppose que la largeur de l'ascendance provenant
+!c   d'une couche est égale à la hauteur de la couche alimentante.
+!c   La vitesse maximale dans l'ascendance est aussi prise comme estimation
+!c   de la vitesse d'entrainement horizontal dans la couche alimentante.
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+               zw=max(wa_moy(ig,l),1.e-10)
+               larg_cons(ig,l)=zmax(ig)*r_aspect                                     &
+       &         *fmc(ig,l)/(rhobarz(ig,l)*zw)
+            endif
+         enddo
+      enddo
+
+      do l=2,nlay
+         do ig=1,ngrid
+            if (l.le.lmaxa(ig)) then
+!c              if (idetr.eq.0) then
+!c  cette option est finalement en dur.
+                  if ((l_mix*zlev(ig,l)).lt.0.)then
+!c                   print*,'pb l_mix*zlev<0'
+                  endif
+!cCR: test: nouvelle def de lambda
+!c                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  if (zw2(ig,l).gt.1.e-10) then
+                  larg_detr(ig,l)=sqrt((l_mix/zw2(ig,l))*zlev(ig,l))
+                  else
+                  larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+                  endif
+!cRC
+!c              else if (idetr.eq.1) then
+!c                 larg_detr(ig,l)=larg_cons(ig,l)
+!c    s            *sqrt(l_mix*zlev(ig,l))/larg_cons(ig,lmix(ig))
+!c              else if (idetr.eq.2) then
+!c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c    s            *sqrt(wa_moy(ig,l))
+!c              else if (idetr.eq.4) then
+!c                 larg_detr(ig,l)=sqrt(l_mix*zlev(ig,l))
+!c    s            *wa_moy(ig,l)
+!c              endif
+            endif
+         enddo
+       enddo
+
+!c      print*,'10 OK convect8'
+!c     print*,'WA2 ',wa_moy
+!c   calcul de la fraction de la maille concernée par l'ascendance en tenant
+!c   compte de l'epluchage du thermique.
+!c
+!cCR def de  zmix continu (profil parabolique des vitesses)
+      do ig=1,ngrid
+           if (lmix(ig).gt.1.) then
+!c test 
+              if (((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                             &
+       &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))                         &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))).gt.1e-10)              &
+       &        then
+!c             
+            zmix(ig)=((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                          &
+       &        *((zlev(ig,lmix(ig)))**2-(zlev(ig,lmix(ig)+1))**2)                   &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))**2-(zlev(ig,lmix(ig)))**2))                  &
+       &        /(2.*((zw2(ig,lmix(ig)-1)-zw2(ig,lmix(ig)))                          &
+       &        *((zlev(ig,lmix(ig)))-(zlev(ig,lmix(ig)+1)))                         &
+       &        -(zw2(ig,lmix(ig))-zw2(ig,lmix(ig)+1))                               &
+       &        *((zlev(ig,lmix(ig)-1))-(zlev(ig,lmix(ig))))))
+            else
+            zmix(ig)=zlev(ig,lmix(ig))
+!c            print*,'pb zmix'
+            endif
+         else 
+         zmix(ig)=0.
+         endif
+!ctest
+         if ((zmax(ig)-zmix(ig)).lt.0.) then
+            zmix(ig)=0.99*zmax(ig)
+!c            print*,'pb zmix>zmax'
+         endif
+      enddo
+!c
+!c calcul du nouveau lmix correspondant
+      do ig=1,ngrid
+         do l=1,klev
+            if (zmix(ig).ge.zlev(ig,l).and.                                          &
+       &          zmix(ig).lt.zlev(ig,l+1)) then
+              lmix(ig)=l
+             endif
+          enddo
+      enddo
+!c
+      do l=2,nlay
+         do ig=1,ngrid
+            if(larg_cons(ig,l).gt.1.) then
+!c     print*,ig,l,lmix(ig),lmaxa(ig),larg_cons(ig,l),'  KKK'
+               fraca(ig,l)=(larg_cons(ig,l)-larg_detr(ig,l))                         &
+       &            /(r_aspect*zmax(ig))
+!c test
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+            else
+!c              wa_moy(ig,l)=0.
+               fraca(ig,l)=0.
+               fracc(ig,l)=0.
+               fracd(ig,l)=1.
+            endif
+         enddo
+      enddo                  
+!cCR: calcul de fracazmix
+       do ig=1,ngrid
+          fracazmix(ig)=(fraca(ig,lmix(ig)+1)-fraca(ig,lmix(ig)))/                   &
+       &     (zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))*zmix(ig)                        &
+       &    +fraca(ig,lmix(ig))-zlev(ig,lmix(ig))*(fraca(ig,lmix(ig)+1)              &
+       &    -fraca(ig,lmix(ig)))/(zlev(ig,lmix(ig)+1)-zlev(ig,lmix(ig)))
+       enddo
+!c
+       do l=2,nlay
+          do ig=1,ngrid
+             if(larg_cons(ig,l).gt.1.) then
+               if (l.gt.lmix(ig)) then
+!ctest
+                 if (zmax(ig)-zmix(ig).lt.1.e-10) then
+!c                   print*,'pb xxx'
+                   xxx(ig,l)=(lmaxa(ig)+1.-l)/(lmaxa(ig)+1.-lmix(ig))
+                 else
+                 xxx(ig,l)=(zmax(ig)-zlev(ig,l))/(zmax(ig)-zmix(ig))
+                 endif
+           if (idetr.eq.0) then
+               fraca(ig,l)=fracazmix(ig)
+           else if (idetr.eq.1) then
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)
+           else if (idetr.eq.2) then
+               fraca(ig,l)=fracazmix(ig)*(1.-(1.-xxx(ig,l))**2)
+           else
+               fraca(ig,l)=fracazmix(ig)*xxx(ig,l)**2
+           endif
+!c     print*,ig,l,lmix(ig),lmaxa(ig),xxx(ig,l),'LLLLLLL'
+               fraca(ig,l)=max(fraca(ig,l),0.)
+               fraca(ig,l)=min(fraca(ig,l),0.5)
+               fracd(ig,l)=1.-fraca(ig,l)
+               fracc(ig,l)=larg_cons(ig,l)/(r_aspect*zmax(ig))
+             endif
+            endif
+         enddo
+      enddo
+      
+!c      print*,'fin calcul fraca'
+!c      print*,'11 OK convect8'
+!c     print*,'Ea3 ',wa_moy
+!c------------------------------------------------------------------
+!c   Calcul de fracd, wd
+!c   somme wa - wd = 0
+!c------------------------------------------------------------------
+
+
+      do ig=1,ngrid
+         fm(ig,1)=0.
+         fm(ig,nlay+1)=0.
+      enddo
+
+      do l=2,nlay
+           do ig=1,ngrid
+              fm(ig,l)=fraca(ig,l)*wa_moy(ig,l)*rhobarz(ig,l)
+!cCR:test
+              if (entr(ig,l-1).lt.1e-10.and.fm(ig,l).gt.fm(ig,l-1)                   &
+       &            .and.l.gt.lmix(ig)) then
+                 fm(ig,l)=fm(ig,l-1)
+!c                 write(1,*)'ajustement fm, l',l
+              endif
+!c              write(1,*)'ig,l,fm(ig,l)',ig,l,fm(ig,l)
+!cRC
+           enddo
+         do ig=1,ngrid
+            if(fracd(ig,l).lt.0.1) then
+              abort_message = 'fracd trop petit'
+              CALL abort_gcm (modname,abort_message,1)
+            else
+!c    vitesse descendante "diagnostique"
+               wd(ig,l)=fm(ig,l)/(fracd(ig,l)*rhobarz(ig,l))
+            endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+!c           masse(ig,l)=rho(ig,l)*(zlev(ig,l+1)-zlev(ig,l))
+            masse(ig,l)=(pplev(ig,l)-pplev(ig,l+1))/RG
+         enddo
+      enddo
+
+!c      print*,'12 OK convect8'
+!c     print*,'WA4 ',wa_moy
+!cc------------------------------------------------------------------
+!c   calcul du transport vertical
+!c------------------------------------------------------------------
+
+      go to 4444
+!c     print*,'XXXXXXXXXXXXXXX ptimestep= ',ptimestep
+      do l=2,nlay-1
+         do ig=1,ngrid
+            if(fm(ig,l+1)*ptimestep.gt.masse(ig,l)                                   &
+       &      .and.fm(ig,l+1)*ptimestep.gt.masse(ig,l+1)) then
+!c     print*,'WARN!!! FM>M ig=',ig,' l=',l,'  FM='
+!c    s         ,fm(ig,l+1)*ptimestep
+!c    s         ,'   M=',masse(ig,l),masse(ig,l+1)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(entr(ig,l)*ptimestep.gt.masse(ig,l)) then
+!c     print*,'WARN!!! E>M ig=',ig,' l=',l,'  E=='
+!c    s         ,entr(ig,l)*ptimestep
+!c    s         ,'   M=',masse(ig,l)
+             endif
+         enddo
+      enddo
+
+      do l=1,nlay
+         do ig=1,ngrid
+            if(.not.fm(ig,l).ge.0..or..not.fm(ig,l).le.10.) then
+!c     print*,'WARN!!! fm exagere ig=',ig,'   l=',l
+!c    s         ,'   FM=',fm(ig,l)
+            endif
+            if(.not.masse(ig,l).ge.1.e-10                                            &
+       &         .or..not.masse(ig,l).le.1.e4) then
+!c     print*,'WARN!!! masse exagere ig=',ig,'   l=',l
+!c    s         ,'   M=',masse(ig,l)
+!c     print*,'rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)',
+!c    s                 rho(ig,l),pplay(ig,l),zpspsk(ig,l),RD,zh(ig,l)
+!c     print*,'zlev(ig,l+1),zlev(ig,l)'
+!c    s                ,zlev(ig,l+1),zlev(ig,l)
+!c     print*,'pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)'
+!c    s                ,pphi(ig,l-1),pphi(ig,l),pphi(ig,l+1)
+            endif
+            if(.not.entr(ig,l).ge.0..or..not.entr(ig,l).le.10.) then
+!c     print*,'WARN!!! entr exagere ig=',ig,'   l=',l
+!c    s         ,'   E=',entr(ig,l)
+            endif
+         enddo
+      enddo
+
+4444   continue
+
+!cCR:redefinition du entr
+       do l=1,nlay
+         do ig=1,ngrid
+            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+            if (detr(ig,l).lt.0.) then
+                entr(ig,l)=entr(ig,l)-detr(ig,l)
+                detr(ig,l)=0.
+!c     print*,'WARNING !!! detrainement negatif ',ig,l
+            endif
+         enddo
+      enddo
+!cRC
+      if (w2di.eq.1) then
+         fm0=fm0+ptimestep*(fm-fm0)/tho
+         entr0=entr0+ptimestep*(entr-entr0)/tho
+      else
+         fm0=fm
+         entr0=entr
+      endif
+
+      if (1.eq.1) then
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zh,zdhadj,zha)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zo,pdoadj,zoa)
+      else
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca                &
+       &    ,zh,zdhadj,zha)
+         call dqthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse,fraca                &
+       &    ,zo,pdoadj,zoa)
+      endif
+
+      if (1.eq.0) then
+         call dvthermcell2(ngrid,nlay,ptimestep,fm0,entr0,masse                      &
+       &    ,fraca,zmax                                                              &
+       &    ,zu,zv,pduadj,pdvadj,zua,zva)
+      else
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zu,pduadj,zua)
+         call dqthermcell(ngrid,nlay,ptimestep,fm0,entr0,masse                       &
+       &    ,zv,pdvadj,zva)
+      endif
+
+      do l=1,nlay
+         do ig=1,ngrid
+            zf=0.5*(fracc(ig,l)+fracc(ig,l+1))
+            zf2=zf/(1.-zf)
+            thetath2(ig,l)=zf2*(zha(ig,l)-zh(ig,l))**2
+            wth2(ig,l)=zf2*(0.5*(wa_moy(ig,l)+wa_moy(ig,l+1)))**2
+         enddo
+      enddo
+
+
+
+!c     print*,'13 OK convect8'
+!c     print*,'WA5 ',wa_moy
+      do l=1,nlay
+         do ig=1,ngrid
+            pdtadj(ig,l)=zdhadj(ig,l)*zpspsk(ig,l)
+         enddo
+      enddo
+
+
+!c     do l=1,nlay
+!c        do ig=1,ngrid
+!c           if(abs(pdtadj(ig,l))*86400..gt.500.) then
+!c     print*,'WARN!!! ig=',ig,'  l=',l
+!c    s         ,'   pdtadj=',pdtadj(ig,l)
+!c           endif
+!c           if(abs(pdoadj(ig,l))*86400..gt.1.) then
+!c     print*,'WARN!!! ig=',ig,'  l=',l
+!c    s         ,'   pdoadj=',pdoadj(ig,l)
+!c           endif
+!c        enddo
+!c      enddo
+
+!c      print*,'14 OK convect8'
+!c------------------------------------------------------------------
+!c   Calculs pour les sorties
+!c------------------------------------------------------------------
+
+      if(sorties) then
+      do l=1,nlay
+         do ig=1,ngrid
+            zla(ig,l)=(1.-fracd(ig,l))*zmax(ig)
+            zld(ig,l)=fracd(ig,l)*zmax(ig)
+            if(1.-fracd(ig,l).gt.1.e-10)                                             &
+       &      zwa(ig,l)=wd(ig,l)*fracd(ig,l)/(1.-fracd(ig,l))
+         enddo
+      enddo
+
+!cdeja fait
+!c      do l=1,nlay
+!c         do ig=1,ngrid
+!c            detr(ig,l)=fm(ig,l)+entr(ig,l)-fm(ig,l+1)
+!c            if (detr(ig,l).lt.0.) then
+!c                entr(ig,l)=entr(ig,l)-detr(ig,l)
+!c                detr(ig,l)=0.
+!c     print*,'WARNING !!! detrainement negatif ',ig,l
+!c            endif
+!c         enddo
+!c      enddo
+
+!c     print*,'15 OK convect8'
+
+      isplit=isplit+1
+
+
+!c #define und
+	goto 123
+#ifdef und
+      CALL writeg1d(1,nlay,wd,'wd      ','wd      ')
+      CALL writeg1d(1,nlay,zwa,'wa      ','wa      ')
+      CALL writeg1d(1,nlay,fracd,'fracd      ','fracd      ')
+      CALL writeg1d(1,nlay,fraca,'fraca      ','fraca      ')
+      CALL writeg1d(1,nlay,wa_moy,'wam         ','wam         ')
+      CALL writeg1d(1,nlay,zla,'la      ','la      ')
+      CALL writeg1d(1,nlay,zld,'ld      ','ld      ')
+      CALL writeg1d(1,nlay,pt,'pt      ','pt      ')
+      CALL writeg1d(1,nlay,zh,'zh      ','zh      ')
+      CALL writeg1d(1,nlay,zha,'zha      ','zha      ')
+      CALL writeg1d(1,nlay,zu,'zu      ','zu      ')
+      CALL writeg1d(1,nlay,zv,'zv      ','zv      ')
+      CALL writeg1d(1,nlay,zo,'zo      ','zo      ')
+      CALL writeg1d(1,nlay,wh,'wh      ','wh      ')
+      CALL writeg1d(1,nlay,wu,'wu      ','wu      ')
+      CALL writeg1d(1,nlay,wv,'wv      ','wv      ')
+      CALL writeg1d(1,nlay,wo,'w15uo     ','wXo     ')
+      CALL writeg1d(1,nlay,zdhadj,'zdhadj      ','zdhadj      ')
+      CALL writeg1d(1,nlay,pduadj,'pduadj      ','pduadj      ')
+      CALL writeg1d(1,nlay,pdvadj,'pdvadj      ','pdvadj      ')
+      CALL writeg1d(1,nlay,pdoadj,'pdoadj      ','pdoadj      ')
+      CALL writeg1d(1,nlay,entr  ,'entr        ','entr        ')
+      CALL writeg1d(1,nlay,detr  ,'detr        ','detr        ')
+      CALL writeg1d(1,nlay,fm    ,'fm          ','fm          ')
+
+      CALL writeg1d(1,nlay,pdtadj,'pdtadj    ','pdtadj    ')
+      CALL writeg1d(1,nlay,pplay,'pplay     ','pplay     ')
+      CALL writeg1d(1,nlay,pplev,'pplev     ','pplev     ')
+
+!c   recalcul des flux en diagnostique...
+!c     print*,'PAS DE TEMPS ',ptimestep
+       call dt2F(pplev,pplay,pt,pdtadj,wh)
+      CALL writeg1d(1,nlay,wh,'wh2     ','wh2     ')
+#endif
+123   continue
+! #define troisD
+#ifdef troisD
+!c       if (sorties) then
+      print*,'Debut des wrgradsfi'
+
+!c      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,wd,'wd        ','wd        ')
+         call wrgradsfi(1,nlay,zwa,'wa        ','wa        ')
+         call wrgradsfi(1,nlay,fracd,'fracd     ','fracd     ')
+         call wrgradsfi(1,nlay,fraca,'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,xxx,'xxx       ','xxx       ')
+         call wrgradsfi(1,nlay,wa_moy,'wam       ','wam       ')
+!c      print*,'WA6 ',wa_moy
+         call wrgradsfi(1,nlay,zla,'la        ','la        ')
+         call wrgradsfi(1,nlay,zld,'ld        ','ld        ')
+         call wrgradsfi(1,nlay,pt,'pt        ','pt        ')
+         call wrgradsfi(1,nlay,zh,'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha,'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua,'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva,'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu,'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv,'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,wh,'wh        ','wh        ')
+         call wrgradsfi(1,nlay,wu,'wu        ','wu        ')
+         call wrgradsfi(1,nlay,wv,'wv        ','wv        ')
+         call wrgradsfi(1,nlay,wo,'wo        ','wo        ')
+         call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+         call wrgradsfi(1,nlay,zdhadj,'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj,'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj,'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj,'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr,'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr,'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm,'fm        ','fm        ')
+         call wrgradsfi(1,nlay,fmc,'fmc       ','fmc       ')
+         call wrgradsfi(1,nlay,zw2,'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,ztva,'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv,'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo,'zo        ','zo        ')
+         call wrgradsfi(1,nlay,larg_cons,'Lc        ','Lc        ')
+         call wrgradsfi(1,nlay,larg_detr,'Ldetr     ','Ldetr     ')
+
+!cCR:nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  ,'entr_star   ','entr_star   ')     
+      call wrgradsfi(1,nlay,f_star    ,'f_star   ','f_star   ')
+      call wrgradsfi(1,1,zmax,'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmix,'zmix      ','zmix      ') 
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d,'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax,'wmax      ','wmax      ')
+      zsortie1d(:)=lmix(:)
+      call wrgradsfi(1,1,zsortie1d,'lmix      ','lmix      ')
+      zsortie1d(:)=lentr(:)
+      call wrgradsfi(1,1,zsortie1d,'lentr      ','lentr     ')
+
+!c      print*,'17 OK convect8'
+
+         do k=1,klev/10
+            write(str2,'(i2.2)') k
+            str10='wa'//str2
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=wa(ig,k,l)
+               enddo
+            enddo   
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+            do l=1,nlay
+               do ig=1,ngrid
+                  zsortie(ig,l)=larg_part(ig,k,l)
+               enddo
+            enddo
+            str10='la'//str2
+            CALL wrgradsfi(1,nlay,zsortie,str10,str10)
+         enddo
+
+
+!c     print*,'18 OK convect8'
+!c      endif
+      print*,'Fin des wrgradsfi'
+#endif
+
+      endif
+
+!c     if(wa_moy(1,4).gt.1.e-10) stop
+
+!c      print*,'19 OK convect8'
+      return
+      end SUBROUTINE thermcell_sec
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_out3d.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_out3d.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_out3d.h	(revision 17)
@@ -0,0 +1,75 @@
+!       if (sorties) then
+
+!      print*,'16 OK convect8'
+         call wrgradsfi(1,nlay,pt(igout,1:klev),'pt        ','pt        ')
+         call wrgradsfi(1,nlay,fraca(igout,1:klev),'fraca     ','fraca     ')
+         call wrgradsfi(1,nlay,zh(igout,1:klev),'zh        ','zh        ')
+         call wrgradsfi(1,nlay,zha(igout,1:klev),'zha        ','zha        ')
+         call wrgradsfi(1,nlay,zua(igout,1:klev),'zua        ','zua        ')
+         call wrgradsfi(1,nlay,zva(igout,1:klev),'zva        ','zva        ')
+         call wrgradsfi(1,nlay,zu(igout,1:klev),'zu        ','zu        ')
+         call wrgradsfi(1,nlay,zv(igout,1:klev),'zv        ','zv        ')
+         call wrgradsfi(1,nlay,zo(igout,1:klev),'zo        ','zo        ')
+         call wrgradsfi(1,1,zmax(igout),'zmax      ','zmax      ')
+!         call wrgradsfi(1,nlay,zdhadj(igout,1:klev),'zdhadj    ','zdhadj    ')
+         call wrgradsfi(1,nlay,pduadj(igout,1:klev),'pduadj    ','pduadj    ')
+         call wrgradsfi(1,nlay,pdvadj(igout,1:klev),'pdvadj    ','pdvadj    ')
+         call wrgradsfi(1,nlay,pdoadj(igout,1:klev),'pdoadj    ','pdoadj    ')
+         call wrgradsfi(1,nlay,entr(igout,1:klev),'entr      ','entr      ')
+         call wrgradsfi(1,nlay,detr(igout,1:klev),'detr      ','detr      ')
+         call wrgradsfi(1,nlay,fm(igout,1:klev),'fm        ','fm        ')
+         call wrgradsfi(1,nlay,zw2(igout,1:klev),'zw2       ','zw2       ')
+         call wrgradsfi(1,nlay,zw_est(igout,1:klev),'w_est      ','w_est      ')
+!on sort les moments
+         call wrgradsfi(1,nlay,thetath2(igout,1:klev),'zh2       ','zh2       ')
+         call wrgradsfi(1,nlay,wth2(igout,1:klev),'w2       ','w2       ')
+         call wrgradsfi(1,nlay,wth3(igout,1:klev),'w3       ','w3       ')
+         call wrgradsfi(1,nlay,q2(igout,1:klev),'q2       ','q2       ')
+!
+!
+         call wrgradsfi(1,nlay,wthl(igout,1:klev),'wthl       ','wthl       ')
+         call wrgradsfi(1,nlay,wthv(igout,1:klev),'wthv       ','wthv       ')
+         call wrgradsfi(1,nlay,wq(igout,1:klev),'wq       ','wq       ')
+         
+         call wrgradsfi(1,nlay,ztva(igout,1:klev),'ztva      ','ztva      ')
+         call wrgradsfi(1,nlay,ztv(igout,1:klev),'ztv       ','ztv       ')
+
+         call wrgradsfi(1,nlay,zo(igout,1:klev),'zo        ','zo        ')
+         call wrgradsfi(1,nlay,zoa(igout,1:klev),'zoa        ','zoa        ')
+
+!nouveaux diagnostiques
+         call wrgradsfi(1,nlay,zthl(igout,1:klev),'zthl        ','zthl        ')
+         call wrgradsfi(1,nlay,zta(igout,1:klev),'zta        ','zta        ')
+         call wrgradsfi(1,nlay,zl(igout,1:klev),'zl        ','zl        ')
+         call wrgradsfi(1,nlay,zdthladj(igout,1:klev),'zdthladj    ',  &
+     &        'zdthladj    ')
+         call wrgradsfi(1,nlay,ztla(igout,1:klev),'ztla      ','ztla      ')
+         call wrgradsfi(1,nlay,zqta(igout,1:klev),'zqta      ','zqta      ')
+         call wrgradsfi(1,nlay,zqla(igout,1:klev),'zqla      ','zqla      ')
+         call wrgradsfi(1,nlay,deltaz(igout,1:klev),'deltaz      ','deltaz      ')
+!nouveaux diagnostiques
+      call wrgradsfi(1,nlay,entr_star  (igout,1:klev),'entr_star   ','entr_star   ')
+      call wrgradsfi(1,nlay,detr_star  (igout,1:klev),'detr_star   ','detr_star   ')     
+      call wrgradsfi(1,nlay,f_star    (igout,1:klev),'f_star   ','f_star   ')
+      call wrgradsfi(1,nlay,zqsat    (igout,1:klev),'zqsat   ','zqsat   ')
+      call wrgradsfi(1,nlay,zqsatth    (igout,1:klev),'qsath   ','qsath   ')
+      call wrgradsfi(1,nlay,alim_star    (igout,1:klev),'alim_star   ','alim_star   ')
+!      call wrgradsfi(1,nlay,alim    (igout,1:klev),'alim   ','alim   ')
+      call wrgradsfi(1,1,f(igout),'f      ','f      ')
+      call wrgradsfi(1,1,alim_star_tot(igout),'a_s_t      ','a_s_t      ')
+      call wrgradsfi(1,1,zmax(igout),'zmax      ','zmax      ')
+      call wrgradsfi(1,1,zmax_sec(igout),'z_sec      ','z_sec      ')
+      call wrgradsfi(1,1,zmix(igout),'zmix      ','zmix      ') 
+!      call wrgradsfi(1,1,nivcon(igout),'nivcon      ','nivcon      ')
+      call wrgradsfi(1,1,zcon(igout),'zcon      ','zcon      ')
+      call wrgradsfi(1,1,zcon2(igout),'zcon2      ','zcon2      ')
+      zsortie1d(:)=lmax(:)
+      call wrgradsfi(1,1,zsortie1d(igout),'lmax      ','lmax      ')
+      call wrgradsfi(1,1,wmax(igout),'wmax      ','wmax      ')
+      call wrgradsfi(1,1,wmax_sec(igout),'w_sec      ','w_sec      ')
+!      zsortie1d(:)=lmix(:)
+!      call wrgradsfi(1,1,zsortie1d(igout),'lmix      ','lmix      ')
+!      zsortie1d(:)=lentr(:)
+!      call wrgradsfi(1,1,zsortie1d(igout),'lentr      ','lentr     ')
+
+      print*,'Fin des wrgradsfi'
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_plume.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_plume.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_plume.F90	(revision 17)
@@ -0,0 +1,857 @@
+!
+! $Id: thermcell_plume.F90 1503 2011-03-23 11:57:52Z idelkadi $
+!
+      SUBROUTINE thermcell_plume(itap,ngrid,klev,ptimestep,ztv,zthl,po,zl,rhobarz,  &
+     &           zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
+     &           lalim,f0,detr_star,entr_star,f_star,csc,ztva,  &
+     &           ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
+     &           ,lev_out,lunout1,igout)
+
+!--------------------------------------------------------------------------
+!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance
+!--------------------------------------------------------------------------
+
+      IMPLICIT NONE
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+#include "iniprint.h"
+#include "thermcell.h"
+
+      INTEGER itap
+      INTEGER lunout1,igout
+      INTEGER ngrid,klev
+      REAL ptimestep
+      REAL ztv(ngrid,klev)
+      REAL zthl(ngrid,klev)
+      REAL po(ngrid,klev)
+      REAL zl(ngrid,klev)
+      REAL rhobarz(ngrid,klev)
+      REAL zlev(ngrid,klev+1)
+      REAL pplev(ngrid,klev+1)
+      REAL pphi(ngrid,klev)
+      REAL zpspsk(ngrid,klev)
+      REAL alim_star(ngrid,klev)
+      REAL f0(ngrid)
+      INTEGER lalim(ngrid)
+      integer lev_out                           ! niveau pour les print
+      integer nbpb
+      real zcon2(ngrid)
+    
+      real alim_star_tot(ngrid)
+
+      REAL ztva(ngrid,klev)
+      REAL ztla(ngrid,klev)
+      REAL zqla(ngrid,klev)
+      REAL zqta(ngrid,klev)
+      REAL zha(ngrid,klev)
+
+      REAL detr_star(ngrid,klev)
+      REAL coefc
+      REAL entr_star(ngrid,klev)
+      REAL detr(ngrid,klev)
+      REAL entr(ngrid,klev)
+
+      REAL csc(ngrid,klev)
+
+      REAL zw2(ngrid,klev+1)
+      REAL w_est(ngrid,klev+1)
+      REAL f_star(ngrid,klev+1)
+      REAL wa_moy(ngrid,klev+1)
+
+      REAL ztva_est(ngrid,klev)
+      REAL zqla_est(ngrid,klev)
+      REAL zqsatth(ngrid,klev)
+      REAL zta_est(ngrid,klev)
+      REAL zdw2
+      REAL zw2modif
+      REAL zeps
+
+      REAL linter(ngrid)
+      INTEGER lmix(ngrid)
+      INTEGER lmix_bis(ngrid)
+      REAL    wmaxa(ngrid)
+
+      INTEGER ig,l,k
+
+      real zdz,zfact,zbuoy,zalpha,zdrag
+      real zcor,zdelta,zcvm5,qlbef
+      real Tbef,qsatbef
+      real dqsat_dT,DT,num,denom
+      REAL REPS,RLvCp,DDT0
+      PARAMETER (DDT0=.01)
+      logical Zsat
+      LOGICAL active(ngrid),activetmp(ngrid)
+      REAL fact_gamma,fact_epsilon,fact_gamma2
+      REAL c2(ngrid,klev)
+      REAL a1,m
+
+      REAL zw2fact,expa
+      Zsat=.false.
+! Initialisation
+      RLvCp = RLVTT/RCPD
+     
+      
+         fact_epsilon=0.002
+         a1=2./3.
+         fact_gamma=0.9
+         zfact=fact_gamma/(1+fact_gamma)
+         fact_gamma2=zfact
+         expa=0.
+      
+
+! Initialisations des variables reeles
+if (1==1) then
+      ztva(:,:)=ztv(:,:)
+      ztva_est(:,:)=ztva(:,:)
+      ztla(:,:)=zthl(:,:)
+      zqta(:,:)=po(:,:)
+      zha(:,:) = ztva(:,:)
+else
+      ztva(:,:)=0.
+      ztva_est(:,:)=0.
+      ztla(:,:)=0.
+      zqta(:,:)=0.
+      zha(:,:) =0.
+endif
+
+      zqla_est(:,:)=0.
+      zqsatth(:,:)=0.
+      zqla(:,:)=0.
+      detr_star(:,:)=0.
+      entr_star(:,:)=0.
+      alim_star(:,:)=0.
+      alim_star_tot(:)=0.
+      csc(:,:)=0.
+      detr(:,:)=0.
+      entr(:,:)=0.
+      zw2(:,:)=0.
+      w_est(:,:)=0.
+      f_star(:,:)=0.
+      wa_moy(:,:)=0.
+      linter(:)=1.
+      linter(:)=1.
+
+! Initialisation des variables entieres
+      lmix(:)=1
+      lmix_bis(:)=2
+      wmaxa(:)=0.
+      lalim(:)=1
+
+!-------------------------------------------------------------------------
+! On ne considere comme actif que les colonnes dont les deux premieres
+! couches sont instables.
+!-------------------------------------------------------------------------
+      active(:)=ztv(:,1)>ztv(:,2)
+
+!-------------------------------------------------------------------------
+! Definition de l'alimentation a l'origine dans thermcell_init
+!-------------------------------------------------------------------------
+      do l=1,klev-1
+         do ig=1,ngrid
+            if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then
+               alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)  &
+     &                       *sqrt(zlev(ig,l+1)) 
+               lalim(ig)=l+1
+               alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
+            endif
+         enddo
+      enddo
+      do l=1,klev
+         do ig=1,ngrid 
+            if (alim_star_tot(ig) > 1.e-10 ) then
+               alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
+            endif
+         enddo
+      enddo
+      alim_star_tot(:)=1.
+
+
+!------------------------------------------------------------------------------
+! Calcul dans la premiere couche
+! On decide dans cette version que le thermique n'est actif que si la premiere
+! couche est instable.
+! Pourrait etre change si on veut que le thermiques puisse se dÃ©clencher
+! dans une couche l>1
+!------------------------------------------------------------------------------
+do ig=1,ngrid
+! Le panache va prendre au debut les caracteristiques de l'air contenu
+! dans cette couche.
+    if (active(ig)) then
+    ztla(ig,1)=zthl(ig,1) 
+    zqta(ig,1)=po(ig,1)
+    zqla(ig,1)=zl(ig,1)
+!cr: attention, prise en compte de f*(1)=1
+    f_star(ig,2)=alim_star(ig,1)
+    zw2(ig,2)=2.*RG*(ztv(ig,1)-ztv(ig,2))/ztv(ig,2)  &
+&                     *(zlev(ig,2)-zlev(ig,1))  &
+&                     *0.4*pphi(ig,1)/(pphi(ig,2)-pphi(ig,1))
+    w_est(ig,2)=zw2(ig,2)
+    endif
+enddo
+!
+
+!==============================================================================
+!boucle de calcul de la vitesse verticale dans le thermique
+!==============================================================================
+do l=2,klev-1
+!==============================================================================
+
+
+! On decide si le thermique est encore actif ou non
+! AFaire : Il faut sans doute ajouter entr_star a alim_star dans ce test
+    do ig=1,ngrid
+       active(ig)=active(ig) &
+&                 .and. zw2(ig,l)>1.e-10 &
+&                 .and. f_star(ig,l)+alim_star(ig,l)>1.e-10
+    enddo
+
+
+
+! Premier calcul de la vitesse verticale a partir de la temperature
+! potentielle virtuelle
+!     if (1.eq.1) then
+!         w_est(ig,3)=zw2(ig,2)* &
+!    &      ((f_star(ig,2))**2) &
+!    &      /(f_star(ig,2)+alim_star(ig,2))**2+ &
+!    &      2.*RG*(ztva(ig,2)-ztv(ig,2))/ztv(ig,2) &
+!    &      *(zlev(ig,3)-zlev(ig,2))
+!      endif
+
+
+!---------------------------------------------------------------------------
+! calcul des proprietes thermodynamiques et de la vitesse de la couche l
+! sans tenir compte du detrainement et de l'entrainement dans cette
+! couche
+! Ici encore, on doit pouvoir ajouter entr_star (qui peut etre calculer
+! avant) a l'alimentation pour avoir un calcul plus propre
+!---------------------------------------------------------------------------
+
+     call thermcell_condens(ngrid,active, &
+&          zpspsk(:,l),pplev(:,l),ztla(:,l-1),zqta(:,l-1),zqla_est(:,l))
+
+    do ig=1,ngrid
+        if(active(ig)) then
+        ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l)
+        zta_est(ig,l)=ztva_est(ig,l)
+        ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l)
+        ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1)  &
+     &      -zqla_est(ig,l))-zqla_est(ig,l))
+
+         if (1.eq.0) then 
+!calcul de w_est sans prendre en compte le drag 
+             w_est(ig,l+1)=zw2(ig,l)*  &
+     &                   ((f_star(ig,l))**2)  &
+     &                   /(f_star(ig,l)+alim_star(ig,l))**2+  &
+     &                   2.*RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+     &                   *(zlev(ig,l+1)-zlev(ig,l))
+         else
+
+           zdz=zlev(ig,l+1)-zlev(ig,l)
+           zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l))/rhobarz(ig,l)
+           zbuoy=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)
+           zdrag=fact_epsilon/(zalpha**expa)
+           zw2fact=zbuoy/zdrag*a1
+           w_est(ig,l+1)=(w_est(ig,l)-zw2fact)*exp(-2.*zdrag/(1+fact_gamma)*zdz) &
+      &    +zw2fact
+
+         endif
+
+             if (w_est(ig,l+1).lt.0.) then
+                w_est(ig,l+1)=zw2(ig,l)
+             endif
+       endif
+    enddo
+
+!-------------------------------------------------
+!calcul des taux d'entrainement et de detrainement
+!-------------------------------------------------
+
+     do ig=1,ngrid
+        if (active(ig)) then
+          zdz=zlev(ig,l+1)-zlev(ig,l)
+          zbuoy=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)
+ 
+! estimation de la fraction couverte par les thermiques
+          zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l))/rhobarz(ig,l)
+
+!calcul de la soumission papier 
+! Calcul  du taux d'entrainement entr_star (epsilon)
+           entr_star(ig,l)=f_star(ig,l)*zdz * (  zfact * MAX(0.,  &     
+     &     a1*zbuoy/w_est(ig,l+1) &
+     &     - fact_epsilon/zalpha**expa  ) &
+     &     +0. )
+           
+!calcul du taux de detrainment (delta)
+!           detr_star(ig,l)=f_star(ig,l)*zdz * (                           &
+!     &      MAX(1.e-3, &
+!     &      -fact_gamma2*a1*zbuoy/w_est(ig,l+1)        &
+!     &      +0.01*(max(zqta(ig,l-1)-po(ig,l),0.)/(po(ig,l))/(w_est(ig,l+1)))**0.5    &    
+!     &     +0. ))
+
+          m=0.5
+
+          detr_star(ig,l)=1.*f_star(ig,l)*zdz *                    &
+    &     MAX(5.e-4,-fact_gamma2*a1*(1./w_est(ig,l+1))*((1.-(1.-m)/(1.+70*zqta(ig,l-1)))*zbuoy        &
+    &     -40*(1.-m)*(max(zqta(ig,l-1)-po(ig,l),0.))/(1.+70*zqta(ig,l-1)) )   )
+
+!           detr_star(ig,l)=f_star(ig,l)*zdz * (                           &
+!     &      MAX(0.0, &
+!     &      -fact_gamma2*a1*zbuoy/w_est(ig,l+1)        &
+!     &      +20*(max(zqta(ig,l-1)-po(ig,l),0.))**1*(zalpha/w_est(ig,l+1))**0.5    &    
+!     &     +0. ))
+
+
+! En dessous de lalim, on prend le max de alim_star et entr_star pour
+! alim_star et 0 sinon
+        if (l.lt.lalim(ig)) then
+          alim_star(ig,l)=max(alim_star(ig,l),entr_star(ig,l))
+          entr_star(ig,l)=0.
+        endif
+
+!attention test
+!        if (detr_star(ig,l).gt.(f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l))) then       
+!            detr_star(ig,l)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)
+!        endif
+! Calcul du flux montant normalise
+      f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)  &
+     &              -detr_star(ig,l)
+
+      endif
+   enddo
+
+!----------------------------------------------------------------------------
+!calcul de la vitesse verticale en melangeant Tl et qt du thermique
+!---------------------------------------------------------------------------
+   activetmp(:)=active(:) .and. f_star(:,l+1)>1.e-10
+   do ig=1,ngrid
+       if (activetmp(ig)) then 
+           Zsat=.false.
+           ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+  &
+     &            (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l))  &
+     &            /(f_star(ig,l+1)+detr_star(ig,l))
+           zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+  &
+     &            (alim_star(ig,l)+entr_star(ig,l))*po(ig,l))  &
+     &            /(f_star(ig,l+1)+detr_star(ig,l))
+
+        endif
+    enddo
+
+   call thermcell_condens(ngrid,activetmp,zpspsk(:,l),pplev(:,l),ztla(:,l),zqta(:,l),zqla(:,l))
+
+
+   do ig=1,ngrid
+      if (activetmp(ig)) then
+! on ecrit de maniere conservative (sat ou non)
+!          T = Tl +Lv/Cp ql
+           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+!on rajoute le calcul de zha pour diagnostiques (temp potentielle)
+           zha(ig,l) = ztva(ig,l)
+           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)  &
+     &              -zqla(ig,l))-zqla(ig,l))
+
+!on ecrit zqsat 
+           zqsatth(ig,l)=qsatbef  
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!          zw2(ig,l+1)=&
+!     &                 zw2(ig,l)*(1-fact_epsilon/(1.+fact_gamma)*2.*(zlev(ig,l+1)-zlev(ig,l))) &
+!     &                 +2.*RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)  &
+!     &                 *1./(1.+fact_gamma) &
+!     &                 *(zlev(ig,l+1)-zlev(ig,l))
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! La meme en plus modulaire :
+           zbuoy=RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+           zdz=zlev(ig,l+1)-zlev(ig,l)
+
+
+           zeps=(entr_star(ig,l)+alim_star(ig,l))/(f_star(ig,l)*zdz)
+
+!if (1==0) then
+!           zw2modif=zw2(ig,l)*(1-fact_epsilon/(1.+fact_gamma)*2.*zdz)
+!           zdw2=2.*zbuoy/(1.+fact_gamma)*zdz
+!           zw2(ig,l+1)=zw2modif+zdw2
+!else
+           zdrag=fact_epsilon/(zalpha**expa)
+           zw2fact=zbuoy/zdrag*a1
+           zw2(ig,l+1)=(zw2(ig,l)-zw2fact)*exp(-2.*zdrag/(1+fact_gamma)*zdz) &
+      &    +zw2fact
+!endif
+
+      endif
+   enddo
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l
+!
+!---------------------------------------------------------------------------
+!initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max 
+!---------------------------------------------------------------------------
+
+   nbpb=0
+   do ig=1,ngrid
+            if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then
+!               stop'On tombe sur le cas particulier de thermcell_dry'
+!               print*,'On tombe sur le cas particulier de thermcell_plume'
+                nbpb=nbpb+1
+                zw2(ig,l+1)=0.
+                linter(ig)=l+1
+            endif
+
+        if (zw2(ig,l+1).lt.0.) then 
+           linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))  &
+     &               -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+           zw2(ig,l+1)=0.
+        endif
+
+           wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) 
+
+        if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!   lmix est le niveau de la couche ou w (wa_moy) est maximum
+!on rajoute le calcul de lmix_bis
+            if (zqla(ig,l).lt.1.e-10) then
+               lmix_bis(ig)=l+1
+            endif
+            lmix(ig)=l+1
+            wmaxa(ig)=wa_moy(ig,l+1)
+        endif
+   enddo
+
+   if (nbpb>0) then
+   print*,'WARNING on tombe ',nbpb,' x sur un pb pour l=',l,' dans thermcell_plume'
+   endif
+
+!=========================================================================
+! FIN DE LA BOUCLE VERTICALE
+      enddo
+!=========================================================================
+
+!on recalcule alim_star_tot
+       do ig=1,ngrid
+          alim_star_tot(ig)=0.
+       enddo
+       do ig=1,ngrid
+          do l=1,lalim(ig)-1
+          alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
+          enddo
+       enddo
+       
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l
+
+
+      return 
+      end
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ SUBROUTINE thermcellV1_plume(itap,ngrid,klev,ptimestep,ztv,zthl,po,zl,rhobarz,  &
+&           zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot,  &
+&           lalim,f0,detr_star,entr_star,f_star,csc,ztva,  &
+&           ztla,zqla,zqta,zha,zw2,w_est,ztva_est,zqsatth,lmix,lmix_bis,linter &
+&           ,lev_out,lunout1,igout)
+
+!--------------------------------------------------------------------------
+!thermcell_plume: calcule les valeurs de qt, thetal et w dans l ascendance
+! Version conforme a l'article de Rio et al. 2010.
+! Code ecrit par Catherine Rio, Arnaud Jam et Frederic Hourdin
+!--------------------------------------------------------------------------
+
+      IMPLICIT NONE
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+#include "iniprint.h"
+#include "thermcell.h"
+
+      INTEGER itap
+      INTEGER lunout1,igout
+      INTEGER ngrid,klev
+      REAL ptimestep
+      REAL ztv(ngrid,klev)
+      REAL zthl(ngrid,klev)
+      REAL po(ngrid,klev)
+      REAL zl(ngrid,klev)
+      REAL rhobarz(ngrid,klev)
+      REAL zlev(ngrid,klev+1)
+      REAL pplev(ngrid,klev+1)
+      REAL pphi(ngrid,klev)
+      REAL zpspsk(ngrid,klev)
+      REAL alim_star(ngrid,klev)
+      REAL f0(ngrid)
+      INTEGER lalim(ngrid)
+      integer lev_out                           ! niveau pour les print
+      integer nbpb
+    
+      real alim_star_tot(ngrid)
+
+      REAL ztva(ngrid,klev)
+      REAL ztla(ngrid,klev)
+      REAL zqla(ngrid,klev)
+      REAL zqta(ngrid,klev)
+      REAL zha(ngrid,klev)
+
+      REAL detr_star(ngrid,klev)
+      REAL coefc
+      REAL entr_star(ngrid,klev)
+      REAL detr(ngrid,klev)
+      REAL entr(ngrid,klev)
+
+      REAL csc(ngrid,klev)
+
+      REAL zw2(ngrid,klev+1)
+      REAL w_est(ngrid,klev+1)
+      REAL f_star(ngrid,klev+1)
+      REAL wa_moy(ngrid,klev+1)
+
+      REAL ztva_est(ngrid,klev)
+      REAL zqla_est(ngrid,klev)
+      REAL zqsatth(ngrid,klev)
+      REAL zta_est(ngrid,klev)
+      REAL ztemp(ngrid),zqsat(ngrid)
+      REAL zdw2
+      REAL zw2modif
+      REAL zw2fact
+      REAL zeps(ngrid,klev)
+
+      REAL linter(ngrid)
+      INTEGER lmix(ngrid)
+      INTEGER lmix_bis(ngrid)
+      REAL    wmaxa(ngrid)
+
+      INTEGER ig,l,k
+
+      real zdz,zbuoy(ngrid,klev),zalpha,gamma(ngrid,klev),zdqt(ngrid,klev),zw2m
+      real zbuoybis
+      real zcor,zdelta,zcvm5,qlbef,zdz2
+      real betalpha,zbetalpha
+      real eps, afact
+      REAL REPS,RLvCp,DDT0
+      PARAMETER (DDT0=.01)
+      logical Zsat
+      LOGICAL active(ngrid),activetmp(ngrid)
+      REAL fact_gamma,fact_epsilon,fact_gamma2,fact_epsilon2
+      REAL c2(ngrid,klev)
+      Zsat=.false.
+! Initialisation
+
+      RLvCp = RLVTT/RCPD
+      fact_epsilon=0.002
+      betalpha=0.9 
+      afact=2./3.            
+
+      zbetalpha=betalpha/(1.+betalpha)
+
+
+! Initialisations des variables reeles
+if (1==0) then
+      ztva(:,:)=ztv(:,:)
+      ztva_est(:,:)=ztva(:,:)
+      ztla(:,:)=zthl(:,:)
+      zqta(:,:)=po(:,:)
+      zha(:,:) = ztva(:,:)
+else
+      ztva(:,:)=0.
+      ztva_est(:,:)=0.
+      ztla(:,:)=0.
+      zqta(:,:)=0.
+      zha(:,:) =0.
+endif
+
+      zqla_est(:,:)=0.
+      zqsatth(:,:)=0.
+      zqla(:,:)=0.
+      detr_star(:,:)=0.
+      entr_star(:,:)=0.
+      alim_star(:,:)=0.
+      alim_star_tot(:)=0.
+      csc(:,:)=0.
+      detr(:,:)=0.
+      entr(:,:)=0.
+      zw2(:,:)=0.
+      zbuoy(:,:)=0.
+      gamma(:,:)=0.
+      zeps(:,:)=0.
+      w_est(:,:)=0.
+      f_star(:,:)=0.
+      wa_moy(:,:)=0.
+      linter(:)=1.
+!     linter(:)=1.
+! Initialisation des variables entieres
+      lmix(:)=1
+      lmix_bis(:)=2
+      wmaxa(:)=0.
+      lalim(:)=1
+
+
+!-------------------------------------------------------------------------
+! On ne considere comme actif que les colonnes dont les deux premieres
+! couches sont instables.
+!-------------------------------------------------------------------------
+      active(:)=ztv(:,1)>ztv(:,2)
+
+!-------------------------------------------------------------------------
+! Definition de l'alimentation a l'origine dans thermcell_init
+!-------------------------------------------------------------------------
+      do l=1,klev-1
+         do ig=1,ngrid
+            if (ztv(ig,l)> ztv(ig,l+1) .and. ztv(ig,1)>=ztv(ig,l) ) then
+               alim_star(ig,l)=MAX((ztv(ig,l)-ztv(ig,l+1)),0.)  &
+     &                       *sqrt(zlev(ig,l+1)) 
+               lalim(ig)=l+1
+               alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
+            endif
+         enddo
+      enddo
+      do l=1,klev
+         do ig=1,ngrid 
+            if (alim_star_tot(ig) > 1.e-10 ) then
+               alim_star(ig,l)=alim_star(ig,l)/alim_star_tot(ig)
+            endif
+         enddo
+      enddo
+      alim_star_tot(:)=1.
+
+
+
+!------------------------------------------------------------------------------
+! Calcul dans la premiere couche
+! On decide dans cette version que le thermique n'est actif que si la premiere
+! couche est instable.
+! Pourrait etre change si on veut que le thermiques puisse se dÃ©clencher
+! dans une couche l>1
+!------------------------------------------------------------------------------
+do ig=1,ngrid
+! Le panache va prendre au debut les caracteristiques de l'air contenu
+! dans cette couche.
+    if (active(ig)) then
+    ztla(ig,1)=zthl(ig,1) 
+    zqta(ig,1)=po(ig,1)
+    zqla(ig,1)=zl(ig,1)
+!cr: attention, prise en compte de f*(1)=1
+    f_star(ig,2)=alim_star(ig,1)
+    zw2(ig,2)=2.*RG*(ztv(ig,1)-ztv(ig,2))/ztv(ig,2)  &
+&                     *(zlev(ig,2)-zlev(ig,1))  &
+&                     *0.4*pphi(ig,1)/(pphi(ig,2)-pphi(ig,1))
+    w_est(ig,2)=zw2(ig,2)
+    endif
+enddo
+!
+
+!==============================================================================
+!boucle de calcul de la vitesse verticale dans le thermique
+!==============================================================================
+do l=2,klev-1
+!==============================================================================
+
+
+! On decide si le thermique est encore actif ou non
+! AFaire : Il faut sans doute ajouter entr_star a alim_star dans ce test
+    do ig=1,ngrid
+       active(ig)=active(ig) &
+&                 .and. zw2(ig,l)>1.e-10 &
+&                 .and. f_star(ig,l)+alim_star(ig,l)>1.e-10
+    enddo
+
+
+
+!---------------------------------------------------------------------------
+! calcul des proprietes thermodynamiques et de la vitesse de la couche l
+! sans tenir compte du detrainement et de l'entrainement dans cette
+! couche
+! C'est a dire qu'on suppose 
+! ztla(l)=ztla(l-1) et zqta(l)=zqta(l-1)
+! Ici encore, on doit pouvoir ajouter entr_star (qui peut etre calculer
+! avant) a l'alimentation pour avoir un calcul plus propre
+!---------------------------------------------------------------------------
+
+   ztemp(:)=zpspsk(:,l)*ztla(:,l-1)
+   call thermcell_qsat(ngrid,active,pplev(:,l),ztemp,zqta(:,l-1),zqsat(:))
+
+    do ig=1,ngrid 
+!       print*,'active',active(ig),ig,l
+        if(active(ig)) then 
+        zqla_est(ig,l)=max(0.,zqta(ig,l-1)-zqsat(ig))
+        ztva_est(ig,l) = ztla(ig,l-1)*zpspsk(ig,l)+RLvCp*zqla_est(ig,l)
+        zta_est(ig,l)=ztva_est(ig,l)
+        ztva_est(ig,l) = ztva_est(ig,l)/zpspsk(ig,l)
+        ztva_est(ig,l) = ztva_est(ig,l)*(1.+RETV*(zqta(ig,l-1)  &
+     &      -zqla_est(ig,l))-zqla_est(ig,l))
+
+!------------------------------------------------
+!AJAM:nouveau calcul de w²  
+!------------------------------------------------
+              zdz=zlev(ig,l+1)-zlev(ig,l)
+              zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)
+
+              zw2fact=fact_epsilon*2.*zdz/(1.+betalpha)
+              zdw2=(afact)*zbuoy(ig,l)/(fact_epsilon)
+              w_est(ig,l+1)=Max(0.0001,exp(-zw2fact)*(w_est(ig,l)-zdw2)+zdw2)
+ 
+
+             if (w_est(ig,l+1).lt.0.) then
+                w_est(ig,l+1)=zw2(ig,l)
+             endif
+       endif
+    enddo
+
+
+!-------------------------------------------------
+!calcul des taux d'entrainement et de detrainement
+!-------------------------------------------------
+
+     do ig=1,ngrid
+        if (active(ig)) then
+
+          zw2m=max(0.5*(w_est(ig,l)+w_est(ig,l+1)),0.1)
+          zw2m=w_est(ig,l+1)
+          zdz=zlev(ig,l+1)-zlev(ig,l)
+          zbuoy(ig,l)=RG*(ztva_est(ig,l)-ztv(ig,l))/ztv(ig,l)
+!          zbuoybis=zbuoy(ig,l)+RG*0.1/300.
+          zbuoybis=zbuoy(ig,l)
+          zalpha=f0(ig)*f_star(ig,l)/sqrt(w_est(ig,l+1))/rhobarz(ig,l)
+          zdqt(ig,l)=max(zqta(ig,l-1)-po(ig,l),0.)/po(ig,l)
+
+          
+          entr_star(ig,l)=f_star(ig,l)*zdz*  zbetalpha*MAX(0.,  &
+    &     afact*zbuoybis/zw2m - fact_epsilon )
+
+
+          detr_star(ig,l)=f_star(ig,l)*zdz                        &
+    &     *MAX(1.e-3, -afact*zbetalpha*zbuoy(ig,l)/zw2m          &
+    &     + 0.012*(zdqt(ig,l)/zw2m)**0.5 )
+          
+! En dessous de lalim, on prend le max de alim_star et entr_star pour
+! alim_star et 0 sinon
+        if (l.lt.lalim(ig)) then
+          alim_star(ig,l)=max(alim_star(ig,l),entr_star(ig,l))
+          entr_star(ig,l)=0.
+        endif
+
+! Calcul du flux montant normalise
+      f_star(ig,l+1)=f_star(ig,l)+alim_star(ig,l)+entr_star(ig,l)  &
+     &              -detr_star(ig,l)
+
+      endif
+   enddo
+
+
+!----------------------------------------------------------------------------
+!calcul de la vitesse verticale en melangeant Tl et qt du thermique
+!---------------------------------------------------------------------------
+   activetmp(:)=active(:) .and. f_star(:,l+1)>1.e-10
+   do ig=1,ngrid
+       if (activetmp(ig)) then 
+           Zsat=.false.
+           ztla(ig,l)=(f_star(ig,l)*ztla(ig,l-1)+  &
+     &            (alim_star(ig,l)+entr_star(ig,l))*zthl(ig,l))  &
+     &            /(f_star(ig,l+1)+detr_star(ig,l))
+           zqta(ig,l)=(f_star(ig,l)*zqta(ig,l-1)+  &
+     &            (alim_star(ig,l)+entr_star(ig,l))*po(ig,l))  &
+     &            /(f_star(ig,l+1)+detr_star(ig,l))
+
+        endif
+    enddo
+
+   ztemp(:)=zpspsk(:,l)*ztla(:,l)
+   call thermcell_qsat(ngrid,activetmp,pplev(:,l),ztemp,zqta(:,l),zqsatth(:,l))
+
+   do ig=1,ngrid
+      if (activetmp(ig)) then
+! on ecrit de maniere conservative (sat ou non)
+!          T = Tl +Lv/Cp ql
+           zqla(ig,l)=max(0.,zqta(ig,l)-zqsatth(ig,l))
+           ztva(ig,l) = ztla(ig,l)*zpspsk(ig,l)+RLvCp*zqla(ig,l)
+           ztva(ig,l) = ztva(ig,l)/zpspsk(ig,l)
+!on rajoute le calcul de zha pour diagnostiques (temp potentielle)
+           zha(ig,l) = ztva(ig,l)
+           ztva(ig,l) = ztva(ig,l)*(1.+RETV*(zqta(ig,l)  &
+     &              -zqla(ig,l))-zqla(ig,l))
+           zbuoy(ig,l)=RG*(ztva(ig,l)-ztv(ig,l))/ztv(ig,l)
+           zdz=zlev(ig,l+1)-zlev(ig,l)
+           zeps(ig,l)=(entr_star(ig,l)+alim_star(ig,l))/(f_star(ig,l)*zdz)
+
+            zw2fact=fact_epsilon*2.*zdz/(1.+betalpha)
+            zdw2=afact*zbuoy(ig,l)/(fact_epsilon)
+            zw2(ig,l+1)=Max(0.0001,exp(-zw2fact)*(zw2(ig,l)-zdw2)+zdw2) 
+      endif
+   enddo
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 460: ig, l',ig, l
+!
+!---------------------------------------------------------------------------
+!initialisations pour le calcul de la hauteur du thermique, de l'inversion et de la vitesse verticale max 
+!---------------------------------------------------------------------------
+
+   nbpb=0
+   do ig=1,ngrid
+            if (zw2(ig,l+1)>0. .and. zw2(ig,l+1).lt.1.e-10) then
+!               stop'On tombe sur le cas particulier de thermcell_dry'
+!               print*,'On tombe sur le cas particulier de thermcell_plume'
+                nbpb=nbpb+1
+                zw2(ig,l+1)=0.
+                linter(ig)=l+1
+            endif
+
+        if (zw2(ig,l+1).lt.0.) then 
+           linter(ig)=(l*(zw2(ig,l+1)-zw2(ig,l))  &
+     &               -zw2(ig,l))/(zw2(ig,l+1)-zw2(ig,l))
+           zw2(ig,l+1)=0.
+        endif
+
+           wa_moy(ig,l+1)=sqrt(zw2(ig,l+1)) 
+
+        if (wa_moy(ig,l+1).gt.wmaxa(ig)) then
+!   lmix est le niveau de la couche ou w (wa_moy) est maximum
+!on rajoute le calcul de lmix_bis
+            if (zqla(ig,l).lt.1.e-10) then
+               lmix_bis(ig)=l+1
+            endif
+            lmix(ig)=l+1
+            wmaxa(ig)=wa_moy(ig,l+1)
+        endif
+   enddo
+
+   if (nbpb>0) then
+   print*,'WARNING on tombe ',nbpb,' x sur un pb pour l=',l,' dans thermcell_plume'
+   endif
+
+!=========================================================================
+! FIN DE LA BOUCLE VERTICALE
+      enddo
+!=========================================================================
+
+!on recalcule alim_star_tot
+       do ig=1,ngrid
+          alim_star_tot(ig)=0.
+       enddo
+       do ig=1,ngrid
+          do l=1,lalim(ig)-1
+          alim_star_tot(ig)=alim_star_tot(ig)+alim_star(ig,l)
+          enddo
+       enddo
+       
+
+        if (prt_level.ge.20) print*,'coucou calcul detr 470: ig, l', ig, l
+
+#undef wrgrads_thermcell
+#ifdef wrgrads_thermcell
+         call wrgradsfi(1,klev,entr_star(igout,1:klev),'esta      ','esta      ')
+         call wrgradsfi(1,klev,detr_star(igout,1:klev),'dsta      ','dsta      ')
+         call wrgradsfi(1,klev,zbuoy(igout,1:klev),'buoy      ','buoy      ')
+         call wrgradsfi(1,klev,zdqt(igout,1:klev),'dqt      ','dqt      ')
+         call wrgradsfi(1,klev,w_est(igout,1:klev),'w_est     ','w_est     ')
+         call wrgradsfi(1,klev,w_est(igout,2:klev+1),'w_es2     ','w_es2     ')
+         call wrgradsfi(1,klev,zw2(igout,1:klev),'zw2A      ','zw2A      ')
+#endif
+
+
+     return 
+     end
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_qsat.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_qsat.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/thermcell_qsat.F90	(revision 17)
@@ -0,0 +1,92 @@
+subroutine thermcell_qsat(klon,active,pplev,ztemp,zqta,zqsat)
+implicit none
+
+#include "YOMCST.h"
+#include "YOETHF.h"
+#include "FCTTRE.h"
+
+
+!====================================================================
+! DECLARATIONS
+!====================================================================
+
+! Arguments
+INTEGER klon
+REAL zpspsk(klon),pplev(klon)
+REAL ztemp(klon),zqta(klon),zqsat(klon)
+LOGICAL active(klon)
+
+! Variables locales
+INTEGER ig,iter
+REAL Tbef(klon),DT(klon)
+REAL tdelta,qsatbef,zcor,qlbef,zdelta,zcvm5,dqsat,num,denom,dqsat_dT
+logical Zsat
+REAL RLvCp
+REAL, SAVE :: DDT0=.01
+LOGICAL afaire(klon),tout_converge
+
+!====================================================================
+! INITIALISATIONS
+!====================================================================
+
+RLvCp = RLVTT/RCPD
+tout_converge=.false.
+afaire(:)=.false.
+DT(:)=0.
+
+
+!====================================================================
+! Routine a vectoriser en copiant active dans converge et en mettant
+! la boucle sur les iterations a l'exterieur est en mettant
+! converge= false des que la convergence est atteinte.
+!====================================================================
+
+do ig=1,klon
+   if (active(ig)) then
+               Tbef(ig)=ztemp(ig)
+               zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+               qsatbef= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig)
+               qsatbef=MIN(0.5,qsatbef)
+               zcor=1./(1.-retv*qsatbef)
+               qsatbef=qsatbef*zcor
+               qlbef=max(0.,zqta(ig)-qsatbef)
+               DT(ig) = 0.5*RLvCp*qlbef
+               zqsat(ig)=qsatbef
+     endif
+enddo
+
+! Traitement du cas ou il y a condensation mais faible
+! On ne condense pas mais on dit que le qsat est le qta
+do ig=1,klon
+   if (active(ig)) then
+      if (0.<abs(DT(ig)).and.abs(DT(ig))<=DDT0) then
+         zqsat(ig)=zqta(ig)
+      endif
+   endif
+enddo
+
+do iter=1,10
+    afaire(:)=abs(DT(:)).gt.DDT0
+    do ig=1,klon
+               if (afaire(ig)) then
+                 Tbef(ig)=Tbef(ig)+DT(ig)
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 qsatbef= R2ES * FOEEW(Tbef(ig),zdelta)/pplev(ig)
+                 qsatbef=MIN(0.5,qsatbef)
+                 zcor=1./(1.-retv*qsatbef)
+                 qsatbef=qsatbef*zcor
+                 qlbef=zqta(ig)-qsatbef
+                 zdelta=MAX(0.,SIGN(1.,RTT-Tbef(ig)))
+                 zcvm5=R5LES*(1.-zdelta) + R5IES*zdelta
+                 zcor=1./(1.-retv*qsatbef)
+                 dqsat_dT=FOEDE(Tbef(ig),zdelta,zcvm5,qsatbef,zcor)
+                 num=-Tbef(ig)+ztemp(ig)+RLvCp*qlbef
+                 denom=1.+RLvCp*dqsat_dT
+                 zqsat(ig) = qsatbef
+                 DT(ig)=num/denom
+               endif
+    enddo
+enddo
+
+return
+end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/traceur.def
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/traceur.def	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/traceur.def	(revision 17)
@@ -0,0 +1,4 @@
+3
+14 14 H2Ov
+10 10 H2Ol
+10 10 FAKE
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/tracinca_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/tracinca_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/tracinca_mod.F90	(revision 17)
@@ -0,0 +1,192 @@
+!$Id $
+!
+MODULE tracinca_mod
+!
+! This module prepares and calls the INCA main subroutines. 
+!
+
+CONTAINS
+
+  SUBROUTINE tracinca_init(aerosol,lessivage)
+    ! This subroutine initialize some control varaibles. 
+
+    USE infotrac
+    IMPLICIT NONE
+    
+    ! Output variables
+    LOGICAL,DIMENSION(nbtr), INTENT(OUT) :: aerosol
+    LOGICAL,INTENT(OUT) :: lessivage
+    
+    
+    ! Initialization
+    lessivage  =.FALSE.
+    aerosol(:) = .FALSE.
+        
+  END SUBROUTINE tracinca_init
+
+  SUBROUTINE tracinca(                                &
+       nstep,    julien,   gmtime,         lafin,     &
+       pdtphys,  t_seri,   paprs,          pplay,     &
+       pmfu,     ftsol,    pctsrf,         pphis,     &
+       pphi,     albsol,   sh,             rh,        &
+       cldfra,   rneb,     diafra,         cldliq,    &
+       itop_con, ibas_con, pmflxr,         pmflxs,    &
+       prfl,     psfl,     aerosol_couple, flxmass_w, &
+       tau_aero, piz_aero, cg_aero,        ccm,       &
+       rfname,                                        &
+       tr_seri,  source,   solsym)      
+
+!========================================================
+!    -- CHIMIE INCA --
+!========================================================
+
+    USE dimphy
+    USE infotrac
+    USE vampir
+    USE comgeomphy
+    USE control_mod
+    USE indice_sol_mod
+
+    
+    IMPLICIT NONE
+    
+    INCLUDE "dimensions.h"
+    INCLUDE "paramet.h"
+
+!==========================================================================
+!                   -- DESCRIPTION DES ARGUMENTS --
+!==========================================================================
+
+
+! EN ENTREE ...
+!
+!Configuration grille,temps:
+    INTEGER,INTENT(IN) :: nstep      ! Appel physique
+    INTEGER,INTENT(IN) :: julien     ! Jour julien
+    REAL,INTENT(IN)    :: gmtime
+    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
+    LOGICAL,INTENT(IN) :: lafin      ! le flag de la fin de la physique
+    
+
+!Physique: 
+!--------
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: rh      ! humidite relative
+    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pphi    ! geopotentiel
+    REAL,DIMENSION(klon),INTENT(IN)        :: pphis
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: cldliq  ! eau liquide nuageuse
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: cldfra  ! fraction nuageuse (tous les nuages)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: diafra  ! fraction nuageuse (convection ou stratus artificiels)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: rneb    ! fraction nuageuse (grande echelle)
+    INTEGER,DIMENSION(klon),INTENT(IN)     :: itop_con
+    INTEGER,DIMENSION(klon),INTENT(IN)     :: ibas_con
+    REAL,DIMENSION(klon),INTENT(IN)        :: albsol  ! albedo surface
+!
+!Convection:
+!----------
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: pmfu  ! flux de masse dans le panache montant
+
+!...Tiedke     
+    REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: pmflxr, pmflxs ! Flux precipitant de pluie, neige aux interfaces [convection]
+    REAL,DIMENSION(klon,klev+1),INTENT(IN)   :: prfl, psfl ! Flux precipitant de pluie, neige aux interfaces [large-scale]
+
+    LOGICAL,INTENT(IN)                       :: aerosol_couple
+    REAL,DIMENSION(klon,klev),INTENT(IN)     :: flxmass_w
+    REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: tau_aero
+    REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: piz_aero
+    REAL,DIMENSION(klon,klev,9,2),INTENT(IN) :: cg_aero
+    CHARACTER(len=4),DIMENSION(9),INTENT(IN) :: rfname 
+    REAL,DIMENSION(klon,klev,2),INTENT(IN)   :: ccm 
+
+! Arguments necessaires pour les sources et puits de traceur:
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol  ! Temperature du sol (surf)(Kelvin)
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol f(nature du sol)
+
+
+  ! InOutput argument
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri ! Concentration Traceur [U/KgA]  
+
+  ! Output arguments
+    REAL,DIMENSION(klon,nbtr), INTENT(OUT)        :: source  ! a voir lorsque le flux de surface est prescrit 
+    CHARACTER(len=8),DIMENSION(nbtr), INTENT(OUT) :: solsym
+
+!=======================================================================================
+!                        -- VARIABLES LOCALES TRACEURS --
+!=======================================================================================
+
+    INTEGER :: k
+    REAL,DIMENSION(klon,klev) :: pdel
+    REAL    :: calday
+    INTEGER :: ncsec
+
+    CALL VTe(VTphysiq)
+    CALL VTb(VTinca)
+    
+    calday = REAL(julien) + gmtime
+    ncsec  = NINT (86400.*gmtime)
+     
+    DO k = 1, klev
+       pdel(:,k) = paprs(:,k) - paprs (:,k+1)
+    END DO
+    
+    IF (config_inca == 'aero') THEN
+#ifdef INCA
+       CALL aerosolmain(                    &
+            aerosol_couple,tr_seri,pdtphys, &
+            pplay,pdel,prfl,pmflxr,psfl,    &
+            pmflxs,pmfu,itop_con,ibas_con,  &
+            pphi,airephy,nstep,rneb,t_seri, &      
+            rh,tau_aero,piz_aero,cg_aero,   &
+            rfname,ccm,lafin)
+#endif
+    END IF
+
+#ifdef INCA
+    CALL chemmain (tr_seri, &   !mmr
+         nstep,      & !nstep
+         calday,     & !calday
+         julien,     & !ncdate
+         ncsec,      & !ncsec
+         1,          & !lat
+         pdtphys,    & !delt
+         paprs(1,1), & !ps
+         pplay,      & !pmid
+         pdel,       & !pdel
+         airephy,    &
+         pctsrf(1,1),& !oro
+         ftsol,      & !tsurf
+         albsol,     & !albs
+         pphi,       & !zma
+         pphis,      & !phis
+         cldfra,     & !cldfr
+         rneb,       & !cldfr_st
+         diafra,     & !cldfr_cv
+         itop_con,   & !cldtop
+         ibas_con,   & !cldbot
+         cldliq,     & !cwat
+         prfl,       & !flxrst
+         pmflxr,     & !flxrcv
+         psfl,       & !flxsst
+         pmflxs,     & !flxscv
+         pmfu,       & !flxupd
+         flxmass_w,  & !flxmass_w
+         t_seri,     & !tfld
+         sh,         & !sh
+         rh,         & !rh
+         iip1,       & !nx
+         jjp1,       & !ny
+         source,     &
+         solsym)
+#endif
+    
+    CALL VTe(VTinca)
+    CALL VTb(VTphysiq)
+    
+    
+  END SUBROUTINE tracinca
+
+
+END MODULE tracinca_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/traclmdz_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/traclmdz_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/traclmdz_mod.F90	(revision 17)
@@ -0,0 +1,644 @@
+!$Id $
+!
+MODULE traclmdz_mod
+
+! 
+! In this module all tracers specific to LMDZ are treated. This module is used 
+! only if running without any other chemestry model as INCA or REPROBUS.  
+!
+  IMPLICIT NONE
+
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: masktr   ! Masque reservoir de sol traceur
+!$OMP THREADPRIVATE(masktr)                        ! Masque de l'echange avec la surface (1 = reservoir) ou (possible >= 1 )
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: fshtr    ! Flux surfacique dans le reservoir de sol
+!$OMP THREADPRIVATE(fshtr)
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE   :: hsoltr   ! Epaisseur equivalente du reservoir de sol
+!$OMP THREADPRIVATE(hsoltr)
+!
+!Radioelements:
+!--------------
+!
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE   :: tautr    ! Constante de decroissance radioactive
+!$OMP THREADPRIVATE(tautr)
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE   :: vdeptr   ! Vitesse de depot sec dans la couche Brownienne
+!$OMP THREADPRIVATE(vdeptr)
+  REAL,DIMENSION(:),ALLOCATABLE,SAVE   :: scavtr   ! Coefficient de lessivage
+!$OMP THREADPRIVATE(scavtr)
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: srcbe    ! Production du beryllium7 dans l atmosphere (U/s/kgA)
+!$OMP THREADPRIVATE(srcbe)
+
+  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: radio    ! radio(it)   = true  => decroisssance radioactive
+!$OMP THREADPRIVATE(radio)  
+
+  REAL,DIMENSION(:,:),ALLOCATABLE,SAVE :: trs     ! Conc. radon ds le sol
+!$OMP THREADPRIVATE(trs)
+
+  INTEGER,SAVE :: id_aga      ! Identification number for tracer : Age of stratospheric air
+!$OMP THREADPRIVATE(id_aga)
+  INTEGER,SAVE :: lev_1p5km   ! Approximative vertical layer number at 1.5km above surface, used for calculation of the age of air. The result shouldn't be that sensible to the exactness of this value as long as it is in the lower troposphere. 
+!$OMP THREADPRIVATE(lev_1p5km)
+
+  INTEGER,SAVE :: id_rn, id_pb ! Identification number for tracer : radon (Rn222), lead (Pb210)
+!$OMP THREADPRIVATE(id_rn, id_pb)
+
+  INTEGER,SAVE :: id_be       ! Activation et position du traceur Be7 [ id_be=0 -> desactive ] 
+!$OMP THREADPRIVATE(id_be)
+
+  INTEGER,SAVE :: id_pcsat, id_pcocsat, id_pcq ! traceurs pseudo-vapeur CL qsat, qsat_oc, q
+!$OMP THREADPRIVATE(id_pcsat, id_pcocsat, id_pcq)
+  INTEGER,SAVE :: id_pcs0, id_pcos0, id_pcq0   ! traceurs pseudo-vapeur CL qsat, qsat_oc, q
+!                                              ! qui ne sont pas transportes par la convection
+!$OMP THREADPRIVATE(id_pcs0, id_pcos0, id_pcq0)
+
+  INTEGER, SAVE:: id_o3
+!$OMP THREADPRIVATE(id_o3)
+! index of ozone tracer with Cariolle parameterization
+! 0 means no ozone tracer
+
+  LOGICAL,SAVE :: rnpb=.FALSE. ! Presence du couple Rn222, Pb210
+!$OMP THREADPRIVATE(rnpb)
+
+
+CONTAINS
+
+  SUBROUTINE traclmdz_from_restart(trs_in)
+    ! This subroutine initialize the module saved variable trs with values from restart file (startphy.nc). 
+    ! This subroutine is called from phyetat0 after the field trs_in has been read.
+    
+    USE dimphy
+    USE infotrac
+    
+    ! Input argument
+    REAL,DIMENSION(klon,nbtr), INTENT(IN) :: trs_in 
+    
+    ! Local variables
+    INTEGER :: ierr
+    
+    ! Allocate restart variables trs
+    ALLOCATE( trs(klon,nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('traclmdz_from_restart', 'pb in allocation 1',1)
+    
+    ! Initialize trs with values read from restart file 
+    trs(:,:) = trs_in(:,:)
+    
+  END SUBROUTINE traclmdz_from_restart
+
+
+  SUBROUTINE traclmdz_init(pctsrf, xlat, xlon, ftsol, tr_seri, t_seri, pplay, sh, pdtphys, aerosol, lessivage)
+    ! This subroutine allocates and initialize module variables and control variables.
+    ! Initialization of the tracers should be done here only for those not found in the restart file.
+    USE dimphy
+    USE infotrac
+    USE regr_pr_comb_coefoz_m, ONLY: alloc_coefoz
+    USE press_coefoz_m, ONLY: press_coefoz
+    USE carbon_cycle_mod, ONLY : carbon_cycle_init, carbon_cycle_tr, carbon_cycle_cpl
+    USE mod_grid_phy_lmdz
+    USE mod_phys_lmdz_para
+    USE indice_sol_mod
+
+    INCLUDE "iniprint.h"
+! Input variables
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN)     :: pctsrf ! Pourcentage de sol f(nature du sol)
+    REAL,DIMENSION(klon),INTENT(IN)           :: xlat   ! latitudes en degres pour chaque point 
+    REAL,DIMENSION(klon),INTENT(IN)           :: xlon   ! longitudes en degres pour chaque point 
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN)     :: ftsol  ! Temperature du sol (surf)(Kelvin)
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT) :: tr_seri! Concentration Traceur [U/KgA]  
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique
+    REAL,INTENT(IN)                        :: pdtphys ! Pas d'integration pour la physique (seconde)  
+
+! Output variables
+    LOGICAL,DIMENSION(nbtr), INTENT(OUT) :: aerosol
+    LOGICAL,INTENT(OUT)                  :: lessivage
+        
+! Local variables    
+    INTEGER :: ierr, it, iiq, i, k
+    REAL, DIMENSION(klon_glo,klev) :: varglo ! variable temporaire sur la grille global    
+    REAL, DIMENSION(klev)          :: mintmp, maxtmp
+    LOGICAL                        :: zero
+! RomP >>> profil initial Be7
+      integer ilesfil
+      parameter (ilesfil=1)
+      integer  irr,kradio
+      real     beryllium(klon,klev)
+! profil initial Pb210
+      integer ilesfil2
+      parameter (ilesfil2=1)
+      integer  irr2,kradio2
+      real     plomb(klon,klev)
+!! RomP <<<
+! --------------------------------------------
+! Allocation
+! --------------------------------------------
+    ALLOCATE( scavtr(nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 9',1)
+    scavtr(:)=1.
+    
+    ALLOCATE( radio(nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 11',1)
+    radio(:) = .false.    ! Par defaut pas decroissance radioactive
+    
+    ALLOCATE( masktr(klon,nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 2',1)
+    
+    ALLOCATE( fshtr(klon,nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 3',1)
+    
+    ALLOCATE( hsoltr(nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 4',1)
+    
+    ALLOCATE( tautr(nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 5',1)
+    tautr(:)  = 0.
+    
+    ALLOCATE( vdeptr(nbtr), stat=ierr)
+    IF (ierr /= 0) CALL abort_gcm('traclmdz_init', 'pb in allocation 6',1)
+    vdeptr(:) = 0.
+
+
+    lessivage  = .TRUE.
+!!jyg(20130206) : le choix d activation du lessivage est fait dans phytrac avec iflag_lscav
+!!    call getin('lessivage',lessivage)
+!!    if(lessivage) then
+!!     print*,'lessivage lsc ON'
+!!    else
+!!     print*,'lessivage lsc OFF'
+!!    endif
+    aerosol(:) = .FALSE.  ! Tous les traceurs sont des gaz par defaut
+    
+!
+! Recherche des traceurs connus : Be7, O3, CO2,...
+! --------------------------------------------
+    id_rn=0; id_pb=0; id_aga=0; id_be=0; id_o3=0
+    id_pcsat=0; id_pcocsat=0; id_pcq=0; id_pcs0=0; id_pcos0=0; id_pcq0=0
+    DO it=1,nbtr
+       iiq=niadv(it+2)
+       IF ( tname(iiq) == "RN" ) THEN
+          id_rn=it ! radon
+       ELSE IF ( tname(iiq) == "PB") THEN
+          id_pb=it ! plomb
+! RomP >>> profil initial de PB210 
+     open (ilesfil2,file='prof.pb210',status='old',iostat=irr2)
+     IF (irr2 == 0) THEN 
+      read(ilesfil2,*) kradio2
+      print*,'number of levels for pb210 profile ',kradio2
+      do k=kradio2,1,-1
+       read (ilesfil2,*) plomb(:,k)
+      enddo
+      close(ilesfil2)
+      do k=1,klev
+       do i=1,klon
+         tr_seri(i,k,id_pb)=plomb(i,k)
+!!        print*, 'tr_seri',i,k,tr_seri(i,k,id_pb)
+        enddo
+      enddo
+     ELSE
+       print *, 'Prof.pb210 does not exist: use restart values'
+     ENDIF
+! RomP <<<
+       ELSE IF ( tname(iiq) == "Aga" .OR. tname(iiq) == "AGA" ) THEN
+          ! Age of stratospheric air
+          id_aga=it
+          radio(id_aga) = .FALSE.
+          aerosol(id_aga) = .FALSE.
+          pbl_flg(id_aga) = 0 
+          
+          ! Find the first model layer above 1.5km from the surface
+          IF (klev>=30) THEN
+             lev_1p5km=6   ! NB! This value is for klev=39
+          ELSE IF (klev>=10) THEN
+             lev_1p5km=5   ! NB! This value is for klev=19
+          ELSE
+             lev_1p5km=klev/2
+          END IF
+       ELSE IF ( tname(iiq) == "BE" .OR. tname(iiq) == "Be" .OR.  &
+            tname(iiq) == "BE7" .OR. tname(iiq) == "Be7" ) THEN  
+          ! Recherche du Beryllium 7
+          id_be=it
+          ALLOCATE( srcbe(klon,klev) )
+          radio(id_be) = .TRUE.
+          aerosol(id_be) = .TRUE. ! le Be est un aerosol
+!jyg le 13/03/2013 ; ajout de pplay en argument de init_be
+!!!          CALL init_be(pctsrf,masktr(:,id_be),tautr(id_be),vdeptr(id_be),scavtr(id_be),srcbe)
+          CALL init_be(pctsrf,pplay,masktr(:,id_be),tautr(id_be),vdeptr(id_be),scavtr(id_be),srcbe)
+          WRITE(lunout,*) 'Initialisation srcBe: OK'
+! RomP >>> profil initial de Be7
+      open (ilesfil,file='prof.be7',status='old',iostat=irr)
+      IF (irr == 0) THEN 
+       read(ilesfil,*) kradio
+       print*,'number of levels for Be7 profile ',kradio
+       do k=kradio,1,-1
+        read (ilesfil,*) beryllium(:,k)
+       enddo
+       close(ilesfil)
+       do k=1,klev
+         do i=1,klon
+          tr_seri(i,k,id_be)=beryllium(i,k)
+!!        print*, 'tr_seri',i,k,tr_seri(i,k,id_be)
+         enddo
+       enddo
+     ELSE
+       print *, 'Prof.Be7 does not exist: use restart values'
+     ENDIF
+! RomP <<<
+       ELSE IF (tname(iiq)=="O3" .OR. tname(iiq)=="o3") THEN
+          ! Recherche de l'ozone : parametrization de la chimie par Cariolle
+          id_o3=it
+          CALL alloc_coefoz   ! allocate ozone coefficients
+          CALL press_coefoz   ! read input pressure levels
+       ELSE IF ( tname(iiq) == "pcsat" .OR. tname(iiq) == "Pcsat" ) THEN
+          id_pcsat=it
+       ELSE IF ( tname(iiq) == "pcocsat" .OR. tname(iiq) == "Pcocsat" ) THEN
+          id_pcocsat=it
+       ELSE IF ( tname(iiq) == "pcq" .OR. tname(iiq) == "Pcq" ) THEN
+          id_pcq=it
+       ELSE IF ( tname(iiq) == "pcs0" .OR. tname(iiq) == "Pcs0" ) THEN
+          id_pcs0=it
+          conv_flg(it)=0 ! No transport by convection for this tracer
+       ELSE IF ( tname(iiq) == "pcos0" .OR. tname(iiq) == "Pcos0" ) THEN
+          id_pcos0=it
+          conv_flg(it)=0 ! No transport by convection for this tracer
+       ELSE IF ( tname(iiq) == "pcq0" .OR. tname(iiq) == "Pcq0" ) THEN
+          id_pcq0=it
+          conv_flg(it)=0 ! No transport by convection for this tracer
+       ELSE
+          WRITE(lunout,*) 'This is an unknown tracer in LMDZ : ', trim(tname(iiq))
+       END IF
+    END DO
+
+!
+! Valeurs specifiques pour les traceurs Rn222 et Pb210
+! ----------------------------------------------
+    IF ( id_rn/=0 .AND. id_pb/=0 ) THEN
+       rnpb = .TRUE.
+       radio(id_rn)= .TRUE.
+       radio(id_pb)= .TRUE.
+       pbl_flg(id_rn) = 0 ! au lieu de clsol=true ! CL au sol calcule
+       pbl_flg(id_pb) = 0 ! au lieu de clsol=true
+       aerosol(id_rn) = .FALSE.
+       aerosol(id_pb) = .TRUE. ! le Pb est un aerosol
+       
+       CALL initrrnpb (id_rn, id_pb, ftsol,pctsrf,masktr,fshtr,hsoltr,tautr,vdeptr,scavtr)
+    END IF
+
+!
+! Initialisation de module carbon_cycle_mod
+! ----------------------------------------------
+    IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN
+       CALL carbon_cycle_init(tr_seri, pdtphys, aerosol, radio)
+    END IF
+
+! Check if all tracers have restart values
+! ----------------------------------------------
+    DO it=1,nbtr
+       iiq=niadv(it+2)
+       ! Test if tracer is zero everywhere. 
+       ! Done by master process MPI and master thread OpenMP
+       CALL gather(tr_seri(:,:,it),varglo)
+       IF (is_mpi_root .AND. is_omp_root) THEN
+          mintmp=MINVAL(varglo,dim=1)
+          maxtmp=MAXVAL(varglo,dim=1)
+          IF (MINVAL(mintmp,dim=1)==0. .AND. MAXVAL(maxtmp,dim=1)==0.) THEN
+             ! Tracer is zero everywhere
+             zero=.TRUE.
+          ELSE
+             zero=.FALSE.
+          END IF
+       END IF
+
+       ! Distribute variable at all processes
+       CALL bcast(zero)
+
+       ! Initalize tracer that was not found in restart file.
+       IF (zero) THEN
+          ! The tracer was not found in restart file or it was equal zero everywhere.
+          WRITE(lunout,*) "The tracer ",trim(tname(iiq))," will be initialized"
+          IF (it==id_pcsat .OR. it==id_pcq .OR. &
+               it==id_pcs0 .OR. it==id_pcq0) THEN
+             tr_seri(:,:,it) = 100.
+          ELSE IF (it==id_pcocsat .OR. it==id_pcos0) THEN
+             DO i = 1, klon
+                IF ( pctsrf (i, is_oce) == 0. ) THEN
+                   tr_seri(i,:,it) = 0.
+                ELSE
+                   tr_seri(i,:,it) = 100.
+                END IF
+             END DO
+          ELSE
+             ! No specific initialization exist for this tracer
+             tr_seri(:,:,it) = 0.
+          END IF
+       END IF
+    END DO
+
+  END SUBROUTINE traclmdz_init
+
+  SUBROUTINE traclmdz(nstep, julien, gmtime, pdtphys, t_seri, paprs, pplay, &
+       cdragh,  coefh, yu1, yv1, ftsol, pctsrf, xlat, xlon, couchelimite, sh, &
+       rh, pphi, ustar, zu10m, zv10m, &
+!!          tr_seri, source, solsym, d_tr_cl, zmasse)                      !RomP
+          tr_seri, source, solsym, d_tr_cl,d_tr_dec, zmasse)               !RomP
+    
+    USE dimphy
+    USE infotrac
+    USE regr_pr_comb_coefoz_m, ONLY: regr_pr_comb_coefoz
+    USE o3_chem_m, ONLY: o3_chem
+    USE carbon_cycle_mod, ONLY : carbon_cycle, carbon_cycle_tr, carbon_cycle_cpl
+    USE indice_sol_mod
+
+    INCLUDE "YOMCST.h"
+
+!==========================================================================
+!                   -- DESCRIPTION DES ARGUMENTS --
+!==========================================================================
+
+! Input arguments
+!
+!Configuration grille,temps:
+    INTEGER,INTENT(IN) :: nstep      ! nombre d'appels de la physiq
+    INTEGER,INTENT(IN) :: julien     ! Jour julien
+    REAL,INTENT(IN)    :: gmtime
+    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)  
+    REAL,DIMENSION(klon),INTENT(IN) :: xlat    ! latitudes pour chaque point 
+    REAL, INTENT(IN):: xlon(:) ! dim(klon) longitude
+
+!
+!Physique: 
+!--------
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+    REAL,intent(in):: zmasse (:, :)   ! dim(klon,klev) density of air, in kg/m2
+
+
+!Couche limite:
+!--------------
+!
+    REAL,DIMENSION(klon),INTENT(IN)      :: cdragh     ! coeff drag pour T et Q
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: coefh      ! coeff melange CL (m**2/s)
+    REAL,DIMENSION(klon),INTENT(IN)      :: yu1        ! vents au premier niveau
+    REAL,DIMENSION(klon),INTENT(IN)      :: yv1        ! vents au premier niveau
+    LOGICAL,INTENT(IN)                   :: couchelimite
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: sh         ! humidite specifique
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: rh      ! Humidite relative
+    REAL,DIMENSION(klon,klev),INTENT(IN) :: pphi    ! geopotentie
+    REAL,DIMENSION(klon),INTENT(IN)      :: ustar   ! ustar (m/s)
+    REAL,DIMENSION(klon),INTENT(IN)      :: zu10m   ! vent zonal 10m (m/s)
+    REAL,DIMENSION(klon),INTENT(IN)      :: zv10m   ! vent zonal 10m (m/s)
+
+! Arguments necessaires pour les sources et puits de traceur:
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: ftsol  ! Temperature du sol (surf)(Kelvin)
+    REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Pourcentage de sol f(nature du sol)
+
+! InOutput argument
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]  
+
+! Output argument
+    CHARACTER(len=8),DIMENSION(nbtr), INTENT(OUT) :: solsym
+    REAL,DIMENSION(klon,nbtr), INTENT(OUT)        :: source  ! a voir lorsque le flux de surface est prescrit 
+    REAL,DIMENSION(klon,klev,nbtr), INTENT(OUT)   :: d_tr_cl ! Td couche limite/traceur
+
+!=======================================================================================
+!                        -- VARIABLES LOCALES TRACEURS --
+!=======================================================================================
+
+    INTEGER :: i, k, it
+    INTEGER :: lmt_pas ! number of time steps of "physics" per day
+
+    REAL,DIMENSION(klon)           :: d_trs    ! Td dans le reservoir
+    REAL,DIMENSION(klon,klev)      :: qsat     ! pression de la vapeur a saturation
+    REAL,DIMENSION(klon,klev,nbtr) :: d_tr_dec ! Td radioactive
+    REAL                           :: zrho     ! Masse Volumique de l'air KgA/m3
+    REAL                           :: amn, amx
+!
+!=================================================================
+!  Ajout de la production en  Be7 (Beryllium) srcbe U/s/kgA
+!=================================================================
+!
+    IF ( id_be /= 0 ) THEN
+       DO k = 1, klev
+          DO i = 1, klon
+             tr_seri(i,k,id_be) = tr_seri(i,k,id_be)+srcbe(i,k)*pdtphys
+          END DO
+       END DO
+       WRITE(*,*) 'Ajout srcBe dans tr_seri: OK'
+    END IF
+  
+
+!=================================================================
+! Update pseudo-vapor tracers 
+!=================================================================
+
+    CALL q_sat(klon*klev,t_seri,pplay,qsat)
+
+    IF ( id_pcsat /= 0 ) THEN
+     DO k = 1, klev
+      DO i = 1, klon
+         IF ( pplay(i,k).GE.85000.) THEN
+            tr_seri(i,k,id_pcsat) = qsat(i,k)
+         ELSE
+            tr_seri(i,k,id_pcsat) = MIN (qsat(i,k), tr_seri(i,k,id_pcsat))            
+         END IF
+      END DO 
+     END DO
+    END IF
+
+    IF ( id_pcocsat /= 0 ) THEN
+     DO k = 1, klev
+      DO i = 1, klon
+         IF ( pplay(i,k).GE.85000.) THEN
+            IF ( pctsrf (i, is_oce) > 0. ) THEN
+               tr_seri(i,k,id_pcocsat) = qsat(i,k)
+            ELSE
+               tr_seri(i,k,id_pcocsat) = 0.
+          END IF
+       ELSE 
+          tr_seri(i,k,id_pcocsat) = MIN (qsat(i,k), tr_seri(i,k,id_pcocsat))
+       END IF
+      END DO
+     END DO
+    END IF
+
+    IF ( id_pcq /= 0 ) THEN
+     DO k = 1, klev
+      DO i = 1, klon
+         IF ( pplay(i,k).GE.85000.) THEN
+            tr_seri(i,k,id_pcq) = sh(i,k)
+         ELSE
+            tr_seri(i,k,id_pcq) = MIN (qsat(i,k), tr_seri(i,k,id_pcq))    
+         END IF
+      END DO
+     END DO
+    END IF
+
+
+    IF ( id_pcs0 /= 0 ) THEN
+     DO k = 1, klev
+      DO i = 1, klon
+         IF ( pplay(i,k).GE.85000.) THEN
+            tr_seri(i,k,id_pcs0) = qsat(i,k)
+         ELSE
+            tr_seri(i,k,id_pcs0) = MIN (qsat(i,k), tr_seri(i,k,id_pcs0))    
+         END IF
+      END DO
+     END DO
+    END IF
+
+
+    IF ( id_pcos0 /= 0 ) THEN
+     DO k = 1, klev
+      DO i = 1, klon
+         IF ( pplay(i,k).GE.85000.) THEN
+            IF ( pctsrf (i, is_oce) > 0. ) THEN
+               tr_seri(i,k,id_pcos0) = qsat(i,k)
+            ELSE
+               tr_seri(i,k,id_pcos0) = 0.
+            END IF
+         ELSE
+            tr_seri(i,k,id_pcos0) = MIN (qsat(i,k), tr_seri(i,k,id_pcos0))
+         END IF
+      END DO
+     END DO
+    END IF
+
+
+    IF ( id_pcq0 /= 0 ) THEN
+     DO k = 1, klev
+      DO i = 1, klon
+         IF ( pplay(i,k).GE.85000.) THEN
+            tr_seri(i,k,id_pcq0) = sh(i,k)
+         ELSE 
+            tr_seri(i,k,id_pcq0) = MIN (qsat(i,k), tr_seri(i,k,id_pcq0))
+         END IF
+      END DO
+     END DO
+    END IF
+
+!=================================================================
+! Update tracer : Age of stratospheric air 
+!=================================================================
+    IF (id_aga/=0) THEN
+       
+       ! Bottom layers
+       DO k = 1, lev_1p5km
+          tr_seri(:,k,id_aga) = 0.0
+       END DO
+       
+       ! Layers above 1.5km
+       DO k = lev_1p5km+1,klev-1
+          tr_seri(:,k,id_aga) = tr_seri(:,k,id_aga) + pdtphys
+       END DO
+       
+       ! Top layer
+       tr_seri(:,klev,id_aga) = tr_seri(:,klev-1,id_aga)
+       
+    END IF
+
+!======================================================================
+!     -- Calcul de l'effet de la couche limite --
+!======================================================================
+
+    IF (couchelimite) THEN             
+       source(:,:) = 0.0
+
+       IF (id_be /=0) THEN
+          DO i=1, klon
+             zrho = pplay(i,1)/t_seri(i,1)/RD
+             source(i,id_be) = - vdeptr(id_be)*tr_seri(i,1,id_be)*zrho
+          END DO
+       END IF
+
+    END IF
+    
+    PRINT *,'  Lluis in traclmdz_mod BOUNDS tr_seri: ',UBOUND(tr_seri),' trs: ',UBOUND(trs)
+
+    DO it=1, nbtr
+       IF (couchelimite .AND. pbl_flg(it) == 0 .AND. (it==id_rn .OR. it==id_pb)) THEN 
+          ! couche limite avec quantite dans le sol calculee
+          CALL cltracrn(it, id_rn, id_pb, pdtphys, yu1, yv1,     &
+               cdragh, coefh,t_seri,ftsol,pctsrf,  &
+               tr_seri(:,:,it),trs(:,it),          &
+               paprs, pplay, zmasse * rg, &
+               masktr(:,it),fshtr(:,it),hsoltr(it),&
+               tautr(it),vdeptr(it),               &
+               xlat,d_tr_cl(:,:,it),d_trs)
+          
+          DO k = 1, klev
+             DO i = 1, klon
+                tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_cl(i,k,it)
+             END DO
+          END DO
+        
+          ! Traceur dans le reservoir sol
+          DO i = 1, klon
+             trs(i,it) = trs(i,it) + d_trs(i)
+          END DO
+       END IF
+    END DO
+          
+
+!======================================================================
+!   Calcul de l'effet du puits radioactif
+!======================================================================
+    CALL radio_decay (id_rn, id_pb, radio,rnpb,pdtphys,tautr,tr_seri,d_tr_dec)
+
+    DO it=1,nbtr
+       WRITE(solsym(it),'(i2)') it
+    END DO
+
+    DO it=1,nbtr
+       IF(radio(it)) then     
+          DO k = 1, klev
+             DO i = 1, klon
+                tr_seri(i,k,it) = tr_seri(i,k,it) + d_tr_dec(i,k,it)
+             END DO
+          END DO
+          CALL minmaxqfi(tr_seri(:,:,it),0.,1.e33,'puits rn it='//solsym(it))
+       END IF
+    END DO
+
+!======================================================================
+!   Parameterization of ozone chemistry
+!======================================================================
+
+    IF (id_o3 /= 0) then
+       lmt_pas = NINT(86400./pdtphys)
+       IF (MOD(nstep - 1, lmt_pas) == 0) THEN
+          ! Once per day, update the coefficients for ozone chemistry:
+          CALL regr_pr_comb_coefoz(julien, xlat, paprs, pplay)
+       END IF
+       CALL o3_chem(julien, gmtime, t_seri, zmasse, pdtphys, xlat, &
+            xlon, tr_seri(:, :, id_o3))
+    END IF
+
+!======================================================================
+!   Calcul de cycle de carbon
+!======================================================================
+    IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN
+       CALL carbon_cycle(nstep, pdtphys, pctsrf, tr_seri, source)
+    END IF
+
+  END SUBROUTINE traclmdz
+
+
+  SUBROUTINE traclmdz_to_restart(trs_out)
+    ! This subroutine is called from phyredem.F where the module 
+    ! variable trs is written to restart file (restartphy.nc)
+    USE dimphy
+    USE infotrac
+    
+    REAL,DIMENSION(klon,nbtr), INTENT(OUT) :: trs_out
+    INTEGER :: ierr
+
+    IF ( ALLOCATED(trs) ) THEN
+       trs_out(:,:) = trs(:,:)
+    ELSE
+       ! No previous allocate of trs. This is the case for create_etat0_limit.
+       trs_out(:,:) = 0.0
+    END IF
+    
+  END SUBROUTINE traclmdz_to_restart
+  
+
+END MODULE traclmdz_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/tracreprobus_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/tracreprobus_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/tracreprobus_mod.F90	(revision 17)
@@ -0,0 +1,109 @@
+MODULE tracreprobus_mod
+!
+! This module prepares and calls the Reprobus main subroutine 
+!
+
+CONTAINS
+
+  SUBROUTINE tracreprobus(pdtphys, gmtime, debutphy, julien, &
+       presnivs, xlat, xlon, pphis, pphi, &
+       t_seri, pplay, paprs, sh , &
+       tr_seri, solsym)
+
+    USE dimphy
+    USE infotrac
+#ifdef REPROBUS 
+    USE CHEM_REP, ONLY : pdt_rep, &  ! pas de temps reprobus
+         daynum, iter, &             ! jourjulien, iteration chimie
+         pdel
+#endif
+    IMPLICIT NONE
+
+! Input argument
+!---------------
+    REAL,INTENT(IN)    :: pdtphys    ! Pas d'integration pour la physique (seconde)
+    REAL,INTENT(IN)    :: gmtime     ! Heure courante
+    LOGICAL,INTENT(IN) :: debutphy   ! le flag de l'initialisation de la physique
+    INTEGER,INTENT(IN) :: julien     ! Jour julien
+
+    REAL,DIMENSION(klev),INTENT(IN)        :: presnivs! pressions approximat. des milieux couches (en PA)
+    REAL,DIMENSION(klon),INTENT(IN)        :: xlat    ! latitudes pour chaque point 
+    REAL,DIMENSION(klon),INTENT(IN)        :: xlon    ! longitudes pour chaque point 
+    REAL,DIMENSION(klon),INTENT(IN)        :: pphis   ! geopotentiel du sol
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pphi    ! geopotentiel de chaque couche
+
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: t_seri  ! Temperature
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: pplay   ! pression pour le mileu de chaque couche (en Pa)
+    REAL,DIMENSION(klon,klev+1),INTENT(IN) :: paprs   ! pression pour chaque inter-couche (en Pa)
+    REAL,DIMENSION(klon,klev),INTENT(IN)   :: sh      ! humidite specifique   
+
+
+! Output argument
+!----------------
+    REAL,DIMENSION(klon,klev,nbtr),INTENT(INOUT)  :: tr_seri ! Concentration Traceur [U/KgA]  
+    CHARACTER(len=8),DIMENSION(nbtr), INTENT(OUT) :: solsym
+  
+
+! Local variables
+!----------------
+    INTEGER :: it, k
+
+#ifdef REPROBUS
+    !   -- CHIMIE REPROBUS --
+    pdt_rep=pdtphys/2.
+    
+    DO k = 1, klev
+       pdel(:,k) = paprs(:,k) - paprs (:,k+1)
+    END DO
+    
+    ! initialisation de ozone passif a ozone en debut d hiver HN et HS
+    IF (julien == 341 .OR. julien == 181) THEN
+       tr_seri(:,:,11)=tr_seri(:,:,8)
+    END IF
+    
+    DO  iter = 1,2
+       daynum = FLOAT(julien) + gmtime + (iter-1)*pdt_rep/86400.
+       
+       DO it=1, nbtr
+!     WRITE(lunout,*)it,' ',minval(tr_seri(:,:,it)),maxval(tr_seri(:,:,it))
+! seulement pour les especes chimiques (pas l'age de l'air)
+! verif valeurs extremes
+! correction: a 1.e-30 quand =0 ou negatif et
+! call abort si >ou= 1.e10
+          WRITE(*,*)it,'nqtot',nqtot,'nbtr',nbtr
+          IF (it < nqtot) THEN
+             WRITE(*,*)'ici',it,nqtot
+#ifdef REPROBUS
+             CALL minmaxqfi_chimie(tr_seri(1,1,it),0.,1.e10,'avant chimie ')
+#endif
+             WRITE(*,*)'apres'
+          ENDIF
+       ENDDO
+       
+#ifdef REPROBUS
+       CALL chemmain_rlong_1401( &
+            tr_seri, & !argument phytrac (change de nom apres: vmr)
+            xlon,    & !argument phytrac (change de nom apres: lon)
+            xlat,    & !argument phytrac (change de nom apres: lat)
+            t_seri,  & !argument phytrac (meme nom)
+            pplay,   & !argument phytrac (meme nom)
+            pphi,    & !argument phytrac (meme nom)
+            pphis,   & !argument phytrac (meme nom)
+            presnivs, & !argument phytrac (meme nom)
+            sh,      & !argument phytrac (meme nom)
+            debutphy) !argument phytrac (change de nom apres: debut)
+       ! pdel, pdt_rep, daynum : definit dans phytrac et utilise dans chemmain
+       !                 et transporte par CHEM_REP
+#endif        
+       
+    END DO
+    
+
+    ! 
+    DO it=1,nbtr
+       WRITE(solsym(it),'(i2)') it
+    END DO
+#endif
+  END SUBROUTINE tracreprobus
+
+END MODULE tracreprobus_mod
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/tracstoke.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/tracstoke.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/tracstoke.h	(revision 17)
@@ -0,0 +1,5 @@
+!
+! $Header$
+!
+      common /tracstoke/istdyn,istphy,unittrac
+      integer istdyn,istphy,unittrac
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/transp.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/transp.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/transp.F	(revision 17)
@@ -0,0 +1,48 @@
+!
+! $Header$
+!
+      SUBROUTINE transp (paprs,tsol,
+     e                   t, q, u, v, geom,
+     s                   vtran_e, vtran_q, utran_e, utran_q)
+c 
+       USE dimphy
+      IMPLICIT none
+c======================================================================
+c Auteur(s): Z.X.Li (LMD/CNRS)
+c Date: le 25 avril 1994
+c Objet: Calculer le transport de l'energie et de la vapeur d'eau
+c======================================================================
+c
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+      REAL paprs(klon,klev+1), tsol(klon)
+      REAL t(klon,klev), q(klon,klev), u(klon,klev), v(klon,klev)
+      REAL utran_e(klon), utran_q(klon), vtran_e(klon), vtran_q(klon)
+c
+      INTEGER i, l
+c     ------------------------------------------------------------------
+      REAL geom(klon,klev), e
+c     ------------------------------------------------------------------
+      DO i = 1, klon
+         utran_e(i) = 0.0
+         utran_q(i) = 0.0
+         vtran_e(i) = 0.0
+         vtran_q(i) = 0.0
+      ENDDO
+c
+      DO l = 1, klev
+      DO i = 1, klon
+         e = RCPD*t(i,l) + RLVTT*q(i,l) + geom(i,l)
+         utran_e(i)=utran_e(i)+ u(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG
+         utran_q(i)=utran_q(i)+ u(i,l)*q(i,l)
+     .                         *(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_e(i)=vtran_e(i)+ v(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_q(i)=vtran_q(i)+ v(i,l)*q(i,l)
+     .                         *(paprs(i,l)-paprs(i,l+1))/RG
+      ENDDO
+      ENDDO
+c
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/transp.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/transp.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/transp.F90	(revision 17)
@@ -0,0 +1,48 @@
+!
+! $Header$
+!
+      SUBROUTINE transp (paprs,tsol,                                                 &
+       &                   t, q, u, v, geom,                                         &
+       &                   vtran_e, vtran_q, utran_e, utran_q)
+!c 
+       USE dimphy
+      IMPLICIT none
+!c======================================================================
+!c Auteur(s): Z.X.Li (LMD/CNRS)
+!c Date: le 25 avril 1994
+!c Objet: Calculer le transport de l'energie et de la vapeur d'eau
+!c======================================================================
+!c
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c
+      REAL paprs(klon,klev+1), tsol(klon)
+      REAL t(klon,klev), q(klon,klev), u(klon,klev), v(klon,klev)
+      REAL utran_e(klon), utran_q(klon), vtran_e(klon), vtran_q(klon)
+!c
+      INTEGER i, l
+!c     ------------------------------------------------------------------
+      REAL geom(klon,klev), e
+!c     ------------------------------------------------------------------
+      DO i = 1, klon
+         utran_e(i) = 0.0
+         utran_q(i) = 0.0
+         vtran_e(i) = 0.0
+         vtran_q(i) = 0.0
+      ENDDO
+!c
+      DO l = 1, klev
+      DO i = 1, klon
+         e = RCPD*t(i,l) + RLVTT*q(i,l) + geom(i,l)
+         utran_e(i)=utran_e(i)+ u(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG
+         utran_q(i)=utran_q(i)+ u(i,l)*q(i,l)                                        &
+       &                         *(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_e(i)=vtran_e(i)+ v(i,l)*e*(paprs(i,l)-paprs(i,l+1))/RG
+         vtran_q(i)=vtran_q(i)+ v(i,l)*q(i,l)                                        &
+       &                         *(paprs(i,l)-paprs(i,l+1))/RG
+      ENDDO
+      ENDDO
+!c
+      RETURN
+      END SUBROUTINE transp
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/undefSTD.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/undefSTD.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/undefSTD.F	(revision 17)
@@ -0,0 +1,100 @@
+!
+! $Id: undefSTD.F 1418 2010-07-19 15:11:24Z jghattas $
+!
+      SUBROUTINE undefSTD(itap,freq_calNMC, read_climoz)
+      USE netcdf
+      USE dimphy
+      USE phys_state_var_mod ! Variables sauvegardees de la physique
+      IMPLICIT none
+c
+c====================================================================
+c
+c I. Musat : 09.2004
+c
+c Calcul * du nombre de pas de temps (FLOAT(ecrit_XXX)-tnondef)) 
+c          ou la variable tlevSTD est bien definie (.NE.missing_val), 
+c et 
+c        * de la somme de tlevSTD => tsumSTD
+c
+c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
+c        ! de la physique
+c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
+c        ! de la physique
+c nout=3 !var. mensuelle "NMC" moyennee toutes les ecrit_hf
+c
+c
+c NB: mettre "inst(X)" dans le write_hist*NMC.h !
+c====================================================================
+c
+cym#include "dimensions.h"
+cym      integer jjmp1
+cym      parameter (jjmp1=jjm+1-1/jjm)
+cym#include "dimphy.h"
+c variables Input
+c
+c     INTEGER nlevSTD, klevSTD, itap
+c     PARAMETER(klevSTD=17)
+      INTEGER itap
+c     REAL dtime
+c
+c variables locales
+c     INTEGER i, k, nout, n
+c     PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC
+      INTEGER i, k, n
+      REAL freq_calNMC(nout)
+      INTEGER read_climoz
+c
+c variables Output
+c     REAL tlevSTD(klon,klevSTD), tsumSTD(klon,klevSTD,nout)
+c     LOGICAL oknondef(klon,klevSTD,nout)
+c     REAL tnondef(klon,klevSTD,nout)
+c
+      REAL missing_val
+c
+      missing_val=nf90_fill_real
+c
+      DO n=1, nout
+c
+c
+c calcul variables tous les freq_calNMC(n)/dtime pas de temps 
+c de la physique
+c
+       IF(MOD(itap,NINT(freq_calNMC(n)/dtime)).EQ.0) THEN
+        DO k=1, nlevSTD
+         DO i=1, klon
+          IF(tlevSTD(i,k).EQ.missing_val) THEN
+c          IF(oknondef(i,k,n)) THEN          
+            tnondef(i,k,n)=tnondef(i,k,n)+1.
+c          ENDIF !oknondef(i,k)
+c
+          ELSE IF(tlevSTD(i,k).NE.missing_val) THEN
+           tsumSTD(i,k,n)=tsumSTD(i,k,n)+tlevSTD(i,k)
+           usumSTD(i,k,n)=usumSTD(i,k,n)+ulevSTD(i,k)
+           vsumSTD(i,k,n)=vsumSTD(i,k,n)+vlevSTD(i,k)
+           wsumSTD(i,k,n)=wsumSTD(i,k,n)+wlevSTD(i,k)
+           phisumSTD(i,k,n)=phisumSTD(i,k,n)+philevSTD(i,k)
+           qsumSTD(i,k,n)=qsumSTD(i,k,n)+qlevSTD(i,k)
+           rhsumSTD(i,k,n)=rhsumSTD(i,k,n)+rhlevSTD(i,k)
+           uvsumSTD(i,k,n)=uvsumSTD(i,k,n)+uvSTD(i,k)
+           vqsumSTD(i,k,n)=vqsumSTD(i,k,n)+vqSTD(i,k)
+           vTsumSTD(i,k,n)=vTsumSTD(i,k,n)+vTSTD(i,k)
+           wqsumSTD(i,k,n)=wqsumSTD(i,k,n)+wqSTD(i,k)
+           vphisumSTD(i,k,n)=vphisumSTD(i,k,n)+vphiSTD(i,k)
+           wTsumSTD(i,k,n)=wTsumSTD(i,k,n)+wTSTD(i,k)
+           u2sumSTD(i,k,n)=u2sumSTD(i,k,n)+u2STD(i,k)
+           v2sumSTD(i,k,n)=v2sumSTD(i,k,n)+v2STD(i,k)
+           T2sumSTD(i,k,n)=T2sumSTD(i,k,n)+T2STD(i,k)
+           O3sumSTD(i,k,n)=O3sumSTD(i,k,n)+O3STD(i,k)
+           IF (read_climoz==2) 
+     &          O3daysumSTD(i,k,n)=O3daysumSTD(i,k,n)+O3daySTD(i,k)
+
+          ENDIF 
+         ENDDO !i
+        ENDDO !k
+c
+       ENDIF !MOD(itap,NINT(freq_calNMC(n)/dtime)).EQ.0
+c
+      ENDDO !n
+c
+      RETURN
+      END  
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/undefSTD.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/undefSTD.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/undefSTD.F90	(revision 17)
@@ -0,0 +1,100 @@
+!
+! $Id: undefSTD.F 1418 2010-07-19 15:11:24Z jghattas $
+!
+      SUBROUTINE undefSTD(itap,freq_calNMC, read_climoz)
+      USE netcdf
+      USE dimphy
+      USE phys_state_var_mod ! Variables sauvegardees de la physique
+      IMPLICIT none
+!c
+!c====================================================================
+!c
+!c I. Musat : 09.2004
+!c
+!c Calcul * du nombre de pas de temps (FLOAT(ecrit_XXX)-tnondef)) 
+!c          ou la variable tlevSTD est bien definie (.NE.missing_val), 
+!c et 
+!c        * de la somme de tlevSTD => tsumSTD
+!c
+!c nout=1 !var. journaliere "day" moyenne sur tous les pas de temps
+!c        ! de la physique
+!c nout=2 !var. mensuelle "mth" moyennee sur tous les pas de temps
+!c        ! de la physique
+!c nout=3 !var. mensuelle "NMC" moyennee toutes les ecrit_hf
+!c
+!c
+!c NB: mettre "inst(X)" dans le write_hist*NMC.h !
+!c====================================================================
+!c
+!cym#include "dimensions.h"
+!cym      integer jjmp1
+!cym      parameter (jjmp1=jjm+1-1/jjm)
+!cym#include "dimphy.h"
+!c variables Input
+!c
+!c     INTEGER nlevSTD, klevSTD, itap
+!c     PARAMETER(klevSTD=17)
+      INTEGER itap
+!c     REAL dtime
+!c
+!c variables locales
+!c     INTEGER i, k, nout, n
+!c     PARAMETER(nout=3) !nout=1 : day; =2 : mth; =3 : NMC
+      INTEGER i, k, n
+      REAL freq_calNMC(nout)
+      INTEGER read_climoz
+!c
+!c variables Output
+!c     REAL tlevSTD(klon,klevSTD), tsumSTD(klon,klevSTD,nout)
+!c     LOGICAL oknondef(klon,klevSTD,nout)
+!c     REAL tnondef(klon,klevSTD,nout)
+!c
+      REAL missing_val
+!c
+      missing_val=nf90_fill_real
+!c
+      DO n=1, nout
+!c
+!c
+!c calcul variables tous les freq_calNMC(n)/dtime pas de temps 
+!c de la physique
+!c
+       IF(MOD(itap,NINT(freq_calNMC(n)/dtime)).EQ.0) THEN
+        DO k=1, nlevSTD
+         DO i=1, klon
+          IF(tlevSTD(i,k).EQ.missing_val) THEN
+!c          IF(oknondef(i,k,n)) THEN          
+            tnondef(i,k,n)=tnondef(i,k,n)+1.
+!c          ENDIF !oknondef(i,k)
+!c
+          ELSE IF(tlevSTD(i,k).NE.missing_val) THEN
+           tsumSTD(i,k,n)=tsumSTD(i,k,n)+tlevSTD(i,k)
+           usumSTD(i,k,n)=usumSTD(i,k,n)+ulevSTD(i,k)
+           vsumSTD(i,k,n)=vsumSTD(i,k,n)+vlevSTD(i,k)
+           wsumSTD(i,k,n)=wsumSTD(i,k,n)+wlevSTD(i,k)
+           phisumSTD(i,k,n)=phisumSTD(i,k,n)+philevSTD(i,k)
+           qsumSTD(i,k,n)=qsumSTD(i,k,n)+qlevSTD(i,k)
+           rhsumSTD(i,k,n)=rhsumSTD(i,k,n)+rhlevSTD(i,k)
+           uvsumSTD(i,k,n)=uvsumSTD(i,k,n)+uvSTD(i,k)
+           vqsumSTD(i,k,n)=vqsumSTD(i,k,n)+vqSTD(i,k)
+           vTsumSTD(i,k,n)=vTsumSTD(i,k,n)+vTSTD(i,k)
+           wqsumSTD(i,k,n)=wqsumSTD(i,k,n)+wqSTD(i,k)
+           vphisumSTD(i,k,n)=vphisumSTD(i,k,n)+vphiSTD(i,k)
+           wTsumSTD(i,k,n)=wTsumSTD(i,k,n)+wTSTD(i,k)
+           u2sumSTD(i,k,n)=u2sumSTD(i,k,n)+u2STD(i,k)
+           v2sumSTD(i,k,n)=v2sumSTD(i,k,n)+v2STD(i,k)
+           T2sumSTD(i,k,n)=T2sumSTD(i,k,n)+T2STD(i,k)
+           O3sumSTD(i,k,n)=O3sumSTD(i,k,n)+O3STD(i,k)
+           IF (read_climoz==2)                                                       &
+       &          O3daysumSTD(i,k,n)=O3daysumSTD(i,k,n)+O3daySTD(i,k)
+
+          ENDIF 
+         ENDDO !i
+        ENDDO !k
+!c
+       ENDIF !MOD(itap,NINT(freq_calNMC(n)/dtime)).EQ.0
+!c
+      ENDDO !n
+!c
+      RETURN
+      END SUBROUTINE undefSTD
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ustarhb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ustarhb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ustarhb.F	(revision 17)
@@ -0,0 +1,54 @@
+!
+! $Header$
+!
+      SUBROUTINE ustarhb(knon,u,v,cd_m, ustar)
+      use dimphy
+      IMPLICIT none
+c======================================================================
+c Laurent Li (LMD/CNRS), le 30 septembre 1998
+c Couche limite non-locale. Adaptation du code du CCM3.
+c Code non teste, donc a ne pas utiliser.
+c======================================================================
+c Nonlocal scheme that determines eddy diffusivities based on a
+c diagnosed boundary layer height and a turbulent velocity scale.
+c Also countergradient effects for heat and moisture are included.
+c
+c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
+c Local versus nonlocal boundary-layer diffusion in a global climate
+c model. J. of Climate, vol. 6, 1825-1842.
+c======================================================================
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+#include "YOMCST.h"
+c
+c Arguments:
+c
+      INTEGER knon ! nombre de points a calculer
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+      REAL ustar(klon)
+c
+      INTEGER i, k
+      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      DO i = 1, knon
+        zx_alf1 = 1.0
+        zx_alf2 = 1.0 - zx_alf1
+        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+        zxmod = 1.0+SQRT(zxu**2+zxv**2)
+        taux = zxu *zxmod*cd_m(i)
+        tauy = zxv *zxmod*cd_m(i)
+        ustar(i) = SQRT(taux**2+tauy**2)
+c       print*,'Ust ',zxu,zxmod,taux,ustar(i)
+      ENDDO
+c
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/ustarhb.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/ustarhb.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/ustarhb.F90	(revision 17)
@@ -0,0 +1,54 @@
+!
+! $Header$
+!
+      SUBROUTINE ustarhb(knon,u,v,cd_m, ustar)
+      use dimphy
+      IMPLICIT none
+!c======================================================================
+!c Laurent Li (LMD/CNRS), le 30 septembre 1998
+!c Couche limite non-locale. Adaptation du code du CCM3.
+!c Code non teste, donc a ne pas utiliser.
+!c======================================================================
+!c Nonlocal scheme that determines eddy diffusivities based on a
+!c diagnosed boundary layer height and a turbulent velocity scale.
+!c Also countergradient effects for heat and moisture are included.
+!c
+!c For more information, see Holtslag, A.A.M., and B.A. Boville, 1993:
+!c Local versus nonlocal boundary-layer diffusion in a global climate
+!c model. J. of Climate, vol. 6, 1825-1842.
+!c======================================================================
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+#include "YOMCST.h"
+!c
+!c Arguments:
+!c
+      INTEGER knon ! nombre de points a calculer
+      REAL u(klon,klev) ! vitesse U (m/s)
+      REAL v(klon,klev) ! vitesse V (m/s)
+      REAL cd_m(klon) ! coefficient de friction au sol pour vitesse
+      REAL ustar(klon)
+!c
+      INTEGER i, k
+      REAL zxt, zxq, zxu, zxv, zxmod, taux, tauy
+      REAL zx_alf1, zx_alf2 ! parametres pour extrapolation
+      LOGICAL unssrf(klon)  ! unstb pbl w/lvls within srf pbl lyr
+      LOGICAL unsout(klon)  ! unstb pbl w/lvls in outer pbl lyr
+      LOGICAL check(klon)   ! True=>chk if Richardson no.>critcal
+!c
+#include "YOETHF.h"
+#include "FCTTRE.h"
+      DO i = 1, knon
+        zx_alf1 = 1.0
+        zx_alf2 = 1.0 - zx_alf1
+        zxu = u(i,1)*zx_alf1+u(i,2)*zx_alf2
+        zxv = v(i,1)*zx_alf1+v(i,2)*zx_alf2
+        zxmod = 1.0+SQRT(zxu**2+zxv**2)
+        taux = zxu *zxmod*cd_m(i)
+        tauy = zxv *zxmod*cd_m(i)
+        ustar(i) = SQRT(taux**2+tauy**2)
+!c       print*,'Ust ',zxu,zxmod,taux,ustar(i)
+      ENDDO
+!c
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/vampir.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/vampir.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/vampir.F90	(revision 17)
@@ -0,0 +1,86 @@
+module Vampir
+
+  INTEGER,parameter :: VTcaldyn=1
+  INTEGER,parameter :: VTintegre=2
+  INTEGER,parameter :: VTadvection=3
+  INTEGER,parameter :: VTdissipation=4
+  INTEGER,parameter :: VThallo=5
+  INTEGER,parameter :: VTphysiq=6
+  INTEGER,parameter :: VTinca=7
+  
+  INTEGER,parameter :: nb_inst=7
+  INTEGER :: MPE_begin(nb_inst)
+  INTEGER :: MPE_end(nb_inst)
+  
+contains
+
+  subroutine InitVampir
+    implicit none
+
+#ifdef USE_VT
+    include 'VT.inc'
+    integer :: ierr
+    
+    call VTSYMDEF(VTcaldyn,"caldyn","caldyn",ierr)
+    call VTSYMDEF(VTintegre,"integre","integre",ierr)
+    call VTSYMDEF(VTadvection,"advection","advection",ierr)
+    call VTSYMDEF(VTdissipation,"dissipation","dissipation",ierr)
+    call VTSYMDEF(VThallo,"hallo","hallo",ierr)
+    call VTSYMDEF(VTphysiq,"physiq","physiq",ierr)
+    call VTSYMDEF(VTinca,"inca","inca",ierr)
+#endif
+
+#ifdef USE_MPE
+    include 'mpe_logf.h' 
+    integer :: ierr,i
+    
+    DO i=1,nb_inst
+      ierr = MPE_Log_get_state_eventIDs( MPE_begin(i), MPE_end(i) )
+    ENDDO
+    
+    ierr = MPE_Describe_state( MPE_begin(VTcaldyn), MPE_end(VTcaldyn),"caldyn", "yellow" )
+    ierr = MPE_Describe_state( MPE_begin(VTintegre), MPE_end(VTintegre),"integre", "blue" )
+    ierr = MPE_Describe_state( MPE_begin(VTadvection), MPE_end(VTadvection),"advection", "green" )
+    ierr = MPE_Describe_state( MPE_begin(VTdissipation), MPE_end(VTdissipation),"dissipation", "ivory" )
+    ierr = MPE_Describe_state( MPE_begin(VThallo), MPE_end(VThallo),"hallo", "orange" )
+    ierr = MPE_Describe_state( MPE_begin(VTphysiq), MPE_end(VTphysiq),"physiq", "purple" )
+    ierr = MPE_Describe_state( MPE_begin(VTinca), MPE_end(VTinca),"inca", "LightBlue" )
+#endif     
+  end subroutine InitVampir
+
+  subroutine VTb(number)
+    implicit none
+    INTEGER :: number
+#ifdef USE_VT    
+    include 'VT.inc'
+    integer :: ierr
+    
+    call VTBEGIN(number,ierr)
+#endif 
+#ifdef USE_MPE
+    include 'mpe_logf.h' 
+    integer :: ierr,i
+    ierr = MPE_Log_event( MPE_begin(number), 0, '' )
+#endif
+
+  end subroutine VTb
+
+  subroutine VTe(number)
+    implicit none
+    INTEGER :: Number
+#ifdef USE_VT    
+    include 'VT.inc'
+    integer :: ierr
+   
+    call VTEND(number,ierr)
+#endif    
+
+#ifdef USE_MPE
+    include 'mpe_logf.h' 
+    integer :: ierr,i
+    ierr = MPE_Log_event( MPE_end(number), 0, '' )
+#endif
+
+  end subroutine VTe
+  
+end module Vampir
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/vdif_kcay.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/vdif_kcay.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/vdif_kcay.F	(revision 17)
@@ -0,0 +1,743 @@
+!
+! $Header$
+!
+      SUBROUTINE vdif_kcay(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2,q2diag,km,kn,ustar
+     s   ,l_mix)
+      use dimphy
+      IMPLICIT NONE
+c.......................................................................
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c 
+c.......................................................................
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon),snstable
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1),q2s(klon,klev+1)
+      REAL q2diag(klon,klev+1)
+      REAL km(klon,klev+1)
+      REAL kn(klon,klev+1)
+      real sq(klon),sqz(klon),zz(klon,klev+1),zq,long0(klon)
+
+      integer l_mix,iii
+c.......................................................................
+c
+c nlay : nombre de couches        
+c nlev : nombre de niveaux
+c ngrid : nombre de points de grille       
+c unsdz : 1 sur l'epaisseur de couche
+c unsdzdec : 1 sur la distance entre le centre de la couche et le
+c            centre de la couche inferieure
+c q : echelle de vitesse au bas de chaque couche
+c     (valeur a la fin du pas de temps)
+c
+c.......................................................................
+      INTEGER nlay,nlev,ngrid
+      REAL unsdz(klon,klev)
+      REAL unsdzdec(klon,klev+1)
+      REAL q(klon,klev+1)
+
+c.......................................................................
+c
+c kmpre : km au debut du pas de temps
+c qcstat : q : solution stationnaire du probleme couple
+c          (valeur a la fin du pas de temps)
+c q2cstat : q2 : solution stationnaire du probleme couple
+c           (valeur a la fin du pas de temps)
+c
+c.......................................................................
+      REAL kmpre(klon,klev+1)
+      REAL qcstat
+      REAL q2cstat
+      real sss,sssq
+c.......................................................................
+c
+c long : longueur de melange calculee selon Blackadar
+c
+c.......................................................................
+      REAL long(klon,klev+1)
+c.......................................................................
+c
+c kmq3 : terme en q^3 dans le developpement de km
+c        (valeur au debut du pas de temps)
+c kmcstat : valeur de km solution stationnaire du systeme {q2 ; du/dz}
+c           (valeur a la fin du pas de temps)
+c knq3 : terme en q^3 dans le developpement de kn
+c mcstat : valeur de m solution stationnaire du systeme {q2 ; du/dz}
+c          (valeur a la fin du pas de temps)
+c m2cstat : valeur de m2 solution stationnaire du systeme {q2 ; du/dz}
+c           (valeur a la fin du pas de temps)
+c m : valeur a la fin du pas de temps
+c mpre : valeur au debut du pas de temps
+c m2 : valeur a la fin du pas de temps
+c n2 : valeur a la fin du pas de temps
+c 
+c.......................................................................
+      REAL kmq3
+      REAL kmcstat
+      REAL knq3
+      REAL mcstat
+      REAL m2cstat
+      REAL m(klon,klev+1)
+      REAL mpre(klon,klev+1)
+      REAL m2(klon,klev+1)
+      REAL n2(klon,klev+1)
+c.......................................................................
+c
+c gn : intermediaire pour les coefficients de stabilite
+c gnmin : borne inferieure de gn (-0.23 ou -0.28)
+c gnmax : borne superieure de gn (0.0233)
+c gninf : vrai si gn est en dessous de sa borne inferieure
+c gnsup : vrai si gn est en dessus de sa borne superieure
+c gm : drole d'objet bien utile
+c ri : nombre de Richardson
+c sn : coefficient de stabilite pour n
+c snq2 : premier terme du developement limite de sn en q2
+c sm : coefficient de stabilite pour m
+c smq2 : premier terme du developement limite de sm en q2
+c
+c.......................................................................
+      REAL gn
+      REAL gnmin
+      REAL gnmax
+      LOGICAL gninf
+      LOGICAL gnsup
+      REAL gm
+c      REAL ri(klon,klev+1)
+      REAL sn(klon,klev+1)
+      REAL snq2(klon,klev+1)
+      REAL sm(klon,klev+1)
+      REAL smq2(klon,klev+1)
+c.......................................................................
+c
+c kappa : consatnte de Von Karman (0.4)
+c long00 : longueur de reference pour le calcul de long (160)
+c a1,a2,b1,b2,c1 : constantes d'origine pour les  coefficients
+c                  de stabilite (0.92/0.74/16.6/10.1/0.08)
+c cn1,cn2 : constantes pour sn
+c cm1,cm2,cm3,cm4 : constantes pour sm
+c
+c.......................................................................
+      REAL kappa
+      REAL long00
+      REAL a1,a2,b1,b2,c1
+      REAL cn1,cn2
+      REAL cm1,cm2,cm3,cm4
+c.......................................................................
+c
+c termq : termes en $q$ dans l'equation de q2
+c termq3 : termes en $q^3$ dans l'equation de q2
+c termqm2 : termes en $q*m^2$ dans l'equation de q2
+c termq3m2 : termes en $q^3*m^2$ dans l'equation de q2
+c
+c.......................................................................
+      REAL termq
+      REAL termq3
+      REAL termqm2
+      REAL termq3m2
+c.......................................................................
+c
+c q2min : borne inferieure de q2
+c q2max : borne superieure de q2
+c
+c.......................................................................
+      REAL q2min
+      REAL q2max
+c.......................................................................
+c knmin : borne inferieure de kn
+c kmmin : borne inferieure de km
+c.......................................................................
+      REAL knmin
+      REAL kmmin
+c.......................................................................
+      INTEGER ilay,ilev,igrid
+      REAL tmp1,tmp2
+c.......................................................................
+      PARAMETER (kappa=0.4E+0)
+      PARAMETER (long00=160.E+0)
+c     PARAMETER (gnmin=-10.E+0)
+      PARAMETER (gnmin=-0.28)
+      PARAMETER (gnmax=0.0233E+0)
+      PARAMETER (a1=0.92E+0)
+      PARAMETER (a2=0.74E+0)
+      PARAMETER (b1=16.6E+0)
+      PARAMETER (b2=10.1E+0)
+      PARAMETER (c1=0.08E+0)
+      PARAMETER (knmin=1.E-5)
+      PARAMETER (kmmin=1.E-5)
+      PARAMETER (q2min=1.e-5)
+      PARAMETER (q2max=1.E+2)
+cym      PARAMETER (nlay=klev)
+cym      PARAMETER (nlev=klev+1)
+c
+      PARAMETER (
+     &  cn1=a2*(1.E+0 -6.E+0 *a1/b1)
+     &          )
+      PARAMETER (
+     &  cn2=-3.E+0 *a2*(6.E+0 *a1+b2)
+     &          )
+      PARAMETER (
+     &  cm1=a1*(1.E+0 -3.E+0 *c1-6.E+0 *a1/b1)
+     &          )
+      PARAMETER (
+     &  cm2=a1*(-3.E+0 *a2*((b2-3.E+0 *a2)*(1.E+0 -6.E+0 *a1/b1)
+     &          -3.E+0 *c1*(b2+6.E+0 *a1)))
+     &          )
+      PARAMETER (
+     &  cm3=-3.E+0 *a2*(6.E+0 *a1+b2)
+     &          )
+      PARAMETER (
+     &  cm4=-9.E+0 *a1*a2
+     &          )
+
+      logical first
+      save first
+      data first/.true./
+c$OMP THREADPRIVATE(first)
+c.......................................................................
+c  traitment des valeur de q2 en entree
+c.......................................................................
+c
+c   Initialisation de q2
+      nlay=klev
+      nlev=klev+1
+       
+      call yamada(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2diag,km,kn,ustar
+     s   ,l_mix)
+      if (first.and.1.eq.1) then
+      first=.false.
+      q2=q2diag
+      endif
+
+      DO ilev=1,nlev
+                                                      DO igrid=1,ngrid 
+        q2(igrid,ilev)=amax1(q2(igrid,ilev),q2min)
+        q(igrid,ilev)=sqrt(q2(igrid,ilev))
+                                                      ENDDO
+      ENDDO
+c
+                                                      DO igrid=1,ngrid 
+      tmp1=cd(igrid)*(u(igrid,1)**2+v(igrid,1)**2)
+      q2(igrid,1)=b1**(2.E+0/3.E+0)*tmp1
+      q2(igrid,1)=amax1(q2(igrid,1),q2min)
+      q(igrid,1)=sqrt(q2(igrid,1))
+                                                      ENDDO
+c
+c.......................................................................
+c  les increments verticaux
+c.......................................................................
+c
+c!!!!! allerte !!!!!c
+c!!!!! zlev n'est pas declare a nlev !!!!!c
+c!!!!! ---->
+                                                      DO igrid=1,ngrid 
+            zlev(igrid,nlev)=zlay(igrid,nlay)
+     &             +( zlay(igrid,nlay) - zlev(igrid,nlev-1) )
+                                                      ENDDO            
+c!!!!! <----
+c!!!!! allerte !!!!!c
+c
+      DO ilay=1,nlay
+                                                      DO igrid=1,ngrid 
+        unsdz(igrid,ilay)=1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay))
+                                                      ENDDO
+      ENDDO
+                                                      DO igrid=1,ngrid 
+      unsdzdec(igrid,1)=1.E+0/(zlay(igrid,1)-zlev(igrid,1))
+                                                      ENDDO
+      DO ilay=2,nlay
+                                                      DO igrid=1,ngrid 
+        unsdzdec(igrid,ilay)=1.E+0/(zlay(igrid,ilay)-zlay(igrid,ilay-1))
+                                                      ENDDO
+      ENDDO
+                                                      DO igrid=1,ngrid 
+      unsdzdec(igrid,nlay+1)=1.E+0/(zlev(igrid,nlay+1)-zlay(igrid,nlay))
+                                                      ENDDO
+c
+c.......................................................................
+c  le cisaillement et le gradient de temperature
+c.......................................................................
+c
+                                                      DO igrid=1,ngrid 
+      m2(igrid,1)=(unsdzdec(igrid,1)
+     &                   *u(igrid,1))**2
+     &                 +(unsdzdec(igrid,1)
+     &                   *v(igrid,1))**2
+      m(igrid,1)=sqrt(m2(igrid,1))
+      mpre(igrid,1)=m(igrid,1)
+                                                      ENDDO
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        n2(igrid,ilev)=g*unsdzdec(igrid,ilev)
+     &                   *(teta(igrid,ilev)-teta(igrid,ilev-1))
+     &                   /(teta(igrid,ilev)+teta(igrid,ilev-1)) *2.E+0
+c       n2(igrid,ilev)=0.
+c
+c --->
+c       on ne sais traiter que les cas stratifies. et l'ajustement
+c       convectif est cense faire en sorte que seul des configurations
+c       stratifiees soient rencontrees en entree de cette routine.
+c       mais, bon ... on sait jamais (meme on sait que n2 prends
+c       quelques valeurs negatives ... parfois) alors : 
+c<---
+c
+        IF (n2(igrid,ilev).lt.0.E+0) THEN
+          n2(igrid,ilev)=0.E+0
+        ENDIF
+c
+        m2(igrid,ilev)=(unsdzdec(igrid,ilev)
+     &                     *(u(igrid,ilev)-u(igrid,ilev-1)))**2
+     &                   +(unsdzdec(igrid,ilev)
+     &                     *(v(igrid,ilev)-v(igrid,ilev-1)))**2
+        m(igrid,ilev)=sqrt(m2(igrid,ilev))
+        mpre(igrid,ilev)=m(igrid,ilev)
+c
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+                                                      DO igrid=1,ngrid 
+      m2(igrid,nlev)=m2(igrid,nlev-1)
+      m(igrid,nlev)=m(igrid,nlev-1)
+      mpre(igrid,nlev)=m(igrid,nlev)
+                                                      ENDDO
+c
+c.......................................................................
+c  calcul des fonctions de stabilite
+c.......................................................................
+c
+      if (l_mix.eq.4) then
+                                                      DO igrid=1,ngrid 
+         sqz(igrid)=1.e-10
+         sq(igrid)=1.e-10
+                                                      ENDDO
+         do ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+           zq=sqrt(q2(igrid,ilev))
+           sqz(igrid)
+     .     =sqz(igrid)+zq*zlev(igrid,ilev)
+     .     *(zlay(igrid,ilev)-zlay(igrid,ilev-1))
+           sq(igrid)=sq(igrid)+zq*(zlay(igrid,ilev)-zlay(igrid,ilev-1))
+                                                      ENDDO
+         enddo
+                                                      DO igrid=1,ngrid 
+         long0(igrid)=0.2*sqz(igrid)/sq(igrid)
+                                                      ENDDO
+      else if (l_mix.eq.3) then
+         long0(igrid)=long00
+      endif
+
+c (abd 5 2)      print*,'LONG0=',long0
+
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        tmp1=kappa*(zlev(igrid,ilev)-zlev(igrid,1))
+        if (l_mix.ge.10) then
+            long(igrid,ilev)=l_mix
+        else
+           long(igrid,ilev)=tmp1/(1.E+0 + tmp1/long0(igrid))
+        endif
+        long(igrid,ilev)=max(min(long(igrid,ilev)
+     s    ,0.5*sqrt(q2(igrid,ilev))/sqrt(max(n2(igrid,ilev),1.e-10)))
+     s    ,5.)
+
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        gm=long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * m2(igrid,ilev)
+c
+        gninf=.false.
+        gnsup=.false.
+        long(igrid,ilev)=long(igrid,ilev)
+        long(igrid,ilev)=long(igrid,ilev)
+c
+        IF (gn.lt.gnmin) THEN
+          gninf=.true.
+          gn=gnmin
+        ENDIF
+c
+        IF (gn.gt.gnmax) THEN
+          gnsup=.true.
+          gn=gnmax
+        ENDIF
+c
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)
+     &     *(1.E+0 +cm4*gn) )
+c
+        IF ((gninf).or.(gnsup)) THEN
+          snq2(igrid,ilev)=0.E+0
+          smq2(igrid,ilev)=0.E+0
+        ELSE
+          snq2(igrid,ilev)=
+     &     -gn
+     &     *(-cn1*cn2/(1.E+0 +cn2*gn)**2 )
+          smq2(igrid,ilev)=
+     &     -gn
+     &     *( cm2*(1.E+0 +cm3*gn)
+     &           *(1.E+0 +cm4*gn)
+     &       -( cm3*(1.E+0 +cm4*gn)
+     &         +cm4*(1.E+0 +cm3*gn) )
+     &       *(cm1+cm2*gn)            )
+     &     /( (1.E+0 +cm3*gn)
+     &       *(1.E+0 +cm4*gn) )**2
+        ENDIF
+c
+c abd
+c        if(ilev.le.57.and.ilev.ge.37) then
+c            print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
+c        endif
+c --->
+c       la decomposition de Taylor en q2 n'a de sens que
+c       dans les cas stratifies ou sn et sm sont quasi
+c       proportionnels a q2. ailleurs on laisse le meme
+c       algorithme car l'ajustement convectif fait le travail.
+c       mais c'est delirant quand sn et snq2 n'ont pas le meme
+c       signe : dans ces cas, on ne fait pas la decomposition.
+c<---
+c
+        IF (snq2(igrid,ilev)*sn(igrid,ilev).le.0.E+0)
+     &      snq2(igrid,ilev)=0.E+0
+        IF (smq2(igrid,ilev)*sm(igrid,ilev).le.0.E+0)
+     &      smq2(igrid,ilev)=0.E+0
+c
+C   Correction pour les couches stables.
+C   Schema repris de JHoltzlag Boville, lui meme venant de...
+
+        if (1.eq.1) then
+        snstable=1.-zlev(igrid,ilev)
+     s     /(700.*max(ustar(igrid),0.0001))
+        snstable=1.-zlev(igrid,ilev)/400.
+        snstable=max(snstable,0.)
+        snstable=snstable*snstable
+
+c abde       print*,'SN ',ilev,sn(1,ilev),snstable
+        if (sn(igrid,ilev).lt.snstable) then
+           sn(igrid,ilev)=snstable
+           snq2(igrid,ilev)=0.
+        endif
+
+        if (sm(igrid,ilev).lt.snstable) then
+           sm(igrid,ilev)=snstable
+           smq2(igrid,ilev)=0.
+        endif
+
+        endif
+
+c sn : coefficient de stabilite pour n
+c snq2 : premier terme du developement limite de sn en q2
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+c.......................................................................
+c  calcul de km et kn au debut du pas de temps
+c.......................................................................
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,1)=knmin
+      km(igrid,1)=kmmin
+      kmpre(igrid,1)=km(igrid,1)
+                                                      ENDDO
+c
+c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+c-----------------------------------------------------------------------
+c
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                                         *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                                         *sm(igrid,ilev)
+        kmpre(igrid,ilev)=km(igrid,ilev)
+c
+c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+c-----------------------------------------------------------------------
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,nlev)=kn(igrid,nlev-1)
+      km(igrid,nlev)=km(igrid,nlev-1)
+      kmpre(igrid,nlev)=km(igrid,nlev)
+                                                      ENDDO
+c
+c.......................................................................
+c  boucle sur les niveaux 2 a nlev-1
+c.......................................................................
+c
+c---->
+      DO 10001 ilev=2,nlev-1
+c---->
+      DO 10002 igrid=1,ngrid 
+c
+c.......................................................................
+c
+c  calcul des termes sources et puits de l'equation de q2
+c  ------------------------------------------------------
+c
+        knq3=kn(igrid,ilev)*snq2(igrid,ilev)
+     &                                    /sn(igrid,ilev)
+        kmq3=km(igrid,ilev)*smq2(igrid,ilev)
+     &                                    /sm(igrid,ilev)
+c
+        termq=0.E+0
+        termq3=0.E+0
+        termqm2=0.E+0
+        termq3m2=0.E+0
+c
+        tmp1=dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)
+        tmp2=dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termqm2=termqm2
+     &    +dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)
+     &    -dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termq3m2=termq3m2
+     &    +dt*2.E+0 *kmq3*m2(igrid,ilev)
+c 
+        termq=termq
+     &    -dt*2.E+0 *kn(igrid,ilev)*n2(igrid,ilev)
+     &    +dt*2.E+0 *knq3*n2(igrid,ilev)
+        termq3=termq3
+     &    -dt*2.E+0 *knq3*n2(igrid,ilev)
+c
+        termq3=termq3
+     &    -dt*2.E+0 *q(igrid,ilev)**3 / (b1*long(igrid,ilev))
+c
+c.......................................................................
+c
+c  resolution stationnaire couplee avec le gradient de vitesse local
+c  -----------------------------------------------------------------
+c
+c  -----{on cherche le cisaillement qui annule l'equation de q^2
+c        supposee en q3}
+c
+        tmp1=termq+termq3
+        tmp2=termqm2+termq3m2
+        m2cstat=m2(igrid,ilev)
+     &      -(tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev))
+        mcstat=sqrt(m2cstat)
+
+c  abde      print*,'M2 L=',ilev,mpre(igrid,ilev),mcstat
+c
+c  -----{puis on ecrit la valeur de q qui annule l'equation de m
+c        supposee en q3}
+c
+        IF (ilev.eq.2) THEN
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)
+     &                        *mpre(igrid,ilev+1)
+     &      +unsdz(igrid,ilev-1)
+     &              *cd(igrid)
+     &              *( sqrt(u(igrid,3)**2+v(igrid,3)**2)
+     &                -mcstat/unsdzdec(igrid,ilev)
+     &                -mpre(igrid,ilev+1)/unsdzdec(igrid,ilev+1) )**2)
+     &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ELSE
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)
+     &                        *mpre(igrid,ilev+1)
+     &      +unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1)
+     &                          *mpre(igrid,ilev-1) )
+     &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ENDIF
+        tmp2=kmcstat
+     &      /( sm(igrid,ilev)/q2(igrid,ilev) )
+     &      /long(igrid,ilev)
+        qcstat=tmp2**(1.E+0/3.E+0)
+        q2cstat=qcstat**2
+c
+c.......................................................................
+c
+c  choix de la solution finale
+c  ---------------------------
+c
+          q(igrid,ilev)=qcstat
+          q2(igrid,ilev)=q2cstat
+          m(igrid,ilev)=mcstat
+c abd       if(ilev.le.57.and.ilev.ge.37) then
+c           print*,'L=',ilev,'   M2=',m2(igrid,ilev),m2cstat,
+c     s     'N2=',n2(igrid,ilev)
+c abd       endif
+          m2(igrid,ilev)=m2cstat
+c
+c --->
+c       pour des raisons simples q2 est minore 
+c<---
+c
+        IF (q2(igrid,ilev).lt.q2min) THEN
+          q2(igrid,ilev)=q2min
+          q(igrid,ilev)=sqrt(q2min)
+        ENDIF
+c
+c.......................................................................
+c
+c  calcul final de kn et km
+c  ------------------------
+c
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        IF (gn.lt.gnmin) gn=gnmin
+        IF (gn.gt.gnmax) gn=gnmax
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) )
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sm(igrid,ilev)
+c abd
+c        if(ilev.le.57.and.ilev.ge.37) then
+c            print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
+c        endif
+c
+c.......................................................................
+c
+10002 CONTINUE
+c
+10001 CONTINUE
+c
+c.......................................................................
+c
+c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,1)=knmin
+      km(igrid,1)=kmmin
+c     kn(igrid,1)=cd(igrid)
+c     km(igrid,1)=cd(igrid)
+      q2(igrid,nlev)=q2(igrid,nlev-1)
+      q(igrid,nlev)=q(igrid,nlev-1)
+      kn(igrid,nlev)=kn(igrid,nlev-1)
+      km(igrid,nlev)=km(igrid,nlev-1)
+                                                      ENDDO
+c
+c  CALCUL DE LA DIFFUSION VERTICALE DE Q2
+      if (1.eq.1) then
+
+        do ilev=2,klev-1
+           sss=sss+plev(1,ilev-1)-plev(1,ilev+1)
+           sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev)
+        enddo
+c        print*,'Q2moy avant',sssq/sss
+c       print*,'Q2q20 ',(q2(1,ilev),ilev=1,10)
+c       print*,'Q2km0 ',(km(1,ilev),ilev=1,10)
+c   ! C'est quoi ca qu'etait dans l'original???
+c       do igrid=1,ngrid
+c          q2(igrid,1)=10.
+c       enddo
+c        q2s=q2
+c       do iii=1,10
+c       call vdif_q2(dt,g,rconst,plev,temp,km,q2)
+c       do ilev=1,klev+1
+c          write(iii+49,*) q2(1,ilev),zlev(1,ilev)
+c       enddo
+c       enddo
+c       stop
+c       do ilev=1,klev
+c          print*,zlev(1,ilev),q2s(1,ilev),q2(1,ilev)
+c       enddo
+c        q2s=q2-q2s
+c       do ilev=1,klev
+c          print*,q2s(1,ilev),zlev(1,ilev)
+c       enddo
+        do ilev=2,klev-1
+           sss=sss+plev(1,ilev-1)-plev(1,ilev+1)
+           sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev)
+        enddo
+        print*,'Q2moy apres',sssq/sss
+c
+c
+        do ilev=1,nlev
+           do igrid=1,ngrid
+              q2(igrid,ilev)=max(q2(igrid,ilev),q2min)
+              q(igrid,ilev)=sqrt(q2(igrid,ilev))
+
+c.......................................................................
+c
+c  calcul final de kn et km
+c  ------------------------
+c
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)
+     &                                           * n2(igrid,ilev)
+        IF (gn.lt.gnmin) gn=gnmin
+        IF (gn.gt.gnmax) gn=gnmax
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=
+     &    (cm1+cm2*gn)
+     &   /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) )
+C   Correction pour les couches stables.
+C   Schema repris de JHoltzlag Boville, lui meme venant de...
+
+        if (1.eq.1) then
+        snstable=1.-zlev(igrid,ilev)
+     s     /(700.*max(ustar(igrid),0.0001))
+        snstable=1.-zlev(igrid,ilev)/400.
+        snstable=max(snstable,0.)
+        snstable=snstable*snstable
+
+c abde      print*,'SN ',ilev,sn(1,ilev),snstable
+        if (sn(igrid,ilev).lt.snstable) then
+           sn(igrid,ilev)=snstable
+           snq2(igrid,ilev)=0.
+        endif
+
+        if (sm(igrid,ilev).lt.snstable) then
+           sm(igrid,ilev)=snstable
+           smq2(igrid,ilev)=0.
+        endif
+
+        endif
+
+c sn : coefficient de stabilite pour n
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+     &                 *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+c
+           enddo
+        enddo
+c       print*,'Q2km1 ',(km(1,ilev),ilev=1,10)
+
+      endif
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/vdif_kcay.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/vdif_kcay.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/vdif_kcay.F90	(revision 17)
@@ -0,0 +1,743 @@
+!
+! $Header$
+!
+      SUBROUTINE vdif_kcay(ngrid,dt,g,rconst,plev,temp                               &
+       &   ,zlev,zlay,u,v,teta,cd,q2,q2diag,km,kn,ustar                              &
+       &   ,l_mix)
+      use dimphy
+      IMPLICIT NONE
+!c.......................................................................
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!c.......................................................................
+!c
+!c dt : pas de temps
+!c g  : g
+!c zlev : altitude a chaque niveau (interface inferieure de la couche
+!c        de meme indice)
+!c zlay : altitude au centre de chaque couche
+!c u,v : vitesse au centre de chaque couche
+!c       (en entree : la valeur au debut du pas de temps)
+!c teta : temperature potentielle au centre de chaque couche
+!c        (en entree : la valeur au debut du pas de temps)
+!c cd : cdrag
+!c      (en entree : la valeur au debut du pas de temps)
+!c q2 : $q^2$ au bas de chaque couche
+!c      (en entree : la valeur au debut du pas de temps)
+!c      (en sortie : la valeur a la fin du pas de temps)
+!c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+!c      couche)
+!c      (en sortie : la valeur a la fin du pas de temps)
+!c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+!c      (en sortie : la valeur a la fin du pas de temps)
+!c 
+!c.......................................................................
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon),snstable
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1),q2s(klon,klev+1)
+      REAL q2diag(klon,klev+1)
+      REAL km(klon,klev+1)
+      REAL kn(klon,klev+1)
+      real sq(klon),sqz(klon),zz(klon,klev+1),zq,long0(klon)
+
+      integer l_mix,iii
+!c.......................................................................
+!c
+!c nlay : nombre de couches        
+!c nlev : nombre de niveaux
+!c ngrid : nombre de points de grille       
+!c unsdz : 1 sur l'epaisseur de couche
+!c unsdzdec : 1 sur la distance entre le centre de la couche et le
+!c            centre de la couche inferieure
+!c q : echelle de vitesse au bas de chaque couche
+!c     (valeur a la fin du pas de temps)
+!c
+!c.......................................................................
+      INTEGER nlay,nlev,ngrid
+      REAL unsdz(klon,klev)
+      REAL unsdzdec(klon,klev+1)
+      REAL q(klon,klev+1)
+
+!c.......................................................................
+!c
+!c kmpre : km au debut du pas de temps
+!c qcstat : q : solution stationnaire du probleme couple
+!c          (valeur a la fin du pas de temps)
+!c q2cstat : q2 : solution stationnaire du probleme couple
+!c           (valeur a la fin du pas de temps)
+!c
+!c.......................................................................
+      REAL kmpre(klon,klev+1)
+      REAL qcstat
+      REAL q2cstat
+      real sss,sssq
+!c.......................................................................
+!c
+!c long : longueur de melange calculee selon Blackadar
+!c
+!c.......................................................................
+      REAL long(klon,klev+1)
+!c.......................................................................
+!c
+!c kmq3 : terme en q^3 dans le developpement de km
+!c        (valeur au debut du pas de temps)
+!c kmcstat : valeur de km solution stationnaire du systeme {q2 ; du/dz}
+!c           (valeur a la fin du pas de temps)
+!c knq3 : terme en q^3 dans le developpement de kn
+!c mcstat : valeur de m solution stationnaire du systeme {q2 ; du/dz}
+!c          (valeur a la fin du pas de temps)
+!c m2cstat : valeur de m2 solution stationnaire du systeme {q2 ; du/dz}
+!c           (valeur a la fin du pas de temps)
+!c m : valeur a la fin du pas de temps
+!c mpre : valeur au debut du pas de temps
+!c m2 : valeur a la fin du pas de temps
+!c n2 : valeur a la fin du pas de temps
+!c 
+!c.......................................................................
+      REAL kmq3
+      REAL kmcstat
+      REAL knq3
+      REAL mcstat
+      REAL m2cstat
+      REAL m(klon,klev+1)
+      REAL mpre(klon,klev+1)
+      REAL m2(klon,klev+1)
+      REAL n2(klon,klev+1)
+!c.......................................................................
+!c
+!c gn : intermediaire pour les coefficients de stabilite
+!c gnmin : borne inferieure de gn (-0.23 ou -0.28)
+!c gnmax : borne superieure de gn (0.0233)
+!c gninf : vrai si gn est en dessous de sa borne inferieure
+!c gnsup : vrai si gn est en dessus de sa borne superieure
+!c gm : drole d'objet bien utile
+!c ri : nombre de Richardson
+!c sn : coefficient de stabilite pour n
+!c snq2 : premier terme du developement limite de sn en q2
+!c sm : coefficient de stabilite pour m
+!c smq2 : premier terme du developement limite de sm en q2
+!c
+!c.......................................................................
+      REAL gn
+      REAL gnmin
+      REAL gnmax
+      LOGICAL gninf
+      LOGICAL gnsup
+      REAL gm
+!c      REAL ri(klon,klev+1)
+      REAL sn(klon,klev+1)
+      REAL snq2(klon,klev+1)
+      REAL sm(klon,klev+1)
+      REAL smq2(klon,klev+1)
+!c.......................................................................
+!c
+!c kappa : consatnte de Von Karman (0.4)
+!c long00 : longueur de reference pour le calcul de long (160)
+!c a1,a2,b1,b2,c1 : constantes d'origine pour les  coefficients
+!c                  de stabilite (0.92/0.74/16.6/10.1/0.08)
+!c cn1,cn2 : constantes pour sn
+!c cm1,cm2,cm3,cm4 : constantes pour sm
+!c
+!c.......................................................................
+      REAL kappa
+      REAL long00
+      REAL a1,a2,b1,b2,c1
+      REAL cn1,cn2
+      REAL cm1,cm2,cm3,cm4
+!c.......................................................................
+!c
+!c termq : termes en $q$ dans l'equation de q2
+!c termq3 : termes en $q^3$ dans l'equation de q2
+!c termqm2 : termes en $q*m^2$ dans l'equation de q2
+!c termq3m2 : termes en $q^3*m^2$ dans l'equation de q2
+!c
+!c.......................................................................
+      REAL termq
+      REAL termq3
+      REAL termqm2
+      REAL termq3m2
+!c.......................................................................
+!c
+!c q2min : borne inferieure de q2
+!c q2max : borne superieure de q2
+!c
+!c.......................................................................
+      REAL q2min
+      REAL q2max
+!c.......................................................................
+!c knmin : borne inferieure de kn
+!c kmmin : borne inferieure de km
+!c.......................................................................
+      REAL knmin
+      REAL kmmin
+!c.......................................................................
+      INTEGER ilay,ilev,igrid
+      REAL tmp1,tmp2
+!c.......................................................................
+      PARAMETER (kappa=0.4E+0)
+      PARAMETER (long00=160.E+0)
+!c     PARAMETER (gnmin=-10.E+0)
+      PARAMETER (gnmin=-0.28)
+      PARAMETER (gnmax=0.0233E+0)
+      PARAMETER (a1=0.92E+0)
+      PARAMETER (a2=0.74E+0)
+      PARAMETER (b1=16.6E+0)
+      PARAMETER (b2=10.1E+0)
+      PARAMETER (c1=0.08E+0)
+      PARAMETER (knmin=1.E-5)
+      PARAMETER (kmmin=1.E-5)
+      PARAMETER (q2min=1.e-5)
+      PARAMETER (q2max=1.E+2)
+!cym      PARAMETER (nlay=klev)
+!cym      PARAMETER (nlev=klev+1)
+!c
+      PARAMETER (                                                                    &
+       &  cn1=a2*(1.E+0 -6.E+0 *a1/b1)                                               &
+       &          )
+      PARAMETER (                                                                    &
+       &  cn2=-3.E+0 *a2*(6.E+0 *a1+b2)                                              &
+       &          )
+      PARAMETER (                                                                    &
+       &  cm1=a1*(1.E+0 -3.E+0 *c1-6.E+0 *a1/b1)                                     &
+       &          )
+      PARAMETER (                                                                    &
+       &  cm2=a1*(-3.E+0 *a2*((b2-3.E+0 *a2)*(1.E+0 -6.E+0 *a1/b1)                   &
+       &          -3.E+0 *c1*(b2+6.E+0 *a1)))                                        &
+       &          )
+      PARAMETER (                                                                    &
+       &  cm3=-3.E+0 *a2*(6.E+0 *a1+b2)                                              &
+       &          )
+      PARAMETER (                                                                    &
+       &  cm4=-9.E+0 *a1*a2                                                          &
+       &          )
+
+      logical first
+      save first
+      data first/.true./
+!$OMP THREADPRIVATE(first)
+!c.......................................................................
+!c  traitment des valeur de q2 en entree
+!c.......................................................................
+!c
+!c   Initialisation de q2
+      nlay=klev
+      nlev=klev+1
+       
+      call yamada(ngrid,dt,g,rconst,plev,temp                                        &
+       &   ,zlev,zlay,u,v,teta,cd,q2diag,km,kn,ustar                                 &
+       &   ,l_mix)
+      if (first.and.1.eq.1) then
+      first=.false.
+      q2=q2diag
+      endif
+
+      DO ilev=1,nlev
+                                                      DO igrid=1,ngrid 
+        q2(igrid,ilev)=amax1(q2(igrid,ilev),q2min)
+        q(igrid,ilev)=sqrt(q2(igrid,ilev))
+                                                      ENDDO
+      ENDDO
+!c
+                                                      DO igrid=1,ngrid 
+      tmp1=cd(igrid)*(u(igrid,1)**2+v(igrid,1)**2)
+      q2(igrid,1)=b1**(2.E+0/3.E+0)*tmp1
+      q2(igrid,1)=amax1(q2(igrid,1),q2min)
+      q(igrid,1)=sqrt(q2(igrid,1))
+                                                      ENDDO
+!c
+!c.......................................................................
+!c  les increments verticaux
+!c.......................................................................
+!c
+!c!!!!! allerte !!!!!c
+!c!!!!! zlev n'est pas declare a nlev !!!!!c
+!c!!!!! ---->
+                                                      DO igrid=1,ngrid 
+            zlev(igrid,nlev)=zlay(igrid,nlay)                                        &
+       &             +( zlay(igrid,nlay) - zlev(igrid,nlev-1) )
+                                                      ENDDO            
+!c!!!!! <----
+!c!!!!! allerte !!!!!c
+!c
+      DO ilay=1,nlay
+                                                      DO igrid=1,ngrid 
+        unsdz(igrid,ilay)=1.E+0/(zlev(igrid,ilay+1)-zlev(igrid,ilay))
+                                                      ENDDO
+      ENDDO
+                                                      DO igrid=1,ngrid 
+      unsdzdec(igrid,1)=1.E+0/(zlay(igrid,1)-zlev(igrid,1))
+                                                      ENDDO
+      DO ilay=2,nlay
+                                                      DO igrid=1,ngrid 
+        unsdzdec(igrid,ilay)=1.E+0/(zlay(igrid,ilay)-zlay(igrid,ilay-1))
+                                                      ENDDO
+      ENDDO
+                                                      DO igrid=1,ngrid 
+      unsdzdec(igrid,nlay+1)=1.E+0/(zlev(igrid,nlay+1)-zlay(igrid,nlay))
+                                                      ENDDO
+!c
+!c.......................................................................
+!c  le cisaillement et le gradient de temperature
+!c.......................................................................
+!c
+                                                      DO igrid=1,ngrid 
+      m2(igrid,1)=(unsdzdec(igrid,1)                                                 &
+       &                   *u(igrid,1))**2                                           &
+       &                 +(unsdzdec(igrid,1)                                         &
+       &                   *v(igrid,1))**2
+      m(igrid,1)=sqrt(m2(igrid,1))
+      mpre(igrid,1)=m(igrid,1)
+                                                      ENDDO
+!c
+!c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+!c-----------------------------------------------------------------------
+!c
+        n2(igrid,ilev)=g*unsdzdec(igrid,ilev)                                        &
+       &                   *(teta(igrid,ilev)-teta(igrid,ilev-1))                    &
+       &                   /(teta(igrid,ilev)+teta(igrid,ilev-1)) *2.E+0
+!c       n2(igrid,ilev)=0.
+!c
+!c --->
+!c       on ne sais traiter que les cas stratifies. et l'ajustement
+!c       convectif est cense faire en sorte que seul des configurations
+!c       stratifiees soient rencontrees en entree de cette routine.
+!c       mais, bon ... on sait jamais (meme on sait que n2 prends
+!c       quelques valeurs negatives ... parfois) alors : 
+!c<---
+!c
+        IF (n2(igrid,ilev).lt.0.E+0) THEN
+          n2(igrid,ilev)=0.E+0
+        ENDIF
+!c
+        m2(igrid,ilev)=(unsdzdec(igrid,ilev)                                         &
+       &                     *(u(igrid,ilev)-u(igrid,ilev-1)))**2                    &
+       &                   +(unsdzdec(igrid,ilev)                                    &
+       &                     *(v(igrid,ilev)-v(igrid,ilev-1)))**2
+        m(igrid,ilev)=sqrt(m2(igrid,ilev))
+        mpre(igrid,ilev)=m(igrid,ilev)
+!c
+!c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+!c-----------------------------------------------------------------------
+!c
+                                                      DO igrid=1,ngrid 
+      m2(igrid,nlev)=m2(igrid,nlev-1)
+      m(igrid,nlev)=m(igrid,nlev-1)
+      mpre(igrid,nlev)=m(igrid,nlev)
+                                                      ENDDO
+!c
+!c.......................................................................
+!c  calcul des fonctions de stabilite
+!c.......................................................................
+!c
+      if (l_mix.eq.4) then
+                                                      DO igrid=1,ngrid 
+         sqz(igrid)=1.e-10
+         sq(igrid)=1.e-10
+                                                      ENDDO
+         do ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+           zq=sqrt(q2(igrid,ilev))
+           sqz(igrid)                                                                &
+       &     =sqz(igrid)+zq*zlev(igrid,ilev)                                         &
+       &     *(zlay(igrid,ilev)-zlay(igrid,ilev-1))
+           sq(igrid)=sq(igrid)+zq*(zlay(igrid,ilev)-zlay(igrid,ilev-1))
+                                                      ENDDO
+         enddo
+                                                      DO igrid=1,ngrid 
+         long0(igrid)=0.2*sqz(igrid)/sq(igrid)
+                                                      ENDDO
+      else if (l_mix.eq.3) then
+         long0(igrid)=long00
+      endif
+
+!c (abd 5 2)      print*,'LONG0=',long0
+
+!c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+!c-----------------------------------------------------------------------
+!c
+        tmp1=kappa*(zlev(igrid,ilev)-zlev(igrid,1))
+        if (l_mix.ge.10) then
+            long(igrid,ilev)=l_mix
+        else
+           long(igrid,ilev)=tmp1/(1.E+0 + tmp1/long0(igrid))
+        endif
+        long(igrid,ilev)=max(min(long(igrid,ilev)                                    &
+       &    ,0.5*sqrt(q2(igrid,ilev))/sqrt(max(n2(igrid,ilev),1.e-10)))              &
+       &    ,5.)
+
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)                                     &
+       &                                           * n2(igrid,ilev)
+        gm=long(igrid,ilev)**2 / q2(igrid,ilev)                                      &
+       &                                           * m2(igrid,ilev)
+!c
+        gninf=.false.
+        gnsup=.false.
+        long(igrid,ilev)=long(igrid,ilev)
+        long(igrid,ilev)=long(igrid,ilev)
+!c
+        IF (gn.lt.gnmin) THEN
+          gninf=.true.
+          gn=gnmin
+        ENDIF
+!c
+        IF (gn.gt.gnmax) THEN
+          gnsup=.true.
+          gn=gnmax
+        ENDIF
+!c
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=                                                              &
+       &    (cm1+cm2*gn)                                                             &
+       &   /( (1.E+0 +cm3*gn)                                                        &
+       &     *(1.E+0 +cm4*gn) )
+!c
+        IF ((gninf).or.(gnsup)) THEN
+          snq2(igrid,ilev)=0.E+0
+          smq2(igrid,ilev)=0.E+0
+        ELSE
+          snq2(igrid,ilev)=                                                          &
+       &     -gn                                                                     &
+       &     *(-cn1*cn2/(1.E+0 +cn2*gn)**2 )
+          smq2(igrid,ilev)=                                                          &
+       &     -gn                                                                     &
+       &     *( cm2*(1.E+0 +cm3*gn)                                                  &
+       &           *(1.E+0 +cm4*gn)                                                  &
+       &       -( cm3*(1.E+0 +cm4*gn)                                                &
+       &         +cm4*(1.E+0 +cm3*gn) )                                              &
+       &       *(cm1+cm2*gn)            )                                            &
+       &     /( (1.E+0 +cm3*gn)                                                      &
+       &       *(1.E+0 +cm4*gn) )**2
+        ENDIF
+!c
+!c abd
+!c        if(ilev.le.57.and.ilev.ge.37) then
+!c            print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
+!c        endif
+!c --->
+!c       la decomposition de Taylor en q2 n'a de sens que
+!c       dans les cas stratifies ou sn et sm sont quasi
+!c       proportionnels a q2. ailleurs on laisse le meme
+!c       algorithme car l'ajustement convectif fait le travail.
+!c       mais c'est delirant quand sn et snq2 n'ont pas le meme
+!c       signe : dans ces cas, on ne fait pas la decomposition.
+!c<---
+!c
+        IF (snq2(igrid,ilev)*sn(igrid,ilev).le.0.E+0)                                &
+       &      snq2(igrid,ilev)=0.E+0
+        IF (smq2(igrid,ilev)*sm(igrid,ilev).le.0.E+0)                                &
+       &      smq2(igrid,ilev)=0.E+0
+!c
+!C   Correction pour les couches stables.
+!C   Schema repris de JHoltzlag Boville, lui meme venant de...
+
+        if (1.eq.1) then
+        snstable=1.-zlev(igrid,ilev)                                                 &
+       &     /(700.*max(ustar(igrid),0.0001))
+        snstable=1.-zlev(igrid,ilev)/400.
+        snstable=max(snstable,0.)
+        snstable=snstable*snstable
+
+!c abde       print*,'SN ',ilev,sn(1,ilev),snstable
+        if (sn(igrid,ilev).lt.snstable) then
+           sn(igrid,ilev)=snstable
+           snq2(igrid,ilev)=0.
+        endif
+
+        if (sm(igrid,ilev).lt.snstable) then
+           sm(igrid,ilev)=snstable
+           smq2(igrid,ilev)=0.
+        endif
+
+        endif
+
+!c sn : coefficient de stabilite pour n
+!c snq2 : premier terme du developement limite de sn en q2
+!c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+!c-----------------------------------------------------------------------
+!c
+!c.......................................................................
+!c  calcul de km et kn au debut du pas de temps
+!c.......................................................................
+!c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,1)=knmin
+      km(igrid,1)=kmmin
+      kmpre(igrid,1)=km(igrid,1)
+                                                      ENDDO
+!c
+!c-----------------------------------------------------------------------
+      DO ilev=2,nlev-1
+                                                      DO igrid=1,ngrid 
+!c-----------------------------------------------------------------------
+!c
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)                                &
+       &                                         *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)                                &
+       &                                         *sm(igrid,ilev)
+        kmpre(igrid,ilev)=km(igrid,ilev)
+!c
+!c-----------------------------------------------------------------------
+                                                      ENDDO
+      ENDDO
+!c-----------------------------------------------------------------------
+!c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,nlev)=kn(igrid,nlev-1)
+      km(igrid,nlev)=km(igrid,nlev-1)
+      kmpre(igrid,nlev)=km(igrid,nlev)
+                                                      ENDDO
+!c
+!c.......................................................................
+!c  boucle sur les niveaux 2 a nlev-1
+!c.......................................................................
+!c
+!c---->
+      DO 10001 ilev=2,nlev-1
+!c---->
+      DO 10002 igrid=1,ngrid 
+!c
+!c.......................................................................
+!c
+!c  calcul des termes sources et puits de l'equation de q2
+!c  ------------------------------------------------------
+!c
+        knq3=kn(igrid,ilev)*snq2(igrid,ilev)                                         &
+       &                                    /sn(igrid,ilev)
+        kmq3=km(igrid,ilev)*smq2(igrid,ilev)                                         &
+       &                                    /sm(igrid,ilev)
+!c
+        termq=0.E+0
+        termq3=0.E+0
+        termqm2=0.E+0
+        termq3m2=0.E+0
+!c
+        tmp1=dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)
+        tmp2=dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termqm2=termqm2                                                              &
+       &    +dt*2.E+0 *km(igrid,ilev)*m2(igrid,ilev)                                 &
+       &    -dt*2.E+0 *kmq3*m2(igrid,ilev)
+        termq3m2=termq3m2                                                            &
+       &    +dt*2.E+0 *kmq3*m2(igrid,ilev)
+!c 
+        termq=termq                                                                  &
+       &    -dt*2.E+0 *kn(igrid,ilev)*n2(igrid,ilev)                                 &
+       &    +dt*2.E+0 *knq3*n2(igrid,ilev)
+        termq3=termq3                                                                &
+       &    -dt*2.E+0 *knq3*n2(igrid,ilev)
+!c
+        termq3=termq3                                                                &
+       &    -dt*2.E+0 *q(igrid,ilev)**3 / (b1*long(igrid,ilev))
+!c
+!c.......................................................................
+!c
+!c  resolution stationnaire couplee avec le gradient de vitesse local
+!c  -----------------------------------------------------------------
+!c
+!c  -----{on cherche le cisaillement qui annule l'equation de q^2
+!c        supposee en q3}
+!c
+        tmp1=termq+termq3
+        tmp2=termqm2+termq3m2
+        m2cstat=m2(igrid,ilev)                                                       &
+       &      -(tmp1+tmp2)/(dt*2.E+0*km(igrid,ilev))
+        mcstat=sqrt(m2cstat)
+
+!c  abde      print*,'M2 L=',ilev,mpre(igrid,ilev),mcstat
+!c
+!c  -----{puis on ecrit la valeur de q qui annule l'equation de m
+!c        supposee en q3}
+!c
+        IF (ilev.eq.2) THEN
+          kmcstat=1.E+0 / mcstat                                                     &
+       &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)                                 &
+       &                        *mpre(igrid,ilev+1)                                  &
+       &      +unsdz(igrid,ilev-1)                                                   &
+       &              *cd(igrid)                                                     &
+       &              *( sqrt(u(igrid,3)**2+v(igrid,3)**2)                           &
+       &                -mcstat/unsdzdec(igrid,ilev)                                 &
+       &                -mpre(igrid,ilev+1)/unsdzdec(igrid,ilev+1) )**2)             &
+       &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ELSE
+          kmcstat=1.E+0 / mcstat                                                     &
+       &    *( unsdz(igrid,ilev)*kmpre(igrid,ilev+1)                                 &
+       &                        *mpre(igrid,ilev+1)                                  &
+       &      +unsdz(igrid,ilev-1)*kmpre(igrid,ilev-1)                               &
+       &                          *mpre(igrid,ilev-1) )                              &
+       &      /( unsdz(igrid,ilev)+unsdz(igrid,ilev-1) )
+        ENDIF
+        tmp2=kmcstat                                                                 &
+       &      /( sm(igrid,ilev)/q2(igrid,ilev) )                                     &
+       &      /long(igrid,ilev)
+        qcstat=tmp2**(1.E+0/3.E+0)
+        q2cstat=qcstat**2
+!c
+!c.......................................................................
+!c
+!c  choix de la solution finale
+!c  ---------------------------
+!c
+          q(igrid,ilev)=qcstat
+          q2(igrid,ilev)=q2cstat
+          m(igrid,ilev)=mcstat
+!c abd       if(ilev.le.57.and.ilev.ge.37) then
+!c           print*,'L=',ilev,'   M2=',m2(igrid,ilev),m2cstat,
+!c     s     'N2=',n2(igrid,ilev)
+!c abd       endif
+          m2(igrid,ilev)=m2cstat
+!c
+!c --->
+!c       pour des raisons simples q2 est minore 
+!c<---
+!c
+        IF (q2(igrid,ilev).lt.q2min) THEN
+          q2(igrid,ilev)=q2min
+          q(igrid,ilev)=sqrt(q2min)
+        ENDIF
+!c
+!c.......................................................................
+!c
+!c  calcul final de kn et km
+!c  ------------------------
+!c
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)                                     &
+       &                                           * n2(igrid,ilev)
+        IF (gn.lt.gnmin) gn=gnmin
+        IF (gn.gt.gnmax) gn=gnmax
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=                                                              &
+       &    (cm1+cm2*gn)                                                             &
+       &   /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) )
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)                                &
+       &                 *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)                                &
+       &                 *sm(igrid,ilev)
+!c abd
+!c        if(ilev.le.57.and.ilev.ge.37) then
+!c            print*,'L=',ilev,'   GN=',gn,'  SM=',sm(igrid,ilev)
+!c        endif
+!c
+!c.......................................................................
+!c
+10002 CONTINUE
+!c
+10001 CONTINUE
+!c
+!c.......................................................................
+!c
+!c
+                                                      DO igrid=1,ngrid 
+      kn(igrid,1)=knmin
+      km(igrid,1)=kmmin
+!c     kn(igrid,1)=cd(igrid)
+!c     km(igrid,1)=cd(igrid)
+      q2(igrid,nlev)=q2(igrid,nlev-1)
+      q(igrid,nlev)=q(igrid,nlev-1)
+      kn(igrid,nlev)=kn(igrid,nlev-1)
+      km(igrid,nlev)=km(igrid,nlev-1)
+                                                      ENDDO
+!c
+!c  CALCUL DE LA DIFFUSION VERTICALE DE Q2
+      if (1.eq.1) then
+
+        do ilev=2,klev-1
+           sss=sss+plev(1,ilev-1)-plev(1,ilev+1)
+           sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev)
+        enddo
+!c        print*,'Q2moy avant',sssq/sss
+!c       print*,'Q2q20 ',(q2(1,ilev),ilev=1,10)
+!c       print*,'Q2km0 ',(km(1,ilev),ilev=1,10)
+!c   ! C'est quoi ca qu'etait dans l'original???
+!c       do igrid=1,ngrid
+!c          q2(igrid,1)=10.
+!c       enddo
+!c        q2s=q2
+!c       do iii=1,10
+!c       call vdif_q2(dt,g,rconst,plev,temp,km,q2)
+!c       do ilev=1,klev+1
+!c          write(iii+49,*) q2(1,ilev),zlev(1,ilev)
+!c       enddo
+!c       enddo
+!c       stop
+!c       do ilev=1,klev
+!c          print*,zlev(1,ilev),q2s(1,ilev),q2(1,ilev)
+!c       enddo
+!c        q2s=q2-q2s
+!c       do ilev=1,klev
+!c          print*,q2s(1,ilev),zlev(1,ilev)
+!c       enddo
+        do ilev=2,klev-1
+           sss=sss+plev(1,ilev-1)-plev(1,ilev+1)
+           sssq=sssq+(plev(1,ilev-1)-plev(1,ilev+1))*q2(1,ilev)
+        enddo
+        print*,'Q2moy apres',sssq/sss
+!c
+!c
+        do ilev=1,nlev
+           do igrid=1,ngrid
+              q2(igrid,ilev)=max(q2(igrid,ilev),q2min)
+              q(igrid,ilev)=sqrt(q2(igrid,ilev))
+
+!c.......................................................................
+!c
+!c  calcul final de kn et km
+!c  ------------------------
+!c
+        gn=-long(igrid,ilev)**2 / q2(igrid,ilev)                                     &
+       &                                           * n2(igrid,ilev)
+        IF (gn.lt.gnmin) gn=gnmin
+        IF (gn.gt.gnmax) gn=gnmax
+        sn(igrid,ilev)=cn1/(1.E+0 +cn2*gn)
+        sm(igrid,ilev)=                                                              &
+       &    (cm1+cm2*gn)                                                             &
+       &   /( (1.E+0 +cm3*gn)*(1.E+0 +cm4*gn) )
+!C   Correction pour les couches stables.
+!C   Schema repris de JHoltzlag Boville, lui meme venant de...
+
+        if (1.eq.1) then
+        snstable=1.-zlev(igrid,ilev)                                                 &
+       &     /(700.*max(ustar(igrid),0.0001))
+        snstable=1.-zlev(igrid,ilev)/400.
+        snstable=max(snstable,0.)
+        snstable=snstable*snstable
+
+!c abde      print*,'SN ',ilev,sn(1,ilev),snstable
+        if (sn(igrid,ilev).lt.snstable) then
+           sn(igrid,ilev)=snstable
+           snq2(igrid,ilev)=0.
+        endif
+
+        if (sm(igrid,ilev).lt.snstable) then
+           sm(igrid,ilev)=snstable
+           smq2(igrid,ilev)=0.
+        endif
+
+        endif
+
+!c sn : coefficient de stabilite pour n
+        kn(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)                                &
+       &                 *sn(igrid,ilev)
+        km(igrid,ilev)=long(igrid,ilev)*q(igrid,ilev)
+!c
+           enddo
+        enddo
+!c       print*,'Q2km1 ',(km(1,ilev),ilev=1,10)
+
+      endif
+
+      RETURN
+      END
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/wake.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/wake.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/wake.F	(revision 17)
@@ -0,0 +1,2896 @@
+!
+! $Id: wake.F 1669 2012-10-16 12:41:50Z fairhead $
+!
+      Subroutine WAKE (p,ph,pi,dtime,sigd_con
+     :                ,te0,qe0,omgb
+     :                ,dtdwn,dqdwn,amdwn,amup,dta,dqa
+     :                ,wdtPBL,wdqPBL,udtPBL,udqPBL
+     o                ,deltatw,deltaqw,dth,hw,sigmaw,wape,fip,gfl
+     o                ,dtls,dqls
+     o                ,ktopw,omgbdth,dp_omgb,wdens
+     o                ,tu,qu
+     o                ,dtKE,dqKE
+     o                ,dtPBL,dqPBL
+     o                ,omg,dp_deltomg,spread
+     o                ,Cstar,d_deltat_gw
+     o                ,d_deltatw2,d_deltaqw2)
+
+
+***************************************************************
+*                                                             *
+* WAKE                                                        *
+*      retour a un Pupper fixe                                *
+*                                                             *
+* written by   :  GRANDPEIX Jean-Yves   09/03/2000            *
+* modified by :   ROEHRIG Romain        01/29/2007            *
+***************************************************************
+c
+      use dimphy
+      IMPLICIT none
+c============================================================================
+C
+C
+C   But : Decrire le comportement des poches froides apparaissant dans les
+C        grands systemes convectifs, et fournir l'energie disponible pour
+C        le declenchement de nouvelles colonnes convectives.
+C
+C   Variables d'etat : deltatw    : ecart de temperature wake-undisturbed area
+C                      deltaqw    : ecart d'humidite wake-undisturbed area
+C                      sigmaw     : fraction d'aire occupee par la poche.
+C
+C   Variable de sortie : 
+c
+c			 wape : WAke Potential Energy
+c                        fip  : Front Incident Power (W/m2) - ALP
+c                        gfl  : Gust Front Length per unit area (m-1)
+C                        dtls : large scale temperature tendency due to wake
+C                        dqls : large scale humidity tendency due to wake
+C                        hw   : hauteur de la poche
+C                     dp_omgb : vertical gradient of large scale omega
+C                     wdens   : densite de poches
+C                      omgbdth: flux of Delta_Theta transported by LS omega
+C                      dtKE   : differential heating (wake - unpertubed)
+C                      dqKE   : differential moistening (wake - unpertubed)
+C                      omg    : Delta_omg =vertical velocity diff. wake-undist. (Pa/s)
+C                 dp_deltomg  : vertical gradient of omg (s-1)
+C                     spread  : spreading term in dt_wake and dq_wake
+C                 deltatw     : updated temperature difference (T_w-T_u).
+C                 deltaqw     : updated humidity difference (q_w-q_u).
+C                 sigmaw      : updated wake fractional area.
+C                 d_deltat_gw : delta T tendency due to GW
+c
+C   Variables d'entree : 
+c
+c		         aire : aire de la maille
+c			 te0  : temperature dans l'environnement  (K)
+C                        qe0  : humidite dans l'environnement     (kg/kg)
+C                        omgb : vitesse verticale moyenne sur la maille (Pa/s)
+C                        dtdwn: source de chaleur due aux descentes (K/s)
+C                        dqdwn: source d'humidite due aux descentes (kg/kg/s)
+C			 dta  : source de chaleur due courants satures et detrain  (K/s)
+C			 dqa  : source d'humidite due aux courants satures et detra (kg/kg/s)
+C                        amdwn: flux de masse total des descentes, par unite de
+C                                surface de la maille (kg/m2/s)
+C                        amup : flux de masse total des ascendances, par unite de
+C                                surface de la maille (kg/m2/s)
+C                        p    : pressions aux milieux des couches (Pa)
+C                        ph   : pressions aux interfaces (Pa)
+C                        pi  : (p/p_0)**kapa (adim)
+C                        dtime: increment temporel (s)
+c
+C   Variables internes :
+c
+c			 rhow : masse volumique de la poche froide
+C                        rho  : environment density at P levels
+C                        rhoh : environment density at Ph levels
+C                        te   : environment temperature | may change within
+C                        qe   : environment humidity    | sub-time-stepping
+C                        the  : environment potential temperature
+C                        thu  : potential temperature in undisturbed area
+C                        tu   :  temperature  in undisturbed area
+C                        qu   : humidity in undisturbed area
+C                      dp_omgb: vertical gradient og LS omega
+C                      omgbw  : wake average vertical omega
+C                     dp_omgbw: vertical gradient of omgbw
+C                      omgbdq : flux of Delta_q transported by LS omega
+C                        dth  : potential temperature diff. wake-undist.
+C                        th1  : first pot. temp. for vertical advection (=thu)
+C                        th2  : second pot. temp. for vertical advection (=thw)
+C                        q1   : first humidity for vertical advection
+C                        q2   : second humidity for vertical advection
+C                     d_deltatw   : terme de redistribution pour deltatw
+C                     d_deltaqw   : terme de redistribution pour deltaqw
+C                      deltatw0   : deltatw initial
+C                      deltaqw0   : deltaqw initial
+C                      hw0    : hw initial
+C                      sigmaw0: sigmaw initial
+C                      amflux : horizontal mass flux through wake boundary
+C                      wdens_ref: initial number of wakes per unit area (3D) or per
+C                               unit length (2D), at the beginning of each time step
+C                      Tgw    : 1 sur la période de onde de gravité
+c                      Cgw    : vitesse de propagation de onde de gravité
+c                      LL     : distance entre 2 poches
+
+c-------------------------------------------------------------------------
+c          Déclaration de variables
+c-------------------------------------------------------------------------
+
+#include "dimensions.h"
+#include "YOMCST.h"
+#include "cvthermo.h"
+#include "iniprint.h"
+
+c Arguments en entree
+c--------------------
+
+      REAL, dimension(klon,klev) :: p, pi
+      REAL, dimension(klon,klev+1) :: ph, omgb
+      REAL dtime
+      REAL, dimension(klon,klev) :: te0,qe0
+      REAL, dimension(klon,klev) :: dtdwn, dqdwn
+      REAL, dimension(klon,klev) :: wdtPBL,wdqPBL
+      REAL, dimension(klon,klev) :: udtPBL,udqPBL
+      REAL, dimension(klon,klev) :: amdwn, amup
+      REAL, dimension(klon,klev) :: dta, dqa
+      REAL, dimension(klon) :: sigd_con
+
+c Sorties
+c--------
+
+      REAL, dimension(klon,klev) :: deltatw, deltaqw, dth
+      REAL, dimension(klon,klev) :: tu, qu
+      REAL, dimension(klon,klev) :: dtls, dqls
+      REAL, dimension(klon,klev) :: dtKE, dqKE
+      REAL, dimension(klon,klev) :: dtPBL, dqPBL
+      REAL, dimension(klon,klev) :: spread
+      REAL, dimension(klon,klev) :: d_deltatgw
+      REAL, dimension(klon,klev) :: d_deltatw2, d_deltaqw2
+      REAL, dimension(klon,klev+1) :: omgbdth, omg
+      REAL, dimension(klon,klev) :: dp_omgb, dp_deltomg
+      REAL, dimension(klon,klev) :: d_deltat_gw
+      REAL, dimension(klon) :: hw, sigmaw, wape, fip, gfl, Cstar
+      REAL, dimension(klon) :: wdens
+      INTEGER, dimension(klon) :: ktopw
+
+c Variables internes
+c-------------------
+
+c Variables à fixer
+      REAL ALON
+      REAL coefgw
+      REAL :: wdens_ref
+      REAL stark
+      REAL alpk
+      REAL delta_t_min
+      INTEGER nsub
+      REAL dtimesub
+      REAL sigmad, hwmin,wapecut
+      REAL :: sigmaw_max
+      REAL :: dens_rate
+      REAL wdens0
+cIM 080208
+      LOGICAL, dimension(klon) :: gwake
+
+c Variables de sauvegarde
+      REAL, dimension(klon,klev) :: deltatw0
+      REAL, dimension(klon,klev) :: deltaqw0
+      REAL, dimension(klon,klev) :: te, qe
+      REAL, dimension(klon) :: sigmaw0, sigmaw1
+
+c Variables pour les GW
+      REAL, DIMENSION(klon) :: LL
+      REAL, dimension(klon,klev) :: N2
+      REAL, dimension(klon,klev) :: Cgw
+      REAL, dimension(klon,klev) :: Tgw
+
+c Variables liées au calcul de hw
+      REAL, DIMENSION(klon) :: ptop_provis, ptop, ptop_new
+      REAL, DIMENSION(klon) :: sum_dth
+      REAL, DIMENSION(klon) :: dthmin
+      REAL, DIMENSION(klon) :: z, dz, hw0
+      INTEGER, DIMENSION(klon) :: ktop, kupper
+
+c Sub-timestep tendencies and related variables
+       REAL d_deltatw(klon,klev),d_deltaqw(klon,klev)
+       REAL d_te(klon,klev),d_qe(klon,klev)
+       REAL d_sigmaw(klon),alpha(klon)
+       REAL q0_min(klon),q1_min(klon)
+       LOGICAL wk_adv(klon), OK_qx_qw(klon)
+       REAL epsilon
+       DATA epsilon/1.e-15/
+
+c Autres variables internes
+      INTEGER isubstep, k, i
+
+      REAL, DIMENSION(klon) :: sum_thu, sum_tu, sum_qu,sum_thvu
+      REAL, DIMENSION(klon) :: sum_dq, sum_rho
+      REAL, DIMENSION(klon) :: sum_dtdwn, sum_dqdwn
+      REAL, DIMENSION(klon) :: av_thu, av_tu, av_qu, av_thvu
+      REAL, DIMENSION(klon) :: av_dth, av_dq, av_rho
+      REAL, DIMENSION(klon) :: av_dtdwn, av_dqdwn
+
+      REAL, DIMENSION(klon,klev) :: rho, rhow
+      REAL, DIMENSION(klon,klev+1) :: rhoh
+      REAL, DIMENSION(klon,klev) :: rhow_moyen
+      REAL, DIMENSION(klon,klev) :: zh
+      REAL, DIMENSION(klon,klev+1) :: zhh
+      REAL, DIMENSION(klon,klev) :: epaisseur1, epaisseur2
+
+      REAL, DIMENSION(klon,klev) :: the, thu
+
+!      REAL, DIMENSION(klon,klev) :: d_deltatw, d_deltaqw
+
+      REAL, DIMENSION(klon,klev+1) :: omgbw
+      REAL, DIMENSION(klon) :: pupper
+      REAL, DIMENSION(klon) :: omgtop
+      REAL, DIMENSION(klon,klev) :: dp_omgbw
+      REAL, DIMENSION(klon) :: ztop, dztop
+      REAL, DIMENSION(klon,klev) :: alpha_up
+      
+      REAL, dimension(klon) :: RRe1, RRe2
+      REAL :: RRd1, RRd2
+      REAL, DIMENSION(klon,klev) :: Th1, Th2, q1, q2
+      REAL, DIMENSION(klon,klev) :: D_Th1, D_Th2, D_dth
+      REAL, DIMENSION(klon,klev) :: D_q1, D_q2, D_dq
+      REAL, DIMENSION(klon,klev) :: omgbdq
+
+      REAL, dimension(klon) :: ff, gg
+      REAL, dimension(klon) :: wape2, Cstar2, heff
+
+      REAL, DIMENSION(klon,klev) :: Crep
+      REAL Crep_upper, Crep_sol
+
+      REAL, DIMENSION(klon,klev) :: ppi
+
+ccc nrlmd
+      real, dimension(klon) :: death_rate,nat_rate
+      real, dimension(klon,klev) :: entr
+      real, dimension(klon,klev) :: detr
+
+C-------------------------------------------------------------------------
+c         Initialisations
+c-------------------------------------------------------------------------
+
+c      print*, 'wake initialisations'
+
+c   Essais d'initialisation avec sigmaw = 0.02 et hw = 10.
+c-------------------------------------------------------------------------
+
+      DATA wapecut,sigmad, hwmin /5.,.02,10./
+ccc nrlmd
+      DATA sigmaw_max /0.4/
+      DATA dens_rate /0.1/
+ccc
+C Longueur de maille (en m)
+c-------------------------------------------------------------------------
+
+c      ALON = 3.e5
+      ALON = 1.e6
+
+
+C Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei)
+c
+c      coefgw : Coefficient pour les ondes de gravité
+c       stark : Coefficient k dans Cstar=k*sqrt(2*WAPE)
+c       wdens : Densité de poche froide par maille
+c-------------------------------------------------------------------------
+
+ccc nrlmd      coefgw=10
+c      coefgw=1
+c      wdens0 = 1.0/(alon**2)
+ccc nrlmd      wdens = 1.0/(alon**2)
+ccc nrlmd      stark = 0.50
+cCRtest
+ccc nrlmd      alpk=0.1
+c      alpk = 1.0
+c      alpk = 0.5
+c      alpk = 0.05
+c
+       stark  = 0.33
+       Alpk   = 0.25
+       wdens_ref  = 8.e-12
+       coefgw = 4.
+      Crep_upper=0.9
+      Crep_sol=1.0
+
+ccc nrlmd Lecture du fichier wake_param.data
+      OPEN(99,file='wake_param.data',status='old',
+     $          form='formatted',err=9999)
+      READ(99,*,end=9998) stark
+      READ(99,*,end=9998) Alpk
+      READ(99,*,end=9998) wdens_ref
+      READ(99,*,end=9998) coefgw
+9998  Continue
+      CLOSE(99)
+9999  Continue
+c
+c   Initialisation de toutes des densites a wdens_ref.
+c   Les densites peuvent evoluer si les poches debordent
+c   (voir au tout debut de la boucle sur les substeps)
+      wdens = wdens_ref
+c
+c      print*,'stark',stark
+c      print*,'alpk',alpk
+c      print*,'wdens',wdens
+c      print*,'coefgw',coefgw
+ccc
+C Minimum value for |T_wake - T_undist|. Used for wake top definition
+c-------------------------------------------------------------------------
+
+      delta_t_min = 0.2
+
+C 1. - Save initial values and initialize tendencies
+C --------------------------------------------------
+
+      DO k=1,klev
+      DO i=1, klon
+        ppi(i,k)=pi(i,k)
+	deltatw0(i,k) = deltatw(i,k)
+	deltaqw0(i,k)= deltaqw(i,k)
+	te(i,k) = te0(i,k)
+	qe(i,k) = qe0(i,k)
+	dtls(i,k) = 0.
+	dqls(i,k) = 0.
+        d_deltat_gw(i,k)=0.
+        d_te(i,k) = 0.
+        d_qe(i,k) = 0.
+        d_deltatw(i,k) = 0.
+        d_deltaqw(i,k) = 0.
+!IM 060508 beg
+        d_deltatw2(i,k)=0.
+        d_deltaqw2(i,k)=0.
+!IM 060508 end
+      ENDDO
+      ENDDO
+c      sigmaw1=sigmaw
+c      IF (sigd_con.GT.sigmaw1) THEN
+c      print*, 'sigmaw,sigd_con', sigmaw, sigd_con
+c      ENDIF
+      DO i=1, klon
+cc      sigmaw(i) = amax1(sigmaw(i),sigd_con(i))
+      sigmaw(i) = amax1(sigmaw(i),sigmad)
+      sigmaw(i) = amin1(sigmaw(i),0.99)
+      sigmaw0(i) = sigmaw(i)
+      wape(i) = 0.
+      wape2(i) = 0.
+      d_sigmaw(i) = 0.
+      ktopw(i) = 0
+      ENDDO
+C
+C
+C 2. - Prognostic part
+C --------------------
+C
+C
+C 2.1 - Undisturbed area and Wake integrals
+C ---------------------------------------------------------
+
+      DO i=1, klon
+      z(i) = 0.
+      ktop(i)=0
+      kupper(i) = 0
+      sum_thu(i) = 0.
+      sum_tu(i) = 0.
+      sum_qu(i) = 0.
+      sum_thvu(i) = 0.
+      sum_dth(i) = 0.
+      sum_dq(i) = 0.
+      sum_rho(i) = 0.
+      sum_dtdwn(i) = 0.
+      sum_dqdwn(i) = 0.
+
+      av_thu(i) = 0.
+      av_tu(i) =0.
+      av_qu(i) =0.
+      av_thvu(i) = 0.
+      av_dth(i) = 0.
+      av_dq(i) = 0.
+      av_rho(i) =0.
+      av_dtdwn(i) =0.
+      av_dqdwn(i) = 0.
+      ENDDO
+c
+c Distance between wakes
+       DO i = 1,klon
+        LL(i) = (1-sqrt(sigmaw(i)))/sqrt(wdens(i))
+       ENDDO
+C Potential temperatures and humidity
+c----------------------------------------------------------
+      DO k =1,klev
+       DO i=1, klon 
+!        write(*,*)'wake 1',i,k,rd,te(i,k)
+        rho(i,k) = p(i,k)/(rd*te(i,k))
+!        write(*,*)'wake 2',rho(i,k)
+        IF(k .eq. 1) THEN
+!        write(*,*)'wake 3',i,k,rd,te(i,k)
+          rhoh(i,k) = ph(i,k)/(rd*te(i,k))
+!        write(*,*)'wake 4',i,k,rd,te(i,k)
+          zhh(i,k)=0
+        ELSE
+!          write(*,*)'wake 5',rd,(te(i,k)+te(i,k-1))
+          rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(i,k-1)))
+!          write(*,*)'wake 6',(-rhoh(i,k)*RG)+zhh(i,k-1)
+          zhh(i,k)=(ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG)+zhh(i,k-1)
+        ENDIF
+!          write(*,*)'wake 7',ppi(i,k)
+        the(i,k) = te(i,k)/ppi(i,k)
+        thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k)
+        tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i)
+        qu(i,k)  =  qe(i,k) - deltaqw(i,k)*sigmaw(i)
+!          write(*,*)'wake 8',(rd*(te(i,k)+deltatw(i,k)))
+        rhow(i,k) = p(i,k)/(rd*(te(i,k)+deltatw(i,k)))
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+       ENDDO
+      ENDDO
+        
+      DO k = 1, klev-1
+      DO i=1, klon 
+        IF(k.eq.1) THEN
+          N2(i,k)=0
+        ELSE
+          N2(i,k)=amax1(0.,-RG**2/the(i,k)*rho(i,k)*(the(i,k+1)-
+     $            the(i,k-1))/(p(i,k+1)-p(i,k-1)))
+        ENDIF
+        ZH(i,k)=(zhh(i,k)+zhh(i,k+1))/2
+
+        Cgw(i,k)=sqrt(N2(i,k))*ZH(i,k)
+        Tgw(i,k)=coefgw*Cgw(i,k)/LL(i)
+      ENDDO
+      ENDDO
+
+      DO i=1, klon
+      N2(i,klev)=0
+      ZH(i,klev)=0
+      Cgw(i,klev)=0
+      Tgw(i,klev)=0
+      ENDDO
+
+c  Calcul de la masse volumique moyenne de la colonne   (bdlmd)
+c-----------------------------------------------------------------
+
+      DO k=1,klev
+       DO i=1, klon
+        epaisseur1(i,k)=0.
+        epaisseur2(i,k)=0.
+       ENDDO
+      ENDDO
+
+      DO i=1, klon
+      epaisseur1(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1.
+      epaisseur2(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1.
+      rhow_moyen(i,1) = rhow(i,1)
+      ENDDO
+
+      DO k = 2, klev
+      DO i=1, klon
+        epaisseur1(i,k)= -(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg) +1.
+        epaisseur2(i,k)=epaisseur2(i,k-1)+epaisseur1(i,k)
+        rhow_moyen(i,k) = (rhow_moyen(i,k-1)*epaisseur2(i,k-1)+
+     $                 rhow(i,k)*epaisseur1(i,k))/epaisseur2(i,k)
+      ENDDO
+      ENDDO
+
+C
+C Choose an integration bound well above wake top
+c-----------------------------------------------------------------
+c
+C       Pupper = 50000.  ! melting level
+c       Pupper = 60000.
+c       Pupper = 80000.  ! essais pour case_e
+       DO i = 1,klon
+        Pupper(i) = 0.6*ph(i,1)
+        Pupper(i) = max(Pupper(i), 45000.)
+ccc        Pupper(i) = 60000.
+       ENDDO
+
+C
+C    Determine Wake top pressure (Ptop) from buoyancy integral
+C    --------------------------------------------------------
+c
+c-1/ Pressure of the level where dth becomes less than delta_t_min.
+
+      DO i=1,klon
+      ptop_provis(i)=ph(i,1)
+      ENDDO
+      DO k= 2,klev
+      DO i=1,klon
+c
+cIM v3JYG; ptop_provis(i).LT. ph(i,1)
+c
+        IF (dth(i,k) .GT. -delta_t_min .and.
+     $      dth(i,k-1).LT. -delta_t_min .and.
+     $      ptop_provis(i).EQ. ph(i,1)) THEN
+          ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
+     $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /
+     $          (dth(i,k) - dth(i,k-1))
+        ENDIF
+      ENDDO
+      ENDDO
+
+c-2/ dth integral
+
+      DO i=1,klon
+      sum_dth(i) = 0.
+      dthmin(i) = -delta_t_min
+      z(i) = 0.
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+        dz(i) = -(amax1(ph(i,k+1),ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .gt. 0) THEN
+          z(i) = z(i)+dz(i)
+          sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+          dthmin(i) = amin1(dthmin(i),dth(i,k))
+        ENDIF
+      ENDDO
+      ENDDO
+
+c-3/ height of triangle with area= sum_dth and base = dthmin
+
+      DO i=1,klon
+      hw0(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5)
+      hw0(i) = amax1(hwmin,hw0(i))
+      ENDDO
+
+c-4/ now, get Ptop
+
+      DO i=1,klon
+      z(i) = 0.
+      ptop(i) = ph(i,1)
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+        dz(i) = amin1(-(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg),hw0(i)-z(i))
+        IF (dz(i) .gt. 0) THEN
+         z(i) = z(i)+dz(i)
+         ptop(i) = ph(i,k)-rho(i,k)*rg*dz(i)
+        ENDIF
+      ENDDO
+      ENDDO
+
+
+C-5/ Determination de ktop et kupper
+
+      DO k=klev,1,-1
+      DO i=1,klon
+        IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k
+        IF (ph(i,k+1) .lt. pupper(i)) kupper(i)=k
+      ENDDO
+      ENDDO
+
+c      On evite kupper = 1 et kupper = klev
+      DO i=1,klon
+        kupper(i) = max(kupper(i),2)
+        kupper(i) = min(kupper(i),klev-1)
+      ENDDO
+
+
+c-6/ Correct ktop and ptop
+
+      DO i = 1,klon
+        ptop_new(i)=ptop(i)
+      ENDDO
+      DO k= klev,2,-1
+      DO i=1,klon
+        IF (k .LE. ktop(i) .and.
+     $      ptop_new(i) .EQ. ptop(i) .and.
+     $      dth(i,k) .GT. -delta_t_min .and.
+     $      dth(i,k-1).LT. -delta_t_min) THEN
+          ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
+     $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /
+     $          (dth(i,k) - dth(i,k-1))
+        ENDIF
+      ENDDO
+      ENDDO
+
+      DO i=1,klon
+        ptop(i) = ptop_new(i)
+      ENDDO
+
+      DO k=klev,1,-1
+      DO i=1,klon
+        IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k
+      ENDDO
+      ENDDO
+c
+c-5/ Set deltatw & deltaqw to 0 above kupper
+c
+      DO k = 1,klev
+      DO i=1,klon
+       IF (k.GE. kupper(i)) THEN
+        deltatw(i,k) = 0.
+        deltaqw(i,k) = 0.
+       ENDIF
+      ENDDO
+      ENDDO
+c
+C
+C Vertical gradient of LS omega
+C
+      DO k = 1,klev
+      DO i=1,klon
+       IF (k.LE. kupper(i)) THEN
+        dp_omgb(i,k) = (omgb(i,k+1) - omgb(i,k))/(ph(i,k+1)-ph(i,k))
+       ENDIF
+      ENDDO
+      ENDDO
+C
+C Integrals (and wake top level number)
+C --------------------------------------
+C
+C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      DO i=1,klon
+      z(i) = 1.
+      dz(i) = 1.
+      sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
+      sum_dth(i) = 0.
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+        dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .GT. 0) THEN
+         z(i) = z(i)+dz(i)
+         sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i)
+         sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i)
+         sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i)
+         sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i)
+         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+         sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
+         sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
+         sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
+         sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
+        ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i=1,klon
+        hw0(i) = z(i)
+      ENDDO
+c
+C
+C 2.1 - WAPE and mean forcing computation
+C ---------------------------------------
+C
+C ---------------------------------------
+C
+C Means
+
+      DO i=1,klon
+      av_thu(i) = sum_thu(i)/hw0(i)
+      av_tu(i) = sum_tu(i)/hw0(i)
+      av_qu(i) = sum_qu(i)/hw0(i)
+      av_thvu(i) = sum_thvu(i)/hw0(i)
+c      av_thve = sum_thve/hw0
+      av_dth(i) = sum_dth(i)/hw0(i)
+      av_dq(i) = sum_dq(i)/hw0(i)
+      av_rho(i) = sum_rho(i)/hw0(i)
+      av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
+      av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
+
+      wape(i) = - rg*hw0(i)*(av_dth(i)
+     $     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+av_dth(i)*
+     $     av_dq(i) ))/av_thvu(i)
+      ENDDO
+C
+C 2.2 Prognostic variable update
+C ------------------------------
+C
+C Filter out bad wakes
+
+      DO k = 1,klev
+       DO i=1,klon
+        IF ( wape(i) .LT. 0.) THEN
+          deltatw(i,k) = 0.
+          deltaqw(i,k) = 0.
+          dth(i,k) = 0.
+        ENDIF
+       ENDDO
+      ENDDO
+c
+      DO i=1,klon
+      IF ( wape(i) .LT. 0.) THEN
+        wape(i) = 0.
+        Cstar(i) = 0.
+        hw(i) = hwmin
+        sigmaw(i) = amax1(sigmad,sigd_con(i))
+        fip(i) = 0.
+        gwake(i) = .FALSE.
+      ELSE
+        Cstar(i) = stark*sqrt(2.*wape(i))
+        gwake(i) = .TRUE.
+      ENDIF
+      ENDDO
+
+c
+c Check qx and qw positivity
+c --------------------------
+      DO i = 1,klon
+       q0_min(i)=min(  (qe(i,1)-sigmaw(i)*deltaqw(i,1)),
+     $              (qe(i,1)+(1.-sigmaw(i))*deltaqw(i,1))  )
+      ENDDO
+      DO k = 2,klev
+      DO i = 1,klon
+        q1_min(i)=min(  (qe(i,k)-sigmaw(i)*deltaqw(i,k)),
+     $              (qe(i,k)+(1.-sigmaw(i))*deltaqw(i,k))  )
+        IF (q1_min(i).le.q0_min(i)) THEN
+          q0_min(i)=q1_min(i)
+        ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1,klon
+       OK_qx_qw(i) = q0_min(i) .GE. 0.
+       alpha(i) = 1.
+      ENDDO
+c
+CC -----------------------------------------------------------------
+C    Sub-time-stepping
+C    -----------------
+C
+      nsub=10
+      dtimesub=dtime/nsub
+c
+c------------------------------------------------------------
+      DO isubstep = 1,nsub
+c------------------------------------------------------------
+c
+c wk_adv is the logical flag enabling wake evolution in the time advance loop
+      DO i = 1,klon
+       wk_adv(i) = OK_qx_qw(i) .AND. alpha(i) .GE. 1.
+      ENDDO
+c
+ccc nrlmd   Ajout d'un recalcul de wdens dans le cas d'un entrainement négatif de ktop à kupper --------
+ccc           On calcule pour cela une densité wdens0 pour laquelle on aurait un entrainement nul ---
+      DO i=1,klon
+cc       print *,' isubstep,wk_adv(i),cstar(i),wape(i) ',
+cc     $           isubstep,wk_adv(i),cstar(i),wape(i)
+        IF (wk_adv(i) .AND. cstar(i).GT.0.01) THEN
+           omg(i,kupper(i)+1) = - Rg*amdwn(i,kupper(i)+1)/sigmaw(i)
+     $                + Rg*amup(i,kupper(i)+1)/(1.-sigmaw(i))
+           wdens0 = ( sigmaw(i) / (4.*3.14) ) *
+     $     ( (1.-sigmaw(i)) * omg(i,kupper(i)+1) /
+     $     ( (ph(i,1)-pupper(i)) * cstar(i) )  ) **(2)
+         IF ( wdens(i) .LE. wdens0*1.1 ) THEN
+            wdens(i) = wdens0
+         ENDIF
+cc	   print*,'omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i)
+cc     $     ,ph(i,1)-pupper(i)',
+cc     $             omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i)
+cc     $     ,ph(i,1)-pupper(i)
+        ENDIF
+      ENDDO
+
+ccc nrlmd
+
+      DO i=1,klon
+       IF (wk_adv(i)) THEN
+        gfl(i) = 2.*sqrt(3.14*wdens(i)*sigmaw(i))
+        sigmaw(i)=amin1(sigmaw(i),sigmaw_max)
+       ENDIF
+      ENDDO
+      DO i=1,klon
+        IF (wk_adv(i)) THEN
+ccc nrlmd          Introduction du taux de mortalité des poches et test sur sigmaw_max=0.4
+ccc         d_sigmaw(i) = gfl(i)*Cstar(i)*dtimesub
+           IF (sigmaw(i).ge.sigmaw_max) THEN
+           death_rate(i)=gfl(i)*Cstar(i)/sigmaw(i)
+           ELSE
+             death_rate(i)=0.
+           END IF
+        d_sigmaw(i) = gfl(i)*Cstar(i)*dtimesub
+     $               - death_rate(i)*sigmaw(i)*dtimesub
+c     $              - nat_rate(i)*sigmaw(i)*dtimesub
+cc        print*, 'd_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i),
+cc     $  death_rate(i),ktop(i),kupper(i)',
+cc     $	         d_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i),
+cc     $  death_rate(i),ktop(i),kupper(i)
+
+c        sigmaw(i) =sigmaw(i) + gfl(i)*Cstar(i)*dtimesub
+c        sigmaw(i) =min(sigmaw(i),0.99)     !!!!!!!!
+c        wdens = wdens0/(10.*sigmaw)
+c        sigmaw =max(sigmaw,sigd_con)
+c        sigmaw =max(sigmaw,sigmad)
+        ENDIF
+      ENDDO
+C
+C
+c calcul de la difference de vitesse verticale poche - zone non perturbee
+cIM 060208 differences par rapport au code initial; init. a 0 dp_deltomg
+cIM 060208 et omg sur les niveaux de 1 a klev+1, alors que avant l'on definit
+cIM 060208 au niveau k=1..?
+      DO k= 1,klev
+      DO i = 1,klon
+      if (wk_adv(i)) THEN !!! nrlmd
+        dp_deltomg(i,k)=0.
+      end if
+      ENDDO
+      ENDDO
+      DO k= 1,klev+1
+      DO i = 1,klon
+      if (wk_adv(i)) THEN !!! nrlmd
+        omg(i,k)=0.
+      end if
+      ENDDO
+      ENDDO
+c
+      DO i=1,klon
+        IF (wk_adv(i)) THEN
+        z(i)= 0.
+        omg(i,1) = 0.
+        dp_deltomg(i,1) = -(gfl(i)*Cstar(i))/(sigmaw(i) * (1-sigmaw(i)))
+        ENDIF
+      ENDDO
+c
+      DO k= 2,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. ktop(i)) THEN
+          dz(i) = -(ph(i,k)-ph(i,k-1))/(rho(i,k-1)*rg)
+          z(i) = z(i)+dz(i)
+          dp_deltomg(i,k)= dp_deltomg(i,1)
+          omg(i,k)= dp_deltomg(i,1)*z(i)
+       ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i = 1,klon
+        IF (wk_adv(i)) THEN
+        dztop(i)=-(ptop(i)-ph(i,ktop(i)))/(rho(i,ktop(i))*rg)
+        ztop(i) = z(i)+dztop(i)
+        omgtop(i)=dp_deltomg(i,1)*ztop(i)
+        ENDIF
+      ENDDO
+c
+c        -----------------
+c        From m/s to Pa/s
+c        -----------------
+c
+       DO i=1,klon
+        IF (wk_adv(i)) THEN
+        omgtop(i) = -rho(i,ktop(i))*rg*omgtop(i)
+        dp_deltomg(i,1) = omgtop(i)/(ptop(i)-ph(i,1))
+        ENDIF
+       ENDDO
+c
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. ktop(i)) THEN
+          omg(i,k) = - rho(i,k)*rg*omg(i,k)
+          dp_deltomg(i,k) = dp_deltomg(i,1)
+       ENDIF
+      ENDDO
+      ENDDO
+c
+c   raccordement lineaire de omg de ptop a pupper
+
+      DO i=1,klon
+      IF ( wk_adv(i) .AND. kupper(i) .GT. ktop(i)) THEN
+        omg(i,kupper(i)+1) = - Rg*amdwn(i,kupper(i)+1)/sigmaw(i)
+     $                + Rg*amup(i,kupper(i)+1)/(1.-sigmaw(i))
+        dp_deltomg(i,kupper(i)) = (omgtop(i)-omg(i,kupper(i)+1))/
+     $                     (ptop(i)-pupper(i))
+      ENDIF
+      ENDDO
+c
+cc      DO i=1,klon
+cc        print*,'Pente entre 0 et kupper (référence)'
+cc     $   	,omg(i,kupper(i)+1)/(pupper(i)-ph(i,1))
+cc        print*,'Pente entre ktop et kupper'
+cc     $  	,(omg(i,kupper(i)+1)-omgtop(i))/(pupper(i)-ptop(i))
+cc      ENDDO
+cc
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .GT. ktop(i) .AND. k .LE. kupper(i)) THEN
+          dp_deltomg(i,k) = dp_deltomg(i,kupper(i))
+          omg(i,k) = omgtop(i)+(ph(i,k)-ptop(i))*dp_deltomg(i,kupper(i))
+       ENDIF
+      ENDDO
+      ENDDO
+ccc nrlmd
+cc      DO i=1,klon
+cc      print*,'deltaw_ktop,deltaw_conv',omgtop(i),omg(i,kupper(i)+1)
+cc      END DO
+ccc
+c
+c
+c--    Compute wake average vertical velocity omgbw
+c
+c
+      DO k = 1,klev+1
+      DO i=1,klon
+        IF ( wk_adv(i)) THEN
+        omgbw(i,k) = omgb(i,k)+(1.-sigmaw(i))*omg(i,k)
+        ENDIF
+      ENDDO
+      ENDDO
+c--    and its vertical gradient dp_omgbw
+c
+      DO k = 1,klev
+      DO i=1,klon
+        IF ( wk_adv(i)) THEN
+        dp_omgbw(i,k) = (omgbw(i,k+1)-omgbw(i,k))/(ph(i,k+1)-ph(i,k))
+        ENDIF
+      ENDDO
+      ENDDO
+C
+c--    Upstream coefficients for omgb velocity
+c--    (alpha_up(k) is the coefficient of the value at level k)
+c--    (1-alpha_up(k) is the coefficient of the value at level k-1)
+      DO k = 1,klev
+      DO i=1,klon
+        IF ( wk_adv(i)) THEN
+         alpha_up(i,k) = 0.
+         IF (omgb(i,k) .GT. 0.) alpha_up(i,k) = 1.
+        ENDIF
+      ENDDO
+      ENDDO
+
+c  Matrix expressing [The,deltatw] from  [Th1,Th2]
+
+      DO i=1,klon
+        IF ( wk_adv(i)) THEN
+         RRe1(i) = 1.-sigmaw(i)
+         RRe2(i) = sigmaw(i)
+        ENDIF
+      ENDDO
+      RRd1 = -1.
+      RRd2 = 1.
+c
+c--    Get [Th1,Th2], dth and [q1,q2]
+c
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+        Th1(i,k) = the(i,k) - sigmaw(i)     *dth(i,k)   ! undisturbed area
+        Th2(i,k) = the(i,k) + (1.-sigmaw(i))*dth(i,k)   ! wake
+        q1(i,k) = qe(i,k) - sigmaw(i)     *deltaqw(i,k) ! undisturbed area
+        q2(i,k) = qe(i,k) + (1.-sigmaw(i))*deltaqw(i,k) ! wake
+       ENDIF
+      ENDDO
+      ENDDO
+
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+       D_Th1(i,1) = 0.
+       D_Th2(i,1) = 0.
+       D_dth(i,1) = 0.
+       D_q1(i,1) = 0.
+       D_q2(i,1) = 0.
+       D_dq(i,1) = 0.
+       end if
+      ENDDO
+
+      DO k= 2,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN
+        D_Th1(i,k) = Th1(i,k-1)-Th1(i,k)
+        D_Th2(i,k) = Th2(i,k-1)-Th2(i,k)
+        D_dth(i,k) = dth(i,k-1)-dth(i,k)
+        D_q1(i,k) = q1(i,k-1)-q1(i,k)
+        D_q2(i,k) = q2(i,k-1)-q2(i,k)
+        D_dq(i,k) = deltaqw(i,k-1)-deltaqw(i,k)
+       ENDIF
+      ENDDO
+      ENDDO
+
+      DO i=1,klon
+        IF( wk_adv(i)) THEN
+         omgbdth(i,1) = 0.
+         omgbdq(i,1) = 0.
+        ENDIF
+      ENDDO
+
+      DO k= 2,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN  !   loop on interfaces
+        omgbdth(i,k) = omgb(i,k)*(    dth(i,k-1) -     dth(i,k))
+        omgbdq(i,k)  = omgb(i,k)*(deltaqw(i,k-1) - deltaqw(i,k))
+       ENDIF
+      ENDDO
+      ENDDO
+c
+c-----------------------------------------------------------------
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN
+c-----------------------------------------------------------------
+c
+c   Compute redistribution (advective) term
+c
+         d_deltatw(i,k) =
+     $             dtimesub/(Ph(i,k)-Ph(i,k+1))*(
+     $       RRd1*omg(i,k  )*sigmaw(i)     *D_Th1(i,k)
+     $      -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1)
+     $      -(1.-alpha_up(i,k))*omgbdth(i,k) - alpha_up(i,k+1)*
+     $      omgbdth(i,k+1))*ppi(i,k)
+c         print*,'d_deltatw=',d_deltatw(i,k)
+c
+         d_deltaqw(i,k) =
+     $             dtimesub/(Ph(i,k)-Ph(i,k+1))*(
+     $       RRd1*omg(i,k  )*sigmaw(i)     *D_q1(i,k)
+     $      -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1)
+     $      -(1.-alpha_up(i,k))*omgbdq(i,k) - alpha_up(i,k+1)*
+     $      omgbdq(i,k+1))
+c         print*,'d_deltaqw=',d_deltaqw(i,k)
+c
+c   and increment large scale tendencies
+c
+
+c
+C
+CC -----------------------------------------------------------------
+         d_te(i,k) =  dtimesub*(
+     $        ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_Th1(i,k)
+     $         -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1) )
+     $               /(Ph(i,k)-Ph(i,k+1))
+ccc nrlmd     $         -sigmaw(i)*(1.-sigmaw(i))*dth(i,k)*dp_deltomg(i,k)
+     $         -sigmaw(i)*(1.-sigmaw(i))*dth(i,k)
+     $         *(omg(i,k)-omg(i,k+1))/(Ph(i,k)-Ph(i,k+1))
+ccc
+     $                      )*ppi(i,k)
+c
+         d_qe(i,k) =  dtimesub*(
+     $        ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_q1(i,k)
+     $         -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1) )
+     $               /(Ph(i,k)-Ph(i,k+1))
+ccc nrlmd     $         -sigmaw(i)*(1.-sigmaw(i))*deltaqw(i,k)*dp_deltomg(i,k)
+     $         -sigmaw(i)*(1.-sigmaw(i))*deltaqw(i,k)
+     $         *(omg(i,k)-omg(i,k+1))/(Ph(i,k)-Ph(i,k+1))
+ccc
+     $                      )
+ccc nrlmd
+       ELSE IF(wk_adv(i) .AND. k .EQ. kupper(i)) THEN
+         d_te(i,k) =  dtimesub*(
+     $       ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_Th1(i,k)
+     $        /(Ph(i,k)-Ph(i,k+1)))
+     $                       )*ppi(i,k)
+
+         d_qe(i,k) =  dtimesub*(
+     $       ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_q1(i,k)       
+     $        /(Ph(i,k)-Ph(i,k+1)))
+     $                       )
+
+       ENDIF
+ccc
+      ENDDO
+      ENDDO
+c------------------------------------------------------------------
+C
+C   Increment state variables
+
+      DO k= 1,klev
+      DO i = 1,klon
+ccc nrlmd       IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN
+        IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
+ccc
+
+
+c
+c Coefficient de répartition
+
+        Crep(i,k)=Crep_sol*(ph(i,kupper(i))-ph(i,k))/(ph(i,kupper(i))
+     $          -ph(i,1))
+        Crep(i,k)=Crep(i,k)+Crep_upper*(ph(i,1)-ph(i,k))/(p(i,1)-
+     $          ph(i,kupper(i)))
+        
+
+c Reintroduce compensating subsidence term.
+
+c        dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw
+c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k))
+c     .                   /(1-sigmaw)
+c        dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw
+c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k))
+c     .                   /(1-sigmaw)
+c
+c        dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw
+c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k))
+c     .                   /(1-sigmaw)
+c        dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw
+c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k))
+c     .                   /(1-sigmaw)
+
+        dtKE(i,k)=(dtdwn(i,k)/sigmaw(i) - dta(i,k)/(1.-sigmaw(i)))
+        dqKE(i,k)=(dqdwn(i,k)/sigmaw(i) - dqa(i,k)/(1.-sigmaw(i)))
+c        print*,'dtKE= ',dtKE(i,k),' dqKE= ',dqKE(i,k)
+c
+        dtPBL(i,k)=(wdtPBL(i,k)/sigmaw(i) - udtPBL(i,k)/(1.-sigmaw(i)))
+        dqPBL(i,k)=(wdqPBL(i,k)/sigmaw(i) - udqPBL(i,k)/(1.-sigmaw(i)))
+c        print*,'dtPBL= ',dtPBL(i,k),' dqPBL= ',dqPBL(i,k)
+c
+ccc nrlmd          Prise en compte du taux de mortalité
+ccc               Définitions de entr, detr
+        detr(i,k)=0.
+
+        entr(i,k)=detr(i,k)+gfl(i)*cstar(i)+
+     $          sigmaw(i)*(1.-sigmaw(i))*dp_deltomg(i,k)
+
+        spread(i,k) = (entr(i,k)-detr(i,k))/sigmaw(i)
+ccc        spread(i,k) = (1.-sigmaw(i))*dp_deltomg(i,k)+gfl(i)*Cstar(i)/
+ccc     $  sigmaw(i)
+
+
+c ajout d'un effet onde de gravité -Tgw(k)*deltatw(k) 03/02/06 YU Jingmei
+
+!      write(lunout,*)'wake.F ',i,k, dtimesub,d_deltat_gw(i,k),
+!     &  Tgw(i,k),deltatw(i,k)
+        d_deltat_gw(i,k)=d_deltat_gw(i,k)-Tgw(i,k)*deltatw(i,k)*
+     $  dtimesub
+!      write(lunout,*)'wake.F ',i,k, dtimesub,d_deltatw(i,k)
+        ff(i)=d_deltatw(i,k)/dtimesub
+
+c Sans GW
+c
+c        deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-spread(k)*deltatw(k))
+c
+c GW formule 1
+c
+c        deltatw(k) = deltatw(k)+dtimesub*
+c     $         (ff+dtKE(k) - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
+c
+c GW formule 2
+
+        IF (dtimesub*Tgw(i,k).lt.1.e-10) THEN
+          d_deltatw(i,k) = dtimesub*
+     $       (ff(i)+dtKE(i,k)+dtPBL(i,k)
+ccc     $       -spread(i,k)*deltatw(i,k)
+     $       - entr(i,k)*deltatw(i,k)/sigmaw(i)
+     $       - (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k)
+     $       / (1.-sigmaw(i))
+ccc
+     $       -Tgw(i,k)*deltatw(i,k))
+        ELSE
+           d_deltatw(i,k) = 1/Tgw(i,k)*(1-exp(-dtimesub*
+     $       Tgw(i,k)))*
+     $       (ff(i)+dtKE(i,k)+dtPBL(i,k)
+ccc     $       -spread(i,k)*deltatw(i,k)
+     $       - entr(i,k)*deltatw(i,k)/sigmaw(i)
+     $       - (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k)
+     $       / (1.-sigmaw(i))
+ccc
+     $       -Tgw(i,k)*deltatw(i,k))
+        ENDIF
+
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+
+        gg(i)=d_deltaqw(i,k)/dtimesub
+
+       d_deltaqw(i,k) = dtimesub*(gg(i)+ dqKE(i,k)+dqPBL(i,k)
+ccc     $     -spread(i,k)*deltaqw(i,k))
+     $        - entr(i,k)*deltaqw(i,k)/sigmaw(i)
+     $        - (death_rate(i)*sigmaw(i)+detr(i,k))*deltaqw(i,k)
+     $        /(1.-sigmaw(i)))
+ccc
+
+ccc nrlmd
+ccc       d_deltatw2(i,k)=d_deltatw2(i,k)+d_deltatw(i,k)
+ccc       d_deltaqw2(i,k)=d_deltaqw2(i,k)+d_deltaqw(i,k)
+ccc
+       ENDIF
+      ENDDO
+      ENDDO
+
+C
+C   Scale tendencies so that water vapour remains positive in w and x.
+C
+      call wake_vec_modulation(klon,klev,wk_adv,epsilon,qe,d_qe,deltaqw,
+     $                d_deltaqw,sigmaw,d_sigmaw,alpha)
+c
+ccc nrlmd
+cc      print*,'alpha'
+cc      do i=1,klon
+cc         print*,alpha(i)
+cc      end do
+ccc
+      DO k = 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
+        d_te(i,k)=alpha(i)*d_te(i,k)
+        d_qe(i,k)=alpha(i)*d_qe(i,k)
+        d_deltatw(i,k)=alpha(i)*d_deltatw(i,k)
+        d_deltaqw(i,k)=alpha(i)*d_deltaqw(i,k)
+        d_deltat_gw(i,k)=alpha(i)*d_deltat_gw(i,k)
+       ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1,klon
+       IF( wk_adv(i)) THEN
+        d_sigmaw(i)=alpha(i)*d_sigmaw(i)
+       ENDIF
+      ENDDO
+
+C   Update large scale variables and wake variables
+cIM 060208 manque DO i + remplace DO k=1,kupper(i)
+cIM 060208     DO k = 1,kupper(i)
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
+        dtls(i,k)=dtls(i,k)+d_te(i,k)
+        dqls(i,k)=dqls(i,k)+d_qe(i,k)
+ccc nrlmd
+        d_deltatw2(i,k)=d_deltatw2(i,k)+d_deltatw(i,k)
+        d_deltaqw2(i,k)=d_deltaqw2(i,k)+d_deltaqw(i,k)
+ccc
+       ENDIF
+      ENDDO
+      ENDDO
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
+        te(i,k) = te0(i,k) + dtls(i,k)
+        qe(i,k) = qe0(i,k) + dqls(i,k)
+        the(i,k) = te(i,k)/ppi(i,k)
+        deltatw(i,k) = deltatw(i,k)+d_deltatw(i,k)
+        deltaqw(i,k) = deltaqw(i,k)+d_deltaqw(i,k)
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+cc      print*,'k,qx,qw',k,qe(i,k)-sigmaw(i)*deltaqw(i,k)
+cc     $        ,qe(i,k)+(1-sigmaw(i))*deltaqw(i,k)
+       ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1,klon
+       IF( wk_adv(i)) THEN
+        sigmaw(i) = sigmaw(i)+d_sigmaw(i)
+       ENDIF
+      ENDDO
+c
+C
+c     Determine Ptop from buoyancy integral
+c     ---------------------------------------
+c
+c-     1/ Pressure of the level where dth changes sign.
+c
+      DO i=1,klon
+       IF ( wk_adv(i)) THEN
+        Ptop_provis(i)=ph(i,1)
+       ENDIF
+      ENDDO
+c
+      DO k= 2,klev
+      DO i=1,klon
+        IF ( wk_adv(i) .AND.
+     $       Ptop_provis(i) .EQ. ph(i,1) .AND.
+     $      dth(i,k) .GT. -delta_t_min .and.
+     $      dth(i,k-1).LT. -delta_t_min) THEN
+          Ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
+     $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k)
+     $          - dth(i,k-1))
+        ENDIF
+      ENDDO
+      ENDDO
+c
+c-     2/ dth integral
+c
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+       sum_dth(i) = 0.
+       dthmin(i) = -delta_t_min
+       z(i) = 0.
+       end if
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+       IF ( wk_adv(i)) THEN
+        dz(i) = -(amax1(ph(i,k+1),Ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .gt. 0) THEN
+         z(i) = z(i)+dz(i)
+         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+         dthmin(i) = amin1(dthmin(i),dth(i,k))
+        ENDIF
+       ENDIF
+      ENDDO
+      ENDDO
+c
+c-     3/ height of triangle with area= sum_dth and base = dthmin
+
+      DO i=1,klon
+       IF ( wk_adv(i)) THEN
+         hw(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5)
+         hw(i) = amax1(hwmin,hw(i))
+       ENDIF
+      ENDDO
+c
+c-     4/ now, get Ptop
+c
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+       ktop(i) = 0
+       z(i)=0.
+       end if
+      ENDDO
+c
+      DO k = 1,klev
+      DO i=1,klon
+       IF ( wk_adv(i)) THEN
+        dz(i) = amin1(-(ph(i,k+1)-Ph(i,k))/(rho(i,k)*rg),hw(i)-z(i))
+        IF (dz(i) .gt. 0) THEN
+         z(i) = z(i)+dz(i)
+         Ptop(i) = Ph(i,k)-rho(i,k)*rg*dz(i)
+         ktop(i) = k
+        ENDIF
+       ENDIF
+      ENDDO
+      ENDDO
+c
+c      4.5/Correct ktop and ptop
+c
+      DO i=1,klon
+       IF ( wk_adv(i)) THEN
+        Ptop_new(i)=ptop(i)
+       ENDIF
+      ENDDO
+c
+      DO k= klev,2,-1
+      DO i=1,klon
+cIM v3JYG; IF (k .GE. ktop(i)
+       IF ( wk_adv(i) .AND.
+     $      k .LE. ktop(i) .AND.
+     $      ptop_new(i) .EQ. ptop(i) .AND.
+     $      dth(i,k) .GT. -delta_t_min .and.
+     $      dth(i,k-1).LT. -delta_t_min) THEN
+          Ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)
+     $          - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k)
+     $          - dth(i,k-1))
+        ENDIF
+      ENDDO
+      ENDDO
+c
+c
+      DO i=1,klon
+       IF ( wk_adv(i)) THEN
+        ptop(i) = ptop_new(i)
+       ENDIF
+      ENDDO
+
+      DO k=klev,1,-1
+      DO i=1,klon
+      if (wk_adv(i)) then !!! nrlmd
+        IF (ph(i,k+1) .LT. ptop(i)) ktop(i)=k
+      end if
+      ENDDO
+      ENDDO
+c
+c      5/ Set deltatw & deltaqw to 0 above kupper
+c
+      DO k = 1,klev
+      DO i=1,klon
+        IF ( wk_adv(i) .AND. k .GE. kupper(i)) THEN
+         deltatw(i,k) = 0.
+         deltaqw(i,k) = 0.
+        ENDIF
+      ENDDO
+      ENDDO
+c
+C
+c-------------Cstar computation---------------------------------
+      DO i=1, klon
+       if (wk_adv(i)) then !!! nrlmd
+      sum_thu(i) = 0.
+      sum_tu(i) = 0.
+      sum_qu(i) = 0.
+      sum_thvu(i) = 0.
+      sum_dth(i) = 0.
+      sum_dq(i) = 0.
+      sum_rho(i) = 0.
+      sum_dtdwn(i) = 0.
+      sum_dqdwn(i) = 0.
+
+      av_thu(i) = 0.
+      av_tu(i) =0.
+      av_qu(i) =0.
+      av_thvu(i) = 0.
+      av_dth(i) = 0.
+      av_dq(i) = 0.
+      av_rho(i) =0.
+      av_dtdwn(i) =0.
+      av_dqdwn(i) = 0.
+       end if
+      ENDDO
+C
+C Integrals (and wake top level number)
+C --------------------------------------
+C
+C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+      z(i) = 1.
+      dz(i) = 1.
+      sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
+      sum_dth(i) = 0.
+       end if
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+        dz(i) = -(max(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .GT. 0) THEN
+         z(i) = z(i)+dz(i)
+         sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i)
+         sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i)
+         sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i)
+         sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i)
+         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+         sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
+         sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
+         sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
+         sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
+        ENDIF
+       end if
+      ENDDO
+      ENDDO
+c
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+        hw0(i) = z(i)
+       end if
+      ENDDO
+c
+C
+C - WAPE and mean forcing computation
+C ---------------------------------------
+C
+C ---------------------------------------
+C
+C Means
+
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+       av_thu(i) = sum_thu(i)/hw0(i)
+       av_tu(i) = sum_tu(i)/hw0(i)
+       av_qu(i) = sum_qu(i)/hw0(i)
+       av_thvu(i) = sum_thvu(i)/hw0(i)
+       av_dth(i) = sum_dth(i)/hw0(i)
+       av_dq(i) = sum_dq(i)/hw0(i)
+       av_rho(i) = sum_rho(i)/hw0(i)
+       av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
+       av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
+c
+       wape(i) = - rg*hw0(i)*(av_dth(i)
+     $     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+av_dth(i)*
+     $     av_dq(i) ))/av_thvu(i)
+       end if
+      ENDDO
+C
+C Filter out bad wakes
+
+      DO k = 1,klev
+       DO i=1,klon
+        if (wk_adv(i)) then !!! nrlmd
+        IF ( wape(i) .LT. 0.) THEN
+          deltatw(i,k) = 0.
+          deltaqw(i,k) = 0.
+          dth(i,k) = 0.
+        ENDIF
+	end if
+       ENDDO
+      ENDDO
+c
+      DO i=1,klon
+      if (wk_adv(i)) then !!! nrlmd
+      IF ( wape(i) .LT. 0.) THEN
+        wape(i) = 0.
+        Cstar(i) = 0.
+        hw(i) = hwmin
+        sigmaw(i) = max(sigmad,sigd_con(i))
+        fip(i) = 0.
+        gwake(i) = .FALSE.
+      ELSE
+        Cstar(i) = stark*sqrt(2.*wape(i))
+        gwake(i) = .TRUE.
+      ENDIF
+      end if
+      ENDDO
+
+       ENDDO      ! end sub-timestep loop
+C
+C -----------------------------------------------------------------
+c   Get back to tendencies per second
+c
+      DO k = 1,klev
+      DO i=1,klon
+
+ccc nrlmd        IF ( wk_adv(i) .AND. k .LE. kupper(i)) THEN
+        IF ( OK_qx_qw(i) .AND. k .LE. kupper(i)) THEN
+ccc
+         dtls(i,k) = dtls(i,k)/dtime
+         dqls(i,k) = dqls(i,k)/dtime
+         d_deltatw2(i,k)=d_deltatw2(i,k)/dtime
+         d_deltaqw2(i,k)=d_deltaqw2(i,k)/dtime
+         d_deltat_gw(i,k) = d_deltat_gw(i,k)/dtime
+cc      print*,'k,dqls,omg,entr,detr',k,dqls(i,k),omg(i,k),entr(i,k)
+cc     $         ,death_rate(i)*sigmaw(i)
+        ENDIF
+      ENDDO
+      ENDDO
+
+c
+c----------------------------------------------------------
+c   Determine wake final state; recompute wape, cstar, ktop;
+c   filter out bad wakes.
+c----------------------------------------------------------
+c
+C 2.1 - Undisturbed area and Wake integrals
+C ---------------------------------------------------------
+
+      DO i=1,klon
+ccc nrlmd       if (wk_adv(i)) then !!! nrlmd
+      if (OK_qx_qw(i)) then
+ccc
+        z(i) = 0.
+        sum_thu(i) = 0.
+        sum_tu(i) = 0.
+        sum_qu(i) = 0.
+        sum_thvu(i) = 0.
+        sum_dth(i) = 0.
+        sum_dq(i) = 0.
+        sum_rho(i) = 0.
+        sum_dtdwn(i) = 0.
+        sum_dqdwn(i) = 0.
+
+        av_thu(i) = 0.
+        av_tu(i) =0.
+        av_qu(i) =0.
+        av_thvu(i) = 0.
+        av_dth(i) = 0.
+        av_dq(i) = 0.
+        av_rho(i) =0.
+        av_dtdwn(i) =0.
+        av_dqdwn(i) = 0.
+       end if	
+      ENDDO
+C Potential temperatures and humidity
+c----------------------------------------------------------
+
+      DO k =1,klev
+      DO i=1,klon
+ccc nrlmd       IF ( wk_adv(i)) THEN
+       if (OK_qx_qw(i)) then
+ccc
+        rho(i,k) = p(i,k)/(rd*te(i,k))
+        IF(k .eq. 1) THEN
+          rhoh(i,k) = ph(i,k)/(rd*te(i,k))
+          zhh(i,k)=0
+        ELSE
+          rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(i,k-1)))
+          zhh(i,k)=(ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG)+zhh(i,k-1)
+        ENDIF
+        the(i,k) = te(i,k)/ppi(i,k)
+        thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k)
+        tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i)
+        qu(i,k)  =  qe(i,k) - deltaqw(i,k)*sigmaw(i)
+        rhow(i,k) = p(i,k)/(rd*(te(i,k)+deltatw(i,k)))
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+       ENDIF
+      ENDDO
+      ENDDO
+
+C Integrals (and wake top level number)
+C -----------------------------------------------------------
+
+C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      DO i=1,klon
+ccc nrlmd       IF ( wk_adv(i)) THEN
+      if (OK_qx_qw(i)) then
+ccc
+        z(i) = 1.
+        dz(i) = 1.
+        sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
+        sum_dth(i) = 0.
+      ENDIF
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+ccc nrlmd       IF ( wk_adv(i)) THEN
+       if (OK_qx_qw(i)) then
+ccc
+        dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .GT. 0) THEN
+         z(i) = z(i)+dz(i)
+         sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i)
+         sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i)
+         sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i)
+         sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i)
+         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+         sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
+         sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
+         sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
+         sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
+        ENDIF
+       ENDIF
+      ENDDO
+      ENDDO
+c
+      DO i=1,klon
+ccc nrlmd       IF ( wk_adv(i)) THEN
+       if (OK_qx_qw(i)) then
+ccc
+        hw0(i) = z(i)
+       ENDIF
+      ENDDO
+c
+C - WAPE and mean forcing computation
+C-------------------------------------------------------------
+
+C Means
+
+      DO i=1, klon
+ccc nrlmd       IF ( wk_adv(i)) THEN
+      if (OK_qx_qw(i)) then
+ccc
+        av_thu(i) = sum_thu(i)/hw0(i)
+        av_tu(i) = sum_tu(i)/hw0(i)
+        av_qu(i) = sum_qu(i)/hw0(i)
+        av_thvu(i) = sum_thvu(i)/hw0(i)
+        av_dth(i) = sum_dth(i)/hw0(i)
+        av_dq(i) = sum_dq(i)/hw0(i)
+        av_rho(i) = sum_rho(i)/hw0(i)
+        av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
+        av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
+
+        wape2(i) = - rg*hw0(i)*(av_dth(i)
+     $     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)
+     $     + av_dth(i)*av_dq(i) ))/av_thvu(i)
+       ENDIF
+      ENDDO
+
+C Prognostic variable update
+C ------------------------------------------------------------
+
+C Filter out bad wakes
+c
+      DO k = 1,klev
+      DO i=1,klon
+ccc nrlmd        IF ( wk_adv(i) .AND. wape2(i) .LT. 0.) THEN
+      if (OK_qx_qw(i) .AND. wape2(i) .LT. 0.) then
+ccc
+          deltatw(i,k) = 0.
+          deltaqw(i,k) = 0.
+          dth(i,k) = 0.
+        ENDIF
+      ENDDO
+      ENDDO
+c
+
+      DO i=1, klon
+ccc nrlmd       IF ( wk_adv(i)) THEN
+      if (OK_qx_qw(i)) then
+ccc
+       IF ( wape2(i) .LT. 0.) THEN
+        wape2(i) = 0.
+        Cstar2(i) = 0.
+        hw(i) = hwmin
+        sigmaw(i) = amax1(sigmad,sigd_con(i))
+        fip(i) = 0.
+        gwake(i) = .FALSE.
+      ELSE
+        if(prt_level.ge.10) print*,'wape2>0'
+        Cstar2(i) = stark*sqrt(2.*wape2(i))
+        gwake(i) = .TRUE.
+      ENDIF
+      ENDIF
+      ENDDO
+c
+      DO i=1, klon
+ccc nrlmd       IF ( wk_adv(i)) THEN
+       if (OK_qx_qw(i)) then
+ccc
+        ktopw(i) = ktop(i)
+       ENDIF
+      ENDDO
+c
+      DO i=1, klon
+ccc nrlmd       IF ( wk_adv(i)) THEN
+       if (OK_qx_qw(i)) then
+ccc
+       IF (ktopw(i) .gt. 0 .and. gwake(i)) then
+
+Cjyg1     Utilisation d'un h_efficace constant ( ~ feeding layer)
+ccc       heff = 600.
+C      Utilisation de la hauteur hw
+cc       heff = 0.7*hw
+       heff(i) = hw(i)
+
+       FIP(i) = 0.5*rho(i,ktopw(i))*Cstar2(i)**3*heff(i)*2*
+     $      sqrt(sigmaw(i)*wdens(i)*3.14)
+       FIP(i) = alpk * FIP(i)
+Cjyg2
+       ELSE
+         FIP(i) = 0.
+       ENDIF
+       ENDIF
+      ENDDO
+c
+C   Limitation de sigmaw
+
+ccc nrlmd
+c       DO i=1,klon
+c         IF (OK_qx_qw(i)) THEN
+c	   IF (sigmaw(i).GE.sigmaw_max) sigmaw(i)=sigmaw_max
+c	 ENDIF
+c       ENDDO
+ccc
+      DO k = 1,klev
+       DO i=1, klon
+
+ccc nrlmd      On maintient désormais constant sigmaw en régime permanent
+ccc      IF ((sigmaw(i).GT.sigmaw_max).or.
+        IF     ( ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0)).or.
+     $         (ktopw(i).le.2) .OR.
+     $         .not. OK_qx_qw(i) ) THEN
+ccc
+          dtls(i,k) = 0.
+          dqls(i,k) = 0.
+          deltatw(i,k) = 0.
+          deltaqw(i,k) = 0.
+        ENDIF
+       ENDDO
+      ENDDO
+c
+ccc nrlmd      On maintient désormais constant sigmaw en régime permanent
+      DO i=1, klon
+        IF  ( ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0)).or.
+     $        (ktopw(i).le.2) .OR.
+     $        .not. OK_qx_qw(i)   ) THEN
+         wape(i) = 0.
+         cstar(i)=0.
+         hw(i) = hwmin
+         sigmaw(i) = sigmad
+         fip(i) = 0.
+        ELSE
+         wape(i) = wape2(i)
+         cstar(i)=cstar2(i)
+        ENDIF
+cc        print*,'wape wape2 ktopw OK_qx_qw =',
+cc     $          wape(i),wape2(i),ktopw(i),OK_qx_qw(i)
+      ENDDO
+c
+c
+      RETURN
+      END
+
+      SUBROUTINE wake_vec_modulation(nlon,nl,wk_adv,epsilon,qe,d_qe,
+     $           deltaqw,d_deltaqw,sigmaw,d_sigmaw,alpha)
+c------------------------------------------------------
+cDtermination du coefficient alpha tel que les tendances
+c corriges alpha*d_G, pour toutes les grandeurs G, correspondent
+c a une humidite positive dans la zone (x) et dans la zone (w).
+c------------------------------------------------------
+c
+ 
+c  Input
+      REAL qe(nlon,nl),d_qe(nlon,nl)
+      REAL deltaqw(nlon,nl),d_deltaqw(nlon,nl)
+      REAL sigmaw(nlon),d_sigmaw(nlon)
+      LOGICAL wk_adv(nlon)
+      INTEGER nl,nlon
+c  Output
+      REAL alpha(nlon)
+c  Internal variables
+      REAL zeta(nlon,nl)
+      REAL alpha1(nlon)
+      REAL x,a,b,c,discrim
+      REAL epsilon
+!      DATA epsilon/1.e-15/
+c
+      DO k=1,nl
+      DO i = 1,nlon
+       IF (wk_adv(i)) THEN
+        IF ((deltaqw(i,k)+d_deltaqw(i,k)).ge.0.) then
+         zeta(i,k)=0.
+        ELSE
+         zeta(i,k)=1.
+        END IF
+       ENDIF
+      ENDDO
+      DO i = 1,nlon
+       IF (wk_adv(i)) THEN
+        x = qe(i,k)+(zeta(i,k)-sigmaw(i))*deltaqw(i,k)
+     $    + d_qe(i,k)+(zeta(i,k)-sigmaw(i))*d_deltaqw(i,k)
+     $    - d_sigmaw(i)*(deltaqw(i,k)+d_deltaqw(i,k))
+        a = -d_sigmaw(i)*d_deltaqw(i,k)
+        b = d_qe(i,k)+(zeta(i,k)-sigmaw(i))*d_deltaqw(i,k)
+     $    - deltaqw(i,k)*d_sigmaw(i)
+        c = qe(i,k)+(zeta(i,k)-sigmaw(i))*deltaqw(i,k)+epsilon
+        discrim = b*b-4.*a*c
+c      print*, 'x, a, b, c, discrim', x, a, b, c, discrim
+        IF (a+b .GE. 0.) THEN !! Condition suffisante pour la positivité de ovap
+         alpha1(i)=1.
+        ELSE
+         IF (x .GE. 0.) THEN
+            alpha1(i)=1.
+         ELSE
+              IF (a .GT. 0.) THEN
+                 alpha1(i)=0.9*min(   (2.*c)/(-b+sqrt(discrim)),
+     $                        (-b+sqrt(discrim))/(2.*a)   )
+              ELSE IF (a .eq. 0.) then
+                 alpha1(i)=0.9*(-c/b)
+              ELSE
+c         print*,'a,b,c discrim',a,b,c discrim
+                 alpha1(i)=0.9*max(   (2.*c)/(-b+sqrt(discrim)),
+     $                        (-b+sqrt(discrim))/(2.*a)   )
+              ENDIF
+         ENDIF
+        ENDIF
+       alpha(i) = min(alpha(i),alpha1(i))
+       ENDIF
+      ENDDO
+      ENDDO
+!
+      return
+      end
+
+      Subroutine WAKE_scal (p,ph,ppi,dtime,sigd_con
+     :                ,te0,qe0,omgb
+     :                ,dtdwn,dqdwn,amdwn,amup,dta,dqa
+     :                ,wdtPBL,wdqPBL,udtPBL,udqPBL
+     o                ,deltatw,deltaqw,dth,hw,sigmaw,wape,fip,gfl
+     o                ,dtls,dqls
+     o                ,ktopw,omgbdth,dp_omgb,wdens
+     o                ,tu,qu
+     o                ,dtKE,dqKE
+     o                ,dtPBL,dqPBL
+     o                ,omg,dp_deltomg,spread
+     o                ,Cstar,d_deltat_gw
+     o                ,d_deltatw2,d_deltaqw2)
+
+***************************************************************
+*                                                             *
+* WAKE                                                        *
+*      retour a un Pupper fixe                                *
+*                                                             *
+* written by   :  GRANDPEIX Jean-Yves   09/03/2000            *
+* modified by :   ROEHRIG Romain        01/29/2007            *
+***************************************************************
+c
+      USE dimphy
+      IMPLICIT none
+c============================================================================
+C
+C
+C   But : Decrire le comportement des poches froides apparaissant dans les
+C        grands systemes convectifs, et fournir l'energie disponible pour
+C        le declenchement de nouvelles colonnes convectives.
+C
+C   Variables d'etat : deltatw    : ecart de temperature wake-undisturbed area
+C                      deltaqw    : ecart d'humidite wake-undisturbed area
+C                      sigmaw     : fraction d'aire occupee par la poche.
+C
+C   Variable de sortie : 
+c
+c			 wape : WAke Potential Energy
+c                        fip  : Front Incident Power (W/m2) - ALP
+c                        gfl  : Gust Front Length per unit area (m-1)
+C                        dtls : large scale temperature tendency due to wake
+C                        dqls : large scale humidity tendency due to wake
+C                        hw   : hauteur de la poche
+C                     dp_omgb : vertical gradient of large scale omega
+C                      omgbdth: flux of Delta_Theta transported by LS omega
+C                      dtKE   : differential heating (wake - unpertubed)
+C                      dqKE   : differential moistening (wake - unpertubed)
+C                      omg    : Delta_omg =vertical velocity diff. wake-undist. (Pa/s)
+C                 dp_deltomg  : vertical gradient of omg (s-1)
+C                     spread  : spreading term in dt_wake and dq_wake
+C                 deltatw     : updated temperature difference (T_w-T_u).
+C                 deltaqw     : updated humidity difference (q_w-q_u).
+C                 sigmaw      : updated wake fractional area.
+C                 d_deltat_gw : delta T tendency due to GW
+c
+C   Variables d'entree : 
+c
+c		         aire : aire de la maille
+c			 te0  : temperature dans l'environnement  (K)
+C                        qe0  : humidite dans l'environnement     (kg/kg)
+C                        omgb : vitesse verticale moyenne sur la maille (Pa/s)
+C                        dtdwn: source de chaleur due aux descentes (K/s)
+C                        dqdwn: source d'humidite due aux descentes (kg/kg/s)
+C			 dta  : source de chaleur due courants satures et detrain  (K/s)
+C			 dqa  : source d'humidite due aux courants satures et detra (kg/kg/s)
+C                        amdwn: flux de masse total des descentes, par unite de
+C                                surface de la maille (kg/m2/s)
+C                        amup : flux de masse total des ascendances, par unite de
+C                                surface de la maille (kg/m2/s)
+C                        p    : pressions aux milieux des couches (Pa)
+C                        ph   : pressions aux interfaces (Pa)
+C                        ppi  : (p/p_0)**kapa (adim)
+C                        dtime: increment temporel (s)
+c
+C   Variables internes :
+c
+c			 rhow : masse volumique de la poche froide
+C                        rho  : environment density at P levels
+C                        rhoh : environment density at Ph levels
+C                        te   : environment temperature | may change within
+C                        qe   : environment humidity    | sub-time-stepping
+C                        the  : environment potential temperature
+C                        thu  : potential temperature in undisturbed area
+C                        tu   :  temperature  in undisturbed area
+C                        qu   : humidity in undisturbed area
+C                      dp_omgb: vertical gradient og LS omega
+C                      omgbw  : wake average vertical omega
+C                     dp_omgbw: vertical gradient of omgbw
+C                      omgbdq : flux of Delta_q transported by LS omega
+C                        dth  : potential temperature diff. wake-undist.
+C                        th1  : first pot. temp. for vertical advection (=thu)
+C                        th2  : second pot. temp. for vertical advection (=thw)
+C                        q1   : first humidity for vertical advection
+C                        q2   : second humidity for vertical advection
+C                     d_deltatw   : terme de redistribution pour deltatw
+C                     d_deltaqw   : terme de redistribution pour deltaqw
+C                      deltatw0   : deltatw initial
+C                      deltaqw0   : deltaqw initial
+C                      hw0    : hw initial
+C                      sigmaw0: sigmaw initial
+C                      amflux : horizontal mass flux through wake boundary
+C                      wdens  : number of wakes per unit area (3D) or per
+C                               unit length (2D)
+C                      Tgw    : 1 sur la période de onde de gravité
+c                      Cgw    : vitesse de propagation de onde de gravité
+c                      LL     : distance entre 2 poches
+
+c-------------------------------------------------------------------------
+c          Déclaration de variables
+c-------------------------------------------------------------------------
+
+#include "dimensions.h"
+cccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "cvthermo.h"
+#include "iniprint.h"
+
+c Arguments en entree
+c--------------------
+
+      REAL p(klev),ph(klev+1),ppi(klev)
+      REAL dtime
+      REAL te0(klev),qe0(klev)
+      REAL omgb(klev+1)
+      REAL dtdwn(klev), dqdwn(klev)
+      REAL wdtPBL(klev),wdqPBL(klev)
+      REAL udtPBL(klev),udqPBL(klev)
+      REAL amdwn(klev), amup(klev)
+      REAL dta(klev), dqa(klev)
+      REAL sigd_con
+
+c Sorties
+c--------
+
+      REAL deltatw(klev), deltaqw(klev), dth(klev)
+      REAL tu(klev), qu(klev)
+      REAL dtls(klev), dqls(klev)
+      REAL dtKE(klev), dqKE(klev)
+      REAL dtPBL(klev), dqPBL(klev)
+      REAL spread(klev)
+      REAL d_deltatgw(klev)
+      REAL d_deltatw2(klev), d_deltaqw2(klev)
+      REAL omgbdth(klev+1), omg(klev+1)
+      REAL dp_omgb(klev), dp_deltomg(klev)
+      REAL d_deltat_gw(klev)
+      REAL hw, sigmaw, wape, fip, gfl, Cstar
+      INTEGER ktopw
+
+c Variables internes
+c-------------------
+
+c Variables à fixer
+      REAL ALON
+      REAL coefgw
+      REAL wdens0, wdens
+      REAL stark
+      REAL alpk
+      REAL delta_t_min
+      REAL Pupper
+      INTEGER nsub
+      REAL dtimesub
+      REAL sigmad, hwmin
+
+c Variables de sauvegarde
+      REAL deltatw0(klev)
+      REAL deltaqw0(klev)
+      REAL te(klev), qe(klev)
+      REAL sigmaw0, sigmaw1
+
+c Variables pour les GW
+      REAL LL
+      REAL N2(klev)
+      REAL Cgw(klev)
+      REAL Tgw(klev)
+
+c Variables liées au calcul de hw
+      REAL ptop_provis, ptop, ptop_new
+      REAL sum_dth
+      REAL dthmin
+      REAL z, dz, hw0
+      INTEGER ktop, kupper
+
+c Autres variables internes
+      INTEGER isubstep, k
+
+      REAL sum_thu, sum_tu, sum_qu,sum_thvu
+      REAL sum_dq, sum_rho
+      REAL sum_dtdwn, sum_dqdwn
+      REAL av_thu, av_tu, av_qu, av_thvu
+      REAL av_dth, av_dq, av_rho
+      REAL av_dtdwn, av_dqdwn
+
+      REAL rho(klev), rhoh(klev+1), rhow(klev)
+      REAL rhow_moyen(klev)
+      REAL zh(klev), zhh(klev+1)
+      REAL epaisseur1(klev), epaisseur2(klev)
+
+      REAL the(klev), thu(klev)
+
+      REAL d_deltatw(klev), d_deltaqw(klev)
+
+      REAL omgbw(klev+1), omgtop
+      REAL dp_omgbw(klev)
+      REAL ztop, dztop
+      REAL alpha_up(klev)
+      
+      REAL RRe1, RRe2, RRd1, RRd2
+      REAL Th1(klev), Th2(klev), q1(klev), q2(klev)
+      REAL D_Th1(klev), D_Th2(klev), D_dth(klev)
+      REAL D_q1(klev), D_q2(klev), D_dq(klev)
+      REAL omgbdq(klev)
+
+      REAL ff, gg
+      REAL wape2, Cstar2, heff
+
+      REAL Crep(klev)
+      REAL Crep_upper, Crep_sol
+
+C-------------------------------------------------------------------------
+c         Initialisations
+c-------------------------------------------------------------------------
+
+c      print*, 'wake initialisations'
+
+c   Essais d'initialisation avec sigmaw = 0.02 et hw = 10.
+c-------------------------------------------------------------------------
+
+      DATA sigmad, hwmin /.02,10./
+
+C Longueur de maille (en m)
+c-------------------------------------------------------------------------
+
+c      ALON = 3.e5
+      ALON = 1.e6
+
+
+C Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei)
+c
+c      coefgw : Coefficient pour les ondes de gravité
+c       stark : Coefficient k dans Cstar=k*sqrt(2*WAPE)
+c       wdens : Densité de poche froide par maille
+c-------------------------------------------------------------------------
+
+      coefgw=10
+c      coefgw=1
+c      wdens0 = 1.0/(alon**2)   
+      wdens = 1.0/(alon**2)       
+      stark = 0.50
+cCRtest
+      alpk=0.1
+c      alpk = 1.0 
+c      alpk = 0.5
+c      alpk = 0.05
+      Crep_upper=0.9
+      Crep_sol=1.0
+
+
+C Minimum value for |T_wake - T_undist|. Used for wake top definition
+c-------------------------------------------------------------------------
+
+      delta_t_min = 0.2
+
+
+C 1. - Save initial values and initialize tendencies
+C --------------------------------------------------
+
+      DO k=1,klev
+	deltatw0(k) = deltatw(k)
+	deltaqw0(k)= deltaqw(k)
+	te(k) = te0(k)
+	qe(k) = qe0(k)
+	dtls(k) = 0.
+	dqls(k) = 0.
+        d_deltat_gw(k)=0.
+        d_deltatw2(k)=0.
+        d_deltaqw2(k)=0.
+      ENDDO
+c      sigmaw1=sigmaw
+c      IF (sigd_con.GT.sigmaw1) THEN
+c      print*, 'sigmaw,sigd_con', sigmaw, sigd_con
+c      ENDIF
+      sigmaw = max(sigmaw,sigd_con)
+      sigmaw = max(sigmaw,sigmad)
+      sigmaw = min(sigmaw,0.99)
+      sigmaw0 = sigmaw
+c      wdens=wdens0/(10.*sigmaw)
+c      IF (sigd_con.GT.sigmaw1) THEN
+c      print*, 'sigmaw1,sigd1', sigmaw, sigd_con
+c      ENDIF
+
+C 2. - Prognostic part
+C =========================================================
+
+c      print *, 'prognostic wake computation'
+
+
+C 2.1 - Undisturbed area and Wake integrals
+C ---------------------------------------------------------
+
+      z = 0.
+      ktop=0
+      kupper = 0
+      sum_thu = 0.
+      sum_tu = 0.
+      sum_qu = 0.
+      sum_thvu = 0.
+      sum_dth = 0.
+      sum_dq = 0.
+      sum_rho = 0.
+      sum_dtdwn = 0.
+      sum_dqdwn = 0.
+
+      av_thu = 0.
+      av_tu =0.
+      av_qu =0.
+      av_thvu = 0.
+      av_dth = 0.
+      av_dq = 0.
+      av_rho =0.
+      av_dtdwn =0.
+      av_dqdwn = 0.
+
+C Potential temperatures and humidity
+c----------------------------------------------------------
+
+      DO k =1,klev
+        rho(k) = p(k)/(rd*te(k))
+        IF(k .eq. 1) THEN
+          rhoh(k) = ph(k)/(rd*te(k))
+          zhh(k)=0
+        ELSE
+          rhoh(k) = ph(k)*2./(rd*(te(k)+te(k-1)))
+          zhh(k)=(ph(k)-ph(k-1))/(-rhoh(k)*RG)+zhh(k-1)
+        ENDIF
+        the(k) = te(k)/ppi(k)
+        thu(k) = (te(k) - deltatw(k)*sigmaw)/ppi(k)
+        tu(k) = te(k) - deltatw(k)*sigmaw
+        qu(k)  =  qe(k) - deltaqw(k)*sigmaw
+        rhow(k) = p(k)/(rd*(te(k)+deltatw(k)))
+        dth(k) = deltatw(k)/ppi(k)
+        LL = (1-sqrt(sigmaw))/sqrt(wdens)       
+      ENDDO
+        
+      DO k = 1, klev-1
+        IF(k.eq.1) THEN
+          N2(k)=0
+        ELSE
+          N2(k)=max(0.,-RG**2/the(k)*rho(k)*(the(k+1)-the(k-1))
+     $           /(p(k+1)-p(k-1)))
+        ENDIF
+        ZH(k)=(zhh(k)+zhh(k+1))/2
+
+        Cgw(k)=sqrt(N2(k))*ZH(k)
+        Tgw(k)=coefgw*Cgw(k)/LL
+      ENDDO
+         
+      N2(klev)=0
+      ZH(klev)=0
+      Cgw(klev)=0
+      Tgw(klev)=0
+
+c  Calcul de la masse volumique moyenne de la colonne
+c-----------------------------------------------------------------
+
+      DO k=1,klev
+        epaisseur1(k)=0.
+        epaisseur2(k)=0.
+      ENDDO
+
+      epaisseur1(1)= -(Ph(2)-Ph(1))/(rho(1)*rg)+1.
+      epaisseur2(1)= -(Ph(2)-Ph(1))/(rho(1)*rg)+1.
+      rhow_moyen(1) = rhow(1)
+
+      DO k = 2, klev
+        epaisseur1(k)= -(Ph(k+1)-Ph(k))/(rho(k)*rg) +1.
+        epaisseur2(k)=epaisseur2(k-1)+epaisseur1(k)
+        rhow_moyen(k) = (rhow_moyen(k-1)*epaisseur2(k-1)+
+     $                 rhow(k)*epaisseur1(k))/epaisseur2(k)
+      ENDDO
+
+
+C Choose an integration bound well above wake top
+c-----------------------------------------------------------------
+
+c       Pupper = 50000.  ! melting level
+       Pupper = 60000.
+c       Pupper = 70000.
+
+
+C    Determine Wake top pressure (Ptop) from buoyancy integral
+C-----------------------------------------------------------------
+
+c-1/ Pressure of the level where dth becomes less than delta_t_min.
+
+      Ptop_provis=ph(1)
+      DO k= 2,klev
+        IF (dth(k) .GT. -delta_t_min .and.
+     $      dth(k-1).LT. -delta_t_min) THEN
+          Ptop_provis = ((dth(k)+delta_t_min)*p(k-1)
+     $          - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1))
+          GO TO 25
+        ENDIF
+      ENDDO
+25    CONTINUE
+
+c-2/ dth integral
+
+      sum_dth = 0.
+      dthmin = -delta_t_min
+      z = 0.
+
+      DO k = 1,klev
+        dz = -(max(ph(k+1),Ptop_provis)-Ph(k))/(rho(k)*rg)
+        IF (dz .le. 0) GO TO 40
+        z = z+dz
+        sum_dth = sum_dth + dth(k)*dz
+        dthmin = min(dthmin,dth(k))
+      ENDDO
+40    CONTINUE
+
+c-3/ height of triangle with area= sum_dth and base = dthmin
+
+      hw0 = 2.*sum_dth/min(dthmin,-0.5)
+      hw0 = max(hwmin,hw0)
+
+c-4/ now, get Ptop
+
+      z = 0.
+      ptop = ph(1)
+
+      DO k = 1,klev
+        dz = min(-(ph(k+1)-Ph(k))/(rho(k)*rg),hw0-z)
+        IF (dz .le. 0) GO TO 45
+        z = z+dz
+        Ptop = Ph(k)-rho(k)*rg*dz
+      ENDDO
+45    CONTINUE
+
+
+C-5/ Determination de ktop et kupper
+
+      DO k=klev,1,-1
+        IF (ph(k+1) .lt. ptop) ktop=k
+        IF (ph(k+1) .lt. pupper) kupper=k
+      ENDDO
+
+c-6/ Correct ktop and ptop
+
+      Ptop_new=ptop
+      DO k= ktop,2,-1
+        IF (dth(k) .GT. -delta_t_min .and.
+     $      dth(k-1).LT. -delta_t_min) THEN
+          Ptop_new = ((dth(k)+delta_t_min)*p(k-1)
+     $          - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1))
+          GO TO 225
+        ENDIF
+      ENDDO
+225   CONTINUE
+
+      ptop = ptop_new
+
+      DO k=klev,1,-1
+        IF (ph(k+1) .lt. ptop) ktop=k
+      ENDDO
+
+c Set deltatw & deltaqw to 0 above kupper
+c-----------------------------------------------------------
+
+      DO k = kupper,klev
+        deltatw(k) = 0.
+        deltaqw(k) = 0.
+      ENDDO
+
+
+C Vertical gradient of LS omega
+C------------------------------------------------------------
+
+      DO k = 1,kupper
+        dp_omgb(k) = (omgb(k+1) - omgb(k))/(ph(k+1)-ph(k))
+      ENDDO
+
+
+C Integrals (and wake top level number)
+C -----------------------------------------------------------
+
+C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      z = 1.
+      dz = 1.
+      sum_thvu =  thu(1)*(1.+eps*qu(1))*dz
+      sum_dth = 0.
+
+      DO k = 1,klev
+        dz = -(max(ph(k+1),Ptop)-Ph(k))/(rho(k)*rg)
+        IF (dz .LE. 0) GO TO 50
+        z = z+dz
+        sum_thu = sum_thu + thu(k)*dz
+        sum_tu = sum_tu + tu(k)*dz
+        sum_qu = sum_qu + qu(k)*dz
+        sum_thvu = sum_thvu + thu(k)*(1.+eps*qu(k))*dz
+        sum_dth = sum_dth + dth(k)*dz
+        sum_dq = sum_dq + deltaqw(k)*dz
+        sum_rho = sum_rho + rhow(k)*dz
+        sum_dtdwn = sum_dtdwn + dtdwn(k)*dz
+        sum_dqdwn = sum_dqdwn + dqdwn(k)*dz
+      ENDDO
+50    CONTINUE
+
+      hw0 = z
+
+C 2.1 - WAPE and mean forcing computation
+C-------------------------------------------------------------
+
+C Means
+
+      av_thu = sum_thu/hw0
+      av_tu = sum_tu/hw0
+      av_qu = sum_qu/hw0
+      av_thvu = sum_thvu/hw0
+c      av_thve = sum_thve/hw0
+      av_dth = sum_dth/hw0
+      av_dq = sum_dq/hw0
+      av_rho = sum_rho/hw0
+      av_dtdwn = sum_dtdwn/hw0
+      av_dqdwn = sum_dqdwn/hw0
+
+      wape = - rg*hw0*(av_dth
+     $     + eps*(av_thu*av_dq+av_dth*av_qu+av_dth*av_dq ))/av_thvu
+
+C 2.2 Prognostic variable update
+C ------------------------------------------------------------
+
+C Filter out bad wakes
+
+      IF ( wape .LT. 0.) THEN
+        if(prt_level.ge.10) print*,'wape<0'
+        wape = 0.
+        hw = hwmin
+        sigmaw = max(sigmad,sigd_con)
+        fip = 0.
+        DO k = 1,klev
+          deltatw(k) = 0.
+          deltaqw(k) = 0.
+          dth(k) = 0.
+        ENDDO
+      ELSE
+        if(prt_level.ge.10) print*,'wape>0'
+        Cstar = stark*sqrt(2.*wape)
+      ENDIF
+
+C------------------------------------------------------------------
+C    Sub-time-stepping
+C------------------------------------------------------------------
+
+c      nsub=36
+      nsub=10
+      dtimesub=dtime/nsub
+
+c------------------------------------------------------------
+      DO isubstep = 1,nsub
+c------------------------------------------------------------
+
+c        print*,'---------------','substep=',isubstep,'-------------'
+
+c  Evolution of sigmaw
+
+
+        gfl = 2.*sqrt(3.14*wdens*sigmaw)            
+
+        sigmaw =sigmaw + gfl*Cstar*dtimesub
+        sigmaw =min(sigmaw,0.99)     !!!!!!!!
+c        wdens = wdens0/(10.*sigmaw)
+c        sigmaw =max(sigmaw,sigd_con)
+c        sigmaw =max(sigmaw,sigmad)
+
+c calcul de la difference de vitesse verticale poche - zone non perturbee
+
+        z= 0.
+        dp_deltomg(1:klev)=0.
+        omg(1:klev+1)=0.
+
+        omg(1) = 0.
+        dp_deltomg(1) = -(gfl*Cstar)/(sigmaw * (1-sigmaw))
+
+        DO k=2,ktop
+          dz = -(Ph(k)-Ph(k-1))/(rho(k-1)*rg)
+          z = z+dz
+          dp_deltomg(k)= dp_deltomg(1)
+          omg(k)= dp_deltomg(1)*z
+        ENDDO
+
+        dztop=-(Ptop-Ph(ktop))/(rho(ktop)*rg)
+        ztop = z+dztop
+        omgtop=dp_deltomg(1)*ztop
+
+
+c Conversion de la vitesse verticale de m/s a Pa/s
+
+        omgtop = -rho(ktop)*rg*omgtop
+        dp_deltomg(1) = omgtop/(ptop-ph(1))
+
+        DO k = 1,ktop
+          omg(k) = - rho(k)*rg*omg(k)
+          dp_deltomg(k) = dp_deltomg(1)
+        ENDDO
+
+c   raccordement lineaire de omg de ptop a pupper
+
+      IF (kupper .GT. ktop) THEN
+        omg(kupper+1) = - Rg*amdwn(kupper+1)/sigmaw
+     $                + Rg*amup(kupper+1)/(1.-sigmaw)
+        dp_deltomg(kupper) = (omgtop-omg(kupper+1))/(Ptop-Pupper)
+        DO k=ktop+1,kupper
+          dp_deltomg(k) = dp_deltomg(kupper)
+          omg(k) = omgtop+(ph(k)-Ptop)*dp_deltomg(kupper)
+        ENDDO
+      ENDIF
+
+c   Compute wake average vertical velocity omgbw
+
+      DO k = 1,klev+1
+        omgbw(k) = omgb(k)+(1.-sigmaw)*omg(k)
+      ENDDO
+
+c  and its vertical gradient dp_omgbw
+
+      DO k = 1,klev
+        dp_omgbw(k) = (omgbw(k+1)-omgbw(k))/(ph(k+1)-ph(k))
+      ENDDO
+
+
+c  Upstream coefficients for omgb velocity
+c--    (alpha_up(k) is the coefficient of the value at level k)
+c--    (1-alpha_up(k) is the coefficient of the value at level k-1)
+
+      DO k = 1,klev
+       alpha_up(k) = 0.
+       IF (omgb(k) .GT. 0.) alpha_up(k) = 1.
+      ENDDO
+
+c  Matrix expressing [The,deltatw] from  [Th1,Th2]
+
+      RRe1 = 1.-sigmaw
+      RRe2 = sigmaw
+      RRd1 = -1.
+      RRd2 = 1.
+
+c Get [Th1,Th2], dth and [q1,q2]
+
+      DO k = 1,kupper+1
+        dth(k) = deltatw(k)/ppi(k)
+        Th1(k) = the(k) - sigmaw     *dth(k)   ! undisturbed area
+        Th2(k) = the(k) + (1.-sigmaw)*dth(k)   ! wake
+        q1(k) = qe(k) - sigmaw     *deltaqw(k) ! undisturbed area
+        q2(k) = qe(k) + (1.-sigmaw)*deltaqw(k) ! wake
+      ENDDO
+
+      D_Th1(1) = 0.
+      D_Th2(1) = 0.
+      D_dth(1) = 0.
+      D_q1(1) = 0.
+      D_q2(1) = 0.
+      D_dq(1) = 0.
+
+      DO k = 2,kupper+1 !   loop on interfaces
+        D_Th1(k) = Th1(k-1)-Th1(k)
+        D_Th2(k) = Th2(k-1)-Th2(k)
+        D_dth(k) = dth(k-1)-dth(k)
+        D_q1(k) = q1(k-1)-q1(k)
+        D_q2(k) = q2(k-1)-q2(k)
+        D_dq(k) = deltaqw(k-1)-deltaqw(k)
+      ENDDO
+
+      omgbdth(1) = 0.
+      omgbdq(1) = 0.
+
+      DO k = 2,kupper+1  !   loop on interfaces
+        omgbdth(k) = omgb(k)*(    dth(k-1) -     dth(k))
+        omgbdq(k)  = omgb(k)*(deltaqw(k-1) - deltaqw(k))
+      ENDDO
+
+
+c-----------------------------------------------------------------
+      DO k=1,kupper-1
+c-----------------------------------------------------------------
+c
+c   Compute redistribution (advective) term
+c
+         d_deltatw(k) =
+     $             dtimesub/(Ph(k)-Ph(k+1))*(
+     $       RRd1*omg(k  )*sigmaw     *D_Th1(k)
+     $      -RRd2*omg(k+1)*(1.-sigmaw)*D_Th2(k+1)
+     $      -(1.-alpha_up(k))*omgbdth(k) - alpha_up(k+1)*omgbdth(k+1)
+     $                      )*ppi(k)
+c         print*,'d_deltatw=',d_deltatw(k)
+c
+         d_deltaqw(k) =
+     $             dtimesub/(Ph(k)-Ph(k+1))*(
+     $       RRd1*omg(k  )*sigmaw     *D_q1(k)
+     $      -RRd2*omg(k+1)*(1.-sigmaw)*D_q2(k+1)
+     $      -(1.-alpha_up(k))*omgbdq(k) - alpha_up(k+1)*omgbdq(k+1)
+     $                      )
+c         print*,'d_deltaqw=',d_deltaqw(k)
+c
+c   and increment large scale tendencies
+c
+         dtls(k) = dtls(k) +
+     $               dtimesub*(
+     $        ( RRe1*omg(k  )*sigmaw     *D_Th1(k)
+     $         -RRe2*omg(k+1)*(1.-sigmaw)*D_Th2(k+1) )
+     $               /(Ph(k)-Ph(k+1))
+     $         -sigmaw*(1.-sigmaw)*dth(k)*dp_deltomg(k)
+     $                      )*ppi(k)
+c         print*,'dtls=',dtls(k)
+c
+         dqls(k) = dqls(k) +
+     $               dtimesub*(
+     $        ( RRe1*omg(k  )*sigmaw     *D_q1(k)
+     $         -RRe2*omg(k+1)*(1.-sigmaw)*D_q2(k+1) )
+     $               /(Ph(k)-Ph(k+1))
+     $         -sigmaw*(1.-sigmaw)*deltaqw(k)*dp_deltomg(k)
+     $                      )
+c         print*,'dqls=',dqls(k)
+
+c-------------------------------------------------------------------
+      ENDDO
+c------------------------------------------------------------------
+
+C   Increment state variables
+
+      DO k = 1,kupper-1
+
+c Coefficient de répartition
+
+        Crep(k)=Crep_sol*(ph(kupper)-ph(k))/(ph(kupper)-ph(1))
+        Crep(k)=Crep(k)+Crep_upper*(ph(1)-ph(k))/(p(1)-ph(kupper))
+        
+
+c Reintroduce compensating subsidence term.
+
+c        dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw
+c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k))
+c     .                   /(1-sigmaw)
+c        dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw
+c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k))
+c     .                   /(1-sigmaw)
+c
+c        dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw
+c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k))
+c     .                   /(1-sigmaw)
+c        dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw
+c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k))
+c     .                   /(1-sigmaw)
+
+        dtKE(k)=(dtdwn(k)/sigmaw - dta(k)/(1.-sigmaw))
+        dqKE(k)=(dqdwn(k)/sigmaw - dqa(k)/(1.-sigmaw))
+c        print*,'dtKE=',dtKE(k)
+c        print*,'dqKE=',dqKE(k)
+c
+        dtPBL(k)=(wdtPBL(k)/sigmaw - udtPBL(k)/(1.-sigmaw))
+        dqPBL(k)=(wdqPBL(k)/sigmaw - udqPBL(k)/(1.-sigmaw))
+c
+        spread(k) = (1.-sigmaw)*dp_deltomg(k)+gfl*Cstar/sigmaw
+c        print*,'spread=',spread(k)
+
+
+c ajout d'un effet onde de gravité -Tgw(k)*deltatw(k) 03/02/06 YU Jingmei
+
+        d_deltat_gw(k)=d_deltat_gw(k)-Tgw(k)*deltatw(k)* dtimesub
+c        print*,'d_delta_gw=',d_deltat_gw(k)
+        ff=d_deltatw(k)/dtimesub
+
+c Sans GW
+c
+c        deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-spread(k)*deltatw(k)) 
+c
+c GW formule 1
+c
+c        deltatw(k) = deltatw(k)+dtimesub*
+c     $         (ff+dtKE(k) - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
+c
+c GW formule 2
+
+        IF (dtimesub*Tgw(k).lt.1.e-10) THEN
+          deltatw(k) = deltatw(k)+dtimesub*
+     $          (ff+dtKE(k)+dtPBL(k) 
+     $          - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
+        ELSE
+           deltatw(k) = deltatw(k)+1/Tgw(k)*(1-exp(-dtimesub*Tgw(k)))*
+     $          (ff+dtKE(k)+dtPBL(k)
+     $          - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
+        ENDIF
+   
+        dth(k) = deltatw(k)/ppi(k)
+
+        gg=d_deltaqw(k)/dtimesub
+
+       deltaqw(k) = deltaqw(k) +
+     $         dtimesub*(gg+ dqKE(k)+dqPBL(k) - spread(k)*deltaqw(k))
+
+       d_deltatw2(k)=d_deltatw2(k)+d_deltatw(k)
+       d_deltaqw2(k)=d_deltaqw2(k)+d_deltaqw(k)
+      ENDDO
+
+C   And update large scale variables
+
+      DO k = 1,kupper
+        te(k) = te0(k) + dtls(k)
+        qe(k) = qe0(k) + dqls(k)
+        the(k) = te(k)/ppi(k)
+      ENDDO
+
+c     Determine Ptop from buoyancy integral
+c----------------------------------------------------------------------
+
+c-1/ Pressure of the level where dth changes sign.
+
+      Ptop_provis=ph(1)
+
+      DO k= 2,klev
+        IF (dth(k) .GT. -delta_t_min .and.
+     $      dth(k-1).LT. -delta_t_min) THEN
+          Ptop_provis = ((dth(k)+delta_t_min)*p(k-1)
+     $          - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1))
+        GO TO 65
+        ENDIF
+      ENDDO
+65    CONTINUE
+
+c-2/ dth integral
+
+      sum_dth = 0.
+      dthmin = -delta_t_min
+      z = 0.
+
+      DO k = 1,klev
+        dz = -(max(ph(k+1),Ptop_provis)-Ph(k))/(rho(k)*rg)
+        IF (dz .le. 0) GO TO 70
+        z = z+dz
+        sum_dth = sum_dth + dth(k)*dz
+        dthmin = min(dthmin,dth(k))
+      ENDDO
+70    CONTINUE
+
+c-3/ height of triangle with area= sum_dth and base = dthmin
+
+      hw = 2.*sum_dth/min(dthmin,-0.5)
+      hw = max(hwmin,hw)
+
+c-4/ now, get Ptop
+
+      ktop = 0
+      z=0.
+
+      DO k = 1,klev
+        dz = min(-(ph(k+1)-Ph(k))/(rho(k)*rg),hw-z)
+        IF (dz .le. 0) GO TO 75
+        z = z+dz
+        Ptop = Ph(k)-rho(k)*rg*dz
+        ktop = k
+      ENDDO
+75    CONTINUE
+
+c-5/Correct ktop and ptop
+
+      Ptop_new=ptop
+
+      DO k= ktop,2,-1
+        IF (dth(k) .GT. -delta_t_min .and.
+     $      dth(k-1).LT. -delta_t_min) THEN
+          Ptop_new = ((dth(k)+delta_t_min)*p(k-1)
+     $          - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1))
+          GO TO 275
+        ENDIF
+      ENDDO
+275   CONTINUE
+
+      ptop = ptop_new
+
+      DO k=klev,1,-1
+        IF (ph(k+1) .LT. ptop) ktop=k
+      ENDDO
+
+c-6/ Set deltatw & deltaqw to 0 above kupper
+
+      DO k = kupper,klev
+        deltatw(k) = 0.
+        deltaqw(k) = 0.
+      ENDDO
+
+c------------------------------------------------------------------
+      ENDDO      ! end sub-timestep loop
+C -----------------------------------------------------------------
+
+c   Get back to tendencies per second
+
+      DO k = 1,kupper-1
+        dtls(k) = dtls(k)/dtime
+        dqls(k) = dqls(k)/dtime
+        d_deltatw2(k)=d_deltatw2(k)/dtime
+        d_deltaqw2(k)=d_deltaqw2(k)/dtime
+        d_deltat_gw(k) = d_deltat_gw(k)/dtime
+      ENDDO
+
+C 2.1 - Undisturbed area and Wake integrals
+C ---------------------------------------------------------
+
+      z = 0.
+      sum_thu = 0.
+      sum_tu = 0.
+      sum_qu = 0.
+      sum_thvu = 0.
+      sum_dth = 0.
+      sum_dq = 0.
+      sum_rho = 0.
+      sum_dtdwn = 0.
+      sum_dqdwn = 0.
+
+      av_thu = 0.
+      av_tu =0.
+      av_qu =0.
+      av_thvu = 0.
+      av_dth = 0.
+      av_dq = 0.
+      av_rho =0.
+      av_dtdwn =0.
+      av_dqdwn = 0.
+
+C Potential temperatures and humidity
+c----------------------------------------------------------
+
+      DO k =1,klev
+        rho(k) = p(k)/(rd*te(k))
+        IF(k .eq. 1) THEN
+          rhoh(k) = ph(k)/(rd*te(k))
+          zhh(k)=0
+        ELSE
+          rhoh(k) = ph(k)*2./(rd*(te(k)+te(k-1)))
+          zhh(k)=(ph(k)-ph(k-1))/(-rhoh(k)*RG)+zhh(k-1)
+        ENDIF
+        the(k) = te(k)/ppi(k)
+        thu(k) = (te(k) - deltatw(k)*sigmaw)/ppi(k)
+        tu(k) = te(k) - deltatw(k)*sigmaw
+        qu(k)  =  qe(k) - deltaqw(k)*sigmaw
+        rhow(k) = p(k)/(rd*(te(k)+deltatw(k)))
+        dth(k) = deltatw(k)/ppi(k)
+       
+      ENDDO
+
+C Integrals (and wake top level number)
+C -----------------------------------------------------------
+
+C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      z = 1.
+      dz = 1.
+      sum_thvu =  thu(1)*(1.+eps*qu(1))*dz
+      sum_dth = 0.
+
+      DO k = 1,klev
+        dz = -(max(ph(k+1),Ptop)-Ph(k))/(rho(k)*rg)
+
+        IF (dz .LE. 0) GO TO 51
+        z = z+dz
+        sum_thu = sum_thu + thu(k)*dz
+        sum_tu = sum_tu + tu(k)*dz
+        sum_qu = sum_qu + qu(k)*dz
+        sum_thvu = sum_thvu + thu(k)*(1.+eps*qu(k))*dz
+        sum_dth = sum_dth + dth(k)*dz
+        sum_dq = sum_dq + deltaqw(k)*dz
+        sum_rho = sum_rho + rhow(k)*dz
+        sum_dtdwn = sum_dtdwn + dtdwn(k)*dz
+        sum_dqdwn = sum_dqdwn + dqdwn(k)*dz
+      ENDDO
+ 51   CONTINUE
+
+      hw0 = z
+
+C 2.1 - WAPE and mean forcing computation
+C-------------------------------------------------------------
+
+C Means
+
+      av_thu = sum_thu/hw0
+      av_tu = sum_tu/hw0
+      av_qu = sum_qu/hw0
+      av_thvu = sum_thvu/hw0
+      av_dth = sum_dth/hw0
+      av_dq = sum_dq/hw0
+      av_rho = sum_rho/hw0
+      av_dtdwn = sum_dtdwn/hw0
+      av_dqdwn = sum_dqdwn/hw0
+
+      wape2 = - rg*hw0*(av_dth
+     $     + eps*(av_thu*av_dq+av_dth*av_qu+av_dth*av_dq ))/av_thvu
+
+
+C 2.2 Prognostic variable update
+C ------------------------------------------------------------
+
+C Filter out bad wakes
+
+      IF ( wape2 .LT. 0.) THEN
+        if(prt_level.ge.10) print*,'wape2<0'
+        wape2 = 0.
+        hw = hwmin
+        sigmaw = max(sigmad,sigd_con)
+        fip = 0.
+        DO k = 1,klev
+          deltatw(k) = 0.
+          deltaqw(k) = 0.
+          dth(k) = 0.
+        ENDDO
+      ELSE
+        if(prt_level.ge.10) print*,'wape2>0'
+        Cstar2 = stark*sqrt(2.*wape2)
+
+      ENDIF
+
+      ktopw = ktop
+
+      IF (ktopw .gt. 0) then
+
+Cjyg1     Utilisation d'un h_efficace constant ( ~ feeding layer)
+ccc       heff = 600.
+C      Utilisation de la hauteur hw
+cc       heff = 0.7*hw
+       heff = hw
+
+       FIP = 0.5*rho(ktopw)*Cstar2**3*heff*2*sqrt(sigmaw*wdens*3.14)
+       FIP = alpk * FIP
+Cjyg2
+       ELSE
+         FIP = 0.
+       ENDIF
+
+
+C   Limitation de sigmaw
+c
+C   sécurité : si le wake occuppe plus de 90 % de la surface de la maille,
+C              alors il disparait en se mélangeant à la partie undisturbed
+
+! correction NICOLAS     .     ((wape.ge.wape2).and.(wape2.le.1.0))) THEN
+      IF ((sigmaw.GT.0.9).or.
+     .     ((wape.ge.wape2).and.(wape2.le.1.0)).or.(ktopw.le.2)) THEN
+cIM cf NR/JYG 251108    .     ((wape.ge.wape2).and.(wape2.le.1.0))) THEN
+c      IF (sigmaw.GT.0.9) THEN
+        DO k = 1,klev
+          dtls(k) = 0.
+          dqls(k) = 0.
+          deltatw(k) = 0.
+          deltaqw(k) = 0.
+        ENDDO
+        wape = 0.
+        hw = hwmin
+        sigmaw = sigmad
+        fip = 0.
+      ENDIF
+
+      RETURN
+      END
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/wake.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/wake.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/wake.F90	(revision 17)
@@ -0,0 +1,2896 @@
+!
+! $Id: wake.F 1669 2012-10-16 12:41:50Z fairhead $
+!
+      SUBROUTINE WAKE (p,ph,pi,dtime,sigd_con                                        &
+       &                ,te0,qe0,omgb                                                &
+       &                ,dtdwn,dqdwn,amdwn,amup,dta,dqa                              &
+       &                ,wdtPBL,wdqPBL,udtPBL,udqPBL                                 &
+       &                ,deltatw,deltaqw,dth,hw,sigmaw,wape,fip,gfl                  &
+       &                ,dtls,dqls                                                   &
+       &                ,ktopw,omgbdth,dp_omgb,wdens                                 &
+       &                ,tu,qu                                                       &
+       &                ,dtKE,dqKE                                                   &
+       &                ,dtPBL,dqPBL                                                 &
+       &                ,omg,dp_deltomg,spread                                       &
+       &                ,Cstar,d_deltat_gw                                           &
+       &                ,d_deltatw2,d_deltaqw2)
+
+
+!***************************************************************
+!*                                                             *
+!* WAKE                                                        *
+!*      retour a un Pupper fixe                                *
+!*                                                             *
+!* written by   :  GRANDPEIX Jean-Yves   09/03/2000            *
+!* modified by :   ROEHRIG Romain        01/29/2007            *
+!***************************************************************
+!c
+      use dimphy
+      IMPLICIT none
+!c============================================================================
+!C
+!C
+!C   But : Decrire le comportement des poches froides apparaissant dans les
+!C        grands systemes convectifs, et fournir l'energie disponible pour
+!C        le declenchement de nouvelles colonnes convectives.
+!C
+!C   Variables d'etat : deltatw    : ecart de temperature wake-undisturbed area
+!C                      deltaqw    : ecart d'humidite wake-undisturbed area
+!C                      sigmaw     : fraction d'aire occupee par la poche.
+!C
+!C   Variable de sortie : 
+!c
+!c			 wape : WAke Potential Energy
+!c                        fip  : Front Incident Power (W/m2) - ALP
+!c                        gfl  : Gust Front Length per unit area (m-1)
+!C                        dtls : large scale temperature tendency due to wake
+!C                        dqls : large scale humidity tendency due to wake
+!C                        hw   : hauteur de la poche
+!C                     dp_omgb : vertical gradient of large scale omega
+!C                     wdens   : densite de poches
+!C                      omgbdth: flux of Delta_Theta transported by LS omega
+!C                      dtKE   : differential heating (wake - unpertubed)
+!C                      dqKE   : differential moistening (wake - unpertubed)
+!C                      omg    : Delta_omg =vertical velocity diff. wake-undist. (Pa/s)
+!C                 dp_deltomg  : vertical gradient of omg (s-1)
+!C                     spread  : spreading term in dt_wake and dq_wake
+!C                 deltatw     : updated temperature difference (T_w-T_u).
+!C                 deltaqw     : updated humidity difference (q_w-q_u).
+!C                 sigmaw      : updated wake fractional area.
+!C                 d_deltat_gw : delta T tendency due to GW
+!c
+!C   Variables d'entree : 
+!c
+!c		         aire : aire de la maille
+!c			 te0  : temperature dans l'environnement  (K)
+!C                        qe0  : humidite dans l'environnement     (kg/kg)
+!C                        omgb : vitesse verticale moyenne sur la maille (Pa/s)
+!C                        dtdwn: source de chaleur due aux descentes (K/s)
+!C                        dqdwn: source d'humidite due aux descentes (kg/kg/s)
+!C			 dta  : source de chaleur due courants satures et detrain  (K/s)
+!C			 dqa  : source d'humidite due aux courants satures et detra (kg/kg/s)
+!C                        amdwn: flux de masse total des descentes, par unite de
+!C                                surface de la maille (kg/m2/s)
+!C                        amup : flux de masse total des ascendances, par unite de
+!C                                surface de la maille (kg/m2/s)
+!C                        p    : pressions aux milieux des couches (Pa)
+!C                        ph   : pressions aux interfaces (Pa)
+!C                        pi  : (p/p_0)**kapa (adim)
+!C                        dtime: increment temporel (s)
+!c
+!C   Variables internes :
+!c
+!c			 rhow : masse volumique de la poche froide
+!C                        rho  : environment density at P levels
+!C                        rhoh : environment density at Ph levels
+!C                        te   : environment temperature | may change within
+!C                        qe   : environment humidity    | sub-time-stepping
+!C                        the  : environment potential temperature
+!C                        thu  : potential temperature in undisturbed area
+!C                        tu   :  temperature  in undisturbed area
+!C                        qu   : humidity in undisturbed area
+!C                      dp_omgb: vertical gradient og LS omega
+!C                      omgbw  : wake average vertical omega
+!C                     dp_omgbw: vertical gradient of omgbw
+!C                      omgbdq : flux of Delta_q transported by LS omega
+!C                        dth  : potential temperature diff. wake-undist.
+!C                        th1  : first pot. temp. for vertical advection (=thu)
+!C                        th2  : second pot. temp. for vertical advection (=thw)
+!C                        q1   : first humidity for vertical advection
+!C                        q2   : second humidity for vertical advection
+!C                     d_deltatw   : terme de redistribution pour deltatw
+!C                     d_deltaqw   : terme de redistribution pour deltaqw
+!C                      deltatw0   : deltatw initial
+!C                      deltaqw0   : deltaqw initial
+!C                      hw0    : hw initial
+!C                      sigmaw0: sigmaw initial
+!C                      amflux : horizontal mass flux through wake boundary
+!C                      wdens_ref: initial number of wakes per unit area (3D) or per
+!C                               unit length (2D), at the beginning of each time step
+!C                      Tgw    : 1 sur la période de onde de gravité
+!c                      Cgw    : vitesse de propagation de onde de gravité
+!c                      LL     : distance entre 2 poches
+
+!c-------------------------------------------------------------------------
+!c          Déclaration de variables
+!c-------------------------------------------------------------------------
+
+#include "dimensions.h"
+#include "YOMCST.h"
+#include "cvthermo.h"
+#include "iniprint.h"
+
+!c Arguments en entree
+!c--------------------
+
+      REAL, dimension(klon,klev) :: p, pi
+      REAL, dimension(klon,klev+1) :: ph, omgb
+      REAL dtime
+      REAL, dimension(klon,klev) :: te0,qe0
+      REAL, dimension(klon,klev) :: dtdwn, dqdwn
+      REAL, dimension(klon,klev) :: wdtPBL,wdqPBL
+      REAL, dimension(klon,klev) :: udtPBL,udqPBL
+      REAL, dimension(klon,klev) :: amdwn, amup
+      REAL, dimension(klon,klev) :: dta, dqa
+      REAL, dimension(klon) :: sigd_con
+
+!c Sorties
+!c--------
+
+      REAL, dimension(klon,klev) :: deltatw, deltaqw, dth
+      REAL, dimension(klon,klev) :: tu, qu
+      REAL, dimension(klon,klev) :: dtls, dqls
+      REAL, dimension(klon,klev) :: dtKE, dqKE
+      REAL, dimension(klon,klev) :: dtPBL, dqPBL
+      REAL, dimension(klon,klev) :: spread
+      REAL, dimension(klon,klev) :: d_deltatgw
+      REAL, dimension(klon,klev) :: d_deltatw2, d_deltaqw2
+      REAL, dimension(klon,klev+1) :: omgbdth, omg
+      REAL, dimension(klon,klev) :: dp_omgb, dp_deltomg
+      REAL, dimension(klon,klev) :: d_deltat_gw
+      REAL, dimension(klon) :: hw, sigmaw, wape, fip, gfl, Cstar
+      REAL, dimension(klon) :: wdens
+      INTEGER, dimension(klon) :: ktopw
+
+!c Variables internes
+!c-------------------
+
+!c Variables à fixer
+      REAL ALON
+      REAL coefgw
+      REAL :: wdens_ref
+      REAL stark
+      REAL alpk
+      REAL delta_t_min
+      INTEGER nsub
+      REAL dtimesub
+      REAL sigmad, hwmin,wapecut
+      REAL :: sigmaw_max
+      REAL :: dens_rate
+      REAL wdens0
+!IM 080208
+      LOGICAL, dimension(klon) :: gwake
+
+!c Variables de sauvegarde
+      REAL, dimension(klon,klev) :: deltatw0
+      REAL, dimension(klon,klev) :: deltaqw0
+      REAL, dimension(klon,klev) :: te, qe
+      REAL, dimension(klon) :: sigmaw0, sigmaw1
+
+!c Variables pour les GW
+      REAL, DIMENSION(klon) :: LL
+      REAL, dimension(klon,klev) :: N2
+      REAL, dimension(klon,klev) :: Cgw
+      REAL, dimension(klon,klev) :: Tgw
+
+!c Variables liées au calcul de hw
+      REAL, DIMENSION(klon) :: ptop_provis, ptop, ptop_new
+      REAL, DIMENSION(klon) :: sum_dth
+      REAL, DIMENSION(klon) :: dthmin
+      REAL, DIMENSION(klon) :: z, dz, hw0
+      INTEGER, DIMENSION(klon) :: ktop, kupper
+
+!c Sub-timestep tendencies and related variables
+       REAL d_deltatw(klon,klev),d_deltaqw(klon,klev)
+       REAL d_te(klon,klev),d_qe(klon,klev)
+       REAL d_sigmaw(klon),alpha(klon)
+       REAL q0_min(klon),q1_min(klon)
+       LOGICAL wk_adv(klon), OK_qx_qw(klon)
+       REAL epsilon
+       DATA epsilon/1.e-15/
+
+!c Autres variables internes
+      INTEGER isubstep, k, i
+
+      REAL, DIMENSION(klon) :: sum_thu, sum_tu, sum_qu,sum_thvu
+      REAL, DIMENSION(klon) :: sum_dq, sum_rho
+      REAL, DIMENSION(klon) :: sum_dtdwn, sum_dqdwn
+      REAL, DIMENSION(klon) :: av_thu, av_tu, av_qu, av_thvu
+      REAL, DIMENSION(klon) :: av_dth, av_dq, av_rho
+      REAL, DIMENSION(klon) :: av_dtdwn, av_dqdwn
+
+      REAL, DIMENSION(klon,klev) :: rho, rhow
+      REAL, DIMENSION(klon,klev+1) :: rhoh
+      REAL, DIMENSION(klon,klev) :: rhow_moyen
+      REAL, DIMENSION(klon,klev) :: zh
+      REAL, DIMENSION(klon,klev+1) :: zhh
+      REAL, DIMENSION(klon,klev) :: epaisseur1, epaisseur2
+
+      REAL, DIMENSION(klon,klev) :: the, thu
+
+!      REAL, DIMENSION(klon,klev) :: d_deltatw, d_deltaqw
+
+      REAL, DIMENSION(klon,klev+1) :: omgbw
+      REAL, DIMENSION(klon) :: pupper
+      REAL, DIMENSION(klon) :: omgtop
+      REAL, DIMENSION(klon,klev) :: dp_omgbw
+      REAL, DIMENSION(klon) :: ztop, dztop
+      REAL, DIMENSION(klon,klev) :: alpha_up
+      
+      REAL, dimension(klon) :: RRe1, RRe2
+      REAL :: RRd1, RRd2
+      REAL, DIMENSION(klon,klev) :: Th1, Th2, q1, q2
+      REAL, DIMENSION(klon,klev) :: D_Th1, D_Th2, D_dth
+      REAL, DIMENSION(klon,klev) :: D_q1, D_q2, D_dq
+      REAL, DIMENSION(klon,klev) :: omgbdq
+
+      REAL, dimension(klon) :: ff, gg
+      REAL, dimension(klon) :: wape2, Cstar2, heff
+
+      REAL, DIMENSION(klon,klev) :: Crep
+      REAL Crep_upper, Crep_sol
+
+      REAL, DIMENSION(klon,klev) :: ppi
+
+!ccc nrlmd
+      real, dimension(klon) :: death_rate,nat_rate
+      real, dimension(klon,klev) :: entr
+      real, dimension(klon,klev) :: detr
+
+!C-------------------------------------------------------------------------
+!c         Initialisations
+!c-------------------------------------------------------------------------
+
+!c      print*, 'wake initialisations'
+
+!c   Essais d'initialisation avec sigmaw = 0.02 et hw = 10.
+!c-------------------------------------------------------------------------
+
+      DATA wapecut,sigmad, hwmin /5.,.02,10./
+!ccc nrlmd
+      DATA sigmaw_max /0.4/
+      DATA dens_rate /0.1/
+!ccc
+!C Longueur de maille (en m)
+!c-------------------------------------------------------------------------
+
+!c      ALON = 3.e5
+      ALON = 1.e6
+
+
+!C Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei)
+!c
+!c      coefgw : Coefficient pour les ondes de gravité
+!c       stark : Coefficient k dans Cstar=k*sqrt(2*WAPE)
+!c       wdens : Densité de poche froide par maille
+!c-------------------------------------------------------------------------
+
+!ccc nrlmd      coefgw=10
+!c      coefgw=1
+!c      wdens0 = 1.0/(alon**2)
+!ccc nrlmd      wdens = 1.0/(alon**2)
+!ccc nrlmd      stark = 0.50
+!cCRtest
+!ccc nrlmd      alpk=0.1
+!c      alpk = 1.0
+!c      alpk = 0.5
+!c      alpk = 0.05
+!c
+       stark  = 0.33
+       Alpk   = 0.25
+       wdens_ref  = 8.e-12
+       coefgw = 4.
+      Crep_upper=0.9
+      Crep_sol=1.0
+
+!ccc nrlmd Lecture du fichier wake_param.data
+      OPEN(99,file='wake_param.data',status='old',                                   &
+       &          form='formatted',err=9999)
+      READ(99,*,end=9998) stark
+      READ(99,*,end=9998) Alpk
+      READ(99,*,end=9998) wdens_ref
+      READ(99,*,end=9998) coefgw
+9998  Continue
+      CLOSE(99)
+9999  Continue
+!c
+!c   Initialisation de toutes des densites a wdens_ref.
+!c   Les densites peuvent evoluer si les poches debordent
+!c   (voir au tout debut de la boucle sur les substeps)
+      wdens = wdens_ref
+!c
+!c      print*,'stark',stark
+!c      print*,'alpk',alpk
+!c      print*,'wdens',wdens
+!c      print*,'coefgw',coefgw
+!ccc
+!C Minimum value for |T_wake - T_undist|. Used for wake top definition
+!c-------------------------------------------------------------------------
+
+      delta_t_min = 0.2
+
+!C 1. - Save initial values and initialize tendencies
+!C --------------------------------------------------
+
+      DO k=1,klev
+      DO i=1, klon
+        ppi(i,k)=pi(i,k)
+	deltatw0(i,k) = deltatw(i,k)
+	deltaqw0(i,k)= deltaqw(i,k)
+	te(i,k) = te0(i,k)
+	qe(i,k) = qe0(i,k)
+	dtls(i,k) = 0.
+	dqls(i,k) = 0.
+        d_deltat_gw(i,k)=0.
+        d_te(i,k) = 0.
+        d_qe(i,k) = 0.
+        d_deltatw(i,k) = 0.
+        d_deltaqw(i,k) = 0.
+!IM 060508 beg
+        d_deltatw2(i,k)=0.
+        d_deltaqw2(i,k)=0.
+!IM 060508 end
+      ENDDO
+      ENDDO
+!c      sigmaw1=sigmaw
+!c      IF (sigd_con.GT.sigmaw1) THEN
+!c      print*, 'sigmaw,sigd_con', sigmaw, sigd_con
+!c      ENDIF
+      DO i=1, klon
+!cc      sigmaw(i) = amax1(sigmaw(i),sigd_con(i))
+      sigmaw(i) = amax1(sigmaw(i),sigmad)
+      sigmaw(i) = amin1(sigmaw(i),0.99)
+      sigmaw0(i) = sigmaw(i)
+      wape(i) = 0.
+      wape2(i) = 0.
+      d_sigmaw(i) = 0.
+      ktopw(i) = 0
+      ENDDO
+!C
+!C
+!C 2. - Prognostic part
+!C --------------------
+!C
+!C
+!C 2.1 - Undisturbed area and Wake integrals
+!C ---------------------------------------------------------
+
+      DO i=1, klon
+      z(i) = 0.
+      ktop(i)=0
+      kupper(i) = 0
+      sum_thu(i) = 0.
+      sum_tu(i) = 0.
+      sum_qu(i) = 0.
+      sum_thvu(i) = 0.
+      sum_dth(i) = 0.
+      sum_dq(i) = 0.
+      sum_rho(i) = 0.
+      sum_dtdwn(i) = 0.
+      sum_dqdwn(i) = 0.
+
+      av_thu(i) = 0.
+      av_tu(i) =0.
+      av_qu(i) =0.
+      av_thvu(i) = 0.
+      av_dth(i) = 0.
+      av_dq(i) = 0.
+      av_rho(i) =0.
+      av_dtdwn(i) =0.
+      av_dqdwn(i) = 0.
+      ENDDO
+!c
+!c Distance between wakes
+       DO i = 1,klon
+        LL(i) = (1-sqrt(sigmaw(i)))/sqrt(wdens(i))
+       ENDDO
+!C Potential temperatures and humidity
+!c----------------------------------------------------------
+      DO k =1,klev
+       DO i=1, klon 
+!        write(*,*)'wake 1',i,k,rd,te(i,k)
+        rho(i,k) = p(i,k)/(rd*te(i,k))
+!        write(*,*)'wake 2',rho(i,k)
+        IF(k .eq. 1) THEN
+!        write(*,*)'wake 3',i,k,rd,te(i,k)
+          rhoh(i,k) = ph(i,k)/(rd*te(i,k))
+!        write(*,*)'wake 4',i,k,rd,te(i,k)
+          zhh(i,k)=0
+        ELSE
+!          write(*,*)'wake 5',rd,(te(i,k)+te(i,k-1))
+          rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(i,k-1)))
+!          write(*,*)'wake 6',(-rhoh(i,k)*RG)+zhh(i,k-1)
+          zhh(i,k)=(ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG)+zhh(i,k-1)
+        ENDIF
+!          write(*,*)'wake 7',ppi(i,k)
+        the(i,k) = te(i,k)/ppi(i,k)
+        thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k)
+        tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i)
+        qu(i,k)  =  qe(i,k) - deltaqw(i,k)*sigmaw(i)
+!          write(*,*)'wake 8',(rd*(te(i,k)+deltatw(i,k)))
+        rhow(i,k) = p(i,k)/(rd*(te(i,k)+deltatw(i,k)))
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+       ENDDO
+      ENDDO
+        
+      DO k = 1, klev-1
+      DO i=1, klon 
+        IF(k.eq.1) THEN
+          N2(i,k)=0
+        ELSE
+          N2(i,k)=amax1(0.,-RG**2/the(i,k)*rho(i,k)*(the(i,k+1)-                     &
+       &            the(i,k-1))/(p(i,k+1)-p(i,k-1)))
+        ENDIF
+        ZH(i,k)=(zhh(i,k)+zhh(i,k+1))/2
+
+        Cgw(i,k)=sqrt(N2(i,k))*ZH(i,k)
+        Tgw(i,k)=coefgw*Cgw(i,k)/LL(i)
+      ENDDO
+      ENDDO
+
+      DO i=1, klon
+      N2(i,klev)=0
+      ZH(i,klev)=0
+      Cgw(i,klev)=0
+      Tgw(i,klev)=0
+      ENDDO
+
+!c  Calcul de la masse volumique moyenne de la colonne   (bdlmd)
+!c-----------------------------------------------------------------
+
+      DO k=1,klev
+       DO i=1, klon
+        epaisseur1(i,k)=0.
+        epaisseur2(i,k)=0.
+       ENDDO
+      ENDDO
+
+      DO i=1, klon
+      epaisseur1(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1.
+      epaisseur2(i,1)= -(ph(i,2)-ph(i,1))/(rho(i,1)*rg)+1.
+      rhow_moyen(i,1) = rhow(i,1)
+      ENDDO
+
+      DO k = 2, klev
+      DO i=1, klon
+        epaisseur1(i,k)= -(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg) +1.
+        epaisseur2(i,k)=epaisseur2(i,k-1)+epaisseur1(i,k)
+        rhow_moyen(i,k) = (rhow_moyen(i,k-1)*epaisseur2(i,k-1)+                      &
+       &                 rhow(i,k)*epaisseur1(i,k))/epaisseur2(i,k)
+      ENDDO
+      ENDDO
+
+!C
+!C Choose an integration bound well above wake top
+!c-----------------------------------------------------------------
+!c
+!C       Pupper = 50000.  ! melting level
+!c       Pupper = 60000.
+!c       Pupper = 80000.  ! essais pour case_e
+       DO i = 1,klon
+        Pupper(i) = 0.6*ph(i,1)
+        Pupper(i) = max(Pupper(i), 45000.)
+!ccc        Pupper(i) = 60000.
+       ENDDO
+
+!C
+!C    Determine Wake top pressure (Ptop) from buoyancy integral
+!C    --------------------------------------------------------
+!c
+!c-1/ Pressure of the level where dth becomes less than delta_t_min.
+
+      DO i=1,klon
+      ptop_provis(i)=ph(i,1)
+      ENDDO
+      DO k= 2,klev
+      DO i=1,klon
+!c
+!IM v3JYG; ptop_provis(i).LT. ph(i,1)
+!c
+        IF (dth(i,k) .GT. -delta_t_min .and.                                         &
+       &      dth(i,k-1).LT. -delta_t_min .and.                                      &
+       &      ptop_provis(i).EQ. ph(i,1)) THEN
+          ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)                          &
+       &          - (dth(i,k-1)+delta_t_min)*p(i,k)) /                               &
+       &          (dth(i,k) - dth(i,k-1))
+        ENDIF
+      ENDDO
+      ENDDO
+
+!c-2/ dth integral
+
+      DO i=1,klon
+      sum_dth(i) = 0.
+      dthmin(i) = -delta_t_min
+      z(i) = 0.
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+        dz(i) = -(amax1(ph(i,k+1),ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .gt. 0) THEN
+          z(i) = z(i)+dz(i)
+          sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+          dthmin(i) = amin1(dthmin(i),dth(i,k))
+        ENDIF
+      ENDDO
+      ENDDO
+
+!c-3/ height of triangle with area= sum_dth and base = dthmin
+
+      DO i=1,klon
+      hw0(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5)
+      hw0(i) = amax1(hwmin,hw0(i))
+      ENDDO
+
+!c-4/ now, get Ptop
+
+      DO i=1,klon
+      z(i) = 0.
+      ptop(i) = ph(i,1)
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+        dz(i) = amin1(-(ph(i,k+1)-ph(i,k))/(rho(i,k)*rg),hw0(i)-z(i))
+        IF (dz(i) .gt. 0) THEN
+         z(i) = z(i)+dz(i)
+         ptop(i) = ph(i,k)-rho(i,k)*rg*dz(i)
+        ENDIF
+      ENDDO
+      ENDDO
+
+
+!C-5/ Determination de ktop et kupper
+
+      DO k=klev,1,-1
+      DO i=1,klon
+        IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k
+        IF (ph(i,k+1) .lt. pupper(i)) kupper(i)=k
+      ENDDO
+      ENDDO
+
+!c      On evite kupper = 1 et kupper = klev
+      DO i=1,klon
+        kupper(i) = max(kupper(i),2)
+        kupper(i) = min(kupper(i),klev-1)
+      ENDDO
+
+
+!c-6/ Correct ktop and ptop
+
+      DO i = 1,klon
+        ptop_new(i)=ptop(i)
+      ENDDO
+      DO k= klev,2,-1
+      DO i=1,klon
+        IF (k .LE. ktop(i) .and.                                                     &
+       &      ptop_new(i) .EQ. ptop(i) .and.                                         &
+       &      dth(i,k) .GT. -delta_t_min .and.                                       &
+       &      dth(i,k-1).LT. -delta_t_min) THEN
+          ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)                             &
+       &          - (dth(i,k-1)+delta_t_min)*p(i,k)) /                               &
+       &          (dth(i,k) - dth(i,k-1))
+        ENDIF
+      ENDDO
+      ENDDO
+
+      DO i=1,klon
+        ptop(i) = ptop_new(i)
+      ENDDO
+
+      DO k=klev,1,-1
+      DO i=1,klon
+        IF (ph(i,k+1) .lt. ptop(i)) ktop(i)=k
+      ENDDO
+      ENDDO
+!c
+!c-5/ Set deltatw & deltaqw to 0 above kupper
+!c
+      DO k = 1,klev
+      DO i=1,klon
+       IF (k.GE. kupper(i)) THEN
+        deltatw(i,k) = 0.
+        deltaqw(i,k) = 0.
+       ENDIF
+      ENDDO
+      ENDDO
+!c
+!C
+!C Vertical gradient of LS omega
+!C
+      DO k = 1,klev
+      DO i=1,klon
+       IF (k.LE. kupper(i)) THEN
+        dp_omgb(i,k) = (omgb(i,k+1) - omgb(i,k))/(ph(i,k+1)-ph(i,k))
+       ENDIF
+      ENDDO
+      ENDDO
+!C
+!C Integrals (and wake top level number)
+!C --------------------------------------
+!C
+!C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      DO i=1,klon
+      z(i) = 1.
+      dz(i) = 1.
+      sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
+      sum_dth(i) = 0.
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+        dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .GT. 0) THEN
+         z(i) = z(i)+dz(i)
+         sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i)
+         sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i)
+         sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i)
+         sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i)
+         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+         sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
+         sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
+         sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
+         sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
+        ENDIF
+      ENDDO
+      ENDDO
+!c
+      DO i=1,klon
+        hw0(i) = z(i)
+      ENDDO
+!c
+!C
+!C 2.1 - WAPE and mean forcing computation
+!C ---------------------------------------
+!C
+!C ---------------------------------------
+!C
+!C Means
+
+      DO i=1,klon
+      av_thu(i) = sum_thu(i)/hw0(i)
+      av_tu(i) = sum_tu(i)/hw0(i)
+      av_qu(i) = sum_qu(i)/hw0(i)
+      av_thvu(i) = sum_thvu(i)/hw0(i)
+!c      av_thve = sum_thve/hw0
+      av_dth(i) = sum_dth(i)/hw0(i)
+      av_dq(i) = sum_dq(i)/hw0(i)
+      av_rho(i) = sum_rho(i)/hw0(i)
+      av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
+      av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
+
+      wape(i) = - rg*hw0(i)*(av_dth(i)                                               &
+       &     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+av_dth(i)*                 &
+       &     av_dq(i) ))/av_thvu(i)
+      ENDDO
+!C
+!C 2.2 Prognostic variable update
+!C ------------------------------
+!C
+!C Filter out bad wakes
+
+      DO k = 1,klev
+       DO i=1,klon
+        IF ( wape(i) .LT. 0.) THEN
+          deltatw(i,k) = 0.
+          deltaqw(i,k) = 0.
+          dth(i,k) = 0.
+        ENDIF
+       ENDDO
+      ENDDO
+!c
+      DO i=1,klon
+      IF ( wape(i) .LT. 0.) THEN
+        wape(i) = 0.
+        Cstar(i) = 0.
+        hw(i) = hwmin
+        sigmaw(i) = amax1(sigmad,sigd_con(i))
+        fip(i) = 0.
+        gwake(i) = .FALSE.
+      ELSE
+        Cstar(i) = stark*sqrt(2.*wape(i))
+        gwake(i) = .TRUE.
+      ENDIF
+      ENDDO
+
+!c
+!c Check qx and qw positivity
+!c --------------------------
+      DO i = 1,klon
+       q0_min(i)=min(  (qe(i,1)-sigmaw(i)*deltaqw(i,1)),                             &
+       &              (qe(i,1)+(1.-sigmaw(i))*deltaqw(i,1))  )
+      ENDDO
+      DO k = 2,klev
+      DO i = 1,klon
+        q1_min(i)=min(  (qe(i,k)-sigmaw(i)*deltaqw(i,k)),                            &
+       &              (qe(i,k)+(1.-sigmaw(i))*deltaqw(i,k))  )
+        IF (q1_min(i).le.q0_min(i)) THEN
+          q0_min(i)=q1_min(i)
+        ENDIF
+      ENDDO
+      ENDDO
+!c
+      DO i = 1,klon
+       OK_qx_qw(i) = q0_min(i) .GE. 0.
+       alpha(i) = 1.
+      ENDDO
+!c
+!CC -----------------------------------------------------------------
+!C    Sub-time-stepping
+!C    -----------------
+!C
+      nsub=10
+      dtimesub=dtime/nsub
+!c
+!c------------------------------------------------------------
+      DO isubstep = 1,nsub
+!c------------------------------------------------------------
+!c
+!c wk_adv is the logical flag enabling wake evolution in the time advance loop
+      DO i = 1,klon
+       wk_adv(i) = OK_qx_qw(i) .AND. alpha(i) .GE. 1.
+      ENDDO
+!c
+!ccc nrlmd   Ajout d'un recalcul de wdens dans le cas d'un entrainement négatif de ktop à kupper --------
+!ccc           On calcule pour cela une densité wdens0 pour laquelle on aurait un entrainement nul ---
+      DO i=1,klon
+!cc       print *,' isubstep,wk_adv(i),cstar(i),wape(i) ',
+!cc     $           isubstep,wk_adv(i),cstar(i),wape(i)
+        IF (wk_adv(i) .AND. cstar(i).GT.0.01) THEN
+           omg(i,kupper(i)+1) = - Rg*amdwn(i,kupper(i)+1)/sigmaw(i)                  &
+       &                + Rg*amup(i,kupper(i)+1)/(1.-sigmaw(i))
+           wdens0 = ( sigmaw(i) / (4.*3.14) ) *                                      &
+       &     ( (1.-sigmaw(i)) * omg(i,kupper(i)+1) /                                 &
+       &     ( (ph(i,1)-pupper(i)) * cstar(i) )  ) **(2)
+         IF ( wdens(i) .LE. wdens0*1.1 ) THEN
+            wdens(i) = wdens0
+         ENDIF
+!cc	   print*,'omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i)
+!cc     $     ,ph(i,1)-pupper(i)',
+!cc     $             omg(i,kupper(i)+1),wdens0,wdens(i),cstar(i)
+!cc     $     ,ph(i,1)-pupper(i)
+        ENDIF
+      ENDDO
+
+!ccc nrlmd
+
+      DO i=1,klon
+       IF (wk_adv(i)) THEN
+        gfl(i) = 2.*sqrt(3.14*wdens(i)*sigmaw(i))
+        sigmaw(i)=amin1(sigmaw(i),sigmaw_max)
+       ENDIF
+      ENDDO
+      DO i=1,klon
+        IF (wk_adv(i)) THEN
+!ccc nrlmd          Introduction du taux de mortalité des poches et test sur sigmaw_max=0.4
+!ccc         d_sigmaw(i) = gfl(i)*Cstar(i)*dtimesub
+           IF (sigmaw(i).ge.sigmaw_max) THEN
+           death_rate(i)=gfl(i)*Cstar(i)/sigmaw(i)
+           ELSE
+             death_rate(i)=0.
+           END IF
+        d_sigmaw(i) = gfl(i)*Cstar(i)*dtimesub                                       &
+       &               - death_rate(i)*sigmaw(i)*dtimesub
+!c     $              - nat_rate(i)*sigmaw(i)*dtimesub
+!cc        print*, 'd_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i),
+!cc     $  death_rate(i),ktop(i),kupper(i)',
+!cc     $	         d_sigmaw(i),sigmaw(i),gfl(i),Cstar(i),wape(i),
+!cc     $  death_rate(i),ktop(i),kupper(i)
+
+!c        sigmaw(i) =sigmaw(i) + gfl(i)*Cstar(i)*dtimesub
+!c        sigmaw(i) =min(sigmaw(i),0.99)     !!!!!!!!
+!c        wdens = wdens0/(10.*sigmaw)
+!c        sigmaw =max(sigmaw,sigd_con)
+!c        sigmaw =max(sigmaw,sigmad)
+        ENDIF
+      ENDDO
+!C
+!C
+!c calcul de la difference de vitesse verticale poche - zone non perturbee
+!IM 060208 differences par rapport au code initial; init. a 0 dp_deltomg
+!IM 060208 et omg sur les niveaux de 1 a klev+1, alors que avant l'on definit
+!IM 060208 au niveau k=1..?
+      DO k= 1,klev
+      DO i = 1,klon
+      if (wk_adv(i)) THEN !!! nrlmd
+        dp_deltomg(i,k)=0.
+      end if
+      ENDDO
+      ENDDO
+      DO k= 1,klev+1
+      DO i = 1,klon
+      if (wk_adv(i)) THEN !!! nrlmd
+        omg(i,k)=0.
+      end if
+      ENDDO
+      ENDDO
+!c
+      DO i=1,klon
+        IF (wk_adv(i)) THEN
+        z(i)= 0.
+        omg(i,1) = 0.
+        dp_deltomg(i,1) = -(gfl(i)*Cstar(i))/(sigmaw(i) * (1-sigmaw(i)))
+        ENDIF
+      ENDDO
+!c
+      DO k= 2,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. ktop(i)) THEN
+          dz(i) = -(ph(i,k)-ph(i,k-1))/(rho(i,k-1)*rg)
+          z(i) = z(i)+dz(i)
+          dp_deltomg(i,k)= dp_deltomg(i,1)
+          omg(i,k)= dp_deltomg(i,1)*z(i)
+       ENDIF
+      ENDDO
+      ENDDO
+!c
+      DO i = 1,klon
+        IF (wk_adv(i)) THEN
+        dztop(i)=-(ptop(i)-ph(i,ktop(i)))/(rho(i,ktop(i))*rg)
+        ztop(i) = z(i)+dztop(i)
+        omgtop(i)=dp_deltomg(i,1)*ztop(i)
+        ENDIF
+      ENDDO
+!c
+!c        -----------------
+!c        From m/s to Pa/s
+!c        -----------------
+!c
+       DO i=1,klon
+        IF (wk_adv(i)) THEN
+        omgtop(i) = -rho(i,ktop(i))*rg*omgtop(i)
+        dp_deltomg(i,1) = omgtop(i)/(ptop(i)-ph(i,1))
+        ENDIF
+       ENDDO
+!c
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. ktop(i)) THEN
+          omg(i,k) = - rho(i,k)*rg*omg(i,k)
+          dp_deltomg(i,k) = dp_deltomg(i,1)
+       ENDIF
+      ENDDO
+      ENDDO
+!c
+!c   raccordement lineaire de omg de ptop a pupper
+
+      DO i=1,klon
+      IF ( wk_adv(i) .AND. kupper(i) .GT. ktop(i)) THEN
+        omg(i,kupper(i)+1) = - Rg*amdwn(i,kupper(i)+1)/sigmaw(i)                     &
+       &                + Rg*amup(i,kupper(i)+1)/(1.-sigmaw(i))
+        dp_deltomg(i,kupper(i)) = (omgtop(i)-omg(i,kupper(i)+1))/                    &
+       &                     (ptop(i)-pupper(i))
+      ENDIF
+      ENDDO
+!c
+!cc      DO i=1,klon
+!cc        print*,'Pente entre 0 et kupper (référence)'
+!cc     $   	,omg(i,kupper(i)+1)/(pupper(i)-ph(i,1))
+!cc        print*,'Pente entre ktop et kupper'
+!cc     $  	,(omg(i,kupper(i)+1)-omgtop(i))/(pupper(i)-ptop(i))
+!cc      ENDDO
+!cc
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .GT. ktop(i) .AND. k .LE. kupper(i)) THEN
+          dp_deltomg(i,k) = dp_deltomg(i,kupper(i))
+          omg(i,k) = omgtop(i)+(ph(i,k)-ptop(i))*dp_deltomg(i,kupper(i))
+       ENDIF
+      ENDDO
+      ENDDO
+!ccc nrlmd
+!cc      DO i=1,klon
+!cc      print*,'deltaw_ktop,deltaw_conv',omgtop(i),omg(i,kupper(i)+1)
+!cc      END DO
+!ccc
+!c
+!c
+!c--    Compute wake average vertical velocity omgbw
+!c
+!c
+      DO k = 1,klev+1
+      DO i=1,klon
+        IF ( wk_adv(i)) THEN
+        omgbw(i,k) = omgb(i,k)+(1.-sigmaw(i))*omg(i,k)
+        ENDIF
+      ENDDO
+      ENDDO
+!c--    and its vertical gradient dp_omgbw
+!c
+      DO k = 1,klev
+      DO i=1,klon
+        IF ( wk_adv(i)) THEN
+        dp_omgbw(i,k) = (omgbw(i,k+1)-omgbw(i,k))/(ph(i,k+1)-ph(i,k))
+        ENDIF
+      ENDDO
+      ENDDO
+!C
+!c--    Upstream coefficients for omgb velocity
+!c--    (alpha_up(k) is the coefficient of the value at level k)
+!c--    (1-alpha_up(k) is the coefficient of the value at level k-1)
+      DO k = 1,klev
+      DO i=1,klon
+        IF ( wk_adv(i)) THEN
+         alpha_up(i,k) = 0.
+         IF (omgb(i,k) .GT. 0.) alpha_up(i,k) = 1.
+        ENDIF
+      ENDDO
+      ENDDO
+
+!c  Matrix expressing [The,deltatw] from  [Th1,Th2]
+
+      DO i=1,klon
+        IF ( wk_adv(i)) THEN
+         RRe1(i) = 1.-sigmaw(i)
+         RRe2(i) = sigmaw(i)
+        ENDIF
+      ENDDO
+      RRd1 = -1.
+      RRd2 = 1.
+!c
+!c--    Get [Th1,Th2], dth and [q1,q2]
+!c
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+        Th1(i,k) = the(i,k) - sigmaw(i)     *dth(i,k)   ! undisturbed area
+        Th2(i,k) = the(i,k) + (1.-sigmaw(i))*dth(i,k)   ! wake
+        q1(i,k) = qe(i,k) - sigmaw(i)     *deltaqw(i,k) ! undisturbed area
+        q2(i,k) = qe(i,k) + (1.-sigmaw(i))*deltaqw(i,k) ! wake
+       ENDIF
+      ENDDO
+      ENDDO
+
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+       D_Th1(i,1) = 0.
+       D_Th2(i,1) = 0.
+       D_dth(i,1) = 0.
+       D_q1(i,1) = 0.
+       D_q2(i,1) = 0.
+       D_dq(i,1) = 0.
+       end if
+      ENDDO
+
+      DO k= 2,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN
+        D_Th1(i,k) = Th1(i,k-1)-Th1(i,k)
+        D_Th2(i,k) = Th2(i,k-1)-Th2(i,k)
+        D_dth(i,k) = dth(i,k-1)-dth(i,k)
+        D_q1(i,k) = q1(i,k-1)-q1(i,k)
+        D_q2(i,k) = q2(i,k-1)-q2(i,k)
+        D_dq(i,k) = deltaqw(i,k-1)-deltaqw(i,k)
+       ENDIF
+      ENDDO
+      ENDDO
+
+      DO i=1,klon
+        IF( wk_adv(i)) THEN
+         omgbdth(i,1) = 0.
+         omgbdq(i,1) = 0.
+        ENDIF
+      ENDDO
+
+      DO k= 2,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)+1) THEN  !   loop on interfaces
+        omgbdth(i,k) = omgb(i,k)*(    dth(i,k-1) -     dth(i,k))
+        omgbdq(i,k)  = omgb(i,k)*(deltaqw(i,k-1) - deltaqw(i,k))
+       ENDIF
+      ENDDO
+      ENDDO
+!c
+!c-----------------------------------------------------------------
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN
+!c-----------------------------------------------------------------
+!c
+!c   Compute redistribution (advective) term
+!c
+         d_deltatw(i,k) =                                                            &
+       &             dtimesub/(Ph(i,k)-Ph(i,k+1))*(                                  &
+       &       RRd1*omg(i,k  )*sigmaw(i)     *D_Th1(i,k)                             &
+       &      -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1)                           &
+       &      -(1.-alpha_up(i,k))*omgbdth(i,k) - alpha_up(i,k+1)*                    &
+       &      omgbdth(i,k+1))*ppi(i,k)
+!c         print*,'d_deltatw=',d_deltatw(i,k)
+!c
+         d_deltaqw(i,k) =                                                            &
+       &             dtimesub/(Ph(i,k)-Ph(i,k+1))*(                                  &
+       &       RRd1*omg(i,k  )*sigmaw(i)     *D_q1(i,k)                              &
+       &      -RRd2*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1)                            &
+       &      -(1.-alpha_up(i,k))*omgbdq(i,k) - alpha_up(i,k+1)*                     &
+       &      omgbdq(i,k+1))
+!c         print*,'d_deltaqw=',d_deltaqw(i,k)
+!c
+!c   and increment large scale tendencies
+!c
+
+!c
+!C
+!CC -----------------------------------------------------------------
+         d_te(i,k) =  dtimesub*(                                                     &
+       &        ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_Th1(i,k)                       &
+       &         -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_Th2(i,k+1) )                   &
+       &               /(Ph(i,k)-Ph(i,k+1))                                          &
+!ccc nrlmd     $         -sigmaw(i)*(1.-sigmaw(i))*dth(i,k)*dp_deltomg(i,k)          &
+       &         -sigmaw(i)*(1.-sigmaw(i))*dth(i,k)                                  &
+       &         *(omg(i,k)-omg(i,k+1))/(Ph(i,k)-Ph(i,k+1))                          &
+!ccc                                                                                 &
+       &                      )*ppi(i,k)
+!c
+         d_qe(i,k) =  dtimesub*(                                                     &
+       &        ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_q1(i,k)                        &
+       &         -RRe2(i)*omg(i,k+1)*(1.-sigmaw(i))*D_q2(i,k+1) )                    &
+       &               /(Ph(i,k)-Ph(i,k+1))                                          &
+!ccc nrlmd     $         -sigmaw(i)*(1.-sigmaw(i))*deltaqw(i,k)*dp_deltomg(i,k)      &
+       &         -sigmaw(i)*(1.-sigmaw(i))*deltaqw(i,k)                              &
+       &         *(omg(i,k)-omg(i,k+1))/(Ph(i,k)-Ph(i,k+1))                          &
+!ccc                                                                                 &
+       &                      )
+!ccc nrlmd
+       ELSE IF(wk_adv(i) .AND. k .EQ. kupper(i)) THEN
+         d_te(i,k) =  dtimesub*(                                                     &
+       &       ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_Th1(i,k)                        &
+       &        /(Ph(i,k)-Ph(i,k+1)))                                                &
+       &                       )*ppi(i,k)
+
+         d_qe(i,k) =  dtimesub*(                                                     &
+       &       ( RRe1(i)*omg(i,k  )*sigmaw(i)     *D_q1(i,k)                         &
+       &        /(Ph(i,k)-Ph(i,k+1)))                                                &
+       &                       )
+
+       ENDIF
+!ccc
+      ENDDO
+      ENDDO
+!c------------------------------------------------------------------
+!C
+!C   Increment state variables
+
+      DO k= 1,klev
+      DO i = 1,klon
+!ccc nrlmd       IF( wk_adv(i) .AND. k .LE. kupper(i)-1) THEN
+        IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
+!ccc
+
+
+!c
+!c Coefficient de répartition
+
+        Crep(i,k)=Crep_sol*(ph(i,kupper(i))-ph(i,k))/(ph(i,kupper(i))                &
+       &          -ph(i,1))
+        Crep(i,k)=Crep(i,k)+Crep_upper*(ph(i,1)-ph(i,k))/(p(i,1)-                    &
+       &          ph(i,kupper(i)))
+        
+
+!c Reintroduce compensating subsidence term.
+
+!c        dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw
+!c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k))
+!c     .                   /(1-sigmaw)
+!c        dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw
+!c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k))
+!c     .                   /(1-sigmaw)
+!c
+!c        dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw
+!c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k))
+!c     .                   /(1-sigmaw)
+!c        dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw
+!c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k))
+!c     .                   /(1-sigmaw)
+
+        dtKE(i,k)=(dtdwn(i,k)/sigmaw(i) - dta(i,k)/(1.-sigmaw(i)))
+        dqKE(i,k)=(dqdwn(i,k)/sigmaw(i) - dqa(i,k)/(1.-sigmaw(i)))
+!c        print*,'dtKE= ',dtKE(i,k),' dqKE= ',dqKE(i,k)
+!c
+        dtPBL(i,k)=(wdtPBL(i,k)/sigmaw(i) - udtPBL(i,k)/(1.-sigmaw(i)))
+        dqPBL(i,k)=(wdqPBL(i,k)/sigmaw(i) - udqPBL(i,k)/(1.-sigmaw(i)))
+!c        print*,'dtPBL= ',dtPBL(i,k),' dqPBL= ',dqPBL(i,k)
+!c
+!ccc nrlmd          Prise en compte du taux de mortalité
+!ccc               Définitions de entr, detr
+        detr(i,k)=0.
+
+        entr(i,k)=detr(i,k)+gfl(i)*cstar(i)+                                         &
+       &          sigmaw(i)*(1.-sigmaw(i))*dp_deltomg(i,k)
+
+        spread(i,k) = (entr(i,k)-detr(i,k))/sigmaw(i)
+!ccc        spread(i,k) = (1.-sigmaw(i))*dp_deltomg(i,k)+gfl(i)*Cstar(i)/
+!ccc     $  sigmaw(i)
+
+
+!c ajout d'un effet onde de gravité -Tgw(k)*deltatw(k) 03/02/06 YU Jingmei
+
+!      write(lunout,*)'wake.F ',i,k, dtimesub,d_deltat_gw(i,k),
+!     &  Tgw(i,k),deltatw(i,k)
+        d_deltat_gw(i,k)=d_deltat_gw(i,k)-Tgw(i,k)*deltatw(i,k)*                     &
+       &  dtimesub
+!      write(lunout,*)'wake.F ',i,k, dtimesub,d_deltatw(i,k)
+        ff(i)=d_deltatw(i,k)/dtimesub
+
+!c Sans GW
+!c
+!c        deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-spread(k)*deltatw(k))
+!c
+!c GW formule 1
+!c
+!c        deltatw(k) = deltatw(k)+dtimesub*
+!c     $         (ff+dtKE(k) - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
+!c
+!c GW formule 2
+
+        IF (dtimesub*Tgw(i,k).lt.1.e-10) THEN
+          d_deltatw(i,k) = dtimesub*                                                 &
+       &       (ff(i)+dtKE(i,k)+dtPBL(i,k)                                           &
+!ccc     $       -spread(i,k)*deltatw(i,k)                                           &
+       &       - entr(i,k)*deltatw(i,k)/sigmaw(i)                                    &
+       &       - (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k)                    &
+       &       / (1.-sigmaw(i))                                                      &
+!ccc                                                                                 &
+       &       -Tgw(i,k)*deltatw(i,k))
+        ELSE
+           d_deltatw(i,k) = 1/Tgw(i,k)*(1-exp(-dtimesub*                             &
+       &       Tgw(i,k)))*                                                           &
+       &       (ff(i)+dtKE(i,k)+dtPBL(i,k)                                           &
+!ccc     $       -spread(i,k)*deltatw(i,k)                                           &
+       &       - entr(i,k)*deltatw(i,k)/sigmaw(i)                                    &
+       &       - (death_rate(i)*sigmaw(i)+detr(i,k))*deltatw(i,k)                    &
+       &       / (1.-sigmaw(i))                                                      &
+!ccc                                                                                 &
+       &       -Tgw(i,k)*deltatw(i,k))
+        ENDIF
+
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+
+        gg(i)=d_deltaqw(i,k)/dtimesub
+
+       d_deltaqw(i,k) = dtimesub*(gg(i)+ dqKE(i,k)+dqPBL(i,k)                        &
+!ccc     $     -spread(i,k)*deltaqw(i,k))                                            &
+       &        - entr(i,k)*deltaqw(i,k)/sigmaw(i)                                   &
+       &        - (death_rate(i)*sigmaw(i)+detr(i,k))*deltaqw(i,k)                   &
+       &        /(1.-sigmaw(i)))
+!ccc
+
+!ccc nrlmd
+!ccc       d_deltatw2(i,k)=d_deltatw2(i,k)+d_deltatw(i,k)
+!ccc       d_deltaqw2(i,k)=d_deltaqw2(i,k)+d_deltaqw(i,k)
+!ccc
+       ENDIF
+      ENDDO
+      ENDDO
+
+!C
+!C   Scale tendencies so that water vapour remains positive in w and x.
+!C
+      call wake_vec_modulation(klon,klev,wk_adv,epsilon,qe,d_qe,deltaqw,             &
+       &                d_deltaqw,sigmaw,d_sigmaw,alpha)
+!c
+!ccc nrlmd
+!cc      print*,'alpha'
+!cc      do i=1,klon
+!cc         print*,alpha(i)
+!cc      end do
+!ccc
+      DO k = 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
+        d_te(i,k)=alpha(i)*d_te(i,k)
+        d_qe(i,k)=alpha(i)*d_qe(i,k)
+        d_deltatw(i,k)=alpha(i)*d_deltatw(i,k)
+        d_deltaqw(i,k)=alpha(i)*d_deltaqw(i,k)
+        d_deltat_gw(i,k)=alpha(i)*d_deltat_gw(i,k)
+       ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1,klon
+       IF( wk_adv(i)) THEN
+        d_sigmaw(i)=alpha(i)*d_sigmaw(i)
+       ENDIF
+      ENDDO
+
+!C   Update large scale variables and wake variables
+!IM 060208 manque DO i + remplace DO k=1,kupper(i)
+!IM 060208     DO k = 1,kupper(i)
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
+        dtls(i,k)=dtls(i,k)+d_te(i,k)
+        dqls(i,k)=dqls(i,k)+d_qe(i,k)
+!ccc nrlmd
+        d_deltatw2(i,k)=d_deltatw2(i,k)+d_deltatw(i,k)
+        d_deltaqw2(i,k)=d_deltaqw2(i,k)+d_deltaqw(i,k)
+!ccc
+       ENDIF
+      ENDDO
+      ENDDO
+      DO k= 1,klev
+      DO i = 1,klon
+       IF( wk_adv(i) .AND. k .LE. kupper(i)) THEN
+        te(i,k) = te0(i,k) + dtls(i,k)
+        qe(i,k) = qe0(i,k) + dqls(i,k)
+        the(i,k) = te(i,k)/ppi(i,k)
+        deltatw(i,k) = deltatw(i,k)+d_deltatw(i,k)
+        deltaqw(i,k) = deltaqw(i,k)+d_deltaqw(i,k)
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+!cc      print*,'k,qx,qw',k,qe(i,k)-sigmaw(i)*deltaqw(i,k)
+!cc     $        ,qe(i,k)+(1-sigmaw(i))*deltaqw(i,k)
+       ENDIF
+      ENDDO
+      ENDDO
+      DO i = 1,klon
+       IF( wk_adv(i)) THEN
+        sigmaw(i) = sigmaw(i)+d_sigmaw(i)
+       ENDIF
+      ENDDO
+!c
+!C
+!c     Determine Ptop from buoyancy integral
+!c     ---------------------------------------
+!c
+!c-     1/ Pressure of the level where dth changes sign.
+!c
+      DO i=1,klon
+       IF ( wk_adv(i)) THEN
+        Ptop_provis(i)=ph(i,1)
+       ENDIF
+      ENDDO
+!c
+      DO k= 2,klev
+      DO i=1,klon
+        IF ( wk_adv(i) .AND.                                                         &
+       &       Ptop_provis(i) .EQ. ph(i,1) .AND.                                     &
+       &      dth(i,k) .GT. -delta_t_min .and.                                       &
+       &      dth(i,k-1).LT. -delta_t_min) THEN
+          Ptop_provis(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)                          &
+       &          - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k)                      &
+       &          - dth(i,k-1))
+        ENDIF
+      ENDDO
+      ENDDO
+!c
+!c-     2/ dth integral
+!c
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+       sum_dth(i) = 0.
+       dthmin(i) = -delta_t_min
+       z(i) = 0.
+       end if
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+       IF ( wk_adv(i)) THEN
+        dz(i) = -(amax1(ph(i,k+1),Ptop_provis(i))-Ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .gt. 0) THEN
+         z(i) = z(i)+dz(i)
+         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+         dthmin(i) = amin1(dthmin(i),dth(i,k))
+        ENDIF
+       ENDIF
+      ENDDO
+      ENDDO
+!c
+!c-     3/ height of triangle with area= sum_dth and base = dthmin
+
+      DO i=1,klon
+       IF ( wk_adv(i)) THEN
+         hw(i) = 2.*sum_dth(i)/amin1(dthmin(i),-0.5)
+         hw(i) = amax1(hwmin,hw(i))
+       ENDIF
+      ENDDO
+!c
+!c-     4/ now, get Ptop
+!c
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+       ktop(i) = 0
+       z(i)=0.
+       end if
+      ENDDO
+!c
+      DO k = 1,klev
+      DO i=1,klon
+       IF ( wk_adv(i)) THEN
+        dz(i) = amin1(-(ph(i,k+1)-Ph(i,k))/(rho(i,k)*rg),hw(i)-z(i))
+        IF (dz(i) .gt. 0) THEN
+         z(i) = z(i)+dz(i)
+         Ptop(i) = Ph(i,k)-rho(i,k)*rg*dz(i)
+         ktop(i) = k
+        ENDIF
+       ENDIF
+      ENDDO
+      ENDDO
+!c
+!c      4.5/Correct ktop and ptop
+!c
+      DO i=1,klon
+       IF ( wk_adv(i)) THEN
+        Ptop_new(i)=ptop(i)
+       ENDIF
+      ENDDO
+!c
+      DO k= klev,2,-1
+      DO i=1,klon
+!IM v3JYG; IF (k .GE. ktop(i)
+       IF ( wk_adv(i) .AND.                                                          &
+       &      k .LE. ktop(i) .AND.                                                   &
+       &      ptop_new(i) .EQ. ptop(i) .AND.                                         &
+       &      dth(i,k) .GT. -delta_t_min .and.                                       &
+       &      dth(i,k-1).LT. -delta_t_min) THEN
+          Ptop_new(i) = ((dth(i,k)+delta_t_min)*p(i,k-1)                             &
+       &          - (dth(i,k-1)+delta_t_min)*p(i,k)) /(dth(i,k)                      &
+       &          - dth(i,k-1))
+        ENDIF
+      ENDDO
+      ENDDO
+!c
+!c
+      DO i=1,klon
+       IF ( wk_adv(i)) THEN
+        ptop(i) = ptop_new(i)
+       ENDIF
+      ENDDO
+
+      DO k=klev,1,-1
+      DO i=1,klon
+      if (wk_adv(i)) then !!! nrlmd
+        IF (ph(i,k+1) .LT. ptop(i)) ktop(i)=k
+      end if
+      ENDDO
+      ENDDO
+!c
+!c      5/ Set deltatw & deltaqw to 0 above kupper
+!c
+      DO k = 1,klev
+      DO i=1,klon
+        IF ( wk_adv(i) .AND. k .GE. kupper(i)) THEN
+         deltatw(i,k) = 0.
+         deltaqw(i,k) = 0.
+        ENDIF
+      ENDDO
+      ENDDO
+!c
+!C
+!c-------------Cstar computation---------------------------------
+      DO i=1, klon
+       if (wk_adv(i)) then !!! nrlmd
+      sum_thu(i) = 0.
+      sum_tu(i) = 0.
+      sum_qu(i) = 0.
+      sum_thvu(i) = 0.
+      sum_dth(i) = 0.
+      sum_dq(i) = 0.
+      sum_rho(i) = 0.
+      sum_dtdwn(i) = 0.
+      sum_dqdwn(i) = 0.
+
+      av_thu(i) = 0.
+      av_tu(i) =0.
+      av_qu(i) =0.
+      av_thvu(i) = 0.
+      av_dth(i) = 0.
+      av_dq(i) = 0.
+      av_rho(i) =0.
+      av_dtdwn(i) =0.
+      av_dqdwn(i) = 0.
+       end if
+      ENDDO
+!C
+!C Integrals (and wake top level number)
+!C --------------------------------------
+!C
+!C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+      z(i) = 1.
+      dz(i) = 1.
+      sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
+      sum_dth(i) = 0.
+       end if
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+        dz(i) = -(max(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .GT. 0) THEN
+         z(i) = z(i)+dz(i)
+         sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i)
+         sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i)
+         sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i)
+         sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i)
+         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+         sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
+         sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
+         sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
+         sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
+        ENDIF
+       end if
+      ENDDO
+      ENDDO
+!c
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+        hw0(i) = z(i)
+       end if
+      ENDDO
+!c
+!C
+!C - WAPE and mean forcing computation
+!C ---------------------------------------
+!C
+!C ---------------------------------------
+!C
+!C Means
+
+      DO i=1,klon
+       if (wk_adv(i)) then !!! nrlmd
+       av_thu(i) = sum_thu(i)/hw0(i)
+       av_tu(i) = sum_tu(i)/hw0(i)
+       av_qu(i) = sum_qu(i)/hw0(i)
+       av_thvu(i) = sum_thvu(i)/hw0(i)
+       av_dth(i) = sum_dth(i)/hw0(i)
+       av_dq(i) = sum_dq(i)/hw0(i)
+       av_rho(i) = sum_rho(i)/hw0(i)
+       av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
+       av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
+!c
+       wape(i) = - rg*hw0(i)*(av_dth(i)                                              &
+       &     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)+av_dth(i)*                 &
+       &     av_dq(i) ))/av_thvu(i)
+       end if
+      ENDDO
+!C
+!C Filter out bad wakes
+
+      DO k = 1,klev
+       DO i=1,klon
+        if (wk_adv(i)) then !!! nrlmd
+        IF ( wape(i) .LT. 0.) THEN
+          deltatw(i,k) = 0.
+          deltaqw(i,k) = 0.
+          dth(i,k) = 0.
+        ENDIF
+	end if
+       ENDDO
+      ENDDO
+!c
+      DO i=1,klon
+      if (wk_adv(i)) then !!! nrlmd
+      IF ( wape(i) .LT. 0.) THEN
+        wape(i) = 0.
+        Cstar(i) = 0.
+        hw(i) = hwmin
+        sigmaw(i) = max(sigmad,sigd_con(i))
+        fip(i) = 0.
+        gwake(i) = .FALSE.
+      ELSE
+        Cstar(i) = stark*sqrt(2.*wape(i))
+        gwake(i) = .TRUE.
+      ENDIF
+      end if
+      ENDDO
+
+       ENDDO      ! end sub-timestep loop
+!C
+!C -----------------------------------------------------------------
+!c   Get back to tendencies per second
+!c
+      DO k = 1,klev
+      DO i=1,klon
+
+!ccc nrlmd        IF ( wk_adv(i) .AND. k .LE. kupper(i)) THEN
+        IF ( OK_qx_qw(i) .AND. k .LE. kupper(i)) THEN
+!ccc
+         dtls(i,k) = dtls(i,k)/dtime
+         dqls(i,k) = dqls(i,k)/dtime
+         d_deltatw2(i,k)=d_deltatw2(i,k)/dtime
+         d_deltaqw2(i,k)=d_deltaqw2(i,k)/dtime
+         d_deltat_gw(i,k) = d_deltat_gw(i,k)/dtime
+!cc      print*,'k,dqls,omg,entr,detr',k,dqls(i,k),omg(i,k),entr(i,k)
+!cc     $         ,death_rate(i)*sigmaw(i)
+        ENDIF
+      ENDDO
+      ENDDO
+
+!c
+!c----------------------------------------------------------
+!c   Determine wake final state; recompute wape, cstar, ktop;
+!c   filter out bad wakes.
+!c----------------------------------------------------------
+!c
+!C 2.1 - Undisturbed area and Wake integrals
+!C ---------------------------------------------------------
+
+      DO i=1,klon
+!ccc nrlmd       if (wk_adv(i)) then !!! nrlmd
+      if (OK_qx_qw(i)) then
+!ccc
+        z(i) = 0.
+        sum_thu(i) = 0.
+        sum_tu(i) = 0.
+        sum_qu(i) = 0.
+        sum_thvu(i) = 0.
+        sum_dth(i) = 0.
+        sum_dq(i) = 0.
+        sum_rho(i) = 0.
+        sum_dtdwn(i) = 0.
+        sum_dqdwn(i) = 0.
+
+        av_thu(i) = 0.
+        av_tu(i) =0.
+        av_qu(i) =0.
+        av_thvu(i) = 0.
+        av_dth(i) = 0.
+        av_dq(i) = 0.
+        av_rho(i) =0.
+        av_dtdwn(i) =0.
+        av_dqdwn(i) = 0.
+       end if	
+      ENDDO
+!C Potential temperatures and humidity
+!c----------------------------------------------------------
+
+      DO k =1,klev
+      DO i=1,klon
+!ccc nrlmd       IF ( wk_adv(i)) THEN
+       if (OK_qx_qw(i)) then
+!ccc
+        rho(i,k) = p(i,k)/(rd*te(i,k))
+        IF(k .eq. 1) THEN
+          rhoh(i,k) = ph(i,k)/(rd*te(i,k))
+          zhh(i,k)=0
+        ELSE
+          rhoh(i,k) = ph(i,k)*2./(rd*(te(i,k)+te(i,k-1)))
+          zhh(i,k)=(ph(i,k)-ph(i,k-1))/(-rhoh(i,k)*RG)+zhh(i,k-1)
+        ENDIF
+        the(i,k) = te(i,k)/ppi(i,k)
+        thu(i,k) = (te(i,k) - deltatw(i,k)*sigmaw(i))/ppi(i,k)
+        tu(i,k) = te(i,k) - deltatw(i,k)*sigmaw(i)
+        qu(i,k)  =  qe(i,k) - deltaqw(i,k)*sigmaw(i)
+        rhow(i,k) = p(i,k)/(rd*(te(i,k)+deltatw(i,k)))
+        dth(i,k) = deltatw(i,k)/ppi(i,k)
+       ENDIF
+      ENDDO
+      ENDDO
+
+!C Integrals (and wake top level number)
+!C -----------------------------------------------------------
+
+!C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      DO i=1,klon
+!ccc nrlmd       IF ( wk_adv(i)) THEN
+      if (OK_qx_qw(i)) then
+!ccc
+        z(i) = 1.
+        dz(i) = 1.
+        sum_thvu(i) =  thu(i,1)*(1.+eps*qu(i,1))*dz(i)
+        sum_dth(i) = 0.
+      ENDIF
+      ENDDO
+
+      DO k = 1,klev
+      DO i=1,klon
+!ccc nrlmd       IF ( wk_adv(i)) THEN
+       if (OK_qx_qw(i)) then
+!ccc
+        dz(i) = -(amax1(ph(i,k+1),ptop(i))-ph(i,k))/(rho(i,k)*rg)
+        IF (dz(i) .GT. 0) THEN
+         z(i) = z(i)+dz(i)
+         sum_thu(i) = sum_thu(i) + thu(i,k)*dz(i)
+         sum_tu(i) = sum_tu(i) + tu(i,k)*dz(i)
+         sum_qu(i) = sum_qu(i) + qu(i,k)*dz(i)
+         sum_thvu(i) = sum_thvu(i) + thu(i,k)*(1.+eps*qu(i,k))*dz(i)
+         sum_dth(i) = sum_dth(i) + dth(i,k)*dz(i)
+         sum_dq(i) = sum_dq(i) + deltaqw(i,k)*dz(i)
+         sum_rho(i) = sum_rho(i) + rhow(i,k)*dz(i)
+         sum_dtdwn(i) = sum_dtdwn(i) + dtdwn(i,k)*dz(i)
+         sum_dqdwn(i) = sum_dqdwn(i) + dqdwn(i,k)*dz(i)
+        ENDIF
+       ENDIF
+      ENDDO
+      ENDDO
+!c
+      DO i=1,klon
+!ccc nrlmd       IF ( wk_adv(i)) THEN
+       if (OK_qx_qw(i)) then
+!ccc
+        hw0(i) = z(i)
+       ENDIF
+      ENDDO
+!c
+!C - WAPE and mean forcing computation
+!C-------------------------------------------------------------
+
+!C Means
+
+      DO i=1, klon
+!ccc nrlmd       IF ( wk_adv(i)) THEN
+      if (OK_qx_qw(i)) then
+!ccc
+        av_thu(i) = sum_thu(i)/hw0(i)
+        av_tu(i) = sum_tu(i)/hw0(i)
+        av_qu(i) = sum_qu(i)/hw0(i)
+        av_thvu(i) = sum_thvu(i)/hw0(i)
+        av_dth(i) = sum_dth(i)/hw0(i)
+        av_dq(i) = sum_dq(i)/hw0(i)
+        av_rho(i) = sum_rho(i)/hw0(i)
+        av_dtdwn(i) = sum_dtdwn(i)/hw0(i)
+        av_dqdwn(i) = sum_dqdwn(i)/hw0(i)
+
+        wape2(i) = - rg*hw0(i)*(av_dth(i)                                            &
+       &     + eps*(av_thu(i)*av_dq(i)+av_dth(i)*av_qu(i)                            &
+       &     + av_dth(i)*av_dq(i) ))/av_thvu(i)
+       ENDIF
+      ENDDO
+
+!C Prognostic variable update
+!C ------------------------------------------------------------
+
+!C Filter out bad wakes
+!c
+      DO k = 1,klev
+      DO i=1,klon
+!ccc nrlmd        IF ( wk_adv(i) .AND. wape2(i) .LT. 0.) THEN
+      if (OK_qx_qw(i) .AND. wape2(i) .LT. 0.) then
+!ccc
+          deltatw(i,k) = 0.
+          deltaqw(i,k) = 0.
+          dth(i,k) = 0.
+        ENDIF
+      ENDDO
+      ENDDO
+!c
+
+      DO i=1, klon
+!ccc nrlmd       IF ( wk_adv(i)) THEN
+      if (OK_qx_qw(i)) then
+!ccc
+       IF ( wape2(i) .LT. 0.) THEN
+        wape2(i) = 0.
+        Cstar2(i) = 0.
+        hw(i) = hwmin
+        sigmaw(i) = amax1(sigmad,sigd_con(i))
+        fip(i) = 0.
+        gwake(i) = .FALSE.
+      ELSE
+        if(prt_level.ge.10) print*,'wape2>0'
+        Cstar2(i) = stark*sqrt(2.*wape2(i))
+        gwake(i) = .TRUE.
+      ENDIF
+      ENDIF
+      ENDDO
+!c
+      DO i=1, klon
+!ccc nrlmd       IF ( wk_adv(i)) THEN
+       if (OK_qx_qw(i)) then
+!ccc
+        ktopw(i) = ktop(i)
+       ENDIF
+      ENDDO
+!c
+      DO i=1, klon
+!ccc nrlmd       IF ( wk_adv(i)) THEN
+       if (OK_qx_qw(i)) then
+!ccc
+       IF (ktopw(i) .gt. 0 .and. gwake(i)) then
+
+!Cjyg1     Utilisation d'un h_efficace constant ( ~ feeding layer)
+!ccc       heff = 600.
+!C      Utilisation de la hauteur hw
+!cc       heff = 0.7*hw
+       heff(i) = hw(i)
+
+       FIP(i) = 0.5*rho(i,ktopw(i))*Cstar2(i)**3*heff(i)*2*                          &
+       &      sqrt(sigmaw(i)*wdens(i)*3.14)
+       FIP(i) = alpk * FIP(i)
+!Cjyg2
+       ELSE
+         FIP(i) = 0.
+       ENDIF
+       ENDIF
+      ENDDO
+!c
+!C   Limitation de sigmaw
+
+!ccc nrlmd
+!c       DO i=1,klon
+!c         IF (OK_qx_qw(i)) THEN
+!c	   IF (sigmaw(i).GE.sigmaw_max) sigmaw(i)=sigmaw_max
+!c	 ENDIF
+!c       ENDDO
+!ccc
+      DO k = 1,klev
+       DO i=1, klon
+
+!ccc nrlmd      On maintient désormais constant sigmaw en régime permanent
+!ccc      IF ((sigmaw(i).GT.sigmaw_max).or.
+        IF     ( ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0)).or.                   &
+       &         (ktopw(i).le.2) .OR.                                                &
+       &         .not. OK_qx_qw(i) ) THEN
+!ccc
+          dtls(i,k) = 0.
+          dqls(i,k) = 0.
+          deltatw(i,k) = 0.
+          deltaqw(i,k) = 0.
+        ENDIF
+       ENDDO
+      ENDDO
+!c
+!ccc nrlmd      On maintient désormais constant sigmaw en régime permanent
+      DO i=1, klon
+        IF  ( ((wape(i).ge.wape2(i)).and.(wape2(i).le.1.0)).or.                      &
+       &        (ktopw(i).le.2) .OR.                                                 &
+       &        .not. OK_qx_qw(i)   ) THEN
+         wape(i) = 0.
+         cstar(i)=0.
+         hw(i) = hwmin
+         sigmaw(i) = sigmad
+         fip(i) = 0.
+        ELSE
+         wape(i) = wape2(i)
+         cstar(i)=cstar2(i)
+        ENDIF
+!cc        print*,'wape wape2 ktopw OK_qx_qw =',
+!cc     $          wape(i),wape2(i),ktopw(i),OK_qx_qw(i)
+      ENDDO
+!c
+!c
+      RETURN
+      END SUBROUTINE WAKE
+
+      SUBROUTINE wake_vec_modulation(nlon,nl,wk_adv,epsilon,qe,d_qe,                 &
+       &           deltaqw,d_deltaqw,sigmaw,d_sigmaw,alpha)
+!c------------------------------------------------------
+!cDtermination du coefficient alpha tel que les tendances
+!c corriges alpha*d_G, pour toutes les grandeurs G, correspondent
+!c a une humidite positive dans la zone (x) et dans la zone (w).
+!c------------------------------------------------------
+!c
+ 
+!c  Input
+      REAL qe(nlon,nl),d_qe(nlon,nl)
+      REAL deltaqw(nlon,nl),d_deltaqw(nlon,nl)
+      REAL sigmaw(nlon),d_sigmaw(nlon)
+      LOGICAL wk_adv(nlon)
+      INTEGER nl,nlon
+!c  Output
+      REAL alpha(nlon)
+!c  Internal variables
+      REAL zeta(nlon,nl)
+      REAL alpha1(nlon)
+      REAL x,a,b,c,discrim
+      REAL epsilon
+!      DATA epsilon/1.e-15/
+!c
+      DO k=1,nl
+      DO i = 1,nlon
+       IF (wk_adv(i)) THEN
+        IF ((deltaqw(i,k)+d_deltaqw(i,k)).ge.0.) then
+         zeta(i,k)=0.
+        ELSE
+         zeta(i,k)=1.
+        END IF
+       ENDIF
+      ENDDO
+      DO i = 1,nlon
+       IF (wk_adv(i)) THEN
+        x = qe(i,k)+(zeta(i,k)-sigmaw(i))*deltaqw(i,k)                               &
+       &    + d_qe(i,k)+(zeta(i,k)-sigmaw(i))*d_deltaqw(i,k)                         &
+       &    - d_sigmaw(i)*(deltaqw(i,k)+d_deltaqw(i,k))
+        a = -d_sigmaw(i)*d_deltaqw(i,k)
+        b = d_qe(i,k)+(zeta(i,k)-sigmaw(i))*d_deltaqw(i,k)                           &
+       &    - deltaqw(i,k)*d_sigmaw(i)
+        c = qe(i,k)+(zeta(i,k)-sigmaw(i))*deltaqw(i,k)+epsilon
+        discrim = b*b-4.*a*c
+!c      print*, 'x, a, b, c, discrim', x, a, b, c, discrim
+        IF (a+b .GE. 0.) THEN !! Condition suffisante pour la positivité de ovap
+         alpha1(i)=1.
+        ELSE
+         IF (x .GE. 0.) THEN
+            alpha1(i)=1.
+         ELSE
+              IF (a .GT. 0.) THEN
+                 alpha1(i)=0.9*min(   (2.*c)/(-b+sqrt(discrim)),                     &
+       &                        (-b+sqrt(discrim))/(2.*a)   )
+              ELSE IF (a .eq. 0.) then
+                 alpha1(i)=0.9*(-c/b)
+              ELSE
+!c         print*,'a,b,c discrim',a,b,c discrim
+                 alpha1(i)=0.9*max(   (2.*c)/(-b+sqrt(discrim)),                     &
+       &                        (-b+sqrt(discrim))/(2.*a)   )
+              ENDIF
+         ENDIF
+        ENDIF
+       alpha(i) = min(alpha(i),alpha1(i))
+       ENDIF
+      ENDDO
+      ENDDO
+!
+      return
+      end SUBROUTINE wake_vec_modulation
+
+      SUBROUTINE WAKE_scal (p,ph,ppi,dtime,sigd_con                                  &
+       &                ,te0,qe0,omgb                                                &
+       &                ,dtdwn,dqdwn,amdwn,amup,dta,dqa                              &
+       &                ,wdtPBL,wdqPBL,udtPBL,udqPBL                                 &
+       &                ,deltatw,deltaqw,dth,hw,sigmaw,wape,fip,gfl                  &
+       &                ,dtls,dqls                                                   &
+       &                ,ktopw,omgbdth,dp_omgb,wdens                                 &
+       &                ,tu,qu                                                       &
+       &                ,dtKE,dqKE                                                   &
+       &                ,dtPBL,dqPBL                                                 &
+       &                ,omg,dp_deltomg,spread                                       &
+       &                ,Cstar,d_deltat_gw                                           &
+       &                ,d_deltatw2,d_deltaqw2)
+
+!***************************************************************
+!*                                                             *
+!* WAKE                                                        *
+!*      retour a un Pupper fixe                                *
+!*                                                             *
+!* written by   :  GRANDPEIX Jean-Yves   09/03/2000            *
+!* modified by :   ROEHRIG Romain        01/29/2007            *
+!***************************************************************
+!c
+      USE dimphy
+      IMPLICIT none
+!c============================================================================
+!C
+!C
+!C   But : Decrire le comportement des poches froides apparaissant dans les
+!C        grands systemes convectifs, et fournir l'energie disponible pour
+!C        le declenchement de nouvelles colonnes convectives.
+!C
+!C   Variables d'etat : deltatw    : ecart de temperature wake-undisturbed area
+!C                      deltaqw    : ecart d'humidite wake-undisturbed area
+!C                      sigmaw     : fraction d'aire occupee par la poche.
+!C
+!C   Variable de sortie : 
+!c
+!c			 wape : WAke Potential Energy
+!c                        fip  : Front Incident Power (W/m2) - ALP
+!c                        gfl  : Gust Front Length per unit area (m-1)
+!C                        dtls : large scale temperature tendency due to wake
+!C                        dqls : large scale humidity tendency due to wake
+!C                        hw   : hauteur de la poche
+!C                     dp_omgb : vertical gradient of large scale omega
+!C                      omgbdth: flux of Delta_Theta transported by LS omega
+!C                      dtKE   : differential heating (wake - unpertubed)
+!C                      dqKE   : differential moistening (wake - unpertubed)
+!C                      omg    : Delta_omg =vertical velocity diff. wake-undist. (Pa/s)
+!C                 dp_deltomg  : vertical gradient of omg (s-1)
+!C                     spread  : spreading term in dt_wake and dq_wake
+!C                 deltatw     : updated temperature difference (T_w-T_u).
+!C                 deltaqw     : updated humidity difference (q_w-q_u).
+!C                 sigmaw      : updated wake fractional area.
+!C                 d_deltat_gw : delta T tendency due to GW
+!c
+!C   Variables d'entree : 
+!c
+!c		         aire : aire de la maille
+!c			 te0  : temperature dans l'environnement  (K)
+!C                        qe0  : humidite dans l'environnement     (kg/kg)
+!C                        omgb : vitesse verticale moyenne sur la maille (Pa/s)
+!C                        dtdwn: source de chaleur due aux descentes (K/s)
+!C                        dqdwn: source d'humidite due aux descentes (kg/kg/s)
+!C			 dta  : source de chaleur due courants satures et detrain  (K/s)
+!C			 dqa  : source d'humidite due aux courants satures et detra (kg/kg/s)
+!C                        amdwn: flux de masse total des descentes, par unite de
+!C                                surface de la maille (kg/m2/s)
+!C                        amup : flux de masse total des ascendances, par unite de
+!C                                surface de la maille (kg/m2/s)
+!C                        p    : pressions aux milieux des couches (Pa)
+!C                        ph   : pressions aux interfaces (Pa)
+!C                        ppi  : (p/p_0)**kapa (adim)
+!C                        dtime: increment temporel (s)
+!c
+!C   Variables internes :
+!c
+!c			 rhow : masse volumique de la poche froide
+!C                        rho  : environment density at P levels
+!C                        rhoh : environment density at Ph levels
+!C                        te   : environment temperature | may change within
+!C                        qe   : environment humidity    | sub-time-stepping
+!C                        the  : environment potential temperature
+!C                        thu  : potential temperature in undisturbed area
+!C                        tu   :  temperature  in undisturbed area
+!C                        qu   : humidity in undisturbed area
+!C                      dp_omgb: vertical gradient og LS omega
+!C                      omgbw  : wake average vertical omega
+!C                     dp_omgbw: vertical gradient of omgbw
+!C                      omgbdq : flux of Delta_q transported by LS omega
+!C                        dth  : potential temperature diff. wake-undist.
+!C                        th1  : first pot. temp. for vertical advection (=thu)
+!C                        th2  : second pot. temp. for vertical advection (=thw)
+!C                        q1   : first humidity for vertical advection
+!C                        q2   : second humidity for vertical advection
+!C                     d_deltatw   : terme de redistribution pour deltatw
+!C                     d_deltaqw   : terme de redistribution pour deltaqw
+!C                      deltatw0   : deltatw initial
+!C                      deltaqw0   : deltaqw initial
+!C                      hw0    : hw initial
+!C                      sigmaw0: sigmaw initial
+!C                      amflux : horizontal mass flux through wake boundary
+!C                      wdens  : number of wakes per unit area (3D) or per
+!C                               unit length (2D)
+!C                      Tgw    : 1 sur la période de onde de gravité
+!c                      Cgw    : vitesse de propagation de onde de gravité
+!c                      LL     : distance entre 2 poches
+
+!c-------------------------------------------------------------------------
+!c          Déclaration de variables
+!c-------------------------------------------------------------------------
+
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+#include "YOMCST.h"
+#include "cvthermo.h"
+#include "iniprint.h"
+
+!c Arguments en entree
+!c--------------------
+
+      REAL p(klev),ph(klev+1),ppi(klev)
+      REAL dtime
+      REAL te0(klev),qe0(klev)
+      REAL omgb(klev+1)
+      REAL dtdwn(klev), dqdwn(klev)
+      REAL wdtPBL(klev),wdqPBL(klev)
+      REAL udtPBL(klev),udqPBL(klev)
+      REAL amdwn(klev), amup(klev)
+      REAL dta(klev), dqa(klev)
+      REAL sigd_con
+
+!c Sorties
+!c--------
+
+      REAL deltatw(klev), deltaqw(klev), dth(klev)
+      REAL tu(klev), qu(klev)
+      REAL dtls(klev), dqls(klev)
+      REAL dtKE(klev), dqKE(klev)
+      REAL dtPBL(klev), dqPBL(klev)
+      REAL spread(klev)
+      REAL d_deltatgw(klev)
+      REAL d_deltatw2(klev), d_deltaqw2(klev)
+      REAL omgbdth(klev+1), omg(klev+1)
+      REAL dp_omgb(klev), dp_deltomg(klev)
+      REAL d_deltat_gw(klev)
+      REAL hw, sigmaw, wape, fip, gfl, Cstar
+      INTEGER ktopw
+
+!c Variables internes
+!c-------------------
+
+!c Variables à fixer
+      REAL ALON
+      REAL coefgw
+      REAL wdens0, wdens
+      REAL stark
+      REAL alpk
+      REAL delta_t_min
+      REAL Pupper
+      INTEGER nsub
+      REAL dtimesub
+      REAL sigmad, hwmin
+
+!c Variables de sauvegarde
+      REAL deltatw0(klev)
+      REAL deltaqw0(klev)
+      REAL te(klev), qe(klev)
+      REAL sigmaw0, sigmaw1
+
+!c Variables pour les GW
+      REAL LL
+      REAL N2(klev)
+      REAL Cgw(klev)
+      REAL Tgw(klev)
+
+!c Variables liées au calcul de hw
+      REAL ptop_provis, ptop, ptop_new
+      REAL sum_dth
+      REAL dthmin
+      REAL z, dz, hw0
+      INTEGER ktop, kupper
+
+!c Autres variables internes
+      INTEGER isubstep, k
+
+      REAL sum_thu, sum_tu, sum_qu,sum_thvu
+      REAL sum_dq, sum_rho
+      REAL sum_dtdwn, sum_dqdwn
+      REAL av_thu, av_tu, av_qu, av_thvu
+      REAL av_dth, av_dq, av_rho
+      REAL av_dtdwn, av_dqdwn
+
+      REAL rho(klev), rhoh(klev+1), rhow(klev)
+      REAL rhow_moyen(klev)
+      REAL zh(klev), zhh(klev+1)
+      REAL epaisseur1(klev), epaisseur2(klev)
+
+      REAL the(klev), thu(klev)
+
+      REAL d_deltatw(klev), d_deltaqw(klev)
+
+      REAL omgbw(klev+1), omgtop
+      REAL dp_omgbw(klev)
+      REAL ztop, dztop
+      REAL alpha_up(klev)
+      
+      REAL RRe1, RRe2, RRd1, RRd2
+      REAL Th1(klev), Th2(klev), q1(klev), q2(klev)
+      REAL D_Th1(klev), D_Th2(klev), D_dth(klev)
+      REAL D_q1(klev), D_q2(klev), D_dq(klev)
+      REAL omgbdq(klev)
+
+      REAL ff, gg
+      REAL wape2, Cstar2, heff
+
+      REAL Crep(klev)
+      REAL Crep_upper, Crep_sol
+
+!C-------------------------------------------------------------------------
+!c         Initialisations
+!c-------------------------------------------------------------------------
+
+!c      print*, 'wake initialisations'
+
+!c   Essais d'initialisation avec sigmaw = 0.02 et hw = 10.
+!c-------------------------------------------------------------------------
+
+      DATA sigmad, hwmin /.02,10./
+
+!C Longueur de maille (en m)
+!c-------------------------------------------------------------------------
+
+!c      ALON = 3.e5
+      ALON = 1.e6
+
+
+!C Configuration de coefgw,stark,wdens (22/02/06 by YU Jingmei)
+!c
+!c      coefgw : Coefficient pour les ondes de gravité
+!c       stark : Coefficient k dans Cstar=k*sqrt(2*WAPE)
+!c       wdens : Densité de poche froide par maille
+!c-------------------------------------------------------------------------
+
+      coefgw=10
+!c      coefgw=1
+!c      wdens0 = 1.0/(alon**2)   
+      wdens = 1.0/(alon**2)       
+      stark = 0.50
+!cCRtest
+      alpk=0.1
+!c      alpk = 1.0 
+!c      alpk = 0.5
+!c      alpk = 0.05
+      Crep_upper=0.9
+      Crep_sol=1.0
+
+
+!C Minimum value for |T_wake - T_undist|. Used for wake top definition
+!c-------------------------------------------------------------------------
+
+      delta_t_min = 0.2
+
+
+!C 1. - Save initial values and initialize tendencies
+!C --------------------------------------------------
+
+      DO k=1,klev
+	deltatw0(k) = deltatw(k)
+	deltaqw0(k)= deltaqw(k)
+	te(k) = te0(k)
+	qe(k) = qe0(k)
+	dtls(k) = 0.
+	dqls(k) = 0.
+        d_deltat_gw(k)=0.
+        d_deltatw2(k)=0.
+        d_deltaqw2(k)=0.
+      ENDDO
+!c      sigmaw1=sigmaw
+!c      IF (sigd_con.GT.sigmaw1) THEN
+!c      print*, 'sigmaw,sigd_con', sigmaw, sigd_con
+!c      ENDIF
+      sigmaw = max(sigmaw,sigd_con)
+      sigmaw = max(sigmaw,sigmad)
+      sigmaw = min(sigmaw,0.99)
+      sigmaw0 = sigmaw
+!c      wdens=wdens0/(10.*sigmaw)
+!c      IF (sigd_con.GT.sigmaw1) THEN
+!c      print*, 'sigmaw1,sigd1', sigmaw, sigd_con
+!c      ENDIF
+
+!C 2. - Prognostic part
+!C =========================================================
+
+!c      print *, 'prognostic wake computation'
+
+
+!C 2.1 - Undisturbed area and Wake integrals
+!C ---------------------------------------------------------
+
+      z = 0.
+      ktop=0
+      kupper = 0
+      sum_thu = 0.
+      sum_tu = 0.
+      sum_qu = 0.
+      sum_thvu = 0.
+      sum_dth = 0.
+      sum_dq = 0.
+      sum_rho = 0.
+      sum_dtdwn = 0.
+      sum_dqdwn = 0.
+
+      av_thu = 0.
+      av_tu =0.
+      av_qu =0.
+      av_thvu = 0.
+      av_dth = 0.
+      av_dq = 0.
+      av_rho =0.
+      av_dtdwn =0.
+      av_dqdwn = 0.
+
+!C Potential temperatures and humidity
+!c----------------------------------------------------------
+
+      DO k =1,klev
+        rho(k) = p(k)/(rd*te(k))
+        IF(k .eq. 1) THEN
+          rhoh(k) = ph(k)/(rd*te(k))
+          zhh(k)=0
+        ELSE
+          rhoh(k) = ph(k)*2./(rd*(te(k)+te(k-1)))
+          zhh(k)=(ph(k)-ph(k-1))/(-rhoh(k)*RG)+zhh(k-1)
+        ENDIF
+        the(k) = te(k)/ppi(k)
+        thu(k) = (te(k) - deltatw(k)*sigmaw)/ppi(k)
+        tu(k) = te(k) - deltatw(k)*sigmaw
+        qu(k)  =  qe(k) - deltaqw(k)*sigmaw
+        rhow(k) = p(k)/(rd*(te(k)+deltatw(k)))
+        dth(k) = deltatw(k)/ppi(k)
+        LL = (1-sqrt(sigmaw))/sqrt(wdens)       
+      ENDDO
+        
+      DO k = 1, klev-1
+        IF(k.eq.1) THEN
+          N2(k)=0
+        ELSE
+          N2(k)=max(0.,-RG**2/the(k)*rho(k)*(the(k+1)-the(k-1))                      &
+       &           /(p(k+1)-p(k-1)))
+        ENDIF
+        ZH(k)=(zhh(k)+zhh(k+1))/2
+
+        Cgw(k)=sqrt(N2(k))*ZH(k)
+        Tgw(k)=coefgw*Cgw(k)/LL
+      ENDDO
+         
+      N2(klev)=0
+      ZH(klev)=0
+      Cgw(klev)=0
+      Tgw(klev)=0
+
+!c  Calcul de la masse volumique moyenne de la colonne
+!c-----------------------------------------------------------------
+
+      DO k=1,klev
+        epaisseur1(k)=0.
+        epaisseur2(k)=0.
+      ENDDO
+
+      epaisseur1(1)= -(Ph(2)-Ph(1))/(rho(1)*rg)+1.
+      epaisseur2(1)= -(Ph(2)-Ph(1))/(rho(1)*rg)+1.
+      rhow_moyen(1) = rhow(1)
+
+      DO k = 2, klev
+        epaisseur1(k)= -(Ph(k+1)-Ph(k))/(rho(k)*rg) +1.
+        epaisseur2(k)=epaisseur2(k-1)+epaisseur1(k)
+        rhow_moyen(k) = (rhow_moyen(k-1)*epaisseur2(k-1)+                            &
+       &                 rhow(k)*epaisseur1(k))/epaisseur2(k)
+      ENDDO
+
+
+!C Choose an integration bound well above wake top
+!c-----------------------------------------------------------------
+
+!c       Pupper = 50000.  ! melting level
+       Pupper = 60000.
+!c       Pupper = 70000.
+
+
+!C    Determine Wake top pressure (Ptop) from buoyancy integral
+!C-----------------------------------------------------------------
+
+!c-1/ Pressure of the level where dth becomes less than delta_t_min.
+
+      Ptop_provis=ph(1)
+      DO k= 2,klev
+        IF (dth(k) .GT. -delta_t_min .and.                                           &
+       &      dth(k-1).LT. -delta_t_min) THEN
+          Ptop_provis = ((dth(k)+delta_t_min)*p(k-1)                                 &
+       &          - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1))
+          GO TO 25
+        ENDIF
+      ENDDO
+25    CONTINUE
+
+!c-2/ dth integral
+
+      sum_dth = 0.
+      dthmin = -delta_t_min
+      z = 0.
+
+      DO k = 1,klev
+        dz = -(max(ph(k+1),Ptop_provis)-Ph(k))/(rho(k)*rg)
+        IF (dz .le. 0) GO TO 40
+        z = z+dz
+        sum_dth = sum_dth + dth(k)*dz
+        dthmin = min(dthmin,dth(k))
+      ENDDO
+40    CONTINUE
+
+!c-3/ height of triangle with area= sum_dth and base = dthmin
+
+      hw0 = 2.*sum_dth/min(dthmin,-0.5)
+      hw0 = max(hwmin,hw0)
+
+!c-4/ now, get Ptop
+
+      z = 0.
+      ptop = ph(1)
+
+      DO k = 1,klev
+        dz = min(-(ph(k+1)-Ph(k))/(rho(k)*rg),hw0-z)
+        IF (dz .le. 0) GO TO 45
+        z = z+dz
+        Ptop = Ph(k)-rho(k)*rg*dz
+      ENDDO
+45    CONTINUE
+
+
+!C-5/ Determination de ktop et kupper
+
+      DO k=klev,1,-1
+        IF (ph(k+1) .lt. ptop) ktop=k
+        IF (ph(k+1) .lt. pupper) kupper=k
+      ENDDO
+
+!c-6/ Correct ktop and ptop
+
+      Ptop_new=ptop
+      DO k= ktop,2,-1
+        IF (dth(k) .GT. -delta_t_min .and.                                           &
+       &      dth(k-1).LT. -delta_t_min) THEN
+          Ptop_new = ((dth(k)+delta_t_min)*p(k-1)                                    &
+       &          - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1))
+          GO TO 225
+        ENDIF
+      ENDDO
+225   CONTINUE
+
+      ptop = ptop_new
+
+      DO k=klev,1,-1
+        IF (ph(k+1) .lt. ptop) ktop=k
+      ENDDO
+
+!c Set deltatw & deltaqw to 0 above kupper
+!c-----------------------------------------------------------
+
+      DO k = kupper,klev
+        deltatw(k) = 0.
+        deltaqw(k) = 0.
+      ENDDO
+
+
+!C Vertical gradient of LS omega
+!C------------------------------------------------------------
+
+      DO k = 1,kupper
+        dp_omgb(k) = (omgb(k+1) - omgb(k))/(ph(k+1)-ph(k))
+      ENDDO
+
+
+!C Integrals (and wake top level number)
+!C -----------------------------------------------------------
+
+!C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      z = 1.
+      dz = 1.
+      sum_thvu =  thu(1)*(1.+eps*qu(1))*dz
+      sum_dth = 0.
+
+      DO k = 1,klev
+        dz = -(max(ph(k+1),Ptop)-Ph(k))/(rho(k)*rg)
+        IF (dz .LE. 0) GO TO 50
+        z = z+dz
+        sum_thu = sum_thu + thu(k)*dz
+        sum_tu = sum_tu + tu(k)*dz
+        sum_qu = sum_qu + qu(k)*dz
+        sum_thvu = sum_thvu + thu(k)*(1.+eps*qu(k))*dz
+        sum_dth = sum_dth + dth(k)*dz
+        sum_dq = sum_dq + deltaqw(k)*dz
+        sum_rho = sum_rho + rhow(k)*dz
+        sum_dtdwn = sum_dtdwn + dtdwn(k)*dz
+        sum_dqdwn = sum_dqdwn + dqdwn(k)*dz
+      ENDDO
+50    CONTINUE
+
+      hw0 = z
+
+!C 2.1 - WAPE and mean forcing computation
+!C-------------------------------------------------------------
+
+!C Means
+
+      av_thu = sum_thu/hw0
+      av_tu = sum_tu/hw0
+      av_qu = sum_qu/hw0
+      av_thvu = sum_thvu/hw0
+!c      av_thve = sum_thve/hw0
+      av_dth = sum_dth/hw0
+      av_dq = sum_dq/hw0
+      av_rho = sum_rho/hw0
+      av_dtdwn = sum_dtdwn/hw0
+      av_dqdwn = sum_dqdwn/hw0
+
+      wape = - rg*hw0*(av_dth                                                        &
+       &     + eps*(av_thu*av_dq+av_dth*av_qu+av_dth*av_dq ))/av_thvu
+
+!C 2.2 Prognostic variable update
+!C ------------------------------------------------------------
+
+!C Filter out bad wakes
+
+      IF ( wape .LT. 0.) THEN
+        if(prt_level.ge.10) print*,'wape<0'
+        wape = 0.
+        hw = hwmin
+        sigmaw = max(sigmad,sigd_con)
+        fip = 0.
+        DO k = 1,klev
+          deltatw(k) = 0.
+          deltaqw(k) = 0.
+          dth(k) = 0.
+        ENDDO
+      ELSE
+        if(prt_level.ge.10) print*,'wape>0'
+        Cstar = stark*sqrt(2.*wape)
+      ENDIF
+
+!C------------------------------------------------------------------
+!C    Sub-time-stepping
+!C------------------------------------------------------------------
+
+!c      nsub=36
+      nsub=10
+      dtimesub=dtime/nsub
+
+!c------------------------------------------------------------
+      DO isubstep = 1,nsub
+!c------------------------------------------------------------
+
+!c        print*,'---------------','substep=',isubstep,'-------------'
+
+!c  Evolution of sigmaw
+
+
+        gfl = 2.*sqrt(3.14*wdens*sigmaw)            
+
+        sigmaw =sigmaw + gfl*Cstar*dtimesub
+        sigmaw =min(sigmaw,0.99)     !!!!!!!!
+!c        wdens = wdens0/(10.*sigmaw)
+!c        sigmaw =max(sigmaw,sigd_con)
+!c        sigmaw =max(sigmaw,sigmad)
+
+!c calcul de la difference de vitesse verticale poche - zone non perturbee
+
+        z= 0.
+        dp_deltomg(1:klev)=0.
+        omg(1:klev+1)=0.
+
+        omg(1) = 0.
+        dp_deltomg(1) = -(gfl*Cstar)/(sigmaw * (1-sigmaw))
+
+        DO k=2,ktop
+          dz = -(Ph(k)-Ph(k-1))/(rho(k-1)*rg)
+          z = z+dz
+          dp_deltomg(k)= dp_deltomg(1)
+          omg(k)= dp_deltomg(1)*z
+        ENDDO
+
+        dztop=-(Ptop-Ph(ktop))/(rho(ktop)*rg)
+        ztop = z+dztop
+        omgtop=dp_deltomg(1)*ztop
+
+
+!c Conversion de la vitesse verticale de m/s a Pa/s
+
+        omgtop = -rho(ktop)*rg*omgtop
+        dp_deltomg(1) = omgtop/(ptop-ph(1))
+
+        DO k = 1,ktop
+          omg(k) = - rho(k)*rg*omg(k)
+          dp_deltomg(k) = dp_deltomg(1)
+        ENDDO
+
+!c   raccordement lineaire de omg de ptop a pupper
+
+      IF (kupper .GT. ktop) THEN
+        omg(kupper+1) = - Rg*amdwn(kupper+1)/sigmaw                                  &
+       &                + Rg*amup(kupper+1)/(1.-sigmaw)
+        dp_deltomg(kupper) = (omgtop-omg(kupper+1))/(Ptop-Pupper)
+        DO k=ktop+1,kupper
+          dp_deltomg(k) = dp_deltomg(kupper)
+          omg(k) = omgtop+(ph(k)-Ptop)*dp_deltomg(kupper)
+        ENDDO
+      ENDIF
+
+!c   Compute wake average vertical velocity omgbw
+
+      DO k = 1,klev+1
+        omgbw(k) = omgb(k)+(1.-sigmaw)*omg(k)
+      ENDDO
+
+!c  and its vertical gradient dp_omgbw
+
+      DO k = 1,klev
+        dp_omgbw(k) = (omgbw(k+1)-omgbw(k))/(ph(k+1)-ph(k))
+      ENDDO
+
+
+!c  Upstream coefficients for omgb velocity
+!c--    (alpha_up(k) is the coefficient of the value at level k)
+!c--    (1-alpha_up(k) is the coefficient of the value at level k-1)
+
+      DO k = 1,klev
+       alpha_up(k) = 0.
+       IF (omgb(k) .GT. 0.) alpha_up(k) = 1.
+      ENDDO
+
+!c  Matrix expressing [The,deltatw] from  [Th1,Th2]
+
+      RRe1 = 1.-sigmaw
+      RRe2 = sigmaw
+      RRd1 = -1.
+      RRd2 = 1.
+
+!c Get [Th1,Th2], dth and [q1,q2]
+
+      DO k = 1,kupper+1
+        dth(k) = deltatw(k)/ppi(k)
+        Th1(k) = the(k) - sigmaw     *dth(k)   ! undisturbed area
+        Th2(k) = the(k) + (1.-sigmaw)*dth(k)   ! wake
+        q1(k) = qe(k) - sigmaw     *deltaqw(k) ! undisturbed area
+        q2(k) = qe(k) + (1.-sigmaw)*deltaqw(k) ! wake
+      ENDDO
+
+      D_Th1(1) = 0.
+      D_Th2(1) = 0.
+      D_dth(1) = 0.
+      D_q1(1) = 0.
+      D_q2(1) = 0.
+      D_dq(1) = 0.
+
+      DO k = 2,kupper+1 !   loop on interfaces
+        D_Th1(k) = Th1(k-1)-Th1(k)
+        D_Th2(k) = Th2(k-1)-Th2(k)
+        D_dth(k) = dth(k-1)-dth(k)
+        D_q1(k) = q1(k-1)-q1(k)
+        D_q2(k) = q2(k-1)-q2(k)
+        D_dq(k) = deltaqw(k-1)-deltaqw(k)
+      ENDDO
+
+      omgbdth(1) = 0.
+      omgbdq(1) = 0.
+
+      DO k = 2,kupper+1  !   loop on interfaces
+        omgbdth(k) = omgb(k)*(    dth(k-1) -     dth(k))
+        omgbdq(k)  = omgb(k)*(deltaqw(k-1) - deltaqw(k))
+      ENDDO
+
+
+!c-----------------------------------------------------------------
+      DO k=1,kupper-1
+!c-----------------------------------------------------------------
+!c
+!c   Compute redistribution (advective) term
+!c
+         d_deltatw(k) =                                                              &
+       &             dtimesub/(Ph(k)-Ph(k+1))*(                                      &
+       &       RRd1*omg(k  )*sigmaw     *D_Th1(k)                                    &
+       &      -RRd2*omg(k+1)*(1.-sigmaw)*D_Th2(k+1)                                  &
+       &      -(1.-alpha_up(k))*omgbdth(k) - alpha_up(k+1)*omgbdth(k+1)              &
+       &                      )*ppi(k)
+!c         print*,'d_deltatw=',d_deltatw(k)
+!c
+         d_deltaqw(k) =                                                              &
+       &             dtimesub/(Ph(k)-Ph(k+1))*(                                      &
+       &       RRd1*omg(k  )*sigmaw     *D_q1(k)                                     &
+       &      -RRd2*omg(k+1)*(1.-sigmaw)*D_q2(k+1)                                   &
+       &      -(1.-alpha_up(k))*omgbdq(k) - alpha_up(k+1)*omgbdq(k+1)                &
+       &                      )
+!c         print*,'d_deltaqw=',d_deltaqw(k)
+!c
+!c   and increment large scale tendencies
+!c
+         dtls(k) = dtls(k) +                                                         &
+       &               dtimesub*(                                                    &
+       &        ( RRe1*omg(k  )*sigmaw     *D_Th1(k)                                 &
+       &         -RRe2*omg(k+1)*(1.-sigmaw)*D_Th2(k+1) )                             &
+       &               /(Ph(k)-Ph(k+1))                                              &
+       &         -sigmaw*(1.-sigmaw)*dth(k)*dp_deltomg(k)                            &
+       &                      )*ppi(k)
+!c         print*,'dtls=',dtls(k)
+!c
+         dqls(k) = dqls(k) +                                                         &
+       &               dtimesub*(                                                    &
+       &        ( RRe1*omg(k  )*sigmaw     *D_q1(k)                                  &
+       &         -RRe2*omg(k+1)*(1.-sigmaw)*D_q2(k+1) )                              &
+       &               /(Ph(k)-Ph(k+1))                                              &
+       &         -sigmaw*(1.-sigmaw)*deltaqw(k)*dp_deltomg(k)                        &
+       &                      )
+!c         print*,'dqls=',dqls(k)
+
+!c-------------------------------------------------------------------
+      ENDDO
+!c------------------------------------------------------------------
+
+!C   Increment state variables
+
+      DO k = 1,kupper-1
+
+!c Coefficient de répartition
+
+        Crep(k)=Crep_sol*(ph(kupper)-ph(k))/(ph(kupper)-ph(1))
+        Crep(k)=Crep(k)+Crep_upper*(ph(1)-ph(k))/(p(1)-ph(kupper))
+        
+
+!c Reintroduce compensating subsidence term.
+
+!c        dtKE(k)=(dtdwn(k)*Crep(k))/sigmaw
+!c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k))
+!c     .                   /(1-sigmaw)
+!c        dqKE(k)=(dqdwn(k)*Crep(k))/sigmaw
+!c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k))
+!c     .                   /(1-sigmaw)
+!c
+!c        dtKE(k)=(dtdwn(k)*Crep(k)+(1-Crep(k))*dta(k))/sigmaw
+!c        dtKE(k)=dtKE(k)-(dtdwn(k)*(1-Crep(k))+dta(k)*Crep(k))
+!c     .                   /(1-sigmaw)
+!c        dqKE(k)=(dqdwn(k)*Crep(k)+(1-Crep(k))*dqa(k))/sigmaw
+!c        dqKE(k)=dqKE(k)-(dqdwn(k)*(1-Crep(k))+dqa(k)*Crep(k))
+!c     .                   /(1-sigmaw)
+
+        dtKE(k)=(dtdwn(k)/sigmaw - dta(k)/(1.-sigmaw))
+        dqKE(k)=(dqdwn(k)/sigmaw - dqa(k)/(1.-sigmaw))
+!c        print*,'dtKE=',dtKE(k)
+!c        print*,'dqKE=',dqKE(k)
+!c
+        dtPBL(k)=(wdtPBL(k)/sigmaw - udtPBL(k)/(1.-sigmaw))
+        dqPBL(k)=(wdqPBL(k)/sigmaw - udqPBL(k)/(1.-sigmaw))
+!c
+        spread(k) = (1.-sigmaw)*dp_deltomg(k)+gfl*Cstar/sigmaw
+!c        print*,'spread=',spread(k)
+
+
+!c ajout d'un effet onde de gravité -Tgw(k)*deltatw(k) 03/02/06 YU Jingmei
+
+        d_deltat_gw(k)=d_deltat_gw(k)-Tgw(k)*deltatw(k)* dtimesub
+!c        print*,'d_delta_gw=',d_deltat_gw(k)
+        ff=d_deltatw(k)/dtimesub
+
+!c Sans GW
+!c
+!c        deltatw(k)=deltatw(k)+dtimesub*(ff+dtKE(k)-spread(k)*deltatw(k)) 
+!c
+!c GW formule 1
+!c
+!c        deltatw(k) = deltatw(k)+dtimesub*
+!c     $         (ff+dtKE(k) - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
+!c
+!c GW formule 2
+
+        IF (dtimesub*Tgw(k).lt.1.e-10) THEN
+          deltatw(k) = deltatw(k)+dtimesub*                                          &
+       &          (ff+dtKE(k)+dtPBL(k)                                               &
+       &          - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
+        ELSE
+           deltatw(k) = deltatw(k)+1/Tgw(k)*(1-exp(-dtimesub*Tgw(k)))*               &
+       &          (ff+dtKE(k)+dtPBL(k)                                               &
+       &          - spread(k)*deltatw(k)-Tgw(k)*deltatw(k))
+        ENDIF
+   
+        dth(k) = deltatw(k)/ppi(k)
+
+        gg=d_deltaqw(k)/dtimesub
+
+       deltaqw(k) = deltaqw(k) +                                                     &
+       &         dtimesub*(gg+ dqKE(k)+dqPBL(k) - spread(k)*deltaqw(k))
+
+       d_deltatw2(k)=d_deltatw2(k)+d_deltatw(k)
+       d_deltaqw2(k)=d_deltaqw2(k)+d_deltaqw(k)
+      ENDDO
+
+!C   And update large scale variables
+
+      DO k = 1,kupper
+        te(k) = te0(k) + dtls(k)
+        qe(k) = qe0(k) + dqls(k)
+        the(k) = te(k)/ppi(k)
+      ENDDO
+
+!c     Determine Ptop from buoyancy integral
+!c----------------------------------------------------------------------
+
+!c-1/ Pressure of the level where dth changes sign.
+
+      Ptop_provis=ph(1)
+
+      DO k= 2,klev
+        IF (dth(k) .GT. -delta_t_min .and.                                           &
+       &      dth(k-1).LT. -delta_t_min) THEN
+          Ptop_provis = ((dth(k)+delta_t_min)*p(k-1)                                 &
+       &          - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1))
+        GO TO 65
+        ENDIF
+      ENDDO
+65    CONTINUE
+
+!c-2/ dth integral
+
+      sum_dth = 0.
+      dthmin = -delta_t_min
+      z = 0.
+
+      DO k = 1,klev
+        dz = -(max(ph(k+1),Ptop_provis)-Ph(k))/(rho(k)*rg)
+        IF (dz .le. 0) GO TO 70
+        z = z+dz
+        sum_dth = sum_dth + dth(k)*dz
+        dthmin = min(dthmin,dth(k))
+      ENDDO
+70    CONTINUE
+
+!c-3/ height of triangle with area= sum_dth and base = dthmin
+
+      hw = 2.*sum_dth/min(dthmin,-0.5)
+      hw = max(hwmin,hw)
+
+!c-4/ now, get Ptop
+
+      ktop = 0
+      z=0.
+
+      DO k = 1,klev
+        dz = min(-(ph(k+1)-Ph(k))/(rho(k)*rg),hw-z)
+        IF (dz .le. 0) GO TO 75
+        z = z+dz
+        Ptop = Ph(k)-rho(k)*rg*dz
+        ktop = k
+      ENDDO
+75    CONTINUE
+
+!c-5/Correct ktop and ptop
+
+      Ptop_new=ptop
+
+      DO k= ktop,2,-1
+        IF (dth(k) .GT. -delta_t_min .and.                                           &
+       &      dth(k-1).LT. -delta_t_min) THEN
+          Ptop_new = ((dth(k)+delta_t_min)*p(k-1)                                    &
+       &          - (dth(k-1)+delta_t_min)*p(k)) /(dth(k) - dth(k-1))
+          GO TO 275
+        ENDIF
+      ENDDO
+275   CONTINUE
+
+      ptop = ptop_new
+
+      DO k=klev,1,-1
+        IF (ph(k+1) .LT. ptop) ktop=k
+      ENDDO
+
+!c-6/ Set deltatw & deltaqw to 0 above kupper
+
+      DO k = kupper,klev
+        deltatw(k) = 0.
+        deltaqw(k) = 0.
+      ENDDO
+
+!c------------------------------------------------------------------
+      ENDDO      ! end sub-timestep loop
+!C -----------------------------------------------------------------
+
+!c   Get back to tendencies per second
+
+      DO k = 1,kupper-1
+        dtls(k) = dtls(k)/dtime
+        dqls(k) = dqls(k)/dtime
+        d_deltatw2(k)=d_deltatw2(k)/dtime
+        d_deltaqw2(k)=d_deltaqw2(k)/dtime
+        d_deltat_gw(k) = d_deltat_gw(k)/dtime
+      ENDDO
+
+!C 2.1 - Undisturbed area and Wake integrals
+!C ---------------------------------------------------------
+
+      z = 0.
+      sum_thu = 0.
+      sum_tu = 0.
+      sum_qu = 0.
+      sum_thvu = 0.
+      sum_dth = 0.
+      sum_dq = 0.
+      sum_rho = 0.
+      sum_dtdwn = 0.
+      sum_dqdwn = 0.
+
+      av_thu = 0.
+      av_tu =0.
+      av_qu =0.
+      av_thvu = 0.
+      av_dth = 0.
+      av_dq = 0.
+      av_rho =0.
+      av_dtdwn =0.
+      av_dqdwn = 0.
+
+!C Potential temperatures and humidity
+!c----------------------------------------------------------
+
+      DO k =1,klev
+        rho(k) = p(k)/(rd*te(k))
+        IF(k .eq. 1) THEN
+          rhoh(k) = ph(k)/(rd*te(k))
+          zhh(k)=0
+        ELSE
+          rhoh(k) = ph(k)*2./(rd*(te(k)+te(k-1)))
+          zhh(k)=(ph(k)-ph(k-1))/(-rhoh(k)*RG)+zhh(k-1)
+        ENDIF
+        the(k) = te(k)/ppi(k)
+        thu(k) = (te(k) - deltatw(k)*sigmaw)/ppi(k)
+        tu(k) = te(k) - deltatw(k)*sigmaw
+        qu(k)  =  qe(k) - deltaqw(k)*sigmaw
+        rhow(k) = p(k)/(rd*(te(k)+deltatw(k)))
+        dth(k) = deltatw(k)/ppi(k)
+       
+      ENDDO
+
+!C Integrals (and wake top level number)
+!C -----------------------------------------------------------
+
+!C Initialize sum_thvu to 1st level virt. pot. temp.
+
+      z = 1.
+      dz = 1.
+      sum_thvu =  thu(1)*(1.+eps*qu(1))*dz
+      sum_dth = 0.
+
+      DO k = 1,klev
+        dz = -(max(ph(k+1),Ptop)-Ph(k))/(rho(k)*rg)
+
+        IF (dz .LE. 0) GO TO 51
+        z = z+dz
+        sum_thu = sum_thu + thu(k)*dz
+        sum_tu = sum_tu + tu(k)*dz
+        sum_qu = sum_qu + qu(k)*dz
+        sum_thvu = sum_thvu + thu(k)*(1.+eps*qu(k))*dz
+        sum_dth = sum_dth + dth(k)*dz
+        sum_dq = sum_dq + deltaqw(k)*dz
+        sum_rho = sum_rho + rhow(k)*dz
+        sum_dtdwn = sum_dtdwn + dtdwn(k)*dz
+        sum_dqdwn = sum_dqdwn + dqdwn(k)*dz
+      ENDDO
+ 51   CONTINUE
+
+      hw0 = z
+
+!C 2.1 - WAPE and mean forcing computation
+!C-------------------------------------------------------------
+
+!C Means
+
+      av_thu = sum_thu/hw0
+      av_tu = sum_tu/hw0
+      av_qu = sum_qu/hw0
+      av_thvu = sum_thvu/hw0
+      av_dth = sum_dth/hw0
+      av_dq = sum_dq/hw0
+      av_rho = sum_rho/hw0
+      av_dtdwn = sum_dtdwn/hw0
+      av_dqdwn = sum_dqdwn/hw0
+
+      wape2 = - rg*hw0*(av_dth                                                       &
+       &     + eps*(av_thu*av_dq+av_dth*av_qu+av_dth*av_dq ))/av_thvu
+
+
+!C 2.2 Prognostic variable update
+!C ------------------------------------------------------------
+
+!C Filter out bad wakes
+
+      IF ( wape2 .LT. 0.) THEN
+        if(prt_level.ge.10) print*,'wape2<0'
+        wape2 = 0.
+        hw = hwmin
+        sigmaw = max(sigmad,sigd_con)
+        fip = 0.
+        DO k = 1,klev
+          deltatw(k) = 0.
+          deltaqw(k) = 0.
+          dth(k) = 0.
+        ENDDO
+      ELSE
+        if(prt_level.ge.10) print*,'wape2>0'
+        Cstar2 = stark*sqrt(2.*wape2)
+
+      ENDIF
+
+      ktopw = ktop
+
+      IF (ktopw .gt. 0) then
+
+!Cjyg1     Utilisation d'un h_efficace constant ( ~ feeding layer)
+!ccc       heff = 600.
+!C      Utilisation de la hauteur hw
+!cc       heff = 0.7*hw
+       heff = hw
+
+       FIP = 0.5*rho(ktopw)*Cstar2**3*heff*2*sqrt(sigmaw*wdens*3.14)
+       FIP = alpk * FIP
+!Cjyg2
+       ELSE
+         FIP = 0.
+       ENDIF
+
+
+!C   Limitation de sigmaw
+!c
+!C   sécurité : si le wake occuppe plus de 90 % de la surface de la maille,
+!C              alors il disparait en se mélangeant à la partie undisturbed
+
+! correction NICOLAS     .     ((wape.ge.wape2).and.(wape2.le.1.0))) THEN
+      IF ((sigmaw.GT.0.9).or.                                                        &
+       &     ((wape.ge.wape2).and.(wape2.le.1.0)).or.(ktopw.le.2)) THEN
+!IM cf NR/JYG 251108    .     ((wape.ge.wape2).and.(wape2.le.1.0))) THEN
+!c      IF (sigmaw.GT.0.9) THEN
+        DO k = 1,klev
+          dtls(k) = 0.
+          dqls(k) = 0.
+          deltatw(k) = 0.
+          deltaqw(k) = 0.
+        ENDDO
+        wape = 0.
+        hw = hwmin
+        sigmaw = sigmad
+        fip = 0.
+      ENDIF
+
+      RETURN
+      END SUBROUTINE WAKE_scal
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/wrf_lmdz_mod.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/wrf_lmdz_mod.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/wrf_lmdz_mod.F90	(revision 17)
@@ -0,0 +1,3138 @@
+MODULE wrf_lmdz_mod
+!
+! Module for the interface to include LMDZ (http://lmdz.lmd.jussieu.fr/) physical packages in WRF
+!
+! L. Fita, Laboratoire Meterologie Dynamique, IPSL, UPMC, CNRS, Jussieu, Paris, France
+!   November 2013
+!
+
+! WRF modules
+!    USE module_domain_type
+
+!!!!!!! Subroutines
+! wrf_varKsoil: Subroutine to provide WRF variable values from the 4 LMDZ soil types
+! lmdz_varKsoil: Subroutine to provide variable values to the 4 LMDZ soil types according to different methods
+! LMDZmoist_WRFmoist: Subroutine to transform from LMDZ moisture array to the WRF moisture array
+! WRFmoist_LMDZmoist: Subroutine to transform from WRF moisture array to the LMDZ moisture array
+! eta_to_pressure: Subroutine to transform from eta levels to pressure levels
+! temp_to_theta: Subroutine to transform from temperatures to WRF potential temperatures
+! theta_to_temp: Subroutine to transform from WRF potential temperatures to temperature
+! temp_to_theta1: Subroutine to transform from temperature to potential temperature
+! theta_to_temp1: Subroutine to transform from potential temperature to temperature
+! def_get_scalar_value: Subroutine to get a scalar value from a .def file
+!   NOTE: For that scalar values with scientific notation (EN, or e-N) it will not work... 
+!     next version!
+! value_kind: Subroutine to determine which kind of value is given
+! string_split: Subtoutine to split a string according to a character and returns the 'Nsec' of the split
+! load_lmdz: Subroutine to load LMDZ variables with values from WRF
+! load_lmdz_limit: Subroutine to load LMDZ limit variables with values from WRF
+! get_lmdz: Subroutine to get LMDZ values and fill WRF variables
+! get_lowbdy: Subroutine to load LMDZ limit variables with values from lowbdy WRF
+! vect_mat: Subroutine to transform a LMDZ physic 1D vector to a 3D matrix
+! vect_mat_zstagg: Subroutine to transform a LMDZ physic 1D vector to a 3D matrix
+! mat_vect: Subroutine to transform a 3D matrix to a LMDZ physic 1D vector
+! mat_vect_zstagg: Subroutine to transform a 3D matrix z-staggered to a LMDZ physic 1D vector
+! WRFlanduse_LMDZKsoil: Subroutine to retrieve LMDZ Ksoil classification using WRF landuse
+! interpolate_layers: Subroutine to interpolate values between different layers 
+!   (constant values along the depth of a layer)
+! interpolate_lin: Program to interpolate values y=a+b*x with: (from clWRF modifications)
+! table_characteristics: Subroutine to read values from a WRF .TBL
+! read_table: Subroutine to read values from a WRF .TBL
+! compute_soil_mass: Subroutine to compute the total soil mass (kg) from a point with
+!   different percentages of soil types
+! compute_TOTsoil_mass_water: Subroutine to compute total soil mass and water from a 
+!   given grid point using a given data-set from SOILPARM.TBL
+! compute_TOTsoil_mass_water_values: Subroutine to compute total soil mass and water
+!   from a given grid point using the values from a given data-set of SOILPARM.TBL
+! get_lmdz_out: Subroutine to get all the LMDZ output variables into the WRF 
+!    Registry structure
+! put_lmdz_in_WRFout: Subroutine to get LMDZ output and get into WRF standard output variables
+
+! LMDZ modules
+!    USE indice_sol_mod
+
+!    IMPLICIT NONE
+
+!    INCLUDE "dimsoil.h"
+
+  CONTAINS
+
+  SUBROUTINE wrf_varKsoil(is,ie,js,je,dx,dy,wbdy,kmethod,ter,lic,oce,sic,vter,vlic,  &
+    voce,vsic,var)
+! Subroutine to provide WRF variable values from the 4 LMDZ soil types
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: is,ie,js,je,dx,dy,wbdy
+    CHARACTER(LEN=50), INTENT(IN)                        :: kmethod
+    REAL, DIMENSION(is:ie,js:je), INTENT(IN)             :: ter,lic,oce,sic
+    REAL, DIMENSION(is:ie,js:je), INTENT(IN)             :: vter,vlic,voce,vsic
+    REAL, DIMENSION(is:ie,js:je), INTENT(OUT)            :: var
+
+! Local
+    INTEGER                                              :: i,j,ddx,ddy
+    CHARACTER(LEN=50)                                    :: errmsg, fname
+    REAL*8, DIMENSION(is:ie,js:je)                       :: prop
+
+!!!!!!! Variables
+! d[x/y]: dimension of the matrices
+! kmethod: method to use
+!   'prod': product, variable is distributed by percentage of the soil type vsoil=var*soil
+! ter: percentage of continent
+! lic: percentage of frozen continent
+! oce: percentage of ocean 
+! sic: percentage of frozen ocean
+! vter: variable on continent
+! vlic: variable on frozen continent
+! voce: variable on ocean 
+! vsic: variable on frozen ocean
+! prop: proportion between soil fractions
+! var: variable to be reinterpreted from LMDZ soil types
+
+    fname="'wrf_varksoil'"
+    errmsg='ERROR -- error -- ERROR -- error'
+
+    prop=-1.d0
+    var=0.
+    ddx=dx-2*wbdy
+    ddy=dy-2*wbdy
+
+    methodkind: IF (TRIM(kmethod) == 'prod') THEN
+      DO i=1,ddx
+        DO j=1,ddy
+          var(i,j)=vter(i,j)*ter(i,j)+vlic(i,j)*lic(i,j)+voce(i,j)*oce(i,j)+vsic(i,j)*sic(i,j)
+        END DO
+      END DO
+
+    ELSE
+      PRINT *,TRIM(errmsg)
+      PRINT *,'   ' // TRIM(fname) // ": method '" // TRIM(kmethod) // "' does not exist !!!!!"
+      STOP
+
+    END IF methodkind
+
+  END SUBROUTINE wrf_varKsoil
+
+  SUBROUTINE lmdz_varKsoil(is,ie,js,je,dx,dy,wbdy,var,kmethod,ter,lic,oce,sic,vter,  &
+    vlic,voce,vsic)
+! Subroutine to provide variable values to the 4 LMDZ soil types according to 
+!   different methods
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: is,ie,js,je,dx,dy,wbdy
+    REAL, DIMENSION(is:ie,js:je), INTENT(IN)             :: var
+    CHARACTER(LEN=50), INTENT(IN)                        :: kmethod
+    REAL, DIMENSION(is:ie,js:je), INTENT(IN)             :: ter,lic,oce,sic
+    REAL, DIMENSION(is:ie,js:je), INTENT(OUT)            :: vter,vlic,voce,vsic
+
+! Local
+    INTEGER                                              :: i,j,ddx,ddy
+    CHARACTER(LEN=50)                                    :: errmsg, fname
+    REAL*8, DIMENSION(is:ie,js:je)                       :: prop
+
+!!!!!!! Variables
+! d[x/y]: dimension of the matrices
+! var: variable to be reinterpreted in LMDZ soil types
+! kmethod: method to use
+!   'NOlic': NO lic, variable is not located in ice continent soil type: lic
+!   'NOlnd': NO land, variable is distributed only to sea soil types: oce, sic
+!   'NOneg': NO negative, variable is distributed only to free ice soil types: ter, oce
+!   'NOoce': NO oce, variable is not located in ocean soil type: oce
+!   'NOpos': NO positive, variable is distributed only to iced soil types: lic, sic
+!   'NOsea': NO sea, variable is distributed only to land soil types: ter, lic
+!   'NOsic': NO sic, variable is not located in ice ocean soil type: sic
+!   'NOter': NO ter, variable is not located in land soil type: ter
+!   'prod': product, variable is distributed by percentage of the soil type vsoil=var*soil
+!   'lic:' lic, variable only is located in ice land soil type: lic
+!   'oce:' oce, variable only is located in ocean soil type: oce
+!   'sic:' sic, variable only is located in ice ocean soil type: sic
+!   'ter:' ter, variable only is located in land soil type: ter
+! ter: percentage of continent
+! lic: percentage of frozen continent
+! oce: percentage of ocean 
+! sic: percentage of frozen ocean
+! vter: variable on continent
+! vlic: variable on frozen continent
+! voce: variable on ocean 
+! vsic: variable on frozen ocean
+! prop: proportion between soil fractions
+
+    fname="'lmdz_varksoil'"
+    errmsg='ERROR -- error -- ERROR -- error'
+
+    ddx=dx-2*wbdy
+    ddy=dy-2*wbdy
+
+    prop=-1.d0
+    vter=0.
+    vlic=0.
+    voce=0.
+    vsic=0.
+
+    methodkind: IF (TRIM(kmethod) == 'NOlic') THEN
+      WHERE (ter+oce+sic /= 0.) prop=1.d0/(ter+oce+sic)
+      DO i=1,ddx
+        DO j=1,ddy
+          IF (prop(i,j) >= 0.) THEN
+            vter(i,j)=var(i,j)*ter(i,j)*prop(i,j)
+            voce(i,j)=var(i,j)*oce(i,j)*prop(i,j)
+            vsic(i,j)=var(i,j)*sic(i,j)*prop(i,j)
+          END IF
+        END DO
+      END DO
+
+    ELSEIF (TRIM(kmethod) == 'NOlnd') THEN
+      WHERE (oce+sic /= 0.) prop=oce*1.d0/(oce+sic)
+      DO i=1,ddx
+        DO j=1,ddy
+          IF (prop(i,j) >= 0.) THEN
+            voce(i,j)=var(i,j)*prop(i,j)
+            vsic(i,j)=var(i,j)*(1.-prop(i,j))
+          END IF
+        END DO
+      END DO
+
+    ELSEIF (TRIM(kmethod) == 'NOneg') THEN
+      WHERE (ter+oce /= 0.) prop=ter*1.d0/(ter+oce)
+      DO i=1,ddx
+        DO j=1,ddy
+          IF (prop(i,j) >= 0.) THEN
+            vter(i,j)=var(i,j)*prop(i,j)
+            voce(i,j)=var(i,j)*(1.-prop(i,j))
+          END IF
+        END DO
+      END DO
+
+    ELSEIF (TRIM(kmethod) == 'NOoce') THEN
+      WHERE (ter+lic+sic /= 0.) prop=1.d0/(ter+lic+sic)
+      DO i=1,ddx
+        DO j=1,ddy
+          IF (prop(i,j) >= 0.) THEN
+            vter(i,j)=var(i,j)*ter(i,j)*prop(i,j)
+            vlic(i,j)=var(i,j)*lic(i,j)*prop(i,j)
+            vsic(i,j)=var(i,j)*sic(i,j)*prop(i,j)
+          END IF
+        END DO
+      END DO
+
+    ELSEIF (TRIM(kmethod) == 'NOpos') THEN
+      WHERE (lic+sic /=0.) prop=lic*1.d0/(lic+sic)
+      DO i=1,ddx
+        DO j=1,ddy
+          IF (prop(i,j) >= 0.) THEN
+            vlic(i,j)=var(i,j)*prop(i,j)
+            vsic(i,j)=var(i,j)*(1.-prop(i,j))
+          END IF
+        END DO
+      END DO
+
+    ELSEIF (TRIM(kmethod) == 'NOsea') THEN
+      WHERE (ter+lic /= 0.) prop=ter*1.d0/(ter+lic)
+      DO i=1,ddx
+        DO j=1,ddy
+          IF (prop(i,j) >= 0.) THEN
+            vter(i,j)=var(i,j)*prop(i,j)
+            vlic(i,j)=var(i,j)*(1.-prop(i,j))
+          END IF
+        END DO
+      END DO
+
+    ELSEIF (TRIM(kmethod) == 'NOsic') THEN
+      WHERE (ter+lic+oce /= 0.) prop=1.d0/(ter+lic+oce)
+      DO i=1,ddx
+        DO j=1,ddy
+          IF (prop(i,j) >= 0.) THEN
+            vter(i,j)=var(i,j)*ter(i,j)*prop(i,j)
+            vlic(i,j)=var(i,j)*lic(i,j)*prop(i,j)
+            voce(i,j)=var(i,j)*oce(i,j)*prop(i,j)
+          END IF
+        END DO
+      END DO
+
+    ELSEIF (TRIM(kmethod) == 'NOter') THEN
+      WHERE (lic+sic+oce /= 0.) prop=1.d0/(lic+sic+oce)
+      DO i=1,ddx
+        DO j=1,ddy
+          IF (prop(i,j) >= 0.) THEN
+            vlic(i,j)=var(i,j)*lic(i,j)*prop(i,j)
+            vsic(i,j)=var(i,j)*sic(i,j)*prop(i,j)
+            voce(i,j)=var(i,j)*oce(i,j)*prop(i,j)
+          END IF
+        END DO
+      END DO
+
+    ELSEIF (TRIM(kmethod) == 'lic') THEN
+      DO i=1,ddx
+        DO j=1,ddy
+          IF (lic(i,j) /= 0.) THEN
+            vlic(i,j)=var(i,j)
+          END IF
+        END DO
+      END DO
+
+    ELSEIF (TRIM(kmethod) == 'oce') THEN
+      DO i=1,ddx
+        DO j=1,ddy
+          IF (oce(i,j) /= 0.) THEN
+            voce(i,j)=var(i,j)
+          END IF
+        END DO
+      END DO
+
+    ELSEIF (TRIM(kmethod) == 'prod') THEN
+      DO i=1,ddx
+        DO j=1,ddy
+          vter(i,j)=var(i,j)*ter(i,j)*1.d0
+          vlic(i,j)=var(i,j)*lic(i,j)*1.d0
+          voce(i,j)=var(i,j)*oce(i,j)*1.d0
+          vsic(i,j)=var(i,j)*sic(i,j)*1.d0
+        END DO
+      END DO
+
+    ELSEIF (TRIM(kmethod) == 'sic') THEN
+      DO i=1,ddx
+        DO j=1,ddy
+          IF (sic(i,j) /= 0.) THEN
+            vsic(i,j)=var(i,j)
+          END IF
+        END DO
+      END DO
+
+    ELSEIF (TRIM(kmethod) == 'ter') THEN
+      DO i=1,ddx
+        DO j=1,ddy
+          IF (ter(i,j) /= 0.) THEN
+            vter(i,j)=var(i,j)
+          END IF
+        END DO
+      END DO
+
+    ELSE
+      PRINT *,TRIM(errmsg)
+      PRINT *,'   ' // TRIM(fname) // ": method '" // TRIM(kmethod) // "' does not exist !!!!!"
+      STOP
+    END IF methodkind
+
+  END SUBROUTINE lmdz_varKsoil
+
+
+  SUBROUTINE LMDZmoist_WRFmoist(lmdzMixRat, dx, dy, dz, Nwmoist, wbdy, wqvid, wqcid, &
+    & wqrid, Nlmdzq, wMOIST)
+! Subroutine to transform from LMDZ moisture array to the WRF moisture array
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: dx, dy, dz, wbdy
+    INTEGER, INTENT(IN)                                  :: Nwmoist, wqvid, wqcid,   &
+      wqrid
+    INTEGER, INTENT(IN)                                  :: Nlmdzq
+    REAL, DIMENSION((dx-2*wbdy)*(dy-2*wbdy),dz,Nlmdzq), INTENT(IN) ::                &
+      lmdzMixRat
+    REAL, DIMENSION(1-wbdy:dx-wbdy+1,dz+1,1-wbdy:dy-wbdy+1,Nwmoist), INTENT(OUT) :: wMOIST
+
+! Local
+    INTEGER                                              :: i,j,k, iq
+    INTEGER                                              :: ddx, ddy
+    INTEGER, ALLOCATABLE, DIMENSION(:)                   :: widlmdz
+    REAL, DIMENSION(1-wbdy:dx-wbdy+1,1-wbdy:dy-wbdy+1)   :: qcr_ratio, wcrMOIST
+
+!!!!!!! Variables
+! widlmdz: vector with the id of the WRF tracers to be also included in the LMDZ moist array
+! d[x,y,z]: Spatial dimension of the WRF moisture array
+! Nwmoist: number of species in wMOIST
+! wqvid: index for the water vapor mixing ratio
+! wqcid: index for the cloud water mixing ratio
+! wqrid: index for the rain water mixing ratio
+! Nlmdzq: number of species in LMDZ
+! lmdxMixRat: LMDZ mixing ratio array
+! qcr_ratio: ratio between cloud/rain liquid water in WRF moisture array
+! wcrMOIST: WRF array combination of cloud and rain liquid water
+! wMOIST: WRF moisture array
+
+!!!!!! L. Fita, July 203
+! At this stage, we only care about water vapor, cloud liquid water and rain liquid water.
+
+    ddx=dx-2*wbdy
+    ddy=dy-2*wbdy
+
+    wMOIST=0.
+    wcrMOIST=0.
+
+    DO k=1,dz
+      DO j=1,ddy
+        DO i=1,ddx
+          wMOIST(i,k,j,wqvid) = lmdzMixRat(ddx*(j-1)+i,k,1)
+          wMOIST(i,k,j,wqcid) = lmdzMixRat(ddx*(j-1)+i,k,2)
+!!          wcrMOIST(i,j) = lmdzMixRat(ddx*(j-1)+1,k,2)
+        END DO
+      END DO
+!! L. Fita, July 2013
+!! We can not know how to split liquid water between cloud and rain. Thus, we use the previous 
+!!   time-step proportion
+!!      qcr_ratio=wMOIST(:,k,:,wqcid)/(wMOIST(:,k,:,wqcid) + wMOIST(:,k,:,wqrid))
+!!      wMOIST(:,k,:,wqcid) = wcrMOIST*qcr_ratio
+!!      wMOIST(:,k,:,wqrid) = wcrMOIST*(1.-qcr_ratio)
+    ENDDO
+
+  END SUBROUTINE LMDZmoist_WRFmoist
+
+
+  SUBROUTINE WRFmoist_LMDZmoist(wMOIST, dx, dy, dz, Nwmoist, wbdy, wqvid, wqcid,     &
+    & wqrid, Nlmdzq, lmdzMixRat)
+! Subroutine to transform from WRF moisture array to the LMDZ moisture array
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: dx, dy, dz, wbdy
+    INTEGER, INTENT(IN)                                  :: Nwmoist, wqvid, wqcid, wqrid
+    INTEGER, INTENT(IN)                                  :: Nlmdzq
+    REAL, DIMENSION(1-wbdy:dx-wbdy+1,dz+1,1-wbdy:dy-wbdy+1,Nwmoist), INTENT(IN) :: wMOIST
+    REAL, DIMENSION((dx-2*wbdy)*(dy-2*wbdy),dz,Nlmdzq), INTENT(OUT) :: lmdzMixRat
+
+! Local
+    INTEGER                                              :: i, j, k, iq, dx2, dy2
+    INTEGER                                              :: ddx, ddy
+!    INTEGER, ALLOCATABLE, DIMENSION(:)                   :: widlmdz
+!    REAL, DIMENSION(dx,dy)                               :: wcrMOIST
+    REAL, DIMENSION(1-wbdy:dx-wbdy+1,1-wbdy:dy-wbdy+1)   :: qcr_ratio, wcrMOIST
+
+
+!!!!!!! Variables
+! wMOIST: WRF moisture array
+! d[x,y,z]: Spatial dimension of the WRF moisture array
+! Nwmoist: number of species in wMOIST
+! wqvid: index for the water vapor mixing ratio
+! wqcid: index for the cloud water mixing ratio
+! wqrid: index for the rain water mixing ratio
+! wcrMOIST: WRF array combination of cloud and rain liquid water
+! Nlmdzq: number of species in LMDZ
+! lmdxMixRat: LMDZ mixing ratio array
+! widlmdz: vector with the id of the WRF tracers to be also included in the LMDZ moist array
+
+    ddx=dx-2*wbdy
+    ddy=dy-2*wbdy
+
+    lmdzMixRat=0.
+
+    DO k=1,dz
+! Only taking water vapor and cloud water mixing ratios
+      DO j=1,ddy
+        DO i=1,ddx
+          lmdzMixRat(ddx*(j-1)+i,k,1) = wMOIST(i,k,j,wqvid)
+          lmdzMixRat(ddx*(j-1)+i,k,2) = wMOIST(i,k,j,wqcid)
+        END DO
+      END DO
+    ENDDO
+
+!!    IF (Nlmdzq > 2) THEN
+! Whenever we would like to use more WRF water spicies some sort of mapping should be needed. 
+!   Maybe  something like this:
+!      IF (ALLOCATED(widlmdz)) DEALLOCATE(widlmdz)
+!      ALLOCATE(widlmdz(Nlmdzq-2))
+
+!!      DO iq=3,Nlmdzq
+!!        DO k=1,dz
+!!          lmdzMixRat(:,k,iq) = (iq-3.+(dz-k-1.)*1./(dz+1.))*1.
+!!        END DO
+!!      END DO
+!!    END IF
+
+!    DEALLOCATE(widlmdz)
+
+  END SUBROUTINE WRFmoist_LMDZmoist
+
+
+  SUBROUTINE eta_to_pressure(etaP, psfc, ptop, dz, presP)
+! Subroutine to transform from eta levels to pressure levels
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: dz
+    REAL, INTENT(IN)                                     :: psfc, ptop
+    REAL, DIMENSION(dz), INTENT(IN)                      :: etaP
+    REAL, DIMENSION(dz), INTENT(OUT)                     :: presP
+
+!!!!!!Variables
+! etaP: vector with the eta values
+! psfc: pressure at the surface (in Pa)
+! ptop: pressure at the top (in Pa)
+! dz: number of vertical levels
+! presP: equivalent vector of pressures (in Pa)
+
+    presP = etaP*(psfc - ptop) + ptop
+
+  END SUBROUTINE eta_to_pressure
+
+
+  SUBROUTINE temp_to_theta(tempValues, pressValues, thetaValues,                     &
+    &                  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                 &
+   )
+! Subroutine to transform from temperatures to WRF potential temperatures
+
+    USE module_model_constants
+
+    IMPLICIT NONE
+
+!-- thetaValues   potential temperature values from WRF (300. to be added)
+!-- pressValues   pressure
+!-- tempValues    temperature values in K
+!
+!-- 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
+
+
+    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: tempValues,            &
+       &           pressValues
+    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: thetaValues
+
+! Local
+    REAL, PARAMETER                                      :: pres0 = 100000.
+
+    thetaValues = tempValues * ( pres0 / pressValues ) ** (r_d / cp)
+
+    thetaValues = thetaValues - 300.
+
+  END SUBROUTINE temp_to_theta
+
+  SUBROUTINE theta_to_temp(thetaValues, pressValues, tempValues,                     &
+    &                  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                 &
+   )
+! Subroutine to transform from WRF potential temperatures to temperature
+
+    USE module_model_constants
+
+    IMPLICIT NONE
+
+!-- thetaValues   potential temperature values from WRF (300. to be added)
+!-- pressValues   pressure
+!-- tempValues    temperature values in K
+!
+!-- 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
+
+
+    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: thetaValues,           &
+       &           pressvalues
+    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: tempValues
+
+! Local
+    REAL, PARAMETER                                      :: pres0 = 100000.
+    INTEGER                                              :: i,j,k
+
+!!    PRINT *,'  thetaValues: ', LBOUND(thetaValues),' x ', UBOUND(thetaValues)
+
+!!    DO k=kms,kme-2
+!!      DO j=jms,jme
+!!        DO i=ims,ime
+!!          IF (thetaValues(i,k,j) == 0. .AND. i > 0 .AND. i < 32 &
+!!            .AND. j > 0 .AND. j < 32) THEN
+!!            PRINT *,'  Zth: T ',i,k,j,thetaValues(i,k,j)
+!!          END IF
+!!        END DO
+!!      END DO
+!!    END DO
+
+    tempValues = ( thetaValues + 300.)*( pressValues / pres0 ) ** (r_d / cp)
+
+!!    DO k=kms,kme-2
+  END SUBROUTINE theta_to_temp
+
+  SUBROUTINE temp_to_theta1(tempValue, pressValue, thetaValue)
+! Subroutine to transform from temperature to potential temperature
+
+    USE module_model_constants
+
+    IMPLICIT NONE
+
+!!!!!!! Variables
+! thetaValue   potential temperature value
+! pressValue   pressure
+! tempValue    temperature value in K
+!
+    REAL, INTENT(IN)                                     :: tempValue, pressValue
+    REAL, INTENT(OUT)                                    :: thetaValue
+
+! Local
+    REAL, PARAMETER                                      :: pres0 = 100000.
+
+    thetaValue = tempValue * ( pres0 / pressValue ) ** (r_d / cp)
+
+  END SUBROUTINE temp_to_theta1
+
+  SUBROUTINE theta_to_temp1(thetaValue, pressValue, tempValue)
+! Subroutine to transform from potential temperature to temperature
+
+    USE module_model_constants
+
+    IMPLICIT NONE
+
+!!!!!!! Variables
+! thetaValue   potential temperature 
+! pressValue   pressure
+! tempValue    temperature value in K
+
+    REAL, INTENT(IN)                                     :: thetaValue, pressvalue
+    REAL, INTENT(OUT)                                    :: tempValue
+
+! Local
+    REAL, PARAMETER                                      :: pres0 = 100000.
+
+    tempValue = thetaValue*( pressValue / pres0 ) ** (r_d / cp)
+
+  END SUBROUTINE theta_to_temp1
+
+  SUBROUTINE def_get_scalar_value(filen, valn, ds, di, dr, db)
+! Subroutine to get a scalar value from a .def file
+!   NOTE: For that scalar values with scientific notation (EN, or e-N) it will not work... 
+!     next version!
+
+    IMPLICIT NONE
+
+    CHARACTER(LEN=100), INTENT(IN)                       :: filen, valn
+    CHARACTER(LEN=100), INTENT(OUT)                      :: ds
+    INTEGER, INTENT(OUT)                                 :: di
+    REAL, INTENT(OUT)                                    :: dr
+    LOGICAL, INTENT(OUT)                                 :: db
+
+! Local
+    INTEGER                                              :: funit, ios, Lvaln
+    INTEGER                                              :: iline, lineval
+    CHARACTER(LEN=1)                                     :: kindvalue
+    CHARACTER(LEN=100)                                   :: varname,varname0
+    CHARACTER(LEN=50)                                    :: subname, errmsg, value,  &
+      value0
+    LOGICAL                                              :: fexists, is_used
+
+!!!!!!! Variables
+! filen: Name of the def file to get the value
+! valn: name of the value to get
+! ds: string value (up to 100 characters)
+! di: integer value
+! dr: real value
+! db: logical value
+! value: value get from the file
+! kindvalue: kind of the value ('s': string, 'i': integer, 'r': real, 'b':boolean )
+
+    subname = 'def_get_scalar_value'
+    errmsg = 'ERROR -- error -- ERROR -- error'
+
+    INQUIRE(FILE=TRIM(filen), EXIST=fexists)
+
+    IF (fexists) THEN
+      Lvaln = LEN_TRIM(valn)
+
+      ds = 'None'
+      di = 0
+      dr = 0.
+      db = .FALSE.
+
+      DO funit=10,100
+        INQUIRE(UNIT=funit, OPENED=is_used)
+        IF (.NOT. is_used) EXIT
+      END DO
+      OPEN(funit, FILE=TRIM(filen), STATUS='old', FORM='formatted', IOSTAT=ios)
+      IF ( ios /= 0 ) THEN
+        PRINT *,errmsg
+        PRINT *, '  ' // TRIM(subname) // ": ERROR opening '" // TRIM(filen) // "'"
+        PRINT *,'ios: ',ios
+        STOP
+      END IF
+!      iunit = get_unused_unit()
+!      IF ( iunit <= 0 ) THEN
+!        IF ( wrf_dm_on_monitor() ) THEN
+!          CALL wrf_error_fatal('Error in module_ra_cam_support: could not find a free Fortran unit.')
+!        END IF
+!      END IF
+      lineval = 0
+      DO iline=1, 10000
+        READ(funit,*,END=125)varname0
+        varname = TRIM(varname0)
+        IF (varname(1:Lvaln) == TRIM(valn)) THEN
+          lineval = iline
+          EXIT
+        END IF
+      END DO
+
+ 125  CONTINUE
+      IF (lineval == 0) THEN
+        PRINT *,errmsg
+        PRINT *,'  ' // TRIM(subname) // ": In file '" // TRIM(filen) //             &
+          & "' does not exist a variable called '" // TRIM(valn) // '" !!!'
+        STOP 
+      ELSE
+        CLOSE(funit)
+        OPEN(funit, FILE=TRIM(filen), STATUS='old', FORM='formatted', IOSTAT=ios)
+        DO iline=1,lineval-1
+          READ(funit,*)varname
+        END DO
+        READ(funit,*)value0
+        CLOSE(UNIT=funit)
+
+        CALL string_split(value0, '=', 2, value)
+        CALL string_split(value, ':', 2, value)
+        CALL value_kind(value, kindvalue)
+
+!        PRINT *,'value: ',TRIM(value), ' kind: ',kindvalue
+
+        IF (kindvalue == 'i') THEN
+          READ(value, '(I50)')di
+        ELSE IF (kindvalue == 'r') THEN
+          READ(value, '(F50.25)')dr
+        ELSE IF (kindvalue == 'e') THEN
+          READ (value, '(E50.25)')dr
+        ELSE IF (kindvalue == 's') THEN
+          ds = TRIM(value)
+        ELSE
+          IF (TRIM(value) == 'y' .OR. TRIM(value) == 'yes' .OR. TRIM(value) == 'Y'   &
+            .OR. TRIM(value) == 'Yes' .OR. TRIM(value) == 'YES') db = .TRUE.
+
+          IF (TRIM(value) == 'n' .OR. TRIM(value) == 'no' .OR. TRIM(value) == 'N'    &
+            .OR. TRIM(value) == 'No' .OR. TRIM(value) == 'NO') db = .FALSE.
+        END IF
+      END IF 
+    ELSE
+      PRINT *,errmsg
+      PRINT *,'  ' // TRIM(subname) // ": File '" // TRIM(filen) // "' does not exist !!"
+      STOP
+    END IF
+
+  END SUBROUTINE def_get_scalar_value
+
+  SUBROUTINE value_kind(value, kindval)
+! Subroutine to determine which kind of value is given
+
+    IMPLICIT NONE
+
+    CHARACTER(LEN=50), INTENT(IN)                        :: value
+    CHARACTER(LEN=1), INTENT(OUT)                        :: kindval
+
+! Local
+    INTEGER                                              :: ic
+    INTEGER                                              :: Lval, Nc, NnumVal, NstrVal
+    LOGICAL                                              :: is_point, is_exp
+
+!!!!!!! Variables
+! value: value to determine the cahracteristics
+! kindval: kind of value. 's': string, 'i': integer, 'r': real, 'e': real scientific notation,
+!   'b':boolean
+! Lval: length of characters of the value 
+! NnumVal: number of numeric characers
+! NstrVal: number of string characters
+! is_point: boolean variable indicating the presence of a '.'
+! is_exp: boolean variable indicating the presence of a 'E' or 'e' (exponential)
+
+
+    IF (TRIM(value) == 'y' .OR. TRIM(value) == 'n' .OR. TRIM(value) == 'yes' .OR.    &
+      TRIM(value) == 'no' .OR. TRIM(value) == 'Y' .OR. TRIM(value) == 'N' .OR.       &
+      TRIM(value) == 'Yes' .OR. TRIM(value) == 'No' .OR. TRIM(value) == 'YES' .OR.   &
+      TRIM(value) == 'NO') THEN
+!      PRINT *,'    boolean!'
+      kindval = 'b'
+    ELSE
+      Lval = LEN_TRIM(value)
+      NnumVal = 0
+      NstrVal = 0
+      is_point = .FALSE.
+
+      DO ic=1,Lval
+        Nc = ICHAR(value(ic:ic)) 
+!        PRINT *, 'char: ',value(ic:ic), ' Nc:',Nc
+        IF (Nc >= 48 .AND. Nc <= 57) THEN
+          Nnumval = Nnumval + 1
+        ELSE
+          NstrVal = NstrVal + 1
+          IF (value(ic:ic) == '.') is_point = .TRUE.
+          IF ((value(ic:ic) == 'e') .OR. (value(ic:ic) == 'E')) is_exp = .TRUE.
+        END IF
+      END DO
+
+!      PRINT *,'NnumVal:', NnumVal, 'NstrVal: ', NstrVal, 'point: ', is_point
+      IF (Nnumval == Lval) THEN
+!        PRINT *,'    integer!'
+        kindval = 'i'
+      ELSE IF ( (Nnumval == Lval -1) .AND. (is_point .EQV. .TRUE.) .AND.             &
+        (NstrVal == 1)) THEN
+!        PRINT *,'    real!'
+        kindval = 'r'
+      ELSE IF ( ((Nnumval == Lval -2) .OR.(Nnumval == Lval -3)) .AND.                &
+        (is_point .EQV. .TRUE.) .AND. (is_exp .EQV. .TRUE.) .AND.                    &
+        ((NstrVal == 2) .OR. (NstrVal == 3)) ) THEN
+!        PRINT *,'    real exponential!'
+        kindval = 'e'
+      ELSE
+!        PRINT *,'    string!'
+        kindval = 's'
+      END IF
+    END IF
+
+  END SUBROUTINE value_kind
+
+  SUBROUTINE string_split(string, charsplit, Nsec, sec)
+! Subtoutine to split a string according to a character and returns the 'Nsec' of the split
+
+  IMPLICIT NONE
+
+  CHARACTER(LEN=50), INTENT(IN)                          :: string
+  CHARACTER(LEN=1), INTENT(IN)                           :: charsplit
+  INTEGER, INTENT(IN)                                    :: Nsec
+  CHARACTER(LEN=50), INTENT(OUT)                         :: sec
+
+! Local
+  INTEGER                                                :: ic
+  INTEGER                                                :: poschar, Lstring
+  INTEGER                                                :: isec, inisec
+  CHARACTER(LEN=50)                                      :: str, secchar
+
+!!!!!!! Variables
+! string: string to split
+! charsplit: character to use to split
+! Nsec: number of section to return
+! sec: returned section of the string 
+
+!  PRINT *,'string: ',string
+
+  str = TRIM(string)
+  poschar=0
+
+  Lstring = LEN_TRIM(str)
+  isec = 1
+  poschar = INDEX(str, charsplit)
+  inisec = 1
+
+  IF (poschar == 0) THEN
+    sec = str
+
+  ELSE
+    DO ic=poschar,50  
+      secchar = str(inisec:poschar-1)
+      IF (isec == Nsec) sec = secchar
+      inisec = poschar + 1
+      poschar = INDEX(str(inisec:Lstring), charsplit)
+      IF (poschar == 0) poschar = Lstring + 2
+      isec = isec + 1
+    END DO
+
+  END IF
+
+  END SUBROUTINE string_split
+
+  SUBROUTINE get_lmdz(ddx,ddy,ddz,bdy,dlmdz,Nks,NzO,plon,plat,pzmasq,ppctsrf,pftsol, &
+    pftsoil,pqsol,pqsurf,pfalb1,pfalb2,pevap,psnow,pradsol,psolsw,psollw,pfder,      &
+    prain_fall,psnow_fall,pagesno,pzmea,pzstd,pzgam,pzthe,pzpic,pzval,prugoro,       &
+    prugos,pzmax0,pf0,pwake_s,pwake_cstar,pwake_pe,pwake_fip,psst,                   &
+    palbedo,pt_ancien,pq_ancien,pu_ancien,pv_ancien,pclwcon,prnebcon,pratqs,         &
+    pema_work1,pema_work2,pwake_deltat,pwake_deltaq,pfm_therm,pentr_therm,           &
+    pdetr_therm,pnat,pwrf_grid)
+! Subroutine to get LMDZ variables with values from WRF
+
+! WRF modules
+    USE module_domain_type
+
+! LMDZ modules
+    USE indice_sol_mod
+
+    IMPLICIT NONE
+
+    TYPE(domain) , TARGET                                :: pwrf_grid
+    INTEGER, INTENT(IN)                                  :: ddx, ddy, ddz, bdy,      &
+      dlmdz, Nks, NzO
+    REAL, DIMENSION(dlmdz), INTENT(IN)                   :: plon, plat, pzmasq,      &
+      pqsol, pradsol, psolsw, psollw, pfder, prain_fall, psnow_fall, pzmea, pzstd,   &
+      pzgam, pzthe, pzpic, pzval, prugoro, pzmax0, pf0, pwake_s,                     &
+      pwake_cstar, pwake_pe, pwake_fip, psst, palbedo, pnat
+! What to do with these variables? ,pnat,pbils,prug
+    REAL, DIMENSION(dlmdz,Nks), INTENT(IN)               :: ppctsrf,pftsol,pqsurf,   &
+      pfalb1,pfalb2,pevap,psnow,prugos,pagesno
+    REAL, DIMENSION(dlmdz,ddz), INTENT(IN)               :: pt_ancien,pq_ancien,     &
+      pu_ancien,pv_ancien,pclwcon,prnebcon,pratqs,pema_work1,pema_work2,pwake_deltat,&
+      pwake_deltaq,pentr_therm,pdetr_therm
+    REAL, DIMENSION(dlmdz,NzO,Nks), INTENT(IN)           :: pftsoil
+    REAL, DIMENSION(dlmdz,ddz+1), INTENT(IN)             :: pfm_therm
+
+! Local
+    INTEGER                                              :: ix,iy,iz,ixy,dx,dy
+    CHARACTER(LEN=50)                                    :: LMDZvarmethod
+
+! Filling all 2D variables
+!!
+    PRINT *,'  Lluis before get_lmdz: 5 11 ltksoil: ',pwrf_grid%ltksoil(5,:,11),     &
+      ' ftsol: ', pftsol(315,:)
+
+    DO iy=1,ddy
+      DO ix=1,ddx
+        ixy=ddx*(iy-1)+ix
+! It does not change on time: pzmask
+! It might change due to ice dynamics?
+        pwrf_grid%lter(ix,iy) = ppctsrf(ixy,is_ter)
+        pwrf_grid%llic(ix,iy) = ppctsrf(ixy,is_lic)
+        pwrf_grid%loce(ix,iy) = ppctsrf(ixy,is_oce)
+        pwrf_grid%lsic(ix,iy) = ppctsrf(ixy,is_sic)
+        DO iz=1,Nks
+          pwrf_grid%ltksoil(ix,iz,iy) = pftsol(ixy,iz)
+        END DO
+        DO iz=1,NzO
+          pwrf_grid%lotter(ix,iz,iy) = pftsoil(ixy,iz,1)
+          pwrf_grid%lotlic(ix,iz,iy) = pftsoil(ixy,iz,2)
+          pwrf_grid%lotoce(ix,iz,iy) = pftsoil(ixy,iz,3)
+          pwrf_grid%lotsic(ix,iz,iy) = pftsoil(ixy,iz,4)
+        END DO
+        DO iz=1,Nks
+          pwrf_grid%lqksoil(ix,iz,iy) = pqsurf(ixy,iz)
+        END DO
+        pwrf_grid%lwsol(ix,iy) = pqsol(ixy)
+        DO iz=1,Nks
+          pwrf_grid%lalbksoil(ix,iz,iy) = pfalb1(ixy,iz)
+          pwrf_grid%llwalbksoil(ix,iz,iy) = pfalb2(ixy,iz)
+          pwrf_grid%levapksoil(ix,iz,iy) = pevap(ixy,iz)
+          pwrf_grid%lsnowksoil(ix,iz,iy) = psnow(ixy,iz)
+        END DO
+        pwrf_grid%lrads(ix,iy) = pradsol(ixy)
+        pwrf_grid%lsolsw(ix,iy) = psolsw(ixy)
+        pwrf_grid%lsollw(ix,iy) = psollw(ixy)
+        pwrf_grid%lfder(ix,iy) = pfder(ixy)
+        pwrf_grid%lrain(ix,iy) = prain_fall(ixy)
+        pwrf_grid%lsnow(ix,iy) = psnow_fall(ixy)
+        DO iz=1,Nks
+          pwrf_grid%lrugksoil(ix,iz,iy) = prugos(ixy,iz)
+          pwrf_grid%lagesnoksoil(ix,iz,iy) = pagesno(ixy,iz)
+        END DO
+! These variables do not change on time!
+!!
+!    pzmea, pzstd, pzsig, pzgam, pzthe, pzpic, pzval, prugsrel
+        pwrf_grid%lrugsea(ix,iy) = prugos(ixy,is_oce)
+!        pwrf_grid%lrunofflic(ix,iy)= prun_off_lic(ixy)
+        pwrf_grid%lzmax0(ix,iy) = pzmax0(ixy)
+        pwrf_grid%lf0(ix,iy) = pf0(ixy)
+        pwrf_grid%lwake_s(ix,iy) = pwake_s(ixy)
+        pwrf_grid%lwake_cstar(ix,iy) = pwake_cstar(ixy)
+        pwrf_grid%lwake_pe(ix,iy) = pwake_pe(ixy)
+        pwrf_grid%lwake_fip(ix,iy) = pwake_fip(ixy)
+        pwrf_grid%lnat(ix,iy) = pnat(ixy)
+        pwrf_grid%sst(ix,iy) = psst(ixy)
+!        pwrf_grid%lbils(ix,iy) = pbils(ixy)
+        pwrf_grid%albedo(ix,iy) = palbedo(ixy)
+!        pwrf_grid%lrug(ix,iy) = prug(ixy)
+      END DO
+    END DO
+
+    dx=ddx+2*bdy
+    dy=ddy+2*bdy
+
+    CALL vect_mat(pclwcon, dx, dy, ddz, bdy, pwrf_grid%lclwcon)
+    CALL vect_mat(prnebcon, dx, dy, ddz, bdy, pwrf_grid%lrnebcon)
+    CALL vect_mat(pratqs, dx, dy, ddz, bdy, pwrf_grid%lratqs)
+    CALL vect_mat(pema_work1, dx, dy, ddz, bdy, pwrf_grid%lema_work1)
+    CALL vect_mat(pema_work2, dx, dy, ddz, bdy, pwrf_grid%lema_work2)
+    CALL vect_mat(pwake_deltat, dx, dy, ddz, bdy, pwrf_grid%lwake_deltat)
+    CALL vect_mat(pwake_deltaq, dx, dy, ddz, bdy, pwrf_grid%lwake_deltaq)
+    CALL vect_mat(pfm_therm, dx, dy, ddz+1, bdy, pwrf_grid%lfm_therm)
+    CALL vect_mat(pentr_therm, dx, dy, ddz, bdy, pwrf_grid%lentr_therm)
+    CALL vect_mat(pdetr_therm, dx, dy, ddz, bdy, pwrf_grid%ldetr_therm)
+
+    PRINT *,'  Lluis after get_lmdz: 5 11 ltksoil: ',pwrf_grid%ltksoil(5,:,11),      &
+      ' ftsol: ', pftsol(315,:)
+
+    RETURN
+
+  END SUBROUTINE get_lmdz
+
+  SUBROUTINE get_lowbdy(ddx, ddy, ddz, bdy, dlmdz, Nks, Nz0, pkglo, pwrf_grid,       &
+    ppctsrf, pftsol, prugos, palbedo, psst, ptsurf_lim, pz0_lim, palb_lim, prug_glo, &
+    ppct_glo)
+! Subroutine to load LMDZ limit variables with values from lowbdy WRF
+
+! WRF modules
+!    USE module_model_constants
+    USE module_domain_type
+
+! LMDZ modules
+    USE indice_sol_mod
+
+    IMPLICIT NONE
+
+    TYPE(domain) , TARGET                                :: pwrf_grid
+    INTEGER, INTENT(IN)                                  :: ddx, ddy, ddz, bdy,      &
+      dlmdz, Nks, Nz0, pkglo
+    REAL, DIMENSION(dlmdz), INTENT(INOUT)                :: psst, palbedo,           &
+      ptsurf_lim, pz0_lim, palb_lim
+! What to do with these variables? ,pnat,pbils
+    REAL, DIMENSION(dlmdz,Nks), INTENT(INOUT)            :: ppctsrf, pftsol, prugos
+    REAL, DIMENSION(pkglo), INTENT(OUT)                  :: prug_glo
+    REAL, DIMENSION(pkglo,Nks), INTENT(OUT)              :: ppct_glo
+
+! Local
+    INTEGER                                              :: ix,iy,iz,ixy,dx,dy,ixx,iyy
+    CHARACTER(LEN=50)                                    :: LMDZvarmethod,fname,errmsg
+
+    fname='get_lowbdy'
+    errmsg='ERROR -- error -- ERROR -- error'
+
+! Filling all 2D variables
+!!
+    DO iy=1,ddy
+      DO ix=1,ddx
+        ixy=ddx*(iy-1)+ix
+        ppctsrf(ixy,is_ter) = pwrf_grid%lter(ix,iy)
+        ppctsrf(ixy,is_lic) = pwrf_grid%llic(ix,iy)
+        IF ( pwrf_grid%xice(ix,iy) /= pwrf_grid%lsic(ix,iy) ) THEN
+! No ocean/frozen ocean fraction before
+          IF (pwrf_grid%loce(ix,iy) == 0.) pwrf_grid%lrugksoil(ix,3,iy) = 0.0001
+          IF (pwrf_grid%lsic(ix,iy) == 0.) pwrf_grid%lrugksoil(ix,4,iy) = 0.001
+          pwrf_grid%loce(ix,iy) = 1. - pwrf_grid%lsic(ix,iy)
+          pwrf_grid%lsic(ix,iy) = pwrf_grid%lsic(ix,iy)
+          ppctsrf(ixy,is_oce) = pwrf_grid%loce(ix,iy)
+          ppctsrf(ixy,is_sic) = pwrf_grid%lsic(ix,iy)
+! Recomputing total roughness
+!!
+          pwrf_grid%lrug(ix,iy)=pwrf_grid%lter(ix,iy)*pwrf_grid%lrugksoil(ix,1,iy) +&
+            pwrf_grid%llic(ix,iy)*pwrf_grid%lrugksoil(ix,2,iy) +                    &
+            pwrf_grid%loce(ix,iy)*pwrf_grid%lrugksoil(ix,3,iy) +                    &
+            pwrf_grid%lsic(ix,iy)*pwrf_grid%lrugksoil(ix,4,iy)
+        END IF
+! Full SST grid points must have a SST value from the wrfinput (WRF 1/0 landmask)
+!   but that LMDZ points with fractions of land/mask could not. Using the closest one
+!   if it is an isolated grid point, using TSK instead
+        IF (pwrf_grid%sst(ix,iy) < 200.15) THEN
+          pwrf_grid%ltksoil(ix,3,iy) = -9.
+          IF ( (ix > 1).AND.(ix < ddx) .AND. (iy > 1).AND.(iy < ddy) ) THEN
+            DO ixx=-1,1
+              DO iyy=-1,1
+!               PRINT *,ixx,iyy,wrf_grid%sst(ix+ixx,iy+iyy)
+                IF (pwrf_grid%sst(ix+ixx,iy+iyy) > 200.15) THEN
+                  pwrf_grid%ltksoil(ix,3,iy) = pwrf_grid%sst(ix+ixx,iy+iyy)
+                  EXIT
+                END IF
+              END DO
+              IF ( pwrf_grid%ltksoil(ix,3,iy) > 200.15) EXIT
+            END DO
+            IF ( pwrf_grid%ltksoil(ix,3,iy) == -9.) pwrf_grid%ltksoil(ix,3,iy) =     &
+              pwrf_grid%tsk(ix,iy)
+            ELSE
+              pwrf_grid%ltksoil(ix,3,iy) = pwrf_grid%tsk(ix,iy)
+            END IF
+        ELSE
+          pwrf_grid%ltksoil(ix,3,iy) = pwrf_grid%sst(ix,iy)
+        END IF
+        IF ( (pwrf_grid%ltksoil(ix,3,iy) < 200.15) .OR.                              &
+          (pwrf_grid%ltksoil(ix,3,iy) > 370.) ) THEN
+          PRINT *,TRIM(errmsg)
+!          WRITE(wrf_err_message,*) '  ' // TRIM(fname) //                            &
+!            ' SST inconsistency at point: ', ix, ', ', iy,' with loce: ',            &
+!            wrf_grid%loce(ix,iy),' has a tsoil(oce)= ',                              &
+!            wrf_grid%ltksoil(ix,3,iy),' sst: ',wrf_grid%sst(ix,iy),' tsk: ',         &
+!            wrf_grid%tsk(ix,iy)
+!          CALL wrf_error_fatal(TRIM(wrf_err_message))
+          PRINT *, '  ' // TRIM(fname) //                                            &
+          ' SST inconsistency at point: ', ix, ', ', iy,' with loce: ',              &
+            pwrf_grid%loce(ix,iy),' has a tsoil(oce)= ',                             &
+            pwrf_grid%ltksoil(ix,3,iy),' sst: ', pwrf_grid%sst(ix,iy),' tsk: ',      &
+            pwrf_grid%tsk(ix,iy)
+        END IF
+        psst(ixy) = pwrf_grid%ltksoil(ix,3,iy)
+        palbedo(ixy) = pwrf_grid%albbck(ix,iy)
+        DO iz=1,Nks
+          prugos(ixy,iz) = pwrf_grid%lrugksoil(ix,iz,iy)
+        END DO
+
+! In ocean_forced_mod is used as tsurf_lim = sst(knindex(1:knon)). Let's complicate it
+!   a little bit...
+        ptsurf_lim(ixy)= psst(ixy)
+! In surf_land_bucket_mod is used as z0_new=rugos(knindex(1:knon),1) [z0_new == z0_limit]
+        pz0_lim(ixy) = prugos(ixy,1)
+        palb_lim(ixy) = palbedo(ixy)
+
+        prug_glo(ixy) = prugos(ixy,is_ter)
+        ppct_glo(ixy,:) = ppctsrf(ixy,:)
+
+      END DO
+    END DO
+
+    RETURN
+
+  END SUBROUTINE get_lowbdy
+
+  SUBROUTINE load_lmdz(pwrf_grid,ddx,ddy,ddz,bdy,dlmdz,Nks,NzO,prlon,prlat,pzmasq,   &
+    ppctsrf,pftsol,pftsoil,pqsurf,pqsol,pfalb1,pfalb2,pevap,psnow,pradsol,psolsw,    &
+    psollw,pfder,prain_fall,psnow_fall,pagesno,pzmea,pzstd,pzgam,pzthe,pzpic,pzval,  &
+    prugoro,prugos,prun_off_lic,pzmax0,pf0,pwake_s,pwake_cstar,pwake_pe,pwake_fip,   &
+    psst,palbedo,pt_ancien,pq_ancien,pu_ancien,pv_ancien,pclwcon,prnebcon,pratqs,    &
+    pema_work1,pema_work2,pwake_deltat,pwake_deltaq,pfm_therm,pentr_therm,           &
+    pdetr_therm,pnat)
+! Subroutine to load LMDZ variables with values from WRF
+
+! WRF modules
+!    USE module_model_constants
+    USE module_domain_type
+
+! LMDZ modules
+    USE indice_sol_mod
+
+    IMPLICIT NONE
+
+    TYPE(domain) , TARGET                                :: pwrf_grid
+    INTEGER, INTENT(IN)                                  :: ddx, ddy, ddz, bdy,      &
+      dlmdz, Nks, NzO
+    REAL, DIMENSION(dlmdz), INTENT(OUT)                  :: prlon, prlat, pzmasq,    &
+      pqsol, pradsol, psolsw, psollw, pfder, prain_fall, psnow_fall, pzmea, pzstd,   &
+      pzgam, pzthe, pzpic, pzval, prugoro, prun_off_lic, pzmax0, pf0, pwake_s,       &
+      pwake_cstar, pwake_pe, pwake_fip, psst, palbedo,pnat
+    REAL, DIMENSION(dlmdz,Nks), INTENT(OUT)              :: ppctsrf,pftsol,pqsurf,   &
+      pfalb1,pfalb2,pevap,psnow,prugos,pagesno
+    REAL, DIMENSION(dlmdz,ddz), INTENT(OUT)              :: pt_ancien,pq_ancien,     &
+      pu_ancien,pv_ancien,pclwcon,prnebcon,pratqs,pema_work1,pema_work2,pwake_deltat,&
+      pwake_deltaq,pentr_therm,pdetr_therm
+    REAL, DIMENSION(dlmdz,NzO,Nks), INTENT(OUT)          :: pftsoil
+    REAL, DIMENSION(dlmdz,ddz+1), INTENT(OUT)            :: pfm_therm
+
+
+! Local
+    INTEGER                                              :: ix,iy,iz,ixy,dx,dy
+    CHARACTER(LEN=50)                                    :: LMDZvarmethod,fname
+
+    fname='load_lmdz'
+
+! Filling all 2D variables
+!!
+    PRINT *,'  ' // TRIM(fname) // '; LUBOUND(grid%lmsk): ',LBOUND(pwrf_grid%lmsk), UBOUND(pwrf_grid%lmsk)
+    PRINT *,'  ' // TRIM(fname) // '; ddx ddy: ',ddy,ddx
+
+    DO iy=1,ddy
+      DO ix=1,ddx
+        ixy=ddx*(iy-1)+ix
+        prlon(ixy) = pwrf_grid%xlong(ix,iy)
+        prlat(ixy) = pwrf_grid%xlat(ix,iy)
+        pzmasq(ixy) = pwrf_grid%lmsk(ix,iy)
+        ppctsrf(ixy,is_ter) = pwrf_grid%lter(ix,iy)
+        ppctsrf(ixy,is_lic) = pwrf_grid%llic(ix,iy)
+        ppctsrf(ixy,is_oce) = pwrf_grid%loce(ix,iy)
+        ppctsrf(ixy,is_sic) = pwrf_grid%lsic(ix,iy)
+        DO iz=1,Nks
+          pftsol(ixy,iz) = pwrf_grid%ltksoil(ix,iz,iy)
+        END DO
+        DO iz=1,NzO
+          pftsoil(ixy,iz,1) = pwrf_grid%lotter(ix,iz,iy)
+          pftsoil(ixy,iz,2) = pwrf_grid%lotlic(ix,iz,iy)
+          pftsoil(ixy,iz,3) = pwrf_grid%lotoce(ix,iz,iy)
+          pftsoil(ixy,iz,4) = pwrf_grid%lotsic(ix,iz,iy)
+        END DO
+        DO iz=1,Nks
+          pqsurf(ixy,iz) = pwrf_grid%lqksoil(ix,iz,iy)
+        END DO
+        pqsol(ixy) = pwrf_grid%lwsol(ix,iy)
+        DO iz=1,Nks
+          pfalb1(ixy,iz) = pwrf_grid%lalbksoil(ix,iz,iy)
+          pfalb2(ixy,iz) = pwrf_grid%llwalbksoil(ix,iz,iy)
+          pevap(ixy,iz) = pwrf_grid%levapksoil(ix,iz,iy)
+          psnow(ixy,iz) = pwrf_grid%lsnowksoil(ix,iz,iy)
+        END DO
+! No way to get back the independent radiative values (unless using LMDZ 'hist*' 
+!   files). Use it in the LMDZ's added way also from grid (no need to initialize it,
+!   no radiation on t=0)
+        pradsol(ixy) = pwrf_grid%lrads(ix,iy)
+        psolsw(ixy) = pwrf_grid%lsolsw(ix,iy)
+        psollw(ixy) = pwrf_grid%lsollw(ix,iy)
+        pfder(ixy) = pwrf_grid%lfder(ix,iy)
+! LMDZ does not provide a way (in the restart) to distingusih between convective, 
+!    non-convective. Thus Use it as a whole
+        prain_fall(ixy) = pwrf_grid%lrain(ix,iy)
+        psnow_fall(ixy) = pwrf_grid%lsnow(ix,iy)
+        DO iz=1,Nks
+          prugos(ixy,iz) = pwrf_grid%lrugksoil(ix,iz,iy)
+          pagesno(ixy,iz) = pwrf_grid%lagesnoksoil(ix,iz,iy)
+        END DO
+        pzmea(ixy) = pwrf_grid%lzmea(ix,iy)
+        pzstd(ixy) = pwrf_grid%lzstd(ix,iy)
+        pzgam(ixy) = pwrf_grid%lzgam(ix,iy)
+        pzthe(ixy) = pwrf_grid%lzthe(ix,iy)
+        pzpic(ixy) = pwrf_grid%lzpic(ix,iy)
+        pzval(ixy) = pwrf_grid%lzval(ix,iy)
+        prugoro(ixy) = pwrf_grid%lzrugsrel(ix,iy)
+!        prugos(ixy,is_oce) = pwrf_grid%lrugsea(ix,iy)
+        prun_off_lic(ixy) = pwrf_grid%lrunofflic(ix,iy)
+        pzmax0(ixy) = pwrf_grid%lzmax0(ix,iy)
+        pf0(ixy) = pwrf_grid%lf0(ix,iy)
+        pwake_s(ixy) = pwrf_grid%lwake_s(ix,iy)
+        pwake_cstar(ixy) = pwrf_grid%lwake_cstar(ix,iy)
+        pwake_pe(ixy) = pwrf_grid%lwake_pe(ix,iy)
+        pwake_fip(ixy) = pwrf_grid%lwake_fip(ix,iy)
+!! limit.nc
+! nat == pctsrf, not needed ?
+        pnat(ixy) = pwrf_grid%lnat(ix,iy)
+        psst(ixy) = pwrf_grid%sst(ix,iy)
+! not used, not defined....
+!        pbils(ixy) = pwrf_grid%lbils(ix,iy)
+        palbedo(ixy) = pwrf_grid%albedo(ix,iy)
+! already done in previous steps
+!        prugos(ixy) = pwrf_grid%lrug(ix,iy)
+
+      END DO
+    END DO
+
+    dx=ddx+2*bdy
+    dy=ddy+2*bdy
+
+    CALL mat_vect(pwrf_grid%t_2, dx, dy, ddz, bdy, pt_ancien)
+! New variable added in the Registry qv_2
+    CALL mat_vect(pwrf_grid%qv_2, dx, dy, ddz, bdy, pq_ancien)
+    CALL mat_vect(pwrf_grid%u_2, dx, dy, ddz, bdy, pu_ancien)
+    CALL mat_vect(pwrf_grid%v_2, dx, dy, ddz, bdy, pv_ancien)
+    CALL mat_vect(pwrf_grid%lclwcon, dx, dy, ddz, bdy, pclwcon)
+    CALL mat_vect(pwrf_grid%lrnebcon, dx, dy, ddz, bdy, prnebcon)
+    CALL mat_vect(pwrf_grid%lratqs, dx, dy, ddz, bdy, pratqs)
+    CALL mat_vect(pwrf_grid%lema_work1, dx, dy, ddz, bdy, pema_work1)
+    CALL mat_vect(pwrf_grid%lema_work2, dx, dy, ddz, bdy, pema_work2)
+    CALL mat_vect(pwrf_grid%lwake_deltat, dx, dy, ddz, bdy, pwake_deltat)
+    CALL mat_vect(pwrf_grid%lwake_deltaq, dx, dy, ddz, bdy, pwake_deltaq)
+    CALL mat_vect(pwrf_grid%lfm_therm, dx, dy, ddz+1, bdy, pfm_therm)
+    CALL mat_vect(pwrf_grid%lentr_therm, dx, dy, ddz, bdy, pentr_therm)
+    CALL mat_vect(pwrf_grid%ldetr_therm, dx, dy, ddz, bdy, pdetr_therm)
+
+    RETURN
+
+  END SUBROUTINE load_lmdz
+
+  SUBROUTINE vect_mat(vect, dx, dy, dz, wbdy, mat)
+! Subroutine to transform a LMDZ physic 1D vector to a 3D matrix
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: dx, dy, dz, wbdy
+    REAL, DIMENSION((dx-2*wbdy)*(dy-2*wbdy),dz), INTENT(IN) :: vect
+    REAL, DIMENSION(1-wbdy:dx-wbdy+1,dz+1,1-wbdy:dy-wbdy+1), INTENT(OUT) :: mat
+
+! Local
+    INTEGER                                              :: i,j,k
+    INTEGER                                              :: ddx, ddy
+    INTEGER                                              :: lp, il, jl
+
+! Variables
+! d[x/y/z]: dimensions
+! mat: matrix to transform
+! vect: vector to produce
+    mat=0.
+
+    ddx=dx-2*wbdy
+    ddy=dy-2*wbdy
+!    lp=321
+!    jl=INT(lp/ddx)+1
+!    il=lp-ddx*(jl-1)
+
+    DO k=1,dz
+      DO j=1,ddy
+        DO i=1,ddx
+          mat(i,k,j)=vect(ddx*(j-1)+i,k)
+        END DO
+      END DO
+!      PRINT *,k,'  Lluis vect: ',vect(lp,k),mat(il,k,jl),' lp: ',lp,' il jl :',il,jl
+    END DO
+
+  END SUBROUTINE vect_mat
+
+
+  SUBROUTINE vect_mat_zstagg(vect, dx, dy, dz, wbdy, mat)
+! Subroutine to transform a LMDZ physic 1D vector to a 3D matrix
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: dx, dy, dz, wbdy
+    REAL, DIMENSION((dx-2*wbdy)*(dy-2*wbdy),dz), INTENT(IN) :: vect
+    REAL, DIMENSION(1-wbdy:dx-wbdy+1,dz,1-wbdy:dy-wbdy+1), INTENT(OUT) :: mat
+
+! Local
+    INTEGER                                              :: i,j,k
+    INTEGER                                              :: ddx, ddy
+
+! Variables
+! d[x/y/z]: dimensions
+! mat: matrix to transform
+! vect: vector to produce
+
+    ddx=dx-2*wbdy
+    ddy=dy-2*wbdy
+
+    mat=0.
+
+    DO k=1,dz
+      DO j=1,ddy
+        DO i=1,ddx
+          mat(i,k,j)=vect(ddx*(j-1)+i,k)
+        END DO
+      END DO
+    END DO
+
+  END SUBROUTINE vect_mat_zstagg
+
+
+  SUBROUTINE mat_vect(mat, dx, dy, dz, wbdy, vect)
+! Subroutine to transform a 3D matrix to a LMDZ physic 1D vector
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: dx, dy, dz, wbdy
+    REAL, DIMENSION(1-wbdy:dx-wbdy+1,dz+1,1-wbdy:dy-wbdy+1), INTENT(IN) :: mat
+    REAL, DIMENSION((dx-2*wbdy)*(dy-2*wbdy),dz), INTENT(OUT) ::                      &
+      vect
+
+! Local
+    INTEGER                                              :: i,j,k
+    INTEGER                                              :: ddx,ddy
+
+! Variables
+! d[x/y/z]: dimensions
+! mat: matrix to transform
+! vect: vector to produce
+
+! Removing HALO
+    ddx=dx-2*wbdy
+    ddy=dy-2*wbdy
+
+    vect=0.
+
+    DO k=1,dz
+      DO j=1,ddy
+        DO i=1,ddx
+          vect(ddx*(j-1)+i,k)= mat(i,k,j)
+        END DO
+      END DO
+    END DO
+
+  END SUBROUTINE mat_vect
+
+  SUBROUTINE mat_vect_zstagg(mat, dx, dy, dz, wbdy, vect)
+! Subroutine to transform a 3D matrix z-staggered to a LMDZ physic 1D vector
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: dx, dy, dz, wbdy
+    REAL, DIMENSION(1-wbdy:dx-wbdy+1,dz,1-wbdy:dy-wbdy+1), INTENT(IN) :: mat
+    REAL, DIMENSION((dx-2*wbdy)*(dy-2*wbdy),dz), INTENT(OUT) ::                      &
+      vect
+
+! Local
+    INTEGER                                              :: i,j,k
+    INTEGER                                              :: ddx,ddy
+
+! Variables
+! d[x/y/z]: dimensions
+! mat: matrix to transform
+! vect: vector to produce
+
+! Removing HALO
+    ddx=dx-2*wbdy
+    ddy=dy-2*wbdy
+
+    DO k=1,dz
+      DO j=1,ddy
+        DO i=1,ddx
+          vect(ddx*(j-1)+i,k)= mat(i,k,j)
+        END DO
+      END DO
+    END DO
+
+  END SUBROUTINE mat_vect_zstagg
+
+  SUBROUTINE WRFlanduse_LMDZKsoil(lndcn,is,ie,js,je,dx,dy,ncat,lndu,mask,kt,kl,ko,ks)
+! Subroutine to retrieve LMDZ Ksoil classification using WRF landuse
+
+    IMPLICIT NONE
+
+    CHARACTER(LEN=50), INTENT(IN)                        :: lndcn
+    INTEGER, INTENT(IN)                                  :: is,ie,js,je,dx,dy,ncat
+    REAL, DIMENSION(is:ie,ncat,js:je), INTENT(IN)        :: lndu
+    REAL, DIMENSION(is:ie,js:je), INTENT(IN)             :: mask
+    REAL, DIMENSION(is:ie,js:je), INTENT(OUT)            :: kt,kl,ko,ks
+
+! Local
+    INTEGER                                              :: i,j,k,ij,Nnones,Ncattot
+    CHARACTER(LEN=50)                                    :: fname, errmsg, wrnmsg
+    REAL, DIMENSION(is:ie,js:je)                         :: totlndu
+    INTEGER, ALLOCATABLE, DIMENSION(:)                   :: ter_wk, lic_wk, oce_wk,  &
+      sic_wk
+    LOGICAL, ALLOCATABLE, DIMENSION(:,:)                 :: wk
+    INTEGER                                              :: Nter_wk, Nlic_wk,        &
+        Noce_wk, Nsic_wk, klks_equal
+    REAL*8, DIMENSION(is:ie,js:je)                       :: Ksoilval
+
+
+!!!!!!!! Variables
+! lndcn: land-use data-set (same as in VEGPARM.TBL)
+! dx,dy: horizontal dimension of the domain
+! ncat: number of categories of the data-set
+! lndu: WRF landuse matrix
+! mask: land-sea mask from WRF
+! k[t/l/o/s]: LMDZ ter, lic, oce, sic matrices
+! Ncattot: theoretical number of laduses for a given data-base
+! [ter/lic/oce/sic]_wk: vectors with the indices of the landuse for LMDZ Ksoil
+! N[ter/lic/oce/sic]_wk: number of indices of the landuse for LMDZ Ksoil
+! wk: boolean matrix for each Ksoil indicating 'true' if the WRF landuse is for Ksoil
+
+    fname="'WRFlanduse_LMDZKsoil'"
+    errmsg='ERROR -- error -- ERROR -- error'
+    wrnmsg='WARNING -- warning -- WARNING -- warning'
+    
+! Checking if at all the grid points SUM(landuse) == 1.
+!! 
+    PRINT *,'  ' // TRIM(fname) // " using '" // TRIM(lndcn) // "' WRF land types"
+
+    totlndu = SUM(lndu, 2)
+
+    Nnones=0
+    DO i=1,dx
+      DO j=1,dy
+        IF (totlndu(i,j) /= 1. ) Nnones = Nnones+1
+      END DO
+    END DO
+
+    IF (Nnones /= 0) THEN
+      PRINT *,TRIM(errmsg)
+      PRINT *,'    ' // TRIM(fname) // ': ', Nnones,' grid points do not have a ' // &
+        'TOTlanduse == 1. from WRF !!!!!'
+      DO i=1,dx
+        DO j=1,dy
+          IF (totlndu(i,j) /= 1.) PRINT *,'      ',i,', ',j,' total land use: ',     &
+            totlndu(i,j),' indiv. values :', lndu(i,:,j)
+        END DO
+      END DO
+    END IF
+
+    SELECT CASE (lndcn)
+      CASE ('OLD')
+        Ncattot = 13
+        Nter_wk = 11
+        Nlic_wk = 1
+        Noce_wk = 1
+        Nsic_wk = 1
+
+        IF (ALLOCATED(ter_wk)) DEALLOCATE(ter_wk)
+        ALLOCATE(ter_wk(Nter_wk))
+        IF (ALLOCATED(lic_wk)) DEALLOCATE(lic_wk)
+        ALLOCATE(lic_wk(Nlic_wk))
+        IF (ALLOCATED(oce_wk)) DEALLOCATE(oce_wk)
+        ALLOCATE(oce_wk(Noce_wk))
+        IF (ALLOCATED(sic_wk)) DEALLOCATE(sic_wk)
+        ALLOCATE(sic_wk(Nsic_wk))
+
+! It could be done much more 'elegantly' ... reading values from LANDUSE.TBL (v3.3)
+!!
+!  1,'Urban land'                    2,'Agriculture'
+!  3,'Range-grassland'               4,'Deciduous forest'
+!  5,'Coniferous forest'             6,'Mixed forest and wet land'
+!  7,'Water'                         8,'Marsh or wet land'
+!  9,'Desert'                       10,'Tundra'
+! 11,'Permanent ice'                12,'Tropical or subtropical forest'
+! 13,'Savannah'
+
+        ter_wk = (/ 1,2,3,4,5,6,8,9,10,12,13 /)
+        lic_wk = (/ 11 /)
+        oce_wk = (/ 7 /)
+        sic_wk = (/ 11 /)
+
+      CASE ('USGS')
+        Ncattot = 33
+        Nter_wk = 22
+        Nlic_wk = 1
+        Noce_wk = 1
+        Nsic_wk = 1
+
+        IF (ALLOCATED(ter_wk)) DEALLOCATE(ter_wk)
+        ALLOCATE(ter_wk(Nter_wk))
+        IF (ALLOCATED(lic_wk)) DEALLOCATE(lic_wk)
+        ALLOCATE(lic_wk(Nlic_wk))
+        IF (ALLOCATED(oce_wk)) DEALLOCATE(oce_wk)
+        ALLOCATE(oce_wk(Noce_wk))
+        IF (ALLOCATED(sic_wk)) DEALLOCATE(sic_wk)
+        ALLOCATE(sic_wk(Nsic_wk))
+
+! It could be done much more 'elegantly' ... reading values from LANDUSE.TBL (v3.3)
+!!
+! 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'                    28,'Unassigned'
+!29,'Unassigned'                    30,'Unassigned'
+!31,'Low Intensity Residential '    32,'High Intensity Residential'
+!33,'Industrial or Commercial'      
+
+! Correct values
+!        ter_wk = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,17,18,19,20,21,22,23,25,26,  &
+!          27,31,32,33 /)
+! How ever, USGS by default has 24 so...
+        ter_wk = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,17,18,19,20,21,22,23 /)
+        lic_wk = (/ 24 /)
+        oce_wk = (/ 16 /)
+        sic_wk = (/ 24 /)
+
+      CASE ('MODIFIED_IGBP_MODIS_NOAH')
+        Ncattot = 33
+        Nter_wk = 28
+        Nlic_wk = 1
+        Noce_wk = 1
+        Nsic_wk = 1
+
+        IF (ALLOCATED(ter_wk)) DEALLOCATE(ter_wk)
+        ALLOCATE(ter_wk(Nter_wk))
+        IF (ALLOCATED(lic_wk)) DEALLOCATE(lic_wk)
+        ALLOCATE(lic_wk(Nlic_wk))
+        IF (ALLOCATED(oce_wk)) DEALLOCATE(oce_wk)
+        ALLOCATE(oce_wk(Noce_wk))
+        IF (ALLOCATED(sic_wk)) DEALLOCATE(sic_wk)
+        ALLOCATE(sic_wk(Nsic_wk))
+
+! It could be done much more 'elegantly' ... reading values from LANDUSE.TBL (v3.3)
+!!
+!  1,'Evergreen Needleleaf Forest'             2,'Evergreen Broadleaf Forest'
+!  3,'Deciduous Needleleaf Forest'             4,'Deciduous Broadleaf Forest'
+!  5,'Mixed Forests'                           6,'Closed Shrublands'
+!  7,'Open Shrublands'                         8,'Woody Savannas'
+!  9,'Savannas'                               10,'Grasslands'
+! 11,'Permanent wetlands'                     12,'Croplands'
+! 13,'Urban and Built-Up'                     14,'cropland/natural vegetation mosaic'
+! 15,'Snow and Ice'                           16,'Barren or Sparsely Vegetated'
+! 17,'Water'                                  18,'Wooded Tundra'
+! 19,'Mixed Tundra'                           20,'Barren Tundra'
+! 21,'Unassigned'                             22,'Unassigned'
+! 23,'Unassigned'                             24,'Unassigned'
+! 25,'Unassigned'                             26,'Unassigned'
+! 27,'Unassigned'                             28,'Unassigned'
+! 29,'Unassigned'                             30,'Unassigned'
+! 31,'Low Intensity Residential '             32,'High Intensity Residential'
+! 33,'Industrial or Commercial'
+
+        ter_wk = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,16,18,19,20,31,32,33 /)
+        lic_wk = (/ 15 /)
+        oce_wk = (/ 17 /)
+        sic_wk = (/ 15 /)
+
+      CASE ('SiB')
+        Ncattot = 16
+        Nter_wk = 14
+        Nlic_wk = 1
+        Noce_wk = 1
+        Nsic_wk = 1
+
+        IF (ALLOCATED(ter_wk)) DEALLOCATE(ter_wk)
+        ALLOCATE(ter_wk(Nter_wk))
+        IF (ALLOCATED(lic_wk)) DEALLOCATE(lic_wk)
+        ALLOCATE(lic_wk(Nlic_wk))
+        IF (ALLOCATED(oce_wk)) DEALLOCATE(oce_wk)
+        ALLOCATE(oce_wk(Noce_wk))
+        IF (ALLOCATED(sic_wk)) DEALLOCATE(sic_wk)
+        ALLOCATE(sic_wk(Nsic_wk))
+
+! It could be done much more 'elegantly' ... reading values from LANDUSE.TBL (v3.3)
+!!
+!  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,'Groundcover Only'              8,'Broadleaf Shrubs with Perennial Ground Cover'
+!  9,'Broadleaf Shrubs 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'
+
+        ter_wk = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14 /)
+        lic_wk = (/ 16 /)
+        oce_wk = (/ 15 /)
+        sic_wk = (/ 16 /)
+
+      CASE ('LW12')
+        Ncattot = 3
+        Nter_wk = 1
+        Nlic_wk = 1
+        Noce_wk = 1
+        Nsic_wk = 1
+
+        IF (ALLOCATED(ter_wk)) DEALLOCATE(ter_wk)
+        ALLOCATE(ter_wk(Nter_wk))
+        IF (ALLOCATED(lic_wk)) DEALLOCATE(lic_wk)
+        ALLOCATE(lic_wk(Nlic_wk))
+        IF (ALLOCATED(oce_wk)) DEALLOCATE(oce_wk)
+        ALLOCATE(oce_wk(Noce_wk))
+        IF (ALLOCATED(sic_wk)) DEALLOCATE(sic_wk)
+        ALLOCATE(sic_wk(Nsic_wk))
+
+! It could be done much more 'elegantly' ... reading values from LANDUSE.TBL (v3.3)
+!!
+!  1,'Land'                              2,'Water'
+!  3,'Snow or Ice'
+
+        ter_wk = (/ 1 /)
+        lic_wk = (/ 3 /)
+        oce_wk = (/ 2 /)
+        sic_wk = (/ 3 /)
+
+      CASE DEFAULT
+        PRINT *,TRIM(errmsg)
+        PRINT *,'  ' // TRIM(fname) // ": landuse data-base '" // TRIM(lndcn) //     &
+          "' not ready !!!"
+        STOP
+
+    END SELECT
+
+! Checking the correct number of categories
+    IF (Ncattot /= ncat) THEN
+      PRINT *,TRIM(wrnmsg)
+      PRINT *,'  ' // TRIM(fname) // ": '" // TRIM(lndcn) // "' landuse data-base "  &
+        // ' has ',Ncattot,' land-uses types ',ncat,' passed !!!!'
+!      STOP
+    END IF
+
+! Mimic WRF landuse with 4 LMDZ Ksoils
+!!
+    IF (ALLOCATED(wk)) DEALLOCATE(wk)
+!    ALLOCATE(wk(4,ncattot))
+    ALLOCATE(wk(4,ncat))
+
+    wk = .FALSE.
+
+    DO i=1,Nter_wk
+      wk(1,ter_wk(i)) = .TRUE.
+    END DO
+    DO i=1,Nlic_wk
+      wk(2,lic_wk(i)) = .TRUE.
+    END DO
+    DO i=1,Noce_wk
+      wk(3,oce_wk(i)) = .TRUE.
+    END DO
+    DO i=1,Nsic_wk
+      wk(4,sic_wk(i)) = .TRUE.
+    END DO
+
+    klks_equal = 0
+    DO i=1,dx
+      DO j=1,dy
+! Using double precission numbers to avoid truncation errors...        
+        Ksoilval(1,1) = SUM(lndu(i,:,j),MASK=wk(1,:))
+        kt(i,j) = Ksoilval(1,1)
+        Ksoilval(1,1) = SUM(lndu(i,:,j),MASK=wk(2,:))
+        kl(i,j) = Ksoilval(1,1)
+        Ksoilval(1,1) = SUM(lndu(i,:,j),MASK=wk(3,:))
+        ko(i,j) = Ksoilval(1,1)
+        Ksoilval(1,1) = SUM(lndu(i,:,j),MASK=wk(4,:))
+        ks(i,j) = Ksoilval(1,1)
+
+        IF (kl(i,j) == ks(i,j)) klks_equal = klks_equal+1
+      END DO
+    END DO
+
+! Assigning lic/sic to all that ice/snow according to the percentage of ter/oce
+!   Is there any other better way? Satellites, do not know what is below the ice ?!
+
+    IF (klks_equal == dx*dy) THEN
+!   Assuming that kl=ks=ice 
+      DO i=1,dx
+        DO j=1,dy
+          IF ((kt(i,j)+ko(i,j)) /= 0.) THEN
+            Ksoilval(1,1) = kl(i,j)*kt(i,j)/(kt(i,j)+ko(i,j))
+            kl(i,j) = Ksoilval(1,1)
+            Ksoilval(1,1) = ks(i,j)*ko(i,j)/(kt(i,j)+ko(i,j))
+            ks(i,j) = Ksoilval(1,1)
+          ELSE
+            Ksoilval(1,1) = kl(i,j)/(kl(i,j)+ks(i,j))
+            Ksoilval(1,2) = ks(i,j)/(kl(i,j)+ks(i,j))
+            kl(i,j) = Ksoilval(1,1)
+            ks(i,j) = Ksoilval(1,2)
+          END IF
+! Introducing WRF land-sea mask
+          IF (mask(i,j) == 1.) THEN
+            kl(i,j)=kl(i,j)+ks(i,j)
+            ks(i,j)=0.
+          ELSE
+            ks(i,j)=kl(i,j)+ks(i,j)
+            kl(i,j)=0.
+          END IF
+        END DO
+      END DO
+    ELSE
+      PRINT *,'  ' // TRIM(fname) // ': land-use data provided different lic & sic !'
+    END IF
+
+! Checking if at all the grid points kt+kl+ko+ks == 1.
+!! 
+    totlndu = kt+kl+ko+ks
+
+    Nnones=0
+    DO i=1,dx
+      DO j=1,dy
+        IF (totlndu(i,j) /= 1. ) Nnones = Nnones+1
+        IF (kt(i,j) + ko(i,j) == 0.)THEN
+          PRINT *,TRIM(wrnmsg)
+          PRINT *,'  ' // TRIM(fname) // ': point without land or water category !!'
+          PRINT *,'i j WRF_ter ter ______________'
+          DO k=1,Nter_wk
+            PRINT *,i,j,lndu(i,ter_wk(k),j), kt(i,j)
+          END DO
+          PRINT *,'i j WRF_oce oce ______________'
+          DO k=1,Noce_wk
+            PRINT *,i,j,lndu(i,oce_wk(k),j), ko(i,j)
+          END DO
+          PRINT *,'  wrf%landusef: ', lndu(i,:,j)
+!          STOP
+        END IF
+      END DO
+    END DO
+
+    ij=1
+    IF (Nnones /= 0) THEN
+      PRINT *,TRIM(errmsg)
+      PRINT *,'  ' // TRIM(fname) // ': ', Nnones,' grid points do not have a ' //   &
+        'TOTlanduse == 1.!!!!!'
+      PRINT *,'pt i j ter+lic+oce+sic : ter lic oce sic ______________'
+      DO i=1,dx
+        DO j=1,dy
+          IF (totlndu(i,j) /= 1.) THEN
+            PRINT *,ij,'; ',i,j,totlndu(i,j),' : ',kt(i,j),kl(i,j),ko(i,j),ks(i,j)
+            ij=ij+1
+          END IF
+        END DO
+      END DO
+    END IF
+
+    DEALLOCATE(ter_wk)
+    DEALLOCATE(lic_wk)
+    DEALLOCATE(oce_wk)
+    DEALLOCATE(sic_wk)
+    DEALLOCATE(wk)
+
+    RETURN
+
+  END SUBROUTINE WRFlanduse_LMDZKsoil
+
+  SUBROUTINE interpolate_layers(NvalsA,posA,valsA,NvalsB,posB,valsB)
+! Subroutine to interpolate values between different layers (constant values along the depth of a layer)
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: NvalsA,NvalsB
+    REAL, DIMENSION(NvalsA), INTENT(IN)                  :: posA,valsA
+    REAL, DIMENSION(NvalsB), INTENT(IN)                  :: posB
+    REAL, DIMENSION(NvalsB), INTENT(OUT)                 :: valsB
+
+! Local
+    INTEGER                                              :: i,k
+    REAL                                                 :: xA,yA,xB,yB
+
+!!!!!!! Variables
+! A: original values used to interpolate
+! B: values to obtain
+! Nvals[A/B]: number of values
+! pos[A/B]: depths of each layer
+! vals[A/B]: values of each layer
+
+!!!!!!! Functions/Subroutines
+! interpolate_lin: subroutine to linearly interpolate
+
+    i=1
+    DO k=1,NvalsB
+      IF (posB(k) > posA(i)) i = i+1
+      IF (i-1 < 1) THEN
+        xA = posA(i)
+        yA = valsA(i)
+        xB = posA(i+1)
+        yB = valsA(i+1)
+      ELSEIF ( i > NvalsA) THEN
+        xA = posA(i-2)
+        yA = valsA(i-2)
+        xB = posA(i-1)
+        yB = valsA(i-1)
+      ELSE
+        xA = posA(i-1)
+        yA = valsA(i-1)
+        xB = posA(i)
+        yB = valsA(i)
+      END IF
+      IF (posB(k) <= xB .AND. i-1 > 1) THEN
+        CALL interpolate_lin(xA,yA,xB,yB,posB(k),valsB(k))
+      ELSEIF (posB(k) <= xA .AND. i-1 < 1) THEN
+        valsB(k) = yA + (yB - yA)*(posB(k) - xA)/(xB - xA)
+      ELSE
+        valsB(k) = yB + (yB - yA)*(posB(k) - xB)/(xB - xA)
+      END IF
+!      PRINT *,'i ',i,'  Interpolating for: ',posB(k),' with xA: ', xA,' yA: ',yA,' & ',   &
+!       ' xB: ', xB,' yB: ',yB,' --> ',valsB(k)
+    END DO
+
+  END SUBROUTINE interpolate_layers
+
+  SUBROUTINE interpolate_lin(x1,y1,x2,y2,x0,y)
+! Program to interpolate values y=a+b*x with: (from clWRF modifications)
+!       a=y1
+!       b=(y2-y1)/(x2-x1)
+!       x=(x2-x0)
+
+    IMPLICIT NONE
+
+    REAL, INTENT (IN)                                    :: x1,x2,x0
+!    REAL(r8), INTENT (IN)                                :: y1,y2
+!    REAL(r8), INTENT (OUT)                               :: y
+!    REAL(r8)                                             :: a,b,x
+    REAL, INTENT (IN)                                   :: y1,y2
+    REAL, INTENT (OUT)                                  :: y
+    REAL                                                :: a,b,x
+
+    a=y1
+    b=(y2-y1)/(x2-x1)
+
+    IF (x0 .GE. x1) THEN
+      x=x0-x1
+    ELSE
+      x=x1-x0
+      b=-b
+    ENDIF
+
+    y=a+b*x
+    
+!    PRINT *,'y=a+b*x'
+!    IF (b .LT. 0.) THEN
+!      PRINT *,'y=',y1,' ',b,'*x'
+!    ELSE
+!      PRINT *,'y=',y1,'+',b,'*x'
+!    ENDIF
+!    PRINT *,'y(',x,')=',y
+
+  END SUBROUTINE interpolate_lin
+
+  SUBROUTINE table_characteristics(datasetn,tablen,datasetline,Nvar,Nr,Nc)
+! Subroutine to read values from a WRF .TBL
+
+    IMPLICIT NONE
+
+    CHARACTER(LEN=50), INTENT(IN)                        :: datasetn
+    CHARACTER(LEN=100), INTENT(IN)                       :: tablen
+    INTEGER, INTENT(OUT)                                 :: datasetline, Nvar, Nr, Nc
+
+! Local
+    INTEGER                                              :: il, iline, ic
+    CHARACTER(LEN=50)                                    :: fname, errmsg
+    CHARACTER(LEN=200)                                   :: lineval
+    LOGICAL                                              :: existsfile, is_used
+    INTEGER                                              :: funit, Llineval, icoma
+
+!!!!!! Variables
+! datasetn: name of the data set to use
+! tablen: name of the table to read
+! Nvar: number of variations (g.e. seasons)
+! Nr: table row number 
+! Nc: table column number
+! datasetline: line in the table where the dataset starts
+
+    fname='table_characteristics'
+    errmsg='ERROR -- error -- ERROR -- error'
+
+    INQUIRE(FILE=TRIM(tablen), EXIST=existsfile)
+
+    IF (existsfile) THEN
+      DO funit=10,100
+        INQUIRE(UNIT=funit, OPENED=is_used)
+        IF (.NOT. is_used) EXIT
+      END DO
+
+    ELSE 
+      PRINT *,TRIM(errmsg)
+      PRINT *,TRIM(fname),': file "'// TRIM(tablen) // '" does not exist !!!'
+      STOP
+    END IF
+
+    OPEN(UNIT=funit, FILE=TRIM(tablen), STATUS='OLD')
+
+! Looking for the place where data-set starts
+!!
+    datasetline = -1
+    iline=1
+    DO il=1,100000
+      READ(funit,*,END=100)lineval
+      IF (TRIM(lineval) == TRIM(datasetn)) datasetline = il
+    END DO
+
+100 CONTINUE
+    IF (datasetline == -1) THEN
+      PRINT *,TRIM(errmsg)
+      PRINT *,TRIM(fname),': in file "'// TRIM(tablen) // '" dataset: "'//           &
+        TRIM(datasetn) // '" does not exist !!!'
+      STOP
+    END IF
+
+! Looking for number of values
+!!
+    REWIND(UNIT=funit)
+    DO ic=1,datasetline
+      READ(funit,*)lineval
+    END DO
+    READ(funit,*)Nr,Nvar
+
+    IF (Nvar > 1) READ(funit,*)lineval
+
+    READ(funit,'(200A)')lineval
+    Llineval=LEN(TRIM(lineval))
+
+!    PRINT *,'  lineval: ******' // TRIM(lineval) // '******', Llineval
+
+    Nc = 0
+    ic = 1
+    DO WHILE (ic <= Llineval)
+!      PRINT *,lineval(ic:Llineval)
+      icoma = SCAN(lineval(ic:Llineval),',')
+      IF (icoma > 1) THEN
+        Nc = Nc + 1
+!        PRINT *,'  Nc: ',Nc,' ic ',ic,' icoma: ',icoma
+      ic = ic + icoma
+      ELSE
+        ic = ic + Llineval
+      END IF
+    END DO
+    PRINT *,'  dataset :"' // TRIM(datasetn) // '" at line ',datasetline,            &
+      ' in table :"'// TRIM(tablen) // '" has N variations: ',Nvar,                  &
+      ' Number of types: ',Nr, ' Number of values: ',Nc
+
+    CLOSE(funit)
+
+    RETURN
+
+  END SUBROUTINE table_characteristics
+
+  SUBROUTINE read_table(datasetn,tablen,datasetline,Nvar,Nr,Nc,vals,valns)
+! Subroutine to read values from a WRF .TBL
+
+    IMPLICIT NONE
+
+    CHARACTER(LEN=50), INTENT(IN)                        :: datasetn
+    CHARACTER(LEN=100), INTENT(IN)                       :: tablen
+    INTEGER, INTENT(IN)                                  :: datasetline, Nvar, Nr, Nc
+    REAL, DIMENSION(Nvar,Nr,Nc), INTENT(OUT)             :: vals
+    CHARACTER(LEN=50), DIMENSION(Nr), INTENT(OUT)        :: valns
+
+
+! Local
+    INTEGER                                              :: iv, ir, ic
+    CHARACTER(LEN=50)                                    :: fname, errmsg, line
+    LOGICAL                                              :: existsfile, is_used
+    INTEGER                                              :: funit
+
+!!!!!!! Variables
+! datasetn: name of the data set to use
+! tablen: name of the table to read
+! Nvar: number of variations (g.e. seasons)
+! Nr: table row number 
+! Nc: table column number
+! datasetline: line in the table where the dataset starts
+! vals: values of the data-set
+! valns: assigned name of each value in the dataset
+
+    fname='read_table'
+    errmsg='ERROR -- error -- ERROR -- error'
+
+    INQUIRE(FILE=TRIM(tablen), EXIST=existsfile)
+
+    IF (existsfile) THEN
+      DO funit=10,100
+        INQUIRE(UNIT=funit, OPENED=is_used)
+        IF (.NOT. is_used) EXIT
+      END DO
+
+    ELSE 
+      PRINT *,TRIM(errmsg)
+        PRINT *,TRIM(fname),': file "'// TRIM(tablen) // '" does not exist !!!'
+        STOP
+    END IF
+
+    OPEN(UNIT=funit, FILE=TRIM(tablen), STATUS='OLD')
+
+    DO ic=1,datasetline+1
+      READ(funit,*)line
+    END DO
+
+    DO iv=1, Nvar
+      IF (Nvar > 1) READ(funit,*)line
+      DO ir=1, Nr
+        READ(funit,*)(vals(iv,ir,ic), ic=1,Nc),valns(ir)
+      END DO
+    END DO
+
+!    PRINT *,'  values dataset :"' // TRIM(datasetn) // '" in table :"' //TRIM(tablen)
+!    DO iv=1,Nvar
+!      PRINT *,'   variation: ',iv
+!      DO ir=1,Nr
+!        PRINT *,'    ',(vals(iv,ir,ic), ic=1,Nc),valns(ir)
+!      END DO
+!    END DO
+
+    CLOSE(funit)
+
+    RETURN
+
+  END SUBROUTINE read_table
+
+
+  SUBROUTINE compute_soil_mass(Nvar,Nr,Nc,vals,valns,soilt,Nnost,NOsoilt,smois,ddx,  &
+    ddy,ddz,soilm,soilq)
+! Subroutine to compute the total soil mass (kg) from a point with different 
+!   percentages of soil types
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: Nvar, Nr, Nc, Nnost
+    REAL, DIMENSION(Nvar,Nr,Nc), INTENT(IN)              :: vals
+    CHARACTER(LEN=50), DIMENSION(Nr), INTENT(IN)         :: valns
+    REAL, DIMENSION(Nr), INTENT(IN)                      :: soilt
+    CHARACTER(LEN=50), DIMENSION(Nnost), INTENT(IN)      :: NOsoilt
+    REAL, INTENT(IN)                                     :: smois, ddx, ddy, ddz
+    REAL, INTENT(OUT)                                    :: soilm,soilq
+
+! Local
+    INTEGER                                              :: iv, ir, ic
+    CHARACTER(LEN=50)                                    :: fname, errmsg
+    LOGICAL                                              :: is_land
+
+!!!!!!! Variables
+! Nvar: number of variations (g.e. seasons)
+! Nr: table row number 
+! Nc: table column number
+! vals: values of the data-set (col2: density [g cm-3])
+! valns: assigned name of each value in the dataset
+! soilt: vector with the percentages of soil types
+! Nnost: number of soil types which are not land
+! NOsoilt: labels of the non-land soil types
+! smois: soil moisture [m3 m-3]
+! ddx,ddy,ddz: volume of the grid cell [m]
+! soilm: total soil mass [kg] 
+! soilq: total soil water [kg kg-1]
+
+    fname='read_table'
+    errmsg='ERROR -- error -- ERROR -- error'
+
+    soilm = 0.
+    soilq = 0.
+
+!    PRINT *,'  soilmoisture: ',smois
+    DO ir=1,Nr
+      is_land = .TRUE.
+      IF (soilt(ir) /= 0.) THEN
+        DO iv=1, Nnost
+          IF (TRIM(valns(ir)) == TRIM(NOsoilt(iv))) is_land = .FALSE.
+        END DO
+        IF (is_land) THEN
+!          PRINT *,'  soil moisture range: ', vals(1,ir,3), vals(1,ir,5) 
+          soilm = soilm + soilt(ir)*vals(1,ir,2)*ddx*ddy*ddz*1000. 
+          soilq = soilq + soilt(ir)*vals(1,ir,2)*smois*ddx*ddy*ddz*1000. 
+!          PRINT *,'  Percentage of soil "' // TRIM(valns(ir)) //'": ',soilt(ir)*100.,&
+!            ' % density: ',vals(1,ir,2),' partial mass: ',                           &
+!            soilt(ir)*vals(1,ir,2)*ddx*ddy*ddz*1000. , ' partial water: ',           &
+!            soilt(ir)*vals(1,ir,2)*smois*ddx*ddy*ddz*1000. 
+        END IF
+      END IF
+    END DO
+! Remember 1 kg H20 = 1 l = 1mm / m2
+!!  PRINT *,'  TOTAL. soil mass: ',soilm,' [kg] soil water: ',soilq,' [kg]',           &
+!!    ' equiv. water depth in soil ',soilq/(ddx*ddy*1000.),' [m]'
+
+  END SUBROUTINE compute_soil_mass
+
+  SUBROUTINE compute_TOTsoil_mass_water(datname, tabname, Nsoiltypes, soiltypest,    &
+    soiltypesb, Nsoillayers, smois, soillayers, sizeX, sizeY, soilTOTmass,           &
+    soilTOThumidity)
+! Subroutine to compute total soil mass and water from a given grid point using a 
+!   given data-set from SOILPARM.TBL
+
+      IMPLICIT NONE
+
+      CHARACTER(LEN=50), INTENT(IN)                      :: datname
+      CHARACTER(LEN=100), INTENT(IN)                     :: tabname
+      INTEGER, INTENT(IN)                                :: Nsoiltypes, Nsoillayers
+      REAL, DIMENSION(Nsoiltypes), INTENT(IN)            :: soiltypest, soiltypesb
+      REAL, DIMENSION(Nsoillayers), INTENT(IN)           :: smois, soillayers
+      REAL, INTENT(IN)                                   :: sizeX, sizeY
+      REAL, INTENT(OUT)                                  :: soilTOTmass,             &
+         soilTOThumidity
+
+! Local
+      INTEGER                                            :: ix,iy,iz
+      REAL, ALLOCATABLE, DIMENSION(:,:,:)                :: values
+      CHARACTER(LEN=50), ALLOCATABLE, DIMENSION(:)       :: namevalues,NOsoiltypes
+      INTEGER                                            :: linedataset,Nvariations, &
+        Nrows, Ncols
+      INTEGER                                            :: NNOsoiltypes
+      REAL, ALLOCATABLE, DIMENSION(:)                    :: soiltypes
+      REAL                                               :: dz,soilmass,soilhumidity
+      CHARACTER(LEN=50)                                  :: fname, errmsg
+
+!!!!!!! Variables
+! datname: name of the data set to use
+! tabname: name of the table to read
+! values: mmatrix with the name of the values: variation (Nvariations, g.e. seasons), 
+!   table row (Nrows),  table column (Ncols)
+! linedataset: line inside data-set where values start
+! namevalues: string assigned to each table row
+! Nsoiltypes: number of soil types
+! soiltypes[t/b]: percentage of the soil types at a given grid point on top/bottom
+! soiltypes: percentage of the soil types at a given grid point (lineray interpolated)
+! NOsoiltypes: vector with the names of soil types which are not land
+
+      fname='"compute_TOTsoil_mass_water"'
+      errmsg='ERROR -- error -- ERROR -- error'
+
+      CALL table_characteristics(datname, tabname, linedataset, Nvariations,         &
+        Nrows, Ncols)
+
+      IF (Nrows /= Nsoiltypes) THEN
+        PRINT *,errmsg
+        PRINT '  ' // TRIM(fname) // ': Number of soil-types: ',Nsoiltypes,          &
+          ' does not concide with the number of values: ', Nrows,                    &
+          ' from the data-set "' // TRIM(datname) // '" !!!'
+        STOP
+      END IF
+
+      IF (ALLOCATED(values)) DEALLOCATE(values)
+      ALLOCATE(values(Nvariations,Nrows,Ncols))
+
+      IF (ALLOCATED(namevalues)) DEALLOCATE(namevalues)
+      ALLOCATE(namevalues(Nrows))
+
+      CALL read_table(datname, tabname, linedataset, Nvariations, Nrows, Ncols,      &
+        values, namevalues)
+
+      IF (ALLOCATED(soiltypes)) DEALLOCATE(soiltypes)
+      ALLOCATE(soiltypes(Nrows))
+
+! On WRF3.3 SOILPARM.TBL
+      SELECT CASE (TRIM(datname))
+
+        CASE ('STAS')
+          NNOsoiltypes = 1
+          IF (ALLOCATED(NOsoiltypes)) DEALLOCATE(NOsoiltypes)
+          ALLOCATE(NOsoiltypes(NNOsoiltypes))
+
+          NOsoiltypes=(/ 'WATER' /)
+        CASE ('STAS-RUC')
+          NNOsoiltypes = 1
+          IF (ALLOCATED(NOsoiltypes)) DEALLOCATE(NOsoiltypes)
+          ALLOCATE(NOsoiltypes( NNOsoiltypes))
+
+          NOsoiltypes=(/ 'WATER' /)
+      END SELECT
+
+      soilTOTmass = 0.
+      soilTOThumidity = 0.
+
+      DO iz=1,Nsoillayers
+        IF (iz == 1 ) THEN
+          dz = soillayers(iz)
+        ELSE
+          dz = soillayers(iz) - soillayers(iz - 1)
+        END IF
+        IF (( iz > 1) .AND. (iz < Nsoillayers)) THEN
+          DO ix=1,Nrows
+            CALL interpolate_lin(soillayers(1), soiltypest(ix),                      &
+              soillayers(Nsoillayers), soiltypesb(ix), soillayers(iz), soiltypes(ix))
+          END DO
+        ELSEIF (iz == 1) THEN
+          soiltypes = soiltypest
+        ELSE
+          soiltypes = soiltypesb
+        END IF
+!        PRINT *,'lev: ',iz,' dz: ',dz,' soil types: ' ,soiltypes
+
+        CALL compute_soil_mass(Nvariations,Nrows,Ncols,values,namevalues,soiltypes,  &
+          NNOsoiltypes,NOsoiltypes,smois(iz),1.,1.,dz,soilmass,soilhumidity)
+        soilTOTmass = soilTOTmass + soilmass
+        soilTOThumidity = soilTOThumidity + soilhumidity
+      END DO
+
+      DEALLOCATE(values)
+      DEALLOCATE(namevalues)
+      DEALLOCATE(soiltypes)
+      DEALLOCATE(NOsoiltypes)
+
+  END SUBROUTINE compute_TOTsoil_mass_water
+
+  SUBROUTINE compute_TOTsoil_mass_water_values(datname, Nvariations, Nrows, Ncols,   &
+    values, namevalues, ip, jp, Nsoiltypes, soiltypest, soiltypesb, Nsoillayers,     &
+    smois, soillayers, sizeX, sizeY, soilTOTmass, soilTOThumidity)
+! Subroutine to compute total soil mass and water from a given grid point using the 
+!   values from a given data-set of SOILPARM.TBL
+
+      IMPLICIT NONE
+
+      CHARACTER(LEN=50), INTENT(IN)                      :: datname
+      INTEGER, INTENT(IN)                                :: Nvariations, Nrows, Ncols
+      REAL, DIMENSION(Nvariations, Nrows, Ncols), INTENT(IN) :: values
+      CHARACTER(LEN=50), DIMENSION(Nrows), INTENT(IN)    :: namevalues
+      INTEGER, INTENT(IN)                                :: ip, jp
+      INTEGER, INTENT(IN)                                :: Nsoiltypes, Nsoillayers
+      REAL, DIMENSION(Nsoiltypes), INTENT(IN)            :: soiltypest, soiltypesb
+      REAL, DIMENSION(Nsoillayers), INTENT(IN)           :: smois, soillayers
+      REAL, INTENT(IN)                                   :: sizeX, sizeY
+      REAL, INTENT(OUT)                                  :: soilTOTmass,             &
+         soilTOThumidity
+
+! Local
+      INTEGER                                            :: ix,iy,iz
+      CHARACTER(LEN=50), ALLOCATABLE, DIMENSION(:)       :: NOsoiltypes
+      INTEGER                                            :: linedataset
+      INTEGER                                            :: NNOsoiltypes
+      REAL, ALLOCATABLE, DIMENSION(:)                    :: soiltypes
+      REAL                                               :: dz,soilmass,soilhumidity
+      CHARACTER(LEN=50)                                  :: fname, errmsg
+
+!!!!!!! Variables
+! datname: name of the data set to use
+! values: mmatrix with the name of the values: variation (Nvariations, g.e. seasons), 
+!   table row (Nrows),  table column (Ncols)
+! linedataset: line inside data-set where values start
+! namevalues: string assigned to each table row
+! ip, jp: coordinates of the grid point
+! Nsoiltypes: number of soil types
+! soiltypes[t/b]: percentage of the soil types at a given grid point on top/bottom
+! soiltypes: percentage of the soil types at a given grid point (lineray interpolated)
+! NOsoiltypes: vector with the names of soil types which are not land
+
+      fname='"compute_TOTsoil_mass_water_values"'
+      errmsg='ERROR -- error -- ERROR -- error'
+
+      IF (Nrows /= Nsoiltypes) THEN
+        PRINT *,errmsg
+        PRINT '  ' // TRIM(fname) // ': Number of soil-types: ',Nsoiltypes,          &
+          ' does not concide with the number of values: ', Nrows,                    &
+          ' from the data-set "' // TRIM(datname) // '" !!!'
+        STOP
+      END IF
+
+      IF (ALLOCATED(soiltypes)) DEALLOCATE(soiltypes)
+      ALLOCATE(soiltypes(Nrows))
+
+! On WRF3.3 SOILPARM.TBL
+      SELECT CASE (TRIM(datname))
+
+        CASE ('STAS')
+          NNOsoiltypes = 1
+          IF (ALLOCATED(NOsoiltypes)) DEALLOCATE(NOsoiltypes)
+          ALLOCATE(NOsoiltypes(NNOsoiltypes))
+
+          NOsoiltypes=(/ 'WATER' /)
+        CASE ('STAS-RUC')
+          NNOsoiltypes = 1
+          IF (ALLOCATED(NOsoiltypes)) DEALLOCATE(NOsoiltypes)
+          ALLOCATE(NOsoiltypes( NNOsoiltypes))
+
+          NOsoiltypes=(/ 'WATER' /)
+      END SELECT
+
+      soilTOTmass = 0.
+      soilTOThumidity = 0.
+
+      DO iz=1,Nsoillayers
+        IF (iz == 1 ) THEN
+          dz = soillayers(iz)
+        ELSE
+          dz = soillayers(iz) - soillayers(iz - 1)
+        END IF
+        IF (( iz > 1) .AND. (iz < Nsoillayers)) THEN
+          DO ix=1,Nrows
+            CALL interpolate_lin(soillayers(1), soiltypest(ix),                      &
+              soillayers(Nsoillayers), soiltypesb(ix), soillayers(iz), soiltypes(ix))
+          END DO
+        ELSEIF (iz == 1) THEN
+          soiltypes = soiltypest
+        ELSE
+          soiltypes = soiltypesb
+        END IF
+!        PRINT *,'lev: ',iz,' dz: ',dz,' soil types: ' ,soiltypes
+
+        CALL compute_soil_mass(Nvariations,Nrows,Ncols,values,namevalues,soiltypes,  &
+          NNOsoiltypes,NOsoiltypes,smois(iz),sizeX,sizeY,dz,soilmass,soilhumidity)
+        soilTOTmass = soilTOTmass + soilmass
+        soilTOThumidity = soilTOThumidity + soilhumidity
+      END DO
+
+      IF ( (soilTOTmass < 0.) .OR. (soilTOThumidity < 0.) ) THEN
+        PRINT *,errmsg
+        PRINT *,'  ' // TRIM(fname) // ' at point ',ip, ', ', jp,                    &
+          ' negative total soil mass: ',soilTOTmass, ' or soil water content',       &
+          soilTOThumidity
+        PRINT *,'  Soil_name density soil_types_________'
+        DO ix=1, Nrows
+           PRINT *,ix, TRIM(namevalues(ix)), values(1,ix,2), soiltypes(ix)
+        END DO
+        PRINT *,'  depth_layer partial_mass soil+moisure partial_moisture__________'
+        DO iz=1,Nsoillayers
+          IF (iz == 1 ) THEN
+            dz = soillayers(iz)
+          ELSE
+            dz = soillayers(iz) - soillayers(iz - 1)
+          END IF
+          IF (( iz > 1) .AND. (iz < Nsoillayers)) THEN
+            DO ix=1,Nrows
+              CALL interpolate_lin(soillayers(1), soiltypest(ix),                    &
+                soillayers(Nsoillayers), soiltypesb(ix), soillayers(iz),soiltypes(ix))
+            END DO
+          ELSEIF (iz == 1) THEN
+            soiltypes = soiltypest
+          ELSE
+            soiltypes = soiltypesb
+          END IF
+          PRINT *,'  ',iz, dz, values(1,iz,2)*sizeX*sizeY*dz*1000., smois(iz),       &
+             smois(iz)*values(1,iz,2)*sizeX*sizeY*dz*1000.
+        END DO
+        STOP
+      END IF
+
+
+      DEALLOCATE(soiltypes)
+      DEALLOCATE(NOsoiltypes)
+
+  END SUBROUTINE compute_TOTsoil_mass_water_values
+
+! cat Registry_out.LMDZ | awk '{print  "        pwrf_grid%"tolower($3)" "$4" = p"tolower($3)" "$4}' >> get_lmdz_out.f90
+! cat get_lmdz_out.f90n' ',' '{print $3}' | tr '\n
+  SUBROUTINE get_lmdz_out(ddx, ddy, ddz, bdy, dlmdz, Nks, Nz0, nqtot, ivap, iliq,    &
+    iflag_pbl, iflag_con, iflag_thermals, iflag_wake, read_climoz, itap,             &
+    pdtphys, paprs, pplay, pphi, pphis, presnivs, qx,                                &
+    d_u, d_v, d_t, d_qx, d_ps,                                                       &
+    pwrf_grid)
+! Subroutine to get all the LMDZ output variables into the WRF Registry structure
+
+! WRF modules
+    USE module_domain_type
+
+! LMDZ modules
+    USE indice_sol_mod
+    USE phys_state_var_mod
+    USE phys_output_var_mod
+!    USE pbl_surface_mod
+    USE phys_local_var_mod
+    USE comgeomphy
+
+! WRF_LMDZ modules
+    USE output_lmdz_NOmodule
+
+! netcdf
+    USE netcdf, ONLY: nf90_fill_real
+
+    IMPLICIT NONE
+
+    TYPE(domain) , TARGET                                :: pwrf_grid
+    INTEGER, INTENT(IN)                                  :: ddx, ddy, ddz, bdy,      &
+      dlmdz, Nks, Nz0, nqtot, ivap, iliq, iflag_pbl, iflag_con, iflag_thermals,      &
+      iflag_wake, read_climoz, itap
+    REAL, INTENT(IN)                                     :: pdtphys
+    REAL, DIMENSION(dlmdz), INTENT(IN)                   :: pphis, d_ps
+    REAL, DIMENSION(ddz), INTENT(IN)                     :: presnivs
+    REAL, DIMENSION(dlmdz,ddz+1), INTENT(IN)             :: paprs
+    REAL, DIMENSION(dlmdz,ddz), INTENT(IN)               :: pplay, pphi, d_u, d_v, d_t
+    REAL, DIMENSION(dlmdz,ddz,nqtot), INTENT(IN)         :: qx, d_qx
+
+!    EXTERNAL suphel
+
+! Local
+    INTEGER                                              :: dx, dy, ix, iy, ixy, iz
+    INTEGER                                              :: i,j,k,l,n
+    INTEGER                                              :: nsrf
+    REAL, DIMENSION(dlmdz,ddz)                           :: var3d
+    REAL, DIMENSION(dlmdz,ddz+1)                         :: var3dstagg
+    REAL                                                 :: RDAY, RG, RD, RMO3
+    CHARACTER(LEN=50)                                    :: fname, errmsg
+    CHARACTER(LEN=4)                                     :: bb2
+    REAL, DIMENSION(dlmdz)                               :: zx_tmp_fi2d ! variable temporaire grille physique
+    REAL, DIMENSION(dlmdz,ddz)                           :: zx_tmp_fi3d ! variable temporaire pour champs 3D 
+    REAL, DIMENSION(dlmdz,ddz+1)                         :: zx_tmp_fi3d1 !variable temporaire pour champs 3D (kelvp1)
+    REAL(KIND=8), DIMENSION(dlmdz,ddz)                   :: zx_tmp2_fi3d ! variable temporaire pour champs 3D 
+    REAL, PARAMETER                                      :: dobson_u = 2.1415e-05
+
+!    klon=dldmz
+!    klev=ddz
+
+
+!! To think about / discuss with Frederic
+
+    INCLUDE "declare_STDlev.h"
+!    INCLUDE "calcul_STDlev.h"
+
+!!!!!!! Variables
+! pwrf_grid: WRF grid structure
+
+! L. Fita, LMD January 2014. It should work using suphel, but not?
+!    CALL suphel
+
+    fname='"get_lmdz_out"'
+    errmsg='ERROR -- error -- ERROR -- error'
+
+    RDAY = 86400.
+    RG = 9.81
+    RD = 287.
+    RMO3=47.9942
+
+    PRINT *,'  Lluis in ' //TRIM(fname)//'!'
+
+! Remove variable assignation already done in get_lmdz? These variables are not used 
+!    in restart/boundaries
+
+    DO ix=1,ddx
+      DO iy=1,ddy
+        ixy=ddx*(iy-1)+ix
+
+        pwrf_grid%lages_ter(ix,iy) = agesno(ixy,1)
+        pwrf_grid%lages_lic(ix,iy) = agesno(ixy,2)
+        pwrf_grid%lages_oce(ix,iy) = agesno(ixy,3)
+        pwrf_grid%lages_sic(ix,iy) = agesno(ixy,4)
+!!        pwrf_grid%lahyb(misc??) = pahyb misc
+        pwrf_grid%laire(ix,iy) = airephy(ixy)
+        pwrf_grid%laireter(ix,iy) = paire_ter(ixy)
+        pwrf_grid%lalb1(ix,iy) = albsol1(ixy)
+        pwrf_grid%lalb2(ix,iy) = albsol2(ixy)
+        pwrf_grid%lalbe_ter(ix,iy) = falb1(ixy,1)
+        pwrf_grid%lalbe_lic(ix,iy) = falb1(ixy,2)
+        pwrf_grid%lalbe_oce(ix,iy) = falb1(ixy,3)
+        pwrf_grid%lalbe_sic(ix,iy) = falb1(ixy,4)
+        pwrf_grid%lale(ix,iy) = ale(ixy)
+        pwrf_grid%lale_bl(ix,iy) = ale_bl(ixy)
+        pwrf_grid%lale_wk(ix,iy) = ale_wake(ixy)
+        pwrf_grid%lalp(ix,iy) = alp(ixy)
+        pwrf_grid%lalp_bl(ix,iy) = alp_bl(ixy)
+        pwrf_grid%lalp_wk(ix,iy) = alp_wake(ixy)
+!!        pwrf_grid%lalt(misc??) = palt misc
+!!        pwrf_grid%lbhyb(misc??) = pbhyb misc
+        pwrf_grid%lbils(ix,iy) = bils(ixy)
+        pwrf_grid%lbils_diss(ix,iy) = bils_diss(ixy)
+        pwrf_grid%lbils_ec(ix,iy) = bils_ec(ixy)
+        pwrf_grid%lbils_enthalp(ix,iy) = bils_enthalp(ixy)
+        pwrf_grid%lbils_kinetic(ix,iy) = bils_kinetic(ixy)
+        pwrf_grid%lbils_latent(ix,iy) = bils_latent(ixy)
+        pwrf_grid%lbils_tke(ix,iy) = bils_tke(ixy)
+        pwrf_grid%lcape(ix,iy) = cape(ixy)
+        pwrf_grid%lcape_max(ix,iy) = cape(ixy)
+        pwrf_grid%lcdrh(ix,iy) = cdragh(ixy)
+        pwrf_grid%lcdrm(ix,iy) = cdragm(ixy)
+        pwrf_grid%lcldh(ix,iy) = cldh(ixy)
+        pwrf_grid%lcldl(ix,iy) = cldl(ixy)
+        pwrf_grid%lcldm(ix,iy) = cldm(ixy)
+        pwrf_grid%lcldq(ix,iy) = cldq(ixy)
+        pwrf_grid%lcldt(ix,iy) = cldt(ixy)
+        pwrf_grid%lcontfracatm(ix,iy) = pctsrf(ixy,is_ter)+pctsrf(ixy,is_lic)
+        pwrf_grid%lcontfracor(ix,iy) = pctsrf(ixy,is_ter)
+!NOTknown!        pwrf_grid%lcumpb(ix,iy) = cumpb(ixy)
+!NOTknown!        pwrf_grid%lcumrn(ix,iy) = cumrn(ixy)
+        pwrf_grid%ldthmin(ix,iy) = dthmin(ixy)
+        pwrf_grid%ldtsvdft(ix,iy) = d_ts(ixy,is_ter)
+        pwrf_grid%ldtsvdfo(ix,iy) = d_ts(ixy,is_oce)
+        pwrf_grid%ldtsvdfg(ix,iy) = d_ts(ixy,is_lic)
+        pwrf_grid%ldtsvdfi(ix,iy) = d_ts(ixy,is_sic)
+        pwrf_grid%levap(ix,iy) = fevap(ixy,1)
+        pwrf_grid%levap_ter(ix,iy) = fevap(ixy,1)
+        pwrf_grid%levap_lic(ix,iy) = fevap(ixy,2)
+        pwrf_grid%levap_oce(ix,iy) = fevap(ixy,3)
+        pwrf_grid%levap_sic(ix,iy) = fevap(ixy,4)
+        pwrf_grid%levappot_ter(ix,iy) = evap_pot(ixy,1)
+        pwrf_grid%levappot_lic(ix,iy) = evap_pot(ixy,2)
+        pwrf_grid%levappot_oce(ix,iy) = evap_pot(ixy,3)
+        pwrf_grid%levappot_sic(ix,iy) = evap_pot(ixy,4)
+        pwrf_grid%lfbase(ix,iy) = ema_cbmf(ixy)
+        pwrf_grid%lfder(ix,iy) = fder(ixy)
+        pwrf_grid%lffonte(ix,iy) = zxffonte(ixy)
+        pwrf_grid%lflat(ix,iy) = zxfluxlat(ixy)
+        pwrf_grid%lflw_ter(ix,iy) = fsollw(ixy,1)
+        pwrf_grid%lflw_lic(ix,iy) = fsollw(ixy,2)
+        pwrf_grid%lflw_oce(ix,iy) = fsollw(ixy,3)
+        pwrf_grid%lflw_sic(ix,iy) = fsollw(ixy,4)
+        pwrf_grid%lfqcalving(ix,iy) = zxfqcalving(ixy)
+        pwrf_grid%lfqfonte(ix,iy) = zxfqfonte(ixy)
+        pwrf_grid%lfract_ter(ix,iy) = pctsrf(ixy,1)
+        pwrf_grid%lfract_lic(ix,iy) = pctsrf(ixy,2)
+        pwrf_grid%lfract_oce(ix,iy) = pctsrf(ixy,3)
+        pwrf_grid%lfract_sic(ix,iy) = pctsrf(ixy,4)
+        pwrf_grid%lfsnow(ix,iy) = zfra_o(ixy)
+        pwrf_grid%lfsw_ter(ix,iy) = fsolw(ixy,1)
+        pwrf_grid%lfsw_lic(ix,iy) = fsolw(ixy,2)
+        pwrf_grid%lfsw_oce(ix,iy) = fsolw(ixy,3)
+        pwrf_grid%lfsw_sic(ix,iy) = fsolw(ixy,4)
+!NOtnow!        pwrf_grid%lftime_con(ix,iy) = float(itau_con)/float(itap)
+        pwrf_grid%lftime_th(ix,iy) = 0.
+        pwrf_grid%liwp(ix,iy) = fiwp(ixy)
+!!        pwrf_grid%llat j = pllat j
+        pwrf_grid%llat_ter(ix,iy) = fluxlat(ixy,1)
+        pwrf_grid%llat_lic(ix,iy) = fluxlat(ixy,2)
+        pwrf_grid%llat_oce(ix,iy) = fluxlat(ixy,3)
+        pwrf_grid%llat_sic(ix,iy) = fluxlat(ixy,4)
+        pwrf_grid%llmaxth(ix,iy) = lmax_th(ixy)
+!!        pwrf_grid%llon i = pllon i
+        pwrf_grid%llwdn200(ix,iy) = lwdn200(ixy)
+        pwrf_grid%llwdn200clr(ix,iy) = lwdn200clr(ixy)
+        pwrf_grid%llwdnsfc(ix,iy) = sollwdown(ixy)
+        pwrf_grid%llwdnsfcclr(ix,iy) = sollwdownclr(ixy)
+        pwrf_grid%llwdownor(ix,iy) = sollwdown(ixy)
+        pwrf_grid%llwp(ix,iy) = flwp(ixy)
+        pwrf_grid%llwup200(ix,iy) = lwup200(ixy)
+        pwrf_grid%llwup200clr(ix,iy) = lwup200clr(ixy)
+        pwrf_grid%llwupsfc(ix,iy) = sollwdown(ixy)-sollw(ixy)
+        pwrf_grid%llwupsfcclr(ix,iy) = -1.*lwdn0(ixy,1)-sollw0(ixy)
+        pwrf_grid%lmsnow(ix,iy) = snow_o(ixy)
+        pwrf_grid%lndayrain(ix,iy) = nday_rain(ixy)
+        pwrf_grid%lnettop(ix,iy) = topsw(ixy)-toplw(ixy)
+        pwrf_grid%lpbase(ix,iy) = ema_pcb(ixy)
+        pwrf_grid%lphis(ix,iy) = pphis(ixy)
+        pwrf_grid%lplcl(ix,iy) = plcl(ixy)
+        pwrf_grid%lplfc(ix,iy) = plfc(ixy)
+        pwrf_grid%lpluc(ix,iy) = rain_con(ixy) + snow_con(ixy)
+        pwrf_grid%lplul(ix,iy) = rain_lsc(ixy) + snow_lsc(ixy)
+        pwrf_grid%lplulst(ix,iy) = plul_st(ixy)
+        pwrf_grid%lplulth(ix,iy) = plul_th(ixy)
+        pwrf_grid%lpourc_ter(ix,iy) = pctsrf(ixy,1)*100.
+        pwrf_grid%lpourc_lic(ix,iy) = pctsrf(ixy,2)*100.
+        pwrf_grid%lpourc_oce(ix,iy) = pctsrf(ixy,3)*100.
+        pwrf_grid%lpourc_sic(ix,iy) = pctsrf(ixy,4)*100.
+        pwrf_grid%lprecip(ix,iy) = rain_fall(ixy) + snow_fall(ixy)
+!!        pwrf_grid%lpresnivs k = plpresnivs k
+        pwrf_grid%lprw(ix,iy) = prw(ixy)
+        pwrf_grid%lpsol(ix,iy) = paprs(ixy,1)
+        pwrf_grid%lptop(ix,iy) = ema_pct(ixy)
+        pwrf_grid%lq2m(ix,iy) = zq2m(ixy)
+        pwrf_grid%lqsat2m(ix,iy) = qsat2m(ixy)
+        pwrf_grid%lqsol(ix,iy) = qsol(ixy)
+        pwrf_grid%lqsurf(ix,iy) = zxqsurf(ixy)
+        pwrf_grid%lradsol(ix,iy) = radsol(ixy)
+        pwrf_grid%lrh2m(ix,iy) = MIN(100.,rh2m(ixy)*100.)
+        pwrf_grid%lrh2m_max(ix,iy) = MIN(100.,rh2m(ixy)*100.)
+        pwrf_grid%lrh2m_min(ix,iy) = MIN(100.,rh2m(ixy)*100.)
+        pwrf_grid%lrugs(ix,iy) = zxrugs(ixy)
+        pwrf_grid%lrugs_ter(ix,iy) = frugs(ixy,1)
+        pwrf_grid%lrugs_lic(ix,iy) = frugs(ixy,2)
+        pwrf_grid%lrugs_oce(ix,iy) = frugs(ixy,3)
+        pwrf_grid%lrugs_sic(ix,iy) = frugs(ixy,4)
+        pwrf_grid%lsens(ix,iy) = -1.*sens(ixy)
+        pwrf_grid%lsicf(ix,iy) = pctsrf(ixy,is_sic)
+        pwrf_grid%ls_lcl(ix,iy) = s_lcl(ixy)
+        pwrf_grid%lslp(ix,iy) = slp(ixy)
+        pwrf_grid%lsnow(ix,iy) = snow_fall(ixy)
+        pwrf_grid%lsnowl(ix,iy) = snow_lsc(ixy)
+        pwrf_grid%lsoll(ix,iy) = sollw(ixy)
+        pwrf_grid%lsoll0(ix,iy) = sollw0(ixy)
+        pwrf_grid%lsollwdown(ix,iy) = sollwdown(ixy)
+        pwrf_grid%lsols(ix,iy) = solsw(ixy)
+        pwrf_grid%lsols0(ix,iy) = solsw0(ixy)
+        pwrf_grid%ls_pblh(ix,iy) = s_pblh(ixy)
+        pwrf_grid%ls_pblt(ix,iy) = s_pblt(ixy)
+        pwrf_grid%ls_therm(ix,iy) = s_therm(ixy)
+        pwrf_grid%lswdn200(ix,iy) = swdn200(ixy)
+        pwrf_grid%lswdn200clr(ix,iy) = swdn200clr(ixy)
+        pwrf_grid%lswdnsfc(ix,iy) = swdn(ixy,1)
+        pwrf_grid%lswdnsfcclr(ix,iy) = swdn0(ixy,1)
+        pwrf_grid%lswdntoa(ix,iy) = swdn(ixy,klev+1)
+        pwrf_grid%lswdntoaclr(ix,iy) = swdn0(ixy,klev+1)
+        pwrf_grid%lswdownor(ix,iy) = solsw(ixy)/(1.-albsol1(ixy))
+        pwrf_grid%lswnetor(ix,iy) = fsolsw(ixy,is_ter)
+        pwrf_grid%lswup200(ix,iy) = swup200(ixy)
+        pwrf_grid%lswup200clr(ix,iy) = swup200clr(ixy)
+        pwrf_grid%lswupsfc(ix,iy) = swup(ixy,1)
+        pwrf_grid%lswupsfcclr(ix,iy) = swup0(ixy,1)
+        pwrf_grid%lswuptoa(ix,iy) = swup(ixy,klev+1)
+        pwrf_grid%lswuptoaclr(ix,iy) = swup0(ixy,klev+1)
+        pwrf_grid%lt2m(ix,iy) = zt2m(ixy)
+        pwrf_grid%lt2m_max(ix,iy) = zt2m(ixy)
+        pwrf_grid%lt2m_min(ix,iy) = zt2m(ixy)
+        pwrf_grid%lt2m_ter(ix,iy) = t2m(ixy,1)
+        pwrf_grid%lt2m_lic(ix,iy) = t2m(ixy,2)
+        pwrf_grid%lt2m_oce(ix,iy) = t2m(ixy,3)
+        pwrf_grid%lt2m_sic(ix,iy) = t2m(ixy,4)
+        pwrf_grid%ltaux(ix,iy) = 0.
+        pwrf_grid%ltauy(ix,iy) = 0.
+        DO iz=1,4
+          pwrf_grid%ltaux(ix,iy) = pwrf_grid%ltauy(ix,iy) + pctsrf(ixy,iz)*          &
+            fluxu(ixy,1,iz)
+          pwrf_grid%ltauy(ix,iy) = pwrf_grid%ltauy(ix,iy) + pctsrf(ixy,iz)*          &
+            fluxv(ixy,1,iz)
+        END DO
+        pwrf_grid%ltaux_ter(ix,iy) = fluxu(ixy,1,1)
+        pwrf_grid%ltaux_lic(ix,iy) = fluxu(ixy,1,2)
+        pwrf_grid%ltaux_oce(ix,iy) = fluxu(ixy,1,3)
+        pwrf_grid%ltaux_sic(ix,iy) = fluxu(ixy,1,4)
+        pwrf_grid%ltauy_ter(ix,iy) = fluxv(ixy,1,1)
+        pwrf_grid%ltauy_lic(ix,iy) = fluxv(ixy,1,2)
+        pwrf_grid%ltauy_oce(ix,iy) = fluxv(ixy,1,3)
+        pwrf_grid%ltauy_sic(ix,iy) = fluxv(ixy,1,4)
+!!        pwrf_grid%ltime - = pltime -
+!!        pwrf_grid%ltime_bounds {lbnds} = pltime_bounds {lbnds}
+!!        pwrf_grid%lti86400 - = plti86400 -
+        IF ( (pctsrf(ixy,is_oce).GT.epsfra).OR.(pctsrf(ixy,is_sic).GT.epsfra) ) THEN
+          pwrf_grid%lt_oce_sic(ix,iy) = (ftsol(ixy, is_oce) * pctsrf(ixy,is_oce)+    &
+          ftsol(ixy, is_sic)*pctsrf(ixy,is_sic))/(pctsrf(ixy,is_oce)+                &
+          pctsrf(ixy,is_sic))
+        ELSE
+          pwrf_grid%lt_oce_sic(ix,iy) = 273.15
+        END IF
+!!        pwrf_grid%lt_op_00001800(misc??) = pt_op_00001800 misc
+!!        pwrf_grid%lt_op_00001800_bnds(misc??) = pt_op_00001800_bnds misc
+        pwrf_grid%ltopl(ix,iy) = toplw(ixy)
+        pwrf_grid%ltopl0(ix,iy) = toplw0(ixy)
+        pwrf_grid%ltops(ix,iy) = topsw(ixy)
+        pwrf_grid%ltops0(ix,iy) = topsw0(ixy)
+        pwrf_grid%ltpot(ix,iy) = tpot(ixy)
+        pwrf_grid%ltpote(ix,iy) = tpote(ixy)
+        pwrf_grid%ltsol(ix,iy) = zxtsol(ixy)
+        pwrf_grid%ltsol_ter(ix,iy) = ftsol(ixy,1)
+        pwrf_grid%ltsol_lic(ix,iy) = ftsol(ixy,2)
+        pwrf_grid%ltsol_oce(ix,iy) = ftsol(ixy,3)
+        pwrf_grid%ltsol_sic(ix,iy) = ftsol(ixy,4)
+        pwrf_grid%lu10m(ix,iy) = zu10m(ixy)
+        pwrf_grid%lu10m_ter(ix,iy) = u10m(ixy,1)
+        pwrf_grid%lu10m_lic(ix,iy) = u10m(ixy,2)
+        pwrf_grid%lu10m_oce(ix,iy) = u10m(ixy,3)
+        pwrf_grid%lu10m_sic(ix,iy) = u10m(ixy,4)
+        pwrf_grid%lue(ix,iy) = ue(ixy)
+        pwrf_grid%luq(ix,iy) = uq(ixy)
+        pwrf_grid%lustar(ix,iy) = zustar(ixy)
+        pwrf_grid%lustar_ter(ix,iy) = ustar(ixy,1)
+        pwrf_grid%lustar_lic(ix,iy) = ustar(ixy,2)
+        pwrf_grid%lustar_oce(ix,iy) = ustar(ixy,3)
+        pwrf_grid%lustar_sic(ix,iy) = ustar(ixy,4)
+        pwrf_grid%lv10m(ix,iy) = zv10m(ixy)
+        pwrf_grid%lv10m_ter(ix,iy) = v10m(ixy,1)
+        pwrf_grid%lv10m_lic(ix,iy) = v10m(ixy,2)
+        pwrf_grid%lv10m_oce(ix,iy) = v10m(ixy,3)
+        pwrf_grid%lv10m_sic(ix,iy) = v10m(ixy,4)
+        pwrf_grid%lve(ix,iy) = ve(ixy)
+        pwrf_grid%lvq(ix,iy) = vq(ixy)
+        pwrf_grid%lwake_h(ix,iy) = wake_h(ixy)
+        pwrf_grid%lwake_s(ix,iy) = wake_s(ixy)
+        pwrf_grid%lwape(ix,iy) = wake_pe(ixy)
+        pwrf_grid%lwbeff(ix,iy) = wbeff(ixy)
+        pwrf_grid%lwbilo_ter(ix,iy) = wfbilo(ixy,1)
+        pwrf_grid%lwbilo_lic(ix,iy) = wfbilo(ixy,2)
+        pwrf_grid%lwbilo_oce(ix,iy) = wfbilo(ixy,3)
+        pwrf_grid%lwbilo_sic(ix,iy) = wfbilo(ixy,4)
+        pwrf_grid%lwbils_ter(ix,iy) = wfbils(ixy,1)
+        pwrf_grid%lwbils_lic(ix,iy) = wfbils(ixy,2)
+        pwrf_grid%lwbils_oce(ix,iy) = wfbils(ixy,3)
+        pwrf_grid%lwbils_sic(ix,iy) = wfbils(ixy,4)
+        pwrf_grid%lweakinv(ix,iy) = weak_inversion(ixy)
+        pwrf_grid%lwind10m(ix,iy) = SQRT(zu10m(ixy)*zu10m(ixy)+zv10m(ixy)*zv10m(ixy))
+        pwrf_grid%lwind10max(ix,iy) = SQRT(zu10m(ixy)*zu10m(ixy)+zv10m(ixy)*zv10m(ixy))
+        pwrf_grid%lzmax_th(ix,iy) = zmax_th(ixy)
+! Output at the standard levels
+!!
+!        DO iz=1, nlevSTD
+!          bb2=clevSTD(iz) 
+ 
+!          IF (TRIM(bb2) == "850") THEN
+!            pwrf_grid%lq850(ix,iy) = q850(ixy)
+!            pwrf_grid%lt850(ix,iy) = t850(ixy)
+!            pwrf_grid%lu850(ix,iy) = u850(ixy)
+!            pwrf_grid%lv850(ix,iy) = v850(ixy)
+!            pwrf_grid%lw850(ix,iy) = w850(ixy)
+!            pwrf_grid%lz850(ix,iy) = z850(ixy)
+!          ELSE IF (TRIM(bb2) == "700") THEN
+!            pwrf_grid%lq700(ix,iy) = q700(ixy)
+!            pwrf_grid%lt700(ix,iy) = t700(ixy)
+!            pwrf_grid%lu700(ix,iy) = u700(ixy)
+!            pwrf_grid%lv700(ix,iy) = v700(ixy)
+!            pwrf_grid%lw700(ix,iy) = w700(ixy)
+!            pwrf_grid%lz700(ix,iy) = z700(ixy)
+!          ELSE IF (TRIM(bb2) == "500") THEN
+!            pwrf_grid%lq500(ix,iy) = q500(ixy)
+!            pwrf_grid%lt500(ix,iy) = t500(ixy)
+!            pwrf_grid%lu500(ix,iy) = u500(ixy)
+!            pwrf_grid%lv500(ix,iy) = v500(ixy)
+!            pwrf_grid%lw500(ix,iy) = w500(ixy)
+!            pwrf_grid%lz500(ix,iy) = z500(ixy)
+!           ELSE IF (TRIM(bb2) == "200")THEN
+!            pwrf_grid%lq200(ix,iy) = q200(ixy)
+!            pwrf_grid%lt200(ix,iy) = t200(ixy)
+!            pwrf_grid%lu200(ix,iy) = u200(ixy)
+!            pwrf_grid%lv200(ix,iy) = v200(ixy)
+!            pwrf_grid%lw200(ix,iy) = w200(ixy)
+!            pwrf_grid%lz200(ix,iy) = z200(ixy)
+!          ELSE IF (TRIM(bb2) == "100") THEN
+!            pwrf_grid%lq100(ix,iy) = q100(ixy)
+!            pwrf_grid%lt100(ix,iy) = t100(ixy)
+!            pwrf_grid%lu100(ix,iy) = u100(ixy)
+!            pwrf_grid%lv100(ix,iy) = v100(ixy)
+!            pwrf_grid%lw100(ix,iy) = w100(ixy)
+!            pwrf_grid%lz100(ix,iy) = z100(ixy)
+!          ELSE IF (TRIM(bb2) == "50") THEN
+!            pwrf_grid%lq50(ix,iy) = q50(ixy)
+!            pwrf_grid%lt50(ix,iy) = t50(ixy)
+!            pwrf_grid%lu50(ix,iy) = u50(ixy)
+!            pwrf_grid%lv50(ix,iy) = v50(ixy)
+!            pwrf_grid%lw50(ix,iy) = w50(ixy)
+!            pwrf_grid%lz50(ix,iy) = z50(ixy)
+!          ELSE IF (TRIM(bb2) == "10") THEN
+!            pwrf_grid%lq10(ix,iy) = q10(ixy)
+!            pwrf_grid%lt10(ix,iy) = t10(ixy)
+!            pwrf_grid%lu10(ix,iy) = u10(ixy)
+!            pwrf_grid%lv10(ix,iy) = v10(ixy)
+!            pwrf_grid%lw10(ix,iy) = w10(ixy)
+!            pwrf_grid%lz10(ix,iy) = z10(ixy)
+!          END IF
+!        END DO
+
+      END DO
+    END DO
+
+    dx=ddx+2*bdy
+    dy=ddy+2*bdy
+
+    CALL vect_mat_zstagg(fraca, dx, dy, ddz+1, bdy, pwrf_grid%la_th)
+    CALL vect_mat(beta_prec, dx, dy, ddz, bdy, pwrf_grid%lbeta_prec)
+    var3d=upwd + dnwd+ dnwd0
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldmc)
+    CALL vect_mat(dnwd, dx, dy, ddz, bdy, pwrf_grid%ldnwd)
+    CALL vect_mat(dnwd0, dx, dy, ddz, bdy, pwrf_grid%ldnwd0)
+! Originally is var3d = d_q_ajsb(1:ddx*ddy,1:ddz)/pdtphys
+    var3d = d_q_ajsb/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldqajs)
+    var3d = d_q_con/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldqcon)
+    CALL vect_mat(d_q_dyn, dx, dy, ddz, bdy, pwrf_grid%ldqdyn)
+    var3d = d_q_eva/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldqeva)
+    var3d = d_q_lsc/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldqlsc)
+    var3d = d_q_lscst/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldqlscst)
+    var3d = d_q_lscth/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldqlscth)
+! L. Fita, LMD January 2014. d_qx is the tendency of moisture due to physiq! 
+!   MOISTtend in the WRF_LMDZ coupling
+    CALL vect_mat(d_qx(:,:,ivap), dx, dy, ddz, bdy, pwrf_grid%ldqphy)
+    var3d = d_q_ajs/pdtphys - d_q_ajsb/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldqthe)
+    var3d = d_q_vdf/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldqvdf)
+    var3d = d_q_wake/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldqwak)
+    var3d = d_t_ajsb/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtajs)
+    var3d = d_t_con/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtcon)
+    var3d = d_t_diss/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtdis)
+    CALL vect_mat(d_t_dyn, dx, dy, ddz, bdy, pwrf_grid%ldtdyn)
+    var3d = d_t_ec/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtec)
+    var3d = d_t_eva/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldteva)
+    CALL vect_mat(detr_therm, dx, dy, ddz, bdy, pwrf_grid%ld_th)
+    CALL vect_mat(cldemi, dx, dy, ddz, bdy, pwrf_grid%lcldemi)
+    CALL vect_mat(cldtau, dx, dy, ddz, bdy, pwrf_grid%lcldtau)
+    CALL vect_mat(clwcon, dx, dy, ddz, bdy, pwrf_grid%lclwcon)
+    var3d = d_t_lif/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtlif)
+    var3d = d_t_lsc/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtlsc)
+    var3d = (d_t_lsc+d_t_eva)/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtlschr)
+    var3d = d_t_lscst/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtlscst)
+    var3d = d_t_lscth/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtlscth)
+    var3d=-1.*cool0/RDAY
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtlw0)
+    var3d = -1.*cool/RDAY
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtlwr)
+    var3d=d_t_oro/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtoro)
+    CALL vect_mat(d_t, dx, dy, ddz, bdy, pwrf_grid%ldtphy)
+    var3d=heat0/RDAY
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtsw0)
+    var3d=heat/RDAY
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtswr)
+    var3d = d_t_ajs/pdtphys - d_t_ajsb/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtthe)
+    var3d=d_t_vdf/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtvdf)
+    var3d=d_t_wake/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldtwak)
+    var3d=d_u_con/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%lducon)
+    CALL vect_mat(d_u_dyn, dx, dy, ddz, bdy, pwrf_grid%ldudyn)
+    var3d=d_u_lif/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldulif)
+    var3d=d_u_oro/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%lduoro)
+    var3d=d_u_vdf/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%lduvdf)
+    var3d=d_v_con/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldvcon)
+    CALL vect_mat(d_v_dyn, dx, dy, ddz, bdy, pwrf_grid%ldvdyn)
+    var3d=d_v_lif/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldvlif)
+    var3d=d_v_oro/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldvoro)
+    var3d=d_v_vdf/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ldvvdf)
+!NOTfound!    CALL vect_mat(ec550aer, dx, dy, ddz, bdy, pwrf_grid%lec550aer)
+    CALL vect_mat(entr_therm, dx, dy, ddz, bdy, pwrf_grid%le_th)
+    CALL vect_mat(coefm(:,:,is_ave), dx, dy, ddz+1, bdy, pwrf_grid%levu)
+    CALL vect_mat(fl, dx, dy, ddz, bdy, pwrf_grid%lfl)
+    CALL vect_mat(zphi, dx, dy, ddz, bdy, pwrf_grid%lgeop)
+    var3d = q_seri + ql_seri
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%lh2o)
+    CALL vect_mat(fiwc, dx, dy, ddz, bdy, pwrf_grid%liwcon)
+    CALL vect_mat(coefh(:,:,is_ave), dx, dy, ddz+1, bdy, pwrf_grid%lkz)
+    CALL vect_mat(coefh(:,:,is_ave), dx, dy, ddz+1, bdy, pwrf_grid%lkz_max)
+!    CALL vect_mat(lambda_th, dx, dy, ddz, bdy, pwrf_grid%llambda_th)
+    CALL vect_mat(flwc, dx, dy, ddz, bdy, pwrf_grid%llwcon)
+!NOTknown!    CALL vect_mat(ma, dx, dy, ddz, bdy, pwrf_grid%lma)
+    CALL vect_mat(zmasse, dx, dy, ddz, bdy, pwrf_grid%lmass)
+!NOTknown!    CALL vect_mat(mc, dx, dy, ddz, bdy, pwrf_grid%lmc)
+!NOTknown!    CALL vect_mat(mcd, dx, dy, ddz, bdy, pwrf_grid%lmcd)
+    CALL vect_mat(ql_seri, dx, dy, ddz, bdy, pwrf_grid%loliq)
+    CALL vect_mat(q_seri, dx, dy, ddz, bdy, pwrf_grid%lovap)
+! L. Fita, LMD January 2014. d_qx is the tendency of moisture due to physiq! 
+!   MOISTtend in the WRF_LMDZ coupling
+    CALL vect_mat(qx(:,:,ivap), dx, dy, ddz, bdy, pwrf_grid%lovapinit)
+!Notnow!    var3d = wo(:,:,1)*dobson_u*1e3 / zmasse / rmo3 * rmd)
+!Notnow!    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%lozone)
+    CALL vect_mat_zstagg(paprs, dx, dy, ddz+1, bdy, pwrf_grid%lpaprs)
+!NOTknown!    CALL vect_mat(pb, dx, dy, ddz, bdy, pwrf_grid%lpb)
+    CALL vect_mat_zstagg(pmflxs, dx, dy, ddz+1, bdy, pwrf_grid%lpr_con_i)
+    CALL vect_mat_zstagg(pmflxr, dx, dy, ddz+1, bdy, pwrf_grid%lpr_con_l)
+    CALL vect_mat(pplay, dx, dy, ddz, bdy, pwrf_grid%lpres)
+    CALL vect_mat_zstagg(psfl, dx, dy, ddz+1, bdy, pwrf_grid%lpr_lsc_i)
+    CALL vect_mat_zstagg(prfl, dx, dy, ddz+1, bdy, pwrf_grid%lpr_lsc_l)
+    var3d = 0.
+    WHERE (ptconv) var3d = 1.
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%lptconv)
+    CALL vect_mat(zqasc, dx, dy, ddz, bdy, pwrf_grid%lq_th)
+    CALL vect_mat(ratqs, dx, dy, ddz, bdy, pwrf_grid%lratqs)
+    CALL vect_mat(re, dx, dy, ddz, bdy, pwrf_grid%lre)
+    CALL vect_mat(ref_ice, dx, dy, ddz, bdy, pwrf_grid%lref_ice)
+    CALL vect_mat(ref_liq, dx, dy, ddz, bdy, pwrf_grid%lref_liq)
+    CALL vect_mat(zx_rh, dx, dy, ddz, bdy, pwrf_grid%lrhum)
+    CALL vect_mat(lwdn, dx, dy, ddz, bdy, pwrf_grid%lrld)
+    CALL vect_mat(lwdn0, dx, dy, ddz, bdy, pwrf_grid%lrldcs)
+    CALL vect_mat(lwup, dx, dy, ddz, bdy, pwrf_grid%lrlu)
+    CALL vect_mat(lwup0, dx, dy, ddz, bdy, pwrf_grid%lrlucs)
+!NOTknown!    CALL vect_mat(rn, dx, dy, ddz, bdy, pwrf_grid%lrn)
+    CALL vect_mat(cldfra, dx, dy, ddz, bdy, pwrf_grid%lrneb)
+    CALL vect_mat(rnebcon, dx, dy, ddz, bdy, pwrf_grid%lrnebcon)
+    CALL vect_mat(rneb, dx, dy, ddz, bdy, pwrf_grid%lrnebls)
+    CALL vect_mat(swdn, dx, dy, ddz, bdy, pwrf_grid%lrsd)
+    CALL vect_mat(swdn0, dx, dy, ddz, bdy, pwrf_grid%lrsdcs)
+    CALL vect_mat(swup, dx, dy, ddz, bdy, pwrf_grid%lrsu)
+    CALL vect_mat(swup0, dx, dy, ddz, bdy, pwrf_grid%lrsucs)
+    CALL vect_mat(fluxt(:,:,1), dx, dy, ddz, bdy, pwrf_grid%lsens_ter)
+    CALL vect_mat(fluxt(:,:,2), dx, dy, ddz, bdy, pwrf_grid%lsens_lic)
+    CALL vect_mat(fluxt(:,:,3), dx, dy, ddz, bdy, pwrf_grid%lsens_oce)
+    CALL vect_mat(fluxt(:,:,4), dx, dy, ddz, bdy, pwrf_grid%lsens_sic)
+    CALL vect_mat(t_seri, dx, dy, ddz, bdy, pwrf_grid%ltemp)
+    CALL vect_mat(theta, dx, dy, ddz, bdy, pwrf_grid%ltheta)
+    var3d=0.
+    DO nsrf=1,nbsrf
+       DO iz=1,ddz+1
+         var3dstagg(:,iz)=var3dstagg(:,iz)+pctsrf(:,nsrf)*pbl_tke(:,iz,nsrf)
+       ENDDO
+    ENDDO
+    CALL vect_mat_zstagg(var3dstagg, dx, dy, ddz+1, bdy, pwrf_grid%ltke)
+    CALL vect_mat_zstagg(var3dstagg, dx, dy, ddz+1, bdy, pwrf_grid%ltke_max)
+    CALL vect_mat(pbl_tke(:,:,1), dx, dy, ddz+1, bdy, pwrf_grid%ltke_ter)
+    CALL vect_mat(pbl_tke(:,:,2), dx, dy, ddz+1, bdy, pwrf_grid%ltke_lic)
+    CALL vect_mat(pbl_tke(:,:,3), dx, dy, ddz+1, bdy, pwrf_grid%ltke_oce)
+    CALL vect_mat(pbl_tke(:,:,4), dx, dy, ddz+1, bdy, pwrf_grid%ltke_sic)
+!NOTinRegisty!    CALL vect_mat(pbl_tke(:,:,1), dx, dy, ddz+1, bdy, pwrf_grid%ltke_ter_max)
+!NOTinRegisty!    CALL vect_mat(pbl_tke(:,:,2), dx, dy, ddz+1, bdy, pwrf_grid%ltke_lic_max)
+!NOTinRegisty!    CALL vect_mat(pbl_tke(:,:,3), dx, dy, ddz+1, bdy, pwrf_grid%ltke_oce_max)
+!NOTinRegisty!    CALL vect_mat(pbl_tke(:,:,4), dx, dy, ddz+1, bdy, pwrf_grid%ltke_sic_max)
+    var3d = d_qx(:,:,ivap)+d_q_dyn
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ltnhus)
+    IF (iflag_thermals == 1) THEN
+      var3d = d_q_con/pdtphys
+    ELSE IF ((iflag_thermals > 1) .AND. (iflag_wake == 1)) THEN
+      var3d = d_q_con/pdtphys + d_q_ajs/pdtphys + d_q_wake/pdtphys
+    END IF
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ltnhusc)
+    var3d = d_q_lsc/pdtphys + d_q_eva/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ltnhusscpbl)
+    var3d = d_t + d_t_dyn
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ltnt)
+    IF (iflag_thermals == 1) THEN
+      var3d = d_t_con/pdtphys + d_t_ajsb/pdtphys
+    ELSE IF ((iflag_thermals  > 1) .AND. (iflag_wake == 1)) THEN
+      var3d=d_t_con/pdtphys + d_t_ajs/pdtphys + d_t_wake/pdtphys
+    END IF
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ltntc)
+    var3d = heat/RDAY - cool/RDAY
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ltntr)
+    var3d = (d_t_lsc + d_t_eva + d_t_vdf)/pdtphys
+    CALL vect_mat(var3d, dx, dy, ddz, bdy, pwrf_grid%ltntscpbl)
+    CALL vect_mat(upwd, dx, dy, ddz, bdy, pwrf_grid%lupwd)
+    CALL vect_mat(u_seri, dx, dy, ddz, bdy, pwrf_grid%lvitu)
+    CALL vect_mat(v_seri, dx, dy, ddz, bdy, pwrf_grid%lvitv)
+    CALL vect_mat(omega, dx, dy, ddz, bdy, pwrf_grid%lvitw)
+    CALL vect_mat_zstagg(Vprecip, dx, dy, ddz+1, bdy, pwrf_grid%lvprecip)
+    CALL vect_mat(wake_deltaq, dx, dy, ddz, bdy, pwrf_grid%lwake_deltaq)
+    CALL vect_mat(wake_deltat, dx, dy, ddz, bdy, pwrf_grid%lwake_deltat)
+    CALL vect_mat(wake_omg, dx, dy, ddz, bdy, pwrf_grid%lwake_omg)
+    CALL vect_mat(wdtrainA, dx, dy, ddz, bdy, pwrf_grid%lwdtraina)
+    CALL vect_mat(wdtrainM, dx, dy, ddz, bdy, pwrf_grid%lwdtrainm)
+! L. Fita, LMD, January 2014. pphis is the given value of the pressure at the surface
+    var3dstagg(:,1) = pphis(:)/RG
+    DO iz=1,ddz
+      var3dstagg(:,iz+1)= var3dstagg(:,iz)-(t_seri(:,iz)*RD*(paprs(:,iz+1)-          &
+       paprs(:,iz)) )/ (pplay(:,iz)*RG)
+    ENDDO
+    CALL vect_mat(var3dstagg, dx, dy, ddz, bdy, pwrf_grid%lzfull)
+    var3dstagg(:,1) = pphis(:)/RG-( (t_seri(:,1)+zxtsol)/2.*RD*(pplay(:,1)-          &
+      paprs(:,1)) )/ ((paprs(:,1)+pplay(:,1))/2.*RG)
+    DO iz=1, ddz-1
+      var3dstagg(:,iz+1)= var3dstagg(:,iz)-( (t_seri(:,iz)+t_seri(:,iz+1))/          &
+        2.*RD*(pplay(:,iz+1)-pplay(:,iz)))/( paprs(:,iz)*RG) 
+    ENDDO
+    CALL vect_mat_zstagg(var3dstagg, dx, dy, ddz+1, bdy, pwrf_grid%lzhalf)
+
+    RETURN
+
+  END SUBROUTINE get_lmdz_out
+
+  SUBROUTINE put_lmdz_in_WRFout(is, ie, js, je, ks, ke, ddx, ddy, ddz, bdy, dlmdz,xp,&
+    yp, lmdp, Nks, Nz0, nqtot, ivap, iliq, iflag_pbl, iflag_con, iflag_thermals,     &
+    iflag_wake, itap, pdtphys, paprs, pplay, pphi, pphis, presnivs, qx, d_u, d_v,    &
+    d_t, d_qx, d_ps, orchidlev, tsoilorchid, nslayers, wslay, wzs, wdzs, wnest_pos,  &
+    wq2, wt2, wth2, wpsfc, wu10, wv10, wresm, wzetatop, wtslb, wsmois,               &
+    wsh2o, wsmcrel, wsfroff, wudroff, wgrdflx, wacgrdflx, wsnow, wsnowh,             &
+    wcanwat, wsst, wsstsk, wlai, wh_diabatic, wsina, wtsk, wtiso,                    &
+    wmax_msftx, wmax_msfty, wrainc, wraincv, wrainsh, wrainshv, wrainnc, wrainncv,   &
+    wsnownc, wsnowncv, wgraupelnc, wgraupelncv, whailnc, whailncv, wstepave_count,   &
+    wcldfra, wswdown, wglw, wswnorm, wolr, wemiss, wtmn, wust, wpblh, whfx,          &
+    wqfx, wlh, wachfx, waclhf, wsnowc, wsr, wpotevp, wsnopcx, wsoiltb) 
+!    wsave_topo_from_real, wavg_fuel_frac, wuah, wvah, wseed1, wseed2)
+! Subroutine to get LMDZ output and get into WRF standard output variables 
+!   (as they appear in the wrfout)
+
+! LMDZ modules
+    USE indice_sol_mod
+    USE phys_state_var_mod
+    USE phys_output_var_mod
+!    USE pbl_surface_mod
+    USE phys_local_var_mod
+    USE comgeomphy
+
+! WRF_LMDZ modules
+    USE output_lmdz_NOmodule
+    USE lmdz_wrf_variables_mod
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                                  :: is, ie, js, je, ks, ke,  &
+      ddx, ddy, ddz, bdy, dlmdz, xp, yp, lmdp, Nks, Nz0, nqtot, ivap, iliq,          &
+      iflag_pbl, iflag_con, iflag_thermals, iflag_wake, itap, nslayers
+    REAL, INTENT(IN)                                     :: pdtphys
+    REAL, DIMENSION(dlmdz), INTENT(IN)                   :: pphis, d_ps
+    REAL, DIMENSION(ddz), INTENT(IN)                     :: presnivs
+    REAL, DIMENSION(dlmdz,ddz+1), INTENT(IN)             :: paprs
+    REAL, DIMENSION(dlmdz,ddz), INTENT(IN)               :: pplay, pphi, d_u, d_v, d_t
+    REAL, DIMENSION(dlmdz,ddz,nqtot), INTENT(IN)         :: qx, d_qx
+    REAL, DIMENSION(Nz0), INTENT(IN)                     :: orchidlev
+    REAL, DIMENSION(dlmdz,Nz0,Nks), INTENT(IN)           :: tsoilorchid
+    INTEGER, INTENT(INOUT)                               :: wstepave_count
+    REAL, INTENT(INOUT)                                  :: wresm, wzetatop, wtiso,  &
+      wmax_msftx, wmax_msfty
+    REAL, DIMENSION(1:nslayers), INTENT(INOUT)           :: wzs, wdzs
+    REAL, DIMENSION(1:nslayers), INTENT(IN)              :: wslay
+    REAL, DIMENSION(is:ie,js:je), INTENT(INOUT)          :: wnest_pos, wq2, wt2,     &
+      wth2, wpsfc, wu10, wv10, wsfroff, wudroff, wgrdflx, wacgrdflx, wsnow, wsnowh,  &
+      wcanwat, wsst, wsstsk, wlai, wsina, wtsk, wrainc, wraincv, wrainsh, wrainshv,  &
+      wrainnc, wrainncv, wsnownc, wsnowncv, wgraupelnc, wgraupelncv, whailnc,        &
+      whailncv, wswdown, wglw, wswnorm, wolr, wemiss, wtmn, wust, wpblh, whfx,       &
+      wqfx, wlh, wachfx, waclhf, wsnowc, wsr, wpotevp, wsnopcx, wsoiltb 
+    REAL, DIMENSION(is:ie,1:nslayers,js:je), INTENT(INOUT) :: wtslb, wsmois, wsh2o,  &
+      wsmcrel
+    REAL, DIMENSION(is:ie,ks:ke,js:je), INTENT(INOUT)    :: wh_diabatic, wcldfra
+!    EXTERNAL suphel
+
+! Local
+    INTEGER                                              :: dx, dy, ix, iy, ixy, iz
+    INTEGER                                              :: nsrf
+    REAL                                                 :: varixy
+    REAL, DIMENSION(Nz0)                                 :: yvals1
+    REAL                                                 :: RDAY, RG, RD
+    CHARACTER(LEN=50)                                    :: fname
+
+!!!!!!! Variables
+! pwrf_grid: WRF grid structure
+
+    fname = "'put_lmdz_in_WRFout'"
+
+! L. Fita, LMD January 2014. It should work using suphel, but not?
+!    CALL suphel
+
+    RDAY = 86400.
+    RG = 9.81
+    RD = 287.
+
+    wdzs(1)=wslay(nslayers)
+    DO iz=1,nslayers-1
+      wdzs(iz+1) = wslay(nslayers-iz+1) - wslay(nslayers-iz)
+    END DO
+!    wmax_msftx = 
+!    wmax_msfty = 
+!    wresm = 
+!    wstepave_count = 
+!    wtiso = 
+!    wzetatop = 
+    wzs = wslay
+
+    DO ix=1,ddx
+      DO iy=1,ddy
+        ixy=ddx*(iy-1)+ix
+        wacgrdflx(ix,iy) = wacgrdflx(ix,iy) + 0.
+        wachfx(ix,iy) = wachfx(ix,iy) + sens(ixy)
+        waclhf(ix,iy) = waclhf(ix,iy) + zxfluxlat(ixy)
+        DO iz=1,ddz
+          wcldfra(ix,iz,iy) = cldfra(ixy,iz)
+        END DO
+        wcanwat(ix,iy) = 0.
+        wglw(ix,iy) = sollwdown(ixy)
+! These are precipitation fluxes !! 
+!        wgraupelnc(ix,iy) = wgraupelnc(ix,iy) + prmflxs(ixy) + prfs(ixy,iz)
+!        wgraupelncv(ix,iy) = prmflxs(ixy) + prfs(ixy,iz)
+        wgrdflx(ix,iy) = 0.
+        whailnc(ix,iy) = whailnc(ix,iy) + 0.
+        whailncv(ix,iy) = 0.
+        wh_diabatic(ix,ks:ke,iy) = 0.
+        whfx(ix,iy) = sens(ixy)
+        wlai(ix,iy) = 0.
+        wlh(ix,iy) = zxfluxlat(ixy)
+        wnest_pos(ix,iy) = 0.
+!!        wnoahres(ix,iy) = 0.
+        wolr(ix,iy) = toplw(ixy)
+        wpblh(ix,iy) = s_pblh(ixy)
+! Should be something from evappot_srf ?
+        wpotevp(ix,iy) = wpotevp(ix,iy) + 0.
+        wpsfc(ix,iy) = paprs(ixy,1)
+        wq2(ix,iy) = zq2m(ixy)
+        wqfx(ix,iy) = 0.
+        wrainc(ix,iy) = wrainc(ix,iy) + rain_fall(ixy)*pdtphys
+        wraincv(ix,iy) = rain_fall(ixy)*pdtphys
+        wrainnc(ix,iy) = wrainnc(ix,iy) + rain_lsc(ixy)*pdtphys
+        wrainncv(ix,iy) = rain_lsc(ixy)*pdtphys
+        wrainsh(ix,iy) = wrainsh(ix,iy) + 0.
+        wrainshv(ix,iy) = 0.
+! L. Fita, LMD. February 2014
+! LMDZ run_off_lic is for continental ice. We could try to get run_off_ter, but....
+!        wsfroff(ix,iy) = 0.
+        DO iz=1,Nks
+          yvals1(iz) = tsoilorchid(ixy,iz,1)*pctsrf(ixy,is_ter) +                    &
+            tsoilorchid(ixy,iz,2)*pctsrf(ixy,is_lic) +                               &
+            tsoilorchid(ixy,iz,3)*pctsrf(ixy,is_oce) +                               &
+            tsoilorchid(ixy,iz,4)*pctsrf(ixy,is_sic)
+        END DO
+        CALL interpolate_layers(Nz0,orchidlev,yvals1,nslayers,wslay,wtslb(ix,:,iy))
+! No way ???
+!          wsh2o(is:ie,iz,js:je) = wsh2o(is:ie,iz,js:je) + 
+!          wsmcrel(is:ie,iz,js:je) = 0.
+
+!        wsinalpha(ix,iy) = 
+        wsina(ix,iy) = 0.
+        wsnopcx(ix,iy) = wsnopcx(ix,iy) + 0.
+!!        wsnowh(ix,iy) = snowght(ixy)
+        wsnownc(ix,iy) = wsnownc(ix,iy) + snow_fall(ixy)*pdtphys
+        wsnowncv(ix,iy) = snow_fall(ixy)*pdtphys
+        wsoiltb(ix,iy) = wtslb(ix,nslayers,iy)
+        IF (rain_fall(ixy) /= 0.) THEN
+          wsr(ix,iy) = ( snow_fall(ixy) ) / ( rain_fall(ixy))
+        ELSE
+          wsr(ix,iy) = 0.
+        END IF
+        wsstsk(ix,iy) = ftsol(ixy,is_oce)
+        wsst(ix,iy) = sst(ixy)
+        wswdown(ix,iy) = swdn(ixy,1)*pctsrf(ixy,is_ter) +                            &
+          swdn(ixy,2)*pctsrf(ixy,is_lic) + swdn(ixy,3)*pctsrf(ixy,is_oce) +          &
+          swdn(ixy,4)*pctsrf(ixy,is_sic)
+        wswnorm(ix,iy) = 0.
+        wt2(ix,iy) = zt2m(ixy)
+! This is not exact!!
+        CALL temp_to_theta1(zt2m(ixy), paprs(ixy,1), wth2(ix,iy))
+        wtsk(ix,iy) = ftsol(ixy, is_ter)*pctsrf(ixy,is_ter) + ftsol(ixy, is_lic)*    &
+          pctsrf(ixy,is_lic) + ftsol(ixy, is_oce)*pctsrf(ixy,is_oce) +               &
+          ftsol(ixy, is_sic)*pctsrf(ixy,is_sic)
+        wu10(ix,iy) = zu10m(ixy)
+        wudroff(ix,iy) = wudroff(ix,iy) + 0.
+        wv10(ix,iy) = zv10m(ixy)
+      END DO
+    END DO
+
+  END SUBROUTINE put_lmdz_in_WRFout
+
+END MODULE wrf_lmdz_mod
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/wrgrads.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/wrgrads.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/wrgrads.F	(revision 17)
@@ -0,0 +1,133 @@
+!
+! $Header$
+!
+      subroutine wrgrads(if,nl,field,name,titlevar)
+      implicit none
+
+c   Declarations
+c    if indice du fichier
+c    nl nombre de couches
+c    field   champ
+c    name    petit nom
+c    titlevar   Titre
+
+#include "gradsdef.h"
+
+c   arguments
+      integer if,nl
+      real field(imx*jmx*lmx)
+
+      integer, parameter:: wp = selected_real_kind(p=6, r=36)
+      real(wp) field4(imx*jmx*lmx)
+
+      character*10 name,file
+      character*10 titlevar
+
+c   local
+
+      integer im,jm,lm,i,j,l,iv,iii,iji,iif,ijf
+
+      logical writectl
+
+
+      writectl=.false.
+
+c     print*,if,iid(if),jid(if),ifd(if),jfd(if)
+      iii=iid(if)
+      iji=jid(if)
+      iif=ifd(if)
+      ijf=jfd(if)
+      im=iif-iii+1
+      jm=ijf-iji+1
+      lm=lmd(if)
+
+c     print*,'im,jm,lm,name,firsttime(if)'
+c     print*,im,jm,lm,name,firsttime(if)
+
+      if(firsttime(if)) then
+         if(name.eq.var(1,if)) then
+            firsttime(if)=.false.
+            ivar(if)=1
+         print*,'fin de l initialiation de l ecriture du fichier'
+         print*,file
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+         else
+            ivar(if)=ivar(if)+1
+            nvar(if)=ivar(if)
+            var(ivar(if),if)=name
+            tvar(ivar(if),if)=trim(titlevar)
+            nld(ivar(if),if)=nl
+c           print*,'initialisation ecriture de ',var(ivar(if),if)
+c           print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
+         endif
+         writectl=.true.
+         itime(if)=1
+      else
+         ivar(if)=mod(ivar(if),nvar(if))+1
+         if (ivar(if).eq.nvar(if)) then
+            writectl=.true.
+            itime(if)=itime(if)+1
+         endif
+
+         if(var(ivar(if),if).ne.name) then
+           print*,'Il faut stoker la meme succession de champs a chaque'
+           print*,'pas de temps'
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+
+           stop
+         endif
+      endif
+
+c     print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
+c     print*,ivar(if),nvar(if),var(ivar(if),if),writectl
+      field4(1:imd(if)*jmd(if)*nl)=field(1:imd(if)*jmd(if)*nl)
+      do l=1,nl
+         irec(if)=irec(if)+1
+c        print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
+c    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
+c    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
+         write(unit(if)+1,rec=irec(if))
+     s   ((field4((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i)
+     s   ,i=iii,iif),j=iji,ijf)
+      enddo
+      if (writectl) then
+
+      file=fichier(if)
+c   WARNING! on reecrase le fichier .ctl a chaque ecriture
+      open(unit(if),file=trim(file)//'.ctl'
+     &         ,form='formatted',status='unknown')
+      write(unit(if),'(a5,1x,a40)')
+     &       'DSET ','^'//trim(file)//'.dat'
+
+      write(unit(if),'(a12)') 'UNDEF 1.0E30'
+      write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if)
+      call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF')
+      call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF')
+      call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF')
+      write(unit(if),'(a4,i10,a30)')
+     &       'TDEF ',itime(if),' LINEAR 02JAN1987 1MO '
+      write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if)
+      do iv=1,nvar(if)
+c        print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
+c        print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)
+         write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if)
+     &     ,99,tvar(iv,if)
+      enddo
+      write(unit(if),'(a7)') 'ENDVARS'
+c
+1000  format(a5,3x,i4,i3,1x,a39)
+
+      close(unit(if))
+
+      endif ! writectl
+
+      return
+
+      END
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/wrgrads.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/wrgrads.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/wrgrads.F90	(revision 17)
@@ -0,0 +1,133 @@
+!
+! $Header$
+!
+      subroutine wrgrads(if,nl,field,name,titlevar)
+      implicit none
+
+!c   Declarations
+!c    if indice du fichier
+!c    nl nombre de couches
+!c    field   champ
+!c    name    petit nom
+!c    titlevar   Titre
+
+#include "gradsdef.h"
+
+!c   arguments
+      integer if,nl
+      real field(imx*jmx*lmx)
+
+      integer, parameter:: wp = selected_real_kind(p=6, r=36)
+      real(wp) field4(imx*jmx*lmx)
+
+      character*10 name,file
+      character*10 titlevar
+
+!c   local
+
+      integer im,jm,lm,i,j,l,iv,iii,iji,iif,ijf
+
+      logical writectl
+
+
+      writectl=.false.
+
+!c     print*,if,iid(if),jid(if),ifd(if),jfd(if)
+      iii=iid(if)
+      iji=jid(if)
+      iif=ifd(if)
+      ijf=jfd(if)
+      im=iif-iii+1
+      jm=ijf-iji+1
+      lm=lmd(if)
+
+!c     print*,'im,jm,lm,name,firsttime(if)'
+!c     print*,im,jm,lm,name,firsttime(if)
+
+      if(firsttime(if)) then
+         if(name.eq.var(1,if)) then
+            firsttime(if)=.false.
+            ivar(if)=1
+         print*,'fin de l initialiation de l ecriture du fichier'
+         print*,file
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+         else
+            ivar(if)=ivar(if)+1
+            nvar(if)=ivar(if)
+            var(ivar(if),if)=name
+            tvar(ivar(if),if)=trim(titlevar)
+            nld(ivar(if),if)=nl
+!c           print*,'initialisation ecriture de ',var(ivar(if),if)
+!c           print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if)
+         endif
+         writectl=.true.
+         itime(if)=1
+      else
+         ivar(if)=mod(ivar(if),nvar(if))+1
+         if (ivar(if).eq.nvar(if)) then
+            writectl=.true.
+            itime(if)=itime(if)+1
+         endif
+
+         if(var(ivar(if),if).ne.name) then
+           print*,'Il faut stoker la meme succession de champs a chaque'
+           print*,'pas de temps'
+           print*,'fichier no: ',if
+           print*,'unit ',unit(if)
+           print*,'nvar  ',nvar(if)
+           print*,'vars ',(var(iv,if),iv=1,nvar(if))
+
+           stop
+         endif
+      endif
+
+!c     print*,'ivar(if),nvar(if),var(ivar(if),if),writectl'
+!c     print*,ivar(if),nvar(if),var(ivar(if),if),writectl
+      field4(1:imd(if)*jmd(if)*nl)=field(1:imd(if)*jmd(if)*nl)
+      do l=1,nl
+         irec(if)=irec(if)+1
+!c        print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf,
+!c    s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii
+!c    s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif
+         write(unit(if)+1,rec=irec(if))                                              &
+       &   ((field4((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i)                           &
+       &   ,i=iii,iif),j=iji,ijf)
+      enddo
+      if (writectl) then
+
+      file=fichier(if)
+!c   WARNING! on reecrase le fichier .ctl a chaque ecriture
+      open(unit(if),file=trim(file)//'.ctl'                                          &
+       &         ,form='formatted',status='unknown')
+      write(unit(if),'(a5,1x,a40)')                                                  &
+       &       'DSET ','^'//trim(file)//'.dat'
+
+      write(unit(if),'(a12)') 'UNDEF 1.0E30'
+      write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if)
+      call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF')
+      call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF')
+      call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF')
+      write(unit(if),'(a4,i10,a30)')                                                 &
+       &       'TDEF ',itime(if),' LINEAR 02JAN1987 1MO '
+      write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if)
+      do iv=1,nvar(if)
+!c        print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)'
+!c        print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)
+         write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if)                     &
+       &     ,99,tvar(iv,if)
+      enddo
+      write(unit(if),'(a7)') 'ENDVARS'
+!c
+1000  format(a5,3x,i4,i3,1x,a39)
+
+      close(unit(if))
+
+      endif ! writectl
+
+      return
+
+      END
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/wrgradsfi.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/wrgradsfi.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/wrgradsfi.F	(revision 17)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+      subroutine wrgradsfi(if,nl,fieldfi_p,name,titlevar)
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      implicit none
+
+c   Declarations
+
+#include "dimensions.h"
+cym#include "dimphy.h"
+
+c   arguments
+      integer if,nl
+      real fieldfi_p(klon,nl)
+      real fieldfi(klon_glo,nl)
+      real fielddyn((iim+1)*(jjm+1),llm)
+      character*10 name
+      character*10 titlevar
+
+c   local
+
+      integer lm,l
+
+
+
+c     print*,'Transformation pour ',name
+      call Gather(fieldfi_p,fieldfi)
+
+c$OMP MASTER      
+      if (is_mpi_root) then
+        call gr_fi_dyn(nl,klon,iim+1,jjm+1,fieldfi,fielddyn)
+        
+c     print*,'Transformation OK '
+        call wrgrads(if,nl,fielddyn,name,titlevar)
+c     print*,'Ecriture ok'
+      endif
+c$OMP END MASTER
+      
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/wrgradsfi.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/wrgradsfi.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/wrgradsfi.F90	(revision 17)
@@ -0,0 +1,43 @@
+!
+! $Header$
+!
+      subroutine wrgradsfi(if,nl,fieldfi_p,name,titlevar)
+      USE dimphy
+      USE mod_grid_phy_lmdz
+      USE mod_phys_lmdz_para
+      implicit none
+
+!c   Declarations
+
+#include "dimensions.h"
+!cym#include "dimphy.h"
+
+!c   arguments
+      integer if,nl
+      real fieldfi_p(klon,nl)
+      real fieldfi(klon_glo,nl)
+      real fielddyn((iim+1)*(jjm+1),llm)
+      character*10 name
+      character*10 titlevar
+
+!c   local
+
+      integer lm,l
+
+
+
+!c     print*,'Transformation pour ',name
+      call Gather(fieldfi_p,fieldfi)
+
+!$OMP MASTER      
+      if (is_mpi_root) then
+        call gr_fi_dyn(nl,klon,iim+1,jjm+1,fieldfi,fielddyn)
+        
+!c     print*,'Transformation OK '
+        call wrgrads(if,nl,fielddyn,name,titlevar)
+!c     print*,'Ecriture ok'
+      endif
+!$OMP END MASTER
+      
+      return
+      end subroutine wrgradsfi
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/write_field.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/write_field.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/write_field.F90	(revision 17)
@@ -0,0 +1,326 @@
+!
+! $Id: write_field.F90 1279 2009-12-10 09:02:56Z fairhead $
+!
+module write_field
+implicit none
+
+  integer, parameter :: MaxWriteField = 100
+  integer, dimension(MaxWriteField),save :: FieldId
+  integer, dimension(MaxWriteField),save :: FieldVarId
+  integer, dimension(MaxWriteField),save :: FieldIndex
+  character(len=255), dimension(MaxWriteField) ::  FieldName 
+   
+  integer,save :: NbField = 0
+  
+  interface WriteField
+    module procedure WriteField3d,WriteField2d,WriteField1d
+  end interface WriteField
+  contains
+  
+    function GetFieldIndex(name)
+    implicit none
+      integer          :: GetFieldindex
+      character(len=*) :: name
+    
+      character(len=255) :: TrueName
+      integer            :: i
+       
+      
+      TrueName=TRIM(ADJUSTL(name))
+    
+      GetFieldIndex=-1
+      do i=1,NbField
+        if (TrueName==FieldName(i)) then
+          GetFieldIndex=i
+          exit
+        endif
+      enddo
+    end function GetFieldIndex
+ 
+    subroutine WriteField3d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:,:,:) :: Field 
+      integer, dimension(3) :: Dim
+      
+      Dim=shape(Field)
+      call WriteField_gen(name,Field,Dim(1),Dim(2),Dim(3))  
+  
+    end subroutine WriteField3d
+    
+    subroutine WriteField2d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:,:) :: Field 
+      integer, dimension(2) :: Dim
+      
+      Dim=shape(Field)
+      call WriteField_gen(name,Field,Dim(1),Dim(2),1)  
+  
+    end subroutine WriteField2d
+    
+    subroutine WriteField1d(name,Field)
+    implicit none
+      character(len=*) :: name
+      real, dimension(:) :: Field 
+      integer, dimension(1) :: Dim
+      
+      Dim=shape(Field)
+      call WriteField_gen(name,Field,Dim(1),1,1)  
+  
+    end subroutine WriteField1d
+        
+    subroutine WriteField_gen(name,Field,dimx,dimy,dimz)
+    implicit none
+    include 'netcdf.inc'
+      character(len=*) :: name
+      integer :: dimx,dimy,dimz
+      real,dimension(dimx,dimy,dimz) :: Field
+      integer,dimension(dimx*dimy*dimz) :: ndex
+      integer :: status
+      integer :: index
+      integer :: start(4)
+      integer :: count(4)
+      
+           
+      Index=GetFieldIndex(name)
+      if (Index==-1) then
+        call CreateNewField(name,dimx,dimy,dimz)
+	Index=GetFieldIndex(name)
+      else
+        FieldIndex(Index)=FieldIndex(Index)+1.
+      endif
+      
+      start(1)=1
+      start(2)=1
+      start(3)=1
+      start(4)=FieldIndex(Index)
+
+      count(1)=dimx
+      count(2)=dimy
+      count(3)=dimz
+      count(4)=1
+
+      status = NF_PUT_VARA_DOUBLE(FieldId(Index),FieldVarId(Index),start,count,Field)
+      status = NF_SYNC(FieldId(Index))
+      
+    end subroutine WriteField_gen
+       
+    subroutine CreateNewField(name,dimx,dimy,dimz)
+    implicit none
+    include 'netcdf.inc'  
+      character(len=*) :: name
+      integer :: dimx,dimy,dimz
+      integer :: TabDim(4)
+      integer :: status
+      
+      
+      NbField=NbField+1
+      FieldName(NbField)=TRIM(ADJUSTL(name))
+      FieldIndex(NbField)=1
+      
+      
+      status = NF_CREATE(TRIM(ADJUSTL(name))//'.nc', NF_CLOBBER, FieldId(NbField))
+      status = NF_DEF_DIM(FieldId(NbField),'X',dimx,TabDim(1))
+      status = NF_DEF_DIM(FieldId(NbField),'Y',dimy,TabDim(2))
+      status = NF_DEF_DIM(FieldId(NbField),'Z',dimz,TabDim(3))
+      status = NF_DEF_DIM(FieldId(NbField),'iter',NF_UNLIMITED,TabDim(4))
+      status = NF_DEF_VAR(FieldId(NbField),FieldName(NbField),NF_DOUBLE,4,TabDim,FieldVarId(NbField))
+      status = NF_ENDDEF(FieldId(NbField))
+
+    end subroutine CreateNewField
+    
+    
+    
+  subroutine write_field1D(name,Field)
+    implicit none
+  
+    integer, parameter :: MaxDim=1
+    character(len=*)   :: name
+    real, dimension(:) :: Field
+    real, dimension(:),allocatable :: New_Field
+    character(len=20) :: str
+    integer, dimension(MaxDim) :: Dim
+    integer :: i,nb
+    integer, parameter :: id=10
+    integer, parameter :: NbCol=4
+    integer :: ColumnSize 
+    integer :: pos
+    character(len=255) :: form
+    character(len=255) :: MaxLen
+    
+    
+    open(unit=id,file=name//'.field',form='formatted',status='replace')
+    write (id,'("----- Field '//name//'",//)')
+    Dim=shape(Field)
+    MaxLen=int2str(len(trim(int2str(Dim(1)))))
+    ColumnSize=20+6+3+len(trim(int2str(Dim(1))))
+    Nb=0
+    Pos=2
+    do i=1,Dim(1)
+      nb=nb+1
+      
+      if (MOD(nb,NbCol)==0) then
+        form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16,/)'
+        Pos=2
+      else
+        form='(t'//trim(int2str(pos))// ',i'//trim(MaxLen) //'," ---> ",g22.16," | ",)'
+        Pos=Pos+ColumnSize
+      endif
+      write (id,form,advance='no') i,Field(i)
+    enddo
+     
+    close(id)
+
+  end subroutine write_field1D
+
+  subroutine write_field2D(name,Field)
+    implicit none
+  
+    integer, parameter :: MaxDim=2
+    character(len=*)   :: name
+    real, dimension(:,:) :: Field
+    real, dimension(:,:),allocatable :: New_Field
+    character(len=20) :: str
+    integer, dimension(MaxDim) :: Dim
+    integer :: i,j,nb
+    integer, parameter :: id=10
+    integer, parameter :: NbCol=4
+    integer :: ColumnSize 
+    integer :: pos,offset
+    character(len=255) :: form
+    character(len=255) :: spacing
+    
+    open(unit=id,file=name//'.field',form='formatted',status='replace')
+    write (id,'("----- Field '//name//'",//)')
+    
+    Dim=shape(Field)
+    offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+3
+    ColumnSize=20+6+3+offset
+
+    spacing='(t2,"'//repeat('-',ColumnSize*NbCol)//'")'
+    
+    do i=1,Dim(2)
+      nb=0
+      Pos=2
+      do j=1,Dim(1)
+        nb=nb+1
+      
+        if (MOD(nb,NbCol)==0) then
+          form='(t'//trim(int2str(pos))//            &
+               ',"('//trim(int2str(j))//','          &
+                    //trim(int2str(i))//')",t'       & 
+                    //trim(int2str(pos+offset))     &    
+                    //'," ---> ",g22.16,/)'
+          Pos=2
+        else
+          form='(t'//trim(int2str(pos))//            &
+               ',"('//trim(int2str(j))//','          &
+                    //trim(int2str(i))//')",t'       & 
+                    //trim(int2str(pos+offset))     &    
+                    //'," ---> ",g22.16," | ")'
+          Pos=Pos+ColumnSize
+        endif
+        write (id,form,advance='no') Field(j,i)
+      enddo
+      if (MOD(nb,NbCol)==0) then
+        write (id,spacing)
+      else
+        write (id,'("")')
+        write (id,spacing)
+      endif
+    enddo
+     
+  end subroutine write_field2D
+  
+  subroutine write_field3D(name,Field)
+    implicit none
+  
+    integer, parameter :: MaxDim=3
+    character(len=*)   :: name
+    real, dimension(:,:,:) :: Field
+    real, dimension(:,:,:),allocatable :: New_Field
+    integer, dimension(MaxDim) :: Dim
+    integer :: i,j,k,nb
+    integer, parameter :: id=10
+    integer, parameter :: NbCol=4
+    integer :: ColumnSize 
+    integer :: pos,offset
+    character(len=255) :: form
+    character(len=255) :: spacing
+
+    open(unit=id,file=name//'.field',form='formatted',status='replace')
+    write (id,'("----- Field '//name//'"//)')
+    
+    Dim=shape(Field)
+    offset=len(trim(int2str(Dim(1))))+len(trim(int2str(Dim(2))))+len(trim(int2str(Dim(3))))+4
+    ColumnSize=22+6+3+offset
+
+!    open(unit=id,file=name,form=formatted
+   
+    spacing='(t2,"'//repeat('-',ColumnSize*NbCol)//'")'
+    
+    do i=1,Dim(3)
+    
+      do j=1,Dim(2)
+        nb=0
+        Pos=2
+        
+        do k=1,Dim(1)
+        nb=nb+1
+      
+          if (MOD(nb,NbCol)==0) then
+            form='(t'//trim(int2str(pos))//            &
+                 ',"('//trim(int2str(k))//','          &
+                      //trim(int2str(j))//','          &
+                      //trim(int2str(i))//')",t'       & 
+                      //trim(int2str(pos+offset))      &    
+                      //'," ---> ",g22.16,/)'
+           Pos=2
+          else
+            form='(t'//trim(int2str(pos))//            &
+                 ',"('//trim(int2str(k))//','          &
+                      //trim(int2str(j))//','          &
+                      //trim(int2str(i))//')",t'       & 
+                      //trim(int2str(pos+offset))      &    
+                      //'," ---> ",g22.16," | ")'
+! dépent de l'implémention, sur compaq, c'est necessaire
+!            Pos=Pos+ColumnSize
+          endif
+          write (id,form,advance='no') Field(k,j,i)
+        enddo
+        if (MOD(nb,NbCol)==0) then
+          write (id,spacing)
+        else
+          write (id,'("")')
+          write (id,spacing)
+        endif
+      enddo
+      write (id,spacing)
+    enddo
+    
+    close(id)
+  
+  end subroutine write_field3D  
+  
+  function int2str(int)
+    implicit none
+    integer, parameter :: MaxLen=10
+    integer,intent(in) :: int
+    character(len=MaxLen) :: int2str
+    logical :: flag
+    integer :: i
+    flag=.true.
+    
+    i=int
+    
+    int2str=''
+    do while (flag)
+      int2str=CHAR(MOD(i,10)+48)//int2str
+      i=i/10
+      if (i==0) flag=.false.
+    enddo
+  end function int2str
+
+end module write_field
+  
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/write_field_phy.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/write_field_phy.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/write_field_phy.F90	(revision 17)
@@ -0,0 +1,36 @@
+!
+! $Header$
+!
+MODULE write_field_phy
+
+  CONTAINS 
+ 
+    SUBROUTINE WriteField_phy(name,Field,ll)
+    USE dimphy
+    USE mod_phys_lmdz_para
+    USE mod_grid_phy_lmdz
+    USE Write_Field
+    
+    IMPLICIT NONE
+    include 'dimensions.h'
+    include 'paramet.h'
+
+    character(len=*)   :: name
+    INTEGER :: ll
+    real, dimension(klon_omp,ll) :: Field
+    real,save,allocatable :: Field_tmp(:,:)
+    real, dimension(klon_glo,ll):: New_Field
+    real, dimension(iim,jjp1,ll):: Field_2d
+
+    CALL Gather(Field,New_Field)
+!$OMP MASTER
+    IF (is_mpi_root) THEN	
+      CALL Grid1Dto2D_glo(New_Field,Field_2D)
+      CALL WriteField(name,Field_2d)
+    ENDIF
+!$OMP END MASTER
+
+  
+   END SUBROUTINE WriteField_phy
+ 
+ END MODULE write_field_phy
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histISCCP.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histISCCP.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histISCCP.h	(revision 17)
@@ -0,0 +1,222 @@
+!
+! $Id: write_histISCCP.h 1665 2012-10-09 13:35:26Z fairhead $
+!
+      IF (ok_isccp) THEN
+!c
+       IF (MOD(itap,NINT(freq_ISCCP/dtime)).EQ.0) THEN
+!c
+       ndex2d = 0
+       ndex3d = 0
+!c
+       itau_w = itau_phy + itap + start_time * day_step / iphysiq
+!c
+       IF(type_run.EQ."ENSP".OR.type_run.EQ."CLIM") THEN
+!c
+        DO n=1, napisccp
+!c
+        DO k=1,kmaxm1
+         zx_tmp_fi3d(1:klon, 1:lmaxm1)=fq_isccp(1:klon,k,1:lmaxm1,n)*100.
+!cym         CALL gr_fi_ecrit(lmaxm1,klon,iim,jjmp1,zx_tmp_fi3d,
+!cym     .                    zx_tmp_3d)
+!c
+!IM: champ 3d : (lon,lat,pres) pour un tau fixe
+!c
+      CALL histwrite_phy(nid_isccp,"cldISCCP_"//taulev(k)//verticaxe(n),             &
+       &                  itau_w,zx_tmp_fi3d)
+        ENDDO !k
+!c
+!cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,nbsunlit(1,:,n),zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"nsunlit"//verticaxe(n),itau_w,                 &
+       &                 nbsunlit(1,:,n))
+!c
+       CALL histwrite_phy(nid_isccp,"meantaucld"//verticaxe(n),itau_w,               &
+       &                 meantaucld(:,n))
+!c
+        ENDDO ! n=1, napisccp
+        ELSE IF(type_run.EQ."AMIP".OR.type_run.EQ."CFMI") THEN
+!c
+        DO n=1, napisccp
+!c        print*,'n=',n,' write_ISCCP avant fq_isccp'
+         DO k=1, kmaxm1
+          DO l=1, lmaxm1
+!c
+         IF(top_height.LE.2) THEN
+          DO i=1, klon
+!c281008 beg
+!c          print*,'write_ISCCP i n nbsunlit',i,n,nbsunlit(1,i,n)
+!c281008 end
+!c
+           IF(nbsunlit(1,i,n).NE.0.) THEN
+            fq_is_true(i,k,l,n)=                                                     &
+       &      fq_isccp(i,k,l,n)*100./nbsunlit(1,i,n)
+           ELSE
+            fq_is_true(i,k,l,n)=0
+           ENDIF
+          ENDDO 
+         ELSE IF(top_height.EQ.3) THEN 
+          DO i=1, klon
+           fq_is_true(i,k,l,n) = fq_isccp(i,k,l,n)*100.
+          ENDDO
+         ENDIF
+!cym         CALL gr_fi_ecrit(1,klon,iim,jjmp1,fq_is_true,
+!cym     .                    zx_tmp_2d)
+!c
+!IM: champ 2d : (lon,lat) pour un tau et une pc fixes
+!c
+         CALL histwrite_phy(nid_isccp,pclev(l)//taulev(k)//verticaxe(n),             &
+       &                  itau_w,fq_is_true(:,k,l,n))
+         ENDDO !l
+        ENDDO !k
+!c
+!c       print*,'n=',n,' write_ISCCP avant nbsunlit'
+!cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,nbsunlit(1,:,n),zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"nsunlit"//verticaxe(n),                        &
+       &                 itau_w,nbsunlit(1,:,n))
+!c
+       CALL histwrite_phy(nid_isccp,"meantaucld"//verticaxe(n),itau_w,               &
+       &                 meantaucld(:,n))
+!c
+        zx_tmp_fi2d(1:klon)=REAL(seed(1:klon,n))
+!c
+!c       print*,'n=',n,' write_ISCCP avant seed'
+!cym        CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"seed"//verticaxe(n),                           &
+       &                 itau_w,zx_tmp_fi2d)
+!c
+!c 9types de nuages ISCCP-D2
+!c fq_isccp(1:klon,k,l,n)*100. <=> pc_tau(k)_pclev(l)
+        DO i=1, klon
+         zx_tmp_fi2d(i)=                                                             &
+       & (fq_is_true(i,1,1,n)+ fq_is_true(i,2,1,n)+ fq_is_true(i,3,1,n) +            &
+       &  fq_is_true(i,1,2,n)+ fq_is_true(i,2,2,n)+ fq_is_true(i,3,2,n) +            &
+       &  fq_is_true(i,1,3,n)+ fq_is_true(i,2,3,n)+ fq_is_true(i,3,3,n) )
+        ENDDO
+!cym       CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"cirr",itau_w,zx_tmp_fi2d)
+!c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=                                                             &
+       &  (fq_is_true(i,4,1,n)+ fq_is_true(i,5,1,n) +                                &
+       &   fq_is_true(i,4,2,n)+ fq_is_true(i,5,2,n) +                                &
+       &   fq_is_true(i,4,3,n)+ fq_is_true(i,5,3,n) )
+        ENDDO
+!cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"cist",itau_w,zx_tmp_fi2d)
+!c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=                                                             &
+       &  (fq_is_true(i,6,1,n)+ fq_is_true(i,7,1,n) +                                &
+       &   fq_is_true(i,6,2,n)+ fq_is_true(i,7,2,n) +                                &
+       &   fq_is_true(i,6,3,n)+ fq_is_true(i,7,3,n) )
+        ENDDO
+!cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"deep",itau_w,zx_tmp_fi2d)
+!c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=                                                             &
+       & (fq_is_true(i,1,4,n)+ fq_is_true(i,2,4,n)+ fq_is_true(i,3,4,n) +            &
+       &  fq_is_true(i,1,5,n)+ fq_is_true(i,2,5,n)+ fq_is_true(i,3,5,n) )
+        ENDDO
+!cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"alcu",itau_w,zx_tmp_fi2d)
+!c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=                                                             &
+       &  (fq_is_true(i,4,4,n)+ fq_is_true(i,5,4,n) +                                &
+       &   fq_is_true(i,4,5,n)+ fq_is_true(i,5,5,n) )
+        ENDDO
+!cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"alst",itau_w,zx_tmp_fi2d)
+!c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=                                                             &
+       &  (fq_is_true(i,6,4,n)+ fq_is_true(i,7,4,n) +                                &
+       &   fq_is_true(i,6,5,n)+ fq_is_true(i,7,5,n) )
+        ENDDO
+!cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"nist",itau_w,zx_tmp_fi2d)
+!c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=                                                             &
+       & (fq_is_true(i,1,6,n)+ fq_is_true(i,2,6,n)+ fq_is_true(i,3,6,n) +            &
+       &  fq_is_true(i,1,7,n)+ fq_is_true(i,2,7,n)+ fq_is_true(i,3,7,n) )
+        ENDDO
+!cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"cumu",itau_w,zx_tmp_fi2d)
+!c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=                                                             &
+       &  (fq_is_true(i,4,6,n)+ fq_is_true(i,5,6,n) +                                &
+       &   fq_is_true(i,4,7,n)+ fq_is_true(i,5,7,n) )
+        ENDDO
+!cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"stcu",itau_w,zx_tmp_fi2d)
+!c
+        DO i=1, klon
+         zx_tmp_fi2d(i)=                                                             &
+       &  (fq_is_true(i,6,6,n)+ fq_is_true(i,7,6,n) +                                &
+       &   fq_is_true(i,6,7,n)+ fq_is_true(i,7,7,n) )
+        ENDDO
+!cym	CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+        CALL histwrite_phy(nid_isccp,"stra",itau_w,zx_tmp_fi2d)
+!c
+!c 3_tau_nuages x 3_levels
+!c fq_is_true(1:klon,k,l,n)*100. <=> pc_tau(k)_pclev(l)
+        DO i=1, klon
+         cld_fi3d(i,1)=                                                              &
+       & (fq_is_true(i,1,1,n)+ fq_is_true(i,2,1,n)+ fq_is_true(i,3,1,n) +            &
+       &  fq_is_true(i,1,2,n)+ fq_is_true(i,2,2,n)+ fq_is_true(i,3,2,n) +            &
+       &  fq_is_true(i,1,3,n)+ fq_is_true(i,2,3,n)+ fq_is_true(i,3,3,n) )
+	 cld_fi3d(i,2)=                                                                     &
+       & (fq_is_true(i,1,4,n)+ fq_is_true(i,2,4,n)+ fq_is_true(i,3,4,n) +            &
+       &  fq_is_true(i,1,5,n)+ fq_is_true(i,2,5,n)+ fq_is_true(i,3,5,n) )
+         cld_fi3d(i,3)=                                                              &
+       & (fq_is_true(i,1,6,n)+ fq_is_true(i,2,6,n)+ fq_is_true(i,3,6,n) +            &
+       &  fq_is_true(i,1,7,n)+ fq_is_true(i,2,7,n)+ fq_is_true(i,3,7,n) )
+        ENDDO   
+!cym        CALL gr_fi_ecrit(lmax3,klon,iim,jjmp1,cld_fi3d,cld_3d)
+        CALL histwrite_phy(nid_isccp,"thin",itau_w,cld_fi3d)
+!c
+        DO i=1, klon
+	 cld_fi3d(i,1)=                                                                     &
+       &   (fq_is_true(i,4,1,n)+ fq_is_true(i,5,1,n) +                               &
+       &    fq_is_true(i,4,2,n)+ fq_is_true(i,5,2,n) +                               &
+       &    fq_is_true(i,4,3,n)+ fq_is_true(i,5,3,n) )
+	 cld_fi3d(i,2)=                                                                     &
+       &   (fq_is_true(i,4,4,n)+ fq_is_true(i,5,4,n) +                               &
+       &    fq_is_true(i,4,5,n)+ fq_is_true(i,5,5,n) )
+	 cld_fi3d(i,3)=                                                                     &
+       &   (fq_is_true(i,4,6,n)+ fq_is_true(i,5,6,n) +                               &
+       &    fq_is_true(i,4,7,n)+ fq_is_true(i,5,7,n) )
+	ENDDO   
+!cym       CALL gr_fi_ecrit(lmax3, klon,iim,jjmp1,cld_fi3d,cld_3d)
+        CALL histwrite_phy(nid_isccp,"mid",itau_w,cld_fi3d)
+!c
+        DO i=1, klon
+	 cld_fi3d(i,1)=                                                                     &
+       &   (fq_is_true(i,6,1,n)+ fq_is_true(i,7,1,n) +                               &
+       &    fq_is_true(i,6,2,n)+ fq_is_true(i,7,2,n) +                               &
+       &    fq_is_true(i,6,3,n)+ fq_is_true(i,7,3,n) )
+         cld_fi3d(i,2)=                                                              &
+       &   (fq_is_true(i,6,4,n)+ fq_is_true(i,7,4,n) +                               &
+       &    fq_is_true(i,6,5,n)+ fq_is_true(i,7,5,n) )
+	 cld_fi3d(i,3)=                                                                     &
+       &   (fq_is_true(i,6,6,n)+ fq_is_true(i,7,6,n) +                               &
+       &    fq_is_true(i,6,7,n)+ fq_is_true(i,7,7,n) )
+        ENDDO   
+!cym       CALL gr_fi_ecrit(lmax3, klon,iim,jjmp1,cld_fi3d,cld_3d)
+        CALL histwrite_phy(nid_isccp,"thick",itau_w,cld_fi3d)
+!c
+        ENDDO ! n=1, napisccp
+!c
+       ENDIF
+!c
+       if (ok_sync) then
+!$OMP MASTER
+        call histsync(nid_isccp)
+!$OMP END MASTER       
+       endif
+
+       ENDIF !(MOD(itap,NINT(freq_ISCCP/dtime)).EQ.0) THEN
+
+      ENDIF !ok_isccp
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histdayNMC.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histdayNMC.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histdayNMC.h	(revision 17)
@@ -0,0 +1,58 @@
+!
+! $Header$
+!
+      IF (ok_histNMC(2)) THEN
+!c
+       ndex3d = 0
+       itau_w = itau_phy + itap + start_time * day_step / iphysiq
+!ccc
+!c  Champs interpolles sur des niveaux de pression du NMC
+!c
+!c     PARAMETER(nout=3) 
+!c nout=1 : in=pdtphys,    out=mth
+!c nout=2 : in=pdtphys,    out=day
+!c nout=3 : in=pdtphys,    out=hf
+!ccc
+      IF(lev_histdayNMC.EQ.nlevSTD) THEN
+       CALL histwrite_phy(nid_daynmc,lNMC,"tnondef",itau_w,                          &
+       &tnondef(:,:,2))
+       CALL histwrite_phy(nid_daynmc,lNMC,"ta",itau_w,                               &
+       &twriteSTD(:,:,2))
+       CALL histwrite_phy(nid_daynmc,lNMC,"zg",itau_w,                               &
+       &phiwriteSTD(:,:,2))
+       CALL histwrite_phy(nid_daynmc,lNMC,"hus",itau_w,                              &
+       &qwriteSTD(:,:,2))
+       CALL histwrite_phy(nid_daynmc,lNMC,"hur",itau_w,                              &
+       &rhwriteSTD(:,:,2))
+       CALL histwrite_phy(nid_daynmc,lNMC,"ua",itau_w,                               &
+       &uwriteSTD(:,:,2))
+       CALL histwrite_phy(nid_daynmc,lNMC,"va",itau_w,                               &
+       &vwriteSTD(:,:,2))
+       CALL histwrite_phy(nid_daynmc,lNMC,"wap",itau_w,                              &
+       &wwriteSTD(:,:,2))
+      ELSE IF(lev_histdayNMC.EQ.nlevSTD8) THEN
+       CALL histwrite_phy(nid_daynmc,lNMC,"tnondef",itau_w,                          &
+       &tnondefSTD8)
+       CALL histwrite_phy(nid_daynmc,lNMC,"ta",itau_w,                               &
+       &twriteSTD8)
+       CALL histwrite_phy(nid_daynmc,lNMC,"zg",itau_w,                               &
+       &phiwriteSTD8)
+       CALL histwrite_phy(nid_daynmc,lNMC,"hus",itau_w,                              &
+       &qwriteSTD8)
+       CALL histwrite_phy(nid_daynmc,lNMC,"hur",itau_w,                              &
+       &rhwriteSTD8)
+       CALL histwrite_phy(nid_daynmc,lNMC,"ua",itau_w,                               &
+       &uwriteSTD8)
+       CALL histwrite_phy(nid_daynmc,lNMC,"va",itau_w,                               &
+       &vwriteSTD8)
+       CALL histwrite_phy(nid_daynmc,lNMC,"wap",itau_w,                              &
+       &wwriteSTD8)
+      ENDIF
+!c
+      if (ok_sync) then
+!$OMP MASTER
+        call histsync(nid_daynmc)
+!$OMP END MASTER
+      endif
+!c
+      ENDIF ! (ok_histNMC(2)) THEN
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histday_seri.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histday_seri.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histday_seri.h	(revision 17)
@@ -0,0 +1,242 @@
+!c
+!c $Header$
+!c
+      IF (is_sequential) THEN
+      
+      IF (type_run.EQ."AMIP") THEN
+!c
+      ndex2d = 0
+      itau_w = itau_phy + itap + start_time * day_step / iphysiq
+!c
+!c Champs 2D:
+!c
+      pi = ACOS(-1.)
+      pir = 4.0*ATAN(1.0) / 180.0
+!c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=(topsw(i)-toplw(i))
+      ENDDO
+!c
+      ok_msk=.FALSE.
+      msk(1:klon)=pctsrf(1:klon,is_ter)
+      CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy,                               &
+       &     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+!c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"bilTOA",itau_w,                                   &
+       &               zx_tmp_2d,iim*jjmp1,ndex2d)
+!c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, bils, airephy,                                      &
+       &     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+!c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"bils",itau_w,                                     &
+       &               zx_tmp_2d,iim*jjmp1,ndex2d)
+!c
+      DO k=1, klev
+      DO i=1, klon
+!IM 080904    zx_tmp_fi3d(i,k)=u(i,k)**2+v(i,k)**2
+       zx_tmp_fi3d(i,k)=(u(i,k)**2+v(i,k)**2)/2.
+      ENDDO
+      ENDDO
+!c
+      CALL moyglo_pondaima(klon, klev, zx_tmp_fi3d,                                  &
+       &     airephy, paprs, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+!c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"ecin",itau_w,                                     &
+       &               zx_tmp_2d,iim*jjmp1,ndex2d) 
+!c
+!IM 151004 BEG
+      IF(1.EQ.0) THEN
+!c
+      DO k=1, klev
+      DO i=1, klon
+       zx_tmp_fi3d(i,k)=u_seri(i,k)*RA*cos(pir* rlat(i))
+      ENDDO
+      ENDDO
+!c
+      CALL moyglo_pondaima(klon, klev, zx_tmp_fi3d,                                  &
+       &     airephy, paprs, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+!c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"momang",itau_w,zx_tmp_2d,                         &
+       &               iim*jjmp1,ndex2d)
+!c
+!c friction torque
+!c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=zxfluxu(i,1)*RA* cos(pir* rlat(i))
+      ENDDO
+!c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy,                               &
+       &     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+!c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"frictor",itau_w,zx_tmp_2d,                        &
+       &               iim*jjmp1,ndex2d)
+!c
+!c mountain torque
+!c
+!IM 190504 BEG
+      CALL gr_fi_dyn(1,klon,iim+1,jjm+1,airephy,airedyn)
+      CALL gr_fi_dyn(klev+1,klon,iim+1,jjm+1,paprs,padyn)
+      CALL gr_fi_dyn(1,klon,iim+1,jjm+1,rlat,rlatdyn)
+      mountor=0.
+      airetot=0.
+      DO j = 1, jjmp1
+       DO i = 1, iim+1
+        ij=i+(iim+1)*(j-1)
+        zx_tmp(ij)=0.
+        DO k = 1, klev
+         zx_tmp(ij)=zx_tmp(ij)+dudyn(i,j,k)*airedyn(i,j)*                            &
+       &              (padyn(i,j,k+1)-padyn(i,j,k))/RG
+         airetot=airetot+airedyn(i,j)
+        ENDDO
+!IM 190504 mountor=mountor+zx_tmp(ij)*airedyn(i,j)*RA*
+        mountor=mountor+zx_tmp(ij)*RA*                                               &
+       &           cos(pir* rlatdyn(i,j))
+       ENDDO
+      ENDDO
+!IM 151004 BEG
+      IF(itap.EQ.1) PRINT*,'airetot=',airetot,airetot/klev
+!IM 151004 END
+!IM 190504      mountor=mountor/(airetot*airetot)
+      mountor=mountor/airetot
+!c
+!IM 190504 END
+      zx_tmp_2d(1:iim,1:jjmp1)=mountor
+      CALL histwrite(nid_day_seri,"mountor",itau_w,zx_tmp_2d,                        &
+       &               iim*jjmp1,ndex2d)
+!c
+      ENDIF !(1.EQ.0) THEN
+!c
+!c
+      CALL gr_fi_dyn(1,klon,iim+1,jjm+1,airephy,airedyn)
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,airephy,zx_tmp_2d)
+      airetot=0.
+!c     DO j = 1, jjmp1
+!c      DO i = 1, iim+1
+!c       ij=i+(iim+1)*(j-1)
+!c       DO k = 1, klev
+!c        airetot=airetot+airedyn(i,j)
+!c        airetot=airetot+airedyn(i,j)
+!c       ENDDO !k
+!c      ENDDO !i
+!c     ENDDO !j
+!c
+      DO i=1, klon
+       airetot=airetot+airephy(i)
+      ENDDO
+!c     IF(itap.EQ.1) PRINT*,'airetotphy=',airetot
+!c
+      airetot=0.
+      DO j=1, jjmp1
+       DO i=1, iim
+        airetot=airetot+zx_tmp_2d(i,j)
+       ENDDO
+      ENDDO
+!c
+!c     IF(itap.EQ.1) PRINT*,'airetotij=',airetot,
+!c    $ '4piR2',4.*pi*RA*RA
+!c
+      zx_tmp_fi2d(1:klon)=aam/airetot
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"momang",itau_w,zx_tmp_2d,                         &
+       &               iim*jjmp1,ndex2d)
+!c
+      zx_tmp_fi2d(1:klon)=torsfc/airetot
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"torsfc",itau_w,zx_tmp_2d,                         &
+       &               iim*jjmp1,ndex2d)
+!c
+!IM 151004 END
+!c
+      CALL moyglo_pondmass(klon, klev, t_seri,                                       &
+       &     airephy, paprs, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+!c
+      CALL gr_fi_ecrit(1,klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"tamv",itau_w,                                     &
+       &               zx_tmp_2d,iim*jjmp1,ndex2d)
+!c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, paprs(:,1), airephy,                                &
+       &     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+!c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"psol",itau_w,                                     &
+       &               zx_tmp_2d,iim*jjmp1,ndex2d)
+!c
+      ok_msk=.FALSE.
+      CALL moyglo_pondaire(klon, evap, airephy,                                      &
+       &     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+!c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d,zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"evap",itau_w,                                     &
+       &               zx_tmp_2d,iim*jjmp1,ndex2d)
+!c
+!c     DO i=1, klon
+!c      zx_tmp_fi2d(i)=SnowFrac(i,is_ter)
+!c     ENDDO
+!c
+!c     ok_msk=.TRUE.
+!c     msk(1:klon)=pctsrf(1:klon,is_ter)
+!c     CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+!c    .                     ok_msk, msk, moyglo)
+!c     zx_tmp_fi2d(1:klon)=moyglo
+!c
+!c     CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+!c     CALL histwrite(nid_day_seri,"SnowFrac",
+!c    .               itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) 
+!c
+!c     DO i=1, klon
+!IM 080904    zx_tmp_fi2d(i)=zsnow_mass(i)/330.*rowl
+!c      zx_tmp_fi2d(i)=zsnow_mass(i)
+!c     ENDDO
+!c
+!IM 140904   ok_msk=.FALSE.
+!c     ok_msk=.TRUE.
+!c     msk(1:klon)=pctsrf(1:klon,is_ter)
+!c     CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy, 
+!c    .     ok_msk, msk, moyglo)
+!c     zx_tmp_fi2d(1:klon)=moyglo
+!c
+!c     CALL gr_fi_ecrit(1, klon,iim,jjmp1,zx_tmp_fi2d,zx_tmp_2d)
+!c     CALL histwrite(nid_day_seri,"snow_depth",itau_w,
+!c    .               zx_tmp_2d,iim*jjmp1,ndex2d)
+!c
+      DO i=1, klon
+       zx_tmp_fi2d(i)=ftsol(i,is_oce)
+      ENDDO
+!c
+      ok_msk=.TRUE.
+      msk(1:klon)=pctsrf(1:klon,is_oce)
+      CALL moyglo_pondaire(klon, zx_tmp_fi2d, airephy,                               &
+       &     ok_msk, msk, moyglo)
+      zx_tmp_fi2d(1:klon)=moyglo
+!c
+      CALL gr_fi_ecrit(1, klon,iim,jjmp1, zx_tmp_fi2d, zx_tmp_2d)
+      CALL histwrite(nid_day_seri,"tsol_"//clnsurf(is_oce),                          &
+       &               itau_w,zx_tmp_2d,iim*jjmp1,ndex2d) 
+!c
+!c=================================================================
+!c=================================================================
+!c=================================================================
+!c
+      if (ok_sync) then
+        call histsync(nid_day_seri)
+      endif
+!c
+      ENDIF !fin test sur type_run.EQ."AMIP"
+      
+      ENDIF  ! mono_cpu
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histhfNMC.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histhfNMC.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histhfNMC.h	(revision 17)
@@ -0,0 +1,90 @@
+!
+! $Header$
+!
+      IF (ok_histNMC(3)) THEN
+!c
+       ndex3d = 0
+       itau_w = itau_phy + itap + start_time * day_step / iphysiq
+!ccc
+!c  Champs interpolles sur des niveaux de pression du NMC
+!c
+!c     PARAMETER(nout=3) 
+!c nout=1 : in=pdtphys,    out=mth
+!c nout=2 : in=pdtphys,    out=day
+!c nout=3 : in=pdtphys,    out=hf
+!ccc
+      CALL histwrite_phy(nid_hfnmc,lNMC,"tnondef",itau_w,                            &
+       &tnondef(:,:,3))
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"ta",itau_w,                                &
+       &twriteSTD3)
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"zg",itau_w,                                &
+       &phiwriteSTD3)
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"hus",itau_w,                               &
+       &qwriteSTD3)
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"hur",itau_w,                               &
+       &rhwriteSTD3)
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"ua",itau_w,                                &
+       &uwriteSTD3)
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"va",itau_w,                                &
+       &vwriteSTD3)
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"wap",itau_w,                               &
+       &wwriteSTD3)
+!c
+       IF (1.EQ.0) THEN
+!c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tnondef(i,k,3).NE.missing_val) THEN
+          zx_tmp_fiNC(i,k) = (100.*tnondef(i,k,3))/freq_moyNMC(3)
+         ELSE
+          zx_tmp_fiNC(i,k) = missing_val
+         ENDIF
+        ENDDO
+       ENDDO !k=1, nlevSTD
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"psbg",itau_w,                              &
+       &zx_tmp_fiNC)
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"uv",itau_w,                                &
+       &uvsumSTD(:,:,3))
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"vq",itau_w,                                &
+       &vqsumSTD(:,:,3))
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"vT",itau_w,                                &
+       &vTsumSTD(:,:,3))
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"wq",itau_w,                                &
+       &wqsumSTD(:,:,3))
+!c
+      CALL histwrite_phy(nid_hfnmc,lNMC,"vphi",itau_w,                               &
+       &vphisumSTD(:,:,3))
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"wT",itau_w,                                &
+       &wTsumSTD(:,:,3))
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"uxu",itau_w,                               &
+       &u2sumSTD(:,:,3))
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"vxv",itau_w,                               &
+       &v2sumSTD(:,:,3))
+!c
+       CALL histwrite_phy(nid_hfnmc,lNMC,"TxT",itau_w,                               &
+       &T2sumSTD(:,:,3))
+!c
+       ENDIF !(1.EQ.0) THEN
+!c
+      if (ok_sync) then
+!$OMP MASTER
+        call histsync(nid_hfnmc)
+!$OMP END MASTER
+      endif
+!c
+      ENDIF !      (ok_histNMC(3)) THEN
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histmthNMC.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histmthNMC.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histmthNMC.h	(revision 17)
@@ -0,0 +1,113 @@
+!
+! $Id: write_histmthNMC.h 1665 2012-10-09 13:35:26Z fairhead $
+!
+      IF (ok_histNMC(1)) THEN
+!c
+       ndex3d = 0
+       itau_w = itau_phy + itap + start_time * day_step / iphysiq
+!ccc
+!c  Champs interpolles sur des niveaux de pression du NMC
+!c
+!c     PARAMETER(nout=3) 
+!c nout=1 : in=pdtphys,    out=mth
+!c nout=2 : in=pdtphys,    out=day
+!c nout=3 : in=pdtphys,    out=hf
+!ccc
+      CALL histwrite_phy(nid_mthnmc,lNMC,"tnondef",itau_w,                           &
+       &tnondef(:,:,1))
+!c
+      CALL histwrite_phy(nid_mthnmc,lNMC,"ta",itau_w,                                &
+       &twriteSTD(:,:,1))
+!c
+      CALL histwrite_phy(nid_mthnmc,lNMC,"zg",itau_w,                                &
+       &phiwriteSTD(:,:,1))
+!c
+       CALL histwrite_phy(nid_mthnmc,lNMC,"hus",itau_w,                              &
+       &qwriteSTD(:,:,1))
+!c
+       CALL histwrite_phy(nid_mthnmc,lNMC,"hur",itau_w,                              &
+       &rhwriteSTD(:,:,1))
+!c
+       CALL histwrite_phy(nid_mthnmc,lNMC,"ua",itau_w,                               &
+       &uwriteSTD(:,:,1))
+!c
+       CALL histwrite_phy(nid_mthnmc,lNMC,"va",itau_w,                               &
+       &vwriteSTD(:,:,1))
+!c
+       CALL histwrite_phy(nid_mthnmc,lNMC,"wap",itau_w,                              &
+       &wwriteSTD(:,:,1))
+!c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(tnondef(i,k,1).NE.missing_val) THEN
+          zx_tmp_fiNC(i,k) = (100.*tnondef(i,k,1))/freq_moyNMC(1)
+         ELSE
+          zx_tmp_fiNC(i,k) = missing_val
+         ENDIF
+        ENDDO
+       ENDDO !k=1, nlevSTD
+!c
+      CALL histwrite_phy(nid_mthnmc,lNMC,"psbg",itau_w,                              &
+       &zx_tmp_fiNC)
+!c
+      CALL histwrite_phy(nid_mthnmc,lNMC,"uv",itau_w,                                &
+       &uvsumSTD(:,:,1))
+!c
+      CALL histwrite_phy(nid_mthnmc,lNMC,"vq",itau_w,                                &
+       &vqsumSTD(:,:,1))
+!c
+      CALL histwrite_phy(nid_mthnmc,lNMC,"vT",itau_w,                                &
+       &vTsumSTD(:,:,1))
+!c
+      CALL histwrite_phy(nid_mthnmc,lNMC,"wq",itau_w,                                &
+       &wqsumSTD(:,:,1))
+!c
+      CALL histwrite_phy(nid_mthnmc,lNMC,"vphi",itau_w,                              &
+       &vphisumSTD(:,:,1))
+!c
+       CALL histwrite_phy(nid_mthnmc,lNMC,"wT",itau_w,                               &
+       &wTsumSTD(:,:,1))
+!c
+       CALL histwrite_phy(nid_mthnmc,lNMC,"uxu",itau_w,                              &
+       &u2sumSTD(:,:,1))
+!c
+       CALL histwrite_phy(nid_mthnmc,lNMC,"vxv",itau_w,                              &
+       &v2sumSTD(:,:,1))
+!c
+       CALL histwrite_phy(nid_mthnmc,lNMC,"TxT",itau_w,                              &
+       &T2sumSTD(:,:,1))
+!c
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(O3sumSTD(i,k,1).NE.missing_val) THEN
+          zx_tmp_fiNC(i,k) = O3sumSTD(i,k,1) * 1.e+9
+         ELSE
+          zx_tmp_fiNC(i,k) = missing_val
+         ENDIF
+        ENDDO
+       ENDDO !k=1, nlevSTD
+       CALL histwrite_phy(nid_mthnmc,lNMC,"tro3",itau_w,                             &
+       & zx_tmp_fiNC)
+!c
+       if (read_climoz == 2) THEN
+       DO k=1, nlevSTD
+        DO i=1, klon
+         IF(O3daysumSTD(i,k,1).NE.missing_val) THEN
+          zx_tmp_fiNC(i,k) = O3daysumSTD(i,k,1) * 1.e+9
+         ELSE
+          zx_tmp_fiNC(i,k) = missing_val
+         ENDIF
+        ENDDO
+       ENDDO !k=1, nlevSTD
+!c
+        CALL histwrite_phy(nid_mthnmc,lNMC,"tro3_daylight",                          &
+       &itau_w, zx_tmp_fiNC)
+       endif 
+!c
+      if (ok_sync) then
+!$OMP MASTER
+        call histsync(nid_mthnmc)
+!$OMP END MASTER
+      endif
+!c
+      ENDIF !(ok_histNMC(1)) THEN
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histrac.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histrac.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/write_histrac.h	(revision 17)
@@ -0,0 +1,125 @@
+!$Id $
+!***************************************
+!  ECRITURE DU FICHIER :  histrac.nc
+!***************************************
+  IF (ecrit_tra > 0.) THEN
+     
+     itau_w = itau_phy + nstep + start_time * day_step / iphysiq
+     
+     CALL histwrite_phy(nid_tra,.FALSE.,"phis",itau_w,pphis)
+     CALL histwrite_phy(nid_tra,.FALSE.,"aire",itau_w,airephy)
+     CALL histwrite_phy(nid_tra,.FALSE.,"zmasse",itau_w,zmasse)
+! RomP >>>
+     CALL histwrite_phy(nid_tra,.FALSE.,"sourceBE",itau_w,sourceBE)
+! RomP <<<
+
+!TRACEURS
+!----------------
+     DO it=1,nbtr
+        iiq=niadv(it+2)
+
+! CONCENTRATIONS
+        CALL histwrite_phy(nid_tra,.FALSE.,tname(iiq),itau_w,tr_seri(:,:,it))
+
+! TD LESSIVAGE       
+      IF (lessivage .AND. aerosol(it)) THEN
+        CALL histwrite_phy(nid_tra,.FALSE.,"fl"//tname(iiq),itau_w,flestottr(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_ls_"//tname(iiq),itau_w,d_tr_ls(:,:,it))
+        IF(iflag_lscav .EQ. 3 .OR. iflag_lscav .EQ. 4) then
+          CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_insc_"//tname(iiq),itau_w,d_tr_insc(:,:,it))
+          CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_bcscav_"//tname(iiq),itau_w,d_tr_bcscav(:,:,it))
+          CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_evls_"//tname(iiq),itau_w,d_tr_evapls(:,:,it))
+          CALL histwrite_phy(nid_tra,.FALSE.,"qpr_ls_"//tname(iiq),itau_w,qPrls(:,it))
+        ENDIF
+      ENDIF
+
+! TD THERMIQUES
+        IF (iflag_thermals.gt.0) THEN
+           CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_th_"//tname(iiq),itau_w,d_tr_th(:,:,it))
+        ENDIF
+
+! TD CONVECTION
+        IF (iflag_con.GE.2) THEN
+           CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_cv_"//tname(iiq),itau_w,d_tr_cv(:,:,it))
+        ENDIF
+
+! TD COUCHE-LIMITE
+      IF (couchelimite) THEN
+        CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_cl_"//tname(iiq),itau_w,d_tr_cl(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_dry_"//tname(iiq),itau_w,d_tr_dry(:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"flux_tr_dry_"//tname(iiq),itau_w,flux_tr_dry(:,it))
+      ENDIF
+
+! TD radio-decroissance
+        CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_dec_"//tname(iiq),itau_w,d_tr_dec(:,:,it))
+
+! RomP >>>
+        IF (iflag_con.EQ.30) THEN
+        CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_cvMA_"//tname(iiq),itau_w,dtrcvMA(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_trsp_"//tname(iiq),itau_w,d_tr_trsp(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_sscav_"//tname(iiq),itau_w,d_tr_sscav(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_sat_"//tname(iiq),itau_w,d_tr_sat(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"d_tr_uscav_"//tname(iiq),itau_w,d_tr_uscav(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"tr_pr_"//tname(iiq),itau_w,qPr(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"tr_aa_"//tname(iiq),itau_w,qPa(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"tr_mel_"//tname(iiq),itau_w,qMel(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"tr_di_"//tname(iiq),itau_w,qDi(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"tr_trspdi_"//tname(iiq),itau_w,qTrdi(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"zmfd1a_"//tname(iiq),itau_w,zmfd1a(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"zmfphi2_"//tname(iiq),itau_w,zmfphi2(:,:,it))
+        CALL histwrite_phy(nid_tra,.FALSE.,"zmfdam_"//tname(iiq),itau_w,zmfdam(:,:,it))
+        ENDIF
+        CALL histwrite_phy(nid_tra,.FALSE.,"dtrdyn_"//tname(iiq),itau_w,d_tr_dyn(:,:,it))
+! RomP <<<
+     ENDDO
+!---------------
+!
+!
+! VENT (niveau 1)   
+     CALL histwrite_phy(nid_tra,.FALSE.,"pyu1",itau_w,yu1)
+     CALL histwrite_phy(nid_tra,.FALSE.,"pyv1",itau_w,yv1)
+!
+! TEMPERATURE DU SOL
+     zx_tmp_fi2d(:)=ftsol(:,1)         
+     CALL histwrite_phy(nid_tra,.FALSE.,"ftsol1",itau_w,zx_tmp_fi2d)
+     zx_tmp_fi2d(:)=ftsol(:,2)
+     CALL histwrite_phy(nid_tra,.FALSE.,"ftsol2",itau_w,zx_tmp_fi2d)
+     zx_tmp_fi2d(:)=ftsol(:,3)
+     CALL histwrite_phy(nid_tra,.FALSE.,"ftsol3",itau_w,zx_tmp_fi2d)
+     zx_tmp_fi2d(:)=ftsol(:,4)
+     CALL histwrite_phy(nid_tra,.FALSE.,"ftsol4",itau_w,zx_tmp_fi2d)
+!      
+! NATURE DU SOL
+     zx_tmp_fi2d(:)=pctsrf(:,1)
+     CALL histwrite_phy(nid_tra,.FALSE.,"psrf1",itau_w,zx_tmp_fi2d)
+     zx_tmp_fi2d(:)=pctsrf(:,2)
+     CALL histwrite_phy(nid_tra,.FALSE.,"psrf2",itau_w,zx_tmp_fi2d)
+     zx_tmp_fi2d(:)=pctsrf(:,3)
+     CALL histwrite_phy(nid_tra,.FALSE.,"psrf3",itau_w,zx_tmp_fi2d)
+     zx_tmp_fi2d(:)=pctsrf(:,4)
+     CALL histwrite_phy(nid_tra,.FALSE.,"psrf4",itau_w,zx_tmp_fi2d)
+ 
+! DIVERS    
+     CALL histwrite_phy(nid_tra,.FALSE.,"Mint",itau_w,Mint(:,:))
+     CALL histwrite_phy(nid_tra,.FALSE.,"frac_impa",itau_w,frac_impa(:,:))    
+     CALL histwrite_phy(nid_tra,.FALSE.,"frac_nucl",itau_w,frac_nucl(:,:))
+
+
+     CALL histwrite_phy(nid_tra,.FALSE.,"pplay",itau_w,pplay)     
+     CALL histwrite_phy(nid_tra,.FALSE.,"T",itau_w,t_seri)     
+     CALL histwrite_phy(nid_tra,.FALSE.,"mfu",itau_w,pmfu)
+     CALL histwrite_phy(nid_tra,.FALSE.,"mfd",itau_w,pmfd)
+     CALL histwrite_phy(nid_tra,.FALSE.,"en_u",itau_w,pen_u)
+     CALL histwrite_phy(nid_tra,.FALSE.,"en_d",itau_w,pen_d)
+     CALL histwrite_phy(nid_tra,.FALSE.,"de_d",itau_w,pde_d)
+     CALL histwrite_phy(nid_tra,.FALSE.,"de_u",itau_w,pde_u)
+     CALL histwrite_phy(nid_tra,.FALSE.,"coefh",itau_w,coefh)
+
+     IF (ok_sync) THEN
+!$OMP MASTER
+        CALL histsync(nid_tra)
+!$OMP END MASTER
+     ENDIF
+
+  ENDIF !ecrit_tra>0.
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/write_paramLMDZ_phy.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/write_paramLMDZ_phy.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/write_paramLMDZ_phy.h	(revision 17)
@@ -0,0 +1,99 @@
+!c
+!c calcul moyennes globales
+!c
+       zx_tmp_fi2d=bils*airephy
+       CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gbils)
+       zx_tmp_fi2d=evap*airephy
+       CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gevap)
+       zx_tmp_fi2d(:)=fevap(:, is_ter)*airephy(:)
+       CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gevapt)
+       zx_tmp_fi2d=zxfluxlat*airephy
+       CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,glat)
+       zx_tmp_fi2d=(topsw0-toplw0)*airephy
+       CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gnet0)
+       zx_tmp_fi2d=(topsw-toplw)*airephy
+       CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gnet)
+       zx_tmp_fi2d=(rain_fall+snow_fall)*airephy
+       CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,grain)
+       zx_tmp_fi2d=zxtsol*airephy
+       CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gtsol)
+       zx_tmp_fi2d=zt2m*airephy
+       CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gt2m)
+       zx_tmp_fi2d=prw*airephy
+       CALL global_mean(zx_tmp_fi2d,airephy,.TRUE.,gprw)
+!c
+!$OMP MASTER
+      if (is_mpi_root) then      
+!c
+      ndex2d = 0
+      itau_w = itau_phy + itap + start_time * day_step / iphysiq
+!c
+!c Variables globales
+!c
+      zx_tmp_0d=R_ecc
+      CALL histwrite(nid_ctesGCM,"R_ecc",itau_w,                                     &
+       &               zx_tmp_0d,np,ndex2d)
+!c
+      zx_tmp_0d=R_peri
+      CALL histwrite(nid_ctesGCM,"R_peri",itau_w,                                    &
+       &               zx_tmp_0d,np,ndex2d)
+!c
+      zx_tmp_0d=R_incl
+      CALL histwrite(nid_ctesGCM,"R_incl",itau_w,                                    &
+       &               zx_tmp_0d,np,ndex2d)
+!c
+      zx_tmp_0d=solaire
+      CALL histwrite(nid_ctesGCM,"solaire",itau_w,                                   &
+       &               zx_tmp_0d,np,ndex2d)
+!c
+      zx_tmp_0d=co2_ppm
+      CALL histwrite(nid_ctesGCM,"co2_ppm",itau_w,                                   &
+       &               zx_tmp_0d,np,ndex2d)
+!c
+      zx_tmp_0d=CH4_ppb
+      CALL histwrite(nid_ctesGCM,"CH4_ppb",itau_w,                                   &
+       &               zx_tmp_0d,np,ndex2d)
+!c
+      zx_tmp_0d=N2O_ppb
+      CALL histwrite(nid_ctesGCM,"N2O_ppb",itau_w,                                   &
+       &               zx_tmp_0d,np,ndex2d)
+!c
+      zx_tmp_0d=CFC11_ppt
+      CALL histwrite(nid_ctesGCM,"CFC11_ppt",itau_w,                                 &
+       &               zx_tmp_0d,np,ndex2d)
+!c
+      zx_tmp_0d=CFC12_ppt
+      CALL histwrite(nid_ctesGCM,"CFC12_ppt",itau_w,                                 &
+       &               zx_tmp_0d,np,ndex2d)
+!c
+!c=================================================================
+!c moyennes globales
+!c
+      CALL histwrite(nid_ctesGCM,"bils",itau_w,                                      &
+       &               gbils,np,ndex2d)
+      CALL histwrite(nid_ctesGCM,"evap",itau_w,                                      &
+       &               gevap,np,ndex2d)
+      CALL histwrite(nid_ctesGCM,"evap_land",itau_w,                                 &
+       &               gevapt,np,ndex2d)
+      CALL histwrite(nid_ctesGCM,"flat",itau_w,                                      &
+       &               glat,np,ndex2d)
+      CALL histwrite(nid_ctesGCM,"nettop0",itau_w,                                   &
+       &               gnet0,np,ndex2d)
+      CALL histwrite(nid_ctesGCM,"nettop",itau_w,                                    &
+       &               gnet,np,ndex2d)
+      CALL histwrite(nid_ctesGCM,"precip",itau_w,                                    &
+       &               grain,np,ndex2d)
+      CALL histwrite(nid_ctesGCM,"tsol",itau_w,                                      &
+       &               gtsol,np,ndex2d)
+      CALL histwrite(nid_ctesGCM,"t2m",itau_w,                                       &
+       &               gt2m,np,ndex2d)
+      CALL histwrite(nid_ctesGCM,"prw",itau_w,                                       &
+       &               gprw,np,ndex2d)
+!c=================================================================
+!c
+      if (ok_sync) then
+        call histsync(nid_ctesGCM)
+      endif
+!c
+      endif !(is_mpi_root) then      
+!$OMP END MASTER
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/wstats.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/wstats.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/wstats.F90	(revision 17)
@@ -0,0 +1,351 @@
+subroutine wstats(ngrid,nom,titre,unite,dim,px)
+
+implicit none
+
+#include "dimensions.h"
+#include "statto.h"
+  include "netcdf.inc"
+
+integer,intent(in) :: ngrid
+character (len=*),intent(in) :: nom,titre,unite
+integer,intent(in) :: dim
+real, dimension(ngrid,llm),intent(in) :: px
+integer,parameter :: iip1=iim+1
+integer,parameter :: jjp1=jjm+1
+real, dimension(iip1,jjp1,llm) :: mean3d,sd3d,dx3
+real, dimension(iip1,jjp1) :: mean2d,sd2d,dx2
+character (len=50) :: namebis
+character (len=50), save :: firstvar
+integer :: ierr,varid,nbdim,nid
+integer :: meanid,sdid
+integer, dimension(4)  :: id,start,size
+logical, save :: firstcall=.TRUE.
+integer :: l,i,j,ig0
+integer,save :: index
+
+integer, save :: step=0
+
+
+if (firstcall) then
+   firstcall=.false.
+   firstvar=trim((nom))
+   call inistats(ierr)
+endif
+
+if (firstvar==nom) then ! If we're back to the first variable
+      step = step + 1
+endif
+
+if (mod(step,istats).ne.0) then
+   RETURN
+endif
+
+ierr = NF_OPEN("stats.nc",NF_WRITE,nid)
+
+namebis=trim(nom)
+ierr= NF_INQ_VARID(nid,namebis,meanid)
+
+if (ierr.ne.NF_NOERR) then
+
+   if (firstvar==nom) then 
+      index=1
+      count=0
+   endif
+
+
+!declaration de la variable
+
+! choix du nom des coordonnees
+   ierr= NF_INQ_DIMID(nid,"longitude",id(1))
+   ierr= NF_INQ_DIMID(nid,"latitude",id(2))
+   if (dim.eq.3) then
+      ierr= NF_INQ_DIMID(nid,"altitude",id(3))
+      ierr= NF_INQ_DIMID(nid,"Time",id(4))
+      nbdim=4
+   else if (dim==2) then
+      ierr= NF_INQ_DIMID(nid,"Time",id(3))
+      nbdim=3
+   endif
+
+   write (*,*) "====================="
+   write (*,*) "STATS: creation de ",nom
+   namebis=trim(nom)
+   call def_var_stats(nid,namebis,titre,unite,nbdim,id,meanid,ierr)
+   call inivar(nid,meanid,ngrid,dim,index,px,ierr)
+   namebis=trim(nom)//"_sd"
+   call def_var_stats(nid,namebis,trim(titre)//" total standard deviation over the season",unite,nbdim,id,sdid,ierr)
+   call inivar(nid,sdid,ngrid,dim,index,px,ierr)
+
+   ierr= NF_CLOSE(nid)
+   return
+
+else
+   namebis=trim(nom)//"_sd"
+   ierr= NF_INQ_VARID(nid,namebis,sdid)
+
+endif
+
+if (firstvar==nom) then 
+   count(index)=count(int(index))+1
+   index=index+1
+   if (index>istime) then
+      index=1
+   endif
+endif
+
+if (count(index)==0) then
+   if (dim.eq.3) then
+      start=(/1,1,1,index/)
+      size=(/iip1,jjp1,llm,1/)
+      mean3d=0
+      sd3d=0
+   else if (dim.eq.2) then
+      start=(/1,1,index,0/)
+      size=(/iip1,jjp1,1,0/)
+      mean2d=0
+      sd2d=0
+   endif
+else
+   if (dim.eq.3) then
+      start=(/1,1,1,index/)
+      size=(/iip1,jjp1,llm,1/)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,meanid,start,size,mean3d)
+      ierr = NF_GET_VARA_DOUBLE(nid,sdid,start,size,sd3d)
+#else
+      ierr = NF_GET_VARA_REAL(nid,meanid,start,size,mean3d)
+      ierr = NF_GET_VARA_REAL(nid,sdid,start,size,sd3d)
+#endif
+      if (ierr.ne.NF_NOERR) then
+         write (*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+
+   else if (dim.eq.2) then
+      start=(/1,1,index,0/)
+      size=(/iip1,jjp1,1,0/)
+#ifdef NC_DOUBLE
+      ierr = NF_GET_VARA_DOUBLE(nid,meanid,start,size,mean2d)
+      ierr = NF_GET_VARA_DOUBLE(nid,sdid,start,size,sd2d)
+#else
+      ierr = NF_GET_VARA_REAL(nid,meanid,start,size,mean2d)
+      ierr = NF_GET_VARA_REAL(nid,sdid,start,size,sd2d)
+#endif
+      if (ierr.ne.NF_NOERR) then
+         write (*,*) NF_STRERROR(ierr)
+         stop ""
+      endif
+   endif
+endif
+
+if (dim.eq.3) then
+
+!  Passage variable physique -->  variable dynamique
+
+   DO l=1,llm
+      DO i=1,iip1
+         dx3(i,1,l)=px(1,l)
+         dx3(i,jjp1,l)=px(ngrid,l)
+      ENDDO
+      DO j=2,jjm
+         ig0= 1+(j-2)*iim
+         DO i=1,iim
+            dx3(i,j,l)=px(ig0+i,l)
+         ENDDO
+         dx3(iip1,j,l)=dx3(1,j,l)
+      ENDDO
+   ENDDO
+
+   mean3d(:,:,:)= mean3d(:,:,:)+dx3(:,:,:)
+   sd3d(:,:,:)= sd3d(:,:,:)+dx3(:,:,:)**2
+
+#ifdef NC_DOUBLE
+   ierr = NF_PUT_VARA_DOUBLE(nid,meanid,start,size,mean3d)
+   ierr = NF_PUT_VARA_DOUBLE(nid,sdid,start,size,sd3d)
+#else
+   ierr = NF_PUT_VARA_REAL(nid,meanid,start,size,mean3d)
+   ierr = NF_PUT_VARA_REAL(nid,sdid,start,size,sd3d)
+#endif
+   if (ierr.ne.NF_NOERR) then
+     write (*,*) NF_STRERROR(ierr)
+     stop ""
+   endif
+
+else if (dim.eq.2) then
+
+!    Passage variable physique -->  physique dynamique
+
+  DO i=1,iip1
+     dx2(i,1)=px(1,1)
+     dx2(i,jjp1)=px(ngrid,1)
+  ENDDO
+  DO j=2,jjm
+     ig0= 1+(j-2)*iim
+     DO i=1,iim
+        dx2(i,j)=px(ig0+i,1)
+     ENDDO
+     dx2(iip1,j)=dx2(1,j)
+  ENDDO
+
+   mean2d(:,:)= mean2d(:,:)+dx2(:,:)
+   sd2d(:,:)= sd2d(:,:)+dx2(:,:)**2
+
+#ifdef NC_DOUBLE
+   ierr = NF_PUT_VARA_DOUBLE(nid,meanid,start,size,mean2d)
+   ierr = NF_PUT_VARA_DOUBLE(nid,sdid,start,size,sd2d)
+#else
+   ierr = NF_PUT_VARA_REAL(nid,meanid,start,size,mean2d)
+   ierr = NF_PUT_VARA_REAL(nid,sdid,start,size,sd2d)
+#endif
+   if (ierr.ne.NF_NOERR) then
+     write (*,*) NF_STRERROR(ierr)
+     stop ""
+   endif
+
+endif
+
+ierr= NF_CLOSE(nid)
+
+end subroutine wstats
+
+!======================================================
+subroutine inivar(nid,varid,ngrid,dim,index,px,ierr)
+
+implicit none
+
+include "dimensions.h"
+!!!!!!include "dimphys.h"
+include "netcdf.inc"
+
+integer, intent(in) :: nid,varid,dim,index,ngrid
+real, dimension(ngrid,llm), intent(in) :: px
+integer, intent(out) :: ierr
+
+integer,parameter :: iip1=iim+1
+integer,parameter :: jjp1=jjm+1
+
+integer :: l,i,j,ig0
+integer, dimension(4) :: start,size
+real, dimension(iip1,jjp1,llm) :: dx3
+real, dimension(iip1,jjp1) :: dx2
+
+if (dim.eq.3) then
+
+   start=(/1,1,1,index/)
+   size=(/iip1,jjp1,llm,1/)
+
+!  Passage variable physique -->  variable dynamique
+
+   DO l=1,llm
+      DO i=1,iip1
+         dx3(i,1,l)=px(1,l)
+         dx3(i,jjp1,l)=px(ngrid,l)
+      ENDDO
+      DO j=2,jjm
+         ig0= 1+(j-2)*iim
+         DO i=1,iim
+            dx3(i,j,l)=px(ig0+i,l)
+         ENDDO
+         dx3(iip1,j,l)=dx3(1,j,l)
+      ENDDO
+   ENDDO
+
+#ifdef NC_DOUBLE
+   ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,dx3)
+#else
+   ierr = NF_PUT_VARA_REAL(nid,varid,start,size,dx3)
+#endif
+
+else if (dim.eq.2) then
+
+      start=(/1,1,index,0/)
+      size=(/iip1,jjp1,1,0/)
+
+!    Passage variable physique -->  physique dynamique
+
+  DO i=1,iip1
+     dx2(i,1)=px(1,1)
+     dx2(i,jjp1)=px(ngrid,1)
+  ENDDO
+  DO j=2,jjm
+     ig0= 1+(j-2)*iim
+     DO i=1,iim
+        dx2(i,j)=px(ig0+i,1)
+     ENDDO
+     dx2(iip1,j)=dx2(1,j)
+  ENDDO
+
+#ifdef NC_DOUBLE
+   ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,size,dx2)
+#else
+   ierr = NF_PUT_VARA_REAL(nid,varid,start,size,dx2)
+#endif
+
+endif
+
+end subroutine inivar
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+subroutine def_var_stats(nid,name,title,units,nbdim,dimids,nvarid,ierr)
+
+! This subroutine defines variable 'name' in a (pre-existing and opened)
+! NetCDF file (known from its NetCDF ID 'nid').
+! The number of dimensions 'nbdim' of the variable, as well as the IDs of
+! corresponding dimensions must be set (in array 'dimids').
+! Upon successfull definition of the variable, 'nvarid' contains the
+! NetCDF ID of the variable.
+! The variables' attributes 'title' (Note that 'long_name' would be more
+! appropriate) and 'units' are also set. 
+
+implicit none
+
+  include "netcdf.inc"
+
+integer,intent(in) :: nid ! NetCDF file ID
+character(len=*),intent(in) :: name ! the variable's name
+character(len=*),intent(in) :: title ! 'title' attribute of variable
+character(len=*),intent(in) :: units ! 'units' attribute of variable
+integer,intent(in) :: nbdim ! number of dimensions of the variable
+integer,dimension(nbdim),intent(in) :: dimids ! NetCDF IDs of the dimensions
+                                              ! the variable is defined along
+integer,intent(out) :: nvarid ! NetCDF ID of the variable
+integer,intent(out) :: ierr ! returned NetCDF staus code
+
+! 1. Switch to NetCDF define mode 
+ierr=NF_REDEF(nid)
+
+! 2. Define the variable
+#ifdef NC_DOUBLE
+ierr = NF_DEF_VAR (nid,adjustl(name),NF_DOUBLE,nbdim,dimids,nvarid)
+#else
+ierr = NF_DEF_VAR (nid,adjustl(name),NF_FLOAT,nbdim,dimids,nvarid)
+#endif
+if(ierr/=NF_NOERR) then
+   write(*,*) "def_var_stats: Failed defining variable "//trim(name)
+   write(*,*) NF_STRERROR(ierr)
+   stop ""
+endif
+
+! 3. Write attributes
+ierr=NF_PUT_ATT_TEXT(nid,nvarid,"title",&
+                     len_trim(adjustl(title)),adjustl(title))
+if(ierr/=NF_NOERR) then
+   write(*,*) "def_var_stats: Failed writing title attribute for "//trim(name)
+   write(*,*) NF_STRERROR(ierr)
+   stop ""
+endif
+
+ierr=NF_PUT_ATT_TEXT(nid,nvarid,"units",&
+                     len_trim(adjustl(units)),adjustl(units))
+if(ierr/=NF_NOERR) then
+   write(*,*) "def_var_stats: Failed writing units attribute for "//trim(name)
+   write(*,*) NF_STRERROR(ierr)
+   stop ""
+endif
+
+! 4. Switch out of NetCDF define mode
+ierr = NF_ENDDEF(nid)
+
+end subroutine def_var_stats
+
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada.F	(revision 17)
@@ -0,0 +1,174 @@
+!
+! $Header$
+!
+      SUBROUTINE yamada(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2,km,kn,ustar
+     s   ,l_mix)
+      use dimphy
+      IMPLICIT NONE
+c.......................................................................
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c
+c.......................................................................
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon),snstable
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1)
+      REAL km(klon,klev+1)
+      REAL kn(klon,klev+1)
+      integer l_mix,ngrid
+
+
+      integer nlay,nlev
+cym      PARAMETER (nlay=klev)
+cym      PARAMETER (nlev=klev+1)
+
+      logical first
+      save first
+      data first/.true./
+c$OMP THREADPRIVATE(first)
+
+      integer ig,k
+
+      real ri,zrif,zalpha,zsm
+      real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev)
+
+      real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1)
+      real l(klon,klev+1),l0(klon)
+
+      real sq(klon),sqz(klon),zz(klon,klev+1)
+      integer iter
+
+      real ric,rifc,b1,kap
+      save ric,rifc,b1,kap
+      data ric,rifc,b1,kap/0.195,0.191,16.6,0.3/
+c$OMP THREADPRIVATE(ric,rifc,b1,kap)
+
+      real frif,falpha,fsm
+
+      frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
+      falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri)
+      fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
+
+      nlay=klev
+      nlev=klev+1
+      
+      if (0.eq.1.and.first) then
+      do ig=1,1000
+         ri=(ig-800.)/500.
+         if (ri.lt.ric) then
+            zrif=frif(ri)
+         else
+            zrif=rifc
+         endif
+         if(zrif.lt.0.16) then
+            zalpha=falpha(zrif)
+            zsm=fsm(zrif)
+         else
+            zalpha=1.12
+            zsm=0.085
+         endif
+         print*,ri,rif,zalpha,zsm
+      enddo
+      first=.false.
+      endif
+
+c  Correction d'un bug sauvage a verifier.
+c      do k=2,nlev
+      do k=2,nlay
+                                                          do ig=1,ngrid
+         dz(ig,k)=zlay(ig,k)-zlay(ig,k-1)
+         m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2)
+     s             /(dz(ig,k)*dz(ig,k))
+         n2(ig,k)=g*2.*(teta(ig,k)-teta(ig,k-1))
+     s            /(teta(ig,k-1)+teta(ig,k))  /dz(ig,k)
+         ri=n2(ig,k)/max(m2(ig,k),1.e-10)
+         if (ri.lt.ric) then
+            rif(ig,k)=frif(ri)
+         else
+            rif(ig,k)=rifc
+         endif
+         if(rif(ig,k).lt.0.16) then
+            alpha(ig,k)=falpha(rif(ig,k))
+            sm(ig,k)=fsm(rif(ig,k))
+         else
+            alpha(ig,k)=1.12
+            sm(ig,k)=0.085
+         endif
+         zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k)
+                                                          enddo
+      enddo
+
+c iterration pour determiner la longueur de melange
+
+                                                          do ig=1,ngrid
+      l0(ig)=100.
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+                                                          enddo
+      enddo
+
+      do iter=1,10
+                                                          do ig=1,ngrid
+         sq(ig)=1.e-10
+         sqz(ig)=1.e-10
+                                                          enddo
+         do k=2,klev-1
+                                                          do ig=1,ngrid
+           q2(ig,k)=l(ig,k)**2*zz(ig,k)
+           l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+     s     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10)))
+           zq=sqrt(q2(ig,k))
+           sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+           sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+         enddo
+                                                          do ig=1,ngrid
+         l0(ig)=0.2*sqz(ig)/sq(ig)
+                                                          enddo
+c(abd 3 5 2)         print*,'ITER=',iter,'  L0=',l0
+
+      enddo
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+     s     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10)))
+         q2(ig,k)=l(ig,k)**2*zz(ig,k)
+         km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         kn(ig,k)=km(ig,k)*alpha(ig,k)
+                                                          enddo
+      enddo
+
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada.F90	(revision 17)
@@ -0,0 +1,174 @@
+!
+! $Header$
+!
+      SUBROUTINE yamada(ngrid,dt,g,rconst,plev,temp                                  &
+       &   ,zlev,zlay,u,v,teta,cd,q2,km,kn,ustar                                     &
+       &   ,l_mix)
+      use dimphy
+      IMPLICIT NONE
+!c.......................................................................
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!c.......................................................................
+!c
+!c dt : pas de temps
+!c g  : g
+!c zlev : altitude a chaque niveau (interface inferieure de la couche
+!c        de meme indice)
+!c zlay : altitude au centre de chaque couche
+!c u,v : vitesse au centre de chaque couche
+!c       (en entree : la valeur au debut du pas de temps)
+!c teta : temperature potentielle au centre de chaque couche
+!c        (en entree : la valeur au debut du pas de temps)
+!c cd : cdrag
+!c      (en entree : la valeur au debut du pas de temps)
+!c q2 : $q^2$ au bas de chaque couche
+!c      (en entree : la valeur au debut du pas de temps)
+!c      (en sortie : la valeur a la fin du pas de temps)
+!c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+!c      couche)
+!c      (en sortie : la valeur a la fin du pas de temps)
+!c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+!c      (en sortie : la valeur a la fin du pas de temps)
+!c
+!c.......................................................................
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon),snstable
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1)
+      REAL km(klon,klev+1)
+      REAL kn(klon,klev+1)
+      integer l_mix,ngrid
+
+
+      integer nlay,nlev
+!cym      PARAMETER (nlay=klev)
+!cym      PARAMETER (nlev=klev+1)
+
+      logical first
+      save first
+      data first/.true./
+!$OMP THREADPRIVATE(first)
+
+      integer ig,k
+
+      real ri,zrif,zalpha,zsm
+      real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev)
+
+      real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1)
+      real l(klon,klev+1),l0(klon)
+
+      real sq(klon),sqz(klon),zz(klon,klev+1)
+      integer iter
+
+      real ric,rifc,b1,kap
+      save ric,rifc,b1,kap
+      data ric,rifc,b1,kap/0.195,0.191,16.6,0.3/
+!$OMP THREADPRIVATE(ric,rifc,b1,kap)
+
+      real frif,falpha,fsm
+
+      frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
+      falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri)
+      fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
+
+      nlay=klev
+      nlev=klev+1
+      
+      if (0.eq.1.and.first) then
+      do ig=1,1000
+         ri=(ig-800.)/500.
+         if (ri.lt.ric) then
+            zrif=frif(ri)
+         else
+            zrif=rifc
+         endif
+         if(zrif.lt.0.16) then
+            zalpha=falpha(zrif)
+            zsm=fsm(zrif)
+         else
+            zalpha=1.12
+            zsm=0.085
+         endif
+         print*,ri,rif,zalpha,zsm
+      enddo
+      first=.false.
+      endif
+
+!c  Correction d'un bug sauvage a verifier.
+!c      do k=2,nlev
+      do k=2,nlay
+                                                          do ig=1,ngrid
+         dz(ig,k)=zlay(ig,k)-zlay(ig,k-1)
+         m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2)                    &
+       &             /(dz(ig,k)*dz(ig,k))
+         n2(ig,k)=g*2.*(teta(ig,k)-teta(ig,k-1))                                     &
+       &            /(teta(ig,k-1)+teta(ig,k))  /dz(ig,k)
+         ri=n2(ig,k)/max(m2(ig,k),1.e-10)
+         if (ri.lt.ric) then
+            rif(ig,k)=frif(ri)
+         else
+            rif(ig,k)=rifc
+         endif
+         if(rif(ig,k).lt.0.16) then
+            alpha(ig,k)=falpha(rif(ig,k))
+            sm(ig,k)=fsm(rif(ig,k))
+         else
+            alpha(ig,k)=1.12
+            sm(ig,k)=0.085
+         endif
+         zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k)
+                                                          enddo
+      enddo
+
+!c iterration pour determiner la longueur de melange
+
+                                                          do ig=1,ngrid
+      l0(ig)=100.
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        l(ig,k)=l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+                                                          enddo
+      enddo
+
+      do iter=1,10
+                                                          do ig=1,ngrid
+         sq(ig)=1.e-10
+         sqz(ig)=1.e-10
+                                                          enddo
+         do k=2,klev-1
+                                                          do ig=1,ngrid
+           q2(ig,k)=l(ig,k)**2*zz(ig,k)
+           l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))                 &
+       &     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10)))
+           zq=sqrt(q2(ig,k))
+           sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+           sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+         enddo
+                                                          do ig=1,ngrid
+         l0(ig)=0.2*sqz(ig)/sq(ig)
+                                                          enddo
+!c(abd 3 5 2)         print*,'ITER=',iter,'  L0=',l0
+
+      enddo
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         l(ig,k)=min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))                   &
+       &     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10)))
+         q2(ig,k)=l(ig,k)**2*zz(ig,k)
+         km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         kn(ig,k)=km(ig,k)*alpha(ig,k)
+                                                          enddo
+      enddo
+
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada4.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada4.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada4.F	(revision 17)
@@ -0,0 +1,645 @@
+!
+! $Header$
+!
+      SUBROUTINE yamada4(ngrid,dt,g,rconst,plev,temp
+     s   ,zlev,zlay,u,v,teta,cd,q2,km,kn,kq,ustar
+     s   ,iflag_pbl)
+      use dimphy
+      IMPLICIT NONE
+#include "iniprint.h"
+c.......................................................................
+cym#include "dimensions.h"
+cym#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+c g  : g
+c zlev : altitude a chaque niveau (interface inferieure de la couche
+c        de meme indice)
+c zlay : altitude au centre de chaque couche
+c u,v : vitesse au centre de chaque couche
+c       (en entree : la valeur au debut du pas de temps)
+c teta : temperature potentielle au centre de chaque couche
+c        (en entree : la valeur au debut du pas de temps)
+c cd : cdrag
+c      (en entree : la valeur au debut du pas de temps)
+c q2 : $q^2$ au bas de chaque couche
+c      (en entree : la valeur au debut du pas de temps)
+c      (en sortie : la valeur a la fin du pas de temps)
+c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+c      couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+c      (en sortie : la valeur a la fin du pas de temps)
+c
+c  iflag_pbl doit valoir entre 6 et 9
+c      l=6, on prend  systematiquement une longueur d'equilibre
+c    iflag_pbl=6 : MY 2.0
+c    iflag_pbl=7 : MY 2.0.Fournier
+c    iflag_pbl=8/9 : MY 2.5
+c       iflag_pbl=8 with special obsolete treatments for convergence
+c       with Cmpi5 NPv3.1 simulations
+c    iflag_pbl=10/11 :  New scheme M2 and N2 explicit and dissiptation exact
+c    iflag_pbl=12 = 11 with vertical diffusion off q2
+c
+c  2013/04/01 (FH hourdin@lmd.jussieu.fr)
+c     Correction for very stable PBLs (iflag_pbl=10 and 11)
+c     iflag_pbl=8 converges numerically with NPv3.1
+c     iflag_pbl=11 -> the model starts with NP from start files created by ce0l
+c                  -> the model can run with longer time-steps.
+c.......................................................................
+
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon)
+      real kmin,qmin,pblhmin(klon),coriol(klon)
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1),qpre
+      REAL unsdz(klon,klev)
+      REAL unsdzdec(klon,klev+1)
+
+      REAL km(klon,klev+1)
+      REAL kmpre(klon,klev+1),tmp2
+      REAL mpre(klon,klev+1)
+      REAL kn(klon,klev+1)
+      REAL kq(klon,klev+1)
+      real ff(klon,klev+1),delta(klon,klev+1)
+      real aa(klon,klev+1),aa0,aa1
+      integer iflag_pbl,ngrid
+      integer nlay,nlev
+
+      logical first
+      integer ipas
+      save first,ipas
+cFH/IM     data first,ipas/.true.,0/
+      data first,ipas/.false.,0/
+c$OMP THREADPRIVATE( first,ipas)
+
+      integer ig,k
+
+
+      real ri,zrif,zalpha,zsm,zsn
+      real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev)
+
+      real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1)
+      real dtetadz(klon,klev+1)
+      real m2cstat,mcstat,kmcstat
+      real l(klon,klev+1)
+      real,allocatable,save :: l0(:)
+c$OMP THREADPRIVATE(l0)      
+      real sq(klon),sqz(klon),zz(klon,klev+1)
+      integer iter
+
+      real ric,rifc,b1,kap
+      save ric,rifc,b1,kap
+      data ric,rifc,b1,kap/0.195,0.191,16.6,0.4/
+c$OMP THREADPRIVATE(ric,rifc,b1,kap)
+      real frif,falpha,fsm
+      real fl,zzz,zl0,zq2,zn2
+
+      real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev)
+     s  ,lyam(klon,klev),knyam(klon,klev)
+     s  ,w2yam(klon,klev),t2yam(klon,klev)
+      logical,save :: firstcall=.true.
+c$OMP THREADPRIVATE(firstcall)       
+      frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
+      falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri)
+      fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
+      fl(zzz,zl0,zq2,zn2)=
+     s     max(min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))
+     s     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) ,1.)
+
+
+      nlay=klev
+      nlev=klev+1
+      
+      if (firstcall) then
+	allocate(l0(klon))
+	firstcall=.false.
+      endif
+
+
+      if (.not.(iflag_pbl.ge.6.and.iflag_pbl.le.12)) then
+           stop'probleme de coherence dans appel a MY'
+      endif
+
+      ipas=ipas+1
+
+
+c.......................................................................
+c  les increments verticaux
+c.......................................................................
+c
+c!!!!! allerte !!!!!c
+c!!!!! zlev n'est pas declare a nlev !!!!!c
+c!!!!! ---->
+                                                      DO ig=1,ngrid
+            zlev(ig,nlev)=zlay(ig,nlay)
+     &             +( zlay(ig,nlay) - zlev(ig,nlev-1) )
+                                                      ENDDO
+c!!!!! <----
+c!!!!! allerte !!!!!c
+c
+      DO k=1,nlay
+                                                      DO ig=1,ngrid
+        unsdz(ig,k)=1.E+0/(zlev(ig,k+1)-zlev(ig,k))
+                                                      ENDDO
+      ENDDO
+                                                      DO ig=1,ngrid
+      unsdzdec(ig,1)=1.E+0/(zlay(ig,1)-zlev(ig,1))
+                                                      ENDDO
+      DO k=2,nlay
+                                                      DO ig=1,ngrid
+        unsdzdec(ig,k)=1.E+0/(zlay(ig,k)-zlay(ig,k-1))
+                                                     ENDDO
+      ENDDO
+                                                      DO ig=1,ngrid
+      unsdzdec(ig,nlay+1)=1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay))
+                                                     ENDDO
+c
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Computing M^2, N^2, Richardson numbers, stability functions
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         dz(ig,k)=zlay(ig,k)-zlay(ig,k-1)
+         m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2)
+     s             /(dz(ig,k)*dz(ig,k))
+         dtetadz(ig,k)=(teta(ig,k)-teta(ig,k-1))/dz(ig,k)
+         n2(ig,k)=g*2.*dtetadz(ig,k)/(teta(ig,k-1)+teta(ig,k))
+c        n2(ig,k)=0.
+         ri=n2(ig,k)/max(m2(ig,k),1.e-10)
+         if (ri.lt.ric) then
+            rif(ig,k)=frif(ri)
+         else
+            rif(ig,k)=rifc
+         endif
+         if(rif(ig,k).lt.0.16) then
+            alpha(ig,k)=falpha(rif(ig,k))
+            sm(ig,k)=fsm(rif(ig,k))
+         else
+            alpha(ig,k)=1.12
+            sm(ig,k)=0.085
+         endif
+         zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k)
+                                                          enddo
+      enddo
+
+
+c====================================================================
+c  Computing the mixing length
+c====================================================================
+
+c   Mise a jour de l0
+      if (iflag_pbl==8.or.iflag_pbl==10) then
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Iterative computation of l0
+! This version is kept for iflag_pbl only for convergence
+! with NPv3.1 Cmip5 simulations
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+                                                          do ig=1,ngrid
+      sq(ig)=1.e-10
+      sqz(ig)=1.e-10
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        zq=sqrt(q2(ig,k))
+        sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+        sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+      enddo
+                                                          do ig=1,ngrid
+      l0(ig)=0.2*sqz(ig)/sq(ig)
+                                                          enddo
+      do k=2,klev
+                                                          do ig=1,ngrid
+         l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
+                                                          enddo
+      enddo
+!     print*,'L0 cas 8 ou 10 ',l0
+
+      else
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! In all other case, the assymptotic mixing length l0 is imposed (100m)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+          l0(:)=150.
+          do k=2,klev
+                                                          do ig=1,ngrid
+             l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
+                                                          enddo
+          enddo
+!     print*,'L0 cas autres ',l0
+
+      endif
+
+
+c====================================================================
+c   Yamada 2.0
+c====================================================================
+      if (iflag_pbl.eq.6) then
+
+      do k=2,klev
+         q2(:,k)=l(:,k)**2*zz(:,k)
+      enddo
+
+
+      else if (iflag_pbl.eq.7) then
+c====================================================================
+c   Yamada 2.Fournier
+c====================================================================
+
+c  Calcul de l,  km, au pas precedent
+      do k=2,klev
+                                                          do ig=1,ngrid
+c        print*,'SMML=',sm(ig,k),l(ig,k)
+         delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k))
+         kmpre(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         mpre(ig,k)=sqrt(m2(ig,k))
+c        print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k)
+                                                          enddo
+      enddo
+
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        m2cstat=max(alpha(ig,k)*n2(ig,k)+delta(ig,k)/b1,1.e-12)
+        mcstat=sqrt(m2cstat)
+
+c        print*,'M2 L=',k,mpre(ig,k),mcstat
+c
+c  -----{puis on ecrit la valeur de q qui annule l'equation de m
+c        supposee en q3}
+c
+        IF (k.eq.2) THEN
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(ig,k)*kmpre(ig,k+1)
+     &                        *mpre(ig,k+1)
+     &      +unsdz(ig,k-1)
+     &              *cd(ig)
+     &              *( sqrt(u(ig,3)**2+v(ig,3)**2)
+     &                -mcstat/unsdzdec(ig,k)
+     &                -mpre(ig,k+1)/unsdzdec(ig,k+1) )**2)
+     &      /( unsdz(ig,k)+unsdz(ig,k-1) )
+        ELSE
+          kmcstat=1.E+0 / mcstat
+     &    *( unsdz(ig,k)*kmpre(ig,k+1)
+     &                        *mpre(ig,k+1)
+     &      +unsdz(ig,k-1)*kmpre(ig,k-1)
+     &                          *mpre(ig,k-1) )
+     &      /( unsdz(ig,k)+unsdz(ig,k-1) )
+        ENDIF
+c       print*,'T2 L=',k,tmp2
+        tmp2=kmcstat
+     &      /( sm(ig,k)/q2(ig,k) )
+     &      /l(ig,k)
+        q2(ig,k)=max(tmp2,1.e-12)**(2./3.)
+c       print*,'Q2 L=',k,q2(ig,k)
+c
+                                                          enddo
+      enddo
+
+      else if (iflag_pbl==8.or.iflag_pbl==9) then
+c====================================================================
+c   Yamada 2.5 a la Didi
+c====================================================================
+
+
+c  Calcul de l,  km, au pas precedent
+      do k=2,klev
+                                                          do ig=1,ngrid
+c        print*,'SMML=',sm(ig,k),l(ig,k)
+         delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k))
+         if (delta(ig,k).lt.1.e-20) then
+c     print*,'ATTENTION   L=',k,'   Delta=',delta(ig,k)
+            delta(ig,k)=1.e-20
+         endif
+         km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         aa0=
+     s   (m2(ig,k)-alpha(ig,k)*n2(ig,k)-delta(ig,k)/b1)
+         aa1=
+     s   (m2(ig,k)*(1.-rif(ig,k))-delta(ig,k)/b1)
+c abder      print*,'AA L=',k,aa0,aa1,aa1/max(m2(ig,k),1.e-20)
+         aa(ig,k)=aa1*dt/(delta(ig,k)*l(ig,k))
+c     print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k)
+         qpre=sqrt(q2(ig,k))
+!        if (iflag_pbl.eq.8 ) then
+            if (aa(ig,k).gt.0.) then
+               q2(ig,k)=(qpre+aa(ig,k)*qpre*qpre)**2
+            else
+               q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
+            endif
+!        else ! iflag_pbl=9
+!           if (aa(ig,k)*qpre.gt.0.9) then
+!              q2(ig,k)=(qpre*10.)**2
+!           else
+!              q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
+!           endif
+!        endif
+         q2(ig,k)=min(max(q2(ig,k),1.e-10),1.e4)
+c     print*,'Q2 L=',k,q2(ig,k),qpre*qpre
+                                                          enddo
+      enddo
+
+      else if (iflag_pbl>=10) then
+
+!        print*,'Schema mixte D'
+!        print*,'Longueur ',l(:,:)
+         do k=2,klev-1
+            l(:,k)=max(l(:,k),1.)
+            km(:,k)=l(:,k)*sqrt(q2(:,k))*sm(:,k)
+            q2(:,k)=q2(:,k)+dt*km(:,k)*m2(:,k)*(1.-rif(:,k))
+            q2(:,k)=min(max(q2(:,k),1.e-10),1.e4)
+            q2(:,k)=1./(1./sqrt(q2(:,k))+dt/(2*l(:,k)*b1))
+            q2(:,k)=q2(:,k)*q2(:,k)
+         enddo
+
+
+      else
+         stop'Cas nom prevu dans yamada4'
+
+      endif ! Fin du cas 8
+
+c     print*,'OK8'
+
+c====================================================================
+c   Calcul des coefficients de mï¿œange
+c====================================================================
+      do k=2,klev
+c     print*,'k=',k
+                                                          do ig=1,ngrid
+cabde      print*,'KML=',l(ig,k),q2(ig,k),sm(ig,k)
+         zq=sqrt(q2(ig,k))
+         km(ig,k)=l(ig,k)*zq*sm(ig,k)
+         kn(ig,k)=km(ig,k)*alpha(ig,k)
+         kq(ig,k)=l(ig,k)*zq*0.2
+c     print*,'KML=',km(ig,k),kn(ig,k)
+                                                          enddo
+      enddo
+
+! Transport diffusif vertical de la TKE.
+      if (iflag_pbl.ge.12) then
+!       print*,'YAMADA VDIF'
+        q2(:,1)=q2(:,2)
+        call vdif_q2(dt,g,rconst,ngrid,plev,temp,kq,q2)
+      endif
+
+c   Traitement des cas noctrunes avec l'introduction d'une longueur
+c   minilale.
+
+c====================================================================
+c   Traitement particulier pour les cas tres stables.
+c   D'apres Holtslag Boville.
+
+      if (prt_level>1) THEN
+       print*,'YAMADA4 0'
+      endif !(prt_level>1) THEN
+                                                          do ig=1,ngrid
+      coriol(ig)=1.e-4
+      pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5)
+                                                          enddo
+
+!     print*,'pblhmin ',pblhmin
+CTest a remettre 21 11 02
+c test abd 13 05 02      if(0.eq.1) then
+      if(1==1) then
+      if(iflag_pbl==8.or.iflag_pbl==10) then
+
+      do k=2,klev
+         do ig=1,ngrid
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=-1. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            if (kn(ig,k).lt.kmin.or.km(ig,k).lt.kmin) then
+c               print*,'Seuil min Km K=',k,kmin,km(ig,k),kn(ig,k)
+c     s           ,sqrt(q2(ig,k)),pblhmin(ig),qmin/sm(ig,k)
+               kn(ig,k)=kmin
+               km(ig,k)=kmin
+               kq(ig,k)=kmin
+c   la longueur de melange est suposee etre l= kap z
+c   K=l q Sm d'ou q2=(K/l Sm)**2
+               q2(ig,k)=(qmin/sm(ig,k))**2
+            endif
+         enddo
+      enddo
+
+      else
+
+      do k=2,klev
+         do ig=1,ngrid
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=-1. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            if (kn(ig,k).lt.kmin.or.km(ig,k).lt.kmin) then
+c               print*,'Seuil min Km K=',k,kmin,km(ig,k),kn(ig,k)
+c     s           ,sqrt(q2(ig,k)),pblhmin(ig),qmin/sm(ig,k)
+               kn(ig,k)=kmin
+               km(ig,k)=kmin
+               kq(ig,k)=kmin
+c   la longueur de melange est suposee etre l= kap z
+c   K=l q Sm d'ou q2=(K/l Sm)**2
+               sm(ig,k)=1.
+               alpha(ig,k)=1.
+               q2(ig,k)=min((qmin/sm(ig,k))**2,10.)
+               zq=sqrt(q2(ig,k))
+               km(ig,k)=l(ig,k)*zq*sm(ig,k)
+               kn(ig,k)=km(ig,k)*alpha(ig,k)
+               kq(ig,k)=l(ig,k)*zq*0.2
+            endif
+         enddo
+      enddo
+      endif
+
+      endif
+
+      if (prt_level>1) THEN
+       print*,'YAMADA4 1'
+      endif !(prt_level>1) THEN
+c   Diagnostique pour stokage
+
+      if(1.eq.0)then
+      rino=rif
+      smyam(1:ngrid,1)=0.
+      styam(1:ngrid,1)=0.
+      lyam(1:ngrid,1)=0.
+      knyam(1:ngrid,1)=0.
+      w2yam(1:ngrid,1)=0.
+      t2yam(1:ngrid,1)=0.
+
+      smyam(1:ngrid,2:klev)=sm(1:ngrid,2:klev)
+      styam(1:ngrid,2:klev)=sm(1:ngrid,2:klev)*alpha(1:ngrid,2:klev)
+      lyam(1:ngrid,2:klev)=l(1:ngrid,2:klev)
+      knyam(1:ngrid,2:klev)=kn(1:ngrid,2:klev)
+
+c   Estimations de w'2 et T'2 d'apres Abdela et McFarlane
+
+      w2yam(1:ngrid,2:klev)=q2(1:ngrid,2:klev)*0.24
+     s    +lyam(1:ngrid,2:klev)*5.17*kn(1:ngrid,2:klev)
+     s    *n2(1:ngrid,2:klev)/sqrt(q2(1:ngrid,2:klev))
+
+      t2yam(1:ngrid,2:klev)=9.1*kn(1:ngrid,2:klev)
+     s    *dtetadz(1:ngrid,2:klev)**2
+     s    /sqrt(q2(1:ngrid,2:klev))*lyam(1:ngrid,2:klev)
+      endif
+
+c     print*,'OKFIN'
+      first=.false.
+      return
+      end
+      SUBROUTINE vdif_q2(timestep,gravity,rconst,ngrid,plev,temp,
+     &  kmy,q2)
+      use dimphy
+      IMPLICIT NONE
+c.......................................................................
+#include "dimensions.h"
+cccc#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+
+      real plev(klon,klev+1)
+      real temp(klon,klev)
+      real timestep
+      real gravity,rconst
+      real kstar(klon,klev+1),zz
+      real kmy(klon,klev+1)
+      real q2(klon,klev+1)
+      real deltap(klon,klev+1)
+      real denom(klon,klev+1),alpha(klon,klev+1),beta(klon,klev+1)
+      integer ngrid
+
+      integer i,k
+
+! 	print*,'RD=',rconst
+      do k=1,klev
+         do i=1,ngrid
+c test
+!       print*,'i,k',i,k
+! 	print*,'temp(i,k)=',temp(i,k)
+! 	print*,'(plev(i,k)-plev(i,k+1))=',plev(i,k),plev(i,k+1)
+            zz=(plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k))
+            kstar(i,k)=0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz
+     s      /(plev(i,k)-plev(i,k+1))*timestep
+         enddo
+      enddo
+
+      do k=2,klev
+         do i=1,ngrid
+            deltap(i,k)=0.5*(plev(i,k-1)-plev(i,k+1))
+         enddo
+      enddo
+      do i=1,ngrid
+         deltap(i,1)=0.5*(plev(i,1)-plev(i,2))
+         deltap(i,klev+1)=0.5*(plev(i,klev)-plev(i,klev+1))
+         denom(i,klev+1)=deltap(i,klev+1)+kstar(i,klev)
+         alpha(i,klev+1)=deltap(i,klev+1)*q2(i,klev+1)/denom(i,klev+1)
+         beta(i,klev+1)=kstar(i,klev)/denom(i,klev+1)
+      enddo
+
+      do k=klev,2,-1
+         do i=1,ngrid
+            denom(i,k)=deltap(i,k)+(1.-beta(i,k+1))*
+     s      kstar(i,k)+kstar(i,k-1)
+c   correction d'un bug 10 01 2001
+            alpha(i,k)=(q2(i,k)*deltap(i,k)
+     s      +kstar(i,k)*alpha(i,k+1))/denom(i,k)
+            beta(i,k)=kstar(i,k-1)/denom(i,k)
+         enddo
+      enddo
+
+c  Si on recalcule q2(1)
+      if(1.eq.0) then
+      do i=1,ngrid
+         denom(i,1)=deltap(i,1)+(1-beta(i,2))*kstar(i,1)
+         q2(i,1)=(q2(i,1)*deltap(i,1)
+     s      +kstar(i,1)*alpha(i,2))/denom(i,1)
+      enddo
+      endif
+c   sinon, on peut sauter cette boucle...
+
+      do k=2,klev+1
+         do i=1,ngrid
+            q2(i,k)=alpha(i,k)+beta(i,k)*q2(i,k-1)
+         enddo
+      enddo
+
+      return
+      end
+      SUBROUTINE vdif_q2e(timestep,gravity,rconst,ngrid,
+     &   plev,temp,kmy,q2)
+      use dimphy
+      IMPLICIT NONE
+c.......................................................................
+#include "dimensions.h"
+cccc#include "dimphy.h"
+c.......................................................................
+c
+c dt : pas de temps
+
+      real plev(klon,klev+1)
+      real temp(klon,klev)
+      real timestep
+      real gravity,rconst
+      real kstar(klon,klev+1),zz
+      real kmy(klon,klev+1)
+      real q2(klon,klev+1)
+      real deltap(klon,klev+1)
+      real denom(klon,klev+1),alpha(klon,klev+1),beta(klon,klev+1)
+      integer ngrid
+
+      integer i,k
+
+      do k=1,klev
+         do i=1,ngrid
+            zz=(plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k))
+            kstar(i,k)=0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz
+     s      /(plev(i,k)-plev(i,k+1))*timestep
+         enddo
+      enddo
+
+      do k=2,klev
+         do i=1,ngrid
+            deltap(i,k)=0.5*(plev(i,k-1)-plev(i,k+1))
+         enddo
+      enddo
+      do i=1,ngrid
+         deltap(i,1)=0.5*(plev(i,1)-plev(i,2))
+         deltap(i,klev+1)=0.5*(plev(i,klev)-plev(i,klev+1))
+      enddo
+
+      do k=klev,2,-1
+         do i=1,ngrid
+            q2(i,k)=q2(i,k)+
+     s      ( kstar(i,k)*(q2(i,k+1)-q2(i,k))
+     s       -kstar(i,k-1)*(q2(i,k)-q2(i,k-1)) )
+     s      /deltap(i,k)
+         enddo
+      enddo
+
+      do i=1,ngrid
+         q2(i,1)=q2(i,1)+
+     s   ( kstar(i,1)*(q2(i,2)-q2(i,1))
+     s                                      )
+     s   /deltap(i,1)
+         q2(i,klev+1)=q2(i,klev+1)+
+     s   ( 
+     s    -kstar(i,klev)*(q2(i,klev+1)-q2(i,klev)) )
+     s   /deltap(i,klev+1)
+      enddo
+
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada4.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada4.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada4.F90	(revision 17)
@@ -0,0 +1,645 @@
+!
+! $Header$
+!
+      SUBROUTINE yamada4(ngrid,dt,g,rconst,plev,temp                                 &
+       &   ,zlev,zlay,u,v,teta,cd,q2,km,kn,kq,ustar                                  &
+       &   ,iflag_pbl)
+      use dimphy
+      IMPLICIT NONE
+#include "iniprint.h"
+!c.......................................................................
+!cym#include "dimensions.h"
+!cym#include "dimphy.h"
+!c.......................................................................
+!c
+!c dt : pas de temps
+!c g  : g
+!c zlev : altitude a chaque niveau (interface inferieure de la couche
+!c        de meme indice)
+!c zlay : altitude au centre de chaque couche
+!c u,v : vitesse au centre de chaque couche
+!c       (en entree : la valeur au debut du pas de temps)
+!c teta : temperature potentielle au centre de chaque couche
+!c        (en entree : la valeur au debut du pas de temps)
+!c cd : cdrag
+!c      (en entree : la valeur au debut du pas de temps)
+!c q2 : $q^2$ au bas de chaque couche
+!c      (en entree : la valeur au debut du pas de temps)
+!c      (en sortie : la valeur a la fin du pas de temps)
+!c km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+!c      couche)
+!c      (en sortie : la valeur a la fin du pas de temps)
+!c kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+!c      (en sortie : la valeur a la fin du pas de temps)
+!c
+!c  iflag_pbl doit valoir entre 6 et 9
+!c      l=6, on prend  systematiquement une longueur d'equilibre
+!c    iflag_pbl=6 : MY 2.0
+!c    iflag_pbl=7 : MY 2.0.Fournier
+!c    iflag_pbl=8/9 : MY 2.5
+!c       iflag_pbl=8 with special obsolete treatments for convergence
+!c       with Cmpi5 NPv3.1 simulations
+!c    iflag_pbl=10/11 :  New scheme M2 and N2 explicit and dissiptation exact
+!c    iflag_pbl=12 = 11 with vertical diffusion off q2
+!c
+!c  2013/04/01 (FH hourdin@lmd.jussieu.fr)
+!c     Correction for very stable PBLs (iflag_pbl=10 and 11)
+!c     iflag_pbl=8 converges numerically with NPv3.1
+!c     iflag_pbl=11 -> the model starts with NP from start files created by ce0l
+!c                  -> the model can run with longer time-steps.
+!c.......................................................................
+
+      REAL dt,g,rconst
+      real plev(klon,klev+1),temp(klon,klev)
+      real ustar(klon)
+      real kmin,qmin,pblhmin(klon),coriol(klon)
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL u(klon,klev)
+      REAL v(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1),qpre
+      REAL unsdz(klon,klev)
+      REAL unsdzdec(klon,klev+1)
+
+      REAL km(klon,klev+1)
+      REAL kmpre(klon,klev+1),tmp2
+      REAL mpre(klon,klev+1)
+      REAL kn(klon,klev+1)
+      REAL kq(klon,klev+1)
+      real ff(klon,klev+1),delta(klon,klev+1)
+      real aa(klon,klev+1),aa0,aa1
+      integer iflag_pbl,ngrid
+      integer nlay,nlev
+
+      logical first
+      integer ipas
+      save first,ipas
+!cFH/IM     data first,ipas/.true.,0/
+      data first,ipas/.false.,0/
+!$OMP THREADPRIVATE( first,ipas)
+
+      integer ig,k
+
+
+      real ri,zrif,zalpha,zsm,zsn
+      real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev)
+
+      real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1)
+      real dtetadz(klon,klev+1)
+      real m2cstat,mcstat,kmcstat
+      real l(klon,klev+1)
+      real,allocatable,save :: l0(:)
+!$OMP THREADPRIVATE(l0)      
+      real sq(klon),sqz(klon),zz(klon,klev+1)
+      integer iter
+
+      real ric,rifc,b1,kap
+      save ric,rifc,b1,kap
+      data ric,rifc,b1,kap/0.195,0.191,16.6,0.4/
+!$OMP THREADPRIVATE(ric,rifc,b1,kap)
+      real frif,falpha,fsm
+      real fl,zzz,zl0,zq2,zn2
+
+      real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev)                       &
+       &  ,lyam(klon,klev),knyam(klon,klev)                                          &
+       &  ,w2yam(klon,klev),t2yam(klon,klev)
+      logical,save :: firstcall=.true.
+!$OMP THREADPRIVATE(firstcall)       
+      frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
+      falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri)
+      fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
+      fl(zzz,zl0,zq2,zn2)=                                                           &
+       &     max(min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig))                   &
+       &     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) ,1.)
+
+
+      nlay=klev
+      nlev=klev+1
+      
+      if (firstcall) then
+	allocate(l0(klon))
+	firstcall=.false.
+      endif
+
+
+      if (.not.(iflag_pbl.ge.6.and.iflag_pbl.le.12)) then
+           stop'probleme de coherence dans appel a MY'
+      endif
+
+      ipas=ipas+1
+
+
+!c.......................................................................
+!c  les increments verticaux
+!c.......................................................................
+!c
+!c!!!!! allerte !!!!!c
+!c!!!!! zlev n'est pas declare a nlev !!!!!c
+!c!!!!! ---->
+                                                      DO ig=1,ngrid
+            zlev(ig,nlev)=zlay(ig,nlay)                                              &
+       &             +( zlay(ig,nlay) - zlev(ig,nlev-1) )
+                                                      ENDDO
+!c!!!!! <----
+!c!!!!! allerte !!!!!c
+!c
+      DO k=1,nlay
+                                                      DO ig=1,ngrid
+        unsdz(ig,k)=1.E+0/(zlev(ig,k+1)-zlev(ig,k))
+                                                      ENDDO
+      ENDDO
+                                                      DO ig=1,ngrid
+      unsdzdec(ig,1)=1.E+0/(zlay(ig,1)-zlev(ig,1))
+                                                      ENDDO
+      DO k=2,nlay
+                                                      DO ig=1,ngrid
+        unsdzdec(ig,k)=1.E+0/(zlay(ig,k)-zlay(ig,k-1))
+                                                     ENDDO
+      ENDDO
+                                                      DO ig=1,ngrid
+      unsdzdec(ig,nlay+1)=1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay))
+                                                     ENDDO
+!c
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Computing M^2, N^2, Richardson numbers, stability functions
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         dz(ig,k)=zlay(ig,k)-zlay(ig,k-1)
+         m2(ig,k)=((u(ig,k)-u(ig,k-1))**2+(v(ig,k)-v(ig,k-1))**2)                    &
+       &             /(dz(ig,k)*dz(ig,k))
+         dtetadz(ig,k)=(teta(ig,k)-teta(ig,k-1))/dz(ig,k)
+         n2(ig,k)=g*2.*dtetadz(ig,k)/(teta(ig,k-1)+teta(ig,k))
+!c        n2(ig,k)=0.
+         ri=n2(ig,k)/max(m2(ig,k),1.e-10)
+         if (ri.lt.ric) then
+            rif(ig,k)=frif(ri)
+         else
+            rif(ig,k)=rifc
+         endif
+         if(rif(ig,k).lt.0.16) then
+            alpha(ig,k)=falpha(rif(ig,k))
+            sm(ig,k)=fsm(rif(ig,k))
+         else
+            alpha(ig,k)=1.12
+            sm(ig,k)=0.085
+         endif
+         zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k)
+                                                          enddo
+      enddo
+
+
+!c====================================================================
+!c  Computing the mixing length
+!c====================================================================
+
+!c   Mise a jour de l0
+      if (iflag_pbl==8.or.iflag_pbl==10) then
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Iterative computation of l0
+! This version is kept for iflag_pbl only for convergence
+! with NPv3.1 Cmip5 simulations
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+                                                          do ig=1,ngrid
+      sq(ig)=1.e-10
+      sqz(ig)=1.e-10
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        zq=sqrt(q2(ig,k))
+        sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+        sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+      enddo
+                                                          do ig=1,ngrid
+      l0(ig)=0.2*sqz(ig)/sq(ig)
+                                                          enddo
+      do k=2,klev
+                                                          do ig=1,ngrid
+         l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
+                                                          enddo
+      enddo
+!     print*,'L0 cas 8 ou 10 ',l0
+
+      else
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! In all other case, the assymptotic mixing length l0 is imposed (100m)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+          l0(:)=150.
+          do k=2,klev
+                                                          do ig=1,ngrid
+             l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
+                                                          enddo
+          enddo
+!     print*,'L0 cas autres ',l0
+
+      endif
+
+
+!c====================================================================
+!c   Yamada 2.0
+!c====================================================================
+      if (iflag_pbl.eq.6) then
+
+      do k=2,klev
+         q2(:,k)=l(:,k)**2*zz(:,k)
+      enddo
+
+
+      else if (iflag_pbl.eq.7) then
+!c====================================================================
+!c   Yamada 2.Fournier
+!c====================================================================
+
+!c  Calcul de l,  km, au pas precedent
+      do k=2,klev
+                                                          do ig=1,ngrid
+!c        print*,'SMML=',sm(ig,k),l(ig,k)
+         delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k))
+         kmpre(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         mpre(ig,k)=sqrt(m2(ig,k))
+!c        print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k)
+                                                          enddo
+      enddo
+
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        m2cstat=max(alpha(ig,k)*n2(ig,k)+delta(ig,k)/b1,1.e-12)
+        mcstat=sqrt(m2cstat)
+
+!c        print*,'M2 L=',k,mpre(ig,k),mcstat
+!c
+!c  -----{puis on ecrit la valeur de q qui annule l'equation de m
+!c        supposee en q3}
+!c
+        IF (k.eq.2) THEN
+          kmcstat=1.E+0 / mcstat                                                     &
+       &    *( unsdz(ig,k)*kmpre(ig,k+1)                                             &
+       &                        *mpre(ig,k+1)                                        &
+       &      +unsdz(ig,k-1)                                                         &
+       &              *cd(ig)                                                        &
+       &              *( sqrt(u(ig,3)**2+v(ig,3)**2)                                 &
+       &                -mcstat/unsdzdec(ig,k)                                       &
+       &                -mpre(ig,k+1)/unsdzdec(ig,k+1) )**2)                         &
+       &      /( unsdz(ig,k)+unsdz(ig,k-1) )
+        ELSE
+          kmcstat=1.E+0 / mcstat                                                     &
+       &    *( unsdz(ig,k)*kmpre(ig,k+1)                                             &
+       &                        *mpre(ig,k+1)                                        &
+       &      +unsdz(ig,k-1)*kmpre(ig,k-1)                                           &
+       &                          *mpre(ig,k-1) )                                    &
+       &      /( unsdz(ig,k)+unsdz(ig,k-1) )
+        ENDIF
+!c       print*,'T2 L=',k,tmp2
+        tmp2=kmcstat                                                                 &
+       &      /( sm(ig,k)/q2(ig,k) )                                                 &
+       &      /l(ig,k)
+        q2(ig,k)=max(tmp2,1.e-12)**(2./3.)
+!c       print*,'Q2 L=',k,q2(ig,k)
+!c
+                                                          enddo
+      enddo
+
+      else if (iflag_pbl==8.or.iflag_pbl==9) then
+!c====================================================================
+!c   Yamada 2.5 a la Didi
+!c====================================================================
+
+
+!c  Calcul de l,  km, au pas precedent
+      do k=2,klev
+                                                          do ig=1,ngrid
+!c        print*,'SMML=',sm(ig,k),l(ig,k)
+         delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k))
+         if (delta(ig,k).lt.1.e-20) then
+!c     print*,'ATTENTION   L=',k,'   Delta=',delta(ig,k)
+            delta(ig,k)=1.e-20
+         endif
+         km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         aa0=                                                                        &
+       &   (m2(ig,k)-alpha(ig,k)*n2(ig,k)-delta(ig,k)/b1)
+         aa1=                                                                        &
+       &   (m2(ig,k)*(1.-rif(ig,k))-delta(ig,k)/b1)
+!c abder      print*,'AA L=',k,aa0,aa1,aa1/max(m2(ig,k),1.e-20)
+         aa(ig,k)=aa1*dt/(delta(ig,k)*l(ig,k))
+!c     print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k)
+         qpre=sqrt(q2(ig,k))
+!        if (iflag_pbl.eq.8 ) then
+            if (aa(ig,k).gt.0.) then
+               q2(ig,k)=(qpre+aa(ig,k)*qpre*qpre)**2
+            else
+               q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
+            endif
+!        else ! iflag_pbl=9
+!           if (aa(ig,k)*qpre.gt.0.9) then
+!              q2(ig,k)=(qpre*10.)**2
+!           else
+!              q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
+!           endif
+!        endif
+         q2(ig,k)=min(max(q2(ig,k),1.e-10),1.e4)
+!c     print*,'Q2 L=',k,q2(ig,k),qpre*qpre
+                                                          enddo
+      enddo
+
+      else if (iflag_pbl>=10) then
+
+!        print*,'Schema mixte D'
+!        print*,'Longueur ',l(:,:)
+         do k=2,klev-1
+            l(:,k)=max(l(:,k),1.)
+            km(:,k)=l(:,k)*sqrt(q2(:,k))*sm(:,k)
+            q2(:,k)=q2(:,k)+dt*km(:,k)*m2(:,k)*(1.-rif(:,k))
+            q2(:,k)=min(max(q2(:,k),1.e-10),1.e4)
+            q2(:,k)=1./(1./sqrt(q2(:,k))+dt/(2*l(:,k)*b1))
+            q2(:,k)=q2(:,k)*q2(:,k)
+         enddo
+
+
+      else
+         stop'Cas nom prevu dans yamada4'
+
+      endif ! Fin du cas 8
+
+!c     print*,'OK8'
+
+!c====================================================================
+!c   Calcul des coefficients de mï¿œange
+!c====================================================================
+      do k=2,klev
+!c     print*,'k=',k
+                                                          do ig=1,ngrid
+!cabde      print*,'KML=',l(ig,k),q2(ig,k),sm(ig,k)
+         zq=sqrt(q2(ig,k))
+         km(ig,k)=l(ig,k)*zq*sm(ig,k)
+         kn(ig,k)=km(ig,k)*alpha(ig,k)
+         kq(ig,k)=l(ig,k)*zq*0.2
+!c     print*,'KML=',km(ig,k),kn(ig,k)
+                                                          enddo
+      enddo
+
+! Transport diffusif vertical de la TKE.
+      if (iflag_pbl.ge.12) then
+!       print*,'YAMADA VDIF'
+        q2(:,1)=q2(:,2)
+        call vdif_q2(dt,g,rconst,ngrid,plev,temp,kq,q2)
+      endif
+
+!c   Traitement des cas noctrunes avec l'introduction d'une longueur
+!c   minilale.
+
+!c====================================================================
+!c   Traitement particulier pour les cas tres stables.
+!c   D'apres Holtslag Boville.
+
+      if (prt_level>1) THEN
+       print*,'YAMADA4 0'
+      endif !(prt_level>1) THEN
+                                                          do ig=1,ngrid
+      coriol(ig)=1.e-4
+      pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5)
+                                                          enddo
+
+!     print*,'pblhmin ',pblhmin
+!CTest a remettre 21 11 02
+!c test abd 13 05 02      if(0.eq.1) then
+      if(1==1) then
+      if(iflag_pbl==8.or.iflag_pbl==10) then
+
+      do k=2,klev
+         do ig=1,ngrid
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=-1. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            if (kn(ig,k).lt.kmin.or.km(ig,k).lt.kmin) then
+!c               print*,'Seuil min Km K=',k,kmin,km(ig,k),kn(ig,k)
+!c     s           ,sqrt(q2(ig,k)),pblhmin(ig),qmin/sm(ig,k)
+               kn(ig,k)=kmin
+               km(ig,k)=kmin
+               kq(ig,k)=kmin
+!c   la longueur de melange est suposee etre l= kap z
+!c   K=l q Sm d'ou q2=(K/l Sm)**2
+               q2(ig,k)=(qmin/sm(ig,k))**2
+            endif
+         enddo
+      enddo
+
+      else
+
+      do k=2,klev
+         do ig=1,ngrid
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=-1. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            if (kn(ig,k).lt.kmin.or.km(ig,k).lt.kmin) then
+!c               print*,'Seuil min Km K=',k,kmin,km(ig,k),kn(ig,k)
+!c     s           ,sqrt(q2(ig,k)),pblhmin(ig),qmin/sm(ig,k)
+               kn(ig,k)=kmin
+               km(ig,k)=kmin
+               kq(ig,k)=kmin
+!c   la longueur de melange est suposee etre l= kap z
+!c   K=l q Sm d'ou q2=(K/l Sm)**2
+               sm(ig,k)=1.
+               alpha(ig,k)=1.
+               q2(ig,k)=min((qmin/sm(ig,k))**2,10.)
+               zq=sqrt(q2(ig,k))
+               km(ig,k)=l(ig,k)*zq*sm(ig,k)
+               kn(ig,k)=km(ig,k)*alpha(ig,k)
+               kq(ig,k)=l(ig,k)*zq*0.2
+            endif
+         enddo
+      enddo
+      endif
+
+      endif
+
+      if (prt_level>1) THEN
+       print*,'YAMADA4 1'
+      endif !(prt_level>1) THEN
+!c   Diagnostique pour stokage
+
+      if(1.eq.0)then
+      rino=rif
+      smyam(1:ngrid,1)=0.
+      styam(1:ngrid,1)=0.
+      lyam(1:ngrid,1)=0.
+      knyam(1:ngrid,1)=0.
+      w2yam(1:ngrid,1)=0.
+      t2yam(1:ngrid,1)=0.
+
+      smyam(1:ngrid,2:klev)=sm(1:ngrid,2:klev)
+      styam(1:ngrid,2:klev)=sm(1:ngrid,2:klev)*alpha(1:ngrid,2:klev)
+      lyam(1:ngrid,2:klev)=l(1:ngrid,2:klev)
+      knyam(1:ngrid,2:klev)=kn(1:ngrid,2:klev)
+
+!c   Estimations de w'2 et T'2 d'apres Abdela et McFarlane
+
+      w2yam(1:ngrid,2:klev)=q2(1:ngrid,2:klev)*0.24                                  &
+       &    +lyam(1:ngrid,2:klev)*5.17*kn(1:ngrid,2:klev)                            &
+       &    *n2(1:ngrid,2:klev)/sqrt(q2(1:ngrid,2:klev))
+
+      t2yam(1:ngrid,2:klev)=9.1*kn(1:ngrid,2:klev)                                   &
+       &    *dtetadz(1:ngrid,2:klev)**2                                              &
+       &    /sqrt(q2(1:ngrid,2:klev))*lyam(1:ngrid,2:klev)
+      endif
+
+!c     print*,'OKFIN'
+      first=.false.
+      return
+      end
+      SUBROUTINE vdif_q2(timestep,gravity,rconst,ngrid,plev,temp,                    &
+       &  kmy,q2)
+      use dimphy
+      IMPLICIT NONE
+!c.......................................................................
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+!c.......................................................................
+!c
+!c dt : pas de temps
+
+      real plev(klon,klev+1)
+      real temp(klon,klev)
+      real timestep
+      real gravity,rconst
+      real kstar(klon,klev+1),zz
+      real kmy(klon,klev+1)
+      real q2(klon,klev+1)
+      real deltap(klon,klev+1)
+      real denom(klon,klev+1),alpha(klon,klev+1),beta(klon,klev+1)
+      integer ngrid
+
+      integer i,k
+
+! 	print*,'RD=',rconst
+      do k=1,klev
+         do i=1,ngrid
+!c test
+!       print*,'i,k',i,k
+! 	print*,'temp(i,k)=',temp(i,k)
+! 	print*,'(plev(i,k)-plev(i,k+1))=',plev(i,k),plev(i,k+1)
+            zz=(plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k))
+            kstar(i,k)=0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz                             &
+       &      /(plev(i,k)-plev(i,k+1))*timestep
+         enddo
+      enddo
+
+      do k=2,klev
+         do i=1,ngrid
+            deltap(i,k)=0.5*(plev(i,k-1)-plev(i,k+1))
+         enddo
+      enddo
+      do i=1,ngrid
+         deltap(i,1)=0.5*(plev(i,1)-plev(i,2))
+         deltap(i,klev+1)=0.5*(plev(i,klev)-plev(i,klev+1))
+         denom(i,klev+1)=deltap(i,klev+1)+kstar(i,klev)
+         alpha(i,klev+1)=deltap(i,klev+1)*q2(i,klev+1)/denom(i,klev+1)
+         beta(i,klev+1)=kstar(i,klev)/denom(i,klev+1)
+      enddo
+
+      do k=klev,2,-1
+         do i=1,ngrid
+            denom(i,k)=deltap(i,k)+(1.-beta(i,k+1))*                                 &
+       &      kstar(i,k)+kstar(i,k-1)
+!c   correction d'un bug 10 01 2001
+            alpha(i,k)=(q2(i,k)*deltap(i,k)                                          &
+       &      +kstar(i,k)*alpha(i,k+1))/denom(i,k)
+            beta(i,k)=kstar(i,k-1)/denom(i,k)
+         enddo
+      enddo
+
+!c  Si on recalcule q2(1)
+      if(1.eq.0) then
+      do i=1,ngrid
+         denom(i,1)=deltap(i,1)+(1-beta(i,2))*kstar(i,1)
+         q2(i,1)=(q2(i,1)*deltap(i,1)                                                &
+       &      +kstar(i,1)*alpha(i,2))/denom(i,1)
+      enddo
+      endif
+!c   sinon, on peut sauter cette boucle...
+
+      do k=2,klev+1
+         do i=1,ngrid
+            q2(i,k)=alpha(i,k)+beta(i,k)*q2(i,k-1)
+         enddo
+      enddo
+
+      return
+      end
+      SUBROUTINE vdif_q2e(timestep,gravity,rconst,ngrid,                             &
+       &   plev,temp,kmy,q2)
+      use dimphy
+      IMPLICIT NONE
+!c.......................................................................
+#include "dimensions.h"
+!cccc#include "dimphy.h"
+!c.......................................................................
+!c
+!c dt : pas de temps
+
+      real plev(klon,klev+1)
+      real temp(klon,klev)
+      real timestep
+      real gravity,rconst
+      real kstar(klon,klev+1),zz
+      real kmy(klon,klev+1)
+      real q2(klon,klev+1)
+      real deltap(klon,klev+1)
+      real denom(klon,klev+1),alpha(klon,klev+1),beta(klon,klev+1)
+      integer ngrid
+
+      integer i,k
+
+      do k=1,klev
+         do i=1,ngrid
+            zz=(plev(i,k)+plev(i,k+1))*gravity/(rconst*temp(i,k))
+            kstar(i,k)=0.125*(kmy(i,k+1)+kmy(i,k))*zz*zz                             &
+       &      /(plev(i,k)-plev(i,k+1))*timestep
+         enddo
+      enddo
+
+      do k=2,klev
+         do i=1,ngrid
+            deltap(i,k)=0.5*(plev(i,k-1)-plev(i,k+1))
+         enddo
+      enddo
+      do i=1,ngrid
+         deltap(i,1)=0.5*(plev(i,1)-plev(i,2))
+         deltap(i,klev+1)=0.5*(plev(i,klev)-plev(i,klev+1))
+      enddo
+
+      do k=klev,2,-1
+         do i=1,ngrid
+            q2(i,k)=q2(i,k)+                                                         &
+       &      ( kstar(i,k)*(q2(i,k+1)-q2(i,k))                                       &
+       &       -kstar(i,k-1)*(q2(i,k)-q2(i,k-1)) )                                   &
+       &      /deltap(i,k)
+         enddo
+      enddo
+
+      do i=1,ngrid
+         q2(i,1)=q2(i,1)+                                                            &
+       &   ( kstar(i,1)*(q2(i,2)-q2(i,1))                                            &
+       &                                      )                                      &
+       &   /deltap(i,1)
+         q2(i,klev+1)=q2(i,klev+1)+                                                  &
+       &   (                                                                         &
+       &    -kstar(i,klev)*(q2(i,klev+1)-q2(i,klev)) )                               &
+       &   /deltap(i,klev+1)
+      enddo
+
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada_c.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada_c.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/yamada_c.F90	(revision 17)
@@ -0,0 +1,712 @@
+!
+! $Header$
+!
+      SUBROUTINE yamada_c(ngrid,timestep,plev,play &
+     &   ,pu,pv,pt,d_u,d_v,d_t,cd,q2,km,kn,kq,d_t_diss,ustar &
+     &   ,iflag_pbl,okiophys)
+      use dimphy
+      IMPLICIT NONE
+#include "iniprint.h"
+#include "YOMCST.h"
+!.......................................................................
+!ym#include "dimensions.h"
+!ym#include "dimphy.h"
+!.......................................................................
+!
+! timestep : pas de temps
+! g  : g
+! zlev : altitude a chaque niveau (interface inferieure de la couche
+!        de meme indice)
+! zlay : altitude au centre de chaque couche
+! u,v : vitesse au centre de chaque couche
+!       (en entree : la valeur au debut du pas de temps)
+! teta : temperature potentielle au centre de chaque couche
+!        (en entree : la valeur au debut du pas de temps)
+! cd : cdrag
+!      (en entree : la valeur au debut du pas de temps)
+! q2 : $q^2$ au bas de chaque couche
+!      (en entree : la valeur au debut du pas de temps)
+!      (en sortie : la valeur a la fin du pas de temps)
+! km : diffusivite turbulente de quantite de mouvement (au bas de chaque
+!      couche)
+!      (en sortie : la valeur a la fin du pas de temps)
+! kn : diffusivite turbulente des scalaires (au bas de chaque couche)
+!      (en sortie : la valeur a la fin du pas de temps)
+!
+!  iflag_pbl doit valoir entre 6 et 9
+!      l=6, on prend  systematiquement une longueur d'equilibre
+!    iflag_pbl=6 : MY 2.0
+!    iflag_pbl=7 : MY 2.0.Fournier
+!    iflag_pbl=8/9 : MY 2.5
+!       iflag_pbl=8 with special obsolete treatments for convergence
+!       with Cmpi5 NPv3.1 simulations
+!    iflag_pbl=10/11 :  New scheme M2 and N2 explicit and dissiptation exact
+!    iflag_pbl=12 = 11 with vertical diffusion off q2
+!
+!  2013/04/01 (FH hourdin@lmd.jussieu.fr)
+!     Correction for very stable PBLs (iflag_pbl=10 and 11)
+!     iflag_pbl=8 converges numerically with NPv3.1
+!     iflag_pbl=11 -> the model starts with NP from start files created by ce0l
+!                  -> the model can run with longer time-steps.
+!.......................................................................
+
+      REAL, DIMENSION(klon,klev) :: d_u,d_v,d_t
+      REAL, DIMENSION(klon,klev) :: pu,pv,pt
+      REAL, DIMENSION(klon,klev) :: d_t_diss
+      INTEGER okiophys
+
+      REAL timestep
+      real plev(klon,klev+1)
+      real play(klon,klev)
+      real ustar(klon)
+      real kmin,qmin,pblhmin(klon),coriol(klon)
+      REAL zlev(klon,klev+1)
+      REAL zlay(klon,klev)
+      REAL zu(klon,klev)
+      REAL zv(klon,klev)
+      REAL zt(klon,klev)
+      REAL teta(klon,klev)
+      REAL cd(klon)
+      REAL q2(klon,klev+1),qpre
+      REAL unsdz(klon,klev)
+      REAL unsdzdec(klon,klev+1)
+
+      REAL km(klon,klev+1)
+      REAL kmpre(klon,klev+1),tmp2
+      REAL mpre(klon,klev+1)
+      REAL kn(klon,klev+1)
+      REAL kq(klon,klev+1)
+      real ff(klon,klev+1),delta(klon,klev+1)
+      real aa(klon,klev+1),aa0,aa1
+      integer iflag_pbl,ngrid
+      integer nlay,nlev
+
+      logical first
+      integer ipas
+      save first,ipas
+!FH/IM     data first,ipas/.true.,0/
+      data first,ipas/.false.,0/
+!$OMP THREADPRIVATE( first,ipas)
+
+      integer ig,k
+
+
+      real ri,zrif,zalpha,zsm,zsn
+      real rif(klon,klev+1),sm(klon,klev+1),alpha(klon,klev)
+
+      real m2(klon,klev+1),dz(klon,klev+1),zq,n2(klon,klev+1)
+      REAL, DIMENSION(klon,klev+1) :: km2,kn2,sqrtq
+      real dtetadz(klon,klev+1)
+      real m2cstat,mcstat,kmcstat
+      real l(klon,klev+1)
+      real leff(klon,klev+1)
+      real,allocatable,save :: l0(:)
+!$OMP THREADPRIVATE(l0)      
+      real sq(klon),sqz(klon),zz(klon,klev+1)
+      integer iter
+
+      real ric,rifc,b1,kap
+      save ric,rifc,b1,kap
+      data ric,rifc,b1,kap/0.195,0.191,16.6,0.4/
+!$OMP THREADPRIVATE(ric,rifc,b1,kap)
+      real frif,falpha,fsm
+      real fl,zzz,zl0,zq2,zn2
+
+      real rino(klon,klev+1),smyam(klon,klev),styam(klon,klev)
+      real lyam(klon,klev),knyam(klon,klev)
+      real w2yam(klon,klev),t2yam(klon,klev)
+      logical,save :: firstcall=.true.
+
+REAL, DIMENSION(klon,klev+1) :: fluxu,fluxv,fluxt
+REAL, DIMENSION(klon,klev+1) :: dddu,dddv,dddt
+REAL, DIMENSION(klon,klev) :: exner,masse
+REAL, DIMENSION(klon,klev+1) :: masseb,q2old,q2neg
+
+!$OMP THREADPRIVATE(firstcall)       
+      frif(ri)=0.6588*(ri+0.1776-sqrt(ri*ri-0.3221*ri+0.03156))
+      falpha(ri)=1.318*(0.2231-ri)/(0.2341-ri)
+      fsm(ri)=1.96*(0.1912-ri)*(0.2341-ri)/((1.-ri)*(0.2231-ri))
+      fl(zzz,zl0,zq2,zn2)= &
+     &     max(min(l0(ig)*kap*zlev(ig,k)/(kap*zlev(ig,k)+l0(ig)) &
+     &     ,0.5*sqrt(q2(ig,k))/sqrt(max(n2(ig,k),1.e-10))) ,1.)
+
+
+      if (firstcall) then
+        allocate(l0(klon))
+#ifdef IOPHYS
+        call iophys_ini
+#endif
+        firstcall=.false.
+      endif
+
+
+#ifdef IOPHYS
+if (okiophys==1) then
+call iophys_ecrit('q2i',klev,'q2 debut my','m2/s2',q2(:,1:klev))
+call iophys_ecrit('kmi',klev,'Kz debut my','m/s2',km(:,1:klev))
+endif
+#endif
+
+      nlay=klev
+      nlev=klev+1
+
+!-------------------------------------------------------------------------
+! Computation of conservative source terms from the turbulent tendencies
+!-------------------------------------------------------------------------
+
+
+   zu(:,:)=pu(:,:)+0.5*d_u(:,:)
+   zv(:,:)=pv(:,:)+0.5*d_v(:,:)
+   zt(:,:)=pt(:,:)+0.5*d_t(:,:)
+   do k=1,klev
+      exner(:,k)=(play(:,k)/plev(:,1))**RKAPPA
+      masse(:,k)=(plev(:,k)-plev(:,k+1))/RG
+   enddo
+   teta(:,:)=zt(:,:)/exner(:,:)
+
+! Atmospheric mass at layer interfaces, where the TKE is computed
+   masseb(:,:)=0.
+   do k=1,klev
+      masseb(:,k)=masseb(:,k)+masse(:,k)
+      masseb(:,k+1)=masseb(:,k+1)+masse(:,k)
+    enddo
+    masseb(:,:)=0.5*masseb(:,:)
+
+
+
+   zlev(:,1)=0.
+   zlay(:,1)=RCPD*teta(:,1)*(1.-exner(:,1))
+   do k=1,klev-1
+      zlay(:,k+1)=zlay(:,k)+0.5*RCPD*(teta(:,k)+teta(:,k+1))*(exner(:,k)-exner(:,k+1))/RG
+      zlev(:,k)=0.5*(zlay(:,k)+zlay(:,k+1)) ! PASBO
+   enddo
+
+   fluxu(:,klev+1)=0.
+   fluxv(:,klev+1)=0.
+   fluxt(:,klev+1)=0.
+
+   do k=klev,1,-1
+      fluxu(:,k)=fluxu(:,k+1)+masse(:,k)*d_u(:,k)
+      fluxv(:,k)=fluxv(:,k+1)+masse(:,k)*d_v(:,k)
+      fluxt(:,k)=fluxt(:,k+1)+masse(:,k)*d_t(:,k)/exner(:,k) ! Flux de theta
+   enddo
+
+   dddu(:,1)=2*zu(:,1)*fluxu(:,1)
+   dddv(:,1)=2*zv(:,1)*fluxv(:,1)
+   dddt(:,1)=(exner(:,1)-1.)*fluxt(:,1)
+
+   do k=2,klev
+      dddu(:,k)=(zu(:,k)-zu(:,k-1))*fluxu(:,k)
+      dddv(:,k)=(zv(:,k)-zv(:,k-1))*fluxv(:,k)
+      dddt(:,k)=(exner(:,k)-exner(:,k-1))*fluxt(:,k)
+   enddo
+   dddu(:,klev+1)=0.
+   dddv(:,klev+1)=0.
+   dddt(:,klev+1)=0.
+
+#ifdef IOPHYS
+if (okiophys==1) then
+      call iophys_ecrit('zlay',klev,'Geop','m',zlay)
+      call iophys_ecrit('teta',klev,'teta','K',teta)
+      call iophys_ecrit('temp',klev,'temp','K',zt)
+      call iophys_ecrit('pt',klev,'temp','K',pt)
+      call iophys_ecrit('d_u',klev,'d_u','m/s2',d_u)
+      call iophys_ecrit('d_v',klev,'d_v','m/s2',d_v)
+      call iophys_ecrit('d_t',klev,'d_t','K/s',d_t)
+      call iophys_ecrit('exner',klev,'exner','',exner)
+      call iophys_ecrit('masse',klev,'masse','',masse)
+      call iophys_ecrit('masseb',klev,'masseb','',masseb)
+      call iophys_ecrit('Cm2',klev,'m2 conserv','m/s',(dddu(:,1:klev)+dddv(:,1:klev))/(masseb(:,1:klev)*timestep))
+      call iophys_ecrit('Cn2',klev,'m2 conserv','m/s',(rcpd*dddt(:,1:klev)/masseb(:,1:klev))/timestep)
+      call iophys_ecrit('rifc',klev,'rif conservative','',rcpd*dddt(:,1:klev)/min(dddu(:,1:klev)+dddv(:,1:klev),-1.e-20))
+endif
+#endif
+
+
+
+      ipas=ipas+1
+
+
+!.......................................................................
+!  les increments verticaux
+!.......................................................................
+!
+!!!!!! allerte !!!!!c
+!!!!!! zlev n'est pas declare a nlev !!!!!c
+!!!!!! ---->
+                                                      DO ig=1,ngrid
+            zlev(ig,nlev)=zlay(ig,nlay) &
+     &             +( zlay(ig,nlay) - zlev(ig,nlev-1) )
+                                                      ENDDO
+!!!!!! <----
+!!!!!! allerte !!!!!c
+!
+      DO k=1,nlay
+                                                      DO ig=1,ngrid
+        unsdz(ig,k)=1.E+0/(zlev(ig,k+1)-zlev(ig,k))
+                                                      ENDDO
+      ENDDO
+                                                      DO ig=1,ngrid
+      unsdzdec(ig,1)=1.E+0/(zlay(ig,1)-zlev(ig,1))
+                                                      ENDDO
+      DO k=2,nlay
+                                                      DO ig=1,ngrid
+        unsdzdec(ig,k)=1.E+0/(zlay(ig,k)-zlay(ig,k-1))
+                                                     ENDDO
+      ENDDO
+                                                      DO ig=1,ngrid
+      unsdzdec(ig,nlay+1)=1.E+0/(zlev(ig,nlay+1)-zlay(ig,nlay))
+                                                     ENDDO
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Computing M^2, N^2, Richardson numbers, stability functions
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+      do k=2,klev
+                                                          do ig=1,ngrid
+         dz(ig,k)=zlay(ig,k)-zlay(ig,k-1)
+         m2(ig,k)=((zu(ig,k)-zu(ig,k-1))**2+(zv(ig,k)-zv(ig,k-1))**2)/(dz(ig,k)*dz(ig,k))
+         dtetadz(ig,k)=(teta(ig,k)-teta(ig,k-1))/dz(ig,k)
+         n2(ig,k)=RG*2.*dtetadz(ig,k)/(teta(ig,k-1)+teta(ig,k))
+!        n2(ig,k)=0.
+         ri=n2(ig,k)/max(m2(ig,k),1.e-10)
+         if (ri.lt.ric) then
+            rif(ig,k)=frif(ri)
+         else
+            rif(ig,k)=rifc
+         endif
+         if(rif(ig,k).lt.0.16) then
+            alpha(ig,k)=falpha(rif(ig,k))
+            sm(ig,k)=fsm(rif(ig,k))
+         else
+            alpha(ig,k)=1.12
+            sm(ig,k)=0.085
+         endif
+         zz(ig,k)=b1*m2(ig,k)*(1.-rif(ig,k))*sm(ig,k)
+                                                          enddo
+      enddo
+
+
+
+!====================================================================
+!  Computing the mixing length
+!====================================================================
+
+!   Mise a jour de l0
+      if (iflag_pbl==8.or.iflag_pbl==10) then
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Iterative computation of l0
+! This version is kept for iflag_pbl only for convergence
+! with NPv3.1 Cmip5 simulations
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+                                                          do ig=1,ngrid
+      sq(ig)=1.e-10
+      sqz(ig)=1.e-10
+                                                          enddo
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        zq=sqrt(q2(ig,k))
+        sqz(ig)=sqz(ig)+zq*zlev(ig,k)*(zlay(ig,k)-zlay(ig,k-1))
+        sq(ig)=sq(ig)+zq*(zlay(ig,k)-zlay(ig,k-1))
+                                                          enddo
+      enddo
+                                                          do ig=1,ngrid
+      l0(ig)=0.2*sqz(ig)/sq(ig)
+                                                          enddo
+      do k=2,klev
+                                                          do ig=1,ngrid
+         l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
+                                                          enddo
+      enddo
+!     print*,'L0 cas 8 ou 10 ',l0
+
+      else
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! In all other case, the assymptotic mixing length l0 is imposed (100m)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+          l0(:)=150.
+          do k=2,klev
+                                                          do ig=1,ngrid
+             l(ig,k)=fl(zlev(ig,k),l0(ig),q2(ig,k),n2(ig,k))
+                                                          enddo
+          enddo
+!     print*,'L0 cas autres ',l0
+
+      endif
+
+
+#ifdef IOPHYS
+if (okiophys==1) then
+call iophys_ecrit('rif',klev,'Flux Richardson','m',rif(:,1:klev))
+call iophys_ecrit('m2',klev,'m2 ','m/s',m2(:,1:klev))
+call iophys_ecrit('Km2',klev,'m2 conserv','m/s',km(:,1:klev)*m2(:,1:klev))
+call iophys_ecrit('Km',klev,'Km','m2/s',km(:,1:klev))
+endif
+#endif
+
+
+IF (iflag_pbl<20) then
+      ! For diagnostics only
+      RETURN
+
+ELSE
+
+!  print*,'OK1'
+
+! Evolution of TKE under source terms K M2 and K N2
+   leff(:,:)=max(l(:,:),1.)
+   IF (iflag_pbl==29) THEN
+      km2(:,:)=km(:,:)*m2(:,:)
+      kn2(:,:)=kn2(:,:)*rif(:,:)
+   ELSEIF (iflag_pbl==25) THEN
+      DO k=1,klev
+         km2(:,k)=-0.5*(dddu(:,k)+dddv(:,k)+dddu(:,k+1)+dddv(:,k+1)) &
+         &        /(masse(:,k)*timestep)
+         kn2(:,k)=rcpd*0.5*(dddt(:,k)+dddt(:,k+1))/(masse(:,k)*timestep)
+         leff(:,k)=0.5*(leff(:,k)+leff(:,k+1))
+      ENDDO
+      km2(:,klev+1)=0. ; kn2(:,klev+1)=0.
+   ELSE
+      km2(:,:)=-(dddu(:,:)+dddv(:,:))/(masseb(:,:)*timestep)
+      kn2(:,:)=rcpd*dddt(:,:)/(masseb(:,:)*timestep)
+   ENDIF
+   q2neg(:,:)=q2(:,:)+timestep*(km2(:,:)-kn2(:,:))
+   q2(:,:)=min(max(q2neg(:,:),1.e-10),1.e4)
+
+! Dissipation of TKE
+   q2old(:,:)=q2(:,:)
+   q2(:,:)=1./(1./sqrt(q2(:,:))+timestep/(2*leff(:,:)*b1))
+   q2(:,:)=q2(:,:)*q2(:,:)
+   IF (iflag_pbl<=24) THEN
+      DO k=1,klev
+         d_t_diss(:,k)=(masseb(:,k)*(q2neg(:,k)-q2(:,k))+masseb(:,k+1)*(q2neg(:,k+1)-q2(:,k+1)))/(2.*rcpd*masse(:,k))
+      ENDDO
+   ELSE IF (iflag_pbl<=27) THEN
+      DO k=1,klev
+         d_t_diss(:,k)=(q2neg(:,k)-q2(:,k))/rcpd
+      ENDDO
+   ENDIF
+!  print*,'iflag_pbl ',d_t_diss
+
+
+! Compuation of stability functions
+   IF (iflag_pbl/=29) THEN
+      DO k=1,klev
+      DO ig=1,ngrid
+         IF (ABS(km2(ig,k))<=1.e-20) THEN
+            rif(ig,k)=0.
+         ELSE
+            rif(ig,k)=min(kn2(ig,k)/km2(ig,k),rifc)
+         ENDIF
+         IF (rif(ig,k).lt.0.16) THEN
+            alpha(ig,k)=falpha(rif(ig,k))
+            sm(ig,k)=fsm(rif(ig,k))
+         else
+            alpha(ig,k)=1.12
+            sm(ig,k)=0.085
+         endif
+      ENDDO
+      ENDDO
+    ENDIF
+
+! Computation of turbulent diffusivities
+   IF (25<=iflag_pbl.and.iflag_pbl<=28) THEN
+     DO k=2,klev
+        sqrtq(:,k)=sqrt(0.5*(q2(:,k)+q2(:,k-1)))
+     ENDDO
+   ELSE
+     DO k=2,klev
+        sqrtq(:,k)=sqrt(q2(:,k))
+     ENDDO
+   ENDIF
+   DO k=2,klev
+   DO ig=1,ngrid
+      km(ig,k)=leff(ig,k)*sqrtq(ig,k)*sm(ig,k)
+      kn(ig,k)=km(ig,k)*alpha(ig,k)
+      kq(ig,k)=leff(ig,k)*zq*0.2
+!         print*,q2(ig,k),zq,km(ig,k)
+   ENDDO
+   ENDDO
+
+
+
+#ifdef IOPHYS
+if (okiophys==1) then
+call iophys_ecrit('mixingl',klev,'Mixing length','m',leff(:,1:klev))
+call iophys_ecrit('rife',klev,'Flux Richardson','m',rif(:,1:klev))
+call iophys_ecrit('q2f',klev,'KTE finale','m2/s',q2(:,1:klev))
+call iophys_ecrit('q2neg',klev,'KTE non bornee','m2/s',q2neg(:,1:klev))
+call iophys_ecrit('alpha',klev,'alpha','',alpha(:,1:klev))
+call iophys_ecrit('sm',klev,'sm','',sm(:,1:klev))
+call iophys_ecrit('q2f',klev,'KTE finale','m2/s',q2(:,1:klev))
+call iophys_ecrit('kmf',klev,'Kz final','m2/s',km(:,1:klev))
+call iophys_ecrit('knf',klev,'Kz final','m2/s',kn(:,1:klev))
+call iophys_ecrit('kqf',klev,'Kz final','m2/s',kq(:,1:klev))
+endif
+#endif
+
+ENDIF
+
+
+!  print*,'OK2'
+      RETURN
+!====================================================================
+!   Yamada 2.0
+!====================================================================
+      if (iflag_pbl.eq.6) then
+
+      do k=2,klev
+         q2(:,k)=l(:,k)**2*zz(:,k)
+      enddo
+
+
+      else if (iflag_pbl.eq.7) then
+!====================================================================
+!   Yamada 2.Fournier
+!====================================================================
+
+!  Calcul de l,  km, au pas precedent
+      do k=2,klev
+                                                          do ig=1,ngrid
+!        print*,'SMML=',sm(ig,k),l(ig,k)
+         delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k))
+         kmpre(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         mpre(ig,k)=sqrt(m2(ig,k))
+!        print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k)
+                                                          enddo
+      enddo
+
+      do k=2,klev-1
+                                                          do ig=1,ngrid
+        m2cstat=max(alpha(ig,k)*n2(ig,k)+delta(ig,k)/b1,1.e-12)
+        mcstat=sqrt(m2cstat)
+
+!        print*,'M2 L=',k,mpre(ig,k),mcstat
+!
+!  -----{puis on ecrit la valeur de q qui annule l'equation de m
+!        supposee en q3}
+!
+        IF (k.eq.2) THEN
+          kmcstat=1.E+0 / mcstat &
+     &    *( unsdz(ig,k)*kmpre(ig,k+1) &
+     &                        *mpre(ig,k+1) &
+     &      +unsdz(ig,k-1) &
+     &              *cd(ig) &
+     &              *( sqrt(zu(ig,3)**2+zv(ig,3)**2) &
+     &                -mcstat/unsdzdec(ig,k) &
+     &                -mpre(ig,k+1)/unsdzdec(ig,k+1) )**2) &
+     &      /( unsdz(ig,k)+unsdz(ig,k-1) )
+        ELSE
+          kmcstat=1.E+0 / mcstat &
+     &    *( unsdz(ig,k)*kmpre(ig,k+1) &
+     &                        *mpre(ig,k+1) &
+     &      +unsdz(ig,k-1)*kmpre(ig,k-1) &
+     &                          *mpre(ig,k-1) ) &
+     &      /( unsdz(ig,k)+unsdz(ig,k-1) )
+        ENDIF
+!       print*,'T2 L=',k,tmp2
+        tmp2=kmcstat &
+     &      /( sm(ig,k)/q2(ig,k) ) &
+     &      /l(ig,k)
+        q2(ig,k)=max(tmp2,1.e-12)**(2./3.)
+!       print*,'Q2 L=',k,q2(ig,k)
+!
+                                                          enddo
+      enddo
+
+      else if (iflag_pbl==8.or.iflag_pbl==9) then
+!====================================================================
+!   Yamada 2.5 a la Didi
+!====================================================================
+
+
+!  Calcul de l,  km, au pas precedent
+      do k=2,klev
+                                                          do ig=1,ngrid
+!        print*,'SMML=',sm(ig,k),l(ig,k)
+         delta(ig,k)=q2(ig,k)/(l(ig,k)**2*sm(ig,k))
+         if (delta(ig,k).lt.1.e-20) then
+!     print*,'ATTENTION   L=',k,'   Delta=',delta(ig,k)
+            delta(ig,k)=1.e-20
+         endif
+         km(ig,k)=l(ig,k)*sqrt(q2(ig,k))*sm(ig,k)
+         aa0=(m2(ig,k)-alpha(ig,k)*n2(ig,k)-delta(ig,k)/b1)
+         aa1=(m2(ig,k)*(1.-rif(ig,k))-delta(ig,k)/b1)
+! abder      print*,'AA L=',k,aa0,aa1,aa1/max(m2(ig,k),1.e-20)
+         aa(ig,k)=aa1*timestep/(delta(ig,k)*l(ig,k))
+!     print*,'0L=',k,l(ig,k),delta(ig,k),km(ig,k)
+         qpre=sqrt(q2(ig,k))
+!        if (iflag_pbl.eq.8 ) then
+            if (aa(ig,k).gt.0.) then
+               q2(ig,k)=(qpre+aa(ig,k)*qpre*qpre)**2
+            else
+               q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
+            endif
+!        else ! iflag_pbl=9
+!           if (aa(ig,k)*qpre.gt.0.9) then
+!              q2(ig,k)=(qpre*10.)**2
+!           else
+!              q2(ig,k)=(qpre/(1.-aa(ig,k)*qpre))**2
+!           endif
+!        endif
+         q2(ig,k)=min(max(q2(ig,k),1.e-10),1.e4)
+!     print*,'Q2 L=',k,q2(ig,k),qpre*qpre
+                                                          enddo
+      enddo
+
+      else if (iflag_pbl>=10) then
+
+!        print*,'Schema mixte D'
+!        print*,'Longueur ',l(:,:)
+         do k=2,klev-1
+            l(:,k)=max(l(:,k),1.)
+            km(:,k)=l(:,k)*sqrt(q2(:,k))*sm(:,k)
+            q2(:,k)=q2(:,k)+timestep*km(:,k)*m2(:,k)*(1.-rif(:,k))
+            q2(:,k)=min(max(q2(:,k),1.e-10),1.e4)
+            q2(:,k)=1./(1./sqrt(q2(:,k))+timestep/(2*l(:,k)*b1))
+            q2(:,k)=q2(:,k)*q2(:,k)
+         enddo
+
+
+      else
+         stop'Cas nom prevu dans yamada4'
+
+      endif ! Fin du cas 8
+
+!     print*,'OK8'
+
+!====================================================================
+!   Calcul des coefficients de mï¿œange
+!====================================================================
+      do k=2,klev
+!     print*,'k=',k
+                                                          do ig=1,ngrid
+!abde      print*,'KML=',l(ig,k),q2(ig,k),sm(ig,k)
+         zq=sqrt(q2(ig,k))
+         km(ig,k)=l(ig,k)*zq*sm(ig,k)
+         kn(ig,k)=km(ig,k)*alpha(ig,k)
+         kq(ig,k)=l(ig,k)*zq*0.2
+!     print*,'KML=',km(ig,k),kn(ig,k)
+                                                          enddo
+      enddo
+
+! Transport diffusif vertical de la TKE.
+      if (iflag_pbl.ge.12) then
+!       print*,'YAMADA VDIF'
+        q2(:,1)=q2(:,2)
+        call vdif_q2(timestep,RG,RD,ngrid,plev,zt,kq,q2)
+      endif
+
+!   Traitement des cas noctrunes avec l'introduction d'une longueur
+!   minilale.
+
+!====================================================================
+!   Traitement particulier pour les cas tres stables.
+!   D'apres Holtslag Boville.
+
+      if (prt_level>1) THEN
+       print*,'YAMADA4 0'
+      endif !(prt_level>1) THEN
+                                                          do ig=1,ngrid
+      coriol(ig)=1.e-4
+      pblhmin(ig)=0.07*ustar(ig)/max(abs(coriol(ig)),2.546e-5)
+                                                          enddo
+
+!     print*,'pblhmin ',pblhmin
+!Test a remettre 21 11 02
+! test abd 13 05 02      if(0.eq.1) then
+      if(1==1) then
+      if(iflag_pbl==8.or.iflag_pbl==10) then
+
+      do k=2,klev
+         do ig=1,ngrid
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=-1. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            if (kn(ig,k).lt.kmin.or.km(ig,k).lt.kmin) then
+!               print*,'Seuil min Km K=',k,kmin,km(ig,k),kn(ig,k)
+!     s           ,sqrt(q2(ig,k)),pblhmin(ig),qmin/sm(ig,k)
+               kn(ig,k)=kmin
+               km(ig,k)=kmin
+               kq(ig,k)=kmin
+!   la longueur de melange est suposee etre l= kap z
+!   K=l q Sm d'ou q2=(K/l Sm)**2
+               q2(ig,k)=(qmin/sm(ig,k))**2
+            endif
+         enddo
+      enddo
+
+      else
+
+      do k=2,klev
+         do ig=1,ngrid
+            if (teta(ig,2).gt.teta(ig,1)) then
+               qmin=ustar(ig)*(max(1.-zlev(ig,k)/pblhmin(ig),0.))**2
+               kmin=kap*zlev(ig,k)*qmin
+            else
+               kmin=-1. ! kmin n'est utilise que pour les SL stables.
+            endif 
+            if (kn(ig,k).lt.kmin.or.km(ig,k).lt.kmin) then
+!               print*,'Seuil min Km K=',k,kmin,km(ig,k),kn(ig,k)
+!     s           ,sqrt(q2(ig,k)),pblhmin(ig),qmin/sm(ig,k)
+               kn(ig,k)=kmin
+               km(ig,k)=kmin
+               kq(ig,k)=kmin
+!   la longueur de melange est suposee etre l= kap z
+!   K=l q Sm d'ou q2=(K/l Sm)**2
+               sm(ig,k)=1.
+               alpha(ig,k)=1.
+               q2(ig,k)=min((qmin/sm(ig,k))**2,10.)
+               zq=sqrt(q2(ig,k))
+               km(ig,k)=l(ig,k)*zq*sm(ig,k)
+               kn(ig,k)=km(ig,k)*alpha(ig,k)
+               kq(ig,k)=l(ig,k)*zq*0.2
+            endif
+         enddo
+      enddo
+      endif
+
+      endif
+
+      if (prt_level>1) THEN
+       print*,'YAMADA4 1'
+      endif !(prt_level>1) THEN
+!   Diagnostique pour stokage
+
+      if(1.eq.0)then
+      rino=rif
+      smyam(1:ngrid,1)=0.
+      styam(1:ngrid,1)=0.
+      lyam(1:ngrid,1)=0.
+      knyam(1:ngrid,1)=0.
+      w2yam(1:ngrid,1)=0.
+      t2yam(1:ngrid,1)=0.
+
+      smyam(1:ngrid,2:klev)=sm(1:ngrid,2:klev)
+      styam(1:ngrid,2:klev)=sm(1:ngrid,2:klev)*alpha(1:ngrid,2:klev)
+      lyam(1:ngrid,2:klev)=l(1:ngrid,2:klev)
+      knyam(1:ngrid,2:klev)=kn(1:ngrid,2:klev)
+
+!   Estimations de w'2 et T'2 d'apres Abdela et McFarlane
+
+      w2yam(1:ngrid,2:klev)=q2(1:ngrid,2:klev)*0.24 &
+     &    +lyam(1:ngrid,2:klev)*5.17*kn(1:ngrid,2:klev) &
+     &    *n2(1:ngrid,2:klev)/sqrt(q2(1:ngrid,2:klev))
+
+      t2yam(1:ngrid,2:klev)=9.1*kn(1:ngrid,2:klev) &
+     &    *dtetadz(1:ngrid,2:klev)**2 &
+     &    /sqrt(q2(1:ngrid,2:klev))*lyam(1:ngrid,2:klev)
+      endif
+
+!     print*,'OKFIN'
+      first=.false.
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/zilch.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/zilch.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/zilch.F	(revision 17)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+      subroutine zilch(x,m)
+c
+c Zero the real array x dimensioned m.
+c
+      implicit none
+c
+      integer m,i
+      real x(m)
+      do 1 i=1,m
+      x(i)= 0.0  
+    1 continue
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/lmdz/zilch.F90
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/lmdz/zilch.F90	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/lmdz/zilch.F90	(revision 17)
@@ -0,0 +1,16 @@
+!
+! $Header$
+!
+      subroutine zilch(x,m)
+!c
+!c Zero the real array x dimensioned m.
+!c
+      implicit none
+!c
+      integer m,i
+      real x(m)
+      do 1 i=1,m
+      x(i)= 0.0  
+    1 continue
+      return
+      end
Index: branches/LMDZ_WRFmeas/WRFV3/main/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/main/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/main/Makefile	(revision 17)
@@ -0,0 +1,185 @@
+#
+
+LN      =       ln -sf
+MAKE    =       make -i -r
+RM      =       rm -f
+
+MODULES =  module_wrf_top.F
+
+OBJS    =
+
+LIBPATHS = 
+
+include ../configure.wrf
+
+$(SOLVER)_wrf : wrf.o ../main/module_wrf_top.o
+	$(RANLIB) $(LIBWRFLIB)
+	$(LD) -o wrf.exe $(LDFLAGS) wrf.o ../main/module_wrf_top.o $(LIBWRFLIB) $(LIB)
+
+$(SOLVER)_wrf_SST_ESMF : wrf_ESMFMod.o wrf_SST_ESMF.o ../main/module_wrf_top.o
+	$(RANLIB) $(LIBWRFLIB)
+	$(LD) -o wrf_SST_ESMF.exe $(LDFLAGS) wrf_SST_ESMF.o wrf_ESMFMod.o ../main/module_wrf_top.o $(LIBWRFLIB) $(LIB)
+
+$(SOLVER)_ideal : module_initialize ideal.o
+	$(RANLIB) $(LIBWRFLIB)
+	$(LD) -o ideal.exe $(LDFLAGS) ideal.o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB)
+
+$(SOLVER)_real : module_initialize real_$(SOLVER).o ndown_$(SOLVER).o nup_$(SOLVER).o tc_$(SOLVER).o
+	$(RANLIB) $(LIBWRFLIB)
+	$(LD) -o real.exe $(LDFLAGS) real_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB)
+	$(LD) -o ndown.exe $(LDFLAGS) ndown_$(SOLVER).o  ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB)
+	$(LD) -o nup.exe $(LDFLAGS) nup_$(SOLVER).o  ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB)
+	$(LD) -o tc.exe $(LDFLAGS) tc_$(SOLVER).o  ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB)
+
+convert_em : convert_em.o
+	$(RANLIB) $(LIBWRFLIB)
+	$(LD) -o convert_em.exe $(LDFLAGS) convert_em.o $(LIBWRFLIB) $(LIB)
+
+convert_nmm : convert_nmm.o
+	$(RANLIB) $(LIBWRFLIB)
+	$(FC) -o convert_nmm.exe $(LDFLAGS) convert_nmm.o $(LIBWRFLIB) $(LIB)
+
+real_nmm : real_nmm.o
+	( cd ../dyn_nmm ;  $(MAKE) module_initialize_real.o )
+	$(RANLIB) $(LIBWRFLIB)
+	$(FC) -o real_nmm.exe $(LDFLAGS) real_nmm.o ../dyn_nmm/module_initialize_real.o ../share/module_optional_input.o ../share/input_wrf.o ../share/module_io_domain.o $(LIBWRFLIB) $(LIB)
+
+module_initialize : ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o
+	( 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)
+#	if [ -z "$(OMP)" ] ; then $(FC) -o real.exe $(LDFLAGS) real_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(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_$(IDEAL_CASE).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_streams.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_initialize_$(IDEAL_CASE).o \
+	../dyn_em/module_big_step_utilities_em.o \
+	../share/module_io_domain.o \
+	../share/module_date_time.o \
+	../share/module_optional_input.o \
+	../share/module_bc_time_utilities.o \
+	$(ESMF_MOD_DEPENDENCE)
+#	../chem/module_input_chem_data.o \
+#	../chem/module_input_chem_bioemiss.o \
+
+
+tc_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_initialize_$(IDEAL_CASE).o \
+	../dyn_em/module_big_step_utilities_em.o \
+	../share/module_io_domain.o \
+	../share/module_date_time.o \
+	../share/module_optional_input.o \
+	../share/module_bc_time_utilities.o \
+	$(ESMF_MOD_DEPENDENCE)
+
+
+
+wrf.o:  ../main/module_wrf_top.o
+
+wrf_ESMFMod.o:  ../main/module_wrf_top.o
+
+wrf_SST_ESMF.o:  wrf_ESMFMod.o
+
+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 \
+                  ../frame/module_state_description.o \
+                  $(ESMF_MOD_DEPENDENCE)
+
+# DO NOT DELETE
Index: branches/LMDZ_WRFmeas/WRFV3/main/convert_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/main/convert_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/main/convert_em.F	(revision 17)
@@ -0,0 +1,167 @@
+!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)
+#ifdef NO_LEAP_CALENDAR
+   CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_NOLEAP, rc=rc )
+#else
+   CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc )
+#endif
+   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
+
Index: branches/LMDZ_WRFmeas/WRFV3/main/ideal.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/main/ideal.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/main/ideal.F	(revision 17)
@@ -0,0 +1,295 @@
+!IDEAL:DRIVER_LAYER
+!
+! create an initial data set for the WRF model based on an ideal condition
+PROGRAM ideal
+
+   USE module_domain , ONLY : domain
+   USE module_initialize_ideal
+   USE module_configure , ONLY : grid_config_rec_type
+
+   USE module_timing
+   USE module_wrf_error
+#ifdef WRF_CHEM
+   USE module_input_chem_data
+   USE module_input_chem_bioemiss
+   USE module_input_chem_emissopt3
+#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
+
+   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 , ONLY : domain
+       USE module_configure , ONLY : grid_config_rec_type
+       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)
+#ifdef NO_LEAP_CALENDAR
+   CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_NOLEAP, rc=rc )
+#else
+   CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc )
+#endif
+   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 )
+
+#ifdef PLANET
+   WRITE ( current_date , FMT = '(I4.4,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2,".0000")' ) &
+           config_flags%start_year, &
+           config_flags%start_day, &
+           config_flags%start_hour, &
+           config_flags%start_minute, &
+           config_flags%start_second 
+#else
+   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 
+#endif
+   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
+      
+#ifdef WRF_CHEM
+         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%emiss_opt == ECPTEC .or. grid%emiss_opt == GOCART_ECPTEC   &
+                                         .or. grid%biomass_burn_opt == BIOMASSB) THEN
+                 message = 'READING EMISSIONS DATA OPT 3'
+                 CALL  wrf_message ( message )
+!                CALL med_read_bin_chem_emissopt3 ( grid , config_flags)
+                 CALL med_read_wrf_chem_emissopt3 ( grid , config_flags)
+              END IF
+
+              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)
+              else IF(grid%bio_emiss_opt == 3 ) THEN !shc
+                 message = 'READING MEGAN 2 EMISSIONS DATA'
+                 CALL  wrf_message ( message )
+                 CALL med_read_wrf_chem_bioemiss ( grid , config_flags)
+              END IF
+
+              IF(grid%dust_opt == 1 .or. grid%dmsemis_opt == 1 .or. grid%chem_opt == 300) THEN !shc
+                 message = 'READING GOCART BG AND/OR DUST and DMS REF FIELDS'
+                 CALL  wrf_message ( message )
+                 CALL med_read_wrf_chem_gocart_bg ( 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)
+              else IF(grid%bio_emiss_opt == 3 ) THEN !shc
+                 message = 'READING MEGAN 2 EMISSIONS DATA'
+                 CALL  wrf_message ( message )
+                 CALL med_read_wrf_chem_bioemiss ( grid , config_flags)
+              END IF
+              IF(grid%emiss_opt == ECPTEC .or. grid%emiss_opt == GOCART_ECPTEC   &
+                                         .or. grid%biomass_burn_opt == BIOMASSB) THEN
+                 message = 'READING EMISSIONS DATA OPT 3'
+                 CALL  wrf_message ( message )
+!                CALL med_read_bin_chem_emissopt3 ( grid , config_flags)
+                 CALL med_read_wrf_chem_emissopt3 ( grid , config_flags)
+              END IF
+
+              IF(grid%dust_opt == 1 .or. grid%dmsemis_opt == 1 .or. grid%chem_opt == 300) THEN !shc
+                 message = 'READING GOCART BG AND/OR DUST and DMS REF FIELDS'
+                 CALL  wrf_message ( message )
+                 CALL med_read_wrf_chem_gocart_bg ( grid , config_flags)
+              END IF
+
+           ELSE
+             message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION'
+             CALL  wrf_message ( message )
+           END IF
+         END IF
+#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_ideal
+  ! 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_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_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
+
Index: branches/LMDZ_WRFmeas/WRFV3/main/module_wrf_top.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/main/module_wrf_top.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/main/module_wrf_top.F	(revision 17)
@@ -0,0 +1,638 @@
+!WRF:DRIVER_LAYER:TOP
+!
+
+!TBH:  $$$  move this to ../frame?  
+
+MODULE module_wrf_top
+!<DESCRIPTION>
+! This module defines top-level wrf_init(), wrf_run(), and wrf_finalize() 
+! routines.  
+!</DESCRIPTION>
+
+   USE module_machine
+   USE module_domain
+   USE module_integrate
+   USE module_driver_constants
+   USE module_configure
+   USE module_check_a_mundo
+
+   USE module_timing
+   USE module_wrf_error
+   USE module_nesting
+
+#ifdef DM_PARALLEL
+   USE module_dm, ONLY : wrf_dm_initialize
+#endif
+
+   IMPLICIT NONE
+
+   REAL    :: time
+
+   INTEGER :: loop , &
+              levels_to_process
+
+   TYPE (domain) , POINTER :: keep_grid, grid_ptr, null_domain
+   TYPE (domain) , pointer :: parent_grid, new_nest
+   LOGICAL                                :: a_nest_was_opened
+   TYPE (grid_config_rec_type), SAVE :: config_flags
+   INTEGER        :: kid, nestid
+   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
+
+! #if (EM_CORE == 1)
+     SUBROUTINE wrf_dfi_write_initialized_state( )
+     END SUBROUTINE wrf_dfi_write_initialized_state
+ 
+     SUBROUTINE wrf_dfi_startfwd_init( )
+     END SUBROUTINE wrf_dfi_startfwd_init
+     
+     SUBROUTINE wrf_dfi_startbck_init( )
+     END SUBROUTINE wrf_dfi_startbck_init
+     
+     SUBROUTINE wrf_dfi_bck_init( )
+     END SUBROUTINE wrf_dfi_bck_init
+     
+     SUBROUTINE wrf_dfi_fwd_init( )
+     END SUBROUTINE wrf_dfi_fwd_init
+     
+     SUBROUTINE wrf_dfi_fst_init( )
+     END SUBROUTINE wrf_dfi_fst_init
+     
+     SUBROUTINE wrf_dfi_array_reset ( )
+     END SUBROUTINE wrf_dfi_array_reset
+! #endif
+
+     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
+
+   END INTERFACE
+
+
+CONTAINS
+
+
+   SUBROUTINE wrf_init( no_init1 )
+!<DESCRIPTION>
+!     WRF initialization routine.
+!</DESCRIPTION>
+#ifdef _OPENMP
+     use omp_lib
+#endif
+#ifdef _ACCEL
+     use accel_lib
+#endif
+     LOGICAL, OPTIONAL, INTENT(IN) :: no_init1
+     INTEGER i, myproc, nproc, hostid, loccomm, ierr, buddcounter, mydevice
+     INTEGER, ALLOCATABLE :: hostids(:), budds(:)
+     CHARACTER*512 hostname
+#ifdef _ACCEL
+     integer :: it, nt, in, devnum
+#endif
+#if defined(DM_PARALLEL) && !defined(STUBMPI) && ( defined(RUN_ON_GPU) || defined(_ACCEL))
+     include "mpif.h"
+#endif
+#include "version_decl"
+
+
+!<DESCRIPTION>
+! Program_name, a global variable defined in frame/module_domain.F, is
+! set, then a routine <a href=init_modules.html>init_modules</a> 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.
+!
+!</DESCRIPTION>
+
+   program_name = "WRF " // TRIM(release_version) // " MODEL"
+
+   ! Initialize WRF modules:  
+   ! Phase 1 returns after MPI_INIT() (if it is called)
+   CALL init_modules(1)
+   IF ( .NOT. PRESENT( no_init1 ) ) THEN
+     ! Initialize utilities (time manager, etc.)
+#ifdef NO_LEAP_CALENDAR
+     CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_NOLEAP )
+#else
+     CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN )
+#endif
+   ENDIF
+   ! Phase 2 resumes after MPI_INIT() (if it is called)
+   CALL init_modules(2)
+
+!<DESCRIPTION>
+! 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 <a href=initial_config.html>initial_config</a>.  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 (<a
+! href=get_config_as_buffer.html>get_config_as_buffer</a>), broadcasting
+! the buffer, then setting the configuration information (<a
+! href=set_config_as_buffer.html>set_config_as_buffer</a>).
+!
+!</DESCRIPTION>
+
+#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 set_derived_rconfigs
+   CALL check_nml_consistency
+   CALL set_physics_rconfigs
+
+#ifdef _ACCEL
+   buddcounter = 1
+   mydevice = 0
+# if defined(DM_PARALLEL) && !defined(STUBMPI) 
+   CALL wrf_get_myproc( myproc )
+   CALL wrf_get_nproc( nproc )
+   CALL wrf_get_hostid ( hostid )
+   CALL wrf_get_dm_communicator ( loccomm )
+
+   ALLOCATE( hostids(nproc) )
+   ALLOCATE( budds(nproc) )
+   CALL mpi_allgather( hostid, 1, MPI_INTEGER, hostids, 1, MPI_INTEGER, loccomm, ierr )
+   if ( ierr .NE. 0 ) print * ,'error in mpi_allgather ',ierr
+   budds = -1
+   buddcounter = 0
+   ! mark the ones i am on the same node with
+   DO i = 1, nproc
+      IF ( hostid .EQ. hostids(i) ) THEN
+         budds(i) = buddcounter
+         buddcounter = buddcounter + 1
+      ENDIF
+   ENDDO
+   mydevice = budds(myproc+1)
+   DEALLOCATE( hostids )
+   DEALLOCATE( budds )
+# endif
+   in = acc_get_num_devices(acc_device_nvidia)
+   if (in .le. 0) print *, 'error:  No GPUS present: ',in
+# ifdef _OPENMP
+   !$OMP PARALLEL SHARED(mydevice,in) PRIVATE(it,nt,devnum)
+   it = omp_get_thread_num()
+   nt = omp_get_num_threads()
+   devnum = mod(mod(mydevice*nt,in) + it, in)
+# ifdef _ACCEL_PROF
+   print *, "Process, Thread, Device: ",mydevice, it, devnum
+# endif
+   call acc_set_device_num(devnum, acc_device_nvidia)
+
+   !$OMP END PARALLEL
+# else
+   it = 0
+   nt = 1
+   devnum = mod(mod(mydevice*nt,in) + it, in)
+#  ifdef _ACCEL_PROF
+   print *, "Process, Thread, Device: ",mydevice, it, devnum
+#  endif
+   call acc_set_device_num(devnum, acc_device_nvidia)
+# endif
+#endif
+
+#ifdef RUN_ON_GPU
+   CALL wrf_get_myproc( myproc )
+   CALL wrf_get_nproc( nproc )
+# ifdef DM_PARALLEL
+   CALL wrf_get_hostid ( hostid ) 
+   CALL wrf_get_dm_communicator ( loccomm )
+   ALLOCATE( hostids(nproc) )
+   ALLOCATE( budds(nproc) )
+   CALL mpi_allgather( hostid, 1, MPI_INTEGER, hostids, 1, MPI_INTEGER, loccomm, ierr )
+   if ( ierr .NE. 0 ) write(0,*)__FILE__,__LINE__,'error in mpi_allgather ',ierr
+   budds = -1
+   buddcounter = 0 
+   ! mark the ones i am on the same node with
+   DO i = 1, nproc 
+      IF ( hostid .EQ. hostids(i) ) THEN
+         budds(i) = buddcounter 
+         buddcounter = buddcounter + 1
+      ENDIF
+   ENDDO
+   mydevice = budds(myproc+1)
+   DEALLOCATE( hostids )
+   DEALLOCATE( budds )
+# else
+   mydevice = 0
+# endif
+   CALL wsm5_gpu_init( myproc, nproc, mydevice )
+#endif
+
+!<DESCRIPTION>
+! 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 <a
+! href=wrf_debug.html>wrf_debug</a> 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.
+! 
+!</DESCRIPTION>
+
+   CALL nl_get_debug_level ( 1, debug_level )
+   CALL set_wrf_debug_level ( debug_level )
+
+   ! allocated and configure the mother domain
+
+   NULLIFY( null_domain )
+
+!<DESCRIPTION>
+! 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.
+!</DESCRIPTION>
+
+   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
+
+!<DESCRIPTION>
+! The top-most domain in the simulation is then allocated and configured
+! by calling <a href=alloc_and_configure_domain.html>alloc_and_configure_domain</a>.
+! 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 <a
+! href=setup_timekeeping.html>setup_timekeeping</a> for head_grid relies
+! on this configuration information, and it must occur after the second
+! broadcast of the configuration information.
+! 
+!</DESCRIPTION>
+   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
+
+! #if (EM_CORE == 1)
+   ! In case we are doing digital filter initialization, set dfi_stage = DFI_SETUP 
+   !   to indicate in Setup_Timekeeping that we want forecast start and
+   !   end times at this point 
+   IF ( head_grid%dfi_opt .NE. DFI_NODFI ) head_grid%dfi_stage = DFI_SETUP
+! #endif
+
+   CALL Setup_Timekeeping (head_grid)
+
+!<DESCRIPTION>
+! The head grid is initialized with read-in data through the call to <a
+! href=med_initialdata_input.html>med_initialdata_input</a>, which is
+! passed the pointer head_grid and a locally declared configuration data
+! structure, config_flags, that is set by a call to <a
+! href=model_to_grid_config_rec.html>model_to_grid_config_rec</a>.  It is
+! also necessary that the indices into the 4d tracer arrays such as
+! moisture be set with a call to <a
+! href=set_scalar_indices_from_config.html>set_scalar_indices_from_config</a>
+! 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 <tt>head_grid%id</tt>, 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.
+! 
+!</DESCRIPTION>
+
+   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 )
+
+   !  For EM (but not DA), if this is a DFI run, we can allocate some space.  We are
+   !  not allowing anyting tricky for nested DFI.  If there are any nested domains,
+   !  they all need to start at the same time.  Otherwise, why even do the DFI?  If
+   !  the domains do not all start at the same time, then there will be inconsistencies,
+   !  which is what DFI is supposed to address.
+
+#if (EM_CORE == 1)
+   IF ( head_grid%dfi_opt .NE. DFI_NODFI ) THEN
+      CALL alloc_doms_for_dfi ( head_grid )
+   END IF
+#endif
+
+
+   END SUBROUTINE wrf_init
+
+
+
+   SUBROUTINE wrf_run( )
+!<DESCRIPTION>
+!     WRF run routine.
+!</DESCRIPTION>
+
+!<DESCRIPTION>
+! 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 <a href=integrate.html>integrate</a> is called to
+! advance the domain forward through that specified time interval.  On
+! return, the simulation is completed.  
+! 
+!</DESCRIPTION>
+
+   !  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 )
+!<DESCRIPTION>
+!     WRF finalize routine.
+!</DESCRIPTION>
+
+!<DESCRIPTION>
+! A Mediation Layer-provided
+! subroutine, <a href=med_shutdown_io.html>med_shutdown_io</a> is called
+! to allow the the model to do any I/O specific cleanup and shutdown, and
+! then the WRF Driver Layer routine <a
+! href=wrf_shutdown.html>wrf_shutdown</a> (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).
+! 
+!</DESCRIPTION>
+     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
+
+
+   SUBROUTINE wrf_dfi()
+!<DESCRIPTION>
+! Runs a digital filter initialization procedure.
+!</DESCRIPTION>
+      IMPLICIT NONE
+
+! #if (EM_CORE == 1)
+      ! Initialization procedure
+      IF ( config_flags%dfi_opt .NE. DFI_NODFI ) THEN
+   
+         SELECT CASE ( config_flags%dfi_opt ) 
+     
+            CASE (DFI_DFL)
+               wrf_err_message = 'Initializing with DFL'
+               CALL wrf_message(TRIM(wrf_err_message))
+   
+               wrf_err_message = '   Filtering forward in time'
+               CALL wrf_message(TRIM(wrf_err_message))
+   
+               CALL wrf_dfi_fwd_init()
+               CALL wrf_run()
+   
+               CALL wrf_dfi_array_reset()
+   
+               CALL wrf_dfi_fst_init()
+   
+               IF ( config_flags%dfi_write_filtered_input ) THEN
+                  CALL wrf_dfi_write_initialized_state()
+               END IF
+   
+            CASE (DFI_DDFI)
+               wrf_err_message = 'Initializing with DDFI'
+               CALL wrf_message(TRIM(wrf_err_message))
+   
+               wrf_err_message = '   Integrating backward in time'
+               CALL wrf_message(TRIM(wrf_err_message))
+   
+               CALL wrf_dfi_bck_init()
+               CALL wrf_run()
+   
+               wrf_err_message = '   Filtering forward in time'
+               CALL wrf_message(TRIM(wrf_err_message))
+   
+               CALL wrf_dfi_fwd_init()
+               CALL wrf_run()
+   
+               CALL wrf_dfi_array_reset()
+   
+               CALL wrf_dfi_fst_init()
+   
+               IF ( config_flags%dfi_write_filtered_input ) THEN
+                  CALL wrf_dfi_write_initialized_state()
+               END IF
+   
+            CASE (DFI_TDFI)
+               wrf_err_message = 'Initializing with TDFI'
+               CALL wrf_message(TRIM(wrf_err_message))
+   
+               wrf_err_message = '   Integrating backward in time'
+               CALL wrf_message(TRIM(wrf_err_message))
+   
+               CALL wrf_dfi_bck_init()
+               CALL wrf_run()
+   
+               CALL wrf_dfi_array_reset()
+   
+               wrf_err_message = '   Filtering forward in time'
+               CALL wrf_message(TRIM(wrf_err_message))
+   
+               CALL wrf_dfi_fwd_init()
+               CALL wrf_run()
+   
+               CALL wrf_dfi_array_reset()
+   
+               CALL wrf_dfi_fst_init()
+   
+               IF ( config_flags%dfi_write_filtered_input ) THEN
+                  CALL wrf_dfi_write_initialized_state()
+               END IF
+   
+            CASE DEFAULT
+               wrf_err_message = 'Unrecognized DFI_OPT in namelist'
+               CALL wrf_error_fatal(TRIM(wrf_err_message))
+   
+         END SELECT
+   
+      END IF
+! #endif
+
+   END SUBROUTINE wrf_dfi
+
+   SUBROUTINE set_derived_rconfigs
+!<DESCRIPTION>
+! Some derived rconfig entries need to be set based on the value of other,
+! non-derived entries before package-dependent memory allocation takes place.
+! This might be employed when, for example, we want to allocate arrays in
+! a package that depends on the setting of two or more namelist variables.
+! In this subroutine, we do just that.
+!</DESCRIPTION>
+
+      IMPLICIT NONE
+
+      INTEGER :: i
+
+
+! #if (EM_CORE == 1)
+      IF ( model_config_rec % dfi_opt .EQ. DFI_NODFI ) THEN
+        DO i = 1, model_config_rec % max_dom
+           model_config_rec % mp_physics_dfi(i) = -1
+        ENDDO
+      ELSE
+        DO i = 1, model_config_rec % max_dom
+           model_config_rec % mp_physics_dfi(i) = model_config_rec % mp_physics(i)
+        ENDDO
+      END IF
+! #endif
+
+#if (DA_CORE == 1)
+      IF ( model_config_rec % dyn_opt .EQ. 2 ) THEN
+        DO i = 1, model_config_rec % max_dom
+           model_config_rec % mp_physics_4dvar(i) = -1
+        ENDDO
+      ELSE
+        DO i = 1, model_config_rec % max_dom
+           model_config_rec % mp_physics_4dvar(i) = model_config_rec % mp_physics(i)
+        ENDDO
+      END IF
+#endif
+
+   END SUBROUTINE set_derived_rconfigs
+
+   RECURSIVE SUBROUTINE alloc_doms_for_dfi ( grid )
+   
+      !  Input variables.
+
+      TYPE (domain) , pointer :: grid
+
+      !  Local variables.
+
+      TYPE (domain) , pointer :: new_nest_loc
+      TYPE (grid_config_rec_type) :: parent_config_flags
+      INTEGER :: nestid_loc , kid_loc
+   
+         !  Are there any subdomains from this level.  The output is the nestid (the domain
+         !  ID of the nest), and kid (an index to which of the parent's children this new nested
+         !  domain represents).
+   
+         DO WHILE ( nests_to_open( grid , nestid_loc , kid_loc ) )
+
+            !  If we found another child domain, we continue on: allocate, set up time keeping, 
+            !  initialize.
+   
+            CALL alloc_and_configure_domain ( domain_id  = nestid_loc   , &
+                                              grid       = new_nest_loc , &
+                                              parent     = grid         , &
+                                              kid        = kid_loc        )
+         
+print *,'for parent domain id #',grid%id,', found child domain #',nestid_loc
+            !  Since this is a DFI run, set the DFI switches to the same for all domains.
+
+            new_nest_loc%dfi_opt = head_grid%dfi_opt
+            new_nest_loc%dfi_stage = DFI_SETUP
+         
+            !  Set up time keeping for the fine grid space that was just allocated.
+
+            CALL Setup_Timekeeping (new_nest_loc)
+
+            !  With space allocated, and timers set, the fine grid can be initialized with data.
+
+            CALL model_to_grid_config_rec ( grid%id , model_config_rec , parent_config_flags )
+            CALL med_nest_initial ( grid , new_nest_loc , config_flags )
+
+            !  Here's the recursive part.  For each of these child domains, we call this same routine.
+            !  This will find all of "new_nest_loc" first generation progeny.
+   
+            CALL alloc_doms_for_dfi ( new_nest_loc )
+   
+         END DO
+   
+   END SUBROUTINE alloc_doms_for_dfi
+
+END MODULE module_wrf_top
Index: branches/LMDZ_WRFmeas/WRFV3/main/ndown_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/main/ndown_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/main/ndown_em.F	(revision 17)
@@ -0,0 +1,2059 @@
+!WRF:DRIVER_LAYER:MAIN
+!
+
+PROGRAM ndown_em
+
+   USE module_machine
+   USE module_domain, ONLY : domain, head_grid, alloc_and_configure_domain, &
+                             domain_clock_set, domain_clock_get, get_ijk_from_grid
+   USE module_domain_type, ONLY : program_name
+   USE module_initialize_real, ONLY : wrfu_initialize, rebalance_driver
+   USE module_integrate
+   USE module_driver_constants
+   USE module_configure, ONLY : grid_config_rec_type, model_config_rec
+   USE module_io_domain
+   USE module_utility
+   USE module_check_a_mundo
+
+   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
+
+     SUBROUTINE vertical_interp (nested_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c)
+         USE module_domain
+         USE module_configure
+         TYPE(domain), POINTER ::  nested_grid
+         INTEGER , INTENT (IN) :: k_dim_c
+         REAL , INTENT (IN) :: cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c
+         REAL , DIMENSION(k_dim_c) , INTENT (IN) ::  znw_c,znu_c
+      END SUBROUTINE vertical_interp
+
+
+   END INTERFACE
+   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 :: nids, nide, njds, njde, nkds, nkde,    &
+              nims, nime, njms, njme, nkms, nkme,    &
+              nips, nipe, njps, njpe, nkps, nkpe
+   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=256)     :: message
+integer :: ii
+
+#include "version_decl"
+
+!!!!!!!!!!!!!!!!!!!!!    mousta   
+    integer ::  n_ref_m,k_dim_c,k_dim_n
+real :: cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c
+   REAL , DIMENSION(:) , ALLOCATABLE :: znw_c,znu_c
+!!!!!!!!!!!!!!!!!!!!!!!!!!11
+
+   !  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
+
+      SUBROUTINE vert_cor(parent_grid,znw_c,k_dim_c)
+         USE module_domain
+         TYPE(domain), POINTER :: parent_grid
+         integer , intent(in) :: k_dim_c
+         real , dimension(k_dim_c), INTENT(IN) :: znw_c
+      END SUBROUTINE vert_cor
+   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)
+#ifdef NO_LEAP_CALENDAR
+   CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_NOLEAP, rc=rc )
+#else
+   CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc )
+#endif
+   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
+
+   CALL check_nml_consistency
+   CALL set_physics_rconfigs
+
+   !  If we are running ndown, and that is WHERE we are now, make sure that we account
+   !  for folks forgetting to say that the aux_input2 stream is in place.
+
+   IF ( model_config_rec%io_form_auxinput2 .EQ. 0 ) THEN
+      CALL wrf_error_fatal( 'ndown: Please set io_form_auxinput2 in the time_control namelist record (probably to 2).')
+   END IF
+
+!!!!!!!!!!!!!!! mousta
+   n_ref_m = model_config_rec % vert_refine_fact
+   k_dim_c = model_config_rec % e_vert(1)
+   k_dim_n = k_dim_c
+   if (n_ref_m .ge. 2) k_dim_n = (k_dim_c - 1) *  n_ref_m + 1
+   model_config_rec % e_vert(1) = k_dim_n
+   model_config_rec % e_vert(2) = k_dim_n
+   ALLOCATE(znw_c(k_dim_c))
+   ALLOCATE(znu_c(k_dim_c))
+   WRITE ( message , FMT = '(A,3I5)' ) 'KDIM_C', k_dim_c , model_config_rec % e_vert(1) , model_config_rec % e_vert(2)
+   CALL       wrf_debug (  99,message )
+!!!!!!!!!!!!!!! mousta
+
+   !  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.
+
+#ifdef PLANET
+   WRITE ( start_date_char , FMT = '(I4.4,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2)' ) &
+           model_config_rec%start_year  (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,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2)' ) &
+           model_config_rec%  end_year  (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) 
+#else
+   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) 
+#endif
+
+   !  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) )
+      WRITE ( message , FMT = '(A,I5," ",A,A)' ) '-------->>>  Processing data: loop=',time_loop,'  date/time = ',date_string
+      CALL       wrf_debug (  99,message )
+      current_date_char = date_string
+      current_date      = date_string // '.0000'
+      start_date        = date_string // '.0000'
+      WRITE ( message , FMT = '(A,I5," ",A,A)' ) 'loopmax = ', time_loop_max, '   ending date = ',end_date_char
+      CALL       wrf_debug (  99,message )
+      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 )
+         WRITE ( message , FMT = '(A,A,A,A,A,I5)' ) 'file date/time = ',date_string,'     desired date = ',&
+         current_date_char,'     status = ', status_next_var
+         CALL       wrf_debug (  99,message )
+
+         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 )
+      WRITE ( message , * ) 'CFB' ,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,znw_c(1),znu_c(1)
+      CALL       wrf_debug (  99,message )
+      CALL input_history ( fid , head_grid , config_flags, ierr)
+!!!!!!!!!!!!!1   mousta
+      cf1_c = head_grid%cf1
+      cf2_c = head_grid%cf2
+      cf3_c = head_grid%cf3
+
+      cfn_c = head_grid%cfn
+      cfn1_c = head_grid%cfn1
+
+      do k = 1,k_dim_c
+      znw_c(k) = head_grid%znw(k)
+      znu_c(k) = head_grid%znu(k)
+      enddo
+      call vert_cor(head_grid,znw_c,k_dim_c)
+      WRITE ( message , * ) 'CFA' ,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,znw_c(1),znu_c(1)
+      CALL       wrf_debug (  99,message )
+      WRITE ( message , * ) 'CFV' ,head_grid%cf1,head_grid%cf2,head_grid%cf3,head_grid%cfn,head_grid%cfn1,&
+      head_grid%znw(1),head_grid%znu(1) , head_grid%e_vert , parent_grid%cf1 , parent_grid%znw(1) , parent_grid%znu(1)
+      CALL       wrf_debug (  99,message )
+!!!!!!!!!!!!!1   mousta
+      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_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 )
+      WRITE ( message , * ) 'MOUSTA_L', nested_grid%mu_2(ips,jps) , nested_grid%u_2(ips,kde-2,jps)
+      CALL       wrf_debug (  99,message )
+      CALL vertical_interp (nested_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c)
+      WRITE ( message , * ) 'MOUSTA_V', nested_grid%mu_2(ips,jps) , nested_grid%u_2(ips,kde-2,jps)
+      CALL       wrf_debug (  99,message )
+      nested_grid%ht_int = nested_grid%ht
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      IF ( time_loop .EQ. 1 ) THEN
+
+         !  Dimension info for fine grid.
+
+         CALL get_ijk_from_grid (  nested_grid ,                   &
+                                   nids, nide, njds, njde, nkds, nkde,    &
+                                   nims, nime, njms, njme, nkms, nkme,    &
+                                   nips, nipe, njps, njpe, nkps, nkpe    )
+
+         !  Store horizontally interpolated terrain in temp location
+
+         CALL  copy_3d_field ( nested_grid%ht_fine , nested_grid%ht , &
+                               nids , nide , njds , njde , 1   , 1   , &
+                               nims , nime , njms , njme , 1   , 1   , &
+                               nips , nipe , njps , njpe , 1   , 1   )
+
+         !  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_auxinput2' )
+         CALL input_auxinput2 ( 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" )
+
+         !  Blend parent and nest field of terrain.
+
+         CALL blend_terrain ( nested_grid%ht_fine , nested_grid%ht , &
+                               nids , nide , njds , njde , 1   , 1   , &
+                               nims , nime , njms , njme , 1   , 1   , &
+                               nips , nipe , njps , njpe , 1   , 1   )
+
+         nested_grid%ht_input = nested_grid%ht
+         nested_grid%ht_int   = nested_grid%ht_fine
+
+         !  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
+
+#ifndef PLANET
+         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) )
+#endif
+
+      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
+!
+!         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%biomass_burn_opt == BIOMASSB) THEN
+                message = 'READING BIOMASS BURNING EMISSIONS DATA '
+                CALL  wrf_message ( message )
+                CALL med_read_wrf_chem_emissopt3 ( nested_grid , config_flags)
+              end if
+
+              if(nested_grid%dust_opt == 1 .or. nested_grid%dmsemis_opt == 1         &
+                 .or. nested_grid%chem_opt == 300  .or. nested_grid%chem_opt == 301) then 
+                 message = 'READING GOCART BG AND/OR DUST and DMS REF FIELDS'
+                 CALL  wrf_message ( message )
+                 CALL med_read_wrf_chem_gocart_bg ( nested_grid , config_flags)
+              end if
+
+              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)
+              else if( nested_grid%bio_emiss_opt == 3 ) THEN 
+                 message = 'READING MEGAN 2 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_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.
+
+         ! u, theta, h, scalars coupled with my, v coupled with mx
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp1 , nested_grid%u_2                 , &
+                       'u' , nested_grid%msfuy , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp1 , nested_grid%v_2                 , &
+                       'v' , nested_grid%msfvx , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp1 , nested_grid%t_2                 , &
+                       't' , nested_grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp1 , nested_grid%ph_2                , &
+                       'h' , nested_grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp1 , nested_grid%moist(ims:ime,kms:kme,jms:jme,P_QV)    , &
+                       't' , nested_grid%msfty , &
+                       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%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%u_bxs, nested_grid%u_bxe,                        &
+                                            nested_grid%u_bys, nested_grid%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%v_bxs, nested_grid%v_bxe,                        &
+                                            nested_grid%v_bys, nested_grid%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%t_bxs, nested_grid%t_bxe,                        &
+                                            nested_grid%t_bys, nested_grid%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%ph_bxs, nested_grid%ph_bxe,                      &
+                                            nested_grid%ph_bys, nested_grid%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(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
+                                            nested_grid%moist_bxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
+                                            nested_grid%moist_bys(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
+                                            nested_grid%moist_bye(ims:ime,kms:kme,1:spec_bdy_width,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%mu_bxs, nested_grid%mu_bxe,                      &
+                                            nested_grid%mu_bys, nested_grid%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(jms:jme,kms:kme,1:spec_bdy_width,nvchem),                                &
+                                            nested_grid%chem_bxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem),                                &
+                                            nested_grid%chem_bys(ims:ime,kms:kme,1:spec_bdy_width,nvchem),                                &
+                                            nested_grid%chem_bye(ims:ime,kms:kme,1:spec_bdy_width,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
+
+         ! u, theta, h, scalars coupled with my, v coupled with mx
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp2 , nested_grid%u_2                 , &
+                       'u' , nested_grid%msfuy , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp2 , nested_grid%v_2                 , &
+                       'v' , nested_grid%msfvx , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp2 , nested_grid%t_2                 , &
+                       't' , nested_grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp2 , nested_grid%ph_2                , &
+                       'h' , nested_grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp2 , nested_grid%moist(ims:ime,kms:kme,jms:jme,P_QV)    , &
+                       't' , nested_grid%msfty , &
+                       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%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%u_btxs, nested_grid%u_btxe   ,          &
+                                            nested_grid%u_btys, nested_grid%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%v_btxs, nested_grid%v_btxe   ,          &
+                                            nested_grid%v_btys, nested_grid%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%t_btxs, nested_grid%t_btxe   ,          &
+                                            nested_grid%t_btys, nested_grid%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%ph_btxs, nested_grid%ph_btxe   ,        &
+                                            nested_grid%ph_btys, nested_grid%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(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
+                                            nested_grid%moist_btxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
+                                            nested_grid%moist_btys(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
+                                            nested_grid%moist_btye(ims:ime,kms:kme,1:spec_bdy_width,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%mu_btxs, nested_grid%mu_btxe   ,        &
+                                            nested_grid%mu_btys, nested_grid%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(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
+                                            nested_grid%chem_btxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
+                                            nested_grid%chem_btys(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
+                                            nested_grid%chem_btye(ims:ime,kms:kme,1:spec_bdy_width,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%u_bxs, nested_grid%u_bxe     ,                   &
+                              nested_grid%u_bys, nested_grid%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%v_bxs, nested_grid%v_bxe     ,                   &
+                              nested_grid%v_bys, nested_grid%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%t_bxs, nested_grid%t_bxe     ,                   &
+                              nested_grid%t_bys, nested_grid%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%ph_bxs, nested_grid%ph_bxe     ,                   &
+                              nested_grid%ph_bys, nested_grid%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(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
+                              nested_grid%moist_bxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV),     &
+                              nested_grid%moist_bys(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
+                              nested_grid%moist_bye(ims:ime,kms:kme,1:spec_bdy_width,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(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
+                              nested_grid%chem_bxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem),     &
+                              nested_grid%chem_bys(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
+                              nested_grid%chem_bye(ims:ime,kms:kme,1:spec_bdy_width,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%mu_bxs, nested_grid%mu_bxe    ,  &
+                              nested_grid%mu_bys, nested_grid%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
+
+         ! u, theta, h, scalars coupled with my, v coupled with mx
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp2 , nested_grid%u_2                 , &
+                       'u' , nested_grid%msfuy , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp2 , nested_grid%v_2                 , &
+                       'v' , nested_grid%msfvx , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp2 , nested_grid%t_2                 , &
+                       't' , nested_grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp2 , nested_grid%ph_2                , &
+                       'h' , nested_grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp2 , nested_grid%moist(ims:ime,kms:kme,jms:jme,P_QV)    , &
+                       't' , nested_grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         mbdy2dtemp2(:,1,:) = nested_grid%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(jms:jme,kms:kme,1:spec_bdy_width,nvchem),  &
+                              nested_grid%chem_btxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
+                              nested_grid%chem_btys(ims:ime,kms:kme,1:spec_bdy_width,nvchem),  &
+                              nested_grid%chem_btye(ims:ime,kms:kme,1:spec_bdy_width,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%u_btxs  , nested_grid%u_btxe , &
+                              nested_grid%u_btys  , nested_grid%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%v_btxs  , nested_grid%v_btxe , &
+                              nested_grid%v_btys  , nested_grid%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%t_btxs  , nested_grid%t_btxe , &
+                              nested_grid%t_btys  , nested_grid%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%ph_btxs  , nested_grid%ph_btxe , &
+                              nested_grid%ph_btys  , nested_grid%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(jms:jme,kms:kme,1:spec_bdy_width,P_QV) , &
+                              nested_grid%moist_btxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV) , &
+                              nested_grid%moist_btys(ims:ime,kms:kme,1:spec_bdy_width,P_QV) , &
+                              nested_grid%moist_btye(ims:ime,kms:kme,1:spec_bdy_width,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%mu_btxs  , nested_grid%mu_btxe , &
+                              nested_grid%mu_btys  , nested_grid%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
+   DEALLOCATE(znw_c)
+   DEALLOCATE(znu_c)
+   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_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
+!!!!!!!!!!!!!!!!!!!!!!!!!!!11
+      SUBROUTINE vert_cor(parent,znw_c,k_dim_c)
+         USE module_domain
+   IMPLICIT NONE
+         TYPE(domain), POINTER :: parent
+         integer , intent(in) :: k_dim_c
+         real , dimension(k_dim_c), INTENT(IN) :: znw_c
+
+       integer :: kde_c , kde_n ,n_refine,ii,kkk,k
+       real :: dznw_m,cof1,cof2
+
+        kde_c = k_dim_c
+        kde_n = parent%e_vert
+        n_refine = parent % vert_refine_fact
+
+
+         kkk = 0
+         do k = 1 , kde_c-1
+         dznw_m = znw_c(k+1) - znw_c(k)
+         do ii = 1,n_refine
+         kkk = kkk + 1
+         parent%znw(kkk) = znw_c(k) + float(ii-1)/float(n_refine)*dznw_m
+         enddo
+         enddo
+         parent%znw(kde_n) = znw_c(kde_c)
+         parent%znw(1) = znw_c(1)
+
+      DO k=1, kde_n-1
+         parent%dnw(k) = parent%znw(k+1) - parent%znw(k)
+         parent%rdnw(k) = 1./parent%dnw(k)
+         parent%znu(k) = 0.5*(parent%znw(k+1)+parent%znw(k))
+      END DO
+
+      DO k=2, kde_n-1
+         parent%dn(k) = 0.5*(parent%dnw(k)+parent%dnw(k-1))
+         parent%rdn(k) = 1./parent%dn(k)
+         parent%fnp(k) = .5* parent%dnw(k  )/parent%dn(k)
+         parent%fnm(k) = .5* parent%dnw(k-1)/parent%dn(k)
+      END DO
+
+  cof1 = (2.*parent%dn(2)+parent%dn(3))/(parent%dn(2)+parent%dn(3))*parent%dnw(1)/parent%dn(2)
+  cof2 =     parent%dn(2)        /(parent%dn(2)+parent%dn(3))*parent%dnw(1)/parent%dn(3)
+
+      parent%cf1  = parent%fnp(2) + cof1
+      parent%cf2  = parent%fnm(2) - cof1 - cof2
+      parent%cf3  = cof2
+
+      parent%cfn  = (.5*parent%dnw(kde_n-1)+parent%dn(kde_n-1))/parent%dn(kde_n-1)
+      parent%cfn1 = -.5*parent%dnw(kde_n-1)/parent%dn(kde_n-1)
+
+
+
+      END SUBROUTINE vert_cor
+
+
+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
+
+
+     SUBROUTINE vertical_interp (parent_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c)
+         USE module_domain
+         USE module_configure
+   IMPLICIT NONE
+         TYPE(domain), POINTER ::  parent_grid
+         INTEGER , INTENT (IN) :: k_dim_c
+         REAL , INTENT (IN) :: cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c
+         REAL , DIMENSION(k_dim_c) , INTENT (IN) ::  znw_c,znu_c
+
+       integer :: kde_c , kde_n ,n_refine,ii,kkk
+       integer :: i , j, k , itrace
+       real :: p_top_m  , p_surf_m , mu_m , hsca_m , pre_c ,pre_n
+
+       real, allocatable, dimension(:) ::  alt_w_c , alt_u_c ,pro_w_c , pro_u_c
+       real, allocatable, dimension(:) ::  alt_w_n , alt_u_n ,pro_w_n , pro_u_n
+
+   INTEGER :: nids, nide, njds, njde, nkds, nkde, &
+              nims, nime, njms, njme, nkms, nkme, &
+              nips, nipe, njps, njpe, nkps, nkpe
+
+      
+         hsca_m = 6.7
+         n_refine = model_config_rec % vert_refine_fact
+         kde_c = k_dim_c
+         kde_n = parent_grid%e_vert
+
+         CALL get_ijk_from_grid ( parent_grid , &
+                                   nids, nide, njds, njde, nkds, nkde, &
+                                   nims, nime, njms, njme, nkms, nkme, &
+                                   nips, nipe, njps, njpe, nkps, nkpe )
+
+      print * , 'MOUSTA_VER  ',parent_grid%e_vert , kde_c , kde_n
+         print *, nids , nide , njds , njde , nkds , nkde
+         print *, nims , nime , njms , njme , nkms , nkme
+         print *, nips , nipe , njps , njpe , nkps , nkpe
+
+
+
+         allocate (alt_w_c(kde_c))
+         allocate (alt_u_c(kde_c+1))
+         allocate (pro_w_c(kde_c))
+         allocate (pro_u_c(kde_c+1))
+
+         allocate (alt_w_n(kde_n))
+         allocate (alt_u_n(kde_n+1))
+         allocate (pro_w_n(kde_n))
+         allocate (pro_u_n(kde_n+1))
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11111
+         p_top_m = parent_grid%p_top
+         p_surf_m = 1.e5
+         mu_m = p_surf_m - p_top_m
+         print * , 'p_top_m', p_top_m
+!    parent
+         do  k = 1,kde_c
+         pre_c = mu_m * znw_c(k) + p_top_m
+         alt_w_c(k) =  -hsca_m * alog(pre_c/p_surf_m)
+         enddo
+         do  k = 1,kde_c-1
+         pre_c = mu_m * znu_c(k) + p_top_m
+         alt_u_c(k+1) =  -hsca_m * alog(pre_c/p_surf_m)
+         enddo
+         alt_u_c(1) =  alt_w_c(1) 
+         alt_u_c(kde_c+1) =  alt_w_c(kde_c) 
+!    nest
+         do  k = 1,kde_n
+         pre_n = mu_m * parent_grid%znw(k) + p_top_m
+         alt_w_n(k) =  -hsca_m * alog(pre_n/p_surf_m)
+         enddo
+         do  k = 1,kde_n-1
+         pre_n = mu_m * parent_grid%znu(k) + p_top_m
+         alt_u_n(k+1) =  -hsca_m * alog(pre_n/p_surf_m)
+         enddo
+         alt_u_n(1) =  alt_w_n(1)
+         alt_u_n(kde_n+1) =  alt_w_n(kde_n)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+IF ( SIZE( parent_grid%u_2, 1 ) * SIZE( parent_grid%u_2, 3 ) .GT. 1 ) THEN 
+do j = njms , njme
+do i = nims , nime
+    
+    do k = 1,kde_c-1
+    pro_u_c(k+1) = parent_grid%u_2(i,k,j)
+    enddo
+    pro_u_c(1      ) = cf1_c*parent_grid%u_2(i,1,j) &
+                     + cf2_c*parent_grid%u_2(i,2,j) &
+                     + cf3_c*parent_grid%u_2(i,3,j)
+
+    pro_u_c(kde_c+1) = cfn_c *parent_grid%u_2(i,kde_c-1,j) &
+                     + cfn1_c*parent_grid%u_2(i,kde_c-2,j) 
+
+    call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
+
+    do k = 1,kde_n-1
+    parent_grid%u_2(i,k,j) = pro_u_n(k+1)
+    enddo
+
+enddo
+enddo
+ENDIF
+
+IF ( SIZE( parent_grid%v_2, 1 ) * SIZE( parent_grid%v_2, 3 ) .GT. 1 ) THEN
+do j = njms , njme
+do i = nims , nime
+
+    do k = 1,kde_c-1
+    pro_u_c(k+1) = parent_grid%v_2(i,k,j)
+    enddo
+    pro_u_c(1      ) = cf1_c*parent_grid%v_2(i,1,j) &
+                     + cf2_c*parent_grid%v_2(i,2,j) &
+                     + cf3_c*parent_grid%v_2(i,3,j)
+
+    pro_u_c(kde_c+1) = cfn_c *parent_grid%v_2(i,kde_c-1,j) &
+                     + cfn1_c*parent_grid%v_2(i,kde_c-2,j)
+
+    call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
+
+    do k = 1,kde_n-1
+    parent_grid%v_2(i,k,j) = pro_u_n(k+1)
+    enddo
+
+enddo
+enddo
+ENDIF
+
+IF ( SIZE( parent_grid%w_2, 1 ) * SIZE( parent_grid%w_2, 3 ) .GT. 1 ) THEN
+do j = njms , njme
+do i = nims , nime
+
+    do k = 1,kde_c
+    pro_w_c(k) = parent_grid%w_2(i,k,j)
+    enddo
+    call inter(pro_w_c,alt_w_c,kde_c,pro_w_n,alt_w_n,kde_n)
+
+    do k = 1,kde_n
+    parent_grid%w_2(i,k,j) = pro_w_n(k)
+    enddo
+enddo
+enddo
+ENDIF
+
+IF ( SIZE( parent_grid%t_2, 1 ) * SIZE( parent_grid%t_2, 3 ) .GT. 1 ) THEN
+do j = njms , njme
+do i = nims , nime
+
+    do k = 1,kde_c-1
+    pro_u_c(k+1) = parent_grid%t_2(i,k,j)
+    enddo
+    pro_u_c(1      ) = cf1_c*parent_grid%t_2(i,1,j) &
+                     + cf2_c*parent_grid%t_2(i,2,j) &
+                     + cf3_c*parent_grid%t_2(i,3,j)
+
+    pro_u_c(kde_c+1) = cfn_c *parent_grid%t_2(i,kde_c-1,j) &
+                     + cfn1_c*parent_grid%t_2(i,kde_c-2,j)
+
+    call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
+
+    do k = 1,kde_n-1
+    parent_grid%t_2(i,k,j) = pro_u_n(k+1)
+    enddo
+
+enddo
+enddo
+ENDIF
+
+DO itrace = PARAM_FIRST_SCALAR, num_moist
+IF ( SIZE( parent_grid%moist, 1 ) * SIZE( parent_grid%moist, 3 ) .GT. 1 ) THEN
+do j = njms , njme
+do i = nims , nime
+
+    do k = 1,kde_c-1
+    pro_u_c(k+1) = parent_grid%moist(i,k,j,itrace)
+    enddo
+    pro_u_c(1      ) = cf1_c*parent_grid%moist(i,1,j,itrace) &
+                     + cf2_c*parent_grid%moist(i,2,j,itrace) &
+                     + cf3_c*parent_grid%moist(i,3,j,itrace)
+
+    pro_u_c(kde_c+1) = cfn_c *parent_grid%moist(i,kde_c-1,j,itrace) &
+                     + cfn1_c*parent_grid%moist(i,kde_c-2,j,itrace)
+
+    call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
+
+    do k = 1,kde_n-1
+    parent_grid%moist(i,k,j,itrace) = pro_u_n(k+1)
+    enddo
+
+enddo
+enddo
+ENDIF
+ENDDO
+
+DO itrace = PARAM_FIRST_SCALAR, num_dfi_moist
+IF ( SIZE( parent_grid%dfi_moist, 1 ) * SIZE( parent_grid%dfi_moist, 3 ) .GT. 1 ) THEN
+do j = njms , njme
+do i = nims , nime
+
+    do k = 1,kde_c-1
+    pro_u_c(k+1) = parent_grid%dfi_moist(i,k,j,itrace)
+    enddo
+    pro_u_c(1      ) = cf1_c*parent_grid%dfi_moist(i,1,j,itrace) &
+                     + cf2_c*parent_grid%dfi_moist(i,2,j,itrace) &
+                     + cf3_c*parent_grid%dfi_moist(i,3,j,itrace)
+
+    pro_u_c(kde_c+1) = cfn_c *parent_grid%dfi_moist(i,kde_c-1,j,itrace) &
+                     + cfn1_c*parent_grid%dfi_moist(i,kde_c-2,j,itrace)
+
+    call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
+
+    do k = 1,kde_n-1
+    parent_grid%dfi_moist(i,k,j,itrace) = pro_u_n(k+1)
+    enddo
+
+enddo
+enddo
+ENDIF
+ENDDO
+
+DO itrace = PARAM_FIRST_SCALAR, num_scalar
+IF ( SIZE( parent_grid%scalar, 1 ) * SIZE( parent_grid%scalar, 3 ) .GT. 1 ) THEN
+do j = njms , njme
+do i = nims , nime
+
+    do k = 1,kde_c-1
+    pro_u_c(k+1) = parent_grid%scalar(i,k,j,itrace)
+    enddo
+    pro_u_c(1      ) = cf1_c*parent_grid%scalar(i,1,j,itrace) &
+                     + cf2_c*parent_grid%scalar(i,2,j,itrace) &
+                     + cf3_c*parent_grid%scalar(i,3,j,itrace)
+
+    pro_u_c(kde_c+1) = cfn_c *parent_grid%scalar(i,kde_c-1,j,itrace) &
+                     + cfn1_c*parent_grid%scalar(i,kde_c-2,j,itrace)
+
+    call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
+
+    do k = 1,kde_n-1
+    parent_grid%scalar(i,k,j,itrace) = pro_u_n(k+1)
+    enddo
+
+enddo
+enddo
+ENDIF
+ENDDO
+
+DO itrace = PARAM_FIRST_SCALAR, num_dfi_scalar
+IF ( SIZE( parent_grid%dfi_scalar, 1 ) * SIZE( parent_grid%dfi_scalar, 3 ) .GT. 1 ) THEN
+do j = njms , njme
+do i = nims , nime
+
+    do k = 1,kde_c-1
+    pro_u_c(k+1) = parent_grid%dfi_scalar(i,k,j,itrace)
+    enddo
+    pro_u_c(1      ) = cf1_c*parent_grid%dfi_scalar(i,1,j,itrace) &
+                     + cf2_c*parent_grid%dfi_scalar(i,2,j,itrace) &
+                     + cf3_c*parent_grid%dfi_scalar(i,3,j,itrace)
+
+    pro_u_c(kde_c+1) = cfn_c *parent_grid%dfi_scalar(i,kde_c-1,j,itrace) &
+                     + cfn1_c*parent_grid%dfi_scalar(i,kde_c-2,j,itrace)
+
+    call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
+
+    do k = 1,kde_n-1
+    parent_grid%dfi_scalar(i,k,j,itrace) = pro_u_n(k+1)
+    enddo
+
+enddo
+enddo
+ENDIF
+ENDDO
+
+
+
+IF ( SIZE( parent_grid%f_ice_phy, 1 ) * SIZE( parent_grid%f_ice_phy, 3 ) .GT. 1 ) THEN
+do j = njms , njme
+do i = nims , nime
+
+    do k = 1,kde_c-1
+    pro_u_c(k+1) = parent_grid%f_ice_phy(i,k,j)
+    enddo
+    pro_u_c(1      ) = cf1_c*parent_grid%f_ice_phy(i,1,j) &
+                     + cf2_c*parent_grid%f_ice_phy(i,2,j) &
+                     + cf3_c*parent_grid%f_ice_phy(i,3,j)
+
+    pro_u_c(kde_c+1) = cfn_c *parent_grid%f_ice_phy(i,kde_c-1,j) &
+                     + cfn1_c*parent_grid%f_ice_phy(i,kde_c-2,j)
+
+    call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
+
+    do k = 1,kde_n-1
+    parent_grid%f_ice_phy(i,k,j) = pro_u_n(k+1)
+    enddo
+
+enddo
+enddo
+ENDIF
+
+IF ( SIZE( parent_grid%f_rain_phy, 1 ) * SIZE( parent_grid%f_rain_phy, 3 ) .GT. 1 ) THEN
+do j = njms , njme
+do i = nims , nime
+
+    do k = 1,kde_c-1
+    pro_u_c(k+1) = parent_grid%f_rain_phy(i,k,j)
+    enddo
+    pro_u_c(1      ) = cf1_c*parent_grid%f_rain_phy(i,1,j) &
+                     + cf2_c*parent_grid%f_rain_phy(i,2,j) &
+                     + cf3_c*parent_grid%f_rain_phy(i,3,j)
+
+    pro_u_c(kde_c+1) = cfn_c *parent_grid%f_rain_phy(i,kde_c-1,j) &
+                     + cfn1_c*parent_grid%f_rain_phy(i,kde_c-2,j)
+
+    call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
+
+    do k = 1,kde_n-1
+    parent_grid%f_rain_phy(i,k,j) = pro_u_n(k+1)
+    enddo
+
+enddo
+enddo
+ENDIF
+
+
+IF ( SIZE( parent_grid%f_rimef_phy, 1 ) * SIZE( parent_grid%f_rimef_phy, 3 ) .GT. 1 ) THEN
+do j = njms , njme
+do i = nims , nime
+
+    do k = 1,kde_c-1
+    pro_u_c(k+1) = parent_grid%f_rimef_phy(i,k,j)
+    enddo
+    pro_u_c(1      ) = cf1_c*parent_grid%f_rimef_phy(i,1,j) &
+                     + cf2_c*parent_grid%f_rimef_phy(i,2,j) &
+                     + cf3_c*parent_grid%f_rimef_phy(i,3,j)
+
+    pro_u_c(kde_c+1) = cfn_c *parent_grid%f_rimef_phy(i,kde_c-1,j) &
+                     + cfn1_c*parent_grid%f_rimef_phy(i,kde_c-2,j)
+
+    call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
+
+    do k = 1,kde_n-1
+    parent_grid%f_rimef_phy(i,k,j) = pro_u_n(k+1)
+    enddo
+
+enddo
+enddo
+ENDIF
+
+IF ( SIZE( parent_grid%h_diabatic, 1 ) * SIZE( parent_grid%h_diabatic, 3 ) .GT. 1 ) THEN
+do j = njms , njme
+do i = nims , nime
+
+    do k = 1,kde_c-1
+    pro_u_c(k+1) = parent_grid%h_diabatic(i,k,j)
+    enddo
+    pro_u_c(1      ) = cf1_c*parent_grid%h_diabatic(i,1,j) &
+                     + cf2_c*parent_grid%h_diabatic(i,2,j) &
+                     + cf3_c*parent_grid%h_diabatic(i,3,j)
+
+    pro_u_c(kde_c+1) = cfn_c *parent_grid%h_diabatic(i,kde_c-1,j) &
+                     + cfn1_c*parent_grid%h_diabatic(i,kde_c-2,j)
+
+    call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
+
+    do k = 1,kde_n-1
+    parent_grid%h_diabatic(i,k,j) = pro_u_n(k+1)
+    enddo
+
+enddo
+enddo
+ENDIF
+
+IF ( SIZE( parent_grid%rthraten, 1 ) * SIZE( parent_grid%rthraten, 3 ) .GT. 1 ) THEN
+do j = njms , njme
+do i = nims , nime
+
+    do k = 1,kde_c-1
+    pro_u_c(k+1) =  parent_grid%rthraten(i,k,j)
+    enddo
+    pro_u_c(1      ) = cf1_c*parent_grid%rthraten(i,1,j) &
+                     + cf2_c*parent_grid%rthraten(i,2,j) &
+                     + cf3_c*parent_grid%rthraten(i,3,j)
+
+    pro_u_c(kde_c+1) = cfn_c *parent_grid%rthraten(i,kde_c-1,j) &
+                     + cfn1_c*parent_grid%rthraten(i,kde_c-2,j)
+
+    call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
+
+    do k = 1,kde_n-1
+    parent_grid%rthraten(i,k,j) = pro_u_n(k+1)
+    enddo
+
+enddo
+enddo
+ENDIF
+
+
+
+
+
+
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+         deallocate (alt_w_c)
+         deallocate (alt_u_c)
+         deallocate (pro_w_c)
+         deallocate (pro_u_c)
+
+         deallocate (alt_w_n)
+         deallocate (alt_u_n)
+         deallocate (pro_w_n)
+         deallocate (pro_u_n)
+
+
+      END SUBROUTINE vertical_interp
+
+!!!!!!!!!!!!!!!!!!!!!!!!11
+    SUBROUTINE inter(pro_c,alt_c,kde_c,pro_n,alt_n,kde_n)
+
+  IMPLICIT NONE
+   INTEGER , INTENT(IN) :: kde_c,kde_n
+   REAL , DIMENSION(kde_c) , INTENT(IN ) :: pro_c,alt_c
+   REAL , DIMENSION(kde_n) , INTENT(IN ) :: alt_n
+   REAL , DIMENSION(kde_n) , INTENT(OUT) :: pro_n
+
+      real ,dimension(kde_c) :: a,b,c,d
+      real :: p
+      integer :: i,j
+
+
+      call coeff_mon(alt_c,pro_c,a,b,c,d,kde_c)
+
+       do i = 1,kde_n-1
+
+          do j=1,kde_c-1
+
+               if ( (alt_n(i) .ge. alt_c(j)).and.(alt_n(i) .lt. alt_c(j+1)) ) then
+                p =  alt_n(i)-alt_c(j)
+                pro_n(i) = p*( p*(a(j)*p+b(j))+c(j)) + d(j)
+                goto 20
+               endif
+           enddo
+20             continue
+       enddo
+
+       pro_n(kde_n) = pro_c(kde_c)
+
+
+   END SUBROUTINE inter
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11
+
+     subroutine  coeff_mon(x,y,a,b,c,d,n)
+
+      implicit none
+
+      integer :: n
+      real ,dimension(n) :: x,y,a,b,c,d
+      real ,dimension(n) :: h,s,p,yp
+
+       integer :: i
+
+
+      do i=1,n-1
+      h(i) = (x(i+1)-x(i))
+      s(i) = (y(i+1)-y(i)) / h(i)
+      enddo
+
+      do i=2,n-1
+      p(i) = (s(i-1)*h(i)+s(i)*h(i-1)) / (h(i-1)+h(i))
+      enddo
+
+      p(1) = s(1)
+      p(n) = s(n-1)
+
+      do i=1,n
+      yp(i) = p(i)
+      enddo
+!!!!!!!!!!!!!!!!!!!!!
+
+      do i=2,n-1
+      yp(i) = (sign(1.,s(i-1))+sign(1.,s(i)))* min( abs(s(i-1)),abs(s(i)),0.5*abs(p(i)))
+      enddo
+
+      do i = 1,n-1
+      a(i) = (yp(i)+yp(i+1)-2.*s(i))/(h(i)*h(i))
+      b(i) = (3.*s(i)-2.*yp(i)-yp(i+1))/h(i)
+      c(i) = yp(i)
+      d(i) = y(i)
+      enddo
+
+      end  subroutine  coeff_mon
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/main/nup_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/main/nup_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/main/nup_em.F	(revision 17)
@@ -0,0 +1,915 @@
+!WRF:DRIVER_LAYER:MAIN
+!
+
+! "Nest up" program in WRFV2.
+! 
+! Description:
+! 
+! The nest up (nup.exe) program reads from wrfout_d02_<date> files for
+! the nest and generates wrfout_d01_<date> 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_*            <start time information for both domains>
+!    end_*              <start time information for both domains>
+!    history_interval   <interval between frames in input/output files>
+!    frames_per_outfile <number of frames in input/output files>
+!    io_form_history    <2 for NetCDF>
+! 
+!  &domains
+!     ...
+!    max_dom            <number of domains; must be 2>
+!    e_we               <col 2 is size of nested grid in west-east>
+!                       <col 1 is ignored in the namelist>
+!    e_sn               <col 2 is size of nested grid in south-north>
+!                       <col 1 is ignored in the namelist>
+!    parent_grid_ratio  <col 2 is nesting ratio in both dims>
+!    feedback           <must be 1>
+!    smooth_option      <recommend 0>
+! 
+!  &physics
+!             <all options in this section should be the same
+!              as the run that generated the nest data>
+! 
+!  created: JM 2006 01 25 
+
+PROGRAM nup_em
+
+   USE module_machine
+   USE module_domain, ONLY : domain, wrfu_timeinterval, alloc_and_configure_domain, &
+      domain_clock_set, domain_get_current_time, domain_get_stop_time, head_grid, &
+      domain_clock_get, domain_clockadvance
+   USE module_domain_type, ONLY : program_name
+   USE module_streams
+   USE module_initialize_real, only : wrfu_initialize
+   USE module_integrate
+   USE module_driver_constants
+   USE module_configure, only : grid_config_rec_type, model_config_rec
+   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)
+#ifdef NO_LEAP_CALENDAR
+   CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_NOLEAP, rc=rc )
+#else
+   CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc )
+#endif
+   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(history_only) = nested_grid%nframes(history_only) + 1
+        IF ( nested_grid%nframes(history_only) >= 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(history_only) = 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%fnm    = nested_grid%fnm
+  parent_grid%fnp    = nested_grid%fnp
+  parent_grid%rdnw   = nested_grid%rdnw
+  parent_grid%rdn    = nested_grid%rdn
+  parent_grid%dnw    = nested_grid%dnw
+  parent_grid%dn     = nested_grid%dn 
+  parent_grid%znu    = nested_grid%znu
+  parent_grid%znw    = nested_grid%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_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
Index: branches/LMDZ_WRFmeas/WRFV3/main/real_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/main/real_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/main/real_em.F	(revision 17)
@@ -0,0 +1,1173 @@
+!  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, ONLY : domain, alloc_and_configure_domain, &
+        domain_clock_set, head_grid, program_name, domain_clockprint
+   USE module_initialize_real, ONLY : wrfu_initialize, find_my_parent, find_my_parent2
+   USE module_initialize_real
+   USE module_io_domain
+   USE module_driver_constants
+   USE module_configure, ONLY : grid_config_rec_type, model_config_rec, &
+        initial_config, get_config_as_buffer, set_config_as_buffer
+   USE module_timing
+   USE module_state_description, ONLY : realonly
+   USE module_symbols_util, ONLY: wrfu_cal_gregorian
+   USE module_check_a_mundo
+#ifdef WRF_CHEM
+   USE module_input_chem_data
+   USE module_input_chem_bioemiss
+!  USE module_input_chem_emissopt3
+#endif
+   USE module_utility, ONLY : WRFU_finalize
+
+   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, ONLY : domain
+      TYPE(domain), POINTER :: grid
+     END SUBROUTINE Setup_Timekeeping
+   END INTERFACE
+
+   LOGICAL :: ok_so_far
+
+#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)
+#ifdef NO_LEAP_CALENDAR
+   CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_NOLEAP, rc=rc )
+#else
+   CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc )
+#endif
+   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
+   END IF
+   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 check_nml_consistency
+   CALL set_physics_rconfigs
+
+   CALL nl_get_debug_level ( 1, debug_level )
+   CALL set_wrf_debug_level ( debug_level )
+
+   CALL  wrf_message ( program_name )
+
+   !  There are variables in the Registry that are only required for the real
+   !  program, fields that come from the WPS package.  We define the run-time
+   !  flag that says to allocate space for these input-from-WPS-only arrays.
+
+   CALL nl_set_use_wps_input ( 1 , REALONLY )
+
+   !  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')
+   END IF
+
+   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 )
+            CALL find_my_parent2( grid_ptr2 , grid_ptr ,             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 )
+
+         !  Some simple checks.
+         
+         ok_so_far = .TRUE.
+
+         DO loop = 2 , model_config_rec%max_dom
+            IF ( model_config_rec%e_vert(loop) .NE.  model_config_rec%e_vert(1) ) THEN
+               CALL  wrf_message ( 'e_vert must be the same for each domain' )
+               ok_so_far = .FALSE.
+            END IF
+         END DO
+         IF ( .NOT. ok_so_far ) THEN
+            CALL wrf_error_fatal( 'fix namelist.input settings' )
+         END IF
+
+         !  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_real
+   USE module_optional_input
+#ifdef WRF_CHEM
+   USE module_input_chem_data
+   USE module_input_chem_bioemiss
+!  USE module_input_chem_emissopt3
+#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 ) .AND. &
+           ( model_config_rec%sst_update .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 )
+      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' )
+      END IF
+
+      !  Input data.
+
+      CALL wrf_debug ( 100 , 'med_sidata_input: calling input_auxinput1' )
+      CALL input_auxinput1 ( 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_input' )
+         CALL init_module_optional_input ( grid , config_flags )
+      END IF
+      CALL       wrf_debug ( 100 , 'med_sidata_input: calling optional_input' )
+      CALL optional_input ( grid , idsi , config_flags )
+
+      !  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" )
+
+#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 med_read_wrf_chem_input ( grid , config_flags)
+
+              IF(grid%emiss_opt == ECPTEC .or. grid%emiss_opt == GOCART_ECPTEC   &
+                                         .or. grid%biomass_burn_opt == BIOMASSB) THEN
+                 message = 'READING EMISSIONS DATA OPT 3'
+                 CALL  wrf_message ( message )
+                 CALL med_read_wrf_chem_emissopt3 ( grid , config_flags)
+              END IF
+
+              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)
+              else IF(grid%bio_emiss_opt == 3 ) THEN !shc
+                 message = 'READING MEGAN 2 EMISSIONS DATA'
+                 CALL  wrf_message ( message )
+                 CALL med_read_wrf_chem_bioemiss ( grid , config_flags)
+              END IF
+
+              IF(grid%dust_opt == 1 .or. grid%dmsemis_opt == 1 .or. grid%chem_opt == 300) THEN !shc
+                 message = 'READING GOCART BG AND/OR DUST and DMS REF FIELDS'
+                 CALL  wrf_message ( message )
+                 CALL med_read_wrf_chem_gocart_bg ( 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)
+              else IF(grid%bio_emiss_opt == 3 ) THEN !shc
+                 message = 'READING MEGAN 2 EMISSIONS DATA'
+                 CALL  wrf_message ( message ) 
+                 CALL med_read_wrf_chem_bioemiss ( grid , config_flags)
+              END IF
+              IF(grid%emiss_opt == ECPTEC .or. grid%emiss_opt == GOCART_ECPTEC   &
+                                         .or. grid%biomass_burn_opt == BIOMASSB) THEN
+                 message = 'READING EMISSIONS DATA OPT 3'
+                 CALL  wrf_message ( message )
+!                CALL med_read_bin_chem_emissopt3 ( grid , config_flags)
+                 CALL med_read_wrf_chem_emissopt3 ( grid , config_flags)
+              END IF
+
+              IF(grid%dust_opt == 1 .or. grid%dmsemis_opt == 1 .or. grid%chem_opt == 300) THEN !shc
+                 message = 'READING GOCART BG AND/OR DUST and DMS REF FIELDS'
+                 CALL  wrf_message ( message )
+                 CALL med_read_wrf_chem_gocart_bg ( grid , config_flags)
+              END IF
+
+           ELSE
+             message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION'
+             CALL  wrf_message ( message )
+           END IF
+         END IF
+      END IF
+#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
+
+#ifdef PLANET
+   WRITE ( start_date_char , FMT = '(I4.4,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2)' ) &
+           start_year,start_day,start_hour,start_minute,start_second
+   WRITE (   end_date_char , FMT = '(I4.4,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2)' ) &
+             end_year,  end_day,  end_hour,  end_minute,  end_second
+#else
+   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
+#endif
+
+   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,  id4 
+   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
+
+      IF ( ( time_loop_max .EQ. 1 )  .OR. ( config_flags%polar ) ) THEN
+
+         !  No need to allocate space since we do not need the lateral boundary data yet
+         !  or at all (in case of the polar flag).
+
+      ELSE
+
+         !  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) )
+
+      END IF
+
+      !  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_input , "DATASET=INPUT", ierr )
+      IF ( ierr .NE. 0 ) THEN
+         CALL wrf_error_fatal( 'real: error opening wrfinput for writing' )
+      END IF
+      CALL output_input ( id1, grid , config_flags , ierr )
+      CALL close_dataset ( id1 , config_flags , "DATASET=INPUT" )
+
+      IF ( time_loop_max .NE. 1 ) THEN
+         IF(sst_update .EQ. 1)THEN
+           CALL construct_filename1( inpname , 'wrflowinp' , grid%id , 2 )
+           CALL open_w_dataset ( id4, TRIM(inpname) , grid , config_flags , output_auxinput4 , "DATASET=AUXINPUT4", ierr )
+           IF ( ierr .NE. 0 ) THEN
+              CALL wrf_error_fatal( 'real: error opening wrflowinp for writing' )
+           END IF
+           CALL output_auxinput4 ( id4, grid , config_flags , ierr )
+         END IF
+      END IF
+
+      IF ( ( time_loop_max .EQ. 1 )  .OR. ( config_flags%polar ) ) THEN
+
+         !  No need to couple data since no lateral BCs required.
+
+      ELSE
+
+         !  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.
+   
+         !  u, theta, h, scalars coupled with my; v coupled with mx
+         CALL couple ( grid%mu_2 , grid%mub , ubdy3dtemp1 , grid%u_2                 , 'u' , grid%msfuy , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( grid%mu_2 , grid%mub , vbdy3dtemp1 , grid%v_2                 , 'v' , grid%msfvx , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( grid%mu_2 , grid%mub , tbdy3dtemp1 , grid%t_2                 , 't' , grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( grid%mu_2 , grid%mub , pbdy3dtemp1 , grid%ph_2                , 'h' , grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( grid%mu_2 , grid%mub , qbdy3dtemp1 , grid%moist(:,:,:,P_QV)      , 't' , grid%msfty , &
+                       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%mu_2(i,j)
+            END DO
+         END DO
+
+      END IF
+
+      IF(grid_fdda .GE. 1)THEN
+         DO j = jps , jpe
+            DO k = kps , kpe
+               DO i = ips , ipe
+                  grid%fdda3d(i,k,j,p_u_ndg_old) = grid%u_2(i,k,j)
+                  grid%fdda3d(i,k,j,p_v_ndg_old) = grid%v_2(i,k,j)
+                  grid%fdda3d(i,k,j,p_t_ndg_old) = grid%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%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%mu_2(i,j)
+!              grid%fdda2d(i,1,j,p_t2_ndg_old) = grid%t2(i,j)
+!              grid%fdda2d(i,1,j,p_q2_ndg_old) = grid%q2(i,j)
+!              grid%fdda2d(i,1,j,p_sn_ndg_old) = grid%snow(i,j)
+            END DO
+         END DO
+      END IF
+
+      IF ( ( time_loop_max .EQ. 1 )  .OR. ( config_flags%polar ) ) THEN
+
+         !  No need to build boundary arrays, since no lateral BCs are being generated.
+
+      ELSE
+   
+         !  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%u_bxs, grid%u_bxe, grid%u_bys, grid%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%v_bxs, grid%v_bxe, grid%v_bys, grid%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%t_bxs, grid%t_bxe, grid%t_bys, grid%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%ph_bxs, grid%ph_bxe, grid%ph_bys, grid%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%mu_bxs, grid%mu_bxe, grid%mu_bys, grid%mu_bye, &
+                                                              'M' , spec_bdy_width      , &
+                                                                    ids , ide , jds , jde , 1 , 1 , &
+                                                                    ims , ime , jms , jme , 1 , 1 , &
+                                                                    ips , ipe , jps , jpe , 1 , 1 )
+      END IF
+
+
+   ELSE IF ( loop .GT. 1 ) THEN
+
+      IF(sst_update .EQ. 1)THEN
+        CALL output_auxinput4 ( id4, grid , config_flags , ierr )
+      END IF
+
+      !  Open the boundary and the fdda file.
+
+      IF ( loop .eq. 2 ) THEN
+         IF ( (grid%id .eq. 1) .and. ( .NOT. config_flags%polar ) ) 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' )
+            END IF
+         END IF
+         IF(grid_fdda .GE. 1)THEN
+            CALL construct_filename1( inpname , 'wrffdda' , grid%id , 2 )
+            CALL open_w_dataset ( id2, TRIM(inpname) , grid , config_flags , output_auxinput10 , "DATASET=AUXINPUT10", ierr )
+            IF ( ierr .NE. 0 ) THEN
+               CALL wrf_error_fatal( 'real: error opening wrffdda for writing' )
+            END IF
+         END IF
+      ELSE
+         IF ( .NOT. domain_clockisstoptime(grid) ) THEN
+            CALL domain_clockadvance( grid )
+            CALL domain_clockprint ( 150, grid, &
+                   'DEBUG assemble_output:  clock after ClockAdvance,' )
+         END IF
+      END IF
+
+      IF ( config_flags%polar ) THEN
+
+         !  No need to couple fields, since no lateral BCs are required.
+
+      ELSE
+   
+         !  Couple this time period's data with total mu, and save it in the *bdy3dtemp2 arrays.
+   
+         !  u, theta, h, scalars coupled with my; v coupled with mx
+         CALL couple ( grid%mu_2 , grid%mub , ubdy3dtemp2 , grid%u_2                 , 'u' , grid%msfuy , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( grid%mu_2 , grid%mub , vbdy3dtemp2 , grid%v_2                 , 'v' , grid%msfvx , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( grid%mu_2 , grid%mub , tbdy3dtemp2 , grid%t_2                 , 't' , grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( grid%mu_2 , grid%mub , pbdy3dtemp2 , grid%ph_2                , 'h' , grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         CALL couple ( grid%mu_2 , grid%mub , qbdy3dtemp2 , grid%moist(:,:,:,P_QV)      , 't' , grid%msfty , &
+                       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%mu_2(i,j)
+            END DO
+         END DO
+
+      END IF
+
+      IF(grid_fdda .GE. 1)THEN
+         DO j = jps , jpe
+            DO k = kps , kpe
+               DO i = ips , ipe
+                  grid%fdda3d(i,k,j,p_u_ndg_new) = grid%u_2(i,k,j)
+                  grid%fdda3d(i,k,j,p_v_ndg_new) = grid%v_2(i,k,j)
+                  grid%fdda3d(i,k,j,p_t_ndg_new) = grid%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%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%mu_2(i,j)
+!              grid%fdda2d(i,1,j,p_t2_ndg_new) = grid%t2(i,j)
+!              grid%fdda2d(i,1,j,p_q2_ndg_new) = grid%q2(i,j)
+!              grid%fdda2d(i,1,j,p_sn_ndg_new) = grid%snow(i,j)
+            END DO
+         END DO
+      END IF
+
+      IF ( config_flags%polar ) THEN
+
+         !  No need to build boundary arrays, since no lateral BCs are being generated.
+
+      ELSE
+
+         !  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%u_btxs, grid%u_btxe,     &
+                                                               grid%u_btys, grid%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%v_btxs, grid%v_btxe,     &
+                                                               grid%v_btys, grid%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%t_btxs, grid%t_btxe,     &
+                                                               grid%t_btys, grid%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%ph_btxs, grid%ph_btxe,   &
+                                                               grid%ph_btys, grid%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%mu_btxs, grid%mu_btxe,   &
+                                                               grid%mu_btys, grid%mu_btye,   &
+                                                               'M' , &
+                                                               spec_bdy_width      , &
+                                                               ids , ide , jds , jde , 1 , 1 , &
+                                                               ims , ime , jms , jme , 1 , 1 , &
+                                                               ips , ipe , jps , jpe , 1 , 1 )
+      END IF
+
+      !  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 ( config_flags%polar ) THEN
+
+         !  No need to ouput boundary data for polar cases.
+
+      ELSE
+
+         !  Output boundary file.
+   
+         IF(grid%id .EQ. 1)THEN
+           print *,'LBC valid between these times ',current_date, ' ',start_date
+           CALL output_boundary ( id, grid , config_flags , ierr )
+         END IF
+
+      END IF
+
+      !  Output gridded/analysis FDDA file.
+
+      IF(grid_fdda .GE. 1) THEN
+         CALL output_auxinput10 ( 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.
+
+      IF ( config_flags%all_ic_times ) THEN
+         CALL construct_filename2a ( inpname , 'wrfinput_d<domain>.<date>' , grid%id , 2 , TRIM(current_date) )
+         CALL open_w_dataset ( id1, inpname , grid , config_flags , output_input , "DATASET=INPUT", ierr )
+         IF ( ierr .NE. 0 ) THEN
+            CALL wrf_error_fatal( 'real: error opening' // inpname // ' for writing' )
+         END IF
+         CALL output_input ( id1, grid , config_flags , ierr )
+         CALL close_dataset ( id1 , config_flags , "DATASET=INPUT" )
+      END IF
+
+      !  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
+
+         IF ( config_flags%polar ) THEN
+  
+            !  No need to swap old for new for the boundary data, it is not required.
+
+         ELSE
+
+            !  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
+
+         END IF
+
+         IF(grid_fdda .GE. 1)THEN
+            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)
+!                 grid%fdda2d(i,1,j,p_t2_ndg_old) = grid%fdda2d(i,1,j,p_t2_ndg_new)
+!                 grid%fdda2d(i,1,j,p_q2_ndg_old) = grid%fdda2d(i,1,j,p_q2_ndg_new)
+!                 grid%fdda2d(i,1,j,p_sn_ndg_old) = grid%fdda2d(i,1,j,p_sn_ndg_new)
+               END DO
+            END DO
+         END IF
+
+         IF ( config_flags%polar ) THEN
+
+            !  No need to build boundary arrays, since no lateral BCs are being generated.
+
+         ELSE
+
+            !  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%u_bxs, grid%u_bxe, grid%u_bys, grid%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%v_bxs, grid%v_bxe, grid%v_bys, grid%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%t_bxs, grid%t_bxe, grid%t_bys, grid%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%ph_bxs, grid%ph_bxe, grid%ph_bys, grid%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%mu_bxs, grid%mu_bxe, grid%mu_bys, grid%mu_bye, &
+                                                                 'M' , spec_bdy_width      , &
+                                                                       ids , ide , jds , jde , 1 , 1 , &
+                                                                       ims , ime , jms , jme , 1 , 1 , &
+                                                                       ips , ipe , jps , jpe , 1 , 1 )
+   
+         END IF
+
+      ELSE IF ( loop .EQ. time_loop_max ) THEN
+
+         !  If this is the last time through here, we need to close the files.
+
+         IF ( config_flags%polar ) THEN
+
+            !  No need to close the boundary file, it was never used.
+
+         ELSE
+            IF(grid%id .EQ. 1) THEN
+               CALL close_dataset ( id , config_flags , "DATASET=BOUNDARY" )
+            END IF
+         END IF
+
+         IF(grid_fdda .GE. 1) THEN
+            CALL close_dataset ( id2 , config_flags , "DATASET=AUXINPUT10" )
+         END IF
+
+         IF(sst_update .EQ. 1)THEN
+            CALL close_dataset ( id4 , config_flags , "DATASET=AUXINPUT4" )
+         END IF
+
+      END IF
+
+   END IF
+
+END SUBROUTINE assemble_output
Index: branches/LMDZ_WRFmeas/WRFV3/main/real_nmm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/main/real_nmm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/main/real_nmm.F	(revision 17)
@@ -0,0 +1,1680 @@
+!  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_real
+   USE module_io_domain
+   USE module_driver_constants
+   USE module_configure
+   USE module_timing
+   USE module_check_a_mundo
+#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 check_nml_consistency
+   CALL set_physics_rconfigs
+
+   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_real
+   USE module_optional_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
+
+#if defined(HWRF)
+  ! Sam Says:
+
+  ! The *INIT arrays are used to read init data written out by hwrf_prep_hybrid
+  REAL,ALLOCATABLE,DIMENSION(:,:,:)::TINIT,UINIT,VINIT,QINIT,CWMINIT
+  REAL,ALLOCATABLE,DIMENSION(:,:,:)::PINIT
+  REAL,ALLOCATABLE,DIMENSION(:,:)::PDINIT
+
+  ! The *B arrays are used to read boundary data written out by hwrf_prep_hybrid
+  REAL,ALLOCATABLE,DIMENSION(:,:,:)::TB,UB,VB,QB,CWMB
+  REAL,ALLOCATABLE,DIMENSION(:,:)::PDB
+
+  INTEGER :: KB, LM, IM, JM, iunit_gfs, N
+
+  integer :: i,j,k
+  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 :: ioerror
+#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.
+       
+       
+      write(message,*) 'TRIM(config_flags%auxinput1_inname): ', TRIM(config_flags%auxinput1_inname)
+      CALL wrf_message(message)
+       
+#if defined(HWRF)
+     ifph_onlyfirst: if(.not.grid%use_prep_hybrid .or. loop==1) then
+#endif
+      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_auxinput1_wrf')
+
+      CALL input_auxinput1 ( 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_input' )
+         CALL init_module_optional_input ( grid , config_flags )
+      CALL wrf_debug ( 100 , 'med_sidata_input: calling optional_input' )
+!
+      CALL optional_input ( grid , idsi , config_flags )
+	write(0,*) 'maxval st_input(1) within real_nmm: ', maxval(st_input(:,1,:))
+      END IF
+!
+      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_input' )
+         CALL init_module_optional_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)
+        current_date_char(11:11)='_'
+        CALL construct_filename4a( si_inpname , config_flags%auxinput1_inname , grid%id , 2 , current_date_char , &
+                                     config_flags%io_form_auxinput1 )
+        CALL read_wps ( grid, trim(si_inpname), current_date_char, config_flags%num_metgrid_levels )
+!!! bogus set some flags??
+      flag_metgrid=1
+      flag_soilhgt=1
+
+
+          ENDIF
+
+#endif
+      CASE DEFAULT
+        CALL wrf_error_fatal('real: not valid io_form_auxinput1')
+      END SELECT
+#if defined(HWRF)
+     endif ifph_onlyfirst
+#endif
+
+      grid%islope=1
+      grid%vegfra=grid%vegfrc
+      grid%dfrlg=grid%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 )
+
+#if defined(HWRF)
+     read_phinit: if(grid%use_prep_hybrid) then
+#if defined(DM_PARALLEL)
+        if(.not. wrf_dm_on_monitor()) then
+           call wrf_error_fatal('real: in use_prep_hybrid mode, threading and mpi are forbidden.')
+        endif
+#endif
+
+        ph_loop1: if(loop==1) then
+
+           ! determine kds, ids, jds
+           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
+           ! Allocate 3D initialization arrays:
+           call wrf_message('ALLOCATE PREP_HYBRID INIT ARRAYS')
+           ALLOCATE ( TINIT  (ids:(ide-1),kds:(kde-1)  ,jds:(jde-1)) )
+           ALLOCATE ( PINIT  (ids:(ide-1),kds:kde      ,jds:(jde-1)) )
+           ALLOCATE ( UINIT  (ids:(ide-1),kds:(kde-1)  ,jds:(jde-1)) )
+           ALLOCATE ( VINIT  (ids:(ide-1),kds:(kde-1)  ,jds:(jde-1)) )
+           ALLOCATE ( QINIT  (ids:(ide-1),kds:(kde-1)  ,jds:(jde-1)) )
+           ALLOCATE ( CWMINIT(ids:(ide-1),kds:(kde-1)  ,jds:(jde-1)) )
+           ALLOCATE ( PDINIT (ids:(ide-1),              jds:(jde-1)) )
+
+           REWIND 900
+           READ(900,iostat=ioerror) PDINIT,TINIT,QINIT,CWMINIT,UINIT,VINIT,PINIT
+           if(ioerror/=0) then
+              call wrf_error_fatal('Unable to read MAKBND output from unit 900.')
+           endif
+           WRITE(0,*) 'U V T AT 10 10 10 ',UINIT(10,10,10),VINIT(10,10,10),TINIT(10,10,10)
+           ! Switch from IKJ to IJK ordering
+           DO I = ids,ide-1
+              DO J = jds,jde-1
+                 grid%pd(I,J) = PDINIT(I,J)
+                 DO K = kds,kde-1
+                    grid%q2(I,J,K) = 0
+                    grid%u(I,J,K) = UINIT(I,K,J)
+                    grid%v(I,J,K) = VINIT(I,K,J)
+                    grid%t(I,J,K) = TINIT(I,K,J)
+                    grid%q(I,J,K) = QINIT(I,K,J)
+                    grid%cwm(I,J,K) = CWMINIT(I,K,J)
+                 ENDDO
+                 !  Was commented out in original V2 HWRF too:
+                 !      DO K = kds,kde
+                 !         grid%nmm_pint(I,J,K) = pinit(I,K,J)
+                 !      ENDDO
+              ENDDO
+           ENDDO
+
+           call wrf_message('DEALLOCATE PREP_HYBRID INIT ARRAYS')
+           deallocate(TINIT,PINIT,UINIT,VINIT,QINIT,CWMINIT,PDINIT)
+        end if ph_loop1
+     end if read_phinit
+#endif
+
+      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)
+              else IF(grid%bio_emiss_opt == 3 ) THEN !shc
+                 message = 'READING MEGAN 2 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%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)
+              else IF(grid%bio_emiss_opt == 3 ) THEN !shc
+                 message = 'READING MEGAN 2 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
+
+#if defined(HWRF)
+  external get_wrf_debug_level
+  integer :: debug
+#endif
+
+   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, sst_update
+   INTEGER , SAVE :: id ,id4
+   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
+
+#if defined(HWRF)
+  ! Sam says:
+
+  ! The *B arrays are used to read boundary data written out by hwrf_prep_hybrid
+  REAL,ALLOCATABLE,DIMENSION(:,:,:)::TB,UB,VB,QB,CWMB
+  REAL,ALLOCATABLE,DIMENSION(:,:)::PDB
+
+  ! Dimensions and looping variables:
+  INTEGER :: KB, LM, IM, JM, N
+
+  ! Unit number to read boundary data from (changes each time)
+  INTEGER :: iunit_gfs
+
+  ! Did we allocate the prep_hybrid input arrays?
+  LOGICAL :: alloc_ph_arrays
+
+  integer :: ioerror
+#endif
+
+#include "deref_kludge.h"
+
+#if defined(HWRF)
+  alloc_ph_arrays=.false.
+  call get_wrf_debug_level(debug)
+#endif
+
+   !  Various sizes that we need to be concerned about.
+
+   ids = grid%sd31
+   ide = grid%ed31-1 ! 030730tst
+   jds = grid%sd32
+   jde = grid%ed32-1 ! 030730tst
+   kds = grid%sd33
+   kde = grid%ed33-1 ! 030730tst
+
+   ims = grid%sm31
+   ime = grid%em31
+   jms = grid%sm32
+   jme = grid%em32
+   kms = grid%sm33
+   kme = grid%em33
+
+   ips = grid%sp31
+   ipe = grid%ep31-1 ! 030730tst
+   jps = grid%sp32
+   jpe = grid%ep32-1 ! 030730tst
+   kps = grid%sp33
+   kpe = 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
+   sst_update = model_config_rec%sst_update
+
+!-----------------------------------------------------------------------
+!
+   main_loop_test: IF ( loop .EQ. 1 ) THEN
+!
+!-----------------------------------------------------------------------
+
+      IF ( time_loop_max .NE. 1 ) THEN
+         IF(sst_update .EQ. 1)THEN
+           CALL construct_filename1( inpname , 'wrflowinp' , grid%id , 2 )
+           CALL open_w_dataset ( id4, TRIM(inpname) , grid , config_flags , output_auxinput4 , "DATASET=AUXINPUT4", ierr )
+           IF ( ierr .NE. 0 ) THEN
+              CALL wrf_error_fatal( 'real: error opening wrflowinp for writing' )
+           END IF
+           CALL output_auxinput4 ( id4, grid , config_flags , ierr )
+         END IF
+      END IF
+
+
+   !  This is the space needed to save the current 3d data for use in computing
+   !  the lateral boundary tendencies.
+
+      ALLOCATE ( ubdy3dtemp1(ims:ime,jms:jme,kms:kme) )
+      ALLOCATE ( vbdy3dtemp1(ims:ime,jms:jme,kms:kme) )
+      ALLOCATE ( tbdy3dtemp1(ims:ime,jms:jme,kms:kme) )
+      ALLOCATE ( qbdy3dtemp1(ims:ime,jms:jme,kms:kme) )
+      ALLOCATE ( cwmbdy3dtemp1(ims:ime,jms:jme,kms:kme) )
+      ALLOCATE ( q2bdy3dtemp1(ims:ime,jms:jme,kms:kme) )
+      ALLOCATE ( pdbdy2dtemp1(ims:ime,jms:jme,1:1) )
+
+	ubdy3dtemp1=0.
+	vbdy3dtemp1=0.
+	tbdy3dtemp1=0.
+	qbdy3dtemp1=0.
+	cwmbdy3dtemp1=0.
+	q2bdy3dtemp1=0.
+	pdbdy2dtemp1=0.
+
+      ALLOCATE ( ubdy3dtemp2(ims:ime,jms:jme,kms:kme) )
+      ALLOCATE ( vbdy3dtemp2(ims:ime,jms:jme,kms:kme) )
+      ALLOCATE ( tbdy3dtemp2(ims:ime,jms:jme,kms:kme) )
+      ALLOCATE ( qbdy3dtemp2(ims:ime,jms:jme,kms:kme) )
+      ALLOCATE ( cwmbdy3dtemp2(ims:ime,jms:jme,kms:kme) )
+      ALLOCATE ( q2bdy3dtemp2(ims:ime,jms:jme,kms:kme) )
+      ALLOCATE ( pdbdy2dtemp2(ims:ime,jms:jme,1:1) )
+
+	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_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_input'
+        CALL wrf_message(message)
+
+        CALL output_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,j,k) = grid%u(i,j,k)
+            vbdy3dtemp1(i,j,k) = grid%v(i,j,k)
+            tbdy3dtemp1(i,j,k) = grid%t(i,j,k)
+            qbdy3dtemp1(i,j,k) = grid%q(i,j,k)
+            cwmbdy3dtemp1(i,j,k) = grid%cwm(i,j,k)
+            q2bdy3dtemp1(i,j,k) = grid%q2(i,j,k)
+          END DO
+          END DO
+
+          DO i = ips , MIN(ide,ipe)
+            pdbdy2dtemp1(i,j,1) = grid%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,j,k) = grid%u(i,j,k)
+            vbdy3dtemp1(i,j,k) = grid%v(i,j,k)
+            tbdy3dtemp1(i,j,k) = grid%t(i,j,k)
+            qbdy3dtemp1(i,j,k) = grid%q(i,j,k)
+            cwmbdy3dtemp1(i,j,k) = grid%cwm(i,j,k)
+            q2bdy3dtemp1(i,j,k) = grid%q2(i,j,k)
+          END DO
+          END DO
+
+          DO i = ips , MIN(ide,ipe)
+            pdbdy2dtemp1(i,j,1) = grid%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,j,k) = grid%t(i,j,k)
+            qbdy3dtemp1(i,j,k) = grid%q(i,j,k)
+            cwmbdy3dtemp1(i,j,k) = grid%cwm(i,j,k)
+            q2bdy3dtemp1(i,j,k) = grid%q2(i,j,k)
+      if(k==1)then
+        write(message,*)' loop=',loop,' i=',i,' j=',j,' tbdy3dtemp1(i,j,k)=',tbdy3dtemp1(i,j,k)
+        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,j,k) = grid%u(i,j,k)
+            vbdy3dtemp1(i,j,k) = grid%v(i,j,k)
+	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,j,1) = grid%pd(i,j)
+          write(message,*)' loop=',loop,' i=',i,' j=',j,' pdbdy2dtemp1(i,j)=',pdbdy2dtemp1(i,j,1)
+          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,j,k) = grid%t(i,j,k)
+            qbdy3dtemp1(i,j,k) = grid%q(i,j,k)
+            cwmbdy3dtemp1(i,j,k) = grid%cwm(i,j,k)
+            q2bdy3dtemp1(i,j,k) = grid%q2(i,j,k)
+	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,j,k) = grid%u(i,j,k)
+            vbdy3dtemp1(i,j,k) = grid%v(i,j,k)
+        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,j,1) = grid%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_ijk (ubdy3dtemp1, grid%u_bxs, grid%u_bxe, &
+                                  grid%u_bys, grid%u_bye, &
+                                  'N', 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_ijk (vbdy3dtemp1, grid%v_bxs, grid%v_bxe, &
+                                  grid%v_bys, grid%v_bye, &
+                                  'N', 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_ijk (tbdy3dtemp1, grid%t_bxs, grid%t_bxe, &
+                                  grid%t_bys, grid%t_bye, &
+                                  'N', 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_ijk (cwmbdy3dtemp1, grid%cwm_bxs, grid%cwm_bxe, &
+                                  grid%cwm_bys, grid%cwm_bye, &
+                                  'N', 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_ijk (qbdy3dtemp1, grid%q_bxs, grid%q_bxe, &
+                                  grid%q_bys, grid%q_bye, &
+                                  'N', 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_ijk (q2bdy3dtemp1, grid%q2_bxs, grid%q2_bxe, &
+                                  grid%q2_bys, grid%q2_bye, &
+                                  'N', 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_ijk (pdbdy2dtemp1, grid%pd_bxs, grid%pd_bxe, &
+                                   grid%pd_bys, grid%pd_bye, &
+                                   'M', 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
+!
+!-----------------------------------------------------------------------
+
+     call wrf_debug(1,'LOOP>1, so start making non-init boundary conditions')
+#if defined(HWRF)
+
+     bdytmp_useph: if(grid%use_prep_hybrid) then
+        call wrf_debug(1,'ALLOCATE PREP_HYBRID BOUNDARY ARRAYS')
+        !! When running in prep_hybrid mode, we must read in the data here.
+
+        ! Allocate boundary arrays:
+        KB = 2*IDE + JDE - 3
+        LM = KDE
+        IM = IDE
+        JM = JDE
+        ALLOCATE(TB(KB,LM,2))
+        ALLOCATE(QB(KB,LM,2))
+        ALLOCATE(CWMB(KB,LM,2))
+        ALLOCATE(UB(KB,LM,2))
+        ALLOCATE(VB(KB,LM,2))
+        ALLOCATE(PDB(KB,2))
+        alloc_ph_arrays=.true.
+
+        ! Read in the data:
+        IUNIT_GFS = 900 + LOOP - 1
+        READ(IUNIT_GFS,iostat=ioerror) PDB,TB,QB,CWMB,UB,VB
+        if(ioerror/=0) then
+           call wrf_error_fatal('Unable to read MAKBND output from unit 900.')
+        endif
+
+        ! Now copy the data into the temporary boundary arrays, and
+        ! switch from IKJ to IJK while we do it.
+
+        !!    Southern boundary
+
+        IF(JPS.EQ.JDS)THEN
+           J=1
+
+           DO k = kps , MIN(kde,kpe)
+              N=1
+              DO i = ips , MIN(ide,ipe)
+                 tbdy3dtemp2(i,j,k) =   TB(N,k,1)
+                 qbdy3dtemp2(i,j,k) =   QB(N,k,1)
+                 cwmbdy3dtemp2(i,j,k) = CWMB(N,k,1)
+                 q2bdy3dtemp2(i,j,k) =  0.0        !KWON
+                 write(message,*)'southtend t',k,i,n,tbdy3dtemp2(i,j,k)
+                 call wrf_debug(10,message)
+                 write(message,*)'southtend q',k,i,n,qbdy3dtemp2(i,j,k)
+                 call wrf_debug(10,message)
+                 if (K .eq. 1 ) then
+                    write(0,*) 'S boundary values T,Q : ', I,tbdy3dtemp2(i,j,k),  &
+                         qbdy3dtemp2(i,j,k)
+                 endif
+                 N=N+1
+              END DO
+           END DO
+
+           DO k = kps , MIN(kde,kpe)
+              N=1
+              DO i = ips , MIN(ide,ipe)
+                 ubdy3dtemp2(i,j,k) = UB(N,k,1)
+                 vbdy3dtemp2(i,j,k) = VB(N,k,1)
+                 N=N+1
+              ENDDO
+           END DO
+
+           N=1
+           DO i = ips , MIN(ide,ipe)
+              pdbdy2dtemp2(i,j,1) = PDB(N,1)
+              write(message,*)'southtend p',i,n,pdbdy2dtemp1(i,j,1)
+              call wrf_debug(10,message)
+              N=N+1
+           END DO
+
+        ENDIF
+
+        !     Northern boundary
+
+        IF(JPE.EQ.JDE)THEN
+
+           J=MIN(JDE,JPE)
+           DO k = kps , MIN(kde,kpe)
+              N=IM+1
+              DO i = ips , MIN(ide,ipe)
+                 tbdy3dtemp2(i,j,k) =   TB(N,k,1)
+                 qbdy3dtemp2(i,j,k) =   QB(N,k,1)
+                 cwmbdy3dtemp2(i,j,k) = CWMB(N,k,1)
+                 q2bdy3dtemp2(i,j,k) =  0.0        !KWON
+                    write(message,*)'northtend t',k,i,n,tbdy3dtemp2(i,j,k)
+                    call wrf_debug(10,message)
+                    write(message,*)'northtend q',k,i,n,qbdy3dtemp2(i,j,k)
+                    call wrf_debug(10,message)
+                 N=N+1
+              END DO
+           END DO
+
+           DO k = kps , MIN(kde,kpe)
+              N=IM
+              DO i = ips , MIN(ide,ipe)
+                 ubdy3dtemp2(i,j,k) = UB(N,k,1)
+                 vbdy3dtemp2(i,j,k) = VB(N,k,1)
+                 N=N+1
+              END DO
+           END DO
+
+           N=IM+1
+           DO i = ips , MIN(ide,ipe)
+              pdbdy2dtemp2(i,j,1) = PDB(N,1)
+                 write(message,*)'northtend p',i,n,pdbdy2dtemp1(i,j,1)
+                 call wrf_debug(10,message)
+              N=N+1
+           END DO
+
+        ENDIF
+
+        !!     Western boundary
+
+        IF(IPS.EQ.IDS)THEN
+           I=1
+           DO k = kps , MIN(kde,kpe)
+              N=2*IM+1
+              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,j,k) =   TB(N,k,1)
+                    qbdy3dtemp2(i,j,k) =   QB(N,k,1)
+                    cwmbdy3dtemp2(i,j,k) = CWMB(N,k,1)
+                    q2bdy3dtemp2(i,j,k) =  0.0        !KWON
+                       write(message,*)'westtend t',k,j,n,tbdy3dtemp2(i,j,k)
+                       call wrf_debug(10,message)
+                       write(message,*)'westtend q',k,j,n,qbdy3dtemp2(i,j,k)
+                       call wrf_debug(10,message)
+                    N=N+1
+                 endif
+              END DO
+           END DO
+
+           DO k = kps , MIN(kde,kpe)
+              N=2*IM-1
+              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,j,k) = UB(N,k,1)
+                    vbdy3dtemp2(i,j,k) = VB(N,k,1)
+                    N=N+1
+                 endif
+              END DO
+           END DO
+
+           N=2*IM+1
+           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,j,1) = PDB(N,1)
+                    write(message,*)'westtend p',j,n,pdbdy2dtemp1(i,j,1)
+                    call wrf_debug(10,message)
+                 N=N+1
+              endif
+           END DO
+
+        ENDIF
+
+        !!     Eastern boundary
+
+        IF(IPE.EQ.IDE)THEN
+
+           I=MIN(IDE,IPE)
+
+           DO k = kps , MIN(kde,kpe)
+              N=2*IM+(JM/2)
+              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,j,k) =   TB(N,k,1)
+                    qbdy3dtemp2(i,j,k) =   QB(N,k,1)
+                    cwmbdy3dtemp2(i,j,k) = CWMB(N,k,1)
+                    q2bdy3dtemp2(i,j,k) =  0.0        !KWON
+                       write(message,*)'easttend t',k,j,n,tbdy3dtemp2(i,j,k)
+                       call wrf_debug(10,message)
+                       write(message,*)'easttend q',k,j,n,qbdy3dtemp2(i,j,k)
+                       call wrf_debug(10,message)
+                    N=N+1
+                 endif
+              END DO
+           END DO
+
+           DO k = kps , MIN(kde,kpe)
+              N=2*IM+(JM/2)-1
+              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,j,k) = UB(N,k,1)
+                    vbdy3dtemp2(i,j,k) = VB(N,k,1)
+                    N=N+1
+                 endif
+              END DO
+           END DO
+
+           N=2*IM+(JM/2)
+           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,j,1) = PDB(N,1)
+                    write(message,*)'easttend p',j,n,pdbdy2dtemp1(i,j,1)
+                    call wrf_debug(10,message)
+                 N=N+1
+              endif
+           END DO
+
+        ENDIF
+     else
+#endif
+
+           CALL output_auxinput4 ( id4, grid , config_flags , ierr )
+
+#if defined( HWRF)
+     endif bdytmp_useph
+#endif
+
+      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
+
+#if defined(HWRF)
+     bdytmp_notph: if(.not.grid%use_prep_hybrid) then
+#endif
+!-----------------------------------------------------------------------
+!***  SOUTHERN BOUNDARY
+!-----------------------------------------------------------------------
+!
+        IF(JPS==JDS)THEN
+          J=1
+          DO k = kps , MIN(kde,kpe)
+          DO i = ips , MIN(ide,ipe)
+            ubdy3dtemp2(i,j,k) = grid%u(i,j,k)
+            vbdy3dtemp2(i,j,k) = grid%v(i,j,k)
+            tbdy3dtemp2(i,j,k) = grid%t(i,j,k)
+            qbdy3dtemp2(i,j,k) = grid%q(i,j,k)
+            cwmbdy3dtemp2(i,j,k) = grid%cwm(i,j,k)
+            q2bdy3dtemp2(i,j,k) = grid%q2(i,j,k)
+          END DO
+          END DO
+!
+          DO i = ips , MIN(ide,ipe)
+            pdbdy2dtemp2(i,j,1) = grid%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,j,k) = grid%u(i,j,k)
+            vbdy3dtemp2(i,j,k) = grid%v(i,j,k)
+            tbdy3dtemp2(i,j,k) = grid%t(i,j,k)
+            qbdy3dtemp2(i,j,k) = grid%q(i,j,k)
+            cwmbdy3dtemp2(i,j,k) = grid%cwm(i,j,k)
+            q2bdy3dtemp2(i,j,k) = grid%q2(i,j,k)
+          END DO
+          END DO
+
+          DO i = ips , MIN(ide,ipe)
+            pdbdy2dtemp2(i,j,1) = grid%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,j,k) = grid%t(i,j,k)
+      if(k==1)then
+        write(message,*)' loop=',loop,' i=',i,' j=',j,' tbdy3dtemp1(i,j,k)=',tbdy3dtemp1(i,j,k)
+        call wrf_debug(10,message)
+      endif
+            qbdy3dtemp2(i,j,k) = grid%q(i,j,k)
+            cwmbdy3dtemp2(i,j,k) = grid%cwm(i,j,k)
+            q2bdy3dtemp2(i,j,k) = grid%q2(i,j,k)
+	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,j,k) = grid%u(i,j,k)
+            vbdy3dtemp2(i,j,k) = grid%v(i,j,k)
+	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,j,1) = grid%pd(i,j)
+          write(message,*)' loop=',loop,' i=',i,' j=',j,' pdbdy2dtemp1(i,j)=',pdbdy2dtemp1(i,j,1)
+          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,j,k) = grid%t(i,j,k)
+            qbdy3dtemp2(i,j,k) = grid%q(i,j,k)
+            cwmbdy3dtemp2(i,j,k) = grid%cwm(i,j,k)
+            q2bdy3dtemp2(i,j,k) = grid%q2(i,j,k)
+	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,j,k) = grid%u(i,j,k)
+            vbdy3dtemp2(i,j,k) = grid%v(i,j,k)
+	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,j,1) = grid%pd(i,j)
+	endif
+          END DO
+        ENDIF
+#if defined(HWRF)
+     endif bdytmp_notph
+#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_ijk ( ubdy3dtemp2 , ubdy3dtemp1 , REAL(interval_seconds),&
+                                   grid%u_btxs, grid%u_btxe, &
+                                   grid%u_btys, grid%u_btye, &
+                                   'N',  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_ijk ( vbdy3dtemp2 , vbdy3dtemp1 , REAL(interval_seconds),&
+                                   grid%v_btxs, grid%v_btxe, &
+                                   grid%v_btys, grid%v_btye, &
+                                   'N',  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_ijk ( tbdy3dtemp2 , tbdy3dtemp1 , REAL(interval_seconds),&
+                                   grid%t_btxs, grid%t_btxe, &
+                                   grid%t_btys, grid%t_btye, &
+                                   'N',  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_ijk ( cwmbdy3dtemp2 , cwmbdy3dtemp1 , REAL(interval_seconds),&
+                                   grid%cwm_btxs, grid%cwm_btxe, &
+                                   grid%cwm_btys, grid%cwm_btye, &
+                                   'N',  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_ijk ( qbdy3dtemp2 , qbdy3dtemp1 , REAL(interval_seconds),&
+                                   grid%q_btxs, grid%q_btxe, &
+                                   grid%q_btys, grid%q_btye, &
+                                   'N',  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_ijk ( q2bdy3dtemp2 , q2bdy3dtemp1 , REAL(interval_seconds),&
+                                   grid%q2_btxs, grid%q2_btxe, &
+                                   grid%q2_btys, grid%q2_btye, &
+                                   'N',  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_ijk( pdbdy2dtemp2 , pdbdy2dtemp1, REAL(interval_seconds),&
+                                   grid%pd_btxs, grid%pd_btxe, &
+                                   grid%pd_btys, grid%pd_btye, &
+                                   'M',  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_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_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 k = kps , kpe
+            DO j = jps , jpe
+               DO i = ips , ipe
+                  ubdy3dtemp1(i,j,k) = ubdy3dtemp2(i,j,k)
+                  vbdy3dtemp1(i,j,k) = vbdy3dtemp2(i,j,k)
+                  tbdy3dtemp1(i,j,k) = tbdy3dtemp2(i,j,k)
+                  cwmbdy3dtemp1(i,j,k) = cwmbdy3dtemp2(i,j,k)
+                  qbdy3dtemp1(i,j,k) = qbdy3dtemp2(i,j,k)
+                  q2bdy3dtemp1(i,j,k) = q2bdy3dtemp2(i,j,k)
+               END DO
+            END DO
+         END DO
+
+!mp	change these limits?????????
+
+         DO j = jps , jpe
+            DO i = ips , ipe
+               pdbdy2dtemp1(i,j,1) = pdbdy2dtemp2(i,j,1)
+            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_ijk (ubdy3dtemp1, grid%u_bxs, grid%u_bxe, &
+                                  grid%u_bys, grid%u_bye, &
+                                  'N', 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_ijk (vbdy3dtemp1, grid%v_bxs, grid%v_bxe, &
+                                  grid%v_bys, grid%v_bye, &
+                                  'N', 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_ijk (tbdy3dtemp1, grid%t_bxs, grid%t_bxe, &
+                                  grid%t_bys, grid%t_bye, &
+                                  'N', 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_ijk (cwmbdy3dtemp1, grid%cwm_bxs, grid%cwm_bxe, &
+                                  grid%cwm_bys, grid%cwm_bye, &
+                                  'N', 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_ijk (qbdy3dtemp1, grid%q_bxs, grid%q_bxe, &
+                                  grid%q_bys, grid%q_bye, &
+                                  'N', 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_ijk (q2bdy3dtemp1, grid%q2_bxs, grid%q2_bxe, &
+                                  grid%q2_bys, grid%q2_bye, &
+                                  'N', 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_ijk (pdbdy2dtemp1,grid%pd_bxs, grid%pd_bxe, &
+                                  grid%pd_bys, grid%pd_bye, &
+                                  'M', 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
+
+#if defined(HWRF)
+  if(alloc_ph_arrays) then
+     call wrf_debug(1,'DEALLOCATE PREP_HYBRID BOUNARY ARRAYS')
+     deallocate(TB,QB,CWMB,UB,VB,PDB)
+  endif
+#endif
+
+END SUBROUTINE assemble_output
Index: branches/LMDZ_WRFmeas/WRFV3/main/tc_em.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/main/tc_em.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/main/tc_em.F	(revision 17)
@@ -0,0 +1,2499 @@
+!  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 tc_data
+   USE module_machine
+   USE module_domain, ONLY : domain, alloc_and_configure_domain, &
+        domain_clock_set, head_grid, program_name, domain_clockprint, &
+        set_current_grid_ptr
+   USE module_io_domain
+   USE module_initialize_real, ONLY : wrfu_initialize
+   USE module_driver_constants
+   USE module_configure, ONLY : grid_config_rec_type, model_config_rec, &
+        initial_config, get_config_as_buffer, set_config_as_buffer
+   USE module_timing
+   USE module_state_description, ONLY : realonly
+   USE module_symbols_util, ONLY: wrfu_cal_gregorian
+   USE module_utility, ONLY : WRFU_finalize
+
+   IMPLICIT NONE
+
+
+   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, bogus_id, storm
+   real::t1,t2
+   real    :: latc_loc(max_bogus),lonc_loc(max_bogus),vmax(max_bogus),rmax(max_bogus)
+   real    :: rankine_lid
+   INTERFACE
+     SUBROUTINE Setup_Timekeeping( grid )
+      USE module_domain, ONLY : 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)
+
+   program_name = "TC_EM " // TRIM(release_version) // " PREPROCESSOR"
+
+!  The TC bogus algorithm assumes that the user defines a central point, and then
+!  allows the program to remove a typhoon based on a distance in km.  This is
+!  implemented on a single processor only.
+
+#ifdef DM_PARALLEL
+   IF ( .NOT. wrf_dm_on_monitor() ) THEN
+      CALL wrf_error_fatal( 'TC bogus must run with a single processor only, re-run with num procs set to 1' )
+   END IF
+#endif
+
+#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)
+#ifdef NO_LEAP_CALENDAR
+   CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_NOLEAP, rc=rc )
+#else
+   CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc )
+#endif
+   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
+   END IF
+   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 )
+
+   !  There are variables in the Registry that are only required for the real
+   !  program, fields that come from the WPS package.  We define the run-time
+   !  flag that says to allocate space for these input-from-WPS-only arrays.
+
+   CALL nl_set_use_wps_input ( 1 , REALONLY )
+
+   !  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')
+   END IF
+
+   all_domains : DO domain_id = 1 , max_dom
+
+      IF ( ( model_config_rec%input_from_file(domain_id) ) .OR. &
+           ( domain_id .EQ. 1 ) ) THEN
+
+         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 , 'tc_em: calling set_scalar_indices_from_config ' )
+         CALL set_scalar_indices_from_config ( grid%id , idum1, idum2 )
+
+!This is goofy but we need to loop through the number of storms to get 
+!the namelist variables for the tc_bogus.  But then we need to 
+!call model_to_grid_config_rec with the grid%id = to 1 in order to
+!reset to the correct information.
+         CALL       wrf_debug ( 100 , 'tc_em: calling model_to_grid_config_rec ' )
+         lonc_loc(:) = -999.
+         latc_loc(:) = -999.
+         vmax(:)     = -999.
+         rmax(:)     = -999.
+         CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
+         lonc_loc(1) = config_flags%lonc_loc
+         latc_loc(1) = config_flags%latc_loc
+         vmax(1)     = config_flags%vmax_meters_per_second
+         rmax(1)     = config_flags%rmax
+         rankine_lid = config_flags%rankine_lid
+         do storm = 2,config_flags%num_storm
+             bogus_id = storm
+             CALL model_to_grid_config_rec ( bogus_id , model_config_rec , config_flags )
+             lonc_loc(storm) = config_flags%lonc_loc
+             latc_loc(storm) = config_flags%latc_loc
+             vmax(storm)     = config_flags%vmax_meters_per_second
+             rmax(storm)     = config_flags%rmax
+!             print *,"in loop ",storm,lonc_loc(storm),latc_loc(storm),vmax(storm),rmax(storm)
+         end do
+         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 , 'tc_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 , 'tc_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 tc_med_sidata_input' )
+         CALL tc_med_sidata_input ( grid , config_flags, latc_loc, lonc_loc, &
+                                    vmax,rmax,rankine_lid)
+         CALL       wrf_debug ( 100 , 'backfrom tc_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 , 'tc_em: SUCCESS COMPLETE TC BOGUS' )
+
+   CALL wrf_shutdown
+
+   CALL WRFU_Finalize( rc=rc )
+
+
+END PROGRAM tc_data
+
+
+!-----------------------------------------------------------------
+SUBROUTINE tc_med_sidata_input ( grid , config_flags, latc_loc, lonc_loc, &
+                                 vmax, rmax,rankine_lid)
+  ! Driver layer
+   USE module_domain
+   USE module_io_domain
+  ! Model layer
+   USE module_configure
+   USE module_bc_time_utilities
+   USE module_optional_input
+
+   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, internal_time_loop,iflag
+! Declarations for the netcdf routines.
+   INTEGER                ::nf_inq
+!
+   CHARACTER (LEN=80)     :: si_inpname
+   CHARACTER (LEN=80)     :: message
+
+   CHARACTER(LEN=19) :: start_date_char , end_date_char , current_date_char , next_date_char
+   CHARACTER(LEN=8)  :: flag_name
+
+   INTEGER :: time_loop_max , loop, rc,icnt,itmp
+   INTEGER :: julyr , julday ,metndims, metnvars, metngatts, nunlimdimid,rcode
+   REAL    :: gmt
+   real    :: t1,t2,t3,t4
+   real    :: latc_loc(max_bogus), lonc_loc(max_bogus)
+   real    :: vmax(max_bogus),rmax(max_bogus),rankine_lid
+
+   grid%input_from_file = .true.
+   grid%input_from_file = .false.
+
+   CALL tc_compute_si_start ( 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%interval_seconds      , &
+                                   model_config_rec%real_data_init_type   , &
+                                   start_date_char)
+
+   end_date_char = start_date_char
+   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
+   print *,"the start date char ",start_date_char
+   print *,"the end date char ",end_date_char
+
+   time_loop_max = 1
+   !  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) )
+
+
+   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 ) .AND. &
+           ( model_config_rec%sst_update .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 tc stuff.  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 )
+      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' )
+      END IF
+
+      !  Input data.
+
+      CALL wrf_debug ( 100 , 'med_sidata_input: calling input_auxinput1' )
+      CALL input_auxinput1 ( idsi ,   grid , config_flags , ierr )
+      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 )
+      CALL       wrf_debug ( 100 , 'med_sidata_input: calling init_module_optional_input' )
+      CALL init_module_optional_input ( grid , config_flags )
+      CALL       wrf_debug ( 100 , 'med_sidata_input: calling optional_input' )
+      CALL optional_input ( grid , idsi , config_flags )
+
+!Here we check the flags yet again.  The flags are checked in optional_input but 
+!the grid% flags are not set.
+      flag_name(1:8) = 'SM000010'
+      CALL wrf_get_dom_ti_integer ( idsi, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) 
+      IF ( ierr .EQ. 0 ) THEN
+          grid%flag_sm000010 = 1
+      end if
+
+       flag_name(1:8) = 'SM010040'
+       CALL wrf_get_dom_ti_integer ( idsi, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) 
+       IF ( ierr .EQ. 0 ) THEN
+          grid%flag_sm010040 = 1
+       end if
+
+       flag_name(1:8) = 'SM040100'
+       CALL wrf_get_dom_ti_integer ( idsi, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) 
+       IF ( ierr .EQ. 0 ) THEN
+            grid%flag_sm040100 = itmp   
+       end if
+
+
+       flag_name(1:8) = 'SM100200'
+       CALL wrf_get_dom_ti_integer ( idsi, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) 
+       IF ( ierr .EQ. 0 ) THEN
+            grid%flag_sm100200 = itmp  
+       end if
+
+!       flag_name(1:8) = 'SM010200'
+!       CALL wrf_get_dom_ti_integer ( idsi, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) 
+!       IF ( ierr .EQ. 0 ) THEN
+!            config_flags%flag_sm010200 = itmp 
+!            print *,"found the flag_sm010200 "         
+!       end if
+
+!Now the soil temperature flags
+        flag_name(1:8) = 'ST000010'
+        CALL wrf_get_dom_ti_integer ( idsi, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) 
+        IF ( ierr .EQ. 0 ) THEN
+            grid%flag_st000010 = 1
+        END IF
+
+
+         flag_name(1:8) = 'ST010040'
+         CALL wrf_get_dom_ti_integer ( idsi, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) 
+         IF ( ierr .EQ. 0 ) THEN
+            grid%flag_st010040 = 1
+         END IF
+
+         flag_name(1:8) = 'ST040100'
+         CALL wrf_get_dom_ti_integer ( idsi, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) 
+         IF ( ierr .EQ. 0 ) THEN
+            grid%flag_st040100 = 1
+         END IF
+
+
+         flag_name(1:8) = 'ST100200'
+         CALL wrf_get_dom_ti_integer ( idsi, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) 
+         IF ( ierr .EQ. 0 ) THEN
+            grid%flag_st100200 = 1
+         END IF
+
+
+
+      CALL close_dataset ( idsi , config_flags , "DATASET=AUXINPUT1" )
+      CALL cpu_time ( t4 )
+
+      !  Possible optional SI input.  This sets flags used by init_domain.
+      !  We need to call the optional input routines to get the flags that 
+      !  are in the metgrid output file so they can be put in the tc bogus 
+      !  output file for real to read.
+      CALL cpu_time ( t3 )
+      already_been_here = .FALSE.
+      CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
+
+
+      CALL cpu_time ( t3 )
+
+      CALL assemble_output ( grid , config_flags , loop , time_loop_max, current_date_char, &
+                             latc_loc, lonc_loc, vmax, rmax, rankine_lid,si_inpname)
+      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 )
+
+      CALL cpu_time ( t1 )
+   END DO
+
+END SUBROUTINE tc_med_sidata_input
+
+
+!-------------------------------------------------------------------------------------
+SUBROUTINE tc_compute_si_start(  &
+   start_year , start_month , start_day , start_hour , start_minute , start_second , &
+   interval_seconds , real_data_init_type , &
+   start_date_char)
+
+   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
+
+#ifdef PLANET
+   WRITE ( start_date_char , FMT = '(I4.4,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2)' ) &
+           start_year,start_day,start_hour,start_minute,start_second
+#else
+   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
+#endif
+
+
+END SUBROUTINE tc_compute_si_start
+
+!-----------------------------------------------------------------------
+SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max,current_date_char, &
+                             latc_loc, lonc_loc,vmax,rmax,rankine_lid,si_inpname)
+
+   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
+
+!These values are in the name list and are avaiable from
+!from the config_flags.
+   real    :: vmax(max_bogus),vmax_ratio,rankine_lid
+   real    :: rmax(max_bogus),stand_lon,cen_lat,ptop_in_pa
+   real    :: latc_loc(max_bogus),lonc_loc(max_bogus)
+
+   INTEGER :: ijds , ijde , spec_bdy_width
+   INTEGER :: i , j , k , idts,map_proj,remove_only,storms
+
+   INTEGER :: id1 , interval_seconds , ierr, rc, sst_update, grid_fdda
+   INTEGER , SAVE :: id, id2,  id4 
+   CHARACTER (LEN=80) :: tcoutname , bdyname,si_inpname
+   CHARACTER(LEN= 4) :: loop_char
+   CHARACTER(LEN=19) ::  current_date_char
+   
+character *19 :: temp19
+character *24 :: temp24 , temp24b
+
+real::t1,t2,truelat1,truelat2
+
+
+   !  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)
+   truelat1  = config_flags%truelat1
+   truelat2  = config_flags%truelat2
+
+   stand_lon = config_flags%stand_lon
+   cen_lat   = config_flags%cen_lat
+   map_proj  = config_flags%map_proj
+
+   vmax_ratio = config_flags%vmax_ratio
+   ptop_in_pa = config_flags%p_top_requested
+   remove_only = 0
+   if(config_flags%remove_storm) then
+      remove_only = 1
+   end if
+
+   storms = config_flags%num_storm
+   print *,"number of storms ",config_flags%num_storm
+   call tc_bogus(cen_lat,stand_lon,map_proj,truelat1,truelat2, &
+                 grid%dx,grid%e_we,grid%e_sn,grid%num_metgrid_levels,ptop_in_pa, &
+                 rankine_lid,latc_loc,lonc_loc,vmax,vmax_ratio,rmax,remove_only, &
+                 storms,grid)
+
+
+
+   !  Open the tc bogused output file. cd 
+   CALL construct_filename4a( tcoutname , config_flags%auxinput1_outname , grid%id , 2 , &
+                                    current_date_char , config_flags%io_form_auxinput1 )
+
+   print *,"outfile name from construct filename ",tcoutname
+   CALL open_w_dataset ( id1, TRIM(tcoutname) , grid , config_flags ,output_auxinput1,"DATASET=AUXINPUT1",ierr )
+   IF ( ierr .NE. 0 ) THEN
+        CALL wrf_error_fatal( 'tc_em: error opening tc bogus file for writing' )
+   END IF
+   CALL output_auxinput1( id1, grid , config_flags , ierr )
+   CALL close_dataset ( id1 , config_flags , "DATASET=AUXINPUT1" )
+
+
+END SUBROUTINE assemble_output
+
+!----------------------------------------------------------------------------------------------
+
+SUBROUTINE tc_bogus(centerlat,stdlon,nproj,truelat1,truelat2,dsm,ew,ns,nz,ptop_in_pa, &
+                    rankine_lid,latc_loc,lonc_loc,vmax,vmax_ratio,rmax,remove_only, &
+                    storms,grid)
+
+!!Original Author Dave Gill.  Modified by Sherrie Fredrick      
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!These are read in from the netcdf file.
+!centerlat  The center latitude from the global attributes in the netcdf file.
+!stdlon     The center longitude from the global attributes in the netcdf file.  
+!nproj      The map projection from the global attributes in the netcdf file.
+!dsm        The spacing in meters from the global attributes in the netcdf file.
+!ew         The west_east_stag from the dimensions in the netcdf file..
+!ns         The south_north_stag from the dimensions in the netcdf file. .
+!nz         The number of metgrid levels from the dimensions in the netcdf file.
+
+!ptop_in_pa This is part of the namelist.input file under the &domains section.
+
+!These values are part of the namelist.input file under the &tc section specifically
+!for the tc bogus code.
+!NOTES: There can be up to five bogus storms.  The variable max_bogus is set in
+!the WRF subroutine called module_driver_constants.F in the ./WRFV3/frame directory.
+
+!latc_loc    The center latitude of the bogus strorm. This is an array dimensioned max_bogus.
+  
+!lonc_loc    The center longitude of the bogus strorm. This is an array dimensioned max_bogus.
+  
+!vmax        The max vortex in meters/second it comes from the namelist entry.
+!             This is an array dimensioned max_bogus.
+
+!vmax_ratio  This comes from the namelist entry.
+
+!rmax        The maximum radius this comes from the namelist entry.
+!             This is an array dimensioned max_bogus
+
+!remove_only If this is set to true in the namelist.input file a value of 0.1
+!             is automatically assigned to vmax. 
+
+!rankine_lid This comes from the namelist entry.  It can be used to determine
+!            what model levels the bogus storm affects.
+
+!storms      The number of bogus storms. 
+
+!grid        This is a Fortran structure which holds all of the field data values
+!            for the netcdf that was read in.  
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+!module_llxy resides in the share directory.
+  USE module_llxy
+!This is for the large structure (grid)
+  USE module_domain
+
+
+
+  IMPLICIT NONE 
+  TYPE(domain)                 :: grid
+  integer ew,ns,nz
+  integer nproj
+  integer storms,nstrm
+  real :: centerlat,stdlon,conef,truelat1,truelat2,dsm,dx,rankine_lid
+  real :: latc_loc(max_bogus),lonc_loc(max_bogus),vmax(max_bogus),vmax_ratio,rmax(max_bogus)
+  
+  real :: press(ew-1,nz,ns-1),rhmx(nz), vwgt(nz),old_slp(ew-1,ns-1)
+  real, dimension(:,:,:) , allocatable :: u11,v11,t11,rh11,phi11
+  real, dimension(:,:,:) , allocatable :: u1 , v1 , t1 , rh1 , phi1
+  real, dimension(ew-1,ns-1) :: lond,terrain,cor,pslx
+
+
+!The map scale factors. 
+  real, dimension(ew,ns-1)    :: msfu   !The mapscale factor for the ew wind staggered grid
+  real, dimension(ew-1,ns)    :: msfv   !The mapscale factor for the ns wind staggered grid
+  real, dimension(ew-1,ns-1)  :: msfm   !The mapscale factor for the unstaggered grid.
+
+  CHARACTER*2  jproj
+  LOGICAL :: l_tcbogus
+
+
+  real :: r_search,r_vor,beta,devps,humidity_max
+  real :: devpc,const,r_vor2,cnst,alphar,epsilon,vormx , rad , sum_q 
+  real :: avg_q ,q_old,ror,q_new,dph,dphx0
+  real :: rh_max,min_RH_value,ps
+  integer :: vert_variation
+  integer :: i,k,j,kx,remove_only
+  integer :: k00,kfrm ,kto ,k85,n_iter,ew_mvc,ns_mvc,nct,itr
+  integer :: strmci(nz), strmcj(nz)
+  real :: disx,disy,alpha,degran,pie,rovcp,cp
+  REAL :: rho,pprm,phip0,x0,y0,vmx,xico,xjco,xicn,xjcn,p85,xlo,rconst,ew_gcntr,ns_gcntr
+  real :: ptop_in_pa,themax,themin
+  real :: latinc,loninc
+  real :: rtemp,colat0,colat
+  REAL :: q1(ew-1,nz,ns-1), psi1(ew-1,nz,ns-1) 
+
+! This is the entire map projection enchilada.
+  TYPE(proj_info) :: proj
+
+  
+
+  REAL :: lat1 , lon1
+! These values are read in from the data set. 
+   real :: knowni,knownj
+
+!  TC bogus
+   REAL utcr(ew,nz,ns-1),  vtcr(ew-1,nz,ns)
+   REAL utcp(ew,nz,ns-1),  vtcp(ew-1,nz,ns)
+   REAL psitc(ew-1,nz,ns-1), psiv(nz)
+   REAL vortc(ew-1,nz,ns-1), vorv(nz)
+   REAL tptc(ew-1,nz,ns-1)
+   REAL phiptc(ew-1,nz,ns-1)
+
+!  Work arrays
+   REAL uuwork(nz), vvwork(nz), temp2(ew,ns)
+   REAL vort(ew-1,nz,ns-1), div(ew-1,nz,ns-1)
+   REAL vortsv(ew-1,nz,ns-1)
+   REAL theta(ew-1,nz,ns-1), t_reduce(ew-1,nz,ns-1)
+   REAL ug(ew,nz,ns-1),   vg(ew-1,nz,ns),  vorg(ew-1,nz,ns-1)
+   REAL delpx(ew-1,ns-1)
+
+!subroutines for relaxation
+   REAL outold(ew-1,ns-1)
+   REAL rd(ew-1,ns-1),     ff(ew-1,ns-1)
+   REAL tmp1(ew-1,ns-1),   tmp2(ew-1,ns-1) 
+
+!  Background fields.
+   REAL , DIMENSION (ew-1,nz,ns-1) :: t0, t00, rh0, q0, phi0, psi0, chi
+
+!  Perturbations
+   REAL , DIMENSION (ew-1,nz,ns-1) :: psipos, tpos, psi ,phipos, phip
+      
+!  Final fields.
+   REAL  u2(ew,nz,ns-1),  v2(ew-1,nz,ns)                         
+   REAL  t2(ew-1,nz,ns-1),z2(ew-1,nz,ns-1)                      
+   REAL  phi2(ew-1,nz,ns-1),rh2(ew-1,nz,ns-1)
+      
+   print *,"the dimensions: north-south = ",ns," east-west =",ew
+   IF (nproj .EQ. 1) THEN
+        jproj = 'LC'
+        print *,"Lambert Conformal projection"
+   ELSE IF (nproj .EQ. 2) THEN
+        jproj = 'ST'
+   ELSE IF (nproj .EQ. 3) THEN
+        jproj = 'ME'
+        print *,"A mercator projection"
+   END IF
+
+
+  knowni = 1.
+  knownj = 1.
+  pie     = 3.141592653589793
+  degran = pie/180.
+  rconst = 287.04
+  min_RH_value = 5.0
+  cp = 1004.0
+  rovcp = rconst/cp
+   
+   r_search = 400000.0
+   r_vor = 300000.0
+   r_vor2 = r_vor * 4
+   beta = 0.5
+   devpc= 40.0
+   vert_variation = 1   
+   humidity_max   = 95.0 
+   alphar         = 1.8
+   latinc        = -999.
+   loninc        = -999.
+
+   if(remove_only .eq. 1) then
+     do nstrm=1,storms
+         vmax(nstrm) = 0.1
+     end do
+   end if
+
+  !  Set up initializations for map projection so that the lat/lon
+  !  of the tropical storm can be put into model (i,j) space.  This needs to be done once per 
+  !  map projection definition.  Since this is the domain that we are "GOING TO", it is a once
+  !  per regridder requirement.  If the user somehow ends up calling this routine for several
+  !  time periods, there is no problemos, just a bit of overhead with redundant calls.
+   
+   dx = dsm
+   lat1 = grid%xlat_gc(1,1)
+   lon1 = grid%xlong_gc(1,1)
+   IF( jproj .EQ. 'ME' )THEN
+       IF ( lon1  .LT. -180. ) lon1  = lon1  + 360.
+       IF ( lon1  .GT.  180. ) lon1  = lon1  - 360.
+       IF ( stdlon .LT. -180. ) stdlon = stdlon + 360.
+       IF ( stdlon .GT.  180. ) stdlon = stdlon - 360.
+       CALL map_set ( proj_merc, proj, lat1, lon1, lat1, lon1, knowni, knownj, dx, &
+                      latinc,loninc,stdlon , truelat1 , truelat2)
+       conef = 0.
+   ELSE IF ( jproj .EQ. 'LC' ) THEN
+        if((truelat1 .eq. 0.0)  .and. (truelat2 .eq. 0.0)) then
+            print *,"Truelat1 and Truelat2 are both 0"
+            stop
+         end if
+        CALL map_set (proj_lc,proj, lat1, lon1, lat1, lon1, knowni, knownj, dx, &
+                       latinc,loninc,stdlon , truelat1 , truelat2)
+       conef = proj%cone
+   ELSE IF ( jproj .EQ. 'ST' ) THEN
+        conef = 1.
+        CALL map_set ( proj_ps,proj,lat1, lon1, lat1, lon1, knowni, knownj, dx, &
+                      latinc,loninc,stdlon , truelat1 , truelat2)
+   END IF
+
+! Load the pressure array.   
+ kx = nz
+ do j = 1,ns-1
+    do k = 1,nz
+       do i = 1,ew-1
+           press(i,k,j) = grid%p_gc(i,k,j)*0.01
+       end do
+    end do
+ end do
+
+
+!  Initialize the vertical profiles for humidity and weighting.
+!The ptop variable will be read in from the namelist
+   IF ( ( ptop_in_pa .EQ. 40000. ) .OR. ( ptop_in_pa .EQ. 60000. ) ) THEN
+         PRINT '(A)','Hold on pardner, your value for PTOP is gonna cause problems for the TC bogus option.'
+         PRINT '(A)','Make it higher up than 400 mb.'
+         STOP 'ptop_woes_for_tc_bogus'
+   END IF
+
+ IF ( vert_variation .EQ. 1 ) THEN
+    DO k=1,kx
+       IF ( press(1,k,1) .GT. 400. ) THEN
+               rhmx(k) = humidity_max
+       ELSE
+               rhmx(k) = humidity_max * MAX( 0.1 , (press(1,k,1) - ptop_in_pa/100.)/(400.-ptop_in_pa/100.) )
+       END IF
+
+        IF ( press(1,k,1) .GT. 600. ) THEN
+             vwgt(k) = 1.0
+        ELSE IF ( press(1,k,1) .LE. 100. ) THEN
+             vwgt(k) = 0.0001
+        ELSE
+             vwgt(k) = MAX ( 0.0001 , (press(1,k,1)-ptop_in_pa/100.)/(600.-ptop_in_pa/100.) )
+        END IF
+      END DO
+
+ ELSE IF ( vert_variation .EQ. 2 ) THEN
+         IF ( kx .eq. 24 ) THEN
+            rhmx = (/ 95.,       95., 95., 95., 95., 95., 95., 95.,      &
+                      95., 95.,  95., 95., 95., 90., 85., 80., 75.,      &
+                      70., 66.,  60., 39., 10., 10., 10./)
+            vwgt = (/ 1.0000,         1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 1.0000, 0.9850,      &
+                      0.9680, 0.9500, 0.9290, 0.9060, 0.8810, 0.8500, 0.7580, 0.6500, 0.5100,      &
+                      0.3500, 0.2120, 0.0500, 0.0270, 0.0001, 0.0001, 0.0001/)
+         ELSE
+            PRINT '(A)','Number of vertical levels assumed to be 24 for AFWA TC bogus option'
+            STOP 'AFWA_TC_BOGUS_LEVEL_ERROR'
+         END IF
+ END IF
+
+!Remember that ns = the north south staggered. This is one more than the ns mass point grid.
+!              ew = the east west staggered. This is one more than the ew mass point grid.
+
+
+!Put the U and V into the new arrays.
+!Remember that the WRF ordering is ew,vert level,ns
+!Vorticity and Divergence calculatins are done on 
+!the staggered grids so the winds are not destaggered
+ allocate(u11 (1:ew, 1:nz, 1:ns-1))
+ allocate(u1  (1:ew, 1:nz, 1:ns-1))      
+ allocate(v11 (1:ew-1, 1:nz, 1:ns))
+ allocate(v1  (1:ew-1, 1:nz, 1:ns))
+ do j = 1,ns-1
+    do k = 1,nz
+       do i = 1,ew
+            u11(i,k,j) = grid%u_gc(i,k,j)
+             u1(i,k,j) = grid%u_gc(i,k,j)
+             msfu(i,j) = grid%msfu(i,j) !map scale factor on the U staggered grid
+       end do
+    end do
+ end do
+
+
+ do j = 1,ns
+    do k = 1,nz
+       do i = 1,ew-1
+            v11(i,k,j) = grid%v_gc(i,k,j)
+             v1(i,k,j) = grid%v_gc(i,k,j)
+           msfv(i,j)   = grid%msfv(i,j)  !map scale factor on the V staggered grid    
+       end do
+    end do
+ end do
+
+
+!Put the temperature, relative humidity and height fields
+!into arrays.  Save the initial fields also.
+!These arrays are on the WRF mass points
+ allocate(t11  (1:ew-1, 1:nz, 1:ns-1))
+ allocate(t1   (1:ew-1, 1:nz, 1:ns-1))
+ allocate(rh11 (1:ew-1, 1:nz, 1:ns-1))
+ allocate(rh1  (1:ew-1, 1:nz, 1:ns-1))
+ allocate(phi11(1:ew-1, 1:nz, 1:ns-1))
+ allocate(phi1 (1:ew-1, 1:nz, 1:ns-1))
+ do j = 1,ns-1
+    do k = 1,nz
+       do i = 1,ew-1
+             t11(i,k,j)  =  grid%t_gc(i,k,j)
+              t1(i,k,j)  =  grid%t_gc(i,k,j)
+            rh11(i,k,j)  =  grid%rh_gc(i,k,j)
+             rh1(i,k,j)  =  grid%rh_gc(i,k,j)
+              msfm(i,j)  = grid%msft(i,j)
+            if(k .eq. 1)then
+               phi11(i,k,j) =  grid%ht_gc(i,j)
+               phi1(i,k,j)  =  grid%ht_gc(i,j) * 9.81
+            else
+               phi11(i,k,j) =  grid%ght_gc(i,k,j)
+               phi1(i,k,j)  =  grid%ght_gc(i,k,j) * 9.81 
+            end if
+       end do
+    end do
+ end do
+
+!The two D fields
+!The terrain soil height is from ght at level 1
+ do j = 1,ns-1
+    do i = 1,ew-1
+       pslx(i,j)    = grid%pslv_gc(i,j) * 0.01
+       cor(i,j)     = grid%f(i,j)               !coreolous
+       lond(i,j)    = grid%xlong_gc(i,j)
+       terrain(i,j) = grid%ht_gc(i,j)
+       old_slp(i,j) = grid%pslv_gc(i,j)
+    end do
+ end do
+
+
+
+!  Loop over the number of storms to process.
+   
+ l_tcbogus = .FALSE.
+ all_storms : DO nstrm=1,storms
+
+
+!Make sure the user has defined the rmax variable
+ if(rmax(nstrm) .eq. -999.) then
+    print *,"Please enter a value for rmax in the namelist"
+    stop
+ end if
+
+
+ k00  = 2
+ kfrm = k00
+ p85  = 850.
+
+ kto  = kfrm
+ DO k=kfrm+1,kx
+     IF ( press(1,k,1) .GE. p85 ) THEN
+           kto = kto + 1
+     END IF
+ END DO
+ k85 = kto 
+
+
+!  Parameters for max wind
+ rho  = 1.2
+ pprm = devpc*100.
+ phip0= pprm/rho 
+
+
+!latc_loc and lonc_loc come in from the namelist. 
+!These x0 and y0 points are relative to the mass points. 
+ CALL latlon_to_ij ( proj , latc_loc(nstrm) , lonc_loc(nstrm) , x0 , y0 )
+ IF ( ( x0 .LT. 1. ) .OR. ( x0 .GT. REAL(ew-1) ) .OR. &
+              ( y0 .LT. 1. ) .OR. ( y0 .GT. REAL(ns-1) ) ) THEN
+         PRINT '(A,I3,A,A,A)','         Storm position is outside the computational domain.'
+         PRINT '(A,2F6.2,A)' ,'         Storm postion: (x,y) = ',x0,y0,'.'
+         stop
+ END IF
+
+ l_tcbogus = .TRUE.
+!  Bogus vortex specifications, vmax (m/s); rmax (m);
+ vmx = vmax(nstrm)  * vmax_ratio
+
+ IF (  latc_loc(nstrm) .LT. 0.  ) THEN
+       vmx = -vmx
+ END IF
+   
+ IF (  vmax(nstrm)  .LE. 0.  ) THEN
+       vmx = SQRT( 2.*(1-beta)*ABS(phip0) )  
+ END IF
+
+ ew_gcntr    = x0  !ew center grid location
+ ns_gcntr    = y0  !ns center grid location
+!For right now we are adding 0.5 to the grid location this
+!makes the output of the wrf tc_bogus scheme analogous to the
+!ouput of the MM5 tc_bogus scheme.
+ ew_gcntr    = x0 + 0.5
+ ns_gcntr    = y0 + 0.5
+
+ n_iter  = 1
+
+!  Start computing.
+
+ PRINT '(/,A,I3,A,A,A)'     ,'---> TC: Processing storm number= ',nstrm
+ PRINT '(A,F6.2,A,F7.2,A)'  ,'         Storm center lat= ',latc_loc(nstrm),' lon= ',lonc_loc(nstrm),'.'
+ PRINT '(A,2F6.2,A)'        ,'         Storm center grid position (x,y)= ',ew_gcntr,ns_gcntr,'.'
+ PRINT '(A,F5.2,F9.2,A)'    ,'         Storm max wind (m/s) and max radius (m)= ',vmx,rmax(nstrm),'.'
+ PRINT '(A,F5.2,A)'         ,'         Estimated central press dev (mb)= ',devpc,'.'
+
+
+!  Initialize storm center to (1,1)
+
+  DO k=1,kx
+     strmci(k) = 1
+     strmcj(k) = 1
+  END DO
+ 
+!  Define complete field of bogus storm
+!Note dx is spacing in meters.  
+!The output arrays from the rankine subroutine vvwork,uuwork,psiv and vorv
+!are defined on the WRF mass points.
+  utcp(:,:,:) = 0.0
+  vtcp(:,:,:) = 0.0
+  print *,"nstrm  ",rmax(nstrm),ew_gcntr,ns_gcntr
+  DO j=1,ns-1
+     DO i=1,ew-1
+        disx = REAL(i) - ew_gcntr 
+        disy = REAL(j) - ns_gcntr 
+        CALL rankine(disx,disy,dx,kx,vwgt,rmax(nstrm),vmx,uuwork,vvwork,psiv,vorv)
+        DO k=1,kx
+            utcp(i,k,j) = uuwork(k)
+            vtcp(i,k,j) = vvwork(k)
+           psitc(i,k,j) = psiv(k)
+           vortc(i,k,j) = vorv(k)
+        END DO
+     END DO
+  END DO
+  call stagger_rankine_winds(utcp,vtcp,ew,ns,nz)
+
+
+  utcr(:,:,:) = 0.0
+  vtcr(:,:,:) = 0.0
+! dave Rotate wind to map proj, on the correct staggering
+  DO j=1,ns-1
+     DO i=2,ew-1
+        xlo = stdlon-grid%xlong_u(i,j)
+        IF ( xlo .GT. 180.)xlo = xlo-360.
+        IF ( xlo .LT.-180.)xlo = xlo+360.
+   
+        alpha = xlo*conef*degran*SIGN(1.,centerlat)
+        DO k=1,kx
+           utcr(i,k,j) = (vtcp(i-1,k,j)+vtcp(i,k,j)+vtcp(i,k,j+1)+vtcp(i-1,k,j+1))/4 *SIN(alpha)+utcp(i,k,j)*COS(alpha)
+           if(utcr(i,k,j) .gt. 300.) then
+              print *,i,k,j,"a very bad value of utcr"
+              stop
+           end if           
+        END DO
+     END DO
+  END DO
+
+
+  DO j=2,ns-1
+     DO i=1,ew-1
+        xlo = stdlon-grid%xlong_v(i,j)
+        IF ( xlo .GT. 180.)xlo = xlo-360.
+        IF ( xlo .LT.-180.)xlo = xlo+360.
+   
+        alpha = xlo*conef*degran*SIGN(1.,centerlat)
+        DO k=1,kx
+           vtcr(i,k,j) = vtcp(i,k,j)*COS(alpha)-(utcp(i,k,j-1)+utcp(i+1,k,j-1)+utcp(i+1,k,j)+utcp(i,k,j))/4*SIN(alpha)
+           if(vtcr(i,k,j) .gt. 300.) then
+              print *,i,k,j,"a very bad value of vtcr"
+              stop
+           end if
+        END DO
+     END DO
+  END DO
+
+
+!Fill in UTCR's along the left and right side.
+  do j = 1,ns-1
+     utcr(1,:,j)  = utcr(2,:,j)
+     utcr(ew,:,j) = utcr(ew-1,:,j)
+ end do
+
+!Fill in V's along the bottom and top.   
+  do i = 1,ew-1
+     vtcr(i,:,1)  = vtcr(i,:,2)
+     vtcr(i,:,ns) = vtcr(i,:,ns-1)
+  end do
+
+  
+!  Compute vorticity of FG.  This is the vorticity of the original winds
+!  on the staggered grid.  The vorticity and divergence are defined at
+!  the mass points when done.
+   CALL vor(u1,v1,msfu,msfv,msfm,ew,ns,kx,dx,vort)
+
+
+!  Compute divergence of FG
+   CALL diverg(u1,v1,msfu,msfv,msfm,ew,ns,kx,dx,div)
+
+
+!  Compute mixing ratio of FG
+   CALL mxratprs(rh1,t1,press*100.,ew,ns,kx,q1,min_RH_value)
+   q1(:,1,:) = q1(:,2,:)
+
+
+!  Compute initial streamfunction - PSI1 
+   vortsv = vort
+   q0 = q1
+   
+
+!  Solve for streamfunction.
+   DO k=1,kx 
+      DO j=1,ns-1
+         DO i=1,ew-1
+            ff(i,j) = vort(i,k,j)
+            tmp1(i,j)= 0.0
+         END DO
+      END DO
+      epsilon = 1.E-2
+      CALL relax(tmp1,ff,rd,ew,ns,dx,epsilon,alphar)
+      DO j=1,ns-1
+         DO i=1,ew-1
+            psi1(i,k,j) = tmp1(i,j)
+         END DO
+      END DO
+   END DO
+
+   
+   DO k=1,kx  !start of the k loop
+      IF ( latc_loc(nstrm) .GE. 0. ) THEN
+           vormx = -1.e10
+      ELSE
+           vormx =  1.e10
+      END IF
+   
+      ew_mvc = 1
+      ns_mvc = 1
+
+      DO j=1,ns-1
+         DO i=1,ew-1
+            rad = SQRT((REAL(i)-ew_gcntr)**2.+(REAL(j)-ns_gcntr)**2.)*dx
+            IF ( rad .LE. r_search ) THEN
+               IF ( latc_loc(nstrm) .GE. 0. ) THEN
+                   IF ( vortsv(i,k,j) .GT. vormx ) THEN
+                        vormx = vortsv(i,k,j)
+                        ew_mvc = i
+                        ns_mvc = j
+                    END IF
+               ELSE IF (latc_loc(nstrm) .LT. 0. ) THEN
+                    IF ( vortsv(i,k,j) .LT. vormx ) THEN
+                         vormx = vortsv(i,k,j)
+                         ew_mvc = i
+                         ns_mvc = j
+                    END IF
+               END IF
+            END IF
+         END DO
+      END DO
+      
+      strmci(k) = ew_mvc 
+      strmcj(k) = ns_mvc
+
+      DO j=1,ns-1
+         DO i=1,ew-1
+            rad = SQRT(REAL((i-ew_mvc)**2.+(j-ns_mvc)**2.))*dx
+            IF ( rad .GT. r_vor ) THEN
+                 vort(i,k,j) = 0.
+                 div(i,k,j)  = 0.
+            END IF
+         END DO
+      END DO   
+
+      DO itr=1,n_iter
+         sum_q = 0.
+         nct = 0
+         DO j=1,ns-1
+            DO i=1,ew-1
+               rad = SQRT(REAL(i-ew_mvc)**2.+REAL(j-ns_mvc)**2.)*dx
+               IF ( (rad .LT. r_vor2).AND.(rad .GE. 0.8*r_vor2) ) THEN
+                     sum_q = sum_q + q0(i,k,j)
+                     nct = nct + 1
+               END IF
+             END DO
+          END DO
+          avg_q = sum_q/MAX(REAL(nct),1.)
+   
+          DO j=1,ns-1
+             DO i=1,ew-1
+                 q_old = q0(i,k,j)
+                 rad = SQRT(REAL(i-ew_mvc)**2.+REAL(j-ns_mvc)**2.)*dx
+                 IF ( rad .LT. r_vor2 ) THEN
+                      ror = rad/r_vor2
+                      q_new = ((1.-ror)*avg_q) + (ror*q_old)
+                      q0(i,k,j) = q_new
+                 END IF
+              END DO
+           END DO
+     END DO !end of itr loop
+ END DO !of the k loop
+
+
+!  Compute divergent wind (chi) at the mass points
+   DO k=1,kx
+      DO j=1,ns-1
+         DO i=1,ew-1
+            ff(i,j) = div(i,k,j)
+            tmp1(i,j)= 0.0
+         END DO
+      END DO
+
+      epsilon = 1.e-2
+      CALL relax(tmp1,ff,rd,ew,ns,dx,epsilon,alphar)
+      DO j=1,ns-1
+         DO i=1,ew-1
+            chi(i,k,j) = tmp1(i,j)
+         END DO
+      END DO
+    END DO !of the k loop for divergent winds 
+
+
+
+!  Compute background streamfunction (PSI0) and perturbation field (PSI)
+!     print *,"perturbation field (PSI) relax three"
+     DO k=1,kx 
+         DO j=1,ns-1
+            DO i=1,ew-1
+               ff(i,j)=vort(i,k,j)
+               tmp1(i,j)=0.0
+            END DO
+         END DO
+         epsilon = 1.e-2
+         CALL relax(tmp1,ff,rd,ew,ns,dx,epsilon,alphar)
+         DO j=1,ns-1
+            DO i=1,ew-1
+               psi(i,k,j)=tmp1(i,j)
+            END DO
+         END DO
+     END DO
+
+
+ !We can now calculate the final wind fields.
+   call final_ew_velocity(u2,u1,chi,psi,utcr,dx,ew,ns,nz)
+   call final_ns_velocity(v2,v1,chi,psi,vtcr,dx,ew,ns,nz)
+
+     DO k=1,kx
+        DO j=1,ns-1
+           DO i=1,ew-1
+              psi0(i,k,j) = psi1(i,k,j)-psi(i,k,j)
+           END DO
+        END DO
+     END DO
+
+     DO k=k00,kx
+        DO j=1,ns-1
+           DO i=1,ew-1
+              psipos(i,k,j)=psi(i,k,j)
+           END DO
+        END DO
+     END DO
+
+
+!  Geostrophic vorticity.
+!We calculate the ug and vg on the wrf U and V staggered grids
+!since this is where the vorticity subroutine expects them.
+
+     CALL geowind(phi1,ew,ns,kx,dx,ug,vg)
+     CALL vor(ug,vg,msfu,msfv,msfm,ew,ns,kx,dx,vorg)
+
+     DO k=1,kx
+        ew_mvc = strmci(k)
+        ns_mvc = strmcj(k)
+
+         DO j=1,ns-1
+           DO i=1,ew-1
+               rad = SQRT(REAL(i-ew_mvc)**2.+REAL(j-ns_mvc)**2.)*dx
+               IF ( rad .GT. r_vor ) THEN
+                    vorg(i,k,j) = 0.
+               END IF
+           END DO
+         END DO
+     END DO
+   
+      DO k=k00,kx
+         DO j=1,ns-1
+            DO i=1,ew-1
+               ff(i,j) = vorg(i,k,j)
+               tmp1(i,j)= 0.0
+            END DO
+         END DO
+         epsilon = 1.e-3
+         CALL relax(tmp1,ff,rd,ew,ns,dx,epsilon,alphar)
+         DO j=1,ns-1
+            DO i=1,ew-1
+               phip(i,k,j) = tmp1(i,j)
+            END DO
+         END DO
+     END DO
+
+
+     !  Background geopotential.
+     DO k=k00,kx
+         DO j=1,ns-1
+            DO i=1,ew-1
+               phi0(i,k,j) = phi1(i,k,j) - phip(i,k,j) 
+            END DO
+         END DO
+     END DO
+
+
+     !  Background temperature
+     DO k=k00,kx 
+        DO j=1,ns-1
+           DO i=1,ew-1
+              IF( k .EQ.  2 ) THEN
+                  tpos(i,k,j) = (-1./rconst)*(phip(i,k+1,j)-phip(i,k,j  ))/LOG(press(i,k+1,j)/press(i,k,j))
+              ELSE IF ( k .EQ. kx ) THEN
+                  tpos(i,k,j) = (-1./rconst)*(phip(i,k  ,j)-phip(i,k-1,j))/LOG(press(i,k,j  )/press(i,k-1,j))
+              ELSE
+                  tpos(i,k,j) = (-1./rconst)*(phip(i,k+1,j)-phip(i,k-1,j))/LOG(press(i,k+1,j)/press(i,k-1,j))
+              END IF
+              t0(i,k,j) = t1(i,k,j)-tpos(i,k,j)
+              t00(i,k,j) = t0(i,k,j)
+              if(t0(i,k,j) .gt. 400) then
+                 print *,"interesting temperature ",t0(i,k,j)," at ",i,j,k
+                 stop
+              end if
+           END DO
+        END DO
+     END DO
+
+     !  New RH.
+     CALL qvtorh (q0,t0,press*100.,k00,ew,ns,kx,rh0,min_RH_value)
+     call final_RH(rh2,rh0,rhmx,strmci,strmcj,rmax(nstrm),ew,ns,nz,k00,dx,ew_gcntr,ns_gcntr,r_vor2)
+
+
+
+     ! adjust T0
+     DO k=k00,kx
+        DO j=1,ns-1
+           DO i=1,ew-1
+              theta(i,k,j) = t1(i,k,j)*(1000./press(i,k,j))**rovcp
+           END DO
+        END DO
+     END DO
+
+
+     ew_mvc = strmci(k00)
+     ns_mvc = strmcj(k00)
+     DO k=kfrm,kto
+        DO j=1,ns-1
+           DO i=1,ew-1
+              rad = SQRT(REAL(i-ew_mvc)**2.+REAL(j-ns_mvc)**2.)*dx
+              IF ( rad .LT. r_vor2 ) THEN
+                  t_reduce(i,k,j) = theta(i,k85,j)-0.03*(press(i,k,j)-press(i,k85,j))
+                  t0(i,k,j) = t00(i,k,j)*(rad/r_vor2) + (((press(i,k,j)/1000.)**rovcp)*t_reduce(i,k,j))*(1.-(rad/r_vor2))
+              END IF
+           END DO
+        END DO
+     END DO
+
+    !  Geopotential perturbation
+    DO k=1,kx
+       DO j=1,ns-1
+          DO i=1,ew-1
+              tmp1(i,j)=psitc(i,k,j)
+          END DO
+       END DO
+       CALL balance(cor,tmp1,ew,ns,dx,outold)
+       DO j=1,ns-1
+          DO i=1,ew-1
+             ff(i,j)=outold(i,j)
+             tmp1(i,j)=0.0
+          END DO
+       END DO
+       epsilon = 1.e-3
+       CALL relax (tmp1,ff,rd,ew,ns,dx,epsilon,alphar)
+       DO j=1,ns-1
+          DO i=1,ew-1
+             phiptc(i,k,j) = tmp1(i,j)
+          END DO
+       END DO
+    END DO     
+
+
+!  New geopotential field.
+   DO j=1,ns-1
+      DO k=1,kx
+         DO i=1,ew-1
+            phi2(i,k,j)  = phi0(i,k,j) + phiptc(i,k,j)
+         END DO
+      END DO
+   END DO
+
+
+   !  New temperature field.
+    DO j=1,ns-1
+       DO k=k00,kx
+          DO i=1,ew-1
+             IF( k .EQ.  2 ) THEN
+                 tptc(i,k,j)=(-1./rconst)*(phiptc(i,k+1,j)-phiptc(i,k,j  ))/LOG(press(i,k+1,j)/press(i,k,j))
+             ELSE IF ( k .EQ. kx ) THEN
+                 tptc(i,k,j)=(-1./rconst)*(phiptc(i,k,j  )-phiptc(i,k-1,j))/LOG(press(i,k,j)/press(i,k-1,j))
+             ELSE
+                 tptc(i,k,j)=(-1./rconst)*(phiptc(i,k+1,j)-phiptc(i,k-1,j))/LOG(press(i,k+1,j)/press(i,k-1,j))
+             END IF
+             t2(i,k,j) = t0(i,k,j) + tptc(i,k,j)
+             if(t2(i,k,j) .gt. 400) then
+                print *,"interesting temperature "
+                print *,t2(i,k,j),i,k,j,tptc(i,k,j)
+                stop
+             end if
+           END DO
+        END DO
+    END DO
+
+
+   !  Sea level pressure change.
+      DO j=1,ns-1
+         DO i=1,ew-1
+            dph = phi2(i,k00,j)-phi1(i,k00,j)
+            delpx(i,j) = rho*dph*0.01
+         END DO
+      END DO
+
+
+    !  New SLP.
+!      print *,"new slp",nstrm
+      DO j=1,ns-1
+         DO i=1,ew-1
+            pslx(i,j) = pslx(i,j)+delpx(i,j) 
+            grid%pslv_gc(i,j) = pslx(i,j) * 100.
+!            print *,pslx(i,j)
+         END DO
+      END DO
+
+  !  Set new geopotential at surface to terrain elevation.
+     DO j=1,ns-1
+        DO i=1,ew-1
+           z2(i,1,j) = terrain(i,j) 
+        END DO
+     END DO
+
+  !  Geopotential back to height.
+
+     DO j=1,ns-1
+        DO k=k00,kx
+           DO i=1,ew-1
+               z2(i,k,j) = phi2(i,k,j)/9.81 
+            END DO
+         END DO
+     END DO
+     
+
+     !  New surface temperature, assuming same theta as from 1000 mb.
+!     print *,"new surface temperature"
+     DO j=1,ns-1
+        DO i=1,ew-1
+           ps = pslx(i,j)
+           t2(i,1,j) = t2(i,k00,j)*((ps/1000.)**rovcp)
+           if(t2(i,1,j) .gt. 400) then
+              print *,"Interesting surface temperature"
+              print *,t2(i,1,j),t2(i,k00,j),ps,i,j
+              stop
+           end if
+        END DO
+     END DO
+
+
+     !  Set surface RH to the value from 1000 mb.
+     DO j=1,ns-1
+        DO i=1,ew-1
+           rh2(i,1,j) = rh2(i,k00,j)
+        END DO
+     END DO
+
+    !  Modification of tropical storm complete.
+    PRINT '(A,I3,A)'       ,'         Bogus storm number ',nstrm,' completed.'
+
+   do j = 1,ns-1
+      do k = 1,nz
+         do i = 1,ew
+            u1(i,k,j) =  u2(i,k,j)
+            grid%u_gc(i,k,j) = u2(i,k,j)
+         end do
+      end do
+   end do
+
+   do j = 1,ns
+      do k = 1,nz
+         do i = 1,ew-1
+            v1(i,k,j)   = v2(i,k,j)
+            grid%v_gc(i,k,j) = v2(i,k,j)
+         end do
+      end do
+   end do
+
+    do j = 1,ns-1
+      do k = 1,nz
+         do i = 1,ew-1  
+            t1(i,k,j)   = t2(i,k,j)
+            grid%t_gc(i,k,j) = t2(i,k,j)
+            rh1(i,k,j)  = rh2(i,k,j)
+            grid%rh_gc(i,k,j)  = rh2(i,k,j)
+            phi1(i,k,j) = phi2(i,k,j)
+            grid%ght_gc(i,k,j) = z2(i,k,j)
+         END DO
+      END DO
+   END DO
+
+
+END DO all_storms
+ deallocate(u11)
+ deallocate(v11)
+ deallocate(t11)
+ deallocate(rh11)
+ deallocate(phi11)
+ deallocate(u1)
+ deallocate(v1)
+ deallocate(t1)
+ deallocate(rh1)
+ deallocate(phi1)
+
+ do j = 1,ns-1
+    do i = 1,ew-1
+       if(grid%ht_gc(i,j) .gt. 1) then
+         grid%p_gc(i,1,j)  = grid%p_gc(i,1,j)  + (pslx(i,j) * 100. - old_slp(i,j))
+         grid%psfc(i,j) = grid%psfc(i,j) + (pslx(i,j) * 100. - old_slp(i,j))
+       else 
+         grid%p_gc(i,1,j)  = pslx(i,j) * 100.
+         grid%psfc(i,j) = pslx(i,j) * 100.
+       end if
+    end do
+ end do
+
+END SUBROUTINE tc_bogus
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+   SUBROUTINE rankine(dx,dy,ds,nlvl,vwgt,rmax,vmax,uu,vv,psi,vor)
+
+   !  Define analytical bogus vortex
+
+      IMPLICIT NONE
+
+      INTEGER nlvl
+      REAL , DIMENSION(nlvl) :: uu, vv, psi, vor
+      REAL , DIMENSION(nlvl) :: vwgt
+      REAL :: dx,dy,ds,rmax,vmax
+ 
+      REAL , PARAMETER :: alpha1= 1.
+      REAL , PARAMETER :: alpha2= -0.75
+      real :: pi
+
+
+      INTEGER :: k
+      REAL :: vr , ang , rr , term1 , bb , term2 , alpha
+
+
+      pi = 3.141592653589793
+      !  Wind component
+
+      DO k=1,nlvl
+         rr = SQRT(dx**2+dy**2)*ds
+         IF ( rr .LT. rmax ) THEN
+            alpha = 1.
+         ELSE IF ( rr .GE. rmax ) THEN
+            alpha = alpha2
+         END IF
+         vr = vmax * (rr/rmax)**(alpha)
+         IF ( dx.GE.0. ) THEN
+            ang = (pi/2.) - ATAN2(dy,MAX(dx,1.e-6))
+            uu(k) = vwgt(k)*(-vr*COS(ang))
+            vv(k) = vwgt(k)*( vr*SIN(ang))
+         ELSE IF ( dx.LT.0. ) THEN
+            ang = ((3.*pi)/2.) + ATAN2(dy,dx)
+            uu(k) = vwgt(k)*(-vr*COS(ang))
+            vv(k) = vwgt(k)*(-vr*SIN(ang))
+         END IF
+      END DO
+
+      !  psi
+      
+      DO k=1,nlvl
+         rr = SQRT(dx**2+dy**2)*ds
+         IF ( rr .LT. rmax ) THEN
+            psi(k) = vwgt(k) * (vmax*rr*rr)/(2.*rmax)
+         ELSE IF ( rr .GE. rmax ) THEN
+            IF (alpha1.EQ.1.0 .AND. alpha2.eq.-1.0) THEN
+               psi(k) = vwgt(k) * vmax*rmax*(0.5+LOG(rr/rmax))
+            ELSE IF (alpha1.EQ.1.0 .AND. alpha2.NE.-1.0) THEN
+               term1 = vmax/(rmax**alpha1)*(rmax**(alpha1+1)/(alpha1+1))
+               bb    = (rr**(alpha2+1)/(alpha2+1))-(rmax**(alpha2+1))/(alpha2+1)
+               term2 = vmax/(rmax**alpha2)*bb
+               psi(k) = vwgt(k) * (term1 + term2)
+            END IF
+         END IF
+      END DO
+
+      ! vort
+
+      DO k=1,nlvl
+         rr = SQRT(dx**2+dy**2)*ds
+         IF ( rr .LT. rmax ) THEN
+            vor(k) = vwgt(k) * (2.*vmax)/rmax
+         ELSE IF ( rr .GE. rmax ) THEN
+            vor(k) = vwgt(k) * ( (vmax/rmax**alpha2)*(rr**(alpha2-1.))*(1.+alpha2) )
+         END IF
+      END DO
+
+   END SUBROUTINE rankine
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+   SUBROUTINE vor(uin,vin,msfu,msfv,msfm,ew,ns,nz,ds,vort)
+
+!Here we assume that the U and V's are still on the WRF staggered grid.
+!The vorticity is then calculated at the mass points on the WRF grid.
+
+
+      IMPLICIT NONE
+
+      INTEGER :: jp1,jm1,ip1,im1,i,j,k
+      INTEGER :: ns, ew, nz, k1
+
+      REAL , DIMENSION(ew,nz,ns-1)   :: uin   !u values on unstaggered U grid
+      REAL , DIMENSION(ew-1,nz,ns)   :: vin   !v values on unstaggered V grid
+      REAL , DIMENSION(ew-1,nz,ns-1) :: vort  !vort is defined on the mass points
+
+      REAL , DIMENSION(ew,ns-1)    :: msfu  !map scale factors on U staggered grid
+      REAL , DIMENSION(ew-1,ns)    :: msfv  !map scale factors on V staggered grid
+      REAL , DIMENSION(ew-1,ns-1)  :: msfm  !map scale factors on unstaggered grid
+
+      real :: u(ew,ns-1),v(ew-1,ns)
+      
+
+      REAL :: ds
+
+      REAL :: dsx,dsy , u1 , u2 , u3 , u4 , v1 , v2 , v3 , v4
+      real :: dudy,dvdx,mm
+
+      
+      vort(:,:,:) = -999.
+      do k = 1,nz
+
+         do j = 1,ns-1
+            do i = 1,ew
+               u(i,j) = uin(i,k,j)
+            end do
+         end do
+
+
+         do j = 1,ns
+            do i = 1,ew-1
+               v(i,j) = vin(i,k,j)
+            end do
+         end do
+
+!Our indicies are from 2 to ns-2 and ew-2.  This is because out
+!map scale factors are not defined for the entire grid.
+         do j = 2,ns-2
+            do i = 2,ew-2
+               mm = msfm(i,j) * msfm(i,j)
+               u1 = u(i  ,j-1)/msfu(i  ,j-1)
+               u2 = u(i+1,j-1)/msfu(i+1,j-1)
+               u3 = u(i+1,j+1)/msfu(i+1,j+1)
+               u4 = u(i  ,j+1)/msfu(i  ,j+1)
+               dudy = mm * (u4 + u3 -(u1 + u2)) /(4*ds)
+
+               v1 = v(i-1,j  )/msfv(i-1,j)
+               v2 = v(i+1,j  )/msfv(i+1,j)
+               v3 = v(i-1 ,j+1)/msfv(i-1,j+1)
+               v4 = v(i+1,j+1)/msfv(i+1,j+1)
+               dvdx = mm * (v4 + v2 - (v1 + v3))/(4*ds)
+
+               vort(i,k,j) = dvdx - dudy
+            end do
+         end do
+!Our vorticity array goes out to ew-1 and ns-1 which is the 
+!mass point grid dimensions.  
+         do i = 2,ew-2
+            vort(i,k,1)    = vort(i,k,2)    !bottom not corners
+            vort(i,k,ns-1) = vort(i,k,ns-2) !top not corners
+         end do
+
+         do j = 1,ns-1
+            vort(ew-1,k,j) = vort(ew-2,k,j) !right side including corners
+            vort(1,k,j)    = vort(2,k,j)    !left side including corners
+         end do
+
+     end do ! this is the k loop end 
+
+   END SUBROUTINE 
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+   SUBROUTINE diverg(uin,vin,msfu,msfv,msfm,ew,ns,nz,ds,div)
+
+   !  Computes divergence on unstaggered grid.  The divergence is calculated
+   !  at the mass points on the WRF grid.
+   !  div = m*m (du/dx + dv/dy)
+
+      IMPLICIT NONE
+
+      INTEGER :: jp1,jm1,ip1,im1,i,j,k
+      INTEGER :: ns, ew, nz, k1
+
+      REAL , DIMENSION(ew,nz,ns-1)   :: uin   !u values on unstaggered U grid
+      REAL , DIMENSION(ew-1,nz,ns)   :: vin   !v values on unstaggered V grid
+      REAL , DIMENSION(ew-1,nz,ns-1) :: div   !divergence is calculate on the mass points
+      REAL , DIMENSION(ew,ns-1)    :: msfu  !map scale factors on U staggered grid
+      REAL , DIMENSION(ew-1,ns)    :: msfv  !map scale factors on V staggered grid
+      REAL , DIMENSION(ew-1,ns-1)  :: msfm  !map scale factors on unstaggered grid
+
+      real :: u(ew,ns-1),v(ew-1,ns)
+      
+
+      REAL :: ds
+
+      REAL :: dsr,u1,u2,v1,v2
+      real :: dudx,dvdy,mm,arg1,arg2
+
+      dsr = 1/ds
+      do k = 1,nz
+
+         do j = 1,ns-1
+            do i = 1,ew
+               u(i,j) = uin(i,k,j)
+            end do
+         end do
+
+
+         do j = 1,ns
+            do i = 1,ew-1
+               v(i,j) = vin(i,k,j)
+            end do
+         end do
+!Our indicies are from 2 to ns-2 and ew-2.  This is because out
+!map scale factors are not defined for the entire grid.
+         do j = 2,ns-2
+            do i = 2,ew-2
+               mm = msfm(i,j) * msfm(i,j)
+               u1 = u(i+1,j)/msfu(i+1,j)
+               u2 = u(i  ,j)/msfu(i  ,j)
+       
+               v1 = v(i,j+1)/msfv(i,j+1)
+               v2 = v(i,j)  /msfv(i,j)
+
+               div(i,k,j) = mm * (u1 - u2 + v1 - v2) * dsr
+            end do
+          end do
+
+!Our divergence array is defined on the mass points. 
+         do i = 2,ew-2
+            div(i,k,1)    = div(i,k,2)    !bottom not corners
+            div(i,k,ns-1) = div(i,k,ns-2) !top not corners
+         end do
+
+         do j = 1,ns-1
+            div(ew-1,k,j) = div(ew-2,k,j) !right side including corners
+            div(1,k,j)    = div(2,k,j)    !left side including corners
+         end do
+
+     end do !end for the k loop
+
+   END SUBROUTINE diverg
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+   SUBROUTINE mxratprs (rh, t, ppa, ew, ns, nz, q, min_RH_value)
+
+      
+      IMPLICIT NONE
+
+      INTEGER   :: i , ew , j , ns , k , nz
+
+
+      REAL      :: min_RH_value
+      REAL      :: ppa(ew-1,nz,ns-1)
+      REAL      :: p( ew-1,nz,ns-1 )
+      REAL      :: q (ew-1,nz,ns-1),rh(ew-1,nz,ns-1),t(ew-1,nz,ns-1)
+
+      REAL      :: es
+      REAL      :: qs
+      REAL      :: cp              = 1004.0
+      REAL      :: svp1,svp2,svp3
+      REAL      :: celkel
+      REAL      :: eps
+      
+
+      !  This function is designed to compute (q) from basic variables
+      !  p (mb), t(K) and rh(0-100%) to give (q) in (kg/kg).
+
+      
+      p = ppa * 0.01
+
+      DO j = 1, ns - 1
+         DO k = 1, nz
+            DO i = 1, ew - 1
+                  rh(i,k,j) = MIN ( MAX ( rh(i,k,j) ,min_RH_value ) , 100. ) 
+            END DO
+        END DO
+     END DO
+
+      svp3   =  29.65
+      svp1   =  0.6112
+      svp2   =  17.67
+      celkel =  273.15
+         eps =  0.622
+
+      DO j = 1, ns-1
+         DO k = 1, nz  
+            DO i = 1,ew-1
+               es = svp1 * 10. * EXP(svp2 * (t(i,k,j) - celkel ) / (t(i,k,j) - svp3 ))
+               qs = eps * es / (p(i,k,j) - es)
+               q(i,k,j) = MAX(0.01 * rh(i,k,j) * qs,0.0)
+            END DO
+         END DO
+      END DO
+
+   END SUBROUTINE mxratprs
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SUBROUTINE mass2_Ustag(field,dim1,dim2,dim3)
+
+   IMPLICIT NONE
+
+   INTEGER :: dim1 , dim2 , dim3
+   REAL , DIMENSION(dim1,dim2,dim3) :: field,dummy
+
+   dummy = 0.0
+   dummy(:,2:dim2-1,:)         = ( field(:,1:dim2-2,:) + &
+                                   field(:,2:dim2-1,:) ) * 0.5
+   dummy(:,1,:)                = field(:,1,:)
+   dummy(:,dim2,:)             = field(:,dim2-1,:)
+
+   field                       =   dummy
+
+END SUBROUTINE mass2_Ustag
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SUBROUTINE mass2_Vstag(field,dim1,dim2,dim3)
+
+   IMPLICIT NONE
+
+   INTEGER :: dim1 , dim2 , dim3
+   REAL , DIMENSION(dim1,dim2,dim3) :: field,dummy
+
+   dummy = 0.0
+   dummy(2:dim1-1,:,:)         = ( field(1:dim1-2,:,:) + &
+                                   field(2:dim1-1,:,:) ) * 0.5
+   dummy(1,:,:)                = field(1,:,:)
+   dummy(dim1,:,:)             = field(dim1-1,:,:)
+
+   field                       =   dummy
+
+END SUBROUTINE mass2_Vstag
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+   SUBROUTINE relax (chi, ff, rd, ew, ns, ds, smallres, alpha)
+
+      IMPLICIT NONE
+
+      INTEGER, PARAMETER    :: mm = 20000
+
+      INTEGER               :: i
+      INTEGER               :: ie
+      INTEGER               :: ew  !ew direction
+      INTEGER               :: iter
+      INTEGER               :: j
+      INTEGER               :: je
+      INTEGER               :: jm
+      INTEGER               :: ns  !ns direction
+      INTEGER               :: mi
+
+      REAL                  :: alpha
+      REAL                  :: alphaov4
+      REAL                  :: chi(ew-1,ns-1)
+      REAL                  :: chimx(ns-1) 
+      REAL                  :: ds
+      REAL                  :: epx
+      REAL                  :: fac
+      REAL                  :: ff(ew-1,ns-1)
+      REAL                  :: rd(ew-1,ns-1)
+      REAL                  :: rdmax(ns-1)
+      REAL                  :: smallres
+
+      LOGICAL               :: converged = .FALSE.
+
+      fac = ds * ds
+      alphaov4 = alpha * 0.25
+
+      ie=ew-2
+      je=ns-2
+
+      DO j = 1, ns-1
+         DO i = 1, ew-1
+            ff(i,j) = fac * ff(i,j)
+            rd(i,j) = 0.0
+         END DO
+      END DO
+
+      iter_loop : DO iter = 1, mm
+         mi = iter
+         chimx = 0.0
+
+
+         DO j = 2, ns-1
+            DO i = 2, ew-1
+               chimx(j) = MAX(ABS(chi(i,j)),chimx(j))
+            END DO
+         END DO
+
+         epx = MAXVAL(chimx) * SMALLRES * 4.0 / alpha
+
+         DO j = 2, ns-2
+            DO i = 2, ew-2
+               rd(i,j) = chi(i,j+1) + chi(i,j-1) + chi(i+1,j) + chi(i-1,j) - 4.0 * chi(i,j) - ff(i,j)
+               chi(i,j) = chi(i,j) + rd(i,j) * alphaov4
+            END DO
+         END DO
+
+         rdmax = 0.0
+
+         DO j = 2, ns-2
+            DO i = 2, ew-2
+               rdmax(j) = MAX(ABS(rd(i,j)),rdmax(j))
+            END DO
+         END DO
+
+
+         IF (MAXVAL(rdmax) .lt. epx) THEN
+            converged = .TRUE.
+            EXIT iter_loop
+         END IF
+
+      END DO iter_loop
+
+      IF (converged ) THEN
+!        PRINT '(A,I5,A)','Relaxation converged in ',mi,' iterations.'
+      ELSE
+         PRINT '(A,I5,A)','Relaxation did not converge in',mm,' iterations.'
+         STOP 'no_converge'
+      END IF
+
+
+      do i = 2,ew-2
+            chi(i,ns-1) = chi(i,ns-2) !top not including corners
+            chi(i,1)    = chi(i,2)    !bottom not including corners
+      end do
+
+      do j = 2,ns-2
+            chi(ew-1,j) = chi(ew-2,j) !right side not including corners
+            chi(1,j)    = chi(2,j)    !left side not including corners
+      end do
+
+ !Fill in the corners 
+      chi(1,1)       = chi(2,1)
+      chi(ew-1,1)    = chi(ew-2,1)
+      chi(1,ns-1)    = chi(2,ns-1)
+      chi(ew-1,ns-1) = chi(ew-2,ns-1)
+
+
+
+   END SUBROUTINE relax
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+   SUBROUTINE geowind(height,ew,ns,nz,ds,ug,vg)
+
+      IMPLICIT NONE
+
+      !     input       height   geopotential on wrf mass grid points
+      !                 ns       wrf staggered V dimension n-s
+      !                 ew       wrf staggered U dimension e-w
+      !                 nz       number of vertical levels
+      !
+      !     output      ug       u component of geo wind on wrf staggered V points
+      !                 vg       v component of geo wind on wrf staggered U points  
+
+      INTEGER :: ew , ns , nz
+      REAL :: ds
+      REAL , DIMENSION(ew-1,nz,ns-1) :: height
+      REAL , DIMENSION(ew,nz,ns-1) :: ug 
+      REAL , DIMENSION(ew-1,nz,ns) :: vg
+
+      REAL :: ds2r , h1 , h2 , h3 , h4, ds4r
+      INTEGER :: i , j , k
+
+      ds4r=1./(4.*ds)
+
+! The height field comes in on the WRF mass points.  
+
+
+
+! ug is the derivative of height in the ns direction  ug = -dheight/dy 
+      ug(:,:,:) = -999.
+      do j=2,ns-2
+         do k=1,nz
+            do i=2,ew-1
+              h1 = height(i,k,j+1)
+              h2 = height(i-1,k,j+1)
+              h3 = height(i  ,k,j-1)
+              h4 = height(i-1,k,j-1)
+              ug(i,k,j) = -( (h1 + h2) - ( h3 + h4) ) * ds4r
+           end do
+        end do
+      end do
+
+       do i = 2,ew-1
+          ug(i,:,1)    = ug(i,:,2)    !bottom not including corner points
+          ug(i,:,ns-1) = ug(i,:,ns-2) !top not including corner points
+       end do
+
+       do j = 2,ns-2
+          ug(1,:,j)  = ug(2,:,j)    !left side 
+          ug(ew,:,j) = ug(ew-1,:,j) !right side 
+       end do  
+     
+       ug(1,:,1)     = ug(2,:,1)         !Lower left hand corner
+       ug(1,:,ns-1)  = ug(2,:,ns-1)      !upper left hand corner 
+       ug(ew,:,1)    = ug(ew-1,:,1)      !Lower right hand corner
+       ug(ew,:,ns-1) = ug(ew-1,:,ns-1)   !upper right hand corner 
+
+
+! ug is the derivative of height in the ns direction  vg = dheight/dx 
+    vg(:,:,:) = -999.
+    DO j=2,ns-1
+       DO k=1,nz
+          DO i=2,ew-2
+              h1 = height(i+1,k,j)
+              h2 = height(i-1,k,j)
+              h3 = height(i+1,k,j-1)
+              h4 = height(i-1,k,j-1)
+              vg(i,k,j) = ( (h1 + h3) - ( h2 + h4) ) * ds4r
+          end do
+       end do
+    end do
+
+    do i = 2,ew-2
+       vg(i,:,1)  = vg(i,:,2)    !bottom not including corner points
+       vg(i,:,ns) = vg(i,:,ns-1) !top not including corner points
+    end do   
+
+    do j = 2,ns-1
+       vg(1,:,j)    = vg(2,:,j)    !left side not including corner points
+       vg(ew-1,:,j) = vg(ew-2,:,j) !right side not including corner points
+   end do  
+      
+   vg(1,:,1)     = vg(2,:,1)        !Lower left hand corner
+   vg(1,:,ns)    = vg(2,:,ns)       !upper left hand corner    
+   vg(ew-1,:,1)  = vg(ew-2,:,1)     !Lower right hand corner
+   vg(ew-1,:,ns) = vg(ew-2,:,ns)    !upper right hand corner 
+   
+
+   END SUBROUTINE geowind
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+   SUBROUTINE balance (f,psi,ew,ns,ds,out)
+
+   !  Calculates the forcing terms in balance equation
+
+   IMPLICIT NONE
+
+      !  f       coriolis force
+      !  psi     stream function
+      !  ew, ns  grid points in east west, north south direction, respectively
+      !  ds      grid distance
+      !  out     output array
+  
+      INTEGER :: ew , ns,nslast,ewlast,ifill
+      REAL , DIMENSION(ew-1,ns-1) :: f,psi,out
+      REAL :: ds
+
+      REAL :: psixx , psiyy , psiy , psix, psixy 
+      REAL :: dssq , ds2 , dssq4,arg1,arg2,arg3,arg4
+
+      INTEGER :: i , j
+
+      dssq  = ds * ds
+      ds2   = ds * 2.
+      dssq4 = ds * ds * 4.
+
+!The forcing terms are calculated on the WRF mass points.
+      out(:,:) = -999.0
+      DO j=2,ns-2
+         DO i=2,ew-2
+            psiyy = ( psi(i,j+1) + psi(i,j-1) - 2.*psi(i,j) ) / dssq
+            psixx = ( psi(i+1,j) + psi(i-1,j) - 2.*psi(i,j) ) / dssq
+            psiy  = ( psi(i,j+1) - psi(i,j-1) ) / ds2
+            psix  = ( psi(i+1,j) - psi(i-1,j) ) / ds2
+            psixy = ( psi(i+1,j+1)+psi(i-1,j-1)-psi(i-1,j+1)-psi(i+1,j-1)) / dssq4
+
+            arg1  = f(i,j)* (psixx+psiyy)
+            arg2  = ( ( f(i,j+1) - f(i,j-1)) / ds2 ) * psiy
+            arg3  = ( ( f(i+1,j) - f(i-1,j)) / ds2 ) * psix
+            arg4  = 2 *(psixy*psixy-psixx*psiyy)
+            out(i,j)= arg1 + arg2  + arg3 - arg4
+         END DO
+      END DO
+
+      do i = 2,ew-2
+            out(i,ns-1) = out(i,ns-2) !top not including corners
+            out(i,1)    = out(i,2)    !bottom not including corners
+      end do
+
+      do j = 2,ns-2
+            out(ew-1,j) = out(ew-2,j) !right side not including corners
+            out(1,j)    = out(2,j)    !left side not including corners
+      end do
+
+ !Fill in the corners 
+      out(1,1)       = out(2,1)
+      out(ew-1,1)    = out(ew-2,1)
+      out(1,ns-1)    = out(2,ns-1)
+      out(ew-1,ns-1) = out(ew-2,ns-1)
+
+   END SUBROUTINE balance
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+   SUBROUTINE qvtorh ( q , t , p , k00, ew , ns , nz , rh, min_RH_value   )
+
+      IMPLICIT NONE
+
+      INTEGER , INTENT(IN) :: ew , ns , nz , k00
+      REAL , INTENT(IN) ,  DIMENSION(ew-1,nz,ns-1) :: q ,t, p
+      REAL , INTENT(OUT) , DIMENSION(ew-1,nz,ns-1) :: rh
+
+      real    min_RH_value
+
+      !  Local variables.
+
+      INTEGER :: i , j , k,fill
+      REAL      :: es
+      REAL      :: qs
+      REAL      :: cp              = 1004.0
+      REAL      :: svp1,svp2,svp3
+      REAL      :: celkel
+      REAL      :: eps
+      svp3   =  29.65
+      svp1   =  0.6112
+      svp2   =  17.67
+      celkel =  273.15
+         eps =  0.622
+
+      DO j = 1 , ns - 1
+         DO k = k00 , nz
+            DO i = 1 , ew -1
+               es = svp1 * 10. * EXP(svp2 * (t(i,k,j) - celkel ) / (t(i,k,j) - svp3 ))
+               qs = eps*es/(0.01*p(i,k,j) - es)
+               rh(i,k,j) = MIN ( 100. , MAX ( 100.*q(i,k,j)/qs , min_RH_value ) )
+            END DO
+         END DO
+      END DO
+
+   END SUBROUTINE qvtorh
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+   SUBROUTINE stagger_rankine_winds(utcp,vtcp,ew,ns,nz)
+
+
+!utcp and vtcp are the output winds of the rankine subroutine
+!The winds are calculated on the mass points of the WRF grid
+!so they need to be staggered out to the WRF staggering. 
+!The utcp is placed on the staggered ew wind grid.
+!The vtcp is placed on the staggered ns wind grid.
+
+!ew is the full grid dimension in the ew direction.
+!ns is the full grid dimension in the ns direction.
+
+!nz is the number of vertical levels.
+
+ INTEGER :: ew, ns, nz, i,k,j
+ REAL utcp(ew,nz,ns-1),  vtcp(ew-1,nz,ns)
+
+!----------------------------------------------------
+!Stagger UTCP
+  DO j=1,ns-1
+     DO i=2,ew-1
+        DO k=1,nz
+           utcp(i,k,j)  = ( utcp(i-1,k,j) + utcp(i,k,j) ) /2
+        end do
+    end do
+  end do
+
+!Fill in U's along the left and right side.
+ do j = 1,ns
+    utcp(1,:,j)  = utcp(2,:,j)
+    utcp(ew,:,j) = utcp(ew-1,:,j)
+ end do
+
+
+!Stagger VTCP
+  DO j=2,ns-1
+     DO i=1,ew-1
+        DO k=1,nz
+           vtcp(i,k,j)  = ( vtcp(i,k,j+1) + vtcp(i,k,j-1) ) /2
+        end do
+    end do
+  end do
+
+!Fill in V's along the bottom and bottom.   
+  do i = 1,ew
+     vtcp(i,:,1)  = vtcp(i,:,2)
+     vtcp(i,:,ns) = vtcp(i,:,ns-1)
+  end do
+
+
+   END SUBROUTINE stagger_rankine_winds
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  subroutine final_ew_velocity(u2,u1,chi,psi,utcr,dx,ew,ns,nz)
+  
+
+  integer :: ew,ns,nz,i,j,k
+  real :: u1(ew,nz,ns-1),utcr(ew,nz,ns-1)
+  real :: psi(ew-1,nz,ns-1),chi(ew-1,nz,ns-1)  
+! input arrays: 
+!       u1 is the original wind coming in from the metgrid file.
+!       utcr is the rankine winds rotated to the map projection put on u WRF staggered grid points.
+
+! psi comes in on the WRF mass points.  psi is the perturbation field
+! calculated from the relaxation of the vorticity.
+
+! chi is the relaxation of the divergent winds on WRF mass points.
+
+
+! ew is the grid dimension of the WRF ew staggered wind
+! ns is the grid dimension of the WRF ns staggered wind
+! nz is the number of vertical levels
+! dx is the grid spacing
+!-------------------------------------------------------------------------------------------
+
+  real :: u2(ew,nz,ns-1)
+! output array u2 is the new wind in the ew direction. Is is on WRF staggering.
+!------------------------------------------------------------------------------------------- 
+  
+  real upos(ew,nz,ns-1),u0(ew,nz,ns-1),uchi(ew,nz,ns-1) 
+! upos is the derivative of psi in the ns direction  u = -dpsi/dy 
+! u0 is the background ew velocity
+! uchi is the array chi on the u staggered grid.
+
+  real    :: dx,arg1,arg2
+
+!-------------------------------------------------------------
+!Take the derivative of chi in the ew direction.
+   uchi(:,:,:) = -999.
+   DO k=1,nz !start of k loop
+      DO j=1,ns-1
+         DO i=2,ew-1
+            uchi(i,k,j) = ( chi(i,k,j) - chi(i-1,k,j) )/dx
+         END DO
+      END DO
+     
+      do j = 1,ns-1
+       uchi(1,k,j)    = uchi(2,k,j)    !fill in the left side
+       uchi(ew,k,j)   = uchi(ew-1,k,j) !fill in the right side  
+      end do
+   end do !k loop
+
+!-----------------------------------------------------------------------------------------
+! Take the derivative of psi in the ns direction.
+    upos = - dpsi/dy
+    upos(:,:,:) = -999.
+    DO k=1,nz
+
+       DO j=2,ns-2
+          DO i=2,ew-1
+              arg1 = psi(i,k,j+1) + psi(i-1,k,j+1)
+              arg2 = psi(i,k,j-1) + psi(i-1,k,j-1)
+              upos(i,k,j) = -( arg1 - arg2 )/(4.*dx)
+          END DO
+       END DO
+
+       do i = 2,ew-1
+          upos(i,k,1)    = upos(i,k,2)    !bottom not including corner points
+          upos(i,k,ns-1) = upos(i,k,ns-2) !top not including corner points
+       end do
+
+       do j = 1,ns-2
+          upos(1,k,j)  = upos(2,k,j)    !left side not including corners
+          upos(ew,k,j) = upos(ew-1,k,j) !right side not including corners
+       end do       
+
+
+       upos(1,k,1)     = upos(2,k,1)         !Lower left hand corner
+       upos(1,k,ns-1)  = upos(2,k,ns-1)      !upper left hand corner 
+       upos(ew,k,1)    = upos(ew-1,k,1)      !Lower right hand corner
+       upos(ew,k,ns-1) = upos(ew-1,k,ns-1)   !upper right hand corner 
+
+    end do  !k loop for dspi/dy
+
+
+
+!-----------------------------------------------------------------------------------------
+
+!  Background u field.
+!  Subtract the first quess wind field from the original winds.
+   do j=1,ns-1
+      do k=1,nz
+         do i=1,ew
+            u0(i,k,j) = u1(i,k,j)-(upos(i,k,j)+uchi(i,k,j))
+         end do
+      end do
+   end do
+   
+
+!   Calculate the final velocity
+    do j=1,ns-1
+       do k=1,nz
+          do i=1,ew
+             u2(i,k,j) = u0(i,k,j)+utcr(i,k,j)
+          end do
+       end do
+    end do
+
+ end subroutine final_ew_velocity
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  subroutine final_ns_velocity(v2,v1,chi,psi,vtcr,dx,ew,ns,nz)
+  
+
+  integer :: ew,ns,nz,i,j,k
+  real :: v1(ew-1,nz,ns),vtcr(ew-1,nz,ns)
+  real :: psi(ew-1,nz,ns-1),chi(ew-1,nz,ns-1)  
+! input arrays: 
+!       v1 is the original wind coming in from the metgrid file.
+!       vtcr is the is the rankine winds rotated to the map projection put on v WRF staggered grid points.
+
+! psi comes on the WRF mass points.  psi is the perturbation field
+! calculated from the relaxation of the vorticity.
+
+! chi is the relaxation of the divergent winds on WRF mass points.
+
+! ew is the grid dimension of the WRF ew staggered wind
+! ns is the grid dimension of the WRF ns staggered wind
+! nz is the number of vertical levels
+
+
+  real :: v2(ew-1,nz,ns)
+! output array v2 is the new wind in the ns direction. Is is on WRF staggering.
+
+  
+  real vpos(ew-1,nz,ns),v0(ew-1,nz,ns),vchi(ew-1,nz,ns)
+! vpos is the derivative of psi in the ew direction  v = dpsi/dx 
+! v0 is the background ns velocity
+! vchi is the relaxation of the divergent wind put on v WRF staggered grid points.
+
+  real    :: dx,arg1,arg2
+
+
+!-----------------------------------------------------------------------------------------
+ vchi(:,:,:) = -999.0
+!The derivative dchi in the ns direction.
+    do k = 1,nz
+       DO j=2,ns-1
+          DO i=1,ew-1
+              vchi(i,k,j) = ( chi(i,k,j) - chi(i,k,j-1))/dx
+          END DO
+       END DO
+
+    do i = 1,ew-1
+       vchi(i,k,1)  = vchi(i,k,2)
+       vchi(i,k,ns) = vchi(i,k,ns-1)
+    end do
+       
+    end do !end of k loop
+
+!-----------------------------------------------------------------------------------------
+!Take the derivative of psi in the ew direction.
+    vpos(:,:,:) = -999.
+
+    DO k=1,nz
+       DO j=2,ns-1
+          DO i=2,ew-2
+              arg1 = psi(i+1,k,j) + psi(i+1,k,j-1)
+              arg2 = psi(i-1,k,j) + psi(i-1,k,j-1)
+              vpos(i,k,j) =  ( arg1 - arg2 )/(4.*dx)
+          END DO
+       END DO
+
+       do i = 2,ew-2
+          vpos(i,k,1)  = vpos(i,k,2)    !bottom not including corner points
+          vpos(i,k,ns) = vpos(i,k,ns-1) !top not including corner points
+      end do   
+
+       do j = 1,ns
+          vpos(1,k,j)    = vpos(2,k,j)    !left side not including corner points
+          vpos(ew-1,k,j) = vpos(ew-2,k,j) !right side not including corner points
+      end do  
+
+
+      vpos(1,k,1)     = vpos(2,k,1)        !Lower left hand corner
+      vpos(1,k,ns)    = vpos(2,k,ns)       !upper left hand corner    
+      vpos(ew-1,k,1)  = vpos(ew-2,k,1)     !Lower right hand corner
+      vpos(ew-1,k,ns) = vpos(ew-2,k,ns)    !upper right hand corner   
+   
+    END DO!k loop for dspi/dx
+    
+
+    do j=1,ns
+       do k=1,nz
+          do i=1,ew-1
+              v0(i,k,j) = v1(i,k,j)-(vpos(i,k,j)+vchi(i,k,j))
+              if( v0(i,k,j) .gt. 100.) then
+                print *,vchi(i,k,j),i,k,j
+                stop
+              end if
+          end do
+       end do
+    end do
+    
+
+!   Calculate the final velocity
+    do j=1,ns
+       do k=1,nz
+          do i=1,ew-1
+             v2(i,k,j) = v0(i,k,j)+vtcr(i,k,j)
+          end do
+       end do
+    end do
+
+    end subroutine final_ns_velocity
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!     
+subroutine final_RH(rh2,rh0,rhmx,strmci,strmcj,rmax_nstrm,ew,ns,nz,k00, &
+                    dx,ew_gcntr,ns_gcntr,r_vor2)
+
+
+
+     integer :: ew,ns,nz
+     real :: rh2(ew-1,nz,ns-1)  !The final output relative humidity.
+     real :: rh0(ew-1,nz,ns-1)  !First quess rh read from the metgrid input file.
+     real :: rhmx(nz)
+     real :: ew_gcntr !ew grid center as returned from the map projection routines.
+     real :: ns_gcntr !ns grid center as returned from the map projection routines.
+     real :: dx       !grid spacing 
+     real :: rmax_nstrm
+
+
+!Local real variables
+     real :: sum_rh,avg_rh,rh_min,rhbkg,rhbog,r_ratio
+     real :: rad
+     real :: rhtc(ew-1,nz,ns-1)
+
+     integer :: nct,k00,i,j,k,ew_mvc,ns_mvc
+     integer :: strmci(nz), strmcj(nz)
+
+
+!-----------------------------------------------------------------------
+     DO k=k00,nz
+        rh_max= rhmx(k)
+        ew_mvc = strmci(k)
+        ns_mvc = strmcj(k)
+   
+
+        sum_rh = 0.
+        nct = 0
+        DO j=1,ns-1
+           DO i=1,ew-1
+              rad = SQRT(REAL(i-ew_mvc)**2.+REAL(j-ns_mvc)**2.)*dx
+              IF ( (rad .LT. r_vor2).AND.(rad .GE. 0.8*r_vor2) ) THEN
+                  sum_rh = sum_rh + rh0(i,k,j)
+                  nct = nct + 1
+              END IF
+           END DO
+        END DO
+        avg_rh = sum_rh/MAX(REAL(nct),1.)
+   
+        DO j=1,ns-1
+            DO i=1,ew-1
+               rh_min = avg_rh 
+               rad = SQRT((REAL(i)-ew_gcntr)**2.+(REAL(j)-ns_gcntr)**2.)*dx
+               IF ( rad .LE. rmax_nstrm ) THEN
+                  rhtc(i,k,j) = rh_max
+               ELSE
+                  rhtc(i,k,j) = (rmax_nstrm/rad)*rh_max+(1.-(rmax_nstrm/rad))*rh_min
+               END IF
+            END DO
+         END DO
+     END DO
+
+
+     !  New RH.
+     DO j=1,ns-1
+        DO k=k00,nz
+           DO i=1,ew-1
+              rhbkg = rh0(i,k,j)
+              rhbog = rhtc(i,k,j)
+              rad = SQRT((REAL(i)-ew_mvc)**2.+(REAL(j)-ns_mvc)**2.)*dx
+               IF ( (rad.GT.rmax_nstrm) .AND. (rad.LE.r_vor2) ) THEN
+                    r_ratio = (rad-rmax_nstrm)/(r_vor2-rmax_nstrm)
+                    rh2(i,k,j) = ((1.-r_ratio)*rhbog) + (r_ratio*rhbkg)
+              ELSE IF (rad .LE. rmax_nstrm ) THEN
+                    rh2(i,k,j) = rhbog
+              ELSE
+                    rh2(i,k,j) = rhbkg
+              END IF
+
+          END DO
+        END DO
+    END DO
+
+ 
+
+    end subroutine final_RH
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 
Index: branches/LMDZ_WRFmeas/WRFV3/main/wrf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/main/wrf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/main/wrf.F	(revision 17)
@@ -0,0 +1,38 @@
+!WRF:DRIVER_LAYER:MAIN
+!
+
+PROGRAM wrf
+
+   USE module_wrf_top, only : wrf_init, wrf_dfi, wrf_run, wrf_finalize
+
+!<DESCRIPTION>
+! 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 <a href=integrate.html>integrate</a> routine to advance the domain
+! to the ending time of the simulation. After the integration is completed, the model
+! is properly shut down.
+!
+!</DESCRIPTION>
+
+   IMPLICIT NONE
+
+#ifdef _OPENMP
+  CALL setfeenv()
+#endif
+
+  ! Set up WRF model.  
+  CALL wrf_init
+
+  ! Run digital filter initialization if requested.
+  CALL wrf_dfi
+
+  ! 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
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/main/wrf_ESMFMod.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/main/wrf_ESMFMod.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/main/wrf_ESMFMod.F	(revision 17)
@@ -0,0 +1,1123 @@
+!WRF:DRIVER_LAYER:MAIN
+!
+
+!<DESCRIPTION>
+! ESMF-specific modules for building WRF as an ESMF component.  
+!
+! This source file is only built when ESMF coupling is used.  
+!
+!</DESCRIPTION>
+
+
+
+MODULE module_metadatautils
+!<DESCRIPTION>
+! This module defines component-independent "model metadata" utilities 
+! used for ESMF coupling.  
+!</DESCRIPTION>
+!TODO:  Upgrade this later to support multiple coupling intervals via Alarms 
+!TODO:  associated with top-level clock.  Do this by adding TimesAttachedToState() 
+!TODO:  inquiry function that will test an ESMF_State to see if the times are 
+!TODO:  present via names defined in this module.  Then call it for every 
+!TODO:  component and resolve conflicts (somehow) for cases where two components 
+!TODO:  define conflicting clocks.  Of course, a component is allowed to not attach 
+!TODO:  times to a state at all, if it can handle any time step.  
+!
+!TODO:  Replace meta-data names with "model metadata" conventions such as CF 
+!TODO:  (once they exist)
+!
+!TODO:  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(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_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_AttributeSet(state, 'ComponentStartTime', timevals, itemCount=SIZE(timevals), rc=rc)
+     IF ( rc /= ESMF_SUCCESS ) THEN
+       CALL wrf_error_fatal ( 'ESMF_AttributeSet(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_AttributeSet(state, 'ComponentStopTime', timevals, itemCount=SIZE(timevals), rc=rc)
+     IF ( rc /= ESMF_SUCCESS ) THEN
+       CALL wrf_error_fatal ( 'ESMF_AttributeSet(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_AttributeSet(state, 'ComponentCouplingInterval', timevals, itemCount=SIZE(timevals), rc=rc)
+     IF ( rc /= ESMF_SUCCESS ) THEN
+       CALL wrf_error_fatal ( 'ESMF_AttributeSet(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, rc )
+     TYPE(ESMF_State),        INTENT(INOUT) :: state
+     TYPE(ESMF_Time),         INTENT(INOUT) :: startTime
+     TYPE(ESMF_Time),         INTENT(INOUT) :: stopTime
+     TYPE(ESMF_TimeInterval), INTENT(INOUT) :: couplingInterval
+     INTEGER, INTENT(INOUT) :: rc
+     ! locals
+     INTEGER :: year, month, day, hour, minute, second
+     INTEGER(ESMF_KIND_I4) :: timevals(6)   ! big enough to hold the vars listed above
+     INTEGER :: thecount  ! 'one attribute ... ah ah ah. TWO attributes!  ah ah ah!!
+     CHARACTER*256 mess
+     ! start time
+     thecount = SIZE(timevals)
+     CALL ESMF_AttributeGet(state, 'ComponentStartTime', timevals, itemCount=thecount, rc=rc)
+     IF ( rc /= ESMF_SUCCESS ) THEN
+!JM return but don't fail; let the caller figure out what to do
+       RETURN
+     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
+     thecount = SIZE(timevals)
+     CALL ESMF_AttributeGet(state, 'ComponentStopTime', timevals, itemCount=thecount, rc=rc)
+     IF ( rc /= ESMF_SUCCESS ) THEN
+!JM return but don't fail; let the caller figure out what to do
+       !CALL wrf_error_fatal ( 'ESMF_AttributeGet(ComponentStopTime) failed' )
+       RETURN
+     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
+     thecount = SIZE(timevals)
+     CALL ESMF_AttributeGet(state, 'ComponentCouplingInterval', timevals, itemCount=thecount, rc=rc)
+     IF ( rc /= ESMF_SUCCESS ) THEN
+!JM return but don't fail; let the caller figure out what to do
+       !CALL wrf_error_fatal ( 'ESMF_AttributeGet(ComponentCouplingInterval) failed' )
+       RETURN
+     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 )
+   USE ESMF_Mod
+     TYPE(ESMF_State),        INTENT(INOUT) :: 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(:)
+     CHARACTER (len=132) :: mess
+
+! Unfortunately, implementing this is unnecessarily difficult due 
+! to lack of 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_StateGet( state, itemName=TRIM(itemNames(i)), &
+                               nestedState=tmpState, rc=rc )
+           IF ( rc /= ESMF_SUCCESS) THEN
+             WRITE(str,*) 'ESMF_StateGet(',TRIM(itemNames(i)),') failed'
+             CALL wrf_error_fatal ( str )
+           ENDIF
+           istate = istate + 1
+           CALL GetTimesFromState( tmpState, startTimes(istate),         &
+                                             stopTimes(istate),          &
+                                             couplingIntervals(istate), rc )
+           IF ( rc /= ESMF_SUCCESS ) THEN
+             istate = istate - 1
+           ENDIF
+         ENDIF
+       ENDDO
+       IF ( istate .EQ. 1 ) THEN
+        ! this presupposes that 1 of the child states exist and has
+        ! valid times in it.  Use that one.
+          CALL write(mess,'WARNING: Only ',TRIM(itemNames(1)), &
+                          ' is valid and has time info in it.  Using that.')
+          CALL wrf_message(mess) 
+          CALL ESMF_StateGet( state, itemName=TRIM(itemNames(1)), &
+                              nestedState=tmpState, rc=rc )
+          CALL GetTimesFromState( tmpState, startTime, stopTime, &
+                                  couplingInterval , rc )
+       ELSE IF ( istate .GT. 1 ) THEN
+          CALL ReconcileTimes( startTimes, stopTimes, couplingIntervals, &
+                               startTime,  stopTime,  couplingInterval )
+       ELSE 
+          CALL wrf_error_fatal('no valid states with times found. giving up.')
+       ENDIF
+     ELSE
+       ! there are no nested ESMF_States so use parent state only
+       CALL GetTimesFromState( state, startTime, stopTime, &
+                               couplingInterval , rc )
+     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(INOUT) :: startTimes(:)
+     TYPE(ESMF_Time),         INTENT(INOUT) :: stopTimes(:)
+     TYPE(ESMF_TimeInterval), INTENT(INOUT) :: 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
+!TODO:  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_message ( 'ReconcileTimes:  inconsistent startTimes. Using first.' )
+           startTimes(i) = startTime
+         ENDIF
+         IF ( stopTimes(i) /= stopTime ) THEN
+           CALL wrf_message ( 'ReconcileTimes:  inconsistent stopTimes. Using first.' )
+           stopTimes(i) = stopTime
+         ENDIF
+         IF ( couplingIntervals(i) /= couplingInterval ) THEN
+           CALL wrf_message ( 'ReconcileTimes:  inconsistent couplingIntervals. Using first.' )
+           couplingIntervals(i) = couplingInterval
+         ENDIF
+       ENDIF
+
+     ENDDO
+
+   END SUBROUTINE ReconcileTimes
+
+
+
+   !TODO:  Eliminate this once this information can be derived via other 
+   !TODO:  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)
+     logical :: logvals(4)
+
+     ! 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 = .FALSE.
+     DO i = 1, SIZE(bdy_mask)
+       IF (bdy_mask(i)) THEN
+         logvals(i) = .TRUE.
+       ENDIF
+     ENDDO
+     CALL ESMF_AttributeSet(state, 'DecompositionLogicals', logvals, itemCount=SIZE(logvals), rc=rc)
+     IF ( rc /= ESMF_SUCCESS) THEN
+       CALL wrf_error_fatal ( 'ESMF_AttributeSet(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_AttributeSet(state, 'DecompositionIntegers', intvals, itemCount=SIZE(intvals), rc=rc)
+     IF ( rc /= ESMF_SUCCESS) THEN
+       CALL wrf_error_fatal ( 'ESMF_AttributeSet(DecompositionIntegers) failed' )
+     ENDIF
+   END SUBROUTINE AttachDecompToState
+
+
+
+   !TODO:  Eliminate this once this information can be derived via other 
+   !TODO:  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(INOUT) :: 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
+     logical :: logvals(4)
+     integer :: thecount ! ah ah ah
+
+     ! first the logicals
+     thecount = SIZE(logvals)
+     CALL ESMF_AttributeGet(state, 'DecompositionLogicals', logvals, itemCount=thecount, rc=rc)
+     IF ( rc /= ESMF_SUCCESS) THEN
+       CALL wrf_error_fatal ( 'ESMF_AttributeGet(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) ) THEN
+         bdy_mask(i) = .TRUE.
+       ENDIF
+     ENDDO
+     ! now the integers
+     thecount = SIZE(intvals)
+     CALL ESMF_AttributeGet(state, 'DecompositionIntegers', intvals, itemCount=thecount, rc=rc)
+     IF ( rc /= ESMF_SUCCESS) THEN
+       CALL wrf_error_fatal ( 'ESMF_AttributeGet(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
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+
+   USE ESMF_Mod
+   USE module_wrf_top, ONLY : wrf_init, wrf_run, wrf_finalize
+   USE module_domain, ONLY : head_grid, get_ijk_from_grid
+   USE module_state_description
+   USE module_streams
+
+   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
+#ifdef DM_PARALLEL
+     TYPE(ESMF_VM) :: vm
+     INTEGER :: mpicomtmp
+#endif
+     INTEGER,                     INTENT(  OUT) :: rc
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+!TODO:  Note that much of the decomposition-related meta-data attached to the 
+!TODO:  exportState are WRF-specific and are only useful if other components 
+!TODO:  want to re-use the WRF IOAPI with the same decomposition as the WRF 
+!TODO:  model.  This is true for the simple WRF+CPL+SST test case, but will 
+!TODO:  not be in general.  Of course other components are free to ignore this 
+!TODO:  information.  
+
+     ! 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 )
+
+#ifdef DM_PARALLEL
+     CALL ESMF_VMGetCurrent(vm, rc=rc)
+     IF ( rc /= ESMF_SUCCESS ) THEN
+       CALL wrf_error_fatal ( 'wrf_component_init1:  ESMF_VMGetCurrent failed' )
+     ENDIF
+     CALL ESMF_VMGet(vm, mpiCommunicator=mpicomtmp, rc=rc)
+     IF ( rc /= ESMF_SUCCESS ) THEN
+       CALL wrf_error_fatal ( 'wrf_component_init1:  ESMF_VMGet failed' )
+     ENDIF
+     CALL wrf_set_dm_communicator( mpicomtmp )
+#endif
+
+     ! Call WRF "init" routine, which, for a DM_PARALLEL run, will recognize 
+     ! that ESMF has already called MPI_INIT and respond appropriately.  
+     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( 500, 'DEBUG wrf_component_init1():  before wrf_findCouplingInterval' )
+     CALL wrf_findCouplingInterval( startTime, stopTime, couplingInterval )
+     CALL wrf_debug( 500, '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 )
+     CALL AttachDecompToState( importState,                  &
+                               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
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+     ! 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 )
+
+     ! populate ESMF import and export states
+     CALL wrf_state_populate( rc )
+     IF ( rc /= 0 ) THEN
+       CALL wrf_error_fatal ( 'wrf_component_init2:  wrf_state_populate 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
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+     ! 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()' )
+
+     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
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+     ! 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
+!<DESCRIPTION>
+!     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
+!</DESCRIPTION>
+     ! locals
+     LOGICAL :: foundcoupling
+     INTEGER :: rc
+     INTEGER :: io_form
+     ! external function prototype
+     INTEGER, EXTERNAL :: use_package
+
+     ! deduce coupling time-step
+     foundcoupling = .FALSE.
+!TODO:  This bit just finds the FIRST case and extracts coupling interval...  
+!TODO:  Add error-checking for over-specification.  
+!TODO:  Add support for multiple coupling intervals later...  
+!TODO:  Add support for coupling that does not begin immediately later...  
+!TODO:  Get rid of duplication once I/O refactoring is finished (and 
+!TODO:  auxio streams can be addressed via index).  
+
+#include "med_find_esmf_coupling.inc"
+
+     ! 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)
+!<DESCRIPTION>
+!     WRF convenience routine for deducing decomposition information.  
+!TODO:  Note that domdesc is meaningful only for SPMD alternating event loops.  
+!TODO:  For concurrent operation (SPMD or MPMD), we will need to create a new 
+!TODO:  "domdesc" suitable for the task layout of the SST component.  For 
+!TODO:  MPMD alternating event loops, we will need to serialize domdesc and 
+!TODO:  store it as metadata within the export state.  Similar arguments apply
+!TODO:  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.  
+!</DESCRIPTION>
+     ! 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  )
+#if 0
+! JM
+! with version 3 of ESMF's staggering concepts, WRF's non-staggered grid is equivalent to 
+! esmf's 'exclusive' region -- that is the set of points that are owned by the 'DE' (eyeroll)
+! WRF, on the other hand, is returning the 'staggered' dimensions here.  So convert to the
+! unstaggered dims before returning.
+! Don't bother with vertical dimension for the time being, since we're only doing 2D coupling.
+!
+     ide = ide-1 ; ipe = MIN(ide,ipe)
+     jde = jde-1 ; jpe = MIN(jde,jpe)
+#else
+! JM
+! with version 4 I have no damned clue at this writing... just random shots for now
+! see if this works.
+     ipe = MIN(ide-1,ipe)
+     jpe = MIN(jde-1,jpe)
+#endif
+
+     domdesc = head_grid%domdesc
+     bdy_mask = head_grid%bdy_mask
+   END SUBROUTINE wrf_getDecompInfo
+
+
+   SUBROUTINE wrf_state_populate( ierr )
+     ! Driver layer
+     USE module_domain, ONLY : domain
+     USE module_io_domain
+     ! Model layer
+     USE module_configure, ONLY : grid_config_rec_type, model_to_grid_config_rec
+     USE module_bc_time_utilities
+
+     IMPLICIT NONE
+
+!<DESCRIPTION>
+!     Populate WRF import and export states from Registry-generated code.  
+!     For now, only head_grid can be coupled.  
+!
+!</DESCRIPTION>
+!TODO:  Extend later to include child 
+!TODO:  domains, possibly via nested ESMF_State's.  
+
+     ! Arguments
+     INTEGER, INTENT(OUT)       :: ierr
+     ! Local
+     TYPE(domain), POINTER      :: grid
+     TYPE(grid_config_rec_type) :: config_flags
+     INTEGER                    :: stream, idum1, idum2, io_form
+     CHARACTER*80               :: fname, n2
+     ! external function prototype
+     INTEGER, EXTERNAL          :: use_package
+
+     ! for now support coupling to head_grid only
+     grid => head_grid
+! TODO:  Use actual grid via current_grid%id via something like this...  
+!  IF ( current_grid_set ) THEN
+!    grid => current_grid
+!  ELSE
+!    ERROR
+!  ENDIF
+
+     CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
+     CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
+
+     stream = 0
+     ierr = 0
+
+#include "med_open_esmf_calls.inc"
+
+   END SUBROUTINE wrf_state_populate
+
+END MODULE module_wrf_component_top
+
+
+
+MODULE module_wrf_setservices
+!<DESCRIPTION>
+! This module defines WRF "Set Services" method wrf_register() 
+! used for ESMF coupling.  
+!</DESCRIPTION>
+
+   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
+!
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+     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
+
Index: branches/LMDZ_WRFmeas/WRFV3/main/wrf_SST_ESMF.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/main/wrf_SST_ESMF.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/main/wrf_SST_ESMF.F	(revision 17)
@@ -0,0 +1,1970 @@
+!WRF:DRIVER_LAYER:MAIN
+!
+
+!<DESCRIPTION>
+! 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.  
+!
+!</DESCRIPTION>
+
+
+
+!<DESCRIPTION>
+! Modules module_sst_component_top and module_sst_setservices define the 
+! "SST" dummy component.  
+!</DESCRIPTION>
+
+MODULE module_sst_component_top
+!<DESCRIPTION>
+! 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.  
+!</DESCRIPTION>
+
+   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
+   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(:,:)
+   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
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+#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
+
+!TODO:  For now, sstinfilename is hard-coded
+!TODO:  Upgrade to use a variant of construct_filename() via startTime 
+!TODO:  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
+!TODO:  use CF conventions for "standard_name" once WRF Registry supports them
+!TODO:      datanames(SST_INDX) = "sea_surface_temperature"
+!TODO:      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
+!<DESCRIPTION>
+!     Reads data from file and stores.  Then 
+!     stuffs the file data into the SST exportState.  
+!</DESCRIPTION>
+
+     #include <wrf_status_codes.h>
+     #include <wrf_io_flags.h>
+
+     ! 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
+#if 1
+              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 , &
+#else
+!jm the dimensions have already been reduced to the non-staggered WRF grid when
+!   they were stored in this module..  Just use as is.
+              ids , ide , jds , jde , 1 , 1 , &
+              ims , ime , jms , jme , 1 , 1         , &
+              ips , ipe , jps , jpe , 1 , 1 , &
+#endif
+              ierr )
+       IF (ierr /= 0) THEN
+         CALL wrf_error_fatal ( TRIM(errormsg) )
+       ENDIF
+     ENDDO
+
+     ! stuff fields into exportState
+!TODO:  change this to Bundles, eventually
+     CALL ESMF_StateGet( 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_StateGet( 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 )
+     CALL ESMF_FieldGet( out_sst_field, 0, 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 )
+     CALL ESMF_FieldGet( out_landmask_field, 0, 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 , jpe
+       DO i= ips , 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
+!TODO:  remove clock after debugging is finished
+     TYPE(ESMF_Clock), INTENT(INOUT) :: clock
+!<DESCRIPTION>
+!     Gets data from coupler via importState 
+!     and compares with data read from file and 
+!     error-exits if they differ.  
+!
+!     The arguments are:
+!       importState     Importstate
+!</DESCRIPTION>
+
+     ! 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
+     ! use these for debug prints
+     TYPE(ESMF_Time) :: currentTime
+     INTEGER, SAVE :: numtimes=0   ! track number of calls
+     CHARACTER(LEN=256) :: timestamp
+
+     ! count calls for debug prints...
+     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) )
+
+     ! extract data from the importState and compare with data from file
+!TODO:  change this to Bundles, eventually
+     CALL ESMF_StateGet( 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_StateGet( 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 )
+     CALL ESMF_FieldGet( in_sst_field, 0, 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 )
+     CALL ESMF_FieldGet( in_landmask_field, 0, 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
+     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
+     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 )
+
+     WRITE(str,*) 'compare_data:  end, numtimes = ',numtimes
+     CALL wrf_debug ( 100 , TRIM(str) )
+
+   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
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+     ! Local variables
+     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.  
+!TODO:  Note that this will only work for SPMD serial operation.  For 
+!TODO:  concurrent operation (SPMD or MPMD), we will need to create a new 
+!TODO:  "domdesc" suitable for the task layout of the SST component.  For
+!TODO:  MPMD serial operation, we will need to extract serialized domdesc 
+!TODO:  from export state metadata and de-serialize it.  Similar arguments 
+!TODO:  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
+!TODO:  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.  
+     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
+!write(0,*)__FILE__,__LINE__,'DomainStart ',DomainStart(1:2)
+!write(0,*)__FILE__,__LINE__,'DomainEnd ',DomainEnd(1:2)
+!write(0,*)__FILE__,__LINE__,'MemoryStart ',MemoryStart(1:2)
+!write(0,*)__FILE__,__LINE__,'MemoryEnd ',MemoryEnd(1:2)
+!write(0,*)__FILE__,__LINE__,'PatchStart ',PatchStart(1:2)
+!write(0,*)__FILE__,__LINE__,'PatchEnd ',PatchEnd(1:2)
+     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 )
+!write(0,*)__FILE__,__LINE__
+     CALL wrf_debug ( 5 , 'DEBUG sst_component_init2:  back from ioesmf_create_grid_int()' )
+     ! create ESMF_Fields
+     ! 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 )
+!write(0,*)__FILE__,__LINE__
+     IF ( rc /= ESMF_SUCCESS ) THEN
+       WRITE( str,* ) 'Error in ESMF_GridValidate ',   &
+                      __FILE__ ,                       &
+                      ', line ',                       &
+                      __LINE__ ,                       &
+                      ', error code = ',rc
+       CALL wrf_error_fatal ( TRIM(str) )
+     ENDIF
+     CALL wrf_debug ( 5 , 'DEBUG sst_component_init2:  back OK from ESMF_GridValidate(esmfgrid)' )
+!TODO:  Once new ESMF 3.0 interfaces have settled down, eliminate "tmp_data_" 
+!TODO:  arrays and let ESMF allocate/deallocate them.  Assuming of course that 
+!TODO:  we can convince ESMF to deallocate safely...  
+!write(0,*)__FILE__,__LINE__
+     ALLOCATE( tmp_data_out_sst(ips:ipe,jps:jpe) )
+!write(0,*)__FILE__,__LINE__
+     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)' )
+!write(0,*)__FILE__,__LINE__,trim(datanames(sst_indx))
+!write(0,*)__FILE__,__LINE__,ips,jps,ipe,jpe
+     out_sst_field = ESMF_FieldCreate(                 &
+                       esmfgrid, tmp_data_out_sst,     &
+                       copyflag=ESMF_DATA_REF,         &
+                       staggerloc=ESMF_STAGGERLOC_CENTER,          &
+                       name=TRIM(datanames(SST_INDX)), &
+                       rc=rc )
+!write(0,*)__FILE__,__LINE__,'Creating out_sst_field for exportState of SST component name ',TRIM(datanames(SST_INDX))
+     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) )
+!TODO:  This bit will be useful once ESMF handles allocation/deallocation.  
+     ! 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
+     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,              &
+                            staggerloc=ESMF_STAGGERLOC_CENTER,          &
+                            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)' )
+!TODO:  This bit will be useful once ESMF handles allocation/deallocation.  
+     ! 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
+     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,         &
+                      staggerloc=ESMF_STAGGERLOC_CENTER,          &
+                      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)' )
+!TODO:  This bit will be useful once ESMF handles allocation/deallocation.  
+     ! 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
+     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,              &
+                           staggerloc=ESMF_STAGGERLOC_CENTER,          &
+                           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)' )
+!TODO:  This bit will be useful once ESMF handles allocation/deallocation.  
+     ! 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_StateAdd( importState, in_sst_field, rc=rc )
+     IF ( rc /= ESMF_SUCCESS ) THEN
+       CALL wrf_error_fatal ( 'ESMF_StateAdd(in_sst_field) failed' )
+     ENDIF
+     CALL ESMF_StateAdd( importState, in_landmask_field, rc=rc )
+     IF ( rc /= ESMF_SUCCESS ) THEN
+       CALL wrf_error_fatal ( 'ESMF_StateAdd(in_landmask_field) failed' )
+     ENDIF
+     ! attach ESMF_Field to exportState
+     CALL ESMF_StateAdd( exportState, out_sst_field, rc=rc )
+     IF ( rc /= ESMF_SUCCESS ) THEN
+       CALL wrf_error_fatal ( 'ESMF_StateAdd(out_sst_field) failed' )
+     ENDIF
+     CALL ESMF_StateAdd( exportState, out_landmask_field, rc=rc )
+     IF ( rc /= ESMF_SUCCESS ) THEN
+       CALL wrf_error_fatal ( 'ESMF_StateAdd(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
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+     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
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+     rc = ESMF_SUCCESS
+
+     ! Get from importState, compare with file data, and error_exit 
+     ! if they differ...  
+!TODO:  change this once WRF can load exportState after integrating
+     ! 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
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+     ! 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 
+     DO i=1, datacount
+       ! destroy field in importState
+       CALL ESMF_StateGet( importState, TRIM(datanames(i)), tmp_field, &
+                                rc=rc )
+       IF (rc /= ESMF_SUCCESS) THEN
+         WRITE( str , * )                                               &
+           'sst_component_finalize:  ESMF_StateGet( 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_StateGet( exportState, TRIM(datanames(i)), tmp_field, &
+                                rc=rc )
+       IF (rc /= ESMF_SUCCESS) THEN
+         WRITE( str , * )                                               &
+           'sst_component_finalize:  ESMF_StateGet( 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
+!<DESCRIPTION>
+! This module defines SST "Set Services" method sst_register() 
+! used for ESMF coupling.  
+!</DESCRIPTION>
+
+   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
+!
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+     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
+
+
+
+!<DESCRIPTION>
+! 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.  
+!
+!</DESCRIPTION>
+
+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
+!
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+      ! 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
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+      ! 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
+!TODO:  use CF conventions for "standard_name" once WRF Registry supports them
+!TODO:      datanames(SST_INDX) = "sea_surface_temperature"
+!TODO:      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)
+      TYPE(ESMF_CplComp), INTENT(INOUT) :: comp
+      TYPE(ESMF_State), INTENT(INOUT) :: importState, exportState
+      TYPE(ESMF_Clock), INTENT(INOUT) :: clock
+      INTEGER, INTENT(OUT) :: rc
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+! Note that comments in this code are preserved from the sample coupler 
+! provided by the ESMF core team.  
+
+      ! Local variables
+character*256 :: mename
+character*256 :: melist(100)
+integer :: mecount
+TYPE(ESMF_StateItemType) :: metypelist(100)
+      TYPE(ESMF_Field) :: src_field, dst_field
+      TYPE(ESMF_Array) :: src_array, dst_array
+      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
+      CHARACTER(LEN=256) :: directionString
+
+      WRITE(str,*) 'WRFSSTCpl_run: begin'
+      CALL wrf_debug ( 100 , TRIM(str) )
+
+      ! 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 )
+      WRITE(str,*) 'WRFSSTCpl_run: importStatename ', trim(importStatename), 'rc = ', rc
+      CALL wrf_debug ( 100, TRIM(str) )
+      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.  
+        WRITE(str,*) 'WRFSSTCpl_run: grabbing first field <',TRIM(datanames(1)), &
+                     '> from import state'
+        CALL wrf_debug ( 100 , TRIM(str) )
+
+!CALL ESMF_StateGet( importState, name=mename, itemCount=mecount, itemNameList=melist, stateitemtypelist=metypelist, rc=rc )
+!write(0,*)'importState mename ',trim(mename)
+!write(0,*)'importState mecount ',mecount
+!do i = 1,mecount
+!write(0,*)i,trim(melist(i))
+!enddo
+!do i = 1,mecount
+!write(0,*)i,metypelist(i)
+!enddo
+
+        CALL ESMF_StateGet( importState, TRIM(datanames(1)), src_field, &
+                                 rc=rc )
+        IF ( rc /= ESMF_SUCCESS ) THEN
+          CALL wrf_error_fatal ( 'WRFSSTCpl_run:  ESMF_StateGet(importState) failed' )
+        ENDIF
+
+        CALL ESMF_FieldGet( src_field, array=src_array, rc=rc )
+        IF ( rc /= ESMF_SUCCESS ) THEN
+          CALL wrf_error_fatal ( 'WRFSSTCpl_run:  ESMF_FieldGet src_array failed' )
+        ENDIF
+        WRITE(str,*) 'WRFSSTCpl_run: grabbing first field <',TRIM(datanames(1)), &
+                     '> from export state'
+        CALL wrf_debug ( 100 , TRIM(str) )
+
+!CALL ESMF_StateGet( exportState, name=mename, itemCount=mecount, itemNameList=melist, stateitemtypelist=metypelist, rc=rc )
+!write(0,*)'Exportstate mename ',trim(mename)
+!write(0,*)'Exportstate mecount ',mecount
+!do i = 1,mecount
+!write(0,*)i,trim(melist(i))
+!enddo
+!do i = 1,mecount
+!write(0,*)i,metypelist(i)
+!enddo
+
+        CALL ESMF_StateGet( exportState, TRIM(datanames(1)), dst_field, &
+                                 rc=rc )
+        IF ( rc /= ESMF_SUCCESS ) THEN
+          WRITE(str,*)'WRFSSTCpl_run: datanames(1) ',TRIM(datanames(1)),' rc ',rc
+          CALL wrf_message(TRIM(str))
+          CALL wrf_error_fatal ( 'WRFSSTCpl_run:  ESMF_StateGet(exportState) failed' )
+        ENDIF
+        CALL ESMF_FieldGet( dst_field, array=dst_array, &
+                                 rc=rc )
+        IF ( rc /= ESMF_SUCCESS ) THEN
+          CALL wrf_error_fatal ( 'WRFSSTCpl_run:  ESMF_FieldGet dst_array 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_ArrayRedistStore( src_array, dst_array, &
+                                      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_ArrayRedistStore( src_array, dst_array, &
+                                      routehandle=fromSST_rh, rc=rc )
+!write(0,*)__FILE__,__LINE__,'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_StateGet(importState,', &
+                     TRIM(datanames(i)),')...'
+        CALL wrf_debug ( 100 , TRIM(str) )
+        CALL ESMF_StateGet( importState, TRIM(datanames(i)), src_field, &
+                                 rc=rc )
+        IF ( rc /= ESMF_SUCCESS ) THEN
+          WRITE(str,*) 'WRFSSTCpl_run:  ESMF_StateGet(importState,', &
+                       TRIM(datanames(i)),') failed'
+          CALL wrf_error_fatal ( str )
+        ENDIF
+        CALL ESMF_FieldGet( src_field, array=src_array, rc=rc )
+        IF ( rc /= ESMF_SUCCESS ) THEN
+          WRITE(str,*) 'WRFSSTCpl_run:  ESMF_FieldGet(src_field,src_array,rc) failed'
+          CALL wrf_error_fatal ( str )
+        ENDIF
+
+        WRITE(str,*) 'WRFSSTCpl_run:  calling ESMF_StateGet(exportState,', &
+                     TRIM(datanames(i)),')...'
+        CALL wrf_debug ( 100 , TRIM(str) )
+        CALL ESMF_StateGet( exportState, TRIM(datanames(i)), dst_field, &
+                                 rc=rc )
+        IF ( rc /= ESMF_SUCCESS ) THEN
+          WRITE(str,*) 'WRFSSTCpl_run:  ESMF_StateGet(exportState,', &
+                       TRIM(datanames(i)),') failed'
+          CALL wrf_error_fatal ( str )
+        ENDIF
+        CALL ESMF_FieldGet( dst_field, array=dst_array, rc=rc )
+        IF ( rc /= ESMF_SUCCESS ) THEN
+          WRITE(str,*) 'WRFSSTCpl_run:  ESMF_FieldGet(dst_field,dst_array,rc) 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:
+        WRITE(str,*) 'WRFSSTCpl_run:  calling ESMF_FieldRedist for <', &
+                     TRIM(datanames(i)),'>...'
+        CALL wrf_debug ( 100 , TRIM(str) )
+        CALL ESMF_ArrayRedist( src_array, dst_array, 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) )
+
+      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
+!<DESCRIPTION>
+!     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.
+!</DESCRIPTION>
+
+      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_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_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
+
+!<DESCRIPTION>
+! 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).  Fields are returned from WRF to SST via the coupler for 
+! self-test only.  
+!
+! 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.  
+!TODO:  ESMF auxio must begin at the start of the run.  Remove this 
+!TODO:  restriction later, if needed.  
+!
+!TODO:  Note that coupling is currently limited to one auxin plus one auxout 
+!TODO:  streams.  Extension to multiple pairs of auxio streams requires 
+!TODO:  nested states (one for each auxio stream pair).  
+!TODO:  For now, only support one input and/or one output stream via 
+!TODO:  io_esmf.  This condition is asserted in 
+!TODO:  ext_esmf_open_for_read_begin() and 
+!TODO:  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.  
+!   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.  
+!
+!</DESCRIPTION>
+
+   ! 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
+   INTEGER :: thecount  ! ah ah ah
+
+   ! Return codes for error checks
+   INTEGER :: rc
+   CHARACTER (ESMF_MAXSTR) :: str
+
+   ! debugging
+   CHARACTER(LEN=256) :: couplingIntervalString
+integer(ESMF_KIND_I4) :: timevals(6)
+
+        
+   ! 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-CPL-SST                '
+   PRINT *, '          U S E   A T   Y O U R   O W N   R I S K            '
+
+   ! Initialize ESMF, get the default Global VM, and set
+   ! the default calendar to be Gregorian.
+#ifdef NO_LEAP_CALENDAR
+   CALL ESMF_Initialize( vm=vm, defaultCalendar=ESMF_CAL_NOLEAP, defaultlogtype=ESMF_LOG_MULTI,rc=rc )
+#else
+   CALL ESMF_Initialize( vm=vm, defaultCalendar=ESMF_CAL_GREGORIAN, defaultlogtype=ESMF_LOG_MULTI,rc=rc )
+#endif
+   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( name="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( name="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( name="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(stateName="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(stateName="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(stateName="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(stateName="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)
+thecount = size(timevals)
+call esmf_attributeget(exportstatewrf,'ComponentCouplingInterval',timevals,itemcount=thecount,rc=rc)
+!write(0,*) 'exportStateWRF year ',timevals(1),__LINE__
+!write(0,*) 'exportStateWRF month ',timevals(2),__LINE__
+!write(0,*) 'exportStateWRF day ',timevals(3),__LINE__
+!write(0,*) 'exportStateWRF hour ',timevals(4),__LINE__
+!write(0,*) 'exportStateWRF minute ',timevals(5),__LINE__
+!write(0,*) 'exportStateWRF second ',timevals(6),__LINE__
+   ! 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)
+thecount = size(timevals)
+call esmf_attributeget(exportstatesst,'ComponentCouplingInterval',timevals,itemcount=thecount,rc=rc)
+!write(0,*) 'exportStateSST year ',timevals(1),__LINE__
+!write(0,*) 'exportStateSST month ',timevals(2),__LINE__
+!write(0,*) 'exportStateSST day ',timevals(3),__LINE__
+!write(0,*) 'exportStateSST hour ',timevals(4),__LINE__
+!write(0,*) 'exportStateSST minute ',timevals(5),__LINE__
+!write(0,*) 'exportStateSST second ',timevals(6),__LINE__
+   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_StateAdd( tmpState, exportStateWRF, rc )
+   IF ( rc /= ESMF_SUCCESS ) THEN
+     CALL wrf_error_fatal ( 'wrf_SST_ESMF:  ESMF_StateAdd(exportStateWRF) failed' )
+   ENDIF
+   CALL ESMF_StateAdd( tmpState, exportStateSST, rc )
+   IF ( rc /= ESMF_SUCCESS ) THEN
+     CALL wrf_error_fatal ( 'wrf_SST_ESMF:  ESMF_StateAdd(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, but would be in general
+!   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
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/Makefile
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/Makefile	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/Makefile	(revision 17)
@@ -0,0 +1,618 @@
+
+
+LN      =       ln -sf
+MAKE    =       make -i -r
+RM      =       rm -f
+
+
+MODULES = \
+	module_cam_shr_kind_mod.o \
+	module_cam_support.o \
+	module_cam_shr_const_mod.o \
+	module_cam_physconst.o \
+	module_cam_cldwat.o \
+	module_cam_wv_saturation.o \
+	module_cam_esinti.o \
+	module_cam_gffgch.o \
+	module_cam_error_function.o \
+	module_cam_constituents.o \
+	module_cam_trb_mtn_stress.o \
+	module_cam_molec_diff.o \
+	module_cam_upper_bc.o \
+	module_cam_bl_diffusion_solver.o \
+	module_cam_bl_eddy_diff.o \
+	module_bl_ysu.o \
+	module_bl_mrf.o \
+	module_bl_gfs.o \
+	module_bl_myjpbl.o \
+	module_bl_qnsepbl.o \
+	module_bl_acm.o \
+	module_bl_mynn.o \
+	module_bl_gwdo.o \
+	module_bl_myjurb.o \
+	module_bl_boulac.o \
+	module_bl_camuwpbl_driver.o \
+	module_cu_camuwshcu_driver.o \
+	module_cu_camuwshcu.o \
+	module_cu_camzm_driver.o \
+	module_cu_camzm.o \
+	module_bl_temf.o \
+	module_cu_g3.o \
+	module_cu_kf.o  \
+	module_cu_bmj.o \
+	module_cu_kfeta.o \
+	module_cu_tiedtke.o\
+	module_cu_gd.o \
+	module_cu_nsas.o \
+	module_cu_sas.o \
+	module_mp_kessler.o \
+	module_mp_lin.o  \
+	module_mp_sbu_ylin.o  \
+	module_mp_wsm3.o \
+	module_mp_wsm5.o \
+	module_mp_wsm6.o \
+	module_mp_etanew.o \
+	module_mp_HWRF.o \
+	module_mp_thompson.o \
+	module_mp_gsfcgce.o \
+	module_mp_morr_two_moment.o \
+	module_mp_milbrandt2mom.o \
+	module_mp_wdm5.o \
+	module_mp_wdm6.o \
+	module_ra_sw.o  \
+	module_ra_gsfcsw.o \
+	module_ra_goddard.o \
+	module_ra_rrtm.o  \
+	module_ra_rrtmg_lw.o  \
+	module_ra_rrtmg_sw.o  \
+        module_ra_cam_support.o \
+        module_ra_cam.o \
+	module_ra_gfdleta.o \
+	module_ra_HWRF.o \
+	module_ra_hs.o  \
+	module_sf_sfclay.o \
+	module_sf_gfs.o \
+	module_sf_gfdl.o \
+	module_sf_slab.o  \
+	module_sf_noahdrv.o  \
+	module_sf_noahlsm.o  \
+        module_sf_urban.o  \
+        module_sf_bep.o  \
+        module_sf_bep_bem.o \
+        module_sf_bem.o \
+	module_sf_pxlsm.o \
+	module_sf_ruclsm.o \
+	module_sf_sfcdiags.o \
+	module_sf_sfcdiags_ruclsm.o \
+	module_sf_sstskin.o \
+	module_sf_tmnupdate.o \
+	module_sf_oml.o \
+	module_sf_myjsfc.o \
+	module_sf_qnsesfc.o \
+	module_sf_mynn.o \
+	module_sf_pxsfclay.o \
+	module_sf_temfsfclay.o \
+	module_sf_idealscmsfclay.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_data_gocart_dust.o \
+	module_cumulus_driver.o \
+	module_shallowcu_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_fdda_spnudging.o \
+	module_fddagd_driver.o  \
+        module_fddaobs_rtfdda.o \
+	module_fddaobs_driver.o \
+	module_wind_generic.o \
+	module_wind_fitch.o \
+	module_lmdz_phys.o
+
+FIRE_MODULES = \
+        module_fr_sfire_driver.o \
+        module_fr_sfire_driver_wrf.o \
+        module_fr_sfire_atm.o \
+        module_fr_sfire_model.o \
+        module_fr_sfire_core.o \
+        module_fr_sfire_phys.o \
+        module_fr_sfire_util.o
+  
+OBJS    =
+
+NMM_MODULES =  
+
+LIBTARGET    =  physics
+TARGETDIR    =  ./
+
+$(LIBTARGET) :
+		if [ $(WRF_NMM_CORE) -eq 1 ] ; then \
+                  $(MAKE) nmm_contrib                                      ; \
+                  $(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(OBJS) $(NMM_OBJS) $(NMM_MODULES) ; \
+                else                                                         \
+                  $(MAKE) non_nmm                                          ; \
+                  $(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(FIRE_MODULES) $(OBJS)             ; \
+                fi
+
+include ../configure.wrf
+
+nmm_contrib : $(NMM_OBJS) $(NMM_MODULES) $(MODULES) $(OBJS)
+
+non_nmm : $(MODULES) $(FIRE_MODULES) $(WIND_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_myjurb.o: ../share/module_model_constants.o
+
+module_bl_boulac.o: ../share/module_model_constants.o
+
+module_bl_qnsepbl.o: ../share/module_model_constants.o
+
+module_bl_gfs.o: module_gfs_machine.o \
+		 module_gfs_physcons.o
+
+module_bl_mynn.o: ../share/module_model_constants.o
+
+module_cam_upper_bc.o: module_cam_shr_kind_mod.o \
+		module_cam_support.o
+
+module_cam_constituents.o: module_cam_shr_kind_mod.o \
+		module_cam_physconst.o \
+		module_cam_support.o \
+		../frame/module_wrf_error.o 
+
+module_cam_trb_mtn_stress.o: module_cam_shr_kind_mod.o \
+		module_cam_support.o
+
+module_cam_molec_diff.o: module_cam_support.o \
+		module_cam_constituents.o \
+		module_cam_upper_bc.o 
+
+module_cam_bl_diffusion_solver.o: module_cam_support.o 
+
+module_cam_bl_eddy_diff.o:module_cam_bl_diffusion_solver.o \
+		module_cam_support.o 
+
+module_bl_camuwpbl_driver.o: module_cam_shr_kind_mod.o \
+		module_cam_support.o \
+		module_cam_constituents.o \
+		module_cam_bl_diffusion_solver.o\
+		module_cam_physconst.o \
+		module_cam_trb_mtn_stress.o \
+		module_cam_bl_eddy_diff.o \
+		module_cam_wv_saturation.o \
+		module_cam_molec_diff.o \
+		../share/module_model_constants.o \
+		module_cam_esinti.o 
+
+module_sf_mynn.o: module_sf_sfclay.o module_bl_mynn.o \
+                ../share/module_model_constants.o
+
+module_sf_gfdl.o : \
+		module_gfs_machine.o \
+		module_gfs_funcphys.o \
+		module_gfs_physcons.o
+
+module_cu_bmj.o: ../share/module_model_constants.o
+
+module_cu_camuwshcu_driver.o: module_cam_support.o \
+                module_cam_physconst.o \
+                module_cam_wv_saturation.o \
+                module_cu_camuwshcu.o
+
+module_cu_camuwshcu.o: module_cam_support.o \
+                module_cam_constituents.o \
+                module_cam_error_function.o \
+                module_cam_esinti.o \
+                module_cam_support.o \
+                module_cam_physconst.o \
+                module_bl_camuwpbl_driver.o
+
+module_cu_camzm_driver.o: ../share/module_model_constants.o \
+                module_cam_shr_kind_mod.o \
+                module_cam_support.o \
+                module_cam_physconst.o \
+                module_bl_camuwpbl_driver.o \
+                module_cu_camzm.o
+
+module_cu_camzm.o: module_cam_shr_kind_mod.o \
+                module_cam_support.o \
+                module_cam_physconst.o \
+                module_cam_wv_saturation.o \
+                module_cam_cldwat.o
+
+module_cam_error_function.o: 
+
+module_cam_cldwat.o: module_cam_shr_kind_mod.o \
+                module_cam_support.o \
+                module_cam_wv_saturation.o \
+                module_cam_physconst.o
+
+module_cam_esinti.o: module_cam_shr_kind_mod.o \
+                module_cam_wv_saturation.o
+
+module_cam_wv_saturation.o: module_cam_shr_kind_mod.o \
+                module_cam_support.o \
+                module_cam_gffgch.o
+
+module_cam_gffgch.o: module_cam_shr_kind_mod.o \
+                module_cam_support.o \
+                module_cam_physconst.o
+
+module_cam_physconst.o: module_cam_shr_kind_mod.o \
+                module_cam_shr_const_mod.o
+
+module_cam_shr_const_mod.o: module_cam_shr_kind_mod.o
+
+module_cam_support.o: module_cam_shr_kind_mod.o
+
+module_cam_shr_kind_mod.o:
+
+module_cu_kf.o:  ../frame/module_wrf_error.o
+
+module_cu_kfeta.o: ../frame/module_wrf_error.o
+
+module_cu_gd.o:
+
+module_cu_nsas.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_cu_tiedtke.o:module_gfs_machine.o \
+		module_gfs_funcphys.o \
+		module_gfs_physcons.o
+
+module_ra_gfdleta.o:  ../frame/module_dm.o \
+		module_mp_etanew.o
+
+module_ra_HWRF.o:   ../frame/module_dm.o module_mp_HWRF.o
+
+module_ra_rrtm.o: ../frame/module_wrf_error.o \
+		../frame/module_dm.o
+
+module_ra_cam_support.o: module_cam_support.o \
+                ../frame/module_wrf_error.o
+
+module_ra_cam.o: module_ra_cam_support.o \
+		 module_cam_support.o \
+                ../frame/module_wrf_error.o
+
+module_mp_lin.o : ../frame/module_wrf_error.o
+
+module_mp_sbu_ylin.o : ../frame/module_wrf_error.o \
+                   ../share/module_model_constants.o
+
+module_mp_milbrandt2mom.o : ../frame/module_wrf_error.o \
+		../share/module_model_constants.o
+
+module_mp_thompson.o : ../frame/module_wrf_error.o 
+
+module_ra_goddard.o : ../frame/module_wrf_error.o
+
+module_mp_gsfcgce.o : ../frame/module_wrf_error.o
+
+module_sf_myjsfc.o: ../share/module_model_constants.o 
+
+module_sf_qnsesfc.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_noahdrv.o: module_sf_noahlsm.o module_data_gocart_dust.o \
+                     module_sf_urban.o module_sf_bep.o module_sf_bep_bem.o 
+
+module_sf_noahlsm.o: ../share/module_model_constants.o
+
+module_sf_bep.o: ../share/module_model_constants.o module_sf_urban.o
+
+module_sf_bep_bem.o: ../share/module_model_constants.o module_sf_bem.o 
+
+module_sf_bem.o: ../share/module_model_constants.o
+
+module_sf_ruclsm.o: ../frame/module_wrf_error.o module_data_gocart_dust.o 
+
+module_sf_pxlsm.o: ../share/module_model_constants.o
+
+module_ra_rrtmg_sw.o: module_ra_rrtmg_lw.o
+
+module_ra_rrtmg_lw.o: ../share/module_model_constants.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_rrtmg_lw.o		\
+		module_ra_rrtmg_sw.o		\
+		module_ra_cam.o		\
+		module_ra_cam_support.o		\
+		module_ra_sw.o			\
+		module_ra_gsfcsw.o		\
+		module_ra_gfdleta.o		\
+		module_ra_HWRF.o		\
+		module_ra_hs.o			\
+		module_sf_sfclay.o		\
+		module_sf_slab.o		\
+		module_sf_myjsfc.o		\
+		module_sf_mynn.o                \
+		module_sf_urban.o                \
+		module_sf_qnsesfc.o		\
+		module_sf_pxsfclay.o		\
+		module_sf_noahlsm.o		\
+		module_sf_noahdrv.o		\
+                module_sf_bep.o                 \
+                module_sf_bep_bem.o             \
+		module_sf_ruclsm.o		\
+		module_sf_pxlsm.o		\
+		module_bl_ysu.o			\
+		module_bl_mrf.o			\
+		module_bl_gfs.o			\
+		module_bl_acm.o			\
+		module_bl_myjpbl.o		\
+		module_bl_qnsepbl.o		\
+		module_bl_mynn.o                \
+		module_bl_myjurb.o              \
+		module_bl_boulac.o              \
+		module_bl_camuwpbl_driver.o     \
+		module_bl_temf.o              \
+		module_cu_kf.o			\
+	        module_cu_g3.o                  \
+		module_cu_kfeta.o		\
+		module_cu_bmj.o			\
+		module_cu_gd.o			\
+		module_cu_nsas.o		\
+		module_cu_sas.o			\
+		module_cu_camzm_driver.o        \
+		module_cu_camuwshcu.o		\
+		module_mp_sbu_ylin.o		\
+		module_mp_wsm3.o		\
+		module_mp_wsm5.o		\
+		module_mp_wsm6.o		\
+		module_mp_etanew.o		\
+		module_mp_HWRF.o		\
+		module_fdda_psufddagd.o		\
+		module_fdda_spnudging.o         \
+		module_fddaobs_rtfdda.o		\
+		module_mp_thompson.o            \
+		module_mp_gsfcgce.o 		\
+                module_mp_morr_two_moment.o     \
+                module_mp_milbrandt2mom.o     \
+		module_mp_wdm5.o		\
+		module_mp_wdm6.o		\
+		module_cam_physconst.o		\
+		module_cam_shr_kind_mod.o	\
+		module_wind_fitch.o		\
+		../frame/module_state_description.o \
+		../frame/module_configure.o \
+		../frame/module_wrf_error.o \
+		../frame/module_dm.o \
+		../share/module_llxy.o \
+		../share/module_model_constants.o 
+
+module_microphysics_driver.o: \
+		module_mixactivate.o \
+		module_mp_kessler.o  module_mp_sbu_ylin.o module_mp_lin.o \
+		module_mp_wsm3.o module_mp_wsm5.o \
+		module_mp_wsm6.o module_mp_etanew.o \
+		module_mp_HWRF.o  \
+		module_mp_thompson.o            \
+		module_mp_gsfcgce.o 		\
+                module_mp_morr_two_moment.o     \
+                module_mp_milbrandt2mom.o     \
+		module_mp_wdm5.o module_mp_wdm6.o \
+		../frame/module_driver_constants.o \
+		../frame/module_state_description.o \
+		../frame/module_wrf_error.o \
+		../frame/module_configure.o \
+		../share/module_model_constants.o 
+
+module_shallowcu_driver.o: \
+		module_cu_camuwshcu_driver.o \
+		../frame/module_state_description.o \
+		../share/module_model_constants.o
+
+module_cumulus_driver.o: \
+		module_cu_kf.o \
+		module_cu_g3.o \
+		module_cu_kfeta.o \
+		module_cu_bmj.o \
+		module_cu_gd.o \
+		module_cu_nsas.o \
+		module_cu_sas.o \
+		module_cu_camzm_driver.o \
+		module_cu_tiedtke.o \
+		../frame/module_state_description.o \
+		../frame/module_configure.o \
+		../frame/module_domain.o \
+		../frame/module_dm.o \
+		../frame/module_comm_dm.o \
+		../frame/module_wrf_error.o \
+		../share/module_model_constants.o
+
+module_pbl_driver.o:  \
+		module_bl_myjpbl.o \
+		module_bl_myjurb.o \
+		module_bl_qnsepbl.o \
+		module_bl_acm.o \
+		module_bl_ysu.o \
+		module_bl_mrf.o \
+                module_bl_boulac.o \
+		module_bl_camuwpbl_driver.o \
+		module_bl_gfs.o \
+		module_bl_mynn.o \
+		module_bl_gwdo.o \
+		module_wind_fitch.o \
+		module_bl_temf.o \
+		../frame/module_state_description.o \
+		../frame/module_configure.o \
+		../share/module_model_constants.o 
+
+module_data_gocart_dust.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_rrtmg_lw.o \
+		module_ra_rrtmg_sw.o \
+		module_ra_cam.o \
+		module_ra_gfdleta.o \
+		module_ra_HWRF.o \
+		module_ra_hs.o \
+		../frame/module_driver_constants.o \
+		../frame/module_state_description.o \
+		../frame/module_dm.o \
+		../frame/module_comm_dm.o \
+		../frame/module_domain.o \
+		../frame/module_wrf_error.o \
+		../frame/module_configure.o \
+		../share/module_bc.o  \
+		../share/module_model_constants.o 
+
+module_surface_driver.o: \
+		module_sf_sfclay.o		\
+		module_sf_slab.o		\
+		module_sf_myjsfc.o		\
+		module_sf_qnsesfc.o		\
+		module_sf_pxsfclay.o		\
+		module_sf_gfs.o  		\
+		module_sf_noahdrv.o		\
+		module_sf_ruclsm.o		\
+		module_sf_pxlsm.o		\
+		module_sf_mynn.o                \
+		module_sf_sfcdiags.o		\
+		module_sf_sfcdiags_ruclsm.o     \
+		module_sf_sstskin.o		\
+		module_sf_tmnupdate.o		\
+		module_sf_temfsfclay.o		\
+		module_sf_idealscmsfclay.o	\
+		../frame/module_state_description.o \
+		../frame/module_configure.o \
+		../share/module_model_constants.o  
+
+module_diagnostics.o: ../frame/module_dm.o
+
+
+module_mixactivate.o: \
+		module_radiation_driver.o
+
+module_fddagd_driver.o: \
+		module_fdda_spnudging.o \
+		module_fdda_psufddagd.o \
+		../frame/module_state_description.o \
+		../frame/module_configure.o \
+		../share/module_model_constants.o
+
+module_fddaobs_driver.o: \
+		../frame/module_domain.o \
+		../share/module_bc.o  \
+		../share/module_model_constants.o  \
+		module_fddaobs_rtfdda.o
+
+module_fr_sfire_driver.o: \
+		../share/module_model_constants.o  \
+                ../frame/module_comm_dm.o \
+		module_fr_sfire_phys.o \
+		module_fr_sfire_model.o \
+		module_fr_sfire_util.o 
+
+module_fr_sfire_driver_wrf.o: \
+		../share/module_model_constants.o  \
+                ../frame/module_comm_dm.o \
+		module_fr_sfire_driver.o \
+		module_fr_sfire_atm.o \
+		module_fr_sfire_util.o 
+
+module_fr_sfire_atm.o: \
+		../share/module_model_constants.o  \
+		module_fr_sfire_util.o 
+
+module_fr_sfire_model.o: \
+	        module_fr_sfire_core.o \
+                module_fr_sfire_phys.o \
+		module_fr_sfire_util.o 
+
+module_fr_sfire_core.o: \
+		module_fr_sfire_util.o \
+	        module_fr_sfire_phys.o 
+
+module_fr_sfire_phys.o: \
+		../share/module_model_constants.o  \
+		module_fr_sfire_util.o 
+
+module_fire_debug_output.o: \
+	        ../frame/module_domain.o \
+	        ../frame/module_configure.o \
+	        ../share/mediation_integrate.o
+
+module_fdda_spnudging.o :\
+		../frame/module_dm.o \
+		../frame/module_state_description.o \
+		../frame/module_domain.o \
+		../frame/module_wrf_error.o
+
+module_sf_bep.o :\
+		module_sf_urban.o
+
+module_wind_fitch.o :\
+		module_wind_generic.o
+
+module_mp_wsm5.o :\
+		module_mp_wsm5_accel.F
+
+module_mp_wsm3.o :\
+		module_mp_wsm3_accel.F
+
+module_lmdz_phys.o:\
+ 		../share/module_model_constants.o \
+		../frame/module_domain_type.o \
+                ../lmdz/physiq.o \
+                ../lmdz/infotrac.o \
+                ../lmdz/iniphysiq.o \
+		../lmdz/conf_gcm.o \
+		../lmdz/init_phys_lmdz.o \
+		../lmdz/comgeomphy.o \
+		../lmdz/control_mod.o \
+		../lmdz/iostart.o \
+		../lmdz/pbl_surface_mod.o \
+		../lmdz/indice_sol_mod.o \
+		../lmdz/fonte_neige_mod.o \
+		../lmdz/surface_data.o \
+		../lmdz/wrf_lmdz_mod.o \
+		../lmdz/mod_grid_phy_lmdz.o \
+		../lmdz/lmdz_wrf_variables_mod.o \
+		../lmdz/NOread_limit_sub_variables.o \
+		../lmdz/output_lmdz_NOmodule.o \
+		../lmdz/phys_state_var_mod.o
+
+# DO NOT DELETE
Index: branches/LMDZ_WRFmeas/WRFV3/phys/fr_sfire_params_args.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/fr_sfire_params_args.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/fr_sfire_params_args.h	(revision 17)
@@ -0,0 +1,2 @@
+,xifms,xifme,xjfms,xjfme &
+,vx,vy,zsf,bbb,betafl,phiwc,r_0,fgip,ischap &
Index: branches/LMDZ_WRFmeas/WRFV3/phys/fr_sfire_params_decl.h
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/fr_sfire_params_decl.h	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/fr_sfire_params_decl.h	(revision 17)
@@ -0,0 +1,7 @@
+! declaration of fire model parameter arrays, passed to normal_spread as arguments
+integer, intent(in)::xifms,xifme,xjfms,xjfme  ! redundant dimensions, for pass-through only
+real,intent(in),dimension(xifms:xifme,xjfms:xjfme):: vx,vy                ! wind velocity (m/s)
+real,intent(in),dimension(xifms:xifme,xjfms:xjfme):: zsf                  ! terrain height (m) 
+real,intent(IN),dimension(xifms:xifme,xjfms:xjfme):: bbb,betafl,phiwc,r_0 ! (node) spread formula coefficients
+real,intent(IN),dimension(xifms:xifme,xjfms:xjfme):: fgip                 ! (cell) init mass of surface fuel (kg/m^2)
+integer,intent(IN),dimension(xifms:xifme,xjfms:xjfme):: ischap            ! (node) .ne.0 if chapparal
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_acm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_acm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_acm.F	(revision 17)
@@ -0,0 +1,1204 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+MODULE module_bl_acm
+
+!  USE module_model_constants
+
+  REAL, PARAMETER      :: RIC    = 0.25                ! critical Richardson number
+  REAL, PARAMETER      :: CRANKP = 0.5                 ! CRANK-NIC PARAMETER
+
+CONTAINS
+
+!-------------------------------------------------------------------
+   SUBROUTINE ACMPBL(XTIME,    DTPBL,    ZNW, SIGMAH,                &
+                     U3D,      V3D,      PP3D,  DZ8W, TH3D, T3D,        &
+                     QV3D,     QC3D,     QI3D, RR3D,                    &	!!  Moisture
+                     UST,      HFX,  QFX,     TSK,                      &
+                     PSFC,     EP1,      G,                             &
+                     ROVCP,    RD,       CPD,                           &
+                     PBLH,      KPBL2D,   REGIME,                       &
+                     GZ1OZ0,   WSPD,     PSIM, MUT,                     &
+                     RUBLTEN,  RVBLTEN,  RTHBLTEN,                      &
+                     RQVBLTEN, RQCBLTEN, RQIBLTEN,                      &
+                     ids,ide, jds,jde, kds,kde,                         &
+                     ims,ime, jms,jme, kms,kme,                         &
+                     its,ite, jts,jte, kts,kte)
+!**********************************************************************
+
+!   THIS MODULE COMPUTES VERTICAL MIXING IN AND ABOVE THE PBL ACCORDING TO 
+!   THE ASYMMETRICAL CONVECTIVE MODEL, VERSION 2  (ACM2), WHICH IS A COMBINED 
+!   LOCAL NON-LOCAL CLOSURE SCHEME BASED ON THE ORIGINAL ACM (PLEIM AND CHANG 1992)
+!
+!   REFERENCES: 
+!   Pleim (2007) A combined local and non-local closure model for the atmospheric
+!                boundary layer.  Part1: Model description and testing.  
+!                JAMC, 46, 1383-1395
+!   Pleim (2007) A combined local and non-local closure model for the atmospheric
+!                boundary layer.  Part2: Application and evaluation in a mesoscale
+!                meteorology model.  JAMC, 46, 1396-1409
+!
+!  REVISION HISTORY:
+!     AX     3/2005 - developed WRF version based on the MM5 PX LSM
+!     RG and JP 7/2006 - Finished WRF adaptation
+!
+!**********************************************************************
+!   ARGUMENT LIST:
+!
+!... Inputs:
+!-- XTIME           Time since simulation start (min)
+!-- DTPBL           PBL time step
+!-- ZNW             Sigma at full layer
+!-- SIGMAH          Sigma at half layer
+!-- U3D             3D u-velocity interpolated to theta points (m/s)
+!-- V3D             3D v-velocity interpolated to theta points (m/s)
+!-- PP3D            Pressure at half levels (Pa)
+!-- DZ8W            dz between full levels (m)
+!-- TH3D            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)
+!-- RR3D            3D dry air density (kg/m^3)
+!-- UST             Friction Velocity (m/s)
+!-- 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)
+!-- PSFC            Pressure at the surface (Pa)
+!-- EP1             Constant for virtual temperature (r_v/r_d-1) (dimensionless)
+!-- G               Gravity (m/s^2)
+!-- ROVCP           r/cp
+!-- RD              gas constant for dry air (j/kg/k)
+!-- CPD             heat capacity at constant pressure for dry air (j/kg/k)
+!-- GZ1OZ0          log(z/z0) where z0 is roughness length
+!-- WSPD            wind speed at lowest model level (m/s)
+!-- PSIM            similarity stability function for momentum
+!-- MUT             Total Mu : Psfc - Ptop
+ 
+!-- 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
+!
+!... Outputs: 
+!-- PBLH            PBL height (m)
+!-- KPBL2D          K index for PBL layer
+!-- REGIME          Flag indicating PBL regime (stable, unstable, etc.)
+!-- 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)
+!
+!-------------------------------------------------------------------
+     IMPLICIT NONE
+
+!.......Arguments
+! DECLARATIONS - INTEGER
+    INTEGER,  INTENT(IN   )   ::      ids,ide, jds,jde, kds,kde, &
+                                      ims,ime, jms,jme, kms,kme, &
+                                      its,ite, jts,jte, kts,kte, XTIME
+
+! DECLARATIONS - REAL
+    REAL,                                INTENT(IN)  ::  DTPBL, EP1,   &
+                                                        G, ROVCP, RD, CPD
+    REAL,    DIMENSION( kms:kme ),       INTENT(IN)  :: ZNW, SIGMAH
+    REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ),                         &
+             INTENT(IN) ::                              U3D, V3D,            &
+                                                        PP3D, DZ8W, T3D,     &
+                                                        QV3D, QC3D, QI3D,    &
+                                                        RR3D, TH3D
+    REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) ::  UST
+    REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(IN) ::                    &
+                                                        HFX, QFX, TSK,       &
+                                                        PSFC
+    INTEGER, DIMENSION( ims:ime, jms:jme ),                                  &
+             INTENT(OUT  )   ::                         KPBL2D
+    REAL,    DIMENSION( ims:ime, jms:jme ),                                  &
+             INTENT(INOUT) ::                           PBLH
+    REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(INOUT)   ::  REGIME
+    REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(IN)  ::                   &
+           					        psim,                &
+							gz1oz0,              &
+                                                        wspd ,   mut
+    REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ),                         &
+             INTENT(INOUT)   ::                         RUBLTEN, RVBLTEN,    &
+                                                        RTHBLTEN, RQVBLTEN,  &
+                                                        RQCBLTEN, RQIBLTEN
+
+!... Local Variables
+
+!... Integer
+      INTEGER :: J, K
+!... Real
+      REAL, DIMENSION( kts:kte ) :: DSIGH, DSIGHI, DSIGFI
+      REAL, DIMENSION( 0:kte )   :: SIGMAF
+      REAL  RDT
+      REAL, PARAMETER :: KARMAN = 0.4
+!...
+
+   RDT = 1.0 / DTPBL
+
+   DO K = 1, kte
+     SIGMAF(K-1) = ZNW(K)
+   ENDDO
+   SIGMAF(kte) = 0.0
+
+   DO K = 1, kte
+     DSIGH(K)  = SIGMAF(K) - SIGMAF(K-1)
+     DSIGHI(K) = 1.0 / DSIGH(K)
+   ENDDO
+
+   DO K = kts,kte-1
+     DSIGFI(K) = 1.0 / (SIGMAH(K+1) - SIGMAH(K))
+   ENDDO
+
+   DSIGFI(kte) = DSIGFI(kte-1)
+   
+    do j = jts,jte
+      CALL ACM2D(j=J,xtime=XTIME, dtpbl=DTPBL, sigmaf=SIGMAF, sigmah=SIGMAH    &
+              ,dsigfi=DSIGFI,dsighi=DSIGHI,dsigh=DSIGH             &
+              ,us=u3d(ims,kms,j),vs=v3d(ims,kms,j)                 &
+              ,theta=th3d(ims,kms,j),tt=t3d(ims,kms,j)             &
+              ,qvs=qv3d(ims,kms,j),qcs=qc3d(ims,kms,j)             &
+              ,qis=qi3d(ims,kms,j),dzf=DZ8W(ims,kms,j)             &
+              ,densx=RR3D(ims,kms,j)                               &
+              ,utnp=rublten(ims,kms,j),vtnp=rvblten(ims,kms,j)     &
+              ,ttnp=rthblten(ims,kms,j),qvtnp=rqvblten(ims,kms,j)  &
+              ,qctnp=rqcblten(ims,kms,j),qitnp=rqiblten(ims,kms,j) &
+              ,cpd=cpd,g=g,rovcp=rovcp,rd=rd,rdt=rdt               &
+              ,psfcpa=psfc(ims,j),ust=ust(ims,j)                   &
+              ,pbl=pblh(ims,j)                                     &
+              ,regime=regime(ims,j),psim=psim(ims,j)               &
+              ,hfx=hfx(ims,j),qfx=qfx(ims,j)                       &
+              ,tg=tsk(ims,j),gz1oz0=gz1oz0(ims,j)                  &
+              ,wspd=wspd(ims,j) ,klpbl=kpbl2d(ims,j)               &
+              ,mut=mut(ims,j)                                      &
+              ,ep1=ep1,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   )
+    enddo
+
+   END SUBROUTINE ACMPBL
+
+!--------------------------------------------------------------------
+   SUBROUTINE ACM2D(j,XTIME, DTPBL, sigmaf, sigmah          &
+              ,dsigfi,dsighi,dsigh                          &
+              ,us,vs,theta,tt,qvs,qcs,qis                   &
+              ,dzf,densx,utnp,vtnp,ttnp,qvtnp,qctnp,qitnp   &
+              ,cpd,g,rovcp,rd,rdt,psfcpa,ust                &
+              ,pbl,regime,psim                              &
+              ,hfx,qfx,tg,gz1oz0,wspd ,klpbl                &
+              ,mut                                          &
+              ,ep1,karman                                   &
+              ,ids,ide, jds,jde, kds,kde   &
+              ,ims,ime, jms,jme, kms,kme   &
+              ,its,ite, jts,jte, kts,kte   )
+
+!            USE module_wrf_error
+            IMPLICIT NONE
+
+!.......Arguments
+
+!... Real
+      REAL, DIMENSION( 0:kte ),             INTENT(IN)  :: SIGMAF
+      REAL, DIMENSION( kms:kme ),           INTENT(IN)  :: SIGMAH
+      REAL, DIMENSION( kts:kte ),           INTENT(IN)  :: DSIGH, DSIGHI, DSIGFI
+      REAL ,                                INTENT(IN)  :: DTPBL, G, RD,ep1,karman,CPD,ROVCP,RDT
+      REAL , DIMENSION( ims:ime ),          INTENT(INOUT)  :: PBL, UST
+      
+      REAL , DIMENSION( ims:ime, kms:kme ), INTENT(IN)  :: US,VS, THETA, TT,   &
+                                                           QVS, QCS, QIS, DENSX
+      REAL,  DIMENSION( ims:ime, kms:kme ), intent(in)  :: DZF
+      REAL,  DIMENSION( ims:ime, kms:kme ), intent(inout)   ::  utnp, &
+							        vtnp, &
+							        ttnp, &
+							        qvtnp, &
+							        qctnp, &
+							        qitnp
+      real,     dimension( ims:ime ), intent(in   )   ::   psfcpa
+      real,     dimension( ims:ime ), intent(in   )   ::   tg
+      real,     dimension( ims:ime ), intent(inout)   ::   regime
+      real,     dimension( ims:ime ), intent(in)      ::   wspd, psim, gz1oz0
+      real,     dimension( ims:ime ), intent(in)      ::   hfx, qfx
+      real,     dimension( ims:ime ), intent(in)      ::   mut
+
+!... Integer
+      INTEGER, DIMENSION( ims:ime ),       INTENT(OUT):: KLPBL
+      INTEGER,  INTENT(IN)      ::      XTIME
+      integer,  intent(in   )   ::      ids,ide, jds,jde, kds,kde, &
+                                        ims,ime, jms,jme, kms,kme, &
+                                        its,ite, jts,jte, kts,kte, j
+!--------------------------------------------------------------------
+!--Local 
+      INTEGER I, K     
+      INTEGER :: KPBLHT
+      INTEGER, DIMENSION( its:ite ) :: KPBLH, NOCONV
+
+!... Real
+      REAL    ::  TVCON, WSS, TCONV, TH1, TOG, DTMP, WSSQ
+      REAL    ::  psix, THV1
+      REAL, DIMENSION( its:ite )          :: FINT, PSTAR, CPAIR
+      REAL, DIMENSION( its:ite, kts:kte ) :: THETAV, RIB,             &
+                                             EDDYZ, UX, VX, THETAX,   &
+                                             QVX, QCX, QIX, ZA
+      REAL, DIMENSION( its:ite, 0:kte )   :: ZF
+      REAL,    DIMENSION( its:ite)           :: WST, TST, QST, USTM, TSTV
+      REAL,    DIMENSION( its:ite )          :: PBLSIG, MOL
+      REAL    ::  FINTT, ZMIX, UMIX, VMIX
+      REAL    ::  TMPFX, TMPVTCON, TMPP, TMPTHS, TMPTH1, TMPVCONV, WS1, DTH
+	REAL    ::  A,TST12,RL,ZFUNC
+!    REAL, PARAMETER :: KARMAN = 0.4
+
+!... Integer
+      INTEGER :: KL, jtf, ktf, itf, KMIX
+!...
+        character*256 :: message
+!-----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
+          qvtnp(i,k) = 0.
+        enddo
+      enddo
+!
+      do k = kts,kte
+        do i = its,ite
+          qctnp(i,k) = 0.
+          qitnp(i,k) = 0.
+        enddo
+      enddo
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!  Compute Micromet Scaling variables, not availiable in WRF for ACM
+     DO I = its,ite
+           cpair(i)     = CPD * (1.0 + 0.84 * QVS(I,1))           ! J/(K KG)
+           TMPFX        = HFX(I)  / (cpair(i) * DENSX(I,1))
+           TMPVTCON     = 1.0 + EP1 * QVS(I,1)              ! COnversion factor for virtual temperature
+           WS1          = SQRT(US(I,1)**2 + VS(I,1)**2)     ! Level 1 wind speed
+           TST(I)     = -TMPFX / UST(I)
+           QST(I)     = -QFX(I) / (UST(I)*DENSX(I,1))
+           USTM(I)    = UST(I) * WS1 / wspd(i)
+           THV1         = TMPVTCON * THETA(I,1) 
+           TSTV(I)      = TST(I)*TMPVTCON + THV1*EP1*QST(I)
+           IF(ABS(TSTV(I)).LT.1.0E-6) THEN
+             TSTV(I) = SIGN(1.0E-6,TSTV(I))
+           ENDIF
+           MOL(I) = THV1 * UST(i)**2/(KARMAN*G*TSTV(I))
+           WST(I) = UST(I) * (PBL(I)/(KARMAN*ABS(MOL(I)))) ** 0.333333       
+           PSTAR(I)   =  MUT(I)/1000.                        ! P* in cb 
+     ENDDO
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!... Compute PBL height
+
+!... compute the height of full- and half-sigma level above ground level
+     DO I = its,ite
+       ZF(I,0)    = 0.0
+       KLPBL(I)   = 1
+     ENDDO
+
+     DO K = kts, kte
+       DO I = its,ite
+         ZF(I,K) = DZF(I,K) + ZF(I,K-1)
+         ZA(I,K) = 0.5 * (ZF(I,K) + ZF(I,K-1))
+       ENDDO
+     ENDDO
+
+     DO K = kts, kte
+       DO I = its,ite
+         TVCON       = 1.0 + EP1 * QVS(I,K)
+         THETAV(I,K) = THETA(I,K) * TVCON
+       ENDDO
+     ENDDO
+
+
+!...  COMPUTE PBL WHERE RICHARDSON NUMBER = RIC (0.25) HOLTSLAG ET AL 1990  
+     DO 100 I = its,ite
+       if(MOL(I).LT.0.0 .AND. XTIME.GT.1) then
+         WSS   = (UST(I) ** 3 + 0.6 * WST(I) ** 3) ** 0.33333
+         TCONV = -8.5 * UST(I) * TSTV(I) / WSS
+         TH1   = THETAV(I,1) + TCONV
+       else
+         TH1   = THETAV(I,1)
+       endif
+
+99     KMIX = 1
+       DO K = 1,kte
+         DTMP   = THETAV(I,K) - TH1
+         IF (DTMP.LT.0.0) KMIX = K
+       ENDDO
+       IF(KMIX.GT.1) THEN
+         FINTT = (TH1 - THETAV(I,KMIX)) / (THETAV(I,KMIX+1)               &
+               - THETAV(I,KMIX))
+         ZMIX = FINTT * (ZA(I,KMIX+1)-ZA(I,KMIX)) + ZA(I,KMIX)
+         UMIX = FINTT * (US(I,KMIX+1)-US(I,KMIX)) + US(I,KMIX)
+         VMIX = FINTT * (VS(I,KMIX+1)-VS(I,KMIX)) + VS(I,KMIX)
+       ELSE
+         ZMIX = ZA(I,1)
+         UMIX = US(I,1)
+         VMIX = VS(I,1)
+       ENDIF
+       DO K = KMIX,kte
+         DTMP   = THETAV(I,K) - TH1
+         TOG = 0.5 * (THETAV(I,K) + TH1) / G
+         WSSQ = (US(I,K)-UMIX)**2                                     &
+              + (VS(I,K)-VMIX)**2
+         IF (KMIX == 1) WSSQ = WSSQ + 100.*UST(I)*UST(I) 
+         WSSQ = MAX( WSSQ, 0.1 )
+         RIB(I,K) = ABS(ZA(I,K)-ZMIX) * DTMP / (TOG * WSSQ)
+         IF (RIB(I,K) .GE. RIC) GO TO 201
+       ENDDO
+
+       write (message, *)' RIBX never exceeds RIC, RIB(i,kte) = ',rib(i,5),        &
+               ' THETAV(i,1) = ',thetav(i,1),' MOL=',mol(i),            &
+               ' TCONV = ',TCONV,' WST = ',WST(I),                      &
+               ' KMIX = ',kmix,' UST = ',UST(I),                       &
+               ' TST = ',TST(I),' U,V = ',US(I,1),VS(I,1),              &
+               ' I,J=',I,J
+       CALL wrf_error_fatal ( message )
+201    CONTINUE
+
+       KPBLH(I) = K
+
+100  CONTINUE
+
+     DO I = its,ite
+       IF (KPBLH(I) .NE. 1) THEN
+!---------INTERPOLATE BETWEEN LEVELS -- jp 7/93
+         FINT(I) = (RIC - RIB(I,KPBLH(I)-1)) / (RIB(I,KPBLH(I)) -       &
+                    RIB(I,KPBLH(I)-1))
+         IF (FINT(I) .GT. 0.5) THEN
+           KPBLHT  = KPBLH(I)
+           FINT(I) = FINT(I) - 0.5
+         ELSE
+           KPBLHT  = KPBLH(I) - 1
+           FINT(I) = FINT(I) + 0.5
+         ENDIF
+         PBL(I)  = FINT(I) * (ZF(I,KPBLHT) - ZF(I,KPBLHT-1)) +          &
+                     ZF(I,KPBLHT-1)
+         KLPBL(I) = KPBLHT
+         PBLSIG(I)   = FINT(I) * DSIGH(KPBLHT) + SIGMAF(KPBLHT-1)    ! sigma at PBL height
+       ELSE
+         KLPBL(I) = 1
+         PBL(I)    = ZF(I,1)                                                  
+         PBLSIG(I)   = SIGMAF(1)                                             
+       ENDIF
+
+     ENDDO
+
+     DO I = its,ite       
+       NOCONV(I) = 0
+       
+! Check for CBL and identify conv. vs. non-conv cells
+       IF (PBL(I) / MOL(I) .LT. -0.02 .AND. KLPBL(I) .GT. 3        &
+           .AND. THETAV(I,1) .GT. THETAV(I,2) .AND. XTIME .GT. 1) THEN
+          NOCONV(I)   = 1
+          REGIME(I) = 4.0                     ! FREE CONVECTIVE - ACM
+       ENDIF
+     ENDDO
+
+!... Calculate Kz
+     CALL EDDYX(DTPBL, ZF,  ZA,     MOL, PBL,  UST,                &
+                US,    VS,  TT,  THETAV, DENSX, PSTAR,              &
+                QVS,   QCS, QIS, DSIGFI, G, RD, CPAIR,              &
+                EDDYZ, its,ite, kts,kte,ims,ime, kms,kme)
+
+     CALL ACM(DTPBL, PSTAR,  NOCONV, SIGMAF, DSIGH, DSIGHI, J,      &
+                 KLPBL, PBL,   PBLSIG, MOL,  UST,                  &
+                 TST, QST,  USTM,   EDDYZ,  DENSX,                  &
+                 US,    VS,     THETA,  QVS,    QCS,    QIS,        &
+                 UX,    VX,     THETAX, QVX,    QCX,    QIX,        &
+                 ids,ide, jds,jde, kds,kde,                         &
+                 ims,ime, jms,jme, kms,kme,                         &
+                 its,ite, jts,jte, kts,kte)
+
+!... Calculate tendency due to PBL parameterization
+
+     DO K = kts, kte
+       DO I = its, ite
+         UTNP(I,K)  = UTNP(I,K) + (UX(I,K) - US(I,K)) * RDT
+         VTNP(I,K)  = VTNP(I,K) + (VX(I,K) - VS(I,K)) * RDT
+         TTNP(I,K)  = TTNP(I,K) + (THETAX(I,K) - THETA(I,K)) * RDT
+         QVTNP(I,K) = QVTNP(I,K) + (QVX(I,K) - QVS(I,K)) * RDT
+         QCTNP(I,K) = QCTNP(I,K) + (QCX(I,K) - QCS(I,K)) * RDT
+         QITNP(I,K) = QITNP(I,K) + (QIX(I,K) - QIS(I,K)) * RDT
+       ENDDO
+     ENDDO
+!     IF(J.EQ.36)PRINT *,' PBL,THETA,THETAX,QVS,QVX=',PBL(20),THETA(20,1),THETAX(20,1),QVS(20,1),QVX(20,1)
+!     IF(J.EQ.36)PRINT *,' UST,ustm,TG,TST=',UST(20),ustm(20),Tg(20),TST(20)
+!     IF(J.EQ.36)PRINT *,' HFX,MOL,WST,WSPD=',HFX(20),MOL(20),WST(20),wspd(20)
+!     IF(J.EQ.36)then
+!       i=20
+!       do k=1,kte
+!         PRINT *,' qvten,uten,vten=',QVTNP(I,K),UTNP(I,K),VTNP(I,K)
+!         PRINT *,' k,thten,th,thx,edy=',k,TTNP(I,K),THETA(20,k),THETAX(20,k),EDDYZ(20,K)
+!       enddo
+!     ENDIF
+   END SUBROUTINE ACM2D
+
+!-------------------------------------------------------------------          
+   SUBROUTINE ACMINIT(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                 )
+!**********************************************************************
+!
+!    This subroutine is for preparing ACM PBL variables. 
+!    Called from module_physics_init.F
+!
+!  REVISION HISTORY:
+!     AX     3/2005 - Originally developed
+!**********************************************************************
+!   ARGUMENT LIST:
+!
+!-------------------------------------------------------------------
+     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( kms:kme ), INTENT(IN)  :: SHALF
+   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::         &
+                                                         RUBLTEN, &
+                                                         RVBLTEN, &
+                                                         RTHBLTEN, &
+                                                         RQVBLTEN, &
+                                                         RQCBLTEN, & 
+                                                         RQIBLTEN
+
+!... Local Variables
+   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 acminit
+
+!-------------------------------------------------------------------          
+   SUBROUTINE EDDYX(DTPBL, ZF,  ZA,     MOL, PBL,  UST,               &
+                    US,    VS,  TT,  THETAV, DENSX, PSTAR,            &
+                    QVS,   QCS, QIS, DSIGFI, G, RD, CPAIR,            &
+                    EDDYZ, its,ite, kts,kte,ims,ime,kms,kme )
+
+
+!**********************************************************************
+!   Two methods for computing Kz:
+!   1.  Boundary scaling similar to Holtslag and Boville (1993)
+!   2.  Local Kz computed as function of local Richardson # and vertical 
+!       wind shear, similar to LIU & CARROLL (1996)
+!
+!**********************************************************************
+!
+!-- DTPBL           time step of the minor loop for the land-surface/pbl model
+!-- ZF              height of full sigma level
+!-- ZA              height of half sigma level
+!-- MOL             Monin-Obukhov length in 1D form
+!-- PBL             PBL height in 1D form
+!-- UST             friction velocity U* in 1D form (m/s)
+!-- US              U wind 
+!-- VS              V wind
+!-- TT              temperature
+!-- THETAV          potential virtual temperature
+!-- DENSX           dry air density (kg/m^3)
+!-- PSTAR           P*=Psfc-Ptop
+!-- QVS             water vapor mixing ratio (Kg/Kg)
+!-- QCS             cloud mixing ratio (Kg/Kg)
+!-- QIS             ice mixing ratio (Kg/Kg)
+!-- DSIGFI          inverse of sigma layer delta
+!-- G               gravity
+!-- RD              gas constant for dry air (j/kg/k)
+!-- CPAIR           specific heat of moist air (M^2 S^-2 K^-1)
+!-- EDDYZ           eddy diffusivity KZ
+!-----------------------------------------------------------------------
+
+      IMPLICIT NONE
+
+!.......Arguments
+  
+!... Integer
+      INTEGER,  INTENT(IN)   ::    its,ite, kts,kte,ims,ime,kms,kme
+!... Real
+      REAL , DIMENSION( ims:ime ),          INTENT(IN)  :: PBL, UST
+      REAL ,                                INTENT(IN)  :: DTPBL, G, RD
+      REAL , DIMENSION( kts:kte ),          INTENT(IN)  :: DSIGFI
+      REAL , DIMENSION( its:ite ),          INTENT(IN)  :: MOL, PSTAR, CPAIR
+
+      REAL , DIMENSION( ims:ime, kms:kme ), INTENT(IN)  :: US,VS, TT,   &
+                                                           QVS, QCS, QIS, DENSX
+      REAL, DIMENSION( its:ite, kts:kte ), INTENT(IN) :: ZA, THETAV
+      REAL, DIMENSION( its:ite, 0:kte )  , INTENT(IN) :: ZF
+      
+      REAL , DIMENSION( its:ite, kts:kte ), INTENT(OUT) :: EDDYZ
+
+!.......Local variables
+
+!... Integer
+      INTEGER  :: ILX, KL, KLM, K, I
+
+!... Real
+      REAL     :: ZOVL, PHIH, WT, ZSOL, ZFUNC, DZF, SS, GOTH, EDYZ
+      REAL     :: RI, QMEAN, TMEAN, XLV, ALPH, CHI, ZK, SQL, DENSF,kzo
+
+!... Parameters
+      REAL, PARAMETER :: RV     = 461.5
+      REAL, PARAMETER :: RC     = 0.25
+      REAL, PARAMETER :: RLAM   = 80.0
+      REAL, PARAMETER :: GAMH   = 16.0 !15.0  !  Holtslag and Boville (1993)
+      REAL, PARAMETER :: BETAH  = 5.0   !  Holtslag and Boville (1993)
+      REAL, PARAMETER :: KARMAN = 0.4
+      REAL, PARAMETER :: EDYZ0  = 0.01  ! New Min Kz
+!      REAL, PARAMETER :: EDYZ0  = 0.1
+!-- IMVDIF      imvdif=1 for moist adiabat vertical diffusion
+      INTEGER, PARAMETER :: imvdif = 1
+!
+      ILX = ite 
+      KL  = kte
+      KLM = kte - 1
+      
+      DO K = kts,KLM
+        DO I = its,ILX
+          EDYZ = 0.0
+          ZOVL = 0.0
+          DZF  = ZA(I,K+1) - ZA(I,K)
+!          kzo = min(0.001 * dzf,EDYZ0)
+          kzo = 0.001 * dzf
+!          kzo = EDYZ0
+!-------------------------------------------------
+          IF (ZF(I,K) .LT. PBL(I)) THEN
+            ZOVL = ZF(I,K) / MOL(I)
+            IF (ZOVL .LT. 0.0) THEN
+              IF (ZF(I,K) .LT. 0.1 * PBL(I)) THEN
+                PHIH = 1.0 / SQRT(1.0 - GAMH * ZOVL)
+                WT   = UST(I) / PHIH
+              ELSE
+                ZSOL = 0.1 * PBL(I) / MOL(I)
+                PHIH = 1.0 / SQRT(1.0 - GAMH * ZSOL)
+                WT   = UST(I) / PHIH
+              ENDIF
+            ELSE IF (ZOVL .LT. 1.0) THEN
+              PHIH = 1.0 + BETAH * ZOVL
+              WT   = UST(I) / PHIH
+            ELSE
+              PHIH = BETAH + ZOVL
+              WT   = UST(I) / PHIH
+            ENDIF
+            ZFUNC      = ZF(I,K) * (1.0 - ZF(I,K) / PBL(I)) ** 2
+            EDYZ = KARMAN * WT * ZFUNC
+!            EDYZ = AMAX1(EDYZ,EDYZ0)
+         ENDIF
+ !            PRINT *,I,K,TT(I,K)
+ !--------------------------------------------------------------------------
+!
+!          RC = 0.257 * DZF ** 0.175
+            SS   = ((US(I,K+1) - US(I,K)) ** 2 + (VS(I,K+1) - VS(I,K)) ** 2)   &
+                  / (DZF * DZF) + 1.0E-9
+            GOTH = 2.0 * G / (THETAV(I,K+1) + THETAV(I,K))
+            RI   = GOTH * (THETAV(I,K+1) - THETAV(I,K)) / (DZF * SS)
+!            PRINT *,I,K,TT(I,K), RI, IMVDIF
+!
+!-- Adjustment to vert diff in Moist air
+          if(imvdif.eq.1)then
+            IF ((QCS(I,K)+QIS(I,K)) .GT. 0.01E-3 .OR. (QCS(I,K+1)+             &
+                 QIS(I,K+1)) .GT. 0.01E-3) THEN
+              QMEAN = 0.5 * (QVS(I,K) + QVS(I,K+1))
+              TMEAN = 0.5 * (TT(I,K) + TT(I,K+1))
+              XLV   = (2.501 - 0.00237 * (TMEAN - 273.15)) * 1.E6
+              ALPH  =  XLV * QMEAN / RD / TMEAN
+              CHI   =  XLV * XLV * QMEAN / CPAIR(I) / RV / TMEAN / TMEAN
+              RI    = (1.0 + ALPH) * (RI -G * G / SS / TMEAN / CPAIR(I) *       &
+                      ((CHI - ALPH) / (1.0 + CHI)))
+            ENDIF
+          endif
+            
+	    ZK  = 0.4 * ZF(I,K)
+            SQL = (ZK * RLAM / (RLAM + ZK)) ** 2
+            
+	    IF (RI .GE. RC) THEN
+              EDDYZ(I,K) = kzo !EDYZ0
+            ELSE IF (RI .GE. 0.0) THEN
+              EDDYZ(I,K) = kzo + SQRT(SS) * (1.- RI / RC) ** 2 * SQL
+            ELSE
+              EDDYZ(I,K) = kzo + SQRT(SS * (1.0 - 25.0 * RI)) * SQL
+            ENDIF
+	  
+          IF(ZOVL.LT.0.0.AND.EDYZ.GT.EDDYZ(I,K)) THEN
+            EDDYZ(I,K) = EDYZ
+          ENDIF
+
+          EDDYZ(I,K) = MIN(1000.0,EDDYZ(I,K))
+          EDDYZ(I,K) = MAX(kzo,EDDYZ(I,K))
+
+          DENSF     = 0.5 * (DENSX(I,K+1) + DENSX(I,K))
+
+          EDDYZ(I,K) = EDDYZ(I,K) * (DENSF * G / PSTAR(I)) ** 2 *       &
+                       DTPBL * DSIGFI(K)*1E-6
+        ENDDO             ! for I loop
+      ENDDO               ! for k loop
+!
+      DO I = its,ILX
+        EDDYZ(I,KL) = 0.0 ! EDDYZ(I,KLM) -- changed jp 3/08
+      ENDDO
+   END SUBROUTINE EDDYX
+
+!-------------------------------------------------------------------          
+   SUBROUTINE ACM (DTPBL, PSTAR,  NOCONV, SIGMAF, DSIGH, DSIGHI, JX, &
+                   KLPBL, PBL,   PBLSIG, MOL,  UST,                  &
+                   TST, QST,  USTM,   EDDYZ,  DENSX,               &
+                   US,    VS,     THETA,  QVS,    QCS,    QIS,     &
+                   UX,    VX,     THETAX, QVX,    QCX,    QIX,     &
+                   ids,ide, jds,jde, kds,kde,                      &
+                   ims,ime, jms,jme, kms,kme,                      &
+                   its,ite, jts,jte, kts,kte)
+!**********************************************************************
+!   PBL model called the Asymmetric Convective Model, Version 2 (ACM2) 
+!   -- See top of module for summary and references
+!
+!---- REVISION HISTORY:
+!   AX     3/2005 - developed WRF version based on ACM2 in the MM5 PX LSM
+!   JP and RG 8/2006 - updates
+!
+!**********************************************************************
+!  ARGUMENTS:
+!-- DTPBL           PBL time step
+!-- PSTAR           Psurf - Ptop in cb
+!-- NOCONV          If free convection =0, no; =1, yes
+!-- SIGMAF          Sigma for full layer
+!-- DSIGH           Sigma thickness
+!-- DSIGHI          Inverse of sigma thickness
+!-- JX              N-S index
+!-- KLPBL           PBL level at K index
+!-- PBL             PBL height in m
+!-- PBLSIG          Sigma level for PBL 
+!-- MOL             Monin-Obukhov length in 1D form
+!-- UST             U* in 1D form
+!-- TST             Theta* in 1D form
+!-- QST             Q* in 1D form
+!-- USTM            U* for computation of momemtum flux 
+!-- EDDYZ           eddy diffusivity KZ
+!-- DENSX           dry air density (kg/m^3)
+!-- US              U wind 
+!-- VS              V wind
+!-- THETA           potential temperature
+!-- QVS             water vapor mixing ratio (Kg/Kg)
+!-- QCS             cloud mixing ratio (Kg/Kg)
+!-- QIS             ice mixing ratio (Kg/Kg)
+!-- UX              new U wind 
+!-- VX              new V wind
+!-- THETAX          new potential temperature
+!-- QVX             new water vapor mixing ratio (Kg/Kg)
+!-- QCX             new cloud mixing ratio (Kg/Kg)
+!-- QIX             new ice mixing ratio (Kg/Kg)
+!-----------------------------------------------------------------------
+
+      IMPLICIT NONE
+
+!.......Arguments
+
+!... Integer
+      INTEGER,  INTENT(IN)      ::      ids,ide, jds,jde, kds,kde, &
+                                        ims,ime, jms,jme, kms,kme, &
+                                        its,ite, jts,jte, kts,kte, JX
+      INTEGER,  DIMENSION( its:ite ), INTENT(IN)  :: NOCONV
+      INTEGER,  DIMENSION( ims:ime ), INTENT(IN)  :: KLPBL
+
+!... Real
+      REAL , DIMENSION( ims:ime ),          INTENT(IN)  :: PBL, UST
+      REAL ,                                INTENT(IN)  :: DTPBL
+      REAL , DIMENSION( its:ite ),          INTENT(IN)  :: PSTAR, PBLSIG,  &
+                                                           MOL, TST, &
+                                                           QST, USTM
+      REAL , DIMENSION( kts:kte ),          INTENT(IN)  :: DSIGHI, DSIGH
+      REAL , DIMENSION( 0:kte ),            INTENT(IN)  :: SIGMAF
+      REAL , DIMENSION( its:ite, kts:kte ), INTENT(INOUT)  :: EDDYZ
+      REAL , DIMENSION( ims:ime, kms:kme ), INTENT(IN)  :: US,VS, THETA,   &
+                                                           QVS, QCS, QIS, DENSX
+      REAL , DIMENSION( its:ite, kts:kte ), INTENT(OUT) :: UX, VX, THETAX,      &
+                                                           QVX, QCX, QIX
+
+!.......Local variables
+
+!... Parameters
+      INTEGER, PARAMETER :: NSP   = 6
+!
+!......ACM2 Parameters
+!     INTEGER, PARAMETER :: IFACM = 0
+!
+      REAL,    PARAMETER :: G1000 = 9.8 * 1.0E-3
+      REAL,    PARAMETER :: XX    = 0.5          ! FACTOR APPLIED TO CONV MIXING TIME STEP
+      REAL,    PARAMETER :: KARMAN = 0.4
+
+!... Integer
+      INTEGER :: ILX, KL, KLM, I, K, NSPX, NLP, NL, JJ, L
+      INTEGER :: KCBLMX
+      INTEGER, DIMENSION( its:ite ) :: KCBL
+
+!... Real
+      REAL                               :: G1000I, MBMAX, HOVL, MEDDY, MBAR
+      REAL                               :: EKZ, RZ, FM, WSPD, DTS, DTRAT, F1
+      REAL, DIMENSION( its:ite )         :: PSTARI, FSACM, RAH, DTLIM
+      REAL, DIMENSION( kts:kte, its:ite) :: MBARKS, MDWN
+      REAL, DIMENSION( 1:NSP, its:ite )  :: FS, BCBOTN
+      REAL, DIMENSION( kts:kte )         :: XPLUS, XMINUS
+      REAL  DELC
+      REAL, DIMENSION( 1:NSP,its:ite,kts:kte  ) :: VCI
+
+      REAL, DIMENSION( kts:kte )               :: AI, BI, CI, EI !, Y
+      REAL, DIMENSION( 1:NSP,kts:kte )         :: DI, UI    
+!
+!--Start Exicutable ----
+
+      ILX = ite
+      KL  = kte
+      KLM = kte - 1
+
+      G1000I = 1.0 / G1000
+      KCBLMX = 0
+      MBMAX  = 0.0
+
+!---COMPUTE ACM MIXING RATE
+      DO I = its, ILX
+        DTLIM(I)  = DTPBL
+        PSTARI(I) = 1.0 / PSTAR(I)
+        KCBL(I)   = 1
+        FSACM(I)  = 0.0
+
+     IF (NOCONV(I) .EQ. 1) THEN
+          KCBL(I) = KLPBL(I)
+!-------MBARKS IS UPWARD MIXING RATE; MDWN IS DOWNWARD MIXING RATE
+!--New couple ACM & EDDY-------------------------------------------------------------
+          HOVL     = -PBL(I) / MOL(I)
+          FSACM(I) = 1./(1.+((KARMAN/(HOVL))**0.3333)/(0.72*KARMAN))
+          MEDDY    = EDDYZ(I,1) / (DTPBL * (PBLSIG(I) - SIGMAF(1)))
+          MBAR     = MEDDY * FSACM(I)
+          DO K = kts,KCBL(I)-1
+            EDDYZ(I,K) = EDDYZ(I,K) * (1.0 - FSACM(I))
+          ENDDO
+!          if(i.eq.100.and.jx.eq.43) PRINT *,' Edy,meddy,mbar=', EDDYZ(I,1),MEDDY,MBAR
+          MBMAX = AMAX1(MBMAX,MBAR)
+          DO K = kts+1,KCBL(I)
+            MBARKS(K,I) = MBAR
+            MDWN(K,I)   = MBAR * (PBLSIG(I) - SIGMAF(K-1)) * DSIGHI(K)
+          ENDDO
+          MBARKS(1,I) = MBAR
+          MBARKS(KCBL(I),I) = MDWN(KCBL(I),I)
+          MDWN(KCBL(I)+1,I) = 0.0
+        ENDIF
+      ENDDO                              ! end of I loop
+
+!      if(NOCONV(20).EQ.1) print *,' KCBL,PBLSIG=',KCBL(20),PBLSIG(20),SIGMAF(KCBL(20)-1),DSIGHI(KCBL(20))
+!      do k = kts,klm
+!        if(NOCONV(20).EQ.1.and.MBAR.lt.1.0e-3)print *,' k,MBARKS,MDWN=',k,MBARKS(k,20),MDWN(k,20)
+!      enddo
+
+       DO K = kts,KLM
+         DO I = its,ILX
+          EKZ   = EDDYZ(I,K) / DTPBL * DSIGHI(K)
+          DTLIM(I) = AMIN1(0.75 / EKZ,DTLIM(I))
+         ENDDO
+       ENDDO
+       
+      DO I = its,ILX 
+        IF (NOCONV(I) .EQ. 1) THEN
+          KCBLMX = AMAX0(KLPBL(I),KCBLMX)
+          RZ     = (SIGMAF(KCBL(I)) - SIGMAF(1)) * DSIGHI(1)
+          DTLIM(I)  = AMIN1(XX / (MBARKS(1,I) * RZ),DTLIM(I))
+        ENDIF
+      ENDDO
+
+      DO I = its,ILX
+      ENDDO
+!
+      DO K = kts,KL
+        DO I = its,ILX
+          VCI(1,I,K) = THETA(I,K)
+          VCI(2,I,K) = QVS(I,K)
+          VCI(3,I,K) = US(I,K)
+          VCI(4,I,K) = VS(I,K)
+          ! -- Also mix cloud water and ice if necessary
+          ! IF (IMOISTX.NE.1.AND.IMOISTX.NE.3) THEN  !!! Check other PBL models
+          VCI(5,I,K) = QCS(I,K)
+          VCI(6,I,K) = QIS(I,K)
+        ENDDO
+      ENDDO
+
+      NSPX=6
+
+      DO I = its,ILX
+!       RAH(I)  = RA(I,J) + 3.976 / UST(I)
+        FS(1,I) = -UST(I) * TST(I) * DENSX(I,1) * PSTARI(I)
+        FS(2,I) = -UST(I) * QST(I) * DENSX(I,1) * PSTARI(I)
+        FM      = -USTM(I) * USTM(I) * DENSX(I,1) * PSTARI(I)
+        WSPD    = SQRT(US(I,1) * US(I,1) + VS(I,1) * VS(I,1)) + 1.E-9
+        FS(3,I) = FM * US(I,1) / WSPD
+        FS(4,I) = FM * VS(I,1) / WSPD
+        FS(5,I) = 0.0
+        FS(6,I) = 0.0                      ! SURFACE FLUXES OF CLOUD WATER AND ICE = 0
+      ENDDO
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      DO I = its,ILX      
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+        NLP   = INT(DTPBL / DTLIM(I) + 1.0)
+        DTS   = (DTPBL / NLP)
+        DTRAT = DTS / DTPBL
+        DO NL = 1,NLP           ! LOOP OVER SUB TIME LOOP              
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!-- COMPUTE ARRAY ELEMENTS THAT ARE INDEPENDANT OF SPECIES
+
+          DO K = kts,KL
+            AI(K) = 0.0
+            BI(K) = 0.0
+            CI(K) = 0.0
+            EI(K) = 0.0
+          ENDDO
+
+          DO K = 2, KCBL(I)
+            EI(K-1) = -CRANKP * MDWN(K,I) * DTS * DSIGH(K) * DSIGHI(K-1)
+            BI(K)   = 1.0 + CRANKP * MDWN(K,I) * DTS
+            AI(K)   = -CRANKP * MBARKS(K,I) * DTS
+          ENDDO
+
+          EI(1) = EI(1) -EDDYZ(I,1) * CRANKP * DSIGHI(1 )* DTRAT
+          AI(2) = AI(2) -EDDYZ(I,1) * CRANKP * DSIGHI(2) * DTRAT
+
+          DO K =  KCBL(I)+1, KL
+            BI(K) = 1.0
+          ENDDO
+
+          DO K = 2,KL
+            XPLUS(K)  = EDDYZ(I,K) * DSIGHI(K) * DTRAT
+            XMINUS(K) = EDDYZ(I,K-1) * DSIGHI(K) * DTRAT
+            CI(K)     = - XMINUS(K) * CRANKP
+            EI(K)     = EI(K) - XPLUS(K) * CRANKP
+            BI(K)     = BI(K) + XPLUS(K) * CRANKP + XMINUS(K) * CRANKP
+          ENDDO
+
+          IF (NOCONV(I) .EQ. 1) THEN
+            BI(1) = 1.0 + CRANKP * MBARKS(1,I) * (PBLSIG(I) - SIGMAF(1)) *    &
+                    DTS * DSIGHI(1) + EDDYZ(I,1) * DSIGHI(1) * CRANKP * DTRAT
+      ELSE
+        BI(1) = 1.0  + EDDYZ(I,1) * DSIGHI(1) * CRANKP * DTRAT
+      ENDIF
+
+
+      DO K = 1,KL
+        DO L = 1,NSPX                    
+           DI(L,K) = 0.0
+        ENDDO
+     ENDDO
+!
+!**   COMPUTE TENDENCY OF CBL CONCENTRATIONS - SEMI-IMPLICIT SOLUTION
+     DO K = 2,KCBL(I)
+       DO L = 1,NSPX                    
+          DELC = DTS * (MBARKS(K,I) * VCI(L,I,1) - MDWN(K,I) *          &
+                 VCI(L,I,K) + DSIGH(K+1) * DSIGHI(K) *                  &
+                        MDWN(K+1,I) * VCI(L,I,K+1))
+          DI(L,K)   = VCI(L,I,K) + (1.0 - CRANKP) * DELC
+       ENDDO
+     ENDDO
+
+     DO K = KCBL(I)+1, KL
+       DO L = 1,NSPX                    
+         DI(L,K) = VCI(L,I,K)
+       ENDDO
+     ENDDO
+
+     DO K = 2,KL
+       IF (K .EQ. KL) THEN
+         DO L = 1,NSPX                    
+           DI(L,K) = DI(L,K)  - (1.0 - CRANKP) * XMINUS(K) *                  &
+                     (VCI(L,I,K) - VCI(L,I,K-1))
+         ENDDO
+       ELSE
+         DO L = 1,NSPX                    
+           DI(L,K) = DI(L,K) + (1.0 - CRANKP) * XPLUS(K) *                   &
+                      (VCI(L,I,K+1) - VCI(L,I,K))  -                         &
+                      (1.0 - CRANKP) * XMINUS(K) *                           &
+                      (VCI(L,I,K) - VCI(L,I,K-1))
+         ENDDO
+       ENDIF
+     ENDDO
+
+     IF (NOCONV(I) .EQ. 1) THEN
+       DO L = 1,NSPX                    
+         F1    = -G1000I * (MBARKS(1,I) *                                &
+                 (PBLSIG(I) - SIGMAF(1)) * VCI(L,I,1) -                  &
+                  MDWN(2,I) * VCI(L,I,2) * DSIGH(2))
+
+         DI(L,1) = VCI(L,I,1) - G1000 * (FS(L,I) - (1.0 - CRANKP)        &
+                 * F1) * DSIGHI(1) * DTS
+       ENDDO
+      ELSE
+        DO L = 1,NSPX                    
+          DI(L,1) = VCI(L,I,1) - G1000 * FS(L,I) * DSIGHI(1) * DTS
+        ENDDO
+      ENDIF
+      DO L = 1,NSPX                    
+        DI(L,1) = DI(L,1) + (1.0 - CRANKP) * EDDYZ(I,1) * DSIGHI(1)      &
+                * DTRAT * (VCI(L,I,2) - VCI(L,I,1))
+      ENDDO
+      IF ( NOCONV(I) .EQ. 1 ) THEN
+        CALL MATRIX (AI, BI, CI, DI, EI, UI, KL, NSPX)
+      ELSE
+        CALL TRI (CI, BI, EI, DI, UI, KL, NSPX)
+      END IF
+!
+!-- COMPUTE NEW THETAV AND Q
+         DO K = 1,KL
+           DO L = 1,NSPX                    
+              VCI(L,I,K) = UI(L,K)
+           ENDDO
+         ENDDO
+!
+        ENDDO                   ! END I LOOP
+      ENDDO                     ! END SUB TIME LOOP
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!
+      DO K = kts,KL
+        DO I = its,ILX
+          THETAX(I,K) = VCI(1,I,K)
+          QVX(I,K)    = VCI(2,I,K)
+          UX(I,K)     = VCI(3,I,K)
+          VX(I,K)     = VCI(4,I,K)
+!            IF( (I.EQ.61 .OR. I.EQ.15) .AND. JX.EQ.22) THEN
+!               PRINT *,'TEST -->',I,K,THETAX(I,K)
+!            ENDIF
+        ENDDO
+      ENDDO
+
+      DO K = kts,KL
+        DO I = its,ILX
+          QCX(I,K) = VCI(5,I,K)
+          QIX(I,K) = VCI(6,I,K)
+        ENDDO
+      ENDDO
+!      ENDIF
+
+   END SUBROUTINE ACM
+!--------------------------------------------------------
+
+   SUBROUTINE MATRIX(A,B,C,D,E,X,KL,NSP)
+   
+   IMPLICIT NONE
+!
+!-- Bordered band diagonal matrix solver for ACM2
+
+!-- ACM2 Matrix is in this form:
+!   B1 E1
+!   A2 B2 E2
+!   A3 C3 B3 E3
+!   A4    C4 B4 E4
+!   A5       C5 B5 E5
+!   A6          C6 B6
+
+!--Upper Matrix is
+!  U11 U12
+!      U22 U23
+!          U33 U34
+!              U44 U45
+!                  U55 U56
+!                      U66
+
+!--Lower Matrix is:
+!  1
+! L21  1
+! L31 L32  1
+! L41 L42 L43  1
+! L51 L52 L53 L54  1
+! L61 L62 L63 L64 L65 1
+!---------------------------------------------------------
+!...Arguments
+      INTEGER, INTENT(IN)   :: KL
+      INTEGER, INTENT(IN)   :: NSP
+      REAL A(KL),B(KL),E(KL)
+      REAL C(KL),D(NSP,KL),X(NSP,KL)
+
+!...Locals
+      REAL Y(NSP,KL),AIJ,SUM
+      REAL L(KL,KL),UII(KL),UIIP1(KL),RUII(KL)
+      INTEGER I,J,V
+
+!-- Define Upper and Lower matrices
+      L(1,1) = 1.
+!      U(1,1) = B(1)
+      UII(1) = B(1)
+      RUII(1) = 1./UII(1)
+      DO I = 2, KL
+	L(I,I) = 1.
+	L(I,1) = A(I)/B(1)
+!        U(I-1,I) =E(I-1)
+        UIIP1(I-1)=E(I-1)
+	IF(I.GE.3) THEN
+	   DO J = 2,I-1
+	     IF(I.EQ.J+1) THEN
+	        AIJ = C(I)
+	     ELSE
+	        AIJ = 0.
+	     ENDIF
+	     L(I,J) = (AIJ-L(I,J-1)*E(J-1))/      &
+                      (B(J)-L(J,J-1)*E(J-1))
+	   ENDDO
+	  ENDIF
+      ENDDO
+	  
+      DO I = 2,KL
+!        U(I,I) = B(I)-L(I,I-1)*E(I-1)
+        UII(I) = B(I)-L(I,I-1)*E(I-1)
+        RUII(I) = 1./UII(I)
+      ENDDO
+  
+!-- Forward sub for Ly=d
+      DO V= 1, NSP
+        Y(V,1) = D(V,1)
+        DO I=2,KL
+	  SUM = D(V,I)
+	  DO J=1,I-1
+	    SUM = SUM - L(I,J)*Y(V,J)
+	  ENDDO
+	  Y(V,I) = SUM
+        ENDDO
+      ENDDO
+
+!-- Back sub for Ux=y
+
+      DO V= 1, NSP
+!        X(V,KL) = Y(V,KL)/U(KL,KL)
+        X(V,KL) = Y(V,KL)*RUII(KL)
+      ENDDO
+      DO I = KL-1,1,-1
+        DO V= 1, NSP
+!	  X(V,I) = (Y(V,I)-U(I,I+1)*X(V,I+1))/U(I,I)
+         X(V,I) = (Y(V,I)-UIIP1(I)*X(V,I+1))*RUII(I)
+        ENDDO
+      ENDDO
+
+   END SUBROUTINE MATRIX
+!:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
+      SUBROUTINE TRI ( L, D, U, B, X,KL,NSP)
+!-----------------------------------------------------------------------
+
+!  FUNCTION:
+!    Solves tridiagonal system by Thomas algorithm. 
+! The associated tri-diagonal system is stored in 3 arrays
+!   D : diagonal
+!   L : sub-diagonal
+!   U : super-diagonal
+!   B : right hand side function
+!   X : return solution from tridiagonal solver
+
+!     [ D(1) U(1) 0    0    0 ...       0     ]
+!     [ L(2) D(2) U(2) 0    0 ...       .     ]
+!     [ 0    L(3) D(3) U(3) 0 ...       .     ]
+!     [ .       .     .     .           .     ] X(i) = B(i)
+!     [ .             .     .     .     0     ]
+!     [ .                   .     .     .     ]
+!     [ 0                           L(n) D(n) ]
+
+!-----------------------------------------------------------------------
+
+      IMPLICIT NONE
+
+! Arguments:
+
+      INTEGER, INTENT(IN)   :: KL
+      INTEGER, INTENT(IN)   :: NSP
+
+      REAL        L( KL )               ! subdiagonal
+      REAL        D(KL)   ! diagonal
+      REAL        U( KL )               ! superdiagonal
+      REAL        B(NSP,KL )   ! R.H. side
+      REAL        X( NSP,KL )   ! solution
+
+! Local Variables:
+
+      REAL        GAM( KL )
+      REAL        BET
+      INTEGER     V, K
+
+! Decomposition and forward substitution:
+      BET = 1.0 / D( 1 )
+      DO V = 1, NSP
+         X( V,1 ) = BET * B(V,1 )
+      ENDDO
+
+      DO K = 2, KL
+         GAM(K ) = BET * U( K-1 )
+         BET = 1.0 / ( D( K ) - L( K ) * GAM( K ) )
+	 DO V = 1, NSP
+            X( V, K ) = BET * ( B( V,K ) - L( K ) * X( V,K-1 ) )
+	 ENDDO
+      END DO
+
+! Back-substitution:
+
+      DO K = KL - 1, 1, -1
+         DO V = 1, NSP
+            X( V,K ) = X( V,K ) - GAM( K+1 ) * X( V,K+1 )
+         END DO
+      ENDDO
+     
+  END SUBROUTINE TRI
+
+END MODULE module_bl_acm
+                        
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_boulac.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_boulac.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_boulac.F	(revision 17)
@@ -0,0 +1,921 @@
+MODULE module_bl_boulac
+
+!USE module_model_constants
+    
+
+!------------------------------------------------------------------------
+!    Calculation of the tendency due to momentum, heat 
+!    and moisture turbulent fluxes follwing the approach 
+!    of Bougeault and Lacarrere, 1989 (MWR, 117, 1872-1890).
+!    The scheme computes a prognostic ecuation for TKE and derives 
+!    dissipation and turbulent coefficients using length scales.
+!    
+!    Subroutine written by Alberto Martilli, CIEMAT, Spain,
+!    e-mail:alberto_martilli@ciemat.es
+!    August 2006.
+!------------------------------------------------------------------------
+! IN THIS VERSION TKE IS NOT ADVECTED!!!!
+! TO BE CHANGED IN THE FUTURE
+! 
+! -----------------------------------------------------------------------
+!  Constant used in the module
+!  ck_b=constant used in the compuation of diffusion coefficients
+!  ceps_b=constant used inthe computation of dissipation
+!  temin= minimum value allowed for TKE
+!  vk=von karman constant
+! -----------------------------------------------------------------------
+
+      real ck_b,ceps_b,vk,temin    ! constant for Bougeault and Lacarrere    
+      parameter(ceps_b=1/1.4,ck_b=0.4,temin=0.0001,vk=0.4) ! impose minimum values for tke similar to those of MYJ
+! -----------------------------------------------------------------------     
+
+
+   CONTAINS
+ 
+      subroutine boulac(frc_urb2d,idiff,flag_bep,dz8w,dt,u_phy,v_phy   & 
+                      ,th_phy,rho,qv_curr,hfx                                  &
+                      ,qfx,ustar,cp,g                                          &
+                      ,rublten,rvblten,rthblten                                &
+                      ,rqvblten,rqcblten                        & 
+                      ,tke,dlk,wu,wv,wt,wq,exch_h,exch_m,pblh        &
+                      ,a_u_bep,a_v_bep,a_t_bep,a_q_bep          &
+                      ,a_e_bep,b_u_bep,b_v_bep                  &
+                      ,b_t_bep,b_q_bep,b_e_bep,dlg_bep          &
+                      ,dl_u_bep,sf_bep,vl_bep                   &                 
+                      ,ids,ide, jds,jde, kds,kde                &
+                      ,ims,ime, jms,jme, kms,kme                &
+                      ,its,ite, jts,jte, kts,kte)                    
+
+      implicit none
+
+
+
+!-----------------------------------------------------------------------
+!     Input
+!------------------------------------------------------------------------
+   INTEGER::                        ids,ide, jds,jde, kds,kde,  &
+                                    ims,ime, jms,jme, kms,kme,  &
+                                    its,ite, jts,jte, kts,kte
+ 
+   integer, INTENT(IN) :: idiff
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::   DZ8W      !vertical resolution       
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::   qv_curr   !moisture  
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::   RHO       !air density
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::   TH_PHY    !potential temperature
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::   U_PHY     !x-component of wind
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::   V_PHY     !y-component of wind
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )    ::   ustar              !friction velocity
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )    ::   hfx                !sensible heat flux (W/m2) at surface 
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )    ::   qfx                !moisture flux at surface
+   real,  INTENT(IN   )    :: g,cp                                              !gravity and Cp
+   REAL, INTENT(IN )::   DT                                                      ! Time step
+
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )    ::   FRC_URB2D          !fraction cover urban
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT)    ::   PBLH          !PBL height
+!
+! variable added for urban
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::a_u_bep        ! Implicit component for the momemtum in X-direction
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::a_v_bep        ! Implicit component for the momemtum in Y-direction
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::a_t_bep        ! Implicit component for the Pot. Temp.
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::a_q_bep        ! Implicit component for Moisture
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::a_e_bep        ! Implicit component for the TKE
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::b_u_bep        ! Explicit component for the momemtum in X-direction
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::b_v_bep        ! Explicit component for the momemtum in Y-direction
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::b_t_bep        ! Explicit component for the Pot. Temp.
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::b_q_bep        ! Explicit component for Moisture
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::b_e_bep        ! Explicit component for the TKE
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT)    ::dlg_bep        ! Height above ground (L_ground in formula (24) of the BLM paper). 
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::dl_u_bep        ! Length scale (lb in formula (22) ofthe BLM paper).
+! urban surface and volumes        
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::sf_bep           ! surface of the urban grid cells
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   )    ::vl_bep             ! volume of the urban grid cells
+   LOGICAL, INTENT(IN) :: flag_bep                                             !flag for BEP
+                                                           
+!
+!-----------------------------------------------------------------------
+!     Local, carried on from one timestep to the other
+!------------------------------------------------------------------------
+!      real, save, allocatable, dimension (:,:,:)::TKE  ! Turbulent kinetic energy
+      real,  dimension (ims:ime, kms:kme, jms:jme)  ::th_0 ! reference state for potential temperature
+
+!------------------------------------------------------------------------
+!     Output
+!------------------------------------------------------------------------   
+        real, dimension( ims:ime, kms:kme, jms:jme ), INTENT(OUT   )    ::  exch_h ! exchange coefficient for heat
+        real, dimension( ims:ime, kms:kme, jms:jme ), INTENT(OUT   )    ::  exch_m ! exchange coefficient for momentum
+        real, dimension( ims:ime, kms:kme, jms:jme ), INTENT(INOUT   )    ::  tke  ! Turbulence Kinetic Energy 
+        real, dimension( ims:ime, kms:kme, jms:jme ), INTENT(OUT   )    ::  wu  ! Turbulent flux of momentum (x) 
+        real, dimension( ims:ime, kms:kme, jms:jme ), INTENT(OUT   )    ::  wv  ! Turbulent flux of momentum (y) 
+        real, dimension( ims:ime, kms:kme, jms:jme ), INTENT(OUT   )    ::  wt  ! Turbulent flux of temperature
+        real, dimension( ims:ime, kms:kme, jms:jme ), INTENT(OUT   )    ::  wq  ! Turbulent flux of water vapor
+        real, dimension( ims:ime, kms:kme, jms:jme ), INTENT(OUT   )    ::  dlk  ! Turbulent flux of water vapor
+! only if idiff not equal 1:
+        REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT   )    ::   RUBLTEN  !tendency for U_phy
+        REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT   )    ::   RVBLTEN  !tendency for V_phy
+        REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT   )    ::   RTHBLTEN !tendency for TH_phy
+        REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT   )    ::   RQVBLTEN !tendency for QV_curr
+        REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT   )    ::   RQCBLTEN !tendency for QV_curr
+
+!--------------------------------------------------------------
+! Local
+!--------------------------------------------------------------
+! 1D array used for the input and output of the routine boulac1D
+
+      real z1D(kms:kme)               ! vertical coordinates (faces of the grid)
+      real dz1D(kms:kme)              ! vertical resolution
+      real u1D(kms:kme)                 ! wind speed in the x directions
+      real v1D(kms:kme)                 ! wind speed in the y directions
+      real th1D(kms:kme)                ! potential temperature
+      real q1D(kms:kme)                 ! potential temperature
+      real rho1D(kms:kme)               ! air density
+      real rhoz1D(kms:kme)            ! air density at the faces
+      real tke1D(kms:kme)               ! air pressure
+      real th01D(kms:kme)               ! reference potential temperature
+      real dlk1D(kms:kme)               ! dlk
+      real dls1D(kms:kme)               ! dls
+      real exch1D(kms:kme)            ! exch
+      real sf1D(kms:kme)              ! surface of the grid cells
+      real vl1D(kms:kme)                ! volume of the  grid cells
+      real a_u1D(kms:kme)               ! Implicit component of the momentum sources or sinks in the X-direction
+      real a_v1D(kms:kme)               ! Implicit component of the momentum sources or sinks in the Y-direction
+      real a_t1D(kms:kme)               ! Implicit component of the heat sources or sinks
+      real a_q1D(kms:kme)               ! Implicit component of the moisture sources or sinks
+      real a_e1D(kms:kme)               ! Implicit component of the TKE sources or sinks
+      real b_u1D(kms:kme)               ! Explicit component of the momentum sources or sinks in the X-direction
+      real b_v1D(kms:kme)               ! Explicit component of the momentum sources or sinks in the Y-direction
+      real b_t1D(kms:kme)               ! Explicit component of the heat sources or sinks
+      real b_q1D(kms:kme)               ! Explicit component of the moisture sources or sinks
+      real b_e1D(kms:kme)               ! Explicit component of the TKE sources or sinks
+      real dlg1D(kms:kme)               ! Height above ground (L_ground in formula (24) of the BLM paper). 
+      real dl_u1D(kms:kme)              ! Length scale (lb in formula (22) ofthe BLM paper)
+      real sh1D(kms:kme)              ! shear
+      real bu1D(kms:kme)              ! buoyancy
+      real wu1D(kms:kme)              ! turbulent flux of momentum (x component)
+      real wv1D(kms:kme)              ! turbulent flux of momentum (y component)
+      real wt1D(kms:kme)              ! turbulent flux of temperature
+      real wq1D(kms:kme)              ! turbulent flux of water vapor
+! local added only for diagnostic output
+      real a_e(ims:ime,kms:kme,jms:jme) ! implicit term in TKE
+      real b_e(ims:ime,kms:kme,jms:jme) ! explicit term in TKE
+      real bu(ims:ime,kms:kme,jms:jme) ! buoyancy term in TKE
+      real sh(ims:ime,kms:kme,jms:jme) ! shear term in TKE
+      real wrk(ims:ime) ! working array
+      integer ix,iy,iz,id,iz_u,iw_u,ig,ir_u,ix1,iy1
+      real ufrac_int                                              ! urban fraction     
+      real vect,time_tke,hour,zzz
+      real ustarf
+      real summ1,summ2,summ3
+      save time_tke,hour
+!
+! store reference state for potential temperature
+! and initialize tke  
+!    
+
+!here I fix the value of the reference state equal to the value of the potnetial temperature
+! the only use of this variable in the code is to compute the paramter BETA = g/th0
+! I fix it to 300K. 
+      
+        do ix=its,ite
+        do iy=jts,jte        
+        do iz=kts,kte
+!         th_0(ix,iz,iy)=th_phy(ix,iz,iy)
+         th_0(ix,iz,iy)=300.
+        enddo
+        enddo
+        enddo
+        
+         bu1d=0.
+         sh1d=0.         
+         b_e1d=0.
+         b_u1d=0.
+         b_v1d=0.
+         b_t1d=0.
+         b_q1d=0.
+         a_e1d=0.
+         a_u1d=0.
+         a_v1d=0.
+         a_t1d=0.
+         a_q1d=0.
+       z1D=0.               ! vertical coordinates (faces of the grid)
+       dz1D=0.              ! vertical resolution
+       u1D =0.                ! wind speed in the x directions
+       v1D =0.                ! wind speed in the y directions
+       th1D=0.                ! potential temperature
+       q1D=0.                 ! potential temperature
+       rho1D=0.               ! air density
+       rhoz1D=0.            ! air density at the faces
+       tke1D =0.              ! air pressure
+       th01D =0.              ! reference potential temperature
+       dlk1D =0.              ! dlk
+       dls1D =0.              ! dls
+       exch1D=0.            ! exch
+       sf1D  =1.            ! surface of the grid cells
+       vl1D  =1.             ! volume of the  grid cells
+       a_u1D =0.              ! Implicit component of the momentum sources or sinks in the X-direction
+       a_v1D =0.              ! Implicit component of the momentum sources or sinks in the Y-direction
+       a_t1D =0.              ! Implicit component of the heat sources or sinks
+       a_q1D =0.              ! Implicit component of the moisture sources or sinks
+       a_e1D =0.              ! Implicit component of the TKE sources or sinks
+       b_u1D =0.              ! Explicit component of the momentum sources or sinks in the X-direction
+       b_v1D =0.              ! Explicit component of the momentum sources or sinks in the Y-direction
+       b_t1D =0.              ! Explicit component of the heat sources or sinks
+       b_q1D =0.              ! Explicit component of the moisture sources or sinks
+       b_e1D =0.              ! Explicit component of the TKE sources or sinks
+       dlg1D =0.              ! Height above ground (L_ground in formula (24) of the BLM paper). 
+       dl_u1D=0.              ! Length scale (lb in formula (22) ofthe BLM paper)
+       sh1D  =0.            ! shear
+       bu1D  =0.            ! buoyancy
+       wu1D  =0.            ! turbulent flux of momentum (x component)
+       wv1D  =0.            ! turbulent flux of momentum (y component)
+       wt1D =0.              ! turbulent flux of temperature
+       wq1D =0.             ! turbulent flux of water vapor
+! local added only for diagnostic output
+         
+! loop over the columns. 
+! put variables in 1D temporary arrays
+!     
+
+       do ix=its,ite
+       do iy=jts,jte
+         z1d(kts)=0.
+         do iz= kts,kte
+	  u1D(iz)=u_phy(ix,iz,iy)
+	  v1D(iz)=v_phy(ix,iz,iy)
+	  th1D(iz)=th_phy(ix,iz,iy)
+          q1D(iz)=qv_curr(ix,iz,iy)
+          tke1D(iz)=tke(ix,iz,iy)
+	  rho1D(iz)=rho(ix,iz,iy)	   
+	  th01D(iz)=th_0(ix,iz,iy)	  
+          dz1D(iz)=dz8w(ix,iz,iy)
+          z1D(iz+1)=z1D(iz)+dz1D(iz)
+         enddo
+        rhoz1D(kts)=rho1D(kts)
+        do iz=kts+1,kte
+         rhoz1D(iz)=(rho1D(iz)*dz1D(iz-1)+rho1D(iz-1)*dz1D(iz))/(dz1D(iz-1)+dz1D(iz))
+        enddo
+        rhoz1D(kte+1)=rho1D(kte)
+        if(flag_bep)then
+         do iz=kts,kte          
+          a_e1D(iz)=a_e_bep(ix,iz,iy)
+          b_e1D(iz)=b_e_bep(ix,iz,iy)
+          dlg1D(iz)=(z1D(iz)+z1D(iz+1))/2.*(1.-frc_urb2d(ix,iy))+dlg_bep(ix,iz,iy)*frc_urb2d(ix,iy)
+          dl_u1D(iz)=dl_u_bep(ix,iz,iy)
+          if((1.-frc_urb2d(ix,iy)).lt.1.)dl_u1D(iz)=dl_u1D(iz)/frc_urb2d(ix,iy)
+          vl1D(iz)=vl_bep(ix,iz,iy)
+          sf1D(iz)=sf_bep(ix,iz,iy)
+         enddo
+         ufrac_int=frc_urb2d(ix,iy)
+         sf1D(kte+1)=sf_bep(ix,1,iy)
+        else
+         do iz=kts,kte          
+          a_e1D(iz)=0.        
+          b_e1D(iz)=0.
+          dlg1D(iz)=(z1D(iz)+z1D(iz+1))/2.
+          dl_u1D(iz)=0.
+          vl1D(iz)=1.
+          sf1D(iz)=1.
+         enddo
+         ufrac_int=0.
+         sf1D(kte+1)=1.
+        endif
+! call the routine that will solve the turbulence in 1D for tke
+
+         call boulac1D(ix,iy,ufrac_int,kms,kme,kts,kte,dz1d,z1D,dt,u1D,v1D,th1D,rho1D,rhoz1D,q1D,th01D,&
+                   tke1D,ustar(ix,iy),hfx(ix,iy),qfx(ix,iy),cp,g,        & 
+                   a_e1D,b_e1D,                              & 
+                   dlg1D,dl_u1D,sf1D,vl1D,dlk1D,dls1D,exch1D,sh1D,bu1D)                    
+
+         call pbl_height(kms,kme,kts,kte,dz1d,z1d,th1D,q1D,pblh(ix,iy))
+
+
+! store turbulent exchange coefficients, TKE, and other variables
+         
+         do iz= kts,kte
+          a_e(ix,iz,iy)=a_e1D(iz)
+          b_e(ix,iz,iy)=b_e1D(iz)
+          if(flag_bep)then
+          dlg_bep(ix,iz,iy)=dlg1D(iz)
+          endif
+          tke(ix,iz,iy)=tke1D(iz)
+          dlk(ix,iz,iy)=dlk1D(iz)
+          sh(ix,iz,iy)=sh1D(iz)
+          bu(ix,iz,iy)=bu1D(iz)
+          exch_h(ix,iz,iy)=exch1D(iz)
+          exch_m(ix,iz,iy)=exch1D(iz)
+         enddo
+
+         if(idiff.ne.1)then
+
+! estimate the tendencies
+
+        if(flag_bep)then         
+         do iz=kts,kte          
+          a_t1D(iz)=a_t_bep(ix,iz,iy)
+          b_t1D(iz)=b_t_bep(ix,iz,iy)
+          a_u1D(iz)=a_u_bep(ix,iz,iy)
+          b_u1D(iz)=b_u_bep(ix,iz,iy)
+          a_v1D(iz)=a_v_bep(ix,iz,iy)
+          b_v1D(iz)=b_v_bep(ix,iz,iy)
+          a_q1D(iz)=a_q_bep(ix,iz,iy)
+          b_q1D(iz)=b_q_bep(ix,iz,iy)
+         enddo
+        else
+         do iz=kts,kte          
+          a_t1D(iz)=0.         
+          b_t1D(iz)=0.
+          a_u1D(iz)=0.        
+          b_u1D(iz)=0.
+          a_v1D(iz)=0.         
+          b_v1D(iz)=0.
+          a_q1D(iz)=0.        
+          b_q1D(iz)=0.
+         enddo
+          b_t1D(1)=hfx(ix,iy)/dz1D(1)/rho1D(1)/cp         
+          b_q1D(1)=qfx(ix,iy)/dz1D(1)/rho1D(1)
+          a_u1D(1)=(-ustar(ix,iy)*ustar(ix,iy)/dz1D(1)/((u1D(1)**2.+v1D(1)**2.)**.5))
+          a_v1D(1)=(-ustar(ix,iy)*ustar(ix,iy)/dz1D(1)/((u1D(1)**2.+v1D(1)**2.)**.5))
+        endif
+
+! solve diffusion equation for momentum x component          
+       call diff(kms,kme,kts,kte,1,1,dt,u1D,rho1D,rhoz1D,exch1D,a_u1D,b_u1D,sf1D,vl1D,dz1D,wu1D)
+        
+! solve diffusion equation for momentum y component          
+       call diff(kms,kme,kts,kte,1,1,dt,v1D,rho1D,rhoz1D,exch1D,a_v1D,b_v1D,sf1D,vl1D,dz1D,wv1D)
+
+! solve diffusion equation for potential temperature        
+       call diff(kms,kme,kts,kte,1,1,dt,th1D,rho1D,rhoz1D,exch1D,a_t1D,b_t1D,sf1D,vl1D,dz1D,wt1D)
+
+! solve diffusion equation for water vapor mixing ratio     
+       call diff(kms,kme,kts,kte,1,1,dt,q1D,rho1D,rhoz1D,exch1D,a_q1D,b_q1D,sf1D,vl1D,dz1D,wq1D)
+
+! compute the tendencies
+                             
+         do iz= kts,kte
+          rthblten(ix,iz,iy)=rthblten(ix,iz,iy)+(th1D(iz)-th_phy(ix,iz,iy))/dt
+          rqvblten(ix,iz,iy)=rqvblten(ix,iz,iy)+(q1D(iz)-qv_curr(ix,iz,iy))/dt
+          rublten(ix,iz,iy)=rublten(ix,iz,iy)+(u1D(iz)-u_phy(ix,iz,iy))/dt
+          rvblten(ix,iz,iy)=rvblten(ix,iz,iy)+(v1D(iz)-v_phy(ix,iz,iy))/dt  
+          wu(ix,iz,iy)=wu1D(iz)
+          wv(ix,iz,iy)=wv1D(iz) 
+          wt(ix,iz,iy)=wt1D(iz)
+          wq(ix,iz,iy)=wq1D(iz)      
+        enddo
+      endif
+   
+      enddo  ! iy
+      enddo  ! ix
+
+         
+         time_tke=time_tke+dt
+
+  
+      return
+      end subroutine boulac
+            
+
+! ===6=8===============================================================72
+
+! ===6=8===============================================================72
+
+      subroutine boulac1D(ix,iy,ufrac_int,kms,kme,kts,kte,dz,z,dt,u,v,th,rho,rhoz,qa,th0,te,    &
+                   ustar,hfx,qfx,cp,g,                               & 
+                   a_e,b_e,                        & 
+                   dlg,dl_u,sf,vl,dlk,dls,exch,sh,bu)                           
+
+! ----------------------------------------------------------------------
+! 1D resolution of TKE following Bougeault and Lacarrere
+! ----------------------------------------------------------------------
+
+      implicit none
+
+      integer iz,ix,iy
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+
+
+      integer kms,kme,kts,kte                 
+      real z(kms:kme)               ! Altitude above the ground of the cell interfaces.
+      real dz(kms:kme)                ! vertical resolution
+      real u(kms:kme)                ! Wind speed in the x direction
+      real v(kms:kme)                ! Wind speed in the y direction
+      real th(kms:kme)                ! Potential temperature
+      real rho(kms:kme)                ! Air density
+      real g                     ! gravity
+      real cp                    !  
+      real te(kms:kme)                ! turbulent kinetic energy
+      real qa(kms:kme)                ! air humidity
+      real th0(kms:kme)               ! Reference potential temperature 
+      real dt                    ! Time step
+      real ustar                 ! ustar
+      real hfx                   ! sensbile heat flux
+      real qfx                   ! kinematic latent heat flux
+      real sf(kms:kme)              ! surface of the urban grid cells
+      real vl(kms:kme)                ! volume of the urban grid cells
+      real a_e(kms:kme)               ! Implicit component of the TKE sources or sinks
+      real b_e(kms:kme)               ! Explicit component of the TKE sources or sinks
+      real dlg(kms:kme)               ! Height above ground (L_ground in formula (24) of the BLM paper). 
+      real dl_u(kms:kme)              ! Length scale (lb in formula (22) ofthe BLM paper)
+      real ufrac_int             ! urban fraction
+! local variables not needed in principle, but that can be used to estimate the budget and turbulent fluxes
+ 
+      real we(kms:kme),dwe(kms:kme)
+     
+! local variables
+      real sh(kms:kme)    ! shear term in TKE eqn.
+      real bu(kms:kme)    ! buoyancy term in TKE eqn.
+      real td(kms:kme)    ! dissipation term in TKE eqn.
+      real exch(kms:kme) ! turbulent diffusion coefficients (defined at the faces)
+      real dls(kms:kme)   ! dissipation length scale
+      real dlk(kms:kme)   ! length scale used to estimate exch
+      real dlu(kms:kme)   ! l_up
+      real dld(kms:kme)   ! l_down
+      real rhoz(kms:kme) !air density at the faces of the cell                
+      real tstar     ! derived from hfx and ustar
+      real beta
+      real summ1,summ2,summ3,summ4
+! interpolate air density at the faces
+
+       
+
+! estimation of tstar
+
+        tstar=-hfx/rho(1)/cp/ustar                                                
+         
+! first compute values of dlu and dld (length scales up and down). 
+       
+       call dissip_bougeault(ix,iy,g,kms,kme,kts,kte,z,dz,te,dlu,dld,th,th0)
+          
+!then average them to obtain dls and dlk (length scales for dissipation and eddy coefficients)
+
+       call length_bougeault(ix,iy,kms,kme,kts,kte,dld,dlu,dlg,dl_u,dls,dlk)
+            
+! compute the turbulent diffusion coefficients exch
+
+       call cdtur_bougeault(ix,iy,kms,kme,kts,kte,te,z,dz,exch,dlk)
+
+! compute source and sink terms in the TKE equation (shear, buoyancy and dissipation)
+       
+       call tke_bougeault(ix,iy,g,kms,kme,kts,kte,z,dz,vl,u,v,th,te,th0,ustar,tstar,exch,dls,td,sh,bu,b_e,a_e,sf,ufrac_int)
+        
+! solve for tke 
+      
+       call diff(kms,kme,kts,kte,1,1,dt,te,rho,rhoz,exch,a_e,b_e,sf,vl,dz,we)
+     
+! avoid negative values for tke
+  
+       do iz=kts,kte
+        if(te(iz).lt.temin) te(iz)=temin
+       enddo 
+      
+       return
+       end subroutine boulac1d
+! 
+! ===6=8===============================================================72
+
+! ===6=8===============================================================72
+         subroutine dissip_bougeault(ix,iy,g,kms,kme,kts,kte,z,dz,te,dlu,dld,th,th0)
+! compute the length scales up and down
+         implicit none
+         integer kms,kme,kts,kte,iz,izz,ix,iy
+         real dzt,zup,beta,zup_inf,bbb,tl,zdo,zdo_sup,zzz,g
+         real te(kms:kme),dlu(kms:kme),dld(kms:kme),dz(kms:kme)
+         real z(kms:kme),th(kms:kme),th0(kms:kme)
+
+         do iz=kts,kte
+          zup=0.
+          dlu(iz)=z(kte+1)-z(iz)-dz(iz)/2.
+          zzz=0.
+          zup_inf=0.
+          beta=g/th0(iz)      !Buoyancy coefficient
+          do izz=iz,kte-1
+           dzt=(dz(izz+1)+dz(izz))/2.
+           zup=zup-beta*th(iz)*dzt
+           zup=zup+beta*(th(izz+1)+th(izz))*dzt/2.
+           zzz=zzz+dzt
+           if(te(iz).lt.zup.and.te(iz).ge.zup_inf)then
+            bbb=(th(izz+1)-th(izz))/dzt
+            if(bbb.ne.0)then
+             tl=(-beta*(th(izz)-th(iz))+sqrt( max(0.,(beta*(th(izz)-th(iz)))**2.+2.*bbb*beta*(te(iz)-zup_inf))))/bbb/beta
+            else
+             if(th(izz).ne.th(iz))then
+              tl=(te(iz)-zup_inf)/(beta*(th(izz)-th(iz)))
+             else
+              tl=0.
+             endif
+            endif            
+            dlu(iz)=zzz-dzt+tl
+           endif
+           zup_inf=zup
+          enddo
+                  
+          zdo=0.
+          zdo_sup=0.
+          dld(iz)=z(iz)+dz(iz)/2.
+          zzz=0.
+          do izz=iz,kts+1,-1
+           dzt=(dz(izz-1)+dz(izz))/2.
+           zdo=zdo+beta*th(iz)*dzt
+           zdo=zdo-beta*(th(izz-1)+th(izz))*dzt/2.
+           zzz=zzz+dzt
+           if(te(iz).lt.zdo.and.te(iz).ge.zdo_sup)then
+            bbb=(th(izz)-th(izz-1))/dzt
+            if(bbb.ne.0.)then
+             tl=(beta*(th(izz)-th(iz))+sqrt( max(0.,(beta*(th(izz)-th(iz)))**2.+2.*bbb*beta*(te(iz)-zdo_sup))))/bbb/beta
+            else
+             if(th(izz).ne.th(iz))then
+              tl=(te(iz)-zdo_sup)/(beta*(th(izz)-th(iz)))
+             else
+              tl=0.
+             endif
+            endif
+            
+            dld(iz)=zzz-dzt+tl
+           endif
+           zdo_sup=zdo
+          enddo
+         enddo
+            
+                   
+         end subroutine dissip_bougeault
+!
+! ===6=8===============================================================72 
+! ===6=8===============================================================72
+         subroutine length_bougeault(ix,iy,kms,kme,kts,kte,dld,dlu,dlg,dl_u,dls,dlk)
+! compute the length scales for dissipation and turbulent coefficients
+         implicit none
+         integer kms,kme,kts,kte,iz,ix,iy
+         real dlu(kms:kme),dld(kms:kme),dl_u(kms:kme)
+         real dls(kms:kme),dlk(kms:kme),dlg(kms:kme)
+         
+         do iz=kts,kte
+          dld(iz)=min(dld(iz),dlg(iz))
+          dls(iz)=sqrt(dlu(iz)*dld(iz))
+          dlk(iz)=min(dlu(iz),dld(iz))
+
+         if(dl_u(iz).gt.0.)then               
+           dls(iz)=1./(1./dls(iz)+1./dl_u(iz))
+           dlk(iz)=1./(1./dlk(iz)+1./dl_u(iz))             
+          endif
+         enddo 
+                   
+         return
+         end subroutine length_bougeault
+!
+
+! ===6=8===============================================================72 
+! ===6=8===============================================================72
+
+       subroutine cdtur_bougeault(ix,iy,kms,kme,kts,kte,te,z,dz,exch,dlk)
+! compute turbulent coefficients
+       implicit none
+       integer iz,kms,kme,kts,kte,ix,iy
+       real te_m,dlk_m
+       real te(kms:kme),exch(kms:kme)
+       real dz(kms:kme),z(kms:kme)
+       real dlk(kms:kme)
+       real fact
+
+       exch(kts)=0.
+
+!       do iz=2,nz-1
+       do iz=kts+1,kte
+        te_m=(te(iz-1)*dz(iz)+te(iz)*dz(iz-1))/(dz(iz)+dz(iz-1))
+        dlk_m=(dlk(iz-1)*dz(iz)+dlk(iz)*dz(iz-1))/(dz(iz)+dz(iz-1))
+        exch(iz)=ck_b*dlk_m*sqrt(te_m)
+!        exch(iz)=max(exch(iz),0.0001)    
+        exch(iz)=max(exch(iz),0.1) 
+       enddo
+
+       exch(kte+1)=0.1
+
+       return
+       end subroutine cdtur_bougeault
+
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+       subroutine diff(kms,kme,kts,kte,iz1,izf,dt,co,rho,rhoz,cd,aa,bb,sf,vl,dz,fc)
+
+
+!------------------------------------------------------------------------
+!           Calculation of the diffusion in 1D        
+!------------------------------------------------------------------------
+!  - Input:
+!       nz    : number of points
+!       iz1   : first calculated point
+!       co    : concentration of the variable of interest
+!       dz    : vertical levels
+!       cd    : diffusion coefficients
+!       dtext : external time step
+!       rho    : density of the air at the center
+!       rhoz   : density of the air at the face
+!       itest : if itest eq 1 then update co, else store in a flux array
+!  - Output:
+!       co :concentration of the variable of interest
+
+!  - Internal:
+!       cddz  : constant terms in the equations 
+!       dt    : diffusion time step
+!       nt    : number of the diffusion time steps
+!       cstab : ratio of the stability condition for the time step
+!---------------------------------------------------------------------
+
+        implicit none
+        integer iz,iz1,izf
+        integer kms,kme,kts,kte
+        real dt,dzv               
+        real co(kms:kme),cd(kms:kme),dz(kms:kme)
+        real rho(kms:kme),rhoz(kms:kme)
+        real cddz(kms:kme+1),fc(kms:kme),df(kms:kme)
+        real a(kms:kme,3),c(kms:kme)
+        real sf(kms:kme),vl(kms:kme)
+        real aa(kms:kme),bb(kms:kme)
+        
+
+! Compute cddz=2*cd/dz  
+        
+        cddz(kts)=sf(kts)*rhoz(kts)*cd(kts)/dz(kts)
+        do iz=kts+1,kte
+         cddz(iz)=2.*sf(iz)*rhoz(iz)*cd(iz)/(dz(iz)+dz(iz-1))
+        enddo
+        cddz(kte+1)=sf(kte+1)*rhoz(kte+1)*cd(kte+1)/dz(kte)
+
+         do iz=kts,iz1-1
+          a(iz,1)=0.
+          a(iz,2)=1.
+          a(iz,3)=0.
+          c(iz)=co(iz)
+         enddo
+          
+          do iz=iz1,kte-izf
+           dzv=vl(iz)*dz(iz)
+           a(iz,1)=-cddz(iz)*dt/dzv/rho(iz)
+           a(iz,2)=1+dt*(cddz(iz)+cddz(iz+1))/dzv/rho(iz)-aa(iz)*dt
+           a(iz,3)=-cddz(iz+1)*dt/dzv/rho(iz)
+           c(iz)=co(iz)+bb(iz)*dt                     
+          enddo
+          
+          do iz=kte-(izf-1),kte
+           a(iz,1)=0.
+           a(iz,2)=1
+           a(iz,3)=0.
+           c(iz)=co(iz)
+          enddo
+           
+          call invert (kms,kme,kts,kte,a,c,co)
+         
+          do iz=kts,iz1 
+           fc(iz)=0.
+          enddo
+                       
+          do iz=iz1+1,kte 
+           fc(iz)=-(cddz(iz)*(co(iz)-co(iz-1)))/rho(iz)
+          enddo
+        
+!          do iz=1,iz1
+!           df(iz)=0.
+!          enddo
+!          
+!          do iz=iz1+1,nz-izf
+!           dzv=vl(iz)*dz(iz)
+!           df(iz)=+(co(iz-1)*cddz(iz)-co(iz)*(cddz(iz)+cddz(iz+1))+co(iz+1)*cddz(iz+1))/dzv/rho(iz)
+!          enddo
+!          
+!          do iz=nz-izf,nz 
+!           df(iz)=0.
+!          enddo
+                                        
+       return
+       end subroutine diff
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+       subroutine buoy(ix,iy,g,kms,kme,kts,kte,th,th0,exch,dz,bu,ustar,tstar,ufrac_int)
+! compute buoyancy term
+       implicit none
+       integer kms,kme,kts,kte,iz,ix,iy
+       real dtdz1,dtdz2,cdm,dtmdz,g      
+       real th(kms:kme),exch(kms:kme),dz(kms:kme),bu(kms:kme)
+       real th0(kms:kme),ustar,tstar,ufrac_int
+        
+!       bu(1)=-ustar*tstar*g/th0(1)*(1.-ufrac_int) 
+      bu(kts)=0. 
+       
+        
+       do iz=kts+1,kte-1       
+        dtdz1=2.*(th(iz)-th(iz-1))/(dz(iz-1)+dz(iz))
+        dtdz2=2.*(th(iz+1)-th(iz))/(dz(iz+1)+dz(iz))                  
+        dtmdz=0.5*(dtdz1+dtdz2)
+        cdm=0.5*(exch(iz+1)+exch(iz))
+        bu(iz)=-cdm*dtmdz*g/th0(iz)         
+       enddo
+!
+                 
+       bu(kte)=0.
+         
+       return
+       end subroutine buoy
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+       subroutine shear(ix,iy,g,kms,kme,kts,kte,u,v,cdua,dz,sh,ustar,tstar,th,ufrac_int)
+! compute shear term
+       implicit none
+       integer kms,kme,kts,kte,iz,ix,iy
+       real dudz1,dudz2,dvdz1,dvdz2,cdm,dumdz,ustar
+       real tstar,th,al,phim,g      
+       real u(kms:kme),v(kms:kme),cdua(kms:kme),dz(kms:kme),sh(kms:kme)
+       real u1,u2,v1,v2,ufrac_int
+
+!       al=vk*g*tstar/(th*(ustar**2.))
+!       if(al.ge.0.)phim=1.+4.7*dz(1)/2.*al
+!       if(al.lt.0.)phim=(1.-15*dz(1)/2.*al)**(-0.25)       
+!        
+!       sh(1)=(ustar**3.)/vk/(dz(1)/2.)*(1.-ufrac_int)       
+       sh(kts)=0.
+       do iz=kts+1,kte-1
+        u2=(dz(iz+1)*u(iz)+dz(iz)*u(iz+1))/(dz(iz)+dz(iz+1))
+        u1=(dz(iz)*u(iz-1)+dz(iz-1)*u(iz))/(dz(iz-1)+dz(iz))
+        v2=(dz(iz+1)*v(iz)+dz(iz)*v(iz+1))/(dz(iz)+dz(iz+1))
+        v1=(dz(iz)*v(iz-1)+dz(iz-1)*v(iz))/(dz(iz-1)+dz(iz))        
+        cdm=0.5*(cdua(iz)+cdua(iz+1)) 
+        dumdz=((u2-u1)/dz(iz))**2.+((v2-v1)/dz(iz))**2.            
+        sh(iz)=cdm*dumdz                          
+       enddo
+
+!!!!!!!
+       sh(kte)=0.
+       
+       return
+       end subroutine shear
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+       subroutine invert(kms,kme,kts,kte,a,c,x)
+       
+!ccccccccccccccccccccccccccccccc       
+! Aim: Inversion and resolution of a tridiagonal matrix
+!          A X = C
+! Input:
+!  a(*,1) lower diagonal (Ai,i-1)
+!  a(*,2) principal diagonal (Ai,i)
+!  a(*,3) upper diagonal (Ai,i+1)
+!  c      
+! Output
+!  x     results
+!ccccccccccccccccccccccccccccccc
+
+       implicit none
+       integer in
+       integer kts,kte,kms,kme
+       real a(kms:kme,3),c(kms:kme),x(kms:kme)                       
+        
+        do in=kte-1,kts,-1                 
+         c(in)=c(in)-a(in,3)*c(in+1)/a(in+1,2)
+         a(in,2)=a(in,2)-a(in,3)*a(in+1,1)/a(in+1,2)
+        enddo
+        
+        do in=kts+1,kte        
+         c(in)=c(in)-a(in,1)*c(in-1)/a(in-1,2)
+        enddo
+        
+        do in=kts,kte
+          
+         x(in)=c(in)/a(in,2)
+          
+        enddo
+
+        return
+        end subroutine invert
+  
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+              
+       subroutine tke_bougeault(ix,iy,g,kms,kme,kts,kte,z,dz,vl,u,v,th,te,th0,ustar,tstar,exch,   &
+                         dls,td,sh,bu,b_e,a_e,sf,ufrac_int)
+! in this routine the shear, buoyancy and part of the dissipation terms
+! of the TKE equation are computed       
+
+       implicit none
+       integer kms,kme,kts,kte,iz,ix,iy
+       real g,ustar,tstar,ufrac_int
+       real z(kms:kme),dz(kms:kme),u(kms:kme),v(kms:kme),th(kms:kme),th0(kms:kme),te(kms:kme)
+       real exch(kms:kme),dls(kms:kme),td(kms:kme),sh(kms:kme),bu(kms:kme)
+       real a_e(kms:kme),b_e(kms:kme)
+       real vl(kms:kme),sf(kms:kme)
+       real te1,dl1
+    
+       call shear(ix,iy,g,kms,kme,kts,kte,u,v,exch,dz,sh,ustar,tstar,th(kts),ufrac_int)
+      
+       call buoy(ix,iy,g,kms,kme,kts,kte,th,th0,exch,dz,bu,ustar,tstar,ufrac_int)
+     
+       do iz=kts,kte          
+        te1=max(te(iz),temin)
+        dl1=max(dls(iz),0.1)
+        td(iz)=-ceps_b*sqrt(te1)/dl1
+        sh(iz)=sh(iz)*sf(iz)
+        bu(iz)=bu(iz)*sf(iz)
+        a_e(iz)=a_e(iz)+td(iz)       
+        b_e(iz)=b_e(iz)+sh(iz)+bu(iz)
+       enddo 
+
+         
+       return
+       end subroutine tke_bougeault    
+!######################################################################
+       subroutine pbl_height(kms,kme,kts,kte,dz,z,th,q,pblh)
+
+! this routine computes the PBL height
+! with an approach similar to MYNN
+       implicit none
+       integer kms,kme,kts,kte,iz
+       real z(kms:kme),dz(kms:kme),th(kms:kme),q(kms:kme)
+       real pblh
+!Local
+       real thv(kms:kme),zc(kms:kme)
+       real thsfc
+
+! compute the height of the center of the grid cells
+      do iz=kts,kte
+       zc(iz)=z(iz)+dz(iz)/2.
+      enddo
+
+! compute the virtual potential temperature
+
+       do iz=kts,kte
+        thv(iz)=th(iz)*(1.+0.61*q(iz))
+       enddo
+! now compute the PBL height
+
+       pblh=0.
+       thsfc=thv(kts)+0.5
+       do iz=kts+1,kte
+        if(pblh.eq.0.and.thv(iz).gt.thsfc)then
+         pblh=zc(iz-1)+(thsfc-thv(iz-1))/(max(0.01,thv(iz)-thv(iz-1)))*(zc(iz)-zc(iz-1))
+!         pblh=z(iz-1)+(thsfc-thv(iz-1))/(max(0.01,thv(iz)-thv(iz-1)))*(z(iz)-z(iz-1))
+        endif
+       enddo
+
+       return
+       end subroutine pbl_height
+
+
+! ===6=8===============================================================72
+
+
+! ===6=8===============================================================72
+      SUBROUTINE BOULACINIT(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,          &
+     &                      TKE_PBL,EXCH_H,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
+
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) ::    EXCH_H, &
+     &                                                         RUBLTEN, &
+     &                                                         RVBLTEN, &
+     &                                                        RTHBLTEN, &
+     &                                                        RQVBLTEN, &
+     &                                                         TKE_PBL
+      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
+          TKE_PBL(I,K,J)=0.0001
+          RUBLTEN(I,K,J)=0.
+          RVBLTEN(I,K,J)=0.
+          RTHBLTEN(I,K,J)=0.
+          RQVBLTEN(I,K,J)=0.
+          EXCH_H(I,K,J)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDIF
+
+      END SUBROUTINE BOULACINIT
+
+
+
+END MODULE module_bl_boulac
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_camuwpbl_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_camuwpbl_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_camuwpbl_driver.F	(revision 17)
@@ -0,0 +1,1099 @@
+MODULE module_bl_camuwpbl_driver
+  !Note: Comments starting with "!!" are directly taken from CAM's interface routine for the UW PBL
+
+  !!----------------------------------------------------------------------------------------------------- !
+  !! Module to compute vertical diffusion of momentum,  moisture, trace constituents                      !
+  !! and static energy. Separate modules compute                                                          !  
+  !!   1. stresses associated with turbulent flow over orography                                          !
+  !!      ( turbulent mountain stress )                                                                   !
+  !!   2. eddy diffusivities, including nonlocal tranport terms                                           !
+  !!   3. molecular diffusivities                                                                         ! 
+  !!   4. coming soon... gravity wave drag                                                                !  
+  !! Lastly, a implicit diffusion solver is called, and tendencies retrieved by                           !
+  !! differencing the diffused and initial states.                                                        !
+  !!                                                                                                      ! 
+  !! Calling sequence:                                                                                    !
+  !!                                                                                                      !
+  !!  vertical_diffusion_init      Initializes vertical diffustion constants and modules                  !
+  !!        init_molec_diff        Initializes molecular diffusivity module                               !
+  !!        init_eddy_diff         Initializes eddy diffusivity module (includes PBL)                     !  
+  !!        init_tms               Initializes turbulent mountain stress module                           !
+  !!        init_vdiff             Initializes diffusion solver module                                    !
+  !!  vertical_diffusion_ts_init   Time step initialization (only used for upper boundary condition)      ! 
+  !!  vertical_diffusion_tend      Computes vertical diffusion tendencies                                 ! 
+  !!        compute_tms            Computes turbulent mountain stresses                                   !
+  !!        compute_eddy_diff      Computes eddy diffusivities and countergradient terms                  !
+  !!        compute_vdiff          Solves vertical diffusion equations, including molecular diffusivities !         
+  !!                                                                                                      !
+  !!---------------------------Code history-------------------------------------------------------------- !
+  !! J. Rosinski : Jun. 1992                                                                              !
+  !! J. McCaa    : Sep. 2004                                                                              !
+  !! S. Park     : Aug. 2006, Dec. 2008. Jan. 2010                                                        !
+  !  B. Singh    : Nov. 2010 (ported to WRF by balwinder.singh@pnl.gov)
+  !!----------------------------------------------------------------------------------------------------- !
+
+  use shr_kind_mod,       only : r8 => shr_kind_r8
+  use module_cam_support, only : pcols, pver, pverp, endrun, iulog,fieldname_len,pcnst
+  use constituents,       only : qmin
+  use diffusion_solver,   only : vdiff_selector
+  use physconst,          only :          &
+       cpair  , &     ! Specific heat of dry air
+       gravit , &     ! Acceleration due to gravity
+       rair   , &     ! Gas constant for dry air
+       zvir   , &     ! rh2o/rair - 1
+       latvap , &     ! Latent heat of vaporization
+       latice , &     ! Latent heat of fusion
+       karman , &     ! von Karman constant 
+       mwdry  , &     ! Molecular weight of dry air
+       avogad , &     ! Avogadro's number
+       boltz          ! Boltzman's constant
+  
+  implicit none
+  private      
+  save
+  
+  !! ----------------- !
+  !! Public interfaces !
+  !! ----------------- !
+  
+  public camuwpblinit   ! Initialization
+  public camuwpbl       ! Driver for the PBL scheme
+  public vd_register    ! Init routine for constituents
+  
+  !! ------------ !
+  !! Private data !
+  !! ------------ !
+  
+  character(len=16)    :: eddy_scheme                  !! Default set in phys_control.F90, use namelist to change
+  !!     'HB'       = Holtslag and Boville (default)
+  !!     'HBR'      = Holtslag and Boville and Rash 
+  !!     'diag_TKE' = Bretherton and Park ( UW Moist Turbulence Scheme )
+  integer, parameter   :: nturb = 5                    !! Number of iterations for solution ( when 'diag_TKE' scheme is selected )
+  logical, parameter   :: wstarent = .true.            !! Use wstar (.true.) or TKE (.false.) entrainment closure ( when 'diag_TKE' scheme is selected )
+  logical              :: do_pseudocon_diff = .false.  !! If .true., do pseudo-conservative variables diffusion
+
+  
+  character(len=16)    :: shallow_scheme               !! For checking compatibility between eddy diffusion and shallow convection schemes
+  !!     'Hack'     = Hack Shallow Convection Scheme
+  !!     'UW'       = Park and Bretherton ( UW Shallow Convection Scheme )
+  character(len=16)    :: microp_scheme                !! Microphysics scheme
+  
+  logical              :: do_molec_diff = .false.      !! Switch for molecular diffusion
+  logical              :: do_tms                       !! Switch for turbulent mountain stress
+  real(r8)             :: tms_orocnst                  !! Converts from standard deviation to height
+  
+  type(vdiff_selector) :: fieldlist_wet                !! Logical switches for moist mixing ratio diffusion
+  type(vdiff_selector) :: fieldlist_dry                !! Logical switches for dry mixing ratio diffusion
+  integer              :: ntop                         !! Top interface level to which vertical diffusion is applied ( = 1 ).
+  integer              :: nbot                         !! Bottom interface level to which vertical diffusion is applied ( = pver ).
+  integer              :: tke_idx, kvh_idx, kvm_idx    !! TKE and eddy diffusivity indices for fields in the physics buffer
+  integer              :: turbtype_idx, smaw_idx       !! Turbulence type and instability functions
+  integer              :: tauresx_idx, tauresy_idx     !! Redisual stress for implicit surface stress
+ 
+  integer              :: ixcldice, ixcldliq           !! Constituent indices for cloud liquid and ice water
+  integer              :: ixnumice, ixnumliq
+  integer              :: wgustd_index
+  logical              :: vd_registered = .false.      !! Detect if vd_register called
+  
+  
+CONTAINS
+  
+  subroutine camuwpbl(dt,u_phy,v_phy,th_phy,rho,qv_curr,hfx             &
+       ,qfx,ustar,rublten,rvblten,rthblten,rqvblten,rqcblten            & 
+       ,tke_pbl,pblh2d,kpbl2d,p8w,p_phy,z,t_phy,qc_curr,qi_curr,z_at_w  &
+       ,cldfra,ht,rthratenlw,exner,itimestep,tauresx2d,tauresy2d,kvh3d  &
+       ,kvm3d,tpert2d,qpert2d,wpert2d                                   & 
+       ,ids,ide, jds,jde, kds,kde                                       &
+       ,ims,ime, jms,jme, kms,kme                                       &
+       ,its,ite, jts,jte, kts,kte)                    
+
+
+    !!---------------------------------------------------- !
+    !! This is an interface routine for vertical diffusion !
+    !!---------------------------------------------------- !
+    use module_cam_support,    only : pcols
+    use trb_mtn_stress,        only : compute_tms
+    use eddy_diff,             only : compute_eddy_diff
+    use wv_saturation,         only : fqsatd, aqsat
+    use molec_diff,            only : compute_molec_diff, vd_lu_qdecomp
+    use constituents,          only : qmincg, qmin
+    use diffusion_solver !!, only : compute_vdiff, any, operator(.not.)
+    
+    implicit none   
+    
+    !------------------------------------------------------------------------!
+    !                             Input                                      !
+    !------------------------------------------------------------------------!
+    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) :: itimestep
+
+    real, intent(in) :: dt                                                ! Time step (s)
+    
+    real, dimension( ims:ime,jms:jme ), intent(in) :: ustar               ! Friction velocity (m/s)
+    real, dimension( ims:ime,jms:jme ), intent(in) :: hfx                 ! Sensible heat flux at surface (w/m2)
+    real, dimension( ims:ime,jms:jme ), intent(in) :: qfx                 ! Moisture      flux at surface (kg m-2 s-1)
+    real, dimension( ims:ime,jms:jme ), intent(in) :: ht                  ! Terrain height (m)
+
+
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: rho       ! Air density (kg/m3)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: th_phy    ! Potential temperature (K)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: u_phy     ! X-component of wind (m/s)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: v_phy     ! Y-component of wind (m/s)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: p_phy     ! Pressure at mid-level (Pa)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: p8w       ! Pressure at level interface (Pa)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: z         ! Height above sea level at mid-level (m) 
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: t_phy     ! temperature (K)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: qv_curr   ! Water vapor mixing ratio - Moisture  (kg/kg)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: qc_curr   ! Cloud water mixing ratio - Cloud liq (kg/kg)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: qi_curr   ! Ice mixing ratio         -Cloud ice  (kg/kg)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: z_at_w    ! Height above sea level at layer interfaces (m) 
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: cldfra    ! Cloud fraction [unitless]
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: exner     ! Dimensionless pressure [unitless]
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: rthratenlw  ! Tendency for LW ( K/s)
+    
+    
+    !------------------------------------------------------------------------!
+    !                          Output                                        !
+    !------------------------------------------------------------------------!   
+    integer, dimension( ims:ime,jms:jme ), intent(out) :: kpbl2d          ! Layer index containing PBL top within or at the base interface
+    real,    dimension( ims:ime,jms:jme ), intent(out) :: pblh2d          ! Planetary boundary layer height (m)
+
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(out) :: rublten  !Tendency for u_phy   (Pa m s-2)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(out) :: rvblten  !Tendency for v_phy   (Pa m s-2)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(out) :: rthblten !Tendency for th_phy  (Pa K s-1)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(out) :: rqvblten !Tendency for qv_curr (Pa kg kg-1 s-1)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(out) :: rqcblten !Tendency for qc_curr (Pa kg kg-1 s-1)
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(out) :: tke_pbl  !Turbulence kinetic energy from PBL scheme (m^2/s^2)
+
+    
+    !---------------------------------------------------------------------------!
+    !     Local, carried on from one timestep to the other (defined in registry)!
+    !---------------------------------------------------------------------------!
+    
+    real, dimension( ims:ime, jms:jme )         , intent(inout ):: tauresx2d,tauresy2d !X AND Y-COMP OF RESIDUAL STRESSES(m^2/s^2)
+    real, dimension( ims:ime, jms:jme )         , intent(out)   :: tpert2d             ! Convective temperature excess (K)
+    real, dimension( ims:ime, jms:jme )         , intent(out)   :: qpert2d             ! Convective humidity excess (kg/kg)
+    real, dimension( ims:ime, jms:jme )         , intent(out)   :: wpert2d             ! Turbulent velocity excess (m/s)
+
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: kvm3d,kvh3d         !Eddy diffusivity for momentum and heat(m^2/s)
+
+    !---------------------------------------------------------------------------!
+    !                               Local                                       !
+    !---------------------------------------------------------------------------!
+
+    character(128) :: errstring                              ! Error status for compute_vdiff
+    logical        :: kvinit                                 ! Tell compute_eddy_diff/ caleddy to initialize kvh, kvm (uses kvf)
+    logical        :: is_first_step                          ! Flag to know if this a first time step
+    integer        :: i,j,k,itsp1,itile_len,ktep1,kflip,ncol,ips 
+    integer        :: lchnk                                  ! Chunk identifier
+    integer        :: pcnstmax                               ! Max number of constituents considered
+    real(r8)       :: tauFac, uMean, dp
+    real(r8)       :: ztodt                                  ! 2*delta-t (s)
+    real(r8)       :: rztodt                                 ! 1./ztodt (1/s)
+
+    real(r8) :: topflx(  pcols)                              ! Molecular heat flux at top interface                                                
+    real(r8) :: wpert(   pcols)                              ! Turbulent velocity excess (m/s)
+    real(r8) :: tauresx( pcols)                              ! [Residual stress to be added in vdiff to correct...
+    real(r8) :: tauresy( pcols)                              ! for turb stress mismatch between sfc and atm accumulated.] (N/m2)
+    real(r8) :: ipbl(    pcols)                              ! If 1, PBL is CL, while if 0, PBL is STL.
+    real(r8) :: kpblh(   pcols)                              ! Layer index containing PBL top within or at the base interface
+    real(r8) :: wstarPBL(pcols)                              ! Convective velocity within PBL (m/s)
+    real(r8) :: sgh(     pcols)                              ! Standard deviation of orography (m) 
+    real(r8) :: landfrac(pcols)                              ! Land fraction [unitless]
+    real(r8) :: taux(    pcols)                              ! x surface stress  (N/m2)
+    real(r8) :: tauy(    pcols)                              ! y surface stress  (N/m2)
+    real(r8) :: tautotx( pcols)                              ! U component of total surface stress (N/m2)
+    real(r8) :: tautoty( pcols)                              ! V component of total surface stress (N/m2)
+    real(r8) :: ksrftms( pcols)                              ! Turbulent mountain stress surface drag coefficient (kg/s/m2)
+    real(r8) :: tautmsx( pcols)                              ! U component of turbulent mountain stress (N/m2)
+    real(r8) :: tautmsy( pcols)                              ! V component of turbulent mountain stress (N/m2)
+    real(r8) :: ustar8(  pcols)                              ! Surface friction velocity (m/s)
+    real(r8) :: pblh(    pcols)                              ! Planetary boundary layer height (m)
+    real(r8) :: tpert(   pcols)                              ! Convective temperature excess (K)
+    real(r8) :: qpert(   pcols)                              ! Convective humidity excess (kg/kg)
+    real(r8) :: shflx(   pcols)                              ! Surface sensible heat flux  (w/m2)
+    real(r8) :: phis(    pcols)                              ! Geopotential at terrain height (m2/s2)
+
+    real(r8) :: cldn8(      pcols,kte)                       ! New stratus fraction (fraction)
+    real(r8) :: qrl8(       pcols,kte)                       ! LW radiative cooling rate(W/kg*Pa)
+    real(r8) :: wsedl8(     pcols,kte)                       ! Sedimentation velocity of stratiform liquid cloud droplet (m/s)
+    real(r8) :: dtk(        pcols,kte)                       ! T tendency from KE dissipation
+    real(r8) :: qt(         pcols,kte)                       !
+    real(r8) :: sl_prePBL(  pcols,kte)                       !
+    real(r8) :: qt_prePBL(  pcols,kte)                       !
+    real(r8) :: slten(      pcols,kte)                       !
+    real(r8) :: qtten(      pcols,kte)                       !
+    real(r8) :: sl(         pcols,kte)                       !                       
+    real(r8) :: ftem(       pcols,kte)                       ! Saturation vapor pressure before PBL
+    real(r8) :: ftem_prePBL(pcols,kte)                       ! Saturation vapor pressure before PBL
+    real(r8) :: ftem_aftPBL(pcols,kte)                       ! Saturation vapor pressure after PBL
+    real(r8) :: tem2(       pcols,kte)                       ! Saturation specific humidity and RH
+    real(r8) :: t_aftPBL(   pcols,kte)                       ! Temperature after PBL diffusion
+    real(r8) :: tten(       pcols,kte)                       ! Temperature tendency by PBL diffusion
+    real(r8) :: rhten(      pcols,kte)                       ! RH tendency by PBL diffusion
+    real(r8) :: qv_aft_PBL( pcols,kte)                       ! qv after PBL diffusion
+    real(r8) :: ql_aft_PBL( pcols,kte)                       ! ql after PBL diffusion
+    real(r8) :: qi_aft_PBL( pcols,kte)                       ! qi after PBL diffusion
+    real(r8) :: s_aft_PBL(  pcols,kte)                       ! s after PBL diffusion
+    real(r8) :: u_aft_PBL(  pcols,kte)                       ! u after PBL diffusion
+    real(r8) :: v_aft_PBL(  pcols,kte)                       ! v after PBL diffusion
+    real(r8) :: qv_pro(     pcols,kte)                       !
+    real(r8) :: ql_pro(     pcols,kte)                       !
+    real(r8) :: qi_pro(     pcols,kte)                       !
+    real(r8) :: s_pro(      pcols,kte)                       !
+    real(r8) :: t_pro(      pcols,kte)                       !
+    real(r8) :: u8(         pcols,kte)                       ! x component of velocity in CAM's data structure (m/s)
+    real(r8) :: v8(         pcols,kte)                       ! y component of velocity in CAM's data structure (m/s)
+    real(r8) :: t8(         pcols,kte)                       ! 
+    real(r8) :: pmid8(      pcols,kte)                       ! Pressure at the midpoints in CAM's data structure (Pa)
+    real(r8) :: pmiddry8(   pcols,kte)                       ! Dry Pressure at the midpoints in CAM's data structure (Pa)
+    real(r8) :: zm8(        pcols,kte)                       ! Height at the midpoints in CAM's data structure  (m)
+    real(r8) :: exner8(     pcols,kte)                       ! exner function in CAM's data structure
+    real(r8) :: s8(         pcols,kte)                       ! Dry static energy (m2/s2)
+    real(r8) :: rpdel8(     pcols,kte)                       ! Inverse of pressure difference (1/Pa)
+    real(r8) :: pdel8(      pcols,kte)                       ! Pressure difference (Pa) 
+    real(r8) :: rpdeldry8(  pcols,kte)                       ! Inverse of dry pressure difference (1/Pa)
+    REAL(r8) :: stnd(       pcols,kte)                       ! Heating rate (dry static energy tendency, W/kg)
+    
+    real(r8) :: tke8(     pcols,kte+1)                       ! Turbulent kinetic energy [ m2/s2 ]
+    real(r8) :: turbtype( pcols,kte+1)                       ! Turbulent interface types [ no unit ]
+    real(r8) :: smaw(     pcols,kte+1)                       ! Normalized Galperin instability function for momentum  ( 0<= <=4.964 and 1 at neutral ) [no units]
+                                                             ! This is 1 when neutral condition (Ri=0), 4.964 for maximum unstable case, and 0 when Ri > Ricrit=0.19. 
+    real(r8) :: cgs(      pcols,kte+1)                       ! Counter-gradient star  [ cg/flux ]
+    real(r8) :: cgh(      pcols,kte+1)                       ! Counter-gradient term for heat [ J/kg/m ]
+    real(r8) :: kvh(      pcols,kte+1)                       ! Eddy diffusivity for heat [ m2/s ]
+    real(r8) :: kvm(      pcols,kte+1)                       ! Eddy diffusivity for momentum [ m2/s ]
+    real(r8) :: kvq(      pcols,kte+1)                       ! Eddy diffusivity for constituents [ m2/s ]
+    real(r8) :: kvh_in(   pcols,kte+1)                       ! kvh from previous timestep [ m2/s ]
+    real(r8) :: kvm_in(   pcols,kte+1)                       ! kvm from previous timestep [ m2/s ]
+    real(r8) :: bprod(    pcols,kte+1)                       ! Buoyancy production of tke [ m2/s3 ]
+    real(r8) :: sprod(    pcols,kte+1)                       ! Shear production of tke [ m2/s3 ]
+    real(r8) :: sfi(      pcols,kte+1)                       ! Saturation fraction at interfaces [ fraction ]
+    real(r8) :: pint8(    pcols,kte+1)                       ! Pressure at the interfaces in CAM's data structure (Pa)
+    real(r8) :: pintdry8( pcols,kte+1)                       ! Dry pressure at the interfaces in CAM's data structure (Pa)
+    real(r8) :: zi8(      pcols,kte+1)                       ! Height at the interfacesin CAM's data structure  (m)
+
+    real(r8) :: cloud(     pcols,kte,3)                      ! Holder for cloud water and ice (q in cam)
+    real(r8) :: cloudtnd(  pcols,kte,3)                      ! Holder for cloud tendencies (ptend_loc%q in cam)
+    real(r8) :: wind_tends(pcols,kte,2)                      ! Wind component tendencies (m/s2)
+
+    real(r8) :: cflx(pcols,pcnst)                            ! Surface constituent flux [ kg/m2/s ]
+    
+
+    !! ----------------------- !
+    !! Main Computation Begins !
+    !! ----------------------- !
+
+    is_first_step  = .false.
+    if(itimestep == 1) then
+       is_first_step = .true.
+    endif
+    !-------------------------------------------------------------------------------------!
+    !Declare maximum number of constituents to be considered. pcnst is 7 in WRF but we are! 
+    !using 1 constituent as we have cflx for only water vapours                                                                 !
+    !-------------------------------------------------------------------------------------!
+
+    pcnstmax      = 1
+    
+    ncol   = pcols
+    ztodt  = 2.0_r8 * DT
+    rztodt = 1.0_r8 / ztodt
+
+
+    !Few definitions in this subroutine require that ncol==1
+    if(ncol .NE. 1) then
+       call wrf_error_fatal('Number of CAM Columns (NCOL) in CAMUWPBL scheme must be 1')
+    endif
+
+    !Initialize all variables which will be used by CAM's modules to zero
+    !This is done to avoid any uninitialized variable
+    
+    errstring = ''
+    topflx(  :) = 0.0_r8
+    wpert(   :) = 0.0_r8
+    tauresx( :) = 0.0_r8
+    tauresy( :) = 0.0_r8
+    ipbl(    :) = 0.0_r8
+    kpblh(   :) = 0.0_r8
+    wstarPBL(:) = 0.0_r8
+    sgh(     :) = 0.0_r8
+    landfrac(:) = 0.0_r8
+    taux(    :) = 0.0_r8
+    tauy(    :) = 0.0_r8
+    tautotx( :) = 0.0_r8
+    tautoty( :) = 0.0_r8
+    ksrftms( :) = 0.0_r8
+    tautmsx( :) = 0.0_r8
+    tautmsy( :) = 0.0_r8
+    ustar8(  :) = 0.0_r8
+    pblh(    :) = 0.0_r8
+    tpert(   :) = 0.0_r8
+    qpert(   :) = 0.0_r8
+    shflx(   :) = 0.0_r8
+    phis(    :) = 0.0_r8
+
+
+    cldn8(      :,:) = 0.0_r8                     
+    qrl8(       :,:) = 0.0_r8                                          
+    wsedl8(     :,:) = 0.0_r8                                          
+    dtk(        :,:) = 0.0_r8                                          
+    qt(         :,:) = 0.0_r8                                          
+    sl_prePBL(  :,:) = 0.0_r8                                            
+    qt_prePBL(  :,:) = 0.0_r8                                            
+    slten(      :,:) = 0.0_r8                                            
+    qtten(      :,:) = 0.0_r8                                            
+    sl(         :,:) = 0.0_r8                                                                   
+    ftem(       :,:) = 0.0_r8                                            
+    ftem_prePBL(:,:) = 0.0_r8                            
+    ftem_aftPBL(:,:) = 0.0_r8                            
+    tem2(       :,:) = 0.0_r8                            
+    t_aftPBL(   :,:) = 0.0_r8                            
+    tten(       :,:) = 0.0_r8                           
+    rhten(      :,:) = 0.0_r8                           
+    qv_aft_PBL( :,:) = 0.0_r8                           
+    ql_aft_PBL( :,:) = 0.0_r8                           
+    qi_aft_PBL( :,:) = 0.0_r8                     
+    s_aft_PBL(  :,:) = 0.0_r8                     
+    u_aft_PBL(  :,:) = 0.0_r8                     
+    v_aft_PBL(  :,:) = 0.0_r8                     
+    qv_pro(     :,:) = 0.0_r8                     
+    ql_pro(     :,:) = 0.0_r8                           
+    qi_pro(     :,:) = 0.0_r8                     
+    s_pro(      :,:) = 0.0_r8                     
+    t_pro(      :,:) = 0.0_r8                     
+    u8(         :,:) = 0.0_r8                     
+    v8(         :,:) = 0.0_r8                           
+    t8(         :,:) = 0.0_r8                     
+    pmid8(      :,:) = 0.0_r8                     
+    pmiddry8(   :,:) = 0.0_r8                     
+    zm8(        :,:) = 0.0_r8                     
+    exner8(     :,:) = 0.0_r8                     
+    s8(         :,:) = 0.0_r8                     
+    rpdel8(     :,:) = 0.0_r8                     
+    pdel8(      :,:) = 0.0_r8                     
+    rpdeldry8(  :,:) = 0.0_r8                     
+    stnd(       :,:) = 0.0_r8                           
+    
+    tke8(     :,:) = 0.0_r8                             
+    turbtype( :,:) = 0.0_r8                             
+    smaw(     :,:) = 0.0_r8                             
+                          
+    cgs(      :,:) = 0.0_r8                             
+    cgh(      :,:) = 0.0_r8                             
+    kvh(      :,:) = 0.0_r8                             
+    kvm(      :,:) = 0.0_r8                             
+    kvq(      :,:) = 0.0_r8                             
+    kvh_in(   :,:) = 0.0_r8                             
+    kvm_in(   :,:) = 0.0_r8                             
+    bprod(    :,:) = 0.0_r8                             
+    sprod(    :,:) = 0.0_r8                             
+    sfi(      :,:) = 0.0_r8                             
+    pint8(    :,:) = 0.0_r8                             
+    pintdry8( :,:) = 0.0_r8        
+    zi8(      :,:) = 0.0_r8       
+
+    cloud(     :,:,:) = 0.0_r8   
+    cloudtnd(  :,:,:) = 0.0_r8   
+    wind_tends(:,:,:) = 0.0_r8   
+    tke_pbl(   :,:,:) = 0.0_r8 
+    cflx(:,:)         = 0.0_r8
+
+    
+    !-------------------------------------------------------------------------------------!
+    !Map CAM variables to the corresponding WRF variables                                 !
+    !Loop over the points in the tile and treat them each as a CAM Chunk                  !
+    !-------------------------------------------------------------------------------------!
+    itsp1     = its - 1 
+    itile_len = ite - itsp1
+    do j    = jts , jte
+       do i = its , ite
+
+          lchnk   = (j - jts) * itile_len + (i - itsp1)          !1-D index location from a 2-D tile
+          phis(1) = ht(i,j) * gravit                             !Used for computing dry static energy
+
+          !Flip vertically quantities computed at the mid points
+          ktep1 = kte + 1
+          do k  = kts,kte
+             kflip               = ktep1 - k
+
+             u8(      1,kflip)   = u_phy(i,k,j)  ! X-component of velocity at the mid-points (m/s) [state%u in CAM]
+             v8(      1,kflip)   = v_phy(i,k,j)  ! Y-component of velocity at the mid-points (m/s) [state%v in CAM]
+
+             pmid8(   1,kflip)   = p_phy(i,k,j)  ! Pressure     at the mid-points    (Pa)      [state%pmid    in CAM]  
+             
+             !The following pmiddry mapping is wrong. Presently, it is not being used in the computations
+             pmiddry8(1,kflip)   = p_phy(i,k,j)  ! Dry pressure at the mid-points    (Pa)      [state%pmiddry in CAM]
+             dp                  = p8w(i,k,j) - p8w(i,k+1,j) !Change in pressure (Pa) 
+             pdel8(  1,kflip)    = dp
+             rpdel8(  1,kflip)   = 1.0_r8/dp     ! Reciprocal of pressure difference (1/Pa)     [state%rpdel in CAM]
+             zm8(     1,kflip)   = z(i,k,j)-ht(i,j)      ! Height above the ground at the midpoints (m) [state%zm    in CAM]
+             t8(      1,kflip)   = t_phy(i,k,j)  ! Temprature at the mid points (K)             [state%t     in CAM]
+             
+             s8(      1,kflip)   = cpair *t8(1,kflip) + gravit*zm8(1,kflip) + phis(1) ! Dry static energy (m2/s2) [state%s in CAM]-Formula tested in vertical_diffusion.F90 of CAM
+             qrl8(    1,kflip)   = rthratenlw(i,k,j)* cpair * dp ! Long Wave heating rate (W/kg*Pa)- Formula obtained from definition of qrlw(pcols,pver) in eddy_diff.F90 in CAM
+
+             !The following is set to zero currently. This value should be passed on from the microphysics subroutine in future
+             wsedl8(  1,kflip)   = 0.0_r8                    ! Sedimentation velocity of stratiform liquid cloud droplet (m/s)
+
+             !Following three formulas are obtained from ported CAM's ZM cumulus scheme
+             !Values of 0 cause a crash in entropy
+             cloud( 1,kflip,1) = max( qv_curr(i,k,j)/(1.+qv_curr(i,k,j)), 1e-30 ) !Specific humidity                       [state%q(:,:,1) in CAM]
+             cloud( 1,kflip,2) = qc_curr(i,k,j)/(1.+qv_curr(i,k,j))               !Convert to moist mix ratio-cloud liquid [state%q(:,:,2) in CAM]
+             cloud( 1,kflip,3) = qi_curr(i,k,j)/(1.+qv_curr(i,k,j))               !cloud ice                               [state%q(:,:,3) in CAM]
+
+             exner8(1,kflip)   = exner(i,k,j)   !Exner function (no units)
+             cldn8( 1,kflip)   = cldfra(i,k,j)  !Cloud fraction (no unit)
+
+          enddo
+          
+          !Future work: Merge the above and below do-loops to avoid extra do-loop, if possible
+
+          do k = kts,kte+1
+             kflip = kte - k + 2
+
+             pint8(   1,kflip) = p8w(   i,k,j) ! Pressure at interfaces [state%pint in CAM]
+
+             !The following pintdry mapping is wrong.Presently, it is not being used in the computations
+             pintdry8(1,kflip) = p8w(   i,k,j) ! Dry pressure at interfaces [state%pintdry in CAM] 
+             zi8(     1,kflip) = z_at_w(i,k,j) -ht(i,j) ! Height at interfaces [state%zi   in CAM]
+
+             !Initialize Variables to zero, these are outputs from the "compute_eddy_diff" 
+             kvq(1,kflip)   = 0.0_r8        ! Eddy diffusivity for constituents (m2/s)
+             cgh(1,kflip)   = 0.0_r8        ! Counter-gradient term for heat
+             cgs(1,kflip)   = 0.0_r8        ! Counter-gradient star     (cg/flux)
+             if( is_first_step ) then
+                kvh3d(i,k,j) = 0.0_r8     ! Eddy diffusivity for heat     (m2/s)
+                kvm3d(i,k,j) = 0.0_r8     ! Eddy diffusivity for momentum (m2/s)
+             endif
+             kvh(1,kflip)   = kvh3d(i,k,j)  
+             kvm(1,kflip)   = kvm3d(i,k,j)  
+          end do
+
+          shflx(   ncol) = hfx(i,j)  ! Surface sensible heat flux (w/m2) 
+
+          !SGH and LANDFRAC are inputs for the compute_tms subroutine. Presently set to zero as do_tms is always false for now
+          sgh(     ncol) = 0.0_r8    ! Standard deviation of orography (m) 
+          landfrac(ncol) = 0.0_r8    ! Fraction (unitless)                 
+
+          uMean      = sqrt( u_phy(i,kts,j) * u_phy(i,kts,j) +  v_phy(i,kts,j) * v_phy(i,kts,j) ) ! Mean velocity
+          tauFac     = rho(i,kts,j) * ustar(i,j) *ustar(i,j)/uMean
+
+          taux(ncol) = -tauFac * u_phy(i,kts,j)  ! x surface stress (N/m2) [Formulation obtained from CAM's BareGround.F90]
+          tauy(ncol) = -tauFac * v_phy(i,kts,j)  ! y surface stress (N/m2)
+
+          !! Retrieve 'tauresx, tauresy' from from the last timestep
+          if( is_first_step ) then
+             tauresx2d(i,j) = 0._r8
+             tauresy2d(i,j) = 0._r8
+          endif
+          tauresx(:ncol) = tauresx2d(i,j)
+          tauresy(:ncol) = tauresy2d(i,j)
+          
+          !! All variables are modified by vertical diffusion
+          
+          !!------------------------------------------!
+          !! Computation of turbulent mountain stress !
+          !!------------------------------------------!
+          
+          !! Consistent with the computation of 'normal' drag coefficient, we are using 
+          !! the raw input (u,v) to compute 'ksrftms', not the provisionally-marched 'u,v' 
+          !! within the iteration loop of the PBL scheme. 
+
+          if( do_tms ) then
+             call compute_tms( pcols   , pver    , ncol  , &
+                  u8      , v8      , t8       , pmid8   , & 
+                  exner8  , zm8     , sgh      , ksrftms , & 
+                  tautmsx , tautmsy , landfrac )
+             !! Here, both 'taux, tautmsx' are explicit surface stresses.        
+             !! Note that this 'tautotx, tautoty' are different from the total stress
+             !! that has been actually added into the atmosphere. This is because both
+             !! taux and tautmsx are fully implicitly treated within compute_vdiff.
+             !! However, 'tautotx, tautoty' are not used in the actual numerical
+             !! computation in this module.   
+             tautotx(:ncol) = taux(:ncol) + tautmsx(:ncol)
+             tautoty(:ncol) = tauy(:ncol) + tautmsy(:ncol)
+          else
+             ksrftms(:ncol) = 0.0_r8
+             tautotx(:ncol) = taux(:ncol)
+             tautoty(:ncol) = tauy(:ncol)
+          endif
+          
+          !-------------------------------------------------------------------------------------!
+          !We are currenly using just water vapour flux at the surface, therefore we will use   !
+          !just one constituent for the flux                                                        !
+          !-------------------------------------------------------------------------------------!
+          cflx(:pcols,1)   = qfx(i,j) ! Surface constituent flux (kg/m2/s)
+          
+          !Following variables are initialized to zero, they are the output from the "compute_eddy_diff" call
+          ustar8(  :pcols) = 0.0_r8   ! Surface friction velocity       (m/s)
+          pblh(    :pcols) = 0.0_r8   ! Planetary boundary layer height (m  )
+          ipbl(    :pcols) = 0.0_r8   ! If 1, PBL is CL, while if 0, PBL is STL.
+          kpblh(   :pcols) = 0.0_r8   ! Layer index containing PBL top within or at the base interface
+          wstarPBL(:pcols) = 0.0_r8   ! Convective velocity within PBL  (m/s)
+
+
+          !!----------------------------------------------------------------------- !
+          !!   Computation of eddy diffusivities - Select appropriate PBL scheme    !
+          !!----------------------------------------------------------------------- !
+          
+          select case (eddy_scheme)
+          case ( 'diag_TKE' ) 
+             
+             !! ---------------------------------------------------------------- !
+             !! At first time step, have eddy_diff.F90:caleddy() use kvh=kvm=kvf !
+             !! This has to be done in compute_eddy_diff after kvf is calculated !
+             !! ---------------------------------------------------------------- !
+             
+             kvinit = .false.
+             if(is_first_step) then
+                kvinit = .true.
+             endif
+             !! ---------------------------------------------- !
+             !! Get LW radiative heating out of physics buffer !
+             !! ---------------------------------------------- !
+             
+             !! Retrieve eddy diffusivities for heat and momentum from physics buffer
+             !! from last timestep ( if first timestep, has been initialized by inidat.F90 )
+             
+             kvm_in(:ncol,:) = kvm(:ncol,:) 
+             kvh_in(:ncol,:) = kvh(:ncol,:) 
+             call compute_eddy_diff( lchnk  , pcols  , pver   , ncol   , t8      , cloud(:,:,1)   , ztodt    ,           &
+                  cloud(:,:,2), cloud(:,:,3), s8     , rpdel8 , cldn8  , qrl8    , wsedl8         , zm8      , zi8     , &
+                  pmid8       , pint8       , u8     , v8     , taux   , tauy    , shflx          , cflx(:,1), wstarent, &
+                  nturb       , ustar8      , pblh   , kvm_in , kvh_in , kvm     , kvh            , kvq      , cgh     , &                                                     
+                  cgs         , tpert       , qpert  , wpert  , tke8   , bprod   , sprod          , sfi      , fqsatd  , &
+                  kvinit      , tauresx     , tauresy, ksrftms, ipbl(:), kpblh(:), wstarPBL(:)    , turbtype , smaw      )
+
+             !! ----------------------------------------------- !       
+             !! Store TKE in pbuf for use by shallow convection !
+             !! ----------------------------------------------- !   
+             
+             !! Store updated kvh, kvm in pbuf to use here on the next timestep 
+             do k = kts,kte+1
+                kflip          = kte - k + 2
+                
+                kvh3d(i,k,j)   = kvh(1,kflip)
+                kvm3d(i,k,j)   = kvm(1,kflip)  
+             end do
+             
+             
+          end select
+          
+          !!------------------------------------ ! 
+          !!    Application of diffusivities     !
+          !!------------------------------------ !
+          cloudtnd(  :ncol,:,:) = cloud(:ncol,:,:)
+          stnd(      :ncol,:  ) = s8(   :ncol,:  )
+          wind_tends(:ncol,:,1) = u8(   :ncol,:  )
+          wind_tends(:ncol,:,2) = v8(   :ncol,:  )
+
+          !!------------------------------------------------------ !
+          !! Write profile output before applying diffusion scheme !
+          !!------------------------------------------------------ !
+          
+          sl_prePBL(:ncol,:pver)  = stnd(:ncol,:pver) - latvap * cloudtnd(:ncol,:pver,ixcldliq) &
+               - ( latvap + latice) * cloudtnd(:ncol,:pver,ixcldice)
+          qt_prePBL(:ncol,:pver)  = cloudtnd(:ncol,:pver,1) + cloudtnd(:ncol,:pver,ixcldliq) &
+               + cloudtnd(:ncol,:pver,ixcldice)
+
+          call aqsat( t8, pmid8, tem2, ftem, pcols, ncol, pver, 1, pver )
+          ftem_prePBL(:ncol,:) = cloud(:ncol,:,1)/ftem(:ncol,:)*100._r8
+
+          !! --------------------------------------------------------------------------------- !
+          !! Call the diffusivity solver and solve diffusion equation                          !
+          !! The final two arguments are optional function references to                       !
+          !! constituent-independent and constituent-dependent moleculuar diffusivity routines !
+          !! --------------------------------------------------------------------------------- !
+          
+          !! Modification : We may need to output 'tautotx_im,tautoty_im' from below 'compute_vdiff' and
+          !!                separately print out as diagnostic output, because these are different from
+          !!                the explicit 'tautotx, tautoty' computed above. 
+          !! Note that the output 'tauresx,tauresy' from below subroutines are fully implicit ones.
+
+          if( any(fieldlist_wet) ) then
+             call compute_vdiff( lchnk, pcols, pver, pcnstmax, ncol, pmid8, pint8, rpdel8, t8, ztodt, &
+                  taux, tauy, shflx, cflx, ntop, nbot, kvh, kvm, kvq, cgs, cgh, zi8, ksrftms, qmincg, &
+                  fieldlist_wet, wind_tends(:,:,1), wind_tends(:,:,2), cloudtnd, stnd, tautmsx,       &
+                  tautmsy, dtk, topflx, errstring, tauresx, tauresy, 1, do_molec_diff,                &
+                  compute_molec_diff, vd_lu_qdecomp)
+          end if
+
+          if( errstring .ne. '' ) then
+             call wrf_error_fatal(errstring)
+          endif
+          
+          if( any( fieldlist_dry ) ) then
+             if( do_molec_diff ) then
+                errstring = "Design flaw: dry vdiff not currently supported with molecular diffusion"
+                call wrf_error_fatal(errstring)
+             end if
+             
+             call compute_vdiff( lchnk, pcols, pver, pcnstmax, ncol, pmiddry8, pintdry8, rpdeldry8, t8, &
+                  ztodt, taux, tauy, shflx, cflx, ntop, nbot, kvh, kvm, kvq, cgs, cgh, zi8, ksrftms,    &
+                  qmincg, fieldlist_dry, wind_tends(:,:,1), wind_tends(:,:,2), cloudtnd, stnd, tautmsx, &
+                  tautmsy, dtk, topflx, errstring, tauresx, tauresy, 1, do_molec_diff,                  &
+                  compute_molec_diff, vd_lu_qdecomp)
+
+             if( errstring .ne. '' ) call wrf_error_fatal(errstring)
+
+          end if
+          
+          ! Store updated tauresx, tauresy to use here on the next timestep
+          tauresx2d(i,j) = tauresx(ncol)
+          tauresy2d(i,j) = tauresy(ncol)
+          
+          !! -------------------------------------------------------- !
+          !! Diagnostics and output writing after applying PBL scheme !
+          !! -------------------------------------------------------- !
+          sl(:ncol,:pver)  = stnd(:ncol,:pver) -   latvap           * cloudtnd(:ncol,:pver,ixcldliq) &
+               - ( latvap + latice) * cloudtnd(:ncol,:pver,ixcldice)
+          qt(:ncol,:pver)  = cloudtnd(:ncol,:pver,1) + cloudtnd(:ncol,:pver,ixcldliq) &
+               + cloudtnd(:ncol,:pver,ixcldice)
+          
+          
+          
+          !! --------------------------------------------------------------- !
+          !! Convert the new profiles into vertical diffusion tendencies.    !
+          !! Convert KE dissipative heat change into "temperature" tendency. !
+          !! --------------------------------------------------------------- !
+
+          slten(:ncol,:)          = ( sl(:ncol,:)             - sl_prePBL(:ncol,:) )   * rztodt 
+          qtten(:ncol,:)          = ( qt(:ncol,:)             - qt_prePBL(:ncol,:) )   * rztodt 
+          stnd(:ncol,:)           = ( stnd(:ncol,:)           - s8(:ncol,:) )          * rztodt
+          wind_tends(:ncol,:,1)   = ( wind_tends(:ncol,:,1)   - u8(:ncol,:) )          * rztodt
+          wind_tends(:ncol,:,2)   = ( wind_tends(:ncol,:,2)   - v8(:ncol,:) )          * rztodt
+          cloudtnd(:ncol,:pver,:) = ( cloudtnd(:ncol,:pver,:) - cloud(:ncol,:pver,:) ) * rztodt
+
+          !! ----------------------------------------------------------- !
+          !! In order to perform 'pseudo-conservative varible diffusion' !
+          !! perform the following two stages:                           !
+          !!                                                             !
+          !! I.  Re-set (1) 'qvten' by 'qtten', and 'qlten = qiten = 0'  !
+          !!            (2) 'sten'  by 'slten', and                      !
+          !!            (3) 'qlten = qiten = 0'                          !
+          !!                                                             !
+          !! II. Apply 'positive_moisture'                               !
+          !!                                                             !
+          !! ----------------------------------------------------------- !
+          if( eddy_scheme .eq. 'diag_TKE' .and. do_pseudocon_diff ) then
+             cloudtnd(:ncol,:pver,1) = qtten(:ncol,:pver)
+             stnd(:ncol,:pver)       = slten(:ncol,:pver)
+             cloudtnd(:ncol,:pver,ixcldliq) = 0._r8         
+             cloudtnd(:ncol,:pver,ixcldice) = 0._r8         
+             cloudtnd(:ncol,:pver,ixnumliq) = 0._r8         
+             cloudtnd(:ncol,:pver,ixnumice) = 0._r8         
+             
+             do ips = 1, ncol
+                do k = 1, pver
+                   qv_pro(ips,k) = cloud(ips,k,1)        + cloudtnd(ips,k,1)             * ztodt       
+                   ql_pro(ips,k) = cloud(ips,k,ixcldliq) + cloudtnd(ips,k,ixcldliq)      * ztodt
+                   qi_pro(ips,k) = cloud(ips,k,ixcldice) + cloudtnd(ips,k,ixcldice)      * ztodt              
+                   s_pro(ips,k)  = s8(ips,k)             + stnd(ips,k)                   * ztodt
+                   t_pro(ips,k)  = t8(ips,k)             + (1._r8/cpair)*stnd(ips,k) * ztodt
+
+                end do
+             end do
+             call positive_moisture( cpair, latvap, latvap+latice, ncol, pver, ztodt, qmin(1), qmin(2), qmin(3),    &
+                  pdel8(:ncol,pver:1:-1), qv_pro(:ncol,pver:1:-1), ql_pro(:ncol,pver:1:-1), &
+                  qi_pro(:ncol,pver:1:-1), t_pro(:ncol,pver:1:-1), s_pro(:ncol,pver:1:-1),       &
+                  cloudtnd(:ncol,pver:1:-1,1), cloudtnd(:ncol,pver:1:-1,ixcldliq),                 &
+                  cloudtnd(:ncol,pver:1:-1,ixcldice), stnd(:ncol,pver:1:-1) )
+             
+          end if
+          
+          !! ----------------------------------------------------------------- !
+          !! Re-calculate diagnostic output variables after vertical diffusion !
+          !! ----------------------------------------------------------------- !
+          qv_aft_PBL(:ncol,:pver)  =   cloud(:ncol,:pver,1)         + cloudtnd(:ncol,:pver,1)        * ztodt
+          ql_aft_PBL(:ncol,:pver)  =   cloud(:ncol,:pver,ixcldliq)  + cloudtnd(:ncol,:pver,ixcldliq) * ztodt
+          qi_aft_PBL(:ncol,:pver)  =   cloud(:ncol,:pver,ixcldice)  + cloudtnd(:ncol,:pver,ixcldice) * ztodt
+
+          s_aft_PBL(:ncol,:pver)   =   s8(:ncol,:pver)           + stnd(:ncol,:pver)          * ztodt
+          t_aftPBL(:ncol,:pver)    = ( s_aft_PBL(:ncol,:pver) - gravit*zm8(:ncol,:pver) ) / cpair 
+          
+          u_aft_PBL(:ncol,:pver)   =  u8(:ncol,:pver)          + wind_tends(:ncol,:pver,1)            * ztodt
+          v_aft_PBL(:ncol,:pver)   =  v8(:ncol,:pver)          + wind_tends(:ncol,:pver,2)            * ztodt
+          
+          call aqsat( t_aftPBL, pmid8, tem2, ftem, pcols, ncol, pver, 1, pver )
+          ftem_aftPBL(:ncol,:pver) = qv_aft_PBL(:ncol,:pver) / ftem(:ncol,:pver) * 100._r8
+          
+          tten(:ncol,:pver)        = ( t_aftPBL(:ncol,:pver)    - t8(:ncol,:pver) )              * rztodt     
+          rhten(:ncol,:pver)       = ( ftem_aftPBL(:ncol,:pver) - ftem_prePBL(:ncol,:pver) )          * rztodt 
+
+
+          !Post processing of the output from CAM 
+          do k=kts,kte
+          
+             kflip = kte-k+1
+             
+             rublten(i,k,j)  = wind_tends(1,kflip,1)
+             rvblten(i,k,j)  = wind_tends(1,kflip,2)
+             rthblten(i,k,j) = stnd(1,kflip)/cpair/exner8(1,kflip)
+             !rqvblten tendency is making the code unstable. Assigned zero for now.Still looking into this issue...
+             !rqiblten tendency computed but not output (JD) ? also above comment may be no longer valid
+             rqvblten(i,k,j) = cloudtnd(1,kflip,1)/(1. - qv_curr(i,k,j))
+             rqcblten(i,k,j) = cloudtnd(1,kflip,2)/(1. - qv_curr(i,k,j))
+             tke_pbl (i,k,j) = tke8(1,kflip)
+             !if(k==kts+10)print*,i,j,k,rublten(i,k,j),rvblten(i,k,j), rqvblten(i,k,j),rqcblten(i,k,j) ,tke_pbl (i,k,j)
+                          
+          end do
+
+          kpbl2d(i,j)  = int(kpblh(1))
+          pblh2d(i,j)  = pblh( 1)
+          tpert2d(i,j) = tpert(1)
+          qpert2d(i,j) = qpert(1)
+          wpert2d(i,j) = wpert(1)
+          
+          !End Post processing of the output from CAM
+       enddo !loop of i
+    enddo !loop of j
+    return
+  end subroutine camuwpbl
+
+
+
+
+!-----------------------------------------------------------------------------------------   
+  subroutine positive_moisture( cp, xlv, xls, ncol, mkx, dt, qvmin, qlmin, qimin, & 
+       dp, qv, ql, qi, t, s, qvten, qlten, qiten, sten )
+    !! ------------------------------------------------------------------------------- !
+    !! If any 'ql < qlmin, qi < qimin, qv < qvmin' are developed in any layer,         !
+    !! force them to be larger than minimum value by (1) condensating water vapor      !
+    !! into liquid or ice, and (2) by transporting water vapor from the very lower     !
+    !! layer. '2._r8' is multiplied to the minimum values for safety.                  !
+    !! Update final state variables and tendencies associated with this correction.    !
+    !! If any condensation happens, update (s,t) too.                                  !
+    !! Note that (qv,ql,qi,t,s) are final state variables after applying corresponding !
+    !! input tendencies.                                                               !
+    !! Be careful the order of k : '1': near-surface layer, 'mkx' : top layer          ! 
+    !! ------------------------------------------------------------------------------- !
+!-----------------------------------------------------------------------------------------   
+    implicit none
+    integer,  intent(in)     :: ncol, mkx
+    real(r8), intent(in)     :: cp, xlv, xls
+    real(r8), intent(in)     :: dt, qvmin, qlmin, qimin
+    real(r8), intent(in)     :: dp(ncol,mkx)
+    real(r8), intent(inout)  :: qv(ncol,mkx), ql(ncol,mkx), qi(ncol,mkx), t(ncol,mkx), s(ncol,mkx)
+    real(r8), intent(inout)  :: qvten(ncol,mkx), qlten(ncol,mkx), qiten(ncol,mkx), sten(ncol,mkx)
+    integer   i, k
+    real(r8)  dql, dqi, dqv, sum, aa, dum 
+    
+    !! Modification : I should check whether this is exactly same as the one used in
+    !!                shallow convection and cloud macrophysics.
+    
+    do i = 1, ncol
+       do k = mkx, 1, -1    ! From the top to the 1st (lowest) layer from the surface
+          dql        = max(0._r8,1._r8*qlmin-ql(i,k))
+          dqi        = max(0._r8,1._r8*qimin-qi(i,k))
+          qlten(i,k) = qlten(i,k) +  dql/dt
+          qiten(i,k) = qiten(i,k) +  dqi/dt
+          qvten(i,k) = qvten(i,k) - (dql+dqi)/dt
+          sten(i,k)  = sten(i,k)  + xlv * (dql/dt) + xls * (dqi/dt)
+          ql(i,k)    = ql(i,k) +  dql
+          qi(i,k)    = qi(i,k) +  dqi
+          qv(i,k)    = qv(i,k) -  dql - dqi
+          s(i,k)     = s(i,k)  +  xlv * dql + xls * dqi
+          t(i,k)     = t(i,k)  + (xlv * dql + xls * dqi)/cp
+          dqv        = max(0._r8,1._r8*qvmin-qv(i,k))
+          qvten(i,k) = qvten(i,k) + dqv/dt
+          qv(i,k)    = qv(i,k)    + dqv
+          if( k .ne. 1 ) then 
+             qv(i,k-1)    = qv(i,k-1)    - dqv*dp(i,k)/dp(i,k-1)
+             qvten(i,k-1) = qvten(i,k-1) - dqv*dp(i,k)/dp(i,k-1)/dt
+          endif
+          qv(i,k) = max(qv(i,k),qvmin)
+          ql(i,k) = max(ql(i,k),qlmin)
+          qi(i,k) = max(qi(i,k),qimin)
+       end do
+       !! Extra moisture used to satisfy 'qv(i,1)=qvmin' is proportionally 
+       !! extracted from all the layers that has 'qv > 2*qvmin'. This fully
+       !! preserves column moisture. 
+       if( dqv .gt. 1.e-20_r8 ) then
+          sum = 0._r8
+          do k = 1, mkx
+             if( qv(i,k) .gt. 2._r8*qvmin ) sum = sum + qv(i,k)*dp(i,k)
+          enddo
+          aa = dqv*dp(i,1)/max(1.e-20_r8,sum)
+          if( aa .lt. 0.5_r8 ) then
+             do k = 1, mkx
+                if( qv(i,k) .gt. 2._r8*qvmin ) then
+                   dum        = aa*qv(i,k)
+                   qv(i,k)    = qv(i,k) - dum
+                   qvten(i,k) = qvten(i,k) - dum/dt
+                endif
+             enddo
+          else 
+             write(iulog,*) 'Full positive_moisture is impossible in vertical_diffusion'
+          endif
+       endif
+    end do
+    return
+    
+  end subroutine positive_moisture
+  
+  
+ 
+ !-----------------------------------------------------------------------------------------   
+  subroutine camuwpblinit(rublten,rvblten,rthblten,rqvblten, &
+       restart,tke_pbl,grid_id,                              &
+       ids,ide,jds,jde,kds,kde,                            &
+       ims,ime,jms,jme,kms,kme,                            &
+       its,ite,jts,jte,kts,kte)
+    !!------------------------------------------------------------------!
+    !! Initialization of time independent fields for vertical diffusion !
+    !! Calls initialization routines for subsidiary modules             !
+    !!----------------------------------------------------------------- !
+
+    !This subroutine is based on vertical_diffusion_init of CAM. This subroutine 
+    !initializes variables for vertical diffusion subroutine calls. The layout 
+    !is kept similar to the original CAM subroutine to facillitate future adaptations.
+!-----------------------------------------------------------------------------------------
+
+    use eddy_diff,              only : init_eddy_diff
+    use molec_diff,             only : init_molec_diff
+    use trb_mtn_stress,         only : init_tms
+    use diffusion_solver,       only : init_vdiff, vdiff_select
+    use constituents,           only : cnst_get_ind, cnst_get_type_byind, cnst_name
+    use module_cam_support,     only : masterproc
+    use module_model_constants, only : epsq2
+    
+    implicit none
+
+    !-------------------------------------------------------------------------------------!
+    !Input and output variables                                                           !
+    !-------------------------------------------------------------------------------------!
+    logical,intent(in) :: restart
+    integer,intent(in) :: grid_id
+    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(out) :: &
+         rublten, rvblten, rthblten, rqvblten,TKE_PBL
+
+    !-------------------------------------------------------------------------------------!
+    !Local Variables                                                                      ! 
+    !-------------------------------------------------------------------------------------!
+    integer        :: i,j,k,itf,jtf,ktf 
+    integer        :: ntop_eddy         !! Top    interface level to which eddy vertical diffusion is applied ( = 1 )
+    integer        :: nbot_eddy         !! Bottom interface level to which eddy vertical diffusion is applied ( = pver )
+    integer        :: ntop_molec        !! Top    interface level to which molecular vertical diffusion is applied ( = 1 )
+    integer        :: nbot_molec        !! Bottom interface level to which molecular vertical diffusion is applied
+    integer        :: pcnstmax          !  number of constituents
+    character(128) :: errstring         !! Error status for init_vdiff
+    real(r8)       :: hypm(kte)         !! reference state midpoint pressures
+    
+
+     !Declare maximum number of constituents to be considered. pcnst is 7 in WRF but we are using 4 constituents
+     pcnstmax = 4 
+ 
+     jtf   = min(jte,jde-1)
+     ktf   = min(kte,kde-1)
+     itf   = min(ite,ide-1)
+ 
+     !Map CAM veritcal level variables
+     pver  = ktf - kts + 1
+     pverp = pver + 1
+
+     !Initialize flags and add constituents
+     call vd_register()  
+ 
+     !! ----------------------------------------------------------------- !
+     !! Get indices of cloud liquid and ice within the constituents array !
+     !! ----------------------------------------------------------------- !
+     
+     call cnst_get_ind( 'CLDLIQ', ixcldliq )
+     call cnst_get_ind( 'CLDICE', ixcldice )
+     if( microp_scheme .eq. 'MG' ) then
+        call cnst_get_ind( 'NUMLIQ', ixnumliq )
+        call cnst_get_ind( 'NUMICE', ixnumice )
+     endif
+ 
+     if (masterproc) then
+        write(iulog,*)'Initializing vertical diffusion (vertical_diffusion_init)'
+     end if
+     
+     !! ---------------------------------------------------------------------------------------- !
+     !! Initialize molecular diffusivity module                                                  !
+     !! Molecular diffusion turned on above ~60 km (50 Pa) if model top is above ~90 km (.1 Pa). !
+     !! Note that computing molecular diffusivities is a trivial expense, but constituent        !
+     !! diffusivities depend on their molecular weights. Decomposing the diffusion matric        !
+     !! for each constituent is a needless expense unless the diffusivity is significant.        !
+     !! ---------------------------------------------------------------------------------------- !
+     
+     ntop_molec = 1       !! Should always be 1
+     nbot_molec = 0       !! Should be set below about 70 km
+  
+     !! ---------------------------------- !    
+     !! Initialize eddy diffusivity module !
+     !! ---------------------------------- !
+     
+     ntop_eddy  = 1       !! No reason not to make this 1, if > 1, must be <= nbot_molec
+     nbot_eddy  = pver    !! Should always be pver
+
+     if( masterproc ) write(iulog,fmt='(a,i3,5x,a,i3)') 'NTOP_EDDY  =', ntop_eddy, 'NBOT_EDDY  =', nbot_eddy
+
+     select case ( eddy_scheme )
+     case ( 'diag_TKE' ) 
+        if( masterproc ) write(iulog,*) 'vertical_diffusion_init: eddy_diffusivity scheme: UW Moist Turbulence Scheme by Bretherton and Park'
+
+        !! Check compatibility of eddy and shallow scheme
+        if( shallow_scheme .ne. 'UW' ) then
+           write(iulog,*) 'ERROR: shallow convection scheme ', shallow_scheme,' is incompatible with eddy scheme ', eddy_scheme
+           call wrf_error_fatal( 'convect_shallow_init: shallow_scheme and eddy_scheme are incompatible' )
+        endif
+        
+        call init_eddy_diff( r8, pver, gravit, cpair, rair, zvir, latvap, latice, &
+             ntop_eddy, nbot_eddy, hypm, karman )
+
+        if( masterproc ) write(iulog,*) 'vertical_diffusion: nturb, ntop_eddy, nbot_eddy ', nturb, ntop_eddy, nbot_eddy
+     end select
+
+     !!-------------------------------------------------------------------------------------!
+     !! The vertical diffusion solver must operate                                          !
+     !! over the full range of molecular and eddy diffusion                                 !
+     !!-------------------------------------------------------------------------------------!
+     
+     ntop = min(ntop_molec,ntop_eddy)
+     nbot = max(nbot_molec,nbot_eddy)
+
+     !! ------------------------------------------- !
+     !! Initialize turbulent mountain stress module !
+     !! ------------------------------------------- !
+     
+     if( do_tms ) then
+        call init_tms( r8, tms_orocnst, karman, gravit, rair )
+        if (masterproc) then
+           write(iulog,*)'Using turbulent mountain stress module'
+           write(iulog,*)'  tms_orocnst = ',tms_orocnst
+        end if
+     endif
+     
+     !! ---------------------------------- !
+     !! Initialize diffusion solver module !
+     !! ---------------------------------- !
+ 
+     call init_vdiff( r8, pcnstmax, rair, gravit, fieldlist_wet, fieldlist_dry, errstring )
+     if( errstring .ne. '' ) call wrf_error_fatal( errstring )
+     
+     !!-------------------------------------------------------------------------------------
+     !! Use fieldlist_wet to select the fields which will be diffused using moist mixing ratios ( all by default )
+     !! Use fieldlist_dry to select the fields which will be diffused using dry   mixing ratios.
+     !!-------------------------------------------------------------------------------------
+     
+     if( vdiff_select( fieldlist_wet, 'u' ) .ne. '' ) call wrf_error_fatal( vdiff_select( fieldlist_wet, 'u' ) )
+     if( vdiff_select( fieldlist_wet, 'v' ) .ne. '' ) call wrf_error_fatal( vdiff_select( fieldlist_wet, 'v' ) )
+     if( vdiff_select( fieldlist_wet, 's' ) .ne. '' ) call wrf_error_fatal( vdiff_select( fieldlist_wet, 's' ) )
+ 
+     do k = 1, pcnstmax
+        if( cnst_get_type_byind(k) .eq. 'wet' ) then
+           if( vdiff_select( fieldlist_wet, 'q', k ) .ne. '' ) call wrf_error_fatal( vdiff_select( fieldlist_wet, 'q', k ) )
+        else
+           if( vdiff_select( fieldlist_dry, 'q', k ) .ne. '' ) call wrf_error_fatal( vdiff_select( fieldlist_dry, 'q', k ) )
+        endif
+     enddo
+ 
+     !Initialize the tendencies
+     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
+                 tke_pbl(i,k,j)  = epsq2
+                 rublten(i,k,j)  = 0.
+                 rvblten(i,k,j)  = 0.
+                 rthblten(i,k,j) = 0.
+                 rqvblten(i,k,j) = 0.
+              enddo
+           enddo
+        enddo
+     endif
+   end subroutine camuwpblinit
+
+
+
+!-----------------------------------------------------------------------------------------
+  subroutine vd_register()
+!
+!This subroutine is based on the vd_register subroutine of CAM. Some additional 
+!initializations are included in this subroutine.
+!
+!-----------------------------------------------------------------------------------------
+    
+    use module_cam_esinti, only : esinti
+    use physconst,         only : mwh2o, cpwv, epsilo, latvap, latice, rh2o, cpair, tmelt
+    use constituents,      only : cnst_add
+    
+    !Local Workspace
+    integer            :: mm
+    logical            :: moist_physics 
+    
+    !Following declarations are from CAM's stratiform.F90 module
+    integer, parameter :: ncnstmax = 4                    ! Number of constituents
+
+    character(len=8), dimension(ncnstmax), parameter :: cnst_names = & 
+         (/'CLDLIQ', 'CLDICE','NUMLIQ','NUMICE'/)         ! Constituent names
+
+    if(vd_registered) return
+
+    !Set flags for the PBL scheme (these flags are obtained using phys_getopts in CAM) 
+    microp_scheme  = 'MG'       !Used for adding constituents
+    eddy_scheme    = 'diag_TKE' !Used for calling eddy scheme 
+
+    !The following flag is deliberately set to UW for now. 
+    shallow_scheme = 'UW'       !Eddy scheme is ONLY compaticle with 'UW' shallow scheme; 
+
+    do_tms         = .false.    !To include stresses due to orography
+    tms_orocnst    = 1._r8      !Orography constant
+    
+    !-------------------------------------------------------------------------------------!
+    !Calls to add constituents (these calls are imported from in initindx.F90 in CAM)     !
+    !                                                                                     !
+    ! Register water vapor.                                                               !
+    ! ** This must be the first call to cnst_add so that water vapor is constituent 1.**  !
+    !-------------------------------------------------------------------------------------!
+
+    moist_physics  = .true.  !This declaration is included to mimic CAM 
+
+    if (moist_physics) then
+       call cnst_add('Q', mwh2o, cpwv, 1.E-12_r8, mm, &
+            longname='Specific humidity', readiv=.true. )
+    else
+       call cnst_add('Q', mwh2o, cpwv, 0.0_r8   , mm, &
+            longname='Specific humidity', readiv=.false.)
+    end if
+    
+    !Following add constituent calls are imported from the stratiform.F90 in CAM
+    
+    call cnst_add(cnst_names(1), mwdry, cpair, 0._r8, ixcldliq, &
+         longname='Grid box averaged cloud liquid amount')
+    call cnst_add(cnst_names(2), mwdry, cpair, 0._r8, ixcldice, &
+         longname='Grid box averaged cloud ice amount'   )
+
+    if ( microp_scheme .eq. 'MG' ) then
+       call cnst_add(cnst_names(3), mwdry, cpair, 0._r8, ixnumliq, &
+            longname='Grid box averaged cloud liquid number')
+       call cnst_add(cnst_names(4), mwdry, cpair, 0._r8, ixnumice, &
+            longname='Grid box averaged cloud ice number'   )
+    end if
+    
+    !-------------------------------------------------------------------------------------!
+    ! Initialize the saturation vapor pressure look-up table...                           !
+    ! This could be moved to a master cam-init subroutine too if it is needed             !
+    ! by more than one CAM parameterization. In CAM this is called from                   !
+    ! phys_init.                                                                          !
+    !-------------------------------------------------------------------------------------!
+
+    call esinti(epsilo, latvap, latice, rh2o, cpair, tmelt)
+
+    vd_registered = .true.
+    
+  end subroutine vd_register
+  
+end module module_bl_camuwpbl_driver
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_gfs.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_gfs.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_gfs.F	(revision 17)
@@ -0,0 +1,1155 @@
+!LWRF:MODEL_LAYER:PHYSICS
+!
+MODULE module_bl_gfs
+
+CONTAINS
+
+!-------------------------------------------------------------------          
+   SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
+                  RUBLTEN,RVBLTEN,RTHBLTEN,                        &
+                  RQVBLTEN,RQCBLTEN,RQIBLTEN,          	           & 
+                  CP,G,ROVCP,R,ROVG,P_QI,P_FIRST_SCALAR,           &
+                  dz8w,z,PSFC,                                     &
+                  UST,PBL,PSIM,PSIH,                               &
+                  HFX,QFX,TSK,GZ1OZ0,WSPD,BR,                      &
+                  DT,KPBL2D,EP1,KARMAN,                            &
+#if (NMM_CORE==1)
+                  DISHEAT,                                         &
+#endif
+                  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
+!-------------------------------------------------------------------
+      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
+!-------------------------------------------------------------------
+
+#if (NMM_CORE==1)
+      LOGICAL , INTENT(IN)::            DISHEAT                         !  gopal's doing
+#endif
+
+      INTEGER, INTENT(IN) ::            ids,ide, jds,jde, kds,kde,      &
+                                        ims,ime, jms,jme, kms,kme,      &
+                                        its,ite, jts,jte, kts,kte,      &
+                                        P_QI,P_FIRST_SCALAR
+
+      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,                           &
+                                        QI3D,                           &
+                                        QV3D,                           &
+                                        T3D,                            &
+                                        TH3D,                           &
+                                        U3D,                            &
+                                        V3D,                            &
+                                        Z   
+
+
+      REAL,    DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::   &
+                                        RTHBLTEN,                       &
+                                        RQCBLTEN,                       &
+                                        RQIBLTEN,                       &
+                                        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 
+
+
+!--------------------------- LOCAL VARS ------------------------------
+
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte) ::         &
+                                        DEL,                            &
+                                        DU,                             &
+                                        DV,                             &
+                                        PHIL,                           &
+                                        PRSL,                           &
+                                        PRSLK,                          &
+                                        T1,                             &
+                                        TAU,                            &
+                                        dishx,                          &
+                                        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,                            &
+                                        cpmikj,                         &
+                                        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 (P_QI.ge.P_FIRST_SCALAR) 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 (P_QI.ge.P_FIRST_SCALAR) 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)
+
+!============================================================================
+!    ADD  IN  DISSIPATIVE HEATING .... v*dv. This is Bob's doing
+!============================================================================
+
+#if (NMM_CORE==1)
+
+      IF(DISHEAT)THEN
+       DO k=kts,kte
+         DO i=its,ite
+          dishx(i,k)=u1(i,k)*du(i,k) + v1(i,k)*dv(i,k)
+          cpmikj=CP*(1.+0.8*QV3D(i,k,j))
+          dishx(i,k)=-dishx(i,k)/cpmikj
+!         IF(k==1)WRITE(0,*)'ADDITIONAL DISSIPATIVE HEATING',tau(i,k),dishx(i,k)
+          tau(i,k)=tau(i,k)+dishx(i,k)
+         ENDDO 
+       ENDDO 
+      ENDIF
+#endif
+
+!=============================================================================
+
+
+      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 (P_QI.ge.P_FIRST_SCALAR) 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
+
+   IF (P_QI .ge. P_FIRST_SCALAR) 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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_gwdo.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_gwdo.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_gwdo.F	(revision 17)
@@ -0,0 +1,700 @@
+! WRf:model_layer:physics
+!
+!
+!
+!
+!
+module module_bl_gwdo
+contains
+!
+!-------------------------------------------------------------------
+!
+   subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, &
+                  rublten,rvblten, &
+                  dtaux3d,dtauy3d,dusfcg,dvsfcg, &
+                  var2d,oc12d,oa2d1,oa2d2,oa2d3,oa2d4,ol2d1,ol2d2,ol2d3,ol2d4, &
+                  znu,znw,mut,p_top, &
+                  cp,g,rd,rv,ep1,pi, &
+                  dt,dx,kpbl2d,itimestep, &
+                  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)
+!-- p3di 3d pressure (pa) at interface level
+!-- pi3d 3d exner function (dimensionless)
+!-- rublten u tendency due to
+! pbl parameterization (m/s/s)
+!-- rvblten v tendency due to
+!-- cp heat capacity at constant pressure for dry air (j/kg/k)
+!-- g acceleration due to gravity (m/s^2)
+!-- rd gas constant for dry air (j/kg/k)
+!-- z height above sea level (m)
+!-- rv gas constant for water vapor (j/kg/k)
+!-- dt time step (s)
+!-- dx model grid interval (m)
+!-- ep1 constant for virtual temperature (r_v/r_d - 1) (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
+!-------------------------------------------------------------------
+!
+  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
+!
+  real, intent(in ) :: dt,dx,cp,g,rd,rv,ep1,pi
+!
+  real, dimension( ims:ime, kms:kme, jms:jme ) , &
+            intent(in ) :: qv3d, &
+                                                                          p3d, &
+                                                                         pi3d, &
+                                                                          t3d, &
+                                                                             z
+  real, dimension( ims:ime, kms:kme, jms:jme ) , &
+            intent(in ) :: p3di
+!
+  real, dimension( ims:ime, kms:kme, jms:jme ) , &
+            intent(inout) :: rublten, &
+                                                                      rvblten
+  real, dimension( ims:ime, kms:kme, jms:jme ) , &
+            intent(inout) :: dtaux3d, &
+                                                                      dtauy3d
+!
+  real, dimension( ims:ime, kms:kme, jms:jme ) , &
+             intent(in ) :: u3d, &
+                                                                          v3d
+!
+  integer, dimension( ims:ime, jms:jme ) , &
+             intent(in ) :: kpbl2d
+  real, dimension( ims:ime, jms:jme ) , &
+             intent(inout ) :: dusfcg, &
+                                                                       dvsfcg
+!
+  real, dimension( ims:ime, jms:jme ) , &
+             intent(in ) :: var2d, &
+                                                                        oc12d, &
+                                                      oa2d1,oa2d2,oa2d3,oa2d4, &
+                                                      ol2d1,ol2d2,ol2d3,ol2d4
+!
+  real, dimension( ims:ime, jms:jme ) , &
+             optional , &
+             intent(in ) :: mut
+!
+  real, dimension( kms:kme ) , &
+             optional , &
+             intent(in ) :: znu, &
+                                                                          znw
+!
+  real, optional, intent(in ) :: p_top
+!
+!local
+!
+  real, dimension( its:ite, kts:kte ) :: delprsi, &
+                                                                          pdh
+  real, dimension( its:ite, kts:kte+1 ) :: pdhi
+  real, dimension( its:ite, 4 ) :: oa4, &
+                                                                          ol4
+  integer :: i,j,k,kdt
+!
+   do j = jts,jte
+      if(present(mut))then
+! For ARW we will replace p and p8w with dry hydrostatic pressure
+        do k = kts,kte+1
+          do i = its,ite
+             if(k.le.kte)pdh(i,k) = mut(i,j)*znu(k) + p_top
+             pdhi(i,k) = mut(i,j)*znw(k) + p_top
+          enddo
+        enddo
+      else
+        do k = kts,kte+1
+          do i = its,ite
+             if(k.le.kte)pdh(i,k) = p3d(i,k,j)
+             pdhi(i,k) = p3di(i,k,j)
+          enddo
+        enddo
+      endif
+!
+      do k = kts,kte
+        do i = its,ite
+          delprsi(i,k) = pdhi(i,k)-pdhi(i,k+1)
+        enddo
+      enddo
+        do i = its,ite
+            oa4(i,1) = oa2d1(i,j)
+            oa4(i,2) = oa2d2(i,j)
+            oa4(i,3) = oa2d3(i,j)
+            oa4(i,4) = oa2d4(i,j)
+            ol4(i,1) = ol2d1(i,j)
+            ol4(i,2) = ol2d2(i,j)
+            ol4(i,3) = ol2d3(i,j)
+            ol4(i,4) = ol2d4(i,j)
+        enddo
+      call gwdo2d(dudt=rublten(ims,kms,j),dvdt=rvblten(ims,kms,j) &
+              ,dtaux2d=dtaux3d(ims,kms,j),dtauy2d=dtauy3d(ims,kms,j) &
+              ,u1=u3d(ims,kms,j),v1=v3d(ims,kms,j) &
+              ,t1=t3d(ims,kms,j),q1=qv3d(ims,kms,j) &
+              ,prsi=pdhi(its,kts),del=delprsi(its,kts) &
+              ,prsl=pdh(its,kts),prslk=pi3d(ims,kms,j) &
+              ,zl=z(ims,kms,j),rcl=1.0 &
+              ,dusfc=dusfcg(ims,j),dvsfc=dvsfcg(ims,j) &
+              ,var=var2d(ims,j),oc1=oc12d(ims,j) &
+              ,oa4=oa4,ol4=ol4 &
+              ,g=g,cp=cp,rd=rd,rv=rv,fv=ep1,pi=pi &
+              ,dxmeter=dx,deltim=dt &
+              ,kpbl=kpbl2d(ims,j),kdt=itimestep,lat=j &
+              ,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 )
+   enddo
+!
+!
+   end subroutine gwdo
+!
+!-------------------------------------------------------------------
+!
+!
+!
+!
+   subroutine gwdo2d(dudt,dvdt,dtaux2d,dtauy2d, &
+                    u1,v1,t1,q1, &
+                    prsi,del,prsl,prslk,zl,rcl, &
+                    var,oc1,oa4,ol4,dusfc,dvsfc, &
+                    g,cp,rd,rv,fv,pi,dxmeter,deltim,kpbl,kdt,lat, &
+                    ids,ide, jds,jde, kds,kde, &
+                    ims,ime, jms,jme, kms,kme, &
+                    its,ite, jts,jte, kts,kte)
+!-------------------------------------------------------------------
+!
+! this code handles the time tendencies of u v due to the effect of mountain
+! induced gravity wave drag from sub-grid scale orography. this routine
+! not only treats the traditional upper-level wave breaking due to mountain
+! variance (alpert 1988), but also the enhanced lower-tropospheric wave
+! breaking due to mountain convexity and asymmetry (kim and arakawa 1995).
+! thus, in addition to the terrain height data in a model grid gox,
+! additional 10-2d topographic statistics files are needed, including
+! orographic standard deviation (var), convexity (oc1), asymmetry (oa4)
+! and ol (ol4). these data sets are prepared based on the 30 sec usgs orography
+! hong (1999). the current scheme was implmented as in hong et al.(2008)
+!
+! coded by song-you hong and young-joon kim and implemented by song-you hong
+!
+! references:
+! hong et al. (2008), wea. and forecasting
+! kim and arakawa (1995), j. atmos. sci.
+! alpet et al. (1988), NWP conference.
+! hong (1999), NCEP office note 424.
+!
+! notice : comparible or lower resolution orography files than model resolution
+! are desirable in preprocess (wps) to prevent weakening of the drag
+!-------------------------------------------------------------------
+!
+! input
+! dudt (ims:ime,kms:kme) non-lin tendency for u wind component
+! dvdt (ims:ime,kms:kme) non-lin tendency for v wind component
+! u1(ims:ime,kms:kme) zonal wind / sqrt(rcl) m/sec at t0-dt
+! v1(ims:ime,kms:kme) meridional wind / sqrt(rcl) m/sec at t0-dt
+! t1(ims:ime,kms:kme) temperature deg k at t0-dt
+! q1(ims:ime,kms:kme) specific humidity at t0-dt
+!
+! rcl a scaling factor = reciprocal of square of cos(lat)
+! for mrf gsm. rcl=1 if u1 and v1 are wind components.
+! deltim time step secs
+! del(kts:kte) positive increment of pressure across layer (pa)
+!
+! output
+! dudt, dvdt wind tendency due to gwdo
+!
+!-------------------------------------------------------------------
+   implicit none
+!-------------------------------------------------------------------
+   integer :: kdt,lat,latd,lond, &
+                            ids,ide, jds,jde, kds,kde, &
+                            ims,ime, jms,jme, kms,kme, &
+                            its,ite, jts,jte, kts,kte
+!
+   real :: g,rd,rv,fv,cp,pi,dxmeter,deltim,rcl
+   real :: dudt(ims:ime,kms:kme),dvdt(ims:ime,kms:kme), &
+                            dtaux2d(ims:ime,kms:kme),dtauy2d(ims:ime,kms:kme), &
+                            u1(ims:ime,kms:kme),v1(ims:ime,kms:kme), &
+                            t1(ims:ime,kms:kme),q1(ims:ime,kms:kme), &
+                            zl(ims:ime,kms:kme),prslk(ims:ime,kms:kme)
+   real :: prsl(its:ite,kts:kte),prsi(its:ite,kts:kte+1), &
+                            del(its:ite,kts:kte)
+   real :: oa4(its:ite,4),ol4(its:ite,4)
+!
+   integer :: kpbl(ims:ime)
+   real :: var(ims:ime),oc1(ims:ime), &
+                            dusfc(ims:ime),dvsfc(ims:ime)
+! critical richardson number for wave breaking : ! larger drag with larger value
+!
+   real,parameter :: ric = 0.25
+!
+   real,parameter :: dw2min = 1.
+   real,parameter :: rimin = -100.
+   real,parameter :: bnv2min = 1.0e-5
+   real,parameter :: efmin = 0.0
+   real,parameter :: efmax = 10.0
+   real,parameter :: xl = 4.0e4
+   real,parameter :: critac = 1.0e-5
+   real,parameter :: gmax = 1.
+   real,parameter :: veleps = 1.0
+   real,parameter :: factop = 0.5
+   real,parameter :: frc = 1.0
+   real,parameter :: ce = 0.8
+   real,parameter :: cg = 0.5
+!
+! local variables
+!
+   integer :: i,k,lcap,lcapp1,nwd,idir,kpblmin,kpblmax, &
+                            klcap,kp1,ikount,kk
+!
+   real :: rcs,rclcs,csg,fdir,cleff,cs,rcsks, &
+                            wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, &
+                            wtkbj,coefm,tem,gfobnv,hd,fro,rim,temc,tem1,efact, &
+                            temv,dtaux,dtauy
+!
+   logical :: ldrag(its:ite),icrilv(its:ite), &
+                            flag(its:ite),kloop1(its:ite)
+!
+   real :: taub(its:ite),taup(its:ite,kts:kte+1), &
+                            xn(its:ite),yn(its:ite), &
+                            ubar(its:ite),vbar(its:ite), &
+                            fr(its:ite),ulow(its:ite), &
+                            rulow(its:ite),bnv(its:ite), &
+                            oa(its:ite),ol(its:ite), &
+                            roll(its:ite),dtfac(its:ite), &
+                            brvf(its:ite),xlinv(its:ite), &
+                            delks(its:ite),delks1(its:ite), &
+                            bnv2(its:ite,kts:kte),usqj(its:ite,kts:kte), &
+                            taud(its:ite,kts:kte),ro(its:ite,kts:kte), &
+                            vtk(its:ite,kts:kte),vtj(its:ite,kts:kte), &
+                            zlowtop(its:ite),velco(its:ite,kts:kte-1)
+!
+   integer :: kbl(its:ite),klowtop(its:ite), &
+                            lowlv(its:ite)
+!
+   logical :: iope
+   integer,parameter :: mdir=8
+   integer :: nwdir(mdir)
+   data nwdir/6,7,5,8,2,3,1,4/
+!
+! initialize local variables
+!
+   kbl=0 ; klowtop=0 ; lowlv=0
+!
+!---- constants
+!
+   rcs = sqrt(rcl)
+   cs = 1. / sqrt(rcl)
+   csg = cs * g
+   lcap = kte
+   lcapp1 = lcap + 1
+   fdir = mdir / (2.0*pi)
+!
+!
+!!!!!!! cleff (subgrid mountain scale ) is highly tunable parameter
+!!!!!!! the bigger (smaller) value produce weaker (stronger) wave drag
+!
+   cleff = max(dxmeter,50.e3)
+!
+! initialize!!
+!
+   dtaux = 0.0
+   dtauy = 0.0
+   do k = kts,kte
+     do i = its,ite
+       usqj(i,k) = 0.0
+       bnv2(i,k) = 0.0
+       vtj(i,k) = 0.0
+       vtk(i,k) = 0.0
+       taup(i,k) = 0.0
+       taud(i,k) = 0.0
+       dtaux2d(i,k)= 0.0
+       dtauy2d(i,k)= 0.0
+     enddo
+   enddo
+   do i = its,ite
+     taup(i,kte+1) = 0.0
+     xlinv(i) = 1.0/xl
+   enddo
+!
+   do k = kts,kte
+     do i = its,ite
+       vtj(i,k) = t1(i,k) * (1.+fv*q1(i,k))
+       vtk(i,k) = vtj(i,k) / prslk(i,k)
+       ro(i,k) = 1./rd * prsl(i,k) / vtj(i,k) ! density kg/m**3
+     enddo
+   enddo
+!
+   do i = its,ite
+     zlowtop(i) = 2. * var(i)
+   enddo
+!
+!--- determine new reference level > 2*var
+!
+   do i = its,ite
+     kloop1(i) = .true.
+   enddo
+   do k = kts+1,kte
+     do i = its,ite
+       if(kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then
+         klowtop(i) = k+1
+         kloop1(i) = .false.
+       endif
+     enddo
+   enddo
+!
+   kpblmax = 2
+   do i = its,ite
+     kbl(i) = max(2, kpbl(i))
+     kbl(i) = max(kbl(i), klowtop(i))
+     delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i)))
+     ubar (i) = 0.0
+     vbar (i) = 0.0
+     taup(i,1) = 0.0
+     oa(i) = 0.0
+     kpblmax = max(kpblmax,kbl(i))
+     flag(i) = .true.
+     lowlv(i) = 2
+   enddo
+   kpblmax = min(kpblmax+1,kte-1)
+!
+! compute low level averages within pbl
+!
+   do k = kts,kpblmax
+     do i = its,ite
+       if (k.lt.kbl(i)) then
+         rcsks = rcs * del(i,k) * delks(i)
+         ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean
+         vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean
+       endif
+     enddo
+   enddo
+!
+! figure out low-level horizontal wind direction
+!
+! nwd 1 2 3 4 5 6 7 8
+! wd w s sw nw e n ne se
+!
+   do i = its,ite
+     wdir = atan2(ubar(i),vbar(i)) + pi
+     idir = mod(nint(fdir*wdir),mdir) + 1
+     nwd = nwdir(idir)
+     oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1)
+     ol(i) = ol4(i,mod(nwd-1,4)+1)
+   enddo
+!
+   kpblmin = kte
+   do i = its,ite
+     kpblmin = min(kpblmin, kbl(i))
+   enddo
+!
+   do i = its,ite
+     if (oa(i).le.0.0) kbl(i) = kpbl(i) + 1
+   enddo
+!
+   do i = its,ite
+     delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i)))
+     delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i)))
+   enddo
+!
+!--- saving richardson number in usqj for migwdi
+!
+   do k = kts,kte-1
+     do i = its,ite
+       ti = 2.0 / (t1(i,k)+t1(i,k+1))
+       rdz = 1./(zl(i,k+1) - zl(i,k))
+       tem1 = u1(i,k) - u1(i,k+1)
+       tem2 = v1(i,k) - v1(i,k+1)
+       dw2 = rcl*(tem1*tem1 + tem2*tem2)
+       shr2 = max(dw2,dw2min) * rdz * rdz
+       bvf2 = g*(g/cp+rdz*(vtj(i,k+1)-vtj(i,k))) * ti
+       usqj(i,k) = max(bvf2/shr2,rimin)
+       bnv2(i,k) = 2*g*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k))
+       bnv2(i,k) = max( bnv2(i,k), bnv2min )
+     enddo
+   enddo
+!
+!-----initialize arrays
+!
+   do i = its,ite
+     xn(i) = 0.0
+     yn(i) = 0.0
+     ubar (i) = 0.0
+     vbar (i) = 0.0
+     roll (i) = 0.0
+     taub (i) = 0.0
+     ulow (i) = 0.0
+     dtfac(i) = 1.0
+     ldrag(i) = .false.
+     icrilv(i) = .false. ! initialize critical level control vector
+   enddo
+!
+!---- compute low level averages
+!---- (u,v)*cos(lat) use uv=(u1,v1) which is wind at t0-1
+!---- use rcs=1/cos(lat) to get wind field
+!
+   do k = 1,kpblmax
+     do i = its,ite
+       if (k .lt. kbl(i)) then
+         rdelks = del(i,k) * delks(i)
+         rcsks = rcs * rdelks
+         ubar(i) = ubar(i) + rcsks * u1(i,k) ! u mean
+         vbar(i) = vbar(i) + rcsks * v1(i,k) ! v mean
+         roll(i) = roll(i) + rdelks * ro(i,k) ! ro mean
+       endif
+     enddo
+   enddo
+!
+!----compute the "low level" or 1/3 wind magnitude (m/s)
+!
+   do i = its,ite
+     ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0)
+     rulow(i) = 1./ulow(i)
+   enddo
+!
+   do k = kts,kte-1
+     do i = its,ite
+       velco(i,k) = (0.5*rcs) * ((u1(i,k)+u1(i,k+1)) * ubar(i) &
+                                + (v1(i,k)+v1(i,k+1)) * vbar(i))
+       velco(i,k) = velco(i,k) * rulow(i)
+       if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0.)) then
+         velco(i,k) = veleps
+       endif
+     enddo
+   enddo
+!
+! no drag when critical level in the base layer
+!
+   do i = its,ite
+     ldrag(i) = velco(i,1).le.0.
+   enddo
+!
+   do k = kts+1,kpblmax-1
+     do i = its,ite
+       if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0.
+     enddo
+   enddo
+!
+! no drag when bnv2.lt.0
+!
+   do k = kts,kpblmax-1
+     do i = its,ite
+       if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. bnv2(i,k).lt.0.
+     enddo
+   enddo
+!
+!-----the low level weighted average ri is stored in usqj(1,1; im)
+!-----the low level weighted average n**2 is stored in bnv2(1,1; im)
+!---- this is called bnvl2 in phys_gwd_alpert_sub not bnv2
+!---- rdelks (del(k)/delks) vert ave factor so we can * instead of /
+!
+   do i = its,ite
+     wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i)
+     bnv2(i,1) = wtkbj * bnv2(i,1)
+     usqj(i,1) = wtkbj * usqj(i,1)
+   enddo
+!
+   do k = kts+1,kpblmax-1
+     do i = its,ite
+       if (k .lt. kbl(i)) then
+         rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i)
+         bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks
+         usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0
+     ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0
+     ldrag(i) = ldrag(i) .or. var(i) .le. 0.0
+   enddo
+!
+! ----- set all ri low level values to the low level value
+!
+   do k = kts+1,kpblmax-1
+     do i = its,ite
+       if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1)
+     enddo
+   enddo
+!
+   do i = its,ite
+     if (.not.ldrag(i)) then
+       bnv(i) = sqrt( bnv2(i,1) )
+       fr(i) = bnv(i) * rulow(i) * var(i)
+       xn(i) = ubar(i) * rulow(i)
+       yn(i) = vbar(i) * rulow(i)
+     endif
+   enddo
+!
+! compute the base level stress and store it in taub
+! calculate enhancement factor, number of mountains & aspect
+! ratio const. use simplified relationship between standard
+! deviation & critical hgt
+!
+   do i = its,ite
+     if (.not. ldrag(i)) then
+       efact = (oa(i) + 2.) ** (ce*fr(i)/frc)
+       efact = min( max(efact,efmin), efmax )
+       coefm = (1. + ol(i)) ** (oa(i)+1.)
+       xlinv(i) = coefm / cleff
+       tem = fr(i) * fr(i) * oc1(i)
+       gfobnv = gmax * tem / ((tem + cg)*bnv(i))
+       taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) &
+                * ulow(i) * gfobnv * efact
+     else
+       taub(i) = 0.0
+       xn(i) = 0.0
+       yn(i) = 0.0
+     endif
+   enddo
+!
+! now compute vertical structure of the stress.
+!
+!----set up bottom values of stress
+!
+   do k = kts,kpblmax
+     do i = its,ite
+       if (k .le. kbl(i)) taup(i,k) = taub(i)
+     enddo
+   enddo
+!
+   do k = kpblmin, kte-1 ! vertical level k loop!
+     kp1 = k + 1
+     do i = its,ite
+!
+!-----unstablelayer if ri < ric
+!-----unstable layer if upper air vel comp along surf vel <=0 (crit lay)
+!---- at (u-c)=0. crit layer exists and bit vector should be set (.le.)
+!
+       if (k .ge. kbl(i)) then
+         icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) &
+                               .or. (velco(i,k) .le. 0.0)
+         brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared
+         brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency
+       endif
+     enddo
+!
+     do i = its,ite
+       if (k .ge. kbl(i) .and. (.not. ldrag(i))) then
+         if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0 ) then
+           temv = 1.0 / velco(i,k)
+           tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5
+           hd = sqrt(taup(i,k) / tem1)
+           fro = brvf(i) * hd * temv
+!
+! rim is the minimum-richardson number by shutts (1985)
+!
+           tem2 = sqrt(usqj(i,k))
+           tem = 1. + tem2 * fro
+           rim = usqj(i,k) * (1.-fro) / (tem * tem)
+!
+! check stability to employ the 'saturation hypothesis'
+! of lindzen (1981) except at tropospheric downstream regions
+!
+           if (rim .le. ric) then ! saturation hypothesis!
+             if ((oa(i) .le. 0. .or. kp1 .ge. lowlv(i) )) then
+               temc = 2.0 + 1.0 / tem2
+               hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i)
+               taup(i,kp1) = tem1 * hd * hd
+             endif
+           else ! no wavebreaking!
+             taup(i,kp1) = taup(i,k)
+           endif
+         endif
+       endif
+     enddo
+   enddo
+!
+   if(lcap.lt.kte) then
+     do klcap = lcapp1,kte
+       do i = its,ite
+         taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap)
+       enddo
+     enddo
+   endif
+!
+! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy
+!
+   do k = kts,kte
+     do i = its,ite
+       taud(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * csg / del(i,k)
+     enddo
+   enddo
+!
+!------limit de-acceleration (momentum deposition ) at top to 1/2 value
+!------the idea is some stuff must go out the 'top'
+!
+   do klcap = lcap,kte
+     do i = its,ite
+       taud(i,klcap) = taud(i,klcap) * factop
+     enddo
+   enddo
+!
+!------if the gravity wave drag would force a critical line
+!------in the lower ksmm1 layers during the next deltim timestep,
+!------then only apply drag until that critical line is reached.
+!
+   do k = kts,kpblmax-1
+     do i = its,ite
+       if (k .le. kbl(i)) then
+         if(taud(i,k).ne.0.) &
+         dtfac(i) = min(dtfac(i),abs(velco(i,k) &
+                   /(deltim*rcs*taud(i,k))))
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     dusfc(i) = 0.
+     dvsfc(i) = 0.
+   enddo
+!
+   do k = kts,kte
+     do i = its,ite
+       taud(i,k) = taud(i,k) * dtfac(i)
+       dtaux = taud(i,k) * xn(i)
+       dtauy = taud(i,k) * yn(i)
+       dtaux2d(i,k) = dtaux
+       dtauy2d(i,k) = dtauy
+       dudt(i,k) = dtaux + dudt(i,k)
+       dvdt(i,k) = dtauy + dvdt(i,k)
+       dusfc(i) = dusfc(i) + dtaux * del(i,k)
+       dvsfc(i) = dvsfc(i) + dtauy * del(i,k)
+     enddo
+   enddo
+!
+   do i = its,ite
+     dusfc(i) = (-1./g*rcs) * dusfc(i)
+     dvsfc(i) = (-1./g*rcs) * dvsfc(i)
+   enddo
+!
+   return
+   end subroutine gwdo2d
+!-------------------------------------------------------------------
+end module module_bl_gwdo
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_mrf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_mrf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_mrf.F	(revision 17)
@@ -0,0 +1,1407 @@
+!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,                              &
+                  p1000mb,                                         &
+                  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   )   ::      P1000mb
+      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),                                 &
+               p1000mb,                                             &
+               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,                                 & 
+                  p1000mb,                                         &
+                  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   )   ::      P1000mb
+      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   
+        THGB(I)=TSK(I)*(P1000mb/PSFCPA(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                                                 
+          THCON=(P1000mb/(PL*1000.))**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
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_myjpbl.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_myjpbl.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_myjpbl.F	(revision 17)
@@ -0,0 +1,1729 @@
+!-----------------------------------------------------------------------
+!
+      MODULE MODULE_BL_MYJPBL
+!
+!-----------------------------------------------------------------------
+!
+      USE MODULE_MODEL_CONSTANTS
+!
+!-----------------------------------------------------------------------
+!
+! REFERENCES:  Janjic (2001), NCEP Office Note 437
+!
+! 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,QCW,QCI,QCS,QCR,QCG    & !BSF
+     &                 ,U,V,RHO,TSK,QSFC,CHKLOWQ,THZ0,QZ0,UZ0,VZ0      & !BSF
+     &                 ,LOWLYR,XLAND,SICE,SNOW                         &
+     &                 ,TKE_MYJ,EXCH_H,USTAR,ZNT,EL_MYJ,PBLH,KPBL,CT   &
+     &                 ,AKHS,AKMS,ELFLX,MIXHT                          &   !PLee (3/07)
+     &                 ,RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN     &
+     &                 ,RQIBLTEN,RQSBLTEN,RQRBLTEN,RQGBLTEN            & !BSF
+     &                 ,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) :: DZ,EXNER   &  !BSF
+     &                                                     ,PMID,PINT  &
+     &                                                     ,RHO        &  !BSF
+     &                                                     ,T,TH,U,V
+!
+      REAL,OPTIONAL,INTENT(IN),DIMENSION(IMS:IME,KMS:KME,JMS:JME)::    &  !BSF
+                                                QV,QCW,QCI,QCS,QCR,QCG    !BSF
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: PBLH,MIXHT            !PLee (3/07)
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: AKHS,AKMS
+!
+      REAL, INTENT(OUT), DIMENSION(IMS:IME,KMS:KME,JMS:JME) ::         &   !BSF
+     &                                         EL_MYJ,RTHBLTEN         &   !BSF
+     &                                        ,RUBLTEN,RVBLTEN        
+!
+      REAL,OPTIONAL,INTENT(OUT),DIMENSION(IMS:IME,KMS:KME,JMS:JME)::   &   !BSF
+     &                                             RQCBLTEN,RQVBLTEN   &   !BSF
+     &                                            ,RQIBLTEN,RQSBLTEN   &   !BSF
+     &                                            ,RQRBLTEN,RQGBLTEN       !BSF
+!
+      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
+!***
+!
+!-- NSPECE is the number of mass SPECies to be vertically mixed
+!   (NSPECS - starting number, NSPECE - ending number)
+!   => Up to 7 species are possible (T,Q,QCW,QCI,QCS,QCR,QCG)
+!
+!-- Logic behind the order of QCW,QCI,QCS,QCR,QCG is based on
+!   increasing terminal fall speed of hydrometeors from cloud
+!   droplets with very low fall speeds (QCW) to fast falling
+!   graupel (QCG)
+!
+      INTEGER, PARAMETER :: NSPECS=1, NSPECE=7  !BSF
+!
+!-- flQI,flQS,flQR,flQG controls what hydrometeors are present
+!   that contribute to total condensate, CWM.  These flags may also be
+!   used in future high resolution runs where all condensate fields
+!   could be vertically mixed (to be determined).  It is assumed
+!   that cloud water is always being passed into the scheme.
+!
+      LOGICAL :: flQI,flQS,flQR,flQG  !BSF
+!
+      INTEGER :: I,J,K,KFLIP,LLOW,LMH,LMXL, NUMS,NSPEC,NSP   !BSF
+!
+      INTEGER,DIMENSION(ITS:ITE,JTS:JTE) :: LPBL
+!
+      REAL :: AKHS_DENS,AKMS_DENS,APEX,DELTAZ,DQDT,DTDIF,DTDT          &   !BSF
+     &       ,DTTURBL,DUDT,DVDT,EXNSFC,PSFC,PTOP,QFC1,QLOW,QOLD,qx     &
+     &       ,RATIOMX,RDTTURBL,RG,RWMSK,SEAMASK,THNEW,THOLD,TX         &
+     &       ,ULOW,VLOW,WMSK
+!
+      REAL, DIMENSION(NSPECS:NSPECE) :: CLOW,CTS,SZ0  !BSF
+!
+      REAL,DIMENSION(KTS:KTE) :: CWMK,Q2K,QK,thk,THvK,TK,UK,VK         & !BSF
+     &                          ,QCWK,QCIK,QCSK,QCRK,QCGK  !BSF
+!
+      REAL, DIMENSION(NSPECS:NSPECE,KTS:KTE) :: SPECIES
+!
+      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,THv, CWM  !BSF
+!
+      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
+!
+!----------------------------------------------------------------------
+!BSF  Begin:
+      NSPEC=3   !-- T, Q, Cloud water
+      flQI=.FALSE.
+      flQS=.FALSE.
+      flQR=.FALSE.
+      flQG=.FALSE.
+!
+      IF (PRESENT(QCI)) THEN
+        flQI=.TRUE.
+        NSPEC=NSPEC+1
+      ENDIF
+!BSF      IF (PRESENT(QCS)) THEN
+!BSF        flQS=.TRUE.
+!BSF        NSPEC=NSPEC+1
+!BSF      ENDIF
+!BSF      IF (PRESENT(QCR)) THEN
+!BSF        flQR=.TRUE.
+!BSF        NSPEC=NSPEC+1
+!BSF      ENDIF
+!BSF      IF (PRESENT(QCG)) THEN
+!BSF        flQG=.TRUE.
+!BSF        NSPEC=NSPEC+1
+!BSF      ENDIF
+!
+!BSF  End:
+
+      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)
+          CWM(I,K,J)=QCW(I,K,J)                          !BSF
+          ratiomx=qv(i,k,j)
+          qx=ratiomx/(1.+ratiomx)
+          IF (flQI) CWM(I,K,J)=CWM(I,K,J)+QCI(I,K,J)     !BSF
+!BSF          IF (flQS) CWM(I,K,J)=CWM(I,K,J)+QCS(I,K,J)
+!BSF          IF (flQR) CWM(I,K,J)=CWM(I,K,J)+QCR(I,K,J)
+!BSF          IF (flQG) CWM(I,K,J)=CWM(I,K,J)+QCG(I,K,J)
+          THv(I,K,J)=(qx*0.608+(1.-cwm(i,k,j)))*TH(I,K,J)
+        ENDDO
+      ENDDO
+      ENDDO
+!
+      EL_MYJ(its:ite,:,jts:jte) = 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)
+            THvK(K)=THv(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,THvK                                   &
+     &               ,Q2K,ZHK,GM,GH,EL                                 &
+     &               ,PBLH(I,J),LPBL(I,J),LMXL,CT(I,J),MIXHT(I,J)      &    !PLee (3/07)
+     &               ,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 UPWARD FROM THE BOTTOM, THOSE SAME COEFFICIENTS AS
+!***  EXCH_H ARE DEFINED ON THE BOTTOMS OF THE LAYERS KTS TO KTE-1
+!***  THUS EXCH_H INDICES INCREASE UPWARD WITH K=KTS AT THE GROUND.
+!
+          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+1,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(KFLIP/=KTE)EL_MYJ(I,K,J)=EL(KFLIP)   ! EL IS NOT DEFINED AT KTE (ground surface)
+          ENDDO
+!
+        ENDDO
+!
+!----------------------------------------------------------------------
+      ENDDO setup_integration
+!----------------------------------------------------------------------
+!
+!***  CONVERT SURFACE SENSIBLE TEMPERATURE TO POTENTIAL TEMPERATURE.
+!
+      DO J=JTS,JTE
+      DO I=ITS,ITE
+        PSFC=PINT(I,LOWLYR(I,J),J)
+        THSK(I,J)=TSK(I,J)*(1.E5/PSFC)**CAPA
+      ENDDO
+      ENDDO
+!
+!----------------------------------------------------------------------
+!
+!----------------------------------------------------------------------
+      main_integration:  DO J=JTS,JTE
+!----------------------------------------------------------------------
+!
+        DO I=ITS,ITE
+!
+!***  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)
+            RATIOMX=QV(I,KFLIP,J)
+            QK(K)=RATIOMX/(1.+RATIOMX)
+            CWMK(K)=CWM(I,KFLIP,J)
+            QCWK(K)=QCW(I,KFLIP,J)
+!BSF  Begin:
+            SPECIES(1,K)=THK(K)
+            SPECIES(2,K)=QK(K)
+            SPECIES(3,K)=QCWK(K)
+            NSP=3
+            IF (flQI) THEN
+              NSP=NSP+1
+              QCIK(K)=QCI(I,KFLIP,J)
+              SPECIES(NSP,K)=QCIK(K)
+            ENDIF
+!BSF            IF (flQS) THEN
+!BSF              NSP=NSP+1
+!BSF              QCSK(K)=QCS(I,KFLIP,J)
+!BSF              SPECIES(NSP,K)=QCSK(K)
+!BSF            ENDIF
+!BSF            IF (flQR) THEN
+!BSF              NSP=NSP+1
+!BSF              QCRK(K)=QCR(I,KFLIP,J)
+!BSF              SPECIES(NSP,K)=QCRK(K)
+!BSF            ENDIF
+!BSF            IF (flQG) THEN
+!BSF              NSP=NSP+1
+!BSF              QCGK(K)=QCG(I,KFLIP,J)
+!BSF              SPECIES(NSP,K)=QCGK(K)
+!BSF            ENDIF
+!BSF  End:
+            ZHK(K)=ZINT(I,K,J)
+            RHOK(K,I)=PMID(I,KFLIP,J)/(R_D*T(I,KFLIP,J)*               &
+     &                                (1.+P608*QK(K)-CWMK(K)))
+          ENDDO
+!
+!***  COUNTING DOWNWARD FROM THE TOP, THE EXCHANGE COEFFICIENTS AKH
+!***  ARE DEFINED ON THE BOTTOMS OF THE LAYERS KTS TO KTE-1.  THESE COEFFICIENTS
+!***  ARE ALSO MULTIPLIED BY THE DENSITY AT THE BOTTOM INTERFACE LEVEL.
+!
+          DO K=KTS,KTE-1
+            AKHK(K)=AKH(I,K,J)*0.5*(RHOK(K,I)+RHOK(K+1,I))
+          ENDDO
+!
+          ZHK(KTE+1)=ZINT(I,KTE+1,J)
+!
+          SEAMASK=XLAND(I,J)-1.
+          THZ0(I,J)=(1.-SEAMASK)*THSK(I,J)+SEAMASK*THZ0(I,J)
+!
+          LLOW=LOWLYR(I,J)
+          AKHS_DENS=AKHS(I,J)*RHOK(KTE+1-LLOW,I)
+!
+          IF(SEAMASK<0.5)THEN
+            QFC1=XLV*CHKLOWQ(I,J)*AKHS_DENS
+!
+            IF(SNOW(I,J)>0..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)
+!
+! BSF: Begin
+          SZ0(1)=THZ0(I,J)
+          SZ0(2)=QZ0 (I,J)
+          DO NUMS=3,NSPECE
+            SZ0(NUMS)=0.
+          ENDDO
+!
+          CLOW(1)=1.
+          CLOW(2)=CHKLOWQ(I,J)
+          DO NUMS=3,NSPECE
+            CLOW(NUMS)=0.
+          ENDDO
+!
+          CTS(1)=CT(I,J)
+          DO NUMS=2,NSPECE
+            CTS(NUMS)=0.
+          ENDDO
+! BSF: End
+!
+!***  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,NSPECS,NSPECE,LPBL(I,J),SZ0             &  !BSF
+     &              ,AKHS_DENS,CLOW,CTS                                &  !BSF
+     &              ,SPECIES,NSPEC,AKHK,ZHK,RHOK(KTS,I)                &  !BSF
+     &              ,IDS,IDE,JDS,JDE,KDS,KDE                           &
+     &              ,IMS,IME,JMS,JME,KMS,KME                           &
+     &              ,ITS,ITE,JTS,JTE,KTS,KTE,I,J)
+!----------------------------------------------------------------------
+!***
+!***  COMPUTE PRIMARY VARIABLE TENDENCIES
+!***
+!BSF Begin:
+          DO K=KTS,KTE
+            THK (K)=SPECIES(1,K)
+            QK  (K)=SPECIES(2,K)
+            QCWK(K)=SPECIES(3,K)
+            CWMK(K)=QCWK(K)
+            NSP=3
+            IF (flQI) THEN
+              NSP=NSP+1
+              QCIK(K)=SPECIES(NSP,K)
+              CWMK(K)=CWMK(K)+QCIK(K)
+            ENDIF
+!BSF            IF (flQS) THEN
+!BSF              NSP=NSP+1
+!BSF              QCSK(K)=SPECIES(NSP,K)
+!BSF              CWMK(K)=CWMK(K)+QCSK(K)
+!BSF            ENDIF
+!BSF            IF (flQR) THEN
+!BSF              NSP=NSP+1
+!BSF              QCRK(K)=SPECIES(NSP,K)
+!BSF              CWMK(K)=CWMK(K)+QCRK(K)
+!BSF            ENDIF
+!BSF            IF (flQG) THEN
+!BSF              NSP=NSP+1
+!BSF              QCGK(K)=SPECIES(NSP,K)
+!BSF              CWMK(K)=CWMK(K)+QCGK(K)
+!BSF            ENDIF
+          ENDDO
+!BSF End:
+!
+          DO K=KTS,KTE
+            KFLIP=KTE+1-K
+            THOLD=TH(I,K,J)
+            THNEW=THK(KFLIP)
+            DTDT=(THNEW-THOLD)*RDTTURBL
+            QOLD=QV(I,K,J)/(1.+QV(I,K,J))
+            DQDT=(QK(KFLIP)-QOLD)*RDTTURBL
+            RTHBLTEN(I,K,J)=DTDT
+            RQVBLTEN(I,K,J)=DQDT/(1.-QK(KFLIP))**2
+!BSF Begin:
+            RQCBLTEN(I,K,J)=(QCWK(KFLIP)-QCW(I,K,J))*RDTTURBL
+            IF (flQI) RQIBLTEN(I,K,J)=(QCIK(KFLIP)-QCI(I,K,J))*RDTTURBL
+!BSF            IF (flQS) RQSBLTEN(I,K,J)=(QCSK(KFLIP)-QCS(I,K,J))*RDTTURBL
+!BSF            IF (flQR) RQRBLTEN(I,K,J)=(QCRK(KFLIP)-QCR(I,K,J))*RDTTURBL
+!BSF            IF (flQG) RQGBLTEN(I,K,J)=(QCGK(KFLIP)-QCG(I,K,J))*RDTTURBL
+!BSF End:
+          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,THv,Q2,Z,GM,GH,EL,PBLH,LPBL,LMXL,CT,MIXHT               &    !PLee(3/07)
+     &,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) :: Q2,THv,U,V
+!
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z
+!
+      REAL,INTENT(OUT) :: PBLH,MIXHT                                         !PLee (3/07)
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(OUT) :: EL,GH,GM
+!
+      REAL,INTENT(INOUT) :: CT
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K,LPBLM
+!
+      REAL :: ADEN,BDEN,AUBR,BUBR,BLMX,EL0,ELOQ2X,GHL,GML              &
+     &       ,QOL2ST,QOL2UN,QDZL,RDZ,SQ,SREL,SZQ,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+1)-Z(LMH+1)
+!
+!-----------------------------------------------------------------------
+      DO K=KTS,LMH
+        Q1(K)=0.
+      ENDDO
+!
+      DO K=1,LMH-1
+        DTH(K)=THv(K)-THv(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)
+!
+        ghl=dth(k)*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)
+      MIXHT=BLMX              !PLee (3/07)
+!
+!----------------------------------------------------------------------
+      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<LMH)THEN
+        DO K=LPBL,LMH-1
+          VKRMZ=(Z(K+1)-Z(LMH+1))*VKARMAN
+          EL(K)=MIN(VKRMZ/(VKRMZ/EL0+1.),ELM(K))
+          REL(K)=EL(K)/ELM(K)
+        ENDDO
+      ENDIF
+!
+      DO K=LPBL+1,LMH-2
+        SREL=MIN(((REL(K-1)+REL(K+1))*0.5+REL(K))*0.5,REL(K))
+        EL(K)=MAX(SREL*ELM(K),EPSL)
+      ENDDO
+!
+!----------------------------------------------------------------------
+      END SUBROUTINE MIXLEN
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!----------------------------------------------------------------------
+                          SUBROUTINE PRODQ2                            &
+!----------------------------------------------------------------------
+!   ******************************************************************
+!   *                                                                *
+!   *            LEVEL 2.5 Q2 PRODUCTION/DISSIPATION                 *
+!   *                                                                *
+!   ******************************************************************
+!
+     &(LMH,DTTURBL,USTAR,GM,GH,EL,Q2                                   &
+     &,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
+!
+      REAL,INTENT(IN) :: DTTURBL,USTAR
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: GH,GM
+      REAL,DIMENSION(KTS:KTE-1),INTENT(INOUT) :: EL
+!
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: Q2
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: ADEN,AEQU,ANUM,ARHS,BDEN,BEQU,BNUM,BRHS,CDEN,CRHS        &
+     &       ,DLOQ1,ELOQ11,ELOQ12,ELOQ13,ELOQ21,ELOQ22,ELOQ31,ELOQ32   &
+     &       ,ELOQ41,ELOQ42,ELOQ51,ELOQ52,ELOQN,EQOL2,GHL,GML          &
+     &       ,RDEN1,RDEN2,RHS2,RHSP1,RHSP2,RHST2
+!
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+!
+      main_integration: DO K=1,LMH-1
+        GML=GM(K)
+        GHL=GH(K)
+!
+!----------------------------------------------------------------------
+!***  COEFFICIENTS OF THE EQUILIBRIUM EQUATION
+!----------------------------------------------------------------------
+!
+        AEQU=(AEQM*GML+AEQH*GHL)*GHL
+        BEQU= BEQM*GML+BEQH*GHL
+!
+!----------------------------------------------------------------------
+!***  EQUILIBRIUM SOLUTION FOR L/Q
+!----------------------------------------------------------------------
+!
+        EQOL2=-0.5*BEQU+SQRT(BEQU*BEQU*0.25-AEQU)
+!
+!----------------------------------------------------------------------
+!***  IS THERE PRODUCTION/DISSIPATION ?
+!----------------------------------------------------------------------
+!
+        IF((GML+GHL*GHL<=EPSTRB)                                       &
+     &   .OR.(GHL>=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(D2T<D2Tmin)THEN
+!           D2Tmin=D2T
+!           IF(D2T<0)KINV=K
+!         ENDIF
+!       ENDDO
+!
+!       IF(KINV<LMH)THEN
+!         DO K=KINV-1,LMH-1
+!           RDZ=2./(Z(K)-Z(K+2))
+!           AKMIN=0.5*RDZ
+!           AKM(K)=MAX(AKM(K),AKMIN)
+!           AKH(K)=MAX(AKH(K),AKMIN)
+!         ENDDO
+!
+!*** Begin debugging
+!         IF(PRINT_DIAG>0)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<LMH)THEN
+!*** End debugging
+!
+!     ENDIF
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE DIFCOF
+!
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!----------------------------------------------------------------------
+                           SUBROUTINE VDIFQ                            &
+!   ******************************************************************
+!   *                                                                *
+!   *               VERTICAL DIFFUSION OF Q2 (TKE)                   *
+!   *                                                                *
+!   ******************************************************************
+     &(LMH,DTDIF,Q2,EL,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
+!
+      INTEGER,INTENT(IN) :: LMH
+!
+      REAL,INTENT(IN) :: DTDIF
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: EL
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z
+!
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: Q2
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: ADEN,AKQS,BDEN,BESH,BESM,CDEN,CF,DTOZS,ELL,ELOQ2,ELOQ4   &
+     &       ,ELQDZ,ESH,ESM,ESQHF,GHL,GML,Q1L,RDEN,RDZ
+!
+      REAL,DIMENSION(KTS:KTE-2) :: AKQ,CM,CR,DTOZ,RSQ2
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+!***
+!***  VERTICAL TURBULENT DIFFUSION
+!***
+!----------------------------------------------------------------------
+      ESQHF=0.5*ESQ
+!
+      DO K=KTS,LMH-2
+        DTOZ(K)=(DTDIF+DTDIF)/(Z(K)-Z(K+2))
+        AKQ(K)=SQRT((Q2(K)+Q2(K+1))*0.5)*(EL(K)+EL(K+1))*ESQHF         &
+     &        /(Z(K+1)-Z(K+2))
+        CR(K)=-DTOZ(K)*AKQ(K)
+      ENDDO
+!
+      CM(1)=DTOZ(1)*AKQ(1)+1.
+      RSQ2(1)=Q2(1)
+!
+      DO K=KTS+1,LMH-2
+        CF=-DTOZ(K)*AKQ(K-1)/CM(K-1)
+        CM(K)=-CR(K-1)*CF+(AKQ(K-1)+AKQ(K))*DTOZ(K)+1.
+        RSQ2(K)=-RSQ2(K-1)*CF+Q2(K)
+      ENDDO
+!
+      DTOZS=(DTDIF+DTDIF)/(Z(LMH-1)-Z(LMH+1))
+      AKQS=SQRT((Q2(LMH-1)+Q2(LMH))*0.5)*(EL(LMH-1)+ELZ0)*ESQHF        &
+     &    /(Z(LMH)-Z(LMH+1))
+!
+      CF=-DTOZS*AKQ(LMH-2)/CM(LMH-2)
+!
+      Q2(LMH-1)=(DTOZS*AKQS*Q2(LMH)-RSQ2(LMH-2)*CF+Q2(LMH-1))          &
+     &        /((AKQ(LMH-2)+AKQS)*DTOZS-CR(LMH-2)*CF+1.)
+!
+      DO K=LMH-2,KTS,-1
+        Q2(K)=(-CR(K)*Q2(K+1)+RSQ2(K))/CM(K)
+      ENDDO
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE VDIFQ
+!
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!---------------------------------------------------------------------
+      SUBROUTINE VDIFH(DTDIF,LMH,MSS,MSE,LPBL,SZ0                     &
+     &                ,RKHS,CLOW,CTS                                  &
+     &                ,SPECIES,NSPEC,RKH,ZHK,RHO                      &
+     &                ,IDS,IDE,JDS,JDE,KDS,KDE                        &
+     &                ,IMS,IME,JMS,JME,KMS,KME                        &
+     &                ,ITS,ITE,JTS,JTE,KTS,KTE,I,J)
+!     ***************************************************************
+!     *                                                             *
+!     *         VERTICAL DIFFUSION OF MASS VARIABLES                *
+!     *                                                             *
+!     * Z. JANJIC MODIFIED TO WORK WITH ARBITRARY NUMBER OF SPECIES *
+!     * ON 05/17/2008                                               *
+!     *                                                             *
+!     ***************************************************************
+!---------------------------------------------------------------------
+!
+      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):: LMH,LPBL,MSS,MSE,NSPEC   !BSF
+!
+!     REAL,INTENT(IN) :: CHKLOWQ,CT,DTDIF,QZ0,RKHS,THZ0
+!
+      REAL,INTENT(IN):: DTDIF,RKHS
+!
+      REAL,DIMENSION(MSS:MSE),INTENT(IN):: CLOW,CTS,SZ0
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN):: RKH
+!
+      REAL,DIMENSION(KTS:KTE  ),INTENT(IN):: RHO
+!
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN):: ZHK
+!
+      REAL,DIMENSION(MSS:MSE,KTS:KTE),INTENT(INOUT):: SPECIES
+
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER:: K,M
+!
+      REAL:: CF,CMB,CMSB,DTOZL,DTOZS,RCML,RHOK,RKHH,RKHZ,RKSS,RSSB
+!
+      REAL,DIMENSION(KTS:KTE-1):: CM,CR,DTOZ
+!
+      REAL,DIMENSION(MSS:MSE,KTS:KTE-1):: RKCT,RSS
+!
+!----------------------------------------------------------------------
+!**********************************************************************
+!---PREPARATIONS-------------------------------------------------------
+      DO K=KTS,LMH-1
+        DTOZ(K)=DTDIF/(ZHK(K)-ZHK(K+1))
+        CR(K)=-DTOZ(K)*RKH(K)
+        IF(K.LT.LPBL) THEN
+          DO M=MSS,NSPEC
+            RKCT(M,K)=0.
+          ENDDO
+        ELSE
+          RKHZ=RKH(K)*(ZHK(K)-ZHK(K+2))
+          DO M=MSS,NSPEC
+            RKCT(M,K)=RKHZ*CTS(M)*0.5
+          ENDDO
+        ENDIF
+      ENDDO
+!---TOP LEVEL----------------------------------------------------------
+      RHOK=RHO(KTS)
+      CM(KTS)=DTOZ(KTS)*RKH(KTS)+RHOK
+      DO M=MSS,NSPEC
+        RSS(M,KTS)=-RKCT(M,KTS)*DTOZ(KTS)+SPECIES(M,KTS)*RHOK
+      ENDDO
+!---INTERMEDIATE LEVELS------------------------------------------------
+      DO K=KTS+1,LMH-1
+        DTOZL=DTOZ(K)
+        CF=-DTOZL*RKH(K-1)/CM(K-1)
+        RHOK=RHO(K)
+        CM(K)=-CR(K-1)*CF+(RKH(K-1)+RKH(K))*DTOZL+RHOK
+        DO M=MSS,NSPEC
+          RSS(M,K)=-RSS(M,K-1)*CF &
+                   +(RKCT(M,K-1)-RKCT(M,K))*DTOZL+SPECIES(M,K)*RHOK
+        ENDDO
+      ENDDO
+!---BOTTOM LEVEL-------------------------------------------------------
+      DTOZS=DTDIF/(ZHK(LMH)-ZHK(LMH+1))
+      RKHH=RKH(LMH-1)
+!
+      CF=-DTOZS*RKHH/CM(LMH-1)
+      CMB=CR(LMH-1)*CF
+      RHOK=RHO(LMH)
+!
+      DO M=MSS,NSPEC
+        RKSS=RKHS*CLOW(M)
+        CMSB=-CMB+(RKHH+RKSS)*DTOZS+RHOK
+        RSSB=-RSS(M,LMH-1)*CF+RKCT(M,LMH-1)*DTOZS+SPECIES(M,LMH)*RHOK
+        SPECIES(M,LMH)=(DTOZS*RKSS*SZ0(M)+RSSB)/CMSB
+      ENDDO
+!---BACKSUBSTITUTION---------------------------------------------------
+      DO K=LMH-1,KTS,-1
+        RCML=1./CM(K)
+        DO M=MSS,NSPEC
+          SPECIES(M,K)=(-CR(K)*SPECIES(M,K+1)+RSS(M,K))*RCML
+        ENDDO
+      ENDDO
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE VDIFH
+!
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!---------------------------------------------------------------------
+      SUBROUTINE VDIFX(DTDIF,LMH,RKHS,CT                              &
+                      ,DUST1,DUST2,RKH,Z,RHO                          &
+                      ,IDS,IDE,JDS,JDE,KDS,KDE                        &
+                      ,IMS,IME,JMS,JME,KMS,KME                        &
+                      ,ITS,ITE,JTS,JTE,KTS,KTE)
+!     ***************************************************************
+!     *                                                             *
+!     *         VERTICAL DIFFUSION OF MASS VARIABLES                *
+!     *                                                             *
+!     ***************************************************************
+!---------------------------------------------------------------------
+!
+      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
+!
+      REAL,INTENT(IN) :: CT,DTDIF,RKHS
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: RKH
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: RHO
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: DUST1,DUST2
+! 
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: CF,CMB,CMDB,CTHF,DTOZL,DTOZS                            &
+             ,RCML,RKHH,RSD1B,RSD2B
+!
+      REAL,DIMENSION(KTS:KTE-1) :: CM,CR,DTOZ,RKCT,RSD1,RSD2
+!
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      CTHF=0.5*CT
+!
+      DO K=KTS,LMH-1
+        DTOZ(K)=DTDIF/(Z(K)-Z(K+1))
+        CR(K)=-DTOZ(K)*RKH(K)
+        RKCT(K)=RKH(K)*(Z(K)-Z(K+2))*CTHF
+      ENDDO
+!
+      CM(KTS)=DTOZ(KTS)*RKH(KTS)+RHO(KTS)
+!----------------------------------------------------------------------
+      RSD1(KTS)=DUST1(KTS)*RHO(KTS)
+      RSD2(KTS)=DUST2(KTS)*RHO(KTS)
+!----------------------------------------------------------------------
+      DO K=KTS+1,LMH-1
+        DTOZL=DTOZ(K)
+        CF=-DTOZL*RKH(K-1)/CM(K-1)
+        CM(K)=-CR(K-1)*CF+(RKH(K-1)+RKH(K))*DTOZL+RHO(K)
+        RSD1(K)=-RSD1(K-1)*CF+DUST1(K)*RHO(K)
+        RSD2(K)=-RSD2(K-1)*CF+DUST2(K)*RHO(K)
+      ENDDO
+!
+      DTOZS=DTDIF/(Z(LMH)-Z(LMH+1))
+      RKHH=RKH(LMH-1)
+!
+      CF=-DTOZS*RKHH/CM(LMH-1)
+!
+      CMB=CR(LMH-1)*CF
+      CMDB=-CMB+RKHH*DTOZS+RHO(LMH)
+!
+      RSD1B=-RSD1(LMH-1)*CF+DUST1(LMH)*RHO(LMH)
+      RSD2B=-RSD2(LMH-1)*CF+DUST2(LMH)*RHO(LMH)
+!----------------------------------------------------------------------
+      DUST1(LMH)=RSD1B/CMDB
+      DUST2(LMH)=RSD2B/CMDB
+!----------------------------------------------------------------------
+      DO K=LMH-1,KTS,-1
+        RCML=1./CM(K)
+        DUST1(K)=(-CR(K)*DUST1(K+1)+RSD1(K))*RCML
+        DUST2(K)=(-CR(K)*DUST2(K+1)+RSD2(K))*RCML
+      ENDDO
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE VDIFX
+
+!---------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!---------------------------------------------------------------------
+      SUBROUTINE VDIFV(LMH,DTDIF,UZ0,VZ0,RKMS,U,V,RKM,Z,RHO           &
+     &                ,IDS,IDE,JDS,JDE,KDS,KDE                        &
+     &                ,IMS,IME,JMS,JME,KMS,KME                        &
+                      ,ITS,ITE,JTS,JTE,KTS,KTE,I,J)
+!     ***************************************************************
+!     *                                                             *
+!     *        VERTICAL DIFFUSION OF VELOCITY COMPONENTS            *
+!     *                                                             *
+!     ***************************************************************
+!---------------------------------------------------------------------
+!
+      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) :: LMH
+!
+      REAL,INTENT(IN) :: RKMS,DTDIF,UZ0,VZ0
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: RKM
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: RHO
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z
+!
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: U,V
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: CF,DTOZAK,DTOZL,DTOZS,RCML,RCMVB,RHOK,RKMH
+!
+      REAL,DIMENSION(KTS:KTE-1) :: CM,CR,DTOZ,RSU,RSV
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      DO K=1,LMH-1
+        DTOZ(K)=DTDIF/(Z(K)-Z(K+1))
+        CR(K)=-DTOZ(K)*RKM(K)
+      ENDDO
+!
+      RHOK=RHO(1)
+      CM(1)=DTOZ(1)*RKM(1)+RHOK
+      RSU(1)=U(1)*RHOK
+      RSV(1)=V(1)*RHOK
+!----------------------------------------------------------------------
+      DO K=2,LMH-1
+        DTOZL=DTOZ(K)
+        CF=-DTOZL*RKM(K-1)/CM(K-1)
+        RHOK=RHO(K)
+        CM(K)=-CR(K-1)*CF+(RKM(K-1)+RKM(K))*DTOZL+RHOK
+        RSU(K)=-RSU(K-1)*CF+U(K)*RHOK
+        RSV(K)=-RSV(K-1)*CF+V(K)*RHOK
+      ENDDO
+!----------------------------------------------------------------------
+      DTOZS=DTDIF/(Z(LMH)-Z(LMH+1))
+      RKMH=RKM(LMH-1)
+!
+      CF=-DTOZS*RKMH/CM(LMH-1)
+      RHOK=RHO(LMH)
+      RCMVB=1./((RKMH+RKMS)*DTOZS-CR(LMH-1)*CF+RHOK)
+      DTOZAK=DTOZS*RKMS
+!----------------------------------------------------------------------
+      U(LMH)=(DTOZAK*UZ0-RSU(LMH-1)*CF+U(LMH)*RHOK)*RCMVB
+      V(LMH)=(DTOZAK*VZ0-RSV(LMH-1)*CF+V(LMH)*RHOK)*RCMVB
+!----------------------------------------------------------------------
+      DO K=LMH-1,1,-1
+        RCML=1./CM(K)
+        U(K)=(-CR(K)*U(K+1)+RSU(K))*RCML
+        V(K)=(-CR(K)*V(K+1)+RSV(K))*RCML
+      ENDDO
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE VDIFV
+!
+!-----------------------------------------------------------------------
+!
+!=======================================================================
+      SUBROUTINE 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                 )
+!-----------------------------------------------------------------------
+      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
+
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) ::    EXCH_H, &
+     &                                                         RUBLTEN, &
+     &                                                         RVBLTEN, &
+     &                                                        RTHBLTEN, &
+     &                                                        RQVBLTEN, &
+     &                                                         TKE_MYJ
+      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
+          TKE_MYJ(I,K,J)=EPSQ2
+          RUBLTEN(I,K,J)=0.
+          RVBLTEN(I,K,J)=0.
+          RTHBLTEN(I,K,J)=0.
+          RQVBLTEN(I,K,J)=0.
+          EXCH_H(I,K,J)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDIF
+
+      END SUBROUTINE MYJPBLINIT
+!-----------------------------------------------------------------------
+!
+      END MODULE MODULE_BL_MYJPBL
+!
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_myjurb.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_myjurb.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_myjurb.F	(revision 17)
@@ -0,0 +1,1803 @@
+!
+      MODULE MODULE_BL_MYJURB
+!
+!-----------------------------------------------------------------------
+!
+      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 MYJURB(IDIFF,FLAG_BEP,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,EXCH_M,USTAR,ZNT,EL_MYJ,PBLH,KPBL,CT   &
+     &                 ,AKHS,AKMS,ELFLX                                &
+     &                 ,RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN     &
+! Variables added for multi-layer UCM
+     &                 ,FRC_URB2D                                      & 
+     &                 ,A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP                &
+     &                 ,A_E_BEP,B_U_BEP,B_V_BEP                        &
+     &                 ,B_T_BEP,B_Q_BEP,B_E_BEP,DLG_BEP                &
+     &                 ,DL_U_BEP,SF_BEP,VL_BEP                         &
+! Multi-layer UCM end
+     &                 ,IDS,IDE,JDS,JDE,KDS,KDE                        &
+     &                 ,IMS,IME,JMS,JME,KMS,KME                        &
+     &                 ,ITS,ITE,JTS,JTE,KTS,KTE)
+!----------------------------------------------------------------------
+!
+      IMPLICIT NONE
+!
+!----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: IDIFF
+      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        
+! Variables added for multi-layer UCM
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: A_U_BEP    &
+     &                                        ,A_V_BEP,A_T_BEP         &
+     &                                        ,A_E_BEP,B_U_BEP         &
+     &                                        ,A_Q_BEP,B_Q_BEP         &
+     &                                        ,B_V_BEP,B_T_BEP         &
+     &                                        ,B_E_BEP,DLG_BEP         &
+     &                                        ,DL_U_BEP                &
+     &                                        ,VL_BEP,SF_BEP
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FRC_URB2D
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME)                          &
+     &    ,INTENT(INOUT) ::                    EXCH_H,EXCH_M,TKE_MYJ
+! UCM end
+
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CT,QSFC,QZ0     &
+     &                                                ,THZ0,USTAR      &
+     &                                                ,UZ0,VZ0,ZNT
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CHKLOWQ,ELFLX
+      LOGICAL,    INTENT(IN   )    ::     FLAG_BEP
+!
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: I,J,K,KFLIP,LLOW,LMH,LMXL
+! Variables added for multi-layer UCM
+      REAL,DIMENSION(KTS:KTE) :: A_U,A_V,A_T,A_E,B_U,B_V,B_T,B_E   !Vertically flipped fields
+      REAL,DIMENSION(KTS:KTE) :: A_Q,B_Q,VLK,DL_U,B_E_FACE,DZ_KFLIP   !Vertically flipped fields
+      REAL,DIMENSION(KTS:KTE) :: SFK                             !Vertically flipped SF,VL
+      INTEGER :: IURB
+      REAL :: SLOPE,ICEPT
+! UCM end
+
+!
+      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(its:ite,:,jts:jte) = 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)
+
+            DZ_KFLIP(K)=DZ(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
+! Multi-layer UCM
+          if(flag_bep)then
+           DO K=KTE,KTS,-1
+            KFLIP=KTE+1-K
+            B_E(K)=B_E_BEP(I,KFLIP,J)
+            A_E(K)=A_E_BEP(I,KFLIP,J)
+            SFK(K)=SF_BEP(I,KFLIP,J)
+            VLK(K)=VL_BEP(I,KFLIP,J)
+            B_E_FACE(K)=0.
+            DL_U(K)=DL_U_BEP(I,KFLIP,J)
+           enddo
+          else
+           DO K=KTE,KTS,-1
+            B_E(K)=0.
+            A_E(K)=0.
+            SFK(K)=1.
+            VLK(K)=1.
+            B_E_FACE(K)=0.
+            DL_U(K)=0.
+           enddo
+          endif
+!UCM end
+! Multi-layer UCM - caculate B_E at grid faces
+!          SFK(1)=1
+         IF (FLAG_BEP) THEN
+          DO K=KTE,KTS,-1
+             IF (K==KTE) THEN
+                B_E_FACE(K)=0.0
+             ELSEIF ( K == KTS ) THEN
+                B_E_FACE(K) = 0.0
+             ELSE
+                SLOPE=(B_E(K-1)-B_E(K))/0.5/(DZ_KFLIP(K-1)+DZ_KFLIP(K))
+                ICEPT=B_E(K)-SLOPE*(ZHK(K)-0.5*DZ_KFLIP(K))
+                B_E_FACE(K)=2.*(SLOPE*ZHK(K)+ICEPT)                         !*2 accounts for Q2K=2.*TKE_MYJ
+             ENDIF
+          ENDDO
+         ENDIF
+!
+!***  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)                 &
+! Multi-layer UCM
+                     ,DL_U                                             &
+! UCM end
+     &               ,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)
+!
+! Multi-layer UCM
+         IF (FLAG_BEP) THEN
+            Q2K(LMH)=Q2K(LMH)*(1-FRC_URB2D(I,J))+(B_E_FACE(LMH)*       &
+                 &         0.5*EL(LMH-1)/11.788/2.)**(2./3.)
+         ENDIF
+!UCM end
+!
+!----------------------------------------------------------------------
+!*** 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))
+! Multi-layer UCM
+            EXCH_H(I,K+1,J)=AKHK(KFLIP)*DELTAZ
+            EXCH_M(I,K+1,J)=AKMK(KFLIP)*DELTAZ
+! UCM end
+          ENDDO
+!----------------------------------------------------------------------
+!***
+!***  CARRY OUT THE VERTICAL DIFFUSION OF
+!***  TURBULENT KINETIC ENERGY
+!***
+!
+
+          CALL VDIFQ(LMH,DTDIF,Q2K,EL,ZHK                             &
+! Multi-layer UCM
+     &              ,A_E,B_E_FACE,SFK,VLK                              &
+! UCM end
+     &              ,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(KFLIP/=KTE)EL_MYJ(I,K,J)=EL(KFLIP)   ! EL IS NOT DEFINED AT KTE (ground surface)
+          ENDDO
+!
+        ENDDO
+!
+!----------------------------------------------------------------------
+      ENDDO setup_integration
+!----------------------------------------------------------------------
+! Multi-layer UCM - if idiff=1 then integration in PBL driver
+      IF(IDIFF.NE.1)then 
+! UCM end
+!
+!***  CONVERT SURFACE SENSIBLE TEMPERATURE TO POTENTIAL TEMPERATURE.
+!
+      DO J=JTS,JTE
+      DO I=ITS,ITE
+        PSFC=PINT(I,LOWLYR(I,J),J)
+        THSK(I,J)=TSK(I,J)*(1.E5/PSFC)**CAPA
+      ENDDO
+      ENDDO
+!
+!----------------------------------------------------------------------
+!
+!----------------------------------------------------------------------
+      main_integration:  DO J=JTS,JTE
+!----------------------------------------------------------------------
+!
+        DO I=ITS,ITE
+!
+!***  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
+            THEK(K)=THE(I,KFLIP,J)
+            RATIOMX=QV(I,KFLIP,J)                            !mixing ratio
+            QK(K)=RATIOMX/(1.+RATIOMX)                       !specific humidity
+            CWMK(K)=CWM(I,KFLIP,J)
+            ZHK(K)=ZINT(I,K,J)
+            RHOK(K,I)=PMID(I,KFLIP,J)/(R_D*T(I,KFLIP,J)*               &
+     &                                (1.+P608*QK(K)-CWMK(K)))
+
+          ENDDO
+!            SFK(1)=1.
+          if(flag_bep)then
+           ! Multi-layer UCM
+           
+            DO K=KTE,KTS,-1
+             KFLIP=KTE+1-K
+             A_Q(K)=A_Q_BEP(I,KFLIP,J)
+             B_Q(K)=B_Q_BEP(I,KFLIP,J)
+             A_T(K)=A_T_BEP(I,KFLIP,J)
+             B_T(K)=B_T_BEP(I,KFLIP,J)
+             SFK(K)=SF_BEP(I,KFLIP,J)
+             VLK(K)=VL_BEP(I,KFLIP,J)             
+            ENDDO
+! UCM end
+          else
+           DO K=KTE,KTS,-1
+             A_Q(K)=0.
+             B_Q(K)=0.
+             A_T(K)=0.
+             B_T(K)=0.
+             SFK(K)=1.
+             VLK(K)=1.
+            ENDDO
+          endif           
+!
+!***  COUNTING DOWNWARD FROM THE TOP, THE EXCHANGE COEFFICIENTS AKH
+!***  ARE DEFINED ON THE BOTTOMS OF THE LAYERS KTS TO KTE-1.  THESE COEFFICIENTS
+!***  ARE ALSO MULTIPLIED BY THE DENSITY AT THE BOTTOM INTERFACE LEVEL.
+!
+          DO K=KTS,KTE-1
+            AKHK(K)=AKH(I,K,J)*0.5*(RHOK(K,I)+RHOK(K+1,I))
+          ENDDO
+!
+          ZHK(KTE+1)=ZINT(I,KTE+1,J)
+!
+          SEAMASK=XLAND(I,J)-1.
+          THZ0(I,J)=(1.-SEAMASK)*THSK(I,J)+SEAMASK*THZ0(I,J)
+!
+          LLOW=LOWLYR(I,J)
+          AKHS_DENS=AKHS(I,J)*RHOK(KTE+1-LLOW,I)
+!
+          IF(SEAMASK<0.5)THEN
+            QFC1=XLV*CHKLOWQ(I,J)*AKHS_DENS
+!
+            IF(SNOW(I,J)>0..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)                 &
+! Multi-layer UCM
+     &              ,A_T,B_T,A_Q,B_Q,SFK,VLK                           &
+! UCM end
+     &              ,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            
+!         SFK(1)=1.
+          if(flag_bep)then
+! Multi-layer UCM           
+           DO K=KTE,KTS,-1
+            KFLIP=KTE+1-K            
+            A_U(K)=A_U_BEP(I,KFLIP,J)
+            A_V(K)=A_V_BEP(I,KFLIP,J)
+            B_U(K)=B_U_BEP(I,KFLIP,J)
+            B_V(K)=B_V_BEP(I,KFLIP,J)
+            SFK(K)=SF_BEP(I,KFLIP,J)
+            VLK(K)=VL_BEP(I,KFLIP,J)
+           ENDDO
+! UCM end
+         else
+           DO K=KTE,KTS,-1            
+            A_U(K)=0.
+            A_V(K)=0.
+            B_U(K)=0.
+            B_V(K)=0.
+            SFK(K)=1.
+            VLK(K)=1.
+           ENDDO
+          endif
+
+          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)              &
+! Multi-layer UCM
+     &              ,A_U,A_V,B_U,B_V,SFK,VLK                           &
+! UCM end
+     &              ,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
+!
+      ENDIF
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE MYJURB
+!
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!----------------------------------------------------------------------
+                          SUBROUTINE MIXLEN                           &
+!----------------------------------------------------------------------
+!   ******************************************************************
+!   *                                                                *
+!   *                   LEVEL 2.5 MIXING LENGTH                      *
+!   *                                                                *
+!   ******************************************************************
+!
+     &(LMH,U,V,T,THE,Q,CWM,Q2,Z,GM,GH,EL,PBLH,LPBL,LMXL,CT             &
+! Multi-layer UCM
+     &,DL_U                                                            &
+! UCM end
+     &,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
+! Multi-layer UCM
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: DL_U
+! UCM end
+!
+      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+1)-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<LMH)THEN
+        DO K=LPBL,LMH-1
+          VKRMZ=(Z(K+1)-Z(LMH+1))*VKARMAN
+! Multi-layer UCM
+          IF (DL_U(K).GT.0.0) THEN
+               EL(K)=MIN(VKRMZ/(VKRMZ/EL0+1.),ELM(K))
+               EL(K)=1./(1./EL(K)+1./DL_U(K))
+            ELSE
+               EL(K)=MIN(VKRMZ/(VKRMZ/EL0+1.),ELM(K))       
+          ENDIF
+! UCM end
+          REL(K)=EL(K)/ELM(K)
+        ENDDO
+      ENDIF
+!
+      DO K=LPBL+1,LMH-2
+        SREL=MIN(((REL(K-1)+REL(K+1))*0.5+REL(K))*0.5,REL(K))
+        EL(K)=MAX(SREL*ELM(K),EPSL)
+      ENDDO
+!
+!----------------------------------------------------------------------
+      END SUBROUTINE MIXLEN
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!----------------------------------------------------------------------
+                          SUBROUTINE PRODQ2                            &
+!----------------------------------------------------------------------
+!   ******************************************************************
+!   *                                                                *
+!   *            LEVEL 2.5 Q2 PRODUCTION/DISSIPATION                 *
+!   *                                                                *
+!   ******************************************************************
+!
+     &(LMH,DTTURBL,USTAR,GM,GH,EL,Q2                                   &
+     &,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
+!
+      REAL,INTENT(IN) :: DTTURBL,USTAR
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: GH,GM
+      REAL,DIMENSION(KTS:KTE-1),INTENT(INOUT) :: EL
+!
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: Q2
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: ADEN,AEQU,ANUM,ARHS,BDEN,BEQU,BNUM,BRHS,CDEN,CRHS        &
+     &       ,DLOQ1,ELOQ11,ELOQ12,ELOQ13,ELOQ21,ELOQ22,ELOQ31,ELOQ32   &
+     &       ,ELOQ41,ELOQ42,ELOQ51,ELOQ52,ELOQN,EQOL2,GHL,GML          &
+     &       ,RDEN1,RDEN2,RHS2,RHSP1,RHSP2,RHST2
+!
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+!
+      main_integration: DO K=1,LMH-1
+        GML=GM(K)
+        GHL=GH(K)
+!
+!----------------------------------------------------------------------
+!***  COEFFICIENTS OF THE EQUILIBRIUM EQUATION
+!----------------------------------------------------------------------
+!
+        AEQU=(AEQM*GML+AEQH*GHL)*GHL
+        BEQU= BEQM*GML+BEQH*GHL
+!
+!----------------------------------------------------------------------
+!***  EQUILIBRIUM SOLUTION FOR L/Q
+!----------------------------------------------------------------------
+!
+        EQOL2=-0.5*BEQU+SQRT(BEQU*BEQU*0.25-AEQU)
+!
+!----------------------------------------------------------------------
+!***  IS THERE PRODUCTION/DISSIPATION ?
+!----------------------------------------------------------------------
+!
+        IF((GML+GHL*GHL<=EPSTRB)                                       &
+     &   .OR.(GHL>=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(D2T<D2Tmin)THEN
+!           D2Tmin=D2T
+!           IF(D2T<0)KINV=K
+!         ENDIF
+!       ENDDO
+!
+!       IF(KINV<LMH)THEN
+!         DO K=KINV-1,LMH-1
+!           RDZ=2./(Z(K)-Z(K+2))
+!           AKMIN=0.5*RDZ
+!           AKM(K)=MAX(AKM(K),AKMIN)
+!           AKH(K)=MAX(AKH(K),AKMIN)
+!         ENDDO
+!
+!*** Begin debugging
+!         IF(PRINT_DIAG>0)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<LMH)THEN
+!*** End debugging
+!
+!     ENDIF
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE DIFCOF
+!
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!----------------------------------------------------------------------
+                           SUBROUTINE VDIFQ                            &
+!   ******************************************************************
+!   *                                                                *
+!   *               VERTICAL DIFFUSION OF Q2 (TKE)                   *
+!   *                                                                *
+!   ******************************************************************
+     &(LMH,DTDIF,Q2,EL,Z                                               &
+! Multi-layer UCM
+     &,A_E,B_E,SFK,VLK                                                 &
+!UCM end
+     &,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
+!
+      REAL,INTENT(IN) :: DTDIF
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: EL
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z
+!
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: Q2
+! Multi-layer UCM
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: A_E,B_E,VLK
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: SFK
+! UCM end
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: ADEN,AKQS,BDEN,BESH,BESM,CDEN,CF,DTOZS,ELL,ELOQ2,ELOQ4   &
+     &       ,ELQDZ,ESH,ESM,ESQHF,GHL,GML,Q1L,RDEN,RDZ
+!
+      REAL,DIMENSION(KTS:KTE-2) :: AKQ,CM,CR,DTOZ,RSQ2
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+!***
+!***  VERTICAL TURBULENT DIFFUSION
+!***
+!----------------------------------------------------------------------
+      ESQHF=0.5*ESQ
+!
+      DO K=KTS,LMH-2
+        DTOZ(K)=(DTDIF+DTDIF)/(Z(K)-Z(K+2))/VLK(K)                      !Bep
+        AKQ(K)=SFK(K)*SQRT((Q2(K)+Q2(K+1))*0.5)*(EL(K)+EL(K+1))*ESQHF &
+     &        /(Z(K+1)-Z(K+2))                                          !Bep
+        CR(K)=-DTOZ(K)*AKQ(K)
+      ENDDO
+!
+      CM(1)=DTOZ(1)*AKQ(1)+1.
+      RSQ2(1)=Q2(1)+DTDIF*B_E(1)                                     !Bep
+!
+      DO K=KTS+1,LMH-2
+        CF=-DTOZ(K)*AKQ(K-1)/CM(K-1)
+        CM(K)=-CR(K-1)*CF+(AKQ(K-1)+AKQ(K))*DTOZ(K)+1.
+        CM(K)=-CR(K-1)*CF+(AKQ(K-1)+AKQ(K))*DTOZ(K)+1.
+        RSQ2(K)=-RSQ2(K-1)*CF+Q2(K)+DTDIF*B_E(K)                     !Bep
+      ENDDO
+!
+      DTOZS=(DTDIF+DTDIF)/(Z(LMH-1)-Z(LMH+1))/VLK(K)
+      AKQS=SFK(K)*SQRT((Q2(LMH-1)+Q2(LMH))*0.5)*(EL(LMH-1)+ELZ0)*ESQHF& 
+     &    /(Z(LMH)-Z(LMH+1))
+!
+      CF=-DTOZS*AKQ(LMH-2)/CM(LMH-2)
+!
+      Q2(LMH-1)=(DTOZS*AKQS*Q2(LMH)-RSQ2(LMH-2)*CF+Q2(LMH-1)&
+     &              +DTDIF*B_E(LMH-1))          &                    !Bep
+     &        /((AKQ(LMH-2)+AKQS)*DTOZS-CR(LMH-2)*CF+1.)
+!
+      DO K=LMH-2,KTS,-1
+        Q2(K)=(-CR(K)*Q2(K+1)+RSQ2(K))/CM(K)
+      ENDDO
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE VDIFQ
+!
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!---------------------------------------------------------------------
+      SUBROUTINE VDIFH(DTDIF,LMH,THZ0,QZ0,RKHS,CHKLOWQ,CT             &
+     &                ,THE,Q,CWM,RKH_IN,Z,RHO                         &
+! Multi-layer UCM
+     &                ,A_T,B_T,A_Q,B_Q,SFK,VLK                        &
+! UCM end
+     &                ,IDS,IDE,JDS,JDE,KDS,KDE                        &
+     &                ,IMS,IME,JMS,JME,KMS,KME                        &
+     &                ,ITS,ITE,JTS,JTE,KTS,KTE,I,J)
+!     ***************************************************************
+!     *                                                             *
+!     *         VERTICAL DIFFUSION OF MASS VARIABLES                *
+!     *                                                             *
+!     ***************************************************************
+!---------------------------------------------------------------------
+!
+      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) :: LMH
+!
+      REAL,INTENT(IN) :: CHKLOWQ,CT,DTDIF,QZ0,RKHS,THZ0
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: RKH_IN
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: RHO
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: CWM,Q,THE
+! Variables added for Bep
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: A_T,B_T,A_Q,B_Q,VLK
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: SFK
+! Bep end
+!
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: CF,CMB,CMCB,CMQB,CMTB,CTHF,DTOZL,DTOZS                   &
+     &       ,RCML,RKHH,RKQS,RSCB,RSQB,RSTB
+! Variables added for Bep
+      REAL :: CF_T,CF_Q,RCML_T,RCML_Q,CMB_T,CMB_Q
+! Bep end
+!
+      REAL,DIMENSION(KTS:KTE-1) :: CM,CR,DTOZ,RKCT,RSC,RSQ,RST
+! Variables added for Bep
+      REAL,DIMENSION(KTS:KTE-1) :: CM_T,CM_Q
+      REAL,DIMENSION(KTS:KTE-1) :: RKH
+! Bep end
+!
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      CTHF=0.5*CT
+!
+      DO K=KTS,LMH-1
+        RKH(K)=RKH_IN(K)*SFK(K)                                    !Bep
+        DTOZ(K)=DTDIF/(Z(K)-Z(K+1))/VLK(K)                         !Bep
+        CR(K)=-DTOZ(K)*RKH(K)
+        RKCT(K)=RKH(K)*(Z(K)-Z(K+2))*CTHF
+      ENDDO
+!
+      CM(KTS)=DTOZ(KTS)*RKH(KTS)+RHO(KTS)
+      CM_T(KTS)=DTOZ(KTS)*RKH(KTS)+RHO(KTS)*(1.-DTDIF*A_T(KTS))   !Bep
+      CM_Q(KTS)=DTOZ(KTS)*RKH(KTS)+RHO(KTS)*(1.-DTDIF*A_Q(KTS))   !Bep
+!----------------------------------------------------------------------
+      RST(KTS) = -RKCT(KTS)*DTOZ(KTS)+&
+                &RHO(KTS)*(THE(KTS)+DTDIF*B_T(KTS))                 !Bep
+      RSQ(KTS) = RHO(KTS)*(  Q(KTS)+DTDIF*B_Q(KTS))                 !Bep
+      RSC(KTS) = RHO(KTS)* CWM(KTS)
+!----------------------------------------------------------------------
+      DO K=KTS+1,LMH-1
+        DTOZL=DTOZ(K)
+        CF   = -DTOZL*RKH(K-1)/CM(K-1)
+        CF_T = -DTOZL*RKH(K-1)/CM_T(K-1)                             !Bep
+        CF_Q = -DTOZL*RKH(K-1)/CM_Q(K-1)                             !Bep
+        CM(K)  = -CR(K-1)*CF+  (RKH(K-1)+RKH(K))*DTOZL+RHO(K)
+        CM_T(K)= -CR(K-1)*CF_T+(RKH(K-1)+RKH(K))*DTOZL+RHO(K)*&
+                   &(1.-DTDIF*A_T(K))
+        CM_Q(K)= -CR(K-1)*CF_Q+(RKH(K-1)+RKH(K))*DTOZL+RHO(K)*&
+                   &(1.-DTDIF*A_Q(K))                                 !Bep
+        RST(K)=-RST(K-1)*CF_T+(RKCT(K-1)-RKCT(K))*DTOZL+RHO(K)*&
+                    &(THE(K)+DTDIF*B_T(K))                             !Bep
+        RSQ(K)=-RSQ(K-1)*CF_Q+RHO(K)*(  Q(K)+DTDIF*B_Q(K))             !Bep
+        RSC(K)=-RSC(K-1)*CF+CWM(K)*RHO(K)
+      ENDDO
+!
+      DTOZS=DTDIF/(Z(LMH)-Z(LMH+1))/VLK(LMH)                   !Bep
+      RKHH=RKH(LMH-1)                            
+!
+      CF=-DTOZS*RKHH/CM(LMH-1)
+      CF_T=-DTOZS*RKHH/CM_T(LMH-1)                  !Bep
+      CF_Q=-DTOZS*RKHH/CM_Q(LMH-1)                  !Bep
+      RKQS=RKHS*CHKLOWQ
+!
+      CMB=CR(LMH-1)*CF
+      CMB_T=CR(LMH-1)*CF_T
+      CMB_Q=CR(LMH-1)*CF_Q
+      CMTB=-CMB_T+RKHH*DTOZS+RHO(LMH)*(1.-DTDIF*A_T(LMH))  !Bep
+      CMQB=-CMB_Q+RKHH*DTOZS+RHO(LMH)*(1.-DTDIF*A_Q(LMH))  !Bep
+      CMCB=-CMB+(RKHH     )*DTOZS+RHO(LMH)
+!
+      RSTB=-RST(LMH-1)*CF_T+RHO(LMH)*(THE(LMH)+DTDIF*B_T(LMH))+&
+             &RKCT(LMH-1)*DTOZS                                     !Bep
+      RSQB=-RSQ(LMH-1)*CF_Q+RHO(LMH)*(  Q(LMH)+DTDIF*B_Q(LMH))      !Bep
+      RSCB=-RSC(LMH-1)*CF+CWM(LMH)*RHO(LMH)
+!----------------------------------------------------------------------
+      THE(LMH)= RSTB/CMTB
+      Q(LMH)  = RSQB/CMQB
+      CWM(LMH)= RSCB/CMCB
+!----------------------------------------------------------------------
+      DO K=LMH-1,KTS,-1
+        RCML=1./CM(K)
+        RCML_T=1./CM_T(K)                                       !Bep
+        RCML_Q=1./CM_Q(K)                                       !Bep
+        THE(K)=(-CR(K)*THE(K+1)+RST(K))*RCML_T
+        Q(K)  =(-CR(K)*  Q(K+1)+RSQ(K))*RCML_Q
+        CWM(K)=(-CR(K)*CWM(K+1)+RSC(K))*RCML
+      ENDDO
+!----------------------------------------------------------------------
+!
+
+   
+      END SUBROUTINE VDIFH
+!
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!---------------------------------------------------------------------
+      SUBROUTINE VDIFX(DTDIF,LMH,RKHS,CT                              &
+                      ,DUST1,DUST2,RKH,Z,RHO                          &
+                      ,IDS,IDE,JDS,JDE,KDS,KDE                        &
+                      ,IMS,IME,JMS,JME,KMS,KME                        &
+                      ,ITS,ITE,JTS,JTE,KTS,KTE)
+!     ***************************************************************
+!     *                                                             *
+!     *         VERTICAL DIFFUSION OF MASS VARIABLES                *
+!     *                                                             *
+!     ***************************************************************
+!---------------------------------------------------------------------
+!
+      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
+!
+      REAL,INTENT(IN) :: CT,DTDIF,RKHS
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: RKH
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: RHO
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: DUST1,DUST2
+! 
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: CF,CMB,CMDB,CTHF,DTOZL,DTOZS                            &
+             ,RCML,RKHH,RSD1B,RSD2B
+!
+      REAL,DIMENSION(KTS:KTE-1) :: CM,CR,DTOZ,RKCT,RSD1,RSD2
+!
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      CTHF=0.5*CT
+!
+      DO K=KTS,LMH-1
+        DTOZ(K)=DTDIF/(Z(K)-Z(K+1))
+        CR(K)=-DTOZ(K)*RKH(K)
+        RKCT(K)=RKH(K)*(Z(K)-Z(K+2))*CTHF
+      ENDDO
+!
+      CM(KTS)=DTOZ(KTS)*RKH(KTS)+RHO(KTS)
+!----------------------------------------------------------------------
+      RSD1(KTS)=DUST1(KTS)*RHO(KTS)
+      RSD2(KTS)=DUST2(KTS)*RHO(KTS)
+!----------------------------------------------------------------------
+      DO K=KTS+1,LMH-1
+        DTOZL=DTOZ(K)
+        CF=-DTOZL*RKH(K-1)/CM(K-1)
+        CM(K)=-CR(K-1)*CF+(RKH(K-1)+RKH(K))*DTOZL+RHO(K)
+        RSD1(K)=-RSD1(K-1)*CF+DUST1(K)*RHO(K)
+        RSD2(K)=-RSD2(K-1)*CF+DUST2(K)*RHO(K)
+      ENDDO
+!
+      DTOZS=DTDIF/(Z(LMH)-Z(LMH+1))
+      RKHH=RKH(LMH-1)
+!
+      CF=-DTOZS*RKHH/CM(LMH-1)
+!
+      CMB=CR(LMH-1)*CF
+      CMDB=-CMB+RKHH*DTOZS+RHO(LMH)
+!
+      RSD1B=-RSD1(LMH-1)*CF+DUST1(LMH)*RHO(LMH)
+      RSD2B=-RSD2(LMH-1)*CF+DUST2(LMH)*RHO(LMH)
+!----------------------------------------------------------------------
+      DUST1(LMH)=RSD1B/CMDB
+      DUST2(LMH)=RSD2B/CMDB
+!----------------------------------------------------------------------
+      DO K=LMH-1,KTS,-1
+        RCML=1./CM(K)
+        DUST1(K)=(-CR(K)*DUST1(K+1)+RSD1(K))*RCML
+        DUST2(K)=(-CR(K)*DUST2(K+1)+RSD2(K))*RCML
+      ENDDO
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE VDIFX
+
+!---------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!---------------------------------------------------------------------
+      SUBROUTINE VDIFV(LMH,DTDIF,UZ0,VZ0,RKMS,U,V,RKM_IN,Z,RHO        &
+! Variables added for Bep
+     &                ,A_UK,A_VK,B_UK,B_VK,SFK,VLK                    &
+! Bep end
+     &                ,IDS,IDE,JDS,JDE,KDS,KDE                        &
+     &                ,IMS,IME,JMS,JME,KMS,KME                        &
+                      ,ITS,ITE,JTS,JTE,KTS,KTE,I,J)
+!     ***************************************************************
+!     *                                                             *
+!     *        VERTICAL DIFFUSION OF VELOCITY COMPONENTS            *
+!     *                                                             *
+!     ***************************************************************
+!---------------------------------------------------------------------
+!
+      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) :: LMH
+!
+      REAL,INTENT(IN) :: RKMS,DTDIF,UZ0,VZ0
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: RKM_IN                    !Bep
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: RHO
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z
+!
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: U,V
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: A_UK,A_VK,B_UK,B_VK,VLK     !Bep
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: SFK                       !Bep
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: CFU,RCMLU,RCMVBU
+      REAL :: CFV,RCMLV,RCMVBV
+      REAL :: DTOZAK,DTOZL,DTOZS,RHOK,RKMH
+!
+      REAL,DIMENSION(KTS:KTE-1) :: CMU,CMV,CR,DTOZ,RSU,RSV
+      REAL,DIMENSION(KTS:KTE-1) :: RKM                                  !Bep
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      DO K=1,LMH-1
+        RKM(K)=RKM_IN(K)*SFK(K)
+        DTOZ(K)=DTDIF/(Z(K)-Z(K+1))/VLK(K)
+        CR(K)=-DTOZ(K)*RKM(K)                             !alpha, gamma
+      ENDDO
+!
+      RHOK=RHO(1)
+      CMU(1)=DTOZ(1)*RKM(1)+RHOK*(1.-DTDIF*A_UK(1))        !Bep change beta
+      CMV(1)=DTOZ(1)*RKM(1)+RHOK*(1.-DTDIF*A_VK(1))        !Bep change beta
+      RSU(1)=RHOK*(U(1)+DTDIF*B_UK(1))                     !Bep change W
+      RSV(1)=RHOK*(V(1)+DTDIF*B_VK(1))                     !Bep change W
+!----------------------------------------------------------------------
+      DO K=2,LMH-1
+        DTOZL=DTOZ(K)
+        CFU=-DTOZL*RKM(K-1)/CMU(K-1)
+        CFV=-DTOZL*RKM(K-1)/CMV(K-1)
+        RHOK=RHO(K)
+        CMU(K)=-CR(K-1)*CFU+(RKM(K-1)+RKM(K))&
+                 &*DTOZL+RHOK*(1.-DTDIF*A_UK(K))                      !Bep
+        CMV(K)=-CR(K-1)*CFV+(RKM(K-1)+RKM(K))&
+                 &*DTOZL+RHOK*(1.-DTDIF*A_VK(K))                      !Bep
+        RSU(K)=-RSU(K-1)*CFU+RHOK*(U(K)+DTDIF*B_UK(K))                !Bep
+        RSV(K)=-RSV(K-1)*CFV+RHOK*(V(K)+DTDIF*B_VK(K))                !Bep
+      ENDDO
+!----------------------------------------------------------------------
+! Bep: change lower BC from value UZ0 at LMH+1 to flux derived BC: Z(LMH+1)=0.
+      DTOZS=DTDIF/(Z(LMH)-Z(LMH+1))/VLK(LMH)           !Bep
+      RKMH=RKM(LMH-1)                       !Bep
+!
+      CFU=-DTOZS*RKMH/CMU(LMH-1)
+      CFV=-DTOZS*RKMH/CMV(LMH-1)
+      RHOK=RHO(LMH)
+      RCMVBU=1./(RKMH*DTOZS-CR(LMH-1)*CFU+RHOK*(1.-DTDIF*A_UK(LMH)))   !Bep
+      RCMVBV=1./(RKMH*DTOZS-CR(LMH-1)*CFV+RHOK*(1.-DTDIF*A_VK(LMH)))   !Bep
+     
+!----------------------------------------------------------------------
+       U(LMH)=(-RSU(LMH-1)*CFU+RHOK*(U(LMH)+DTDIF*B_UK(LMH)))*RCMVBU  !Bep
+       V(LMH)=(-RSV(LMH-1)*CFV+RHOK*(V(LMH)+DTDIF*B_VK(LMH)))*RCMVBV  !Bep
+!----------------------------------------------------------------------
+      DO K=LMH-1,1,-1
+        RCMLU=1./CMU(K)                                  !Bep
+        RCMLV=1./CMV(K)                                  !Bep
+        U(K)=(-CR(K)*U(K+1)+RSU(K))*RCMLU                !Bep
+        V(K)=(-CR(K)*V(K+1)+RSV(K))*RCMLV                !Bep
+      ENDDO
+!----------------------------------------------------------------------
+!
+      
+      END SUBROUTINE VDIFV
+!
+!-----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!=======================================================================
+      SUBROUTINE MYJURBINIT(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                 )
+!-----------------------------------------------------------------------
+      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
+
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) ::    EXCH_H, &
+     &                                                         RUBLTEN, &
+     &                                                         RVBLTEN, &
+     &                                                        RTHBLTEN, &
+     &                                                        RQVBLTEN, &
+     &                                                         TKE_MYJ
+      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
+          TKE_MYJ(I,K,J)=EPSQ2
+          RUBLTEN(I,K,J)=0.
+          RVBLTEN(I,K,J)=0.
+          RTHBLTEN(I,K,J)=0.
+          RQVBLTEN(I,K,J)=0.
+          EXCH_H(I,K,J)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDIF
+
+      END SUBROUTINE MYJURBINIT
+!-----------------------------------------------------------------------
+!
+      END MODULE MODULE_BL_MYJURB
+!
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_mynn.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_mynn.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_mynn.F	(revision 17)
@@ -0,0 +1,1875 @@
+! translated from NN f77 to F90 and put into WRF by Mariusz Pagowski
+! NOAA/GSD & CIRA/CSU, Feb 2008
+! changes to original code:
+! 1. code is 1d (in z)
+! 2. no advection of TKE, covariances and variances 
+! 3. Cranck-Nicholson replaced with the implicit scheme
+! 4. removed terrain dependent grid since input in WRF in actual
+!    distances in z[m]
+! 5. cosmetic changes to adhere to WRF standard (remove common blocks, 
+!            intent etc)
+
+MODULE module_bl_mynn
+
+  USE module_model_constants, only: &
+       &karman, g, p1000mb, &
+       &cp, r_d, rcp, xlv, &
+       &svp1, svp2, svp3, svpt0, ep_1, ep_2
+
+  IMPLICIT NONE
+
+! The parameters below depend on stability functions of module_sf_mynn.
+  REAL, PARAMETER :: cphm_st=5.0, cphm_unst=16.0, &
+                     cphh_st=5.0, cphh_unst=16.0
+
+  REAL, PARAMETER :: xlvcp=xlv/cp, ev=xlv, rd=r_d, rk=cp/rd, &
+       &svp11=svp1*1.e3, p608=ep_1, ep_3=1.-ep_2
+
+  REAL, PARAMETER :: tref=300.0    ! reference temperature (K)
+  REAL, PARAMETER :: tv0=p608*tref, tv1=(1.+p608)*tref, gtr=g/tref
+
+! Closure constants
+  REAL, PARAMETER :: &
+       &vk  = karman, &
+       &pr  =  0.74, &
+       &g1  =  0.235, &
+       &b1  = 24.0, &
+       &b2  = 15.0, &
+       &c2  =  0.75, &
+       &c3  =  0.352, &
+       &c4  =  0.0, &
+       &c5  =  0.2, &
+       &a1  = b1*( 1.0-3.0*g1 )/6.0, &
+!       &c1  = g1 -1.0/( 3.0*a1*b1**(1.0/3.0) ), &
+       &c1  = g1 -1.0/( 3.0*a1*2.88449914061481660), &
+       &a2  = a1*( g1-c1 )/( g1*pr ), &
+       &g2  = b2/b1*( 1.0-c3 ) +2.0*a1/b1*( 3.0-2.0*c2 )
+
+  REAL, PARAMETER :: &
+       &cc2 =  1.0-c2, &
+       &cc3 =  1.0-c3, &
+       &e1c =  3.0*a2*b2*cc3, &
+       &e2c =  9.0*a1*a2*cc2, &
+       &e3c =  9.0*a2*a2*cc2*( 1.0-c5 ), &
+       &e4c = 12.0*a1*a2*cc2, &
+       &e5c =  6.0*a1*a1
+
+! Constants for length scale
+  REAL, PARAMETER :: qmin=0.0, zmax=1.0, cns=2.7, &
+       &alp1=0.23, alp2=1.0, alp3=5.0, alp4=100.0
+
+! Constants for gravitational settling
+!  REAL, PARAMETER :: gno=1.e6/(1.e8)**(2./3.), gpw=5./3., qcgmin=1.e-8
+  REAL, PARAMETER :: gno=4.64158883361278196
+  REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8,qkemin=1.e-12
+!  REAL, PARAMETER :: pblh_ref=1500.
+
+  REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423
+
+  INTEGER :: mynn_level
+
+CONTAINS
+
+! **********************************************************************
+! *   An improved Mellor-Yamada turbulence closure model               *
+! *                                                                    *
+! *                                   Aug/2005  M. Nakanishi (N.D.A)   *
+! *                        Modified:  Dec/2005  M. Nakanishi (N.D.A)   *
+! *                                             naka@nda.ac.jp         *
+! *                                                                    *
+! *   Contents:                                                        *
+! *     1. mym_initialize  (to be called once initially)               *
+! *        gives the closure constants and initializes the turbulent   *
+! *        quantities.                                                 *
+! *    (2) mym_level2      (called in the other subroutines)           *
+! *        calculates the stability functions at Level 2.              *
+! *    (3) mym_length      (called in the other subroutines)           *
+! *        calculates the master length scale.                         *
+! *     4. mym_turbulence                                              *
+! *        calculates the vertical diffusivity coefficients and the    *
+! *        production terms for the turbulent quantities.              *
+! *     5. mym_predict                                                 *
+! *        predicts the turbulent quantities at the next step.         *
+! *     6. mym_condensation                                            *
+! *        determines the liquid water content and the cloud fraction  *
+! *        diagnostically.                                             *
+! *                                                                    *
+! *             call mym_initialize                                    *
+! *                  |                                                 *
+! *                  |<----------------+                               *
+! *                  |                 |                               *
+! *             call mym_condensation  |                               *
+! *             call mym_turbulence    |                               *
+! *             call mym_predict       |                               *
+! *                  |                 |                               *
+! *                  |-----------------+                               *
+! *                  |                                                 *
+! *                 end                                                *
+! *                                                                    *
+! *   Variables worthy of special mention:                             *
+! *     tref   : Reference temperature                                 *
+! *     thl     : Liquid water potential temperature               *
+! *     qw     : Total water (water vapor+liquid water) content        *
+! *     ql     : Liquid water content                                  *
+! *     vt, vq : Functions for computing the buoyancy flux             *
+! *                                                                    *
+! *     If the water contents are unnecessary, e.g., in the case of    *
+! *     ocean models, thl is the potential temperature and qw, ql, vt   *
+! *     and vq are all zero.                                           *
+! *                                                                    *
+! *   Grid arrangement:                                                *
+! *             k+1 +---------+                                        *
+! *                 |         |     i = 1 - nx                         *
+! *             (k) |    *    |     j = 1 - ny                         *
+! *                 |         |     k = 1 - nz                         *
+! *              k  +---------+                                        *
+! *                 i   (i)  i+1                                       *
+! *                                                                    *
+! *     All the predicted variables are defined at the center (*) of   *
+! *     the grid boxes. The diffusivity coefficients are, however,     *
+! *     defined on the walls of the grid boxes.                        *
+! *     # Upper boundary values are given at k=nz.                   *
+! *                                                                    *
+! *   References:                                                      *
+! *     1. Nakanishi, M., 2001:                                        *
+! *        Boundary-Layer Meteor., 99, 349-378.                        *
+! *     2. Nakanishi, M. and H. Niino, 2004:                           *
+! *        Boundary-Layer Meteor., 112, 1-31.                          *
+! *     3. Nakanishi, M. and H. Niino, 2006:                           *
+! *        Boundary-Layer Meteor., (in press).                         *
+! **********************************************************************
+!
+!
+!     SUBROUTINE  mym_initialize:
+!
+!     Input variables:
+!       iniflag         : <>0; turbulent quantities will be initialized
+!                         = 0; turbulent quantities have been already
+!                              given, i.e., they will not be initialized
+!       mx, my          : Maximum numbers of grid boxes
+!                         in the x and y directions, respectively
+!       nx, ny, nz      : Numbers of the actual grid boxes
+!                         in the x, y and z directions, respectively
+!       tref            : Reference temperature                      (K)
+!       dz(nz)        : Vertical grid spacings                     (m)
+!                         # dz(nz)=dz(nz-1)
+!       zw(nz+1)        : Heights of the walls of the grid boxes     (m)
+!                         # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1)
+!       h(mx,ny)        : G^(1/2) in the terrain-following coordinate
+!                         # h=1-zg/zt, where zg is the height of the
+!                           terrain and zt the top of the model domain
+!       pi0(mx,my,nz) : Exner function at zw*h+zg             (J/kg K)
+!                         defined by c_p*( p_basic/1000hPa )^kappa
+!                         This is usually computed by integrating
+!                         d(pi0)/dz = -h*g/tref.
+!       rmo(mx,ny)      : Inverse of the Obukhov length         (m^(-1))
+!       flt, flq(mx,ny) : Turbulent fluxes of sensible and latent heat,
+!                         respectively, e.g., flt=-u_*Theta_* (K m/s)
+!! flt - liquid water potential temperature surface flux
+!! flq - total water flux surface flux
+!       ust(mx,ny)      : Friction velocity                        (m/s)
+!       pmz(mx,ny)      : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1))
+!                         is the first grid point above the surafce, z0
+!                         the roughness length and zeta=(z1*h+z0)*rmo
+!       phh(mx,ny)      : phi_h at z1*h+z0
+!       u, v(mx,my,nz): Components of the horizontal wind        (m/s)
+!       thl(mx,my,nz)  : Liquid water potential temperature
+!                                                                    (K)
+!       qw(mx,my,nz)  : Total water content Q_w                (kg/kg)
+!
+!     Output variables:
+!       ql(mx,my,nz)  : Liquid water content                   (kg/kg)
+!       v?(mx,my,nz)  : Functions for computing the buoyancy flux
+!       qke(mx,my,nz) : Twice the turbulent kineti! energy q^2
+!                                                              (m^2/s^2)
+!       tsq(mx,my,nz) : Variance of Theta_l                      (K^2)
+!       qsq(mx,my,nz) : Variance of Q_w
+!       cov(mx,my,nz) : Covariance of Theta_l and Q_w              (K)
+!       el(mx,my,nz)  : Master length scale L                      (m)
+!                         defined on the walls of the grid boxes
+!       bsh             : no longer used
+!       via common      : Closure constants
+!
+!     Work arrays:        see subroutine mym_level2
+!       pd?(mx,my,nz) : Half of the production terms at Level 2
+!                         defined on the walls of the grid boxes
+!       qkw(mx,my,nz) : q on the walls of the grid boxes         (m/s)
+!
+!     # As to dtl, ...gh, see subroutine mym_turbulence.
+!
+
+  SUBROUTINE  mym_initialize ( kts,kte,&
+       &            dz, zw,  &
+       &            u, v, thl, qw, &
+!       &            ust, rmo, pmz, phh, flt, flq,&
+       &            ust, rmo, &
+       &            Qke, Tsq, Qsq, Cov)
+
+!
+    
+    INTEGER, INTENT(IN)   :: kts,kte
+!    REAL, INTENT(IN)   :: ust, rmo, pmz, phh, flt, flq
+    REAL, INTENT(IN)   :: ust, rmo
+    REAL, DIMENSION(kts:kte), INTENT(in) :: dz
+    REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw
+    REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw
+
+    REAL, DIMENSION(kts:kte), INTENT(out) :: qke,tsq,qsq,cov
+
+
+    REAL, DIMENSION(kts:kte) :: &
+         &ql,el,pdk,pdt,pdq,pdc,dtl,dqw,dtv,&
+         &gm,gh,sm,sh,qkw,vt,vq
+    INTEGER :: k,l,lmax
+    REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq
+
+
+!   **  At first ql, vt and vq are set to zero.  **
+    DO k = kts,kte
+       ql(k) = 0.0
+       vt(k) = 0.0
+       vq(k) = 0.0
+    END DO
+!
+    CALL mym_level2 ( kts,kte,&
+         &            dz,  &
+         &            u, v, thl, qw, &
+         &            ql, vt, vq, &
+         &            dtl, dqw, dtv, gm, gh, sm, sh )
+!
+!   **  Preliminary setting  **
+
+    el (kts) = 0.0
+    qke(kts) = ust**2 * ( b1*pmz )**(2.0/3.0)
+!
+    phm      = phh*b2 / ( b1*pmz )**(1.0/3.0)
+    tsq(kts) = phm*( flt/ust )**2
+    qsq(kts) = phm*( flq/ust )**2
+    cov(kts) = phm*( flt/ust )*( flq/ust )
+!
+    DO k = kts+1,kte
+       vkz = vk*zw(k)
+       el (k) = vkz/( 1.0 + vkz/100.0 )
+       qke(k) = 0.0
+!
+       tsq(k) = 0.0
+       qsq(k) = 0.0
+       cov(k) = 0.0
+    END DO
+!
+!   **  Initialization with an iterative manner          **
+!   **  lmax is the iteration count. This is arbitrary.  **
+    lmax = 5  !!kte +3
+!
+    DO l = 1,lmax
+!
+       CALL mym_length ( kts,kte,&
+            &            dz, zw, &
+            &            rmo, flt, flq, &
+            &            vt, vq, &
+            &            qke, &
+            &            dtv, &
+            &            el, &
+            &            qkw)
+!
+       DO k = kts+1,kte
+          elq = el(k)*qkw(k)
+          pdk(k) = elq*( sm(k)*gm (k)+&
+               &sh(k)*gh (k) )
+          pdt(k) = elq*  sh(k)*dtl(k)**2
+          pdq(k) = elq*  sh(k)*dqw(k)**2
+          pdc(k) = elq*  sh(k)*dtl(k)*dqw(k)
+       END DO
+!
+!   **  Strictly, vkz*h(i,j) -> vk*( 0.5*dz(1)*h(i,j)+z0 )  **
+       vkz = vk*0.5*dz(kts)
+!
+       elv = 0.5*( el(kts+1)+el(kts) ) /  vkz 
+       qke(kts) = ust**2 * ( b1*pmz*elv    )**(2.0/3.0)
+!
+       phm      = phh*b2 / ( b1*pmz/elv**2 )**(1.0/3.0)
+       tsq(kts) = phm*( flt/ust )**2
+       qsq(kts) = phm*( flq/ust )**2
+       cov(kts) = phm*( flt/ust )*( flq/ust )
+!
+       DO k = kts+1,kte-1
+          b1l = b1*0.25*( el(k+1)+el(k) )
+          tmpq=MAX(b1l*( pdk(k+1)+pdk(k) ),qkemin)
+!          PRINT *,'tmpqqqqq',tmpq,pdk(k+1),pdk(k)
+          qke(k) = tmpq**(2.0/3.0)
+
+!
+          IF ( qke(k) .LE. 0.0 ) THEN
+             b2l = 0.0
+          ELSE
+             b2l = b2*( b1l/b1 ) / SQRT( qke(k) )
+          END IF
+!
+          tsq(k) = b2l*( pdt(k+1)+pdt(k) )
+          qsq(k) = b2l*( pdq(k+1)+pdq(k) )
+          cov(k) = b2l*( pdc(k+1)+pdc(k) )
+       END DO
+
+!
+    END DO
+
+!!    qke(kts)=qke(kts+1)
+!!    tsq(kts)=tsq(kts+1)
+!!    qsq(kts)=qsq(kts+1)
+!!    cov(kts)=cov(kts+1)
+
+    qke(kte)=qke(kte-1)
+    tsq(kte)=tsq(kte-1)
+    qsq(kte)=qsq(kte-1)
+    cov(kte)=cov(kte-1)
+
+!
+!    RETURN
+
+  END SUBROUTINE mym_initialize
+  
+!
+!     SUBROUTINE  mym_level2:
+!
+!     Input variables:    see subroutine mym_initialize
+!
+!     Output variables:
+!       dtl(mx,my,nz) : Vertical gradient of Theta_l             (K/m)
+!       dqw(mx,my,nz) : Vertical gradient of Q_w
+!       dtv(mx,my,nz) : Vertical gradient of Theta_V             (K/m)
+!       gm (mx,my,nz) : G_M divided by L^2/q^2                (s^(-2))
+!       gh (mx,my,nz) : G_H divided by L^2/q^2                (s^(-2))
+!       sm (mx,my,nz) : Stability function for momentum, at Level 2
+!       sh (mx,my,nz) : Stability function for heat, at Level 2
+!
+!       These are defined on the walls of the grid boxes.
+!
+  SUBROUTINE  mym_level2 (kts,kte,&
+       &            dz, &
+       &            u, v, thl, qw, &
+       &            ql, vt, vq, &
+       &            dtl, dqw, dtv, gm, gh, sm, sh )
+!
+
+    INTEGER, INTENT(IN)   :: kts,kte
+    REAL, DIMENSION(kts:kte), INTENT(in) :: dz
+    REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,ql,vt,vq
+
+
+    REAL, DIMENSION(kts:kte), INTENT(out) :: &
+         &dtl,dqw,dtv,gm,gh,sm,sh
+
+    INTEGER :: k
+
+    REAL :: rfc,f1,f2,rf1,rf2,smc,shc,&
+         &ri1,ri2,ri3,ri4,duz,dtz,dqz,vtt,vqq,dtq,dzk,afk,abk,ri,rf
+
+!    ev  = 2.5e6
+!    tv0 = 0.61*tref
+!    tv1 = 1.61*tref
+!    gtr = 9.81/tref
+!
+    rfc = g1/( g1+g2 )
+    f1  = b1*( g1-c1 ) +3.0*a2*( 1.0    -c2 )*( 1.0-c5 ) &
+    &                   +2.0*a1*( 3.0-2.0*c2 )
+    f2  = b1*( g1+g2 ) -3.0*a1*( 1.0    -c2 )
+    rf1 = b1*( g1-c1 )/f1
+    rf2 = b1*  g1     /f2
+    smc = a1 /a2*  f1/f2
+    shc = 3.0*a2*( g1+g2 )
+!
+    ri1 = 0.5/smc
+    ri2 = rf1*smc
+    ri3 = 4.0*rf2*smc -2.0*ri2
+    ri4 = ri2**2
+!
+    DO k = kts+1,kte
+       dzk = 0.5  *( dz(k)+dz(k-1) )
+       afk = dz(k)/( dz(k)+dz(k-1) )
+       abk = 1.0 -afk
+       duz = ( u(k)-u(k-1) )**2 +( v(k)-v(k-1) )**2
+       duz =   duz                    /dzk**2
+       dtz = ( thl(k)-thl(k-1) )/( dzk )
+       dqz = ( qw(k)-qw(k-1) )/( dzk )
+!
+       vtt =  1.0 +vt(k)*abk +vt(k-1)*afk
+       vqq =  tv0 +vq(k)*abk +vq(k-1)*afk
+       dtq =  vtt*dtz +vqq*dqz
+!
+       dtl(k) =  dtz
+       dqw(k) =  dqz
+       dtv(k) =  dtq
+!?      dtv(i,j,k) =  dtz +tv0*dqz
+!?   :              +( ev/pi0(i,j,k)-tv1 )
+!?   :              *( ql(i,j,k)-ql(i,j,k-1) )/( dzk*h(i,j) )
+!
+       gm (k) =  duz
+       gh (k) = -dtq*gtr
+!
+!   **  Gradient Richardson number  **
+       ri = -gh(k)/MAX( duz, 1.0e-10 )
+!   **  Flux Richardson number  **
+       rf = MIN( ri1*( ri+ri2-SQRT(ri**2-ri3*ri+ri4) ), rfc )
+!
+       sh (k) = shc*( rfc-rf )/( 1.0-rf )
+       sm (k) = smc*( rf1-rf )/( rf2-rf ) * sh(k)
+    END DO
+!
+    RETURN
+
+  END SUBROUTINE mym_level2
+
+!
+!     SUBROUTINE  mym_length:
+!
+!     Input variables:    see subroutine mym_initialize
+!
+!     Output variables:   see subroutine mym_initialize
+!
+!     Work arrays:
+!       elt(mx,ny)      : Length scale depending on the PBL depth    (m)
+!       vsc(mx,ny)      : Velocity scale q_c                       (m/s)
+!                         at first, used for computing elt
+!
+  SUBROUTINE  mym_length ( kts,kte,&
+    &            dz, zw, &
+    &            rmo, flt, flq, &
+    &            vt, vq, &
+    &            qke, &
+    &            dtv, &
+    &            el, &
+    &            qkw)
+    
+    INTEGER, INTENT(IN)   :: kts,kte
+    REAL, DIMENSION(kts:kte), INTENT(in) :: dz
+    REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw
+    REAL, INTENT(in) :: rmo,flt,flq
+    REAL, DIMENSION(kts:kte), INTENT(IN) :: qke,vt,vq
+
+
+    REAL, DIMENSION(kts:kte), INTENT(out) :: &
+         &qkw, el
+    REAL, DIMENSION(kts:kte), INTENT(in) :: dtv
+
+    REAL :: elt,vsc
+
+    INTEGER :: i,j,k
+    REAL :: afk,abk,zwk,dzk,qdz,vflx,bv,elb,els,elf
+
+!    tv0 = 0.61*tref
+!    gtr = 9.81/tref
+!
+    DO k = kts+1,kte
+       afk = dz(k)/( dz(k)+dz(k-1) )
+       abk = 1.0 -afk
+       qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*&
+            &afk,1.0e-10))
+    END DO
+!
+    elt = 1.0e-5
+    vsc = 1.0e-5
+!
+!   **  Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 )  **
+    DO k = kts+1,kte-1
+       zwk = zw(k)
+       dzk = 0.5*( dz(k)+dz(k-1) )
+       qdz = MAX( qkw(k)-qmin, 0.0 )*dzk
+             elt = elt +qdz*zwk
+             vsc = vsc +qdz
+    END DO
+!
+    vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq
+    elt =  alp1*elt/vsc
+    vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0)
+!
+!   **  Strictly, el(i,j,1) is not zero.  **
+    el(kts) = 0.0
+!
+    DO k = kts+1,kte
+       zwk = zw(k)
+!   **  Length scale limited by the buoyancy effect  **
+       IF ( dtv(k) .GT. 0.0 ) THEN
+          bv  = SQRT( gtr*dtv(k) )
+          elb = alp2*qkw(k) / bv &
+               &       *( 1.0 + alp3/alp2*&
+               &SQRT( vsc/( bv*elt ) ) )
+          elf=elb
+          elf = alp2 * qkw(k)/bv
+       ELSE
+          elb = 1.0e10
+          elf =elb
+       END IF
+!
+!   **  Length scale in the surface layer  **
+       IF ( rmo .GT. 0.0 ) THEN
+          els =  vk*zwk &
+               &        /( 1.0 + cns*MIN( zwk*rmo, zmax ) )
+       ELSE
+          els =  vk*zwk &
+               &  *( 1.0 - alp4*    zwk*rmo         )**0.2
+       END IF
+!
+       el(k) =      MIN(elb/( elb/elt+elb/els+1.0 ),elf)
+!!       el(k) =      elb/( elb/elt+elb/els+1.0 )
+
+    END DO
+!
+    RETURN
+
+  END SUBROUTINE mym_length
+
+!
+!     SUBROUTINE  mym_turbulence:
+!
+!     Input variables:    see subroutine mym_initialize
+!       levflag         : <>3;  Level 2.5
+!                         = 3;  Level 3
+!
+!     # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables.
+!
+!     Output variables:   see subroutine mym_initialize
+!       dfm(mx,my,nz) : Diffusivity coefficient for momentum,
+!                         divided by dz (not dz*h(i,j))            (m/s)
+!       dfh(mx,my,nz) : Diffusivity coefficient for heat,
+!                         divided by dz (not dz*h(i,j))            (m/s)
+!       dfq(mx,my,nz) : Diffusivity coefficient for q^2,
+!                         divided by dz (not dz*h(i,j))            (m/s)
+!       tcd(mx,my,nz)   : Countergradient diffusion term for Theta_l
+!                                                                  (K/s)
+!       qcd(mx,my,nz)   : Countergradient diffusion term for Q_w
+!                                                              (kg/kg s)
+!       pd?(mx,my,nz) : Half of the production terms
+!
+!       Only tcd and qcd are defined at the center of the grid boxes
+!
+!     # DO NOT forget that tcd and qcd are added on the right-hand side
+!       of the equations for Theta_l and Q_w, respectively.
+!
+!     Work arrays:        see subroutine mym_initialize and level2
+!
+!     # dtl, dqw, dtv, gm and gh are allowed to share storage units with
+!       dfm, dfh, dfq, tcd and qcd, respectively, for saving memory.
+!
+  SUBROUTINE  mym_turbulence ( kts,kte,&
+    &            levflag, &
+    &            dz, zw, &
+    &            u, v, thl, ql, qw, &
+    &            qke, tsq, qsq, cov, &
+    &            vt, vq,&
+    &            rmo, flt, flq, &
+    &            El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc)
+
+!
+    INTEGER, INTENT(IN)   :: kts,kte
+    INTEGER, INTENT(IN)   :: levflag
+    REAL, DIMENSION(kts:kte), INTENT(in) :: dz
+    REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw
+    REAL, INTENT(in) :: rmo,flt,flq   
+    REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,& 
+         &ql,vt,vq,qke,tsq,qsq,cov
+
+    REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq,&
+         &pdk,pdt,pdq,pdc,tcd,qcd,el
+
+    REAL, DIMENSION(kts:kte) :: qkw,dtl,dqw,dtv,gm,gh,sm,sh
+
+    INTEGER :: k
+!    REAL :: cc2,cc3,e1c,e2c,e3c,e4c,e5c
+    REAL :: e6c,dzk,afk,abk,vtt,vqq,&
+         &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh
+
+    DOUBLE PRECISION  q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel
+    DOUBLE PRECISION  q3sq, t3sq, r3sq, c3sq, dlsq, qdiv
+    DOUBLE PRECISION  e1, e2, e3, e4, enum, eden, wden
+!
+!    tv0 = 0.61*tref
+!    gtr = 9.81/tref
+!
+!    cc2 =  1.0-c2
+!    cc3 =  1.0-c3
+!    e1c =  3.0*a2*b2*cc3
+!    e2c =  9.0*a1*a2*cc2
+!    e3c =  9.0*a2*a2*cc2*( 1.0-c5 )
+!    e4c = 12.0*a1*a2*cc2
+!    e5c =  6.0*a1*a1
+!
+
+    CALL mym_level2 (kts,kte,&
+    &            dz, &
+    &            u, v, thl, qw, &
+    &            ql, vt, vq, &
+    &            dtl, dqw, dtv, gm, gh, sm, sh )
+!
+    CALL mym_length (kts,kte, &
+    &            dz, zw, &
+    &            rmo, flt, flq, &
+    &            vt, vq, &
+    &            qke, &
+    &            dtv, &
+    &            el, &
+    &            qkw)
+!
+    DO k = kts+1,kte
+       dzk = 0.5  *( dz(k)+dz(k-1) )
+       afk = dz(k)/( dz(k)+dz(k-1) )
+       abk = 1.0 -afk
+       elsq = el (k)**2
+       q2sq = b1*elsq*( sm(k)*gm(k)+sh(k)*gh(k) )
+       q3sq = qkw(k)**2
+!
+!  Modified: Dec/22/2005, from here, (dlsq -> elsq)
+       gmel = gm (k)*elsq
+       ghel = gh (k)*elsq
+!  Modified: Dec/22/2005, up to here
+!
+!     **  Since qkw is set to more than 0.0, q3sq > 0.0.  **
+       IF ( q3sq .LT. q2sq ) THEN
+          qdiv = SQRT( q3sq/q2sq )
+          sm(k) = sm(k) * qdiv
+          sh(k) = sh(k) * qdiv
+!
+          e1   = q3sq - e1c*ghel * qdiv**2
+          e2   = q3sq - e2c*ghel * qdiv**2
+          e3   = e1   + e3c*ghel * qdiv**2
+          e4   = e1   - e4c*ghel * qdiv**2
+          eden = e2*e4 + e3*e5c*gmel * qdiv**2
+          eden = MAX( eden, 1.0d-20 )
+       ELSE
+          e1   = q3sq - e1c*ghel
+          e2   = q3sq - e2c*ghel
+          e3   = e1   + e3c*ghel
+          e4   = e1   - e4c*ghel
+          eden = e2*e4 + e3*e5c*gmel
+          eden = MAX( eden, 1.0d-20 )
+!
+          qdiv = 1.0
+          sm(k) = q3sq*a1*( e3-3.0*c1*e4       )/eden
+          sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden
+       END IF
+!
+!   **  Level 3 : start  **
+       IF ( levflag .EQ. 3 ) THEN
+          t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2
+          r2sq = qdiv*b2*elsq*sh(k)*dqw(k)**2
+          c2sq = qdiv*b2*elsq*sh(k)*dtl(k)*dqw(k)
+          t3sq = MAX( tsq(k)*abk+tsq(k-1)*afk, 0.0 )
+          r3sq = MAX( qsq(k)*abk+qsq(k-1)*afk, 0.0 )
+          c3sq =      cov(k)*abk+cov(k-1)*afk
+!
+!  Modified: Dec/22/2005, from here
+          c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq )
+!
+          vtt  = 1.0 +vt(k)*abk +vt(k-1)*afk
+          vqq  = tv0 +vq(k)*abk +vq(k-1)*afk
+          t2sq = vtt*t2sq +vqq*c2sq
+          r2sq = vtt*c2sq +vqq*r2sq
+          c2sq = MAX( vtt*t2sq+vqq*r2sq, 0.0d0 )
+          t3sq = vtt*t3sq +vqq*c3sq
+          r3sq = vtt*c3sq +vqq*r3sq
+          c3sq = MAX( vtt*t3sq+vqq*r3sq, 0.0d0 )
+!
+          cw25 = e1*( e2 + 3.0*c1*e5c*gmel*qdiv**2 )/( 3.0*eden )
+!
+!     **  Limitation on q, instead of L/q  **
+          dlsq =  elsq
+          IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k)
+!
+!     **  Limitation on c3sq (0.12 =< cw =< 0.76) **
+          e2   = q3sq - e2c*ghel * qdiv**2
+          e3   = q3sq + e3c*ghel * qdiv**2
+          e4   = q3sq - e4c*ghel * qdiv**2
+          eden = e2*e4  + e3 *e5c*gmel * qdiv**2
+!
+          wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 &
+               &        *( e2*e4c - e3c*e5c*gmel * qdiv**2 )
+!
+          IF ( wden .NE. 0.0 ) THEN
+             clow = q3sq*( 0.12-cw25 )*eden/wden
+             cupp = q3sq*( 0.76-cw25 )*eden/wden
+!
+             IF ( wden .GT. 0.0 ) THEN
+                c3sq  = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp )
+             ELSE
+                c3sq  = MAX( MIN( c3sq, c2sq+clow ), c2sq+cupp )
+             END IF
+          END IF
+!
+          e1   = e2 + e5c*gmel * qdiv**2
+          eden = MAX( eden, 1.0d-20 )
+!  Modified: Dec/22/2005, up to here
+!
+          e6c  = 3.0*a2*cc3*gtr * dlsq/elsq
+!
+!     **  for Gamma_theta  **
+!!          enum = qdiv*e6c*( t3sq-t2sq )
+          IF ( t2sq .GE. 0.0 ) THEN
+             enum = MAX( qdiv*e6c*( t3sq-t2sq ), 0.0d0 )
+          ELSE
+             enum = MIN( qdiv*e6c*( t3sq-t2sq ), 0.0d0 )
+          ENDIF
+
+          gamt =-e1  *enum    /eden
+!
+!     **  for Gamma_q  **
+!!          enum = qdiv*e6c*( r3sq-r2sq )
+          IF ( r2sq .GE. 0.0 ) THEN
+             enum = MAX( qdiv*e6c*( r3sq-r2sq ), 0.0d0 )
+          ELSE
+             enum = MIN( qdiv*e6c*( r3sq-r2sq ), 0.0d0 )
+          ENDIF
+
+          gamq =-e1  *enum    /eden
+!
+!     **  for Sm' and Sh'd(Theta_V)/dz  **
+!!          enum = qdiv*e6c*( c3sq-c2sq )
+          enum = MAX( qdiv*e6c*( c3sq-c2sq ), 0.0d0)
+
+          smd  = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2
+          gamv = e1  *enum*gtr/eden
+!
+
+          sm(k) = sm(k) +smd
+!
+!     **  For elh (see below), qdiv at Level 3 is reset to 1.0.  **
+          qdiv = 1.0
+!   **  Level 3 : end  **
+!
+       ELSE
+!     **  At Level 2.5, qdiv is not reset.  **
+          gamt = 0.0
+          gamq = 0.0
+          gamv = 0.0
+       END IF
+!
+       elq = el(k)*qkw(k)
+       elh = elq*qdiv
+!
+       pdk(k) = elq*( sm(k)*gm (k) &
+            &                    +sh(k)*gh (k)+gamv )
+       pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k)
+       pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k)
+       pdc(k) = elh*( sh(k)*dtl(k)+gamt )&
+            &*dqw(k)*0.5 &
+                  &+elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5
+!
+       tcd(k) = elq*gamt
+       qcd(k) = elq*gamq
+!
+       dfm(k) = elq*sm (k) / dzk
+       dfh(k) = elq*sh (k) / dzk
+!  Modified: Dec/22/2005, from here
+!   **  In sub.mym_predict, dfq for the TKE and scalar variance **
+!   **  are set to 3.0*dfm and 1.0*dfm, respectively.           **
+       dfq(k) =     dfm(k)
+!  Modified: Dec/22/2005, up to here
+    END DO
+!
+    dfm(kts) = 0.0
+    dfh(kts) = 0.0
+    dfq(kts) = 0.0
+    tcd(kts) = 0.0
+    qcd(kts) = 0.0
+
+    tcd(kte) = 0.0
+    qcd(kte) = 0.0
+
+!
+    DO k = kts,kte-1
+       dzk = dz(k)
+       tcd(k) = ( tcd(k+1)-tcd(k) )/( dzk )
+       qcd(k) = ( qcd(k+1)-qcd(k) )/( dzk )
+    END DO
+!
+    RETURN
+
+  END SUBROUTINE mym_turbulence
+
+!
+!     SUBROUTINE  mym_predict:
+!
+!     Input variables:    see subroutine mym_initialize and turbulence
+!       qke(mx,my,nz) : qke at (n)th time level
+!       tsq, ...cov     : ditto
+!
+!     Output variables:
+!       qke(mx,my,nz) : qke at (n+1)th time level
+!       tsq, ...cov     : ditto
+!
+!     Work arrays:
+!       qkw(mx,my,nz)   : q at the center of the grid boxes        (m/s)
+!       bp (mx,my,nz)   : = 1/2*F,     see below
+!       rp (mx,my,nz)   : = P-1/2*F*Q, see below
+!
+!     # The equation for a turbulent quantity Q can be expressed as
+!          dQ/dt + Ah + Av = Dh + Dv + P - F*Q,                      (1)
+!       where A is the advection, D the diffusion, P the production,
+!       F*Q the dissipation and h and v denote horizontal and vertical,
+!       respectively. If Q is q^2, F is 2q/B_1L.
+!       Using the Crank-Nicholson scheme for Av, Dv and F*Q, a finite
+!       difference equation is written as
+!          Q{n+1} - Q{n} = dt  *( Dh{n}   - Ah{n}   + P{n} )
+!                        + dt/2*( Dv{n}   - Av{n}   - F*Q{n}   )
+!                        + dt/2*( Dv{n+1} - Av{n+1} - F*Q{n+1} ),    (2)
+!       where n denotes the time level.
+!       When the advection and diffusion terms are discretized as
+!          dt/2*( Dv - Av ) = a(k)Q(k+1) - b(k)Q(k) + c(k)Q(k-1),    (3)
+!       Eq.(2) can be rewritten as
+!          - a(k)Q(k+1) + [ 1 + b(k) + dt/2*F ]Q(k) - c(k)Q(k-1)
+!                 = Q{n} + dt  *( Dh{n}   - Ah{n}   + P{n} )
+!                        + dt/2*( Dv{n}   - Av{n}   - F*Q{n}   ),    (4)
+!       where Q on the left-hand side is at (n+1)th time level.
+!
+!       In this subroutine, a(k), b(k) and c(k) are obtained from
+!       subprogram coefvu and are passed to subprogram tinteg via
+!       common. 1/2*F and P-1/2*F*Q are stored in bp and rp,
+!       respectively. Subprogram tinteg solves Eq.(4).
+!
+!       Modify this subroutine according to your numerical integration
+!       scheme (program).
+!
+
+
+  SUBROUTINE  mym_predict (kts,kte,&
+       &            levflag,  &
+       &            delt,&
+       &            dz, &
+       &            ust, flt, flq, pmz, phh, &
+       &            el, dfq, &
+       &            pdk, pdt, pdq, pdc,&
+       &            qke, tsq, qsq, cov)
+
+    INTEGER, INTENT(IN)   :: kts,kte    
+    INTEGER, INTENT(IN) :: levflag
+    REAL, INTENT(IN) :: delt
+    REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq,el
+    REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc
+    REAL, INTENT(IN) ::  flt, flq, ust, pmz, phh
+    REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov
+    
+    INTEGER :: k,nz
+    REAL, DIMENSION(kts:kte) :: qkw, bp, rp, df3q
+    REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l
+    REAL, DIMENSION(kts:kte) :: dtz
+    REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d
+
+    nz=kte-kts+1
+
+!   **  Strictly, vkz*h(i,j) -> vk*( 0.5*dz(1)*h(i,j)+z0 )  **
+    vkz = vk*0.5*dz(kts)
+!
+!  Modified: Dec/22/2005, from here
+!   **  dfq for the TKE is 3.0*dfm.  **
+!    CALL coefvu ( dfq, 3.0 ) ! make change here
+!  Modified: Dec/22/2005, up to here
+!
+    DO k = kts,kte
+!!       qke(k) = MAX(qke(k), 0.0)
+       qkw(k) = SQRT( MAX( qke(k), 0.0 ) )
+       df3q(k)=3.*dfq(k)
+       dtz(k)=delt/dz(k)
+    END DO
+!
+    pdk1 = 2.0*ust**3*pmz/( vkz )
+    phm  = 2.0/ust   *phh/( vkz )
+    pdt1 = phm*flt**2
+    pdq1 = phm*flq**2
+    pdc1 = phm*flt*flq
+!
+!   **  pdk(i,j,1)+pdk(i,j,2) corresponds to pdk1.  **
+    pdk(kts) = pdk1 -pdk(kts+1)
+
+!!    pdt(kts) = pdt1 -pdt(kts+1)
+!!    pdq(kts) = pdq1 -pdq(kts+1)
+!!    pdc(kts) = pdc1 -pdc(kts+1)
+    pdt(kts) = pdt(kts+1)
+    pdq(kts) = pdq(kts+1)
+    pdc(kts) = pdc(kts+1)
+!
+!   **  Prediction of twice the turbulent kinetic energy  **
+!!    DO k = kts+1,kte-1
+    DO k = kts,kte-1
+       b1l = b1*0.5*( el(k+1)+el(k) )
+       bp(k) = 2.*qkw(k) / b1l
+       rp(k) = pdk(k+1) + pdk(k) 
+    END DO
+    
+!!    a(1)=0.
+!!    b(1)=1.
+!!    c(1)=-1.
+!!    d(1)=0.
+
+! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt.
+    DO k=kts,kte-1
+       a(k-kts+1)=-dtz(k)*df3q(k)
+       b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt
+       c(k-kts+1)=-dtz(k)*df3q(k+1)
+       d(k-kts+1)=rp(k)*delt + qke(k)
+    ENDDO
+
+!!    DO k=kts+1,kte-1
+!!       a(k-kts+1)=-dtz(k)*df3q(k)
+!!       b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))
+!!       c(k-kts+1)=-dtz(k)*df3q(k+1)
+!!       d(k-kts+1)=rp(k)*delt + qke(k) - qke(k)*bp(k)*delt
+!!    ENDDO
+
+    a(nz)=-1. !0.
+    b(nz)=1.
+    c(nz)=0.
+    d(nz)=0.
+
+    CALL tridiag(nz,a,b,c,d)
+
+    DO k=kts,kte
+       qke(k)=d(k-kts+1)
+    ENDDO
+      
+
+    IF ( levflag .EQ. 3 ) THEN
+!
+!  Modified: Dec/22/2005, from here
+!   **  dfq for the scalar variance is 1.0*dfm.  **
+!       CALL coefvu ( dfq, 1.0 ) make change here 
+!  Modified: Dec/22/2005, up to here
+!
+!   **  Prediction of the temperature variance  **
+!!       DO k = kts+1,kte-1
+       DO k = kts,kte-1
+          b2l = b2*0.5*( el(k+1)+el(k) )
+          bp(k) = 2.*qkw(k) / b2l
+          rp(k) = pdt(k+1) + pdt(k) 
+       END DO
+       
+!zero gradient for tsq at bottom and top
+       
+!!       a(1)=0.
+!!       b(1)=1.
+!!       c(1)=-1.
+!!       d(1)=0.
+
+! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt.
+       DO k=kts,kte-1
+          a(k-kts+1)=-dtz(k)*dfq(k)
+          b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt
+          c(k-kts+1)=-dtz(k)*dfq(k+1)
+          d(k-kts+1)=rp(k)*delt + tsq(k)
+       ENDDO
+
+!!       DO k=kts+1,kte-1
+!!          a(k-kts+1)=-dtz(k)*dfq(k)
+!!          b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))
+!!          c(k-kts+1)=-dtz(k)*dfq(k+1)
+!!          d(k-kts+1)=rp(k)*delt + tsq(k) - tsq(k)*bp(k)*delt
+!!       ENDDO
+
+       a(nz)=-1. !0.
+       b(nz)=1.
+       c(nz)=0.
+       d(nz)=0.
+       
+       CALL tridiag(nz,a,b,c,d)
+       
+       DO k=kts,kte
+          tsq(k)=d(k-kts+1)
+       ENDDO
+       
+!   **  Prediction of the moisture variance  **
+!!       DO k = kts+1,kte-1
+       DO k = kts,kte-1
+          b2l = b2*0.5*( el(k+1)+el(k) )
+          bp(k) = 2.*qkw(k) / b2l
+          rp(k) = pdq(k+1) +pdq(k) 
+       END DO
+       
+!zero gradient for qsq at bottom and top
+       
+!!       a(1)=0.
+!!       b(1)=1.
+!!       c(1)=-1.
+!!       d(1)=0.
+
+! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt.
+       DO k=kts,kte-1
+          a(k-kts+1)=-dtz(k)*dfq(k)
+          b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt
+          c(k-kts+1)=-dtz(k)*dfq(k+1)
+          d(k-kts+1)=rp(k)*delt + qsq(k)
+       ENDDO
+
+!!       DO k=kts+1,kte-1
+!!          a(k-kts+1)=-dtz(k)*dfq(k)
+!!          b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))
+!!          c(k-kts+1)=-dtz(k)*dfq(k+1)
+!!          d(k-kts+1)=rp(k)*delt + qsq(k) -qsq(k)*bp(k)*delt
+!!       ENDDO
+
+       a(nz)=-1. !0.
+       b(nz)=1.
+       c(nz)=0.
+       d(nz)=0.
+       
+       CALL tridiag(nz,a,b,c,d)
+       
+       DO k=kts,kte
+          qsq(k)=d(k-kts+1)
+       ENDDO
+       
+!   **  Prediction of the temperature-moisture covariance  **
+!!       DO k = kts+1,kte-1
+       DO k = kts,kte-1
+          b2l = b2*0.5*( el(k+1)+el(k) )
+          bp(k) = 2.*qkw(k) / b2l
+          rp(k) = pdc(k+1) + pdc(k) 
+       END DO
+       
+!zero gradient for tqcov at bottom and top
+       
+!!       a(1)=0.
+!!       b(1)=1.
+!!       c(1)=-1.
+!!       d(1)=0.
+
+! Since dfq(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*dfq(k+1)+bp(k)*delt.
+       DO k=kts,kte-1
+          a(k-kts+1)=-dtz(k)*dfq(k)
+          b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))+bp(k)*delt
+          c(k-kts+1)=-dtz(k)*dfq(k+1)
+          d(k-kts+1)=rp(k)*delt + cov(k)
+       ENDDO
+
+!!       DO k=kts+1,kte-1
+!!          a(k-kts+1)=-dtz(k)*dfq(k)
+!!          b(k-kts+1)=1.+dtz(k)*(dfq(k)+dfq(k+1))
+!!          c(k-kts+1)=-dtz(k)*dfq(k+1)
+!!          d(k-kts+1)=rp(k)*delt + cov(k) - cov(k)*bp(k)*delt
+!!       ENDDO
+
+       a(nz)=-1. !0.
+       b(nz)=1.
+       c(nz)=0.
+       d(nz)=0.
+       
+       CALL tridiag(nz,a,b,c,d)
+       
+       DO k=kts,kte
+          cov(k)=d(k-kts+1)
+       ENDDO
+       
+    ELSE
+!!       DO k = kts+1,kte-1
+       DO k = kts,kte-1
+          IF ( qkw(k) .LE. 0.0 ) THEN
+             b2l = 0.0
+          ELSE
+             b2l = b2*0.25*( el(k+1)+el(k) )/qkw(k)
+          END IF
+!
+          tsq(k) = b2l*( pdt(k+1)+pdt(k) )
+          qsq(k) = b2l*( pdq(k+1)+pdq(k) )
+          cov(k) = b2l*( pdc(k+1)+pdc(k) )
+       END DO
+       
+!!       tsq(kts)=tsq(kts+1)
+!!       qsq(kts)=qsq(kts+1)
+!!       cov(kts)=cov(kts+1)
+
+       tsq(kte)=tsq(kte-1)
+       qsq(kte)=qsq(kte-1)
+       cov(kte)=cov(kte-1)
+      
+    END IF
+
+  END SUBROUTINE mym_predict
+  
+!     SUBROUTINE  mym_condensation:
+!
+!     Input variables:    see subroutine mym_initialize and turbulence
+!       pi (mx,my,nz) : Perturbation of the Exner function    (J/kg K)
+!                         defined on the walls of the grid boxes
+!                         This is usually computed by integrating
+!                         d(pi)/dz = h*g*tv/tref**2
+!                         from the upper boundary, where tv is the
+!                         virtual potential temperature minus tref.
+!
+!     Output variables:   see subroutine mym_initialize
+!       cld(mx,my,nz)   : Cloud fraction
+!
+!     Work arrays:
+!       qmq(mx,my,nz)   : Q_w-Q_{sl}, where Q_{sl} is the saturation
+!                         specific humidity at T=Tl
+!       alp(mx,my,nz)   : Functions in the condensation process
+!       bet(mx,my,nz)   : ditto
+!       sgm(mx,my,nz)   : Combined standard deviation sigma_s
+!                         multiplied by 2/alp
+!
+!     # qmq, alp, bet and sgm are allowed to share storage units with
+!       any four of other work arrays for saving memory.
+!
+!     # Results are sensitive particularly to values of cp and rd.
+!       Set these values to those adopted by you.
+!
+
+
+
+  SUBROUTINE  mym_condensation (kts,kte, &
+    &            dz, &
+    &            thl, qw, &
+    &            p,exner, &
+    &            tsq, qsq, cov, &
+    &            Vt, Vq)
+
+    INTEGER, INTENT(IN)   :: kts,kte
+
+    REAL, DIMENSION(kts:kte), INTENT(IN) :: dz
+    REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner, thl, qw, &
+         &tsq, qsq, cov
+
+    REAL, DIMENSION(kts:kte), INTENT(OUT) :: vt,vq
+    
+
+    REAL, DIMENSION(kts:kte) :: qmq,alp,bet,sgm,ql,cld
+
+    DOUBLE PRECISION :: t3sq, r3sq, c3sq
+!
+
+    REAL :: p2a,t,esl,qsl,dqsl,q1,cld0,eq1,qll,&
+         &q2p,pt,rac,qt
+    INTEGER :: i,j,k
+
+    REAL :: erf
+
+! Note: kte needs to be larger than kts, i.e., kte >= kts+1.
+
+    DO k = kts,kte-1
+       p2a = exner(k)
+       t  = thl(k)*p2a 
+
+!x      if ( ct .gt. 0.0 ) then
+!       a  =  17.27
+!       b  = 237.3
+!x      else
+!x        a  =  21.87
+!x        b  = 265.5
+!x      end if
+!
+!   **  3.8 = 0.622*6.11 (hPa)  **
+       esl=svp11*EXP(svp2*(t-svpt0)/(t-svp3))
+       qsl=ep_2*esl/(p(k)-ep_3*esl)
+!       qsl  = 3.8*EXP( a*ct/( b+ct ) ) / ( 1000.0*p2a**rk )
+       dqsl = qsl*ep_2*ev/( rd*t**2 )
+!
+       qmq(k) = qw(k) -qsl
+
+       alp(k) = 1.0/( 1.0+dqsl*xlvcp )
+       bet(k) = dqsl*p2a
+!
+       t3sq = MAX( tsq(k), 0.0 )
+       r3sq = MAX( qsq(k), 0.0 )
+       c3sq =      cov(k)
+       c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq )
+!
+       r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq
+       sgm(k) = SQRT( MAX( r3sq, 1.0d-10 ) )
+    END DO
+!
+    DO k = kts,kte-1
+       q1   = qmq(k) / sgm(k)
+       cld0 = 0.5*( 1.0+erf( q1*rr2 ) )
+!       q1=0.
+!       cld0=0.
+
+       eq1  = rrp*EXP( -0.5*q1*q1 )
+       qll  = MAX( cld0*q1 + eq1, 0.0 )
+
+       cld(k) = cld0
+       ql (k) = alp(k)*sgm(k)*qll
+!
+       q2p  = xlvcp/exner( k )
+       pt   = thl(k) +q2p*ql(k)
+       qt   = 1.0 +p608*qw(k) -(1.+p608)*ql(k)
+       rac  = alp(k)*( cld0-qll*eq1 )*( q2p*qt-(1.+p608)*pt )
+!
+       vt (k) =      qt-1.0 -rac*bet(k)
+       vq (k) = p608*pt-tv0 +rac
+    END DO
+!
+
+    cld(kte) = cld(kte-1)
+    ql(kte) = ql(kte-1)
+    vt(kte) = vt(kte-1)
+    vq(kte) = vq(kte-1)
+
+    RETURN
+
+  END SUBROUTINE mym_condensation
+
+  SUBROUTINE mynn_tendencies(kts,kte,&
+       &levflag,grav_settling,&
+       &delt,&
+       &dz,&
+       &u,v,th,qv,qc,p,exner,&
+       &thl,sqv,sqc,sqw,&
+       &ust,flt,flq,wspd,qcg,&
+       &tsq,qsq,cov,&
+       &tcd,qcd,&
+       &dfm,dfh,dfq,&
+       &Du,Dv,Dth,Dqv,Dqc)
+
+    INTEGER, INTENT(in) :: kts,kte
+    INTEGER, INTENT(in) :: grav_settling,levflag
+
+!! grav_settling = 1 for gravitational settling of droplets
+!! grav_settling = 0 otherwise
+! thl - liquid water potential temperature
+! qw - total water
+! dfm,dfh,dfq - as above
+! flt - surface flux of thl
+! flq - surface flux of qw
+
+
+    REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,qv,qc,p,exner,&
+         &dfm,dfh,dfq,dz,tsq,qsq,cov,tcd,qcd
+    REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc
+    REAL, DIMENSION(kts:kte), INTENT(out) :: du,dv,dth,dqv,dqc
+    REAL, INTENT(IN) :: delt,ust,flt,flq,wspd,qcg
+
+!    REAL, INTENT(IN) :: delt,ust,flt,flq,qcg,&
+!         &gradu_top,gradv_top,gradth_top,gradqv_top
+
+
+!local vars
+
+    REAL, DIMENSION(kts:kte) :: dtz,vt,vq
+
+    REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d
+
+    REAL :: rhs,gfluxm,gfluxp,dztop
+    INTEGER :: k,kk,nz
+
+    nz=kte-kts+1
+
+    dztop=.5*(dz(kte)+dz(kte-1))
+
+    DO k=kts,kte
+       dtz(k)=delt/dz(k)
+    ENDDO
+
+!! u
+   
+    k=kts
+
+    a(1)=0.
+    b(1)=1.+dtz(k)*(dfm(k+1)+ust**2/wspd)
+    c(1)=-dtz(k)*dfm(k+1)
+    d(1)=u(k)
+
+!!    a(1)=0.
+!!    b(1)=1.+dtz(k)*dfm(k+1)
+!!    c(1)=-dtz(k)*dfm(k+1)
+!!    d(1)=u(k)*(1.-ust**2/wspd*dtz(k))
+    
+    DO k=kts+1,kte-1
+       kk=k-kts+1
+       a(kk)=-dtz(k)*dfm(k)
+       b(kk)=1.+dtz(k)*(dfm(k)+dfm(k+1))
+       c(kk)=-dtz(k)*dfm(k+1)
+       d(kk)=u(k)
+    ENDDO
+
+!! no flux at the top
+
+!    a(nz)=-1.
+!    b(nz)=1.
+!    c(nz)=0.
+!    d(nz)=0.
+
+!! specified gradient at the top 
+
+!    a(nz)=-1.
+!    b(nz)=1.
+!    c(nz)=0.
+!    d(nz)=gradu_top*dztop
+
+!! prescribed value
+
+    a(nz)=0
+    b(nz)=1.
+    c(nz)=0.
+    d(nz)=u(kte)
+
+    CALL tridiag(nz,a,b,c,d)
+    
+    DO k=kts,kte
+       du(k)=(d(k-kts+1)-u(k))/delt
+    ENDDO
+
+!! v
+
+    k=kts
+
+    a(1)=0.
+    b(1)=1.+dtz(k)*(dfm(k+1)+ust**2/wspd)
+    c(1)=-dtz(k)*dfm(k+1)
+    d(1)=v(k)
+
+!!    a(1)=0.
+!!    b(1)=1.+dtz(k)*dfm(k+1)
+!!    c(1)=-dtz(k)*dfm(k+1)
+!!    d(1)=v(k)*(1.-ust**2/wspd*dtz(k))
+
+    DO k=kts+1,kte-1
+       kk=k-kts+1
+       a(kk)=-dtz(k)*dfm(k)
+       b(kk)=1.+dtz(k)*(dfm(k)+dfm(k+1))
+       c(kk)=-dtz(k)*dfm(k+1)
+       d(kk)=v(k)
+    ENDDO
+
+!! no flux at the top
+
+!    a(nz)=-1.
+!    b(nz)=1.
+!    c(nz)=0.
+!    d(nz)=0.
+
+
+!! specified gradient at the top
+
+!    a(nz)=-1.
+!    b(nz)=1.
+!    c(nz)=0.
+!    d(nz)=gradv_top*dztop
+
+!! prescribed value
+
+    a(nz)=0
+    b(nz)=1.
+    c(nz)=0.
+    d(nz)=v(kte)
+
+    CALL tridiag(nz,a,b,c,d)
+    
+    DO k=kts,kte
+       dv(k)=(d(k-kts+1)-v(k))/delt
+    ENDDO
+
+!! thl 
+
+    k=kts
+
+    a(1)=0.
+    b(1)=1.+dtz(k)*dfh(k+1)
+    c(1)=-dtz(k)*dfh(k+1)
+    
+! if qcg not used then assume constant flux in the surface layer
+
+    IF (qcg < qcgmin) THEN
+       IF (sqc(k) > qcgmin) THEN
+          gfluxm=grav_settling*gno*sqc(k)**gpw
+       ELSE
+          gfluxm=0.
+       ENDIF
+    ELSE
+       gfluxm=grav_settling*gno*(qcg/(1.+qcg))**gpw
+    ENDIF
+
+    IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN
+       gfluxp=grav_settling*gno*(.5*(sqc(k+1)+sqc(k)))**gpw
+    ELSE
+       gfluxp=0.
+    ENDIF
+
+    rhs=-xlvcp/exner(k)&
+         &*( &
+         &(gfluxp - gfluxm)/dz(k)&
+         & ) + tcd(k)
+
+    d(1)=thl(k)+dtz(k)*flt+rhs*delt
+    
+    DO k=kts+1,kte-1
+       kk=k-kts+1
+       a(kk)=-dtz(k)*dfh(k)
+       b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) 
+       c(kk)=-dtz(k)*dfh(k+1)
+
+       IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN
+          gfluxp=grav_settling*gno*(.5*(sqc(k+1)+sqc(k)))**gpw
+       ELSE
+          gfluxp=0.
+       ENDIF
+       
+       IF (.5*(sqc(k-1)+sqc(k)) > qcgmin) THEN
+          gfluxm=grav_settling*gno*(.5*(sqc(k-1)+sqc(k)))**gpw
+       ELSE
+          gfluxm=0.
+       ENDIF
+
+       rhs=-xlvcp/exner(k)&
+            &*( &
+            &(gfluxp - gfluxm)/dz(k)&
+            & ) + tcd(k)
+       d(kk)=thl(k)+rhs*delt
+    ENDDO
+
+!! no flux at the top
+
+!    a(nz)=-1.
+!    b(nz)=1.
+!    c(nz)=0.
+!    d(nz)=0.
+ 
+!! specified gradient at the top
+
+!assume gradthl_top=gradth_top
+
+!    a(nz)=-1.
+!    b(nz)=1.
+!    c(nz)=0.
+!    d(nz)=gradth_top*dztop
+
+!! prescribed value
+
+    a(nz)=0.
+    b(nz)=1.
+    c(nz)=0.
+    d(nz)=thl(kte)
+
+    CALL tridiag(nz,a,b,c,d)
+    
+    DO k=kts,kte
+       thl(k)=d(k-kts+1)
+    ENDDO
+
+!! total water
+
+    k=kts
+  
+    a(1)=0.
+    b(1)=1.+dtz(k)*dfh(k+1)
+    c(1)=-dtz(k)*dfh(k+1)
+    
+    IF (qcg < qcgmin) THEN
+       IF (sqc(k) > qcgmin) THEN
+          gfluxm=grav_settling*gno*sqc(k)**gpw
+       ELSE
+          gfluxm=0.
+       ENDIF
+    ELSE
+       gfluxm=grav_settling*gno*(qcg/(1.+qcg))**gpw
+    ENDIF
+    
+    IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN
+       gfluxp=grav_settling*gno*(.5*(sqc(k+1)+sqc(k)))**gpw
+    ELSE
+       gfluxp=0.
+    ENDIF
+
+    rhs=&
+         &( &
+         &(gfluxp - gfluxm)/dz(k)& 
+        & ) + qcd(k)
+    
+    d(1)=sqw(k)+dtz(k)*flq+rhs*delt
+    
+    DO k=kts+1,kte-1
+       kk=k-kts+1
+       a(kk)=-dtz(k)*dfh(k)
+       b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) 
+       c(kk)=-dtz(k)*dfh(k+1)
+
+       IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN
+          gfluxp=grav_settling*gno*(.5*(sqc(k+1)+sqc(k)))**gpw
+       ELSE
+          gfluxp=0.
+       ENDIF
+
+       IF (.5*(sqc(k-1)+sqc(k)) > qcgmin) THEN
+          gfluxm=grav_settling*gno*(.5*(sqc(k-1)+sqc(k)))**gpw
+       ELSE
+          gfluxm=0.
+       ENDIF
+
+       rhs=&
+            &( &
+            &(gfluxp - gfluxm)/dz(k)&
+            & ) + qcd(k)
+       d(kk)=sqw(k) + rhs*delt
+    ENDDO
+
+
+!! no flux at the top
+
+!    a(nz)=-1.
+!    b(nz)=1.
+!    c(nz)=0.
+!    d(nz)=0.
+ 
+!! specified gradient at the top
+!assume gradqw_top=gradqv_top
+
+!    a(nz)=-1.
+!    b(nz)=1.
+!    c(nz)=0.
+!    d(nz)=gradqv_top*dztop
+
+!! prescribed value
+
+    a(nz)=0.
+    b(nz)=1.
+    c(nz)=0.
+    d(nz)=sqw(kte)
+
+    CALL tridiag(nz,a,b,c,d)
+
+!convert to mixing ratios for wrf
+    
+    DO k=kts,kte
+       sqw(k)=d(k-kts+1)
+       sqv(k)=sqw(k)-sqc(k)
+       Dqv(k)=(sqv(k)/(1.-sqv(k))-qv(k))/delt
+!       Dqc(k)=(sqc(k)/(1.-sqc(k))-qc(k))/delt
+       Dqc(k)=0.
+       Dth(k)=(thl(k)+xlvcp/exner(k)*sqc(k)-th(k))/delt
+    ENDDO
+
+  END SUBROUTINE mynn_tendencies
+
+  SUBROUTINE retrieve_exchange_coeffs(kts,kte,&
+       &dfm,dfh,dfq,dz,&
+       &K_m,K_h,K_q)
+
+    INTEGER , INTENT(in) :: kts,kte
+
+    REAL, DIMENSION(KtS:KtE), INTENT(in) :: dz,dfm,dfh,dfq
+
+    REAL, DIMENSION(KtS:KtE), INTENT(out) :: &
+         &K_m, K_h, K_q
+
+
+    INTEGER :: k
+    REAL :: dzk
+
+    K_m(kts)=0.
+    K_h(kts)=0.
+    K_q(kts)=0.
+
+    DO k=kts+1,kte
+       dzk = 0.5  *( dz(k)+dz(k-1) )
+       K_m(k)=dfm(k)*dzk
+       K_h(k)=dfh(k)*dzk
+       K_q(k)=dfq(k)*dzk
+    ENDDO
+
+  END SUBROUTINE retrieve_exchange_coeffs
+
+
+  SUBROUTINE tridiag(n,a,b,c,d)
+
+!! to solve system of linear eqs on tridiagonal matrix n times n
+!! after Peaceman and Rachford, 1955
+!! a,b,c,d - are vectors of order n 
+!! a,b,c - are coefficients on the LHS
+ !! d - is initially RHS on the output becomes a solution vector
+    
+    INTEGER, INTENT(in):: n
+    REAL, DIMENSION(n), INTENT(in) :: a,b
+    REAL, DIMENSION(n), INTENT(inout) :: c,d
+    
+    INTEGER :: i
+    REAL :: p
+    REAL, DIMENSION(n) :: q
+    
+    c(n)=0.
+    q(1)=-c(1)/b(1)
+    d(1)=d(1)/b(1)
+    
+    DO i=2,n
+       p=1./(b(i)+a(i)*q(i-1))
+       q(i)=-c(i)*p
+       d(i)=(d(i)-a(i)*d(i-1))*p
+    ENDDO
+    
+    DO i=n-1,1,-1
+       d(i)=d(i)+q(i)*d(i+1)
+    ENDDO
+    
+  END SUBROUTINE tridiag
+
+  SUBROUTINE mynn_bl_driver(&
+       &initflag,&
+       &grav_settling,&
+       &delt,&
+       &dz,&
+       &u,v,th,qv,qc,&
+       &p,exner,rho,&
+       &xland,ts,qsfc,qcg,ps,&
+       &ust,ch,hfx,qfx,rmol,wspd,&
+       &Qke,Tsq,Qsq,Cov,&
+       &Du,Dv,Dth,&
+       &Dqv,Dqc,&
+!       &K_m,K_h,K_q&
+       &K_h,k_m,&
+       &Pblh&
+       &,IDS,IDE,JDS,JDE,KDS,KDE                    &
+       &,IMS,IME,JMS,JME,KMS,KME                    &
+       &,ITS,ITE,JTS,JTE,KTS,KTE)
+    
+    INTEGER, INTENT(in) :: initflag
+    INTEGER, INTENT(in) :: grav_settling
+    
+    INTEGER,INTENT(IN) :: &
+         & IDS,IDE,JDS,JDE,KDS,KDE &
+         &,IMS,IME,JMS,JME,KMS,KME &
+         &,ITS,ITE,JTS,JTE,KTS,KTE
+    
+
+! initflag > 0  for TRUE
+! else        for FALSE
+!       levflag         : <>3;  Level 2.5
+!                         = 3;  Level 3
+! grav_settling = 1 when gravitational settling accounted for
+! grav_settling = 0 when gravitational settling NOT accounted for
+    
+    REAL, INTENT(in) :: delt
+    REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(in) :: dz,&
+         &u,v,th,qv,qc,p,exner,rho 
+    REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(in) :: xland,ust,&
+         &ch,rmol,ts,qsfc,qcg,ps,hfx,qfx, wspd
+!
+    REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: &
+         &Qke,Tsq,Qsq,Cov
+    REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: &
+         &Du,Dv,Dth,Dqv,Dqc
+
+    REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: &
+         &K_h,K_m
+
+    REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(inout) :: &
+         &Pblh
+    
+!local vars
+    INTEGER :: ITF,JTF,KTF
+    INTEGER :: i,j,k
+    REAL, DIMENSION(KMS:KME) :: thl,sqv,sqc,sqw,&
+         &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, Vt, Vq
+
+    REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: K_q
+
+    REAL, DIMENSION(KMS:KME+1) :: zw
+    
+    REAL :: cpm,sqcg,flt,flq,pmz,phh,exnerg,zet
+    
+    REAL, DIMENSION(KMS:KME) :: thetav
+    REAL :: thsfc
+
+
+    INTEGER, SAVE :: levflag
+    
+    JTF=MIN0(JTE,JDE-1)
+    ITF=MIN0(ITE,IDE-1)
+    KTF=MIN0(KTE,KDE-1)
+    
+       levflag=mynn_level
+
+    IF (initflag > 0) THEN
+
+       DO j=JTS,JTF
+          DO i=ITS,ITF
+             DO k=KTS,KTF
+                sqv(k)=qv(i,k,j)/(1.+qv(i,k,j))
+                thl(k)=th(i,k,j)
+!JOE-PBLH test
+                thetav(k)=th(i,k,j)*(1.+0.61*qv(i,k,j))
+!JOE-end
+                IF (k==kts) THEN
+                   zw(k)=0.
+                ELSE
+                   zw(k)=zw(k-1)+dz(i,k-1,j)
+                ENDIF
+
+                k_m(i,k,j)=0.
+                k_h(i,k,j)=0.
+                k_q(i,k,j)=0.
+
+             ENDDO
+             
+             zw(ktf+1)=zw(ktf)+dz(i,ktf,j)
+             
+             CALL mym_initialize ( kts,kte,&
+                  &dz(i,kts:kte,j), zw,  &
+                  &u(i,kts:kte,j), v(i,kts:kte,j), &
+                  &thl, sqv,&
+                  &ust(i,j), rmol(i,j),&
+                  &Qke(i,kts:kte,j), Tsq(i,kts:kte,j), &
+                  &Qsq(i,kts:kte,j), Cov(i,kts:kte,j))
+             
+!             pblh(i,j)=pblh_ref
+          
+!JOE-PBLH test begin
+             PBLH(i,j)=0.
+             thsfc = thetav(1)
+             DO k = kts+1,kte
+                IF (PBLH(i,j)==0.  .AND.  thetav(k)>(thsfc+0.5))THEN
+                   PBLH(i,j)=zw(k) - ((thetav(k)-(thsfc+0.5)) * &
+                        &(dz(i,k-1,j)/(MAX(thetav(k)-thetav(k-1),0.01))))
+                ENDIF
+             ENDDO
+!JOE--PBLH test end
+             
+          ENDDO
+       ENDDO
+
+    ENDIF
+
+    DO j=JTS,JTF
+       DO i=ITS,ITF
+          DO k=KTS,KTF
+             sqv(k)=qv(i,k,j)/(1.+qv(i,k,j))
+             sqc(k)=qc(i,k,j)/(1.+qc(i,k,j))
+             sqw(k)=sqv(k)+sqc(k)
+             thl(k)=th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k)
+!JOE-PBLH test
+             thetav(k)=th(i,k,j)*(1.+0.61*qv(i,k,j))
+!JOE-end
+
+             IF (k==kts) THEN
+                zw(k)=0.
+             ELSE
+                zw(k)=zw(k-1)+dz(i,k-1,j)
+             ENDIF
+          ENDDO
+
+          zw(ktf+1)=zw(ktf)+dz(i,ktf,j)          
+          
+          sqcg=qcg(i,j)/(1.+qcg(i,j))
+          cpm=cp*(1.+0.8*qv(i,kts,j))
+
+! The exchange coefficient for cloud water is assumed to be the same as
+! that for heat. CH is multiplied by WSPD. See module_sf_mynn.F
+          exnerg=(ps(i,j)/p1000mb)**rcp
+          flt = hfx(i,j)/( rho(i,kts,j)*cpm ) &
+         +xlvcp*ch(i,j)*(sqc(kts)/exner(i,kts,j)-sqcg/exnerg)
+          flq = qfx(i,j)/  rho(i,kts,j)       &
+               -ch(i,j)*(sqc(kts)               -sqcg       )
+
+!!!!!
+          zet = 0.5*dz(i,kts,j)*rmol(i,j)
+          if ( zet >= 0.0 ) then
+            pmz = 1.0 + (cphm_st-1.0) * zet
+            phh = 1.0 +  cphh_st      * zet
+          else
+            pmz = 1.0/    (1.0-cphm_unst*zet)**0.25 - zet
+            phh = 1.0/SQRT(1.0-cphh_unst*zet)
+          end if
+!!!!!
+
+          CALL  mym_condensation ( kts,kte,&
+               &dz(i,kts:kte,j), &
+               &thl, sqw, &
+               &p(i,kts:kte,j),exner(i,kts:kte,j), &
+               &tsq(i,kts:kte,j), qsq(i,kts:kte,j), cov(i,kts:kte,j), &
+               &Vt, Vq)
+          
+          CALL mym_turbulence ( kts,kte,&
+               &levflag, &
+               &dz(i,kts:kte,j), zw, &
+               &u(i,kts:kte,j), v(i,kts:kte,j), thl, sqc, sqw, &
+               &qke(i,kts:kte,j), tsq(i,kts:kte,j), &
+               &qsq(i,kts:kte,j), cov(i,kts:kte,j), &
+               &vt, vq,&
+               &rmol(i,j), flt, flq, &
+               &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc)
+
+          
+          CALL mym_predict (kts,kte,&
+               &levflag,  &
+               &delt,&
+               &dz(i,kts:kte,j), &
+               &ust(i,j), flt, flq, pmz, phh, &
+               &el, dfq, &
+               &pdk, pdt, pdq, pdc,&
+               &Qke(i,kts:kte,j), Tsq(i,kts:kte,j), &
+               &Qsq(i,kts:kte,j), Cov(i,kts:kte,j))
+
+          CALL mynn_tendencies(kts,kte,&
+               &levflag,grav_settling,&
+               &delt,&
+               &dz(i,kts:kte,j),&
+               &u(i,kts:kte,j),v(i,kts:kte,j),&
+               &th(i,kts:kte,j),qv(i,kts:kte,j),qc(i,kts:kte,j),&
+               &p(i,kts:kte,j),exner(i,kts:kte,j),&
+               &thl,sqv,sqc,sqw,&
+               &ust(i,j),flt,flq,wspd(i,j),qcg(i,j),&
+               &tsq(i,kts:kte,j),qsq(i,kts:kte,j),cov(i,kts:kte,j),&
+               &tcd,qcd,&
+               &dfm,dfh,dfq,&
+               &Du(i,kts:kte,j),Dv(i,kts:kte,j),Dth(i,kts:kte,j),&
+               &Dqv(i,kts:kte,j),Dqc(i,kts:kte,j))
+
+          CALL retrieve_exchange_coeffs(kts,kte,&
+               &dfm,dfh,dfq,dz(i,kts:kte,j),&
+               &K_m(i,kts:kte,j),K_h(i,kts:kte,j),K_q(i,kts:kte,j))
+
+       
+!JOE-PBLH test begin
+          PBLH(i,j)=0.
+          thsfc = thetav(1)
+          DO k = kts+1,kte
+             IF (PBLH(i,j)==0.  .AND.  thetav(k)>(thsfc+0.5))THEN
+                PBLH(i,j)=zw(k) - ((thetav(k)-(thsfc+0.5)) * &
+                     &(dz(i,k-1,j)/(MAX(thetav(k)-thetav(k-1),0.01))))
+             ENDIF
+          ENDDO
+!JOE--PBLH test end
+          
+!          pblh(i,j)=pblh_ref
+
+       ENDDO
+    ENDDO
+    
+  END SUBROUTINE mynn_bl_driver
+
+  SUBROUTINE mynn_bl_init_driver(&
+       &Du,Dv,Dth,&
+       &Dqv,Dqc&
+       &,RESTART,ALLOWED_TO_READ,LEVEL&
+       &,IDS,IDE,JDS,JDE,KDS,KDE                    &
+       &,IMS,IME,JMS,JME,KMS,KME                    &
+       &,ITS,ITE,JTS,JTE,KTS,KTE)
+
+    LOGICAL,INTENT(IN) :: ALLOWED_TO_READ,RESTART
+    INTEGER,INTENT(IN) :: LEVEL
+
+    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) :: &
+         &Du,Dv,Dth,Dqv,Dqc
+
+    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
+                Du(i,k,j)=0.
+                Dv(i,k,j)=0.
+                Dth(i,k,j)=0.
+                Dqv(i,k,j)=0.
+                Dqc(i,k,j)=0.
+             ENDDO
+          ENDDO
+       ENDDO
+    ENDIF
+
+    mynn_level=level
+
+  END SUBROUTINE mynn_bl_init_driver
+  
+END MODULE module_bl_mynn
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_qnsepbl.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_qnsepbl.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_qnsepbl.F	(revision 17)
@@ -0,0 +1,1345 @@
+!-----------------------------------------------------------------------
+!
+      MODULE MODULE_BL_QNSEPBL
+!
+!-----------------------------------------------------------------------
+!
+      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
+!
+!-----------------------------------------------------------------------
+!***  QNSE MODEL CONSTANTS 
+!-----------------------------------------------------------------------
+!
+      REAL,PARAMETER :: EPSQ2L=0.01
+      REAL,PARAMETER :: C0=0.55,CEPS=C0**3,BLCKDR=0.0063,CN=0.75        &
+     &                 ,AM1=8.0,AM2=2.3,AM3=35.0,AH1=1.4,AH2=-0.01      &
+     &                 ,AH3=1.29,AH4=2.44,AH5=19.8                      &
+     &                 ,ARIMIN=0.127,BM1=2.88,BM2=16.0,BH1=3.6,BH2=16.0 &
+     &                 ,BH3=720.0,EPSKM=1.E-3
+!
+      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 QNSEPBL(DT,STEPBL,HT,DZ                                &
+     &                 ,PMID,PINT,TH,T,EXNER,QV,CWM,U,V,RHO            &
+     &                 ,TSK,QSFC,CHKLOWQ,THZ0,QZ0,UZ0,VZ0,CORF         &
+     &                 ,LOWLYR,XLAND,SICE,SNOW                         &
+     &                 ,TKE,EXCH_H,EXCH_M,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,EXCH_M,TKE
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CHKLOWQ,ELFLX,CORF
+!
+!----------------------------------------------------------------------
+!***
+!***  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,RI,GH,S2
+!
+      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(its:ite,:,jts:jte) = 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(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,USTAR(I,J),CORF(I,J),S2,GH,RI,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)
+!
+!----------------------------------------------------------------------
+!*** THE MODEL LAYER (COUNTING UPWARD) CONTAINING THE TOP OF THE PBL
+!----------------------------------------------------------------------
+!
+          KPBL(I,J)=KTE-LPBL(I,J)+1
+!
+!----------------------------------------------------------------------
+!***
+!***  FIND THE QNSE EXCHANGE COEFFICIENTS
+!***
+          CALL DIFCOF(LMH,EL,RI,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+1,J)=AKHK(KFLIP)*DELTAZ
+            EXCH_M(I,K+1,J)=AKMK(KFLIP)*DELTAZ
+          ENDDO
+!
+!----------------------------------------------------------------------
+!***
+!***  SOLVE FOR THE PRODUCTION/DISSIPATION OF
+!***  THE TURBULENT KINETIC ENERGY
+!***
+!
+          CALL PRODQ2(LMH,DTTURBL,USTAR(I,J),S2,RI,Q2K,EL,ZHK,AKMK,AKHK &
+     &               ,IDS,IDE,JDS,JDE,KDS,KDE                          &
+     &               ,IMS,IME,JMS,JME,KMS,KME                          &
+     &               ,ITS,ITE,JTS,JTE,KTS,KTE)
+!
+!----------------------------------------------------------------------
+!***
+!***  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),EPSQ2L)
+            TKE(I,K,J)=0.5*Q2K(KFLIP)
+            IF(KFLIP/=KTE)EL_MYJ(I,K,J)=EL(KFLIP)   ! EL IS NOT DEFINED AT KTE
+          ENDDO
+!
+        ENDDO
+!
+!----------------------------------------------------------------------
+      ENDDO setup_integration
+!----------------------------------------------------------------------
+!
+!***  CONVERT SURFACE SENSIBLE TEMPERATURE TO POTENTIAL TEMPERATURE.
+!
+      DO J=JTS,JTE
+      DO I=ITS,ITE
+        PSFC=PINT(I,LOWLYR(I,J),J)
+        THSK(I,J)=TSK(I,J)*(1.E5/PSFC)**CAPA
+      ENDDO
+      ENDDO
+!
+!----------------------------------------------------------------------
+!
+!----------------------------------------------------------------------
+      main_integration:  DO J=JTS,JTE
+!----------------------------------------------------------------------
+!
+        DO I=ITS,ITE
+!
+!***  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
+            THEK(K)=THE(I,KFLIP,J)
+            RATIOMX=QV(I,KFLIP,J)
+            QK(K)=RATIOMX/(1.+RATIOMX)
+            CWMK(K)=CWM(I,KFLIP,J)
+            ZHK(K)=ZINT(I,K,J)
+            RHOK(K,I)=PMID(I,KFLIP,J)/(R_D*T(I,KFLIP,J)*               &
+     &                                (1.+P608*QK(K)-CWMK(K)))
+          ENDDO
+!
+!***  COUNTING DOWNWARD FROM THE TOP, THE EXCHANGE COEFFICIENTS AKH
+!***  ARE DEFINED ON THE BOTTOMS OF THE LAYERS KTS TO KTE-1.  THESE COEFFICIENTS
+!***  ARE ALSO MULTIPLIED BY THE DENSITY AT THE BOTTOM INTERFACE LEVEL.
+!
+          DO K=KTS,KTE-1
+            AKHK(K)=AKH(I,K,J)*0.5*(RHOK(K,I)+RHOK(K+1,I))
+          ENDDO
+!
+          ZHK(KTE+1)=ZINT(I,KTE+1,J)
+!
+          SEAMASK=XLAND(I,J)-1.
+          THZ0(I,J)=(1.-SEAMASK)*THSK(I,J)+SEAMASK*THZ0(I,J)
+!
+          LLOW=LOWLYR(I,J)
+          AKHS_DENS=AKHS(I,J)*RHOK(KTE+1-LLOW,I)
+!
+          IF(SEAMASK<0.5)THEN
+            QFC1=XLV*CHKLOWQ(I,J)*AKHS_DENS
+!
+            IF(SNOW(I,J)>0..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, S2, 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), S2(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, S2, 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), S2(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 QNSEPBL
+!
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!----------------------------------------------------------------------
+                          SUBROUTINE MIXLEN                            &
+!----------------------------------------------------------------------
+!   ******************************************************************
+!   *                                                                *
+!   *                   LEVEL 2.5 MIXING LENGTH                      *
+!   *                                                                *
+!   ******************************************************************
+!
+     &(LMH,U,V,T,THE,Q,CWM,Q2,Z,USTAR,CORF                             &
+     &,S2,GH,RI,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,RI,GH,S2
+!
+      REAL,INTENT(INOUT) :: CT
+!
+      REAL,INTENT(IN) :: CORF,USTAR
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K,LPBLM
+!
+      REAL :: A,ADEN,B,BDEN,AUBR,BUBR,BLMX,EL0,ELOQ2X,GHL,S2L          &
+     &       ,QOL2ST,QOL2UN,QDZL,RDZ,SQ,SREL,SZQ,TEM,THM,VKRMZ,RLAMBDA &
+     &       ,RLB,RLN,F
+!
+      REAL,DIMENSION(KTS:KTE) :: Q1,EN2
+!
+      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)<=EPSQ2L*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.
+!----------------------------------------------------------------------
+!***  COMPUTE LOCAL GRADIENT RICHARDSON NUMBER 
+!----------------------------------------------------------------------
+      DO K=KTS,LMH-1
+        RDZ=2./(Z(K)-Z(K+2))
+        S2L=((U(K)-U(K+1))**2+(V(K)-V(K+1))**2)*RDZ*RDZ   ! S**2
+        S2L=MAX(S2L,EPSGM)
+        S2(K)=S2L
+!
+        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                       ! dTheta/dz
+!
+        IF(ABS(GHL)<=EPSGH)GHL=EPSGH
+!
+        EN2(K)=GHL*G/THM                                   ! N**2
+!
+        GH(K)=GHL
+        RI(K)=EN2(K)/S2L
+      ENDDO
+!
+!----------------------------------------------------------------------
+!***  FIND MAXIMUM MIXING LENGTHS AND THE LEVEL OF THE PBL TOP
+!----------------------------------------------------------------------
+!
+      LMXL=LMH
+!
+      DO K=KTS,LMH-1
+        S2L=S2(K)
+        GHL=GH(K)
+!
+        IF(GHL>=EPSGH)THEN
+          IF(S2L/GHL<=REQU)THEN
+            ELM(K)=EPSL
+            LMXL=K
+          ELSE
+            AUBR=(AUBM*S2L+AUBH*GHL)*GHL
+            BUBR= BUBM*S2L+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*S2L+ADNH*GHL)*GHL
+          BDEN= BDNM*S2L+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<LMH)THEN
+        DO K=LPBL,LMH-1
+          VKRMZ=(Z(K+1)-Z(LMH+1))*VKARMAN
+          EL(K)=MIN(VKRMZ/(VKRMZ/EL0+1.),ELM(K))
+          REL(K)=EL(K)/ELM(K)
+        ENDDO
+      ENDIF
+!
+      DO K=LPBL+1,LMH-2
+        SREL=MIN(((REL(K-1)+REL(K+1))*0.5+REL(K))*0.5,REL(K))
+        EL(K)=MAX(SREL*ELM(K),EPSL)
+      ENDDO
+!
+!----------------------------------------------------------------------
+!***  MIXING LENGTH FOR THE QNSE MODEL IN STABLE CASE
+!----------------------------------------------------------------------
+!
+      F=MAX(CORF,EPS1)
+      RLAMBDA=F/(BLCKDR*USTAR)
+      DO K=KTS,LMH-1
+        IF(EN2(K)>=0.0)THEN                          ! Stable case
+          VKRMZ=(Z(K+1)-Z(LMH+1))*VKARMAN
+          RLB=RLAMBDA+1./VKRMZ
+          RLN=SQRT(2.*EN2(K)/Q2(K))/CN
+!         EL(K)=MIN(1./(RLB+RLN),ELM(K))
+          EL(K)=1./(RLB+RLN)
+        ENDIF
+      ENDDO
+!
+!----------------------------------------------------------------------
+      END SUBROUTINE MIXLEN
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!----------------------------------------------------------------------
+                          SUBROUTINE PRODQ2                            &
+!----------------------------------------------------------------------
+!   ******************************************************************
+!   *                                                                *
+!   *            LEVEL 2.5 Q2 PRODUCTION/DISSIPATION                 *
+!   *                                                                *
+!   ******************************************************************
+!
+     &(LMH,DTTURBL,USTAR,S2,RI,Q2,EL,Z,AKM,AKH                         &
+     &,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
+!
+      REAL,INTENT(IN) :: DTTURBL,USTAR
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: S2,RI,AKM,AKH,EL
+!
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z
+!
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: Q2
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: S2L,Q2L,DELTAZ,AKML,AKHL,EN2,PR,BPR,DIS,RC02
+!
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+!
+      RC02=2.0/(C0*C0)
+      main_integration: DO K=1,LMH-1
+        S2L=S2(K)
+        Q2L=Q2(K)
+        DELTAZ=0.5*(Z(K)-Z(K+2))
+        AKML=AKM(K)*DELTAZ
+        AKHL=AKH(K)*DELTAZ
+        EN2=RI(K)*S2L                                           !N**2
+!
+!***  TURBULENCE PRODUCTION TERM
+!
+        PR=AKML*S2L
+!
+!***  BUOYANCY PRODUCTION
+!
+        BPR=AKHL*EN2
+!
+!***  DISSIPATION
+!
+        DIS=CEPS*(0.5*Q2L)**1.5/EL(K)
+!
+        Q2L=Q2L+2.0*(PR-BPR-DIS)*DTTURBL
+        Q2(K)=AMAX1(Q2L,EPSQ2L)
+!----------------------------------------------------------------------
+!***  END OF PRODUCTION/DISSIPATION LOOP
+!----------------------------------------------------------------------
+!
+      ENDDO main_integration
+!
+!----------------------------------------------------------------------
+!***  LOWER BOUNDARY CONDITION FOR Q2
+!----------------------------------------------------------------------
+!
+      Q2(LMH)=AMAX1(RC02*USTAR*USTAR,EPSQ2L)
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE PRODQ2
+!
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!----------------------------------------------------------------------
+                           SUBROUTINE DIFCOF                           &
+!   ******************************************************************
+!   *                                                                *
+!   *      DIFFUSION COEFFICIENTS KM, KH BASED ON THE QNSE THEORY    *
+!   *                                                                *
+!   ******************************************************************
+     &(LMH,EL,RI,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
+!
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: Q2
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: EL,RI
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(OUT) :: AKH,AKM
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: AK0,ALPHAM,ALPHAH,RIL,RIL2,ARIL,ARIL2,ARIL4,ELL,Q1L,RDZ  &
+     &       ,AK0DZ,AKMIN
+!
+!*** Begin debugging
+      INTEGER,INTENT(IN) :: PRINT_DIAG
+!     REAL :: D2Tmin
+!*** End debugging
+!
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+!
+      DO K=1,LMH-1
+        ELL=EL(K)
+        Q1L=SQRT(0.5*Q2(K))               !Note that Q1L is SQRT(TKE)
+        RIL=RI(K)
+        AK0=C0*ELL*Q1L                    !KM in neutral case
+!
+!----------------------------------------------------------------------
+!***  STABILITY FUNCTIONS ALPHAM AND ALPHAH
+!----------------------------------------------------------------------
+!
+!!! UNSTABLE CASE
+!
+        IF(RIL<=0) THEN
+          ARIL=MIN(ABS(RIL),2.*ARIMIN)
+          ARIL2=ARIL*ARIL
+          ARIL4=ARIL2*ARIL2
+          ALPHAM=1.0+BM1*ARIL+BM2*ARIL2
+          ALPHAH=AH1+BH1*ARIL+BH2*ARIL2+BH3*ARIL4
+!
+!!! STABLE CASE
+!
+        ELSE
+          RIL2=RIL*RIL
+          ALPHAM=(1.0+AM1*RIL2)/(1.0+AM2*RIL+AM3*RIL2)
+          ALPHAH=(AH1+AH2*RIL+AH3*RIL2)/(1.0+AH4*RIL+AH5*RIL2)
+        ENDIF
+!
+!-----------------------------------------------------------------------
+!*** END OF STABILITY FUNCTIONS COMPUTATIONS
+!-----------------------------------------------------------------------
+!
+!----------------------------------------------------------------------
+!***  DIFFUSION COEFFICIENTS
+!----------------------------------------------------------------------
+!
+        RDZ=2./(Z(K)-Z(K+2))
+        AK0DZ=AK0*RDZ
+        AKMIN=EPSKM*RDZ
+        AKM(K)=MAX(AK0DZ*ALPHAM,AKMIN)
+        AKH(K)=MAX(AK0DZ*ALPHAH,AKMIN)
+!----------------------------------------------------------------------
+      ENDDO
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE DIFCOF
+!
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!----------------------------------------------------------------------
+                           SUBROUTINE VDIFQ                            &
+!   ******************************************************************
+!   *                                                                *
+!   *               VERTICAL DIFFUSION OF Q2 (TKE)                   *
+!   *                                                                *
+!   ******************************************************************
+     &(LMH,DTDIF,Q2,EL,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
+!
+      INTEGER,INTENT(IN) :: LMH
+!
+      REAL,INTENT(IN) :: DTDIF
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: EL
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z
+!
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: Q2
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: ADEN,AKQS,BDEN,BESH,BESM,CDEN,CF,DTOZS,ELL,ELOQ2,ELOQ4   &
+     &       ,ELQDZ,ESH,ESM,ESQHF,GHL,GML,Q1L,RDEN,RDZ
+!
+      REAL,DIMENSION(KTS:KTE-2) :: AKQ,CM,CR,DTOZ,RSQ2
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+!***
+!***  VERTICAL TURBULENT DIFFUSION
+!***
+!----------------------------------------------------------------------
+      ESQHF=0.5*ESQ
+!
+      DO K=KTS,LMH-2
+        DTOZ(K)=(DTDIF+DTDIF)/(Z(K)-Z(K+2))
+        AKQ(K)=SQRT((Q2(K)+Q2(K+1))*0.5)*(EL(K)+EL(K+1))*ESQHF         &
+     &        /(Z(K+1)-Z(K+2))
+        CR(K)=-DTOZ(K)*AKQ(K)
+      ENDDO
+!
+      CM(1)=DTOZ(1)*AKQ(1)+1.
+      RSQ2(1)=Q2(1)
+!
+      DO K=KTS+1,LMH-2
+        CF=-DTOZ(K)*AKQ(K-1)/CM(K-1)
+        CM(K)=-CR(K-1)*CF+(AKQ(K-1)+AKQ(K))*DTOZ(K)+1.
+        RSQ2(K)=-RSQ2(K-1)*CF+Q2(K)
+      ENDDO
+!
+      DTOZS=(DTDIF+DTDIF)/(Z(LMH-1)-Z(LMH+1))
+      AKQS=SQRT((Q2(LMH-1)+Q2(LMH))*0.5)*(EL(LMH-1)+ELZ0)*ESQHF        &
+     &    /(Z(LMH)-Z(LMH+1))
+!
+      CF=-DTOZS*AKQ(LMH-2)/CM(LMH-2)
+!
+      Q2(LMH-1)=(DTOZS*AKQS*Q2(LMH)-RSQ2(LMH-2)*CF+Q2(LMH-1))          &
+     &        /((AKQ(LMH-2)+AKQS)*DTOZS-CR(LMH-2)*CF+1.)
+!
+      DO K=LMH-2,KTS,-1
+        Q2(K)=(-CR(K)*Q2(K+1)+RSQ2(K))/CM(K)
+      ENDDO
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE VDIFQ
+!
+!----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!---------------------------------------------------------------------
+      SUBROUTINE VDIFH(DTDIF,LMH,THZ0,QZ0,RKHS,CHKLOWQ,CT             &
+     &                ,THE,Q,CWM,RKH,Z,RHO                            &
+     &                ,IDS,IDE,JDS,JDE,KDS,KDE                        &
+     &                ,IMS,IME,JMS,JME,KMS,KME                        &
+     &                ,ITS,ITE,JTS,JTE,KTS,KTE,I,J)
+!     ***************************************************************
+!     *                                                             *
+!     *         VERTICAL DIFFUSION OF MASS VARIABLES                *
+!     *                                                             *
+!     ***************************************************************
+!---------------------------------------------------------------------
+!
+      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) :: LMH
+!
+      REAL,INTENT(IN) :: CHKLOWQ,CT,DTDIF,QZ0,RKHS,THZ0
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: RKH
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: RHO
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: CWM,Q,THE
+!
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: CF,CMB,CMCB,CMQB,CMTB,CTHF,DTOZL,DTOZS                   &
+     &       ,RCML,RKHH,RKQS,RSCB,RSQB,RSTB
+!
+      REAL,DIMENSION(KTS:KTE-1) :: CM,CR,DTOZ,RKCT,RSC,RSQ,RST
+!
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      CTHF=0.5*CT
+!
+      DO K=KTS,LMH-1
+        DTOZ(K)=DTDIF/(Z(K)-Z(K+1))
+        CR(K)=-DTOZ(K)*RKH(K)
+        RKCT(K)=RKH(K)*(Z(K)-Z(K+2))*CTHF
+      ENDDO
+!
+      CM(KTS)=DTOZ(KTS)*RKH(KTS)+RHO(KTS)
+!----------------------------------------------------------------------
+      RST(KTS)=-RKCT(KTS)*DTOZ(KTS)                                    &
+     &         +THE(KTS)*RHO(KTS)
+      RSQ(KTS)=Q(KTS)  *RHO(KTS)
+      RSC(KTS)=CWM(KTS)*RHO(KTS)
+!----------------------------------------------------------------------
+      DO K=KTS+1,LMH-1
+        DTOZL=DTOZ(K)
+        CF=-DTOZL*RKH(K-1)/CM(K-1)
+        CM(K)=-CR(K-1)*CF+(RKH(K-1)+RKH(K))*DTOZL+RHO(K)
+        RST(K)=-RST(K-1)*CF+(RKCT(K-1)-RKCT(K))*DTOZL+THE(K)*RHO(K)
+        RSQ(K)=-RSQ(K-1)*CF+Q(K)  *RHO(K)
+        RSC(K)=-RSC(K-1)*CF+CWM(K)*RHO(K)
+      ENDDO
+!
+      DTOZS=DTDIF/(Z(LMH)-Z(LMH+1))
+      RKHH=RKH(LMH-1)
+!
+      CF=-DTOZS*RKHH/CM(LMH-1)
+      RKQS=RKHS*CHKLOWQ
+!
+      CMB=CR(LMH-1)*CF
+      CMTB=-CMB+(RKHH+RKHS)*DTOZS+RHO(LMH)
+      CMQB=-CMB+(RKHH+RKQS)*DTOZS+RHO(LMH)
+      CMCB=-CMB+(RKHH     )*DTOZS+RHO(LMH)
+!
+      RSTB=-RST(LMH-1)*CF+RKCT(LMH-1)*DTOZS+THE(LMH)*RHO(LMH)
+      RSQB=-RSQ(LMH-1)*CF+Q(LMH)  *RHO(LMH)
+      RSCB=-RSC(LMH-1)*CF+CWM(LMH)*RHO(LMH)
+!----------------------------------------------------------------------
+      THE(LMH)=(DTOZS*RKHS*THZ0+RSTB)/CMTB
+      Q(LMH)  =(DTOZS*RKQS*QZ0 +RSQB)/CMQB
+      CWM(LMH)=(                RSCB)/CMCB
+!----------------------------------------------------------------------
+      DO K=LMH-1,KTS,-1
+        RCML=1./CM(K)
+        THE(K)=(-CR(K)*THE(K+1)+RST(K))*RCML
+        Q(K)  =(-CR(K)*  Q(K+1)+RSQ(K))*RCML
+        CWM(K)=(-CR(K)*CWM(K+1)+RSC(K))*RCML
+      ENDDO
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE VDIFH
+!
+!---------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!---------------------------------------------------------------------
+      SUBROUTINE VDIFV(LMH,DTDIF,UZ0,VZ0,RKMS,U,V,RKM,Z,RHO           &
+     &                ,IDS,IDE,JDS,JDE,KDS,KDE                        &
+     &                ,IMS,IME,JMS,JME,KMS,KME                        &
+                      ,ITS,ITE,JTS,JTE,KTS,KTE,I,J)
+!     ***************************************************************
+!     *                                                             *
+!     *        VERTICAL DIFFUSION OF VELOCITY COMPONENTS            *
+!     *                                                             *
+!     ***************************************************************
+!---------------------------------------------------------------------
+!
+      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) :: LMH
+!
+      REAL,INTENT(IN) :: RKMS,DTDIF,UZ0,VZ0
+!
+      REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: RKM
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: RHO
+      REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z
+!
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: U,V
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: K
+!
+      REAL :: CF,DTOZAK,DTOZL,DTOZS,RCML,RCMVB,RHOK,RKMH
+!
+      REAL,DIMENSION(KTS:KTE-1) :: CM,CR,DTOZ,RSU,RSV
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      DO K=1,LMH-1
+        DTOZ(K)=DTDIF/(Z(K)-Z(K+1))
+        CR(K)=-DTOZ(K)*RKM(K)
+      ENDDO
+!
+      RHOK=RHO(1)
+      CM(1)=DTOZ(1)*RKM(1)+RHOK
+      RSU(1)=U(1)*RHOK
+      RSV(1)=V(1)*RHOK
+!----------------------------------------------------------------------
+      DO K=2,LMH-1
+        DTOZL=DTOZ(K)
+        CF=-DTOZL*RKM(K-1)/CM(K-1)
+        RHOK=RHO(K)
+        CM(K)=-CR(K-1)*CF+(RKM(K-1)+RKM(K))*DTOZL+RHOK
+        RSU(K)=-RSU(K-1)*CF+U(K)*RHOK
+        RSV(K)=-RSV(K-1)*CF+V(K)*RHOK
+      ENDDO
+!----------------------------------------------------------------------
+      DTOZS=DTDIF/(Z(LMH)-Z(LMH+1))
+      RKMH=RKM(LMH-1)
+!
+      CF=-DTOZS*RKMH/CM(LMH-1)
+      RHOK=RHO(LMH)
+      RCMVB=1./((RKMH+RKMS)*DTOZS-CR(LMH-1)*CF+RHOK)
+      DTOZAK=DTOZS*RKMS
+!----------------------------------------------------------------------
+      U(LMH)=(DTOZAK*UZ0-RSU(LMH-1)*CF+U(LMH)*RHOK)*RCMVB
+      V(LMH)=(DTOZAK*VZ0-RSV(LMH-1)*CF+V(LMH)*RHOK)*RCMVB
+!----------------------------------------------------------------------
+      DO K=LMH-1,1,-1
+        RCML=1./CM(K)
+        U(K)=(-CR(K)*U(K+1)+RSU(K))*RCML
+        V(K)=(-CR(K)*V(K+1)+RSV(K))*RCML
+      ENDDO
+!----------------------------------------------------------------------
+!
+      END SUBROUTINE VDIFV
+!
+!-----------------------------------------------------------------------
+!
+!=======================================================================
+      SUBROUTINE QNSEPBLINIT(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,          &
+     &                      TKE,EXCH_H,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
+
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) ::    EXCH_H, &
+     &                                                         RUBLTEN, &
+     &                                                         RVBLTEN, &
+     &                                                        RTHBLTEN, &
+     &                                                        RQVBLTEN, &
+     &                                                         TKE
+      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
+          TKE(I,K,J)=EPSQ2L
+          RUBLTEN(I,K,J)=0.
+          RVBLTEN(I,K,J)=0.
+          RTHBLTEN(I,K,J)=0.
+          RQVBLTEN(I,K,J)=0.
+          EXCH_H(I,K,J)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDIF
+
+      END SUBROUTINE QNSEPBLINIT
+!-----------------------------------------------------------------------
+!
+      END MODULE MODULE_BL_QNSEPBL
+!
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_temf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_temf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_temf.F	(revision 17)
@@ -0,0 +1,1435 @@
+!wrf:model_layer:physics
+!
+!
+!
+!
+module module_bl_temf
+contains
+!
+!-------------------------------------------------------------------
+!
+   subroutine temfpbl(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,rho,      &
+                  rublten,rvblten,rthblten,                                    &
+                  rqvblten,rqcblten,rqiblten,flag_qi,                          &
+                  g,cp,rcp,r_d,r_v,cpv,                                   &
+                  z,xlv,psfc,                                          &
+                  mut,p_top,                                           &
+                  znt,ht,ust,zol,hol,hpbl,psim,psih,                         &
+                  xland,hfx,qfx,tsk,qsfc,gz1oz0,wspd,br,                    &
+                  dt,dtmin,kpbl2d,                                             &
+                  svp1,svp2,svp3,svpt0,ep1,ep2,karman,eomeg,stbolt,            &
+                  kh_temf,km_temf,                                            &
+                  u10,v10,t2,                                                  &
+                  te_temf,shf_temf,qf_temf,uw_temf,vw_temf,                    &
+                  wupd_temf,mf_temf,thup_temf,qtup_temf,qlup_temf,            &
+                  cf3d_temf,cfm_temf,                                         &
+                  hd_temf,lcl_temf,hct_temf,                            &
+                  flhc,flqc,exch_temf,                                &
+                  fCor,                                                        &
+                  ids,ide, jds,jde, kds,kde,                                   &
+                  ims,ime, jms,jme, kms,kme,                                   &
+                  its,ite, jts,jte, kts,kte                                   &
+                  )
+!-------------------------------------------------------------------
+      implicit none
+!-------------------------------------------------------------------
+! New variables for TEMF
+!-- te_temf     Total energy from this scheme
+!-- shf_temf    Sensible heat flux profile from this scheme (kinematic)
+!-- qf_temf     Moisture flux profile from this scheme (kinematic)
+!-- uw_temf     U momentum flux component from this scheme
+!-- vw_temf     V momentum flux component from this scheme
+!-- kh_temf     Exchange coefficient for heat (3D)
+!-- km_temf     Exchange coefficient for momentum (3D)
+!-- wupd_temf     Updraft velocity from TEMF BL scheme
+!-- mf_temf       Mass flux from TEMF BL scheme
+!-- thup_temf   Updraft thetal from TEMF BL scheme
+!-- qtup_temf   Updraft qt from TEMF BL scheme
+!-- qlup_temf   Updraft ql from TEMF BL scheme
+!-- cf3d_temf   3D cloud fraction from TEMF BL scheme
+!-- cfm_temf    Column cloud fraction from TEMF BL scheme
+!-- exch_temf   Surface exchange coefficient (as for moisture) from TEMF surface layer scheme
+!-- flhc        Surface exchange coefficient for heat (needed by surface scheme)
+!-- flqc        Surface exchange coefficient for moisture (including moisture availablity)
+!-- fCor        Coriolis parameter (from grid%f)
+!
+!-- 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)
+!               (note: if P_QI<PARAM_FIRST_SCALAR this should be zero filled)
+!-- p3d         3d pressure (pa)
+!-- p3di        3d pressure (pa) at interface level
+!-- pi3d	3d exner function (dimensionless)
+!-- rho 	3d dry air density (kg/m^3)
+!-- rublten     u tendency due to
+!               pbl parameterization (m/s/s)
+!-- rvblten     v tendency due to
+!               pbl parameterization (m/s/s)
+!-- 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_d          gas constant for dry air (j/kg/k)
+!-- rovg 	r/g
+!-- z		height above sea level (m)
+!-- xlv         latent heat of vaporization (j/kg)
+!-- r_v 		gas constant for water vapor (j/kg/k)
+!-- psfc        pressure at the surface (pa)
+!-- znt		roughness length (m)
+!-- ht          terrain height ASL (m)
+!-- ust		u* in similarity theory (m/s)
+!-- zol		z/l height over monin-obukhov length
+!-- hol		pbl height over monin-obukhov length
+!-- hpbl	pbl height (m)
+!-- 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)
+!-- qsfc	surface specific humidity (kg/kg)
+!-- gz1oz0      log(z/z0) where z0 is roughness length
+!-- wspd        wind speed at lowest model level (m/s)
+!-- u10         u-wind speed at 10 m (m/s)
+!-- v10         v-wind speed at 10 m (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 earths 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
+!-------------------------------------------------------------------
+! Arguments
+!
+   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,g,cp,rcp,r_d,r_v,xlv,cpv
+!
+   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, qi3d, &
+                                     p3d, pi3d, th3d, t3d, &
+				     z, rho
+!
+   real,     dimension( ims:ime, kms:kme, jms:jme )                          , &
+             intent(inout)   ::      te_temf
+   real,     dimension( ims:ime, kms:kme, jms:jme )                          , &
+             intent(  out)   ::      shf_temf, qf_temf, uw_temf, vw_temf     , &
+                                     wupd_temf, mf_temf, thup_temf, qtup_temf, &
+                                     qlup_temf,cf3d_temf
+   real,     dimension( ims:ime, jms:jme )                          , &
+             intent(inout)   ::      flhc, flqc, exch_temf
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             intent(in   )   ::      fCor
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             intent(  out)   ::      hd_temf, lcl_temf, hct_temf, cfm_temf
+!
+   real,     dimension( ims:ime, kms:kme, jms:jme )                          , &
+             intent(in   )   ::      p3di
+!
+   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)   ::      kh_temf, km_temf
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             intent(inout)   ::      u10, v10, t2
+!
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             intent(in   )   ::      xland, &
+                                     psim, psih, gz1oz0, br, &
+                                     psfc, tsk, qsfc
+!
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             intent(inout)   ::      hfx, qfx
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             intent(inout)   ::      hol, ust, hpbl, znt, wspd, zol
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             intent(in   )   ::      ht
+!
+  real,      dimension( ims:ime, kms:kme, jms:jme )                          , &
+             intent(in   )   ::      u3d, v3d
+!
+  integer,   dimension( ims:ime, jms:jme )                                   , &
+             intent(out  )   ::      kpbl2d
+!
+     logical, intent(in)        ::   flag_qi
+!
+!   real,     dimension( ims:ime, kms:kme, jms:jme ), &
+!             optional                              , &
+!             intent(inout)   ::      rqiblten
+!
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             optional                                                        , &
+             intent(in   )   ::      mut
+!
+   real,     optional, intent(in   )   ::  p_top
+!
+!-------------------------------------------------------
+! Local variables
+   integer :: j
+
+   do j = jts,jte
+      call temf2d(J=j,ux=u3d(ims,kms,j),vx=v3d(ims,kms,j)                      &
+              ,tx=t3d(ims,kms,j),thx=th3d(ims,kms,j)                           &
+              ,qvx=qv3d(ims,kms,j),qcx=qc3d(ims,kms,j)                         &
+              ,qix=qi3d(ims,kms,j)                                             &
+              ,p2d=p3d(ims,kms,j),p2di=p3di(ims,kms,j)                         &
+              ,pi2d=pi3d(ims,kms,j),rho=rho(ims,kms,j)                         &
+              ,rubltenx=rublten(ims,kms,j),rvbltenx=rvblten(ims,kms,j)         &
+              ,rthbltenx=rthblten(ims,kms,j),rqvbltenx=rqvblten(ims,kms,j)     &
+              ,rqcbltenx=rqcblten(ims,kms,j),rqibltenx=rqiblten(ims,kms,j)     &
+              ,g=g,cp=cp,rcp=rcp,r_d=r_d,r_v=r_v,cpv=cpv            &
+              ,z2d=z(ims,kms,j)                         &
+              ,xlv=xlv                                                   &
+              ,psfcpa=psfc(ims,j),znt=znt(ims,j),zsrf=ht(ims,j),ust=ust(ims,j) &
+              ,zol=zol(ims,j),hol=hol(ims,j),hpbl=hpbl(ims,j)                  &
+              ,psim=psim(ims,j)                           &
+              ,psih=psih(ims,j),xland=xland(ims,j)                             &
+              ,hfx=hfx(ims,j),qfx=qfx(ims,j)                                   &
+              ,tsk=tsk(ims,j),qsfc=qsfc(ims,j),gz1oz0=gz1oz0(ims,j)           &
+              ,wspd=wspd(ims,j),br=br(ims,j)                                   &
+              ,dt=dt,dtmin=dtmin,kpbl1d=kpbl2d(ims,j)                          &
+              ,svp1=svp1,svp2=svp2,svp3=svp3,svpt0=svpt0                       &
+              ,ep1=ep1,ep2=ep2,karman=karman,eomeg=eomeg                       &
+              ,stbolt=stbolt                                                   &
+              ,kh_temfx=kh_temf(ims,kms,j),km_temfx=km_temf(ims,kms,j)         &
+              ,u10=u10(ims,j),v10=v10(ims,j),t2=t2(ims,j)                      &
+              ,te_temfx=te_temf(ims,kms,j)                                     &
+              ,shf_temfx=shf_temf(ims,kms,j),qf_temfx=qf_temf(ims,kms,j)       &
+              ,uw_temfx=uw_temf(ims,kms,j),vw_temfx=vw_temf(ims,kms,j)       &
+              ,wupd_temfx=wupd_temf(ims,kms,j),mf_temfx=mf_temf(ims,kms,j)   &
+              ,thup_temfx=thup_temf(ims,kms,j),qtup_temfx=qtup_temf(ims,kms,j) &
+              ,qlup_temfx=qlup_temf(ims,kms,j) &
+              ,cf3d_temfx=cf3d_temf(ims,kms,j),cfm_temfx=cfm_temf(ims,j)       &
+              ,hd_temfx=hd_temf(ims,j),lcl_temfx=lcl_temf(ims,j)       &
+              ,hct_temfx=hct_temf(ims,j),exch_temfx=exch_temf(ims,j)    &
+              ,flhc=flhc(ims,j),flqc=flqc(ims,j)                     &
+              ,fCor=fCor(ims,j)                                              &
+              ,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   )
+   enddo
+!
+   end subroutine temfpbl
+!
+!-------------------------------------------------------------------
+!
+   subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
+                  rubltenx,rvbltenx,rthbltenx,                                 &
+                  rqvbltenx,rqcbltenx,rqibltenx,                               &
+                  g,cp,rcp,r_d,r_v,cpv,                            &
+                  z2d,                                                  &
+                  xlv,psfcpa,                                    &
+                  znt,zsrf,ust,zol,hol,hpbl,psim,psih,                      &
+                  xland,hfx,qfx,tsk,qsfc,gz1oz0,wspd,br,                   &
+                  dt,dtmin,kpbl1d,                                             &
+                  svp1,svp2,svp3,svpt0,ep1,ep2,karman,eomeg,stbolt,            &
+                  kh_temfx,km_temfx,                                         &
+                  u10,v10,t2,                                                 &
+                  te_temfx,shf_temfx,qf_temfx,uw_temfx,vw_temfx,               &
+                  wupd_temfx,mf_temfx,thup_temfx,qtup_temfx,qlup_temfx,       &
+                  cf3d_temfx,cfm_temfx,                                        &
+                  hd_temfx,lcl_temfx,hct_temfx,exch_temfx,           &
+                  flhc,flqc,                                                 &
+                  fCor,                                                        &
+                  ids,ide, jds,jde, kds,kde,                                   &
+                  ims,ime, jms,jme, kms,kme,                                   &
+                  its,ite, jts,jte, kts,kte                                   &
+                  )
+!-------------------------------------------------------------------
+   implicit none
+!-------------------------------------------------------------------
+!
+! This is the Total Energy - Mass Flux (TEMF) PBL scheme.
+! Initial implementation 2010 by Wayne Angevine, CIRES/NOAA ESRL.
+! References:
+!    Angevine et al., 2010, MWR
+!    Angevine, 2005, JAM
+!    Mauritsen et al., 2007, JAS
+!
+!-------------------------------------------------------------------
+!
+   integer,  intent(in   )   ::      ids,ide, jds,jde, kds,kde,                &
+                                     ims,ime, jms,jme, kms,kme,                &
+                                     its,ite, jts,jte, kts,kte, j
+!
+   real,     intent(in   )   ::      dt,dtmin,g,cp,rcp,r_d,r_v,cpv,xlv
+!
+   real,     intent(in )     ::      svp1,svp2,svp3,svpt0
+   real,     intent(in )     ::      ep1,ep2,karman,eomeg,stbolt
+!
+   real,     dimension( ims:ime, kms:kme ),                                    &
+             intent(in)      ::      z2d
+!
+   real,     dimension( ims:ime, kms:kme )                                   , &
+             intent(in   )   ::      ux, vx
+   real,     dimension( ims:ime, kms:kme )                                   , &
+             intent(inout)   ::      te_temfx
+   real,     dimension( ims:ime, kms:kme )                                   , &
+             intent(  out)   ::      shf_temfx, qf_temfx, uw_temfx, vw_temfx , &
+                                     wupd_temfx, mf_temfx,thup_temfx,          &
+                                     qtup_temfx, qlup_temfx, cf3d_temfx
+   real,     dimension( ims:ime )                                   , &
+             intent(  out)   ::      hd_temfx, lcl_temfx, hct_temfx, cfm_temfx
+   real,     dimension( ims:ime )                                   , &
+             intent(in   )   ::      fCor
+   real,     dimension( ims:ime )                                   , &
+             intent(inout)   ::      flhc, flqc, exch_temfx
+   real,     dimension( ims:ime, kms:kme )                                   , &
+             intent(in   )   ::      tx, thx, qvx, qcx, qix, pi2d, rho
+   real,     dimension( ims:ime, kms:kme )                                 , &
+             intent(in   )   ::      p2di, p2d
+!
+   real,     dimension( ims:ime, kms:kme )                                   , &
+             intent(inout)   ::      rubltenx, rvbltenx, rthbltenx,            &
+                                     rqvbltenx, rqcbltenx, rqibltenx
+!
+   real,     dimension( ims:ime )                                            , &
+             intent(inout)   ::      hol, ust, hpbl, znt
+   real,     dimension( ims:ime )                                            , &
+             intent(in   )   ::      xland, zsrf
+   real,     dimension( ims:ime )                                            , &
+             intent(inout)   ::      hfx, qfx
+!
+   real,     dimension( ims:ime ), intent(inout)   ::  wspd
+   real,     dimension( ims:ime ), intent(in  )    ::  br
+!
+   real,     dimension( ims:ime ), intent(in   )   ::  psim, psih
+   real,     dimension( ims:ime ), intent(in   )   ::  gz1oz0
+!
+   real,     dimension( ims:ime ), intent(in   )   ::  psfcpa
+   real,     dimension( ims:ime ), intent(in   )   ::  tsk, qsfc
+   real,     dimension( ims:ime ), intent(inout)   ::  zol
+   integer,  dimension( ims:ime ), intent(out  )   ::  kpbl1d
+   real,     dimension( ims:ime, kms:kme )                                   , &
+             intent(inout)   ::        kh_temfx, km_temfx
+!
+   real,     dimension( ims:ime )                                            , &
+             intent(inout)    ::        u10, v10, t2
+!
+!
+!-----------------------------------------------------------
+! Local variables
+!
+! TE model constants
+   logical, parameter :: MFopt = .true.  ! Use mass flux or not
+!   real, parameter :: visc_temf = 1.57e-5
+!   real, parameter :: conduc_temf = 1.57e-5 / 0.733
+   real, parameter :: visc_temf = 1.57e-4   ! WA TEST bigger minimum K
+   real, parameter :: conduc_temf = 1.57e-4 / 0.733
+   real, parameter :: Pr_temf = 0.733
+   real, parameter :: TEmin = 1e-3
+   real, parameter :: ftau0 = 0.17
+   real, parameter :: fth0 = 0.145
+!   real, parameter :: fth0 = 0.12    ! WA 10/13/10 to make PrT0 ~= 1
+   real, parameter :: critRi = 0.25
+   real, parameter :: Cf = 0.185
+   real, parameter :: CN = 2.0
+!   real, parameter :: Ceps = ftau0**1.5
+   real, parameter :: Ceps = 0.070
+   real, parameter :: Cgamma = Ceps
+   real, parameter :: Cphi = Ceps
+!   real, parameter :: PrT0 = Cphi/Ceps * ftau0**2. / 2 / fth0**2.
+   real, parameter :: PrT0 = Cphi/Ceps * ftau0**2 / 2. / fth0**2
+! EDMF constants
+   real, parameter :: CM = 0.03      ! Proportionality constant for subcloud MF
+   real, parameter :: Cdelt = 0.006  ! Prefactor for detrainment rate
+   real, parameter :: Cw = 0.5       ! Prefactor for surface wUPD
+   real, parameter :: Cc = 3.0       ! Prefactor for convective length scale
+   real, parameter :: lasymp = 200.0 ! Asymptotic length scale WA 11/20/09
+   real, parameter :: hmax = 4000.0  ! Max hd,hct WA 11/20/09
+!
+   integer :: i, k, kt   ! Loop variable
+   integer, dimension( its:ite) ::  h0idx
+   real, dimension( its:ite)    ::  h0
+   real, dimension( its:ite)    ::  wstr, ang, wm
+   real, dimension( its:ite)    ::  hd,lcl,hct,ht
+   real, dimension( its:ite)    ::  convection_TKE_surface_src, sfcFTE
+   real, dimension( its:ite)    ::  sfcTHVF
+   real, dimension( its:ite)    ::  z0t
+   integer, dimension( its:ite) ::  hdidx,lclidx,hctidx,htidx
+   integer, dimension( its:ite) ::  tval
+   ! real, dimension( its:ite )   ::  sfcHF, sfcQF
+   real, dimension( its:ite, kts:kte) :: thetal, qt
+   real, dimension( its:ite, kts:kte) :: u_temf, v_temf
+   real, dimension( its:ite, kts:kte) :: rv, rl, rt
+   real, dimension( its:ite, kts:kte) :: chi_poisson, gam
+   real, dimension( its:ite, kts:kte) :: dthdz, dqtdz, dudz, dvdz
+   real, dimension( its:ite, kts:kte) :: lepsmin
+   real, dimension( its:ite, kts:kte) :: thetav
+   real, dimension( its:ite, kts:kte) :: MFCth, MFCq, MFCu, MFCv
+   real, dimension( its:ite, kts:kte) :: MFCql, MFCthv, MFCTE
+   real, dimension( its:ite, kts:kte) :: epsmf, deltmf, dMdz
+   real, dimension( its:ite, kts:kte) :: UUPD, VUPD
+   real, dimension( its:ite, kts:kte) :: thetavUPD, qlUPD, TEUPD
+   real, dimension( its:ite, kts:kte) :: thetavUPDmoist, wupd_dry
+   real, dimension( its:ite, kts:kte) :: B, Bmoist
+   real, dimension( its:ite, kts:kte) :: zm, zt, dzm, dzt
+   real, dimension( its:ite, kts:kte) :: dthUPDdz, dqtup_temfxdz, dwUPDdz
+   real, dimension( its:ite, kts:kte) :: dwUPDmoistdz
+   real, dimension( its:ite, kts:kte) :: dUUPDdz, dVUPDdz, dTEUPDdz
+   real, dimension( its:ite, kts:kte) :: TUPD, rstUPD, rUPD, rlUPD, qstUPD
+   real, dimension( its:ite, kts:kte) :: N2, S, Ri, beta, ftau, fth, ratio
+   real, dimension( its:ite, kts:kte) :: TKE, TE2
+   real, dimension( its:ite, kts:kte) :: ustrtilde, linv, leps
+   real, dimension( its:ite, kts:kte) :: km, kh
+   real, dimension( its:ite, kts:kte) :: Fz, QFK, uwk, vwk
+   real, dimension( its:ite, kts:kte) :: km_conv, kh_conv, lconv
+   real, dimension( its:ite, kts:kte) :: alpha2, beta2   ! For thetav flux calculation
+   real, dimension( its:ite, kts:kte) :: THVF, buoy_src, srcs
+   real, dimension( its:ite, kts:kte) :: u_new, v_new
+   real, dimension( its:ite, kts:kte) :: thx_new, qvx_new, qcx_new
+   real, dimension( its:ite, kts:kte) :: thup_new, qvup_new
+   real, dimension( its:ite, kts:kte) :: beta1 ! For saturation humidity calculations
+   real Cepsmf    ! Prefactor for entrainment rate
+   real red_fact  ! WA TEST for reducing MF components
+   logical is_convective
+   ! Vars for cloud fraction calculation
+   real, dimension( its:ite, kts:kte) :: au, sigq, qst, satdef
+   real sigq2, rst
+
+!----------------------------------------------------------------------
+! Grid staggering:  Matlab version has mass and turbulence levels.
+! WRF has full levels (with w) and half levels (u,v,theta,q*).  Both
+! sets of levels use the same indices (kts:kte).  See pbl_driver or
+! WRF Physics doc for (a few) details.  
+! So *mass levels correspond to half levels.*
+! WRF full levels are ignored, we define our own turbulence levels
+! in order to put the first one below the first half level.
+! Another difference is that
+! the Matlab version (and the Mauritsen et al. paper) consider the
+! first mass level to be at z0 (effectively the surface).  WRF considers
+! the first half level to be above the effective surface.  The first half
+! level, at k=1, has nonzero values of u,v for example.  Here we convert
+! all incoming variables to internal ones with the correct indexing
+! in order to make the code consistent with the Matlab version.  We
+! already had to do this for thetal and qt anyway, so the only additional
+! overhead is for u and v.
+! I use suffixes m for mass and t for turbulence as in Matlab for things
+! like indices.
+! Note that zsrf is the terrain height ASL, from Registry variable ht.
+! Translations (Matlab to WRF):
+!     dzt -> calculated below
+!     dzm -> not supplied, calculated below
+!     k -> karman
+!     z0 -> znt
+!     z0t -> not in WRF, calculated below
+!     zt -> calculated below
+!     zm -> (z2d - zsrf) but NOTE zm(1) is now z0 (znt) and zm(2) is
+!                                 z2d(1) - zsrf
+!
+! WA I take the temperature at z0 to be
+! TSK.  This isn't exactly robust.  Also I pass out the surface
+! exchange coefficients flhc, flqc for the surface scheme to use in the 
+! next timestep.
+! WA 2/16/11 removed calculation of flhc, flqc which are not needed here.
+! These should be removed from the calling sequence someday.
+!
+! Other notes:
+! - I have often used 1 instead of kts below, because the scheme demands
+!   to know where the surface is.  It won't work if kts .NE. 1.
+
+
+   do i = its,ite      ! Main loop 
+
+      ! Get incoming surface theta from TSK (WA for now)
+      thetal(i,1) = tsk(i) / pi2d(i,1)  ! WA really should use Exner func. at z0
+      if (exch_temfx(i) > 1.0e-12) then
+         qt(i,1) = qfx(i) / exch_temfx(i) + qvx(i,1)  ! WA assumes no liquid at z0
+      else
+         qt(i,1) = qvx(i,1)
+      end if
+      rv(i,1) = qt(i,1) / (1.-qt(i,1))   ! Water vapor
+      rl(i,1) = 0.
+      rt(i,1) = rv(i,1) + rl(i,1)        ! Total water (without ice)
+      chi_poisson(i,1) = rcp * (1.+rv(i,1)/ep2) / (1.+rv(i,1)*cpv/cp)
+      gam(i,1) = rv(i,1) * r_v / (cp + rv(i,1)*cpv)
+      ! thetav(i,1) = thetal(i,1) * (1. + 0.608*qt(i,1))  ! WA Assumes ql(env)=0, what if it isn't?
+      thetav(i,1) = thetal(i,1) * (1. + 0.608*qt(i,1) - qcx(i,1))  ! WA 4/6/10 allow environment liquid
+      ! WA TEST (R5) set z0t = z0
+      ! z0t(i) = znt(i) / 10.0   ! WA this is hard coded in Matlab version
+      z0t(i) = znt(i)
+
+      ! Convert incoming theta to thetal and qv,qc to qt
+      ! NOTE this is where the indexing gets changed from WRF to TEMF basis
+      do k = kts+1,kte
+         ! Convert specific humidities to mixing ratios
+         rv(i,k) = qvx(i,k-1) / (1.-qvx(i,k-1))   ! Water vapor
+         rl(i,k) = qcx(i,k-1) / (1.-qcx(i,k-1))   ! Liquid water 
+         rt(i,k) = rv(i,k) + rl(i,k)        ! Total water (without ice)
+         chi_poisson(i,k) = rcp * (1.+rv(i,k)/ep2) / (1.+rv(i,k)*cpv/cp)
+         gam(i,k) = rt(i,k) * r_v / (cp + rt(i,k)*cpv)
+         thetal(i,k) = thx(i,k-1) * ((ep2+rv(i,k))/(ep2+rt(i,k)))**chi_poisson(i,k) * (rv(i,k)/rt(i,k))**(-gam(i,k)) * exp( -xlv*rl(i,k) / ((cp + rt(i,k)*cpv) * tx(i,k)))
+         qt(i,k) = qvx(i,k-1) + qcx(i,k-1)
+         ! thetav(i,k) = thetal(i,k) * (1. + 0.608*qt(i,k))  ! WA Assumes ql(env)=0, what if it isn't?
+         thetav(i,k) = thetal(i,k) * (1. + 0.608*qt(i,k) - qcx(i,k-1))  ! WA 4/6/10 allow environment liquid
+      end do
+
+      ! Convert incoming u,v to internal u_temf, v_temf
+      ! NOTE this is where the indexing gets changed from WRF to TEMF basis
+      u_temf(i,1) = 0.   ! zero winds at z0
+      v_temf(i,1) = 0.
+      do k = kts+1,kte
+         u_temf(i,k) = ux(i,k-1)
+         v_temf(i,k) = vx(i,k-1)
+      end do
+
+      ! Get delta height at half (mass) levels
+      zm(i,1) = znt(i)
+      dzt(i,1) = z2d(i,1) - zsrf(i) - zm(i,1)
+      ! Get height and delta at turbulence levels
+      zt(i,1) = (z2d(i,1) - zsrf(i) - znt(i)) / 2.
+      do kt = kts+1,kte
+         zm(i,kt) = z2d(i,kt-1) - zsrf(i) ! Convert indexing from WRF to TEMF
+         zt(i,kt) = (zm(i,kt) + z2d(i,kt) - zsrf(i)) / 2.
+         dzm(i,kt) = zt(i,kt) - zt(i,kt-1)
+         dzt(i,kt) = z2d(i,kt+1) - z2d(i,kt)
+      end do
+      dzm(i,1) = dzm(i,2)  ! WA why?
+      dzt(i,kte) = dzt(i,kte-1)    ! WA 12/23/09
+
+      ! Gradients at first level
+      dthdz(i,1) = (thetal(i,2)-thetal(i,1)) / (zt(i,1) * log10(zm(i,2)/z0t(i)))
+      dqtdz(i,1) = (qt(i,2)-qt(i,1)) / (zt(i,1) * log10(zm(i,2)/z0t(i)))
+      dudz(i,1) = (u_temf(i,2)-u_temf(i,1)) / (zt(i,1) * log10(zm(i,2)/znt(i)))
+      dvdz(i,1) = (v_temf(i,2)-v_temf(i,1)) / (zt(i,1) * log10(zm(i,2)/znt(i)))
+
+      ! Surface thetaV flux from Stull p.147
+      sfcTHVF(i) = hfx(i)/(rho(i,1)*cp) * (1.+0.608*(qvx(i,1)+qcx(i,1))) + 0.608*thetav(i,1)*qf_temfx(i,1)
+
+      ! WA use hd_temf to calculate w* instead of finding h0 here????
+      ! Watch initialization!
+      h0idx(i) = 1
+      h0(i) = zm(i,1)
+
+      ! WA TEST (R4) remove lower limit on leps
+      ! lepsmin(i,kts) = min(0.4*zt(i,kts), 5.)
+      lepsmin(i,kts) = 0.
+
+      do k = kts+1,kte-1
+         ! WA TEST (R4) remove lower limit on leps
+         ! lepsmin(i,k) = min(0.4*zt(i,k), 5.)
+         lepsmin(i,k) = 0.
+         ! lepsmin(i,k) = min(zt(i,k), 20.)  ! WA to deal with runaway
+
+         ! Mean gradients
+         ! dthdz(i,k) = (thx(i,k) - thx(i,k-1)) / dzt(i,k)  ! WA 1/12/10
+         dthdz(i,k) = (thetal(i,k+1) - thetal(i,k)) / dzt(i,k)
+         dqtdz(i,k) = (qt(i,k+1) - qt(i,k)) / dzt(i,k)
+         dudz(i,k) = (u_temf(i,k+1) - u_temf(i,k)) / dzt(i,k)
+         dvdz(i,k) = (v_temf(i,k+1) - v_temf(i,k)) / dzt(i,k)
+
+         ! Find h0 (should eventually be interpolated for smoothness)
+         if (thetav(i,k) > thetav(i,1) .AND. h0idx(i) .EQ. 1) then
+            h0idx(i) = k
+            h0(i) = zm(i,k)
+         end if
+      end do
+
+      ! Gradients at top level   
+
+      dthdz(i,kte) = dthdz(i,kte-1)
+      dqtdz(i,kte) = dqtdz(i,kte-1)
+      dudz(i,kte) = dudz(i,kte-1)
+      dvdz(i,kte) = dvdz(i,kte-1)
+
+      if ( hfx(i) > 0.) then
+         ! wstr(i) = (g * h0(i) / thetav(i,2) * shf_temfx(i,1) ) ** (1./3.)
+         wstr(i) = (g * h0(i) / thetav(i,2) * hfx(i)/(rho(i,1)*cp) ) ** (1./3.)
+      else
+         wstr(i) = 0.
+      end if
+      
+
+      ! Set flag convective or not for use below
+      is_convective = wstr(i) > 0. .AND. MFopt .AND. dthdz(i,1)<0. .AND. dthdz(i,2)<0.  ! WA 12/16/09 require two levels of negative (unstable) gradient
+
+      ! Find stability parameters and length scale (on turbulence levels)
+      do kt = 1,kte-1
+         N2(i,kt) = 2. * g / (thetav(i,kt) + thetav(i,kt+1))*dthdz(i,kt)
+         S(i,kt) = sqrt(dudz(i,kt)**2. + dvdz(i,kt)**2.)
+         Ri(i,kt) = N2(i,kt) / S(i,kt)**2.
+         if (S(i,kt) < 1e-15) then
+            if (N2(i,kt) >= 0) then
+               Ri(i,kt) = 10.
+            else
+               Ri(i,kt) = -1.
+            end if
+         end if
+         beta(i,kt) = 2. * g / (thetav(i,kt)+thetav(i,kt+1))
+         if (Ri(i,kt) > 0) then
+            ratio(i,kt) = Ri(i,kt)/(Cphi**2.*ftau0**2./(2.*Ceps**2.*fth0**2.)+3.*Ri(i,kt))
+            ftau(i,kt) = ftau0 * ((3./4.) / (1.+4.*Ri(i,kt)) + 1./4.)
+            fth(i,kt) = fth0 / (1.+4.*Ri(i,kt))
+            TE2(i,kt) = 2. * te_temfx(i,kt) * ratio(i,kt) * N2(i,kt) / beta(i,kt)**2.
+         else
+            ratio(i,kt) = Ri(i,kt)/(Cphi**2.*ftau0**2./(-2.*Ceps**2.*fth0**2.)+2.*Ri(i,kt))
+            ftau(i,kt) = ftau0
+            fth(i,kt) = fth0
+            TE2(i,kt) = 0.
+         end if
+         TKE(i,kt) = te_temfx(i,kt) * (1. - ratio(i,kt))
+         ustrtilde(i,kt) = sqrt(ftau(i,kt) * TKE(i,kt))
+         if (N2(i,kt) > 0.) then
+            linv(i,kt) = 1./karman / zt(i,kt) + abs(fCor(i)) / (Cf*ustrtilde(i,kt)) + sqrt(N2(i,kt))/(CN*ustrtilde(i,kt)) + 1./lasymp  ! WA Test 11/20/09
+         else
+            linv(i,kt) = 1./karman / zt(i,kt) + abs(fCor(i)) / (Cf*ustrtilde(i,kt)) + 1./lasymp  ! WA Test 11/20/09
+         end if
+         leps(i,kt) = 1./linv(i,kt)
+         leps(i,kt) = max(leps(i,kt),lepsmin(i,kt))
+      end do 
+      S(i,kte) = 0.0
+      N2(i,kte) = 0.0
+      TKE(i,kte) = 0.0
+      linv(i,kte) = linv(i,kte-1)
+      leps(i,kte) = leps(i,kte-1)
+
+
+      ! Find diffusion coefficients
+      ! First use basic formulae for stable and neutral cases,
+      ! then for convective conditions, and finally choose the larger
+      ! WA 12/23/09 use convective form up to hd/2 always
+      ! WA 12/28/09 after restructuring, this block is above MF block,
+      ! so hd is not yet available for this timestep, must use h0,
+      ! or use hd from previous timestep but be careful about initialization.
+      do kt = 1,kte-1    ! WA 12/22/09
+         ! WA 4/8/10 remove beta term to avoid negative and huge values
+         ! of km due to very small denominator.  This is an interim fix
+         ! until we find something better (more theoretically sound).
+         ! km(i,kt) = TKE(i,kt)**1.5 * ftau(i,kt)**2. / (-beta(i,kt) * fth(i,kt) * sqrt(TE2(i,kt)) + Ceps * sqrt(TKE(i,kt)*te_temfx(i,kt)) / leps(i,kt))
+         km(i,kt) = TKE(i,kt)**1.5 * ftau(i,kt)**2. / (Ceps * sqrt(TKE(i,kt)*te_temfx(i,kt)) / leps(i,kt))
+         kh(i,kt) = 2. * leps(i,kt) * fth(i,kt)**2. * TKE(i,kt) / sqrt(te_temfx(i,kt)) / Cphi
+         if ( is_convective) then
+            if (kt <= h0idx(i)) then
+               lconv(i,kt) = 1. / (1. / (karman*zt(i,kt)) + Cc / (karman * (h0(i) - zt(i,kt))))
+            else
+               lconv(i,kt) = 0.
+            end if
+            ! WA 12/15/09 use appropriate coeffs to match kh_conv and kh at neutral
+            kh_conv(i,kt) = ftau0**2. / Ceps / PrT0 * sqrt(TKE(i,kt)) * lconv(i,kt)
+            if (kh_conv(i,kt) < 0.) then
+               kh_conv(i,kt) = 0.
+            end if
+            km_conv(i,kt) = PrT0 * kh_conv(i,kt)
+            if (zt(i,kt) <= h0(i)/2.) then
+               km(i,kt) = km_conv(i,kt)
+               kh(i,kt) = kh_conv(i,kt)
+            end if
+            ! WA TEST 1/11/10 go back to max in upper BL
+            if (zt(i,kt) > h0(i)/2. .AND. kt <= h0idx(i)) then
+               km(i,kt) = max(km(i,kt),km_conv(i,kt),visc_temf)
+               kh(i,kt) = max(kh(i,kt),kh_conv(i,kt),conduc_temf)
+            end if
+         end if  ! is_convective
+         km(i,kt) = max(km(i,kt),visc_temf)
+         kh(i,kt) = max(kh(i,kt),conduc_temf)
+         Fz(i,kt) = -kh(i,kt) * dthdz(i,kt)  ! Diffusive heat flux
+      end do
+      km(i,kte) = km(i,kte-1)  ! WA 12/22/09
+      kh(i,kte) = kh(i,kte-1)
+      Fz(i,kte) = 0.0          ! WA 4/2/10
+
+
+      !*** Mass flux block starts here ***
+
+      if ( is_convective) then
+
+         Cepsmf = 2. / max(200.,h0(i))
+         Cepsmf = max(Cepsmf,0.002)    ! WA 7/20/10
+         do k = kts,kte
+            ! Calculate lateral entrainment fraction for subcloud layer
+            ! epsilon and delta are defined on mass grid (half levels)
+            epsmf(i,k) = Cepsmf
+         end do
+
+         ! Initialize updraft
+         thup_temfx(i,1) = thetal(i,1)    ! No excess
+         qtup_temfx(i,1) = qt(i,1)            ! No excess
+         rUPD(i,1) = qtup_temfx(i,1) / (1. - qtup_temfx(i,1))
+         wupd_temfx(i,1) = Cw * wstr(i)
+         wupd_dry(i,1) = Cw * wstr(i)
+         UUPD(i,1) = u_temf(i,1)
+         VUPD(i,1) = v_temf(i,1)
+         thetavUPD(i,1) = thup_temfx(i,1) * (1. + 0.608*qtup_temfx(i,1))  ! WA Assumes no liquid
+         thetavUPDmoist(i,1) = thup_temfx(i,1) * (1. + 0.608*qtup_temfx(i,1))  ! WA Assumes no liquid
+         TEUPD(i,1) = te_temfx(i,1) + g / thetav(i,1) * sfcTHVF(i)
+         ! qlUPD(i,1) = 0.
+         qlUPD(i,1) = qcx(i,1)  ! WA allow environment liquid
+         TUPD(i,1) = thup_temfx(i,1) * pi2d(i,1)   
+         rstUPD(i,1) = rsat(p2d(i,1),TUPD(i,1),ep2)  
+         rlUPD(i,1) = 0.
+
+         ! Calculate updraft parameters counting up
+         do k = 2,kte
+            dthUPDdz(i,k-1) = -epsmf(i,k) * (thup_temfx(i,k-1) - thetal(i,k-1))
+            thup_temfx(i,k) = thup_temfx(i,k-1) + dthUPDdz(i,k-1) * dzm(i,k-1)
+            dqtup_temfxdz(i,k-1) = -epsmf(i,k) * (qtup_temfx(i,k-1) - qt(i,k-1))
+            qtup_temfx(i,k) = qtup_temfx(i,k-1) + dqtup_temfxdz(i,k-1) * dzm(i,k-1)
+            thetavUPD(i,k) = thup_temfx(i,k) * (1. + 0.608*qtup_temfx(i,k))  ! WA Assumes no liquid
+            B(i,k-1) = g * (thetavUPD(i,k) - thetav(i,k)) / thetav(i,k)
+            if ( wupd_dry(i,k-1) < 1e-15 ) then
+               wupd_dry(i,k) = 0.
+            else
+               dwUPDdz(i,k-1) = -2. *epsmf(i,k)*wupd_dry(i,k-1) + 0.33*B(i,k-1)/wupd_dry(i,k-1)
+               wupd_dry(i,k) = wupd_dry(i,k-1) + dwUPDdz(i,k-1) * dzm(i,k-1)
+            end if
+            dUUPDdz(i,k-1) = -epsmf(i,k) * (UUPD(i,k-1) - u_temf(i,k-1))
+            UUPD(i,k) = UUPD(i,k-1) + dUUPDdz(i,k-1) * dzm(i,k-1)
+            dVUPDdz(i,k-1) = -epsmf(i,k) * (VUPD(i,k-1) - v_temf(i,k-1))
+            VUPD(i,k) = VUPD(i,k-1) + dVUPDdz(i,k-1) * dzm(i,k-1)
+            dTEUPDdz(i,k-1) = -epsmf(i,k) * (TEUPD(i,k-1) - te_temfx(i,k-1))
+            TEUPD(i,k) = TEUPD(i,k-1) + dTEUPDdz(i,k-1) * dzm(i,k-1)
+            ! Alternative updraft velocity based on moist thetav
+            ! Need thetavUPDmoist, qlUPD
+            rUPD(i,k) = qtup_temfx(i,k) / (1. - qtup_temfx(i,k))
+            ! WA Updraft temperature assuming no liquid
+            TUPD(i,k) = thup_temfx(i,k) * pi2d(i,k)   
+            ! Updraft saturation mixing ratio 
+            ! rstUPD(i,k) = rsat(p2d(i,k),TUPD(i,k),ep2)  ! WA 4/19/10
+            rstUPD(i,k) = rsat(p2d(i,k-1),TUPD(i,k),ep2)  
+            ! Correct to actual temperature (Sommeria & Deardorff 1977)
+            beta1(i,k) = 0.622 * (xlv/(r_d*TUPD(i,k))) * (xlv/(cp*TUPD(i,k)))
+            rstUPD(i,k) = rstUPD(i,k) * (1.0+beta1(i,k)*rUPD(i,k)) / (1.0+beta1(i,k)*rstUPD(i,k))
+            qstUPD(i,k) = rstUPD(i,k) / (1. + rstUPD(i,k))
+            if (rUPD(i,k) > rstUPD(i,k)) then
+               rlUPD(i,k) = rUPD(i,k) - rstUPD(i,k)
+               qlUPD(i,k) = rlUPD(i,k) / (1. + rlUPD(i,k))
+               thetavUPDmoist(i,k) = (thup_temfx(i,k) + ((xlv/cp)*qlUPD(i,k)/pi2d(i,k))) * (1. + 0.608*qstUPD(i,k) - qlUPD(i,k))
+            else
+               rlUPD(i,k) = 0.
+               ! qlUPD(i,k) = 0.
+               qlUPD(i,k) = qcx(i,k-1)   ! WA 4/6/10 allow environment liquid
+               ! WA does this make sense?  Should be covered above?
+               thetavUPDmoist(i,k) = thup_temfx(i,k) * (1. + 0.608*qtup_temfx(i,k))
+            end if
+            Bmoist(i,k-1) = g * (thetavUPDmoist(i,k) - thetav(i,k)) / thetav(i,k)
+            if ( wupd_temfx(i,k-1) < 1e-15 ) then
+               wupd_temfx(i,k) = 0.
+            else
+               dwUPDmoistdz(i,k-1) = -2. *epsmf(i,k)*wupd_temfx(i,k-1) + 0.33*Bmoist(i,k-1)/wupd_temfx(i,k-1)
+               wupd_temfx(i,k) = wupd_temfx(i,k-1) + dwUPDmoistdz(i,k-1) * dzm(i,k-1)
+            end if
+         end do
+
+         ! Find hd based on wUPD
+         if (wupd_dry(i,1) == 0.) then
+            hdidx(i) = 1
+         else
+            hdidx(i) = kte  ! In case wUPD <= 0 not found
+            do k = 2,kte
+               ! if (wupd_dry(i,k) <= 0.) then
+               if (wupd_dry(i,k) <= 0. .OR. zm(i,k) > hmax) then  ! WA Test
+                  hdidx(i) = k
+                  goto 100   ! FORTRAN made me do it!
+               end if
+            end do
+         end if
+100      hd(i) = zm(i,hdidx(i))
+         ! kpbl1d(i) = hd(i)        ! WA not sure if this is what I want for diagnostic out to larger WRF universe....and it's not right if not convective
+         kpbl1d(i) = hdidx(i)  ! WA 5/11/10 kpbl should be index
+         hpbl(i) = hd(i)       ! WA 5/11/10 hpbl is height.  Should still be replaced by something that works whether convective or not.
+
+         ! Find LCL, hct, and ht
+         lclidx(i) = kte   ! In case LCL not found
+         do k = kts,kte
+            if (rUPD(i,k) > rstUPD(i,k)) then
+               lclidx(i) = k
+               goto 200
+            end if
+         end do
+200      lcl(i) = zm(i,lclidx(i))
+
+         if (hd(i) > lcl(i)) then   ! Forced cloud (at least) occurs
+            ! Find hct based on wUPDmoist
+            if (wupd_temfx(i,1) == 0.) then
+               hctidx(i) = 1
+            else
+               hctidx(i) = kte  ! In case wUPD <= 0 not found
+               do k = 2,kte
+                  if (wupd_temfx(i,k) <= 0. .OR. zm(i,k) > hmax) then  ! WA Test
+                     hctidx(i) = k
+                     goto 300   ! FORTRAN made me do it!
+                  end if
+               end do
+            end if
+   300      hct(i) = zm(i,hctidx(i))
+            if (hctidx(i) <= hdidx(i)+1) then   ! No active cloud
+               hct(i) = hd(i)
+               hctidx(i) = hdidx(i)
+            else 
+            end if
+         else   ! No cloud
+            hct(i) = hd(i)
+            hctidx(i) = hdidx(i)
+         end if
+         ht(i) = max(hd(i),hct(i))
+         htidx(i) = max(hdidx(i),hctidx(i))
+
+         ! Now truncate updraft at ht with taper
+         do k = 1,kte
+            if (zm(i,k) < 0.9*ht(i)) then  ! Below taper region
+               tval(i) = 1
+            else if (zm(i,k) >= 0.9*ht(i) .AND. zm(i,k) <= 1.0*ht(i)) then
+               ! Within taper region
+               tval(i) = 1. - ((zm(i,k) - 0.9*ht(i)) / (1.0*ht(i) - 0.9*ht(i)))
+            else  ! Above taper region
+               tval(i) = 0.
+            end if
+            thup_temfx(i,k) = tval(i) * thup_temfx(i,k) + (1-tval(i))*thetal(i,k)
+            thetavUPD(i,k) = tval(i) * thetavUPD(i,k) + (1-tval(i))*thetav(i,k)
+            qtup_temfx(i,k) = tval(i) * qtup_temfx(i,k) + (1-tval(i)) * qt(i,k)
+            qlUPD(i,k) = tval(i) * qlUPD(i,k) + (1-tval(i)) * qcx(i,k-1)
+            UUPD(i,k) = tval(i) * UUPD(i,k) + (1-tval(i)) * u_temf(i,k)
+            VUPD(i,k) = tval(i) * VUPD(i,k) + (1-tval(i)) * v_temf(i,k)
+            TEUPD(i,k) = tval(i) * TEUPD(i,k) + (1-tval(i)) * te_temfx(i,k)
+            if (zm(i,k) > ht(i)) then  ! WA this is just for cleanliness
+               wupd_temfx(i,k) = 0.
+               dwUPDmoistdz(i,k) = 0.
+               wupd_dry(i,k) = 0.
+               dwUPDdz(i,k) = 0.
+            end if
+         end do
+
+         ! Calculate lateral detrainment rate for cloud layer
+         deltmf(i,1) = Cepsmf
+         do k = 2,kte-1
+            if (hctidx(i) > hdidx(i)+1) then      ! Some cloud
+               deltmf(i,k) = 0.9 * Cepsmf + Cdelt * (atan((zm(i,k)-(lcl(i)+(hct(i)-lcl(i))/1.5))/((hct(i)-lcl(i))/8))+(3.1415926/2))/3.1415926
+            else if (k < hdidx(i)) then   ! No cloud, below hd
+               deltmf(i,k) = Cepsmf + 0.05 * 1. / (hd(i) - zm(i,k))
+            else if (k >= hdidx(i)) then    ! No cloud, above hd
+               deltmf(i,k) = deltmf(i,k-1)
+            end if
+         end do
+
+         ! Calculate mass flux (defined on turbulence levels)
+         mf_temfx(i,1) = CM * wstr(i)
+         do kt = 2,kte-1
+            dMdz(i,kt) = (epsmf(i,kt) - deltmf(i,kt)) * mf_temfx(i,kt-1) * dzt(i,kt)
+            mf_temfx(i,kt) = mf_temfx(i,kt-1) + dMdz(i,kt)
+         end do
+
+         ! WA 12/28/09 If mass flux component > diffusive 
+         ! component at second level,
+         ! reduce M to prevent a stable layer
+         MFCth(i,2) = mf_temfx(i,2) * (thup_temfx(i,2)-thetal(i,2) + thup_temfx(i,3)-thetal(i,3)) / 2.
+         if (MFCth(i,2) > Fz(i,2)) then
+            red_fact = Fz(i,2) / MFCth(i,2)
+            do kt = 1,kte
+               mf_temfx(i,kt) = mf_temfx(i,kt) * red_fact
+            end do
+         end if  ! Reduce M to prevent stable layer at second level
+
+         ! Calculate mass flux contributions to fluxes (defined on turb levels)
+         ! Use log interpolation at first level
+         MFCth(i,1) = mf_temfx(i,1) * (thup_temfx(i,1)-thetal(i,1) + (thup_temfx(i,2)-thetal(i,2) - (thup_temfx(i,1)-thetal(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
+         MFCq(i,1) = mf_temfx(i,1) * (qtup_temfx(i,1)-qt(i,1) + (qtup_temfx(i,2)-qt(i,2) - (qtup_temfx(i,1)-qt(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
+         MFCu(i,1) = mf_temfx(i,1) * (UUPD(i,1)-u_temf(i,1) + (UUPD(i,2)-u_temf(i,2) - (UUPD(i,1)-u_temf(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
+         MFCv(i,1) = mf_temfx(i,1) * (VUPD(i,1)-v_temf(i,1) + (VUPD(i,2)-v_temf(i,2) - (VUPD(i,1)-v_temf(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
+         MFCql(i,1) = mf_temfx(i,1) * (qlUPD(i,1)-qcx(i,1) + (qlUPD(i,2)-qcx(i,2) - (qlUPD(i,1)-qcx(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
+         MFCTE(i,1) = mf_temfx(i,1) * (TEUPD(i,1)-te_temfx(i,1) + (TEUPD(i,2)-te_temfx(i,2) - (TEUPD(i,1)-te_temfx(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))  ! WA Check this
+         do kt = 2,kte-1
+            MFCth(i,kt) = mf_temfx(i,kt) * (thup_temfx(i,kt)-thetal(i,kt) + thup_temfx(i,kt+1)-thetal(i,kt+1)) / 2.
+            MFCq(i,kt) = mf_temfx(i,kt) * (qtup_temfx(i,kt)-qt(i,kt) + qtup_temfx(i,kt+1)-qt(i,kt+1)) / 2.
+            MFCu(i,kt) = mf_temfx(i,kt) * (UUPD(i,kt)-u_temf(i,kt) + UUPD(i,kt+1)-u_temf(i,kt+1)) / 2.
+            MFCv(i,kt) = mf_temfx(i,kt) * (VUPD(i,kt)-v_temf(i,kt) + VUPD(i,kt+1)-v_temf(i,kt+1)) / 2.
+            MFCql(i,kt) = mf_temfx(i,kt) * (qlUPD(i,kt)-qcx(i,kt-1) + qlUPD(i,kt+1)-qcx(i,kt)) / 2.
+            MFCTE(i,kt) = mf_temfx(i,kt) * (TEUPD(i,kt)-te_temfx(i,kt)) ! TE is on turb levels
+         end do
+         MFCth(i,kte) = 0
+         MFCq(i,kte) = 0
+         MFCu(i,kte) = 0
+         MFCv(i,kte) = 0
+         MFCql(i,kte) = 0
+         MFCTE(i,kte) = 0
+
+         ! Calculate cloud fraction (on mass levels)
+         cf3d_temfx(i,1) = 0.0
+         cfm_temfx(i) = 0.0
+         do k = 2,kte
+            ! if (wupd_temfx(i,k-1) >= 1.0e-15 .AND. wupd_temfx(i,k) >= 1.0e-15 .AND. .NOT. isnan(wupd_temfx(i,k-1)) .AND. .NOT. isnan(wupd_temfx(i,k))) then
+            if (wupd_temfx(i,k-1) >= 1.0e-15 .AND. wupd_temfx(i,k) >= 1.0e-15) then
+               au(i,k) = ((mf_temfx(i,k-1)+mf_temfx(i,k))/2.0) / ((wupd_temfx(i,k-1)+wupd_temfx(i,k))/2.0)  ! WA average before divide, is that best?
+            else
+               au(i,k) = 0.0
+            end if
+            sigq2 = au(i,k) * (qtup_temfx(i,k)-qt(i,k))
+            if (sigq2 > 0.0) then
+               sigq(i,k) = sqrt(sigq2)
+            else
+               sigq(i,k) = 0.0
+            end if
+            ! rst = rsat(p2d(i,k),thx(i,k)*pi2d(i,k),ep2)
+            rst = rsat(p2d(i,k-1),thx(i,k-1)*pi2d(i,k-1),ep2)
+            qst(i,k) = rst / (1. + rst)
+            satdef(i,k) = qt(i,k) - qst(i,k)
+            if (satdef(i,k) <= 0.0) then
+               if (sigq(i,k) > 1.0e-15) then
+                  cf3d_temfx(i,k) = max(0.5 + 0.36 * atan(1.55*(satdef(i,k)/sigq(i,k))),0.0)
+               else
+                  cf3d_temfx(i,k) = 0.0
+               end if
+            else
+               cf3d_temfx(i,k) = 1.0
+            end if
+            if (zm(i,k) < lcl(i)) then
+               cf3d_temfx(i,k) = 0.0
+            end if
+            ! Put max value so far into cfm
+            if (zt(i,k) <= hmax) then
+               cfm_temfx(i) = max(cf3d_temfx(i,k),cfm_temfx(i))
+            end if
+         end do
+
+      else    ! not is_convective, no MF components
+         do kt = 1,kte
+            MFCth(i,kt) = 0
+            MFCq(i,kt) = 0
+            MFCu(i,kt) = 0
+            MFCv(i,kt) = 0
+            MFCql(i,kt) = 0
+            MFCTE(i,kt) = 0
+         end do
+         lcl(i) = zm(i,kte-1)
+         hct(i) = zm(i,1)
+         hctidx(i) = 1
+         hd(i) = zm(i,1)
+         hdidx(i) = 1
+         ht(i) = hd(i)
+         ! Cloud fraction calculations
+         cf3d_temfx(i,1) = 0.0
+         cfm_temfx(i) = 0.0
+         do k = 2,kte
+            if (qcx(i,k-1) > 1.0e-15) then
+               cf3d_temfx(i,k) = 1.0
+            else
+               cf3d_temfx(i,k) = 0.0
+            end if
+            ! Put max value so far into cfm
+            if (zt(i,k) <= hmax) then
+               cfm_temfx(i) = max(cf3d_temfx(i,k),cfm_temfx(i))
+            end if
+         end do
+
+      end if   ! MF components or not
+      cf3d_temfx(i,kte) = 0.0
+      ! Mass flux block ends here
+
+      ! Flux profiles
+      do kt = 2,kte
+         ! Fz(i,kt) = -kh(i,kt) * dthdz(i,kt)
+         shf_temfx(i,kt) = Fz(i,kt) + MFCth(i,kt)
+         QFK(i,kt) = -kh(i,kt) * dqtdz(i,kt)
+         qf_temfx(i,kt) = QFK(i,kt) + MFCq(i,kt)
+         uwk(i,kt) = -km(i,kt) * dudz(i,kt)
+         uw_temfx(i,kt) = uwk(i,kt) + MFCu(i,kt)
+         vwk(i,kt) = -km(i,kt) * dvdz(i,kt)
+         vw_temfx(i,kt) = vwk(i,kt) + MFCv(i,kt)
+      end do
+
+      ! Surface momentum fluxes
+      ust(i) = sqrt(ftau(i,1)/ftau0) * sqrt(u_temf(i,2)**2. + v_temf(i,2)**2.) * leps(i,1) / log(zm(i,2)/znt(i)) / zt(i,1)
+      ang(i) = atan2(v_temf(i,2),u_temf(i,2))
+      uw_temfx(i,1) = -cos(ang(i)) * ust(i)**2.
+      vw_temfx(i,1) = -sin(ang(i)) * ust(i)**2.
+
+      ! Calculate mixed scaling velocity (Moeng & Sullivan 1994 JAS p.1021)
+      ! Replaces ust everywhere (WA need to reconsider?)
+      ! wm(i) = (1./5. * (wstr(i)**3. + 5. * ust(i)**3.)) ** (1./3.) 
+      ! WA TEST (R2,R11) 7/23/10 reduce velocity scale to fix excessive fluxes
+      wm(i) = 0.5 * (1./5. * (wstr(i)**3. + 5. * ust(i)**3.)) ** (1./3.) 
+      ! WA TEST 2/14/11 limit contribution of w*
+      ! wm(i) = 0.5 * (1./5. * (min(0.8,wstr(i))**3. + 5. * ust(i)**3.)) ** (1./3.) 
+      ! WA TEST (R3-R11) 7/23/10 wm = u*
+      ! wm(i) = ust(i)
+
+      ! Specified flux versions (flux is modified by land surface)
+      shf_temfx(i,1) = hfx(i)/(rho(i,1)*cp) + (shf_temfx(i,2) - hfx(i)/(rho(i,1)*cp)) * (zt(i,2)-zt(i,1)) / (zt(i,2)-znt(i))
+      qf_temfx(i,1) = qfx(i)/rho(i,1) + (qf_temfx(i,2)-qfx(i)/rho(i,1)) * (zt(i,2)-zt(i,1)) / (zt(i,2)-znt(i))
+      Fz(i,1) = shf_temfx(i,1) - MFCth(i,1)
+      QFK(i,1) = qf_temfx(i,1) - MFCq(i,1)
+
+
+      ! Calculate thetav and its flux
+      ! From Lewellen 2004 eq. 3
+      ! WA The constants and combinations below should probably be replaced
+      ! by something more consistent with the WRF system, but for now
+      ! I don't want to take the chance of breaking something.
+      do kt = 2,kte-1
+         alpha2(i,kt) = 0.61 * (thetal(i,kt) + thetal(i,kt+1)) / 2.
+         beta2(i,kt) = (100000. / p2di(i,kt))**0.286 * 2.45e-6 / 1004.67 - 1.61 * (thetal(i,kt) + thetal(i,kt+1)) / 2.
+      end do
+      alpha2(i,1) = 0.61 * (thetal(i,1) + (thetal(i,2)-thetal(i,1)) * (zt(i,2) - znt(i)) / (zm(i,2) - znt(i)))
+      alpha2(i,kte) = 0.61 * thetal(i,kte)
+      beta2(i,1) = (100000. / p2di(i,1))**0.286 * 2.45e-6 / 1004.67 - 1.61 * (thetal(i,1) + (thetal(i,2) - thetal(i,1))  * (zt(i,2) - znt(i)) / (zm(i,2) - znt(i)))
+      beta2(i,kte) = (100000. / p2di(i,kte))**0.286 * 2.45e-6 / 1004.67 - 1.61 * thetal(i,kte)
+      if ( is_convective ) then ! Activate EDMF components
+         do kt = 1,kte-1
+            MFCthv(i,kt) = (1. + 0.61 * (qtup_temfx(i,kt)+qtup_temfx(i,kt+1))) / 2. * MFCth(i,kt) + alpha2(i,kt) * MFCq(i,kt) + beta2(i,kt) * MFCql(i,kt)
+         end do
+         MFCthv(i,kte) = 0.
+      else    ! No MF components
+         do kt = 1,kte
+            MFCthv(i,kt) = 0.
+         end do
+      end if
+
+      do kt = 1,kte
+         THVF(i,kt) = (1. + 0.61 * qt(i,kt)) * Fz(i,kt) + alpha2(i,kt) * QFK(i,kt) + MFCthv(i,kt)
+      end do
+
+      ! Update mean variables:
+      ! This is done with implicit solver for diffusion part followed
+      ! by explicit solution for MF terms.
+      ! Note that Coriolis terms that were source terms for u and v
+      ! in Matlab code are now handled by WRF outside this PBL context.
+
+      u_new(i,:) = u_temf(i,:)
+      call solve_implicit_temf(km(i,kts:kte-1),u_new(i,kts+1:kte),uw_temfx(i,1),dzm(i,kts:kte-1),dzt(i,kts:kte-1),kts,kte-1,dt,.FALSE.)
+      do k = 2,kte-1
+         u_new(i,k) = u_new(i,k) + dt * (-(MFCu(i,k)-MFCu(i,k-1))) / dzm(i,k)
+      end do
+
+      v_new(i,:) = v_temf(i,:)
+      call solve_implicit_temf(km(i,kts:kte-1),v_new(i,kts+1:kte),vw_temfx(i,1),dzm(i,kts:kte-1),dzt(i,kts:kte-1),kts,kte-1,dt,.FALSE.)
+      do k = 2,kte-1
+         v_new(i,k) = v_new(i,k) + dt * (-(MFCv(i,k)-MFCv(i,k-1))) / dzm(i,k)
+      end do
+
+      call solve_implicit_temf(kh(i,kts:kte-1),thetal(i,kts+1:kte),Fz(i,1),dzm(i,kts:kte-1),dzt(i,kts:kte-1),kts,kte-1,dt,.FALSE.)
+      do k = 2,kte-1
+         thetal(i,k) = thetal(i,k) + dt * (-(MFCth(i,k)-MFCth(i,k-1))) / dzm(i,k)
+      end do
+
+      call solve_implicit_temf(kh(i,kts:kte-1),qt(i,kts+1:kte),QFK(i,1),dzm(i,kts:kte-1),dzt(i,kts:kte-1),kts,kte-1,dt,.FALSE.)
+      do k = 2,kte-1
+         qt(i,k) = qt(i,k) + dt * (-(MFCq(i,k)-MFCq(i,k-1))) / dzm(i,k)
+      end do
+
+      ! Stepping TE forward is a bit more complicated
+      te_temfx(i,1) = ust(i)**2. / ftau(i,1) * (1. + ratio(i,1))
+      if ( is_convective ) then
+         ! WA currently disabled if MFopt=false, is that right?
+         convection_TKE_surface_src(i) = 2. * beta(i,1) * shf_temfx(i,1)
+      else
+         convection_TKE_surface_src(i) = 0.
+      end if
+      te_temfx(i,1) = max(te_temfx(i,1), (leps(i,1) / Cgamma * (ust(i)**2. * S(i,1) + convection_TKE_surface_src(i)))**(2./3.))
+      sfcFTE(i) = -(km(i,1)+km(i,2)) / 2. * (te_temfx(i,2)-te_temfx(i,1)) / dzm(i,2)
+
+      do kt = 1,kte
+         if (THVF(i,kt) >= 0) then
+            buoy_src(i,kt) = 2. * g / thetav(i,kt) * THVF(i,kt)
+         else
+            buoy_src(i,kt) = 0.  ! Cancel buoyancy term when locally stable
+         end if
+         srcs(i,kt) = -uw_temfx(i,kt) * dudz(i,kt) - vw_temfx(i,kt) * dvdz(i,kt) - Cgamma * te_temfx(i,kt)**1.5 * linv(i,kt) + buoy_src(i,kt)
+      end do
+      call solve_implicit_temf((km(i,kts:kte-1)+km(i,kts+1:kte))/2.0,te_temfx(i,kts+1:kte),sfcFTE(i),dzt(i,kts+1:kte),dzt(i,kts:kte-1),kts,kte-1,dt,.false.)
+      do kt = 2,kte-1
+         te_temfx(i,kt) = te_temfx(i,kt) + dt * srcs(i,kt)
+         te_temfx(i,kt) = te_temfx(i,kt) + dt * (-(MFCTE(i,kt)-MFCTE(i,kt-1))) / dzt(i,kt)
+         if (te_temfx(i,kt) < TEmin) te_temfx(i,kt) = TEmin
+      end do
+      te_temfx(i,kte) = 0.0   ! WA 4/2/10
+      do kt = 2,kte-1
+         if (te_temfx(i,kt) > 30.0) then      ! WA DEBUG
+            te_temfx(i,kt) = 30.0    ! WA TEST limit max TE
+         end if
+      end do
+
+      ! Done with updates, now convert internal variables back to WRF vars
+      do k = kts,kte
+         ! Populate kh_temfx, km_temfx from kh, km
+         kh_temfx(i,k) = kh(i,k)
+         km_temfx(i,k) = km(i,k)
+      end do
+
+      ! Convert thetal, qt back to theta, qv, qc
+      ! See opposite conversion at top of subroutine
+      ! WA this accounts for offset of indexing between
+      ! WRF and TEMF, see notes at top of this routine.
+      call thlqt2thqvqc(thetal(i,kts+1:kte),qt(i,kts+1:kte),thx_new(i,kts:kte-1),qvx_new(i,kts:kte-1),qcx_new(i,kts:kte-1),p2d(i,kts:kte-1),pi2d(i,kts:kte-1),kts,kte-1,ep2,xlv,cp)
+
+      do k = kts,kte-1
+         ! Calculate tendency terms
+         ! WA this accounts for offset of indexing between
+         ! WRF and TEMF, see notes at top of this routine.
+         rubltenx(i,k) = (u_new(i,k+1) - u_temf(i,k+1)) / dt
+         rvbltenx(i,k) = (v_new(i,k+1) - v_temf(i,k+1)) / dt
+         rthbltenx(i,k) = (thx_new(i,k) - thx(i,k)) / dt
+         rqvbltenx(i,k) = (qvx_new(i,k) - qvx(i,k)) / dt
+         rqcbltenx(i,k) = (qcx_new(i,k) - qcx(i,k)) / dt
+      end do
+      rubltenx(i,kte) = 0.
+      rvbltenx(i,kte) = 0.
+      rthbltenx(i,kte) = 0.
+      rqvbltenx(i,kte) = 0.
+      rqcbltenx(i,kte) = 0.
+
+      ! Populate surface exchange coefficient variables to go back out
+      ! for next time step of surface scheme
+      ! Unit specifications in SLAB and sfclay are conflicting and probably
+      ! incorrect.  This will give a dynamic heat flux (W/m^2) or moisture
+      ! flux (kg(water)/(m^2*s)) when multiplied by a difference.
+      ! These formulae are the same as what's used above to get surface
+      ! flux from surface temperature and specific humidity.
+      ! WA 2/16/11 removed, not needed in BL
+      ! flhc(i) = rho(i,1) * cp * fth(i,1)/fth0 * wm(i) * leps(i,1) / PrT0 / log(zm(i,2)/z0t(i)) / zt(i,1)
+      ! flqc(i)  = rho(i,1) * fth(i,1)/fth0 * wm(i) * leps(i,1) / PrT0 / log(zm(i,2)/z0t(i)) / zt(i,1)
+      ! WA Must exchange coeffs be limited to avoid runaway in some 
+      ! (convective?) conditions?  Something like this is done in sfclay.
+      ! Doing nothing for now.
+
+      ! Populate 10 m winds and 2 m temp
+      ! WA Note this only works if first mass level is above 10 m
+      u10(i) = u_new(i,2) * log(10.0/znt(i)) / log(zm(i,2)/znt(i))
+      v10(i) = v_new(i,2) * log(10.0/znt(i)) / log(zm(i,2)/znt(i))
+      t2(i) = (tsk(i)/pi2d(i,1) + (thx_new(i,1) - tsk(i)/pi2d(i,1)) * log(2.0/z0t(i)) / log(zm(i,2)/z0t(i))) * pi2d(i,1)  ! WA this should also use pi at z0
+
+      ! Populate diagnostic variables
+      hd_temfx(i) = hd(i)
+      lcl_temfx(i) = lcl(i)
+      hct_temfx(i) = hct(i)
+
+      ! Send updraft liquid water back
+      if ( is_convective) then
+         do k = kts,kte-1
+            qlup_temfx(i,k) = qlUPD(i,k)
+         end do
+      else
+         qlup_temfx(i,1) = qcx(i,1)
+         do k = kts+1,kte-1
+            qlup_temfx(i,k) = qcx(i,k-1)
+         end do
+      end if
+      qlup_temfx(i,kte) = qcx(i,kte)
+
+   end do  ! Main (i) loop
+
+   end subroutine temf2d
+!
+!--------------------------------------------------------------------
+!
+   subroutine thlqt2thqvqc(thetal,qt,theta,qv,qc,p,piex,kbot,ktop,ep2,Lv,Cp)
+
+!  Calculates theta, qv, qc from thetal, qt.
+!  Originally from RAMS (subroutine satadjst) by way of Hongli Jiang.
+
+   implicit none
+   integer, intent(in   ) :: kbot, ktop
+   real,    dimension( kbot:ktop ), intent(in   ) :: thetal, qt
+   real,    dimension( kbot:ktop ), intent(  out) :: theta, qv, qc
+   real,    dimension( kbot:ktop ), intent(in   ) :: p, piex
+   real,    intent(in   ) :: ep2, Lv, Cp
+!
+!  Local variables
+   integer :: k, iterate
+   real :: T1, Tt
+   real, dimension( kbot:ktop) :: rst
+   real, dimension( kbot:ktop) :: Tair, rc, rt, rv
+!
+   do k = kbot,ktop
+      T1 = thetal(k) * piex(k)   ! First guess T is just thetal converted to T
+      Tair(k) = T1
+      rt(k) = qt(k) / (1. - qt(k))
+
+      do iterate = 1,20
+         rst(k) = rsat(p(k),Tair(k),ep2)
+         rc(k) = max(rt(k) - rst(k), 0.)
+         Tt = 0.7*Tair(k) + 0.3*T1 * (1.+Lv*rc(k) / (Cp*max(Tair(k),253.)))
+         if ( abs(Tt - Tair(k)) < 0.001) GOTO 100
+         Tair(k) = Tt
+      end do
+100   continue
+      rv(k) = rt(k) - rc(k)
+      qv(k) = rv(k) / (1. + rv(k))
+      qc(k) = rc(k) / (1. + rc(k))
+      theta(k) = Tair(k) / piex(k)
+   end do ! k loop
+   return
+   end subroutine thlqt2thqvqc
+!
+!--------------------------------------------------------------------
+!
+   subroutine findhct_te( thetavenv,thetaparin,qpar, &
+                          rpar,hdidx,paridx,zm,hct,hctidx,p,piex,ep2,kbot,ktop)
+
+! Calculates the cloud top height (limit of convection) for the
+! updraft properties.  hct is the level at which a parcel lifted
+! at the moist adiabatic rate where it is saturated and at the dry
+! adiabatic rate otherwise, first has thetav cooler than the environment.
+! Loops start at LCL (paridx).
+
+   implicit none
+   integer, intent(in) :: kbot, ktop
+   integer, intent(in) :: paridx, hdidx
+   real, intent(in)    :: ep2
+   real, dimension( kbot:ktop), intent(in) :: thetavenv
+   real, dimension( kbot:ktop), intent(in) :: thetaparin
+   real, dimension( kbot:ktop), intent(in) :: qpar, rpar, zm, p, piex
+   real, intent(out)    :: hct
+   integer, intent(out) :: hctidx
+! Local variables
+   integer k
+   real, dimension( kbot:ktop) :: thetapar, thetavpar, qlpar, Tpar, rsatpar
+   real, dimension( kbot:ktop) :: qsatpar
+   real :: gammas, TparC
+
+   thetapar(paridx) = thetaparin(paridx)
+   Tpar(paridx) = thetapar(paridx) * piex(paridx)
+   hctidx = ktop   ! In case hct not found
+   do k = paridx+1,ktop
+      ! Find saturation mixing ratio at parcel temperature
+      rsatpar(k) = rsat(p(k-1),Tpar(k-1),ep2)
+      qsatpar(k) = rsatpar(k) / (1. + rsatpar(k))
+
+      ! When parcel is unsaturated, its temperature changes 
+      ! at dry adiabatic rate (in other words, theta is constant).
+      if (rpar(k) <= rsatpar(k)) then
+         thetapar(k) = thetapar(k-1)
+         Tpar(k) = thetapar(k) * piex(k)
+         thetavpar(k) = thetapar(k) * (1.+0.608*qpar(k))
+      else
+         ! When parcel is saturated, its temperature changes at
+         ! moist adiabatic rate
+         ! Calculate moist adiabatic lapse rate according to Gill A4.12
+         ! Requires T in deg.C
+         TparC = Tpar(k-1) - 273.15
+         gammas = 6.4 - 0.12 * TparC + 2.5e-5 * TparC**3. + (-2.4 + 1.e-3 * (TparC-5.)**2.) * (1. - p(k-1)/100000.)
+         Tpar(k) = Tpar(k-1) - gammas/1000. * (zm(k)-zm(k-1))
+         thetapar(k) = Tpar(k) / piex(k)
+         qlpar(k) = qpar(k) - qsatpar(k)  ! Liquid water in parcel
+         thetavpar(k) = thetapar(k) * (1. + 0.608 * qsatpar(k) - qlpar(k))
+      end if
+      if (thetavenv(k) >= thetavpar(k)) then
+         hctidx = k
+         goto 1000
+      end if
+   end do
+1000  hct = zm(hctidx)
+   return
+   end subroutine findhct_te
+!
+!--------------------------------------------------------------------
+!
+   real function rsat(p,T,ep2)
+
+!  Calculates the saturation mixing ratio with respect to liquid water
+!  Arguments are pressure (Pa) and absolute temperature (K)
+!  Uses the formula from the ARM intercomparison setup.
+!  Converted from Matlab by WA 7/28/08
+
+implicit none
+real p, T, ep2
+real temp, x
+real, parameter :: c0 = 0.6105851e+3
+real, parameter :: c1 = 0.4440316e+2
+real, parameter :: c2 = 0.1430341e+1
+real, parameter :: c3 = 0.2641412e-1
+real, parameter :: c4 = 0.2995057e-3
+real, parameter :: c5 = 0.2031998e-5
+real, parameter :: c6 = 0.6936113e-8
+real, parameter :: c7 = 0.2564861e-11
+real, parameter :: c8 = -0.3704404e-13
+
+temp = T - 273.15
+
+x =c0+temp*(c1+temp*(c2+temp*(c3+temp*(c4+temp*(c5+temp*(c6+temp*(c7+temp*c8)))))))
+rsat = ep2*x/(p-x)
+
+return
+end function rsat
+!
+!--------------------------------------------------------------------
+!
+   subroutine solve_implicit_temf(Khlf,psi_n,srf_flux,dzm,dzt,kbot,ktop,dt,print_flag)
+
+!  Implicit solution of vertical diffusion for conserved variable
+!  psi given diffusivity Khlf on turbulence levels,
+!  and surface flux srf_flux.
+!  dzm is delta_z of mass levels, dzt is delta_z of turbulence levels.
+!  dt is timestep (s).
+
+   implicit none
+   integer  :: kbot, ktop
+   logical  :: print_flag
+   real :: srf_flux, dt
+   real,    dimension( kbot:ktop ), intent(in   ) :: Khlf
+   real,    dimension( kbot:ktop ), intent(in   ) :: dzm, dzt
+   real,    dimension( kbot:ktop ), intent(inout) :: psi_n
+!
+!  Local variables
+   integer :: k
+   real,    dimension( kbot:ktop ) :: AU, BU, CU, YU
+!
+   AU(kbot) = Khlf(kbot) / (dzm(kbot)*dzt(kbot))
+   BU(kbot) = -1.0/dt - Khlf(kbot+1)/(dzm(kbot+1)*dzt(kbot+1))
+   CU(kbot) = Khlf(kbot+1)/(dzm(kbot)*dzt(kbot+1))
+   YU(kbot) = -psi_n(kbot)/dt - srf_flux/dzm(kbot)
+
+   do k = kbot+1,ktop-1
+      ! Subdiagonal (A) vector
+      AU(k) = Khlf(k) / (dzm(k) * dzt(k))
+      ! Main diagonal (B) vector
+      BU(k) = -1.0/dt - (Khlf(k)/dzt(k) + Khlf(k+1)/dzt(k+1)) / dzm(k)
+      ! Superdiagonal (C) vector
+      CU(k) = Khlf(k+1) / (dzm(k)*dzt(k+1))
+      ! Result vector
+      YU(k) = -psi_n(k)/dt
+   end do ! k loop
+
+   AU(ktop) = 0.
+   BU(ktop) = -1.0 / dt
+   YU(ktop) = -psi_n(ktop) / dt
+
+   ! Compute result with tridiagonal routine
+   psi_n = trid(AU,BU,CU,YU,kbot,ktop)
+
+   return
+   end subroutine solve_implicit_temf
+!
+!--------------------------------------------------------------------
+!
+   function trid(a,b,c,r,kbot,ktop)
+
+!  Solves tridiagonal linear system.
+!  Inputs are subdiagonal vector a, main diagonal b, superdiagonal c,
+!  result r, column top and bottom indices kbot and ktop.
+!  Originally from Numerical Recipes section 2.4.
+
+   implicit none
+   real,    dimension( kbot:ktop ) :: trid
+   integer  :: kbot, ktop
+   real,    dimension( kbot:ktop ), intent(in   ) :: a, b, c, r
+!
+!  Local variables
+   integer :: k
+   real    :: bet
+   real,    dimension( kbot:ktop ) :: gam, u
+!
+   bet = b(kbot)
+   u(kbot) = r(kbot) / bet
+
+   do k = kbot+1,ktop
+      gam(k) = c(k-1) / bet
+      bet = b(k) - a(k)*gam(k)
+      u(k) = (r(k) - a(k)*u(k-1)) / bet
+   end do
+
+   do k = ktop-1,kbot,-1
+      u(k) = u(k) - gam(k+1)*u(k+1)
+   end do
+
+   trid = u
+
+   return
+   end function trid
+!
+!--------------------------------------------------------------------
+!
+   subroutine temfinit(rublten,rvblten,rthblten,rqvblten,                      &
+                      rqcblten,rqiblten,p_qi,p_first_scalar,                   &
+                      restart, allowed_to_read,                                &
+                      te_temf, cf3d_temf,                                     &
+                      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, &
+                                                                     te_temf, &
+                                                                     cf3d_temf
+! Local variables
+   integer :: i, j, k, itf, jtf, ktf
+   real, parameter :: TEmin = 1e-3
+!
+   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.
+        te_temf(i,k,j) = TEmin
+        cf3d_temf(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 temfinit
+!-------------------------------------------------------------------
+end module module_bl_temf
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_ysu.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_ysu.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_bl_ysu.F	(revision 17)
@@ -0,0 +1,1404 @@
+!WRf:model_layer:physics
+!
+!
+!
+!
+!
+!
+!
+module module_bl_ysu
+contains
+!
+!
+!-------------------------------------------------------------------
+!
+   subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,               &
+                  rublten,rvblten,rthblten,                                    &
+                  rqvblten,rqcblten,rqiblten,flag_qi,                          &
+                  cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv,                    &
+                  dz8w,psfc,                                                   &
+                  znu,znw,mut,p_top,                                           &
+                  znt,ust,hpbl,psim,psih,                                      &
+                  xland,hfx,qfx,gz1oz0,wspd,br,                                &
+                  dt,kpbl2d,                                                   &
+                  exch_h,                                                      &
+                  u10,v10,                                                     &
+                  ids,ide, jds,jde, kds,kde,                                   &
+                  ims,ime, jms,jme, kms,kme,                                   &
+                  its,ite, jts,jte, kts,kte,                                   &
+                !optional
+                  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)
+!               (note: if P_QI<PARAM_FIRST_SCALAR this should be zero filled)
+!-- p3d         3d pressure (pa)
+!-- p3di        3d pressure (pa) at interface level
+!-- pi3d	3d exner function (dimensionless)
+!-- rr3d	3d dry air density (kg/m^3)
+!-- rublten     u tendency due to
+!               pbl parameterization (m/s/s)
+!-- rvblten     v tendency due to
+!               pbl parameterization (m/s/s)
+!-- 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
+!-- rd          gas constant for dry air (j/kg/k)
+!-- rovg 	r/g
+!-- dz8w	dz between full levels (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)
+!-- hpbl	pbl height (m)
+!-- 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)
+!-- gz1oz0      log(z/z0) where z0 is roughness length
+!-- wspd        wind speed at lowest model level (m/s)
+!-- u10         u-wind speed at 10 m (m/s)
+!-- v10         v-wind speed at 10 m (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)
+!-- ep2         constant for specific humidity calculation
+!-- 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,parameter ::  ndiff = 3
+   real,parameter    ::  rcl = 1.0
+!
+   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,cp,g,rovcp,rovg,rd,xlv,rv
+!
+   real,     intent(in )     ::      ep1,ep2,karman
+!
+   real,     dimension( ims:ime, kms:kme, jms:jme )                          , &
+             intent(in   )   ::                                          qv3d, &
+                                         			         qc3d, &
+ 				                                         qi3d, &
+                                   		                          p3d, &
+            		                                                 pi3d, &
+		                      	                                 th3d, &
+		                                		          t3d, &
+				                                         dz8w
+   real,     dimension( ims:ime, kms:kme, jms:jme )                          , &
+             intent(in   )   ::                                          p3di
+!
+   real,     dimension( ims:ime, kms:kme, jms:jme )                          , &
+             intent(inout)   ::                                       rublten, &
+                                              			      rvblten, &
+                                               			     rthblten, &
+                                                 	             rqvblten, &
+                                                                     rqcblten
+!
+   real,     dimension( ims:ime, kms:kme, jms:jme )                          , &
+             intent(inout)   ::                                        exch_h
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             intent(in   )   ::                                           u10, &
+                                                                          v10
+!
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             intent(in   )   ::                                         xland, &
+     			                                                  hfx, &
+                                                                          qfx, &
+                                                                           br, &
+                                                                         psfc
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             intent(in   )   ::                                                &
+                                                                         psim, &
+                                                                         psih, &
+                                                                       gz1oz0
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             intent(inout)   ::                                           znt, &
+                                                                          ust, &
+                                                                         hpbl, &
+                                                                          wspd
+!
+  real,      dimension( ims:ime, kms:kme, jms:jme )                          , &
+             intent(in   )   ::                                           u3d, &
+                                                                          v3d
+!
+  integer,   dimension( ims:ime, jms:jme )                                   , &
+             intent(out  )   ::                                        kpbl2d
+  logical, intent(in)        ::                                       flag_qi
+!optional
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             optional                                                        , &
+             intent(inout)   ::                                        regime
+!
+   real,     dimension( ims:ime, kms:kme, jms:jme )                          , &
+             optional                                                        , &
+             intent(inout)   ::                                       rqiblten
+!
+   real,     dimension( kms:kme )                                            , &
+             optional                                                        , &
+             intent(in   )   ::                                           znu, &
+                                                                          znw
+!
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             optional                                                        , &
+             intent(in   )   ::                                           mut
+!
+   real,     optional, intent(in   )   ::                               p_top
+!
+!local
+   integer ::  i,j,k
+   real,     dimension( its:ite, kts:kte*ndiff )  ::                 rqvbl2dt, &
+                                                                         qv2d
+   real,     dimension( its:ite, kts:kte )  ::                            pdh
+   real,     dimension( its:ite, kts:kte+1 )  ::                         pdhi
+   real,     dimension( its:ite )  ::                                          &
+                                                                        dusfc, &
+                                                                        dvsfc, &
+                                                                        dtsfc, &
+                                                                        dqsfc
+!
+   qv2d(:,:) = 0.0
+   do j = jts,jte
+      if(present(mut))then
+! For ARW we will replace p and p8w with dry hydrostatic pressure
+        do k = kts,kte+1
+          do i = its,ite
+             if(k.le.kte)pdh(i,k) = mut(i,j)*znu(k) + p_top
+             pdhi(i,k) = mut(i,j)*znw(k) + p_top
+          enddo
+        enddo
+      else
+        do k = kts,kte+1
+          do i = its,ite
+             if(k.le.kte)pdh(i,k) = p3d(i,k,j)
+             pdhi(i,k) = p3di(i,k,j)
+          enddo
+        enddo
+      endif
+      do k = kts,kte
+        do i = its,ite
+          qv2d(i,k) = qv3d(i,k,j)
+          qv2d(i,k+kte) = qc3d(i,k,j)
+          if(present(rqiblten)) qv2d(i,k+kte+kte) = qi3d(i,k,j)
+        enddo
+      enddo
+!
+      call ysu2d(J=j,ux=u3d(ims,kms,j),vx=v3d(ims,kms,j)                       &
+              ,tx=t3d(ims,kms,j)                                               &
+              ,qx=qv2d(its,kts)                                                &
+              ,p2d=pdh(its,kts),p2di=pdhi(its,kts)                             &
+              ,pi2d=pi3d(ims,kms,j)                                            &
+              ,utnp=rublten(ims,kms,j),vtnp=rvblten(ims,kms,j)                 &
+              ,ttnp=rthblten(ims,kms,j),qtnp=rqvbl2dt(its,kts),ndiff=ndiff     &
+              ,cp=cp,g=g,rovcp=rovcp,rd=rd,rovg=rovg                           &
+              ,xlv=xlv,rv=rv                                                   &
+              ,ep1=ep1,ep2=ep2,karman=karman                                   &
+              ,dz8w2d=dz8w(ims,kms,j)                                          &
+              ,psfcpa=psfc(ims,j),znt=znt(ims,j),ust=ust(ims,j)                &
+              ,hpbl=hpbl(ims,j)                                                &
+              ,regime=regime(ims,j),psim=psim(ims,j)                           &
+              ,psih=psih(ims,j),xland=xland(ims,j)                             &
+              ,hfx=hfx(ims,j),qfx=qfx(ims,j)                                   &
+              ,wspd=wspd(ims,j),br=br(ims,j)                                   &
+              ,dusfc=dusfc,dvsfc=dvsfc,dtsfc=dtsfc,dqsfc=dqsfc                 &
+              ,dt=dt,rcl=1.0,kpbl1d=kpbl2d(ims,j)                              &
+              ,exch_hx=exch_h(ims,kms,j)                                       &
+              ,u10=u10(ims,j),v10=v10(ims,j)                                   &
+              ,gz1oz0=gz1oz0(ims,j)                                            &
+              ,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   )
+!
+      do k = kts,kte
+        do i = its,ite
+          rthblten(i,k,j) = rthblten(i,k,j)/pi3d(i,k,j)
+          rqvblten(i,k,j) = rqvbl2dt(i,k)
+          rqcblten(i,k,j) = rqvbl2dt(i,k+kte)
+          if(present(rqiblten)) rqiblten(i,k,j) = rqvbl2dt(i,k+kte+kte)
+        enddo
+      enddo
+   enddo
+!
+   end subroutine ysu
+!
+!-------------------------------------------------------------------
+!
+   subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d,                               &
+                  utnp,vtnp,ttnp,qtnp,ndiff,                                   &
+                  cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv,                    &
+                  dz8w2d,psfcpa,                                               &
+                  znt,ust,hpbl,psim,psih,                                      &
+                  xland,hfx,qfx,wspd,br,                                       &
+                  dusfc,dvsfc,dtsfc,dqsfc,                                     &
+                  dt,rcl,kpbl1d,                                               &
+                  exch_hx,                                                     &
+                  u10,v10,                                                     &
+                  gz1oz0,                                                      &
+                  ids,ide, jds,jde, kds,kde,                                   &
+                  ims,ime, jms,jme, kms,kme,                                   &
+                  its,ite, jts,jte, kts,kte,                                   &
+                !optional
+                  regime                                           )
+!-------------------------------------------------------------------
+   implicit none
+!-------------------------------------------------------------------
+!
+!     this code is a revised vertical diffusion package ("ysupbl")
+!     with a nonlocal turbulent mixing in the pbl after "mrfpbl".
+!     the ysupbl (hong et al. 2006) is based on the study of noh 
+!     et al.(2003) and accumulated realism of the behavior of the 
+!     troen and mahrt (1986) concept implemented by hong and pan(1996). 
+!     the major ingredient of the ysupbl is the inclusion of an explicit
+!     treatment of the entrainment processes at the entrainment layer.
+!     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.
+!
+!     mrfpbl:
+!     coded by song-you hong (ncep), implemented by jimy dudhia (ncar)
+!              fall 1996
+!
+!     ysupbl:
+!     coded by song-you hong (yonsei university) and implemented by
+!              song-you hong (yonsei university) and jimy dudhia (ncar)
+!              summer 2002
+!
+!     further modifications :
+!              an enhanced stable layer mixing, april 2008
+!               ==> increase pbl height when sfc is stable (hong 2010)
+!              pressure-level diffusion, april 2009
+!               ==> negligible differences
+!              implicit forcing for momentum with clean up, july 2009
+!               ==> prevents model blowup when sfc layer is too low
+!              increase of lamda, 30 < 0.1 x del z < 300, feb 2010
+!               ==> prevents model blowup when delz is extremely large
+!              revised prandtl number at surface, peggy lemone, feb 2010
+!               ==> increase kh, decrease mixing due to counter-gradient term
+!
+!     references:
+!
+!        hong (2010) quart. j. roy. met. soc
+!        hong, noh, and dudhia (2006), mon. wea. rev. 
+!        hong and pan (1996), mon. wea. rev.
+!        noh, chun, hong, and raasch (2003), boundary layer met.
+!        troen and mahrt (1986), boundary layer met.
+!
+!-------------------------------------------------------------------
+!
+   real,parameter    ::  xkzmin = 0.01,xkzmax = 1000.,rimin = -100.
+   real,parameter    ::  rlam = 30.,prmin = 0.25,prmax = 4.
+   real,parameter    ::  brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4
+   real,parameter    ::  afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0
+   real,parameter    ::  phifac = 8.,sfcfrac = 0.1
+   real,parameter    ::  d1 = 0.02, d2 = 0.05, d3 = 0.001
+   real,parameter    ::  h1 = 0.33333335, h2 = 0.6666667
+   real,parameter    ::  ckz = 0.001,zfmin = 1.e-8,aphi5 = 5.,aphi16 = 16.
+   real,parameter    ::  tmin=1.e-2
+   real,parameter    ::  gamcrt = 3.,gamcrq = 2.e-3
+   real,parameter    ::  xka = 2.4e-5
+   integer,parameter ::  imvdif = 1
+!
+   integer,  intent(in   )   ::     ids,ide, jds,jde, kds,kde,                 &
+                                    ims,ime, jms,jme, kms,kme,                 &
+                                    its,ite, jts,jte, kts,kte,                 &
+                                    j,ndiff
+!
+   real,     intent(in   )   ::     dt,rcl,cp,g,rovcp,rovg,rd,xlv,rv
+!
+   real,     intent(in )     ::     ep1,ep2,karman
+!
+   real,     dimension( ims:ime, kms:kme ),                                    &
+             intent(in)      ::                                        dz8w2d, &
+                                                                         pi2d
+!
+   real,     dimension( ims:ime, kms:kme )                                   , &
+             intent(in   )   ::                                            tx
+   real,     dimension( its:ite, kts:kte*ndiff )                             , &
+             intent(in   )   ::                                            qx
+!
+   real,     dimension( ims:ime, kms:kme )                                   , &
+             intent(inout)   ::                                          utnp, &
+                                                                         vtnp, &
+                                                                         ttnp
+   real,     dimension( its:ite, kts:kte*ndiff )                             , &
+             intent(inout)   ::                                          qtnp
+!
+   real,     dimension( its:ite, kts:kte+1 )                                 , &
+             intent(in   )   ::                                          p2di
+!
+   real,     dimension( its:ite, kts:kte )                                   , &
+             intent(in   )   ::                                           p2d
+!
+!
+   real,     dimension( ims:ime )                                            , &
+             intent(inout)   ::                                           ust, &
+                                                                         hpbl, &
+                                                                          znt
+   real,     dimension( ims:ime )                                            , &
+             intent(in   )   ::                                         xland, &
+                                                                          hfx, &
+                                                                          qfx
+!
+   real,     dimension( ims:ime ), intent(inout)   ::                    wspd
+   real,     dimension( ims:ime ), intent(in  )    ::                      br
+!
+   real,     dimension( ims:ime ), intent(in   )   ::                    psim, &
+                                                                         psih
+   real,     dimension( ims:ime ), intent(in   )   ::                  gz1oz0
+!
+   real,     dimension( ims:ime ), intent(in   )   ::                  psfcpa
+   integer,  dimension( ims:ime ), intent(out  )   ::                  kpbl1d
+!
+   real,     dimension( ims:ime, kms:kme )                                   , &
+             intent(in   )   ::                                            ux, &
+                                                                           vx
+!optional
+   real,     dimension( ims:ime )                                            , &
+             optional                                                        , &
+             intent(inout)   ::                                        regime
+!
+! local vars
+!
+   real,     dimension( its:ite )            ::                           hol
+   real,     dimension( its:ite, kts:kte+1 ) ::                            zq
+!
+   real,     dimension( its:ite, kts:kte )   ::                        	       &
+                                                                     thx,thvx, &
+                                                                          del, &
+                                                                          dza, &
+                                                                          dzq, &
+                                                                           za
+!
+   real,    dimension( its:ite )             ::                                &
+                                                                         rhox, &
+                                                                       govrth, &
+                                                                  zl1,thermal, &
+                                                                 wscale,hgamt, &
+                                                                   hgamq,brdn, &
+                                                                    brup,phim, &
+                                                                         phih, &
+                                                                  dusfc,dvsfc, &
+                                                                  dtsfc,dqsfc, &
+                                                                        prpbl, &
+                                                                        wspd1
+!
+   real,    dimension( its:ite, kts:kte )    ::                     xkzm,xkzh, &
+                                                     		        f1,f2, &
+                                                     		        r1,r2, &
+                                                                        ad,au, &
+                                                                           cu, &
+                                                                           al, &
+                                                                         xkzq, &
+                                                                         zfac
+!
+!jdf added exch_hx
+   real,    dimension( ims:ime, kms:kme )                                    , &
+            intent(inout)   ::                                        exch_hx
+!
+   real,    dimension( ims:ime )                                             , & 
+            intent(in  )    ::                                            u10, &
+                                                                          v10
+   real,    dimension( its:ite )    ::                                         &
+                                                                         brcr, &
+                                                                        sflux, &
+                                                                    brcr_sbro
+!
+   real,    dimension( its:ite, kts:kte, ndiff)  ::                     r3,f3
+   integer, dimension( its:ite )             ::                          kpbl
+!
+   logical, dimension( its:ite )             ::                        pblflg, &
+                                                                       sfcflg, &
+                                                                       stable
+!
+   integer ::  n,i,k,l,ic,is
+   integer ::  klpbl, ktrace1, ktrace2, ktrace3
+!
+!
+   real    ::  dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0
+   real    ::  xkzo,ss,ri,qmean,tmean,alph,chi,zk,rl2,dk,sri
+   real    ::  brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz
+   real    ::  utend,vtend,ttend,qtend
+   real    ::  dtstep,govrthv
+   real    ::  cont, conq, conw, conwrc 
+!
+   real, dimension( its:ite, kts:kte )     ::                         wscalek, &
+                                                                  xkzml,xkzhl, &
+                                                               zfacent,entfac
+   real, dimension( its:ite )              ::                            ust3, &
+                                                                 wstar3,wstar, &
+                                                                  hgamu,hgamv, &
+                                                                      wm2, we, &
+                                                                       bfxpbl, &
+                                                                hfxpbl,qfxpbl, &
+                                                                ufxpbl,vfxpbl, &
+                                                                  delta,dthvx
+   real    ::  prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx,                           &
+               dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr,     &
+               prfac,phim8z
+!
+!----------------------------------------------------------------------
+!
+   klpbl = kte
+!
+   cont=cp/g
+   conq=xlv/g
+   conw=1./g
+   conwrc = conw*sqrt(rcl)
+   conpr = bfac*karman*sfcfrac
+!
+!  k-start index for tracer diffusion
+!
+   ktrace1 = 0
+   ktrace2 = 0 + kte
+   ktrace3 = 0 + kte*2
+!
+   do k = kts,kte
+     do i = its,ite
+       thx(i,k) = tx(i,k)/pi2d(i,k)
+     enddo
+   enddo
+!
+   do k = kts,kte
+     do i = its,ite
+       tvcon = (1.+ep1*qx(i,k))
+       thvx(i,k) = thx(i,k)*tvcon
+     enddo
+   enddo
+!
+   do i = its,ite
+     tvcon = (1.+ep1*qx(i,1))
+     rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon)
+     govrth(i) = g/thx(i,1)
+   enddo
+!
+!-----compute the height of full- and half-sigma levels above ground
+!     level, and the layer thicknesses.
+!
+   do i = its,ite
+     zq(i,1) = 0.
+   enddo
+!
+   do k = kts,kte
+     do i = its,ite
+       zq(i,k+1) = dz8w2d(i,k)+zq(i,k)
+     enddo
+   enddo
+! 
+   do k = kts,kte
+     do i = its,ite
+       za(i,k) = 0.5*(zq(i,k)+zq(i,k+1))
+       dzq(i,k) = zq(i,k+1)-zq(i,k)
+       del(i,k) = p2di(i,k)-p2di(i,k+1)
+     enddo
+   enddo
+!
+   do i = its,ite
+     dza(i,1) = za(i,1)
+   enddo
+!
+   do k = kts+1,kte
+     do i = its,ite
+       dza(i,k) = za(i,k)-za(i,k-1)
+     enddo
+   enddo
+!
+!
+!-----initialize vertical tendencies and
+!
+   utnp(:,:) = 0.
+   vtnp(:,:) = 0.
+   ttnp(:,:) = 0.
+   qtnp(:,:) = 0.
+!
+   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
+     dusfc(i) = 0.
+     dvsfc(i) = 0.
+     dtsfc(i) = 0.
+     dqsfc(i) = 0.
+   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.
+     sflux(i) = hfx(i)/rhox(i)/cp + qfx(i)/rhox(i)*ep1*thx(i,1)
+     if(br(i).gt.0.0) sfcflg(i) = .false.
+   enddo
+!
+!     compute the first guess of pbl height
+!
+   do i = its,ite
+     stable(i) = .false.
+     brup(i) = br(i)
+     brcr(i) = brcr_ub
+   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(i)
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     k = kpbl(i)
+     if(brdn(i).ge.brcr(i))then
+       brint = 0.
+     elseif(brup(i).le.brcr(i))then
+       brint = 1.
+     else
+       brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i))
+     endif
+     hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1))
+     if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1
+     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(sflux(i),0.)
+       hfx0 = max(hfx(i)/rhox(i)/cp,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).and.sflux(i).gt.0.0)then
+       gamfac   = bfac/rhox(i)/wscale(i)
+       hgamt(i) = min(gamfac*hfx(i)/cp,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) = max(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)
+       brcr(i) = brcr_ub
+     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(i)
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     if(pblflg(i)) then
+       k = kpbl(i)
+       if(brdn(i).ge.brcr(i))then
+         brint = 0.
+       elseif(brup(i).le.brcr(i))then
+         brint = 1.
+       else
+         brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i))
+       endif
+       hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1))
+       if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1
+       if(kpbl(i).le.1) pblflg(i) = .false.
+     endif
+   enddo
+!
+!     stable boundary layer
+!
+   do i = its,ite
+     if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then
+       brup(i) = br(i)
+       stable(i) = .false.
+     else
+       stable(i) = .true.
+     endif
+   enddo
+!
+   do i = its,ite
+     if((.not.stable(i)).and.((xland(i)-1.5).ge.0))then
+       wspd10 = u10(i)*u10(i) + v10(i)*v10(i)
+       wspd10 = sqrt(wspd10)
+       ross = wspd10 / (cori*znt(i))
+       brcr_sbro(i) = min(0.16*(1.e-7*ross)**(-0.18),.3)
+     endif
+   enddo
+!
+   do i = its,ite
+     if(.not.stable(i))then
+       if((xland(i)-1.5).ge.0)then
+         brcr(i) = brcr_sbro(i)
+       else
+         brcr(i) = brcr_sb
+       endif
+     endif
+   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(i)
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then
+       k = kpbl(i)
+       if(brdn(i).ge.brcr(i))then
+         brint = 0.
+       elseif(brup(i).le.brcr(i))then
+         brint = 1.
+       else
+         brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i))
+       endif
+       hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1))
+       if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1
+       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
+       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),tmin)
+       dthx  = max(thx(i,k+1)-thx(i,k),tmin)
+       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.tmin) then
+         ufxpbl(i) = max(prpbl(i)*we(i)*dux,-ust(i)*ust(i))
+       elseif(dux.lt.-tmin) then
+         ufxpbl(i) = min(prpbl(i)*we(i)*dux,ust(i)*ust(i))
+       else
+         ufxpbl(i) = 0.0
+       endif
+       if(dvx.gt.tmin) then
+         vfxpbl(i) = max(prpbl(i)*we(i)*dvx,-ust(i)*ust(i))
+       elseif(dvx.lt.-tmin) 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.
+         wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1
+         if(sfcflg(i)) then 
+           prfac = conpr/phim(i)/((1.+4.*karman*wstar3(i)/ust3(i)))**h1
+           prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2./hpbl(i)**2.
+         else
+           prfac = 0.
+           prnumfac = 0.
+           phim8z = 1.+(phim(i)-1.)*zq(i,k+1)/sfcfrac/hpbl(i)
+           wscalek(i,k) = ust(i)/phim8z
+           wscalek(i,k) = max(wscalek(i,k),ust(i)/aphi5)
+         endif
+         prnum0 = (phih(i)/phim(i)+prfac)
+         prnum0 = min(prnum0,prmax)
+         prnum0 = max(prnum0,prmin)
+         xkzm(i,k) = xkzo+wscalek(i,k)*karman*zq(i,k+1)*zfac(i,k)**pfac
+         prnum =  1. + (prnum0-1.)*exp(prnumfac)
+         xkzq(i,k) = xkzm(i,k)/prnum*zfac(i,k)**(pfac_q-pfac)
+         prnum0 = prnum0/(1.+prfac)
+         prnum =  1. + (prnum0-1.)*exp(prnumfac)
+         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)
+         xkzq(i,k) = min(xkzq(i,k),xkzmax)
+         xkzq(i,k) = max(xkzq(i,k),xkzmin)
+       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.and.ndiff.ge.3)then
+           if((qx(i,ktrace2+k)+qx(i,ktrace3+k)).gt.0.01e-3.and.(qx(i           &
+             ,ktrace2+k+1)+qx(i,ktrace3+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)
+         rlamdz = min(max(0.1*dza(i,k+1),rlam),300.)
+         rl2 = (zk*rlamdz/(rlamdz+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)
+       endif
+     enddo
+   enddo
+!
+!     compute tridiagonal matrix elements for heat
+!
+   do k = kts,kte
+     do i = its,ite
+       au(i,k) = 0.
+       al(i,k) = 0.
+       ad(i,k) = 0.
+       f1(i,k) = 0.
+     enddo
+   enddo
+!
+   do i = its,ite
+     ad(i,1) = 1.
+     f1(i,1) = thx(i,1)-300.+hfx(i)/cont/del(i,1)*dt2
+   enddo
+!
+   do k = kts,kte-1
+     do i = its,ite
+       dtodsd = dt2/del(i,k)
+       dtodsu = dt2/del(i,k+1)
+       dsig   = p2d(i,k)-p2d(i,k+1)
+       rdz    = 1./dza(i,k+1)
+       tem1   = dsig*xkzh(i,k)*rdz
+       if(pblflg(i).and.k.lt.kpbl(i)) then
+         dsdzt = tem1*(-hgamt(i)/hpbl(i)-hfxpbl(i)*zfacent(i,k)/xkzh(i,k))
+         f1(i,k)   = f1(i,k)+dtodsd*dsdzt
+         f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt
+       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)-300.
+       else
+         f1(i,k+1) = thx(i,k+1)-300.
+       endif
+       tem1   = dsig*xkzh(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)
+       exch_hx(i,k+1) = xkzh(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)
+     enddo
+   enddo
+!
+   call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1)
+!
+!     recover tendencies of heat
+!
+   do k = kte,kts,-1
+     do i = its,ite
+       ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k)
+       ttnp(i,k) = ttnp(i,k)+ttend
+       dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k)/pi2d(i,k)
+     enddo
+   enddo
+!
+!     compute tridiagonal matrix elements for moisture, clouds, and tracers
+!
+   do k = kts,kte
+     do i = its,ite
+       au(i,k) = 0.
+       al(i,k) = 0.
+       ad(i,k) = 0.
+     enddo
+   enddo
+!
+   do ic = 1,ndiff
+     do i = its,ite
+       do k = kts,kte
+         f3(i,k,ic) = 0.
+       enddo
+     enddo
+   enddo
+!
+   do i = its,ite
+     ad(i,1) = 1.
+     f3(i,1,1) = qx(i,1)+qfx(i)*g/del(i,1)*dt2
+   enddo
+!
+   if(ndiff.ge.2) then
+     do ic = 2,ndiff
+       is = (ic-1) * kte
+       do i = its,ite
+         f3(i,1,ic) = qx(i,1+is)
+       enddo
+     enddo
+   endif
+!
+   do k = kts,kte
+     do i = its,ite
+       if(k.ge.kpbl(i)) then
+         xkzq(i,k) = xkzh(i,k)
+       endif
+     enddo
+   enddo
+!
+   do k = kts,kte-1
+     do i = its,ite
+       dtodsd = dt2/del(i,k)
+       dtodsu = dt2/del(i,k+1)
+       dsig   = p2d(i,k)-p2d(i,k+1)
+       rdz    = 1./dza(i,k+1)
+       tem1   = dsig*xkzq(i,k)*rdz
+       if(pblflg(i).and.k.lt.kpbl(i)) then
+         dsdzq = tem1*(-qfxpbl(i)*zfacent(i,k)/xkzq(i,k))
+         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
+         xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k))
+         xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k))
+         xkzq(i,k) = min(xkzq(i,k),xkzmax)
+         xkzq(i,k) = max(xkzq(i,k),xkzmin)
+         f3(i,k+1,1) = qx(i,k+1)
+       else
+         f3(i,k+1,1) = qx(i,k+1)
+       endif
+       tem1   = dsig*xkzq(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)
+!      exch_hx(i,k+1) = xkzh(i,k)
+     enddo
+   enddo
+!
+   if(ndiff.ge.2) then
+     do ic = 2,ndiff
+       is = (ic-1) * kte
+       do k = kts,kte-1
+         do i = its,ite
+           f3(i,k+1,ic) = qx(i,k+1+is)
+         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)
+     enddo
+   enddo
+!
+   do ic = 1,ndiff
+     do k = kts,kte
+       do i = its,ite
+         r3(i,k,ic) = f3(i,k,ic)
+       enddo
+     enddo
+   enddo
+!
+!     solve tridiagonal problem for moisture, clouds, and tracers
+!
+   call tridin_ysu(al,ad,cu,r3,au,f3,its,ite,kts,kte,ndiff)
+!
+!     recover tendencies of heat and moisture
+!
+   do k = kte,kts,-1
+     do i = its,ite
+       qtend = (f3(i,k,1)-qx(i,k))*rdt
+       qtnp(i,k) = qtnp(i,k)+qtend
+       dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k)
+     enddo
+   enddo
+!
+   if(ndiff.ge.2) then
+     do ic = 2,ndiff
+       is = (ic-1) * kte
+       do k = kte,kts,-1
+         do i = its,ite
+           qtend = (f3(i,k,ic)-qx(i,k+is))*rdt
+           qtnp(i,k+is) = qtnp(i,k+is)+qtend
+         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.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2                    &
+              *(wspd1(i)/wspd(i))**2
+     f1(i,1) = ux(i,1)
+     f2(i,1) = vx(i,1)
+   enddo
+!
+   do k = kts,kte-1
+     do i = its,ite
+       dtodsd = dt2/del(i,k)
+       dtodsu = dt2/del(i,k+1)
+       dsig   = p2d(i,k)-p2d(i,k+1)
+       rdz    = 1./dza(i,k+1)
+       tem1   = dsig*xkzm(i,k)*rdz
+     if(pblflg(i).and.k.lt.kpbl(i))then
+       dsdzu     = tem1*(-hgamu(i)/hpbl(i)-ufxpbl(i)*zfacent(i,k)/xkzm(i,k))
+       dsdzv     = tem1*(-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
+       tem1   = dsig*xkzm(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
+!
+! 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 tridi1n(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
+       dusfc(i) = dusfc(i) + utend*conwrc*del(i,k)
+       dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k)
+     enddo
+   enddo
+!
+!---- end of vertical diffusion
+!
+   do i = its,ite
+     kpbl1d(i) = kpbl(i)
+   enddo
+!
+   end subroutine ysu2d
+!
+   subroutine tridi1n(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 tridi1n
+!
+   subroutine tridin_ysu(cl,cm,cu,r2,au,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
+   real, dimension( its:ite, kts:kte,nt )                                    , &
+         intent(in   )  ::                                                 r2
+!
+   real, dimension( its:ite, kts:kte )                                       , &
+         intent(inout)  ::                                                 au, &
+						                           cu
+   real, dimension( its:ite, kts:kte,nt )                                    , &
+         intent(inout)  ::                                                 f2
+!
+   real    :: fk
+   integer :: i,k,l,n,it
+!
+!----------------------------------------------------------------
+!
+   l = ite
+   n = kte
+!
+   do it = 1,nt
+     do i = its,l
+       fk = 1./cm(i,1)
+       au(i,1) = fk*cu(i,1)
+       f2(i,1,it) = fk*r2(i,1,it)
+     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))
+       au(i,k) = fk*cu(i,k)
+       f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it))
+     enddo
+   enddo
+   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 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_ysu
+!
+   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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_bl_diffusion_solver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_bl_diffusion_solver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_bl_diffusion_solver.F	(revision 17)
@@ -0,0 +1,966 @@
+#define WRF_PORT
+
+module diffusion_solver
+
+  !------------------------------------------------------------------------------------ !
+  ! Module to solve vertical diffusion equations using a tri-diagonal solver.           !
+  ! The module will also apply countergradient fluxes, and apply molecular              ! 
+  ! diffusion for constituents.                                                         !
+  !                                                                                     !
+  ! Public interfaces :                                                                 ! 
+  !    init_vdiff       initializes time independent coefficients                       !
+  !    compute_vdiff    solves diffusion equations                                      !
+  !    vd_lu_solve      tridiagonal solver also used by gwd (should be private)         !
+  !    vd_lu_decomp     tridiagonal solver also used by gwd (should be private)         !
+  !    vdiff_selector   type for storing fields selected to be diffused                 !
+  !    vdiff_select     selects fields to be diffused                                   !
+  !    operator(.not.)  extends .not. to operate on type vdiff_selector                 !
+  !    any              provides functionality of intrinsic any for type vdiff_selector !
+  !                                                                                     !
+  !------------------------------------ Code History ---------------------------------- !
+  ! Initial subroutines :  B. Boville and others, 1991-2004                             !
+  ! Modularization      :  J. McCaa, September 2004                                     !
+  ! Most Recent Code    :  Sungsu Park, Aug. 2006, Dec. 2008, Jan. 2010.                !
+  !------------------------------------------------------------------------------------ !
+  
+
+#ifndef WRF_PORT 
+  use cam_logfile,   only : iulog
+#else
+  use module_cam_support,   only: iulog
+#endif
+
+  implicit none
+  private       
+  save
+
+  integer, parameter :: r8 = selected_real_kind(12)      ! 8 byte real
+
+  ! ----------------- !
+  ! Public interfaces !
+  ! ----------------- !
+
+  public init_vdiff                                      ! Initialization
+  public compute_vdiff                                   ! Full routine
+  public vd_lu_solve                                     ! Tridiagonal solver also used by gwd ( should be private! )
+  public vd_lu_decomp                                    ! Tridiagonal solver also used by gwd ( should be private! )
+  public vdiff_selector                                  ! Type for storing fields selected to be diffused
+  public vdiff_select                                    ! Selects fields to be diffused
+  public operator(.not.)                                 ! Extends .not. to operate on type vdiff_selector
+  public any                                             ! Provides functionality of intrinsic any for type vdiff_selector
+
+  integer, public   :: nbot_molec                        ! Bottom level where molecular diffusivity is applied
+ 
+  ! Below stores logical array of fields to be diffused
+
+  type vdiff_selector 
+       private
+       logical, pointer, dimension(:) :: fields
+  end type vdiff_selector
+
+  ! Below extends .not. to operate on type vdiff_selector
+
+  interface operator(.not.)
+       module procedure not
+  end interface
+
+  ! Below provides functionality of intrinsic any for type vdiff_selector
+
+  interface any                           
+       module procedure my_any
+  end interface
+
+  ! ------------ !
+  ! Private data !
+  ! ------------ !
+
+  real(r8), private   :: cpair                           ! Specific heat of dry air
+  real(r8), private   :: gravit                          ! Acceleration due to gravity
+  real(r8), private   :: rair                            ! Gas constant for dry air
+  real(r8), private   :: zvir                            ! rh2o/rair - 1
+  real(r8), private   :: latvap                          ! Latent heat of vaporization
+  real(r8), private   :: karman                          ! von Karman constant
+
+  ! Parameters used for Turbulent Mountain Stress
+
+  real(r8), parameter :: z0fac   = 0.025_r8              ! Factor determining z_0 from orographic standard deviation
+  real(r8), parameter :: z0max   = 100._r8               ! Max value of z_0 for orography
+  real(r8), parameter :: horomin = 10._r8                ! Min value of subgrid orographic height for mountain stress
+  real(r8), parameter :: dv2min  = 0.01_r8               ! Minimum shear squared
+  real(r8), private   :: oroconst                        ! Converts from standard deviation to height
+
+  contains
+
+  ! =============================================================================== !
+  !                                                                                 !
+  ! =============================================================================== !
+
+  subroutine init_vdiff( kind, ncnst, rair_in, gravit_in, fieldlist_wet, fieldlist_dry, errstring )
+
+    integer,              intent(in)  :: kind            ! Kind used for reals
+    integer,              intent(in)  :: ncnst           ! Number of constituents
+    real(r8),             intent(in)  :: rair_in         ! Input gas constant for dry air
+    real(r8),             intent(in)  :: gravit_in       ! Input gravititational acceleration
+    type(vdiff_selector), intent(out) :: fieldlist_wet   ! List of fields to be diffused using moist mixing ratio
+    type(vdiff_selector), intent(out) :: fieldlist_dry   ! List of fields to be diffused using dry   mixing ratio
+    character(128),       intent(out) :: errstring       ! Output status
+    
+    errstring = ''
+    if( kind .ne. r8 ) then
+        write(iulog,*) 'KIND of reals passed to init_vdiff -- exiting.'
+        errstring = 'init_vdiff'
+        return
+    endif
+
+    rair   = rair_in     
+    gravit = gravit_in 
+
+    allocate( fieldlist_wet%fields( 3 + ncnst ) )
+    fieldlist_wet%fields(:) = .false.
+
+    allocate( fieldlist_dry%fields( 3 + ncnst ) )
+    fieldlist_dry%fields(:) = .false.
+
+  end subroutine init_vdiff
+
+  ! =============================================================================== !
+  !                                                                                 !
+  ! =============================================================================== !
+
+  subroutine compute_vdiff( lchnk           ,                                                                   &
+                            pcols           , pver               , ncnst         , ncol         , pmid        , &
+                            pint            , rpdel              , t             , ztodt        , taux        , &
+                            tauy            , shflx              , cflx          , ntop         , nbot        , &
+                            kvh             , kvm                , kvq           , cgs          , cgh         , &
+                            zi              , ksrftms            , qmincg        , fieldlist    ,               &
+                            u               , v                  , q             , dse          ,               &
+                            tautmsx         , tautmsy            , dtk           , topflx       , errstring   , &
+                            tauresx         , tauresy            , itaures       ,                              &
+                            do_molec_diff   , compute_molec_diff , vd_lu_qdecomp )
+
+    !-------------------------------------------------------------------------- !
+    ! Driver routine to compute vertical diffusion of momentum, moisture, trace !
+    ! constituents and dry static energy. The new temperature is computed from  !
+    ! the diffused dry static energy.                                           ! 
+    ! Turbulent diffusivities and boundary layer nonlocal transport terms are   !
+    ! obtained from the turbulence module.                                      !
+    !-------------------------------------------------------------------------- !
+#ifndef WRF_PORT 
+    use phys_debug_util,    only : phys_debug_col
+    use time_manager,       only : is_first_step, get_nstep
+    use phys_control,       only : phys_getopts
+#endif
+  
+  ! Modification : Ideally, we should diffuse 'liquid-ice static energy' (sl), not the dry static energy.
+  !                Also, vertical diffusion of cloud droplet number concentration and aerosol number
+  !                concentration should be done very carefully in the future version.
+
+    ! --------------- !
+    ! Input Arguments !
+    ! --------------- !
+
+    integer,  intent(in)    :: lchnk                   
+    integer,  intent(in)    :: pcols
+    integer,  intent(in)    :: pver
+    integer,  intent(in)    :: ncnst
+    integer,  intent(in)    :: ncol                      ! Number of atmospheric columns
+    integer,  intent(in)    :: ntop                      ! Top    interface level to which vertical diffusion is applied ( = 1 ).
+    integer,  intent(in)    :: nbot                      ! Bottom interface level to which vertical diffusion is applied ( = pver ).
+    integer,  intent(in)    :: itaures                   ! Indicator determining whether 'tauresx,tauresy' is updated (1) or non-updated (0) in this subroutine.   
+
+    real(r8), intent(in)    :: pmid(pcols,pver)          ! Mid-point pressures [ Pa ]
+    real(r8), intent(in)    :: pint(pcols,pver+1)        ! Interface pressures [ Pa ]
+    real(r8), intent(in)    :: rpdel(pcols,pver)         ! 1./pdel
+    real(r8), intent(in)    :: t(pcols,pver)             ! Temperature [ K ]
+    real(r8), intent(in)    :: ztodt                     ! 2 delta-t [ s ]
+    real(r8), intent(in)    :: taux(pcols)               ! Surface zonal      stress. Input u-momentum per unit time per unit area into the atmosphere [ N/m2 ]
+    real(r8), intent(in)    :: tauy(pcols)               ! Surface meridional stress. Input v-momentum per unit time per unit area into the atmosphere [ N/m2 ]
+    real(r8), intent(in)    :: shflx(pcols)              ! Surface sensible heat flux [ W/m2 ]
+    real(r8), intent(in)    :: cflx(pcols,ncnst)         ! Surface constituent flux [ kg/m2/s ]
+    real(r8), intent(in)    :: zi(pcols,pver+1)          ! Interface heights [ m ]
+    real(r8), intent(in)    :: ksrftms(pcols)            ! Surface drag coefficient for turbulent mountain stress. > 0. [ kg/s/m2 ]
+    real(r8), intent(in)    :: qmincg(ncnst)             ! Minimum constituent mixing ratios from cg fluxes
+
+    logical,  intent(in)         :: do_molec_diff        ! Flag indicating multiple constituent diffusivities
+    integer,  external, optional :: compute_molec_diff   ! Constituent-independent moleculuar diffusivity routine
+    integer,  external, optional :: vd_lu_qdecomp        ! Constituent-dependent moleculuar diffusivity routine
+    type(vdiff_selector), intent(in) :: fieldlist        ! Array of flags selecting which fields to diffuse
+
+    ! ---------------------- !
+    ! Input-Output Arguments !
+    ! ---------------------- !
+
+    real(r8), intent(inout) :: kvh(pcols,pver+1)         ! Eddy diffusivity for heat [ m2/s ]
+    real(r8), intent(inout) :: kvm(pcols,pver+1)         ! Eddy viscosity ( Eddy diffusivity for momentum ) [ m2/s ]
+    real(r8), intent(inout) :: kvq(pcols,pver+1)         ! Eddy diffusivity for constituents
+    real(r8), intent(inout) :: cgs(pcols,pver+1)         ! Counter-gradient star [ cg/flux ]
+    real(r8), intent(inout) :: cgh(pcols,pver+1)         ! Counter-gradient term for heat
+
+    real(r8), intent(inout) :: u(pcols,pver)             ! U wind. This input is the 'raw' input wind to PBL scheme without iterative provisional update. [ m/s ]
+    real(r8), intent(inout) :: v(pcols,pver)             ! V wind. This input is the 'raw' input wind to PBL scheme without iterative provisional update. [ m/s ]
+    real(r8), intent(inout) :: q(pcols,pver,ncnst)       ! Moisture and trace constituents [ kg/kg, #/kg ? ]
+    real(r8), intent(inout) :: dse(pcols,pver)           ! Dry static energy [ J/kg ]
+
+    real(r8), intent(inout) :: tauresx(pcols)            ! Input  : Reserved surface stress at previous time step
+    real(r8), intent(inout) :: tauresy(pcols)            ! Output : Reserved surface stress at current  time step
+
+    ! ---------------- !
+    ! Output Arguments !
+    ! ---------------- !
+
+    real(r8), intent(out)   :: dtk(pcols,pver)           ! T tendency from KE dissipation
+    real(r8), intent(out)   :: tautmsx(pcols)            ! Implicit zonal      turbulent mountain surface stress [ N/m2 = kg m/s /s/m2 ]
+    real(r8), intent(out)   :: tautmsy(pcols)            ! Implicit meridional turbulent mountain surface stress [ N/m2 = kg m/s /s/m2 ]
+    real(r8), intent(out)   :: topflx(pcols)             ! Molecular heat flux at the top interface
+    character(128), intent(out) :: errstring             ! Output status
+
+    ! --------------- !
+    ! Local Variables ! 
+    ! --------------- !
+
+    integer  :: i, k, m, icol                            ! Longitude, level, constituent indices
+    integer  :: status                                   ! Status indicator
+    integer  :: ntop_molec                               ! Top level where molecular diffusivity is applied
+    logical  :: lqtst(pcols)                             ! Adjust vertical profiles
+    logical  :: need_decomp                              ! Whether to compute a new decomposition
+    logical  :: cnst_fixed_ubc(ncnst)                    ! Whether upper boundary condition is fixed
+    logical  :: do_iss                                   ! Use implicit turbulent surface stress computation
+
+    real(r8) :: tmpm(pcols,pver)                         ! Potential temperature, ze term in tri-diag sol'n
+    real(r8) :: ca(pcols,pver)                           ! - Upper diag of tri-diag matrix
+    real(r8) :: cc(pcols,pver)                           ! - Lower diag of tri-diag matrix
+    real(r8) :: dnom(pcols,pver)                         ! 1./(1. + ca(k) + cc(k) - cc(k)*ze(k-1))
+
+    real(r8) :: tmp1(pcols)                              ! Temporary storage
+    real(r8) :: tmpi1(pcols,pver+1)                      ! Interface KE dissipation
+    real(r8) :: tint(pcols,pver+1)                       ! Interface temperature
+    real(r8) :: rhoi(pcols,pver+1)                       ! rho at interfaces
+    real(r8) :: tmpi2(pcols,pver+1)                      ! dt*(g*rho)**2/dp at interfaces
+    real(r8) :: rrho(pcols)                              ! 1./bottom level density 
+
+    real(r8) :: zero(pcols)                              ! Zero array for surface heat exchange coefficients 
+    real(r8) :: tautotx(pcols)                           ! Total surface stress ( zonal )
+    real(r8) :: tautoty(pcols)                           ! Total surface stress ( meridional )
+
+    real(r8) :: dinp_u(pcols,pver+1)                     ! Vertical difference at interfaces, input u
+    real(r8) :: dinp_v(pcols,pver+1)                     ! Vertical difference at interfaces, input v
+    real(r8) :: dout_u                                   ! Vertical difference at interfaces, output u
+    real(r8) :: dout_v                                   ! Vertical difference at interfaces, output v
+    real(r8) :: dse_top(pcols)                           ! dse on top boundary
+    real(r8) :: cc_top(pcols)                            ! Lower diagonal at top interface
+    real(r8) :: cd_top(pcols)                            ! 
+    real(r8) :: rghd(pcols,pver+1)                       ! (1/H_i - 1/H) *(g*rho)^(-1)
+
+    real(r8) :: qtm(pcols,pver)                          ! Temporary copy of q
+    real(r8) :: kq_scal(pcols,pver+1)                    ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity
+    real(r8) :: mw_fac(ncnst)                            ! sqrt(1/M_q + 1/M_d) for this constituent
+    real(r8) :: cnst_mw(ncnst)                           ! Molecular weight [ kg/kmole ]
+    real(r8) :: ubc_mmr(pcols,ncnst)                     ! Upper boundary mixing ratios [ kg/kg ]
+    real(r8) :: ubc_t(pcols)                             ! Upper boundary temperature [ K ]
+
+    real(r8) :: ws(pcols)                                ! Lowest-level wind speed [ m/s ]
+    real(r8) :: tau(pcols)                               ! Turbulent surface stress ( not including mountain stress )
+    real(r8) :: ksrfturb(pcols)                          ! Surface drag coefficient of 'normal' stress. > 0. Virtual mass input per unit time per unit area [ kg/s/m2 ]
+    real(r8) :: ksrf(pcols)                              ! Surface drag coefficient of 'normal' stress + Surface drag coefficient of 'tms' stress.  > 0. [ kg/s/m2 ] 
+    real(r8) :: usum_in(pcols)                           ! Vertical integral of input u-momentum. Total zonal     momentum per unit area in column  [ sum of u*dp/g = kg m/s m-2 ]
+    real(r8) :: vsum_in(pcols)                           ! Vertical integral of input v-momentum. Total meridional momentum per unit area in column [ sum of v*dp/g = kg m/s m-2 ]
+    real(r8) :: usum_mid(pcols)                          ! Vertical integral of u-momentum after adding explicit residual stress
+    real(r8) :: vsum_mid(pcols)                          ! Vertical integral of v-momentum after adding explicit residual stress
+    real(r8) :: usum_out(pcols)                          ! Vertical integral of u-momentum after doing implicit diffusion
+    real(r8) :: vsum_out(pcols)                          ! Vertical integral of v-momentum after doing implicit diffusion
+    real(r8) :: tauimpx(pcols)                           ! Actual net stress added at the current step other than mountain stress
+    real(r8) :: tauimpy(pcols)                           ! Actual net stress added at the current step other than mountain stress
+    real(r8) :: wsmin                                    ! Minimum sfc wind speed for estimating frictional transfer velocity ksrf. [ m/s ]
+    real(r8) :: ksrfmin                                  ! Minimum surface drag coefficient [ kg/s/m^2 ]
+    real(r8) :: timeres                                  ! Relaxation time scale of residual stress ( >= dt ) [ s ]
+    real(r8) :: ramda                                    ! dt/timeres [ no unit ]
+    real(r8) :: psum
+    real(r8) :: u_in, u_res, tauresx_in
+    real(r8) :: v_in, v_res, tauresy_in  
+
+    ! ------------------------------------------------ !
+    ! Parameters for implicit surface stress treatment !
+    ! ------------------------------------------------ !
+
+    wsmin    = 1._r8                                     ! Minimum wind speed for ksrfturb computation        [ m/s ]
+    ksrfmin  = 1.e-4_r8                                  ! Minimum surface drag coefficient                   [ kg/s/m^2 ]
+    timeres  = 7200._r8                                  ! Relaxation time scale of residual stress ( >= dt ) [ s ]
+#ifndef WRF_PORT 
+    call phys_getopts( do_iss_out = do_iss )
+#endif
+    do_iss = .true.
+
+    ! ----------------------- !
+    ! Main Computation Begins !
+    ! ----------------------- !
+
+    errstring = ''
+    if( ( diffuse(fieldlist,'u') .or. diffuse(fieldlist,'v') ) .and. .not. diffuse(fieldlist,'s') ) then
+          errstring = 'diffusion_solver.compute_vdiff: must diffuse s if diffusing u or v'
+          return
+    end if
+    zero(:) = 0._r8
+
+    ! Compute 'rho' and 'dt*(g*rho)^2/dp' at interfaces
+
+    tint(:ncol,1) = t(:ncol,1)
+    rhoi(:ncol,1) = pint(:ncol,1) / (rair*tint(:ncol,1))
+    do k = 2, pver
+       do i = 1, ncol
+          tint(i,k)  = 0.5_r8 * ( t(i,k) + t(i,k-1) )
+          rhoi(i,k)  = pint(i,k) / (rair*tint(i,k))
+          tmpi2(i,k) = ztodt * ( gravit*rhoi(i,k) )**2 / ( pmid(i,k) - pmid(i,k-1) )
+       end do
+    end do
+    tint(:ncol,pver+1) = t(:ncol,pver)
+    rhoi(:ncol,pver+1) = pint(:ncol,pver+1) / ( rair*tint(:ncol,pver+1) )
+
+    rrho(:ncol) = rair  * t(:ncol,pver) / pmid(:ncol,pver)
+    tmp1(:ncol) = ztodt * gravit * rpdel(:ncol,pver)
+
+    !--------------------------------------- !
+    ! Computation of Molecular Diffusivities !
+    !--------------------------------------- !
+
+  ! Modification : Why 'kvq' is not changed by molecular diffusion ? 
+
+    if( do_molec_diff ) then
+
+        if( (.not.present(compute_molec_diff)) .or. (.not.present(vd_lu_qdecomp)) ) then
+              errstring = 'compute_vdiff: do_molec_diff true but compute_molec_diff or vd_lu_qdecomp missing'
+              return
+        endif
+
+      ! The next subroutine 'compute_molec_diff' :
+      !     Modifies : kvh, kvm, tint, rhoi, and tmpi2
+      !     Returns  : kq_scal, ubc_t, ubc_mmr, dse_top, cc_top, cd_top, cnst_mw, 
+      !                cnst_fixed_ubc , mw_fac , ntop_molec 
+
+        status = compute_molec_diff( lchnk          ,                                                                &
+                                     pcols          , pver    , ncnst      , ncol      , t      , pmid   , pint    , &
+                                     zi             , ztodt   , kvh        , kvm       , tint   , rhoi   , tmpi2   , &
+                                     kq_scal        , ubc_t   , ubc_mmr    , dse_top   , cc_top , cd_top , cnst_mw , &
+                                     cnst_fixed_ubc , mw_fac  , ntop_molec , nbot_molec )
+
+    else
+
+        kq_scal(:,:) = 0._r8
+        cd_top(:)    = 0._r8
+        cc_top(:)    = 0._r8
+
+    endif
+
+    !---------------------------- !
+    ! Diffuse Horizontal Momentum !
+    !---------------------------- !
+
+    if( diffuse(fieldlist,'u') .or. diffuse(fieldlist,'v') ) then
+
+        ! Compute the vertical upward differences of the input u,v for KE dissipation
+        ! at each interface.
+        ! Velocity = 0 at surface, so difference at the bottom interface is -u,v(pver)
+        ! These 'dinp_u, dinp_v' are computed using the non-diffused input wind.
+
+        do i = 1, ncol
+           dinp_u(i,1) = 0._r8
+           dinp_v(i,1) = 0._r8
+           dinp_u(i,pver+1) = -u(i,pver)
+           dinp_v(i,pver+1) = -v(i,pver)
+        end do
+        do k = 2, pver
+           do i = 1, ncol
+              dinp_u(i,k) = u(i,k) - u(i,k-1)
+              dinp_v(i,k) = v(i,k) - v(i,k-1)
+           end do
+        end do
+
+       ! -------------------------------------------------------------- !
+       ! Do 'Implicit Surface Stress' treatment for numerical stability !
+       ! in the lowest model layer.                                     !
+       ! -------------------------------------------------------------- !
+
+       if( do_iss ) then
+
+         ! Compute surface drag coefficient for implicit diffusion 
+         ! including turbulent turbulent mountain stress. 
+
+           do i = 1, ncol
+              ws(i)       = max( sqrt( u(i,pver)**2._r8 + v(i,pver)**2._r8 ), wsmin )
+              tau(i)      = sqrt( taux(i)**2._r8 + tauy(i)**2._r8 )
+              ksrfturb(i) = max( tau(i) / ws(i), ksrfmin )
+           end do              
+           ksrf(:ncol) = ksrfturb(:ncol) + ksrftms(:ncol)  ! Do all surface stress ( normal + tms ) implicitly
+
+         ! Vertical integration of input momentum. 
+         ! This is total horizontal momentum per unit area [ kg*m/s/m2 ] in each column.
+         ! Note (u,v) are the raw input to the PBL scheme, not the
+         ! provisionally-marched ones within the iteration loop of the PBL scheme.  
+
+           do i = 1, ncol
+              usum_in(i) = 0._r8
+              vsum_in(i) = 0._r8
+              do k = 1, pver
+                 usum_in(i) = usum_in(i) + (1._r8/gravit)*u(i,k)/rpdel(i,k)
+                 vsum_in(i) = vsum_in(i) + (1._r8/gravit)*v(i,k)/rpdel(i,k)
+              end do
+           end do              
+
+         ! Add residual stress of previous time step explicitly into the lowest
+         ! model layer with a relaxation time scale of 'timeres'.
+
+           ramda         = ztodt / timeres
+           u(:ncol,pver) = u(:ncol,pver) + tmp1(:ncol)*tauresx(:ncol)*ramda
+           v(:ncol,pver) = v(:ncol,pver) + tmp1(:ncol)*tauresy(:ncol)*ramda
+
+         ! Vertical integration of momentum after adding explicit residual stress
+         ! into the lowest model layer.
+
+           do i = 1, ncol
+              usum_mid(i) = 0._r8
+              vsum_mid(i) = 0._r8
+              do k = 1, pver
+                 usum_mid(i) = usum_mid(i) + (1._r8/gravit)*u(i,k)/rpdel(i,k)
+                 vsum_mid(i) = vsum_mid(i) + (1._r8/gravit)*v(i,k)/rpdel(i,k)
+              end do
+           end do              
+
+         ! Debug 
+         ! icol = phys_debug_col(lchnk) 
+         ! if ( icol > 0 .and. get_nstep() .ge. 1 ) then
+         !      tauresx_in = tauresx(icol)
+         !      tauresy_in = tauresy(icol)
+         !      u_in  = u(icol,pver) - tmp1(icol) * tauresx(icol) * ramda
+         !      v_in  = v(icol,pver) - tmp1(icol) * tauresy(icol) * ramda
+         !      u_res = u(icol,pver)
+         !      v_res = v(icol,pver)
+         ! endif
+         ! Debug
+
+       else
+
+         ! In this case, do 'turbulent mountain stress' implicitly, 
+         ! but do 'normal turbulent stress' explicitly.
+         ! In this case, there is no 'redisual stress' as long as 'tms' is
+         ! treated in a fully implicit wway, which is true.
+
+         ! 1. Do 'tms' implicitly
+
+           ksrf(:ncol) = ksrftms(:ncol) 
+
+         ! 2. Do 'normal stress' explicitly
+
+           u(:ncol,pver) = u(:ncol,pver) + tmp1(:ncol)*taux(:ncol)
+           v(:ncol,pver) = v(:ncol,pver) + tmp1(:ncol)*tauy(:ncol)
+
+       end if  ! End of 'do iss' ( implicit surface stress )
+
+       ! --------------------------------------------------------------------------------------- !
+       ! Diffuse horizontal momentum implicitly using tri-diagnonal matrix.                      !
+       ! The 'u,v' are input-output: the output 'u,v' are implicitly diffused winds.             !
+       !    For implicit 'normal' stress : ksrf = ksrftms + ksrfturb,                            !
+       !                                   u(pver) : explicitly include 'redisual normal' stress !
+       !    For explicit 'normal' stress : ksrf = ksrftms                                        !
+       !                                   u(pver) : explicitly include 'normal' stress          !                                              
+       ! Note that in all the two cases above, 'tms' is fully implicitly treated.                !
+       ! --------------------------------------------------------------------------------------- !
+
+       call vd_lu_decomp( pcols , pver , ncol  ,                        &
+                          ksrf  , kvm  , tmpi2 , rpdel , ztodt , zero , &
+                          ca    , cc   , dnom  , tmpm  , ntop  , nbot )
+
+       call vd_lu_solve(  pcols , pver , ncol  ,                        &
+                          u     , ca   , tmpm  , dnom  , ntop  , nbot , zero )
+
+       call vd_lu_solve(  pcols , pver , ncol  ,                        &
+                          v     , ca   , tmpm  , dnom  , ntop  , nbot , zero )
+
+       ! ---------------------------------------------------------------------- !
+       ! Calculate 'total' ( tautotx ) and 'tms' ( tautmsx ) stresses that      !
+       ! have been actually added into the atmosphere at the current time step. ! 
+       ! Also, update residual stress, if required.                             !
+       ! ---------------------------------------------------------------------- !
+
+       do i = 1, ncol
+
+          ! Compute the implicit 'tms' using the updated winds.
+          ! Below 'tautmsx(i),tautmsy(i)' are pure implicit mountain stresses
+          ! that has been actually added into the atmosphere both for explicit
+          ! and implicit approach. 
+
+          tautmsx(i) = -ksrftms(i)*u(i,pver)
+          tautmsy(i) = -ksrftms(i)*v(i,pver)
+
+          if( do_iss ) then
+
+            ! Compute vertical integration of final horizontal momentum
+
+              usum_out(i) = 0._r8
+              vsum_out(i) = 0._r8
+              do k = 1, pver
+                 usum_out(i) = usum_out(i) + (1._r8/gravit)*u(i,k)/rpdel(i,k)
+                 vsum_out(i) = vsum_out(i) + (1._r8/gravit)*v(i,k)/rpdel(i,k)
+              end do
+
+            ! Compute net stress added into the atmosphere at the current time step.
+            ! Note that the difference between 'usum_in' and 'usum_out' are induced
+            ! by 'explicit residual stress + implicit total stress' for implicit case, while
+            ! by 'explicit normal   stress + implicit tms   stress' for explicit case. 
+            ! Here, 'tautotx(i)' is net stress added into the air at the current time step.
+
+              tauimpx(i) = ( usum_out(i) - usum_in(i) ) / ztodt
+              tauimpy(i) = ( vsum_out(i) - vsum_in(i) ) / ztodt
+
+              tautotx(i) = tauimpx(i) 
+              tautoty(i) = tauimpy(i) 
+
+            ! Compute redisual stress and update if required.
+            ! Note that the total stress we should have added at the current step is
+            ! the sum of 'taux(i) - ksrftms(i)*u(i,pver) + tauresx(i)'.
+
+              if( itaures .eq. 1 ) then
+                  tauresx(i) = taux(i) + tautmsx(i) + tauresx(i) - tauimpx(i)
+                  tauresy(i) = tauy(i) + tautmsy(i) + tauresy(i) - tauimpy(i)
+              endif
+
+          else
+
+              tautotx(i) = tautmsx(i) + taux(i)
+              tautoty(i) = tautmsy(i) + tauy(i)
+              tauresx(i) = 0._r8
+              tauresy(i) = 0._r8
+
+          end if  ! End of 'do_iss' routine
+
+       end do ! End of 'do i = 1, ncol' routine
+
+     ! Debug 
+     ! icol = phys_debug_col(lchnk) 
+     ! if ( icol > 0 .and. get_nstep() .ge. 1 ) then
+     !      write(iulog,*)
+     !      write(iulog,*)  'diffusion_solver debug'  
+     !      write(iulog,*)
+     !      write(iulog,*)  'u_in, u_res, u_out'
+     !      write(iulog,*)   u_in, u_res, u(icol,pver)
+     !      write(iulog,*)  'tauresx_in, tautmsx, tauimpx(actual), tauimpx(derived), tauresx_out, taux'
+     !      write(iulog,*)   tauresx_in, tautmsx(icol), tauimpx(icol), -ksrf(icol)*u(icol,pver), tauresx(icol), taux(icol)
+     !      write(iulog,*)
+     !      write(iulog,*)  'v_in, v_res, v_out'
+     !      write(iulog,*)   v_in, v_res, v(icol,pver)
+     !      write(iulog,*)  'tauresy_in, tautmsy, tauimpy(actual), tauimpy(derived), tauresy_out, tauy'
+     !      write(iulog,*)   tauresy_in, tautmsy(icol), tauimpy(icol), -ksrf(icol)*v(icol,pver), tauresy(icol), tauy(icol)
+     !      write(iulog,*)
+     !      write(iulog,*)  'itaures, ksrf, ksrfturb, ksrftms'
+     !      write(iulog,*)   itaures, ksrf(icol), ksrfturb(icol), ksrftms(icol)
+     !      write(iulog,*) 
+     ! endif
+     ! Debug
+
+       ! ------------------------------------ !
+       ! Calculate kinetic energy dissipation !
+       ! ------------------------------------ !       
+
+     ! Modification : In future, this should be set exactly same as 
+     !                the ones in the convection schemes 
+
+       ! 1. Compute dissipation term at interfaces
+       !    Note that 'u,v' are already diffused wind, and 'tautotx,tautoty' are 
+       !    implicit stress that has been actually added. On the other hand,
+       !    'dinp_u, dinp_v' were computed using non-diffused input wind.
+
+     ! Modification : I should check whether non-consistency between 'u' and 'dinp_u'
+     !                is correctly intended approach. I think so.
+
+       k = pver + 1
+       do i = 1, ncol
+          tmpi1(i,1) = 0._r8
+          tmpi1(i,k) = 0.5_r8 * ztodt * gravit * &
+                       ( (-u(i,k-1) + dinp_u(i,k))*tautotx(i) + (-v(i,k-1) + dinp_v(i,k))*tautoty(i) )
+       end do
+
+       do k = 2, pver
+          do i = 1, ncol
+             dout_u = u(i,k) - u(i,k-1)
+             dout_v = v(i,k) - v(i,k-1)
+             tmpi1(i,k) = 0.25_r8 * tmpi2(i,k) * kvm(i,k) * &
+                          ( dout_u**2 + dout_v**2 + dout_u*dinp_u(i,k) + dout_v*dinp_v(i,k) )
+          end do
+       end do
+
+       ! 2. Compute dissipation term at midpoints, add to dry static energy
+
+       do k = 1, pver
+          do i = 1, ncol
+             dtk(i,k) = ( tmpi1(i,k+1) + tmpi1(i,k) ) * rpdel(i,k)
+             dse(i,k) = dse(i,k) + dtk(i,k)
+          end do
+       end do
+
+    end if ! End of diffuse horizontal momentum, diffuse(fieldlist,'u') routine
+
+    !-------------------------- !
+    ! Diffuse Dry Static Energy !
+    !-------------------------- !
+
+  ! Modification : In future, we should diffuse the fully conservative 
+  !                moist static energy,not the dry static energy.
+
+    if( diffuse(fieldlist,'s') ) then
+
+      ! Add counter-gradient to input static energy profiles
+
+        do k = 1, pver
+           dse(:ncol,k) = dse(:ncol,k) + ztodt * rpdel(:ncol,k) * gravit  *                &
+                                       ( rhoi(:ncol,k+1) * kvh(:ncol,k+1) * cgh(:ncol,k+1) &
+                                       - rhoi(:ncol,k  ) * kvh(:ncol,k  ) * cgh(:ncol,k  ) )
+       end do
+
+     ! Add the explicit surface fluxes to the lowest layer
+
+       dse(:ncol,pver) = dse(:ncol,pver) + tmp1(:ncol) * shflx(:ncol)
+
+     ! Diffuse dry static energy
+
+       call vd_lu_decomp( pcols , pver , ncol  ,                         &
+                          zero  , kvh  , tmpi2 , rpdel , ztodt , cc_top, &
+                          ca    , cc   , dnom  , tmpm  , ntop  , nbot    )
+
+       call vd_lu_solve(  pcols , pver , ncol  ,                         &
+                          dse   , ca   , tmpm  , dnom  , ntop  , nbot  , cd_top )
+
+     ! Calculate flux at top interface
+     
+     ! Modification : Why molecular diffusion does not work for dry static energy in all layers ?
+
+       if( do_molec_diff ) then
+           topflx(:ncol) =  - kvh(:ncol,ntop_molec) * tmpi2(:ncol,ntop_molec) / (ztodt*gravit) * &
+                            ( dse(:ncol,ntop_molec) - dse_top(:ncol) )
+       end if
+
+    endif
+
+    !---------------------------- !
+    ! Diffuse Water Vapor Tracers !
+    !---------------------------- !
+
+  ! Modification : For aerosols, I need to use separate treatment 
+  !                for aerosol mass and aerosol number. 
+
+    ! Loop through constituents
+
+    need_decomp = .true.
+
+    do m = 1, ncnst
+
+       if( diffuse(fieldlist,'q',m) ) then
+
+           ! Add the nonlocal transport terms to constituents in the PBL.
+           ! Check for neg q's in each constituent and put the original vertical
+           ! profile back if a neg value is found. A neg value implies that the
+           ! quasi-equilibrium conditions assumed for the countergradient term are
+           ! strongly violated.
+
+           qtm(:ncol,:pver) = q(:ncol,:pver,m)
+
+           do k = 1, pver
+              q(:ncol,k,m) = q(:ncol,k,m) + &
+                             ztodt * rpdel(:ncol,k) * gravit  * ( cflx(:ncol,m) * rrho(:ncol) ) * &
+                           ( rhoi(:ncol,k+1) * kvh(:ncol,k+1) * cgs(:ncol,k+1)                    &
+                           - rhoi(:ncol,k  ) * kvh(:ncol,k  ) * cgs(:ncol,k  ) )
+           end do
+           lqtst(:ncol) = all(q(:ncol,1:pver,m) >= qmincg(m), 2)
+           do k = 1, pver
+              q(:ncol,k,m) = merge( q(:ncol,k,m), qtm(:ncol,k), lqtst(:ncol) )
+           end do
+
+           ! Add the explicit surface fluxes to the lowest layer
+
+           q(:ncol,pver,m) = q(:ncol,pver,m) + tmp1(:ncol) * cflx(:ncol,m)
+
+           ! Diffuse constituents.
+
+           if( need_decomp ) then
+
+               call vd_lu_decomp( pcols , pver , ncol  ,                         &
+                                  zero  , kvq  , tmpi2 , rpdel , ztodt , zero  , &
+                                  ca    , cc   , dnom  , tmpm  , ntop  , nbot )
+
+               if( do_molec_diff ) then
+
+                 ! Update decomposition in molecular diffusion range, include separation velocity term
+
+                   status = vd_lu_qdecomp( pcols , pver   , ncol      , cnst_fixed_ubc(m), cnst_mw(m), ubc_mmr(:,m), &
+                                           kvq   , kq_scal, mw_fac(m) , tmpi2            , rpdel     ,               &
+                                           ca    , cc     , dnom      , tmpm             , rhoi      ,               &
+                                           tint  , ztodt  , ntop_molec, nbot_molec       , cd_top )
+               else
+                   need_decomp =  .false.
+               endif
+           end if
+
+           call vd_lu_solve(  pcols , pver , ncol  ,                         &
+                              q(1,1,m) , ca, tmpm  , dnom  , ntop  , nbot  , cd_top )
+       end if
+    end do
+
+    return
+  end subroutine compute_vdiff
+
+  ! =============================================================================== !
+  !                                                                                 !
+  ! =============================================================================== !
+
+  subroutine vd_lu_decomp( pcols, pver, ncol ,                        &
+                           ksrf , kv  , tmpi , rpdel, ztodt , cc_top, &
+                           ca   , cc  , dnom , ze   , ntop  , nbot    )
+    !---------------------------------------------------------------------- !
+    ! Determine superdiagonal (ca(k)) and subdiagonal (cc(k)) coeffs of the ! 
+    ! tridiagonal diffusion matrix.                                         ! 
+    ! The diagonal elements (1+ca(k)+cc(k)) are not required by the solver. !
+    ! Also determine ze factor and denominator for ze and zf (see solver).  !
+    !---------------------------------------------------------------------- !
+
+    ! --------------------- !
+    ! Input-Output Argument !
+    ! --------------------- !
+
+    integer,  intent(in)  :: pcols                 ! Number of allocated atmospheric columns
+    integer,  intent(in)  :: pver                  ! Number of allocated atmospheric levels 
+    integer,  intent(in)  :: ncol                  ! Number of computed atmospheric columns
+    integer,  intent(in)  :: ntop                  ! Top level to operate on
+    integer,  intent(in)  :: nbot                  ! Bottom level to operate on
+    real(r8), intent(in)  :: ksrf(pcols)           ! Surface "drag" coefficient [ kg/s/m2 ]
+    real(r8), intent(in)  :: kv(pcols,pver+1)      ! Vertical diffusion coefficients [ m2/s ]
+    real(r8), intent(in)  :: tmpi(pcols,pver+1)    ! dt*(g/R)**2/dp*pi(k+1)/(.5*(tm(k+1)+tm(k))**2
+    real(r8), intent(in)  :: rpdel(pcols,pver)     ! 1./pdel  (thickness bet interfaces)
+    real(r8), intent(in)  :: ztodt                 ! 2 delta-t [ s ]
+    real(r8), intent(in)  :: cc_top(pcols)         ! Lower diagonal on top interface (for fixed ubc only)
+
+    real(r8), intent(out) :: ca(pcols,pver)        ! Upper diagonal
+    real(r8), intent(out) :: cc(pcols,pver)        ! Lower diagonal
+    real(r8), intent(out) :: dnom(pcols,pver)      ! 1./(1. + ca(k) + cc(k) - cc(k)*ze(k-1))
+    real(r8), intent(out) :: ze(pcols,pver)        ! Term in tri-diag. matrix system
+
+    ! --------------- !
+    ! Local Variables !
+    ! --------------- !
+
+    integer :: i                                   ! Longitude index
+    integer :: k                                   ! Vertical  index
+
+    ! ----------------------- !
+    ! Main Computation Begins !
+    ! ----------------------- !
+
+    ! Determine superdiagonal (ca(k)) and subdiagonal (cc(k)) coeffs of the 
+    ! tridiagonal diffusion matrix. The diagonal elements  (cb=1+ca+cc) are
+    ! a combination of ca and cc; they are not required by the solver.
+
+    do k = nbot - 1, ntop, -1
+       do i = 1, ncol
+          ca(i,k  ) = kv(i,k+1) * tmpi(i,k+1) * rpdel(i,k  )
+          cc(i,k+1) = kv(i,k+1) * tmpi(i,k+1) * rpdel(i,k+1)
+       end do
+    end do
+
+    ! The bottom element of the upper diagonal (ca) is zero (element not used).
+    ! The subdiagonal (cc) is not needed in the solver.
+
+    do i = 1, ncol
+       ca(i,nbot) = 0._r8
+    end do
+
+    ! Calculate e(k).  This term is 
+    ! required in solution of tridiagonal matrix defined by implicit diffusion eqn.
+
+    do i = 1, ncol
+       dnom(i,nbot) = 1._r8/(1._r8 + cc(i,nbot) + ksrf(i)*ztodt*gravit*rpdel(i,nbot))
+       ze(i,nbot)   = cc(i,nbot)*dnom(i,nbot)
+    end do
+
+    do k = nbot - 1, ntop + 1, -1
+       do i = 1, ncol
+          dnom(i,k) = 1._r8/(1._r8 + ca(i,k) + cc(i,k) - ca(i,k)*ze(i,k+1))
+          ze(i,k)   = cc(i,k)*dnom(i,k)
+       end do
+    end do
+
+    do i = 1, ncol
+       dnom(i,ntop) = 1._r8/(1._r8 + ca(i,ntop) + cc_top(i) - ca(i,ntop)*ze(i,ntop+1))
+    end do
+
+    return
+  end subroutine vd_lu_decomp
+
+  ! =============================================================================== !
+  !                                                                                 !
+  ! =============================================================================== !
+
+  subroutine vd_lu_solve( pcols , pver , ncol , &
+                          q     , ca   , ze   , dnom , ntop , nbot , cd_top )
+    !----------------------------------------------------------------------------------- !
+    ! Solve the implicit vertical diffusion equation with zero flux boundary conditions. !
+    ! Procedure for solution of the implicit equation follows Richtmyer and              !
+    ! Morton (1967,pp 198-200).                                                          !
+    !                                                                                    !
+    ! The equation solved is                                                             !
+    !                                                                                    !  
+    !     -ca(k)*q(k+1) + cb(k)*q(k) - cc(k)*q(k-1) = d(k),                              !
+    !                                                                                    !
+    ! where d(k) is the input profile and q(k) is the output profile                     !
+    !                                                                                    ! 
+    ! The solution has the form                                                          !
+    !                                                                                    !
+    !     q(k) = ze(k)*q(k-1) + zf(k)                                                    !
+    !                                                                                    !
+    !     ze(k) = cc(k) * dnom(k)                                                        !
+    !                                                                                    !  
+    !     zf(k) = [d(k) + ca(k)*zf(k+1)] * dnom(k)                                       !
+    !                                                                                    !
+    !     dnom(k) = 1/[cb(k) - ca(k)*ze(k+1)] =  1/[1 + ca(k) + cc(k) - ca(k)*ze(k+1)]   !
+    !                                                                                    !
+    ! Note that the same routine is used for temperature, momentum and tracers,          !
+    ! and that input variables are replaced.                                             !
+    ! ---------------------------------------------------------------------------------- ! 
+
+    ! --------------------- !
+    ! Input-Output Argument !
+    ! --------------------- !
+
+    integer,  intent(in)    :: pcols                  ! Number of allocated atmospheric columns
+    integer,  intent(in)    :: pver                   ! Number of allocated atmospheric levels 
+    integer,  intent(in)    :: ncol                   ! Number of computed atmospheric columns
+    integer,  intent(in)    :: ntop                   ! Top level to operate on
+    integer,  intent(in)    :: nbot                   ! Bottom level to operate on
+    real(r8), intent(in)    :: ca(pcols,pver)         ! -Upper diag coeff.of tri-diag matrix
+    real(r8), intent(in)    :: ze(pcols,pver)         ! Term in tri-diag solution
+    real(r8), intent(in)    :: dnom(pcols,pver)       ! 1./(1. + ca(k) + cc(k) - ca(k)*ze(k+1))
+    real(r8), intent(in)    :: cd_top(pcols)          ! cc_top * ubc value
+
+    real(r8), intent(inout) :: q(pcols,pver)          ! Constituent field
+
+    ! --------------- !
+    ! Local Variables ! 
+    ! --------------- !
+
+    real(r8)                :: zf(pcols,pver)         ! Term in tri-diag solution
+    integer                    i, k                   ! Longitude, vertical indices
+
+    ! ----------------------- !
+    ! Main Computation Begins !
+    ! ----------------------- !
+
+    ! Calculate zf(k). Terms zf(k) and ze(k) are required in solution of 
+    ! tridiagonal matrix defined by implicit diffusion equation.
+    ! Note that only levels ntop through nbot need be solved for.
+
+    do i = 1, ncol
+       zf(i,nbot) = q(i,nbot)*dnom(i,nbot)
+    end do
+
+    do k = nbot - 1, ntop + 1, -1
+       do i = 1, ncol
+          zf(i,k) = (q(i,k) + ca(i,k)*zf(i,k+1))*dnom(i,k)
+       end do
+    end do
+
+    ! Include boundary condition on top element
+
+    k = ntop
+    do i = 1, ncol
+       zf(i,k) = (q(i,k) + cd_top(i) + ca(i,k)*zf(i,k+1))*dnom(i,k)
+    end do
+
+    ! Perform back substitution
+
+    do i = 1, ncol
+       q(i,ntop) = zf(i,ntop)
+    end do
+
+    do k = ntop + 1, nbot, +1
+       do i = 1, ncol
+          q(i,k) = zf(i,k) + ze(i,k)*q(i,k-1)
+       end do
+    end do
+
+    return
+  end subroutine vd_lu_solve
+
+  ! =============================================================================== !
+  !                                                                                 !
+  ! =============================================================================== !
+  
+  character(128) function vdiff_select( fieldlist, name, qindex )
+    ! --------------------------------------------------------------------- !
+    ! This function sets the field with incoming name as one to be diffused !
+    ! --------------------------------------------------------------------- !
+    type(vdiff_selector), intent(inout)        :: fieldlist
+    character(*),         intent(in)           :: name
+    integer,              intent(in), optional :: qindex
+    
+    vdiff_select = ''
+    select case (name)
+    case ('u','U')
+       fieldlist%fields(1) = .true.
+    case ('v','V')
+       fieldlist%fields(2) = .true.
+    case ('s','S')
+       fieldlist%fields(3) = .true.
+    case ('q','Q')
+       if( present(qindex) ) then
+           fieldlist%fields(3 + qindex) = .true.
+       else
+           fieldlist%fields(4) = .true.
+       endif
+    case default
+       write(vdiff_select,*) 'Bad argument to vdiff_index: ', name
+    end select
+    return
+    
+  end function vdiff_select
+
+  type(vdiff_selector) function not(a)
+    ! ------------------------------------------------------------- !
+    ! This function extends .not. to operate on type vdiff_selector !
+    ! ------------------------------------------------------------- !    
+    type(vdiff_selector), intent(in)  :: a
+    allocate(not%fields(size(a%fields)))
+    not%fields(:) = .not. a%fields(:)
+  end function not
+
+  logical function my_any(a)
+    ! -------------------------------------------------- !
+    ! This function extends the intrinsic function 'any' ! 
+    ! to operate on type vdiff_selector                  ! 
+    ! -------------------------------------------------- !
+    type(vdiff_selector), intent(in) :: a
+    my_any = any(a%fields)
+  end function my_any
+
+  logical function diffuse(fieldlist,name,qindex)
+    ! ---------------------------------------------------------------------------- !
+    ! This function reports whether the field with incoming name is to be diffused !
+    ! ---------------------------------------------------------------------------- !
+    type(vdiff_selector), intent(in)           :: fieldlist
+    character(*),         intent(in)           :: name
+    integer,              intent(in), optional :: qindex
+    
+    select case (name)
+    case ('u','U')
+       diffuse = fieldlist%fields(1)
+    case ('v','V')
+       diffuse = fieldlist%fields(2)
+    case ('s','S')
+       diffuse = fieldlist%fields(3)
+    case ('q','Q')
+       if( present(qindex) ) then
+           diffuse = fieldlist%fields(3 + qindex)
+       else
+           diffuse = fieldlist%fields(4)
+       endif
+    case default
+       diffuse = .false.
+    end select
+    return
+  end function diffuse
+
+end module diffusion_solver
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_bl_eddy_diff.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_bl_eddy_diff.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_bl_eddy_diff.F	(revision 17)
@@ -0,0 +1,4011 @@
+#define WRF_PORT
+
+module eddy_diff
+
+  !--------------------------------------------------------------------------------- !
+  !                                                                                  !
+  ! The University of Washington Moist Turbulence Scheme to compute eddy diffusion   ! 
+  ! coefficients associated with dry and moist turbulences in the whole              !
+  ! atmospheric layers.                                                              !
+  !                                                                                  !
+  ! For detailed description of the code and its performances, see                   !
+  !                                                                                  !
+  ! 1.'A new moist turbulence parametrization in the Community Atmosphere Model'     !
+  !    by Christopher S. Bretherton and Sungsu Park. J. Climate. 2009. 22. 3422-3448 !
+  ! 2.'The University of Washington shallow convection and moist turbulence schemes  !
+  !    and their impact on climate simulations with the Community Atmosphere Model'  !
+  !    by Sungsu Park and Christopher S. Bretherton. J. Climate. 2009. 22. 3449-3469 !
+  !                                                                                  !
+  ! For questions on the scheme and code, send an email to                           !
+  !     Sungsu Park      at sungsup@ucar.edu (tel: 303-497-1375)                     !
+  !     Chris Bretherton at breth@washington.edu                                     !
+  !                                                                                  ! 
+  ! Developed by Chris Bretherton at the University of Washington, Seattle, WA.      !
+  !              Sungsu Park      at the CGD/NCAR, Boulder, CO.                      !
+  ! Last coded on May.2006, Dec.2009 by Sungsu Park.                                 !
+  !                                                                                  !  
+  !--------------------------------------------------------------------------------- !
+
+  use diffusion_solver, only : vdiff_selector
+#ifndef WRF_PORT 
+  use cam_history,      only : outfld, addfld, phys_decomp
+  use cam_logfile,      only : iulog
+  use ppgrid,           only : pver
+#else
+  use module_cam_support,   only: iulog, pver,outfld, addfld, phys_decomp  
+#endif
+
+  implicit none
+  private
+  save
+
+  public init_eddy_diff
+  public compute_eddy_diff
+
+  type(vdiff_selector)        :: fieldlist_wet                  ! Logical switches for moist mixing ratio diffusion
+  type(vdiff_selector)        :: fieldlist_dry                  ! Logical switches for dry   mixing ratio diffusion
+  integer,          parameter :: r8 = selected_real_kind(12)    ! 8 byte real
+
+  ! --------------------------------- !
+  ! PBL Parameters used in the UW PBL !
+  ! --------------------------------- !
+
+  character,        parameter :: sftype         = 'l'           ! Method for calculating saturation fraction
+
+  character(len=4), parameter :: choice_evhc    = 'maxi'        ! 'orig',   'ramp',   'maxi'   : recommended to be used with choice_radf 
+  character(len=6), parameter :: choice_radf    = 'maxi'        ! 'orig',   'ramp',   'maxi'   : recommended to be used with choice_evhc 
+  character(len=6), parameter :: choice_SRCL    = 'nonamb'      ! 'origin', 'remove', 'nonamb'
+ 
+  character(len=6), parameter :: choice_tunl    = 'rampcl'      ! 'origin', 'rampsl'(Sungsu), 'rampcl'(Chris)
+  real(r8),         parameter :: ctunl          =  2._r8        !  Maximum asympt leng = ctunl*tunl when choice_tunl = 'rampsl(cl)' [ no unit ]
+  character(len=6), parameter :: choice_leng    = 'origin'      ! 'origin', 'takemn'
+  real(r8),         parameter :: cleng          =  3._r8        !  Order of 'leng' when choice_leng = 'origin' [ no unit ]
+  character(len=6), parameter :: choice_tkes    = 'ibprod'      ! 'ibprod' (include tkes in computing bprod), 'ebprod'(exclude)
+
+  ! Parameters for 'sedimenttaion-entrainment feedback' for liquid stratus 
+  ! If .false.,  no sedimentation entrainment feedback ( i.e., use default evhc )
+
+  logical,          parameter :: id_sedfact     = .false.
+  real(r8),         parameter :: ased           =  9._r8        !  Valid only when id_sedfact = .true.
+
+  ! --------------------------------------------------------------------------------------------------- !
+  ! Parameters governing entrainment efficiency A = a1l(i)*evhc, evhc = 1 + a2l * a3l * L * ql / jt2slv !
+  ! Here, 'ql' is cloud-top LWC and 'jt2slv' is the jump in 'slv' across                                !
+  ! the cloud-top entrainment zone ( across two grid layers to consider full mixture )                  !
+  ! --------------------------------------------------------------------------------------------------- !
+
+  real(r8),         parameter :: a1l            =   0.10_r8     ! Dry entrainment efficiency for TKE closure
+                                                                ! a1l = 0.2*tunl*erat^-1.5, where erat = <e>/wstar^2 for dry CBL =  0.3.
+
+  real(r8),         parameter :: a1i            =   0.2_r8      ! Dry entrainment efficiency for wstar closure
+  real(r8),         parameter :: ccrit          =   0.5_r8      ! Minimum allowable sqrt(tke)/wstar. Used in solving cubic equation for 'ebrk'
+  real(r8),         parameter :: wstar3factcrit =   0.5_r8      ! 1/wstar3factcrit is the maximally allowed enhancement of 'wstar3' due to entrainment.
+
+  real(r8),         parameter :: a2l            =   30._r8      ! Moist entrainment enhancement param (recommended range : 10~30 )
+  real(r8),         parameter :: a3l            =   0.8_r8      ! Approximation to a complicated thermodynamic parameters
+
+  real(r8),         parameter :: jbumin         =   .001_r8     ! Minimum buoyancy jump at an entrainment jump, [m/s2]
+  real(r8),         parameter :: evhcmax        =   10._r8      ! Upper limit of evaporative enhancement factor
+
+  real(r8),         parameter :: ustar_min      =   0.01_r8     ! Minimum permitted value of ustar [ m/s ] 
+  real(r8),         parameter :: onet           =   1._r8/3._r8 ! 1/3 power in wind gradient expression [ no unit ]
+#ifndef WRF_PORT
+  !pver is not a parameter in cam_support module in WRF, therefore ncvmax cannot be equated to pver as parameter 
+  integer,          parameter :: ncvmax         =   pver        ! Max numbers of CLs (good to set to 'pver')
+#endif
+  integer                     :: ncvmax                         ! Max numbers of CLs (good to set to 'pver') !Pver is not a parameter in cam_support module
+  real(r8),         parameter :: qmin           =   1.e-5_r8    ! Minimum grid-mean LWC counted as clouds [kg/kg]
+  real(r8),         parameter :: ntzero         =   1.e-12_r8   ! Not zero (small positive number used in 's2')
+  real(r8),         parameter :: b1             =   5.8_r8      ! TKE dissipation D = e^3/(b1*leng), e = b1*W.
+  real(r8)                    :: b123                           ! b1**(2/3)
+  real(r8),         parameter :: tunl           =   0.085_r8    ! Asympt leng = tunl*(turb lay depth)
+  real(r8),         parameter :: alph1          =   0.5562_r8   ! alph1~alph5 : Galperin instability function parameters
+  real(r8),         parameter :: alph2          =  -4.3640_r8   !               These coefficients are used to calculate 
+  real(r8),         parameter :: alph3          = -34.6764_r8   !               'sh' and 'sm' from 'gh'.
+  real(r8),         parameter :: alph4          =  -6.1272_r8   !
+  real(r8),         parameter :: alph5          =   0.6986_r8   !
+  real(r8),         parameter :: ricrit         =   0.19_r8     ! Critical Richardson number for turbulence. Can be any value >= 0.19.
+  real(r8),         parameter :: ae             =   1._r8       ! TKE transport efficiency [no unit]
+  real(r8),         parameter :: rinc           =  -0.04_r8     ! Minimum W/<W> used for CL merging test 
+  real(r8),         parameter :: wpertmin       =   1.e-6_r8    ! Minimum PBL eddy vertical velocity perturbation
+  real(r8),         parameter :: wfac           =   1._r8       ! Ratio of 'wpert' to sqrt(tke) for CL.
+  real(r8),         parameter :: tfac           =   1._r8       ! Ratio of 'tpert' to (w't')/wpert for CL. Same ratio also used for q
+  real(r8),         parameter :: fak            =   8.5_r8      ! Constant in surface temperature excess for stable STL. [ no unit ]         
+  real(r8),         parameter :: rcapmin        =   0.1_r8      ! Minimum allowable e/<e> in a CL
+  real(r8),         parameter :: rcapmax        =   2.0_r8      ! Maximum allowable e/<e> in a CL
+  real(r8),         parameter :: tkemax         =  20._r8       ! TKE is capped at tkemax [m2/s2]
+  real(r8),         parameter :: lambda         =   0.5_r8      ! Under-relaxation factor ( 0 < lambda =< 1 )
+
+  logical,          parameter :: use_kvf        =  .false.      ! .true. (.false.) : initialize kvh/kvm =  kvf ( 0. )
+  logical,          parameter :: use_dw_surf    =  .true.       ! Used in 'zisocl'. Default is 'true'
+                                                                ! If 'true', surface interfacial energy does not contribute to the CL mean
+                                                                !            stbility functions after finishing merging.     For this case,
+                                                                !           'dl2n2_surf' is only used for a merging test based on 'l2n2'
+                                                                ! If 'false',surface interfacial enery explicitly contribute to    CL mean
+                                                                !            stability functions after finishing merging.    For this case,
+                                                                !           'dl2n2_surf' and 'dl2s2_surf' are directly used for calculating
+                                                                !            surface interfacial layer energetics
+
+  logical,          parameter :: set_qrlzero    =  .false.      ! .true. ( .false.) : turning-off ( on) radiative-turbulence interaction by setting qrl = 0.
+
+  ! ------------------------------------- !
+  ! PBL Parameters not used in the UW PBL !
+  ! ------------------------------------- !
+
+  real(r8),         parameter :: pblmaxp        =  4.e4_r8      ! PBL max depth in pressure units. 
+  real(r8),         parameter :: zkmin          =  0.01_r8      ! Minimum kneutral*f(ri). 
+  real(r8),         parameter :: betam          = 15.0_r8       ! Constant in wind gradient expression.
+  real(r8),         parameter :: betas          =  5.0_r8       ! Constant in surface layer gradient expression.
+  real(r8),         parameter :: betah          = 15.0_r8       ! Constant in temperature gradient expression.
+  real(r8),         parameter :: fakn           =  7.2_r8       ! Constant in turbulent prandtl number.
+  real(r8),         parameter :: ricr           =  0.3_r8       ! Critical richardson number.
+  real(r8),         parameter :: sffrac         =  0.1_r8       ! Surface layer fraction of boundary layer
+  real(r8),         parameter :: binm           =  betam*sffrac ! betam * sffrac
+  real(r8),         parameter :: binh           =  betah*sffrac ! betah * sffrac
+
+  ! ------------------------------------------------------- !
+  ! PBL constants set using values from other parts of code !
+  ! ------------------------------------------------------- !
+
+  real(r8)                    :: cpair                          ! Specific heat of dry air
+  real(r8)                    :: rair                           ! Gas const for dry air
+  real(r8)                    :: zvir                           ! rh2o/rair - 1
+  real(r8)                    :: latvap                         ! Latent heat of vaporization
+  real(r8)                    :: latice                         ! Latent heat of fusion
+  real(r8)                    :: latsub                         ! Latent heat of sublimation
+  real(r8)                    :: g                              ! Gravitational acceleration
+  real(r8)                    :: vk                             ! Von Karman's constant
+  real(r8)                    :: ccon                           ! fak * sffrac * vk
+
+  integer                     :: ntop_turb                      ! Top interface level to which turbulent vertical diffusion is applied ( = 1 )
+  integer                     :: nbot_turb                      ! Bottom interface level to which turbulent vertical diff is applied ( = pver )
+
+  real(r8), allocatable       :: ml2(:)                         ! Mixing lengths squared. Not used in the UW PBL. Used for computing free air diffusivity.
+
+  CONTAINS
+
+  !============================================================================ !
+  !                                                                             !
+  !============================================================================ !
+  
+  subroutine init_eddy_diff( kind, pver, gravx, cpairx, rairx, zvirx, & 
+                             latvapx, laticex, ntop_eddy, nbot_eddy, hypm, vkx )
+    !---------------------------------------------------------------- ! 
+    ! Purpose:                                                        !
+    ! Initialize time independent constants/variables of PBL package. !
+    !---------------------------------------------------------------- !
+    use diffusion_solver, only: init_vdiff, vdiff_select
+#ifndef WRF_PORT 
+    use cam_history,      only: outfld, addfld, phys_decomp
+#else
+    use module_cam_support,   only: outfld, addfld, phys_decomp  
+#endif
+    implicit none
+    ! --------- !
+    ! Arguments !
+    ! --------- !
+    integer,  intent(in) :: kind       ! Kind of reals being passed in
+    integer,  intent(in) :: pver       ! Number of vertical layers
+    integer,  intent(in) :: ntop_eddy  ! Top interface level to which eddy vertical diffusivity is applied ( = 1 )
+    integer,  intent(in) :: nbot_eddy  ! Bottom interface level to which eddy vertical diffusivity is applied ( = pver )
+    real(r8), intent(in) :: gravx      ! Acceleration of gravity
+    real(r8), intent(in) :: cpairx     ! Specific heat of dry air
+    real(r8), intent(in) :: rairx      ! Gas constant for dry air
+    real(r8), intent(in) :: zvirx      ! rh2o/rair - 1
+    real(r8), intent(in) :: latvapx    ! Latent heat of vaporization
+    real(r8), intent(in) :: laticex    ! Latent heat of fusion
+    real(r8), intent(in) :: hypm(pver) ! Reference pressures at midpoints
+    real(r8), intent(in) :: vkx        ! Von Karman's constant
+
+    character(128)       :: errstring  ! Error status for init_vdiff
+    integer              :: k          ! Vertical loop index
+
+    !As pver is not parameter in the cam_support module in WRF, a value to ncvmax is given here
+    ncvmax = pver        ! Max numbers of CLs (good to set to 'pver') 
+
+    if( kind .ne. r8 ) then
+        write(iulog,*) 'wrong KIND of reals passed to init_diffusvity -- exiting.'
+        stop 'init_eddy_diff'
+    endif
+
+    ! --------------- !
+    ! Basic constants !
+    ! --------------- !
+
+    cpair     = cpairx
+    rair      = rairx
+    g         = gravx
+    zvir      = zvirx
+    latvap    = latvapx
+    latice    = laticex
+    latsub    = latvap + latice
+    vk        = vkx
+    ccon      = fak*sffrac*vk
+    ntop_turb = ntop_eddy
+    nbot_turb = nbot_eddy
+    b123      = b1**(2._r8/3._r8)
+
+    ! Set the square of the mixing lengths. Only for CAM3 HB PBL scheme.
+    ! Not used for UW moist PBL. Used for free air eddy diffusivity.
+
+#if 0
+    allocate(ml2(pver+1))
+    ml2(1:ntop_turb) = 0._r8
+    do k = ntop_turb + 1, nbot_turb
+       ml2(k) = 30.0_r8**2
+    end do
+    ml2(nbot_turb+1:pver+1) = 0._r8
+#endif
+    
+    ! Initialize diffusion solver module
+
+    call init_vdiff(r8, 1, rair, g, fieldlist_wet, fieldlist_dry, errstring)
+
+    ! Select the fields which will be diffused 
+
+    if(vdiff_select(fieldlist_wet,'s').ne.'')   write(iulog,*) 'error: ', vdiff_select(fieldlist_wet,'s')
+    if(vdiff_select(fieldlist_wet,'q',1).ne.'') write(iulog,*) 'error: ', vdiff_select(fieldlist_wet,'q',1)
+    if(vdiff_select(fieldlist_wet,'u').ne.'')   write(iulog,*) 'error: ', vdiff_select(fieldlist_wet,'u')
+    if(vdiff_select(fieldlist_wet,'v').ne.'')   write(iulog,*) 'error: ', vdiff_select(fieldlist_wet,'v')
+
+    ! ------------------------------------------------------------------- !
+    ! Writing outputs for detailed analysis of UW moist turbulence scheme !
+    ! ------------------------------------------------------------------- !
+
+    call addfld('UW_errorPBL',      'm2/s',    1,      'A',  'Error function of UW PBL',                              phys_decomp )
+    call addfld('UW_n2',            's-2',     pver,   'A',  'Buoyancy Frequency, LI',                                phys_decomp )
+    call addfld('UW_s2',            's-2',     pver,   'A',  'Shear Frequency, LI',                                   phys_decomp )
+    call addfld('UW_ri',            'no',      pver,   'A',  'Interface Richardson Number, I',                        phys_decomp )
+    call addfld('UW_sfuh',          'no',      pver,   'A',  'Upper-Half Saturation Fraction, L',                     phys_decomp )
+    call addfld('UW_sflh',          'no',      pver,   'A',  'Lower-Half Saturation Fraction, L',                     phys_decomp )
+    call addfld('UW_sfi',           'no',      pver+1, 'A',  'Interface Saturation Fraction, I',                      phys_decomp )
+    call addfld('UW_cldn',          'no',      pver,   'A',  'Cloud Fraction, L',                                     phys_decomp )
+    call addfld('UW_qrl',           'g*W/m2',  pver,   'A',  'LW cooling rate, L',                                    phys_decomp )
+    call addfld('UW_ql',            'kg/kg',   pver,   'A',  'ql(LWC), L',                                            phys_decomp )
+    call addfld('UW_chu',           'g*kg/J',  pver+1, 'A',  'Buoyancy Coefficient, chu, I',                          phys_decomp )
+    call addfld('UW_chs',           'g*kg/J',  pver+1, 'A',  'Buoyancy Coefficient, chs, I',                          phys_decomp )
+    call addfld('UW_cmu',           'g/kg/kg', pver+1, 'A',  'Buoyancy Coefficient, cmu, I',                          phys_decomp )
+    call addfld('UW_cms',           'g/kg/kg', pver+1, 'A',  'Buoyancy Coefficient, cms, I',                          phys_decomp )    
+    call addfld('UW_tke',           'm2/s2',   pver+1, 'A',  'TKE, I',                                                phys_decomp )
+    call addfld('UW_wcap',          'm2/s2',   pver+1, 'A',  'Wcap, I',                                               phys_decomp )        
+    call addfld('UW_bprod',         'm2/s3',   pver+1, 'A',  'Buoyancy production, I',                                phys_decomp )
+    call addfld('UW_sprod',         'm2/s3',   pver+1, 'A',  'Shear production, I',                                   phys_decomp )    
+    call addfld('UW_kvh',           'm2/s',    pver+1, 'A',  'Eddy diffusivity of heat, I',                           phys_decomp )
+    call addfld('UW_kvm',           'm2/s',    pver+1, 'A',  'Eddy diffusivity of uv, I',                             phys_decomp )
+    call addfld('UW_pblh',          'm',       1,      'A',  'PBLH, 1',                                               phys_decomp )
+    call addfld('UW_pblhp',         'Pa',      1,      'A',  'PBLH pressure, 1',                                      phys_decomp )
+    call addfld('UW_tpert',         'K',       1,      'A',  'Convective T excess, 1',                                phys_decomp )
+    call addfld('UW_qpert',         'kg/kg',   1,      'A',  'Convective qt excess, I',                               phys_decomp )
+    call addfld('UW_wpert',         'm/s',     1,      'A',  'Convective W excess, I',                                phys_decomp )
+    call addfld('UW_ustar',         'm/s',     1,      'A',  'Surface Frictional Velocity, 1',                        phys_decomp )
+    call addfld('UW_tkes',          'm2/s2',   1,      'A',  'Surface TKE, 1',                                        phys_decomp )
+    call addfld('UW_minpblh',       'm',       1,      'A',  'Minimum PBLH, 1',                                       phys_decomp )
+    call addfld('UW_turbtype',      'no',      pver+1, 'A',  'Interface Turbulence Type, I',                          phys_decomp )    
+    call addfld('UW_kbase_o',       'no',      ncvmax, 'A',  'Initial CL Base Exterbal Interface Index, CL',          phys_decomp )
+    call addfld('UW_ktop_o',        'no',      ncvmax, 'A',  'Initial Top Exterbal Interface Index, CL',              phys_decomp )
+    call addfld('UW_ncvfin_o',      '#',       1,      'A',  'Initial Total Number of CL regimes, CL',                phys_decomp )
+    call addfld('UW_kbase_mg',      'no',      ncvmax, 'A',  'kbase after merging, CL',                               phys_decomp )
+    call addfld('UW_ktop_mg',       'no',      ncvmax, 'A',  'ktop after merging, CL',                                phys_decomp )
+    call addfld('UW_ncvfin_mg',     '#',       1,      'A',  'ncvfin after merging, CL',                              phys_decomp )
+    call addfld('UW_kbase_f',       'no',      ncvmax, 'A',  'Final kbase with SRCL, CL',                             phys_decomp )
+    call addfld('UW_ktop_f',        'no',      ncvmax, 'A',  'Final ktop with SRCL, CL',                              phys_decomp )
+    call addfld('UW_ncvfin_f',      '#',       1,      'A',  'Final ncvfin with SRCL, CL',                            phys_decomp )
+    call addfld('UW_wet',           'm/s',     ncvmax, 'A',  'Entrainment rate at CL top, CL',                        phys_decomp )
+    call addfld('UW_web',           'm/s',     ncvmax, 'A',  'Entrainment rate at CL base, CL',                       phys_decomp )
+    call addfld('UW_jtbu',          'm/s2',    ncvmax, 'A',  'Buoyancy jump across CL top, CL',                       phys_decomp )
+    call addfld('UW_jbbu',          'm/s2',    ncvmax, 'A',  'Buoyancy jump across CL base, CL',                      phys_decomp )
+    call addfld('UW_evhc',          'no',      ncvmax, 'A',  'Evaporative enhancement factor, CL',                    phys_decomp )
+    call addfld('UW_jt2slv',        'J/kg',    ncvmax, 'A',  'slv jump for evhc, CL',                                 phys_decomp )
+    call addfld('UW_n2ht',          's-2',     ncvmax, 'A',  'n2 at just below CL top interface, CL',                 phys_decomp )
+    call addfld('UW_n2hb',          's-2',     ncvmax, 'A',  'n2 at just above CL base interface',                    phys_decomp )
+    call addfld('UW_lwp',           'kg/m2',   ncvmax, 'A',  'LWP in the CL top layer, CL',                           phys_decomp )
+    call addfld('UW_optdepth',      'no',      ncvmax, 'A',  'Optical depth of the CL top layer, CL',                 phys_decomp )
+    call addfld('UW_radfrac',       'no',      ncvmax, 'A',  'Fraction of radiative cooling confined in the CL top',  phys_decomp )
+    call addfld('UW_radf',          'm2/s3',   ncvmax, 'A',  'Buoyancy production at the CL top by radf, I',          phys_decomp )        
+    call addfld('UW_wstar',         'm/s',     ncvmax, 'A',  'Convective velocity, Wstar, CL',                        phys_decomp )
+    call addfld('UW_wstar3fact',    'no',      ncvmax, 'A',  'Enhancement of wstar3 due to entrainment, CL',          phys_decomp )
+    call addfld('UW_ebrk',          'm2/s2',   ncvmax, 'A',  'CL-averaged TKE, CL',                                   phys_decomp )
+    call addfld('UW_wbrk',          'm2/s2',   ncvmax, 'A',  'CL-averaged W, CL',                                     phys_decomp )
+    call addfld('UW_lbrk',          'm',       ncvmax, 'A',  'CL internal thickness, CL',                             phys_decomp )
+    call addfld('UW_ricl',          'no',      ncvmax, 'A',  'CL-averaged Ri, CL',                                    phys_decomp )
+    call addfld('UW_ghcl',          'no',      ncvmax, 'A',  'CL-averaged gh, CL',                                    phys_decomp )
+    call addfld('UW_shcl',          'no',      ncvmax, 'A',  'CL-averaged sh, CL',                                    phys_decomp )
+    call addfld('UW_smcl',          'no',      ncvmax, 'A',  'CL-averaged sm, CL',                                    phys_decomp )
+    call addfld('UW_gh',            'no',      pver+1, 'A',  'gh at all interfaces, I',                               phys_decomp )
+    call addfld('UW_sh',            'no',      pver+1, 'A',  'sh at all interfaces, I',                               phys_decomp )
+    call addfld('UW_sm',            'no',      pver+1, 'A',  'sm at all interfaces, I',                               phys_decomp )
+    call addfld('UW_ria',           'no',      pver+1, 'A',  'ri at all interfaces, I',                               phys_decomp )
+    call addfld('UW_leng',          'm/s',     pver+1, 'A',  'Turbulence length scale, I',                            phys_decomp )
+
+  return
+
+  end subroutine init_eddy_diff
+
+  !=============================================================================== !
+  !                                                                                !
+  !=============================================================================== !
+  
+  subroutine compute_eddy_diff( lchnk  ,                                                            &
+                                pcols  , pver   , ncol     , t       , qv       , ztodt   ,         &
+                                ql     , qi     , s        , rpdel   , cldn     , qrl     , wsedl , &
+                                z      , zi     , pmid     , pi      , u        , v       ,         &
+                                taux   , tauy   , shflx    , qflx    , wstarent , nturb   ,         &
+                                ustar  , pblh   , kvm_in   , kvh_in  , kvm_out  , kvh_out , kvq   , & 
+                                cgh    , cgs    , tpert    , qpert   , wpert    , tke     , bprod , &
+                                sprod  , sfi    , qsat     , kvinit  ,                              &
+                                tauresx, tauresy, ksrftms  ,                                        &
+                                ipbl   , kpblh  , wstarPBL , turbtype, sm_aw )
+       
+    !-------------------------------------------------------------------- ! 
+    ! Purpose: Interface to compute eddy diffusivities.                   !
+    !          Eddy diffusivities are calculated in a fully implicit way  !
+    !          through iteration process.                                 !   
+    ! Author:  Sungsu Park. August. 2006.                                 !
+    !                       May.    2008.                                 !
+    !-------------------------------------------------------------------- !
+    use diffusion_solver, only: compute_vdiff
+#ifndef WRF_PORT 
+    use cam_history,      only: outfld, addfld, phys_decomp
+  ! use physics_types,    only: physics_state
+    use phys_debug_util,  only: phys_debug_col
+    use time_manager,     only: is_first_step, get_nstep
+#else
+    use module_cam_support,   only: outfld, addfld, phys_decomp 
+#endif
+
+    implicit none
+
+  ! type(physics_state)     :: state                     ! Physics state variables
+
+    ! --------------- !
+    ! Input Variables !
+    ! --------------- ! 
+
+    integer,  intent(in)    :: lchnk   
+    integer,  intent(in)    :: pcols                     ! Number of atmospheric columns [ # ]
+    integer,  intent(in)    :: pver                      ! Number of atmospheric layers  [ # ]
+    integer,  intent(in)    :: ncol                      ! Number of atmospheric columns [ # ]
+    integer,  intent(in)    :: nturb                     ! Number of iteration steps for calculating eddy diffusivity [ # ]
+    logical,  intent(in)    :: wstarent                  ! .true. means use the 'wstar' entrainment closure. 
+    logical,  intent(in)    :: kvinit                    ! 'true' means time step = 1 : used for initializing kvh, kvm (uses kvf or zero)
+    real(r8), intent(in)    :: ztodt                     ! Physics integration time step 2 delta-t [ s ]
+    real(r8), intent(in)    :: t(pcols,pver)             ! Temperature [K]
+    real(r8), intent(in)    :: qv(pcols,pver)            ! Water vapor  specific humidity [ kg/kg ]
+    real(r8), intent(in)    :: ql(pcols,pver)            ! Liquid water specific humidity [ kg/kg ]
+    real(r8), intent(in)    :: qi(pcols,pver)            ! Ice specific humidity [ kg/kg ]
+    real(r8), intent(in)    :: s(pcols,pver)             ! Dry static energy [ J/kg ]
+    real(r8), intent(in)    :: rpdel(pcols,pver)         ! 1./pdel where 'pdel' is thickness of the layer [ Pa ]
+    real(r8), intent(in)    :: cldn(pcols,pver)          ! Stratiform cloud fraction [ fraction ]
+    real(r8), intent(in)    :: qrl(pcols,pver)           ! LW cooling rate
+    real(r8), intent(in)    :: wsedl(pcols,pver)         ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ]
+    real(r8), intent(in)    :: z(pcols,pver)             ! Layer mid-point height above surface [ m ]
+    real(r8), intent(in)    :: zi(pcols,pver+1)          ! Interface height above surface [ m ]
+    real(r8), intent(in)    :: pmid(pcols,pver)          ! Layer mid-point pressure [ Pa ]
+    real(r8), intent(in)    :: pi(pcols,pver+1)          ! Interface pressure [ Pa ]
+    real(r8), intent(in)    :: u(pcols,pver)             ! Zonal velocity [ m/s ]
+    real(r8), intent(in)    :: v(pcols,pver)             ! Meridional velocity [ m/s ]
+    real(r8), intent(in)    :: taux(pcols)               ! Zonal wind stress at surface [ N/m2 ]
+    real(r8), intent(in)    :: tauy(pcols)               ! Meridional wind stress at surface [ N/m2 ]
+    real(r8), intent(in)    :: shflx(pcols)              ! Sensible heat flux at surface [ unit ? ]
+    real(r8), intent(in)    :: qflx(pcols)               ! Water vapor flux at surface [ unit ? ]
+    real(r8), intent(in)    :: kvm_in(pcols,pver+1)      ! kvm saved from last timestep [ m2/s ]
+    real(r8), intent(in)    :: kvh_in(pcols,pver+1)      ! kvh saved from last timestep [ m2/s ]
+    real(r8), intent(in)    :: ksrftms(pcols)            ! Surface drag coefficient of turbulent mountain stress [ unit ? ]
+
+    ! ---------------- !
+    ! Output Variables !
+    ! ---------------- ! 
+
+    real(r8), intent(out)   :: kvm_out(pcols,pver+1)     ! Eddy diffusivity for momentum [ m2/s ]
+    real(r8), intent(out)   :: kvh_out(pcols,pver+1)     ! Eddy diffusivity for heat [ m2/s ]
+    real(r8), intent(out)   :: kvq(pcols,pver+1)         ! Eddy diffusivity for constituents, moisture and tracers [ m2/s ] (note not having '_out')
+    real(r8), intent(out)   :: ustar(pcols)              ! Surface friction velocity [ m/s ]
+    real(r8), intent(out)   :: pblh(pcols)               ! PBL top height [ m ]
+    real(r8), intent(out)   :: cgh(pcols,pver+1)         ! Counter-gradient term for heat [ J/kg/m ]
+    real(r8), intent(out)   :: cgs(pcols,pver+1)         ! Counter-gradient star [ cg/flux ]
+    real(r8), intent(out)   :: tpert(pcols)              ! Convective temperature excess [ K ]
+    real(r8), intent(out)   :: qpert(pcols)              ! Convective humidity excess [ kg/kg ]
+    real(r8), intent(out)   :: wpert(pcols)              ! Turbulent velocity excess [ m/s ]
+    real(r8), intent(out)   :: tke(pcols,pver+1)         ! Turbulent kinetic energy [ m2/s2 ]
+    real(r8), intent(out)   :: bprod(pcols,pver+1)       ! Buoyancy production [ m2/s3 ] 
+    real(r8), intent(out)   :: sprod(pcols,pver+1)       ! Shear production [ m2/s3 ] 
+    real(r8), intent(out)   :: sfi(pcols,pver+1)         ! Interfacial layer saturation fraction [ fraction ]
+    real(r8), intent(out)   :: turbtype(pcols,pver+1)    ! Turbulence type identifier at all interfaces [ no unit ]
+    real(r8), intent(out)   :: sm_aw(pcols,pver+1)       ! Normalized Galperin instability function for momentum [ no unit ]
+                                                         ! This is 1 when neutral condition (Ri=0), 4.964 for maximum unstable case, and 0 when Ri > Ricrit=0.19. 
+    real(r8), intent(out)   :: ipbl(pcols)               ! If 1, PBL is CL, while if 0, PBL is STL.
+    real(r8), intent(out)   :: kpblh(pcols)              ! Layer index containing PBL top within or at the base interface
+    real(r8), intent(out)   :: wstarPBL(pcols)           ! Convective velocity within PBL [ m/s ]
+
+    ! ---------------------- !
+    ! Input-Output Variables !
+    ! ---------------------- ! 
+
+    real(r8), intent(inout) :: tauresx(pcols)            ! Residual stress to be added in vdiff to correct for turb
+    real(r8), intent(inout) :: tauresy(pcols)            ! Stress mismatch between sfc and atm accumulated in prior timesteps
+
+    ! --------------- !
+    ! Local Variables !
+    ! --------------- !
+
+    integer                    icol
+    integer                    i, k, iturb, status
+    integer,  external      :: qsat
+    character(128)          :: errstring                 ! Error status for compute_vdiff
+
+    real(r8)                :: tautotx(pcols)            ! Total stress including tms
+    real(r8)                :: tautoty(pcols)            ! Total stress including tms
+    real(r8)                :: kvf(pcols,pver+1)         ! Free atmospheric eddy diffusivity [ m2/s ]
+    real(r8)                :: kvm(pcols,pver+1)         ! Eddy diffusivity for momentum [ m2/s ]
+    real(r8)                :: kvh(pcols,pver+1)         ! Eddy diffusivity for heat [ m2/s ]
+    real(r8)                :: kvm_preo(pcols,pver+1)    ! Eddy diffusivity for momentum [ m2/s ]
+    real(r8)                :: kvh_preo(pcols,pver+1)    ! Eddy diffusivity for heat [ m2/s ]
+    real(r8)                :: kvm_pre(pcols,pver+1)     ! Eddy diffusivity for momentum [ m2/s ]
+    real(r8)                :: kvh_pre(pcols,pver+1)     ! Eddy diffusivity for heat [ m2/s ]
+    real(r8)                :: errorPBL(pcols)           ! Error function showing whether PBL produced convergent solution or not. [ unit ? ]
+    real(r8)                :: s2(pcols,pver)            ! Shear squared, defined at interfaces except surface [ s-2 ]
+    real(r8)                :: n2(pcols,pver)            ! Buoyancy frequency, defined at interfaces except surface [ s-2 ]
+    real(r8)                :: ri(pcols,pver)            ! Richardson number, 'n2/s2', defined at interfaces except surface [ s-2 ]
+    real(r8)                :: pblhp(pcols)              ! PBL top pressure [ Pa ]
+    real(r8)                :: minpblh(pcols)            ! Minimum PBL height based on surface stress
+
+    real(r8)                :: qt(pcols,pver)            ! Total specific humidity [ kg/kg ]
+    real(r8)                :: sfuh(pcols,pver)          ! Saturation fraction in upper half-layer [ fraction ]
+    real(r8)                :: sflh(pcols,pver)          ! Saturation fraction in lower half-layer [ fraction ]
+    real(r8)                :: sl(pcols,pver)            ! Liquid water static energy [ J/kg ]
+    real(r8)                :: slv(pcols,pver)           ! Liquid water virtual static energy [ J/kg ]
+    real(r8)                :: slslope(pcols,pver)       ! Slope of 'sl' in each layer
+    real(r8)                :: qtslope(pcols,pver)       ! Slope of 'qt' in each layer
+    real(r8)                :: rrho(pcols)               ! Density at the lowest layer
+    real(r8)                :: qvfd(pcols,pver)          ! Specific humidity for diffusion [ kg/kg ]
+    real(r8)                :: tfd(pcols,pver)           ! Temperature for diffusion [ K ]
+    real(r8)                :: slfd(pcols,pver)          ! Liquid static energy [ J/kg ]
+    real(r8)                :: qtfd(pcols,pver)          ! Total specific humidity [ kg/kg ] 
+    real(r8)                :: qlfd(pcols,pver)          ! Liquid water specific humidity for diffusion [ kg/kg ]
+    real(r8)                :: ufd(pcols,pver)           ! U-wind for diffusion [ m/s ]
+    real(r8)                :: vfd(pcols,pver)           ! V-wind for diffusion [ m/s ]
+
+    ! Buoyancy coefficients : w'b' = ch * w'sl' + cm * w'qt'
+
+    real(r8)                :: chu(pcols,pver+1)         ! Heat buoyancy coef for dry states, defined at each interface, finally.
+    real(r8)                :: chs(pcols,pver+1)         ! Heat buoyancy coef for sat states, defined at each interface, finally. 
+    real(r8)                :: cmu(pcols,pver+1)         ! Moisture buoyancy coef for dry states, defined at each interface, finally.
+    real(r8)                :: cms(pcols,pver+1)         ! Moisture buoyancy coef for sat states, defined at each interface, finally. 
+
+    real(r8)                :: jnk1d(pcols)
+    real(r8)                :: jnk2d(pcols,pver+1)  
+    real(r8)                :: zero(pcols)
+    real(r8)                :: zero2d(pcols,pver+1)
+    real(r8)                :: es(1)                     ! Saturation vapor pressure
+    real(r8)                :: qs(1)                     ! Saturation specific humidity
+    real(r8)                :: gam(1)                    ! (L/cp)*dqs/dT
+    real(r8)                :: ep2, templ, temps
+
+    ! ------------------------------- !
+    ! Variables for diagnostic output !
+    ! ------------------------------- !
+
+    real(r8)                :: tkes(pcols)               ! TKE at surface interface [ m2/s2 ]
+    real(r8)                :: kbase_o(pcols,ncvmax)     ! Original external base interface index of CL from 'exacol'
+    real(r8)                :: ktop_o(pcols,ncvmax)      ! Original external top  interface index of CL from 'exacol'
+    real(r8)                :: ncvfin_o(pcols)           ! Original number of CLs from 'exacol'
+    real(r8)                :: kbase_mg(pcols,ncvmax)    ! 'kbase' after extending-merging from 'zisocl'
+    real(r8)                :: ktop_mg(pcols,ncvmax)     ! 'ktop' after extending-merging from 'zisocl'
+    real(r8)                :: ncvfin_mg(pcols)          ! 'ncvfin' after extending-merging from 'zisocl'
+    real(r8)                :: kbase_f(pcols,ncvmax)     ! Final 'kbase' after extending-merging & including SRCL
+    real(r8)                :: ktop_f(pcols,ncvmax)      ! Final 'ktop' after extending-merging & including SRCL
+    real(r8)                :: ncvfin_f(pcols)           ! Final 'ncvfin' after extending-merging & including SRCL
+    real(r8)                :: wet(pcols,ncvmax)         ! Entrainment rate at the CL top  [ m/s ] 
+    real(r8)                :: web(pcols,ncvmax)         ! Entrainment rate at the CL base [ m/s ]. Set to zero if CL is based at surface.
+    real(r8)                :: jtbu(pcols,ncvmax)        ! Buoyancy jump across the CL top  [ m/s2 ]  
+    real(r8)                :: jbbu(pcols,ncvmax)        ! Buoyancy jump across the CL base [ m/s2 ]  
+    real(r8)                :: evhc(pcols,ncvmax)        ! Evaporative enhancement factor at the CL top
+    real(r8)                :: jt2slv(pcols,ncvmax)      ! Jump of slv ( across two layers ) at CL top used only for evhc [ J/kg ]
+    real(r8)                :: n2ht(pcols,ncvmax)        ! n2 defined at the CL top  interface but using sfuh(kt)   instead of sfi(kt) [ s-2 ] 
+    real(r8)                :: n2hb(pcols,ncvmax)        ! n2 defined at the CL base interface but using sflh(kb-1) instead of sfi(kb) [ s-2 ]
+    real(r8)                :: lwp(pcols,ncvmax)         ! LWP in the CL top layer [ kg/m2 ]
+    real(r8)                :: opt_depth(pcols,ncvmax)   ! Optical depth of the CL top layer
+    real(r8)                :: radinvfrac(pcols,ncvmax)  ! Fraction of radiative cooling confined in the top portion of CL top layer
+    real(r8)                :: radf(pcols,ncvmax)        ! Buoyancy production at the CL top due to LW radiative cooling [ m2/s3 ]
+    real(r8)                :: wstar(pcols,ncvmax)       ! Convective velocity in each CL [ m/s ]
+    real(r8)                :: wstar3fact(pcols,ncvmax)  ! Enhancement of 'wstar3' due to entrainment (inverse) [ no unit ]
+    real(r8)                :: ebrk(pcols,ncvmax)        ! Net mean TKE of CL including entrainment effect [ m2/s2 ]
+    real(r8)                :: wbrk(pcols,ncvmax)        ! Net mean normalized TKE (W) of CL, 'ebrk/b1' including entrainment effect [ m2/s2 ]
+    real(r8)                :: lbrk(pcols,ncvmax)        ! Energetic internal thickness of CL [m]
+    real(r8)                :: ricl(pcols,ncvmax)        ! CL internal mean Richardson number
+    real(r8)                :: ghcl(pcols,ncvmax)        ! Half of normalized buoyancy production of CL
+    real(r8)                :: shcl(pcols,ncvmax)        ! Galperin instability function of heat-moisture of CL
+    real(r8)                :: smcl(pcols,ncvmax)        ! Galperin instability function of mementum of CL
+    real(r8)                :: ghi(pcols,pver+1)         ! Half of normalized buoyancy production at all interfaces
+    real(r8)                :: shi(pcols,pver+1)         ! Galperin instability function of heat-moisture at all interfaces
+    real(r8)                :: smi(pcols,pver+1)         ! Galperin instability function of heat-moisture at all interfaces
+    real(r8)                :: rii(pcols,pver+1)         ! Interfacial Richardson number defined at all interfaces
+    real(r8)                :: lengi(pcols,pver+1)       ! Turbulence length scale at all interfaces [ m ]
+    real(r8)                :: wcap(pcols,pver+1)        ! Normalized TKE at all interfaces [ m2/s2 ]
+
+    ! ---------- !
+    ! Initialize !
+    ! ---------- !
+
+    zero(:)     = 0._r8
+    zero2d(:,:) = 0._r8
+
+    ! ----------------------- !
+    ! Main Computation Begins ! 
+    ! ----------------------- !
+
+    ufd(:ncol,:)  = u(:ncol,:)
+    vfd(:ncol,:)  = v(:ncol,:)
+    tfd(:ncol,:)  = t(:ncol,:)
+    qvfd(:ncol,:) = qv(:ncol,:)
+    qlfd(:ncol,:) = ql(:ncol,:)
+    
+    do iturb = 1, nturb
+
+     ! Compute total stress by including 'tms'.
+     ! Here, in computing 'tms', we can use either iteratively changed 'ufd,vfd' or the
+     ! initially given 'u,v' to the PBL scheme. Note that normal stress, 'taux, tauy'
+     ! are not changed by iteration. In order to treat 'tms' in a fully implicit way,
+     ! I am using updated wind, here.
+
+       tautotx(:ncol) = taux(:ncol) - ksrftms(:ncol) * ufd(:ncol,pver)
+       tautoty(:ncol) = tauy(:ncol) - ksrftms(:ncol) * vfd(:ncol,pver)
+
+     ! Calculate (qt,sl,n2,s2,ri) from a given set of (t,qv,ql,qi,u,v)
+
+       call trbintd( &
+                     pcols    , pver    , ncol  , z       , ufd     , vfd     , tfd   , pmid    , &
+                     tautotx  , tautoty , ustar , rrho    , s2      , n2      , ri    , zi      , &
+                     pi       , cldn    , qtfd  , qvfd    , qlfd    , qi      , sfi   , sfuh    , &
+                     sflh     , slfd    , slv   , slslope , qtslope , chs     , chu   , cms     , &
+                     cmu      , minpblh , qsat )
+
+     ! Save initial (i.e., before iterative diffusion) profile of (qt,sl) at each iteration.         
+     ! Only necessary for (qt,sl) not (u,v) because (qt,sl) are newly calculated variables. 
+
+       if( iturb .eq. 1 ) then
+           qt(:ncol,:) = qtfd(:ncol,:)
+           sl(:ncol,:) = slfd(:ncol,:)
+       endif
+
+     ! Get free atmosphere exchange coefficients. This 'kvf' is not used in UW moist PBL scheme
+
+       if( use_kvf )call austausch_atm( pcols, pver, ncol, ri, s2, kvf )
+
+     ! Initialize kvh/kvm to send to caleddy, depending on model timestep and iteration number
+     ! This is necessary for 'wstar-based' entrainment closure.
+
+       if( iturb .eq. 1 ) then
+           if( kvinit ) then
+           ! First iteration of first model timestep : Use free tropospheric value or zero.
+             if( use_kvf ) then
+                 kvh(:ncol,:) = kvf(:ncol,:)
+                 kvm(:ncol,:) = kvf(:ncol,:)
+             else
+                 kvh(:ncol,:) = 0._r8
+                 kvm(:ncol,:) = 0._r8
+             endif
+           else
+             ! First iteration on any model timestep except the first : Use value from previous timestep
+             kvh(:ncol,:) = kvh_in(:ncol,:)
+             kvm(:ncol,:) = kvm_in(:ncol,:)
+           endif
+       else
+        ! Not the first iteration : Use from previous iteration
+          kvh(:ncol,:) = kvh_out(:ncol,:)
+          kvm(:ncol,:) = kvm_out(:ncol,:)
+       endif
+
+     ! Calculate eddy diffusivity (kvh_out,kvm_out) and (tke,bprod,sprod) using
+     ! a given (kvh,kvm) which are used only for initializing (bprod,sprod)  at
+     ! the first part of caleddy. (bprod,sprod) are fully updated at the end of
+     ! caleddy after calculating (kvh_out,kvm_out) 
+
+       call caleddy( pcols     , pver      , ncol      ,                     &
+                     slfd      , qtfd      , qlfd      , slv      ,ufd     , &
+                     vfd       , pi        , z         , zi       ,          &
+                     qflx      , shflx     , slslope   , qtslope  ,          &
+                     chu       , chs       , cmu       , cms      ,sfuh    , &
+                     sflh      , n2        , s2        , ri       ,rrho    , &
+                     pblh      , ustar     ,                                 &
+                     kvh       , kvm       , kvh_out   , kvm_out  ,          &
+                     tpert     , qpert     , qrl       , kvf      , tke    , &
+                     wstarent  , bprod     , sprod     , minpblh  , wpert  , &
+                     tkes      , turbtype  , sm_aw     ,                     & 
+                     kbase_o   , ktop_o    , ncvfin_o  ,                     &
+                     kbase_mg  , ktop_mg   , ncvfin_mg ,                     &                  
+                     kbase_f   , ktop_f    , ncvfin_f  ,                     &                  
+                     wet       , web       , jtbu      , jbbu     ,          &
+                     evhc      , jt2slv    , n2ht      , n2hb     ,          & 
+                     lwp       , opt_depth , radinvfrac, radf     ,          &
+                     wstar     , wstar3fact,                                 &
+                     ebrk      , wbrk      , lbrk      , ricl     , ghcl   , & 
+                     shcl      , smcl      , ghi       , shi      , smi    , &
+                     rii       , lengi     , wcap      , pblhp    , cldn   , &
+                     ipbl      , kpblh     , wsedl )
+
+     ! Calculate errorPBL to check whether PBL produced convergent solutions or not.
+
+       if( iturb .eq. nturb ) then
+           do i = 1, ncol
+              errorPBL(i) = 0._r8 
+              do k = 1, pver
+                 errorPBL(i) = errorPBL(i) + ( kvh(i,k) - kvh_out(i,k) )**2 
+              end do 
+              errorPBL(i) = sqrt(errorPBL(i)/pver)
+           end do
+       end if
+
+     ! Eddy diffusivities which will be used for the initialization of (bprod,
+     ! sprod) in 'caleddy' at the next iteration step.
+
+       if( iturb .gt. 1 .and. iturb .lt. nturb ) then
+           kvm_out(:ncol,:) = lambda * kvm_out(:ncol,:) + ( 1._r8 - lambda ) * kvm(:ncol,:)
+           kvh_out(:ncol,:) = lambda * kvh_out(:ncol,:) + ( 1._r8 - lambda ) * kvh(:ncol,:)
+       endif
+
+     ! Set nonlocal terms to zero for flux diagnostics, since not used by caleddy.
+
+       cgh(:ncol,:) = 0._r8
+       cgs(:ncol,:) = 0._r8      
+
+       if( iturb .lt. nturb ) then
+
+         ! Each time we diffuse the original state
+
+           slfd(:ncol,:)  = sl(:ncol,:)
+           qtfd(:ncol,:)  = qt(:ncol,:)
+           ufd(:ncol,:)   = u(:ncol,:)
+           vfd(:ncol,:)   = v(:ncol,:)
+
+         ! Diffuse initial profile of each time step using a given (kvh_out,kvm_out)
+         ! In the below 'compute_vdiff', (slfd,qtfd,ufd,vfd) are 'inout' variables.
+
+           call compute_vdiff( lchnk   ,                                                  &
+                               pcols   , pver     , 1        , ncol         , pmid      , &
+                               pi      , rpdel    , t        , ztodt        , taux      , &
+                               tauy    , shflx    , qflx     , ntop_turb    , nbot_turb , &
+                               kvh_out , kvm_out  , kvh_out  , cgs          , cgh       , &
+                               zi      , ksrftms  , zero     , fieldlist_wet,             &
+                               ufd     , vfd      , qtfd     , slfd         ,             &
+                               jnk1d   , jnk1d    , jnk2d    , jnk1d        , errstring , &
+                               tauresx , tauresy  , 0        , .false. )
+
+         ! Retrieve (tfd,qvfd,qlfd) from (slfd,qtfd) in order to 
+         ! use 'trbintd' at the next iteration.
+          
+          do k = 1, pver
+             do i = 1, ncol
+              ! ----------------------------------------------------- ! 
+              ! Compute the condensate 'qlfd' in the updated profiles !
+              ! ----------------------------------------------------- !  
+              ! Option.1 : Assume grid-mean condensate is homogeneously diffused by the moist turbulence scheme.
+              !            This should bs used if 'pseudodiff = .false.' in vertical_diffusion.F90.
+              ! Modification : Need to be check whether below is correct in the presence of ice, qi.       
+              !                I should understand why the variation of ice, qi is neglected during diffusion.
+                templ     = ( slfd(i,k) - g*z(i,k) ) / cpair
+                status    =   qsat( templ, pmid(i,k), es(1), qs(1), gam(1), 1 )
+                ep2       =  .622_r8 
+                temps     =   templ + ( qtfd(i,k) - qs(1) ) / ( cpair / latvap + latvap * qs(1) / ( rair * templ**2 ) )
+                status    =   qsat( temps, pmid(i,k), es(1), qs(1), gam(1), 1 )
+                qlfd(i,k) =   max( qtfd(i,k) - qi(i,k) - qs(1) ,0._r8 )
+              ! Option.2 : Assume condensate is not diffused by the moist turbulence scheme. 
+              !            This should bs used if 'pseudodiff = .true.'  in vertical_diffusion.F90.       
+              ! qlfd(i,k) = ql(i,k)
+              ! ----------------------------- !
+              ! Compute the other 'qvfd, tfd' ! 
+              ! ----------------------------- !
+                qvfd(i,k) = max( 0._r8, qtfd(i,k) - qi(i,k) - qlfd(i,k) )
+                tfd(i,k)  = ( slfd(i,k) + latvap * qlfd(i,k) + latsub * qi(i,k) - g*z(i,k)) / cpair
+             end do
+          end do
+       endif
+
+     ! Debug 
+     ! icol = phys_debug_col(lchnk) 
+     ! if( icol > 0 .and. get_nstep() .ge. 1 ) then
+     !     write(iulog,*) ' '
+     !     write(iulog,*) 'eddy_diff debug at the end of iteration' 
+     !     write(iulog,*) 't,     qv,     ql,     cld,     u,     v'
+     !     do k = pver-3, pver
+     !        write (iulog,*) k, tfd(icol,k), qvfd(icol,k), qlfd(icol,k), cldn(icol,k), ufd(icol,k), vfd(icol,k)
+     !     end do
+     ! endif
+     ! Debug
+
+    end do  ! End of 'iturb' iteration
+
+    kvq(:ncol,:) = kvh_out(:ncol,:)
+
+  ! Compute 'wstar' within the PBL for use in the future convection scheme.
+
+    do i = 1, ncol
+       if( ipbl(i) .eq. 1._r8 ) then 
+           wstarPBL(i) = max( 0._r8, wstar(i,1) )
+       else
+           wstarPBL(i) = 0._r8
+       endif
+    end do
+
+    ! --------------------------------------------------------------- !
+    ! Writing for detailed diagnostic analysis of UW moist PBL scheme !
+    ! --------------------------------------------------------------- !
+
+    call outfld( 'UW_errorPBL',    errorPBL,   pcols,   lchnk )
+
+    call outfld( 'UW_n2',          n2,         pcols,   lchnk )
+    call outfld( 'UW_s2',          s2,         pcols,   lchnk )
+    call outfld( 'UW_ri',          ri,         pcols,   lchnk )
+
+    call outfld( 'UW_sfuh',        sfuh,       pcols,   lchnk )
+    call outfld( 'UW_sflh',        sflh,       pcols,   lchnk )
+    call outfld( 'UW_sfi',         sfi,        pcols,   lchnk )
+
+    call outfld( 'UW_cldn',        cldn,       pcols,   lchnk )
+    call outfld( 'UW_qrl',         qrl,        pcols,   lchnk )
+    call outfld( 'UW_ql',          qlfd,       pcols,   lchnk )
+
+    call outfld( 'UW_chu',         chu,        pcols,   lchnk )
+    call outfld( 'UW_chs',         chs,        pcols,   lchnk )
+    call outfld( 'UW_cmu',         cmu,        pcols,   lchnk )
+    call outfld( 'UW_cms',         cms,        pcols,   lchnk )
+
+    call outfld( 'UW_tke',         tke,        pcols,   lchnk )
+    call outfld( 'UW_wcap',        wcap,       pcols,   lchnk )
+    call outfld( 'UW_bprod',       bprod,      pcols,   lchnk )
+    call outfld( 'UW_sprod',       sprod,      pcols,   lchnk )
+
+    call outfld( 'UW_kvh',         kvh_out,    pcols,   lchnk )
+    call outfld( 'UW_kvm',         kvm_out,    pcols,   lchnk )
+
+    call outfld( 'UW_pblh',        pblh,       pcols,   lchnk )
+    call outfld( 'UW_pblhp',       pblhp,      pcols,   lchnk )
+    call outfld( 'UW_tpert',       tpert,      pcols,   lchnk )
+    call outfld( 'UW_qpert',       qpert,      pcols,   lchnk )
+    call outfld( 'UW_wpert',       wpert,      pcols,   lchnk )
+
+    call outfld( 'UW_ustar',       ustar,      pcols,   lchnk )
+    call outfld( 'UW_tkes',        tkes,       pcols,   lchnk )
+    call outfld( 'UW_minpblh',     minpblh,    pcols,   lchnk )
+
+    call outfld( 'UW_turbtype',    turbtype,   pcols,   lchnk )
+
+    call outfld( 'UW_kbase_o',     kbase_o,    pcols,   lchnk )
+    call outfld( 'UW_ktop_o',      ktop_o,     pcols,   lchnk )
+    call outfld( 'UW_ncvfin_o',    ncvfin_o,   pcols,   lchnk )
+
+    call outfld( 'UW_kbase_mg',    kbase_mg,   pcols,   lchnk )
+    call outfld( 'UW_ktop_mg',     ktop_mg,    pcols,   lchnk )
+    call outfld( 'UW_ncvfin_mg',   ncvfin_mg,  pcols,   lchnk )
+
+    call outfld( 'UW_kbase_f',     kbase_f,    pcols,   lchnk )
+    call outfld( 'UW_ktop_f',      ktop_f,     pcols,   lchnk )
+    call outfld( 'UW_ncvfin_f',    ncvfin_f,   pcols,   lchnk ) 
+
+    call outfld( 'UW_wet',         wet,        pcols,   lchnk )
+    call outfld( 'UW_web',         web,        pcols,   lchnk )
+    call outfld( 'UW_jtbu',        jtbu,       pcols,   lchnk )
+    call outfld( 'UW_jbbu',        jbbu,       pcols,   lchnk )
+    call outfld( 'UW_evhc',        evhc,       pcols,   lchnk )
+    call outfld( 'UW_jt2slv',      jt2slv,     pcols,   lchnk )
+    call outfld( 'UW_n2ht',        n2ht,       pcols,   lchnk )
+    call outfld( 'UW_n2hb',        n2hb,       pcols,   lchnk )
+    call outfld( 'UW_lwp',         lwp,        pcols,   lchnk )
+    call outfld( 'UW_optdepth',    opt_depth,  pcols,   lchnk )
+    call outfld( 'UW_radfrac',     radinvfrac, pcols,   lchnk )
+    call outfld( 'UW_radf',        radf,       pcols,   lchnk )
+    call outfld( 'UW_wstar',       wstar,      pcols,   lchnk )
+    call outfld( 'UW_wstar3fact',  wstar3fact, pcols,   lchnk )
+    call outfld( 'UW_ebrk',        ebrk,       pcols,   lchnk )
+    call outfld( 'UW_wbrk',        wbrk,       pcols,   lchnk )
+    call outfld( 'UW_lbrk',        lbrk,       pcols,   lchnk )
+    call outfld( 'UW_ricl',        ricl,       pcols,   lchnk )
+    call outfld( 'UW_ghcl',        ghcl,       pcols,   lchnk )
+    call outfld( 'UW_shcl',        shcl,       pcols,   lchnk )
+    call outfld( 'UW_smcl',        smcl,       pcols,   lchnk )
+
+    call outfld( 'UW_gh',          ghi,        pcols,   lchnk )
+    call outfld( 'UW_sh',          shi,        pcols,   lchnk )
+    call outfld( 'UW_sm',          smi,        pcols,   lchnk )
+    call outfld( 'UW_ria',         rii,        pcols,   lchnk )
+    call outfld( 'UW_leng',        lengi,      pcols,   lchnk )
+
+    return
+    
+  end subroutine compute_eddy_diff
+
+  !=============================================================================== !
+  !                                                                                !
+  !=============================================================================== !
+  
+  subroutine sfdiag( pcols   , pver    , ncol    , qt      , ql      , sl      , &
+                     pi      , pm      , zi      , cld     , sfi     , sfuh    , &
+                     sflh    , slslope , qtslope , qsat )
+    !----------------------------------------------------------------------- ! 
+    !                                                                        !
+    ! Purpose: Interface for calculating saturation fractions  at upper and  ! 
+    !          lower-half layers, & interfaces for use by turbulence scheme  !
+    !                                                                        !
+    ! Method : Various but 'l' should be chosen for consistency.             !
+    !                                                                        ! 
+    ! Author : B. Stevens and C. Bretherton (August 2000)                    !
+    !          Sungsu Park. August 2006.                                     !
+    !                       May.   2008.                                     ! 
+    !                                                                        !  
+    ! S.Park : The computed saturation fractions are repeatedly              !
+    !          used to compute buoyancy coefficients in'trbintd' & 'caleddy'.!  
+    !----------------------------------------------------------------------- !
+
+    implicit none       
+
+    ! --------------- !
+    ! Input arguments !
+    ! --------------- !
+
+    integer,  external    :: qsat
+
+    integer,  intent(in)  :: pcols               ! Number of atmospheric columns   
+    integer,  intent(in)  :: pver                ! Number of atmospheric layers   
+    integer,  intent(in)  :: ncol                ! Number of atmospheric columns   
+
+    real(r8), intent(in)  :: sl(pcols,pver)      ! Liquid water static energy [ J/kg ]
+    real(r8), intent(in)  :: qt(pcols,pver)      ! Total water specific humidity [ kg/kg ]
+    real(r8), intent(in)  :: ql(pcols,pver)      ! Liquid water specific humidity [ kg/kg ]
+    real(r8), intent(in)  :: pi(pcols,pver+1)    ! Interface pressures [ Pa ]
+    real(r8), intent(in)  :: pm(pcols,pver)      ! Layer mid-point pressures [ Pa ]
+    real(r8), intent(in)  :: zi(pcols,pver+1)    ! Interface heights [ m ]
+    real(r8), intent(in)  :: cld(pcols,pver)     ! Stratiform cloud fraction [ fraction ]
+    real(r8), intent(in)  :: slslope(pcols,pver) ! Slope of 'sl' in each layer
+    real(r8), intent(in)  :: qtslope(pcols,pver) ! Slope of 'qt' in each layer
+
+    ! ---------------- !
+    ! Output arguments !
+    ! ---------------- !
+
+    real(r8), intent(out) :: sfi(pcols,pver+1)   ! Interfacial layer saturation fraction [ fraction ]
+    real(r8), intent(out) :: sfuh(pcols,pver)    ! Saturation fraction in upper half-layer [ fraction ]
+    real(r8), intent(out) :: sflh(pcols,pver)    ! Saturation fraction in lower half-layer [ fraction ]
+
+    ! --------------- !
+    ! Local Variables !
+    ! --------------- !
+
+    integer               :: i                   ! Longitude index
+    integer               :: k                   ! Vertical index
+    integer               :: km1                 ! k-1
+    integer               :: status              ! Status returned by function calls
+    real(r8)              :: sltop, slbot        ! sl at top/bot of grid layer
+    real(r8)              :: qttop, qtbot        ! qt at top/bot of grid layer
+    real(r8)              :: tltop(1), tlbot(1)  ! Liquid water temperature at top/bot of grid layer
+    real(r8)              :: qxtop, qxbot        ! Sat excess at top/bot of grid layer
+    real(r8)              :: qxm                 ! Sat excess at midpoint
+    real(r8)              :: es(1)               ! Saturation vapor pressure
+    real(r8)              :: qs(1)               ! Saturation spec. humidity
+    real(r8)              :: gam(1)              ! (L/cp)*dqs/dT
+    real(r8)              :: cldeff(pcols,pver)  ! Effective Cloud Fraction [ fraction ]
+
+    ! ----------------------- !
+    ! Main Computation Begins ! 
+    ! ----------------------- !
+
+    sfi(1:ncol,:)    = 0._r8
+    sfuh(1:ncol,:)   = 0._r8
+    sflh(1:ncol,:)   = 0._r8
+    cldeff(1:ncol,:) = 0._r8
+
+    select case (sftype)
+    case ('d')
+       ! ----------------------------------------------------------------------- !
+       ! Simply use the given stratus fraction ('horizontal' cloud partitioning) !
+       ! ----------------------------------------------------------------------- !
+       do k = ntop_turb + 1, nbot_turb
+          km1 = k - 1
+          do i = 1, ncol
+             sfuh(i,k) = cld(i,k)
+             sflh(i,k) = cld(i,k)
+             sfi(i,k)  = 0.5_r8 * ( sflh(i,km1) + min( sflh(i,km1), sfuh(i,k) ) )
+          end do
+       end do
+       do i = 1, ncol
+          sfi(i,pver+1) = sflh(i,pver) 
+       end do
+    case ('l')
+       ! ------------------------------------------ !
+       ! Use modified stratus fraction partitioning !
+       ! ------------------------------------------ !
+       do k = ntop_turb + 1, nbot_turb
+          km1 = k - 1
+          do i = 1, ncol
+             cldeff(i,k) = cld(i,k)
+             sfuh(i,k)   = cld(i,k)
+             sflh(i,k)   = cld(i,k)
+             if( ql(i,k) .lt. qmin ) then
+                 sfuh(i,k) = 0._r8
+                 sflh(i,k) = 0._r8
+             end if
+           ! Modification : The contribution of ice should be carefully considered.
+             if( choice_evhc .eq. 'ramp' .or. choice_radf .eq. 'ramp' ) then 
+                 cldeff(i,k) = cld(i,k) * min( ql(i,k) / qmin, 1._r8 )
+                 sfuh(i,k)   = cldeff(i,k)
+                 sflh(i,k)   = cldeff(i,k)
+             elseif( choice_evhc .eq. 'maxi' .or. choice_radf .eq. 'maxi' ) then 
+                 cldeff(i,k) = cld(i,k)
+                 sfuh(i,k)   = cldeff(i,k)
+                 sflh(i,k)   = cldeff(i,k)
+             endif
+           ! At the stratus top, take the minimum interfacial saturation fraction
+             sfi(i,k) = 0.5_r8 * ( sflh(i,km1) + min( sfuh(i,k), sflh(i,km1) ) )
+           ! Modification : Currently sfi at the top and surface interfaces are set to be zero.
+           !                Also, sfuh and sflh in the top model layer is set to be zero.
+           !                However, I may need to set 
+           !                         do i = 1, ncol
+           !                            sfi(i,pver+1) = sflh(i,pver) 
+           !                         end do
+           !                for treating surface-based fog. 
+           ! OK. I added below block similar to the other cases.
+          end do
+       end do
+       do i = 1, ncol
+          sfi(i,pver+1) = sflh(i,pver)
+       end do
+    case ('u')
+       ! ------------------------------------------------------------------------- !
+       ! Use unsaturated buoyancy - since sfi, sfuh, sflh have already been zeroed !
+       ! nothing more need be done for this case.                                  !
+       ! ------------------------------------------------------------------------- !
+    case ('z')
+       ! ------------------------------------------------------------------------- !
+       ! Calculate saturation fraction based on whether the air just above or just !
+       ! below the interface is saturated, i.e. with vertical cloud partitioning.  !
+       ! The saturation fraction of the interfacial layer between mid-points k and !
+       ! k+1 is computed by averaging the saturation fraction   of the half-layers !
+       ! above and below the interface,  with a special provision   for cloud tops !
+       ! (more cloud in the half-layer below than in the half-layer above).In each !
+       ! half-layer, vertical partitioning of  cloud based on the slopes diagnosed !
+       ! above is used.     Loop down through the layers, computing the saturation !
+       ! fraction in each half-layer (sfuh for upper half, sflh for lower half).   !
+       ! Once sfuh(i,k) is computed, use with sflh(i,k-1) to determine  saturation !
+       ! fraction sfi(i,k) for interfacial layer k-0.5.                            !
+       ! This is 'not' chosen for full consistent treatment of stratus fraction in !
+       ! all physics schemes.                                                      !
+       ! ------------------------------------------------------------------------- !
+       do k = ntop_turb + 1, nbot_turb
+          km1 = k - 1
+          do i = 1, ncol
+           ! Compute saturation excess at the mid-point of layer k
+             sltop    = sl(i,k) + slslope(i,k) * ( pi(i,k) - pm(i,k) )      
+             qttop    = qt(i,k) + qtslope(i,k) * ( pi(i,k) - pm(i,k) )
+             tltop(1) = ( sltop - g * zi(i,k) ) / cpair 
+             status   = qsat( tltop(1), pi(i,k), es(1), qs(1), gam(1), 1 )
+             qxtop    = qttop - qs(1) 
+             slbot    = sl(i,k) + slslope(i,k) * ( pi(i,k+1) - pm(i,k) )      
+             qtbot    = qt(i,k) + qtslope(i,k) * ( pi(i,k+1) - pm(i,k) )
+             tlbot(1) = ( slbot - g * zi(i,k+1) ) / cpair 
+             status   = qsat( tlbot(1), pi(i,k+1), es(1), qs(1), gam(1), 1 )
+             qxbot    = qtbot - qs(1) 
+             qxm      = qxtop + ( qxbot - qxtop ) * ( pm(i,k) - pi(i,k) ) / ( pi(i,k+1) - pi(i,k) )
+           ! Find the saturation fraction sfuh(i,k) of the upper half of layer k.
+             if( ( qxtop .lt. 0._r8 ) .and. ( qxm .lt. 0._r8 ) ) then
+                   sfuh(i,k) = 0._r8 
+             else if( ( qxtop .gt. 0._r8 ) .and. ( qxm .gt. 0._r8 ) ) then
+                   sfuh(i,k) = 1._r8  
+             else ! Either qxm < 0 and qxtop > 0 or vice versa
+                   sfuh(i,k) = max( qxtop, qxm ) / abs( qxtop - qxm )
+             end if
+           ! Combine with sflh(i) (still for layer k-1) to get interfac layer saturation fraction
+             sfi(i,k) = 0.5_r8 * ( sflh(i,k-1) + min( sflh(i,k-1), sfuh(i,k) ) )
+           ! Update sflh to be for the lower half of layer k.             
+             if( ( qxbot .lt. 0._r8 ) .and. ( qxm .lt. 0._r8 ) ) then
+                   sflh(i,k) = 0._r8 
+             else if( ( qxbot .gt. 0._r8 ) .and. ( qxm .gt. 0._r8 ) ) then
+                   sflh(i,k) = 1._r8 
+             else ! Either qxm < 0 and qxbot > 0 or vice versa
+                   sflh(i,k) = max( qxbot, qxm ) / abs( qxbot - qxm )
+             end if
+          end do  ! i
+       end do ! k
+       do i = 1, ncol
+          sfi(i,pver+1) = sflh(i,pver)  ! Saturation fraction in the lowest half-layer. 
+       end do
+    end select
+
+  return
+  end subroutine sfdiag
+  
+  !=============================================================================== !
+  !                                                                                !
+  !=============================================================================== !
+ 
+  subroutine trbintd( pcols   , pver    , ncol    ,                               &
+                      z       , u       , v       ,                               &
+                      t       , pmid    , taux    ,                               &
+                      tauy    , ustar   , rrho    ,                               &
+                      s2      , n2      , ri      ,                               &
+                      zi      , pi      , cld     ,                               &
+                      qt      , qv      , ql      , qi      , sfi     , sfuh    , &
+                      sflh    , sl      , slv     , slslope , qtslope ,           &
+                      chs     , chu     , cms     , cmu     , minpblh , qsat )
+    !----------------------------------------------------------------------- !
+    ! Purpose: Calculate buoyancy coefficients at all interfaces including   !
+    !          surface. Also, computes the profiles of ( sl,qt,n2,s2,ri ).   !
+    !          Note that (n2,s2,ri) are defined at each interfaces except    !
+    !          surface.                                                      !
+    !                                                                        !
+    ! Author: B. Stevens  ( Extracted from pbldiff, August, 2000 )           !
+    !         Sungsu Park ( August 2006, May. 2008 )                         !
+    !----------------------------------------------------------------------- !
+
+    implicit none
+
+    ! --------------- !
+    ! Input arguments !
+    ! --------------- !
+
+    integer,  intent(in)  :: pcols                            ! Number of atmospheric columns   
+    integer,  intent(in)  :: pver                             ! Number of atmospheric layers   
+    integer,  intent(in)  :: ncol                             ! Number of atmospheric columns
+    real(r8), intent(in)  :: z(pcols,pver)                    ! Layer mid-point height above surface [ m ]
+    real(r8), intent(in)  :: u(pcols,pver)                    ! Layer mid-point u [ m/s ]
+    real(r8), intent(in)  :: v(pcols,pver)                    ! Layer mid-point v [ m/s ]
+    real(r8), intent(in)  :: t(pcols,pver)                    ! Layer mid-point temperature [ K ]
+    real(r8), intent(in)  :: pmid(pcols,pver)                 ! Layer mid-point pressure [ Pa ]
+    real(r8), intent(in)  :: taux(pcols)                      ! Surface u stress [ N/m2 ]
+    real(r8), intent(in)  :: tauy(pcols)                      ! Surface v stress [ N/m2 ]
+    real(r8), intent(in)  :: zi(pcols,pver+1)                 ! Interface height [ m ]
+    real(r8), intent(in)  :: pi(pcols,pver+1)                 ! Interface pressure [ Pa ]
+    real(r8), intent(in)  :: cld(pcols,pver)                  ! Stratus fraction
+    real(r8), intent(in)  :: qv(pcols,pver)                   ! Water vapor specific humidity [ kg/kg ]
+    real(r8), intent(in)  :: ql(pcols,pver)                   ! Liquid water specific humidity [ kg/kg ]
+    real(r8), intent(in)  :: qi(pcols,pver)                   ! Ice water specific humidity [ kg/kg ]
+    integer,  external    :: qsat
+
+    ! ---------------- !
+    ! Output arguments !
+    ! ---------------- !
+
+    real(r8), intent(out) :: ustar(pcols)                     ! Surface friction velocity [ m/s ]
+    real(r8), intent(out) :: s2(pcols,pver)                   ! Interfacial ( except surface ) shear squared [ s-2 ]
+    real(r8), intent(out) :: n2(pcols,pver)                   ! Interfacial ( except surface ) buoyancy frequency [ s-2 ]
+    real(r8), intent(out) :: ri(pcols,pver)                   ! Interfacial ( except surface ) Richardson number, 'n2/s2'
+ 
+    real(r8), intent(out) :: qt(pcols,pver)                   ! Total specific humidity [ kg/kg ]
+    real(r8), intent(out) :: sfi(pcols,pver+1)                ! Interfacial layer saturation fraction [ fraction ]
+    real(r8), intent(out) :: sfuh(pcols,pver)                 ! Saturation fraction in upper half-layer [ fraction ]
+    real(r8), intent(out) :: sflh(pcols,pver)                 ! Saturation fraction in lower half-layer [ fraction ]
+    real(r8), intent(out) :: sl(pcols,pver)                   ! Liquid water static energy [ J/kg ] 
+    real(r8), intent(out) :: slv(pcols,pver)                  ! Liquid water virtual static energy [ J/kg ]
+   
+    real(r8), intent(out) :: chu(pcols,pver+1)                ! Heat buoyancy coef for dry states at all interfaces, finally. [ unit ? ]
+    real(r8), intent(out) :: chs(pcols,pver+1)                ! heat buoyancy coef for sat states at all interfaces, finally. [ unit ? ]
+    real(r8), intent(out) :: cmu(pcols,pver+1)                ! Moisture buoyancy coef for dry states at all interfaces, finally. [ unit ? ]
+    real(r8), intent(out) :: cms(pcols,pver+1)                ! Moisture buoyancy coef for sat states at all interfaces, finally. [ unit ? ]
+    real(r8), intent(out) :: slslope(pcols,pver)              ! Slope of 'sl' in each layer
+    real(r8), intent(out) :: qtslope(pcols,pver)              ! Slope of 'qt' in each layer
+    real(r8), intent(out) :: rrho(pcols)                      ! 1./bottom level density [ m3/kg ]
+    real(r8), intent(out) :: minpblh(pcols)                   ! Minimum PBL height based on surface stress [ m ]
+ 
+    ! --------------- !
+    ! Local Variables !
+    ! --------------- ! 
+
+    integer               :: i                                ! Longitude index
+    integer               :: k, km1                           ! Level index
+    integer               :: status                           ! Status returned by function calls
+
+    real(r8)              :: qs(pcols,pver)                   ! Saturation specific humidity
+    real(r8)              :: es(pcols,pver)                   ! Saturation vapor pressure
+    real(r8)              :: gam(pcols,pver)                  ! (l/cp)*(d(qs)/dT)
+    real(r8)              :: rdz                              ! 1 / (delta z) between midpoints
+    real(r8)              :: dsldz                            ! 'delta sl / delta z' at interface
+    real(r8)              :: dqtdz                            ! 'delta qt / delta z' at interface
+    real(r8)              :: ch                               ! 'sfi' weighted ch at the interface
+    real(r8)              :: cm                               ! 'sfi' weighted cm at the interface
+    real(r8)              :: bfact                            ! Buoyancy factor in n2 calculations
+    real(r8)              :: product                          ! Intermediate vars used to find slopes
+    real(r8)              :: dsldp_a, dqtdp_a                 ! Slopes across interface above 
+    real(r8)              :: dsldp_b(pcols), dqtdp_b(pcols)   ! Slopes across interface below
+
+    ! ----------------------- !
+    ! Main Computation Begins !
+    ! ----------------------- !
+
+    ! Compute ustar, and kinematic surface fluxes from surface energy fluxes
+
+    do i = 1, ncol
+       rrho(i)    = rair * t(i,pver) / pmid(i,pver)
+       ustar(i)   = max( sqrt( sqrt( taux(i)**2 + tauy(i)**2 ) * rrho(i) ), ustar_min )
+       minpblh(i) = 100.0_r8 * ustar(i)                       ! By construction, 'minpblh' is larger than 1 [m] when 'ustar_min = 0.01'. 
+    end do
+
+    ! Calculate conservative scalars (qt,sl,slv) and buoyancy coefficients at the layer mid-points.
+    ! Note that 'ntop_turb = 1', 'nbot_turb = pver'
+
+    do k = ntop_turb, nbot_turb
+       status = qsat( t(1,k), pmid(1,k), es(1,k), qs(1,k), gam(1,k), ncol )
+       do i = 1, ncol
+          qt(i,k)  = qv(i,k) + ql(i,k) + qi(i,k) 
+          sl(i,k)  = cpair * t(i,k) + g * z(i,k) - latvap * ql(i,k) - latsub * qi(i,k)
+          slv(i,k) = sl(i,k) * ( 1._r8 + zvir * qt(i,k) )
+        ! Thermodynamic coefficients for buoyancy flux - in this loop these are
+        ! calculated at mid-points; later,  they will be averaged to interfaces,
+        ! where they will ultimately be used.  At the surface, the coefficients
+        ! are taken from the lowest mid point.
+          bfact    = g / ( t(i,k) * ( 1._r8 + zvir * qv(i,k) - ql(i,k) - qi(i,k) ) )
+          chu(i,k) = ( 1._r8 + zvir * qt(i,k) ) * bfact / cpair
+          chs(i,k) = ( ( 1._r8 + ( 1._r8 + zvir ) * gam(i,k) * cpair * t(i,k) / latvap ) / ( 1._r8 + gam(i,k) ) ) * bfact / cpair
+          cmu(i,k) = zvir * bfact * t(i,k)
+          cms(i,k) = latvap * chs(i,k)  -  bfact * t(i,k)
+       end do
+    end do
+
+    do i = 1, ncol
+       chu(i,pver+1) = chu(i,pver)
+       chs(i,pver+1) = chs(i,pver)
+       cmu(i,pver+1) = cmu(i,pver)
+       cms(i,pver+1) = cms(i,pver)
+    end do
+
+    ! Compute slopes of conserved variables sl, qt within each layer k. 
+    ! 'a' indicates the 'above' gradient from layer k-1 to layer k and 
+    ! 'b' indicates the 'below' gradient from layer k   to layer k+1.
+    ! We take a smaller (in absolute value)  of these gradients as the
+    ! slope within layer k. If they have opposite signs,   gradient in 
+    ! layer k is taken to be zero. I should re-consider whether   this
+    ! profile reconstruction is the best or not.
+    ! This is similar to the profile reconstruction used in the UWShCu. 
+
+    do i = 1, ncol
+     ! Slopes at endpoints determined by extrapolation
+       slslope(i,pver) = ( sl(i,pver) - sl(i,pver-1) ) / ( pmid(i,pver) - pmid(i,pver-1) )
+       qtslope(i,pver) = ( qt(i,pver) - qt(i,pver-1) ) / ( pmid(i,pver) - pmid(i,pver-1) )
+       slslope(i,1)    = ( sl(i,2) - sl(i,1) ) / ( pmid(i,2) - pmid(i,1) )
+       qtslope(i,1)    = ( qt(i,2) - qt(i,1) ) / ( pmid(i,2) - pmid(i,1) )
+       dsldp_b(i)      = slslope(i,1)
+       dqtdp_b(i)      = qtslope(i,1)
+    end do
+
+    do k = 2, pver - 1
+       do i = 1, ncol
+          dsldp_a    = dsldp_b(i)
+          dqtdp_a    = dqtdp_b(i)
+          dsldp_b(i) = ( sl(i,k+1) - sl(i,k) ) / ( pmid(i,k+1) - pmid(i,k) )
+          dqtdp_b(i) = ( qt(i,k+1) - qt(i,k) ) / ( pmid(i,k+1) - pmid(i,k) )
+          product    = dsldp_a * dsldp_b(i)
+          if( product .le. 0._r8 ) then 
+              slslope(i,k) = 0._r8
+          else if( product .gt. 0._r8 .and. dsldp_a .lt. 0._r8 ) then 
+              slslope(i,k) = max( dsldp_a, dsldp_b(i) )
+          else if( product .gt. 0._r8 .and. dsldp_a .gt. 0._r8 ) then 
+              slslope(i,k) = min( dsldp_a, dsldp_b(i) )
+          end if
+          product = dqtdp_a*dqtdp_b(i)
+          if( product .le. 0._r8 ) then 
+              qtslope(i,k) = 0._r8
+          else if( product .gt. 0._r8 .and. dqtdp_a .lt. 0._r8 ) then 
+              qtslope(i,k) = max( dqtdp_a, dqtdp_b(i) )
+          else if( product .gt. 0._r8 .and. dqtdp_a .gt. 0._r8 ) then 
+              qtslope(i,k) = min( dqtdp_a, dqtdp_b(i) )
+          end if
+       end do ! i
+    end do ! k
+
+    !  Compute saturation fraction at the interfacial layers for use in buoyancy
+    !  flux computation.
+
+    call sfdiag( pcols  , pver    , ncol    , qt      , ql      , sl      , & 
+                 pi     , pmid    , zi      , cld     , sfi     , sfuh    , &
+                 sflh   , slslope , qtslope , qsat )
+
+    ! Calculate buoyancy coefficients at all interfaces (1:pver+1) and (n2,s2,ri) 
+    ! at all interfaces except surface. Note 'nbot_turb = pver', 'ntop_turb = 1'.
+    ! With the previous definition of buoyancy coefficients at the surface, the 
+    ! resulting buoyancy coefficients at the top and surface interfaces becomes 
+    ! identical to the buoyancy coefficients at the top and bottom layers. Note 
+    ! that even though the dimension of (s2,n2,ri) is 'pver',  they are defined
+    ! at interfaces ( not at the layer mid-points ) except the surface. 
+
+    do k = nbot_turb, ntop_turb + 1, -1
+       km1 = k - 1
+       do i = 1, ncol
+          rdz      = 1._r8 / ( z(i,km1) - z(i,k) )
+          dsldz    = ( sl(i,km1) - sl(i,k) ) * rdz
+          dqtdz    = ( qt(i,km1) - qt(i,k) ) * rdz 
+          chu(i,k) = ( chu(i,km1) + chu(i,k) ) * 0.5_r8
+          chs(i,k) = ( chs(i,km1) + chs(i,k) ) * 0.5_r8
+          cmu(i,k) = ( cmu(i,km1) + cmu(i,k) ) * 0.5_r8
+          cms(i,k) = ( cms(i,km1) + cms(i,k) ) * 0.5_r8
+          ch       = chu(i,k) * ( 1._r8 - sfi(i,k) ) + chs(i,k) * sfi(i,k)
+          cm       = cmu(i,k) * ( 1._r8 - sfi(i,k) ) + cms(i,k) * sfi(i,k)
+          n2(i,k)  = ch * dsldz +  cm * dqtdz
+          s2(i,k)  = ( ( u(i,km1) - u(i,k) )**2 + ( v(i,km1) - v(i,k) )**2) * rdz**2
+          s2(i,k)  = max( ntzero, s2(i,k) )
+          ri(i,k)  = n2(i,k) / s2(i,k)
+       end do
+    end do 
+    do i = 1, ncol
+       n2(i,1) = n2(i,2)
+       s2(i,1) = s2(i,2)
+       ri(i,1) = ri(i,2)
+    end do
+
+  return
+
+  end subroutine trbintd
+
+  !=============================================================================== !
+  !                                                                                !
+  !=============================================================================== !
+  
+  subroutine austausch_atm( pcols, pver, ncol, ri, s2, kvf )
+
+    !---------------------------------------------------------------------- ! 
+    !                                                                       !
+    ! Purpose: Computes exchange coefficients for free turbulent flows.     !
+    !          This is not used in the UW moist turbulence scheme.          !
+    !                                                                       !
+    ! Method:                                                               !
+    !                                                                       !
+    ! The free atmosphere diffusivities are based on standard mixing length !
+    ! forms for the neutral diffusivity multiplied by functns of Richardson !
+    ! number. K = l^2 * |dV/dz| * f(Ri). The same functions are used for    !
+    ! momentum, potential temperature, and constitutents.                   !
+    !                                                                       !
+    ! The stable Richardson num function (Ri>0) is taken from Holtslag and  !
+    ! Beljaars (1989), ECMWF proceedings. f = 1 / (1 + 10*Ri*(1 + 8*Ri))    !
+    ! The unstable Richardson number function (Ri<0) is taken from  CCM1.   !
+    ! f = sqrt(1 - 18*Ri)                                                   !
+    !                                                                       !
+    ! Author: B. Stevens (rewrite, August 2000)                             !
+    !                                                                       !
+    !---------------------------------------------------------------------- !
+    implicit none
+    
+    ! --------------- ! 
+    ! Input arguments !
+    ! --------------- !
+
+    integer,  intent(in)  :: pcols                ! Number of atmospheric columns   
+    integer,  intent(in)  :: pver                 ! Number of atmospheric layers   
+    integer,  intent(in)  :: ncol                 ! Number of atmospheric columns
+
+    real(r8), intent(in)  :: s2(pcols,pver)       ! Shear squared
+    real(r8), intent(in)  :: ri(pcols,pver)       ! Richardson no
+
+    ! ---------------- !
+    ! Output arguments !
+    ! ---------------- !
+
+    real(r8), intent(out) :: kvf(pcols,pver+1)    ! Eddy diffusivity for heat and tracers
+
+    ! --------------- !
+    ! Local Variables !
+    ! --------------- !
+
+    real(r8)              :: fofri                ! f(ri)
+    real(r8)              :: kvn                  ! Neutral Kv
+
+    integer               :: i                    ! Longitude index
+    integer               :: k                    ! Vertical index
+
+    ! ----------------------- !
+    ! Main Computation Begins !
+    ! ----------------------- !
+
+    kvf(:ncol,:)           = 0.0_r8
+    kvf(:ncol,pver+1)      = 0.0_r8
+    kvf(:ncol,1:ntop_turb) = 0.0_r8
+
+    ! Compute the free atmosphere vertical diffusion coefficients: kvh = kvq = kvm. 
+
+    do k = ntop_turb + 1, nbot_turb
+       do i = 1, ncol
+          if( ri(i,k) < 0.0_r8 ) then
+              fofri = sqrt( max( 1._r8 - 18._r8 * ri(i,k), 0._r8 ) )
+          else 
+              fofri = 1.0_r8 / ( 1.0_r8 + 10.0_r8 * ri(i,k) * ( 1.0_r8 + 8.0_r8 * ri(i,k) ) )    
+          end if
+          kvn = ml2(k) * sqrt(s2(i,k))
+          kvf(i,k) = max( zkmin, kvn * fofri )
+       end do
+    end do
+
+    return
+
+    end subroutine austausch_atm
+
+    ! ---------------------------------------------------------------------------- !
+    !                                                                              !
+    ! The University of Washington Moist Turbulence Scheme                         !
+    !                                                                              !
+    ! Authors : Chris Bretherton at the University of Washington, Seattle, WA      ! 
+    !           Sungsu Park at the CGD/NCAR, Boulder, CO                           !
+    !                                                                              !
+    ! ---------------------------------------------------------------------------- !
+
+    subroutine caleddy( pcols        , pver         , ncol        ,                             &
+                        sl           , qt           , ql          , slv        , u            , &
+                        v            , pi           , z           , zi         ,                &
+                        qflx         , shflx        , slslope     , qtslope    ,                &
+                        chu          , chs          , cmu         , cms        , sfuh         , &
+                        sflh         , n2           , s2          , ri         , rrho         , &
+                        pblh         , ustar        ,                                           &
+                        kvh_in       , kvm_in       , kvh         , kvm        ,                &
+                        tpert        , qpert        , qrlin       , kvf        , tke          , & 
+                        wstarent     , bprod        , sprod       , minpblh    , wpert        , &
+                        tkes         , turbtype_f   , sm_aw       ,                             &
+                        kbase_o      , ktop_o       , ncvfin_o    ,                             & 
+                        kbase_mg     , ktop_mg      , ncvfin_mg   ,                             & 
+                        kbase_f      , ktop_f       , ncvfin_f    ,                             & 
+                        wet_CL       , web_CL       , jtbu_CL     , jbbu_CL    ,                &
+                        evhc_CL      , jt2slv_CL    , n2ht_CL     , n2hb_CL    , lwp_CL       , &
+                        opt_depth_CL , radinvfrac_CL, radf_CL     , wstar_CL   , wstar3fact_CL, &
+                        ebrk         , wbrk         , lbrk        , ricl       , ghcl         , & 
+                        shcl         , smcl         ,                                           &
+                        gh_a         , sh_a         , sm_a        , ri_a       , leng         , & 
+                        wcap         , pblhp        , cld         , ipbl       , kpblh        , &
+                        wsedl        )
+
+    !--------------------------------------------------------------------------------- !
+    !                                                                                  !
+    ! Purpose : This is a driver routine to compute eddy diffusion coefficients        !
+    !           for heat (sl), momentum (u, v), moisture (qt), and other  trace        !
+    !           constituents.   This scheme uses first order closure for stable        !
+    !           turbulent layers (STL). For convective layers (CL), entrainment        !
+    !           closure is used at the CL external interfaces, which is coupled        !
+    !           to the diagnosis of a CL regime mean TKE from the instantaneous        !
+    !           thermodynamic and velocity profiles.   The CLs are diagnosed by        !
+    !           extending original CL layers of moist static instability   into        !
+    !           adjacent weakly stably stratified interfaces,   stopping if the        !
+    !           stability is too strong.   This allows a realistic depiction of        !
+    !           dry convective boundary layers with a downgradient approach.           !
+    !                                                                                  !   
+    ! NOTE:     This routine currently assumes ntop_turb = 1, nbot_turb = pver         !
+    !           ( turbulent diffusivities computed at all interior interfaces )        !
+    !           and will require modification to handle a different ntop_turb.         ! 
+    !                                                                                  !
+    ! Authors:  Sungsu Park and Chris Bretherton. 08/2006, 05/2008.                    !
+    !                                                                                  ! 
+    ! For details, see                                                                 !
+    !                                                                                  !
+    ! 1. 'A new moist turbulence parametrization in the Community Atmosphere Model'    !
+    !     by Christopher S. Bretherton & Sungsu Park. J. Climate. 22. 3422-3448. 2009. !
+    !                                                                                  !
+    ! 2. 'The University of Washington shallow convection and moist turbulence schemes !
+    !     and their impact on climate simulations with the Community Atmosphere Model' !
+    !     by Sungsu Park & Christopher S. Bretherton. J. Climate. 22. 3449-3469. 2009. !
+    !                                                                                  !
+    ! For questions on the scheme and code, send an email to                           !
+    !     sungsup@ucar.edu or breth@washington.edu                                     !
+    !                                                                                  !
+    !--------------------------------------------------------------------------------- !
+
+    ! ---------------- !
+    ! Inputs variables !
+    ! ---------------- !
+
+    implicit none
+
+    integer,  intent(in) :: pcols                     ! Number of atmospheric columns   
+    integer,  intent(in) :: pver                      ! Number of atmospheric layers   
+    integer,  intent(in) :: ncol                      ! Number of atmospheric columns   
+    real(r8), intent(in) :: u(pcols,pver)             ! U wind [ m/s ]
+    real(r8), intent(in) :: v(pcols,pver)             ! V wind [ m/s ]
+    real(r8), intent(in) :: sl(pcols,pver)            ! Liquid water static energy, cp * T + g * z - Lv * ql - Ls * qi [ J/kg ]
+    real(r8), intent(in) :: slv(pcols,pver)           ! Liquid water virtual static energy, sl * ( 1 + 0.608 * qt ) [ J/kg ]
+    real(r8), intent(in) :: qt(pcols,pver)            ! Total speccific humidity  qv + ql + qi [ kg/kg ] 
+    real(r8), intent(in) :: ql(pcols,pver)            ! Liquid water specific humidity [ kg/kg ]
+    real(r8), intent(in) :: pi(pcols,pver+1)          ! Interface pressures [ Pa ]
+    real(r8), intent(in) :: z(pcols,pver)             ! Layer midpoint height above surface [ m ]
+    real(r8), intent(in) :: zi(pcols,pver+1)          ! Interface height above surface, i.e., zi(pver+1) = 0 all over the globe [ m ]
+    real(r8), intent(in) :: chu(pcols,pver+1)         ! Buoyancy coeffi. unsaturated sl (heat) coef. at all interfaces. [ unit ? ]
+    real(r8), intent(in) :: chs(pcols,pver+1)         ! Buoyancy coeffi. saturated sl (heat) coef. at all interfaces. [ unit ? ]
+    real(r8), intent(in) :: cmu(pcols,pver+1)         ! Buoyancy coeffi. unsaturated qt (moisture) coef. at all interfaces [ unit ? ]
+    real(r8), intent(in) :: cms(pcols,pver+1)         ! Buoyancy coeffi. saturated qt (moisture) coef. at all interfaces [ unit ? ]
+    real(r8), intent(in) :: sfuh(pcols,pver)          ! Saturation fraction in upper half-layer [ fraction ]
+    real(r8), intent(in) :: sflh(pcols,pver)          ! Saturation fraction in lower half-layer [ fraction ]
+    real(r8), intent(in) :: n2(pcols,pver)            ! Interfacial (except surface) moist buoyancy frequency [ s-2 ]
+    real(r8), intent(in) :: s2(pcols,pver)            ! Interfacial (except surface) shear frequency [ s-2 ]
+    real(r8), intent(in) :: ri(pcols,pver)            ! Interfacial (except surface) Richardson number
+    real(r8), intent(in) :: qflx(pcols)               ! Kinematic surface constituent ( water vapor ) flux [ kg/m2/s ]
+    real(r8), intent(in) :: shflx(pcols)              ! Kinematic surface heat flux [ unit ? ] 
+    real(r8), intent(in) :: slslope(pcols,pver)       ! Slope of 'sl' in each layer [ J/kg/Pa ]
+    real(r8), intent(in) :: qtslope(pcols,pver)       ! Slope of 'qt' in each layer [ kg/kg/Pa ]
+    real(r8), intent(in) :: qrlin(pcols,pver)         ! Input grid-mean LW heating rate : [ K/s ] * cpair * dp = [ W/kg*Pa ]
+    real(r8), intent(in) :: wsedl(pcols,pver)         ! Sedimentation velocity of liquid stratus cloud droplet [ m/s ]
+    real(r8), intent(in) :: ustar(pcols)              ! Surface friction velocity [ m/s ]
+    real(r8), intent(in) :: rrho(pcols)               ! 1./bottom mid-point density. Specific volume [ m3/kg ]
+    real(r8), intent(in) :: kvf(pcols,pver+1)         ! Free atmosphere eddy diffusivity [ m2/s ]
+    logical,  intent(in) :: wstarent                  ! Switch for choosing wstar3 entrainment parameterization
+    real(r8), intent(in) :: minpblh(pcols)            ! Minimum PBL height based on surface stress [ m ]
+    real(r8), intent(in) :: kvh_in(pcols,pver+1)      ! kvh saved from last timestep or last iterative step [ m2/s ] 
+    real(r8), intent(in) :: kvm_in(pcols,pver+1)      ! kvm saved from last timestep or last iterative step [ m2/s ]
+    real(r8), intent(in) :: cld(pcols,pver)           ! Stratus Cloud Fraction [ fraction ]
+
+    ! ---------------- !
+    ! Output variables !
+    ! ---------------- !
+
+    real(r8), intent(out) :: kvh(pcols,pver+1)        ! Eddy diffusivity for heat, moisture, and tracers [ m2/s ]
+    real(r8), intent(out) :: kvm(pcols,pver+1)        ! Eddy diffusivity for momentum [ m2/s ]
+    real(r8), intent(out) :: pblh(pcols)              ! PBL top height [ m ]
+    real(r8), intent(out) :: pblhp(pcols)             ! PBL top height pressure [ Pa ]
+    real(r8), intent(out) :: tpert(pcols)             ! Convective temperature excess [ K ]
+    real(r8), intent(out) :: qpert(pcols)             ! Convective humidity excess [ kg/kg ]
+    real(r8), intent(out) :: wpert(pcols)             ! Turbulent velocity excess [ m/s ]
+    real(r8), intent(out) :: tke(pcols,pver+1)        ! Turbulent kinetic energy [ m2/s2 ], 'tkes' at surface, pver+1.
+    real(r8), intent(out) :: bprod(pcols,pver+1)      ! Buoyancy production [ m2/s3 ],     'bflxs' at surface, pver+1.
+    real(r8), intent(out) :: sprod(pcols,pver+1)      ! Shear production [ m2/s3 ], (ustar(i)**3)/(vk*z(i,pver))  at surface, pver+1.
+    real(r8), intent(out) :: turbtype_f(pcols,pver+1) ! Turbulence type at each interface:
+                                                      ! 0. = Non turbulence interface
+                                                      ! 1. = Stable turbulence interface
+                                                      ! 2. = CL interior interface ( if bflxs > 0, surface is this )
+                                                      ! 3. = Bottom external interface of CL
+                                                      ! 4. = Top external interface of CL.
+                                                      ! 5. = Double entraining CL external interface 
+    real(r8), intent(out) :: sm_aw(pcols,pver+1)      ! Galperin instability function of momentum for use in the microphysics [ no unit ]
+    real(r8), intent(out) :: ipbl(pcols)              ! If 1, PBL is CL, while if 0, PBL is STL.
+    real(r8), intent(out) :: kpblh(pcols)             ! Layer index containing PBL within or at the base interface
+
+    ! --------------------------- !
+    ! Diagnostic output variables !
+    ! --------------------------- !
+
+    real(r8) :: tkes(pcols)                           ! TKE at surface [ m2/s2 ] 
+    real(r8) :: kbase_o(pcols,ncvmax)                 ! Original external base interface index of CL just after 'exacol'
+    real(r8) :: ktop_o(pcols,ncvmax)                  ! Original external top  interface index of CL just after 'exacol'
+    real(r8) :: ncvfin_o(pcols)                       ! Original number of CLs just after 'exacol'
+    real(r8) :: kbase_mg(pcols,ncvmax)                ! kbase  just after extending-merging (after 'zisocl') but without SRCL
+    real(r8) :: ktop_mg(pcols,ncvmax)                 ! ktop   just after extending-merging (after 'zisocl') but without SRCL
+    real(r8) :: ncvfin_mg(pcols)                      ! ncvfin just after extending-merging (after 'zisocl') but without SRCL
+    real(r8) :: kbase_f(pcols,ncvmax)                 ! Final kbase  after adding SRCL
+    real(r8) :: ktop_f(pcols,ncvmax)                  ! Final ktop   after adding SRCL
+    real(r8) :: ncvfin_f(pcols)                       ! Final ncvfin after adding SRCL
+    real(r8) :: wet_CL(pcols,ncvmax)                  ! Entrainment rate at the CL top [ m/s ] 
+    real(r8) :: web_CL(pcols,ncvmax)                  ! Entrainment rate at the CL base [ m/s ]
+    real(r8) :: jtbu_CL(pcols,ncvmax)                 ! Buoyancy jump across the CL top [ m/s2 ]  
+    real(r8) :: jbbu_CL(pcols,ncvmax)                 ! Buoyancy jump across the CL base [ m/s2 ]  
+    real(r8) :: evhc_CL(pcols,ncvmax)                 ! Evaporative enhancement factor at the CL top
+    real(r8) :: jt2slv_CL(pcols,ncvmax)               ! Jump of slv ( across two layers ) at CL top for use only in evhc [ J/kg ]
+    real(r8) :: n2ht_CL(pcols,ncvmax)                 ! n2 defined at the CL top  interface but using sfuh(kt)   instead of sfi(kt) [ s-2 ]
+    real(r8) :: n2hb_CL(pcols,ncvmax)                 ! n2 defined at the CL base interface but using sflh(kb-1) instead of sfi(kb) [ s-2 ]
+    real(r8) :: lwp_CL(pcols,ncvmax)                  ! LWP in the CL top layer [ kg/m2 ]
+    real(r8) :: opt_depth_CL(pcols,ncvmax)            ! Optical depth of the CL top layer
+    real(r8) :: radinvfrac_CL(pcols,ncvmax)           ! Fraction of LW radiative cooling confined in the top portion of CL
+    real(r8) :: radf_CL(pcols,ncvmax)                 ! Buoyancy production at the CL top due to radiative cooling [ m2/s3 ]
+    real(r8) :: wstar_CL(pcols,ncvmax)                ! Convective velocity of CL including entrainment contribution finally [ m/s ]
+    real(r8) :: wstar3fact_CL(pcols,ncvmax)           ! "wstar3fact" of CL. Entrainment enhancement of wstar3 (inverse)
+
+    real(r8) :: gh_a(pcols,pver+1)                    ! Half of normalized buoyancy production, -l2n2/2e. [ no unit ]
+    real(r8) :: sh_a(pcols,pver+1)                    ! Galperin instability function of heat-moisture at all interfaces [ no unit ]
+    real(r8) :: sm_a(pcols,pver+1)                    ! Galperin instability function of momentum      at all interfaces [ no unit ]
+    real(r8) :: ri_a(pcols,pver+1)                    ! Interfacial Richardson number                  at all interfaces [ no unit ]
+
+    real(r8) :: ebrk(pcols,ncvmax)                    ! Net CL mean TKE [ m2/s2 ]
+    real(r8) :: wbrk(pcols,ncvmax)                    ! Net CL mean normalized TKE [ m2/s2 ]
+    real(r8) :: lbrk(pcols,ncvmax)                    ! Net energetic integral thickness of CL [ m ]
+    real(r8) :: ricl(pcols,ncvmax)                    ! Mean Richardson number of CL ( l2n2/l2s2 )
+    real(r8) :: ghcl(pcols,ncvmax)                    ! Half of normalized buoyancy production of CL                 
+    real(r8) :: shcl(pcols,ncvmax)                    ! Instability function of heat and moisture of CL
+    real(r8) :: smcl(pcols,ncvmax)                    ! Instability function of momentum of CL
+
+    real(r8) :: leng(pcols,pver+1)                    ! Turbulent length scale [ m ], 0 at the surface.
+    real(r8) :: wcap(pcols,pver+1)                    ! Normalized TKE [m2/s2], 'tkes/b1' at the surface and 'tke/b1' at
+                                                      ! the top/bottom entrainment interfaces of CL assuming no transport.
+    ! ------------------------ !
+    ! Local Internal Variables !
+    ! ------------------------ !
+
+    logical :: belongcv(pcols,pver+1)                 ! True for interfaces in a CL (both interior and exterior are included)
+    logical :: belongst(pcols,pver+1)                 ! True for stable turbulent layer interfaces (STL)
+    logical :: in_CL                                  ! True if interfaces k,k+1 both in same CL.
+    logical :: extend                                 ! True when CL is extended in zisocl
+    logical :: extend_up                              ! True when CL is extended upward in zisocl
+    logical :: extend_dn                              ! True when CL is extended downward in zisocl
+
+    integer :: i                                      ! Longitude index
+    integer :: k                                      ! Vertical index
+    integer :: ks                                     ! Vertical index
+    integer :: ncvfin(pcols)                          ! Total number of CL in column
+    integer :: ncvf                                   ! Total number of CL in column prior to adding SRCL
+    integer :: ncv                                    ! Index of current CL
+    integer :: ncvnew                                 ! Index of added SRCL appended after regular CLs from 'zisocl'
+    integer :: ncvsurf                                ! If nonzero, CL index based on surface (usually 1, but can be > 1 when SRCL is based at sfc)
+    integer :: kbase(pcols,ncvmax)                    ! Vertical index of CL base interface
+    integer :: ktop(pcols,ncvmax)                     ! Vertical index of CL top interface
+    integer :: kb, kt                                 ! kbase and ktop for current CL
+    integer :: ktblw                                  ! ktop of the CL located at just below the current CL
+    integer :: turbtype(pcols,pver+1)                 ! Interface turbulence type :
+                                                      ! 0 = Non turbulence interface
+                                                      ! 1 = Stable turbulence interface
+                                                      ! 2 = CL interior interface ( if bflxs > 0, sfc is this )
+                                                      ! 3 = Bottom external interface of CL
+                                                      ! 4 = Top external interface of CL
+                                                      ! 5 = Double entraining CL external interface
+    integer  :: ktopbl(pcols)                         ! PBL top height or interface index 
+    real(r8) :: bflxs(pcols)                          ! Surface buoyancy flux [ m2/s3 ]
+    real(r8) :: rcap                                  ! 'tke/ebrk' at all interfaces of CL. Set to 1 at the CL entrainment interfaces
+    real(r8) :: jtzm                                  ! Interface layer thickness of CL top interface [ m ]
+    real(r8) :: jtsl                                  ! Jump of s_l across CL top interface [ J/kg ]
+    real(r8) :: jtqt                                  ! Jump of q_t across CL top interface [ kg/kg ]
+    real(r8) :: jtbu                                  ! Jump of buoyancy across CL top interface [ m/s2 ]
+    real(r8) :: jtu                                   ! Jump of u across CL top interface [ m/s ]
+    real(r8) :: jtv                                   ! Jump of v across CL top interface [ m/s ]
+    real(r8) :: jt2slv                                ! Jump of slv ( across two layers ) at CL top for use only in evhc [ J/kg ]
+    real(r8) :: radf                                  ! Buoyancy production at the CL top due to radiative cooling [ m2/s3 ]
+    real(r8) :: jbzm                                  ! Interface layer thickness of CL base interface [ m ]
+    real(r8) :: jbsl                                  ! Jump of s_l across CL base interface [ J/kg ]
+    real(r8) :: jbqt                                  ! Jump of q_t across CL top interface [ kg/kg ]
+    real(r8) :: jbbu                                  ! Jump of buoyancy across CL base interface [ m/s2 ]
+    real(r8) :: jbu                                   ! Jump of u across CL base interface [ m/s ]
+    real(r8) :: jbv                                   ! Jump of v across CL base interface [ m/s ]
+    real(r8) :: ch                                    ! Buoyancy coefficients defined at the CL top and base interfaces using CL internal
+    real(r8) :: cm                                    ! sfuh(kt) and sflh(kb-1) instead of sfi(kt) and sfi(kb), respectively. These are 
+                                                      ! used for entrainment calculation at CL external interfaces and SRCL identification.
+    real(r8) :: n2ht                                  ! n2 defined at the CL top  interface but using sfuh(kt)   instead of sfi(kt) [ s-2 ]
+    real(r8) :: n2hb                                  ! n2 defined at the CL base interface but using sflh(kb-1) instead of sfi(kb) [ s-2 ]
+    real(r8) :: n2htSRCL                              ! n2 defined at the upper-half layer of SRCL. This is used only for identifying SRCL.
+                                                      ! n2htSRCL use SRCL internal slope sl and qt as well as sfuh(kt) instead of sfi(kt) [ s-2 ]
+    real(r8) :: gh                                    ! Half of normalized buoyancy production ( -l2n2/2e ) [ no unit ]
+    real(r8) :: sh                                    ! Galperin instability function for heat and moisture
+    real(r8) :: sm                                    ! Galperin instability function for momentum
+    real(r8) :: lbulk                                 ! Depth of turbulent layer, Master length scale (not energetic length)
+    real(r8) :: dzht                                  ! Thickness of top    half-layer [ m ]
+    real(r8) :: dzhb                                  ! Thickness of bottom half-layer [ m ]
+    real(r8) :: rootp                                 ! Sqrt(net CL-mean TKE including entrainment contribution) [ m/s ]     
+    real(r8) :: evhc                                  ! Evaporative enhancement factor: (1+E) with E = evap. cool. efficiency [ no unit ]
+    real(r8) :: kentr                                 ! Effective entrainment diffusivity 'wet*dz', 'web*dz' [ m2/s ]
+    real(r8) :: lwp                                   ! Liquid water path in the layer kt [ kg/m2 ]
+    real(r8) :: opt_depth                             ! Optical depth of the layer kt [ no unit ]
+    real(r8) :: radinvfrac                            ! Fraction of LW cooling in the layer kt concentrated at the CL top [ no unit ]
+    real(r8) :: wet                                   ! CL top entrainment rate [ m/s ]
+    real(r8) :: web                                   ! CL bot entrainment rate [ m/s ]. Set to zero if CL is based at surface.
+    real(r8) :: vyt                                   ! n2ht/n2 at the CL top  interface
+    real(r8) :: vyb                                   ! n2hb/n2 at the CL base interface
+    real(r8) :: vut                                   ! Inverse Ri (=s2/n2) at the CL top  interface
+    real(r8) :: vub                                   ! Inverse Ri (=s2/n2) at the CL base interface
+    real(r8) :: fact                                  ! Factor relating TKE generation to entrainment [ no unit ]
+    real(r8) :: trma                                  ! Intermediate variables used for solving quadratic ( for gh from ri )
+    real(r8) :: trmb                                  ! and cubic equations ( for ebrk: the net CL mean TKE )
+    real(r8) :: trmc                                  !
+    real(r8) :: trmp                                  !
+    real(r8) :: trmq                                  !
+    real(r8) :: qq                                    ! 
+    real(r8) :: det                                   !
+    real(r8) :: gg                                    ! Intermediate variable used for calculating stability functions of
+                                                      ! SRCL or SBCL based at the surface with bflxs > 0.
+    real(r8) :: dzhb5                                 ! Half thickness of the bottom-most layer of current CL regime
+    real(r8) :: dzht5                                 ! Half thickness of the top-most layer of adjacent CL regime just below current CL
+    real(r8) :: qrlw(pcols,pver)                      ! Local grid-mean LW heating rate : [K/s] * cpair * dp = [ W/kg*Pa ]
+
+    real(r8) :: cldeff(pcols,pver)                    ! Effective stratus fraction
+    real(r8) :: qleff                                 ! Used for computing evhc
+    real(r8) :: tunlramp                              ! Ramping tunl
+    real(r8) :: leng_imsi                             ! For Kv = max(Kv_STL, Kv_entrain)
+    real(r8) :: tke_imsi                              !
+    real(r8) :: kvh_imsi                              !
+    real(r8) :: kvm_imsi                              !
+    real(r8) :: alph4exs                              ! For extended stability function in the stable regime
+    real(r8) :: ghmin                                 !   
+
+    real(r8) :: sedfact                               ! For 'sedimentation-entrainment feedback' 
+
+    ! Local variables specific for 'wstar' entrainment closure
+
+    real(r8) :: cet                                   ! Proportionality coefficient between wet and wstar3
+    real(r8) :: ceb                                   ! Proportionality coefficient between web and wstar3
+    real(r8) :: wstar                                 ! Convective velocity for CL [ m/s ]
+    real(r8) :: wstar3                                ! Cubed convective velocity for CL [ m3/s3 ]
+    real(r8) :: wstar3fact                            ! 1/(relative change of wstar^3 by entrainment)
+    real(r8) :: rmin                                  ! sqrt(p)
+    real(r8) :: fmin                                  ! f(rmin), where f(r) = r^3 - 3*p*r - 2q
+    real(r8) :: rcrit                                 ! ccrit*wstar
+    real(r8) :: fcrit                                 ! f(rcrit)
+    logical     noroot                                ! True if f(r) has no root r > rcrit
+
+    !-----------------------!
+    ! Start of Main Program !
+    !-----------------------!
+    
+    ! Option: Turn-off LW radiative-turbulence interaction in PBL scheme
+    !         by setting qrlw = 0.  Logical parameter 'set_qrlzero'  was
+    !         defined in the first part of 'eddy_diff.F90' module. 
+
+    if( set_qrlzero ) then
+        qrlw(:,:) = 0._r8
+    else
+        qrlw(:ncol,:pver) = qrlin(:ncol,:pver)
+    endif
+
+    ! Define effective stratus fraction using the grid-mean ql.
+    ! Modification : The contribution of ice should be carefully considered.
+    !                This should be done in combination with the 'qrlw' and
+    !                overlapping assumption of liquid and ice stratus. 
+
+    do k = 1, pver
+       do i = 1, ncol
+          if( choice_evhc .eq. 'ramp' .or. choice_radf .eq. 'ramp' ) then 
+              cldeff(i,k) = cld(i,k) * min( ql(i,k) / qmin, 1._r8 )
+          else
+              cldeff(i,k) = cld(i,k)
+          endif
+       end do
+    end do
+
+    ! For an extended stability function in the stable regime, re-define
+    ! alph4exe and ghmin. This is for future work.
+
+    if( ricrit .eq. 0.19_r8 ) then
+        alph4exs = alph4
+        ghmin    = -3.5334_r8
+    elseif( ricrit .gt. 0.19_r8 ) then
+        alph4exs = -2._r8 * b1 * alph2 / ( alph3 - 2._r8 * b1 * alph5 ) / ricrit
+        ghmin    = -1.e10_r8
+    else
+        write(iulog,*) 'Error : ricrit should be larger than 0.19 in UW PBL'       
+        stop
+    endif
+
+    !
+    ! Initialization of Diagnostic Output
+    !
+
+    do i = 1, ncol
+       wet_CL(i,:ncvmax)        = 0._r8
+       web_CL(i,:ncvmax)        = 0._r8
+       jtbu_CL(i,:ncvmax)       = 0._r8
+       jbbu_CL(i,:ncvmax)       = 0._r8
+       evhc_CL(i,:ncvmax)       = 0._r8
+       jt2slv_CL(i,:ncvmax)     = 0._r8
+       n2ht_CL(i,:ncvmax)       = 0._r8
+       n2hb_CL(i,:ncvmax)       = 0._r8                    
+       lwp_CL(i,:ncvmax)        = 0._r8
+       opt_depth_CL(i,:ncvmax)  = 0._r8
+       radinvfrac_CL(i,:ncvmax) = 0._r8
+       radf_CL(i,:ncvmax)       = 0._r8
+       wstar_CL(i,:ncvmax)      = 0._r8          
+       wstar3fact_CL(i,:ncvmax) = 0._r8
+       ricl(i,:ncvmax)          = 0._r8
+       ghcl(i,:ncvmax)          = 0._r8
+       shcl(i,:ncvmax)          = 0._r8
+       smcl(i,:ncvmax)          = 0._r8
+       ebrk(i,:ncvmax)          = 0._r8
+       wbrk(i,:ncvmax)          = 0._r8
+       lbrk(i,:ncvmax)          = 0._r8
+       gh_a(i,:pver+1)          = 0._r8
+       sh_a(i,:pver+1)          = 0._r8
+       sm_a(i,:pver+1)          = 0._r8
+       ri_a(i,:pver+1)          = 0._r8
+       sm_aw(i,:pver+1)         = 0._r8
+       ipbl(i)                  = 0._r8
+       kpblh(i)                 = real(pver,r8)
+    end do  
+
+    ! kvh and kvm are stored over timesteps in 'vertical_diffusion.F90' and 
+    ! passed in as kvh_in and kvm_in.  However,  at the first timestep they
+    ! need to be computed and these are done just before calling 'caleddy'.   
+    ! kvm and kvh are also stored over iterative time step in the first part
+    ! of 'eddy_diff.F90'
+
+    do k = 1, pver + 1
+       do i = 1, ncol
+        ! Initialize kvh and kvm to zero or kvf
+          if( use_kvf ) then
+              kvh(i,k) = kvf(i,k)
+              kvm(i,k) = kvf(i,k)
+          else
+              kvh(i,k) = 0._r8
+              kvm(i,k) = 0._r8
+          end if
+        ! Zero diagnostic quantities for the new diffusion step.
+          wcap(i,k) = 0._r8
+          leng(i,k) = 0._r8
+          tke(i,k)  = 0._r8
+          turbtype(i,k) = 0
+       end do
+    end do
+
+    ! Initialize 'bprod' [ m2/s3 ] and 'sprod' [ m2/s3 ] at all interfaces.
+    ! Note this initialization is a hybrid initialization since 'n2' [s-2] and 's2' [s-2]
+    ! are calculated from the given current initial profile, while 'kvh_in' [m2/s] and 
+    ! 'kvm_in' [m2/s] are from the previous iteration or previous time step.
+    ! This initially guessed 'bprod' and 'sprod' will be updated at the end of this 
+    ! 'caleddy' subroutine for diagnostic output.
+    ! This computation of 'brpod,sprod' below is necessary for wstar-based entrainment closure.
+
+    do k = 2, pver
+       do i = 1, ncol
+            bprod(i,k) = -kvh_in(i,k) * n2(i,k)
+            sprod(i,k) =  kvm_in(i,k) * s2(i,k)
+       end do
+    end do
+
+    ! Set 'bprod' and 'sprod' at top and bottom interface.
+    ! In calculating 'surface' (actually lowest half-layer) buoyancy flux,
+    ! 'chu' at surface is defined to be the same as 'chu' at the mid-point
+    ! of lowest model layer (pver) at the end of 'trbind'. The same is for
+    ! the other buoyancy coefficients.  'sprod(i,pver+1)'  is defined in a
+    ! consistent way as the definition of 'tkes' in the original code.
+    ! ( Important Option ) If I want to isolate surface buoyancy flux from
+    ! the other parts of CL regimes energetically even though bflxs > 0,
+    ! all I should do is to re-define 'bprod(i,pver+1)=0' in the below 'do'
+    ! block. Additionally for merging test of extending SBCL based on 'l2n2'
+    ! in 'zisocl', I should use 'l2n2 = - wint / sh'  for similar treatment
+    ! as previous code. All other parts of the code  are fully consistently
+    ! treated by these change only.
+    ! My future general convection scheme will use bflxs(i).
+
+    do i = 1, ncol
+       bprod(i,1) = 0._r8 ! Top interface
+       sprod(i,1) = 0._r8 ! Top interface
+       ch = chu(i,pver+1) * ( 1._r8 - sflh(i,pver) ) + chs(i,pver+1) * sflh(i,pver)   
+       cm = cmu(i,pver+1) * ( 1._r8 - sflh(i,pver) ) + cms(i,pver+1) * sflh(i,pver)   
+       bflxs(i) = ch * shflx(i) * rrho(i) + cm * qflx(i) * rrho(i)
+       if( choice_tkes .eq. 'ibprod' ) then
+           bprod(i,pver+1) = bflxs(i)
+       else
+           bprod(i,pver+1) = 0._r8
+       endif
+       sprod(i,pver+1) = (ustar(i)**3)/(vk*z(i,pver))
+    end do
+
+    ! Initially identify CL regimes in 'exacol'
+    !    ktop  : Interface index of the CL top  external interface
+    !    kbase : Interface index of the CL base external interface
+    !    ncvfin: Number of total CLs
+    ! Note that if surface buoyancy flux is positive ( bflxs = bprod(i,pver+1) > 0 ),
+    ! surface interface is identified as an internal interface of CL. However, even
+    ! though bflxs <= 0, if 'pver' interface is a CL internal interface (ri(pver)<0),
+    ! surface interface is identified as an external interface of CL. If bflxs =< 0 
+    ! and ri(pver) >= 0, then surface interface is identified as a stable turbulent
+    ! intereface (STL) as shown at the end of 'caleddy'. Even though a 'minpblh' is
+    ! passed into 'exacol', it is not used in the 'exacol'.
+
+    call exacol( pcols, pver, ncol, ri, bflxs, minpblh, zi, ktop, kbase, ncvfin )
+
+    ! Diagnostic output of CL interface indices before performing 'extending-merging'
+    ! of CL regimes in 'zisocl'
+    do i = 1, ncol
+    do k = 1, ncvmax
+       kbase_o(i,k) = real(kbase(i,k),r8)
+       ktop_o(i,k)  = real(ktop(i,k),r8) 
+       ncvfin_o(i)  = real(ncvfin(i),r8)
+    end do
+    end do 
+
+    ! ----------------------------------- !
+    ! Perform calculation for each column !
+    ! ----------------------------------- !
+
+    do i = 1, ncol
+
+       ! Define Surface Interfacial Layer TKE, 'tkes'.
+       ! In the current code, 'tkes' is used as representing TKE of surface interfacial
+       ! layer (low half-layer of surface-based grid layer). In the code, when bflxs>0,
+       ! surface interfacial layer is assumed to be energetically  coupled to the other
+       ! parts of the CL regime based at the surface. In this sense, it is conceptually
+       ! more reasonable to include both 'bprod' and 'sprod' in the definition of 'tkes'.
+       ! Since 'tkes' cannot be negative, it is lower bounded by small positive number. 
+       ! Note that inclusion of 'bprod' in the definition of 'tkes' may increase 'ebrk'
+       ! and 'wstar3', and eventually, 'wet' at the CL top, especially when 'bflxs>0'.
+       ! This might help to solve the problem of too shallow PBLH over the overcast Sc
+       ! regime. If I want to exclude 'bprod(i,pver+1)' in calculating 'tkes' even when
+       ! bflxs > 0, all I should to do is to set 'bprod(i,pver+1) = 0' in the above 
+       ! initialization 'do' loop (explained above), NOT changing the formulation of
+       ! tkes(i) in the below block. This is because for consistent treatment in the 
+       ! other parts of the code also.
+  
+     ! tkes(i) = (b1*vk*z(i,pver)*sprod(i,pver+1))**(2._r8/3._r8)
+       tkes(i) = max(b1*vk*z(i,pver)*(bprod(i,pver+1)+sprod(i,pver+1)), 1.e-7_r8)**(2._r8/3._r8)
+       tkes(i) = min(tkes(i), tkemax)
+       tke(i,pver+1)  = tkes(i)
+       wcap(i,pver+1) = tkes(i)/b1
+
+       ! Extend and merge the initially identified CLs, relabel the CLs, and calculate
+       ! CL internal mean energetics and stability functions in 'zisocl'. 
+       ! The CL nearest to the surface is CL(1) and the CL index, ncv, increases 
+       ! with height. The following outputs are from 'zisocl'. Here, the dimension
+       ! of below outputs are (pcols,ncvmax) (except the 'ncvfin(pcols)' and 
+       ! 'belongcv(pcols,pver+1)) and 'ncv' goes from 1 to 'ncvfin'. 
+       ! For 'ncv = ncvfin+1, ncvmax', below output are already initialized to be zero. 
+       !      ncvfin       : Total number of CLs
+       !      kbase(ncv)   : Base external interface index of CL
+       !      ktop         : Top  external interface index of CL
+       !      belongcv     : True if the interface (either internal or external) is CL  
+       !      ricl         : Mean Richardson number of internal CL
+       !      ghcl         : Normalized buoyancy production '-l2n2/2e' [no unit] of internal CL
+       !      shcl         : Galperin instability function of heat-moisture of internal CL
+       !      smcl         : Galperin instability function of momentum of internal CL
+       !      lbrk, <l>int : Thickness of (energetically) internal CL (lint, [m])
+       !      wbrk, <W>int : Mean normalized TKE of internal CL  ([m2/s2])
+       !      ebrk, <e>int : Mean TKE of internal CL (b1*wbrk,[m2/s2])
+       ! The ncvsurf is an identifier saying which CL regime is based at the surface.
+       ! If 'ncvsurf=1', then the first CL regime is based at the surface. If surface
+       ! interface is not a part of CL (neither internal nor external), 'ncvsurf = 0'.
+       ! After identifying and including SRCLs into the normal CL regimes (where newly
+       ! identified SRCLs are simply appended to the normal CL regimes using regime 
+       ! indices of 'ncvfin+1','ncvfin+2' (as will be shown in the below SRCL part),..
+       ! where 'ncvfin' is the final CL regime index produced after extending-merging 
+       ! in 'zisocl' but before adding SRCLs), if any newly identified SRCL (e.g., 
+       ! 'ncvfin+1') is based at surface, then 'ncvsurf = ncvfin+1'. Thus 'ncvsurf' can
+       ! be 0, 1, or >1. 'ncvsurf' can be a useful diagnostic output.   
+
+       ncvsurf = 0
+       if( ncvfin(i) .gt. 0 ) then 
+           call zisocl( pcols  , pver     , i        ,           &
+                        z      , zi       , n2       , s2      , & 
+                        bprod  , sprod    , bflxs    , tkes    , &
+                        ncvfin , kbase    , ktop     , belongcv, &
+                        ricl   , ghcl     , shcl     , smcl    , & 
+                        lbrk   , wbrk     , ebrk     ,           & 
+                        extend , extend_up, extend_dn )
+           if( kbase(i,1) .eq. pver + 1 ) ncvsurf = 1
+       else
+           belongcv(i,:) = .false.
+       endif
+
+       ! Diagnostic output after finishing extending-merging process in 'zisocl'
+       ! Since we are adding SRCL additionally, we need to print out these here.
+
+       do k = 1, ncvmax
+          kbase_mg(i,k) = real(kbase(i,k))
+          ktop_mg(i,k)  = real(ktop(i,k)) 
+          ncvfin_mg(i)  = real(ncvfin(i))
+       end do 
+
+       ! ----------------------- !
+       ! Identification of SRCLs !
+       ! ----------------------- !
+
+     ! Modification : This cannot identify the 'cirrus' layer due to the condition of
+     !                ql(i,k) .gt. qmin. This should be modified in future to identify
+     !                a single thin cirrus layer.  
+     !                Instead of ql, we may use cldn in future, including ice 
+     !                contribution.
+
+       ! ------------------------------------------------------------------------------ !
+       ! Find single-layer radiatively-driven cloud-topped convective layers (SRCLs).   !
+       ! SRCLs extend through a single model layer k, with entrainment at the top and   !
+       ! bottom interfaces, unless bottom interface is the surface.                     !
+       ! The conditions for an SRCL is identified are:                                  ! 
+       !                                                                                !
+       !   1. Cloud in the layer, k : ql(i,k) .gt. qmin = 1.e-5 [ kg/kg ]               !
+       !   2. No cloud in the above layer (else assuming that some fraction of the LW   !
+       !      flux divergence in layer k is concentrated at just below top interface    !
+       !      of layer k is invalid). Then, this condition might be sensitive to the    !
+       !      vertical resolution of grid.                                              !
+       !   3. LW radiative cooling (SW heating is assumed uniformly distributed through !
+       !      layer k, so not relevant to buoyancy production) in the layer k. However, !
+       !      SW production might also contribute, which may be considered in a future. !
+       !   4. Internal stratification 'n2ht' of upper-half layer should be unstable.    !
+       !      The 'n2ht' is pure internal stratification of upper half layer, obtained  !
+       !      using internal slopes of sl, qt in layer k (in contrast to conventional   !
+       !      interfacial slope) and saturation fraction in the upper-half layer,       !
+       !      sfuh(k) (in contrast to sfi(k)).                                          !
+       !   5. Top and bottom interfaces not both in the same existing convective layer. !
+       !      If SRCL is within the previouisly identified CL regimes, we don't define  !
+       !      a new SRCL.                                                               !
+       !   6. k >= ntop_turb + 1 = 2                                                    !
+       !   7. Ri at the top interface > ricrit = 0.19 (otherwise turbulent mixing will  !
+       !      broadly distribute the cloud top in the vertical, preventing localized    !
+       !      radiative destabilization at the top interface).                          !
+       !                                                                                !
+       ! Note if 'k = pver', it identifies a surface-based single fog layer, possibly,  !
+       ! warm advection fog. Note also the CL regime index of SRCLs itself increases    !
+       ! with height similar to the regular CLs indices identified from 'zisocl'.       !
+       ! ------------------------------------------------------------------------------ !
+
+       ncv  = 1
+       ncvf = ncvfin(i)
+
+       if( choice_SRCL .eq. 'remove' ) goto 222 
+
+       do k = nbot_turb, ntop_turb + 1, -1 ! 'k = pver, 2, -1' is a layer index.
+
+          if( ql(i,k) .gt. qmin .and. ql(i,k-1) .lt. qmin .and. qrlw(i,k) .lt. 0._r8 &
+                                .and. ri(i,k) .ge. ricrit ) then
+
+              ! In order to avoid any confliction with the treatment of ambiguous layer,
+              ! I need to impose an additional constraint that ambiguous layer cannot be
+              ! SRCL. So, I added constraint that 'k+1' interface (base interface of k
+              ! layer) should not be a part of previously identified CL. Since 'belongcv'
+              ! is even true for external entrainment interfaces, below constraint is
+              ! fully sufficient.
+ 
+              if( choice_SRCL .eq. 'nonamb' .and. belongcv(i,k+1) ) then
+                  go to 220 
+              endif
+
+              ch = ( 1._r8 - sfuh(i,k) ) * chu(i,k) + sfuh(i,k) * chs(i,k)
+              cm = ( 1._r8 - sfuh(i,k) ) * cmu(i,k) + sfuh(i,k) * cms(i,k)
+
+              n2htSRCL = ch * slslope(i,k) + cm * qtslope(i,k)
+
+              if( n2htSRCL .le. 0._r8 ) then
+
+                  ! Test if bottom and top interfaces are part of the pre-existing CL. 
+                  ! If not, find appropriate index for the new SRCL. Note that this
+                  ! calculation makes use of 'ncv set' obtained from 'zisocl'. The 
+                  ! 'in_CL' is a parameter testing whether the new SRCL is already 
+                  ! within the pre-existing CLs (.true.) or not (.false.). 
+
+                  in_CL = .false.
+
+                  do while ( ncv .le. ncvf )
+                     if( ktop(i,ncv) .le. k ) then
+                        if( kbase(i,ncv) .gt. k ) then 
+                            in_CL = .true.
+                        endif
+                        exit             ! Exit from 'do while' loop if SRCL is within the CLs.
+                     else
+                        ncv = ncv + 1    ! Go up one CL
+                     end if
+                  end do ! ncv
+
+                  if( .not. in_CL ) then ! SRCL is not within the pre-existing CLs.
+
+                     ! Identify a new SRCL and add it to the pre-existing CL regime group.
+
+                     ncvfin(i)       =  ncvfin(i) + 1
+                     ncvnew          =  ncvfin(i)
+                     ktop(i,ncvnew)  =  k
+                     kbase(i,ncvnew) =  k+1
+                     belongcv(i,k)   = .true.
+                     belongcv(i,k+1) = .true.
+
+                     ! Calculate internal energy of SRCL. There is no internal energy if
+                     ! SRCL is elevated from the surface. Also, we simply assume neutral 
+                     ! stability function. Note that this assumption of neutral stability
+                     ! does not influence numerical calculation- stability functions here
+                     ! are just for diagnostic output. In general SRCLs other than a SRCL 
+                     ! based at surface with bflxs <= 0, there is no other way but to use
+                     ! neutral stability function.  However, in case of SRCL based at the
+                     ! surface,  we can explicitly calculate non-zero stability functions            
+                     ! in a consistent way.   Even though stability functions of SRCL are
+                     ! just diagnostic outputs not influencing numerical calculations, it
+                     ! would be informative to write out correct reasonable values rather
+                     ! than simply assuming neutral stability. I am doing this right now.
+                     ! Similar calculations were done for the SBCL and when surface inter
+                     ! facial layer was merged by overlying CL in 'ziscol'.
+
+                     if( k .lt. pver ) then
+
+                         wbrk(i,ncvnew) = 0._r8
+                         ebrk(i,ncvnew) = 0._r8
+                         lbrk(i,ncvnew) = 0._r8
+                         ghcl(i,ncvnew) = 0._r8
+                         shcl(i,ncvnew) = 0._r8
+                         smcl(i,ncvnew) = 0._r8
+                         ricl(i,ncvnew) = 0._r8
+
+                     else ! Surface-based fog
+
+                         if( bflxs(i) .gt. 0._r8 ) then    ! Incorporate surface TKE into CL interior energy
+                                                           ! It is likely that this case cannot exist  since
+                                                           ! if surface buoyancy flux is positive,  it would
+                                                           ! have been identified as SBCL in 'zisocl' ahead. 
+                             ebrk(i,ncvnew) = tkes(i)
+                             lbrk(i,ncvnew) = z(i,pver)
+                             wbrk(i,ncvnew) = tkes(i) / b1    
+        
+                             write(iulog,*) 'Major mistake in SRCL: bflxs > 0 for surface-based SRCL'
+                             write(iulog,*) 'bflxs = ', bflxs(i)
+                             write(iulog,*) 'ncvfin_o = ', ncvfin_o(i)
+                             write(iulog,*) 'ncvfin_mg = ', ncvfin_mg(i)
+                             do ks = 1, ncvmax
+                                write(iulog,*) 'ncv =', ks, ' ', kbase_o(i,ks), ktop_o(i,ks), kbase_mg(i,ks), ktop_mg(i,ks)
+                             end do
+                             stop
+
+                         else                              ! Don't incorporate surface interfacial TKE into CL interior energy
+
+                             ebrk(i,ncvnew) = 0._r8
+                             lbrk(i,ncvnew) = 0._r8
+                             wbrk(i,ncvnew) = 0._r8
+
+                         endif
+
+                         ! Calculate stability functions (ghcl, shcl, smcl, ricl) explicitly
+                         ! using an reverse procedure starting from tkes(i). Note that it is
+                         ! possible to calculate stability functions even when bflxs < 0.
+                         ! Previous code just assumed neutral stability functions. Note that
+                         ! since alph5 = 0.7 > 0, alph3 = -35 < 0, the denominator of gh  is
+                         ! always positive if bflxs > 0. However, if bflxs < 0,  denominator
+                         ! can be zero. For this case, we provide a possible maximum negative
+                         ! value (the most stable state) to gh. Note also tkes(i) is always a
+                         ! positive value by a limiter. Also, sprod(i,pver+1) > 0 by limiter.
+                         
+                         gg = 0.5_r8 * vk * z(i,pver) * bprod(i,pver+1) / ( tkes(i)**(3._r8/2._r8) )
+                         if( abs(alph5-gg*alph3) .le. 1.e-7_r8 ) then
+                           ! gh = -0.28_r8
+                           ! gh = -3.5334_r8
+                             gh = ghmin
+                         else    
+                             gh = gg / ( alph5 - gg * alph3 )
+                         end if 
+                       ! gh = min(max(gh,-0.28_r8),0.0233_r8)
+                       ! gh = min(max(gh,-3.5334_r8),0.0233_r8)
+                         gh = min(max(gh,ghmin),0.0233_r8)
+                         ghcl(i,ncvnew) =  gh
+                         shcl(i,ncvnew) =  max(0._r8,alph5/(1._r8+alph3*gh))
+                         smcl(i,ncvnew) =  max(0._r8,(alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4exs*gh))
+                         ricl(i,ncvnew) = -(smcl(i,ncvnew)/shcl(i,ncvnew))*(bprod(i,pver+1)/sprod(i,pver+1))
+
+                       ! 'ncvsurf' is CL regime index based at the surface. If there is no
+                       ! such regime, then 'ncvsurf = 0'.
+    
+                         ncvsurf = ncvnew
+
+                      end if
+
+                  end if
+
+              end if
+
+          end if
+
+   220 continue    
+
+       end do ! End of 'k' loop where 'k' is a grid layer index running from 'pver' to 2
+
+   222 continue
+
+       ! -------------------------------------------------------------------------- !
+       ! Up to this point, we identified all kinds of CL regimes :                  !
+       !   1. A SBCL. By construction, 'bflxs > 0' for SBCL.                        !
+       !   2. Surface-based CL with multiple layers and 'bflxs =< 0'                !
+       !   3. Surface-based CL with multiple layers and 'bflxs > 0'                 !
+       !   4. Regular elevated CL with two entraining interfaces                    ! 
+       !   5. SRCLs. If SRCL is based at surface, it will be bflxs < 0.             !
+       ! '1-4' were identified from 'zisocl' while '5' were identified separately   !
+       ! after performing 'zisocl'. CL regime index of '1-4' increases with height  !
+       ! ( e.g., CL = 1 is the CL regime nearest to the surface ) while CL regime   !
+       ! index of SRCL is simply appended after the final index of CL regimes from  !
+       ! 'zisocl'. However, CL regime indices of SRCLs itself increases with height !
+       ! when there are multiple SRCLs, similar to the regular CLs from 'zisocl'.   !
+       ! -------------------------------------------------------------------------- !
+
+       ! Diagnostic output of final CL regimes indices
+       
+       do k = 1, ncvmax
+          kbase_f(i,k) = real(kbase(i,k))
+          ktop_f(i,k)  = real(ktop(i,k)) 
+          ncvfin_f(i)  = real(ncvfin(i))
+       end do 
+
+       ! ---------------------------------------- !
+       ! Perform do loop for individual CL regime !
+       ! ---------------------------------------- ! -------------------------------- !
+       ! For individual CLs, compute                                                 !
+       !   1. Entrainment rates at the CL top and (if any) base interfaces using     !
+       !      appropriate entrainment closure (current code use 'wstar' closure).    !
+       !   2. Net CL mean (i.e., including entrainment contribution) TKE (ebrk)      !
+       !      and normalized TKE (wbrk).                                             ! 
+       !   3. TKE (tke) and normalized TKE (wcap) profiles at all CL interfaces.     !
+       !   4. ( kvm, kvh ) profiles at all CL interfaces.                            !
+       !   5. ( bprod, sprod ) profiles at all CL interfaces.                        !
+       ! Also calculate                                                              !
+       !   1. PBL height as the top external interface of surface-based CL, if any.  !
+       !   2. Characteristic excesses of convective 'updraft velocity (wpert)',      !
+       !      'temperature (tpert)', and 'moisture (qpert)' in the surface-based CL, !
+       !      if any, for use in the separate convection scheme.                     ! 
+       ! If there is no surface-based CL, 'PBL height' and 'convective excesses' are !
+       ! calculated later from surface-based STL (Stable Turbulent Layer) properties.!
+       ! --------------------------------------------------------------------------- !
+
+       ktblw = 0
+       do ncv = 1, ncvfin(i)
+
+          kt = ktop(i,ncv)
+          kb = kbase(i,ncv)
+          ! Check whether surface interface is energetically interior or not.
+          if( kb .eq. (pver+1) .and. bflxs(i) .le. 0._r8 ) then
+              lbulk = zi(i,kt) - z(i,pver)
+          else
+              lbulk = zi(i,kt) - zi(i,kb)
+          end if
+
+          ! Calculate 'turbulent length scale (leng)' and 'normalized TKE (wcap)'
+          ! at all CL interfaces except the surface.  Note that below 'wcap' at 
+          ! external interfaces are not correct. However, it does not influence 
+          ! numerical calculation and correct normalized TKE at the entraining 
+          ! interfaces will be re-calculated at the end of this 'do ncv' loop. 
+
+          do k = min(kb,pver), kt, -1 
+             if( choice_tunl .eq. 'rampcl' ) then
+               ! In order to treat the case of 'ricl(i,ncv) >> 0' of surface-based SRCL
+               ! with 'bflxs(i) < 0._r8', I changed ricl(i,ncv) -> min(0._r8,ricl(i,ncv))
+               ! in the below exponential. This is necessary to prevent the model crash
+               ! by too large values (e.g., 700) of ricl(i,ncv)   
+                 tunlramp = ctunl*tunl*(1._r8-(1._r8-1._r8/ctunl)*exp(min(0._r8,ricl(i,ncv))))
+                 tunlramp = min(max(tunlramp,tunl),ctunl*tunl)
+             elseif( choice_tunl .eq. 'rampsl' ) then
+                 tunlramp = ctunl*tunl
+               ! tunlramp = 0.765_r8
+             else
+                 tunlramp = tunl
+             endif
+             if( choice_leng .eq. 'origin' ) then
+                 leng(i,k) = ( (vk*zi(i,k))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng)
+               ! leng(i,k) = vk*zi(i,k) / (1._r8+vk*zi(i,k)/(tunlramp*lbulk))
+             else
+                 leng(i,k) = min( vk*zi(i,k), tunlramp*lbulk )              
+             endif
+             wcap(i,k) = (leng(i,k)**2) * (-shcl(i,ncv)*n2(i,k)+smcl(i,ncv)*s2(i,k))
+          end do ! k
+
+          ! Calculate basic cross-interface variables ( jump condition ) across the 
+          ! base external interface of CL.
+
+          if( kb .lt. pver+1 ) then 
+
+              jbzm = z(i,kb-1) - z(i,kb)                                      ! Interfacial layer thickness [m]
+              jbsl = sl(i,kb-1) - sl(i,kb)                                    ! Interfacial jump of 'sl' [J/kg]
+              jbqt = qt(i,kb-1) - qt(i,kb)                                    ! Interfacial jump of 'qt' [kg/kg]
+              jbbu = n2(i,kb) * jbzm                                          ! Interfacial buoyancy jump [m/s2] considering saturation ( > 0 ) 
+              jbbu = max(jbbu,jbumin)                                         ! Set minimum buoyancy jump, jbumin = 1.e-3
+              jbu  = u(i,kb-1) - u(i,kb)                                      ! Interfacial jump of 'u' [m/s]
+              jbv  = v(i,kb-1) - v(i,kb)                                      ! Interfacial jump of 'v' [m/s]
+              ch   = (1._r8 -sflh(i,kb-1))*chu(i,kb) + sflh(i,kb-1)*chs(i,kb) ! Buoyancy coefficient just above the base interface
+              cm   = (1._r8 -sflh(i,kb-1))*cmu(i,kb) + sflh(i,kb-1)*cms(i,kb) ! Buoyancy coefficient just above the base interface
+              n2hb = (ch*jbsl + cm*jbqt)/jbzm                                 ! Buoyancy frequency [s-2] just above the base interface
+              vyb  = n2hb*jbzm/jbbu                                           ! Ratio of 'n2hb/n2' at 'kb' interface
+              vub  = min(1._r8,(jbu**2+jbv**2)/(jbbu*jbzm) )                  ! Ratio of 's2/n2 = 1/Ri' at 'kb' interface
+
+          else 
+
+            ! Below setting is necessary for consistent treatment when 'kb' is at the surface.
+              jbbu = 0._r8
+              n2hb = 0._r8
+              vyb  = 0._r8
+              vub  = 0._r8
+              web  = 0._r8
+
+          end if
+
+          ! Calculate basic cross-interface variables ( jump condition ) across the 
+          ! top external interface of CL. The meanings of variables are similar to
+          ! the ones at the base interface.
+
+          jtzm = z(i,kt-1) - z(i,kt)
+          jtsl = sl(i,kt-1) - sl(i,kt)
+          jtqt = qt(i,kt-1) - qt(i,kt)
+          jtbu = n2(i,kt)*jtzm                                                ! Note : 'jtbu' is guaranteed positive by definition of CL top.
+          jtbu = max(jtbu,jbumin)                                             ! But threshold it anyway to be sure.
+          jtu  = u(i,kt-1) - u(i,kt)
+          jtv  = v(i,kt-1) - v(i,kt)
+          ch   = (1._r8 -sfuh(i,kt))*chu(i,kt) + sfuh(i,kt)*chs(i,kt) 
+          cm   = (1._r8 -sfuh(i,kt))*cmu(i,kt) + sfuh(i,kt)*cms(i,kt) 
+          n2ht = (ch*jtsl + cm*jtqt)/jtzm                       
+          vyt  = n2ht*jtzm/jtbu                                  
+          vut  = min(1._r8,(jtu**2+jtv**2)/(jtbu*jtzm))             
+
+          ! Evaporative enhancement factor of entrainment rate at the CL top interface, evhc. 
+          ! We take the full inversion strength to be 'jt2slv = slv(i,kt-2)-slv(i,kt)' 
+          ! where 'kt-1' is in the ambiguous layer. However, for a cloud-topped CL overlain
+          ! by another CL, it is possible that 'slv(i,kt-2) < slv(i,kt)'. To avoid negative
+          ! or excessive evhc, we lower-bound jt2slv and upper-bound evhc.  Note 'jtslv' is
+          ! used only for calculating 'evhc' : when calculating entrainment rate,   we will
+          ! use normal interfacial buoyancy jump across CL top interface.
+
+          evhc   = 1._r8
+          jt2slv = 0._r8
+
+        ! Modification : I should check whether below 'jbumin' produces reasonable limiting value.   
+        !                In addition, our current formulation does not consider ice contribution. 
+
+          if( choice_evhc .eq. 'orig' ) then
+
+              if( ql(i,kt) .gt. qmin .and. ql(i,kt-1) .lt. qmin ) then 
+                  jt2slv = slv(i,max(kt-2,1)) - slv(i,kt)
+                  jt2slv = max( jt2slv, jbumin*slv(i,kt-1)/g )
+                  evhc   = 1._r8 + a2l * a3l * latvap * ql(i,kt) / jt2slv
+                  evhc   = min( evhc, evhcmax )
+              end if
+
+          elseif( choice_evhc .eq. 'ramp' ) then
+
+              jt2slv = slv(i,max(kt-2,1)) - slv(i,kt)
+              jt2slv = max( jt2slv, jbumin*slv(i,kt-1)/g )
+              evhc   = 1._r8 + max(cldeff(i,kt)-cldeff(i,kt-1),0._r8) * a2l * a3l * latvap * ql(i,kt) / jt2slv
+              evhc   = min( evhc, evhcmax )
+
+          elseif( choice_evhc .eq. 'maxi' ) then
+
+              qleff  = max( ql(i,kt-1), ql(i,kt) ) 
+              jt2slv = slv(i,max(kt-2,1)) - slv(i,kt)
+              jt2slv = max( jt2slv, jbumin*slv(i,kt-1)/g )
+              evhc   = 1._r8 + a2l * a3l * latvap * qleff / jt2slv
+              evhc   = min( evhc, evhcmax )
+
+          endif
+
+          ! Calculate cloud-top radiative cooling contribution to buoyancy production.
+          ! Here,  'radf' [m2/s3] is additional buoyancy flux at the CL top interface 
+          ! associated with cloud-top LW cooling being mainly concentrated near the CL
+          ! top interface ( just below CL top interface ).  Contribution of SW heating
+          ! within the cloud is not included in this radiative buoyancy production 
+          ! since SW heating is more broadly distributed throughout the CL top layer. 
+
+          lwp        = 0._r8
+          opt_depth  = 0._r8
+          radinvfrac = 0._r8 
+          radf       = 0._r8
+
+          if( choice_radf .eq. 'orig' ) then
+
+              if( ql(i,kt) .gt. qmin .and. ql(i,kt-1) .lt. qmin ) then 
+
+                  lwp       = ql(i,kt) * ( pi(i,kt+1) - pi(i,kt) ) / g
+                  opt_depth = 156._r8 * lwp  ! Estimated LW optical depth in the CL top layer
+
+                  ! Approximate LW cooling fraction concentrated at the inversion by using
+                  ! polynomial approx to exact formula 1-2/opt_depth+2/(exp(opt_depth)-1))
+
+                  radinvfrac  = opt_depth * ( 4._r8 + opt_depth ) / ( 6._r8 * ( 4._r8 + opt_depth ) + opt_depth**2 )
+                  radf        = qrlw(i,kt) / ( pi(i,kt) - pi(i,kt+1) ) ! Cp*radiative cooling = [ W/kg ] 
+                  radf        = max( radinvfrac * radf * ( zi(i,kt) - zi(i,kt+1) ), 0._r8 ) * chs(i,kt)
+                ! We can disable cloud LW cooling contribution to turbulence by uncommenting:
+                ! radf = 0._r8
+
+              end if
+
+          elseif( choice_radf .eq. 'ramp' ) then
+
+                  lwp         = ql(i,kt) * ( pi(i,kt+1) - pi(i,kt) ) / g
+                  opt_depth   = 156._r8 * lwp  ! Estimated LW optical depth in the CL top layer
+                  radinvfrac  = opt_depth * ( 4._r8 + opt_depth ) / ( 6._r8 * ( 4._r8 + opt_depth ) + opt_depth**2 )
+                  radinvfrac  = max(cldeff(i,kt)-cldeff(i,kt-1),0._r8) * radinvfrac 
+                  radf        = qrlw(i,kt) / ( pi(i,kt) - pi(i,kt+1) ) ! Cp*radiative cooling [W/kg] 
+                  radf        = max( radinvfrac * radf * ( zi(i,kt) - zi(i,kt+1) ), 0._r8 ) * chs(i,kt)
+
+          elseif( choice_radf .eq. 'maxi' ) then
+
+                ! Radiative flux divergence both in 'kt' and 'kt-1' layers are included 
+                ! 1. From 'kt' layer
+                  lwp         = ql(i,kt) * ( pi(i,kt+1) - pi(i,kt) ) / g
+                  opt_depth   = 156._r8 * lwp  ! Estimated LW optical depth in the CL top layer
+                  radinvfrac  = opt_depth * ( 4._r8 + opt_depth ) / ( 6._r8 * ( 4._r8 + opt_depth ) + opt_depth**2 )
+                  radf        = max( radinvfrac * qrlw(i,kt) / ( pi(i,kt) - pi(i,kt+1) ) * ( zi(i,kt) - zi(i,kt+1) ), 0._r8 )
+                ! 2. From 'kt-1' layer and add the contribution from 'kt' layer
+                  lwp         = ql(i,kt-1) * ( pi(i,kt) - pi(i,kt-1) ) / g
+                  opt_depth   = 156._r8 * lwp  ! Estimated LW optical depth in the CL top layer
+                  radinvfrac  = opt_depth * ( 4._r8 + opt_depth ) / ( 6._r8 * ( 4._r8 + opt_depth) + opt_depth**2 )
+                  radf        = radf + max( radinvfrac * qrlw(i,kt-1) / ( pi(i,kt-1) - pi(i,kt) ) * ( zi(i,kt-1) - zi(i,kt) ), 0._r8 )
+                  radf        = max( radf, 0._r8 ) * chs(i,kt) 
+
+          endif
+
+          ! ------------------------------------------------------------------- !
+          ! Calculate 'wstar3' by summing buoyancy productions within CL from   !
+          !   1. Interior buoyancy production ( bprod: fcn of TKE )             !
+          !   2. Cloud-top radiative cooling                                    !
+          !   3. Surface buoyancy flux contribution only when bflxs > 0.        !
+          !      Note that master length scale, lbulk, has already been         !
+          !      corrctly defined at the first part of this 'do ncv' loop       !
+          !      considering the sign of bflxs.                                 !
+          ! This 'wstar3' is used for calculation of entrainment rate.          !
+          ! Note that this 'wstar3' formula does not include shear production   !
+          ! and the effect of drizzle, which should be included later.          !
+          ! Q : Strictly speaking, in calculating interior buoyancy production, ! 
+          !     the use of 'bprod' is not correct, since 'bprod' is not correct !
+          !     value but initially guessed value.   More reasonably, we should ! 
+          !     use '-leng(i,k)*sqrt(b1*wcap(i,k))*shcl(i,ncv)*n2(i,k)' instead !
+          !     of 'bprod(i,k)', although this is still an  approximation since !
+          !     tke(i,k) is not exactly 'b1*wcap(i,k)'  due to a transport term.! 
+          !     However since iterative calculation will be performed after all,! 
+          !     below might also be OK. But I should test this alternative.     !
+          ! ------------------------------------------------------------------- !      
+
+          dzht   = zi(i,kt)  - z(i,kt)     ! Thickness of CL top half-layer
+          dzhb   = z(i,kb-1) - zi(i,kb)    ! Thickness of CL bot half-layer
+          wstar3 = radf * dzht
+          do k = kt + 1, kb - 1 ! If 'kt = kb - 1', this loop will not be performed. 
+               wstar3 =  wstar3 + bprod(i,k) * ( z(i,k-1) - z(i,k) )
+             ! Below is an alternative which may speed up convergence.
+             ! However, for interfaces merged into original CL, it can
+             ! be 'wcap(i,k)<0' since 'n2(i,k)>0'.  Thus, I should use
+             ! the above original one.
+             ! wstar3 =  wstar3 - leng(i,k)*sqrt(b1*wcap(i,k))*shcl(i,ncv)*n2(i,k)* &
+             !                    (z(i,k-1) - z(i,k))
+          end do      
+          if( kb .eq. (pver+1) .and. bflxs(i) .gt. 0._r8 ) then
+             wstar3 = wstar3 + bflxs(i) * dzhb
+           ! wstar3 = wstar3 + bprod(i,pver+1) * dzhb
+          end if   
+          wstar3 = max( 2.5_r8 * wstar3, 0._r8 )
+   
+          ! -------------------------------------------------------------- !
+          ! Below single block is for 'sedimentation-entrainment feedback' !
+          ! -------------------------------------------------------------- !          
+
+          if( id_sedfact ) then
+            ! wsed    = 7.8e5_r8*(ql(i,kt)/ncliq(i,kt))**(2._r8/3._r8)
+              sedfact = exp(-ased*wsedl(i,kt)/(wstar3**(1._r8/3._r8)+1.e-6))
+              if( choice_evhc .eq. 'orig' ) then
+                  if (ql(i,kt).gt.qmin .and. ql(i,kt-1).lt.qmin) then
+                      jt2slv = slv(i,max(kt-2,1)) - slv(i,kt)
+                      jt2slv = max(jt2slv, jbumin*slv(i,kt-1)/g)
+                      evhc = 1._r8+sedfact*a2l*a3l*latvap*ql(i,kt) / jt2slv
+                      evhc = min(evhc,evhcmax)
+                  end if
+              elseif( choice_evhc .eq. 'ramp' ) then
+                  jt2slv = slv(i,max(kt-2,1)) - slv(i,kt)
+                  jt2slv = max(jt2slv, jbumin*slv(i,kt-1)/g)
+                  evhc = 1._r8+max(cldeff(i,kt)-cldeff(i,kt-1),0._r8)*sedfact*a2l*a3l*latvap*ql(i,kt) / jt2slv
+                  evhc = min(evhc,evhcmax)
+              elseif( choice_evhc .eq. 'maxi' ) then
+                  qleff  = max(ql(i,kt-1),ql(i,kt))
+                  jt2slv = slv(i,max(kt-2,1)) - slv(i,kt)
+                  jt2slv = max(jt2slv, jbumin*slv(i,kt-1)/g)
+                  evhc = 1._r8+sedfact*a2l*a3l*latvap*qleff / jt2slv
+                  evhc = min(evhc,evhcmax)
+              endif
+          endif
+
+          ! -------------------------------------------------------------------------- !
+          ! Now diagnose CL top and bottom entrainment rates (and the contribution of  !
+          ! top/bottom entrainments to wstar3) using entrainment closures of the form  !
+          !                                                                            !        
+          !                   wet = cet*wstar3, web = ceb*wstar3                       !
+          !                                                                            !
+          ! where cet and ceb depend on the entrainment interface jumps, ql, etc.      !
+          ! No entrainment is diagnosed unless the wstar3 > 0. Note '1/wstar3fact' is  !
+          ! a factor indicating the enhancement of wstar3 due to entrainment process.  !
+          ! Q : Below setting of 'wstar3fact = max(..,0.5)'might prevent the possible  !
+          !     case when buoyancy consumption by entrainment is  stronger than cloud  !
+          !     top radiative cooling production. Is that OK ? No.  According to bulk  !
+          !     modeling study, entrainment buoyancy consumption was always a certain  !
+          !     fraction of other net productions, rather than a separate sum.  Thus,  !
+          !     below max limit of wstar3fact is correct.   'wstar3fact = max(.,0.5)'  !
+          !     prevents unreasonable enhancement of CL entrainment rate by cloud-top  !
+          !     entrainment instability, CTEI.                                         !
+          ! Q : Use of the same dry entrainment coefficient, 'a1i' both at the CL  top !
+          !     and base interfaces may result in too small 'wstar3' and 'ebrk' below, !
+          !     as was seen in my generalized bulk modeling study. This should be re-  !
+          !     considered later                                                       !
+          ! -------------------------------------------------------------------------- !
+          
+          if( wstar3 .gt. 0._r8 ) then
+              cet = a1i * evhc / ( jtbu * lbulk )
+              if( kb .eq. pver + 1 ) then 
+                  wstar3fact = max( 1._r8 + 2.5_r8 * cet * n2ht * jtzm * dzht, wstar3factcrit )
+              else    
+                  ceb = a1i / ( jbbu * lbulk )
+                  wstar3fact = max( 1._r8 + 2.5_r8 * cet * n2ht * jtzm * dzht &
+                                          + 2.5_r8 * ceb * n2hb * jbzm * dzhb, wstar3factcrit )
+              end if
+              wstar3 = wstar3 / wstar3fact       
+          else ! wstar3 == 0
+              wstar3fact = 0._r8 ! This is just for dianostic output
+              cet        = 0._r8
+              ceb        = 0._r8
+          end if 
+
+          ! ---------------------------------------------------------------------------- !
+          ! Calculate net CL mean TKE including entrainment contribution by solving a    !
+          ! canonical cubic equation. The solution of cubic equ. is 'rootp**2 = ebrk'    !
+          ! where 'ebrk' originally (before solving cubic eq.) was interior CL mean TKE, !
+          ! but after solving cubic equation,  it is replaced by net CL mean TKE in the  !
+          ! same variable 'ebrk'.                                                        !
+          ! ---------------------------------------------------------------------------- !
+          ! Solve cubic equation (canonical form for analytic solution)                  !
+          !   r^3 - 3*trmp*r - 2*trmq = 0,   r = sqrt<e>                                 ! 
+          ! to estimate <e> for CL, derived from layer-mean TKE balance:                 !
+          !                                                                              !
+          !   <e>^(3/2)/(b_1*<l>) \approx <B + S>   (*)                                  !
+          !   <B+S> = (<B+S>_int * l_int + <B+S>_et * dzt + <B+S>_eb * dzb)/lbulk        !
+          !   <B+S>_int = <e>^(1/2)/(b_1*<l>)*<e>_int                                    !
+          !   <B+S>_et  = (-vyt+vut)*wet*jtbu + radf                                     !
+          !   <B+S>_eb  = (-vyb+vub)*web*jbbu                                            !
+          !                                                                              !
+          ! where:                                                                       !
+          !   <> denotes a vertical avg (over the whole CL unless indicated)             !
+          !   l_int (called lbrk below) is aggregate thickness of interior CL layers     !
+          !   dzt = zi(i,kt)-z(i,kt)   is thickness of top entrainment layer             !
+          !   dzb = z(i,kb-1)-zi(i,kb) is thickness of bot entrainment layer             !
+          !   <e>_int (called ebrk below) is the CL-mean TKE if only interior            !
+          !                               interfaces contributed.                        !
+          !   wet, web                  are top. bottom entrainment rates                !
+          !                                                                              !
+          ! For a single-level radiatively-driven convective layer, there are no         ! 
+          ! interior interfaces so 'ebrk' = 'lbrk' = 0. If the CL goes to the            !
+          ! surface, 'vyb' and 'vub' are set to zero before and 'ebrk' and 'lbrk'        !
+          ! have already incorporated the surface interfacial layer contribution,        !
+          ! so the same formulas still apply.                                            !
+          !                                                                              !
+          ! In the original formulation based on TKE,                                    !
+          !    wet*jtbu = a1l*evhc*<e>^3/2/leng(i,kt)                                    ! 
+          !    web*jbbu = a1l*<e>^3/2/leng(i,kt)                                         !
+          !                                                                              !
+          ! In the wstar formulation                                                     !
+          !    wet*jtbu = a1i*evhc*wstar3/lbulk                                          !
+          !    web*jbbu = a1i*wstar3/lbulk,                                              !
+          ! ---------------------------------------------------------------------------- !
+
+          fact = ( evhc * ( -vyt + vut ) * dzht + ( -vyb + vub ) * dzhb * leng(i,kb) / leng(i,kt) ) / lbulk
+
+          if( wstarent ) then
+
+              ! (Option 1) 'wstar' entrainment formulation 
+              ! Here trmq can have either sign, and will usually be nonzero even for non-
+              ! cloud topped CLs.  If trmq > 0, there will be two positive roots r; we take 
+              ! the larger one. Why ? If necessary, we limit entrainment and wstar to prevent
+              ! a solution with r < ccrit*wstar ( Why ? ) where we take ccrit = 0.5. 
+
+              trma = 1._r8          
+              trmp = ebrk(i,ncv) * ( lbrk(i,ncv) / lbulk ) / 3._r8 + ntzero
+              trmq = 0.5_r8 * b1 * ( leng(i,kt)  / lbulk ) * ( radf * dzht + a1i * fact * wstar3 )
+
+              ! Check if there is an acceptable root with r > rcrit = ccrit*wstar. 
+              ! To do this, first find local minimum fmin of the cubic f(r) at sqrt(p), 
+              ! and value fcrit = f(rcrit).
+
+              rmin  = sqrt(trmp)
+              fmin  = rmin * ( rmin * rmin - 3._r8 * trmp ) - 2._r8 * trmq
+              wstar = wstar3**onet
+              rcrit = ccrit * wstar
+              fcrit = rcrit * ( rcrit * rcrit - 3._r8 * trmp ) - 2._r8 * trmq
+
+              ! No acceptable root exists (noroot = .true.) if either:
+              !    1) rmin < rcrit (in which case cubic is monotone increasing for r > rcrit)
+              !       and f(rcrit) > 0.
+              ! or 2) rmin > rcrit (in which case min of f(r) in r > rcrit is at rmin)
+              !       and f(rmin) > 0.  
+              ! In this case, we reduce entrainment and wstar3 such that r/wstar = ccrit;
+              ! this changes the coefficients of the cubic.   It might be informative to
+              ! check when and how many 'noroot' cases occur,  since when 'noroot',   we
+              ! will impose arbitrary limit on 'wstar3, wet, web, and ebrk' using ccrit.
+
+              noroot = ( ( rmin .lt. rcrit ) .and. ( fcrit .gt. 0._r8 ) ) &
+                  .or. ( ( rmin .ge. rcrit ) .and. ( fmin  .gt. 0._r8 ) )
+              if( noroot ) then ! Solve cubic for r
+                  trma = 1._r8 - b1 * ( leng(i,kt) / lbulk ) * a1i * fact / ccrit**3
+                  trma = max( trma, 0.5_r8 )  ! Limit entrainment enhancement of ebrk
+                  trmp = trmp / trma 
+                  trmq = 0.5_r8 * b1 * ( leng(i,kt) / lbulk ) * radf * dzht / trma
+              end if   ! noroot
+
+              ! Solve the cubic equation
+
+              qq = trmq**2 - trmp**3
+              if( qq .ge. 0._r8 ) then 
+                  rootp = ( trmq + sqrt(qq) )**(1._r8/3._r8) + ( max( trmq - sqrt(qq), 0._r8 ) )**(1._r8/3._r8)
+              else
+                  rootp = 2._r8 * sqrt(trmp) * cos( acos( trmq / sqrt(trmp**3) ) / 3._r8 )
+              end if
+ 
+              ! Adjust 'wstar3' only if there is 'noroot'. 
+              ! And calculate entrainment rates at the top and base interfaces.
+
+              if( noroot )  wstar3 = ( rootp / ccrit )**3     ! Adjust wstar3 
+              wet = cet * wstar3                              ! Find entrainment rates
+              if( kb .lt. pver + 1 ) web = ceb * wstar3       ! When 'kb.eq.pver+1', it was set to web=0. 
+
+          else !
+
+              ! (Option.2) wstarentr = .false. Use original entrainment formulation.
+              ! trmp > 0 if there are interior interfaces in CL, trmp = 0 otherwise.
+              ! trmq > 0 if there is cloudtop radiative cooling, trmq = 0 otherwise.
+             
+              trma = 1._r8 - b1 * a1l * fact
+              trma = max( trma, 0.5_r8 )  ! Prevents runaway entrainment instability
+              trmp = ebrk(i,ncv) * ( lbrk(i,ncv) / lbulk ) / ( 3._r8 * trma )
+              trmq = 0.5_r8 * b1 * ( leng(i,kt)  / lbulk ) * radf * dzht / trma
+
+              qq = trmq**2 - trmp**3
+              if( qq .ge. 0._r8 ) then 
+                  rootp = ( trmq + sqrt(qq) )**(1._r8/3._r8) + ( max( trmq - sqrt(qq), 0._r8 ) )**(1._r8/3._r8)
+              else ! Also part of case 3
+                  rootp = 2._r8 * sqrt(trmp) * cos( acos( trmq / sqrt(trmp**3) ) / 3._r8 )
+              end if   ! qq
+
+             ! Find entrainment rates and limit them by free-entrainment values a1l*sqrt(e)
+
+              wet = a1l * rootp * min( evhc * rootp**2 / ( leng(i,kt) * jtbu ), 1._r8 )   
+              if( kb .lt. pver + 1 ) web = a1l * rootp * min( evhc * rootp**2 / ( leng(i,kb) * jbbu ), 1._r8 )
+
+          end if ! wstarentr
+
+          ! ---------------------------------------------------- !
+          ! Finally, get the net CL mean TKE and normalized TKE  ! 
+          ! ---------------------------------------------------- !
+
+          ebrk(i,ncv) = rootp**2
+          ebrk(i,ncv) = min(ebrk(i,ncv),tkemax) ! Limit CL-avg TKE used for entrainment
+          wbrk(i,ncv) = ebrk(i,ncv)/b1  
+        
+          ! The only way ebrk = 0 is for SRCL which are actually radiatively cooled 
+          ! at top interface. In this case, we remove 'convective' label from the 
+          ! interfaces around this layer. This case should now be impossible, so 
+          ! we flag it. Q: I can't understand why this case is impossible now. Maybe,
+          ! due to various limiting procedures used in solving cubic equation ? 
+          ! In case of SRCL, 'ebrk' should be positive due to cloud top LW radiative
+          ! cooling contribution, although 'ebrk(internal)' of SRCL before including
+          ! entrainment contribution (which include LW cooling contribution also) is
+          ! zero. 
+
+          if( ebrk(i,ncv) .le. 0._r8 ) then
+              write(iulog,*) 'CALEDDY: Warning, CL with zero TKE, i, kt, kb ', i, kt, kb
+              belongcv(i,kt) = .false.
+              belongcv(i,kb) = .false. 
+          end if
+          
+          ! ----------------------------------------------------------------------- !
+          ! Calculate complete TKE profiles at all CL interfaces, capped by tkemax. !
+          ! We approximate TKE = <e> at entrainment interfaces. However when CL is  !
+          ! based at surface, correct 'tkes' will be inserted to tke(i,pver+1).     !
+          ! Note that this approximation at CL external interfaces do not influence !
+          ! numerical calculation since 'e' at external interfaces are not used  in !
+          ! actual numerical calculation afterward. In addition in order to extract !
+          ! correct TKE averaged over the PBL in the cumulus scheme,it is necessary !
+          ! to set e = <e> at the top entrainment interface.  Since net CL mean TKE !
+          ! 'ebrk' obtained by solving cubic equation already includes tkes  ( tkes !
+          ! is included when bflxs > 0 but not when bflxs <= 0 into internal ebrk ),!
+          ! 'tkes' should be written to tke(i,pver+1)                               !
+          ! ----------------------------------------------------------------------- !
+
+          ! 1. At internal interfaces          
+          do k = kb - 1, kt + 1, -1
+             rcap = ( b1 * ae + wcap(i,k) / wbrk(i,ncv) ) / ( b1 * ae + 1._r8 )
+             rcap = min( max(rcap,rcapmin), rcapmax )
+             tke(i,k) = ebrk(i,ncv) * rcap
+             tke(i,k) = min( tke(i,k), tkemax )
+             kvh(i,k) = leng(i,k) * sqrt(tke(i,k)) * shcl(i,ncv)
+             kvm(i,k) = leng(i,k) * sqrt(tke(i,k)) * smcl(i,ncv)
+             bprod(i,k) = -kvh(i,k) * n2(i,k)
+             sprod(i,k) =  kvm(i,k) * s2(i,k)
+             turbtype(i,k) = 2                     ! CL interior interfaces.
+             sm_aw(i,k) = smcl(i,ncv)/alph1        ! Diagnostic output for microphysics
+          end do
+
+          ! 2. At CL top entrainment interface
+          kentr = wet * jtzm
+          kvh(i,kt) = kentr
+          kvm(i,kt) = kentr
+          bprod(i,kt) = -kentr * n2ht + radf       ! I must use 'n2ht' not 'n2'
+          sprod(i,kt) =  kentr * s2(i,kt)
+          turbtype(i,kt) = 4                       ! CL top entrainment interface
+          trmp = -b1 * ae / ( 1._r8 + b1 * ae )
+          trmq = -(bprod(i,kt)+sprod(i,kt))*b1*leng(i,kt)/(1._r8+b1*ae)/(ebrk(i,ncv)**(3._r8/2._r8))
+          rcap = compute_cubic(0._r8,trmp,trmq)**2._r8
+          rcap = min( max(rcap,rcapmin), rcapmax )
+          tke(i,kt)  = ebrk(i,ncv) * rcap
+          tke(i,kt)  = min( tke(i,kt), tkemax )
+          sm_aw(i,kt) = smcl(i,ncv) / alph1        ! Diagnostic output for microphysics
+
+          ! 3. At CL base entrainment interface and double entraining interfaces
+          ! When current CL base is also the top interface of CL regime below,
+          ! simply add the two contributions for calculating eddy diffusivity
+          ! and buoyancy/shear production. Below code correctly works because
+          ! we (CL regime index) always go from surface upward.
+
+          if( kb .lt. pver + 1 ) then 
+
+              kentr = web * jbzm
+
+              if( kb .ne. ktblw ) then
+
+                  kvh(i,kb) = kentr
+                  kvm(i,kb) = kentr
+                  bprod(i,kb) = -kvh(i,kb)*n2hb     ! I must use 'n2hb' not 'n2'
+                  sprod(i,kb) =  kvm(i,kb)*s2(i,kb)
+                  turbtype(i,kb) = 3                ! CL base entrainment interface
+                  trmp = -b1*ae/(1._r8+b1*ae)
+                  trmq = -(bprod(i,kb)+sprod(i,kb))*b1*leng(i,kb)/(1._r8+b1*ae)/(ebrk(i,ncv)**(3._r8/2._r8))
+                  rcap = compute_cubic(0._r8,trmp,trmq)**2._r8
+                  rcap = min( max(rcap,rcapmin), rcapmax )
+                  tke(i,kb)  = ebrk(i,ncv) * rcap
+                  tke(i,kb)  = min( tke(i,kb),tkemax )
+
+              else
+                  
+                  kvh(i,kb) = kvh(i,kb) + kentr 
+                  kvm(i,kb) = kvm(i,kb) + kentr
+                ! dzhb5 : Half thickness of the lowest  layer of  current CL regime
+                ! dzht5 : Half thickness of the highest layer of adjacent CL regime just below current CL. 
+                  dzhb5 = z(i,kb-1) - zi(i,kb)
+                  dzht5 = zi(i,kb) - z(i,kb)
+                  bprod(i,kb) = ( dzht5*bprod(i,kb) - dzhb5*kentr*n2hb )     / ( dzhb5 + dzht5 )
+                  sprod(i,kb) = ( dzht5*sprod(i,kb) + dzhb5*kentr*s2(i,kb) ) / ( dzhb5 + dzht5 )
+                  trmp = -b1*ae/(1._r8+b1*ae)
+                  trmq = -kentr*(s2(i,kb)-n2hb)*b1*leng(i,kb)/(1._r8+b1*ae)/(ebrk(i,ncv)**(3._r8/2._r8))
+                  rcap = compute_cubic(0._r8,trmp,trmq)**2._r8
+                  rcap = min( max(rcap,rcapmin), rcapmax )
+                  tke_imsi = ebrk(i,ncv) * rcap
+                  tke_imsi = min( tke_imsi, tkemax )
+                  tke(i,kb)  = ( dzht5*tke(i,kb) + dzhb5*tke_imsi ) / ( dzhb5 + dzht5 )               
+                  tke(i,kb)  = min(tke(i,kb),tkemax)
+                  turbtype(i,kb) = 5                ! CL double entraining interface      
+                 
+              end if
+
+           else
+
+             ! If CL base interface is surface, compute similarly using wcap(i,kb)=tkes/b1    
+             ! Even when bflx < 0, use the same formula in order to impose consistency of
+             ! tke(i,kb) at bflx = 0._r8
+ 
+             rcap = (b1*ae + wcap(i,kb)/wbrk(i,ncv))/(b1*ae + 1._r8)
+             rcap = min( max(rcap,rcapmin), rcapmax )
+             tke(i,kb) = ebrk(i,ncv) * rcap
+             tke(i,kb) = min( tke(i,kb),tkemax )
+
+          end if
+
+          ! For double entraining interface, simply use smcl(i,ncv) of the overlying CL. 
+          ! Below 'sm_aw' is a diagnostic output for use in the microphysics.
+          ! When 'kb' is surface, 'sm' will be over-written later below.
+
+          sm_aw(i,kb) = smcl(i,ncv)/alph1             
+
+          ! Calculate wcap at all interfaces of CL. Put a  minimum threshold on TKE
+          ! to prevent possible division by zero.  'wcap' at CL internal interfaces
+          ! are already calculated in the first part of 'do ncv' loop correctly.
+          ! When 'kb.eq.pver+1', below formula produces the identical result to the
+          ! 'tkes(i)/b1' if leng(i,kb) is set to vk*z(i,pver). Note  wcap(i,pver+1)
+          ! is already defined as 'tkes(i)/b1' at the first part of caleddy.
+          
+          wcap(i,kt) = (bprod(i,kt)+sprod(i,kt))*leng(i,kt)/sqrt(max(tke(i,kt),1.e-6_r8))
+          if( kb .lt. pver + 1 ) then
+              wcap(i,kb) = (bprod(i,kb)+sprod(i,kb))*leng(i,kb)/sqrt(max(tke(i,kb),1.e-6_r8))
+          end if
+
+          ! Save the index of upper external interface of current CL-regime in order to
+          ! handle the case when this interface is also the lower external interface of 
+          ! CL-regime located just above. 
+
+          ktblw = kt 
+
+          ! Diagnostic Output
+
+          wet_CL(i,ncv)        = wet
+          web_CL(i,ncv)        = web
+          jtbu_CL(i,ncv)       = jtbu
+          jbbu_CL(i,ncv)       = jbbu
+          evhc_CL(i,ncv)       = evhc
+          jt2slv_CL(i,ncv)     = jt2slv
+          n2ht_CL(i,ncv)       = n2ht
+          n2hb_CL(i,ncv)       = n2hb          
+          lwp_CL(i,ncv)        = lwp
+          opt_depth_CL(i,ncv)  = opt_depth
+          radinvfrac_CL(i,ncv) = radinvfrac
+          radf_CL(i,ncv)       = radf
+          wstar_CL(i,ncv)      = wstar          
+          wstar3fact_CL(i,ncv) = wstar3fact          
+
+       end do        ! ncv
+ 
+       ! Calculate PBL height and characteristic cumulus excess for use in the
+       ! cumulus convection shceme. Also define turbulence type at the surface
+       ! when the lowest CL is based at the surface. These are just diagnostic
+       ! outputs, not influencing numerical calculation of current PBL scheme.
+       ! If the lowest CL is based at the surface, define the PBL depth as the
+       ! CL top interface. The same rule is applied for all CLs including SRCL.
+
+       if( ncvsurf .gt. 0 ) then
+
+           ktopbl(i) = ktop(i,ncvsurf)
+           pblh(i)   = zi(i, ktopbl(i))
+           pblhp(i)  = pi(i, ktopbl(i))
+           wpert(i)  = max(wfac*sqrt(ebrk(i,ncvsurf)),wpertmin)
+           tpert(i)  = max(abs(shflx(i)*rrho(i)/cpair)*tfac/wpert(i),0._r8)
+           qpert(i)  = max(abs(qflx(i)*rrho(i))*tfac/wpert(i),0._r8)
+
+           if( bflxs(i) .gt. 0._r8 ) then
+               turbtype(i,pver+1) = 2 ! CL interior interface
+           else
+               turbtype(i,pver+1) = 3 ! CL external base interface
+           endif
+
+           ipbl(i)  = 1._r8
+           kpblh(i) = ktopbl(i) - 1._r8
+
+       end if ! End of the calculationf of te properties of surface-based CL.
+
+       ! -------------------------------------------- !
+       ! Treatment of Stable Turbulent Regime ( STL ) !
+       ! -------------------------------------------- !
+
+       ! Identify top and bottom most (internal) interfaces of STL except surface.
+       ! Also, calculate 'turbulent length scale (leng)' at each STL interfaces.     
+
+       belongst(i,1) = .false.   ! k = 1 (top interface) is assumed non-turbulent
+       do k = 2, pver            ! k is an interface index
+          belongst(i,k) = ( ri(i,k) .lt. ricrit ) .and. ( .not. belongcv(i,k) )
+          if( belongst(i,k) .and. ( .not. belongst(i,k-1) ) ) then
+              kt = k             ! Top interface index of STL
+          elseif( .not. belongst(i,k) .and. belongst(i,k-1) ) then
+              kb = k - 1         ! Base interface index of STL
+              lbulk = z(i,kt-1) - z(i,kb)
+              do ks = kt, kb
+                 if( choice_tunl .eq. 'rampcl' ) then
+                     tunlramp = tunl
+                 elseif( choice_tunl .eq. 'rampsl' ) then
+                    tunlramp = max( 1.e-3_r8, ctunl * tunl * exp(-log(ctunl)*ri(i,ks)/ricrit) )
+                  ! tunlramp = 0.065_r8 + 0.7_r8 * exp(-20._r8*ri(i,ks))
+                 else
+                    tunlramp = tunl
+                 endif
+                 if( choice_leng .eq. 'origin' ) then
+                     leng(i,ks) = ( (vk*zi(i,ks))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng)
+                   ! leng(i,ks) = vk*zi(i,ks) / (1._r8+vk*zi(i,ks)/(tunlramp*lbulk))
+                 else
+                     leng(i,ks) = min( vk*zi(i,ks), tunlramp*lbulk )              
+                 endif
+              end do
+          end if
+       end do ! k
+
+       ! Now look whether STL extends to ground.  If STL extends to surface,
+       ! re-define master length scale,'lbulk' including surface interfacial
+       ! layer thickness, and re-calculate turbulent length scale, 'leng' at
+       ! all STL interfaces again. Note that surface interface is assumed to
+       ! always be STL if it is not CL.   
+       
+       belongst(i,pver+1) = .not. belongcv(i,pver+1)
+
+       if( belongst(i,pver+1) ) then     ! kb = pver+1 (surface  STL)
+
+           turbtype(i,pver+1) = 1        ! Surface is STL interface
+          
+           if( belongst(i,pver) ) then   ! STL includes interior
+             ! 'kt' already defined above as the top interface of STL
+               lbulk = z(i,kt-1)          
+           else                          ! STL with no interior turbulence
+               kt = pver+1
+               lbulk = z(i,kt-1)
+           end if
+
+           ! PBL height : Layer mid-point just above the highest STL interface
+           ! Note in contrast to the surface based CL regime where  PBL height
+           ! was defined at the top external interface, PBL height of  surface
+           ! based STL is defined as the layer mid-point.
+
+           ktopbl(i) = kt - 1
+           pblh(i)   = z(i,ktopbl(i))
+           pblhp(i)  = 0.5_r8 * ( pi(i,ktopbl(i)) + pi(i,ktopbl(i)+1) )          
+
+           ! Re-calculate turbulent length scale including surface interfacial
+           ! layer contribution to lbulk.
+
+           do ks = kt, pver
+              if( choice_tunl .eq. 'rampcl' ) then
+                  tunlramp = tunl
+              elseif( choice_tunl .eq. 'rampsl' ) then
+                  tunlramp = max(1.e-3_r8,ctunl*tunl*exp(-log(ctunl)*ri(i,ks)/ricrit))
+                ! tunlramp = 0.065_r8 + 0.7_r8 * exp(-20._r8*ri(i,ks))
+              else
+                  tunlramp = tunl
+              endif
+              if( choice_leng .eq. 'origin' ) then
+                  leng(i,ks) = ( (vk*zi(i,ks))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng)
+                ! leng(i,ks) = vk*zi(i,ks) / (1._r8+vk*zi(i,ks)/(tunlramp*lbulk))
+              else
+                  leng(i,ks) = min( vk*zi(i,ks), tunlramp*lbulk )              
+              endif
+           end do ! ks
+
+           ! Characteristic cumulus excess of surface-based STL.
+           ! We may be able to use ustar for wpert.
+
+           wpert(i) = 0._r8 
+           tpert(i) = max(shflx(i)*rrho(i)/cpair*fak/ustar(i),0._r8) ! CCM stable-layer forms
+           qpert(i) = max(qflx(i)*rrho(i)*fak/ustar(i),0._r8)
+
+           ipbl(i)  = 0._r8
+           kpblh(i) = ktopbl(i)
+
+       end if
+
+       ! Calculate stability functions and energetics at the STL interfaces
+       ! except the surface. Note that tke(i,pver+1) and wcap(i,pver+1) are
+       ! already calculated in the first part of 'caleddy', kvm(i,pver+1) &
+       ! kvh(i,pver+1) were already initialized to be zero, bprod(i,pver+1)
+       ! & sprod(i,pver+1) were direcly calculated from the bflxs and ustar.
+       ! Note transport term is assumed to be negligible at STL interfaces.
+           
+       do k = 2, pver
+
+          if( belongst(i,k) ) then
+
+              turbtype(i,k) = 1    ! STL interfaces
+              trma = alph3*alph4exs*ri(i,k) + 2._r8*b1*(alph2-alph4exs*alph5*ri(i,k))
+              trmb = (alph3+alph4exs)*ri(i,k) + 2._r8*b1*(-alph5*ri(i,k)+alph1)
+              trmc = ri(i,k)
+              det = max(trmb*trmb-4._r8*trma*trmc,0._r8)
+              ! Sanity Check
+              if( det .lt. 0._r8 ) then
+                  write(iulog,*) 'The det < 0. for the STL in UW eddy_diff'             
+                  stop
+              end if                  
+              gh = (-trmb + sqrt(det))/(2._r8*trma)
+            ! gh = min(max(gh,-0.28_r8),0.0233_r8)
+            ! gh = min(max(gh,-3.5334_r8),0.0233_r8)
+              gh = min(max(gh,ghmin),0.0233_r8)
+              sh = max(0._r8,alph5/(1._r8+alph3*gh))
+              sm = max(0._r8,(alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4exs*gh))
+
+              tke(i,k)   = b1*(leng(i,k)**2)*(-sh*n2(i,k)+sm*s2(i,k))
+              tke(i,k)   = min(tke(i,k),tkemax)
+              wcap(i,k)  = tke(i,k)/b1
+              kvh(i,k)   = leng(i,k) * sqrt(tke(i,k)) * sh
+              kvm(i,k)   = leng(i,k) * sqrt(tke(i,k)) * sm
+              bprod(i,k) = -kvh(i,k) * n2(i,k)
+              sprod(i,k) =  kvm(i,k) * s2(i,k)
+
+              sm_aw(i,k) = sm/alph1     ! This is diagnostic output for use in the microphysics             
+
+          end if
+
+       end do  ! k
+
+       ! --------------------------------------------------- !
+       ! End of treatment of Stable Turbulent Regime ( STL ) !
+       ! --------------------------------------------------- !
+
+       ! --------------------------------------------------------------- !
+       ! Re-computation of eddy diffusivity at the entrainment interface !
+       ! assuming that it is purely STL (0<Ri<0.19). Note even Ri>0.19,  !
+       ! turbulent can exist at the entrainment interface since 'Sh,Sm'  !
+       ! do not necessarily go to zero even when Ri>0.19. Since Ri can   !
+       ! be fairly larger than 0.19 at the entrainment interface, I      !
+       ! should set minimum value of 'tke' to be 0. in order to prevent  !
+       ! sqrt(tke) from being imaginary.                                 !
+       ! --------------------------------------------------------------- !
+
+       ! goto 888
+
+         do k = 2, pver
+
+         if( ( turbtype(i,k) .eq. 3 ) .or. ( turbtype(i,k) .eq. 4 ) .or. &
+             ( turbtype(i,k) .eq. 5 ) ) then
+
+             trma = alph3*alph4exs*ri(i,k) + 2._r8*b1*(alph2-alph4exs*alph5*ri(i,k))
+             trmb = (alph3+alph4exs)*ri(i,k) + 2._r8*b1*(-alph5*ri(i,k)+alph1)
+             trmc = ri(i,k)
+             det  = max(trmb*trmb-4._r8*trma*trmc,0._r8)
+             gh   = (-trmb + sqrt(det))/(2._r8*trma)
+           ! gh   = min(max(gh,-0.28_r8),0.0233_r8)
+           ! gh   = min(max(gh,-3.5334_r8),0.0233_r8)
+             gh   = min(max(gh,ghmin),0.0233_r8)
+             sh   = max(0._r8,alph5/(1._r8+alph3*gh))
+             sm   = max(0._r8,(alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4exs*gh))
+
+             lbulk = z(i,k-1) - z(i,k)
+
+             if( choice_tunl .eq. 'rampcl' ) then
+                 tunlramp = tunl
+             elseif( choice_tunl .eq. 'rampsl' ) then
+                 tunlramp = max(1.e-3_r8,ctunl*tunl*exp(-log(ctunl)*ri(i,k)/ricrit))
+               ! tunlramp = 0.065_r8 + 0.7_r8*exp(-20._r8*ri(i,k))
+             else
+                 tunlramp = tunl
+             endif
+             if( choice_leng .eq. 'origin' ) then
+                 leng_imsi = ( (vk*zi(i,k))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng)
+               ! leng_imsi = vk*zi(i,k) / (1._r8+vk*zi(i,k)/(tunlramp*lbulk))
+             else
+                 leng_imsi = min( vk*zi(i,k), tunlramp*lbulk )              
+             endif
+
+             tke_imsi = b1*(leng_imsi**2)*(-sh*n2(i,k)+sm*s2(i,k))
+             tke_imsi = min(max(tke_imsi,0._r8),tkemax)
+             kvh_imsi = leng_imsi * sqrt(tke_imsi) * sh
+             kvm_imsi = leng_imsi * sqrt(tke_imsi) * sm
+
+             if( kvh(i,k) .lt. kvh_imsi ) then 
+                 kvh(i,k)   =  kvh_imsi
+                 kvm(i,k)   =  kvm_imsi
+                 leng(i,k)  = leng_imsi
+                 tke(i,k)   =  tke_imsi
+                 wcap(i,k)  =  tke_imsi / b1
+                 bprod(i,k) = -kvh_imsi * n2(i,k)
+                 sprod(i,k) =  kvm_imsi * s2(i,k)
+                 sm_aw(i,k) =  sm/alph1     ! This is diagnostic output for use in the microphysics             
+                 turbtype(i,k) = 1          ! This was added on Dec.10.2009 for use in microphysics.
+             endif
+
+         end if
+
+         end do
+
+ ! 888   continue 
+
+       ! ------------------------------------------------------------------ !
+       ! End of recomputation of eddy diffusivity at entrainment interfaces !
+       ! ------------------------------------------------------------------ !
+
+       ! As an option, we can impose a certain minimum back-ground diffusivity.
+
+       ! do k = 1, pver+1
+       !    kvh(i,k) = max(0.01_r8,kvh(i,k))
+       !    kvm(i,k) = max(0.01_r8,kvm(i,k))
+       ! enddo
+ 
+       ! --------------------------------------------------------------------- !
+       ! Diagnostic Output                                                     !
+       ! Just for diagnostic purpose, calculate stability functions at  each   !
+       ! interface including surface. Instead of assuming neutral stability,   !
+       ! explicitly calculate stability functions using an reverse procedure   !
+       ! starting from tkes(i) similar to the case of SRCL and SBCL in zisocl. !
+       ! Note that it is possible to calculate stability functions even when   !
+       ! bflxs < 0. Note that this inverse method allows us to define Ri even  !
+       ! at the surface. Note also tkes(i) and sprod(i,pver+1) are always      !
+       ! positive values by limiters (e.g., ustar_min = 0.01).                 !
+       ! Dec.12.2006 : Also just for diagnostic output, re-set                 !
+       ! 'bprod(i,pver+1)= bflxs(i)' here. Note that this setting does not     !
+       ! influence numerical calculation at all - it is just for diagnostic    !
+       ! output.                                                               !
+       ! --------------------------------------------------------------------- !
+
+       bprod(i,pver+1) = bflxs(i)
+              
+       gg = 0.5_r8*vk*z(i,pver)*bprod(i,pver+1)/(tkes(i)**(3._r8/2._r8))
+       if( abs(alph5-gg*alph3) .le. 1.e-7_r8 ) then
+         ! gh = -0.28_r8
+           if( bprod(i,pver+1) .gt. 0._r8 ) then
+               gh = -3.5334_r8
+           else
+               gh = ghmin
+           endif
+       else    
+           gh = gg/(alph5-gg*alph3)
+       end if 
+
+     ! gh = min(max(gh,-0.28_r8),0.0233_r8)
+       if( bprod(i,pver+1) .gt. 0._r8 ) then
+           gh = min(max(gh,-3.5334_r8),0.0233_r8)
+       else
+           gh = min(max(gh,ghmin),0.0233_r8)
+       endif
+
+       gh_a(i,pver+1) = gh     
+       sh_a(i,pver+1) = max(0._r8,alph5/(1._r8+alph3*gh))
+       if( bprod(i,pver+1) .gt. 0._r8 ) then       
+           sm_a(i,pver+1) = max(0._r8,(alph1+alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4*gh))
+       else
+           sm_a(i,pver+1) = max(0._r8,(alph1+alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4exs*gh))
+       endif
+       sm_aw(i,pver+1) = sm_a(i,pver+1)/alph1
+       ri_a(i,pver+1)  = -(sm_a(i,pver+1)/sh_a(i,pver+1))*(bprod(i,pver+1)/sprod(i,pver+1))
+
+       do k = 1, pver
+          if( ri(i,k) .lt. 0._r8 ) then
+              trma = alph3*alph4*ri(i,k) + 2._r8*b1*(alph2-alph4*alph5*ri(i,k))
+              trmb = (alph3+alph4)*ri(i,k) + 2._r8*b1*(-alph5*ri(i,k)+alph1)
+              trmc = ri(i,k)
+              det  = max(trmb*trmb-4._r8*trma*trmc,0._r8)
+              gh   = (-trmb + sqrt(det))/(2._r8*trma)
+              gh   = min(max(gh,-3.5334_r8),0.0233_r8)
+              gh_a(i,k) = gh
+              sh_a(i,k) = max(0._r8,alph5/(1._r8+alph3*gh))
+              sm_a(i,k) = max(0._r8,(alph1+alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4*gh))
+              ri_a(i,k) = ri(i,k)
+          else
+              if( ri(i,k) .gt. ricrit ) then
+                  gh_a(i,k) = ghmin
+                  sh_a(i,k) = 0._r8
+                  sm_a(i,k) = 0._r8
+                  ri_a(i,k) = ri(i,k)
+              else
+                  trma = alph3*alph4exs*ri(i,k) + 2._r8*b1*(alph2-alph4exs*alph5*ri(i,k))
+                  trmb = (alph3+alph4exs)*ri(i,k) + 2._r8*b1*(-alph5*ri(i,k)+alph1)
+                  trmc = ri(i,k)
+                  det  = max(trmb*trmb-4._r8*trma*trmc,0._r8)
+                  gh   = (-trmb + sqrt(det))/(2._r8*trma)
+                  gh   = min(max(gh,ghmin),0.0233_r8)
+                  gh_a(i,k) = gh
+                  sh_a(i,k) = max(0._r8,alph5/(1._r8+alph3*gh))
+                  sm_a(i,k) = max(0._r8,(alph1+alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4exs*gh))
+                  ri_a(i,k) = ri(i,k)
+              endif
+          endif
+
+       end do
+
+       do k = 1, pver + 1
+          turbtype_f(i,k) = real(turbtype(i,k))
+       end do
+
+    end do   ! End of column index loop, i 
+
+    return
+
+    end subroutine caleddy
+
+    !============================================================================== !
+    !                                                                               !
+    !============================================================================== !
+
+    subroutine exacol( pcols, pver, ncol, ri, bflxs, minpblh, zi, ktop, kbase, ncvfin ) 
+
+    ! ---------------------------------------------------------------------------- !
+    ! Object : Find unstable CL regimes and determine the indices                  !
+    !          kbase, ktop which delimit these unstable layers :                   !
+    !          ri(kbase) > 0 and ri(ktop) > 0, but ri(k) < 0 for ktop < k < kbase. ! 
+    ! Author : Chris  Bretherton 08/2000,                                          !
+    !          Sungsu Park       08/2006, 11/2008                                  !
+    !----------------------------------------------------------------------------- !
+
+    implicit none
+
+    ! --------------- !
+    ! Input variables !
+    ! --------------- !
+
+    integer,  intent(in) :: pcols                  ! Number of atmospheric columns   
+    integer,  intent(in) :: pver                   ! Number of atmospheric vertical layers   
+    integer,  intent(in) :: ncol                   ! Number of atmospheric columns   
+
+    real(r8), intent(in) :: ri(pcols,pver)         ! Moist gradient Richardson no.
+    real(r8), intent(in) :: bflxs(pcols)           ! Buoyancy flux at surface
+    real(r8), intent(in) :: minpblh(pcols)         ! Minimum PBL height based on surface stress
+    real(r8), intent(in) :: zi(pcols,pver+1)       ! Interface heights
+
+    ! ---------------- !
+    ! Output variables !      
+    ! ---------------- !
+
+    integer, intent(out) :: kbase(pcols,ncvmax)    ! External interface index of CL base
+    integer, intent(out) :: ktop(pcols,ncvmax)     ! External interface index of CL top
+    integer, intent(out) :: ncvfin(pcols)          ! Total number of CLs
+
+    ! --------------- !
+    ! Local variables !
+    ! --------------- !
+
+    integer              :: i
+    integer              :: k
+    integer              :: ncv
+    real(r8)             :: rimaxentr
+    real(r8)             :: riex(pver+1)           ! Column Ri profile extended to surface
+
+    ! ----------------------- !
+    ! Main Computation Begins !
+    ! ----------------------- !
+
+    do i = 1, ncol
+       ncvfin(i) = 0
+       do ncv = 1, ncvmax
+          ktop(i,ncv)  = 0
+          kbase(i,ncv) = 0
+       end do
+    end do
+
+    ! ------------------------------------------------------ !
+    ! Find CL regimes starting from the surface going upward !
+    ! ------------------------------------------------------ !
+    
+    rimaxentr = 0._r8   
+    
+    do i = 1, ncol
+
+       riex(2:pver) = ri(i,2:pver)
+
+       ! Below allows consistent treatment of surface and other interfaces.
+       ! Simply, if surface buoyancy flux is positive, Ri of surface is set to be negative.
+
+       riex(pver+1) = rimaxentr - bflxs(i) 
+
+       ncv = 0
+       k   = pver + 1 ! Work upward from surface interface
+
+       do while ( k .gt. ntop_turb + 1 )
+
+        ! Below means that if 'bflxs > 0' (do not contain '=' sign), surface
+        ! interface is energetically interior surface. 
+       
+          if( riex(k) .lt. rimaxentr ) then 
+
+              ! Identify a new CL
+
+              ncv = ncv + 1
+
+              ! First define 'kbase' as the first interface below the lower-most unstable interface
+              ! Thus, Richardson number at 'kbase' is positive.
+
+              kbase(i,ncv) = min(k+1,pver+1)
+
+              ! Decrement k until top unstable level
+
+              do while( riex(k) .lt. rimaxentr .and. k .gt. ntop_turb + 1 )
+                 k = k - 1
+              end do
+
+              ! ktop is the first interface above upper-most unstable interface
+              ! Thus, Richardson number at 'ktop' is positive. 
+
+              ktop(i,ncv) = k
+             
+          else
+
+              ! Search upward for a CL.
+
+              k = k - 1
+
+          end if
+
+       end do ! End of CL regime finding for each atmospheric column
+
+       ncvfin(i) = ncv    
+
+    end do  ! End of atmospheric column do loop
+
+    return 
+
+    end subroutine exacol
+
+    !============================================================================== !
+    !                                                                               !
+    !============================================================================== !
+    
+    subroutine zisocl( pcols  , pver  , long ,                                 & 
+                       z      , zi    , n2   ,  s2      ,                      & 
+                       bprod  , sprod , bflxs,  tkes    ,                      & 
+                       ncvfin , kbase , ktop ,  belongcv,                      & 
+                       ricl   , ghcl  , shcl ,  smcl    ,                      &
+                       lbrk   , wbrk  , ebrk ,  extend  , extend_up, extend_dn )
+
+    !------------------------------------------------------------------------ !
+    ! Object : This 'zisocl' vertically extends original CLs identified from  !
+    !          'exacol' using a merging test based on either 'wint' or 'l2n2' !
+    !          and identify new CL regimes. Similar to the case of 'exacol',  !
+    !          CL regime index increases with height.  After identifying new  !
+    !          CL regimes ( kbase, ktop, ncvfin ),calculate CL internal mean  !
+    !          energetics (lbrk : energetic thickness integral, wbrk, ebrk )  !
+    !          and stability functions (ricl, ghcl, shcl, smcl) by including  !
+    !          surface interfacial layer contribution when bflxs > 0.   Note  !
+    !          that there are two options in the treatment of the energetics  !
+    !          of surface interfacial layer (use_dw_surf= 'true' or 'false')  !
+    ! Author : Sungsu Park 08/2006, 11/2008                                   !
+    !------------------------------------------------------------------------ !
+
+    implicit none
+
+    ! --------------- !    
+    ! Input variables !
+    ! --------------- !
+
+    integer,  intent(in)   :: long                    ! Longitude of the column
+    integer,  intent(in)   :: pcols                   ! Number of atmospheric columns   
+    integer,  intent(in)   :: pver                    ! Number of atmospheric vertical layers   
+    real(r8), intent(in)   :: z(pcols, pver)          ! Layer mid-point height [ m ]
+    real(r8), intent(in)   :: zi(pcols, pver+1)       ! Interface height [ m ]
+    real(r8), intent(in)   :: n2(pcols, pver)         ! Buoyancy frequency at interfaces except surface [ s-2 ]
+    real(r8), intent(in)   :: s2(pcols, pver)         ! Shear frequency at interfaces except surface [ s-2 ]
+    real(r8), intent(in)   :: bprod(pcols,pver+1)     ! Buoyancy production [ m2/s3 ]. bprod(i,pver+1) = bflxs 
+    real(r8), intent(in)   :: sprod(pcols,pver+1)     ! Shear production [ m2/s3 ]. sprod(i,pver+1) = usta**3/(vk*z(i,pver))
+    real(r8), intent(in)   :: bflxs(pcols)            ! Surface buoyancy flux [ m2/s3 ]. bprod(i,pver+1) = bflxs 
+    real(r8), intent(in)   :: tkes(pcols)             ! TKE at the surface [ s2/s2 ]
+
+    ! ---------------------- !
+    ! Input/output variables !
+    ! ---------------------- !
+
+    integer, intent(inout) :: kbase(pcols,ncvmax)     ! Base external interface index of CL
+    integer, intent(inout) :: ktop(pcols,ncvmax)      ! Top external interface index of CL
+    integer, intent(inout) :: ncvfin(pcols)           ! Total number of CLs
+
+    ! ---------------- !
+    ! Output variables !
+    ! ---------------- !
+
+    logical,  intent(out) :: belongcv(pcols,pver+1)   ! True if interface is in a CL ( either internal or external )
+    real(r8), intent(out) :: ricl(pcols,ncvmax)       ! Mean Richardson number of internal CL
+    real(r8), intent(out) :: ghcl(pcols,ncvmax)       ! Half of normalized buoyancy production of internal CL
+    real(r8), intent(out) :: shcl(pcols,ncvmax)       ! Galperin instability function of heat-moisture of internal CL
+    real(r8), intent(out) :: smcl(pcols,ncvmax)       ! Galperin instability function of momentum of internal CL
+    real(r8), intent(out) :: lbrk(pcols,ncvmax)       ! Thickness of (energetically) internal CL ( lint, [m] )
+    real(r8), intent(out) :: wbrk(pcols,ncvmax)       ! Mean normalized TKE of internal CL  [ m2/s2 ]
+    real(r8), intent(out) :: ebrk(pcols,ncvmax)       ! Mean TKE of internal CL ( b1*wbrk, [m2/s2] )
+
+    ! ------------------ !
+    ! Internal variables !
+    ! ------------------ !
+
+    logical               :: extend                   ! True when CL is extended in zisocl
+    logical               :: extend_up                ! True when CL is extended upward in zisocl
+    logical               :: extend_dn                ! True when CL is extended downward in zisocl
+    logical               :: bottom                   ! True when CL base is at surface ( kb = pver + 1 )
+
+    integer               :: i                        ! Local index for the longitude
+    integer               :: ncv                      ! CL Index increasing with height
+    integer               :: incv
+    integer               :: k
+    integer               :: kb                       ! Local index for kbase
+    integer               :: kt                       ! Local index for ktop
+    integer               :: ncvinit                  ! Value of ncv at routine entrance 
+    integer               :: cntu                     ! Number of merged CLs during upward   extension of individual CL
+    integer               :: cntd                     ! Number of merged CLs during downward extension of individual CL
+    integer               :: kbinc                    ! Index for incorporating underlying CL
+    integer               :: ktinc                    ! Index for incorporating  overlying CL
+
+    real(r8)              :: wint                     ! Normalized TKE of internal CL
+    real(r8)              :: dwinc                    ! Normalized TKE of CL external interfaces
+    real(r8)              :: dw_surf                  ! Normalized TKE of surface interfacial layer
+    real(r8)              :: dzinc
+    real(r8)              :: gh
+    real(r8)              :: sh
+    real(r8)              :: sm
+    real(r8)              :: gh_surf                  ! Half of normalized buoyancy production in surface interfacial layer 
+    real(r8)              :: sh_surf                  ! Galperin instability function in surface interfacial layer  
+    real(r8)              :: sm_surf                  ! Galperin instability function in surface interfacial layer 
+    real(r8)              :: l2n2                     ! Vertical integral of 'l^2N^2' over CL. Include thickness product
+    real(r8)              :: l2s2                     ! Vertical integral of 'l^2S^2' over CL. Include thickness product
+    real(r8)              :: dl2n2                    ! Vertical integration of 'l^2*N^2' of CL external interfaces
+    real(r8)              :: dl2s2                    ! Vertical integration of 'l^2*S^2' of CL external interfaces
+    real(r8)              :: dl2n2_surf               ! 'dl2n2' defined in the surface interfacial layer
+    real(r8)              :: dl2s2_surf               ! 'dl2s2' defined in the surface interfacial layer  
+    real(r8)              :: lint                     ! Thickness of (energetically) internal CL
+    real(r8)              :: dlint                    ! Interfacial layer thickness of CL external interfaces
+    real(r8)              :: dlint_surf               ! Surface interfacial layer thickness 
+    real(r8)              :: lbulk                    ! Master Length Scale : Whole CL thickness from top to base external interface
+    real(r8)              :: lz                       ! Turbulent length scale
+    real(r8)              :: ricll                    ! Mean Richardson number of internal CL 
+    real(r8)              :: trma
+    real(r8)              :: trmb
+    real(r8)              :: trmc
+    real(r8)              :: det
+    real(r8)              :: zbot                     ! Height of CL base
+    real(r8)              :: l2rat                    ! Square of ratio of actual to initial CL (not used)
+    real(r8)              :: gg                       ! Intermediate variable used for calculating stability functions of SBCL
+    real(r8)              :: tunlramp                 ! Ramping tunl
+
+    ! ----------------------- !
+    ! Main Computation Begins !
+    ! ----------------------- ! 
+
+    i = long
+
+    ! Initialize main output variables
+    
+    do k = 1, ncvmax
+       ricl(i,k) = 0._r8
+       ghcl(i,k) = 0._r8
+       shcl(i,k) = 0._r8
+       smcl(i,k) = 0._r8
+       lbrk(i,k) = 0._r8
+       wbrk(i,k) = 0._r8
+       ebrk(i,k) = 0._r8
+    end do
+    extend    = .false.
+    extend_up = .false.
+    extend_dn = .false.
+
+    ! ----------------------------------------------------------- !
+    ! Loop over each CL to see if any of them need to be extended !
+    ! ----------------------------------------------------------- !
+
+    ncv = 1
+
+    do while( ncv .le. ncvfin(i) )
+
+       ncvinit = ncv
+       cntu    = 0
+       cntd    = 0
+       kb      = kbase(i,ncv) 
+       kt      = ktop(i,ncv)
+       
+       ! ---------------------------------------------------------------------------- !
+       ! Calculation of CL interior energetics including surface before extension     !
+       ! ---------------------------------------------------------------------------- !
+       ! Note that the contribution of interior interfaces (not surface) to 'wint' is !
+       ! accounted by using '-sh*l2n2 + sm*l2s2' while the contribution of surface is !
+       ! accounted by using 'dwsurf = tkes/b1' when bflxs > 0. This approach is fully !
+       ! reasonable. Another possible alternative,  which seems to be also consistent !
+       ! is to calculate 'dl2n2_surf'  and  'dl2s2_surf' of surface interfacial layer !
+       ! separately, and this contribution is explicitly added by initializing 'l2n2' !
+       ! 'l2s2' not by zero, but by 'dl2n2_surf' and 'ds2n2_surf' below.  At the same !
+       ! time, 'dwsurf' should be excluded in 'wint' calculation below. The only diff.!
+       ! between two approaches is that in case of the latter approach, contributions !
+       ! of surface interfacial layer to the CL mean stability function (ri,gh,sh,sm) !
+       ! are explicitly included while the first approach is not. In this sense,  the !
+       ! second approach seems to be more conceptually consistent,   but currently, I !
+       ! (Sungsu) will keep the first default approach. There is a switch             !
+       ! 'use_dw_surf' at the first part of eddy_diff.F90 chosing one of              !
+       ! these two options.                                                           !
+       ! ---------------------------------------------------------------------------- !
+       
+       ! ------------------------------------------------------ !   
+       ! Step 0: Calculate surface interfacial layer energetics !
+       ! ------------------------------------------------------ !
+
+       lbulk      = zi(i,kt) - zi(i,kb)
+       dlint_surf = 0._r8
+       dl2n2_surf = 0._r8
+       dl2s2_surf = 0._r8
+       dw_surf    = 0._r8
+       if( kb .eq. pver+1 ) then
+
+           if( bflxs(i) .gt. 0._r8 ) then
+
+               ! Calculate stability functions of surface interfacial layer
+               ! from the given 'bprod(i,pver+1)' and 'sprod(i,pver+1)' using
+               ! inverse approach. Since alph5>0 and alph3<0, denominator of
+               ! gg is always positive if bprod(i,pver+1)>0.               
+
+               gg    = 0.5_r8*vk*z(i,pver)*bprod(i,pver+1)/(tkes(i)**(3._r8/2._r8))
+               gh    = gg/(alph5-gg*alph3)
+             ! gh    = min(max(gh,-0.28_r8),0.0233_r8)
+               gh    = min(max(gh,-3.5334_r8),0.0233_r8)
+               sh    = alph5/(1._r8+alph3*gh)
+               sm    = (alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4*gh)
+               ricll = min(-(sm/sh)*(bprod(i,pver+1)/sprod(i,pver+1)),ricrit)
+
+               ! Calculate surface interfacial layer contribution to CL internal
+               ! energetics. By construction, 'dw_surf = -dl2n2_surf + ds2n2_surf'
+               ! is exactly satisfied, which corresponds to assuming turbulent
+               ! length scale of surface interfacial layer = vk * z(i,pver). Note
+               ! 'dl2n2_surf','dl2s2_surf','dw_surf' include thickness product.   
+
+               dlint_surf = z(i,pver)
+               dl2n2_surf = -vk*(z(i,pver)**2)*bprod(i,pver+1)/(sh*sqrt(tkes(i)))
+               dl2s2_surf =  vk*(z(i,pver)**2)*sprod(i,pver+1)/(sm*sqrt(tkes(i)))
+               dw_surf    = (tkes(i)/b1)*z(i,pver) 
+
+           else
+
+               ! Note that this case can happen when surface is an external 
+               ! interface of CL.
+               lbulk = zi(i,kt) - z(i,pver)
+
+           end if
+
+       end if
+           
+       ! ------------------------------------------------------ !   
+       ! Step 1: Include surface interfacial layer contribution !
+       ! ------------------------------------------------------ !
+       
+       lint = dlint_surf
+       l2n2 = dl2n2_surf
+       l2s2 = dl2s2_surf          
+       wint = dw_surf
+       if( use_dw_surf ) then
+           l2n2 = 0._r8
+           l2s2 = 0._r8
+       else
+           wint = 0._r8
+       end if    
+       
+       ! --------------------------------------------------------------------------------- !
+       ! Step 2. Include the contribution of 'pure internal interfaces' other than surface !
+       ! --------------------------------------------------------------------------------- ! 
+       
+       if( kt .lt. kb - 1 ) then ! The case of non-SBCL.
+                              
+           do k = kb - 1, kt + 1, -1       
+              if( choice_tunl .eq. 'rampcl' ) then
+                ! Modification : I simply used the average tunlramp between the two limits.
+                  tunlramp = 0.5_r8*(1._r8+ctunl)*tunl
+              elseif( choice_tunl .eq. 'rampsl' ) then
+                  tunlramp = ctunl*tunl
+                ! tunlramp = 0.765_r8
+              else
+                  tunlramp = tunl
+              endif
+              if( choice_leng .eq. 'origin' ) then
+                  lz = ( (vk*zi(i,k))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng)
+                ! lz = vk*zi(i,k) / (1._r8+vk*zi(i,k)/(tunlramp*lbulk))
+              else
+                  lz = min( vk*zi(i,k), tunlramp*lbulk )              
+              endif
+              dzinc = z(i,k-1) - z(i,k)
+              l2n2  = l2n2 + lz*lz*n2(i,k)*dzinc
+              l2s2  = l2s2 + lz*lz*s2(i,k)*dzinc
+              lint  = lint + dzinc
+           end do
+
+           ! Calculate initial CL stability functions (gh,sh,sm) and net
+           ! internal energy of CL including surface contribution if any. 
+
+         ! Modification : It seems that below cannot be applied when ricrit > 0.19.
+         !                May need future generalization.
+
+           ricll = min(l2n2/max(l2s2,ntzero),ricrit) ! Mean Ri of internal CL
+           trma  = alph3*alph4*ricll+2._r8*b1*(alph2-alph4*alph5*ricll)
+           trmb  = ricll*(alph3+alph4)+2._r8*b1*(-alph5*ricll+alph1)
+           trmc  = ricll
+           det   = max(trmb*trmb-4._r8*trma*trmc,0._r8)
+           gh    = (-trmb + sqrt(det))/2._r8/trma
+         ! gh    = min(max(gh,-0.28_r8),0.0233_r8)
+           gh    = min(max(gh,-3.5334_r8),0.0233_r8)
+           sh    = alph5/(1._r8+alph3*gh)
+           sm    = (alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4*gh)
+           wint  = wint - sh*l2n2 + sm*l2s2 
+
+       else ! The case of SBCL
+ 
+           ! If there is no pure internal interface, use only surface interfacial
+           ! values. However, re-set surface interfacial values such  that it can
+           ! be used in the merging tests (either based on 'wint' or 'l2n2')  and
+           ! in such that surface interfacial energy is not double-counted.
+           ! Note that regardless of the choise of 'use_dw_surf', below should be
+           ! kept as it is below, for consistent merging test of extending SBCL. 
+       
+           lint = dlint_surf
+           l2n2 = dl2n2_surf
+           l2s2 = dl2s2_surf 
+           wint = dw_surf
+
+           ! Aug.29.2006 : Only for the purpose of merging test of extending SRCL
+           ! based on 'l2n2', re-define 'l2n2' of surface interfacial layer using
+           ! 'wint'. This part is designed for similar treatment of merging as in
+           ! the original 'eddy_diff.F90' code,  where 'l2n2' of SBCL was defined
+           ! as 'l2n2 = - wint / sh'. Note that below block is used only when (1)
+           ! surface buoyancy production 'bprod(i,pver+1)' is NOT included in the
+           ! calculation of surface TKE in the initialization of 'bprod(i,pver+1)'
+           ! in the main subroutine ( even though bflxs > 0 ), and (2) to force 
+           ! current scheme be similar to the previous scheme in the treatment of  
+           ! extending-merging test of SBCL based on 'l2n2'. Otherwise below line
+           ! must be commented out. Note at this stage, correct non-zero value of
+           ! 'sh' has been already computed.      
+
+           if( choice_tkes .eq. 'ebprod' ) then
+               l2n2 = - wint / sh 
+           endif
+           
+       endif
+           
+       ! Set consistent upper limits on 'l2n2' and 'l2s2'. Below limits are
+       ! reasonable since l2n2 of CL interior interface is always negative.
+
+       l2n2 = -min(-l2n2, tkemax*lint/(b1*sh))
+       l2s2 =  min( l2s2, tkemax*lint/(b1*sm))
+       
+       ! Note that at this stage, ( gh, sh, sm )  are the values of surface
+       ! interfacial layer if there is no pure internal interface, while if
+       ! there is pure internal interface, ( gh, sh, sm ) are the values of
+       ! pure CL interfaces or the values that include both the CL internal
+       ! interfaces and surface interfaces, depending on the 'use_dw_surf'.       
+       
+       ! ----------------------------------------------------------------------- !
+       ! Perform vertical extension-merging process                              !
+       ! ----------------------------------------------------------------------- !
+       ! During the merging process, we assumed ( lbulk, sh, sm ) of CL external !
+       ! interfaces are the same as the ones of the original merging CL. This is !
+       ! an inevitable approximation since we don't know  ( sh, sm ) of external !
+       ! interfaces at this stage.     Note that current default merging test is !
+       ! purely based on buoyancy production without including shear production, !
+       ! since we used 'l2n2' instead of 'wint' as a merging parameter. However, !
+       ! merging test based on 'wint' maybe conceptually more attractable.       !
+       ! Downward CL merging process is identical to the upward merging process, !
+       ! but when the base of extended CL reaches to the surface, surface inter  !
+       ! facial layer contribution to the energetic of extended CL must be done  !
+       ! carefully depending on the sign of surface buoyancy flux. The contribu  !
+       ! tion of surface interfacial layer energetic is included to the internal !
+       ! energetics of merging CL only when bflxs > 0.                           !
+       ! ----------------------------------------------------------------------- !
+       
+       ! ---------------------------- !
+       ! Step 1. Extend the CL upward !
+       ! ---------------------------- !
+       
+       extend = .false.    ! This will become .true. if CL top or base is extended
+
+       ! Calculate contribution of potentially incorporable CL top interface
+
+       if( choice_tunl .eq. 'rampcl' ) then
+           tunlramp = 0.5_r8*(1._r8+ctunl)*tunl
+       elseif( choice_tunl .eq. 'rampsl' ) then
+           tunlramp = ctunl*tunl
+         ! tunlramp = 0.765_r8
+       else
+           tunlramp = tunl
+       endif
+       if( choice_leng .eq. 'origin' ) then
+           lz = ( (vk*zi(i,kt))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng)
+         ! lz = vk*zi(i,kt) / (1._r8+vk*zi(i,kt)/(tunlramp*lbulk))
+       else
+           lz = min( vk*zi(i,kt), tunlramp*lbulk )              
+       endif
+
+       dzinc = z(i,kt-1)-z(i,kt)
+       dl2n2 = lz*lz*n2(i,kt)*dzinc
+       dl2s2 = lz*lz*s2(i,kt)*dzinc
+       dwinc = -sh*dl2n2 + sm*dl2s2
+
+       ! ------------ !
+       ! Merging Test !
+       ! ------------ !
+ 
+     ! do while (  dwinc .gt. ( rinc*dzinc*wint/(lint+(1._r8-rinc)*dzinc)) )  ! Merging test based on wint
+     ! do while ( -dl2n2 .gt. (-rinc*dzinc*l2n2/(lint+(1._r8-rinc)*dzinc)) )  ! Merging test based on l2n2 
+       do while ( -dl2n2 .gt. (-rinc*l2n2/(1._r8-rinc)) .and. kt-1 .gt. ntop_turb )                     ! Integral merging test
+
+          ! Add contribution of top external interface to interior energy.
+          ! Note even when we chose 'use_dw_surf='true.', the contribution
+          ! of surface interfacial layer to 'l2n2' and 'l2s2' are included
+          ! here. However it is not double counting of surface interfacial
+          ! energy : surface interfacial layer energy is counted in 'wint'
+          ! formula and 'l2n2' is just used for performing merging test in
+          ! this 'do while' loop.     
+
+          lint = lint + dzinc
+          l2n2 = l2n2 + dl2n2
+          l2n2 = -min(-l2n2, tkemax*lint/(b1*sh))
+          l2s2 = l2s2 + dl2s2
+          wint = wint + dwinc
+
+          ! Extend top external interface of CL upward after merging
+
+          kt        = kt - 1
+          extend    = .true.
+          extend_up = .true.
+          if( kt .eq. ntop_turb ) then
+              write(iulog,*) 'zisocl: Error: Tried to extend CL to the model top'
+              stop
+          end if
+
+          ! If the top external interface of extending CL is the same as the 
+          ! top interior interface of the overlying CL, overlying CL will be
+          ! automatically merged. Then,reduce total number of CL regime by 1. 
+          ! and increase 'cntu'(number of merged CLs during upward extension)
+          ! by 1.
+ 
+          ktinc = kbase(i,ncv+cntu+1) - 1  ! Lowest interior interface of overlying CL
+
+          if( kt .eq. ktinc ) then
+
+              do k = kbase(i,ncv+cntu+1) - 1, ktop(i,ncv+cntu+1) + 1, -1
+
+                 if( choice_tunl .eq. 'rampcl' ) then
+                     tunlramp = 0.5_r8*(1._r8+ctunl)*tunl
+                 elseif( choice_tunl .eq. 'rampsl' ) then
+                     tunlramp = ctunl*tunl
+                   ! tunlramp = 0.765_r8
+                 else
+                     tunlramp = tunl
+                 endif
+                 if( choice_leng .eq. 'origin' ) then
+                     lz = ( (vk*zi(i,k))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng)
+                   ! lz = vk*zi(i,k) / (1._r8+vk*zi(i,k)/(tunlramp*lbulk))
+                 else
+                     lz = min( vk*zi(i,k), tunlramp*lbulk )              
+                 endif
+
+                 dzinc = z(i,k-1)-z(i,k)
+                 dl2n2 = lz*lz*n2(i,k)*dzinc
+                 dl2s2 = lz*lz*s2(i,k)*dzinc
+                 dwinc = -sh*dl2n2 + sm*dl2s2
+
+                 lint = lint + dzinc
+                 l2n2 = l2n2 + dl2n2
+                 l2n2 = -min(-l2n2, tkemax*lint/(b1*sh))
+                 l2s2 = l2s2 + dl2s2
+                 wint = wint + dwinc
+
+              end do 
+
+              kt        = ktop(i,ncv+cntu+1) 
+              ncvfin(i) = ncvfin(i) - 1
+              cntu      = cntu + 1
+        
+          end if
+
+          ! Again, calculate the contribution of potentially incorporatable CL
+          ! top external interface of CL regime.
+
+          if( choice_tunl .eq. 'rampcl' ) then
+              tunlramp = 0.5_r8*(1._r8+ctunl)*tunl
+          elseif( choice_tunl .eq. 'rampsl' ) then
+              tunlramp = ctunl*tunl
+            ! tunlramp = 0.765_r8
+          else
+              tunlramp = tunl
+          endif
+          if( choice_leng .eq. 'origin' ) then
+              lz = ( (vk*zi(i,kt))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng)
+            ! lz = vk*zi(i,kt) / (1._r8+vk*zi(i,kt)/(tunlramp*lbulk))
+          else
+              lz = min( vk*zi(i,kt), tunlramp*lbulk )              
+          endif
+
+          dzinc = z(i,kt-1)-z(i,kt)
+          dl2n2 = lz*lz*n2(i,kt)*dzinc
+          dl2s2 = lz*lz*s2(i,kt)*dzinc
+          dwinc = -sh*dl2n2 + sm*dl2s2
+
+       end do   ! End of upward merging test 'do while' loop
+
+       ! Update CL interface indices appropriately if any CL was merged.
+       ! Note that below only updated the interface index of merged CL,
+       ! not the original merging CL.  Updates of 'kbase' and 'ktop' of 
+       ! the original merging CL  will be done after finishing downward
+       ! extension also later.
+
+       if( cntu .gt. 0 ) then
+           do incv = 1, ncvfin(i) - ncv
+              kbase(i,ncv+incv) = kbase(i,ncv+cntu+incv)
+              ktop(i,ncv+incv)  = ktop(i,ncv+cntu+incv)
+           end do
+       end if
+
+       ! ------------------------------ !
+       ! Step 2. Extend the CL downward !
+       ! ------------------------------ !
+       
+       if( kb .ne. pver + 1 ) then
+
+           ! Calculate contribution of potentially incorporable CL base interface
+
+           if( choice_tunl .eq. 'rampcl' ) then
+               tunlramp = 0.5_r8*(1._r8+ctunl)*tunl
+           elseif( choice_tunl .eq. 'rampsl' ) then
+               tunlramp = ctunl*tunl
+             ! tunlramp = 0.765_r8
+           else
+               tunlramp = tunl
+           endif
+           if( choice_leng .eq. 'origin' ) then
+               lz = ( (vk*zi(i,kb))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng)
+             ! lz = vk*zi(i,kb) / (1._r8+vk*zi(i,kb)/(tunlramp*lbulk))
+           else
+               lz = min( vk*zi(i,kb), tunlramp*lbulk )              
+           endif
+
+           dzinc = z(i,kb-1)-z(i,kb)
+           dl2n2 = lz*lz*n2(i,kb)*dzinc
+           dl2s2 = lz*lz*s2(i,kb)*dzinc
+           dwinc = -sh*dl2n2 + sm*dl2s2
+
+           ! ------------ ! 
+           ! Merging test !
+           ! ------------ ! 
+
+           ! In the below merging tests, I must keep '.and.(kb.ne.pver+1)',   
+           ! since 'kb' is continuously updated within the 'do while' loop  
+           ! whenever CL base is merged.
+
+         ! do while( (  dwinc .gt. ( rinc*dzinc*wint/(lint+(1._r8-rinc)*dzinc)) ) &  ! Merging test based on wint
+         ! do while( ( -dl2n2 .gt. (-rinc*dzinc*l2n2/(lint+(1._r8-rinc)*dzinc)) ) &  ! Merging test based on l2n2
+         !             .and.(kb.ne.pver+1))
+           do while( ( -dl2n2 .gt. (-rinc*l2n2/(1._r8-rinc)) ) &                     ! Integral merging test
+                       .and.(kb.ne.pver+1))
+
+              ! Add contributions from interfacial layer kb to CL interior 
+
+              lint = lint + dzinc
+              l2n2 = l2n2 + dl2n2
+              l2n2 = -min(-l2n2, tkemax*lint/(b1*sh))
+              l2s2 = l2s2 + dl2s2
+              wint = wint + dwinc
+
+              ! Extend the base external interface of CL downward after merging
+
+              kb        =  kb + 1
+              extend    = .true.
+              extend_dn = .true.
+
+              ! If the base external interface of extending CL is the same as the 
+              ! base interior interface of the underlying CL, underlying CL  will
+              ! be automatically merged. Then, reduce total number of CL by 1. 
+              ! For a consistent treatment with 'upward' extension,  I should use
+              ! 'kbinc = kbase(i,ncv-1) - 1' instead of 'ktop(i,ncv-1) + 1' below.
+              ! However, it seems that these two methods produce the same results.
+              ! Note also that in contrast to upward merging, the decrease of ncv
+              ! should be performed here.
+              ! Note that below formula correctly works even when upperlying CL 
+              ! regime incorporates below SBCL.
+
+              kbinc = 0
+              if( ncv .gt. 1 ) kbinc = ktop(i,ncv-1) + 1
+              if( kb .eq. kbinc ) then
+
+                  do k =  ktop(i,ncv-1) + 1, kbase(i,ncv-1) - 1
+
+                     if( choice_tunl .eq. 'rampcl' ) then
+                         tunlramp = 0.5_r8*(1._r8+ctunl)*tunl
+                     elseif( choice_tunl .eq. 'rampsl' ) then
+                         tunlramp = ctunl*tunl
+                       ! tunlramp = 0.765_r8
+                     else
+                         tunlramp = tunl
+                     endif
+                     if( choice_leng .eq. 'origin' ) then
+                         lz = ( (vk*zi(i,k))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng)
+                       ! lz = vk*zi(i,k) / (1._r8+vk*zi(i,k)/(tunlramp*lbulk))
+                     else
+                         lz = min( vk*zi(i,k), tunlramp*lbulk )              
+                     endif
+
+                     dzinc = z(i,k-1)-z(i,k)
+                     dl2n2 = lz*lz*n2(i,k)*dzinc
+                     dl2s2 = lz*lz*s2(i,k)*dzinc
+                     dwinc = -sh*dl2n2 + sm*dl2s2
+
+                     lint = lint + dzinc
+                     l2n2 = l2n2 + dl2n2
+                     l2n2 = -min(-l2n2, tkemax*lint/(b1*sh))
+                     l2s2 = l2s2 + dl2s2
+                     wint = wint + dwinc
+
+                  end do 
+
+                  ! We are incorporating interior of CL ncv-1, so merge
+                  ! this CL into the current CL.
+
+                  kb        = kbase(i,ncv-1)
+                  ncv       = ncv - 1
+                  ncvfin(i) = ncvfin(i) -1
+                  cntd      = cntd + 1
+
+              end if
+
+              ! Calculate the contribution of potentially incorporatable CL
+              ! base external interface. Calculate separately when the base
+              ! of extended CL is surface and non-surface.
+             
+              if( kb .eq. pver + 1 ) then 
+
+                  if( bflxs(i) .gt. 0._r8 ) then 
+                      ! Calculate stability functions of surface interfacial layer
+                      gg = 0.5_r8*vk*z(i,pver)*bprod(i,pver+1)/(tkes(i)**(3._r8/2._r8))
+                      gh_surf = gg/(alph5-gg*alph3)
+                    ! gh_surf = min(max(gh_surf,-0.28_r8),0.0233_r8)
+                      gh_surf = min(max(gh_surf,-3.5334_r8),0.0233_r8)
+                      sh_surf = alph5/(1._r8+alph3*gh_surf)
+                      sm_surf = (alph1 + alph2*gh_surf)/(1._r8+alph3*gh_surf)/(1._r8+alph4*gh_surf)
+                      ! Calculate surface interfacial layer contribution. By construction,
+                      ! it exactly becomes 'dw_surf = -dl2n2_surf + ds2n2_surf'  
+                      dlint_surf = z(i,pver)
+                      dl2n2_surf = -vk*(z(i,pver)**2._r8)*bprod(i,pver+1)/(sh_surf*sqrt(tkes(i)))
+                      dl2s2_surf =  vk*(z(i,pver)**2._r8)*sprod(i,pver+1)/(sm_surf*sqrt(tkes(i)))
+                      dw_surf = (tkes(i)/b1)*z(i,pver) 
+                  else
+                      dlint_surf = 0._r8
+                      dl2n2_surf = 0._r8
+                      dl2s2_surf = 0._r8
+                      dw_surf = 0._r8
+                  end if
+                  ! If (kb.eq.pver+1), updating of CL internal energetics should be 
+                  ! performed here inside of 'do while' loop, since 'do while' loop
+                  ! contains the constraint of '.and.(kb.ne.pver+1)',so updating of
+                  ! CL internal energetics cannot be performed within this do while
+                  ! loop when kb.eq.pver+1. Even though I updated all 'l2n2','l2s2',
+                  ! 'wint' below, only the updated 'wint' is used in the following
+                  ! numerical calculation.                
+                  lint = lint + dlint_surf
+                  l2n2 = l2n2 + dl2n2_surf
+                  l2n2 = -min(-l2n2, tkemax*lint/(b1*sh))
+                  l2s2 = l2s2 + dl2s2_surf 
+                  wint = wint + dw_surf                
+                
+              else
+
+                  if( choice_tunl .eq. 'rampcl' ) then
+                      tunlramp = 0.5_r8*(1._r8+ctunl)*tunl
+                  elseif( choice_tunl .eq. 'rampsl' ) then
+                      tunlramp = ctunl*tunl
+                    ! tunlramp = 0.765_r8
+                  else
+                      tunlramp = tunl
+                  endif
+                  if( choice_leng .eq. 'origin' ) then
+                      lz = ( (vk*zi(i,kb))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng)
+                    ! lz = vk*zi(i,kb) / (1._r8+vk*zi(i,kb)/(tunlramp*lbulk))
+                  else
+                      lz = min( vk*zi(i,kb), tunlramp*lbulk )              
+                  endif
+
+                  dzinc = z(i,kb-1)-z(i,kb)
+                  dl2n2 = lz*lz*n2(i,kb)*dzinc
+                  dl2s2 = lz*lz*s2(i,kb)*dzinc
+                  dwinc = -sh*dl2n2 + sm*dl2s2
+
+              end if
+
+          end do ! End of merging test 'do while' loop
+
+          if( (kb.eq.pver+1) .and. (ncv.ne.1) ) then 
+               write(iulog,*) 'Major mistake zisocl: the CL based at surface is not indexed 1'
+               stop
+          end if
+
+       end if   ! Done with bottom extension of CL 
+
+       ! Update CL interface indices appropriately if any CL was merged.
+       ! Note that below only updated the interface index of merged CL,
+       ! not the original merging CL.  Updates of 'kbase' and 'ktop' of 
+       ! the original merging CL  will be done later below. I should 
+       ! check in detail if below index updating is correct or not.   
+
+       if( cntd .gt. 0 ) then
+           do incv = 1, ncvfin(i) - ncv
+              kbase(i,ncv+incv) = kbase(i,ncvinit+incv)
+              ktop(i,ncv+incv)  = ktop(i,ncvinit+incv)
+           end do
+       end if
+
+       ! Sanity check for positive wint.
+
+       if( wint .lt. 0.01_r8 ) then
+           wint = 0.01_r8
+       end if
+
+       ! -------------------------------------------------------------------------- !
+       ! Finally update CL mean internal energetics including surface contribution  !
+       ! after finishing all the CL extension-merging process.  As mentioned above, !
+       ! there are two possible ways in the treatment of surface interfacial layer, !
+       ! either through 'dw_surf' or 'dl2n2_surf and dl2s2_surf' by setting logical !
+       ! variable 'use_dw_surf' =.true. or .false.    In any cases, we should avoid !
+       ! double counting of surface interfacial layer and one single consistent way !
+       ! should be used throughout the program.                                     !
+       ! -------------------------------------------------------------------------- !
+
+       if( extend ) then
+
+           ktop(i,ncv)  = kt
+           kbase(i,ncv) = kb
+
+           ! ------------------------------------------------------ !   
+           ! Step 1: Include surface interfacial layer contribution !
+           ! ------------------------------------------------------ !        
+          
+           lbulk      = zi(i,kt) - zi(i,kb)
+           dlint_surf = 0._r8
+           dl2n2_surf = 0._r8
+           dl2s2_surf = 0._r8
+           dw_surf    = 0._r8
+           if( kb .eq. pver + 1 ) then
+               if( bflxs(i) .gt. 0._r8 ) then
+                   ! Calculate stability functions of surface interfacial layer
+                   gg = 0.5_r8*vk*z(i,pver)*bprod(i,pver+1)/(tkes(i)**(3._r8/2._r8))
+                   gh = gg/(alph5-gg*alph3)
+                 ! gh = min(max(gh,-0.28_r8),0.0233_r8)
+                   gh = min(max(gh,-3.5334_r8),0.0233_r8)
+                   sh = alph5/(1._r8+alph3*gh)
+                   sm = (alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4*gh)
+                   ! Calculate surface interfacial layer contribution. By construction,
+                   ! it exactly becomes 'dw_surf = -dl2n2_surf + ds2n2_surf'  
+                   dlint_surf = z(i,pver)
+                   dl2n2_surf = -vk*(z(i,pver)**2._r8)*bprod(i,pver+1)/(sh*sqrt(tkes(i)))
+                   dl2s2_surf =  vk*(z(i,pver)**2._r8)*sprod(i,pver+1)/(sm*sqrt(tkes(i)))
+                   dw_surf    = (tkes(i)/b1)*z(i,pver) 
+               else
+                   lbulk = zi(i,kt) - z(i,pver)
+               end if
+           end if
+           lint = dlint_surf
+           l2n2 = dl2n2_surf
+           l2s2 = dl2s2_surf
+           wint = dw_surf
+           if( use_dw_surf ) then
+               l2n2 = 0._r8
+               l2s2 = 0._r8
+           else
+               wint = 0._r8
+           end if   
+       
+           ! -------------------------------------------------------------- !
+           ! Step 2. Include the contribution of 'pure internal interfaces' !
+           ! -------------------------------------------------------------- ! 
+          
+           do k = kt + 1, kb - 1
+              if( choice_tunl .eq. 'rampcl' ) then
+                  tunlramp = 0.5_r8*(1._r8+ctunl)*tunl
+              elseif( choice_tunl .eq. 'rampsl' ) then
+                  tunlramp = ctunl*tunl
+                ! tunlramp = 0.765_r8
+              else
+                  tunlramp = tunl
+              endif
+              if( choice_leng .eq. 'origin' ) then
+                  lz = ( (vk*zi(i,k))**(-cleng) + (tunlramp*lbulk)**(-cleng) )**(-1._r8/cleng)
+                ! lz = vk*zi(i,k) / (1._r8+vk*zi(i,k)/(tunlramp*lbulk))
+              else
+                  lz = min( vk*zi(i,k), tunlramp*lbulk )              
+              endif
+              dzinc = z(i,k-1) - z(i,k)
+              lint = lint + dzinc
+              l2n2 = l2n2 + lz*lz*n2(i,k)*dzinc
+              l2s2 = l2s2 + lz*lz*s2(i,k)*dzinc
+           end do
+
+           ricll = min(l2n2/max(l2s2,ntzero),ricrit)
+           trma = alph3*alph4*ricll+2._r8*b1*(alph2-alph4*alph5*ricll)
+           trmb = ricll*(alph3+alph4)+2._r8*b1*(-alph5*ricll+alph1)
+           trmc = ricll
+           det = max(trmb*trmb-4._r8*trma*trmc,0._r8)
+           gh = (-trmb + sqrt(det))/2._r8/trma
+         ! gh = min(max(gh,-0.28_r8),0.0233_r8)
+           gh = min(max(gh,-3.5334_r8),0.0233_r8)
+           sh = alph5 / (1._r8+alph3*gh)
+           sm = (alph1 + alph2*gh)/(1._r8+alph3*gh)/(1._r8+alph4*gh)
+           ! Even though the 'wint' after finishing merging was positive, it is 
+           ! possible that re-calculated 'wint' here is negative.  In this case,
+           ! correct 'wint' to be a small positive number
+           wint = max( wint - sh*l2n2 + sm*l2s2, 0.01_r8 )
+
+       end if
+
+       ! ---------------------------------------------------------------------- !
+       ! Calculate final output variables of each CL (either has merged or not) !
+       ! ---------------------------------------------------------------------- !
+
+       lbrk(i,ncv) = lint
+       wbrk(i,ncv) = wint/lint
+       ebrk(i,ncv) = b1*wbrk(i,ncv)
+       ebrk(i,ncv) = min(ebrk(i,ncv),tkemax)
+       ricl(i,ncv) = ricll 
+       ghcl(i,ncv) = gh 
+       shcl(i,ncv) = sh
+       smcl(i,ncv) = sm
+
+       ! Increment counter for next CL. I should check if the increament of 'ncv'
+       ! below is reasonable or not, since whenever CL is merged during downward
+       ! extension process, 'ncv' is lowered down continuously within 'do' loop.
+       ! But it seems that below 'ncv = ncv + 1' is perfectly correct.
+
+       ncv = ncv + 1
+
+    end do                   ! End of loop over each CL regime, ncv.
+
+    ! ---------------------------------------------------------- !
+    ! Re-initialize external interface indices which are not CLs !
+    ! ---------------------------------------------------------- !
+
+    do ncv = ncvfin(i) + 1, ncvmax
+       ktop(i,ncv)  = 0
+       kbase(i,ncv) = 0
+    end do
+
+    ! ------------------------------------------------ !
+    ! Update CL interface identifiers, 'belongcv'      !
+    ! CL external interfaces are also identified as CL !
+    ! ------------------------------------------------ !
+
+    do k = 1, pver + 1
+       belongcv(i,k) = .false.
+    end do
+
+    do ncv = 1, ncvfin(i)
+       do k = ktop(i,ncv), kbase(i,ncv)
+          belongcv(i,k) = .true.
+       end do
+    end do
+
+    return
+
+    end subroutine zisocl
+
+    real(r8) function compute_cubic(a,b,c)
+    ! ------------------------------------------------------------------------- !
+    ! Solve canonical cubic : x^3 + a*x^2 + b*x + c = 0,  x = sqrt(e)/sqrt(<e>) !
+    ! Set x = max(xmin,x) at the end                                            ! 
+    ! ------------------------------------------------------------------------- !
+    implicit none
+    real(r8), intent(in)     :: a, b, c
+    real(r8)  qq, rr, dd, theta, aa, bb, x1, x2, x3
+    real(r8), parameter      :: xmin = 1.e-2_r8
+    
+    qq = (a**2-3._r8*b)/9._r8 
+    rr = (2._r8*a**3 - 9._r8*a*b + 27._r8*c)/54._r8
+    
+    dd = rr**2 - qq**3
+    if( dd .le. 0._r8 ) then
+        theta = acos(rr/qq**(3._r8/2._r8))
+        x1 = -2._r8*sqrt(qq)*cos(theta/3._r8) - a/3._r8
+        x2 = -2._r8*sqrt(qq)*cos((theta+2._r8*3.141592)/3._r8) - a/3._r8
+        x3 = -2._r8*sqrt(qq)*cos((theta-2._r8*3.141592)/3._r8) - a/3._r8
+        compute_cubic = max(max(max(x1,x2),x3),xmin)        
+        return
+    else
+        if( rr .ge. 0._r8 ) then
+            aa = -(sqrt(rr**2-qq**3)+rr)**(1._r8/3._r8)
+        else
+            aa =  (sqrt(rr**2-qq**3)-rr)**(1._r8/3._r8)
+        endif
+        if( aa .eq. 0._r8 ) then
+            bb = 0._r8
+        else
+            bb = qq/aa
+        endif
+        compute_cubic = max((aa+bb)-a/3._r8,xmin) 
+        return
+    endif
+
+    return
+    end function compute_cubic
+
+END MODULE eddy_diff
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_cldwat.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_cldwat.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_cldwat.F	(revision 17)
@@ -0,0 +1,1696 @@
+#undef DEBUG
+#define WRF_PORT
+
+module cldwat
+!----------------------------------------------------------------------- 
+! 
+! Purpose: Prognostic cloud water data and methods.
+! 
+! Public interfaces:
+!
+! inimc -- Initialize constants
+! pcond -- Calculate prognostic condensate
+!
+! cldwat_fice   -- calculate fraction of condensate in ice phase (radiation partitioning)
+!
+! Author: P. Rasch, with Modifications by Minghua Zhang
+! January 2010, modified by J. Kay to add precip fluxes for COSP simulator
+! Ported to WRF by William.Gustafson@pnl.gov, Nov. 2009
+!    updated to CESM1_0_1, Nov. 2010
+!
+!-----------------------------------------------------------------------
+   use shr_kind_mod,  only: r8 => shr_kind_r8
+   use physconst,     only: tmelt
+#ifndef WRF_PORT
+   use spmd_utils,    only: masterproc
+   use ppgrid,        only: pcols, pver, pverp
+   use wv_saturation, only: estblf, hlatv, tmin, hlatf, rgasv, pcf, &
+                            cp, epsqs, ttrice
+   use abortutils,    only: endrun
+   use cam_logfile,   only: iulog
+#else
+   use module_cam_support, only: masterproc, &
+                                 pcols, pver, pverp, &
+                                 endrun, &
+                                 iulog
+#endif
+
+   implicit none
+
+!-----------------------------------------------------------------------
+! PUBLIC: Make default data and interfaces private
+!-----------------------------------------------------------------------
+   private
+   save
+#ifndef WRF_PORT
+   public inimc, pcond          ! Public interfaces
+#endif
+   public cldwat_fice          ! Public interfaces
+#ifndef WRF_PORT
+   public cldwat_readnl
+#endif
+   integer, public::  ktop      ! Level above 10 hPa
+
+#ifndef WRF_PORT
+   real(r8),public ::  icritc               ! threshold for autoconversion of cold ice
+   real(r8),public ::  icritw               ! threshold for autoconversion of warm ice
+!!$   real(r8),public,parameter::  conke  = 1.e-6    ! tunable constant for evaporation of precip
+!!$   real(r8),public,parameter::  conke  =  2.e-6    ! tunable constant for evaporation of precip
+   real(r8),public ::  conke                          ! tunable constant for evaporation of precip
+#else
+! Currently, the WRF_PORT bipasses the namelist initialization of these
+! tunable parameters. We are hard-coding them to the default values for
+! the fv 0.23x0.31 grid. One might choose to implement an option to set
+! these via the WRF Registry in the future.
+   real(r8),public :: icritw = 2.0e-4
+   real(r8),public :: icritc = 45.0e-6
+   real(r8),public :: conke  = 5.0e-6
+
+#endif
+
+!-----------------------------------------------------------------------
+! PRIVATE: Everything else is private to this module
+!-----------------------------------------------------------------------
+   real(r8), private, parameter :: tmax_fice = tmelt - 10._r8       ! max temperature for cloud ice formation
+!!$   real(r8), private, parameter :: tmax_fice = tmelt          ! max temperature for cloud ice formation
+!!$   real(r8), private, parameter :: tmin_fice = tmax_fice - 20.! min temperature for cloud ice formation
+   real(r8), private, parameter :: tmin_fice = tmax_fice - 30._r8   ! min temperature for cloud ice formation
+!  pjr
+   real(r8), private, parameter :: tmax_fsnow = tmelt            ! max temperature for transition to convective snow
+   real(r8), private, parameter :: tmin_fsnow = tmelt-5._r8         ! min temperature for transition to convective snow
+   real(r8), private:: rhonot   ! air density at surface
+   real(r8), private:: t0       ! Freezing temperature
+   real(r8), private:: cldmin   ! assumed minimum cloud amount
+   real(r8), private:: small    ! small number compared to unity
+   real(r8), private:: c        ! constant for graupel like snow cm**(1-d)/s
+   real(r8), private:: d        ! constant for graupel like snow
+   real(r8), private:: esi      ! collection efficient for ice by snow
+   real(r8), private:: esw      ! collection efficient for water by snow
+   real(r8), private:: nos      ! particles snow / cm**4
+   real(r8), private:: pi       ! Mathematical constant
+   real(r8), private:: gravit   ! Gravitational acceleration at surface
+   real(r8), private:: rh2o
+   real(r8), private:: prhonos
+   real(r8), private:: thrpd    ! numerical three added to d
+   real(r8), private:: gam3pd   ! gamma function on (3+d)
+   real(r8), private:: gam4pd   ! gamma function on (4+d)
+   real(r8), private:: rhoi     ! ice density
+   real(r8), private:: rhos     ! snow density
+   real(r8), private:: rhow     ! water density
+   real(r8), private:: mcon01   ! constants used in cloud microphysics
+   real(r8), private:: mcon02   ! constants used in cloud microphysics
+   real(r8), private:: mcon03   ! constants used in cloud microphysics
+   real(r8), private:: mcon04   ! constants used in cloud microphysics
+   real(r8), private:: mcon05   ! constants used in cloud microphysics
+   real(r8), private:: mcon06   ! constants used in cloud microphysics
+   real(r8), private:: mcon07   ! constants used in cloud microphysics
+   real(r8), private:: mcon08   ! constants used in cloud microphysics
+
+   integer, private ::  k1mb    ! index of the eta level near 1 mb
+
+! Parameters used in findmcnew
+   real(r8) :: r3lcrit              ! critical radius at which autoconversion become efficient
+   real(r8) :: capnsi               ! sea ice cloud particles / cm3
+   real(r8) :: capnc                ! cold and oceanic cloud particles / cm3
+   real(r8) :: capnw                ! warm continental cloud particles / cm3
+   real(r8) :: kconst               ! const for terminal velocity (stokes regime)
+   real(r8) :: effc                 ! collection efficiency
+   real(r8) :: alpha                ! ratio of 3rd moment radius to 2nd
+   real(r8) :: capc                 ! constant for autoconversion
+   real(r8) :: convfw               ! constant used for fall velocity calculation
+   real(r8) :: cracw                ! constant used for rain accreting water
+   real(r8) :: critpr               ! critical precip rate collection efficiency changes
+   real(r8) :: ciautb               ! coefficient of autoconversion of ice (1/s)
+
+#ifdef DEBUG
+   integer, private,parameter ::  nlook = 1  ! Number of points to examine
+   integer, private ::  ilook(nlook)         ! Longitude index to examine
+   integer, private ::  latlook(nlook)       ! Latitude index to examine
+   integer, private ::  lchnklook(nlook)     ! Chunk index to examine
+   integer, private ::  icollook(nlook)      ! Column index to examine
+#endif
+  ! Private data
+  real(r8), parameter :: unset_r8 = huge(1.0_r8)
+
+contains
+!===============================================================================
+  subroutine cldwat_readnl(nlfile)
+#ifndef WRF_PORT
+   use namelist_utils,  only: find_group_name
+   use units,           only: getunit, freeunit
+   use mpishorthand
+#endif
+
+   character(len=*), intent(in) :: nlfile  ! filepath for file containing namelist input
+#ifndef WRF_PORT
+
+
+
+   ! Namelist variables
+   real(r8) :: cldwat_icritw = unset_r8    !   icritw = threshold for autoconversion of warm ice  
+   real(r8) :: cldwat_icritc = unset_r8    !   icritc = threshold for autoconversion of cold ice  
+   real(r8) :: cldwat_conke  = unset_r8    !   conke  = tunable constant for evaporation of precip
+
+   ! Local variables
+   integer :: unitn, ierr
+   character(len=*), parameter :: subname = 'cldwat_readnl'
+
+   namelist /cldwat_nl/ cldwat_icritw, cldwat_icritc, cldwat_conke
+
+   !-----------------------------------------------------------------------------
+
+   if (masterproc) then
+      unitn = getunit()
+      open( unitn, file=trim(nlfile), status='old' )
+      call find_group_name(unitn, 'cldwat_nl', status=ierr)
+      if (ierr == 0) then
+         read(unitn, cldwat_nl, iostat=ierr)
+         if (ierr /= 0) then
+            call endrun(subname // ':: ERROR reading namelist')
+         end if
+      end if
+      close(unitn)
+      call freeunit(unitn)
+
+      ! set local variables
+      icritw = cldwat_icritw 
+      icritc = cldwat_icritc
+      conke  = cldwat_conke
+
+   end if
+
+
+
+#ifdef SPMD
+   ! Broadcast namelist variables
+   call mpibcast(icritw,            1, mpir8,  0, mpicom)
+   call mpibcast(icritc,            1, mpir8,  0, mpicom)
+   call mpibcast(conke,             1, mpir8,  0, mpicom)
+#endif
+
+!endif for WRF_PORT:
+#endif
+
+end subroutine cldwat_readnl
+
+!================================================================================================
+  subroutine cldwat_fice(ncol, t, fice, fsnow)
+!
+! Compute the fraction of the total cloud water which is in ice phase.
+! The fraction depends on temperature only. 
+! This is the form that was used for radiation, the code came from cldefr originally
+! 
+! Author: B. A. Boville Sept 10, 2002
+!  modified: PJR 3/13/03 (added fsnow to ascribe snow production for convection )
+!-----------------------------------------------------------------------
+    implicit none
+
+! Arguments
+    integer,  intent(in)  :: ncol                 ! number of active columns
+    real(r8), intent(in)  :: t(pcols,pver)        ! temperature
+
+    real(r8), intent(out) :: fice(pcols,pver)     ! Fractional ice content within cloud
+    real(r8), intent(out) :: fsnow(pcols,pver)    ! Fractional snow content for convection
+
+! Local variables
+    integer :: i,k                                   ! loop indexes
+
+!-----------------------------------------------------------------------
+
+! Define fractional amount of cloud that is ice
+    do k=1,pver
+       do i=1,ncol
+
+! If warmer than tmax then water phase
+          if (t(i,k) > tmax_fice) then
+             fice(i,k) = 0.0_r8
+
+! If colder than tmin then ice phase
+          else if (t(i,k) < tmin_fice) then
+             fice(i,k) = 1.0_r8
+
+! Otherwise mixed phase, with ice fraction decreasing linearly from tmin to tmax
+          else 
+             fice(i,k) =(tmax_fice - t(i,k)) / (tmax_fice - tmin_fice)
+          end if
+
+! snow fraction partitioning
+
+! If warmer than tmax then water phase
+          if (t(i,k) > tmax_fsnow) then
+             fsnow(i,k) = 0.0_r8
+
+! If colder than tmin then ice phase
+          else if (t(i,k) < tmin_fsnow) then
+             fsnow(i,k) = 1.0_r8
+
+! Otherwise mixed phase, with ice fraction decreasing linearly from tmin to tmax
+          else 
+             fsnow(i,k) =(tmax_fsnow - t(i,k)) / (tmax_fsnow - tmin_fsnow)
+          end if
+
+       end do
+    end do
+
+    return
+  end subroutine cldwat_fice
+
+#ifndef WRF_PORT
+subroutine inimc( tmeltx, rhonotx, gravitx, rh2ox)
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! initialize constants for the prognostic condensate
+! 
+! Author: P. Rasch, April 1997
+! 
+!-----------------------------------------------------------------------
+   use pmgrid, only: plev, plevp
+   use dycore, only: dycore_is, get_resolution
+   use hycoef, only: hypm
+
+   integer k
+   real(r8), intent(in) :: tmeltx
+   real(r8), intent(in) :: rhonotx
+   real(r8), intent(in) :: gravitx
+   real(r8), intent(in) :: rh2ox
+
+#ifdef UNICOSMP
+   real(r8) signgam              ! variable required by cray gamma function
+   external gamma
+#endif
+   rhonot = rhonotx          ! air density at surface (gm/cm3)
+   gravit = gravitx
+   rh2o   = rh2ox
+   rhos = .1_r8                 ! assumed snow density (gm/cm3)
+   rhow = 1._r8                 ! water density
+   rhoi = 1._r8                 ! ice density
+   esi = 1.0_r8                 ! collection efficient for ice by snow
+   esw = 0.1_r8                 ! collection efficient for water by snow
+   t0 = tmeltx               ! approximate freezing temp
+   cldmin = 0.02_r8             ! assumed minimum cloud amount
+   small = 1.e-22_r8            ! a small number compared to unity
+   c = 152.93_r8                ! constant for graupel like snow cm**(1-d)/s
+   d = 0.25_r8                  ! constant for graupel like snow
+   nos = 3.e-2_r8               ! particles snow / cm**4
+   pi = 4._r8*atan(1.0_r8)
+   prhonos = pi*rhos*nos
+   thrpd = 3._r8 + d
+   if (d==0.25_r8) then
+      gam3pd = 2.549256966718531_r8 ! only right for d = 0.25
+      gam4pd = 8.285085141835282_r8
+   else
+#ifdef UNICOSMP
+      call gamma(3._r8+d, signgam, gam3pd)
+      gam3pd = sign(exp(gam3pd),signgam)
+      call gamma(4._r8+d, signgam, gam4pd)
+      gam4pd = sign(exp(gam4pd),signgam)
+      write(iulog,*) ' d, gamma(3+d), gamma(4+d) =', gam3pd, gam4pd
+#else
+      write(iulog,*) ' can only use d ne 0.25 on a cray '
+      stop
+#endif
+   endif
+   mcon01 = pi*nos*c*gam3pd/4._r8
+   mcon02 = 1._r8/(c*gam4pd*sqrt(rhonot)/(6*prhonos**(d/4._r8)))
+   mcon03 = -(0.5_r8+d/4._r8)
+   mcon04 = 4._r8/(4._r8+d)
+   mcon05 = (3+d)/(4+d)
+   mcon06 = (3+d)/4._r8
+   mcon07 = mcon01*sqrt(rhonot)*mcon02**mcon05/prhonos**mcon06
+   mcon08 = -0.5_r8/(4._r8+d)
+
+!  find the level about 1mb, we wont do the microphysics above this level
+   k1mb = 1
+   do k=1,pver-1
+      if (hypm(k) < 1.e2_r8 .and. hypm(k+1) >= 1.e2_r8) then
+         if (1.e2_r8-hypm(k) < hypm(k+1)-1.e2_r8) then
+            k1mb = k
+         else
+            k1mb = k + 1
+         end if
+         goto 20
+      end if
+   end do
+   if (masterproc) then
+      write(iulog,*)'inimc: model levels bracketing 1 mb not found'
+   end if
+!  call endrun
+   k1mb = 1
+20 if( masterproc ) write(iulog,*)'inimc: model level nearest 1 mb is',k1mb,'which is',hypm(k1mb),'pascals'
+
+   if( masterproc ) write(iulog,*) 'cloud water initialization by inimc complete '
+
+! Initialize parameters used by findmcnew
+   capnw = 400._r8              ! warm continental cloud particles / cm3
+   capnc = 150._r8              ! cold and oceanic cloud particles / cm3
+!  capnsi = 40._r8              ! sea ice cloud particles density  / cm3
+   capnsi = 75._r8              ! sea ice cloud particles density  / cm3
+
+   kconst = 1.18e6_r8           ! const for terminal velocity
+
+!      effc = 1._r8                 ! autoconv collection efficiency following boucher 96
+!      effc = .55*0.05_r8           ! autoconv collection efficiency following baker 93
+   effc = 0.55_r8               ! autoconv collection efficiency following tripoli and cotton
+!   effc = 0._r8    ! turn off warm-cloud autoconv
+   alpha = 1.1_r8**4
+   capc = pi**(-.333_r8)*kconst*effc *(0.75_r8)**(1.333_r8)*alpha  ! constant for autoconversion
+
+   !r3lcrit: critical radius where liq conversion begins (10.0 micron)
+   r3lcrit = 10.0e-6_r8
+
+! critical precip rate at which we assume the collector drops can change the
+! drop size enough to enhance the auto-conversion process (mm/day)
+   critpr = 0.5_r8
+   convfw = 1.94_r8*2.13_r8*sqrt(rhow*1000._r8*9.81_r8*2.7e-4_r8)
+
+! liquid microphysics
+!      cracw = 6_r8                 ! beheng
+   cracw = .884_r8*sqrt(9.81_r8/(rhow*1000._r8*2.7e-4_r8)) ! tripoli and cotton
+
+! ice microphysics
+   ciautb = 5.e-4_r8
+
+    if ( masterproc ) then
+       write(iulog,*)'tuning parameters cldwat: icritw',icritw,'icritc',icritc,'conke',conke
+       write(iulog,*)'tuning parameters cldwat: capnw',capnw,'capnc',capnc,'capnsi',capnsi,'kconst',kconst
+       write(iulog,*)'tuning parameters cldwat: effc',effc,'alpha',alpha,'capc',capc,'r3lcrit',r3lcrit
+       write(iulog,*)'tuning parameters cldwat: critpr',critpr,'convfw',convfw,'cracw',cracw,'ciautb',ciautb
+    endif
+
+   return
+end subroutine inimc
+
+subroutine pcond (lchnk   ,ncol    , &
+                  tn      ,ttend   ,qn      ,qtend   ,omega   , &
+                  cwat    ,p       ,pdel    ,cldn    ,fice    , fsnow, &
+                  cme     ,prodprec,prodsnow,evapprec,evapsnow,evapheat, prfzheat, &     
+                  meltheat,precip  ,snowab  ,deltat  ,fwaut   , &
+                  fsaut   ,fracw   ,fsacw   ,fsaci   ,lctend  , &
+                  rhdfda  ,rhu00   ,seaicef, zi      ,ice2pr, liq2pr, &
+                  liq2snow, snowh, rkflxprc, rkflxsnw)  
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! The public interface to the cloud water parameterization
+! returns tendencies to water vapor, temperature and cloud water variables
+! 
+! For basic method 
+!  See: Rasch, P. J, and J. E. Kristjansson, A Comparison of the CCM3
+!  model climate using diagnosed and 
+!  predicted condensate parameterizations, 1998, J. Clim., 11,
+!  pp1587---1614.
+! 
+! For important modifications to improve the method of determining
+! condensation/evaporation see Zhang et al (2001, in preparation)
+!
+! Authors: M. Zhang, W. Lin, P. Rasch and J.E. Kristjansson
+!          B. A. Boville (latent heat of fusion)
+!-----------------------------------------------------------------------
+   use wv_saturation, only: vqsatd
+   use cam_control_mod, only: nlvdry
+!
+!---------------------------------------------------------------------
+!
+! Input Arguments
+!
+   integer, intent(in) :: lchnk                 ! chunk identifier
+   integer, intent(in) :: ncol                  ! number of atmospheric columns
+
+   real(r8), intent(in) :: fice(pcols,pver)     ! fraction of cwat that is ice
+   real(r8), intent(in) :: fsnow(pcols,pver)    ! fraction of rain that freezes to snow
+   real(r8), intent(in) :: cldn(pcols,pver)     ! new value of cloud fraction    (fraction)
+   real(r8), intent(in) :: cwat(pcols,pver)     ! cloud water (kg/kg)
+   real(r8), intent(in) :: omega(pcols,pver)    ! vert pressure vel (Pa/s)
+   real(r8), intent(in) :: p(pcols,pver)        ! pressure          (K)
+   real(r8), intent(in) :: pdel(pcols,pver)     ! pressure thickness (Pa)
+   real(r8), intent(in) :: qn(pcols,pver)       ! new water vapor    (kg/kg)
+   real(r8), intent(in) :: qtend(pcols,pver)    ! mixing ratio tend  (kg/kg/s)
+   real(r8), intent(in) :: tn(pcols,pver)       ! new temperature    (K)
+   real(r8), intent(in) :: ttend(pcols,pver)    ! temp tendencies    (K/s)
+   real(r8), intent(in) :: deltat               ! time step to advance solution over
+   real(r8), intent(in) :: lctend(pcols,pver)   ! cloud liquid water tendencies   ====wlin
+   real(r8), intent(in) :: rhdfda(pcols,pver)   ! dG(a)/da, rh=G(a), when rh>u00  ====wlin
+   real(r8), intent(in) :: rhu00 (pcols,pver)   ! Rhlim for cloud                 ====wlin
+   real(r8), intent(in) :: seaicef(pcols)       ! sea ice fraction  (fraction)
+   real(r8), intent(in) :: zi(pcols,pverp)      ! layer interfaces (m)
+    real(r8), intent(in) :: snowh(pcols)         ! Snow depth over land, water equivalent (m)
+!
+! Output Arguments
+!
+   real(r8), intent(out) :: cme     (pcols,pver) ! rate of cond-evap of condensate (1/s)
+   real(r8), intent(out) :: prodprec(pcols,pver) ! rate of conversion of condensate to precip (1/s)
+   real(r8), intent(out) :: evapprec(pcols,pver) ! rate of evaporation of falling precip (1/s)
+   real(r8), intent(out) :: evapsnow(pcols,pver) ! rate of evaporation of falling snow (1/s)
+   real(r8), intent(out) :: evapheat(pcols,pver) ! heating rate due to evaporation of precip (W/kg)
+   real(r8), intent(out) :: prfzheat(pcols,pver) ! heating rate due to freezing of precip (W/kg)
+   real(r8), intent(out) :: meltheat(pcols,pver) ! heating rate due to snow melt (W/kg)
+   real(r8), intent(out) :: precip(pcols)        ! rate of precipitation (kg / (m**2 * s))
+   real(r8), intent(out) :: snowab(pcols)        ! rate of snow (kg / (m**2 * s))
+   real(r8), intent(out) :: ice2pr(pcols,pver)   ! rate of conversion of ice to precip
+   real(r8), intent(out) :: liq2pr(pcols,pver)   ! rate of conversion of liquid to precip
+   real(r8), intent(out) :: liq2snow(pcols,pver) ! rate of conversion of liquid to snow
+   real(r8), intent(out) :: rkflxprc(pcols,pverp)   ! grid-box mean RK flux_large_scale_cloud_rain at interfaces (kg m^-2 s^-1)
+   real(r8), intent(out) :: rkflxsnw(pcols,pverp)   ! grid-box mean RK flux_large_scale_cloud_snow at interfaces (kg m^-2 s^-1)
+
+   real(r8) nice2pr     ! rate of conversion of ice to snow
+   real(r8) nliq2pr     ! rate of conversion of liquid to precip
+   real(r8) nliq2snow   ! rate of conversion of liquid to snow
+   real(r8) prodsnow(pcols,pver) ! rate of production of snow
+
+!
+! Local workspace
+!
+   real(r8) :: precab(pcols)        ! rate of precipitation (kg / (m**2 * s))
+   integer i                 ! work variable
+   integer iter              ! #iterations for precipitation calculation
+   integer k                 ! work variable
+   integer l                 ! work variable
+
+   real(r8) cldm(pcols)          ! mean cloud fraction over the time step
+   real(r8) cldmax(pcols)        ! max cloud fraction above
+   real(r8) coef(pcols)          ! conversion time scale for condensate to rain
+   real(r8) cwm(pcols)           ! cwat mixing ratio at midpoint of time step
+   real(r8) cwn(pcols)           ! cwat mixing ratio at end
+   real(r8) denom                ! work variable
+   real(r8) dqsdt                ! change in sat spec. hum. wrt temperature
+   real(r8) es(pcols)            ! sat. vapor pressure
+   real(r8) fracw(pcols,pver)    ! relative importance of collection of liquid by rain
+   real(r8) fsaci(pcols,pver)    ! relative importance of collection of ice by snow
+   real(r8) fsacw(pcols,pver)    ! relative importance of collection of liquid by snow
+   real(r8) fsaut(pcols,pver)    ! relative importance of ice auto conversion
+   real(r8) fwaut(pcols,pver)    ! relative importance of warm cloud autoconversion
+   real(r8) gamma(pcols)         ! d qs / dT
+   real(r8) icwc(pcols)          ! in-cloud water content (kg/kg)
+   real(r8) mincld               ! a small cloud fraction to avoid / zero
+   real(r8) omeps                ! 1 minus epsilon
+   real(r8),parameter ::omsm=0.99999_r8                 ! a number just less than unity (for rounding)
+   real(r8) prprov(pcols)        ! provisional value of precip at btm of layer
+   real(r8) prtmp                ! work variable
+   real(r8) q(pcols,pver)        ! mixing ratio before time step ignoring condensate
+   real(r8) qs(pcols)            ! spec. hum. of water vapor
+   real(r8) qsn, esn             ! work variable
+   real(r8) qsp(pcols,pver)      ! sat pt mixing ratio
+   real(r8) qtl(pcols)           ! tendency which would saturate the grid box in deltat
+   real(r8) qtmp, ttmp           ! work variable
+   real(r8) relhum1(pcols)        ! relative humidity
+   real(r8) relhum(pcols)        ! relative humidity
+!!$   real(r8) tc                   ! crit temp of transition to ice
+   real(r8) t(pcols,pver)        ! temp before time step ignoring condensate
+   real(r8) tsp(pcols,pver)      ! sat pt temperature
+   real(r8) pol                  ! work variable
+   real(r8) cdt                  ! work variable
+   real(r8) wtthick              ! work variable
+
+! Extra local work space for cloud scheme modification       
+
+   real(r8) cpohl                !Cp/Hlatv
+   real(r8) hlocp                !Hlatv/Cp
+   real(r8) dto2                 !0.5*deltat (delta=2.0*dt)
+   real(r8) calpha(pcols)        !alpha of new C - E scheme formulation
+   real(r8) cbeta (pcols)        !beta  of new C - E scheme formulation
+   real(r8) cbetah(pcols)        !beta_hat at saturation portion 
+   real(r8) cgamma(pcols)        !gamma of new C - E scheme formulation
+   real(r8) cgamah(pcols)        !gamma_hat at saturation portion
+   real(r8) rcgama(pcols)        !gamma/gamma_hat
+   real(r8) csigma(pcols)        !sigma of new C - E scheme formulation
+   real(r8) cmec1 (pcols)        !c1    of new C - E scheme formulation
+   real(r8) cmec2 (pcols)        !c2    of new C - E scheme formulation
+   real(r8) cmec3 (pcols)        !c3    of new C - E scheme formulation
+   real(r8) cmec4 (pcols)        !c4    of new C - E scheme formulation
+   real(r8) cmeres(pcols)        !residual cond of over-sat after cme and evapprec
+   real(r8) ctmp                 !a scalar representation of cmeres
+   real(r8) clrh2o               ! Ratio of latvap to water vapor gas const
+   real(r8) ice(pcols,pver)    ! ice mixing ratio
+   real(r8) liq(pcols,pver)    ! liquid mixing ratio
+   real(r8) rcwn(pcols,2,pver), rliq(pcols,2,pver), rice(pcols,2,pver)
+   real(r8) cwnsave(pcols,2,pver), cmesave(pcols,2,pver)
+   real(r8) prodprecsave(pcols,2,pver)
+   logical error_found
+!
+!------------------------------------------------------------
+!
+   clrh2o = hlatv/rh2o   ! Ratio of latvap to water vapor gas const
+   omeps = 1.0_r8 - epsqs
+#ifdef PERGRO
+   mincld = 1.e-4_r8
+   iter = 1   ! number of times to iterate the precipitation calculation
+#else
+   mincld = 1.e-4_r8
+   iter = 2
+#endif
+!   omsm = 0.99999
+   cpohl = cp/hlatv
+   hlocp = hlatv/cp
+   dto2=0.5_r8*deltat
+!
+! Constant for computing rate of evaporation of precipitation:
+!
+!!$   conke = 1.e-5
+!!$   conke = 1.e-6
+!
+! initialize a few single level fields
+!
+   do i = 1,ncol
+      precip(i) = 0.0_r8
+      precab(i) = 0.0_r8
+      snowab(i) = 0.0_r8
+      cldmax(i) = 0.0_r8
+   end do
+!
+! initialize multi-level fields 
+!
+   do k = 1,pver
+      do i = 1,ncol
+         q(i,k) = qn(i,k) 
+         t(i,k) = tn(i,k)
+!         q(i,k)=qn(i,k)-qtend(i,k)*deltat
+!         t(i,k)=tn(i,k)-ttend(i,k)*deltat
+    end do
+   end do
+   cme     (:ncol,:) = 0._r8
+   evapprec(:ncol,:) = 0._r8
+   prodprec(:ncol,:) = 0._r8
+   evapsnow(:ncol,:) = 0._r8
+   prodsnow(:ncol,:) = 0._r8
+   evapheat(:ncol,:) = 0._r8
+   meltheat(:ncol,:) = 0._r8
+   prfzheat(:ncol,:) = 0._r8
+   ice2pr(:ncol,:)   = 0._r8
+   liq2pr(:ncol,:)   = 0._r8
+   liq2snow(:ncol,:) = 0._r8
+   fwaut(:ncol,:) = 0._r8
+   fsaut(:ncol,:) = 0._r8
+   fracw(:ncol,:) = 0._r8
+   fsacw(:ncol,:) = 0._r8
+   fsaci(:ncol,:) = 0._r8
+   rkflxprc(:ncol,:) = 0._r8
+   rkflxsnw(:ncol,:) = 0._r8
+
+!
+! find the wet bulb temp and saturation value
+! for the provisional t and q without condensation
+!
+   call findsp (lchnk, ncol, qn, tn, p, tsp, qsp)
+   do 800 k = k1mb,pver
+      call vqsatd (t(1,k), p(1,k), es, qs, gamma, ncol)
+      do i = 1,ncol
+         relhum(i) = q(i,k)/qs(i)
+!
+         cldm(i) = max(cldn(i,k),mincld)
+!
+! the max cloud fraction above this level
+!
+         cldmax(i) = max(cldmax(i), cldm(i))
+
+! define the coefficients for C - E calculation
+
+         calpha(i) = 1.0_r8/qs(i)
+         cbeta (i) = q(i,k)/qs(i)**2*gamma(i)*cpohl
+         cbetah(i) = 1.0_r8/qs(i)*gamma(i)*cpohl
+         cgamma(i) = calpha(i)+hlatv*cbeta(i)/cp
+         cgamah(i) = calpha(i)+hlatv*cbetah(i)/cp
+         rcgama(i) = cgamma(i)/cgamah(i)
+
+         if(cldm(i) > mincld) then
+            icwc(i) = max(0._r8,cwat(i,k)/cldm(i))
+         else
+            icwc(i) = 0.0_r8
+         endif
+!PJR the above logic give zero icwc with nonzero cwat, dont like it!
+!PJR generates problems with csigma
+!PJR set the icwc to a very small number, so we can start from zero cloud cover and make some clouds
+!         icwc(i) = max(1.e-8_r8,cwat(i,k)/cldm(i))
+
+!
+! initial guess of evaporation, will be updated within iteration
+!
+         evapprec(i,k) = conke*(1._r8 - cldm(i))*sqrt(precab(i)) &
+                        *(1._r8 - min(relhum(i),1._r8))
+
+!
+! zero cmeres before iteration for each level
+!
+         cmeres(i)=0.0_r8
+
+      end do
+      do i = 1,ncol
+!
+! fractions of ice at this level
+!
+!!$         tc = t(i,k) - t0
+!!$         fice(i,k) = max(0._r8,min(-tc*0.05,1.0_r8))
+!
+! calculate the cooling due to a phase change of the rainwater
+! from above
+!
+         if (t(i,k) >= t0) then
+            meltheat(i,k) =  -hlatf * snowab(i) * gravit/pdel(i,k)
+            snowab(i) = 0._r8
+         else
+            meltheat(i,k) = 0._r8
+         endif
+      end do
+
+!
+! calculate cme and formation of precip. 
+!
+! The cloud microphysics is highly nonlinear and coupled with cme
+! Both rain processes and cme are calculated iteratively.
+! 
+      do 100 l = 1,iter
+
+        do i = 1,ncol
+
+!
+! calculation of cme has 4 scenarios
+! ==================================
+!
+           if(relhum(i) > rhu00(i,k)) then
+    
+           ! 1. whole grid saturation
+           ! ========================
+              if(relhum(i) >= 0.999_r8 .or. cldm(i) >= 0.999_r8 ) then
+                 cme(i,k)=(calpha(i)*qtend(i,k)-cbetah(i)*ttend(i,k))/cgamah(i)
+
+           ! 2. fractional saturation
+           ! ========================
+              else
+                 if (rhdfda(i,k) .eq. 0. .and. icwc(i).eq.0.) then
+                    write (iulog,*) ' cldwat.F90:  empty rh cloud ', i, k, lchnk
+                    write (iulog,*) ' relhum, iter ', relhum(i), l, rhu00(i,k), cldm(i), cldn(i,k)
+                    call endrun ()
+                 endif
+                  csigma(i) = 1.0_r8/(rhdfda(i,k)+cgamma(i)*icwc(i))
+                  cmec1(i) = (1.0_r8-cldm(i))*csigma(i)*rhdfda(i,k)
+                  cmec2(i) = cldm(i)*calpha(i)/cgamah(i)+(1.0_r8-rcgama(i)*cldm(i))*   &
+                             csigma(i)*calpha(i)*icwc(i)
+                  cmec3(i) = cldm(i)*cbetah(i)/cgamah(i) +  &
+                           (cbeta(i)-rcgama(i)*cldm(i)*cbetah(i))*csigma(i)*icwc(i)
+                  cmec4(i) = csigma(i)*cgamma(i)*icwc(i)
+
+                  ! Q=C-E=-C1*Al + C2*Aq - C3* At + C4*Er
+  
+                  cme(i,k) = -cmec1(i)*lctend(i,k) + cmec2(i)*qtend(i,k)  &
+                             -cmec3(i)*ttend(i,k) + cmec4(i)*evapprec(i,k)
+               endif
+
+           ! 3. when rh < rhu00, evaporate existing cloud water
+           ! ================================================== 
+           else if(cwat(i,k) > 0.0_r8)then
+              ! liquid water should be evaporated but not to exceed 
+              ! saturation point. if qn > qsp, not to evaporate cwat
+              cme(i,k)=-min(max(0._r8,qsp(i,k)-qn(i,k)),cwat(i,k))/deltat 
+
+           ! 4. no condensation nor evaporation
+           ! ==================================
+           else
+              cme(i,k)=0.0_r8
+           endif
+
+  
+        end do    !end loop for cme update
+
+! Because of the finite time step, 
+! place a bound here not to exceed wet bulb point
+! and not to evaporate more than available water
+!
+         do i = 1, ncol
+            qtmp = qn(i,k) - cme(i,k)*deltat
+
+! possibilities to have qtmp > qsp
+!
+!   1. if qn > qs(tn), it condenses; 
+!      if after applying cme,  qtmp > qsp,  more condensation is applied. 
+!      
+!   2. if qn < qs, evaporation should not exceed qsp,
+    
+            if(qtmp > qsp(i,k)) then
+              cme(i,k) = cme(i,k) + (qtmp-qsp(i,k))/deltat
+            endif
+
+!
+! if net evaporation, it should not exceed available cwat
+!
+            if(cme(i,k) < -cwat(i,k)/deltat)  &
+               cme(i,k) = -cwat(i,k)/deltat
+!
+! addition of residual condensation from previous step of iteration
+!
+            cme(i,k) = cme(i,k) + cmeres(i)
+
+         end do
+
+         !      limit cme for roundoff errors
+         do i = 1, ncol
+            cme(i,k) = cme(i,k)*omsm
+         end do
+
+         do i = 1,ncol
+!
+! as a safe limit, condensation should not reduce grid mean rh below rhu00
+! 
+           if(cme(i,k) > 0.0_r8 .and. relhum(i) > rhu00(i,k) )  &
+              cme(i,k) = min(cme(i,k), (qn(i,k)-qs(i)*rhu00(i,k))/deltat)
+!
+! initial guess for cwm (mean cloud water over time step) if 1st iteration
+!
+           if(l < 2) then
+             cwm(i) = max(cwat(i,k)+cme(i,k)*dto2,  0._r8)
+           endif
+
+         enddo
+
+! provisional precipitation falling through model layer
+         do i = 1,ncol
+!!$            prprov(i) =  precab(i) + prodprec(i,k)*pdel(i,k)/gravit
+! rain produced in this layer not too effective in collection process
+            wtthick = max(0._r8,min(0.5_r8,((zi(i,k)-zi(i,k+1))/1000._r8)**2))
+            prprov(i) =  precab(i) + wtthick*prodprec(i,k)*pdel(i,k)/gravit
+         end do
+
+! calculate conversion of condensate to precipitation by cloud microphysics 
+         call findmcnew (lchnk   ,ncol    , &
+                         k       ,prprov  ,snowab,  t       ,p        , &
+                         cwm     ,cldm    ,cldmax  ,fice(1,k),coef    , &
+                         fwaut(1,k),fsaut(1,k),fracw(1,k),fsacw(1,k),fsaci(1,k), &
+                         seaicef, snowh)
+!
+! calculate the precip rate
+!
+         error_found = .false.
+         do i = 1,ncol
+            if (cldm(i) > 0) then  
+!
+! first predict the cloud water
+!
+               cdt = coef(i)*deltat
+               if (cdt > 0.01_r8) then
+                  pol = cme(i,k)/coef(i) ! production over loss
+                  cwn(i) = max(0._r8,(cwat(i,k)-pol)*exp(-cdt)+ pol)
+               else
+                  cwn(i) = max(0._r8,(cwat(i,k) + cme(i,k)*deltat)/(1+cdt))
+               endif
+!
+! now back out the tendency of net rain production
+!
+               prodprec(i,k) =  max(0._r8,cme(i,k)-(cwn(i)-cwat(i,k))/deltat)
+            else
+               prodprec(i,k) = 0.0_r8
+               cwn(i) = 0._r8
+            endif
+
+            ! provisional calculation of conversion terms
+            ice2pr(i,k) = prodprec(i,k)*(fsaut(i,k)+fsaci(i,k))
+            liq2pr(i,k) = prodprec(i,k)*(fwaut(i,k)+fsacw(i,k)+fracw(i,k))
+!old        liq2snow(i,k) = prodprec(i,k)*fsacw(i,k)
+
+!           revision suggested by Jim McCaa
+!           it controls the amount of snow hitting the sfc 
+!           by forcing a lot of conversion of cloud liquid to snow phase
+!           it might be better done later by an explicit representation of 
+!           rain accreting ice (and freezing), or by an explicit freezing of raindrops
+            liq2snow(i,k) = max(prodprec(i,k)*fsacw(i,k), fsnow(i,k)*liq2pr(i,k))
+
+            ! bounds
+            nice2pr = min(ice2pr(i,k),(cwat(i,k)+cme(i,k)*deltat)*fice(i,k)/deltat)
+            nliq2pr = min(liq2pr(i,k),(cwat(i,k)+cme(i,k)*deltat)*(1._r8-fice(i,k))/deltat)
+!            write(iulog,*) ' prodprec ', i, k, prodprec(i,k)
+!            write(iulog,*) ' nliq2pr, nice2pr ', nliq2pr, nice2pr
+            if (liq2pr(i,k).ne.0._r8) then
+               nliq2snow = liq2snow(i,k)*nliq2pr/liq2pr(i,k)   ! correction
+            else
+               nliq2snow = liq2snow(i,k)
+            endif
+
+!           avoid roundoff problems generating negatives
+            nliq2snow = nliq2snow*omsm
+            nliq2pr = nliq2pr*omsm
+            nice2pr = nice2pr*omsm
+            
+!           final estimates of conversion to precip and snow
+            prodprec(i,k) = (nliq2pr + nice2pr)
+            prodsnow(i,k) = (nice2pr + nliq2snow)
+
+            rcwn(i,l,k) =  cwat(i,k) + (cme(i,k)-   prodprec(i,k))*deltat
+            rliq(i,l,k) = (cwat(i,k) + cme(i,k)*deltat)*(1._r8-fice(i,k)) - nliq2pr * deltat
+            rice(i,l,k) = (cwat(i,k) + cme(i,k)*deltat)* fice(i,k)      -    nice2pr                     *deltat
+
+!           Save for sanity check later...  
+!           Putting sanity checks inside loops 100 and 800 screws up the 
+!           IBM compiler for reasons as yet unknown.  TBH
+            cwnsave(i,l,k)      = cwn(i)
+            cmesave(i,l,k)      = cme(i,k)
+            prodprecsave(i,l,k) = prodprec(i,k)
+!           End of save for sanity check later...  
+
+!           final version of condensate to precip terms
+            liq2pr(i,k) = nliq2pr
+            liq2snow(i,k) = nliq2snow
+            ice2pr(i,k) = nice2pr
+
+            cwn(i) = rcwn(i,l,k)
+!
+! update any remaining  provisional values
+!
+            cwm(i) = (cwn(i) + cwat(i,k))*0.5_r8
+!
+! update in cloud water
+!
+            if(cldm(i) > mincld) then
+               icwc(i) = cwm(i)/cldm(i)
+            else
+               icwc(i) = 0.0_r8
+            endif
+!PJR the above logic give zero icwc with nonzero cwat, dont like it!
+!PJR generates problems with csigma
+!PJR set the icwc to a very small number, so we can start from zero cloud cover and make some clouds
+!         icwc(i) = max(1.e-8_r8,cwm(i)/cldm(i))
+
+         end do              ! end of do i = 1,ncol
+
+!
+! calculate provisional value of cloud water for
+! evaporation of precipitate (evapprec) calculation
+!
+      do i = 1,ncol
+         qtmp = qn(i,k) - cme(i,k)*deltat
+         ttmp = tn(i,k) + deltat/cp * ( meltheat(i,k)       &
+              + (hlatv + hlatf*fice(i,k)) * cme(i,k) )
+         esn = estblf(ttmp)
+         qsn = min(epsqs*esn/(p(i,k) - omeps*esn),1._r8)
+         qtl(i) = max((qsn - qtmp)/deltat,0._r8)
+         relhum1(i) = qtmp/qsn
+      end do
+!
+      do i = 1,ncol
+#ifdef PERGRO
+         evapprec(i,k) = conke*(1._r8 - max(cldm(i),mincld))* &
+                         sqrt(precab(i))*(1._r8 - min(relhum1(i),1._r8))
+#else
+         evapprec(i,k) = conke*(1._r8 - cldm(i))*sqrt(precab(i)) &
+                         *(1._r8 - min(relhum1(i),1._r8))
+#endif
+!
+! limit the evaporation to the amount which is entering the box
+! or saturates the box
+!
+         prtmp = precab(i)*gravit/pdel(i,k)
+         evapprec(i,k) = min(evapprec(i,k), prtmp, qtl(i))*omsm
+#ifdef PERGRO
+!           zeroing needed for pert growth
+         evapprec(i,k) = 0._r8
+#endif
+!
+! Partition evaporation of precipitate between rain and snow using
+! the fraction of snow falling into the box. Determine the heating
+! due to evaporation. Note that evaporation is positive (loss of precip,
+! gain of vapor) and that heating is negative.
+         if (evapprec(i,k) > 0._r8) then
+            evapsnow(i,k) = evapprec(i,k) * snowab(i) / precab(i)
+            evapheat(i,k) = -hlatv * evapprec(i,k) - hlatf * evapsnow(i,k)
+         else 
+            evapsnow(i,k) = 0._r8
+            evapheat(i,k) = 0._r8
+         end if
+! Account for the latent heat of fusion for liquid drops collected by falling snow
+         prfzheat(i,k) = hlatf * liq2snow(i,k)
+      end do
+
+! now remove the residual of any over-saturation. Normally,
+! the oversaturated water vapor should have been removed by 
+! cme formulation plus constraints by wet bulb tsp/qsp
+! as computed above. However, because of non-linearity,
+! addition of (cme-evapprec) to update t and q may still cause
+! a very small amount of over saturation. It is called a
+! residual of over-saturation because theoretically, cme
+! should have taken care of all of large scale condensation.
+! 
+
+       do i = 1,ncol
+          qtmp = qn(i,k)-(cme(i,k)-evapprec(i,k))*deltat
+          ttmp = tn(i,k) + deltat/cp * ( meltheat(i,k) + evapheat(i,k) + prfzheat(i,k)      &
+              + (hlatv + hlatf*fice(i,k)) * cme(i,k) )
+          esn = estblf(ttmp)
+          qsn = min(epsqs*esn/(p(i,k) - omeps*esn),1._r8)
+          !
+          !Upper stratosphere and mesosphere, qsn calculated
+          !above may be negative. Here just to skip it instead
+          !of resetting it to 1 as in aqsat
+          !
+          if(qtmp > qsn .and. qsn > 0) then
+             !calculate dqsdt, a more precise calculation
+             !which taking into account different range of T 
+             !can be found in aqsatd.F. Here follows
+             !cond.F to calculate it.
+             !
+             denom = (p(i,k)-omeps*esn)*ttmp*ttmp
+             dqsdt = clrh2o*qsn*p(i,k)/denom
+             !
+             !now extra condensation to bring air to just saturation
+             !
+             ctmp = (qtmp-qsn)/(1._r8+hlocp*dqsdt)/deltat
+             cme(i,k) = cme(i,k)+ctmp
+!
+! save residual on cmeres to addtion to cme on entering next iteration
+! cme exit here contain the residual but overrided if back to iteration
+!
+             cmeres(i) = ctmp
+          else
+             cmeres(i) = 0.0_r8
+          endif
+       end do
+              
+ 100 continue              ! end of do l = 1,iter
+
+!
+! precipitation
+!
+      do i = 1,ncol
+         precip(i) = precip(i) + pdel(i,k)/gravit * (prodprec(i,k) - evapprec(i,k))
+         precab(i) = precab(i) + pdel(i,k)/gravit * (prodprec(i,k) - evapprec(i,k))
+         if(precab(i).lt.0._r8) precab(i)=0._r8
+!         snowab(i) = snowab(i) + pdel(i,k)/gravit * (prodprec(i,k)*fice(i,k) - evapsnow(i,k))
+         snowab(i) = snowab(i) + pdel(i,k)/gravit * (prodsnow(i,k) - evapsnow(i,k))
+
+         ! If temperature above freezing, all precip is rain flux.  if temperature below freezing, all precip is snow flux.
+         rkflxprc(i,k+1) = precab(i) - snowab(i)
+         rkflxsnw(i,k+1) = snowab(i)
+
+!!$         if ((precab(i)) < 1.e-10) then      
+!!$            precab(i) = 0.
+!!$            snowab(i) = 0.
+!!$         endif
+      end do
+ 800 continue                ! level loop (k=1,pver)
+
+! begin sanity checks
+   error_found = .false.
+   do k = k1mb,pver
+      do l = 1,iter
+         do i = 1,ncol
+	    if (abs(rcwn(i,l,k)).lt.1.e-300_r8) rcwn(i,l,k) = 0._r8
+	    if (abs(rliq(i,l,k)).lt.1.e-300_r8) rliq(i,l,k) = 0._r8
+	    if (abs(rice(i,l,k)).lt.1.e-300_r8) rice(i,l,k) = 0._r8
+            if (rcwn(i,l,k).lt.0._r8) error_found = .true.
+            if (rliq(i,l,k).lt.0._r8) error_found = .true.
+            if (rice(i,l,k).lt.0._r8) error_found = .true.
+         enddo
+      enddo
+   enddo
+   if (error_found) then
+      do k = k1mb,pver
+         do l = 1,iter
+            do i = 1,ncol
+               if (rcwn(i,l,k).lt.0._r8) then
+                  write(iulog,*) ' prob with neg rcwn1 ', rcwn(i,l,k),  &
+                     cwnsave(i,l,k)
+                  write(iulog,*) ' cwat, cme*deltat, prodprec*deltat ', &
+                     cwat(i,k), cmesave(i,l,k)*deltat,               &
+                     prodprecsave(i,l,k)*deltat,                     &
+                     (cmesave(i,l,k)-prodprecsave(i,l,k))*deltat
+                  call endrun('PCOND')
+               endif
+               if (rliq(i,l,k).lt.0._r8) then
+                  write(iulog,*) ' prob with neg rliq1 ', rliq(i,l,k)
+                  call endrun('PCOND')
+               endif
+               if (rice(i,l,k).lt.0._r8) then
+                  write(iulog,*) ' prob with neg rice ', rice(i,l,k)
+                  call endrun('PCOND')
+               endif
+            enddo
+         enddo
+      enddo
+   end if
+! end sanity checks
+
+   return
+end subroutine pcond
+
+!##############################################################################
+
+subroutine findmcnew (lchnk   ,ncol    , &
+                      k       ,precab  ,snowab,  t       ,p       , &
+                      cwm     ,cldm    ,cldmax  ,fice    ,coef    , &
+                      fwaut   ,fsaut   ,fracw   ,fsacw   ,fsaci   , &
+                      seaicef ,snowh   )
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! calculate the conversion of condensate to precipitate
+! 
+! Method: 
+! See: Rasch, P. J, and J. E. Kristjansson, A Comparison of the CCM3
+!  model climate using diagnosed and 
+!  predicted condensate parameterizations, 1998, J. Clim., 11,
+!  pp1587---1614.
+! 
+! Author: P. Rasch
+! 
+!-----------------------------------------------------------------------
+   use phys_grid, only: get_rlat_all_p
+   use comsrf,        only: landm
+!
+! input args
+!
+   integer, intent(in) :: lchnk                 ! chunk identifier
+   integer, intent(in) :: ncol                  ! number of atmospheric columns
+   integer, intent(in) :: k                     ! level index
+
+   real(r8), intent(in) :: precab(pcols)        ! rate of precipitation from above (kg / (m**2 * s))
+   real(r8), intent(in) :: t(pcols,pver)        ! temperature       (K)
+   real(r8), intent(in) :: p(pcols,pver)        ! pressure          (Pa)
+   real(r8), intent(in) :: cldm(pcols)          ! cloud fraction
+   real(r8), intent(in) :: cldmax(pcols)        ! max cloud fraction above this level
+   real(r8), intent(in) :: cwm(pcols)           ! condensate mixing ratio (kg/kg)
+   real(r8), intent(in) :: fice(pcols)          ! fraction of cwat that is ice
+   real(r8), intent(in) :: seaicef(pcols)       ! sea ice fraction 
+   real(r8), intent(in) :: snowab(pcols)        ! rate of snow from above (kg / (m**2 * s))
+    real(r8), intent(in) :: snowh(pcols)         ! Snow depth over land, water equivalent (m)
+
+! output arguments
+   real(r8), intent(out) :: coef(pcols)          ! conversion rate (1/s)
+   real(r8), intent(out) :: fwaut(pcols)         ! relative importance of liquid autoconversion (a diagnostic)
+   real(r8), intent(out) :: fsaut(pcols)         ! relative importance of ice autoconversion    (a diagnostic)
+   real(r8), intent(out) :: fracw(pcols)         ! relative importance of rain accreting liquid (a diagnostic)
+   real(r8), intent(out) :: fsacw(pcols)         ! relative importance of snow accreting liquid (a diagnostic)
+   real(r8), intent(out) :: fsaci(pcols)         ! relative importance of snow accreting ice    (a diagnostic)
+
+! work variables
+
+   integer i
+   integer ii
+   integer ind(pcols)
+   integer ncols
+
+   real(r8), parameter :: degrad = 57.296_r8 ! divide by this to convert degrees to radians
+   real(r8) capn                 ! local cloud particles / cm3
+   real(r8) capnoice             ! local cloud particles when not over sea ice / cm3
+   real(r8) ciaut                ! coefficient of autoconversion of ice (1/s)
+   real(r8) cldloc(pcols)        ! non-zero amount of cloud
+   real(r8) cldpr(pcols)         ! assumed cloudy volume occupied by rain and cloud
+   real(r8) con1                 ! work constant
+   real(r8) con2                 ! work constant
+   real(r8) csacx                ! constant used for snow accreting liquid or ice
+!!$   real(r8) dtice                ! interval for transition from liquid to ice
+   real(r8) icemr(pcols)         ! in-cloud ice mixing ratio
+   real(r8) icrit                ! threshold for autoconversion of ice
+   real(r8) liqmr(pcols)         ! in-cloud liquid water mixing ratio
+   real(r8) pracw                ! rate of rain accreting water
+   real(r8) prlloc(pcols)        ! local rain flux in mm/day
+   real(r8) prscgs(pcols)        ! local snow amount in cgs units
+   real(r8) psaci                ! rate of collection of ice by snow (lin et al 1983)
+   real(r8) psacw                ! rate of collection of liquid by snow (lin et al 1983)
+   real(r8) psaut                ! rate of autoconversion of ice condensate
+   real(r8) ptot                 ! total rate of conversion
+   real(r8) pwaut                ! rate of autoconversion of liquid condensate
+   real(r8) r3l                  ! volume radius
+   real(r8) rainmr(pcols)        ! in-cloud rain mixing ratio
+   real(r8) rat1                 ! work constant
+   real(r8) rat2                 ! work constant
+!!$   real(r8) rdtice               ! recipricol of dtice
+   real(r8) rho(pcols)           ! density (mks units)
+   real(r8) rhocgs               ! density (cgs units)
+   real(r8) rlat(pcols)          ! latitude (radians)
+   real(r8) snowfr               ! fraction of precipate existing as snow
+   real(r8) totmr(pcols)         ! in-cloud total condensate mixing ratio
+   real(r8) vfallw               ! fall speed of precipitate as liquid
+   real(r8) wp                   ! weight factor used in calculating pressure dep of autoconversion
+   real(r8) wsi                  ! weight factor for sea ice
+   real(r8) wt                   ! fraction of ice
+   real(r8) wland                ! fraction of land
+
+!      real(r8) csaci
+!      real(r8) csacw
+!      real(r8) cwaut
+!      real(r8) efact
+!      real(r8) lamdas
+!      real(r8) lcrit
+!      real(r8) rcwm
+!      real(r8) r3lc2
+!      real(r8) snowmr(pcols)
+!      real(r8) vfalls
+
+   real(8) ftot
+
+!     inline statement functions
+   real(r8) heavy, heavym, a1, a2, heavyp, heavymp
+   heavy(a1,a2) = max(0._r8,sign(1._r8,a1-a2))  ! heavyside function
+   heavym(a1,a2) = max(0.01_r8,sign(1._r8,a1-a2))  ! modified heavyside function
+!
+! New heavyside functions to perhaps address error growth problems
+!
+   heavyp(a1,a2) = a1/(a2+a1+1.e-36_r8)
+   heavymp(a1,a2) = (a1+0.01_r8*a2)/(a2+a1+1.e-36_r8)
+
+!
+! find all the points where we need to do the microphysics
+! and set the output variables to zero
+!
+   ncols = 0
+   do i = 1,ncol
+      coef(i) = 0._r8
+      fwaut(i) = 0._r8
+      fsaut(i) = 0._r8
+      fracw(i) = 0._r8
+      fsacw(i) = 0._r8
+      fsaci(i) = 0._r8
+      liqmr(i) = 0._r8
+      rainmr(i) = 0._r8
+      if (cwm(i) > 1.e-20_r8) then
+         ncols = ncols + 1
+         ind(ncols) = i
+      endif
+   end do
+
+!cdir nodep
+!DIR$ CONCURRENT
+   do ii = 1,ncols
+      i = ind(ii)
+!
+! the local cloudiness at this level
+!
+      cldloc(i) = max(cldmin,cldm(i))
+!
+! a weighted mean between max cloudiness above, and this layer
+!
+      cldpr(i) = max(cldmin,(cldmax(i)+cldm(i))*0.5_r8)
+!
+! decompose the suspended condensate into
+! an incloud liquid and ice phase component
+!
+      totmr(i) = cwm(i)/cldloc(i)
+      icemr(i) = totmr(i)*fice(i)
+      liqmr(i) = totmr(i)*(1._r8-fice(i))
+!
+! density
+!
+      rho(i) = p(i,k)/(287._r8*t(i,k))
+      rhocgs = rho(i)*1.e-3_r8     ! density in cgs units
+!
+! decompose the precipitate into a liquid and ice phase
+!
+      if (t(i,k) > t0) then
+         vfallw = convfw/sqrt(rho(i))
+         rainmr(i) = precab(i)/(rho(i)*vfallw*cldpr(i))
+         snowfr = 0
+!        snowmr(i)
+      else
+         snowfr = 1
+         rainmr(i) = 0._r8
+      endif
+!     rainmr(i) = (precab(i)-snowab(i))/(rho(i)*vfallw*cldpr(i))
+!
+! local snow amount in cgs units
+!
+      prscgs(i) = precab(i)/cldpr(i)*0.1_r8*snowfr
+!     prscgs(i) = snowab(i)/cldpr(i)*0.1
+!
+! local rain amount in mm/day
+!
+      prlloc(i) = precab(i)*86400._r8/cldpr(i)
+   end do
+
+   con1 = 1._r8/(1.333_r8*pi)**0.333_r8 * 0.01_r8 ! meters
+!
+! calculate the conversion terms
+!
+   call get_rlat_all_p(lchnk, ncol, rlat)
+
+!cdir nodep
+!DIR$ CONCURRENT
+   do ii = 1,ncols
+      i = ind(ii)
+      rhocgs = rho(i)*1.e-3_r8     ! density in cgs units
+!
+! exponential temperature factor
+!
+!        efact = exp(0.025*(t(i,k)-t0))
+!
+! some temperature dependent constants
+!
+!!$      wt = min(1._r8,max(0._r8,(t0-t(i,k))*rdtice))
+      wt = fice(i)
+      icrit = icritc*wt + icritw*(1-wt)
+!
+! jrm Reworked droplet number concentration algorithm
+      ! Start with pressure-dependent value appropriate for continental air
+      ! Note: reltab has a temperature dependence here
+      capn = capnw + (capnc-capnw) * min(1._r8,max(0._r8,1.0_r8-(p(i,k)-0.8_r8*p(i,pver))/(0.2_r8*p(i,pver))))
+      ! Modify for snow depth over land
+      capn = capn + (capnc-capn) * min(1.0_r8,max(0.0_r8,snowh(i)*10._r8))
+      ! Ramp between polluted value over land to clean value over ocean.
+      capn = capn + (capnc-capn) * min(1.0_r8,max(0.0_r8,1.0_r8-landm(i,lchnk)))
+      ! Ramp between the resultant value and a sea ice value in the presence of ice.
+      capn = capn + (capnsi-capn) * min(1.0_r8,max(0.0_r8,seaicef(i)))
+! end jrm
+!      
+#ifdef DEBUG2
+      if ( (lat(i) == latlook(1)) .or. (lat(i) == latlook(2)) ) then
+         if (i == ilook(1)) then
+            write(iulog,*) ' findmcnew: lat, k, seaicef, landm, wp, capnoice, capn ', &
+                 lat(i), k, seaicef(i), landm(i,lat(i)), wp, capnoice, capn
+         endif
+      endif
+#endif
+
+!
+! useful terms in following calculations
+!
+      rat1 = rhocgs/rhow
+      rat2 = liqmr(i)/capn
+      con2 = (rat1*rat2)**0.333_r8
+!
+! volume radius
+!
+!        r3l = (rhocgs*liqmr(i)/(1.333*pi*capn*rhow))**0.333 * 0.01 ! meters
+      r3l = con1*con2
+!
+! critical threshold for autoconversion if modified for mixed phase
+! clouds to mimic a bergeron findeisen process
+! r3lc2 = r3lcrit*(1.-0.5*fice(i)*(1-fice(i)))
+!
+! autoconversion of liquid
+!
+!        cwaut = 2.e-4
+!        cwaut = 1.e-3
+!        lcrit = 2.e-4
+!        lcrit = 5.e-4
+!        pwaut = max(0._r8,liqmr(i)-lcrit)*cwaut
+!
+! pwaut is following tripoli and cotton (and many others)
+! we reduce the autoconversion below critpr, because these are regions where
+! the drop size distribution is likely to imply much smaller collector drops than
+! those relevant for a cloud distribution corresponding to the value of effc = 0.55
+! suggested by cotton (see austin 1995 JAS, baker 1993)
+
+! easy to follow form
+!        pwaut = capc*liqmr(i)**2*rhocgs/rhow
+!    $           *(liqmr(i)*rhocgs/(rhow*capn))**(.333)
+!    $           *heavy(r3l,r3lcrit)
+!    $           *max(0.10_r8,min(1._r8,prlloc(i)/critpr))
+! somewhat faster form
+#define HEAVYNEW
+#ifdef HEAVYNEW
+!#ifdef PERGRO
+      pwaut = capc*liqmr(i)**2*rat1*con2*heavymp(r3l,r3lcrit) * &
+              max(0.10_r8,min(1._r8,prlloc(i)/critpr))
+#else
+      pwaut = capc*liqmr(i)**2*rat1*con2*heavym(r3l,r3lcrit)* &
+              max(0.10_r8,min(1._r8,prlloc(i)/critpr))
+#endif
+!
+! autoconversion of ice
+!
+!        ciaut = ciautb*efact
+      ciaut = ciautb
+!        psaut = capc*totmr(i)**2*rhocgs/rhoi
+!     $           *(totmr(i)*rhocgs/(rhoi*capn))**(.333)
+!
+! autoconversion of ice condensate
+!
+#ifdef PERGRO
+      psaut = heavyp(icemr(i),icrit)*icemr(i)*ciaut
+#else
+      psaut = max(0._r8,icemr(i)-icrit)*ciaut
+#endif
+!
+! collection of liquid by rain
+!
+!        pracw = cracw*rho(i)*liqmr(i)*rainmr(i) !(beheng 1994)
+      pracw = cracw*rho(i)*sqrt(rho(i))*liqmr(i)*rainmr(i) !(tripoli and cotton)
+!!      pracw = 0.
+!
+! the following lines calculate the slope parameter and snow mixing ratio
+! from the precip rate using the equations found in lin et al 83
+! in the most natural form, but it is expensive, so after some tedious
+! algebraic manipulation you can use the cheaper form found below
+!            vfalls = c*gam4pd/(6*lamdas**d)*sqrt(rhonot/rhocgs)
+!     $               *0.01   ! convert from cm/s to m/s
+!            snowmr(i) = snowfr*precab(i)/(rho(i)*vfalls*cldpr(i))
+!            snowmr(i) = ( prscgs(i)*mcon02 * (rhocgs**mcon03) )**mcon04
+!            lamdas = (prhonos/max(rhocgs*snowmr(i),small))**0.25
+!            csacw = mcon01*sqrt(rhonot/rhocgs)/(lamdas**thrpd)
+!
+! coefficient for collection by snow independent of phase
+!
+      csacx = mcon07*rhocgs**mcon08*prscgs(i)**mcon05
+
+!
+! collection of liquid by snow (lin et al 1983)
+!
+      psacw = csacx*liqmr(i)*esw
+#ifdef PERGRO
+! this is necessary for pergro
+      psacw = 0._r8
+#endif
+!
+! collection of ice by snow (lin et al 1983)
+!
+      psaci = csacx*icemr(i)*esi
+!
+! total conversion of condensate to precipitate
+!
+      ptot = pwaut + psaut + pracw + psacw + psaci
+!
+! the recipricol of cloud water amnt (or zero if no cloud water)
+!
+!         rcwm =  totmr(i)/(max(totmr(i),small)**2)
+!
+! turn the tendency back into a loss rate (1/seconds)
+!
+      if (totmr(i) > 0._r8) then
+         coef(i) = ptot/totmr(i)
+      else
+         coef(i) = 0._r8
+      endif
+
+      if (ptot.gt.0._r8) then
+         fwaut(i) = pwaut/ptot
+         fsaut(i) = psaut/ptot
+         fracw(i) = pracw/ptot
+         fsacw(i) = psacw/ptot
+         fsaci(i) = psaci/ptot
+      else
+         fwaut(i) = 0._r8
+         fsaut(i) = 0._r8
+         fracw(i) = 0._r8
+         fsacw(i) = 0._r8
+         fsaci(i) = 0._r8
+      endif
+
+      ftot = fwaut(i)+fsaut(i)+fracw(i)+fsacw(i)+fsaci(i)
+!      if (abs(ftot-1._r8).gt.1.e-14_r8.and.ftot.ne.0._r8) then
+!         write(iulog,*) ' something is wrong in findmcnew ', ftot, &
+!              fwaut(i),fsaut(i),fracw(i),fsacw(i),fsaci(i)
+!         write(iulog,*) ' unscaled ', ptot, &
+!              pwaut,psaut,pracw,psacw,psaci
+!         write(iulog,*) ' totmr, liqmr, icemr ', totmr(i), liqmr(i), icemr(i)
+!         call endrun()
+!      endif
+   end do
+#ifdef DEBUG
+   i = icollook(nlook)
+   if (lchnk == lchnklook(nlook) ) then
+      write(iulog,*)
+      write(iulog,*) '------', k, i, lchnk
+      write(iulog,*) ' liqmr, rainmr,precab ', liqmr(i), rainmr(i), precab(i)*8.64e4_r8
+      write(iulog,*) ' frac: waut,saut,racw,sacw,saci ', &
+           fwaut(i), fsaut(i), fracw(i), fsacw(i), fsaci(i)
+   endif
+#endif
+
+   return
+end subroutine findmcnew
+
+!##############################################################################
+
+subroutine findsp (lchnk, ncol, q, t, p, tsp, qsp)
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+!     find the wet bulb temperature for a given t and q
+!     in a longitude height section
+!     wet bulb temp is the temperature and spec humidity that is 
+!     just saturated and has the same enthalpy
+!     if q > qs(t) then tsp > t and qsp = qs(tsp) < q
+!     if q < qs(t) then tsp < t and qsp = qs(tsp) > q
+!
+! Method: 
+! a Newton method is used
+! first guess uses an algorithm provided by John Petch from the UKMO
+! we exclude points where the physical situation is unrealistic
+! e.g. where the temperature is outside the range of validity for the
+!      saturation vapor pressure, or where the water vapor pressure
+!      exceeds the ambient pressure, or the saturation specific humidity is 
+!      unrealistic
+! 
+! Author: P. Rasch
+! 
+!-----------------------------------------------------------------------
+!
+!     input arguments
+!
+   integer, intent(in) :: lchnk                 ! chunk identifier
+   integer, intent(in) :: ncol                  ! number of atmospheric columns
+
+   real(r8), intent(in) :: q(pcols,pver)        ! water vapor (kg/kg)
+   real(r8), intent(in) :: t(pcols,pver)        ! temperature (K)
+   real(r8), intent(in) :: p(pcols,pver)        ! pressure    (Pa)
+!
+! output arguments
+!
+   real(r8), intent(out) :: tsp(pcols,pver)      ! saturation temp (K)
+   real(r8), intent(out) :: qsp(pcols,pver)      ! saturation mixing ratio (kg/kg)
+!
+! local variables
+!
+   integer i                 ! work variable
+   integer k                 ! work variable
+   logical lflg              ! work variable
+   integer iter              ! work variable
+   integer l                 ! work variable
+   logical :: error_found
+
+   real(r8) omeps                ! 1 minus epsilon
+   real(r8) trinv                ! work variable
+   real(r8) es                   ! sat. vapor pressure
+   real(r8) desdt                ! change in sat vap pressure wrt temperature
+!     real(r8) desdp                ! change in sat vap pressure wrt pressure
+   real(r8) dqsdt                ! change in sat spec. hum. wrt temperature
+   real(r8) dgdt                 ! work variable
+   real(r8) g                    ! work variable
+   real(r8) weight(pcols)        ! work variable
+   real(r8) hlatsb               ! (sublimation)
+   real(r8) hlatvp               ! (vaporization)
+   real(r8) hltalt(pcols,pver)   ! lat. heat. of vap.
+   real(r8) tterm                ! work var.
+   real(r8) qs                   ! spec. hum. of water vapor
+   real(r8) tc                   ! crit temp of transition to ice
+
+! work variables
+   real(r8) t1, q1, dt, dq
+   real(r8) dtm, dqm
+   real(r8) qvd, a1, tmp
+   real(r8) rair
+   real(r8) r1b, c1, c2, c3
+   real(r8) denom
+   real(r8) dttol
+   real(r8) dqtol
+   integer doit(pcols) 
+   real(r8) enin(pcols), enout(pcols)
+   real(r8) tlim(pcols)
+
+   omeps = 1.0_r8 - epsqs
+   trinv = 1.0_r8/ttrice
+   a1 = 7.5_r8*log(10._r8)
+   rair =  287.04_r8
+   c3 = rair*a1/cp
+   dtm = 0._r8    ! needed for iter=0 blowup with f90 -ei
+   dqm = 0._r8    ! needed for iter=0 blowup with f90 -ei
+   dttol = 1.e-4_r8 ! the relative temp error tolerance required to quit the iteration
+   dqtol = 1.e-4_r8 ! the relative moisture error tolerance required to quit the iteration
+!  tmin = 173.16 ! the coldest temperature we can deal with
+!
+! max number of times to iterate the calculation
+   iter = 8
+!
+   do k = k1mb,pver
+
+!
+! first guess on the wet bulb temperature
+!
+      do i = 1,ncol
+
+#ifdef DEBUG
+         if ( (lchnk == lchnklook(nlook) ) .and. (i == icollook(nlook) ) ) then
+            write(iulog,*) ' '
+            write(iulog,*) ' level, t, q, p', k, t(i,k), q(i,k), p(i,k)
+         endif
+#endif
+! limit the temperature range to that relevant to the sat vap pres tables
+#if ( ! defined WACCM_PHYS )
+         tlim(i) = min(max(t(i,k),173._r8),373._r8)
+#else
+         tlim(i) = min(max(t(i,k),128._r8),373._r8)
+#endif
+         es = estblf(tlim(i))
+         denom = p(i,k) - omeps*es
+         qs = epsqs*es/denom
+         doit(i) = 0
+         enout(i) = 1._r8
+! make sure a meaningful calculation is possible
+         if (p(i,k) > 5._r8*es .and. qs > 0._r8 .and. qs < 0.5_r8) then
+!
+! Saturation specific humidity
+!
+             qs = min(epsqs*es/denom,1._r8)
+!
+! "generalized" analytic expression for t derivative of es
+!  accurate to within 1 percent for 173.16 < t < 373.16
+!
+! Weighting of hlat accounts for transition from water to ice
+! polynomial expression approximates difference between es over
+! water and es over ice from 0 to -ttrice (C) (min of ttrice is
+! -40): required for accurate estimate of es derivative in transition
+! range from ice to water also accounting for change of hlatv with t
+! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw
+!
+             tc     = tlim(i) - t0
+             lflg   = (tc >= -ttrice .and. tc < 0.0_r8)
+             weight(i) = min(-tc*trinv,1.0_r8)
+             hlatsb = hlatv + weight(i)*hlatf
+             hlatvp = hlatv - 2369.0_r8*tc
+             if (tlim(i) < t0) then
+                hltalt(i,k) = hlatsb
+             else
+                hltalt(i,k) = hlatvp
+             end if
+             enin(i) = cp*tlim(i) + hltalt(i,k)*q(i,k)
+
+! make a guess at the wet bulb temp using a UKMO algorithm (from J. Petch)
+             tmp =  q(i,k) - qs
+             c1 = hltalt(i,k)*c3
+             c2 = (tlim(i) + 36._r8)**2
+             r1b    = c2/(c2 + c1*qs)
+             qvd   = r1b*tmp
+             tsp(i,k) = tlim(i) + ((hltalt(i,k)/cp)*qvd)
+#ifdef DEBUG
+             if ( (lchnk == lchnklook(nlook) ) .and. (i == icollook(nlook) ) ) then
+                write(iulog,*) ' relative humidity ', q(i,k)/qs
+                write(iulog,*) ' first guess ', tsp(i,k)
+             endif
+#endif
+             es = estblf(tsp(i,k))
+             qsp(i,k) = min(epsqs*es/(p(i,k) - omeps*es),1._r8)
+          else
+             doit(i) = 1
+             tsp(i,k) = tlim(i)
+             qsp(i,k) = q(i,k)
+             enin(i) = 1._r8
+          endif
+       end do   ! end do i
+!
+! now iterate on first guess
+!
+      do l = 1, iter
+         dtm = 0
+         dqm = 0
+         do i = 1,ncol
+            if (doit(i) == 0) then
+               es = estblf(tsp(i,k))
+!
+! Saturation specific humidity
+!
+               qs = min(epsqs*es/(p(i,k) - omeps*es),1._r8)
+!
+! "generalized" analytic expression for t derivative of es
+! accurate to within 1 percent for 173.16 < t < 373.16
+!
+! Weighting of hlat accounts for transition from water to ice
+! polynomial expression approximates difference between es over
+! water and es over ice from 0 to -ttrice (C) (min of ttrice is
+! -40): required for accurate estimate of es derivative in transition
+! range from ice to water also accounting for change of hlatv with t
+! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw
+!
+               tc     = tsp(i,k) - t0
+               lflg   = (tc >= -ttrice .and. tc < 0.0_r8)
+               weight(i) = min(-tc*trinv,1.0_r8)
+               hlatsb = hlatv + weight(i)*hlatf
+               hlatvp = hlatv - 2369.0_r8*tc
+               if (tsp(i,k) < t0) then
+                  hltalt(i,k) = hlatsb
+               else
+                  hltalt(i,k) = hlatvp
+               end if
+               if (lflg) then
+                  tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3)+tc*(pcf(4) + tc*pcf(5))))
+               else
+                  tterm = 0.0_r8
+               end if
+               desdt = hltalt(i,k)*es/(rgasv*tsp(i,k)*tsp(i,k)) + tterm*trinv
+               dqsdt = (epsqs + omeps*qs)/(p(i,k) - omeps*es)*desdt
+!              g = cp*(tlim(i)-tsp(i,k)) + hltalt(i,k)*q(i,k)- hltalt(i,k)*qsp(i,k)
+               g = enin(i) - (cp*tsp(i,k) + hltalt(i,k)*qsp(i,k))
+               dgdt = -(cp + hltalt(i,k)*dqsdt)
+               t1 = tsp(i,k) - g/dgdt
+               dt = abs(t1 - tsp(i,k))/t1
+               tsp(i,k) = max(t1,tmin)
+               es = estblf(tsp(i,k))
+               q1 = min(epsqs*es/(p(i,k) - omeps*es),1._r8)
+               dq = abs(q1 - qsp(i,k))/max(q1,1.e-12_r8)
+               qsp(i,k) = q1
+#ifdef DEBUG
+               if ( (lchnk == lchnklook(nlook) ) .and. (i == icollook(nlook) ) ) then
+                  write(iulog,*) ' rel chg lev, iter, t, q ', k, l, dt, dq, g
+               endif
+#endif
+               dtm = max(dtm,dt)
+               dqm = max(dqm,dq)
+! if converged at this point, exclude it from more iterations
+               if (dt < dttol .and. dq < dqtol) then
+                  doit(i) = 2
+               endif
+               enout(i) = cp*tsp(i,k) + hltalt(i,k)*qsp(i,k)
+! bail out if we are too near the end of temp range
+#if ( ! defined WACCM_PHYS )
+               if (tsp(i,k) < 174.16_r8) then
+#else
+               if (tsp(i,k) < 130.16_r8) then
+#endif
+                  doit(i) = 4
+               endif
+            else
+            endif
+         end do              ! do i = 1,ncol
+
+         if (dtm < dttol .and. dqm < dqtol) then
+            go to 10
+         endif
+
+      end do                 ! do l = 1,iter
+10    continue
+
+      error_found = .false.
+      if (dtm > dttol .or. dqm > dqtol) then
+         do i = 1,ncol
+            if (doit(i) == 0) error_found = .true.
+         end do
+         if (error_found) then
+            do i = 1,ncol
+               if (doit(i) == 0) then
+                  write(iulog,*) ' findsp not converging at point i, k ', i, k
+                  write(iulog,*) ' t, q, p, enin ', t(i,k), q(i,k), p(i,k), enin(i)
+                  write(iulog,*) ' tsp, qsp, enout ', tsp(i,k), qsp(i,k), enout(i)
+                  call endrun ('FINDSP')
+               endif
+            end do
+         endif
+      endif
+      do i = 1,ncol
+         if (doit(i) == 2 .and. abs((enin(i)-enout(i))/(enin(i)+enout(i))) > 1.e-4_r8) then
+            error_found = .true.
+         endif
+      end do
+      if (error_found) then
+         do i = 1,ncol
+            if (doit(i) == 2 .and. abs((enin(i)-enout(i))/(enin(i)+enout(i))) > 1.e-4_r8) then
+               write(iulog,*) ' the enthalpy is not conserved for point ', &
+                  i, k, enin(i), enout(i)
+               write(iulog,*) ' t, q, p, enin ', t(i,k), q(i,k), p(i,k), enin(i)
+               write(iulog,*) ' tsp, qsp, enout ', tsp(i,k), qsp(i,k), enout(i)
+               call endrun ('FINDSP')
+            endif
+         end do
+      endif
+      
+   end do                    ! level loop (k=1,pver)
+
+   return
+end subroutine findsp
+
+#endif
+
+end module cldwat
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_constituents.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_constituents.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_constituents.F	(revision 17)
@@ -0,0 +1,386 @@
+#define WRF_PORT
+
+module constituents
+
+!----------------------------------------------------------------------------------------------
+! 
+! Purpose: Contains data and functions for manipulating advected and non-advected constituents.
+!
+! Revision history:
+!             B.A. Boville    Original version
+! June 2003   P. Rasch        Add wet/dry m.r. specifier
+! 2004-08-28  B. Eaton        Add query function to allow turning off the default CAM output of
+!                             constituents so that chemistry module can make the outfld calls.
+!                             Allow cnst_get_ind to return without aborting when constituent not
+!                             found.
+! 2006-10-31  B. Eaton        Remove 'non-advected' constituent functionality.
+!----------------------------------------------------------------------------------------------
+  use shr_kind_mod, only: r8 => shr_kind_r8
+  use physconst,    only: r_universal
+
+#ifndef WRF_PORT 
+  use spmd_utils,   only: masterproc
+  use abortutils,   only: endrun
+  use cam_logfile,  only: iulog
+#else
+  use module_cam_support,   only: masterproc,endrun,iulog,pcnst
+#endif
+
+  implicit none
+  private
+  save
+!
+! Public interfaces
+!
+  public cnst_add             ! add a constituent to the list of advected constituents
+  public cnst_num_avail       ! returns the number of available slots in the constituent array
+  public cnst_get_ind         ! get the index of a constituent
+  public cnst_get_type_byind  ! get the type of a constituent
+  public cnst_get_type_byname ! get the type of a constituent
+  public cnst_read_iv         ! query whether constituent initial values are read from initial file
+  public cnst_chk_dim         ! check that number of constituents added equals dimensions (pcnst)
+  public cnst_cam_outfld      ! Returns true if default CAM output was specified in the cnst_add calls.
+
+! Public data
+#ifndef WRF_PORT 
+  integer, parameter, public :: pcnst  = PCNST      ! number of advected constituents (including water vapor)
+#endif
+
+  character(len=16), public :: cnst_name(pcnst)     ! constituent names
+  character(len=128),public :: cnst_longname(pcnst) ! long name of constituents
+
+! Namelist variables
+  logical, public :: readtrace = .true.             ! true => obtain initial tracer data from IC file
+
+!
+! Constants for each tracer
+  real(r8),    public :: cnst_cp  (pcnst)          ! specific heat at constant pressure (J/kg/K)
+  real(r8),    public :: cnst_cv  (pcnst)          ! specific heat at constant volume (J/kg/K)
+  real(r8),    public :: cnst_mw  (pcnst)          ! molecular weight (kg/kmole)
+  character*3, public :: cnst_type(pcnst)          ! wet or dry mixing ratio
+  real(r8),    public :: cnst_rgas(pcnst)          ! gas constant ()
+  real(r8),    public :: qmin     (pcnst)          ! minimum permitted constituent concentration (kg/kg)
+  real(r8),    public :: qmincg   (pcnst)          ! for backward compatibility only
+  logical,     public :: cnst_fixed_ubc(pcnst) = .false.  ! upper bndy condition = fixed ?
+
+!++bee - temporary... These names should be declared in the module that makes the addfld and outfld calls.
+! Lists of tracer names and diagnostics
+   character(len=16), public :: apcnst    (pcnst)   ! constituents after physics  (FV core only)
+   character(len=16), public :: bpcnst    (pcnst)   ! constituents before physics (FV core only)
+   character(len=16), public :: hadvnam   (pcnst)   ! names of horizontal advection tendencies
+   character(len=16), public :: vadvnam   (pcnst)   ! names of vertical advection tendencies
+   character(len=16), public :: dcconnam  (pcnst)   ! names of convection tendencies
+   character(len=16), public :: fixcnam   (pcnst)   ! names of species slt fixer tendencies
+   character(len=16), public :: tendnam   (pcnst)   ! names of total tendencies of species
+   character(len=16), public :: ptendnam  (pcnst)   ! names of total physics tendencies of species
+   character(len=16), public :: dmetendnam(pcnst)   ! names of dme adjusted tracers (FV)
+   character(len=16), public :: sflxnam   (pcnst)   ! names of surface fluxes of species
+   character(len=16), public :: tottnam   (pcnst)   ! names for horz + vert + fixer tendencies
+
+! Private data
+
+  integer :: padv = 0                      ! index pointer to last advected tracer
+  logical :: read_init_vals(pcnst)         ! true => read initial values from initial file
+  logical :: cam_outfld_(pcnst)            ! true  => default CAM output of constituents in kg/kg
+                                           ! false => chemistry is responsible for making outfld
+                                           !          calls for constituents
+
+!==============================================================================================
+CONTAINS
+!==============================================================================================
+
+  subroutine cnst_add (name, mwc, cpc, qminc, &
+                       ind, longname, readiv, mixtype, cam_outfld, fixed_ubc)
+!----------------------------------------------------------------------- 
+! 
+! Purpose: Register a constituent to be advected by the large scale winds and transported by
+!          subgrid scale processes.
+!
+!---------------------------------------------------------------------------------
+!
+    character(len=*), intent(in) :: &
+       name      ! constituent name used as variable name in history file output (8 char max)
+    real(r8),intent(in)    :: mwc    ! constituent molecular weight (kg/kmol)
+    real(r8),intent(in)    :: cpc    ! constituent specific heat at constant pressure (J/kg/K)
+    real(r8),intent(in)    :: qminc  ! minimum value of mass mixing ratio (kg/kg)
+                                     ! normally 0., except water 1.E-12, for radiation.
+    integer, intent(out)   :: ind    ! global constituent index (in q array)
+
+    character(len=*), intent(in), optional :: &
+       longname    ! value for long_name attribute in netcdf output (128 char max, defaults to name)
+    logical,          intent(in), optional :: &
+       readiv      ! true => read initial values from initial file (default: true)
+    character(len=*), intent(in), optional :: &
+       mixtype     ! mixing ratio type (dry, wet)
+    logical,          intent(in), optional :: &
+       cam_outfld  ! true => default CAM output of constituent in kg/kg
+    logical,          intent(in), optional :: &
+       fixed_ubc ! true => const has a fixed upper bndy condition
+
+!-----------------------------------------------------------------------
+
+! set tracer index and check validity, advected tracer
+    padv = padv+1
+    ind  = padv
+    if (padv > pcnst) then
+       write(iulog,*) 'CNST_ADD: advected tracer index greater than pcnst = ', pcnst
+       call endrun
+    end if
+
+! set tracer name and constants
+    cnst_name(ind) = name
+    if ( present(longname) )then
+       cnst_longname(ind) = longname
+    else
+       cnst_longname(ind) = name
+    end if
+
+! set whether to read initial values from initial file
+    if ( present(readiv) ) then
+       read_init_vals(ind) = readiv
+    else
+       read_init_vals(ind) = readtrace
+    end if
+
+! set constituent mixing ratio type
+    if ( present(mixtype) )then
+       cnst_type(ind) = mixtype
+    else
+       cnst_type(ind) = 'wet'
+    end if
+
+! set outfld type 
+! (false: the module declaring the constituent is responsible for outfld calls)
+    if ( present(cam_outfld) ) then
+       cam_outfld_(ind) = cam_outfld
+    else
+       cam_outfld_(ind) = .true.
+    end if
+
+! set upper boundary condition type
+    if ( present(fixed_ubc) ) then
+       cnst_fixed_ubc(ind) = fixed_ubc
+    else
+       cnst_fixed_ubc(ind) = .false.
+    end if
+
+    cnst_cp  (ind) = cpc
+    cnst_mw  (ind) = mwc
+    qmin     (ind) = qminc
+    qmincg   (ind) = qminc
+    if (ind == 1) qmincg = 0._r8  ! This crap is replicate what was there before ****
+
+    cnst_rgas(ind) = r_universal * mwc
+    cnst_cv  (ind) = cpc - cnst_rgas(ind)
+
+    return
+  end subroutine cnst_add
+
+!==============================================================================
+
+  function cnst_num_avail()
+
+     ! return number of available slots in the constituent array
+
+     integer cnst_num_avail
+
+     cnst_num_avail = pcnst - padv
+
+  end function cnst_num_avail
+
+!==============================================================================
+
+  subroutine cnst_get_ind (name, ind, abort)
+!----------------------------------------------------------------------- 
+! 
+! Purpose: Get the index of a constituent 
+! 
+! Author:  B.A. Boville
+! 
+!-----------------------------Arguments---------------------------------
+!
+    character(len=*),  intent(in)  :: name  ! constituent name
+    integer,           intent(out) :: ind   ! global constituent index (in q array)
+    logical, optional, intent(in)  :: abort ! optional flag controlling abort
+
+!---------------------------Local workspace-----------------------------
+    integer :: m                                   ! tracer index
+    logical :: abort_on_error
+!-----------------------------------------------------------------------
+
+! Find tracer name in list
+    do m = 1, pcnst
+       if (name == cnst_name(m)) then
+          ind  = m
+          return
+       end if
+    end do
+
+! Unrecognized name
+    abort_on_error = .true.
+    if ( present(abort) ) abort_on_error = abort
+
+    if ( abort_on_error ) then
+       write(iulog,*) 'CNST_GET_IND, name:', name,  ' not found in list:', cnst_name(:)
+#ifdef WRF_PORT
+       call wrf_message(iulog)
+#endif
+       call endrun('CNST_GET_IND: name not found')
+    end if
+
+! error return
+    ind = -1
+
+  end subroutine cnst_get_ind
+
+!==============================================================================================
+
+  character*3 function cnst_get_type_byind (ind)
+!----------------------------------------------------------------------- 
+! 
+! Purpose: Get the type of a constituent 
+! 
+! Method: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! Author:  P. J. Rasch
+! 
+!-----------------------------Arguments---------------------------------
+!
+    integer, intent(in)   :: ind    ! global constituent index (in q array)
+
+!---------------------------Local workspace-----------------------------
+    integer :: m                                   ! tracer index
+
+!-----------------------------------------------------------------------
+
+    if (ind.le.pcnst) then
+       cnst_get_type_byind = cnst_type(ind)
+    else
+       ! Unrecognized name
+       write(iulog,*) 'CNST_GET_TYPE_BYIND, ind:', ind
+       call endrun
+    endif
+
+
+  end function cnst_get_type_byind
+
+!==============================================================================================
+
+  character*3 function cnst_get_type_byname (name)
+!----------------------------------------------------------------------- 
+! 
+! Purpose: Get the type of a constituent 
+! 
+! Method: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! Author:  P. J. Rasch
+! 
+!-----------------------------Arguments---------------------------------
+!
+    character(len=*), intent(in) :: name ! constituent name
+
+!---------------------------Local workspace-----------------------------
+    integer :: m                                   ! tracer index
+
+!-----------------------------------------------------------------------
+
+    do m = 1, pcnst
+       if (name == cnst_name(m)) then
+          cnst_get_type_byname = cnst_type(m)
+          return
+       end if
+    end do
+
+! Unrecognized name
+    write(iulog,*) 'CNST_GET_TYPE_BYNAME, name:', name,  ' not found in list:', cnst_name(:)
+    call endrun
+
+  end function cnst_get_type_byname
+
+!==============================================================================
+  function cnst_read_iv(m)
+!----------------------------------------------------------------------- 
+! 
+! Purpose: Query whether constituent initial values are read from initial file.
+! 
+! Author:  B. Eaton
+! 
+!-----------------------------Arguments---------------------------------
+!
+    integer, intent(in) :: m    ! constituent index
+
+    logical :: cnst_read_iv     ! true => read initial values from inital file
+!-----------------------------------------------------------------------
+
+    cnst_read_iv = read_init_vals(m)
+ end function cnst_read_iv
+
+!==============================================================================
+  subroutine cnst_chk_dim
+!----------------------------------------------------------------------- 
+! 
+! Purpose: Check that the number of registered constituents of each type is the
+!          same as the dimension
+! 
+! Method: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! Author:  B.A. Boville
+! 
+    integer i,m
+!-----------------------------------------------------------------------
+!
+    if (padv /= pcnst) then
+       write(iulog,*)'CNST_CHK_DIM: number of advected tracer ',padv, ' not equal to pcnst = ',pcnst
+       call endrun ()
+    endif
+
+    if (masterproc) then
+       write(iulog,*) 'Advected constituent list:'
+       do i = 1, pcnst
+          write(iulog,'(i4,2x,a8,2x,a128,2x,a3)') i, cnst_name(i), cnst_longname(i), cnst_type(i)
+       end do
+    end if
+
+    ! Set names of advected tracer diagnostics
+    do m=1,pcnst
+       apcnst    (m)  = trim(cnst_name(m))//'AP'
+       bpcnst    (m)  = trim(cnst_name(m))//'BP'
+       hadvnam   (m)  = 'HA'//cnst_name(m)
+       vadvnam   (m)  = 'VA'//cnst_name(m)
+       fixcnam   (m)  = 'DF'//cnst_name(m)
+       tendnam   (m)  = 'TE'//cnst_name(m)
+       ptendnam  (m)  = 'PTE'//cnst_name(m)
+       dmetendnam(m)  = 'DME'//cnst_name(m)
+       tottnam   (m)  = 'TA'//cnst_name(m)
+       sflxnam(m)     = 'SF'//cnst_name(m)
+    end do
+
+
+  end subroutine cnst_chk_dim
+
+!==============================================================================
+
+function cnst_cam_outfld(m)
+!----------------------------------------------------------------------- 
+! 
+! Purpose:
+! Query whether default CAM outfld calls should be made.
+! 
+!----------------------------------------------------------------------- 
+   integer, intent(in) :: m                ! constituent index
+   logical             :: cnst_cam_outfld  ! true => use default CAM outfld calls
+!-----------------------------------------------------------------------
+
+   cnst_cam_outfld = cam_outfld_(m)
+
+end function cnst_cam_outfld
+
+!==============================================================================
+
+end module constituents
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_error_function.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_error_function.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_error_function.F	(revision 17)
@@ -0,0 +1,651 @@
+!------------------------------------------------------------------------
+! Based on error_function.F90 from CAM
+! Ported to WRF by William.Gustafson@pnl.gov, Dec. 2009
+!------------------------------------------------------------------------
+
+module error_function
+
+! This module provides generic interfaces for functions that evaluate
+! erf(x), erfc(x), and exp(x*x)*erfc(x) in either single or double precision.
+
+implicit none
+private
+save
+
+! Public functions
+public :: erf, erfc, erfcx
+
+interface erf
+   module procedure erf_r4
+   module procedure derf
+end interface
+
+interface erfc
+   module procedure erfc_r4
+   module procedure derfc
+end interface
+
+interface erfcx
+   module procedure erfcx_r4
+   module procedure derfcx
+end interface
+
+! Private variables
+integer, parameter :: r4 = selected_real_kind(6)  ! 4 byte real
+integer, parameter :: r8 = selected_real_kind(12) ! 8 byte real
+
+contains
+
+!------------------------------------------------------------------
+!
+! 6 December 2006 -- B. Eaton
+! The following comments are from the original version of CALERF.
+! The only changes in implementing this module are that the function
+! names previously used for the single precision versions have been
+! adopted for the new generic interfaces.  To support these interfaces
+! there is now both a single precision version (calerf_r4) and a
+! double precision version (calerf_r8) of CALERF below.  These versions
+! are hardcoded to use IEEE arithmetic.
+!
+!------------------------------------------------------------------
+!
+! This packet evaluates  erf(x),  erfc(x),  and  exp(x*x)*erfc(x)
+!   for a real argument  x.  It contains three FUNCTION type
+!   subprograms: ERF, ERFC, and ERFCX (or DERF, DERFC, and DERFCX),
+!   and one SUBROUTINE type subprogram, CALERF.  The calling
+!   statements for the primary entries are:
+!
+!                   Y=ERF(X)     (or   Y=DERF(X)),
+!
+!                   Y=ERFC(X)    (or   Y=DERFC(X)),
+!   and
+!                   Y=ERFCX(X)   (or   Y=DERFCX(X)).
+!
+!   The routine  CALERF  is intended for internal packet use only,
+!   all computations within the packet being concentrated in this
+!   routine.  The function subprograms invoke  CALERF  with the
+!   statement
+!
+!          CALL CALERF(ARG,RESULT,JINT)
+!
+!   where the parameter usage is as follows
+!
+!      Function                     Parameters for CALERF
+!       call              ARG                  Result          JINT
+!
+!     ERF(ARG)      ANY REAL ARGUMENT         ERF(ARG)          0
+!     ERFC(ARG)     ABS(ARG) .LT. XBIG        ERFC(ARG)         1
+!     ERFCX(ARG)    XNEG .LT. ARG .LT. XMAX   ERFCX(ARG)        2
+!
+!   The main computation evaluates near-minimax approximations
+!   from "Rational Chebyshev approximations for the error function"
+!   by W. J. Cody, Math. Comp., 1969, PP. 631-638.  This
+!   transportable program uses rational functions that theoretically
+!   approximate  erf(x)  and  erfc(x)  to at least 18 significant
+!   decimal digits.  The accuracy achieved depends on the arithmetic
+!   system, the compiler, the intrinsic functions, and proper
+!   selection of the machine-dependent constants.
+!
+!*******************************************************************
+!*******************************************************************
+!
+! Explanation of machine-dependent constants
+!
+!   XMIN   = the smallest positive floating-point number.
+!   XINF   = the largest positive finite floating-point number.
+!   XNEG   = the largest negative argument acceptable to ERFCX;
+!            the negative of the solution to the equation
+!            2*exp(x*x) = XINF.
+!   XSMALL = argument below which erf(x) may be represented by
+!            2*x/sqrt(pi)  and above which  x*x  will not underflow.
+!            A conservative value is the largest machine number X
+!            such that   1.0 + X = 1.0   to machine precision.
+!   XBIG   = largest argument acceptable to ERFC;  solution to
+!            the equation:  W(x) * (1-0.5/x**2) = XMIN,  where
+!            W(x) = exp(-x*x)/[x*sqrt(pi)].
+!   XHUGE  = argument above which  1.0 - 1/(2*x*x) = 1.0  to
+!            machine precision.  A conservative value is
+!            1/[2*sqrt(XSMALL)]
+!   XMAX   = largest acceptable argument to ERFCX; the minimum
+!            of XINF and 1/[sqrt(pi)*XMIN].
+!
+!   Approximate values for some important machines are:
+!
+!                          XMIN       XINF        XNEG     XSMALL
+!
+!  CDC 7600      (S.P.)  3.13E-294   1.26E+322   -27.220  7.11E-15
+!  CRAY-1        (S.P.)  4.58E-2467  5.45E+2465  -75.345  7.11E-15
+!  IEEE (IBM/XT,
+!    SUN, etc.)  (S.P.)  1.18E-38    3.40E+38     -9.382  5.96E-8
+!  IEEE (IBM/XT,
+!    SUN, etc.)  (D.P.)  2.23D-308   1.79D+308   -26.628  1.11D-16
+!  IBM 195       (D.P.)  5.40D-79    7.23E+75    -13.190  1.39D-17
+!  UNIVAC 1108   (D.P.)  2.78D-309   8.98D+307   -26.615  1.73D-18
+!  VAX D-Format  (D.P.)  2.94D-39    1.70D+38     -9.345  1.39D-17
+!  VAX G-Format  (D.P.)  5.56D-309   8.98D+307   -26.615  1.11D-16
+!
+!
+!                          XBIG       XHUGE       XMAX
+!
+!  CDC 7600      (S.P.)  25.922      8.39E+6     1.80X+293
+!  CRAY-1        (S.P.)  75.326      8.39E+6     5.45E+2465
+!  IEEE (IBM/XT,
+!    SUN, etc.)  (S.P.)   9.194      2.90E+3     4.79E+37
+!  IEEE (IBM/XT,
+!    SUN, etc.)  (D.P.)  26.543      6.71D+7     2.53D+307
+!  IBM 195       (D.P.)  13.306      1.90D+8     7.23E+75
+!  UNIVAC 1108   (D.P.)  26.582      5.37D+8     8.98D+307
+!  VAX D-Format  (D.P.)   9.269      1.90D+8     1.70D+38
+!  VAX G-Format  (D.P.)  26.569      6.71D+7     8.98D+307
+!
+!*******************************************************************
+!*******************************************************************
+!
+! Error returns
+!
+!  The program returns  ERFC = 0      for  ARG .GE. XBIG;
+!
+!                       ERFCX = XINF  for  ARG .LT. XNEG;
+!      and
+!                       ERFCX = 0     for  ARG .GE. XMAX.
+!
+!
+! Intrinsic functions required are:
+!
+!     ABS, AINT, EXP
+!
+!
+!  Author: W. J. Cody
+!          Mathematics and Computer Science Division
+!          Argonne National Laboratory
+!          Argonne, IL 60439
+!
+!  Latest modification: March 19, 1990
+!
+!------------------------------------------------------------------
+
+SUBROUTINE CALERF_r8(ARG, RESULT, JINT)
+
+   !------------------------------------------------------------------
+   !  This version uses 8-byte reals
+   !------------------------------------------------------------------
+   integer, parameter :: rk = r8
+
+   ! arguments
+   real(rk), intent(in)  :: arg
+   integer,  intent(in)  :: jint
+   real(rk), intent(out) :: result
+
+   ! local variables
+   INTEGER :: I
+
+   real(rk) :: X, Y, YSQ, XNUM, XDEN, DEL
+
+   !------------------------------------------------------------------
+   !  Mathematical constants
+   !------------------------------------------------------------------
+   real(rk), parameter :: ZERO   = 0.0E0_rk
+   real(rk), parameter :: FOUR   = 4.0E0_rk
+   real(rk), parameter :: ONE    = 1.0E0_rk
+   real(rk), parameter :: HALF   = 0.5E0_rk
+   real(rk), parameter :: TWO    = 2.0E0_rk
+   real(rk), parameter :: SQRPI  = 5.6418958354775628695E-1_rk
+   real(rk), parameter :: THRESH = 0.46875E0_rk
+   real(rk), parameter :: SIXTEN = 16.0E0_rk
+
+!------------------------------------------------------------------
+!  Machine-dependent constants: IEEE single precision values
+!------------------------------------------------------------------
+!S      real, parameter :: XINF   =  3.40E+38
+!S      real, parameter :: XNEG   = -9.382E0
+!S      real, parameter :: XSMALL =  5.96E-8 
+!S      real, parameter :: XBIG   =  9.194E0
+!S      real, parameter :: XHUGE  =  2.90E3
+!S      real, parameter :: XMAX   =  4.79E37
+
+   !------------------------------------------------------------------
+   !  Machine-dependent constants: IEEE double precision values
+   !------------------------------------------------------------------
+   real(rk), parameter :: XINF   =   1.79E308_r8
+   real(rk), parameter :: XNEG   = -26.628E0_r8
+   real(rk), parameter :: XSMALL =   1.11E-16_r8
+   real(rk), parameter :: XBIG   =  26.543E0_r8
+   real(rk), parameter :: XHUGE  =   6.71E7_r8
+   real(rk), parameter :: XMAX   =   2.53E307_r8
+
+   !------------------------------------------------------------------
+   !  Coefficients for approximation to  erf  in first interval
+   !------------------------------------------------------------------
+   real(rk), parameter :: A(5) = (/ 3.16112374387056560E00_rk, 1.13864154151050156E02_rk, &
+                                    3.77485237685302021E02_rk, 3.20937758913846947E03_rk, &
+                                    1.85777706184603153E-1_rk /)
+   real(rk), parameter :: B(4) = (/ 2.36012909523441209E01_rk, 2.44024637934444173E02_rk, &
+                                    1.28261652607737228E03_rk, 2.84423683343917062E03_rk /)
+
+   !------------------------------------------------------------------
+   !  Coefficients for approximation to  erfc  in second interval
+   !------------------------------------------------------------------
+   real(rk), parameter :: C(9) = (/ 5.64188496988670089E-1_rk, 8.88314979438837594E00_rk, &
+                                    6.61191906371416295E01_rk, 2.98635138197400131E02_rk, &
+                                    8.81952221241769090E02_rk, 1.71204761263407058E03_rk, &
+                                    2.05107837782607147E03_rk, 1.23033935479799725E03_rk, &
+                                    2.15311535474403846E-8_rk /)
+   real(rk), parameter :: D(8) = (/ 1.57449261107098347E01_rk, 1.17693950891312499E02_rk, &
+                                    5.37181101862009858E02_rk, 1.62138957456669019E03_rk, &
+                                    3.29079923573345963E03_rk, 4.36261909014324716E03_rk, &
+                                    3.43936767414372164E03_rk, 1.23033935480374942E03_rk /)
+
+   !------------------------------------------------------------------
+   !  Coefficients for approximation to  erfc  in third interval
+   !------------------------------------------------------------------
+   real(rk), parameter :: P(6) = (/ 3.05326634961232344E-1_rk, 3.60344899949804439E-1_rk, &
+                                    1.25781726111229246E-1_rk, 1.60837851487422766E-2_rk, &
+                                    6.58749161529837803E-4_rk, 1.63153871373020978E-2_rk /)
+   real(rk), parameter :: Q(5) = (/ 2.56852019228982242E00_rk, 1.87295284992346047E00_rk, &
+                                    5.27905102951428412E-1_rk, 6.05183413124413191E-2_rk, &
+                                    2.33520497626869185E-3_rk /)
+
+   !------------------------------------------------------------------
+   X = ARG
+   Y = ABS(X)
+   IF (Y .LE. THRESH) THEN
+      !------------------------------------------------------------------
+      !  Evaluate  erf  for  |X| <= 0.46875
+      !------------------------------------------------------------------
+      YSQ = ZERO
+      IF (Y .GT. XSMALL) YSQ = Y * Y
+      XNUM = A(5)*YSQ
+      XDEN = YSQ
+      DO I = 1, 3
+         XNUM = (XNUM + A(I)) * YSQ
+         XDEN = (XDEN + B(I)) * YSQ
+      end do
+      RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
+      IF (JINT .NE. 0) RESULT = ONE - RESULT
+      IF (JINT .EQ. 2) RESULT = EXP(YSQ) * RESULT
+      GO TO 80
+   ELSE IF (Y .LE. FOUR) THEN
+      !------------------------------------------------------------------
+      !  Evaluate  erfc  for 0.46875 <= |X| <= 4.0
+      !------------------------------------------------------------------
+      XNUM = C(9)*Y
+      XDEN = Y
+      DO I = 1, 7
+         XNUM = (XNUM + C(I)) * Y
+         XDEN = (XDEN + D(I)) * Y
+      end do
+      RESULT = (XNUM + C(8)) / (XDEN + D(8))
+      IF (JINT .NE. 2) THEN
+         YSQ = AINT(Y*SIXTEN)/SIXTEN
+         DEL = (Y-YSQ)*(Y+YSQ)
+         RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
+      END IF
+   ELSE
+      !------------------------------------------------------------------
+      !  Evaluate  erfc  for |X| > 4.0
+      !------------------------------------------------------------------
+      RESULT = ZERO
+      IF (Y .GE. XBIG) THEN
+         IF ((JINT .NE. 2) .OR. (Y .GE. XMAX)) GO TO 30
+         IF (Y .GE. XHUGE) THEN
+            RESULT = SQRPI / Y
+            GO TO 30
+         END IF
+      END IF
+      YSQ = ONE / (Y * Y)
+      XNUM = P(6)*YSQ
+      XDEN = YSQ
+      DO I = 1, 4
+         XNUM = (XNUM + P(I)) * YSQ
+         XDEN = (XDEN + Q(I)) * YSQ
+      end do
+      RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
+      RESULT = (SQRPI -  RESULT) / Y
+      IF (JINT .NE. 2) THEN
+         YSQ = AINT(Y*SIXTEN)/SIXTEN
+         DEL = (Y-YSQ)*(Y+YSQ)
+         RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
+      END IF
+   END IF
+30 continue
+   !------------------------------------------------------------------
+   !  Fix up for negative argument, erf, etc.
+   !------------------------------------------------------------------
+   IF (JINT .EQ. 0) THEN
+      RESULT = (HALF - RESULT) + HALF
+      IF (X .LT. ZERO) RESULT = -RESULT
+   ELSE IF (JINT .EQ. 1) THEN
+      IF (X .LT. ZERO) RESULT = TWO - RESULT
+   ELSE
+      IF (X .LT. ZERO) THEN
+         IF (X .LT. XNEG) THEN
+            RESULT = XINF
+         ELSE
+            YSQ = AINT(X*SIXTEN)/SIXTEN
+            DEL = (X-YSQ)*(X+YSQ)
+            Y = EXP(YSQ*YSQ) * EXP(DEL)
+            RESULT = (Y+Y) - RESULT
+         END IF
+      END IF
+   END IF
+80 continue
+end SUBROUTINE CALERF_r8
+
+!------------------------------------------------------------------------------------------
+
+SUBROUTINE CALERF_r4(ARG, RESULT, JINT)
+
+   !------------------------------------------------------------------
+   !  This version uses 4-byte reals
+   !------------------------------------------------------------------
+   integer, parameter :: rk = r4
+
+   ! arguments
+   real(rk), intent(in)  :: arg
+   integer,  intent(in)  :: jint
+   real(rk), intent(out) :: result
+
+   ! local variables
+   INTEGER :: I
+
+   real(rk) :: X, Y, YSQ, XNUM, XDEN, DEL
+
+   !------------------------------------------------------------------
+   !  Mathematical constants
+   !------------------------------------------------------------------
+   real(rk), parameter :: ZERO   = 0.0E0_rk
+   real(rk), parameter :: FOUR   = 4.0E0_rk
+   real(rk), parameter :: ONE    = 1.0E0_rk
+   real(rk), parameter :: HALF   = 0.5E0_rk
+   real(rk), parameter :: TWO    = 2.0E0_rk
+   real(rk), parameter :: SQRPI  = 5.6418958354775628695E-1_rk
+   real(rk), parameter :: THRESH = 0.46875E0_rk
+   real(rk), parameter :: SIXTEN = 16.0E0_rk
+
+   !------------------------------------------------------------------
+   !  Machine-dependent constants: IEEE single precision values
+   !------------------------------------------------------------------
+   real(rk), parameter :: XINF   =  3.40E+38_r4
+   real(rk), parameter :: XNEG   = -9.382E0_r4
+   real(rk), parameter :: XSMALL =  5.96E-8_r4 
+   real(rk), parameter :: XBIG   =  9.194E0_r4
+   real(rk), parameter :: XHUGE  =  2.90E3_r4
+   real(rk), parameter :: XMAX   =  4.79E37_r4
+
+   !------------------------------------------------------------------
+   !  Coefficients for approximation to  erf  in first interval
+   !------------------------------------------------------------------
+   real(rk), parameter :: A(5) = (/ 3.16112374387056560E00_rk, 1.13864154151050156E02_rk, &
+                                    3.77485237685302021E02_rk, 3.20937758913846947E03_rk, &
+                                    1.85777706184603153E-1_rk /)
+   real(rk), parameter :: B(4) = (/ 2.36012909523441209E01_rk, 2.44024637934444173E02_rk, &
+                                    1.28261652607737228E03_rk, 2.84423683343917062E03_rk /)
+
+   !------------------------------------------------------------------
+   !  Coefficients for approximation to  erfc  in second interval
+   !------------------------------------------------------------------
+   real(rk), parameter :: C(9) = (/ 5.64188496988670089E-1_rk, 8.88314979438837594E00_rk, &
+                                    6.61191906371416295E01_rk, 2.98635138197400131E02_rk, &
+                                    8.81952221241769090E02_rk, 1.71204761263407058E03_rk, &
+                                    2.05107837782607147E03_rk, 1.23033935479799725E03_rk, &
+                                    2.15311535474403846E-8_rk /)
+   real(rk), parameter :: D(8) = (/ 1.57449261107098347E01_rk, 1.17693950891312499E02_rk, &
+                                    5.37181101862009858E02_rk, 1.62138957456669019E03_rk, &
+                                    3.29079923573345963E03_rk, 4.36261909014324716E03_rk, &
+                                    3.43936767414372164E03_rk, 1.23033935480374942E03_rk /)
+
+   !------------------------------------------------------------------
+   !  Coefficients for approximation to  erfc  in third interval
+   !------------------------------------------------------------------
+   real(rk), parameter :: P(6) = (/ 3.05326634961232344E-1_rk, 3.60344899949804439E-1_rk, &
+                                    1.25781726111229246E-1_rk, 1.60837851487422766E-2_rk, &
+                                    6.58749161529837803E-4_rk, 1.63153871373020978E-2_rk /)
+   real(rk), parameter :: Q(5) = (/ 2.56852019228982242E00_rk, 1.87295284992346047E00_rk, &
+                                    5.27905102951428412E-1_rk, 6.05183413124413191E-2_rk, &
+                                    2.33520497626869185E-3_rk /)
+
+   !------------------------------------------------------------------
+   X = ARG
+   Y = ABS(X)
+   IF (Y .LE. THRESH) THEN
+      !------------------------------------------------------------------
+      !  Evaluate  erf  for  |X| <= 0.46875
+      !------------------------------------------------------------------
+      YSQ = ZERO
+      IF (Y .GT. XSMALL) YSQ = Y * Y
+      XNUM = A(5)*YSQ
+      XDEN = YSQ
+      DO I = 1, 3
+         XNUM = (XNUM + A(I)) * YSQ
+         XDEN = (XDEN + B(I)) * YSQ
+      end do
+      RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
+      IF (JINT .NE. 0) RESULT = ONE - RESULT
+      IF (JINT .EQ. 2) RESULT = EXP(YSQ) * RESULT
+      GO TO 80
+   ELSE IF (Y .LE. FOUR) THEN
+      !------------------------------------------------------------------
+      !  Evaluate  erfc  for 0.46875 <= |X| <= 4.0
+      !------------------------------------------------------------------
+      XNUM = C(9)*Y
+      XDEN = Y
+      DO I = 1, 7
+         XNUM = (XNUM + C(I)) * Y
+         XDEN = (XDEN + D(I)) * Y
+      end do
+      RESULT = (XNUM + C(8)) / (XDEN + D(8))
+      IF (JINT .NE. 2) THEN
+         YSQ = AINT(Y*SIXTEN)/SIXTEN
+         DEL = (Y-YSQ)*(Y+YSQ)
+         RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
+      END IF
+   ELSE
+      !------------------------------------------------------------------
+      !  Evaluate  erfc  for |X| > 4.0
+      !------------------------------------------------------------------
+      RESULT = ZERO
+      IF (Y .GE. XBIG) THEN
+         IF ((JINT .NE. 2) .OR. (Y .GE. XMAX)) GO TO 30
+         IF (Y .GE. XHUGE) THEN
+            RESULT = SQRPI / Y
+            GO TO 30
+         END IF
+      END IF
+      YSQ = ONE / (Y * Y)
+      XNUM = P(6)*YSQ
+      XDEN = YSQ
+      DO I = 1, 4
+         XNUM = (XNUM + P(I)) * YSQ
+         XDEN = (XDEN + Q(I)) * YSQ
+      end do
+      RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
+      RESULT = (SQRPI -  RESULT) / Y
+      IF (JINT .NE. 2) THEN
+         YSQ = AINT(Y*SIXTEN)/SIXTEN
+         DEL = (Y-YSQ)*(Y+YSQ)
+         RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
+      END IF
+   END IF
+30 continue
+   !------------------------------------------------------------------
+   !  Fix up for negative argument, erf, etc.
+   !------------------------------------------------------------------
+   IF (JINT .EQ. 0) THEN
+      RESULT = (HALF - RESULT) + HALF
+      IF (X .LT. ZERO) RESULT = -RESULT
+   ELSE IF (JINT .EQ. 1) THEN
+      IF (X .LT. ZERO) RESULT = TWO - RESULT
+   ELSE
+      IF (X .LT. ZERO) THEN
+         IF (X .LT. XNEG) THEN
+            RESULT = XINF
+         ELSE
+            YSQ = AINT(X*SIXTEN)/SIXTEN
+            DEL = (X-YSQ)*(X+YSQ)
+            Y = EXP(YSQ*YSQ) * EXP(DEL)
+            RESULT = (Y+Y) - RESULT
+         END IF
+      END IF
+   END IF
+80 continue
+end SUBROUTINE CALERF_r4
+
+!------------------------------------------------------------------------------------------
+
+FUNCTION DERF(X)
+!--------------------------------------------------------------------
+!
+! This subprogram computes approximate values for erf(x).
+!   (see comments heading CALERF).
+!
+!   Author/date: W. J. Cody, January 8, 1985
+!
+!--------------------------------------------------------------------
+   integer, parameter :: rk = r8 ! 8 byte real
+
+   ! argument
+   real(rk), intent(in) :: X
+
+   ! return value
+   real(rk) :: DERF
+
+   ! local variables
+   INTEGER :: JINT = 0
+   !------------------------------------------------------------------
+
+   CALL CALERF_r8(X, DERF, JINT)
+END FUNCTION DERF
+
+!------------------------------------------------------------------------------------------
+
+FUNCTION ERF_r4(X)
+!--------------------------------------------------------------------
+!
+! This subprogram computes approximate values for erf(x).
+!   (see comments heading CALERF).
+!
+!   Author/date: W. J. Cody, January 8, 1985
+!
+!--------------------------------------------------------------------
+   integer, parameter :: rk = r4 ! 4 byte real
+
+   ! argument
+   real(rk), intent(in) :: X
+
+   ! return value
+   real(rk) :: ERF_r4
+
+   ! local variables
+   INTEGER :: JINT = 0
+   !------------------------------------------------------------------
+
+   CALL CALERF_r4(X, ERF_r4, JINT)
+END FUNCTION ERF_r4
+
+!------------------------------------------------------------------------------------------
+
+FUNCTION DERFC(X)
+!--------------------------------------------------------------------
+!
+! This subprogram computes approximate values for erfc(x).
+!   (see comments heading CALERF).
+!
+!   Author/date: W. J. Cody, January 8, 1985
+!
+!--------------------------------------------------------------------
+   integer, parameter :: rk = r8 ! 8 byte real
+
+   ! argument
+   real(rk), intent(in) :: X
+
+   ! return value
+   real(rk) :: DERFC
+
+   ! local variables
+   INTEGER :: JINT = 1
+   !------------------------------------------------------------------
+
+   CALL CALERF_r8(X, DERFC, JINT)
+END FUNCTION DERFC
+
+!------------------------------------------------------------------------------------------
+
+FUNCTION ERFC_r4(X)
+!--------------------------------------------------------------------
+!
+! This subprogram computes approximate values for erfc(x).
+!   (see comments heading CALERF).
+!
+!   Author/date: W. J. Cody, January 8, 1985
+!
+!--------------------------------------------------------------------
+   integer, parameter :: rk = r4 ! 4 byte real
+
+   ! argument
+   real(rk), intent(in) :: X
+
+   ! return value
+   real(rk) :: ERFC_r4
+
+   ! local variables
+   INTEGER :: JINT = 1
+   !------------------------------------------------------------------
+
+   CALL CALERF_r4(X, ERFC_r4, JINT)
+END FUNCTION ERFC_r4
+
+!------------------------------------------------------------------------------------------
+
+FUNCTION DERFCX(X)
+!--------------------------------------------------------------------
+!
+! This subprogram computes approximate values for exp(x*x) * erfc(x).
+!   (see comments heading CALERF).
+!
+!   Author/date: W. J. Cody, March 30, 1987
+!
+!--------------------------------------------------------------------
+   integer, parameter :: rk = r8 ! 8 byte real
+
+   ! argument
+   real(rk), intent(in) :: X
+
+   ! return value
+   real(rk) :: DERFCX
+
+   ! local variables
+   INTEGER :: JINT = 2
+   !------------------------------------------------------------------
+
+   CALL CALERF_r8(X, DERFCX, JINT)
+END FUNCTION DERFCX
+
+!------------------------------------------------------------------------------------------
+
+FUNCTION ERFCX_R4(X)
+!--------------------------------------------------------------------
+!
+! This subprogram computes approximate values for exp(x*x) * erfc(x).
+!   (see comments heading CALERF).
+!
+!   Author/date: W. J. Cody, March 30, 1987
+!
+!--------------------------------------------------------------------
+   integer, parameter :: rk = r4 ! 8 byte real
+
+   ! argument
+   real(rk), intent(in) :: X
+
+   ! return value
+   real(rk) :: ERFCX_R4
+
+   ! local variables
+   INTEGER :: JINT = 2
+   !------------------------------------------------------------------
+
+   CALL CALERF_r4(X, ERFCX_R4, JINT)
+END FUNCTION ERFCX_R4
+
+!------------------------------------------------------------------------------------------
+
+end module error_function
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_esinti.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_esinti.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_esinti.F	(revision 17)
@@ -0,0 +1,77 @@
+#define WRF_PORT
+
+!------------------------------------------------------------------------
+! Based on esinti.F90 from CAM
+! Ported to WRF by William.Gustafson@pnl.gov, Nov. 2009
+! Updated to CESM_1_0_1, Nov. 2010
+!------------------------------------------------------------------------
+
+#ifdef WRF_PORT
+module module_cam_esinti
+
+  implicit none
+
+  private
+  public esinti
+
+contains
+#endif
+
+subroutine esinti(epslon  ,latvap  ,latice  ,rh2o    ,cpair   ,tmelt   )
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! Initialize es lookup tables
+! 
+! Method: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! 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
+!
+#if ( defined WACCM_PHYS)
+   tmn   = 127.16_r8
+#else
+   tmn   = 173.16_r8
+#endif
+   tmx   = 375.16_r8
+   trice =  20.00_r8
+   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
+
+#ifdef WRF_PORT
+end module module_cam_esinti
+#endif
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_gffgch.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_gffgch.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_gffgch.F	(revision 17)
@@ -0,0 +1,157 @@
+#define WRF_PORT
+
+!------------------------------------------------------------------------
+! Based on gffgch.F90 from CAM
+! Ported to WRF by William.Gustafson@pnl.gov, Nov. 2009
+!------------------------------------------------------------------------
+
+#ifdef WRF_PORT
+module module_cam_gffgch
+
+  implicit none
+
+  private
+  public gffgch
+
+contains
+#endif
+
+subroutine gffgch(t       ,es      ,itype   )
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! Computes saturation vapor pressure over water and/or over ice using
+! Goff & Gratch (1946) relationships. 
+! <Say what the routine does> 
+! 
+! 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
+#ifdef WRF_PORT
+   use module_cam_support, only: endrun, &
+                                 iulog
+#else
+   use abortutils,   only: endrun
+   use cam_logfile,  only: iulog
+#endif
+    
+   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(real(itype,r8))
+      itypo = itype
+      itype = 1
+   else
+      tr    = 0.0_r8
+      itypo = itype
+   end if
+   if (tr > 40.0_r8) then
+      write(iulog,900) tr
+#ifdef WRF_PORT
+      call wrf_message(iulog)
+#endif
+      call endrun ('GFFGCH')                ! Abnormal termination
+   end if
+!
+   if(t < (tmelt - tr) .and. itype == 1) go to 10
+!
+! Water
+!
+   ps = 1013.246_r8
+   ts = 373.16_r8
+   e1 = 11.344_r8*(1.0_r8 - t/ts)
+   e2 = -3.49149_r8*(ts/t - 1.0_r8)
+   f1 = -7.90298_r8*(ts/t - 1.0_r8)
+   f2 = 5.02808_r8*log10(ts/t)
+   f3 = -1.3816_r8*(10.0_r8**e1 - 1.0_r8)/10000000.0_r8
+   f4 = 8.1328_r8*(10.0_r8**e2 - 1.0_r8)/1000.0_r8
+   f5 = log10(ps)
+   f  = f1 + f2 + f3 + f4 + f5
+   es = (10.0_r8**f)*100.0_r8
+   eswtr = es
+!
+   if(t >= tmelt .or. itype == 0) go to 20
+!
+! Ice
+!
+10 continue
+   t0    = tmelt
+   term1 = 2.01889049_r8/(t0/t)
+   term2 = 3.56654_r8*log(t0/t)
+   term3 = 20.947031_r8*(t0/t)
+   es    = 575.185606e10_r8*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_r8 - 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
+
+#ifdef WRF_PORT
+end module module_cam_gffgch
+#endif
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_molec_diff.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_molec_diff.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_molec_diff.F	(revision 17)
@@ -0,0 +1,403 @@
+#define WRF_PORT
+
+module molec_diff
+  
+  !------------------------------------------------------------------------------------------------- !
+  ! Module to compute molecular diffusivity for various constituents                                 !
+  !                                                                                                  !    
+  ! Public interfaces :                                                                              !
+  !                                                                                                  !
+  !    init_molec_diff           Initializes time independent coefficients                           !
+  !    init_timestep_molec_diff  Time-step initialization for molecular diffusivity                  ! 
+  !    compute_molec_diff        Computes constituent-independent terms for moleculuar diffusivity   !
+  !    vd_lu_qdecomp             Computes constituent-dependent terms for moleculuar diffusivity and !
+  !                              updates terms in the triadiagonal matrix used for the implicit      !
+  !                              solution of the diffusion equation                                  !
+  !                                                                                                  !
+  !---------------------------Code history---------------------------------------------------------- !
+  ! Modularized     :  J. McCaa, September 2004                                                      !
+  ! Lastly Arranged :  S. Park,  January.  2010                                                      !
+  !------------------------------------------------------------------------------------------------- !
+    
+#ifndef WRF_PORT 
+    use perf_mod
+    use cam_logfile,  only : iulog
+#else
+  use module_cam_support,   only: iulog, t_stopf, t_startf
+#endif
+
+  implicit none
+  private       
+  save
+
+  public init_molec_diff
+#ifndef WRF_PORT   
+  public init_timestep_molec_diff
+#endif
+  public compute_molec_diff 
+  public vd_lu_qdecomp
+
+  ! ---------- !
+  ! Parameters ! 
+  ! ---------- !
+
+  integer,  parameter   :: r8 = selected_real_kind(12) ! 8 byte real
+  
+  real(r8), parameter   :: km_fac = 3.55E-7_r8         ! Molecular viscosity constant [ unit ? ]
+  real(r8), parameter   :: pr_num = 1._r8              ! Prandtl number [ no unit ]
+  real(r8), parameter   :: pwr    = 2._r8/3._r8        ! Exponentiation factor [ unit ? ]
+  real(r8), parameter   :: d0     = 1.52E20_r8         ! Diffusion factor [ m-1 s-1 ] molec sqrt(kg/kmol/K) [ unit ? ]
+                                                       ! Aerononmy, Part B, Banks and Kockarts (1973), p39
+                                                       ! Note text cites 1.52E18 cm-1 ...
+
+  real(r8)              :: rair                        ! Gas constant for dry air
+  real(r8)              :: mw_dry                      ! Molecular weight of dry air
+  real(r8)              :: n_avog                      ! Avogadro's number [ molec/kmol ]
+  real(r8)              :: gravit     
+  real(r8)              :: cpair
+  real(r8)              :: kbtz                        ! Boltzman constant
+
+  integer               :: ntop_molec                  ! Top    interface level to which molecular vertical diffusion is applied ( = 1 )
+  integer               :: nbot_molec                  ! Bottom interface level to which molecular vertical diffusion is applied ( = pver )
+  real(r8), allocatable :: mw_fac(:)                   ! sqrt(1/M_q + 1/M_d) in constituent diffusivity [  unit ? ]
+  
+  contains
+
+  !============================================================================ !
+  !                                                                             !
+  !============================================================================ !
+
+  subroutine init_molec_diff( kind, ncnst, rair_in, ntop_molec_in, nbot_molec_in, &
+                              mw_dry_in, n_avog_in, gravit_in, cpair_in, kbtz_in )
+    
+    use constituents,     only : cnst_mw
+    use upper_bc,         only : ubc_init
+    
+    integer,  intent(in)  :: kind           ! Kind of reals being passed in
+    integer,  intent(in)  :: ncnst          ! Number of constituents
+    integer,  intent(in)  :: ntop_molec_in  ! Top interface level to which molecular vertical diffusion is applied ( = 1 )
+    integer,  intent(in)  :: nbot_molec_in  ! Bottom interface level to which molecular vertical diffusion is applied.
+    real(r8), intent(in)  :: rair_in
+    real(r8), intent(in)  :: mw_dry_in      ! Molecular weight of dry air
+    real(r8), intent(in)  :: n_avog_in      ! Avogadro's number [ molec/kmol ]
+    real(r8), intent(in)  :: gravit_in
+    real(r8), intent(in)  :: cpair_in
+    real(r8), intent(in)  :: kbtz_in        ! Boltzman constant
+    integer               :: m              ! Constituent index
+    
+    if( kind .ne. r8 ) then
+        write(iulog,*) 'KIND of reals passed to init_molec_diff -- exiting.'
+        stop 'init_molec_diff'
+    endif
+    
+    rair       = rair_in
+    mw_dry     = mw_dry_in
+    n_avog     = n_avog_in
+    gravit     = gravit_in
+    cpair      = cpair_in
+    kbtz       = kbtz_in
+    ntop_molec = ntop_molec_in
+    nbot_molec = nbot_molec_in
+    
+  ! Initialize upper boundary condition variables
+
+    call ubc_init()
+
+  ! Molecular weight factor in constitutent diffusivity
+  ! ***** FAKE THIS FOR NOW USING MOLECULAR WEIGHT OF DRY AIR FOR ALL TRACERS ****
+ 
+    allocate(mw_fac(ncnst))
+    do m = 1, ncnst
+       mw_fac(m) = d0 * mw_dry * sqrt(1._r8/mw_dry + 1._r8/cnst_mw(m)) / n_avog
+    end do
+
+  end subroutine init_molec_diff
+
+  !============================================================================ !
+  !                                                                             !
+  !============================================================================ !
+#ifndef WRF_PORT 
+  subroutine init_timestep_molec_diff(state)
+    !--------------------------- !
+    ! Timestep dependent setting ! 
+    !--------------------------- !
+    use upper_bc,     only : ubc_timestep_init
+    use physics_types,only: physics_state
+    use ppgrid,       only: begchunk, endchunk
+
+    type(physics_state), intent(in) :: state(begchunk:endchunk)                 
+
+    call ubc_timestep_init( state)
+    
+  end subroutine init_timestep_molec_diff
+#endif
+  !============================================================================ !
+  !                                                                             !
+  !============================================================================ !
+
+  integer function compute_molec_diff( lchnk       ,                                                                      &
+                                       pcols       , pver       , ncnst      , ncol     , t      , pmid   , pint        , &
+                                       zi          , ztodt      , kvh        , kvm      , tint   , rhoi   , tmpi2       , &
+                                       kq_scal     , ubc_t      , ubc_mmr    , dse_top  , cc_top , cd_top , cnst_mw_out , &
+                                       cnst_fixed_ubc_out , mw_fac_out , ntop_molec_out , nbot_molec_out )
+    
+    use upper_bc,        only : ubc_get_vals
+    use constituents,    only : cnst_mw, cnst_fixed_ubc
+
+    ! --------------------- !
+    ! Input-Output Argument !
+    ! --------------------- !
+    
+    integer,  intent(in)    :: pcols
+    integer,  intent(in)    :: pver
+    integer,  intent(in)    :: ncnst
+    integer,  intent(in)    :: ncol                      ! Number of atmospheric columns
+    integer,  intent(in)    :: lchnk                     ! Chunk identifier
+    real(r8), intent(in)    :: t(pcols,pver)             ! Temperature input
+    real(r8), intent(in)    :: pmid(pcols,pver)          ! Midpoint pressures
+    real(r8), intent(in)    :: pint(pcols,pver+1)        ! Interface pressures
+    real(r8), intent(in)    :: zi(pcols,pver+1)          ! Interface heights
+    real(r8), intent(in)    :: ztodt                     ! 2 delta-t
+    
+    real(r8), intent(inout) :: kvh(pcols,pver+1)         ! Diffusivity for heat
+    real(r8), intent(inout) :: kvm(pcols,pver+1)         ! Viscosity ( diffusivity for momentum )
+    real(r8), intent(inout) :: tint(pcols,pver+1)        ! Interface temperature
+    real(r8), intent(inout) :: rhoi(pcols,pver+1)        ! Density ( rho ) at interfaces
+    real(r8), intent(inout) :: tmpi2(pcols,pver+1)       ! dt*(g*rho)**2/dp at interfaces
+
+    real(r8), intent(out)   :: kq_scal(pcols,pver+1)     ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity
+    real(r8), intent(out)   :: ubc_mmr(pcols,ncnst)      ! Upper boundary mixing ratios [ kg/kg ]
+    real(r8), intent(out)   :: cnst_mw_out(ncnst)
+    logical,  intent(out)   :: cnst_fixed_ubc_out(ncnst)
+    real(r8), intent(out)   :: mw_fac_out(ncnst)
+    real(r8), intent(out)   :: dse_top(pcols)            ! dse on top boundary
+    real(r8), intent(out)   :: cc_top(pcols)             ! Lower diagonal at top interface
+    real(r8), intent(out)   :: cd_top(pcols)             ! cc_top * dse ubc value
+    integer,  intent(out)   :: ntop_molec_out   
+    integer,  intent(out)   :: nbot_molec_out   
+
+    ! --------------- ! 
+    ! Local variables !
+    ! --------------- !
+
+    integer                 :: m                          ! Constituent index
+    integer                 :: i                          ! Column index
+    integer                 :: k                          ! Level index
+    real(r8)                :: mkvisc                     ! Molecular kinematic viscosity c*tint**(2/3)/rho
+    real(r8)                :: ubc_t(pcols)               ! Upper boundary temperature (K)
+
+    ! ----------------------- !
+    ! Main Computation Begins !
+    ! ----------------------- !
+
+  ! Get upper boundary values
+
+    call ubc_get_vals( lchnk, ncol, ntop_molec, pint, zi, ubc_t, ubc_mmr )
+
+  ! Below are already computed, just need to be copied for output
+
+    cnst_mw_out(:ncnst)        = cnst_mw(:ncnst)
+    cnst_fixed_ubc_out(:ncnst) = cnst_fixed_ubc(:ncnst)
+    mw_fac_out(:ncnst)         = mw_fac(:ncnst)
+    ntop_molec_out             = ntop_molec
+    nbot_molec_out             = nbot_molec
+    
+  ! Density and related factors for moecular diffusion and ubc.
+  ! Always have a fixed upper boundary T if molecular diffusion is active. Why ?
+
+    tint (:ncol,ntop_molec) = ubc_t(:ncol)
+    rhoi (:ncol,ntop_molec) = pint(:ncol,ntop_molec) / ( rair * tint(:ncol,ntop_molec) )
+    tmpi2(:ncol,ntop_molec) = ztodt * ( gravit * rhoi(:ncol,ntop_molec))**2 &
+                                    / ( pmid(:ncol,ntop_molec) - pint(:ncol,ntop_molec) )
+    
+  ! Compute molecular kinematic viscosity, heat diffusivity and factor for constituent diffusivity
+  ! This is a key part of the code.
+
+    kq_scal(:ncol,1:ntop_molec-1) = 0._r8
+    do k = ntop_molec, nbot_molec
+       do i = 1, ncol
+          mkvisc       = km_fac * tint(i,k)**pwr / rhoi(i,k)
+          kvm(i,k)     = kvm(i,k) + mkvisc
+          kvh(i,k)     = kvh(i,k) + mkvisc * pr_num
+          kq_scal(i,k) = sqrt(tint(i,k)) / rhoi(i,k)
+       end do
+    end do
+    kq_scal(:ncol,nbot_molec+1:pver+1) = 0._r8
+    
+  ! Top boundary condition for dry static energy
+
+    dse_top(:ncol) = cpair * tint(:ncol,ntop_molec) + gravit * zi(:ncol,ntop_molec)
+
+  ! Top value of cc for dry static energy
+
+    do i = 1, ncol
+       cc_top(i) = ztodt * gravit**2 * rhoi(i,ntop_molec) * km_fac * ubc_t(i)**pwr / &
+                   ( ( pint(i,2) - pint(i,1) ) * ( pmid(i,1) - pint(i,1) ) )
+    enddo
+    cd_top(:ncol) = cc_top(:ncol) * dse_top(:ncol)
+    
+    compute_molec_diff = 1
+    return
+  end function compute_molec_diff
+
+  !============================================================================ !
+  !                                                                             !
+  !============================================================================ !
+
+  integer function vd_lu_qdecomp( pcols , pver   , ncol       , fixed_ubc  , mw     , ubc_mmr , &
+                                  kv    , kq_scal, mw_facm    , tmpi       , rpdel  ,           &
+                                  ca    , cc     , dnom       , ze         , rhoi   ,           &
+                                  tint  , ztodt  , ntop_molec , nbot_molec , cd_top )
+
+    !------------------------------------------------------------------------------ !
+    ! Add the molecular diffusivity to the turbulent diffusivity for a consitutent. !
+    ! Update the superdiagonal (ca(k)), diagonal (cb(k)) and subdiagonal (cc(k))    !
+    ! coefficients of the tridiagonal diffusion matrix, also ze and denominator.    !
+    !------------------------------------------------------------------------------ !
+
+    ! ---------------------- !
+    ! Input-Output Arguments !
+    ! ---------------------- !
+
+    integer,  intent(in)    :: pcols
+    integer,  intent(in)    :: pver
+    integer,  intent(in)    :: ncol                  ! Number of atmospheric columns
+
+    integer,  intent(in)    :: ntop_molec
+    integer,  intent(in)    :: nbot_molec
+
+    logical,  intent(in)    :: fixed_ubc             ! Fixed upper boundary condition flag
+    real(r8), intent(in)    :: kv(pcols,pver+1)      ! Eddy diffusivity
+    real(r8), intent(in)    :: kq_scal(pcols,pver+1) ! Molecular diffusivity ( kq_fac*sqrt(T)*m_d/rho )
+    real(r8), intent(in)    :: mw                    ! Molecular weight for this constituent
+    real(r8), intent(in)    :: ubc_mmr(pcols)        ! Upper boundary mixing ratios [ kg/kg ]
+    real(r8), intent(in)    :: mw_facm               ! sqrt(1/M_q + 1/M_d) for this constituent
+    real(r8), intent(in)    :: tmpi(pcols,pver+1)    ! dt*(g/R)**2/dp*pi(k+1)/(.5*(tm(k+1)+tm(k))**2
+    real(r8), intent(in)    :: rpdel(pcols,pver)     ! 1./pdel ( thickness bet interfaces )
+    real(r8), intent(in)    :: rhoi(pcols,pver+1)    ! Density at interfaces [ kg/m3 ]
+    real(r8), intent(in)    :: tint(pcols,pver+1)    ! Interface temperature [ K ]
+    real(r8), intent(in)    :: ztodt                 ! 2 delta-t [ s ]
+
+    real(r8), intent(inout) :: ca(pcols,pver)        ! -Upper diagonal
+    real(r8), intent(inout) :: cc(pcols,pver)        ! -Lower diagonal
+    real(r8), intent(inout) :: dnom(pcols,pver)      ! 1./(1. + ca(k) + cc(k) - cc(k)*ze(k-1)) , 1./(b(k) - c(k)*e(k-1))
+    real(r8), intent(inout) :: ze(pcols,pver)        ! Term in tri-diag. matrix system
+
+    real(r8), intent(out)   :: cd_top(pcols)         ! Term for updating top level with ubc
+
+    ! --------------- !
+    ! Local Variables !
+    ! --------------- !
+
+    integer                 :: i                     ! Longitude index
+    integer                 :: k, kp1                ! Vertical indicies
+
+    real(r8)                :: rghd(pcols,pver+1)    ! (1/H_i - 1/H) * (rho*g)^(-1)
+    real(r8)                :: kmq(ncol)             ! Molecular diffusivity for constituent
+    real(r8)                :: wrk0(ncol)            ! Work variable
+    real(r8)                :: wrk1(ncol)            ! Work variable
+
+    real(r8)                :: cb(pcols,pver)        ! - Diagonal
+    real(r8)                :: kvq(pcols,pver+1)     ! Output vertical diffusion coefficient
+
+    ! ----------------------- !
+    ! Main Computation Begins !
+    ! ----------------------- !   
+
+    ! --------------------------------------------------------------------- !
+    ! Determine superdiagonal (ca(k)) and subdiagonal (cc(k)) coeffs of the !
+    ! tridiagonal diffusion matrix. The diagonal elements  (cb=1+ca+cc) are !
+    ! a combination of ca and cc; they are not required by the solver.      !
+    !---------------------------------------------------------------------- !
+
+    call t_startf('vd_lu_qdecomp')
+
+    kvq(:,:)  = 0._r8
+    cd_top(:) = 0._r8
+
+  ! Compute difference between scale heights of constituent and dry air
+
+    do k = ntop_molec, nbot_molec
+       do i = 1, ncol
+          rghd(i,k) = gravit / ( kbtz * n_avog * tint(i,k) ) * ( mw - mw_dry )
+          rghd(i,k) = ztodt * gravit * rhoi(i,k) * rghd(i,k) 
+       enddo
+    enddo
+
+    !-------------------- !
+    ! Molecular diffusion !
+    !-------------------- !
+
+    do k = nbot_molec - 1, ntop_molec, -1
+       kp1 = k + 1
+       kmq(:ncol)  = kq_scal(:ncol,kp1) * mw_facm
+       wrk0(:ncol) = ( kv(:ncol,kp1) + kmq(:ncol) ) * tmpi(:ncol,kp1)
+       wrk1(:ncol) = kmq(:ncol) * 0.5_r8 * rghd(:ncol,kp1)
+     ! Add species separation term
+       ca(:ncol,k  )  = ( wrk0(:ncol) - wrk1(:ncol) ) * rpdel(:ncol,k)
+       cc(:ncol,kp1)  = ( wrk0(:ncol) + wrk1(:ncol) ) * rpdel(:ncol,kp1)
+       kvq(:ncol,kp1) = kmq(:ncol)
+    end do
+
+    if( fixed_ubc ) then
+        cc(:ncol,ntop_molec) = kq_scal(:ncol,ntop_molec) * mw_facm                 &
+                             * ( tmpi(:ncol,ntop_molec) + rghd(:ncol,ntop_molec) ) &
+                             * rpdel(:ncol,ntop_molec)
+    end if
+
+  ! Calculate diagonal elements
+
+    do k = nbot_molec - 1, ntop_molec + 1, -1
+       kp1 = k + 1
+       cb(:ncol,k) = 1._r8 + ca(:ncol,k) + cc(:ncol,k)                   &
+                   + rpdel(:ncol,k) * ( kvq(:ncol,kp1) * rghd(:ncol,kp1) &
+                   - kvq(:ncol,k) * rghd(:ncol,k) )
+       kvq(:ncol,kp1) = kv(:ncol,kp1) + kvq(:ncol,kp1)
+    end do
+
+    k   = ntop_molec
+    kp1 = k + 1
+    if( fixed_ubc ) then
+        cb(:ncol,k) = 1._r8 + ca(:ncol,k)                                 &
+                    + rpdel(:ncol,k) * kvq(:ncol,kp1) * rghd(:ncol,kp1)   &
+                    + kq_scal(:ncol,ntop_molec) * mw_facm                 &
+                    * ( tmpi(:ncol,ntop_molec) - rghd(:ncol,ntop_molec) ) &
+                    * rpdel(:ncol,ntop_molec)
+    else
+        cb(:ncol,k) = 1._r8 + ca(:ncol,k) &
+                    + rpdel(:ncol,k) * kvq(:ncol,kp1) * rghd(:ncol,kp1)
+    end if
+
+    k   = nbot_molec
+    cb(:ncol,k) = 1._r8 + cc(:ncol,k) + ca(:ncol,k) &
+                - rpdel(:ncol,k) * kvq(:ncol,k)*rghd(:ncol,k)
+    do k = 1, nbot_molec + 1, -1
+       cb(:ncol,k) = 1._r8 + ca(:ncol,k) + cc(:ncol,k)
+    end do
+
+  ! Compute term for updating top level mixing ratio for ubc
+
+    if( fixed_ubc ) then
+        cd_top(:ncol) = cc(:ncol,ntop_molec) * ubc_mmr(:ncol)
+    end if
+
+    !-------------------------------------------------------- !
+    ! Calculate e(k).                                         !
+    ! This term is required in solution of tridiagonal matrix ! 
+    ! defined by implicit diffusion equation.                 !
+    !-------------------------------------------------------- !
+
+    do k = nbot_molec, ntop_molec + 1, -1
+       dnom(:ncol,k) = 1._r8 / ( cb(:ncol,k) - ca(:ncol,k) * ze(:ncol,k+1) )
+       ze(:ncol,k)   = cc(:ncol,k) * dnom(:ncol,k)
+    end do
+    k = ntop_molec
+    dnom(:ncol,k) = 1._r8 / ( cb(:ncol,k) - ca(:ncol,k) * ze(:ncol,k+1) )
+
+    vd_lu_qdecomp = 1
+    call t_stopf('vd_lu_qdecomp')
+    return
+
+  end function vd_lu_qdecomp
+
+  end module molec_diff
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_physconst.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_physconst.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_physconst.F	(revision 17)
@@ -0,0 +1,183 @@
+#define WRF_PORT
+
+module physconst
+!------------------------------------------------------------------------
+! Based on physconst.F90 from CAM
+! Ported to WRF by William.Gustafson@pnl.gov, Nov. 2009
+! Updated to version from CESM 1.0.1 Nov. 2010
+!------------------------------------------------------------------------
+
+   ! Physical constants.  Use CCSM shared values whenever available.
+
+   use shr_kind_mod, only: r8 => shr_kind_r8
+   use shr_const_mod, only: shr_const_g,      shr_const_stebol, shr_const_tkfrz,  &
+                            shr_const_mwdair, shr_const_rdair,  shr_const_mwwv,   &
+                            shr_const_latice, shr_const_latvap, shr_const_cpdair, &
+                            shr_const_rhofw,  shr_const_cpwv,   shr_const_rgas,   &
+                            shr_const_karman, shr_const_pstd,   shr_const_rhodair,&
+                            shr_const_avogad, shr_const_boltz,  shr_const_cpfw,   &
+                            shr_const_rwv,    shr_const_zvir,   shr_const_pi,     &
+                            shr_const_rearth, shr_const_sday,   shr_const_cday,   &
+                            shr_const_spval         
+   implicit none
+   private
+   public  :: physconst_readnl
+   save
+   ! Constants based off share code or defined in physconst
+
+   real(r8), public, parameter :: avogad      = shr_const_avogad     ! Avogadro's number (molecules/kmole)
+   real(r8), public, parameter :: boltz       = shr_const_boltz      ! Boltzman's constant (J/K/molecule)
+   real(r8), public, parameter :: cday        = shr_const_cday       ! sec in calendar day ~ sec
+   real(r8), public, parameter :: cpair       = shr_const_cpdair     ! specific heat of dry air (J/K/kg)
+   real(r8), public, parameter :: cpliq       = shr_const_cpfw       ! specific heat of fresh h2o (J/K/kg)
+   real(r8), public, parameter :: karman      = shr_const_karman     ! Von Karman constant
+   real(r8), public, parameter :: latice      = shr_const_latice     ! Latent heat of fusion (J/kg)
+   real(r8), public, parameter :: latvap      = shr_const_latvap     ! Latent heat of vaporization (J/kg)
+   real(r8), public, parameter :: pi          = shr_const_pi         ! 3.14...
+   real(r8), public, parameter :: pstd        = shr_const_pstd       ! Standard pressure (Pascals)
+   real(r8), public, parameter :: r_universal = shr_const_rgas       ! Universal gas constant (J/K/kmol)
+   real(r8), public, parameter :: rhoh2o      = shr_const_rhofw      ! Density of liquid water (STP)
+   real(r8), public, parameter :: spval       = shr_const_spval      !special value 
+   real(r8), public, parameter :: stebol      = shr_const_stebol     ! Stefan-Boltzmann's constant (W/m^2/K^4)
+   real(r8), public, parameter :: tmelt       = shr_const_tkfrz      ! Freezing point of water (K)
+
+   real(r8), public, parameter :: c0          = 2.99792458e8_r8      ! Speed of light in a vacuum (m/s)
+   real(r8), public, parameter :: planck      = 6.6260755e-34_r8     ! Planck's constant (J.s)
+
+   ! Molecular weights
+   real(r8), public, parameter :: mwco2       =  44._r8             ! molecular weight co2
+   real(r8), public, parameter :: mwn2o       =  44._r8             ! molecular weight n2o
+   real(r8), public, parameter :: mwch4       =  16._r8             ! molecular weight ch4
+   real(r8), public, parameter :: mwf11       = 136._r8             ! molecular weight cfc11
+   real(r8), public, parameter :: mwf12       = 120._r8             ! molecular weight cfc12
+   real(r8), public, parameter :: mwo3        =  48._r8             ! molecular weight O3
+   real(r8), public, parameter :: mwso2       =  64._r8
+   real(r8), public, parameter :: mwso4       =  96._r8
+   real(r8), public, parameter :: mwh2o2      =  34._r8
+   real(r8), public, parameter :: mwdms       =  62._r8
+
+
+   ! modifiable physical constants for aquaplanet
+
+   real(r8), public           :: gravit       = shr_const_g     ! gravitational acceleration (m/s**2)
+   real(r8), public           :: sday         = shr_const_sday  ! sec in siderial day ~ sec
+   real(r8), public           :: mwh2o        = shr_const_mwwv  ! molecular weight h2o
+   real(r8), public           :: cpwv         = shr_const_cpwv  ! specific heat of water vapor (J/K/kg)
+   real(r8), public           :: mwdry        = shr_const_mwdair! molecular weight dry air
+   real(r8), public           :: rearth       = shr_const_rearth! radius of earth (m)
+
+!---------------  Variables below here are derived from those above -----------------------
+
+   real(r8), public           :: rga          = 1._r8/shr_const_g                 ! reciprocal of gravit
+   real(r8), public           :: ra           = 1._r8/shr_const_rearth            ! reciprocal of earth radius
+   real(r8), public           :: omega        = 2.0_R8*shr_const_pi/shr_const_sday! earth rot ~ rad/sec
+   real(r8), public           :: rh2o         = shr_const_rgas/shr_const_mwwv     ! Water vapor gas constant ~ J/K/kg
+   real(r8), public           :: rair         = shr_const_rdair   ! Dry air gas constant     ~ J/K/kg
+   real(r8), public           :: epsilo       = shr_const_mwwv/shr_const_mwdair   ! ratio of h2o to dry air molecular weights 
+   real(r8), public           :: zvir         = (shr_const_rwv/shr_const_rdair)-1.0_R8 ! (rh2o/rair) - 1
+   real(r8), public           :: cpvir        = (shr_const_cpwv/shr_const_cpdair)-1.0_R8 ! CPWV/CPDAIR - 1.0
+   real(r8), public           :: rhodair      = shr_const_pstd/(shr_const_rdair*shr_const_tkfrz)
+   real(r8), public           :: cappa        = (shr_const_rgas/shr_const_mwdair)/shr_const_cpdair  ! R/Cp
+   real(r8), public           :: ez           ! Coriolis expansion coeff -> omega/sqrt(0.375)   
+   real(r8), public           :: Cpd_on_Cpv   = shr_const_cpdair/shr_const_cpwv
+                         
+
+!================================================================================================
+contains
+!================================================================================================
+
+   ! Read namelist variables.
+   subroutine physconst_readnl(nlfile)
+#ifndef WRF_PORT
+      use namelist_utils,  only: find_group_name
+      use units,           only: getunit, freeunit
+      use mpishorthand
+      use spmd_utils,      only: masterproc
+      use abortutils,      only: endrun
+      use cam_logfile,     only: iulog
+#endif      
+      character(len=*), intent(in) :: nlfile  ! filepath for file containing namelist input
+#ifndef WRF_PORT
+      ! Local variables
+      integer :: unitn, ierr
+      character(len=*), parameter :: subname = 'physconst_readnl'
+      logical       newg, newsday, newmwh2o, newcpwv, newmwdry, newrearth
+
+      ! Physical constants needing to be reset (ie. for aqua planet experiments)
+      namelist /physconst_nl/  cpwv, gravit, mwdry, mwh2o, rearth, sday
+
+      !-----------------------------------------------------------------------------
+
+      if (masterproc) then
+         unitn = getunit()
+         open( unitn, file=trim(nlfile), status='old' )
+         call find_group_name(unitn, 'physconst_nl', status=ierr)
+         if (ierr == 0) then
+            read(unitn, physconst_nl, iostat=ierr)
+            if (ierr /= 0) then
+               call endrun(subname // ':: ERROR reading namelist')
+            end if
+         end if
+         close(unitn)
+         call freeunit(unitn)
+      end if
+
+#ifdef SPMD
+      ! Broadcast namelist variables
+      call mpibcast(cpwv,      1,                   mpir8,   0, mpicom)
+      call mpibcast(gravit,    1,                   mpir8,   0, mpicom)
+      call mpibcast(mwdry,     1,                   mpir8,   0, mpicom)
+      call mpibcast(mwh2o,     1,                   mpir8,   0, mpicom)
+      call mpibcast(rearth,    1,                   mpir8,   0, mpicom)
+      call mpibcast(sday,      1,                   mpir8,   0, mpicom)
+#endif
+
+
+      
+      newg     =  gravit .ne. shr_const_g 
+      newsday  =  sday   .ne. shr_const_sday
+      newmwh2o =  mwh2o  .ne. shr_const_mwwv
+      newcpwv  =  cpwv   .ne. shr_const_cpwv
+      newmwdry =  mwdry  .ne. shr_const_mwdair
+      newrearth=  rearth .ne. shr_const_rearth
+      
+      
+      
+      if (newg .or. newsday .or. newmwh2o .or. newcpwv .or. newmwdry .or. newrearth) then
+         if (masterproc) then
+            write(iulog,*)'****************************************************************************'
+            write(iulog,*)'***    New Physical Constant Values set via namelist                     ***'
+            write(iulog,*)'***                                                                      ***'
+            write(iulog,*)'***    Physical Constant    Old Value                  New Value         ***'
+            if (newg)       write(iulog,*)'***       GRAVITY   ',shr_const_g,gravit,'***'
+            if (newsday)    write(iulog,*)'***       SDAY      ',shr_const_sday,sday,'***'
+            if (newmwh2o)   write(iulog,*)'***       MWH20     ',shr_const_mwwv,mwh2o,'***'
+            if (newcpwv)    write(iulog,*)'***       CPWV      ',shr_const_cpwv,cpwv,'***'
+            if (newmwdry)   write(iulog,*)'***       MWDRY     ',shr_const_mwdair,mwdry,'***'
+            if (newrearth)  write(iulog,*)'***       REARTH    ',shr_const_rearth,rearth,'***'
+            write(iulog,*)'****************************************************************************'
+         end if
+         rga         = 1._r8/gravit 
+         ra          = 1._r8/rearth
+         omega       = 2.0_R8*pi/sday
+         cpvir       = cpwv/cpair - 1._r8
+         epsilo      = mwh2o/mwdry      
+         
+         !  rair and rh2o have to be defined before any of the variables that use them
+         
+         rair        = r_universal/mwdry
+         rh2o        = r_universal/mwh2o  
+         
+         cappa       = rair/cpair       
+         rhodair     = pstd/(rair*tmelt)
+         zvir        =  (rh2o/rair)-1.0_R8
+         ez          = omega / sqrt(0.375_r8)
+         Cpd_on_Cpv  = cpair/cpwv
+         
+      else	
+         ez          = omega / sqrt(0.375_r8)
+      end if
+#endif      
+    end subroutine physconst_readnl
+
+  end module physconst
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_shr_const_mod.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_shr_const_mod.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_shr_const_mod.F	(revision 17)
@@ -0,0 +1,66 @@
+!------------------------------------------------------------------------
+! Based on shr_const_mod.F90 from CAM
+! Ported to WRF by William.Gustafson@pnl.gov, Nov. 2009
+!------------------------------------------------------------------------
+
+!===============================================================================
+! SVN $Id: shr_const_mod.F90 6749 2007-10-04 20:58:20Z jwolfe $
+! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/branch_tags/cesm1_0_rel_tags/cesm1_0_rel03_share3_100802/shr/shr_const_mod.F90 $
+!===============================================================================
+
+MODULE shr_const_mod
+
+   use shr_kind_mod
+
+   integer(SHR_KIND_IN),parameter,private :: R8 = SHR_KIND_R8 ! rename for local readability only
+
+   !----------------------------------------------------------------------------
+   ! physical constants (all data public)
+   !----------------------------------------------------------------------------
+   public
+
+   real(R8),parameter :: SHR_CONST_PI      = 3.14159265358979323846_R8  ! pi
+   real(R8),parameter :: SHR_CONST_CDAY    = 86400.0_R8      ! sec in calendar day ~ sec
+   real(R8),parameter :: SHR_CONST_SDAY    = 86164.0_R8      ! sec in siderial day ~ sec
+   real(R8),parameter :: SHR_CONST_OMEGA   = 2.0_R8*SHR_CONST_PI/SHR_CONST_SDAY ! earth rot ~ rad/sec
+   real(R8),parameter :: SHR_CONST_REARTH  = 6.37122e6_R8    ! radius of earth ~ m
+   real(R8),parameter :: SHR_CONST_G       = 9.80616_R8      ! acceleration of gravity ~ m/s^2
+
+   real(R8),parameter :: SHR_CONST_STEBOL  = 5.67e-8_R8      ! Stefan-Boltzmann constant ~ W/m^2/K^4
+   real(R8),parameter :: SHR_CONST_BOLTZ   = 1.38065e-23_R8  ! Boltzmann's constant ~ J/K/molecule
+   real(R8),parameter :: SHR_CONST_AVOGAD  = 6.02214e26_R8   ! Avogadro's number ~ molecules/kmole
+   real(R8),parameter :: SHR_CONST_RGAS    = SHR_CONST_AVOGAD*SHR_CONST_BOLTZ       ! Universal gas constant ~ J/K/kmole
+   real(R8),parameter :: SHR_CONST_MWDAIR  = 28.966_R8       ! molecular weight dry air ~ kg/kmole
+   real(R8),parameter :: SHR_CONST_MWWV    = 18.016_R8       ! molecular weight water vapor
+   real(R8),parameter :: SHR_CONST_RDAIR   = SHR_CONST_RGAS/SHR_CONST_MWDAIR        ! Dry air gas constant     ~ J/K/kg
+   real(R8),parameter :: SHR_CONST_RWV     = SHR_CONST_RGAS/SHR_CONST_MWWV          ! Water vapor gas constant ~ J/K/kg
+   real(R8),parameter :: SHR_CONST_ZVIR    = (SHR_CONST_RWV/SHR_CONST_RDAIR)-1.0_R8 ! RWV/RDAIR - 1.0
+   real(R8),parameter :: SHR_CONST_KARMAN  = 0.4_R8          ! Von Karman constant
+   real(R8),parameter :: SHR_CONST_PSTD    = 101325.0_R8     ! standard pressure ~ pascals
+   real(R8),parameter :: SHR_CONST_PDB     = 0.0112372_R8    ! ratio of 13C/12C in Pee Dee Belemnite (C isotope standard)
+ 
+   real(R8),parameter :: SHR_CONST_TKTRIP  = 273.16_R8       ! triple point of fresh water        ~ K
+   real(R8),parameter :: SHR_CONST_TKFRZ   = 273.15_R8       ! freezing T of fresh water          ~ K 
+   real(R8),parameter :: SHR_CONST_TKFRZSW = SHR_CONST_TKFRZ - 1.8_R8 ! freezing T of salt water  ~ K
+
+   real(R8),parameter :: SHR_CONST_RHODAIR = &               ! density of dry air at STP  ~ kg/m^3
+                         SHR_CONST_PSTD/(SHR_CONST_RDAIR*SHR_CONST_TKFRZ)
+   real(R8),parameter :: SHR_CONST_RHOFW   = 1.000e3_R8      ! density of fresh water     ~ kg/m^3
+   real(R8),parameter :: SHR_CONST_RHOSW   = 1.026e3_R8      ! density of sea water       ~ kg/m^3
+   real(R8),parameter :: SHR_CONST_RHOICE  = 0.917e3_R8      ! density of ice             ~ kg/m^3
+   real(R8),parameter :: SHR_CONST_CPDAIR  = 1.00464e3_R8    ! specific heat of dry air   ~ J/kg/K
+   real(R8),parameter :: SHR_CONST_CPWV    = 1.810e3_R8      ! specific heat of water vap ~ J/kg/K
+   real(R8),parameter :: SHR_CONST_CPVIR   = (SHR_CONST_CPWV/SHR_CONST_CPDAIR)-1.0_R8 ! CPWV/CPDAIR - 1.0
+   real(R8),parameter :: SHR_CONST_CPFW    = 4.188e3_R8      ! specific heat of fresh h2o ~ J/kg/K
+   real(R8),parameter :: SHR_CONST_CPSW    = 3.996e3_R8      ! specific heat of sea h2o   ~ J/kg/K
+   real(R8),parameter :: SHR_CONST_CPICE   = 2.11727e3_R8    ! specific heat of fresh ice ~ J/kg/K
+   real(R8),parameter :: SHR_CONST_LATICE  = 3.337e5_R8      ! latent heat of fusion      ~ J/kg
+   real(R8),parameter :: SHR_CONST_LATVAP  = 2.501e6_R8      ! latent heat of evaporation ~ J/kg
+   real(R8),parameter :: SHR_CONST_LATSUB  = &               ! latent heat of sublimation ~ J/kg
+                         SHR_CONST_LATICE + SHR_CONST_LATVAP
+   real(R8),parameter :: SHR_CONST_OCN_REF_SAL = 34.7_R8     ! ocn ref salinity (psu)
+   real(R8),parameter :: SHR_CONST_ICE_REF_SAL =  4.0_R8     ! ice ref salinity (psu)
+
+   real(R8),parameter :: SHR_CONST_SPVAL   = 1.0e30_R8       ! special missing value
+
+END MODULE shr_const_mod
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_shr_kind_mod.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_shr_kind_mod.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_shr_kind_mod.F	(revision 17)
@@ -0,0 +1,26 @@
+!------------------------------------------------------------------------
+! Based on csm_share/shr/shr_kind_mod.F90 from CAM
+! Ported to WRF by William.Gustafson@pnl.gov, Nov. 2009
+!------------------------------------------------------------------------
+!===============================================================================
+! SVN $Id: shr_kind_mod.F90 11926 2008-09-25 21:10:40Z mvertens $
+! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/branch_tags/cesm1_0_rel_tags/cesm1_0_rel03_share3_100802/shr/shr_kind_mod.F90 $
+!===============================================================================
+
+MODULE shr_kind_mod
+
+   !----------------------------------------------------------------------------
+   ! precision/kind constants add data public
+   !----------------------------------------------------------------------------
+   public
+   integer,parameter :: SHR_KIND_R8 = selected_real_kind(12) ! 8 byte real
+   integer,parameter :: SHR_KIND_R4 = selected_real_kind( 6) ! 4 byte real
+   integer,parameter :: SHR_KIND_RN = kind(1.0)              ! native real
+   integer,parameter :: SHR_KIND_I8 = selected_int_kind (13) ! 8 byte integer
+   integer,parameter :: SHR_KIND_I4 = selected_int_kind ( 6) ! 4 byte integer
+   integer,parameter :: SHR_KIND_IN = kind(1)                ! native integer
+   integer,parameter :: SHR_KIND_CS = 80                     ! short char
+   integer,parameter :: SHR_KIND_CL = 256                    ! long char
+   integer,parameter :: SHR_KIND_CX = 512                    ! extra-long char
+
+END MODULE shr_kind_mod
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_support.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_support.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_support.F	(revision 17)
@@ -0,0 +1,174 @@
+MODULE module_cam_support
+!------------------------------------------------------------------------
+! This module contains global scope variables and routines shared by
+! multiple CAM physics routines. As much as possible, the codes is copied
+! verbatim from the corresponding CAM modules noted below.
+!
+! Author: William.Gustafson@pnl.gov, Nov 2009
+!------------------------------------------------------------------------
+  use module_state_description, only: param_num_moist
+  use shr_kind_mod
+
+  implicit none
+
+  public
+  save
+
+  integer(SHR_KIND_IN),parameter,private :: R8 = SHR_KIND_R8 ! rename for local readability only
+
+! From spmd_utils in CAM...
+  logical, parameter :: masterproc = .true.
+
+! From ppgrid in CAM...
+  integer, parameter :: pcols = 1   !Always have a chunk size of 1 in WRF
+  integer :: pver                   !Number of model level middles in CAM speak
+  integer :: pverp                  !Number of model level interfaces in CAM speak
+
+! From constituents in CAM...
+  integer, parameter :: pcnst = param_num_moist !Number of tracer constituents for CAM q array
+                                          !In WRF this is currently setup to only handle
+                                          !the moist array, and then even in a half-handed way.
+                                          !We allocate the max possible size, but loops need to
+                                          !be over a smaller number.
+                                          !Scalar and chem need to eventually be handled too.
+  real(kind=r8), parameter, dimension(pcnst) :: qmin = 0. !Minimun constituent concentration
+                                          !(kg/kg) Normally 0.
+
+! From cam_logfile...
+  character(len=250) :: iulog       !In CAM this is a file handle. In WRF, this is a string
+                                    !that can be used to send messages via wrf_message, etc.
+
+!From cam_pio_utils.F90
+integer, parameter, public :: phys_decomp=100
+
+! From cam_pio_utils (used in camuwpbl_driver module)...
+integer, parameter :: fieldname_len = 16   ! max chars for field name
+
+!------------------------------------------------------------------------
+CONTAINS
+!------------------------------------------------------------------------
+
+!!$!------------------------------------------------------------------------
+!!$CHARACTER(len=3) FUNCTION cnst_get_type_byind(ind)
+!!$! Gets the consituent type.
+!!$!
+!!$! Replaces function of same name in constituents module in CAM.
+!!$! ~This routine is currently hard-coded for the indices. It should be
+!!$!  generalized to handle arbitrary values, especially for chemical
+!!$!  tracers and advanced microphysics with additional phases.
+!!$!
+!!$! Author: William.Gustafson@pnl.gov, Nov 2009
+!!$!------------------------------------------------------------------------
+!!$  integer, intent(in) :: ind  !global constituent index (in q array)
+!!$
+!!$  select case (ind)
+!!$
+!!$  case(1) !vapor
+!!$     cnst_get_type_byind = "wet"
+!!$  case (2) !cloud droplets
+!!$     cnst_get_type_byind = "wet"
+!!$  case (3) !cloud ice crystals
+!!$     cnst_get_type_byind = "wet"
+!!$  case default
+!!$     cnst_get_type_byind = "wet"
+!!$  end select
+!!$
+!!$END FUNCTION cnst_get_type_byind
+
+
+!------------------------------------------------------------------------
+SUBROUTINE endrun(msg)
+! Pass through routine to wrf_error_fatal that mimics endrun in module
+! abortutils of CAM.
+!
+! Replaces endrun in abortutils module in CAM.
+!
+! Author: William.Gustafson@pnl.gov, Nov 2009
+! Modified : Balwinder.Singh@pnl.gov - Argument made optional 
+!------------------------------------------------------------------------
+  USE module_wrf_error
+
+! Argument of the subroutine is made optional to accomodate endrun calls with no argument 
+  character(len=*), intent(in), optional :: msg
+
+  if(present(msg)) then
+     call wrf_error_fatal(msg)
+  else
+! The error message is written to iulog bwfore the endrun call
+     call wrf_error_fatal(iulog)
+  endif
+
+END SUBROUTINE endrun
+
+
+
+!------------------------------------------------------------------------
+SUBROUTINE t_stopf(event)
+! Stub to accomodate stop time calls of CAM
+!
+! Replaces t_stopf in perf_mod module in CAM.
+!
+! Author: Balwinder.Singh@pnl.gov
+!------------------------------------------------------------------------
+  character(len=*), intent(in) :: event 
+  
+END SUBROUTINE t_stopf
+
+
+
+!------------------------------------------------------------------------
+SUBROUTINE t_startf(event)
+! Stub to accomodate start time calls of CAM
+!
+! Replaces t_startf in perf_mod module in CAM.
+!
+! Author: Balwinder.Singh@pnl.gov
+!------------------------------------------------------------------------
+
+   character(len=*), intent(in) :: event
+
+ END SUBROUTINE t_startf
+
+
+
+!------------------------------------------------------------------------
+SUBROUTINE outfld( fname, field, idim, c)
+! Stub to accomodate outfld calls of CAM
+!
+! Replaces outfld in cam_history module in CAM.
+!
+! Author: Balwinder.Singh@pnl.gov
+!------------------------------------------------------------------------
+  character(len=*), intent(in) :: fname
+  integer,          intent(in) :: idim          
+  integer,          intent(in) :: c             
+  real(r8),         intent(in) :: field(idim,*)
+
+END SUBROUTINE outfld
+
+
+
+!------------------------------------------------------------------------
+SUBROUTINE addfld(fname, units, numlev, avgflag, long_name, &
+                      decomp_type, flag_xyfill, flag_isccplev, sampling_seq)
+! Stub to accomodate addfld calls of CAM
+!
+! Replaces addfld in cam_history module in CAM.
+!
+! Author: Balwinder.Singh@pnl.gov
+!------------------------------------------------------------------------
+  character(len=*), intent(in) :: fname     
+  character(len=*), intent(in) :: units     
+  character(len=1), intent(in) :: avgflag   
+  character(len=*), intent(in) :: long_name 
+  
+  integer, intent(in) :: numlev             
+  integer, intent(in) :: decomp_type        
+  
+  logical, intent(in), optional :: flag_xyfill
+  logical, intent(in), optional :: flag_isccplev
+  character(len=*), intent(in), optional :: sampling_seq
+    
+END SUBROUTINE ADDFLD
+
+END MODULE module_cam_support
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_trb_mtn_stress.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_trb_mtn_stress.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_trb_mtn_stress.F	(revision 17)
@@ -0,0 +1,188 @@
+#define WRF_PORT
+
+module trb_mtn_stress
+
+#ifndef WRF_PORT 
+  use cam_logfile,   only : iulog
+#else
+  use module_cam_support,   only: iulog
+#endif
+  use shr_kind_mod,  only : r8 => shr_kind_r8
+
+
+  implicit none
+  private      
+  save
+
+  public init_tms                             ! Initialization
+  public compute_tms                          ! Full routine
+
+  ! ------------ !
+  ! Private data !
+  ! ------------ !
+
+#if( defined WACCM_PHYS)
+  real(r8), parameter :: z0fac  = 0.1_r8      ! Factor determining z_0 from orographic standard deviation [ no unit ]
+  real(r8), parameter :: horomin= 1._r8       ! Minimum value of subgrid orographic height for mountain stress [ m ]
+#else
+  real(r8), parameter :: z0fac  = 0.075_r8    ! Factor determining z_0 from orographic standard deviation [ no unit ]
+  real(r8), parameter :: horomin= 1._r8       ! Minimum value of subgrid orographic height for mountain stress [ m ]
+#endif
+
+  real(r8), parameter :: z0max  = 100._r8     ! Maximum value of z_0 for orography [ m ]
+  real(r8), parameter :: dv2min = 0.01_r8     ! Minimum shear squared [ m2/s2 ]
+  real(r8)            :: oroconst             ! Converts from standard deviation to height [ no unit ]
+  real(r8)            :: karman               ! von Karman constant
+  real(r8)            :: gravit               ! Acceleration due to gravity
+  real(r8)            :: rair                 ! Gas constant for dry air
+
+  contains
+
+  !============================================================================ !
+  !                                                                             !
+  !============================================================================ !
+
+  subroutine init_tms( kind, oro_in, karman_in, gravit_in, rair_in )
+    
+    integer,  intent(in) :: kind   
+    real(r8), intent(in) :: oro_in, karman_in, gravit_in, rair_in
+    
+    if( kind .ne. r8 ) then
+        write(iulog,*) 'KIND of reals passed to init_tms -- exiting.'
+        stop 'compute_tms'
+    endif
+
+    oroconst = oro_in
+    karman   = karman_in
+    gravit   = gravit_in
+    rair     = rair_in
+    
+    return
+  end subroutine init_tms
+
+  !============================================================================ !
+  !                                                                             !
+  !============================================================================ !
+
+  subroutine compute_tms( pcols    , pver    , ncol    ,                     &
+                          u        , v       , t       , pmid    , exner   , &
+                          zm       , sgh     , ksrf    , taux    , tauy    , & 
+                          landfrac )
+
+    !------------------------------------------------------------------------------ !
+    ! Turbulent mountain stress parameterization                                    !  
+    !                                                                               !
+    ! Returns surface drag coefficient and stress associated with subgrid mountains !
+    ! For points where the orographic variance is small ( including ocean ),        !
+    ! the returned surface drag coefficient and stress is zero.                     !
+    !                                                                               !
+    ! Lastly arranged : Sungsu Park. Jan. 2010.                                     !
+    !------------------------------------------------------------------------------ !
+
+    ! ---------------------- !
+    ! Input-Output Arguments ! 
+    ! ---------------------- !
+
+    integer,  intent(in)  :: pcols                 ! Number of columns dimensioned
+    integer,  intent(in)  :: pver                  ! Number of model layers
+    integer,  intent(in)  :: ncol                  ! Number of columns actually used
+
+    real(r8), intent(in)  :: u(pcols,pver)         ! Layer mid-point zonal wind [ m/s ]
+    real(r8), intent(in)  :: v(pcols,pver)         ! Layer mid-point meridional wind [ m/s ]
+    real(r8), intent(in)  :: t(pcols,pver)         ! Layer mid-point temperature [ K ]
+    real(r8), intent(in)  :: pmid(pcols,pver)      ! Layer mid-point pressure [ Pa ]
+    real(r8), intent(in)  :: exner(pcols,pver)     ! Layer mid-point exner function [ no unit ]
+    real(r8), intent(in)  :: zm(pcols,pver)        ! Layer mid-point height [ m ]
+    real(r8), intent(in)  :: sgh(pcols)            ! Standard deviation of orography [ m ]
+    real(r8), intent(in)  :: landfrac(pcols)       ! Land fraction [ fraction ]
+    
+    real(r8), intent(out) :: ksrf(pcols)           ! Surface drag coefficient [ kg/s/m2 ]
+    real(r8), intent(out) :: taux(pcols)           ! Surface zonal      wind stress [ N/m2 ]
+    real(r8), intent(out) :: tauy(pcols)           ! Surface meridional wind stress [ N/m2 ]
+
+    ! --------------- !
+    ! Local Variables !
+    ! --------------- !
+
+    integer  :: i                                  ! Loop index
+    integer  :: kb, kt                             ! Bottom and top of source region
+    
+    real(r8) :: horo                               ! Orographic height [ m ]
+    real(r8) :: z0oro                              ! Orographic z0 for momentum [ m ]
+    real(r8) :: dv2                                ! (delta v)**2 [ m2/s2 ]
+    real(r8) :: ri                                 ! Richardson number [ no unit ]
+    real(r8) :: stabfri                            ! Instability function of Richardson number [ no unit ]
+    real(r8) :: rho                                ! Density [ kg/m3 ]
+    real(r8) :: cd                                 ! Drag coefficient [ no unit ]
+    real(r8) :: vmag                               ! Velocity magnitude [ m /s ]
+
+    ! ----------------------- !
+    ! Main Computation Begins !
+    ! ----------------------- !
+       
+    do i = 1, ncol
+
+     ! determine subgrid orgraphic height ( mean to peak )
+
+       horo = oroconst * sgh(i)
+
+     ! No mountain stress if horo is too small
+
+       if( horo < horomin ) then
+
+           ksrf(i) = 0._r8
+           taux(i) = 0._r8
+           tauy(i) = 0._r8
+
+       else
+
+         ! Determine z0m for orography
+
+           z0oro = min( z0fac * horo, z0max )
+
+         ! Calculate neutral drag coefficient
+
+           cd = ( karman / log( ( zm(i,pver) + z0oro ) / z0oro) )**2
+
+         ! Calculate the Richardson number over the lowest 2 layers
+
+           kt  = pver - 1
+           kb  = pver
+           dv2 = max( ( u(i,kt) - u(i,kb) )**2 + ( v(i,kt) - v(i,kb) )**2, dv2min )
+
+         ! Modification : Below computation of Ri is wrong. Note that 'Exner' function here is
+         !                inverse exner function. Here, exner function is not multiplied in
+         !                the denominator. Also, we should use moist Ri not dry Ri.
+         !                Also, this approach using the two lowest model layers can be potentially
+         !                sensitive to the vertical resolution.  
+         ! OK. I only modified the part associated with exner function.
+
+           ri  = 2._r8 * gravit * ( t(i,kt) * exner(i,kt) - t(i,kb) * exner(i,kb) ) * ( zm(i,kt) - zm(i,kb) ) &
+                                / ( ( t(i,kt) * exner(i,kt) + t(i,kb) * exner(i,kb) ) * dv2 )
+
+         ! ri  = 2._r8 * gravit * ( t(i,kt) * exner(i,kt) - t(i,kb) * exner(i,kb) ) * ( zm(i,kt) - zm(i,kb) ) &
+         !                      / ( ( t(i,kt) + t(i,kb) ) * dv2 )
+
+         ! Calculate the instability function and modify the neutral drag cofficient.
+         ! We should probably follow more elegant approach like Louis et al (1982) or Bretherton and Park (2009) 
+         ! but for now we use very crude approach : just 1 for ri < 0, 0 for ri > 1, and linear ramping.
+
+           stabfri = max( 0._r8, min( 1._r8, 1._r8 - ri ) )
+           cd      = cd * stabfri
+
+         ! Compute density, velocity magnitude and stress using bottom level properties
+
+           rho     = pmid(i,pver) / ( rair * t(i,pver) ) 
+           vmag    = sqrt( u(i,pver)**2 + v(i,pver)**2 )
+           ksrf(i) = rho * cd * vmag * landfrac(i)
+           taux(i) = -ksrf(i) * u(i,pver)
+           tauy(i) = -ksrf(i) * v(i,pver)
+
+       end if
+
+    end do
+    
+    return
+  end subroutine compute_tms
+
+  end module trb_mtn_stress
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_upper_bc.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_upper_bc.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_upper_bc.F	(revision 17)
@@ -0,0 +1,108 @@
+#define WRF_PORT
+
+module upper_bc
+
+!---------------------------------------------------------------------------------
+! Module to compute the upper boundary condition for temperature (dry static energy)
+! and trace gases.   The standard CAM version does nothing.
+!
+! original code by Stacy Walters
+! adapted by B. A. Boville
+!---------------------------------------------------------------------------------
+
+  use shr_kind_mod, only: r8 => shr_kind_r8
+#ifndef WRF_PORT
+  use ppgrid,       only: pcols, pverp
+  use constituents, only: pcnst
+#else
+  use module_cam_support,       only: pcols, pverp, pcnst
+#endif
+
+
+  implicit none
+  private
+  save
+!
+! Public interfaces
+!
+  public :: ubc_defaultopts    ! set default values of namelist variables
+  public :: ubc_setopts        ! get namelist input
+  public :: ubc_init           ! global initialization
+#ifndef WRF_PORT     
+  public :: ubc_timestep_init  ! time step initialization
+#endif
+  public :: ubc_get_vals       ! get ubc values for this step
+
+!================================================================================================
+contains
+!================================================================================================
+
+subroutine ubc_defaultopts(tgcm_ubc_file_out, snoe_ubc_file_out)
+!----------------------------------------------------------------------- 
+! Purpose: Return default runtime options
+!-----------------------------------------------------------------------
+
+   character(len=*), intent(out), optional :: tgcm_ubc_file_out
+   character(len=*), intent(out), optional :: snoe_ubc_file_out
+!-----------------------------------------------------------------------
+
+end subroutine ubc_defaultopts
+
+!================================================================================================
+
+subroutine ubc_setopts(tgcm_ubc_file_in, snoe_ubc_file_in)
+!----------------------------------------------------------------------- 
+! Purpose: Set runtime options
+!-----------------------------------------------------------------------
+
+   character(len=*), intent(in), optional :: tgcm_ubc_file_in
+   character(len=*), intent(in), optional :: snoe_ubc_file_in
+!-----------------------------------------------------------------------
+
+end subroutine ubc_setopts
+
+!===============================================================================
+
+  subroutine ubc_init
+!-----------------------------------------------------------------------
+! Initialization of time independent fields for the upper boundary condition
+! Calls initialization routine for MSIS, TGCM and SNOE
+!-----------------------------------------------------------------------
+
+  end subroutine ubc_init
+
+!===============================================================================
+#ifndef WRF_PORT
+  subroutine ubc_timestep_init(state)
+    use physics_types,only : physics_state
+    use ppgrid,       only : begchunk, endchunk
+
+!-----------------------------------------------------------------------
+! timestep dependent setting
+!-----------------------------------------------------------------------
+
+    type(physics_state), intent(in):: state(begchunk:endchunk)                 
+
+  end subroutine ubc_timestep_init
+#endif
+
+!===============================================================================
+
+  subroutine ubc_get_vals (lchnk, ncol, ntop_molec, pint, zi, msis_temp, ubc_mmr)
+!-----------------------------------------------------------------------
+! interface routine for vertical diffusion and pbl scheme
+!-----------------------------------------------------------------------
+
+!------------------------------Arguments--------------------------------
+    integer,  intent(in)  :: lchnk                 ! chunk identifier
+    integer,  intent(in)  :: ncol                  ! number of atmospheric columns
+    integer,  intent(in)  :: ntop_molec            ! top of molecular diffusion region (=1)
+    real(r8), intent(in)  :: pint(pcols,pverp)     ! interface pressures
+    real(r8), intent(in)  :: zi(pcols,pverp)       ! interface geoptl height above sfc
+
+    real(r8), intent(out) :: ubc_mmr(pcols,pcnst)  ! upper bndy mixing ratios (kg/kg)
+    real(r8), intent(out) :: msis_temp(pcols)      ! upper bndy temperature (K)
+
+  end subroutine ubc_get_vals
+
+end module upper_bc
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_wv_saturation.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_wv_saturation.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cam_wv_saturation.F	(revision 17)
@@ -0,0 +1,1341 @@
+#define WRF_PORT
+
+!
+! Common block and statement functions for saturation vapor pressure
+! look-up procedure, J. J. Hack, February 1990
+!
+! Ported to WRF by William.Gustafson@pnl.gov, Nov. 2009
+! Updated to version from CESM1_0_1, Nov. 2010
+!
+! $Id$
+!
+module wv_saturation
+  use shr_kind_mod, only: r8 => shr_kind_r8
+#ifndef WRF_PORT
+  use abortutils,   only: endrun
+  use cam_logfile,  only: iulog
+#else
+  use module_cam_support, only: &
+       masterproc, &
+       endrun, &
+       iulog
+  use module_wrf_error
+#endif
+
+  implicit none
+  private
+  save
+!
+! Public interfaces
+!
+  public gestbl   ! Initialization subroutine
+  public estblf   ! saturation pressure table lookup
+  public aqsat    ! Returns saturation vapor pressure
+#ifndef WRF_PORT
+  public aqsatd   ! Same as aqsat, but also returns a temperature derivitive
+  public vqsatd   ! Vector version of aqsatd
+#endif
+  public fqsatd   ! Function version of vqsatd
+#ifndef WRF_PORT
+  public qsat_water  ! saturation mixing ration with respect to liquid water
+  public vqsat_water ! vector version of qsat_water
+  public qsat_ice    ! saturation mixing ration with respect to ice
+  public vqsat_ice   ! vector version of qsat_ice
+  public vqsatd_water
+  public aqsat_water
+  public vqsatd2_water         ! Variant of vqsatd_water to print out dqsdT
+  public vqsatd2_water_single  ! Single value version of vqsatd2_water
+  public vqsatd2
+  public vqsatd2_single
+  public polysvp
+#endif
+!
+! Data used by cldwat
+!
+  public hlatv, tmin, hlatf, rgasv, pcf, cp, epsqs, ttrice
+!
+! Data
+!
+  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) ttrice     ! transition range from es over H2O to es over ice
+  real(r8) pcf(6)     ! polynomial coeffs -> es transition water to ice
+  real(r8) epsqs      ! Ratio of h2o to dry air molecular weights 
+  real(r8) rgasv      ! Gas constant for water vapor
+  real(r8) hlatf      ! Latent heat of vaporization
+  real(r8) hlatv      ! Latent heat of fusion
+  real(r8) cp         ! specific heat of dry air
+  real(r8) tmelt      ! Melting point of water (K)
+  logical icephs  ! false => saturation vapor press over water only
+
+contains
+
+   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._r8)* &
+            estbl(i)-(tmin+ai-e)* &
+            estbl(i+1)
+   end function estblf
+
+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
+! 
+!-----------------------------------------------------------------------
+#ifndef WRF_PORT
+   use spmd_utils, only: masterproc
+#else
+   use module_cam_gffgch
+#endif
+!------------------------------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
+   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
+!
+!-----------------------------------------------------------------------
+!
+! 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_r8)
+   if (lentbl .gt. plenest) then
+      write(iulog,9000) tmax, tmin, plenest
+#ifdef WRF_PORT
+      call wrf_message(iulog)
+#endif
+      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_r8) then
+         itype = -ttrice
+      else
+         itype = 1
+      end if
+   else
+      itype = 0
+   end if
+!
+   t = tmin - 1.0_r8
+   do n=1,lentbl
+      t = t + 1.0_r8
+      call gffgch(t,estbl(n),itype)
+   end do
+!
+   do n=lentbl+1,plenest
+      estbl(n) = -99999.0_r8
+   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_r8
+   pcf(2) = -5.47288442819e+00_r8
+   pcf(3) = -3.67471858735e-01_r8
+   pcf(4) = -8.95963532403e-03_r8
+   pcf(5) = -7.78053686625e-05_r8
+!
+!                  --- 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(iulog,*)' *** SATURATION VAPOR PRESSURE TABLE COMPLETED ***'
+#ifdef WRF_PORT
+      call wrf_debug(100,iulog)
+#endif
+   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 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: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! 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_r8 - 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_r8) then
+            qs(i,k) = 1.0_r8
+            es(i,k) = p(i,k)
+         end if
+      end do
+   end do
+!
+   return
+end subroutine aqsat
+
+#ifndef WRF_PORT
+!++xl
+subroutine aqsat_water(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:
+! <Describe the algorithm(s) used in the routine.>
+! <Also include any applicable external references.>
+!
+! 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_r8 - epsqs
+   do k=kstart,kend
+      do i=1,ilen
+!        es(i,k) = estblf(t(i,k))
+         es(i,k) = polysvp(t(i,k),0)
+!
+! 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_r8) then
+            qs(i,k) = 1.0_r8
+            es(i,k) = p(i,k)
+         end if
+      end do
+   end do
+!
+   return
+end subroutine aqsat_water
+!--xl
+
+
+subroutine aqsatd(t       ,p       ,es      ,qs      ,gam     , &
+                  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).   
+! 
+! Method: 
+! Differs from aqsat by also calculating and returning
+! gamma (l/cp)*(d(qsat)/dT)
+! Input arrays temperature and pressure (dimensioned ii,kk).
+! 
+! Author: J. Hack
+! 
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+   integer, intent(in) :: ii            ! I dimension of arrays t, p, es, qs
+   integer, intent(in) :: ilen          ! Vector length in I direction
+   integer, intent(in) :: kk            ! K dimension of arrays t, p, es, qs
+   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
+   real(r8), intent(out) :: gam(ii,kk)       ! (l/cp)*(d(qs)/dt)
+!
+!---------------------------Local workspace-----------------------------
+!
+   logical lflg          ! True if in temperature transition region
+   integer i             ! i index for vector calculations
+   integer k             ! k index
+   real(r8) omeps            ! 1. - 0.622
+   real(r8) trinv            ! Reciprocal of ttrice (transition range)
+   real(r8) tc               ! Temperature (in degrees C)
+   real(r8) weight           ! Weight for es transition from water to ice
+   real(r8) hltalt           ! Appropriately modified hlat for T derivatives
+   real(r8) hlatsb           ! hlat weighted in transition region
+   real(r8) hlatvp           ! hlat modified for t changes above freezing
+   real(r8) tterm            ! Account for d(es)/dT in transition region
+   real(r8) desdt            ! d(es)/dT
+!
+!-----------------------------------------------------------------------
+!
+   omeps = 1.0_r8 - 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 qs
+! values which can occur in the upper stratosphere and mesosphere
+!
+         qs(i,k) = min(1.0_r8,qs(i,k))
+!
+         if (qs(i,k) < 0.0_r8) then
+            qs(i,k) = 1.0_r8
+            es(i,k) = p(i,k)
+         end if
+      end do
+   end do
+!
+! "generalized" analytic expression for t derivative of es
+! accurate to within 1 percent for 173.16 < t < 373.16
+!
+   trinv = 0.0_r8
+   if ((.not. icephs) .or. (ttrice.eq.0.0_r8)) go to 10
+   trinv = 1.0_r8/ttrice
+!
+   do k=kstart,kend
+      do i=1,ilen
+!
+! Weighting of hlat accounts for transition from water to ice
+! polynomial expression approximates difference between es over
+! water and es over ice from 0 to -ttrice (C) (min of ttrice is
+! -40): required for accurate estimate of es derivative in transition
+! range from ice to water also accounting for change of hlatv with t
+! above freezing where constant slope is given by -2369 j/(kg c) =cpv - cw
+!
+         tc     = t(i,k) - tmelt
+         lflg   = (tc >= -ttrice .and. tc < 0.0_r8)
+         weight = min(-tc*trinv,1.0_r8)
+         hlatsb = hlatv + weight*hlatf
+         hlatvp = hlatv - 2369.0_r8*tc
+         if (t(i,k) < tmelt) then
+            hltalt = hlatsb
+         else
+            hltalt = hlatvp
+         end if
+         if (lflg) then
+            tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + tc*(pcf(4) + tc*pcf(5))))
+         else
+            tterm = 0.0_r8
+         end if
+         desdt    = hltalt*es(i,k)/(rgasv*t(i,k)*t(i,k)) + tterm*trinv
+         gam(i,k) = hltalt*qs(i,k)*p(i,k)*desdt/(cp*es(i,k)*(p(i,k) - omeps*es(i,k)))
+         if (qs(i,k) == 1.0_r8) gam(i,k) = 0.0_r8
+      end do
+   end do
+!
+   go to 20
+!
+! No icephs or water to ice transition
+!
+10 do k=kstart,kend
+      do i=1,ilen
+!
+! Account for change of hlatv with t above freezing where
+! constant slope is given by -2369 j/(kg c) = cpv - cw
+!
+         hlatvp = hlatv - 2369.0_r8*(t(i,k)-tmelt)
+         if (icephs) then
+            hlatsb = hlatv + hlatf
+         else
+            hlatsb = hlatv
+         end if
+         if (t(i,k) < tmelt) then
+            hltalt = hlatsb
+         else
+            hltalt = hlatvp
+         end if
+         desdt    = hltalt*es(i,k)/(rgasv*t(i,k)*t(i,k))
+         gam(i,k) = hltalt*qs(i,k)*p(i,k)*desdt/(cp*es(i,k)*(p(i,k) - omeps*es(i,k)))
+         if (qs(i,k) == 1.0_r8) gam(i,k) = 0.0_r8
+      end do
+   end do
+!
+20 return
+end subroutine aqsatd
+#endif
+
+subroutine vqsatd(t       ,p       ,es      ,qs      ,gam      , &
+                  len     )
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! Utility procedure to look up and return saturation vapor pressure from
+! precomputed table, calculate and return saturation specific humidity
+! (g/g), and calculate and return gamma (l/cp)*(d(qsat)/dT).  The same
+! function as qsatd, but operates on vectors of temperature and pressure
+! 
+! Method: 
+! 
+! Author: J. Hack
+! 
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+   integer, intent(in) :: len       ! vector length
+   real(r8), intent(in) :: t(len)       ! temperature
+   real(r8), intent(in) :: p(len)       ! pressure
+!
+! Output arguments
+!
+   real(r8), intent(out) :: es(len)   ! saturation vapor pressure
+   real(r8), intent(out) :: qs(len)   ! saturation specific humidity
+   real(r8), intent(out) :: gam(len)  ! (l/cp)*(d(qs)/dt)
+!
+!--------------------------Local Variables------------------------------
+!
+   logical lflg   ! true if in temperature transition region
+!
+   integer i      ! index for vector calculations
+!
+   real(r8) omeps     ! 1. - 0.622
+   real(r8) trinv     ! reciprocal of ttrice (transition range)
+   real(r8) tc        ! temperature (in degrees C)
+   real(r8) weight    ! weight for es transition from water to ice
+   real(r8) hltalt    ! appropriately modified hlat for T derivatives
+!
+   real(r8) hlatsb    ! hlat weighted in transition region
+   real(r8) hlatvp    ! hlat modified for t changes above freezing
+   real(r8) tterm     ! account for d(es)/dT in transition region
+   real(r8) desdt     ! d(es)/dT
+!
+!-----------------------------------------------------------------------
+!
+   omeps = 1.0_r8 - epsqs
+   do i=1,len
+      es(i) = estblf(t(i))
+!
+! Saturation specific humidity
+!
+      qs(i) = epsqs*es(i)/(p(i) - omeps*es(i))
+!
+! The following check is to avoid the generation of negative
+! values that can occur in the upper stratosphere and mesosphere
+!
+      qs(i) = min(1.0_r8,qs(i))
+!
+      if (qs(i) < 0.0_r8) then
+         qs(i) = 1.0_r8
+         es(i) = p(i)
+      end if
+   end do
+!
+! "generalized" analytic expression for t derivative of es
+! accurate to within 1 percent for 173.16 < t < 373.16
+!
+   trinv = 0.0_r8
+   if ((.not. icephs) .or. (ttrice.eq.0.0_r8)) go to 10
+   trinv = 1.0_r8/ttrice
+   do i=1,len
+!
+! Weighting of hlat accounts for transition from water to ice
+! polynomial expression approximates difference between es over
+! water and es over ice from 0 to -ttrice (C) (min of ttrice is
+! -40): required for accurate estimate of es derivative in transition
+! range from ice to water also accounting for change of hlatv with t
+! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw
+!
+      tc     = t(i) - tmelt
+      lflg   = (tc >= -ttrice .and. tc < 0.0_r8)
+      weight = min(-tc*trinv,1.0_r8)
+      hlatsb = hlatv + weight*hlatf
+      hlatvp = hlatv - 2369.0_r8*tc
+      if (t(i) < tmelt) then
+         hltalt = hlatsb
+      else
+         hltalt = hlatvp
+      end if
+      if (lflg) then
+         tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + tc*(pcf(4) + tc*pcf(5))))
+      else
+         tterm = 0.0_r8
+      end if
+      desdt  = hltalt*es(i)/(rgasv*t(i)*t(i)) + tterm*trinv
+      gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i)))
+      if (qs(i) == 1.0_r8) gam(i) = 0.0_r8
+   end do
+   return
+!
+! No icephs or water to ice transition
+!
+10 do i=1,len
+!
+! Account for change of hlatv with t above freezing where
+! constant slope is given by -2369 j/(kg c) = cpv - cw
+!
+      hlatvp = hlatv - 2369.0_r8*(t(i)-tmelt)
+      if (icephs) then
+         hlatsb = hlatv + hlatf
+      else
+         hlatsb = hlatv
+      end if
+      if (t(i) < tmelt) then
+         hltalt = hlatsb
+      else
+         hltalt = hlatvp
+      end if
+      desdt  = hltalt*es(i)/(rgasv*t(i)*t(i))
+      gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i)))
+      if (qs(i) == 1.0_r8) gam(i) = 0.0_r8
+   end do
+!
+   return
+!
+end subroutine vqsatd
+
+#ifndef WRF_PORT
+!++xl
+subroutine vqsatd_water(t       ,p       ,es      ,qs      ,gam      , &
+                        len     )
+
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+   integer, intent(in) :: len       ! vector length
+   real(r8), intent(in) :: t(len)       ! temperature
+   real(r8), intent(in) :: p(len)       ! pressure
+
+!
+! Output arguments
+!
+   real(r8), intent(out) :: es(len)   ! saturation vapor pressure
+   real(r8), intent(out) :: qs(len)   ! saturation specific humidity
+   real(r8), intent(out) :: gam(len)  ! (l/cp)*(d(qs)/dt)
+
+!
+!--------------------------Local Variables------------------------------
+!
+!
+   integer i      ! index for vector calculations
+!
+   real(r8) omeps     ! 1. - 0.622
+   real(r8) hltalt    ! appropriately modified hlat for T derivatives
+!
+   real(r8) hlatsb    ! hlat weighted in transition region
+   real(r8) hlatvp    ! hlat modified for t changes above freezing
+   real(r8) desdt     ! d(es)/dT
+!
+!-----------------------------------------------------------------------
+!
+   omeps = 1.0_r8 - epsqs
+   do i=1,len
+      es(i) = polysvp(t(i),0)
+!
+! Saturation specific humidity
+!
+      qs(i) = epsqs*es(i)/(p(i) - omeps*es(i))
+!
+! The following check is to avoid the generation of negative
+! values that can occur in the upper stratosphere and mesosphere
+!
+      qs(i) = min(1.0_r8,qs(i))
+!
+      if (qs(i) < 0.0_r8) then
+         qs(i) = 1.0_r8
+         es(i) = p(i)
+      end if
+   end do
+!
+! No icephs or water to ice transition
+!
+   do i=1,len
+!
+! Account for change of hlatv with t above freezing where
+! constant slope is given by -2369 j/(kg c) = cpv - cw
+!
+      hlatvp = hlatv - 2369.0_r8*(t(i)-tmelt)
+      hlatsb = hlatv
+      if (t(i) < tmelt) then
+         hltalt = hlatsb
+      else
+         hltalt = hlatvp
+      end if
+      desdt  = hltalt*es(i)/(rgasv*t(i)*t(i))
+      gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i)))
+      if (qs(i) == 1.0_r8) gam(i) = 0.0_r8
+   end do
+!
+   return
+!
+end subroutine vqsatd_water
+
+      function polysvp (T,type)
+!  Compute saturation vapor pressure by using
+! function from Goff and Gatch (1946)
+
+!  Polysvp returned in units of pa.
+!  T is input in units of K.
+!  type refers to saturation with respect to liquid (0) or ice (1)
+
+      real(r8) dum
+
+      real(r8) T,polysvp
+
+      integer type
+
+! ice
+
+      if (type.eq.1) then
+
+! Goff Gatch equation (good down to -100 C)
+
+         polysvp = 10._r8**(-9.09718_r8*(273.16_r8/t-1._r8)-3.56654_r8* &
+          log10(273.16_r8/t)+0.876793_r8*(1._r8-t/273.16_r8)+ &
+          log10(6.1071_r8))*100._r8
+
+      end if
+
+! Goff Gatch equation, uncertain below -70 C
+
+      if (type.eq.0) then
+         polysvp = 10._r8**(-7.90298_r8*(373.16_r8/t-1._r8)+ &
+             5.02808_r8*log10(373.16_r8/t)- &
+             1.3816e-7_r8*(10._r8**(11.344_r8*(1._r8-t/373.16_r8))-1._r8)+ &
+             8.1328e-3_r8*(10._r8**(-3.49149_r8*(373.16_r8/t-1._r8))-1._r8)+ &
+             log10(1013.246_r8))*100._r8
+         end if
+
+
+      end function polysvp
+!--xl
+#endif
+
+integer function fqsatd(t    ,p    ,es    ,qs   ,gam   , len     )
+  !----------------------------------------------------------------------- 
+  ! Purpose: 
+  ! This is merely a function interface vqsatd.
+  !------------------------------Arguments--------------------------------
+  ! Input arguments
+  integer, intent(in) :: len       ! vector length
+  real(r8), intent(in) :: t(len)       ! temperature
+  real(r8), intent(in) :: p(len)       ! pressure
+  ! Output arguments
+  real(r8), intent(out) :: es(len)   ! saturation vapor pressure
+  real(r8), intent(out) :: qs(len)   ! saturation specific humidity
+  real(r8), intent(out) :: gam(len)  ! (l/cp)*(d(qs)/dt)
+  ! Call vqsatd
+  call vqsatd(t       ,p       ,es      ,qs      ,gam  , len     )
+  fqsatd = 1
+  return
+end function fqsatd
+
+#ifndef WRF_PORT
+real(r8) function qsat_water(t,p)
+  !  saturation mixing ratio w/respect to liquid water
+  real(r8) t ! temperature
+  real(r8) p ! pressure (Pa)
+  real(r8) es ! saturation vapor pressure (Pa)
+  real(r8) ps, ts, e1, e2, f1, f2, f3, f4, f5, f
+  !  real(r8) t0inv ! 1/273.
+  !  data t0inv/0.003663/
+  !  save t0inv
+  !  es = 611.*exp(hlatv/rgasv*(t0inv-1./t))
+
+  ps = 1013.246_r8
+  ts = 373.16_r8
+  e1 = 11.344_r8*(1.0_r8 - t/ts)
+  e2 = -3.49149_r8*(ts/t - 1.0_r8)
+  f1 = -7.90298_r8*(ts/t - 1.0_r8)
+  f2 = 5.02808_r8*log10(ts/t)
+  f3 = -1.3816_r8*(10.0_r8**e1 - 1.0_r8)/10000000.0_r8
+  f4 = 8.1328_r8*(10.0_r8**e2 - 1.0_r8)/1000.0_r8
+  f5 = log10(ps)
+  f  = f1 + f2 + f3 + f4 + f5
+  es = (10.0_r8**f)*100.0_r8
+
+  qsat_water = epsqs*es/(p-(1.-epsqs)*es) ! saturation w/respect to liquid only
+  if(qsat_water < 0.) qsat_water = 1.
+
+end function qsat_water
+
+subroutine vqsat_water(t,p,qsat_water,len)
+  !  saturation mixing ratio w/respect to liquid water
+  integer, intent(in)  :: len
+  real(r8) t(len) ! temperature
+  real(r8) p(len) ! pressure (Pa)
+  real(r8) qsat_water(len)
+  real(r8) es ! saturation vapor pressure (Pa)
+  real(r8), parameter :: t0inv = 1._r8/273._r8
+  real(r8) coef
+  integer :: i
+
+  coef = hlatv/rgasv
+  do i=1,len
+     es = 611._r8*exp(coef*(t0inv-1./t(i)))
+     qsat_water(i) = epsqs*es/(p(i)-(1.-epsqs)*es) ! saturation w/respect to liquid only
+     if(qsat_water(i) < 0.) qsat_water(i) = 1.
+  enddo
+
+  return
+
+end subroutine vqsat_water
+
+real(r8) function qsat_ice(t,p)
+  !  saturation mixing ratio w/respect to ice
+  real(r8) t ! temperature
+  real(r8) p ! pressure (Pa)
+  real(r8) es ! saturation vapor pressure (Pa)
+  real(r8), parameter :: t0inv = 1._r8/273._r8
+  es = 611.*exp((hlatv+hlatf)/rgasv*(t0inv-1./t))
+  qsat_ice = epsqs*es/(p-(1.-epsqs)*es) ! saturation w/respect to liquid only
+  if(qsat_ice < 0.) qsat_ice = 1.
+
+end function qsat_ice
+
+subroutine vqsat_ice(t,p,qsat_ice,len)
+  !  saturation mixing ratio w/respect to liquid water
+  integer,intent(in) :: len
+  real(r8) t(len) ! temperature
+  real(r8) p(len) ! pressure (Pa)
+  real(r8) qsat_ice(len)
+  real(r8) es ! saturation vapor pressure (Pa)
+  real(r8), parameter :: t0inv = 1._r8/273._r8
+  real(r8) coef
+  integer :: i
+
+  coef = (hlatv+hlatf)/rgasv
+  do i=1,len
+     es = 611.*exp(coef*(t0inv-1./t(i)))
+     qsat_ice(i) = epsqs*es/(p(i)-(1.-epsqs)*es) ! saturation w/respect to liquid only
+     if(qsat_ice(i) < 0.) qsat_ice(i) = 1.
+  enddo
+
+  return
+
+end subroutine vqsat_ice
+
+! Sungsu
+! Below two subroutines (vqsatd2_water,vqsatd2_water_single) are by Sungsu
+! Replace 'gam -> dqsdt'
+! Sungsu
+
+subroutine vqsatd2_water(t       ,p       ,es      ,qs      ,dqsdt      , &
+                        len     )
+
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+   integer, intent(in) :: len       ! vector length
+   real(r8), intent(in) :: t(len)       ! temperature
+   real(r8), intent(in) :: p(len)       ! pressure
+
+!
+! Output arguments
+!
+   real(r8), intent(out) :: es(len)   ! saturation vapor pressure
+   real(r8), intent(out) :: qs(len)   ! saturation specific humidity
+ ! real(r8), intent(out) :: gam(len)  ! (l/cp)*(d(qs)/dt)
+ ! Sungsu
+   real(r8), intent(out) :: dqsdt(len)  ! (d(qs)/dt)
+ ! End by Sungsu
+
+!
+!--------------------------Local Variables------------------------------
+!
+!
+   integer i      ! index for vector calculations
+!
+   real(r8) omeps     ! 1. - 0.622
+   real(r8) hltalt    ! appropriately modified hlat for T derivatives
+!
+   real(r8) hlatsb    ! hlat weighted in transition region
+   real(r8) hlatvp    ! hlat modified for t changes above freezing
+   real(r8) desdt     ! d(es)/dT
+
+ ! Sungsu
+   real(r8) gam(len)  ! (l/cp)*(d(qs)/dt)
+ ! End by Sungsu
+
+!
+!-----------------------------------------------------------------------
+!
+   omeps = 1.0_r8 - epsqs
+   do i=1,len
+      es(i) = polysvp(t(i),0)
+!
+! Saturation specific humidity
+!
+      qs(i) = epsqs*es(i)/(p(i) - omeps*es(i))
+!
+! The following check is to avoid the generation of negative
+! values that can occur in the upper stratosphere and mesosphere
+!
+      qs(i) = min(1.0_r8,qs(i))
+!
+      if (qs(i) < 0.0_r8) then
+         qs(i) = 1.0_r8
+         es(i) = p(i)
+      end if
+   end do
+!
+! No icephs or water to ice transition
+!
+   do i=1,len
+!
+! Account for change of hlatv with t above freezing where
+! constant slope is given by -2369 j/(kg c) = cpv - cw
+!
+      hlatvp = hlatv - 2369.0_r8*(t(i)-tmelt)
+      hlatsb = hlatv
+      if (t(i) < tmelt) then
+         hltalt = hlatsb
+      else
+         hltalt = hlatvp
+      end if
+      desdt  = hltalt*es(i)/(rgasv*t(i)*t(i))
+      gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i)))
+      if (qs(i) == 1.0_r8) gam(i) = 0.0_r8
+    ! Sungsu
+      dqsdt(i) = (cp/hltalt)*gam(i)
+    ! End by Sungsu
+   end do
+!
+   return
+!
+end subroutine vqsatd2_water
+
+subroutine vqsatd2_water_single(t       ,p       ,es      ,qs      ,dqsdt)
+
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+
+   real(r8), intent(in) :: t       ! temperature
+   real(r8), intent(in) :: p       ! pressure
+
+!
+! Output arguments
+!
+   real(r8), intent(out) :: es   ! saturation vapor pressure
+   real(r8), intent(out) :: qs   ! saturation specific humidity
+ ! real(r8), intent(out) :: gam  ! (l/cp)*(d(qs)/dt)
+ ! Sungsu
+   real(r8), intent(out) :: dqsdt  ! (d(qs)/dt)
+ ! End by Sungsu
+
+!
+!--------------------------Local Variables------------------------------
+!
+!
+   integer i      ! index for vector calculations
+!
+   real(r8) omeps     ! 1. - 0.622
+   real(r8) hltalt    ! appropriately modified hlat for T derivatives
+!
+   real(r8) hlatsb    ! hlat weighted in transition region
+   real(r8) hlatvp    ! hlat modified for t changes above freezing
+   real(r8) desdt     ! d(es)/dT
+
+ ! Sungsu
+   real(r8) gam  ! (l/cp)*(d(qs)/dt)
+ ! End by Sungsu
+
+!
+!-----------------------------------------------------------------------
+!
+   omeps = 1.0_r8 - epsqs
+!  do i=1,len
+      es = polysvp(t,0)
+!
+! Saturation specific humidity
+!
+      qs = epsqs*es/(p - omeps*es)
+!
+! The following check is to avoid the generation of negative
+! values that can occur in the upper stratosphere and mesosphere
+!
+      qs = min(1.0_r8,qs)
+!
+      if (qs < 0.0_r8) then
+         qs = 1.0_r8
+         es = p
+      end if
+!  end do
+!
+! No icephs or water to ice transition
+!
+!  do i=1,len
+!
+! Account for change of hlatv with t above freezing where
+! constant slope is given by -2369 j/(kg c) = cpv - cw
+!
+      hlatvp = hlatv - 2369.0_r8*(t-tmelt)
+      hlatsb = hlatv
+      if (t < tmelt) then
+         hltalt = hlatsb
+      else
+         hltalt = hlatvp
+      end if
+      desdt  = hltalt*es/(rgasv*t*t)
+      gam = hltalt*qs*p*desdt/(cp*es*(p - omeps*es))
+      if (qs == 1.0_r8) gam = 0.0_r8
+    ! Sungsu
+      dqsdt = (cp/hltalt)*gam
+    ! End by Sungsu
+!  end do
+!
+   return
+!
+end subroutine vqsatd2_water_single
+
+
+subroutine vqsatd2(t       ,p       ,es      ,qs      ,dqsdt      , &
+                   len     )
+!----------------------------------------------------------------------- 
+! Sungsu : This is directly copied from 'vqsatd' but 'dqsdt' is output
+!          instead of gam for use in Sungsu's equilibrium stratiform
+!          macrophysics scheme.
+! 
+! Purpose: 
+! Utility procedure to look up and return saturation vapor pressure from
+! precomputed table, calculate and return saturation specific humidity
+! (g/g), and calculate and return gamma (l/cp)*(d(qsat)/dT).  The same
+! function as qsatd, but operates on vectors of temperature and pressure
+! 
+! Method: 
+! 
+! Author: J. Hack
+! 
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+   integer, intent(in) :: len       ! vector length
+   real(r8), intent(in) :: t(len)       ! temperature
+   real(r8), intent(in) :: p(len)       ! pressure
+!
+! Output arguments
+!
+   real(r8), intent(out) :: es(len)   ! saturation vapor pressure
+   real(r8), intent(out) :: qs(len)   ! saturation specific humidity
+ ! real(r8), intent(out) :: gam(len)  ! (l/cp)*(d(qs)/dt)
+ ! Sungsu
+   real(r8), intent(out) :: dqsdt(len)  ! (d(qs)/dt)
+ ! End by Sungsu 
+
+!
+!--------------------------Local Variables------------------------------
+!
+   logical lflg   ! true if in temperature transition region
+!
+   integer i      ! index for vector calculations
+!
+   real(r8) omeps     ! 1. - 0.622
+   real(r8) trinv     ! reciprocal of ttrice (transition range)
+   real(r8) tc        ! temperature (in degrees C)
+   real(r8) weight    ! weight for es transition from water to ice
+   real(r8) hltalt    ! appropriately modified hlat for T derivatives
+!
+   real(r8) hlatsb    ! hlat weighted in transition region
+   real(r8) hlatvp    ! hlat modified for t changes above freezing
+   real(r8) tterm     ! account for d(es)/dT in transition region
+   real(r8) desdt     ! d(es)/dT
+
+ ! Sungsu
+   real(r8) gam(len)  ! (l/cp)*(d(qs)/dt)
+ ! End by Sungsu
+!
+!-----------------------------------------------------------------------
+!
+   omeps = 1.0_r8 - epsqs
+   do i=1,len
+      es(i) = estblf(t(i))
+!
+! Saturation specific humidity
+!
+      qs(i) = epsqs*es(i)/(p(i) - omeps*es(i))
+!
+! The following check is to avoid the generation of negative
+! values that can occur in the upper stratosphere and mesosphere
+!
+      qs(i) = min(1.0_r8,qs(i))
+!
+      if (qs(i) < 0.0_r8) then
+         qs(i) = 1.0_r8
+         es(i) = p(i)
+      end if
+   end do
+!
+! "generalized" analytic expression for t derivative of es
+! accurate to within 1 percent for 173.16 < t < 373.16
+!
+   trinv = 0.0_r8
+   if ((.not. icephs) .or. (ttrice.eq.0.0_r8)) go to 10
+   trinv = 1.0_r8/ttrice
+   do i=1,len
+!
+! Weighting of hlat accounts for transition from water to ice
+! polynomial expression approximates difference between es over
+! water and es over ice from 0 to -ttrice (C) (min of ttrice is
+! -40): required for accurate estimate of es derivative in transition
+! range from ice to water also accounting for change of hlatv with t
+! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw
+!
+      tc     = t(i) - tmelt
+      lflg   = (tc >= -ttrice .and. tc < 0.0_r8)
+      weight = min(-tc*trinv,1.0_r8)
+      hlatsb = hlatv + weight*hlatf
+      hlatvp = hlatv - 2369.0_r8*tc
+      if (t(i) < tmelt) then
+         hltalt = hlatsb
+      else
+         hltalt = hlatvp
+      end if
+      if (lflg) then
+         tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + tc*(pcf(4) + tc*pcf(5))))
+      else
+         tterm = 0.0_r8
+      end if
+      desdt  = hltalt*es(i)/(rgasv*t(i)*t(i)) + tterm*trinv
+      gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i)))
+      if (qs(i) == 1.0_r8) gam(i) = 0.0_r8
+    ! Sungsu
+      dqsdt(i) = (cp/hltalt)*gam(i)
+    ! End by Sungsu
+   end do
+   return
+!
+! No icephs or water to ice transition
+!
+10 do i=1,len
+!
+! Account for change of hlatv with t above freezing where
+! constant slope is given by -2369 j/(kg c) = cpv - cw
+!
+      hlatvp = hlatv - 2369.0_r8*(t(i)-tmelt)
+      if (icephs) then
+         hlatsb = hlatv + hlatf
+      else
+         hlatsb = hlatv
+      end if
+      if (t(i) < tmelt) then
+         hltalt = hlatsb
+      else
+         hltalt = hlatvp
+      end if
+      desdt  = hltalt*es(i)/(rgasv*t(i)*t(i))
+      gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i)))
+      if (qs(i) == 1.0_r8) gam(i) = 0.0_r8
+    ! Sungsu
+      dqsdt(i) = (cp/hltalt)*gam(i)
+    ! End by Sungsu
+   end do
+!
+   return
+!
+end subroutine vqsatd2
+
+
+! Below routine is by Sungsu
+
+subroutine vqsatd2_single(t       ,p       ,es      ,qs      ,dqsdt)
+!----------------------------------------------------------------------- 
+! Sungsu : This is directly copied from 'vqsatd' but 'dqsdt' is output
+!          instead of gam for use in Sungsu's equilibrium stratiform
+!          macrophysics scheme.
+! 
+! Purpose: 
+! Utility procedure to look up and return saturation vapor pressure from
+! precomputed table, calculate and return saturation specific humidity
+! (g/g), and calculate and return gamma (l/cp)*(d(qsat)/dT).  The same
+! function as qsatd, but operates on vectors of temperature and pressure
+! 
+! Method: 
+! 
+! Author: J. Hack
+! 
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+   real(r8), intent(in) :: t       ! temperature
+   real(r8), intent(in) :: p       ! pressure
+!
+! Output arguments
+!
+   real(r8), intent(out) :: es     ! saturation vapor pressure
+   real(r8), intent(out) :: qs     ! saturation specific humidity
+ ! real(r8), intent(out) :: gam    ! (l/cp)*(d(qs)/dt)
+ ! Sungsu
+   real(r8), intent(out) :: dqsdt  ! (d(qs)/dt)
+ ! End by Sungsu 
+
+!
+!--------------------------Local Variables------------------------------
+!
+   logical lflg   ! true if in temperature transition region
+!
+!  integer i      ! index for vector calculations
+!
+   real(r8) omeps     ! 1. - 0.622
+   real(r8) trinv     ! reciprocal of ttrice (transition range)
+   real(r8) tc        ! temperature (in degrees C)
+   real(r8) weight    ! weight for es transition from water to ice
+   real(r8) hltalt    ! appropriately modified hlat for T derivatives
+!
+   real(r8) hlatsb    ! hlat weighted in transition region
+   real(r8) hlatvp    ! hlat modified for t changes above freezing
+   real(r8) tterm     ! account for d(es)/dT in transition region
+   real(r8) desdt     ! d(es)/dT
+
+ ! Sungsu
+   real(r8) gam       ! (l/cp)*(d(qs)/dt)
+ ! End by Sungsu
+!
+!-----------------------------------------------------------------------
+!
+   omeps = 1.0_r8 - epsqs
+
+!  do i=1,len
+
+      es = estblf(t)
+!
+! Saturation specific humidity
+!
+      qs = epsqs*es/(p - omeps*es)
+!
+! The following check is to avoid the generation of negative
+! values that can occur in the upper stratosphere and mesosphere
+!
+      qs = min(1.0_r8,qs)
+!
+      if (qs < 0.0_r8) then
+         qs = 1.0_r8
+         es = p
+      end if
+
+!  end do
+!
+! "generalized" analytic expression for t derivative of es
+! accurate to within 1 percent for 173.16 < t < 373.16
+!
+   trinv = 0.0_r8
+   if ((.not. icephs) .or. (ttrice.eq.0.0_r8)) go to 10
+   trinv = 1.0_r8/ttrice
+
+!  do i=1,len
+!
+! Weighting of hlat accounts for transition from water to ice
+! polynomial expression approximates difference between es over
+! water and es over ice from 0 to -ttrice (C) (min of ttrice is
+! -40): required for accurate estimate of es derivative in transition
+! range from ice to water also accounting for change of hlatv with t
+! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw
+!
+      tc     = t - tmelt
+      lflg   = (tc >= -ttrice .and. tc < 0.0_r8)
+      weight = min(-tc*trinv,1.0_r8)
+      hlatsb = hlatv + weight*hlatf
+      hlatvp = hlatv - 2369.0_r8*tc
+      if (t < tmelt) then
+         hltalt = hlatsb
+      else
+         hltalt = hlatvp
+      end if
+      if (lflg) then
+         tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + tc*(pcf(4) + tc*pcf(5))))
+      else
+         tterm = 0.0_r8
+      end if
+      desdt  = hltalt*es/(rgasv*t*t) + tterm*trinv
+      gam = hltalt*qs*p*desdt/(cp*es*(p - omeps*es))
+      if (qs == 1.0_r8) gam = 0.0_r8
+    ! Sungsu
+      dqsdt = (cp/hltalt)*gam
+    ! End by Sungsu
+!  end do
+   return
+!
+! No icephs or water to ice transition
+!
+
+10 continue
+
+!10 do i=1,len
+!
+! Account for change of hlatv with t above freezing where
+! constant slope is given by -2369 j/(kg c) = cpv - cw
+!
+      hlatvp = hlatv - 2369.0_r8*(t-tmelt)
+      if (icephs) then
+         hlatsb = hlatv + hlatf
+      else
+         hlatsb = hlatv
+      end if
+      if (t < tmelt) then
+         hltalt = hlatsb
+      else
+         hltalt = hlatvp
+      end if
+      desdt  = hltalt*es/(rgasv*t*t)
+      gam = hltalt*qs*p*desdt/(cp*es*(p - omeps*es))
+      if (qs == 1.0_r8) gam = 0.0_r8
+    ! Sungsu
+      dqsdt = (cp/hltalt)*gam
+    ! End by Sungsu
+
+!  end do
+!
+   return
+!
+end subroutine vqsatd2_single
+#endif
+
+end module wv_saturation 
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_bmj.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_bmj.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_bmj.F	(revision 17)
@@ -0,0 +1,2104 @@
+!-----------------------------------------------------------------------
+!
+!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        & 
+     &                 ,ELIWV=2.683E6,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                           &
+     &                 ,DTSHAL=-1.0,TREL=2400.
+!
+      REAL,PARAMETER :: DTtrigr=-0.0                                    &
+                       ,DTPtrigr=DTtrigr*PONE      !<-- Average parcel virtual temperature deficit over depth PONE.
+                                                   !<-- NOTE: CAPEtrigr is scaled by the cloud base temperature (see below)
+!
+      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                             &
+     &                 ,CUDT, CURR_SECS, ADAPT_STEP_FLAG                &
+     &                 ,RAINCV,PRATEC,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,   &
+           PRATEC
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CUBOT,CUTOP
+!
+      LOGICAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CU_ACT_FLAG
+
+! Adaptive time-step variables
+      REAL,  INTENT(IN   ) :: CUDT
+      REAL,  INTENT(IN   ) :: CURR_SECS
+      LOGICAL,INTENT(IN   ) :: ADAPT_STEP_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,LMH
+
+      LOGICAL :: run_param
+!     
+!***  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
+!                                                                        
+      if (adapt_step_flag) then
+         if ( (ITIMESTEP .eq. 0) .or. (cudt .eq. 0) .or. &
+         ( CURR_SECS + dt >= ( int( CURR_SECS / ( cudt * 60 ) ) + 1 ) * cudt * 60 ) ) then
+         run_param = .TRUE.
+      else
+         run_param = .FALSE.
+      endif
+      
+      else
+         if (MOD(ITIMESTEP,STEPCU) .EQ. 0 .or. ITIMESTEP .eq. 0) then
+            run_param = .TRUE.
+         else
+            run_param = .FALSE.
+         endif
+      endif
+      
+!-----------------------------------------------------------------------
+!                                                                      
+!***  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(run_param)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.
+          PRATEC(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
+          PRATEC(I,J)=PCPCOL*1.E3/(STEPCU * DT)
+!
+!***  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.LTOP<LBOT)THEN
+              DO K=LTOP,LBOT
+                PLYR=PLYR+DPCOL(K)
+                DELQ=DELQ+DPCOL(K)*DTCNVC*ABS(DQDT(K))
+                DELT=DELT+DPCOL(K)*DTCNVC*ABS(DTDT(K))
+              ENDDO
+              DELQ=DELQ/PLYR
+              DELT=DELT/PLYR
+            ENDIF
+!
+            WRITE(6,"(2a,2i4,3e12.4,f7.2,4i3)") &
+                 '{cu3 i,j,PCPCOL,DTavg,DQavg,PLYR,'  &
+                 ,'LBOT,LTOP,CUBOT,CUTOP = '  &
+                 ,i,j, PCPCOL,DELT,1000.*DELQ,.01*PLYR  &
+                 ,LBOT,LTOP,NINT(CUBOT(I,J)),NINT(CUTOP(I,J))
+!
+            IF(PLYR> 0.)THEN
+              DO K=LBOT,LTOP,-1
+                KFLIP=KTE+1-K
+                WRITE(6,"(a,i3,2e12.4,f7.2)") '{cu3a KFLIP,DT,DQ,DP = ' &
+                     ,KFLIP,DTCNVC*DTDT(K),1000.*DTCNVC*DQDT(K),.01*DPCOL(K)
+              ENDDO
+            ENDIF
+          ENDIF
+!***  End debugging convection
+!-----------------------------------------------------------------------
+!
+        ENDDO
+        ENDDO
+!
+      ENDIF
+!
+      END SUBROUTINE BMJDRV
+!-----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!-----------------------------------------------------------------------
+                          SUBROUTINE BMJ                                &
+!-----------------------------------------------------------------------
+     & (ITIMESTEP,I,J,DTCNVC,LMH,SM,CLDEFI                              &
+     & ,DPRS,PRSMID,Q,T,PSFC,PT                                         &
+     & ,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)
+!-----------------------------------------------------------------------
+      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,ITIMESTEP
+! 
+      INTEGER,INTENT(IN) :: LMH,LPBL
+!
+      INTEGER,INTENT(OUT) :: LBOT,LTOP
+!
+      REAL,INTENT(IN) :: CP,D608,DTCNVC,ELIV,ELWV,G,PSFC,PT,R,SM,TFRZ
+!
+      REAL,DIMENSION(KTS:KTE),INTENT(IN) :: DPRS,PRSMID,Q,T
+!
+      REAL,INTENT(INOUT) :: CLDEFI,PCPCOL
+!
+      REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: DQDT,DTDT
+!
+!-----------------------------------------------------------------------
+!***  DEFINE LOCAL VARIABLES
+!-----------------------------------------------------------------------
+!                                                            
+      REAL,DIMENSION(KTS:KTE) :: APEK,APESK,EL,FPK                      &
+                                ,PK,PSK,QK,QREFK,QSATK                  &
+                                ,THERK,THEVRF,THSK                      &
+                                ,THVMOD,THVREF,TK,TREFK
+      REAL,DIMENSION(KTS:KTE) :: APE,DIFQ,DIFT,THEE,THES,TREF
+!
+      REAL,DIMENSION(KTS:KTE) :: CPE,CPEcnv,DTV,DTVcnv,THEScnv    !<-- CPE for shallow convection buoyancy check (24 Aug 2006)
+!
+      LOGICAL :: DEEP,SHALLOW
+!
+!***  Begin debugging convection
+      LOGICAL :: PRINT_DIAG
+!***  End debugging convection
+!
+!-----------------------------------------------------------------------
+!***
+!***  LOCAL SCALARS
+!***
+!-----------------------------------------------------------------------
+      REAL :: APEKL,APEKXX,APEKXY,APES,APESTS                           &
+     &            ,AVRGT,AVRGTL,BQ,BQK,BQS00K,BQS10K                    &
+     &            ,CAPA,CUP,DEN,DENTPY,DEPMIN,DEPTH                     &
+     &            ,DEPWL,DHDT,DIFQL,DIFTL,DP,DPKL,DPLO,DPMIX,DPOT       &
+     &            ,DPUP,DQREF,DRHDP,DRHEAT,DSP                          &
+     &            ,DSP0,DSP0K,DSPB,DSPBK,DSPT,DSPTK                     &
+     &            ,DSQ,DST,DSTQ,DTHEM,DTDP,EFI                          &
+     &            ,FEFI,FFUP,FPRS,FPTK,HCORR                            &
+     &            ,OTSUM,P,P00K,P01K,P10K,P11K                          &
+     &            ,PART1,PART2,PART3,PBOT,PBOTFC,PBTK                   &
+     &            ,PK0,PKB,PKL,PKT,PKXXXX,PKXXXY                        &
+     &            ,PLMH,PELEVFC,PBTmx,plo,POTSUM,PP1,PPK,PRECK          &
+     &            ,PRESK,PSP,PSUM,PTHRS,PTOP,PTPK,PUP                   &
+     &            ,QBT,QKL,QNEW,QOTSUM,QQ1,QQK,QRFKL                    &
+     &            ,QRFTP,QSP,QSUM,QUP,RDP0T                             &
+     &            ,RDPSUM,RDTCNVC,RHH,RHL,RHMAX,ROTSUM,RTBAR,RHAVG      &
+     &            ,SM1,SMIX,SQ,SQK,SQS00K,SQS10K,STABDL,SUMDE,SUMDP     &
+     &            ,SUMDT,TAUK,TAUKSC,TCORR,THBT,THERKX,THERKY           &
+     &            ,THESP,THSKL,THTPK,THVMKL,TKL,TNEW                    &
+     &            ,TQ,TQK,TREFKX,TRFKL,trmlo,trmup,TSKL,tsp,TTH         &
+     &            ,TTHK,TUP                                             &
+     &            ,CAPEcnv,PSPcnv,THBTcnv,CAPEtrigr,CAPE                &
+     &            ,TLEV2,QSAT1,QSAT2,RHSHmax
+!
+      INTEGER :: IQ,IQTB,IT,ITER,ITREFI,ITTB,ITTBK,KB,KNUMH,KNUML       &
+     &          ,L,L0,L0M1,LB,LBM1,LCOR,LPT1                            &
+     &          ,LQM,LSHU,LTP1,LTP2,LTSH, LBOTcnv,LTOPcnv,LMID
+!-----------------------------------------------------------------------
+!
+      REAL,PARAMETER :: DSPBSL=DSPBFL*FSL,DSP0SL=DSP0FL*FSL             &
+     &                 ,DSPTSL=DSPTFL*FSL                               &
+     &                 ,DSPBSS=DSPBFS*FSS,DSP0SS=DSP0FS*FSS             &
+     &                 ,DSPTSS=DSPTFS*FSS
+!
+      REAL,PARAMETER :: ELEVFC=0.6,STEFI=1.
+!
+      REAL,PARAMETER :: SLOPBL=(DSPBFL-DSPBSL)/(1.-EFIMN)               &
+     &                 ,SLOP0L=(DSP0FL-DSP0SL)/(1.-EFIMN)               &
+     &                 ,SLOPTL=(DSPTFL-DSPTSL)/(1.-EFIMN)               &
+     &                 ,SLOPBS=(DSPBFS-DSPBSS)/(1.-EFIMN)               &
+     &                 ,SLOP0S=(DSP0FS-DSP0SS)/(1.-EFIMN)               &
+     &                 ,SLOPTS=(DSPTFS-DSPTSS)/(1.-EFIMN)               &
+     &                 ,SLOPST=(STABDF-STABDS)/(1.-EFIMN)               &
+     &                 ,SLOPE=(1.-EFMNT)/(1.-EFIMN)
+!
+      REAL :: A23M4L,CPRLG,ELOCP,RCP,QWAT
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      CAPA=R/CP
+      CPRLG=CP/(ROW*G*ELWV)
+      ELOCP=ELIWV/CP
+      RCP=1./CP
+      A23M4L=A2*(A3-A4)*ELWV
+      RDTCNVC=1./DTCNVC
+      DEPMIN=PSH*PSFC*RSFCP
+!
+      DEEP=.FALSE.
+      SHALLOW=.FALSE.
+!
+      DSP0=0.
+      DSPB=0.
+      DSPT=0.
+!-----------------------------------------------------------------------
+      TAUK=DTCNVC/TREL
+      TAUKSC=DTCNVC/(1.0*TREL) 
+!-----------------------------------------------------------------------
+!-----------------------------PREPARATIONS------------------------------
+!-----------------------------------------------------------------------
+      LBOT=LMH
+      PCPCOL=0.
+      TREF(KTS)=T(KTS)
+!
+      DO L=KTS,LMH
+        APESTS=PRSMID(L)
+        APE(L)=(1.E5/APESTS)**CAPA
+        CPEcnv(L)=0.
+        DTVcnv(L)=0.
+        THEScnv(L)=0.
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!----------------SEARCH FOR MAXIMUM BUOYANCY LEVEL----------------------
+!-----------------------------------------------------------------------
+!
+      PLMH=PRSMID(LMH)
+      PELEVFC=PLMH*ELEVFC
+      PBTmx=PRSMID(LMH)-PONE
+      CAPEcnv=0.
+      PSPcnv=0.
+      THBTcnv=0.
+      LBOTcnv=LBOT
+      LTOPcnv=LBOT
+!
+!-----------------------------------------------------------------------
+!----------------TRIAL MAXIMUM BUOYANCY LEVEL VARIABLES-----------------
+!-----------------------------------------------------------------------
+!
+      max_buoy_loop: DO KB=LMH,1,-1
+!
+!-----------------------------------------------------------------------
+!
+        PKL=PRSMID(KB)
+!       IF (PKL<PELEVFC .OR. T(KB)<=TFRZ) EXIT
+        IF (PKL<PELEVFC) EXIT
+        LBOT=LMH
+        LTOP=LMH
+!
+!-----------------------------------------------------------------------
+!***  SEARCH OVER A SCALED DEPTH IN FINDING THE PARCEL
+!***  WITH THE MAX THETA-E 
+!-----------------------------------------------------------------------
+!
+        QBT=Q(KB)
+        THBT=T(KB)*APE(KB)
+        TTH=(THBT-THL)*RDTH
+        QQ1=TTH-AINT(TTH)
+        ITTB=INT(TTH)+1
+!----------------KEEPING INDICES WITHIN THE TABLE-----------------------
+        IF(ITTB<1)THEN
+          ITTB=1
+          QQ1=0.
+        ELSE IF(ITTB>=JTB)THEN
+          ITTB=JTB-1
+          QQ1=0.
+        ENDIF
+!--------------BASE AND SCALING FACTOR FOR SPEC. HUMIDITY---------------
+        ITTBK=ITTB
+        BQS00K=QS0(ITTBK)
+        SQS00K=SQS(ITTBK)
+        BQS10K=QS0(ITTBK+1)
+        SQS10K=SQS(ITTBK+1)
+!--------------SCALING SPEC. HUMIDITY & TABLE INDEX---------------------
+        BQ=(BQS10K-BQS00K)*QQ1+BQS00K
+        SQ=(SQS10K-SQS00K)*QQ1+SQS00K
+        TQ=(QBT-BQ)/SQ*RDQ
+        PP1=TQ-AINT(TQ)
+        IQTB=INT(TQ)+1
+!----------------KEEPING INDICES WITHIN THE TABLE-----------------------
+        IF(IQTB<1)THEN
+          IQTB=1
+          PP1=0.
+        ELSE IF(IQTB>=ITB)THEN
+          IQTB=ITB-1
+          PP1=0.
+        ENDIF
+!--------------SATURATION PRESSURE AT FOUR SURROUNDING TABLE PTS.-------
+        IQ=IQTB
+        IT=ITTB
+        P00K=PTBL(IQ  ,IT  )
+        P10K=PTBL(IQ+1,IT  )
+        P01K=PTBL(IQ  ,IT+1)
+        P11K=PTBL(IQ+1,IT+1)
+!
+!--------------SATURATION POINT VARIABLES AT THE BOTTOM-----------------
+!
+        PSP=P00K+(P10K-P00K)*PP1+(P01K-P00K)*QQ1                        &
+     &          +(P00K-P10K-P01K+P11K)*PP1*QQ1
+        APES=(1.E5/PSP)**CAPA
+        THESP=THBT*EXP(ELOCP*QBT*APES/THBT)
+!
+!-----------------------------------------------------------------------
+!-----------CHOOSE CLOUD BASE AS MODEL LEVEL JUST BELOW PSP-------------
+!-----------------------------------------------------------------------
+!
+        DO L=KTS,LMH-1
+          P=PRSMID(L)
+          IF(P<PSP.AND.P>=PQM)LBOT=L+1
+        ENDDO
+!***
+!*** WARNING: LBOT MUST NOT BE > LMH-1 IN SHALLOW CONVECTION
+!*** MAKE SURE CLOUD BASE IS AT LEAST PONE ABOVE THE SURFACE
+!***
+        PBOT=PRSMID(LBOT)
+        IF(PBOT>=PBTmx.OR.LBOT>=LMH)THEN
+          DO L=KTS,LMH-1
+            P=PRSMID(L)
+            IF(P<PBTmx)LBOT=L
+          ENDDO
+          PBOT=PRSMID(LBOT)
+        ENDIF 
+!
+!-----------------------------------------------------------------------
+!----------------CLOUD TOP COMPUTATION----------------------------------
+!-----------------------------------------------------------------------
+!
+        LTOP=LBOT
+        PTOP=PBOT
+        DO L=LMH,KTS,-1
+          THES(L)=THESP
+        ENDDO
+!
+!-----------------------------------------------------------------------
+!### BEGIN: ###########  WARNING  ###########  WARNING  ###########
+!-----------------------------------------------------------------------
+!
+!### IMPORTANT: THIS "DO KB=LMH,1,-1" loop must be broken up into two
+!    separate loops in order for entrainment as programmed below to work
+!    properly.  
+!
+!---------------  ENTRAINMENT DURING PARCEL ASCENT  --------------------
+!
+!        DO L=LMH,KB,-1
+!          THES(L)=THESP
+!        ENDDO
+!
+!        DO L=KTS,LMH
+!          THEE(L)=THES(L)
+!        ENDDO
+!!
+!        FEFI=(CLDEFI-EFIMN)*SLOPE+EFMNT
+!        FFUP=FUP/(FEFI*FEFI)
+!!
+!        IF(PBOT>ENPLO)THEN
+!          FPRS=1.
+!        ELSEIF(PBOT>ENPUP)THEN
+!          FPRS=(PBOT-ENPUP)*RENDP
+!        ELSE
+!          FPRS=0.
+!        ENDIF
+!!
+!        FFUP=FFUP*FPRS*FPRS*0.5
+!        DPUP=DPRS(KB)
+!!
+!        DO L=KB-1,KTS,-1
+!          DPLO=DPUP
+!          DPUP=DPRS(L)
+!!
+!          THES(L)=((-FFUP*DPLO+1.)*THES(L+1)                           &
+!     &            +(THEE(L)*DPUP+THEE(L+1)*DPLO)*FFUP)                 &
+!     &           /(FFUP*DPUP+1.)
+!      ENDDO
+!
+!-----------------------------------------------------------------------
+!### END: ###########  WARNING  ###########  WARNING  ###########
+!-----------------------------------------------------------------------
+!!
+!-----------------------------------------------------------------------
+!!***  COMPUTE PARCEL TEMPERATURE ALONG THE ASCENT TRAJECTORY
+!!***  SCALING PRESSURE & TT TABLE INDEX.
+!-----------------------------------------------------------------------
+!!
+!!
+!       DO L=LMH,KTS,-1
+!!
+!         PRESK=PRSMID(L)
+!!
+!         IF(PRESK<PLQ)THEN
+!           CALL TTBLEX(ITB,JTB,PL,PRESK,RDP,RDTHE                      &
+!     &                ,STHE,THE0,THES(L),TTBL,TREF(L))
+!         ELSE
+!           CALL TTBLEX(ITBQ,JTBQ,PLQ,PRESK,RDPQ,RDTHEQ                 &
+!     &                ,STHEQ,THE0Q,THES(L),TTBLQ,TREF(L))
+!         ENDIF
+!!
+!       ENDDO
+!!
+!!-----------------------------------------------------------------------
+!!----------------BUOYANCY CHECK-----------------------------------------
+!!-----------------------------------------------------------------------
+!!
+!       DO L=LMH,KTS,-1
+!         IF(TREF(L)>T(L)-DTTOP)LTOP=L
+!       ENDDO
+!!
+!!***  CLOUD TOP PRESSURE
+!!
+!       PTOP=PRSMID(LTOP)
+!
+!------------------FIRST ENTROPY CHECK----------------------------------
+!
+        DO L=KTS,LMH
+          CPE(L)=0.
+          DTV(L)=0.
+        ENDDO
+!-----------------------------------------------------------------------
+!       lbot_ltop: IF(LBOT>LTOP)THEN
+!-----------------------------------------------------------------------
+!-- Begin: Buoyancy check including deep convection (24 Aug 2006) 
+!-----------------------------------------------------------------------
+          DENTPY=0.
+          L=KB
+          PLO=PRSMID(L)
+          TRMLO=0.
+          CAPEtrigr=DTPtrigr/T(LBOT)
+!
+!--- Below cloud base
+!
+          IF(KB>LBOT) THEN
+            DO L=KB-1,LBOT+1,-1
+              PUP=PRSMID(L)
+              TUP=THBT/APE(L)
+              DP=PLO-PUP
+              TRMUP=(TUP*(QBT*0.608+1.)                                 &
+     &            -T(L)*(Q(L)*0.608+1.))*0.5                            &
+     &             /(T(L)*(Q(L)*0.608+1.))
+              DTV(L)=TRMLO+TRMUP
+              DENTPY=DTV(L)*DP+DENTPY
+              CPE(L)=DENTPY
+              IF (DENTPY < CAPEtrigr) GO TO 170
+              PLO=PUP
+              TRMLO=TRMUP
+            ENDDO
+          ELSE
+            L=LBOT+1
+            PLO=PRSMID(L)
+            TUP=THBT/APE(L)
+            TRMLO=(TUP*(QBT*0.608+1.)                                   &
+     &            -T(L)*(Q(L)*0.608+1.))*0.5                            &
+     &             /(T(L)*(Q(L)*0.608+1.))
+          ENDIF  ! IF(KB>LBOT) THEN
+!
+!--- At cloud base
+!
+          L=LBOT
+          PUP=PSP
+          TUP=THBT/APES
+          TSP=(T(L+1)-T(L))/(PLO-PBOT)                                  &
+     &       *(PUP-PBOT)+T(L)
+          QSP=(Q(L+1)-Q(L))/(PLO-PBOT)                                  &
+     &       *(PUP-PBOT)+Q(L)
+          DP=PLO-PUP
+          TRMUP=(TUP*(QBT*0.608+1.)                                     &
+     &          -TSP*(QSP*0.608+1.))*0.5                                &
+     &         /(TSP*(QSP*0.608+1.))
+          DTV(L)=TRMLO+TRMUP
+          DENTPY=DTV(L)*DP+DENTPY
+          CPE(L)=DENTPY
+          DTV(L)=DTV(L)*DP
+          PLO=PUP
+          TRMLO=TRMUP
+          PUP=PRSMID(L)
+!
+!--- Calculate updraft temperature along moist adiabat (TUP)
+!
+          IF(PUP<PLQ)THEN
+            CALL TTBLEX(ITB,JTB,PL,PUP,RDP,RDTHE                        &
+     &                 ,STHE,THE0,THES(L),TTBL,TUP)
+          ELSE
+            CALL TTBLEX(ITBQ,JTBQ,PLQ,PUP,RDPQ,RDTHEQ                   &
+     &                 ,STHEQ,THE0Q,THES(L),TTBLQ,TUP)
+          ENDIF
+!
+          QUP=PQ0/PUP*EXP(A2*(TUP-A3)/(TUP-A4))
+          QWAT=QBT-QUP  !-- Water loading effects, reversible adiabat
+          DP=PLO-PUP
+          TRMUP=(TUP*(QUP*0.608+1.-QWAT)                                &
+     &          -T(L)*(Q(L)*0.608+1.))*0.5                              &
+     &         /(T(L)*(Q(L)*0.608+1.))
+          DENTPY=(TRMLO+TRMUP)*DP+DENTPY
+          CPE(L)=DENTPY
+          DTV(L)=(DTV(L)+(TRMLO+TRMUP)*DP)/(PRSMID(LBOT+1)-PRSMID(LBOT))
+!
+          IF (DENTPY < CAPEtrigr) GO TO 170
+!
+          PLO=PUP
+          TRMLO=TRMUP
+!
+!-----------------------------------------------------------------------
+!--- In cloud above cloud base
+!-----------------------------------------------------------------------
+!
+          DO L=LBOT-1,KTS,-1
+            PUP=PRSMID(L)
+!
+!--- Calculate updraft temperature along moist adiabat (TUP)
+!
+            IF(PUP<PLQ)THEN
+              CALL TTBLEX(ITB,JTB,PL,PUP,RDP,RDTHE                      &
+       &                 ,STHE,THE0,THES(L),TTBL,TUP)
+            ELSE
+              CALL TTBLEX(ITBQ,JTBQ,PLQ,PUP,RDPQ,RDTHEQ                 &
+       &                 ,STHEQ,THE0Q,THES(L),TTBLQ,TUP)
+            ENDIF
+!
+            QUP=PQ0/PUP*EXP(A2*(TUP-A3)/(TUP-A4))
+            QWAT=QBT-QUP  !-- Water loading effects, reversible adiabat
+            DP=PLO-PUP
+            TRMUP=(TUP*(QUP*0.608+1.-QWAT)                              &
+     &            -T(L)*(Q(L)*0.608+1.))*0.5                            &
+     &           /(T(L)*(Q(L)*0.608+1.))
+            DTV(L)=TRMLO+TRMUP
+            DENTPY=DTV(L)*DP+DENTPY
+            CPE(L)=DENTPY
+!
+            IF (DENTPY < CAPEtrigr) GO TO 170
+!
+            PLO=PUP
+            TRMLO=TRMUP
+          ENDDO
+!
+!-----------------------------------------------------------------------
+!
+170       LTP1=KB
+          CAPE=0.
+!
+!-----------------------------------------------------------------------
+!--- Cloud top level (LTOP) is located where CAPE is a maximum
+!--- Exit cloud-top search if CAPE < CAPEtrigr
+!-----------------------------------------------------------------------
+!
+          DO L=KB,KTS,-1
+            IF (CPE(L) < CAPEtrigr) THEN
+              EXIT
+            ELSE IF (CPE(L) > CAPE) THEN
+              LTP1=L
+              CAPE=CPE(L)
+            ENDIF
+          ENDDO      !-- End DO L=KB,KTS,-1
+!
+          LTOP=MIN(LTP1,LBOT)
+! 
+!-----------------------------------------------------------------------
+!--------------- CHECK FOR MAXIMUM INSTABILITY  ------------------------
+!-----------------------------------------------------------------------
+          IF(CAPE > CAPEcnv) THEN
+            CAPEcnv=CAPE
+            PSPcnv=PSP
+            THBTcnv=THBT
+            LBOTcnv=LBOT
+            LTOPcnv=LTOP
+            DO L=LMH,KTS,-1
+              CPEcnv(L)=CPE(L)
+              DTVcnv(L)=DTV(L)
+              THEScnv(L)=THES(L)
+            ENDDO
+          ENDIF    ! End IF(CAPE > CAPEcnv) THEN
+!
+!       ENDIF lbot_ltop
+!
+!-----------------------------------------------------------------------
+!
+      ENDDO max_buoy_loop
+!
+!-----------------------------------------------------------------------
+!------------------------  MAXIMUM INSTABILITY  ------------------------
+!-----------------------------------------------------------------------
+!
+      IF(CAPEcnv > 0.) THEN
+        PSP=PSPcnv
+        THBT=THBTcnv
+        LBOT=LBOTcnv
+        LTOP=LTOPcnv
+        PBOT=PRSMID(LBOT)
+        PTOP=PRSMID(LTOP)
+!
+        DO L=LMH,KTS,-1
+          CPE(L)=CPEcnv(L)
+          DTV(L)=DTVcnv(L)
+          THES(L)=THEScnv(L)
+        ENDDO
+!
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!-----  Quick exit if cloud is too thin or no CAPE is present  ---------
+!-----------------------------------------------------------------------
+!
+      IF(PTOP>PBOT-PNO.OR.LTOP>LBOT-2.OR.CAPEcnv<=0.)THEN
+        LBOT=0
+        LTOP=KTE
+        PBOT=PRSMID(LMH)
+        PTOP=PBOT
+        CLDEFI=AVGEFI*SM+STEFI*(1.-SM)
+        GO TO 800
+      ENDIF
+!
+!***  DEPTH OF CLOUD REQUIRED TO MAKE THE POINT A DEEP CONVECTION POINT
+!***  IS A SCALED VALUE OF PSFC.
+!
+      DEPTH=PBOT-PTOP
+!
+      IF(DEPTH>=DEPMIN) THEN
+        DEEP=.TRUE.
+      ELSE
+        SHALLOW=.TRUE.
+        GO TO 600
+      ENDIF
+!
+!-----------------------------------------------------------------------
+!DCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCD
+!DCDCDCDCDCDCDCDCDCDCDC    DEEP CONVECTION   DCDCDCDCDCDCDCDCDCDCDCDCDCD
+!DCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCD
+!-----------------------------------------------------------------------
+!
+  300 CONTINUE
+!
+      LB =LBOT
+      EFI=CLDEFI
+!-----------------------------------------------------------------------
+!--------------INITIALIZE VARIABLES IN THE CONVECTIVE COLUMN------------
+!-----------------------------------------------------------------------
+!***
+!***  ONE SHOULD NOTE THAT THE VALUES ASSIGNED TO THE ARRAY TREFK
+!***  IN THE FOLLOWING LOOP ARE REALLY ONLY RELEVANT IN ANCHORING THE
+!***  REFERENCE TEMPERATURE PROFILE AT LEVEL LB.  WHEN BUILDING THE
+!***  REFERENCE PROFILE FROM CLOUD BASE, THEN ASSIGNING THE
+!***  AMBIENT TEMPERATURE TO TREFK IS ACCEPTABLE.  HOWEVER, WHEN
+!***  BUILDING THE REFERENCE PROFILE FROM SOME OTHER LEVEL (SUCH AS
+!***  ONE LEVEL ABOVE THE GROUND), THEN TREFK SHOULD BE FILLED WITH
+!***  THE TEMPERATURES IN TREF(L) WHICH ARE THE TEMPERATURES OF
+!***  THE MOIST ADIABAT THROUGH CLOUD BASE.  BY THE TIME THE LINE 
+!***  NUMBERED 450 HAS BEEN REACHED, TREFK ACTUALLY DOES HOLD THE
+!***  REFERENCE TEMPERATURE PROFILE.
+!***
+      DO L=KTS,LMH
+        DIFT  (L)=0.
+        DIFQ  (L)=0.
+        TKL      =T(L)
+        TK    (L)=TKL
+        TREFK (L)=TKL
+        QKL      =Q(L)
+        QK    (L)=QKL
+        QREFK (L)=QKL
+        PKL      =PRSMID(L)
+        PK    (L)=PKL
+        PSK   (L)=PKL
+        APEKL    =APE(L)
+        APEK  (L)=APEKL
+!
+!--- Calculate temperature along moist adiabat (TREF)
+!
+        IF(PKL<PLQ)THEN
+          CALL TTBLEX(ITB,JTB,PL,PKL,RDP,RDTHE                          &
+     &               ,STHE,THE0,THES(L),TTBL,TREF(L))
+        ELSE
+          CALL TTBLEX(ITBQ,JTBQ,PLQ,PKL,RDPQ,RDTHEQ                     &
+     &               ,STHEQ,THE0Q,THES(L),TTBLQ,TREF(L))
+        ENDIF
+        THERK (L)=TREF(L)*APEKL
+      ENDDO
+!
+!------------DEEP CONVECTION REFERENCE TEMPERATURE PROFILE------------
+!
+      LTP1=LTOP+1
+      LBM1=LB-1
+      PKB=PK(LB)
+      PKT=PK(LTOP)
+      STABDL=(EFI-EFIMN)*SLOPST+STABDS
+!
+!------------TEMPERATURE REFERENCE PROFILE BELOW FREEZING LEVEL-------
+!
+      EL(LB) = ELWV    
+      L0=LB
+      PK0=PK(LB)
+      TREFKX=TREFK(LB)
+      THERKX=THERK(LB)
+      APEKXX=APEK(LB)
+      THERKY=THERK(LBM1)
+      APEKXY=APEK(LBM1)
+!
+      DO L=LBM1,LTOP,-1
+        IF(T(L+1)<TFRZ)GO TO 430
+        TREFKX=((THERKY-THERKX)*STABDL                                  &
+     &          +TREFKX*APEKXX)/APEKXY
+        TREFK(L)=TREFKX
+        EL(L)=ELWV
+        APEKXX=APEKXY
+        THERKX=THERKY
+        APEKXY=APEK(L-1)
+        THERKY=THERK(L-1)
+        L0=L
+        PK0=PK(L0)
+      ENDDO
+!
+!--------------FREEZING LEVEL AT OR ABOVE THE CLOUD TOP-----------------
+!
+      GO TO 450
+!
+!--------------TEMPERATURE REFERENCE PROFILE ABOVE FREEZING LEVEL-------
+!
+  430 L0M1=L0-1
+      RDP0T=1./(PK0-PKT)
+      DTHEM=THERK(L0)-TREFK(L0)*APEK(L0)
+!
+      DO L=LTOP,L0M1
+        TREFK(L)=(THERK(L)-(PK(L)-PKT)*DTHEM*RDP0T)/APEK(L)
+        EL(L)=ELWV !ELIV
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!--------------DEEP CONVECTION REFERENCE HUMIDITY PROFILE---------------
+!-----------------------------------------------------------------------
+!
+!***  DEPWL IS THE PRESSURE DIFFERENCE BETWEEN CLOUD BASE AND
+!***  THE FREEZING LEVEL
+!
+  450 CONTINUE
+      DEPWL=PKB-PK0
+      DEPTH=PFRZ*PSFC*RSFCP
+      SM1=1.-SM
+      PBOTFC=1.
+!
+!-------------FIRST ADJUSTMENT OF TEMPERATURE PROFILE-------------------
+!!
+!      SUMDT=0.
+!      SUMDP=0.
+!!
+!      DO L=LTOP,LB
+!        SUMDT=(TK(L)-TREFK(L))*DPRS(L)+SUMDT
+!        SUMDP=SUMDP+DPRS(L)
+!      ENDDO
+!!
+!      TCORR=SUMDT/SUMDP
+!!
+!      DO L=LTOP,LB
+!        TREFK(L)=TREFK(L)+TCORR
+!      ENDDO
+!!
+!-----------------------------------------------------------------------
+!--------------- ITERATION LOOP FOR CLOUD EFFICIENCY -------------------
+!-----------------------------------------------------------------------
+!
+      cloud_efficiency : DO ITREFI=1,ITREFI_MAX  
+!
+!-----------------------------------------------------------------------
+        DSPBK=((EFI-EFIMN)*SLOPBS+DSPBSS*PBOTFC)*SM                     &
+     &       +((EFI-EFIMN)*SLOPBL+DSPBSL*PBOTFC)*SM1
+        DSP0K=((EFI-EFIMN)*SLOP0S+DSP0SS*PBOTFC)*SM                     &
+     &       +((EFI-EFIMN)*SLOP0L+DSP0SL*PBOTFC)*SM1
+        DSPTK=((EFI-EFIMN)*SLOPTS+DSPTSS*PBOTFC)*SM                     &
+     &       +((EFI-EFIMN)*SLOPTL+DSPTSL*PBOTFC)*SM1
+!
+!-----------------------------------------------------------------------
+!
+        DO L=LTOP,LB
+!
+!***
+!***  SATURATION PRESSURE DIFFERENCE
+!***
+          IF(DEPWL>=DEPTH)THEN
+            IF(L<L0)THEN
+              DSP=((PK0-PK(L))*DSPTK+(PK(L)-PKT)*DSP0K)/(PK0-PKT)
+            ELSE
+              DSP=((PKB-PK(L))*DSP0K+(PK(L)-PK0)*DSPBK)/(PKB-PK0)
+            ENDIF
+          ELSE
+            DSP=DSP0K
+            IF(L<L0)THEN
+              DSP=((PK0-PK(L))*DSPTK+(PK(L)-PKT)*DSP0K)/(PK0-PKT)
+            ENDIF
+          ENDIF
+!***
+!***  HUMIDITY PROFILE
+!***
+          IF(PK(L)>PQM)THEN
+            PSK(L)=PK(L)+DSP
+            APESK(L)=(1.E5/PSK(L))**CAPA
+            THSK(L)=TREFK(L)*APEK(L)
+            QREFK(L)=PQ0/PSK(L)*EXP(A2*(THSK(L)-A3*APESK(L))            &
+     &                                /(THSK(L)-A4*APESK(L)))
+          ELSE
+            QREFK(L)=QK(L)
+          ENDIF
+!
+        ENDDO
+!-----------------------------------------------------------------------
+!***
+!***  ENTHALPY CONSERVATION INTEGRAL
+!***
+!-----------------------------------------------------------------------
+        enthalpy_conservation : DO ITER=1,2
+!
+          SUMDE=0.
+          SUMDP=0.
+!
+          DO L=LTOP,LB
+            SUMDE=((TK(L)-TREFK(L))*CP+(QK(L)-QREFK(L))*EL(L))*DPRS(L)  &
+     &            +SUMDE
+            SUMDP=SUMDP+DPRS(L)
+          ENDDO
+!
+          HCORR=SUMDE/(SUMDP-DPRS(LTOP))
+          LCOR=LTOP+1
+!***
+!***  FIND LQM
+!***
+          LQM=1
+          DO L=KTS,LB
+            IF(PK(L)<=PQM)LQM=L
+          ENDDO
+!***
+!***  ABOVE LQM CORRECT TEMPERATURE ONLY
+!***
+          IF(LCOR<=LQM)THEN
+            DO L=LCOR,LQM
+              TREFK(L)=TREFK(L)+HCORR*RCP
+            ENDDO
+            LCOR=LQM+1
+          ENDIF
+!***
+!***  BELOW LQM CORRECT BOTH TEMPERATURE AND MOISTURE
+!***
+          DO L=LCOR,LB
+            TSKL=TREFK(L)*APEK(L)/APESK(L)
+            DHDT=QREFK(L)*A23M4L/(TSKL-A4)**2+CP
+            TREFK(L)=HCORR/DHDT+TREFK(L)
+            THSKL=TREFK(L)*APEK(L)
+            QREFK(L)=PQ0/PSK(L)*EXP(A2*(THSKL-A3*APESK(L))              &
+     &                                /(THSKL-A4*APESK(L)))
+          ENDDO
+!
+        ENDDO  enthalpy_conservation
+!-----------------------------------------------------------------------
+!
+!***  HEATING, MOISTENING, PRECIPITATION
+!
+!-----------------------------------------------------------------------
+        AVRGT=0.
+        PRECK=0.
+        DSQ=0.
+        DST=0.
+!
+        DO L=LTOP,LB
+          TKL=TK(L)
+          DIFTL=(TREFK(L)-TKL  )*TAUK
+          DIFQL=(QREFK(L)-QK(L))*TAUK
+          AVRGTL=(TKL+TKL+DIFTL)
+          DPOT=DPRS(L)/AVRGTL
+          DST=DIFTL*DPOT+DST
+          DSQ=DIFQL*EL(L)*DPOT+DSQ
+          AVRGT=AVRGTL*DPRS(L)+AVRGT
+          PRECK=DIFTL*DPRS(L)+PRECK
+          DIFT(L)=DIFTL
+          DIFQ(L)=DIFQL
+        ENDDO
+!
+        DST=(DST+DST)*CP
+        DSQ=DSQ+DSQ
+        DENTPY=DST+DSQ
+        AVRGT=AVRGT/(SUMDP+SUMDP)
+!
+!        DRHEAT=PRECK*CP/AVRGT
+        DRHEAT=(PRECK*SM+MAX(1.E-7,PRECK)*(1.-SM))*CP/AVRGT !As in Eta!
+        DRHEAT=MAX(DRHEAT,1.E-20)
+        EFI=EFIFC*DENTPY/DRHEAT
+!-----------------------------------------------------------------------
+        EFI=MIN(EFI,1.)
+        EFI=MAX(EFI,EFIMN)
+!-----------------------------------------------------------------------
+!
+      ENDDO  cloud_efficiency
+!
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!---------------------- DEEP CONVECTION --------------------------------
+!-----------------------------------------------------------------------
+!
+      IF(DENTPY>=EPSNTP.AND.PRECK>EPSPR)THEN
+!
+        CLDEFI=EFI
+        FEFI=EFMNT+SLOPE*(EFI-EFIMN)
+        FEFI=(DENTPY-EPSNTP)*FEFI/DENTPY
+        PRECK=PRECK*FEFI
+!
+!***  UPDATE PRECIPITATION AND TENDENCIES OF TEMPERATURE AND MOISTURE
+!
+        CUP=PRECK*CPRLG
+        PCPCOL=CUP
+!
+        DO L=LTOP,LB
+          DTDT(L)=DIFT(L)*FEFI*RDTCNVC
+          DQDT(L)=DIFQ(L)*FEFI*RDTCNVC
+        ENDDO
+!
+      ELSE
+!
+!-----------------------------------------------------------------------
+!***  REDUCE THE CLOUD TOP
+!-----------------------------------------------------------------------
+!
+!        LTOP=LTOP+3
+!        PTOP=PRSMID(LTOP)
+!        DEPMIN=PSH*PSFC*RSFCP
+!        DEPTH=PBOT-PTOP
+!***
+!***  ITERATE DEEP CONVECTION PROCEDURE IF NEEDED
+!***
+!        IF(DEPTH>=DEPMIN)THEN
+!          GO TO 300
+!        ENDIF
+!
+!        CLDEFI=AVGEFI
+         CLDEFI=EFIMN*SM+STEFI*(1.-SM)
+!***
+!***  SEARCH FOR SHALLOW CLOUD TOP
+!***
+!        LTSH=LBOT
+!        LBM1=LBOT-1
+!        PBTK=PK(LBOT)
+!        DEPMIN=PSH*PSFC*RSFCP
+!        PTPK=PBTK-DEPMIN
+        PTPK=MAX(PSHU, PK(LBOT)-DEPMIN)
+!***
+!***  CLOUD TOP IS THE LEVEL JUST BELOW PBTK-PSH or JUST BELOW PSHU
+!***
+        DO L=KTS,LMH
+          IF(PK(L)<=PTPK)LTOP=L+1
+        ENDDO
+!
+!        PTPK=PK(LTOP)
+!!***
+!!***  HIGHEST LEVEL ALLOWED IS LEVEL JUST BELOW PSHU
+!!***
+!        IF(PTPK<=PSHU)THEN
+!!
+!          DO L=KTS,LMH
+!            IF(PK(L)<=PSHU)LSHU=L+1
+!          ENDDO
+!!
+!          LTOP=LSHU
+!          PTPK=PK(LTOP)
+!        ENDIF
+!
+!        if(ltop>=lbot)then
+!!!!!!     lbot=0
+!          ltop=lmh
+!!!!!!     pbot=pk(lbot)
+!          ptop=pk(ltop)
+!          pbot=ptop
+!          go to 600
+!        endif
+!
+!        LTP1=LTOP+1
+!        LTP2=LTOP+2
+!!
+!        DO L=LTOP,LBOT
+!          QSATK(L)=PQ0/PK(L)*EXP(A2*(TK(L)-A3)/(TK(L)-A4))
+!        ENDDO
+!!
+!        RHH=QK(LTOP)/QSATK(LTOP)
+!        RHMAX=0.
+!        LTSH=LTOP
+!!
+!        DO L=LTP1,LBM1
+!          RHL=QK(L)/QSATK(L)
+!          DRHDP=(RHH-RHL)/(PK(L-1)-PK(L))
+!!
+!          IF(DRHDP>RHMAX)THEN
+!            LTSH=L-1
+!            RHMAX=DRHDP
+!          ENDIF
+!!
+!          RHH=RHL
+!        ENDDO
+!
+!-----------------------------------------------------------------------
+!-- Make shallow cloud top a function of virtual temperature excess (DTV)
+!-----------------------------------------------------------------------
+!
+        LTP1=LBOT
+        DO L=LBOT-1,LTOP,-1
+          IF (DTV(L) > 0.) THEN
+            LTP1=L
+          ELSE
+            EXIT
+          ENDIF
+        ENDDO
+        LTOP=MIN(LTP1,LBOT)
+!***
+!***  CLOUD MUST BE AT LEAST TWO LAYERS THICK
+!***
+!        IF(LBOT-LTOP<2)LTOP=LBOT-2  (eliminate this criterion)
+!
+!-- End: Buoyancy check (24 Aug 2006)
+!
+        PTOP=PK(LTOP)
+        SHALLOW=.TRUE.
+        DEEP=.FALSE.
+!
+      ENDIF
+!DCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCD
+!DCDCDCDCDCDCDC          END OF DEEP CONVECTION            DCDCDCDCDCDCD
+!DCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCDCD
+!
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+  600 CONTINUE
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+!
+!----------------GATHER SHALLOW CONVECTION POINTS-----------------------
+!
+!      IF(PTOP<=PBOT-PNO.AND.LTOP<=LBOT-2)THEN
+!         DEPMIN=PSH*PSFC*RSFCP
+!!
+!!        if(lpbl<lbot)lbot=lpbl
+!!        if(lbot>lmh-1)lbot=lmh-1
+!!        pbot=prsmid(lbot)
+!!
+!         IF(PTOP+1.>=PBOT-DEPMIN)SHALLOW=.TRUE.
+!      ELSE
+!         LBOT=0
+!         LTOP=KTE
+!      ENDIF
+!
+!***********************************************************************
+!-----------------------------------------------------------------------
+!***  Begin debugging convection
+      IF(PRINT_DIAG)THEN
+        WRITE(6,"(a,2i3,L2,3e12.4)")  &
+             '{cu2a lbot,ltop,shallow,pbot,ptop,depmin = ' &
+             ,lbot,ltop,shallow,pbot,ptop,depmin
+      ENDIF
+!***  End debugging convection
+!-----------------------------------------------------------------------
+!
+      IF(.NOT.SHALLOW)GO TO 800
+!
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!SCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCS
+!SCSCSCSCSCSCSC         SHALLOW CONVECTION          CSCSCSCSCSCSCSCSCSCS
+!SCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCS
+!-----------------------------------------------------------------------
+      DO L=KTS,LMH
+        TKL      =T(L)
+        TK   (L) =TKL
+        TREFK(L) =TKL
+        QKL      =Q(L)
+        QK   (L) =QKL
+        QREFK(L) =QKL
+        PKL      =PRSMID(L)
+        PK   (L) =PKL
+        QSATK(L) =PQ0/PK(L)*EXP(A2*(TK(L)-A3)/(TK(L)-A4))
+        APEKL    =APE(L)
+        APEK (L) =APEKL
+        THVMKL   =TKL*APEKL*(QKL*D608+1.)
+        THVREF(L)=THVMKL
+!
+!        IF(TKL>=TFRZ)THEN
+          EL(L)=ELWV
+!        ELSE
+!          EL(L)=ELIV
+!        ENDIF
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!-- Begin: Raise cloud top if avg RH>RHSHmax and CAPE>0
+!   RHSHmax=RH at cloud base associated with a DSP of PONE
+!-----------------------------------------------------------------------
+!
+      TLEV2=T(LBOT)*((PK(LBOT)-PONE)/PK(LBOT))**CAPA
+      QSAT1=PQ0/PK(LBOT)*EXP(A2*(T(LBOT)-A3)/(TK(LBOT)-A4))
+      QSAT2=PQ0/(PK(LBOT)-PONE)*EXP(A2*(TLEV2-A3)/(TLEV2-A4))
+      RHSHmax=QSAT2/QSAT1
+      SUMDP=0.
+      RHAVG=0.
+!
+      DO L=LBOT,LTOP,-1
+        RHAVG=RHAVG+DPRS(L)*QK(L)/QSATK(L)
+        SUMDP=SUMDP+DPRS(L)
+      ENDDO
+!
+      IF (RHAVG/SUMDP > RHSHmax) THEN
+        LTSH=LTOP
+        DO L=LTOP-1,KTS,-1
+          RHAVG=RHAVG+DPRS(L)*QK(L)/QSATK(L)
+          SUMDP=SUMDP+DPRS(L)
+          IF (CPE(L) > 0.) THEN
+            LTSH=L
+          ELSE
+            EXIT
+          ENDIF
+          IF (RHAVG/SUMDP <= RHSHmax) EXIT
+          IF (PK(L) <= PSHU) EXIT
+        ENDDO
+        LTOP=LTSH
+      ENDIF
+!
+!-- End: Raise cloud top if avg RH>RHSHmax and CAPE>0
+!
+!---------------------------SHALLOW CLOUD TOP---------------------------
+      LBM1=LBOT-1
+      PTPK=PTOP
+      LTP1=LTOP-1
+      DEPTH=PBOT-PTOP
+!-----------------------------------------------------------------------
+!***  Begin debugging convection
+      IF(PRINT_DIAG)THEN
+        WRITE(6,"(a,4e12.4)") '{cu2b PBOT,PTOP,DEPTH,DEPMIN= ' &
+             ,PBOT,PTOP,DEPTH,DEPMIN
+      ENDIF
+!***  End debugging convection
+!-----------------------------------------------------------------------
+!
+!BSF      IF(DEPTH<DEPMIN)THEN
+!BSF        GO TO 800
+!BSF      ENDIF
+!-----------------------------------------------------------------------
+      IF(PTOP>PBOT-PNO.OR.LTOP>LBOT-2)THEN
+        LBOT=0
+!!!     LTOP=LBOT
+        LTOP=KTE
+        PTOP=PBOT
+        GO TO 800
+      ENDIF
+!
+!--------------SCALING POTENTIAL TEMPERATURE & TABLE INDEX AT TOP-------
+!
+      THTPK=T(LTP1)*APE(LTP1)
+!
+      TTHK=(THTPK-THL)*RDTH
+      QQK =TTHK-AINT(TTHK)
+      IT  =INT(TTHK)+1
+!
+      IF(IT<1)THEN
+        IT=1
+        QQK=0.
+      ENDIF
+!
+      IF(IT>=JTB)THEN
+        IT=JTB-1
+        QQK=0.
+      ENDIF
+!
+!--------------BASE AND SCALING FACTOR FOR SPEC. HUMIDITY AT TOP--------
+!
+      BQS00K=QS0(IT)
+      SQS00K=SQS(IT)
+      BQS10K=QS0(IT+1)
+      SQS10K=SQS(IT+1)
+!
+!--------------SCALING SPEC. HUMIDITY & TABLE INDEX AT TOP--------------
+!
+      BQK=(BQS10K-BQS00K)*QQK+BQS00K
+      SQK=(SQS10K-SQS00K)*QQK+SQS00K
+!
+!     TQK=(Q(LTOP)-BQK)/SQK*RDQ
+      TQK=(Q(LTP1)-BQK)/SQK*RDQ
+!
+      PPK=TQK-AINT(TQK)
+      IQ =INT(TQK)+1
+!
+      IF(IQ<1)THEN
+        IQ=1
+        PPK=0.
+      ENDIF
+!
+      IF(IQ>=ITB)THEN
+        IQ=ITB-1
+        PPK=0.
+      ENDIF
+!
+!----------------CLOUD TOP SATURATION POINT PRESSURE--------------------
+!
+      PART1=(PTBL(IQ+1,IT)-PTBL(IQ,IT))*PPK
+      PART2=(PTBL(IQ,IT+1)-PTBL(IQ,IT))*QQK
+      PART3=(PTBL(IQ  ,IT  )-PTBL(IQ+1,IT  )                            &
+     &      -PTBL(IQ  ,IT+1)+PTBL(IQ+1,IT+1))*PPK*QQK
+      PTPK=PTBL(IQ,IT)+PART1+PART2+PART3
+!-----------------------------------------------------------------------
+      DPMIX=PTPK-PSP
+      IF(ABS(DPMIX).LT.3000.)DPMIX=-3000.
+!
+!----------------TEMPERATURE PROFILE SLOPE------------------------------
+!
+      SMIX=(THTPK-THBT)/DPMIX*STABS
+!
+      TREFKX=TREFK(LBOT+1)
+      PKXXXX=PK(LBOT+1)
+      PKXXXY=PK(LBOT)
+      APEKXX=APEK(LBOT+1)
+      APEKXY=APEK(LBOT)
+!
+      LMID=.5*(LBOT+LTOP)
+!
+      DO L=LBOT,LTOP,-1
+        TREFKX=((PKXXXY-PKXXXX)*SMIX                                    &
+     &          +TREFKX*APEKXX)/APEKXY
+        TREFK(L)=TREFKX
+        IF(L<=LMID) TREFK(L)=MAX(TREFK(L), TK(L)+DTSHAL)
+        APEKXX=APEKXY
+        PKXXXX=PKXXXY
+        APEKXY=APEK(L-1)
+        PKXXXY=PK(L-1)
+      ENDDO
+!
+!----------------TEMPERATURE REFERENCE PROFILE CORRECTION---------------
+!
+      SUMDT=0.
+      SUMDP=0.
+!
+      DO L=LTOP,LBOT
+        SUMDT=(TK(L)-TREFK(L))*DPRS(L)+SUMDT
+        SUMDP=SUMDP+DPRS(L)
+      ENDDO
+!
+      RDPSUM=1./SUMDP
+      FPK(LBOT)=TREFK(LBOT)
+!
+      TCORR=SUMDT*RDPSUM
+!
+      DO L=LTOP,LBOT
+        TRFKL   =TREFK(L)+TCORR
+        TREFK(L)=TRFKL
+        FPK  (L)=TRFKL
+      ENDDO
+!
+!----------------HUMIDITY PROFILE EQUATIONS-----------------------------
+!
+      PSUM  =0.
+      QSUM  =0.
+      POTSUM=0.
+      QOTSUM=0.
+      OTSUM =0.
+      DST   =0.
+      FPTK  =FPK(LTOP)
+!
+      DO L=LTOP,LBOT
+        DPKL  =FPK(L)-FPTK
+        PSUM  =DPKL *DPRS(L)+PSUM
+        QSUM  =QK(L)*DPRS(L)+QSUM
+        RTBAR =2./(TREFK(L)+TK(L))
+        OTSUM =DPRS(L)*RTBAR+OTSUM
+        POTSUM=DPKL    *RTBAR*DPRS(L)+POTSUM
+        QOTSUM=QK(L)   *RTBAR*DPRS(L)+QOTSUM
+        DST   =(TREFK(L)-TK(L))*RTBAR*DPRS(L)/EL(L)+DST
+      ENDDO
+!
+      PSUM  =PSUM*RDPSUM
+      QSUM  =QSUM*RDPSUM
+      ROTSUM=1./OTSUM
+      POTSUM=POTSUM*ROTSUM
+      QOTSUM=QOTSUM*ROTSUM
+      DST   =DST*ROTSUM*CP
+!
+!-----------------------------------------------------------------------
+!***  Begin debugging convection
+      IF(PRINT_DIAG)THEN
+        WRITE(6,"(a,5e12.4)") '{cu2c DST,PSUM,QSUM,POTSUM,QOTSUM = ' &
+             ,DST,PSUM,QSUM,POTSUM,QOTSUM
+      ENDIF
+!***  End debugging convection
+!-----------------------------------------------------------------------
+!
+!----------------ENSURE POSITIVE ENTROPY CHANGE-------------------------
+!
+      IF(DST>0.)THEN
+!        dstq=dst*epsup
+        LBOT=0
+!!!!    LTOP=LBOT
+        LTOP=KTE
+        PTOP=PBOT
+        GO TO 800
+      ELSE
+        DSTQ=DST*EPSDN
+      ENDIF
+!
+!----------------CHECK FOR ISOTHERMAL ATMOSPHERE------------------------
+!
+      DEN=POTSUM-PSUM
+!
+      IF(-DEN/PSUM<5.E-5)THEN
+        LBOT=0
+!!!!    LTOP=LBOT
+        LTOP=KTE
+        PTOP=PBOT
+        GO TO 800
+!
+!----------------SLOPE OF THE REFERENCE HUMIDITY PROFILE----------------
+!
+      ELSE
+        DQREF=(QOTSUM-DSTQ-QSUM)/DEN
+      ENDIF
+!
+!-------------- HUMIDITY DOES NOT INCREASE WITH HEIGHT------------------
+!
+      IF(DQREF<0.)THEN
+        LBOT=0
+!!!!    LTOP=LBOT
+        LTOP=KTE
+        PTOP=PBOT
+        GO TO 800
+      ENDIF
+!
+!----------------HUMIDITY AT THE CLOUD TOP------------------------------
+!
+      QRFTP=QSUM-DQREF*PSUM
+!
+!----------------HUMIDITY PROFILE---------------------------------------
+!
+      DO L=LTOP,LBOT
+        QRFKL=(FPK(L)-FPTK)*DQREF+QRFTP
+!
+!***  TOO DRY CLOUDS NOT ALLOWED
+!
+        TNEW=(TREFK(L)-TK(L))*TAUKSC+TK(L)
+        QSATK(L)=PQ0/PK(L)*EXP(A2*(TNEW-A3)/(TNEW-A4))
+        QNEW=(QRFKL-QK(L))*TAUKSC+QK(L)
+!
+        IF(QNEW<QSATK(L)*RHLSC)THEN
+          LBOT=0
+!!!!      LTOP=LBOT
+          LTOP=KTE
+          PTOP=PBOT
+          GO TO 800
+        ENDIF
+!
+!-------------TOO MOIST CLOUDS NOT ALLOWED------------------------------
+!
+        IF(QNEW>QSATK(L)*RHHSC)THEN
+          LBOT=0
+!!!!      LTOP=LBOT
+          LTOP=KTE
+          PTOP=PBOT
+          GO TO 800
+        ENDIF
+
+!
+        THVREF(L)=TREFK(L)*APEK(L)*(QRFKL*D608+1.)
+        QREFK(L)=QRFKL
+      ENDDO
+!
+!------------------ ELIMINATE CLOUDS WITH BOTTOMS TOO DRY --------------
+!!
+!      qnew=(qrefk(lbot)-qk(lbot))*tauksc+qk(lbot)
+!!
+!      if(qnew<qk(lbot+1)*stresh)then  !!?? stresh too large!!
+!        lbot=0
+!!!!!!   ltop=lbot
+!        ltop=kte
+!        ptop=pbot
+!        go to 800
+!      endif
+!!
+!-------------- ELIMINATE IMPOSSIBLE SLOPES (BETTS,DTHETA/DQ)------------
+!
+      DO L=LTOP,LBOT
+        DTDP=(THVREF(L-1)-THVREF(L))/(PRSMID(L)-PRSMID(L-1))
+!
+        IF(DTDP<EPSDT)THEN
+          LBOT=0
+!!!!!     LTOP=LBOT
+          LTOP=KTE
+          PTOP=PBOT
+          GO TO 800
+        ENDIF
+!
+      ENDDO
+!-----------------------------------------------------------------------
+!--------------RELAXATION TOWARD REFERENCE PROFILES---------------------
+!-----------------------------------------------------------------------
+!
+      DO L=LTOP,LBOT
+        DTDT(L)=(TREFK(L)-TK(L))*TAUKSC*RDTCNVC
+        DQDT(L)=(QREFK(L)-QK(L))*TAUKSC*RDTCNVC
+      ENDDO
+!
+!-----------------------------------------------------------------------
+!***  Begin debugging convection
+      IF(PRINT_DIAG)THEN
+        DO L=LBOT,LTOP,-1
+          WRITE(6,"(a,i3,4e12.4)") '{cu2 KFLIP,DT,DTDT,DQ,DQDT = ' &
+               ,KTE+1-L,TREFK(L)-TK(L),DTDT(L),QREFK(L)-QK(L),DQDT(L)
+        ENDDO
+      ENDIF
+!***  End debugging convection
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!SCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCS
+!SCSCSCSCSCSCSC         END OF SHALLOW CONVECTION        SCSCSCSCSCSCSCS
+!SCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCSCS
+!-----------------------------------------------------------------------
+  800 CONTINUE
+!-----------------------------------------------------------------------
+      END SUBROUTINE BMJ
+!-----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!-----------------------------------------------------------------------
+                           SUBROUTINE TTBLEX                            &
+     & (ITBX,JTBX,PLX,PRSMID,RDPX,RDTHEX,STHE                           &
+     & ,THE0,THESP,TTBL,TREF)
+!-----------------------------------------------------------------------
+!     ******************************************************************
+!     *                                                                *
+!     *           EXTRACT TEMPERATURE OF THE MOIST ADIABAT FROM        *
+!     *                      THE APPROPRIATE TTBL                      *
+!     *                                                                *
+!     ******************************************************************
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: ITBX,JTBX
+!
+      REAL,INTENT(IN) :: PLX,PRSMID,RDPX,RDTHEX,THESP
+!
+      REAL,DIMENSION(ITBX),INTENT(IN) :: STHE,THE0
+!
+      REAL,DIMENSION(JTBX,ITBX),INTENT(IN) :: TTBL
+!
+      REAL,INTENT(OUT) :: TREF
+!-----------------------------------------------------------------------
+      REAL :: BTHE00K,BTHE10K,BTHK,PK,PP,QQ,STHE00K,STHE10K,STHK        &
+     &       ,T00K,T01K,T10K,T11K,TPK,TTHK
+!
+      INTEGER :: IPTB,ITHTB
+!-----------------------------------------------------------------------
+!----------------SCALING PRESSURE & TT TABLE INDEX----------------------
+!-----------------------------------------------------------------------
+      PK=PRSMID
+      TPK=(PK-PLX)*RDPX
+      QQ=TPK-AINT(TPK)
+      IPTB=INT(TPK)+1
+!----------------KEEPING INDICES WITHIN THE TABLE-----------------------
+      IF(IPTB<1)THEN
+        IPTB=1
+        QQ=0.
+      ENDIF
+!
+      IF(IPTB>=ITBX)THEN
+        IPTB=ITBX-1
+        QQ=0.
+      ENDIF
+!----------------BASE AND SCALING FACTOR FOR THETAE---------------------
+      BTHE00K=THE0(IPTB)
+      STHE00K=STHE(IPTB)
+      BTHE10K=THE0(IPTB+1)
+      STHE10K=STHE(IPTB+1)
+!----------------SCALING THE & TT TABLE INDEX---------------------------
+      BTHK=(BTHE10K-BTHE00K)*QQ+BTHE00K
+      STHK=(STHE10K-STHE00K)*QQ+STHE00K
+      TTHK=(THESP-BTHK)/STHK*RDTHEX
+      PP=TTHK-AINT(TTHK)
+      ITHTB=INT(TTHK)+1
+!----------------KEEPING INDICES WITHIN THE TABLE-----------------------
+      IF(ITHTB<1)THEN
+        ITHTB=1
+        PP=0.
+      ENDIF
+!
+      IF(ITHTB>=JTBX)THEN
+        ITHTB=JTBX-1
+        PP=0.
+      ENDIF
+!----------------TEMPERATURE AT FOUR SURROUNDING TT TABLE PTS.----------
+      T00K=TTBL(ITHTB,IPTB)
+      T10K=TTBL(ITHTB+1,IPTB)
+      T01K=TTBL(ITHTB,IPTB+1)
+      T11K=TTBL(ITHTB+1,IPTB+1)
+!-----------------------------------------------------------------------
+!----------------PARCEL TEMPERATURE-------------------------------------
+!-----------------------------------------------------------------------
+      TREF=(T00K+(T10K-T00K)*PP+(T01K-T00K)*QQ                          &
+     &    +(T00K-T10K-T01K+T11K)*PP*QQ)
+!-----------------------------------------------------------------------
+      END SUBROUTINE TTBLEX
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+      SUBROUTINE BMJINIT(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN            &
+     &                  ,CLDEFI,LOWLYR,CP,RD,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
+!
+      REAL,INTENT(IN) :: CP,RD
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) ::            &
+     &                                              RTHCUTEN            &
+     &                                             ,RQVCUTEN            &
+     &                                             ,RQCCUTEN            &
+     &                                             ,RQRCUTEN
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CLDEFI
+
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: LOWLYR
+!
+      REAL,PARAMETER :: EPS=1.E-9
+!
+      REAL, DIMENSION(JTB) :: APP,APT,AQP,AQT,PNEW,POLD,QSNEW,QSOLD     &
+     &                       ,THENEW,THEOLD,TNEW,TOLD,Y2P,Y2T
+!
+      REAL,DIMENSION(JTBQ) :: APTQ,AQTQ,THENEWQ,THEOLDQ                 &
+     &                       ,TNEWQ,TOLDQ,Y2TQ
+!
+      INTEGER :: I,J,K,ITF,JTF,KTF
+      INTEGER :: KTH,KTHM,KTHM1,KP,KPM,KPM1
+!
+      REAL :: APE,DP,DQS,DTH,DTHE,P,QS,QS0K,SQSK,STHEK                  &
+     &       ,TH,THE0K,DENOM,ELOCP
+!-----------------------------------------------------------------------
+
+      ELOCP=ELIWV/CP
+      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
+!
+        DO J=JTS,JTF
+        DO I=ITS,ITF
+          CLDEFI(I,J)=AVGEFI
+        ENDDO
+        ENDDO
+      ENDIF
+!
+!***  FOR NOW, ASSUME SIGMA MODE FOR LOWEST MODEL LAYER
+!
+      DO J=JTS,JTF
+      DO I=ITS,ITF
+        LOWLYR(I,J)=1
+      ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!----------------COARSE LOOK-UP TABLE FOR SATURATION POINT--------------
+!-----------------------------------------------------------------------
+!
+      KTHM=JTB
+      KPM=ITB
+      KTHM1=KTHM-1
+      KPM1=KPM-1
+!
+      DTH=(THH-THL)/REAL(KTHM-1)
+      DP =(PH -PL )/REAL(KPM -1)
+!
+      TH=THL-DTH
+!-----------------------------------------------------------------------
+      DO 100 KTH=1,KTHM
+!
+      TH=TH+DTH
+      P=PL-DP
+!
+      DO KP=1,KPM
+        P=P+DP
+        APE=(100000./P)**(RD/CP)
+        DENOM=TH-A4*APE
+        IF (DENOM>EPS) THEN
+           QSOLD(KP)=PQ0/P*EXP(A2*(TH-A3*APE)/DENOM)
+        ELSE
+           QSOLD(KP)=0.
+        ENDIF
+        POLD(KP)=P
+      ENDDO
+!
+      QS0K=QSOLD(1)
+      SQSK=QSOLD(KPM)-QSOLD(1)
+      QSOLD(1  )=0.
+      QSOLD(KPM)=1.
+!
+      DO KP=2,KPM1
+        QSOLD(KP)=(QSOLD(KP)-QS0K)/SQSK
+        IF((QSOLD(KP)-QSOLD(KP-1)).LT.EPS)QSOLD(KP)=QSOLD(KP-1)+EPS
+      ENDDO
+!
+      QS0(KTH)=QS0K
+      QS0_EXP(KTH)=QS0K
+      SQS(KTH)=SQSK
+      SQS_EXP(KTH)=SQSK
+!-----------------------------------------------------------------------
+      QSNEW(1  )=0.
+      QSNEW(KPM)=1.
+      DQS=1./REAL(KPM-1)
+!
+      DO KP=2,KPM1
+        QSNEW(KP)=QSNEW(KP-1)+DQS
+      ENDDO
+!
+      Y2P(1   )=0.
+      Y2P(KPM )=0.
+!
+      CALL SPLINE(JTB,KPM,QSOLD,POLD,Y2P,KPM,QSNEW,PNEW,APP,AQP)
+!
+      DO KP=1,KPM
+        PTBL(KP,KTH)=PNEW(KP)
+        PTBL_EXP(KP,KTH)=PNEW(KP)
+      ENDDO
+!-----------------------------------------------------------------------
+  100 CONTINUE
+!-----------------------------------------------------------------------
+!------------COARSE LOOK-UP TABLE FOR T(P) FROM CONSTANT THE------------
+!-----------------------------------------------------------------------
+      P=PL-DP
+!
+      DO 200 KP=1,KPM
+!
+      P=P+DP
+      TH=THL-DTH
+!
+      DO KTH=1,KTHM
+        TH=TH+DTH
+        APE=(1.E5/P)**(RD/CP)
+        DENOM=TH-A4*APE
+        IF (DENOM>EPS) THEN
+           QS=PQ0/P*EXP(A2*(TH-A3*APE)/DENOM)
+        ELSE
+           QS=0.
+        ENDIF
+!        QS=PQ0/P*EXP(A2*(TH-A3*APE)/(TH-A4*APE))
+        TOLD(KTH)=TH/APE
+        THEOLD(KTH)=TH*EXP(ELOCP*QS/TOLD(KTH))
+      ENDDO
+!
+      THE0K=THEOLD(1)
+      STHEK=THEOLD(KTHM)-THEOLD(1)
+      THEOLD(1   )=0.
+      THEOLD(KTHM)=1.
+!
+      DO KTH=2,KTHM1
+        THEOLD(KTH)=(THEOLD(KTH)-THE0K)/STHEK
+        IF((THEOLD(KTH)-THEOLD(KTH-1)).LT.EPS)                          &
+     &      THEOLD(KTH)=THEOLD(KTH-1)  +  EPS
+      ENDDO
+!
+      THE0(KP)=THE0K
+      STHE(KP)=STHEK
+!-----------------------------------------------------------------------
+      THENEW(1  )=0.
+      THENEW(KTHM)=1.
+      DTHE=1./REAL(KTHM-1)
+!
+      DO KTH=2,KTHM1
+        THENEW(KTH)=THENEW(KTH-1)+DTHE
+      ENDDO
+!
+      Y2T(1   )=0.
+      Y2T(KTHM)=0.
+!
+      CALL SPLINE(JTB,KTHM,THEOLD,TOLD,Y2T,KTHM,THENEW,TNEW,APT,AQT)
+!
+      DO KTH=1,KTHM
+        TTBL(KTH,KP)=TNEW(KTH)
+      ENDDO
+!-----------------------------------------------------------------------
+  200 CONTINUE
+!-----------------------------------------------------------------------
+!
+!-----------------------------------------------------------------------
+!---------------FINE LOOK-UP TABLE FOR SATURATION POINT-----------------
+!-----------------------------------------------------------------------
+      KTHM=JTBQ
+      KPM=ITBQ
+      KTHM1=KTHM-1
+      KPM1=KPM-1
+!
+      DTH=(THHQ-THL)/REAL(KTHM-1)
+      DP=(PH-PLQ)/REAL(KPM-1)
+!
+      TH=THL-DTH
+      P=PLQ-DP
+!-----------------------------------------------------------------------
+!---------------FINE LOOK-UP TABLE FOR T(P) FROM CONSTANT THE-----------
+!-----------------------------------------------------------------------
+      DO 300 KP=1,KPM
+!
+      P=P+DP
+      TH=THL-DTH
+!
+      DO KTH=1,KTHM
+        TH=TH+DTH
+        APE=(1.E5/P)**(RD/CP)
+        DENOM=TH-A4*APE
+        IF (DENOM>EPS) THEN
+           QS=PQ0/P*EXP(A2*(TH-A3*APE)/DENOM)
+        ELSE
+           QS=0.
+        ENDIF
+!        QS=PQ0/P*EXP(A2*(TH-A3*APE)/(TH-A4*APE))
+        TOLDQ(KTH)=TH/APE
+        THEOLDQ(KTH)=TH*EXP(ELOCP*QS/TOLDQ(KTH))
+      ENDDO
+!
+      THE0K=THEOLDQ(1)
+      STHEK=THEOLDQ(KTHM)-THEOLDQ(1)
+      THEOLDQ(1   )=0.
+      THEOLDQ(KTHM)=1.
+!
+      DO KTH=2,KTHM1
+        THEOLDQ(KTH)=(THEOLDQ(KTH)-THE0K)/STHEK
+        IF((THEOLDQ(KTH)-THEOLDQ(KTH-1))<EPS)                           &
+     &      THEOLDQ(KTH)=THEOLDQ(KTH-1)+EPS
+      ENDDO
+!
+      THE0Q(KP)=THE0K
+      STHEQ(KP)=STHEK
+!-----------------------------------------------------------------------
+      THENEWQ(1  )=0.
+      THENEWQ(KTHM)=1.
+      DTHE=1./REAL(KTHM-1)
+!
+      DO KTH=2,KTHM1
+        THENEWQ(KTH)=THENEWQ(KTH-1)+DTHE
+      ENDDO
+!
+      Y2TQ(1   )=0.
+      Y2TQ(KTHM)=0.
+!
+      CALL SPLINE(JTBQ,KTHM,THEOLDQ,TOLDQ,Y2TQ,KTHM                     &
+     &           ,THENEWQ,TNEWQ,APTQ,AQTQ)
+!
+      DO KTH=1,KTHM
+        TTBLQ(KTH,KP)=TNEWQ(KTH)
+      ENDDO
+!-----------------------------------------------------------------------
+  300 CONTINUE
+!-----------------------------------------------------------------------
+      END SUBROUTINE BMJINIT
+!-----------------------------------------------------------------------
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!-----------------------------------------------------------------------
+      SUBROUTINE SPLINE(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) :: 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 :: K,K1,K2,KOLD,NOLDM1
+      REAL :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR                   &
+     &       ,RDX,RTDXC,X,XK,XSQ,Y2K,Y2KP1
+!-----------------------------------------------------------------------
+      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==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<NOLD)GO TO 100
+!-----------------------------------------------------------------------
+  150 K=NOLDM1
+!
+  200 Y2(K)=P(K-1)+Q(K-1)*Y2(K+1)
+!
+      K=K-1
+      IF(K>1)GO TO 200
+!-----------------------------------------------------------------------
+      K1=1
+!
+  300 XK=XNEW(K1)
+!
+      DO 400 K2=2,NOLD
+!
+      IF(XOLD(K2)>XK)THEN
+        KOLD=K2-1
+        GO TO 450
+      ENDIF
+!
+  400 CONTINUE
+!
+      YNEW(K1)=YOLD(NOLD)
+      GO TO 600
+!
+  450 IF(K1==1)GO TO 500
+      IF(K==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)
+!
+  600 K1=K1+1
+      IF(K1<=NNEW)GO TO 300
+!-----------------------------------------------------------------------
+      END SUBROUTINE SPLINE
+!-----------------------------------------------------------------------
+!
+      END MODULE MODULE_CU_BMJ
+!
+!-----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_camuwshcu.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_camuwshcu.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_camuwshcu.F	(revision 17)
@@ -0,0 +1,5387 @@
+#define WRF_PORT
+
+!------------------------------------------------------------------------
+! Based on uwshcu.F90 from CAM
+! Ported to WRF by William.Gustafson@pnl.gov, Jan. 2010
+!------------------------------------------------------------------------
+
+  module uwshcu
+
+#ifndef WRF_PORT
+  use cam_history,    only: outfld, addfld, phys_decomp
+  use cam_logfile,    only: iulog
+  use ppgrid,         only: pcols, pver, pverp
+  use abortutils,     only: endrun
+#else
+  use module_state_description, only: CAMUWPBLSCHEME, MYJPBLSCHEME
+  use module_cam_support, only: outfld, addfld, phys_decomp, iulog, pcols, pver, pverp, endrun
+  use module_bl_camuwpbl_driver, only: vd_register
+#endif
+  use error_function, only: erfc
+
+  implicit none
+  private
+  save
+
+  public init_uwshcu
+  public compute_uwshcu
+  public compute_uwshcu_inv
+  
+  integer , parameter :: r8 = selected_real_kind(12)    !  8 byte real
+  real(r8)            :: xlv                            !  Latent heat of vaporization
+  real(r8)            :: xlf                            !  Latent heat of fusion
+  real(r8)            :: xls                            !  Latent heat of sublimation = xlv + xlf
+  real(r8)            :: cp                             !  Specific heat of dry air
+  real(r8)            :: zvir                           !  rh2o/rair - 1
+  real(r8)            :: r                              !  Gas constant for dry air
+  real(r8)            :: g                              !  Gravitational constant
+  real(r8)            :: ep2                            !  mol wgt water vapor / mol wgt dry air 
+  real(r8)            :: p00                            !  Reference pressure for exner function
+  real(r8)            :: rovcp                          !  R/cp
+
+  contains
+  
+  real(r8) function exnf(pressure)
+           real(r8), intent(in)              :: pressure
+           exnf = (pressure/p00)**rovcp
+           return
+  end function exnf
+
+  subroutine init_uwshcu(                                        &
+       kind, xlv_in, cp_in, xlf_in, zvir_in, r_in, g_in, ep2_in  &
+#ifdef WRF_PORT
+       , rushten, rvshten, rthshten, rqvshten,                   &
+       rqcshten, rqrshten, rqishten, rqsshten, rqgshten,         &
+       p_qc, p_qr, p_qi, p_qs, p_qg,                             &
+       bl_pbl_physics, param_first_scalar, restart,              &
+       grid_id,                                                  &
+       ids, ide, jds, jde, kds, kde,                             &
+       ims, ime, jms, jme, kms, kme,                             &
+       its, ite, jts, jte, kts, kte                              )
+#else
+                                                                 )
+#endif
+!~add in zeroing of things like rliq that may come from ZM or may not
+
+    !------------------------------------------------------------- ! 
+    ! Purpose:                                                     !
+    ! Initialize key constants for the shallow convection package. !
+    !------------------------------------------------------------- !
+
+#ifndef WRF_PORT
+    use cam_history,   only: outfld, addfld, phys_decomp
+    use ppgrid,        only: pcols, pver, pverp
+#else
+    use module_cam_esinti,  only: esinti
+    use module_cam_support, only: outfld, addfld, phys_decomp, pcols, pver, pverp
+    use physconst, only: epsilo, latvap, latice, rh2o, cpair, tmelt
+#endif
+    implicit none
+    integer , intent(in) :: kind       !  kind of reals being passed in
+    real(r8), intent(in) :: xlv_in     !  Latent heat of vaporization
+    real(r8), intent(in) :: xlf_in     !  Latent heat of fusion
+    real(r8), intent(in) :: cp_in      !  Specific heat of dry air
+    real(r8), intent(in) :: zvir_in    !  rh2o/rair - 1
+    real(r8), intent(in) :: r_in       !  Gas constant for dry air
+    real(r8), intent(in) :: g_in       !  Gravitational constant
+    real(r8), intent(in) :: ep2_in     !  mol wgt water vapor / mol wgt dry air 
+
+#ifdef WRF_PORT
+    LOGICAL , INTENT(IN)           ::   restart
+    INTEGER , INTENT(IN)           ::   grid_id
+    INTEGER , INTENT(IN)           ::   ids, ide, jds, jde, kds, kde, &
+                                        ims, ime, jms, jme, kms, kme, &
+                                        its, ite, jts, jte, kts, kte, &
+                                        p_qc, p_qr, p_qi, p_qs, p_qg, &
+                                        param_first_scalar,           &
+                                        bl_pbl_physics
+
+    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(OUT) :: &
+                                                             rushten, &
+                                                             rvshten, &
+                                                            rthshten, &
+                                                            rqvshten, &
+                                                            rqcshten, &
+                                                            rqrshten, &
+                                                            rqishten, &
+                                                            rqsshten, &
+                                                            rqgshten
+
+  integer :: i, itf, j, jtf, k, ktf
+
+  jtf = min(jte,jde-1)
+  ktf = min(kte,kde-1)
+  itf = min(ite,ide-1)
+!
+! The CAM UW shallow Cu scheme only works with PBL schemes that generate
+! TKE. So, for example, YSU would be an invalid choice to combine with
+! the UW scheme. For now, we are coupling into the tke_pbl version of
+! TKE used by MYJ, CAMUWPBL and others. At some point, it would be great to unify
+! all the different TKEs output so that things work together properly.
+! QKE from MYNN remains separate
+!
+  select case(bl_pbl_physics)
+  case (CAMUWPBLSCHEME, MYJPBLSCHEME)
+     !These are acceptable PBL schemes.
+  case default
+     call wrf_error_fatal("The CAMUWSHCU scheme requires either CAMUWPBLSCHEME or MYJPBLSCHEME.")
+  end select
+!
+! Initialize module_cam_support variables...
+! This could be moved to a master "cam-init" subroutine once multiple CAM
+! parameterizations are implemented in WRF. For now, it doesn't hurt to
+! have these possibly initialized more than once since they are
+! essentially constant.
+!
+  pver  = ktf-kts+1
+  pverp = pver+1
+!
+! Initialize the saturation vapor pressure look-up table...
+! This could be moved to a master cam-init subroutine too if it is needed
+! by more than one CAM parameterization. In CAM this is called from
+! phys_init.
+!
+  call esinti(epsilo, latvap, latice, rh2o, cpair, tmelt)
+!
+!~If the PBL scheme is not UW PBL, then we need to initialize the CAM
+! consituents array. Eventually, this should really be done once for
+! all the CAM routines through a call from phys_init, or equiv. location.
+! This would avoid mistakes from multiple initiations.
+!
+  if( bl_pbl_physics /= CAMUWPBLSCHEME ) then
+     if(grid_id.eq.1)call vd_register
+  end if
+#endif
+
+    ! ------------------------- !
+    ! Internal Output Variables !
+    ! ------------------------- !
+
+    call addfld( 'qtflx_Cu'       , 'kg/m2/s' , pverp , 'A' , 'Convective qt flux'                                  , phys_decomp )
+    call addfld( 'slflx_Cu'       , 'J/m2/s'  , pverp , 'A' , 'Convective sl flux'                                  , phys_decomp )
+    call addfld( 'uflx_Cu'        , 'kg/m/s2' , pverp , 'A' , 'Convective  u flux'                                  , phys_decomp )
+    call addfld( 'vflx_Cu'        , 'kg/m/s2' , pverp , 'A' , 'Convective  v flux'                                  , phys_decomp )
+
+    call addfld( 'qtten_Cu'       , 'kg/kg/s' , pver  , 'A' , 'qt tendency by convection'                           , phys_decomp )
+    call addfld( 'slten_Cu'       , 'J/kg/s'  , pver  , 'A' , 'sl tendency by convection'                           , phys_decomp )
+    call addfld( 'uten_Cu'        , 'm/s2'    , pver  , 'A' , ' u tendency by convection'                           , phys_decomp )
+    call addfld( 'vten_Cu'        , 'm/s2'    , pver  , 'A' , ' v tendency by convection'                           , phys_decomp )
+    call addfld( 'qvten_Cu'       , 'kg/kg/s' , pver  , 'A' , 'qv tendency by convection'                           , phys_decomp )
+    call addfld( 'qlten_Cu'       , 'kg/kg/s' , pver  , 'A' , 'ql tendency by convection'                           , phys_decomp )
+    call addfld( 'qiten_Cu'       , 'kg/kg/s' , pver  , 'A' , 'qi tendency by convection'                           , phys_decomp )
+
+    call addfld( 'cbmf_Cu'        , 'kg/m2/s' , 1     , 'A' , 'Cumulus base mass flux'                              , phys_decomp )
+    call addfld( 'ufrcinvbase_Cu' , 'fraction', 1     , 'A' , 'Cumulus fraction at PBL top'                         , phys_decomp ) 
+    call addfld( 'ufrclcl_Cu'     , 'fraction', 1     , 'A' , 'Cumulus fraction at LCL'                             , phys_decomp )
+    call addfld( 'winvbase_Cu'    , 'm/s'     , 1     , 'A' , 'Cumulus vertical velocity at PBL top'                , phys_decomp )
+    call addfld( 'wlcl_Cu'        , 'm/s'     , 1     , 'A' , 'Cumulus vertical velocity at LCL'                    , phys_decomp )
+    call addfld( 'plcl_Cu'        , 'Pa'      , 1     , 'A' , 'LCL of source air'                                   , phys_decomp )
+    call addfld( 'pinv_Cu'        , 'Pa'      , 1     , 'A' , 'PBL top pressure'                                    , phys_decomp )
+    call addfld( 'plfc_Cu'        , 'Pa'      , 1     , 'A' , 'LFC of source air'                                   , phys_decomp )
+    call addfld( 'pbup_Cu'        , 'Pa'      , 1     , 'A' , 'Highest interface level of positive cumulus buoyancy', phys_decomp )
+    call addfld( 'ppen_Cu'        , 'Pa'      , 1     , 'A' , 'Highest level where cumulus w is 0'                  , phys_decomp )
+    call addfld( 'qtsrc_Cu'       , 'kg/kg'   , 1     , 'A' , 'Cumulus source air qt'                               , phys_decomp )
+    call addfld( 'thlsrc_Cu'      , 'K'       , 1     , 'A' , 'Cumulus source air thl'                              , phys_decomp )
+    call addfld( 'thvlsrc_Cu'     , 'K'       , 1     , 'A' , 'Cumulus source air thvl'                             , phys_decomp )
+    call addfld( 'emfkbup_Cu'     , 'kg/m2/s' , 1     , 'A' , 'Penetrative mass flux at kbup'                       , phys_decomp )
+    call addfld( 'cin_Cu'         , 'J/kg'    , 1     , 'A' , 'CIN upto LFC'                                        , phys_decomp )
+    call addfld( 'cinlcl_Cu'      , 'J/kg'    , 1     , 'A' , 'CIN upto LCL'                                        , phys_decomp )
+    call addfld( 'cbmflimit_Cu'   , 'kg/m2/s' , 1     , 'A' , 'cbmflimiter'                                         , phys_decomp ) 
+    call addfld( 'tkeavg_Cu'      , 'm2/s2'   , 1     , 'A' , 'Average tke within PBL for convection scheme'        , phys_decomp ) 
+    call addfld( 'zinv_Cu'        , 'm'       , 1     , 'A' , 'PBL top height'                                      , phys_decomp )
+    call addfld( 'rcwp_Cu'        , 'kg/m2'   , 1     , 'A' , 'Cumulus LWP+IWP'                                     , phys_decomp )
+    call addfld( 'rlwp_Cu'        , 'kg/m2'   , 1     , 'A' , 'Cumulus LWP'                                         , phys_decomp )
+    call addfld( 'riwp_Cu'        , 'kg/m2'   , 1     , 'A' , 'Cumulus IWP'                                         , phys_decomp )
+    call addfld( 'tophgt_Cu'      , 'm'       , 1     , 'A' , 'Cumulus top height'                                  , phys_decomp )
+
+    call addfld( 'wu_Cu'          , 'm/s'     , pverp , 'A' , 'Convective updraft vertical velocity'                , phys_decomp )
+    call addfld( 'ufrc_Cu'        , 'fraction', pverp , 'A' , 'Convective updraft fractional area'                  , phys_decomp )
+    call addfld( 'qtu_Cu'         , 'kg/kg'   , pverp , 'A' , 'Cumulus updraft qt'                                  , phys_decomp )
+    call addfld( 'thlu_Cu'        , 'K'       , pverp , 'A' , 'Cumulus updraft thl'                                 , phys_decomp )
+    call addfld( 'thvu_Cu'        , 'K'       , pverp , 'A' , 'Cumulus updraft thv'                                 , phys_decomp )
+    call addfld( 'uu_Cu'          , 'm/s'     , pverp , 'A' , 'Cumulus updraft uwnd'                                , phys_decomp )
+    call addfld( 'vu_Cu'          , 'm/s'     , pverp , 'A' , 'Cumulus updraft vwnd'                                , phys_decomp )
+    call addfld( 'qtu_emf_Cu'     , 'kg/kg'   , pverp , 'A' , 'qt of penatratively entrained air'                   , phys_decomp )
+    call addfld( 'thlu_emf_Cu'    , 'K'       , pverp , 'A' , 'thl of penatratively entrained air'                  , phys_decomp )
+    call addfld( 'uu_emf_Cu'      , 'm/s'     , pverp , 'A' , 'uwnd of penatratively entrained air'                 , phys_decomp )
+    call addfld( 'vu_emf_Cu'      , 'm/s'     , pverp , 'A' , 'vwnd of penatratively entrained air'                 , phys_decomp )
+    call addfld( 'umf_Cu'         , 'kg/m2/s' , pverp , 'A' , 'Cumulus updraft mass flux'                           , phys_decomp )
+    call addfld( 'uemf_Cu'        , 'kg/m2/s' , pverp , 'A' , 'Cumulus net ( updraft + entrainment ) mass flux'     , phys_decomp )
+    call addfld( 'qcu_Cu'         , 'kg/kg'   , pver  , 'A' , 'Cumulus updraft LWC+IWC'                             , phys_decomp )
+    call addfld( 'qlu_Cu'         , 'kg/kg'   , pver  , 'A' , 'Cumulus updraft LWC'                                 , phys_decomp )
+    call addfld( 'qiu_Cu'         , 'kg/kg'   , pver  , 'A' , 'Cumulus updraft IWC'                                 , phys_decomp )
+    call addfld( 'cufrc_Cu'       , 'fraction', pver  , 'A' , 'Cumulus cloud fraction'                              , phys_decomp )
+    call addfld( 'fer_Cu'         , '1/m'     , pver  , 'A' , 'Cumulus lateral fractional entrainment rate'         , phys_decomp )
+    call addfld( 'fdr_Cu'         , '1/m'     , pver  , 'A' , 'Cumulus lateral fractional detrainment Rate'         , phys_decomp )
+
+    call addfld( 'dwten_Cu'       , 'kg/kg/s' , pver  , 'A' , 'Expellsion rate of cumulus cloud water to env.'      , phys_decomp )
+    call addfld( 'diten_Cu'       , 'kg/kg/s' , pver  , 'A' , 'Expellsion rate of cumulus ice water to env.'        , phys_decomp )
+    call addfld( 'qrten_Cu'       , 'kg/kg/s' , pver  , 'A' , 'Production rate of rain by cumulus'                  , phys_decomp )
+    call addfld( 'qsten_Cu'       , 'kg/kg/s' , pver  , 'A' , 'Production rate of snow by cumulus'                  , phys_decomp )
+    call addfld( 'flxrain_Cu'     , 'kg/m2/s' , pverp , 'A' , 'Rain flux induced by Cumulus'                        , phys_decomp )
+    call addfld( 'flxsnow_Cu'     , 'kg/m2/s' , pverp , 'A' , 'Snow flux induced by Cumulus'                        , phys_decomp )
+    call addfld( 'ntraprd_Cu'     , 'kg/kg/s' , pver  , 'A' , 'Net production rate of rain by Cumulus'              , phys_decomp )
+    call addfld( 'ntsnprd_Cu'     , 'kg/kg/s' , pver  , 'A' , 'Net production rate of snow by Cumulus'              , phys_decomp )
+
+    call addfld( 'excessu_Cu'     , 'no'      , pver  , 'A' , 'Updraft saturation excess'                           , phys_decomp )
+    call addfld( 'excess0_Cu'     , 'no'      , pver  , 'A' , 'Environmental saturation excess'                     , phys_decomp )
+    call addfld( 'xc_Cu'          , 'no'      , pver  , 'A' , 'Critical mixing ratio'                               , phys_decomp )
+    call addfld( 'aquad_Cu'       , 'no'      , pver  , 'A' , 'aquad'                                               , phys_decomp )
+    call addfld( 'bquad_Cu'       , 'no'      , pver  , 'A' , 'bquad'                                               , phys_decomp )
+    call addfld( 'cquad_Cu'       , 'no'      , pver  , 'A' , 'cquad'                                               , phys_decomp )
+    call addfld( 'bogbot_Cu'      , 'no'      , pver  , 'A' , 'Cloud buoyancy at the bottom interface'              , phys_decomp )
+    call addfld( 'bogtop_Cu'      , 'no'      , pver  , 'A' , 'Cloud buoyancy at the top interface'                 , phys_decomp )
+
+    call addfld('exit_UWCu_Cu'    , 'no'      , 1     , 'A' , 'exit_UWCu'                                           , phys_decomp ) 
+    call addfld('exit_conden_Cu'  , 'no'      , 1     , 'A' , 'exit_conden'                                         , phys_decomp ) 
+    call addfld('exit_klclmkx_Cu' , 'no'      , 1     , 'A' , 'exit_klclmkx'                                        , phys_decomp ) 
+    call addfld('exit_klfcmkx_Cu' , 'no'      , 1     , 'A' , 'exit_klfcmkx'                                        , phys_decomp ) 
+    call addfld('exit_ufrc_Cu'    , 'no'      , 1     , 'A' , 'exit_ufrc'                                           , phys_decomp ) 
+    call addfld('exit_wtw_Cu'     , 'no'      , 1     , 'A' , 'exit_wtw'                                            , phys_decomp ) 
+    call addfld('exit_drycore_Cu' , 'no'      , 1     , 'A' , 'exit_drycore'                                        , phys_decomp ) 
+    call addfld('exit_wu_Cu'      , 'no'      , 1     , 'A' , 'exit_wu'                                             , phys_decomp ) 
+    call addfld('exit_cufilter_Cu', 'no'      , 1     , 'A' , 'exit_cufilter'                                       , phys_decomp ) 
+    call addfld('exit_kinv1_Cu'   , 'no'      , 1     , 'A' , 'exit_kinv1'                                          , phys_decomp ) 
+    call addfld('exit_rei_Cu'     , 'no'      , 1     , 'A' , 'exit_rei'                                            , phys_decomp ) 
+
+    call addfld('limit_shcu_Cu'   , 'no'      , 1     , 'A' , 'limit_shcu'                                          , phys_decomp ) 
+    call addfld('limit_negcon_Cu' , 'no'      , 1     , 'A' , 'limit_negcon'                                        , phys_decomp ) 
+    call addfld('limit_ufrc_Cu'   , 'no'      , 1     , 'A' , 'limit_ufrc'                                          , phys_decomp ) 
+    call addfld('limit_ppen_Cu'   , 'no'      , 1     , 'A' , 'limit_ppen'                                          , phys_decomp ) 
+    call addfld('limit_emf_Cu'    , 'no'      , 1     , 'A' , 'limit_emf'                                           , phys_decomp ) 
+    call addfld('limit_cinlcl_Cu' , 'no'      , 1     , 'A' , 'limit_cinlcl'                                        , phys_decomp ) 
+    call addfld('limit_cin_Cu'    , 'no'      , 1     , 'A' , 'limit_cin'                                           , phys_decomp ) 
+    call addfld('limit_cbmf_Cu'   , 'no'      , 1     , 'A' , 'limit_cbmf'                                          , phys_decomp ) 
+    call addfld('limit_rei_Cu'    , 'no'      , 1     , 'A' , 'limit_rei'                                           , phys_decomp ) 
+    call addfld('ind_delcin_Cu'   , 'no'      , 1     , 'A' , 'ind_delcin'                                          , phys_decomp ) 
+
+    if( kind .ne. r8 ) then
+        write(iulog,*) 'wrong KIND of reals passed to init_uwshcu -- exiting.'
+        call endrun
+    endif
+    xlv   = xlv_in
+    xlf   = xlf_in
+    xls   = xlv + xlf
+    cp    = cp_in
+    zvir  = zvir_in
+    r     = r_in
+    g     = g_in
+    ep2   = ep2_in
+    p00   = 1.e5_r8
+    rovcp = r/cp
+
+#ifdef WRF_PORT
+!
+! Set initial values for WRF arrays dependent on restart conditions
+!
+  if(.not.restart)then
+     do j=jts,jtf
+        do k=kts,ktf
+           do i=its,itf
+              rushten(i,k,j)  = 0.
+              rvshten(i,k,j)  = 0.
+              rthshten(i,k,j) = 0.
+              rqvshten(i,k,j) = 0.
+              if( p_qc > param_first_scalar ) rqcshten(i,k,j) = 0.
+              if( p_qr > param_first_scalar ) rqrshten(i,k,j) = 0.
+              if( p_qi > param_first_scalar ) rqishten(i,k,j) = 0.
+              if( p_qs > param_first_scalar ) rqsshten(i,k,j) = 0.
+              if( p_qg > param_first_scalar ) rqgshten(i,k,j) = 0.
+           enddo
+        enddo
+     enddo
+  end if
+#endif
+
+  end subroutine init_uwshcu
+
+  subroutine compute_uwshcu_inv( mix      , mkx        , iend          , ncnst     , dt       ,  & 
+                                 ps0_inv  , zs0_inv    , p0_inv        , z0_inv    , dp0_inv  ,  &
+                                 u0_inv   , v0_inv     , qv0_inv       , ql0_inv   , qi0_inv  ,  &
+                                 t0_inv   , s0_inv     , tr0_inv       ,                         &
+                                 tke_inv  , cldfrct_inv, concldfrct_inv, pblh      , cush     ,  & 
+                                 umf_inv  , slflx_inv  , qtflx_inv     ,                         & 
+                                 qvten_inv, qlten_inv  , qiten_inv     ,                         &
+                                 sten_inv , uten_inv   , vten_inv      , trten_inv ,             &  
+                                 qrten_inv, qsten_inv  , precip        , snow      , evapc_inv,  &
+                                 cufrc_inv, qcu_inv    , qlu_inv       , qiu_inv   ,             &   
+                                 cbmf     , qc_inv     , rliq          ,                         &
+                                 cnt_inv  , cnb_inv    , qsat          , lchnk     , dpdry0_inv ) 
+
+    implicit none
+    integer , intent(in)    :: lchnk     
+    integer , intent(in)    :: mix
+    integer , intent(in)    :: mkx
+    integer , intent(in)    :: iend
+    integer , intent(in)    :: ncnst
+    real(r8), intent(in)    :: dt                       !  Time step : 2*delta_t [ s ]
+    real(r8), intent(in)    :: ps0_inv(mix,mkx+1)       !  Environmental pressure at the interfaces [ Pa ]
+    real(r8), intent(in)    :: zs0_inv(mix,mkx+1)       !  Environmental height at the interfaces   [ m ]
+    real(r8), intent(in)    :: p0_inv(mix,mkx)          !  Environmental pressure at the layer mid-point [ Pa ]
+    real(r8), intent(in)    :: z0_inv(mix,mkx)          !  Environmental height at the layer mid-point [ m ]
+    real(r8), intent(in)    :: dp0_inv(mix,mkx)         !  Environmental layer pressure thickness [ Pa ] > 0.
+    real(r8), intent(in)    :: dpdry0_inv(mix,mkx)      !  Environmental dry layer pressure thickness [ Pa ]
+    real(r8), intent(in)    :: u0_inv(mix,mkx)          !  Environmental zonal wind [ m/s ]
+    real(r8), intent(in)    :: v0_inv(mix,mkx)          !  Environmental meridional wind [ m/s ]
+    real(r8), intent(in)    :: qv0_inv(mix,mkx)         !  Environmental water vapor specific humidity [ kg/kg ]
+    real(r8), intent(in)    :: ql0_inv(mix,mkx)         !  Environmental liquid water specific humidity [ kg/kg ]
+    real(r8), intent(in)    :: qi0_inv(mix,mkx)         !  Environmental ice specific humidity [ kg/kg ]
+    real(r8), intent(in)    :: t0_inv(mix,mkx)          !  Environmental temperature [ K ]
+    real(r8), intent(in)    :: s0_inv(mix,mkx)          !  Environmental dry static energy [ J/kg ]
+    real(r8), intent(in)    :: tr0_inv(mix,mkx,ncnst)   !  Environmental tracers [ #, kg/kg ]
+    real(r8), intent(in)    :: tke_inv(mix,mkx+1)       !  Turbulent kinetic energy at the interfaces [ m2/s2 ]
+    real(r8), intent(in)    :: cldfrct_inv(mix,mkx)     !  Total cloud fraction at the previous time step [ fraction ]
+    real(r8), intent(in)    :: concldfrct_inv(mix,mkx)  !  Total convective ( shallow + deep ) cloud fraction at the previous time step [ fraction ]
+    real(r8), intent(in)    :: pblh(mix)                !  Height of PBL [ m ]
+    real(r8), intent(inout) :: cush(mix)                !  Convective scale height [ m ]
+    real(r8), intent(out)   :: umf_inv(mix,mkx+1)       !  Updraft mass flux at the interfaces [ kg/m2/s ]
+    real(r8), intent(out)   :: qvten_inv(mix,mkx)       !  Tendency of water vapor specific humidity [ kg/kg/s ]
+    real(r8), intent(out)   :: qlten_inv(mix,mkx)       !  Tendency of liquid water specific humidity [ kg/kg/s ]
+    real(r8), intent(out)   :: qiten_inv(mix,mkx)       !  Tendency of ice specific humidity [ kg/kg/s ]
+    real(r8), intent(out)   :: sten_inv(mix,mkx)        !  Tendency of dry static energy [ J/kg/s ]
+    real(r8), intent(out)   :: uten_inv(mix,mkx)        !  Tendency of zonal wind [ m/s2 ]
+    real(r8), intent(out)   :: vten_inv(mix,mkx)        !  Tendency of meridional wind [ m/s2 ]
+    real(r8), intent(out)   :: trten_inv(mix,mkx,ncnst) !  Tendency of tracers [ #/s, kg/kg/s ]
+    real(r8), intent(out)   :: qrten_inv(mix,mkx)       !  Tendency of rain water specific humidity [ kg/kg/s ]
+    real(r8), intent(out)   :: qsten_inv(mix,mkx)       !  Tendency of snow specific humidity [ kg/kg/s ]
+    real(r8), intent(out)   :: precip(mix)              !  Precipitation ( rain + snow ) flux at the surface [ m/s ]
+    real(r8), intent(out)   :: snow(mix)                !  Snow flux at the surface [ m/s ]
+    real(r8), intent(out)   :: evapc_inv(mix,mkx)       !  Evaporation of precipitation [ kg/kg/s ]
+    real(r8), intent(out)   :: rliq(mix)                !  Vertical integral of tendency of detrained cloud condensate qc [ m/s ]
+    real(r8), intent(out)   :: slflx_inv(mix,mkx+1)     !  Updraft liquid static energy flux [ J/kg * kg/m2/s ]
+    real(r8), intent(out)   :: qtflx_inv(mix,mkx+1)     !  Updraft total water flux [ kg/kg * kg/m2/s ]
+    real(r8), intent(out)   :: cufrc_inv(mix,mkx)       !  Shallow cumulus cloud fraction at the layer mid-point [ fraction ]
+    real(r8), intent(out)   :: qcu_inv(mix,mkx)         !  Liquid+ice specific humidity within cumulus updraft [ kg/kg ]
+    real(r8), intent(out)   :: qlu_inv(mix,mkx)         !  Liquid water specific humidity within cumulus updraft [ kg/kg ]
+    real(r8), intent(out)   :: qiu_inv(mix,mkx)         !  Ice specific humidity within cumulus updraft [ kg/kg ]
+    real(r8), intent(out)   :: qc_inv(mix,mkx)          !  Tendency of cumulus condensate detrained into the environment [ kg/kg/s ]
+    real(r8), intent(out)   :: cbmf(mix)                !  Cumulus base mass flux [ kg/m2/s ]
+    real(r8), intent(out)   :: cnt_inv(mix)             !  Cumulus top  interface index, cnt = kpen [ no ]
+    real(r8), intent(out)   :: cnb_inv(mix)             !  Cumulus base interface index, cnb = krel - 1 [ no ]
+    integer , external      :: qsat                     !  Function pointer to sat vap pressure function
+
+    real(r8)                :: ps0(mix,0:mkx)           !  Environmental pressure at the interfaces [ Pa ]
+    real(r8)                :: zs0(mix,0:mkx)           !  Environmental height at the interfaces   [ m ]
+    real(r8)                :: p0(mix,mkx)              !  Environmental pressure at the layer mid-point [ Pa ]
+    real(r8)                :: z0(mix,mkx)              !  Environmental height at the layer mid-point [ m ]
+    real(r8)                :: dp0(mix,mkx)             !  Environmental layer pressure thickness [ Pa ] > 0.
+    real(r8)                :: dpdry0(mix,mkx)          !  Environmental dry layer pressure thickness [ Pa ]
+    real(r8)                :: u0(mix,mkx)              !  Environmental zonal wind [ m/s ]
+    real(r8)                :: v0(mix,mkx)              !  Environmental meridional wind [ m/s ]
+    real(r8)                :: tke(mix,0:mkx)           !  Turbulent kinetic energy at the interfaces [ m2/s2 ]
+    real(r8)                :: cldfrct(mix,mkx)         !  Total cloud fraction at the previous time step [ fraction ]
+    real(r8)                :: concldfrct(mix,mkx)      !  Total convective ( shallow + deep ) cloud fraction at the previous time step [ fraction ]
+    real(r8)                :: qv0(mix,mkx)             !  Environmental water vapor specific humidity [ kg/kg ]
+    real(r8)                :: ql0(mix,mkx)             !  Environmental liquid water specific humidity [ kg/kg ]
+    real(r8)                :: qi0(mix,mkx)             !  Environmental ice specific humidity [ kg/kg ]
+    real(r8)                :: t0(mix,mkx)              !  Environmental temperature [ K ]
+    real(r8)                :: s0(mix,mkx)              !  Environmental dry static energy [ J/kg ]
+    real(r8)                :: tr0(mix,mkx,ncnst)       !  Environmental tracers [ #, kg/kg ]
+    real(r8)                :: umf(mix,0:mkx)           !  Updraft mass flux at the interfaces [ kg/m2/s ]
+    real(r8)                :: qvten(mix,mkx)           !  Tendency of water vapor specific humidity [ kg/kg/s ]
+    real(r8)                :: qlten(mix,mkx)           !  Tendency of liquid water specific humidity [ kg/kg/s ]
+    real(r8)                :: qiten(mix,mkx)           !  tendency of ice specific humidity [ kg/kg/s ]
+    real(r8)                :: sten(mix,mkx)            !  Tendency of static energy [ J/kg/s ]
+    real(r8)                :: uten(mix,mkx)            !  Tendency of zonal wind [ m/s2 ]
+    real(r8)                :: vten(mix,mkx)            !  Tendency of meridional wind [ m/s2 ]
+    real(r8)                :: trten(mix,mkx,ncnst)     !  Tendency of tracers [ #/s, kg/kg/s ]
+    real(r8)                :: qrten(mix,mkx)           !  Tendency of rain water specific humidity [ kg/kg/s ]
+    real(r8)                :: qsten(mix,mkx)           !  Tendency of snow speficif humidity [ kg/kg/s ]
+    real(r8)                :: evapc(mix,mkx)           !  Tendency of evaporation of precipitation [ kg/kg/s ]
+    real(r8)                :: slflx(mix,0:mkx)         !  Updraft liquid static energy flux [ J/kg * kg/m2/s ]
+    real(r8)                :: qtflx(mix,0:mkx)         !  Updraft total water flux [ kg/kg * kg/m2/s ]
+    real(r8)                :: cufrc(mix,mkx)           !  Shallow cumulus cloud fraction at the layer mid-point [ fraction ]
+    real(r8)                :: qcu(mix,mkx)             !  Condensate water specific humidity within cumulus updraft at the layer mid-point [ kg/kg ]
+    real(r8)                :: qlu(mix,mkx)             !  Liquid water specific humidity within cumulus updraft at the layer mid-point [ kg/kg ]
+    real(r8)                :: qiu(mix,mkx)             !  Ice specific humidity within cumulus updraft at the layer mid-point [ kg/kg ]
+    real(r8)                :: qc(mix,mkx)              !  Tendency of cumulus condensate detrained into the environment [ kg/kg/s ]
+    real(r8)                :: cnt(mix)                 !  Cumulus top  interface index, cnt = kpen [ no ]
+    real(r8)                :: cnb(mix)                 !  Cumulus base interface index, cnb = krel - 1 [ no ] 
+    integer                 :: k                        !  Vertical index for local fields [ no ] 
+    integer                 :: k_inv                    !  Vertical index for incoming fields [ no ]
+    integer                 :: m                        !  Tracer index [ no ]
+
+    do k = 1, mkx
+       k_inv               = mkx + 1 - k
+       p0(:iend,k)         = p0_inv(:iend,k_inv)
+       u0(:iend,k)         = u0_inv(:iend,k_inv)
+       v0(:iend,k)         = v0_inv(:iend,k_inv)
+       z0(:iend,k)         = z0_inv(:iend,k_inv)
+       dp0(:iend,k)        = dp0_inv(:iend,k_inv)
+       dpdry0(:iend,k)     = dpdry0_inv(:iend,k_inv)
+       qv0(:iend,k)        = qv0_inv(:iend,k_inv)
+       ql0(:iend,k)        = ql0_inv(:iend,k_inv)
+       qi0(:iend,k)        = qi0_inv(:iend,k_inv)
+       t0(:iend,k)         = t0_inv(:iend,k_inv)
+       s0(:iend,k)         = s0_inv(:iend,k_inv)
+       cldfrct(:iend,k)    = cldfrct_inv(:iend,k_inv)
+       concldfrct(:iend,k) = concldfrct_inv(:iend,k_inv)
+       do m = 1, ncnst
+          tr0(:iend,k,m)   = tr0_inv(:iend,k_inv,m)
+       enddo
+    enddo
+    
+    do k = 0, mkx
+       k_inv               = mkx + 1 - k
+       ps0(:iend,k)        = ps0_inv(:iend,k_inv)
+       zs0(:iend,k)        = zs0_inv(:iend,k_inv)
+       tke(:iend,k)        = tke_inv(:iend,k_inv)
+    end do
+
+    call compute_uwshcu( mix  , mkx    , iend      , ncnst , dt   , &
+                         ps0  , zs0    , p0        , z0    , dp0  , &
+                         u0   , v0     , qv0       , ql0   , qi0  , & 
+                         t0   , s0     , tr0       ,                & 
+                         tke  , cldfrct, concldfrct, pblh  , cush , & 
+                         umf  , slflx  , qtflx     ,                &  
+                         qvten, qlten  , qiten     ,                & 
+                         sten , uten   , vten      , trten ,        &
+                         qrten, qsten  , precip    , snow  , evapc, &
+                         cufrc, qcu    , qlu       , qiu   ,        &
+                         cbmf , qc     , rliq      ,                &
+                         cnt  , cnb    , qsat      , lchnk , dpdry0 )
+
+    ! Reverse cloud top/base interface indices
+
+       cnt_inv(:iend) = mkx + 1 - cnt(:iend)
+       cnb_inv(:iend) = mkx + 1 - cnb(:iend)
+
+    do k = 0, mkx
+       k_inv                  = mkx + 1 - k
+       umf_inv(:iend,k_inv)   = umf(:iend,k)       
+       slflx_inv(:iend,k_inv) = slflx(:iend,k)     
+       qtflx_inv(:iend,k_inv) = qtflx(:iend,k)     
+    end do
+
+    do k = 1, mkx
+       k_inv                         = mkx + 1 - k
+       qvten_inv(:iend,k_inv)        = qvten(:iend,k)   
+       qlten_inv(:iend,k_inv)        = qlten(:iend,k)   
+       qiten_inv(:iend,k_inv)        = qiten(:iend,k)   
+       sten_inv(:iend,k_inv)         = sten(:iend,k)    
+       uten_inv(:iend,k_inv)         = uten(:iend,k)    
+       vten_inv(:iend,k_inv)         = vten(:iend,k)    
+       qrten_inv(:iend,k_inv)        = qrten(:iend,k)   
+       qsten_inv(:iend,k_inv)        = qsten(:iend,k)   
+       evapc_inv(:iend,k_inv)        = evapc(:iend,k)
+       cufrc_inv(:iend,k_inv)        = cufrc(:iend,k)   
+       qcu_inv(:iend,k_inv)          = qcu(:iend,k)     
+       qlu_inv(:iend,k_inv)          = qlu(:iend,k)     
+       qiu_inv(:iend,k_inv)          = qiu(:iend,k)     
+       qc_inv(:iend,k_inv)           = qc(:iend,k)      
+       do m = 1, ncnst
+          trten_inv(:iend,k_inv,m)   = trten(:iend,k,m) 
+       enddo
+    enddo
+    
+  end subroutine compute_uwshcu_inv
+
+
+  subroutine compute_uwshcu( mix      , mkx       , iend         , ncnst    , dt        , &
+                             ps0_in   , zs0_in    , p0_in        , z0_in    , dp0_in    , &
+                             u0_in    , v0_in     , qv0_in       , ql0_in   , qi0_in    , &
+                             t0_in    , s0_in     , tr0_in       ,                        &
+                             tke_in   , cldfrct_in, concldfrct_in,  pblh_in , cush_inout, & 
+                             umf_out  , slflx_out , qtflx_out    ,                        &
+                             qvten_out, qlten_out , qiten_out    ,                        & 
+                             sten_out , uten_out  , vten_out     , trten_out,             &
+                             qrten_out, qsten_out , precip_out   , snow_out , evapc_out , &
+                             cufrc_out, qcu_out   , qlu_out      , qiu_out  ,             &
+                             cbmf_out , qc_out    , rliq_out     ,                        &
+                             cnt_out  , cnb_out   , qsat         , lchnk    , dpdry0_in )
+
+    ! ------------------------------------------------------------ !
+    !                                                              !  
+    !  University of Washington Shallow Convection Scheme          !
+    !                                                              !
+    !  Described in Park and Bretherton. 2008. J. Climate :        !
+    !                                                              !
+    ! 'The University of Washington shallow convection and         !
+    !  moist turbulent schemes and their impact on climate         !
+    !  simulations with the Community Atmosphere Model'            !
+    !                                                              !
+    !  Coded by Sungsu Park. Oct.2005.                             ! 
+    !                        May.2008.                             !
+    !  For questions, send an email to sungsup@ucar.edu or         ! 
+    !                                  sungsu@atmos.washington.edu !
+    !                                                              !
+    ! ------------------------------------------------------------ !
+
+#ifndef WRF_PORT 
+    use cam_history,     only : outfld, addfld, phys_decomp
+#else
+    use module_cam_support, only : outfld, addfld, phys_decomp
+#endif
+    use constituents,    only : qmin, cnst_get_type_byind, cnst_get_ind
+#ifdef MODAL_AERO
+    use modal_aero_data, only : ntot_amode, numptr_amode
+#endif
+
+    implicit none
+
+    ! ---------------------- !
+    ! Input-Output Variables !
+    ! ---------------------- !
+
+    integer , intent(in)    :: lchnk
+    integer , intent(in)    :: mix
+    integer , intent(in)    :: mkx
+    integer , intent(in)    :: iend
+    integer , intent(in)    :: ncnst
+    real(r8), intent(in)    :: dt                             !  Time step : 2*delta_t [ s ]
+    real(r8), intent(in)    :: ps0_in(mix,0:mkx)              !  Environmental pressure at the interfaces [ Pa ]
+    real(r8), intent(in)    :: zs0_in(mix,0:mkx)              !  Environmental height at the interfaces [ m ]
+    real(r8), intent(in)    :: p0_in(mix,mkx)                 !  Environmental pressure at the layer mid-point [ Pa ]
+    real(r8), intent(in)    :: z0_in(mix,mkx)                 !  Environmental height at the layer mid-point [ m ]
+    real(r8), intent(in)    :: dp0_in(mix,mkx)                !  Environmental layer pressure thickness [ Pa ] > 0.
+    real(r8), intent(in)    :: dpdry0_in(mix,mkx)             !  Environmental dry layer pressure thickness [ Pa ]
+    real(r8), intent(in)    :: u0_in(mix,mkx)                 !  Environmental zonal wind [ m/s ]
+    real(r8), intent(in)    :: v0_in(mix,mkx)                 !  Environmental meridional wind [ m/s ]
+    real(r8), intent(in)    :: qv0_in(mix,mkx)                !  Environmental water vapor specific humidity [ kg/kg ]
+    real(r8), intent(in)    :: ql0_in(mix,mkx)                !  Environmental liquid water specific humidity [ kg/kg ]
+    real(r8), intent(in)    :: qi0_in(mix,mkx)                !  Environmental ice specific humidity [ kg/kg ]
+    real(r8), intent(in)    :: t0_in(mix,mkx)                 !  Environmental temperature [ K ]
+    real(r8), intent(in)    :: s0_in(mix,mkx)                 !  Environmental dry static energy [ J/kg ]
+    real(r8), intent(in)    :: tr0_in(mix,mkx,ncnst)          !  Environmental tracers [ #, kg/kg ]
+    real(r8), intent(in)    :: tke_in(mix,0:mkx)              !  Turbulent kinetic energy at the interfaces [ m2/s2 ]
+    real(r8), intent(in)    :: cldfrct_in(mix,mkx)            !  Total cloud fraction at the previous time step [ fraction ]
+    real(r8), intent(in)    :: concldfrct_in(mix,mkx)         !  Total convective cloud fraction at the previous time step [ fraction ]
+    real(r8), intent(in)    :: pblh_in(mix)                   !  Height of PBL [ m ]
+    real(r8), intent(inout) :: cush_inout(mix)                !  Convective scale height [ m ]
+
+    real(r8)                   tw0_in(mix,mkx)                !  Wet bulb temperature [ K ]
+    real(r8)                   qw0_in(mix,mkx)                !  Wet-bulb specific humidity [ kg/kg ]
+
+    real(r8), intent(out)   :: umf_out(mix,0:mkx)             !  Updraft mass flux at the interfaces [ kg/m2/s ]
+    real(r8), intent(out)   :: qvten_out(mix,mkx)             !  Tendency of water vapor specific humidity [ kg/kg/s ]
+    real(r8), intent(out)   :: qlten_out(mix,mkx)             !  Tendency of liquid water specific humidity [ kg/kg/s ]
+    real(r8), intent(out)   :: qiten_out(mix,mkx)             !  Tendency of ice specific humidity [ kg/kg/s ]
+    real(r8), intent(out)   :: sten_out(mix,mkx)              !  Tendency of dry static energy [ J/kg/s ]
+    real(r8), intent(out)   :: uten_out(mix,mkx)              !  Tendency of zonal wind [ m/s2 ]
+    real(r8), intent(out)   :: vten_out(mix,mkx)              !  Tendency of meridional wind [ m/s2 ]
+    real(r8), intent(out)   :: trten_out(mix,mkx,ncnst)       !  Tendency of tracers [ #/s, kg/kg/s ]
+    real(r8), intent(out)   :: qrten_out(mix,mkx)             !  Tendency of rain water specific humidity [ kg/kg/s ]
+    real(r8), intent(out)   :: qsten_out(mix,mkx)             !  Tendency of snow specific humidity [ kg/kg/s ]
+    real(r8), intent(out)   :: precip_out(mix)                !  Precipitation ( rain + snow ) rate at surface [ m/s ]
+    real(r8), intent(out)   :: snow_out(mix)                  !  Snow rate at surface [ m/s ]
+    real(r8), intent(out)   :: evapc_out(mix,mkx)             !  Tendency of evaporation of precipitation [ kg/kg/s ]
+    real(r8), intent(out)   :: slflx_out(mix,0:mkx)           !  Updraft/pen.entrainment liquid static energy flux [ J/kg * kg/m2/s ]
+    real(r8), intent(out)   :: qtflx_out(mix,0:mkx)           !  updraft/pen.entrainment total water flux [ kg/kg * kg/m2/s ]
+    real(r8), intent(out)   :: cufrc_out(mix,mkx)             !  Shallow cumulus cloud fraction at the layer mid-point [ fraction ]
+    real(r8), intent(out)   :: qcu_out(mix,mkx)               !  Condensate water specific humidity within cumulus updraft [ kg/kg ]
+    real(r8), intent(out)   :: qlu_out(mix,mkx)               !  Liquid water specific humidity within cumulus updraft [ kg/kg ]
+    real(r8), intent(out)   :: qiu_out(mix,mkx)               !  Ice specific humidity within cumulus updraft [ kg/kg ]
+    real(r8), intent(out)   :: cbmf_out(mix)                  !  Cloud base mass flux [ kg/m2/s ]
+    real(r8), intent(out)   :: qc_out(mix,mkx)                !  Tendency of detrained cumulus condensate into the environment [ kg/kg/s ]
+    real(r8), intent(out)   :: rliq_out(mix)                  !  Vertical integral of qc_out [ m/s ]
+    real(r8), intent(out)   :: cnt_out(mix)                   !  Cumulus top  interface index, cnt = kpen [ no ]
+    real(r8), intent(out)   :: cnb_out(mix)                   !  Cumulus base interface index, cnb = krel - 1 [ no ] 
+
+    !
+    ! Internal Output Variables
+    !
+
+    integer , external      :: qsat 
+    real(r8)                   qtten_out(mix,mkx)             !  Tendency of qt [ kg/kg/s ]
+    real(r8)                   slten_out(mix,mkx)             !  Tendency of sl [ J/kg/s ]
+    real(r8)                   ufrc_out(mix,0:mkx)            !  Updraft fractional area at the interfaces [ fraction ]
+    real(r8)                   uflx_out(mix,0:mkx)            !  Updraft/pen.entrainment zonal momentum flux [ m/s/m2/s ]
+    real(r8)                   vflx_out(mix,0:mkx)            !  Updraft/pen.entrainment meridional momentum flux [ m/s/m2/s ]
+    real(r8)                   fer_out(mix,mkx)               !  Fractional lateral entrainment rate [ 1/Pa ]
+    real(r8)                   fdr_out(mix,mkx)               !  Fractional lateral detrainment rate [ 1/Pa ]
+    real(r8)                   cinh_out(mix)                  !  Convective INhibition upto LFC (CIN) [ J/kg ]
+    real(r8)                   trflx_out(mix,0:mkx,ncnst)     !  Updraft/pen.entrainment tracer flux [ #/m2/s, kg/kg/m2/s ] 
+   
+    ! -------------------------------------------- !
+    ! One-dimensional variables at each grid point !
+    ! -------------------------------------------- !
+
+    ! 1. Input variables
+
+    real(r8)    ps0(0:mkx)                                    !  Environmental pressure at the interfaces [ Pa ]
+    real(r8)    zs0(0:mkx)                                    !  Environmental height at the interfaces [ m ]
+    real(r8)    p0(mkx)                                       !  Environmental pressure at the layer mid-point [ Pa ]
+    real(r8)    z0(mkx)                                       !  Environmental height at the layer mid-point [ m ]
+    real(r8)    dp0(mkx)                                      !  Environmental layer pressure thickness [ Pa ] > 0.
+    real(r8)    dpdry0(mkx)                                   !  Environmental dry layer pressure thickness [ Pa ]
+    real(r8)    u0(mkx)                                       !  Environmental zonal wind [ m/s ]
+    real(r8)    v0(mkx)                                       !  Environmental meridional wind [ m/s ]
+    real(r8)    tke(0:mkx)                                    !  Turbulent kinetic energy at the interfaces [ m2/s2 ]
+    real(r8)    cldfrct(mkx)                                  !  Total cloud fraction at the previous time step [ fraction ]
+    real(r8)    concldfrct(mkx)                               !  Total convective cloud fraction at the previous time step [ fraction ]
+    real(r8)    qv0(mkx)                                      !  Environmental water vapor specific humidity [ kg/kg ]
+    real(r8)    ql0(mkx)                                      !  Environmental liquid water specific humidity [ kg/kg ]
+    real(r8)    qi0(mkx)                                      !  Environmental ice specific humidity [ kg/kg ]
+    real(r8)    t0(mkx)                                       !  Environmental temperature [ K ]
+    real(r8)    s0(mkx)                                       !  Environmental dry static energy [ J/kg ]
+    real(r8)    pblh                                          !  Height of PBL [ m ]
+    real(r8)    cush                                          !  Convective scale height [ m ]
+    real(r8)    tr0(mkx,ncnst)                                !  Environmental tracers [ #, kg/kg ]
+
+    ! 2. Environmental variables directly derived from the input variables
+
+    real(r8)    qt0(mkx)                                      !  Environmental total specific humidity [ kg/kg ]
+    real(r8)    thl0(mkx)                                     !  Environmental liquid potential temperature [ K ]
+    real(r8)    thvl0(mkx)                                    !  Environmental liquid virtual potential temperature [ K ]
+    real(r8)    ssqt0(mkx)                                    !  Linear internal slope of environmental total specific humidity [ kg/kg/Pa ]
+    real(r8)    ssthl0(mkx)                                   !  Linear internal slope of environmental liquid potential temperature [ K/Pa ]
+    real(r8)    ssu0(mkx)                                     !  Linear internal slope of environmental zonal wind [ m/s/Pa ]
+    real(r8)    ssv0(mkx)                                     !  Linear internal slope of environmental meridional wind [ m/s/Pa ]
+    real(r8)    thv0bot(mkx)                                  !  Environmental virtual potential temperature at the bottom of each layer [ K ]
+    real(r8)    thv0top(mkx)                                  !  Environmental virtual potential temperature at the top of each layer [ K ]
+    real(r8)    thvl0bot(mkx)                                 !  Environmental liquid virtual potential temperature at the bottom of each layer [ K ]
+    real(r8)    thvl0top(mkx)                                 !  Environmental liquid virtual potential temperature at the top of each layer [ K ]
+    real(r8)    exn0(mkx)                                     !  Exner function at the layer mid points [ no ]
+    real(r8)    exns0(0:mkx)                                  !  Exner function at the interfaces [ no ]
+    real(r8)    sstr0(mkx,ncnst)                              !  Linear slope of environmental tracers [ #/Pa, kg/kg/Pa ]
+
+   ! 2-1. For preventing negative condensate at the provisional time step
+
+    real(r8)    qv0_star(mkx)                                 !  Environmental water vapor specific humidity [ kg/kg ]
+    real(r8)    ql0_star(mkx)                                 !  Environmental liquid water specific humidity [ kg/kg ]
+    real(r8)    qi0_star(mkx)                                 !  Environmental ice specific humidity [ kg/kg ]
+    real(r8)    t0_star(mkx)                                  !  Environmental temperature [ K ]
+    real(r8)    s0_star(mkx)                                  !  Environmental dry static energy [ J/kg ]
+
+   ! 3. Variables associated with cumulus convection
+
+    real(r8)    umf(0:mkx)                                    !  Updraft mass flux at the interfaces [ kg/m2/s ]
+    real(r8)    emf(0:mkx)                                    !  Penetrative entrainment mass flux at the interfaces [ kg/m2/s ]
+    real(r8)    qvten(mkx)                                    !  Tendency of water vapor specific humidity [ kg/kg/s ]
+    real(r8)    qlten(mkx)                                    !  Tendency of liquid water specific humidity [ kg/kg/s ]
+    real(r8)    qiten(mkx)                                    !  Tendency of ice specific humidity [ kg/kg/s ]
+    real(r8)    sten(mkx)                                     !  Tendency of dry static energy [ J/kg ]
+    real(r8)    uten(mkx)                                     !  Tendency of zonal wind [ m/s2 ]
+    real(r8)    vten(mkx)                                     !  Tendency of meridional wind [ m/s2 ]
+    real(r8)    qrten(mkx)                                    !  Tendency of rain water specific humidity [ kg/kg/s ]
+    real(r8)    qsten(mkx)                                    !  Tendency of snow specific humidity [ kg/kg/s ]
+    real(r8)    precip                                        !  Precipitation rate ( rain + snow) at the surface [ m/s ]
+    real(r8)    snow                                          !  Snow rate at the surface [ m/s ]
+    real(r8)    evapc(mkx)                                    !  Tendency of evaporation of precipitation [ kg/kg/s ]
+    real(r8)    slflx(0:mkx)                                  !  Updraft/pen.entrainment liquid static energy flux [ J/kg * kg/m2/s ]
+    real(r8)    qtflx(0:mkx)                                  !  Updraft/pen.entrainment total water flux [ kg/kg * kg/m2/s ]
+    real(r8)    uflx(0:mkx)                                   !  Updraft/pen.entrainment flux of zonal momentum [ m/s/m2/s ]
+    real(r8)    vflx(0:mkx)                                   !  Updraft/pen.entrainment flux of meridional momentum [ m/s/m2/s ]
+    real(r8)    cufrc(mkx)                                    !  Shallow cumulus cloud fraction at the layer mid-point [ fraction ]
+    real(r8)    qcu(mkx)                                      !  Condensate water specific humidity within convective updraft [ kg/kg ]
+    real(r8)    qlu(mkx)                                      !  Liquid water specific humidity within convective updraft [ kg/kg ]
+    real(r8)    qiu(mkx)                                      !  Ice specific humidity within convective updraft [ kg/kg ]
+    real(r8)    dwten(mkx)                                    !  Detrained water tendency from cumulus updraft [ kg/kg/s ]
+    real(r8)    diten(mkx)                                    !  Detrained ice   tendency from cumulus updraft [ kg/kg/s ]
+    real(r8)    fer(mkx)                                      !  Fractional lateral entrainment rate [ 1/Pa ]
+    real(r8)    fdr(mkx)                                      !  Fractional lateral detrainment rate [ 1/Pa ]
+    real(r8)    uf(mkx)                                       !  Zonal wind at the provisional time step [ m/s ]
+    real(r8)    vf(mkx)                                       !  Meridional wind at the provisional time step [ m/s ]
+    real(r8)    qc(mkx)                                       !  Tendency due to detrained 'cloud water + cloud ice' (without rain-snow contribution) [ kg/kg/s ]
+    real(r8)    qc_l(mkx)                                     !  Tendency due to detrained 'cloud water' (without rain-snow contribution) [ kg/kg/s ]
+    real(r8)    qc_i(mkx)                                     !  Tendency due to detrained 'cloud ice' (without rain-snow contribution) [ kg/kg/s ]
+    real(r8)    qc_lm
+    real(r8)    qc_im
+    real(r8)    nc_lm
+    real(r8)    nc_im
+    real(r8)    ql_emf_kbup
+    real(r8)    qi_emf_kbup
+    real(r8)    nl_emf_kbup
+    real(r8)    ni_emf_kbup
+    real(r8)    qlten_det
+    real(r8)    qiten_det
+    real(r8)    rliq                                          !  Vertical integral of qc [ m/s ] 
+    real(r8)    cnt                                           !  Cumulus top  interface index, cnt = kpen [ no ]
+    real(r8)    cnb                                           !  Cumulus base interface index, cnb = krel - 1 [ no ] 
+    real(r8)    qtten(mkx)                                    !  Tendency of qt [ kg/kg/s ]
+    real(r8)    slten(mkx)                                    !  Tendency of sl [ J/kg/s ]
+    real(r8)    ufrc(0:mkx)                                   !  Updraft fractional area [ fraction ]
+    real(r8)    trten(mkx,ncnst)                              !  Tendency of tracers [ #/s, kg/kg/s ]
+    real(r8)    trflx(0:mkx,ncnst)                            !  Flux of tracers due to convection [ # * kg/m2/s, kg/kg * kg/m2/s ]
+    real(r8)    trflx_d(0:mkx)                                !  Adjustive downward flux of tracers to prevent negative tracers
+    real(r8)    trflx_u(0:mkx)                                !  Adjustive upward   flux of tracers to prevent negative tracers
+    real(r8)    trmin                                         !  Minimum concentration of tracers allowed
+    real(r8)    pdelx, dum 
+    
+    !----- Variables used for the calculation of condensation sink associated with compensating subsidence
+    !      In the current code, this 'sink' tendency is simply set to be zero.
+
+    real(r8)    uemf(0:mkx)                                   !  Net updraft mass flux at the interface ( emf + umf ) [ kg/m2/s ]
+    real(r8)    comsub(mkx)                                   !  Compensating subsidence at the layer mid-point ( unit of mass flux, umf ) [ kg/m2/s ]
+    real(r8)    qlten_sink(mkx)                               !  Liquid condensate tendency by compensating subsidence/upwelling [ kg/kg/s ]
+    real(r8)    qiten_sink(mkx)                               !  Ice    condensate tendency by compensating subsidence/upwelling [ kg/kg/s ]
+    real(r8)    nlten_sink(mkx)                               !  Liquid droplets # tendency by compensating subsidence/upwelling [ kg/kg/s ]
+    real(r8)    niten_sink(mkx)                               !  Ice    droplets # tendency by compensating subsidence/upwelling [ kg/kg/s ]
+    real(r8)    thlten_sub, qtten_sub                         !  Tendency of conservative scalars by compensating subsidence/upwelling
+    real(r8)    qlten_sub, qiten_sub                          !  Tendency of ql0, qi0             by compensating subsidence/upwelling
+    real(r8)    nlten_sub, niten_sub                          !  Tendency of nl0, ni0             by compensating subsidence/upwelling
+    real(r8)    thl_prog, qt_prog                             !  Prognosed 'thl, qt' by compensating subsidence/upwelling 
+
+    !----- Variables describing cumulus updraft
+
+    real(r8)    wu(0:mkx)                                     !  Updraft vertical velocity at the interface [ m/s ]
+    real(r8)    thlu(0:mkx)                                   !  Updraft liquid potential temperature at the interface [ K ]
+    real(r8)    qtu(0:mkx)                                    !  Updraft total specific humidity at the interface [ kg/kg ]
+    real(r8)    uu(0:mkx)                                     !  Updraft zonal wind at the interface [ m/s ]
+    real(r8)    vu(0:mkx)                                     !  Updraft meridional wind at the interface [ m/s ]
+    real(r8)    thvu(0:mkx)                                   !  Updraft virtual potential temperature at the interface [ m/s ]
+    real(r8)    rei(mkx)                                      !  Updraft fractional mixing rate with the environment [ 1/Pa ]
+    real(r8)    tru(0:mkx,ncnst)                              !  Updraft tracers [ #, kg/kg ]
+
+    !----- Variables describing conservative scalars of entraining downdrafts  at the 
+    !      entraining interfaces, i.e., 'kbup <= k < kpen-1'. At the other interfaces,
+    !      belows are simply set to equal to those of updraft for simplicity - but it
+    !      does not influence numerical calculation.
+
+    real(r8)    thlu_emf(0:mkx)                               !  Penetrative downdraft liquid potential temperature at entraining interfaces [ K ]
+    real(r8)    qtu_emf(0:mkx)                                !  Penetrative downdraft total water at entraining interfaces [ kg/kg ]
+    real(r8)    uu_emf(0:mkx)                                 !  Penetrative downdraft zonal wind at entraining interfaces [ m/s ]
+    real(r8)    vu_emf(0:mkx)                                 !  Penetrative downdraft meridional wind at entraining interfaces [ m/s ]
+    real(r8)    tru_emf(0:mkx,ncnst)                          !  Penetrative Downdraft tracers at entraining interfaces [ #, kg/kg ]    
+
+    !----- Variables associated with evaporations of convective 'rain' and 'snow'
+
+    real(r8)    flxrain(0:mkx)                                !  Downward rain flux at each interface [ kg/m2/s ]
+    real(r8)    flxsnow(0:mkx)                                !  Downward snow flux at each interface [ kg/m2/s ]
+    real(r8)    ntraprd(mkx)                                  !  Net production ( production - evaporation +  melting ) rate of rain in each layer [ kg/kg/s ]
+    real(r8)    ntsnprd(mkx)                                  !  Net production ( production - evaporation + freezing ) rate of snow in each layer [ kg/kg/s ]
+    real(r8)    flxsntm                                       !  Downward snow flux at the top of each layer after melting [ kg/m2/s ]
+    real(r8)    snowmlt                                       !  Snow melting tendency [ kg/kg/s ]
+    real(r8)    subsat                                        !  Sub-saturation ratio (1-qv/qs) [ no unit ]
+    real(r8)    evprain                                       !  Evaporation rate of rain [ kg/kg/s ]
+    real(r8)    evpsnow                                       !  Evaporation rate of snow [ kg/kg/s ]
+    real(r8)    evplimit                                      !  Limiter of 'evprain + evpsnow' [ kg/kg/s ]
+    real(r8)    evplimit_rain                                 !  Limiter of 'evprain' [ kg/kg/s ]
+    real(r8)    evplimit_snow                                 !  Limiter of 'evpsnow' [ kg/kg/s ]
+    real(r8)    evpint_rain                                   !  Vertically-integrated evaporative flux of rain [ kg/m2/s ]
+    real(r8)    evpint_snow                                   !  Vertically-integrated evaporative flux of snow [ kg/m2/s ]
+    real(r8)    kevp                                          !  Evaporative efficiency [ complex unit ]
+
+    !----- Other internal variables
+
+    integer     kk, mm, k, i, m, kp1, km1
+    integer     iter_scaleh, iter_xc
+    integer     id_check, status
+    integer     klcl                                          !  Layer containing LCL of source air
+    integer     kinv                                          !  Inversion layer with PBL top interface as a lower interface
+    integer     krel                                          !  Release layer where buoyancy sorting mixing occurs for the first time
+    integer     klfc                                          !  LFC layer of cumulus source air
+    integer     kbup                                          !  Top layer in which cloud buoyancy is positive at the top interface
+    integer     kpen                                          !  Highest layer with positive updraft vertical velocity - top layer cumulus can reach
+    logical     id_exit   
+    logical     forcedCu                                      !  If 'true', cumulus updraft cannot overcome the buoyancy barrier just above the PBL top.
+    real(r8)    thlsrc, qtsrc, usrc, vsrc, thvlsrc            !  Updraft source air properties
+    real(r8)    PGFc, uplus, vplus
+    real(r8)    trsrc(ncnst), tre(ncnst)
+    real(r8)    plcl, plfc, prel, wrel
+    real(r8)    frc_rasn
+    real(r8)    ee2, ud2, wtw, wtwb, wtwh
+    real(r8)    xc, xc_2                                       
+    real(r8)    cldhgt, scaleh, tscaleh, cridis, rle, rkm
+    real(r8)    rkfre, sigmaw, epsvarw, tkeavg, dpsum, dpi, thvlmin
+    real(r8)    thlxsat, qtxsat, thvxsat, x_cu, x_en, thv_x0, thv_x1
+    real(r8)    thj, qvj, qlj, qij, thvj, tj, thv0j, rho0j, rhos0j, qse 
+    real(r8)    cin, cinlcl
+    real(r8)    pe, dpe, exne, thvebot, thle, qte, ue, ve, thlue, qtue, wue
+    real(r8)    mu, mumin0, mumin1, mumin2, mulcl, mulclstar
+    real(r8)    cbmf, wcrit, winv, wlcl, ufrcinv, ufrclcl, rmaxfrac
+    real(r8)    criqc, exql, exqi, rpen, ppen
+    real(r8)    thl0top, thl0bot, qt0bot, qt0top, thvubot, thvutop
+    real(r8)    thlu_top, qtu_top, qlu_top, qiu_top, qlu_mid, qiu_mid, exntop
+    real(r8)    thl0lcl, qt0lcl, thv0lcl, thv0rel, rho0inv, autodet
+    real(r8)    aquad, bquad, cquad, xc1, xc2, excessu, excess0, xsat, xs1, xs2
+    real(r8)    bogbot, bogtop, delbog, drage, expfac, rbuoy, rdrag
+    real(r8)    rcwp, rlwp, riwp, qcubelow, qlubelow, qiubelow
+    real(r8)    rainflx, snowflx                     
+    real(r8)    es(1)                               
+    real(r8)    qs(1)                               
+    real(r8)    gam(1)                                        !  (L/cp)*dqs/dT
+    real(r8)    qsat_arg             
+    real(r8)    xsrc, xmean, xtop, xbot, xflx(0:mkx)
+    real(r8)    tmp1, tmp2
+
+    !----- Some diagnostic internal output variables
+
+    real(r8)  ufrcinvbase_out(mix)                            !  Cumulus updraft fraction at the PBL top [ fraction ]
+    real(r8)  ufrclcl_out(mix)                                !  Cumulus updraft fraction at the LCL ( or PBL top when LCL is below PBL top ) [ fraction ]
+    real(r8)  winvbase_out(mix)                               !  Cumulus updraft velocity at the PBL top [ m/s ]
+    real(r8)  wlcl_out(mix)                                   !  Cumulus updraft velocity at the LCL ( or PBL top when LCL is below PBL top ) [ m/s ]
+    real(r8)  plcl_out(mix)                                   !  LCL of source air [ Pa ]
+    real(r8)  pinv_out(mix)                                   !  PBL top pressure [ Pa ]
+    real(r8)  plfc_out(mix)                                   !  LFC of source air [ Pa ]
+    real(r8)  pbup_out(mix)                                   !  Highest interface level of positive buoyancy [ Pa ]
+    real(r8)  ppen_out(mix)                                   !  Highest interface evel where Cu w = 0 [ Pa ]
+    real(r8)  qtsrc_out(mix)                                  !  Sourse air qt [ kg/kg ]
+    real(r8)  thlsrc_out(mix)                                 !  Sourse air thl [ K ]
+    real(r8)  thvlsrc_out(mix)                                !  Sourse air thvl [ K ]
+    real(r8)  emfkbup_out(mix)                                !  Penetrative downward mass flux at 'kbup' interface [ kg/m2/s ]
+    real(r8)  cinlclh_out(mix)                                !  Convective INhibition upto LCL (CIN) [ J/kg = m2/s2 ]
+    real(r8)  tkeavg_out(mix)                                 !  Average tke over the PBL [ m2/s2 ]
+    real(r8)  cbmflimit_out(mix)                              !  Cloud base mass flux limiter [ kg/m2/s ]
+    real(r8)  zinv_out(mix)                                   !  PBL top height [ m ]
+    real(r8)  rcwp_out(mix)                                   !  Layer mean Cumulus LWP+IWP [ kg/m2 ] 
+    real(r8)  rlwp_out(mix)                                   !  Layer mean Cumulus LWP [ kg/m2 ] 
+    real(r8)  riwp_out(mix)                                   !  Layer mean Cumulus IWP [ kg/m2 ] 
+    real(r8)  wu_out(mix,0:mkx)                               !  Updraft vertical velocity ( defined from the release level to 'kpen-1' interface )
+    real(r8)  qtu_out(mix,0:mkx)                              !  Updraft qt [ kg/kg ]
+    real(r8)  thlu_out(mix,0:mkx)                             !  Updraft thl [ K ]
+    real(r8)  thvu_out(mix,0:mkx)                             !  Updraft thv [ K ]
+    real(r8)  uu_out(mix,0:mkx)                               !  Updraft zonal wind [ m/s ] 
+    real(r8)  vu_out(mix,0:mkx)                               !  Updraft meridional wind [ m/s ]
+    real(r8)  qtu_emf_out(mix,0:mkx)                          !  Penetratively entrained qt [ kg/kg ]   
+    real(r8)  thlu_emf_out(mix,0:mkx)                         !  Penetratively entrained thl [ K ]
+    real(r8)  uu_emf_out(mix,0:mkx)                           !  Penetratively entrained u [ m/s ]
+    real(r8)  vu_emf_out(mix,0:mkx)                           !  Penetratively entrained v [ m/s ]
+    real(r8)  uemf_out(mix,0:mkx)                             !  Net upward mass flux including penetrative entrainment (umf+emf) [ kg/m2/s ]
+    real(r8)  tru_out(mix,0:mkx,ncnst)                        !  Updraft tracers [ #, kg/kg ]   
+    real(r8)  tru_emf_out(mix,0:mkx,ncnst)                    !  Penetratively entrained tracers [ #, kg/kg ]
+
+    real(r8)  wu_s(0:mkx)                                     !  Same as above but for implicit CIN
+    real(r8)  qtu_s(0:mkx)
+    real(r8)  thlu_s(0:mkx)
+    real(r8)  thvu_s(0:mkx)
+    real(r8)  uu_s(0:mkx)
+    real(r8)  vu_s(0:mkx)
+    real(r8)  qtu_emf_s(0:mkx) 
+    real(r8)  thlu_emf_s(0:mkx)  
+    real(r8)  uu_emf_s(0:mkx)   
+    real(r8)  vu_emf_s(0:mkx)
+    real(r8)  uemf_s(0:mkx)   
+    real(r8)  tru_s(0:mkx,ncnst)
+    real(r8)  tru_emf_s(0:mkx,ncnst)   
+
+    real(r8)  dwten_out(mix,mkx)
+    real(r8)  diten_out(mix,mkx)
+    real(r8)  flxrain_out(mix,0:mkx)  
+    real(r8)  flxsnow_out(mix,0:mkx)  
+    real(r8)  ntraprd_out(mix,mkx)    
+    real(r8)  ntsnprd_out(mix,mkx)    
+
+    real(r8)  dwten_s(mkx)
+    real(r8)  diten_s(mkx)
+    real(r8)  flxrain_s(0:mkx)  
+    real(r8)  flxsnow_s(0:mkx)  
+    real(r8)  ntraprd_s(mkx)    
+    real(r8)  ntsnprd_s(mkx)    
+
+    real(r8)  excessu_arr_out(mix,mkx)
+    real(r8)  excessu_arr(mkx) 
+    real(r8)  excessu_arr_s(mkx)
+    real(r8)  excess0_arr_out(mix,mkx)
+    real(r8)  excess0_arr(mkx)
+    real(r8)  excess0_arr_s(mkx)
+    real(r8)  xc_arr_out(mix,mkx)
+    real(r8)  xc_arr(mkx)
+    real(r8)  xc_arr_s(mkx)
+    real(r8)  aquad_arr_out(mix,mkx)
+    real(r8)  aquad_arr(mkx)
+    real(r8)  aquad_arr_s(mkx)
+    real(r8)  bquad_arr_out(mix,mkx)
+    real(r8)  bquad_arr(mkx)
+    real(r8)  bquad_arr_s(mkx)
+    real(r8)  cquad_arr_out(mix,mkx) 
+    real(r8)  cquad_arr(mkx)
+    real(r8)  cquad_arr_s(mkx)
+    real(r8)  bogbot_arr_out(mix,mkx)
+    real(r8)  bogbot_arr(mkx)
+    real(r8)  bogbot_arr_s(mkx)
+    real(r8)  bogtop_arr_out(mix,mkx)
+    real(r8)  bogtop_arr(mkx)
+    real(r8)  bogtop_arr_s(mkx)
+
+    real(r8)  exit_UWCu(mix)
+    real(r8)  exit_conden(mix)
+    real(r8)  exit_klclmkx(mix)
+    real(r8)  exit_klfcmkx(mix)
+    real(r8)  exit_ufrc(mix)
+    real(r8)  exit_wtw(mix)
+    real(r8)  exit_drycore(mix)
+    real(r8)  exit_wu(mix)
+    real(r8)  exit_cufilter(mix)
+    real(r8)  exit_kinv1(mix)
+    real(r8)  exit_rei(mix)
+
+    real(r8)  limit_shcu(mix)
+    real(r8)  limit_negcon(mix)
+    real(r8)  limit_ufrc(mix)
+    real(r8)  limit_ppen(mix)
+    real(r8)  limit_emf(mix)
+    real(r8)  limit_cinlcl(mix)
+    real(r8)  limit_cin(mix)
+    real(r8)  limit_cbmf(mix)
+    real(r8)  limit_rei(mix)
+    real(r8)  ind_delcin(mix)
+
+    real(r8) :: ufrcinvbase_s, ufrclcl_s, winvbase_s, wlcl_s, plcl_s, pinv_s, plfc_s, &
+                qtsrc_s, thlsrc_s, thvlsrc_s, emfkbup_s, cinlcl_s, pbup_s, ppen_s, cbmflimit_s, &
+                tkeavg_s, zinv_s, rcwp_s, rlwp_s, riwp_s 
+    real(r8) :: ufrcinvbase, winvbase, pinv, zinv, emfkbup, cbmflimit, rho0rel  
+
+    !----- Variables for implicit CIN computation
+
+    real(r8), dimension(mkx)         :: qv0_s  , ql0_s   , qi0_s   , s0_s    , u0_s    ,           & 
+                                        v0_s   , t0_s    , qt0_s   , thl0_s  , thvl0_s , qvten_s , &
+                                        qlten_s, qiten_s , qrten_s , qsten_s , sten_s  , evapc_s , &
+                                        uten_s , vten_s  , cufrc_s , qcu_s   , qlu_s   , qiu_s   , &
+                                        fer_s  , fdr_s   , qc_s    , qtten_s , slten_s 
+    real(r8), dimension(0:mkx)       :: umf_s  , slflx_s , qtflx_s , ufrc_s  , uflx_s , vflx_s
+    real(r8)                         :: cush_s , precip_s, snow_s  , cin_s   , rliq_s, cbmf_s, cnt_s, cnb_s
+    real(r8)                         :: cin_i,cin_f,del_CIN,ke,alpha,thlj
+    real(r8)                         :: cinlcl_i,cinlcl_f,del_cinlcl
+    integer                          :: iter
+
+    real(r8), dimension(mkx,ncnst)   :: tr0_s, trten_s
+    real(r8), dimension(0:mkx,ncnst) :: trflx_s
+
+    !----- Variables for temporary storages
+
+    real(r8), dimension(mkx)         :: qv0_o, ql0_o, qi0_o, t0_o, s0_o, u0_o, v0_o
+    real(r8), dimension(mkx)         :: qt0_o    , thl0_o   , thvl0_o   ,                         &
+                                        qvten_o  , qlten_o  , qiten_o   , qrten_o   , qsten_o ,   &
+                                        sten_o   , uten_o   , vten_o    , qcu_o     , qlu_o   ,   & 
+                                        qiu_o    , cufrc_o  , evapc_o   ,                         &
+                                        thv0bot_o, thv0top_o, thvl0bot_o, thvl0top_o,             &
+                                        ssthl0_o , ssqt0_o  , ssu0_o    , ssv0_o    , qc_o    ,   &
+                                        qtten_o  , slten_o  
+    real(r8), dimension(0:mkx)       :: umf_o    , slflx_o  , qtflx_o   , ufrc_o 
+    real(r8), dimension(mix)         :: cush_o   , precip_o , snow_o    , rliq_o, cbmf_o, cnt_o, cnb_o
+    real(r8), dimension(0:mkx)       :: uflx_o   , vflx_o
+    real(r8)                         :: tkeavg_o , thvlmin_o, qtsrc_o  , thvlsrc_o, thlsrc_o ,    &
+                                        usrc_o   , vsrc_o   , plcl_o   , plfc_o   ,               &
+                                        thv0lcl_o, cinlcl_o 
+    integer                          :: kinv_o   , klcl_o   , klfc_o  
+
+    real(r8), dimension(mkx,ncnst)   :: tr0_o
+    real(r8), dimension(mkx,ncnst)   :: trten_o, sstr0_o  
+    real(r8), dimension(0:mkx,ncnst) :: trflx_o
+    real(r8), dimension(ncnst)       :: trsrc_o
+    integer                          :: ixnumliq, ixnumice
+
+    ! ------------------ !
+    !                    !
+    ! Define Parameters  !
+    !                    !
+    ! ------------------ !
+
+    ! ------------------------ !
+    ! Iterative xc calculation !
+    ! ------------------------ !
+
+    integer , parameter              :: niter_xc = 2
+
+    ! ----------------------------------------------------------- !
+    ! Choice of 'CIN = cin' (.true.) or 'CIN = cinlcl' (.false.). !
+    ! ----------------------------------------------------------- !
+
+    logical , parameter              :: use_CINcin = .true.
+
+    ! --------------------------------------------------------------- !
+    ! Choice of 'explicit' ( 1 ) or 'implicit' ( 2 )  CIN.            !
+    !                                                                 !
+    ! When choose 'CIN = cinlcl' above,  it is recommended not to use ! 
+    ! implicit CIN, i.e., do 'NOT' choose simultaneously :            !
+    !            [ 'use_CINcin=.false. & 'iter_cin=2' ]               !
+    ! since 'cinlcl' will be always set to zero whenever LCL is below !
+    ! the PBL top interface in the current code. So, averaging cinlcl !
+    ! of two iter_cin steps is likely not so good. Except that,   all !
+    ! the other combinations of  'use_CINcin'  & 'iter_cin' are OK.   !
+    !                                                                 !
+    ! Feb 2007, Bundy: Note that use_CINcin = .false. will try to use !
+    !           a variable (del_cinlcl) that is not currently set     !
+    !                                                                 !
+    ! --------------------------------------------------------------- !
+
+    integer , parameter              :: iter_cin = 2
+
+    ! ---------------------------------------------------------------- !
+    ! Choice of 'self-detrainment' by negative buoyancy in calculating !
+    ! cumulus updraft mass flux at the top interface in each layer.    !
+    ! ---------------------------------------------------------------- !
+
+    logical , parameter              :: use_self_detrain = .false.
+    
+    ! --------------------------------------------------------- !
+    ! Cumulus momentum flux : turn-on (.true.) or off (.false.) !
+    ! --------------------------------------------------------- !
+
+    logical , parameter              :: use_momenflx = .true.
+
+    ! ----------------------------------------------------------------------------------------- !
+    ! Penetrative Entrainment : Cumulative ( .true. , original ) or Non-Cumulative ( .false. )  !
+    ! This option ( .false. ) is designed to reduce the sensitivity to the vertical resolution. !
+    ! ----------------------------------------------------------------------------------------- !
+
+    logical , parameter              :: use_cumpenent = .true.
+
+    ! --------------------------------------------------------------------------------------------------------------- !
+    ! Computation of the grid-mean condensate tendency.                                                               !
+    !     use_expconten = .true.  : explcitly compute tendency by condensate detrainment and compensating subsidence  !
+    !     use_expconten = .false. : use the original proportional condensate tendency equation. ( original )          !
+    ! --------------------------------------------------------------------------------------------------------------- !
+
+    logical , parameter              :: use_expconten = .true.
+
+    ! --------------------------------------------------------------------------------------------------------------- !
+    ! Treatment of reserved condensate                                                                                !
+    !     use_unicondet = .true.  : detrain condensate uniformly over the environment ( original )                    !
+    !     use_unicondet = .false. : detrain condensate into the pre-existing stratus                                  !
+    ! --------------------------------------------------------------------------------------------------------------- !
+
+    logical , parameter              :: use_unicondet = .false.
+
+    ! ----------------------- !
+    ! For lateral entrainment !
+    ! ----------------------- !
+
+    parameter (rle = 0.1_r8)         !  For critical stopping distance for lateral entrainment [no unit]
+!   parameter (rkm = 16.0_r8)        !  Determine the amount of air that is involved in buoyancy-sorting [no unit] 
+    parameter (rkm = 14.0_r8)        !  Determine the amount of air that is involved in buoyancy-sorting [no unit]
+
+    parameter (rpen = 10.0_r8)       !  For penetrative entrainment efficiency
+    parameter (rkfre = 1.0_r8)       !  Vertical velocity variance as fraction of  tke. 
+    parameter (rmaxfrac = 0.10_r8)   !  Maximum allowable 'core' updraft fraction
+    parameter (mumin1 = 0.906_r8)    !  Normalized CIN ('mu') corresponding to 'rmaxfrac' at the PBL top
+                                     !  obtaind by inverting 'rmaxfrac = 0.5*erfc(mumin1)'.
+                                     !  [ rmaxfrac:mumin1 ] = [ 0.05:1.163, 0.075:1.018, 0.1:0.906, 0.15:0.733, 0.2:0.595, 0.25:0.477 ] 
+    parameter (rbuoy = 1.0_r8)       !  For nonhydrostatic pressure effects on updraft [no unit]
+    parameter (rdrag = 1.0_r8)       !  Drag coefficient [no unit]
+
+    parameter (epsvarw = 5.e-4_r8)   !  Variance of w at PBL top by meso-scale component [m2/s2]          
+    parameter (PGFc = 0.7_r8)        !  This is used for calculating vertical variations cumulus  
+                                     !  'u' & 'v' by horizontal PGF during upward motion [no unit]
+
+    ! ---------------------------------------- !
+    ! Bulk microphysics controlling parameters !
+    ! --------------------------------------------------------------------------- ! 
+    ! criqc    : Maximum condensate that can be hold by cumulus updraft [kg/kg]   !
+    ! frc_rasn : Fraction of precipitable condensate in the expelled cloud water  !
+    !            from cumulus updraft. The remaining fraction ('1-frc_rasn')  is  !
+    !            'suspended condensate'.                                          !
+    !                0 : all expelled condensate is 'suspended condensate'        ! 
+    !                1 : all expelled condensate is 'precipitable condensate'     !
+    ! kevp     : Evaporative efficiency                                           !
+    ! noevap_krelkpen : No evaporation from 'krel' to 'kpen' layers               ! 
+    ! --------------------------------------------------------------------------- !    
+
+    parameter ( criqc    = 0.7e-3_r8 ) 
+    parameter ( frc_rasn = 1.0_r8    )
+    parameter ( kevp     = 2.e-6_r8  )
+    logical, parameter :: noevap_krelkpen = .false.
+
+    !------------------------!
+    !                        !
+    ! Start Main Calculation !
+    !                        !
+    !------------------------!
+
+    call cnst_get_ind( 'NUMLIQ', ixnumliq )
+    call cnst_get_ind( 'NUMICE', ixnumice )
+
+    ! ------------------------------------------------------- !
+    ! Initialize output variables defined for all grid points !
+    ! ------------------------------------------------------- !
+
+    umf_out(:iend,0:mkx)         = 0.0_r8
+    slflx_out(:iend,0:mkx)       = 0.0_r8
+    qtflx_out(:iend,0:mkx)       = 0.0_r8
+    qvten_out(:iend,:mkx)        = 0.0_r8
+    qlten_out(:iend,:mkx)        = 0.0_r8
+    qiten_out(:iend,:mkx)        = 0.0_r8
+    sten_out(:iend,:mkx)         = 0.0_r8
+    uten_out(:iend,:mkx)         = 0.0_r8
+    vten_out(:iend,:mkx)         = 0.0_r8
+    qrten_out(:iend,:mkx)        = 0.0_r8
+    qsten_out(:iend,:mkx)        = 0.0_r8
+    precip_out(:iend)            = 0.0_r8
+    snow_out(:iend)              = 0.0_r8
+    evapc_out(:iend,:mkx)        = 0.0_r8
+    cufrc_out(:iend,:mkx)        = 0.0_r8
+    qcu_out(:iend,:mkx)          = 0.0_r8
+    qlu_out(:iend,:mkx)          = 0.0_r8
+    qiu_out(:iend,:mkx)          = 0.0_r8
+    fer_out(:iend,:mkx)          = 0.0_r8
+    fdr_out(:iend,:mkx)          = 0.0_r8
+    cinh_out(:iend)              = -1.0_r8
+    cinlclh_out(:iend)           = -1.0_r8
+    cbmf_out(:iend)              = 0.0_r8
+    qc_out(:iend,:mkx)           = 0.0_r8
+    rliq_out(:iend)              = 0.0_r8
+    cnt_out(:iend)               = real(mkx, r8)
+    cnb_out(:iend)               = 0.0_r8
+    qtten_out(:iend,:mkx)        = 0.0_r8
+    slten_out(:iend,:mkx)        = 0.0_r8
+    ufrc_out(:iend,0:mkx)        = 0.0_r8
+
+    uflx_out(:iend,0:mkx)        = 0.0_r8
+    vflx_out(:iend,0:mkx)        = 0.0_r8
+
+    trten_out(:iend,:mkx,:ncnst) = 0.0_r8
+    trflx_out(:iend,0:mkx,:ncnst)= 0.0_r8
+    
+    ufrcinvbase_out(:iend)       = 0.0_r8
+    ufrclcl_out(:iend)           = 0.0_r8
+    winvbase_out(:iend)          = 0.0_r8
+    wlcl_out(:iend)              = 0.0_r8
+    plcl_out(:iend)              = 0.0_r8
+    pinv_out(:iend)              = 0.0_r8
+    plfc_out(:iend)              = 0.0_r8
+    pbup_out(:iend)              = 0.0_r8
+    ppen_out(:iend)              = 0.0_r8
+    qtsrc_out(:iend)             = 0.0_r8
+    thlsrc_out(:iend)            = 0.0_r8
+    thvlsrc_out(:iend)           = 0.0_r8
+    emfkbup_out(:iend)           = 0.0_r8
+    cbmflimit_out(:iend)         = 0.0_r8
+    tkeavg_out(:iend)            = 0.0_r8
+    zinv_out(:iend)              = 0.0_r8
+    rcwp_out(:iend)              = 0.0_r8
+    rlwp_out(:iend)              = 0.0_r8
+    riwp_out(:iend)              = 0.0_r8
+
+    wu_out(:iend,0:mkx)          = 0.0_r8
+    qtu_out(:iend,0:mkx)         = 0.0_r8
+    thlu_out(:iend,0:mkx)        = 0.0_r8
+    thvu_out(:iend,0:mkx)        = 0.0_r8
+    uu_out(:iend,0:mkx)          = 0.0_r8
+    vu_out(:iend,0:mkx)          = 0.0_r8
+    qtu_emf_out(:iend,0:mkx)     = 0.0_r8
+    thlu_emf_out(:iend,0:mkx)    = 0.0_r8
+    uu_emf_out(:iend,0:mkx)      = 0.0_r8
+    vu_emf_out(:iend,0:mkx)      = 0.0_r8
+    uemf_out(:iend,0:mkx)        = 0.0_r8
+
+    tru_out(:iend,0:mkx,:ncnst)     = 0.0_r8
+    tru_emf_out(:iend,0:mkx,:ncnst) = 0.0_r8
+
+    dwten_out(:iend,:mkx)        = 0.0_r8
+    diten_out(:iend,:mkx)        = 0.0_r8
+    flxrain_out(:iend,0:mkx)     = 0.0_r8  
+    flxsnow_out(:iend,0:mkx)     = 0.0_r8
+    ntraprd_out(:iend,mkx)       = 0.0_r8
+    ntsnprd_out(:iend,mkx)       = 0.0_r8
+
+    excessu_arr_out(:iend,:mkx)  = 0.0_r8
+    excess0_arr_out(:iend,:mkx)  = 0.0_r8
+    xc_arr_out(:iend,:mkx)       = 0.0_r8
+    aquad_arr_out(:iend,:mkx)    = 0.0_r8
+    bquad_arr_out(:iend,:mkx)    = 0.0_r8
+    cquad_arr_out(:iend,:mkx)    = 0.0_r8
+    bogbot_arr_out(:iend,:mkx)   = 0.0_r8
+    bogtop_arr_out(:iend,:mkx)   = 0.0_r8
+
+    exit_UWCu(:iend)             = 0.0_r8 
+    exit_conden(:iend)           = 0.0_r8 
+    exit_klclmkx(:iend)          = 0.0_r8 
+    exit_klfcmkx(:iend)          = 0.0_r8 
+    exit_ufrc(:iend)             = 0.0_r8 
+    exit_wtw(:iend)              = 0.0_r8 
+    exit_drycore(:iend)          = 0.0_r8 
+    exit_wu(:iend)               = 0.0_r8 
+    exit_cufilter(:iend)         = 0.0_r8 
+    exit_kinv1(:iend)            = 0.0_r8 
+    exit_rei(:iend)              = 0.0_r8 
+
+    limit_shcu(:iend)            = 0.0_r8 
+    limit_negcon(:iend)          = 0.0_r8 
+    limit_ufrc(:iend)            = 0.0_r8
+    limit_ppen(:iend)            = 0.0_r8
+    limit_emf(:iend)             = 0.0_r8
+    limit_cinlcl(:iend)          = 0.0_r8
+    limit_cin(:iend)             = 0.0_r8
+    limit_cbmf(:iend)            = 0.0_r8
+    limit_rei(:iend)             = 0.0_r8
+
+    ind_delcin(:iend)            = 0.0_r8
+
+    !--------------------------------------------------------------!
+    !                                                              !
+    ! Start the column i loop where i is a horozontal column index !
+    !                                                              !
+    !--------------------------------------------------------------!
+
+    ! Compute wet-bulb temperature and specific humidity
+    ! for treating evaporation of precipitation.
+
+    call findsp( lchnk, iend, qv0_in, t0_in, p0_in, tw0_in, qw0_in )
+
+    do i = 1, iend                                      
+
+      id_exit = .false.
+
+      ! -------------------------------------------- !
+      ! Define 1D input variables at each grid point !
+      ! -------------------------------------------- !
+
+      ps0(0:mkx)       = ps0_in(i,0:mkx)
+      zs0(0:mkx)       = zs0_in(i,0:mkx)
+      p0(:mkx)         = p0_in(i,:mkx)
+      z0(:mkx)         = z0_in(i,:mkx)
+      dp0(:mkx)        = dp0_in(i,:mkx)
+      dpdry0(:mkx)     = dpdry0_in(i,:mkx)
+      u0(:mkx)         = u0_in(i,:mkx)
+      v0(:mkx)         = v0_in(i,:mkx)
+      qv0(:mkx)        = qv0_in(i,:mkx)
+      ql0(:mkx)        = ql0_in(i,:mkx)
+      qi0(:mkx)        = qi0_in(i,:mkx)
+      t0(:mkx)         = t0_in(i,:mkx)
+      s0(:mkx)         = s0_in(i,:mkx)
+      tke(0:mkx)       = tke_in(i,0:mkx)
+      cldfrct(:mkx)    = cldfrct_in(i,:mkx)
+      concldfrct(:mkx) = concldfrct_in(i,:mkx)
+      pblh             = pblh_in(i)
+      cush             = cush_inout(i)
+      do m = 1, ncnst
+         tr0(:mkx,m)   = tr0_in(i,:mkx,m)
+      enddo
+
+      ! --------------------------------------------------------- !
+      ! Compute other basic thermodynamic variables directly from ! 
+      ! the input variables at each grid point                    !
+      ! --------------------------------------------------------- !
+
+      !----- 1. Compute internal environmental variables
+      
+      exn0(:mkx)   = (p0(:mkx)/p00)**rovcp
+      exns0(0:mkx) = (ps0(0:mkx)/p00)**rovcp
+      qt0(:mkx)    = (qv0(:mkx) + ql0(:mkx) + qi0(:mkx))
+      thl0(:mkx)   = (t0(:mkx) - xlv*ql0(:mkx)/cp - xls*qi0(:mkx)/cp)/exn0(:mkx)
+      thvl0(:mkx)  = (1._r8 + zvir*qt0(:mkx))*thl0(:mkx)
+
+      !----- 2. Compute slopes of environmental variables in each layer
+      !         Dimension of ssthl0(:mkx) is implicit.
+
+      ssthl0       = slope(mkx,thl0,p0) 
+      ssqt0        = slope(mkx,qt0 ,p0)
+      ssu0         = slope(mkx,u0  ,p0)
+      ssv0         = slope(mkx,v0  ,p0)
+      do m = 1, ncnst
+         sstr0(:mkx,m) = slope(mkx,tr0(:mkx,m),p0)
+      enddo     
+ 
+      !----- 3. Compute "thv0" and "thvl0" at the top/bottom interfaces in each layer
+      !         There are computed from the reconstructed thl, qt at the top/bottom.
+
+      do k = 1, mkx
+
+         thl0bot = thl0(k) + ssthl0(k)*(ps0(k-1) - p0(k))
+         qt0bot  = qt0(k)  + ssqt0(k) *(ps0(k-1) - p0(k))
+         call conden(ps0(k-1),thl0bot,qt0bot,thj,qvj,qlj,qij,qse,id_check,qsat)
+         if( id_check .eq. 1 ) then
+             exit_conden(i) = 1._r8
+             id_exit = .true.
+             go to 333
+         end if
+         thv0bot(k)  = thj*(1._r8 + zvir*qvj - qlj - qij)
+         thvl0bot(k) = thl0bot*(1._r8 + zvir*qt0bot)
+          
+         thl0top = thl0(k) + ssthl0(k)*(ps0(k) - p0(k))
+         qt0top  =  qt0(k) + ssqt0(k) *(ps0(k) - p0(k))
+         call conden(ps0(k),thl0top,qt0top,thj,qvj,qlj,qij,qse,id_check,qsat)
+         if( id_check .eq. 1 ) then
+             exit_conden(i) = 1._r8
+             id_exit = .true.
+             go to 333
+         end if 
+         thv0top(k)  = thj*(1._r8 + zvir*qvj - qlj - qij)
+         thvl0top(k) = thl0top*(1._r8 + zvir*qt0top)
+
+      end do
+
+      ! ------------------------------------------------------------ !
+      ! Save input and related environmental thermodynamic variables !
+      ! for use at "iter_cin=2" when "del_CIN >= 0"                  !
+      ! ------------------------------------------------------------ !
+
+      qv0_o(:mkx)          = qv0(:mkx)
+      ql0_o(:mkx)          = ql0(:mkx)
+      qi0_o(:mkx)          = qi0(:mkx)
+      t0_o(:mkx)           = t0(:mkx)
+      s0_o(:mkx)           = s0(:mkx)
+      u0_o(:mkx)           = u0(:mkx)
+      v0_o(:mkx)           = v0(:mkx)
+      qt0_o(:mkx)          = qt0(:mkx)
+      thl0_o(:mkx)         = thl0(:mkx)
+      thvl0_o(:mkx)        = thvl0(:mkx)
+      ssthl0_o(:mkx)       = ssthl0(:mkx)
+      ssqt0_o(:mkx)        = ssqt0(:mkx)
+      thv0bot_o(:mkx)      = thv0bot(:mkx)
+      thv0top_o(:mkx)      = thv0top(:mkx)
+      thvl0bot_o(:mkx)     = thvl0bot(:mkx)
+      thvl0top_o(:mkx)     = thvl0top(:mkx)
+      ssu0_o(:mkx)         = ssu0(:mkx) 
+      ssv0_o(:mkx)         = ssv0(:mkx) 
+      do m = 1, ncnst
+         tr0_o(:mkx,m)     = tr0(:mkx,m)
+         sstr0_o(:mkx,m)   = sstr0(:mkx,m)
+      enddo 
+
+      ! ---------------------------------------------- !
+      ! Initialize output variables at each grid point !
+      ! ---------------------------------------------- !
+
+      umf(0:mkx)          = 0.0_r8
+      emf(0:mkx)          = 0.0_r8
+      slflx(0:mkx)        = 0.0_r8
+      qtflx(0:mkx)        = 0.0_r8
+      uflx(0:mkx)         = 0.0_r8
+      vflx(0:mkx)         = 0.0_r8
+      qvten(:mkx)         = 0.0_r8
+      qlten(:mkx)         = 0.0_r8
+      qiten(:mkx)         = 0.0_r8
+      sten(:mkx)          = 0.0_r8
+      uten(:mkx)          = 0.0_r8
+      vten(:mkx)          = 0.0_r8
+      qrten(:mkx)         = 0.0_r8
+      qsten(:mkx)         = 0.0_r8
+      dwten(:mkx)         = 0.0_r8
+      diten(:mkx)         = 0.0_r8
+      precip              = 0.0_r8
+      snow                = 0.0_r8
+      evapc(:mkx)         = 0.0_r8
+      cufrc(:mkx)         = 0.0_r8
+      qcu(:mkx)           = 0.0_r8
+      qlu(:mkx)           = 0.0_r8
+      qiu(:mkx)           = 0.0_r8
+      fer(:mkx)           = 0.0_r8
+      fdr(:mkx)           = 0.0_r8
+      cin                 = 0.0_r8
+      cbmf                = 0.0_r8
+      qc(:mkx)            = 0.0_r8
+      qc_l(:mkx)          = 0.0_r8
+      qc_i(:mkx)          = 0.0_r8
+      rliq                = 0.0_r8
+      cnt                 = real(mkx, r8)
+      cnb                 = 0.0_r8
+      qtten(:mkx)         = 0.0_r8
+      slten(:mkx)         = 0.0_r8   
+      ufrc(0:mkx)         = 0.0_r8  
+
+      thlu(0:mkx)         = 0.0_r8
+      qtu(0:mkx)          = 0.0_r8
+      uu(0:mkx)           = 0.0_r8
+      vu(0:mkx)           = 0.0_r8
+      wu(0:mkx)           = 0.0_r8
+      thvu(0:mkx)         = 0.0_r8
+      thlu_emf(0:mkx)     = 0.0_r8
+      qtu_emf(0:mkx)      = 0.0_r8
+      uu_emf(0:mkx)       = 0.0_r8
+      vu_emf(0:mkx)       = 0.0_r8
+      
+      ufrcinvbase         = 0.0_r8
+      ufrclcl             = 0.0_r8
+      winvbase            = 0.0_r8
+      wlcl                = 0.0_r8
+      emfkbup             = 0.0_r8 
+      cbmflimit           = 0.0_r8
+      excessu_arr(:mkx)   = 0.0_r8
+      excess0_arr(:mkx)   = 0.0_r8
+      xc_arr(:mkx)        = 0.0_r8
+      aquad_arr(:mkx)     = 0.0_r8
+      bquad_arr(:mkx)     = 0.0_r8
+      cquad_arr(:mkx)     = 0.0_r8
+      bogbot_arr(:mkx)    = 0.0_r8
+      bogtop_arr(:mkx)    = 0.0_r8
+
+      uemf(0:mkx)         = 0.0_r8
+      comsub(:mkx)        = 0.0_r8
+      qlten_sink(:mkx)    = 0.0_r8
+      qiten_sink(:mkx)    = 0.0_r8 
+      nlten_sink(:mkx)    = 0.0_r8
+      niten_sink(:mkx)    = 0.0_r8 
+
+      do m = 1, ncnst
+         trflx(0:mkx,m)   = 0.0_r8
+         trten(:mkx,m)    = 0.0_r8
+         tru(0:mkx,m)     = 0.0_r8
+         tru_emf(0:mkx,m) = 0.0_r8
+      enddo
+
+    !-----------------------------------------------! 
+    ! Below 'iter' loop is for implicit CIN closure !
+    !-----------------------------------------------!
+
+    ! ----------------------------------------------------------------------------- ! 
+    ! It is important to note that this iterative cin loop is located at the outest !
+    ! shell of the code. Thus, source air properties can also be changed during the !
+    ! iterative cin calculation, because cumulus convection induces non-zero fluxes !
+    ! even at interfaces below PBL top height through 'fluxbelowinv' subroutine.    !
+    ! ----------------------------------------------------------------------------- !
+
+    do iter = 1, iter_cin
+
+       ! ---------------------------------------------------------------------- ! 
+       ! Cumulus scale height                                                   ! 
+       ! In contrast to the premitive code, cumulus scale height is iteratively !
+       ! calculated at each time step, and at each iterative cin step.          !
+       ! It is not clear whether I should locate below two lines within or  out !
+       ! of the iterative cin loop.                                             !
+       ! ---------------------------------------------------------------------- !
+
+       tscaleh = cush                        
+       cush    = -1._r8
+
+       ! ----------------------------------------------------------------------- !
+       ! Find PBL top height interface index, 'kinv-1' where 'kinv' is the layer !
+       ! index with PBLH in it. When PBLH is exactly at interface, 'kinv' is the !
+       ! layer index having PBLH as a lower interface.                           !
+       ! In the previous code, I set the lower limit of 'kinv' by 2  in order to !
+       ! be consistent with the other parts of the code. However in the modified !
+       ! code, I allowed 'kinv' to be 1 & if 'kinv = 1', I just exit the program !
+       ! without performing cumulus convection. This new approach seems to be    !
+       ! more reasonable: if PBL height is within 'kinv=1' layer, surface is STL !
+       ! interface (bflxs <= 0) and interface just above the surface should be   !
+       ! either non-turbulent (Ri>0.19) or stably turbulent (0<=Ri<0.19 but this !
+       ! interface is identified as a base external interface of upperlying CL.  !
+       ! Thus, when 'kinv=1', PBL scheme guarantees 'bflxs <= 0'.  For this case !
+       ! it is reasonable to assume that cumulus convection does not happen.     !
+       ! When these is SBCL, PBL height from the PBL scheme is likely to be very !
+       ! close at 'kinv-1' interface, but not exactly, since 'zi' information is !
+       ! changed between two model time steps. In order to ensure correct identi !
+       ! fication of 'kinv' for general case including SBCL, I imposed an offset !
+       ! of 5 [m] in the below 'kinv' finding block.                             !
+       ! ----------------------------------------------------------------------- !
+       
+       do k = mkx - 1, 1, -1 
+          if( (pblh + 5._r8 - zs0(k))*(pblh + 5._r8 - zs0(k+1)) .lt. 0._r8 ) then
+               kinv = k + 1 
+               go to 15
+          endif 
+       end do
+       kinv = 1
+15     continue    
+
+       if( kinv .le. 1 ) then          
+           exit_kinv1(i) = 1._r8
+           id_exit = .true.
+           go to 333
+       endif
+       ! From here, it must be 'kinv >= 2'.
+
+       ! -------------------------------------------------------------------------- !
+       ! Find PBL averaged tke ('tkeavg') and minimum 'thvl' ('thvlmin') in the PBL !
+       ! In the current code, 'tkeavg' is obtained by averaging all interfacial TKE !
+       ! within the PBL. However, in order to be conceptually consistent with   PBL !
+       ! scheme, 'tkeavg' should be calculated by considering surface buoyancy flux.!
+       ! If surface buoyancy flux is positive ( bflxs >0 ), surface interfacial TKE !
+       ! should be included in calculating 'tkeavg', while if bflxs <= 0,   surface !
+       ! interfacial TKE should not be included in calculating 'tkeavg'.   I should !
+       ! modify the code when 'bflxs' is available as an input of cumulus scheme.   !
+       ! 'thvlmin' is a minimum 'thvl' within PBL obtained by comparing top &  base !
+       ! interface values of 'thvl' in each layers within the PBL.                  !
+       ! -------------------------------------------------------------------------- !
+       
+       dpsum    = 0._r8
+       tkeavg   = 0._r8
+       thvlmin  = 1000._r8
+       do k = 0, kinv - 1   ! Here, 'k' is an interfacial layer index.  
+          if( k .eq. 0 ) then
+              dpi = ps0(0) - p0(1)
+          elseif( k .eq. (kinv-1) ) then 
+              dpi = p0(kinv-1) - ps0(kinv-1)
+          else
+              dpi = p0(k) - p0(k+1)
+          endif 
+          dpsum  = dpsum  + dpi  
+          tkeavg = tkeavg + dpi*tke(k) 
+          if( k .ne. 0 ) thvlmin = min(thvlmin,min(thvl0bot(k),thvl0top(k)))
+       end do
+       tkeavg  = tkeavg/dpsum
+
+       ! ------------------------------------------------------------------ !
+       ! Find characteristics of cumulus source air: qtsrc,thlsrc,usrc,vsrc !
+       ! Note that 'thlsrc' was con-cocked using 'thvlsrc' and 'qtsrc'.     !
+       ! 'qtsrc' is defined as the lowest layer mid-point value;   'thlsrc' !
+       ! is from 'qtsrc' and 'thvlmin=thvlsrc'; 'usrc' & 'vsrc' are defined !
+       ! as the values just below the PBL top interface.                    !
+       ! ------------------------------------------------------------------ !
+
+       qtsrc   = qt0(1)                     
+       thvlsrc = thvlmin 
+       thlsrc  = thvlsrc / ( 1._r8 + zvir * qtsrc )  
+       usrc    = u0(kinv-1) + ssu0(kinv-1) * ( ps0(kinv-1) - p0(kinv-1) )             
+       vsrc    = v0(kinv-1) + ssv0(kinv-1) * ( ps0(kinv-1) - p0(kinv-1) )             
+       do m = 1, ncnst
+          trsrc(m) = tr0(1,m)
+       enddo 
+
+       ! ------------------------------------------------------------------ !
+       ! Find LCL of the source air and a layer index containing LCL (klcl) !
+       ! When the LCL is exactly at the interface, 'klcl' is a layer index  ! 
+       ! having 'plcl' as the lower interface similar to the 'kinv' case.   !
+       ! In the previous code, I assumed that if LCL is located within the  !
+       ! lowest model layer ( 1 ) or the top model layer ( mkx ), then  no  !
+       ! convective adjustment is performed and just exited.   However, in  !
+       ! the revised code, I relaxed the first constraint and  even though  !
+       ! LCL is at the lowest model layer, I allowed cumulus convection to  !
+       ! be initiated. For this case, cumulus convection should be started  !
+       ! from the PBL top height, as shown in the following code.           !
+       ! When source air is already saturated even at the surface, klcl is  !
+       ! set to 1.                                                          !
+       ! ------------------------------------------------------------------ !
+
+       plcl = qsinvert(qtsrc,thlsrc,ps0(0),qsat)
+       do k = 0, mkx
+          if( ps0(k) .lt. plcl ) then
+              klcl = k
+              go to 25
+          endif           
+       end do
+       klcl = mkx
+25     continue
+       klcl = max(1,klcl)
+     
+       if( plcl .lt. 30000._r8 ) then               
+     ! if( klcl .eq. mkx ) then          
+           exit_klclmkx(i) = 1._r8
+           id_exit = .true.
+           go to 333
+       endif
+
+       ! ------------------------------------------------------------- !
+       ! Calculate environmental virtual potential temperature at LCL, !
+       !'thv0lcl' which is solely used in the 'cin' calculation. Note  !
+       ! that 'thv0lcl' is calculated first by calculating  'thl0lcl'  !
+       ! and 'qt0lcl' at the LCL, and performing 'conden' afterward,   !
+       ! in fully consistent with the other parts of the code.         !
+       ! ------------------------------------------------------------- !
+
+       thl0lcl = thl0(klcl) + ssthl0(klcl) * ( plcl - p0(klcl) )
+       qt0lcl  = qt0(klcl)  + ssqt0(klcl)  * ( plcl - p0(klcl) )
+       call conden(plcl,thl0lcl,qt0lcl,thj,qvj,qlj,qij,qse,id_check,qsat)
+       if( id_check .eq. 1 ) then
+           exit_conden(i) = 1._r8
+           id_exit = .true.
+           go to 333
+       end if
+       thv0lcl = thj * ( 1._r8 + zvir * qvj - qlj - qij )
+
+       ! ------------------------------------------------------------------------ !
+       ! Compute Convective Inhibition, 'cin' & 'cinlcl' [J/kg]=[m2/s2] TKE unit. !
+       !                                                                          !
+       ! 'cin' (cinlcl) is computed from the PBL top interface to LFC (LCL) using ! 
+       ! piecewisely reconstructed environmental profiles, assuming environmental !
+       ! buoyancy profile within each layer ( or from LCL to upper interface in   !
+       ! each layer ) is simply a linear profile. For the purpose of cin (cinlcl) !
+       ! calculation, we simply assume that lateral entrainment does not occur in !
+       ! updrafting cumulus plume, i.e., cumulus source air property is conserved.!
+       ! Below explains some rules used in the calculations of cin (cinlcl).   In !
+       ! general, both 'cin' and 'cinlcl' are calculated from a PBL top interface !
+       ! to LCL and LFC, respectively :                                           !
+       ! 1. If LCL is lower than the PBL height, cinlcl = 0 and cin is calculated !
+       !    from PBL height to LFC.                                               !
+       ! 2. If LCL is higher than PBL height,   'cinlcl' is calculated by summing !
+       !    both positive and negative cloud buoyancy up to LCL using 'single_cin'!
+       !    From the LCL to LFC, however, only negative cloud buoyancy is counted !
+       !    to calculate final 'cin' upto LFC.                                    !
+       ! 3. If either 'cin' or 'cinlcl' is negative, they are set to be zero.     !
+       ! In the below code, 'klfc' is the layer index containing 'LFC' similar to !
+       ! 'kinv' and 'klcl'.                                                       !
+       ! ------------------------------------------------------------------------ !
+
+        cin    = 0._r8
+        cinlcl = 0._r8
+        plfc   = 0._r8
+        klfc   = mkx
+
+        ! ------------------------------------------------------------------------- !
+        ! Case 1. LCL height is higher than PBL interface ( 'pLCL <= ps0(kinv-1)' ) !
+        ! ------------------------------------------------------------------------- !
+
+        if( klcl .ge. kinv ) then
+
+            do k = kinv, mkx - 1
+               if( k .lt. klcl ) then
+                   thvubot = thvlsrc
+                   thvutop = thvlsrc  
+                   cin     = cin + single_cin(ps0(k-1),thv0bot(k),ps0(k),thv0top(k),thvubot,thvutop)
+               elseif( k .eq. klcl ) then
+                   !----- Bottom to LCL
+                   thvubot = thvlsrc
+                   thvutop = thvlsrc
+                   cin     = cin + single_cin(ps0(k-1),thv0bot(k),plcl,thv0lcl,thvubot,thvutop)
+                   if( cin .lt. 0._r8 ) limit_cinlcl(i) = 1._r8
+                   cinlcl  = max(cin,0._r8)
+                   cin     = cinlcl
+                   !----- LCL to Top
+                   thvubot = thvlsrc
+                   call conden(ps0(k),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check,qsat)
+                   if( id_check .eq. 1 ) then
+                       exit_conden(i) = 1._r8
+                       id_exit = .true.
+                       go to 333
+                   end if
+                   thvutop = thj * ( 1._r8 + zvir*qvj - qlj - qij )
+                   call getbuoy(plcl,thv0lcl,ps0(k),thv0top(k),thvubot,thvutop,plfc,cin)
+                   if( plfc .gt. 0._r8 ) then 
+                       klfc = k 
+                       go to 35
+                   end if
+               else
+                   thvubot = thvutop
+                   call conden(ps0(k),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check,qsat)
+                   if( id_check .eq. 1 ) then
+                       exit_conden(i) = 1._r8
+                       id_exit = .true.
+                       go to 333
+                   end if
+                   thvutop = thj * ( 1._r8 + zvir*qvj - qlj - qij )
+                   call getbuoy(ps0(k-1),thv0bot(k),ps0(k),thv0top(k),thvubot,thvutop,plfc,cin)
+                   if( plfc .gt. 0._r8 ) then 
+                       klfc = k
+                       go to 35
+                   end if 
+               endif
+            end do        
+
+       ! ----------------------------------------------------------------------- !
+       ! Case 2. LCL height is lower than PBL interface ( 'pLCL > ps0(kinv-1)' ) !
+       ! ----------------------------------------------------------------------- !
+
+       else
+          cinlcl = 0._r8 
+          do k = kinv, mkx - 1
+             call conden(ps0(k-1),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check,qsat)
+             if( id_check .eq. 1 ) then
+                 exit_conden(i) = 1._r8
+                 id_exit = .true.
+                 go to 333
+             end if
+             thvubot = thj * ( 1._r8 + zvir*qvj - qlj - qij )
+             call conden(ps0(k),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check,qsat)
+             if( id_check .eq. 1 ) then
+                 exit_conden(i) = 1._r8
+                 id_exit = .true.
+                 go to 333
+             end if
+             thvutop = thj * ( 1._r8 + zvir*qvj - qlj - qij )
+             call getbuoy(ps0(k-1),thv0bot(k),ps0(k),thv0top(k),thvubot,thvutop,plfc,cin)
+             if( plfc .gt. 0._r8 ) then 
+                 klfc = k
+                 go to 35
+             end if 
+          end do
+       endif  ! End of CIN case selection
+
+ 35    continue
+       if( cin .lt. 0._r8 ) limit_cin(i) = 1._r8
+       cin = max(0._r8,cin)
+       if( klfc .ge. mkx ) then
+           klfc = mkx
+         ! write(iulog,*) 'klfc >= mkx'
+           exit_klfcmkx(i) = 1._r8
+           id_exit = .true.
+           go to 333
+       endif
+
+       ! ---------------------------------------------------------------------- !
+       ! In order to calculate implicit 'cin' (or 'cinlcl'), save the initially !
+       ! calculated 'cin' and 'cinlcl', and other related variables. These will !
+       ! be restored after calculating implicit CIN.                            !
+       ! ---------------------------------------------------------------------- !
+
+       if( iter .eq. 1 ) then 
+           cin_i       = cin
+           cinlcl_i    = cinlcl
+           ke          = rbuoy / ( rkfre * tkeavg + epsvarw ) 
+           kinv_o      = kinv     
+           klcl_o      = klcl     
+           klfc_o      = klfc    
+           plcl_o      = plcl    
+           plfc_o      = plfc     
+           tkeavg_o    = tkeavg   
+           thvlmin_o   = thvlmin
+           qtsrc_o     = qtsrc    
+           thvlsrc_o   = thvlsrc  
+           thlsrc_o    = thlsrc
+           usrc_o      = usrc     
+           vsrc_o      = vsrc     
+           thv0lcl_o   = thv0lcl  
+           do m = 1, ncnst
+              trsrc_o(m) = trsrc(m)
+           enddo
+       endif   
+
+     ! Modification : If I impose w = max(0.1_r8, w) up to the top interface of
+     !                klfc, I should only use cinlfc.  That is, if I want to
+     !                use cinlcl, I should not impose w = max(0.1_r8, w).
+     !                Using cinlcl is equivalent to treating only 'saturated'
+     !                moist convection. Note that in this sense, I should keep
+     !                the functionality of both cinlfc and cinlcl.
+     !                However, the treatment of penetrative entrainment level becomes
+     !                ambiguous if I choose 'cinlcl'. Thus, the best option is to use
+     !                'cinlfc'.
+
+       ! -------------------------------------------------------------------------- !
+       ! Calculate implicit 'cin' by averaging initial and final cins.    Note that !
+       ! implicit CIN is adopted only when cumulus convection stabilized the system,!
+       ! i.e., only when 'del_CIN >0'. If 'del_CIN<=0', just use explicit CIN. Note !
+       ! also that since 'cinlcl' is set to zero whenever LCL is below the PBL top, !
+       ! (see above CIN calculation part), the use of 'implicit CIN=cinlcl'  is not !
+       ! good. Thus, when using implicit CIN, always try to only use 'implicit CIN= !
+       ! cin', not 'implicit CIN=cinlcl'. However, both 'CIN=cin' and 'CIN=cinlcl'  !
+       ! are good when using explicit CIN.                                          !
+       ! -------------------------------------------------------------------------- !
+
+       if( iter .ne. 1 ) then
+
+           cin_f = cin
+           cinlcl_f = cinlcl
+           if( use_CINcin ) then
+               del_CIN = cin_f - cin_i
+           else
+               del_CIN = cinlcl_f - cinlcl_i
+           endif
+
+           if( del_CIN .gt. 0._r8 ) then
+
+               ! -------------------------------------------------------------- ! 
+               ! Calculate implicit 'cin' and 'cinlcl'. Note that when we chose !
+               ! to use 'implicit CIN = cin', choose 'cinlcl = cinlcl_i' below: !
+               ! because iterative CIN only aims to obtain implicit CIN,  once  !
+               ! we obtained 'implicit CIN=cin', it is good to use the original !
+               ! profiles information for all the other variables after that.   !
+               ! Note 'cinlcl' will be explicitly used in calculating  'wlcl' & !
+               ! 'ufrclcl' after calculating 'winv' & 'ufrcinv'  at the PBL top !
+               ! interface later, after calculating 'cbmf'.                     !
+               ! -------------------------------------------------------------- !
+         
+               alpha = compute_alpha( del_CIN, ke ) 
+               cin   = cin_i + alpha * del_CIN
+               if( use_CINcin ) then
+                   cinlcl = cinlcl_i                 
+               else
+                   cinlcl = cinlcl_i + alpha * del_cinlcl   
+               endif
+
+               ! ----------------------------------------------------------------- !
+               ! Restore the original values from the previous 'iter_cin' step (1) !
+               ! to compute correct tendencies for (n+1) time step by implicit CIN !
+               ! ----------------------------------------------------------------- !
+
+               kinv      = kinv_o     
+               klcl      = klcl_o     
+               klfc      = klfc_o    
+               plcl      = plcl_o    
+               plfc      = plfc_o     
+               tkeavg    = tkeavg_o   
+               thvlmin   = thvlmin_o
+               qtsrc     = qtsrc_o    
+               thvlsrc   = thvlsrc_o  
+               thlsrc    = thlsrc_o
+               usrc      = usrc_o     
+               vsrc      = vsrc_o     
+               thv0lcl   = thv0lcl_o  
+               do m = 1, ncnst
+                  trsrc(m) = trsrc_o(m)
+               enddo
+
+               qv0(:mkx)            = qv0_o(:mkx)
+               ql0(:mkx)            = ql0_o(:mkx)
+               qi0(:mkx)            = qi0_o(:mkx)
+               t0(:mkx)             = t0_o(:mkx)
+               s0(:mkx)             = s0_o(:mkx)
+               u0(:mkx)             = u0_o(:mkx)
+               v0(:mkx)             = v0_o(:mkx)
+               qt0(:mkx)            = qt0_o(:mkx)
+               thl0(:mkx)           = thl0_o(:mkx)
+               thvl0(:mkx)          = thvl0_o(:mkx)
+               ssthl0(:mkx)         = ssthl0_o(:mkx)
+               ssqt0(:mkx)          = ssqt0_o(:mkx)
+               thv0bot(:mkx)        = thv0bot_o(:mkx)
+               thv0top(:mkx)        = thv0top_o(:mkx)
+               thvl0bot(:mkx)       = thvl0bot_o(:mkx)
+               thvl0top(:mkx)       = thvl0top_o(:mkx)
+               ssu0(:mkx)           = ssu0_o(:mkx) 
+               ssv0(:mkx)           = ssv0_o(:mkx) 
+               do m = 1, ncnst
+                  tr0(:mkx,m)   = tr0_o(:mkx,m)
+                  sstr0(:mkx,m) = sstr0_o(:mkx,m)
+               enddo
+
+               ! ------------------------------------------------------ !
+               ! Initialize all fluxes, tendencies, and other variables ! 
+               ! in association with cumulus convection.                !
+               ! ------------------------------------------------------ ! 
+
+               umf(0:mkx)          = 0.0_r8
+               emf(0:mkx)          = 0.0_r8
+               slflx(0:mkx)        = 0.0_r8
+               qtflx(0:mkx)        = 0.0_r8
+               uflx(0:mkx)         = 0.0_r8
+               vflx(0:mkx)         = 0.0_r8
+               qvten(:mkx)         = 0.0_r8
+               qlten(:mkx)         = 0.0_r8
+               qiten(:mkx)         = 0.0_r8
+               sten(:mkx)          = 0.0_r8
+               uten(:mkx)          = 0.0_r8
+               vten(:mkx)          = 0.0_r8
+               qrten(:mkx)         = 0.0_r8
+               qsten(:mkx)         = 0.0_r8
+               dwten(:mkx)         = 0.0_r8
+               diten(:mkx)         = 0.0_r8
+               precip              = 0.0_r8
+               snow                = 0.0_r8
+               evapc(:mkx)         = 0.0_r8
+               cufrc(:mkx)         = 0.0_r8
+               qcu(:mkx)           = 0.0_r8
+               qlu(:mkx)           = 0.0_r8
+               qiu(:mkx)           = 0.0_r8
+               fer(:mkx)           = 0.0_r8
+               fdr(:mkx)           = 0.0_r8
+               qc(:mkx)            = 0.0_r8
+               qc_l(:mkx)          = 0.0_r8
+               qc_i(:mkx)          = 0.0_r8
+               rliq                = 0.0_r8
+               cbmf                = 0.0_r8
+               cnt                 = real(mkx, r8)
+               cnb                 = 0.0_r8
+               qtten(:mkx)         = 0.0_r8
+               slten(:mkx)         = 0.0_r8
+               ufrc(0:mkx)         = 0.0_r8
+
+               thlu(0:mkx)         = 0.0_r8
+               qtu(0:mkx)          = 0.0_r8
+               uu(0:mkx)           = 0.0_r8
+               vu(0:mkx)           = 0.0_r8
+               wu(0:mkx)           = 0.0_r8
+               thvu(0:mkx)         = 0.0_r8
+               thlu_emf(0:mkx)     = 0.0_r8
+               qtu_emf(0:mkx)      = 0.0_r8
+               uu_emf(0:mkx)       = 0.0_r8
+               vu_emf(0:mkx)       = 0.0_r8
+             
+               do m = 1, ncnst
+                  trflx(0:mkx,m)   = 0.0_r8
+                  trten(:mkx,m)    = 0.0_r8
+                  tru(0:mkx,m)     = 0.0_r8
+                  tru_emf(0:mkx,m) = 0.0_r8
+               enddo
+
+               ! -------------------------------------------------- !
+               ! Below are diagnostic output variables for detailed !
+               ! analysis of cumulus scheme.                        !
+               ! -------------------------------------------------- ! 
+
+               ufrcinvbase         = 0.0_r8
+               ufrclcl             = 0.0_r8
+               winvbase            = 0.0_r8
+               wlcl                = 0.0_r8
+               emfkbup             = 0.0_r8 
+               cbmflimit           = 0.0_r8
+               excessu_arr(:mkx)   = 0.0_r8
+               excess0_arr(:mkx)   = 0.0_r8
+               xc_arr(:mkx)        = 0.0_r8
+               aquad_arr(:mkx)     = 0.0_r8
+               bquad_arr(:mkx)     = 0.0_r8
+               cquad_arr(:mkx)     = 0.0_r8
+               bogbot_arr(:mkx)    = 0.0_r8
+               bogtop_arr(:mkx)    = 0.0_r8
+
+          else ! When 'del_CIN < 0', use explicit CIN instead of implicit CIN.
+           
+               ! ----------------------------------------------------------- ! 
+               ! Identifier showing whether explicit or implicit CIN is used !
+               ! ----------------------------------------------------------- ! 
+
+               ind_delcin(i) = 1._r8             
+   
+               ! --------------------------------------------------------- !
+               ! Restore original output values of "iter_cin = 1" and exit !
+               ! --------------------------------------------------------- !
+
+               umf_out(i,0:mkx)         = umf_s(0:mkx)
+               qvten_out(i,:mkx)        = qvten_s(:mkx)
+               qlten_out(i,:mkx)        = qlten_s(:mkx)  
+               qiten_out(i,:mkx)        = qiten_s(:mkx)
+               sten_out(i,:mkx)         = sten_s(:mkx)
+               uten_out(i,:mkx)         = uten_s(:mkx)  
+               vten_out(i,:mkx)         = vten_s(:mkx)
+               qrten_out(i,:mkx)        = qrten_s(:mkx)
+               qsten_out(i,:mkx)        = qsten_s(:mkx)  
+               precip_out(i)            = precip_s
+               snow_out(i)              = snow_s
+               evapc_out(i,:mkx)        = evapc_s(:mkx)
+               cush_inout(i)            = cush_s
+               cufrc_out(i,:mkx)        = cufrc_s(:mkx)  
+               slflx_out(i,0:mkx)       = slflx_s(0:mkx)  
+               qtflx_out(i,0:mkx)       = qtflx_s(0:mkx)
+               qcu_out(i,:mkx)          = qcu_s(:mkx)    
+               qlu_out(i,:mkx)          = qlu_s(:mkx)  
+               qiu_out(i,:mkx)          = qiu_s(:mkx)  
+               cbmf_out(i)              = cbmf_s
+               qc_out(i,:mkx)           = qc_s(:mkx)  
+               rliq_out(i)              = rliq_s
+               cnt_out(i)               = cnt_s
+               cnb_out(i)               = cnb_s
+               do m = 1, ncnst
+                  trten_out(i,:mkx,m)   = trten_s(:mkx,m)
+               enddo  
+             
+               ! ------------------------------------------------------------------------------ ! 
+               ! Below are diagnostic output variables for detailed analysis of cumulus scheme. !
+               ! The order of vertical index is reversed for this internal diagnostic output.   !
+               ! ------------------------------------------------------------------------------ !   
+
+               fer_out(i,mkx:1:-1)      = fer_s(:mkx)  
+               fdr_out(i,mkx:1:-1)      = fdr_s(:mkx)  
+               cinh_out(i)              = cin_s
+               cinlclh_out(i)           = cinlcl_s
+               qtten_out(i,mkx:1:-1)    = qtten_s(:mkx)
+               slten_out(i,mkx:1:-1)    = slten_s(:mkx)
+               ufrc_out(i,mkx:0:-1)     = ufrc_s(0:mkx)
+               uflx_out(i,mkx:0:-1)     = uflx_s(0:mkx)  
+               vflx_out(i,mkx:0:-1)     = vflx_s(0:mkx)  
+
+               ufrcinvbase_out(i)       = ufrcinvbase_s
+               ufrclcl_out(i)           = ufrclcl_s 
+               winvbase_out(i)          = winvbase_s
+               wlcl_out(i)              = wlcl_s
+               plcl_out(i)              = plcl_s
+               pinv_out(i)              = pinv_s    
+               plfc_out(i)              = plfc_s    
+               pbup_out(i)              = pbup_s
+               ppen_out(i)              = ppen_s    
+               qtsrc_out(i)             = qtsrc_s
+               thlsrc_out(i)            = thlsrc_s
+               thvlsrc_out(i)           = thvlsrc_s
+               emfkbup_out(i)           = emfkbup_s
+               cbmflimit_out(i)         = cbmflimit_s
+               tkeavg_out(i)            = tkeavg_s
+               zinv_out(i)              = zinv_s
+               rcwp_out(i)              = rcwp_s
+               rlwp_out(i)              = rlwp_s
+               riwp_out(i)              = riwp_s
+
+               wu_out(i,mkx:0:-1)       = wu_s(0:mkx)
+               qtu_out(i,mkx:0:-1)      = qtu_s(0:mkx)
+               thlu_out(i,mkx:0:-1)     = thlu_s(0:mkx)
+               thvu_out(i,mkx:0:-1)     = thvu_s(0:mkx)
+               uu_out(i,mkx:0:-1)       = uu_s(0:mkx)
+               vu_out(i,mkx:0:-1)       = vu_s(0:mkx)
+               qtu_emf_out(i,mkx:0:-1)  = qtu_emf_s(0:mkx)
+               thlu_emf_out(i,mkx:0:-1) = thlu_emf_s(0:mkx)
+               uu_emf_out(i,mkx:0:-1)   = uu_emf_s(0:mkx)
+               vu_emf_out(i,mkx:0:-1)   = vu_emf_s(0:mkx)
+               uemf_out(i,mkx:0:-1)     = uemf_s(0:mkx)
+
+               dwten_out(i,mkx:1:-1)    = dwten_s(:mkx)
+               diten_out(i,mkx:1:-1)    = diten_s(:mkx)
+               flxrain_out(i,mkx:0:-1)  = flxrain_s(0:mkx)
+               flxsnow_out(i,mkx:0:-1)  = flxsnow_s(0:mkx)
+               ntraprd_out(i,mkx:1:-1)  = ntraprd_s(:mkx)
+               ntsnprd_out(i,mkx:1:-1)  = ntsnprd_s(:mkx)
+
+               excessu_arr_out(i,mkx:1:-1)  = excessu_arr_s(:mkx)
+               excess0_arr_out(i,mkx:1:-1)  = excess0_arr_s(:mkx)
+               xc_arr_out(i,mkx:1:-1)       = xc_arr_s(:mkx)
+               aquad_arr_out(i,mkx:1:-1)    = aquad_arr_s(:mkx)
+               bquad_arr_out(i,mkx:1:-1)    = bquad_arr_s(:mkx)
+               cquad_arr_out(i,mkx:1:-1)    = cquad_arr_s(:mkx)
+               bogbot_arr_out(i,mkx:1:-1)   = bogbot_arr_s(:mkx)
+               bogtop_arr_out(i,mkx:1:-1)   = bogtop_arr_s(:mkx)
+
+               do m = 1, ncnst
+                  trflx_out(i,mkx:0:-1,m)   = trflx_s(0:mkx,m)  
+                  tru_out(i,mkx:0:-1,m)     = tru_s(0:mkx,m)
+                  tru_emf_out(i,mkx:0:-1,m) = tru_emf_s(0:mkx,m)
+               enddo
+
+               id_exit = .false.
+               go to 333
+
+          endif
+
+       endif    
+
+       ! ------------------------------------------------------------------ !
+       ! Define a release level, 'prel' and release layer, 'krel'.          !
+       ! 'prel' is the lowest level from which buoyancy sorting occurs, and !
+       ! 'krel' is the layer index containing 'prel' in it, similar to  the !
+       ! previous definitions of 'kinv', 'klcl', and 'klfc'.    In order to !
+       ! ensure that only PBL scheme works within the PBL,  if LCL is below !
+       ! PBL top height, then 'krel = kinv', while if LCL is above  PBL top !
+       ! height, then 'krel = klcl'.   Note however that regardless of  the !
+       ! definition of 'krel', cumulus convection induces fluxes within PBL !
+       ! through 'fluxbelowinv'.  We can make cumulus convection start from !
+       ! any level, even within the PBL by appropriately defining 'krel'  & !
+       ! 'prel' here. Then it must be accompanied by appropriate definition !
+       ! of source air properties, CIN, and re-setting of 'fluxbelowinv', & !
+       ! many other stuffs.                                                 !
+       ! Note that even when 'prel' is located above the PBL top height, we !
+       ! still have cumulus convection between PBL top height and 'prel':   !
+       ! we simply assume that no lateral mixing occurs in this range.      !
+       ! ------------------------------------------------------------------ !
+
+       if( klcl .lt. kinv ) then
+           krel    = kinv
+           prel    = ps0(krel-1)
+           thv0rel = thv0bot(krel) 
+       else
+           krel    = klcl
+           prel    = plcl 
+           thv0rel = thv0lcl
+       endif  
+
+       ! --------------------------------------------------------------------------- !
+       ! Calculate cumulus base mass flux ('cbmf'), fractional area ('ufrcinv'), and !
+       ! and mean vertical velocity (winv) of cumulus updraft at PBL top interface.  !
+       ! Also, calculate updraft fractional area (ufrclcl) and vertical velocity  at !
+       ! the LCL (wlcl). When LCL is below PBLH, cinlcl = 0 and 'ufrclcl = ufrcinv', !
+       ! and 'wlcl = winv.                                                           !
+       ! Only updrafts strong enough to overcome CIN can rise over PBL top interface.! 
+       ! Thus,  in order to calculate cumulus mass flux at PBL top interface, 'cbmf',!
+       ! we need to know 'CIN' ( the strength of potential energy barrier ) and      !
+       ! 'sigmaw' ( a standard deviation of updraft vertical velocity at the PBL top !
+       ! interface, a measure of turbulentce strength in the PBL ).   Naturally, the !
+       ! ratio of these two variables, 'mu' - normalized CIN by TKE- is key variable !
+       ! controlling 'cbmf'.  If 'mu' becomes large, only small fraction of updrafts !
+       ! with very strong TKE can rise over the PBL - both 'cbmf' and 'ufrc' becomes !
+       ! small, but 'winv' becomes large ( this can be easily understood by PDF of w !
+       ! at PBL top ).  If 'mu' becomes small, lots of updraft can rise over the PBL !
+       ! top - both 'cbmf' and 'ufrc' becomes large, but 'winv' becomes small. Thus, !
+       ! all of the key variables associated with cumulus convection  at the PBL top !
+       ! - 'cbmf', 'ufrc', 'winv' where 'cbmf = rho*ufrc*winv' - are a unique functi !
+       ! ons of 'mu', normalized CIN. Although these are uniquely determined by 'mu',! 
+       ! we usually impose two comstraints on 'cbmf' and 'ufrc': (1) because we will !
+       ! simply assume that subsidence warming and drying of 'kinv-1' layer in assoc !
+       ! iation with 'cbmf' at PBL top interface is confined only in 'kinv-1' layer, !
+       ! cbmf must not be larger than the mass within the 'kinv-1' layer. Otherwise, !
+       ! instability will occur due to the breaking of stability con. If we consider !
+       ! semi-Lagrangian vertical advection scheme and explicitly consider the exten !
+       ! t of vertical movement of each layer in association with cumulus mass flux, !
+       ! we don't need to impose this constraint. However,  using a  semi-Lagrangian !
+       ! scheme is a future research subject. Note that this constraint should be ap !
+       ! plied for all interfaces above PBL top as well as PBL top interface.   As a !
+       ! result, this 'cbmf' constraint impose a 'lower' limit on mu - 'mumin0'. (2) !
+       ! in order for mass flux parameterization - rho*(w'a')= M*(a_c-a_e) - to   be !
+       ! valid, cumulus updraft fractional area should be much smaller than 1.    In !
+       ! current code, we impose 'rmaxfrac = 0.1 ~ 0.2'   through the whole vertical !
+       ! layers where cumulus convection occurs. At the PBL top interface,  the same !
+       ! constraint is made by imposing another lower 'lower' limit on mu, 'mumin1'. !
+       ! After that, also limit 'ufrclcl' to be smaller than 'rmaxfrac' by 'mumin2'. !
+       ! --------------------------------------------------------------------------- !
+       
+       ! --------------------------------------------------------------------------- !
+       ! Calculate normalized CIN, 'mu' satisfying all the three constraints imposed !
+       ! on 'cbmf'('mumin0'), 'ufrc' at the PBL top - 'ufrcinv' - ( by 'mumin1' from !
+       ! a parameter sentence), and 'ufrc' at the LCL - 'ufrclcl' ( by 'mumin2').    !
+       ! Note that 'cbmf' does not change between PBL top and LCL  because we assume !
+       ! that buoyancy sorting does not occur when cumulus updraft is unsaturated.   !
+       ! --------------------------------------------------------------------------- !
+   
+       if( use_CINcin ) then       
+           wcrit = sqrt( 2._r8 * cin * rbuoy )      
+       else
+           wcrit = sqrt( 2._r8 * cinlcl * rbuoy )   
+       endif
+       sigmaw = sqrt( rkfre * tkeavg + epsvarw )
+       mu = wcrit/sigmaw/1.4142_r8                  
+       if( mu .ge. 3._r8 ) then
+         ! write(iulog,*) 'mu >= 3'
+           id_exit = .true.
+           go to 333
+       endif
+       rho0inv = ps0(kinv-1)/(r*thv0top(kinv-1)*exns0(kinv-1))
+       cbmf = (rho0inv*sigmaw/2.5066_r8)*exp(-mu**2)
+       ! 1. 'cbmf' constraint
+       cbmflimit = 0.9_r8*dp0(kinv-1)/g/dt
+       mumin0 = 0._r8
+       if( cbmf .gt. cbmflimit ) mumin0 = sqrt(-log(2.5066_r8*cbmflimit/rho0inv/sigmaw))
+       ! 2. 'ufrcinv' constraint
+       mu = max(max(mu,mumin0),mumin1)
+       ! 3. 'ufrclcl' constraint      
+       mulcl = sqrt(2._r8*cinlcl*rbuoy)/1.4142_r8/sigmaw
+       mulclstar = sqrt(max(0._r8,2._r8*(exp(-mu**2)/2.5066_r8)**2*(1._r8/erfc(mu)**2-0.25_r8/rmaxfrac**2)))
+       if( mulcl .gt. 1.e-8_r8 .and. mulcl .gt. mulclstar ) then
+           mumin2 = compute_mumin2(mulcl,rmaxfrac,mu)
+           if( mu .gt. mumin2 ) then
+               write(iulog,*) 'Critical error in mu calculation in UW_ShCu'
+               call endrun
+           endif
+           mu = max(mu,mumin2)
+           if( mu .eq. mumin2 ) limit_ufrc(i) = 1._r8
+       endif
+       if( mu .eq. mumin0 ) limit_cbmf(i) = 1._r8
+       if( mu .eq. mumin1 ) limit_ufrc(i) = 1._r8
+
+       ! ------------------------------------------------------------------- !    
+       ! Calculate final ['cbmf','ufrcinv','winv'] at the PBL top interface. !
+       ! Note that final 'cbmf' here is obtained in such that 'ufrcinv' and  !
+       ! 'ufrclcl' are smaller than ufrcmax with no instability.             !
+       ! ------------------------------------------------------------------- !
+
+       cbmf = (rho0inv*sigmaw/2.5066_r8)*exp(-mu**2)                       
+       winv = sigmaw*(2._r8/2.5066_r8)*exp(-mu**2)/erfc(mu)
+       ufrcinv = cbmf/winv/rho0inv
+
+       ! ------------------------------------------------------------------- !
+       ! Calculate ['ufrclcl','wlcl'] at the LCL. When LCL is below PBL top, !
+       ! it automatically becomes 'ufrclcl = ufrcinv' & 'wlcl = winv', since !
+       ! it was already set to 'cinlcl=0' if LCL is below PBL top interface. !
+       ! Note 'cbmf' at the PBL top is the same as 'cbmf' at the LCL.  Note  !
+       ! also that final 'cbmf' here is obtained in such that 'ufrcinv' and  !
+       ! 'ufrclcl' are smaller than ufrcmax and there is no instability.     !
+       ! By construction, it must be 'wlcl > 0' but for assurance, I checked !
+       ! this again in the below block. If 'ufrclcl < 0.1%', just exit.      !
+       ! ------------------------------------------------------------------- !
+
+       wtw = winv * winv - 2._r8 * cinlcl * rbuoy
+       if( wtw .le. 0._r8 ) then
+         ! write(iulog,*) 'wlcl < 0 at the LCL'
+           exit_wtw(i) = 1._r8
+           id_exit = .true.
+           go to 333
+       endif
+       wlcl = sqrt(wtw)
+       ufrclcl = cbmf/wlcl/rho0inv
+       wrel = wlcl
+       if( ufrclcl .le. 0.0001_r8 ) then
+         ! write(iulog,*) 'ufrclcl <= 0.0001' 
+           exit_ufrc(i) = 1._r8
+           id_exit = .true.
+           go to 333
+       endif
+       ufrc(krel-1) = ufrclcl
+
+       ! ----------------------------------------------------------------------- !
+       ! Below is just diagnostic output for detailed analysis of cumulus scheme !
+       ! ----------------------------------------------------------------------- !
+
+       ufrcinvbase        = ufrcinv
+       winvbase           = winv
+       umf(kinv-1:krel-1) = cbmf   
+       wu(kinv-1:krel-1)  = winv   
+
+       ! -------------------------------------------------------------------------- ! 
+       ! Define updraft properties at the level where buoyancy sorting starts to be !
+       ! happening, i.e., by definition, at 'prel' level within the release layer.  !
+       ! Because no lateral entrainment occurs upto 'prel', conservative scalars of ! 
+       ! cumulus updraft at release level is same as those of source air.  However, ! 
+       ! horizontal momentums of source air are modified by horizontal PGF forcings ! 
+       ! from PBL top interface to 'prel'.  For this case, we should add additional !
+       ! horizontal momentum from PBL top interface to 'prel' as will be done below !
+       ! to 'usrc' and 'vsrc'. Note that below cumulus updraft properties - umf, wu,!
+       ! thlu, qtu, thvu, uu, vu - are defined all interfaces not at the layer mid- !
+       ! point. From the index notation of cumulus scheme, wu(k) is the cumulus up- !
+       ! draft vertical velocity at the top interface of k layer.                   !
+       ! Diabatic horizontal momentum forcing should be treated as a kind of 'body' !
+       ! forcing without actual mass exchange between convective updraft and        !
+       ! environment, but still taking horizontal momentum from the environment to  !
+       ! the convective updrafts. Thus, diabatic convective momentum transport      !
+       ! vertically redistributes environmental horizontal momentum.                !
+       ! -------------------------------------------------------------------------- !
+
+       emf(krel-1)  = 0._r8
+       umf(krel-1)  = cbmf
+       wu(krel-1)   = wrel
+       thlu(krel-1) = thlsrc
+       qtu(krel-1)  = qtsrc
+       call conden(prel,thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check,qsat)
+       if( id_check .eq. 1 ) then
+           exit_conden(i) = 1._r8
+           id_exit = .true.
+           go to 333
+       endif
+       thvu(krel-1) = thj * ( 1._r8 + zvir*qvj - qlj - qij )       
+
+       uplus = 0._r8
+       vplus = 0._r8
+       if( krel .eq. kinv ) then
+           uplus = PGFc * ssu0(kinv) * ( prel - ps0(kinv-1) )
+           vplus = PGFc * ssv0(kinv) * ( prel - ps0(kinv-1) )
+       else
+           do k = kinv, max(krel-1,kinv)
+              uplus = uplus + PGFc * ssu0(k) * ( ps0(k) - ps0(k-1) )
+              vplus = vplus + PGFc * ssv0(k) * ( ps0(k) - ps0(k-1) )
+           end do
+           uplus = uplus + PGFc * ssu0(krel) * ( prel - ps0(krel-1) )
+           vplus = vplus + PGFc * ssv0(krel) * ( prel - ps0(krel-1) )
+       end if
+       uu(krel-1) = usrc + uplus
+       vu(krel-1) = vsrc + vplus      
+
+       do m = 1, ncnst
+          tru(krel-1,m)  = trsrc(m)
+       enddo
+
+       ! -------------------------------------------------------------------------- !
+       ! Define environmental properties at the level where buoyancy sorting occurs !
+       ! ('pe', normally, layer midpoint except in the 'krel' layer). In the 'krel' !
+       ! layer where buoyancy sorting starts to occur, however, 'pe' is defined     !
+       ! differently because LCL is regarded as lower interface for mixing purpose. !
+       ! -------------------------------------------------------------------------- !
+
+       pe      = 0.5_r8 * ( prel + ps0(krel) )
+       dpe     = prel - ps0(krel)
+       exne    = exnf(pe)
+       thvebot = thv0rel
+       thle    = thl0(krel) + ssthl0(krel) * ( pe - p0(krel) )
+       qte     = qt0(krel)  + ssqt0(krel)  * ( pe - p0(krel) )
+       ue      = u0(krel)   + ssu0(krel)   * ( pe - p0(krel) )
+       ve      = v0(krel)   + ssv0(krel)   * ( pe - p0(krel) )
+       do m = 1, ncnst
+          tre(m) = tr0(krel,m)  + sstr0(krel,m) * ( pe - p0(krel) )
+       enddo
+
+       !-------------------------! 
+       ! Buoyancy-Sorting Mixing !
+       !-------------------------!------------------------------------------------ !
+       !                                                                           !
+       !  In order to complete buoyancy-sorting mixing at layer mid-point, and so  ! 
+       !  calculate 'updraft mass flux, updraft w velocity, conservative scalars'  !
+       !  at the upper interface of each layer, we need following 3 information.   ! 
+       !                                                                           !
+       !  1. Pressure where mixing occurs ('pe'), and temperature at 'pe' which is !
+       !     necessary to calculate various thermodynamic coefficients at pe. This !
+       !     temperature is obtained by undiluted cumulus properties lifted to pe. ! 
+       !  2. Undiluted updraft properties at pe - conservative scalar and vertical !
+       !     velocity -which are assumed to be the same as the properties at lower !
+       !     interface only for calculation of fractional lateral entrainment  and !
+       !     detrainment rate ( fer(k) and fdr(k) [Pa-1] ), respectively.    Final !
+       !     values of cumulus conservative scalars and w at the top interface are !
+       !     calculated afterward after obtaining fer(k) & fdr(k).                 !
+       !  3. Environmental properties at pe.                                       !
+       ! ------------------------------------------------------------------------- !
+       
+       ! ------------------------------------------------------------------------ ! 
+       ! Define cumulus scale height.                                             !
+       ! Cumulus scale height is defined as the maximum height cumulus can reach. !
+       ! In case of premitive code, cumulus scale height ('cush')  at the current !
+       ! time step was assumed to be the same as 'cush' of previous time step.    !
+       ! However, I directly calculated cush at each time step using an iterative !
+       ! method. Note that within the cumulus scheme, 'cush' information is  used !
+       ! only at two places during buoyancy-sorting process:                      !
+       ! (1) Even negatively buoyancy mixtures with strong vertical velocity      !
+       !     enough to rise up to 'rle*scaleh' (rle = 0.1) from pe are entrained  !
+       !     into cumulus updraft,                                                !  
+       ! (2) The amount of mass that is involved in buoyancy-sorting mixing       !
+       !      process at pe is rei(k) = rkm/scaleh/rho*g [Pa-1]                   !
+       ! In terms of (1), I think critical stopping distance might be replaced by !
+       ! layer thickness. In future, we will use rei(k) = (0.5*rkm/z0(k)/rho/g).  !
+       ! In the premitive code,  'scaleh' was largely responsible for the jumping !
+       ! variation of precipitation amount.                                       !
+       ! ------------------------------------------------------------------------ !   
+
+       scaleh = tscaleh
+       if( tscaleh .lt. 0.0_r8 ) scaleh = 1000._r8 
+
+     ! Save time : Set iter_scaleh = 1. This will automatically use 'cush' from the previous time step
+     !             at the first implicit iteration. At the second implicit iteration, it will use
+     !             the updated 'cush' by the first implicit cin. So, this updating has an effect of
+     !             doing one iteration for cush calculation, which is good. 
+     !             So, only this setting of 'iter_scaleh = 1' is sufficient-enough to save computation time.
+     ! OK
+
+       do iter_scaleh = 1, 3
+
+       ! ---------------------------------------------------------------- !
+       ! Initialization of 'kbup' and 'kpen'                              !
+       ! ---------------------------------------------------------------- !
+       ! 'kbup' is the top-most layer in which cloud buoyancy is positive !
+       ! both at the top and bottom interface of the layer. 'kpen' is the !
+       ! layer upto which cumulus panetrates ,i.e., cumulus w at the base !
+       ! interface is positive, but becomes negative at the top interface.!
+       ! Here, we initialize 'kbup' and 'kpen'. These initializations are !  
+       ! not trivial but important, expecially   in calculating turbulent !
+       ! fluxes without confliction among several physics as explained in !
+       ! detail in the part of turbulent fluxes calculation later.   Note !
+       ! that regardless of whether 'kbup' and 'kpen' are updated or  not !
+       ! during updraft motion,  penetrative entrainments are dumped down !
+       ! across the top interface of 'kbup' later.      More specifically,!
+       ! penetrative entrainment heat and moisture fluxes are  calculated !
+       ! from the top interface of 'kbup' layer  to the base interface of !
+       ! 'kpen' layer. Because of this, initialization of 'kbup' & 'kpen' !
+       ! influence the convection system when there are not updated.  The !  
+       ! below initialization of 'kbup = krel' assures  that  penetrative !
+       ! entrainment fluxes always occur at interfaces above the PBL  top !
+       ! interfaces (i.e., only at interfaces k >=kinv ), which seems  to !
+       ! be attractable considering that the most correct fluxes  at  the !
+       ! PBL top interface can be ontained from the 'fluxbelowinv'  using !
+       ! reconstructed PBL height.                                        ! 
+       ! The 'kbup = krel'(after going through the whole buoyancy sorting !
+       ! proces during updraft motion) implies that cumulus updraft  from !
+       ! the PBL top interface can not reach to the LFC,so that 'kbup' is !
+       ! not updated during upward. This means that cumulus updraft   did !
+       ! not fully overcome the buoyancy barrier above just the PBL top.  !
+       ! If 'kpen' is not updated either ( i.e., cumulus cannot rise over !
+       ! the top interface of release layer),penetrative entrainment will !
+       ! not happen at any interfaces.  If cumulus updraft can rise above !
+       ! the release layer but cannot fully overcome the buoyancy barrier !
+       ! just above PBL top interface, penetratve entrainment   occurs at !
+       ! several above interfaces, including the top interface of release ! 
+       ! layer. In the latter case, warming and drying tendencies will be !
+       ! be initiated in 'krel' layer. Note current choice of 'kbup=krel' !
+       ! is completely compatible with other flux physics without  double !
+       ! or miss counting turbulent fluxes at any interface. However, the !
+       ! alternative choice of 'kbup=krel-1' also has itw own advantage - !
+       ! when cumulus updraft cannot overcome buoyancy barrier just above !
+       ! PBL top, entrainment warming and drying are concentrated in  the !
+       ! 'kinv-1' layer instead of 'kinv' layer for this case. This might !
+       ! seems to be more dynamically reasonable, but I will choose the   !
+       ! 'kbup = krel' choice since it is more compatible  with the other !
+       ! parts of the code, expecially, when we chose ' use_emf=.false. ' !
+       ! as explained in detail in turbulent flux calculation part.       !
+       ! ---------------------------------------------------------------- ! 
+
+       kbup    = krel
+       kpen    = krel
+       
+       ! ------------------------------------------------------------ !
+       ! Since 'wtw' is continuously updated during vertical motion,  !
+       ! I need below initialization command within this 'iter_scaleh'!
+       ! do loop. Similarily, I need initializations of environmental !
+       ! properties at 'krel' layer as below.                         !
+       ! ------------------------------------------------------------ !
+
+       wtw     = wlcl * wlcl
+       pe      = 0.5_r8 * ( prel + ps0(krel) )
+       dpe     = prel - ps0(krel)
+       exne    = exnf(pe)
+       thvebot = thv0rel
+       thle    = thl0(krel) + ssthl0(krel) * ( pe - p0(krel) )
+       qte     = qt0(krel)  + ssqt0(krel)  * ( pe - p0(krel) )
+       ue      = u0(krel)   + ssu0(krel)   * ( pe - p0(krel) )
+       ve      = v0(krel)   + ssv0(krel)   * ( pe - p0(krel) )
+       do m = 1, ncnst
+          tre(m) = tr0(krel,m)  + sstr0(krel,m)  * ( pe - p0(krel) )
+       enddo
+
+       ! ----------------------------------------------------------------------- !
+       ! Cumulus rises upward from 'prel' ( or base interface of  'krel' layer ) !
+       ! until updraft vertical velocity becomes zero.                           !
+       ! Buoyancy sorting is performed via two stages. (1) Using cumulus updraft !
+       ! properties at the base interface of each layer,perform buoyancy sorting !
+       ! at the layer mid-point, 'pe',  and update cumulus properties at the top !
+       ! interface, and then  (2) by averaging updated cumulus properties at the !
+       ! top interface and cumulus properties at the base interface,   calculate !
+       ! cumulus updraft properties at pe that will be used  in buoyancy sorting !
+       ! mixing - thlue, qtue and, wue.  Using this averaged properties, perform !
+       ! buoyancy sorting again at pe, and re-calculate fer(k) and fdr(k). Using !
+       ! this recalculated fer(k) and fdr(k),  finally calculate cumulus updraft !
+       ! properties at the top interface - thlu, qtu, thvu, uu, vu. In the below,!
+       ! 'iter_xc = 1' performs the first stage, while 'iter_xc= 2' performs the !
+       ! second stage. We can increase the number of iterations, 'nter_xc'.as we !
+       ! want, but a sample test indicated that about 3 - 5 iterations  produced !
+       ! satisfactory converent solution. Finally, identify 'kbup' and 'kpen'.   !
+       ! ----------------------------------------------------------------------- !
+       
+       do k = krel, mkx - 1 ! Here, 'k' is a layer index.
+
+          km1 = k - 1
+
+          thlue = thlu(km1)
+          qtue  = qtu(km1)    
+          wue   = wu(km1)
+          wtwb  = wtw  
+
+       do iter_xc = 1, niter_xc
+          
+          wtw = wu(km1) * wu(km1)
+
+          ! ---------------------------------------------------------------- !
+          ! Calculate environmental and cumulus saturation 'excess' at 'pe'. !
+          ! Note that in order to calculate saturation excess, we should use ! 
+          ! liquid water temperature instead of temperature  as the argument !
+          ! of "qsat". But note normal argument of "qsat" is temperature.    !
+          ! ---------------------------------------------------------------- !
+
+          call conden(pe,thle,qte,thj,qvj,qlj,qij,qse,id_check,qsat)
+          if( id_check .eq. 1 ) then
+              exit_conden(i) = 1._r8
+              id_exit = .true.
+              go to 333
+          end if
+          thv0j    = thj * ( 1._r8 + zvir*qvj - qlj - qij )
+          rho0j    = pe / ( r * thv0j * exne )
+          qsat_arg = thle*exne     
+          status   = qsat(qsat_arg,pe,es(1),qs(1),gam(1),1)
+          excess0  = qte - qs(1)
+
+          call conden(pe,thlue,qtue,thj,qvj,qlj,qij,qse,id_check,qsat)
+          if( id_check .eq. 1 ) then
+              exit_conden(i) = 1._r8
+              id_exit = .true.
+              go to 333
+          end if
+          ! ----------------------------------------------------------------- !
+          ! Detrain excessive condensate larger than 'criqc' from the cumulus ! 
+          ! updraft before performing buoyancy sorting. All I should to do is !
+          ! to update 'thlue' &  'que' here. Below modification is completely !
+          ! compatible with the other part of the code since 'thule' & 'qtue' !
+          ! are used only for buoyancy sorting. I found that as long as I use !
+          ! 'niter_xc >= 2',  detraining excessive condensate before buoyancy !
+          ! sorting has negligible influence on the buoyancy sorting results. !   
+          ! ----------------------------------------------------------------- !
+          if( (qlj + qij) .gt. criqc ) then
+               exql  = ( ( qlj + qij ) - criqc ) * qlj / ( qlj + qij )
+               exqi  = ( ( qlj + qij ) - criqc ) * qij / ( qlj + qij )
+               qtue  = qtue - exql - exqi
+               thlue = thlue + (xlv/cp/exne)*exql + (xls/cp/exne)*exqi 
+          endif
+          call conden(pe,thlue,qtue,thj,qvj,qlj,qij,qse,id_check,qsat)
+          if( id_check .eq. 1 ) then
+              exit_conden(i) = 1._r8
+              id_exit = .true.
+              go to 333
+          end if
+          thvj     = thj * ( 1._r8 + zvir * qvj - qlj - qij )
+          tj       = thj * exne ! This 'tj' is used for computing thermo. coeffs. below
+          qsat_arg = thlue*exne
+          status   = qsat(qsat_arg,pe,es(1),qs(1),gam(1),1)
+          excessu  = qtue - qs(1)
+
+          ! ------------------------------------------------------------------- !
+          ! Calculate critical mixing fraction, 'xc'. Mixture with mixing ratio !
+          ! smaller than 'xc' will be entrained into cumulus updraft.  Both the !
+          ! saturated updrafts with 'positive buoyancy' or 'negative buoyancy + ! 
+          ! strong vertical velocity enough to rise certain threshold distance' !
+          ! are kept into the updraft in the below program. If the core updraft !
+          ! is unsaturated, we can set 'xc = 0' and let the cumulus  convection !
+          ! still works or we may exit.                                         !
+          ! Current below code does not entrain unsaturated mixture. However it !
+          ! should be modified such that it also entrain unsaturated mixture.   !
+          ! ------------------------------------------------------------------- !
+
+          ! ----------------------------------------------------------------- !
+          ! cridis : Critical stopping distance for buoyancy sorting purpose. !
+          !          scaleh is only used here.                                !
+          ! ----------------------------------------------------------------- !
+
+            cridis = rle*scaleh                 ! Original code
+          ! cridis = 1._r8*(zs0(k) - zs0(k-1))  ! New code
+ 
+          ! ---------------- !
+          ! Buoyancy Sorting !
+          ! ---------------- !                   
+
+          ! ----------------------------------------------------------------- !
+          ! Case 1 : When both cumulus and env. are unsaturated or saturated. !
+          ! ----------------------------------------------------------------- !
+
+          if( ( excessu .le. 0._r8 .and. excess0 .le. 0._r8 ) .or. ( excessu .ge. 0._r8 .and. excess0 .ge. 0._r8 ) ) then
+                xc = min(1._r8,max(0._r8,1._r8-2._r8*rbuoy*g*cridis/wue**2._r8*(1._r8-thvj/thv0j)))
+              ! Below 3 lines are diagnostic output not influencing
+              ! numerical calculations.
+                aquad = 0._r8
+                bquad = 0._r8
+                cquad = 0._r8
+          else
+          ! -------------------------------------------------- !
+          ! Case 2 : When either cumulus or env. is saturated. !
+          ! -------------------------------------------------- !
+              xsat    = excessu / ( excessu - excess0 );
+              thlxsat = thlue + xsat * ( thle - thlue );
+              qtxsat  = qtue  + xsat * ( qte - qtue );
+              call conden(pe,thlxsat,qtxsat,thj,qvj,qlj,qij,qse,id_check,qsat)
+              if( id_check .eq. 1 ) then
+                  exit_conden(i) = 1._r8
+                  id_exit = .true.
+                  go to 333
+              end if
+              thvxsat = thj * ( 1._r8 + zvir * qvj - qlj - qij )               
+              ! -------------------------------------------------- !
+              ! kk=1 : Cumulus Segment, kk=2 : Environment Segment !
+              ! -------------------------------------------------- ! 
+              do kk = 1, 2 
+                   if( kk .eq. 1 ) then
+                       thv_x0 = thvj;
+                       thv_x1 = ( 1._r8 - 1._r8/xsat ) * thvj + ( 1._r8/xsat ) * thvxsat;
+                   else
+                       thv_x1 = thv0j;
+                       thv_x0 = ( xsat / ( xsat - 1._r8 ) ) * thv0j + ( 1._r8/( 1._r8 - xsat ) ) * thvxsat;
+                   endif
+                   aquad =  wue**2;
+                   bquad =  2._r8*rbuoy*g*cridis*(thv_x1 - thv_x0)/thv0j - 2._r8*wue**2;
+                   cquad =  2._r8*rbuoy*g*cridis*(thv_x0 -  thv0j)/thv0j +       wue**2;
+                   if( kk .eq. 1 ) then
+                       if( ( bquad**2-4._r8*aquad*cquad ) .ge. 0._r8 ) then
+                             call roots(aquad,bquad,cquad,xs1,xs2,status)
+                             x_cu = min(1._r8,max(0._r8,min(xsat,min(xs1,xs2))))
+                       else
+                             x_cu = xsat;
+                       endif
+                   else 
+                       if( ( bquad**2-4._r8*aquad*cquad) .ge. 0._r8 ) then
+                             call roots(aquad,bquad,cquad,xs1,xs2,status)
+                             x_en = min(1._r8,max(0._r8,max(xsat,min(xs1,xs2))))
+                       else
+                             x_en = 1._r8;
+                       endif
+                   endif
+              enddo
+              if( x_cu .eq. xsat ) then
+                  xc = max(x_cu, x_en);
+              else
+                  xc = x_cu;
+              endif
+          endif
+
+          ! ------------------------------------------------------------------------ !
+          ! Compute fractional lateral entrainment & detrainment rate in each layers.!
+          ! The unit of rei(k), fer(k), and fdr(k) is [Pa-1].  Alternative choice of !
+          ! 'rei(k)' is also shown below, where coefficient 0.5 was from approximate !
+          ! tuning against the BOMEX case.                                           !
+          ! In order to prevent the onset of instability in association with cumulus !
+          ! induced subsidence advection, cumulus mass flux at the top interface  in !
+          ! any layer should be smaller than ( 90% of ) total mass within that layer.!
+          ! I imposed limits on 'rei(k)' as below,  in such that stability condition ! 
+          ! is always satisfied.                                                     !
+          ! Below limiter of 'rei(k)' becomes negative for some cases, causing error.!
+          ! So, for the time being, I came back to the original limiter.             !
+          ! ------------------------------------------------------------------------ !
+          ee2    = xc**2
+          ud2    = 1._r8 - 2._r8*xc + xc**2
+        ! rei(k) = ( rkm / scaleh / g / rho0j )        ! Default.
+          rei(k) = ( 0.5_r8 * rkm / z0(k) / g /rho0j ) ! Alternative.
+          if( xc .gt. 0.5_r8 ) rei(k) = min(rei(k),0.9_r8*log(dp0(k)/g/dt/umf(km1) + 1._r8)/dpe/(2._r8*xc-1._r8))
+          fer(k) = rei(k) * ee2
+          fdr(k) = rei(k) * ud2
+
+          ! ------------------------------------------------------------------------------ !
+          ! Iteration Start due to 'maxufrc' constraint [ ****************************** ] ! 
+          ! ------------------------------------------------------------------------------ !
+
+          ! -------------------------------------------------------------------------- !
+          ! Calculate cumulus updraft mass flux and penetrative entrainment mass flux. !
+          ! Note that  non-zero penetrative entrainment mass flux will be asigned only !
+          ! to interfaces from the top interface of 'kbup' layer to the base interface !
+          ! of 'kpen' layer as will be shown later.                                    !
+          ! -------------------------------------------------------------------------- !
+
+          umf(k) = umf(km1) * exp( dpe * ( fer(k) - fdr(k) ) )
+          emf(k) = 0._r8    
+
+          ! --------------------------------------------------------- !
+          ! Compute cumulus updraft properties at the top interface.  !
+          ! Also use Tayler expansion in order to treat limiting case !
+          ! --------------------------------------------------------- !
+
+          if( fer(k)*dpe .lt. 1.e-4_r8 ) then
+              thlu(k) = thlu(km1) + ( thle + ssthl0(k) * dpe / 2._r8 - thlu(km1) ) * fer(k) * dpe
+              qtu(k)  =  qtu(km1) + ( qte  +  ssqt0(k) * dpe / 2._r8 -  qtu(km1) ) * fer(k) * dpe
+              uu(k)   =   uu(km1) + ( ue   +   ssu0(k) * dpe / 2._r8 -   uu(km1) ) * fer(k) * dpe - PGFc * ssu0(k) * dpe
+              vu(k)   =   vu(km1) + ( ve   +   ssv0(k) * dpe / 2._r8 -   vu(km1) ) * fer(k) * dpe - PGFc * ssv0(k) * dpe
+              do m = 1, ncnst
+                 tru(k,m)  =  tru(km1,m) + ( tre(m)  + sstr0(k,m) * dpe / 2._r8  -  tru(km1,m) ) * fer(k) * dpe
+              enddo
+          else
+              thlu(k) = ( thle + ssthl0(k) / fer(k) - ssthl0(k) * dpe / 2._r8 ) -          &
+                        ( thle + ssthl0(k) * dpe / 2._r8 - thlu(km1) + ssthl0(k) / fer(k) ) * exp(-fer(k) * dpe)
+              qtu(k)  = ( qte  +  ssqt0(k) / fer(k) -  ssqt0(k) * dpe / 2._r8 ) -          &  
+                        ( qte  +  ssqt0(k) * dpe / 2._r8 -  qtu(km1) +  ssqt0(k) / fer(k) ) * exp(-fer(k) * dpe)
+              uu(k) =   ( ue + ( 1._r8 - PGFc ) * ssu0(k) / fer(k) - ssu0(k) * dpe / 2._r8 ) - &
+                        ( ue +     ssu0(k) * dpe / 2._r8 -   uu(km1) + ( 1._r8 - PGFc ) * ssu0(k) / fer(k) ) * exp(-fer(k) * dpe)
+              vu(k) =   ( ve + ( 1._r8 - PGFc ) * ssv0(k) / fer(k) - ssv0(k) * dpe / 2._r8 ) - &
+                        ( ve +     ssv0(k) * dpe / 2._r8 -   vu(km1) + ( 1._r8 - PGFc ) * ssv0(k) / fer(k) ) * exp(-fer(k) * dpe)
+              do m = 1, ncnst
+                 tru(k,m)  = ( tre(m)  + sstr0(k,m) / fer(k) - sstr0(k,m) * dpe / 2._r8 ) - &  
+                             ( tre(m)  + sstr0(k,m) * dpe / 2._r8 - tru(km1,m) + sstr0(k,m) / fer(k) ) * exp(-fer(k) * dpe)
+              enddo
+          end if
+
+          !------------------------------------------------------------------- !
+          ! Expel some of cloud water and ice from cumulus  updraft at the top !
+          ! interface.  Note that this is not 'detrainment' term  but a 'sink' !
+          ! term of cumulus updraft qt ( or one part of 'source' term of  mean !
+          ! environmental qt ). At this stage, as the most simplest choice, if !
+          ! condensate amount within cumulus updraft is larger than a critical !
+          ! value, 'criqc', expels the surplus condensate from cumulus updraft !
+          ! to the environment. A certain fraction ( e.g., 'frc_sus' ) of this !
+          ! expelled condesnate will be in a form that can be suspended in the !
+          ! layer k where it was formed, while the other fraction, '1-frc_sus' ! 
+          ! will be in a form of precipitatble (e.g.,can potentially fall down !
+          ! across the base interface of layer k ). In turn we should describe !
+          ! subsequent falling of precipitable condensate ('1-frc_sus') across !
+          ! the base interface of the layer k, &  evaporation of precipitating !
+          ! water in the below layer k-1 and associated evaporative cooling of !
+          ! the later, k-1, and falling of 'non-evaporated precipitating water !
+          ! ( which was initially formed in layer k ) and a newly-formed preci !
+          ! pitable water in the layer, k-1', across the base interface of the !
+          ! lower layer k-1.  Cloud microphysics should correctly describe all !
+          ! of these process.  In a near future, I should significantly modify !
+          ! this cloud microphysics, including precipitation-induced downdraft !
+          ! also.                                                              !
+          ! ------------------------------------------------------------------ !
+
+          call conden(ps0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check,qsat)
+          if( id_check .eq. 1 ) then
+              exit_conden(i) = 1._r8
+              id_exit = .true.
+              go to 333
+          end if
+          if( (qlj + qij) .gt. criqc ) then
+               exql    = ( ( qlj + qij ) - criqc ) * qlj / ( qlj + qij )
+               exqi    = ( ( qlj + qij ) - criqc ) * qij / ( qlj + qij )
+               ! ---------------------------------------------------------------- !
+               ! It is very important to re-update 'qtu' and 'thlu'  at the upper ! 
+               ! interface after expelling condensate from cumulus updraft at the !
+               ! top interface of the layer. As mentioned above, this is a 'sink' !
+               ! of cumulus qt (or equivalently, a 'source' of environmentasl qt),!
+               ! not a regular convective'detrainment'.                           !
+               ! ---------------------------------------------------------------- !
+               qtu(k)  = qtu(k) - exql - exqi
+               thlu(k) = thlu(k) + (xlv/cp/exns0(k))*exql + (xls/cp/exns0(k))*exqi 
+               ! ---------------------------------------------------------------- !
+               ! Expelled cloud condensate into the environment from the updraft. ! 
+               ! After all the calculation later, 'dwten' and 'diten' will have a !
+               ! unit of [ kg/kg/s ], because it is a tendency of qt. Restoration !
+               ! of 'dwten' and 'diten' to this correct unit through  multiplying !
+               ! 'umf(k)*g/dp0(k)' will be performed later after finally updating !
+               ! 'umf' using a 'rmaxfrac' constraint near the end of this updraft !
+               ! buoyancy sorting loop.                                           !
+               ! ---------------------------------------------------------------- !
+               dwten(k) = exql   
+               diten(k) = exqi
+          else
+               dwten(k) = 0._r8
+               diten(k) = 0._r8
+          endif
+          ! ----------------------------------------------------------------- ! 
+          ! Update 'thvu(k)' after detraining condensate from cumulus updraft.!
+          ! ----------------------------------------------------------------- ! 
+          call conden(ps0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check,qsat)
+          if( id_check .eq. 1 ) then
+              exit_conden(i) = 1._r8
+              id_exit = .true.
+              go to 333
+          end if  
+          thvu(k) = thj * ( 1._r8 + zvir * qvj - qlj - qij )
+
+          ! ----------------------------------------------------------- ! 
+          ! Calculate updraft vertical velocity at the upper interface. !
+          ! In order to calculate 'wtw' at the upper interface, we use  !
+          ! 'wtw' at the lower interface. Note  'wtw'  is continuously  ! 
+          ! updated as cumulus updraft rises.                           !
+          ! ----------------------------------------------------------- !
+
+          bogbot = rbuoy * ( thvu(km1) / thvebot  - 1._r8 ) ! Cloud buoyancy at base interface
+          bogtop = rbuoy * ( thvu(k) / thv0top(k) - 1._r8 ) ! Cloud buoyancy at top  interface
+
+          delbog = bogtop - bogbot
+          drage  = fer(k) * ( 1._r8 + rdrag )
+          expfac = exp(-2._r8*drage*dpe)
+
+          wtwb = wtw
+          if( drage*dpe .gt. 1.e-3_r8 ) then
+              wtw = wtw*expfac + (delbog + (1._r8-expfac)*(bogbot + delbog/(-2._r8*drage*dpe)))/(rho0j*drage)
+          else
+              wtw = wtw + dpe * ( bogbot + bogtop ) / rho0j
+          endif
+
+        ! Force the plume rise at least to klfc of the undiluted plume.
+        ! Because even the below is not complete, I decided not to include this.
+
+        ! if( k .le. klfc ) then
+        !     wtw = max( 1.e-2_r8, wtw )
+        ! endif 
+         
+          ! -------------------------------------------------------------- !
+          ! Repeat 'iter_xc' iteration loop until 'iter_xc = niter_xc'.    !
+          ! Also treat the case even when wtw < 0 at the 'kpen' interface. !
+          ! -------------------------------------------------------------- !  
+          
+          if( wtw .gt. 0._r8 ) then   
+              thlue = 0.5_r8 * ( thlu(km1) + thlu(k) )
+              qtue  = 0.5_r8 * ( qtu(km1)  +  qtu(k) )         
+              wue   = 0.5_r8 *   sqrt( max( wtwb + wtw, 0._r8 ) )
+          else
+              go to 111
+          endif 
+
+       enddo ! End of 'iter_xc' loop  
+
+   111 continue
+
+          ! --------------------------------------------------------------------------- ! 
+          ! Add the contribution of self-detrainment  to vertical variations of cumulus !
+          ! updraft mass flux. The reason why we are trying to include self-detrainment !
+          ! is as follows.  In current scheme,  vertical variation of updraft mass flux !
+          ! is not fully consistent with the vertical variation of updraft vertical w.  !
+          ! For example, within a given layer, let's assume that  cumulus w is positive !
+          ! at the base interface, while negative at the top interface. This means that !
+          ! cumulus updraft cannot reach to the top interface of the layer. However,    !
+          ! cumulus updraft mass flux at the top interface is not zero according to the !
+          ! vertical tendency equation of cumulus mass flux.   Ideally, cumulus updraft ! 
+          ! mass flux at the top interface should be zero for this case. In order to    !
+          ! assures that cumulus updraft mass flux goes to zero when cumulus updraft    ! 
+          ! vertical velocity goes to zero, we are imposing self-detrainment term as    !
+          ! below by considering layer-mean cloud buoyancy and cumulus updraft vertical !
+          ! velocity square at the top interface. Use of auto-detrainment term will  be !
+          ! determined by setting 'use_self_detrain=.true.' in the parameter sentence.  !
+          ! --------------------------------------------------------------------------- !
+     
+          if( use_self_detrain ) then
+              autodet = min( 0.5_r8*g*(bogbot+bogtop)/(max(wtw,0._r8)+1.e-4_r8), 0._r8 ) 
+              umf(k)  = umf(k) * exp( 0.637_r8*(dpe/rho0j/g) * autodet )   
+          end if      
+          if( umf(k) .eq. 0._r8 ) wtw = -1._r8
+
+          ! -------------------------------------- !
+          ! Below block is just a dignostic output !
+          ! -------------------------------------- ! 
+
+          excessu_arr(k) = excessu
+          excess0_arr(k) = excess0
+          xc_arr(k)      = xc
+          aquad_arr(k)   = aquad
+          bquad_arr(k)   = bquad
+          cquad_arr(K)   = cquad
+          bogbot_arr(k)  = bogbot
+          bogtop_arr(k)  = bogtop
+
+          ! ------------------------------------------------------------------- !
+          ! 'kbup' is the upper most layer in which cloud buoyancy  is positive ! 
+          ! both at the base and top interface.  'kpen' is the upper most layer !
+          ! up to cumulus can reach. Usually, 'kpen' is located higher than the !
+          ! 'kbup'. Note we initialized these by 'kbup = krel' & 'kpen = krel'. !
+          ! As explained before, it is possible that only 'kpen' is updated,    !
+          ! while 'kbup' keeps its initialization value. For this case, current !
+          ! scheme will simply turns-off penetrative entrainment fluxes and use ! 
+          ! normal buoyancy-sorting fluxes for 'kbup <= k <= kpen-1' interfaces,!
+          ! in order to describe shallow continental cumulus convection.        !
+          ! ------------------------------------------------------------------- !
+          
+        ! if( bogbot .gt. 0._r8 .and. bogtop .gt. 0._r8 ) then 
+        ! if( bogtop .gt. 0._r8 ) then          
+          if( bogtop .gt. 0._r8 .and. wtw .gt. 0._r8 ) then 
+              kbup = k
+          end if
+
+          if( wtw .le. 0._r8 ) then
+              kpen = k
+              go to 45
+          end if
+
+          wu(k) = sqrt(wtw)
+          if( wu(k) .gt. 100._r8 ) then
+              exit_wu(i) = 1._r8
+              id_exit = .true.
+              go to 333
+          endif
+
+          ! ---------------------------------------------------------------------------- !
+          ! Iteration end due to 'rmaxfrac' constraint [ ***************************** ] ! 
+          ! ---------------------------------------------------------------------------- !
+
+          ! ---------------------------------------------------------------------- !
+          ! Calculate updraft fractional area at the upper interface and set upper ! 
+          ! limit to 'ufrc' by 'rmaxfrac'. In order to keep the consistency  among !
+          ! ['ufrc','umf','wu (or wtw)'], if ufrc is limited by 'rmaxfrac', either !
+          ! 'umf' or 'wu' should be changed. Although both 'umf' and 'wu (wtw)' at !
+          ! the current upper interface are used for updating 'umf' & 'wu'  at the !
+          ! next upper interface, 'umf' is a passive variable not influencing  the !
+          ! buoyancy sorting process in contrast to 'wtw'. This is a reason why we !
+          ! adjusted 'umf' instead of 'wtw'. In turn we updated 'fdr' here instead !
+          ! of 'fer',  which guarantees  that all previously updated thermodynamic !
+          ! variables at the upper interface before applying 'rmaxfrac' constraint !
+          ! are already internally consistent,  even though 'ufrc'  is  limited by !
+          ! 'rmaxfrac'. Thus, we don't need to go through interation loop again.If !
+          ! If we update 'fer' however, we should go through above iteration loop. !
+          ! ---------------------------------------------------------------------- !
+            
+          rhos0j  = ps0(k) / ( r * 0.5_r8 * ( thv0bot(k+1) + thv0top(k) ) * exns0(k) )
+          ufrc(k) = umf(k) / ( rhos0j * wu(k) )
+          if( ufrc(k) .gt. rmaxfrac ) then
+              limit_ufrc(i) = 1._r8 
+              ufrc(k) = rmaxfrac
+              umf(k)  = rmaxfrac * rhos0j * wu(k)
+              fdr(k)  = fer(k) - log( umf(k) / umf(km1) ) / dpe
+          endif
+
+          ! ------------------------------------------------------------ !
+          ! Update environmental properties for at the mid-point of next !
+          ! upper layer for use in buoyancy sorting.                     !
+          ! ------------------------------------------------------------ ! 
+
+          pe      = p0(k+1)
+          dpe     = dp0(k+1)
+          exne    = exn0(k+1)
+          thvebot = thv0bot(k+1)
+          thle    = thl0(k+1)
+          qte     = qt0(k+1)
+          ue      = u0(k+1)
+          ve      = v0(k+1) 
+          do m = 1, ncnst
+             tre(m)  = tr0(k+1,m)
+          enddo
+
+       end do   ! End of cumulus updraft loop from the 'krel' layer to 'kpen' layer.
+       
+       ! ------------------------------------------------------------------------------- !
+       ! Up to this point, we finished all of buoyancy sorting processes from the 'krel' !
+       ! layer to 'kpen' layer: at the top interface of individual layers, we calculated !
+       ! updraft and penetrative mass fluxes [ umf(k) & emf(k) = 0 ], updraft fractional !
+       ! area [ ufrc(k) ],  updraft vertical velocity [ wu(k) ],  updraft  thermodynamic !
+       ! variables [thlu(k),qtu(k),uu(k),vu(k),thvu(k)]. In the layer,we also calculated !
+       ! fractional entrainment-detrainment rate [ fer(k), fdr(k) ], and detrainment ten !
+       ! dency of water and ice from cumulus updraft [ dwten(k), diten(k) ]. In addition,!
+       ! we updated and identified 'krel' and 'kpen' layer index, if any.  In the 'kpen' !
+       ! layer, we calculated everything mentioned above except the 'wu(k)' and 'ufrc(k)'!
+       ! since a real value of updraft vertical velocity is not defined at the kpen  top !
+       ! interface (note 'ufrc' at the top interface of layer is calculated from 'umf(k)'!
+       ! and 'wu(k)'). As mentioned before, special treatment is required when 'kbup' is !
+       ! not updated and so 'kbup = krel'.                                               !
+       ! ------------------------------------------------------------------------------- !
+       
+       ! ------------------------------------------------------------------------------ !
+       ! During the 'iter_scaleh' iteration loop, non-physical ( with non-zero values ) !
+       ! values can remain in the variable arrays above (also 'including' in case of wu !
+       ! and ufrc at the top interface) the 'kpen' layer. This can happen when the kpen !
+       ! layer index identified from the 'iter_scaleh = 1' iteration loop is located at !
+       ! above the kpen layer index identified from   'iter_scaleh = 3' iteration loop. !
+       ! Thus, in the following calculations, we should only use the values in each     !
+       ! variables only up to finally identified 'kpen' layer & 'kpen' interface except ! 
+       ! 'wu' and 'ufrc' at the top interface of 'kpen' layer.    Note that in order to !
+       ! prevent any problems due to these non-physical values, I re-initialized    the !
+       ! values of [ umf(kpen:mkx), emf(kpen:mkx), dwten(kpen+1:mkx), diten(kpen+1:mkx),! 
+       ! fer(kpen:mkx), fdr(kpen+1:mkx), ufrc(kpen:mkx) ] to be zero after 'iter_scaleh'!
+       ! do loop.                                                                       !
+       ! ------------------------------------------------------------------------------ !
+       
+ 45    continue
+
+       ! ------------------------------------------------------------------------------ !
+       ! Calculate 'ppen( < 0 )', updarft penetrative distance from the lower interface !
+       ! of 'kpen' layer. Note that bogbot & bogtop at the 'kpen' layer either when fer !
+       ! is zero or non-zero was already calculated above.                              !
+       ! It seems that below qudarature solving formula is valid only when bogbot < 0.  !
+       ! Below solving equation is clearly wrong ! I should revise this !               !
+       ! ------------------------------------------------------------------------------ ! 
+            
+       if( drage .eq. 0._r8 ) then
+           aquad =  ( bogtop - bogbot ) / ( ps0(kpen) - ps0(kpen-1) )
+           bquad =  2._r8 * bogbot
+           cquad = -wu(kpen-1)**2 * rho0j
+           call roots(aquad,bquad,cquad,xc1,xc2,status)
+           if( status .eq. 0 ) then
+               if( xc1 .le. 0._r8 .and. xc2 .le. 0._r8 ) then
+                   ppen = max( xc1, xc2 )
+                   ppen = min( 0._r8,max( -dp0(kpen), ppen ) )  
+               elseif( xc1 .gt. 0._r8 .and. xc2 .gt. 0._r8 ) then
+                   ppen = -dp0(kpen)
+                   write(iulog,*) 'Warning : UW-Cumulus penetrates upto kpen interface'
+#ifdef WRF_PORT
+                   call wrf_message(iulog)
+#endif
+               else
+                   ppen = min( xc1, xc2 )
+                   ppen = min( 0._r8,max( -dp0(kpen), ppen ) )  
+               endif
+           else
+               ppen = -dp0(kpen)
+               write(iulog,*) 'Warning : UW-Cumulus penetrates upto kpen interface'
+#ifdef WRF_PORT
+               call wrf_message(iulog)
+#endif
+           endif       
+       else 
+           ppen = compute_ppen(wtwb,drage,bogbot,bogtop,rho0j,dp0(kpen))
+       endif
+       if( ppen .eq. -dp0(kpen) .or. ppen .eq. 0._r8 ) limit_ppen(i) = 1._r8
+
+       ! -------------------------------------------------------------------- !
+       ! Re-calculate the amount of expelled condensate from cloud updraft    !
+       ! at the cumulus top. This is necessary for refined calculations of    !
+       ! bulk cloud microphysics at the cumulus top. Note that ppen < 0._r8   !
+       ! In the below, I explicitly calculate 'thlu_top' & 'qtu_top' by       !
+       ! using non-zero 'fer(kpen)'.                                          !    
+       ! -------------------------------------------------------------------- !
+
+       if( fer(kpen)*(-ppen) .lt. 1.e-4_r8 ) then
+           thlu_top = thlu(kpen-1) + ( thl0(kpen) + ssthl0(kpen) * (-ppen) / 2._r8 - thlu(kpen-1) ) * fer(kpen) * (-ppen)
+           qtu_top  =  qtu(kpen-1) + (  qt0(kpen) +  ssqt0(kpen) * (-ppen) / 2._r8  - qtu(kpen-1) ) * fer(kpen) * (-ppen)
+       else
+           thlu_top = ( thl0(kpen) + ssthl0(kpen) / fer(kpen) - ssthl0(kpen) * (-ppen) / 2._r8 ) - &
+                      ( thl0(kpen) + ssthl0(kpen) * (-ppen) / 2._r8 - thlu(kpen-1) + ssthl0(kpen) / fer(kpen) ) * exp(-fer(kpen) * (-ppen))
+           qtu_top  = ( qt0(kpen)  +  ssqt0(kpen) / fer(kpen) -  ssqt0(kpen) * (-ppen) / 2._r8 ) - &  
+                      ( qt0(kpen)  +  ssqt0(kpen) * (-ppen) / 2._r8 -  qtu(kpen-1) +  ssqt0(kpen) / fer(kpen) ) * exp(-fer(kpen) * (-ppen))
+       end if
+
+       call conden(ps0(kpen-1)+ppen,thlu_top,qtu_top,thj,qvj,qlj,qij,qse,id_check,qsat)
+       if( id_check .eq. 1 ) then
+           exit_conden(i) = 1._r8
+           id_exit = .true.
+           go to 333
+       end if
+       exntop = ((ps0(kpen-1)+ppen)/p00)**rovcp
+       if( (qlj + qij) .gt. criqc ) then
+            dwten(kpen) = ( ( qlj + qij ) - criqc ) * qlj / ( qlj + qij )
+            diten(kpen) = ( ( qlj + qij ) - criqc ) * qij / ( qlj + qij )
+            qtu_top  = qtu_top - dwten(kpen) - diten(kpen)
+            thlu_top = thlu_top + (xlv/cp/exntop)*dwten(kpen) + (xls/cp/exntop)*diten(kpen) 
+       else
+            dwten(kpen) = 0._r8
+            diten(kpen) = 0._r8
+       endif      
+ 
+       ! ----------------------------------------------------------------------- !
+       ! Calculate cumulus scale height as the top height that cumulus can reach.!
+       ! ----------------------------------------------------------------------- !
+       
+       rhos0j = ps0(kpen-1)/(r*0.5_r8*(thv0bot(kpen)+thv0top(kpen-1))*exns0(kpen-1))  
+       cush   = zs0(kpen-1) - ppen/rhos0j/g
+       scaleh = cush 
+
+    end do   ! End of 'iter_scaleh' loop.   
+
+       ! -------------------------------------------------------------------- !   
+       ! The 'forcedCu' is logical identifier saying whether cumulus updraft  !
+       ! overcome the buoyancy barrier just above the PBL top. If it is true, !
+       ! cumulus did not overcome the barrier -  this is a shallow convection !
+       ! with negative cloud buoyancy, mimicking  shallow continental cumulus !
+       ! convection. Depending on 'forcedCu' parameter, treatment of heat  &  !
+       ! moisture fluxes at the entraining interfaces, 'kbup <= k < kpen - 1' !
+       ! will be set up in a different ways, as will be shown later.          !
+       ! -------------------------------------------------------------------- !
+ 
+       if( kbup .eq. krel ) then 
+           forcedCu = .true.
+           limit_shcu(i) = 1._r8
+       else
+           forcedCu = .false.
+           limit_shcu(i) = 0._r8
+       endif  
+       
+       ! ------------------------------------------------------------------ !
+       ! Filtering of unerasonable cumulus adjustment here.  This is a very !
+       ! important process which should be done cautiously. Various ways of !
+       ! filtering are possible depending on cases mainly using the indices !
+       ! of key layers - 'klcl','kinv','krel','klfc','kbup','kpen'. At this !
+       ! stage, the followings are all possible : 'kinv >= 2', 'klcl >= 1', !
+       ! 'krel >= kinv', 'kbup >= krel', 'kpen >= krel'. I must design this !
+       ! filtering very cautiously, in such that none of  realistic cumulus !
+       ! convection is arbitrarily turned-off. Potentially, I might turn-off! 
+       ! cumulus convection if layer-mean 'ql > 0' in the 'kinv-1' layer,in !
+       ! order to suppress cumulus convection growing, based at the Sc top. ! 
+       ! This is one of potential future modifications. Note that ppen < 0. !
+       ! ------------------------------------------------------------------ !
+
+       cldhgt = ps0(kpen-1) + ppen
+       if( forcedCu ) then
+           ! write(iulog,*) 'forcedCu - did not overcome initial buoyancy barrier'
+           exit_cufilter(i) = 1._r8
+           id_exit = .true.
+           go to 333
+       end if
+       ! Limit 'additional shallow cumulus' for DYCOMS simulation.
+       ! if( cldhgt.ge.88000._r8 ) then
+       !     id_exit = .true.
+       !     go to 333
+       ! end if
+       
+       ! ------------------------------------------------------------------------------ !
+       ! Re-initializing some key variables above the 'kpen' layer in order to suppress !
+       ! the influence of non-physical values above 'kpen', in association with the use !
+       ! of 'iter_scaleh' loop. Note that umf, emf,  ufrc are defined at the interfaces !
+       ! (0:mkx), while 'dwten','diten', 'fer', 'fdr' are defined at layer mid-points.  !
+       ! Initialization of 'fer' and 'fdr' is for correct writing purpose of diagnostic !
+       ! output. Note that we set umf(kpen)=emf(kpen)=ufrc(kpen)=0, in consistent  with !
+       ! wtw < 0  at the top interface of 'kpen' layer. However, we still have non-zero !
+       ! expelled cloud condensate in the 'kpen' layer.                                 !
+       ! ------------------------------------------------------------------------------ !
+
+       umf(kpen:mkx)     = 0._r8
+       emf(kpen:mkx)     = 0._r8
+       ufrc(kpen:mkx)    = 0._r8
+       dwten(kpen+1:mkx) = 0._r8
+       diten(kpen+1:mkx) = 0._r8
+       fer(kpen+1:mkx)   = 0._r8
+       fdr(kpen+1:mkx)   = 0._r8
+       
+       ! ------------------------------------------------------------------------ !
+       ! Calculate downward penetrative entrainment mass flux, 'emf(k) < 0',  and !
+       ! thermodynamic properties of penetratively entrained airs at   entraining !
+       ! interfaces. emf(k) is defined from the top interface of the  layer  kbup !
+       ! to the bottom interface of the layer 'kpen'. Note even when  kbup = krel,!
+       ! i.e.,even when 'kbup' was not updated in the above buoyancy  sorting  do !
+       ! loop (i.e., 'kbup' remains as the initialization value),   below do loop !
+       ! of penetrative entrainment flux can be performed without  any conceptual !
+       ! or logical problems, because we have already computed all  the variables !
+       ! necessary for performing below penetrative entrainment block.            !
+       ! In the below 'do' loop, 'k' is an interface index at which non-zero 'emf'! 
+       ! (penetrative entrainment mass flux) is calculated. Since cumulus updraft !
+       ! is negatively buoyant in the layers between the top interface of 'kbup'  !
+       ! layer (interface index, kbup) and the top interface of 'kpen' layer, the !
+       ! fractional lateral entrainment, fer(k) within these layers will be close !
+       ! to zero - so it is likely that only strong lateral detrainment occurs in !
+       ! thses layers. Under this situation,we can easily calculate the amount of !
+       ! detrainment cumulus air into these negatively buoyanct layers by  simply !
+       ! comparing cumulus updraft mass fluxes between the base and top interface !
+       ! of each layer: emf(k) = emf(k-1)*exp(-fdr(k)*dp0(k))                     !
+       !                       ~ emf(k-1)*(1-rei(k)*dp0(k))                       !
+       !                emf(k-1)-emf(k) ~ emf(k-1)*rei(k)*dp0(k)                  !
+       ! Current code assumes that about 'rpen~10' times of these detrained  mass !
+       ! are penetratively re-entrained down into the 'k-1' interface. And all of !
+       ! these detrained masses are finally dumped down into the top interface of !
+       ! 'kbup' layer. Thus, the amount of penetratively entrained air across the !
+       ! top interface of 'kbup' layer with 'rpen~10' becomes too large.          !
+       ! Note that this penetrative entrainment part can be completely turned-off !
+       ! and we can simply use normal buoyancy-sorting involved turbulent  fluxes !
+       ! by modifying 'penetrative entrainment fluxes' part below.                !
+       ! ------------------------------------------------------------------------ !
+       
+       ! -----------------------------------------------------------------------!
+       ! Calculate entrainment mass flux and conservative scalars of entraining !
+       ! free air at interfaces of 'kbup <= k < kpen - 1'                       !
+       ! ---------------------------------------------------------------------- !
+ 
+       do k = 0, mkx
+          thlu_emf(k) = thlu(k)
+          qtu_emf(k)  = qtu(k)
+          uu_emf(k)   = uu(k)
+          vu_emf(k)   = vu(k)
+          do m = 1, ncnst
+             tru_emf(k,m)  = tru(k,m)
+          enddo
+       end do
+
+       do k = kpen - 1, kbup, -1  ! Here, 'k' is an interface index at which
+                                  ! penetrative entrainment fluxes are calculated. 
+                                  
+          rhos0j = ps0(k) / ( r * 0.5_r8 * ( thv0bot(k+1) + thv0top(k) ) * exns0(k) )
+
+          if( k .eq. kpen - 1 ) then
+
+             ! ------------------------------------------------------------------------ ! 
+             ! Note that 'ppen' has already been calculated in the above 'iter_scaleh'  !
+             ! loop assuming zero lateral entrainmentin the layer 'kpen'.               !
+             ! ------------------------------------------------------------------------ !       
+             
+             ! -------------------------------------------------------------------- !
+             ! Calculate returning mass flux, emf ( < 0 )                           !
+             ! Current penetrative entrainment rate with 'rpen~10' is too large and !
+             ! future refinement is necessary including the definition of 'thl','qt'! 
+             ! of penetratively entrained air.  Penetratively entrained airs across !
+             ! the 'kpen-1' interface is assumed to have the properties of the base !
+             ! interface of 'kpen' layer. Note that 'emf ~ - umf/ufrc = - w * rho'. !
+             ! Thus, below limit sets an upper limit of |emf| to be ~ 10cm/s, which !
+             ! is very loose constraint. Here, I used more restricted constraint on !
+             ! the limit of emf, assuming 'emf' cannot exceed a net mass within the !
+             ! layer above the interface. Similar to the case of warming and drying !
+             ! due to cumulus updraft induced compensating subsidence,  penetrative !
+             ! entrainment induces compensating upwelling -     in order to prevent !  
+             ! numerical instability in association with compensating upwelling, we !
+             ! should similarily limit the amount of penetrative entrainment at the !
+             ! interface by the amount of masses within the layer just above the    !
+             ! penetratively entraining interface.                                  !
+             ! -------------------------------------------------------------------- !
+             
+             if( ( umf(k)*ppen*rei(kpen)*rpen ) .lt. -0.1_r8*rhos0j )         limit_emf(i) = 1._r8
+             if( ( umf(k)*ppen*rei(kpen)*rpen ) .lt. -0.9_r8*dp0(kpen)/g/dt ) limit_emf(i) = 1._r8             
+
+             emf(k) = max( max( umf(k)*ppen*rei(kpen)*rpen, -0.1_r8*rhos0j), -0.9_r8*dp0(kpen)/g/dt)
+             thlu_emf(k) = thl0(kpen) + ssthl0(kpen) * ( ps0(k) - p0(kpen) )
+             qtu_emf(k)  = qt0(kpen)  + ssqt0(kpen)  * ( ps0(k) - p0(kpen) )
+             uu_emf(k)   = u0(kpen)   + ssu0(kpen)   * ( ps0(k) - p0(kpen) )     
+             vu_emf(k)   = v0(kpen)   + ssv0(kpen)   * ( ps0(k) - p0(kpen) )   
+             do m = 1, ncnst
+                tru_emf(k,m)  = tr0(kpen,m)  + sstr0(kpen,m)  * ( ps0(k) - p0(kpen) )
+             enddo
+
+          else ! if(k.lt.kpen-1). 
+              
+             ! --------------------------------------------------------------------------- !
+             ! Note we are coming down from the higher interfaces to the lower interfaces. !
+             ! Also note that 'emf < 0'. So, below operation is a summing not subtracting. !
+             ! In order to ensure numerical stability, I imposed a modified correct limit  ! 
+             ! of '-0.9*dp0(k+1)/g/dt' on emf(k).                                          !
+             ! --------------------------------------------------------------------------- !
+
+             if( use_cumpenent ) then  ! Original Cumulative Penetrative Entrainment
+
+                 if( ( emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.1_r8*rhos0j )        limit_emf(i) = 1
+                 if( ( emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.9_r8*dp0(k+1)/g/dt ) limit_emf(i) = 1         
+                 emf(k) = max(max(emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen, -0.1_r8*rhos0j), -0.9_r8*dp0(k+1)/g/dt )    
+                 if( abs(emf(k)) .gt. abs(emf(k+1)) ) then
+                     thlu_emf(k) = ( thlu_emf(k+1) * emf(k+1) + thl0(k+1) * ( emf(k) - emf(k+1) ) ) / emf(k)
+                     qtu_emf(k)  = ( qtu_emf(k+1)  * emf(k+1) + qt0(k+1)  * ( emf(k) - emf(k+1) ) ) / emf(k)
+                     uu_emf(k)   = ( uu_emf(k+1)   * emf(k+1) + u0(k+1)   * ( emf(k) - emf(k+1) ) ) / emf(k)
+                     vu_emf(k)   = ( vu_emf(k+1)   * emf(k+1) + v0(k+1)   * ( emf(k) - emf(k+1) ) ) / emf(k)
+                     do m = 1, ncnst
+                        tru_emf(k,m)  = ( tru_emf(k+1,m)  * emf(k+1) + tr0(k+1,m)  * ( emf(k) - emf(k+1) ) ) / emf(k)
+                     enddo
+                 else   
+                     thlu_emf(k) = thl0(k+1)
+                     qtu_emf(k)  =  qt0(k+1)
+                     uu_emf(k)   =   u0(k+1)
+                     vu_emf(k)   =   v0(k+1)
+                     do m = 1, ncnst
+                        tru_emf(k,m)  =  tr0(k+1,m)
+                     enddo
+                 endif   
+                     
+             else ! Alternative Non-Cumulative Penetrative Entrainment
+
+                 if( ( -umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.1_r8*rhos0j )        limit_emf(i) = 1
+                 if( ( -umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.9_r8*dp0(k+1)/g/dt ) limit_emf(i) = 1         
+                 emf(k) = max(max(-umf(k)*dp0(k+1)*rei(k+1)*rpen, -0.1_r8*rhos0j), -0.9_r8*dp0(k+1)/g/dt )    
+                 thlu_emf(k) = thl0(k+1)
+                 qtu_emf(k)  =  qt0(k+1)
+                 uu_emf(k)   =   u0(k+1)
+                 vu_emf(k)   =   v0(k+1)
+                 do m = 1, ncnst
+                    tru_emf(k,m)  =  tr0(k+1,m)
+                 enddo
+
+             endif
+
+          endif
+
+          ! ---------------------------------------------------------------------------- !
+          ! In this GCM modeling framework,  all what we should do is to calculate  heat !
+          ! and moisture fluxes at the given geometrically-fixed height interfaces -  we !
+          ! don't need to worry about movement of material height surface in association !
+          ! with compensating subsidence or unwelling, in contrast to the bulk modeling. !
+          ! In this geometrically fixed height coordinate system, heat and moisture flux !
+          ! at the geometrically fixed height handle everything - a movement of material !
+          ! surface is implicitly treated automatically. Note that in terms of turbulent !
+          ! heat and moisture fluxes at model interfaces, both the cumulus updraft  mass !
+          ! flux and penetratively entraining mass flux play the same role -both of them ! 
+          ! warms and dries the 'kbup' layer, cools and moistens the 'kpen' layer,   and !
+          ! cools and moistens any intervening layers between 'kbup' and 'kpen' layers.  !
+          ! It is important to note these identical roles on turbulent heat and moisture !
+          ! fluxes of 'umf' and 'emf'.                                                   !
+          ! When 'kbup' is a stratocumulus-topped PBL top interface,  increase of 'rpen' !
+          ! is likely to strongly diffuse stratocumulus top interface,  resulting in the !
+          ! reduction of cloud fraction. In this sense, the 'kbup' interface has a  very !
+          ! important meaning and role : across the 'kbup' interface, strong penetrative !
+          ! entrainment occurs, thus any sharp gradient properties across that interface !
+          ! are easily diffused through strong mass exchange. Thus, an initialization of ! 
+          ! 'kbup' (and also 'kpen') should be done very cautiously as mentioned before. ! 
+          ! In order to prevent this stron diffusion for the shallow cumulus convection  !
+          ! based at the Sc top, it seems to be good to initialize 'kbup = krel', rather !
+          ! that 'kbup = krel-1'.                                                        !
+          ! ---------------------------------------------------------------------------- !
+          
+       end do
+
+       !------------------------------------------------------------------ !
+       !                                                                   ! 
+       ! Compute turbulent heat, moisture, momentum flux at all interfaces !
+       !                                                                   !
+       !------------------------------------------------------------------ !
+       ! It is very important to note that in calculating turbulent fluxes !
+       ! below, we must not double count turbulent flux at any interefaces.!
+       ! In the below, turbulent fluxes at the interfaces (interface index !
+       ! k) are calculated by the following 4 blocks in consecutive order: !
+       !                                                                   !
+       ! (1) " 0 <= k <= kinv - 1 "  : PBL fluxes.                         !
+       !     From 'fluxbelowinv' using reconstructed PBL height. Currently,!
+       !     the reconstructed PBLs are independently calculated for  each !
+       !     individual conservative scalar variables ( qt, thl, u, v ) in !
+       !     each 'fluxbelowinv',  instead of being uniquely calculated by !
+       !     using thvl. Turbulent flux at the surface is assumed to be 0. !
+       ! (2) " kinv <= k <= krel - 1 " : Non-buoyancy sorting fluxes       !
+       !     Assuming cumulus mass flux  and cumulus updraft thermodynamic !
+       !     properties (except u, v which are modified by the PGFc during !
+       !     upward motion) are conserved during a updraft motion from the !
+       !     PBL top interface to the release level. If these layers don't !
+       !     exist (e,g, when 'krel = kinv'), then  current routine do not !
+       !     perform this routine automatically. So I don't need to modify !
+       !     anything.                                                     ! 
+       ! (3) " krel <= k <= kbup - 1 " : Buoyancy sorting fluxes           !
+       !     From laterally entraining-detraining buoyancy sorting plumes. ! 
+       ! (4) " kbup <= k < kpen-1 " : Penetrative entrainment fluxes       !
+       !     From penetratively entraining plumes,                         !
+       !                                                                   !
+       ! In case of normal situation, turbulent interfaces  in each groups !
+       ! are mutually independent of each other. Thus double flux counting !
+       ! or ambiguous flux counting requiring the choice among the above 4 !
+       ! groups do not occur normally. However, in case that cumulus plume !
+       ! could not completely overcome the buoyancy barrier just above the !
+       ! PBL top interface and so 'kbup = krel' (.forcedCu=.true.) ( here, !
+       ! it can be either 'kpen = krel' as the initialization, or ' kpen > !
+       ! krel' if cumulus updraft just penetrated over the top of  release !
+       ! layer ). If this happens, we should be very careful in organizing !
+       ! the sequence of the 4 calculation routines above -  note that the !
+       ! routine located at the later has the higher priority.  Additional ! 
+       ! feature I must consider is that when 'kbup = kinv - 1' (this is a !
+       ! combined situation of 'kbup=krel-1' & 'krel = kinv' when I  chose !
+       ! 'kbup=krel-1' instead of current choice of 'kbup=krel'), a strong !
+       ! penetrative entrainment fluxes exists at the PBL top interface, & !
+       ! all of these fluxes are concentrated (deposited) within the layer ! 
+       ! just below PBL top interface (i.e., 'kinv-1' layer). On the other !
+       ! hand, in case of 'fluxbelowinv', only the compensating subsidence !
+       ! effect is concentrated in the 'kinv-1' layer and 'pure' turbulent !
+       ! heat and moisture fluxes ( 'pure' means the fluxes not associated !
+       ! with compensating subsidence) are linearly distributed throughout !
+       ! the whole PBL. Thus different choice of the above flux groups can !
+       ! produce very different results. Output variable should be written !
+       ! consistently to the choice of computation sequences.              !
+       ! When the case of 'kbup = krel(-1)' happens,another way to dealing !
+       ! with this case is to simply ' exit ' the whole cumulus convection !
+       ! calculation without performing any cumulus convection.     We can !
+       ! choose this approach by specifying a condition in the  'Filtering !
+       ! of unreasonable cumulus adjustment' just after 'iter_scaleh'. But !
+       ! this seems not to be a good choice (although this choice was used !
+       ! previous code ), since it might arbitrary damped-out  the shallow !
+       ! cumulus convection over the continent land, where shallow cumulus ! 
+       ! convection tends to be negatively buoyant.                        !
+       ! ----------------------------------------------------------------- !  
+
+       ! --------------------------------------------------- !
+       ! 1. PBL fluxes :  0 <= k <= kinv - 1                 !
+       !    All the information necessary to reconstruct PBL ! 
+       !    height are passed to 'fluxbelowinv'.             !
+       ! --------------------------------------------------- !
+
+       xsrc  = qtsrc
+       xmean = qt0(kinv)
+       xtop  = qt0(kinv+1) + ssqt0(kinv+1) * ( ps0(kinv)   - p0(kinv+1) )
+       xbot  = qt0(kinv-1) + ssqt0(kinv-1) * ( ps0(kinv-1) - p0(kinv-1) )        
+       call fluxbelowinv( cbmf, ps0(0:mkx), mkx, kinv, dt, xsrc, xmean, xtop, xbot, xflx )
+       qtflx(0:kinv-1) = xflx(0:kinv-1)
+
+       xsrc  = thlsrc
+       xmean = thl0(kinv)
+       xtop  = thl0(kinv+1) + ssthl0(kinv+1) * ( ps0(kinv)   - p0(kinv+1) )
+       xbot  = thl0(kinv-1) + ssthl0(kinv-1) * ( ps0(kinv-1) - p0(kinv-1) )        
+       call fluxbelowinv( cbmf, ps0(0:mkx), mkx, kinv, dt, xsrc, xmean, xtop, xbot, xflx )
+       slflx(0:kinv-1) = cp * exns0(0:kinv-1) * xflx(0:kinv-1)
+
+       xsrc  = usrc
+       xmean = u0(kinv)
+       xtop  = u0(kinv+1) + ssu0(kinv+1) * ( ps0(kinv)   - p0(kinv+1) )
+       xbot  = u0(kinv-1) + ssu0(kinv-1) * ( ps0(kinv-1) - p0(kinv-1) )
+       call fluxbelowinv( cbmf, ps0(0:mkx), mkx, kinv, dt, xsrc, xmean, xtop, xbot, xflx )
+       uflx(0:kinv-1) = xflx(0:kinv-1)
+
+       xsrc  = vsrc
+       xmean = v0(kinv)
+       xtop  = v0(kinv+1) + ssv0(kinv+1) * ( ps0(kinv)   - p0(kinv+1) )
+       xbot  = v0(kinv-1) + ssv0(kinv-1) * ( ps0(kinv-1) - p0(kinv-1) )
+       call fluxbelowinv( cbmf, ps0(0:mkx), mkx, kinv, dt, xsrc, xmean, xtop, xbot, xflx )
+       vflx(0:kinv-1) = xflx(0:kinv-1)
+
+       do m = 1, ncnst
+          xsrc  = trsrc(m)
+          xmean = tr0(kinv,m)
+          xtop  = tr0(kinv+1,m) + sstr0(kinv+1,m) * ( ps0(kinv)   - p0(kinv+1) )
+          xbot  = tr0(kinv-1,m) + sstr0(kinv-1,m) * ( ps0(kinv-1) - p0(kinv-1) )        
+          call fluxbelowinv( cbmf, ps0(0:mkx), mkx, kinv, dt, xsrc, xmean, xtop, xbot, xflx )
+          trflx(0:kinv-1,m) = xflx(0:kinv-1)
+       enddo
+
+       ! -------------------------------------------------------------- !
+       ! 2. Non-buoyancy sorting fluxes : kinv <= k <= krel - 1         !
+       !    Note that when 'krel = kinv', below block is never executed !
+       !    as in a desirable, expected way ( but I must check  if this !
+       !    is the case ). The non-buoyancy sorting fluxes are computed !
+       !    only when 'krel > kinv'.                                    !
+       ! -------------------------------------------------------------- !          
+
+       uplus = 0._r8
+       vplus = 0._r8
+       do k = kinv, krel - 1
+          kp1 = k + 1
+          qtflx(k) = cbmf * ( qtsrc  - (  qt0(kp1) +  ssqt0(kp1) * ( ps0(k) - p0(kp1) ) ) )          
+          slflx(k) = cbmf * ( thlsrc - ( thl0(kp1) + ssthl0(kp1) * ( ps0(k) - p0(kp1) ) ) ) * cp * exns0(k)
+          uplus    = uplus + PGFc * ssu0(k) * ( ps0(k) - ps0(k-1) )
+          vplus    = vplus + PGFc * ssv0(k) * ( ps0(k) - ps0(k-1) )
+          uflx(k)  = cbmf * ( usrc + uplus -  (  u0(kp1)  +   ssu0(kp1) * ( ps0(k) - p0(kp1) ) ) ) 
+          vflx(k)  = cbmf * ( vsrc + vplus -  (  v0(kp1)  +   ssv0(kp1) * ( ps0(k) - p0(kp1) ) ) )
+          do m = 1, ncnst
+             trflx(k,m) = cbmf * ( trsrc(m)  - (  tr0(kp1,m) +  sstr0(kp1,m) * ( ps0(k) - p0(kp1) ) ) )
+          enddo          
+       end do
+
+       ! ------------------------------------------------------------------------ !
+       ! 3. Buoyancy sorting fluxes : krel <= k <= kbup - 1                       !
+       !    In case that 'kbup = krel - 1 ' ( or even in case 'kbup = krel' ),    ! 
+       !    buoyancy sorting fluxes are not calculated, which is consistent,      !
+       !    desirable feature.                                                    !  
+       ! ------------------------------------------------------------------------ !
+
+       do k = krel, kbup - 1      
+          kp1 = k + 1
+          slflx(k) = cp * exns0(k) * umf(k) * ( thlu(k) - ( thl0(kp1) + ssthl0(kp1) * ( ps0(k) - p0(kp1) ) ) )
+          qtflx(k) = umf(k) * ( qtu(k) - ( qt0(kp1) + ssqt0(kp1) * ( ps0(k) - p0(kp1) ) ) )
+          uflx(k)  = umf(k) * ( uu(k) - ( u0(kp1) + ssu0(kp1) * ( ps0(k) - p0(kp1) ) ) )
+          vflx(k)  = umf(k) * ( vu(k) - ( v0(kp1) + ssv0(kp1) * ( ps0(k) - p0(kp1) ) ) )
+          do m = 1, ncnst
+             trflx(k,m) = umf(k) * ( tru(k,m) - ( tr0(kp1,m) + sstr0(kp1,m) * ( ps0(k) - p0(kp1) ) ) )
+          enddo
+       end do
+
+       ! ------------------------------------------------------------------------- !
+       ! 4. Penetrative entrainment fluxes : kbup <= k <= kpen - 1                 !
+       !    The only confliction that can happen is when 'kbup = kinv-1'. For this !
+       !    case, turbulent flux at kinv-1 is calculated  both from 'fluxbelowinv' !
+       !    and here as penetrative entrainment fluxes.  Since penetrative flux is !
+       !    calculated later, flux at 'kinv - 1 ' will be that of penetrative flux.!
+       !    However, turbulent flux calculated at 'kinv - 1' from penetrative entr.!
+       !    is less attractable,  since more reasonable turbulent flux at 'kinv-1' !
+       !    should be obtained from 'fluxbelowinv', by considering  re-constructed ! 
+       !    inversion base height. This conflicting problem can be solved if we can!
+       !    initialize 'kbup = krel', instead of kbup = krel - 1. This choice seems!
+       !    to be more reasonable since it is not conflicted with 'fluxbelowinv' in!
+       !    calculating fluxes at 'kinv - 1' ( for this case, flux at 'kinv-1' is  !
+       !    always from 'fluxbelowinv' ), and flux at 'krel-1' is calculated from  !
+       !    the non-buoyancy sorting flux without being competed with penetrative  !
+       !    entrainment fluxes. Even when we use normal cumulus flux instead of    !
+       !    penetrative entrainment fluxes at 'kbup <= k <= kpen-1' interfaces,    !
+       !    the initialization of kbup=krel perfectly works without any conceptual !
+       !    confliction. Thus it seems to be much better to choose 'kbup = krel'   !
+       !    initialization of 'kbup', which is current choice.                     !
+       !    Note that below formula uses conventional updraft cumulus fluxes for   !
+       !    shallow cumulus which did not overcome the first buoyancy barrier above!
+       !    PBL top while uses penetrative entrainment fluxes for the other cases  !
+       !    'kbup <= k <= kpen-1' interfaces. Depending on cases, however, I can   !
+       !    selelct different choice.                                              !
+       ! ------------------------------------------------------------------------------------------------------------------ !
+       !   if( forcedCu ) then                                                                                              !
+       !       slflx(k) = cp * exns0(k) * umf(k) * ( thlu(k) - ( thl0(kp1) + ssthl0(kp1) * ( ps0(k) - p0(kp1) ) ) )         !
+       !       qtflx(k) =                 umf(k) * (  qtu(k) - (  qt0(kp1) +  ssqt0(kp1) * ( ps0(k) - p0(kp1) ) ) )         !
+       !       uflx(k)  =                 umf(k) * (   uu(k) - (   u0(kp1) +   ssu0(kp1) * ( ps0(k) - p0(kp1) ) ) )         !
+       !       vflx(k)  =                 umf(k) * (   vu(k) - (   v0(kp1) +   ssv0(kp1) * ( ps0(k) - p0(kp1) ) ) )         !
+       !       do m = 1, ncnst                                                                                              !
+       !          trflx(k,m) = umf(k) * ( tru(k,m) - ( tr0(kp1,m) + sstr0(kp1,m) * ( ps0(k) - p0(kp1) ) ) )                 !
+       !       enddo                                                                                                        !
+       !   else                                                                                                             !
+       !       slflx(k) = cp * exns0(k) * emf(k) * ( thlu_emf(k) - ( thl0(k) + ssthl0(k) * ( ps0(k) - p0(k) ) ) )           !
+       !       qtflx(k) =                 emf(k) * (  qtu_emf(k) - (  qt0(k) +  ssqt0(k) * ( ps0(k) - p0(k) ) ) )           !
+       !       uflx(k)  =                 emf(k) * (   uu_emf(k) - (   u0(k) +   ssu0(k) * ( ps0(k) - p0(k) ) ) )           !
+       !       vflx(k)  =                 emf(k) * (   vu_emf(k) - (   v0(k) +   ssv0(k) * ( ps0(k) - p0(k) ) ) )           !
+       !       do m = 1, ncnst                                                                                              !
+       !          trflx(k,m) = emf(k) * ( tru_emf(k,m) - ( tr0(k,m) + sstr0(k,m) * ( ps0(k) - p0(k) ) ) )                   !
+       !       enddo                                                                                                        !
+       !   endif                                                                                                            !
+       !                                                                                                                    !
+       !   if( use_uppenent ) then ! Combined Updraft + Penetrative Entrainment Flux                                        !
+       !       slflx(k) = cp * exns0(k) * umf(k) * ( thlu(k)     - ( thl0(kp1) + ssthl0(kp1) * ( ps0(k) - p0(kp1) ) ) ) + & !
+       !                  cp * exns0(k) * emf(k) * ( thlu_emf(k) - (   thl0(k) +   ssthl0(k) * ( ps0(k) - p0(k) ) ) )       !
+       !       qtflx(k) =                 umf(k) * (  qtu(k)     - (  qt0(kp1) +  ssqt0(kp1) * ( ps0(k) - p0(kp1) ) ) ) + & !
+       !                                  emf(k) * (  qtu_emf(k) - (    qt0(k) +    ssqt0(k) * ( ps0(k) - p0(k) ) ) )       !                   
+       !       uflx(k)  =                 umf(k) * (   uu(k)     - (   u0(kp1) +   ssu0(kp1) * ( ps0(k) - p0(kp1) ) ) ) + & !
+       !                                  emf(k) * (   uu_emf(k) - (     u0(k) +     ssu0(k) * ( ps0(k) - p0(k) ) ) )       !                      
+       !       vflx(k)  =                 umf(k) * (   vu(k)     - (   v0(kp1) +   ssv0(kp1) * ( ps0(k) - p0(kp1) ) ) ) + & !
+       !                                  emf(k) * (   vu_emf(k) - (     v0(k) +     ssv0(k) * ( ps0(k) - p0(k) ) ) )       !                     
+       !       do m = 1, ncnst                                                                                              !
+       !          trflx(k,m) = umf(k) * ( tru(k,m) - ( tr0(kp1,m) + sstr0(kp1,m) * ( ps0(k) - p0(kp1) ) ) ) + &             ! 
+       !                       emf(k) * ( tru_emf(k,m) - ( tr0(k,m) + sstr0(k,m) * ( ps0(k) - p0(k) ) ) )                   ! 
+       !       enddo                                                                                                        !
+       ! ------------------------------------------------------------------------------------------------------------------ !
+
+       do k = kbup, kpen - 1      
+          kp1 = k + 1
+          slflx(k) = cp * exns0(k) * emf(k) * ( thlu_emf(k) - ( thl0(k) + ssthl0(k) * ( ps0(k) - p0(k) ) ) )
+          qtflx(k) =                 emf(k) * (  qtu_emf(k) - (  qt0(k) +  ssqt0(k) * ( ps0(k) - p0(k) ) ) ) 
+          uflx(k)  =                 emf(k) * (   uu_emf(k) - (   u0(k) +   ssu0(k) * ( ps0(k) - p0(k) ) ) ) 
+          vflx(k)  =                 emf(k) * (   vu_emf(k) - (   v0(k) +   ssv0(k) * ( ps0(k) - p0(k) ) ) )
+          do m = 1, ncnst
+             trflx(k,m) = emf(k) * ( tru_emf(k,m) - ( tr0(k,m) + sstr0(k,m) * ( ps0(k) - p0(k) ) ) ) 
+          enddo
+       end do
+
+       ! ------------------------------------------- !
+       ! Turn-off cumulus momentum flux as an option !
+       ! ------------------------------------------- !
+
+       if( .not. use_momenflx ) then
+           uflx(0:mkx) = 0._r8
+           vflx(0:mkx) = 0._r8
+       endif       
+
+       ! -------------------------------------------------------- !
+       ! Condensate tendency by compensating subsidence/upwelling !
+       ! -------------------------------------------------------- !
+       
+       uemf(0:mkx)         = 0._r8
+       do k = 0, kinv - 2  ! Assume linear updraft mass flux within the PBL.
+          uemf(k) = cbmf * ( ps0(0) - ps0(k) ) / ( ps0(0) - ps0(kinv-1) ) 
+       end do
+       uemf(kinv-1:krel-1) = cbmf
+       uemf(krel:kbup-1)   = umf(krel:kbup-1)
+       uemf(kbup:kpen-1)   = emf(kbup:kpen-1) ! Only use penetrative entrainment flux consistently.
+
+       comsub(1:mkx) = 0._r8
+       do k = 1, kpen
+          comsub(k)  = 0.5_r8 * ( uemf(k) + uemf(k-1) ) 
+       end do    
+
+       do k = 1, kpen
+          if( comsub(k) .ge. 0._r8 ) then
+              if( k .eq. mkx ) then
+                  thlten_sub = 0._r8
+                  qtten_sub  = 0._r8
+                  qlten_sub  = 0._r8
+                  qiten_sub  = 0._r8
+                  nlten_sub  = 0._r8
+                  niten_sub  = 0._r8
+              else
+                  thlten_sub = g * comsub(k) * ( thl0(k+1) - thl0(k) ) / ( p0(k) - p0(k+1) )
+                  qtten_sub  = g * comsub(k) * (  qt0(k+1) -  qt0(k) ) / ( p0(k) - p0(k+1) )
+                  qlten_sub  = g * comsub(k) * (  ql0(k+1) -  ql0(k) ) / ( p0(k) - p0(k+1) )
+                  qiten_sub  = g * comsub(k) * (  qi0(k+1) -  qi0(k) ) / ( p0(k) - p0(k+1) )
+                  nlten_sub  = g * comsub(k) * (  tr0(k+1,ixnumliq) -  tr0(k,ixnumliq) ) / ( p0(k) - p0(k+1) )
+                  niten_sub  = g * comsub(k) * (  tr0(k+1,ixnumice) -  tr0(k,ixnumice) ) / ( p0(k) - p0(k+1) )
+              endif
+          else
+              if( k .eq. 1 ) then
+                  thlten_sub = 0._r8
+                  qtten_sub  = 0._r8
+                  qlten_sub  = 0._r8
+                  qiten_sub  = 0._r8
+                  nlten_sub  = 0._r8
+                  niten_sub  = 0._r8
+              else
+                  thlten_sub = g * comsub(k) * ( thl0(k) - thl0(k-1) ) / ( p0(k-1) - p0(k) )
+                  qtten_sub  = g * comsub(k) * (  qt0(k) -  qt0(k-1) ) / ( p0(k-1) - p0(k) )
+                  qlten_sub  = g * comsub(k) * (  ql0(k) -  ql0(k-1) ) / ( p0(k-1) - p0(k) )
+                  qiten_sub  = g * comsub(k) * (  qi0(k) -  qi0(k-1) ) / ( p0(k-1) - p0(k) )
+                  nlten_sub  = g * comsub(k) * (  tr0(k,ixnumliq) -  tr0(k-1,ixnumliq) ) / ( p0(k-1) - p0(k) )
+                  niten_sub  = g * comsub(k) * (  tr0(k,ixnumice) -  tr0(k-1,ixnumice) ) / ( p0(k-1) - p0(k) )
+              endif
+          endif
+          thl_prog = thl0(k) + thlten_sub * dt
+          qt_prog  = max( qt0(k) + qtten_sub * dt, 1.e-12_r8 )
+          call conden(p0(k),thl_prog,qt_prog,thj,qvj,qlj,qij,qse,id_check,qsat)
+          if( id_check .eq. 1 ) then
+              id_exit = .true.
+              go to 333
+          endif
+        ! qlten_sink(k) = ( qlj - ql0(k) ) / dt
+        ! qiten_sink(k) = ( qij - qi0(k) ) / dt
+          qlten_sink(k) = max( qlten_sub, - ql0(k) / dt ) ! For consistency with prognostic macrophysics scheme
+          qiten_sink(k) = max( qiten_sub, - qi0(k) / dt ) ! For consistency with prognostic macrophysics scheme
+          nlten_sink(k) = max( nlten_sub, - tr0(k,ixnumliq) / dt ) 
+          niten_sink(k) = max( niten_sub, - tr0(k,ixnumice) / dt )
+       end do
+
+       ! --------------------------------------------- !
+       !                                               !
+       ! Calculate convective tendencies at each layer ! 
+       !                                               !
+       ! --------------------------------------------- !
+       
+       ! ----------------- !
+       ! Momentum tendency !
+       ! ----------------- !
+       
+       do k = 1, kpen
+          km1 = k - 1 
+          uten(k) = ( uflx(km1) - uflx(k) ) * g / dp0(k)
+          vten(k) = ( vflx(km1) - vflx(k) ) * g / dp0(k) 
+          uf(k)   = u0(k) + uten(k) * dt
+          vf(k)   = v0(k) + vten(k) * dt
+        ! do m = 1, ncnst
+        !    trten(k,m) = ( trflx(km1,m) - trflx(k,m) ) * g / dp0(k)
+        !  ! Limit trten(k,m) such that negative value is not developed.
+        !  ! This limitation does not conserve grid-mean tracers and future
+        !  ! refinement is required for tracer-conserving treatment.
+        !    trten(k,m) = max(trten(k,m),-tr0(k,m)/dt)              
+        ! enddo
+       end do        
+
+       ! ----------------------------------------------------------------- !
+       ! Tendencies of thermodynamic variables.                            ! 
+       ! This part requires a careful treatment of bulk cloud microphysics.!
+       ! Relocations of 'precipitable condensates' either into the surface ! 
+       ! or into the tendency of 'krel' layer will be performed just after !
+       ! finishing the below 'do-loop'.                                    !        
+       ! ----------------------------------------------------------------- !
+       
+       rliq    = 0._r8
+       rainflx = 0._r8
+       snowflx = 0._r8
+
+       do k = 1, kpen
+
+          km1 = k - 1
+
+          ! ------------------------------------------------------------------------------ !
+          ! Compute 'slten', 'qtten', 'qvten', 'qlten', 'qiten', and 'sten'                !
+          !                                                                                !
+          ! Key assumptions made in this 'cumulus scheme' are :                            !
+          ! 1. Cumulus updraft expels condensate into the environment at the top interface !
+          !    of each layer. Note that in addition to this expel process ('source' term), !
+          !    cumulus updraft can modify layer mean condensate through normal detrainment !
+          !    forcing or compensating subsidence.                                         !
+          ! 2. Expelled water can be either 'sustaining' or 'precipitating' condensate. By !
+          !    definition, 'suataining condensate' will remain in the layer where it was   !
+          !    formed, while 'precipitating condensate' will fall across the base of the   !
+          !    layer where it was formed.                                                  !
+          ! 3. All precipitating condensates are assumed to fall into the release layer or !
+          !    ground as soon as it was formed without being evaporated during the falling !
+          !    process down to the desinated layer ( either release layer of surface ).    !
+          ! ------------------------------------------------------------------------------ !
+
+          ! ------------------------------------------------------------------------- !     
+          ! 'dwten(k)','diten(k)' : Production rate of condensate  within the layer k !
+          !      [ kg/kg/s ]        by the expels of condensate from cumulus updraft. !
+          ! It is important to note that in terms of moisture tendency equation, this !
+          ! is a 'source' term of enviromental 'qt'.  More importantly,  these source !
+          ! are already counted in the turbulent heat and moisture fluxes we computed !
+          ! until now, assuming all the expelled condensate remain in the layer where ! 
+          ! it was formed. Thus, in calculation of 'qtten' and 'slten' below, we MUST !
+          ! NOT add or subtract these terms explicitly in order not to double or miss !
+          ! count, unless some expelled condensates fall down out of the layer.  Note !
+          ! this falling-down process ( i.e., precipitation process ) and  associated !
+          ! 'qtten' and 'slten' and production of surface precipitation flux  will be !
+          ! treated later in 'zm_conv_evap' in 'convect_shallow_tend' subroutine.     ! 
+          ! In below, we are converting expelled cloud condensate into correct unit.  !
+          ! I found that below use of '0.5 * (umf(k-1) + umf(k))' causes conservation !
+          ! errors at some columns in global simulation. So, I returned to originals. !
+          ! This will cause no precipitation flux at 'kpen' layer since umf(kpen)=0.  !
+          ! ------------------------------------------------------------------------- !
+
+          dwten(k) = dwten(k) * 0.5_r8 * ( umf(k-1) + umf(k) ) * g / dp0(k) ! [ kg/kg/s ]
+          diten(k) = diten(k) * 0.5_r8 * ( umf(k-1) + umf(k) ) * g / dp0(k) ! [ kg/kg/s ]  
+
+          ! dwten(k) = dwten(k) * umf(k) * g / dp0(k) ! [ kg/kg/s ]
+          ! diten(k) = diten(k) * umf(k) * g / dp0(k) ! [ kg/kg/s ]
+
+          ! --------------------------------------------------------------------------- !
+          ! 'qrten(k)','qsten(k)' : Production rate of rain and snow within the layer k !
+          !     [ kg/kg/s ]         by cumulus expels of condensates to the environment.!         
+          ! This will be falled-out of the layer where it was formed and will be dumped !
+          ! dumped into the release layer assuming that there is no evaporative cooling !
+          ! while precipitable condensate moves to the relaes level. This is reasonable ! 
+          ! assumtion if cumulus is purely vertical and so the path along which precita !
+          ! ble condensate falls is fully saturared. This 're-allocation' process of    !
+          ! precipitable condensate into the release layer is fully described in this   !
+          ! convection scheme. After that, the dumped water into the release layer will !
+          ! falling down across the base of release layer ( or LCL, if  exact treatment ! 
+          ! is required ) and will be allowed to be evaporated in layers below  release !
+          ! layer, and finally non-zero surface precipitation flux will be calculated.  !
+          ! This latter process will be separately treated 'zm_conv_evap' routine.      !
+          ! --------------------------------------------------------------------------- !
+
+          qrten(k) = frc_rasn * dwten(k)
+          qsten(k) = frc_rasn * diten(k) 
+ 
+          ! ----------------------------------------------------------------------- !         
+          ! 'rainflx','snowflx' : Cumulative rain and snow flux integrated from the ! 
+          !     [ kg/m2/s ]       release leyer to the 'kpen' layer. Note that even !
+          ! though wtw(kpen) < 0 (and umf(kpen) = 0) at the top interface of 'kpen' !
+          ! layer, 'dwten(kpen)' and diten(kpen)  were calculated after calculating !
+          ! explicit cloud top height. Thus below calculation of precipitation flux !
+          ! is correct. Note that  precipitating condensates are formed only in the !
+          ! layers from 'krel' to 'kpen', including the two layers.                 !
+          ! ----------------------------------------------------------------------- !
+
+          rainflx = rainflx + qrten(k) * dp0(k) / g
+          snowflx = snowflx + qsten(k) * dp0(k) / g
+
+          ! ------------------------------------------------------------------------ !
+          ! 'slten(k)','qtten(k)'                                                    !
+          !  Note that 'slflx(k)' and 'qtflx(k)' we have calculated already included !
+          !  all the contributions of (1) expels of condensate (dwten(k), diten(k)), !
+          !  (2) mass detrainment ( delta * umf * ( qtu - qt ) ), & (3) compensating !
+          !  subsidence ( M * dqt / dz ). Thus 'slflx(k)' and 'qtflx(k)' we computed ! 
+          !  is a hybrid turbulent flux containing one part of 'source' term - expel !
+          !  of condensate. In order to calculate 'slten' and 'qtten', we should add !
+          !  additional 'source' term, if any. If the expelled condensate falls down !
+          !  across the base of the layer, it will be another sink (negative source) !
+          !  term.  Note also that we included frictional heating terms in the below !
+          !  calculation of 'slten'.                                                 !
+          ! ------------------------------------------------------------------------ !
+                   
+          slten(k) = ( slflx(km1) - slflx(k) ) * g / dp0(k)
+          if( k .eq. 1 ) then
+              slten(k) = slten(k) - g / 4._r8 / dp0(k) * (                            &
+                                    uflx(k)*(uf(k+1) - uf(k) + u0(k+1) - u0(k)) +     & 
+                                    vflx(k)*(vf(k+1) - vf(k) + v0(k+1) - v0(k)))
+          elseif( k .ge. 2 .and. k .le. kpen-1 ) then
+              slten(k) = slten(k) - g / 4._r8 / dp0(k) * (                            &
+                                    uflx(k)*(uf(k+1) - uf(k) + u0(k+1) - u0(k)) +     &
+                                    uflx(k-1)*(uf(k) - uf(k-1) + u0(k) - u0(k-1)) +   &
+                                    vflx(k)*(vf(k+1) - vf(k) + v0(k+1) - v0(k)) +     &
+                                    vflx(k-1)*(vf(k) - vf(k-1) + v0(k) - v0(k-1)))
+          elseif( k .eq. kpen ) then
+              slten(k) = slten(k) - g / 4._r8 / dp0(k) * (                            &
+                                    uflx(k-1)*(uf(k) - uf(k-1) + u0(k) - u0(k-1)) +   &
+                                    vflx(k-1)*(vf(k) - vf(k-1) + v0(k) - v0(k-1)))
+          endif
+          qtten(k) = ( qtflx(km1) - qtflx(k) ) * g / dp0(k)
+
+          ! ---------------------------------------------------------------------------- !
+          ! Compute condensate tendency, including reserved condensate                   !
+          ! We assume that eventual detachment and detrainment occurs in kbup layer  due !
+          ! to downdraft buoyancy sorting. In the layer above the kbup, only penetrative !
+          ! entrainment exists. Penetrative entrained air is assumed not to contain any  !
+          ! condensate.                                                                  !
+          ! ---------------------------------------------------------------------------- !
+  
+          ! Compute in-cumulus condensate at the layer mid-point.
+
+          if( k .lt. krel .or. k .gt. kpen ) then
+              qlu_mid = 0._r8
+              qiu_mid = 0._r8
+              qlj     = 0._r8
+              qij     = 0._r8
+          elseif( k .eq. krel ) then 
+              call conden(prel,thlu(krel-1),qtu(krel-1),thj,qvj,qlj,qij,qse,id_check,qsat)
+              if( id_check .eq. 1 ) then
+                  exit_conden(i) = 1._r8
+                  id_exit = .true.
+                  go to 333
+              endif
+              qlubelow = qlj       
+              qiubelow = qij       
+              call conden(ps0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check,qsat)
+              if( id_check .eq. 1 ) then
+                  exit_conden(i) = 1._r8
+                  id_exit = .true.
+                  go to 333
+              end if
+              qlu_mid = 0.5_r8 * ( qlubelow + qlj ) * ( prel - ps0(k) )/( ps0(k-1) - ps0(k) )
+              qiu_mid = 0.5_r8 * ( qiubelow + qij ) * ( prel - ps0(k) )/( ps0(k-1) - ps0(k) )
+          elseif( k .eq. kpen ) then 
+              call conden(ps0(k-1)+ppen,thlu_top,qtu_top,thj,qvj,qlj,qij,qse,id_check,qsat)
+              if( id_check .eq. 1 ) then
+                  exit_conden(i) = 1._r8
+                  id_exit = .true.
+                  go to 333
+              end if
+              qlu_mid = 0.5_r8 * ( qlubelow + qlj ) * ( -ppen )        /( ps0(k-1) - ps0(k) )
+              qiu_mid = 0.5_r8 * ( qiubelow + qij ) * ( -ppen )        /( ps0(k-1) - ps0(k) )
+              qlu_top = qlj
+              qiu_top = qij
+          else
+              call conden(ps0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check,qsat)
+              if( id_check .eq. 1 ) then
+                  exit_conden(i) = 1._r8
+                  id_exit = .true.
+                  go to 333
+              end if
+              qlu_mid = 0.5_r8 * ( qlubelow + qlj )
+              qiu_mid = 0.5_r8 * ( qiubelow + qij )
+          endif
+          qlubelow = qlj       
+          qiubelow = qij       
+
+          ! 1. Sustained Precipitation
+
+          qc_l(k) = ( 1._r8 - frc_rasn ) * dwten(k) ! [ kg/kg/s ]
+          qc_i(k) = ( 1._r8 - frc_rasn ) * diten(k) ! [ kg/kg/s ]
+
+          ! 2. Detrained Condensate
+
+          if( k .le. kbup ) then 
+              qc_l(k) = qc_l(k) + g * 0.5_r8 * ( umf(k-1) + umf(k) ) * fdr(k) * qlu_mid ! [ kg/kg/s ]
+              qc_i(k) = qc_i(k) + g * 0.5_r8 * ( umf(k-1) + umf(k) ) * fdr(k) * qiu_mid ! [ kg/kg/s ]
+              qc_lm   =         - g * 0.5_r8 * ( umf(k-1) + umf(k) ) * fdr(k) * ql0(k)  
+              qc_im   =         - g * 0.5_r8 * ( umf(k-1) + umf(k) ) * fdr(k) * qi0(k)
+            ! Below 'nc_lm', 'nc_im' should be used only when frc_rasn = 1.
+              nc_lm   =         - g * 0.5_r8 * ( umf(k-1) + umf(k) ) * fdr(k) * tr0(k,ixnumliq)  
+              nc_im   =         - g * 0.5_r8 * ( umf(k-1) + umf(k) ) * fdr(k) * tr0(k,ixnumice)
+          else
+              qc_lm   = 0._r8
+              qc_im   = 0._r8
+              nc_lm   = 0._r8
+              nc_im   = 0._r8
+          endif
+
+          ! 3. Detached Updraft 
+
+          if( k .eq. kbup ) then
+              qc_l(k) = qc_l(k) + g * umf(k) * qlj     / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
+              qc_i(k) = qc_i(k) + g * umf(k) * qij     / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
+              qc_lm   = qc_lm   - g * umf(k) * ql0(k)  / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
+              qc_im   = qc_im   - g * umf(k) * qi0(k)  / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
+              nc_lm   = nc_lm   - g * umf(k) * tr0(k,ixnumliq)  / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
+              nc_im   = nc_im   - g * umf(k) * tr0(k,ixnumice)  / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
+          endif 
+
+          ! 4. Cumulative Penetrative entrainment detrained in the 'kbup' layer
+          !    Explicitly compute the properties detrained penetrative entrained airs in k = kbup layer.
+
+          if( k .eq. kbup ) then
+              call conden(p0(k),thlu_emf(k),qtu_emf(k),thj,qvj,ql_emf_kbup,qi_emf_kbup,qse,id_check,qsat)
+              if( id_check .eq. 1 ) then
+                  id_exit = .true.
+                  go to 333
+              endif
+              if( ql_emf_kbup .gt. 0._r8 ) then
+                  nl_emf_kbup = tru_emf(k,ixnumliq)
+              else
+                  nl_emf_kbup = 0._r8
+              endif
+              if( qi_emf_kbup .gt. 0._r8 ) then
+                  ni_emf_kbup = tru_emf(k,ixnumice)
+              else
+                  ni_emf_kbup = 0._r8
+              endif
+              qc_lm   = qc_lm   - g * emf(k) * ( ql_emf_kbup - ql0(k) ) / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
+              qc_im   = qc_im   - g * emf(k) * ( qi_emf_kbup - qi0(k) ) / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
+              nc_lm   = nc_lm   - g * emf(k) * ( nl_emf_kbup - tr0(k,ixnumliq) ) / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
+              nc_im   = nc_im   - g * emf(k) * ( ni_emf_kbup - tr0(k,ixnumice) ) / ( ps0(k-1) - ps0(k) ) ! [ kg/kg/s ]
+          endif 
+
+          qlten_det   = qc_l(k) + qc_lm
+          qiten_det   = qc_i(k) + qc_im
+
+          ! --------------------------------------------------------------------------------- !
+          ! 'qlten(k)','qiten(k)','qvten(k)','sten(k)'                                        !
+          ! Note that falling of precipitation will be treated later.                         !
+          ! The prevension of negative 'qv,ql,qi' will be treated later in positive_moisture. !
+          ! --------------------------------------------------------------------------------- ! 
+
+          if( use_expconten ) then
+              if( use_unicondet ) then
+                  qc_l(k) = 0._r8
+                  qc_i(k) = 0._r8 
+                  qlten(k) = frc_rasn * dwten(k) + qlten_sink(k) + qlten_det
+                  qiten(k) = frc_rasn * diten(k) + qiten_sink(k) + qiten_det
+              else 
+                  qlten(k) = qc_l(k) + frc_rasn * dwten(k) + ( max( 0._r8, ql0(k) + ( qc_lm + qlten_sink(k) ) * dt ) - ql0(k) ) / dt
+                  qiten(k) = qc_i(k) + frc_rasn * diten(k) + ( max( 0._r8, qi0(k) + ( qc_im + qiten_sink(k) ) * dt ) - qi0(k) ) / dt
+                  trten(k,ixnumliq) = max( nc_lm + nlten_sink(k), - tr0(k,ixnumliq) / dt )
+                  trten(k,ixnumice) = max( nc_im + niten_sink(k), - tr0(k,ixnumice) / dt )
+              endif
+          else
+              if( use_unicondet ) then
+                  qc_l(k) = 0._r8
+                  qc_i(k) = 0._r8 
+              endif                      
+              qlten(k) = dwten(k) + ( qtten(k) - dwten(k) - diten(k) ) * ( ql0(k) / qt0(k) )
+              qiten(k) = diten(k) + ( qtten(k) - dwten(k) - diten(k) ) * ( qi0(k) / qt0(k) )
+          endif
+
+          qvten(k) = qtten(k) - qlten(k) - qiten(k)
+          sten(k)  = slten(k) + xlv * qlten(k) + xls * qiten(k)
+
+          ! -------------------------------------------------------------------------- !
+          ! 'rliq' : Verticall-integrated 'suspended cloud condensate'                 !
+          !  [m/s]   This is so called 'reserved liquid water'  in other subroutines   ! 
+          ! of CAM3, since the contribution of this term should not be included into   !
+          ! the tendency of each layer or surface flux (precip)  within this cumulus   !
+          ! scheme. The adding of this term to the layer tendency will be done inthe   !
+          ! 'stratiform_tend', just after performing sediment process there.           !
+          ! The main problem of these rather going-back-and-forth and stupid-seeming   ! 
+          ! approach is that the sediment process of suspendened condensate will not   !
+          ! be treated at all in the 'stratiform_tend'.                                !
+          ! Note that 'precip' [m/s] is vertically-integrated total 'rain+snow' formed !
+          ! from the cumulus updraft. Important : in the below, 1000 is rhoh2o ( water !
+          ! density ) [ kg/m^3 ] used for unit conversion from [ kg/m^2/s ] to [ m/s ] !
+          ! for use in stratiform.F90.                                                 !
+          ! -------------------------------------------------------------------------- ! 
+
+          qc(k)  =  qc_l(k) +  qc_i(k)   
+          rliq   =  rliq    + qc(k) * dp0(k) / g / 1000._r8    ! [ m/s ]
+
+       end do
+
+          precip  =  rainflx + snowflx                       ! [ kg/m2/s ]
+          snow    =  snowflx                                 ! [ kg/m2/s ] 
+
+       ! ---------------------------------------------------------------- !
+       ! Now treats the 'evaporation' and 'melting' of rain ( qrten ) and ! 
+       ! snow ( qsten ) during falling process. Below algorithms are from !
+       ! 'zm_conv_evap' but with some modification, which allows separate !
+       ! treatment of 'rain' and 'snow' condensates. Note that I included !
+       ! the evaporation dynamics into the convection scheme for complete !
+       ! development of cumulus scheme especially in association with the ! 
+       ! implicit CIN closure. In compatible with this internal treatment !
+       ! of evaporation, I should modify 'convect_shallow',  in such that !
+       ! 'zm_conv_evap' is not performed when I choose UW PBL-Cu schemes. !                                          
+       ! ---------------------------------------------------------------- !
+
+       evpint_rain    = 0._r8 
+       evpint_snow    = 0._r8
+       flxrain(0:mkx) = 0._r8
+       flxsnow(0:mkx) = 0._r8
+       ntraprd(:mkx)  = 0._r8
+       ntsnprd(:mkx)  = 0._r8
+
+       do k = mkx, 1, -1  ! 'k' is a layer index : 'mkx'('1') is the top ('bottom') layer
+          
+          ! ----------------------------------------------------------------------------- !
+          ! flxsntm [kg/m2/s] : Downward snow flux at the top of each layer after melting.! 
+          ! snowmlt [kg/kg/s] : Snow melting tendency.                                    !
+          ! Below allows melting of snow when it goes down into the warm layer below.     !
+          ! ----------------------------------------------------------------------------- !
+
+          if( t0(k) .gt. 273.16_r8 ) then
+              snowmlt = max( 0._r8, flxsnow(k) * g / dp0(k) ) 
+          else
+              snowmlt = 0._r8
+          endif
+
+          ! ----------------------------------------------------------------- !
+          ! Evaporation rate of 'rain' and 'snow' in the layer k, [ kg/kg/s ] !
+          ! where 'rain' and 'snow' are coming down from the upper layers.    !
+          ! I used the same evaporative efficiency both for 'rain' and 'snow'.!
+          ! Note that evaporation is not allowed in the layers 'k >= krel' by !
+          ! assuming that inside of cumulus cloud, across which precipitation !
+          ! is falling down, is fully saturated.                              !
+          ! The asumptions in association with the 'evplimit_rain(snow)' are  !
+          !   1. Do not allow evaporation to supersate the layer              !
+          !   2. Do not evaporate more than the flux falling into the layer   !
+          !   3. Total evaporation cannot exceed the input total surface flux !
+          ! ----------------------------------------------------------------- !
+
+          status = qsat(t0(k),p0(k),es(1),qs(1),gam(1), 1)          
+          subsat = max( ( 1._r8 - qv0(k)/qs(1) ), 0._r8 )
+          if( noevap_krelkpen ) then
+              if( k .ge. krel ) subsat = 0._r8
+          endif
+
+          evprain  = kevp * subsat * sqrt(flxrain(k)+snowmlt*dp0(k)/g) 
+          evpsnow  = kevp * subsat * sqrt(max(flxsnow(k)-snowmlt*dp0(k)/g,0._r8))
+
+          evplimit = max( 0._r8, ( qw0_in(i,k) - qv0(k) ) / dt ) 
+
+          evplimit_rain = min( evplimit,      ( flxrain(k) + snowmlt * dp0(k) / g ) * g / dp0(k) )
+          evplimit_rain = min( evplimit_rain, ( rainflx - evpint_rain ) * g / dp0(k) )
+          evprain = max(0._r8,min( evplimit_rain, evprain ))
+
+          evplimit_snow = min( evplimit,   max( flxsnow(k) - snowmlt * dp0(k) / g , 0._r8 ) * g / dp0(k) )
+          evplimit_snow = min( evplimit_snow, ( snowflx - evpint_snow ) * g / dp0(k) )
+          evpsnow = max(0._r8,min( evplimit_snow, evpsnow ))
+
+          if( ( evprain + evpsnow ) .gt. evplimit ) then
+                tmp1 = evprain * evplimit / ( evprain + evpsnow )
+                tmp2 = evpsnow * evplimit / ( evprain + evpsnow )
+                evprain = tmp1
+                evpsnow = tmp2
+          endif
+
+          evapc(k) = evprain + evpsnow
+
+          ! ------------------------------------------------------------- !
+          ! Vertically-integrated evaporative fluxes of 'rain' and 'snow' !
+          ! ------------------------------------------------------------- !
+
+          evpint_rain = evpint_rain + evprain * dp0(k) / g
+          evpint_snow = evpint_snow + evpsnow * dp0(k) / g
+
+          ! -------------------------------------------------------------- !
+          ! Net 'rain' and 'snow' production rate in the layer [ kg/kg/s ] !
+          ! -------------------------------------------------------------- !         
+
+          ntraprd(k) = qrten(k) - evprain + snowmlt
+          ntsnprd(k) = qsten(k) - evpsnow - snowmlt
+         
+          ! -------------------------------------------------------------------------------- !
+          ! Downward fluxes of 'rain' and 'snow' fluxes at the base of the layer [ kg/m2/s ] !
+          ! Note that layer index increases with height.                                     !
+          ! -------------------------------------------------------------------------------- !
+
+          flxrain(k-1) = flxrain(k) + ntraprd(k) * dp0(k) / g
+          flxsnow(k-1) = flxsnow(k) + ntsnprd(k) * dp0(k) / g
+          flxrain(k-1) = max( flxrain(k-1), 0._r8 )
+          if( flxrain(k-1) .eq. 0._r8 ) ntraprd(k) = -flxrain(k) * g / dp0(k)
+          flxsnow(k-1) = max( flxsnow(k-1), 0._r8 )         
+          if( flxsnow(k-1) .eq. 0._r8 ) ntsnprd(k) = -flxsnow(k) * g / dp0(k)
+
+          ! ---------------------------------- !
+          ! Calculate thermodynamic tendencies !
+          ! --------------------------------------------------------------------------- !
+          ! Note that equivalently, we can write tendency formula of 'sten' and 'slten' !
+          ! by 'sten(k)  = sten(k) - xlv*evprain  - xls*evpsnow - (xls-xlv)*snowmlt' &  !
+          !    'slten(k) = sten(k) - xlv*qlten(k) - xls*qiten(k)'.                      !
+          ! The above formula is equivalent to the below formula. However below formula !
+          ! is preferred since we have already imposed explicit constraint on 'ntraprd' !
+          ! and 'ntsnprd' in case that flxrain(k-1) < 0 & flxsnow(k-1) < 0._r8          !
+          ! Note : In future, I can elborate the limiting of 'qlten','qvten','qiten'    !
+          !        such that that energy and moisture conservation error is completely  !
+          !        suppressed.                                                          !
+          ! Re-storation to the positive condensate will be performed later below       !
+          ! --------------------------------------------------------------------------- !
+
+          qlten(k) = qlten(k) - qrten(k)
+          qiten(k) = qiten(k) - qsten(k)
+          qvten(k) = qvten(k) + evprain  + evpsnow
+          qtten(k) = qlten(k) + qiten(k) + qvten(k)
+          if( ( qv0(k) + qvten(k)*dt ) .lt. qmin(1) .or. &
+              ( ql0(k) + qlten(k)*dt ) .lt. qmin(2) .or. &
+              ( qi0(k) + qiten(k)*dt ) .lt. qmin(3) ) then
+               limit_negcon(i) = 1._r8
+          end if
+          sten(k)  = sten(k) - xlv*evprain  - xls*evpsnow - (xls-xlv)*snowmlt
+          slten(k) = sten(k) - xlv*qlten(k) - xls*qiten(k)
+
+        !  slten(k) = slten(k) + xlv * ntraprd(k) + xls * ntsnprd(k)         
+        !  sten(k)  = slten(k) + xlv * qlten(k)   + xls * qiten(k)
+
+       end do
+
+       ! ------------------------------------------------------------- !
+       ! Calculate final surface flux of precipitation, rain, and snow !
+       ! Convert unit to [m/s] for use in 'check_energy_chng'.         !  
+       ! ------------------------------------------------------------- !
+
+       precip  = ( flxrain(0) + flxsnow(0) ) / 1000._r8
+       snow    =   flxsnow(0) / 1000._r8       
+
+       ! --------------------------------------------------------------------------- !
+       ! Until now, all the calculations are done completely in this shallow cumulus !
+       ! scheme. If you want to use this cumulus scheme other than CAM3, then do not !
+       ! perform below block. However, for compatible use with the other subroutines !
+       ! in CAM3, I should subtract the effect of 'qc(k)' ('rliq') from the tendency !
+       ! equation in each layer, since this effect will be separately added later in !
+       ! in 'stratiform_tend' just after performing sediment process there. In order !
+       ! to be consistent with 'stratiform_tend', just subtract qc(k)  from tendency !
+       ! equation of each layer, but do not add it to the 'precip'. Apprently,  this !
+       ! will violate energy and moisture conservations.    However, when performing !
+       ! conservation check in 'tphysbc.F90' just after 'convect_shallow_tend',   we !
+       ! will add 'qc(k)' ( rliq ) to the surface flux term just for the purpose  of !
+       ! passing the energy-moisture conservation check. Explicit adding-back of 'qc'!
+       ! to the individual layer tendency equation will be done in 'stratiform_tend' !
+       ! after performing sediment process there. Simply speaking, in 'tphysbc' just !
+       ! after 'convect_shallow_tend', we will dump 'rliq' into surface as a  'rain' !
+       ! in order to satisfy energy and moisture conservation, and  in the following !
+       ! 'stratiform_tend', we will restore it back to 'qlten(k)' ( 'ice' will go to !  
+       ! 'water' there) from surface precipitation. This is a funny but conceptually !
+       ! entertaining procedure. One concern I have for this complex process is that !
+       ! output-writed stratiform precipitation amount will be underestimated due to !
+       ! arbitrary subtracting of 'rliq' in stratiform_tend, where                   !
+       ! ' prec_str = prec_sed + prec_pcw - rliq' and 'rliq' is not real but fake.   ! 
+       ! However, as shown in 'srfxfer.F90', large scale precipitation amount (PRECL)!
+       ! that is writed-output is corrected written since in 'srfxfer.F90',  PRECL = !
+       ! 'prec_sed + prec_pcw', without including 'rliq'. So current code is correct.!
+       ! Note also in 'srfxfer.F90', convective precipitation amount is 'PRECC =     ! 
+       ! prec_zmc(i) + prec_cmf(i)' which is also correct.                           !
+       ! --------------------------------------------------------------------------- !
+
+       do k = 1, kpen       
+          qtten(k) = qtten(k) - qc(k)
+          qlten(k) = qlten(k) - qc_l(k)
+          qiten(k) = qiten(k) - qc_i(k)
+          slten(k) = slten(k) + ( xlv * qc_l(k) + xls * qc_i(k) )
+          ! ---------------------------------------------------------------------- !
+          ! Since all reserved condensates will be treated  as liquid water in the !
+          ! 'check_energy_chng' & 'stratiform_tend' without an explicit conversion !
+          ! algorithm, I should consider explicitly the energy conversions between !
+          ! 'ice' and 'liquid' - i.e., I should convert 'ice' to 'liquid'  and the !
+          ! necessary energy for this conversion should be subtracted from 'sten'. ! 
+          ! Without this conversion here, energy conservation error come out. Note !
+          ! that there should be no change of 'qvten(k)'.                          !
+          ! ---------------------------------------------------------------------- !
+          sten(k)  = sten(k)  - ( xls - xlv ) * qc_i(k)
+       end do
+
+       ! --------------------------------------------------------------- !
+       ! Prevent the onset-of negative condensate at the next time step  !
+       ! Potentially, this block can be moved just in front of the above !
+       ! block.                                                          ! 
+       ! --------------------------------------------------------------- !
+
+       ! Modification : I should check whether this 'positive_moisture_single' routine is
+       !                consistent with the one used in UW PBL and cloud macrophysics schemes.
+       ! Modification : Below may overestimate resulting 'ql, qi' if we use the new 'qc_l', 'qc_i'
+       !                in combination with the original computation of qlten, qiten. However,
+       !                if we use new 'qlten,qiten', there is no problem.
+
+        qv0_star(:mkx) = qv0(:mkx) + qvten(:mkx) * dt
+        ql0_star(:mkx) = ql0(:mkx) + qlten(:mkx) * dt
+        qi0_star(:mkx) = qi0(:mkx) + qiten(:mkx) * dt
+        s0_star(:mkx)  =  s0(:mkx) +  sten(:mkx) * dt
+        call positive_moisture_single( xlv, xls, mkx, dt, qmin(1), qmin(2), qmin(3), dp0, qv0_star, ql0_star, qi0_star, s0_star, qvten, qlten, qiten, sten )
+        qtten(:mkx)    = qvten(:mkx) + qlten(:mkx) + qiten(:mkx)
+        slten(:mkx)    = sten(:mkx)  - xlv * qlten(:mkx) - xls * qiten(:mkx)
+
+       ! --------------------- !
+       ! Tendencies of tracers !
+       ! --------------------- !
+
+       do m = 4, ncnst
+
+       if( m .ne. ixnumliq .and. m .ne. ixnumice ) then
+
+          trmin = qmin(m)
+#ifdef MODAL_AERO
+          do mm = 1, ntot_amode
+             if( m .eq. numptr_amode(mm) ) then
+                 trmin = 1.e-5_r8
+                 goto 55
+             endif              
+          enddo
+       55 continue
+#endif 
+          trflx_d(0:mkx) = 0._r8
+          trflx_u(0:mkx) = 0._r8           
+          do k = 1, mkx-1
+             if( cnst_get_type_byind(m) .eq. 'wet' ) then
+                 pdelx = dp0(k)
+             else
+                 pdelx = dpdry0(k)
+             endif
+             km1 = k - 1
+             dum = ( tr0(k,m) - trmin ) *  pdelx / g / dt + trflx(km1,m) - trflx(k,m) + trflx_d(km1)
+             trflx_d(k) = min( 0._r8, dum )
+          enddo
+          do k = mkx, 2, -1
+             if( cnst_get_type_byind(m) .eq. 'wet' ) then
+                 pdelx = dp0(k)
+             else
+                 pdelx = dpdry0(k)
+             endif
+             km1 = k - 1
+             dum = ( tr0(k,m) - trmin ) * pdelx / g / dt + trflx(km1,m) - trflx(k,m) + &
+                                                           trflx_d(km1) - trflx_d(k) - trflx_u(k) 
+             trflx_u(km1) = max( 0._r8, -dum ) 
+          enddo
+          do k = 1, mkx
+             if( cnst_get_type_byind(m) .eq. 'wet' ) then
+                 pdelx = dp0(k)
+             else
+                 pdelx = dpdry0(k)
+             endif
+             km1 = k - 1
+           ! Check : I should re-check whether '_u', '_d' are correctly ordered in 
+           !         the below tendency computation.
+             trten(k,m) = ( trflx(km1,m) - trflx(k,m) + & 
+                            trflx_d(km1) - trflx_d(k) + &
+                            trflx_u(km1) - trflx_u(k) ) * g / pdelx
+          enddo
+
+       endif
+
+       enddo
+
+       ! ---------------------------------------------------------------- !
+       ! Cumpute default diagnostic outputs                               !
+       ! Note that since 'qtu(krel-1:kpen-1)' & 'thlu(krel-1:kpen-1)' has !
+       ! been adjusted after detraining cloud condensate into environment ! 
+       ! during cumulus updraft motion,  below calculations will  exactly !
+       ! reproduce in-cloud properties as shown in the output analysis.   !
+       ! ---------------------------------------------------------------- ! 
+ 
+       call conden(prel,thlu(krel-1),qtu(krel-1),thj,qvj,qlj,qij,qse,id_check,qsat)
+       if( id_check .eq. 1 ) then
+           exit_conden(i) = 1._r8
+           id_exit = .true.
+           go to 333
+       end if
+       qcubelow = qlj + qij
+       qlubelow = qlj       
+       qiubelow = qij       
+       rcwp     = 0._r8
+       rlwp     = 0._r8
+       riwp     = 0._r8
+
+       ! --------------------------------------------------------------------- !
+       ! In the below calculations, I explicitly considered cloud base ( LCL ) !
+       ! and cloud top height ( ps0(kpen-1) + ppen )                           !
+       ! ----------------------------------------------------------------------! 
+       do k = krel, kpen ! This is a layer index
+          ! ------------------------------------------------------------------ ! 
+          ! Calculate cumulus condensate at the upper interface of each layer. !
+          ! Note 'ppen < 0' and at 'k=kpen' layer, I used 'thlu_top'&'qtu_top' !
+          ! which explicitly considered zero or non-zero 'fer(kpen)'.          !
+          ! ------------------------------------------------------------------ ! 
+          if( k .eq. kpen ) then 
+              call conden(ps0(k-1)+ppen,thlu_top,qtu_top,thj,qvj,qlj,qij,qse,id_check,qsat)
+          else
+              call conden(ps0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check,qsat)
+          endif
+          if( id_check .eq. 1 ) then
+              exit_conden(i) = 1._r8
+              id_exit = .true.
+              go to 333
+          end if
+          ! ---------------------------------------------------------------- !
+          ! Calculate in-cloud mean LWC ( qlu(k) ), IWC ( qiu(k) ),  & layer !
+          ! mean cumulus fraction ( cufrc(k) ),  vertically-integrated layer !
+          ! mean LWP and IWP. Expel some of in-cloud condensate at the upper !
+          ! interface if it is largr than criqc. Note cumulus cloud fraction !
+          ! is assumed to be twice of core updraft fractional area. Thus LWP !
+          ! and IWP will be twice of actual value coming from our scheme.    !
+          ! ---------------------------------------------------------------- !
+          qcu(k)   = 0.5_r8 * ( qcubelow + qlj + qij )
+          qlu(k)   = 0.5_r8 * ( qlubelow + qlj )
+          qiu(k)   = 0.5_r8 * ( qiubelow + qij )
+          cufrc(k) = ( ufrc(k-1) + ufrc(k) )
+          if( k .eq. krel ) then
+              cufrc(k) = ( ufrclcl + ufrc(k) )*( prel - ps0(k) )/( ps0(k-1) - ps0(k) )
+          else if( k .eq. kpen ) then
+              cufrc(k) = ( ufrc(k-1) + 0._r8 )*( -ppen )        /( ps0(k-1) - ps0(k) )
+              if( (qlj + qij) .gt. criqc ) then           
+                   qcu(k) = 0.5_r8 * ( qcubelow + criqc )
+                   qlu(k) = 0.5_r8 * ( qlubelow + criqc * qlj / ( qlj + qij ) )
+                   qiu(k) = 0.5_r8 * ( qiubelow + criqc * qij / ( qlj + qij ) )
+              endif
+          endif  
+          rcwp = rcwp + ( qlu(k) + qiu(k) ) * ( ps0(k-1) - ps0(k) ) / g * cufrc(k)
+          rlwp = rlwp +   qlu(k)            * ( ps0(k-1) - ps0(k) ) / g * cufrc(k)
+          riwp = riwp +   qiu(k)            * ( ps0(k-1) - ps0(k) ) / g * cufrc(k)
+          qcubelow = qlj + qij
+          qlubelow = qlj
+          qiubelow = qij
+       end do
+       ! ------------------------------------ !      
+       ! Cloud top and base interface indices !
+       ! ------------------------------------ !
+       cnt = real( kpen, r8 )
+       cnb = real( krel - 1, r8 )
+
+       ! ------------------------------------------------------------------------- !
+       ! End of formal calculation. Below blocks are for implicit CIN calculations ! 
+       ! with re-initialization and save variables at iter_cin = 1._r8             !
+       ! ------------------------------------------------------------------------- !
+       
+       ! --------------------------------------------------------------- !
+       ! Adjust the original input profiles for implicit CIN calculation !
+       ! --------------------------------------------------------------- !
+
+       if( iter .ne. iter_cin ) then 
+
+          ! ------------------------------------------------------------------- !
+          ! Save the output from "iter_cin = 1"                                 !
+          ! These output will be writed-out if "iter_cin = 1" was not performed !
+          ! for some reasons.                                                   !
+          ! ------------------------------------------------------------------- !
+
+          qv0_s(:mkx)           = qv0(:mkx) + qvten(:mkx) * dt
+          ql0_s(:mkx)           = ql0(:mkx) + qlten(:mkx) * dt
+          qi0_s(:mkx)           = qi0(:mkx) + qiten(:mkx) * dt
+          s0_s(:mkx)            = s0(:mkx)  +  sten(:mkx) * dt 
+          u0_s(:mkx)            = u0(:mkx)  +  uten(:mkx) * dt
+          v0_s(:mkx)            = v0(:mkx)  +  vten(:mkx) * dt 
+          qt0_s(:mkx)           = qv0_s(:mkx) + ql0_s(:mkx) + qi0_s(:mkx)
+          t0_s(:mkx)            = t0(:mkx)  +  sten(:mkx) * dt / cp
+          do m = 1, ncnst
+             tr0_s(:mkx,m)      = tr0(:mkx,m) + trten(:mkx,m) * dt
+          enddo
+
+          umf_s(0:mkx)          = umf(0:mkx)
+          qvten_s(:mkx)         = qvten(:mkx)
+          qlten_s(:mkx)         = qlten(:mkx)  
+          qiten_s(:mkx)         = qiten(:mkx)
+          sten_s(:mkx)          = sten(:mkx)
+          uten_s(:mkx)          = uten(:mkx)  
+          vten_s(:mkx)          = vten(:mkx)
+          qrten_s(:mkx)         = qrten(:mkx)
+          qsten_s(:mkx)         = qsten(:mkx)  
+          precip_s              = precip
+          snow_s                = snow
+          evapc_s(:mkx)         = evapc(:mkx)
+          cush_s                = cush
+          cufrc_s(:mkx)         = cufrc(:mkx)  
+          slflx_s(0:mkx)        = slflx(0:mkx)  
+          qtflx_s(0:mkx)        = qtflx(0:mkx)  
+          qcu_s(:mkx)           = qcu(:mkx)  
+          qlu_s(:mkx)           = qlu(:mkx)  
+          qiu_s(:mkx)           = qiu(:mkx)  
+          fer_s(:mkx)           = fer(:mkx)  
+          fdr_s(:mkx)           = fdr(:mkx)  
+          cin_s                 = cin
+          cinlcl_s              = cinlcl
+          cbmf_s                = cbmf
+          rliq_s                = rliq
+          qc_s(:mkx)            = qc(:mkx)
+          cnt_s                 = cnt
+          cnb_s                 = cnb
+          qtten_s(:mkx)         = qtten(:mkx)
+          slten_s(:mkx)         = slten(:mkx)
+          ufrc_s(0:mkx)         = ufrc(0:mkx) 
+
+          uflx_s(0:mkx)         = uflx(0:mkx)  
+          vflx_s(0:mkx)         = vflx(0:mkx)  
+           
+          ufrcinvbase_s         = ufrcinvbase
+          ufrclcl_s             = ufrclcl 
+          winvbase_s            = winvbase
+          wlcl_s                = wlcl
+          plcl_s                = plcl
+          pinv_s                = ps0(kinv-1)
+          plfc_s                = plfc        
+          pbup_s                = ps0(kbup)
+          ppen_s                = ps0(kpen-1) + ppen        
+          qtsrc_s               = qtsrc
+          thlsrc_s              = thlsrc
+          thvlsrc_s             = thvlsrc
+          emfkbup_s             = emf(kbup)
+          cbmflimit_s           = cbmflimit
+          tkeavg_s              = tkeavg
+          zinv_s                = zs0(kinv-1)
+          rcwp_s                = rcwp
+          rlwp_s                = rlwp
+          riwp_s                = riwp
+
+          wu_s(0:mkx)           = wu(0:mkx)
+          qtu_s(0:mkx)          = qtu(0:mkx)
+          thlu_s(0:mkx)         = thlu(0:mkx)
+          thvu_s(0:mkx)         = thvu(0:mkx)
+          uu_s(0:mkx)           = uu(0:mkx)
+          vu_s(0:mkx)           = vu(0:mkx)
+          qtu_emf_s(0:mkx)      = qtu_emf(0:mkx)
+          thlu_emf_s(0:mkx)     = thlu_emf(0:mkx)
+          uu_emf_s(0:mkx)       = uu_emf(0:mkx)
+          vu_emf_s(0:mkx)       = vu_emf(0:mkx)
+          uemf_s(0:mkx)         = uemf(0:mkx)
+
+          dwten_s(:mkx)         = dwten(:mkx)
+          diten_s(:mkx)         = diten(:mkx)
+          flxrain_s(0:mkx)      = flxrain(0:mkx)
+          flxsnow_s(0:mkx)      = flxsnow(0:mkx)
+          ntraprd_s(:mkx)       = ntraprd(:mkx)
+          ntsnprd_s(:mkx)       = ntsnprd(:mkx)
+
+          excessu_arr_s(:mkx)   = excessu_arr(:mkx)
+          excess0_arr_s(:mkx)   = excess0_arr(:mkx)
+          xc_arr_s(:mkx)        = xc_arr(:mkx)
+          aquad_arr_s(:mkx)     = aquad_arr(:mkx)
+          bquad_arr_s(:mkx)     = bquad_arr(:mkx)
+          cquad_arr_s(:mkx)     = cquad_arr(:mkx)
+          bogbot_arr_s(:mkx)    = bogbot_arr(:mkx)
+          bogtop_arr_s(:mkx)    = bogtop_arr(:mkx)
+
+          do m = 1, ncnst
+             trten_s(:mkx,m)    = trten(:mkx,m)
+             trflx_s(0:mkx,m)   = trflx(0:mkx,m)
+             tru_s(0:mkx,m)     = tru(0:mkx,m)
+             tru_emf_s(0:mkx,m) = tru_emf(0:mkx,m)
+          enddo
+
+          ! ----------------------------------------------------------------------------- ! 
+          ! Recalculate environmental variables for new cin calculation at "iter_cin = 2" ! 
+          ! using the updated state variables. Perform only for variables necessary  for  !
+          ! the new cin calculation.                                                      !
+          ! ----------------------------------------------------------------------------- !
+          
+          qv0(:mkx)   = qv0_s(:mkx)
+          ql0(:mkx)   = ql0_s(:mkx)
+          qi0(:mkx)   = qi0_s(:mkx)
+          s0(:mkx)    = s0_s(:mkx)
+          t0(:mkx)    = t0_s(:mkx)
+      
+          qt0(:mkx)   = (qv0(:mkx) + ql0(:mkx) + qi0(:mkx))
+          thl0(:mkx)  = (t0(:mkx) - xlv*ql0(:mkx)/cp - xls*qi0(:mkx)/cp)/exn0(:mkx)
+          thvl0(:mkx) = (1._r8 + zvir*qt0(:mkx))*thl0(:mkx)
+
+          ssthl0      = slope(mkx,thl0,p0) ! Dimension of ssthl0(:mkx) is implicit
+          ssqt0       = slope(mkx,qt0 ,p0)
+          ssu0        = slope(mkx,u0  ,p0)
+          ssv0        = slope(mkx,v0  ,p0)
+          do m = 1, ncnst
+             sstr0(:mkx,m) = slope(mkx,tr0(:mkx,m),p0)
+          enddo
+
+          do k = 1, mkx
+
+             thl0bot = thl0(k) + ssthl0(k) * ( ps0(k-1) - p0(k) )
+             qt0bot  = qt0(k)  + ssqt0(k)  * ( ps0(k-1) - p0(k) )
+             call conden(ps0(k-1),thl0bot,qt0bot,thj,qvj,qlj,qij,qse,id_check,qsat)
+             if( id_check .eq. 1 ) then
+                 exit_conden(i) = 1._r8
+                 id_exit = .true.
+                 go to 333
+             end if
+             thv0bot(k)  = thj * ( 1._r8 + zvir*qvj - qlj - qij )
+             thvl0bot(k) = thl0bot * ( 1._r8 + zvir*qt0bot )
+          
+             thl0top = thl0(k) + ssthl0(k) * ( ps0(k) - p0(k) )
+             qt0top  =  qt0(k) + ssqt0(k)  * ( ps0(k) - p0(k) )
+             call conden(ps0(k),thl0top,qt0top,thj,qvj,qlj,qij,qse,id_check,qsat)
+             if( id_check .eq. 1 ) then
+                 exit_conden(i) = 1._r8
+                 id_exit = .true.
+                 go to 333
+             end if
+             thv0top(k)  = thj * ( 1._r8 + zvir*qvj - qlj - qij )
+             thvl0top(k) = thl0top * ( 1._r8 + zvir*qt0top )
+
+          end do
+
+       endif               ! End of 'if(iter .ne. iter_cin)' if sentence. 
+
+     end do                ! End of implicit CIN loop (cin_iter)      
+
+     ! ----------------------- !
+     ! Update Output Variables !
+     ! ----------------------- !
+
+     umf_out(i,0:mkx)             = umf(0:mkx)
+     slflx_out(i,0:mkx)           = slflx(0:mkx)
+     qtflx_out(i,0:mkx)           = qtflx(0:mkx)
+     qvten_out(i,:mkx)            = qvten(:mkx)
+     qlten_out(i,:mkx)            = qlten(:mkx)
+     qiten_out(i,:mkx)            = qiten(:mkx)
+     sten_out(i,:mkx)             = sten(:mkx)
+     uten_out(i,:mkx)             = uten(:mkx)
+     vten_out(i,:mkx)             = vten(:mkx)
+     qrten_out(i,:mkx)            = qrten(:mkx)
+     qsten_out(i,:mkx)            = qsten(:mkx)
+     precip_out(i)                = precip
+     snow_out(i)                  = snow
+     evapc_out(i,:mkx)            = evapc(:mkx)
+     cufrc_out(i,:mkx)            = cufrc(:mkx)
+     qcu_out(i,:mkx)              = qcu(:mkx)
+     qlu_out(i,:mkx)              = qlu(:mkx)
+     qiu_out(i,:mkx)              = qiu(:mkx)
+     cush_inout(i)                = cush
+     cbmf_out(i)                  = cbmf
+     rliq_out(i)                  = rliq
+     qc_out(i,:mkx)               = qc(:mkx)
+     cnt_out(i)                   = cnt
+     cnb_out(i)                   = cnb
+
+     do m = 1, ncnst
+        trten_out(i,:mkx,m)       = trten(:mkx,m)
+     enddo
+  
+     ! ------------------------------------------------- !
+     ! Below are specific diagnostic output for detailed !
+     ! analysis of cumulus scheme                        !
+     ! ------------------------------------------------- !
+
+     fer_out(i,mkx:1:-1)          = fer(:mkx)  
+     fdr_out(i,mkx:1:-1)          = fdr(:mkx)  
+     cinh_out(i)                  = cin
+     cinlclh_out(i)               = cinlcl
+     qtten_out(i,mkx:1:-1)        = qtten(:mkx)
+     slten_out(i,mkx:1:-1)        = slten(:mkx)
+     ufrc_out(i,mkx:0:-1)         = ufrc(0:mkx)
+     uflx_out(i,mkx:0:-1)         = uflx(0:mkx)  
+     vflx_out(i,mkx:0:-1)         = vflx(0:mkx)  
+     
+     ufrcinvbase_out(i)           = ufrcinvbase
+     ufrclcl_out(i)               = ufrclcl 
+     winvbase_out(i)              = winvbase
+     wlcl_out(i)                  = wlcl
+     plcl_out(i)                  = plcl
+     pinv_out(i)                  = ps0(kinv-1)
+     plfc_out(i)                  = plfc    
+     pbup_out(i)                  = ps0(kbup)        
+     ppen_out(i)                  = ps0(kpen-1) + ppen            
+     qtsrc_out(i)                 = qtsrc
+     thlsrc_out(i)                = thlsrc
+     thvlsrc_out(i)               = thvlsrc
+     emfkbup_out(i)               = emf(kbup)
+     cbmflimit_out(i)             = cbmflimit
+     tkeavg_out(i)                = tkeavg
+     zinv_out(i)                  = zs0(kinv-1)
+     rcwp_out(i)                  = rcwp
+     rlwp_out(i)                  = rlwp
+     riwp_out(i)                  = riwp
+
+     wu_out(i,mkx:0:-1)           = wu(0:mkx)
+     qtu_out(i,mkx:0:-1)          = qtu(0:mkx)
+     thlu_out(i,mkx:0:-1)         = thlu(0:mkx)
+     thvu_out(i,mkx:0:-1)         = thvu(0:mkx)
+     uu_out(i,mkx:0:-1)           = uu(0:mkx)
+     vu_out(i,mkx:0:-1)           = vu(0:mkx)
+     qtu_emf_out(i,mkx:0:-1)      = qtu_emf(0:mkx)
+     thlu_emf_out(i,mkx:0:-1)     = thlu_emf(0:mkx)
+     uu_emf_out(i,mkx:0:-1)       = uu_emf(0:mkx)
+     vu_emf_out(i,mkx:0:-1)       = vu_emf(0:mkx)
+     uemf_out(i,mkx:0:-1)         = uemf(0:mkx)
+
+     dwten_out(i,mkx:1:-1)        = dwten(:mkx)
+     diten_out(i,mkx:1:-1)        = diten(:mkx)
+     flxrain_out(i,mkx:0:-1)      = flxrain(0:mkx)
+     flxsnow_out(i,mkx:0:-1)      = flxsnow(0:mkx)
+     ntraprd_out(i,mkx:1:-1)      = ntraprd(:mkx)
+     ntsnprd_out(i,mkx:1:-1)      = ntsnprd(:mkx)
+
+     excessu_arr_out(i,mkx:1:-1)  = excessu_arr(:mkx)
+     excess0_arr_out(i,mkx:1:-1)  = excess0_arr(:mkx)
+     xc_arr_out(i,mkx:1:-1)       = xc_arr(:mkx)
+     aquad_arr_out(i,mkx:1:-1)    = aquad_arr(:mkx)
+     bquad_arr_out(i,mkx:1:-1)    = bquad_arr(:mkx)
+     cquad_arr_out(i,mkx:1:-1)    = cquad_arr(:mkx)
+     bogbot_arr_out(i,mkx:1:-1)   = bogbot_arr(:mkx)
+     bogtop_arr_out(i,mkx:1:-1)   = bogtop_arr(:mkx)
+
+     do m = 1, ncnst
+        trflx_out(i,mkx:0:-1,m)   = trflx(0:mkx,m)  
+        tru_out(i,mkx:0:-1,m)     = tru(0:mkx,m)
+        tru_emf_out(i,mkx:0:-1,m) = tru_emf(0:mkx,m)
+     enddo
+
+ 333 if(id_exit) then ! Exit without cumulus convection
+
+     exit_UWCu(i) = 1._r8
+
+     ! --------------------------------------------------------------------- !
+     ! Initialize output variables when cumulus convection was not performed.!
+     ! --------------------------------------------------------------------- !
+     
+     umf_out(i,0:mkx)             = 0._r8   
+     slflx_out(i,0:mkx)           = 0._r8
+     qtflx_out(i,0:mkx)           = 0._r8
+     qvten_out(i,:mkx)            = 0._r8
+     qlten_out(i,:mkx)            = 0._r8
+     qiten_out(i,:mkx)            = 0._r8
+     sten_out(i,:mkx)             = 0._r8
+     uten_out(i,:mkx)             = 0._r8
+     vten_out(i,:mkx)             = 0._r8
+     qrten_out(i,:mkx)            = 0._r8
+     qsten_out(i,:mkx)            = 0._r8
+     precip_out(i)                = 0._r8
+     snow_out(i)                  = 0._r8
+     evapc_out(i,:mkx)            = 0._r8
+     cufrc_out(i,:mkx)            = 0._r8
+     qcu_out(i,:mkx)              = 0._r8
+     qlu_out(i,:mkx)              = 0._r8
+     qiu_out(i,:mkx)              = 0._r8
+     cush_inout(i)                = -1._r8
+     cbmf_out(i)                  = 0._r8   
+     rliq_out(i)                  = 0._r8
+     qc_out(i,:mkx)               = 0._r8
+     cnt_out(i)                   = 1._r8
+     cnb_out(i)                   = real(mkx, r8)
+
+     fer_out(i,mkx:1:-1)          = 0._r8  
+     fdr_out(i,mkx:1:-1)          = 0._r8  
+     cinh_out(i)                  = -1._r8 
+     cinlclh_out(i)               = -1._r8 
+     qtten_out(i,mkx:1:-1)        = 0._r8
+     slten_out(i,mkx:1:-1)        = 0._r8
+     ufrc_out(i,mkx:0:-1)         = 0._r8
+     uflx_out(i,mkx:0:-1)         = 0._r8  
+     vflx_out(i,mkx:0:-1)         = 0._r8  
+
+     ufrcinvbase_out(i)           = 0._r8 
+     ufrclcl_out(i)               = 0._r8 
+     winvbase_out(i)              = 0._r8    
+     wlcl_out(i)                  = 0._r8    
+     plcl_out(i)                  = 0._r8    
+     pinv_out(i)                  = 0._r8     
+     plfc_out(i)                  = 0._r8     
+     pbup_out(i)                  = 0._r8    
+     ppen_out(i)                  = 0._r8    
+     qtsrc_out(i)                 = 0._r8    
+     thlsrc_out(i)                = 0._r8    
+     thvlsrc_out(i)               = 0._r8    
+     emfkbup_out(i)               = 0._r8
+     cbmflimit_out(i)             = 0._r8    
+     tkeavg_out(i)                = 0._r8    
+     zinv_out(i)                  = 0._r8    
+     rcwp_out(i)                  = 0._r8    
+     rlwp_out(i)                  = 0._r8    
+     riwp_out(i)                  = 0._r8    
+
+     wu_out(i,mkx:0:-1)           = 0._r8    
+     qtu_out(i,mkx:0:-1)          = 0._r8        
+     thlu_out(i,mkx:0:-1)         = 0._r8         
+     thvu_out(i,mkx:0:-1)         = 0._r8         
+     uu_out(i,mkx:0:-1)           = 0._r8        
+     vu_out(i,mkx:0:-1)           = 0._r8        
+     qtu_emf_out(i,mkx:0:-1)      = 0._r8         
+     thlu_emf_out(i,mkx:0:-1)     = 0._r8         
+     uu_emf_out(i,mkx:0:-1)       = 0._r8          
+     vu_emf_out(i,mkx:0:-1)       = 0._r8    
+     uemf_out(i,mkx:0:-1)         = 0._r8    
+   
+     dwten_out(i,mkx:1:-1)        = 0._r8    
+     diten_out(i,mkx:1:-1)        = 0._r8    
+     flxrain_out(i,mkx:0:-1)      = 0._r8     
+     flxsnow_out(i,mkx:0:-1)      = 0._r8    
+     ntraprd_out(i,mkx:1:-1)      = 0._r8    
+     ntsnprd_out(i,mkx:1:-1)      = 0._r8    
+
+     excessu_arr_out(i,mkx:1:-1)  = 0._r8    
+     excess0_arr_out(i,mkx:1:-1)  = 0._r8    
+     xc_arr_out(i,mkx:1:-1)       = 0._r8    
+     aquad_arr_out(i,mkx:1:-1)    = 0._r8    
+     bquad_arr_out(i,mkx:1:-1)    = 0._r8    
+     cquad_arr_out(i,mkx:1:-1)    = 0._r8    
+     bogbot_arr_out(i,mkx:1:-1)   = 0._r8    
+     bogtop_arr_out(i,mkx:1:-1)   = 0._r8    
+
+     do m = 1, ncnst
+        trten_out(i,:mkx,m)       = 0._r8
+        trflx_out(i,mkx:0:-1,m)   = 0._r8  
+        tru_out(i,mkx:0:-1,m)     = 0._r8
+        tru_emf_out(i,mkx:0:-1,m) = 0._r8
+     enddo
+
+     end if
+
+     end do                  ! end of big i loop for each column.
+
+     ! ---------------------------------------- !
+     ! Writing main diagnostic output variables !
+     ! ---------------------------------------- !
+
+     call outfld( 'qtflx_Cu'        , qtflx_out(:,mkx:0:-1),    mix,    lchnk ) 
+     call outfld( 'slflx_Cu'        , slflx_out(:,mkx:0:-1),    mix,    lchnk ) 
+     call outfld( 'uflx_Cu'         , uflx_out,                 mix,    lchnk ) 
+     call outfld( 'vflx_Cu'         , vflx_out,                 mix,    lchnk ) 
+
+     call outfld( 'qtten_Cu'        , qtten_out,                mix,    lchnk ) 
+     call outfld( 'slten_Cu'        , slten_out,                mix,    lchnk ) 
+     call outfld( 'uten_Cu'         , uten_out(:,mkx:1:-1),     mix,    lchnk ) 
+     call outfld( 'vten_Cu'         , vten_out(:,mkx:1:-1),     mix,    lchnk ) 
+     call outfld( 'qvten_Cu'        , qvten_out(:,mkx:1:-1),    mix,    lchnk ) 
+     call outfld( 'qlten_Cu'        , qlten_out(:,mkx:1:-1),    mix,    lchnk )
+     call outfld( 'qiten_Cu'        , qiten_out(:,mkx:1:-1),    mix,    lchnk )   
+
+     call outfld( 'cbmf_Cu'         , cbmf_out,                 mix,    lchnk ) 
+     call outfld( 'ufrcinvbase_Cu'  , ufrcinvbase_out,          mix,    lchnk ) 
+     call outfld( 'ufrclcl_Cu'      , ufrclcl_out,              mix,    lchnk ) 
+     call outfld( 'winvbase_Cu'     , winvbase_out,             mix,    lchnk ) 
+     call outfld( 'wlcl_Cu'         , wlcl_out,                 mix,    lchnk ) 
+     call outfld( 'plcl_Cu'         , plcl_out,                 mix,    lchnk ) 
+     call outfld( 'pinv_Cu'         , pinv_out,                 mix,    lchnk ) 
+     call outfld( 'plfc_Cu'         , plfc_out,                 mix,    lchnk ) 
+     call outfld( 'pbup_Cu'         , pbup_out,                 mix,    lchnk ) 
+     call outfld( 'ppen_Cu'         , ppen_out,                 mix,    lchnk ) 
+     call outfld( 'qtsrc_Cu'        , qtsrc_out,                mix,    lchnk ) 
+     call outfld( 'thlsrc_Cu'       , thlsrc_out,               mix,    lchnk ) 
+     call outfld( 'thvlsrc_Cu'      , thvlsrc_out,              mix,    lchnk ) 
+     call outfld( 'emfkbup_Cu'      , emfkbup_out,              mix,    lchnk )
+     call outfld( 'cin_Cu'          , cinh_out,                 mix,    lchnk )  
+     call outfld( 'cinlcl_Cu'       , cinlclh_out,              mix,    lchnk ) 
+     call outfld( 'cbmflimit_Cu'    , cbmflimit_out,            mix,    lchnk ) 
+     call outfld( 'tkeavg_Cu'       , tkeavg_out,               mix,    lchnk )
+     call outfld( 'zinv_Cu'         , zinv_out,                 mix,    lchnk )  
+     call outfld( 'rcwp_Cu'         , rcwp_out,                 mix,    lchnk )
+     call outfld( 'rlwp_Cu'         , rlwp_out,                 mix,    lchnk )
+     call outfld( 'riwp_Cu'         , riwp_out,                 mix,    lchnk )
+     call outfld( 'tophgt_Cu'       , cush_inout,               mix,    lchnk )   
+
+     call outfld( 'wu_Cu'           , wu_out,                   mix,    lchnk )
+     call outfld( 'ufrc_Cu'         , ufrc_out,                 mix,    lchnk )
+     call outfld( 'qtu_Cu'          , qtu_out,                  mix,    lchnk )
+     call outfld( 'thlu_Cu'         , thlu_out,                 mix,    lchnk )
+     call outfld( 'thvu_Cu'         , thvu_out,                 mix,    lchnk )
+     call outfld( 'uu_Cu'           , uu_out,                   mix,    lchnk )
+     call outfld( 'vu_Cu'           , vu_out,                   mix,    lchnk )
+     call outfld( 'qtu_emf_Cu'      , qtu_emf_out,              mix,    lchnk )
+     call outfld( 'thlu_emf_Cu'     , thlu_emf_out,             mix,    lchnk )
+     call outfld( 'uu_emf_Cu'       , uu_emf_out,               mix,    lchnk )
+     call outfld( 'vu_emf_Cu'       , vu_emf_out,               mix,    lchnk )
+     call outfld( 'umf_Cu'          , umf_out(:,mkx:0:-1),      mix,    lchnk )
+     call outfld( 'uemf_Cu'         , uemf_out,                 mix,    lchnk )
+     call outfld( 'qcu_Cu'          , qcu_out(:,mkx:1:-1),      mix,    lchnk )
+     call outfld( 'qlu_Cu'          , qlu_out(:,mkx:1:-1),      mix,    lchnk )
+     call outfld( 'qiu_Cu'          , qiu_out(:,mkx:1:-1),      mix,    lchnk )
+     call outfld( 'cufrc_Cu'        , cufrc_out(:,mkx:1:-1),    mix,    lchnk )  
+     call outfld( 'fer_Cu'          , fer_out,                  mix,    lchnk )  
+     call outfld( 'fdr_Cu'          , fdr_out,                  mix,    lchnk )  
+
+     call outfld( 'dwten_Cu'        , dwten_out,                mix,    lchnk )
+     call outfld( 'diten_Cu'        , diten_out,                mix,    lchnk )
+     call outfld( 'qrten_Cu'        , qrten_out(:,mkx:1:-1),    mix,    lchnk )
+     call outfld( 'qsten_Cu'        , qsten_out(:,mkx:1:-1),    mix,    lchnk )
+     call outfld( 'flxrain_Cu'      , flxrain_out,              mix,    lchnk )
+     call outfld( 'flxsnow_Cu'      , flxsnow_out,              mix,    lchnk )
+     call outfld( 'ntraprd_Cu'      , ntraprd_out,              mix,    lchnk )
+     call outfld( 'ntsnprd_Cu'      , ntsnprd_out,              mix,    lchnk )
+
+     call outfld( 'excessu_Cu'      , excessu_arr_out,          mix,    lchnk )
+     call outfld( 'excess0_Cu'      , excess0_arr_out,          mix,    lchnk )
+     call outfld( 'xc_Cu'           , xc_arr_out,               mix,    lchnk )
+     call outfld( 'aquad_Cu'        , aquad_arr_out,            mix,    lchnk )
+     call outfld( 'bquad_Cu'        , bquad_arr_out,            mix,    lchnk )
+     call outfld( 'cquad_Cu'        , cquad_arr_out,            mix,    lchnk )
+     call outfld( 'bogbot_Cu'       , bogbot_arr_out,           mix,    lchnk )
+     call outfld( 'bogtop_Cu'       , bogtop_arr_out,           mix,    lchnk )
+
+     call outfld( 'exit_UWCu_Cu'    , exit_UWCu,                mix,    lchnk ) 
+     call outfld( 'exit_conden_Cu'  , exit_conden,              mix,    lchnk ) 
+     call outfld( 'exit_klclmkx_Cu' , exit_klclmkx,             mix,    lchnk ) 
+     call outfld( 'exit_klfcmkx_Cu' , exit_klfcmkx,             mix,    lchnk ) 
+     call outfld( 'exit_ufrc_Cu'    , exit_ufrc,                mix,    lchnk ) 
+     call outfld( 'exit_wtw_Cu'     , exit_wtw,                 mix,    lchnk ) 
+     call outfld( 'exit_drycore_Cu' , exit_drycore,             mix,    lchnk ) 
+     call outfld( 'exit_wu_Cu'      , exit_wu,                  mix,    lchnk ) 
+     call outfld( 'exit_cufilter_Cu', exit_cufilter,            mix,    lchnk ) 
+     call outfld( 'exit_kinv1_Cu'   , exit_kinv1,               mix,    lchnk ) 
+     call outfld( 'exit_rei_Cu'     , exit_rei,                 mix,    lchnk ) 
+
+     call outfld( 'limit_shcu_Cu'   , limit_shcu,               mix,    lchnk ) 
+     call outfld( 'limit_negcon_Cu' , limit_negcon,             mix,    lchnk ) 
+     call outfld( 'limit_ufrc_Cu'   , limit_ufrc,               mix,    lchnk ) 
+     call outfld( 'limit_ppen_Cu'   , limit_ppen,               mix,    lchnk ) 
+     call outfld( 'limit_emf_Cu'    , limit_emf,                mix,    lchnk ) 
+     call outfld( 'limit_cinlcl_Cu' , limit_cinlcl,             mix,    lchnk ) 
+     call outfld( 'limit_cin_Cu'    , limit_cin,                mix,    lchnk ) 
+     call outfld( 'limit_cbmf_Cu'   , limit_cbmf,               mix,    lchnk ) 
+     call outfld( 'limit_rei_Cu'    , limit_rei,                mix,    lchnk ) 
+     call outfld( 'ind_delcin_Cu'   , ind_delcin,               mix,    lchnk ) 
+
+    return
+
+  end subroutine compute_uwshcu
+
+  ! ------------------------------ !
+  !                                ! 
+  ! Beginning of subroutine blocks !
+  !                                !
+  ! ------------------------------ !
+
+  subroutine getbuoy(pbot,thv0bot,ptop,thv0top,thvubot,thvutop,plfc,cin)
+  ! ----------------------------------------------------------- !
+  ! Subroutine to calculate integrated CIN [ J/kg = m2/s2 ] and !
+  ! 'cinlcl, plfc' if any. Assume 'thv' is linear in each layer !
+  ! both for cumulus and environment. Note that this subroutine !
+  ! only include positive CIN in calculation - if there are any !
+  ! negative CIN, it is assumed to be zero.    This is slightly !
+  ! different from 'single_cin' below, where both positive  and !
+  ! negative CIN are included.                                  !
+  ! ----------------------------------------------------------- !
+    real(r8) pbot,thv0bot,ptop,thv0top,thvubot,thvutop,plfc,cin,frc
+
+    if( thvubot .gt. thv0bot .and. thvutop .gt. thv0top ) then
+        plfc = pbot
+        return
+    elseif( thvubot .le. thv0bot .and. thvutop .le. thv0top ) then 
+        cin  = cin - ( (thvubot/thv0bot - 1._r8) + (thvutop/thv0top - 1._r8)) * (pbot - ptop) /        &
+                     ( pbot/(r*thv0bot*exnf(pbot)) + ptop/(r*thv0top*exnf(ptop)) )
+    elseif( thvubot .gt. thv0bot .and. thvutop .le. thv0top ) then 
+        frc  = ( thvutop/thv0top - 1._r8 ) / ( (thvutop/thv0top - 1._r8) - (thvubot/thv0bot - 1._r8) )
+        cin  = cin - ( thvutop/thv0top - 1._r8 ) * ( (ptop + frc*(pbot - ptop)) - ptop ) /             &
+                     ( pbot/(r*thv0bot*exnf(pbot)) + ptop/(r*thv0top*exnf(ptop)) )
+    else            
+        frc  = ( thvubot/thv0bot - 1._r8 ) / ( (thvubot/thv0bot - 1._r8) - (thvutop/thv0top - 1._r8) )
+        plfc = pbot - frc * ( pbot - ptop )
+        cin  = cin - ( thvubot/thv0bot - 1._r8)*(pbot - plfc)/                                         & 
+                     ( pbot/(r*thv0bot*exnf(pbot)) + ptop/(r*thv0top * exnf(ptop)))
+    endif
+
+    return
+  end subroutine getbuoy
+
+  function single_cin(pbot,thv0bot,ptop,thv0top,thvubot,thvutop)
+  ! ------------------------------------------------------- !
+  ! Function to calculate a single layer CIN by summing all ! 
+  ! positive and negative CIN.                              !
+  ! ------------------------------------------------------- ! 
+    real(r8) :: single_cin
+    real(r8)    pbot,thv0bot,ptop,thv0top,thvubot,thvutop 
+
+    single_cin = ( (1._r8 - thvubot/thv0bot) + (1._r8 - thvutop/thv0top)) * ( pbot - ptop ) / &
+                 ( pbot/(r*thv0bot*exnf(pbot)) + ptop/(r*thv0top*exnf(ptop)) )
+    return
+  end function single_cin   
+
+
+  subroutine conden(p,thl,qt,th,qv,ql,qi,rvls,id_check,qsat)
+  ! --------------------------------------------------------------------- !
+  ! Calculate thermodynamic properties from a given set of ( p, thl, qt ) !
+  ! --------------------------------------------------------------------- !
+    implicit none
+    real(r8), intent(in)  :: p
+    real(r8), intent(in)  :: thl
+    real(r8), intent(in)  :: qt
+    real(r8), intent(out) :: th
+    real(r8), intent(out) :: qv
+    real(r8), intent(out) :: ql
+    real(r8), intent(out) :: qi
+    real(r8), intent(out) :: rvls
+    integer , intent(out) :: id_check
+    integer , external    :: qsat
+    real(r8)              :: tc,temps,t
+    real(r8)              :: leff, nu, qc
+    integer               :: iteration
+    real(r8)              :: es(1)              ! Saturation vapor pressure
+    real(r8)              :: qs(1)              ! Saturation spec. humidity
+    real(r8)              :: gam(1)             ! (L/cp)*dqs/dT
+    integer               :: status             ! Return status of qsat call
+
+    tc   = thl*exnf(p)
+  ! Modification : In order to be compatible with the dlf treatment in stratiform.F90,
+  !                we may use ( 268.15, 238.15 ) with 30K ramping instead of 20 K,
+  !                in computing ice fraction below. 
+  !                Note that 'cldwat_fice' uses ( 243.15, 263.15 ) with 20K ramping for stratus.
+    nu   = max(min((268._r8 - tc)/20._r8,1.0_r8),0.0_r8)  ! Fraction of ice in the condensate. 
+    leff = (1._r8 - nu)*xlv + nu*xls                      ! This is an estimate that hopefully speeds convergence
+
+    ! --------------------------------------------------------------------------- !
+    ! Below "temps" and "rvls" are just initial guesses for iteration loop below. !
+    ! Note that the output "temps" from the below iteration loop is "temperature" !
+    ! NOT "liquid temperature".                                                   !
+    ! --------------------------------------------------------------------------- !
+
+    temps  = tc
+    status = qsat(temps,p,es(1),qs(1),gam(1), 1)
+    rvls   = qs(1)
+
+    if( qs(1) .ge. qt ) then  
+        id_check = 0
+        qv = qt
+        qc = 0._r8
+        ql = 0._r8
+        qi = 0._r8
+        th = tc/exnf(p)
+    else 
+        do iteration = 1, 10
+           temps  = temps + ( (tc-temps)*cp/leff + qt - rvls )/( cp/leff + ep2*leff*rvls/r/temps/temps )
+           status = qsat(temps,p,es(1),qs(1),gam(1),1)
+           rvls   = qs(1)
+        end do
+        qc = max(qt - qs(1),0._r8)
+        qv = qt - qc
+        ql = qc*(1._r8 - nu)
+        qi = nu*qc
+        th = temps/exnf(p)
+        if( abs((temps-(leff/cp)*qc)-tc) .ge. 1._r8 ) then
+            id_check = 1
+        else
+            id_check = 0
+        end if
+    end if
+
+    return
+  end subroutine conden
+
+  subroutine roots(a,b,c,r1,r2,status)
+  ! --------------------------------------------------------- !
+  ! Subroutine to solve the second order polynomial equation. !
+  ! I should check this subroutine later.                     !
+  ! --------------------------------------------------------- !
+    real(r8), intent(in)  :: a
+    real(r8), intent(in)  :: b
+    real(r8), intent(in)  :: c
+    real(r8), intent(out) :: r1
+    real(r8), intent(out) :: r2
+    integer , intent(out) :: status
+    real(r8)              :: q
+
+    status = 0
+
+    if( a .eq. 0._r8 ) then                            ! Form b*x + c = 0
+        if( b .eq. 0._r8 ) then                        ! Failure: c = 0
+            status = 1
+        else                                           ! b*x + c = 0
+            r1 = -c/b
+        endif
+        r2 = r1
+    else
+        if( b .eq. 0._r8 ) then                        ! Form a*x**2 + c = 0
+            if( a*c .gt. 0._r8 ) then                  ! Failure: x**2 = -c/a < 0
+                status = 2  
+            else                                       ! x**2 = -c/a 
+                r1 = sqrt(-c/a)
+            endif
+            r2 = -r1
+       else                                            ! Form a*x**2 + b*x + c = 0
+            if( (b**2 - 4._r8*a*c) .lt. 0._r8 ) then   ! Failure, no real roots
+                 status = 3
+            else
+                 q  = -0.5_r8*(b + sign(1.0_r8,b)*sqrt(b**2 - 4._r8*a*c))
+                 r1 =  q/a
+                 r2 =  c/q
+            endif
+       endif
+    endif
+
+    return
+  end subroutine roots
+  
+  function slope(mkx,field,p0)
+  ! ------------------------------------------------------------------ !
+  ! Function performing profile reconstruction of conservative scalars !
+  ! in each layer. This is identical to profile reconstruction used in !
+  ! UW-PBL scheme but from bottom to top layer here.     At the lowest !
+  ! layer near to surface, slope is defined using the two lowest layer !
+  ! mid-point values. I checked this subroutine and it is correct.     !
+  ! ------------------------------------------------------------------ !
+    real(r8)             :: slope(mkx)
+    integer,  intent(in) :: mkx
+    real(r8), intent(in) :: field(mkx)
+    real(r8), intent(in) :: p0(mkx)
+    
+    real(r8)             :: below
+    real(r8)             :: above
+    integer              :: k
+
+    below = ( field(2) - field(1) ) / ( p0(2) - p0(1) )
+    do k = 2, mkx
+       above = ( field(k) - field(k-1) ) / ( p0(k) - p0(k-1) )
+       if( above .gt. 0._r8 ) then
+           slope(k-1) = max(0._r8,min(above,below))
+       else 
+           slope(k-1) = min(0._r8,max(above,below))
+       end if
+       below = above
+    end do
+    slope(mkx) = slope(mkx-1)
+
+    return
+  end function slope
+
+  function qsinvert(qt,thl,psfc,qsat)
+  ! ----------------------------------------------------------------- !
+  ! Function calculating saturation pressure ps (or pLCL) from qt and !
+  ! thl ( liquid potential temperature,  NOT liquid virtual potential ! 
+  ! temperature) by inverting Bolton formula. I should check later if !
+  ! current use of 'leff' instead of 'xlv' here is reasonable or not. !
+  ! ----------------------------------------------------------------- !
+    real(r8)          :: qsinvert    
+    real(r8)             qt, thl, psfc
+    real(r8)             ps, Pis, Ts, err, dlnqsdT, dTdPis
+    real(r8)             dPisdps, dlnqsdps, derrdps, dps 
+    real(r8)             Ti, rhi, TLCL, PiLCL, psmin, dpsmax
+    integer              i
+    integer, external :: qsat
+    real(r8)          :: es(1)                     ! saturation vapor pressure
+    real(r8)          :: qs(1)                     ! saturation spec. humidity
+    real(r8)          :: gam(1)                    ! (L/cp)*dqs/dT
+    integer           :: status                    ! return status of qsat call
+    real(r8)          :: leff, nu
+
+    psmin  = 100._r8*100._r8 ! Default saturation pressure [Pa] if iteration does not converge
+    dpsmax = 1._r8           ! Tolerance [Pa] for convergence of iteration
+
+    ! ------------------------------------ !
+    ! Calculate best initial guess of pLCL !
+    ! ------------------------------------ !
+
+    Ti       =  thl*(psfc/p00)**rovcp
+    status   =  qsat(Ti,psfc,es(1),qs(1),gam(1),1)
+    rhi      =  qt/qs(1)      
+    if( rhi .le. 0.01_r8 ) then
+        write(iulog,*) 'Source air is too dry and pLCL is set to psmin in uwshcu.F90' 
+#ifdef WRF_PORT
+        call wrf_message(iulog)
+#endif
+        qsinvert = psmin
+        return
+    end if
+    TLCL     =  55._r8 + 1._r8/(1._r8/(Ti-55._r8)-log(rhi)/2840._r8); ! Bolton's formula. MWR.1980.Eq.(22)
+    PiLCL    =  TLCL/thl
+    ps       =  p00*(PiLCL)**(1._r8/rovcp)
+
+    do i = 1, 10
+       Pis      =  (ps/p00)**rovcp
+       Ts       =  thl*Pis
+       status   =  qsat(Ts,ps,es(1),qs(1),gam(1),1)
+       err      =  qt - qs(1)
+       nu       =  max(min((268._r8 - Ts)/20._r8,1.0_r8),0.0_r8)        
+       leff     =  (1._r8 - nu)*xlv + nu*xls                   
+       dlnqsdT  =  gam(1)*(cp/leff)/qs(1)
+       dTdPis   =  thl
+       dPisdps  =  rovcp*Pis/ps 
+       dlnqsdps = -1._r8/(ps - (1._r8 - ep2)*es(1))
+       derrdps  = -qs(1)*(dlnqsdT * dTdPis * dPisdps + dlnqsdps)
+       dps      = -err/derrdps
+       ps       =  ps + dps
+       if( ps .lt. 0._r8 ) then
+           write(iulog,*) 'pLCL iteration is negative and set to psmin in uwshcu.F90', qt, thl, psfc 
+#ifdef WRF_PORT
+           call wrf_message(iulog)
+#endif
+           qsinvert = psmin
+           return    
+       end if
+       if( abs(dps) .le. dpsmax ) then
+           qsinvert = ps
+           return
+       end if
+    end do
+    write(iulog,*) 'pLCL does not converge and is set to psmin in uwshcu.F90', qt, thl, psfc 
+    qsinvert = psmin
+    return
+  end function qsinvert
+
+  real(r8) function compute_alpha(del_CIN,ke)
+  ! ------------------------------------------------ !
+  ! Subroutine to compute proportionality factor for !
+  ! implicit CIN calculation.                        !   
+  ! ------------------------------------------------ !
+    real(r8) :: del_CIN, ke
+    real(r8) :: x0, x1
+
+    integer  :: iteration
+
+    x0 = 0._r8
+    do iteration = 1, 10
+       x1 = x0 - (exp(-x0*ke*del_CIN) - x0)/(-ke*del_CIN*exp(-x0*ke*del_CIN) - 1._r8)
+       x0 = x1
+    end do
+    compute_alpha = x0
+
+    return
+
+  end function compute_alpha
+
+  real(r8) function compute_mumin2(mulcl,rmaxfrac,mulow)
+  ! --------------------------------------------------------- !
+  ! Subroutine to compute critical 'mu' (normalized CIN) such ! 
+  ! that updraft fraction at the LCL is equal to 'rmaxfrac'.  !
+  ! --------------------------------------------------------- !  
+    real(r8) :: mulcl, rmaxfrac, mulow
+    real(r8) :: x0, x1, ex, ef, exf, f, fs
+    integer  :: iteration
+
+    x0 = mulow
+    do iteration = 1, 10
+       ex = exp(-x0**2)
+       ef = erfc(x0)
+       ! if(x0.ge.3._r8) then
+       !    compute_mumin2 = 3._r8 
+       !    goto 20
+       ! endif 
+       exf = ex/ef
+       f  = 0.5_r8*exf**2 - 0.5_r8*(ex/2._r8/rmaxfrac)**2 - (mulcl*2.5066_r8/2._r8)**2
+       fs = (2._r8*exf**2)*(exf/sqrt(3.141592_r8)-x0) + (0.5_r8*x0*ex**2)/(rmaxfrac**2)
+       x1 = x0 - f/fs     
+       x0 = x1
+    end do
+    compute_mumin2 = x0
+
+ 20 return
+
+  end function compute_mumin2
+
+  real(r8) function compute_ppen(wtwb,D,bogbot,bogtop,rho0j,dpen)
+  ! ----------------------------------------------------------- !
+  ! Subroutine to compute critical 'ppen[Pa]<0' ( pressure dis. !
+  ! from 'ps0(kpen-1)' to the cumulus top where cumulus updraft !
+  ! vertical velocity is exactly zero ) by considering exact    !
+  ! non-zero fer(kpen).                                         !  
+  ! ----------------------------------------------------------- !  
+    real(r8) :: wtwb, D, bogbot, bogtop, rho0j, dpen
+    real(r8) :: x0, x1, f, fs, SB, s00
+    integer  :: iteration
+
+    ! Buoyancy slope
+      SB = ( bogtop - bogbot ) / dpen
+    ! Sign of slope, 'f' at x = 0
+    ! If 's00>0', 'w' increases with height.
+      s00 = bogbot / rho0j - D * wtwb
+
+    if( D*dpen .lt. 1.e-8 ) then
+        if( s00 .ge. 0._r8 ) then
+            x0 = dpen       
+        else
+            x0 = max(0._r8,min(dpen,-0.5_r8*wtwb/s00))
+        endif
+    else
+        if( s00 .ge. 0._r8 ) then
+            x0 = dpen
+        else 
+            x0 = 0._r8
+        endif
+        do iteration = 1, 5
+           f  = exp(-2._r8*D*x0)*(wtwb-(bogbot-SB/(2._r8*D))/(D*rho0j)) + &
+                                 (SB*x0+bogbot-SB/(2._r8*D))/(D*rho0j)
+           fs = -2._r8*D*exp(-2._r8*D*x0)*(wtwb-(bogbot-SB/(2._r8*D))/(D*rho0j)) + &
+                                 (SB)/(D*rho0j)
+           x1 = x0 - f/fs     
+           x0 = x1
+      end do
+
+    endif    
+
+    compute_ppen = -max(0._r8,min(dpen,x0))
+
+  end function compute_ppen
+
+  subroutine fluxbelowinv(cbmf,ps0,mkx,kinv,dt,xsrc,xmean,xtopin,xbotin,xflx)   
+  ! ------------------------------------------------------------------------- !
+  ! Subroutine to calculate turbulent fluxes at and below 'kinv-1' interfaces.!
+  ! Check in the main program such that input 'cbmf' should not be zero.      !  
+  ! If the reconstructed inversion height does not go down below the 'kinv-1' !
+  ! interface, then turbulent flux at 'kinv-1' interface  is simply a product !
+  ! of 'cmbf' and 'qtsrc-xbot' where 'xbot' is the value at the top interface !
+  ! of 'kinv-1' layer. This flux is linearly interpolated down to the surface !
+  ! assuming turbulent fluxes at surface are zero. If reconstructed inversion !
+  ! height goes down below the 'kinv-1' interface, subsidence warming &drying !
+  ! measured by 'xtop-xbot', where  'xtop' is the value at the base interface !
+  ! of 'kinv+1' layer, is added ONLY to the 'kinv-1' layer, using appropriate !
+  ! mass weighting ( rpinv and rcbmf, or rr = rpinv / rcbmf ) between current !
+  ! and next provisional time step. Also impose a limiter to enforce outliers !
+  ! of thermodynamic variables in 'kinv' layer  to come back to normal values !
+  ! at the next step.                                                         !
+  ! ------------------------------------------------------------------------- !            
+    integer,  intent(in)                     :: mkx, kinv 
+    real(r8), intent(in)                     :: cbmf, dt, xsrc, xmean, xtopin, xbotin
+    real(r8), intent(in),  dimension(0:mkx)  :: ps0
+    real(r8), intent(out), dimension(0:mkx)  :: xflx  
+    integer k
+    real(r8) rcbmf, rpeff, dp, rr, pinv_eff, xtop, xbot, pinv, xtop_ori, xbot_ori
+
+    xflx(0:mkx) = 0._r8
+    dp = ps0(kinv-1) - ps0(kinv) 
+    
+    if( abs(xbotin-xtopin) .le. 1.e-13_r8 ) then
+        xbot = xbotin - 1.e-13_r8
+        xtop = xtopin + 1.e-13_r8
+    else
+        xbot = xbotin
+        xtop = xtopin
+    endif
+    ! -------------------------------------- !
+    ! Compute reconstructed inversion height !
+    ! -------------------------------------- !
+    xtop_ori = xtop
+    xbot_ori = xbot
+    rcbmf = ( cbmf * g * dt ) / dp                  ! Can be larger than 1 : 'OK'      
+    rpeff = ( xmean - xtop ) / ( xbot - xtop ) 
+    rpeff = min( max(0._r8,rpeff), 1._r8 )          ! As of this, 0<= rpeff <= 1   
+    if( rpeff .eq. 0._r8 .or. rpeff .eq. 1._r8 ) then
+        xbot = xmean
+        xtop = xmean
+    endif
+    ! Below two commented-out lines are the old code replacing the above 'if' block.   
+    ! if(rpeff.eq.1) xbot = xmean
+    ! if(rpeff.eq.0) xtop = xmean    
+    rr       = rpeff / rcbmf
+    pinv     = ps0(kinv-1) - rpeff * dp             ! "pinv" before detraining mass
+    pinv_eff = ps0(kinv-1) + ( rcbmf - rpeff ) * dp ! Effective "pinv" after detraining mass
+    ! ----------------------------------------------------------------------- !
+    ! Compute turbulent fluxes.                                               !
+    ! Below two cases exactly converges at 'kinv-1' interface when rr = 1._r8 !
+    ! ----------------------------------------------------------------------- !
+    do k = 0, kinv - 1
+       xflx(k) = cbmf * ( xsrc - xbot ) * ( ps0(0) - ps0(k) ) / ( ps0(0) - pinv )
+    end do
+    if( rr .le. 1._r8 ) then
+        xflx(kinv-1) =  xflx(kinv-1) - ( 1._r8 - rr ) * cbmf * ( xtop_ori - xbot_ori )
+    endif
+
+    return
+  end subroutine fluxbelowinv
+
+  subroutine positive_moisture_single( xlv, xls, mkx, dt, qvmin, qlmin, qimin, dp, qv, ql, qi, s, qvten, qlten, qiten, sten )
+  ! ------------------------------------------------------------------------------- !
+  ! If any 'ql < qlmin, qi < qimin, qv < qvmin' are developed in any layer,         !
+  ! force them to be larger than minimum value by (1) condensating water vapor      !
+  ! into liquid or ice, and (2) by transporting water vapor from the very lower     !
+  ! layer. '2._r8' is multiplied to the minimum values for safety.                  !
+  ! Update final state variables and tendencies associated with this correction.    !
+  ! If any condensation happens, update (s,t) too.                                  !
+  ! Note that (qv,ql,qi,s) are final state variables after applying corresponding   !
+  ! input tendencies and corrective tendencies                                      !
+  ! ------------------------------------------------------------------------------- !
+    implicit none
+    integer,  intent(in)     :: mkx
+    real(r8), intent(in)     :: xlv, xls
+    real(r8), intent(in)     :: dt, qvmin, qlmin, qimin
+    real(r8), intent(in)     :: dp(mkx)
+    real(r8), intent(inout)  :: qv(mkx), ql(mkx), qi(mkx), s(mkx)
+    real(r8), intent(inout)  :: qvten(mkx), qlten(mkx), qiten(mkx), sten(mkx)
+    integer   k
+    real(r8)  dql, dqi, dqv, sum, aa, dum 
+
+    do k = mkx, 1, -1        ! From the top to the 1st (lowest) layer from the surface
+       dql = max(0._r8,1._r8*qlmin-ql(k))
+       dqi = max(0._r8,1._r8*qimin-qi(k))
+       qlten(k) = qlten(k) +  dql/dt
+       qiten(k) = qiten(k) +  dqi/dt
+       qvten(k) = qvten(k) - (dql+dqi)/dt
+       sten(k)  = sten(k)  + xlv * (dql/dt) + xls * (dqi/dt)
+       ql(k)    = ql(k) +  dql
+       qi(k)    = qi(k) +  dqi
+       qv(k)    = qv(k) -  dql - dqi
+       s(k)     = s(k)  +  xlv * dql + xls * dqi
+       dqv      = max(0._r8,1._r8*qvmin-qv(k))
+       qvten(k) = qvten(k) + dqv/dt
+       qv(k)    = qv(k)   + dqv
+       if( k .ne. 1 ) then 
+           qv(k-1)    = qv(k-1)    - dqv*dp(k)/dp(k-1)
+           qvten(k-1) = qvten(k-1) - dqv*dp(k)/dp(k-1)/dt
+       endif
+       qv(k) = max(qv(k),qvmin)
+       ql(k) = max(ql(k),qlmin)
+       qi(k) = max(qi(k),qimin)
+    end do
+    ! Extra moisture used to satisfy 'qv(i,1)=qvmin' is proportionally 
+    ! extracted from all the layers that has 'qv > 2*qvmin'. This fully
+    ! preserves column moisture. 
+    if( dqv .gt. 1.e-20_r8 ) then
+        sum = 0._r8
+        do k = 1, mkx
+           if( qv(k) .gt. 2._r8*qvmin ) sum = sum + qv(k)*dp(k)
+        enddo
+        aa = dqv*dp(1)/max(1.e-20_r8,sum)
+        if( aa .lt. 0.5_r8 ) then
+            do k = 1, mkx
+               if( qv(k) .gt. 2._r8*qvmin ) then
+                   dum      = aa*qv(k)
+                   qv(k)    = qv(k) - dum
+                   qvten(k) = qvten(k) - dum/dt
+               endif
+            enddo 
+        else 
+            write(iulog,*) 'Full positive_moisture is impossible in uwshcu'
+        endif
+    endif 
+
+    return
+  end subroutine positive_moisture_single
+
+  subroutine findsp (lchnk, ncol, q, t, p, tsp, qsp)
+
+  !----------------------------------------------------------------------- 
+  ! 
+  ! Purpose: 
+  !     find the wet bulb temperature for a given t and q
+  !     in a longitude height section
+  !     wet bulb temp is the temperature and spec humidity that is 
+  !     just saturated and has the same enthalpy
+  !     if q > qs(t) then tsp > t and qsp = qs(tsp) < q
+  !     if q < qs(t) then tsp < t and qsp = qs(tsp) > q
+  !
+  ! Method: 
+  ! a Newton method is used
+  ! first guess uses an algorithm provided by John Petch from the UKMO
+  ! we exclude points where the physical situation is unrealistic
+  ! e.g. where the temperature is outside the range of validity for the
+  !      saturation vapor pressure, or where the water vapor pressure
+  !      exceeds the ambient pressure, or the saturation specific humidity is 
+  !      unrealistic
+  ! 
+  ! Author: P. Rasch
+  ! 
+  !-----------------------------------------------------------------------
+
+  use wv_saturation, only: estblf, hlatv, tmin, hlatf, rgasv, pcf, &
+                           cp, epsqs, ttrice
+
+  !
+  !     input arguments
+  !
+   integer, intent(in) :: lchnk                 ! chunk identifier
+   integer, intent(in) :: ncol                  ! number of atmospheric columns
+
+   real(r8), intent(in) :: q(pcols,pver)        ! water vapor (kg/kg)
+   real(r8), intent(in) :: t(pcols,pver)        ! temperature (K)
+   real(r8), intent(in) :: p(pcols,pver)        ! pressure    (Pa)
+!
+! output arguments
+!
+   real(r8), intent(out) :: tsp(pcols,pver)      ! saturation temp (K)
+   real(r8), intent(out) :: qsp(pcols,pver)      ! saturation mixing ratio (kg/kg)
+!
+! local variables
+!
+   integer i                 ! work variable
+   integer k                 ! work variable
+   logical lflg              ! work variable
+   integer iter              ! work variable
+   integer l                 ! work variable
+   logical :: error_found
+
+   real(r8) omeps                ! 1 minus epsilon
+   real(r8) trinv                ! work variable
+   real(r8) es                   ! sat. vapor pressure
+   real(r8) desdt                ! change in sat vap pressure wrt temperature
+!     real(r8) desdp                ! change in sat vap pressure wrt pressure
+   real(r8) dqsdt                ! change in sat spec. hum. wrt temperature
+   real(r8) dgdt                 ! work variable
+   real(r8) g                    ! work variable
+   real(r8) weight(pcols)        ! work variable
+   real(r8) hlatsb               ! (sublimation)
+   real(r8) hlatvp               ! (vaporization)
+   real(r8) hltalt(pcols,pver)   ! lat. heat. of vap.
+   real(r8) tterm                ! work var.
+   real(r8) qs                   ! spec. hum. of water vapor
+   real(r8) tc                   ! crit temp of transition to ice
+   real(r8) tt0 
+
+! work variables
+   real(r8) t1, q1, dt, dq
+   real(r8) dtm, dqm
+   real(r8) qvd, a1, tmp
+   real(r8) rair
+   real(r8) r1b, c1, c2, c3
+   real(r8) denom
+   real(r8) dttol
+   real(r8) dqtol
+   integer doit(pcols) 
+   real(r8) enin(pcols), enout(pcols)
+   real(r8) tlim(pcols)
+
+   omeps = 1.0_r8 - epsqs
+   trinv = 1.0_r8/ttrice
+   a1 = 7.5_r8*log(10._r8)
+   rair =  287.04_r8
+   c3 = rair*a1/cp
+   dtm = 0._r8    ! needed for iter=0 blowup with f90 -ei
+   dqm = 0._r8    ! needed for iter=0 blowup with f90 -ei
+   dttol = 1.e-4_r8 ! the relative temp error tolerance required to quit the iteration
+   dqtol = 1.e-4_r8 ! the relative moisture error tolerance required to quit the iteration
+   tt0 = 273.15_r8  ! Freezing temperature 
+!  tmin = 173.16 ! the coldest temperature we can deal with
+!
+! max number of times to iterate the calculation
+   iter = 8
+!
+   do k = 1,pver
+
+!
+! first guess on the wet bulb temperature
+!
+      do i = 1,ncol
+
+#ifdef DEBUG
+         if ( (lchnk == lchnklook(nlook) ) .and. (i == icollook(nlook) ) ) then
+            write(iulog,*) ' '
+            write(iulog,*) ' level, t, q, p', k, t(i,k), q(i,k), p(i,k)
+         endif
+#endif
+! limit the temperature range to that relevant to the sat vap pres tables
+#if ( ! defined WACCM_MOZART )
+         tlim(i) = min(max(t(i,k),173._r8),373._r8)
+#else
+         tlim(i) = min(max(t(i,k),128._r8),373._r8)
+#endif
+         es = estblf(tlim(i))
+         denom = p(i,k) - omeps*es
+         qs = epsqs*es/denom
+         doit(i) = 0
+         enout(i) = 1._r8
+! make sure a meaningful calculation is possible
+         if (p(i,k) > 5._r8*es .and. qs > 0._r8 .and. qs < 0.5_r8) then
+!
+! Saturation specific humidity
+!
+             qs = min(epsqs*es/denom,1._r8)
+!
+! "generalized" analytic expression for t derivative of es
+!  accurate to within 1 percent for 173.16 < t < 373.16
+!
+! Weighting of hlat accounts for transition from water to ice
+! polynomial expression approximates difference between es over
+! water and es over ice from 0 to -ttrice (C) (min of ttrice is
+! -40): required for accurate estimate of es derivative in transition
+! range from ice to water also accounting for change of hlatv with t
+! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw
+!
+             tc     = tlim(i) - tt0
+             lflg   = (tc >= -ttrice .and. tc < 0.0_r8)
+             weight(i) = min(-tc*trinv,1.0_r8)
+             hlatsb = hlatv + weight(i)*hlatf
+             hlatvp = hlatv - 2369.0_r8*tc
+             if (tlim(i) < tt0) then
+                hltalt(i,k) = hlatsb
+             else
+                hltalt(i,k) = hlatvp
+             end if
+             enin(i) = cp*tlim(i) + hltalt(i,k)*q(i,k)
+
+! make a guess at the wet bulb temp using a UKMO algorithm (from J. Petch)
+             tmp =  q(i,k) - qs
+             c1 = hltalt(i,k)*c3
+             c2 = (tlim(i) + 36._r8)**2
+             r1b    = c2/(c2 + c1*qs)
+             qvd   = r1b*tmp
+             tsp(i,k) = tlim(i) + ((hltalt(i,k)/cp)*qvd)
+#ifdef DEBUG
+             if ( (lchnk == lchnklook(nlook) ) .and. (i == icollook(nlook) ) ) then
+                write(iulog,*) ' relative humidity ', q(i,k)/qs
+                write(iulog,*) ' first guess ', tsp(i,k)
+             endif
+#endif
+             es = estblf(tsp(i,k))
+             qsp(i,k) = min(epsqs*es/(p(i,k) - omeps*es),1._r8)
+          else
+             doit(i) = 1
+             tsp(i,k) = tlim(i)
+             qsp(i,k) = q(i,k)
+             enin(i) = 1._r8
+          endif
+       end do   ! end do i
+!
+! now iterate on first guess
+!
+      do l = 1, iter
+         dtm = 0
+         dqm = 0
+         do i = 1,ncol
+            if (doit(i) == 0) then
+               es = estblf(tsp(i,k))
+!
+! Saturation specific humidity
+!
+               qs = min(epsqs*es/(p(i,k) - omeps*es),1._r8)
+!
+! "generalized" analytic expression for t derivative of es
+! accurate to within 1 percent for 173.16 < t < 373.16
+!
+! Weighting of hlat accounts for transition from water to ice
+! polynomial expression approximates difference between es over
+! water and es over ice from 0 to -ttrice (C) (min of ttrice is
+! -40): required for accurate estimate of es derivative in transition
+! range from ice to water also accounting for change of hlatv with t
+! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw
+!
+               tc     = tsp(i,k) - tt0
+               lflg   = (tc >= -ttrice .and. tc < 0.0_r8)
+               weight(i) = min(-tc*trinv,1.0_r8)
+               hlatsb = hlatv + weight(i)*hlatf
+               hlatvp = hlatv - 2369.0_r8*tc
+               if (tsp(i,k) < tt0) then
+                  hltalt(i,k) = hlatsb
+               else
+                  hltalt(i,k) = hlatvp
+               end if
+               if (lflg) then
+                  tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3)+tc*(pcf(4) + tc*pcf(5))))
+               else
+                  tterm = 0.0_r8
+               end if
+               desdt = hltalt(i,k)*es/(rgasv*tsp(i,k)*tsp(i,k)) + tterm*trinv
+               dqsdt = (epsqs + omeps*qs)/(p(i,k) - omeps*es)*desdt
+!              g = cp*(tlim(i)-tsp(i,k)) + hltalt(i,k)*q(i,k)- hltalt(i,k)*qsp(i,k)
+               g = enin(i) - (cp*tsp(i,k) + hltalt(i,k)*qsp(i,k))
+               dgdt = -(cp + hltalt(i,k)*dqsdt)
+               t1 = tsp(i,k) - g/dgdt
+               dt = abs(t1 - tsp(i,k))/t1
+               tsp(i,k) = max(t1,tmin)
+               es = estblf(tsp(i,k))
+               q1 = min(epsqs*es/(p(i,k) - omeps*es),1._r8)
+               dq = abs(q1 - qsp(i,k))/max(q1,1.e-12_r8)
+               qsp(i,k) = q1
+#ifdef DEBUG
+               if ( (lchnk == lchnklook(nlook) ) .and. (i == icollook(nlook) ) ) then
+                  write(iulog,*) ' rel chg lev, iter, t, q ', k, l, dt, dq, g
+               endif
+#endif
+               dtm = max(dtm,dt)
+               dqm = max(dqm,dq)
+! if converged at this point, exclude it from more iterations
+               if (dt < dttol .and. dq < dqtol) then
+                  doit(i) = 2
+               endif
+               enout(i) = cp*tsp(i,k) + hltalt(i,k)*qsp(i,k)
+! bail out if we are too near the end of temp range
+#if ( ! defined WACCM_MOZART )
+               if (tsp(i,k) < 174.16_r8) then
+#else
+               if (tsp(i,k) < 130.16_r8) then
+#endif
+                  doit(i) = 4
+               endif
+            else
+            endif
+         end do              ! do i = 1,ncol
+
+         if (dtm < dttol .and. dqm < dqtol) then
+            go to 10
+         endif
+
+      end do                 ! do l = 1,iter
+10    continue
+
+      error_found = .false.
+      if (dtm > dttol .or. dqm > dqtol) then
+         do i = 1,ncol
+            if (doit(i) == 0) error_found = .true.
+         end do
+         if (error_found) then
+            do i = 1,ncol
+               if (doit(i) == 0) then
+                  write(iulog,*) ' findsp not converging at point i, k ', i, k
+                  write(iulog,*) ' t, q, p, enin ', t(i,k), q(i,k), p(i,k), enin(i)
+                  write(iulog,*) ' tsp, qsp, enout ', tsp(i,k), qsp(i,k), enout(i)
+                  call endrun ('FINDSP')
+               endif
+            end do
+         endif
+      endif
+      do i = 1,ncol
+         if (doit(i) == 2 .and. abs((enin(i)-enout(i))/(enin(i)+enout(i))) > 1.e-4_r8) then
+            error_found = .true.
+         endif
+      end do
+      if (error_found) then
+         do i = 1,ncol
+            if (doit(i) == 2 .and. abs((enin(i)-enout(i))/(enin(i)+enout(i))) > 1.e-4_r8) then
+               write(iulog,*) ' the enthalpy is not conserved for point ', &
+                  i, k, enin(i), enout(i)
+               write(iulog,*) ' t, q, p, enin ', t(i,k), q(i,k), p(i,k), enin(i)
+               write(iulog,*) ' tsp, qsp, enout ', tsp(i,k), qsp(i,k), enout(i)
+               call endrun ('FINDSP')
+            endif
+         end do
+      endif
+      
+   end do                    ! level loop (k=1,pver)
+
+   return
+   end subroutine findsp
+
+  ! ------------------------ !
+  !                          ! 
+  ! End of subroutine blocks !
+  !                          !
+  ! ------------------------ !
+
+  end module uwshcu
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_camuwshcu_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_camuwshcu_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_camuwshcu_driver.F	(revision 17)
@@ -0,0 +1,381 @@
+MODULE module_cu_camuwshcu_driver
+  USE shr_kind_mod,    only: r8 => shr_kind_r8
+
+! Roughly based on convect_shallow_tend in convect_shallow.F90 from CAM
+! but tailored for the UW shallow cumulus scheme.
+
+  IMPLICIT NONE
+
+  PRIVATE                  !Default to private
+  PUBLIC :: &              !Public entities
+       camuwshcu_driver
+
+CONTAINS
+
+!------------------------------------------------------------------------
+SUBROUTINE camuwshcu_driver(                                  &
+              ids,ide, jds,jde, kds,kde                       &
+             ,ims,ime, jms,jme, kms,kme                       &
+             ,its,ite, jts,jte, kts,kte                       &
+             ,num_moist, dt                                   &
+             ,p, p8w, pi_phy, z, z_at_w, dz8w                 &
+             ,t_phy, u_phy, v_phy                             &
+             ,moist, qv, qc, qi                               &
+             ,pblh_in, tke_pbl, cldfra, cldfra_old, cldfrash  &
+             ,cush_inout, rainsh, pratesh, snowsh, icwmrsh    &
+             ,cmfmc, cmfmc2_inout, rprdsh_inout, cbmf_inout   &
+             ,cmfsl, cmflq, dlf, evapcsh_inout                &
+             ,rliq, rliq2_inout, cubot, cutop                 &
+             ,rushten, rvshten, rthshten                      &
+             ,rqvshten, rqcshten, rqrshten                    &
+             ,rqishten, rqsshten, rqgshten                    &
+             ,ht                                              &
+                                                              )
+! This routine is based on convect_shallow_tend in CAM. It handles the
+! mapping of variables from the WRF to the CAM framework for the UW
+! shallow convective parameterization.
+!
+! Author: William.Gustafson@pnl.gov, Jan. 2010
+!------------------------------------------------------------------------
+  USE module_state_description, only: param_first_scalar, &
+                                      p_qc, p_qr, p_qi, p_qs, p_qg
+  USE module_cam_support,       only: pcols, pver
+  USE constituents,             only: cnst_get_ind
+  USE physconst,                only: cpair, gravit, latvap
+  USE uwshcu,                   only: compute_uwshcu_inv
+  USE wv_saturation,            only: fqsatd
+
+! Subroutine arguments...
+  INTEGER, INTENT(IN   ) ::    ids,ide, jds,jde, kds,kde,  &
+                               ims,ime, jms,jme, kms,kme,  &
+                               its,ite, jts,jte, kts,kte,  &
+                               num_moist
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), INTENT(IN) :: &
+                              moist    !moist tracer array
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: &
+                             cldfra, & !cloud fraction
+                         cldfra_old, & !previous time step cloud fraction
+                               dz8w, & !height between layer interface (m)
+                                  p, & !pressure at mid-level (Pa)
+                                p8w, & !pressure at level interface (Pa)
+                             pi_phy, & !exner function, (p0/p)^(R/cpair) (none)
+                                 qv, & !water vapor mixing ratio (kg/kg-dry air)
+                              t_phy, & !temperature (K)
+                            tke_pbl, & !turbulent kinetic energy from PBL (m2/s2)
+                              u_phy, & !zonal wind component on T points (m/s)
+                              v_phy, & !meridional wind component on T points (m/s)
+                                  z, & !height above sea level at mid-level (m)
+                             z_at_w    !height above sea level at interface (m)
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN), OPTIONAL :: &
+                                 qc, & !cloud droplet mixing ratio (kg/kg-dry air)
+                                 qi    !cloud ice crystal mixing ratio (kg/kg-dry air)
+
+  REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: &
+                            pblh_in, & !height of PBL (m)
+                            ht         !Terrain height (m)
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: &
+                           cldfrash, & !shallow convective cloud fraction
+                              cmfmc, & !deep+shalow cloud fraction (already contains deep part from ZM)
+                       cmfmc2_inout, & !shallow cloud fraction
+                              cmflq, & !convective flux of total water in energy unit (~units)
+                              cmfsl, & !convective flux of liquid water static energy (~units)
+                                dlf, & !dq/dt due to export of cloud water (input=deep from ZM, output=deep+shallow)
+                      evapcsh_inout, & !output array for evaporation of shallow convection precipitation (kg/kg/s)
+                            icwmrsh, & !shallow cumulus in-cloud water mixing ratio (kg/m2)
+                       rprdsh_inout, & !dq/dt due to deep(~?) & shallow convective rainout (~units?)
+                            rushten, & !UNcoupled zonal wind tend from shallow Cu scheme (m/s2)
+                            rvshten, & !UNcoupled meridional wind tend from shallow Cu scheme (m/s2)
+                           rthshten, & !UNcoupled potential temperature tendendcy from shallow cu scheme (K/s)
+                           rqvshten, & !UNcoupled water vapor mixing ratio tend from shallow Cu scheme (kg/kg/s)
+                           rqcshten, & !UNcoupled clod droplet mixing ratio tend from shallow Cu scheme (kg/kg/s)
+                           rqrshten, & !UNcoupled raindrop mixing ratio tend from shallow Cu scheme (kg/kg/s)
+                           rqishten, & !UNcoupled ice crystal mixing ratio tend from shallow Cu scheme (kg/kg/s)
+                           rqsshten, & !UNcoupled snow mixing ratio tend from shallow Cu scheme (kg/kg/s)
+                           rqgshten    !UNcoupled graupel mixing ratio tend from shallow Cu scheme (kg/kg/s)
+
+  REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: &
+                         cbmf_inout, & !cloud base mass flux (kg/m2/s)
+                              cubot, & !level number of base of convection
+                              cutop, & !level number of top of convection
+                         cush_inout, & !convective scale height (~units?)
+                            pratesh, & !time-step shallow cumulus precip rate at surface (mm/s)
+                             rainsh, & !time-step shallow cumulus precip (rain+snow) at surface (mm)
+                               rliq, & !vertically-integrated reserved cloud condensate (m/s)
+                        rliq2_inout, & !vertically-integrated reserved cloud condensate for shallow (m/s)
+                             snowsh    !accumulated convective snow rate at surface for shallow Cu (m/s) ~are these the units we should use for WRF?
+
+  REAL, INTENT(IN) :: &
+                                 dt    !time step (s)
+
+! Local variables...
+  !Variables dimensioned for input to CAM routines
+  REAL(r8), DIMENSION(pcols, kte, 5) ::  &   ! dimensioned by 5(=ncnst) associated with CAM constituents (cnst_name size)
+                             moist8, & !tracer array for CAM routines
+                         tnd_tracer    !tracer tendency
+
+  REAL(r8), DIMENSION(pcols, kte+1) ::  &
+                              pint8, & !pressure at layer interface (Pa)
+                                zi8, & !height above the ground at interfaces (m)
+                               tke8, & !turbulent kinetic energy at level interfaces (m2/s2)
+                              slflx, & !convective liquid water static energy flux (~units?)
+                              qtflx    !convective total water flux (~units?)
+                                                            
+
+
+  REAL(r8), DIMENSION(pcols, kte) ::  &
+                               cld8, & !cloud fraction
+                            cldold8, & !previous time step cloud fraction ~should this be just the convective part?
+                             cmfdqs, & !convective snow production (~units?)
+                             cmfmc2, & !cloud fraction
+                            evapcsh, & !evaporation of shallow convection precipitation >= 0. (kg/kg/s)
+                           iccmr_uw, & !in-cloud cumulus LWC+IWC (kg/m2)
+                           icwmr_uw, & !in-cloud cumulus LWC (kg/m2)
+                           icimr_uw, & !in-cloud cumulus IWC (kg/m2)
+                              pdel8, & !pressure difference between layer interfaces (Pa)
+                           pdeldry8, & !pressure difference between layer interfaces for dry atm (Pa)
+                              pmid8, & !pressure at layer middle (Pa)
+                                qc2, & !dq/dt due to export of cloud water
+                                qh8, & !specific humidity (kg/kg-moist air)
+                                qc8, & !cloud liquid water (~units?)
+                                qi8, & !cloud ice (~units?)
+                              qhtnd, & !specific humidity tendency (kg/kg/s)
+                              qctnd, & !cloud water mixing ratio tendency
+                              qitnd, & !cloud ice mixing ratio tendency
+                             rprdsh, & !dq/dt due to deep(~?) & shallow convective rainout (~units?)
+                                 s8, & !dry static energy (J/kg)
+                              shfrc, & !shallow cloud fraction
+                               stnd, & !heating rate (dry static energy tendency, W/kg)
+                                 t8, & !temperature (K)
+                                 u8, & !environment zonal wind (m/s)
+                               utnd, & !zonal wind tendency (m/s2)
+                                 v8, & !environment meridional wind (m/s)
+                               vtnd, & !meridional wind tendency (m/s2)
+                                zm8    !height between interfaces (m)
+
+  REAL(r8), DIMENSION(pcols) ::  &
+                               cbmf, & !cloud base mass flux (kg/m2/s)
+                               cnb2, & !bottom level of convective activity
+                               cnt2, & !top level of convective activity
+                               cush, & !convective scale height (~units?)
+                               pblh, & !pblh height (m)
+                              precc, & !convective precip (rain+snow) at surface for shallow Cu (m/s)
+                              rliq2, & !vertically-integrated reserved cloud condensate for shallow (m/s)
+                               snow    !convective snow rate at surface (m/s)
+
+  !Other local vars
+  REAL(r8) :: ztodt        !2 delta-t (s)
+  INTEGER :: i, j, k, kflip, m, mp1
+  INTEGER :: cnb, cnt      !index of cloud base and top in CAM world (indices decrease with height)
+  INTEGER :: lchnk         !chunk identifier, used to map 2-D to 1-D arrays in WRF
+  INTEGER :: ncnst         !number of tracers
+  INTEGER :: ncol          !number of atmospheric columns in chunk
+  CHARACTER(LEN=250) :: msg
+!
+! Initialize...
+!
+  ncol  = 1           !chunk size in WRF is 1 since we loop over all columns in a tile
+! ncnst = num_moist-1 !currently we only handle the moist array for tracers
+  ncnst = 5 ! this is associated with moist8 array
+  ztodt = 2.*dt
+!
+! Map variables to inputs for zm_convr and call it...
+! Loop over the points in the tile and treat them each as a CAM chunk.
+!
+  ij_loops : do j = jts,jte
+     do i = its,ite
+        lchnk = (j-jts)*(ite-its+1) + (i-its+1) !1-D index location from the 2-D tile
+
+        !Flip variables on the layer interfaces
+        do k = kts,kte+1
+           kflip = kte-k+2
+
+           pint8(1,kflip) = p8w(i,k,j)
+           zi8(1,kflip)   = z_at_w(i,k,j) - ht(i,j) ! height above the ground at interfaces
+        end do
+
+        !Flip variables on the layer middles
+        do k = kts,kte
+           kflip = kte-k+1
+
+           cld8(1,kflip)    = cldfra(i,k,j)
+           cldold8(1,kflip) = cldfra_old(i,k,j)
+           pdel8(1,kflip)   = p8w(i,k,j) - p8w(i,k+1,j)
+           pmid8(1,kflip)   = p(i,k,j)
+           qh8(1,kflip)     = max( qv(i,k,j)/(1. + qv(i,k,j)), 1e-30 ) !values of 0 cause a crash in entropy
+           if( present(qc) ) then
+              qc8(1,kflip)  = qc(i,k,j)/(1. + qv(i,k,j)) !Convert to moist mix ratio
+           else
+              qc8(1,kflip)  = 0.
+           end if
+           if( present(qi) ) then
+              qi8(1,kflip)  = qi(i,k,j)/(1. + qv(i,k,j)) !Used in convtran, ditto for conversion
+           else
+              qi8(1,kflip)  = 0.
+           end if
+           pdeldry8(1,kflip)= pdel8(1,kflip)*(1._r8 - qh8(1,kflip))
+           t8(1,kflip)      = t_phy(i,k,j)
+           s8(1,kflip)      = cpair*t8(1,kflip) + gravit*(z(i,k,j)-ht(i,j))
+           u8(1,kflip)      = u_phy(i,k,j)
+           v8(1,kflip)      = v_phy(i,k,j)
+           zm8(1,kflip)     = dz8w(i,k,j)
+        end do
+
+        !TKE in CAM is on the interfaces but in WRF it is on the layer
+        !middle. We will interpolate the TKE from the to the interfaces
+        !and then just use the lowest TKE for the surface and the highest
+        !TKE at the top.
+        tke8(1,kte+1) = tke_pbl(i,1,j)    !surface
+        tke8(1,1)     = tke_pbl(i,kte,j)  !model top interface
+        do k = kts,kte-1
+           kflip = kte-k+1
+           tke8(1,kflip) = 0.5*(tke_pbl(i,k,j) + tke_pbl(i,k+1,j))
+        end do
+
+        !Flip the tracer array -
+        !shift tracer dimension down one to remove "blank" index and
+        !convert to wet instead of dry mixing ratios.
+        do k = kts,kte
+           kflip = kte-k+1
+!!$           do m = 1,ncnst
+!!$              moist8(1,kflip,m) = moist(i,k,j,m+1)/(1. + qv(i,k,j))
+!!$           end do
+
+!~For now, send replicate part of the tracer array and send zeros for the
+! rest since CAM treats condensate diagnostically compared to WRF that is
+! prognostic. This avoids issues with hard-wired assumptions in the UW
+! ShCu scheme. This should be looked at again when more time is available.
+! Set to zero for most then overwrite as needed...
+           moist8(1,kflip,1:ncnst) = 0.
+
+           moist8(1,kflip,1) = qv(i,k,j)/(1. + qv(i,k,j))
+
+           call cnst_get_ind( 'CLDLIQ', m )
+           moist8(1,kflip,m) = qc(i,k,j)/(1. + qv(i,k,j))
+
+           call cnst_get_ind( 'CLDICE', m )
+           moist8(1,kflip,m) = qi(i,k,j)/(1. + qv(i,k,j))
+
+           call cnst_get_ind( 'NUMLIQ', m )
+           moist8(1,kflip,m) = 0.
+
+           call cnst_get_ind( 'NUMICE', m )
+           moist8(1,kflip,m) = 0.
+        end do
+
+        !Some remapping to get arrays to pass into the routine
+        pblh(1) = pblh_in(i,j)
+        cush(1) = cush_inout(i,j)
+!
+! Main guts of the routine...
+! This is a bit inefficient because we are flippling the arrays and they
+! will then get flipped back again by compute_uwshcu_inv. We are doing
+! this to preserve the CAM code as much as possible for maintenance.
+!
+        call compute_uwshcu_inv(                        &
+             pcols, pver, ncol, ncnst, ztodt,           &
+             pint8, zi8, pmid8, zm8, pdel8,             &
+             u8, v8, qh8, qc8, qi8,                     &
+             t8, s8, moist8,                            &
+             tke8, cld8, cldold8, pblh, cush,           &
+             cmfmc2, slflx, qtflx,                      &
+             qhtnd, qctnd, qitnd,                       &
+             stnd, utnd, vtnd, tnd_tracer,              &
+             rprdsh, cmfdqs, precc, snow,               &
+             evapcsh, shfrc, iccmr_UW, icwmr_UW,        &
+             icimr_UW, cbmf, qc2, rliq2,                &
+             cnt2, cnb2, fqsatd, lchnk, pdeldry8        )
+!
+! Map output into WRF-dimensioned arrays...
+!
+        cush_inout(i,j) = cush(1)
+
+        do k = kts,kte
+           kflip = kte-k+1
+
+           !Add shallow reserved cloud condensate to deep reserved cloud condensate
+           ! dlf (kg/kg/s, qc in CAM),  rliq done below
+           dlf(i,k,j)          = dlf(i,k,j) + qc2(1,kflip)
+
+           evapcsh_inout(i,k,j)= evapcsh(1,kflip)
+           icwmrsh(i,k,j)      = icwmr_uw(1,kflip)
+
+           rprdsh(1,kflip)     = rprdsh(1,kflip) + cmfdqs(1,kflip)
+           rprdsh_inout(i,k,j) = rprdsh(1,kflip)
+           !Not doing rprdtot for now since not yet used by other CAM routines in WRF
+
+           !Tendencies of winds, potential temperature, and moisture
+           !fields treated specifically by UW scheme
+           rushten(i,k,j)  = utnd(1,kflip)
+           rvshten(i,k,j)  = vtnd(1,kflip)
+           rthshten(i,k,j) = stnd(1,kflip)/cpair/pi_phy(i,k,j)
+           rqvshten(i,k,j) = qhtnd(1,kflip)/(1. - qv(i,k,j))
+           if( p_qc >= param_first_scalar ) &
+                rqcshten(i,k,j) = qctnd(1,kflip)/(1. - qv(i,k,j))
+           if( p_qi >= param_first_scalar ) &
+                rqishten(i,k,j) = qitnd(1,kflip)/(1. - qv(i,k,j))
+
+!~Turn off tendencies for most condensates since CAM treats them diagnostically.
+!           !Tendencies of tracers except qv,qc,qi
+!!~need to make sure qg tendency is propagated through to application
+!           do m = 4,ncnst
+!              mp1 = m+1 !shift to p_ value for the tracer
+!              if( mp1==p_qr ) then
+!                 rqrshten(i,k,j) = tnd_tracer(1,kflip,m)/(1. - qv(i,k,j))
+!              else if( mp1==p_qs ) then
+!                 rqsshten(i,k,j) = tnd_tracer(1,kflip,m)/(1. - qv(i,k,j))
+!              else if( mp1==p_qg ) then
+!                 rqgshten(i,k,j) = tnd_tracer(1,kflip,m)/(1. - qv(i,k,j))
+!              else
+!                 write(msg,'(a,i3)') "WARNING: UW shallow Cu cannot handle tracer ",m
+!                 call wrf_debug(100, msg)
+!              end if
+!           end do
+
+           !Combine shallow and deep cumulus updraft mass flux
+           cmfmc2_inout(i,k,j) = cmfmc2(1,kflip)
+           cmfmc(i,k,j)        = cmfmc(i,k,j) + cmfmc2(1,kflip)
+
+        end do !k-loop to kte
+
+        do k = kts,kte+1
+           kflip = kte-k+2
+
+           !Convective fluxes of 'sl' and 'qt' in energy unit
+           cmfsl(i,k,j) = slflx(1,kflip)
+           cmflq(i,k,j) = qtflx(1,kflip)*latvap
+        end do !k-loop to kte+1
+
+        !Calculate fractional occurance of shallow convection
+        !~Not doing this since it would require adding time averaging ability across output times
+
+        !Rain rate for shallow convection
+!       rainsh(i,j)  = precc(1)*1e3
+        pratesh(i,j) = precc(1)*1e3/dt !~this will need changing for adaptive time steps and cudt
+
+        !Get indices of convection top and bottom based on deep+shallow
+        !Note: cnt2 and cnb2 have indices decreasing with height, but
+        !      cutop and cubot have indicies increasing with height
+        kflip = kte - cutop(i,j) + 1
+        cnt = kflip
+        if( cnt2(1) < kflip ) cnt = cnt2(1)
+        cutop(i,j) = kte - cnt + 1
+
+        kflip = kte - cubot(i,j) + 1
+        cnb = kflip
+        if( cnb2(1) > kflip ) cnb = cnb2(1)
+        cubot(i,j) = kte - cnb + 1
+
+        !Add shallow reserved cloud condensate to deep reserved cloud condensate
+        !dlf done above, rliq (m/s)
+        rliq2_inout(i,j) = rliq2(1)
+        rliq(i,j)        = rliq(i,j) + rliq2(1)
+
+     end do
+  end do ij_loops
+END SUBROUTINE camuwshcu_driver
+
+END MODULE module_cu_camuwshcu_driver
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_camzm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_camzm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_camzm.F	(revision 17)
@@ -0,0 +1,3734 @@
+#define WRF_PORT
+
+module module_cu_camzm
+
+!Based on zm_conv.F90 from CAM
+
+!---------------------------------------------------------------------------------
+! Purpose:
+!
+! Interface from Zhang-McFarlane convection scheme, includes evaporation of convective 
+! precip from the ZM scheme
+!
+! Apr 2006: RBN: Code added to perform a dilute ascent for closure of the CM mass flux
+!                based on an entraining plume a la Raymond and Blythe (1992)
+!
+! Author: Byron Boville, from code in tphysbc
+! Ported from CAM to WRF by William.Gustafson@pnl.gov, Nov. 2009
+!   updated to CESM1_0_1, Nov. 2010
+!
+!---------------------------------------------------------------------------------
+
+  use shr_kind_mod,    only: r8 => shr_kind_r8
+  use cldwat,          only: cldwat_fice
+  use physconst,       only: cpair, epsilo, gravit, latice, latvap, tmelt, rair, &
+                             cpwv, cpliq, rh2o
+#ifndef WRF_PORT
+  use spmd_utils,      only: masterproc
+  use ppgrid,          only: pcols, pver, pverp
+
+  use abortutils,      only: endrun
+  use cam_logfile,     only: iulog
+
+#else
+  use module_cam_support, only: masterproc, &
+                                pcols, pver, pverp, &
+                                endrun, &
+                                iulog
+  use module_wrf_error
+#endif
+
+  implicit none
+
+  save
+  private                         ! Make default type private to the module
+!
+! PUBLIC: interfaces
+!
+  public zmconv_readnl            ! read zmconv_nl namelist
+  public zm_convi                 ! ZM schemea
+  public zm_convr                 ! ZM schemea
+  public zm_conv_evap             ! evaporation of precip from ZM schemea
+  public convtran                 ! convective transport
+  public momtran                  ! convective momentum transport
+
+!
+! Private data
+!
+   real(r8), parameter :: unset_r8 = huge(1.0_r8)
+   real(r8) :: zmconv_c0_lnd = unset_r8    
+   real(r8) :: zmconv_c0_ocn = unset_r8    
+   real(r8) :: zmconv_ke     = unset_r8    
+   real(r8) rl         ! wg latent heat of vaporization.
+   real(r8) cpres      ! specific heat at constant pressure in j/kg-degk.
+   real(r8), parameter :: capelmt = 70._r8  ! threshold value for cape for deep convection.
+   real(r8) :: ke           ! Tunable evaporation efficiency set from namelist input zmconv_ke
+   real(r8) :: c0_lnd       ! set from namelist input zmconv_c0_lnd
+   real(r8) :: c0_ocn       ! set from namelist input zmconv_c0_ocn
+   real(r8) tau   ! convective time scale
+   real(r8),parameter :: a = 21.656_r8
+   real(r8),parameter :: b = 5418._r8
+   real(r8),parameter :: c1 = 6.112_r8
+   real(r8),parameter :: c2 = 17.67_r8
+   real(r8),parameter :: c3 = 243.5_r8
+   real(r8) :: tfreez
+   real(r8) :: eps1
+      
+
+   logical :: no_deep_pbl ! default = .false.
+                          ! no_deep_pbl = .true. eliminates deep convection entirely within PBL 
+   
+
+!moved from moistconvection.F90
+   real(r8) :: rgrav       ! reciprocal of grav
+   real(r8) :: rgas        ! gas constant for dry air
+   real(r8) :: grav        ! = gravit
+   real(r8) :: cp          ! = cpres = cpair
+   
+   integer  limcnv       ! top interface level limit for convection
+   real(r8),parameter ::  tiedke_add = 0.5_r8   
+contains
+
+subroutine zmconv_readnl(nlfile)
+#ifndef WRF_PORT
+   use namelist_utils,  only: find_group_name
+   use units,           only: getunit, freeunit
+   use mpishorthand
+#endif
+
+   character(len=*), intent(in) :: nlfile  ! filepath for file containing namelist input
+
+#ifndef WRF_PORT
+   ! Local variables
+   integer :: unitn, ierr
+   character(len=*), parameter :: subname = 'zmconv_readnl'
+
+   namelist /zmconv_nl/ zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke
+   !-----------------------------------------------------------------------------
+
+   if (masterproc) then
+      unitn = getunit()
+      open( unitn, file=trim(nlfile), status='old' )
+      call find_group_name(unitn, 'zmconv_nl', status=ierr)
+      if (ierr == 0) then
+         read(unitn, zmconv_nl, iostat=ierr)
+         if (ierr /= 0) then
+            call endrun(subname // ':: ERROR reading namelist')
+         end if
+      end if
+      close(unitn)
+      call freeunit(unitn)
+
+      ! set local variables
+      c0_lnd = zmconv_c0_lnd
+      c0_ocn = zmconv_c0_ocn
+      ke = zmconv_ke
+
+   end if
+
+#ifdef SPMD
+   ! Broadcast namelist variables
+   call mpibcast(c0_lnd,            1, mpir8,  0, mpicom)
+   call mpibcast(c0_ocn,            1, mpir8,  0, mpicom)
+   call mpibcast(ke,                1, mpir8,  0, mpicom)
+#endif
+
+#else
+! WRF_PORT currently uses hard-wired values for the namelist input. The
+! values could easily be setup to come from the Registry in the future.
+! The hard-wired values are the defaults for the fv core. They should be
+! verified by somebody knowledgable on the matter.
+   c0_lnd = 0.0035d0
+   c0_ocn = 0.0035d0
+   ke     = 1.0e-6
+#endif
+
+end subroutine zmconv_readnl
+
+
+subroutine zm_convi(limcnv_in, no_deep_pbl_in)
+
+#ifndef WRF_PORT
+   use dycore,       only: dycore_is, get_resolution
+#endif
+
+   integer, intent(in)           :: limcnv_in       ! top interface level limit for convection
+   logical, intent(in), optional :: no_deep_pbl_in  ! no_deep_pbl = .true. eliminates ZM convection entirely within PBL 
+
+   ! local variables
+   character(len=32)   :: hgrid           ! horizontal grid specifier
+
+   ! Initialization of ZM constants
+   limcnv = limcnv_in
+   tfreez = tmelt
+   eps1   = epsilo
+   rl     = latvap
+   cpres  = cpair
+   rgrav  = 1.0_r8/gravit
+   rgas   = rair
+   grav   = gravit
+   cp     = cpres
+
+   if ( present(no_deep_pbl_in) )  then
+      no_deep_pbl = no_deep_pbl_in
+   else
+      no_deep_pbl = .false.
+   endif
+
+   ! tau=4800. were used in canadian climate center. however, in echam3 t42, 
+   ! convection is too weak, thus adjusted to 2400.
+
+#ifndef WRF_PORT
+   hgrid = get_resolution()
+#endif
+   tau = 3600._r8
+
+   if ( masterproc ) then
+      write(iulog,*) 'tuning parameters zm_convi: tau',tau
+#ifdef WRF_PORT
+      call wrf_debug(100,iulog)
+#endif
+      write(iulog,*) 'tuning parameters zm_convi: c0_lnd',c0_lnd, ', c0_ocn', c0_ocn 
+#ifdef WRF_PORT
+      call wrf_debug(100,iulog)
+#endif
+      write(iulog,*) 'tuning parameters zm_convi: ke',ke
+#ifdef WRF_PORT
+      call wrf_debug(100,iulog)
+#endif
+      write(iulog,*) 'tuning parameters zm_convi: no_deep_pbl',no_deep_pbl
+#ifdef WRF_PORT
+      call wrf_debug(100,iulog)
+   endif
+#endif
+
+   if (masterproc) then 
+      write(iulog,*)'**** ZM: DILUTE Buoyancy Calculation ****'
+#ifdef WRF_PORT
+      call wrf_debug(100,iulog)
+#endif
+   end if
+
+end subroutine zm_convi
+
+
+
+subroutine zm_convr(lchnk   ,ncol    , &
+                    t       ,qh      ,prec    ,jctop   ,jcbot   , &
+                    pblh    ,zm      ,geos    ,zi      ,qtnd    , &
+                    heat    ,pap     ,paph    ,dpp     , &
+                    delt    ,mcon    ,cme     ,cape    , &
+                    tpert   ,dlf     ,pflx    ,zdu     ,rprd    , &
+                    mu      ,md      ,du      ,eu      ,ed      , &
+                    dp      ,dsubcld ,jt      ,maxg    ,ideep   , &
+                    lengath ,ql      ,rliq    ,landfrac)
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! Main driver for zhang-mcfarlane convection scheme 
+! 
+! Method: 
+! performs deep convective adjustment based on mass-flux closure
+! algorithm.
+! 
+! Author:guang jun zhang, m.lazare, n.mcfarlane. CAM Contact: P. Rasch
+!
+! This is contributed code not fully standardized by the CAM core group.
+! All variables have been typed, where most are identified in comments
+! The current procedure will be reimplemented in a subsequent version
+! of the CAM where it will include a more straightforward formulation
+! and will make use of the standard CAM nomenclature
+! 
+!-----------------------------------------------------------------------
+#ifdef WRF_PORT
+  use module_cam_support, only: pcnst
+#else
+   use constituents, only: pcnst
+#endif
+
+!
+! ************************ index of variables **********************
+!
+!  wg * alpha    array of vertical differencing used (=1. for upstream).
+!  w  * cape     convective available potential energy.
+!  wg * capeg    gathered convective available potential energy.
+!  c  * capelmt  threshold value for cape for deep convection.
+!  ic  * cpres    specific heat at constant pressure in j/kg-degk.
+!  i  * dpp      
+!  ic  * delt     length of model time-step in seconds.
+!  wg * dp       layer thickness in mbs (between upper/lower interface).
+!  wg * dqdt     mixing ratio tendency at gathered points.
+!  wg * dsdt     dry static energy ("temp") tendency at gathered points.
+!  wg * dudt     u-wind tendency at gathered points.
+!  wg * dvdt     v-wind tendency at gathered points.
+!  wg * dsubcld  layer thickness in mbs between lcl and maxi.
+!  ic  * grav     acceleration due to gravity in m/sec2.
+!  wg * du       detrainment in updraft. specified in mid-layer
+!  wg * ed       entrainment in downdraft.
+!  wg * eu       entrainment in updraft.
+!  wg * hmn      moist static energy.
+!  wg * hsat     saturated moist static energy.
+!  w  * ideep    holds position of gathered points vs longitude index.
+!  ic  * pver     number of model levels.
+!  wg * j0       detrainment initiation level index.
+!  wg * jd       downdraft   initiation level index.
+!  ic  * jlatpr   gaussian latitude index for printing grids (if needed).
+!  wg * jt       top  level index of deep cumulus convection.
+!  w  * lcl      base level index of deep cumulus convection.
+!  wg * lclg     gathered values of lcl.
+!  w  * lel      index of highest theoretical convective plume.
+!  wg * lelg     gathered values of lel.
+!  w  * lon      index of onset level for deep convection.
+!  w  * maxi     index of level with largest moist static energy.
+!  wg * maxg     gathered values of maxi.
+!  wg * mb       cloud base mass flux.
+!  wg * mc       net upward (scaled by mb) cloud mass flux.
+!  wg * md       downward cloud mass flux (positive up).
+!  wg * mu       upward   cloud mass flux (positive up). specified
+!                at interface
+!  ic  * msg      number of missing moisture levels at the top of model.
+!  w  * p        grid slice of ambient mid-layer pressure in mbs.
+!  i  * pblt     row of pbl top indices.
+!  w  * pcpdh    scaled surface pressure.
+!  w  * pf       grid slice of ambient interface pressure in mbs.
+!  wg * pg       grid slice of gathered values of p.
+!  w  * q        grid slice of mixing ratio.
+!  wg * qd       grid slice of mixing ratio in downdraft.
+!  wg * qg       grid slice of gathered values of q.
+!  i/o * qh       grid slice of specific humidity.
+!  w  * qh0      grid slice of initial specific humidity.
+!  wg * qhat     grid slice of upper interface mixing ratio.
+!  wg * ql       grid slice of cloud liquid water.
+!  wg * qs       grid slice of saturation mixing ratio.
+!  w  * qstp     grid slice of parcel temp. saturation mixing ratio.
+!  wg * qstpg    grid slice of gathered values of qstp.
+!  wg * qu       grid slice of mixing ratio in updraft.
+!  ic  * rgas     dry air gas constant.
+!  wg * rl       latent heat of vaporization.
+!  w  * s        grid slice of scaled dry static energy (t+gz/cp).
+!  wg * sd       grid slice of dry static energy in downdraft.
+!  wg * sg       grid slice of gathered values of s.
+!  wg * shat     grid slice of upper interface dry static energy.
+!  wg * su       grid slice of dry static energy in updraft.
+!  i/o * t       
+!  o  * jctop    row of top-of-deep-convection indices passed out.
+!  O  * jcbot    row of base of cloud indices passed out.
+!  wg * tg       grid slice of gathered values of t.
+!  w  * tl       row of parcel temperature at lcl.
+!  wg * tlg      grid slice of gathered values of tl.
+!  w  * tp       grid slice of parcel temperatures.
+!  wg * tpg      grid slice of gathered values of tp.
+!  i/o * u        grid slice of u-wind (real).
+!  wg * ug       grid slice of gathered values of u.
+!  i/o * utg      grid slice of u-wind tendency (real).
+!  i/o * v        grid slice of v-wind (real).
+!  w  * va       work array re-used by called subroutines.
+!  wg * vg       grid slice of gathered values of v.
+!  i/o * vtg      grid slice of v-wind tendency (real).
+!  i  * w        grid slice of diagnosed large-scale vertical velocity.
+!  w  * z        grid slice of ambient mid-layer height in metres.
+!  w  * zf       grid slice of ambient interface height in metres.
+!  wg * zfg      grid slice of gathered values of zf.
+!  wg * zg       grid slice of gathered values of z.
+!
+!-----------------------------------------------------------------------
+!
+! multi-level i/o fields:
+!  i      => input arrays.
+!  i/o    => input/output arrays.
+!  w      => work arrays.
+!  wg     => work arrays operating only on gathered points.
+!  ic     => input data constants.
+!  c      => data constants pertaining to subroutine itself.
+!
+! input arguments
+!
+   integer, intent(in) :: lchnk                   ! chunk identifier
+   integer, intent(in) :: ncol                    ! number of atmospheric columns
+
+   real(r8), intent(in) :: t(pcols,pver)          ! grid slice of temperature at mid-layer.
+   real(r8), intent(in) :: qh(pcols,pver,pcnst)   ! grid slice of specific humidity.
+   real(r8), intent(in) :: pap(pcols,pver)     
+   real(r8), intent(in) :: paph(pcols,pver+1)
+   real(r8), intent(in) :: dpp(pcols,pver)        ! local sigma half-level thickness (i.e. dshj).
+   real(r8), intent(in) :: zm(pcols,pver)
+   real(r8), intent(in) :: geos(pcols)
+   real(r8), intent(in) :: zi(pcols,pver+1)
+   real(r8), intent(in) :: pblh(pcols)
+   real(r8), intent(in) :: tpert(pcols)
+   real(r8), intent(in) :: landfrac(pcols) ! RBN Landfrac
+!
+! output arguments
+!
+   real(r8), intent(out) :: qtnd(pcols,pver)           ! specific humidity tendency (kg/kg/s)
+   real(r8), intent(out) :: heat(pcols,pver)           ! heating rate (dry static energy tendency, W/kg)
+   real(r8), intent(out) :: mcon(pcols,pverp)
+   real(r8), intent(out) :: dlf(pcols,pver)    ! scattrd version of the detraining cld h2o tend
+   real(r8), intent(out) :: pflx(pcols,pverp)  ! scattered precip flux at each level
+   real(r8), intent(out) :: cme(pcols,pver)
+   real(r8), intent(out) :: cape(pcols)        ! w  convective available potential energy.
+   real(r8), intent(out) :: zdu(pcols,pver)
+   real(r8), intent(out) :: rprd(pcols,pver)     ! rain production rate
+! move these vars from local storage to output so that convective
+! transports can be done in outside of conv_cam.
+   real(r8), intent(out) :: mu(pcols,pver)
+   real(r8), intent(out) :: eu(pcols,pver)
+   real(r8), intent(out) :: du(pcols,pver)
+   real(r8), intent(out) :: md(pcols,pver)
+   real(r8), intent(out) :: ed(pcols,pver)
+   real(r8), intent(out) :: dp(pcols,pver)       ! wg layer thickness in mbs (between upper/lower interface).
+   real(r8), intent(out) :: dsubcld(pcols)       ! wg layer thickness in mbs between lcl and maxi.
+   real(r8), intent(out) :: jctop(pcols)  ! o row of top-of-deep-convection indices passed out.
+   real(r8), intent(out) :: jcbot(pcols)  ! o row of base of cloud indices passed out.
+   real(r8), intent(out) :: prec(pcols)
+   real(r8), intent(out) :: rliq(pcols) ! reserved liquid (not yet in cldliq) for energy integrals
+
+   real(r8) zs(pcols)
+   real(r8) dlg(pcols,pver)    ! gathrd version of the detraining cld h2o tend
+   real(r8) pflxg(pcols,pverp) ! gather precip flux at each level
+   real(r8) cug(pcols,pver)    ! gathered condensation rate
+   real(r8) evpg(pcols,pver)   ! gathered evap rate of rain in downdraft
+   real(r8) mumax(pcols)
+   integer jt(pcols)                          ! wg top  level index of deep cumulus convection.
+   integer maxg(pcols)                        ! wg gathered values of maxi.
+   integer ideep(pcols)                       ! w holds position of gathered points vs longitude index.
+   integer lengath
+!     diagnostic field used by chem/wetdep codes
+   real(r8) ql(pcols,pver)                    ! wg grid slice of cloud liquid water.
+!
+   real(r8) pblt(pcols)           ! i row of pbl top indices.
+
+!
+!-----------------------------------------------------------------------
+!
+! general work fields (local variables):
+!
+   real(r8) q(pcols,pver)              ! w  grid slice of mixing ratio.
+   real(r8) p(pcols,pver)              ! w  grid slice of ambient mid-layer pressure in mbs.
+   real(r8) z(pcols,pver)              ! w  grid slice of ambient mid-layer height in metres.
+   real(r8) s(pcols,pver)              ! w  grid slice of scaled dry static energy (t+gz/cp).
+   real(r8) tp(pcols,pver)             ! w  grid slice of parcel temperatures.
+   real(r8) zf(pcols,pver+1)           ! w  grid slice of ambient interface height in metres.
+   real(r8) pf(pcols,pver+1)           ! w  grid slice of ambient interface pressure in mbs.
+   real(r8) qstp(pcols,pver)           ! w  grid slice of parcel temp. saturation mixing ratio.
+
+   real(r8) tl(pcols)                  ! w  row of parcel temperature at lcl.
+
+   integer lcl(pcols)                  ! w  base level index of deep cumulus convection.
+   integer lel(pcols)                  ! w  index of highest theoretical convective plume.
+   integer lon(pcols)                  ! w  index of onset level for deep convection.
+   integer maxi(pcols)                 ! w  index of level with largest moist static energy.
+   integer index(pcols)
+   real(r8) precip
+!
+! gathered work fields:
+!
+   real(r8) qg(pcols,pver)             ! wg grid slice of gathered values of q.
+   real(r8) tg(pcols,pver)             ! w  grid slice of temperature at interface.
+   real(r8) pg(pcols,pver)             ! wg grid slice of gathered values of p.
+   real(r8) zg(pcols,pver)             ! wg grid slice of gathered values of z.
+   real(r8) sg(pcols,pver)             ! wg grid slice of gathered values of s.
+   real(r8) tpg(pcols,pver)            ! wg grid slice of gathered values of tp.
+   real(r8) zfg(pcols,pver+1)          ! wg grid slice of gathered values of zf.
+   real(r8) qstpg(pcols,pver)          ! wg grid slice of gathered values of qstp.
+   real(r8) ug(pcols,pver)             ! wg grid slice of gathered values of u.
+   real(r8) vg(pcols,pver)             ! wg grid slice of gathered values of v.
+   real(r8) cmeg(pcols,pver)
+
+   real(r8) rprdg(pcols,pver)           ! wg gathered rain production rate
+   real(r8) capeg(pcols)               ! wg gathered convective available potential energy.
+   real(r8) tlg(pcols)                 ! wg grid slice of gathered values of tl.
+   real(r8) landfracg(pcols)            ! wg grid slice of landfrac  
+
+   integer lclg(pcols)       ! wg gathered values of lcl.
+   integer lelg(pcols)
+!
+! work fields arising from gathered calculations.
+!
+   real(r8) dqdt(pcols,pver)           ! wg mixing ratio tendency at gathered points.
+   real(r8) dsdt(pcols,pver)           ! wg dry static energy ("temp") tendency at gathered points.
+!      real(r8) alpha(pcols,pver)      ! array of vertical differencing used (=1. for upstream).
+   real(r8) sd(pcols,pver)             ! wg grid slice of dry static energy in downdraft.
+   real(r8) qd(pcols,pver)             ! wg grid slice of mixing ratio in downdraft.
+   real(r8) mc(pcols,pver)             ! wg net upward (scaled by mb) cloud mass flux.
+   real(r8) qhat(pcols,pver)           ! wg grid slice of upper interface mixing ratio.
+   real(r8) qu(pcols,pver)             ! wg grid slice of mixing ratio in updraft.
+   real(r8) su(pcols,pver)             ! wg grid slice of dry static energy in updraft.
+   real(r8) qs(pcols,pver)             ! wg grid slice of saturation mixing ratio.
+   real(r8) shat(pcols,pver)           ! wg grid slice of upper interface dry static energy.
+   real(r8) hmn(pcols,pver)            ! wg moist static energy.
+   real(r8) hsat(pcols,pver)           ! wg saturated moist static energy.
+   real(r8) qlg(pcols,pver)
+   real(r8) dudt(pcols,pver)           ! wg u-wind tendency at gathered points.
+   real(r8) dvdt(pcols,pver)           ! wg v-wind tendency at gathered points.
+!      real(r8) ud(pcols,pver)
+!      real(r8) vd(pcols,pver)
+
+   real(r8) mb(pcols)                  ! wg cloud base mass flux.
+
+   integer jlcl(pcols)
+   integer j0(pcols)                 ! wg detrainment initiation level index.
+   integer jd(pcols)                 ! wg downdraft initiation level index.
+
+   real(r8) delt                     ! length of model time-step in seconds.
+
+   integer i
+   integer ii
+   integer k
+   integer msg                      !  ic number of missing moisture levels at the top of model.
+   real(r8) qdifr
+   real(r8) sdifr
+!
+!--------------------------Data statements------------------------------
+!
+! Set internal variable "msg" (convection limit) to "limcnv-1"
+!
+   msg = limcnv - 1
+!
+! initialize necessary arrays.
+! zero out variables not used in cam
+!
+   qtnd(:,:) = 0._r8
+   heat(:,:) = 0._r8
+   mcon(:,:) = 0._r8
+   rliq(:ncol)   = 0._r8
+!
+! initialize convective tendencies
+!
+   prec(:ncol) = 0._r8
+   do k = 1,pver
+      do i = 1,ncol
+         dqdt(i,k)  = 0._r8
+         dsdt(i,k)  = 0._r8
+         dudt(i,k)  = 0._r8
+         dvdt(i,k)  = 0._r8
+         pflx(i,k)  = 0._r8
+         pflxg(i,k) = 0._r8
+         cme(i,k)   = 0._r8
+         rprd(i,k)  = 0._r8
+         zdu(i,k)   = 0._r8
+         ql(i,k)    = 0._r8
+         qlg(i,k)   = 0._r8
+         dlf(i,k)   = 0._r8
+         dlg(i,k)   = 0._r8
+      end do
+   end do
+   do i = 1,ncol
+      pflx(i,pverp) = 0
+      pflxg(i,pverp) = 0
+   end do
+!
+   do i = 1,ncol
+      pblt(i) = pver
+      dsubcld(i) = 0._r8
+
+      jctop(i) = pver
+      jcbot(i) = 1
+   end do
+!
+! calculate local pressure (mbs) and height (m) for both interface
+! and mid-layer locations.
+!
+   do i = 1,ncol
+      zs(i) = geos(i)*rgrav
+      pf(i,pver+1) = paph(i,pver+1)*0.01_r8
+      zf(i,pver+1) = zi(i,pver+1) + zs(i)
+   end do
+   do k = 1,pver
+      do i = 1,ncol
+         p(i,k) = pap(i,k)*0.01_r8
+         pf(i,k) = paph(i,k)*0.01_r8
+         z(i,k) = zm(i,k) + zs(i)
+         zf(i,k) = zi(i,k) + zs(i)
+      end do
+   end do
+!
+   do k = pver - 1,msg + 1,-1
+      do i = 1,ncol
+         if (abs(z(i,k)-zs(i)-pblh(i)) < (zf(i,k)-zf(i,k+1))*0.5_r8) pblt(i) = k
+      end do
+   end do
+!
+! store incoming specific humidity field for subsequent calculation
+! of precipitation (through change in storage).
+! define dry static energy (normalized by cp).
+!
+   do k = 1,pver
+      do i = 1,ncol
+         q(i,k) = qh(i,k,1)
+         s(i,k) = t(i,k) + (grav/cpres)*z(i,k)
+         tp(i,k)=0.0_r8
+         shat(i,k) = s(i,k)
+         qhat(i,k) = q(i,k)
+      end do
+   end do
+
+   do i = 1,ncol
+      capeg(i) = 0._r8
+      lclg(i) = 1
+      lelg(i) = pver
+      maxg(i) = 1
+      tlg(i) = 400._r8
+      dsubcld(i) = 0._r8
+   end do
+
+   !  Evaluate Tparcel, qsat(Tparcel), buoyancy and CAPE, 
+   !     lcl, lel, parcel launch level at index maxi()=hmax
+
+   call buoyan_dilute(lchnk   ,ncol    , &
+               q       ,t       ,p       ,z       ,pf       , &
+               tp      ,qstp    ,tl      ,rl      ,cape     , &
+               pblt    ,lcl     ,lel     ,lon     ,maxi     , &
+               rgas    ,grav    ,cpres   ,msg     , &
+               tpert   )
+
+!
+! determine whether grid points will undergo some deep convection
+! (ideep=1) or not (ideep=0), based on values of cape,lcl,lel
+! (require cape.gt. 0 and lel<lcl as minimum conditions).
+!
+   lengath = 0
+   do i=1,ncol
+      if (cape(i) > capelmt) then
+         lengath = lengath + 1
+         index(lengath) = i
+      end if
+   end do
+
+   if (lengath.eq.0) return
+   do ii=1,lengath
+      i=index(ii)
+      ideep(ii)=i
+   end do
+!
+! obtain gathered arrays necessary for ensuing calculations.
+!
+   do k = 1,pver
+      do i = 1,lengath
+         dp(i,k) = 0.01_r8*dpp(ideep(i),k)
+         qg(i,k) = q(ideep(i),k)
+         tg(i,k) = t(ideep(i),k)
+         pg(i,k) = p(ideep(i),k)
+         zg(i,k) = z(ideep(i),k)
+         sg(i,k) = s(ideep(i),k)
+         tpg(i,k) = tp(ideep(i),k)
+         zfg(i,k) = zf(ideep(i),k)
+         qstpg(i,k) = qstp(ideep(i),k)
+         ug(i,k) = 0._r8
+         vg(i,k) = 0._r8
+      end do
+   end do
+!
+   do i = 1,lengath
+      zfg(i,pver+1) = zf(ideep(i),pver+1)
+   end do
+   do i = 1,lengath
+      capeg(i) = cape(ideep(i))
+      lclg(i) = lcl(ideep(i))
+      lelg(i) = lel(ideep(i))
+      maxg(i) = maxi(ideep(i))
+      tlg(i) = tl(ideep(i))
+      landfracg(i) = landfrac(ideep(i))
+   end do
+!
+! calculate sub-cloud layer pressure "thickness" for use in
+! closure and tendency routines.
+!
+   do k = msg + 1,pver
+      do i = 1,lengath
+         if (k >= maxg(i)) then
+            dsubcld(i) = dsubcld(i) + dp(i,k)
+         end if
+      end do
+   end do
+!
+! define array of factors (alpha) which defines interfacial
+! values, as well as interfacial values for (q,s) used in
+! subsequent routines.
+!
+   do k = msg + 2,pver
+      do i = 1,lengath
+!            alpha(i,k) = 0.5
+         sdifr = 0._r8
+         qdifr = 0._r8
+         if (sg(i,k) > 0._r8 .or. sg(i,k-1) > 0._r8) &
+            sdifr = abs((sg(i,k)-sg(i,k-1))/max(sg(i,k-1),sg(i,k)))
+         if (qg(i,k) > 0._r8 .or. qg(i,k-1) > 0._r8) &
+            qdifr = abs((qg(i,k)-qg(i,k-1))/max(qg(i,k-1),qg(i,k)))
+         if (sdifr > 1.E-6_r8) then
+            shat(i,k) = log(sg(i,k-1)/sg(i,k))*sg(i,k-1)*sg(i,k)/(sg(i,k-1)-sg(i,k))
+         else
+            shat(i,k) = 0.5_r8* (sg(i,k)+sg(i,k-1))
+         end if
+         if (qdifr > 1.E-6_r8) then
+            qhat(i,k) = log(qg(i,k-1)/qg(i,k))*qg(i,k-1)*qg(i,k)/(qg(i,k-1)-qg(i,k))
+         else
+            qhat(i,k) = 0.5_r8* (qg(i,k)+qg(i,k-1))
+         end if
+      end do
+   end do
+!
+! obtain cloud properties.
+!
+
+   call cldprp(lchnk   , &
+               qg      ,tg      ,ug      ,vg      ,pg      , &
+               zg      ,sg      ,mu      ,eu      ,du      , &
+               md      ,ed      ,sd      ,qd      ,mc      , &
+               qu      ,su      ,zfg     ,qs      ,hmn     , &
+               hsat    ,shat    ,qlg     , &
+               cmeg    ,maxg    ,lelg    ,jt      ,jlcl    , &
+               maxg    ,j0      ,jd      ,rl      ,lengath , &
+               rgas    ,grav    ,cpres   ,msg     , &
+               pflxg   ,evpg    ,cug     ,rprdg   ,limcnv  ,landfracg)
+!
+! convert detrainment from units of "1/m" to "1/mb".
+!
+   do k = msg + 1,pver
+      do i = 1,lengath
+         du   (i,k) = du   (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k)
+         eu   (i,k) = eu   (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k)
+         ed   (i,k) = ed   (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k)
+         cug  (i,k) = cug  (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k)
+         cmeg (i,k) = cmeg (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k)
+         rprdg(i,k) = rprdg(i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k)
+         evpg (i,k) = evpg (i,k)* (zfg(i,k)-zfg(i,k+1))/dp(i,k)
+      end do
+   end do
+
+   call closure(lchnk   , &
+                qg      ,tg      ,pg      ,zg      ,sg      , &
+                tpg     ,qs      ,qu      ,su      ,mc      , &
+                du      ,mu      ,md      ,qd      ,sd      , &
+                qhat    ,shat    ,dp      ,qstpg   ,zfg     , &
+                qlg     ,dsubcld ,mb      ,capeg   ,tlg     , &
+                lclg    ,lelg    ,jt      ,maxg    ,1       , &
+                lengath ,rgas    ,grav    ,cpres   ,rl      , &
+                msg     ,capelmt    )
+!
+! limit cloud base mass flux to theoretical upper bound.
+!
+   do i=1,lengath
+      mumax(i) = 0
+   end do
+   do k=msg + 2,pver
+      do i=1,lengath
+        mumax(i) = max(mumax(i), mu(i,k)/dp(i,k))
+      end do
+   end do
+
+   do i=1,lengath
+      if (mumax(i) > 0._r8) then
+         mb(i) = min(mb(i),0.5_r8/(delt*mumax(i)))
+      else
+         mb(i) = 0._r8
+      endif
+   end do
+   ! If no_deep_pbl = .true., don't allow convection entirely 
+   ! within PBL (suggestion of Bjorn Stevens, 8-2000)
+
+   if (no_deep_pbl) then
+      do i=1,lengath
+         if (zm(ideep(i),jt(i)) < pblh(ideep(i))) mb(i) = 0
+      end do
+   end if
+
+
+   do k=msg+1,pver
+      do i=1,lengath
+         mu   (i,k)  = mu   (i,k)*mb(i)
+         md   (i,k)  = md   (i,k)*mb(i)
+         mc   (i,k)  = mc   (i,k)*mb(i)
+         du   (i,k)  = du   (i,k)*mb(i)
+         eu   (i,k)  = eu   (i,k)*mb(i)
+         ed   (i,k)  = ed   (i,k)*mb(i)
+         cmeg (i,k)  = cmeg (i,k)*mb(i)
+         rprdg(i,k)  = rprdg(i,k)*mb(i)
+         cug  (i,k)  = cug  (i,k)*mb(i)
+         evpg (i,k)  = evpg (i,k)*mb(i)
+         pflxg(i,k+1)= pflxg(i,k+1)*mb(i)*100._r8/grav
+      end do
+   end do
+!
+! compute temperature and moisture changes due to convection.
+!
+   call q1q2_pjr(lchnk   , &
+                 dqdt    ,dsdt    ,qg      ,qs      ,qu      , &
+                 su      ,du      ,qhat    ,shat    ,dp      , &
+                 mu      ,md      ,sd      ,qd      ,qlg     , &
+                 dsubcld ,jt      ,maxg    ,1       ,lengath , &
+                 cpres   ,rl      ,msg     ,          &
+                 dlg     ,evpg    ,cug     )
+!
+! gather back temperature and mixing ratio.
+!
+   do k = msg + 1,pver
+!DIR$ CONCURRENT
+      do i = 1,lengath
+!
+! q is updated to compute net precip.
+!
+         q(ideep(i),k) = qh(ideep(i),k,1) + 2._r8*delt*dqdt(i,k)
+         qtnd(ideep(i),k) = dqdt (i,k)
+         cme (ideep(i),k) = cmeg (i,k)
+         rprd(ideep(i),k) = rprdg(i,k)
+         zdu (ideep(i),k) = du   (i,k)
+         mcon(ideep(i),k) = mc   (i,k)
+         heat(ideep(i),k) = dsdt (i,k)*cpres
+         dlf (ideep(i),k) = dlg  (i,k)
+         pflx(ideep(i),k) = pflxg(i,k)
+         ql  (ideep(i),k) = qlg  (i,k)
+      end do
+   end do
+!
+!DIR$ CONCURRENT
+   do i = 1,lengath
+      jctop(ideep(i)) = jt(i)
+!++bee
+      jcbot(ideep(i)) = maxg(i)
+!--bee
+      pflx(ideep(i),pverp) = pflxg(i,pverp)
+   end do
+
+! Compute precip by integrating change in water vapor minus detrained cloud water
+   do k = pver,msg + 1,-1
+      do i = 1,ncol
+         prec(i) = prec(i) - dpp(i,k)* (q(i,k)-qh(i,k,1)) - dpp(i,k)*dlf(i,k)*2*delt
+      end do
+   end do
+
+! obtain final precipitation rate in m/s.
+   do i = 1,ncol
+      prec(i) = rgrav*max(prec(i),0._r8)/ (2._r8*delt)/1000._r8
+   end do
+
+! Compute reserved liquid (not yet in cldliq) for energy integrals.
+! Treat rliq as flux out bottom, to be added back later.
+   do k = 1, pver
+      do i = 1, ncol
+         rliq(i) = rliq(i) + dlf(i,k)*dpp(i,k)/gravit
+      end do
+   end do
+   rliq(:ncol) = rliq(:ncol) /1000._r8
+
+   return
+end subroutine zm_convr
+
+!===============================================================================
+subroutine zm_conv_evap(ncol,lchnk, &
+     t,pmid,pdel,q, &
+     tend_s, tend_s_snwprd, tend_s_snwevmlt, tend_q, &
+     prdprec, cldfrc, deltat,  &
+     prec, snow, ntprprd, ntsnprd, flxprec, flxsnow )
+
+!-----------------------------------------------------------------------
+! Compute tendencies due to evaporation of rain from ZM scheme
+!--
+! Compute the total precipitation and snow fluxes at the surface.
+! Add in the latent heat of fusion for snow formation and melt, since it not dealt with
+! in the Zhang-MacFarlane parameterization.
+! Evaporate some of the precip directly into the environment using a Sundqvist type algorithm
+!-----------------------------------------------------------------------
+
+    use wv_saturation,  only: aqsat
+#ifndef WRF_PORT
+    use phys_grid, only: get_rlat_all_p
+#endif
+
+!------------------------------Arguments--------------------------------
+    integer,intent(in) :: ncol, lchnk             ! number of columns and chunk index
+    real(r8),intent(in), dimension(pcols,pver) :: t          ! temperature (K)
+    real(r8),intent(in), dimension(pcols,pver) :: pmid       ! midpoint pressure (Pa) 
+    real(r8),intent(in), dimension(pcols,pver) :: pdel       ! layer thickness (Pa)
+    real(r8),intent(in), dimension(pcols,pver) :: q          ! water vapor (kg/kg)
+    real(r8),intent(inout), dimension(pcols,pver) :: tend_s     ! heating rate (J/kg/s)
+    real(r8),intent(inout), dimension(pcols,pver) :: tend_q     ! water vapor tendency (kg/kg/s)
+    real(r8),intent(out  ), dimension(pcols,pver) :: tend_s_snwprd ! Heating rate of snow production
+    real(r8),intent(out  ), dimension(pcols,pver) :: tend_s_snwevmlt ! Heating rate of evap/melting of snow
+    
+
+
+    real(r8), intent(in   ) :: prdprec(pcols,pver)! precipitation production (kg/ks/s)
+    real(r8), intent(in   ) :: cldfrc(pcols,pver) ! cloud fraction
+    real(r8), intent(in   ) :: deltat             ! time step
+
+    real(r8), intent(inout) :: prec(pcols)        ! Convective-scale preciptn rate
+    real(r8), intent(out)   :: snow(pcols)        ! Convective-scale snowfall rate
+!
+!---------------------------Local storage-------------------------------
+
+    real(r8) :: est    (pcols,pver)    ! Saturation vapor pressure
+    real(r8) :: fice   (pcols,pver)    ! ice fraction in precip production
+    real(r8) :: fsnow_conv(pcols,pver) ! snow fraction in precip production
+    real(r8) :: qsat   (pcols,pver)    ! saturation specific humidity
+    real(r8),intent(out) :: flxprec(pcols,pverp)   ! Convective-scale flux of precip at interfaces (kg/m2/s)
+    real(r8),intent(out) :: flxsnow(pcols,pverp)   ! Convective-scale flux of snow   at interfaces (kg/m2/s)
+    real(r8),intent(out) :: ntprprd(pcols,pver)    ! net precip production in layer
+    real(r8),intent(out) :: ntsnprd(pcols,pver)    ! net snow production in layer
+    real(r8) :: work1                  ! temp variable (pjr)
+    real(r8) :: work2                  ! temp variable (pjr)
+
+    real(r8) :: evpvint(pcols)         ! vertical integral of evaporation
+    real(r8) :: evpprec(pcols)         ! evaporation of precipitation (kg/kg/s)
+    real(r8) :: evpsnow(pcols)         ! evaporation of snowfall (kg/kg/s)
+    real(r8) :: snowmlt(pcols)         ! snow melt tendency in layer
+    real(r8) :: flxsntm(pcols)         ! flux of snow into layer, after melting
+
+    real(r8) :: evplimit               ! temp variable for evaporation limits
+    real(r8) :: rlat(pcols)
+
+    integer :: i,k                     ! longitude,level indices
+
+
+!-----------------------------------------------------------------------
+
+! convert input precip to kg/m2/s
+    prec(:ncol) = prec(:ncol)*1000._r8
+
+! determine saturation vapor pressure
+    call aqsat (t    ,pmid  ,est    ,qsat    ,pcols   , &
+         ncol ,pver  ,1       ,pver    )
+
+! determine ice fraction in rain production (use cloud water parameterization fraction at present)
+    call cldwat_fice(ncol, t, fice, fsnow_conv)
+
+! zero the flux integrals on the top boundary
+    flxprec(:ncol,1) = 0._r8
+    flxsnow(:ncol,1) = 0._r8
+    evpvint(:ncol)   = 0._r8
+
+    do k = 1, pver
+       do i = 1, ncol
+
+! Melt snow falling into layer, if necessary. 
+          if (t(i,k) > tmelt) then
+             flxsntm(i) = 0._r8
+             snowmlt(i) = flxsnow(i,k) * gravit/ pdel(i,k)
+          else
+             flxsntm(i) = flxsnow(i,k)
+             snowmlt(i) = 0._r8
+          end if
+
+! relative humidity depression must be > 0 for evaporation
+          evplimit = max(1._r8 - q(i,k)/qsat(i,k), 0._r8)
+
+! total evaporation depends on flux in the top of the layer
+! flux prec is the net production above layer minus evaporation into environmet
+          evpprec(i) = ke * (1._r8 - cldfrc(i,k)) * evplimit * sqrt(flxprec(i,k))
+!**********************************************************
+!!          evpprec(i) = 0.    ! turn off evaporation for now
+!**********************************************************
+
+! Don't let evaporation supersaturate layer (approx). Layer may already be saturated.
+! Currently does not include heating/cooling change to qsat
+          evplimit   = max(0._r8, (qsat(i,k)-q(i,k)) / deltat)
+
+! Don't evaporate more than is falling into the layer - do not evaporate rain formed
+! in this layer but if precip production is negative, remove from the available precip
+! Negative precip production occurs because of evaporation in downdrafts.
+!!$          evplimit   = flxprec(i,k) * gravit / pdel(i,k) + min(prdprec(i,k), 0.)
+          evplimit   = min(evplimit, flxprec(i,k) * gravit / pdel(i,k))
+
+! Total evaporation cannot exceed input precipitation
+          evplimit   = min(evplimit, (prec(i) - evpvint(i)) * gravit / pdel(i,k))
+
+          evpprec(i) = min(evplimit, evpprec(i))
+
+! evaporation of snow depends on snow fraction of total precipitation in the top after melting
+          if (flxprec(i,k) > 0._r8) then
+!            evpsnow(i) = evpprec(i) * flxsntm(i) / flxprec(i,k)
+!            prevent roundoff problems
+             work1 = min(max(0._r8,flxsntm(i)/flxprec(i,k)),1._r8)
+             evpsnow(i) = evpprec(i) * work1
+          else
+             evpsnow(i) = 0._r8
+          end if
+
+! vertically integrated evaporation
+          evpvint(i) = evpvint(i) + evpprec(i) * pdel(i,k)/gravit
+
+! net precip production is production - evaporation
+          ntprprd(i,k) = prdprec(i,k) - evpprec(i)
+! net snow production is precip production * ice fraction - evaporation - melting
+!pjrworks ntsnprd(i,k) = prdprec(i,k)*fice(i,k) - evpsnow(i) - snowmlt(i)
+!pjrwrks2 ntsnprd(i,k) = prdprec(i,k)*fsnow_conv(i,k) - evpsnow(i) - snowmlt(i)
+! the small amount added to flxprec in the work1 expression has been increased from 
+! 1e-36 to 8.64e-11 (1e-5 mm/day).  This causes the temperature based partitioning
+! scheme to be used for small flxprec amounts.  This is to address error growth problems.
+#ifdef PERGRO
+          work1 = min(max(0._r8,flxsnow(i,k)/(flxprec(i,k)+8.64e-11_r8)),1._r8)
+#else
+          if (flxprec(i,k).gt.0._r8) then
+             work1 = min(max(0._r8,flxsnow(i,k)/flxprec(i,k)),1._r8)
+          else
+             work1 = 0._r8
+          endif
+#endif
+          work2 = max(fsnow_conv(i,k), work1)
+          if (snowmlt(i).gt.0._r8) work2 = 0._r8
+!         work2 = fsnow_conv(i,k)
+          ntsnprd(i,k) = prdprec(i,k)*work2 - evpsnow(i) - snowmlt(i)
+          tend_s_snwprd  (i,k) = prdprec(i,k)*work2*latice
+          tend_s_snwevmlt(i,k) = - ( evpsnow(i) + snowmlt(i) )*latice
+
+! precipitation fluxes
+          flxprec(i,k+1) = flxprec(i,k) + ntprprd(i,k) * pdel(i,k)/gravit
+          flxsnow(i,k+1) = flxsnow(i,k) + ntsnprd(i,k) * pdel(i,k)/gravit
+
+! protect against rounding error
+          flxprec(i,k+1) = max(flxprec(i,k+1), 0._r8)
+          flxsnow(i,k+1) = max(flxsnow(i,k+1), 0._r8)
+! more protection (pjr)
+!         flxsnow(i,k+1) = min(flxsnow(i,k+1), flxprec(i,k+1))
+
+! heating (cooling) and moistening due to evaporation 
+! - latent heat of vaporization for precip production has already been accounted for
+! - snow is contained in prec
+          tend_s(i,k)   =-evpprec(i)*latvap + ntsnprd(i,k)*latice
+          tend_q(i,k) = evpprec(i)
+       end do
+    end do
+
+! set output precipitation rates (m/s)
+    prec(:ncol) = flxprec(:ncol,pver+1) / 1000._r8
+    snow(:ncol) = flxsnow(:ncol,pver+1) / 1000._r8
+
+!**********************************************************
+!!$    tend_s(:ncol,:)   = 0.      ! turn heating off
+!**********************************************************
+
+  end subroutine zm_conv_evap
+
+
+
+subroutine convtran(lchnk   , &
+                    doconvtran,q       ,ncnst   ,mu      ,md      , &
+                    du      ,eu      ,ed      ,dp      ,dsubcld , &
+                    jt      ,mx      ,ideep   ,il1g    ,il2g    , &
+                    nstep   ,fracis  ,dqdt    ,dpdry   )
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! Convective transport of trace species
+!
+! Mixing ratios may be with respect to either dry or moist air
+! 
+! Method: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! Author: P. Rasch
+! 
+!-----------------------------------------------------------------------
+   use shr_kind_mod, only: r8 => shr_kind_r8
+   use constituents, only: cnst_get_type_byind
+#ifndef WRF_PORT
+   use ppgrid
+   use abortutils, only: endrun
+!~~~#else
+!   use module_cam_support, only: cnst_get_type_byind
+#endif
+
+   implicit none
+!-----------------------------------------------------------------------
+!
+! Input arguments
+!
+   integer, intent(in) :: lchnk                 ! chunk identifier
+   integer, intent(in) :: ncnst                 ! number of tracers to transport
+   logical, intent(in) :: doconvtran(ncnst)     ! flag for doing convective transport
+   real(r8), intent(in) :: q(pcols,pver,ncnst)  ! Tracer array including moisture
+   real(r8), intent(in) :: mu(pcols,pver)       ! Mass flux up
+   real(r8), intent(in) :: md(pcols,pver)       ! Mass flux down
+   real(r8), intent(in) :: du(pcols,pver)       ! Mass detraining from updraft
+   real(r8), intent(in) :: eu(pcols,pver)       ! Mass entraining from updraft
+   real(r8), intent(in) :: ed(pcols,pver)       ! Mass entraining from downdraft
+   real(r8), intent(in) :: dp(pcols,pver)       ! Delta pressure between interfaces
+   real(r8), intent(in) :: dsubcld(pcols)       ! Delta pressure from cloud base to sfc
+   real(r8), intent(in) :: fracis(pcols,pver,ncnst) ! fraction of tracer that is insoluble
+
+   integer, intent(in) :: jt(pcols)         ! Index of cloud top for each column
+   integer, intent(in) :: mx(pcols)         ! Index of cloud top for each column
+   integer, intent(in) :: ideep(pcols)      ! Gathering array
+   integer, intent(in) :: il1g              ! Gathered min lon indices over which to operate
+   integer, intent(in) :: il2g              ! Gathered max lon indices over which to operate
+   integer, intent(in) :: nstep             ! Time step index
+
+   real(r8), intent(in) :: dpdry(pcols,pver)       ! Delta pressure between interfaces
+
+
+! input/output
+
+   real(r8), intent(out) :: dqdt(pcols,pver,ncnst)  ! Tracer tendency array
+
+!--------------------------Local Variables------------------------------
+
+   integer i                 ! Work index
+   integer k                 ! Work index
+   integer kbm               ! Highest altitude index of cloud base
+   integer kk                ! Work index
+   integer kkp1              ! Work index
+   integer km1               ! Work index
+   integer kp1               ! Work index
+   integer ktm               ! Highest altitude index of cloud top
+   integer m                 ! Work index
+
+   real(r8) cabv                 ! Mix ratio of constituent above
+   real(r8) cbel                 ! Mix ratio of constituent below
+   real(r8) cdifr                ! Normalized diff between cabv and cbel
+   real(r8) chat(pcols,pver)     ! Mix ratio in env at interfaces
+   real(r8) cond(pcols,pver)     ! Mix ratio in downdraft at interfaces
+   real(r8) const(pcols,pver)    ! Gathered tracer array
+   real(r8) fisg(pcols,pver)     ! gathered insoluble fraction of tracer
+   real(r8) conu(pcols,pver)     ! Mix ratio in updraft at interfaces
+   real(r8) dcondt(pcols,pver)   ! Gathered tend array
+   real(r8) small                ! A small number
+   real(r8) mbsth                ! Threshold for mass fluxes
+   real(r8) mupdudp              ! A work variable
+   real(r8) minc                 ! A work variable
+   real(r8) maxc                 ! A work variable
+   real(r8) fluxin               ! A work variable
+   real(r8) fluxout              ! A work variable
+   real(r8) netflux              ! A work variable
+
+   real(r8) dutmp(pcols,pver)       ! Mass detraining from updraft
+   real(r8) eutmp(pcols,pver)       ! Mass entraining from updraft
+   real(r8) edtmp(pcols,pver)       ! Mass entraining from downdraft
+   real(r8) dptmp(pcols,pver)    ! Delta pressure between interfaces
+!-----------------------------------------------------------------------
+!
+   small = 1.e-36_r8
+
+! mbsth is the threshold below which we treat the mass fluxes as zero (in mb/s)
+   mbsth = 1.e-15_r8
+
+! Find the highest level top and bottom levels of convection
+   ktm = pver
+   kbm = pver
+   do i = il1g, il2g
+      ktm = min(ktm,jt(i))
+      kbm = min(kbm,mx(i))
+   end do
+
+! Loop ever each constituent
+   do m = 2, ncnst
+      if (doconvtran(m)) then
+
+         if (cnst_get_type_byind(m).eq.'dry') then
+            do k = 1,pver
+               do i =il1g,il2g
+                  dptmp(i,k) = dpdry(i,k)
+                  dutmp(i,k) = du(i,k)*dp(i,k)/dpdry(i,k)
+                  eutmp(i,k) = eu(i,k)*dp(i,k)/dpdry(i,k)
+                  edtmp(i,k) = ed(i,k)*dp(i,k)/dpdry(i,k)
+               end do
+            end do
+         else
+            do k = 1,pver
+               do i =il1g,il2g
+                  dptmp(i,k) = dp(i,k)
+                  dutmp(i,k) = du(i,k)
+                  eutmp(i,k) = eu(i,k)
+                  edtmp(i,k) = ed(i,k)
+               end do
+            end do
+         endif
+!        dptmp = dp
+
+! Gather up the constituent and set tend to zero
+         do k = 1,pver
+            do i =il1g,il2g
+               const(i,k) = q(ideep(i),k,m)
+               fisg(i,k) = fracis(ideep(i),k,m)
+            end do
+         end do
+
+! From now on work only with gathered data
+
+! Interpolate environment tracer values to interfaces
+         do k = 1,pver
+            km1 = max(1,k-1)
+            do i = il1g, il2g
+               minc = min(const(i,km1),const(i,k))
+               maxc = max(const(i,km1),const(i,k))
+               if (minc < 0) then
+                  cdifr = 0._r8
+               else
+                  cdifr = abs(const(i,k)-const(i,km1))/max(maxc,small)
+               endif
+
+! If the two layers differ significantly use a geometric averaging
+! procedure
+               if (cdifr > 1.E-6_r8) then
+                  cabv = max(const(i,km1),maxc*1.e-12_r8)
+                  cbel = max(const(i,k),maxc*1.e-12_r8)
+                  chat(i,k) = log(cabv/cbel)/(cabv-cbel)*cabv*cbel
+
+               else             ! Small diff, so just arithmetic mean
+                  chat(i,k) = 0.5_r8* (const(i,k)+const(i,km1))
+               end if
+
+! Provisional up and down draft values
+               conu(i,k) = chat(i,k)
+               cond(i,k) = chat(i,k)
+
+!              provisional tends
+               dcondt(i,k) = 0._r8
+
+            end do
+         end do
+
+! Do levels adjacent to top and bottom
+         k = 2
+         km1 = 1
+         kk = pver
+         do i = il1g,il2g
+            mupdudp = mu(i,kk) + dutmp(i,kk)*dptmp(i,kk)
+            if (mupdudp > mbsth) then
+               conu(i,kk) = (+eutmp(i,kk)*fisg(i,kk)*const(i,kk)*dptmp(i,kk))/mupdudp
+            endif
+            if (md(i,k) < -mbsth) then
+               cond(i,k) =  (-edtmp(i,km1)*fisg(i,km1)*const(i,km1)*dptmp(i,km1))/md(i,k)
+            endif
+         end do
+
+! Updraft from bottom to top
+         do kk = pver-1,1,-1
+            kkp1 = min(pver,kk+1)
+            do i = il1g,il2g
+               mupdudp = mu(i,kk) + dutmp(i,kk)*dptmp(i,kk)
+               if (mupdudp > mbsth) then
+                  conu(i,kk) = (  mu(i,kkp1)*conu(i,kkp1)+eutmp(i,kk)*fisg(i,kk)* &
+                                  const(i,kk)*dptmp(i,kk) )/mupdudp
+               endif
+            end do
+         end do
+
+! Downdraft from top to bottom
+         do k = 3,pver
+            km1 = max(1,k-1)
+            do i = il1g,il2g
+               if (md(i,k) < -mbsth) then
+                  cond(i,k) =  (  md(i,km1)*cond(i,km1)-edtmp(i,km1)*fisg(i,km1)*const(i,km1) &
+                                  *dptmp(i,km1) )/md(i,k)
+               endif
+            end do
+         end do
+
+
+         do k = ktm,pver
+            km1 = max(1,k-1)
+            kp1 = min(pver,k+1)
+            do i = il1g,il2g
+
+! version 1 hard to check for roundoff errors
+!               dcondt(i,k) =
+!     $                  +(+mu(i,kp1)* (conu(i,kp1)-chat(i,kp1))
+!     $                    -mu(i,k)*   (conu(i,k)-chat(i,k))
+!     $                    +md(i,kp1)* (cond(i,kp1)-chat(i,kp1))
+!     $                    -md(i,k)*   (cond(i,k)-chat(i,k))
+!     $                   )/dp(i,k)
+
+! version 2 hard to limit fluxes
+!               fluxin =  mu(i,kp1)*conu(i,kp1) + mu(i,k)*chat(i,k)
+!     $                 -(md(i,k)  *cond(i,k)   + md(i,kp1)*chat(i,kp1))
+!               fluxout = mu(i,k)*conu(i,k)     + mu(i,kp1)*chat(i,kp1)
+!     $                 -(md(i,kp1)*cond(i,kp1) + md(i,k)*chat(i,k))
+
+! version 3 limit fluxes outside convection to mass in appropriate layer
+! these limiters are probably only safe for positive definite quantitities
+! it assumes that mu and md already satify a courant number limit of 1
+               fluxin =  mu(i,kp1)*conu(i,kp1)+ mu(i,k)*min(chat(i,k),const(i,km1)) &
+                         -(md(i,k)  *cond(i,k) + md(i,kp1)*min(chat(i,kp1),const(i,kp1)))
+               fluxout = mu(i,k)*conu(i,k) + mu(i,kp1)*min(chat(i,kp1),const(i,k)) &
+                         -(md(i,kp1)*cond(i,kp1) + md(i,k)*min(chat(i,k),const(i,k)))
+
+               netflux = fluxin - fluxout
+               if (abs(netflux) < max(fluxin,fluxout)*1.e-12_r8) then
+                  netflux = 0._r8
+               endif
+               dcondt(i,k) = netflux/dptmp(i,k)
+            end do
+         end do
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+!
+!DIR$ NOINTERCHANGE
+         do k = kbm,pver
+            km1 = max(1,k-1)
+            do i = il1g,il2g
+               if (k == mx(i)) then
+
+! version 1
+!                  dcondt(i,k) = (1./dsubcld(i))*
+!     $              (-mu(i,k)*(conu(i,k)-chat(i,k))
+!     $               -md(i,k)*(cond(i,k)-chat(i,k))
+!     $              )
+
+! version 2
+!                  fluxin =  mu(i,k)*chat(i,k) - md(i,k)*cond(i,k)
+!                  fluxout = mu(i,k)*conu(i,k) - md(i,k)*chat(i,k)
+! version 3
+                  fluxin =  mu(i,k)*min(chat(i,k),const(i,km1)) - md(i,k)*cond(i,k)
+                  fluxout = mu(i,k)*conu(i,k) - md(i,k)*min(chat(i,k),const(i,k))
+
+                  netflux = fluxin - fluxout
+                  if (abs(netflux) < max(fluxin,fluxout)*1.e-12_r8) then
+                     netflux = 0._r8
+                  endif
+!                  dcondt(i,k) = netflux/dsubcld(i)
+                  dcondt(i,k) = netflux/dptmp(i,k)
+               else if (k > mx(i)) then
+!                  dcondt(i,k) = dcondt(i,k-1)
+                  dcondt(i,k) = 0._r8
+               end if
+            end do
+         end do
+
+! Initialize to zero everywhere, then scatter tendency back to full array
+         dqdt(:,:,m) = 0._r8
+         do k = 1,pver
+            kp1 = min(pver,k+1)
+!DIR$ CONCURRENT
+            do i = il1g,il2g
+               dqdt(ideep(i),k,m) = dcondt(i,k)
+            end do
+         end do
+
+      end if      ! for doconvtran
+
+   end do
+
+   return
+end subroutine convtran
+
+!=========================================================================================
+
+subroutine momtran(lchnk, ncol, &
+                    domomtran,q       ,ncnst   ,mu      ,md    , &
+                    du      ,eu      ,ed      ,dp      ,dsubcld , &
+                    jt      ,mx      ,ideep   ,il1g    ,il2g    , &
+                    nstep   ,dqdt    ,pguall     ,pgdall, icwu, icwd, dt, seten    )
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! Convective transport of momentum
+!
+! Mixing ratios may be with respect to either dry or moist air
+! 
+! Method: 
+! Based on the convtran subroutine by P. Rasch
+! <Also include any applicable external references.> 
+! 
+! Author: J. Richter and P. Rasch
+! 
+!-----------------------------------------------------------------------
+   use shr_kind_mod, only: r8 => shr_kind_r8
+#ifndef WRF_PORT
+   use constituents,    only: cnst_get_type_byind
+   use ppgrid
+   use abortutils, only: endrun
+#endif
+   implicit none
+!-----------------------------------------------------------------------
+!
+! Input arguments
+!
+   integer, intent(in) :: lchnk                 ! chunk identifier
+   integer, intent(in) :: ncol                  ! number of atmospheric columns
+   integer, intent(in) :: ncnst                 ! number of tracers to transport
+   logical, intent(in) :: domomtran(ncnst)      ! flag for doing convective transport
+   real(r8), intent(in) :: q(pcols,pver,ncnst)  ! Wind array
+   real(r8), intent(in) :: mu(pcols,pver)       ! Mass flux up
+   real(r8), intent(in) :: md(pcols,pver)       ! Mass flux down
+   real(r8), intent(in) :: du(pcols,pver)       ! Mass detraining from updraft
+   real(r8), intent(in) :: eu(pcols,pver)       ! Mass entraining from updraft
+   real(r8), intent(in) :: ed(pcols,pver)       ! Mass entraining from downdraft
+   real(r8), intent(in) :: dp(pcols,pver)       ! Delta pressure between interfaces
+   real(r8), intent(in) :: dsubcld(pcols)       ! Delta pressure from cloud base to sfc
+   real(r8), intent(in)    :: dt                       !  time step in seconds : 2*delta_t
+
+   integer, intent(in) :: jt(pcols)         ! Index of cloud top for each column
+   integer, intent(in) :: mx(pcols)         ! Index of cloud top for each column
+   integer, intent(in) :: ideep(pcols)      ! Gathering array
+   integer, intent(in) :: il1g              ! Gathered min lon indices over which to operate
+   integer, intent(in) :: il2g              ! Gathered max lon indices over which to operate
+   integer, intent(in) :: nstep             ! Time step index
+
+
+
+! input/output
+
+   real(r8), intent(out) :: dqdt(pcols,pver,ncnst)  ! Tracer tendency array
+
+!--------------------------Local Variables------------------------------
+
+   integer i                 ! Work index
+   integer k                 ! Work index
+   integer kbm               ! Highest altitude index of cloud base
+   integer kk                ! Work index
+   integer kkp1              ! Work index
+   integer kkm1              ! Work index
+   integer km1               ! Work index
+   integer kp1               ! Work index
+   integer ktm               ! Highest altitude index of cloud top
+   integer m                 ! Work index
+   integer ii                 ! Work index
+
+   real(r8) cabv                 ! Mix ratio of constituent above
+   real(r8) cbel                 ! Mix ratio of constituent below
+   real(r8) cdifr                ! Normalized diff between cabv and cbel
+   real(r8) chat(pcols,pver)     ! Mix ratio in env at interfaces
+   real(r8) cond(pcols,pver)     ! Mix ratio in downdraft at interfaces
+   real(r8) const(pcols,pver)    ! Gathered wind array
+   real(r8) conu(pcols,pver)     ! Mix ratio in updraft at interfaces
+   real(r8) dcondt(pcols,pver)   ! Gathered tend array
+   real(r8) small                ! A small number
+   real(r8) mbsth                ! Threshold for mass fluxes
+   real(r8) mupdudp              ! A work variable
+   real(r8) minc                 ! A work variable
+   real(r8) maxc                 ! A work variable
+   real(r8) fluxin               ! A work variable
+   real(r8) fluxout              ! A work variable
+   real(r8) netflux              ! A work variable
+
+   real(r8) momcu                ! constant for updraft pressure gradient term
+   real(r8) momcd                ! constant for downdraft pressure gradient term
+   real(r8) sum                  ! sum
+   real(r8) sum2                  ! sum2
+ 
+   real(r8) mududp(pcols,pver) ! working variable
+   real(r8) mddudp(pcols,pver)     ! working variable
+
+   real(r8) pgu(pcols,pver)      ! Pressure gradient term for updraft
+   real(r8) pgd(pcols,pver)      ! Pressure gradient term for downdraft
+
+   real(r8),intent(out) ::  pguall(pcols,pver,ncnst)      ! Apparent force from  updraft PG
+   real(r8),intent(out) ::  pgdall(pcols,pver,ncnst)      ! Apparent force from  downdraft PG
+
+   real(r8),intent(out) ::  icwu(pcols,pver,ncnst)      ! In-cloud winds in updraft
+   real(r8),intent(out) ::  icwd(pcols,pver,ncnst)      ! In-cloud winds in downdraft
+
+   real(r8),intent(out) ::  seten(pcols,pver) ! Dry static energy tendency
+   real(r8)                 gseten(pcols,pver) ! Gathered dry static energy tendency
+
+   real(r8)  mflux(pcols,pverp,ncnst)   ! Gathered momentum flux
+
+   real(r8)  wind0(pcols,pver,ncnst)       !  gathered  wind before time step
+   real(r8)  windf(pcols,pver,ncnst)       !  gathered  wind after time step
+   real(r8) fkeb, fket, ketend_cons, ketend, utop, ubot, vtop, vbot, gset2
+   
+
+!-----------------------------------------------------------------------
+!
+
+! Initialize outgoing fields
+   pguall(:,:,:)     = 0.0_r8
+   pgdall(:,:,:)     = 0.0_r8
+! Initialize in-cloud winds to environmental wind
+   icwu(:ncol,:,:)       = q(:ncol,:,:)
+   icwd(:ncol,:,:)       = q(:ncol,:,:)
+
+! Initialize momentum flux and  final winds
+   mflux(:,:,:)       = 0.0_r8
+   wind0(:,:,:)         = 0.0_r8
+   windf(:,:,:)         = 0.0_r8
+
+! Initialize dry static energy
+
+   seten(:,:)         = 0.0_r8
+   gseten(:,:)         = 0.0_r8
+
+! Define constants for parameterization
+
+   momcu = 0.4_r8
+   momcd = 0.4_r8
+
+   small = 1.e-36_r8
+! mbsth is the threshold below which we treat the mass fluxes as zero (in mb/s)
+   mbsth = 1.e-15_r8
+
+! Find the highest level top and bottom levels of convection
+   ktm = pver
+   kbm = pver
+   do i = il1g, il2g
+      ktm = min(ktm,jt(i))
+      kbm = min(kbm,mx(i))
+   end do
+
+! Loop ever each wind component
+   do m = 1, ncnst                    !start at m = 1 to transport momentum
+      if (domomtran(m)) then
+
+! Gather up the winds and set tend to zero
+         do k = 1,pver
+            do i =il1g,il2g
+               const(i,k) = q(ideep(i),k,m)
+                wind0(i,k,m) = const(i,k)
+            end do
+         end do
+
+
+! From now on work only with gathered data
+
+! Interpolate winds to interfaces
+
+         do k = 1,pver
+            km1 = max(1,k-1)
+            do i = il1g, il2g
+
+               ! use arithmetic mean
+               chat(i,k) = 0.5_r8* (const(i,k)+const(i,km1))
+
+! Provisional up and down draft values
+               conu(i,k) = chat(i,k)
+               cond(i,k) = chat(i,k)
+
+!              provisional tends
+               dcondt(i,k) = 0._r8
+
+            end do
+         end do
+
+
+!
+! Pressure Perturbation Term
+! 
+
+      !Top boundary:  assume mu is zero 
+
+         k=1
+         pgu(:il2g,k) = 0.0_r8
+         pgd(:il2g,k) = 0.0_r8
+
+         do k=2,pver-1
+            km1 = max(1,k-1)
+            kp1 = min(pver,k+1)
+            do i = il1g,il2g
+            
+               !interior points
+
+               mududp(i,k) =  ( mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) &
+                           +  mu(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k))
+
+               pgu(i,k) = - momcu * 0.5_r8 * mududp(i,k)
+                           
+
+               mddudp(i,k) =  ( md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) &
+                           +  md(i,kp1) * (const(i,kp1) - const(i,k))/dp(i,k))
+
+               pgd(i,k) = - momcd * 0.5_r8 * mddudp(i,k)
+
+
+            end do
+         end do
+
+       ! bottom boundary 
+       k = pver
+       km1 = max(1,k-1)
+       do i=il1g,il2g
+
+          mududp(i,k) =   mu(i,k) * (const(i,k)- const(i,km1))/dp(i,km1)
+          pgu(i,k) = - momcu *  mududp(i,k)
+          
+          mddudp(i,k) =   md(i,k) * (const(i,k)- const(i,km1))/dp(i,km1) 
+
+          pgd(i,k) = - momcd * mddudp(i,k)
+          
+       end do
+       
+
+!
+! In-cloud velocity calculations
+!
+
+! Do levels adjacent to top and bottom
+         k = 2
+         km1 = 1
+         kk = pver
+         kkm1 = max(1,kk-1)
+         do i = il1g,il2g
+            mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk)
+            if (mupdudp > mbsth) then
+                 
+               conu(i,kk) = (+eu(i,kk)*const(i,kk)*dp(i,kk)+pgu(i,kk)*dp(i,kk))/mupdudp
+            endif
+            if (md(i,k) < -mbsth) then
+               cond(i,k) =  (-ed(i,km1)*const(i,km1)*dp(i,km1))-pgd(i,km1)*dp(i,km1)/md(i,k)
+            endif
+
+                        
+         end do
+
+
+
+! Updraft from bottom to top
+         do kk = pver-1,1,-1
+            kkm1 = max(1,kk-1)
+            kkp1 = min(pver,kk+1)
+            do i = il1g,il2g
+               mupdudp = mu(i,kk) + du(i,kk)*dp(i,kk)
+               if (mupdudp > mbsth) then
+            
+                  conu(i,kk) = (  mu(i,kkp1)*conu(i,kkp1)+eu(i,kk)* &
+                                  const(i,kk)*dp(i,kk)+pgu(i,kk)*dp(i,kk))/mupdudp
+               endif
+            end do
+
+         end do
+
+
+! Downdraft from top to bottom
+         do k = 3,pver
+            km1 = max(1,k-1)
+            do i = il1g,il2g
+               if (md(i,k) < -mbsth) then
+                            
+                  cond(i,k) =  (  md(i,km1)*cond(i,km1)-ed(i,km1)*const(i,km1) &
+                                  *dp(i,km1)-pgd(i,km1)*dp(i,km1) )/md(i,k)
+
+               endif
+            end do
+         end do
+
+
+         sum = 0._r8
+         sum2 = 0._r8
+
+
+         do k = ktm,pver
+            km1 = max(1,k-1)
+            kp1 = min(pver,k+1)
+            do i = il1g,il2g
+               ii = ideep(i)
+	
+! version 1 hard to check for roundoff errors
+               dcondt(i,k) =  &
+                           +(mu(i,kp1)* (conu(i,kp1)-chat(i,kp1)) &
+                           -mu(i,k)*   (conu(i,k)-chat(i,k))      &
+                           +md(i,kp1)* (cond(i,kp1)-chat(i,kp1)) &
+                           -md(i,k)*   (cond(i,k)-chat(i,k)) &
+                          )/dp(i,k)
+
+            end do
+         end do
+
+  ! dcont for bottom layer
+          !
+          !DIR$ NOINTERCHANGE
+          do k = kbm,pver
+             km1 = max(1,k-1)
+             do i = il1g,il2g
+                if (k == mx(i)) then
+
+                   ! version 1
+                   dcondt(i,k) = (1./dp(i,k))*   &  
+                        (-mu(i,k)*(conu(i,k)-chat(i,k)) &
+                        -md(i,k)*(cond(i,k)-chat(i,k)) &
+                        )
+                end if
+             end do
+          end do
+
+! Initialize to zero everywhere, then scatter tendency back to full array
+         dqdt(:,:,m) = 0._r8
+
+         do k = 1,pver
+            do i = il1g,il2g
+               ii = ideep(i)
+               dqdt(ii,k,m) = dcondt(i,k)
+    ! Output apparent force on the mean flow from pressure gradient
+               pguall(ii,k,m) = -pgu(i,k)
+               pgdall(ii,k,m) = -pgd(i,k)
+               icwu(ii,k,m)   =  conu(i,k)
+               icwd(ii,k,m)   =  cond(i,k)
+            end do
+         end do
+
+          ! Calculate momentum flux in units of mb*m/s2 
+
+          do k = ktm,pver
+             do i = il1g,il2g
+                ii = ideep(i)
+                mflux(i,k,m) = &
+                     -mu(i,k)*   (conu(i,k)-chat(i,k))      &
+                     -md(i,k)*   (cond(i,k)-chat(i,k))
+             end do
+          end do
+
+
+          ! Calculate winds at the end of the time step 
+
+          do k = ktm,pver
+             do i = il1g,il2g
+                ii = ideep(i)
+                km1 = max(1,k-1)
+                kp1 = k+1
+                windf(i,k,m) = const(i,k)    -   (mflux(i,kp1,m) - mflux(i,k,m)) * dt /dp(i,k)
+
+             end do
+          end do
+
+       end if      ! for domomtran
+   end do
+
+ ! Need to add an energy fix to account for the dissipation of kinetic energy
+    ! Formulation follows from Boville and Bretherton (2003)
+    ! formulation by PJR
+
+    do k = ktm,pver
+       km1 = max(1,k-1)
+       kp1 = min(pver,k+1)
+       do i = il1g,il2g
+
+          ii = ideep(i)
+
+          ! calculate the KE fluxes at top and bot of layer 
+          ! based on a discrete approximation to b&b eq(35) F_KE = u*F_u + v*F_v at interface
+          utop = (wind0(i,k,1)+wind0(i,km1,1))/2.
+          vtop = (wind0(i,k,2)+wind0(i,km1,2))/2.
+          ubot = (wind0(i,kp1,1)+wind0(i,k,1))/2.
+          vbot = (wind0(i,kp1,2)+wind0(i,k,2))/2.
+          fket = utop*mflux(i,k,1)   + vtop*mflux(i,k,2)    ! top of layer
+          fkeb = ubot*mflux(i,k+1,1) + vbot*mflux(i,k+1,2)  ! bot of layer
+
+          ! divergence of these fluxes should give a conservative redistribution of KE
+          ketend_cons = (fket-fkeb)/dp(i,k)
+
+          ! tendency in kinetic energy resulting from the momentum transport
+          ketend = ((windf(i,k,1)**2 + windf(i,k,2)**2) - (wind0(i,k,1)**2 + wind0(i,k,2)**2))*0.5/dt
+
+          ! the difference should be the dissipation
+          gset2 = ketend_cons - ketend
+          gseten(i,k) = gset2
+
+       end do
+
+    end do
+
+    ! Scatter dry static energy to full array
+    do k = 1,pver
+       do i = il1g,il2g
+          ii = ideep(i)
+          seten(ii,k) = gseten(i,k)
+
+       end do
+    end do
+
+   return
+end subroutine momtran
+
+#ifndef WRF_PORT
+!=========================================================================================
+
+subroutine buoyan(lchnk   ,ncol    , &
+                  q       ,t       ,p       ,z       ,pf      , &
+                  tp      ,qstp    ,tl      ,rl      ,cape    , &
+                  pblt    ,lcl     ,lel     ,lon     ,mx      , &
+                  rd      ,grav    ,cp      ,msg     , &
+                  tpert   )
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! <Say what the routine does> 
+! 
+! Method: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! Author:
+! This is contributed code not fully standardized by the CCM core group.
+! The documentation has been enhanced to the degree that we are able.
+! Reviewed:          P. Rasch, April 1996
+! 
+!-----------------------------------------------------------------------
+   implicit none
+!-----------------------------------------------------------------------
+!
+! input arguments
+!
+   integer, intent(in) :: lchnk                 ! chunk identifier
+   integer, intent(in) :: ncol                  ! number of atmospheric columns
+
+   real(r8), intent(in) :: q(pcols,pver)        ! spec. humidity
+   real(r8), intent(in) :: t(pcols,pver)        ! temperature
+   real(r8), intent(in) :: p(pcols,pver)        ! pressure
+   real(r8), intent(in) :: z(pcols,pver)        ! height
+   real(r8), intent(in) :: pf(pcols,pver+1)     ! pressure at interfaces
+   real(r8), intent(in) :: pblt(pcols)          ! index of pbl depth
+   real(r8), intent(in) :: tpert(pcols)         ! perturbation temperature by pbl processes
+
+!
+! output arguments
+!
+   real(r8), intent(out) :: tp(pcols,pver)       ! parcel temperature
+   real(r8), intent(out) :: qstp(pcols,pver)     ! saturation mixing ratio of parcel
+   real(r8), intent(out) :: tl(pcols)            ! parcel temperature at lcl
+   real(r8), intent(out) :: cape(pcols)          ! convective aval. pot. energy.
+   integer lcl(pcols)        !
+   integer lel(pcols)        !
+   integer lon(pcols)        ! level of onset of deep convection
+   integer mx(pcols)         ! level of max moist static energy
+!
+!--------------------------Local Variables------------------------------
+!
+   real(r8) capeten(pcols,5)     ! provisional value of cape
+   real(r8) tv(pcols,pver)       !
+   real(r8) tpv(pcols,pver)      !
+   real(r8) buoy(pcols,pver)
+
+   real(r8) a1(pcols)
+   real(r8) a2(pcols)
+   real(r8) estp(pcols)
+   real(r8) pl(pcols)
+   real(r8) plexp(pcols)
+   real(r8) hmax(pcols)
+   real(r8) hmn(pcols)
+   real(r8) y(pcols)
+
+   logical plge600(pcols)
+   integer knt(pcols)
+   integer lelten(pcols,5)
+
+   real(r8) cp
+   real(r8) e
+   real(r8) grav
+
+   integer i
+   integer k
+   integer msg
+   integer n
+
+   real(r8) rd
+   real(r8) rl
+#ifdef PERGRO
+   real(r8) rhd
+#endif
+!
+!-----------------------------------------------------------------------
+!
+   do n = 1,5
+      do i = 1,ncol
+         lelten(i,n) = pver
+         capeten(i,n) = 0._r8
+      end do
+   end do
+!
+   do i = 1,ncol
+      lon(i) = pver
+      knt(i) = 0
+      lel(i) = pver
+      mx(i) = lon(i)
+      cape(i) = 0._r8
+      hmax(i) = 0._r8
+   end do
+
+   tp(:ncol,:) = t(:ncol,:)
+   qstp(:ncol,:) = q(:ncol,:)
+
+!!! RBN - Initialize tv and buoy for output.
+!!! tv=tv : tpv=tpv : qstp=q : buoy=0.
+   tv(:ncol,:) = t(:ncol,:) *(1._r8+1.608*q(:ncol,:))/ (1._r8+q(:ncol,:))
+   tpv(:ncol,:) = tv(:ncol,:)
+   buoy(:ncol,:) = 0._r8
+
+!
+! set "launching" level(mx) to be at maximum moist static energy.
+! search for this level stops at planetary boundary layer top.
+!
+#ifdef PERGRO
+   do k = pver,msg + 1,-1
+      do i = 1,ncol
+         hmn(i) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k)
+!
+! Reset max moist static energy level when relative difference exceeds 1.e-4
+!
+         rhd = (hmn(i) - hmax(i))/(hmn(i) + hmax(i))
+         if (k >= nint(pblt(i)) .and. k <= lon(i) .and. rhd > -1.e-4_r8) then
+            hmax(i) = hmn(i)
+            mx(i) = k
+         end if
+      end do
+   end do
+#else
+   do k = pver,msg + 1,-1
+      do i = 1,ncol
+         hmn(i) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k)
+         if (k >= nint(pblt(i)) .and. k <= lon(i) .and. hmn(i) > hmax(i)) then
+            hmax(i) = hmn(i)
+            mx(i) = k
+         end if
+      end do
+   end do
+#endif
+!
+   do i = 1,ncol
+      lcl(i) = mx(i)
+      e = p(i,mx(i))*q(i,mx(i))/ (eps1+q(i,mx(i)))
+      tl(i) = 2840._r8/ (3.5_r8*log(t(i,mx(i)))-log(e)-4.805_r8) + 55._r8
+      if (tl(i) < t(i,mx(i))) then
+         plexp(i) = (1._r8/ (0.2854_r8* (1._r8-0.28_r8*q(i,mx(i)))))
+         pl(i) = p(i,mx(i))* (tl(i)/t(i,mx(i)))**plexp(i)
+      else
+         tl(i) = t(i,mx(i))
+         pl(i) = p(i,mx(i))
+      end if
+   end do
+
+!
+! calculate lifting condensation level (lcl).
+!
+   do k = pver,msg + 2,-1
+      do i = 1,ncol
+         if (k <= mx(i) .and. (p(i,k) > pl(i) .and. p(i,k-1) <= pl(i))) then
+            lcl(i) = k - 1
+         end if
+      end do
+   end do
+!
+! if lcl is above the nominal level of non-divergence (600 mbs),
+! no deep convection is permitted (ensuing calculations
+! skipped and cape retains initialized value of zero).
+!
+   do i = 1,ncol
+      plge600(i) = pl(i).ge.600._r8
+   end do
+!
+! initialize parcel properties in sub-cloud layer below lcl.
+!
+   do k = pver,msg + 1,-1
+      do i=1,ncol
+         if (k > lcl(i) .and. k <= mx(i) .and. plge600(i)) then
+            tv(i,k) = t(i,k)* (1._r8+1.608_r8*q(i,k))/ (1._r8+q(i,k))
+            qstp(i,k) = q(i,mx(i))
+            tp(i,k) = t(i,mx(i))* (p(i,k)/p(i,mx(i)))**(0.2854_r8* (1._r8-0.28_r8*q(i,mx(i))))
+!
+! buoyancy is increased by 0.5 k as in tiedtke
+!
+!-jjh          tpv (i,k)=tp(i,k)*(1.+1.608*q(i,mx(i)))/
+!-jjh     1                     (1.+q(i,mx(i)))
+            tpv(i,k) = (tp(i,k)+tpert(i))*(1._r8+1.608_r8*q(i,mx(i)))/ (1._r8+q(i,mx(i)))
+            buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add
+         end if
+      end do
+   end do
+
+!
+! define parcel properties at lcl (i.e. level immediately above pl).
+!
+   do k = pver,msg + 1,-1
+      do i=1,ncol
+         if (k == lcl(i) .and. plge600(i)) then
+            tv(i,k) = t(i,k)* (1._r8+1.608_r8*q(i,k))/ (1._r8+q(i,k))
+            qstp(i,k) = q(i,mx(i))
+            tp(i,k) = tl(i)* (p(i,k)/pl(i))**(0.2854_r8* (1._r8-0.28_r8*qstp(i,k)))
+!              estp(i)  =exp(a-b/tp(i,k))
+! use of different formulas for est has about 1 g/kg difference
+! in qs at t= 300k, and 0.02 g/kg at t=263k, with the formula
+! above giving larger qs.
+!
+            estp(i) = c1*exp((c2* (tp(i,k)-tfreez))/((tp(i,k)-tfreez)+c3))
+
+            qstp(i,k) = eps1*estp(i)/ (p(i,k)-estp(i))
+            a1(i) = cp / rl + qstp(i,k) * (1._r8+ qstp(i,k) / eps1) * rl * eps1 / &
+                    (rd * tp(i,k) ** 2)
+            a2(i) = .5_r8* (qstp(i,k)* (1._r8+2._r8/eps1*qstp(i,k))* &
+                    (1._r8+qstp(i,k)/eps1)*eps1**2*rl*rl/ &
+                    (rd**2*tp(i,k)**4)-qstp(i,k)* &
+                    (1._r8+qstp(i,k)/eps1)*2._r8*eps1*rl/ &
+                    (rd*tp(i,k)**3))
+            a1(i) = 1._r8/a1(i)
+            a2(i) = -a2(i)*a1(i)**3
+            y(i) = q(i,mx(i)) - qstp(i,k)
+            tp(i,k) = tp(i,k) + a1(i)*y(i) + a2(i)*y(i)**2
+!          estp(i)  =exp(a-b/tp(i,k))
+            estp(i) = c1*exp((c2* (tp(i,k)-tfreez))/ ((tp(i,k)-tfreez)+c3))
+
+            qstp(i,k) = eps1*estp(i) / (p(i,k)-estp(i))
+!
+! buoyancy is increased by 0.5 k in cape calculation.
+! dec. 9, 1994
+!-jjh          tpv(i,k) =tp(i,k)*(1.+1.608*qstp(i,k))/(1.+q(i,mx(i)))
+!
+            tpv(i,k) = (tp(i,k)+tpert(i))* (1._r8+1.608_r8*qstp(i,k)) / (1._r8+q(i,mx(i)))
+            buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add
+         end if
+      end do
+   end do
+!
+! main buoyancy calculation.
+!
+   do k = pver - 1,msg + 1,-1
+      do i=1,ncol
+         if (k < lcl(i) .and. plge600(i)) then
+            tv(i,k) = t(i,k)* (1._r8+1.608_r8*q(i,k))/ (1._r8+q(i,k))
+            qstp(i,k) = qstp(i,k+1)
+            tp(i,k) = tp(i,k+1)* (p(i,k)/p(i,k+1))**(0.2854_r8* (1._r8-0.28_r8*qstp(i,k)))
+!          estp(i) = exp(a-b/tp(i,k))
+            estp(i) = c1*exp((c2* (tp(i,k)-tfreez))/((tp(i,k)-tfreez)+c3))
+
+            qstp(i,k) = eps1*estp(i)/ (p(i,k)-estp(i))
+            a1(i) = cp/rl + qstp(i,k)* (1._r8+qstp(i,k)/eps1)*rl*eps1/ (rd*tp(i,k)**2)
+            a2(i) = .5_r8* (qstp(i,k)* (1._r8+2._r8/eps1*qstp(i,k))* &
+                    (1._r8+qstp(i,k)/eps1)*eps1**2*rl*rl/ &
+                    (rd**2*tp(i,k)**4)-qstp(i,k)* &
+                    (1._r8+qstp(i,k)/eps1)*2._r8*eps1*rl/ &
+                    (rd*tp(i,k)**3))
+            a1(i) = 1._r8/a1(i)
+            a2(i) = -a2(i)*a1(i)**3
+            y(i) = qstp(i,k+1) - qstp(i,k)
+            tp(i,k) = tp(i,k) + a1(i)*y(i) + a2(i)*y(i)**2
+!          estp(i)  =exp(a-b/tp(i,k))
+            estp(i) = c1*exp((c2* (tp(i,k)-tfreez))/ ((tp(i,k)-tfreez)+c3))
+
+            qstp(i,k) = eps1*estp(i)/ (p(i,k)-estp(i))
+!-jjh          tpv(i,k) =tp(i,k)*(1.+1.608*qstp(i,k))/
+!jt            (1.+q(i,mx(i)))
+            tpv(i,k) = (tp(i,k)+tpert(i))* (1._r8+1.608_r8*qstp(i,k))/(1._r8+q(i,mx(i)))
+            buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add
+         end if
+      end do
+   end do
+
+!
+   do k = msg + 2,pver
+      do i = 1,ncol
+         if (k < lcl(i) .and. plge600(i)) then
+            if (buoy(i,k+1) > 0._r8 .and. buoy(i,k) <= 0._r8) then
+               knt(i) = min(5,knt(i) + 1)
+               lelten(i,knt(i)) = k
+            end if
+         end if
+      end do
+   end do
+!
+! calculate convective available potential energy (cape).
+!
+   do n = 1,5
+      do k = msg + 1,pver
+         do i = 1,ncol
+            if (plge600(i) .and. k <= mx(i) .and. k > lelten(i,n)) then
+               capeten(i,n) = capeten(i,n) + rd*buoy(i,k)*log(pf(i,k+1)/pf(i,k))
+            end if
+         end do
+      end do
+   end do
+!
+! find maximum cape from all possible tentative capes from
+! one sounding,
+! and use it as the final cape, april 26, 1995
+!
+   do n = 1,5
+      do i = 1,ncol
+         if (capeten(i,n) > cape(i)) then
+            cape(i) = capeten(i,n)
+            lel(i) = lelten(i,n)
+         end if
+      end do
+   end do
+!
+! put lower bound on cape for diagnostic purposes.
+!
+   do i = 1,ncol
+      cape(i) = max(cape(i), 0._r8)
+   end do
+!
+   return
+end subroutine buoyan
+
+#endif
+
+subroutine cldprp(lchnk   , &
+                  q       ,t       ,u       ,v       ,p       , &
+                  z       ,s       ,mu      ,eu      ,du      , &
+                  md      ,ed      ,sd      ,qd      ,mc      , &
+                  qu      ,su      ,zf      ,qst     ,hmn     , &
+                  hsat    ,shat    ,ql      , &
+                  cmeg    ,jb      ,lel     ,jt      ,jlcl    , &
+                  mx      ,j0      ,jd      ,rl      ,il2g    , &
+                  rd      ,grav    ,cp      ,msg     , &
+                  pflx    ,evp     ,cu      ,rprd    ,limcnv  ,landfrac)
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! <Say what the routine does> 
+! 
+! Method: 
+! may 09/91 - guang jun zhang, m.lazare, n.mcfarlane.
+!             original version cldprop.
+! 
+! Author: See above, modified by P. Rasch
+! This is contributed code not fully standardized by the CCM core group.
+!
+! this code is very much rougher than virtually anything else in the CCM
+! there are debug statements left strewn about and code segments disabled
+! these are to facilitate future development. We expect to release a
+! cleaner code in a future release
+!
+! the documentation has been enhanced to the degree that we are able
+!
+!-----------------------------------------------------------------------
+
+   implicit none
+
+!------------------------------------------------------------------------------
+!
+! Input arguments
+!
+   integer, intent(in) :: lchnk                  ! chunk identifier
+
+   real(r8), intent(in) :: q(pcols,pver)         ! spec. humidity of env
+   real(r8), intent(in) :: t(pcols,pver)         ! temp of env
+   real(r8), intent(in) :: p(pcols,pver)         ! pressure of env
+   real(r8), intent(in) :: z(pcols,pver)         ! height of env
+   real(r8), intent(in) :: s(pcols,pver)         ! normalized dry static energy of env
+   real(r8), intent(in) :: zf(pcols,pverp)       ! height of interfaces
+   real(r8), intent(in) :: u(pcols,pver)         ! zonal velocity of env
+   real(r8), intent(in) :: v(pcols,pver)         ! merid. velocity of env
+   real(r8), intent(in) :: landfrac(pcols) ! RBN Landfrac
+
+   integer, intent(in) :: jb(pcols)              ! updraft base level
+   integer, intent(in) :: lel(pcols)             ! updraft launch level
+   integer, intent(out) :: jt(pcols)              ! updraft plume top
+   integer, intent(out) :: jlcl(pcols)            ! updraft lifting cond level
+   integer, intent(in) :: mx(pcols)              ! updraft base level (same is jb)
+   integer, intent(out) :: j0(pcols)              ! level where updraft begins detraining
+   integer, intent(out) :: jd(pcols)              ! level of downdraft
+   integer, intent(in) :: limcnv                 ! convection limiting level
+   integer, intent(in) :: il2g                   !CORE GROUP REMOVE
+   integer, intent(in) :: msg                    ! missing moisture vals (always 0)
+   real(r8), intent(in) :: rl                    ! latent heat of vap
+   real(r8), intent(in) :: shat(pcols,pver)      ! interface values of dry stat energy
+!
+! output
+!
+   real(r8), intent(out) :: rprd(pcols,pver)     ! rate of production of precip at that layer
+   real(r8), intent(out) :: du(pcols,pver)       ! detrainement rate of updraft
+   real(r8), intent(out) :: ed(pcols,pver)       ! entrainment rate of downdraft
+   real(r8), intent(out) :: eu(pcols,pver)       ! entrainment rate of updraft
+   real(r8), intent(out) :: hmn(pcols,pver)      ! moist stat energy of env
+   real(r8), intent(out) :: hsat(pcols,pver)     ! sat moist stat energy of env
+   real(r8), intent(out) :: mc(pcols,pver)       ! net mass flux
+   real(r8), intent(out) :: md(pcols,pver)       ! downdraft mass flux
+   real(r8), intent(out) :: mu(pcols,pver)       ! updraft mass flux
+   real(r8), intent(out) :: pflx(pcols,pverp)    ! precipitation flux thru layer
+   real(r8), intent(out) :: qd(pcols,pver)       ! spec humidity of downdraft
+   real(r8), intent(out) :: ql(pcols,pver)       ! liq water of updraft
+   real(r8), intent(out) :: qst(pcols,pver)      ! saturation spec humidity of env.
+   real(r8), intent(out) :: qu(pcols,pver)       ! spec hum of updraft
+   real(r8), intent(out) :: sd(pcols,pver)       ! normalized dry stat energy of downdraft
+   real(r8), intent(out) :: su(pcols,pver)       ! normalized dry stat energy of updraft
+
+
+   real(r8) rd                   ! gas constant for dry air
+   real(r8) grav                 ! gravity
+   real(r8) cp                   ! heat capacity of dry air
+
+!
+! Local workspace
+!
+   real(r8) gamma(pcols,pver)
+   real(r8) dz(pcols,pver)
+   real(r8) iprm(pcols,pver)
+   real(r8) hu(pcols,pver)
+   real(r8) hd(pcols,pver)
+   real(r8) eps(pcols,pver)
+   real(r8) f(pcols,pver)
+   real(r8) k1(pcols,pver)
+   real(r8) i2(pcols,pver)
+   real(r8) ihat(pcols,pver)
+   real(r8) i3(pcols,pver)
+   real(r8) idag(pcols,pver)
+   real(r8) i4(pcols,pver)
+   real(r8) qsthat(pcols,pver)
+   real(r8) hsthat(pcols,pver)
+   real(r8) gamhat(pcols,pver)
+   real(r8) cu(pcols,pver)
+   real(r8) evp(pcols,pver)
+   real(r8) cmeg(pcols,pver)
+   real(r8) qds(pcols,pver)
+! RBN For c0mask
+   real(r8) c0mask(pcols)
+   real(r8) hmin(pcols)
+   real(r8) expdif(pcols)
+   real(r8) expnum(pcols)
+   real(r8) ftemp(pcols)
+   real(r8) eps0(pcols)
+   real(r8) rmue(pcols)
+   real(r8) zuef(pcols)
+   real(r8) zdef(pcols)
+   real(r8) epsm(pcols)
+   real(r8) ratmjb(pcols)
+   real(r8) est(pcols)
+   real(r8) totpcp(pcols)
+   real(r8) totevp(pcols)
+   real(r8) alfa(pcols)
+   real(r8) ql1
+   real(r8) tu
+   real(r8) estu
+   real(r8) qstu
+
+   real(r8) small
+   real(r8) mdt
+
+   integer khighest
+   integer klowest
+   integer kount
+   integer i,k
+
+   logical doit(pcols)
+   logical done(pcols)
+!
+!------------------------------------------------------------------------------
+!
+   do i = 1,il2g
+      ftemp(i) = 0._r8
+      expnum(i) = 0._r8
+      expdif(i) = 0._r8
+      c0mask(i)  = c0_ocn * (1._r8-landfrac(i)) +   c0_lnd * landfrac(i) 
+   end do
+!
+!jr Change from msg+1 to 1 to prevent blowup
+!
+   do k = 1,pver
+      do i = 1,il2g
+         dz(i,k) = zf(i,k) - zf(i,k+1)
+      end do
+   end do
+
+!
+! initialize many output and work variables to zero
+!
+   pflx(:il2g,1) = 0
+
+   do k = 1,pver
+      do i = 1,il2g
+         k1(i,k) = 0._r8
+         i2(i,k) = 0._r8
+         i3(i,k) = 0._r8
+         i4(i,k) = 0._r8
+         mu(i,k) = 0._r8
+         f(i,k) = 0._r8
+         eps(i,k) = 0._r8
+         eu(i,k) = 0._r8
+         du(i,k) = 0._r8
+         ql(i,k) = 0._r8
+         cu(i,k) = 0._r8
+         evp(i,k) = 0._r8
+         cmeg(i,k) = 0._r8
+         qds(i,k) = q(i,k)
+         md(i,k) = 0._r8
+         ed(i,k) = 0._r8
+         sd(i,k) = s(i,k)
+         qd(i,k) = q(i,k)
+         mc(i,k) = 0._r8
+         qu(i,k) = q(i,k)
+         su(i,k) = s(i,k)
+!        est(i)=exp(a-b/t(i,k))
+         est(i) = c1*exp((c2* (t(i,k)-tfreez))/((t(i,k)-tfreez)+c3))
+!++bee
+         if ( p(i,k)-est(i) > 0._r8 ) then
+            qst(i,k) = eps1*est(i)/ (p(i,k)-est(i))
+         else
+            qst(i,k) = 1.0_r8
+         end if
+!--bee
+         gamma(i,k) = qst(i,k)*(1._r8 + qst(i,k)/eps1)*eps1*rl/(rd*t(i,k)**2)*rl/cp
+         hmn(i,k) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k)
+         hsat(i,k) = cp*t(i,k) + grav*z(i,k) + rl*qst(i,k)
+         hu(i,k) = hmn(i,k)
+         hd(i,k) = hmn(i,k)
+         rprd(i,k) = 0._r8
+      end do
+   end do
+!
+!jr Set to zero things which make this routine blow up
+!
+   do k=1,msg
+      do i=1,il2g
+         rprd(i,k) = 0._r8
+      end do
+   end do
+!
+! interpolate the layer values of qst, hsat and gamma to
+! layer interfaces
+!
+   do i = 1,il2g
+      hsthat(i,msg+1) = hsat(i,msg+1)
+      qsthat(i,msg+1) = qst(i,msg+1)
+      gamhat(i,msg+1) = gamma(i,msg+1)
+      totpcp(i) = 0._r8
+      totevp(i) = 0._r8
+   end do
+   do k = msg + 2,pver
+      do i = 1,il2g
+         if (abs(qst(i,k-1)-qst(i,k)) > 1.E-6_r8) then
+            qsthat(i,k) = log(qst(i,k-1)/qst(i,k))*qst(i,k-1)*qst(i,k)/ (qst(i,k-1)-qst(i,k))
+         else
+            qsthat(i,k) = qst(i,k)
+         end if
+         hsthat(i,k) = cp*shat(i,k) + rl*qsthat(i,k)
+         if (abs(gamma(i,k-1)-gamma(i,k)) > 1.E-6_r8) then
+            gamhat(i,k) = log(gamma(i,k-1)/gamma(i,k))*gamma(i,k-1)*gamma(i,k)/ &
+                                (gamma(i,k-1)-gamma(i,k))
+         else
+            gamhat(i,k) = gamma(i,k)
+         end if
+      end do
+   end do
+!
+! initialize cloud top to highest plume top.
+!jr changed hard-wired 4 to limcnv+1 (not to exceed pver)
+!
+   jt(:) = pver
+   do i = 1,il2g
+      jt(i) = max(lel(i),limcnv+1)
+      jt(i) = min(jt(i),pver)
+      jd(i) = pver
+      jlcl(i) = lel(i)
+      hmin(i) = 1.E6_r8
+   end do
+!
+! find the level of minimum hsat, where detrainment starts
+!
+   do k = msg + 1,pver
+      do i = 1,il2g
+         if (hsat(i,k) <= hmin(i) .and. k >= jt(i) .and. k <= jb(i)) then
+            hmin(i) = hsat(i,k)
+            j0(i) = k
+         end if
+      end do
+   end do
+   do i = 1,il2g
+      j0(i) = min(j0(i),jb(i)-2)
+      j0(i) = max(j0(i),jt(i)+2)
+!
+! Fix from Guang Zhang to address out of bounds array reference
+!
+      j0(i) = min(j0(i),pver)
+   end do
+!
+! Initialize certain arrays inside cloud
+!
+   do k = msg + 1,pver
+      do i = 1,il2g
+         if (k >= jt(i) .and. k <= jb(i)) then
+            hu(i,k) = hmn(i,mx(i)) + cp*tiedke_add
+            su(i,k) = s(i,mx(i)) + tiedke_add
+         end if
+      end do
+   end do
+!
+! *********************************************************
+! compute taylor series for approximate eps(z) below
+! *********************************************************
+!
+   do k = pver - 1,msg + 1,-1
+      do i = 1,il2g
+         if (k < jb(i) .and. k >= jt(i)) then
+            k1(i,k) = k1(i,k+1) + (hmn(i,mx(i))-hmn(i,k))*dz(i,k)
+            ihat(i,k) = 0.5_r8* (k1(i,k+1)+k1(i,k))
+            i2(i,k) = i2(i,k+1) + ihat(i,k)*dz(i,k)
+            idag(i,k) = 0.5_r8* (i2(i,k+1)+i2(i,k))
+            i3(i,k) = i3(i,k+1) + idag(i,k)*dz(i,k)
+            iprm(i,k) = 0.5_r8* (i3(i,k+1)+i3(i,k))
+            i4(i,k) = i4(i,k+1) + iprm(i,k)*dz(i,k)
+         end if
+      end do
+   end do
+!
+! re-initialize hmin array for ensuing calculation.
+!
+   do i = 1,il2g
+      hmin(i) = 1.E6_r8
+   end do
+   do k = msg + 1,pver
+      do i = 1,il2g
+         if (k >= j0(i) .and. k <= jb(i) .and. hmn(i,k) <= hmin(i)) then
+            hmin(i) = hmn(i,k)
+            expdif(i) = hmn(i,mx(i)) - hmin(i)
+         end if
+      end do
+   end do
+!
+! *********************************************************
+! compute approximate eps(z) using above taylor series
+! *********************************************************
+!
+   do k = msg + 2,pver
+      do i = 1,il2g
+         expnum(i) = 0._r8
+         ftemp(i) = 0._r8
+         if (k < jt(i) .or. k >= jb(i)) then
+            k1(i,k) = 0._r8
+            expnum(i) = 0._r8
+         else
+            expnum(i) = hmn(i,mx(i)) - (hsat(i,k-1)*(zf(i,k)-z(i,k)) + &
+                        hsat(i,k)* (z(i,k-1)-zf(i,k)))/(z(i,k-1)-z(i,k))
+         end if
+         if ((expdif(i) > 100._r8 .and. expnum(i) > 0._r8) .and. &
+	     k1(i,k) > expnum(i)*dz(i,k)) then
+            ftemp(i) = expnum(i)/k1(i,k)
+            f(i,k) = ftemp(i) + i2(i,k)/k1(i,k)*ftemp(i)**2 + &
+                     (2._r8*i2(i,k)**2-k1(i,k)*i3(i,k))/k1(i,k)**2* &
+                     ftemp(i)**3 + (-5._r8*k1(i,k)*i2(i,k)*i3(i,k)+ &
+                     5._r8*i2(i,k)**3+k1(i,k)**2*i4(i,k))/ &
+                     k1(i,k)**3*ftemp(i)**4
+            f(i,k) = max(f(i,k),0._r8)
+            f(i,k) = min(f(i,k),0.0002_r8)
+         end if
+      end do
+   end do
+   do i = 1,il2g
+      if (j0(i) < jb(i)) then
+         if (f(i,j0(i)) < 1.E-6_r8 .and. f(i,j0(i)+1) > f(i,j0(i))) j0(i) = j0(i) + 1
+      end if
+   end do
+   do k = msg + 2,pver
+      do i = 1,il2g
+         if (k >= jt(i) .and. k <= j0(i)) then
+            f(i,k) = max(f(i,k),f(i,k-1))
+         end if
+      end do
+   end do
+   do i = 1,il2g
+      eps0(i) = f(i,j0(i))
+      eps(i,jb(i)) = eps0(i)
+   end do
+!
+! This is set to match the Rasch and Kristjansson paper
+!
+   do k = pver,msg + 1,-1
+      do i = 1,il2g
+         if (k >= j0(i) .and. k <= jb(i)) then
+            eps(i,k) = f(i,j0(i))
+         end if
+      end do
+   end do
+   do k = pver,msg + 1,-1
+      do i = 1,il2g
+         if (k < j0(i) .and. k >= jt(i)) eps(i,k) = f(i,k)
+      end do
+   end do
+!
+! specify the updraft mass flux mu, entrainment eu, detrainment du
+! and moist static energy hu.
+! here and below mu, eu,du, md and ed are all normalized by mb
+!
+   do i = 1,il2g
+      if (eps0(i) > 0._r8) then
+         mu(i,jb(i)) = 1._r8
+         eu(i,jb(i)) = mu(i,jb(i))/dz(i,jb(i))
+      end if
+   end do
+   do k = pver,msg + 1,-1
+      do i = 1,il2g
+         if (eps0(i) > 0._r8 .and. (k >= jt(i) .and. k < jb(i))) then
+            zuef(i) = zf(i,k) - zf(i,jb(i))
+            rmue(i) = (1._r8/eps0(i))* (exp(eps(i,k+1)*zuef(i))-1._r8)/zuef(i)
+            mu(i,k) = (1._r8/eps0(i))* (exp(eps(i,k  )*zuef(i))-1._r8)/zuef(i)
+            eu(i,k) = (rmue(i)-mu(i,k+1))/dz(i,k)
+            du(i,k) = (rmue(i)-mu(i,k))/dz(i,k)
+         end if
+      end do
+   end do
+!
+   khighest = pverp
+   klowest = 1
+   do i=1,il2g
+      khighest = min(khighest,lel(i))
+      klowest = max(klowest,jb(i))
+   end do
+   do k = klowest-1,khighest,-1
+!cdir$ ivdep
+      do i = 1,il2g
+         if (k <= jb(i)-1 .and. k >= lel(i) .and. eps0(i) > 0._r8) then
+            if (mu(i,k) < 0.01_r8) then
+               hu(i,k) = hu(i,jb(i))
+               mu(i,k) = 0._r8
+               eu(i,k) = 0._r8
+               du(i,k) = mu(i,k+1)/dz(i,k)
+            else
+               hu(i,k) = mu(i,k+1)/mu(i,k)*hu(i,k+1) + &
+                         dz(i,k)/mu(i,k)* (eu(i,k)*hmn(i,k)- du(i,k)*hsat(i,k))
+            end if
+         end if
+      end do
+   end do
+!
+! reset cloud top index beginning from two layers above the
+! cloud base (i.e. if cloud is only one layer thick, top is not reset
+!
+   do i=1,il2g
+      doit(i) = .true.
+   end do
+   do k=klowest-2,khighest-1,-1
+      do i=1,il2g
+         if (doit(i) .and. k <= jb(i)-2 .and. k >= lel(i)-1) then
+  	   if (hu(i,k) <= hsthat(i,k) .and. hu(i,k+1) > hsthat(i,k+1) &
+	       .and. mu(i,k) >= 0.02_r8) then
+               if (hu(i,k)-hsthat(i,k) < -2000._r8) then
+                  jt(i) = k + 1
+                  doit(i) = .false.
+               else
+                  jt(i) = k
+                  if (eps0(i) <= 0._r8) doit(i) = .false.
+               end if
+            else if (hu(i,k) > hu(i,jb(i)) .or. mu(i,k) < 0.01_r8) then
+               jt(i) = k + 1
+               doit(i) = .false.
+            end if
+         end if
+      end do
+   end do
+   do k = pver,msg + 1,-1
+!cdir$ ivdep
+      do i = 1,il2g
+         if (k >= lel(i) .and. k <= jt(i) .and. eps0(i) > 0._r8) then
+            mu(i,k) = 0._r8
+            eu(i,k) = 0._r8
+            du(i,k) = 0._r8
+            hu(i,k) = hu(i,jb(i))
+         end if
+         if (k == jt(i) .and. eps0(i) > 0._r8) then
+            du(i,k) = mu(i,k+1)/dz(i,k)
+            eu(i,k) = 0._r8
+            mu(i,k) = 0._r8
+         end if
+      end do
+   end do
+!
+! specify downdraft properties (no downdrafts if jd.ge.jb).
+! scale down downward mass flux profile so that net flux
+! (up-down) at cloud base in not negative.
+!
+   do i = 1,il2g
+!
+! in normal downdraft strength run alfa=0.2.  In test4 alfa=0.1
+!
+      alfa(i) = 0.1_r8
+      jt(i) = min(jt(i),jb(i)-1)
+      jd(i) = max(j0(i),jt(i)+1)
+      jd(i) = min(jd(i),jb(i))
+      hd(i,jd(i)) = hmn(i,jd(i)-1)
+      if (jd(i) < jb(i) .and. eps0(i) > 0._r8) then
+         epsm(i) = eps0(i)
+         md(i,jd(i)) = -alfa(i)*epsm(i)/eps0(i)
+      end if
+   end do
+   do k = msg + 1,pver
+      do i = 1,il2g
+         if ((k > jd(i) .and. k <= jb(i)) .and. eps0(i) > 0._r8) then
+            zdef(i) = zf(i,jd(i)) - zf(i,k)
+            md(i,k) = -alfa(i)/ (2._r8*eps0(i))*(exp(2._r8*epsm(i)*zdef(i))-1._r8)/zdef(i)
+         end if
+      end do
+   end do
+   do k = msg + 1,pver
+      do i = 1,il2g
+         if ((k >= jt(i) .and. k <= jb(i)) .and. eps0(i) > 0._r8 .and. jd(i) < jb(i)) then
+            ratmjb(i) = min(abs(mu(i,jb(i))/md(i,jb(i))),1._r8)
+            md(i,k) = md(i,k)*ratmjb(i)
+         end if
+      end do
+   end do
+
+   small = 1.e-20_r8
+   do k = msg + 1,pver
+      do i = 1,il2g
+         if ((k >= jt(i) .and. k <= pver) .and. eps0(i) > 0._r8) then
+            ed(i,k-1) = (md(i,k-1)-md(i,k))/dz(i,k-1)
+            mdt = min(md(i,k),-small)
+            hd(i,k) = (md(i,k-1)*hd(i,k-1) - dz(i,k-1)*ed(i,k-1)*hmn(i,k-1))/mdt
+         end if
+      end do
+   end do
+!
+! calculate updraft and downdraft properties.
+!
+   do k = msg + 2,pver
+      do i = 1,il2g
+         if ((k >= jd(i) .and. k <= jb(i)) .and. eps0(i) > 0._r8 .and. jd(i) < jb(i)) then
+            qds(i,k) = qsthat(i,k) + gamhat(i,k)*(hd(i,k)-hsthat(i,k))/ &
+               (rl*(1._r8 + gamhat(i,k)))
+         end if
+      end do
+   end do
+!
+   do i = 1,il2g
+      done(i) = .false.
+   end do
+   kount = 0
+   do k = pver,msg + 2,-1
+      do i = 1,il2g
+         if (( .not. done(i) .and. k > jt(i) .and. k < jb(i)) .and. eps0(i) > 0._r8) then
+            su(i,k) = mu(i,k+1)/mu(i,k)*su(i,k+1) + &
+                      dz(i,k)/mu(i,k)* (eu(i,k)-du(i,k))*s(i,k)
+            qu(i,k) = mu(i,k+1)/mu(i,k)*qu(i,k+1) + dz(i,k)/mu(i,k)* (eu(i,k)*q(i,k)- &
+                            du(i,k)*qst(i,k))
+            tu = su(i,k) - grav/cp*zf(i,k)
+            estu = c1*exp((c2* (tu-tfreez))/ ((tu-tfreez)+c3))
+            qstu = eps1*estu/ ((p(i,k)+p(i,k-1))/2._r8-estu)
+            if (qu(i,k) >= qstu) then
+               jlcl(i) = k
+               kount = kount + 1
+               done(i) = .true.
+            end if
+         end if
+      end do
+      if (kount >= il2g) goto 690
+   end do
+690 continue
+   do k = msg + 2,pver
+      do i = 1,il2g
+         if (k == jb(i) .and. eps0(i) > 0._r8) then
+            qu(i,k) = q(i,mx(i))
+            su(i,k) = (hu(i,k)-rl*qu(i,k))/cp
+         end if
+         if ((k > jt(i) .and. k <= jlcl(i)) .and. eps0(i) > 0._r8) then
+            su(i,k) = shat(i,k) + (hu(i,k)-hsthat(i,k))/(cp* (1._r8+gamhat(i,k)))
+            qu(i,k) = qsthat(i,k) + gamhat(i,k)*(hu(i,k)-hsthat(i,k))/ &
+                     (rl* (1._r8+gamhat(i,k)))
+         end if
+      end do
+   end do
+
+! compute condensation in updraft
+   do k = pver,msg + 2,-1
+      do i = 1,il2g
+         if (k >= jt(i) .and. k < jb(i) .and. eps0(i) > 0._r8) then
+            cu(i,k) = ((mu(i,k)*su(i,k)-mu(i,k+1)*su(i,k+1))/ &
+                      dz(i,k)- (eu(i,k)-du(i,k))*s(i,k))/(rl/cp)
+            if (k == jt(i)) cu(i,k) = 0._r8
+            cu(i,k) = max(0._r8,cu(i,k))
+         end if
+      end do
+   end do
+
+! compute condensed liquid, rain production rate
+! accumulate total precipitation (condensation - detrainment of liquid)
+! Note ql1 = ql(k) + rprd(k)*dz(k)/mu(k)
+! The differencing is somewhat strange (e.g. du(i,k)*ql(i,k+1)) but is
+! consistently applied.
+!    mu, ql are interface quantities
+!    cu, du, eu, rprd are midpoint quantites
+   do k = pver,msg + 2,-1
+      do i = 1,il2g
+         rprd(i,k) = 0._r8
+         if (k >= jt(i) .and. k < jb(i) .and. eps0(i) > 0._r8 .and. mu(i,k) >= 0.0_r8) then
+            if (mu(i,k) > 0._r8) then
+               ql1 = 1._r8/mu(i,k)* (mu(i,k+1)*ql(i,k+1)- &
+                     dz(i,k)*du(i,k)*ql(i,k+1)+dz(i,k)*cu(i,k))
+               ql(i,k) = ql1/ (1._r8+dz(i,k)*c0mask(i))
+            else
+               ql(i,k) = 0._r8
+            end if
+            totpcp(i) = totpcp(i) + dz(i,k)*(cu(i,k)-du(i,k)*ql(i,k+1))
+            rprd(i,k) = c0mask(i)*mu(i,k)*ql(i,k)
+         end if
+      end do
+   end do
+!
+   do i = 1,il2g
+      qd(i,jd(i)) = qds(i,jd(i))
+      sd(i,jd(i)) = (hd(i,jd(i)) - rl*qd(i,jd(i)))/cp
+   end do
+!
+   do k = msg + 2,pver
+      do i = 1,il2g
+         if (k >= jd(i) .and. k < jb(i) .and. eps0(i) > 0._r8) then
+            qd(i,k+1) = qds(i,k+1)
+            evp(i,k) = -ed(i,k)*q(i,k) + (md(i,k)*qd(i,k)-md(i,k+1)*qd(i,k+1))/dz(i,k)
+            evp(i,k) = max(evp(i,k),0._r8)
+            mdt = min(md(i,k+1),-small)
+            sd(i,k+1) = ((rl/cp*evp(i,k)-ed(i,k)*s(i,k))*dz(i,k) + md(i,k)*sd(i,k))/mdt
+            totevp(i) = totevp(i) - dz(i,k)*ed(i,k)*q(i,k)
+         end if
+      end do
+   end do
+   do i = 1,il2g
+!*guang         totevp(i) = totevp(i) + md(i,jd(i))*q(i,jd(i)-1) -
+      totevp(i) = totevp(i) + md(i,jd(i))*qd(i,jd(i)) - md(i,jb(i))*qd(i,jb(i))
+   end do
+!!$   if (.true.) then
+   if (.false.) then
+      do i = 1,il2g
+         k = jb(i)
+         if (eps0(i) > 0._r8) then
+            evp(i,k) = -ed(i,k)*q(i,k) + (md(i,k)*qd(i,k))/dz(i,k)
+            evp(i,k) = max(evp(i,k),0._r8)
+            totevp(i) = totevp(i) - dz(i,k)*ed(i,k)*q(i,k)
+         end if
+      end do
+   endif
+
+   do i = 1,il2g
+      totpcp(i) = max(totpcp(i),0._r8)
+      totevp(i) = max(totevp(i),0._r8)
+   end do
+!
+   do k = msg + 2,pver
+      do i = 1,il2g
+         if (totevp(i) > 0._r8 .and. totpcp(i) > 0._r8) then
+            md(i,k)  = md (i,k)*min(1._r8, totpcp(i)/(totevp(i)+totpcp(i)))
+            ed(i,k)  = ed (i,k)*min(1._r8, totpcp(i)/(totevp(i)+totpcp(i)))
+            evp(i,k) = evp(i,k)*min(1._r8, totpcp(i)/(totevp(i)+totpcp(i)))
+         else
+            md(i,k) = 0._r8
+            ed(i,k) = 0._r8
+            evp(i,k) = 0._r8
+         end if
+! cmeg is the cloud water condensed - rain water evaporated
+! rprd is the cloud water converted to rain - (rain evaporated)
+         cmeg(i,k) = cu(i,k) - evp(i,k)
+         rprd(i,k) = rprd(i,k)-evp(i,k)
+      end do
+   end do
+
+! compute the net precipitation flux across interfaces
+   pflx(:il2g,1) = 0._r8
+   do k = 2,pverp
+      do i = 1,il2g
+         pflx(i,k) = pflx(i,k-1) + rprd(i,k-1)*dz(i,k-1)
+      end do
+   end do
+!
+   do k = msg + 1,pver
+      do i = 1,il2g
+         mc(i,k) = mu(i,k) + md(i,k)
+      end do
+   end do
+!
+   return
+end subroutine cldprp
+
+subroutine closure(lchnk   , &
+                   q       ,t       ,p       ,z       ,s       , &
+                   tp      ,qs      ,qu      ,su      ,mc      , &
+                   du      ,mu      ,md      ,qd      ,sd      , &
+                   qhat    ,shat    ,dp      ,qstp    ,zf      , &
+                   ql      ,dsubcld ,mb      ,cape    ,tl      , &
+                   lcl     ,lel     ,jt      ,mx      ,il1g    , &
+                   il2g    ,rd      ,grav    ,cp      ,rl      , &
+                   msg     ,capelmt )
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! <Say what the routine does> 
+! 
+! Method: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! Author: G. Zhang and collaborators. CCM contact:P. Rasch
+! This is contributed code not fully standardized by the CCM core group.
+!
+! this code is very much rougher than virtually anything else in the CCM
+! We expect to release cleaner code in a future release
+!
+! the documentation has been enhanced to the degree that we are able
+! 
+!-----------------------------------------------------------------------
+#ifndef WRF_PORT
+   use dycore,    only: dycore_is, get_resolution
+#endif
+
+   implicit none
+
+!
+!-----------------------------Arguments---------------------------------
+!
+   integer, intent(in) :: lchnk                 ! chunk identifier
+
+   real(r8), intent(inout) :: q(pcols,pver)        ! spec humidity
+   real(r8), intent(inout) :: t(pcols,pver)        ! temperature
+   real(r8), intent(inout) :: p(pcols,pver)        ! pressure (mb)
+   real(r8), intent(inout) :: mb(pcols)            ! cloud base mass flux
+   real(r8), intent(in) :: z(pcols,pver)        ! height (m)
+   real(r8), intent(in) :: s(pcols,pver)        ! normalized dry static energy
+   real(r8), intent(in) :: tp(pcols,pver)       ! parcel temp
+   real(r8), intent(in) :: qs(pcols,pver)       ! sat spec humidity
+   real(r8), intent(in) :: qu(pcols,pver)       ! updraft spec. humidity
+   real(r8), intent(in) :: su(pcols,pver)       ! normalized dry stat energy of updraft
+   real(r8), intent(in) :: mc(pcols,pver)       ! net convective mass flux
+   real(r8), intent(in) :: du(pcols,pver)       ! detrainment from updraft
+   real(r8), intent(in) :: mu(pcols,pver)       ! mass flux of updraft
+   real(r8), intent(in) :: md(pcols,pver)       ! mass flux of downdraft
+   real(r8), intent(in) :: qd(pcols,pver)       ! spec. humidity of downdraft
+   real(r8), intent(in) :: sd(pcols,pver)       ! dry static energy of downdraft
+   real(r8), intent(in) :: qhat(pcols,pver)     ! environment spec humidity at interfaces
+   real(r8), intent(in) :: shat(pcols,pver)     ! env. normalized dry static energy at intrfcs
+   real(r8), intent(in) :: dp(pcols,pver)       ! pressure thickness of layers
+   real(r8), intent(in) :: qstp(pcols,pver)     ! spec humidity of parcel
+   real(r8), intent(in) :: zf(pcols,pver+1)     ! height of interface levels
+   real(r8), intent(in) :: ql(pcols,pver)       ! liquid water mixing ratio
+
+   real(r8), intent(in) :: cape(pcols)          ! available pot. energy of column
+   real(r8), intent(in) :: tl(pcols)
+   real(r8), intent(in) :: dsubcld(pcols)       ! thickness of subcloud layer
+
+   integer, intent(in) :: lcl(pcols)        ! index of lcl
+   integer, intent(in) :: lel(pcols)        ! index of launch leve
+   integer, intent(in) :: jt(pcols)         ! top of updraft
+   integer, intent(in) :: mx(pcols)         ! base of updraft
+!
+!--------------------------Local variables------------------------------
+!
+   real(r8) dtpdt(pcols,pver)
+   real(r8) dqsdtp(pcols,pver)
+   real(r8) dtmdt(pcols,pver)
+   real(r8) dqmdt(pcols,pver)
+   real(r8) dboydt(pcols,pver)
+   real(r8) thetavp(pcols,pver)
+   real(r8) thetavm(pcols,pver)
+
+   real(r8) dtbdt(pcols),dqbdt(pcols),dtldt(pcols)
+   real(r8) beta
+   real(r8) capelmt
+   real(r8) cp
+   real(r8) dadt(pcols)
+   real(r8) debdt
+   real(r8) dltaa
+   real(r8) eb
+   real(r8) grav
+
+   integer i
+   integer il1g
+   integer il2g
+   integer k, kmin, kmax
+   integer msg
+
+   real(r8) rd
+   real(r8) rl
+! change of subcloud layer properties due to convection is
+! related to cumulus updrafts and downdrafts.
+! mc(z)=f(z)*mb, mub=betau*mb, mdb=betad*mb are used
+! to define betau, betad and f(z).
+! note that this implies all time derivatives are in effect
+! time derivatives per unit cloud-base mass flux, i.e. they
+! have units of 1/mb instead of 1/sec.
+!
+   do i = il1g,il2g
+      mb(i) = 0._r8
+      eb = p(i,mx(i))*q(i,mx(i))/ (eps1+q(i,mx(i)))
+      dtbdt(i) = (1._r8/dsubcld(i))* (mu(i,mx(i))*(shat(i,mx(i))-su(i,mx(i)))+ &
+                  md(i,mx(i))* (shat(i,mx(i))-sd(i,mx(i))))
+      dqbdt(i) = (1._r8/dsubcld(i))* (mu(i,mx(i))*(qhat(i,mx(i))-qu(i,mx(i)))+ &
+                 md(i,mx(i))* (qhat(i,mx(i))-qd(i,mx(i))))
+      debdt = eps1*p(i,mx(i))/ (eps1+q(i,mx(i)))**2*dqbdt(i)
+      dtldt(i) = -2840._r8* (3.5_r8/t(i,mx(i))*dtbdt(i)-debdt/eb)/ &
+                 (3.5_r8*log(t(i,mx(i)))-log(eb)-4.805_r8)**2
+   end do
+!
+!   dtmdt and dqmdt are cumulus heating and drying.
+!
+   do k = msg + 1,pver
+      do i = il1g,il2g
+         dtmdt(i,k) = 0._r8
+         dqmdt(i,k) = 0._r8
+      end do
+   end do
+!
+   do k = msg + 1,pver - 1
+      do i = il1g,il2g
+         if (k == jt(i)) then
+            dtmdt(i,k) = (1._r8/dp(i,k))*(mu(i,k+1)* (su(i,k+1)-shat(i,k+1)- &
+                          rl/cp*ql(i,k+1))+md(i,k+1)* (sd(i,k+1)-shat(i,k+1)))
+            dqmdt(i,k) = (1._r8/dp(i,k))*(mu(i,k+1)* (qu(i,k+1)- &
+                         qhat(i,k+1)+ql(i,k+1))+md(i,k+1)*(qd(i,k+1)-qhat(i,k+1)))
+         end if
+      end do
+   end do
+!
+   beta = 0._r8
+   do k = msg + 1,pver - 1
+      do i = il1g,il2g
+         if (k > jt(i) .and. k < mx(i)) then
+            dtmdt(i,k) = (mc(i,k)* (shat(i,k)-s(i,k))+mc(i,k+1)* (s(i,k)-shat(i,k+1)))/ &
+                         dp(i,k) - rl/cp*du(i,k)*(beta*ql(i,k)+ (1-beta)*ql(i,k+1))
+!          dqmdt(i,k)=(mc(i,k)*(qhat(i,k)-q(i,k))
+!     1                +mc(i,k+1)*(q(i,k)-qhat(i,k+1)))/dp(i,k)
+!     2                +du(i,k)*(qs(i,k)-q(i,k))
+!     3                +du(i,k)*(beta*ql(i,k)+(1-beta)*ql(i,k+1))
+
+            dqmdt(i,k) = (mu(i,k+1)* (qu(i,k+1)-qhat(i,k+1)+cp/rl* (su(i,k+1)-s(i,k)))- &
+                          mu(i,k)* (qu(i,k)-qhat(i,k)+cp/rl*(su(i,k)-s(i,k)))+md(i,k+1)* &
+                         (qd(i,k+1)-qhat(i,k+1)+cp/rl*(sd(i,k+1)-s(i,k)))-md(i,k)* &
+                         (qd(i,k)-qhat(i,k)+cp/rl*(sd(i,k)-s(i,k))))/dp(i,k) + &
+                          du(i,k)* (beta*ql(i,k)+(1-beta)*ql(i,k+1))
+         end if
+      end do
+   end do
+!
+   do k = msg + 1,pver
+      do i = il1g,il2g
+         if (k >= lel(i) .and. k <= lcl(i)) then
+            thetavp(i,k) = tp(i,k)* (1000._r8/p(i,k))** (rd/cp)*(1._r8+1.608_r8*qstp(i,k)-q(i,mx(i)))
+            thetavm(i,k) = t(i,k)* (1000._r8/p(i,k))** (rd/cp)*(1._r8+0.608_r8*q(i,k))
+            dqsdtp(i,k) = qstp(i,k)* (1._r8+qstp(i,k)/eps1)*eps1*rl/(rd*tp(i,k)**2)
+!
+! dtpdt is the parcel temperature change due to change of
+! subcloud layer properties during convection.
+!
+            dtpdt(i,k) = tp(i,k)/ (1._r8+rl/cp* (dqsdtp(i,k)-qstp(i,k)/tp(i,k)))* &
+                        (dtbdt(i)/t(i,mx(i))+rl/cp* (dqbdt(i)/tl(i)-q(i,mx(i))/ &
+                         tl(i)**2*dtldt(i)))
+!
+! dboydt is the integrand of cape change.
+!
+            dboydt(i,k) = ((dtpdt(i,k)/tp(i,k)+1._r8/(1._r8+1.608_r8*qstp(i,k)-q(i,mx(i)))* &
+                          (1.608_r8 * dqsdtp(i,k) * dtpdt(i,k) -dqbdt(i))) - (dtmdt(i,k)/t(i,k)+0.608_r8/ &
+                          (1._r8+0.608_r8*q(i,k))*dqmdt(i,k)))*grav*thetavp(i,k)/thetavm(i,k)
+         end if
+      end do
+   end do
+!
+   do k = msg + 1,pver
+      do i = il1g,il2g
+         if (k > lcl(i) .and. k < mx(i)) then
+            thetavp(i,k) = tp(i,k)* (1000._r8/p(i,k))** (rd/cp)*(1._r8+0.608_r8*q(i,mx(i)))
+            thetavm(i,k) = t(i,k)* (1000._r8/p(i,k))** (rd/cp)*(1._r8+0.608_r8*q(i,k))
+!
+! dboydt is the integrand of cape change.
+!
+            dboydt(i,k) = (dtbdt(i)/t(i,mx(i))+0.608_r8/ (1._r8+0.608_r8*q(i,mx(i)))*dqbdt(i)- &
+                          dtmdt(i,k)/t(i,k)-0.608_r8/ (1._r8+0.608_r8*q(i,k))*dqmdt(i,k))* &
+                          grav*thetavp(i,k)/thetavm(i,k)
+         end if
+      end do
+   end do
+
+!
+! buoyant energy change is set to 2/3*excess cape per 3 hours
+!
+   dadt(il1g:il2g)  = 0._r8
+   kmin = minval(lel(il1g:il2g))
+   kmax = maxval(mx(il1g:il2g)) - 1
+   do k = kmin, kmax
+      do i = il1g,il2g
+         if ( k >= lel(i) .and. k <= mx(i) - 1) then
+            dadt(i) = dadt(i) + dboydt(i,k)* (zf(i,k)-zf(i,k+1))
+         endif
+      end do
+   end do
+   do i = il1g,il2g
+      dltaa = -1._r8* (cape(i)-capelmt)
+      if (dadt(i) /= 0._r8) mb(i) = max(dltaa/tau/dadt(i),0._r8)
+   end do
+!
+   return
+end subroutine closure
+
+subroutine q1q2_pjr(lchnk   , &
+                    dqdt    ,dsdt    ,q       ,qs      ,qu      , &
+                    su      ,du      ,qhat    ,shat    ,dp      , &
+                    mu      ,md      ,sd      ,qd      ,ql      , &
+                    dsubcld ,jt      ,mx      ,il1g    ,il2g    , &
+                    cp      ,rl      ,msg     ,          &
+                    dl      ,evp     ,cu      )
+
+
+   implicit none
+
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! <Say what the routine does> 
+! 
+! Method: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! Author: phil rasch dec 19 1995
+! 
+!-----------------------------------------------------------------------
+
+
+   real(r8), intent(in) :: cp
+
+   integer, intent(in) :: lchnk             ! chunk identifier
+   integer, intent(in) :: il1g
+   integer, intent(in) :: il2g
+   integer, intent(in) :: msg
+
+   real(r8), intent(in) :: q(pcols,pver)
+   real(r8), intent(in) :: qs(pcols,pver)
+   real(r8), intent(in) :: qu(pcols,pver)
+   real(r8), intent(in) :: su(pcols,pver)
+   real(r8), intent(in) :: du(pcols,pver)
+   real(r8), intent(in) :: qhat(pcols,pver)
+   real(r8), intent(in) :: shat(pcols,pver)
+   real(r8), intent(in) :: dp(pcols,pver)
+   real(r8), intent(in) :: mu(pcols,pver)
+   real(r8), intent(in) :: md(pcols,pver)
+   real(r8), intent(in) :: sd(pcols,pver)
+   real(r8), intent(in) :: qd(pcols,pver)
+   real(r8), intent(in) :: ql(pcols,pver)
+   real(r8), intent(in) :: evp(pcols,pver)
+   real(r8), intent(in) :: cu(pcols,pver)
+   real(r8), intent(in) :: dsubcld(pcols)
+
+   real(r8),intent(out) :: dqdt(pcols,pver),dsdt(pcols,pver)
+   real(r8),intent(out) :: dl(pcols,pver)
+   integer kbm
+   integer ktm
+   integer jt(pcols)
+   integer mx(pcols)
+!
+! work fields:
+!
+   integer i
+   integer k
+
+   real(r8) emc
+   real(r8) rl
+!-------------------------------------------------------------------
+   do k = msg + 1,pver
+      do i = il1g,il2g
+         dsdt(i,k) = 0._r8
+         dqdt(i,k) = 0._r8
+         dl(i,k) = 0._r8
+      end do
+   end do
+!
+! find the highest level top and bottom levels of convection
+!
+   ktm = pver
+   kbm = pver
+   do i = il1g, il2g
+      ktm = min(ktm,jt(i))
+      kbm = min(kbm,mx(i))
+   end do
+
+   do k = ktm,pver-1
+      do i = il1g,il2g
+         emc = -cu (i,k)               &         ! condensation in updraft
+               +evp(i,k)                         ! evaporating rain in downdraft
+
+         dsdt(i,k) = -rl/cp*emc &
+                     + (+mu(i,k+1)* (su(i,k+1)-shat(i,k+1)) &
+                        -mu(i,k)*   (su(i,k)-shat(i,k)) &
+                        +md(i,k+1)* (sd(i,k+1)-shat(i,k+1)) &
+                        -md(i,k)*   (sd(i,k)-shat(i,k)) &
+                       )/dp(i,k)
+
+         dqdt(i,k) = emc + &
+                    (+mu(i,k+1)* (qu(i,k+1)-qhat(i,k+1)) &
+                     -mu(i,k)*   (qu(i,k)-qhat(i,k)) &
+                     +md(i,k+1)* (qd(i,k+1)-qhat(i,k+1)) &
+                     -md(i,k)*   (qd(i,k)-qhat(i,k)) &
+                    )/dp(i,k)
+
+         dl(i,k) = du(i,k)*ql(i,k+1)
+
+      end do
+   end do
+
+!
+!DIR$ NOINTERCHANGE!
+   do k = kbm,pver
+      do i = il1g,il2g
+         if (k == mx(i)) then
+            dsdt(i,k) = (1._r8/dsubcld(i))* &
+                        (-mu(i,k)* (su(i,k)-shat(i,k)) &
+                         -md(i,k)* (sd(i,k)-shat(i,k)) &
+                        )
+            dqdt(i,k) = (1._r8/dsubcld(i))* &
+                        (-mu(i,k)*(qu(i,k)-qhat(i,k)) &
+                         -md(i,k)*(qd(i,k)-qhat(i,k)) &
+                        )
+         else if (k > mx(i)) then
+            dsdt(i,k) = dsdt(i,k-1)
+            dqdt(i,k) = dqdt(i,k-1)
+         end if
+      end do
+   end do
+!
+   return
+end subroutine q1q2_pjr
+
+subroutine buoyan_dilute(lchnk   ,ncol    , &
+                  q       ,t       ,p       ,z       ,pf      , &
+                  tp      ,qstp    ,tl      ,rl      ,cape    , &
+                  pblt    ,lcl     ,lel     ,lon     ,mx      , &
+                  rd      ,grav    ,cp      ,msg     , &
+                  tpert   )
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! Calculates CAPE the lifting condensation level and the convective top
+! where buoyancy is first -ve.
+! 
+! Method: Calculates the parcel temperature based on a simple constant
+! entraining plume model. CAPE is integrated from buoyancy.
+! 09/09/04 - Simplest approach using an assumed entrainment rate for 
+!            testing (dmpdp). 
+! 08/04/05 - Swap to convert dmpdz to dmpdp  
+!
+! SCAM Logical Switches - DILUTE:RBN - Now Disabled 
+! ---------------------
+! switch(1) = .T. - Uses the dilute parcel calculation to obtain tendencies.
+! switch(2) = .T. - Includes entropy/q changes due to condensate loss and freezing.
+! switch(3) = .T. - Adds the PBL Tpert for the parcel temperature at all levels.
+! 
+! References:
+! Raymond and Blythe (1992) JAS 
+! 
+! Author:
+! Richard Neale - September 2004
+! 
+!-----------------------------------------------------------------------
+   implicit none
+!-----------------------------------------------------------------------
+!
+! input arguments
+!
+   integer, intent(in) :: lchnk                 ! chunk identifier
+   integer, intent(in) :: ncol                  ! number of atmospheric columns
+
+   real(r8), intent(in) :: q(pcols,pver)        ! spec. humidity
+   real(r8), intent(in) :: t(pcols,pver)        ! temperature
+   real(r8), intent(in) :: p(pcols,pver)        ! pressure
+   real(r8), intent(in) :: z(pcols,pver)        ! height
+   real(r8), intent(in) :: pf(pcols,pver+1)     ! pressure at interfaces
+   real(r8), intent(in) :: pblt(pcols)          ! index of pbl depth
+   real(r8), intent(in) :: tpert(pcols)         ! perturbation temperature by pbl processes
+
+!
+! output arguments
+!
+   real(r8), intent(out) :: tp(pcols,pver)       ! parcel temperature
+   real(r8), intent(out) :: qstp(pcols,pver)     ! saturation mixing ratio of parcel (only above lcl, just q below).
+   real(r8), intent(out) :: tl(pcols)            ! parcel temperature at lcl
+   real(r8), intent(out) :: cape(pcols)          ! convective aval. pot. energy.
+   integer lcl(pcols)        !
+   integer lel(pcols)        !
+   integer lon(pcols)        ! level of onset of deep convection
+   integer mx(pcols)         ! level of max moist static energy
+!
+!--------------------------Local Variables------------------------------
+!
+   real(r8) capeten(pcols,5)     ! provisional value of cape
+   real(r8) tv(pcols,pver)       !
+   real(r8) tpv(pcols,pver)      !
+   real(r8) buoy(pcols,pver)
+
+   real(r8) a1(pcols)
+   real(r8) a2(pcols)
+   real(r8) estp(pcols)
+   real(r8) pl(pcols)
+   real(r8) plexp(pcols)
+   real(r8) hmax(pcols)
+   real(r8) hmn(pcols)
+   real(r8) y(pcols)
+
+   logical plge600(pcols)
+   integer knt(pcols)
+   integer lelten(pcols,5)
+
+   real(r8) cp
+   real(r8) e
+   real(r8) grav
+
+   integer i
+   integer k
+   integer msg
+   integer n
+
+   real(r8) rd
+   real(r8) rl
+#ifdef PERGRO
+   real(r8) rhd
+#endif
+!
+!-----------------------------------------------------------------------
+!
+   do n = 1,5
+      do i = 1,ncol
+         lelten(i,n) = pver
+         capeten(i,n) = 0._r8
+      end do
+   end do
+!
+   do i = 1,ncol
+      lon(i) = pver
+      knt(i) = 0
+      lel(i) = pver
+      mx(i) = lon(i)
+      cape(i) = 0._r8
+      hmax(i) = 0._r8
+   end do
+
+   tp(:ncol,:) = t(:ncol,:)
+   qstp(:ncol,:) = q(:ncol,:)
+
+!!! RBN - Initialize tv and buoy for output.
+!!! tv=tv : tpv=tpv : qstp=q : buoy=0.
+   tv(:ncol,:) = t(:ncol,:) *(1._r8+1.608_r8*q(:ncol,:))/ (1._r8+q(:ncol,:))
+   tpv(:ncol,:) = tv(:ncol,:)
+   buoy(:ncol,:) = 0._r8
+
+!
+! set "launching" level(mx) to be at maximum moist static energy.
+! search for this level stops at planetary boundary layer top.
+!
+#ifdef PERGRO
+   do k = pver,msg + 1,-1
+      do i = 1,ncol
+         hmn(i) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k)
+!
+! Reset max moist static energy level when relative difference exceeds 1.e-4
+!
+         rhd = (hmn(i) - hmax(i))/(hmn(i) + hmax(i))
+         if (k >= nint(pblt(i)) .and. k <= lon(i) .and. rhd > -1.e-4_r8) then
+            hmax(i) = hmn(i)
+            mx(i) = k
+         end if
+      end do
+   end do
+#else
+   do k = pver,msg + 1,-1
+      do i = 1,ncol
+         hmn(i) = cp*t(i,k) + grav*z(i,k) + rl*q(i,k)
+         if (k >= nint(pblt(i)) .and. k <= lon(i) .and. hmn(i) > hmax(i)) then
+            hmax(i) = hmn(i)
+            mx(i) = k
+         end if
+      end do
+   end do
+#endif
+
+! LCL dilute calculation - initialize to mx(i)
+! Determine lcl in parcel_dilute and get pl,tl after parcel_dilute
+! Original code actually sets LCL as level above wher condensate forms.
+! Therefore in parcel_dilute lcl(i) will be at first level where qsmix < qtmix.
+
+   do i = 1,ncol ! Initialise LCL variables.
+      lcl(i) = mx(i)
+      tl(i) = t(i,mx(i))
+      pl(i) = p(i,mx(i))
+   end do
+
+!
+! main buoyancy calculation.
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!! DILUTE PLUME CALCULATION USING ENTRAINING PLUME !!!
+!!!   RBN 9/9/04   !!!
+
+   call parcel_dilute(lchnk, ncol, msg, mx, p, t, q, tpert, tp, tpv, qstp, pl, tl, lcl)
+
+
+! If lcl is above the nominal level of non-divergence (600 mbs),
+! no deep convection is permitted (ensuing calculations
+! skipped and cape retains initialized value of zero).
+!
+   do i = 1,ncol
+      plge600(i) = pl(i).ge.600._r8 ! Just change to always allow buoy calculation.
+   end do
+
+!
+! Main buoyancy calculation.
+!
+   do k = pver,msg + 1,-1
+      do i=1,ncol
+         if (k <= mx(i) .and. plge600(i)) then   ! Define buoy from launch level to cloud top.
+            tv(i,k) = t(i,k)* (1._r8+1.608_r8*q(i,k))/ (1._r8+q(i,k))
+            buoy(i,k) = tpv(i,k) - tv(i,k) + tiedke_add  ! +0.5K or not?
+         else
+            qstp(i,k) = q(i,k)
+            tp(i,k)   = t(i,k)            
+            tpv(i,k)  = tv(i,k)
+         endif
+      end do
+   end do
+
+
+
+!-------------------------------------------------------------------------------
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+
+!
+   do k = msg + 2,pver
+      do i = 1,ncol
+         if (k < lcl(i) .and. plge600(i)) then
+            if (buoy(i,k+1) > 0. .and. buoy(i,k) <= 0._r8) then
+               knt(i) = min(5,knt(i) + 1)
+               lelten(i,knt(i)) = k
+            end if
+         end if
+      end do
+   end do
+!
+! calculate convective available potential energy (cape).
+!
+   do n = 1,5
+      do k = msg + 1,pver
+         do i = 1,ncol
+            if (plge600(i) .and. k <= mx(i) .and. k > lelten(i,n)) then
+               capeten(i,n) = capeten(i,n) + rd*buoy(i,k)*log(pf(i,k+1)/pf(i,k))
+            end if
+         end do
+      end do
+   end do
+!
+! find maximum cape from all possible tentative capes from
+! one sounding,
+! and use it as the final cape, april 26, 1995
+!
+   do n = 1,5
+      do i = 1,ncol
+         if (capeten(i,n) > cape(i)) then
+            cape(i) = capeten(i,n)
+            lel(i) = lelten(i,n)
+         end if
+      end do
+   end do
+!
+! put lower bound on cape for diagnostic purposes.
+!
+   do i = 1,ncol
+      cape(i) = max(cape(i), 0._r8)
+   end do
+!
+   return
+end subroutine buoyan_dilute
+
+subroutine parcel_dilute (lchnk, ncol, msg, klaunch, p, t, q, tpert, tp, tpv, qstp, pl, tl, lcl)
+
+! Routine  to determine 
+!   1. Tp   - Parcel temperature
+!   2. qstp - Saturated mixing ratio at the parcel temperature.
+
+!--------------------
+implicit none
+!--------------------
+
+integer, intent(in) :: lchnk
+integer, intent(in) :: ncol
+integer, intent(in) :: msg
+
+integer, intent(in), dimension(pcols) :: klaunch(pcols)
+
+real(r8), intent(in), dimension(pcols,pver) :: p
+real(r8), intent(in), dimension(pcols,pver) :: t
+real(r8), intent(in), dimension(pcols,pver) :: q
+real(r8), intent(in), dimension(pcols) :: tpert ! PBL temperature perturbation.
+
+real(r8), intent(inout), dimension(pcols,pver) :: tp    ! Parcel temp.
+real(r8), intent(inout), dimension(pcols,pver) :: qstp  ! Parcel water vapour (sat value above lcl).
+real(r8), intent(inout), dimension(pcols) :: tl         ! Actual temp of LCL.
+real(r8), intent(inout), dimension(pcols) :: pl          ! Actual pressure of LCL. 
+
+integer, intent(inout), dimension(pcols) :: lcl ! Lifting condesation level (first model level with saturation).
+
+real(r8), intent(out), dimension(pcols,pver) :: tpv   ! Define tpv within this routine.
+
+!--------------------
+
+! Have to be careful as s is also dry static energy.
+
+
+! If we are to retain the fact that CAM loops over grid-points in the internal
+! loop then we need to dimension sp,atp,mp,xsh2o with ncol.
+
+
+real(r8) tmix(pcols,pver)        ! Tempertaure of the entraining parcel.
+real(r8) qtmix(pcols,pver)       ! Total water of the entraining parcel.
+real(r8) qsmix(pcols,pver)       ! Saturated mixing ratio at the tmix.
+real(r8) smix(pcols,pver)        ! Entropy of the entraining parcel.
+real(r8) xsh2o(pcols,pver)       ! Precipitate lost from parcel.
+real(r8) ds_xsh2o(pcols,pver)    ! Entropy change due to loss of condensate.
+real(r8) ds_freeze(pcols,pver)   ! Entropy change sue to freezing of precip.
+
+real(r8) mp(pcols)    ! Parcel mass flux.
+real(r8) qtp(pcols)   ! Parcel total water.
+real(r8) sp(pcols)    ! Parcel entropy.
+
+real(r8) sp0(pcols)    ! Parcel launch entropy.
+real(r8) qtp0(pcols)   ! Parcel launch total water.
+real(r8) mp0(pcols)    ! Parcel launch relative mass flux.
+
+real(r8) lwmax      ! Maximum condesate that can be held in cloud before rainout.
+real(r8) dmpdp      ! Parcel fractional mass entrainment rate (/mb).
+!real(r8) dmpdpc     ! In cloud parcel mass entrainment rate (/mb).
+real(r8) dmpdz      ! Parcel fractional mass entrainment rate (/m)
+real(r8) dpdz,dzdp  ! Hydrstatic relation and inverse of.
+real(r8) senv       ! Environmental entropy at each grid point.
+real(r8) qtenv      ! Environmental total water "   "   ".
+real(r8) penv       ! Environmental total pressure "   "   ".
+real(r8) tenv       ! Environmental total temperature "   "   ".
+real(r8) new_s      ! Hold value for entropy after condensation/freezing adjustments.
+real(r8) new_q      ! Hold value for total water after condensation/freezing adjustments.
+real(r8) dp         ! Layer thickness (center to center)
+real(r8) tfguess    ! First guess for entropy inversion - crucial for efficiency!
+real(r8) tscool     ! Super cooled temperature offset (in degC) (eg -35).
+
+real(r8) qxsk, qxskp1        ! LCL excess water (k, k+1)
+real(r8) dsdp, dqtdp, dqxsdp ! LCL s, qt, p gradients (k, k+1)
+real(r8) slcl,qtlcl,qslcl    ! LCL s, qt, qs values.
+
+integer rcall       ! Number of ientropy call for errors recording
+integer nit_lheat     ! Number of iterations for condensation/freezing loop.
+integer i,k,ii   ! Loop counters.
+
+!======================================================================
+!    SUMMARY
+!
+!  9/9/04 - Assumes parcel is initiated from level of maxh (klaunch)
+!           and entrains at each level with a specified entrainment rate.
+!
+! 15/9/04 - Calculates lcl(i) based on k where qsmix is first < qtmix.          
+!
+!======================================================================
+!
+! Set some values that may be changed frequently.
+!
+
+nit_lheat = 2 ! iterations for ds,dq changes from condensation freezing.
+dmpdz=-1.e-3_r8        ! Entrainment rate. (-ve for /m)
+!dmpdpc = 3.e-2_r8   ! In cloud entrainment rate (/mb).
+lwmax = 1.e-3_r8    ! Need to put formula in for this.
+tscool = 0.0_r8   ! Temp at which water loading freezes in the cloud.
+
+qtmix=0._r8
+smix=0._r8
+
+qtenv = 0._r8
+senv = 0._r8
+tenv = 0._r8
+penv = 0._r8
+
+qtp0 = 0._r8
+sp0  = 0._r8
+mp0 = 0._r8
+
+qtp = 0._r8
+sp = 0._r8
+mp = 0._r8
+
+new_q = 0._r8
+new_s = 0._r8
+
+! **** Begin loops ****
+
+do k = pver, msg+1, -1
+   do i=1,ncol 
+
+! Initialize parcel values at launch level.
+
+      if (k == klaunch(i)) then 
+         qtp0(i) = q(i,k)   ! Parcel launch total water (assuming subsaturated) - OK????.
+         sp0(i)  = entropy(t(i,k),p(i,k),qtp0(i))  ! Parcel launch entropy.
+         mp0(i)  = 1._r8       ! Parcel launch relative mass (i.e. 1 parcel stays 1 parcel for dmpdp=0, undilute). 
+         smix(i,k)  = sp0(i)
+         qtmix(i,k) = qtp0(i)
+         tfguess = t(i,k)
+         rcall = 1
+         call ientropy (rcall,i,lchnk,smix(i,k),p(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess)
+      end if
+
+! Entraining levels
+      
+      if (k < klaunch(i)) then 
+
+! Set environmental values for this level.                 
+         
+         dp = (p(i,k)-p(i,k+1)) ! In -ve mb as p decreasing with height - difference between center of layers.
+         qtenv = 0.5_r8*(q(i,k)+q(i,k+1))         ! Total water of environment.
+         tenv  = 0.5_r8*(t(i,k)+t(i,k+1)) 
+         penv  = 0.5_r8*(p(i,k)+p(i,k+1))
+
+         senv  = entropy(tenv,penv,qtenv)  ! Entropy of environment.   
+
+! Determine fractional entrainment rate /pa given value /m.
+
+         dpdz = -(penv*grav)/(rgas*tenv) ! in mb/m since  p in mb.
+         dzdp = 1._r8/dpdz                  ! in m/mb
+         dmpdp = dmpdz*dzdp              ! /mb Fractional entrainment
+
+! Sum entrainment to current level
+! entrains q,s out of intervening dp layers, in which linear variation is assumed
+! so really it entrains the mean of the 2 stored values.
+
+         sp(i)  = sp(i)  - dmpdp*dp*senv 
+         qtp(i) = qtp(i) - dmpdp*dp*qtenv 
+         mp(i)  = mp(i)  - dmpdp*dp
+            
+! Entrain s and qt to next level.
+
+         smix(i,k)  = (sp0(i)  +  sp(i)) / (mp0(i) + mp(i))
+         qtmix(i,k) = (qtp0(i) + qtp(i)) / (mp0(i) + mp(i))
+
+! Invert entropy from s and q to determine T and saturation-capped q of mixture.
+! t(i,k) used as a first guess so that it converges faster.
+
+         tfguess = tmix(i,k+1)
+         rcall = 2
+         call ientropy(rcall,i,lchnk,smix(i,k),p(i,k),qtmix(i,k),tmix(i,k),qsmix(i,k),tfguess)   
+
+!
+! Determine if this is lcl of this column if qsmix <= qtmix.
+! FIRST LEVEL where this happens on ascending.
+
+         if (qsmix(i,k) <= qtmix(i,k) .and. qsmix(i,k+1) > qtmix(i,k+1)) then
+            lcl(i) = k
+            qxsk   = qtmix(i,k) - qsmix(i,k)
+            qxskp1 = qtmix(i,k+1) - qsmix(i,k+1)
+            dqxsdp = (qxsk - qxskp1)/dp
+            pl(i)  = p(i,k+1) - qxskp1/dqxsdp    ! pressure level of actual lcl.
+            dsdp   = (smix(i,k)  - smix(i,k+1))/dp
+            dqtdp  = (qtmix(i,k) - qtmix(i,k+1))/dp
+            slcl   = smix(i,k+1)  +  dsdp* (pl(i)-p(i,k+1))  
+            qtlcl  = qtmix(i,k+1) +  dqtdp*(pl(i)-p(i,k+1))
+
+            tfguess = tmix(i,k)
+            rcall = 3
+            call ientropy (rcall,i,lchnk,slcl,pl(i),qtlcl,tl(i),qslcl,tfguess)
+
+!            write(iulog,*)' '
+!            write(iulog,*)' p',p(i,k+1),pl(i),p(i,lcl(i))
+!            write(iulog,*)' t',tmix(i,k+1),tl(i),tmix(i,lcl(i))
+!            write(iulog,*)' s',smix(i,k+1),slcl,smix(i,lcl(i))
+!            write(iulog,*)'qt',qtmix(i,k+1),qtlcl,qtmix(i,lcl(i))
+!            write(iulog,*)'qs',qsmix(i,k+1),qslcl,qsmix(i,lcl(i))
+
+         endif
+!         
+      end if !  k < klaunch
+
+ 
+   end do ! Levels loop
+end do ! Columns loop
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!END ENTRAINMENT LOOP!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! Could stop now and test with this as it will provide some estimate of buoyancy
+!! without the effects of freezing/condensation taken into account for tmix.
+
+!! So we now have a profile of entropy and total water of the entraining parcel
+!! Varying with height from the launch level klaunch parcel=environment. To the 
+!! top allowed level for the existence of convection.
+
+!! Now we have to adjust these values such that the water held in vaopor is < or 
+!! = to qsmix. Therefore, we assume that the cloud holds a certain amount of
+!! condensate (lwmax) and the rest is rained out (xsh2o). This, obviously 
+!! provides latent heating to the mixed parcel and so this has to be added back 
+!! to it. But does this also increase qsmix as well? Also freezing processes
+ 
+
+xsh2o = 0._r8
+ds_xsh2o = 0._r8
+ds_freeze = 0._r8
+
+!!!!!!!!!!!!!!!!!!!!!!!!!PRECIPITATION/FREEZING LOOP!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! Iterate solution twice for accuracy
+
+
+
+do k = pver, msg+1, -1
+   do i=1,ncol    
+      
+! Initialize variables at k=klaunch
+      
+      if (k == klaunch(i)) then
+
+! Set parcel values at launch level assume no liquid water.            
+
+         tp(i,k)    = tmix(i,k)
+         qstp(i,k)  = q(i,k) 
+         tpv(i,k)   =  (tp(i,k) + tpert(i)) * (1._r8+1.608_r8*qstp(i,k)) / (1._r8+qstp(i,k))
+         
+      end if
+
+      if (k < klaunch(i)) then
+            
+! Initiaite loop if switch(2) = .T. - RBN:DILUTE - TAKEN OUT BUT COULD BE RETURNED LATER.
+
+! Iterate nit_lheat times for s,qt changes.
+
+         do ii=0,nit_lheat-1            
+
+! Rain (xsh2o) is excess condensate, bar LWMAX (Accumulated loss from qtmix).
+
+            xsh2o(i,k) = max (0._r8, qtmix(i,k) - qsmix(i,k) - lwmax)
+
+! Contribution to ds from precip loss of condensate (Accumulated change from smix).(-ve)                     
+                     
+            ds_xsh2o(i,k) = ds_xsh2o(i,k+1) - cpliq * log (tmix(i,k)/tfreez) * max(0._r8,(xsh2o(i,k)-xsh2o(i,k+1)))
+!
+! Entropy of freezing: latice times amount of water involved divided by T.
+!
+ 
+            if (tmix(i,k) <= tfreez+tscool .and. ds_freeze(i,k+1) == 0._r8) then ! One off freezing of condensate. 
+               ds_freeze(i,k) = (latice/tmix(i,k)) * max(0._r8,qtmix(i,k)-qsmix(i,k)-xsh2o(i,k)) ! Gain of LH
+            end if
+            
+            if (tmix(i,k) <= tfreez+tscool .and. ds_freeze(i,k+1) /= 0._r8) then ! Continual freezing of additional condensate.
+               ds_freeze(i,k) = ds_freeze(i,k+1)+(latice/tmix(i,k)) * max(0._r8,(qsmix(i,k+1)-qsmix(i,k)))
+            end if
+            
+! Adjust entropy and accordingly to sum of ds (be careful of signs).
+
+            new_s = smix(i,k) + ds_xsh2o(i,k) + ds_freeze(i,k) 
+
+! Adjust liquid water and accordingly to xsh2o.
+
+            new_q = qtmix(i,k) - xsh2o(i,k)
+
+! Invert entropy to get updated Tmix and qsmix of parcel.
+
+            tfguess = tmix(i,k)
+            rcall =4
+            call ientropy (rcall,i,lchnk,new_s, p(i,k), new_q, tmix(i,k), qsmix(i,k), tfguess)
+            
+         end do  ! Iteration loop for freezing processes.
+
+! tp  - Parcel temp is temp of mixture.
+! tpv - Parcel v. temp should be density temp with new_q total water. 
+
+         tp(i,k)    = tmix(i,k)
+
+! tpv = tprho in the presence of condensate (i.e. when new_q > qsmix)
+
+         if (new_q > qsmix(i,k)) then  ! Super-saturated so condensate present - reduces buoyancy.
+            qstp(i,k) = qsmix(i,k)
+         else                          ! Just saturated/sub-saturated - no condensate virtual effects.
+            qstp(i,k) = new_q
+         end if
+
+         tpv(i,k) = (tp(i,k)+tpert(i))* (1._r8+1.608_r8*qstp(i,k)) / (1._r8+ new_q) 
+
+      end if ! k < klaunch
+      
+   end do ! Loop for columns
+   
+end do  ! Loop for vertical levels.
+
+
+return
+end subroutine parcel_dilute
+
+!-----------------------------------------------------------------------------------------
+real(r8) function entropy(TK,p,qtot)
+!-----------------------------------------------------------------------------------------
+!
+! TK(K),p(mb),qtot(kg/kg)
+! from Raymond and Blyth 1992
+!
+     real(r8), intent(in) :: p,qtot,TK
+     real(r8) :: qv,qsat,e,esat,L,eref,pref
+
+pref = 1000.0_r8           ! mb
+eref = 6.106_r8            ! sat p at tfreez (mb)
+
+L = rl - (cpliq - cpwv)*(TK-tfreez)         ! T IN CENTIGRADE
+
+! Replace call to satmixutils.
+
+esat = c1*exp(c2*(TK-tfreez)/(c3+TK-tfreez))       ! esat(T) in mb
+qsat=eps1*esat/(p-esat)                      ! Sat. mixing ratio (in kg/kg).
+
+qv = min(qtot,qsat)                         ! Partition qtot into vapor part only.
+e = qv*p / (eps1 +qv)
+
+entropy = (cpres + qtot*cpliq)*log( TK/tfreez) - rgas*log( (p-e)/pref ) + &
+        L*qv/TK - qv*rh2o*log(qv/qsat)
+! 
+return
+end FUNCTION entropy
+
+!
+!-----------------------------------------------------------------------------------------
+   SUBROUTINE ientropy (rcall,icol,lchnk,s,p,qt,T,qsat,Tfg)
+!-----------------------------------------------------------------------------------------
+!
+! p(mb), Tfg/T(K), qt/qv(kg/kg), s(J/kg). 
+! Inverts entropy, pressure and total water qt 
+! for T and saturated vapor mixing ratio
+! 
+#ifndef WRF_PORT
+     use phys_grid, only: get_rlon_p, get_rlat_p
+#endif
+
+     integer, intent(in) :: icol, lchnk, rcall
+     real(r8), intent(in)  :: s, p, Tfg, qt
+     real(r8), intent(out) :: qsat, T
+     real(r8) :: qv,Ts,dTs,fs1,fs2,esat     
+     real(r8) :: pref,eref,L,e
+     real(r8) :: this_lat,this_lon
+     integer :: LOOPMAX,i
+
+LOOPMAX = 100                   !* max number of iteration loops 
+
+! Values for entropy
+pref = 1000.0_r8           ! mb ref pressure.
+eref = 6.106_r8           ! sat p at tfreez (mb)
+
+! Invert the entropy equation -- use Newton's method
+
+Ts = Tfg                  ! Better first guess based on Tprofile from conv.
+
+converge: do i=0, LOOPMAX
+
+   L = rl - (cpliq - cpwv)*(Ts-tfreez) 
+
+   esat = c1*exp(c2*(Ts-tfreez)/(c3+Ts-tfreez)) ! Bolton (eq. 10)
+   qsat = eps1*esat/(p-esat)     
+   qv = min(qt,qsat) 
+   e = qv*p / (eps1 +qv)  ! Bolton (eq. 16)
+   fs1 = (cpres + qt*cpliq)*log( Ts/tfreez ) - rgas*log( (p-e)/pref ) + &
+        L*qv/Ts - qv*rh2o*log(qv/qsat) - s
+   
+   L = rl - (cpliq - cpwv)*(Ts-1._r8-tfreez)         
+
+   esat = c1*exp(c2*(Ts-1._r8-tfreez)/(c3+Ts-1._r8-tfreez))
+   qsat = eps1*esat/(p-esat)  
+   qv = min(qt,qsat) 
+   e = qv*p / (eps1 +qv)
+   fs2 = (cpres + qt*cpliq)*log( (Ts-1._r8)/tfreez ) - rgas*log( (p-e)/pref ) + &
+        L*qv/(Ts-1._r8) - qv*rh2o*log(qv/qsat) - s 
+   
+   dTs = fs1/(fs2 - fs1)
+   Ts  = Ts+dTs
+   if (abs(dTs).lt.0.001_r8) exit converge
+   if (i .eq. LOOPMAX - 1) then
+#ifndef WRF_PORT
+      this_lat = get_rlat_p(lchnk, icol)*57.296_r8
+      this_lon = get_rlon_p(lchnk, icol)*57.296_r8
+#else
+!Do not worry about the specific lat/lon in WRF
+      this_lat = 0.
+      this_lon = 0.
+#endif
+      write(iulog,*) '*** ZM_CONV: IENTROPY: Failed and about to exit, info follows ****'
+#ifdef WRF_PORT
+      call wrf_message(iulog)
+#endif
+      write(iulog,100) 'ZM_CONV: IENTROPY. Details: call#,lchnk,icol= ',rcall,lchnk,icol, &
+       ' lat: ',this_lat,' lon: ',this_lon, &
+       ' P(mb)= ', p, ' Tfg(K)= ', Tfg, ' qt(g/kg) = ', 1000._r8*qt, &
+       ' qsat(g/kg) = ', 1000._r8*qsat,', s(J/kg) = ',s
+#ifdef WRF_PORT
+      call wrf_message(iulog)
+#endif
+      call endrun('**** ZM_CONV IENTROPY: Tmix did not converge ****')
+   end if
+enddo converge
+
+! Replace call to satmixutils.
+
+esat = c1*exp(c2*(Ts-tfreez)/(c3+Ts-tfreez))
+qsat=eps1*esat/(p-esat)
+
+qv = min(qt,qsat)                             !       /* check for saturation */
+T = Ts 
+
+ 100    format (A,I1,I4,I4,7(A,F6.2))
+
+return
+end SUBROUTINE ientropy
+
+end module module_cu_camzm
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_camzm_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_camzm_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_camzm_driver.F	(revision 17)
@@ -0,0 +1,819 @@
+MODULE module_cu_camzm_driver
+
+!Roughly based on zm_conv_intr.F90 from CAM
+
+  USE module_cam_support, only: pcnst, pcols, pver, pverp
+
+  IMPLICIT NONE
+
+  PRIVATE                  !Default to private
+  PUBLIC :: &              !Public entities
+       camzm_driver, &
+       zm_conv_init
+
+CONTAINS
+
+!------------------------------------------------------------------------
+SUBROUTINE camzm_driver(                                      &
+              ids,ide, jds,jde, kds,kde                       &
+             ,ims,ime, jms,jme, kms,kme                       &
+             ,its,ite, jts,jte, kts,kte                       &
+             ,itimestep, bl_pbl_physics, sf_sfclay_physics    &
+             ,th, t_phy, tsk, tke_pbl, ust, qv, qc, qi        &
+             ,mavail, kpbl, pblh, xland, z                    &
+             ,z_at_w, dz8w, ht, p, p8w, pi_phy, psfc          &
+             ,u_phy, v_phy, hfx, qfx, cldfra                  &
+             ,tpert_camuwpbl                                  &
+             ,dx, dt, stepcu, cudt, curr_secs, adapt_step_flag&
+             ,cape_out, mu_out, md_out, zmdt, zmdq            &
+             ,rliq_out, dlf_out                               &
+             ,pconvb, pconvt, cubot, cutop, raincv, pratec    &
+             ,rucuten, rvcuten                                &
+             ,rthcuten, rqvcuten, rqccuten, rqicuten          &
+             ,evaptzm, fzsntzm, evsntzm, evapqzm, zmflxprc    &
+             ,zmflxsnw, zmntprpd, zmntsnpd, zmeiheat          &
+             ,cmfmc, cmfmcdzm, preccdzm, precz                &
+             ,zmmtu, zmmtv, zmupgu, zmupgd, zmvpgu, zmvpgd    &
+             ,zmicuu, zmicud, zmicvu, zmicvd                  &
+             ,zmdice, zmdliq                                  &
+                                                              )
+! This routine is based on zm_conv_tend in CAM. It handles the mapping of
+! variables from the WRF to the CAM framework for the Zhang-McFarlane
+! convective parameterization.
+!
+! Author: William.Gustafson@pnl.gov, Nov. 2009
+! Last modified: William.Gustafson@pnl.gov, Nov. 2010
+!------------------------------------------------------------------------
+  USE shr_kind_mod,    only: r8 => shr_kind_r8
+  USE physconst, only: cpair, gravit
+  USE module_cu_camzm, only: convtran, momtran, zm_conv_evap, zm_convr
+
+! Subroutine arguments...
+  INTEGER, INTENT(IN   ) ::    ids,ide, jds,jde, kds,kde,  &
+                               ims,ime, jms,jme, kms,kme,  &
+                               its,ite, jts,jte, kts,kte,  &
+                     bl_pbl_physics, & !pbl scheme
+                          itimestep, & !time step index
+                  sf_sfclay_physics, & !surface layer scheme
+                             stepcu    !number of time steps between Cu calls
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: &
+                             cldfra, & !cloud fraction
+                               dz8w, & !height between interfaces (m)
+                                  p, & !pressure at mid-level (Pa)
+                                p8w, & !pressure at level interface (Pa)
+                             pi_phy, & !exner function, (p0/p)^(R/cpair) (none)
+                                 qv, & !water vapor mixing ratio (kg/kg-dry air)
+                                 th, & !potential temperature (K)
+                            tke_pbl, & !turbulent kinetic energy from PBL (m2/s2)
+                              t_phy, & !temperature (K)
+                              u_phy, & !zonal wind component on T points (m/s)
+                              v_phy, & !meridional wind component on T points (m/s)
+                                  z, & !height above sea level at mid-level (m)
+                             z_at_w    !height above sea level at interface (m)
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN), OPTIONAL :: &
+                                 qc, & !cloud droplet mixing ratio (kg/kg-dry air)
+                                 qi    !cloud ice crystal mixing ratio (kg/kg-dry air)
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: &
+                            dlf_out, & !detraining cloud water tendendcy
+                            evaptzm, & !temp. tendency - evap/snow prod from ZM (K/s)
+                            fzsntzm, & !temp. tendency - rain to snow conversion from ZM (K/s)
+                            evsntzm, & !temp. tendency - snow to rain conversion from ZM (K/s)
+                            evapqzm, & !spec. humidity tend. - evaporation from ZM (kg/kg/s)
+                           zmflxprc, & !flux of precipitation from ZM (kg/m2/s)
+                           zmflxsnw, & !flux of snow from ZM (kg/m2/s)
+                           zmntprpd, & !net precipitation production from ZM (kg/kg/s)
+                           zmntsnpd, & !net snow production from ZM (kg/kg/s)
+                           zmeiheat, & !heating by ice and evaporation from ZM (W/kg)
+                              cmfmc, & !convective mass flux--m sub c, deep here but ultimately deep+shallow (kg/m2/s)
+                           cmfmcdzm, & !convection mass flux from ZM deep (kg/m2/s)
+                             md_out, & !output convective downdraft mass flux (kg/m2/s)
+                             mu_out, & !output convective updraft mass flux (kg/m2/s)
+                            rucuten, & !UNcoupled zonal wind tendency due to Cu scheme (m/s2)
+                            rvcuten, & !UNcoupled meridional wind tendency due to Cu scheme (m/s2)
+                           rthcuten, & !UNcoupled potential temperature tendendcy due to cu scheme (K/s)
+                           rqvcuten, & !UNcoupled water vapor mixing ratio tendency due to Cu scheme (kg/kg/s)
+                               zmdt, & !temp. tendency from moist convection (K/s)
+                               zmdq, & !spec. humidity tendency from moist convection (kg/kg/s)
+                              zmmtu, & !U tendency from ZM convective momentum transport (m/s2)
+                              zmmtv, & !V tendency from ZM convective momentum transport (m/s2)
+                             zmupgu, & !zonal force from ZM updraft pressure gradient term (m/s2)
+                             zmupgd, & !zonal force from ZM downdraft pressure gradient term (m/s2)
+                             zmvpgu, & !meridional force from ZM updraft pressure gradient term (m/s2)
+                             zmvpgd, & !meridional force from ZM downdraft pressure gradient term (m/s2)
+                             zmicuu, & !ZM in-cloud U updrafts (m/s)
+                             zmicud, & !ZM in-cloud U downdrafts (m/s)
+                             zmicvu, & !ZM in-cloud V updrafts (m/s)
+                             zmicvd, & !ZM in-cloud V downdrafts (m/s)
+                             zmdice, & !ZM cloud ice tendency (kg/kg/s)
+                             zmdliq    !ZM cloud liquid tendency (kg/kg/s)
+
+  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT), OPTIONAL :: &
+                           rqccuten, & !UNcoupled cloud droplet mixing ratio tendency due to Cu scheme (kg/kg/s)
+                           rqicuten    !UNcoupled ice crystal mixing ratio tendency due to Cu scheme (kg/kg/s)
+
+  REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: &
+                                hfx, & !upward heat flux at sfc (W/m2)
+                                 ht, & !terrain height (m)
+                              xland, & !land/water mask, 1=land, 2=water
+                             mavail, & !soil moisture availability
+                               pblh, & !planetary boundary layer height (m)
+                               psfc, & !surface pressure (Pa)
+                                qfx, & !upward moisture flux at sfc (kg/m2/s)
+                     tpert_camuwpbl, & !temperature perturbation from UW CAM PBL
+                                tsk, & !skin temperature (K)
+                                ust    !u* in similarity theory (m/s)
+
+  REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: &
+                           cape_out, & !convective available potential energy (J/kg)
+                              cubot, & !level number of base of convection
+                              cutop, & !level number of top of convection
+                             pconvb, & !pressure of base of convection (Pa)
+                             pconvt, & !pressure of top of convection (Pa)
+                             pratec, & !rain rate returned to WRF for accumulation (mm/s)
+                           preccdzm, & !convection precipitation rate from ZM deep (m/s)
+                              precz, & !total precipitation rate from ZM (m/s)
+                             raincv, & !time-step convective rain amount (mm)
+                           rliq_out    !vertical integral of reserved cloud water
+
+  REAL, INTENT(IN) :: &
+                               cudt, & !cumulus time step (min)
+                          curr_secs, & !current forecast time (s)
+                                 dt, & !domain time step (s)
+                                 dx    !grid spacing (m)
+
+  INTEGER, DIMENSION( ims:ime, jms:jme), INTENT(IN) :: &
+                               kpbl    !index of PBL level
+
+  LOGICAL, INTENT(IN) :: &
+                    adapt_step_flag    !using adaptive time steps?
+
+! Local variables...
+  !Variables dimensioned for input to ZM routines
+  REAL(r8), DIMENSION(pcols, kte+1) ::  &
+                               mcon, & !convective mass flux--m sub c (sub arg out in CAM)
+                               pflx, & !scattered precip flux at each level (sub arg out in CAM)
+                              pint8, & !pressure at layer interface (Pa)
+                                zi8    !height above sea level at mid-level (m)
+
+  REAL(r8), DIMENSION(pcols, kte, pcnst) ::  &
+                                qh8    !specific humidity (kg/kg-moist air)
+
+  REAL(r8), DIMENSION(pcols, kte, 3) ::  &
+                              cloud, & !holder for cloud water and ice (q in CAM)
+                           cloudtnd, & !holder for cloud tendencies (ptend_loc%q in CAM)
+                             fracis    !fraction of cloud species that are insoluble
+
+  REAL(r8), DIMENSION(pcols, kte, 2) ::  &
+                               icwu, & !in-cloud winds in upraft (m/s)
+                               icwd, & !in-cloud winds in downdraft (m/s)
+                             pguall, & !apparent force from updraft pres. gradient (~units?)
+                             pgdall, & !apparent force from downdraft pres. gradient (~units?)
+                              winds, & !wind components (m/s)
+                         wind_tends    !wind component tendencies (m/s2)
+
+  REAL(r8), DIMENSION(pcols, kte) ::  &
+                               cld8, & !cloud fraction
+                                cme, & !cmf condensation - evaporation (~units?, sub arg out in CAM)
+                                dlf, & !scattered version of the detraining cld h2o tendency (~units?)
+                         fake_dpdry, & !place holder for dpdry, delta pres. of dry atmos.
+                            flxprec, & !evap outfld: convective-scale flux of precip at interfaces (kg/m2/s)
+                            flxsnow, & !evap outfld: convective-scale flux of snow at interfaces (kg/m2/s)
+                            ntprprd, & !evap outfld: net precip production in layer (kg/kg/s)
+                            ntsnprd, & !evap outfld: net snow production in layer (kg/kg/s)
+                              pdel8, & !pressure thickness of layer (between interfaces, Pa)
+                              pmid8, & !pressure at layer middle (Pa)
+                                ql8, & !cloud liquid water (~units?)
+                                qi8, & !cloud ice (~units?)
+                                 t8, & !temperature (K)
+                                zm8, & !height above ground at mid-level (m)
+                               qtnd, & !specific humidity tendency (kg/kg/s)
+                               rprd, & !rain production rate (kg/kg/s, comes from pbuf array in CAM, add to restart?~)
+                               stnd, & !heating rate (dry static energy tendency, W/kg)
+                      tend_s_snwprd, & !heating rate of snow production (~units?)
+                    tend_s_snwevmlt, & !heating rate of evap/melting of snow (~units?)
+                                zdu    !detraining mass flux (~units? sub arg out in CAM)
+
+  REAL(r8), DIMENSION(pcols) ::  &
+                               cape, & !convective available potential energy (J/kg)
+                              jctop, & !row of top-of-deep-convection indices passed out (sub arg out in CAM)
+                              jcbot, & !row of base of cloud indices passed out (sub arg out in CAM)
+                           landfrac, & !land fraction
+                              pblh8, & !planetary boundary layer height (m)
+                               phis, & !geopotential at terrain height (m2/s2)
+                               prec, & !convective-scale precipitation rate from ZM (m/s)
+                               rliq, & !reserved liquid (not yet in cldliq) for energy integrals (units? sub arg out in CAM)
+                               snow, & !convective-scale snowfall rate from ZM (m/s)
+                              tpert    !thermal (convective) temperature excess (K)
+
+  !Variables that were declared at the module level of zm_conv_intr in
+  !CAM. In that context they needed to be held between calls to
+  !zm_conv_tend and zm_conv_tend2 at the chunk level. In WRF, these vars
+  !are setup to hold the whole "memory" dimension, but as a 1-D vector
+  !instead of a 2-D array as is typically done in WRF. This allows us to
+  !leave the CAM routines in tact. For now, this forces us to immediately
+  !call zm_conv_tend2 before leaving this module, but it allows us to
+  !follow the WRF rules. We can deal with generalizing this for handling
+  !tracer convective transport of aerosols later.~
+  REAL(r8), DIMENSION(pcols, kte, (ime-ims+1)*(jme-jms+1)) :: &
+                                 dp, & !layer pres. thickness between interfaces (mb)
+                                 du, &
+                                 ed, &
+                                 eu, &
+                                 md, &
+                                 mu
+
+  REAL(r8), DIMENSION(pcols, (ime-ims+1)*(jme-jms+1)) :: &
+                            dsubcld    ! layer pres. thickness between LCL and maxi (mb)
+
+  INTEGER, DIMENSION(pcols, (ime-ims+1)*(jme-jms+1)) :: &
+                              ideep, & ! holds position of gathered points
+                                 jt, & ! top-level index of deep cumulus convection
+                               maxg    ! gathered values of maxi
+                               
+  INTEGER, DIMENSION((ime-ims+1)*(jme-jms+1)) :: &
+                            lengath    ! number of gathered points
+
+  !Other local vars
+  INTEGER :: i, j, k, kflip, n, ncnst
+  INTEGER :: lchnk         !chunk identifier, used to map 2-D to 1-D arrays in WRF
+  INTEGER :: ncol          !number of atmospheric columns in chunk
+  LOGICAL, DIMENSION(3) :: l_qt    !logical switches for constituent tendency presence
+  LOGICAL, DIMENSION(2) :: l_windt !logical switches for wind tendency presence
+  LOGICAL :: run_param     !flag for handling alternate cumulus call freq.
+!
+! Check to see if this is a convection timestep...
+!
+  if (adapt_step_flag) then
+     if ( (itimestep==0) .or. (cudt<=0) .or. &
+          ( curr_secs+dt >= ( int(curr_secs/( cudt*60 )) + 1 )*cudt*60 ) ) then
+        run_param = .TRUE.
+     else
+        run_param = .FALSE.
+     endif
+
+  else
+     if (mod(itimestep,stepcu)==0 .or. itimestep==0) then
+        run_param = .TRUE.
+     else
+        run_param = .FALSE.
+     endif
+  endif
+
+  !Leave the subroutine if it is not yet time to call the cumulus param
+  if( .not. run_param ) return
+!
+! Initialize...
+!
+  ncol  = 1          !chunk size in WRF is 1 since we loop over all columns in a tile
+
+  cape_out(its:ite, jts:jte)        = 0.
+  mu_out(its:ite, kts:kte, jts:jte) = 0.
+  md_out(its:ite, kts:kte, jts:jte) = 0.
+  zmdt(its:ite, kts:kte, jts:jte)   = 0.
+!
+! Map variables to inputs for zm_convr and call it...
+! Loop over the points in the tile and treat them each as a CAM chunk.
+!
+  do j = jts,jte
+     do i = its,ite
+        lchnk = (j-jts)*(ite-its+1) + (i-its+1) !1-D index location from the 2-D tile
+
+        !Flip variables on the layer middles
+        do k = kts,kte
+           kflip = kte-k+1
+
+           cld8(1,kflip)  = cldfra(i,k,j)
+           pdel8(1,kflip) = p8w(i,k,j) - p8w(i,k+1,j)
+           pmid8(1,kflip) = p(i,k,j)
+           qh8(1,kflip,1) = max( qv(i,k,j)/(1.+qv(i,k,j)), 1e-30 ) !values of 0 cause a crash in entropy
+           if( present(qc) ) then
+              ql8(1,kflip) = qc(i,k,j)/(1.+qv(i,k,j)) !Convert to moist mix ratio
+           else
+              ql8(1,kflip) = 0.
+           end if
+           if( present(qi) ) then
+              qi8(1,kflip) = qi(i,k,j)/(1.+qv(i,k,j)) !Used in convtran, ditto for conversion
+           else
+              qi8(1,kflip) = 0.
+           end if
+           t8(1,kflip)    = t_phy(i,k,j)
+           zm8(1,kflip)   = z(i,k,j) - ht(i,j) !Height above the ground at midlevels
+        end do
+
+        !Flip variables on the layer interfaces
+        do k = kts,kte+1
+           kflip = kte-k+2
+
+           pint8(1,kflip) = p8w(i,k,j)
+           zi8(1,kflip)   = z_at_w(i,k,j) -ht(i,j) !Height above the ground at interfaces
+        end do
+
+        !Other necessary conversions for input to ZM
+        if( xland(i,j)==2 ) then
+           landfrac(1) = 1. !land, WRF is all or nothing
+        else
+           landfrac(1) = 0. !water
+        end if
+        pblh8(1) = pblh(i,j)
+        phis(1)  = ht(i,j)*gravit
+
+        call get_tpert(bl_pbl_physics, sf_sfclay_physics, dx, &
+             mavail(i,j), kpbl(i,j), pblh(i,j), &
+             dz8w(i,1,j), psfc(i,j), qv(i,1,j), t_phy(i,1,j), &
+             th(i,1,j), tsk(i,j), tke_pbl(i,:,j), ust(i,j), &
+             u_phy(i,1,j), v_phy(i,1,j), hfx(i,j), qfx(i,j), &
+             tpert_camuwpbl(i,j), kte, &
+             tpert(1))
+
+        !Call the Zhang-McFarlane (1996) convection parameterization
+        !NOTE: The 0.5*dt is correct and is a nuance of CAM typically
+        !      using 2*dt for physics tendencies. Everywhere in zm_convr
+        !      that dt is used, the dt is multiplied by 2 to get back to
+        !      the 2*dt. Everywhere else in the CAM ZM interface the full
+        !      2*dt is passed into the subroutines. In WRF we use 1*dt
+        !      in place of CAM's 2*dt since the adjustment is made
+        !      elsewhere.
+        call zm_convr( lchnk, ncol, &
+             t8, qh8, prec, jctop, jcbot, &
+             pblh8, zm8, phis, zi8, qtnd, &
+             stnd, pmid8, pint8, pdel8, &
+             0.5_r8*real(dt,r8), mcon, cme, cape, &
+             tpert, dlf, pflx, zdu, rprd, &
+             mu(:,:,lchnk), md(:,:,lchnk),du(:,:,lchnk),eu(:,:,lchnk),ed(:,:,lchnk), &
+             dp(:,:,lchnk), dsubcld(:,lchnk), jt(:,lchnk), maxg(:,lchnk), ideep(:,lchnk), &
+             lengath(lchnk), ql8, rliq, landfrac )
+
+        !Start mapping CAM output to WRF output variables. We follow the
+        !same order as in CAM's zm_conv_tend to ease maintenance...
+        do k=kts,kte
+           kflip = kte-k+1
+           dlf_out(i,k,j)  = dlf(1,kflip)
+        end do
+        cape_out(i,j) = cape(1)
+        rliq_out(i,j) = rliq(1)
+
+        !Convert mass flux from reported mb/s to kg/m2/s
+        mcon(:ncol,:pver) = mcon(:ncol,:pver) * 100._r8/gravit
+
+        ! Store upward and downward mass fluxes in un-gathered arrays
+        ! + convert from mb/s to kg/m2/s
+        do n=1,lengath(lchnk)
+           do k=kts,kte
+              kflip = kte-k+1
+!              ii = ideep(n,lchnk) <--in WRF this is always 1 because chunk size=1
+              mu_out(i,k,j) = mu(n,kflip,lchnk) * 100._r8/gravit
+              md_out(i,k,j) = md(n,kflip,lchnk) * 100._r8/gravit
+           end do
+        end do
+
+        do k=kts,kte
+           kflip = kte-k+1
+           zmdt(i,k,j) = stnd(1,kflip)/cpair
+           zmdq(i,k,j) = qtnd(1,kflip)
+        end do
+
+        !Top and bottom pressure of convection
+        pconvt(i,j) = p8w(i,1,j)
+        pconvb(i,j) = p8w(i,1,j)
+        do n = 1,lengath(lchnk)
+           if (maxg(n,lchnk).gt.jt(n,lchnk)) then
+              pconvt(i,j) = pmid8(ideep(n,lchnk),jt(n,lchnk))  ! gathered array (or jctop ungathered)
+              pconvb(i,j) = pmid8(ideep(n,lchnk),maxg(n,lchnk))! gathered array
+           endif
+        end do
+        cutop(i,j) = jctop(1)
+        cubot(i,j) = jcbot(1)
+
+        !Add tendency from this process to tendencies arrays. Also,
+        !increment the local state arrays to reflect additional tendency
+        !from zm_convr, i.e. the physics update call in CAM. Note that
+        !we are not readjusting the pressure levels to hydrostatic
+        !balance for the new virtual temperature like is done in CAM. We
+        !will let WRF take care of such things later for the total
+        !tendency.
+        do k=kts,kte
+           kflip = kte-k+1
+
+           !Convert temperature to potential temperature and
+           !specific humidity to water vapor mixing ratio
+           rthcuten(i,k,j) = zmdt(i,k,j)/pi_phy(i,k,j)
+           rqvcuten(i,k,j) = zmdq(i,k,j)/(1._r8 - zmdq(i,k,j))
+
+           t8(1,kflip)    = t8(1,kflip) + zmdt(i,k,j)*real(dt,r8)
+           qh8(1,kflip,1) = qh8(1,kflip,1) + zmdq(i,k,j)*real(dt,r8)
+        end do
+
+        ! Determine the phase of the precipitation produced and add latent heat of fusion
+        ! Evaporate some of the precip directly into the environment (Sundqvist)
+        ! Allow this to use the updated state1 (t8 and qh8 in WRF) and the fresh ptend_loc type
+        ! heating and specific humidity tendencies produced
+        qtnd = 0._r8 !re-initialize tendencies (i.e. physics_ptend_init(ptend_loc))
+        stnd = 0._r8
+        call zm_conv_evap(ncol, lchnk, &
+             t8, pmid8, pdel8, qh8(:,:,1), &
+             stnd, tend_s_snwprd, tend_s_snwevmlt, qtnd, &
+             rprd, cld8, real(dt,r8), &
+             prec, snow, ntprprd, ntsnprd , flxprec, flxsnow)
+
+        ! Parse output variables from zm_conv_evap
+        do k=kts,kte
+           kflip = kte-k+1
+
+           evaptzm(i,k,j)  = stnd(1,kflip)/cpair
+           fzsntzm(i,k,j)  = tend_s_snwprd(1,kflip)/cpair
+           evsntzm(i,k,j)  = tend_s_snwevmlt(1,kflip)/cpair
+           evapqzm(i,k,j)  = qtnd(1,kflip)
+           zmflxprc(i,k,j) = flxprec(1,kflip)
+           zmflxsnw(i,k,j) = flxsnow(1,kflip)
+           zmntprpd(i,k,j) = ntprprd(1,kflip)
+           zmntsnpd(i,k,j) = ntsnprd(1,kflip)
+           zmeiheat(i,k,j) = stnd(1,kflip) !Do we really need this and evaptzm?
+           cmfmc(i,k,j)    = mcon(1,kflip) !Set to deep value here, shallow added in UW scheme
+           cmfmcdzm(i,k,j) = mcon(1,kflip)
+           preccdzm(i,j)   = prec(1)       !Rain rate from just deep
+           precz(i,j)      = prec(1)       !Rain rate for total convection (just deep right now)
+           pratec(i,j)     = prec(1)*1e3   !Rain rate used in WRF for accumulation (mm/s)
+           raincv(i,j)     = pratec(i,j)*dt !Rain amount for time step returned back to WRF
+        end do
+
+        !Add tendency from zm_conv_evap to tendencies arrays. Also,
+        !increment the local state arrays to reflect additional tendency
+        !Note that we are not readjusting the pressure levels to hydrostatic
+        !balance for the new virtual temperature like is done in CAM. We
+        !will let WRF take care of such things later for the total
+        !tendency.
+        do k=kts,kte
+           kflip = kte-k+1
+
+           !Convert temperature to potential temperature and
+           !specific humidity to water vapor mixing ratio
+           rthcuten(i,k,j) = rthcuten(i,k,j) + &
+                             evaptzm(i,k,j)/pi_phy(i,k,j)
+           rqvcuten(i,k,j) = rqvcuten(i,k,j) + &
+                             evapqzm(i,k,j)/(1. - qv(i,k,j))
+
+           t8(1,kflip)    = t8(1,kflip) + evaptzm(i,k,j)*real(dt,r8)
+           qh8(1,kflip,1) = qh8(1,kflip,1) + evapqzm(i,k,j)*real(dt,r8)
+        end do
+
+        ! Momentum transport
+        stnd       = 0._r8     !Zero relevant tendencies in preparation
+        wind_tends = 0._r8
+        do k=kts,kte
+           kflip = kte-k+1
+           winds(1,k,1) = u_phy(i,kflip,j)
+           winds(1,k,2) = v_phy(i,kflip,j)
+        end do
+        l_windt(1:2) = .true.
+
+        call momtran (lchnk, ncol, &
+             l_windt, winds, 2, mu(:,:,lchnk), md(:,:,lchnk), &
+             du(:,:,lchnk), eu(:,:,lchnk), ed(:,:,lchnk), dp(:,:,lchnk), dsubcld(:,lchnk), &
+             jt(:,lchnk),maxg(:,lchnk), ideep(:,lchnk), 1, lengath(lchnk), &
+             itimestep, wind_tends, pguall, pgdall, icwu, icwd, real(dt,r8), stnd )
+        
+        !Add tendency from momtran to tendencies arrays. Also,
+        !increment the local state arrays to reflect additional tendency
+        !Note that we are not readjusting the pressure levels to hydrostatic
+        !balance for the new virtual temperature like is done in CAM. We
+        !will let WRF take care of such things later for the total
+        !tendency.
+        do k=kts,kte
+           kflip = kte-k+1
+
+           !Convert temperature to potential temperature and
+           !specific humidity to water vapor mixing ratio
+           rucuten(i,k,j)  = wind_tends(1,kflip,1)
+           rvcuten(i,k,j)  = wind_tends(1,kflip,2)
+           rthcuten(i,k,j) = rthcuten(i,k,j) + &
+                                 stnd(1,kflip)/cpair/pi_phy(i,k,j)
+
+           t8(1,kflip) = t8(1,kflip) + stnd(1,kflip)/cpair*real(dt,r8)
+           !winds is not used again so do not bother updating them
+        end do
+
+        !Parse output arrays for momtran
+        do k=kts,kte
+           kflip = kte-k+1
+
+           zmmtu(i,k,j) = wind_tends(1,kflip,1) !wind tendencies...
+           zmmtv(i,k,j) = wind_tends(1,kflip,2)
+
+           zmupgu(i,k,j) = pguall(1,kflip,1)   !apparent force pres. grads...
+           zmupgd(i,k,j) = pgdall(1,kflip,1)
+           zmvpgu(i,k,j) = pguall(1,kflip,2)
+           zmvpgd(i,k,j) = pgdall(1,kflip,2)
+
+           zmicuu(i,k,j) = icwu(1,kflip,1)     !in-cloud winds...
+           zmicud(i,k,j) = icwd(1,kflip,1)
+           zmicvu(i,k,j) = icwu(1,kflip,2)
+           zmicvd(i,k,j) = icwd(1,kflip,2)
+        end do
+
+        !Setup for convective transport of cloud water and ice
+        !~We should set this up to use an integer pointer instead of
+        ! hard-coded numbers for each species so that we can easily
+        ! handle other species. Something to come back to later...
+        l_qt(1)   = .false.     !do not mix water vapor
+        l_qt(2:3) = .true.      !do mix cloud water and ice
+        cloudtnd = 0._r8
+        fracis(1,:,1:3) = 0._r8 !all cloud liquid & ice is soluble
+        ncnst = 3               !number of constituents in cloud array (including vapor)
+        fake_dpdry = 0._r8      !delta pres. for dry atmos. (0 since assuming moist mix ratios)
+        do k=kts,kte
+           kflip = kte-k+1
+
+           cloud(1,kflip,1) = qh8(1,kflip,1)  !We can either use moist mix ratios, as is
+           cloud(1,kflip,2) = ql8(1,kflip)    !done here, or else use dry mix ratios, send
+           cloud(1,kflip,3) = qi8(1,kflip)    !in appropriate dpdry values, and return the
+                                              !approp. response from cnst_get_type_byind
+        end do
+
+        call convtran (lchnk, &
+             l_qt, cloud, ncnst,  mu(:,:,lchnk), md(:,:,lchnk), &
+             du(:,:,lchnk), eu(:,:,lchnk), ed(:,:,lchnk), dp(:,:,lchnk), dsubcld(:,lchnk), &
+             jt(:,lchnk), maxg(:,lchnk), ideep(:,lchnk), 1, lengath(lchnk), &
+             itimestep, fracis, cloudtnd, fake_dpdry)
+
+        !Parse output for convtran and increment tendencies
+        do k=kts,kte
+           kflip = kte-k+1
+
+           zmdice(i,k,j) = cloudtnd(1,kflip,3)
+           zmdliq(i,k,j) = cloudtnd(1,kflip,2)
+
+           !Convert cloud tendencies from wet to dry mix ratios
+           if( present(rqccuten) ) then
+              rqccuten(i,k,j) = cloudtnd(1,kflip,2)/(1. - qv(i,k,j))
+           end if
+           if( present(rqicuten) ) then
+              rqicuten(i,k,j) = cloudtnd(1,kflip,3)/(1. - qv(i,k,j))
+           end if
+        end do
+        
+     end do !i-loop
+  end do    !j-loop
+END SUBROUTINE camzm_driver
+
+
+!------------------------------------------------------------------------
+SUBROUTINE zm_conv_init(rucuten, rvcuten, rthcuten, rqvcuten,           &
+                     rqccuten, rqicuten,                                &
+                     p_qc, p_qi, param_first_scalar,                    &
+                     restart,                                           &
+                     ids, ide, jds, jde, kds, kde,                      &
+                     ims, ime, jms, jme, kms, kme,                      &
+                     its, ite, jts, jte, kts, kte                    )
+! Initialization routine for Zhang-McFarlane cumulus parameterization
+! from CAM. The routine with this name in CAM is revamped here to give
+! the needed functionality within WRF.
+!
+! Author: William.Gustafson@pnl.gov, Nov. 2009
+!------------------------------------------------------------------------
+  USE module_cam_esinti,  only: esinti
+  USE physconst, only: epsilo, latvap, latice, rh2o, cpair, tmelt
+  USE module_bl_camuwpbl_driver, only: vd_register
+  USE module_cu_camzm, only: zm_convi, zmconv_readnl
+
+  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, &
+                                      p_qc, p_qi, param_first_scalar
+
+  REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(OUT) :: &
+                                                           rucuten, &
+                                                           rvcuten, &
+                                                          rthcuten, &
+                                                          rqvcuten, &
+                                                          rqccuten, &
+                                                          rqicuten
+
+  integer :: i, itf, j, jtf, k, ktf
+  integer :: limcnv
+
+  jtf = min(jte,jde-1)
+  ktf = min(kte,kde-1)
+  itf = min(ite,ide-1)
+!
+! Initialize module_cam_support variables...
+! This could be moved to a master "cam-init" subroutine once multiple CAM
+! parameterizations are implemented in WRF. For now, it doesn't hurt to
+! have these possibly initialized more than once since they are
+! essentially constant.
+!
+  pver  = ktf-kts+1
+  pverp = pver+1
+!
+! Initialize the saturation vapor pressure look-up table...
+! This could be moved to a master cam-init subroutine too if it is needed
+! by more than one CAM parameterization. In CAM this is called from
+! phys_init.
+!
+  call esinti(epsilo, latvap, latice, rh2o, cpair, tmelt)
+
+!~Need code here to set limcnv to max convective level of 40 mb... To 
+! properly set an average value for the whole domain would involve doing
+! a collective operation across the whole domain to get pressure averages
+! by level, which is difficult within the WRF framework. So, we will just
+! use the model top for now.
+!
+! Technically, limcnv should be calculated for each grid point at each
+! time because the levels in WRF do not have a constant pressure, as
+! opposed to CAM. But, that would involve making this variable local
+! instead of at the module level as is currently done in CAM. For now,
+! we will not worry about this because WRF rarely has domains higher than
+! 40 mb. There is also little variability between grid points near the
+! model top due to the underlying topography so a constant value would
+! be OK across the comain. Also, remember that CAM levels are reversed in
+! the vertical from WRF. So, setting limcnv to 1 means the top of the
+! domain. Note that because of a bug in the parcel_dilute routine, limcnv
+! must be >=2 instead of 1. Otherwise, an array out-of-bounds occurs.
+  limcnv = 2
+!
+! Get the ZM namelist variables (hard-wired for now)...
+!
+  call zmconv_readnl("hard-wired")
+! 
+!~need to determine if convection should happen in PBL and set
+! no_deep_pbl_in accordingly
+  call zm_convi(limcnv, NO_DEEP_PBL_IN=.false.)
+
+!
+! Set initial values for arrays dependent on restart conditions
+!
+  if(.not.restart)then
+     do j=jts,jtf
+        do k=kts,ktf
+           do i=its,itf
+              rucuten(i,k,j)  = 0.
+              rvcuten(i,k,j)  = 0.
+              rthcuten(i,k,j) = 0.
+              rqvcuten(i,k,j) = 0.
+              if( p_qc > param_first_scalar ) rqccuten(i,k,j) = 0.
+              if( p_qi > param_first_scalar ) rqicuten(i,k,j) = 0.
+           enddo
+        enddo
+     enddo
+  end if
+
+END SUBROUTINE zm_conv_init
+
+
+!------------------------------------------------------------------------
+SUBROUTINE get_tpert(bl_pbl_physics, sf_sfclay_physics, dx, &
+     mavail, kpbl, pblh, dzlowest, &
+     psfc, qvlowest, t_phylowest, thlowest, tsk, tke_pbl, ust, &
+     u_phylowest, v_phylowest, hfx, qfx, tpert_camuwpbl, kte, tpert)
+! Calculates the temperature perturbation used to trigger convection.
+! This should only be used if tpert is not already provided by CAM's PBL
+! scheme. Right now, this only works with the Mellor-Yamada boundary
+! layer scheme in combination with the MYJ surface scheme. This is due to
+! the need of TKE for the vertical velocity perturbation. This scheme has
+! not been generalized to handle all schemes that produce TKE at this
+! time, and the non-TKE schemes, e.g. YSU, could probably have an
+! appropriate tpert deduced but we have not taken the time yet to do it.
+!
+! Author: William.Gustafson@pnl.gov, Nov. 2009
+! Last updated: William.Gustafson@pnl.gov, Nov. 2010
+!------------------------------------------------------------------------
+  USE shr_kind_mod,    only: r8 => shr_kind_r8
+  USE module_model_constants, only: cp, ep_1, ep_2, g, r_d, rcp, &
+                                    svp1, svp2, svp3, svpt0, xlv
+  USE module_state_description, ONLY : SFCLAYSCHEME              &
+                                      ,MYJSFCSCHEME              &
+                                      ,GFSSFCSCHEME              &
+                                      ,SLABSCHEME                &
+                                      ,LSMSCHEME                 &
+                                      ,RUCLSMSCHEME              &
+                                      ,MYJPBLSCHEME              &
+                                      ,CAMUWPBLSCHEME
+!
+! Subroutine arguments...
+!
+  real, dimension(:), intent(in) :: tke_pbl
+  real, intent(in) :: dx, dzlowest, hfx, mavail, pblh, psfc, qvlowest, &
+       tpert_camuwpbl, tsk, t_phylowest, thlowest, ust, u_phylowest, &
+       v_phylowest
+  integer, intent(in) :: bl_pbl_physics, kpbl, kte, sf_sfclay_physics
+  real(r8),intent(inout) :: tpert
+!
+! Local vars...
+!
+  real, parameter :: fak      = 8.5   !Constant in surface temperature excess         
+  real, parameter :: tfac     = 1.    !Ratio of 'tpert' to (w't')/wpert
+  real, parameter :: wfac     = 1.    !Ratio of 'wpert' to sqrt(tke)
+  real, parameter :: wpertmin = 1.e-6 !Min PBL eddy vertical velocity perturbation
+  real :: ebrk                        !In CAM, net mean TKE of CL including
+                                      !entrainment effect (m2/s2). In WRF,
+                                      !average TKE within the PBL
+  real :: br2, dthvdz, e1, flux, govrth, psfccmb, qfx, qsfc, rhox, thgb, &
+       thv, tskv, tvcon, vconv, vsgd, wpert, wspd, za
+  integer :: k
+  character(len=250) :: msg
+  logical :: UnstableOrNeutral
+!
+! We can get the perturbation values directly from CAMUWPBLSCHEME if
+! available. Otherwise, we have to calculate them.
+!
+  if( bl_pbl_physics==CAMUWPBLSCHEME ) then
+     tpert = tpert_camuwpbl
+!
+!...non-CAMUWPBL. Need MYJ SFC & PBL for now until other schemes
+!   get coded to give perturbations too.
+! First, we need to determine if the conditions are stable or unstable.
+! We will do this by mimicing the bulk Richardson calculation from
+! module_sf_sfclay.F because the MYJ scheme does not provide this info.
+! The logic borrowed from the CuP shallow cumulus scheme. Non-MYJ sfc
+! scheme code is commented out for now since we also require MYJ PBL
+! scheme.
+!
+  elseif( bl_pbl_physics==MYJPBLSCHEME ) then
+
+     UnstableOrNeutral = .false.
+     sfclay_case: SELECT CASE (sf_sfclay_physics)
+     CASE (MYJSFCSCHEME)
+        ! The MYJ sfc scheme does not already provide a stability criteria.
+        ! So, we will mimic the bulk Richardson calculation from
+        ! module_sf_sfclay.F.
+
+        if( pblh <= 0. ) call wrf_error_fatal( &
+             "CAMZMSCHEME needs a PBL height from a PBL scheme.")
+
+        za     = 0.5*dzlowest
+
+        e1     = svp1*exp(svp2*(tsk-svpt0)/(tsk-svp3))
+        psfccmb=psfc/1000.  !converts from Pa to cmb
+        qsfc   = ep_2*e1/(psfccmb-e1)
+        thgb   = tsk*(100./psfccmb)**rcp
+        tskv   = thgb*(1.+ep_1*qsfc*mavail)
+        tvcon  = 1.+ep_1*qvlowest
+        thv    = thlowest*tvcon
+        dthvdz = (thv-tskv)
+
+        govrth = g/thlowest
+
+        rhox   = psfc/(r_d*t_phylowest*tvcon)
+        flux   = max(hfx/rhox/cp + ep_1*tskv*qfx/rhox,0.)
+        vconv  = (g/tsk*pblh*flux)**.33
+        vsgd   = 0.32 * (max(dx/5000.-1.,0.))**.33
+        wspd   = sqrt(u_phylowest*u_phylowest+v_phylowest*v_phylowest)
+        wspd   = sqrt(wspd*wspd+vconv*vconv+vsgd*vsgd)
+        wspd   = max(wspd,0.1)
+
+        !And finally, the bulk Richardson number...
+        br2   = govrth*za*dthvdz/(wspd*wspd)
+
+        if( br2 <= 0. ) UnstableOrNeutral = .true.
+
+     CASE DEFAULT
+        call wrf_error_fatal("CAMZMSCHEME requires MYJSFCSCHEME or else CAMUWPBLSCHEME.")
+
+     END SELECT sfclay_case
+!
+! The perturbation temperature for unstable conditions...
+! The calculation follows the one in caleddy inside eddy_diff.F90 from
+! CAM.
+!
+     !Check that we are using the MJY BL scheme since we are hard-wired to
+     !use TKE and u* from this scheme. At some point this dependency should
+     !be broken and a way needs to be found for other schemes to provide
+     !reasonable tpert values too.
+     if( bl_pbl_physics /= MYJPBLSCHEME ) &
+          call wrf_error_fatal("CAMZMSCHEME requires MYJPBLSCHEME or CAMUWPBLSCHEME")
+   
+
+     !Recalculate rhox in case a non-MYJ scheme is used to get
+     !stability and rhox is not calculated above. Right now, this is
+     !technically reduncant, but cheap.
+     tvcon = 1.+ep_1*qvlowest
+     rhox  = psfc/(r_d*t_phylowest*tvcon)
+
+     if( UnstableOrNeutral ) then
+        !1st, get avg TKE w/n the PBL as a proxy for ebrk variable in CAM
+        ebrk = 0.
+        do k=1,min(kpbl,kte)
+           ebrk = ebrk + tke_pbl(k)
+        end do
+        ebrk = ebrk/real(kpbl)
+
+        wpert = max( wfac*sqrt(ebrk), wpertmin )
+        tpert = max( abs(hfx/rhox/cp)*tfac/wpert, 0. )
+!
+! Or, the perturbation temperature for stable conditions...
+!
+     else !Stable conditions
+        tpert = max( hfx/rhox/cp*fak/ust, 0. )
+     end if
+
+  else
+     call wrf_error_fatal("CAMZMSCHEME requires MYJPBLSCHEME or CAMUWPBLSCHEME")
+
+  end if !PBL choice
+
+END SUBROUTINE get_tpert
+
+END MODULE module_cu_camzm_driver
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_g3.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_g3.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_g3.F	(revision 17)
@@ -0,0 +1,5313 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+
+MODULE module_cu_g3
+
+CONTAINS
+
+!-------------------------------------------------------------
+   SUBROUTINE G3DRV(                                            &
+               DT,itimestep,DX                                  &
+              ,rho,RAINCV,PRATEC                                &
+              ,U,V,t,W,q,p,pi                                   &
+              ,dz8w,p8w,XLV,CP,G,r_v                            &
+              ,STEPCU,htop,hbot                                 &
+              ,CU_ACT_FLAG,warm_rain                            &
+              ,APR_GR,APR_W,APR_MC,APR_ST,APR_AS                &
+              ,APR_CAPMA,APR_CAPME,APR_CAPMI                    &
+              ,MASS_FLUX,XF_ENS,PR_ENS,HT,XLAND,gsw,edt_out     &
+              ,GDC,GDC2 ,kpbl,k22_shallow,kbcon_shallow         &
+              ,ktop_shallow,xmb_shallow                         &
+              ,cugd_tten,cugd_qvten ,cugd_qcten                 &
+              ,cugd_ttens,cugd_qvtens,cugd_avedx,imomentum      &
+              ,ensdim,maxiens,maxens,maxens2,maxens3,ichoice    &
+              ,ishallow_g3,ids,ide, jds,jde, kds,kde            &
+              ,ims,ime, jms,jme, kms,kme                        &
+              ,ips,ipe, jps,jpe, kps,kpe                        &
+              ,its,ite, jts,jte, kts,kte                        &
+              ,periodic_x,periodic_y                            &
+              ,RQVCUTEN,RQCCUTEN,RQICUTEN                       &
+              ,RQVFTEN,RTHFTEN,RTHCUTEN                         &
+              ,rqvblten,rthblten                                &
+              ,F_QV    ,F_QC    ,F_QR    ,F_QI    ,F_QS         &
+#if ( WRF_DFI_RADAR == 1 )
+                 ! Optional CAP suppress option
+              ,do_capsuppress,cap_suppress_loc                  &
+#endif                                 
+                                                                )
+!-------------------------------------------------------------
+   IMPLICIT NONE
+!-------------------------------------------------------------
+   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
+   LOGICAL periodic_x,periodic_y
+               integer, parameter  :: ens4_spread = 3 ! max(3,cugd_avedx)
+               integer, parameter  :: ens4=ens4_spread*ens4_spread
+
+   integer, intent (in   )              ::                      &
+                       ensdim,maxiens,maxens,maxens2,maxens3,ichoice
+  
+   INTEGER,      INTENT(IN   ) :: STEPCU, ITIMESTEP,cugd_avedx, &
+                                  ishallow_g3,imomentum
+   LOGICAL,      INTENT(IN   ) :: warm_rain
+
+   REAL,         INTENT(IN   ) :: XLV, R_v
+   REAL,         INTENT(IN   ) :: CP,G
+
+   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
+          INTENT(IN   ) ::                                      &
+                                                          U,    &
+                                                          V,    &
+                                                          W,    &
+                                                         pi,    &
+                                                          t,    &
+                                                          q,    &
+                                                          p,    &
+                                                       dz8w,    &
+                                                       p8w,    &
+                                                        rho
+   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
+          OPTIONAL                                         ,    &
+          INTENT(INOUT   ) ::                                   &
+               GDC,GDC2
+
+   REAL, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: GSW,HT,XLAND
+   INTEGER, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: KPBL
+   INTEGER, DIMENSION( ims:ime , jms:jme ),INTENT(INOUT) :: k22_shallow, &
+                 kbcon_shallow,ktop_shallow
+!
+   REAL, INTENT(IN   ) :: DT, DX
+!
+
+   REAL, DIMENSION( ims:ime , jms:jme ),                        &
+         INTENT(INOUT) ::           pratec,RAINCV, MASS_FLUX,   &
+                          APR_GR,APR_W,APR_MC,APR_ST,APR_AS,    &
+                         edt_out,APR_CAPMA,APR_CAPME,APR_CAPMI, &
+                         htop,hbot,xmb_shallow
+!+lxz
+!  REAL, DIMENSION( ims:ime , jms:jme ) :: & !, INTENT(INOUT) ::       &
+!        HTOP,     &! highest model layer penetrated by cumulus since last reset in radiation_driver
+!        HBOT       ! lowest  model layer penetrated by cumulus since last reset in radiation_driver
+!                   ! HBOT>HTOP follow physics leveling convention
+
+   LOGICAL, DIMENSION( ims:ime , jms:jme ),                     &
+         INTENT(INOUT) ::                       CU_ACT_FLAG
+
+!
+! Optionals
+!
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+         OPTIONAL,                                              &
+         INTENT(INOUT) ::                           RTHFTEN,    &
+                            cugd_tten,cugd_qvten,cugd_qcten,    &
+                            cugd_ttens,cugd_qvtens,             &
+                                                    RQVFTEN
+
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+         OPTIONAL,                                              &
+         INTENT(INOUT) ::                                       &
+                                                   RTHCUTEN,    &
+                                                   RQVCUTEN,    &
+                                                   RQVBLTEN,    &
+                                                   RTHBLTEN,    &
+                                                   RQCCUTEN,    &
+                                                   RQICUTEN
+!
+! 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
+
+
+#if ( WRF_DFI_RADAR == 1 )
+!
+!  option of cap suppress: 
+!        do_capsuppress = 1   do
+!        do_capsuppress = other   don't
+!
+!
+   INTEGER,      INTENT(IN   ) ,OPTIONAL   :: do_capsuppress
+   REAL, DIMENSION( ims:ime, jms:jme ),INTENT(IN   ),OPTIONAL  :: cap_suppress_loc
+   REAL, DIMENSION( its:ite ) :: cap_suppress_j
+#endif
+
+
+! LOCAL VARS
+     real,    dimension(ims:ime,jms:jme,1:ensdim),intent(inout) ::      &
+        xf_ens,pr_ens
+     real,    dimension ( its:ite , jts:jte , 1:ensdim) ::      &
+        massflni,xfi_ens,pri_ens
+   REAL, DIMENSION( its:ite , jts:jte ) ::            MASSI_FLX,    &
+                          APRi_GR,APRi_W,APRi_MC,APRi_ST,APRi_AS,    &
+                         edti_out,APRi_CAPMA,APRi_CAPME,APRi_CAPMI,gswi
+     real,    dimension (its:ite,kts:kte) ::                    &
+        SUBT,SUBQ,OUTT,OUTQ,OUTQC,phh,subm,cupclw,dhdt,         &
+        outts,outqs
+     real,    dimension (its:ite)         ::                    &
+        pret, ter11, aa0, fp,xlandi
+!+lxz
+     integer, dimension (its:ite) ::                            &
+        kbcon, ktop,kpbli,k22s,kbcons,ktops
+!.lxz
+     integer, dimension (its:ite,jts:jte) ::                    &
+        iact_old_gr
+     integer :: iens,ibeg,iend,jbeg,jend,n,nn,ens4n
+     integer :: ibegh,iendh,jbegh,jendh
+     integer :: ibegc,iendc,jbegc,jendc
+
+!
+! 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) ::                    &
+        T2d,q2d,PO,P2d,US,VS,tn,qo,tshall,qshall
+     real,    dimension (ips-2:ipe+2,kps:kpe,jps-2:jpe+2) ::    &
+        ave_f_t,ave_f_q
+     real,    dimension (its:ite,kts:kte,1:ens4) ::                    &
+        omeg,tx,qx
+     real, dimension (its:ite)            ::                    &
+        Z1,PSUR,AAEQ,direction,cuten,umean,vmean,pmean,xmbs
+     real, dimension (its:ite,1:ens4)     ::                    &
+        mconv
+
+   INTEGER :: i,j,k,ICLDCK,ipr,jpr
+   REAL    :: tcrit,tscl_KF,dp,dq,sub_spread,subcenter
+   INTEGER :: itf,jtf,ktf,iss,jss,nbegin,nend
+   INTEGER :: high_resolution
+   REAL    :: rkbcon,rktop        !-lxz
+! ruc variable
+     real, dimension (its:ite)            ::  tkm
+
+  ! A. Betts for shallow convection: suggestion for the KF timescale < DELTAX  / 25 m/s
+   tscl_kf=dx/25.
+  !
+!   write(0,*)'ishallow = ',ishallow_g3
+   high_resolution=0
+   if(cugd_avedx.gt.1) high_resolution=1
+   subcenter=0.
+!  subcenter=1./float(cugd_avedx)
+   sub_spread=max(1.,float(cugd_avedx*cugd_avedx-1))
+   sub_spread=(1.-subcenter)/sub_spread
+   iens=1
+   ipr=43
+   jpr=1
+   ipr=0
+   jpr=0
+!  if(itimestep.eq.8)then
+!   ipr=37
+!   jpr=16
+!  endif
+   IF ( periodic_x ) THEN
+      ibeg=max(its,ids)
+      iend=min(ite,ide-1)
+      ibegc=max(its,ids)
+      iendc=min(ite,ide-1)
+   ELSE
+      ibeg=max(its,ids)
+      iend=min(ite,ide-1)
+      ibegc=max(its,ids+4)
+      iendc=min(ite,ide-5)
+   END IF
+   IF ( periodic_y ) THEN
+      jbeg=max(jts,jds)
+      jend=min(jte,jde-1)
+      jbegc=max(jts,jds)
+      jendc=min(jte,jde-1)
+   ELSE
+      jbeg=max(jts,jds)
+      jend=min(jte,jde-1)
+      jbegc=max(jts,jds+4)
+      jendc=min(jte,jde-5)
+   END IF
+   do j=jts,jte
+   do i=its,ite
+     k22_shallow(i,j)=0
+     kbcon_shallow(i,j)=0
+     ktop_shallow(i,j)=0
+     xmb_shallow(i,j)=0
+   enddo
+   enddo
+   tcrit=258.
+   ave_f_t=0.
+   ave_f_q=0.
+
+   itf=MIN(ite,ide-1)
+   ktf=MIN(kte,kde-1)
+   jtf=MIN(jte,jde-1)
+!                                                                      
+#if ( EM_CORE == 1 )
+     if(high_resolution.eq.1)then
+!
+! calculate these on the halo...the incominh tendencies have been exchanged on a 24pt halo
+! only neede for high resolution run
+!
+     ibegh=its
+     jbegh=jts
+     iendh=ite
+     jendh=jte
+     if(its.eq.ips)ibegh=max(its-1,ids)
+     if(jts.eq.jps)jbegh=max(jts-1,jds)
+     if(jte.eq.jpe)jendh=min(jte+1,jde-1)
+     if(ite.eq.ipe)iendh=min(ite+1,ide-1)
+        DO J = jbegh,jendh
+        DO k= kts,ktf
+        DO I= ibegh,iendh
+          ave_f_t(i,k,j)=(rthften(i-1,k,j-1)+rthften(i-1,k,j) + rthften(i-1,k,j+1)+ &
+                         rthften(i,k,j-1)   +rthften(i,k,j)   +rthften(i,k,j+1)+         &
+                         rthften(i+1,k,j-1) +rthften(i+1,k,j) +rthften(i+1,k,j+1))/9.
+          ave_f_q(i,k,j)=(rqvften(i-1,k,j-1)+rqvften(i-1,k,j) + rqvften(i-1,k,j+1)+ &
+                         rqvften(i,k,j-1)   +rqvften(i,k,j)   +rqvften(i,k,j+1)+         &
+                         rqvften(i+1,k,j-1) +rqvften(i+1,k,j) +rqvften(i+1,k,j+1))/9.
+!         ave_f_t(i,k,j)=rthften(i,k,j)
+!         ave_f_q(i,k,j)=rqvften(i,k,j)
+        ENDDO
+        ENDDO
+        ENDDO
+     endif
+#endif
+     DO 100 J = jts,jtf  
+     DO n= 1,ensdim
+     DO I= its,itf
+       xfi_ens(i,j,n)=0.
+       pri_ens(i,j,n)=0.
+!      xfi_ens(i,j,n)=xf_ens(i,j,n)
+!      pri_ens(i,j,n)=pr_ens(i,j,n)
+     ENDDO
+     ENDDO
+     DO I= its,itf
+        kbcon(i)=0
+        ktop(i)=0
+        tkm(i)=0.
+        HBOT(I,J)  =REAL(KTE)
+        HTOP(I,J)  =REAL(KTS)
+        iact_old_gr(i,j)=0
+        mass_flux(i,j)=0.
+        massi_flx(i,j)=0.
+        raincv(i,j)=0.
+        pratec (i,j)=0.
+        edt_out(i,j)=0.
+        edti_out(i,j)=0.
+        gswi(i,j)=gsw(i,j)
+        xlandi(i)=xland(i,j)
+        APRi_GR(i,j)=apr_gr(i,j)
+        APRi_w(i,j)=apr_w(i,j)
+        APRi_mc(i,j)=apr_mc(i,j)
+        APRi_st(i,j)=apr_st(i,j)
+        APRi_as(i,j)=apr_as(i,j)
+        APRi_capma(i,j)=apr_capma(i,j)
+        APRi_capme(i,j)=apr_capme(i,j)
+        APRi_capmi(i,j)=apr_capmi(i,j)
+        CU_ACT_FLAG(i,j) = .true.
+     ENDDO
+     do k=kts,kte
+     DO I= its,itf
+       cugd_tten(i,k,j)=0.
+       cugd_ttens(i,k,j)=0.
+       cugd_qvten(i,k,j)=0.
+       cugd_qvtens(i,k,j)=0.
+       cugd_qcten(i,k,j)=0.
+     ENDDO
+     ENDDO
+     DO n=1,ens4
+     DO I= its,itf
+        mconv(i,n)=0.
+     ENDDO
+     do k=kts,kte
+     DO I= its,itf
+         omeg(i,k,n)=0.
+         tx(i,k,n)=0.
+         qx(i,k,n)=0.
+     ENDDO
+     ENDDO
+     ENDDO
+     DO k=1,ensdim
+     DO I= its,itf
+        massflni(i,j,k)=0.
+     ENDDO
+     ENDDO
+     !  put hydrostatic pressure on half levels
+     DO K=kts,ktf
+     DO I=ITS,ITF
+         phh(i,k) = p(i,k,j)
+     ENDDO
+     ENDDO
+
+     DO I=ITS,ITF
+         PSUR(I)=p8w(I,1,J)*.01
+!        PSUR(I)=p(I,1,J)*.01
+         TER11(I)=HT(i,j)
+         aaeq(i)=0.
+         direction(i)=0.
+         pret(i)=0.
+         umean(i)=0.
+         vmean(i)=0.
+         pmean(i)=0.
+         kpbli(i)=kpbl(i,j)
+     ENDDO
+!    if(j.eq.jpr)write(0,*)'psur(ipr),ter11(ipr),kpbli(ipr)'
+!    if(j.eq.jpr)write(0,*)psur(ipr),ter11(ipr),kpbli(ipr),r_v
+     DO K=kts,ktf
+     DO I=ITS,ITF
+         po(i,k)=phh(i,k)*.01
+         subm(i,k)=0.
+         P2d(I,K)=PO(i,k)
+         US(I,K) =u(i,k,j)
+         VS(I,K) =v(i,k,j)
+         T2d(I,K)=t(i,k,j)
+         q2d(I,K)=q(i,k,j)
+         IF(Q2d(I,K).LT.1.E-08)Q2d(I,K)=1.E-08
+         SUBT(I,K)=0.
+         SUBQ(I,K)=0.
+         OUTT(I,K)=0.
+         OUTQ(I,K)=0.
+         OUTQC(I,K)=0.
+         OUTTS(I,K)=0.
+         OUTQS(I,K)=0.
+         TN(I,K)=t2d(i,k)+RTHFTEN(i,k,j)*dt
+         QO(I,K)=q2d(i,k)+RQVFTEN(i,k,j)*dt
+         TSHALL(I,K)=t2d(i,k)+RTHBLTEN(i,k,j)*pi(i,k,j)*dt
+         DHDT(I,K)=cp*RTHBLTEN(i,k,j)*pi(i,k,j)+ XLV*RQVBLTEN(i,k,j)
+         QSHALL(I,K)=q2d(i,k)+RQVBLTEN(i,k,j)*dt
+         if(high_resolution.eq.1)then
+            TN(I,K)=t2d(i,k)+ave_f_t(i,k,j)*dt
+            QO(I,K)=q2d(i,k)+ave_f_q(i,k,j)*dt
+         endif
+         IF(TN(I,K).LT.200.)TN(I,K)=T2d(I,K)
+         IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08
+!        if(i.eq.ipr.and.j.eq.jpr)then
+!         write(0,123)k,p2d(i,k),t2d(i,k),tn(i,k),q2d(i,k),QO(i,k),RTHBLTEN(i,k,j),RQVBLTEN(i,k,j)
+!        endif
+     ENDDO
+     ENDDO
+123  format(1x,i2,f8.0,1x,2(1x,f8.3),4(1x,e12.4))
+     ens4n=0
+     nbegin=0
+     nend=0
+     if(ens4_spread.gt.1)then
+     nbegin=-ens4_spread/2
+     nend=ens4_spread/2
+     endif
+     do nn=nbegin,nend,1
+       jss=max(j+nn,jds+0)
+       jss=min(jss,jde-1)
+       do n=nbegin,nend,1
+         ens4n=ens4n+1
+         DO K=kts,ktf
+         DO I=ITS,ITF
+          iss=max(i+n,ids+0)
+          iss=min(iss,ide-1)
+         omeg(I,K,ens4n)= -g*rho(i,k,j)*w(iss,k,jss)
+!        omeg(I,K,ens4n)= -g*rho(i,k,j)*w(i,k,j)
+         Tx(I,K,ens4n)=t2d(i,k)+RTHFTEN(iss,k,jss)*dt
+!        Tx(I,K,ens4n)=t2d(i,k)+RTHFTEN(i,k,j)*dt
+         if(high_resolution.eq.1)Tx(I,K,ens4n)=t2d(i,k)+ave_f_t(iss,k,jss)*dt
+         IF(Tx(I,K,ens4n).LT.200.)Tx(I,K,ens4n)=T2d(I,K)
+         Qx(I,K,ens4n)=q2d(i,k)+RQVFTEN(iss,k,jss)*dt
+         Qx(I,K,ens4n)=q2d(i,k)+RQVFTEN(i,k,j)*dt
+         if(high_resolution.eq.1)qx(I,K,ens4n)=q2d(i,k)+ave_f_q(iss,k,jss)*dt
+         IF(Qx(I,K,ens4n).LT.1.E-08)Qx(I,K,ens4n)=1.E-08
+        enddo
+        enddo
+      enddo !n
+      enddo !nn
+      do k=  kts+1,ktf-1
+      DO I = its,itf
+         if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then
+            dp=-.5*(p2d(i,k+1)-p2d(i,k-1))
+            umean(i)=umean(i)+us(i,k)*dp
+            vmean(i)=vmean(i)+vs(i,k)*dp
+            pmean(i)=pmean(i)+dp
+         endif
+      enddo
+      enddo
+      DO I = its,itf
+         umean(i)=umean(i)/pmean(i)
+         vmean(i)=vmean(i)/pmean(i)
+         direction(i)=(atan2(umean(i),vmean(i))+3.1415926)*57.29578
+         if(direction(i).gt.360.)direction(i)=direction(i)-360.
+      ENDDO
+      do n=1,ens4
+      DO K=kts,ktf-1
+      DO I = its,itf
+        dq=(q2d(i,k+1)-q2d(i,k))
+        mconv(i,n)=mconv(i,n)+omeg(i,k,n)*dq/g
+      enddo
+      ENDDO
+      ENDDO
+      do n=1,ens4
+      DO I = its,itf
+        if(mconv(i,n).lt.0.)mconv(i,n)=0.
+      ENDDO
+      ENDDO
+!
+!---- CALL CUMULUS PARAMETERIZATION
+!
+#if ( WRF_DFI_RADAR == 1 )
+      if(do_capsuppress == 1 ) then
+        DO I= its,itf
+            cap_suppress_j(i)=cap_suppress_loc(i,j)
+        ENDDO
+      endif
+#endif
+      CALL CUP_enss_3d(outqc,j,AAEQ,T2d,Q2d,TER11,subm,TN,QO,PO,PRET,&
+           P2d,OUTT,OUTQ,DT,itimestep,tkm,PSUR,US,VS,tcrit,iens,tx,qx,          &
+           tshall,qshall,kpbli,DHDT,outts,outqs,tscl_kf,           &
+           k22s,kbcons,ktops,xmbs,                                 &
+           mconv,massflni,iact_old_gr,omeg,direction,MASSi_FLX,  &
+           maxiens,maxens,maxens2,maxens3,ensdim,                 &
+           APRi_GR,APRi_W,APRi_MC,APRi_ST,APRi_AS,                &
+           APRi_CAPMA,APRi_CAPME,APRi_CAPMI,kbcon,ktop,cupclw,    &
+           xfi_ens,pri_ens,XLANDi,gswi,edti_out,subt,subq,        &
+! ruc          lv_p,rv_p,cpd_p,g0_p,ichoice,ipr,jpr,                  &
+           xlv,r_v,cp,g,ichoice,ipr,jpr,ens4,high_resolution,     &
+           ishallow_g3,itf,jtf,ktf,                               &
+           its,ite, jts,jte, kts,kte                              &
+#if ( WRF_DFI_RADAR == 1 )
+           ,do_capsuppress,cap_suppress_j                         &             
+#endif
+                                                             )
+
+
+            if(j.lt.jbegc.or.j.gt.jendc)go to 100
+            DO I=ibegc,iendc
+              xmb_shallow(i,j)=xmbs(i)
+              k22_shallow(i,j)=k22s(i)
+              kbcon_shallow(i,j)=kbcons(i)
+              ktop_shallow(i,j)=ktops(i)
+              cuten(i)=0.
+              if(pret(i).gt.0.)then
+                 cuten(i)=1.
+!                raincv(i,j)=pret(i)*dt
+              endif
+            ENDDO
+!           if(j.eq.jpr)write(0,*)'precip,ktop,kbcon = ',pret(ipr),ktop(ipr),kbcon(ipr)
+            DO I=ibegc,iendc
+            DO K=kts,ktf
+               cugd_ttens(I,K,J)=subt(i,k)*cuten(i)*sub_spread
+               cugd_qvtens(I,K,J)=subq(i,k)*cuten(i)*sub_spread
+!              cugd_tten(I,K,J)=outt(i,k)*cuten(i) 
+!              cugd_qvten(I,K,J)=outq(i,k)*cuten(i)
+               cugd_tten(I,K,J)=outts(i,k)+outt(i,k)*cuten(i)
+               cugd_qvten(I,K,J)=outqs(i,k)+outq(i,k)*cuten(i)
+               cugd_qcten(I,K,J)=outqc(i,k)*cuten(i)
+!              if(i.eq.ipr.and.j.eq.jpr)then
+!                write(0,*)subt(i,k)+outt(i,k),subq(i,k)+outq(i,k),outts(i,k),outqs(i,k)
+!              endif
+            ENDDO
+            ENDDO
+            DO I=ibegc,iendc
+              if(pret(i).gt.0.)then
+                 raincv(i,j)=pret(i)*dt
+                 pratec(i,j)=pret(i)
+                 rkbcon = kte+kts - kbcon(i)
+                 rktop  = kte+kts -  ktop(i)
+                 if (ktop(i)  > HTOP(i,j)) HTOP(i,j) = ktop(i)+.001
+                 if (kbcon(i) < HBOT(i,j)) HBOT(i,j) = kbcon(i)+.001
+              endif
+            ENDDO
+            DO n= 1,ensdim
+            DO I= ibegc,iendc
+              xf_ens(i,j,n)=xfi_ens(i,j,n)
+              pr_ens(i,j,n)=pri_ens(i,j,n)
+            ENDDO
+            ENDDO
+            DO I= ibegc,iendc
+               APR_GR(i,j)=apri_gr(i,j)
+               APR_w(i,j)=apri_w(i,j)
+               APR_mc(i,j)=apri_mc(i,j)
+               APR_st(i,j)=apri_st(i,j)
+               APR_as(i,j)=apri_as(i,j)
+               APR_capma(i,j)=apri_capma(i,j)
+               APR_capme(i,j)=apri_capme(i,j)
+               APR_capmi(i,j)=apri_capmi(i,j)
+               mass_flux(i,j)=massi_flx(i,j)
+               edt_out(i,j)=edti_out(i,j)
+            ENDDO
+            IF(PRESENT(RQCCUTEN)) THEN
+              IF ( F_QC ) THEN
+                DO K=kts,ktf
+                DO I=ibegc,iendc
+                   RQCCUTEN(I,K,J)=outqc(I,K)*cuten(i)
+                   IF ( PRESENT( GDC ) ) GDC(I,K,J)=CUPCLW(I,K)*cuten(i)
+                   IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=0.
+                ENDDO
+                ENDDO
+              ENDIF
+            ENDIF
+
+!......     QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2)     
+
+            IF(PRESENT(RQICUTEN).AND.PRESENT(RQCCUTEN))THEN
+              IF (F_QI) THEN
+                DO K=kts,ktf
+                  DO I=ibegc,iendc
+                   if(t2d(i,k).lt.258.)then
+                      RQICUTEN(I,K,J)=outqc(I,K)*cuten(i)
+                      cugd_qcten(i,k,j)=0.
+                      RQCCUTEN(I,K,J)=0.
+                      IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=CUPCLW(I,K)*cuten(i)
+                   else
+                      RQICUTEN(I,K,J)=0.
+                      RQCCUTEN(I,K,J)=outqc(I,K)*cuten(i)
+                      IF ( PRESENT( GDC ) ) GDC(I,K,J)=CUPCLW(I,K)*cuten(i)
+                   endif
+                ENDDO
+                ENDDO
+              ENDIF
+            ENDIF
+
+ 100    continue
+
+   END SUBROUTINE G3DRV
+
+   SUBROUTINE CUP_enss_3d(OUTQC,J,AAEQ,T,Q,Z1,sub_mas,                    &
+              TN,QO,PO,PRE,P,OUTT,OUTQ,DTIME,ktau,tkmax,PSUR,US,VS,    &
+              TCRIT,iens,tx,qx,                                        &
+              tshall,qshall,kpbl,dhdt,outts,outqs,tscl_kf,             &
+              k23,kbcon3,ktop3,xmb3,                                   &
+              mconv,massfln,iact,                                      &
+              omeg,direction,massflx,maxiens,                          &
+              maxens,maxens2,maxens3,ensdim,                           &
+              APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                       &
+              APR_CAPMA,APR_CAPME,APR_CAPMI,kbcon,ktop,cupclw,         &   !-lxz
+              xf_ens,pr_ens,xland,gsw,edt_out,subt,subq,               &
+              xl,rv,cp,g,ichoice,ipr,jpr,ens4,high_resolution,         &
+              ishallow_g3,itf,jtf,ktf,                                 &
+              its,ite, jts,jte, kts,kte                                &
+#if ( WRF_DFI_RADAR == 1 )
+                 ! Optional CAP suppress option
+                     ,do_capsuppress,cap_suppress_j                  &
+#endif                                 
+                                                )
+
+   IMPLICIT NONE
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,jtf,ktf,ktau,                                              &
+        its,ite, jts,jte, kts,kte,ipr,jpr,ens4,high_resolution
+     integer, intent (in   )              ::                           &
+        j,ensdim,maxiens,ishallow_g3,maxens,maxens2,maxens3,ichoice,iens
+  !
+  ! 
+  !
+     real,    dimension (its:ite,jts:jte,1:ensdim)                     &
+        ,intent (inout)                   ::                           &
+        massfln,xf_ens,pr_ens
+     real,    dimension (its:ite,jts:jte)                              &
+        ,intent (inout )                  ::                           &
+               APR_GR,APR_W,APR_MC,APR_ST,APR_AS,APR_CAPMA,     &
+               APR_CAPME,APR_CAPMI,massflx,edt_out
+     real,    dimension (its:ite,jts:jte)                              &
+        ,intent (in   )                   ::                           &
+               gsw
+     integer, dimension (its:ite,jts:jte)                              &
+        ,intent (in   )                   ::                           &
+        iact
+  ! outtem = output temp tendency (per s)
+  ! outq   = output q tendency (per s)
+  ! outqc  = output qc tendency (per s)
+  ! pre    = output precip
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout  )                   ::                           &
+        DHDT,OUTT,OUTQ,OUTQC,subt,subq,sub_mas,cupclw,outts,outqs
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        pre,xmb3
+     integer,    dimension (its:ite)                                   &
+        ,intent (out  )                   ::                           &
+        kbcon,ktop,k23,kbcon3,ktop3
+     integer,    dimension (its:ite)                                   &
+        ,intent (in  )                   ::                           &
+        kpbl
+  !
+  ! 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,PO,P,US,VS,tn,tshall,qshall
+     real,    dimension (its:ite,kts:kte,1:ens4)                       &
+        ,intent (inout   )                   ::                           &
+        omeg,tx,qx
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout)                   ::                           &
+         Q,QO
+     real, dimension (its:ite)                                         &
+        ,intent (in   )                   ::                           &
+        Z1,PSUR,AAEQ,direction,tkmax,xland
+     real, dimension (its:ite,1:ens4)                                         &
+        ,intent (in   )                   ::                           &
+        mconv
+
+       
+       real                                                            &
+        ,intent (in   )                   ::                           &
+        dtime,tcrit,xl,cp,rv,g,tscl_kf
+
+#if ( WRF_DFI_RADAR == 1 )
+!
+!  option of cap suppress: 
+!        do_capsuppress = 1   do
+!        do_capsuppress = other   don't
+!
+!
+   INTEGER,      INTENT(IN   ) ,OPTIONAL   :: do_capsuppress
+   REAL, DIMENSION( its:ite ),INTENT(IN   ) ,OPTIONAL   :: cap_suppress_j
+#endif
+
+!
+!  local ensemble dependent variables in this routine
+!
+     real,    dimension (its:ite,1:maxens)  ::                         &
+        xaa0_ens
+     real,    dimension (1:maxens)  ::                                 &
+        mbdt_ens
+     real,    dimension (1:maxens2) ::                                 &
+        edt_ens
+     real,    dimension (its:ite,1:maxens2) ::                         &
+        edtc
+     real,    dimension (its:ite,kts:kte,1:maxens2) ::                 &
+        dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens,subt_ens,subq_ens
+!
+!
+!
+!***************** 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
+  ! pr_ens = precipitation ensemble
+  ! xf_ens = mass flux ensembles
+  ! massfln = downdraft mass flux ensembles used in next timestep
+  ! omeg = omega from large scale model
+  ! mconv = moisture convergence from large scale model
+  ! zd      = downdraft normalized mass flux
+  ! zu      = updraft normalized mass flux
+  ! dir     = "storm motion"
+  ! mbdt    = arbitrary numerical parameter
+  ! dtime   = dt over which forcing is applied
+  ! iact_gr_old = flag to tell where convection was active
+  ! kbcon       = LFC of parcel from k22
+  ! k22         = updraft originating level
+  ! icoic       = flag if only want one closure (usually set to zero!)
+  ! 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) ::                           &
+        he3,hes3,qes3,z3,zdo3,zu3_0,hc3_0,dby3_0,gamma3_0_cup,         &
+        qes3_cup,q3_cup,he3_cup,hes3_cup,z3_cup,gamma3_cup,t3_cup,     &
+        xhe3,xhes3,xqes3,xz3,xt3,xq3,                                  &
+        xqes3_cup,xq3_cup,xhe3_cup,xhes3_cup,xz3_cup,xgamma3_cup,      &
+        xt3_cup,                                                       &
+        xdby3,xqc3,xhc3,xqrc3,xzu3,                                    &
+        dby3,qc3,pw3,hc3,qrc3,zu3,cd3,DELLAH3,DELLAQ3,                 &
+        dsubt3,dsubq3,DELLAT3,DELLAQC3
+
+     real,    dimension (its:ite,kts:kte) ::                           &
+        he,hes,qes,z,                                                  &
+        heo,heso,qeso,zo,                                              &
+        xhe,xhes,xqes,xz,xt,xq,                                        &
+
+        qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,      &
+        qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,     &
+        tn_cup,                                                        &
+        xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup,xp_cup,xgamma_cup,     &
+        xt_cup,                                                        &
+
+        dby,qc,qrcd,pwd,pw,hcd,qcd,dbyd,hc,qrc,zu,zd,clw_all,          &
+        dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco,zuo,zdo,      &
+        xdby,xqc,xqrcd,xpwd,xpw,xhcd,xqcd,xhc,xqrc,xzu,xzd,            &
+
+  ! cd  = detrainment function for updraft
+  ! cdd = detrainment function for downdraft
+  ! dellat = change of temperature per unit mass flux of cloud ensemble
+  ! dellaq = change of q per unit mass flux of cloud ensemble
+  ! dellaqc = change of qc per unit mass flux of cloud ensemble
+
+        cd,cdd,scr1,DELLAH,DELLAQ,DELLAT,DELLAQC,dsubt,dsubq
+
+  ! aa0 cloud work function for downdraft
+  ! edt = epsilon
+  ! aa0     = cloud work function without forcing effects
+  ! aa1     = cloud work function with forcing effects
+  ! xaa0    = cloud work function with cloud effects (ensemble dependent)
+  ! edt     = epsilon
+
+     real,    dimension (its:ite) ::                                   &
+       aa3_0,aa3,hkb3,qkb3,pwav3,bu3,xaa3,xhkb3,                       &
+       hkb3_0,edt,edto,edtx,AA1,AA0,XAA0,HKB,                          &
+       HKBO,aad,XHKB,QKB,QKBO,edt3,                                    &
+       XMB,XPWAV,XPWEV,PWAV,PWEV,PWAVO,                                &
+       PWEVO,BU,BUO,cap_max,xland1,                                    &
+       cap_max_increment,closure_n,cap_max3
+     real,    dimension (its:ite,1:ens4) ::                                   &
+        axx
+     integer,    dimension (its:ite) ::                                &
+       kzdown,KDET,K22,KB,JMIN,kstabi,kstabm,K22x,jmin3,kdet3,         &   !-lxz
+       KBCONx,KBx,KTOPx,ierr,ierr2,ierr3,KBMAX,ierr5,ierr5_0 
+
+     integer                              ::                           &
+       nall,iedt,nens,nens3,ki,I,K,KK,iresult
+     real                                 ::                           &
+      day,dz,mbdt,mbdt_s,entr_rate,radius,entrd_rate,mentr_rate,mentrd_rate,  &
+      zcutdown,edtmax,edtmin,depth_min,zkbmax,z_detr,zktop,            &
+      massfld,dh,cap_maxs,trash,entr_rate3,mentr_rate3
+
+     integer :: jmini
+     logical :: keep_going
+     real xff_shal(9),blqe,xkshal
+
+
+
+      day=86400.
+      do i=its,itf
+        xmb3(i)=0.
+        closure_n(i)=16.
+        xland1(i)=1.
+        if(xland(i).gt.1.5)xland1(i)=0.
+!       cap_max_increment(i)=50.
+        cap_max_increment(i)=25.
+      enddo
+!
+!--- specify entrainmentrate and detrainmentrate
+!
+      if(iens.le.4)then
+      radius=14000.-float(iens)*2000.
+      else
+      radius=12000.
+      endif
+!
+!--- gross entrainment rate (these may be changed later on in the
+!--- program, depending what your detrainment is!!)
+!
+      entr_rate =.2/radius
+      entr_rate3=.2/200.
+!
+!--- entrainment of mass
+!
+      mentrd_rate=0.
+      mentr_rate=entr_rate
+      mentr_rate3=entr_rate3
+!
+!--- initial detrainmentrates
+!
+      do k=kts,ktf
+      do i=its,itf
+        cupclw(i,k)=0.
+        cd(i,k)=0.01*entr_rate
+        cd3(i,k)=entr_rate3
+        cdd(i,k)=0.
+        zdo3(i,k)=0.
+        hcdo(i,k)=0.
+        qrcdo(i,k)=0.
+        dellaqc(i,k)=0.
+      enddo
+      enddo
+!
+!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft
+!    base mass flux
+!
+      edtmax=1.
+      edtmin=.2
+!
+!--- minimum depth (m), clouds must have
+!
+      depth_min=500.
+!
+!--- maximum depth (mb) of capping 
+!--- inversion (larger cap = no convection)
+!
+!     cap_maxs=125.
+      cap_maxs=75.
+      DO i=its,itf
+        kbmax(i)=1
+        jmin3(i)=0
+        kdet3(i)=0
+        aa0(i)=0.
+        aa3_0(i)=0.
+        aa1(i)=0.
+        aa3(i)=0.
+        aad(i)=0.
+        edt(i)=0.
+        edt3(i)=0.
+        kstabm(i)=ktf-1
+        IERR(i)=0
+        IERR2(i)=0
+        IERR3(i)=0
+        IERR5(i)=0
+        IERR5_0(i)=0
+ enddo
+!
+!--- first check for upstream convection
+!
+#if ( WRF_DFI_RADAR == 1 )
+  if(do_capsuppress == 1) then
+      do i=its,itf
+          cap_max(i)=cap_maxs
+          cap_max3(i)=25.
+          if(gsw(i,j).lt.1.or.high_resolution.eq.1)cap_max(i)=25.
+          if (abs(cap_suppress_j(i) - 1.0 ) < 0.1 ) then
+             cap_max(i)=cap_maxs+75.
+          elseif (abs(cap_suppress_j(i) - 0.0 ) < 0.1 ) then
+             cap_max(i)=10.0
+          endif
+          iresult=0
+      enddo
+  else
+     do i=its,itf
+         cap_max(i)=cap_maxs
+          cap_max3(i)=25.
+         if(gsw(i,j).lt.1.or.high_resolution.eq.1)cap_max(i)=25.
+       iresult=0
+     enddo
+  endif
+
+      do i=its,itf
+        edt_out(i,j)=cap_max(i)
+      enddo
+#else
+      do i=its,itf
+          cap_max(i)=cap_maxs
+          cap_max3(i)=25.
+          if(gsw(i,j).lt.1.or.high_resolution.eq.1)cap_max(i)=25.
+        iresult=0
+
+      enddo
+#endif
+!
+!--- 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.
+!
+      do nens=1,maxens
+         mbdt_ens(nens)=(float(nens)-3.)*dtime*1.e-3+dtime*5.E-03
+      enddo
+      do nens=1,maxens2
+         edt_ens(nens)=.95-float(nens)*.01
+      enddo
+!
+!--- environmental conditions, FIRST HEIGHTS
+!
+      do i=its,itf
+         if(ierr(i).ne.20)then
+            do k=1,maxens*maxens2*maxens3
+               xf_ens(i,j,(iens-1)*maxens*maxens2*maxens3+k)=0.
+               pr_ens(i,j,(iens-1)*maxens*maxens2*maxens3+k)=0.
+            enddo
+         endif
+      enddo
+!
+!--- calculate moist static energy, heights, qes
+!
+      call cup_env(z,qes,he,hes,t,q,p,z1, &
+           psur,ierr,tcrit,0,xl,cp,   &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, &
+           psur,ierr,tcrit,0,xl,cp,   &
+           itf,jtf,ktf, &
+           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,          &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, &
+           heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur,  &
+           ierr,z1,xl,rv,cp,          &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      do i=its,itf
+        if(aaeq(i).lt.-0.1)then
+           ierr(i)=20
+        endif
+!     if(ierr(i).eq.0)then
+!
+      do k=kts,ktf
+        if(zo_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(zo_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(HEO_CUP,3,KBMAX,K22,ierr, &
+           itf,jtf,ktf, &
+           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,heo_cup,heso_cup, &
+           ierr,kbmax,po_cup,cap_max, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- increase detrainment in stable layers
+!
+      CALL cup_minimi(HEso_cup,Kbcon,kstabm,kstabi,ierr,  &
+           itf,jtf,ktf, &
+           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)+.15*entr_rate
+             if(cd(i,k).gt.1.0*entr_rate)cd(i,k)=1.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,'deep', &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_up_he(k22,hkbo,zo_cup,cd,mentr_rate,heo_cup,hco, &
+           kbcon,ierr,dbyo,heo,heso_cup,'deep', &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+
+!--- DETERMINE CLOUD TOP - KTOP
+!
+      call cup_ktop(1,dbyo,kbcon,ktop,ierr, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      DO 37 i=its,itf
+         kzdown(i)=0
+         if(ierr(i).eq.0)then
+            zktop=(zo_cup(i,ktop(i))-z1(i))*.6
+            zktop=min(zktop+z1(i),zcutdown+z1(i))
+            do k=kts,kte
+              if(zo_cup(i,k).gt.zktop)then
+                 kzdown(i)=k
+                 go to 37
+              endif
+              enddo
+         endif
+ 37   CONTINUE
+!
+!--- DOWNDRAFT ORIGINATING LEVEL - JMIN
+!
+      call cup_minimi(HEso_cup,K22,kzdown,JMIN,ierr, &
+           itf,jtf,ktf, &
+           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
+!
+      jmini = jmin(i)
+      keep_going = .TRUE.
+      do while ( keep_going )
+        keep_going = .FALSE.
+        if ( jmini - 1 .lt. kdet(i)   ) kdet(i) = jmini-1
+        if ( jmini     .ge. ktop(i)-1 ) jmini = ktop(i) - 2
+        ki = jmini
+        hcdo(i,ki)=heso_cup(i,ki)
+        DZ=Zo_cup(i,Ki+1)-Zo_cup(i,Ki)
+        dh=0.
+        do k=ki-1,1,-1
+          hcdo(i,k)=heso_cup(i,jmini)
+          DZ=Zo_cup(i,K+1)-Zo_cup(i,K)
+          dh=dh+dz*(HCDo(i,K)-heso_cup(i,k))
+          if(dh.gt.0.)then
+            jmini=jmini-1
+            if ( jmini .gt. 3 ) then
+              keep_going = .TRUE.
+            else
+              ierr(i) = 9
+              exit
+            endif
+          endif
+        enddo
+      enddo
+      jmin(i) = jmini 
+      if ( jmini .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(-zo_cup(I,KBCON(I))+zo_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, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_up_nms(zuo,zo_cup,mentr_rate,cd,kbcon,ktop,ierr,k22, &
+           itf,jtf,ktf, &
+           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,                 &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_dd_nms(zdo,zo_cup,cdd,mentrd_rate,jmin,ierr, &
+           1,kdet,z1,                 &
+           itf,jtf,ktf, &
+           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,  &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_dd_he(heso_cup,zdo,hcdo,zo_cup,cdd,mentrd_rate, &
+           jmin,ierr,heo,dbydo,he_cup,&
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- calculate moisture properties of downdraft
+!
+      call cup_dd_moisture_3d(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,high_resolution, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_dd_moisture_3d(zdo,hcdo,heso_cup,qcdo,qeso_cup, &
+           pwdo,qo_cup,zo_cup,cdd,mentrd_rate,jmin,ierr,gammao_cup, &
+           pwevo,bu,qrcdo,qo,heo,tn_cup,1,xl,high_resolution, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- calculate moisture properties of updraft
+!
+      call cup_up_moisture('deep',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, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      do k=kts,ktf
+      do i=its,itf
+         cupclw(i,k)=qrc(i,k)
+      enddo
+      enddo
+      call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, &
+           kbcon,ktop,cd,dbyo,mentr_rate,clw_all, &
+           qo,GAMMAo_cup,zuo,qeso_cup,k22,qo_cup,xl,&
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- calculate workfunctions for updrafts
+!
+      call cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup, &
+           kbcon,ktop,ierr,           &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_up_aa0(aa1,zo,zuo,dbyo,GAMMAo_CUP,tn_cup, &
+           kbcon,ktop,ierr,           &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      do i=its,itf
+         if(ierr(i).eq.0)then
+           if(aa1(i).eq.0.)then
+               ierr(i)=17
+           endif
+         endif
+      enddo
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!    NEXT section for shallow convection
+!
+      if(ishallow_g3.eq.1)then
+!     write(0,*)'now do shallow for j = ',j
+      call cup_env(z3,qes3,he3,hes3,tshall,qshall,po,z1, &
+           psur,ierr5,tcrit,0,xl,cp,   &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_env_clev(tshall,qes3,qshall,he3,hes3,z3,po,qes3_cup,q3_cup, &
+           he3_cup,hes3_cup,z3_cup,po_cup,gamma3_cup,t3_cup,psur,  &
+           ierr5,z1,xl,rv,cp,          &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      CALL cup_MAXIMI(HE3_CUP,1,kbmax,K23,ierr5, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+       DO i=its,itf
+         if(kpbl(i).gt.5)cap_max3(i)=po_cup(i,kpbl(i))
+         IF(ierr5(I).eq.0.)THEN
+         IF(K23(I).Gt.Kbmax(i))ierr5(i)=2
+         if(kpbl(i).gt.5)k23(i)=kpbl(i)
+         endif
+         ierr5_0(i)=ierr5(i)
+       ENDDO
+      call cup_kbcon(cap_max_increment,5,k23,kbcon3,he3_cup,hes3_cup, &
+           ierr5,kbmax,po_cup,cap_max3, &
+!          ierr5,kpbl,po_cup,cap_max3, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_up_he(k23,hkb3,z3_cup,cd3,mentr_rate3,he3_cup,hc3, &
+           kbcon3,ierr5,dby3,he3,hes3_cup,'shallow', &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_up_he(k23,hkb3_0,z_cup,cd3,mentr_rate3,he_cup,hc3_0, &
+           kbcon3,ierr5,dby3_0,he,hes_cup,'shallow', &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_ktop(1,dby3,kbcon3,ktop3,ierr5, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_up_nms(zu3,z3_cup,mentr_rate3,cd3,kbcon3,ktop3,    &
+           ierr5,k23, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_up_nms(zu3_0,z_cup,mentr_rate3,cd3,kbcon3,ktop3,    &
+           ierr5,k23, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+! first calculate aa3_0_cup
+!
+      call cup_up_aa0(aa3_0,z,zu3_0,dby3_0,GAMMA3_0_CUP,t_cup, &
+           kbcon3,ktop3,ierr5,           &
+           itf,jtf,ktf, &
+          its,ite, jts,jte, kts,kte)
+!
+!  now what is necessary for aa3 and feedbacks
+!
+      call cup_up_moisture('shallow',ierr5,z3_cup,qc3,qrc3,pw3,pwav3, &
+           kbcon3,ktop3,cd3,dby3,mentr_rate3,clw_all, &
+           qshall,GAMMA3_cup,zu3,qes3_cup,k23,q3_cup,xl,&
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_up_aa0(aa3,z3,zu3,dby3,GAMMA3_CUP,t3_cup, &
+           kbcon3,ktop3,ierr5,           &
+           itf,jtf,ktf, &
+          its,ite, jts,jte, kts,kte)
+!     do i=its,itf
+!        if(ierr5(i).eq.0)then
+!          if(aa3(i).eq.0.)then
+!              ierr5(i)=17
+!          endif
+!        endif
+!     enddo
+!     call cup_dellabot('shallow',ipr,jpr,q3_cup,ierr5,z3_cup,po,qrcdo,edto, &
+!          zdo,cdd,q3,dellaq3,dsubq,j,mentrd_rate,z3,g,&
+!          itf,jtf,ktf, &
+!          its,ite, jts,jte, kts,kte)
+      call cup_dellas_3d(ierr5,z3_cup,po_cup,hcdo,edt3,zdo3,cdd,    &
+           he3,dellah3,dsubt3,j,mentrd_rate,zu3,g,                     &
+           cd3,hc3,ktop3,k23,kbcon3,mentr_rate3,jmin,he3_cup,kdet, &
+           k23,ipr,jpr,'shallow',0,                                 &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_dellas_3d(ierr5,z3_cup,po_cup,qrcdo,edt3,zdo3,cdd, &
+           qshall,dellaq3,dsubq3,j,mentrd_rate,zu3,g, &
+           cd3,qc3,ktop3,k23,kbcon3,mentr_rate3,jmin,q3_cup,kdet, &
+           k23,ipr,jpr,'shallow',0,               &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte    )
+              mbdt_s=1.e-1*mbdt_ens(1)
+              do k=kts,ktf
+              do i=its,itf
+                 dellat3(i,k)=0.
+                 if(ierr5(i).eq.0)then
+                    trash=dsubt3(i,k)
+                    XHE3(I,K)=(dsubt3(i,k)+DELLAH3(I,K))*MBDT_S+HE3(I,K)
+                    XQ3(I,K)=(dsubq3(i,k)+DELLAQ3(I,K))*MBDT_S+QSHALL(I,K)
+                    DELLAT3(I,K)=(1./cp)*(DELLAH3(I,K)-xl*DELLAQ3(I,K))
+                    dSUBT3(I,K)=(1./cp)*(dsubt3(i,k)-xl*dsubq3(i,k))
+                    XT3(I,K)= (DELLAT3(I,K)+dsubt3(i,k))*MBDT_S+TSHALL(I,K)
+                    IF(XQ3(I,K).LE.0.)XQ3(I,K)=1.E-08
+!                    if(i.eq.ipr.and.j.eq.jpr)then
+!                      write(0,*)k,trash,DELLAQ3(I,K),dsubq3(I,K),dsubt3(i,k)
+!                    endif
+                 ENDIF
+              enddo
+              enddo
+      do i=its,itf
+      if(ierr5(i).eq.0)then
+      XHE3(I,ktf)=HE3(I,ktf)
+      XQ3(I,ktf)=QSHALL(I,ktf)
+      XT3(I,ktf)=TSHALL(I,ktf)
+      IF(XQ3(I,ktf).LE.0.)XQ3(I,ktf)=1.E-08
+      endif
+      enddo
+!
+!--- calculate moist static energy, heights, qes
+!
+      call cup_env(xz3,xqes3,xhe3,xhes3,xt3,xq3,po,z1, &
+           psur,ierr5,tcrit,2,xl,cp,   &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- environmental values on cloud levels
+!
+      call cup_env_clev(xt3,xqes3,xq3,xhe3,xhes3,xz3,po,xqes3_cup,xq3_cup, &
+           xhe3_cup,xhes3_cup,xz3_cup,po_cup,gamma3_cup,xt3_cup,psur,   &
+           ierr5,z1,xl,rv,cp,          &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!     
+!     
+!**************************** static control
+!     
+!--- moist static energy inside cloud
+!
+      do i=its,itf
+        if(ierr5(i).eq.0)then
+          xhkb3(i)=xhe3(i,k23(i))
+        endif
+      enddo
+      call cup_up_he(k23,xhkb3,xz3_cup,cd3,mentr_rate3,xhe3_cup,xhc3, &
+           kbcon3,ierr5,xdby3,xhe3,xhes3_cup,'shallow', &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!          
+!c--- normalized mass flux profile and CWF
+!          
+      call cup_up_nms(xzu3,xz3_cup,mentr_rate3,cd3,kbcon3,ktop3,ierr5,k23, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_up_aa0(xaa3,xz3,xzu3,xdby3,GAMMA3_CUP,xt3_cup, &
+           kbcon3,ktop3,ierr5,           &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+! now for shallow forcing
+!
+       do i=its,itf
+        xmb3(i)=0.
+        xff_shal(1:9)=0.
+        if(ierr5(i).eq.0)then
+          xkshal=(xaa3(i)-aa3(i))/mbdt_s
+          if(xkshal.gt.0.)xkshal=+1.e6
+          if(xkshal.gt.-1.e-4 .and. xkshal.lt.0.)xkshal=-1.e-4
+          xff_shal(1)=max(0.,-(aa3(i)-aa3_0(i))/(xkshal*dtime))
+          xff_shal(2)=max(0.,-(aa3(i)-aa3_0(i))/(xkshal*dtime))
+          xff_shal(3)=max(0.,-(aa3(i)-aa3_0(i))/(xkshal*dtime))
+          if(aa3_0(i).le.0)then
+           xff_shal(1)=0.
+           xff_shal(2)=0.
+           xff_shal(3)=0.
+          endif
+          if(aa3(i)-aa3_0(i).le.0.)then
+           xff_shal(1)=0.
+           xff_shal(2)=0.
+           xff_shal(3)=0.
+          endif
+! boundary layer QE (from Saulo Freitas)
+          blqe=0.
+          trash=0.
+          if(k23(i).lt.kpbl(i)+1)then
+             do k=1,kbcon3(i)-1
+                blqe=blqe+100.*dhdt(i,k)*(p_cup(i,k)-p_cup(i,k+1))/g
+             enddo
+             trash=max((hc3(i,kbcon3(i))-he_cup(i,kbcon3(i))),1.e1)
+             xff_shal(7)=max(0.,blqe/trash)
+             xff_shal(7)=min(0.1,xff_shal(7))
+          else
+             xff_shal(7)=0.
+          endif
+          if((xkshal.lt.-1.1e-04) .and.  &
+             ((aa3(i)-aa3_0(i).gt.0.) .or. (xff_shal(7).gt.0)))then
+          xff_shal(4)=max(0.,-aa3(i)/(xkshal*tscl_KF))
+          xff_shal(4)=min(0.1,xff_shal(4))
+          xff_shal(5)=xff_shal(4)
+          xff_shal(6)=xff_shal(4)
+          else
+           xff_shal(4)=0.
+           xff_shal(5)=0.
+           xff_shal(6)=0.
+          endif
+!         write(0,888)'i0=',i,j,kpbl(i),blqe,xff_shal(7)
+888       format(a3,3(1x,i3),2e12.4)
+          xff_shal(8)= xff_shal(7)
+          xff_shal(9)= xff_shal(7)
+          do k=1,9
+           xmb3(i)=xmb3(i)+xff_shal(k)
+          enddo
+          xmb3(i)=min(.1,xmb3(i)/9.)
+!         if(xmb3(i).eq.10.1 )then
+!           write(0,*)'i0,xmb3,blqe,xkshal = ',i,j,xmb3(i),blqe,xkshal
+!           if(xff_shal(7).ge.0.1)then
+!             write(0,*)'i1,blqe,trash = ',blqe,trash
+!           endif
+!           if(xff_shal(7).eq.0 .and. xff_shal(1).ge.0.1)then
+!              write(0,*)'i2,aa3_0(i),aa3(i),xaa3(i) = ',aa3_0(i),aa3(i),xaa3(i)
+!           endif
+!           if(xff_shal(5).ge.0.1)then
+!              write(0,*)'i3,aa3(i),a0,xkshal= ',aa3(i),aa3_0(i),xkshal
+!           endif
+!           write(0,*)'i0, xff_shallow = ',xff_shal
+!         endif
+!!         if(xff_shal(7).eq.0 .and. xff_shal(4).gt.0 .and. xmb3(i).eq.0.5)then
+!!           write(0,*)'i4,xmb3 = ',i,j,xmb3(i),xkshal
+!!           write(0,*)'xff_shallow = ',xff_shal
+!!           write(0,*)aa3(i),xaa3(i),blqe
+!!         endif
+          if(xmb3(i).eq.0.)ierr5(i)=22
+          if(xmb3(i).lt.0.)then
+             ierr5(i)=21
+!            write(0,*)'neg xmb,i,j,xmb3 for shallow = ',i,j,k23(i),ktop3(i),kbcon3(i),kpbl(i)
+          endif
+        endif
+!         if(ierr5(i).eq.0)write(0,*)'i,j,xmb3 for shallow = ',i,j,xmb3(i),k23(i),ktop3(i)
+!         if(ierr5(i).eq.0.and.i.eq.12.and.j.eq.25)write(0,*)'i,j,xmb3 for shallow = ',k23(i),ktop3(i),kbcon3(i),kpbl(i)
+!         if(ierr5(i).eq.0)write(0,*)'i,j,xmb3 for shallow = ',i,j,k23(i),ktop3(i),kbcon3(i),kpbl(i)
+        if(ierr5(i).ne.0)then
+           k23(i)=0
+           kbcon3(i)=0
+           ktop3(i)=0
+           xmb3(i)=0
+           do k=kts,ktf
+              outts(i,k)=0.
+              outqs(i,k)=0.
+           enddo
+        else if(ierr5(i).eq.0)then
+!
+! got the mass flux, sanity check, first for heating rates
+!
+          trash=0.
+          do k=2,ktop3(i)
+           trash=max(trash,86400.*(dsubt3(i,k)+dellat3(i,k))*xmb3(i))
+          enddo
+          if(trash.gt.150.)xmb3(i)=xmb3(i)*150./trash
+!
+! sanity check on moisture tendencies: do not allow anything that may allow neg tendencies
+!
+          do k=2,ktop3(i)
+           trash=q(i,k)+(dsubq3(i,k)+dellaq3(i,k))*xmb3(i)*dtime
+          if(trash.lt.1.e-12)then
+! max allowable tendency over tendency that would lead to too small mix ratios
+!
+            trash=((1.e-12-q(i,k))/dtime)                   &
+                  /((dsubq3(i,k)+dellaq3(i,k))*xmb3(i))
+            trash=max(0.,trash)
+            trash=min(1.,trash)
+            xmb3(i)=trash*xmb3(i)
+          endif
+          enddo
+! 
+! final tendencies
+!
+          do k=2,ktop3(i)
+           outts(i,k)=(dsubt3(i,k)+dellat3(i,k))*xmb3(i)
+           outqs(i,k)=(dsubq3(i,k)+dellaq3(i,k))*xmb3(i)
+          enddo
+        endif
+       enddo
+!       if(j.eq.-25)then
+!!        write(0,*)'!!!!!!!! j = ',j,' !!!!!!!!!!!!!!!!!!!!'
+        i=12
+!        write(0,*)k23(i),kbcon3(i),ktop3(i)
+!        write(0,*)kpbl(i),ierr5(i),ierr(i)
+!        write(0,*)xmb3(i),xff_shal(1:9)
+!        write(0,*)xaa3(i),aa1(i),aa0(i),aa3(i)
+!        do k=1,ktf
+!          write(0,*)po(i,k),he3(i,k),hes3(i,k),dellah3(i,k)
+!        enddo
+!        do k=1,ktf
+!          write(0,*)zu3(i,k),hc3(i,k),dsubt3(i,k),dellat3(i,k)
+!        enddo
+!        do k=1,ktop3(i)+1
+!          blqe=cp*outts(i,k)+xl*outqs(i,k)
+!          write(0,*)outts(i,k),outqs(i,k),blqe
+!        enddo
+!       endif
+!      
+! done shallow
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+       ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+      call cup_axx(tcrit,kbmax,z1,p,psur,xl,rv,cp,tx,qx,axx,ierr,    &
+           cap_max,cap_max_increment,entr_rate,mentr_rate,&
+           j,itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte,ens4)
+
+!
+!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR
+!
+      call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, &
+           pwevo,edtmax,edtmin,maxens2,edtc, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      do 250 iedt=1,maxens2
+        do i=its,itf
+         if(ierr(i).eq.0)then
+         edt(i)=edtc(i,iedt)
+         edto(i)=edtc(i,iedt)
+         edtx(i)=edtc(i,iedt)
+         edt_out(i,j)=edtc(i,2)
+         if(high_resolution.eq.1)then
+            edt(i)=edtc(i,3)
+            edto(i)=edtc(i,3)
+            edtx(i)=edtc(i,3)
+            edt_out(i,j)=edtc(i,3)
+         endif
+         endif
+        enddo
+        do k=kts,ktf
+        do i=its,itf
+           subt_ens(i,k,iedt)=0.
+           subq_ens(i,k,iedt)=0.
+           dellat_ens(i,k,iedt)=0.
+           dellaq_ens(i,k,iedt)=0.
+           dellaqc_ens(i,k,iedt)=0.
+           pwo_ens(i,k,iedt)=0.
+        enddo
+        enddo
+!
+!      if(j.eq.jpr.and.iedt.eq.1.and.ipr.gt.its.and.ipr.lt.ite)then
+!!      if(j.eq.jpr)then
+!         i=ipr
+!!        write(0,*)'in 250 loop ',iedt,edt(ipr),ierr(ipr)
+!!       if(ierr(i).eq.0.or.ierr(i).eq.3)then
+!         write(0,*)'250',k22(I),kbcon(i),ktop(i),jmin(i)
+!         write(0,*)edt(i),aa0(i),aa1(i)
+!         do k=kts,ktf
+!           write(0,*)k,z(i,k),he(i,k),hes(i,k)
+!         enddo
+!         write(0,*)'end 250 loop ',iedt,edt(ipr),ierr(ipr)
+!         do k=1,ktop(i)+1
+!           write(0,*)zu(i,k),zd(i,k),pw(i,k),pwd(i,k)
+!         enddo
+!!        endif
+!      endif
+      do i=its,itf
+        aad(i)=0.
+      enddo
+!
+!--- change per unit mass that a model cloud would modify the environment
+!
+!--- 1. in bottom layer
+!
+      call cup_dellabot('deep',ipr,jpr,heo_cup,ierr,zo_cup,po,hcdo,edto, &
+           zdo,cdd,heo,dellah,dsubt,j,mentrd_rate,zo,g, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_dellabot('deep',ipr,jpr,qo_cup,ierr,zo_cup,po,qrcdo,edto, &
+           zdo,cdd,qo,dellaq,dsubq,j,mentrd_rate,zo,g,&
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- 2. everywhere else
+!
+      call cup_dellas_3d(ierr,zo_cup,po_cup,hcdo,edto,zdo,cdd,    &
+           heo,dellah,dsubt,j,mentrd_rate,zuo,g,                     &
+           cd,hco,ktop,k22,kbcon,mentr_rate,jmin,heo_cup,kdet, &
+           k22,ipr,jpr,'deep',high_resolution,                                 &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!-- take out cloud liquid water for detrainment
+!
+!??   do k=kts,ktf
+      do k=kts,ktf-1
+      do i=its,itf
+       scr1(i,k)=0.
+       dellaqc(i,k)=0.
+       if(ierr(i).eq.0)then
+         scr1(i,k)=qco(i,k)-qrco(i,k)
+         if(k.eq.ktop(i)-0)dellaqc(i,k)= &
+                      .01*zuo(i,ktop(i))*qrco(i,ktop(i))* &
+                      9.81/(po_cup(i,k)-po_cup(i,k+1))
+         if(k.lt.ktop(i).and.k.gt.kbcon(i))then
+           dz=zo_cup(i,k+1)-zo_cup(i,k)
+           dellaqc(i,k)=.01*9.81*cd(i,k)*dz*zuo(i,k) &
+                        *.5*(qrco(i,k)+qrco(i,k+1))/ &
+                        (po_cup(i,k)-po_cup(i,k+1))
+         endif
+       endif
+      enddo
+      enddo
+      call cup_dellas_3d(ierr,zo_cup,po_cup,qrcdo,edto,zdo,cdd, &
+           qo,dellaq,dsubq,j,mentrd_rate,zuo,g, &
+           cd,qco,ktop,k22,kbcon,mentr_rate,jmin,qo_cup,kdet, &
+           k22,ipr,jpr,'deep',high_resolution,               &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte    )
+!
+!--- using dellas, calculate changed environmental profiles
+!
+!     do 200 nens=1,maxens
+      mbdt=mbdt_ens(2)
+      do i=its,itf
+      xaa0_ens(i,1)=0.
+      xaa0_ens(i,2)=0.
+      xaa0_ens(i,3)=0.
+      enddo
+
+!      if(j.eq.jpr)then
+!               write(0,*)'xt',xl,'DELLAH(I,K),DELLAQ(I,K),dsubq(I,K),dsubt(i,k)'
+!      endif
+      do k=kts,ktf
+      do i=its,itf
+         dellat(i,k)=0.
+         if(ierr(i).eq.0)then
+            trash=dsubt(i,k)
+            XHE(I,K)=(dsubt(i,k)+DELLAH(I,K))*MBDT+HEO(I,K)
+            XQ(I,K)=(dsubq(i,k)+DELLAQ(I,K))*MBDT+QO(I,K)
+            DELLAT(I,K)=(1./cp)*(DELLAH(I,K)-xl*DELLAQ(I,K))
+            dSUBT(I,K)=(1./cp)*(dsubt(i,k)-xl*dsubq(i,k))
+            XT(I,K)= (DELLAT(I,K)+dsubt(i,k))*MBDT+TN(I,K)
+            IF(XQ(I,K).LE.0.)XQ(I,K)=1.E-08
+!             if(i.eq.ipr.and.j.eq.jpr)then
+!               write(0,*)k,trash,DELLAQ(I,K),dsubq(I,K),dsubt(i,k)
+!             endif
+         ENDIF
+      enddo
+      enddo
+      do i=its,itf
+      if(ierr(i).eq.0)then
+      XHE(I,ktf)=HEO(I,ktf)
+      XQ(I,ktf)=QO(I,ktf)
+      XT(I,ktf)=TN(I,ktf)
+      IF(XQ(I,ktf).LE.0.)XQ(I,ktf)=1.E-08
+      endif
+      enddo
+!
+!--- calculate moist static energy, heights, qes
+!
+      call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, &
+           psur,ierr,tcrit,2,xl,cp,   &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- environmental values on cloud levels
+!
+      call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, &
+           xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur,   &
+           ierr,z1,xl,rv,cp,          &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!
+!**************************** static control
+!
+!--- moist static energy inside cloud
+!
+      do i=its,itf
+        if(ierr(i).eq.0)then
+          xhkb(i)=xhe(i,k22(i))
+        endif
+      enddo
+      call cup_up_he(k22,xhkb,xz_cup,cd,mentr_rate,xhe_cup,xhc, &
+           kbcon,ierr,xdby,xhe,xhes_cup,'deep', &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!c--- normalized mass flux profile
+!
+      call cup_up_nms(xzu,xz_cup,mentr_rate,cd,kbcon,ktop,ierr,k22, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- moisture downdraft
+!
+      call cup_dd_nms(xzd,xz_cup,cdd,mentrd_rate,jmin,ierr, &
+           1,kdet,z1,                 &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_dd_he(xhes_cup,xzd,xhcd,xz_cup,cdd,mentrd_rate, &
+           jmin,ierr,xhe,dbyd,xhe_cup,&
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_dd_moisture_3d(xzd,xhcd,xhes_cup,xqcd,xqes_cup, &
+           xpwd,xq_cup,xz_cup,cdd,mentrd_rate,jmin,ierr,gamma_cup, &
+           xpwev,bu,xqrcd,xq,xhe,xt_cup,3,xl,high_resolution, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+
+!
+!------- MOISTURE updraft
+!
+      call cup_up_moisture('deep',ierr,xz_cup,xqc,xqrc,xpw,xpwav, &
+           kbcon,ktop,cd,xdby,mentr_rate,clw_all, &
+           xq,GAMMA_cup,xzu,xqes_cup,k22,xq_cup,xl, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- workfunctions for updraft
+!
+      call cup_up_aa0(xaa0,xz,xzu,xdby,GAMMA_CUP,xt_cup, &
+           kbcon,ktop,ierr,           &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      do 200 nens=1,maxens
+      do i=its,itf 
+         if(ierr(i).eq.0)then
+           xaa0_ens(i,nens)=xaa0(i)
+           nall=(iens-1)*maxens3*maxens*maxens2 &
+                +(iedt-1)*maxens*maxens3 &
+                +(nens-1)*maxens3
+           do k=kts,ktf
+              if(k.le.ktop(i))then
+                 do nens3=1,maxens3
+                 if(nens3.eq.7)then
+!--- b=0
+                 pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)  &
+                                 +edto(i)*pwdo(i,k)             &
+                                    +pwo(i,k) 
+!--- b=beta
+                 else if(nens3.eq.8)then
+                 pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ &
+                                    pwo(i,k)
+!--- b=beta/2
+                 else if(nens3.eq.9)then
+                 pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)  &
+                                 +.5*edto(i)*pwdo(i,k)          &
+                                 +  pwo(i,k)
+                 else
+                 pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ &
+                                    pwo(i,k)+edto(i)*pwdo(i,k)
+                 endif
+                 enddo
+              endif
+           enddo
+         if(pr_ens(i,j,nall+7).lt.1.e-6)then
+            ierr(i)=18
+            do nens3=1,maxens3
+               pr_ens(i,j,nall+nens3)=0.
+            enddo
+         endif
+         do nens3=1,maxens3
+           if(pr_ens(i,j,nall+nens3).lt.1.e-4)then
+            pr_ens(i,j,nall+nens3)=0.
+           endif
+         enddo
+         endif
+      enddo
+ 200  continue
+!
+!--- LARGE SCALE FORCING
+!
+!
+!------- CHECK wether aa0 should have been zero
+!
+!
+      CALL cup_MAXIMI(HEO_CUP,3,KBMAX,K22x,ierr, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      do i=its,itf
+         ierr2(i)=ierr(i)
+         ierr3(i)=ierr(i)
+      enddo
+      call cup_kbcon(cap_max_increment,2,k22x,kbconx,heo_cup, &
+           heso_cup,ierr2,kbmax,po_cup,cap_max, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      call cup_kbcon(cap_max_increment,3,k22x,kbconx,heo_cup, &
+           heso_cup,ierr3,kbmax,po_cup,cap_max, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
+!
+
+      call cup_forcing_ens_3d(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt_ens,dtime,   &
+           ierr,ierr2,ierr3,xf_ens,j,'deeps',axx,                 &
+           maxens,iens,iedt,maxens2,maxens3,mconv,            &
+           po_cup,ktop,omeg,zdo,k22,zuo,pr_ens,edto,kbcon,    &
+           massflx,iact,direction,ensdim,massfln,ichoice,edt_out,     &
+           high_resolution,itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte,ens4,ktau)
+!
+      do k=kts,ktf
+      do i=its,itf
+        if(ierr(i).eq.0)then
+           subt_ens(i,k,iedt)=dsubt(i,k)
+           subq_ens(i,k,iedt)=dsubq(i,k)
+           dellat_ens(i,k,iedt)=dellat(i,k)
+           dellaq_ens(i,k,iedt)=dellaq(i,k)
+           dellaqc_ens(i,k,iedt)=dellaqc(i,k)
+           pwo_ens(i,k,iedt)=pwo(i,k)+edt(i)*pwdo(i,k)
+        else 
+           subt_ens(i,k,iedt)=0.
+           subq_ens(i,k,iedt)=0.
+           dellat_ens(i,k,iedt)=0.
+           dellaq_ens(i,k,iedt)=0.
+           dellaqc_ens(i,k,iedt)=0.
+           pwo_ens(i,k,iedt)=0.
+        endif
+!       if(i.eq.ipr.and.j.eq.jpr)then
+!         write(0,*)'1',iens,iedt,dellat(i,k),dellat_ens(i,k,iedt), &
+!           dellaq(i,k), dellaqc(i,k)
+!         write(0,*)'2',k,subt_ens(i,k,iedt),subq_ens(i,k,iedt)
+!       endif
+      enddo
+      enddo
+ 250  continue
+!
+!--- FEEDBACK
+!
+      call cup_output_ens_3d(xf_ens,ierr,dellat_ens,dellaq_ens, &
+           dellaqc_ens,subt_ens,subq_ens,subt,subq,outt,     &
+           outq,outqc,zuo,sub_mas,pre,pwo_ens,xmb,ktop,      &
+           j,'deep',maxens2,maxens,iens,ierr2,ierr3,         &
+           pr_ens,maxens3,ensdim,massfln,                    &
+           APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                &
+           APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1,   &
+           itf,jtf,ktf,                        &
+           its,ite, jts,jte, kts,kte)
+      k=1
+      do i=its,itf
+          if(ierr(i).eq.0.and.ierr5(i).eq.0.and.kbcon(i).lt.ktop3(i)+1)then
+!            write(0,*)'both ier and ier5=0 at i,j=',i,j,kbcon(i),ktop3(i)
+             if(high_resolution.eq.1)then
+                outts(i,kts:kte)=0.
+                outqs(i,kts:kte)=0.
+             endif
+          elseif (ierr5(i).eq.0)then
+!            write(0,*)'ier5=0 at i,j=',i,j,k23(i),ktop3(i)
+          endif
+
+           PRE(I)=MAX(PRE(I),0.)
+!           if(i.eq.ipr.and.j.eq.jpr)then
+!             write(0,*)'i,j,pre(i),aa0(i),aa1(i)'
+!             write(0,*)i,j,pre(i),aa0(i)
+!           endif
+      enddo
+!
+!---------------------------done------------------------------
+!
+!      do i=its,itf
+!        if(ierr(i).eq.0)then
+!       if(i.eq.ipr.and.j.eq.jpr)then
+!         write(0,*)'on output, pre =',pre(i),its,itf,kts,ktf
+!         do k=kts,ktf
+!           write(0,*)z(i,k),outt(i,k)*86400.,subt(i,k)*86400.
+!         enddo
+!         write(0,*)i,j,(axx(i,k),k=1,ens4)
+!       endif
+!       endif
+!      enddo
+!     print *,'ierr(i) = ',ierr(i),pre(i)
+
+   END SUBROUTINE CUP_enss_3d
+
+
+   SUBROUTINE cup_dd_aa0(edt,ierr,aa0,jmin,gamma_cup,t_cup, &
+              hcd,hes_cup,z,zd,                             &
+              itf,jtf,ktf,                    &
+              its,ite, jts,jte, kts,kte                    )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,jtf,ktf,                                     &
+        its,ite, jts,jte, kts,kte
+  ! aa0 cloud work function for downdraft
+  ! gamma_cup = gamma on model cloud levels
+  ! t_cup = temperature (Kelvin) on model cloud levels
+  ! hes_cup = saturation moist static energy on model cloud levels
+  ! hcd = moist static energy in downdraft
+  ! edt = epsilon
+  ! zd normalized downdraft mass flux
+  ! z = heights of model levels 
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        z,zd,gamma_cup,t_cup,hes_cup,hcd
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        edt
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        jmin
+!
+! input and output
+!
+
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        aa0
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k,kk
+     real                                 ::                           &
+        dz
+!
+       do i=its,itf
+        aa0(i)=0.
+       enddo
+!
+!??    DO k=kts,kte-1
+       DO k=kts,ktf-1
+       do i=its,itf
+         IF(ierr(I).eq.0.and.k.lt.jmin(i))then
+         KK=JMIN(I)-K
+!
+!--- ORIGINAL
+!
+         DZ=(Z(I,KK)-Z(I,KK+1))
+         AA0(I)=AA0(I)+zd(i,kk)*EDT(I)*DZ*(9.81/(1004.*T_cup(I,KK))) &
+            *((hcd(i,kk)-hes_cup(i,kk))/(1.+GAMMA_cup(i,kk)))
+         endif
+      enddo
+      enddo
+
+   END SUBROUTINE CUP_dd_aa0
+
+
+   SUBROUTINE cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, &
+              pwev,edtmax,edtmin,maxens2,edtc,               &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,jtf,ktf,           &
+        its,ite, jts,jte, kts,kte
+     integer, intent (in   )              ::                           &
+        maxens2
+  !
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        us,vs,z,p
+     real,    dimension (its:ite,1:maxens2)                            &
+        ,intent (out  )                   ::                           &
+        edtc
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        edt
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        pwav,pwev
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        edtmax,edtmin
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        ktop,kbcon
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+!
+!  local variables in this routine
+!
+
+     integer i,k,kk
+     real    einc,pef,pefb,prezk,zkbc
+     real,    dimension (its:ite)         ::                           &
+      vshear,sdp,vws
+
+!
+!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR
+!
+! */ calculate an average wind shear over the depth of the cloud
+!
+       do i=its,itf
+        edt(i)=0.
+        vws(i)=0.
+        sdp(i)=0.
+        vshear(i)=0.
+       enddo
+       do k=1,maxens2
+       do i=its,itf
+        edtc(i,k)=0.
+       enddo
+       enddo
+       do kk = kts,ktf-1
+         do 62 i=its,itf
+          IF(ierr(i).ne.0)GO TO 62
+          if (kk .le. min0(ktop(i),ktf) .and. kk .ge. kbcon(i)) then
+             vws(i) = vws(i)+ &
+              (abs((us(i,kk+1)-us(i,kk))/(z(i,kk+1)-z(i,kk))) &
+          +   abs((vs(i,kk+1)-vs(i,kk))/(z(i,kk+1)-z(i,kk)))) * &
+              (p(i,kk) - p(i,kk+1))
+            sdp(i) = sdp(i) + p(i,kk) - p(i,kk+1)
+          endif
+          if (kk .eq. ktf-1)vshear(i) = 1.e3 * vws(i) / sdp(i)
+   62   continue
+       end do
+      do i=its,itf
+         IF(ierr(i).eq.0)then
+            pef=(1.591-.639*VSHEAR(I)+.0953*(VSHEAR(I)**2) &
+               -.00496*(VSHEAR(I)**3))
+            if(pef.gt.1.)pef=1.
+            if(pef.lt.0.)pef=0.
+!
+!--- cloud base precip efficiency
+!
+            zkbc=z(i,kbcon(i))*3.281e-3
+            prezk=.02
+            if(zkbc.gt.3.)then
+               prezk=.96729352+zkbc*(-.70034167+zkbc*(.162179896+zkbc &
+               *(- 1.2569798E-2+zkbc*(4.2772E-4-zkbc*5.44E-6))))
+            endif
+            if(zkbc.gt.25)then
+               prezk=2.4
+            endif
+            pefb=1./(1.+prezk)
+            if(pefb.gt.1.)pefb=1.
+            if(pefb.lt.0.)pefb=0.
+            EDT(I)=1.-.5*(pefb+pef)
+!--- edt here is 1-precipeff!
+            einc=.2*edt(i)
+            do k=1,maxens2
+                edtc(i,k)=edt(i)+float(k-2)*einc
+            enddo
+         endif
+      enddo
+      do i=its,itf
+         IF(ierr(i).eq.0)then
+            do k=1,maxens2
+               EDTC(I,K)=-EDTC(I,K)*PWAV(I)/PWEV(I)
+               IF(EDTC(I,K).GT.edtmax)EDTC(I,K)=edtmax
+               IF(EDTC(I,K).LT.edtmin)EDTC(I,K)=edtmin
+            enddo
+         endif
+      enddo
+
+   END SUBROUTINE cup_dd_edt
+
+
+   SUBROUTINE cup_dd_he(hes_cup,zd,hcd,z_cup,cdd,entr,       &
+              jmin,ierr,he,dby,he_cup,                       &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+                                  itf,jtf,ktf,           &
+                                  its,ite, jts,jte, kts,kte
+  ! hcd = downdraft moist static energy
+  ! he = moist static energy on model levels
+  ! he_cup = moist static energy on model cloud levels
+  ! hes_cup = saturation moist static energy on model cloud levels
+  ! dby = buoancy term
+  ! cdd= detrainment function 
+  ! z_cup = heights of model cloud levels 
+  ! entr = entrainment rate
+  ! zd   = downdraft normalized mass flux
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        he,he_cup,hes_cup,z_cup,cdd,zd
+  ! entr= entrainment rate 
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        entr
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        jmin
+!
+! input and output
+!
+
+   ! ierr error value, maybe modified in this routine
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        hcd,dby
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k,ki
+     real                                 ::                           &
+        dz
+
+
+      do k=kts+1,ktf
+      do i=its,itf
+      dby(i,k)=0.
+      IF(ierr(I).eq.0)then
+         hcd(i,k)=hes_cup(i,k)
+      endif
+      enddo
+      enddo
+!
+      do 100 i=its,itf
+      IF(ierr(I).eq.0)then
+      k=jmin(i)
+      hcd(i,k)=hes_cup(i,k)
+      dby(i,k)=hcd(i,jmin(i))-hes_cup(i,k)
+!
+      do ki=jmin(i)-1,1,-1
+         DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki)
+         HCD(i,Ki)=(HCD(i,Ki+1)*(1.-.5*CDD(i,Ki)*DZ) &
+                  +entr*DZ*HE(i,Ki) &
+                  )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ)
+         dby(i,ki)=HCD(i,Ki)-hes_cup(i,ki)
+      enddo
+!
+      endif
+!--- end loop over i
+100    continue
+
+
+   END SUBROUTINE cup_dd_he
+
+
+   SUBROUTINE cup_dd_moisture_3d(zd,hcd,hes_cup,qcd,qes_cup,    &
+              pwd,q_cup,z_cup,cdd,entr,jmin,ierr,            &
+              gamma_cup,pwev,bu,qrcd,                        &
+              q,he,t_cup,iloop,xl,high_resolution,           &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+                                  itf,jtf,ktf,           &
+                                  its,ite, jts,jte, kts,kte,high_resolution
+  ! cdd= detrainment function 
+  ! q = environmental q on model levels
+  ! q_cup = environmental q on model cloud levels
+  ! qes_cup = saturation q on model cloud levels
+  ! hes_cup = saturation h on model cloud levels
+  ! 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 
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        zd,t_cup,hes_cup,hcd,qes_cup,q_cup,z_cup,cdd,gamma_cup,q,he 
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        entr,xl
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        iloop
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        jmin
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        qcd,qrcd,pwd
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        pwev,bu
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k,ki
+     real                                 ::                           &
+        dh,dz,dqeva
+
+      do i=its,itf
+         bu(i)=0.
+         pwev(i)=0.
+      enddo
+      do k=kts,ktf
+      do i=its,itf
+         qcd(i,k)=0.
+         qrcd(i,k)=0.
+         pwd(i,k)=0.
+      enddo
+      enddo
+!
+!
+!
+      do 100 i=its,itf
+      IF(ierr(I).eq.0)then
+      k=jmin(i)
+      DZ=Z_cup(i,K+1)-Z_cup(i,K)
+      qcd(i,k)=q_cup(i,k)
+      if(high_resolution.eq.1)qcd(i,k)=.5*(qes_cup(i,k)+q_cup(i,k))
+      qrcd(i,k)=qes_cup(i,k)
+      pwd(i,jmin(i))=min(0.,qcd(i,k)-qrcd(i,k))
+      pwev(i)=pwev(i)+pwd(i,jmin(i))
+      qcd(i,k)=qes_cup(i,k)
+!
+      DH=HCD(I,k)-HES_cup(I,K)
+      bu(i)=dz*dh
+      do ki=jmin(i)-1,1,-1
+         DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki)
+         QCD(i,Ki)=(qCD(i,Ki+1)*(1.-.5*CDD(i,Ki)*DZ) &
+                  +entr*DZ*q(i,Ki) &
+                  )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ)
+!
+!--- to be negatively buoyant, hcd should be smaller than hes!
+!
+         DH=HCD(I,ki)-HES_cup(I,Ki)
+         bu(i)=bu(i)+dz*dh
+         QRCD(I,Ki)=qes_cup(i,ki)+(1./XL)*(GAMMA_cup(i,ki) &
+                  /(1.+GAMMA_cup(i,ki)))*DH
+         dqeva=qcd(i,ki)-qrcd(i,ki)
+         if(dqeva.gt.0.)dqeva=0.
+         pwd(i,ki)=zd(i,ki)*dqeva
+         qcd(i,ki)=qrcd(i,ki)
+         pwev(i)=pwev(i)+pwd(i,ki)
+!        if(iloop.eq.1.and.i.eq.102.and.j.eq.62)then
+!         print *,'in cup_dd_moi ', hcd(i,ki),HES_cup(I,Ki),dh,dqeva
+!        endif
+      enddo
+!
+!--- end loop over i
+       if(pwev(I).eq.0.and.iloop.eq.1)then
+!        print *,'problem with buoy in cup_dd_moisture',i
+         ierr(i)=7
+       endif
+       if(BU(I).GE.0.and.iloop.eq.1)then
+!        print *,'problem with buoy in cup_dd_moisture',i
+         ierr(i)=7
+       endif
+      endif
+100    continue
+
+   END SUBROUTINE cup_dd_moisture_3d
+
+
+   SUBROUTINE cup_dd_nms(zd,z_cup,cdd,entr,jmin,ierr,        &
+              itest,kdet,z1,                                 &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+                                  itf,jtf,ktf,           &
+                                  its,ite, jts,jte, kts,kte
+  ! z_cup = height of cloud model level
+  ! z1 = terrain elevation
+  ! entr = downdraft entrainment rate
+  ! jmin = downdraft originating level
+  ! kdet = level above ground where downdraft start detraining
+  ! itest = flag to whether to calculate cdd
+  
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        z_cup
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        z1 
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        entr 
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        jmin,kdet
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itest
+!
+! input and output
+!
+
+   ! ierr error value, maybe modified in this routine
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+                                                                 ierr
+   ! zd is the normalized downdraft mass flux
+   ! cdd is the downdraft detrainmen function
+
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+                                                             zd
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout)                   ::                           &
+                                                             cdd
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+                                                  i,k,ki
+     real                                 ::                           &
+                                            a,perc,dz
+
+!
+!--- perc is the percentage of mass left when hitting the ground
+!
+      perc=.03
+
+      do k=kts,ktf
+      do i=its,itf
+         zd(i,k)=0.
+         if(itest.eq.0)cdd(i,k)=0.
+      enddo
+      enddo
+      a=1.-perc
+!
+!
+!
+      do 100 i=its,itf
+      IF(ierr(I).eq.0)then
+      zd(i,jmin(i))=1.
+!
+!--- integrate downward, specify detrainment(cdd)!
+!
+      do ki=jmin(i)-1,1,-1
+         DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki)
+         if(ki.le.kdet(i).and.itest.eq.0)then
+           cdd(i,ki)=entr+(1.- (a*(z_cup(i,ki)-z1(i)) &
+                     +perc*(z_cup(i,kdet(i))-z1(i)) ) &
+                         /(a*(z_cup(i,ki+1)-z1(i)) &
+                      +perc*(z_cup(i,kdet(i))-z1(i))))/dz
+         endif
+         zd(i,ki)=zd(i,ki+1)*(1.+(entr-cdd(i,ki))*dz)
+      enddo
+!
+      endif
+!--- end loop over i
+100    continue
+
+   END SUBROUTINE cup_dd_nms
+
+
+   SUBROUTINE cup_dellabot(name,ipr,jpr,he_cup,ierr,z_cup,p_cup,  &
+              hcd,edt,zd,cdd,he,della,subs,j,mentrd_rate,z,g,     &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,jtf,ktf,           &
+        its,ite, jts,jte, kts,kte
+     integer, intent (in   )              ::                           &
+        j,ipr,jpr
+      character *(*), intent (in)        ::                           &
+       name
+  !
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        della,subs
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in  )                   ::                           &
+        z_cup,p_cup,hcd,zd,cdd,he,z,he_cup
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        edt
+     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
+!
+!
+!     if(name.eq.'shallow')then
+!        edt(:)=0.
+!        cdd(:,:)=0.
+!     endif
+      do 100 i=its,itf
+      della(i,1)=0.
+      subs(i,1)=0.
+      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
+      DELLA(I,1)=(detdo1*.5*(HCD(i,1)+HCD(i,2)) &
+                 +detdo2*hcd(i,1) &
+                 +subin*he_cup(i,2) &
+                 -entdo*he(i,1))*g/dp
+      SUBS(I,1)=0.
+!      if(i.eq.ipr.and.j.eq.jpr)then
+!       write(0,*)'db1',della(i,1),subs(i,1),subin,entdo
+!       write(0,*)'db2',detdo1,detdo2,detdo1+detdo2-entdo+subin
+!      endif
+ 100  CONTINUE
+
+   END SUBROUTINE cup_dellabot
+
+
+   SUBROUTINE cup_dellas_3d(ierr,z_cup,p_cup,hcd,edt,zd,cdd,              &
+              he,della,subs,j,mentrd_rate,zu,g,                             &
+              cd,hc,ktop,k22,kbcon,mentr_rate,jmin,he_cup,kdet,kpbl,   &
+              ipr,jpr,name,high_res,                                            &
+              itf,jtf,ktf,                               &
+              its,ite, jts,jte, kts,kte                               )
+
+   IMPLICIT NONE
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,jtf,ktf,           &
+        its,ite, jts,jte, kts,kte
+     integer, intent (in   )              ::                           &
+        j,ipr,jpr,high_res
+  !
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        della,subs
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in  )                   ::                           &
+        z_cup,p_cup,hcd,zd,cdd,he,hc,cd,zu,he_cup
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        edt
+     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,kstart
+      real detdo1,detdo2,entdo,dp,dz,subin,detdo,entup,                &
+      detup,subdown,entdoj,entupk,detupk,totmas
+!
+      i=ipr
+      kstart=kts+1
+      if(name.eq.'shallow')kstart=kts
+       DO K=kstart,ktf
+       do i=its,itf
+          della(i,k)=0.
+          subs(i,k)=0.
+       enddo
+       enddo
+!
+! no downdrafts for shallow convection
+!
+       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
+         if(k.lt.k22(i)-1.and.name.eq.'shallow')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)
+!3d        subin=zu(i,k+1)-zd(i,k+1)*edt(i)
+         subin=-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
+!3d        subdown=(zu(i,k)-zd(i,k)*edt(i))
+         subdown=-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))
+         subin=zu(i,k+1)-zd(i,k+1)*edt(i)
+         if(high_res.eq.1)subin=-zd(i,k+1)*edt(i)
+!        subin=-zd(i,k+1)*edt(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.
+!
+! this subsidene for ktop now in subs term!
+!        subdown=zu(i,k)
+         subdown=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,
+!     1   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 ( 'totmas .gt.1.e-6' )
+         endif
+         dp=100.*(p_cup(i,k-1)-p_cup(i,k))
+         della(i,k)=(detup*.5*(HC(i,K+1)+HC(i,K)) &
+                    +detdo*.5*(HCD(i,K+1)+HCD(i,K)) &
+                    -entup*he(i,k) &
+                    -entdo*he(i,k) &
+                    +subin*he_cup(i,k+1) &
+                    -subdown*he_cup(i,k) &
+                    +detupk*(hc(i,ktop(i))-he_cup(i,ktop(i)))    &
+                    -entupk*he_cup(i,k22(i)) &
+                    -entdoj*he_cup(i,jmin(i)) &
+                     )*g/dp
+           if(high_res.eq.1)then
+! the first term includes entr and detr into/from updraft as well as (entup-detup)*he(i,k) from
+!  neighbouring point, to make things mass consistent....
+!            if(k.ge.k22(i))then
+                della(i,k)=(                          &
+                    detup*.5*(HC(i,K+1)+HC(i,K))-entup*he(i,k)+(entup-detup)*he(i,k) &
+                    +detdo*.5*(HCD(i,K+1)+HCD(i,K)) &
+                    -entdo*he(i,k) &
+                    +subin*he_cup(i,k+1) &
+                    -subdown*he_cup(i,k) &
+                    +detupk*(hc(i,ktop(i))-he(i,ktop(i)))    &
+                    -entdoj*he_cup(i,jmin(i)) &
+                    -entupk*he_cup(i,k22(i))+entupk*he(i,k) &
+                     )*g/dp
+!             else if(k.eq.k22(i)-1)then
+!                  della(i,k)=(-entupk*he_cup(i,k22(i))+entupk*he(i,k))*g/dp
+           endif
+!3d        subin=zu(i,k+1)-zd(i,k+1)*edt(i)
+!
+! updraft subsidence only
+!
+         if(k.ge.k22(i).and.k.lt.ktop(i))then
+         subs(i,k)=(zu(i,k+1)*he_cup(i,k+1) &
+                    -zu(i,k)*he_cup(i,k))*g/dp
+!        else if(k.eq.ktop(i))then
+!        subs(i,k)=-detupk*he_cup(i,k)*g/dp
+         endif
+!
+! in igh res case, subsidence terms are for meighbouring points only. This has to be 
+! done mass consistent with the della term
+         if(high_res.eq.1)then
+            if(k.ge.k22(i).and.k.lt.ktop(i))then
+               subs(i,k)=(zu(i,k+1)*he_cup(i,k+1)-zu(i,k)*he_cup(i,k)-(entup-detup)*he(i,k))*g/dp
+            else if(k.eq.ktop(i))then
+               subs(i,k)=detupk*(he(i,ktop(i))-he_cup(i,ktop(i)))*g/dp
+            else if(k.eq.k22(i)-1)then
+               subs(i,k)=(entupk*he(i,k)-entupk*he_cup(i,k))*g/dp
+         endif
+         endif
+!       if(i.eq.ipr.and.j.eq.jpr)then
+!         write(0,*)'d',k,della(i,k),subs(i,k),subin,subdown
+!!        write(0,*)'d',detup,entup,entdo,entupk,entdoj
+!!        print *,k,della(i,k),subin*he_cup(i,k+1),subdown*he_cup(i,k),
+!!     1            detdo*.5*(HCD(i,K+1)+HCD(i,K))
+!!        print *,k,detup*.5*(HC(i,K+1)+HC(i,K)),detupk*hc(i,ktop(i)),
+!!     1         entup*he(i,k),entdo*he(i,k)
+!!        print *,k,he_cup(i,k+1),he_cup(i,k),entupk*he_cup(i,k)
+!       endif
+
+ 100  CONTINUE
+
+   END SUBROUTINE cup_dellas_3d
+
+
+   SUBROUTINE cup_direction2(i,j,dir,id,massflx,             &
+              iresult,imass,massfld,                         &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,jtf,ktf,           &
+        its,ite, jts,jte, kts,kte
+     integer, intent (in   )              ::                           &
+        i,j,imass
+     integer, intent (out  )              ::                           &
+        iresult
+  !
+  ! ierr error value, maybe modified in this routine
+  !
+     integer,    dimension (its:ite,jts:jte)                           &
+        ,intent (in   )                   ::                           &
+        id
+     real,    dimension (its:ite,jts:jte)                              &
+        ,intent (in   )                   ::                           &
+        massflx
+     real,    dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        dir
+     real                                                              &
+        ,intent (out  )                   ::                           &
+        massfld
+!
+!  local variables in this routine
+!
+
+       integer k,ia,ja,ib,jb
+       real diff
+!
+!
+!
+       if(imass.eq.1)then
+           massfld=massflx(i,j)
+       endif
+       iresult=0
+!      return
+       diff=22.5
+       if(dir(i).lt.22.5)dir(i)=360.+dir(i)
+       if(id(i,j).eq.1)iresult=1
+!      ja=max(2,j-1)
+!      ia=max(2,i-1)
+!      jb=min(mjx-1,j+1)
+!      ib=min(mix-1,i+1)
+       ja=j-1
+       ia=i-1
+       jb=j+1
+       ib=i+1
+        if(dir(i).gt.90.-diff.and.dir(i).le.90.+diff)then
+!--- steering flow from the east
+          if(id(ib,j).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(ib,j),massflx(i,j))
+            endif
+            return
+          endif
+        else if(dir(i).gt.135.-diff.and.dir(i).le.135.+diff)then
+!--- steering flow from the south-east
+          if(id(ib,ja).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(ib,ja),massflx(i,j))
+            endif
+            return
+          endif
+!--- steering flow from the south
+        else if(dir(i).gt.180.-diff.and.dir(i).le.180.+diff)then
+          if(id(i,ja).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(i,ja),massflx(i,j))
+            endif
+            return
+          endif
+!--- steering flow from the south west
+        else if(dir(i).gt.225.-diff.and.dir(i).le.225.+diff)then
+          if(id(ia,ja).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(ia,ja),massflx(i,j))
+            endif
+            return
+          endif
+!--- steering flow from the west
+        else if(dir(i).gt.270.-diff.and.dir(i).le.270.+diff)then
+          if(id(ia,j).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(ia,j),massflx(i,j))
+            endif
+            return
+          endif
+!--- steering flow from the north-west
+        else if(dir(i).gt.305.-diff.and.dir(i).le.305.+diff)then
+          if(id(ia,jb).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(ia,jb),massflx(i,j))
+            endif
+            return
+          endif
+!--- steering flow from the north
+        else if(dir(i).gt.360.-diff.and.dir(i).le.360.+diff)then
+          if(id(i,jb).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(i,jb),massflx(i,j))
+            endif
+            return
+          endif
+!--- steering flow from the north-east
+        else if(dir(i).gt.45.-diff.and.dir(i).le.45.+diff)then
+          if(id(ib,jb).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(ib,jb),massflx(i,j))
+            endif
+            return
+          endif
+        endif
+
+   END SUBROUTINE cup_direction2
+
+
+   SUBROUTINE cup_env(z,qes,he,hes,t,q,p,z1,                 &
+              psur,ierr,tcrit,itest,xl,cp,                   &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,jtf,ktf,           &
+        its,ite, jts,jte, kts,kte
+  !
+  ! ierr error value, maybe modified in this routine
+  ! q           = environmental mixing ratio
+  ! qes         = environmental saturation mixing ratio
+  ! t           = environmental temp
+  ! tv          = environmental virtual temp
+  ! p           = environmental pressure
+  ! z           = environmental heights
+  ! he          = environmental moist static energy
+  ! hes         = environmental saturation moist static energy
+  ! psur        = surface pressure
+  ! z1          = terrain elevation
+  ! 
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        p,t,q
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        he,hes,qes
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout)                   ::                           &
+        z
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        psur,z1
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        xl,cp
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itest
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+       i,k,iph
+      real, dimension (1:2) :: AE,BE,HT
+      real, dimension (its:ite,kts:kte) :: tv
+      real :: tcrit,e,tvbar
+
+
+      HT(1)=XL/CP
+      HT(2)=2.834E6/CP
+      BE(1)=.622*HT(1)/.286
+      AE(1)=BE(1)/273.+ALOG(610.71)
+      BE(2)=.622*HT(2)/.286
+      AE(2)=BE(2)/273.+ALOG(610.71)
+!      print *, 'TCRIT = ', tcrit,its,ite
+      DO k=kts,ktf
+      do i=its,itf
+        if(ierr(i).eq.0)then
+!Csgb - IPH is for phase, dependent on TCRIT (water or ice)
+        IPH=1
+        IF(T(I,K).LE.TCRIT)IPH=2
+!       print *, 'AE(IPH),BE(IPH) = ',AE(IPH),BE(IPH),AE(IPH)-BE(IPH),T(i,k),i,k
+        E=EXP(AE(IPH)-BE(IPH)/T(I,K))
+!       print *, 'P, E = ', P(I,K), E
+        QES(I,K)=.622*E/(100.*P(I,K)-E)
+        IF(QES(I,K).LE.1.E-08)QES(I,K)=1.E-08
+        IF(QES(I,K).LT.Q(I,K))QES(I,K)=Q(I,K)
+!       IF(Q(I,K).GT.QES(I,K))Q(I,K)=QES(I,K)
+        TV(I,K)=T(I,K)+.608*Q(I,K)*T(I,K)
+        endif
+      enddo
+      enddo
+!
+!--- z's are calculated with changed h's and q's and t's
+!--- if itest=2
+!
+      if(itest.ne.2)then
+         do i=its,itf
+           if(ierr(i).eq.0)then
+             Z(I,1)=max(0.,Z1(I))-(ALOG(P(I,1))- &
+                 ALOG(PSUR(I)))*287.*TV(I,1)/9.81
+           endif
+         enddo
+
+! --- calculate heights
+         DO K=kts+1,ktf
+         do i=its,itf
+           if(ierr(i).eq.0)then
+              TVBAR=.5*TV(I,K)+.5*TV(I,K-1)
+              Z(I,K)=Z(I,K-1)-(ALOG(P(I,K))- &
+               ALOG(P(I,K-1)))*287.*TVBAR/9.81
+           endif
+         enddo
+         enddo
+      else
+         do k=kts,ktf
+         do i=its,itf
+           if(ierr(i).eq.0)then
+             z(i,k)=(he(i,k)-1004.*t(i,k)-2.5e6*q(i,k))/9.81
+             z(i,k)=max(1.e-3,z(i,k))
+           endif
+         enddo
+         enddo
+      endif
+!
+!--- calculate moist static energy - HE
+!    saturated moist static energy - HES
+!
+       DO k=kts,ktf
+       do i=its,itf
+         if(ierr(i).eq.0)then
+         if(itest.eq.0)HE(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*Q(I,K)
+         HES(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*QES(I,K)
+         IF(HE(I,K).GE.HES(I,K))HE(I,K)=HES(I,K)
+         endif
+      enddo
+      enddo
+
+   END SUBROUTINE cup_env
+
+
+   SUBROUTINE 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,                                &
+              itf,jtf,ktf,                       &
+              its,ite, jts,jte, kts,kte                       )
+
+   IMPLICIT NONE
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,jtf,ktf,           &
+        its,ite, jts,jte, kts,kte
+  !
+  ! ierr error value, maybe modified in this routine
+  ! q           = environmental mixing ratio
+  ! q_cup       = environmental mixing ratio on cloud levels
+  ! qes         = environmental saturation mixing ratio
+  ! qes_cup     = environmental saturation mixing ratio on cloud levels
+  ! t           = environmental temp
+  ! t_cup       = environmental temp on cloud levels
+  ! p           = environmental pressure
+  ! p_cup       = environmental pressure on cloud levels
+  ! z           = environmental heights
+  ! z_cup       = environmental heights on cloud levels
+  ! he          = environmental moist static energy
+  ! he_cup      = environmental moist static energy on cloud levels
+  ! hes         = environmental saturation moist static energy
+  ! hes_cup     = environmental saturation moist static energy on cloud levels
+  ! gamma_cup   = gamma on cloud levels
+  ! psur        = surface pressure
+  ! z1          = terrain elevation
+  ! 
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        qes,q,he,hes,z,p,t
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        psur,z1
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        xl,rv,cp
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+       i,k
+
+
+      do k=kts+1,ktf
+      do i=its,itf
+        if(ierr(i).eq.0)then
+        qes_cup(i,k)=.5*(qes(i,k-1)+qes(i,k))
+        q_cup(i,k)=.5*(q(i,k-1)+q(i,k))
+        hes_cup(i,k)=.5*(hes(i,k-1)+hes(i,k))
+        he_cup(i,k)=.5*(he(i,k-1)+he(i,k))
+        if(he_cup(i,k).gt.hes_cup(i,k))he_cup(i,k)=hes_cup(i,k)
+        z_cup(i,k)=.5*(z(i,k-1)+z(i,k))
+        p_cup(i,k)=.5*(p(i,k-1)+p(i,k))
+        t_cup(i,k)=.5*(t(i,k-1)+t(i,k))
+        gamma_cup(i,k)=(xl/cp)*(xl/(rv*t_cup(i,k) &
+                       *t_cup(i,k)))*qes_cup(i,k)
+        endif
+      enddo
+      enddo
+      do i=its,itf
+        if(ierr(i).eq.0)then
+        qes_cup(i,1)=qes(i,1)
+        q_cup(i,1)=q(i,1)
+        hes_cup(i,1)=hes(i,1)
+        he_cup(i,1)=he(i,1)
+        z_cup(i,1)=.5*(z(i,1)+z1(i))
+        p_cup(i,1)=.5*(p(i,1)+psur(i))
+        t_cup(i,1)=t(i,1)
+        gamma_cup(i,1)=xl/cp*(xl/(rv*t_cup(i,1) &
+                       *t_cup(i,1)))*qes_cup(i,1)
+        endif
+      enddo
+
+   END SUBROUTINE cup_env_clev
+
+
+   SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,&
+              xf_ens,j,name,axx,maxens,iens,iedt,maxens2,maxens3,mconv,    &
+              p_cup,ktop,omeg,zd,k22,zu,pr_ens,edt,kbcon,massflx,      &
+              iact_old_gr,dir,ensdim,massfln,icoic,edt_out,            &
+              high_resolution,itf,jtf,ktf,               &
+              its,ite, jts,jte, kts,kte,ens4,ktau                )
+
+   IMPLICIT NONE
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,jtf,ktf,           &
+        its,ite, jts,jte, kts,kte,ens4,high_resolution,ktau
+     integer, intent (in   )              ::                           &
+        j,ensdim,maxens,iens,iedt,maxens2,maxens3
+  !
+  ! ierr error value, maybe modified in this routine
+  ! pr_ens = precipitation ensemble
+  ! xf_ens = mass flux ensembles
+  ! massfln = downdraft mass flux ensembles used in next timestep
+  ! omeg = omega from large scale model
+  ! mconv = moisture convergence from large scale model
+  ! zd      = downdraft normalized mass flux
+  ! zu      = updraft normalized mass flux
+  ! aa0     = cloud work function without forcing effects
+  ! aa1     = cloud work function with forcing effects
+  ! xaa0    = cloud work function with cloud effects (ensemble dependent)
+  ! edt     = epsilon
+  ! dir     = "storm motion"
+  ! mbdt    = arbitrary numerical parameter
+  ! dtime   = dt over which forcing is applied
+  ! iact_gr_old = flag to tell where convection was active
+  ! kbcon       = LFC of parcel from k22
+  ! k22         = updraft originating level
+  ! icoic       = flag if only want one closure (usually set to zero!)
+  ! name        = deep or shallow convection flag
+  !
+     real,    dimension (its:ite,jts:jte,1:ensdim)                     &
+        ,intent (inout)                   ::                           &
+        pr_ens
+     real,    dimension (its:ite,jts:jte,1:ensdim)                     &
+        ,intent (out  )                   ::                           &
+        xf_ens,massfln
+     real,    dimension (its:ite,jts:jte)                              &
+        ,intent (inout   )                   ::                           &
+        edt_out
+     real,    dimension (its:ite,jts:jte)                              &
+        ,intent (in   )                   ::                           &
+        massflx
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        zd,zu,p_cup
+     real,    dimension (its:ite,kts:kte,1:ens4)                              &
+        ,intent (in   )                   ::                           &
+        omeg
+     real,    dimension (its:ite,1:maxens)                             &
+        ,intent (in   )                   ::                           &
+        xaa0
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        aa1,edt,dir,xland
+     real,    dimension (its:ite,1:ens4)                                      &
+        ,intent (in   )                   ::                           &
+        mconv,axx
+     real,    dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        aa0,closure_n
+     real,    dimension (1:maxens)                                     &
+        ,intent (in   )                   ::                           &
+        mbdt
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        dtime
+     integer, dimension (its:ite,jts:jte)                              &
+        ,intent (in   )                   ::                           &
+        iact_old_gr
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        k22,kbcon,ktop
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr,ierr2,ierr3
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        icoic
+      character *(*), intent (in)         ::                           &
+       name
+!
+!  local variables in this routine
+!
+
+     real,    dimension (1:maxens3)       ::                           &
+       xff_ens3
+     real,    dimension (1:maxens)        ::                           &
+       xk
+     integer                              ::                           &
+       i,k,nall,n,ne,nens,nens3,iresult,iresultd,iresulte,mkxcrt,kclim
+     parameter (mkxcrt=15)
+     real                                 ::                           &
+       fens4,a1,massfld,a_ave,xff0,xff00,xxx,xomg,aclim1,aclim2,aclim3,aclim4
+     real,    dimension(1:mkxcrt)         ::                           &
+       pcrit,acrit,acritt
+
+     integer :: nall2,ixxx,irandom
+     integer,  dimension (12) :: seed
+
+
+      DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400.,    &
+                 350.,300.,250.,200.,150./
+      DATA ACRIT/.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/
+!
+       seed=0
+       seed(2)=j
+       seed(3)=ktau
+       nens=0
+       irandom=1
+       if(high_resolution.eq.1)irandom=0
+       irandom=0
+       fens4=float(ens4)
+
+!--- LARGE SCALE FORCING
+!
+       DO 100 i=its,itf
+          if(name.eq.'deeps'.and.ierr(i).gt.995)then
+           aa0(i)=0.
+           ierr(i)=0
+          endif
+          IF(ierr(i).eq.0)then
+!
+!---
+!
+             if(name.eq.'deeps')then
+!
+                a_ave=0.
+                do ne=1,ens4
+                  a_ave=a_ave+axx(i,ne)
+                enddo
+                a_ave=max(0.,a_ave/fens4)
+                a_ave=min(a_ave,aa1(i))
+                a_ave=max(0.,a_ave)
+                do ne=1,16
+                  xff_ens3(ne)=0.
+                enddo
+                xff0= (AA1(I)-AA0(I))/DTIME
+                if(high_resolution.eq.1)xff0= (a_ave-AA0(I))/DTIME
+                xff_ens3(1)=(AA1(I)-AA0(I))/dtime
+                xff_ens3(2)=(a_ave-AA0(I))/dtime
+                if(irandom.eq.1)then
+                   seed(1)=i
+                   call random_seed (PUT=seed)
+                   call random_number (xxx)
+                   ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8)))
+                   xff_ens3(3)=(axx(i,ixxx)-AA0(I))/dtime
+                   call random_number (xxx)
+                   ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8)))
+                   xff_ens3(13)=(axx(i,ixxx)-AA0(I))/dtime
+                else
+                   xff_ens3(3)=(AA1(I)-AA0(I))/dtime
+                   xff_ens3(13)=(AA1(I)-AA0(I))/dtime
+                endif
+                if(high_resolution.eq.1)then
+                   xff_ens3(1)=(a_ave-AA0(I))/dtime
+                   xff_ens3(2)=(a_ave-AA0(I))/dtime
+                   xff_ens3(3)=(a_ave-AA0(I))/dtime
+                   xff_ens3(13)=(a_ave-AA0(I))/dtime
+                endif
+!   
+!--- more original Arakawa-Schubert (climatologic value of aa0)
+!
+!
+!--- omeg is in bar/s, mconv done with omeg in Pa/s
+!     more like Brown (1979), or Frank-Cohen (199?)
+!
+                xff_ens3(14)=0.
+                do ne=1,ens4
+                  xff_ens3(14)=xff_ens3(14)-omeg(i,k22(i),ne)/(fens4*9.81)
+                enddo
+                if(xff_ens3(14).lt.0.)xff_ens3(14)=0.
+                xff_ens3(5)=0.
+                do ne=1,ens4
+                  xff_ens3(5)=xff_ens3(5)-omeg(i,kbcon(i),ne)/(fens4*9.81)
+                enddo
+                if(xff_ens3(5).lt.0.)xff_ens3(5)=0.
+!  
+! minimum below kbcon
+!
+                if(high_resolution.eq.0)then
+                   xff_ens3(4)=-omeg(i,2,1)/9.81
+                   do k=2,kbcon(i)-1
+                   do ne=1,ens4
+                     xomg=-omeg(i,k,ne)/9.81
+                     if(xomg.lt.xff_ens3(4))xff_ens3(4)=xomg
+                   enddo
+                   enddo
+                   if(xff_ens3(4).lt.0.)xff_ens3(4)=0.
+!
+! max below kbcon
+                   xff_ens3(6)=-omeg(i,2,1)/9.81
+                   do k=2,kbcon(i)-1
+                   do ne=1,ens4
+                     xomg=-omeg(i,k,ne)/9.81
+                     if(xomg.gt.xff_ens3(6))xff_ens3(6)=xomg
+                   enddo
+                   enddo
+                   if(xff_ens3(6).lt.0.)xff_ens3(6)=0.
+                endif
+                if(high_resolution.eq.1)then
+                   xff_ens3(5)=min(xff_ens3(5),xff_ens3(14))
+                   xff_ens3(4)=xff_ens3(5)
+                   xff_ens3(6)=xff_ens3(5)
+                endif
+!
+!--- more like Krishnamurti et al.; pick max and average values
+!
+                xff_ens3(7)=mconv(i,1)
+                xff_ens3(8)=mconv(i,1)
+                xff_ens3(9)=mconv(i,1)
+                if(ens4.gt.1)then
+                   do ne=2,ens4
+                      if (mconv(i,ne).gt.xff_ens3(7))xff_ens3(7)=mconv(i,ne)
+                   enddo
+                   do ne=2,ens4
+                      if (mconv(i,ne).lt.xff_ens3(8))xff_ens3(8)=mconv(i,ne)
+                   enddo
+                   do ne=2,ens4
+                      xff_ens3(9)=xff_ens3(9)+mconv(i,ne)
+                   enddo
+                   xff_ens3(9)=xff_ens3(9)/fens4
+                endif
+                if(high_resolution.eq.1)then
+                   xff_ens3(7)=xff_ens3(9)
+                   xff_ens3(8)=xff_ens3(9)
+                   xff_ens3(15)=xff_ens3(9)
+                endif
+!
+                if(high_resolution.eq.0)then
+                if(irandom.eq.1)then
+                   seed(1)=i
+                   call random_seed (PUT=seed)
+                   call random_number (xxx)
+                   ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8)))
+                   xff_ens3(15)=mconv(i,ixxx)
+                else
+                   xff_ens3(15)=mconv(i,1)
+                endif
+                endif
+!
+!--- more like Fritsch Chappel or Kain Fritsch (plus triggers)
+!
+                xff_ens3(10)=A_AVE/(60.*40.)
+                xff_ens3(11)=AA1(I)/(60.*40.)
+                if(irandom.eq.1)then
+                   seed(1)=i
+                   call random_seed (PUT=seed)
+                   call random_number (xxx)
+                   ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8)))
+                   xff_ens3(12)=AXX(I,ixxx)/(60.*40.)
+                else
+                   xff_ens3(12)=AA1(I)/(60.*40.)
+                endif
+                if(high_resolution.eq.1)then
+                   xff_ens3(11)=xff_ens3(10)
+                   xff_ens3(12)=xff_ens3(10)
+                endif
+!  
+!--- more original Arakawa-Schubert (climatologic value of aa0)
+!
+!               edt_out(i,j)=xff0
+                if(icoic.eq.0)then
+                if(xff0.lt.0.)then
+                     xff_ens3(1)=0.
+                     xff_ens3(2)=0.
+                     xff_ens3(3)=0.
+                     xff_ens3(13)=0.
+                     xff_ens3(10)=0.
+                     xff_ens3(11)=0.
+                     xff_ens3(12)=0.
+                endif
+                endif
+
+
+
+                do nens=1,maxens
+                   XK(nens)=(XAA0(I,nens)-AA1(I))/MBDT(2)
+                   if(xk(nens).le.0.and.xk(nens).gt.-1.e-6) &
+                           xk(nens)=-1.e-6
+                   if(xk(nens).gt.0.and.xk(nens).lt.1.e-6) &
+                           xk(nens)=1.e-6
+                enddo
+!
+!--- add up all ensembles
+!
+                do 350 ne=1,maxens
+!
+!--- for every xk, we have maxens3 xffs
+!--- iens is from outermost ensemble (most expensive!
+!
+!--- iedt (maxens2 belongs to it)
+!--- is from second, next outermost, not so expensive
+!
+!--- so, for every outermost loop, we have maxens*maxens2*3
+!--- ensembles!!! nall would be 0, if everything is on first
+!--- loop index, then ne would start counting, then iedt, then iens....
+!
+                   iresult=0
+                   iresultd=0
+                   iresulte=0
+                   nall=(iens-1)*maxens3*maxens*maxens2 &
+                        +(iedt-1)*maxens*maxens3 &
+                        +(ne-1)*maxens3
+!
+! over water, enfor!e small cap for some of the closures
+!
+                if(xland(i).lt.0.1)then
+                 if(ierr2(i).gt.0.or.ierr3(i).gt.0)then
+                      xff_ens3(1) =0.
+                      massfln(i,j,nall+1)=0.
+                      xff_ens3(2) =0.
+                      massfln(i,j,nall+2)=0.
+                      xff_ens3(3) =0.
+                      massfln(i,j,nall+3)=0.
+                      xff_ens3(10) =0.
+                      massfln(i,j,nall+10)=0.
+                      xff_ens3(11) =0.
+                      massfln(i,j,nall+11)=0.
+                      xff_ens3(12) =0.
+                      massfln(i,j,nall+12)=0.
+                      xff_ens3(7) =0.
+                      massfln(i,j,nall+7)=0.
+                      xff_ens3(8) =0.
+                      massfln(i,j,nall+8)=0.
+                      xff_ens3(9) =0.
+                      massfln(i,j,nall+9)=0.
+                      xff_ens3(13) =0.
+                      massfln(i,j,nall+13)=0.
+                      xff_ens3(15) =0.
+                      massfln(i,j,nall+15)=0.
+                endif
+                endif
+!
+! end water treatment
+!
+!
+!--- check for upwind convection
+!                  iresult=0
+                   massfld=0.
+
+!                  call cup_direction2(i,j,dir,iact_old_gr, &
+!                       massflx,iresult,1,                  &
+!                       massfld,                            &
+!                       itf,jtf,ktf,          &
+!                       ims,ime, jms,jme, kms,kme,          &
+!                       its,ite, jts,jte, kts,kte          )
+!                  if(i.eq.ipr.and.j.eq.jpr.and.iedt.eq.1.and.ne.eq.1)then
+!                  if(iedt.eq.1.and.ne.eq.1)then
+!                   print *,massfld,ne,iedt,iens
+!                   print *,xk(ne),xff_ens3(1),xff_ens3(2),xff_ens3(3)
+!                  endif
+!                  print *,i,j,massfld,aa0(i),aa1(i)
+                   IF(XK(ne).lt.0.and.xff0.gt.0.)iresultd=1
+                   iresulte=max(iresult,iresultd)
+                   iresulte=1
+                   if(iresulte.eq.1)then
+!
+!--- special treatment for stability closures
+!
+
+                      if(xff0.ge.0.)then
+                         xf_ens(i,j,nall+1)=massfld
+                         xf_ens(i,j,nall+2)=massfld
+                         xf_ens(i,j,nall+3)=massfld
+                         xf_ens(i,j,nall+13)=massfld
+                         if(xff_ens3(1).gt.0)xf_ens(i,j,nall+1)=max(0.,-xff_ens3(1)/xk(ne)) &
+                                        +massfld
+                         if(xff_ens3(2).gt.0)xf_ens(i,j,nall+2)=max(0.,-xff_ens3(2)/xk(ne)) &
+                                        +massfld
+                         if(xff_ens3(3).gt.0)xf_ens(i,j,nall+3)=max(0.,-xff_ens3(3)/xk(ne)) &
+                                        +massfld
+                         if(xff_ens3(13).gt.0)xf_ens(i,j,nall+13)=max(0.,-xff_ens3(13)/xk(ne)) &
+                                        +massfld
+!                       endif
+                      else
+                         xf_ens(i,j,nall+1)=massfld
+                         xf_ens(i,j,nall+2)=massfld
+                         xf_ens(i,j,nall+3)=massfld
+                         xf_ens(i,j,nall+13)=massfld
+                      endif
+!
+!--- if iresult.eq.1, following independent of xff0
+!
+                         xf_ens(i,j,nall+4)=max(0.,xff_ens3(4) &
+                            +massfld)
+                         xf_ens(i,j,nall+5)=max(0.,xff_ens3(5) &
+                                        +massfld)
+                         xf_ens(i,j,nall+6)=max(0.,xff_ens3(6) &
+                                        +massfld)
+                         xf_ens(i,j,nall+14)=max(0.,xff_ens3(14) &
+                                        +massfld)
+                         a1=max(1.e-3,pr_ens(i,j,nall+7))
+                         xf_ens(i,j,nall+7)=max(0.,xff_ens3(7) &
+                                     /a1)
+                         a1=max(1.e-3,pr_ens(i,j,nall+8))
+                         xf_ens(i,j,nall+8)=max(0.,xff_ens3(8) &
+                                     /a1)
+                         a1=max(1.e-3,pr_ens(i,j,nall+9))
+                         xf_ens(i,j,nall+9)=max(0.,xff_ens3(9) &
+                                     /a1)
+                         a1=max(1.e-3,pr_ens(i,j,nall+15))
+                         xf_ens(i,j,nall+15)=max(0.,xff_ens3(15) &
+                                     /a1)
+                         if(XK(ne).lt.0.)then
+                            xf_ens(i,j,nall+10)=max(0., &
+                                        -xff_ens3(10)/xk(ne)) &
+                                        +massfld
+                            xf_ens(i,j,nall+11)=max(0., &
+                                        -xff_ens3(11)/xk(ne)) &
+                                        +massfld
+                            xf_ens(i,j,nall+12)=max(0., &
+                                        -xff_ens3(12)/xk(ne)) &
+                                        +massfld
+                         else
+                            xf_ens(i,j,nall+10)=massfld
+                            xf_ens(i,j,nall+11)=massfld
+                            xf_ens(i,j,nall+12)=massfld
+                         endif
+                      if(icoic.ge.1)then
+                      closure_n(i)=0.
+                      xf_ens(i,j,nall+1)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+2)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+3)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+4)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+5)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+6)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+7)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+8)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+9)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+10)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+11)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+12)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+13)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+14)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+15)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+16)=xf_ens(i,j,nall+icoic)
+                      endif
+!
+! 16 is a randon pick from the oher 15
+!
+                if(irandom.eq.1)then
+                   call random_number (xxx)
+                   ixxx=min(15,max(1,int(15.*xxx+1.e-8)))
+                   xf_ens(i,j,nall+16)=xf_ens(i,j,nall+ixxx)
+                else
+                   xf_ens(i,j,nall+16)=xf_ens(i,j,nall+1)
+                endif
+!
+!
+!--- store new for next time step
+!
+                      do nens3=1,maxens3
+                        massfln(i,j,nall+nens3)=edt(i) &
+                                                *xf_ens(i,j,nall+nens3)
+                        massfln(i,j,nall+nens3)=max(0., &
+                                              massfln(i,j,nall+nens3))
+                      enddo
+!
+!
+!--- do some more on the caps!!! ne=1 for 175, ne=2 for 100,....
+!
+!     do not care for caps here for closure groups 1 and 5,
+!     they are fine, do not turn them off here
+!
+!
+                if(ne.eq.2.and.ierr2(i).gt.0)then
+                      xf_ens(i,j,nall+1) =0.
+                      xf_ens(i,j,nall+2) =0.
+                      xf_ens(i,j,nall+3) =0.
+                      xf_ens(i,j,nall+4) =0.
+                      xf_ens(i,j,nall+5) =0.
+                      xf_ens(i,j,nall+6) =0.
+                      xf_ens(i,j,nall+7) =0.
+                      xf_ens(i,j,nall+8) =0.
+                      xf_ens(i,j,nall+9) =0.
+                      xf_ens(i,j,nall+10)=0.
+                      xf_ens(i,j,nall+11)=0.
+                      xf_ens(i,j,nall+12)=0.
+                      xf_ens(i,j,nall+13)=0.
+                      xf_ens(i,j,nall+14)=0.
+                      xf_ens(i,j,nall+15)=0.
+                      xf_ens(i,j,nall+16)=0.
+                      massfln(i,j,nall+1)=0.
+                      massfln(i,j,nall+2)=0.
+                      massfln(i,j,nall+3)=0.
+                      massfln(i,j,nall+4)=0.
+                      massfln(i,j,nall+5)=0.
+                      massfln(i,j,nall+6)=0.
+                      massfln(i,j,nall+7)=0.
+                      massfln(i,j,nall+8)=0.
+                      massfln(i,j,nall+9)=0.
+                      massfln(i,j,nall+10)=0.
+                      massfln(i,j,nall+11)=0.
+                      massfln(i,j,nall+12)=0.
+                      massfln(i,j,nall+13)=0.
+                      massfln(i,j,nall+14)=0.
+                      massfln(i,j,nall+15)=0.
+                      massfln(i,j,nall+16)=0.
+                endif
+                if(ne.eq.3.and.ierr3(i).gt.0)then
+                      xf_ens(i,j,nall+1) =0.
+                      xf_ens(i,j,nall+2) =0.
+                      xf_ens(i,j,nall+3) =0.
+                      xf_ens(i,j,nall+4) =0.
+                      xf_ens(i,j,nall+5) =0.
+                      xf_ens(i,j,nall+6) =0.
+                      xf_ens(i,j,nall+7) =0.
+                      xf_ens(i,j,nall+8) =0.
+                      xf_ens(i,j,nall+9) =0.
+                      xf_ens(i,j,nall+10)=0.
+                      xf_ens(i,j,nall+11)=0.
+                      xf_ens(i,j,nall+12)=0.
+                      xf_ens(i,j,nall+13)=0.
+                      xf_ens(i,j,nall+14)=0.
+                      xf_ens(i,j,nall+15)=0.
+                      xf_ens(i,j,nall+16)=0.
+                      massfln(i,j,nall+1)=0.
+                      massfln(i,j,nall+2)=0.
+                      massfln(i,j,nall+3)=0.
+                      massfln(i,j,nall+4)=0.
+                      massfln(i,j,nall+5)=0.
+                      massfln(i,j,nall+6)=0.
+                      massfln(i,j,nall+7)=0.
+                      massfln(i,j,nall+8)=0.
+                      massfln(i,j,nall+9)=0.
+                      massfln(i,j,nall+10)=0.
+                      massfln(i,j,nall+11)=0.
+                      massfln(i,j,nall+12)=0.
+                      massfln(i,j,nall+13)=0.
+                      massfln(i,j,nall+14)=0.
+                      massfln(i,j,nall+15)=0.
+                      massfln(i,j,nall+16)=0.
+                endif
+
+                   endif
+ 350            continue
+! ne=1, cap=175
+!
+                   nall=(iens-1)*maxens3*maxens*maxens2 &
+                        +(iedt-1)*maxens*maxens3
+! ne=2, cap=100
+!
+                   nall2=(iens-1)*maxens3*maxens*maxens2 &
+                        +(iedt-1)*maxens*maxens3 &
+                        +(2-1)*maxens3
+                      xf_ens(i,j,nall+4) = xf_ens(i,j,nall2+4)
+                      xf_ens(i,j,nall+5) =xf_ens(i,j,nall2+5)
+                      xf_ens(i,j,nall+6) =xf_ens(i,j,nall2+6)
+                      xf_ens(i,j,nall+14) =xf_ens(i,j,nall2+14)
+                      xf_ens(i,j,nall+7) =xf_ens(i,j,nall2+7)
+                      xf_ens(i,j,nall+8) =xf_ens(i,j,nall2+8)
+                      xf_ens(i,j,nall+9) =xf_ens(i,j,nall2+9)
+                      xf_ens(i,j,nall+15) =xf_ens(i,j,nall2+15)
+                      xf_ens(i,j,nall+10)=xf_ens(i,j,nall2+10)
+                      xf_ens(i,j,nall+11)=xf_ens(i,j,nall2+11)
+                      xf_ens(i,j,nall+12)=xf_ens(i,j,nall2+12)
+                go to 100
+             endif
+          elseif(ierr(i).ne.20.and.ierr(i).ne.0)then
+             do n=1,ensdim
+               xf_ens(i,j,n)=0.
+               massfln(i,j,n)=0.
+             enddo
+          endif
+ 100   continue
+
+   END SUBROUTINE cup_forcing_ens_3d
+
+
+   SUBROUTINE cup_kbcon(cap_inc,iloop,k22,kbcon,he_cup,hes_cup, &
+              ierr,kbmax,p_cup,cap_max,                         &
+              itf,jtf,ktf,                        &
+              its,ite, jts,jte, kts,kte                        )
+
+   IMPLICIT NONE
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,jtf,ktf,           &
+        its,ite, jts,jte, kts,kte
+  ! 
+  ! 
+  ! 
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        he_cup,hes_cup,p_cup
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        cap_max,cap_inc
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        kbmax
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        kbcon,k22,ierr
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        iloop
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k
+     real                                 ::                           &
+        pbcdif,plus,hetest
+!
+!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
+!
+       DO 27 i=its,itf
+      kbcon(i)=1
+      IF(ierr(I).ne.0)GO TO 27
+      KBCON(I)=K22(I)
+      GO TO 32
+ 31   CONTINUE
+      KBCON(I)=KBCON(I)+1
+      IF(KBCON(I).GT.KBMAX(i)+2)THEN
+         if(iloop.ne.4)ierr(i)=3
+!        if(iloop.lt.4)ierr(i)=997
+        GO TO 27
+      ENDIF
+ 32   CONTINUE
+      hetest=HE_cup(I,K22(I))
+      if(iloop.eq.5)then
+       do k=1,k22(i)
+         hetest=max(hetest,he_cup(i,k))
+       enddo
+      endif
+      IF(HETEST.LT.HES_cup(I,KBCON(I)))GO TO 31
+
+!     cloud base pressure and max moist static energy pressure
+!     i.e., the depth (in mb) of the layer of negative buoyancy
+      if(KBCON(I)-K22(I).eq.1)go to 27
+      PBCDIF=-P_cup(I,KBCON(I))+P_cup(I,K22(I))
+      plus=max(25.,cap_max(i)-float(iloop-1)*cap_inc(i))
+      if(iloop.eq.4)plus=cap_max(i)
+!
+! for shallow convection, if cap_max is greater than 25, it is the pressure at pbltop
+      if(iloop.eq.5)plus=25.
+      if(iloop.eq.5.and.cap_max(i).gt.25)pbcdif=-P_cup(I,KBCON(I))+cap_max(i)
+      IF(PBCDIF.GT.plus)THEN
+        K22(I)=K22(I)+1
+        KBCON(I)=K22(I)
+        GO TO 32
+      ENDIF
+ 27   CONTINUE
+
+   END SUBROUTINE cup_kbcon
+
+
+   SUBROUTINE cup_ktop(ilo,dby,kbcon,ktop,ierr,              &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,jtf,ktf,           &
+        its,ite, jts,jte, kts,kte
+  ! dby = buoancy term
+  ! ktop = cloud top (output)
+  ! ilo  = flag
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout)                   ::                           &
+        dby
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        kbcon
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        ilo
+     integer, dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        ktop
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k
+!
+        DO 42 i=its,itf
+        ktop(i)=1
+         IF(ierr(I).EQ.0)then
+          DO 40 K=KBCON(I)+1,ktf-1
+            IF(DBY(I,K).LE.0.)THEN
+                KTOP(I)=K-1
+                GO TO 41
+             ENDIF
+  40      CONTINUE
+          if(ilo.eq.1)ierr(i)=5
+!         if(ilo.eq.2)ierr(i)=998
+          GO TO 42
+  41     CONTINUE
+         do k=ktop(i)+1,ktf
+           dby(i,k)=0.
+         enddo
+         endif
+  42     CONTINUE
+
+   END SUBROUTINE cup_ktop
+
+
+   SUBROUTINE cup_MAXIMI(ARRAY,KS,KE,MAXX,ierr,              &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+         itf,jtf,ktf,                                    &
+         its,ite, jts,jte, kts,kte
+  ! array input array
+  ! x output array with return values
+  ! kt output array of levels
+  ! ks,kend  check-range
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+         array
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+         ierr,ke
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+         ks
+     integer, dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+         maxx
+     real,    dimension (its:ite)         ::                           &
+         x
+     real                                 ::                           &
+         xar
+     integer                              ::                           &
+         i,k
+
+       DO 200 i=its,itf
+       MAXX(I)=KS
+       if(ierr(i).eq.0)then
+      X(I)=ARRAY(I,KS)
+!
+       DO 100 K=KS,KE(i)
+         XAR=ARRAY(I,K)
+         IF(XAR.GE.X(I)) THEN
+            X(I)=XAR
+            MAXX(I)=K
+         ENDIF
+ 100  CONTINUE
+      endif
+ 200  CONTINUE
+
+   END SUBROUTINE cup_MAXIMI
+
+
+   SUBROUTINE cup_minimi(ARRAY,KS,KEND,KT,ierr,              &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+         itf,jtf,ktf,                                    &
+         its,ite, jts,jte, kts,kte
+  ! array input array
+  ! x output array with return values
+  ! kt output array of levels
+  ! ks,kend  check-range
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+         array
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+         ierr,ks,kend
+     integer, dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+         kt
+     real,    dimension (its:ite)         ::                           &
+         x
+     integer                              ::                           &
+         i,k,kstop
+
+       DO 200 i=its,itf
+      KT(I)=KS(I)
+      if(ierr(i).eq.0)then
+      X(I)=ARRAY(I,KS(I))
+       KSTOP=MAX(KS(I)+1,KEND(I))
+!
+       DO 100 K=KS(I)+1,KSTOP
+         IF(ARRAY(I,K).LT.X(I)) THEN
+              X(I)=ARRAY(I,K)
+              KT(I)=K
+         ENDIF
+ 100  CONTINUE
+      endif
+ 200  CONTINUE
+
+   END SUBROUTINE cup_MINIMI
+
+
+   SUBROUTINE cup_output_ens_3d(xf_ens,ierr,dellat,dellaq,dellaqc,  &
+              subt_ens,subq_ens,subt,subq,outtem,outq,outqc,     &
+              zu,sub_mas,pre,pw,xmb,ktop,                 &
+              j,name,nx,nx2,iens,ierr2,ierr3,pr_ens,             &
+              maxens3,ensdim,massfln,                            &
+              APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                 &
+              APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1,    &
+              itf,jtf,ktf, &
+              its,ite, jts,jte, kts,kte)
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,jtf,ktf,           &
+        its,ite, jts,jte, kts,kte
+     integer, intent (in   )              ::                           &
+        j,ensdim,nx,nx2,iens,maxens3
+  ! xf_ens = ensemble mass fluxes
+  ! pr_ens = precipitation ensembles
+  ! dellat = change of temperature per unit mass flux of cloud ensemble
+  ! dellaq = change of q per unit mass flux of cloud ensemble
+  ! dellaqc = change of qc per unit mass flux of cloud ensemble
+  ! outtem = output temp tendency (per s)
+  ! outq   = output q tendency (per s)
+  ! outqc  = output qc tendency (per s)
+  ! pre    = output precip
+  ! xmb    = total base mass flux
+  ! xfac1  = correction factor
+  ! pw = pw -epsilon*pd (ensemble dependent)
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,jts:jte,1:ensdim)                     &
+        ,intent (inout)                   ::                           &
+       xf_ens,pr_ens,massfln
+     real,    dimension (its:ite,jts:jte)                              &
+        ,intent (inout)                   ::                           &
+               APR_GR,APR_W,APR_MC,APR_ST,APR_AS,APR_CAPMA,            &
+               APR_CAPME,APR_CAPMI 
+
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        outtem,outq,outqc,subt,subq,sub_mas
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in  )                   ::                           &
+        zu
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        pre,xmb
+     real,    dimension (its:ite)                                      &
+        ,intent (inout  )                   ::                           &
+        closure_n,xland1
+     real,    dimension (its:ite,kts:kte,1:nx)                     &
+        ,intent (in   )                   ::                           &
+       subt_ens,subq_ens,dellat,dellaqc,dellaq,pw
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        ktop
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr,ierr2,ierr3
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k,n,ncount
+     real                                 ::                           &
+        outtes,ddtes,dtt,dtq,dtqc,dtpw,tuning,prerate,clos_wei,xmbhelp
+     real                                 ::                           &
+        dtts,dtqs
+     real,    dimension (its:ite)         ::                           &
+       xfac1,xfac2
+     real,    dimension (its:ite)::                           &
+       xmb_ske,xmb_ave,xmb_std,xmb_cur,xmbweight
+     real,    dimension (its:ite)::                           &
+       pr_ske,pr_ave,pr_std,pr_cur
+     real,    dimension (its:ite,jts:jte)::                           &
+               pr_gr,pr_w,pr_mc,pr_st,pr_as,pr_capma,     &
+               pr_capme,pr_capmi
+     real, dimension (5) :: weight,wm,wm1,wm2,wm3
+     real, dimension (its:ite,5) :: xmb_w
+
+!
+      character *(*), intent (in)        ::                           &
+       name
+!
+     weight(1) = -999.  !this will turn off weights
+     wm(1)=-999.
+
+     tuning=0.
+!
+!
+      DO k=kts,ktf
+      do i=its,itf
+        outtem(i,k)=0.
+        outq(i,k)=0.
+        outqc(i,k)=0.
+        subt(i,k)=0.
+        subq(i,k)=0.
+        sub_mas(i,k)=0.
+      enddo
+      enddo
+      do i=its,itf
+        pre(i)=0.
+        xmb(i)=0.
+         xfac1(i)=0.
+         xfac2(i)=0.
+        xmbweight(i)=1.
+      enddo
+      do i=its,itf
+        IF(ierr(i).eq.0)then
+        do n=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3
+           if(pr_ens(i,j,n).le.0.)then
+             xf_ens(i,j,n)=0.
+           endif
+        enddo
+        endif
+      enddo
+!
+!--- calculate ensemble average mass fluxes
+!
+       call massflx_stats(xf_ens,ensdim,nx2,nx,maxens3,      &
+            xmb_ave,xmb_std,xmb_cur,xmb_ske,j,ierr,1,    &
+            APR_GR,APR_W,APR_MC,APR_ST,APR_AS,           &
+            APR_CAPMA,APR_CAPME,APR_CAPMI,               &
+            pr_gr,pr_w,pr_mc,pr_st,pr_as,                &
+            pr_capma,pr_capme,pr_capmi,                  &
+            itf,jtf,ktf,                   &
+            its,ite, jts,jte, kts,kte                   )
+       xmb_w=0.
+       call massflx_stats(pr_ens,ensdim,nx2,nx,maxens3,  &
+            pr_ave,pr_std,pr_cur,pr_ske,j,ierr,2,        &
+            APR_GR,APR_W,APR_MC,APR_ST,APR_AS,           &
+            APR_CAPMA,APR_CAPME,APR_CAPMI,               &
+            pr_gr,pr_w,pr_mc,pr_st,pr_as,                &
+            pr_capma,pr_capme,pr_capmi,                  &
+            itf,jtf,ktf,                   &
+            its,ite, jts,jte, kts,kte                   )
+!
+!-- now do feedback
+!
+      ddtes=100.
+      do i=its,itf
+        if(ierr(i).eq.0)then
+         if(xmb_ave(i).le.0.)then
+              ierr(i)=13
+              xmb_ave(i)=0.
+         endif
+         xmb(i)=max(.1*xmb_ave(i),xmb_ave(i)-tuning*xmb_std(i))
+! --- Now use proper count of how many closures were actually
+!       used in cup_forcing_ens (including screening of some
+!       closures over water) to properly normalize xmb
+           clos_wei=16./max(1.,closure_n(i))
+           if (xland1(i).lt.0.5)xmb(i)=xmb(i)*clos_wei
+           if(xmb(i).eq.0.)then
+              ierr(i)=19
+           endif
+           if(xmb(i).gt.100.)then
+              ierr(i)=19
+           endif
+           xfac1(i)=xmb(i)
+           xfac2(i)=xmb(i)
+
+        endif
+!       if(weight(1).lt.-100.)xfac1(i)=xmb_ave(i)
+!       if(weight(1).lt.-100.)xfac2(i)=xmb_ave(i)
+      ENDDO
+      DO k=kts,ktf
+      do i=its,itf
+            dtt=0.
+            dtts=0.
+            dtq=0.
+            dtqs=0.
+            dtqc=0.
+            dtpw=0.
+        IF(ierr(i).eq.0.and.k.le.ktop(i))then
+           do n=1,nx
+              dtt=dtt+dellat(i,k,n)
+              dtts=dtts+subt_ens(i,k,n)
+              dtq=dtq+dellaq(i,k,n)
+              dtqs=dtqs+subq_ens(i,k,n)
+              dtqc=dtqc+dellaqc(i,k,n)
+              dtpw=dtpw+pw(i,k,n)
+           enddo
+           OUTTEM(I,K)=XMB(I)*dtt/float(nx)
+           SUBT(I,K)=XMB(I)*dtts/float(nx)
+           OUTQ(I,K)=XMB(I)*dtq/float(nx)
+           SUBQ(I,K)=XMB(I)*dtqs/float(nx)
+           OUTQC(I,K)=XMB(I)*dtqc/float(nx)
+           PRE(I)=PRE(I)+XMB(I)*dtpw/float(nx)
+           sub_mas(i,k)=zu(i,k)*xmb(i)
+        endif
+      enddo
+      enddo
+
+      do i=its,itf
+        if(ierr(i).eq.0)then
+        do k=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3
+          massfln(i,j,k)=massfln(i,j,k)*xfac1(i)
+          xf_ens(i,j,k)=xf_ens(i,j,k)*xfac1(i)
+        enddo
+        endif
+      ENDDO
+
+   END SUBROUTINE cup_output_ens_3d
+
+
+   SUBROUTINE cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup,       &
+              kbcon,ktop,ierr,                               &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,jtf,ktf,                                     &
+        its,ite, jts,jte, kts,kte
+  ! aa0 cloud work function
+  ! gamma_cup = gamma on model cloud levels
+  ! t_cup = temperature (Kelvin) on model cloud levels
+  ! dby = buoancy term
+  ! zu= normalized updraft mass flux
+  ! z = heights of model levels 
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        z,zu,gamma_cup,t_cup,dby
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        kbcon,ktop
+!
+! input and output
+!
+
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        aa0
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k
+     real                                 ::                           &
+        dz,da
+!
+        do i=its,itf
+         aa0(i)=0.
+        enddo
+        DO 100 k=kts+1,ktf
+        DO 100 i=its,itf
+         IF(ierr(i).ne.0)GO TO 100
+         IF(K.LE.KBCON(I))GO TO 100
+         IF(K.Gt.KTOP(I))GO TO 100
+         DZ=Z(I,K)-Z(I,K-1)
+         da=zu(i,k)*DZ*(9.81/(1004.*( &
+                (T_cup(I,K)))))*DBY(I,K-1)/ &
+             (1.+GAMMA_CUP(I,K))
+         IF(K.eq.KTOP(I).and.da.le.0.)go to 100
+         AA0(I)=AA0(I)+da
+         if(aa0(i).lt.0.)aa0(i)=0.
+100     continue
+
+   END SUBROUTINE cup_up_aa0
+
+
+   SUBROUTINE cup_up_he(k22,hkb,z_cup,cd,entr,he_cup,hc,     &
+              kbcon,ierr,dby,he,hes_cup,name,                &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+                                  itf,jtf,ktf,           &
+                                  its,ite, jts,jte, kts,kte
+      character *(*), intent (in)        ::                           &
+       name
+  ! hc = cloud moist static energy
+  ! hkb = moist static energy at originating level
+  ! he = moist static energy on model levels
+  ! he_cup = moist static energy on model cloud levels
+  ! hes_cup = saturation moist static energy on model cloud levels
+  ! dby = buoancy term
+  ! cd= detrainment function 
+  ! z_cup = heights of model cloud levels 
+  ! entr = entrainment rate
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        he,he_cup,hes_cup,z_cup,cd
+  ! entr= entrainment rate 
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        entr
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        kbcon,k22
+!
+! input and output
+!
+
+   ! ierr error value, maybe modified in this routine
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        hc,dby
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        hkb
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k
+     real                                 ::                           &
+        dz
+!
+!--- moist static energy inside cloud
+!
+      do k=kts,ktf
+      do i=its,itf
+         hc(i,k)=0.
+         DBY(I,K)=0.
+      enddo
+      enddo
+      do i=its,itf
+         hkb(i)=0.
+      enddo
+      do i=its,itf
+        if(ierr(i).eq.0.)then
+          hkb(i)=he_cup(i,k22(i))
+          if(name.eq.'shallow')then
+             do k=1,k22(i)
+               hkb(i)=max(hkb(i),he_cup(i,k))
+             enddo
+          endif
+          do k=1,k22(i)
+              hc(i,k)=he_cup(i,k)
+          enddo
+          do k=k22(i),kbcon(i)-1
+              hc(i,k)=hkb(i)
+          enddo
+          k=kbcon(i)
+          hc(i,k)=hkb(i)
+          DBY(I,Kbcon(i))=Hkb(I)-HES_cup(I,K)
+        endif
+      enddo
+      do k=kts+1,ktf
+      do i=its,itf
+        if(k.gt.kbcon(i).and.ierr(i).eq.0.)then
+           DZ=Z_cup(i,K)-Z_cup(i,K-1)
+           HC(i,K)=(HC(i,K-1)*(1.-.5*CD(i,K)*DZ)+entr* &
+                DZ*HE(i,K-1))/(1.+entr*DZ-.5*cd(i,k)*dz)
+           DBY(I,K)=HC(I,K)-HES_cup(I,K)
+        endif
+      enddo
+
+      enddo
+
+   END SUBROUTINE cup_up_he
+
+
+   SUBROUTINE cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav,     &
+              kbcon,ktop,cd,dby,mentr_rate,clw_all,                  &
+              q,GAMMA_cup,zu,qes_cup,k22,qe_cup,xl,          &
+              itf,jtf,ktf,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+                                  itf,jtf,ktf,           &
+                                  its,ite, jts,jte, kts,kte
+  ! cd= detrainment function 
+  ! q = environmental q on model levels
+  ! qe_cup = environmental q on model cloud levels
+  ! qes_cup = saturation q on model cloud levels
+  ! dby = buoancy term
+  ! cd= detrainment function 
+  ! zu = normalized updraft mass flux
+  ! gamma_cup = gamma on model cloud levels
+  ! mentr_rate = entrainment rate
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        q,zu,gamma_cup,qe_cup,dby,qes_cup,z_cup,cd
+  ! entr= entrainment rate 
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        mentr_rate,xl
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        kbcon,ktop,k22
+!
+! input and output
+!
+
+   ! ierr error value, maybe modified in this routine
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+      character *(*), intent (in)        ::                           &
+       name
+   ! qc = cloud q (including liquid water) after entrainment
+   ! qrch = saturation q in cloud
+   ! qrc = liquid water content in cloud after rainout
+   ! pw = condensate that will fall out at that level
+   ! pwav = totan normalized integrated condensate (I1)
+   ! c0 = conversion rate (cloud to rain)
+
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        qc,qrc,pw,clw_all
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        pwav
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        iall,i,k
+     real                                 ::                           &
+        dh,qrch,c0,dz,radius
+!
+        iall=0
+        c0=.002
+!
+!--- no precip for small clouds
+!
+        if(name.eq.'shallow')c0=0.
+        do i=its,itf
+          pwav(i)=0.
+        enddo
+        do k=kts,ktf
+        do i=its,itf
+          pw(i,k)=0.
+          qc(i,k)=0.
+          if(ierr(i).eq.0)qc(i,k)=qes_cup(i,k)
+          clw_all(i,k)=0.
+          qrc(i,k)=0.
+        enddo
+        enddo
+      do i=its,itf
+      if(ierr(i).eq.0.)then
+      do k=k22(i),kbcon(i)-1
+        qc(i,k)=qe_cup(i,k22(i))
+      enddo
+      endif
+      enddo
+
+        DO 100 k=kts+1,ktf
+        DO 100 i=its,itf
+         IF(ierr(i).ne.0)GO TO 100
+         IF(K.Lt.KBCON(I))GO TO 100
+         IF(K.Gt.KTOP(I))GO TO 100
+         DZ=Z_cup(i,K)-Z_cup(i,K-1)
+!
+!------    1. steady state plume equation, for what could
+!------       be in cloud without condensation
+!
+!
+        QC(i,K)=(QC(i,K-1)*(1.-.5*CD(i,K)*DZ)+mentr_rate* &
+                DZ*Q(i,K-1))/(1.+mentr_rate*DZ-.5*cd(i,k)*dz)
+!
+!--- saturation  in cloud, this is what is allowed to be in it
+!
+         QRCH=QES_cup(I,K)+(1./XL)*(GAMMA_cup(i,k) &
+              /(1.+GAMMA_cup(i,k)))*DBY(I,K)
+!
+!------- LIQUID WATER CONTENT IN cloud after rainout
+!
+        clw_all(i,k)=QC(I,K)-QRCH
+        QRC(I,K)=(QC(I,K)-QRCH)/(1.+C0*DZ)
+        if(qrc(i,k).lt.0.)then
+          qrc(i,k)=0.
+        endif
+!
+!-------   3.Condensation
+!
+         PW(i,k)=c0*dz*QRC(I,K)*zu(i,k)
+        if(iall.eq.1)then
+          qrc(i,k)=0.
+          pw(i,k)=(QC(I,K)-QRCH)*zu(i,k)
+          if(pw(i,k).lt.0.)pw(i,k)=0.
+        endif
+!
+!----- set next level
+!
+         QC(I,K)=QRC(I,K)+qrch
+!
+!--- integrated normalized ondensate
+!
+         PWAV(I)=PWAV(I)+PW(I,K)
+ 100     CONTINUE
+
+   END SUBROUTINE cup_up_moisture
+
+
+   SUBROUTINE cup_up_nms(zu,z_cup,entr,cd,kbcon,ktop,ierr,k22,  &
+              itf,jtf,ktf,                        &
+              its,ite, jts,jte, kts,kte                        )
+
+   IMPLICIT NONE
+
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+         itf,jtf,ktf,                                    &
+         its,ite, jts,jte, kts,kte
+  ! cd= detrainment function 
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+         z_cup,cd
+  ! entr= entrainment rate 
+     real                                                              &
+        ,intent (in   )                   ::                           &
+         entr
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+         kbcon,ktop,k22
+!
+! input and output
+!
+
+   ! ierr error value, maybe modified in this routine
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+         ierr
+   ! zu is the normalized mass flux
+
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+         zu
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+         i,k
+     real                                 ::                           &
+         dz
+!
+!   initialize for this go around
+!
+       do k=kts,ktf
+       do i=its,itf
+         zu(i,k)=0.
+       enddo
+       enddo
+!
+! do normalized mass budget
+!
+       do i=its,itf
+          IF(ierr(I).eq.0)then
+             do k=k22(i),kbcon(i)
+               zu(i,k)=1.
+             enddo
+             DO K=KBcon(i)+1,KTOP(i)
+               DZ=Z_cup(i,K)-Z_cup(i,K-1)
+               ZU(i,K)=ZU(i,K-1)*(1.+(entr-cd(i,k))*DZ)
+             enddo
+          endif
+       enddo
+
+   END SUBROUTINE cup_up_nms
+
+!====================================================================
+   SUBROUTINE g3init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,           &
+                        MASS_FLUX,cp,restart,                       &
+                        P_QC,P_QI,P_FIRST_SCALAR,                   &
+                        RTHFTEN, RQVFTEN,                           &
+                        APR_GR,APR_W,APR_MC,APR_ST,APR_AS,          &
+                        APR_CAPMA,APR_CAPME,APR_CAPMI,              &
+                        cugd_tten,cugd_ttens,cugd_qvten,            &
+                        cugd_qvtens,cugd_qcten,                     &
+                        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_FIRST_SCALAR, P_QI, P_QC
+   REAL,     INTENT(IN)           ::  cp
+
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
+                                                          CUGD_TTEN,         &
+                                                          CUGD_TTENS,        &
+                                                          CUGD_QVTEN,        &
+                                                          CUGD_QVTENS,       &
+                                                          CUGD_QCTEN
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
+                                                          RTHCUTEN, &
+                                                          RQVCUTEN, &
+                                                          RQCCUTEN, &
+                                                          RQICUTEN   
+
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
+                                                          RTHFTEN,  &
+                                                          RQVFTEN
+
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) ::        &
+                                APR_GR,APR_W,APR_MC,APR_ST,APR_AS,  &
+                                APR_CAPMA,APR_CAPME,APR_CAPMI,      &
+                                MASS_FLUX
+
+   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,jte
+     DO k=kts,kte
+     DO i=its,ite
+        RTHCUTEN(i,k,j)=0.
+        RQVCUTEN(i,k,j)=0.
+     ENDDO
+     ENDDO
+     ENDDO
+     DO j=jts,jte
+     DO k=kts,kte
+     DO i=its,ite
+       cugd_tten(i,k,j)=0.
+       cugd_ttens(i,k,j)=0.
+       cugd_qvten(i,k,j)=0.
+       cugd_qvtens(i,k,j)=0.
+     ENDDO
+     ENDDO
+     ENDDO
+
+     DO j=jts,jtf
+     DO k=kts,ktf
+     DO i=its,itf
+        RTHFTEN(i,k,j)=0.
+        RQVFTEN(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.
+           cugd_qcten(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
+
+     DO j=jts,jtf
+     DO i=its,itf
+        mass_flux(i,j)=0.
+     ENDDO
+     ENDDO
+
+     DO j=jts,jtf
+     DO i=its,itf
+        APR_GR(i,j)=0.
+        APR_ST(i,j)=0.
+        APR_W(i,j)=0.
+        APR_MC(i,j)=0.
+        APR_AS(i,j)=0.
+        APR_CAPMA(i,j)=0.
+        APR_CAPME(i,j)=0.
+        APR_CAPMI(i,j)=0.
+     ENDDO
+     ENDDO
+
+   ENDIF
+
+   END SUBROUTINE g3init
+
+
+   SUBROUTINE massflx_stats(xf_ens,ensdim,maxens,maxens2,maxens3, &
+              xt_ave,xt_std,xt_cur,xt_ske,j,ierr,itest,           &
+              APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                  &
+              APR_CAPMA,APR_CAPME,APR_CAPMI,                      &
+              pr_gr,pr_w,pr_mc,pr_st,pr_as,                       &
+              pr_capma,pr_capme,pr_capmi,                         &
+              itf,jtf,ktf,  &
+              its,ite, jts,jte, kts,kte)
+
+   IMPLICIT NONE
+
+   integer, intent (in   )              ::                                    &
+                     j,ensdim,maxens3,maxens,maxens2,itest
+   INTEGER,      INTENT(IN   ) ::                                             &
+                                  itf,jtf,ktf,                  &
+                                  its,ite, jts,jte, kts,kte
+
+
+     real, dimension (its:ite)                                                &
+         , intent(inout) ::                                                   &
+           xt_ave,xt_cur,xt_std,xt_ske
+     integer, dimension (its:ite), intent (in) ::                             &
+           ierr
+     real, dimension (its:ite,jts:jte,1:ensdim)                               &
+         , intent(in   ) ::                                                   &
+           xf_ens
+     real, dimension (its:ite,jts:jte)                                        &
+         , intent(inout) ::                                                   &
+           APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                                 &
+           APR_CAPMA,APR_CAPME,APR_CAPMI
+     real, dimension (its:ite,jts:jte)                                        &
+         , intent(inout) ::                                                   &
+           pr_gr,pr_w,pr_mc,pr_st,pr_as,                                      &
+           pr_capma,pr_capme,pr_capmi
+
+!
+! local stuff
+!
+     real, dimension (its:ite , 1:maxens3 )       ::                          &
+           x_ave,x_cur,x_std,x_ske
+     real, dimension (its:ite , 1:maxens  )       ::                          &
+           x_ave_cap
+
+
+      integer, dimension (1:maxens3) :: nc1
+      integer :: i,k
+      integer :: num,kk,num2,iedt
+      real :: a3,a4
+
+      num=ensdim/maxens3
+      num2=ensdim/maxens
+      if(itest.eq.1)then
+      do i=its,ite
+       pr_gr(i,j) =  0.
+       pr_w(i,j) =  0.
+       pr_mc(i,j) = 0.
+       pr_st(i,j) = 0.
+       pr_as(i,j) = 0.
+       pr_capma(i,j) =  0.
+       pr_capme(i,j) = 0.
+       pr_capmi(i,j) = 0.
+      enddo
+      endif
+
+      do k=1,maxens
+      do i=its,ite
+        x_ave_cap(i,k)=0.
+      enddo
+      enddo
+      do k=1,maxens3
+      do i=its,ite
+        x_ave(i,k)=0.
+        x_std(i,k)=0.
+        x_ske(i,k)=0.
+        x_cur(i,k)=0.
+      enddo
+      enddo
+      do i=its,ite
+        xt_ave(i)=0.
+        xt_std(i)=0.
+        xt_ske(i)=0.
+        xt_cur(i)=0.
+      enddo
+      do kk=1,num
+      do k=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0)then
+        x_ave(i,k)=x_ave(i,k)+xf_ens(i,j,maxens3*(kk-1)+k)
+        endif
+      enddo
+      enddo
+      enddo
+      do iedt=1,maxens2
+      do k=1,maxens
+      do kk=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0)then
+        x_ave_cap(i,k)=x_ave_cap(i,k)                               &
+            +xf_ens(i,j,maxens3*(k-1)+(iedt-1)*maxens*maxens3+kk)
+        endif
+      enddo
+      enddo
+      enddo
+      enddo
+      do k=1,maxens
+      do i=its,ite
+        if(ierr(i).eq.0)then
+        x_ave_cap(i,k)=x_ave_cap(i,k)/float(num2)
+        endif
+      enddo
+      enddo
+
+      do k=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0)then
+        x_ave(i,k)=x_ave(i,k)/float(num)
+        endif
+      enddo
+      enddo
+      do k=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0)then
+        xt_ave(i)=xt_ave(i)+x_ave(i,k)
+        endif
+      enddo
+      enddo
+      do i=its,ite
+        if(ierr(i).eq.0)then
+        xt_ave(i)=xt_ave(i)/float(maxens3)
+        endif
+      enddo
+!
+!--- now do std, skewness,curtosis
+!
+      do kk=1,num
+      do k=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0.and.x_ave(i,k).gt.0.)then
+!       print *,i,j,k,kk,x_std(i,k),xf_ens(i,j,maxens3*(kk-1)+k),x_ave(i,k)
+        x_std(i,k)=x_std(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**2
+        x_ske(i,k)=x_ske(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**3
+        x_cur(i,k)=x_cur(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**4
+        endif
+      enddo
+      enddo
+      enddo
+      do k=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0.and.xt_ave(i).gt.0.)then
+        xt_std(i)=xt_std(i)+(x_ave(i,k)-xt_ave(i))**2
+        xt_ske(i)=xt_ske(i)+(x_ave(i,k)-xt_ave(i))**3
+        xt_cur(i)=xt_cur(i)+(x_ave(i,k)-xt_ave(i))**4
+        endif
+      enddo
+      enddo
+      do k=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0.and.x_std(i,k).gt.0.)then
+           x_std(i,k)=x_std(i,k)/float(num)
+           a3=max(1.e-6,x_std(i,k))
+           x_std(i,k)=sqrt(a3)
+           a3=max(1.e-6,x_std(i,k)**3)
+           a4=max(1.e-6,x_std(i,k)**4)
+           x_ske(i,k)=x_ske(i,k)/float(num)/a3
+           x_cur(i,k)=x_cur(i,k)/float(num)/a4
+        endif
+!       print*,'                               '
+!       print*,'Some statistics at gridpoint i,j, ierr',i,j,ierr(i)
+!       print*,'statistics for closure number ',k
+!       print*,'Average= ',x_ave(i,k),'  Std= ',x_std(i,k)
+!       print*,'Skewness= ',x_ske(i,k),' Curtosis= ',x_cur(i,k)
+!       print*,'                               '
+
+      enddo
+      enddo
+      do i=its,ite
+        if(ierr(i).eq.0.and.xt_std(i).gt.0.)then
+           xt_std(i)=xt_std(i)/float(maxens3)
+           a3=max(1.e-6,xt_std(i))
+           xt_std(i)=sqrt(a3)
+           a3=max(1.e-6,xt_std(i)**3)
+           a4=max(1.e-6,xt_std(i)**4)
+           xt_ske(i)=xt_ske(i)/float(maxens3)/a3
+           xt_cur(i)=xt_cur(i)/float(maxens3)/a4
+!       print*,'                               '
+!       print*,'Total ensemble independent statistics at i =',i
+!       print*,'Average= ',xt_ave(i),'  Std= ',xt_std(i)
+!       print*,'Skewness= ',xt_ske(i),' Curtosis= ',xt_cur(i)
+!       print*,'                               '
+!
+!  first go around: store massflx for different closures/caps
+!
+      if(itest.eq.1)then
+       pr_gr(i,j) = .25*(x_ave(i,1)+x_ave(i,2)+x_ave(i,3)+x_ave(i,13))
+       pr_w(i,j) = .25*(x_ave(i,4)+x_ave(i,5)+x_ave(i,6)+x_ave(i,14))
+       pr_mc(i,j) = .25*(x_ave(i,7)+x_ave(i,8)+x_ave(i,9)+x_ave(i,15))
+       pr_st(i,j) = .333*(x_ave(i,10)+x_ave(i,11)+x_ave(i,12))
+       pr_as(i,j) = x_ave(i,16)
+       pr_capma(i,j) = x_ave_cap(i,1)
+       pr_capme(i,j) = x_ave_cap(i,2)
+       pr_capmi(i,j) = x_ave_cap(i,3)
+!
+!  second go around: store preciprates (mm/hour) for different closures/caps
+!
+        else if (itest.eq.2)then
+       APR_GR(i,j)=.25*(x_ave(i,1)+x_ave(i,2)+x_ave(i,3)+x_ave(i,13))*      &
+                  3600.*pr_gr(i,j) +APR_GR(i,j)
+       APR_W(i,j)=.25*(x_ave(i,4)+x_ave(i,5)+x_ave(i,6)+x_ave(i,14))*       &
+                  3600.*pr_w(i,j) +APR_W(i,j)
+       APR_MC(i,j)=.25*(x_ave(i,7)+x_ave(i,8)+x_ave(i,9)+x_ave(i,15))*      &
+                  3600.*pr_mc(i,j) +APR_MC(i,j)
+       APR_ST(i,j)=.333*(x_ave(i,10)+x_ave(i,11)+x_ave(i,12))*   &
+                  3600.*pr_st(i,j) +APR_ST(i,j)
+       APR_AS(i,j)=x_ave(i,16)*                       &
+                  3600.*pr_as(i,j) +APR_AS(i,j)
+       APR_CAPMA(i,j) = x_ave_cap(i,1)*                          &
+                  3600.*pr_capma(i,j) +APR_CAPMA(i,j)
+       APR_CAPME(i,j) = x_ave_cap(i,2)*                          &
+                  3600.*pr_capme(i,j) +APR_CAPME(i,j)
+       APR_CAPMI(i,j) = x_ave_cap(i,3)*                          &
+                  3600.*pr_capmi(i,j) +APR_CAPMI(i,j)
+        endif
+        endif
+      enddo
+
+   END SUBROUTINE massflx_stats
+
+   SUBROUTINE cup_axx(tcrit,kbmax,z1,p,psur,xl,rv,cp,tx,qx,axx,ierr,    &
+           cap_max,cap_max_increment,entr_rate,mentr_rate,&
+           j,itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte,ens4)
+   IMPLICIT NONE
+   INTEGER,      INTENT(IN   ) ::                                             &
+                                  j,itf,jtf,ktf,                &
+                                  its,ite, jts,jte, kts,kte,ens4
+     real, dimension (its:ite,kts:kte,1:ens4)                                 &
+         , intent(inout) ::                                                   &
+           tx,qx
+     real, dimension (its:ite,kts:kte)                                 &
+         , intent(in) ::                                                   &
+           p
+     real, dimension (its:ite)                                 &
+         , intent(in) ::                                                   &
+           z1,psur,cap_max,cap_max_increment
+     real, intent(in) ::                                                   &
+           tcrit,xl,rv,cp,mentr_rate,entr_rate
+     real, dimension (its:ite,1:ens4)                                 &
+         , intent(out) ::                                                   &
+           axx
+     integer, dimension (its:ite), intent (in) ::                             &
+           ierr,kbmax
+     integer, dimension (its:ite) ::                             &
+           ierrxx,k22xx,kbconxx,ktopxx,kstabm,kstabi
+      real, dimension (1:2) :: AE,BE,HT
+      real, dimension (its:ite,kts:kte) :: tv
+      real :: e,tvbar
+     integer n,i,k,iph
+     real,    dimension (its:ite,kts:kte) ::                           &
+        he,hes,qes,z,                                                  &
+        qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,      &
+        tn_cup,                                                        &
+        dby,qc,qrcd,pwd,pw,hcd,qcd,dbyd,hc,qrc,zu,zd,cd
+
+     real,    dimension (its:ite) ::                                   &
+       AA0,HKB,QKB,          &
+       PWAV,BU
+      do n=1,ens4
+      do i=its,ite
+       axx(i,n)=0.
+      enddo
+      enddo
+     HT(1)=XL/CP
+     HT(2)=2.834E6/CP
+     BE(1)=.622*HT(1)/.286
+     AE(1)=BE(1)/273.+ALOG(610.71)
+     BE(2)=.622*HT(2)/.286
+     AE(2)=BE(2)/273.+ALOG(610.71)
+!
+!
+     do 100 n=1,ens4
+
+      do k=kts,ktf
+      do i=its,itf
+        cd(i,k)=0.1*entr_rate
+      enddo
+      enddo
+
+
+      do i=its,itf
+        ierrxx(i)=ierr(i)
+        k22xx(i)=1
+        kbconxx(i)=1
+        ktopxx(i)=1
+        kstabm(i)=ktf-1
+      enddo
+      DO k=kts,ktf
+      do i=its,itf
+        if(ierrxx(i).eq.0)then
+        IPH=1
+        IF(Tx(I,K,n).LE.TCRIT)IPH=2
+        E=EXP(AE(IPH)-BE(IPH)/TX(I,K,N))
+        QES(I,K)=.622*E/(100.*P(I,K)-E)
+        IF(QES(I,K).LE.1.E-08)QES(I,K)=1.E-08
+        IF(Qx(I,K,N).GT.QES(I,K))Qx(I,K,N)=QES(I,K)
+        TV(I,K)=Tx(I,K,N)+.608*Qx(I,K,N)*Tx(I,K,N)
+        endif
+      enddo
+      enddo
+!
+         do i=its,itf
+           if(ierrxx(i).eq.0)then
+             Z(I,KTS)=max(0.,Z1(I))-(ALOG(P(I,KTS))- &
+                 ALOG(PSUR(I)))*287.*TV(I,KTS)/9.81
+           endif
+         enddo
+
+! --- calculate heights
+         DO K=kts+1,ktf
+         do i=its,itf
+           if(ierrxx(i).eq.0)then
+              TVBAR=.5*TV(I,K)+.5*TV(I,K-1)
+              Z(I,K)=Z(I,K-1)-(ALOG(P(I,K))- &
+               ALOG(P(I,K-1)))*287.*TVBAR/9.81
+           endif
+         enddo
+         enddo
+!
+!--- calculate moist static energy - HE
+!    saturated moist static energy - HES
+!
+       DO k=kts,ktf
+       do i=its,itf
+         if(ierrxx(i).eq.0)then
+         HE(I,K)=9.81*Z(I,K)+1004.*Tx(I,K,n)+2.5E06*Qx(I,K,n)
+         HES(I,K)=9.81*Z(I,K)+1004.*Tx(I,K,n)+2.5E06*QES(I,K)
+         IF(HE(I,K).GE.HES(I,K))HE(I,K)=HES(I,K)
+         endif
+      enddo
+      enddo
+
+! cup levels
+!
+      do k=kts+1,ktf
+      do i=its,itf
+        if(ierrxx(i).eq.0)then
+        qes_cup(i,k)=.5*(qes(i,k-1)+qes(i,k))
+        q_cup(i,k)=.5*(qx(i,k-1,n)+qx(i,k,n))
+        hes_cup(i,k)=.5*(hes(i,k-1)+hes(i,k))
+        he_cup(i,k)=.5*(he(i,k-1)+he(i,k))
+        if(he_cup(i,k).gt.hes_cup(i,k))he_cup(i,k)=hes_cup(i,k)
+        z_cup(i,k)=.5*(z(i,k-1)+z(i,k))
+        p_cup(i,k)=.5*(p(i,k-1)+p(i,k))
+        t_cup(i,k)=.5*(tx(i,k-1,n)+tx(i,k,n))
+        gamma_cup(i,k)=(xl/cp)*(xl/(rv*t_cup(i,k) &
+                       *t_cup(i,k)))*qes_cup(i,k)
+        endif
+      enddo
+      enddo
+      do i=its,itf
+        if(ierrxx(i).eq.0)then
+        qes_cup(i,1)=qes(i,1)
+        q_cup(i,1)=qx(i,1,n)
+        hes_cup(i,1)=hes(i,1)
+        he_cup(i,1)=he(i,1)
+        z_cup(i,1)=.5*(z(i,1)+z1(i))
+        p_cup(i,1)=.5*(p(i,1)+psur(i))
+        t_cup(i,1)=tx(i,1,n)
+        gamma_cup(i,1)=xl/cp*(xl/(rv*t_cup(i,1) &
+                       *t_cup(i,1)))*qes_cup(i,1)
+        endif
+      enddo
+!
+!
+!------- DETERMINE LEVEL WITH HIGHEST MOIST STATIC ENERGY CONTENT - K22
+!
+      CALL cup_MAXIMI(HE_CUP,3,KBMAX,K22XX,ierrxx, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+       DO 36 i=its,itf
+         IF(ierrxx(I).eq.0.)THEN
+         IF(K22xx(I).GE.KBMAX(i))ierrxx(i)=2
+         endif
+ 36   CONTINUE
+!
+!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
+!
+      call cup_kbcon(cap_max_increment,1,k22xx,kbconxx,he_cup,hes_cup, &
+           ierrxx,kbmax,p_cup,cap_max, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- increase detrainment in stable layers
+!
+      CALL cup_minimi(HEs_cup,Kbconxx,kstabm,kstabi,ierrxx,  &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      do i=its,itf
+      IF(ierrxx(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(k22xx,hkb,z_cup,cd,mentr_rate,he_cup,hc, &
+           kbconxx,ierrxx,dby,he,hes_cup,'deep', &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+
+!--- DETERMINE CLOUD TOP - KTOP
+!
+      call cup_ktop(1,dby,kbconxx,ktopxx,ierrxx, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!c--- normalized updraft mass flux profile
+!
+      call cup_up_nms(zu,z_cup,mentr_rate,cd,kbconxx,ktopxx,ierrxx,k22xx, &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- calculate workfunctions for updrafts
+!
+      call cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup, &
+           kbconxx,ktopxx,ierrxx,           &
+           itf,jtf,ktf, &
+           its,ite, jts,jte, kts,kte)
+      do i=its,itf
+       if(ierrxx(i).eq.0)axx(i,n)=aa0(i)
+      enddo
+100   continue
+     END SUBROUTINE cup_axx
+
+      SUBROUTINE conv_grell_spread3d(rthcuten,rqvcuten,rqccuten,raincv,   &
+     &         cugd_avedx,cugd_tten,cugd_qvten,rqicuten,cugd_ttens,       &
+     &         cugd_qvtens,cugd_qcten,pi_phy,moist_qv,pratec,dt,num_tiles,&
+     &         imomentum,F_QV    ,F_QC    ,F_QR    ,F_QI    ,F_QS,        &
+     &         ids, ide, jds, jde, kds, kde,                              &
+     &         ips, ipe, jps, jpe, kps, kpe,                              &
+     &         ims, ime, jms, jme, kms, kme,                              &
+     &         its, ite, jts, jte, kts, kte   )
+
+!
+
+   INTEGER,      INTENT(IN   )    ::   num_tiles,imomentum
+   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, &
+                                       cugd_avedx
+   REAL, DIMENSION (ims:ime,kms:kme,jms:jme), optional,INTENT (INOUT) ::     &
+     &  rthcuten,rqvcuten,rqccuten,rqicuten
+   REAL, DIMENSION (ims:ime,kms:kme,jms:jme), optional,INTENT (IN   ) ::     &
+     &  cugd_tten,cugd_qvten,cugd_ttens,cugd_qvtens,cugd_qcten
+   REAL, DIMENSION (ims:ime,kms:kme,jms:jme),INTENT (IN) ::        &
+          moist_qv
+   REAL, DIMENSION (ims:ime,kms:kme,jms:jme), INTENT (IN) ::        &
+          PI_PHY
+   REAL, DIMENSION (ims:ime,jms:jme), INTENT (INOUT) ::             &
+          raincv,pratec
+   REAL,                              INTENT(IN) ::   dt
+   INTEGER                        :: ikk1,ikk2,ikk11,i,j,k,kk,nn,smoothh,smoothv
+   INTEGER                        :: ifs,ife,jfs,jfe,ido,jdo,cugd_spread
+   LOGICAL                        :: new
+!
+! 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
+   REAL, DIMENSION (its-2:ite+2,kts:kte,jts-2:jte+2) ::     &
+          RTHcutent,RQVcutent
+   real, dimension (its-2:ite+2,jts-2:jte+2) :: Qmem
+   real, dimension (its-1:ite+1,jts-1:jte+1) :: smTT,smTQ
+   real, dimension (kts:kte) :: conv_TRASHT,conv_TRASHQ
+   REAL                           :: Qmem1,Qmem2,Qmemf,Thresh
+
+   smoothh=1
+   smoothv=1
+   cugd_spread=cugd_avedx/2
+
+   ifs=max(its,ids)
+   jfs=max(jts,jds)
+   ife=min(ite,ide-1)
+   jfe=min(jte,jde-1)
+
+   do j=jfs-2,jfe+2
+   do i=ifs-2,ife+2
+     Qmem(i,j)=1.
+   enddo
+   enddo
+   do j=jfs-1,jfe+1
+   do i=ifs-1,ife+1
+     smTT(i,j)=0.
+     smTQ(i,j)=0.
+   enddo
+   enddo
+   do j=jfs,jfe              
+   do k=kts,kte              
+   do i=ifs,ife
+     rthcuten(i,k,j)=0. 
+     rqvcuten(i,k,j)=0.      
+   enddo
+   enddo
+   enddo
+   do j=jfs-2,jfe+2              
+   do k=kts,kte              
+   do i=ifs-2,ife+2
+     RTHcutent(i,k,j)=0. 
+     RQVcutent(i,k,j)=0.      
+   enddo
+   enddo
+   enddo
+!     
+!
+!       
+!  
+! prelims finished, now go real for every grid point
+!  
+   if(cugd_spread.gt.0.or.smoothh.eq.1)then
+      !if(its.eq.ips)ifs=max(its-1,ids)
+      !if(ite.eq.ipe)ife=min(ite+1,ide-1)
+      !if(jts.eq.jps)jfs=max(jts-1,jds)
+      !if(jte.eq.jpe)jfe=min(jte+1,jde-1)
+      ifs=max(its-1,ids)
+      ife=min(ite+1,ide-1)
+      jfs=max(jts-1,jds)
+      jfe=min(jte+1,jde-1)
+   endif
+
+! *** jm note -- for smoothing this goes out one row/column beyond tile in i and j
+   do j=jfs,jfe
+     do i=ifs,ife
+!
+       do k=kts,kte
+         RTHcutent(i,k,j)=cugd_tten(i,k,j)
+         RQVcutent(i,k,j)=cugd_qvten(i,k,j)
+       enddo
+!
+! for high res run, spread the subsidence
+! this is tricky......only consider grid points where there was no rain,
+! so cugd_tten and such are zero!
+!
+       if(cugd_spread.gt.0)then
+         do k=kts,kte
+           do nn=-1,1,1
+             jdo=max(j+nn,jds)
+             jdo=min(jdo,jde-1)
+             do kk=-1,1,1
+               ido=max(i+kk,ids)
+               ido=min(ido,ide-1)
+               RTHcutent(i,k,j)=RTHcutent(i,k,j)     &
+                                    +Qmem(ido,jdo)*cugd_ttens(ido,k,jdo)
+               RQVcutent(i,k,j)=RQVcutent(i,k,j)     &
+                                    +Qmem(ido,jdo)*cugd_qvtens(ido,k,jdo)
+             enddo
+           enddo
+         enddo
+       endif
+!       
+! end spreading
+    
+       if(cugd_spread.eq.0)then
+         do k=kts,kte
+           RTHcutent(i,k,j)=RTHcutent(i,k,j)+cugd_ttens(i,k,j)
+           RQVcutent(i,k,j)=RQVcutent(i,k,j)+cugd_qvtens(i,k,j)
+         enddo
+       endif
+     enddo  ! end j
+   enddo  ! end i
+
+! smooth
+   do k=kts,kte
+     if(smoothh.eq.0)then
+          ifs=max(its,ids+4)
+          ife=min(ite,ide-5)
+          jfs=max(jts,jds+4)
+          jfe=min(jte,jde-5)
+          do i=ifs,ife
+            do j=jfs,jfe
+              rthcuten(i,k,j)=RTHcutent(i,k,j)
+              rqvcuten(i,k,j)=RQVcutent(i,k,j)
+            enddo  ! end j
+          enddo  ! end j
+     else if(smoothh.eq.1)then   ! smooth
+          ifs=max(its,ids)
+          ife=min(ite,ide-1)
+          jfs=max(jts,jds)
+          jfe=min(jte,jde-1)
+! we need an extra row for j (halo comp)
+          !if(jts.eq.jps)jfs=max(jts-1,jds)
+          !if(jte.eq.jpe)jfe=min(jte+1,jde-1)
+          jfs=max(jts-1,jds)
+          jfe=min(jte+1,jde-1)
+          do i=ifs,ife
+            do j=jfs,jfe
+               smTT(i,j)=.25*(RTHcutent(i-1,k,j)+2.*RTHcutent(i,k,j)+RTHcutent(i+1,k,j))
+               smTQ(i,j)=.25*(RQVcutent(i-1,k,j)+2.*RQVcutent(i,k,j)+RQVcutent(i+1,k,j))
+            enddo  ! end j
+          enddo  ! end j
+          ifs=max(its,ids+4)
+          ife=min(ite,ide-5)
+          jfs=max(jts,jds+4)
+          jfe=min(jte,jde-5)
+          do i=ifs,ife
+            do j=jfs,jfe
+              rthcuten(i,k,j)=.25*(smTT(i,j-1)+2.*smTT(i,j)+smTT(i,j+1))
+              rqvcuten(i,k,j)=.25*(smTQ(i,j-1)+2.*smTQ(i,j)+smTQ(i,j+1))
+            enddo  ! end j
+          enddo  ! end i
+      endif  ! smoothh
+    enddo  ! end k
+!       
+! check moistening rates
+!         
+    ifs=max(its,ids+4)
+    ife=min(ite,ide-5)
+    jfs=max(jts,jds+4)
+    jfe=min(jte,jde-5)
+    do j=jfs,jfe
+      do i=ifs,ife
+        Qmemf=1.
+        Thresh=1.e-20
+        do k=kts,kte              
+          if(rqvcuten(i,k,j).lt.0.)then
+            Qmem1=moist_qv(i,k,j)+rqvcuten(i,k,j)*dt
+            if(Qmem1.lt.Thresh)then
+              Qmem1=rqvcuten(i,k,j)
+              Qmem2=(Thresh-moist_qv(i,k,j))/dt
+              Qmemf=min(Qmemf,Qmem2/Qmem1)
+              Qmemf=max(0.,Qmemf)
+              Qmemf=min(1.,Qmemf)
+            endif
+          endif
+        enddo
+        do k=kts,kte
+          rqvcuten(i,k,j)=rqvcuten(i,k,j)*Qmemf
+          rthcuten(i,k,j)=rthcuten(i,k,j)*Qmemf
+        enddo
+        if(present(rqccuten))then
+          if(f_qc) then
+            do k=kts,kte
+              rqccuten(i,k,j)=rqccuten(i,k,j)*Qmemf
+            enddo
+          endif
+        endif
+        if(present(rqicuten))then
+          if(f_qi) then
+            do k=kts,kte
+              rqicuten(i,k,j)=rqicuten(i,k,j)*Qmemf
+            enddo
+          endif
+        endif
+        raincv(I,J)=raincv(I,J)*Qmemf
+        pratec(I,J)=pratec(I,J)*Qmemf
+!
+! check heating rates
+
+!
+        Thresh=200.
+        Qmemf=1.
+        Qmem1=0.
+        do k=kts,kte
+          Qmem1=abs(rthcuten(i,k,j))*86400. 
+
+          if(Qmem1.gt.Thresh)then
+            Qmem2=Thresh/Qmem1
+            Qmemf=min(Qmemf,Qmem2)
+            Qmemf=max(0.,Qmemf) 
+          endif
+
+        enddo
+        raincv(i,j)=raincv(i,j)*Qmemf
+        pratec(i,j)=pratec(i,j)*Qmemf
+        do k=kts,kte
+          rqvcuten(i,k,j)=rqvcuten(i,k,j)*Qmemf
+          rthcuten(i,k,j)=rthcuten(i,k,j)*Qmemf
+        enddo
+        if(present(rqccuten))then
+          if(f_qc) then
+            do k=kts,kte
+              rqccuten(i,k,j)=rqccuten(i,k,j)*Qmemf
+            enddo
+          endif
+        endif
+        if(present(rqicuten))then
+          if(f_qi) then
+            do k=kts,kte
+              rqicuten(i,k,j)=rqicuten(i,k,j)*Qmemf
+            enddo
+          endif
+        endif
+        if(smoothv.eq.1)then
+! 
+! smooth for now
+!
+          do k=kts+2,kte-2
+            conv_TRASHT(k)= .25*(rthcuten(i,k-1,j)+2.*rthcuten(i,k,j)+rthcuten(i,k+1,j))
+            conv_TRASHQ(k)= .25*(rqvcuten(i,k-1,j)+2.*rqvcuten(i,k,j)+rqvcuten(i,k+1,j))
+          enddo
+          do k=kts+2,kte-2
+            rthcuten(i,k,j)=conv_TRASHT(k)
+            rqvcuten(i,k,j)=conv_TRASHQ(k)
+          enddo
+        endif
+        do k=kts,kte
+          rthcuten(i,k,j)=rthcuten(i,k,j)/pi_phy(i,k,j)
+        enddo
+      enddo  ! end j
+    enddo  ! end i
+
+  END SUBROUTINE CONV_GRELL_SPREAD3D
+!-------------------------------------------------------
+END MODULE module_cu_g3
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_gd.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_gd.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_gd.F	(revision 17)
@@ -0,0 +1,4553 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+
+MODULE module_cu_gd
+
+CONTAINS
+
+!-------------------------------------------------------------
+   SUBROUTINE GRELLDRV(                                         &
+               DT,itimestep,DX                                  &
+              ,rho,RAINCV,PRATEC                                &
+              ,U,V,t,W,q,p,pi                                   &
+              ,dz8w,p8w,XLV,CP,G,r_v                            &
+              ,STEPCU,htop,hbot                                 &
+              ,CU_ACT_FLAG,warm_rain                            &
+              ,APR_GR,APR_W,APR_MC,APR_ST,APR_AS                &
+              ,APR_CAPMA,APR_CAPME,APR_CAPMI                    &
+              ,MASS_FLUX,XF_ENS,PR_ENS,HT,XLAND,gsw             &
+              ,GDC,GDC2                                         &
+              ,ensdim,maxiens,maxens,maxens2,maxens3            &
+              ,ids,ide, jds,jde, kds,kde                        &
+              ,ims,ime, jms,jme, kms,kme                        &
+              ,its,ite, jts,jte, kts,kte                        &
+              ,periodic_x,periodic_y                            &
+              ,RQVCUTEN,RQCCUTEN,RQICUTEN                       &
+              ,RQVFTEN,RQVBLTEN                                 &
+              ,RTHFTEN,RTHCUTEN,RTHRATEN,RTHBLTEN               &
+              ,F_QV    ,F_QC    ,F_QR    ,F_QI    ,F_QS         &
+              ,CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,f_flux             )
+
+!-------------------------------------------------------------
+   IMPLICIT NONE
+!-------------------------------------------------------------
+   INTEGER,      INTENT(IN   ) ::                               &
+                                  ids,ide, jds,jde, kds,kde,    & 
+                                  ims,ime, jms,jme, kms,kme,    & 
+                                  its,ite, jts,jte, kts,kte
+   LOGICAL periodic_x,periodic_y
+
+   integer, intent (in   )              ::                      &
+                       ensdim,maxiens,maxens,maxens2,maxens3
+  
+   INTEGER,      INTENT(IN   ) :: STEPCU, ITIMESTEP
+   LOGICAL,      INTENT(IN   ) :: warm_rain
+
+   REAL,         INTENT(IN   ) :: XLV, R_v
+   REAL,         INTENT(IN   ) :: CP,G
+
+   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
+          INTENT(IN   ) ::                                      &
+                                                          U,    &
+                                                          V,    &
+                                                          W,    &
+                                                         pi,    &
+                                                          t,    &
+                                                          q,    &
+                                                          p,    &
+                                                       dz8w,    &
+                                                       p8w,    &
+                                                        rho
+   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
+          OPTIONAL                                         ,    &
+          INTENT(INOUT   ) ::                                   &
+               GDC,GDC2
+
+
+   REAL, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: GSW,HT,XLAND
+!
+   REAL, INTENT(IN   ) :: DT, DX
+!
+
+   REAL, DIMENSION( ims:ime , jms:jme ),                        &
+         INTENT(INOUT) ::         RAINCV, PRATEC, MASS_FLUX,    &
+                          APR_GR,APR_W,APR_MC,APR_ST,APR_AS,    &
+                              APR_CAPMA,APR_CAPME,APR_CAPMI,htop,hbot
+!+lxz
+!  REAL, DIMENSION( ims:ime , jms:jme ) :: & !, INTENT(INOUT) ::       &
+!        HTOP,     &! highest model layer penetrated by cumulus since last reset in radiation_driver
+!        HBOT       ! lowest  model layer penetrated by cumulus since last reset in radiation_driver
+!                   ! HBOT>HTOP follow physics leveling convention
+
+   LOGICAL, DIMENSION( ims:ime , jms:jme ),                     &
+         INTENT(INOUT) ::                       CU_ACT_FLAG
+
+!
+! Optionals
+!
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+         OPTIONAL,                                              &
+         INTENT(INOUT) ::                           RTHFTEN,    &
+                                                    RQVFTEN
+
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+         OPTIONAL,                                              &
+         INTENT(IN   ) ::                                       &
+                                                   RTHRATEN,    &
+                                                   RTHBLTEN,    &
+                                                   RQVBLTEN
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+         OPTIONAL,                                              &
+         INTENT(INOUT) ::                                       &
+                                                   RTHCUTEN,    &
+                                                   RQVCUTEN,    &
+                                                   RQCCUTEN,    &
+                                                   RQICUTEN
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+         OPTIONAL,                                              &
+         INTENT(INOUT) ::                                       &
+                                                   CFU1,        &
+                                                   CFD1,        &
+                                                   DFU1,        &
+                                                   EFU1,        &
+                                                   DFD1,        &
+                                                   EFD1
+!
+! 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
+   LOGICAL, intent(in), OPTIONAL ::                f_flux
+
+
+
+! LOCAL VARS
+     real,    dimension ( ims:ime , jms:jme , 1:ensdim) ::      &
+        massfln,xf_ens,pr_ens
+     real,    dimension (its:ite,kts:kte+1) ::                    &
+        OUTT,OUTQ,OUTQC,phh,cupclw,     &
+        outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1
+     logical :: l_flux
+     real,    dimension (its:ite)         ::                    &
+        pret, ter11, aa0, fp
+!+lxz
+     integer, dimension (its:ite) ::                            &
+        kbcon, ktop
+!.lxz
+     integer, dimension (its:ite,jts:jte) ::                    &
+        iact_old_gr
+     integer :: ichoice,iens,ibeg,iend,jbeg,jend
+
+!
+! 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+1) ::                    &
+        T2d,TN,q2d,qo,PO,P2d,US,VS,omeg
+     real, dimension (its:ite)            ::                    &
+        Z1,PSUR,AAEQ,direction,mconv,cuten,umean,vmean,pmean
+
+   INTEGER :: i,j,k,ICLDCK,ipr,jpr
+   REAL    :: tcrit,dp,dq
+   INTEGER :: itf,jtf,ktf
+   REAL    :: rkbcon,rktop        !-lxz
+
+   l_flux=.FALSE.
+   if (present(f_flux)) l_flux=f_flux
+   if (l_flux) then
+      l_flux = l_flux .and. present(cfu1) .and. present(cfd1)   &
+               .and. present(dfu1) .and. present(efu1)          &
+               .and. present(dfd1) .and. present(efd1)
+   endif
+
+   ichoice=0
+   iens=1
+     ipr=0
+     jpr=0
+
+   IF ( periodic_x ) THEN
+      ibeg=max(its,ids)
+      iend=min(ite,ide-1)
+   ELSE
+      ibeg=max(its,ids+4)
+      iend=min(ite,ide-5)
+   END IF
+   IF ( periodic_y ) THEN
+      jbeg=max(jts,jds)
+      jend=min(jte,jde-1)
+   ELSE
+      jbeg=max(jts,jds+4)
+      jend=min(jte,jde-5)
+   END IF
+
+
+   tcrit=258.
+
+   itf=MIN(ite,ide-1)
+   ktf=MIN(kte,kde-1)
+   jtf=MIN(jte,jde-1)
+!                                                                      
+     DO 100 J = jts,jtf  
+     DO I= its,itf
+        cuten(i)=0.
+        iact_old_gr(i,j)=0
+        mass_flux(i,j)=0.
+        pratec(i,j) = 0.
+        raincv(i,j)=0.
+        CU_ACT_FLAG(i,j) = .true.
+     ENDDO
+     DO k=1,ensdim
+     DO I= its,itf
+        massfln(i,j,k)=0.
+     ENDDO
+     ENDDO
+#if ( EM_CORE == 1 )
+     DO k= kts,ktf
+     DO I= its,itf
+        RTHFTEN(i,k,j)=(RTHFTEN(i,k,j)+RTHRATEN(i,k,j)+RTHBLTEN(i,k,j))*pi(i,k,j)
+        RQVFTEN(i,k,j)=RQVFTEN(i,k,j)+RQVBLTEN(i,k,j)
+     ENDDO
+     ENDDO
+#endif
+     !  put hydrostatic pressure on half levels
+     DO K=kts,ktf
+     DO I=ITS,ITF
+         phh(i,k) = p(i,k,j)
+     ENDDO
+     ENDDO
+     DO I=ITS,ITF
+         PSUR(I)=p8w(I,1,J)*.01
+         TER11(I)=HT(i,j)
+         mconv(i)=0.
+         aaeq(i)=0.
+         direction(i)=0.
+         pret(i)=0.
+         umean(i)=0.
+         vmean(i)=0.
+         pmean(i)=0.
+     ENDDO
+     DO K=kts,ktf
+     DO I=ITS,ITF
+         omeg(i,k)=0.
+!        cupclw(i,k)=0.
+         po(i,k)=phh(i,k)*.01
+         P2d(I,K)=PO(i,k)
+         US(I,K) =u(i,k,j)
+         VS(I,K) =v(i,k,j)
+         T2d(I,K)=t(i,k,j)
+         q2d(I,K)=q(i,k,j)
+         omeg(I,K)= -g*rho(i,k,j)*w(i,k,j)
+         TN(I,K)=t2d(i,k)+RTHFTEN(i,k,j)*dt
+         IF(TN(I,K).LT.200.)TN(I,K)=T2d(I,K)
+         QO(I,K)=q2d(i,k)+RQVFTEN(i,k,j)*dt
+         IF(Q2d(I,K).LT.1.E-08)Q2d(I,K)=1.E-08
+         IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08
+         OUTT(I,K)=0.
+         OUTQ(I,K)=0.
+         OUTQC(I,K)=0.
+!        RTHFTEN(i,k,j)=0.
+!        RQVFTEN(i,k,j)=0.
+     ENDDO
+     ENDDO
+      do k=  kts+1,ktf-1
+      DO I = its,itf
+         if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then
+            dp=-.5*(p2d(i,k+1)-p2d(i,k-1))
+            umean(i)=umean(i)+us(i,k)*dp
+            vmean(i)=vmean(i)+vs(i,k)*dp
+            pmean(i)=pmean(i)+dp
+         endif
+      enddo
+      enddo
+      DO I = its,itf
+         umean(i)=umean(i)/pmean(i)
+         vmean(i)=vmean(i)/pmean(i)
+         direction(i)=(atan2(umean(i),vmean(i))+3.1415926)*57.29578
+         if(direction(i).gt.360.)direction(i)=direction(i)-360.
+      ENDDO
+      DO K=kts,ktf-1
+      DO I = its,itf
+        dq=(q2d(i,k+1)-q2d(i,k))
+        mconv(i)=mconv(i)+omeg(i,k)*dq/g
+      ENDDO
+      ENDDO
+      DO I = its,itf
+        if(mconv(i).lt.0.)mconv(i)=0.
+      ENDDO
+!
+!---- CALL CUMULUS PARAMETERIZATION
+!
+      CALL CUP_enss(outqc,j,AAEQ,T2d,Q2d,TER11,TN,QO,PO,PRET,     &
+           P2d,OUTT,OUTQ,DT,PSUR,US,VS,tcrit,iens,                &
+           mconv,massfln,iact_old_gr,omeg,direction,MASS_FLUX,    &
+           maxiens,maxens,maxens2,maxens3,ensdim,                 &
+           APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                     &
+           APR_CAPMA,APR_CAPME,APR_CAPMI,kbcon,ktop,              &
+           xf_ens,pr_ens,XLAND,gsw,cupclw,                        &
+           xlv,r_v,cp,g,ichoice,ipr,jpr,                          &
+           outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1,l_flux,&
+           ids,ide, jds,jde, kds,kde,                             &
+           ims,ime, jms,jme, kms,kme,                             &
+           its,ite, jts,jte, kts,kte                             )
+
+      CALL neg_check(dt,q2d,outq,outt,outqc,pret,its,ite,kts,kte,itf,ktf)
+      if(j.ge.jbeg.and.j.le.jend)then
+
+            DO I=its,itf
+!             cuten(i)=0.
+              if(i.ge.ibeg.and.i.le.iend)then
+              if(pret(i).gt.0.)then
+                 pratec(i,j)=pret(i)
+                 raincv(i,j)=pret(i)*dt
+                 cuten(i)=1.
+                 rkbcon = kte+kts - kbcon(i)
+                 rktop  = kte+kts -  ktop(i)
+                 if (ktop(i)  > HTOP(i,j)) HTOP(i,j) = ktop(i)+.001
+                 if (kbcon(i) < HBOT(i,j)) HBOT(i,j) = kbcon(i)+.001
+              endif
+              else
+               pret(i)=0.
+              endif
+            ENDDO
+            DO K=kts,ktf
+            DO I=its,itf
+               RTHCUTEN(I,K,J)=outt(i,k)*cuten(i)/pi(i,k,j)
+               RQVCUTEN(I,K,J)=outq(i,k)*cuten(i)
+            ENDDO
+            ENDDO
+
+            IF(PRESENT(RQCCUTEN)) THEN
+              IF ( F_QC ) THEN
+                DO K=kts,ktf
+                DO I=its,itf
+                   RQCCUTEN(I,K,J)=outqc(I,K)*cuten(i)
+                   IF ( PRESENT( GDC ) ) GDC(I,K,J)=CUPCLW(I,K)*cuten(i)
+                   IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=0.
+                ENDDO
+                ENDDO
+              ENDIF
+            ENDIF
+
+!......     QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2)     
+
+            IF(PRESENT(RQICUTEN).AND.PRESENT(RQCCUTEN))THEN
+              IF (F_QI) THEN
+                DO K=kts,ktf
+                DO I=its,itf
+                   if(t2d(i,k).lt.258.)then
+                      RQICUTEN(I,K,J)=outqc(I,K)*cuten(i)
+                      RQCCUTEN(I,K,J)=0.
+                      IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=CUPCLW(I,K)*cuten(i)
+                   else
+                      RQICUTEN(I,K,J)=0.
+                      RQCCUTEN(I,K,J)=outqc(I,K)*cuten(i)
+                      IF ( PRESENT( GDC ) ) GDC(I,K,J)=CUPCLW(I,K)*cuten(i)
+                   endif
+                ENDDO
+                ENDDO
+              ENDIF
+            ENDIF
+
+            if (l_flux) then
+               DO K=kts,ktf
+               DO I=its,itf
+                  cfu1(i,k,j)=outcfu1(i,k)*cuten(i)
+                  cfd1(i,k,j)=outcfd1(i,k)*cuten(i)
+                  dfu1(i,k,j)=outdfu1(i,k)*cuten(i)
+                  efu1(i,k,j)=outefu1(i,k)*cuten(i)
+                  dfd1(i,k,j)=outdfd1(i,k)*cuten(i)
+                  efd1(i,k,j)=outefd1(i,k)*cuten(i)
+               enddo
+               enddo
+            endif
+        endif !jbeg,jend
+
+ 100    continue
+
+   END SUBROUTINE GRELLDRV
+
+
+   SUBROUTINE CUP_enss(OUTQC,J,AAEQ,T,Q,Z1,                            &
+              TN,QO,PO,PRE,P,OUTT,OUTQ,DTIME,PSUR,US,VS,               &
+              TCRIT,iens,mconv,massfln,iact,                           &
+              omeg,direction,massflx,maxiens,                          &
+              maxens,maxens2,maxens3,ensdim,                           &
+              APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                       &
+              APR_CAPMA,APR_CAPME,APR_CAPMI,kbcon,ktop,                &   !-lxz
+              xf_ens,pr_ens,xland,gsw,cupclw,                          &
+              xl,rv,cp,g,ichoice,ipr,jpr,                              &
+              outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1,l_flux,  &
+              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,ipr,jpr
+     integer, intent (in   )              ::                           &
+        j,ensdim,maxiens,maxens,maxens2,maxens3,ichoice,iens
+  !
+  ! 
+  !
+     real,    dimension (ims:ime,jms:jme,1:ensdim)                     &
+        ,intent (inout)                   ::                           &
+        massfln,xf_ens,pr_ens
+     real,    dimension (ims:ime,jms:jme)                              &
+        ,intent (inout )                  ::                           &
+               APR_GR,APR_W,APR_MC,APR_ST,APR_AS,APR_CAPMA,     &
+               APR_CAPME,APR_CAPMI,massflx
+     real,    dimension (ims:ime,jms:jme)                              &
+        ,intent (in   )                   ::                           &
+               xland,gsw
+     integer, dimension (its:ite,jts:jte)                              &
+        ,intent (in   )                   ::                           &
+        iact
+  ! outtem = output temp tendency (per s)
+  ! outq   = output q tendency (per s)
+  ! outqc  = output qc tendency (per s)
+  ! pre    = output precip
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        OUTT,OUTQ,OUTQC,CUPCLW,                                        &
+        outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1
+     logical, intent(in) :: l_flux
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        pre
+!+lxz
+     integer,    dimension (its:ite)                                   &
+        ,intent (out  )                   ::                           &
+        kbcon,ktop
+!.lxz
+  !
+  ! 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,TN,PO,P,US,VS,omeg
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout)                   ::                           &
+         Q,QO
+     real, dimension (its:ite)                                         &
+        ,intent (in   )                   ::                           &
+        Z1,PSUR,AAEQ,direction,mconv
+
+       
+       real                                                            &
+        ,intent (in   )                   ::                           &
+        dtime,tcrit,xl,cp,rv,g
+
+
+!
+!  local ensemble dependent variables in this routine
+!
+     real,    dimension (its:ite,1:maxens)  ::                         &
+        xaa0_ens
+     real,    dimension (1:maxens)  ::                                 &
+        mbdt_ens
+     real,    dimension (1:maxens2) ::                                 &
+        edt_ens
+     real,    dimension (its:ite,1:maxens2) ::                         &
+        edtc
+     real,    dimension (its:ite,kts:kte,1:maxens2) ::                 &
+        dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens
+     real,    dimension (its:ite,kts:kte,1:maxens2) ::                 &
+        CFU1_ens,CFD1_ens,DFU1_ens,EFU1_ens,DFD1_ens,EFD1_ens
+!
+!
+!
+!***************** 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
+  ! pr_ens = precipitation ensemble
+  ! xf_ens = mass flux ensembles
+  ! massfln = downdraft mass flux ensembles used in next timestep
+  ! omeg = omega from large scale model
+  ! mconv = moisture convergence from large scale model
+  ! zd      = downdraft normalized mass flux
+  ! zu      = updraft normalized mass flux
+  ! dir     = "storm motion"
+  ! mbdt    = arbitrary numerical parameter
+  ! dtime   = dt over which forcing is applied
+  ! iact_gr_old = flag to tell where convection was active
+  ! kbcon       = LFC of parcel from k22
+  ! k22         = updraft originating level
+  ! icoic       = flag if only want one closure (usually set to zero!)
+  ! 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,                                                  &
+        heo,heso,qeso,zo,                                              &
+        xhe,xhes,xqes,xz,xt,xq,                                        &
+
+        qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,      &
+        qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,     &
+        tn_cup,                                                        &
+        xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup,xp_cup,xgamma_cup,     &
+        xt_cup,                                                        &
+
+        dby,qc,qrcd,pwd,pw,hcd,qcd,dbyd,hc,qrc,zu,zd,clw_all,          &
+        dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco,zuo,zdo,      &
+        xdby,xqc,xqrcd,xpwd,xpw,xhcd,xqcd,xhc,xqrc,xzu,xzd,            &
+
+  ! cd  = detrainment function for updraft
+  ! cdd = detrainment function for downdraft
+  ! dellat = change of temperature per unit mass flux of cloud ensemble
+  ! dellaq = change of q per unit mass flux of cloud ensemble
+  ! dellaqc = change of qc per unit mass flux of cloud ensemble
+
+        cd,cdd,scr1,DELLAH,DELLAQ,DELLAT,DELLAQC,                      &
+        CFU1,CFD1,DFU1,EFU1,DFD1,EFD1
+
+  ! aa0 cloud work function for downdraft
+  ! edt = epsilon
+  ! aa0     = cloud work function without forcing effects
+  ! aa1     = cloud work function with forcing effects
+  ! xaa0    = cloud work function with cloud effects (ensemble dependent)
+  ! edt     = epsilon
+     real,    dimension (its:ite) ::                                   &
+       edt,edto,edtx,AA1,AA0,XAA0,HKB,HKBO,aad,XHKB,QKB,QKBO,          &
+       XMB,XPWAV,XPWEV,PWAV,PWEV,PWAVO,PWEVO,BU,BUO,cap_max,xland1,     &
+       cap_max_increment,closure_n
+     integer,    dimension (its:ite) ::                                &
+       kzdown,KDET,K22,KB,JMIN,kstabi,kstabm,K22x,                     &   !-lxz
+       KBCONx,KBx,KTOPx,ierr,ierr2,ierr3,KBMAX 
+
+     integer                              ::                           &
+       nall,iedt,nens,nens3,ki,I,K,KK,iresult
+     real                                 ::                           &
+      day,dz,mbdt,entr_rate,radius,entrd_rate,mentr_rate,mentrd_rate,  &
+      zcutdown,edtmax,edtmin,depth_min,zkbmax,z_detr,zktop,            &
+      massfld,dh,cap_maxs
+
+     integer :: itf,jtf,ktf
+     integer :: jmini
+     logical :: keep_going
+
+     itf=MIN(ite,ide-1)
+     ktf=MIN(kte,kde-1)
+     jtf=MIN(jte,jde-1)
+
+!sms$distribute end
+      day=86400.
+      do i=its,itf
+        closure_n(i)=16.
+        xland1(i)=1.
+        if(xland(i,j).gt.1.5)xland1(i)=0.
+        cap_max_increment(i)=25.
+      enddo
+!
+!--- specify entrainmentrate and detrainmentrate
+!
+      if(iens.le.4)then
+      radius=14000.-float(iens)*2000.
+      else
+      radius=12000.
+      endif
+!
+!--- 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
+        cupclw(i,k)=0.
+        cd(i,k)=0.1*entr_rate
+        cdd(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=75.
+!sms$to_local(grid_dh: <1, mix :size>, <2, mjx :size>) begin
+      DO 7 i=its,itf
+        kbmax(i)=1
+        aa0(i)=0.
+        aa1(i)=0.
+        aad(i)=0.
+        edt(i)=0.
+        kstabm(i)=ktf-1
+        IERR(i)=0
+        IERR2(i)=0
+        IERR3(i)=0
+        if(aaeq(i).lt.-1.)then
+           ierr(i)=20
+        endif
+ 7    CONTINUE
+!
+!--- first check for upstream convection
+!
+      do i=its,itf
+          cap_max(i)=cap_maxs
+!         if(tkmax(i,j).lt.2.)cap_max(i)=25.
+          if(gsw(i,j).lt.1.)cap_max(i)=25.
+
+        iresult=0
+!       massfld=0.
+!     call cup_direction2(i,j,direction,iact, &
+!          cu_mfx,iresult,0,massfld,  &
+!          ids,ide, jds,jde, kds,kde, &
+!          ims,ime, jms,jme, kms,kme, &
+!          its,ite, jts,jte, kts,kte)
+!         cap_max(i)=cap_maxs
+       if(iresult.eq.1)then
+          cap_max(i)=cap_maxs+20.
+       endif
+!      endif
+      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.
+!
+      do nens=1,maxens
+         mbdt_ens(nens)=(float(nens)-3.)*dtime*1.e-3+dtime*5.E-03
+      enddo
+      do nens=1,maxens2
+         edt_ens(nens)=.95-float(nens)*.01
+      enddo
+!     if(j.eq.jpr)then
+!       print *,'radius ensemble ',iens,radius
+!       print *,mbdt_ens
+!       print *,edt_ens
+!     endif
+!
+!--- environmental conditions, FIRST HEIGHTS
+!
+      do i=its,itf
+         if(ierr(i).ne.20)then
+            do k=1,maxens*maxens2*maxens3
+               xf_ens(i,j,(iens-1)*maxens*maxens2*maxens3+k)=0.
+               pr_ens(i,j,(iens-1)*maxens*maxens2*maxens3+k)=0.
+            enddo
+         endif
+      enddo
+!
+!--- 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)
+      call cup_env(zo,qeso,heo,heso,tn,qo,po,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(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, &
+           heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_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)
+      do i=its,itf
+      if(ierr(i).eq.0)then
+!
+      do k=kts,ktf-2
+        if(zo_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(zo_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(HEO_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,heo_cup,heso_cup, &
+           ierr,kbmax,po_cup,cap_max, &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+!     call cup_kbcon_cin(1,k22,kbcon,heo_cup,heso_cup,z,tn_cup, &
+!          qeso_cup,ierr,kbmax,po_cup,cap_max,xl,cp,&
+!          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(HEso_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)
+      call cup_up_he(k22,hkbo,zo_cup,cd,mentr_rate,heo_cup,hco, &
+           kbcon,ierr,dbyo,heo,heso_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,dbyo,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=(zo_cup(i,ktop(i))-z1(i))*.6
+            zktop=min(zktop+z1(i),zcutdown+z1(i))
+            do k=kts,kte
+              if(zo_cup(i,k).gt.zktop)then
+                 kzdown(i)=k
+                 go to 37
+              endif
+              enddo
+         endif
+ 37   CONTINUE
+!
+!--- DOWNDRAFT ORIGINATING LEVEL - JMIN
+!
+      call cup_minimi(HEso_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
+!
+!jm begin 20061212:  the following code replaces code that
+!   was too complex and causing problem for optimization.
+!   Done in consultation with G. Grell.
+        jmini = jmin(i)
+        keep_going = .TRUE.
+        DO WHILE ( keep_going )
+          keep_going = .FALSE.
+          if ( jmini - 1 .lt. kdet(i)   ) kdet(i) = jmini-1
+          if ( jmini     .ge. ktop(i)-1 ) jmini = ktop(i) - 2
+          ki = jmini
+          hcdo(i,ki)=heso_cup(i,ki)
+          DZ=Zo_cup(i,Ki+1)-Zo_cup(i,Ki)
+          dh=0.
+          DO k=ki-1,1,-1
+            hcdo(i,k)=heso_cup(i,jmini)
+            DZ=Zo_cup(i,K+1)-Zo_cup(i,K)
+            dh=dh+dz*(HCDo(i,K)-heso_cup(i,k))
+            IF(dh.gt.0.)THEN
+              jmini=jmini-1
+              IF ( jmini .gt. 3 ) THEN
+                keep_going = .TRUE.
+              ELSE
+                ierr(i) = 9
+                EXIT
+              ENDIF
+            ENDIF
+          ENDDO
+        ENDDO
+        jmin(i) = jmini
+        IF ( jmini .le. 3 ) THEN
+          ierr(i)=4
+        ENDIF
+!jm end 20061212
+      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(-zo_cup(I,KBCON(I))+zo_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)
+      call cup_up_nms(zuo,zo_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)
+      call cup_dd_nms(zdo,zo_cup,cdd,mentrd_rate,jmin,ierr, &
+           1,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)
+      call cup_dd_he(heso_cup,zdo,hcdo,zo_cup,cdd,mentrd_rate, &
+           jmin,ierr,heo,dbydo,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)
+      call cup_dd_moisture(zdo,hcdo,heso_cup,qcdo,qeso_cup, &
+           pwdo,qo_cup,zo_cup,cdd,mentrd_rate,jmin,ierr,gammao_cup, &
+           pwevo,bu,qrcdo,qo,heo,tn_cup,1,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)
+      do k=kts,ktf
+      do i=its,itf
+         cupclw(i,k)=qrc(i,k)
+      enddo
+      enddo
+      call cup_up_moisture(ierr,zo_cup,qco,qrco,pwo,pwavo, &
+           kbcon,ktop,cd,dbyo,mentr_rate,clw_all, &
+           qo,GAMMAo_cup,zuo,qeso_cup,k22,qo_cup,xl,&
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- calculate workfunctions for updrafts
+!
+      call cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup, &
+           kbcon,ktop,ierr,           &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+      call cup_up_aa0(aa1,zo,zuo,dbyo,GAMMAo_CUP,tn_cup, &
+           kbcon,ktop,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(aa1(i).eq.0.)then
+               ierr(i)=17
+           endif
+         endif
+      enddo
+!
+!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR
+!
+      call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, &
+           pwevo,edtmax,edtmin,maxens2,edtc, &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+      do 250 iedt=1,maxens2
+        do i=its,itf
+         if(ierr(i).eq.0)then
+         edt(i)=edtc(i,iedt)
+         edto(i)=edtc(i,iedt)
+         edtx(i)=edtc(i,iedt)
+         endif
+        enddo
+        do k=kts,ktf
+        do i=its,itf
+           dellat_ens(i,k,iedt)=0.
+           dellaq_ens(i,k,iedt)=0.
+           dellaqc_ens(i,k,iedt)=0.
+           pwo_ens(i,k,iedt)=0.
+        enddo
+        enddo
+        if (l_flux) then
+           do k=kts,ktf
+              do i=its,itf
+                 cfu1_ens(i,k,iedt)=0.
+                 cfd1_ens(i,k,iedt)=0.
+                 dfu1_ens(i,k,iedt)=0.
+                 efu1_ens(i,k,iedt)=0.
+                 dfd1_ens(i,k,iedt)=0.
+                 efd1_ens(i,k,iedt)=0.
+              enddo
+           enddo
+        endif
+!
+      do i=its,itf
+        aad(i)=0.
+      enddo
+!     do i=its,itf
+!       if(ierr(i).eq.0)then
+!        eddt(i,j)=edt(i)
+!        EDTX(I)=EDT(I)
+!        BU(I)=0.
+!        BUO(I)=0.
+!       endif
+!     enddo
+!
+!---downdraft workfunctions
+!
+!     call cup_dd_aa0(edt,ierr,aa0,jmin,gamma_cup,t_cup, &
+!          hcd,hes_cup,z,zd,          &
+!          ids,ide, jds,jde, kds,kde, &
+!          ims,ime, jms,jme, kms,kme, &
+!          its,ite, jts,jte, kts,kte)
+!     call cup_dd_aa0(edto,ierr,aad,jmin,gammao_cup,tn_cup, &
+!          hcdo,heso_cup,zo,zdo,      &
+!          ids,ide, jds,jde, kds,kde, &
+!          ims,ime, jms,jme, kms,kme, &
+!          its,ite, jts,jte, kts,kte)
+!
+!--- change per unit mass that a model cloud would modify the environment
+!
+!--- 1. in bottom layer
+!
+      call cup_dellabot(ipr,jpr,heo_cup,ierr,zo_cup,po,hcdo,edto, &
+           zuo,zdo,cdd,heo,dellah,j,mentrd_rate,zo,g, &
+           CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,l_flux,               &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+      call cup_dellabot(ipr,jpr,qo_cup,ierr,zo_cup,po,qrcdo,edto, &
+           zuo,zdo,cdd,qo,dellaq,j,mentrd_rate,zo,g,&
+           CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,.FALSE.,               &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- 2. everywhere else
+!
+      call cup_dellas(ierr,zo_cup,po_cup,hcdo,edto,zdo,cdd,    &
+           heo,dellah,j,mentrd_rate,zuo,g,                     &
+           cd,hco,ktop,k22,kbcon,mentr_rate,jmin,heo_cup,kdet, &
+           k22,ipr,jpr,'deep',                                 &
+           CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,l_flux,               &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+!
+!-- take out cloud liquid water for detrainment
+!
+!??   do k=kts,ktf
+      do k=kts,ktf-1
+      do i=its,itf
+       scr1(i,k)=0.
+       dellaqc(i,k)=0.
+       if(ierr(i).eq.0)then
+!       print *,'in vupnewg, after della ',ierr(i),aa0(i),i,j
+         scr1(i,k)=qco(i,k)-qrco(i,k)
+         if(k.eq.ktop(i)-0)dellaqc(i,k)= &
+                      .01*zuo(i,ktop(i))*qrco(i,ktop(i))* &
+                      9.81/(po_cup(i,k)-po_cup(i,k+1))
+         if(k.lt.ktop(i).and.k.gt.kbcon(i))then
+           dz=zo_cup(i,k+1)-zo_cup(i,k)
+           dellaqc(i,k)=.01*9.81*cd(i,k)*dz*zuo(i,k) &
+                        *.5*(qrco(i,k)+qrco(i,k+1))/ &
+                        (po_cup(i,k)-po_cup(i,k+1))
+         endif
+       endif
+      enddo
+      enddo
+      call cup_dellas(ierr,zo_cup,po_cup,qrcdo,edto,zdo,cdd, &
+           qo,dellaq,j,mentrd_rate,zuo,g, &
+           cd,scr1,ktop,k22,kbcon,mentr_rate,jmin,qo_cup,kdet, &
+           k22,ipr,jpr,'deep',               &
+           CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,.FALSE.,            &
+              ids,ide, jds,jde, kds,kde,                     &
+              ims,ime, jms,jme, kms,kme,                     &
+              its,ite, jts,jte, kts,kte    )
+!
+!--- using dellas, calculate changed environmental profiles
+!
+!     do 200 nens=1,maxens
+      mbdt=mbdt_ens(2)
+      do i=its,itf
+      xaa0_ens(i,1)=0.
+      xaa0_ens(i,2)=0.
+      xaa0_ens(i,3)=0.
+      enddo
+
+!     mbdt=mbdt_ens(nens)
+!     do i=its,itf 
+!     xaa0_ens(i,nens)=0.
+!     enddo
+      do k=kts,ktf
+      do i=its,itf
+         dellat(i,k)=0.
+         if(ierr(i).eq.0)then
+            XHE(I,K)=DELLAH(I,K)*MBDT+HEO(I,K)
+            XQ(I,K)=DELLAQ(I,K)*MBDT+QO(I,K)
+            DELLAT(I,K)=(1./cp)*(DELLAH(I,K)-xl*DELLAQ(I,K))
+            XT(I,K)= DELLAT(I,K)*MBDT+TN(I,K)
+            IF(XQ(I,K).LE.0.)XQ(I,K)=1.E-08
+!            if(i.eq.ipr.and.j.eq.jpr)then
+!              print *,k,DELLAH(I,K),DELLAQ(I,K),DELLAT(I,K)
+!            endif
+         ENDIF
+      enddo
+      enddo
+      do i=its,itf
+      if(ierr(i).eq.0)then
+      XHE(I,ktf)=HEO(I,ktf)
+      XQ(I,ktf)=QO(I,ktf)
+      XT(I,ktf)=TN(I,ktf)
+      IF(XQ(I,ktf).LE.0.)XQ(I,ktf)=1.E-08
+      endif
+      enddo
+!
+!--- calculate moist static energy, heights, qes
+!
+      call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, &
+           psur,ierr,tcrit,2,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(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, &
+           xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_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)
+!
+!
+!**************************** static control
+!
+!--- moist static energy inside cloud
+!
+      do i=its,itf
+        if(ierr(i).eq.0)then
+          xhkb(i)=xhe(i,k22(i))
+        endif
+      enddo
+      call cup_up_he(k22,xhkb,xz_cup,cd,mentr_rate,xhe_cup,xhc, &
+           kbcon,ierr,xdby,xhe,xhes_cup, &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+!
+!c--- normalized mass flux profile
+!
+      call cup_up_nms(xzu,xz_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)
+!
+!--- moisture downdraft
+!
+      call cup_dd_nms(xzd,xz_cup,cdd,mentrd_rate,jmin,ierr, &
+           1,kdet,z1,                 &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+      call cup_dd_he(xhes_cup,xzd,xhcd,xz_cup,cdd,mentrd_rate, &
+           jmin,ierr,xhe,dbyd,xhe_cup,&
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+      call cup_dd_moisture(xzd,xhcd,xhes_cup,xqcd,xqes_cup, &
+           xpwd,xq_cup,xz_cup,cdd,mentrd_rate,jmin,ierr,gamma_cup, &
+           xpwev,bu,xqrcd,xq,xhe,xt_cup,3,xl, &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+
+!
+!------- MOISTURE updraft
+!
+      call cup_up_moisture(ierr,xz_cup,xqc,xqrc,xpw,xpwav, &
+           kbcon,ktop,cd,xdby,mentr_rate,clw_all, &
+           xq,GAMMA_cup,xzu,xqes_cup,k22,xq_cup,xl, &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- workfunctions for updraft
+!
+      call cup_up_aa0(xaa0,xz,xzu,xdby,GAMMA_CUP,xt_cup, &
+           kbcon,ktop,ierr,           &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- workfunctions for downdraft
+!
+!
+!     call cup_dd_aa0(edtx,ierr,xaa0,jmin,gamma_cup,xt_cup, &
+!          xhcd,xhes_cup,xz,xzd,      &
+!          ids,ide, jds,jde, kds,kde, &
+!          ims,ime, jms,jme, kms,kme, &
+!          its,ite, jts,jte, kts,kte)
+      do 200 nens=1,maxens
+      do i=its,itf 
+         if(ierr(i).eq.0)then
+           xaa0_ens(i,nens)=xaa0(i)
+           nall=(iens-1)*maxens3*maxens*maxens2 &
+                +(iedt-1)*maxens*maxens3 &
+                +(nens-1)*maxens3
+           do k=kts,ktf
+              if(k.le.ktop(i))then
+                 do nens3=1,maxens3
+                 if(nens3.eq.7)then
+!--- b=0
+                 pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ &
+                                    pwo(i,k) 
+!                                  +edto(i)*pwdo(i,k)
+!--- b=beta
+                 else if(nens3.eq.8)then
+                 pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ &
+                                    pwo(i,k)
+!--- b=beta/2
+                 else if(nens3.eq.9)then
+                 pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ &
+                                    pwo(i,k)
+!                                  +.5*edto(i)*pwdo(i,k)
+                 else
+                 pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ &
+                                    pwo(i,k)+edto(i)*pwdo(i,k)
+                 endif
+                 enddo
+              endif
+           enddo
+         if(pr_ens(i,j,nall+7).lt.1.e-6)then
+            ierr(i)=18
+            do nens3=1,maxens3
+               pr_ens(i,j,nall+nens3)=0.
+            enddo
+         endif
+         do nens3=1,maxens3
+           if(pr_ens(i,j,nall+nens3).lt.1.e-4)then
+            pr_ens(i,j,nall+nens3)=0.
+           endif
+         enddo
+         endif
+      enddo
+ 200  continue
+!
+!--- LARGE SCALE FORCING
+!
+!
+!------- CHECK wether aa0 should have been zero
+!
+!
+      CALL cup_MAXIMI(HEO_CUP,3,KBMAX,K22x,ierr, &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+      do i=its,itf
+         ierr2(i)=ierr(i)
+         ierr3(i)=ierr(i)
+      enddo
+      call cup_kbcon(cap_max_increment,2,k22x,kbconx,heo_cup, &
+           heso_cup,ierr2,kbmax,po_cup,cap_max, &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+      call cup_kbcon(cap_max_increment,3,k22x,kbconx,heo_cup, &
+           heso_cup,ierr3,kbmax,po_cup,cap_max, &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+!
+!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
+!
+      call cup_forcing_ens(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt_ens,dtime,   &
+           ierr,ierr2,ierr3,xf_ens,j,'deeps',                 &
+           maxens,iens,iedt,maxens2,maxens3,mconv,            &
+           po_cup,ktop,omeg,zdo,k22,zuo,pr_ens,edto,kbcon,    &
+           massflx,iact,direction,ensdim,massfln,ichoice,     &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+!
+      do k=kts,ktf
+      do i=its,itf
+        if(ierr(i).eq.0)then
+           dellat_ens(i,k,iedt)=dellat(i,k)
+           dellaq_ens(i,k,iedt)=dellaq(i,k)
+           dellaqc_ens(i,k,iedt)=dellaqc(i,k)
+           pwo_ens(i,k,iedt)=pwo(i,k)+edt(i)*pwdo(i,k)
+        else 
+           dellat_ens(i,k,iedt)=0.
+           dellaq_ens(i,k,iedt)=0.
+           dellaqc_ens(i,k,iedt)=0.
+           pwo_ens(i,k,iedt)=0.
+        endif
+!      if(i.eq.ipr.and.j.eq.jpr)then
+!        print *,iens,iedt,dellat(i,k),dellat_ens(i,k,iedt), &
+!          dellaq(i,k), dellaqc(i,k)
+!      endif
+      enddo
+      enddo
+      if (l_flux) then
+         do k=kts,ktf
+            do i=its,itf
+               if(ierr(i).eq.0)then
+                 cfu1_ens(i,k,iedt)=cfu1(i,k)
+                 cfd1_ens(i,k,iedt)=cfd1(i,k)
+                 dfu1_ens(i,k,iedt)=dfu1(i,k)
+                 efu1_ens(i,k,iedt)=efu1(i,k)
+                 dfd1_ens(i,k,iedt)=dfd1(i,k)
+                 efd1_ens(i,k,iedt)=efd1(i,k)
+              else
+                 cfu1_ens(i,k,iedt)=0.
+                 cfd1_ens(i,k,iedt)=0.
+                 dfu1_ens(i,k,iedt)=0.
+                 efu1_ens(i,k,iedt)=0.
+                 dfd1_ens(i,k,iedt)=0.
+                 efd1_ens(i,k,iedt)=0.
+              end if
+           end do
+         end do
+      end if
+
+ 250  continue
+!
+!--- FEEDBACK
+!
+      call cup_output_ens(xf_ens,ierr,dellat_ens,dellaq_ens, &
+           dellaqc_ens,outt,outq,outqc,pre,pwo_ens,xmb,ktop, &
+           j,'deep',maxens2,maxens,iens,ierr2,ierr3,         &
+           pr_ens,maxens3,ensdim,massfln,                    &
+           APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                &
+           APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1,   &
+           outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1,  &
+           CFU1_ens,CFD1_ens,DFU1_ens,EFU1_ens,DFD1_ens,EFD1_ens,  &
+           l_flux,                                           &
+           ids,ide, jds,jde, kds,kde, &
+           ims,ime, jms,jme, kms,kme, &
+           its,ite, jts,jte, kts,kte)
+      do i=its,itf
+           PRE(I)=MAX(PRE(I),0.)
+      enddo
+!
+!---------------------------done------------------------------
+!
+
+   END SUBROUTINE CUP_enss
+
+
+   SUBROUTINE cup_dd_aa0(edt,ierr,aa0,jmin,gamma_cup,t_cup, &
+              hcd,hes_cup,z,zd,                             &
+              ids,ide, jds,jde, kds,kde,                    &
+              ims,ime, jms,jme, kms,kme,                    &
+              its,ite, jts,jte, kts,kte                    )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        ids,ide, jds,jde, kds,kde,                                     &
+        ims,ime, jms,jme, kms,kme,                                     &
+        its,ite, jts,jte, kts,kte
+  ! aa0 cloud work function for downdraft
+  ! gamma_cup = gamma on model cloud levels
+  ! t_cup = temperature (Kelvin) on model cloud levels
+  ! hes_cup = saturation moist static energy on model cloud levels
+  ! hcd = moist static energy in downdraft
+  ! edt = epsilon
+  ! zd normalized downdraft mass flux
+  ! z = heights of model levels 
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        z,zd,gamma_cup,t_cup,hes_cup,hcd
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        edt
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        jmin
+!
+! input and output
+!
+
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        aa0
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k,kk
+     real                                 ::                           &
+        dz
+!
+     integer :: itf, ktf
+!
+     itf=MIN(ite,ide-1)
+     ktf=MIN(kte,kde-1)
+!
+!??    DO k=kts,kte-1
+       DO k=kts,ktf-1
+       do i=its,itf
+         IF(ierr(I).eq.0.and.k.lt.jmin(i))then
+         KK=JMIN(I)-K
+!
+!--- ORIGINAL
+!
+         DZ=(Z(I,KK)-Z(I,KK+1))
+         AA0(I)=AA0(I)+zd(i,kk)*EDT(I)*DZ*(9.81/(1004.*T_cup(I,KK))) &
+            *((hcd(i,kk)-hes_cup(i,kk))/(1.+GAMMA_cup(i,kk)))
+         endif
+      enddo
+      enddo
+
+   END SUBROUTINE CUP_dd_aa0
+
+
+   SUBROUTINE cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, &
+              pwev,edtmax,edtmin,maxens2,edtc,               &
+              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   )              ::                           &
+        maxens2
+  !
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        us,vs,z,p
+     real,    dimension (its:ite,1:maxens2)                            &
+        ,intent (out  )                   ::                           &
+        edtc
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        edt
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        pwav,pwev
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        edtmax,edtmin
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        ktop,kbcon
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+!
+!  local variables in this routine
+!
+
+     integer i,k,kk
+     real    einc,pef,pefb,prezk,zkbc
+     real,    dimension (its:ite)         ::                           &
+      vshear,sdp,vws
+
+     integer :: itf, ktf
+
+     itf=MIN(ite,ide-1)
+     ktf=MIN(kte,kde-1)
+!
+!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR
+!
+! */ calculate an average wind shear over the depth of the cloud
+!
+       do i=its,itf
+        edt(i)=0.
+        vws(i)=0.
+        sdp(i)=0.
+        vshear(i)=0.
+       enddo
+       do kk = kts,ktf-1
+         do 62 i=its,itf
+          IF(ierr(i).ne.0)GO TO 62
+          if (kk .le. min0(ktop(i),ktf) .and. kk .ge. kbcon(i)) then
+             vws(i) = vws(i)+ &
+              (abs((us(i,kk+1)-us(i,kk))/(z(i,kk+1)-z(i,kk))) &
+          +   abs((vs(i,kk+1)-vs(i,kk))/(z(i,kk+1)-z(i,kk)))) * &
+              (p(i,kk) - p(i,kk+1))
+            sdp(i) = sdp(i) + p(i,kk) - p(i,kk+1)
+          endif
+          if (kk .eq. ktf-1)vshear(i) = 1.e3 * vws(i) / sdp(i)
+   62   continue
+       end do
+      do i=its,itf
+         IF(ierr(i).eq.0)then
+            pef=(1.591-.639*VSHEAR(I)+.0953*(VSHEAR(I)**2) &
+               -.00496*(VSHEAR(I)**3))
+            if(pef.gt.edtmax)pef=edtmax
+            if(pef.lt.edtmin)pef=edtmin
+!
+!--- cloud base precip efficiency
+!
+            zkbc=z(i,kbcon(i))*3.281e-3
+            prezk=.02
+            if(zkbc.gt.3.)then
+               prezk=.96729352+zkbc*(-.70034167+zkbc*(.162179896+zkbc &
+               *(- 1.2569798E-2+zkbc*(4.2772E-4-zkbc*5.44E-6))))
+            endif
+            if(zkbc.gt.25)then
+               prezk=2.4
+            endif
+            pefb=1./(1.+prezk)
+            if(pefb.gt.edtmax)pefb=edtmax
+            if(pefb.lt.edtmin)pefb=edtmin
+            EDT(I)=1.-.5*(pefb+pef)
+!--- edt here is 1-precipeff!
+!           einc=(1.-edt(i))/float(maxens2)
+!           einc=edt(i)/float(maxens2+1)
+!--- 20 percent
+            einc=.2*edt(i)
+            do k=1,maxens2
+                edtc(i,k)=edt(i)+float(k-2)*einc
+            enddo
+         endif
+      enddo
+      do i=its,itf
+         IF(ierr(i).eq.0)then
+            do k=1,maxens2
+               EDTC(I,K)=-EDTC(I,K)*PWAV(I)/PWEV(I)
+               IF(EDTC(I,K).GT.edtmax)EDTC(I,K)=edtmax
+               IF(EDTC(I,K).LT.edtmin)EDTC(I,K)=edtmin
+            enddo
+         endif
+      enddo
+
+   END SUBROUTINE cup_dd_edt
+
+
+   SUBROUTINE cup_dd_he(hes_cup,zd,hcd,z_cup,cdd,entr,       &
+              jmin,ierr,he,dby,he_cup,                       &
+              ids,ide, jds,jde, kds,kde,                     &
+              ims,ime, jms,jme, kms,kme,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+                                  ids,ide, jds,jde, kds,kde,           &
+                                  ims,ime, jms,jme, kms,kme,           &
+                                  its,ite, jts,jte, kts,kte
+  ! hcd = downdraft moist static energy
+  ! he = moist static energy on model levels
+  ! he_cup = moist static energy on model cloud levels
+  ! hes_cup = saturation moist static energy on model cloud levels
+  ! dby = buoancy term
+  ! cdd= detrainment function 
+  ! z_cup = heights of model cloud levels 
+  ! entr = entrainment rate
+  ! zd   = downdraft normalized mass flux
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        he,he_cup,hes_cup,z_cup,cdd,zd
+  ! entr= entrainment rate 
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        entr
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        jmin
+!
+! input and output
+!
+
+   ! ierr error value, maybe modified in this routine
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        hcd,dby
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k,ki
+     real                                 ::                           &
+        dz
+
+     integer :: itf, ktf
+
+     itf=MIN(ite,ide-1)
+     ktf=MIN(kte,kde-1)
+
+      do k=kts+1,ktf
+      do i=its,itf
+      dby(i,k)=0.
+      IF(ierr(I).eq.0)then
+         hcd(i,k)=hes_cup(i,k)
+      endif
+      enddo
+      enddo
+!
+      do 100 i=its,itf
+      IF(ierr(I).eq.0)then
+      k=jmin(i)
+      hcd(i,k)=hes_cup(i,k)
+      dby(i,k)=hcd(i,jmin(i))-hes_cup(i,k)
+!
+      do ki=jmin(i)-1,1,-1
+         DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki)
+         HCD(i,Ki)=(HCD(i,Ki+1)*(1.-.5*CDD(i,Ki)*DZ) &
+                  +entr*DZ*HE(i,Ki) &
+                  )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ)
+         dby(i,ki)=HCD(i,Ki)-hes_cup(i,ki)
+      enddo
+!
+      endif
+!--- end loop over i
+100    continue
+
+
+   END SUBROUTINE cup_dd_he
+
+
+   SUBROUTINE cup_dd_moisture(zd,hcd,hes_cup,qcd,qes_cup,    &
+              pwd,q_cup,z_cup,cdd,entr,jmin,ierr,            &
+              gamma_cup,pwev,bu,qrcd,                        &
+              q,he,t_cup,iloop,xl,                           &
+              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
+  ! cdd= detrainment function 
+  ! q = environmental q on model levels
+  ! q_cup = environmental q on model cloud levels
+  ! qes_cup = saturation q on model cloud levels
+  ! hes_cup = saturation h on model cloud levels
+  ! 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 
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        zd,t_cup,hes_cup,hcd,qes_cup,q_cup,z_cup,cdd,gamma_cup,q,he 
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        entr,xl
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        iloop
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        jmin
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        qcd,qrcd,pwd
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        pwev,bu
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k,ki
+     real                                 ::                           &
+        dh,dz,dqeva
+
+     integer :: itf, ktf
+
+     itf=MIN(ite,ide-1)
+     ktf=MIN(kte,kde-1)
+
+      do i=its,itf
+         bu(i)=0.
+         pwev(i)=0.
+      enddo
+      do k=kts,ktf
+      do i=its,itf
+         qcd(i,k)=0.
+         qrcd(i,k)=0.
+         pwd(i,k)=0.
+      enddo
+      enddo
+!
+!
+!
+      do 100 i=its,itf
+      IF(ierr(I).eq.0)then
+      k=jmin(i)
+      DZ=Z_cup(i,K+1)-Z_cup(i,K)
+      qcd(i,k)=q_cup(i,k)
+!     qcd(i,k)=.5*(qes_cup(i,k)+q_cup(i,k))
+      qrcd(i,k)=qes_cup(i,k)
+      pwd(i,jmin(i))=min(0.,qcd(i,k)-qrcd(i,k))
+      pwev(i)=pwev(i)+pwd(i,jmin(i))
+      qcd(i,k)=qes_cup(i,k)
+!
+      DH=HCD(I,k)-HES_cup(I,K)
+      bu(i)=dz*dh
+      do ki=jmin(i)-1,1,-1
+         DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki)
+         QCD(i,Ki)=(qCD(i,Ki+1)*(1.-.5*CDD(i,Ki)*DZ) &
+                  +entr*DZ*q(i,Ki) &
+                  )/(1.+entr*DZ-.5*CDD(i,Ki)*DZ)
+!
+!--- to be negatively buoyant, hcd should be smaller than hes!
+!
+         DH=HCD(I,ki)-HES_cup(I,Ki)
+         bu(i)=bu(i)+dz*dh
+         QRCD(I,Ki)=qes_cup(i,ki)+(1./XL)*(GAMMA_cup(i,ki) &
+                  /(1.+GAMMA_cup(i,ki)))*DH
+         dqeva=qcd(i,ki)-qrcd(i,ki)
+         if(dqeva.gt.0.)dqeva=0.
+         pwd(i,ki)=zd(i,ki)*dqeva
+         qcd(i,ki)=qrcd(i,ki)
+         pwev(i)=pwev(i)+pwd(i,ki)
+!        if(iloop.eq.1.and.i.eq.102.and.j.eq.62)then
+!         print *,'in cup_dd_moi ', hcd(i,ki),HES_cup(I,Ki),dh,dqeva
+!        endif
+      enddo
+!
+!--- end loop over i
+       if(pwev(I).eq.0.and.iloop.eq.1)then
+!        print *,'problem with buoy in cup_dd_moisture',i
+         ierr(i)=7
+       endif
+       if(BU(I).GE.0.and.iloop.eq.1)then
+!        print *,'problem with buoy in cup_dd_moisture',i
+         ierr(i)=7
+       endif
+      endif
+100    continue
+
+   END SUBROUTINE cup_dd_moisture
+
+
+   SUBROUTINE cup_dd_nms(zd,z_cup,cdd,entr,jmin,ierr,        &
+              itest,kdet,z1,                                 &
+              ids,ide, jds,jde, kds,kde,                     &
+              ims,ime, jms,jme, kms,kme,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+                                  ids,ide, jds,jde, kds,kde,           &
+                                  ims,ime, jms,jme, kms,kme,           &
+                                  its,ite, jts,jte, kts,kte
+  ! z_cup = height of cloud model level
+  ! z1 = terrain elevation
+  ! entr = downdraft entrainment rate
+  ! jmin = downdraft originating level
+  ! kdet = level above ground where downdraft start detraining
+  ! itest = flag to whether to calculate cdd
+  
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        z_cup
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        z1 
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        entr 
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        jmin,kdet
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itest
+!
+! input and output
+!
+
+   ! ierr error value, maybe modified in this routine
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+                                                                 ierr
+   ! zd is the normalized downdraft mass flux
+   ! cdd is the downdraft detrainmen function
+
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+                                                             zd
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout)                   ::                           &
+                                                             cdd
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+                                                  i,k,ki
+     real                                 ::                           &
+                                            a,perc,dz
+
+     integer :: itf, ktf
+
+     itf=MIN(ite,ide-1)
+     ktf=MIN(kte,kde-1)
+!
+!--- perc is the percentage of mass left when hitting the ground
+!
+      perc=.03
+
+      do k=kts,ktf
+      do i=its,itf
+         zd(i,k)=0.
+         if(itest.eq.0)cdd(i,k)=0.
+      enddo
+      enddo
+      a=1.-perc
+!
+!
+!
+      do 100 i=its,itf
+      IF(ierr(I).eq.0)then
+      zd(i,jmin(i))=1.
+!
+!--- integrate downward, specify detrainment(cdd)!
+!
+      do ki=jmin(i)-1,1,-1
+         DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki)
+         if(ki.le.kdet(i).and.itest.eq.0)then
+           cdd(i,ki)=entr+(1.- (a*(z_cup(i,ki)-z1(i)) &
+                     +perc*(z_cup(i,kdet(i))-z1(i)) ) &
+                         /(a*(z_cup(i,ki+1)-z1(i)) &
+                      +perc*(z_cup(i,kdet(i))-z1(i))))/dz
+         endif
+         zd(i,ki)=zd(i,ki+1)*(1.+(entr-cdd(i,ki))*dz)
+      enddo
+!
+      endif
+!--- end loop over i
+100    continue
+
+   END SUBROUTINE cup_dd_nms
+
+
+   SUBROUTINE cup_dellabot(ipr,jpr,he_cup,ierr,z_cup,p_cup,  &
+              hcd,edt,zu,zd,cdd,he,della,j,mentrd_rate,z,g,     &
+              CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,l_flux,  &
+              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   )              ::                           &
+        j,ipr,jpr
+  !
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        della
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in  )                   ::                           &
+        z_cup,p_cup,hcd,zu,zd,cdd,he,z,he_cup
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        edt
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        g,mentrd_rate
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout  )                 ::                           &
+        CFU1,CFD1,DFU1,EFU1,DFD1,EFD1
+     logical, intent(in) :: l_flux
+!
+!  local variables in this routine
+!
+
+      integer i
+      real detdo,detdo1,detdo2,entdo,dp,dz,subin,                      &
+      totmas
+!
+     integer :: itf, ktf
+
+     itf=MIN(ite,ide-1)
+     ktf=MIN(kte,kde-1)
+!
+!
+!      if(j.eq.jpr)print *,'in cup dellabot '
+      do 100 i=its,itf
+      if (l_flux) then
+         cfu1(i,1)=0.
+         cfd1(i,1)=0.
+         cfu1(i,2)=0.
+         cfd1(i,2)=0.
+         dfu1(i,1)=0.
+         efu1(i,1)=0.
+         dfd1(i,1)=0.
+         efd1(i,1)=0.
+      endif
+      della(i,1)=0.
+      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
+      DELLA(I,1)=(detdo1*.5*(HCD(i,1)+HCD(i,2)) &
+                 +detdo2*hcd(i,1) &
+                 +subin*he_cup(i,2) &
+                 -entdo*he(i,1))*g/dp
+      if (l_flux) then
+         cfd1(i,2)   = -edt(i)*zd(i,2)  !only contribution to subin, subdown=0
+         dfd1(i,1)   =  detdo1+detdo2
+         efd1(i,1)   = -entdo
+      endif
+ 100  CONTINUE
+
+   END SUBROUTINE cup_dellabot
+
+
+   SUBROUTINE cup_dellas(ierr,z_cup,p_cup,hcd,edt,zd,cdd,              &
+              he,della,j,mentrd_rate,zu,g,                             &
+              cd,hc,ktop,k22,kbcon,mentr_rate,jmin,he_cup,kdet,kpbl,   &
+              ipr,jpr,name,                                            &
+              CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,l_flux,  &
+              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   )              ::                           &
+        j,ipr,jpr
+  !
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        della
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in  )                   ::                           &
+        z_cup,p_cup,hcd,zd,cdd,he,hc,cd,zu,he_cup
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        edt
+     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
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout  )                 ::                           &
+        CFU1,CFD1,DFU1,EFU1,DFD1,EFD1
+     logical, intent(in) :: l_flux
+!
+!  local variables in this routine
+!
+
+      integer i,k
+      real detdo1,detdo2,entdo,dp,dz,subin,detdo,entup,                &
+      detup,subdown,entdoj,entupk,detupk,totmas
+!
+     integer :: itf, ktf
+
+     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 K=kts+1,ktf
+       do i=its,itf
+          della(i,k)=0.
+       enddo
+       enddo
+       if (l_flux) then
+          DO K=kts+1,ktf-1
+             do i=its,itf
+                cfu1(i,k+1)=0.
+                cfd1(i,k+1)=0.
+             enddo
+          enddo
+          DO K=kts+1,ktf
+             do i=its,itf
+                dfu1(i,k)=0.
+                efu1(i,k)=0.
+                dfd1(i,k)=0.
+                efd1(i,k)=0.
+             enddo
+          enddo
+       endif
+!
+       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
+         if (l_flux) then
+! z_cup(k+1):      zu(k+1), -zd(k+1) ==> subin   ==> cf[du]1   (k+1)  (full-eta level k+1)
+!
+! z(k)      :      detup, detdo, entup, entdo    ==> [de]f[du]1 (k)   (half-eta level  k )
+!
+! z_cup(k)  :      zu(k), -zd(k)     ==> subdown ==> cf[du]1    (k)   (full-eta level  k )
+
+! Store downdraft/updraft mass fluxes at full eta level k (z_cup(k)) in cf[ud]1(k):
+            cfu1(i,k+1)   =  zu(i,k+1)
+            cfd1(i,k+1)   = -edt(i)*zd(i,k+1)
+! Store detrainment/entrainment mass fluxes at half eta level k (z(k)) in [de]f[du]1(k):
+            dfu1(i,k) =   detup+detupk
+            efu1(i,k) = -(entup+entupk)
+            dfd1(i,k) =   detdo
+            efd1(i,k) = -(entdo+entdoj)
+         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,
+!     1   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 ( 'totmas .gt.1.e-6' )
+         endif
+         dp=100.*(p_cup(i,k-1)-p_cup(i,k))
+         della(i,k)=(subin*he_cup(i,k+1) &
+                    -subdown*he_cup(i,k) &
+                    +detup*.5*(HC(i,K+1)+HC(i,K)) &
+                    +detdo*.5*(HCD(i,K+1)+HCD(i,K)) &
+                    -entup*he(i,k) &
+                    -entdo*he(i,k) &
+                    -entupk*he_cup(i,k22(i)) &
+                    -entdoj*he_cup(i,jmin(i)) &
+                    +detupk*hc(i,ktop(i)) &
+                     )*g/dp
+!      if(i.eq.ipr.and.j.eq.jpr)then
+!        print *,k,della(i,k),subin*he_cup(i,k+1),subdown*he_cup(i,k),
+!     1            detdo*.5*(HCD(i,K+1)+HCD(i,K))
+!        print *,k,detup*.5*(HC(i,K+1)+HC(i,K)),detupk*hc(i,ktop(i)),
+!     1         entup*he(i,k),entdo*he(i,k)
+!        print *,k,he_cup(i,k+1),he_cup(i,k),entupk*he_cup(i,k)
+!      endif
+
+ 100  CONTINUE
+
+   END SUBROUTINE cup_dellas
+
+
+   SUBROUTINE cup_direction2(i,j,dir,id,massflx,             &
+              iresult,imass,massfld,                         &
+              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   )              ::                           &
+        i,j,imass
+     integer, intent (out  )              ::                           &
+        iresult
+  !
+  ! ierr error value, maybe modified in this routine
+  !
+     integer,    dimension (ims:ime,jms:jme)                           &
+        ,intent (in   )                   ::                           &
+        id
+     real,    dimension (ims:ime,jms:jme)                              &
+        ,intent (in   )                   ::                           &
+        massflx
+     real,    dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        dir
+     real                                                              &
+        ,intent (out  )                   ::                           &
+        massfld
+!
+!  local variables in this routine
+!
+
+       integer k,ia,ja,ib,jb
+       real diff
+!
+!
+!
+       if(imass.eq.1)then
+           massfld=massflx(i,j)
+       endif
+       iresult=0
+!      return
+       diff=22.5
+       if(dir(i).lt.22.5)dir(i)=360.+dir(i)
+       if(id(i,j).eq.1)iresult=1
+!      ja=max(2,j-1)
+!      ia=max(2,i-1)
+!      jb=min(mjx-1,j+1)
+!      ib=min(mix-1,i+1)
+       ja=j-1
+       ia=i-1
+       jb=j+1
+       ib=i+1
+        if(dir(i).gt.90.-diff.and.dir(i).le.90.+diff)then
+!--- steering flow from the east
+          if(id(ib,j).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(ib,j),massflx(i,j))
+            endif
+            return
+          endif
+        else if(dir(i).gt.135.-diff.and.dir(i).le.135.+diff)then
+!--- steering flow from the south-east
+          if(id(ib,ja).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(ib,ja),massflx(i,j))
+            endif
+            return
+          endif
+!--- steering flow from the south
+        else if(dir(i).gt.180.-diff.and.dir(i).le.180.+diff)then
+          if(id(i,ja).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(i,ja),massflx(i,j))
+            endif
+            return
+          endif
+!--- steering flow from the south west
+        else if(dir(i).gt.225.-diff.and.dir(i).le.225.+diff)then
+          if(id(ia,ja).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(ia,ja),massflx(i,j))
+            endif
+            return
+          endif
+!--- steering flow from the west
+        else if(dir(i).gt.270.-diff.and.dir(i).le.270.+diff)then
+          if(id(ia,j).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(ia,j),massflx(i,j))
+            endif
+            return
+          endif
+!--- steering flow from the north-west
+        else if(dir(i).gt.305.-diff.and.dir(i).le.305.+diff)then
+          if(id(ia,jb).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(ia,jb),massflx(i,j))
+            endif
+            return
+          endif
+!--- steering flow from the north
+        else if(dir(i).gt.360.-diff.and.dir(i).le.360.+diff)then
+          if(id(i,jb).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(i,jb),massflx(i,j))
+            endif
+            return
+          endif
+!--- steering flow from the north-east
+        else if(dir(i).gt.45.-diff.and.dir(i).le.45.+diff)then
+          if(id(ib,jb).eq.1)then
+            iresult=1
+            if(imass.eq.1)then
+               massfld=max(massflx(ib,jb),massflx(i,j))
+            endif
+            return
+          endif
+        endif
+
+   END SUBROUTINE cup_direction2
+
+
+   SUBROUTINE cup_env(z,qes,he,hes,t,q,p,z1,                 &
+              psur,ierr,tcrit,itest,xl,cp,                   &
+              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
+  !
+  ! ierr error value, maybe modified in this routine
+  ! q           = environmental mixing ratio
+  ! qes         = environmental saturation mixing ratio
+  ! t           = environmental temp
+  ! tv          = environmental virtual temp
+  ! p           = environmental pressure
+  ! z           = environmental heights
+  ! he          = environmental moist static energy
+  ! hes         = environmental saturation moist static energy
+  ! psur        = surface pressure
+  ! z1          = terrain elevation
+  ! 
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        p,t
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        he,hes,qes
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout)                   ::                           &
+        z,q
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        psur,z1
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        xl,cp
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itest
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+       i,k,iph
+      real, dimension (1:2) :: AE,BE,HT
+      real, dimension (its:ite,kts:kte) :: tv
+      real :: tcrit,e,tvbar
+
+     integer :: itf, ktf
+
+     itf=MIN(ite,ide-1)
+     ktf=MIN(kte,kde-1)
+
+      HT(1)=XL/CP
+      HT(2)=2.834E6/CP
+      BE(1)=.622*HT(1)/.286
+      AE(1)=BE(1)/273.+ALOG(610.71)
+      BE(2)=.622*HT(2)/.286
+      AE(2)=BE(2)/273.+ALOG(610.71)
+!      print *, 'TCRIT = ', tcrit,its,ite
+      DO k=kts,ktf
+      do i=its,itf
+        if(ierr(i).eq.0)then
+!Csgb - IPH is for phase, dependent on TCRIT (water or ice)
+        IPH=1
+        IF(T(I,K).LE.TCRIT)IPH=2
+!       print *, 'AE(IPH),BE(IPH) = ',AE(IPH),BE(IPH),AE(IPH)-BE(IPH),T(i,k),i,k
+        E=EXP(AE(IPH)-BE(IPH)/T(I,K))
+!       print *, 'P, E = ', P(I,K), E
+        QES(I,K)=.622*E/(100.*P(I,K)-E)
+        IF(QES(I,K).LE.1.E-08)QES(I,K)=1.E-08
+        IF(Q(I,K).GT.QES(I,K))Q(I,K)=QES(I,K)
+        TV(I,K)=T(I,K)+.608*Q(I,K)*T(I,K)
+        endif
+      enddo
+      enddo
+!
+!--- z's are calculated with changed h's and q's and t's
+!--- if itest=2
+!
+      if(itest.ne.2)then
+         do i=its,itf
+           if(ierr(i).eq.0)then
+             Z(I,1)=max(0.,Z1(I))-(ALOG(P(I,1))- &
+                 ALOG(PSUR(I)))*287.*TV(I,1)/9.81
+           endif
+         enddo
+
+! --- calculate heights
+         DO K=kts+1,ktf
+         do i=its,itf
+           if(ierr(i).eq.0)then
+              TVBAR=.5*TV(I,K)+.5*TV(I,K-1)
+              Z(I,K)=Z(I,K-1)-(ALOG(P(I,K))- &
+               ALOG(P(I,K-1)))*287.*TVBAR/9.81
+           endif
+         enddo
+         enddo
+      else
+         do k=kts,ktf
+         do i=its,itf
+           if(ierr(i).eq.0)then
+             z(i,k)=(he(i,k)-1004.*t(i,k)-2.5e6*q(i,k))/9.81
+             z(i,k)=max(1.e-3,z(i,k))
+           endif
+         enddo
+         enddo
+      endif
+!
+!--- calculate moist static energy - HE
+!    saturated moist static energy - HES
+!
+       DO k=kts,ktf
+       do i=its,itf
+         if(ierr(i).eq.0)then
+         if(itest.eq.0)HE(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*Q(I,K)
+         HES(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*QES(I,K)
+         IF(HE(I,K).GE.HES(I,K))HE(I,K)=HES(I,K)
+!         if(i.eq.2)then
+!           print *,k,z(i,k),t(i,k),p(i,k),he(i,k),hes(i,k)
+!         endif
+         endif
+      enddo
+      enddo
+
+   END SUBROUTINE cup_env
+
+
+   SUBROUTINE 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                       )
+
+   IMPLICIT NONE
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        ids,ide, jds,jde, kds,kde,           &
+        ims,ime, jms,jme, kms,kme,           &
+        its,ite, jts,jte, kts,kte
+  !
+  ! ierr error value, maybe modified in this routine
+  ! q           = environmental mixing ratio
+  ! q_cup       = environmental mixing ratio on cloud levels
+  ! qes         = environmental saturation mixing ratio
+  ! qes_cup     = environmental saturation mixing ratio on cloud levels
+  ! t           = environmental temp
+  ! t_cup       = environmental temp on cloud levels
+  ! p           = environmental pressure
+  ! p_cup       = environmental pressure on cloud levels
+  ! z           = environmental heights
+  ! z_cup       = environmental heights on cloud levels
+  ! he          = environmental moist static energy
+  ! he_cup      = environmental moist static energy on cloud levels
+  ! hes         = environmental saturation moist static energy
+  ! hes_cup     = environmental saturation moist static energy on cloud levels
+  ! gamma_cup   = gamma on cloud levels
+  ! psur        = surface pressure
+  ! z1          = terrain elevation
+  ! 
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        qes,q,he,hes,z,p,t
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        psur,z1
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        xl,rv,cp
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+       i,k
+
+     integer :: itf, ktf
+
+     itf=MIN(ite,ide-1)
+     ktf=MIN(kte,kde-1)
+
+      do k=kts+1,ktf
+      do i=its,itf
+        if(ierr(i).eq.0)then
+        qes_cup(i,k)=.5*(qes(i,k-1)+qes(i,k))
+        q_cup(i,k)=.5*(q(i,k-1)+q(i,k))
+        hes_cup(i,k)=.5*(hes(i,k-1)+hes(i,k))
+        he_cup(i,k)=.5*(he(i,k-1)+he(i,k))
+        if(he_cup(i,k).gt.hes_cup(i,k))he_cup(i,k)=hes_cup(i,k)
+        z_cup(i,k)=.5*(z(i,k-1)+z(i,k))
+        p_cup(i,k)=.5*(p(i,k-1)+p(i,k))
+        t_cup(i,k)=.5*(t(i,k-1)+t(i,k))
+        gamma_cup(i,k)=(xl/cp)*(xl/(rv*t_cup(i,k) &
+                       *t_cup(i,k)))*qes_cup(i,k)
+        endif
+      enddo
+      enddo
+      do i=its,itf
+        if(ierr(i).eq.0)then
+        qes_cup(i,1)=qes(i,1)
+        q_cup(i,1)=q(i,1)
+        hes_cup(i,1)=hes(i,1)
+        he_cup(i,1)=he(i,1)
+        z_cup(i,1)=.5*(z(i,1)+z1(i))
+        p_cup(i,1)=.5*(p(i,1)+psur(i))
+        t_cup(i,1)=t(i,1)
+        gamma_cup(i,1)=xl/cp*(xl/(rv*t_cup(i,1) &
+                       *t_cup(i,1)))*qes_cup(i,1)
+        endif
+      enddo
+
+   END SUBROUTINE cup_env_clev
+
+
+   SUBROUTINE cup_forcing_ens(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,&
+              xf_ens,j,name,maxens,iens,iedt,maxens2,maxens3,mconv,    &
+              p_cup,ktop,omeg,zd,k22,zu,pr_ens,edt,kbcon,massflx,      &
+              iact_old_gr,dir,ensdim,massfln,icoic,                    &
+              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   )              ::                           &
+        j,ensdim,maxens,iens,iedt,maxens2,maxens3
+  !
+  ! ierr error value, maybe modified in this routine
+  ! pr_ens = precipitation ensemble
+  ! xf_ens = mass flux ensembles
+  ! massfln = downdraft mass flux ensembles used in next timestep
+  ! omeg = omega from large scale model
+  ! mconv = moisture convergence from large scale model
+  ! zd      = downdraft normalized mass flux
+  ! zu      = updraft normalized mass flux
+  ! aa0     = cloud work function without forcing effects
+  ! aa1     = cloud work function with forcing effects
+  ! xaa0    = cloud work function with cloud effects (ensemble dependent)
+  ! edt     = epsilon
+  ! dir     = "storm motion"
+  ! mbdt    = arbitrary numerical parameter
+  ! dtime   = dt over which forcing is applied
+  ! iact_gr_old = flag to tell where convection was active
+  ! kbcon       = LFC of parcel from k22
+  ! k22         = updraft originating level
+  ! icoic       = flag if only want one closure (usually set to zero!)
+  ! name        = deep or shallow convection flag
+  !
+     real,    dimension (ims:ime,jms:jme,1:ensdim)                     &
+        ,intent (inout)                   ::                           &
+        pr_ens
+     real,    dimension (ims:ime,jms:jme,1:ensdim)                     &
+        ,intent (out  )                   ::                           &
+        xf_ens,massfln
+     real,    dimension (ims:ime,jms:jme)                              &
+        ,intent (in   )                   ::                           &
+        massflx
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        omeg,zd,zu,p_cup
+     real,    dimension (its:ite,1:maxens)                             &
+        ,intent (in   )                   ::                           &
+        xaa0
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        aa1,edt,dir,mconv,xland
+     real,    dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        aa0,closure_n
+     real,    dimension (1:maxens)                                     &
+        ,intent (in   )                   ::                           &
+        mbdt
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        dtime
+     integer, dimension (its:ite,jts:jte)                              &
+        ,intent (in   )                   ::                           &
+        iact_old_gr
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        k22,kbcon,ktop
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr,ierr2,ierr3
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        icoic
+      character *(*), intent (in)         ::                           &
+       name
+!
+!  local variables in this routine
+!
+
+     real,    dimension (1:maxens3)       ::                           &
+       xff_ens3
+     real,    dimension (1:maxens)        ::                           &
+       xk
+     integer                              ::                           &
+       i,k,nall,n,ne,nens,nens3,iresult,iresultd,iresulte,mkxcrt,kclim
+     parameter (mkxcrt=15)
+     real                                 ::                           &
+       a1,massfld,xff0,xomg,aclim1,aclim2,aclim3,aclim4
+     real,    dimension(1:mkxcrt)         ::                           &
+       pcrit,acrit,acritt
+
+     integer :: itf,nall2
+
+     itf=MIN(ite,ide-1)
+
+      DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400.,    &
+                 350.,300.,250.,200.,150./
+      DATA ACRIT/.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/
+!
+       nens=0
+
+!--- LARGE SCALE FORCING
+!
+       DO 100 i=its,itf
+!       if(i.eq.ipr.and.j.eq.jpr)print *,'ierr = ',ierr(i)
+          if(name.eq.'deeps'.and.ierr(i).gt.995)then
+!          print *,i,j,ierr(i),aa0(i)
+           aa0(i)=0.
+           ierr(i)=0
+          endif
+          IF(ierr(i).eq.0)then
+!           kclim=0
+           do k=mkxcrt,1,-1
+             if(p_cup(i,ktop(i)).lt.pcrit(k))then
+               kclim=k
+               go to 9
+             endif
+           enddo
+           if(p_cup(i,ktop(i)).ge.pcrit(1))kclim=1
+ 9         continue
+           kclim=max(kclim,1)
+           k=max(kclim-1,1)
+           aclim1=acrit(kclim)*1.e3
+           aclim2=acrit(k)*1.e3
+           aclim3=acritt(kclim)*1.e3
+           aclim4=acritt(k)*1.e3
+!           print *,'p_cup(ktop(i)),kclim,pcrit(kclim)'
+!           print *,p_cup(i,ktop(i)),kclim,pcrit(kclim)
+!           print *,'aclim1,aclim2,aclim3,aclim4'
+!           print *,aclim1,aclim2,aclim3,aclim4
+!           print *,dtime,name,ierr(i),aa1(i),aa0(i)
+!          print *,dtime,name,ierr(i),aa1(i),aa0(i)
+!
+!--- treatment different for this closure
+!
+             if(name.eq.'deeps')then
+!
+                xff0= (AA1(I)-AA0(I))/DTIME
+                xff_ens3(1)=(AA1(I)-AA0(I))/dtime
+                xff_ens3(2)=.9*xff_ens3(1)
+                xff_ens3(3)=1.1*xff_ens3(1)
+!   
+!--- more original Arakawa-Schubert (climatologic value of aa0)
+!
+!
+!--- omeg is in bar/s, mconv done with omeg in Pa/s
+!     more like Brown (1979), or Frank-Cohen (199?)
+!
+                xff_ens3(4)=-omeg(i,k22(i))/9.81
+                xff_ens3(5)=-omeg(i,kbcon(i))/9.81
+                xff_ens3(6)=-omeg(i,1)/9.81
+                do k=2,kbcon(i)-1
+                  xomg=-omeg(i,k)/9.81
+                  if(xomg.gt.xff_ens3(6))xff_ens3(6)=xomg
+                enddo
+!
+!--- more like Krishnamurti et al.
+!
+                xff_ens3(7)=mconv(i)
+                xff_ens3(8)=mconv(i)
+                xff_ens3(9)=mconv(i)
+!
+!--- more like Fritsch Chappel or Kain Fritsch (plus triggers)
+!
+                xff_ens3(10)=AA1(I)/(60.*20.)
+                xff_ens3(11)=AA1(I)/(60.*30.)
+                xff_ens3(12)=AA1(I)/(60.*40.)
+!  
+!--- more original Arakawa-Schubert (climatologic value of aa0)
+!
+                xff_ens3(13)=max(0.,(AA1(I)-aclim1)/dtime)
+                xff_ens3(14)=max(0.,(AA1(I)-aclim2)/dtime)
+                xff_ens3(15)=max(0.,(AA1(I)-aclim3)/dtime)
+                xff_ens3(16)=max(0.,(AA1(I)-aclim4)/dtime)
+!               if(ierr2(i).gt.0.or.ierr3(i).gt.0)then
+!                 xff_ens3(10)=0.
+!                 xff_ens3(11)=0.
+!                 xff_ens3(12)=0.
+!                 xff_ens3(13)=0.
+!                 xff_ens3(14)=0.
+!                 xff_ens3(15)=0.
+!                 xff_ens3(16)=0.
+!               endif
+
+                do nens=1,maxens
+                   XK(nens)=(XAA0(I,nens)-AA1(I))/MBDT(2)
+                   if(xk(nens).le.0.and.xk(nens).gt.-1.e-6) &
+                           xk(nens)=-1.e-6
+                   if(xk(nens).gt.0.and.xk(nens).lt.1.e-6) &
+                           xk(nens)=1.e-6
+                enddo
+!
+!--- add up all ensembles
+!
+                do 350 ne=1,maxens
+!
+!--- for every xk, we have maxens3 xffs
+!--- iens is from outermost ensemble (most expensive!
+!
+!--- iedt (maxens2 belongs to it)
+!--- is from second, next outermost, not so expensive
+!
+!--- so, for every outermost loop, we have maxens*maxens2*3
+!--- ensembles!!! nall would be 0, if everything is on first
+!--- loop index, then ne would start counting, then iedt, then iens....
+!
+                   iresult=0
+                   iresultd=0
+                   iresulte=0
+                   nall=(iens-1)*maxens3*maxens*maxens2 &
+                        +(iedt-1)*maxens*maxens3 &
+                        +(ne-1)*maxens3
+!
+! over water, enfor!e small cap for some of the closures
+!
+                if(xland(i).lt.0.1)then
+                 if(ierr2(i).gt.0.or.ierr3(i).gt.0)then
+!       - ierr2 - 75 mb cap thickness, ierr3 - 125 cap thickness
+
+! - for larger cap, set Grell closure to zero
+                      xff_ens3(1) =0.
+                      massfln(i,j,nall+1)=0.
+                      xff_ens3(2) =0.
+                      massfln(i,j,nall+2)=0.
+                      xff_ens3(3) =0.
+                      massfln(i,j,nall+3)=0.
+                      closure_n(i)=closure_n(i)-1.
+
+                      xff_ens3(7) =0.
+                      massfln(i,j,nall+7)=0.
+                      xff_ens3(8) =0.
+                      massfln(i,j,nall+8)=0.
+                      xff_ens3(9) =0.
+!                     massfln(i,j,nall+9)=0.
+                      closure_n(i)=closure_n(i)-1.
+                endif
+!
+!   also take out some closures in general
+!
+                      xff_ens3(4) =0.
+                      massfln(i,j,nall+4)=0.
+                      xff_ens3(5) =0.
+                      massfln(i,j,nall+5)=0.
+                      xff_ens3(6) =0.
+                      massfln(i,j,nall+6)=0.
+                      closure_n(i)=closure_n(i)-3.
+
+                      xff_ens3(10)=0.
+                      massfln(i,j,nall+10)=0.
+                      xff_ens3(11)=0.
+                      massfln(i,j,nall+11)=0.
+                      xff_ens3(12)=0.
+                      massfln(i,j,nall+12)=0.
+                      if(ne.eq.1)closure_n(i)=closure_n(i)-3
+                      xff_ens3(13)=0.
+                      massfln(i,j,nall+13)=0.
+                      xff_ens3(14)=0.
+                      massfln(i,j,nall+14)=0.
+                      xff_ens3(15)=0.
+                      massfln(i,j,nall+15)=0.
+                      massfln(i,j,nall+16)=0.
+                      if(ne.eq.1)closure_n(i)=closure_n(i)-4
+
+                endif
+!
+! end water treatment
+!
+!--- check for upwind convection
+!                  iresult=0
+                   massfld=0.
+
+!                  call cup_direction2(i,j,dir,iact_old_gr, &
+!                       massflx,iresult,1,                  &
+!                       massfld,                            &
+!                       ids,ide, jds,jde, kds,kde,          &
+!                       ims,ime, jms,jme, kms,kme,          &
+!                       its,ite, jts,jte, kts,kte          )
+!                  if(i.eq.ipr.and.j.eq.jpr.and.iedt.eq.1.and.ne.eq.1)then
+!                  if(iedt.eq.1.and.ne.eq.1)then
+!                   print *,massfld,ne,iedt,iens
+!                   print *,xk(ne),xff_ens3(1),xff_ens3(2),xff_ens3(3)
+!                  endif
+!                  print *,i,j,massfld,aa0(i),aa1(i)
+                   IF(XK(ne).lt.0.and.xff0.gt.0.)iresultd=1
+                   iresulte=max(iresult,iresultd)
+                   iresulte=1
+                   if(iresulte.eq.1)then
+!
+!--- special treatment for stability closures
+!
+
+                      if(xff0.gt.0.)then
+                         xf_ens(i,j,nall+1)=max(0.,-xff_ens3(1)/xk(ne)) &
+                                        +massfld
+                         xf_ens(i,j,nall+2)=max(0.,-xff_ens3(2)/xk(ne)) &
+                                        +massfld
+                         xf_ens(i,j,nall+3)=max(0.,-xff_ens3(3)/xk(ne)) &
+                                        +massfld
+                         xf_ens(i,j,nall+13)=max(0.,-xff_ens3(13)/xk(ne)) &
+                                        +massfld
+                         xf_ens(i,j,nall+14)=max(0.,-xff_ens3(14)/xk(ne)) &
+                                        +massfld
+                         xf_ens(i,j,nall+15)=max(0.,-xff_ens3(15)/xk(ne)) &
+                                        +massfld
+                         xf_ens(i,j,nall+16)=max(0.,-xff_ens3(16)/xk(ne)) &
+                                        +massfld
+                      else
+                         xf_ens(i,j,nall+1)=massfld
+                         xf_ens(i,j,nall+2)=massfld
+                         xf_ens(i,j,nall+3)=massfld
+                         xf_ens(i,j,nall+13)=massfld
+                         xf_ens(i,j,nall+14)=massfld
+                         xf_ens(i,j,nall+15)=massfld
+                         xf_ens(i,j,nall+16)=massfld
+                      endif
+!
+!--- if iresult.eq.1, following independent of xff0
+!
+                         xf_ens(i,j,nall+4)=max(0.,xff_ens3(4) &
+                            +massfld)
+                         xf_ens(i,j,nall+5)=max(0.,xff_ens3(5) &
+                                        +massfld)
+                         xf_ens(i,j,nall+6)=max(0.,xff_ens3(6) &
+                                        +massfld)
+                         a1=max(1.e-3,pr_ens(i,j,nall+7))
+                         xf_ens(i,j,nall+7)=max(0.,xff_ens3(7) &
+                                     /a1)
+                         a1=max(1.e-3,pr_ens(i,j,nall+8))
+                         xf_ens(i,j,nall+8)=max(0.,xff_ens3(8) &
+                                     /a1)
+                         a1=max(1.e-3,pr_ens(i,j,nall+9))
+                         xf_ens(i,j,nall+9)=max(0.,xff_ens3(9) &
+                                     /a1)
+                         if(XK(ne).lt.0.)then
+                            xf_ens(i,j,nall+10)=max(0., &
+                                        -xff_ens3(10)/xk(ne)) &
+                                        +massfld
+                            xf_ens(i,j,nall+11)=max(0., &
+                                        -xff_ens3(11)/xk(ne)) &
+                                        +massfld
+                            xf_ens(i,j,nall+12)=max(0., &
+                                        -xff_ens3(12)/xk(ne)) &
+                                        +massfld
+                         else
+                            xf_ens(i,j,nall+10)=massfld
+                            xf_ens(i,j,nall+11)=massfld
+                            xf_ens(i,j,nall+12)=massfld
+                         endif
+                      if(icoic.ge.1)then
+                      closure_n(i)=0.
+                      xf_ens(i,j,nall+1)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+2)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+3)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+4)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+5)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+6)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+7)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+8)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+9)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+10)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+11)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+12)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+13)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+14)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+15)=xf_ens(i,j,nall+icoic)
+                      xf_ens(i,j,nall+16)=xf_ens(i,j,nall+icoic)
+                      endif
+!
+! replace 13-16 for now with other stab closures
+! (13 gave problems for mass model)
+!
+!                     xf_ens(i,j,nall+13)=xf_ens(i,j,nall+1)
+                      if(icoic.eq.0)xf_ens(i,j,nall+14)=xf_ens(i,j,nall+13)
+!                     xf_ens(i,j,nall+15)=xf_ens(i,j,nall+11)
+!                     xf_ens(i,j,nall+16)=xf_ens(i,j,nall+11)
+!                     xf_ens(i,j,nall+7)=xf_ens(i,j,nall+4)
+!                     xf_ens(i,j,nall+8)=xf_ens(i,j,nall+5)
+!                     xf_ens(i,j,nall+9)=xf_ens(i,j,nall+6)
+!
+!--- store new for next time step
+!
+                      do nens3=1,maxens3
+                        massfln(i,j,nall+nens3)=edt(i) &
+                                                *xf_ens(i,j,nall+nens3)
+                        massfln(i,j,nall+nens3)=max(0., &
+                                              massfln(i,j,nall+nens3))
+                      enddo
+!
+!
+!--- do some more on the caps!!! ne=1 for 175, ne=2 for 100,....
+!
+!     do not care for caps here for closure groups 1 and 5,
+!     they are fine, do not turn them off here
+!
+!
+                if(ne.eq.2.and.ierr2(i).gt.0)then
+                      xf_ens(i,j,nall+1) =0.
+                      xf_ens(i,j,nall+2) =0.
+                      xf_ens(i,j,nall+3) =0.
+                      xf_ens(i,j,nall+4) =0.
+                      xf_ens(i,j,nall+5) =0.
+                      xf_ens(i,j,nall+6) =0.
+                      xf_ens(i,j,nall+7) =0.
+                      xf_ens(i,j,nall+8) =0.
+                      xf_ens(i,j,nall+9) =0.
+                      xf_ens(i,j,nall+10)=0.
+                      xf_ens(i,j,nall+11)=0.
+                      xf_ens(i,j,nall+12)=0.
+                      xf_ens(i,j,nall+13)=0.
+                      xf_ens(i,j,nall+14)=0.
+                      xf_ens(i,j,nall+15)=0.
+                      xf_ens(i,j,nall+16)=0.
+                      massfln(i,j,nall+1)=0.
+                      massfln(i,j,nall+2)=0.
+                      massfln(i,j,nall+3)=0.
+                      massfln(i,j,nall+4)=0.
+                      massfln(i,j,nall+5)=0.
+                      massfln(i,j,nall+6)=0.
+                      massfln(i,j,nall+7)=0.
+                      massfln(i,j,nall+8)=0.
+                      massfln(i,j,nall+9)=0.
+                      massfln(i,j,nall+10)=0.
+                      massfln(i,j,nall+11)=0.
+                      massfln(i,j,nall+12)=0.
+                      massfln(i,j,nall+13)=0.
+                      massfln(i,j,nall+14)=0.
+                      massfln(i,j,nall+15)=0.
+                      massfln(i,j,nall+16)=0.
+                endif
+                if(ne.eq.3.and.ierr3(i).gt.0)then
+                      xf_ens(i,j,nall+1) =0.
+                      xf_ens(i,j,nall+2) =0.
+                      xf_ens(i,j,nall+3) =0.
+                      xf_ens(i,j,nall+4) =0.
+                      xf_ens(i,j,nall+5) =0.
+                      xf_ens(i,j,nall+6) =0.
+                      xf_ens(i,j,nall+7) =0.
+                      xf_ens(i,j,nall+8) =0.
+                      xf_ens(i,j,nall+9) =0.
+                      xf_ens(i,j,nall+10)=0.
+                      xf_ens(i,j,nall+11)=0.
+                      xf_ens(i,j,nall+12)=0.
+                      xf_ens(i,j,nall+13)=0.
+                      xf_ens(i,j,nall+14)=0.
+                      xf_ens(i,j,nall+15)=0.
+                      xf_ens(i,j,nall+16)=0.
+                      massfln(i,j,nall+1)=0.
+                      massfln(i,j,nall+2)=0.
+                      massfln(i,j,nall+3)=0.
+                      massfln(i,j,nall+4)=0.
+                      massfln(i,j,nall+5)=0.
+                      massfln(i,j,nall+6)=0.
+                      massfln(i,j,nall+7)=0.
+                      massfln(i,j,nall+8)=0.
+                      massfln(i,j,nall+9)=0.
+                      massfln(i,j,nall+10)=0.
+                      massfln(i,j,nall+11)=0.
+                      massfln(i,j,nall+12)=0.
+                      massfln(i,j,nall+13)=0.
+                      massfln(i,j,nall+14)=0.
+                      massfln(i,j,nall+15)=0.
+                      massfln(i,j,nall+16)=0.
+                endif
+
+                   endif
+ 350            continue
+! ne=1, cap=175
+!
+                   nall=(iens-1)*maxens3*maxens*maxens2 &
+                        +(iedt-1)*maxens*maxens3
+! ne=2, cap=100
+!
+                   nall2=(iens-1)*maxens3*maxens*maxens2 &
+                        +(iedt-1)*maxens*maxens3 &
+                        +(2-1)*maxens3
+                      xf_ens(i,j,nall+4) = xf_ens(i,j,nall2+4)
+                      xf_ens(i,j,nall+5) =xf_ens(i,j,nall2+5)
+                      xf_ens(i,j,nall+6) =xf_ens(i,j,nall2+6)
+                      xf_ens(i,j,nall+7) =xf_ens(i,j,nall2+7)
+                      xf_ens(i,j,nall+8) =xf_ens(i,j,nall2+8)
+                      xf_ens(i,j,nall+9) =xf_ens(i,j,nall2+9)
+                      xf_ens(i,j,nall+10)=xf_ens(i,j,nall2+10)
+                      xf_ens(i,j,nall+11)=xf_ens(i,j,nall2+11)
+                      xf_ens(i,j,nall+12)=xf_ens(i,j,nall2+12)
+                go to 100
+             endif
+          elseif(ierr(i).ne.20.and.ierr(i).ne.0)then
+             do n=1,ensdim
+               xf_ens(i,j,n)=0.
+               massfln(i,j,n)=0.
+             enddo
+          endif
+ 100   continue
+
+   END SUBROUTINE cup_forcing_ens
+
+
+   SUBROUTINE cup_kbcon(cap_inc,iloop,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                        )
+
+   IMPLICIT NONE
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        ids,ide, jds,jde, kds,kde,           &
+        ims,ime, jms,jme, kms,kme,           &
+        its,ite, jts,jte, kts,kte
+  ! 
+  ! 
+  ! 
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        he_cup,hes_cup,p_cup
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        cap_max,cap_inc
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        kbmax
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        kbcon,k22,ierr
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        iloop
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i
+     real                                 ::                           &
+        pbcdif,plus
+     integer :: itf
+
+     itf=MIN(ite,ide-1)
+!
+!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
+!
+       DO 27 i=its,itf
+      kbcon(i)=1
+      IF(ierr(I).ne.0)GO TO 27
+      KBCON(I)=K22(I)
+      GO TO 32
+ 31   CONTINUE
+      KBCON(I)=KBCON(I)+1
+      IF(KBCON(I).GT.KBMAX(i)+2)THEN
+         if(iloop.lt.4)ierr(i)=3
+!        if(iloop.lt.4)ierr(i)=997
+        GO TO 27
+      ENDIF
+ 32   CONTINUE
+      IF(HE_cup(I,K22(I)).LT.HES_cup(I,KBCON(I)))GO TO 31
+
+!     cloud base pressure and max moist static energy pressure
+!     i.e., the depth (in mb) of the layer of negative buoyancy
+      if(KBCON(I)-K22(I).eq.1)go to 27
+      PBCDIF=-P_cup(I,KBCON(I))+P_cup(I,K22(I))
+      plus=max(25.,cap_max(i)-float(iloop-1)*cap_inc(i))
+      if(iloop.eq.4)plus=cap_max(i)
+      IF(PBCDIF.GT.plus)THEN
+        K22(I)=K22(I)+1
+        KBCON(I)=K22(I)
+        GO TO 32
+      ENDIF
+ 27   CONTINUE
+
+   END SUBROUTINE cup_kbcon
+
+
+   SUBROUTINE cup_kbcon_cin(iloop,k22,kbcon,he_cup,hes_cup,  &
+              z,tmean,qes,ierr,kbmax,p_cup,cap_max,xl,cp,    &
+              ids,ide, jds,jde, kds,kde,                     &
+              ims,ime, jms,jme, kms,kme,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        ids,ide, jds,jde, kds,kde,           &
+        ims,ime, jms,jme, kms,kme,           &
+        its,ite, jts,jte, kts,kte
+  ! 
+  ! 
+  ! 
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        he_cup,hes_cup,p_cup,z,tmean,qes
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        cap_max
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        xl,cp
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        kbmax
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        kbcon,k22,ierr
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        iloop
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k
+     real                                 ::                           &
+        cin,cin_max,dh,tprim,gamma
+!
+     integer :: itf
+
+     itf=MIN(ite,ide-1)
+!
+!
+    
+!
+!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
+!
+       DO 27 i=its,itf
+      cin_max=-cap_max(i)
+      kbcon(i)=1
+      cin = 0.
+      IF(ierr(I).ne.0)GO TO 27
+      KBCON(I)=K22(I)
+      GO TO 32
+ 31   CONTINUE
+      KBCON(I)=KBCON(I)+1
+      IF(KBCON(I).GT.KBMAX(i)+2)THEN
+         if(iloop.eq.1)ierr(i)=3
+!        if(iloop.eq.2)ierr(i)=997
+        GO TO 27
+      ENDIF
+ 32   CONTINUE
+      dh      = HE_cup(I,K22(I)) - HES_cup(I,KBCON(I))
+      if (dh.lt. 0.) then
+        GAMMA=(xl/cp)*(xl/(461.525*(Tmean(I,K22(i))**2)))*QES(I,K22(i))
+        tprim = dh/(cp*(1.+gamma))
+
+        cin = cin + 9.8066 * tprim &
+              *(z(i,k22(i))-z(i,k22(i)-1)) / tmean(i,k22(i))
+        go to 31
+      end if
+
+
+!     If negative energy in negatively buoyant layer
+!       exceeds convective inhibition (CIN) threshold,
+!       then set K22 level one level up and see if that
+!       will work.
+
+      IF(cin.lT.cin_max)THEN
+!       print *,i,cin,cin_max,k22(i),kbcon(i)
+        K22(I)=K22(I)+1
+        KBCON(I)=K22(I)
+        GO TO 32
+      ENDIF
+ 27   CONTINUE
+
+   END SUBROUTINE cup_kbcon_cin
+
+
+   SUBROUTINE cup_ktop(ilo,dby,kbcon,ktop,ierr,              &
+              ids,ide, jds,jde, kds,kde,                     &
+              ims,ime, jms,jme, kms,kme,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        ids,ide, jds,jde, kds,kde,           &
+        ims,ime, jms,jme, kms,kme,           &
+        its,ite, jts,jte, kts,kte
+  ! dby = buoancy term
+  ! ktop = cloud top (output)
+  ! ilo  = flag
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout)                   ::                           &
+        dby
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        kbcon
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        ilo
+     integer, dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        ktop
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k
+!
+     integer :: itf, ktf
+
+     itf=MIN(ite,ide-1)
+     ktf=MIN(kte,kde-1)
+!
+!
+        DO 42 i=its,itf
+        ktop(i)=1
+         IF(ierr(I).EQ.0)then
+          DO 40 K=KBCON(I)+1,ktf-1
+            IF(DBY(I,K).LE.0.)THEN
+                KTOP(I)=K-1
+                GO TO 41
+             ENDIF
+  40      CONTINUE
+          if(ilo.eq.1)ierr(i)=5
+!         if(ilo.eq.2)ierr(i)=998
+          GO TO 42
+  41     CONTINUE
+         do k=ktop(i)+1,ktf
+           dby(i,k)=0.
+         enddo
+         endif
+  42     CONTINUE
+
+   END SUBROUTINE cup_ktop
+
+
+   SUBROUTINE cup_MAXIMI(ARRAY,KS,KE,MAXX,ierr,              &
+              ids,ide, jds,jde, kds,kde,                     &
+              ims,ime, jms,jme, kms,kme,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+         ids,ide, jds,jde, kds,kde,                                    &
+         ims,ime, jms,jme, kms,kme,                                    &
+         its,ite, jts,jte, kts,kte
+  ! array input array
+  ! x output array with return values
+  ! kt output array of levels
+  ! ks,kend  check-range
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+         array
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+         ierr,ke
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+         ks
+     integer, dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+         maxx
+     real,    dimension (its:ite)         ::                           &
+         x
+     real                                 ::                           &
+         xar
+     integer                              ::                           &
+         i,k
+     integer :: itf
+
+     itf=MIN(ite,ide-1)
+
+       DO 200 i=its,itf
+       MAXX(I)=KS
+       if(ierr(i).eq.0)then
+      X(I)=ARRAY(I,KS)
+!
+       DO 100 K=KS,KE(i)
+         XAR=ARRAY(I,K)
+         IF(XAR.GE.X(I)) THEN
+            X(I)=XAR
+            MAXX(I)=K
+         ENDIF
+ 100  CONTINUE
+      endif
+ 200  CONTINUE
+
+   END SUBROUTINE cup_MAXIMI
+
+
+   SUBROUTINE cup_minimi(ARRAY,KS,KEND,KT,ierr,              &
+              ids,ide, jds,jde, kds,kde,                     &
+              ims,ime, jms,jme, kms,kme,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+         ids,ide, jds,jde, kds,kde,                                    &
+         ims,ime, jms,jme, kms,kme,                                    &
+         its,ite, jts,jte, kts,kte
+  ! array input array
+  ! x output array with return values
+  ! kt output array of levels
+  ! ks,kend  check-range
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+         array
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+         ierr,ks,kend
+     integer, dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+         kt
+     real,    dimension (its:ite)         ::                           &
+         x
+     integer                              ::                           &
+         i,k,kstop
+
+     integer :: itf
+
+     itf=MIN(ite,ide-1)
+
+       DO 200 i=its,itf
+      KT(I)=KS(I)
+      if(ierr(i).eq.0)then
+      X(I)=ARRAY(I,KS(I))
+       KSTOP=MAX(KS(I)+1,KEND(I))
+!
+       DO 100 K=KS(I)+1,KSTOP
+         IF(ARRAY(I,K).LT.X(I)) THEN
+              X(I)=ARRAY(I,K)
+              KT(I)=K
+         ENDIF
+ 100  CONTINUE
+      endif
+ 200  CONTINUE
+
+   END SUBROUTINE cup_MINIMI
+
+
+   SUBROUTINE cup_output_ens(xf_ens,ierr,dellat,dellaq,dellaqc,  &
+              outtem,outq,outqc,pre,pw,xmb,ktop,                 &
+              j,name,nx,nx2,iens,ierr2,ierr3,pr_ens,             &
+              maxens3,ensdim,massfln,                            &
+              APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                 &
+              APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1,    &
+              outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1,  &
+              CFU1_ens,CFD1_ens,DFU1_ens,EFU1_ens,DFD1_ens,EFD1_ens,  &
+              l_flux,                                           &
+              ids,ide, jds,jde, kds,kde, &
+              ims,ime, jms,jme, kms,kme, &
+              its,ite, jts,jte, kts,kte)
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        ids,ide, jds,jde, kds,kde,           &
+        ims,ime, jms,jme, kms,kme,           &
+        its,ite, jts,jte, kts,kte
+     integer, intent (in   )              ::                           &
+        j,ensdim,nx,nx2,iens,maxens3
+  ! xf_ens = ensemble mass fluxes
+  ! pr_ens = precipitation ensembles
+  ! dellat = change of temperature per unit mass flux of cloud ensemble
+  ! dellaq = change of q per unit mass flux of cloud ensemble
+  ! dellaqc = change of qc per unit mass flux of cloud ensemble
+  ! outtem = output temp tendency (per s)
+  ! outq   = output q tendency (per s)
+  ! outqc  = output qc tendency (per s)
+  ! pre    = output precip
+  ! xmb    = total base mass flux
+  ! xfac1  = correction factor
+  ! pw = pw -epsilon*pd (ensemble dependent)
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (ims:ime,jms:jme,1:ensdim)                     &
+        ,intent (inout)                   ::                           &
+       xf_ens,pr_ens,massfln
+     real,    dimension (ims:ime,jms:jme)                              &
+        ,intent (inout)                   ::                           &
+               APR_GR,APR_W,APR_MC,APR_ST,APR_AS,APR_CAPMA,            &
+               APR_CAPME,APR_CAPMI 
+
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        outtem,outq,outqc
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        pre,xmb
+     real,    dimension (its:ite)                                      &
+        ,intent (inout  )                   ::                           &
+        closure_n,xland1
+     real,    dimension (its:ite,kts:kte,1:nx)                         &
+        ,intent (in   )                   ::                           &
+       dellat,dellaqc,dellaq,pw
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        ktop
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr,ierr2,ierr3
+     real,    dimension (its:ite,kts:kte,1:ensdim)                     &
+        ,intent (in   )                   ::                           &
+       CFU1_ens,CFD1_ens,DFU1_ens,EFU1_ens,DFD1_ens,EFD1_ens
+     real,    dimension (its:ite,kts:kte)                     &
+        ,intent (out)                   ::                           &
+           outCFU1,outCFD1,outDFU1,outEFU1,outDFD1,outEFD1
+     logical, intent(in) :: l_flux
+
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k,n,ncount
+     real                                 ::                           &
+        outtes,ddtes,dtt,dtq,dtqc,dtpw,tuning,prerate,clos_wei
+     real,    dimension (its:ite)         ::                           &
+       xfac1
+     real,    dimension (its:ite)::                           &
+       xmb_ske,xmb_ave,xmb_std,xmb_cur,xmbweight
+     real,    dimension (its:ite)::                           &
+       pr_ske,pr_ave,pr_std,pr_cur
+     real,    dimension (its:ite,jts:jte)::                           &
+               pr_gr,pr_w,pr_mc,pr_st,pr_as,pr_capma,     &
+               pr_capme,pr_capmi
+     integer :: iedt, kk
+
+!
+      character *(*), intent (in)        ::                           &
+       name
+!
+     integer :: itf, ktf
+
+     itf=MIN(ite,ide-1)
+     ktf=MIN(kte,kde-1)
+     tuning=0.
+!
+!
+      DO k=kts,ktf
+      do i=its,itf
+        outtem(i,k)=0.
+        outq(i,k)=0.
+        outqc(i,k)=0.
+      enddo
+      enddo
+      do i=its,itf
+        pre(i)=0.
+        xmb(i)=0.
+         xfac1(i)=1.
+        xmbweight(i)=1.
+      enddo
+      do i=its,itf
+        IF(ierr(i).eq.0)then
+        do n=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3
+           if(pr_ens(i,j,n).le.0.)then
+             xf_ens(i,j,n)=0.
+           endif
+        enddo
+        endif
+      enddo
+!
+!--- calculate ensemble average mass fluxes
+!
+       call massflx_stats(xf_ens,ensdim,nx2,nx,maxens3,      &
+            xmb_ave,xmb_std,xmb_cur,xmb_ske,j,ierr,1,    &
+            APR_GR,APR_W,APR_MC,APR_ST,APR_AS,           &
+            APR_CAPMA,APR_CAPME,APR_CAPMI,               &
+            pr_gr,pr_w,pr_mc,pr_st,pr_as,                &
+            pr_capma,pr_capme,pr_capmi,                  &
+            ids,ide, jds,jde, kds,kde,                   &
+            ims,ime, jms,jme, kms,kme,                   &
+            its,ite, jts,jte, kts,kte                   )
+       call massflx_stats(pr_ens,ensdim,nx2,nx,maxens3,  &
+            pr_ave,pr_std,pr_cur,pr_ske,j,ierr,2,        &
+            APR_GR,APR_W,APR_MC,APR_ST,APR_AS,           &
+            APR_CAPMA,APR_CAPME,APR_CAPMI,               &
+            pr_gr,pr_w,pr_mc,pr_st,pr_as,                &
+            pr_capma,pr_capme,pr_capmi,                  &
+            ids,ide, jds,jde, kds,kde,                   &
+            ims,ime, jms,jme, kms,kme,                   &
+            its,ite, jts,jte, kts,kte                   )
+!
+!-- now do feedback
+!
+      ddtes=200.
+!     if(name.eq.'shal')ddtes=200.
+      do i=its,itf
+        if(ierr(i).eq.0)then
+         if(xmb_ave(i).le.0.)then
+              ierr(i)=13
+              xmb_ave(i)=0.
+         endif
+!        xmb(i)=max(0.,xmb_ave(i))
+         xmb(i)=max(.1*xmb_ave(i),xmb_ave(i)-tuning*xmb_std(i))
+! --- Now use proper count of how many closures were actually
+!       used in cup_forcing_ens (including screening of some
+!       closures over water) to properly normalize xmb
+           clos_wei=16./max(1.,closure_n(i))
+           if (xland1(i).lt.0.5)xmb(i)=xmb(i)*clos_wei
+           if(xmb(i).eq.0.)then
+              ierr(i)=19
+           endif
+           if(xmb(i).gt.100.)then
+              ierr(i)=19
+           endif
+           xfac1(i)=xmb(i)
+
+        endif
+        xfac1(i)=xmb_ave(i)
+      ENDDO
+      DO k=kts,ktf
+      do i=its,itf
+            dtt=0.
+            dtq=0.
+            dtqc=0.
+            dtpw=0.
+        IF(ierr(i).eq.0.and.k.le.ktop(i))then
+           do n=1,nx
+              dtt=dtt+dellat(i,k,n)
+              dtq=dtq+dellaq(i,k,n)
+              dtqc=dtqc+dellaqc(i,k,n)
+              dtpw=dtpw+pw(i,k,n)
+           enddo
+           outtes=dtt*XMB(I)*86400./float(nx)
+           IF((OUTTES.GT.2.*ddtes.and.k.gt.2))THEN
+             XMB(I)= 2.*ddtes/outtes * xmb(i)
+             outtes=1.*ddtes
+           endif
+           if (outtes .lt. -ddtes) then
+             XMB(I)= -ddtes/outtes * xmb(i)
+             outtes=-ddtes
+           endif
+           if (outtes .gt. .5*ddtes.and.k.le.2) then
+             XMB(I)= ddtes/outtes * xmb(i)
+             outtes=.5*ddtes
+           endif
+           OUTTEM(I,K)=XMB(I)*dtt/float(nx)
+           OUTQ(I,K)=XMB(I)*dtq/float(nx)
+           OUTQC(I,K)=XMB(I)*dtqc/float(nx)
+           PRE(I)=PRE(I)+XMB(I)*dtpw/float(nx)
+        endif
+      enddo
+      enddo
+      do i=its,itf
+        if(ierr(i).eq.0)then
+           prerate=pre(i)*3600.
+           if(prerate.lt.0.1)then
+              if(ierr2(i).gt.0.or.ierr3(i).gt.0)then
+                 pre(i)=0.
+                 ierr(i)=221
+                 do k=kts,ktf
+                    outtem(i,k)=0.
+                    outq(i,k)=0.
+                    outqc(i,k)=0.
+                 enddo
+                 do k=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3
+                   massfln(i,j,k)=0.
+                   xf_ens(i,j,k)=0.
+                 enddo
+               endif
+            endif
+
+        endif
+      ENDDO
+
+      do i=its,itf
+        if(ierr(i).eq.0)then
+        xfac1(i)=xmb(i)/xfac1(i)
+        do k=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3
+          massfln(i,j,k)=massfln(i,j,k)*xfac1(i)
+          xf_ens(i,j,k)=xf_ens(i,j,k)*xfac1(i)
+        enddo
+        endif
+      ENDDO
+      if (l_flux) then
+         if (iens .eq. 1) then  ! Only do deep convection mass fluxes
+            do k=kts,ktf
+               do i=its,itf
+                  outcfu1(i,k)=0.
+                  outcfd1(i,k)=0.
+                  outdfu1(i,k)=0.
+                  outefu1(i,k)=0.
+                  outdfd1(i,k)=0.
+                  outefd1(i,k)=0.
+                  if (ierr(i) .eq. 0) then
+                     do iedt=1,nx
+                        do kk=1,nx2*maxens3
+                           n=(iens-1)*nx*nx2*maxens3 + &
+                                (iedt-1)*nx2*maxens3 + kk
+                           outcfu1(i,k)=outcfu1(i,k)+cfu1_ens(i,k,iedt)*xf_ens(i,j,n)
+                           outcfd1(i,k)=outcfd1(i,k)+cfd1_ens(i,k,iedt)*xf_ens(i,j,n)
+                           outdfu1(i,k)=outdfu1(i,k)+dfu1_ens(i,k,iedt)*xf_ens(i,j,n)
+                           outefu1(i,k)=outefu1(i,k)+efu1_ens(i,k,iedt)*xf_ens(i,j,n)
+                           outdfd1(i,k)=outdfd1(i,k)+dfd1_ens(i,k,iedt)*xf_ens(i,j,n)
+                           outefd1(i,k)=outefd1(i,k)+efd1_ens(i,k,iedt)*xf_ens(i,j,n)
+                        end do
+                     end do
+                     outcfu1(i,k)=outcfu1(i,k)/ensdim
+                     outcfd1(i,k)=outcfd1(i,k)/ensdim
+                     outdfu1(i,k)=outdfu1(i,k)/ensdim
+                     outefu1(i,k)=outefu1(i,k)/ensdim
+                     outdfd1(i,k)=outdfd1(i,k)/ensdim
+                     outefd1(i,k)=outefd1(i,k)/ensdim
+                  end if !ierr
+               end do !i 
+            end do !k
+         end if !iens .eq. 1
+      end if !l_flux
+
+   END SUBROUTINE cup_output_ens
+
+
+   SUBROUTINE cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup,       &
+              kbcon,ktop,ierr,                               &
+              ids,ide, jds,jde, kds,kde,                     &
+              ims,ime, jms,jme, kms,kme,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        ids,ide, jds,jde, kds,kde,                                     &
+        ims,ime, jms,jme, kms,kme,                                     &
+        its,ite, jts,jte, kts,kte
+  ! aa0 cloud work function
+  ! gamma_cup = gamma on model cloud levels
+  ! t_cup = temperature (Kelvin) on model cloud levels
+  ! dby = buoancy term
+  ! zu= normalized updraft mass flux
+  ! z = heights of model levels 
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        z,zu,gamma_cup,t_cup,dby
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        kbcon,ktop
+!
+! input and output
+!
+
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        aa0
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k
+     real                                 ::                           &
+        dz,da
+!
+     integer :: itf, ktf
+
+     itf = MIN(ite,ide-1)
+     ktf = MIN(kte,kde-1)
+
+        do i=its,itf
+         aa0(i)=0.
+        enddo
+        DO 100 k=kts+1,ktf
+        DO 100 i=its,itf
+         IF(ierr(i).ne.0)GO TO 100
+         IF(K.LE.KBCON(I))GO TO 100
+         IF(K.Gt.KTOP(I))GO TO 100
+         DZ=Z(I,K)-Z(I,K-1)
+         da=zu(i,k)*DZ*(9.81/(1004.*( &
+                (T_cup(I,K)))))*DBY(I,K-1)/ &
+             (1.+GAMMA_CUP(I,K))
+         IF(K.eq.KTOP(I).and.da.le.0.)go to 100
+         AA0(I)=AA0(I)+da
+         if(aa0(i).lt.0.)aa0(i)=0.
+100     continue
+
+   END SUBROUTINE cup_up_aa0
+
+
+   SUBROUTINE cup_up_he(k22,hkb,z_cup,cd,entr,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                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+                                  ids,ide, jds,jde, kds,kde,           &
+                                  ims,ime, jms,jme, kms,kme,           &
+                                  its,ite, jts,jte, kts,kte
+  ! hc = cloud moist static energy
+  ! hkb = moist static energy at originating level
+  ! he = moist static energy on model levels
+  ! he_cup = moist static energy on model cloud levels
+  ! hes_cup = saturation moist static energy on model cloud levels
+  ! dby = buoancy term
+  ! cd= detrainment function 
+  ! z_cup = heights of model cloud levels 
+  ! entr = entrainment rate
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        he,he_cup,hes_cup,z_cup,cd
+  ! entr= entrainment rate 
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        entr
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        kbcon,k22
+!
+! input and output
+!
+
+   ! ierr error value, maybe modified in this routine
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        hc,dby
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        hkb
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k
+     real                                 ::                           &
+        dz
+!
+     integer :: itf, ktf
+
+     itf = MIN(ite,ide-1)
+     ktf = MIN(kte,kde-1)
+!
+!--- moist static energy inside cloud
+!
+      do i=its,itf
+      if(ierr(i).eq.0.)then
+      hkb(i)=he_cup(i,k22(i))
+      do k=1,k22(i)
+        hc(i,k)=he_cup(i,k)
+        DBY(I,K)=0.
+      enddo
+      do k=k22(i),kbcon(i)-1
+        hc(i,k)=hkb(i)
+        DBY(I,K)=0.
+      enddo
+        k=kbcon(i)
+        hc(i,k)=hkb(i)
+        DBY(I,Kbcon(i))=Hkb(I)-HES_cup(I,K)
+      endif
+      enddo
+      do k=kts+1,ktf
+      do i=its,itf
+        if(k.gt.kbcon(i).and.ierr(i).eq.0.)then
+           DZ=Z_cup(i,K)-Z_cup(i,K-1)
+           HC(i,K)=(HC(i,K-1)*(1.-.5*CD(i,K)*DZ)+entr* &
+                DZ*HE(i,K-1))/(1.+entr*DZ-.5*cd(i,k)*dz)
+           DBY(I,K)=HC(I,K)-HES_cup(I,K)
+        endif
+      enddo
+
+      enddo
+
+   END SUBROUTINE cup_up_he
+
+
+   SUBROUTINE 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,qe_cup,xl,          &
+              ids,ide, jds,jde, kds,kde,                     &
+              ims,ime, jms,jme, kms,kme,                     &
+              its,ite, jts,jte, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+                                  ids,ide, jds,jde, kds,kde,           &
+                                  ims,ime, jms,jme, kms,kme,           &
+                                  its,ite, jts,jte, kts,kte
+  ! cd= detrainment function 
+  ! q = environmental q on model levels
+  ! qe_cup = environmental q on model cloud levels
+  ! qes_cup = saturation q on model cloud levels
+  ! dby = buoancy term
+  ! cd= detrainment function 
+  ! zu = normalized updraft mass flux
+  ! gamma_cup = gamma on model cloud levels
+  ! mentr_rate = entrainment rate
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        q,zu,gamma_cup,qe_cup,dby,qes_cup,z_cup,cd
+  ! entr= entrainment rate 
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        mentr_rate,xl
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        kbcon,ktop,k22
+!
+! input and output
+!
+
+   ! ierr error value, maybe modified in this routine
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+   ! qc = cloud q (including liquid water) after entrainment
+   ! qrch = saturation q in cloud
+   ! qrc = liquid water content in cloud after rainout
+   ! pw = condensate that will fall out at that level
+   ! pwav = totan normalized integrated condensate (I1)
+   ! c0 = conversion rate (cloud to rain)
+
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+        qc,qrc,pw,clw_all
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        pwav
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        iall,i,k
+     real                                 ::                           &
+        dh,qrch,c0,dz,radius
+!
+     integer :: itf, ktf
+
+     itf = MIN(ite,ide-1)
+     ktf = MIN(kte,kde-1)
+
+        iall=0
+        c0=.002
+!
+!--- 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 i=its,itf
+          pwav(i)=0.
+        enddo
+        do k=kts,ktf
+        do i=its,itf
+          pw(i,k)=0.
+          if(ierr(i).eq.0)qc(i,k)=qes_cup(i,k)
+          clw_all(i,k)=0.
+          qrc(i,k)=0.
+        enddo
+        enddo
+      do i=its,itf
+      if(ierr(i).eq.0.)then
+      do k=k22(i),kbcon(i)-1
+        qc(i,k)=qe_cup(i,k22(i))
+      enddo
+      endif
+      enddo
+
+        DO 100 k=kts+1,ktf
+        DO 100 i=its,itf
+         IF(ierr(i).ne.0)GO TO 100
+         IF(K.Lt.KBCON(I))GO TO 100
+         IF(K.Gt.KTOP(I))GO TO 100
+         DZ=Z_cup(i,K)-Z_cup(i,K-1)
+!
+!------    1. steady state plume equation, for what could
+!------       be in cloud without condensation
+!
+!
+        QC(i,K)=(QC(i,K-1)*(1.-.5*CD(i,K)*DZ)+mentr_rate* &
+                DZ*Q(i,K-1))/(1.+mentr_rate*DZ-.5*cd(i,k)*dz)
+!
+!--- saturation  in cloud, this is what is allowed to be in it
+!
+         QRCH=QES_cup(I,K)+(1./XL)*(GAMMA_cup(i,k) &
+              /(1.+GAMMA_cup(i,k)))*DBY(I,K)
+!
+!------- LIQUID WATER CONTENT IN cloud after rainout
+!
+        clw_all(i,k)=QC(I,K)-QRCH
+        QRC(I,K)=(QC(I,K)-QRCH)/(1.+C0*DZ)
+        if(qrc(i,k).lt.0.)then
+          qrc(i,k)=0.
+        endif
+!
+!-------   3.Condensation
+!
+         PW(i,k)=c0*dz*QRC(I,K)*zu(i,k)
+        if(iall.eq.1)then
+          qrc(i,k)=0.
+          pw(i,k)=(QC(I,K)-QRCH)*zu(i,k)
+          if(pw(i,k).lt.0.)pw(i,k)=0.
+        endif
+!
+!----- set next level
+!
+         QC(I,K)=QRC(I,K)+qrch
+!
+!--- integrated normalized ondensate
+!
+         PWAV(I)=PWAV(I)+PW(I,K)
+ 100     CONTINUE
+
+   END SUBROUTINE cup_up_moisture
+
+
+   SUBROUTINE cup_up_nms(zu,z_cup,entr,cd,kbcon,ktop,ierr,k22,  &
+              ids,ide, jds,jde, kds,kde,                        &
+              ims,ime, jms,jme, kms,kme,                        &
+              its,ite, jts,jte, kts,kte                        )
+
+   IMPLICIT NONE
+
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+         ids,ide, jds,jde, kds,kde,                                    &
+         ims,ime, jms,jme, kms,kme,                                    &
+         its,ite, jts,jte, kts,kte
+  ! cd= detrainment function 
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+         z_cup,cd
+  ! entr= entrainment rate 
+     real                                                              &
+        ,intent (in   )                   ::                           &
+         entr
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+         kbcon,ktop,k22
+!
+! input and output
+!
+
+   ! ierr error value, maybe modified in this routine
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+         ierr
+   ! zu is the normalized mass flux
+
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (out  )                   ::                           &
+         zu
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+         i,k
+     real                                 ::                           &
+         dz
+     integer :: itf, ktf
+
+     itf = MIN(ite,ide-1)
+     ktf = MIN(kte,kde-1)
+!
+!   initialize for this go around
+!
+       do k=kts,ktf
+       do i=its,itf
+         zu(i,k)=0.
+       enddo
+       enddo
+!
+! do normalized mass budget
+!
+       do i=its,itf
+          IF(ierr(I).eq.0)then
+             do k=k22(i),kbcon(i)
+               zu(i,k)=1.
+             enddo
+             DO K=KBcon(i)+1,KTOP(i)
+               DZ=Z_cup(i,K)-Z_cup(i,K-1)
+               ZU(i,K)=ZU(i,K-1)*(1.+(entr-cd(i,k))*DZ)
+             enddo
+          endif
+       enddo
+
+   END SUBROUTINE cup_up_nms
+
+!====================================================================
+   SUBROUTINE gdinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,           &
+                        MASS_FLUX,cp,restart,                       &
+                        P_QC,P_QI,P_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               )
+!--------------------------------------------------------------------   
+   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_FIRST_SCALAR, P_QI, P_QC
+   REAL,     INTENT(IN)           ::  cp
+
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
+                                                          RTHCUTEN, &
+                                                          RQVCUTEN, &
+                                                          RQCCUTEN, &
+                                                          RQICUTEN   
+
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
+                                                          RTHFTEN,  &
+                                                          RQVFTEN
+
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) ::        &
+                                APR_GR,APR_W,APR_MC,APR_ST,APR_AS,  &
+                                APR_CAPMA,APR_CAPME,APR_CAPMI,      &
+                                MASS_FLUX
+
+   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
+
+     DO j=jts,jtf
+     DO k=kts,ktf
+     DO i=its,itf
+        RTHFTEN(i,k,j)=0.
+        RQVFTEN(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
+
+     DO j=jts,jtf
+     DO i=its,itf
+        mass_flux(i,j)=0.
+     ENDDO
+     ENDDO
+
+   ENDIF
+     DO j=jts,jtf
+     DO i=its,itf
+        APR_GR(i,j)=0.
+        APR_ST(i,j)=0.
+        APR_W(i,j)=0.
+        APR_MC(i,j)=0.
+        APR_AS(i,j)=0.
+        APR_CAPMA(i,j)=0.
+        APR_CAPME(i,j)=0.
+        APR_CAPMI(i,j)=0.
+     ENDDO
+     ENDDO
+
+   END SUBROUTINE gdinit
+
+
+   SUBROUTINE massflx_stats(xf_ens,ensdim,maxens,maxens2,maxens3, &
+              xt_ave,xt_std,xt_cur,xt_ske,j,ierr,itest,           &
+              APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                  &
+              APR_CAPMA,APR_CAPME,APR_CAPMI,                      &
+              pr_gr,pr_w,pr_mc,pr_st,pr_as,                       &
+              pr_capma,pr_capme,pr_capmi,                         &
+              ids,ide, jds,jde, kds,kde,  &
+              ims,ime, jms,jme, kms,kme,  &
+              its,ite, jts,jte, kts,kte)
+
+   IMPLICIT NONE
+
+   integer, intent (in   )              ::                                    &
+                     j,ensdim,maxens3,maxens,maxens2,itest
+   INTEGER,      INTENT(IN   ) ::                                             &
+                                  ids,ide, jds,jde, kds,kde,                  &
+                                  ims,ime, jms,jme, kms,kme,                  &
+                                  its,ite, jts,jte, kts,kte
+
+
+     real, dimension (its:ite)                                                &
+         , intent(inout) ::                                                   &
+           xt_ave,xt_cur,xt_std,xt_ske
+     integer, dimension (its:ite), intent (in) ::                             &
+           ierr
+     real, dimension (ims:ime,jms:jme,1:ensdim)                               &
+         , intent(in   ) ::                                                   &
+           xf_ens
+     real, dimension (ims:ime,jms:jme)                                        &
+         , intent(inout) ::                                                   &
+           APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                                 &
+           APR_CAPMA,APR_CAPME,APR_CAPMI
+     real, dimension (its:ite,jts:jte)                                        &
+         , intent(inout) ::                                                   &
+           pr_gr,pr_w,pr_mc,pr_st,pr_as,                                      &
+           pr_capma,pr_capme,pr_capmi
+
+!
+! local stuff
+!
+     real, dimension (its:ite , 1:maxens3 )       ::                          &
+           x_ave,x_cur,x_std,x_ske
+     real, dimension (its:ite , 1:maxens  )       ::                          &
+           x_ave_cap
+
+
+      integer, dimension (1:maxens3) :: nc1
+      integer :: i,k
+      integer :: num,kk,num2,iedt
+      real :: a3,a4
+
+      num=ensdim/maxens3
+      num2=ensdim/maxens
+      if(itest.eq.1)then
+      do i=its,ite
+       pr_gr(i,j) =  0.
+       pr_w(i,j) =  0.
+       pr_mc(i,j) = 0.
+       pr_st(i,j) = 0.
+       pr_as(i,j) = 0.
+       pr_capma(i,j) =  0.
+       pr_capme(i,j) = 0.
+       pr_capmi(i,j) = 0.
+      enddo
+      endif
+
+      do k=1,maxens
+      do i=its,ite
+        x_ave_cap(i,k)=0.
+      enddo
+      enddo
+      do k=1,maxens3
+      do i=its,ite
+        x_ave(i,k)=0.
+        x_std(i,k)=0.
+        x_ske(i,k)=0.
+        x_cur(i,k)=0.
+      enddo
+      enddo
+      do i=its,ite
+        xt_ave(i)=0.
+        xt_std(i)=0.
+        xt_ske(i)=0.
+        xt_cur(i)=0.
+      enddo
+      do kk=1,num
+      do k=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0)then
+        x_ave(i,k)=x_ave(i,k)+xf_ens(i,j,maxens3*(kk-1)+k)
+        endif
+      enddo
+      enddo
+      enddo
+      do iedt=1,maxens2
+      do k=1,maxens
+      do kk=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0)then
+        x_ave_cap(i,k)=x_ave_cap(i,k)                               &
+            +xf_ens(i,j,maxens3*(k-1)+(iedt-1)*maxens*maxens3+kk)
+        endif
+      enddo
+      enddo
+      enddo
+      enddo
+      do k=1,maxens
+      do i=its,ite
+        if(ierr(i).eq.0)then
+        x_ave_cap(i,k)=x_ave_cap(i,k)/float(num2)
+        endif
+      enddo
+      enddo
+
+      do k=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0)then
+        x_ave(i,k)=x_ave(i,k)/float(num)
+        endif
+      enddo
+      enddo
+      do k=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0)then
+        xt_ave(i)=xt_ave(i)+x_ave(i,k)
+        endif
+      enddo
+      enddo
+      do i=its,ite
+        if(ierr(i).eq.0)then
+        xt_ave(i)=xt_ave(i)/float(maxens3)
+        endif
+      enddo
+!
+!--- now do std, skewness,curtosis
+!
+      do kk=1,num
+      do k=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0.and.x_ave(i,k).gt.0.)then
+!       print *,i,j,k,kk,x_std(i,k),xf_ens(i,j,maxens3*(kk-1)+k),x_ave(i,k)
+        x_std(i,k)=x_std(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**2
+        x_ske(i,k)=x_ske(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**3
+        x_cur(i,k)=x_cur(i,k)+(xf_ens(i,j,maxens3*(kk-1)+k)-x_ave(i,k))**4
+        endif
+      enddo
+      enddo
+      enddo
+      do k=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0.and.xt_ave(i).gt.0.)then
+        xt_std(i)=xt_std(i)+(x_ave(i,k)-xt_ave(i))**2
+        xt_ske(i)=xt_ske(i)+(x_ave(i,k)-xt_ave(i))**3
+        xt_cur(i)=xt_cur(i)+(x_ave(i,k)-xt_ave(i))**4
+        endif
+      enddo
+      enddo
+      do k=1,maxens3
+      do i=its,ite
+        if(ierr(i).eq.0.and.x_std(i,k).gt.0.)then
+           x_std(i,k)=x_std(i,k)/float(num)
+           a3=max(1.e-6,x_std(i,k))
+           x_std(i,k)=sqrt(a3)
+           a3=max(1.e-6,x_std(i,k)**3)
+           a4=max(1.e-6,x_std(i,k)**4)
+           x_ske(i,k)=x_ske(i,k)/float(num)/a3
+           x_cur(i,k)=x_cur(i,k)/float(num)/a4
+        endif
+!       print*,'                               '
+!       print*,'Some statistics at gridpoint i,j, ierr',i,j,ierr(i)
+!       print*,'statistics for closure number ',k
+!       print*,'Average= ',x_ave(i,k),'  Std= ',x_std(i,k)
+!       print*,'Skewness= ',x_ske(i,k),' Curtosis= ',x_cur(i,k)
+!       print*,'                               '
+
+      enddo
+      enddo
+      do i=its,ite
+        if(ierr(i).eq.0.and.xt_std(i).gt.0.)then
+           xt_std(i)=xt_std(i)/float(maxens3)
+           a3=max(1.e-6,xt_std(i))
+           xt_std(i)=sqrt(a3)
+           a3=max(1.e-6,xt_std(i)**3)
+           a4=max(1.e-6,xt_std(i)**4)
+           xt_ske(i)=xt_ske(i)/float(maxens3)/a3
+           xt_cur(i)=xt_cur(i)/float(maxens3)/a4
+!       print*,'                               '
+!       print*,'Total ensemble independent statistics at i =',i
+!       print*,'Average= ',xt_ave(i),'  Std= ',xt_std(i)
+!       print*,'Skewness= ',xt_ske(i),' Curtosis= ',xt_cur(i)
+!       print*,'                               '
+!
+!  first go around: store massflx for different closures/caps
+!
+      if(itest.eq.1)then
+       pr_gr(i,j) = .333*(x_ave(i,1)+x_ave(i,2)+x_ave(i,3))
+       pr_w(i,j) = .333*(x_ave(i,4)+x_ave(i,5)+x_ave(i,6))
+       pr_mc(i,j) = .333*(x_ave(i,7)+x_ave(i,8)+x_ave(i,9))
+       pr_st(i,j) = .333*(x_ave(i,10)+x_ave(i,11)+x_ave(i,12))
+       pr_as(i,j) = .25*(x_ave(i,13)+x_ave(i,14)+x_ave(i,15) &
+                     + x_ave(i,16))
+       pr_capma(i,j) = x_ave_cap(i,1)
+       pr_capme(i,j) = x_ave_cap(i,2)
+       pr_capmi(i,j) = x_ave_cap(i,3)
+!
+!  second go around: store preciprates (mm/hour) for different closures/caps
+!
+        else if (itest.eq.2)then
+       APR_GR(i,j)=.333*(x_ave(i,1)+x_ave(i,2)+x_ave(i,3))*      &
+                  3600.*pr_gr(i,j) +APR_GR(i,j)
+       APR_W(i,j)=.333*(x_ave(i,4)+x_ave(i,5)+x_ave(i,6))*       &
+                  3600.*pr_w(i,j) +APR_W(i,j)
+       APR_MC(i,j)=.333*(x_ave(i,7)+x_ave(i,8)+x_ave(i,9))*      &
+                  3600.*pr_mc(i,j) +APR_MC(i,j)
+       APR_ST(i,j)=.333*(x_ave(i,10)+x_ave(i,11)+x_ave(i,12))*   &
+                  3600.*pr_st(i,j) +APR_ST(i,j)
+       APR_AS(i,j)=.25*(x_ave(i,13)+x_ave(i,14)+x_ave(i,15)      &
+                           + x_ave(i,16))*                       &
+                  3600.*pr_as(i,j) +APR_AS(i,j)
+       APR_CAPMA(i,j) = x_ave_cap(i,1)*                          &
+                  3600.*pr_capma(i,j) +APR_CAPMA(i,j)
+       APR_CAPME(i,j) = x_ave_cap(i,2)*                          &
+                  3600.*pr_capme(i,j) +APR_CAPME(i,j)
+       APR_CAPMI(i,j) = x_ave_cap(i,3)*                          &
+                  3600.*pr_capmi(i,j) +APR_CAPMI(i,j)
+        endif
+        endif
+      enddo
+
+   END SUBROUTINE massflx_stats
+
+
+   SUBROUTINE neg_check(dt,q,outq,outt,outqc,pret,its,ite,kts,kte,itf,ktf)
+
+   INTEGER,      INTENT(IN   ) ::            its,ite,kts,kte,itf,ktf
+
+     real, dimension (its:ite,kts:kte  )                    ,                 &
+      intent(inout   ) ::                                                     &
+       q,outq,outt,outqc
+     real, dimension (its:ite  )                            ,                 &
+      intent(inout   ) ::                                                     &
+       pret
+     real                                                                     &
+        ,intent (in  )                   ::                                   &
+        dt
+     real :: thresh,qmem,qmemf,qmem2,qtest,qmem1
+!
+! first do check on vertical heating rate
+!
+      thresh=200.01
+      do i=its,itf
+      qmemf=1.
+      qmem=0.
+      do k=kts,ktf
+         qmem=outt(i,k)*86400.
+         if(qmem.gt.2.*thresh)then
+           qmem2=2.*thresh/qmem
+           qmemf=min(qmemf,qmem2)
+!
+!
+!          print *,'1',' adjusted massflux by factor ',i,k,qmem,qmem2,qmemf
+         endif
+         if(qmem.lt.-thresh)then
+           qmem2=-thresh/qmem
+           qmemf=min(qmemf,qmem2)
+!
+!
+!          print *,'2',' adjusted massflux by factor ',i,k,qmem,qmem2,qmemf
+         endif
+      enddo
+      do k=kts,ktf
+         outq(i,k)=outq(i,k)*qmemf
+         outt(i,k)=outt(i,k)*qmemf
+         outqc(i,k)=outqc(i,k)*qmemf
+      enddo
+      pret(i)=pret(i)*qmemf 
+      enddo
+!
+! 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
+!
+      thresh=1.e-10
+      do i=its,itf
+      qmemf=1.
+      do k=kts,ktf
+         qmem=outq(i,k)
+         if(abs(qmem).gt.0.)then
+         qtest=q(i,k)+outq(i,k)*dt
+         if(qtest.lt.thresh)then
+!
+! qmem2 would be the maximum allowable tendency
+!
+           qmem1=outq(i,k)
+           qmem2=(thresh-q(i,k))/dt
+           qmemf=min(qmemf,qmem2/qmem1)
+!          qmemf=max(0.,qmemf)
+!          print *,'4 adjusted tendencies ',i,k,qmem,qmem2,qmemf
+         endif
+         endif
+      enddo
+      do k=kts,ktf
+         outq(i,k)=outq(i,k)*qmemf
+         outt(i,k)=outt(i,k)*qmemf
+         outqc(i,k)=outqc(i,k)*qmemf
+      enddo
+      pret(i)=pret(i)*qmemf 
+      enddo
+
+   END SUBROUTINE neg_check
+
+
+!-------------------------------------------------------
+END MODULE module_cu_gd
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_kf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_kf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_kf.F	(revision 17)
@@ -0,0 +1,2631 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+
+MODULE module_cu_kf
+
+   USE module_wrf_error
+
+   REAL    , PARAMETER :: RAD          = 1500.
+
+CONTAINS
+
+!-------------------------------------------------------------
+   SUBROUTINE KFCPS(                                         &
+               ids,ide, jds,jde, kds,kde                     &
+              ,ims,ime, jms,jme, kms,kme                     &
+              ,its,ite, jts,jte, kts,kte                     &
+              ,DT,KTAU,DX,CUDT,CURR_SECS,ADAPT_STEP_FLAG     &
+              ,rho                                           &
+              ,RAINCV,PRATEC,NCA                             &
+              ,U,V,TH,T,W,QV,dz8w,Pcps,pi                    &
+              ,W0AVG,XLV0,XLV1,XLS0,XLS1,CP,R,G,EP1          &
+              ,EP2,SVP1,SVP2,SVP3,SVPT0                      &
+              ,STEPCU,CU_ACT_FLAG,warm_rain                  &
+            ! optional arguments
+              ,F_QV    ,F_QC    ,F_QR    ,F_QI    ,F_QS      &
+              ,RQVCUTEN,RQCCUTEN,RQRCUTEN,RQICUTEN,RQSCUTEN  &
+              ,RTHCUTEN                                      &
+                                                             )
+!-------------------------------------------------------------
+   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, &
+                                                         QV, &
+                                                          T, &
+                                                       dz8w, &
+                                                       Pcps, &
+                                                        rho, &
+                                                         pi
+!
+   REAL,  INTENT(IN   ) :: DT, DX
+   REAL,  INTENT(IN   ) :: CUDT
+   REAL,  INTENT(IN   ) :: CURR_SECS
+   LOGICAL,INTENT(IN  ) :: ADAPT_STEP_FLAG
+
+   REAL, DIMENSION( ims:ime , jms:jme ),                     &
+          INTENT(INOUT) ::                                   &
+                                                     RAINCV  &
+                                                    ,PRATEC  &
+                                                    ,   NCA
+
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),           &
+          INTENT(INOUT) ::                                   &
+                                                      W0AVG
+
+   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
+
+   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
+
+   INTEGER :: i,j,k,NTST,ICLDCK
+
+   LOGICAL :: qi_flag , qs_flag
+! adjustable time step changes
+   REAL    :: lastdt = -1.0
+   REAL    :: W0AVGfctr, W0fctr, W0den
+   LOGICAL :: run_param
+
+!----------------------------------------------------------------------
+
+!--- CALL CUMULUS PARAMETERIZATION                                        
+!                                                                        
+!...TST IS THE NUMBER OF TIME STEPS IN 10 MINUTES...W0AVG IS CLOSE TO A    
+!...RUNNING MEAN VERTICAL VELOCITY...NOTE THAT IF YOU CHANGE TST, IT WIL  
+!...CHANGE THE FREQUENCY OF THE CONVECTIVE INTITIATION CHECK (SEE BELOW) 
+!...NOTE THAT THE ORDERING OF VERTICAL LAYERS MUST BE REVERSED FOR W0AVG
+!...BECAUSE THE ORDERING IS REVERSED IN KFPARA...                         
+!                                                                           
+   DXSQ=DX*DX
+   qi_flag = .FALSE.
+   qs_flag = .FALSE.
+   IF ( PRESENT( F_QI ) ) qi_flag = f_qi
+   IF ( PRESENT( F_QS ) ) qs_flag = f_qs
+
+!----------------------
+   NTST=STEPCU
+   TST=float(NTST*2)                                                         
+!----------------------
+!  NTST=NINT(1200./(DT*2.))                                                 
+!  TST=float(NTST)                                                         
+!  NTST=NINT(0.5*TST)                                                   
+!  NTST=MAX0(NTST,1)                                                   
+!----------------------
+!  ICLDCK=MOD(KTAU,NTST)                                              
+!----------------------
+!  write(0,*) 'DT = ',DT,'  KTAU = ',KTAU,' DX = ',DX
+!  write(0,*) 'CUDT = ',CUDT,'  CURR_SECS = ',CURR_SECS
+!  write(0,*) 'ADAPT_STEP_FLAG = ',ADAPT_STEP_FLAG,' IDS = ',IDS
+!  write(0,*) 'STEPCU = ',STEPCU,' warm_rain = ',warm_rain
+!  write(0,*) 'F_QV = ',F_QV,' F_QC = ',F_QV
+!  write(0,*) 'F_QI = ',F_QI,' F_QS = ',F_QS
+!  write(0,*) 'F_QR = ',F_QR
+!  stop
+   if (lastdt < 0) then
+      lastdt = dt
+   endif
+
+   if (ADAPT_STEP_FLAG) then
+      W0AVGfctr = 2 * MAX(CUDT*60,dt) - dt
+      W0fctr = dt
+      W0den = 2 * MAX(CUDT*60,dt)
+   else
+      W0AVGfctr = (TST-1.)
+      W0fctr = 1.
+      W0den = TST
+   endif
+
+   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))
+
+!           Old:
+!
+!           W0AVG(I,K,J)=(W0AVG(I,K,J)*(TST-1.)+W0)/TST
+!           New, to support adaptive time step:
+!
+            W0AVG(I,K,J) = ( W0AVG(I,K,J) * W0AVGfctr + W0 * W0fctr ) / W0den
+
+         ENDDO
+      ENDDO
+   ENDDO
+   lastdt = dt
+!                                                                      
+!...CHECK FOR CONVECTIVE INITIATION EVERY 5 MINUTES (OR NTST/2)...      
+!                                                                     
+
+!
+! Modified for adaptive time step
+!
+   if (ADAPT_STEP_FLAG) then
+     if ( (KTAU .eq. 1) .or. (cudt .eq. 0) .or. &
+          ( CURR_SECS + dt >= &
+          ( int( CURR_SECS / ( cudt * 60 ) ) + 1 ) * cudt * 60 ) ) then
+        run_param = .TRUE.
+     else
+        run_param = .FALSE.
+     endif
+
+   else
+      if (MOD(KTAU,NTST) .EQ. 0 .or. KTAU .eq. 1) then
+         run_param = .TRUE.
+      else
+         run_param = .FALSE.
+      endif
+   endif
+
+   IF (run_param) 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 (i.eq. 110 .and. j .eq. 59 ) then
+!   write(0,*) 'nca = ',nca(i,j),' CU_ACT_FLAG = ',CU_ACT_FLAG(i,j)
+!   write(0,*) 'dt = ',dt,' ADAPT_STEP_FLAG = ',ADAPT_STEP_FLAG
+! endif
+!        IF ( NINT(NCA(I,J)) .gt. 0 ) then
+         IF ( NCA(I,J) .gt. 0.5*DT ) 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.
+	    PRATEC(I,J)=0.
+!
+! 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 KFPARA(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,PRATEC,NCA,                 &
+                 warm_rain,qi_flag,qs_flag,         &
+                 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)
+                 RQVCUTEN(I,K,J)=DQDT(K)
+              ENDDO
+            ENDIF
+
+            IF( PRESENT(RQRCUTEN) .AND. PRESENT(RQCCUTEN) .AND. &
+                PRESENT(F_QR)                                    ) 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 ) .AND. qi_flag )THEN
+              DO K=kts,kte
+                 RQICUTEN(I,K,J)=DQIDT(K)
+              ENDDO
+            ENDIF
+
+            IF( PRESENT ( RQSCUTEN ) .AND. qs_flag )THEN
+              DO K=kts,kte
+                 RQSCUTEN(I,K,J)=DQSDT(K)
+              ENDDO
+            ENDIF                                                         
+!
+         ENDIF                                                         
+       ENDDO
+     ENDDO
+
+   ENDIF
+
+   END SUBROUTINE KFCPS
+   
+!-----------------------------------------------------------
+   SUBROUTINE KFPARA (I, J,                                &
+                      U0,V0,T0,QV0,P0,DZQ,W0AVG1D,         &
+                      DT,DX,DXSQ,rho,                      &
+                      XLV0,XLV1,XLS0,XLS1,CP,R,G,          &
+                      EP2,SVP1,SVP2,SVP3,SVPT0,            &
+                      DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT,   &
+                      RAINCV,PRATEC,NCA,                   &
+                      warm_rain,qi_flag,qs_flag,           &
+                      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, &
+                                I,J
+      LOGICAL, INTENT(IN   ) :: warm_rain
+      LOGICAL           :: qi_flag, qs_flag
+
+!
+      REAL, DIMENSION( kts:kte ),                          &
+            INTENT(IN   ) ::                           U0, &
+                                                       V0, &
+                                                       T0, &
+                                                      QV0, &
+                                                       P0, &
+                                                      rho, &
+                                                      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) ::                       RAINCV, &
+                                                   PRATEC, &
+                                                      NCA
+!
+!...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,RHOE,TVQU,DP,RH,EQFRC,WSPD,         &
+            QDT,FXM,THTAG,THTESG,THPA,THFXTOP,             &
+            THFXBOT,QPA,QFXTOP,QFXBOT,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
+
+! LOCAL VARS
+
+      REAL    :: P00,T00,CV,B61,RLF,RHIC,RHBC,PIE,         &
+                 TTFRZ,TBFRZ,C5,RATE
+      REAL    :: GDRY,ROCP,ALIQ,BLIQ,                      & 
+                 CLIQ,DLIQ,AICE,BICE,CICE,DICE
+      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,THTUDL,TUDL,TTEMP,FRC1,   &
+                 QNEWIC,RL,R1,QNWFRZ,EFFQ,BE,BOTERM,ENTERM,&
+                 DZZ,WSQ,UDLBE,REI,EE2,UD2,TTMP,F1,F2,     &
+                 THTTMP,QTMP,TMPLIQ,TMPICE,TU95,TU10,EE1,  &
+                 UD1,CLDHGT,DPTT,QNEWLQ,DUMFDP,EE,TSAT,    &
+                 THTA,P150,USR,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         
+
+      INTEGER :: KX,K,KL
+!                                                    
+      INTEGER :: ISTOP,ML,L5,L4,KMIX,LOW,                  &
+                 LC,MXLAYR,LLFC,NLAYRS,NK,                 &
+                 KPBL,KLCL,LCL,LET,IFLAG,                  &
+                 KFRZ,NK1,LTOP,NJ,LTOP1,                   &
+                 LTOPM1,LVF,KSTART,KMIN,LFS,               &
+                 ND,NIC,LDB,LDT,ND1,NDK,                   &
+                 NM,LMAX,NCOUNT,NOITR,                     &
+                 NSTEP,NTC
+!                                                    
+      DATA P00,T00/1.E5,273.16/                     
+      DATA CV,B61,RLF/717.,0.608,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.01/                                           
+!-----------------------------------------------------------
+      GDRY=-G/CP                                               
+      ROCP=R/CP
+      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
+      AICE = 613.2  
+      BICE = 22.452                                         
+      CICE = 6133.0                                        
+      DICE = 0.61                                         
+!
+
+!...OPTION TO FEED CONVECTIVELY GENERATED RAINWATER      
+!...INTO GRID-RESOLVED RAINWATER (OR SNOW/GRAUPEL)      
+!...FIELD.  'FBFRC' IS THE FRACTION OF AVAILABLE       
+!...PRECIPITATION TO BE FED BACK (0.0 - 1.0)...      
+!                                                   
+      FBFRC=0.0                                    
+!                                                                       
+!...SCHEME IS CALLED ONCE  ON EACH NORTH-SOUTH SLICE, THE LOOP BELOW   
+!...CHECKS FOR THE POSSIBILITY OF INITIATING PARAMETERIZED            
+!...CONVECTION AT EACH POINT WITHIN THE SLICE                        
+!                                                                   
+!...SEE IF IT IS NECESSARY TO CHECK FOR CONVECTIVE TRIGGERING AT THIS 
+!...GRID POINT. IF NCA>0, 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)*DT
+        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
+
+        PRATEC(I,J)=PPTFLX*(1.-FBFRC)/DXSQ                       
+        RAINCV(I,J)=DT*PRATEC(I,J)
+        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
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_kfeta.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_kfeta.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_kfeta.F	(revision 17)
@@ -0,0 +1,3134 @@
+MODULE module_cu_kfeta
+
+   USE module_wrf_error
+
+!
+!  V3.3: A new trigger function is added based Ma and Tan (2009):
+!   Ma, L.-M. and Z.-M. Tan, 2009: Improving the behavior of 
+!   the cumulus parameterization for tropical cyclone prediction: 
+!   Convection trigger. Atmospheric Research, 92, 190 - 211.
+!
+!--------------------------------------------------------------------
+! 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                      &
+             ,trigger                                        &
+             ,DT,KTAU,DX,CUDT,CURR_SECS,ADAPT_STEP_FLAG      &
+             ,rho,RAINCV,PRATEC,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, RQVFTEN                     &
+                                                             )
+!
+!-------------------------------------------------------------
+   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   ) :: trigger
+   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,  INTENT(IN   ) :: CUDT
+   REAL,  INTENT(IN   ) :: CURR_SECS
+   LOGICAL,INTENT(IN   ) :: ADAPT_STEP_FLAG
+!
+   REAL, DIMENSION( ims:ime , jms:jme ),                     &
+          INTENT(INOUT) ::                           RAINCV
+
+   REAL,    DIMENSION( ims:ime , jms:jme ),                  &
+          INTENT(INOUT) ::                           PRATEC
+
+   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, &
+                                                   RQVFTEN
+!
+! 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, &
+                                                  tpart_v1D, &
+                                                  tpart_h1D, &
+                                                    W0AVG1D
+
+   REAL, DIMENSION( kts:kte )::                              &
+                                                       DQDT, &
+                                                      DQIDT, &
+                                                      DQCDT, &
+                                                      DQRDT, &
+                                                      DQSDT, &
+                                                       DTDT
+
+  REAL, DIMENSION (its-1:ite+1,kts:kte,jts-1:jte+1) ::  aveh_t, aveh_q
+  REAL, DIMENSION (its:ite,kts:kte,jts:jte) :: aveh_qmax, aveh_qmin
+  REAL, DIMENSION (its:ite,kts:kte,jts:jte) ::  avev_t, avev_q 
+  REAL, DIMENSION (its:ite,kts:kte,jts:jte) :: avev_qmax, avev_qmin
+  REAL, DIMENSION (its:ite,kts:kte,jts:jte) ::  coef_v, coef_h, tpart_h, tpart_v
+  INTEGER :: ii,jj,kk
+
+  REAL :: ttop
+  REAL, DIMENSION (kts:kte)  :: z0
+
+   REAL    ::         TST,tv,PRS,RHOE,W0,SCR1,DXSQ,tmp
+   integer :: ibegh,iendh,jbegh,jendh
+   integer :: istart,iend,jstart,jend
+   INTEGER :: i,j,k,NTST
+   REAL    :: lastdt = -1.0
+   REAL    :: W0AVGfctr, W0fctr, W0den
+   LOGICAL :: run_param
+   
+!
+   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
+!
+   if (lastdt < 0) then
+      lastdt = dt
+   endif
+   
+   if (ADAPT_STEP_FLAG) then
+      W0AVGfctr = 2 * MAX(CUDT*60,dt) - dt
+      W0fctr = dt
+      W0den = 2 * MAX(CUDT*60,dt)
+   else
+      W0AVGfctr = (TST-1.)
+      W0fctr = 1.
+      W0den = TST
+   endif
+
+  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))
+
+!           Old:            
+!
+!            W0AVG(I,K,J)=(W0AVG(I,K,J)*(TST-1.)+W0)/TST            
+!
+!           New, to support adaptive time step:
+!
+            W0AVG(I,K,J) = ( W0AVG(I,K,J) * W0AVGfctr + W0 * W0fctr ) / W0den
+         ENDDO
+      ENDDO
+   ENDDO
+   lastdt = dt
+!
+!...CHECK FOR CONVECTIVE INITIATION EVERY 5 MINUTES (OR NTST/2)...
+!
+! Modified for adaptive time step
+!
+   if (ADAPT_STEP_FLAG) then
+      if ( (KTAU .eq. 1) .or. (cudt .eq. 0) .or. &
+           ( CURR_SECS + dt >= &
+           ( int( CURR_SECS / ( cudt * 60 ) ) + 1 ) * cudt * 60 ) ) then
+         run_param = .TRUE.
+      else
+         run_param = .FALSE.
+      endif
+
+   else
+      if (MOD(KTAU,NTST) .EQ. 0 .or. KTAU .eq. 1) then
+         run_param = .TRUE.
+      else
+         run_param = .FALSE.
+      endif
+   endif
+
+   if (run_param) then
+
+! New trigger function
+     IF (trigger.eq.2) THEN         
+!
+! calculate 9-point average of moisture advection and temperature using halo (Horizontal)
+!
+     aveh_t=-999   ! horizontal 9-point ave
+     aveh_q=-999
+     avev_t=0   ! vertical 3-level ave
+     avev_q=0
+     avev_qmax=0
+     avev_qmin=0
+     aveh_qmax=0
+     aveh_qmin=0
+     tpart_h=0
+     tpart_v=0
+     coef_h=0
+     coef_v=0
+     ibegh=max(its-1, ids+1)   ! start from 2
+     jbegh=max(jts-1, jds+1)
+     iendh=min(ite+1, ide-2)   ! end at ide-2
+     jendh=min(jte+1, jde-2)
+        DO J = jbegh,jendh
+        DO K = kts,kte
+        DO I = ibegh,iendh
+          aveh_t(i,k,j)=(T(i-1,k,j-1)+T(i-1,k,j)  +T(i-1,k,j+1)+ &
+                         T(i,k,j-1)   +T(i,k,j)   +T(i,k,j+1)+         &
+                         T(i+1,k,j-1) +T(i+1,k,j) +T(i+1,k,j+1))/9.
+          aveh_q(i,k,j)=(rqvften(i-1,k,j-1)+rqvften(i-1,k,j)  +rqvften(i-1,k,j+1)+ &
+                         rqvften(i,k,j-1)   +rqvften(i,k,j)   +rqvften(i,k,j+1)+         &
+                         rqvften(i+1,k,j-1) +rqvften(i+1,k,j) +rqvften(i+1,k,j+1))/9.
+        ENDDO
+        ENDDO
+        ENDDO
+! boundary value ( all processors will do the following? Or just those processsors handling sub-area including boundary)
+        DO K = kts,kte
+           DO J = jts-1,jte+1
+            DO I = its-1,ite+1
+
+            if(i.eq.ids) then
+            aveh_t(i,k,j)=aveh_t(i+1,k,j)
+            aveh_q(i,k,j)=aveh_q(i+1,k,j)
+            elseif(i.eq.ide-1) then
+            aveh_t(i,k,j)=aveh_t(i-1,k,j)
+            aveh_q(i,k,j)=aveh_q(i-1,k,j)
+            endif
+
+            if(j.eq.jds) then
+             aveh_t(i,k,j)=aveh_t(i,k,j+1)
+             aveh_q(i,k,j)=aveh_q(i,k,j+1)
+            elseif(j.eq.jde-1) then
+            aveh_t(i,k,j)=aveh_t(i,k,j-1)
+            aveh_q(i,k,j)=aveh_q(i,k,j-1)
+            endif
+
+            if(j.eq.jds.and.i.eq.ids) then
+            aveh_q(i,k,j)=aveh_q(i+1,k,j+1) 
+            aveh_t(i,k,j)=aveh_t(i+1,k,j+1) 
+            endif
+
+            if(j.eq.jde-1.and.i.eq.ids) then
+            aveh_q(i,k,j)=aveh_q(i+1,k,j-1) 
+            aveh_t(i,k,j)=aveh_t(i+1,k,j-1) 
+            endif
+
+            if(j.eq.jde-1.and.i.eq.ide-1) then
+            aveh_q(i,k,j)=aveh_q(i-1,k,j-1) 
+            aveh_t(i,k,j)=aveh_t(i-1,k,j-1) 
+            endif
+
+            if(j.eq.jds.and.i.eq.ide-1) then
+            aveh_q(i,k,j)=aveh_q(i-1,k,j+1) 
+            aveh_t(i,k,j)=aveh_t(i-1,k,j+1) 
+            endif
+
+            ENDDO
+           ENDDO
+        ENDDO
+! search for max/min moisture advection in 9-point range, calculate horizontal T-perturbation (tpart_h)
+     istart=max(its, ids+1)   ! start from 2
+     jstart=max(jts, jds+1)
+     iend=min(ite, ide-2)   ! end at ide-2
+     jend=min(jte, jde-2)
+        DO K = kts,kte
+        DO J = jstart,jend
+        DO I = istart,iend
+           aveh_qmax(i,k,j)=aveh_q(i,k,j)
+           aveh_qmin(i,k,j)=aveh_q(i,k,j)
+          DO ii=-1, 1
+           DO jj=-1,1
+             if(aveh_q(i+II,k,j+JJ).gt.aveh_qmax(i,k,j)) aveh_qmax(i,k,j)=aveh_q(i+II,k,j+JJ)
+             if(aveh_q(i+II,k,j+JJ).lt.aveh_qmin(i,k,j)) aveh_qmin(i,k,j)=aveh_q(i+II,k,j+JJ)
+           ENDDO
+          ENDDO 
+          if(aveh_qmax(i,k,j).gt.aveh_qmin(i,k,j))then
+          coef_h(i,k,j)=(aveh_q(i,k,j)-aveh_qmin(i,k,j))/(aveh_qmax(i,k,j)-aveh_qmin(i,k,j))
+          else
+          coef_h(i,k,j)=0.
+          endif
+          coef_h(i,k,j)=amin1(coef_h(i,k,j),1.0)
+          coef_h(i,k,j)=amax1(coef_h(i,k,j),0.0)
+          tpart_h(i,k,j)=coef_h(i,k,j)*(T(i,k,j)-aveh_t(i,k,j))
+        ENDDO
+        ENDDO
+        ENDDO
+    89 continue 
+! vertical 3-layer calculation
+        DO J = jts, jte
+        DO I = its, ite
+          z0(1) = 0.5 * dz8w(i,1,j)
+          DO K = 2, kte
+            Z0(K) = Z0(K-1) + .5 * (DZ8W(i,K,j) + DZ8W(i,K-1,j))
+          ENDDO
+        DO K = kts+1,kte-1
+	  ttop = t(i,k,j) + ((t(i,k,j) - t(i,k+1,j)) / (z0(k) - z0(k+1))) * (z0(k)-z0(k-1))
+          avev_t(i,k,j)=(T(i,k-1,j) + T(i,k,j) + ttop)/3.
+!         avev_t(i,k,j)=(T(i,k-1,j)+T(i,k,j) + T(i,k+1,j))/3.
+          avev_q(i,k,j)=(rqvften(i,k-1,j)+rqvften(i,k,j) + rqvften(i,k+1,j))/3.
+        ENDDO
+          avev_t(i,kts,j)=avev_t(i,kts+1,j)   ! lowest level value, is it the same as avev_t(i,kds,j)=avev_t(i,kds+1,j)?
+          avev_q(i,kts,j)=avev_q(i,kts+1,j)   
+          avev_t(i,kte,j)=avev_t(i,kte-1,j)   ! highest level value
+          avev_q(i,kte,j)=avev_q(i,kte-1,j)   
+        ENDDO
+        ENDDO
+! max /min value
+        DO J = jts, jte
+        DO I = its, ite
+        DO K = kts+1,kte-1
+          avev_qmax(i,k,j)=avev_q(i,k,j)
+          avev_qmin(i,k,j)=avev_q(i,k,j)
+         DO kk=-1,1
+         if(avev_q(i,k+kk,j).gt.avev_qmax(i,k,j)) avev_qmax(i,k,j)=avev_q(i,k+kk,j) 
+         if(avev_q(i,k+kk,j).lt.avev_qmin(i,k,j)) avev_qmin(i,k,j)=avev_q(i,k+kk,j) 
+         ENDDO
+         if(avev_qmax(i,k,j).gt.avev_qmin(i,k,j)) then
+         coef_v(i,k,j)=(avev_q(i,k,j)-avev_qmin(i,k,j))/(avev_qmax(i,k,j)-avev_qmin(i,k,j))
+         else
+         coef_v(i,k,j)=0
+         endif
+         tpart_v(i,k,j)=coef_v(i,k,j)*(T(i,k,j)-avev_t(i,k,j))
+        ENDDO
+         tpart_v(i,kts,j)= tpart_v(i,kts+1,j)    ! lowest level
+         tpart_v(i,kte,j)= tpart_v(i,kte-1,j)    ! highest level
+        ENDDO
+        ENDDO
+     ENDIF       ! endif (trigger.eq.2)          
+!
+     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 ( NCA(I,J) .ge. 0.5*DT ) 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
+            PRATEC(I,J)=0.
+!
+! 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)
+               IF (trigger.eq.2) THEN
+                  tpart_h1D(K) =tpart_h(I,K,J)
+                  tpart_v1D(K) =tpart_v(I,K,J)
+               ELSE
+                  tpart_h1D(K) = 0.
+                  tpart_v1D(K) = 0.
+               ENDIF
+            ENDDO
+            CALL KF_eta_PARA(I, J,                  &
+                 U1D,V1D,T1D,QV1D,P1D,DZ1D,W0AVG1D, &
+                 tpart_h1D,tpart_v1D,               &
+                 trigger,                           &
+                 DT,DX,DXSQ,RHO1D,                  &
+                 XLV0,XLV1,XLS0,XLS1,CP,R,G,        &
+                 EP2,SVP1,SVP2,SVP3,SVPT0,          &
+                 DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, &
+                 RAINCV,PRATEC,NCA,                 &
+                 flag_QI,flag_QS,warm_rain,         &
+                 CUTOP,CUBOT,CUDT,                  &
+                 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)
+                 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     ! i-loop
+     ENDDO       ! j-loop
+   ENDIF         ! run_param
+!
+   END SUBROUTINE KF_eta_CPS
+! ****************************************************************************
+!-----------------------------------------------------------
+   SUBROUTINE KF_eta_PARA (I, J,                           &
+                      U0,V0,T0,QV0,P0,DZQ,W0AVG1D,         &
+                      TPART_H0,TPART_V0,                   &
+                      trigger,                             &
+                      DT,DX,DXSQ,rhoe,                     &
+                      XLV0,XLV1,XLS0,XLS1,CP,R,G,          &
+                      EP2,SVP1,SVP2,SVP3,SVPT0,            &
+                      DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT,   &
+                      RAINCV,PRATEC,NCA,                   &
+                      F_QI,F_QS,warm_rain,                 &
+                      CUTOP,CUBOT,CUDT,                    &
+                      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
+          ! ,P_QI,P_QS,P_FIRST_SCALAR
+      INTEGER, INTENT(IN   ) ::  trigger
+
+      LOGICAL, INTENT(IN   ) :: F_QI, F_QS
+
+      LOGICAL, INTENT(IN   ) :: warm_rain
+!
+      REAL, DIMENSION( kts:kte ),                          &
+            INTENT(IN   ) ::                           U0, &
+                                                       V0, &
+                                                 TPART_H0, &
+                                                 TPART_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(INOUT) ::                       PRATEC
+
+      REAL, DIMENSION( ims:ime , jms:jme ),                &
+            INTENT(OUT) ::                          CUBOT, &
+                                                    CUTOP
+      REAL,  INTENT(IN   ) :: CUDT
+!
+!...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
+      REAL :: u00,qslcl,rhlcl,dqssdt    !jfb
+      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/   ! wrf default
+!      DATA RATE/0.01/  ! value used in NRCM
+!      DATA RATE/0.001/  ! effectively turn off autoconversion
+!-----------------------------------------------------------
+      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
+!
+!  Saturation vapor pressure (ES) is calculated following Buck (1981)
+!...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
+      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
+! calculate DLP using Z instead of log(P)
+          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        ! Kain (2004) Eq. 2
+            WKLCL=0.02*ZLCL/2.E3
+          ELSE
+            WKLCL=0.02                ! units of m/s
+          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      ! Kain (2004) Eq. 1
+          ENDIF
+
+! New trigger function
+           IF(trigger.eq.2) then
+              DTLCL=amax1(TPART_H0(KLCL)+TPART_V0(KLCL),0.0)
+           ENDIF
+! end for trigger function
+!
+        dtrh = 0.
+	if (trigger  .eq. 3) then
+!...for ETA model, give parcel an extra temperature perturbation based
+!...the threshold RH for condensation (U00)...
+! as described in Narita and Ohmori (2007, 12th Mesoscale Conf.
+!
+!...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   
+        endif   ! trigger 3
+!         IF(ISHALL.EQ.1)IPRNT=.TRUE.
+!         IPRNT=.TRUE.
+!         IF(TLCL+DTLCL.GT.TENV)GOTO 45
+ 
+trigger2:  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     ! Kain (2004) Eq. 3  (sort of)
+              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...    (Kain (2004) Eq. 6)
+            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...
+!     
+!    **1 variables indicate the bottom of a model layer
+!    **2 variables indicate the top of a model layer
+!     
+            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          !    KF (1990) Eq. 1; Kain (2004) Eq. 5
+              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       ! Kain (2004)  Eq. 4
+                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 EQUILIBRIUM
+!   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...
+!     
+            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...
+!
+!   Kain (2004)  Eq. 7
+!
+            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 trigger2
+        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,LTOP
+      IF(T0(NK).GT.T00)ML=NK
+    ENDDO
+    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 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)
+          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)         ! 30 minutes  >= TIMEC <= 60 minutes
+        TIMEC=AMIN1(3600.,TIMEC)
+        IF(ISHALL.EQ.1)TIMEC=2400.       ! shallow convection TIMEC = 40 minutes
+        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
+         WRITE(message,1035)PEF,PEFCBH,LC,LET,WKL,VWS
+         CALL wrf_message( message )
+!       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)    ! Kain (2004) eq. 11
+          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
+           write(message,*)'PRECIP EFFICIENCY =',PEFF
+           CALL wrf_message(message)
+!          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 INFLOW
+!   INTO CONVECTIVE DRAFTS FROM A GIVEN LAYER IS NO MORE THAN IS AVAILABLE
+!   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 ON
+!...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, BORROW
+!...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 CONVECTIVE
+!...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 LAYER
+!...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
+         WRITE(message,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC
+         CALL wrf_message(message)
+!        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(message,*)'P(LC), DTP, WKL, WKLCL =',p0(LC)/100.,       &
+                     TLCL+DTLCL+dtrh-TENV,WKL,WKLCL
+         call wrf_message(message)
+         write(message,*)'TLCL, DTLCL, DTRH, TENV =',TLCL,DTLCL,       &
+                      DTRH,TENV   
+         call wrf_message(message)
+         WRITE(message,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG,       &
+         TMIX-T00,PMIX,QMIX,ABE
+         call wrf_message(message)
+         WRITE(message,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100.,  &
+         WLCL,CLDHGT(LC)
+         call wrf_message(message)
+         WRITE(message,1035)PEF,PEFCBH,LC,LET,WKL,VWS 
+         call wrf_message(message)
+         write(message,*)'PRECIP EFFICIENCY =',PEFF 
+         call wrf_message(message)
+      WRITE(message,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC
+         call wrf_message(message)
+!      ENDIF
+!!!!! HERE !!!!!!!
+           WRITE(message,1070)'  P  ','   DP ',' DT K/D ',' DR K/D ','   OMG  ',        &
+          ' DOMGDP ','   UMF  ','   UER  ','   UDR  ','   DMF  ','   DER  '        &
+          ,'   DDR  ','   EMS  ','    W0  ','  DETLQ ',' DETIC '
+         call wrf_message(message)
+           write(message,*)'just before DO 300...'
+         call wrf_message(message)
+!          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(message,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
+         call wrf_message(message)
+           ENDDO
+           WRITE(message,1085)'K','P','Z','T0','TG','DT','TU','TD','Q0','QG',             &
+                  'DQ','QU','QD','QLG','QIG','QRG','QSG','RH0','RHG'
+         call wrf_message(message)
+           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(message,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
+         call wrf_message(message)
+           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)
+        PRATEC(I,J)=PPTFLX*(1.-FBFRC)/DXSQ
+        RAINCV(I,J)=DT*PRATEC(I,J)     !  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) = REAL(NIC)*DT
+        IF(ISHALL.EQ.1)THEN
+           TIMEC = 2400.
+           NCA(I,J) = CUDT*60.
+           NSHALL = NSHALL+1
+        ENDIF
+
+        DO K=1,KX
+!         IF(IMOIST(INEST).NE.2)THEN
+!
+!...IF HYDROMETEORS ARE NOT ALLOWED, THEY MUST BE EVAPORATED OR SUBLIMATED
+!...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 HYDROMETEORS
+!...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 TENDENCIES
+!...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
+        PRATEC(I,J)=PPTFLX*(1.-FBFRC)/DXSQ
+        RAINCV(I,J)=DT*PRATEC(I,J)
+!        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 TEMPERATURES, 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
+!
+      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               ! KF90  Eq. 9
+!                                                                       
+!  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)            ! KF90  Eq. 9                                              
+!                                                                       
+!  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                            
+!  Solves for KF90 Eq. 2
+!
+!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
+!        For example, KF90 Eq. 10 no longer used
+!
+      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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_nsas.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_nsas.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_nsas.F	(revision 17)
@@ -0,0 +1,3267 @@
+!
+!
+!
+!
+MODULE module_cu_nsas
+CONTAINS
+!
+!-------------------------------------------------------------------------------
+   subroutine cu_nsas(dt,p3di,p3d,pi3d,qc3d,qi3d,rho3d,itimestep,stepcu,       &
+                     hbot,htop,cu_act_flag,cudt,curr_secs,adapt_step_flag,     &
+                     rthcuten,rqvcuten,rqccuten,rqicuten,                      &
+                     rucuten,rvcuten,                                          &
+                     qv3d,t3d,raincv,pratec,xland,dz8w,w,u3d,v3d,              &
+                     hpbl,hfx,qfx,                                             &
+                     mp_physics,                                               &
+                     p_qc,p_qi,p_first_scalar,                                 &
+                     cp,cliq,cpv,g,xlv,r_d,r_v,ep_1,ep_2,                      &
+                     cice,xls,psat,f_qi,f_qc,                                  &
+                     ids,ide, jds,jde, kds,kde,                                &
+                     ims,ime, jms,jme, kms,kme,                                &
+                     its,ite, jts,jte, kts,kte)
+!-------------------------------------------------------------------------------
+  implicit none
+!-------------------------------------------------------------------------------
+!
+!-- dt          time step (s)
+!-- p3di        3d pressure (pa) at interface level
+!-- p3d         3d pressure (pa)
+!-- pi3d        3d exner function (dimensionless)
+!-- z           height above sea level (m)
+!-- qc3d        cloud water mixing ratio (kg/kg)
+!-- qi3d        cloud ice mixing ratio (kg/kg)
+!-- qv3d        3d water vapor mixing ratio (kg/kg)
+!-- t3d         temperature (k)
+!-- raincv      cumulus scheme precipitation (mm)
+!-- w           vertical velocity (m/s)
+!-- dz8w        dz between full levels (m)
+!-- u3d         3d u-velocity interpolated to theta points (m/s)
+!-- v3d         3d v-velocity interpolated to theta points (m/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   )   ::       ids,ide, jds,jde, kds,kde,                &
+                                     ims,ime, jms,jme, kms,kme,                &
+                                     its,ite, jts,jte, kts,kte,                &
+                                     itimestep, stepcu,                        &
+                                     p_qc,p_qi,p_first_scalar
+!
+  real,     intent(in   )   ::      cp,cliq,cpv,g,xlv,r_d,r_v,ep_1,ep_2,       &
+                                    cice,xls,psat
+  real,     intent(in   )   ::      dt
+!
+  real,     dimension( ims:ime, kms:kme, jms:jme ),optional                  , &
+            intent(inout)   ::                                       rthcuten, &
+                                                                      rucuten, &
+                                                                      rvcuten, &
+                                                                     rqccuten, &
+                                                                     rqicuten, &
+                                                                     rqvcuten
+  logical, optional ::                                              F_QC,F_QI
+  real,     dimension( ims:ime, kms:kme, jms:jme )                           , &
+            intent(in   )   ::                                           qv3d, &
+                                                                         qc3d, &
+                                                                         qi3d, &
+                                                                        rho3d, &
+                                                                          p3d, &
+                                                                         pi3d, &
+                                                                          t3d
+  real,     dimension( ims:ime, kms:kme, jms:jme )                           , &
+            intent(in   )   ::                                           p3di
+  real,     dimension( ims:ime, kms:kme, jms:jme )                           , &
+            intent(in   )   ::                                           dz8w, &  
+                                                                            w
+  real,     dimension( ims:ime, jms:jme )                                    , &
+            intent(inout) ::                                           raincv, &
+                                                                       pratec
+  real,     dimension( ims:ime, jms:jme )                                    , &
+            intent(out) ::                                               hbot, &
+                                                                         htop
+  real,     dimension( ims:ime, jms:jme )                                    , &
+            intent(in   ) ::                                            xland
+!
+  real,     dimension( ims:ime, kms:kme, jms:jme )                           , &
+             intent(in   )   ::                                           u3d, &
+                                                                          v3d
+  logical,  dimension( ims:ime, jms:jme )                                    , &
+            intent(inout) ::                                      cu_act_flag
+  real, intent(   in) ::                                                 cudt
+  real, intent(   in) ::                                            curr_secs
+  logical, intent(    in) ::                                  adapt_step_flag
+!
+  real,     dimension( ims:ime, jms:jme )                                    , &
+             intent(in   )   ::                                          hpbl, &
+                                                                          hfx, &
+                                                                          qfx
+  integer,   intent(in   )   ::                                    mp_physics
+  integer :: ncloud
+!
+!local
+!
+  real,  dimension( its:ite, jts:jte )  ::                            raincv1, &
+                                                                      raincv2, &
+                                                                      pratec1, &
+                                                                      pratec2
+  real,   dimension( its:ite, kts:kte )  ::                               del, &
+                                                                        prsll, &
+                                                                          dot, &
+                                                                           u1, &
+                                                                           v1, &
+                                                                           t1, &
+                                                                          q1,  &
+                                                                          qc2, &
+                                                                          qi2
+  real,   dimension( its:ite, kts:kte+1 )  ::                           prsii, &
+                                                                          zii
+  real,   dimension( its:ite, kts:kte )  ::                               zll 
+  real,   dimension( its:ite)  ::                                         rain
+  real ::                                                          delt,rdelt
+  integer, dimension (its:ite)  ::                                       kbot, &
+                                                                         ktop, &
+                                                                          kuo
+  logical ::  run_param
+  integer ::  i,j,k,kp
+!
+!-------------------------------------------------------------------------------
+! microphysics scheme --> ncloud 
+   if (mp_physics .eq. 1) then
+     ncloud = 0
+   elseif ( mp_physics .eq. 2 .or. mp_physics .eq. 3 ) then
+     ncloud = 2
+   elseif ( mp_physics .eq. 5 ) then
+     ncloud = 3 
+   elseif ( mp_physics .eq. 4 .or. mp_physics .eq. 14 ) then
+     ncloud = 4
+   elseif ( mp_physics .eq. 9) then
+     ncloud = 6
+   else
+     ncloud = 5
+   endif  
+!
+!-------------------------------------------------------------------------------
+!
+!*** check to see if this is a convection timestep
+!
+      if (adapt_step_flag) then
+        if ( (itimestep .eq. 0) .or. (cudt .eq. 0) .or.                        &
+          (curr_secs + dt >= (int(curr_secs/(cudt*60))+1)*cudt*60)) then
+          run_param = .true.
+        else
+          run_param = .false.
+        endif
+      else
+        if (MOD(itimestep,stepcu) .EQ. 0 .or. itimestep .eq. 0) then
+          run_param = .true.
+        else
+          run_param = .false.
+        endif
+      endif
+!-------------------------------------------------------------------------------
+   if(run_param) then
+      do j=jts,jte
+        do i=its,ite
+          cu_act_flag(i,j)=.TRUE.
+        enddo
+      enddo
+      delt=dt*stepcu
+      rdelt=1./delt
+!
+   do j = jts,jte  !outer most J_loop
+      do k = kts,kte
+        kp = k+1
+        do i = its,ite
+          dot(i,k) = -5.0e-4*g*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j))
+          prsll(i,k)=p3d(i,k,j)*0.001
+          prsii(i,k)=p3di(i,k,j)*0.001
+        enddo
+      enddo
+      do i = its,ite
+        prsii(i,kte+1)=p3di(i,kte+1,j)*0.001
+      enddo
+!
+      do i=its,ite
+        zii(i,1)=0.0
+      enddo     
+!
+      do k=kts,kte                                            
+        do i=its,ite
+          zii(i,k+1)=zii(i,k)+dz8w(i,k,j)
+        enddo
+      enddo
+!
+      do k=kts,kte                
+        do i=its,ite                                                  
+          zll(i,k)=0.5*(zii(i,k)+zii(i,k+1))
+        enddo                                                         
+      enddo
+!
+      do k=kts,kte
+        do i=its,ite
+          del(i,k)=prsll(i,k)*g/r_d*dz8w(i,k,j)/t3d(i,k,j)
+          u1(i,k)=u3d(i,k,j)
+          v1(i,k)=v3d(i,k,j)
+          t1(i,k)=t3d(i,k,j)
+          q1(i,k)=qv3d(i,k,j)
+          qi2(i,k) = qi3d(i,k,j)
+          qc2(i,k) = qc3d(i,k,j)
+        enddo
+      enddo
+!
+! NCEP SAS 
+      call nsas2d(delt=dt,del=del(its,kts),prsl=prsll(its,kts),                &
+              prsi=prsii(its,kts),prslk=pi3d(ims,kms,j),zl=zll(its,kts),       &
+              zi=zii(its,kts),ncloud=ncloud,qc2=qc2(its,kts),qi2=qi2(its,kts), &
+              q1=q1(its,kts),t1=t1(its,kts),rain=rain(its),                    &
+              kbot=kbot(its),ktop=ktop(its),                                   &
+              kuo=kuo(its),                                                    &
+              lat=j,slimsk=xland(ims,j),dot=dot(its,kts),                      &
+              u1=u1(its,kts), v1=v1(its,kts),                                  &
+              cp_=cp,cliq_=cliq,cvap_=cpv,g_=g,hvap_=xlv,                      &
+              rd_=r_d,rv_=r_v,fv_=ep_1,ep2=ep_2,                               &
+              cice=cice,xls=xls,psat=psat,                                     &
+              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   )
+!
+      do i=its,ite
+        pratec1(i,j)=rain(i)*1000./(stepcu*dt)
+        raincv1(i,j)=rain(i)*1000./(stepcu)
+      enddo
+!
+! NCEP SCV
+      call nscv2d(delt=dt,del=del(its,kts),prsl=prsll(its,kts),                &
+              prsi=prsii(its,kts),prslk=pi3d(ims,kms,j),zl=zll(its,kts),       &
+              zi=zii(its,kts),ncloud=ncloud,qc2=qc2(its,kts),qi2=qi2(its,kts), &
+              q1=q1(its,kts),t1=t1(its,kts),rain=rain(its),                    &
+              kbot=kbot(its),ktop=ktop(its),                                   &
+              kuo=kuo(its),                                                    &
+              slimsk=xland(ims,j),dot=dot(its,kts),                            &
+              u1=u1(its,kts), v1=v1(its,kts),                                  &
+              cp_=cp,cliq_=cliq,cvap_=cpv,g_=g,hvap_=xlv,                      &
+              rd_=r_d,rv_=r_v,fv_=ep_1,ep2=ep_2,                               &
+              cice=cice,xls=xls,psat=psat,                                     &
+              hpbl=hpbl(ims,j),hfx=hfx(ims,j),qfx=qfx(ims,j),                  &
+              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   )
+!
+   do i=its,ite
+     pratec2(i,j)=rain(i)*1000./(stepcu*dt)
+     raincv2(i,j)=rain(i)*1000./(stepcu)
+   enddo
+!
+   do i=its,ite
+     raincv(i,j) = raincv1(i,j) + raincv2(i,j)
+     pratec(i,j) = pratec1(i,j) + pratec2(i,j)
+     hbot(i,j) = kbot(i)
+     htop(i,j) = ktop(i)
+   enddo
+!
+      IF(PRESENT(rthcuten).AND.PRESENT(rqvcuten)) THEN
+      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)-qv3d(i,k,j))*rdelt
+        enddo
+      enddo
+      ENDIF
+!
+      IF(PRESENT(rucuten).AND.PRESENT(rvcuten)) THEN
+      do k = kts,kte
+        do i= its,ite
+          rucuten(i,k,j)=(u1(i,k)-u3d(i,k,j))*rdelt
+          rvcuten(i,k,j)=(v1(i,k)-v3d(i,k,j))*rdelt
+        enddo
+      enddo
+      ENDIF
+!
+      if(PRESENT( rqicuten )) THEN
+        IF ( F_QI ) THEN
+        do k=kts,kte
+          do i=its,ite
+            rqicuten(i,k,j)=(qi2(i,k)-qi3d(i,k,j))*rdelt
+          enddo
+        enddo
+        endif
+      endif
+      if(PRESENT( rqccuten )) THEN
+        IF ( F_QC ) THEN
+        do k=kts,kte
+          do i=its,ite
+            rqccuten(i,k,j)=(qc2(i,k)-qc3d(i,k,j))*rdelt
+          enddo
+        enddo
+        endif
+      endif
+!
+   enddo ! outer most J_loop
+  endif
+!
+   end subroutine cu_nsas
+!
+!==============================================================================
+! NCEP SAS (Deep Convection Scheme)
+!==============================================================================
+   subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
+            ncloud,                                                            & 
+            qc2,qi2,                                                           & 
+            q1,t1,rain,kbot,ktop,                                              &
+            kuo,                                                               &
+            lat,slimsk,dot,u1,v1,cp_,cliq_,cvap_,g_,hvap_,rd_,rv_,fv_,ep2,     &
+            cice,xls,psat,                                                     &
+            ids,ide, jds,jde, kds,kde,                                         &
+            ims,ime, jms,jme, kms,kme,                                         &
+            its,ite, jts,jte, kts,kte)
+!
+!------------------------------------------------------------------------------
+!
+! subprogram:    phys_cps_sas      computes convective heating and moistening
+!                                                      and momentum transport
+!
+! abstract: computes convective heating and moistening using a one
+!   cloud type arakawa-schubert convection scheme originally developed
+!   by georg grell. the scheme has been revised at ncep since initial 
+!   implementation in 1993. it includes updraft and downdraft effects.
+!   the closure is the cloud work function. both updraft and downdraft
+!   are assumed to be saturated and the heating and moistening are
+!   accomplished by the compensating environment. convective momentum transport
+!   is taken into account. the name comes from "simplified arakawa-schubert
+!   convection parameterization".
+!
+! developed by hua-lu pan, wan-shu wu, songyou hong, and jongil han
+!   implemented into wrf by kyosun sunny lim and songyou hong
+!   module with cpp-based options is available in grims 
+!
+! program history log:
+!   92-03-01  hua-lu pan       operational development
+!   96-03-01  song-you hong    revised closure, and trigger 
+!   99-03-01  hua-lu pan       multiple clouds
+!   06-03-01  young-hwa byun   closure based on moisture convergence (optional)
+!   09-10-01  jung-eun kim     f90 format with standard physics modules
+!   10-07-01  jong-il han      revised cloud model,trigger, as in gfs july 2010
+!   10-12-01  kyosun sunny lim wrf compatible version
+!
+!
+! usage:    call phys_cps_sas(delt,delx,del,prsl,prsi,prslk,prsik,zl,zi,       &
+!                             q2,q1,t1,u1,v1,rcs,slimsk,dot,cldwrk,rain,       &
+!                             jcap,ncloud,lat,kbot,ktop,kuo,                   &
+!                             ids,ide, jds,jde, kds,kde,                       &
+!                             ims,ime, jms,jme, kms,kme,                       &
+!                             its,ite, jts,jte, kts,kte)
+!
+!   delt     - real model integration time step
+!   delx     - real model grid interval
+!   del      - real (kms:kme) sigma layer thickness
+!   prsl     - real (ims:ime,kms:kme) pressure values
+!   prsi     - real (ims:ime,kms:kme) pressure values at interface level
+!   prslk    - real (ims:ime,kms:kme) pressure values to the kappa
+!   prsik    - real (ims:ime,kms:kme) pressure values to the kappa at interface lev.
+!   zl       - real (ims:ime,kms:kme) height above sea level
+!   zi       - real (ims:ime,kms:kme) height above sea level at interface level
+!   rcs      - real
+!   slimsk   - real (ims:ime) land(1),sea(0), ice(2) flag
+!   dot      - real (ims:ime,kms:kme) vertical velocity
+!   jcap     - integer spectral truncation
+!   ncloud   - integer number of hydrometeors
+!   lat      - integer  current latitude index
+!
+! output argument list:
+!   q2       - real (ims:ime,kms:kme) detrained hydrometeors in kg/kg
+!            - in case of the  --> qc2(cloud), qi2(ice)
+!   q1       - real (ims:ime,kms:kme) adjusted specific humidity in kg/kg
+!   t1       - real (ims:ime,kms:kme) adjusted temperature in kelvin
+!   u1       - real (ims:ime,kms:kme) adjusted zonal wind in m/s
+!   v1       - real (ims:ime,kms:kme) adjusted meridional wind in m/s
+!   cldwrk   - real (ims:ime) cloud work function
+!   rain     - real (ims:ime) convective rain in meters
+!   kbot     - integer (ims:ime) cloud bottom level
+!   ktop     - integer (ims:ime) cloud top level
+!   kuo      - integer (ims:ime) bit flag indicating deep convection
+!
+! subprograms called:
+!   fpvs     - function to compute saturation vapor pressure
+!
+! remarks: function fpvs is inlined by fpp.
+!          nonstandard automatic arrays are used.
+!
+! references :
+!   pan and wu    (1995, ncep office note)
+!   hong and pan  (1998, mon wea rev)
+!   park and hong (2007,jmsj)
+!   byun and hong (2007, mon wea rev)
+!   han and pan   (2011, wea. forecasting)
+!
+!------------------------------------------------------------------------------
+!------------------------------------------------------------------------------
+   implicit none
+!------------------------------------------------------------------------------
+!
+! model tunable parameters 
+!
+   real,parameter  ::  alphal = 0.5,    alphas = 0.5
+   real,parameter  ::  betal  = 0.05,   betas  = 0.05
+   real,parameter  ::  pdpdwn = 0.0,    pdetrn = 200.0
+   real,parameter  ::  c0     = 0.002,  c1     = 0.002
+   real,parameter  ::  pgcon = 0.55
+   real,parameter  ::  xlamdd = 1.0e-4, xlamde = 1.0e-4
+   real,parameter  ::  clam   = 0.1,    cxlamu = 1.0e-4
+   real,parameter  ::  aafac  = 0.1
+   real,parameter  ::  dthk=25.
+   real,parameter  ::  cincrmax = 180.,cincrmin = 120.
+   real,parameter  ::  W1l = -8.E-3 
+   real,parameter  ::  W2l = -4.E-2
+   real,parameter  ::  W3l = -5.E-3 
+   real,parameter  ::  W4l = -5.E-4
+   real,parameter  ::  W1s = -2.E-4
+   real,parameter  ::  W2s = -2.E-3
+   real,parameter  ::  W3s = -1.E-3
+   real,parameter  ::  W4s = -2.E-5
+   real,parameter  ::  mbdt = 10., edtmaxl = 0.3, edtmaxs = 0.3
+   real,parameter  ::  evfacts = 0.3, evfactl = 0.3
+!
+   real,parameter  ::  tf=233.16,tcr=263.16,tcrf=1.0/(tcr-tf)
+   real,parameter  ::  xk1=2.e-5,xlhor=3.e4,xhver=5000.,theimax=1.
+   real,parameter  ::  xc1=1.e-7,xc2=1.e4,xc3=3.e3,ecesscr=3.0,edtk1=3.e4
+!
+!  passing variables
+!
+   real            ::  cp_,cliq_,cvap_,g_,hvap_,rd_,rv_,fv_,ep2
+   real            ::  pi_,qmin_,t0c_,cice,xlv0,xls,psat
+   integer         ::  lat,                                                    &
+                       ncloud,                                                 &
+                       ids,ide, jds,jde, kds,kde,                              &
+                       ims,ime, jms,jme, kms,kme,                              &
+                       its,ite, jts,jte, kts,kte
+!
+   real            ::  delt,rcs
+   real            ::  del(its:ite,kts:kte),                                   &
+                       prsl(its:ite,kts:kte),prslk(ims:ime,kms:kme),           &
+                       prsi(its:ite,kts:kte+1),                                &
+                       zl(its:ite,kts:kte),zi(its:ite,kts:kte+1),              &
+                       q1(its:ite,kts:kte),t1(its:ite,kts:kte),                &
+                       u1(its:ite,kts:kte),v1(its:ite,kts:kte),                &
+                       dot(its:ite,kts:kte)
+   real            ::  qi2(its:ite,kts:kte)
+   real            ::  qc2(its:ite,kts:kte)
+!
+   real            ::  rain(its:ite)
+   integer         ::  kbot(its:ite),ktop(its:ite),kuo(its:ite)
+   real            ::  slimsk(ims:ime)
+!
+!
+!  local variables and arrays
+!
+   integer         ::  i,k,kmax,kbmax,kbm,jmn,indx,indp,kts1,kte1,kmax1,kk
+   real            ::  p(its:ite,kts:kte),pdot(its:ite),acrtfct(its:ite)
+   real            ::  uo(its:ite,kts:kte),vo(its:ite,kts:kte)
+   real            ::  to(its:ite,kts:kte),qo(its:ite,kts:kte)
+   real            ::  hcko(its:ite,kts:kte)
+   real            ::  qcko(its:ite,kts:kte),eta(its:ite,kts:kte)
+   real            ::  etad(its:ite,kts:kte)
+   real            ::  qrcdo(its:ite,kts:kte)
+   real            ::  pwo(its:ite,kts:kte),pwdo(its:ite,kts:kte)
+   real            ::  dtconv(its:ite)
+   real            ::  deltv(its:ite),acrt(its:ite)
+   real            ::  qeso(its:ite,kts:kte)
+   real            ::  tvo(its:ite,kts:kte),dbyo(its:ite,kts:kte)
+   real            ::  heo(its:ite,kts:kte),heso(its:ite,kts:kte)
+   real            ::  qrcd(its:ite,kts:kte)
+   real            ::  dellah(its:ite,kts:kte),dellaq(its:ite,kts:kte)
+!
+   integer         ::  kb(its:ite),kbcon(its:ite)
+   integer         ::  kbcon1(its:ite)
+   real            ::  hmax(its:ite),delq(its:ite)
+   real            ::  hkbo(its:ite),qkbo(its:ite),pbcdif(its:ite)
+   integer         ::  kbds(its:ite),lmin(its:ite),jmin(its:ite)
+   integer         ::  ktcon(its:ite)
+   integer         ::  ktcon1(its:ite)
+   integer         ::  kbdtr(its:ite),kpbl(its:ite)
+   integer         ::  klcl(its:ite),ktdown(its:ite)
+   real            ::  vmax(its:ite)
+   real            ::  hmin(its:ite),pwavo(its:ite)
+   real            ::  aa1(its:ite),vshear(its:ite)
+   real            ::  qevap(its:ite)
+   real            ::  edt(its:ite)
+   real            ::  edto(its:ite),pwevo(its:ite)
+   real            ::  qcond(its:ite)
+   real            ::  hcdo(its:ite,kts:kte)
+   real            ::  ddp(its:ite),pp2(its:ite)
+   real            ::  qcdo(its:ite,kts:kte)
+   real            ::  adet(its:ite),aatmp(its:ite)
+   real            ::  xhkb(its:ite),xqkb(its:ite)
+   real            ::  xpwav(its:ite),xpwev(its:ite),xhcd(its:ite,kts:kte)
+   real            ::  xaa0(its:ite),f(its:ite),xk(its:ite)
+   real            ::  xmb(its:ite)
+   real            ::  edtx(its:ite),xqcd(its:ite,kts:kte)
+   real            ::  hsbar(its:ite),xmbmax(its:ite)
+   real            ::  xlamb(its:ite,kts:kte),xlamd(its:ite)
+   real            ::  excess(its:ite)
+   real            ::  plcl(its:ite)
+   real            ::  delhbar(its:ite),delqbar(its:ite),deltbar(its:ite)
+   real,save       ::  pcrit(15), acritt(15)
+   real            ::  acrit(15)
+   real            ::  qcirs(its:ite,kts:kte),qrski(its:ite)
+   real            ::  dellal(its:ite,kts:kte)
+   real            ::  rntot(its:ite),delqev(its:ite),delq2(its:ite) 
+!
+   real            ::  fent1(its:ite,kts:kte),fent2(its:ite,kts:kte)
+   real            ::  frh(its:ite,kts:kte)
+   real            ::  xlamud(its:ite),sumx(its:ite)
+   real            ::  aa2(its:ite)
+   real            ::  ucko(its:ite,kts:kte),vcko(its:ite,kts:kte)
+   real            ::  ucdo(its:ite,kts:kte),vcdo(its:ite,kts:kte)
+   real            ::  dellau(its:ite,kts:kte),dellav(its:ite,kts:kte)
+   real            ::  delubar(its:ite),delvbar(its:ite)
+   real            ::  qlko_ktcon(its:ite)
+!
+   real            ::  alpha,beta,                                             &
+                       dt2,dtmin,dtmax,dtmaxl,dtmaxs,                          &
+                       el2orc,eps,fact1,fact2,                                 &
+                       tem,tem1,cincr
+   real            ::  dz,dp,es,pprime,qs,                                     &
+                       dqsdp,desdt,dqsdt,gamma,                                &
+                       dt,dq,po,thei,delza,dzfac,                              &
+                       thec,theb,thekb,thekh,theavg,thedif,                    &
+                       omgkb,omgkbp1,omgdif,omgfac,heom,rh,thermal,chi,        &
+                       factor,onemf,dz1,qrch,etah,qlk,qc,rfact,shear,          &
+                       e1,dh,deta,detad,theom,edtmax,dhh,dg,aup,adw,           &
+                       dv1,dv2,dv3,dv1q,dv2q,dv3q,dvq1,                        &
+                       dv1u,dv2u,dv3u,dv1v,dv2v,dv3v,                          &
+                       dellat,xdby,xqrch,xqc,xpw,xpwd,                         &
+                       w1,w2,w3,w4,qrsk,evef,ptem,ptem1
+!
+   logical         ::  totflg, cnvflg(its:ite),flg(its:ite)
+!
+!  climatological critical cloud work functions for closure
+!
+   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/
+!
+!-----------------------------------------------------------------------
+!
+! define miscellaneous values
+!
+   pi_   = 3.14159
+   qmin_ = 1.0e-30
+   t0c_ = 273.15
+   xlv0 = hvap_
+   rcs  = 1.
+   el2orc = hvap_*hvap_/(rv_*cp_)
+   eps    = rd_/rv_
+   fact1  = (cvap_-cliq_)/rv_
+   fact2  = hvap_/rv_-fact1*t0c_
+   kts1 = kts + 1
+   kte1 = kte - 1
+   dt2    = delt
+   dtmin  = max(dt2,1200.)
+   dtmax  = max(dt2,3600.)
+!
+!
+!  initialize arrays
+!
+   do i = its,ite
+     rain(i)     = 0.0
+     kbot(i)   = kte+1
+     ktop(i)   = 0
+     kuo(i)    = 0
+     cnvflg(i) = .true.
+     dtconv(i) = 3600.
+     pdot(i)   = 0.0
+     edto(i)   = 0.0
+     edtx(i)   = 0.0
+     xmbmax(i) = 0.3
+     excess(i) = 0.0
+     plcl(i)   = 0.0
+     kpbl(i)   = 1
+     aa2(i) = 0.0
+     qlko_ktcon(i) = 0.0
+     pbcdif(i)= 0.0
+     lmin(i) = 1
+     jmin(i) = 1
+     edt(i) = 0.0
+   enddo
+!
+   do k = 1,15
+     acrit(k) = acritt(k) * (975. - pcrit(k))
+   enddo
+!
+! Define top layer for search of the downdraft originating layer
+! and the maximum thetae for updraft
+!
+   kbmax = kte
+   kbm   = kte
+   kmax  = kte
+   do k = kts,kte
+     do i = its,ite
+       if(prsl(i,k).gt.prsi(i,1)*0.45) kbmax = k + 1
+       if(prsl(i,k).gt.prsi(i,1)*0.70) kbm   = k + 1
+       if(prsl(i,k).gt.prsi(i,1)*0.04) kmax  = k + 1
+     enddo
+   enddo
+   kmax = min(kmax,kte)
+   kmax1 = kmax - 1
+   kbm = min(kbm,kte)
+!
+! convert surface pressure to mb from cb
+!
+   do k = kts,kte
+     do i = its,ite
+       pwo(i,k)  = 0.0
+       pwdo(i,k) = 0.0
+       dellal(i,k) = 0.0
+       hcko(i,k) = 0.0
+       qcko(i,k) = 0.0
+       hcdo(i,k) = 0.0
+       qcdo(i,k) = 0.0
+     enddo
+   enddo
+!
+   do k = kts,kmax
+     do i = its,ite
+       p(i,k) = prsl(i,k) * 10.
+       pwo(i,k) = 0.0
+       pwdo(i,k) = 0.0
+       to(i,k) = t1(i,k)
+       qo(i,k) = q1(i,k)
+       dbyo(i,k) = 0.0
+       fent1(i,k) = 1.0
+       fent2(i,k) = 1.0
+       frh(i,k) = 0.0
+       ucko(i,k) = 0.0
+       vcko(i,k) = 0.0
+       ucdo(i,k) = 0.0
+       vcdo(i,k) = 0.0
+       uo(i,k) = u1(i,k) * rcs
+       vo(i,k) = v1(i,k) * rcs
+     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 = kts,kmax
+     do i = its,ite
+       qeso(i,k)=0.01*fpvs(to(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+       qeso(i,k) = eps * qeso(i,k) / (p(i,k) + (eps-1.) * qeso(i,k))
+       qeso(i,k) = max(qeso(i,k),qmin_)
+       qo(i,k)   = max(qo(i,k), 1.e-10 )
+       tvo(i,k)  = to(i,k) + fv_ * to(i,k) * max(qo(i,k),qmin_)
+     enddo
+   enddo
+!
+! compute moist static energy
+!
+   do k = kts,kmax
+     do i = its,ite
+       heo(i,k)  = g_ * zl(i,k) + cp_* to(i,k) + hvap_ * qo(i,k)
+       heso(i,k) = g_ * zl(i,k) + cp_* to(i,k) + hvap_ * qeso(i,k)
+     enddo
+   enddo
+!
+! Determine level with largest moist static energy
+! This is the level where updraft starts
+!
+   do i = its,ite
+     hmax(i) = heo(i,1)
+     kb(i) = 1
+   enddo
+!
+   do k = kts1,kbm
+     do i = its,ite
+       if(heo(i,k).gt.hmax(i)) then
+         kb(i) = k
+         hmax(i) = heo(i,k)
+       endif
+     enddo
+   enddo
+!
+   do k = kts,kmax1
+     do i = its,ite
+       if(cnvflg(i)) then
+         dz = .5 * (zl(i,k+1) - zl(i,k))
+         dp = .5 * (p(i,k+1) - p(i,k))
+         es = 0.01*fpvs(to(i,k+1),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+         pprime = p(i,k+1) + (eps-1.) * es
+         qs = eps * es / pprime
+         dqsdp = - qs / pprime
+         desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
+         dqsdt = qs * p(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 = .5 * (p(i,k) + p(i,k+1))
+         qeso(i,k)=0.01*fpvs(to(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+         qeso(i,k) = eps * qeso(i,k) / (po + (eps-1.) * qeso(i,k))
+         qeso(i,k) = max(qeso(i,k),qmin_)
+         qo(i,k)   = max(qo(i,k), 1.e-10)
+         frh(i,k)  = 1. - min(qo(i,k)/qeso(i,k), 1.)
+         heo(i,k)  = .5 * g_ * (zl(i,k) + zl(i,k+1)) +                          &
+                cp_ * to(i,k) + hvap_ * qo(i,k)
+         heso(i,k) = .5 * g_ * (zl(i,k) + zl(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
+!
+! look for convective cloud base as the level of free convection
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       indx = kb(i)
+       hkbo(i) = heo(i,indx)
+       qkbo(i) = qo(i,indx)
+     endif
+   enddo
+!
+   do i = its,ite
+     flg(i) = cnvflg(i)
+     kbcon(i) = kmax
+   enddo
+!
+     do k = kts,kbmax
+       do i = its,ite
+         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
+       enddo
+     enddo
+     do i = its,ite
+       if(kbcon(i).eq.kmax) cnvflg(i) = .false.
+     enddo
+!
+     totflg = .true.
+     do i = its,ite
+       totflg = totflg .and. (.not. cnvflg(i))
+     enddo
+     if(totflg) return
+!
+     do i = its,ite
+       if(cnvflg(i)) then
+!
+!  determine critical convective inhibition
+!  as a function of vertical velocity at cloud base.
+!
+          pdot(i)  = 10.* dot(i,kbcon(i))
+          if(slimsk(i).eq.1.) then
+            w1 = w1l
+            w2 = w2l
+            w3 = w3l
+            w4 = w4l
+          else
+            w1 = w1s
+            w2 = w2s
+            w3 = w3s
+            w4 = w4s
+          endif
+          if(pdot(i).le.w4) then
+            tem = (pdot(i) - w4) / (w3 - w4)
+          elseif(pdot(i).ge.-w4) then
+            tem = - (pdot(i) + w4) / (w4 - w3)
+          else
+            tem = 0.
+          endif
+          tem = max(tem,-1.)
+          tem = min(tem,1.)
+          tem = 1. - tem
+          tem1= .5*(cincrmax-cincrmin)
+          cincr = cincrmax - tem * tem1
+         pbcdif(i) = -p(i,kbcon(i)) + p(i,kb(i))
+         if(pbcdif(i).gt.cincr) cnvflg(i) = .false.
+       endif
+     enddo
+!
+!
+   totflg = .true.
+   do i = its,ite
+     totflg = totflg .and. (.not. cnvflg(i))
+   enddo
+   if(totflg) return
+!
+   do k = kts,kte1
+     do i = its,ite
+       xlamb(i,k) = clam / zi(i,k+1) 
+     enddo
+   enddo
+!
+!  assume that updraft entrainment rate above cloud base is
+!  same as that at cloud base
+!
+   do k = kts1,kmax1
+     do i = its,ite
+       if(cnvflg(i).and.(k.gt.kbcon(i))) then
+         xlamb(i,k) = xlamb(i,kbcon(i))
+       endif
+     enddo
+   enddo
+!
+!   assume the detrainment rate for the updrafts to be same as
+!   the entrainment rate at cloud base
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       xlamud(i) = xlamb(i,kbcon(i))
+     endif
+   enddo
+!
+!  functions rapidly decreasing with height, mimicking a cloud ensemble
+!    (Bechtold et al., 2008)
+!
+   do k = kts1,kmax1
+     do i = its,ite
+       if(cnvflg(i).and.(k.gt.kbcon(i))) then
+         tem = qeso(i,k)/qeso(i,kbcon(i))
+         fent1(i,k) = tem**2
+         fent2(i,k) = tem**3
+       endif
+     enddo
+   enddo
+!
+!  final entrainment rate as the sum of turbulent part and organized entrainment
+!    depending on the environmental relative humidity
+!    (Bechtold et al., 2008)
+!
+   do k = kts1,kmax1
+     do i = its,ite
+       if(cnvflg(i).and.(k.ge.kbcon(i))) then
+          tem = cxlamu * frh(i,k) * fent2(i,k)
+          xlamb(i,k) = xlamb(i,k)*fent1(i,k) + tem
+       endif
+     enddo
+   enddo
+!
+! determine updraft mass flux
+!
+   do k = kts,kte
+     do i = its,ite
+      if(cnvflg(i)) then
+         eta(i,k) = 1.
+       endif
+     enddo
+   enddo
+!
+   do k = kbmax,kts1,-1
+     do i = its,ite
+       if(cnvflg(i).and.k.lt.kbcon(i).and.k.ge.kb(i)) then
+         dz = zi(i,k+2) - zi(i,k+1)
+         ptem     = 0.5*(xlamb(i,k)+xlamb(i,k+1))-xlamud(i)
+         eta(i,k) = eta(i,k+1) / (1. + ptem * dz)
+       endif
+     enddo
+   enddo
+  do k = kts1,kmax1
+     do i = its,ite
+       if(cnvflg(i).and.k.gt.kbcon(i)) then
+         dz  = zi(i,k+1) - zi(i,k)
+         ptem = 0.5*(xlamb(i,k)+xlamb(i,k-1))-xlamud(i)
+         eta(i,k) = eta(i,k-1) * (1 + ptem * dz)
+       endif
+     enddo
+   enddo
+   do i = its,ite
+     if(cnvflg(i)) then
+       dz = zi(i,3) - zi(i,2)
+       ptem     = 0.5*(xlamb(i,1)+xlamb(i,2))-xlamud(i)
+       eta(i,1) = eta(i,2) / (1. + ptem * dz)
+     endif
+   enddo
+!
+! work up updraft cloud properties
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       indx = kb(i)
+       hcko(i,indx) = hkbo(i)
+       qcko(i,indx) = qkbo(i)
+       ucko(i,indx) = uo(i,indx)
+       vcko(i,indx) = vo(i,indx)
+       pwavo(i) = 0.
+     endif
+   enddo
+!
+! cloud property below cloud base is modified by the entrainment proces
+!
+   do k = kts1,kmax1
+     do i = its,ite
+       if(cnvflg(i).and.k.gt.kb(i)) then
+         dz   = zi(i,k+1) - zi(i,k)
+         tem  = 0.5 * (xlamb(i,k)+xlamb(i,k-1)) * dz
+         tem1 = 0.5 * xlamud(i) * dz
+         factor = 1. + tem - tem1
+         ptem = 0.5 * tem + pgcon
+         ptem1= 0.5 * tem - pgcon
+         hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*                          &
+                     (heo(i,k)+heo(i,k-1)))/factor
+         ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k)                      &
+                     +ptem1*uo(i,k-1))/factor
+         vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k)                      &
+                     +ptem1*vo(i,k-1))/factor
+         dbyo(i,k) = hcko(i,k) - heso(i,k)
+       endif
+     enddo
+   enddo
+!
+!   taking account into convection inhibition due to existence of
+!    dry layers below cloud base
+!
+   do i = its,ite
+     flg(i) = cnvflg(i)
+     kbcon1(i) = kmax
+   enddo
+!
+   do k = kts1,kmax
+     do i = its,ite
+       if(flg(i).and.k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then
+         kbcon1(i) = k
+         flg(i) = .false.
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       if(kbcon1(i).eq.kmax) cnvflg(i) = .false.
+     endif
+   enddo
+!
+   do i =its,ite
+     if(cnvflg(i)) then
+       tem = p(i,kbcon(i)) - p(i,kbcon1(i))
+       if(tem.gt.dthk) then
+          cnvflg(i) = .false.
+       endif
+     endif
+   enddo
+!
+   totflg = .true.
+   do i = its,ite
+     totflg = totflg .and. (.not. cnvflg(i))
+   enddo
+   if(totflg) return
+!
+!
+!  determine cloud top
+!
+!
+   do i = its,ite
+     flg(i) = cnvflg(i)
+     ktcon(i) = 1
+   enddo
+!
+!   check inversion
+!
+   do k = kts1,kmax1
+     do i = its,ite
+       if(dbyo(i,k).lt.0..and.flg(i).and.k.gt. kbcon1(i)) then
+         ktcon(i) = k
+         flg(i)   = .false.
+       endif
+     enddo
+   enddo
+!
+!
+! check cloud depth
+!
+   do i = its,ite
+     if(cnvflg(i).and.(p(i,kbcon(i)) - p(i,ktcon(i))).lt.150.)                 &
+            cnvflg(i) = .false.
+   enddo
+!
+   totflg = .true.
+   do i = its,ite
+     totflg = totflg .and. (.not. cnvflg(i))
+   enddo
+   if(totflg) return
+!
+!
+!  search for downdraft originating level above theta-e minimum
+!
+   do i = its,ite 
+     if(cnvflg(i)) then
+       hmin(i) = heo(i,kbcon1(i))
+       lmin(i) = kbmax
+       jmin(i) = kbmax
+    endif
+   enddo
+!
+   do k = kts1,kbmax 
+     do i = its,ite 
+       if(cnvflg(i).and.k.gt.kbcon1(i).and.heo(i,k).lt.hmin(i)) then
+         lmin(i) = k + 1
+         hmin(i) = heo(i,k)
+       endif
+     enddo
+   enddo
+!
+! make sure that jmin is within the cloud
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       jmin(i) = min(lmin(i),ktcon(i)-1)
+       jmin(i) = max(jmin(i),kbcon1(i)+1)
+       if(jmin(i).ge.ktcon(i)) cnvflg(i) = .false.
+     endif
+   enddo
+!
+!  specify upper limit of mass flux at cloud base
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       k = kbcon(i)
+       dp = 1000. * del(i,k)
+       xmbmax(i) = dp / (g_ * dt2)
+     endif
+   enddo
+!
+!
+! compute cloud moisture property and precipitation
+!
+   do i = its,ite
+     aa1(i) = 0.
+   enddo
+!
+   do k = kts1,kmax
+     do i = its,ite
+       if(cnvflg(i).and.k.gt.kb(i).and.k.lt.ktcon(i)) then
+         dz = .5 * (zl(i,k+1) - zl(i,k-1))
+         dz1 = (zi(i,k+1) - zi(i,k))
+         gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+         qrch = qeso(i,k)                                                      &
+              + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
+         tem  = 0.5 * (xlamb(i,k)+xlamb(i,k-1)) * dz1
+         tem1 = 0.5 * xlamud(i) * dz1
+         factor = 1. + tem - tem1
+         qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*                           & 
+                    (qo(i,k)+qo(i,k-1)))/factor
+         qcirs(i,k) = eta(i,k) * qcko(i,k) - eta(i,k) * qrch
+!
+! check if there is excess moisture to release latent heat
+!
+         if(qcirs(i,k).gt.0. .and. k.ge.kbcon(i)) then
+           etah = .5 * (eta(i,k) + eta(i,k-1))
+           if(ncloud.gt.0..and.k.gt.jmin(i)) then
+             dp = 1000. * del(i,k)
+             qlk = qcirs(i,k) / (eta(i,k) + etah * (c0 + c1) * dz1)
+             dellal(i,k) = etah * c1 * dz1 * qlk * g_ / dp
+           else
+             qlk = qcirs(i,k) / (eta(i,k) + etah * c0 * dz1)
+           endif
+	   aa1(i) = aa1(i) - dz1 * g_ * qlk
+           qc = qlk + qrch
+           pwo(i,k) = etah * c0 * dz1 * qlk
+           qcko(i,k) = qc
+           pwavo(i) = pwavo(i) + pwo(i,k)
+         endif
+       endif
+     enddo
+   enddo
+!
+! calculate cloud work function at t+dt
+!
+   do k = kts1,kmax 
+     do i = its,ite 
+       if(cnvflg(i).and.k.ge.kbcon(i).and.k.lt.ktcon(i)) then
+         dz1 = zl(i,k+1) - zl(i,k)
+         gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+         rfact =  1. + fv_ * cp_ * gamma* to(i,k) / hvap_
+         aa1(i) = aa1(i) +dz1 * (g_ / (cp_ * to(i,k)))                         &
+                  * dbyo(i,k) / (1. + gamma)* rfact
+         aa1(i) = aa1(i)+dz1 * g_ * fv_ *                                      &
+                  max(0.,(qeso(i,k) - qo(i,k)))
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
+   enddo
+!
+      totflg = .true.
+      do i=its,ite
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!
+!    estimate the convective overshooting as the level
+!    where the [aafac * cloud work function] becomes zero,
+!    which is the final cloud top
+!
+      do i = its,ite
+        if (cnvflg(i)) then
+          aa2(i) = aafac * aa1(i)
+        endif
+      enddo
+!
+      do i = its,ite
+        flg(i) = cnvflg(i)
+        ktcon1(i) = kmax1
+      enddo
+!
+      do k = kts1, kmax
+        do i = its, ite
+          if (flg(i)) then
+            if(k.ge.ktcon(i).and.k.lt.kmax) then
+              dz1 = zl(i,k+1) - zl(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + fv_ * cp_ * gamma* to(i,k) / hvap_
+              aa2(i) = aa2(i) +dz1 * (g_ / (cp_ * to(i,k)))                    &
+                       * dbyo(i,k) / (1. + gamma)* rfact
+              if(aa2(i).lt.0.) then
+                ktcon1(i) = k
+                flg(i) = .false.
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!
+!  compute cloud moisture property, detraining cloud water
+!  and precipitation in overshooting layers
+!
+   do k = kts1,kmax
+     do i = its,ite
+       if (cnvflg(i)) then
+         if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then
+           dz = (zi(i,k+1) - zi(i,k))
+           gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+           qrch = qeso(i,k)+ gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
+           tem  = 0.5 * (xlamb(i,k)+xlamb(i,k-1)) * dz
+           tem1 = 0.5 * xlamud(i) * dz
+           factor = 1. + tem - tem1
+           qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*                         & 
+                      (qo(i,k)+qo(i,k-1)))/factor
+           qcirs(i,k) = eta(i,k) * qcko(i,k) - eta(i,k) * qrch
+!
+!  check if there is excess moisture to release latent heat
+!
+           if(qcirs(i,k).gt.0.) then
+             etah = .5 * (eta(i,k) + eta(i,k-1))
+             if(ncloud.gt.0.) then
+               dp = 1000. * del(i,k)
+               qlk = qcirs(i,k) / (eta(i,k) + etah * (c0 + c1) * dz)
+               dellal(i,k) = etah * c1 * dz * qlk * g_ / dp
+             else
+               qlk = qcirs(i,k) / (eta(i,k) + etah * c0 * dz)
+             endif
+             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
+!
+! exchange ktcon with ktcon1
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       kk = ktcon(i)
+       ktcon(i) = ktcon1(i)
+       ktcon1(i) = kk
+     endif
+   enddo
+!
+! this section is ready for cloud water
+!
+   if (ncloud.gt.0) then
+!
+!  compute liquid and vapor separation at cloud top
+! 
+   do i = its,ite
+     if(cnvflg(i)) then
+     k = ktcon(i)-1
+       gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+       qrch = qeso(i,k)                                                     &
+              + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
+       dq = qcko(i,k) - qrch
+!
+!  check if there is excess moisture to release latent heat
+!
+       if(dq.gt.0.) then
+         qlko_ktcon(i) = dq
+         qcko(i,k) = qrch
+       endif
+     endif
+   enddo
+   endif
+!
+! ..... downdraft calculations .....
+!
+! determine downdraft strength in terms of wind shear
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       vshear(i) = 0.
+     endif
+   enddo
+!
+   do k = kts1,kmax
+     do i = its,ite
+       if(k.gt.kb(i).and.k.le.ktcon(i).and.cnvflg(i)) then
+         shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2                                  & 
+                       + (vo(i,k)-vo(i,k-1)) ** 2)
+         vshear(i) = vshear(i) + shear
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i)+1)-zi(i,kb(i)+1))
+       e1 = 1.591-.639*vshear(i)                                               &
+           +.0953*(vshear(i)**2)-.00496*(vshear(i)**3)
+       edt(i)  = 1.-e1
+       edt(i)  = min(edt(i),.9)
+       edt(i)  = max(edt(i),.0)
+       edto(i) = edt(i)
+       edtx(i) = edt(i)
+     endif
+   enddo
+!
+! determine detrainment rate between 1 and kbdtr
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       sumx(i) = 0.
+     endif
+   enddo
+!
+   do k = kts,kmax1
+     do i = its,ite
+       if(cnvflg(i).and.k.ge.1.and.k.lt.kbcon(i)) then
+         dz = zi(i,k+2) - zi(i,k+1)
+         sumx(i) = sumx(i) + dz
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     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)
+       dz =(sumx(i)+zi(i,2))/float(kbcon(i))
+       tem = 1./float(kbcon(i))
+       xlamd(i) = (1.-beta**tem)/dz
+     endif
+   enddo
+!
+! determine downdraft mass flux
+!
+   do k = kts,kmax
+     do i = its,ite
+       if(cnvflg(i)) then
+         etad(i,k) = 1.
+       endif
+       qrcdo(i,k) = 0.
+       qrcd(i,k) = 0.
+     enddo
+   enddo
+!
+   do k = kmax1,kts,-1
+     do i = its,ite
+       if(cnvflg(i)) then
+         if(k.lt.jmin(i).and.k.ge.kbcon(i))then
+           dz = (zi(i,k+2) - zi(i,k+1))
+           ptem = xlamdd-xlamde
+           etad(i,k) = etad(i,k+1) * (1.-ptem * dz)
+         elseif(k.lt.kbcon(i))then
+           dz = (zi(i,k+2) - zi(i,k+1))
+           ptem = xlamd(i)+xlamdd-xlamde
+           etad(i,k) = etad(i,k+1) * (1.-ptem * dz)
+         endif
+       endif
+     enddo
+   enddo
+!
+!
+! downdraft moisture properties
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+      pwevo(i) = 0.
+     endif
+   enddo
+!
+   do i = its,ite
+     if(cnvflg(i))  then 
+       jmn = jmin(i)
+       hcdo(i,jmn) = heo(i,jmn)
+       qcdo(i,jmn) = qo(i,jmn)
+       qrcdo(i,jmn) = qeso(i,jmn)
+       ucdo(i,jmn) = uo(i,jmn)
+       vcdo(i,jmn) = vo(i,jmn)
+     endif
+   enddo
+!
+   do k = kmax1,kts,-1 
+     do i = its,ite 
+       if (cnvflg(i) .and. k.lt.jmin(i)) then
+         dz = zi(i,k+2) - zi(i,k+1)
+         if(k.ge.kbcon(i)) then
+           tem  = xlamde * dz
+           tem1 = 0.5 * xlamdd * dz
+         else
+           tem  = xlamde * dz
+           tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+          endif
+          factor = 1. + tem - tem1
+          ptem = 0.5 * tem - pgcon
+          ptem1= 0.5 * tem + pgcon
+          hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5*                     & 
+                      (heo(i,k)+heo(i,k+1)))/factor
+          ucdo(i,k) = ((1.-tem1)*ucdo(i,k+1)+ptem*uo(i,k+1)               & 
+                     +ptem1*uo(i,k))/factor
+          vcdo(i,k) = ((1.-tem1)*vcdo(i,k+1)+ptem*vo(i,k+1)               & 
+                     +ptem1*vo(i,k))/factor
+          dbyo(i,k) = hcdo(i,k) - heso(i,k)
+       endif
+     enddo
+   enddo
+!
+   do k = kmax1,kts,-1
+     do i = its,ite
+       if(cnvflg(i).and.k.lt.jmin(i)) then
+         dq = qeso(i,k)
+         dt = to(i,k)
+         gamma = el2orc * dq / dt**2
+         qrcdo(i,k)=dq+(1./hvap_)*(gamma/(1.+gamma))*dbyo(i,k)
+         detad = etad(i,k+1) - etad(i,k)
+         dz = zi(i,k+2) - zi(i,k+1)
+         if(k.ge.kbcon(i)) then
+            tem  = xlamde * dz
+            tem1 = 0.5 * xlamdd * dz
+         else
+            tem  = xlamde * dz
+            tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+         endif
+         factor = 1. + tem - tem1
+         qcdo(i,k) = ((1.-tem1)*qcdo(i,k+1)+tem*0.5*                      & 
+                     (qo(i,k)+qo(i,k+1)))/factor
+         pwdo(i,k) = etad(i,k+1) * qcdo(i,k) -etad(i,k+1) * qrcdo(i,k)
+         qcdo(i,k) = qrcdo(i,k)
+         pwevo(i) = pwevo(i) + pwdo(i,k)
+       endif
+     enddo
+   enddo
+!
+! final downdraft strength dependent on precip
+! efficiency (edt), normalized condensate (pwav), and
+! evaporate (pwev)
+!
+   do i = its,ite
+     edtmax = edtmaxl
+     if(slimsk(i).eq.2.) edtmax = edtmaxs
+     if(cnvflg(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
+     endif
+   enddo
+!
+! downdraft cloudwork functions
+!
+   do k = kmax1,kts,-1
+     do i = its,ite
+       if(cnvflg(i).and.k.lt.jmin(i)) then
+         gamma = el2orc * qeso(i,k) / to(i,k)**2
+         dhh=hcdo(i,k)
+         dt=to(i,k)
+         dg=gamma
+         dh=heso(i,k)
+         dz=-1.*(zl(i,k+1)-zl(i,k))
+         aa1(i)=aa1(i)+edto(i)*dz*(g_/(cp_*dt))*((dhh-dh)/(1.+dg))             &
+                *(1.+fv_*cp_*dg*dt/hvap_)
+         aa1(i)=aa1(i)+edto(i)*dz*g_*fv_*max(0.,(qeso(i,k)-qo(i,k)))
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
+   enddo
+!
+   totflg = .true.
+   do i=its,ite
+     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 = kts,kmax
+     do i = its,ite
+       if(cnvflg(i)) then
+         dellah(i,k) = 0.
+         dellaq(i,k) = 0.
+         dellau(i,k) = 0.
+         dellav(i,k) = 0.
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       dp = 1000. * del(i,1)
+       dellah(i,1) = edto(i) * etad(i,1) * (hcdo(i,1)                          &
+                   - heo(i,1)) * g_ / dp
+       dellaq(i,1) = edto(i) * etad(i,1) * (qcdo(i,1)                          &
+                   - qo(i,1)) * g_ / dp
+       dellau(i,1) = edto(i) * etad(i,1) * (ucdo(i,1)                          &
+                   - uo(i,1)) * g_ / dp
+       dellav(i,1) = edto(i) * etad(i,1) * (vcdo(i,1)                          &
+                   - vo(i,1)) * g_ / dp
+     endif
+   enddo
+!
+! changed due to subsidence and entrainment
+!
+   do k = kts1,kmax1
+     do i = its,ite
+       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 = zi(i,k+1) - zi(i,k)
+         tem  = 0.5 * (xlamb(i,k)+xlamb(i,k-1))
+         tem1 = xlamud(i)
+         if(k.le.kbcon(i)) then
+           ptem  = xlamde
+           ptem1 = xlamd(i)+xlamdd
+         else
+           ptem  = xlamde
+           ptem1 = xlamdd
+         endif
+         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*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2*dz              & 
+         +  aup*tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz                  & 
+         +  adw*edto(i)*ptem1*etad(i,k)*.5*(hcdo(i,k)+hcdo(i,k-1))*dz) *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*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2q*dz             & 
+         +  aup*tem1*eta(i,k-1)*.5*(qcko(i,k)+qcko(i,k-1))*dz                  & 
+         +  adw*edto(i)*ptem1*etad(i,k)*.5*(qrcdo(i,k)+qrcdo(i,k-1))*dz) *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*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2u*dz             & 
+         +  aup*tem1*eta(i,k-1)*.5*(ucko(i,k)+ucko(i,k-1))*dz                  & 
+         +  adw*edto(i)*ptem1*etad(i,k)*.5*(ucdo(i,k)+ucdo(i,k-1))*dz          & 
+         -  pgcon*(aup*eta(i,k-1)-adw*edto(i)*etad(i,k))*(dv1u-dv3u))*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*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2v*dz             & 
+         +  aup*tem1*eta(i,k-1)*.5*(vcko(i,k)+vcko(i,k-1))*dz                  & 
+         +  adw*edto(i)*ptem1*etad(i,k)*.5*(vcdo(i,k)+vcdo(i,k-1))*dz          & 
+         -  pgcon*(aup*eta(i,k-1)-adw*edto(i)*etad(i,k))*(dv1v-dv3v))*g_/dp
+       endif
+     enddo
+   enddo
+!
+! cloud top
+!
+   do i = its,ite
+     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,indx) = eta(i,indx-1) * qlko_ktcon(i) * g_ / dp
+     endif
+   enddo
+!
+! final changed variable per unit mass flux
+!
+   do k = kts,kmax
+     do i = its,ite
+       if(cnvflg(i).and.k.gt.ktcon(i)) then
+         qo(i,k) = q1(i,k)
+         to(i,k) = t1(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)
+         qo(i,k) = max(qo(i,k),1.0e-10)
+       endif
+     enddo
+   enddo
+!
+!------------------------------------------------------------------------------
+!
+! the above changed environment is now used to calulate the
+! effect the arbitrary cloud (with unit mass flux)
+! 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
+!
+!------------------------------------------------------------------------------
+!
+   do k = kts,kmax
+     do i = its,ite
+       if(cnvflg(i)) then
+         qeso(i,k)=0.01* fpvs(to(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+         qeso(i,k) = eps * qeso(i,k) / (p(i,k) + (eps-1.) * qeso(i,k))
+         qeso(i,k) = max(qeso(i,k),qmin_)
+         tvo(i,k)  = to(i,k) + fv_ * to(i,k) * max(qo(i,k),qmin_)
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       xaa0(i) = 0.
+       xpwav(i) = 0.
+     endif
+   enddo
+!
+! moist static energy
+!
+   do k = kts,kmax1
+     do i = its,ite
+       if(cnvflg(i)) then
+         dz = .5 * (zl(i,k+1) - zl(i,k))
+         dp = .5 * (p(i,k+1) - p(i,k))
+         es =0.01*fpvs(to(i,k+1),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+         pprime = p(i,k+1) + (eps-1.) * es
+         qs = eps * es / pprime
+         dqsdp = - qs / pprime
+         desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
+         dqsdt = qs * p(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 = .5 * (p(i,k) + p(i,k+1))
+         qeso(i,k) =0.01* fpvs(to(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+         qeso(i,k) = eps * qeso(i,k) / (po + (eps-1.) * qeso(i,k))
+         qeso(i,k) = max(qeso(i,k),qmin_)
+         qo(i,k)   = max(qo(i,k), 1.0e-10)
+         heo(i,k) = .5 * g_ * (zl(i,k) + zl(i,k+1)) +                          &
+                     cp_ * to(i,k) + hvap_ * qo(i,k)
+         heso(i,k) = .5 * g_ * (zl(i,k) + zl(i,k+1)) +                         &
+                     cp_ * to(i,k) + hvap_ * qeso(i,k)
+       endif
+     enddo
+   enddo
+!
+   k = kmax
+   do i = its,ite
+     if(cnvflg(i)) then
+       heo(i,k)  = g_ * zl(i,k) + cp_ * to(i,k) + hvap_ * qo(i,k)
+       heso(i,k) = g_ * zl(i,k) + cp_ * to(i,k) + hvap_ * qeso(i,k)
+     endif
+   enddo
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       xaa0(i) = 0.
+       xpwav(i) = 0.
+       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 = kts1,kmax1
+     do i = its,ite
+       if(cnvflg(i).and.k.gt.kb(i).and.k.le.ktcon(i)) then
+         dz = zi(i,k+1) - zi(i,k)
+         tem  = 0.5 * (xlamb(i,k)+xlamb(i,k-1)) * dz
+         tem1 = 0.5 * xlamud(i) * dz
+         factor = 1. + tem - tem1
+         hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*                         & 
+                    (heo(i,k)+heo(i,k-1)))/factor
+       endif
+     enddo
+   enddo
+!
+   do k = kts1,kmax1
+     do i = its,ite
+       if(cnvflg(i).and.k.gt.kb(i).and.k.lt.ktcon(i)) then
+         dz = zi(i,k+1) - zi(i,k)
+         gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+         xdby = hcko(i,k) - heso(i,k)
+         xqrch = qeso(i,k)                                                     &
+              + gamma * xdby / (hvap_ * (1. + gamma))
+         tem  = 0.5 * (xlamb(i,k)+xlamb(i,k-1)) * dz
+         tem1 = 0.5 * xlamud(i) * dz
+         factor = 1. + tem - tem1
+         qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*(qo(i,k)+qo(i,k-1)))/factor
+         dq = eta(i,k) * qcko(i,k) - eta(i,k) * xqrch
+         if(k.ge.kbcon(i).and.dq.gt.0.) then
+           etah = .5 * (eta(i,k) + eta(i,k-1))
+           if(ncloud.gt.0..and.k.gt.jmin(i)) then
+             qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+           else
+             qlk = dq / (eta(i,k) + etah * c0 * dz)
+           endif
+           if(k.lt.ktcon1(i)) then
+             xaa0(i) = xaa0(i) - dz * g_ * qlk
+           endif
+           qcko(i,k) = qlk + xqrch
+           xpw = etah * c0 * dz * qlk
+           xpwav(i) = xpwav(i) + xpw
+         endif
+       endif
+       if(cnvflg(i).and.k.ge.kbcon(i).and.k.lt.ktcon1(i)) then
+         dz1 = zl(i,k+1) - zl(i,k)
+         gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+         rfact =  1. + fv_ * cp_ * gamma                                       &
+                  * to(i,k) / hvap_
+         xdby = hcko(i,k) - heso(i,k)
+         xaa0(i) = xaa0(i)                                                     &
+                 + dz1 * (g_ / (cp_ * to(i,k)))                                &
+                 * xdby / (1. + gamma)                                         &
+                 * rfact
+         xaa0(i)=xaa0(i)+                                                      &
+                  dz1 * g_ * fv_ *                                             &
+                  max(0.,(qeso(i,k) - qo(i,k)))
+       endif
+     enddo
+   enddo
+!
+! ..... downdraft calculations .....
+!
+!
+! downdraft moisture properties
+!
+   do i = its,ite
+     xpwev(i) = 0.
+   enddo
+   do i = its,ite
+     if(cnvflg(i)) then
+       jmn = jmin(i)
+       xhcd(i,jmn) = heo(i,jmn)
+       xqcd(i,jmn) = qo(i,jmn)
+       qrcd(i,jmn) = qeso(i,jmn)
+     endif
+   enddo
+!
+   do k = kmax1,kts, -1
+     do i = its,ite
+       if(cnvflg(i).and.k.lt.jmin(i)) then
+         dz = zi(i,k+2) - zi(i,k+1)
+         if(k.ge.kbcon(i)) then
+            tem  = xlamde * dz
+            tem1 = 0.5 * xlamdd * dz
+         else
+            tem  = xlamde * dz
+            tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+         endif
+         factor = 1. + tem - tem1
+         xhcd(i,k) = ((1.-tem1)*xhcd(i,k+1)+tem*0.5*                        & 
+                    (heo(i,k)+heo(i,k+1)))/factor
+       endif
+     enddo
+   enddo
+!
+   do k = kmax1,kts, -1
+     do i = its,ite
+       if(cnvflg(i).and.k.lt.jmin(i)) then
+         dq = qeso(i,k)
+         dt = to(i,k)
+         gamma = el2orc * dq / dt**2
+         dh = xhcd(i,k) - heso(i,k)
+         qrcd(i,k)=dq+(1./hvap_)*(gamma/(1.+gamma))*dh
+         dz = zi(i,k+2) - zi(i,k+1)
+         if(k.ge.kbcon(i)) then
+           tem  = xlamde * dz
+           tem1 = 0.5 * xlamdd * dz
+         else
+           tem  = xlamde * dz
+           tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+         endif
+         factor = 1. + tem - tem1
+         xqcd(i,k) = ((1.-tem1)*xqcd(i,k+1)+tem*0.5*                           & 
+                   (qo(i,k)+qo(i,k+1)))/factor
+         xpwd     = etad(i,k+1) * (xqcd(i,k) - qrcd(i,k))
+         xqcd(i,k)= qrcd(i,k)
+         xpwev(i) = xpwev(i) + xpwd
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     edtmax = edtmaxl
+     if(slimsk(i).eq.2.) edtmax = edtmaxs
+     if(cnvflg(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
+     endif
+   enddo
+!
+! downdraft cloudwork functions
+!
+   do k = kmax1,kts, -1
+     do i = its,ite
+       if(cnvflg(i).and.k.lt.jmin(i)) then
+         gamma = el2orc * qeso(i,k) / to(i,k)**2
+         dhh=xhcd(i,k)
+         dt= to(i,k)
+         dg= gamma
+         dh= heso(i,k)
+         dz=-1.*(zl(i,k+1)-zl(i,k))
+         xaa0(i)=xaa0(i)+edtx(i)*dz*(g_/(cp_*dt))*((dhh-dh)/(1.+dg))           &
+                 *(1.+fv_*cp_*dg*dt/hvap_)
+         xaa0(i)=xaa0(i)+edtx(i)*                                              &
+                  dz*g_*fv_*max(0.,(qeso(i,k)-qo(i,k)))
+       endif
+     enddo
+   enddo
+!
+! calculate critical cloud work function
+!
+   do i = its,ite
+     acrt(i) = 0.
+     if(cnvflg(i)) then
+       if(p(i,ktcon(i)).lt.pcrit(15))then
+         acrt(i)=acrit(15)*(975.-p(i,ktcon(i)))/(975.-pcrit(15))
+       else if(p(i,ktcon(i)).gt.pcrit(1))then
+         acrt(i)=acrit(1)
+       else
+         k = int((850. - p(i,ktcon(i)))/50.) + 2
+         k = min(k,15)
+         k = max(k,2)
+         acrt(i)=acrit(k)+(acrit(k-1)-acrit(k))*                               &
+              (p(i,ktcon(i))-pcrit(k))/(pcrit(k-1)-pcrit(k))
+        endif
+      endif
+    enddo
+!
+   do i = its,ite
+     acrtfct(i) = 1.
+     w1 = w1s
+     w2 = w2s
+     w3 = w3s
+     w4 = w4s
+     if(slimsk(i).eq.1.) then
+       w1 = w1l
+       w2 = w2l
+       w3 = w3l
+       w4 = w4l
+     endif
+     if(cnvflg(i)) then
+       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
+       acrtfct(i) = max(acrtfct(i),-1.)
+       acrtfct(i) = min(acrtfct(i),1.)
+       acrtfct(i) = 1. - acrtfct(i)
+       dtconv(i) = dt2 + max((1800. - dt2),0.) * (pdot(i) - w2) / (w1 - w2)   
+       dtconv(i) = max(dtconv(i),dtmin)
+       dtconv(i) = min(dtconv(i),dtmax)
+!
+     endif
+   enddo
+!
+! large scale forcing
+!
+   do i= its,ite
+     if(cnvflg(i)) then
+       f(i) = (aa1(i) - acrt(i) * acrtfct(i)) / dtconv(i)
+       if(f(i).le.0.) cnvflg(i) = .false.
+     endif
+     if(cnvflg(i)) then
+       xk(i) = (xaa0(i) - aa1(i)) / mbdt
+       if(xk(i).ge.0.) cnvflg(i) = .false.
+     endif
+!
+! kernel, cloud base mass flux
+!
+     if(cnvflg(i)) then
+       xmb(i) = -f(i) / xk(i)
+       xmb(i) = min(xmb(i),xmbmax(i))
+     endif
+!
+     if(cnvflg(i)) then
+     endif
+!
+   enddo
+   totflg = .true.
+   do i = its,ite
+     totflg = totflg .and. (.not. cnvflg(i))
+   enddo
+   if(totflg) return
+!
+! restore t0 and qo to t1 and q1 in case convection stops
+!
+   do k = kts,kmax
+     do i = its,ite
+       if (cnvflg(i)) then
+       to(i,k) = t1(i,k)
+       qo(i,k) = q1(i,k)
+       uo(i,k) = u1(i,k)
+       vo(i,k) = v1(i,k)
+       qeso(i,k) = 0.01*fpvs(t1(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+       qeso(i,k) = eps * qeso(i,k) / (p(i,k) + (eps-1.) * qeso(i,k))
+       qeso(i,k) = max(qeso(i,k),qmin_)
+       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 = its,ite
+     delhbar(i) = 0.
+     delqbar(i) = 0.
+     deltbar(i) = 0.
+     qcond(i) = 0.
+     qrski(i) = 0.
+     delubar(i) = 0.
+     delvbar(i) = 0.
+   enddo
+!
+   do k = kts,kmax
+     do i = its,ite
+       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
+         tem=1./rcs
+         u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem
+         v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem 
+         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_
+         delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g_
+         delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g_
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+     endif
+   enddo
+!
+   do k = kts,kmax 
+     do i = its,ite 
+       if (cnvflg(i) .and. k.le.ktcon(i)) then
+         qeso(i,k)=0.01* fpvs(t1(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+         qeso(i,k) = eps * qeso(i,k)/(p(i,k) + (eps-1.)*qeso(i,k))
+         qeso(i,k) = max(qeso(i,k), qmin_ )
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite 
+     rntot(i) = 0.
+     delqev(i) = 0.
+     delq2(i) = 0.
+     flg(i) = cnvflg(i) 
+   enddo
+!
+!  comptute rainfall  
+!
+   do k = kmax,kts,-1
+     do i = its,ite
+       if(cnvflg(i).and.k.lt.ktcon(i)) then
+         aup = 1.
+         if(k.le.kb(i)) aup = 0.
+         adw = 1.
+         if(k.ge.jmin(i)) adw = 0.
+         rntot(i) = rntot(i)                                                   &
+               + (aup * pwo(i,k) + adw * edto(i) * pwdo(i,k))                  &
+               * xmb(i) * .001 * dt2
+       endif
+     enddo
+   enddo
+!
+!  conversion rainfall (m) and compute the evaporation of falling raindrops 
+!
+   do k = kmax,kts,-1
+     do i = its,ite
+       delq(i) = 0.0
+       deltv(i) = 0.0
+       qevap(i) = 0.0
+       if(cnvflg(i).and.k.lt.ktcon(i)) then
+         aup = 1.
+         if(k.le.kb(i)) aup = 0.
+         adw = 1.
+         if(k.ge.jmin(i)) adw = 0.
+         rain(i) = rain(i)                                                     &
+               + (aup * pwo(i,k) + adw * edto(i) * pwdo(i,k))                  &
+               * xmb(i) * .001 * dt2
+       endif
+       if(flg(i).and.k.lt.ktcon(i)) then
+         evef = edt(i) * evfacts
+         if(slimsk(i).eq.1.) evef = edt(i) * evfactl
+         qcond(i) = evef * (q1(i,k) - qeso(i,k)) / (1. + el2orc *              &
+                  qeso(i,k) / t1(i,k)**2)
+         dp = 1000. * del(i,k)
+         if(rain(i).gt.0..and.qcond(i).lt.0.) then
+           qevap(i) = -qcond(i) * (1. - exp(-.32 * sqrt(dt2 * rain(i))))
+           qevap(i) = min(qevap(i), rain(i)*1000.*g_/dp)
+           delq2(i) = delqev(i) + .001 * qevap(i) * dp / g_
+           if (delq2(i).gt.rntot(i)) then
+             qevap(i) = 1000.* g_ * (rntot(i) - delqev(i)) / dp
+             flg(i) = .false.
+           endif 
+         endif
+         if(rain(i).gt.0..and.qevap(i).gt.0.) then
+           q1(i,k) = q1(i,k) + qevap(i)
+           t1(i,k) = t1(i,k) - (hvap_/cp_) * qevap(i)
+           rain(i) = rain(i) - .001 * qevap(i) * dp / g_
+           delqev(i) = delqev(i) + .001*dp*qevap(i)/g_
+           deltv(i) =  - (hvap_/cp_)*qevap(i)/dt2
+           delq(i) =  + qevap(i)/dt2
+         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
+     enddo
+   enddo
+!
+!
+! consider the negative rain in the event of rain evaporation and downdrafts
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       if(rain(i).lt.0..and..not.flg(i)) rain(i) = 0.
+       if(rain(i).le.0.) then
+         rain(i) = 0.
+       else
+         ktop(i) = ktcon(i)
+         kbot(i) = kbcon(i)
+         kuo(i) = 1
+       endif
+     endif
+   enddo
+!
+   do k = kts,kmax
+     do i = its,ite
+       if(cnvflg(i).and.rain(i).le.0.) then
+          t1(i,k) = to(i,k)
+          q1(i,k) = qo(i,k)
+          u1(i,k) = uo(i,k)
+          v1(i,k) = vo(i,k)
+       endif
+     enddo
+   enddo
+!
+!  detrainment of cloud water and ice
+!
+   if (ncloud.gt.0) then
+     do k = kts,kmax 
+       do i = its,ite 
+         if (cnvflg(i) .and. rain(i).gt.0.) then
+           if (k.ge.kbcon(i).and.k.le.ktcon(i)) then
+             tem  = dellal(i,k) * xmb(i) * dt2
+             tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf))
+             if (ncloud.ge.4) then
+               qi2(i,k) = qi2(i,k) + tem * tem1            ! ice
+               qc2(i,k) = qc2(i,k) + tem *(1.0-tem1)       ! water
+             else
+               qc2(i,k) = qc2(i,k) + tem
+             endif
+           endif
+         endif
+       enddo
+     enddo
+   endif
+!
+   end subroutine nsas2d
+!===============================================================================
+      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
+!
+      if (t.lt.180.) then
+        tr=ttp/180.
+        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
+      endif
+!
+      if (t.ge.330.) then
+        tr=ttp/330
+        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
+      endif
+!
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+      END FUNCTION fpvs
+!===============================================================================
+   subroutine nsasinit(rthcuten,rqvcuten,rqccuten,rqicuten,                    &
+                      rucuten,rvcuten,                                         &  
+                      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,        &
+                                                               rucuten,        &
+                                                               rvcuten,        &
+                                                              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.
+       rucuten(i,k,j)=0.   
+       rvcuten(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 nsasinit
+!
+!==============================================================================
+! NCEP SCV (Shallow Convection Scheme)
+!==============================================================================
+   subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
+                 ncloud,qc2,qi2,q1,t1,rain,kbot,ktop,                          &
+                 kuo,                                                          &
+                 slimsk,dot,u1,v1,                                             &
+                 cp_,cliq_,cvap_,g_,hvap_,rd_,rv_,fv_,ep2,                     &
+                 cice,xls,psat,                                                &
+                 hpbl,hfx,qfx,                                                 &
+                 ids,ide, jds,jde, kds,kde,                                    &
+                 ims,ime, jms,jme, kms,kme,                                    &
+                 its,ite, jts,jte, kts,kte)
+!
+!-------------------------------------------------------------------------------
+!
+! subprogram:    nscv2d           computes shallow-convective heating and moisng
+!
+! abstract: computes non-precipitating convective heating and moistening 
+!   using a one cloud type arakawa-schubert convection scheme as in the ncep
+!   sas scheme. the scheme has been operational at ncep gfs model since july 2010
+!   the scheme includes updraft and downdraft effects, but the cloud depth is 
+!   limited less than 150 hpa. 
+!
+! developed by jong-il han and hua-lu pan 
+!   implemented into wrf by jiheon jang and songyou hong
+!   module with cpp-based options is available in grims
+!
+! program history log:
+!   10-07-01 jong-il han  initial operational implementation at ncep gfs
+!   10-12-01 jihyeon jang implemented into wrf
+!
+! subprograms called:
+!   fpvs     - function to compute saturation vapor pressure
+!
+! references:
+!   han and pan (2010, wea. forecasting)
+!   
+!-------------------------------------------------------------------------------
+   implicit none
+!-------------------------------------------------------------------------------
+!  in/out variables
+!
+   integer         ::  ids,ide, jds,jde, kds,kde,                              &
+                       ims,ime, jms,jme, kms,kme,                              &
+                       its,ite, jts,jte, kts,kte
+   real            ::  cp_,cliq_,cvap_,g_,hvap_,rd_,rv_,fv_,ep2
+   real            ::  pi_,qmin_,t0c_
+   real            ::  cice,xlv0,xls,psat
+!
+   real            ::  delt
+   real            ::  del(its:ite,kts:kte),                                   &
+                       prsl(its:ite,kts:kte),prslk(ims:ime,kms:kme),           &
+                       prsi(its:ite,kts:kte+1),zl(its:ite,kts:kte)
+   integer         ::  ncloud
+   real            ::  slimsk(ims:ime)
+   real            ::  dot(its:ite,kts:kte)
+   real            ::  hpbl(ims:ime)
+   real            ::  rcs
+   real            ::  hfx(ims:ime),qfx(ims:ime)
+!
+   real            ::  qi2(its:ite,kts:kte),qc2(its:ite,kts:kte)
+   real            ::  q1(its:ite,kts:kte),                                    &
+                       t1(its:ite,kts:kte),                                    &
+                       u1(its:ite,kts:kte),                                    &
+                       v1(its:ite,kts:kte)
+   integer         ::  kuo(its:ite)
+!
+   real            ::  rain(its:ite)
+   integer         ::  kbot(its:ite),ktop(its:ite)
+!
+!  local variables and arrays
+!
+   integer         ::  i,j,indx, jmn, k, kk, km1
+   integer         ::  kpbl(its:ite)
+!
+   real            ::  dellat,                                                 &
+                       desdt,   deta,    detad,   dg,                          &
+                       dh,      dhh,     dlnsig,  dp,                          &
+                       dq,      dqsdp,   dqsdt,   dt,                          &
+                       dt2,     dtmax,   dtmin,                                &
+                       dv1h,    dv2h,    dv3h,                                 &
+                       dv1q,    dv2q,    dv3q,                                 &
+                       dv1u,    dv2u,    dv3u,                                 &
+                       dv1v,    dv2v,    dv3v,                                 &
+                       dz,      dz1,     e1,      clam,                        &
+                       aafac,                                                  &
+                       es,      etah,                                          &
+                       evef,    evfact,  evfactl,                              &
+                       factor,  fjcap,                                         &
+                       gamma,   pprime,  betaw,                                &
+                       qlk,     qrch,    qs,                                   &
+                       rfact,   shear,   tem1,                                 &
+                       tem2,    val,     val1,                                 &
+                       val2,    w1,      w1l,     w1s,                         &
+                       w2,      w2l,     w2s,     w3,                          &
+                       w3l,     w3s,     w4,      w4l,                         &
+                       w4s,     tem,     ptem,    ptem1,                       &
+                       pgcon
+!
+   integer         ::  kb(its:ite), kbcon(its:ite), kbcon1(its:ite),           &
+                       ktcon(its:ite), ktcon1(its:ite),                        &
+                       kbm(its:ite), kmax(its:ite)
+!
+   real            ::  aa1(its:ite),                                           &
+                       delhbar(its:ite), delq(its:ite),                        &
+                       delq2(its:ite),   delqev(its:ite), rntot(its:ite),      &
+                       delqbar(its:ite), deltbar(its:ite),                     &
+                       deltv(its:ite),   edt(its:ite),                         &
+                       wstar(its:ite),   sflx(its:ite),                        &
+                       pdot(its:ite),    po(its:ite,kts:kte),                  &
+                       qcond(its:ite),   qevap(its:ite),  hmax(its:ite),       &
+                       vshear(its:ite),                                        &
+                       xlamud(its:ite),  xmb(its:ite),    xmbmax(its:ite)
+   real            ::  delubar(its:ite), delvbar(its:ite)
+!
+   real            ::  cincr
+!
+   real            ::  thx(its:ite, kts:kte)
+   real            ::  rhox(its:ite)
+   real            ::  tvcon
+!
+   real            ::  p(its:ite,kts:kte),       to(its:ite,kts:kte),          &
+                       qo(its:ite,kts:kte),      qeso(its:ite,kts:kte),        &
+                       uo(its:ite,kts:kte),      vo(its:ite,kts:kte)
+!
+!  cloud water
+!
+   real            ::  qlko_ktcon(its:ite),     dellal(its:ite,kts:kte),       &
+                       dbyo(its:ite,kts:kte),                                  &
+                       xlamue(its:ite,kts:kte),                                &
+                       heo(its:ite,kts:kte),    heso(its:ite,kts:kte),         &
+                       dellah(its:ite,kts:kte), dellaq(its:ite,kts:kte),       &
+                       dellau(its:ite,kts:kte), dellav(its:ite,kts:kte),       &
+                       ucko(its:ite,kts:kte),   vcko(its:ite,kts:kte),         &
+                       hcko(its:ite,kts:kte),   qcko(its:ite,kts:kte),         &
+                       eta(its:ite,kts:kte),    zi(its:ite,kts:kte+1),         &
+                       pwo(its:ite,kts:kte)
+!
+   logical         ::  totflg, cnvflg(its:ite), flg(its:ite)
+!
+!  physical parameters
+!
+   real,parameter  ::  c0=.002,c1=5.e-4
+   real,parameter  ::  cincrmax=180.,cincrmin=120.,dthk=25.
+   real            ::  el2orc,fact1,fact2,eps
+   real,parameter  ::  h1=0.33333333
+   real,parameter  ::  tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)
+!
+!-------------------------------------------------------------------------------
+!
+   pi_ = 3.14159
+   qmin_ = 1.0e-30
+   t0c_ = 273.15
+   xlv0 = hvap_
+      km1 = kte - 1
+!
+!  compute surface buoyancy flux
+!
+      do k = kts,kte
+        do i = its,ite
+          thx(i,k) = t1(i,k)/prslk(i,k)
+        enddo
+      enddo
+!
+      do i=its,ite
+         tvcon = (1.+fv_*q1(i,1))
+         rhox(i) = prsl(i,1)*1.e3/(rd_*t1(i,1)*tvcon)
+      enddo
+!
+      do i=its,ite
+!        sflx(i) = heat(i)+fv_*t1(i,1)*evap(i)
+         sflx(i) = hfx(i)/rhox(i)/cp_ + qfx(i)/rhox(i)*fv_*thx(i,1)
+      enddo
+!
+!  initialize arrays
+!
+      do i=its,ite
+        cnvflg(i) = .true.
+        if(kuo(i).eq.1) cnvflg(i) = .false.
+        if(sflx(i).le.0.) cnvflg(i) = .false.
+        if(cnvflg(i)) then
+          kbot(i)=kte+1
+          ktop(i)=0
+        endif
+        rain(i)=0.
+        kbcon(i)=kte
+        ktcon(i)=1
+        kb(i)=kte
+        pdot(i) = 0.
+        qlko_ktcon(i) = 0.
+        edt(i)  = 0.
+        aa1(i)  = 0.
+        vshear(i) = 0.
+      enddo
+!
+      totflg = .true.
+      do i=its,ite
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!
+      dt2   =  delt
+      val   =         1200.
+      dtmin = max(dt2, val )
+      val   =         3600.
+      dtmax = max(dt2, val )
+!  model tunable parameters are all here
+      clam    = .3
+      aafac   = .1
+      betaw   = .03
+      evfact  = 0.3
+      evfactl = 0.3
+      pgcon   = 0.55    ! Zhang & Wu (2003,JAS)
+      val     =           1.
+!
+! define miscellaneous values
+!
+     el2orc = hvap_*hvap_/(rv_*cp_)
+     eps    = rd_/rv_ 
+     fact1  = (cvap_-cliq_)/rv_
+     fact2  = hvap_/rv_-fact1*t0c_
+!
+      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
+!
+!  define top layer for search of the downdraft originating layer
+!  and the maximum thetae for updraft
+!
+      do i=its,ite
+        kbm(i)   = kte
+        kmax(i)  = kte
+      enddo
+!     
+      do k = kts, kte
+        do i=its,ite
+          if (prsl(i,k).gt.prsi(i,1)*0.70) kbm(i) = k + 1
+          if (prsl(i,k).gt.prsi(i,1)*0.60) kmax(i) = k + 1
+        enddo
+      enddo
+      do i=its,ite
+        kbm(i)   = min(kbm(i),kmax(i))
+      enddo
+!
+!  hydrostatic height assume zero terr and compute
+!  updraft entrainment rate as an inverse function of height
+!
+      do k = kts, km1
+        do i=its,ite
+          xlamue(i,k) = clam / zi(i,k)
+        enddo
+      enddo
+      do i=its,ite
+        xlamue(i,kte) = xlamue(i,km1)
+      enddo
+!
+!  pbl height
+!
+      do i=its,ite
+        flg(i) = cnvflg(i)
+        kpbl(i)= 1
+      enddo
+!
+      do k = kts+1, km1
+        do i=its,ite
+          if (flg(i).and.zl(i,k).le.hpbl(i)) then 
+            kpbl(i) = k
+          else
+            flg(i) = .false.
+          endif
+        enddo
+      enddo
+!
+      do i=its,ite
+        kpbl(i)= min(kpbl(i),kbm(i))
+      enddo
+!
+!   convert surface pressure to mb from cb
+!
+      rcs = 1.
+      do k = kts, kte
+        do i =its,ite
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            p(i,k) = prsl(i,k) * 10.0
+            eta(i,k)  = 1.
+            hcko(i,k) = 0.
+            qcko(i,k) = 0.
+            ucko(i,k) = 0.
+            vcko(i,k) = 0.
+            dbyo(i,k) = 0.
+            pwo(i,k)  = 0.
+            dellal(i,k) = 0.
+            to(i,k)   = t1(i,k)
+            qo(i,k)   = q1(i,k)
+            uo(i,k)   = u1(i,k) * rcs
+            vo(i,k)   = v1(i,k) * rcs
+          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 = kts, kte
+        do i=its,ite
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+            qeso(i,k) = eps * qeso(i,k) / (p(i,k) + (eps-1.)*qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+          endif
+        enddo
+      enddo
+!
+!  compute moist static energy
+!
+      do k = kts,kte
+        do i=its,ite
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            tem       = g_ * zl(i,k) + cp_ * to(i,k)
+            heo(i,k)  = tem  + hvap_ * qo(i,k)
+            heso(i,k) = tem  + hvap_ * qeso(i,k)
+          endif
+        enddo
+      enddo
+!
+!  determine level with largest moist static energy within pbl
+!  this is the level where updraft starts
+!
+      do i=its,ite
+         if (cnvflg(i)) then
+            hmax(i) = heo(i,1)
+            kb(i) = 1
+         endif
+      enddo
+!
+      do k = kts+1, kte
+        do i=its,ite
+          if (cnvflg(i).and.k.le.kpbl(i)) then
+            if(heo(i,k).gt.hmax(i)) then
+              kb(i)   = k
+              hmax(i) = heo(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!
+      do k = kts, km1
+        do i=its,ite
+          if (cnvflg(i) .and. k .le. kmax(i)-1) then
+            dz      = .5 * (zl(i,k+1) - zl(i,k))
+            dp      = .5 * (p(i,k+1) - p(i,k))
+            es = 0.01*fpvs(to(i,k+1),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+            pprime  = p(i,k+1) + (eps-1.) * es
+            qs      = eps * es / pprime
+            dqsdp   = - qs / pprime
+            desdt   = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
+            dqsdt   = qs * p(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 * (p(i,k) + p(i,k+1))
+          endif
+        enddo
+      enddo
+!
+      do k = kts, km1
+        do i=its,ite
+          if (cnvflg(i) .and. k .le. kmax(i)-1) then
+            qeso(i,k)=0.01*fpvs(to(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + (eps-1.) * qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+            heo(i,k)  = .5 * g_ * (zl(i,k) + zl(i,k+1)) +                      &
+                        cp_ * to(i,k) + hvap_ * qo(i,k)
+            heso(i,k) = .5 * g_ * (zl(i,k) + zl(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
+!
+!  look for the level of free convection as cloud base
+!
+      do i=its,ite
+        flg(i)   = cnvflg(i)
+        if(flg(i)) kbcon(i) = kmax(i)
+      enddo
+!
+      do k = kts+1, km1
+        do i=its,ite
+          if (flg(i).and.k.lt.kbm(i)) then
+            if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then
+              kbcon(i) = k
+              flg(i)   = .false.
+            endif
+          endif
+        enddo
+      enddo
+!
+      do i=its,ite
+        if(cnvflg(i)) then
+          if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false.
+        endif
+      enddo
+!
+      totflg = .true.
+      do i=its,ite
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!
+!  determine critical convective inhibition
+!  as a function of vertical velocity at cloud base.
+!
+      do i=its,ite
+        if(cnvflg(i)) then
+          pdot(i)  = 10.* dot(i,kbcon(i))
+        endif
+      enddo
+!
+      do i=its,ite
+        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
+          if(pdot(i).le.w4) then
+            ptem = (pdot(i) - w4) / (w3 - w4)
+          elseif(pdot(i).ge.-w4) then
+            ptem = - (pdot(i) + w4) / (w4 - w3)
+          else
+            ptem = 0.
+          endif
+          val1    =             -1.
+          ptem = max(ptem,val1)
+          val2    =             1.
+          ptem = min(ptem,val2)
+          ptem = 1. - ptem
+          ptem1= .5*(cincrmax-cincrmin)
+          cincr = cincrmax - ptem * ptem1
+          tem1 = p(i,kb(i)) - p(i,kbcon(i))
+          if(tem1.gt.cincr) then
+             cnvflg(i) = .false.
+          endif
+        endif
+      enddo
+!
+      totflg = .true.
+      do i=its,ite
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!
+!  assume the detrainment rate for the updrafts to be same as 
+!  the entrainment rate at cloud base
+!
+      do i = its,ite
+        if(cnvflg(i)) then
+          xlamud(i) = xlamue(i,kbcon(i))
+        endif
+      enddo
+!
+!  determine updraft mass flux for the subcloud layers
+!
+       do k = km1, kts, -1
+        do i = its,ite
+          if (cnvflg(i)) then
+            if(k.lt.kbcon(i).and.k.ge.kb(i)) then
+              dz       = zi(i,k+1) - zi(i,k)
+              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i)
+              eta(i,k) = eta(i,k+1) / (1. + ptem * dz)
+            endif
+          endif
+        enddo
+      enddo
+!
+!  compute mass flux above cloud base
+!
+      do k = kts+1, km1
+        do i = its,ite
+         if(cnvflg(i))then
+           if(k.gt.kbcon(i).and.k.lt.kmax(i)) then
+              dz       = zi(i,k) - zi(i,k-1)
+              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i)
+              eta(i,k) = eta(i,k-1) * (1 + ptem * dz)
+           endif
+         endif
+        enddo
+      enddo
+!
+!  compute updraft cloud property
+!
+      do i = its,ite
+        if(cnvflg(i)) then
+          indx         = kb(i)
+          hcko(i,indx) = heo(i,indx)
+          ucko(i,indx) = uo(i,indx)
+          vcko(i,indx) = vo(i,indx)
+        endif
+      enddo
+!
+      do k = kts+1, km1
+        do i = its,ite
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.kmax(i)) then
+              dz   = zi(i,k) - zi(i,k-1)
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              ptem = 0.5 * tem + pgcon
+              ptem1= 0.5 * tem - pgcon
+              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*                      &
+                          (heo(i,k)+heo(i,k-1)))/factor
+              ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k)                  &
+                          +ptem1*uo(i,k-1))/factor
+              vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k)                  &
+                          +ptem1*vo(i,k-1))/factor
+              dbyo(i,k) = hcko(i,k) - heso(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!
+!   taking account into convection inhibition due to existence of
+!    dry layers below cloud base
+!
+      do i=its,ite
+        flg(i) = cnvflg(i)
+        kbcon1(i) = kmax(i)
+      enddo
+!
+      do k = kts+1, km1
+        do i=its,ite
+          if (flg(i).and.k.lt.kbm(i)) then
+            if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then
+              kbcon1(i) = k
+              flg(i)    = .false.
+            endif
+          endif
+        enddo
+      enddo
+!
+      do i=its,ite
+        if(cnvflg(i)) then
+          if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false.
+        endif
+      enddo
+!
+      do i=its,ite
+        if(cnvflg(i)) then
+          tem = p(i,kbcon(i)) - p(i,kbcon1(i))
+          if(tem.gt.dthk) then
+             cnvflg(i) = .false.
+          endif
+        endif
+      enddo
+!
+      totflg = .true.
+      do i = its,ite
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!
+!  determine first guess cloud top as the level of zero buoyancy
+!    limited to the level of sigma=0.7
+!
+      do i = its,ite
+        flg(i) = cnvflg(i)
+        if(flg(i)) ktcon(i) = kbm(i)
+      enddo
+!
+      do k = kts+1, km1
+        do i=its,ite
+          if (flg(i).and.k .lt. kbm(i)) then
+            if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then
+               ktcon(i) = k
+               flg(i)   = .false.
+            endif
+          endif
+        enddo
+      enddo
+!
+!  specify upper limit of mass flux at cloud base
+!
+      do i = its,ite
+        if(cnvflg(i)) then
+          k = kbcon(i)
+          dp = 1000. * del(i,k)
+          xmbmax(i) = dp / (g_ * dt2)
+        endif
+      enddo
+!
+!  compute cloud moisture property and precipitation
+!
+      do i = its,ite
+        if (cnvflg(i)) then
+          aa1(i) = 0.
+          qcko(i,kb(i)) = qo(i,kb(i))
+        endif
+      enddo
+!
+      do k = kts+1, km1
+        do i = its,ite
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrch = qeso(i,k)                                                 &
+                   + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*                      &
+                          (qo(i,k)+qo(i,k-1)))/factor
+              dq = eta(i,k) * (qcko(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(k.ge.kbcon(i).and.dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0) then
+                  dp = 1000. * del(i,k)
+                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+                  dellal(i,k) = etah * c1 * dz * qlk * g_ / dp
+                else
+                  qlk = dq / (eta(i,k) + etah * c0 * dz)
+                endif
+                aa1(i) = aa1(i) - dz * g_ * qlk
+                qcko(i,k)= qlk + qrch
+                pwo(i,k) = etah * c0 * dz * qlk
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!
+!  calculate cloud work function
+!
+      do k = kts+1, km1
+        do i = its,ite
+          if (cnvflg(i)) then
+            if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then
+              dz1 = zl(i,k+1) - zl(i,k)        
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + fv_ * cp_ * gamma                                  &
+                      * to(i,k) / hvap_
+              aa1(i) = aa1(i) + dz1 * (g_ / (cp_ * to(i,k)))                   &
+                      * dbyo(i,k) / (1. + gamma) * rfact
+              val = 0.
+              aa1(i)=aa1(i)+ dz1 * g_ * fv_ *                                  &
+                      max(val,(qeso(i,k) - qo(i,k)))
+            endif
+          endif
+        enddo
+      enddo
+!
+      do i = its,ite
+        if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
+      enddo
+!
+      totflg = .true.
+      do i=its,ite
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!
+!  estimate the convective overshooting as the level
+!    where the [aafac * cloud work function] becomes zero,
+!    which is the final cloud top limited to the level of sigma=0.7
+!
+      do i = its,ite
+        if (cnvflg(i)) then
+          aa1(i) = aafac * aa1(i)
+        endif
+      enddo
+!
+      do i = its,ite
+        flg(i) = cnvflg(i)
+        ktcon1(i) = kbm(i)
+      enddo
+!
+      do k = kts+1, km1
+        do i = its,ite
+          if (flg(i)) then
+            if(k.ge.ktcon(i).and.k.lt.kbm(i)) then
+              dz1 = zl(i,k+1) - zl(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + fv_ * cp_ * gamma                                  &
+                      * to(i,k) / hvap_
+              aa1(i) = aa1(i) +                                                &
+                      dz1 * (g_ / (cp_ * to(i,k)))                             &
+                      * dbyo(i,k) / (1. + gamma) * rfact
+              if(aa1(i).lt.0.) then
+                ktcon1(i) = k
+                flg(i) = .false.
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!
+!  compute cloud moisture property, detraining cloud water
+!    and precipitation in overshooting layers
+!
+      do k = kts+1, km1
+        do i = its,ite
+          if (cnvflg(i)) then
+            if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrch = qeso(i,k)                                                 &
+                   + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*                      &
+                          (qo(i,k)+qo(i,k-1)))/factor
+              dq = eta(i,k) * (qcko(i,k) - qrch)
+!
+!  check if there is excess moisture to release latent heat
+!
+              if(dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0) then
+                  dp = 1000. * del(i,k)
+                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+                  dellal(i,k) = etah * c1 * dz * qlk * g_ / dp
+                else
+                  qlk = dq / (eta(i,k) + etah * c0 * dz)
+                endif
+                qcko(i,k) = qlk + qrch
+                pwo(i,k) = etah * c0 * dz * qlk
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!
+! exchange ktcon with ktcon1
+!
+      do i = its,ite
+        if(cnvflg(i)) then
+          kk = ktcon(i)
+          ktcon(i) = ktcon1(i)
+          ktcon1(i) = kk
+        endif
+      enddo
+!
+!  this section is ready for cloud water
+!
+      if(ncloud.gt.0) then
+!
+!  compute liquid and vapor separation at cloud top
+!
+      do i = its,ite
+        if(cnvflg(i)) then
+          k = ktcon(i) - 1
+          gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+          qrch = qeso(i,k)                                                     &
+               + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
+          dq = qcko(i,k) - qrch
+!
+!  check if there is excess moisture to release latent heat
+!
+          if(dq.gt.0.) then
+            qlko_ktcon(i) = dq
+            qcko(i,k) = qrch
+          endif
+        endif
+      enddo
+!
+      endif
+!
+!--- compute precipitation efficiency in terms of windshear
+!
+      do i = its,ite
+        if(cnvflg(i)) then
+          vshear(i) = 0.
+        endif
+      enddo
+!
+      do k = kts+1,kte
+        do i = its,ite
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2                             &
+                        + (vo(i,k)-vo(i,k-1)) ** 2)
+              vshear(i) = vshear(i) + shear
+            endif
+          endif
+        enddo
+      enddo
+!
+      do i = its,ite
+        if(cnvflg(i)) then
+          vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i)))
+          e1=1.591-.639*vshear(i)                                              &
+             +.0953*(vshear(i)**2)-.00496*(vshear(i)**3)
+          edt(i)=1.-e1
+          val =         .9
+          edt(i) = min(edt(i),val)
+          val =         .0
+          edt(i) = max(edt(i),val)
+        endif
+      enddo
+!
+!--- what would the change be, that a cloud with unit mass
+!--- will do to the environment?
+!
+      do k = kts,kte
+        do i = its,ite
+          if(cnvflg(i) .and. k .le. kmax(i)) then
+            dellah(i,k) = 0.
+            dellaq(i,k) = 0.
+            dellau(i,k) = 0.
+            dellav(i,k) = 0.
+          endif
+        enddo
+      enddo
+!
+!--- changed due to subsidence and entrainment
+!
+      do k = kts+1, km1
+        do i = its,ite
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              dp = 1000. * del(i,k)
+              dz = zi(i,k) - zi(i,k-1)
+!
+              dv1h = heo(i,k)
+              dv2h = .5 * (heo(i,k) + heo(i,k-1))
+              dv3h = 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)
+!
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1))
+              tem1 = xlamud(i)
+!
+              dellah(i,k) = dellah(i,k) +                                      &
+          ( eta(i,k)*dv1h - eta(i,k-1)*dv3h                                    &
+         -  tem*eta(i,k-1)*dv2h*dz                                             &
+         +  tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz                      &
+              ) *g_/dp
+!
+              dellaq(i,k) = dellaq(i,k) +                                      &
+          ( eta(i,k)*dv1q - eta(i,k-1)*dv3q                                    &
+         -  tem*eta(i,k-1)*dv2q*dz                                             &
+         +  tem1*eta(i,k-1)*.5*(qcko(i,k)+qcko(i,k-1))*dz                      &
+              ) *g_/dp
+!
+              dellau(i,k) = dellau(i,k) +                                      &
+          ( eta(i,k)*dv1u - eta(i,k-1)*dv3u                                    &
+         -  tem*eta(i,k-1)*dv2u*dz                                             &
+         +  tem1*eta(i,k-1)*.5*(ucko(i,k)+ucko(i,k-1))*dz                      &
+         -  pgcon*eta(i,k-1)*(dv1u-dv3u)                                       &
+              ) *g_/dp
+!
+              dellav(i,k) = dellav(i,k) +                                      &
+          ( eta(i,k)*dv1v - eta(i,k-1)*dv3v                                    &
+         -  tem*eta(i,k-1)*dv2v*dz                                             &
+         +  tem1*eta(i,k-1)*.5*(vcko(i,k)+vcko(i,k-1))*dz                      &
+         -  pgcon*eta(i,k-1)*(dv1v-dv3v)                                       &
+              ) *g_/dp
+!
+            endif
+          endif
+        enddo
+      enddo
+!
+!------- cloud top
+!
+      do i = its,ite
+        if(cnvflg(i)) then
+          indx = ktcon(i)
+          dp = 1000. * del(i,indx)
+          dv1h = heo(i,indx-1)
+          dellah(i,indx) = eta(i,indx-1) *                                     &
+                          (hcko(i,indx-1) - dv1h) * g_ / dp
+          dv1q = qo(i,indx-1)
+          dellaq(i,indx) = eta(i,indx-1) *                                     &
+                          (qcko(i,indx-1) - dv1q) * 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,indx) = eta(i,indx-1) *                                     &
+                          qlko_ktcon(i) * g_ / dp
+        endif
+      enddo
+!
+!  mass flux at cloud base for shallow convection
+!  (Grant, 2001)
+!
+      do i= its,ite
+        if(cnvflg(i)) then
+          k = kbcon(i)
+          ptem = g_*sflx(i)*hpbl(i)/t1(i,1)
+          wstar(i) = ptem**h1
+          tem = po(i,k)*100. / (rd_*t1(i,k))
+          xmb(i) = betaw*tem*wstar(i)
+          xmb(i) = min(xmb(i),xmbmax(i))
+        endif
+      enddo
+!
+      do k = kts,kte
+        do i = its,ite
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            qeso(i,k)=0.01* fpvs(t1(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+            qeso(i,k) = eps * qeso(i,k) / (p(i,k) + (eps-1.)*qeso(i,k))
+            val     =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val )
+          endif
+        enddo
+      enddo
+!
+      do i = its,ite
+        delhbar(i) = 0.
+        delqbar(i) = 0.
+        deltbar(i) = 0.
+        delubar(i) = 0.
+        delvbar(i) = 0.
+        qcond(i) = 0.
+      enddo
+!
+      do k = kts,kte
+        do i = its,ite
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              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
+              tem = 1./rcs
+              u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem
+              v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem
+              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_
+              delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g_
+              delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g_
+            endif
+          endif
+        enddo
+      enddo
+!
+      do k = kts,kte
+        do i = its,ite
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              qeso(i,k)=0.01* fpvs(t1(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls &
+                        ,psat,t0c_)
+              qeso(i,k) = eps * qeso(i,k)/(p(i,k) + (eps-1.)*qeso(i,k))
+              val     =             1.e-8
+              qeso(i,k) = max(qeso(i,k), val )
+            endif
+          endif
+        enddo
+      enddo
+!
+      do i = its,ite
+        rntot(i) = 0.
+        delqev(i) = 0.
+        delq2(i) = 0.
+        flg(i) = cnvflg(i)
+      enddo
+!
+      do k = kte, kts, -1
+        do i = its,ite
+          if (cnvflg(i)) then
+            if(k.lt.ktcon(i).and.k.gt.kb(i)) then
+              rntot(i) = rntot(i) + pwo(i,k) * xmb(i) * .001 * dt2
+            endif
+          endif
+        enddo
+      enddo
+!
+! evaporating rain
+!
+      do k = kte, kts, -1
+        do i = its,ite
+          if (k .le. kmax(i)) then
+            deltv(i) = 0.
+            delq(i) = 0.
+            qevap(i) = 0.
+            if(cnvflg(i)) then
+              if(k.lt.ktcon(i).and.k.gt.kb(i)) then
+                rain(i) = rain(i) + pwo(i,k) * xmb(i) * .001 * dt2
+              endif
+            endif
+            if(flg(i).and.k.lt.ktcon(i)) then
+              evef = edt(i) * evfact
+              if(slimsk(i).eq.1.) evef=edt(i) * evfactl
+              qcond(i) = evef * (q1(i,k) - qeso(i,k))                          &
+                       / (1. + el2orc * qeso(i,k) / t1(i,k)**2)
+              dp = 1000. * del(i,k)
+              if(rain(i).gt.0..and.qcond(i).lt.0.) then
+                qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rain(i))))
+                qevap(i) = min(qevap(i), rain(i)*1000.*g_/dp)
+                delq2(i) = delqev(i) + .001 * qevap(i) * dp / g_
+              endif
+              if(rain(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(rain(i).gt.0..and.qevap(i).gt.0.) then
+                tem  = .001 * dp / g_
+                tem1 = qevap(i) * tem
+                if(tem1.gt.rain(i)) then
+                  qevap(i) = rain(i) / tem
+                  rain(i) = 0.
+                else
+                  rain(i) = rain(i) - tem1
+                endif
+                q1(i,k) = q1(i,k) + qevap(i)
+                t1(i,k) = t1(i,k) - (hvap_/cp_) * qevap(i)
+                deltv(i) = - (hvap_/cp_)*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
+!
+      do i = its,ite
+        if(cnvflg(i)) then
+          if(rain(i).lt.0..or..not.flg(i)) rain(i) = 0.
+          ktop(i) = ktcon(i)
+          kbot(i) = kbcon(i)
+          kuo(i) = 0
+        endif
+      enddo
+!
+! cloud water
+!
+      if (ncloud.gt.0) then
+!
+      do k = kts, km1
+        do i = its,ite
+          if (cnvflg(i)) then
+            if (k.ge.kbcon(i).and.k.le.ktcon(i)) then
+              tem  = dellal(i,k) * xmb(i) * dt2
+              tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf))
+              if (ncloud.ge.4) then
+                qi2(i,k) = qi2(i,k) + tem * tem1            ! ice
+                qc2(i,k) = qc2(i,k) + tem *(1.0-tem1)       ! water
+              else
+                qc2(i,k) = qc2(i,k) + tem
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!
+      endif
+!
+      end subroutine nscv2d
+!-------------------------------------------------------------------------------
+!
+END MODULE module_cu_nsas
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_sas.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_sas.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_sas.F	(revision 17)
@@ -0,0 +1,2546 @@
+!!
+MODULE module_cu_sas 
+
+CONTAINS
+
+!-----------------------------------------------------------------
+      SUBROUTINE CU_SAS(DT,ITIMESTEP,STEPCU,                        &
+                 RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,               &
+                 RUCUTEN,RVCUTEN,                                   & ! gopal's doing for SAS
+                 RAINCV,PRATEC,HTOP,HBOT,                           &
+                 U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D,           &
+                 DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG,                   &
+                 P_QC,                                              & 
+#if (NMM_CORE == 1)
+                 STORE_RAND,MOMMIX, & ! gopal's doing
+#endif
+                 P_QI,P_FIRST_SCALAR,                               & 
+                 CUDT, CURR_SECS, ADAPT_STEP_FLAG,                  &
+                 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
+      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)
+!
+!-- MOMMIX      MOMENTUM MIXING COEFFICIENT (can be set in the namelist)
+!-- RUCUTEN     U tendency due to Cumulus Momentum Mixing (gopal's doing for SAS)
+!-- RVCUTEN     V tendency due to Cumulus Momentum Mixing (gopal's doing for SAS)
+!
+!-- 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,                      &     !NSTD
+                                        P_FIRST_SCALAR,                 &
+                                        P_QC,                           &
+                                        P_QI,                           &
+                                        STEPCU
+
+      REAL,    INTENT(IN) ::                                            &
+                                        DT
+
+
+      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::      &
+                                        RQCCUTEN,                       &
+                                        RQICUTEN,                       &
+                                        RQVCUTEN,                       &
+                                        RTHCUTEN
+      REAL, DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(INOUT) ::      &
+                                        RUCUTEN,                        &  ! gopal's doing for SAS
+                                        RVCUTEN                            ! gopal's doing for SAS 
+#if (NMM_CORE == 1)
+      REAL,    INTENT(IN) ::    MOMMIX
+      REAL, DIMENSION( ims:ime , jms:jme ),                             &
+                         INTENT(IN) :: STORE_RAND
+
+#endif
+
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(IN) ::               &
+                                        XLAND
+
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::            &
+                                        RAINCV, PRATEC
+
+      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
+
+! Adaptive time-step variables
+      REAL,  INTENT(IN   ) :: CUDT
+      REAL,  INTENT(IN   ) :: CURR_SECS
+      LOGICAL,INTENT(IN   ) :: ADAPT_STEP_FLAG
+
+!--------------------------- LOCAL VARS ------------------------------
+
+      REAL,    DIMENSION(ims:ime, jms:jme) ::                           &
+                                        PSFC
+
+
+      REAL     (kind=kind_phys) ::                                      &
+                                        DELT,                           &
+                                        DPSHC,                          &
+                                        RDELT,                          &
+                                        RSEED
+
+      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 
+
+      LOGICAL :: run_param
+
+      DATA IGPVS/0/
+
+!-----------------------------------------------------------------------
+!
+!***  CHECK TO SEE IF THIS IS A CONVECTION TIMESTEP
+!
+      if (adapt_step_flag) then
+         if ( (ITIMESTEP .eq. 0) .or. (cudt .eq. 0) .or. &
+         ( CURR_SECS + dt >= ( int( CURR_SECS / ( cudt * 60 ) ) + 1 ) * cudt * 60 ) ) then
+         run_param = .TRUE.
+      else
+         run_param = .FALSE.
+      endif
+
+      else
+         if (MOD(ITIMESTEP,STEPCU) .EQ. 0 .or. ITIMESTEP .eq. 0) then
+            run_param = .TRUE.
+         else
+            run_param = .FALSE.
+         endif
+      endif
+
+!-----------------------------------------------------------------------
+
+
+   IF(run_param) 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(igpvs.eq.0) CALL GFUNCPHYS
+   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 -------------------------------------
+
+!    Based on some important findings from Morris Bender, XKT2 was defined in
+!    terms of random number instead of random number based cloud tops
+!    Also, these random numbers are stored and are changed only once in
+!    approximately 5 minutes interval now. This is gopal's doing for HWRF.
+
+!     call random_number(XKT2)
+
+#if (EM_CORE == 1)
+!    XKT2 was defined in terms of random number instead of random number based cloud tops
+!    ZCX   
+     call init_random_seed()
+     call random_number(XKT2)
+#ifdef REGTEST
+! for regtest only
+     xkt2 = 0.1
+#endif
+#endif
+!   
+#if (NMM_CORE == 1)
+      DO i=its,ite
+         XKT2(i) = STORE_RAND(i,j)
+      ENDDO
+#endif
+
+      DO i=its,ite
+        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) 
+
+!!!   make more like GFDL ... eliminate shallow convection.....
+!!!   CALL SHALCV(IM,IM,KX,DELT,DEL,PRSI,PRSL,PRSLK,KUO,Q1,T1,DPSHC)
+#if (EM_CORE == 1)
+      CALL SHALCV(IM,IM,KX,DELT,DEL,PRSI,PRSL,PRSLK,KUO,Q1,T1,DPSHC)
+#endif
+
+      DO I=ITS,ITE
+        RAINCV(I,J)=RN(I)*1000./STEPCU
+        PRATEC(I,J)=RN(I)*1000./(STEPCU * DT)
+        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
+
+!===============================================================================
+!     ADD MOMENTUM MIXING TERM AS TENDENCIES. This is gopal's doing for SAS
+!     MOMMIX is the reduction factor set to 0.7 by default. Because NMM has 
+!     divergence damping term, a reducion factor for cumulum mixing may be
+!     required otherwise storms were too weak.
+!===============================================================================
+!
+#if (NMM_CORE == 1)
+      DO K=KTS,KTE
+        DO I=ITS,ITE
+         RUCUTEN(I,J,K)=MOMMIX*(U1(I,K)-U3D(I,K,J))*RDELT
+         RVCUTEN(I,J,K)=MOMMIX*(V1(I,K)-V3D(I,K,J))*RDELT
+        ENDDO
+      ENDDO
+#endif
+
+
+      IF(P_QC .ge. P_FIRST_SCALAR)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
+
+      IF(P_QI .ge. P_FIRST_SCALAR)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
+
+   ENDDO    ! Outer most J loop
+
+   ENDIF
+
+   END SUBROUTINE CU_SAS
+
+!====================================================================
+   SUBROUTINE sasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,          &
+                      RUCUTEN,RVCUTEN,                              &   ! gopal's doing for SAS
+                      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
+   REAL,     DIMENSION( ims:ime , jms:jme , kms:kme ) , INTENT(OUT) ::  &
+                                                              RUCUTEN,  & ! gopal's doing for SAS
+                                                              RVCUTEN   
+
+   INTEGER :: i, j, k, itf, jtf, ktf
+
+   jtf=min0(jte,jde-1)
+   ktf=min0(kte,kde-1)
+   itf=min0(ite,ide-1)
+
+#ifdef HWRF
+!zhang's doing
+   IF(.not.restart .or. .not.allowed_to_read)THEN
+!end of zhang's doing
+#else
+   IF(.not.restart)THEN
+#endif
+     DO j=jts,jtf
+     DO k=kts,ktf
+     DO i=its,itf
+       RTHCUTEN(i,k,j)=0.
+       RQVCUTEN(i,k,j)=0.
+       RUCUTEN(i,j,k)=0.   ! gopal's doing for SAS
+       RVCUTEN(i,j,k)=0.    ! gopal's doing for SAS
+     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
+      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), J
+      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
+!     change for hurricane model
+        BETAl = .5
+        betas = .5
+!     EVEF    = 0.07
+      evfact  = 0.3
+      evfactl = 0.3
+!     change for hurricane model
+         evfact = 0.6
+         evfactl = .6
+#if ( EM_CORE == 1 )
+!  HAWAII TEST - ZCX
+      ALPHAl  = .5
+      ALPHAs  = .75
+      BETAl   = .05
+      betas   = .05
+      evfact  = 0.5
+      evfactl = 0.5
+#endif
+      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
+
+#if (EM_CORE == 1)
+!   random seeds - ZCX    
+      SUBROUTINE init_random_seed()
+            INTEGER :: i, n, clock
+            INTEGER, DIMENSION(:), ALLOCATABLE :: seed
+
+            CALL RANDOM_SEED(size = n)
+            ALLOCATE(seed(n))
+
+            CALL SYSTEM_CLOCK(COUNT=clock)
+
+            seed = clock + 37 * (/ (i - 1, i = 1, n) /)
+            CALL RANDOM_SEED(PUT = seed)
+
+            DEALLOCATE(seed)
+      END SUBROUTINE 
+#endif
+      END MODULE module_cu_sas
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_tiedtke.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_tiedtke.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cu_tiedtke.F	(revision 17)
@@ -0,0 +1,3067 @@
+!-----------------------------------------------------------------------
+!
+!WRF:MODEL_LAYER:PHYSICS
+!
+!####################TIEDTKE SCHEME#########################
+!   Taken from the IPRC iRAM - Yuqing Wang, University of Hawaii
+!   Added by Chunxi Zhang and Yuqing Wang to WRF3.2, May, 2010
+!   refenrence: Tiedtke (1989, MWR, 117, 1779-1800)
+!               Nordeng, T.E., (1995), CAPE closure and organized entrainment/detrainment
+!               Yuqing Wang et al. (2003,J. Climate, 16, 1721-1738) for improvements 
+!                                                  for cloud top detrainment 
+!                       (2004, Mon. Wea. Rev., 132, 274-296), improvements for PBL clouds
+!                        (2007,Mon. Wea. Rev., 135, 567-585), diurnal cycle of precipitation
+!   This scheme is on testing
+!###########################################################
+MODULE module_cu_tiedtke
+!
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! epsl--- allowed minimum value for floating calculation
+!---------------------------------------------------------------
+      real,parameter ::  epsl  = 1.0e-20
+      real,parameter ::  t000  = 273.15
+      real,parameter ::  hgfr  = 233.15   ! defined in param.f in explct
+!-------------------------------------------------------------    
+!  Ends the parameters set
+!++++++++++++++++++++++++++++
+     REAL,PRIVATE :: G,CPV
+     REAL :: API,A,EOMEGA,RD,RV,CPD,RCPD,VTMPC1,VTMPC2,   &
+             RHOH2O,ALV,ALS,ALF,CLW,TMELT,SOLC,STBO,DAYL,YEARL, &
+             C1ES,C2ES,C3LES,C3IES,C4LES,C4IES,C5LES,C5IES,ZRG 
+    
+     REAL :: ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP,RHM,RHC,    &
+             CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON,CRIRH,ZBUO0,  &
+             fdbk,ZTAU
+ 
+     INTEGER :: nentr
+
+     REAL :: CVDIFTS, CEVAPCU1, CEVAPCU2,ZDNOPRC
+    
+  
+     PARAMETER(A=6371.22E03,                                    &
+      ALV=2.5008E6,                 &                  
+      ALS=2.8345E6,                 &
+      ALF=ALS-ALV,                  &
+      CPD=1005.46,                  &
+      CPV=1869.46,                  & ! CPV in module is 1846.4
+      RCPD=1.0/CPD,                 &
+      RHOH2O=1.0E03,                & 
+      TMELT=273.16,                 &
+      G=9.806,                      & ! G=9.806
+      ZRG=1.0/G,                    &
+      RD=287.05,                    &
+      RV=461.51,                    &
+      C1ES=610.78,                  &
+      C2ES=C1ES*RD/RV,              &
+      C3LES=17.269,                 &
+      C4LES=35.86,                  &
+      C5LES=C3LES*(TMELT-C4LES),    &
+      C3IES=21.875,                 &
+      C4IES=7.66,                   &
+      C5IES=C3IES*(TMELT-C4IES),    &
+      API=3.141593,                 & ! API=2.0*ASIN(1.)
+      VTMPC1=RV/RD-1.0,             &
+      VTMPC2=CPV/CPD-1.0,           &
+      CVDIFTS=1.0,                  &
+      CEVAPCU1=1.93E-6*261.,        & 
+      CEVAPCU2=1.E3/(38.3*0.293) )
+
+     
+!                SPECIFY PARAMETERS FOR MASSFLUX-SCHEME
+!                  --------------------------------------
+!                   These are tunable parameters
+!
+!     ENTRPEN: AVERAGE ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+!     -------
+!
+      PARAMETER(ENTRPEN=1.0E-4)
+!
+!     ENTRSCV: AVERAGE ENTRAINMENT RATE FOR SHALLOW CONVECTION
+!     -------
+!
+      PARAMETER(ENTRSCV=1.2E-3)
+!
+!     ENTRMID: AVERAGE ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+!     -------
+!
+      PARAMETER(ENTRMID=1.0E-4)
+!
+!     ENTRDD: AVERAGE ENTRAINMENT RATE FOR DOWNDRAFTS
+!     ------
+!
+      PARAMETER(ENTRDD =2.0E-4)
+!
+!     CMFCTOP:   RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANCY LEVEL
+!     -------
+!
+      PARAMETER(CMFCTOP=0.26)
+!
+!     CMFCMAX:   MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC
+!     -------
+!
+      PARAMETER(CMFCMAX=1.0)
+!
+!     CMFCMIN:   MINIMUM MASSFLUX VALUE (FOR SAFETY)
+!     -------
+!
+      PARAMETER(CMFCMIN=1.E-10)
+!
+!     CMFDEPS:   FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+!     -------
+!
+      PARAMETER(CMFDEPS=0.30)
+!
+!     CPRCON:  COEFFICIENTS FOR DETERMINING CONVERSION FROM CLOUD WATER
+!
+      PARAMETER(CPRCON = 2.0E-3/G)
+!
+!     ZDNOPRC: The pressure depth below which no precipitation
+!
+      PARAMETER(ZDNOPRC = 1.5E4)
+!--------------------
+     PARAMETER(nentr=1)   ! Old entrainment rate parameterization   ! chn1,2,4
+!      PARAMETER(nentr=2)   ! New entrainment rate parameterization    ! chn3
+!
+!--------------------
+      PARAMETER(RHC=0.80,RHM=1.0,ZBUO0=0.50)
+!--------------------
+      PARAMETER(CRIRH=0.80,fdbk = 1.0,ZTAU = 3600.0)
+!--------------------
+      LOGICAL :: LMFPEN,LMFMID,LMFSCV,LMFDD,LMFDUDV
+      PARAMETER(LMFPEN=.TRUE.,LMFMID=.TRUE.,LMFSCV=.TRUE.,LMFDD=.TRUE.,LMFDUDV=.TRUE.)
+!--------------------
+!#################### END of Variables definition##########################
+!-----------------------------------------------------------------------
+!
+CONTAINS
+!-----------------------------------------------------------------------
+      SUBROUTINE CU_TIEDTKE(                                    &
+                 DT,ITIMESTEP,STEPCU                            &
+                ,RAINCV,PRATEC,QFX,ZNU                          &
+                ,U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D        &
+                ,QVFTEN,QVPBLTEN                                &
+                ,DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG                &
+                ,CUDT, CURR_SECS, ADAPT_STEP_FLAG               &
+                ,ids,ide, jds,jde, kds,kde                      &
+                ,ims,ime, jms,jme, kms,kme                      &
+                ,its,ite, jts,jte, kts,kte                      &
+                ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN            &
+                ,RUCUTEN, RVCUTEN                               &
+                ,F_QV    ,F_QC    ,F_QR    ,F_QI    ,F_QS       &
+                                                                )
+
+!-------------------------------------------------------------------
+      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)
+!-- RHO3D       3D air density (kg/m^3)
+!-- P8w         3D hydrostatic pressure at full levels (Pa)
+!-- Pcps        3D hydrostatic pressure at half levels (Pa)
+!-- PI3D        3D exner function (dimensionless)
+!-- RTHCUTEN      Theta tendency due to 
+!                 cumulus scheme precipitation (K/s)
+!-- RUCUTEN       U wind tendency due to 
+!                 cumulus scheme precipitation (K/s)
+!-- RVCUTEN       V wind 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)
+!-- PRATEC        precipitiation rate from cumulus scheme (mm/s)
+!-- dz8w        dz between full levels (m)
+!-- QFX         upward moisture flux at the surface (kg/m^2/s)
+!-- DT          time step (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) ::            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, PRATEC
+
+      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,                           &
+                                        QVFTEN,                         &
+                                        QVPBLTEN,                       &
+                                        QI3D,                           &
+                                        QV3D,                           &
+                                        RHO3D,                          &
+                                        T3D,                            &
+                                        U3D,                            &
+                                        V3D,                            &
+                                        W                              
+
+!--------------------------- OPTIONAL VARS ----------------------------
+                                                                                                      
+      REAL, DIMENSION(ims:ime, kms:kme, jms:jme),                       &
+               OPTIONAL, INTENT(INOUT) ::                               &
+                                        RQCCUTEN,                       &
+                                        RQICUTEN,                       &
+                                        RQVCUTEN,                       &
+                                        RTHCUTEN,                       &
+                                        RUCUTEN,                        &
+                                        RVCUTEN
+                                                                                                      
+!
+! 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
+ 
+! Adaptive time-step variables
+      REAL,  INTENT(IN   ) :: CUDT
+      REAL,  INTENT(IN   ) :: CURR_SECS
+      LOGICAL,INTENT(IN   ) :: ADAPT_STEP_FLAG
+
+!--------------------------- LOCAL VARS ------------------------------
+
+      REAL,    DIMENSION(ims:ime, jms:jme) ::                           &
+                                        QFX     
+
+      REAL      ::                                      &
+                                        DELT,                           &
+                                        RDELT                          
+
+      REAL     , DIMENSION(its:ite) ::                  &
+                                        RCS,                            &
+                                        RN,                             &
+                                        EVAP
+      INTEGER  , DIMENSION(its:ite) ::  SLIMSK                         
+      
+
+      REAL     , DIMENSION(its:ite, kts:kte+1) ::       &
+                                        PRSI                            
+
+      REAL     , DIMENSION(its:ite, kts:kte) ::         &
+                                        DEL,                            &
+                                        DOT,                            &
+                                        PHIL,                           &
+                                        PRSL,                           &
+                                        Q1,                             & 
+                                        Q2,                             &
+                                        Q3,                             &
+                                        Q1B,                            &
+                                        Q1BL,                           &
+                                        Q11,                            &
+                                        Q12,                            &  
+                                        T1,                             & 
+                                        U1,                             & 
+                                        V1,                             & 
+                                        ZI,                             & 
+                                        ZL,                             &
+                                        OMG,                            &
+                                        GHT 
+
+      INTEGER, DIMENSION(its:ite) ::                                    &
+                                        KBOT,                           &
+                                        KTOP                           
+
+      INTEGER ::                                                        &
+                                        I,                              &
+                                        IM,                             &
+                                        J,                              &
+                                        K,                              &
+                                        KM,                             &
+                                        KP,                             &
+                                        KX
+
+
+      LOGICAL :: run_param
+
+!-------other local variables----
+      INTEGER,DIMENSION( its:ite ) :: KTYPE
+      REAL, DIMENSION( kts:kte )   :: sig1      ! half sigma levels
+      REAL, DIMENSION( kms:kme )   :: ZNU
+      INTEGER                      :: zz 
+!-----------------------------------------------------------------------
+!
+!***  CHECK TO SEE IF THIS IS A CONVECTION TIMESTEP
+!
+      if (adapt_step_flag) then
+         if ( (ITIMESTEP .eq. 1) .or. (cudt .eq. 0) .or. &
+          ( CURR_SECS + dt >= ( int( CURR_SECS / ( cudt * 60 ) ) + 1 ) * cudt * 60 ) ) then
+           run_param = .TRUE.
+         else
+           run_param = .FALSE.
+         endif   
+      else
+         if (MOD(ITIMESTEP,STEPCU) .EQ. 0 .or. ITIMESTEP .eq. 1) then
+            run_param = .TRUE.
+         else
+            run_param = .FALSE.
+         endif
+      endif
+
+!-----------------------------------------------------------------------
+   IF(run_param) 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
+      DELT=DT*STEPCU
+      RDELT=1./DELT
+
+!-------------  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 -------------------------------------
+      DO i=its,ite
+        SLIMSK(i)=int(ABS(XLAND(i,j)-2.))
+      ENDDO
+
+      DO k=kts,kte
+        kp=k+1
+        DO i=its,ite
+          DOT(i,k)=-0.5*g*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j))
+        ENDDO
+      ENDDO
+
+      DO k=kts,kte
+        zz = kte+1-k        
+        DO i=its,ite
+          U1(i,zz)=U3D(i,k,j)
+          V1(i,zz)=V3D(i,k,j)
+          T1(i,zz)=T3D(i,k,j)
+          Q1(i,zz)= QV3D(i,k,j)
+          if(itimestep == 1) then
+             Q1B(i,zz)=0.
+             Q1BL(i,zz)=0.
+          else
+             Q1B(i,zz)=QVFTEN(i,k,j)
+             Q1BL(i,zz)=QVPBLTEN(i,k,j)
+          endif
+          Q2(i,zz)=QC3D(i,k,j)
+          Q3(i,zz)=QI3D(i,k,j)
+          OMG(i,zz)=DOT(i,k)
+          GHT(i,zz)=ZL(i,k)
+          PRSL(i,zz) = Pcps(i,k,j)
+        ENDDO
+      ENDDO
+
+      DO k=kts,kte+1
+        zz = kte+2-k
+        DO i=its,ite
+          PRSI(i,zz) = P8w(i,k,j)
+        ENDDO
+      ENDDO 
+
+      DO k=kts,kte
+         zz = kte+1-k
+         sig1(zz) = ZNU(k)
+      ENDDO
+
+!###############before call TIECNV, we need EVAP########################
+!       EVAP is the vapor flux at the surface
+!########################################################################
+!
+      DO i=its,ite
+        EVAP(i) = QFX(i,j)
+      ENDDO
+!########################################################################
+      CALL TIECNV(U1,V1,T1,Q1,Q2,Q3,Q1B,Q1BL,GHT,OMG,PRSL,PRSI,EVAP,             &
+                  RN,SLIMSK,KTYPE,IM,KX,KX+1,sig1,DELT)                 
+
+      DO I=ITS,ITE
+         RAINCV(I,J)=RN(I)/STEPCU
+         PRATEC(I,J)=RN(I)/(STEPCU * DT)
+      ENDDO
+
+      DO K=KTS,KTE
+        zz = kte+1-k
+        DO I=ITS,ITE
+          RTHCUTEN(I,K,J)=(T1(I,zz)-T3D(I,K,J))/PI3D(I,K,J)*RDELT
+          RQVCUTEN(I,K,J)=(Q1(I,zz)-QV3D(I,K,J))*RDELT
+          RUCUTEN(I,K,J) =(U1(I,zz)-U3D(I,K,J))*RDELT
+          RVCUTEN(I,K,J) =(V1(I,zz)-V3D(I,K,J))*RDELT 
+        ENDDO
+      ENDDO
+
+      IF(PRESENT(RQCCUTEN))THEN
+        IF ( F_QC ) THEN
+          DO K=KTS,KTE
+            zz = kte+1-k
+            DO I=ITS,ITE
+              RQCCUTEN(I,K,J)=(Q2(I,zz)-QC3D(I,K,J))*RDELT
+            ENDDO
+          ENDDO
+        ENDIF
+      ENDIF
+
+      IF(PRESENT(RQICUTEN))THEN
+        IF ( F_QI ) THEN
+          DO K=KTS,KTE
+            zz = kte+1-k
+            DO I=ITS,ITE
+              RQICUTEN(I,K,J)=(Q3(I,zz)-QI3D(I,K,J))*RDELT
+            ENDDO
+          ENDDO
+        ENDIF
+      ENDIF
+
+
+   ENDDO
+
+   ENDIF
+
+   END SUBROUTINE CU_TIEDTKE
+
+!====================================================================
+   SUBROUTINE tiedtkeinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,          &
+                     RUCUTEN,RVCUTEN,                                   &
+                     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, &
+                                                              RUCUTEN,RVCUTEN 
+
+   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.
+       RUCUTEN(i,k,j)=0.
+       RVCUTEN(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 tiedtkeinit
+
+! ------------------------------------------------------------------------
+
+!------------This is the combined version for tiedtke---------------
+!----------------------------------------------------------------
+!  In this module only the mass flux convection scheme of the ECMWF is included
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!#############################################################
+!
+!             LEVEL 1 SUBROUTINEs
+!
+!#############################################################
+!********************************************************
+!        subroutine TIECNV
+!********************************************************
+      SUBROUTINE TIECNV(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg,  &
+               pap,paph,evap,zprecc,lndj,KTYPE,lq,km,km1,sig1,dt)
+!-----------------------------------------------------------------
+!  This is the interface between the meso-scale model and the mass 
+!  flux convection module
+!-----------------------------------------------------------------
+      implicit none
+
+      real pu(lq,km),pv(lq,km),pt(lq,km),pqv(lq,km),pqvf(lq,km)
+      real poz(lq,km),pomg(lq,km),evap(lq),zprecc(lq),pqvbl(lq,km)
+
+      REAL PUM1(lq,km),    PVM1(lq,km),                             &
+          PTTE(lq,km),    PQTE(lq,km),  PVOM(lq,km),  PVOL(lq,km),  &
+          PVERV(lq,km),   PGEO(lq,km),  PAP(lq,km),   PAPH(lq,km1)
+      REAL PQHFL(lq),      ZQQ(lq,km),   PAPRC(lq),    PAPRS(lq),   &
+          PRSFC(lq),      PSSFC(lq),    PAPRSM(lq),   PCTE(lq,km)
+      REAL ZTP1(lq,km),    ZQP1(lq,km),  ZTU(lq,km),   ZQU(lq,km),  &
+          ZLU(lq,km),     ZLUDE(lq,km), ZMFU(lq,km),  ZMFD(lq,km),  &
+          ZQSAT(lq,km),   pqc(lq,km),   pqi(lq,km),   ZRAIN(lq)
+
+      REAL sig(km1),sig1(km)
+      INTEGER ICBOT(lq),   ICTOP(lq),     KTYPE(lq),   lndj(lq)
+      REAL  dt
+      LOGICAL LOCUM(lq)
+
+      real PSHEAT,PSRAIN,PSEVAP,PSMELT,PSDISS,TT
+      real ZTMST,ZTPP1,fliq,fice,ZTC,ZALF
+      integer i,j,k,lq,lp,km,km1
+!     real TLUCUA
+!     external TLUCUA
+
+      ZTMST=dt
+!  Masv flux diagnostics.
+
+      PSHEAT=0.0
+      PSRAIN=0.0
+      PSEVAP=0.0
+      PSMELT=0.0
+      PSDISS=0.0
+      DO 8 j=1,lq
+        ZRAIN(j)=0.0
+        LOCUM(j)=.FALSE.
+        PRSFC(j)=0.0
+        PSSFC(j)=0.0
+        PAPRC(j)=0.0
+        PAPRS(j)=0.0
+        PAPRSM(j)=0.0
+        PQHFL(j)=evap(j)
+    8 CONTINUE
+
+!     CONVERT MODEL VARIABLES FOR MFLUX SCHEME
+
+      DO 10 k=1,km
+        DO 10 j=1,lq
+          PTTE(j,k)=0.0
+          PCTE(j,k)=0.0
+          PVOM(j,k)=0.0
+          PVOL(j,k)=0.0
+          ZTP1(j,k)=pt(j,k)
+          ZQP1(j,k)=pqv(j,k)/(1.0+pqv(j,k))
+          PUM1(j,k)=pu(j,k)
+          PVM1(j,k)=pv(j,k)
+          PVERV(j,k)=pomg(j,k)
+          PGEO(j,k)=G*poz(j,k)
+          TT=ZTP1(j,k)
+          ZQSAT(j,k)=TLUCUA(TT)/PAP(j,k)
+          ZQSAT(j,k)=MIN(0.5,ZQSAT(j,k))
+          ZQSAT(j,k)=ZQSAT(j,k)/(1.-VTMPC1*ZQSAT(j,k))
+          PQTE(j,k)=pqvf(j,k)+pqvbl(j,k)
+          ZQQ(j,k)=PQTE(j,k)
+   10 CONTINUE
+!
+!-----------------------------------------------------------------------
+!*    2.     CALL 'CUMASTR'(MASTER-ROUTINE FOR CUMULUS PARAMETERIZATION)
+!
+      CALL CUMASTR_NEW &
+         (lq,       km,       km1,      km-1,    ZTP1,   &
+          ZQP1,     PUM1,     PVM1,     PVERV,   ZQSAT,  &
+          PQHFL,    ZTMST,    PAP,      PAPH,    PGEO,   &
+          PTTE,     PQTE,     PVOM,     PVOL,    PRSFC,  & 
+          PSSFC,    PAPRC,    PAPRSM,   PAPRS,   LOCUM,  &
+          KTYPE,    ICBOT,    ICTOP,    ZTU,     ZQU,    &
+          ZLU,      ZLUDE,    ZMFU,     ZMFD,    ZRAIN,  &
+          PSRAIN,   PSEVAP,   PSHEAT,   PSDISS,  PSMELT, &
+          PCTE,     sig1,     lndj)
+!
+!     TO INCLUDE THE CLOUD WATER AND CLOUD ICE DETRAINED FROM CONVECTION
+!
+      IF(fdbk.ge.1.0e-9) THEN
+      DO 20 K=1,km
+      DO 20 j=1,lq
+      If(PCTE(j,k).GT.0.0) then
+        ZTPP1=pt(j,k)+PTTE(j,k)*ZTMST
+        if(ZTPP1.ge.t000) then
+           fliq=1.0
+           ZALF=0.0
+        else if(ZTPP1.le.hgfr) then
+           fliq=0.0
+           ZALF=ALF
+        else
+           ZTC=ZTPP1-t000
+           fliq=0.0059+0.9941*exp(-0.003102*ZTC*ZTC)
+           ZALF=ALF
+        endif
+        fice=1.0-fliq
+        pqc(j,k)=pqc(j,k)+fliq*PCTE(j,k)*ZTMST
+        pqi(j,k)=pqi(j,k)+fice*PCTE(j,k)*ZTMST
+        PTTE(j,k)=PTTE(j,k)-ZALF*RCPD*fliq*PCTE(j,k)
+      Endif
+   20 CONTINUE
+      ENDIF
+!
+      DO 75 k=1,km
+        DO 75 j=1,lq
+          pt(j,k)=ZTP1(j,k)+PTTE(j,k)*ZTMST
+          ZQP1(j,k)=ZQP1(j,k)+(PQTE(j,k)-ZQQ(j,k))*ZTMST
+          pqv(j,k)=ZQP1(j,k)/(1.0-ZQP1(j,k))
+   75 CONTINUE
+      DO 85 j=1,lq
+        zprecc(j)=amax1(0.0,(PRSFC(j)+PSSFC(j))*ZTMST)
+   85 CONTINUE
+      IF (LMFDUDV) THEN
+        DO 100 k=1,km
+          DO 100 j=1,lq
+            pu(j,k)=pu(j,k)+PVOM(j,k)*ZTMST
+            pv(j,k)=pv(j,k)+PVOL(j,k)*ZTMST
+  100   CONTINUE
+      ENDIF
+!
+      RETURN
+      END SUBROUTINE TIECNV
+
+!#############################################################
+!
+!             LEVEL 2 SUBROUTINEs
+!
+!#############################################################
+!***********************************************************
+!           SUBROUTINE CUMASTR_NEW
+!***********************************************************
+      SUBROUTINE CUMASTR_NEW                             &
+         (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTEN,  &
+          PQEN,     PUEN,     PVEN,     PVERV,    PQSEN, &
+          PQHFL,    ZTMST,    PAP,      PAPH,     PGEO,  &
+          PTTE,     PQTE,     PVOM,     PVOL,     PRSFC, &
+          PSSFC,    PAPRC,    PAPRSM,   PAPRS,    LDCUM, &
+          KTYPE,    KCBOT,    KCTOP,    PTU,      PQU,   &
+          PLU,      PLUDE,    PMFU,     PMFD,     PRAIN, &
+          PSRAIN,   PSEVAP,   PSHEAT,   PSDISS,   PSMELT,& 
+          PCTE,     sig1,     lndj)
+!
+!***CUMASTR*  MASTER ROUTINE FOR CUMULUS MASSFLUX-SCHEME
+!     M.TIEDTKE      E.C.M.W.F.     1986/1987/1989
+!***PURPOSE
+!   -------
+!          THIS ROUTINE COMPUTES THE PHYSICAL TENDENCIES OF THE
+!     PROGNOSTIC VARIABLES T,Q,U AND V DUE TO CONVECTIVE PROCESSES.
+!     PROCESSES CONSIDERED ARE: CONVECTIVE FLUXES, FORMATION OF
+!     PRECIPITATION, EVAPORATION OF FALLING RAIN BELOW CLOUD BASE,
+!     SATURATED CUMULUS DOWNDRAFTS.
+!***INTERFACE.
+!   ----------
+!          *CUMASTR* IS CALLED FROM *MSSFLX*
+!     THE ROUTINE TAKES ITS INPUT FROM THE LONG-TERM STORAGE
+!     T,Q,U,V,PHI AND P AND MOISTURE TENDENCIES.
+!     IT RETURNS ITS OUTPUT TO THE SAME SPACE
+!      1.MODIFIED TENDENCIES OF MODEL VARIABLES
+!      2.RATES OF CONVECTIVE PRECIPITATION
+!        (USED IN SUBROUTINE SURF)
+!      3.CLOUD BASE, CLOUD TOP AND PRECIP FOR RADIATION
+!        (USED IN SUBROUTINE CLOUD)
+!***METHOD
+!   ------
+!     PARAMETERIZATION IS DONE USING A MASSFLUX-SCHEME.
+!        (1) DEFINE CONSTANTS AND PARAMETERS
+!        (2) SPECIFY VALUES (T,Q,QS...) AT HALF LEVELS AND
+!            INITIALIZE UPDRAFT- AND DOWNDRAFT-VALUES IN 'CUINI'
+!        (3) CALCULATE CLOUD BASE IN 'CUBASE'
+!            AND SPECIFY CLOUD BASE MASSFLUX FROM PBL MOISTURE BUDGET
+!        (4) DO CLOUD ASCENT IN 'CUASC' IN ABSENCE OF DOWNDRAFTS
+!        (5) DO DOWNDRAFT CALCULATIONS:
+!              (A) DETERMINE VALUES AT LFS IN 'CUDLFS'
+!              (B) DETERMINE MOIST DESCENT IN 'CUDDRAF'
+!              (C) RECALCULATE CLOUD BASE MASSFLUX CONSIDERING THE
+!                  EFFECT OF CU-DOWNDRAFTS
+!        (6) DO FINAL CLOUD ASCENT IN 'CUASC'
+!        (7) DO FINAL ADJUSMENTS TO CONVECTIVE FLUXES IN 'CUFLX',
+!            DO EVAPORATION IN SUBCLOUD LAYER
+!        (8) CALCULATE INCREMENTS OF T AND Q IN 'CUDTDQ'
+!        (9) CALCULATE INCREMENTS OF U AND V IN 'CUDUDV'
+!***EXTERNALS.
+!   ----------
+!       CUINI:  INITIALIZES VALUES AT VERTICAL GRID USED IN CU-PARAMETR.
+!       CUBASE: CLOUD BASE CALCULATION FOR PENETR.AND SHALLOW CONVECTION
+!       CUASC:  CLOUD ASCENT FOR ENTRAINING PLUME
+!       CUDLFS: DETERMINES VALUES AT LFS FOR DOWNDRAFTS
+!       CUDDRAF:DOES MOIST DESCENT FOR CUMULUS DOWNDRAFTS
+!       CUFLX:  FINAL ADJUSTMENTS TO CONVECTIVE FLUXES (ALSO IN PBL)
+!       CUDQDT: UPDATES TENDENCIES FOR T AND Q
+!       CUDUDV: UPDATES TENDENCIES FOR U AND V
+!***SWITCHES.
+!   --------
+!          LMFPEN=.T.   PENETRATIVE CONVECTION IS SWITCHED ON
+!          LMFSCV=.T.   SHALLOW CONVECTION IS SWITCHED ON
+!          LMFMID=.T.   MIDLEVEL CONVECTION IS SWITCHED ON
+!          LMFDD=.T.    CUMULUS DOWNDRAFTS SWITCHED ON
+!          LMFDUDV=.T.  CUMULUS FRICTION SWITCHED ON
+!***
+!     MODEL PARAMETERS (DEFINED IN SUBROUTINE CUPARAM)
+!     ------------------------------------------------
+!     ENTRPEN    ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+!     ENTRSCV    ENTRAINMENT RATE FOR SHALLOW CONVECTION
+!     ENTRMID    ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+!     ENTRDD     ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS
+!     CMFCTOP    RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANCY
+!                LEVEL
+!     CMFCMAX    MAXIMUM MASSFLUX VALUE ALLOWED FOR
+!     CMFCMIN    MINIMUM MASSFLUX VALUE (FOR SAFETY)
+!     CMFDEPS    FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+!     CPRCON     COEFFICIENT FOR CONVERSION FROM CLOUD WATER TO RAIN
+!***REFERENCE.
+!   ----------
+!          PAPER ON MASSFLUX SCHEME (TIEDTKE,1989)
+!-----------------------------------------------------------------
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+      INTEGER   KLON, KLEV, KLEVP1
+      INTEGER   KLEVM1
+      REAL      ZTMST
+      REAL      PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT, ZCONS2
+      INTEGER   JK,JL,IKB
+      REAL      ZQUMQE, ZDQMIN, ZMFMAX, ZALVDCP, ZQALV
+      REAL      ZHSAT, ZGAM, ZZZ, ZHHAT, ZBI, ZRO, ZDZ, ZDHDZ, ZDEPTH
+      REAL      ZFAC, ZRH, ZPBMPT, DEPT, ZHT, ZEPS
+      INTEGER   ICUM, ITOPM2
+      REAL     PTEN(KLON,KLEV),        PQEN(KLON,KLEV), &
+              PUEN(KLON,KLEV),        PVEN(KLON,KLEV),  &
+              PTTE(KLON,KLEV),        PQTE(KLON,KLEV),  &
+              PVOM(KLON,KLEV),        PVOL(KLON,KLEV),  &
+              PQSEN(KLON,KLEV),       PGEO(KLON,KLEV),  &
+              PAP(KLON,KLEV),         PAPH(KLON,KLEVP1),& 
+              PVERV(KLON,KLEV),       PQHFL(KLON)
+      REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),  &
+              PLU(KLON,KLEV),         PLUDE(KLON,KLEV), &
+              PMFU(KLON,KLEV),        PMFD(KLON,KLEV),  &
+              PAPRC(KLON),            PAPRS(KLON),      &
+              PAPRSM(KLON),           PRAIN(KLON),      &
+              PRSFC(KLON),            PSSFC(KLON)
+      REAL     ZTENH(KLON,KLEV),       ZQENH(KLON,KLEV),&
+              ZGEOH(KLON,KLEV),       ZQSENH(KLON,KLEV),&
+              ZTD(KLON,KLEV),         ZQD(KLON,KLEV),   &
+              ZMFUS(KLON,KLEV),       ZMFDS(KLON,KLEV), &
+              ZMFUQ(KLON,KLEV),       ZMFDQ(KLON,KLEV), &
+              ZDMFUP(KLON,KLEV),      ZDMFDP(KLON,KLEV),& 
+              ZMFUL(KLON,KLEV),       ZRFL(KLON),       &
+              ZUU(KLON,KLEV),         ZVU(KLON,KLEV),   &
+              ZUD(KLON,KLEV),         ZVD(KLON,KLEV)
+      REAL     ZENTR(KLON),            ZHCBASE(KLON),   &
+              ZMFUB(KLON),            ZMFUB1(KLON),     &
+              ZDQPBL(KLON),           ZDQCV(KLON) 
+      REAL     ZSFL(KLON),             ZDPMEL(KLON,KLEV), &
+              PCTE(KLON,KLEV),        ZCAPE(KLON),        &
+              ZHEAT(KLON),            ZHHATT(KLON,KLEV),  &
+              ZHMIN(KLON),            ZRELH(KLON)
+      REAL     sig1(KLEV)
+      INTEGER  ILAB(KLON,KLEV),        IDTOP(KLON),   &
+              ICTOP0(KLON),           ILWMIN(KLON)    
+      INTEGER  KCBOT(KLON),            KCTOP(KLON),   &
+              KTYPE(KLON),            IHMIN(KLON),    &
+              KTOP0,                  lndj(KLON)
+      LOGICAL  LDCUM(KLON)
+      LOGICAL  LODDRAF(KLON),          LLO1
+!-------------------------------------------
+!     1.    SPECIFY CONSTANTS AND PARAMETERS
+!-------------------------------------------
+  100 CONTINUE
+      ZCONS2=1./(G*ZTMST)
+!--------------------------------------------------------------
+!*    2.    INITIALIZE VALUES AT VERTICAL GRID POINTS IN 'CUINI'
+!--------------------------------------------------------------
+  200 CONTINUE
+      CALL CUINI &
+         (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTEN,  &
+          PQEN,     PQSEN,    PUEN,     PVEN,     PVERV, &
+          PGEO,     PAPH,     ZGEOH,    ZTENH,    ZQENH,  &
+          ZQSENH,   ILWMIN,   PTU,      PQU,      ZTD,   &
+          ZQD,      ZUU,      ZVU,      ZUD,      ZVD,   &
+          PMFU,     PMFD,     ZMFUS,    ZMFDS,    ZMFUQ, &
+          ZMFDQ,    ZDMFUP,   ZDMFDP,   ZDPMEL,   PLU,  &
+          PLUDE,    ILAB)
+!----------------------------------
+!*    3.0   CLOUD BASE CALCULATIONS
+!----------------------------------
+  300 CONTINUE
+!*         (A) DETERMINE CLOUD BASE VALUES IN 'CUBASE'
+!          -------------------------------------------
+      CALL CUBASE &
+         (KLON,     KLEV,     KLEVP1,   KLEVM1,   ZTENH, &
+          ZQENH,    ZGEOH,    PAPH,     PTU,      PQU,   &
+          PLU,      PUEN,     PVEN,     ZUU,      ZVU,   &
+          LDCUM,    KCBOT,    ILAB)
+!*          (B) DETERMINE TOTAL MOISTURE CONVERGENCE AND
+!*              THEN DECIDE ON TYPE OF CUMULUS CONVECTION
+!               -----------------------------------------
+       JK=1
+       DO 310 JL=1,KLON
+       ZDQCV(JL) =PQTE(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
+       ZDQPBL(JL)=0.0
+       IDTOP(JL)=0
+  310  CONTINUE
+       DO 320 JK=2,KLEV
+       DO 315 JL=1,KLON
+       ZDQCV(JL)=ZDQCV(JL)+PQTE(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
+       IF(JK.GE.KCBOT(JL)) ZDQPBL(JL)=ZDQPBL(JL)+PQTE(JL,JK)  &
+                                    *(PAPH(JL,JK+1)-PAPH(JL,JK))
+  315 CONTINUE
+  320 CONTINUE
+      DO 340 JL=1,KLON
+         KTYPE(JL)=0
+      IF(ZDQCV(JL).GT.MAX(0.,1.1*PQHFL(JL)*G)) THEN
+         KTYPE(JL)=1
+      ELSE
+         KTYPE(JL)=2
+      ENDIF
+!*         (C) DETERMINE MOISTURE SUPPLY FOR BOUNDARY LAYER
+!*             AND DETERMINE CLOUD BASE MASSFLUX IGNORING
+!*             THE EFFECTS OF DOWNDRAFTS AT THIS STAGE
+!              ------------------------------------------
+      IKB=KCBOT(JL)
+      ZQUMQE=PQU(JL,IKB)+PLU(JL,IKB)-ZQENH(JL,IKB)
+      ZDQMIN=MAX(0.01*ZQENH(JL,IKB),1.E-10)
+      IF(ZDQPBL(JL).GT.0..AND.ZQUMQE.GT.ZDQMIN.AND.LDCUM(JL)) THEN
+         ZMFUB(JL)=ZDQPBL(JL)/(G*MAX(ZQUMQE,ZDQMIN))
+      ELSE
+         ZMFUB(JL)=0.01
+         LDCUM(JL)=.FALSE.
+      ENDIF
+      ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
+      ZMFUB(JL)=MIN(ZMFUB(JL),ZMFMAX)
+!------------------------------------------------------
+!*    4.0   DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME
+!------------------------------------------------------
+  400 CONTINUE
+!*         (A) ESTIMATE CLOUD HEIGHT FOR ENTRAINMENT/DETRAINMENT
+!*             CALCULATIONS IN CUASC (MAX.POSSIBLE CLOUD HEIGHT
+!*             FOR NON-ENTRAINING PLUME, FOLLOWING A.-S.,1974)
+! -------------------------------------------------------------
+      IKB=KCBOT(JL)
+      ZHCBASE(JL)=CPD*PTU(JL,IKB)+ZGEOH(JL,IKB)+ALV*PQU(JL,IKB)
+      ICTOP0(JL)=KCBOT(JL)-1
+  340 CONTINUE
+      ZALVDCP=ALV/CPD
+      ZQALV=1./ALV
+      DO 420 JK=KLEVM1,3,-1
+      DO 420 JL=1,KLON
+      ZHSAT=CPD*ZTENH(JL,JK)+ZGEOH(JL,JK)+ALV*ZQSENH(JL,JK)
+      ZGAM=C5LES*ZALVDCP*ZQSENH(JL,JK)/  &
+          ((1.-VTMPC1*ZQSENH(JL,JK))*(ZTENH(JL,JK)-C4LES)**2)
+      ZZZ=CPD*ZTENH(JL,JK)*0.608
+      ZHHAT=ZHSAT-(ZZZ+ZGAM*ZZZ)/(1.+ZGAM*ZZZ*ZQALV)* &
+                 MAX(ZQSENH(JL,JK)-ZQENH(JL,JK),0.)
+      ZHHATT(JL,JK)=ZHHAT
+      IF(JK.LT.ICTOP0(JL).AND.ZHCBASE(JL).GT.ZHHAT) ICTOP0(JL)=JK
+  420 CONTINUE
+      DO 430 JL=1,KLON
+      JK=KCBOT(JL)
+      ZHSAT=CPD*ZTENH(JL,JK)+ZGEOH(JL,JK)+ALV*ZQSENH(JL,JK)
+      ZGAM=C5LES*ZALVDCP*ZQSENH(JL,JK)/   &
+          ((1.-VTMPC1*ZQSENH(JL,JK))*(ZTENH(JL,JK)-C4LES)**2)
+      ZZZ=CPD*ZTENH(JL,JK)*0.608
+      ZHHAT=ZHSAT-(ZZZ+ZGAM*ZZZ)/(1.+ZGAM*ZZZ*ZQALV)* &
+                 MAX(ZQSENH(JL,JK)-ZQENH(JL,JK),0.)
+      ZHHATT(JL,JK)=ZHHAT
+  430 CONTINUE
+!
+! Find lowest possible org. detrainment level
+!
+      DO 440 JL = 1, KLON
+         ZHMIN(JL) = 0.
+         IF( LDCUM(JL).AND.KTYPE(JL).EQ.1 ) THEN
+            IHMIN(JL) = KCBOT(JL)
+         ELSE
+            IHMIN(JL) = -1
+         END IF
+ 440  CONTINUE 
+!
+      ZBI = 1./(25.*G)
+      DO 450 JK = KLEV, 1, -1
+      DO 450 JL = 1, KLON
+      LLO1 = LDCUM(JL).AND.KTYPE(JL).EQ.1.AND.IHMIN(JL).EQ.KCBOT(JL)
+      IF (LLO1.AND.JK.LT.KCBOT(JL).AND.JK.GE.ICTOP0(JL)) THEN
+        IKB = KCBOT(JL)
+        ZRO = RD*ZTENH(JL,JK)/(G*PAPH(JL,JK))
+        ZDZ = (PAPH(JL,JK)-PAPH(JL,JK-1))*ZRO
+        ZDHDZ=(CPD*(PTEN(JL,JK-1)-PTEN(JL,JK))+ALV*(PQEN(JL,JK-1)-   &
+          PQEN(JL,JK))+(PGEO(JL,JK-1)-PGEO(JL,JK)))*G/(PGEO(JL,      &
+          JK-1)-PGEO(JL,JK))
+        ZDEPTH = ZGEOH(JL,JK) - ZGEOH(JL,IKB)
+        ZFAC = SQRT(1.+ZDEPTH*ZBI)
+        ZHMIN(JL) = ZHMIN(JL) + ZDHDZ*ZFAC*ZDZ
+        ZRH = -ALV*(ZQSENH(JL,JK)-ZQENH(JL,JK))*ZFAC
+        IF (ZHMIN(JL).GT.ZRH) IHMIN(JL) = JK
+      END IF
+ 450  CONTINUE 
+      DO 460 JL = 1, KLON
+      IF (LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN
+        IF (IHMIN(JL).LT.ICTOP0(JL)) IHMIN(JL) = ICTOP0(JL)
+      END IF
+      if(nentr.eq.1) then
+        IF(KTYPE(JL).EQ.1) THEN
+          ZENTR(JL)=ENTRPEN
+        ELSE
+          ZENTR(JL)=ENTRSCV
+        ENDIF
+        if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
+      else
+        ZDEPTH=ZRG*(ZGEOH(JL,ICTOP0(JL))-ZGEOH(JL,KCBOT(JL)))
+        ZENTR(JL)=MAX(ENTRPEN,1.5/MAX(500.0,ZDEPTH))
+        if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
+      endif
+ 460  CONTINUE 
+!*         (B) DO ASCENT IN 'CUASC'IN ABSENCE OF DOWNDRAFTS
+!----------------------------------------------------------
+      CALL CUASC_NEW &
+         (KLON,     KLEV,     KLEVP1,   KLEVM1,   ZTENH,   &
+          ZQENH,    PUEN,     PVEN,     PTEN,     PQEN,    &
+          PQSEN,    PGEO,     ZGEOH,    PAP,      PAPH,    &
+          PQTE,     PVERV,    ILWMIN,   LDCUM,    ZHCBASE, &
+          KTYPE,    ILAB,     PTU,      PQU,      PLU,     &
+          ZUU,      ZVU,      PMFU,     ZMFUB,    ZENTR,   &
+          ZMFUS,    ZMFUQ,    ZMFUL,    PLUDE,    ZDMFUP,  &
+          KCBOT,    KCTOP,    ICTOP0,   ICUM,     ZTMST,   &
+          IHMIN,    ZHHATT,   ZQSENH)
+      IF(ICUM.EQ.0) GO TO 1000
+!*     (C) CHECK CLOUD DEPTH AND CHANGE ENTRAINMENT RATE ACCORDINGLY
+!          CALCULATE PRECIPITATION RATE (FOR DOWNDRAFT CALCULATION)
+!------------------------------------------------------------------
+      DO 480 JL=1,KLON
+      ZPBMPT=PAPH(JL,KCBOT(JL))-PAPH(JL,KCTOP(JL))
+      IF(LDCUM(JL)) ICTOP0(JL)=KCTOP(JL)
+      IF(LDCUM(JL).AND.KTYPE(JL).EQ.1.AND.ZPBMPT.LT.ZDNOPRC) KTYPE(JL)=2
+      IF(KTYPE(JL).EQ.2.and.nentr.eq.1) then
+        ZENTR(JL)=ENTRSCV
+        if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
+      endif
+      if(nentr.eq.2) then
+        ZDEPTH=ZRG*(ZGEOH(JL,KCTOP(JL))-ZGEOH(JL,KCBOT(JL)))
+        ZENTR(JL)=MAX(ENTRPEN,1.5/MAX(500.0,ZDEPTH))
+        if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
+      endif
+      ZRFL(JL)=ZDMFUP(JL,1)
+  480 CONTINUE
+      DO 490 JK=2,KLEV
+      DO 490 JL=1,KLON
+          ZRFL(JL)=ZRFL(JL)+ZDMFUP(JL,JK)
+  490 CONTINUE
+!-----------------------------------------
+!*    5.0   CUMULUS DOWNDRAFT CALCULATIONS
+!-----------------------------------------
+  500 CONTINUE
+      IF(LMFDD) THEN
+!*      (A) DETERMINE LFS IN 'CUDLFS'
+!--------------------------------------
+         CALL CUDLFS &
+         (KLON,     KLEV,     KLEVP1,   ZTENH,    ZQENH,  &
+          PUEN,     PVEN,     ZGEOH,    PAPH,     PTU,    &
+          PQU,      ZUU,      ZVU,      LDCUM,    KCBOT,  &
+          KCTOP,    ZMFUB,    ZRFL,     ZTD,      ZQD,    &
+          ZUD,      ZVD,      PMFD,     ZMFDS,    ZMFDQ,  &
+          ZDMFDP,   IDTOP,    LODDRAF)
+!*     (B)  DETERMINE DOWNDRAFT T,Q AND FLUXES IN 'CUDDRAF'
+!------------------------------------------------------------
+         CALL CUDDRAF &
+         (KLON,     KLEV,     KLEVP1,   ZTENH,    ZQENH,  &
+          PUEN,     PVEN,     ZGEOH,    PAPH,     ZRFL,   &
+          LODDRAF,  ZTD,      ZQD,      ZUD,      ZVD,    &
+          PMFD,     ZMFDS,    ZMFDQ,    ZDMFDP)
+!*     (C)  RECALCULATE CONVECTIVE FLUXES DUE TO EFFECT OF
+!           DOWNDRAFTS ON BOUNDARY LAYER MOISTURE BUDGET
+!-----------------------------------------------------------
+      END IF
+!
+!-- 5.1 Recalculate cloud base massflux from a cape closure
+!       for deep convection (ktype=1) and by PBL equilibrium
+!       taking downdrafts into account for shallow convection
+!       (ktype=2)
+!       implemented by Y. WANG based on ECHAM4 in Nov. 2001.
+!
+      DO 510 JL=1,KLON
+        ZHEAT(JL)=0.0
+        ZCAPE(JL)=0.0
+        ZRELH(JL)=0.0
+        ZMFUB1(JL)=ZMFUB(JL)
+  510 CONTINUE
+!
+      DO 511 JL=1,KLON
+      IF(LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN
+      KTOP0=MAX(12,KCTOP(JL))
+       DO JK=2,KLEV
+       IF(JK.LE.KCBOT(JL).AND.JK.GT.KCTOP(JL)) THEN
+         ZRO=PAPH(JL,JK)/(RD*ZTENH(JL,JK))
+         ZDZ=(PAPH(JL,JK)-PAPH(JL,JK-1))/(G*ZRO)
+         ZHEAT(JL)=ZHEAT(JL)+((PTEN(JL,JK-1)-PTEN(JL,JK)   &
+           +G*ZDZ/CPD)/ZTENH(JL,JK)+0.608*(PQEN(JL,JK-1)-  &
+           PQEN(JL,JK)))*(PMFU(JL,JK)+PMFD(JL,JK))*G/ZRO
+         ZCAPE(JL)=ZCAPE(JL)+G*((PTU(JL,JK)*(1.+.608*PQU(JL,JK) &
+           -PLU(JL,JK)))/(ZTENH(JL,JK)*(1.+.608*ZQENH(JL,JK))) &
+           -1.0)*ZDZ
+       ENDIF
+       IF(JK.LE.KCBOT(JL).AND.JK.GT.KTOP0) THEN
+         dept=(PAPH(JL,JK)-PAPH(JL,JK-1))/(PAPH(JL,KCBOT(JL))-  &
+            PAPH(JL,KTOP0))
+         ZRELH(JL)=ZRELH(JL)+dept*PQEN(JL,JK)/PQSEN(JL,JK)
+       ENDIF
+       ENDDO
+!
+       IF(ZRELH(JL).GE.CRIRH) THEN
+         IKB=KCBOT(JL)
+!         ZHT=MAX(0.0,(ZCAPE(JL)-300.0))/(ZTAU*ZHEAT(JL))
+         ZHT=MAX(0.0,(ZCAPE(JL)-0.0))/(ZTAU*ZHEAT(JL))
+         ZMFUB1(JL)=MAX(ZMFUB(JL)*ZHT,0.01)
+         ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
+         ZMFUB1(JL)=MIN(ZMFUB1(JL),ZMFMAX)
+       ELSE
+         ZMFUB1(JL)=0.01
+         ZMFUB(JL)=0.01
+         LDCUM(JL)=.FALSE.
+        ENDIF
+       ENDIF
+  511  CONTINUE
+!
+!*  5.2   RECALCULATE CONVECTIVE FLUXES DUE TO EFFECT OF
+!         DOWNDRAFTS ON BOUNDARY LAYER MOISTURE BUDGET
+!--------------------------------------------------------
+       DO 512 JL=1,KLON
+        IF(KTYPE(JL).NE.1) THEN
+           IKB=KCBOT(JL)
+           IF(PMFD(JL,IKB).LT.0.0.AND.LODDRAF(JL)) THEN
+              ZEPS=CMFDEPS
+           ELSE
+              ZEPS=0.
+           ENDIF
+           ZQUMQE=PQU(JL,IKB)+PLU(JL,IKB)-          &
+                 ZEPS*ZQD(JL,IKB)-(1.-ZEPS)*ZQENH(JL,IKB)
+           ZDQMIN=MAX(0.01*ZQENH(JL,IKB),1.E-10)
+           ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
+           IF(ZDQPBL(JL).GT.0..AND.ZQUMQE.GT.ZDQMIN.AND.LDCUM(JL) &
+             .AND.ZMFUB(JL).LT.ZMFMAX) THEN
+              ZMFUB1(JL)=ZDQPBL(JL)/(G*MAX(ZQUMQE,ZDQMIN))
+           ELSE
+              ZMFUB1(JL)=ZMFUB(JL)
+           ENDIF
+           LLO1=(KTYPE(JL).EQ.2).AND.ABS(ZMFUB1(JL)  &
+                -ZMFUB(JL)).LT.0.2*ZMFUB(JL)
+           IF(.NOT.LLO1) ZMFUB1(JL)=ZMFUB(JL)
+           ZMFUB1(JL)=MIN(ZMFUB1(JL),ZMFMAX)
+        END IF
+  512   CONTINUE
+        DO 530 JK=1,KLEV
+        DO 530 JL=1,KLON
+        IF(LDCUM(JL)) THEN
+           ZFAC=ZMFUB1(JL)/MAX(ZMFUB(JL),1.E-10)
+           PMFD(JL,JK)=PMFD(JL,JK)*ZFAC
+           ZMFDS(JL,JK)=ZMFDS(JL,JK)*ZFAC
+           ZMFDQ(JL,JK)=ZMFDQ(JL,JK)*ZFAC
+           ZDMFDP(JL,JK)=ZDMFDP(JL,JK)*ZFAC
+        ELSE
+           PMFD(JL,JK)=0.0
+           ZMFDS(JL,JK)=0.0
+           ZMFDQ(JL,JK)=0.0
+           ZDMFDP(JL,JK)=0.0
+        ENDIF
+  530   CONTINUE
+        DO 538 JL=1,KLON
+           IF(LDCUM(JL)) THEN
+              ZMFUB(JL)=ZMFUB1(JL)
+           ELSE
+              ZMFUB(JL)=0.0
+           ENDIF
+  538   CONTINUE
+!
+!---------------------------------------------------------------
+!*    6.0      DETERMINE FINAL CLOUD ASCENT FOR ENTRAINING PLUME
+!*             FOR PENETRATIVE CONVECTION (TYPE=1),
+!*             FOR SHALLOW TO MEDIUM CONVECTION (TYPE=2)
+!*             AND FOR MID-LEVEL CONVECTION (TYPE=3).
+!---------------------------------------------------------------
+  600 CONTINUE
+      CALL CUASC_NEW &
+         (KLON,     KLEV,     KLEVP1,   KLEVM1,   ZTENH,  &
+          ZQENH,    PUEN,     PVEN,     PTEN,     PQEN,   &
+          PQSEN,    PGEO,     ZGEOH,    PAP,      PAPH,   &
+          PQTE,     PVERV,    ILWMIN,   LDCUM,    ZHCBASE,& 
+          KTYPE,    ILAB,     PTU,      PQU,      PLU,    &
+          ZUU,      ZVU,      PMFU,     ZMFUB,    ZENTR,  &
+          ZMFUS,    ZMFUQ,    ZMFUL,    PLUDE,    ZDMFUP, &
+          KCBOT,    KCTOP,    ICTOP0,   ICUM,     ZTMST,  &
+          IHMIN,    ZHHATT,   ZQSENH)
+!----------------------------------------------------------
+!*    7.0      DETERMINE FINAL CONVECTIVE FLUXES IN 'CUFLX'
+!----------------------------------------------------------
+  700 CONTINUE
+      CALL CUFLX &
+         (KLON,     KLEV,     KLEVP1,   PQEN,     PQSEN,  &
+          ZTENH,    ZQENH,    PAPH,     ZGEOH,    KCBOT,  &
+          KCTOP,    IDTOP,    KTYPE,    LODDRAF,  LDCUM,  &
+          PMFU,     PMFD,     ZMFUS,    ZMFDS,    ZMFUQ,  &
+          ZMFDQ,    ZMFUL,    PLUDE,    ZDMFUP,   ZDMFDP, &
+          ZRFL,     PRAIN,    PTEN,     ZSFL,     ZDPMEL, &
+          ITOPM2,   ZTMST,    sig1)
+!----------------------------------------------------------------
+!*    8.0      UPDATE TENDENCIES FOR T AND Q IN SUBROUTINE CUDTDQ
+!----------------------------------------------------------------
+  800 CONTINUE
+      CALL CUDTDQ                                          &
+         (KLON,     KLEV,     KLEVP1,   ITOPM2,   PAPH,    &
+          LDCUM,    PTEN,     PTTE,     PQTE,     ZMFUS,   &
+          ZMFDS,    ZMFUQ,    ZMFDQ,    ZMFUL,    ZDMFUP,  &
+          ZDMFDP,   ZTMST,    ZDPMEL,   PRAIN,    ZRFL,    &
+          ZSFL,     PSRAIN,   PSEVAP,   PSHEAT,   PSMELT,  &
+          PRSFC,    PSSFC,    PAPRC,    PAPRSM,   PAPRS,   &
+          PQEN,     PQSEN,    PLUDE,    PCTE)
+!----------------------------------------------------------------
+!*    9.0      UPDATE TENDENCIES FOR U AND U IN SUBROUTINE CUDUDV
+!----------------------------------------------------------------
+  900 CONTINUE
+      IF(LMFDUDV) THEN
+      CALL CUDUDV  &
+         (KLON,     KLEV,     KLEVP1,   ITOPM2,   KTYPE,   &
+          KCBOT,    PAPH,     LDCUM,    PUEN,     PVEN,    &
+          PVOM,     PVOL,     ZUU,      ZUD,      ZVU,     &
+          ZVD,      PMFU,     PMFD,     PSDISS)
+      END IF
+ 1000 CONTINUE
+      RETURN
+      END SUBROUTINE CUMASTR_NEW
+!
+
+!#############################################################
+!
+!             LEVEL 3 SUBROUTINEs
+!
+!#############################################################
+!**********************************************
+!       SUBROUTINE CUINI
+!**********************************************
+!
+      SUBROUTINE CUINI                                    &
+         (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTEN,   &
+          PQEN,     PQSEN,    PUEN,     PVEN,     PVERV,  &
+          PGEO,     PAPH,     PGEOH,    PTENH,    PQENH,  &
+          PQSENH,   KLWMIN,   PTU,      PQU,      PTD,    &
+          PQD,      PUU,      PVU,      PUD,      PVD,    &
+          PMFU,     PMFD,     PMFUS,    PMFDS,    PMFUQ,  &
+          PMFDQ,    PDMFUP,   PDMFDP,   PDPMEL,   PLU,    &
+          PLUDE,    KLAB)
+!      M.TIEDTKE         E.C.M.W.F.     12/89
+!***PURPOSE
+!   -------
+!          THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC.
+!          TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME),
+!          AND INITIALIZES VALUES FOR UPDRAFTS AND DOWNDRAFTS
+!***INTERFACE
+!   ---------
+!          THIS ROUTINE IS CALLED FROM *CUMASTR*.
+!***METHOD.
+!  --------
+!          FOR EXTRAPOLATION TO HALF LEVELS SEE TIEDTKE(1989)
+!***EXTERNALS
+!   ---------
+!          *CUADJTQ* TO SPECIFY QS AT HALF LEVELS
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+      INTEGER   KLON, KLEV, KLEVP1
+      INTEGER   klevm1
+      INTEGER   JK,JL,IK, ICALL
+      REAL      ZDP, ZZS
+      REAL     PTEN(KLON,KLEV),        PQEN(KLON,KLEV),    &
+              PUEN(KLON,KLEV),        PVEN(KLON,KLEV),     &
+              PQSEN(KLON,KLEV),       PVERV(KLON,KLEV),    &
+              PGEO(KLON,KLEV),        PGEOH(KLON,KLEV),    &
+              PAPH(KLON,KLEVP1),      PTENH(KLON,KLEV),    &
+              PQENH(KLON,KLEV),       PQSENH(KLON,KLEV)
+      REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),     &
+              PTD(KLON,KLEV),         PQD(KLON,KLEV),      &
+              PUU(KLON,KLEV),         PUD(KLON,KLEV),      &
+              PVU(KLON,KLEV),         PVD(KLON,KLEV),      &
+              PMFU(KLON,KLEV),        PMFD(KLON,KLEV),     &
+              PMFUS(KLON,KLEV),       PMFDS(KLON,KLEV),    &
+              PMFUQ(KLON,KLEV),       PMFDQ(KLON,KLEV),    &
+              PDMFUP(KLON,KLEV),      PDMFDP(KLON,KLEV),   & 
+              PLU(KLON,KLEV),         PLUDE(KLON,KLEV)
+      REAL     ZWMAX(KLON),            ZPH(KLON),          &
+              PDPMEL(KLON,KLEV)
+      INTEGER  KLAB(KLON,KLEV),        KLWMIN(KLON)
+      LOGICAL  LOFLAG(KLON)
+!------------------------------------------------------------
+!*    1.       SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS
+!*             ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE
+!*             FIND LEVEL OF MAXIMUM VERTICAL VELOCITY
+! -----------------------------------------------------------
+  100 CONTINUE
+      ZDP=0.5
+      DO 130 JK=2,KLEV
+      DO 110 JL=1,KLON
+      PGEOH(JL,JK)=PGEO(JL,JK)+(PGEO(JL,JK-1)-PGEO(JL,JK))*ZDP
+      PTENH(JL,JK)=(MAX(CPD*PTEN(JL,JK-1)+PGEO(JL,JK-1),   &
+                  CPD*PTEN(JL,JK)+PGEO(JL,JK))-PGEOH(JL,JK))*RCPD
+      PQSENH(JL,JK)=PQSEN(JL,JK-1)
+      ZPH(JL)=PAPH(JL,JK)
+      LOFLAG(JL)=.TRUE.
+  110 CONTINUE
+      IK=JK
+      ICALL=0
+      CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTENH,PQSENH,LOFLAG,ICALL)
+      DO 120 JL=1,KLON
+      PQENH(JL,JK)=MIN(PQEN(JL,JK-1),PQSEN(JL,JK-1))    &
+                 +(PQSENH(JL,JK)-PQSEN(JL,JK-1))
+      PQENH(JL,JK)=MAX(PQENH(JL,JK),0.)
+  120 CONTINUE
+  130 CONTINUE
+      DO 140 JL=1,KLON
+      PTENH(JL,KLEV)=(CPD*PTEN(JL,KLEV)+PGEO(JL,KLEV)-   &
+                     PGEOH(JL,KLEV))*RCPD
+      PQENH(JL,KLEV)=PQEN(JL,KLEV)
+      PTENH(JL,1)=PTEN(JL,1)
+      PQENH(JL,1)=PQEN(JL,1)
+      PGEOH(JL,1)=PGEO(JL,1)
+      KLWMIN(JL)=KLEV
+      ZWMAX(JL)=0.
+  140 CONTINUE
+      DO 160 JK=KLEVM1,2,-1
+      DO 150 JL=1,KLON
+      ZZS=MAX(CPD*PTENH(JL,JK)+PGEOH(JL,JK),   &
+             CPD*PTENH(JL,JK+1)+PGEOH(JL,JK+1))
+      PTENH(JL,JK)=(ZZS-PGEOH(JL,JK))*RCPD
+  150 CONTINUE
+  160 CONTINUE
+      DO 190 JK=KLEV,3,-1
+      DO 180 JL=1,KLON
+      IF(PVERV(JL,JK).LT.ZWMAX(JL)) THEN
+         ZWMAX(JL)=PVERV(JL,JK)
+         KLWMIN(JL)=JK
+      END IF
+  180 CONTINUE
+  190 CONTINUE
+!-----------------------------------------------------------
+!*    2.0      INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS
+!-----------------------------------------------------------
+  200 CONTINUE
+      DO 230 JK=1,KLEV
+      IK=JK-1
+      IF(JK.EQ.1) IK=1
+      DO 220 JL=1,KLON
+      PTU(JL,JK)=PTENH(JL,JK)
+      PTD(JL,JK)=PTENH(JL,JK)
+      PQU(JL,JK)=PQENH(JL,JK)
+      PQD(JL,JK)=PQENH(JL,JK)
+      PLU(JL,JK)=0.
+      PUU(JL,JK)=PUEN(JL,IK)
+      PUD(JL,JK)=PUEN(JL,IK)
+      PVU(JL,JK)=PVEN(JL,IK)
+      PVD(JL,JK)=PVEN(JL,IK)
+      PMFU(JL,JK)=0.
+      PMFD(JL,JK)=0.
+      PMFUS(JL,JK)=0.
+      PMFDS(JL,JK)=0.
+      PMFUQ(JL,JK)=0.
+      PMFDQ(JL,JK)=0.
+      PDMFUP(JL,JK)=0.
+      PDMFDP(JL,JK)=0.
+      PDPMEL(JL,JK)=0.
+      PLUDE(JL,JK)=0.
+      KLAB(JL,JK)=0
+  220 CONTINUE
+  230 CONTINUE
+      RETURN
+      END SUBROUTINE CUINI   
+
+!**********************************************
+!       SUBROUTINE CUBASE
+!********************************************** 
+      SUBROUTINE CUBASE &
+         (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTENH, &
+          PQENH,    PGEOH,    PAPH,     PTU,      PQU,   &
+          PLU,      PUEN,     PVEN,     PUU,      PVU,   &
+          LDCUM,    KCBOT,    KLAB)
+!      THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
+!      FOR CUMULUS PARAMETERIZATION
+!      M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
+!***PURPOSE.
+!   --------
+!          TO PRODUCE CLOUD BASE VALUES FOR CU-PARAMETRIZATION
+!***INTERFACE
+!   ---------
+!          THIS ROUTINE IS CALLED FROM *CUMASTR*.
+!          INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
+!          IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
+!                 KLAB=1 FOR SUBCLOUD LEVELS
+!                 KLAB=2 FOR CONDENSATION LEVEL
+!***METHOD.
+!  --------
+!          LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
+!          (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
+!***EXTERNALS
+!   ---------
+!          *CUADJTQ* FOR ADJUSTING T AND Q DUE TO CONDENSATION IN ASCENT
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+      INTEGER   KLON, KLEV, KLEVP1
+      INTEGER   klevm1
+      INTEGER   JL,JK,IS,IK,ICALL,IKB
+      REAL      ZBUO,ZZ
+      REAL     PTENH(KLON,KLEV),       PQENH(KLON,KLEV),  &
+              PGEOH(KLON,KLEV),       PAPH(KLON,KLEVP1)
+      REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),   &
+              PLU(KLON,KLEV)
+      REAL     PUEN(KLON,KLEV),        PVEN(KLON,KLEV),  &
+              PUU(KLON,KLEV),         PVU(KLON,KLEV) 
+      REAL     ZQOLD(KLON,KLEV),       ZPH(KLON)
+      INTEGER  KLAB(KLON,KLEV),        KCBOT(KLON)
+      LOGICAL  LDCUM(KLON),            LOFLAG(KLON)
+!***INPUT VARIABLES:
+!       PTENH [ZTENH] - Environment Temperature on half levels. (CUINI)
+!       PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI)
+!       PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX)
+!       PAPH - Pressure of half levels. (MSSFLX)
+!***VARIABLES MODIFIED BY CUBASE:
+!       LDCUM - Logical denoting profiles. (CUBASE)
+!       KTYPE - Convection type - 1: Penetrative  (CUMASTR)
+!                                 2: Stratocumulus (CUMASTR)
+!                                 3: Mid-level  (CUASC)
+!       PTU - Cloud Temperature.
+!       PQU - Cloud specific Humidity.
+!       PLU - Cloud Liquid Water (Moisture condensed out)
+!       KCBOT - Cloud Base Level. (CUBASE)
+!       KLAB [ILAB] - Level Label - 1: Sub-cloud layer (CUBASE)
+!------------------------------------------------
+!     1.       INITIALIZE VALUES AT LIFTING LEVEL
+!------------------------------------------------
+  100 CONTINUE
+      DO 110 JL=1,KLON
+        KLAB(JL,KLEV)=1
+        KCBOT(JL)=KLEVM1
+        LDCUM(JL)=.FALSE.
+        PUU(JL,KLEV)=PUEN(JL,KLEV)*(PAPH(JL,KLEVP1)-PAPH(JL,KLEV))
+        PVU(JL,KLEV)=PVEN(JL,KLEV)*(PAPH(JL,KLEVP1)-PAPH(JL,KLEV))
+  110 CONTINUE
+!-------------------------------------------------------
+!     2.0      DO ASCENT IN SUBCLOUD LAYER,
+!              CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
+!              ADJUST T,Q AND L ACCORDINGLY IN *CUADJTQ*,
+!              CHECK FOR BUOYANCY AND SET FLAGS
+!-------------------------------------------------------
+      DO 200 JK=1,KLEV
+      DO 200 JL=1,KLON
+        ZQOLD(JL,JK)=0.0
+  200 CONTINUE
+      DO 290 JK=KLEVM1,2,-1
+        IS=0
+        DO 210 JL=1,KLON
+          IF(KLAB(JL,JK+1).EQ.1) THEN
+             IS=IS+1
+             LOFLAG(JL)=.TRUE.
+          ELSE
+             LOFLAG(JL)=.FALSE.
+          ENDIF
+          ZPH(JL)=PAPH(JL,JK)
+  210   CONTINUE
+        IF(IS.EQ.0) GO TO 290
+        DO 220 JL=1,KLON
+          IF(LOFLAG(JL)) THEN
+             PQU(JL,JK)=PQU(JL,JK+1)
+             PTU(JL,JK)=(CPD*PTU(JL,JK+1)+PGEOH(JL,JK+1)  &
+                       -PGEOH(JL,JK))*RCPD
+             ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK))-      &
+                 PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))+ZBUO0
+             IF(ZBUO.GT.0.) KLAB(JL,JK)=1
+             ZQOLD(JL,JK)=PQU(JL,JK)
+          END IF
+  220   CONTINUE
+        IK=JK
+        ICALL=1
+        CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTU,PQU,LOFLAG,ICALL)
+        DO 240 JL=1,KLON
+          IF(LOFLAG(JL).AND.PQU(JL,JK).NE.ZQOLD(JL,JK)) THEN
+             KLAB(JL,JK)=2
+             PLU(JL,JK)=PLU(JL,JK)+ZQOLD(JL,JK)-PQU(JL,JK)
+             ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK))-      &
+                 PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))+ZBUO0
+             IF(ZBUO.GT.0.) THEN
+                KCBOT(JL)=JK
+                LDCUM(JL)=.TRUE.
+             END IF
+          END IF
+  240   CONTINUE
+!             CALCULATE AVERAGES OF U AND V FOR SUBCLOUD ARA,.
+!             THE VALUES WILL BE USED TO DEFINE CLOUD BASE VALUES.
+        IF(LMFDUDV) THEN
+           DO 250 JL=1,KLON
+             IF(JK.GE.KCBOT(JL)) THEN
+                PUU(JL,KLEV)=PUU(JL,KLEV)+           &
+                          PUEN(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
+                PVU(JL,KLEV)=PVU(JL,KLEV)+           &
+                          PVEN(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
+             END IF
+ 250       CONTINUE
+        END IF
+  290 CONTINUE
+      IF(LMFDUDV) THEN
+         DO 310 JL=1,KLON
+         IF(LDCUM(JL)) THEN
+            IKB=KCBOT(JL)
+            ZZ=1./(PAPH(JL,KLEVP1)-PAPH(JL,IKB))
+            PUU(JL,KLEV)=PUU(JL,KLEV)*ZZ
+            PVU(JL,KLEV)=PVU(JL,KLEV)*ZZ
+         ELSE
+            PUU(JL,KLEV)=PUEN(JL,KLEVM1)
+            PVU(JL,KLEV)=PVEN(JL,KLEVM1)
+         END IF
+ 310     CONTINUE
+      END IF
+      RETURN
+      END SUBROUTINE CUBASE
+
+!
+!**********************************************
+!       SUBROUTINE CUASC_NEW
+!********************************************** 
+      SUBROUTINE CUASC_NEW &
+         (KLON,     KLEV,     KLEVP1,   KLEVM1,   PTENH,  &
+          PQENH,    PUEN,     PVEN,     PTEN,     PQEN,   &
+          PQSEN,    PGEO,     PGEOH,    PAP,      PAPH,   &
+          PQTE,     PVERV,    KLWMIN,   LDCUM,    PHCBASE,& 
+          KTYPE,    KLAB,     PTU,      PQU,      PLU,    &
+          PUU,      PVU,      PMFU,     PMFUB,    PENTR,  &
+          PMFUS,    PMFUQ,    PMFUL,    PLUDE,    PDMFUP, & 
+          KCBOT,    KCTOP,    KCTOP0,   KCUM,     ZTMST,  &
+          KHMIN,    PHHATT,   PQSENH)
+!     THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS
+!     FOR CUMULUS PARAMETERIZATION
+!     M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
+!     Y.WANG            IPRC           11/01 MODIF.
+!***PURPOSE.
+!   --------
+!          TO PRODUCE CLOUD ASCENTS FOR CU-PARAMETRIZATION
+!          (VERTICAL PROFILES OF T,Q,L,U AND V AND CORRESPONDING
+!           FLUXES AS WELL AS PRECIPITATION RATES)
+!***INTERFACE
+!   ---------
+!          THIS ROUTINE IS CALLED FROM *CUMASTR*.
+!***METHOD.
+!  --------
+!          LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
+!          AND THEN CALCULATE MOIST ASCENT FOR
+!          ENTRAINING/DETRAINING PLUME.
+!          ENTRAINMENT AND DETRAINMENT RATES DIFFER FOR
+!          SHALLOW AND DEEP CUMULUS CONVECTION.
+!          IN CASE THERE IS NO PENETRATIVE OR SHALLOW CONVECTION
+!          CHECK FOR POSSIBILITY OF MID LEVEL CONVECTION
+!          (CLOUD BASE VALUES CALCULATED IN *CUBASMC*)
+!***EXTERNALS
+!   ---------
+!          *CUADJTQ* ADJUST T AND Q DUE TO CONDENSATION IN ASCENT
+!          *CUENTR_NEW*  CALCULATE ENTRAINMENT/DETRAINMENT RATES
+!          *CUBASMC* CALCULATE CLOUD BASE VALUES FOR MIDLEVEL CONVECTION
+!***REFERENCE
+!   ---------
+!          (TIEDTKE,1989)
+!***INPUT VARIABLES:
+!       PTENH [ZTENH] - Environ Temperature on half levels. (CUINI)
+!       PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI)
+!       PUEN - Environment wind u-component. (MSSFLX)
+!       PVEN - Environment wind v-component. (MSSFLX)
+!       PTEN - Environment Temperature. (MSSFLX)
+!       PQEN - Environment Specific Humidity. (MSSFLX)
+!       PQSEN - Environment Saturation Specific Humidity. (MSSFLX)
+!       PGEO - Geopotential. (MSSFLX)
+!       PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX)
+!       PAP - Pressure in Pa.  (MSSFLX)
+!       PAPH - Pressure of half levels. (MSSFLX)
+!       PQTE - Moisture convergence (Delta q/Delta t). (MSSFLX)
+!       PVERV - Large Scale Vertical Velocity (Omega). (MSSFLX)
+!       KLWMIN [ILWMIN] - Level of Minimum Omega. (CUINI)
+!       KLAB [ILAB] - Level Label - 1: Sub-cloud layer.
+!                                   2: Condensation Level (Cloud Base)
+!       PMFUB [ZMFUB] - Updraft Mass Flux at Cloud Base. (CUMASTR)
+!***VARIABLES MODIFIED BY CUASC:
+!       LDCUM - Logical denoting profiles. (CUBASE)
+!       KTYPE - Convection type - 1: Penetrative  (CUMASTR)
+!                                 2: Stratocumulus (CUMASTR)
+!                                 3: Mid-level  (CUASC)
+!       PTU - Cloud Temperature.
+!       PQU - Cloud specific Humidity.
+!       PLU - Cloud Liquid Water (Moisture condensed out)
+!       PUU [ZUU] - Cloud Momentum U-Component.
+!       PVU [ZVU] - Cloud Momentum V-Component.
+!       PMFU - Updraft Mass Flux.
+!       PENTR [ZENTR] - Entrainment Rate. (CUMASTR ) (CUBASMC)
+!       PMFUS [ZMFUS] - Updraft Flux of Dry Static Energy. (CUBASMC)
+!       PMFUQ [ZMFUQ] - Updraft Flux of Specific Humidity.
+!       PMFUL [ZMFUL] - Updraft Flux of Cloud Liquid Water.
+!       PLUDE - Liquid Water Returned to Environment by Detrainment.
+!       PDMFUP [ZMFUP] -
+!       KCBOT - Cloud Base Level. (CUBASE)
+!       KCTOP -
+!       KCTOP0 [ICTOP0] - Estimate of Cloud Top. (CUMASTR)
+!       KCUM [ICUM] -
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+      INTEGER   KLON, KLEV, KLEVP1
+      INTEGER   klevm1,kcum
+      REAL      ZTMST,ZCONS2,ZDZ,ZDRODZ
+      INTEGER   JL,JK,IKB,IK,IS,IKT,ICALL
+      REAL      ZMFMAX,ZFAC,ZMFTEST,ZDPRHO,ZMSE,ZNEVN,ZODMAX
+      REAL      ZQEEN,ZSEEN,ZSCDE,ZGA,ZDT,ZSCOD
+      REAL      ZQUDE,ZQCOD, ZMFUSK, ZMFUQK,ZMFULK
+      REAL      ZBUO, ZPRCON, ZLNEW, ZZ, ZDMFEU, ZDMFDU
+      REAL      ZBUOYZ,ZZDMF
+      REAL     PTENH(KLON,KLEV),       PQENH(KLON,KLEV), &
+              PUEN(KLON,KLEV),        PVEN(KLON,KLEV),   &
+              PTEN(KLON,KLEV),        PQEN(KLON,KLEV),   &
+              PGEO(KLON,KLEV),        PGEOH(KLON,KLEV),  &
+              PAP(KLON,KLEV),         PAPH(KLON,KLEVP1), &
+              PQSEN(KLON,KLEV),       PQTE(KLON,KLEV),   &
+              PVERV(KLON,KLEV),       PQSENH(KLON,KLEV)  
+      REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),   &
+              PUU(KLON,KLEV),         PVU(KLON,KLEV),    &
+              PMFU(KLON,KLEV),        ZPH(KLON),         &
+              PMFUB(KLON),            PENTR(KLON),       &
+              PMFUS(KLON,KLEV),       PMFUQ(KLON,KLEV),  &
+              PLU(KLON,KLEV),         PLUDE(KLON,KLEV),  &
+              PMFUL(KLON,KLEV),       PDMFUP(KLON,KLEV)
+      REAL     ZDMFEN(KLON),           ZDMFDE(KLON),     &
+              ZMFUU(KLON),            ZMFUV(KLON),       &
+              ZPBASE(KLON),           ZQOLD(KLON),       &
+              PHHATT(KLON,KLEV),      ZODETR(KLON,KLEV), &
+              ZOENTR(KLON,KLEV),      ZBUOY(KLON)
+      REAL     PHCBASE(KLON)
+      INTEGER  KLWMIN(KLON),           KTYPE(KLON),      &
+              KLAB(KLON,KLEV),        KCBOT(KLON),       &
+              KCTOP(KLON),            KCTOP0(KLON),      &
+              KHMIN(KLON)
+      LOGICAL  LDCUM(KLON),            LOFLAG(KLON)
+!--------------------------------
+!*    1.       SPECIFY PARAMETERS
+!--------------------------------
+  100 CONTINUE
+      ZCONS2=1./(G*ZTMST)
+!---------------------------------
+!     2.        SET DEFAULT VALUES
+!---------------------------------
+  200 CONTINUE
+      DO 210 JL=1,KLON
+        ZMFUU(JL)=0.
+        ZMFUV(JL)=0.
+        ZBUOY(JL)=0.
+        IF(.NOT.LDCUM(JL)) KTYPE(JL)=0
+  210 CONTINUE
+      DO 230 JK=1,KLEV
+      DO 230 JL=1,KLON
+          PLU(JL,JK)=0.
+          PMFU(JL,JK)=0.
+          PMFUS(JL,JK)=0.
+          PMFUQ(JL,JK)=0.
+          PMFUL(JL,JK)=0.
+          PLUDE(JL,JK)=0.
+          PDMFUP(JL,JK)=0.
+          ZOENTR(JL,JK)=0.
+          ZODETR(JL,JK)=0.
+          IF(.NOT.LDCUM(JL).OR.KTYPE(JL).EQ.3) KLAB(JL,JK)=0
+          IF(.NOT.LDCUM(JL).AND.PAPH(JL,JK).LT.4.E4) KCTOP0(JL)=JK
+  230 CONTINUE
+!------------------------------------------------
+!     3.0      INITIALIZE VALUES AT LIFTING LEVEL
+!------------------------------------------------
+      DO 310 JL=1,KLON
+        KCTOP(JL)=KLEVM1
+        IF(.NOT.LDCUM(JL)) THEN
+           KCBOT(JL)=KLEVM1
+           PMFUB(JL)=0.
+           PQU(JL,KLEV)=0.
+        END IF
+        PMFU(JL,KLEV)=PMFUB(JL)
+        PMFUS(JL,KLEV)=PMFUB(JL)*(CPD*PTU(JL,KLEV)+PGEOH(JL,KLEV))
+        PMFUQ(JL,KLEV)=PMFUB(JL)*PQU(JL,KLEV)
+        IF(LMFDUDV) THEN
+           ZMFUU(JL)=PMFUB(JL)*PUU(JL,KLEV)
+           ZMFUV(JL)=PMFUB(JL)*PVU(JL,KLEV)
+        END IF
+  310 CONTINUE
+!
+!-- 3.1 Find organized entrainment at cloud base
+!
+      DO 322 JL=1,KLON
+      LDCUM(JL)=.FALSE.
+      IF (KTYPE(JL).EQ.1) THEN
+      IKB = KCBOT(JL)
+      ZBUOY(JL)=G*((PTU(JL,IKB)-PTENH(JL,IKB))/PTENH(JL,IKB)+ &
+               0.608*(PQU(JL,IKB)-PQENH(JL,IKB)))
+       IF (ZBUOY(JL).GT.0.) THEN
+        ZDZ = (PGEO(JL,IKB-1)-PGEO(JL,IKB))*ZRG
+        ZDRODZ = -LOG(PTEN(JL,IKB-1)/PTEN(JL,IKB))/ZDZ -  &
+                 G/(RD*PTENH(JL,IKB))
+        ZOENTR(JL,IKB-1)=ZBUOY(JL)*0.5/(1.+ZBUOY(JL)*ZDZ) &
+                +ZDRODZ
+        ZOENTR(JL,IKB-1) = MIN(ZOENTR(JL,IKB-1),1.E-3)
+        ZOENTR(JL,IKB-1) = MAX(ZOENTR(JL,IKB-1),0.)
+       END IF
+      END IF
+  322 CONTINUE 
+!
+!-----------------------------------------------------------------
+!     4.       DO ASCENT: SUBCLOUD LAYER (KLAB=1) ,CLOUDS (KLAB=2)
+!              BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN
+!              BY ADJUSTING T,Q AND L ACCORDINGLY IN *CUADJTQ*,
+!              THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY
+!-----------------------------------------------------------------
+  400 CONTINUE
+      DO 480 JK=KLEVM1,2,-1
+!                  SPECIFY CLOUD BASE VALUES FOR MIDLEVEL CONVECTION
+!                  IN *CUBASMC* IN CASE THERE IS NOT ALREADY CONVECTION
+! ---------------------------------------------------------------------
+      IK=JK
+      IF(LMFMID.AND.IK.LT.KLEVM1.AND.IK.GT.KLEV-13) THEN
+      CALL CUBASMC  &
+         (KLON,     KLEV,     KLEVM1,   IK,      PTEN,  &
+          PQEN,     PQSEN,    PUEN,     PVEN,    PVERV, &
+          PGEO,     PGEOH,    LDCUM,    KTYPE,   KLAB,  &
+          PMFU,     PMFUB,    PENTR,    KCBOT,   PTU,   &
+          PQU,      PLU,      PUU,     PVU,      PMFUS, &
+          PMFUQ,    PMFUL,    PDMFUP,  ZMFUU,    ZMFUV)
+      ENDIF
+      IS=0
+      DO 410 JL=1,KLON
+        ZQOLD(JL)=0.0
+        IS=IS+KLAB(JL,JK+1)
+        IF(KLAB(JL,JK+1).EQ.0) KLAB(JL,JK)=0
+        LOFLAG(JL)=KLAB(JL,JK+1).GT.0
+        ZPH(JL)=PAPH(JL,JK)
+        IF(KTYPE(JL).EQ.3.AND.JK.EQ.KCBOT(JL)) THEN
+           ZMFMAX=(PAPH(JL,JK)-PAPH(JL,JK-1))*ZCONS2
+           IF(PMFUB(JL).GT.ZMFMAX) THEN
+              ZFAC=ZMFMAX/PMFUB(JL)
+              PMFU(JL,JK+1)=PMFU(JL,JK+1)*ZFAC
+              PMFUS(JL,JK+1)=PMFUS(JL,JK+1)*ZFAC
+              PMFUQ(JL,JK+1)=PMFUQ(JL,JK+1)*ZFAC
+              ZMFUU(JL)=ZMFUU(JL)*ZFAC
+              ZMFUV(JL)=ZMFUV(JL)*ZFAC
+              PMFUB(JL)=ZMFMAX
+           END IF
+        END IF
+  410 CONTINUE
+      IF(IS.EQ.0) GO TO 480
+!
+!*     SPECIFY ENTRAINMENT RATES IN *CUENTR_NEW*
+! -------------------------------------
+      IK=JK
+      CALL CUENTR_NEW &
+         (KLON,     KLEV,     KLEVP1,   IK,       PTENH,&
+          PAPH,     PAP,      PGEOH,    KLWMIN,   LDCUM,&
+          KTYPE,    KCBOT,    KCTOP0,   ZPBASE,   PMFU, &
+          PENTR,    ZDMFEN,   ZDMFDE,   ZODETR,   KHMIN)
+!
+!      DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME
+! -------------------------------------------------------
+! Do adiabatic ascent for entraining/detraining plume
+! the cloud ensemble entrains environmental values
+! in turbulent detrainment cloud ensemble values are detrained
+! in organized detrainment the dry static energy and
+! moisture that are neutral compared to the
+! environmental air are detrained
+!
+      DO 420 JL=1,KLON
+      IF(LOFLAG(JL)) THEN
+        IF(JK.LT.KCBOT(JL)) THEN
+         ZMFTEST=PMFU(JL,JK+1)+ZDMFEN(JL)-ZDMFDE(JL)
+         ZMFMAX=MIN(ZMFTEST,(PAPH(JL,JK)-PAPH(JL,JK-1))*ZCONS2)
+         ZDMFEN(JL)=MAX(ZDMFEN(JL)-MAX(ZMFTEST-ZMFMAX,0.),0.)
+        END IF
+        ZDMFDE(JL)=MIN(ZDMFDE(JL),0.75*PMFU(JL,JK+1))
+        PMFU(JL,JK)=PMFU(JL,JK+1)+ZDMFEN(JL)-ZDMFDE(JL)
+        IF (JK.LT.kcbot(jl)) THEN
+          zdprho = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
+          zoentr(jl,jk) = zoentr(jl,jk)*zdprho*pmfu(jl,jk+1)
+          zmftest = pmfu(jl,jk) + zoentr(jl,jk)-zodetr(jl,jk)
+          zmfmax = MIN(zmftest,(paph(jl,jk)-paph(jl,jk-1))*zcons2)
+          zoentr(jl,jk) = MAX(zoentr(jl,jk)-MAX(zmftest-zmfmax,0.),0.)
+        END IF
+!
+! limit organized detrainment to not allowing for too deep clouds
+!
+        IF (ktype(jl).EQ.1.AND.jk.LT.kcbot(jl).AND.jk.LE.khmin(jl)) THEN
+          zmse = cpd*ptu(jl,jk+1) + alv*pqu(jl,jk+1) + pgeoh(jl,jk+1)
+          ikt = kctop0(jl)
+          znevn=(pgeoh(jl,ikt)-pgeoh(jl,jk+1))*(zmse-phhatt(jl,  &
+               jk+1))*zrg
+          IF (znevn.LE.0.) znevn = 1.
+          zdprho = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
+          zodmax = ((phcbase(jl)-zmse)/znevn)*zdprho*pmfu(jl,jk+1)
+          zodmax = MAX(zodmax,0.)
+          zodetr(jl,jk) = MIN(zodetr(jl,jk),zodmax)
+        END IF
+        zodetr(jl,jk) = MIN(zodetr(jl,jk),0.75*pmfu(jl,jk))
+        pmfu(jl,jk) = pmfu(jl,jk) + zoentr(jl,jk) - zodetr(jl,jk)
+        ZQEEN=PQENH(JL,JK+1)*ZDMFEN(JL)
+        zqeen=zqeen + pqenh(jl,jk+1)*zoentr(jl,jk)
+        ZSEEN=(CPD*PTENH(JL,JK+1)+PGEOH(JL,JK+1))*ZDMFEN(JL)
+        zseen=zseen+(cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))*  &
+             zoentr(jl,jk)
+        ZSCDE=(CPD*PTU(JL,JK+1)+PGEOH(JL,JK+1))*ZDMFDE(JL)
+! find moist static energy that give nonbuoyant air
+        zga = alv*pqsenh(jl,jk+1)/(rv*(ptenh(jl,jk+1)**2))
+        zdt = (plu(jl,jk+1)-0.608*(pqsenh(jl,jk+1)-pqenh(jl, &
+               jk+1)))/(1./ptenh(jl,jk+1)+0.608*zga)
+        zscod = cpd*ptenh(jl,jk+1) + pgeoh(jl,jk+1) + cpd*zdt
+        zscde = zscde + zodetr(jl,jk)*zscod
+        zqude = pqu(jl,jk+1)*zdmfde(jl)
+        zqcod = pqsenh(jl,jk+1) + zga*zdt
+        zqude = zqude + zodetr(jl,jk)*zqcod
+        plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl)
+        plude(jl,jk) = plude(jl,jk)+plu(jl,jk+1)*zodetr(jl,jk)
+        zmfusk = pmfus(jl,jk+1) + zseen - zscde
+        zmfuqk = pmfuq(jl,jk+1) + zqeen - zqude
+        zmfulk = pmful(jl,jk+1) - plude(jl,jk)
+        plu(jl,jk) = zmfulk*(1./MAX(cmfcmin,pmfu(jl,jk)))
+        pqu(jl,jk) = zmfuqk*(1./MAX(cmfcmin,pmfu(jl,jk)))
+        ptu(jl,jk)=(zmfusk*(1./MAX(cmfcmin,pmfu(jl,jk)))-  &
+            pgeoh(jl,jk))*rcpd
+        ptu(jl,jk) = MAX(100.,ptu(jl,jk))
+        ptu(jl,jk) = MIN(400.,ptu(jl,jk))
+        zqold(jl) = pqu(jl,jk)
+      END IF
+  420 CONTINUE
+!*             DO CORRECTIONS FOR MOIST ASCENT
+!*             BY ADJUSTING T,Q AND L IN *CUADJTQ*
+!------------------------------------------------
+      IK=JK
+      ICALL=1
+!
+      CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTU,PQU,LOFLAG,ICALL)
+!
+      DO 440 JL=1,KLON
+      IF(LOFLAG(JL).AND.PQU(JL,JK).NE.ZQOLD(JL)) THEN
+         KLAB(JL,JK)=2
+         PLU(JL,JK)=PLU(JL,JK)+ZQOLD(JL)-PQU(JL,JK)
+         ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK)-PLU(JL,JK))-  &
+        PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))
+         IF(KLAB(JL,JK+1).EQ.1) ZBUO=ZBUO+ZBUO0
+         IF(ZBUO.GT.0..AND.PMFU(JL,JK).GT.0.01*PMFUB(JL).AND. &
+                            JK.GE.KCTOP0(JL)) THEN
+            KCTOP(JL)=JK
+            LDCUM(JL)=.TRUE.
+            IF(ZPBASE(JL)-PAPH(JL,JK).GE.ZDNOPRC) THEN
+               ZPRCON=CPRCON
+            ELSE
+               ZPRCON=0.
+            ENDIF
+            ZLNEW=PLU(JL,JK)/(1.+ZPRCON*(PGEOH(JL,JK)-PGEOH(JL,JK+1)))
+            PDMFUP(JL,JK)=MAX(0.,(PLU(JL,JK)-ZLNEW)*PMFU(JL,JK))
+            PLU(JL,JK)=ZLNEW
+         ELSE
+            KLAB(JL,JK)=0
+            PMFU(JL,JK)=0.
+         END IF
+      END IF
+      IF(LOFLAG(JL)) THEN
+         PMFUL(JL,JK)=PLU(JL,JK)*PMFU(JL,JK)
+         PMFUS(JL,JK)=(CPD*PTU(JL,JK)+PGEOH(JL,JK))*PMFU(JL,JK)
+         PMFUQ(JL,JK)=PQU(JL,JK)*PMFU(JL,JK)
+      END IF
+  440 CONTINUE
+!
+      IF(LMFDUDV) THEN
+!
+        DO 460 JL=1,KLON
+        zdmfen(jl) = zdmfen(jl) + zoentr(jl,jk)
+        zdmfde(jl) = zdmfde(jl) + zodetr(jl,jk)
+           IF(LOFLAG(JL)) THEN
+              IF(KTYPE(JL).EQ.1.OR.KTYPE(JL).EQ.3) THEN
+                 IF(ZDMFEN(JL).LE.1.E-20) THEN
+                    ZZ=3.
+                 ELSE
+                    ZZ=2.
+                 ENDIF
+              ELSE
+                 IF(ZDMFEN(JL).LE.1.0E-20) THEN
+                    ZZ=1.
+                 ELSE
+                    ZZ=0.
+                 ENDIF
+              END IF
+              ZDMFEU=ZDMFEN(JL)+ZZ*ZDMFDE(JL)
+              ZDMFDU=ZDMFDE(JL)+ZZ*ZDMFDE(JL)
+              ZDMFDU=MIN(ZDMFDU,0.75*PMFU(JL,JK+1))
+              ZMFUU(JL)=ZMFUU(JL)+                              &
+                       ZDMFEU*PUEN(JL,JK)-ZDMFDU*PUU(JL,JK+1)   
+              ZMFUV(JL)=ZMFUV(JL)+                              &
+                       ZDMFEU*PVEN(JL,JK)-ZDMFDU*PVU(JL,JK+1)   
+              IF(PMFU(JL,JK).GT.0.) THEN
+                 PUU(JL,JK)=ZMFUU(JL)*(1./PMFU(JL,JK))
+                 PVU(JL,JK)=ZMFUV(JL)*(1./PMFU(JL,JK))
+              END IF
+           END IF
+  460   CONTINUE
+!
+        END IF
+!
+! Compute organized entrainment
+! for use at next level
+!
+      DO 470 jl = 1, klon
+       IF (loflag(jl).AND.ktype(jl).EQ.1) THEN
+        zbuoyz=g*((ptu(jl,jk)-ptenh(jl,jk))/ptenh(jl,jk)+  &
+              0.608*(pqu(jl,jk)-pqenh(jl,jk))-plu(jl,jk))
+        zbuoyz = MAX(zbuoyz,0.0)
+        zdz = (pgeo(jl,jk-1)-pgeo(jl,jk))*zrg
+        zdrodz = -LOG(pten(jl,jk-1)/pten(jl,jk))/zdz -  &
+                 g/(rd*ptenh(jl,jk))
+        zbuoy(jl) = zbuoy(jl) + zbuoyz*zdz
+        zoentr(jl,jk-1) = zbuoyz*0.5/(1.+zbuoy(jl))+zdrodz
+        zoentr(jl,jk-1) = MIN(zoentr(jl,jk-1),1.E-3)
+        zoentr(jl,jk-1) = MAX(zoentr(jl,jk-1),0.)
+       END IF
+  470 CONTINUE 
+!
+  480 CONTINUE
+! -----------------------------------------------------------------
+!     5.       DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
+! -----------------------------------------------------------------
+!                  (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT
+!                         AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN
+!                         FROM PREVIOUS CALCULATIONS ABOVE)
+  500 CONTINUE
+      DO 510 JL=1,KLON
+      IF(KCTOP(JL).EQ.KLEVM1) LDCUM(JL)=.FALSE.
+      KCBOT(JL)=MAX(KCBOT(JL),KCTOP(JL))
+  510 CONTINUE
+      IS=0
+      DO 520 JL=1,KLON
+      IF(LDCUM(JL)) THEN
+         IS=IS+1
+      ENDIF
+  520 CONTINUE
+      KCUM=IS
+      IF(IS.EQ.0) GO TO 800
+      DO 530 JL=1,KLON
+      IF(LDCUM(JL)) THEN
+         JK=KCTOP(JL)-1
+         ZZDMF=CMFCTOP
+         ZDMFDE(JL)=(1.-ZZDMF)*PMFU(JL,JK+1)
+         PLUDE(JL,JK)=ZDMFDE(JL)*PLU(JL,JK+1)
+         PMFU(JL,JK)=PMFU(JL,JK+1)-ZDMFDE(JL)
+         PMFUS(JL,JK)=(CPD*PTU(JL,JK)+PGEOH(JL,JK))*PMFU(JL,JK)
+         PMFUQ(JL,JK)=PQU(JL,JK)*PMFU(JL,JK)
+         PMFUL(JL,JK)=PLU(JL,JK)*PMFU(JL,JK)
+         PLUDE(JL,JK-1)=PMFUL(JL,JK)
+         PDMFUP(JL,JK)=0.
+      END IF
+  530 CONTINUE
+        IF(LMFDUDV) THEN
+           DO 540 JL=1,KLON
+           IF(LDCUM(JL)) THEN
+              JK=KCTOP(JL)-1
+              PUU(JL,JK)=PUU(JL,JK+1)
+              PVU(JL,JK)=PVU(JL,JK+1)
+           END IF
+  540      CONTINUE
+        END IF
+  800 CONTINUE
+      RETURN
+      END SUBROUTINE CUASC_NEW
+!
+
+!**********************************************
+!       SUBROUTINE CUDLFS
+!********************************************** 
+      SUBROUTINE CUDLFS &
+         (KLON,     KLEV,     KLEVP1,   PTENH,    PQENH,  &
+          PUEN,     PVEN,     PGEOH,    PAPH,     PTU,    &
+          PQU,      PUU,      PVU,      LDCUM,    KCBOT,  &
+          KCTOP,    PMFUB,    PRFL,     PTD,      PQD,    &
+          PUD,      PVD,      PMFD,     PMFDS,    PMFDQ,  &
+          PDMFDP,   KDTOP,    LDDRAF)
+!      THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR
+!      CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES
+!      M.TIEDTKE         E.C.M.W.F.    12/86 MODIF.  12/89
+!***PURPOSE.
+!   --------
+!          TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS
+!          FOR MASSFLUX CUMULUS PARAMETERIZATION
+!***INTERFACE
+!   ---------
+!          THIS ROUTINE IS CALLED FROM *CUMASTR*.
+!          INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI
+!          AND UPDRAFT VALUES T,Q,U AND V AND ALSO
+!          CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE.
+!          IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS.
+!***METHOD.
+!  --------
+!          CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF
+!          MOIST ENVIRONMENTAL AIR AND CLOUD AIR.
+!***EXTERNALS
+!   ---------
+!          *CUADJTQ* FOR CALCULATING WET BULB T AND Q AT LFS
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+      INTEGER   KLON, KLEV, KLEVP1
+      INTEGER   JL,KE,JK,IS,IK,ICALL
+      REAL      ZTTEST, ZQTEST, ZBUO, ZMFTOP
+      REAL     PTENH(KLON,KLEV),       PQENH(KLON,KLEV),   &
+              PUEN(KLON,KLEV),        PVEN(KLON,KLEV),     &
+              PGEOH(KLON,KLEV),       PAPH(KLON,KLEVP1),   &
+              PTU(KLON,KLEV),         PQU(KLON,KLEV),      &
+              PUU(KLON,KLEV),         PVU(KLON,KLEV),      &
+              PMFUB(KLON),            PRFL(KLON)
+      REAL     PTD(KLON,KLEV),         PQD(KLON,KLEV),     &
+              PUD(KLON,KLEV),         PVD(KLON,KLEV),      &
+              PMFD(KLON,KLEV),        PMFDS(KLON,KLEV),    &
+              PMFDQ(KLON,KLEV),       PDMFDP(KLON,KLEV)    
+      REAL     ZTENWB(KLON,KLEV),      ZQENWB(KLON,KLEV),  &
+              ZCOND(KLON),            ZPH(KLON)
+      INTEGER  KCBOT(KLON),            KCTOP(KLON),        &
+              KDTOP(KLON)
+      LOGICAL  LDCUM(KLON),            LLo2(KLON),         &
+              LDDRAF(KLON)
+!-----------------------------------------------
+!     1.       SET DEFAULT VALUES FOR DOWNDRAFTS
+!-----------------------------------------------
+  100 CONTINUE
+      DO 110 JL=1,KLON
+      LDDRAF(JL)=.FALSE.
+      KDTOP(JL)=KLEVP1
+  110 CONTINUE
+      IF(.NOT.LMFDD) GO TO 300
+!------------------------------------------------------------
+!     2.       DETERMINE LEVEL OF FREE SINKING BY
+!              DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS
+!              FOR EVERY POINT AND PROCEED AS FOLLOWS:
+!                (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q
+!                (2) DO MIXING WITH CUMULUS CLOUD AIR
+!                (3) CHECK FOR NEGATIVE BUOYANCY
+!              THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE
+!              OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB
+!              TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO
+!              EVAPORATION OF RAIN AND CLOUD WATER)
+!------------------------------------------------------------------
+  200 CONTINUE
+      KE=KLEV-3
+      DO 290 JK=3,KE
+!   2.1      CALCULATE WET-BULB TEMPERATURE AND MOISTURE
+!            FOR ENVIRONMENTAL AIR IN *CUADJTQ*
+! -----------------------------------------------------
+  210 CONTINUE
+      IS=0
+      DO 212 JL=1,KLON
+      ZTENWB(JL,JK)=PTENH(JL,JK)
+      ZQENWB(JL,JK)=PQENH(JL,JK)
+      ZPH(JL)=PAPH(JL,JK)
+      LLO2(JL)=LDCUM(JL).AND.PRFL(JL).GT.0..AND..NOT.LDDRAF(JL).AND. &
+              (JK.LT.KCBOT(JL).AND.JK.GT.KCTOP(JL))
+      IF(LLO2(JL))THEN
+         IS=IS+1
+      ENDIF
+  212 CONTINUE
+      IF(IS.EQ.0) GO TO 290
+      IK=JK
+      ICALL=2
+      CALL CUADJTQ(KLON,KLEV,IK,ZPH,ZTENWB,ZQENWB,LLO2,ICALL)
+!   2.2      DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR
+!            AND CHECK FOR NEGATIVE BUOYANCY.
+!            THEN SET VALUES FOR DOWNDRAFT AT LFS.
+! -----------------------------------------------------
+  220 CONTINUE
+      DO 222 JL=1,KLON
+      IF(LLO2(JL)) THEN
+         ZTTEST=0.5*(PTU(JL,JK)+ZTENWB(JL,JK))
+         ZQTEST=0.5*(PQU(JL,JK)+ZQENWB(JL,JK))
+         ZBUO=ZTTEST*(1.+VTMPC1*ZQTEST)-  &
+             PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))
+         ZCOND(JL)=PQENH(JL,JK)-ZQENWB(JL,JK)
+         ZMFTOP=-CMFDEPS*PMFUB(JL)
+         IF(ZBUO.LT.0..AND.PRFL(JL).GT.10.*ZMFTOP*ZCOND(JL)) THEN
+            KDTOP(JL)=JK
+            LDDRAF(JL)=.TRUE.
+            PTD(JL,JK)=ZTTEST
+            PQD(JL,JK)=ZQTEST
+            PMFD(JL,JK)=ZMFTOP
+            PMFDS(JL,JK)=PMFD(JL,JK)*(CPD*PTD(JL,JK)+PGEOH(JL,JK))
+            PMFDQ(JL,JK)=PMFD(JL,JK)*PQD(JL,JK)
+            PDMFDP(JL,JK-1)=-0.5*PMFD(JL,JK)*ZCOND(JL)
+            PRFL(JL)=PRFL(JL)+PDMFDP(JL,JK-1)
+         END IF
+      END IF
+  222 CONTINUE
+         IF(LMFDUDV) THEN
+            DO 224 JL=1,KLON
+            IF(PMFD(JL,JK).LT.0.) THEN
+               PUD(JL,JK)=0.5*(PUU(JL,JK)+PUEN(JL,JK-1))
+               PVD(JL,JK)=0.5*(PVU(JL,JK)+PVEN(JL,JK-1))
+            END IF
+  224       CONTINUE
+         END IF
+  290 CONTINUE
+ 300  CONTINUE
+      RETURN
+      END SUBROUTINE CUDLFS
+!
+
+!**********************************************
+!       SUBROUTINE CUDDRAF
+!********************************************** 
+      SUBROUTINE CUDDRAF &
+         (KLON,     KLEV,     KLEVP1,   PTENH,    PQENH, &
+          PUEN,     PVEN,     PGEOH,    PAPH,     PRFL,  &
+          LDDRAF,   PTD,      PQD,      PUD,      PVD,   &
+          PMFD,     PMFDS,    PMFDQ,    PDMFDP)
+!     THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
+!     M.TIEDTKE         E.C.M.W.F.    12/86 MODIF.  12/89
+!***PURPOSE.
+!   --------
+!          TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
+!          (I.E. T,Q,U AND V AND FLUXES)
+!***INTERFACE
+!   ---------
+!          THIS ROUTINE IS CALLED FROM *CUMASTR*.
+!          INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
+!          IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
+!          AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
+!***METHOD.
+!  --------
+!          CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
+!          A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
+!          B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
+!***EXTERNALS
+!   ---------
+!          *CUADJTQ* FOR ADJUSTING T AND Q DUE TO EVAPORATION IN
+!          SATURATED DESCENT
+!***REFERENCE
+!   ---------
+!          (TIEDTKE,1989)
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+      INTEGER   KLON, KLEV, KLEVP1
+      INTEGER   JK,IS,JL,ITOPDE, IK, ICALL
+      REAL      ZENTR,ZSEEN, ZQEEN, ZSDDE, ZQDDE,ZMFDSK, ZMFDQK
+      REAL      ZBUO, ZDMFDP, ZMFDUK, ZMFDVK
+      REAL     PTENH(KLON,KLEV),       PQENH(KLON,KLEV),  &
+              PUEN(KLON,KLEV),        PVEN(KLON,KLEV),    &
+              PGEOH(KLON,KLEV),       PAPH(KLON,KLEVP1) 
+      REAL     PTD(KLON,KLEV),         PQD(KLON,KLEV),    &
+              PUD(KLON,KLEV),         PVD(KLON,KLEV),     &
+              PMFD(KLON,KLEV),        PMFDS(KLON,KLEV),   &
+              PMFDQ(KLON,KLEV),       PDMFDP(KLON,KLEV),  &
+              PRFL(KLON)
+      REAL     ZDMFEN(KLON),           ZDMFDE(KLON),      &
+              ZCOND(KLON),            ZPH(KLON)       
+      LOGICAL  LDDRAF(KLON),           LLO2(KLON)
+!--------------------------------------------------------------
+!     1.       CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
+!                (A) CALCULATING ENTRAINMENT RATES, ASSUMING
+!                     LINEAR DECREASE OF MASSFLUX IN PBL
+!                 (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
+!                     AND MOISTENING IS CALCULATED IN *CUADJTQ*
+!                 (C) CHECKING FOR NEGATIVE BUOYANCY AND
+!                     SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
+! ----------------------------------------------------------------
+  100 CONTINUE
+      DO 180 JK=3,KLEV
+      IS=0
+      DO 110 JL=1,KLON
+      ZPH(JL)=PAPH(JL,JK)
+      LLO2(JL)=LDDRAF(JL).AND.PMFD(JL,JK-1).LT.0.
+      IF(LLO2(JL)) THEN
+         IS=IS+1
+      ENDIF
+  110 CONTINUE
+      IF(IS.EQ.0) GO TO 180
+      DO 122 JL=1,KLON
+      IF(LLO2(JL)) THEN
+         ZENTR=ENTRDD*PMFD(JL,JK-1)*RD*PTENH(JL,JK-1)/   &
+              (G*PAPH(JL,JK-1))*(PAPH(JL,JK)-PAPH(JL,JK-1))
+         ZDMFEN(JL)=ZENTR
+         ZDMFDE(JL)=ZENTR
+      END IF
+  122 CONTINUE
+      ITOPDE=KLEV-2
+         IF(JK.GT.ITOPDE) THEN
+            DO 124 JL=1,KLON
+            IF(LLO2(JL)) THEN
+               ZDMFEN(JL)=0.
+               ZDMFDE(JL)=PMFD(JL,ITOPDE)*      &
+              (PAPH(JL,JK)-PAPH(JL,JK-1))/     &
+              (PAPH(JL,KLEVP1)-PAPH(JL,ITOPDE))
+            END IF
+  124       CONTINUE
+         END IF
+      DO 126 JL=1,KLON
+         IF(LLO2(JL)) THEN
+            PMFD(JL,JK)=PMFD(JL,JK-1)+ZDMFEN(JL)-ZDMFDE(JL)
+            ZSEEN=(CPD*PTENH(JL,JK-1)+PGEOH(JL,JK-1))*ZDMFEN(JL)
+            ZQEEN=PQENH(JL,JK-1)*ZDMFEN(JL)
+            ZSDDE=(CPD*PTD(JL,JK-1)+PGEOH(JL,JK-1))*ZDMFDE(JL)
+            ZQDDE=PQD(JL,JK-1)*ZDMFDE(JL)
+            ZMFDSK=PMFDS(JL,JK-1)+ZSEEN-ZSDDE
+            ZMFDQK=PMFDQ(JL,JK-1)+ZQEEN-ZQDDE
+            PQD(JL,JK)=ZMFDQK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
+            PTD(JL,JK)=(ZMFDSK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))- &
+                       PGEOH(JL,JK))*RCPD
+            PTD(JL,JK)=MIN(400.,PTD(JL,JK))
+            PTD(JL,JK)=MAX(100.,PTD(JL,JK))
+            ZCOND(JL)=PQD(JL,JK)
+         END IF
+  126 CONTINUE
+      IK=JK
+      ICALL=2
+      CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTD,PQD,LLO2,ICALL)
+      DO 150 JL=1,KLON
+         IF(LLO2(JL)) THEN
+            ZCOND(JL)=ZCOND(JL)-PQD(JL,JK)
+            ZBUO=PTD(JL,JK)*(1.+VTMPC1*PQD(JL,JK))- &
+           PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))
+            IF(ZBUO.GE.0..OR.PRFL(JL).LE.(PMFD(JL,JK)*ZCOND(JL))) THEN
+               PMFD(JL,JK)=0.
+            ENDIF
+            PMFDS(JL,JK)=(CPD*PTD(JL,JK)+PGEOH(JL,JK))*PMFD(JL,JK)
+            PMFDQ(JL,JK)=PQD(JL,JK)*PMFD(JL,JK)
+            ZDMFDP=-PMFD(JL,JK)*ZCOND(JL)
+            PDMFDP(JL,JK-1)=ZDMFDP
+            PRFL(JL)=PRFL(JL)+ZDMFDP
+         END IF
+  150 CONTINUE
+        IF(LMFDUDV) THEN
+          DO 160 JL=1,KLON
+             IF(LLO2(JL).AND.PMFD(JL,JK).LT.0.) THEN
+                ZMFDUK=PMFD(JL,JK-1)*PUD(JL,JK-1)+   &
+               ZDMFEN(JL)*PUEN(JL,JK-1)-ZDMFDE(JL)*PUD(JL,JK-1)
+                ZMFDVK=PMFD(JL,JK-1)*PVD(JL,JK-1)+   &
+               ZDMFEN(JL)*PVEN(JL,JK-1)-ZDMFDE(JL)*PVD(JL,JK-1)
+                PUD(JL,JK)=ZMFDUK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
+                PVD(JL,JK)=ZMFDVK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
+             END IF
+  160     CONTINUE
+        END IF
+  180 CONTINUE
+      RETURN
+      END SUBROUTINE CUDDRAF
+!
+
+!**********************************************
+!       SUBROUTINE CUFLX
+!********************************************** 
+      SUBROUTINE CUFLX &
+         (KLON,     KLEV,     KLEVP1,   PQEN,    PQSEN,     &
+          PTENH,    PQENH,    PAPH,     PGEOH,   KCBOT,    &
+          KCTOP,    KDTOP,    KTYPE,    LDDRAF,  LDCUM,  &
+          PMFU,     PMFD,     PMFUS,    PMFDS,   PMFUQ,  &
+          PMFDQ,    PMFUL,    PLUDE,    PDMFUP,  PDMFDP, &
+          PRFL,     PRAIN,    PTEN,     PSFL,    PDPMEL, &
+          KTOPM2,   ZTMST,    sig1)
+!      M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
+!***PURPOSE
+!   -------
+!          THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE
+!          FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER
+!***INTERFACE
+!   ---------
+!          THIS ROUTINE IS CALLED FROM *CUMASTR*.
+!***EXTERNALS
+!   ---------
+!          NONE
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+      INTEGER   KLON, KLEV, KLEVP1
+      INTEGER   KTOPM2, ITOP, JL, JK, IKB
+      REAL      ZTMST, ZCONS1, ZCONS2, ZCUCOV, ZTMELP2
+      REAL      ZZP, ZFAC, ZSNMLT, ZRFL, CEVAPCU, ZRNEW
+      REAL      ZRMIN, ZRFLN, ZDRFL, ZDPEVAP
+      REAL     PQEN(KLON,KLEV),        PQSEN(KLON,KLEV),  &
+              PTENH(KLON,KLEV),       PQENH(KLON,KLEV),   &
+              PAPH(KLON,KLEVP1),      PGEOH(KLON,KLEV)    
+      REAL     PMFU(KLON,KLEV),        PMFD(KLON,KLEV),   &
+              PMFUS(KLON,KLEV),       PMFDS(KLON,KLEV),   &
+              PMFUQ(KLON,KLEV),       PMFDQ(KLON,KLEV),   &
+              PDMFUP(KLON,KLEV),      PDMFDP(KLON,KLEV),  &
+              PMFUL(KLON,KLEV),       PLUDE(KLON,KLEV),   &
+              PRFL(KLON),             PRAIN(KLON)
+      REAL     PTEN(KLON,KLEV),        PDPMEL(KLON,KLEV), &
+              PSFL(KLON),             ZPSUBCL(KLON)
+      REAL     sig1(KLEV)
+      INTEGER  KCBOT(KLON),            KCTOP(KLON),     &
+              KDTOP(KLON),            KTYPE(KLON)
+      LOGICAL  LDDRAF(KLON),           LDCUM(KLON)
+!*       SPECIFY CONSTANTS
+      ZCONS1=CPD/(ALF*G*ZTMST)
+      ZCONS2=1./(G*ZTMST)
+      ZCUCOV=0.05
+      ZTMELP2=TMELT+2.
+!*  1.0      DETERMINE FINAL CONVECTIVE FLUXES
+!---------------------------------------------
+  100 CONTINUE
+      ITOP=KLEV
+      DO 110 JL=1,KLON
+      PRFL(JL)=0.
+      PSFL(JL)=0.
+      PRAIN(JL)=0.
+!     SWITCH OFF SHALLOW CONVECTION
+      IF(.NOT.LMFSCV.AND.KTYPE(JL).EQ.2)THEN
+        LDCUM(JL)=.FALSE.
+        LDDRAF(JL)=.FALSE.
+      ENDIF
+      ITOP=MIN(ITOP,KCTOP(JL))
+      IF(.NOT.LDCUM(JL).OR.KDTOP(JL).LT.KCTOP(JL)) LDDRAF(JL)=.FALSE.
+      IF(.NOT.LDCUM(JL)) KTYPE(JL)=0
+  110 CONTINUE
+      KTOPM2=ITOP-2
+      DO 120 JK=KTOPM2,KLEV
+      DO 115 JL=1,KLON
+      IF(LDCUM(JL).AND.JK.GE.KCTOP(JL)-1) THEN
+         PMFUS(JL,JK)=PMFUS(JL,JK)-PMFU(JL,JK)*  &
+                     (CPD*PTENH(JL,JK)+PGEOH(JL,JK))
+         PMFUQ(JL,JK)=PMFUQ(JL,JK)-PMFU(JL,JK)*PQENH(JL,JK)
+         IF(LDDRAF(JL).AND.JK.GE.KDTOP(JL)) THEN
+            PMFDS(JL,JK)=PMFDS(JL,JK)-PMFD(JL,JK)*  &
+                        (CPD*PTENH(JL,JK)+PGEOH(JL,JK))
+            PMFDQ(JL,JK)=PMFDQ(JL,JK)-PMFD(JL,JK)*PQENH(JL,JK)
+         ELSE
+            PMFD(JL,JK)=0.
+            PMFDS(JL,JK)=0.
+            PMFDQ(JL,JK)=0.
+            PDMFDP(JL,JK-1)=0.
+         END IF
+      ELSE
+         PMFU(JL,JK)=0.
+         PMFD(JL,JK)=0.
+         PMFUS(JL,JK)=0.
+         PMFDS(JL,JK)=0.
+         PMFUQ(JL,JK)=0.
+         PMFDQ(JL,JK)=0.
+         PMFUL(JL,JK)=0.
+         PDMFUP(JL,JK-1)=0.
+         PDMFDP(JL,JK-1)=0.
+         PLUDE(JL,JK-1)=0.
+      END IF
+  115 CONTINUE
+  120 CONTINUE
+      DO 130 JK=KTOPM2,KLEV
+      DO 125 JL=1,KLON
+      IF(LDCUM(JL).AND.JK.GT.KCBOT(JL)) THEN
+         IKB=KCBOT(JL)
+         ZZP=((PAPH(JL,KLEVP1)-PAPH(JL,JK))/  &
+             (PAPH(JL,KLEVP1)-PAPH(JL,IKB)))
+         IF(KTYPE(JL).EQ.3) THEN
+            ZZP=ZZP**2
+         ENDIF
+         PMFU(JL,JK)=PMFU(JL,IKB)*ZZP
+         PMFUS(JL,JK)=PMFUS(JL,IKB)*ZZP
+         PMFUQ(JL,JK)=PMFUQ(JL,IKB)*ZZP
+         PMFUL(JL,JK)=PMFUL(JL,IKB)*ZZP
+      END IF
+!*    2.        CALCULATE RAIN/SNOW FALL RATES
+!*              CALCULATE MELTING OF SNOW
+!*              CALCULATE EVAPORATION OF PRECIP
+!----------------------------------------------
+      IF(LDCUM(JL)) THEN
+         PRAIN(JL)=PRAIN(JL)+PDMFUP(JL,JK)
+         IF(PTEN(JL,JK).GT.TMELT) THEN
+            PRFL(JL)=PRFL(JL)+PDMFUP(JL,JK)+PDMFDP(JL,JK)
+            IF(PSFL(JL).GT.0..AND.PTEN(JL,JK).GT.ZTMELP2) THEN
+               ZFAC=ZCONS1*(PAPH(JL,JK+1)-PAPH(JL,JK))
+               ZSNMLT=MIN(PSFL(JL),ZFAC*(PTEN(JL,JK)-ZTMELP2))
+               PDPMEL(JL,JK)=ZSNMLT
+               PSFL(JL)=PSFL(JL)-ZSNMLT
+               PRFL(JL)=PRFL(JL)+ZSNMLT
+            END IF
+         ELSE
+            PSFL(JL)=PSFL(JL)+PDMFUP(JL,JK)+PDMFDP(JL,JK)
+         END IF
+      END IF
+  125 CONTINUE
+  130 CONTINUE
+      DO 230 JL=1,KLON
+        PRFL(JL)=MAX(PRFL(JL),0.)
+        PSFL(JL)=MAX(PSFL(JL),0.)
+        ZPSUBCL(JL)=PRFL(JL)+PSFL(JL)
+  230 CONTINUE
+      DO 240 JK=KTOPM2,KLEV
+      DO 235 JL=1,KLON
+      IF(LDCUM(JL).AND.JK.GE.KCBOT(JL).AND. &
+             ZPSUBCL(JL).GT.1.E-20) THEN
+          ZRFL=ZPSUBCL(JL)
+          CEVAPCU=CEVAPCU1*SQRT(CEVAPCU2*SQRT(sig1(JK)))
+          ZRNEW=(MAX(0.,SQRT(ZRFL/ZCUCOV)-   &
+                  CEVAPCU*(PAPH(JL,JK+1)-PAPH(JL,JK))* &
+                MAX(0.,PQSEN(JL,JK)-PQEN(JL,JK))))**2*ZCUCOV
+          ZRMIN=ZRFL-ZCUCOV*MAX(0.,0.8*PQSEN(JL,JK)-PQEN(JL,JK)) &
+               *ZCONS2*(PAPH(JL,JK+1)-PAPH(JL,JK))
+          ZRNEW=MAX(ZRNEW,ZRMIN)
+          ZRFLN=MAX(ZRNEW,0.)
+          ZDRFL=MIN(0.,ZRFLN-ZRFL)
+          PDMFUP(JL,JK)=PDMFUP(JL,JK)+ZDRFL
+          ZPSUBCL(JL)=ZRFLN
+      END IF
+  235 CONTINUE
+  240 CONTINUE
+      DO 250 JL=1,KLON
+        ZDPEVAP=ZPSUBCL(JL)-(PRFL(JL)+PSFL(JL))
+        PRFL(JL)=PRFL(JL)+ZDPEVAP*PRFL(JL)*  &
+                  (1./MAX(1.E-20,PRFL(JL)+PSFL(JL)))
+        PSFL(JL)=PSFL(JL)+ZDPEVAP*PSFL(JL)*  &
+                  (1./MAX(1.E-20,PRFL(JL)+PSFL(JL)))
+  250 CONTINUE
+      RETURN
+      END SUBROUTINE CUFLX
+!
+
+!**********************************************
+!       SUBROUTINE CUDTDQ
+!********************************************** 
+      SUBROUTINE CUDTDQ &
+         (KLON,     KLEV,     KLEVP1,   KTOPM2,   PAPH,   &
+          LDCUM,    PTEN,     PTTE,     PQTE,     PMFUS,  &
+          PMFDS,    PMFUQ,    PMFDQ,    PMFUL,    PDMFUP, &
+          PDMFDP,   ZTMST,    PDPMEL,   PRAIN,    PRFL,   &
+          PSFL,     PSRAIN,   PSEVAP,   PSHEAT,   PSMELT, &
+          PRSFC,    PSSFC,    PAPRC,    PAPRSM,   PAPRS,  &
+          PQEN,     PQSEN,    PLUDE,    PCTE)
+!**** *CUDTDQ* - UPDATES T AND Q TENDENCIES, PRECIPITATION RATES
+!                DOES GLOBAL DIAGNOSTICS
+!      M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
+!***INTERFACE.
+!   ----------
+!          *CUDTDQ* IS CALLED FROM *CUMASTR*
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+      INTEGER   KLON, KLEV, KLEVP1
+      INTEGER   KTOPM2,JL, JK
+      REAL      ZTMST, PSRAIN, PSEVAP, PSHEAT, PSMELT, ZDIAGT, ZDIAGW
+      REAL      ZALV, RHK, RHCOE, PLDFD, ZDTDT, ZDQDT
+      REAL     PTTE(KLON,KLEV),        PQTE(KLON,KLEV),  &
+              PTEN(KLON,KLEV),        PLUDE(KLON,KLEV),  &
+              PGEO(KLON,KLEV),        PAPH(KLON,KLEVP1), &
+              PAPRC(KLON),            PAPRS(KLON),       &
+              PAPRSM(KLON),           PCTE(KLON,KLEV),   &
+              PRSFC(KLON),            PSSFC(KLON)
+      REAL     PMFUS(KLON,KLEV),       PMFDS(KLON,KLEV), &
+              PMFUQ(KLON,KLEV),       PMFDQ(KLON,KLEV), &
+              PMFUL(KLON,KLEV),       PQSEN(KLON,KLEV), &
+              PDMFUP(KLON,KLEV),      PDMFDP(KLON,KLEV),& 
+              PRFL(KLON),             PRAIN(KLON),      &
+              PQEN(KLON,KLEV)
+      REAL     PDPMEL(KLON,KLEV),      PSFL(KLON)
+      REAL     ZSHEAT(KLON),           ZMELT(KLON)
+      LOGICAL  LDCUM(KLON)
+!--------------------------------
+!*    1.0      SPECIFY PARAMETERS
+!--------------------------------
+  100 CONTINUE
+      ZDIAGT=ZTMST
+      ZDIAGW=ZDIAGT/RHOH2O
+!--------------------------------------------------
+!*    2.0      INCREMENTATION OF T AND Q TENDENCIES
+!--------------------------------------------------
+  200 CONTINUE
+      DO 210 JL=1,KLON
+      ZMELT(JL)=0.
+      ZSHEAT(JL)=0.
+  210 CONTINUE
+      DO 250 JK=KTOPM2,KLEV
+      IF(JK.LT.KLEV) THEN
+         DO 220 JL=1,KLON
+         IF(LDCUM(JL)) THEN
+            IF(PTEN(JL,JK).GT.TMELT) THEN
+               ZALV=ALV
+            ELSE
+               ZALV=ALS
+            ENDIF
+            RHK=MIN(1.0,PQEN(JL,JK)/PQSEN(JL,JK))
+            RHCOE=MAX(0.0,(RHK-RHC)/(RHM-RHC))
+            pldfd=MAX(0.0,RHCOE*fdbk*PLUDE(JL,JK))
+            ZDTDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*RCPD*      &
+              (PMFUS(JL,JK+1)-PMFUS(JL,JK)+                  &
+              PMFDS(JL,JK+1)-PMFDS(JL,JK)-ALF*PDPMEL(JL,JK)  &
+              -ZALV*(PMFUL(JL,JK+1)-PMFUL(JL,JK)-pldfd-      &
+              (PDMFUP(JL,JK)+PDMFDP(JL,JK))))
+            PTTE(JL,JK)=PTTE(JL,JK)+ZDTDT
+            ZDQDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*& 
+              (PMFUQ(JL,JK+1)-PMFUQ(JL,JK)+       &
+              PMFDQ(JL,JK+1)-PMFDQ(JL,JK)+        &
+              PMFUL(JL,JK+1)-PMFUL(JL,JK)-pldfd-  &
+              (PDMFUP(JL,JK)+PDMFDP(JL,JK)))
+            PQTE(JL,JK)=PQTE(JL,JK)+ZDQDT
+            PCTE(JL,JK)=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*pldfd
+            ZSHEAT(JL)=ZSHEAT(JL)+ZALV*(PDMFUP(JL,JK)+PDMFDP(JL,JK))
+            ZMELT(JL)=ZMELT(JL)+PDPMEL(JL,JK)
+         END IF
+  220 CONTINUE
+      ELSE
+         DO 230 JL=1,KLON
+         IF(LDCUM(JL)) THEN
+            IF(PTEN(JL,JK).GT.TMELT) THEN
+               ZALV=ALV
+            ELSE
+               ZALV=ALS
+            ENDIF
+            RHK=MIN(1.0,PQEN(JL,JK)/PQSEN(JL,JK))
+            RHCOE=MAX(0.0,(RHK-RHC)/(RHM-RHC))
+            pldfd=MAX(0.0,RHCOE*fdbk*PLUDE(JL,JK))
+            ZDTDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*RCPD*           &
+                (PMFUS(JL,JK)+PMFDS(JL,JK)+ALF*PDPMEL(JL,JK)-ZALV* &
+                (PMFUL(JL,JK)+PDMFUP(JL,JK)+PDMFDP(JL,JK)+pldfd))  
+            PTTE(JL,JK)=PTTE(JL,JK)+ZDTDT
+            ZDQDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*                &
+                     (PMFUQ(JL,JK)+PMFDQ(JL,JK)+pldfd+             &
+                     (PMFUL(JL,JK)+PDMFUP(JL,JK)+PDMFDP(JL,JK)))   
+            PQTE(JL,JK)=PQTE(JL,JK)+ZDQDT
+            PCTE(JL,JK)=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*pldfd
+            ZSHEAT(JL)=ZSHEAT(JL)+ZALV*(PDMFUP(JL,JK)+PDMFDP(JL,JK))
+            ZMELT(JL)=ZMELT(JL)+PDPMEL(JL,JK)
+         END IF
+  230    CONTINUE
+      END IF
+  250 CONTINUE
+!---------------------------------------------------------
+!      3.      UPDATE SURFACE FIELDS AND DO GLOBAL BUDGETS
+!---------------------------------------------------------
+  300 CONTINUE
+      DO 310 JL=1,KLON
+      PRSFC(JL)=PRFL(JL)
+      PSSFC(JL)=PSFL(JL)
+      PAPRC(JL)=PAPRC(JL)+ZDIAGW*(PRFL(JL)+PSFL(JL))
+      PAPRS(JL)=PAPRSM(JL)+ZDIAGW*PSFL(JL)
+      PSHEAT=PSHEAT+ZSHEAT(JL)
+      PSRAIN=PSRAIN+PRAIN(JL)
+      PSEVAP=PSEVAP-(PRFL(JL)+PSFL(JL))
+      PSMELT=PSMELT+ZMELT(JL)
+  310 CONTINUE
+      PSEVAP=PSEVAP+PSRAIN
+      RETURN
+      END SUBROUTINE CUDTDQ
+
+!
+!**********************************************
+!       SUBROUTINE CUDUDV
+!********************************************** 
+      SUBROUTINE CUDUDV &
+         (KLON,     KLEV,     KLEVP1,   KTOPM2,   KTYPE,  &
+          KCBOT,    PAPH,     LDCUM,    PUEN,     PVEN,   &
+          PVOM,     PVOL,     PUU,      PUD,      PVU,    &
+          PVD,      PMFU,     PMFD,     PSDISS)
+!**** *CUDUDV* - UPDATES U AND V TENDENCIES,
+!                DOES GLOBAL DIAGNOSTIC OF DISSIPATION
+!      M.TIEDTKE         E.C.M.W.F.     7/86 MODIF.  12/89
+!***INTERFACE.
+!   ----------
+!          *CUDUDV* IS CALLED FROM *CUMASTR*
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+      INTEGER   KLON, KLEV, KLEVP1
+      INTEGER   KTOPM2, JK, IK, JL, IKB
+      REAL      PSDISS,ZZP, ZDUDT ,ZDVDT, ZSUM
+      REAL     PUEN(KLON,KLEV),        PVEN(KLON,KLEV),   &
+              PVOL(KLON,KLEV),        PVOM(KLON,KLEV),    &
+              PAPH(KLON,KLEVP1)
+      REAL     PUU(KLON,KLEV),         PUD(KLON,KLEV),    &
+              PVU(KLON,KLEV),         PVD(KLON,KLEV),     &
+              PMFU(KLON,KLEV),        PMFD(KLON,KLEV)
+      REAL     ZMFUU(KLON,KLEV),       ZMFDU(KLON,KLEV),  &
+              ZMFUV(KLON,KLEV),       ZMFDV(KLON,KLEV),   &
+              ZDISS(KLON)
+      INTEGER  KTYPE(KLON),            KCBOT(KLON)
+      LOGICAL  LDCUM(KLON)
+!------------------------------------------------------------
+!*    1.0      CALCULATE FLUXES AND UPDATE U AND V TENDENCIES
+! -----------------------------------------------------------
+  100 CONTINUE
+      DO 120 JK=KTOPM2,KLEV
+      IK=JK-1
+      DO 110 JL=1,KLON
+      IF(LDCUM(JL)) THEN
+        ZMFUU(JL,JK)=PMFU(JL,JK)*(PUU(JL,JK)-PUEN(JL,IK))
+        ZMFUV(JL,JK)=PMFU(JL,JK)*(PVU(JL,JK)-PVEN(JL,IK))
+        ZMFDU(JL,JK)=PMFD(JL,JK)*(PUD(JL,JK)-PUEN(JL,IK))
+        ZMFDV(JL,JK)=PMFD(JL,JK)*(PVD(JL,JK)-PVEN(JL,IK))
+      END IF
+  110 CONTINUE
+  120 CONTINUE
+      DO 140 JK=KTOPM2,KLEV
+      DO 130 JL=1,KLON
+      IF(LDCUM(JL).AND.JK.GT.KCBOT(JL)) THEN
+         IKB=KCBOT(JL)
+         ZZP=((PAPH(JL,KLEVP1)-PAPH(JL,JK))/  &
+             (PAPH(JL,KLEVP1)-PAPH(JL,IKB)))
+         IF(KTYPE(JL).EQ.3) THEN
+            ZZP=ZZP**2
+         ENDIF
+         ZMFUU(JL,JK)=ZMFUU(JL,IKB)*ZZP
+         ZMFUV(JL,JK)=ZMFUV(JL,IKB)*ZZP
+         ZMFDU(JL,JK)=ZMFDU(JL,IKB)*ZZP
+         ZMFDV(JL,JK)=ZMFDV(JL,IKB)*ZZP
+      END IF
+  130 CONTINUE
+  140 CONTINUE
+      DO 150 JL=1,KLON
+      ZDISS(JL)=0.
+  150 CONTINUE
+      DO 190 JK=KTOPM2,KLEV
+      IF(JK.LT.KLEV) THEN
+         DO 160 JL=1,KLON
+            IF(LDCUM(JL)) THEN
+               ZDUDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
+                    (ZMFUU(JL,JK+1)-ZMFUU(JL,JK)+     &
+                     ZMFDU(JL,JK+1)-ZMFDU(JL,JK))
+               ZDVDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
+                    (ZMFUV(JL,JK+1)-ZMFUV(JL,JK)+     &
+                     ZMFDV(JL,JK+1)-ZMFDV(JL,JK))
+               ZDISS(JL)=ZDISS(JL)+        &
+                        PUEN(JL,JK)*(ZMFUU(JL,JK+1)-ZMFUU(JL,JK)+   &
+                                     ZMFDU(JL,JK+1)-ZMFDU(JL,JK))+  &
+                        PVEN(JL,JK)*(ZMFUV(JL,JK+1)-ZMFUV(JL,JK)+   &
+                                     ZMFDV(JL,JK+1)-ZMFDV(JL,JK))
+               PVOM(JL,JK)=PVOM(JL,JK)+ZDUDT
+               PVOL(JL,JK)=PVOL(JL,JK)+ZDVDT
+            END IF
+  160    CONTINUE
+      ELSE
+         DO 170 JL=1,KLON
+            IF(LDCUM(JL)) THEN
+               ZDUDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
+                        (ZMFUU(JL,JK)+ZMFDU(JL,JK))
+               ZDVDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
+                        (ZMFUV(JL,JK)+ZMFDV(JL,JK))
+               ZDISS(JL)=ZDISS(JL)-        &
+      (PUEN(JL,JK)*(ZMFUU(JL,JK)+ZMFDU(JL,JK))+ &
+      PVEN(JL,JK)*(ZMFUV(JL,JK)+ZMFDV(JL,JK)))
+               PVOM(JL,JK)=PVOM(JL,JK)+ZDUDT
+               PVOL(JL,JK)=PVOL(JL,JK)+ZDVDT
+            END IF
+  170    CONTINUE
+       END IF
+  190 CONTINUE
+      ZSUM=SSUM(KLON,ZDISS(1),1)
+      PSDISS=PSDISS+ZSUM
+      RETURN
+      END SUBROUTINE CUDUDV
+!
+
+!#################################################################
+!
+!                 LEVEL 4 SUBROUTINES
+!
+!#################################################################
+!**************************************************************
+!             SUBROUTINE CUBASMC
+!**************************************************************
+      SUBROUTINE CUBASMC   &
+         (KLON,     KLEV,     KLEVM1,  KK,     PTEN,  &
+          PQEN,     PQSEN,    PUEN,    PVEN,   PVERV, &
+          PGEO,     PGEOH,    LDCUM,   KTYPE,  KLAB,  &
+          PMFU,     PMFUB,    PENTR,   KCBOT,  PTU,   &
+          PQU,      PLU,      PUU,     PVU,    PMFUS, &
+          PMFUQ,    PMFUL,    PDMFUP,  PMFUU,  PMFUV) 
+!      M.TIEDTKE         E.C.M.W.F.     12/89
+!***PURPOSE.
+!   --------
+!          THIS ROUTINE CALCULATES CLOUD BASE VALUES
+!          FOR MIDLEVEL CONVECTION
+!***INTERFACE
+!   ---------
+!          THIS ROUTINE IS CALLED FROM *CUASC*.
+!          INPUT ARE ENVIRONMENTAL VALUES T,Q ETC
+!          IT RETURNS CLOUDBASE VALUES FOR MIDLEVEL CONVECTION
+!***METHOD.
+!   -------
+!          S. TIEDTKE (1989)
+!***EXTERNALS
+!   ---------
+!          NONE
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+      INTEGER   KLON, KLEV, KLEVP1
+      INTEGER   KLEVM1,KK, JL
+      REAL      zzzmb
+      REAL     PTEN(KLON,KLEV),        PQEN(KLON,KLEV),  &
+              PUEN(KLON,KLEV),        PVEN(KLON,KLEV),   &
+              PQSEN(KLON,KLEV),       PVERV(KLON,KLEV),  & 
+              PGEO(KLON,KLEV),        PGEOH(KLON,KLEV)
+      REAL     PTU(KLON,KLEV),         PQU(KLON,KLEV),   &
+              PUU(KLON,KLEV),         PVU(KLON,KLEV),    &
+              PLU(KLON,KLEV),         PMFU(KLON,KLEV),   &
+              PMFUB(KLON),            PENTR(KLON),       &
+              PMFUS(KLON,KLEV),       PMFUQ(KLON,KLEV),  &
+              PMFUL(KLON,KLEV),       PDMFUP(KLON,KLEV), &
+              PMFUU(KLON),            PMFUV(KLON)
+      INTEGER  KTYPE(KLON),            KCBOT(KLON),      &
+              KLAB(KLON,KLEV)
+      LOGICAL  LDCUM(KLON)
+!--------------------------------------------------------
+!*    1.      CALCULATE ENTRAINMENT AND DETRAINMENT RATES
+! -------------------------------------------------------
+  100 CONTINUE
+         DO 150 JL=1,KLON
+          IF( .NOT. LDCUM(JL).AND.KLAB(JL,KK+1).EQ.0.0.AND.  &
+             PQEN(JL,KK).GT.0.90*PQSEN(JL,KK)) THEN
+            PTU(JL,KK+1)=(CPD*PTEN(JL,KK)+PGEO(JL,KK)-PGEOH(JL,KK+1)) &
+                               *RCPD
+            PQU(JL,KK+1)=PQEN(JL,KK)
+            PLU(JL,KK+1)=0.
+            ZZZMB=MAX(CMFCMIN,-PVERV(JL,KK)/G)
+            ZZZMB=MIN(ZZZMB,CMFCMAX)
+            PMFUB(JL)=ZZZMB
+            PMFU(JL,KK+1)=PMFUB(JL)
+            PMFUS(JL,KK+1)=PMFUB(JL)*(CPD*PTU(JL,KK+1)+PGEOH(JL,KK+1))
+            PMFUQ(JL,KK+1)=PMFUB(JL)*PQU(JL,KK+1)
+            PMFUL(JL,KK+1)=0.
+            PDMFUP(JL,KK+1)=0.
+            KCBOT(JL)=KK
+            KLAB(JL,KK+1)=1
+            KTYPE(JL)=3
+            PENTR(JL)=ENTRMID
+               IF(LMFDUDV) THEN
+                  PUU(JL,KK+1)=PUEN(JL,KK)
+                  PVU(JL,KK+1)=PVEN(JL,KK)
+                  PMFUU(JL)=PMFUB(JL)*PUU(JL,KK+1)
+                  PMFUV(JL)=PMFUB(JL)*PVU(JL,KK+1)
+               END IF
+         END IF
+  150   CONTINUE
+      RETURN
+      END SUBROUTINE CUBASMC
+
+!
+!**************************************************************
+!             SUBROUTINE CUADJTQ
+!**************************************************************
+      SUBROUTINE CUADJTQ(KLON,KLEV,KK,PP,PT,PQ,LDFLAG,KCALL)
+!      M.TIEDTKE         E.C.M.W.F.     12/89
+!      D.SALMOND         CRAY(UK))      12/8/91
+!***PURPOSE.
+!   --------
+!          TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT
+!***INTERFACE
+!   ---------
+!          THIS ROUTINE IS CALLED FROM SUBROUTINES:
+!              *CUBASE*   (T AND Q AT CONDENSTION LEVEL)
+!              *CUASC*    (T AND Q AT CLOUD LEVELS)
+!              *CUINI*    (ENVIRONMENTAL T AND QS VALUES AT HALF LEVELS)
+!          INPUT ARE UNADJUSTED T AND Q VALUES,
+!          IT RETURNS ADJUSTED VALUES OF T AND Q
+!          NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS
+!               KCALL=0    ENV. T AND QS IN*CUINI*
+!               KCALL=1  CONDENSATION IN UPDRAFTS  (E.G.  CUBASE, CUASC)
+!               KCALL=2  EVAPORATION IN DOWNDRAFTS (E.G.  CUDLFS,CUDDRAF
+!***EXTERNALS
+!   ---------
+!          3 LOOKUP TABLES ( TLUCUA, TLUCUB, TLUCUC )
+!          FOR CONDENSATION CALCULATIONS.
+!          THE TABLES ARE INITIALISED IN *SETPHYS*.
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+      INTEGER   KLON, KLEV
+      INTEGER   KK, KCALL, ISUM, JL
+      REAL      ZQSAT, ZCOR, ZCOND1, TT
+      REAL     PT(KLON,KLEV),          PQ(KLON,KLEV),  &
+              ZCOND(KLON),            ZQP(KLON),       &
+              PP(KLON)
+      LOGICAL  LDFLAG(KLON)
+!------------------------------------------------------------------
+!     2.      CALCULATE CONDENSATION AND ADJUST T AND Q ACCORDINGLY
+!------------------------------------------------------------------
+  200 CONTINUE
+      IF (KCALL.EQ.1 ) THEN
+         ISUM=0
+         DO 210 JL=1,KLON
+         ZCOND(JL)=0.
+         IF(LDFLAG(JL)) THEN
+            ZQP(JL)=1./PP(JL)
+            TT=PT(JL,KK)
+            ZQSAT=TLUCUA(TT)*ZQP(JL)
+            ZQSAT=MIN(0.5,ZQSAT)
+            ZCOR=1./(1.-VTMPC1*ZQSAT)
+            ZQSAT=ZQSAT*ZCOR
+            ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+            ZCOND(JL)=MAX(ZCOND(JL),0.)
+            PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
+            PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
+            IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
+         END IF
+  210    CONTINUE
+         IF(ISUM.EQ.0) GO TO 230
+         DO 220 JL=1,KLON
+         IF(LDFLAG(JL).AND.ZCOND(JL).NE.0.) THEN
+            TT=PT(JL,KK)
+            ZQSAT=TLUCUA(TT)*ZQP(JL)
+            ZQSAT=MIN(0.5,ZQSAT)
+            ZCOR=1./(1.-VTMPC1*ZQSAT)
+            ZQSAT=ZQSAT*ZCOR
+            ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+            PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
+            PQ(JL,KK)=PQ(JL,KK)-ZCOND1
+         END IF
+  220    CONTINUE
+  230    CONTINUE
+      END IF
+      IF(KCALL.EQ.2) THEN
+         ISUM=0
+         DO 310 JL=1,KLON
+         ZCOND(JL)=0.
+         IF(LDFLAG(JL)) THEN
+            TT=PT(JL,KK)
+            ZQP(JL)=1./PP(JL)
+            ZQSAT=TLUCUA(TT)*ZQP(JL)
+            ZQSAT=MIN(0.5,ZQSAT)
+            ZCOR=1./(1.-VTMPC1*ZQSAT)
+            ZQSAT=ZQSAT*ZCOR
+            ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+            ZCOND(JL)=MIN(ZCOND(JL),0.)
+            PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
+            PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
+            IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
+         END IF
+  310    CONTINUE
+         IF(ISUM.EQ.0) GO TO 330
+         DO 320 JL=1,KLON
+         IF(LDFLAG(JL).AND.ZCOND(JL).NE.0.) THEN
+            TT=PT(JL,KK)
+            ZQSAT=TLUCUA(TT)*ZQP(JL)
+            ZQSAT=MIN(0.5,ZQSAT)
+            ZCOR=1./(1.-VTMPC1*ZQSAT)
+            ZQSAT=ZQSAT*ZCOR
+            ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+            PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
+            PQ(JL,KK)=PQ(JL,KK)-ZCOND1
+         END IF
+  320    CONTINUE
+  330    CONTINUE
+      END IF
+      IF(KCALL.EQ.0) THEN
+         ISUM=0
+         DO 410 JL=1,KLON
+           TT=PT(JL,KK)
+           ZQP(JL)=1./PP(JL)
+           ZQSAT=TLUCUA(TT)*ZQP(JL)
+           ZQSAT=MIN(0.5,ZQSAT)
+           ZCOR=1./(1.-VTMPC1*ZQSAT)
+           ZQSAT=ZQSAT*ZCOR
+           ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+           PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
+           PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
+           IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
+  410    CONTINUE
+         IF(ISUM.EQ.0) GO TO 430
+         DO 420 JL=1,KLON
+           TT=PT(JL,KK)
+           ZQSAT=TLUCUA(TT)*ZQP(JL)
+           ZQSAT=MIN(0.5,ZQSAT)
+           ZCOR=1./(1.-VTMPC1*ZQSAT)
+           ZQSAT=ZQSAT*ZCOR
+           ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+           PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
+           PQ(JL,KK)=PQ(JL,KK)-ZCOND1
+  420    CONTINUE
+  430    CONTINUE
+      END IF
+      IF(KCALL.EQ.4) THEN
+         DO 510 JL=1,KLON
+           TT=PT(JL,KK)
+           ZQP(JL)=1./PP(JL)
+           ZQSAT=TLUCUA(TT)*ZQP(JL)
+           ZQSAT=MIN(0.5,ZQSAT)
+           ZCOR=1./(1.-VTMPC1*ZQSAT)
+           ZQSAT=ZQSAT*ZCOR
+           ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+           PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
+           PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
+  510    CONTINUE
+         DO 520 JL=1,KLON
+           TT=PT(JL,KK)
+           ZQSAT=TLUCUA(TT)*ZQP(JL)
+           ZQSAT=MIN(0.5,ZQSAT)
+           ZCOR=1./(1.-VTMPC1*ZQSAT)
+           ZQSAT=ZQSAT*ZCOR
+           ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+           PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
+           PQ(JL,KK)=PQ(JL,KK)-ZCOND1
+  520    CONTINUE
+      END IF
+      RETURN
+      END SUBROUTINE CUADJTQ
+
+!
+!**********************************************************
+!        SUBROUTINE CUENTR_NEW
+!**********************************************************
+      SUBROUTINE CUENTR_NEW                              &   
+         (KLON,     KLEV,     KLEVP1,   KK,       PTENH, &
+          PAPH,     PAP,      PGEOH,    KLWMIN,   LDCUM, &
+          KTYPE,    KCBOT,    KCTOP0,   ZPBASE,   PMFU,  &
+          PENTR,    ZDMFEN,   ZDMFDE,   ZODETR,   KHMIN)
+!      M.TIEDTKE         E.C.M.W.F.     12/89
+!      Y.WANG            IPRC           11/01
+!***PURPOSE.
+!   --------
+!          THIS ROUTINE CALCULATES ENTRAINMENT/DETRAINMENT RATES
+!          FOR UPDRAFTS IN CUMULUS PARAMETERIZATION
+!***INTERFACE
+!   ---------
+!          THIS ROUTINE IS CALLED FROM *CUASC*.
+!          INPUT ARE ENVIRONMENTAL VALUES T,Q ETC
+!          AND UPDRAFT VALUES T,Q ETC
+!          IT RETURNS ENTRAINMENT/DETRAINMENT RATES
+!***METHOD.
+!  --------
+!          S. TIEDTKE (1989), NORDENG(1996)
+!***EXTERNALS
+!   ---------
+!          NONE
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+      INTEGER   KLON, KLEV, KLEVP1
+      INTEGER   KK, JL, IKLWMIN,IKB, IKT, IKH
+      REAL      ZRRHO, ZDPRHO, ZPMID, ZENTR, ZZMZK, ZTMZK, ARG, ZORGDE
+      REAL     PTENH(KLON,KLEV),                           &
+              PAP(KLON,KLEV),         PAPH(KLON,KLEVP1),   &
+              PMFU(KLON,KLEV),        PGEOH(KLON,KLEV),    &
+              PENTR(KLON),            ZPBASE(KLON),        &
+              ZDMFEN(KLON),           ZDMFDE(KLON),        &
+              ZODETR(KLON,KLEV)
+      INTEGER  KLWMIN(KLON),           KTYPE(KLON),        &
+              KCBOT(KLON),            KCTOP0(KLON),        &
+              KHMIN(KLON)
+      LOGICAL  LDCUM(KLON),LLO1,LLO2
+!---------------------------------------------------------
+!*    1.       CALCULATE ENTRAINMENT AND DETRAINMENT RATES
+!---------------------------------------------------------
+!*    1.1      SPECIFY ENTRAINMENT RATES FOR SHALLOW CLOUDS
+!----------------------------------------------------------
+!*    1.2      SPECIFY ENTRAINMENT RATES FOR DEEP CLOUDS
+!-------------------------------------------------------
+      DO jl = 1, klon
+        zpbase(jl) = paph(jl,kcbot(jl))
+        zrrho = (rd*ptenh(jl,kk+1))/paph(jl,kk+1)
+        zdprho = (paph(jl,kk+1)-paph(jl,kk))*zrg
+        zpmid = 0.5*(zpbase(jl)+paph(jl,kctop0(jl)))
+        zentr = pentr(jl)*pmfu(jl,kk+1)*zdprho*zrrho
+        llo1 = kk.LT.kcbot(jl).AND.ldcum(jl)
+        if(llo1) then
+           zdmfde(jl) = zentr
+        else
+           zdmfde(jl) = 0.0
+        endif
+        llo2 = llo1.AND.ktype(jl).EQ.2.AND.((zpbase(jl)-paph(jl,kk)) &
+             .LT.ZDNOPRC.OR.paph(jl,kk).GT.zpmid)
+        if(llo2) then
+            zdmfen(jl) = zentr
+        else
+            zdmfen(jl) = 0.0
+        endif
+        iklwmin = MAX(klwmin(jl),kctop0(jl)+2)
+        llo2 = llo1.AND.ktype(jl).EQ.3.AND.(kk.GE.iklwmin.OR.pap(jl,kk) &
+             .GT.zpmid)
+        IF (llo2) zdmfen(jl) = zentr
+        llo2 = llo1.AND.ktype(jl).EQ.1
+! Turbulent entrainment
+        IF (llo2) zdmfen(jl) = zentr
+! Organized detrainment, detrainment starts at khmin
+        ikb = kcbot(jl)
+        zodetr(jl,kk) = 0.
+        IF (llo2.AND.kk.LE.khmin(jl).AND.kk.GE.kctop0(jl)) THEN
+          ikt = kctop0(jl)
+          ikh = khmin(jl)
+          IF (ikh.GT.ikt) THEN
+            zzmzk = -(pgeoh(jl,ikh)-pgeoh(jl,kk))*zrg
+            ztmzk = -(pgeoh(jl,ikh)-pgeoh(jl,ikt))*zrg
+            arg = 3.1415*(zzmzk/ztmzk)*0.5
+            zorgde = TAN(arg)*3.1415*0.5/ztmzk
+            zdprho = (paph(jl,kk+1)-paph(jl,kk))*(zrg*zrrho)
+            zodetr(jl,kk) = MIN(zorgde,1.E-3)*pmfu(jl,kk+1)*zdprho
+          END IF
+        END IF
+      ENDDO
+! 
+      RETURN
+      END SUBROUTINE CUENTR_NEW
+!
+
+!**********************************************************
+!        FUNCTION SSUM, TLUCUA, TLUCUB, TLUCUC
+!**********************************************************
+      REAL FUNCTION SSUM ( N, X, IX )
+!
+! COMPUTES SSUM = SUM OF [X(I)]
+!     FOR N ELEMENTS OF X WITH SKIP INCREMENT IX FOR VECTOR X
+!
+      IMPLICIT NONE
+      REAL X(*)
+      REAL ZSUM
+      INTEGER N, IX, JX, JL
+!
+      JX = 1
+      ZSUM = 0.0
+      DO JL = 1, N
+        ZSUM = ZSUM + X(JX)
+        JX = JX + IX
+      enddo
+!
+      SSUM=ZSUM
+!
+      RETURN
+      END FUNCTION SSUM
+
+      REAL FUNCTION TLUCUA(TT)
+!
+!  Set up lookup tables for cloud ascent calculations.
+!
+      IMPLICIT NONE
+      REAL ZCVM3,ZCVM4,TT !,TLUCUA
+!
+      IF(TT-TMELT.GT.0.) THEN
+         ZCVM3=C3LES
+         ZCVM4=C4LES
+      ELSE
+         ZCVM3=C3IES
+         ZCVM4=C4IES
+      END IF
+      TLUCUA=C2ES*EXP(ZCVM3*(TT-TMELT)*(1./(TT-ZCVM4)))
+!
+      RETURN
+      END FUNCTION TLUCUA
+!
+      REAL FUNCTION TLUCUB(TT)
+!
+!  Set up lookup tables for cloud ascent calculations.
+!
+      IMPLICIT NONE
+      REAL Z5ALVCP,Z5ALSCP,ZCVM4,ZCVM5,TT !,TLUCUB
+!
+      Z5ALVCP=C5LES*ALV/CPD
+      Z5ALSCP=C5IES*ALS/CPD
+      IF(TT-TMELT.GT.0.) THEN
+         ZCVM4=C4LES
+         ZCVM5=Z5ALVCP
+      ELSE
+         ZCVM4=C4IES
+         ZCVM5=Z5ALSCP
+      END IF
+      TLUCUB=ZCVM5*(1./(TT-ZCVM4))**2
+!
+      RETURN
+      END FUNCTION TLUCUB
+!
+      REAL FUNCTION TLUCUC(TT)
+!
+!  Set up lookup tables for cloud ascent calculations.
+!
+      IMPLICIT NONE
+      REAL ZALVDCP,ZALSDCP,TT,ZLDCP !,TLUCUC
+!
+      ZALVDCP=ALV/CPD
+      ZALSDCP=ALS/CPD
+      IF(TT-TMELT.GT.0.) THEN
+         ZLDCP=ZALVDCP
+      ELSE
+         ZLDCP=ZALSDCP
+      END IF
+      TLUCUC=ZLDCP
+!
+      RETURN
+      END FUNCTION TLUCUC
+!
+
+END MODULE module_cu_tiedtke
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_cumulus_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_cumulus_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_cumulus_driver.F	(revision 17)
@@ -0,0 +1,905 @@
+!WRF:MEDIATION_LAYER:PHYSICS
+!
+
+MODULE module_cumulus_driver
+CONTAINS
+   SUBROUTINE cumulus_driver(grid                                     &
+                 ! Order dependent args for domain, mem, and tile dims
+                     ,ids,ide, jds,jde, kds,kde                       &
+                     ,ims,ime, jms,jme, kms,kme                       &
+                     ,ips,ipe, jps,jpe, kps,kpe                       &
+                     ,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,cudt,curr_secs,adapt_step_flag  &
+                     ,rainc,raincv,pratec,nca                         &
+                     ,z,z_at_w,dz8w,mavail,pblh,p8w,psfc,tsk          &
+                     ,tke_pbl, ust                                    &
+                     ,forcet,forceq,w0avg,stepcu,gsw                  &
+                     ,cldefi,lowlyr,xland,cu_act_flag,warm_rain       &
+                     ,hfx,qfx,cldfra,tpert2d,htop,hbot,kpbl,ht&
+                     ,ensdim,maxiens,maxens,maxens2,maxens3           &
+                     ,periodic_x,periodic_y                           &
+                 ! Package selection variables
+                     ,cu_physics, bl_pbl_physics, sf_sfclay_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,edt_out,clos_choice         &
+                     ,mass_flux,xf_ens,pr_ens,cugd_avedx,imomentum    &
+                     ,ishallow,cugd_tten,cugd_qvten,cugd_qcten        &
+                     ,cugd_ttens,cugd_qvtens                          &
+                     ,gd_cloud,gd_cloud2                              &
+                 ! Optional output arguments for CAMZM scheme
+                     ,cape, zmmu, zmmd, zmdt, zmdq, dlf, rliq         &
+                     ,pconvb, pconvt                                  &
+                     ,evaptzm, fzsntzm, evsntzm, evapqzm, zmflxprc    &
+                     ,zmflxsnw, zmntprpd, zmntsnpd, zmeiheat          &
+                     ,cmfmc, cmfmcdzm, preccdzm, precz                &
+                     ,zmmtu, zmmtv, zmupgu, zmupgd, zmvpgu, zmvpgd    &
+                     ,zmicuu, zmicud, zmicvu, zmicvd, zmdice, zmdliq  &
+                     ,k22_shallow,kbcon_shallow,ktop_shallow,xmb_shallow &
+                 ! Optional arguments for NSAS scheme
+                     ,mp_physics                                      &
+                 ! Optional moisture and other tendencies
+                     ,rqvcuten,rqccuten,rqrcuten                      &
+                     ,rqicuten,rqscuten,rqgcuten                      &
+                     ,rqvblten,rqvften                                &
+                     ,rucuten,rvcuten                                 &
+                     ,rthcuten,rthraten,rthblten,rthften              &
+#if (NMM_CORE==1)
+                 ! for hwrf-sas                      --- 3.2 CLEANUP TODO -- THESE SHOULD BE OPTIONAL, NOT #IF/#ENDIF
+                     ,mommix,store_rand                               &
+#endif
+! Optional variables for tiedtke scheme - add by ZCX&YQW 
+                     ,znu                                             &
+                 ! Optional moisture tracer flags 
+                     ,f_qv,f_qc,f_qr                                  &
+                     ,f_qi,f_qs,f_qg                                  &
+                     ,CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,f_flux            &
+                 ! Optional trigger function activation variable
+                     ,kfeta_trigger                                   &
+#if ( WRF_DFI_RADAR == 1 )
+                 ! Optional CAP suppress option      --- 3.2 CLEANUP TODO -- THESE SHOULD BE OPTIONAL, NOT #IF/#ENDIF
+                     ,do_capsuppress                                  &
+#endif                                 
+                                                                      )
+!----------------------------------------------------------------------
+   USE module_model_constants
+   USE module_state_description, ONLY:     KFSCHEME,BMJSCHEME         &
+                                          ,KFETASCHEME,GDSCHEME       &
+                                          ,G3SCHEME                   &
+                                          ,P_QC,P_QI,Param_FIRST_SCALAR &
+                                          ,CAMZMSCHEME, SASSCHEME     &
+                                          ,NSASSCHEME                 &
+                                          ,TIEDTKESCHEME
+
+! *** add new modules of schemes here
+
+   USE module_cu_kf     ,  ONLY : kfcps
+   USE module_cu_bmj    ,  ONLY : bmjdrv
+#ifdef DM_PARALLEL
+   USE module_dm        , ONLY : ntasks_x,ntasks_y,local_communicator,mytask,ntasks 
+# if (EM_CORE == 1)
+   USE module_comm_dm   ,  ONLY : halo_cup_g3_in_sub, halo_cup_g3_out_sub
+# endif
+#endif
+   USE module_domain    , ONLY: domain
+   USE module_cu_kfeta  , ONLY : kf_eta_cps
+   USE module_cu_gd     , ONLY : grelldrv
+   USE module_cu_g3     , ONLY : g3drv,conv_grell_spread3d
+   USE module_cu_sas
+   USE module_cu_camzm_driver, ONLY : camzm_driver
+   USE module_cu_tiedtke, ONLY : cu_tiedtke
+   USE module_cu_nsas   , ONLY : cu_nsas
+   USE module_wrf_error , ONLY : wrf_err_message
+
+   !  This driver calls subroutines for the cumulus parameterizations.
+   !
+   !  1. Kain & Fritsch (1993)
+   !  2. Betts-Miller-Janjic (Janjic, 1994)
+   !  3. Grell-Devenyi (Grell and Devenyi, 2002)
+   !  4. Simplified Arakawa-Schubert scheme (NCEP)
+   !     (adapted by Zhang and Wang to work with ARW in V3.3)
+   !  5. Grell 3D ensemble scheme
+   !  6. Modified Tiedtke scheme (Zhang and Wang 2010)
+   ! 14. New simplified Arakawa-Schubert scheme (NCEP, YSU)
+   !
+!----------------------------------------------------------------------
+   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)
+!-- CUDT          cumulus time step (minute)
+!-- curr_secs     current forecast time (seconds)
+!-- itimestep     number of time step (integer)   
+!-- DX            horizontal space interval (m)
+!-- rr            dry air density (kg/m^3)
+!
+!-- RUCUTEN       Zonal wind tendency due to 
+!                 cumulus scheme precipitation (m/s/s)
+!-- RVCUTEN       Meridional wind tendency due to 
+!                 cumulus scheme precipitation (m/s/s)
+!-- 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        time-step cumulus scheme precipitation (mm)
+!-- PRATEC        precipitiation rate from cumulus scheme (mm/s)
+!-- 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)
+!-- tsk           skin temperature (K)
+!-- tke_pbl       turbulent kinetic energy from PBL scheme (m2/s2)
+!-- ust           u* in similarity theory (m/s)
+!-- w             vertical velocity (m/s)
+!-- moist         moisture array (4D - last index is species) (kg/kg)
+!-- z             height above sea level at middle of layers (m)
+!-- z_at_w        height above sea level at layer interfaces (m)
+!-- dz8w          dz between full levels (m)
+!-- pblh          planetary boundary layer height (m)
+!-- mavail        soil moisture availability
+!-- p8w           pressure at full levels (Pa)
+!-- psfc          surface pressure (Pa)
+!-- p_phy         pressure (Pa)
+!-- pi_phy        exner function (dimensionless)
+!                 points (dimensionless)
+!-- hfx           upward heat flux at surface (W/m2)
+!-- qfx           upward moisture flux at surface (kg/m2/s)
+!-- 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
+!-- cldfra        cloud fraction
+!-- CU_ACT_FLAG
+!-- W0AVG         average vertical velocity, (for KF scheme) (m/s)
+!-- kfeta_trigger namelist for KF trigger (=1, default; =2, moisture-advection-dependent trigger)
+!-- 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
+!-- periodic_x    T/F this is using periodic lateral boundaries in the X direction
+!-- periodic_y    T/F this is using periodic lateral boundaries in the Y-direction
+!
+!======================================================================
+
+   INTEGER,      INTENT(IN   )    ::                             &
+                                      ids,ide, jds,jde, kds,kde, &
+                                      ims,ime, jms,jme, kms,kme, &
+                                                        kts,kte, &
+                                      itimestep, num_tiles
+   LOGICAL periodic_x, periodic_y
+   TYPE(domain) , INTENT(INOUT)          :: grid
+   INTEGER, DIMENSION(num_tiles), INTENT(IN) ::                       &
+     &           i_start,i_end,j_start,j_end
+
+   INTEGER,      INTENT(IN   )    ::                             &
+                  ensdim,maxiens,maxens,maxens2,maxens3
+
+   INTEGER, OPTIONAL,     INTENT(IN   )    ::                    &
+                   cugd_avedx,clos_choice,bl_pbl_physics,sf_sfclay_physics
+
+   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 ) ::                                          &
+                                                              z  &
+                                                      ,    dz8w  &
+                                                      ,     p8w  &
+                                                      ,       p  &
+                                                      ,      pi  &
+                                                      ,       u  &
+                                                      ,       v  &
+                                                      ,      th  &
+                                                      ,       t  &
+                                                      ,     rho  &
+                                                      ,       w  
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                 &
+         INTENT(IN ),OPTIONAL ::                         z_at_w  &
+                                                      ,  cldfra  &
+                                                      , tke_pbl  
+
+   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
+ 
+   REAL, DIMENSION( kms:kme ), OPTIONAL, INTENT(IN   ) ::        &
+                                                            znu
+
+   REAL, DIMENSION( ims:ime , jms:jme ),INTENT(INOUT),OPTIONAL :: &
+        PRATEC,MAVAIL,PBLH,PSFC,TSK,TPERT2D,UST,HFX,QFX
+   REAL, DIMENSION( ims:ime , jms:jme ) :: tmppratec
+                                                    
+   INTEGER, DIMENSION( ims:ime , jms:jme ),                      &
+                    INTENT(IN) ::                          KPBL
+
+   LOGICAL, DIMENSION( ims:ime , jms:jme ),                      &
+          INTENT(INOUT) :: CU_ACT_FLAG
+
+   INTEGER, INTENT(IN   ), OPTIONAL        ::   kfeta_trigger
+
+   REAL,  INTENT(IN   ) :: DT, DX
+   INTEGER,      INTENT(IN   ),OPTIONAL    ::                             &
+                   ips,ipe, jps,jpe, kps,kpe,imomentum,ishallow
+   REAL,  INTENT(IN   ),OPTIONAL :: CUDT
+   REAL,  INTENT(IN   ),OPTIONAL :: CURR_SECS
+   LOGICAL,INTENT(IN   ),OPTIONAL    ::     adapt_step_flag
+   REAL   :: cudt_pass, curr_secs_pass
+   LOGICAL :: adapt_step_flag_pass
+
+   INTEGER,      INTENT(IN   ), OPTIONAL    ::   mp_physics
+#if (NMM_CORE==1)
+   REAL, DIMENSION( ims:ime , jms:jme ),                         &
+                    INTENT(IN) ::  STORE_RAND
+   REAL,            INTENT(INOUT) :: mommix
+#endif
+
+   REAL, DIMENSION( ims:ime, jms:jme, kms:kme ),                 &
+                   INTENT(INOUT) :: rucuten,rvcuten
+!
+! optional arguments
+!
+   INTEGER, DIMENSION( ims:ime, jms:jme ),                       &
+         OPTIONAL, INTENT(INOUT) ::                              &
+     k22_shallow,kbcon_shallow,ktop_shallow
+   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                          &
+                     ,cugd_tten,cugd_qvten,cugd_qcten            &
+                     ,cugd_ttens,cugd_qvtens                     &
+                     ,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,edt_out,xmb_shallow          &
+                                                    , MASS_FLUX  &
+               ,cape, pconvb, pconvt, preccdzm, precz, rliq
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                 &
+         OPTIONAL, INTENT(INOUT) ::                              &
+                  GD_CLOUD,GD_CLOUD2,                            &
+                  zmmd, zmmu, zmdt, zmdq, dlf,                   &
+                  evaptzm, fzsntzm, evsntzm, evapqzm, zmflxprc,  &
+                  zmflxsnw, zmntprpd, zmntsnpd, zmeiheat,        &
+                  cmfmc, cmfmcdzm,                               &
+                  zmmtu, zmmtv, zmupgu, zmupgd, zmvpgu, zmvpgd,  &
+                  zmicuu, zmicud, zmicvu, zmicvd, zmdice, zmdliq
+   REAL, DIMENSION( ims:ime , jms:jme , 1:ensdim ),              &
+          OPTIONAL,                                              &
+          INTENT(INOUT) ::                       XF_ENS, PR_ENS
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+         OPTIONAL,                                              &
+         INTENT(INOUT) ::                                       &
+                                                   CFU1,        &
+                                                   CFD1,        &
+                                                   DFU1,        &
+                                                   EFU1,        &
+                                                   DFD1,        &
+                                                   EFD1
+
+!
+! 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
+   LOGICAL, INTENT(IN), OPTIONAL ::                   f_flux
+
+#if ( WRF_DFI_RADAR == 1 )
+!
+!  option of cap suppress: 
+!        do_capsuppress = 1   do
+!        do_capsuppress = other   don't
+!
+!
+   INTEGER,      INTENT(IN   ) ,OPTIONAL   :: do_capsuppress
+   REAL, DIMENSION( ims:ime, jms:jme ) :: cap_suppress_loc
+#endif
+
+! LOCAL  VAR
+
+   INTEGER :: i,j,k,its,ite,jts,jte,ij,trigger_kf
+   logical :: l_flux
+
+!-----------------------------------------------------------------
+
+   l_flux=.FALSE.
+   if (present(f_flux)) l_flux=f_flux
+   if (.not. PRESENT(CURR_SECS)) then
+      curr_secs_pass = -1
+   else 
+      curr_secs_pass = curr_secs
+   endif
+
+   if (.not. PRESENT(CUDT)) then
+      cudt_pass = -1
+   else
+      cudt_pass = cudt
+   endif
+
+   if (.not. PRESENT(adapt_step_flag)) then
+      adapt_step_flag_pass = .false.
+   else
+      adapt_step_flag_pass = adapt_step_flag
+   endif
+
+   ! Initialize tmppratec to pratec
+
+   if ( PRESENT ( pratec ) ) then
+      tmppratec(:,:) = pratec(:,:)
+   else
+      tmppratec(:,:) = 0.
+   end if
+
+   if (.not. PRESENT(kfeta_trigger)) then
+      trigger_kf = 1
+   else
+      trigger_kf = kfeta_trigger
+   endif
+
+   IF (cu_physics .eq. 0) return
+
+#if  ( EM_CORE == 1 )
+      if(cu_physics .eq. 5 ) 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,min(jte,jde-1)
+        do k=kts,kte
+        do i=its,min(ite,ide-1)
+           RTHFTEN(i,k,j)=(RTHFTEN(i,k,j)+RTHRATEN(i,k,j) &
+                               +RTHBLTEN(i,k,j))*pi(i,k,j)
+           RQVFTEN(i,k,j)=RQVFTEN(i,k,j)+RQVBLTEN(i,k,j)
+       enddo
+       enddo
+       enddo
+      ENDDO
+      !$OMP END PARALLEL DO
+      endif
+
+      IF ( cu_physics == G3SCHEME .OR. cu_physics == KFETASCHEME ) THEN
+#ifdef DM_PARALLEL
+#include "HALO_CUP_G3_IN.inc"
+#endif
+      ENDIF
+#endif
+
+! 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 , CUDT=cudt_pass   &
+               ,CURR_SECS=curr_secs_pass                        &
+               ,ADAPT_STEP_FLAG=adapt_step_flag_pass            &
+               ,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, PRATEC=tmppratec, 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, PRATEC=tmppratec      &
+               ,RHO=rho                                         &
+               ,DT=dt ,ITIMESTEP=itimestep ,STEPCU=stepcu       &
+               ,CUDT=cudt_pass                                  &
+               ,CURR_SECS=curr_secs_pass                        &
+               ,ADAPT_STEP_FLAG=adapt_step_flag_pass            &
+               ,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              &
+               ,CUDT=cudt_pass                                  &
+               ,CURR_SECS=curr_secs_pass                        &
+               ,ADAPT_STEP_FLAG=adapt_step_flag_pass            &
+               ,RAINCV=raincv, PRATEC=tmppratec, 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 &
+               ,trigger=trigger_kf                              &
+              ! optionals
+               ,RTHCUTEN=rthcuten                               &
+               ,RQVCUTEN=rqvcuten ,RQCCUTEN=rqccuten            &
+               ,RQRCUTEN=rqrcuten ,RQICUTEN=rqicuten            &
+               ,RQSCUTEN=rqscuten, RQVFTEN=RQVFTEN              &
+               ,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     &
+               ,PRATEC=tmppratec                                &
+               ,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 &
+               ,PERIODIC_X=periodic_x,PERIODIC_Y=periodic_y     &
+              ! 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                             &
+               ,CFU1=CFU1,CFD1=CFD1,DFU1=DFU1,EFU1=EFU1         &
+               ,DFD1=DFD1,EFD1=EFD1,f_flux=l_flux               )
+          CALL wrf_debug(200,'back from grelldrv')
+
+     CASE (SASSCHEME)
+                                                                                                                                           
+          IF ( adapt_step_flag_pass ) THEN
+            WRITE( wrf_err_message , * ) 'The SAS cumulus option will not work properly with an adaptive time step'
+            CALL wrf_error_fatal ( wrf_err_message )
+          END IF
+          CALL wrf_debug(100,'in cu_sas')
+          CALL CU_SAS(                                          &
+                DT=dt,ITIMESTEP=itimestep,STEPCU=STEPCU         &
+               ,RTHCUTEN=RTHCUTEN,RQVCUTEN=RQVCUTEN             &
+               ,RQCCUTEN=RQCCUTEN,RQICUTEN=RQICUTEN             &
+               ,RUCUTEN=RUCUTEN, RVCUTEN=RVCUTEN                &
+               ,RAINCV=RAINCV,PRATEC=tmpPRATEC,HTOP=HTOP,HBOT=HBOT &
+               ,U3D=u,V3D=v,W=w,T3D=t                           &
+               ,QV3D=QV_CURR,QC3D=QC_CURR,QI3D=QI_CURR          &
+               ,PI3D=pi,RHO3D=rho                               &
+               ,DZ8W=dz8w,PCPS=p,P8W=p8w,XLAND=XLAND            &
+               ,CU_ACT_FLAG=CU_ACT_FLAG                         &
+               ,P_QC=p_qc                                       &
+#if (NMM_CORE==1)
+               ,store_rand=store_rand  &
+               ,MOMMIX=MOMMIX  &
+#endif
+               ,P_QI=p_qi,P_FIRST_SCALAR=param_first_scalar     &
+               ,CUDT=cudt_pass                                  &
+               ,CURR_SECS=curr_secs_pass                        &
+               ,ADAPT_STEP_FLAG=adapt_step_flag_pass            &
+               ,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 (G3SCHEME)
+          CALL wrf_debug(100,'in grelldrv')
+#if ( WRF_DFI_RADAR == 1 )
+          if (do_capsuppress == 1) then
+            WRITE( wrf_err_message , * ) 'G3 do CAP suppress',its,jts,min( jte,jde-1 ),min( ite,ide-1 ),kte
+            CALL wrf_debug(200, wrf_err_message)
+            DO j = jts, min( jte,jde-1 )
+            DO i = its, min( ite,ide-1 )
+               cap_suppress_loc(i,j) = grid%dfi_tten_rad(i,kte,j)
+            ENDDO
+            ENDDO
+         endif
+#endif
+          CALL G3DRV(                                           &
+                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,PRATEC=tmppratec    &
+               ,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,edt_out=edt_out             &
+               ,GDC=gd_cloud,GDC2=gd_cloud2,kpbl=kpbl           &
+               ,k22_shallow=k22_shallow                         &
+               ,kbcon_shallow=kbcon_shallow                     &
+               ,ktop_shallow=ktop_shallow                       &
+               ,xmb_shallow=xmb_shallow                         &
+               ,cugd_tten=cugd_tten,cugd_qvten=cugd_qvten       &
+               ,cugd_ttens=cugd_ttens,cugd_qvtens=cugd_qvtens   &
+               ,cugd_qcten=cugd_qcten,cugd_avedx=cugd_avedx     &
+               ,imomentum=imomentum,ishallow_g3=ishallow        &
+               ,ENSDIM=ensdim,MAXIENS=maxiens,MAXENS=maxens     &
+               ,MAXENS2=maxens2,MAXENS3=maxens3,ichoice=clos_choice &
+               ,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 &
+               ,IPS=ips,IPE=ipe,JPS=jps,JPE=jpe,KPS=kps,KPE=kpe &
+               ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte &
+               ,PERIODIC_X=periodic_x,PERIODIC_Y=periodic_y     &
+              ! optionals
+#if (NMM_CORE == 1 )
+               ,RTHCUTEN=RTHCUTEN ,RTHFTEN=forcet               &
+               ,RQICUTEN=RQICUTEN ,RQVFTEN=forceq               &
+#else
+               ,RTHCUTEN=RTHCUTEN ,RTHFTEN=RTHFTEN              &
+               ,RQICUTEN=RQICUTEN ,RQVFTEN=RQVFTEN              &
+               ,rqvblten=rqvblten,rthblten=rthblten             &
+#endif
+               ,RQVCUTEN=RQVCUTEN,RQCCUTEN=RQCCUTEN             &
+               ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr                   &
+               ,F_QI=f_qi,F_QS=f_qs                             &
+#if ( WRF_DFI_RADAR == 1 )
+                 ! Optional CAP suppress option
+              ,do_capsuppress=do_capsuppress                    &
+              ,cap_suppress_loc=cap_suppress_loc                &
+#endif                                 
+                                                                )
+     CASE (CAMZMSCHEME)
+          IF (PRESENT(z_at_w) .AND. PRESENT(mavail)                 &
+                 .AND. PRESENT(pblh) .AND. PRESENT(psfc))THEN
+          CALL wrf_debug(100,'in camzm_cps')
+      IF(.not.f_qi)THEN
+         WRITE( wrf_err_message , * ) 'This cumulus option requires ice microphysics option: f_qi = ', f_qi
+         CALL wrf_error_fatal ( wrf_err_message )
+      ENDIF
+          CALL CAMZM_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     &
+               ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte     &
+               ,ITIMESTEP=itimestep, BL_PBL_PHYSICS=bl_pbl_physics  &
+               ,SF_SFCLAY_PHYSICS=sf_sfclay_physics                 &
+               ,TH=th, T_PHY=t, TSK=tsk, TKE_PBL=tke_pbl, UST=ust   &
+               ,QV=qv_curr, QC=qc_curr, QI=qi_curr, MAVAIL=mavail   &
+               ,KPBL=kpbl, PBLH=pblh, XLAND=xland                   & 
+               ,Z=z, Z_AT_W=z_at_w                                  &
+               ,DZ8W=dz8w, HT=ht                                    &
+               ,P=p, P8W=p8w, PI_PHY=pi, PSFC=psfc                  &
+               ,U_PHY=u, V_PHY=v, HFX=hfx, QFX=qfx, CLDFRA=cldfra   &
+               ,TPERT_CAMUWPBL=tpert2d                              &
+               ,DX=dx, DT=dt, STEPCU=stepcu, CUDT=cudt              &
+               ,CURR_SECS=curr_secs                                 &
+               ,ADAPT_STEP_FLAG=adapt_step_flag, CAPE_OUT=cape      &
+               ,MU_OUT=zmmu, MD_OUT=zmmd                            &
+               ,ZMDT=zmdt, ZMDQ=zmdq, DLF_OUT=dlf, RLIQ_OUT=rliq    &
+               ,PCONVT=pconvt, PCONVB=pconvb, CUBOT=hbot, CUTOP=htop&
+               ,RAINCV=raincv, PRATEC=tmppratec                     &
+               ,RUCUTEN=rucuten, RVCUTEN=rvcuten                    &
+               ,RTHCUTEN=rthcuten, RQVCUTEN=rqvcuten                &
+               ,RQCCUTEN=rqccuten, RQICUTEN=rqicuten                &
+               ,EVAPTZM=evaptzm, FZSNTZM=fzsntzm, EVSNTZM=evsntzm   &
+               ,EVAPQZM=evapqzm, ZMFLXPRC=zmflxprc                  &
+               ,ZMFLXSNW=zmflxsnw, ZMNTPRPD=zmntprpd                &
+               ,ZMNTSNPD=zmntsnpd, ZMEIHEAT=zmeiheat                &
+               ,CMFMC=cmfmc, CMFMCDZM=cmfmcdzm                      &
+               ,PRECCDZM=preccdzm, PRECZ=precz                      &
+               ,ZMMTU=zmmtu, ZMMTV=zmmtv, ZMUPGU=zmupgu             &
+               ,ZMUPGD=zmupgd, ZMVPGU=zmvpgu, ZMVPGD=zmvpgd         &
+               ,ZMICUU=zmicuu, ZMICUD=zmicud, ZMICVU=zmicvu         &
+               ,ZMICVD=zmicvd, ZMDICE=zmdice, ZMDLIQ=zmdliq         &
+                                                                    )
+          ELSE
+             WRITE( wrf_err_message , * ) 'Insufficient arguments to call CAMZM cu scheme'
+             CALL wrf_error_fatal ( wrf_err_message )
+          ENDIF
+
+! TIEDTKE SCHEME - ZCX&YQW (U of Hawaii)
+     CASE (TIEDTKESCHEME)
+
+        IF ( PRESENT ( QFX ) .AND. PRESENT( ZNU ) ) THEN
+
+          CALL wrf_debug(100,'in cu_tiedtke')
+          CALL CU_TIEDTKE(                                      &
+                DT=dt,ITIMESTEP=itimestep,STEPCU=STEPCU         &
+               ,RAINCV=RAINCV,PRATEC=tmppratec,QFX=qfx,ZNU=znu  &
+               ,U3D=u,V3D=v,W=w,T3D=t,PI3D=pi,RHO3D=rho         &
+               ,QV3D=QV_CURR,QC3D=QC_CURR,QI3D=QI_CURR          &
+               ,QVFTEN=RQVFTEN,QVPBLTEN=RQVBLTEN                &
+               ,DZ8W=dz8w,PCPS=p,P8W=p8w,XLAND=XLAND            &
+               ,CU_ACT_FLAG=CU_ACT_FLAG                         &
+               ,CUDT=cudt_pass                                  &
+               ,CURR_SECS=curr_secs_pass                        &
+               ,ADAPT_STEP_FLAG=adapt_step_flag_pass            &
+               ,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             &
+               ,RUCUTEN = RUCUTEN,RVCUTEN = RVCUTEN             &
+               ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr                   &
+               ,F_QI=f_qi,F_QS=f_qs                             &
+                                                             )
+        ELSE
+          CALL wrf_error_fatal('Lacking arguments for CU_TIEDTKE in cumulus driver')
+        ENDIF
+
+! New GFS SAS SCHEME - (Yonsei Univ., South Korea)
+     CASE (NSASSCHEME)
+        IF ( PRESENT ( QFX ) .AND. PRESENT( HFX ) ) THEN
+          CALL wrf_debug(100,'in nsas_cps')
+          CALL CU_NSAS(                                         &
+                DT=dt,P3DI=p8w,P3D=p,PI3D=pi,                   &
+                QC3D=QC_CURR,QI3D=QI_CURR,RHO3D=rho,            &
+                ITIMESTEP=itimestep,STEPCU=STEPCU,              &
+                HBOT=HBOT,HTOP=HTOP,                            &
+                CU_ACT_FLAG=CU_ACT_FLAG,CUDT=cudt_pass,         &
+                CURR_SECS=curr_secs_pass,                       &
+                ADAPT_STEP_FLAG=adapt_step_flag_pass,           &
+                RTHCUTEN=RTHCUTEN,RQVCUTEN=RQVCUTEN,            &
+                RQCCUTEN=RQCCUTEN,RQICUTEN=RQICUTEN,            &
+                RUCUTEN=RUCUTEN,RVCUTEN=RVCUTEN,                &
+                QV3D=QV_CURR,T3D=t,                             &
+                RAINCV=RAINCV,PRATEC=tmpPRATEC,                 &
+                XLAND=XLAND,DZ8W=dz8w,W=w,U3D=u,V3D=v,          &
+                HPBL=pblh,HFX=hfx,QFX=qfx,                      & 
+                MP_PHYSICS=mp_physics,                          & 
+                P_QC=p_qc,P_QI=p_qi,                            &
+                P_FIRST_SCALAR=param_first_scalar               &
+               ,CP=cp,CLIQ=cliq,CPV=cpv,G=g,XLV=xlv,R_D=r_d     &
+               ,R_V=r_v,EP_1=ep_1,EP_2=EP_2                     &
+               ,CICE=cice,XLS=xls,PSAT=psat                     &
+               ,F_QI=f_qi,F_QC=f_qc                             & 
+               ,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('Lacking arguments for CU_NSAS in cumulus driver')
+        ENDIF
+
+     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
+#if  ( EM_CORE == 1 )
+   IF(cu_physics .eq. 5 )then
+#ifdef DM_PARALLEL
+#     include "HALO_CUP_G3_OUT.inc"
+#endif
+      !$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)
+
+        call conv_grell_spread3d(rthcuten=rthcuten,rqvcuten=rqvcuten                &
+     &            ,rqccuten=rqccuten,raincv=raincv,cugd_avedx=cugd_avedx            &
+     &            ,cugd_tten=cugd_tten,cugd_qvten=cugd_qvten,rqicuten=rqicuten      &
+     &            ,cugd_ttens=cugd_ttens,cugd_qvtens=cugd_qvtens                    &
+     &            ,cugd_qcten=cugd_qcten,pi_phy=pi,moist_qv=qv_curr                 &
+     &            ,PRATEC=tmppratec,dt=dt,num_tiles=num_tiles                       &
+     &            ,imomentum=imomentum                             &
+     &            ,F_QV=F_QV,F_QC=F_QC,F_QR=F_QR,F_QI=F_QI,F_QS=F_QS                &
+     &            ,ids=IDS,ide=IDE, jds=JDS,jde=JDE, kds=KDS,kde=KDE                &
+     &            ,ips=IPS,ipe=IPE, jps=JPS,jpe=JPE, kps=KPS,kpe=KPE                &
+     &            ,ims=IMS,ime=IME, jms=JMS,jme=JME, kms=KMS,kme=KME                &
+     &            ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte)
+      ENDDO
+      !$OMP END PARALLEL DO
+   endif
+#endif
+
+      !
+      ! Copy pratec back to output array, if necessary.
+      !
+      if (PRESENT(PRATEC)) then
+         pratec(:,:) = tmppratec(:,:)
+      endif
+          CALL wrf_debug(200,'returning from cumulus_driver')
+   END SUBROUTINE cumulus_driver
+
+END MODULE module_cumulus_driver
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_data_gocart_dust.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_data_gocart_dust.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_data_gocart_dust.F	(revision 17)
@@ -0,0 +1,10 @@
+Module module_data_gocart_dust
+  INTEGER, PARAMETER :: ndust=5,ndcls=3,ndsrc=1,maxstypes=100
+  real, dimension (maxstypes) :: porosity
+  REAL :: ch_dust(ndust,12)
+  REAL,    PARAMETER :: dyn_visc = 1.5E-5
+  real*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./)
+  real*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/)
+  INTEGER, DIMENSION (5), PARAMETER :: ipoint(5)=(/3,2,2,2,2/)
+  REAL, DIMENSION (5), PARAMETER :: frac_s(5)=(/0.1,0.25,0.25,0.25,0.25/)
+END Module module_data_gocart_dust
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_diagnostics.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_diagnostics.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_diagnostics.F	(revision 17)
@@ -0,0 +1,518 @@
+!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                                     &
+                     ,p8w,pk1m,mu_2,mu_2m                             &
+                     ,u,v                                             &
+                     ,raincv,rainncv,rainc,rainnc                     &
+                     ,i_rainc,i_rainnc                                &
+                     ,hfx,sfcevp,lh                                   &
+                     ,ACSWUPT,ACSWUPTC,ACSWDNT,ACSWDNTC               & ! Optional
+                     ,ACSWUPB,ACSWUPBC,ACSWDNB,ACSWDNBC               & ! Optional
+                     ,ACLWUPT,ACLWUPTC,ACLWDNT,ACLWDNTC               & ! Optional
+                     ,ACLWUPB,ACLWUPBC,ACLWDNB,ACLWDNBC               & ! Optional
+                     ,I_ACSWUPT,I_ACSWUPTC,I_ACSWDNT,I_ACSWDNTC       & ! Optional
+                     ,I_ACSWUPB,I_ACSWUPBC,I_ACSWDNB,I_ACSWDNBC       & ! Optional
+                     ,I_ACLWUPT,I_ACLWUPTC,I_ACLWDNT,I_ACLWDNTC       & ! Optional
+                     ,I_ACLWUPB,I_ACLWUPBC,I_ACLWDNB,I_ACLWDNBC       & ! Optional
+                     ,dt,xtime,sbw,t2                                 &
+                     ,diag_print                                      &
+                     ,bucket_mm, bucket_J                             &
+                     ,prec_acc_c, prec_acc_nc, snow_acc_nc            &
+                     ,snowncv, prec_acc_dt, curr_secs                 &
+                                                                      )
+!----------------------------------------------------------------------
+
+  USE module_dm, ONLY: wrf_dm_sum_real, wrf_dm_maxval
+
+   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
+!
+!-- P8W           3D pressure array at full eta levels
+!-- 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)
+!-- SNOWNCV       explicit scheme snow 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.
+!-- PREC_ACC_C    accumulated convective precip over accumulation time prec_acc_dt
+!-- PREC_ACC_NC   accumulated explicit precip over accumulation time prec_acc_dt
+!-- SNOW_ACC_NC   accumulated explicit snow precip over accumulation time prec_acc_dt
+!-- PREC_ACC_DT   precip accumulation time, default is 60 min
+!-- CURR_SECS     model time in seconds
+!
+!-- 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,      INTENT(IN   )    ::   bucket_mm, bucket_J
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                 &
+         INTENT(IN ) ::                                       u  &
+                                                    ,         v  &
+                                                    ,       p8w
+
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) ::           &
+                                                           MU_2  &
+                                                    ,   RAINNCV  &
+                                                    ,    RAINCV  &
+                                                    ,   SNOWNCV  &
+                                                    ,       HFX  &
+                                                    ,        LH  &
+                                                    ,    SFCEVP  &  
+                                                    ,        T2     
+
+   REAL, DIMENSION( ims:ime , jms:jme ),                         &
+          INTENT(INOUT) ::                                DPSDT  &
+                                                    ,     DMUDT  &
+                                                    ,    RAINNC  &
+                                                    ,     RAINC  &
+                                                    ,     MU_2M  &
+                                                    ,      PK1M
+ 
+   REAL,  INTENT(IN   ) :: DT, XTIME
+   INTEGER,  INTENT(IN   ) :: SBW
+   INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) ::     &
+                                                       I_RAINC,  &
+                                                       I_RAINNC
+   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
+   INTEGER, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
+                      I_ACSWUPT,I_ACSWUPTC,I_ACSWDNT,I_ACSWDNTC,  &
+                      I_ACSWUPB,I_ACSWUPBC,I_ACSWDNB,I_ACSWDNBC,  &
+                      I_ACLWUPT,I_ACLWUPTC,I_ACLWDNT,I_ACLWDNTC,  &
+                      I_ACLWUPB,I_ACLWUPBC,I_ACLWDNB,I_ACLWDNBC
+
+   REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
+                      PREC_ACC_C, PREC_ACC_NC, SNOW_ACC_NC
+
+   REAL, OPTIONAL, INTENT(IN)::  PREC_ACC_DT, CURR_SECS
+
+   INTEGER :: i,j,k,its,ite,jts,jte,ij
+   INTEGER :: idp,jdp,irc,jrc,irnc,jrnc,isnh,jsnh
+   INTEGER :: prfreq
+
+   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
+   REAL              :: dmumax, raincmax, rainncmax, snowhmax
+   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
+   CHARACTER*256     :: outstring
+   CHARACTER*6       :: grid_str
+
+!-----------------------------------------------------------------
+! Handle accumulations with buckets to prevent round-off truncation in long runs
+! This is done every 360 minutes assuming time step fits exactly into 360 minutes
+   IF(bucket_mm .gt. 0. .AND. MOD(NINT(XTIME),360) .EQ. 0)THEN
+! SET START AND END POINTS FOR TILES
+!  !$OMP PARALLEL DO   &
+!  !$OMP PRIVATE ( ij )
+
+   DO ij = 1 , num_tiles
+
+      IF (xtime .eq. 0.0)THEN
+        DO j=j_start(ij),j_end(ij)
+        DO i=i_start(ij),i_end(ij)
+          i_rainnc(i,j) = 0
+          i_rainc(i,j) = 0
+        ENDDO      
+        ENDDO
+      ENDIF
+      DO j=j_start(ij),j_end(ij)
+      DO i=i_start(ij),i_end(ij)
+        IF(rainnc(i,j) .gt. bucket_mm)THEN
+          rainnc(i,j) = rainnc(i,j) - bucket_mm
+          i_rainnc(i,j) =  i_rainnc(i,j) + 1
+        ENDIF
+        IF(rainc(i,j) .gt. bucket_mm)THEN
+          rainc(i,j) = rainc(i,j) - bucket_mm
+          i_rainc(i,j) =  i_rainc(i,j) + 1
+        ENDIF
+      ENDDO      
+      ENDDO
+
+      IF (xtime .eq. 0.0 .and. bucket_J .gt. 0.0 .and. PRESENT(ACSWUPT))THEN
+        DO j=j_start(ij),j_end(ij)
+        DO i=i_start(ij),i_end(ij)
+          i_acswupt(i,j) = 0
+          i_acswuptc(i,j) = 0
+          i_acswdnt(i,j) = 0
+          i_acswdntc(i,j) = 0
+          i_acswupb(i,j) = 0
+          i_acswupbc(i,j) = 0
+          i_acswdnb(i,j) = 0
+          i_acswdnbc(i,j) = 0
+        ENDDO      
+        ENDDO
+      ENDIF
+      IF (xtime .eq. 0.0  .and. bucket_J .gt. 0.0 .and. PRESENT(ACLWUPT))THEN
+        DO j=j_start(ij),j_end(ij)
+        DO i=i_start(ij),i_end(ij)
+          i_aclwupt(i,j) = 0
+          i_aclwuptc(i,j) = 0
+          i_aclwdnt(i,j) = 0
+          i_aclwdntc(i,j) = 0
+          i_aclwupb(i,j) = 0
+          i_aclwupbc(i,j) = 0
+          i_aclwdnb(i,j) = 0
+          i_aclwdnbc(i,j) = 0
+        ENDDO      
+        ENDDO
+      ENDIF
+      IF (PRESENT(ACSWUPT) .and. bucket_J .gt. 0.0)THEN
+      DO j=j_start(ij),j_end(ij)
+      DO i=i_start(ij),i_end(ij)
+        IF(acswupt(i,j) .gt. bucket_J)THEN
+          acswupt(i,j) = acswupt(i,j) - bucket_J
+          i_acswupt(i,j) =  i_acswupt(i,j) + 1
+        ENDIF
+        IF(acswuptc(i,j) .gt. bucket_J)THEN
+          acswuptc(i,j) = acswuptc(i,j) - bucket_J
+          i_acswuptc(i,j) =  i_acswuptc(i,j) + 1
+        ENDIF
+        IF(acswdnt(i,j) .gt. bucket_J)THEN
+          acswdnt(i,j) = acswdnt(i,j) - bucket_J
+          i_acswdnt(i,j) =  i_acswdnt(i,j) + 1
+        ENDIF
+        IF(acswdntc(i,j) .gt. bucket_J)THEN
+          acswdntc(i,j) = acswdntc(i,j) - bucket_J
+          i_acswdntc(i,j) =  i_acswdntc(i,j) + 1
+        ENDIF
+        IF(acswupb(i,j) .gt. bucket_J)THEN
+          acswupb(i,j) = acswupb(i,j) - bucket_J
+          i_acswupb(i,j) =  i_acswupb(i,j) + 1
+        ENDIF
+        IF(acswupbc(i,j) .gt. bucket_J)THEN
+          acswupbc(i,j) = acswupbc(i,j) - bucket_J
+          i_acswupbc(i,j) =  i_acswupbc(i,j) + 1
+        ENDIF
+        IF(acswdnb(i,j) .gt. bucket_J)THEN
+          acswdnb(i,j) = acswdnb(i,j) - bucket_J
+          i_acswdnb(i,j) =  i_acswdnb(i,j) + 1
+        ENDIF
+        IF(acswdnbc(i,j) .gt. bucket_J)THEN
+          acswdnbc(i,j) = acswdnbc(i,j) - bucket_J
+          i_acswdnbc(i,j) =  i_acswdnbc(i,j) + 1
+        ENDIF
+      ENDDO      
+      ENDDO
+      ENDIF
+      IF (PRESENT(ACLWUPT) .and. bucket_J .gt. 0.0)THEN
+      DO j=j_start(ij),j_end(ij)
+      DO i=i_start(ij),i_end(ij)
+        IF(aclwupt(i,j) .gt. bucket_J)THEN
+          aclwupt(i,j) = aclwupt(i,j) - bucket_J
+          i_aclwupt(i,j) =  i_aclwupt(i,j) + 1
+        ENDIF
+        IF(aclwuptc(i,j) .gt. bucket_J)THEN
+          aclwuptc(i,j) = aclwuptc(i,j) - bucket_J
+          i_aclwuptc(i,j) =  i_aclwuptc(i,j) + 1
+        ENDIF
+        IF(aclwdnt(i,j) .gt. bucket_J)THEN
+          aclwdnt(i,j) = aclwdnt(i,j) - bucket_J
+          i_aclwdnt(i,j) =  i_aclwdnt(i,j) + 1
+        ENDIF
+        IF(aclwdntc(i,j) .gt. bucket_J)THEN
+          aclwdntc(i,j) = aclwdntc(i,j) - bucket_J
+          i_aclwdntc(i,j) =  i_aclwdntc(i,j) + 1
+        ENDIF
+        IF(aclwupb(i,j) .gt. bucket_J)THEN
+          aclwupb(i,j) = aclwupb(i,j) - bucket_J
+          i_aclwupb(i,j) =  i_aclwupb(i,j) + 1
+        ENDIF
+        IF(aclwupbc(i,j) .gt. bucket_J)THEN
+          aclwupbc(i,j) = aclwupbc(i,j) - bucket_J
+          i_aclwupbc(i,j) =  i_aclwupbc(i,j) + 1
+        ENDIF
+        IF(aclwdnb(i,j) .gt. bucket_J)THEN
+          aclwdnb(i,j) = aclwdnb(i,j) - bucket_J
+          i_aclwdnb(i,j) =  i_aclwdnb(i,j) + 1
+        ENDIF
+        IF(aclwdnbc(i,j) .gt. bucket_J)THEN
+          aclwdnbc(i,j) = aclwdnbc(i,j) - bucket_J
+          i_aclwdnbc(i,j) =  i_aclwdnbc(i,j) + 1
+        ENDIF
+      ENDDO      
+      ENDDO
+      ENDIF
+   ENDDO
+!  !$OMP END PARALLEL DO
+   ENDIF
+
+! Compute precipitation accumulation in a given time window: prec_acc_dt
+   IF (prec_acc_dt .gt. 0.) THEN
+
+!  !$OMP PARALLEL DO   &
+!  !$OMP PRIVATE ( ij )
+
+   DO ij = 1 , num_tiles
+
+      DO j=j_start(ij),j_end(ij)
+      DO i=i_start(ij),i_end(ij)
+         IF (mod(curr_secs, 60.* prec_acc_dt) == 0.) THEN
+            prec_acc_c(i,j)  = 0.
+            prec_acc_nc(i,j) = 0.
+            snow_acc_nc(i,j)  = 0.
+         ENDIF
+         prec_acc_c(i,j)  = prec_acc_c(i,j)  +  RAINCV(i,j)
+         prec_acc_nc(i,j) = prec_acc_nc(i,j) + RAINNCV(i,j)
+         prec_acc_c(i,j)  = MAX (prec_acc_c(i,j), 0.0)
+         prec_acc_nc(i,j) = MAX (prec_acc_nc(i,j), 0.0)
+         snow_acc_nc(i,j)   = snow_acc_nc(i,j) + SNOWNCV(I,J)
+! add convective precip to snow bucket if t2 < 273.15
+         IF ( t2(i,j) .lt. 273.15 ) THEN
+         snow_acc_nc(i,j)   = snow_acc_nc(i,j) +  RAINCV(i,j)
+         snow_acc_nc(i,j)   = MAX (snow_acc_nc(i,j), 0.0)
+         ENDIF
+      ENDDO     
+      ENDDO     
+
+   ENDDO     
+
+!  !$OMP END PARALLEL DO
+   ENDIF
+
+   if (diag_print .eq. 0 ) return
+
+   IF ( xtime .ne. 0. ) THEN
+
+    if(diag_print.eq.1) then
+       prfreq = dt
+!      prfreq = max(2,int(dt/60.))   ! in min
+    else
+       prfreq=10                   ! in min
+    endif
+   
+    IF (MOD(nint(dt),prfreq) == 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 )
+
+   dmumax = 0.
+   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)=(p8w(i,kms,j)-pk1m(i,j))/dt
+         dmudt(i,j)=(mu_2(i,j)-mu_2m(i,j))/dt
+         if(abs(dmudt(i,j)*dt).gt.dmumax)then
+           dmumax=abs(dmudt(i,j)*dt)
+           idp=i
+           jdp=j
+         endif
+      ENDDO      
+      ENDDO
+
+   ENDDO
+!  !$OMP END PARALLEL DO
+
+! convert DMUMAX from (PA) to (bars) per time step
+   dmumax = dmumax*1.e-5
+! compute global MAX
+   CALL wrf_dm_maxval ( dmumax,  idp, jdp )
+
+!  print *, 'p8w(30,1,30),pk1m(30,30) : ', p8w(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.
+   rainc_sum = 0.
+   raint_sum = 0.
+   rainnc_sum = 0.
+   sfcevp_sum = 0.
+   hfx_sum = 0.
+   lh_sum = 0.
+   raincmax = 0.
+   rainncmax = 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))
+! MAX for accumulated conv precip
+       IF(rainc(i,j).gt.raincmax)then
+          raincmax=rainc(i,j)
+          irc=i
+          jrc=j
+       ENDIF
+       rainnc_sum = rainnc_sum + abs(rainnc(i,j))
+! MAX for accumulated resolved precip
+       IF(rainnc(i,j).gt.rainncmax)then
+          rainncmax=rainnc(i,j)
+          irnc=i
+          jrnc=j
+       ENDIF
+       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 MAX
+   CALL wrf_dm_maxval ( raincmax, irc, jrc )
+   CALL wrf_dm_maxval ( rainncmax, irnc, jrnc )
+
+! 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 (mb/3h): ', xtime, &
+           dpsdt_sum/no_points*108., &
+           dmudt_sum/no_points*108.
+     CALL wrf_message ( TRIM(outstring) )
+
+     WRITE(outstring,*) grid_str,'Max mu change time step: ', idp,jdp,dmumax
+     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): ', xtime, &
+           raint_sum/no_points, &
+           rainc_sum/no_points, &
+           rainnc_sum/no_points
+     CALL wrf_message ( TRIM(outstring) )
+     WRITE(outstring,*) grid_str,'Max Accum Resolved Precip,   I,J  (mm): '               ,&
+           rainncmax,irnc,jrnc
+     CALL wrf_message ( TRIM(outstring) )
+     WRITE(outstring,*) grid_str,'Max Accum Convective Precip,   I,J  (mm): '             ,&
+           raincmax,irc,jrc
+     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        ! print frequency
+   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)=p8w(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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_fdda_psufddagd.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_fdda_psufddagd.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_fdda_psufddagd.F	(revision 17)
@@ -0,0 +1,1291 @@
+!wrf:model_layer:physics
+!
+!
+!
+MODULE module_fdda_psufddagd
+
+CONTAINS
+!
+!-------------------------------------------------------------------
+!
+   SUBROUTINE fddagd(itimestep,dx,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,  &
+
+               grid_sfdda, &
+               analysis_interval_sfc, end_fdda_hour_sfc, guv_sfc, gt_sfc, gq_sfc, &
+               rinblw, &
+
+               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,       &
+     u10_ndg_old, v10_ndg_old, t2_ndg_old, th2_ndg_old, q2_ndg_old, &
+     rh_ndg_old, psl_ndg_old, ps_ndg_old, tob_ndg_old, odis_ndg_old, &
+     u10_ndg_new, v10_ndg_new, t2_ndg_new, th2_ndg_new, q2_ndg_new, &
+     rh_ndg_new, psl_ndg_new, ps_ndg_new, tob_ndg_new, odis_ndg_new, &
+               RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN,&
+               pblh, ht, regime, znt, z, z_at_w,                             &
+               ids,ide, jds,jde, kds,kde,                           &
+               ims,ime, jms,jme, kms,kme,                           &
+               its,ite, jts,jte, kts,kte                        )
+
+!-------------------------------------------------------------------
+   implicit none
+!-------------------------------------------------------------------
+!
+!   This code was implemented by Aijun Deng (Penn State).  The 3-D analysis nudging was comleted 
+!   and released in December 2006.  The surface analysis nudging capability was added and 
+!   released in March 2009 with WRFV3.1.
+!
+!-- 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)   ::      analysis_interval_sfc, end_fdda_hour_sfc
+   INTEGER,  INTENT(IN)   ::      grid_sfdda
+
+   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, dx, 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(IN)      ::           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(IN)       ::                       u10_ndg_old,  &
+                                                         v10_ndg_old,  &
+                                                         t2_ndg_old,   &
+                                                         th2_ndg_old,  &
+                                                         q2_ndg_old,   &
+                                                         rh_ndg_old,   &
+                                                         psl_ndg_old,  &
+                                                         ps_ndg_old,   &
+                                                         u10_ndg_new,  &
+                                                         v10_ndg_new,  &
+                                                         t2_ndg_new,   &
+                                                         th2_ndg_new,  &
+                                                         q2_ndg_new,   &
+                                                         rh_ndg_new,   &
+                                                         psl_ndg_new,  &
+                                                         ps_ndg_new
+
+   REAL,       DIMENSION( ims:ime, jms:jme ),            &   
+               INTENT(IN)       ::                       tob_ndg_old,  &
+                                                         tob_ndg_new
+
+   REAL,     DIMENSION( ims:ime, jms:jme ), &
+             INTENT(INOUT) ::   mu_ndg_old, &
+                                mu_ndg_new
+
+   REAL,       DIMENSION( ims:ime, jms:jme ),            &   
+               INTENT(IN)       ::                       odis_ndg_old, odis_ndg_new
+
+   REAL,     DIMENSION( ims:ime, kms:kme, jms:jme ), &
+             INTENT(IN)   ::                    u3d, &
+                                                v3d
+
+   REAL,  DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: pblh, &
+                                                       ht, &
+                                                       regime, &
+                                                       znt
+
+   REAL, INTENT(IN)    :: guv, gt, gq
+   REAL, INTENT(IN)    :: guv_sfc, gt_sfc, gq_sfc, rinblw
+
+   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
+   INTEGER :: int4
+
+   int4 = 1  ! 1: temporal interpolation. else: target nudging toward *_ndg_new values
+
+   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( xtime > actual_end_fdda_min ) THEN
+!  If xtime is greater than the end time, no need to calculate tendencies. Just set the tnedencies 
+!  to zero to turn off nudging and return.
+     DO j = jts, jte
+     DO k = kts, kte
+     DO i = its, ite
+       RUNDGDTEN(i,k,j) = 0.0
+       RVNDGDTEN(i,k,j) = 0.0
+       RTHNDGDTEN(i,k,j) = 0.0
+       RQVNDGDTEN(i,k,j) = 0.0
+       IF( k .EQ. kts ) RMUNDGDTEN(i,j) = 0.
+     ENDDO
+     ENDDO
+     ENDDO
+     RETURN
+   ENDIF
+
+   IF( analysis_interval <= 0 )CALL wrf_error_fatal('In grid FDDA, gfdda_interval_m must be > 0')
+   xtime_old = FLOOR(xtime/analysis_interval) * analysis_interval * 1.0
+   xtime_new = xtime_old + analysis_interval
+   IF( int4 == 1 ) THEN
+     coef = (xtime-xtime_old)/(xtime_new-xtime_old)
+   ELSE
+     coef = 1.0          ! Nudging toward a target value (*_ndg_new values)
+   ENDIF
+
+   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,' 3-D analysis nudging reads new data at time = ', xtime, ' min.'
+         CALL wrf_message( TRIM(message) )
+         WRITE(message,'(a,i1,a,2f8.2,a)') &
+          'D0',id,' 3-D 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 3-D 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
+           WRITE(message,'(a,i1,a,3i4,a,f10.4,a,f10.4)') &
+             '    D0',id,' sample 3-D analysis values at i,k,j=', i0, k, j0, &
+             ' mu_ndg_old=', mu_ndg_old(i0,j0), ' mu_ndg_new=', mu_ndg_new(i0,j0)
+           CALL wrf_message( TRIM(message) )
+           DO k = kts, kte
+             WRITE(message,'(a,i1,a,3i4,a,f10.4,a,f10.4)') &
+               '    D0',id,' sample 3-D 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 3-D 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 3-D 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
+
+        IF( int4 == 1 ) then
+           WRITE(message,'(a,i1,a)') '    D0',id, &
+              ' 3-D nudging towards the temporally interpolated analysis'
+         ELSE
+           WRITE(message,'(a,i1,a)') '    D0',id, &
+              ' 3-D nudging towards the target analysis'
+         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 .OR. grid_sfdda == 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 .OR. grid_sfdda == 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 .OR. grid_sfdda == 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)/(analysis_interval*1.0)
+     ELSE                                                     
+       tfac = 0.0
+     ENDIF
+
+   ENDIF                                                  
+!
+! Surface Analysis Nudging
+!
+   IF( grid_sfdda == 1 ) THEN
+     CALL SFDDAGD(itimestep,dx,dt,xtime, id, &
+     analysis_interval_sfc, end_fdda_hour_sfc, guv_sfc, gt_sfc, gq_sfc, &
+     rinblw, &
+               u3d,v3d,th3d,t3d,                 &
+               qv3d,     &
+               p3d,pi3d,        &
+     u10_ndg_old, v10_ndg_old, t2_ndg_old, th2_ndg_old, q2_ndg_old, &
+     rh_ndg_old, psl_ndg_old, ps_ndg_old, tob_ndg_old, odis_ndg_old,  &
+     u10_ndg_new, v10_ndg_new, t2_ndg_new, th2_ndg_new, q2_ndg_new, &
+     rh_ndg_new, psl_ndg_new, ps_ndg_new, tob_ndg_new, odis_ndg_new,  &
+     RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN,&
+     pblh, ht, regime, znt, z, z_at_w,                             &
+     ids,ide, jds,jde, kds,kde,                           &
+     ims,ime, jms,jme, kms,kme,                           &
+     its,ite, jts,jte, kts,kte, wpbl, wzfac, if_ramping, dtramp_min, &
+     actual_end_fdda_min, tfac )
+   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) = 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) = 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) = 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) = 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 sfddagd(itimestep,dx,dt,xtime,  &
+               id, analysis_interval_sfc, end_fdda_hour_sfc, &
+               guv_sfc, gt_sfc, gq_sfc, rinblw,  &
+               u3d,v3d,th3d,t3d,                 &
+               qv3d,     &
+               p3d,pi3d,                &
+               u10_ndg_old, v10_ndg_old, t2_ndg_old, th2_ndg_old, q2_ndg_old, &
+               rh_ndg_old, psl_ndg_old, ps_ndg_old, tob_ndg_old, odis_ndg_old,  &
+               u10_ndg_new, v10_ndg_new, t2_ndg_new, th2_ndg_new, q2_ndg_new, &
+               rh_ndg_new, psl_ndg_new, ps_ndg_new, tob_ndg_new, odis_ndg_new,  &
+               RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN, &
+               pblh, ht, regime, znt, z, z_at_w,                             &
+               ids,ide, jds,jde, kds,kde,                           &
+               ims,ime, jms,jme, kms,kme,                           &
+               its,ite, jts,jte, kts,kte, wpbl, wzfac, if_ramping, dtramp_min, &
+               actual_end_fdda_min, tfac)
+
+!-------------------------------------------------------------------
+   USE module_model_constants
+ 
+   implicit none
+
+!-------------------------------------------------------------------
+!  
+!   This code was implemented by Aijun Deng (Penn State).  The 3-D analysis nudging was comleted
+!   and released in December 2006.  The surface analysis nudging capability was added and
+!   released in March 2009 with WRFV3.1.
+!
+!-- 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_sfc, end_fdda_hour_sfc
+
+   INTEGER , INTENT(IN)   ::      id
+   REAL,     INTENT(IN)   ::      dx,DT, xtime
+
+   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, jms:jme ),            &
+               INTENT(IN)       ::                       u10_ndg_old,  &
+                                                         v10_ndg_old,  &
+                                                         t2_ndg_old,   &
+                                                         th2_ndg_old,  &
+                                                         q2_ndg_old,   &
+                                                         rh_ndg_old,   &
+                                                         psl_ndg_old,  &
+                                                         ps_ndg_old,   &
+                                                         u10_ndg_new,  &
+                                                         v10_ndg_new,  &
+                                                         t2_ndg_new,   &
+                                                         th2_ndg_new,  &
+                                                         q2_ndg_new,   &
+                                                         rh_ndg_new,   &
+                                                         psl_ndg_new,  &
+                                                         ps_ndg_new
+
+   REAL,       DIMENSION( ims:ime, jms:jme ),            &
+               INTENT(IN)       ::                       tob_ndg_old,  &
+                                                         tob_ndg_new
+
+   REAL,     DIMENSION( ims:ime, kms:kme, jms:jme ), &
+             INTENT(IN)   ::                    u3d, &
+                                                v3d
+
+   REAL,       DIMENSION( ims:ime, jms:jme ),            &
+               INTENT(IN)         ::                    odis_ndg_old, odis_ndg_new
+
+   REAL,  DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: pblh, &
+                                                       ht,   &
+                                                       regime, &
+                                                       znt
+
+   REAL, INTENT(IN)    :: guv_sfc, gt_sfc, gq_sfc, rinblw
+
+   INTEGER             :: i, j, k, itsu, jtsv, itf, jtf, ktf, i0, j0
+   REAL                :: xtime_old_sfc, xtime_new_sfc, coef, val_analysis, es
+   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 ), &
+         INTENT(IN)                                   :: wpbl  ! 1: u, 2: v, 3: t, 4: q
+   REAL, DIMENSION( kts:kte, 4 ),  &
+         INTENT(IN)                                   :: wzfac ! 1: u, 2: v, 3: t, 4: q
+   REAL, DIMENSION( its:ite, jts:jte)                 :: wndcor_u, wndcor_v
+   REAL, DIMENSION( its-2:ite+1, jts-2:jte+1)         :: blw_old, blw_new
+   REAL, DIMENSION( its:ite, kts:kte, jts:jte)        :: qsat
+
+   REAL                                               :: m, b=1.8, blw, rindx, x
+
+   REAL :: difz, wr14, wr1z, wr24, wr2z, wndfac, reg, znt0
+   INTEGER,  INTENT(IN)   :: if_ramping
+   REAL, INTENT(IN)       :: dtramp_min
+
+   LOGICAL , EXTERNAL     :: wrf_dm_on_monitor
+
+   CHARACTER (LEN=256)    :: message
+   INTEGER :: iwinds, idd, iqsat, int4
+
+   iwinds = 1    ! 1: Scale the surface wind analysis to the lowest model level, 
+                 ! if the first model half-layer is greater than 10 meters 
+                 ! and we are in the free convection regime (REGIME=4.0). else: no
+   idd = 1       ! 1: Obs data density correction is applied. else: no
+   iqsat = 1     ! 1: Remove super saturation. eles: no
+   int4 = 1      ! 1: temporal ionterpolation. else: target nudging toward *_ndg_new values
+
+   IF( analysis_interval_sfc <= 0 )CALL wrf_error_fatal('In grid sfc FDDA, sgfdda_interval_m must be > 0')
+   xtime_old_sfc = FLOOR(xtime/analysis_interval_sfc) * analysis_interval_sfc * 1.0
+   xtime_new_sfc = xtime_old_sfc + analysis_interval_sfc
+   IF( int4 == 1 ) THEN
+     coef = (xtime-xtime_old_sfc)/(xtime_new_sfc-xtime_old_sfc)  ! Temporal interpolation
+   ELSE
+     coef = 1.0          ! Nudging toward a target value (*_ndg_new values)
+   ENDIF
+
+   IF ( wrf_dm_on_monitor()) THEN
+
+     CALL get_wrf_debug_level( dbg_level )
+
+     IF( xtime-xtime_old_sfc < 0.5*dt/60.0 ) THEN
+
+       IF( xtime < end_fdda_hour_sfc*60.0 ) THEN
+         WRITE(message,'(a,i1,a,f10.3,a)') &
+          'D0',id,' surface analysis nudging reads new data at time = ', xtime, ' min.'
+         CALL wrf_message( TRIM(message) )
+         WRITE(message,'(a,i1,a,2f8.2,a)') &
+          'D0',id,' surface analysis nudging bracketing times = ', xtime_old_sfc, xtime_new_sfc, ' min.'
+         CALL wrf_message( TRIM(message) )
+       ENDIF
+
+       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_sfc > 0.0 ) THEN
+           WRITE(message,'(a,i1,a,2i4,a,f10.4,a,f10.4)') &
+             '    D0',id,' sample surface analysis values at i,j=', i0, j0, &
+             ' u10_ndg_old=', u10_ndg_old(i0,j0), ' u10_ndg_new=', u10_ndg_new(i0,j0)
+           CALL wrf_message( TRIM(message) )
+           WRITE(message,'(a,i1,a,2i4,a,f10.4,a,f10.4)') &
+             '    D0',id,' sample surface analysis values at i,j=', i0, j0, &
+             ' v10_ndg_old=', v10_ndg_old(i0,j0), ' v10_ndg_new=', v10_ndg_new(i0,j0)
+           CALL wrf_message( TRIM(message) )
+         ENDIF
+
+         IF( gt_sfc > 0.0 ) THEN
+           WRITE(message,'(a,i1,a,2i4,a,f10.4,a,f10.4)') &
+             '    D0',id,' sample surface analysis values at i,j=', i0, j0, &
+             ' th2_ndg_old=', th2_ndg_old(i0,j0), ' th2_ndg_new=', th2_ndg_new(i0,j0)
+           CALL wrf_message( TRIM(message) )
+         ENDIF
+
+         IF( gq_sfc > 0.0 ) THEN
+           WRITE(message,'(a,i1,a,2i4,a,f10.4,a,f10.4)') &
+             '    D0',id,' sample surface analysis values at i,j=', i0, j0, &
+             ' q2_ndg_old=', q2_ndg_old(i0,j0), ' q2_ndg_new=', q2_ndg_new(i0,j0)
+           CALL wrf_message( TRIM(message) )
+         ENDIF
+
+         IF( iwinds ==  1 ) &
+           WRITE(message,'(a,i1,a)') '    D0',id, &
+              ' surface wind analysis s scaled to the lowest model level, if dz1 > 10m and REGIME=4.'
+
+         IF( idd ==  1 ) &
+           WRITE(message,'(a,i1,a)') '    D0',id, &
+              ' obs data density is used for additional weighting function'
+
+         IF( iqsat ==  1 ) &
+           WRITE(message,'(a,i1,a)') '    D0',id, &
+              ' super saturation is not allowed for q analysis'
+
+         IF( int4 ==  1 ) then
+           WRITE(message,'(a,i1,a)') '    D0',id, &
+              ' surface nudging towards the temporally interpolated analysis'
+         ELSE
+           WRITE(message,'(a,i1,a)') '    D0',id, &
+              ' surface nudging towards the target analysis'
+         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)
+
+!
+! Compute the vertical weighting function to scale the surface wind analysis to 
+! the lowest model level, if the first model half-layer is greater
+! than 10 meters and we are in the free convection regime (REGIME=4.0). 
+!
+   IF( iwinds == 1 ) THEN
+     wndcor_u(:,:) = 1.0
+     DO j=jts,jtf
+     DO i=itsu,itf
+       reg =  0.5 * ( regime(i-1,  j) + regime(i,  j) )
+       difz = 0.5 * ( z(i-1,1,j) - ht(i-1,j)  &
+                    + z(i,  1,j) - ht(i,  j)    ) 
+       IF( reg > 3.5 .AND. difz > 10.0 ) THEN
+         znt0 = 0.5 * (    znt(i-1,  j) +    znt(i,  j) )
+         IF( znt0 <= 0.2) THEN
+           wndcor_u(i,j) = 1.0+0.320*znt0**0.2
+         ELSE
+           wndcor_u(i,j) = 1.169+0.315*znt0
+         ENDIF
+
+         wr14 = log(40.0/0.05)
+         wr1z = log(difz/0.05)
+         wr24 = log(40.0/1.0)
+         wr2z = log(difz/1.0)
+         wndfac = 0.5*(WR1Z/WR14+WR2Z/WR24) 
+         wndcor_u(i,j) = wndfac*wndcor_u(i,j)
+       ENDIF
+     ENDDO
+     ENDDO
+
+     IF ( wrf_dm_on_monitor()) THEN
+       IF( xtime-xtime_old_sfc < 0.5*dt/60.0 ) THEN
+         IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min ) THEN
+           i0 = (ite-its)/2+its
+           j0 = (jte-jts)/2+jts
+           WRITE(message,'(a,i1,a,2i4,a,f10.4)') &
+             '    D0',id,' sample wndcor_u values at i,j=', i0, j0, &
+             ' wndcor_u=', wndcor_u(i0,j0)
+           CALL wrf_message( TRIM(message) )
+         ENDIF
+       ENDIF
+     ENDIF
+   ELSE 
+     wndcor_u(:,:) = 1.0
+   ENDIF
+
+   IF( iwinds == 1 ) THEN
+     wndcor_v(:,:) = 1.0
+     DO j=jtsv,jtf
+     DO i=its,itf
+       reg =  0.5 * ( regime(i,  j-1) + regime(i,  j) )
+       difz = 0.5 * ( z(i,1,j-1) - ht(i,j-1)  &
+                  +   z(i,1,j  ) - ht(i,j  )    )
+       IF( reg > 3.5 .AND. difz > 10.0 ) THEN 
+         znt0 = 0.5 * (    znt(i,  j-1) +    znt(i,  j) )
+         IF( znt0 <= 0.2) THEN
+           wndcor_v(i,j) = 1.0+0.320*znt0**0.2
+         ELSE
+           wndcor_v(i,j) = 1.169+0.315*znt0
+         ENDIF
+       
+         wr14 = log(40.0/0.05)
+         wr1z = log(difz/0.05)
+         wr24 = log(40.0/1.0)
+         wr2z = log(difz/1.0)
+         wndfac = 0.5*(WR1Z/WR14+WR2Z/WR24)
+           wndcor_v(i,j) = wndfac*wndcor_v(i,j)
+       ENDIF
+     ENDDO
+     ENDDO
+     IF ( wrf_dm_on_monitor()) THEN
+       IF( xtime-xtime_old_sfc < 0.5*dt/60.0 ) THEN
+         IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min ) THEN
+           i0 = (ite-its)/2+its
+           j0 = (jte-jts)/2+jts
+           WRITE(message,'(a,i1,a,2i4,a,f10.4)') &
+             '    D0',id,' sample wndcor_v values at i,j=', i0, j0, &
+             ' wndcor_v=', wndcor_v(i0,j0)
+           CALL wrf_message( TRIM(message) )
+         ENDIF
+       ENDIF
+     ENDIF
+   ELSE 
+     wndcor_v(:,:) = 1.0
+   ENDIF
+!
+! Compute saturation mixing ratio so that nudging to a super-saturated state
+! is not allowed.
+!
+   IF( iqsat == 1 ) THEN
+     DO j=jts,jtf
+     DO k=kts,ktf
+     DO i=its,itf
+       es = SVP1*EXP(SVP2*(t3d(i,k,j)-SVPT0)/(t3d(i,k,j)-SVP3))  * 10.0    ! mb
+       qsat(i,k,j) = EP_2*es/(p3d(i,k,j)/100.0-es)
+     ENDDO
+     ENDDO
+     ENDDO
+
+     IF ( wrf_dm_on_monitor()) THEN
+       IF( xtime-xtime_old_sfc < 0.5*dt/60.0 ) THEN
+         IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min ) THEN
+           i0 = (ite-its)/2+its
+           j0 = (jte-jts)/2+jts 
+           DO k = kts, kte
+             WRITE(message,'(a,i1,a,3i4,a,f10.4,a,f10.4)') &
+               '    D0',id,' sample moisture values (g/kg) at i,k,j=', i0, k, j0, &
+               ' qv3d=', qv3d(i0,k,j0)*1000.0, ' qsat=', qsat(i0,k,j0)*1000.0
+             CALL wrf_message( TRIM(message) )
+           ENDDO
+         ENDIF
+       ENDIF
+     ENDIF
+   ENDIF
+!
+! Obs data density weighting.
+!
+   IF( idd == 1 ) THEN
+
+     IF( rinblw < 0.001 ) THEN
+       IF ( wrf_dm_on_monitor()) THEN
+         WRITE(message,'(a)') 'Error in rinblw, please specify a reasonable value ***'
+         CALL wrf_message( TRIM(message) )
+       ENDIF
+       CALL wrf_error_fatal('In grid FDDA')
+     ENDIF
+
+     rindx = rinblw*1000.0/dx
+     m = -0.8*2.0/rindx
+
+     DO j=MAX(jts-2,jds),MIN(jtf+1,jde-1)
+     DO i=MAX(its-2,ids),MIN(itf+1,ide-1)
+       IF( odis_ndg_old(i,j) < 0.5*rinblw ) THEN
+         blw_old(i,j) = 1.0
+       ELSE
+         x = min( odis_ndg_old(i,j)*1000./dx, rindx )
+         blw_old(i,j) = m * x + b
+       ENDIF
+
+       IF( odis_ndg_new(i,j) < 0.5*rinblw ) THEN
+         blw_new(i,j) = 1.0
+       ELSE
+         x = min( odis_ndg_new(i,j)*1000./dx, rindx )
+         blw_new(i,j) = m * x + b
+       ENDIF
+     ENDDO
+     ENDDO
+
+! Smoother applies one point outside the tile, but one point in from boundaries
+     CALL smther(blw_old, its-2,itf+1, jts-2,jtf+1, 1, &
+                 MAX(its-2,ids+1), MIN(ite+1,ide-2), MAX(jts-2,jds+1), MIN(jte+1,jde-2))
+     CALL smther(blw_new, its-2,itf+1, jts-2,jtf+1, 1, &
+                 MAX(its-2,ids+1), MIN(ite+1,ide-2), MAX(jts-2,jds+1), MIN(jte+1,jde-2))
+
+     WHERE ( blw_old > 1.0)
+        blw_old = 1.0
+     END WHERE
+     WHERE ( blw_new > 1.0)
+        blw_new = 1.0
+     END WHERE
+     WHERE ( blw_old < 0.0)
+        blw_old = 0.0
+     END WHERE
+     WHERE ( blw_new < 0.0)
+        blw_new = 0.0
+     END WHERE
+
+     IF ( wrf_dm_on_monitor()) THEN
+       IF( xtime-xtime_old_sfc < 0.5*dt/60.0 ) THEN
+         IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min ) THEN
+           i0 = (ite-its)/2+its
+           j0 = (jte-jts)/2+jts
+           WRITE(message,'(a,i1,a,2i4,4(a,f10.4))') &
+             '    D0',id,' sample blw values at i,j=', i0, j0, &
+             ' odis_ndg_old=', odis_ndg_old(i0,j0), ' km odis_ndg_new=', odis_ndg_new(i0,j0), &
+             ' km  blw_old=', blw_old(i0,j0), ' blw_new=', blw_new(i0,j0)
+           CALL wrf_message( TRIM(message) )
+         ENDIF
+       ENDIF
+     ENDIF
+
+   ENDIF
+!
+! TFAC for surface analysis nudging
+!
+   IF( xtime >= actual_end_fdda_min-ABS(dtramp_min) .AND. xtime <= actual_end_fdda_min &
+       .AND. dtramp_min > 0.0 .AND. if_ramping == 1 )  &
+    coef = (xtime-xtime_old_sfc+analysis_interval_sfc)/(analysis_interval_sfc*1.0)
+!  print*, 'coef =', xtime_old_sfc, xtime, xtime_new_sfc, coef
+!              
+! Compute surface analysis nudging tendencies for u, v, t and q
+!              
+   DO j=jts,jtf
+   DO k=kts,ktf
+   DO i=itsu,itf
+     IF( idd == 1 ) THEN
+       blw = 0.5* (blw_old(i-1,j)+blw_old(i,j)) * ( 1.0 - coef ) &
+           + 0.5* (blw_new(i-1,j)+blw_new(i,j)) * coef
+     ELSE
+       blw = 1.0
+     ENDIF
+     val_analysis = u10_ndg_old(i,j) *( 1.0 - coef ) + u10_ndg_new(i,j) * coef
+     val_analysis = val_analysis * wndcor_u(i,j)
+     RUNDGDTEN(i,k,j) = guv_sfc * (1.0-wpbl(i,k,j,1)) * wzfac(k,1) * tfac * blw * &
+                         ( val_analysis - u3d(i,1,j) )
+   ENDDO
+   ENDDO
+   ENDDO
+
+   DO j=jtsv,jtf
+   DO k=kts,ktf 
+   DO i=its,itf
+     IF( idd == 1 ) THEN
+       blw = 0.5* (blw_old(i,j-1)+blw_old(i,j)) * ( 1.0 - coef ) &
+           + 0.5* (blw_new(i,j-1)+blw_new(i,j)) * coef
+     ELSE
+       blw = 1.0
+     ENDIF
+     val_analysis = v10_ndg_old(i,j) *( 1.0 - coef ) + v10_ndg_new(i,j) * coef
+     val_analysis = val_analysis * wndcor_v(i,j)
+     RVNDGDTEN(i,k,j) = guv_sfc * (1.0-wpbl(i,k,j,2)) * wzfac(k,2) * tfac * blw * &
+                       ( val_analysis - v3d(i,1,j) )
+   ENDDO
+   ENDDO
+   ENDDO
+
+   DO j=jts,jtf
+   DO k=kts,ktf
+   DO i=its,itf
+     IF( idd == 1 ) THEN
+       blw = blw_old(i,j) * ( 1.0 - coef ) + blw_new(i,j) * coef
+     ELSE
+       blw = 1.0
+     ENDIF
+     val_analysis = th2_ndg_old(i,j) *( 1.0 - coef ) + th2_ndg_new(i,j) * coef
+     RTHNDGDTEN(i,k,j) = gt_sfc * (1.0-wpbl(i,k,j,3)) * wzfac(k,3) * tfac * blw * &
+                          ( val_analysis - th3d(i,1,j))
+
+     val_analysis = q2_ndg_old(i,j) *( 1.0 - coef ) + q2_ndg_new(i,j) * coef
+     IF( iqsat ==  1 .AND. val_analysis > qsat(i,k,j) ) val_analysis = qsat(i,k,j)
+     RQVNDGDTEN(i,k,j) = gq_sfc * (1.0-wpbl(i,k,j,4)) * wzfac(k,4) * tfac * blw * &
+                          ( val_analysis - qv3d(i,k,j) )
+   ENDDO
+   ENDDO
+   ENDDO
+
+   END SUBROUTINE sfddagd
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+   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, &
+               grid_sfdda, guv_sfc, gt_sfc, gq_sfc,                &
+                      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, grid_sfdda
+   REAL,     INTENT(IN)   ::      dtramp_min
+   REAL, INTENT(IN)       ::      guv, gt, gq
+   REAL, INTENT(IN)       ::      guv_sfc, gt_sfc, gq_sfc
+   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,' 3-D analysis nudging for wind is applied 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,' 3-D analysis nudging for wind is not applied and Guv= ', guv
+       CALL wrf_message(TRIM(message))
+     ENDIF
+
+     IF( gt > 0.0 ) THEN
+       WRITE(message,'(a,i1,a,e12.4)') &
+           'D0',id,' 3-D analysis nudging for temperature is applied 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,' 3-D analysis nudging for temperature is not applied and Gt= ', gt
+       CALL wrf_message(TRIM(message))
+     ENDIF
+
+     IF( gq > 0.0 ) THEN
+       WRITE(message,'(a,i1,a,e12.4)') &
+         'D0',id,' 3-D analysis nudging for water vapor mixing ratio is applied 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,' 3-D analysis nudging for water vapor mixing ratio is not applied 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,' 3-D 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,' 3-D 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,' 3-D 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,' 3-D 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,' 3-D 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,' 3-D analysis nudging for water vapor mixing ratio is turned off below layer', &
+           k_zfac_q
+        CALL wrf_message(TRIM(message))
+     ENDIF
+
+     IF( grid_sfdda ==1 ) THEN
+       IF( guv_sfc > 0.0 ) THEN
+         WRITE(message,'(a,i1,a,e12.4)') &
+             'D0',id,' surface analysis nudging for wind is applied and Guv_sfc= ', guv_sfc
+         CALL wrf_message(TRIM(message))
+       ELSE IF( guv_sfc < 0.0 ) THEN
+         CALL wrf_error_fatal('In grid FDDA, Guv_sfc must be positive.')
+       ELSE
+         WRITE(message,'(a,i1,a,e12.4)') &
+             'D0',id,' surface analysis nudging for wind is not applied and Guv_sfc= ', guv_sfc
+         CALL wrf_message(TRIM(message))
+       ENDIF
+
+       IF( gt_sfc > 0.0 ) THEN
+         WRITE(message,'(a,i1,a,e12.4)') &
+             'D0',id,' surface analysis nudging for temperature is applied and Gt_sfc= ', gt_sfc
+         CALL wrf_message(TRIM(message))
+       ELSE IF( gt_sfc < 0.0 ) THEN
+         CALL wrf_error_fatal('In grid FDDA, Gt_sfc must be positive.')
+       ELSE
+         WRITE(message,'(a,i1,a,e12.4)') &
+             'D0',id,' surafce analysis nudging for temperature is not applied and Gt_sfc= ', gt_sfc
+         CALL wrf_message(TRIM(message))
+       ENDIF
+
+       IF( gq_sfc > 0.0 ) THEN
+         WRITE(message,'(a,i1,a,e12.4)') &
+           'D0',id,' surface analysis nudging for water vapor mixing ratio is applied and Gq_sfc= ', gq_sfc
+         CALL wrf_message(TRIM(message))
+       ELSE IF( gq_sfc < 0.0 ) THEN
+         CALL wrf_error_fatal('In grid FDDA, Gq_sfc must be positive.')
+       ELSE
+         WRITE(message,'(a,i1,a,e12.4)') &
+           'D0',id,' surface analysis nudging for water vapor mixing ratio is not applied and Gq_sfc= ', gq_sfc
+         CALL wrf_message(TRIM(message))
+       ENDIF
+
+     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
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  SUBROUTINE smther(slab, idimst, idimnd, jdimst, jdimnd, npass, ist, ind, jst, jnd)
+!
+!    PURPOSE: SPATIALLY SMOOTH DATA IN SLAB TO DAMPEN SHORT
+!             WAVELENGTH COMPONENTS.
+!
+!    Implemented based on the same smoothing subroutine used in MM5, with modifications to
+!    remove the extra loop that causes unneccessary desmoothing.  Aijun Deng (Penn State),
+!    December 2008 
+!
+    IMPLICIT NONE
+
+    INTEGER :: idimst, idimnd, jdimst, jdimnd, npass, ist, ind, jst, jnd
+    INTEGER :: i, j, k, kp
+    REAL    :: asv, aplus, cell
+    REAL, DIMENSION(idimst:idimnd, jdimst:jdimnd) :: SLAB
+    REAL, DIMENSION(2)                            :: XNU
+
+    IF(NPASS.EQ.0)RETURN
+    XNU(1)=0.50
+    XNU(2)=-0.52
+    DO K=1,NPASS
+!      FIRST, SMOOTH IN THE J DIRECTION
+        DO J=JST,JND
+          ASV=SLAB(IST-1,J)
+          DO I=IST,IND
+            APLUS=SLAB(I+1,J)
+            CELL=SLAB(I,J)
+            SLAB(I,J)=SLAB(I,J)+XNU(K)*((ASV+APLUS)/2.0-SLAB(I,J))
+            ASV=CELL
+          ENDDO
+        ENDDO
+
+!      NOW, SMOOTH IN THE I DIRECTION
+        DO I=IST,IND
+          ASV=SLAB(I,JST-1)
+          DO J=JST,JND
+            APLUS=SLAB(I,J+1)
+            CELL=SLAB(I,J)
+            SLAB(I,J)=SLAB(I,J)+XNU(K)*((ASV+APLUS)/2.0-SLAB(I,J))
+            ASV=CELL
+          ENDDO
+        ENDDO
+
+    ENDDO
+
+  END SUBROUTINE smther
+
+!-------------------------------------------------------------------
+END MODULE module_fdda_psufddagd
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_fdda_spnudging.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_fdda_spnudging.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_fdda_spnudging.F	(revision 17)
@@ -0,0 +1,1087 @@
+!wrf:model_layer:physics
+!
+! Code contributed by Gonzalo Miguez-Macho, Univ. de Santiago de Compostela, Galicia, Spain
+!
+MODULE module_fdda_spnudging
+
+#ifdef DM_PARALLEL
+  USE module_dm , ONLY : ntasks_x, ntasks_y, local_communicator_x, local_communicator_y, data_order_xzy
+#endif
+  USE module_wrf_error , ONLY : wrf_err_message
+
+CONTAINS
+!
+!-------------------------------------------------------------------
+!
+   SUBROUTINE spectral_nudging(grid,itimestep,dt,xtime,id,analysis_interval, end_fdda_hour, &
+               if_no_pbl_nudging_uv, if_no_pbl_nudging_t, if_no_pbl_nudging_ph,&
+               if_zfac_uv, k_zfac_uv, dk_zfac_uv, & 
+               if_zfac_t, k_zfac_t, dk_zfac_t, &
+               if_zfac_ph, k_zfac_ph, dk_zfac_ph, &
+               guv, gt, gph, if_ramping, dtramp_min, xwavenum, ywavenum, &
+               u3d,v3d,th3d,ph3d,                 &
+               u_ndg_old,v_ndg_old,t_ndg_old,ph_ndg_old,       &
+               u_ndg_new,v_ndg_new,t_ndg_new,ph_ndg_new,       &
+               RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RPHNDGDTEN,&
+               pblh, ht, z, z_at_w,                             &
+               ids,ide, jds,jde, kds,kde,                           &
+               ims,ime, jms,jme, kms,kme,                           &
+               i_start,i_end, j_start,j_end, kts,kte, num_tiles, &
+               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                   )
+
+
+
+   USE module_state_description
+   USE module_domain, ONLY : domain
+
+!-------------------------------------------------------------------
+   implicit none
+!-------------------------------------------------------------------
+!-- u3d         3d u-velocity staggered on u points
+!-- v3d         3d v-velocity staggered on v points
+!-- th3d        3d potential temperature (k)
+!---ph3d        3d perturbation geopotential
+!-- rundgdten   staggered u tendency due to
+!               spectral nudging (m/s/s)
+!-- rvndgdten   staggered v tendency due to
+!               spectral nudging (m/s/s)
+!-- rthndgdten  theta tendency due to
+!               spectral nudging (K/s)
+!-- phndgdten  ph tendency due to
+!               spectral nudging (m2/s2/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
+!-------------------------------------------------------------------
+!
+   TYPE(domain) , TARGET          :: grid
+
+   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_ph
+   INTEGER,  INTENT(IN)   ::      if_zfac_uv, if_zfac_t, if_zfac_ph
+   INTEGER,  INTENT(IN)   ::      k_zfac_uv,  k_zfac_t, k_zfac_ph
+   INTEGER,  INTENT(IN)   ::      dk_zfac_uv,  dk_zfac_t, dk_zfac_ph
+   INTEGER,  INTENT(IN)   ::      if_ramping
+   INTEGER,  INTENT(IN)   ::      xwavenum,ywavenum
+
+   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, &
+                                  kts,kte, num_tiles,        &
+                                  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 
+
+   INTEGER, DIMENSION(num_tiles), INTENT(IN) ::                   &
+  &                                    i_start,i_end,j_start,j_end
+ 
+   REAL,     DIMENSION( ims:ime, kms:kme, jms:jme ), &
+             INTENT(IN)   ::                  ph3d, &
+                                              th3d, &
+                                                 z, &
+                                            z_at_w
+
+   REAL,     DIMENSION( ims:ime, kms:kme, jms:jme ), &
+             INTENT(INOUT)   ::           rundgdten, &
+                                          rvndgdten, &
+                                         rthndgdten, &
+                                         rphndgdten
+
+
+   REAL,     DIMENSION( ims:ime, kms:kme, jms:jme ), &
+             INTENT(INOUT)   ::           u_ndg_old, &
+                                          v_ndg_old, &
+                                          t_ndg_old, &
+                                          ph_ndg_old, &
+                                          u_ndg_new, &
+                                          v_ndg_new, &
+                                          t_ndg_new, &
+                                          ph_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 ,gph
+
+   INTEGER             :: its,ite, jts,jte,ij
+   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( ips:ipe, kps:kpe, jps:jpe, 4 ) :: wpbl  ! 1: u, 2: v, 3: t, 4: ph
+   REAL, DIMENSION( kps:kpe, 4 )                   :: wzfac ! 1: u, 2: v, 3: t, 4: ph
+
+   LOGICAL , EXTERNAL  :: wrf_dm_on_monitor
+
+   CHARACTER (LEN=256) :: message
+
+#if  ! ( NMM_CORE == 1 )
+
+      DO ij = 1 , num_tiles
+          its=i_start(ij)
+          ite=i_end(ij)
+          jts=j_start(ij)
+          jte=j_end(ij)
+      ENDDO
+!GMM default values for vertical coefficients, set here
+   wpbl(:,:,:,:) = 1.0
+   wzfac(:,:) = 1.0
+
+ !$OMP PARALLEL DO   &
+ !$OMP PRIVATE ( ij, i,j,k ) ! only for part of the calculation.
+ DO ij = 1 , num_tiles
+     DO j = jts, jte
+     DO k = kts, kte
+     DO i = its, ite
+       RUNDGDTEN(i,k,j) = 0.0
+       RVNDGDTEN(i,k,j) = 0.0
+       RTHNDGDTEN(i,k,j) = 0.0
+       RPHNDGDTEN(i,k,j) = 0.0
+     ENDDO
+     ENDDO
+     ENDDO
+ ENDDO
+ !$OMP END PARALLEL DO
+
+ 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( xtime > actual_end_fdda_min ) RETURN
+
+ !$OMP PARALLEL DO   &
+ !$OMP PRIVATE ( ij, i,j,k ) ! only for part of the calculation. 
+ !GMM Transpose and filtering needs to be done on patch
+ 
+ DO ij = 1 , num_tiles
+
+!  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)
+
+   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,' Spectral nudging read in new data at time = ', xtime, ' min.'
+         CALL wrf_message( TRIM(message) )
+         WRITE(message,'(a,i1,a,2f8.2,a)') &
+          'D0',id,' Spectral 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( gph > 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, &
+               ' ph_ndg_old=', ph_ndg_old(i0,k,j0), ' ph_ndg_new=', ph_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_ph 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).
+!
+!GMM If those are set to zero, then check if the user-defined namelist switches (if_zfac_uv, if_zfac_t,
+! if_zfac_ph 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_ph) 
+! below which analysis nudging is turned off (wzfac = 1 above k_zfac_x and = 0 in below k_zfac_x).
+!  The strength of nudging increases linearly from k_zfac to kzfac + dk_zfac 
+! (dk_zfac_uv, dk_zfac_t and kd_zfac_ph are also set in the namelist, default value is 1).
+!If all switches are set to zero, wzfac = 1 (default value).
+!
+
+   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_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
+          wpbl(i, k, j, 1) = max ( min ( float(k-kpbl) / float(dk_zfac_uv) , 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_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
+          wpbl(i, k, j, 2) = max ( min ( float(k-kpbl) / float(dk_zfac_uv) , 1. ) , 0.)
+       ENDDO
+
+     ENDDO
+     ENDDO
+
+   ELSEIF( if_zfac_uv == 1 ) THEN
+
+     DO j=jts,jte
+     DO k=kts,ktf
+     DO i=its,ite
+          wpbl(i, k, j, 1) = max ( min ( float(k-k_zfac_uv) / float(dk_zfac_uv) , 1. ) , 0.)
+          wpbl(i, k, j, 2) = wpbl(i, k, j, 1)
+     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_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
+          wpbl(i, k, j, 3) = max ( min ( float(k-kpbl) / float(dk_zfac_t) , 1. ) , 0.)
+       ENDDO 
+        
+     ENDDO
+     ENDDO
+
+   ELSEIF( if_zfac_t == 1 ) THEN
+
+     DO j=jts,jtf
+     DO k=kts,ktf
+     DO i=its,itf
+          wpbl(i, k, j, 3) = max ( min ( float(k-k_zfac_t) / float(dk_zfac_t) , 1. ) , 0.)
+     ENDDO
+     ENDDO
+     ENDDO
+
+   ENDIF
+
+
+   IF( if_no_pbl_nudging_ph == 1 ) THEN
+   
+     DO j=jts,jtf
+     DO i=its,itf
+
+       kpbl = 1
+       zpbl = pblh(i,j)
+          
+       loop_kph: DO k=kts,kte
+         zagl = z_at_w(i,k,  j)-ht(i,j)
+         IF( zpbl >= zagl) THEN
+           kpbl = k
+           EXIT loop_kph
+         ENDIF
+       ENDDO loop_kph
+
+       DO k=kts,kte
+          wpbl(i, k, j, 4) = max ( min ( float(k-kpbl) / float(dk_zfac_ph) , 1. ) , 0.)
+       ENDDO 
+            
+     ENDDO  
+     ENDDO
+        
+   ELSEIF( if_zfac_ph == 1 ) THEN
+
+     DO j=jts,jtf
+     DO k=kts,kte
+     DO i=its,itf
+          wpbl(i, k, j, 4) = max ( min ( float(k-k_zfac_ph) / float(dk_zfac_ph) , 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                                                  
+
+   ENDDO
+   !$OMP END PARALLEL DO
+
+!
+! Compute 3-D nudging tendencies for u, v
+!
+!
+!GMM Fist calculate differences between model variables and analysis values,
+!then filter in the x and y direction all wave numbers higher than
+! xwavenum and ywavenum, as specified in the namelist.
+!If either xwavenum or ywavenum are not specified,
+! default values are zero, and spectral nudging is turned off
+!Then use the filtered differences to calculate the spectral nudging tendencies
+
+IF(guv > 0. ) then
+
+ !$OMP PARALLEL DO   &
+ !$OMP PRIVATE ( ij, i,j,k )
+ DO ij = 1 , num_tiles
+
+   DO j=jts,jte
+   DO k=kts,ktf
+   DO i=its,ite
+     val_analysis = u_ndg_old(i,k,j) *( 1.0 - coef ) + u_ndg_new(i,k,j) * coef
+     
+     grid%dif_analysis(i,k,j) = val_analysis - u3d(i,k,j)
+
+   ENDDO
+   ENDDO
+   ENDDO
+ 
+ ENDDO
+ !$OMP END PARALLEL DO
+
+!Filter
+
+#ifdef DM_PARALLEL
+# include "XPOSE_SPECTRAL_NUDGING_z2x.inc"
+
+     CALL spectral_nudging_filter_3dx( grid%dif_xxx, xwavenum,    &
+                                ids, ide, jds, jde, kds, kde,         &
+                                imsx, imex, jmsx, jmex, kmsx, kmex,     &
+                                ipsx, ipex, jpsx, jpex, kpsx, MIN(kde-1,kpex) ) 
+
+# include "XPOSE_SPECTRAL_NUDGING_x2y.inc"
+
+     CALL spectral_nudging_filter_3dy( grid%dif_yyy, ywavenum,    &
+                                ids, ide, jds, jde, kds, kde,         &
+                                imsy, imey, jmsy, jmey, kmsy, kmey,     &
+                                ipsy, ipey, jpsy, jpey, kpsy, MIN(kde-1,kpey) )
+
+# include "XPOSE_SPECTRAL_NUDGING_y2z.inc"
+
+
+#else
+     CALL spectral_nudging_filter_3dx( grid%dif_analysis, xwavenum,     &
+                                ids, ide, jds, jde, kds, kde,       &
+                                ims, ime, jms, jme, kms, kme,       &
+                                ips, ipe, jps, jpe, kps, MIN(kde-1,kpe) )
+
+     CALL spectral_nudging_filter_3dy( grid%dif_analysis, ywavenum,      &
+                                ids, ide, jds, jde, kds, kde,       &
+                                ims, ime, jms, jme, kms, kme,       &
+                                ips, ipe, jps, jpe, kps, MIN(kde-1,kpe) )
+#endif
+
+! Calculate tendency
+
+ !$OMP PARALLEL DO   &
+ !$OMP PRIVATE ( ij, i,j,k )
+ DO ij = 1 , num_tiles
+
+   DO j=jts,jte
+   DO k=kts,ktf
+   DO i=its,ite
+     RUNDGDTEN(i,k,j) = guv * wpbl(i,k,j,1) * wzfac(k,1) * tfac * &
+                        grid%dif_analysis(i,k,j)
+   ENDDO
+   ENDDO
+   ENDDO
+
+
+!
+! Now V component
+!
+
+   DO j=jts,jte
+   DO k=kts,ktf
+   DO i=its,ite
+     val_analysis = v_ndg_old(i,k,j) *( 1.0 - coef ) + v_ndg_new(i,k,j) * coef
+
+     grid%dif_analysis(i,k,j) = val_analysis - v3d(i,k,j)
+
+   ENDDO
+   ENDDO
+   ENDDO
+
+ ENDDO
+ !$OMP END PARALLEL DO
+
+!
+! Filter
+!
+#ifdef DM_PARALLEL
+# include "XPOSE_SPECTRAL_NUDGING_z2x.inc"
+     CALL spectral_nudging_filter_3dx( grid%dif_xxx, xwavenum,     &
+                                ids, ide, jds, jde, kds, kde,         &
+                                imsx, imex, jmsx, jmex, kmsx, kmex,     &
+                                ipsx, ipex, jpsx, jpex, kpsx, MIN(kde-1,kpex) )
+
+# include "XPOSE_SPECTRAL_NUDGING_x2y.inc"
+     CALL spectral_nudging_filter_3dy( grid%dif_yyy, ywavenum,   &
+                                ids, ide, jds, jde, kds, kde-1,         &
+                                imsy, imey, jmsy, jmey, kmsy, kmey,     &
+                                ipsy, ipey, jpsy, jpey, kpsy, MIN(kde-1,kpey) )
+
+# include "XPOSE_SPECTRAL_NUDGING_y2z.inc"
+
+
+#else
+     CALL spectral_nudging_filter_3dx( grid%dif_analysis, xwavenum,    &
+                                ids, ide, jds, jde, kds, kde,       &
+                                ims, ime, jms, jme, kms, kme,       &
+                                ips, ipe, jps, jpe, kps, MIN(kde-1,kpe) )
+
+     CALL spectral_nudging_filter_3dy( grid%dif_analysis, ywavenum,    &
+                                ids, ide, jds, jde, kds, kde,       &
+                                ims, ime, jms, jme, kms, kme,       &
+                                ips, ipe, jps, jpe, kps, MIN(kde-1,kpe) )
+#endif
+
+! Calculate tendency
+
+ !$OMP PARALLEL DO   &
+ !$OMP PRIVATE ( ij, i,j,k )
+ DO ij = 1 , num_tiles
+
+   DO j=jts,jte
+   DO k=kts,ktf
+   DO i=its,ite
+     RVNDGDTEN(i,k,j) = guv * wpbl(i,k,j,2) * wzfac(k,2) * tfac * &
+                        grid%dif_analysis(i,k,j)
+   ENDDO
+   ENDDO
+   ENDDO
+
+ ENDDO
+ !$OMP END PARALLEL DO
+
+ENDIF
+
+IF(gt > 0. ) then
+
+ !$OMP PARALLEL DO   &
+ !$OMP PRIVATE ( ij, i,j,k )
+ DO ij = 1 , num_tiles
+
+   DO j=jts,jte
+   DO k=kts,ktf
+   DO i=its,ite
+     val_analysis = t_ndg_old(i,k,j) *( 1.0 - coef ) + t_ndg_new(i,k,j) * coef
+
+     grid%dif_analysis(i,k,j) = val_analysis - th3d(i,k,j) + 300.
+
+   ENDDO
+   ENDDO
+   ENDDO
+
+ ENDDO
+ !$OMP END PARALLEL DO
+
+!Filter
+
+#ifdef DM_PARALLEL
+# include "XPOSE_SPECTRAL_NUDGING_z2x.inc"
+
+     CALL spectral_nudging_filter_3dx( grid%dif_xxx, xwavenum,    &
+                                ids, ide, jds, jde, kds, kde,         &
+                                imsx, imex, jmsx, jmex, kmsx, kmex,     &
+                                ipsx, ipex, jpsx, jpex, kpsx, MIN(kde-1,kpex) )
+
+# include "XPOSE_SPECTRAL_NUDGING_x2y.inc"
+
+     CALL spectral_nudging_filter_3dy( grid%dif_yyy, ywavenum,    &
+                                ids, ide, jds, jde, kds, kde,         &
+                                imsy, imey, jmsy, jmey, kmsy, kmey,     &
+                                ipsy, ipey, jpsy, jpey, kpsy, MIN(kde-1,kpey) )
+
+# include "XPOSE_SPECTRAL_NUDGING_y2z.inc"
+
+
+#else
+     CALL spectral_nudging_filter_3dx( grid%dif_analysis, xwavenum,     &
+                                ids, ide, jds, jde, kds, kde,       &
+                                ims, ime, jms, jme, kms, kme,       &
+                                ips, ipe, jps, jpe, kps, MIN(kde-1,kpe) )
+
+     CALL spectral_nudging_filter_3dy( grid%dif_analysis, ywavenum,      &
+                                ids, ide, jds, jde, kds, kde,       &
+                                ims, ime, jms, jme, kms, kme,       &
+                                ips, ipe, jps, jpe, kps, MIN(kde-1,kpe) )
+#endif
+
+! Calculate tendency
+
+ !$OMP PARALLEL DO   &
+ !$OMP PRIVATE ( ij, i,j,k )
+ DO ij = 1 , num_tiles
+
+   DO j=jts,jte
+   DO k=kts,ktf
+   DO i=its,ite
+     RTHNDGDTEN(i,k,j) = gt * wpbl(i,k,j,3) * wzfac(k,3) * tfac * &
+                        grid%dif_analysis(i,k,j)
+   ENDDO
+   ENDDO
+   ENDDO
+
+ ENDDO
+ !$OMP END PARALLEL DO
+
+ENDIF
+
+IF(gph > 0. ) then
+
+ !$OMP PARALLEL DO   &
+ !$OMP PRIVATE ( ij, i,j,k )
+ DO ij = 1 , num_tiles
+
+   DO j=jts,jte
+   DO k=kts,kte
+   DO i=its,ite
+     val_analysis = ph_ndg_old(i,k,j) *( 1.0 - coef ) + ph_ndg_new(i,k,j) * coef
+
+     grid%dif_analysis(i,k,j) = val_analysis - ph3d(i,k,j)
+
+   ENDDO
+   ENDDO
+   ENDDO
+
+ ENDDO
+ !$OMP END PARALLEL DO
+
+!Filter
+
+#ifdef DM_PARALLEL
+# include "XPOSE_SPECTRAL_NUDGING_z2x.inc"
+
+     CALL spectral_nudging_filter_3dx( grid%dif_xxx, xwavenum,    &
+                                ids, ide, jds, jde, kds, kde,         &
+                                imsx, imex, jmsx, jmex, kmsx, kmex,     &
+                                ipsx, ipex, jpsx, jpex, kpsx, kpex  )
+
+# include "XPOSE_SPECTRAL_NUDGING_x2y.inc"
+
+     CALL spectral_nudging_filter_3dy( grid%dif_yyy, ywavenum,    &
+                                ids, ide, jds, jde, kds, kde,         &
+                                imsy, imey, jmsy, jmey, kmsy, kmey,     &
+                                ipsy, ipey, jpsy, jpey, kpsy, kpey  )
+
+# include "XPOSE_SPECTRAL_NUDGING_y2z.inc"
+
+
+#else
+     CALL spectral_nudging_filter_3dx( grid%dif_analysis, xwavenum,     &
+                                ids, ide, jds, jde, kds, kde,       &
+                                ims, ime, jms, jme, kms, kme,       &
+                                ips, ipe, jps, jpe, kps, kpe )
+
+     CALL spectral_nudging_filter_3dy( grid%dif_analysis, ywavenum,      &
+                                ids, ide, jds, jde, kds, kde,       &
+                                ims, ime, jms, jme, kms, kme,       &
+                                ips, ipe, jps, jpe, kps, kpe  )
+#endif
+
+! Calculate tendency
+
+ !$OMP PARALLEL DO   &
+ !$OMP PRIVATE ( ij, i,j,k )
+ DO ij = 1 , num_tiles
+
+   DO j=jts,jte
+   DO k=kts,kte
+   DO i=its,ite
+     RPHNDGDTEN(i,k,j) = gph * wpbl(i,k,j,4) * wzfac(k,4) * tfac * &
+                        grid%dif_analysis(i,k,j)
+   ENDDO
+   ENDDO
+   ENDDO
+
+ ENDDO
+ !$OMP END PARALLEL DO
+
+ENDIF
+
+#endif
+
+   END SUBROUTINE spectral_nudging
+
+!------------------------------------------------------------------------------
+
+SUBROUTINE spectral_nudging_filter_3dx( f, nwave,            &
+                            ids, ide, jds, jde, kds, kde,    &
+                            ims, ime, jms, jme, kms, kme,    &
+                            its, ite, jts, jte, kts, kte )
+
+  IMPLICIT NONE
+
+  INTEGER ,       INTENT(IN   ) :: nwave
+  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) ::  f
+
+  REAL , DIMENSION(1:ide-ids+1,1:kte-kts+1) :: sheet
+  INTEGER ::  i, j, j_end, k, nx, ny
+
+  ! Variables will stay in domain form since this routine is meaningless
+  ! unless tile extent is the same as domain extent in E/W direction, i.e.,
+  ! the processor has access to all grid points in E/W direction.
+  ! There may be other ways of doing FFTs, but we haven't learned them yet...
+
+  ! Check to make sure we have full access to all E/W points
+  IF ((its /= ids) .OR. (ite /= ide)) THEN
+     WRITE ( wrf_err_message , * ) 'module_spectral_nudging: 3d: (its /= ids) or (ite /= ide)',its,ids,ite,ide
+     CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
+  END IF
+
+
+  nx = ide-ids+1 
+  ny = kte-kts+1 ! we can filter extra level for variables that are non-Z-staggered
+  j_end = MIN(jte, jde-1)
+  IF (j_end == jde-1) j_end = jde
+  DO j = jts, j_end
+
+        DO k=kts,kte
+        DO i=ids,ide-1
+           sheet(i-ids+1,k-kts+1) = f(i,k,j)
+        END DO
+           sheet(ide,k-kts+1) = 0.
+        END DO
+
+        CALL spectral_nudging_filter_fft_2d_ncar(nx,ny,nwave,sheet)
+
+        DO k=kts,kte
+           DO i=ids,ide
+              f(i,k,j) = sheet(i-ids+1,k-kts+1)
+           END DO
+        END DO
+  END DO ! outer j (latitude) loop
+
+END SUBROUTINE spectral_nudging_filter_3dx
+!------------------------------------------------------------------------------
+
+SUBROUTINE spectral_nudging_filter_3dy( f, nwave,   &
+                            ids, ide, jds, jde, kds, kde,    &
+                            ims, ime, jms, jme, kms, kme,    &
+                            its, ite, jts, jte, kts, kte )
+
+  IMPLICIT NONE
+
+  INTEGER ,       INTENT(IN   ) :: nwave
+  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) ::  f
+
+  REAL , DIMENSION(1:jde-jds+1,1:kte-kts+1) :: sheet
+  INTEGER ::  i, j, i_end, k, nx, ny
+
+  ! Variables will stay in domain form since this routine is meaningless
+  ! unless tile extent is the same as domain extent in S/N direction, i.e.,
+  ! the processor has access to all grid points in S/N direction.
+  ! There may be other ways of doing FFTs, but we haven't learned them yet...
+
+  ! Check to make sure we have full access to all S/N points
+  IF ((jts /= jds) .OR. (jte /= jde)) THEN
+     WRITE ( wrf_err_message , * ) 'module_spectral_nudging: 3d: (jts /= jds) or (jte /= jde)',jts,ids,ite,ide
+     CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
+  END IF
+
+
+  nx = jde-jds+1
+  ny = kte-kts+1 ! we can filter extra level for variables that are non-Z-staggered
+  i_end = MIN(ite, ide-1)
+  IF (i_end == ide-1) i_end = ide
+  DO i = its, i_end
+
+        DO k=kts,kte
+        DO j=jds,jde
+           sheet(j-jds+1,k-kts+1) = f(i,k,j)
+        END DO
+           sheet(jde,k-kts+1) = 0.
+        END DO
+
+        CALL spectral_nudging_filter_fft_2d_ncar(nx,ny,nwave,sheet)
+
+        DO k=kts,kte
+           DO j=jds,jde
+              f(i,k,j) = sheet(j-jds+1,k-kts+1)
+           END DO
+        END DO
+  END DO ! outer i (longitude) loop
+
+END SUBROUTINE spectral_nudging_filter_3dy
+
+!------------------------------------------------------------------------------
+
+SUBROUTINE spectral_nudging_filter_fft_2d_ncar(nx,ny,nwave,fin)
+  IMPLICIT NONE
+  INTEGER , INTENT(IN) :: nx, ny, nwave
+  REAL , DIMENSION(nx,ny), INTENT(INOUT) :: fin
+
+  INTEGER :: i, j
+  REAL, dimension(nx,ny) :: fp
+
+  INTEGER :: lensave, ier, nh, n1
+  INTEGER :: lot, jump, n, inc, lenr, lensav, lenwrk
+  REAL, DIMENSION(nx+15) :: wsave
+  REAL, DIMENSION(nx,ny) :: work
+
+
+
+!  we are following the naming convention of the fftpack5 routines
+
+  n = nx
+  lot = ny
+  lensav = n+15
+  inc = 1
+  lenr = nx*ny
+  jump = nx
+  lenwrk = lenr
+
+!  forward transform
+!  initialize coefficients, place in wsave
+!   (should place this in init and save wsave at program start)
+
+  call rfftmi(n,wsave,lensav,ier)
+  IF(ier /= 0) THEN
+    write(0,*) ' error in rfftmi ',ier
+  END IF
+
+!  do the forward transform
+
+  call rfftmf( lot, jump, n, inc, fin, lenr, wsave, lensav, work, lenwrk, ier )
+  IF(ier /= 0) THEN
+    write(0,*) ' error in rfftmf ',ier
+  END IF
+
+  if(MOD(n,2) == 0) then
+    nh = n/2 - 1
+  else
+    nh = (n-1)/2
+  end if
+
+
+! filter all waves with wavenumber larger than nwave
+
+  fp = 1.
+
+  DO j=1,ny
+     DO i=nwave+1,nh
+         fp(2*i-1,j) = 0.
+         fp(2*i,j) = 0.
+     ENDDO
+  ENDDO
+
+  DO j=1,ny
+    DO i=1,nx
+      fin(i,j) = fp(i,j)*fin(i,j)
+    ENDDO
+  ENDDO
+
+!  do the backward transform
+
+  call rfftmb( lot, jump, n, inc, fin, lenr, wsave, lensav, work, lenwrk, ier )
+  IF(ier /= 0) THEN
+    write(0,*) ' error in rfftmb ',ier
+  END IF
+
+END SUBROUTINE spectral_nudging_filter_fft_2d_ncar
+
+!-------------------------------------------------------------------
+
+   SUBROUTINE fddaspnudginginit(id,rundgdten,rvndgdten,rthndgdten,rphndgdten, &
+               run_hours,  &
+               if_no_pbl_nudging_uv, if_no_pbl_nudging_t, if_no_pbl_nudging_ph, &
+               if_zfac_uv, k_zfac_uv, dk_zfac_uv, &
+               if_zfac_t, k_zfac_t, dk_zfac_t, &
+               if_zfac_ph, k_zfac_ph, dk_zfac_ph, &               
+               guv, gt, gph, if_ramping, dtramp_min, end_fdda_hour, &
+               xwavenum,ywavenum,                          &
+                      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, &
+                                                      rphndgdten
+   INTEGER,  INTENT(IN)   ::      run_hours
+   INTEGER,  INTENT(IN)   ::      if_no_pbl_nudging_uv, if_no_pbl_nudging_t, &
+                                  if_no_pbl_nudging_ph, end_fdda_hour
+   INTEGER,  INTENT(IN)   ::      if_zfac_uv, if_zfac_t, if_zfac_ph
+   INTEGER,  INTENT(IN)   ::      k_zfac_uv,  k_zfac_t,  k_zfac_ph
+   INTEGER,  INTENT(IN)   ::      dk_zfac_uv,  dk_zfac_t,  dk_zfac_ph
+   INTEGER,  INTENT(IN)   ::      if_ramping
+   INTEGER,  INTENT(IN)   ::      xwavenum,ywavenum
+   REAL,     INTENT(IN)   ::      dtramp_min
+   REAL, INTENT(IN)       ::      guv, gt, gph
+   REAL                   ::      actual_end_fdda_min
+
+   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,a,i4,a,i4)') &
+           'D0',id,' Spectral nudging for wind is turned on and Guv= ', guv,' xwave= ',xwavenum,' ywavenum= ',ywavenum
+       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,' Spectral 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,a,i4,a,i4)') &
+           'D0',id,' Spectral nudging for temperature is turned on and Gt= ', gt,' xwave= ',xwavenum,' ywavenum= ',ywavenum
+       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,' Spectral nudging for temperature is turned off and Gt= ', gt
+       CALL wrf_message(TRIM(message))
+     ENDIF
+
+     IF( gph > 0.0) THEN
+       WRITE(message,'(a,i1,a,e12.4,a,i4,a,i4)') &
+         'D0',id,' Spectral nudging for geopotential is turned on and Gph= ', gph,' xwave= ',xwavenum,' ywavenum= ',ywavenum
+       CALL wrf_message(TRIM(message))
+     ELSE IF( gph < 0.0 ) THEN
+       CALL wrf_error_fatal('In grid FDDA, Gph must be positive.')
+     ELSE
+       WRITE(message,'(a,i1,a,e12.4)') &
+         'D0',id,' Spectral nudging for geopotential is turned off and Gph= ', gph
+       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,' Spectral nudging for wind is turned off within the PBL.'
+        CALL wrf_message(TRIM(message))
+             IF( dk_zfac_uv < 1 ) CALL wrf_error_fatal('In spectral nudging, dk_zfac_uv must be greater or equal than 1.')
+     ELSEIF( guv > 0.0 .AND. if_zfac_uv == 1 ) THEN
+        WRITE(message,'(a,i1,a,i3)') &
+           'D0',id,' Spectral nudging for wind is turned off below layer', k_zfac_uv
+        CALL wrf_message(TRIM(message))
+             IF( dk_zfac_uv < 1 ) CALL wrf_error_fatal('In spectral nudging, dk_zfac_uv must  be greater or equal than 1.')       
+     ENDIF
+
+
+     IF( gt > 0.0 .AND. if_no_pbl_nudging_t == 1 ) THEN
+        WRITE(message,'(a,i1,a)') &
+           'D0',id,' Spectral nudging for temperature is turned off within the PBL.'
+        CALL wrf_message(TRIM(message))
+             IF( dk_zfac_t < 1 ) CALL wrf_error_fatal('In spectral nudging, dk_zfac_t must be greater or equal than 1.')
+     ELSEIF( gt > 0.0 .AND. if_zfac_t == 1 ) THEN
+        WRITE(message,'(a,i1,a,i3)') &
+           'D0',id,' Spectral nudging for temperature is turned off below layer', k_zfac_t
+        CALL wrf_message(TRIM(message))
+            IF( dk_zfac_t < 1 ) CALL wrf_error_fatal('In spectral nudging, dk_zfac_t must be greater or equal than 1.')
+     ENDIF
+
+
+     IF( gph > 0.0 .AND. if_no_pbl_nudging_ph == 1 ) THEN
+        WRITE(message,'(a,i1,a)') &
+         'D0',id,' Spectral nudging for geopotential is turned off within the PBL.'
+        CALL wrf_message(TRIM(message))
+            IF( dk_zfac_ph < 1 ) CALL wrf_error_fatal('In spectral nudging, dk_zfac_ph must be greater or equal than 1.')
+     ELSEIF( gph > 0.0 .AND. if_zfac_ph == 1 ) THEN
+        WRITE(message,'(a,i1,a,i3)') &
+          'D0',id,' Spectral nudging for geopotential is turned off below layer', &
+           k_zfac_ph
+        CALL wrf_message(TRIM(message))
+            IF( dk_zfac_ph < 1 ) CALL wrf_error_fatal('In spectral nudging, dk_zfac_ph must be greater or equal than 1.')
+     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,' Spectral 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.
+        rphndgdten(i,k,j) = 0.
+     ENDDO
+     ENDDO
+     ENDDO
+   ENDIF
+
+   END SUBROUTINE fddaspnudginginit
+!-------------------------------------------------------------------
+
+END MODULE module_fdda_spnudging
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_fddagd_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_fddagd_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_fddagd_driver.F	(revision 17)
@@ -0,0 +1,451 @@
+!WRF:MEDIATION_LAYER:PHYSICS
+!
+
+MODULE module_fddagd_driver
+CONTAINS
+
+!------------------------------------------------------------------
+   SUBROUTINE fddagd_driver(itimestep,dt,xtime,                   &
+                  id,  &
+                  RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,                 &
+                  RPHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN,               &
+                  u_ndg_old,v_ndg_old,t_ndg_old,ph_ndg_old,       &
+                  q_ndg_old,mu_ndg_old,       &
+                  u_ndg_new,v_ndg_new,t_ndg_new,ph_ndg_new,       &
+                  q_ndg_new,mu_ndg_new,       &
+                  u3d,v3d,th_phy,ph,rho,moist,                    &
+                  p_phy,pi_phy,p8w,t_phy,dz8w,z,z_at_w,           &
+                  grid,config_flags,DX,n_moist,                   &
+                  STEPFG,                                         &
+                  pblh,ht,regime,znt,                             &
+                  ids,ide, jds,jde, kds,kde,                      &
+                  ims,ime, jms,jme, kms,kme,                      &
+                  i_start,i_end, j_start,j_end, kts,kte, num_tiles, &
+                  u10, v10, th2, q2, &
+                  u10_ndg_old, v10_ndg_old, t2_ndg_old, th2_ndg_old, q2_ndg_old,  &
+                  rh_ndg_old, psl_ndg_old, ps_ndg_old, tob_ndg_old, odis_ndg_old, &
+                  u10_ndg_new, v10_ndg_new, t2_ndg_new, th2_ndg_new, q2_ndg_new,  &
+                  rh_ndg_new, psl_ndg_new, ps_ndg_new, tob_ndg_new, odis_ndg_new, &
+                  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                     )
+!------------------------------------------------------------------
+   USE module_configure
+   USE module_state_description
+   USE module_model_constants
+   USE module_domain, ONLY : domain
+
+! *** add new modules of schemes here
+
+   USE module_fdda_psufddagd
+   USE module_fdda_spnudging
+
+!------------------------------------------------------------------
+   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)
+!-- RPHNDGDTEN      Geopotential tendency due to
+!                 FDDA analysis nudging (m^2/s^3)
+!-- 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
+   TYPE(domain) , TARGET          :: grid
+!
+
+   INTEGER , INTENT(IN)         ::     id
+
+   INTEGER,    INTENT(IN   )    ::     ids,ide, jds,jde, kds,kde, &
+                                       ims,ime, jms,jme, kms,kme, &
+                                       kts,kte, num_tiles,        &
+                                       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,   &
+                                       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, &
+                                                              ph, &
+                                                            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, &
+                                                        RPHNDGDTEN, &
+                                                        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, &
+                                                         ph_ndg_old,&
+                                                         q_ndg_old, &
+                                                         u_ndg_new, &
+                                                         v_ndg_new, &
+                                                         t_ndg_new, &
+                                                         ph_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, &
+                                           znt
+
+   REAL,    DIMENSION( ims:ime , jms:jme ), INTENT(INOUT   ) :: regime
+
+   REAL,       DIMENSION( ims:ime, jms:jme ),            &
+               INTENT(IN   )    ::                       u10, &
+                                                         v10, &
+                                                         th2, &
+                                                         q2
+
+   REAL,       DIMENSION( ims:ime, jms:jme ),            &
+               INTENT(IN)       ::                       u10_ndg_old,  &
+                                                         v10_ndg_old,  &
+                                                         t2_ndg_old,   &
+                                                         th2_ndg_old,  &
+                                                         q2_ndg_old,   &
+                                                         rh_ndg_old,   &
+                                                         psl_ndg_old,  &
+                                                         ps_ndg_old,   &
+                                                         odis_ndg_old,  &
+                                                         u10_ndg_new,  &
+                                                         v10_ndg_new,  &
+                                                         t2_ndg_new,   &
+                                                         th2_ndg_new,  &
+                                                         q2_ndg_new,   &
+                                                         rh_ndg_new,   &
+                                                         psl_ndg_new,  &
+                                                         ps_ndg_new,   &
+                                                         odis_ndg_new
+
+   REAL,       DIMENSION( ims:ime, jms:jme ),            &
+               INTENT(IN)       ::                       tob_ndg_old,  &
+                                                         tob_ndg_new
+
+!  LOCAL  VAR
+
+!
+   INTEGER :: i,J,K,NK,jj,ij
+   CHARACTER (LEN=256) :: message
+
+!------------------------------------------------------------------
+!
+#if  ! ( NMM_CORE == 1 )
+  if (config_flags%grid_fdda .eq. 0 .AND. config_flags%grid_sfdda .eq. 0) return
+
+  IF (itimestep == 1) THEN
+
+   IF( config_flags%grid_fdda .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)
+
+         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
+            ph_ndg_old(i,k,j) = ph(i,k,j)
+            q_ndg_old(i,k,j) = moist(i,k,j,P_QV)
+         ENDDO
+         mu_ndg_old(i,j) = 0.0
+
+      ENDDO
+      ENDDO
+
+   ENDDO
+
+!  IF( config_flags%grid_sfdda .eq. 1 ) THEN
+!    DO ij = 1 , num_tiles
+!       DO j=j_start(ij),j_end(ij)
+!       DO i=i_start(ij),i_end(ij)
+!             u10_ndg_old(i,j) = u10(i,j)
+!             v10_ndg_old(i,j) = v10(i,j)
+!             th2_ndg_old(i,j) = th2(i,j) - 300.0
+!              q2_ndg_old(i,j) = q2(i,j)
+!       ENDDO
+!       ENDDO
+
+!    ENDDO
+!  ENDIF
+   !$OMP END PARALLEL DO
+
+   ENDIF
+  ENDIF
+
+!GMM if fgdtzero = 1, tendencies are zero in between calls
+
+  IF (mod(itimestep-1,STEPFG) .eq. 0 .and. config_flags%fgdtzero .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)
+
+         DO k=kts,min(kte+1,kde)
+            RTHNDGDTEN(I,K,J)=0.
+            RUNDGDTEN(I,K,J)=0.
+            RVNDGDTEN(I,K,J)=0.
+            RPHNDGDTEN(I,K,J)=0.
+            RQVNDGDTEN(I,K,J)=0.
+         ENDDO
+
+         RMUNDGDTEN(I,J)=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.
+            RPHNDGDTEN(I,K,J)=0.
+            RQVNDGDTEN(I,K,J)=0.
+         ENDDO
+
+         RMUNDGDTEN(I,J)=0.
+
+      ENDDO
+      ENDDO
+
+   ENDDO
+   !$OMP END PARALLEL DO
+
+!
+   IF( config_flags%grid_fdda /= 0 ) THEN
+   fdda_select: SELECT CASE(config_flags%grid_fdda)
+
+      CASE (PSUFDDAGD)
+
+      !$OMP PARALLEL DO   &
+      !$OMP PRIVATE ( ij, i,j,k )
+       DO ij = 1 , num_tiles
+        CALL wrf_debug(100,'in PSU FDDA scheme')
+
+           IF( config_flags%bl_pbl_physics /= 1 &
+         .AND. config_flags%bl_pbl_physics /= 5 &
+         .AND. config_flags%bl_pbl_physics /= 6 &
+         .AND. config_flags%bl_pbl_physics /= 7 &
+         .AND. config_flags%bl_pbl_physics /= 99 ) THEN
+             DO j=MAX(j_start(ij)-1,jds),j_end(ij)
+             DO i=MAX(i_start(ij)-1,ids),i_end(ij)
+               IF( pblh(i,j) > z_at_w(i,2,j)-ht(i,j) ) THEN
+                 regime(i,j) = 4.0
+               ELSE
+                 regime(i,j) = 1.0
+               ENDIF
+             ENDDO
+             ENDDO
+           ENDIF
+
+           CALL FDDAGD(itimestep,dx,dt,xtime, &
+               id, &
+               config_flags%auxinput10_interval_m, &
+               config_flags%auxinput10_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, &
+     config_flags%grid_sfdda, &
+     config_flags%auxinput9_interval_m, &
+     config_flags%auxinput9_end_h, &
+     config_flags%guv_sfc, &
+     config_flags%gt_sfc, config_flags%gq_sfc, config_flags%rinblw, &
+               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,       &
+     u10_ndg_old, v10_ndg_old, t2_ndg_old, th2_ndg_old, q2_ndg_old, &
+     rh_ndg_old, psl_ndg_old, ps_ndg_old, tob_ndg_old, odis_ndg_old,  &
+     u10_ndg_new, v10_ndg_new, t2_ndg_new, th2_ndg_new, q2_ndg_new, &
+     rh_ndg_new, psl_ndg_new, ps_ndg_new, tob_ndg_new, odis_ndg_new,  &
+               RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN,&
+               pblh, ht, regime, znt, 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  )
+
+      ENDDO
+     !$OMP END PARALLEL DO
+
+      CASE (SPNUDGING)
+        CALL wrf_debug(100,'in SPECTRAL NUDGING scheme')
+           CALL SPECTRAL_NUDGING(grid,itimestep,dt,xtime, &
+               id, &
+               config_flags%auxinput10_interval_m, &
+               config_flags%auxinput10_end_h, &
+               config_flags%if_no_pbl_nudging_uv, &
+               config_flags%if_no_pbl_nudging_t, &
+               config_flags%if_no_pbl_nudging_ph, &
+               config_flags%if_zfac_uv, &
+               config_flags%k_zfac_uv, &
+               config_flags%dk_zfac_uv,  &
+               config_flags%if_zfac_t, &
+               config_flags%k_zfac_t, &
+               config_flags%dk_zfac_t, &
+               config_flags%if_zfac_ph, &
+               config_flags%k_zfac_ph, &
+               config_flags%dk_zfac_ph,  &
+               config_flags%guv, &
+               config_flags%gt,  &
+               config_flags%gph,  &
+               config_flags%if_ramping, config_flags%dtramp_min, &
+               config_flags%xwavenum, config_flags%ywavenum, &
+               u3d,v3d,th_phy,ph,                 &
+               u_ndg_old,v_ndg_old,t_ndg_old,ph_ndg_old,       &
+               u_ndg_new,v_ndg_new,t_ndg_new,ph_ndg_new,       &
+               RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RPHNDGDTEN,&
+               pblh, ht, z, z_at_w,                             &
+               ids,ide, jds,jde, kds,kde,                           &
+               ims,ime, jms,jme, kms,kme,                           &
+               i_start,i_end,j_start,j_end,kts,kte, num_tiles,      &
+               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                        )
+
+
+     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
+   ENDIF
+
+   ENDIF
+
+#endif
+!
+   END SUBROUTINE fddagd_driver
+END MODULE module_fddagd_driver
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_fddaobs_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_fddaobs_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_fddaobs_driver.F	(revision 17)
@@ -0,0 +1,650 @@
+!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,         &
+               config_flags,                                     &
+               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,                         &
+               npfi, ionf,                                       &
+               obs_prt_max, obs_prt_freq, idynin, dtramp,        &
+               parent_grid_ratio, maxdom, itimestep,             &
+               xtime,                                            &
+               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,                          &
+               msftx, msfty, msfux, msfuy, msfvx, msfvy, p_phy, t_tendf, t0,             &
+               ub, vb, tb, qvb, pbase, ptop, pp, phb, ph,        &
+               uratx, vratx, tratx, ru_tendf, rv_tendf,          &
+               moist_tend, savwt,                                &
+               regime, pblh, z_at_w,                             &
+               z,                                                &
+               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 : g, 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
+  TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
+  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
+  INTEGER, intent(in) :: npfi
+  INTEGER, intent(in) :: ionf
+  INTEGER, intent(in) :: obs_prt_max      ! max number of obs in printout
+  INTEGER, intent(in) :: obs_prt_freq     ! frequency (in obs index) printout 
+  INTEGER, intent(in) :: idynin
+  REAL, intent(inout) :: dtramp
+  INTEGER, intent(in) :: parent_grid_ratio
+  REAL, intent(in)     :: xtime           ! forecast time in minutes
+  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 ) ! vertical layer index for PBL top
+  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) :: msftx( ims:ime , jms:jme )  ! Map scale on t-grid
+  REAL, INTENT(IN) :: msfty( ims:ime , jms:jme )  ! Map scale on t-grid
+  REAL, INTENT(IN) :: msfux( ims:ime , jms:jme )  ! Map scale on u-grid
+  REAL, INTENT(IN) :: msfuy( ims:ime , jms:jme )  ! Map scale on u-grid
+  REAL, INTENT(IN) :: msfvx( ims:ime , jms:jme )  ! Map scale on v-grid
+  REAL, INTENT(IN) :: msfvy( 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 )
+  REAL, INTENT(INOUT) :: regime( ims:ime, jms:jme )
+  REAL, INTENT(IN) :: pblh( ims:ime, jms:jme )
+  REAL, INTENT(IN) :: z_at_w( ims:ime, kms:kme, jms:jme ) ! Model ht(m) asl, f-levs
+  REAL, INTENT(IN) :: z( ims:ime, kms:kme, jms:jme )  ! Model ht(m) asl, h-levs
+
+#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) :: phb( ims:ime, kms:kme, jms:jme ) ! Base geopotential
+  REAL,   INTENT(IN) :: ph( ims:ime, kms:kme, jms:jme )  ! Perturbation geopotential
+  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               :: 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
+  real    :: vih_uv(its:ite,jts:jte,2) ! Vert infl heights abv grd for LML obs (wind)
+  real    :: vih_t (its:ite,jts:jte,2) ! Vert infl heights abv grd for LML obs (temp)
+  real    :: vih_q (its:ite,jts:jte,2) ! Vert infl heights abv grd for LML obs (mois)
+  integer :: vik_uv(its:ite,jts:jte,2) ! Vert infl k-levels for LML obs (wind)
+  integer :: vik_t (its:ite,jts:jte,2) ! Vert infl k-levels for LML obs (temp)
+  integer :: vik_q (its:ite,jts:jte,2) ! Vert infl k-levels for LML obs (mois)
+  real    :: z_at_p( kms:kme )       ! Height at p levels
+#ifdef RAL
+  real    :: HTIJ(ids:ide, jds:jde) = 0.  ! Terrain ht on global grid
+#endif
+  character(len=200) :: msg  ! Argument to wrf_message
+
+#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.     
+  ktau  = itimestep - 1        !ktau corresponds to xtime
+
+! Set NSTA to zero on startup, or else retrieve value from last pass.
+  IF(ktau.EQ.fdob%ktaur) THEN
+     if (iprt_nudob) then
+        write(msg,'(a,i2,a)') 'OBS NUDGING is requested on a total of ',   &
+                              fdob%domain_tot,' domain(s).'
+        call wrf_message(msg)
+     endif
+     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
+
+  CALL wrf_debug(100,'in PSU FDDA scheme')
+
+! Make sure regime array is set over entire grid
+! (ajb: Copied code from fddagd)
+    IF( config_flags%bl_pbl_physics /= 1 &
+  .AND. config_flags%bl_pbl_physics /= 5 &
+  .AND. config_flags%bl_pbl_physics /= 6 &
+  .AND. config_flags%bl_pbl_physics /= 7 &
+  .AND. config_flags%bl_pbl_physics /= 99 ) THEN
+      DO j = jts, jte
+      DO i = its, ite
+           IF( pblh(i,j) > z_at_w(i,2,j)-ht(i,j) ) THEN
+             regime(i,j) = 4.0
+           ELSE
+             regime(i,j) = 1.0
+           ENDIF
+      ENDDO
+      ENDDO
+    ENDIF
+
+! Compute VIF heights for each grid column (used for LML obs)
+   if(fdob%sfc_scheme_vert.EQ.0) then
+     if(nudge_wind.EQ.1 .AND. NSTA.GT.0)  then
+       CALL compute_VIH( fdob%vif_uv, fdob%vif_max,                &
+                         fdob%vif_fullmin, fdob%vif_rampmin,       &
+                         regime, pblh,                             &
+                         ht, z, vih_uv,                            &
+                         ids,ide, jds,jde, kds,kde,                &
+                         ims,ime, jms,jme, kms,kme,                &
+                         its,ite, jts,jte, kts,kte )
+     endif
+     if(nudge_temp.EQ.1 .AND. NSTA.GT.0)  then
+       CALL compute_VIH( fdob%vif_t, fdob%vif_max,                 &
+                         fdob%vif_fullmin, fdob%vif_rampmin,       &
+                         regime, pblh,                             &
+                         ht, z, vih_t,                             &
+                         ids,ide, jds,jde, kds,kde,                &
+                         ims,ime, jms,jme, kms,kme,                &
+                         its,ite, jts,jte, kts,kte )
+     endif
+     if(nudge_mois.EQ.1 .AND. NSTA.GT.0)  then
+       CALL compute_VIH( fdob%vif_q, fdob%vif_max,                 &
+                         fdob%vif_fullmin, fdob%vif_rampmin,       &
+                         regime, pblh,                             &
+                         ht, z, vih_q,                             &
+                         ids,ide, jds,jde, kds,kde,                &
+                         ims,ime, jms,jme, kms,kme,                &
+                         its,ite, jts,jte, kts,kte )
+     endif
+   endif
+!********************* END AJB MOVE TO SLAB ***************************
+
+! 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,       &
+                   z,                                                &
+                   uratx, vratx, tratx, kpbl,                        &
+                   nobs_ndg_vars, nobs_err_flds, max_obs, maxdom,    &
+                   fdob%levidn, parid, fdob%nstat, fdob%nstaw,       &
+                   nudge_wind, nudge_temp, nudge_mois, nudge_pstr,   &
+                   fdob%timeob, fdob%rio, fdob%rjo, fdob%rko,        &
+                   varobs, errf, ktau, xtime,                        &
+                   parent_grid_ratio, npfi,                          &
+                   obs_prt_max, obs_prt_freq, iprt_errob,            &
+                   fdob%obsprt, fdob%stnidprt,                       &
+                   fdob%latprt, fdob%lonprt,                         &
+                   fdob%mlatprt, fdob%mlonprt,                       &
+                   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.
+!
+!--- OBS NUDGING FOR TEMP AND MOISTURE
+!
+     NSTA=NSTAT
+     IF(J .GT. 2 .and. J .LT. jde-1) 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), msftx(ims,j), msfty(ims,j),            &
+                  nobs_ndg_vars, nobs_err_flds, max_obs, maxdom,     &
+                  npfi, ionf, rinxy, fdob%window,                    &
+                  fdob%nudge_t_pbl,                                  &
+                  fdob%sfcfact, fdob%sfcfacr,                        &
+                  fdob%levidn,                                       &
+                  parid, nstat,                                      &
+                  fdob%rinfmn, fdob%rinfmx, fdob%pfree,              &
+                  fdob%dcon, fdob%tfaci,                             &
+                  fdob%sfc_scheme_horiz, fdob%sfc_scheme_vert,       &
+                  fdob%max_sndng_gap,                                &
+                  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), kpbl(ims,j), 0,                &
+                  vih_t(its,j,1), vih_t(its,j,2), ht(ims,j),         &
+                  z(ims,kms,j),                                      &
+                  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), msftx(ims,j), msfty(ims,j),            &
+                  nobs_ndg_vars, nobs_err_flds, max_obs, maxdom,     &
+                  npfi, ionf, rinxy, fdob%window,                    &
+                  fdob%nudge_q_pbl,                                  &
+                  fdob%sfcfact, fdob%sfcfacr,                        &
+                  fdob%levidn,                                       &
+                  parid, nstat,                                      &
+                  fdob%rinfmn, fdob%rinfmx, fdob%pfree,              &
+                  fdob%dcon, fdob%tfaci,                             &
+                  fdob%sfc_scheme_horiz, fdob%sfc_scheme_vert,       &
+                  fdob%max_sndng_gap,                                &
+                  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), kpbl(ims,j), 0,                &
+                  vih_q(its,j,1), vih_q(its,j,2), ht(ims,j),         &
+                  z(ims,kms,j),                                      &
+                  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), msfux(ims,j), msfuy(ims,j),              &
+                nobs_ndg_vars, nobs_err_flds, max_obs, maxdom,       &
+                npfi, ionf, rinxy, fdob%window,                      &
+                fdob%nudge_uv_pbl,                                   &
+                fdob%sfcfact, fdob%sfcfacr,                          &
+                fdob%levidn,                                         &
+                parid, nstat,                                        &
+                fdob%rinfmn, fdob%rinfmx, fdob%pfree,                &
+                fdob%dcon, fdob%tfaci,                               &
+                fdob%sfc_scheme_horiz, fdob%sfc_scheme_vert,         &
+                fdob%max_sndng_gap,                                  &
+                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), kpbl(ims,j), 0,                  &
+                vih_uv(its,j,1), vih_uv(its,j,2), ht(ims,j),         &
+                z(ims,kms,j),                                        &
+                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), msfvx(ims,j), msfvy(ims,j),              &
+                nobs_ndg_vars, nobs_err_flds, max_obs, maxdom,       &
+                npfi, ionf, rinxy, fdob%window,                      &
+                fdob%nudge_uv_pbl,                                   &
+                fdob%sfcfact, fdob%sfcfacr,                          &
+                fdob%levidn,                                         &
+                parid, nstat,                                        &
+                fdob%rinfmn, fdob%rinfmx, fdob%pfree,                &
+                fdob%dcon, fdob%tfaci,                               &
+                fdob%sfc_scheme_horiz, fdob%sfc_scheme_vert,         &
+                fdob%max_sndng_gap,                                  &
+                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), kpbl(ims,j), 0,                  &
+                vih_uv(its,j,1), vih_uv(its,j,2), ht(ims,j),         &
+                z(ims,kms,j),                                        &
+                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
+
+  SUBROUTINE compute_VIH(vif, hmax, fullmin, rampmin,       &
+                         regime, pblh, terrh, z, vih,       &
+                         ids,ide, jds,jde, kds,kde,         & ! domain dims
+                         ims,ime, jms,jme, kms,kme,         &
+                         its,ite, jts,jte, kts,kte)
+
+  USE module_fddaobs_rtfdda
+
+  IMPLICIT NONE
+!*******************************************************************************
+!*****     COMPUTE HEIGHTS FOR SURFACE OBS VERTICAL INFLUENCE FUNCTION     *****
+!*******************************************************************************
+
+  REAL,    INTENT(IN)  :: vif(6)                     ! Vert infl params for regimes
+  REAL,    INTENT(IN)  :: hmax                       ! Max height to apply nudging
+  REAL,    INTENT(IN)  :: fullmin                    ! Min height of full nudging
+  REAL,    INTENT(IN)  :: rampmin                    ! Min height to ramp full-to-0 
+  REAL,    INTENT(IN)  :: regime(ims:ime,jms:jme)    ! Stability regime
+  REAL,    INTENT(IN)  :: pblh(ims:ime,jms:jme)      ! PBL height (m)
+  REAL,    INTENT(IN)  :: terrh(ims:ime,jms:jme)     ! Terrain ht (m)
+  REAL,    INTENT(IN)  :: z(ims:ime,kms:kme,jms:jme) ! Ht (m) above sl (half levs)
+  REAL,    INTENT(OUT) :: vih(its:ite,jts:jte,2)     ! Vt infl hts abv grd for LML obs
+! INTEGER, INTENT(OUT) :: vik(its:ite,jts:jte,2)     ! Vert infl k-levels for LML obs
+  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.
+
+! Local variables
+  real  :: fullr(its:ite)    ! Height up to full vertical weighting
+  real  :: rampr(its:ite)    ! Height of ramp-down to zero weighting
+  character(len=200) :: msg  ! Argument to wrf_message
+  integer:: i, j             ! Loop counters
+
+  integer k     ! ajb test
+
+! Do J-slabs
+  do j = jts, jte
+
+!   Set fullr and rampr values according to regimes
+    do i = its, ite
+
+      if(regime(i,j).eq.1.0) then        ! REGIME 1
+        fullr(i) = vif(1)
+        rampr(i) = vif(2)
+      elseif(regime(i,j).eq.2.0) then    ! REGIME 2
+        fullr(i) = vif(3)
+        rampr(i) = vif(4)
+      elseif(regime(i,j).eq.3.0 .or. regime(i,j).eq.4.0) then    ! REGIME 4
+        fullr(i) = vif(5)
+        rampr(i) = vif(6)
+      else
+        write(msg,'(a,f5.1,2(a,i4))') 'Unknown regime type ', regime(i,j),    &
+                                 ' at grid coordinate i = ',i,' j = ',j
+        call wrf_message(msg)
+        call wrf_error_fatal ( 'fddaobs_driver: compute_VIH STOP' )
+        
+      endif
+
+    enddo
+
+!   Get vert infl heights for LML obs, from fullr, rampr, and pblh
+    CALL get_vif_hts_slab(fullr, rampr, pblh(ims,j),         &
+                          hmax, fullmin, rampmin,            &
+                          vih(its,j,1), vih(its,j,2),        &
+                          ims,ime, its,ite)
+  enddo
+  END SUBROUTINE compute_VIH
+
+  SUBROUTINE get_vif_hts_slab(fullr, rampr, pblh, hmax, fullmin, rampmin, &
+                              ht1, ht2, ims,ime, its,ite)
+! Compute VIF heights 
+
+  IMPLICIT NONE
+
+  REAL, INTENT(IN)    :: fullr(its:ite)   ! Height up to full vertical weighting
+  REAL, INTENT(IN)    :: rampr(its:ite)   ! Height of ramp-down to zero weighting
+  REAL, INTENT(IN)    :: pblh(ims:ime)    ! PBL height (m)
+  REAL, INTENT(IN)    :: hmax             ! Max height to apply nudging
+  REAL, INTENT(IN)    :: fullmin          ! Min height of full nudging
+  REAL, INTENT(IN)    :: rampmin          ! Min height to ramp full-to-0 
+  REAL, INTENT(OUT)   :: ht1(its:ite)     ! Vert infl fcn height 1
+  REAL, INTENT(OUT)   :: ht2(its:ite)     ! Vert infl fcn height 2
+  INTEGER, INTENT(IN) :: ims,ime          ! Memory dims.
+  INTEGER, INTENT(IN) :: its,ite          ! Tile   dims.
+
+! Local variables
+  integer :: i
+
+  do i = its, ite
+
+! Determine lower height (below which the VIF=1 for full weighting)
+    if(fullr(i).ge.0.0) then        ! fullr is height from ground
+      ht1(i) = fullr(i)
+    else                            ! fullr is relative to pbl (-5000 bias)
+      ht1(i) = pblh(i) - (fullr(i)+5000.)
+    endif
+
+!   Height ht1 can be no smaller than fullmin
+    ht1(i) = max(fullmin,ht1(i))
+
+! Determine upper height (to which the VIF ramps down to zero weighting)
+! NOTE: Height of ramp-down (ht2-ht1) can be no smaller than rampmin
+
+    if(rampr(i).ge.0.0) then
+!     rampr is height from ht1
+      ht2(i) = ht1(i) + max(rampmin,rampr(i))
+    else
+!     rampr is relative to pbl (-5000 bias)
+      ht2(i) = max( ht1(i)+rampmin, pblh(i)-(rampr(i)+5000.) )
+    endif
+
+! Apply hmax
+    ht1(i) = min(ht1(i), hmax-rampmin)
+    ht2(i) = min(ht2(i), hmax) 
+  enddo
+  END SUBROUTINE get_vif_hts_slab
+
+  SUBROUTINE get_vik_slab( h, hlevs, ht, vik, ims,ime, kms,kme, its,ite, kts,kte )
+
+! Compute VIK values from heights on j-slab 
+
+  IMPLICIT NONE
+
+  REAL,    INTENT(IN) :: h(its:ite)          ! height (m) above ground, on j-slab
+  REAL,    INTENT(IN) :: hlevs(ims:ime,kms:kme) ! hgt (m) abv grd at modl levs (slab)
+  REAL,    INTENT(IN) :: ht(ims:ime)         ! terrain height (m) (slab)
+  INTEGER, INTENT(OUT):: vik(its:ite)        ! vert infl k levels (slab)
+  INTEGER, INTENT(IN) :: ims,ime, kms,kme    ! memory dims
+  INTEGER, INTENT(IN) :: its,ite, kts,kte    ! tile   dims
+
+! Local variables
+  integer :: i
+  integer :: k
+  real    :: ht_ag(kts:kte)
+
+  do i = its, ite
+
+!   Get column of height-above-ground values for this i coord
+    do k = kts,kte
+       ht_ag(k) = hlevs(i,k) - ht(i)
+    enddo
+!   Get k levels that correspond to height values
+    vik(i) = ht_to_k( h(i), ht_ag, kts,kte ) 
+  enddo
+  END SUBROUTINE get_vik_slab
+
+  INTEGER FUNCTION ht_to_k( h, hlevs, kts,kte )
+  IMPLICIT NONE
+
+  REAL,    INTENT(IN)  :: h                     ! height value (m)
+  REAL,    INTENT(IN)  :: hlevs(kts:kte)        ! model height levels
+  INTEGER, INTENT(IN)  :: kts,kte               ! tile dims
+
+! Local variables
+  INTEGER :: k               ! loop counter
+  INTEGER :: klo             ! lower k bound
+
+  KLEVS: do k = kts, kte
+    klo = k-1
+    if(h .le. hlevs(k)) then
+      EXIT KLEVS
+    endif
+  enddo KLEVS
+  klo = max0(1,klo)
+  ht_to_k = min0(kte,klo)
+  RETURN
+  END FUNCTION ht_to_k
+
+END MODULE module_fddaobs_driver
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_fddaobs_rtfdda.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_fddaobs_rtfdda.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_fddaobs_rtfdda.F	(revision 17)
@@ -0,0 +1,2977 @@
+!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
+!
+! Modification History:
+!   03212007 Modified fddaobs_init to compute Lambert cone factor. -Al Bourgeois
+
+CONTAINS
+
+!------------------------------------------------------------------------------
+  SUBROUTINE fddaobs_init(nudge_opt, maxdom, inest, parid,             &
+                          idynin, dtramp, fdaend, restart,             &
+                          twindo_cg, twindo, itimestep,                &
+                          no_pbl_nudge_uv,                             &
+                          no_pbl_nudge_t,                              &
+                          no_pbl_nudge_q,                              &
+                          sfc_scheme_horiz, sfc_scheme_vert,           &
+                          maxsnd_gap,                                  &
+                          sfcfact, sfcfacr, dpsmx,                     &
+                          nudge_wind, nudge_temp, nudge_mois,          &
+                          nudgezfullr1_uv, nudgezrampr1_uv,            &
+                          nudgezfullr2_uv, nudgezrampr2_uv,            &
+                          nudgezfullr4_uv, nudgezrampr4_uv,            &
+                          nudgezfullr1_t,  nudgezrampr1_t,             &
+                          nudgezfullr2_t,  nudgezrampr2_t,             &
+                          nudgezfullr4_t,  nudgezrampr4_t,             &
+                          nudgezfullr1_q,  nudgezrampr1_q,             &
+                          nudgezfullr2_q,  nudgezrampr2_q,             &
+                          nudgezfullr4_q,  nudgezrampr4_q,             &
+                          nudgezfullmin,   nudgezrampmin, nudgezmax,   &
+                          xlat, xlong,                                 &
+                          start_year, start_month, start_day,          &
+                          start_hour, start_minute, start_second,      &
+                          p00, t00, tlp,                               &
+                          znu, p_top,                                  &
+#if ( EM_CORE == 1 )
+                          fdob,                                        &
+#endif
+                          iprt,                                        &
+                          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_model_constants, ONLY : g, r_d
+  USE module_domain
+  USE module_dm, ONLY : wrf_dm_min_real
+!-----------------------------------------------------------------------
+  IMPLICIT NONE
+!-----------------------------------------------------------------------
+
+!=======================================================================
+! Definitions
+!-----------
+  INTEGER, intent(in)  :: maxdom
+  INTEGER, intent(in)  :: 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)
+  INTEGER, intent(in)  :: idynin         ! flag for dynamic initialization
+  REAL,    intent(in)  :: dtramp         ! time period for idynin ramping (min)
+  REAL,    intent(in)  :: fdaend(maxdom) ! nudging end time for domain (min)
+  LOGICAL, intent(in)  :: restart
+  REAL, intent(in)     :: twindo_cg      ! time window on coarse grid
+  REAL, intent(in)     :: twindo
+  INTEGER, intent(in)  :: itimestep
+  INTEGER , INTENT(IN) :: no_pbl_nudge_uv(maxdom)  ! flags for no wind nudging in pbl 
+  INTEGER , INTENT(IN) :: no_pbl_nudge_t(maxdom)   ! flags for no temperature nudging in pbl
+  INTEGER , INTENT(IN) :: no_pbl_nudge_q(maxdom)   ! flags for no moisture nudging in pbl
+  INTEGER , INTENT(IN) :: sfc_scheme_horiz ! horizontal spreading scheme for surf obs (wrf or orig mm5)
+  INTEGER , INTENT(IN) :: sfc_scheme_vert  ! vertical spreading scheme for surf obs (orig or regime vif)
+  REAL    , INTENT(IN) :: maxsnd_gap      ! max allowed pressure gap in soundings, for interp (centibars)
+  REAL, intent(in)     :: sfcfact      ! scale factor applied to time window for surface obs  
+  REAL, intent(in)     :: sfcfacr      ! scale fac applied to horiz rad of infl for sfc obs
+  REAL, intent(in)     :: dpsmx        ! max press change allowed within hor rad of infl
+  INTEGER , INTENT(IN) :: nudge_wind(maxdom)       ! wind-nudging flag
+  INTEGER , INTENT(IN) :: nudge_temp(maxdom)       ! temperature-nudging flag
+  INTEGER , INTENT(IN) :: nudge_mois(maxdom)       ! moisture-nudging flag
+  REAL, INTENT(IN)     :: nudgezfullr1_uv  ! vert infl fcn, regime=1 full-wt   hght, winds
+  REAL, INTENT(IN)     :: nudgezrampr1_uv  ! vert infl fcn, regime=1 ramp down hght, winds
+  REAL, INTENT(IN)     :: nudgezfullr2_uv  ! vert infl fcn, regime=2 full-wt   hght, winds
+  REAL, INTENT(IN)     :: nudgezrampr2_uv  ! vert infl fcn, regime=2 ramp down hght, winds
+  REAL, INTENT(IN)     :: nudgezfullr4_uv  ! vert infl fcn, regime=4 full-wt   hght, winds
+  REAL, INTENT(IN)     :: nudgezrampr4_uv  ! vert infl fcn, regime=4 ramp down hght, winds
+  REAL, INTENT(IN)     :: nudgezfullr1_t   ! vert infl fcn, regime=1 full-wt   hght, temp
+  REAL, INTENT(IN)     :: nudgezrampr1_t   ! vert infl fcn, regime=1 ramp down hght, temp
+  REAL, INTENT(IN)     :: nudgezfullr2_t   ! vert infl fcn, regime=2 full-wt   hght, temp
+  REAL, INTENT(IN)     :: nudgezrampr2_t   ! vert infl fcn, regime=2 ramp down hght, temp
+  REAL, INTENT(IN)     :: nudgezfullr4_t   ! vert infl fcn, regime=4 full-wt   hght, temp
+  REAL, INTENT(IN)     :: nudgezrampr4_t   ! vert infl fcn, regime=4 ramp down hght, temp
+  REAL, INTENT(IN)     :: nudgezfullr1_q   ! vert infl fcn, regime=1 full-wt   hght, mois
+  REAL, INTENT(IN)     :: nudgezrampr1_q   ! vert infl fcn, regime=1 ramp down hght, mois
+  REAL, INTENT(IN)     :: nudgezfullr2_q   ! vert infl fcn, regime=2 full-wt   hght, mois
+  REAL, INTENT(IN)     :: nudgezrampr2_q   ! vert infl fcn, regime=2 ramp down hght, mois
+  REAL, INTENT(IN)     :: nudgezfullr4_q   ! vert infl fcn, regime=4 full-wt   hght, mois
+  REAL, INTENT(IN)     :: nudgezrampr4_q   ! vert infl fcn, regime=4 ramp down hght, mois
+  REAL, INTENT(IN)     :: nudgezfullmin    ! min dpth thru which vert infl fcn remains 1.0 (m)
+  REAL, INTENT(IN)     :: nudgezrampmin    ! min dpth thru which vif decreases 1.0 to 0.0 (m)
+  REAL, INTENT(IN)     :: nudgezmax        ! max dpth in which vif is nonzero (m)
+  REAL, INTENT(IN)     :: xlat ( ims:ime, jms:jme )        ! latitudes on mass-point grid
+  REAL, INTENT(IN)     :: xlong( ims:ime, jms:jme )        ! longitudes on mass-point grid
+  INTEGER, intent(in)  :: start_year   ! Model start year
+  INTEGER, intent(in)  :: start_month  ! Model start month
+  INTEGER, intent(in)  :: start_day    ! Model start day
+  INTEGER, intent(in)  :: start_hour   ! Model start hour
+  INTEGER, intent(in)  :: start_minute ! Model start minute
+  INTEGER, intent(in)  :: start_second ! Model start second
+  REAL, INTENT(IN)     :: p00          ! base state pressure
+  REAL, INTENT(IN)     :: t00          ! base state temperature
+  REAL, INTENT(IN)     :: tlp          ! base state lapse rate
+  REAL, INTENT(IN)     :: p_top        ! pressure at top of model
+  REAL, INTENT(IN)     :: znu( kms:kme )      ! eta values on half (mass) levels
+#if ( EM_CORE == 1 ) 
+  TYPE(fdob_type), intent(inout)  :: fdob
+#endif
+  LOGICAL, intent(in)  :: iprt         ! Flag enabling printing warning messages
+
+! 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
+  real               :: conv            ! 180/pi
+  real               :: tl1             ! Lambert standard parallel 1
+  real               :: tl2             ! Lambert standard parallel 2
+  real               :: xn1
+  real               :: known_lat       ! Latitude of domain point (i,j)=(1,1)
+  real               :: known_lon       ! Longitude of domain point (i,j)=(1,1) 
+  character(len=200) :: msg             ! Argument to wrf_message
+  real               :: z_at_p( kms:kme )  ! height at p levels
+  integer            :: i,j,k           ! loop counters
+
+#if ( EM_CORE == 1 ) 
+
+! Check to see if the nudging flag has been set. If not,
+! simply RETURN.
+  nudge_flag = (nudge_opt(inest) .eq. 1)
+  if (.not. nudge_flag) return
+
+  call wrf_message("")
+  write(msg,fmt='(a,i2)') ' OBSERVATION NUDGING IS ACTIVATED FOR MESH ',inest
+  call wrf_message(msg)
+
+  ktau  = itimestep
+  if(restart) then
+    fdob%ktaur = ktau
+  else
+    fdob%ktaur = 0 
+  endif
+
+! Create character string containing model starting-date
+  CALL date_string(start_year, start_month, start_day, start_hour,        &
+                   start_minute, start_second, fdob%sdate)
+
+! Set flag for nudging on pressure (not sigma) surfaces.
+  fdob%iwtsig = 0
+
+!**************************************************************************
+! *** Initialize datend for dynamic initialization (ajb added 08132008) ***
+!**************************************************************************
+! Set ending nudging date (used with dynamic ramp-down) to zero.
+  fdob%datend = 0.
+  fdob%ieodi = 0
+
+! Check for dynamic initialization flag
+  if(idynin.eq.1)then
+!    Set datend to time in minutes after which data are assumed to have ended.
+     if(dtramp.gt.0.)then
+        fdob%datend = fdaend(inest) - dtramp
+     else
+        fdob%datend = fdaend(inest)
+     endif
+     if(iprt) then
+        call wrf_message("")
+        write(msg,fmt='(a,i3,a)')                                              &
+          ' *** DYNAMIC-INITIALIZATION OPTION FOR INEST = ', inest, ' ***'
+        call wrf_message(msg)
+        write(msg,*) ' FDAEND,DATEND,DTRAMP: ',fdaend(inest),fdob%datend,dtramp
+        call wrf_message(msg)
+        call wrf_message("")
+     endif
+  endif
+! *** end dynamic initialization section ***
+!**************************************************************************
+
+! Store flags for surface obs spreading schemes
+  if(sfc_scheme_horiz.eq.1) then
+     call wrf_message('MM5 scheme selected for horizontal spreading of surface obs')
+  elseif (sfc_scheme_horiz.eq.0) then
+     call wrf_message('WRF scheme selected for horizontal spreading of surface obs')
+  else
+     write(msg,fmt='(a,i3)') 'Unknown h-spreading scheme for surface obs: ',sfc_scheme_horiz
+     call wrf_message(msg)
+     call wrf_message("Valid selections: 0=WRF scheme, 1=Original MM5 scheme")
+     call wrf_error_fatal ( 'fddaobs_init: module_fddaobs_rtfdda STOP' )
+  endif
+
+  if(sfc_scheme_vert.eq.1) then
+     call wrf_message('Original simple scheme selected for vertical spreading of surface obs')
+  elseif (sfc_scheme_vert.eq.0) then
+     call wrf_message("Regime-based VIF scheme selected for vertical spreading of surface obs")
+  else
+     write(msg,fmt='(a,i3)') 'Unknown v-spreading scheme for surface obs: ',sfc_scheme_vert
+     call wrf_message(msg)
+     call wrf_message("Valid selections: 0=Regime-based VIF scheme, 1=Original simple scheme")
+     call wrf_error_fatal ( 'fddaobs_init: module_fddaobs_rtfdda STOP' )
+  endif
+  fdob%sfc_scheme_horiz = sfc_scheme_horiz 
+  fdob%sfc_scheme_vert  = sfc_scheme_vert
+
+
+! Store temporal and spatial scales
+  fdob%sfcfact = sfcfact
+  fdob%sfcfacr = sfcfacr
+
+! Set time window.
+  fdob%window = twindo
+  call wrf_message("")
+  write(msg,fmt='(a,i3)') '*** TIME WINDOW SETTINGS FOR NEST ',inest
+  call wrf_message(msg)
+  write(msg,fmt='(a,f6.3,2(a,f5.3))') '    TWINDO (hrs) = ',twindo,      &
+            '  SFCFACT = ',sfcfact,'  SFCFACR = ',sfcfacr
+  call wrf_message(msg)
+  call wrf_message("")
+
+  if(inest.eq.1) then
+    if(twindo .eq. 0.) then
+      if(iprt) then
+        call wrf_message("")
+        write(msg,*) '*** WARNING: TWINDO=0 on the coarse domain.'
+        call wrf_message(msg)
+        write(msg,*) '*** Did you forget to set twindo in the fdda namelist?'
+        call wrf_message(msg)
+        call wrf_message("")
+      endif
+    endif
+  else        ! nest
+    if(twindo .eq. 0.) then
+      fdob%window = twindo_cg
+      if(iprt) then
+        call wrf_message("")
+        write(msg,fmt='(a,i2)') 'WARNING: TWINDO=0. for nest ',inest
+        call wrf_message(msg)
+        write(msg,fmt='(a,f12.5,a)') 'Default to coarse-grid value of ', twindo_cg,' hrs'
+        call wrf_message(msg)
+        call wrf_message("")
+      endif
+    endif
+  endif
+
+! Initialize flags.
+
+  fdob%domain_tot=0
+  do nest=1,maxdom
+    fdob%domain_tot = fdob%domain_tot + nudge_opt(nest)
+  end do
+
+! Calculate and store dcon from dpsmx
+  if(dpsmx.gt.0.) then
+       fdob%dpsmx = dpsmx
+       fdob%dcon = 1.0/fdob%dpsmx
+  else 
+       call wrf_error_fatal('fddaobs_init: Namelist variable dpsmx must be greater than zero!')
+  endif
+
+! Calculate and store base-state heights at half (mass) levels.
+  CALL get_base_state_height_column( p_top, p00, t00, tlp, g, r_d, znu,   &
+                                     fdob%base_state,  kts, kte, kds,kde, kms,kme )
+
+! Initialize flags for nudging within PBL.
+  fdob%nudge_uv_pbl  = .true.
+  fdob%nudge_t_pbl   = .true.
+  fdob%nudge_q_pbl   = .true.
+  if(no_pbl_nudge_uv(inest) .eq. 1) fdob%nudge_uv_pbl  = .false.
+  if(no_pbl_nudge_t(inest) .eq. 1)  fdob%nudge_t_pbl   = .false.
+  if(no_pbl_nudge_q(inest) .eq. 1)  fdob%nudge_q_pbl   = .false.
+
+  if(no_pbl_nudge_uv(inest) .eq. 1) then
+    fdob%nudge_uv_pbl  = .false.
+    write(msg,*) '   --> Obs nudging for U/V is turned off in PBL'
+    call wrf_message(msg)
+  endif
+  if(no_pbl_nudge_t(inest) .eq. 1)  then
+    fdob%nudge_t_pbl   = .false.
+    write(msg,*) '   --> Obs nudging for T is turned off in PBL'
+    call wrf_message(msg)
+  endif
+  if(no_pbl_nudge_q(inest) .eq. 1)  then
+    fdob%nudge_q_pbl   = .false.
+    write(msg,*) '   --> Obs nudging for Q is turned off in PBL'
+    call wrf_message(msg)
+  endif
+
+! Store max allowed pressure gap for interpolating between soundings
+  fdob%max_sndng_gap = maxsnd_gap
+  write(msg,fmt='(a,f6.1)')  &
+  '*** MAX PRESSURE GAP (cb) for interpolation between soundings = ',maxsnd_gap
+  call wrf_message(msg)
+  call wrf_message("")
+
+! Initialize vertical influence fcn for LML obs 
+  if(sfc_scheme_vert.eq.0) then
+    fdob%vif_uv(1) = nudgezfullr1_uv
+    fdob%vif_uv(2) = nudgezrampr1_uv
+    fdob%vif_uv(3) = nudgezfullr2_uv
+    fdob%vif_uv(4) = nudgezrampr2_uv
+    fdob%vif_uv(5) = nudgezfullr4_uv
+    fdob%vif_uv(6) = nudgezrampr4_uv
+    fdob%vif_t (1) = nudgezfullr1_t
+    fdob%vif_t (2) = nudgezrampr1_t
+    fdob%vif_t (3) = nudgezfullr2_t
+    fdob%vif_t (4) = nudgezrampr2_t
+    fdob%vif_t (5) = nudgezfullr4_t
+    fdob%vif_t (6) = nudgezrampr4_t
+    fdob%vif_q (1) = nudgezfullr1_q
+    fdob%vif_q (2) = nudgezrampr1_q
+    fdob%vif_q (3) = nudgezfullr2_q
+    fdob%vif_q (4) = nudgezrampr2_q
+    fdob%vif_q (5) = nudgezfullr4_q
+    fdob%vif_q (6) = nudgezrampr4_q
+
+! Sanity checks
+    if(nudgezmax.le.0.) then
+      write(msg,*) 'STOP! OBS NAMELIST INPUT obs_nudgezmax MUST BE GREATER THAN ZERO.'
+      call wrf_message(msg)
+      write(msg,*) 'THE NAMELIST VALUE IS',nudgezmax
+      call wrf_message(msg)
+      call wrf_error_fatal ( 'fddaobs_init: STOP on bad obs_nudgemax value' )
+    endif
+    if(nudgezfullmin.lt.0.) then
+      write(msg,*) 'STOP! OBS NAMELIST INPUT obs_nudgezfullmin MUST BE NONNEGATIVE.'
+      call wrf_message(msg)
+      write(msg,*) 'THE NAMELIST VALUE IS',nudgezfullmin
+      call wrf_message(msg)
+      call wrf_error_fatal ( 'fddaobs_init: STOP on bad obs_nudgefullmin value' )
+    endif
+    if(nudgezrampmin.lt.0.) then
+      write(msg,*) 'STOP! OBS NAMELIST INPUT obs_nudgezrampmin MUST BE NONNEGATIVE.'
+      call wrf_message(msg)
+      write(msg,*) 'THE NAMELIST VALUE IS',nudgezrampmin
+      call wrf_message(msg)
+      call wrf_error_fatal ( 'fddaobs_init: STOP on bad obs_nudgerampmin value' )
+    endif
+    if(nudgezmax.lt.nudgezfullmin+nudgezrampmin) then
+      write(msg,*) 'STOP! INCONSISTENT OBS NAMELIST INPUTS.'
+      call wrf_message(msg)
+      write(msg,fmt='(3(a,f12.3))') 'obs_nudgezmax = ',nudgezmax,                &
+                              ' obs_nudgezfullmin = ',nudgezfullmin,       &
+                              ' obs_nudgezrampmin = ',nudgezrampmin
+      call wrf_message(msg)
+      write(msg,*) 'REQUIRE NUDGEZMAX >= NUDGEZFULLMIN + NUDGEZRAMPMIN'
+      call wrf_message(msg)
+      call wrf_error_fatal ( 'fddaobs_init: STOP on inconsistent namelist values' )
+    endif
+ 
+    fdob%vif_fullmin = nudgezfullmin
+    fdob%vif_rampmin = nudgezrampmin
+    fdob%vif_max     = nudgezmax
+ 
+! Check to make sure that if nudgzfullmin > 0, then it must be at least as large as the
+! first model half-level will be anywhere in the domain at any time within the simulation.
+! We use 1.1 times the base-state value fdob%base_state(1) for this purpose. 
+
+    if(nudgezfullmin.gt.0.0) then
+        if(nudgezfullmin .lt. 1.1*fdob%base_state(1)) then
+           fdob%vif_fullmin = 1.1*fdob%base_state(1)
+        endif
+    endif
+
+! Print vertical weight info only if wind, temperature, or moisture nudging is requested.
+    if( (nudge_wind(inest).eq.1) .or. (nudge_temp(inest).eq.1)                             &
+                                               .or. (nudge_mois(inest).eq.1) ) then
+    call wrf_message("")
+    write(msg,fmt='(a,i2,a)') ' *** SETUP DESCRIPTION FOR SURFACE OBS NUDGING ON MESH ',inest,' :'
+    call wrf_message(msg)
+
+    call wrf_message("")
+    write(msg,fmt='(a,i5,a)') '  NUDGEZMAX: The maximum height at which nudging will be'//     &
+                        ' applied from surface obs is ', nint(nudgezmax),' m AGL.'
+    call wrf_message(msg)
+    call wrf_message("")
+    write(msg,fmt='(a,i3,a)') '  NUDGEZFULLMIN: The minimum height of full nudging weight'//   &
+                          ' for surface obs is ', nint(fdob%vif_fullmin),' m.'
+    call wrf_message(msg)
+    if(nudgezfullmin.lt.fdob%vif_fullmin) then
+        write(msg,fmt='(a,i3,a)') '  ***WARNING***: NUDGEZFULLMIN has been increased from'//   &
+                              ' the user-input value of ',nint(nudgezfullmin),' m.'
+        call wrf_message(msg)
+        write(msg,fmt='(a,i3,a)') '  to ensure that at least the bottom model level is'//      &
+                              ' included in full nudging.'
+        call wrf_message(msg)
+    endif
+    call wrf_message("")
+    write(msg,fmt='(a,i3,a)') '  NUDGEZRAMPMIN: The minimum height to ramp from full to no'//  &
+                          ' nudging for surface obs is ', nint(nudgezrampmin),' m.'
+    call wrf_message(msg)
+    call wrf_message("")
+    endif   !endif either wind, temperature, or moisture nudging is requested
+
+! Print vif settings
+    if(nudge_wind(inest) .eq. 1) then
+      call print_vif_var('wind', fdob%vif_uv, nudgezfullmin, nudgezrampmin)
+      call wrf_message("")
+    endif
+    if(nudge_temp(inest) .eq. 1) then
+      call print_vif_var('temp', fdob%vif_t,  nudgezfullmin, nudgezrampmin)
+      call wrf_message("")
+    endif
+    if(nudge_mois(inest) .eq. 1) then
+      call print_vif_var('mois', fdob%vif_q,  nudgezfullmin, nudgezrampmin)
+      call wrf_message("")
+    endif
+
+    if( (nudge_wind(inest).eq.1) .or. (nudge_temp(inest).eq.1)                             &
+                                                 .or. (nudge_mois(inest).eq.1) ) then
+    write(msg,fmt='(a,i2)') ' *** END SETUP DESCRIPTION FOR SURFACE OBS NUDGING ON MESH ',inest
+    call wrf_message(msg)
+    call wrf_message("")
+    endif
+  endif   !endif(sfc_scheme_vert.EQ.0)
+
+! Set parameters.
+  fdob%pfree = 50.0
+  fdob%rinfmn = 1.0
+  fdob%rinfmx = 2.0
+
+! Get known lat and lon and store these on all processors in fdob structure, for
+! later use in projection x-formation to map (lat,lon) to (x,y) for each obs.
+      IF (its .eq. 1 .AND. jts .eq. 1) then
+         known_lat = xlat(1,1)
+         known_lon = xlong(1,1)
+      ELSE
+         known_lat = 9999.
+         known_lon = 9999.
+      END IF
+      fdob%known_lat = wrf_dm_min_real(known_lat)
+      fdob%known_lon = wrf_dm_min_real(known_lon)
+
+! 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 = parent
+        goto 100
+      endif
+  enddo
+
+
+! fdob%LML_OBS_HT1_LEV = kte 
+! HT1: do k = kte, kts, -1
+!        if( LML_HT1 .gt. z_at_p(k) ) then
+!          fdob%LML_OBS_HT1_LEV = k
+!          EXIT HT1 
+!        endif
+!      enddo  HT1
+
+! fdob%LML_OBS_HT2_LEV = kte 
+! HT2: do k = kte, kts, -1
+!        if( LML_HT2 .gt. z_at_p(k) ) then
+!          fdob%LML_OBS_HT2_LEV = k
+!          EXIT HT2 
+!        endif
+!      enddo HT2 
+  RETURN
+#endif
+  END SUBROUTINE fddaobs_init
+
+#if ( EM_CORE == 1 )
+!-----------------------------------------------------------------------
+SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp,  &
+                 z,                                             &
+                 uratx, vratx, tratx, kpbl,                     &
+                 nndgv, nerrf, niobf, maxdom,                   &
+                 levidn, parid, nstat, nstaw,                   &
+                 iswind, istemp, ismois, ispstr,                &
+                 timeob, rio, rjo, rko,                         &
+                 varobs, errf, ktau, xtime,                     &
+                 iratio, npfi,                                  &
+                 prt_max, prt_freq, iprt,                       &
+                 obs_prt, stnid_prt, lat_prt, lon_prt,          &
+                 mlat_prt, mlon_prt,                            & 
+                 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, wrf_dm_sum_real
+#else
+  USE module_dm, ONLY :                      wrf_dm_sum_real
+#endif
+  USE module_model_constants, ONLY : rcp
+
+!-----------------------------------------------------------------------
+  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 ERRF IS AS FOLLOWS:
+!        IVAR                VARIABLE TYPE(TAU-1)
+!        ----                --------------------
+!         1                    U error at obs loc
+!         2                    V error at obs loc
+!         3                    T error at obs loc
+!         4                    Q error at obs loc
+!         5                    Vertical layer index for PBL top at IOB, JOB
+!         6                    Model surface press at obs loc (T-points)
+!         7                    Model surface press at obs loc (U-points)
+!         8                    Model surface press at obs loc (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)  :: ktau                   ! Model time step index
+  REAL, INTENT(IN)     :: xtime                  ! Forecast time in minutes
+  INTEGER, INTENT(IN)  :: iratio                 ! Nest to parent gridsize ratio.
+  INTEGER, INTENT(IN)  :: npfi                   ! Coarse-grid diagnostics freq.
+  INTEGER, INTENT(IN)  :: prt_max                ! Max number of obs to print.
+  INTEGER, INTENT(IN)  :: prt_freq               ! Frequency of obs to print.
+  LOGICAL, INTENT(IN)  :: iprt                   ! Print flag
+  INTEGER, INTENT(IN)  :: obs_prt(prt_max)       ! Print obs indices
+  INTEGER, INTENT(IN)  :: stnid_prt(40,prt_max)  ! Print obs station ids
+  REAL, INTENT(IN)     :: lat_prt(prt_max)       ! Print obs latitude
+  REAL, INTENT(IN)     :: lon_prt(prt_max)       ! Print obs longitude
+  REAL, INTENT(IN)     :: mlat_prt(prt_max)      ! Print model lat at obs loc
+  REAL, INTENT(IN)     :: mlon_prt(prt_max)      ! Print model lon at obs loc
+  INTEGER, INTENT(IN)  :: nstat                  ! # stations held for use
+  INTEGER, INTENT(IN)  :: nstaw                  ! # stations in current window
+  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) :: z( ims:ime, kms:kme, jms:jme ) ! Ht above sl on half-levels
+  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.
+  INTEGER,INTENT(IN) :: kpbl( ims:ime, jms:jme )  ! Vertical layer index for PBL top
+  REAL,   INTENT(IN) :: timeob(niobf)             ! Obs time (hrs)
+  REAL,   INTENT(IN) :: rio(niobf)                ! Obs west-east coordinate (non-stag grid).
+  REAL,   INTENT(IN) :: rjo(niobf)                ! Obs south-north coordinate (non-stag grid).
+  REAL,   INTENT(INOUT) :: rko(niobf)             ! Obs bottom-top coordinate
+  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
+  character(len=200) :: msg            ! Argument to wrf_message
+
+! 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 :: obs_pottemp                  ! Potential temperature at observation
+
+!***  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
+  integer ips                            ! For printing obs information
+  integer pnx                            ! obs index for printout
+
+  real gridx,gridy,dxob,dyob,dzob,dxob_ms,dyob_ms
+  real pob
+  real hob
+  real uratiob,vratiob,tratiob,tratxob,fnpf
+
+#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(msg,fmt='(a,i5,a,i2,a,i5,a)') '++++++CALL ERROB AT KTAU = ', &
+            KTAU,' AND INEST = ',INEST,':  NSTA = ',NSTAW,' ++++++'
+    call wrf_message(msg)
+  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)
+
+
+! ajb 20090423: BUGFIX TO OBS_IN_HEIGHT OPTION
+! This is tricky: Initialize pob to zero in all procs. Only one proc actually
+! calculates pob. If this is an obs to be converted from height-to-pressure, then
+! by definition, varobs(5,n) will initially have the missing value -888888. After
+! the pob calculation, pob will be zero in all procs except the one that calculated
+! it, and so pob is dm_summed over all procs and stored into varobs(5,n). So on
+! subsequent passes, the dm_sum will not occur because varobs(5,n) will not have a
+! missing value. If this is not an obs-in-height,  
+
+        pob = 0.0
+
+#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) ) )  
+          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                ityp=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 .eq.-888888.) then
+               hob = varobs(6,n)
+               if(hob .gt. -800000. ) then
+                 pob = ht_to_p( hob, ppbo, pbbo, z, iob_ms, job_ms,          &
+                                dxob_ms, dyob_ms, k_start, k_end, kds,kde,   &
+                                ims,ime, jms,jme, kms,kme )
+               endif
+            endif
+
+            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
+
+! ajb 20090423: If obs-in-height, varobs(5,n) is sum of pob (see note above).
+        if(varobs(5,n) .eq. -888888. .and. varobs(6,n) .gt. -800000.) then
+           varobs(5,n) = wrf_dm_sum_real ( pob )
+        endif
+
+        RC(N)=RKO(N)
+
+      ENDDO      ! END COARSE MESH LOOP OVER NSTA 
+
+    ELSE       ! FINE MESH CASE
+
+!**********************************************************************
+!ajb_07012008: Conversion of obs coordinates to the fine mesh here
+!ajb   is no longer necessary, since implementation of the WRF map pro-
+!ajb   jections (to each nest directly) is implemented in sub in4dob. 
+!**********************************************************************
+!ajb
+!ajb  GET (I,J,K) OF OBSERVATIONS ON FINE MESH VALUES.
+      DO N=1,NSTA
+          RA(N)=RIO(N)-GRIDX           ! ajb added 07012008
+          RB(N)=RJO(N)-GRIDY           ! ajb added 07012008
+          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)
+
+! ajb 20090423: BUGFIX TO OBS_IN_HEIGHT OPTION (see COARSE MESH comments)
+        pob = 0.0
+
+#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) ) )
+          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 .eq.-888888.) then
+               hob = varobs(6,n)
+               if(hob .gt. -800000. ) then
+                 pob = ht_to_p( hob, ppbo, pbbo, z, iob_ms, job_ms,          &
+                                dxob_ms, dyob_ms, k_start, k_end, kds,kde,   &
+                                ims,ime, jms,jme, kms,kme )
+               endif
+            endif
+
+            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
+
+! ajb 20090423: If obs-in-height, varobs(5,n) is sum of pob (see note above).
+        if(varobs(5,n) .eq. -888888. .and. varobs(6,n) .gt. -800000.) then
+           varobs(5,n) = wrf_dm_sum_real ( pob )
+        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.-DYOB)*((1.-DXOB)*uratio(IOB,JOB)+     &
+                    DXOB*uratio(IOBP,JOB)                        &
+                  )+DYOB*((1.-DXOB)*uratio(IOB,JOBP)+            &
+                  DXOB*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.-DYOB)*((1.-DXOB)*vratio(IOB,JOB)+     &
+                    DXOB*vratio(IOBP,JOB)                        &
+                  )+DYOB*((1.-DXOB)*vratio(IOB,JOBP)+            &
+                  DXOB*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))))
+
+!      if(n.le.10) then
+!        write(6,*) 
+!        write(6,'(a,i3,i3,i3,a,i3,a,i2)') 'ERRF2 at ',iob,job,kob,   &
+!                                     ' N = ',n,' inest = ',inest
+!        write(6,*) 'VAROBS(2,N) = ',varobs(2,n)
+!        write(6,*) 'VAROBS(5,N) = ',varobs(5,n)
+!        write(6,*) 'VB(IOB,KOB,JOB) = ',VB(IOB,KOB,JOB)
+!        write(6,*) 'ERRF(2,N) = ',errf(2,n)
+!        write(6,*) 'vratiob = ',vratiob
+!        write(6,*)
+!      endif
+
+  
+!           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.-DYOB)*((1.-DXOB)*tratx(IOB,JOB)+        &
+                    DXOB*tratx(IOB+1,JOB)                          &
+                  )+DYOB*((1.-DXOB)*tratx(IOB,JOB+1)+              &
+                  DXOB*tratx(IOB+1,JOB+1)))
+            else
+              tratxob=1.
+            endif
+
+!yliu
+            if(abs(tratxob) .lt. 1.0E-3) tratxob=1.
+
+!ajb We must convert temperature to potential temperature
+            obs_pottemp = -888888.
+            if(varobs(3,n).gt.-800000. .and. varobs(5,n).gt.-800000) then
+              obs_pottemp = varobs(3,n)*(100./varobs(5,n))**RCP - t0
+            endif
+
+            ERRF(3,N)=ERRF(3,N)+tratxob*obs_pottemp-((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 ( 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)
+
+!*******************************************************
+!   USE ERRF(5,N) TO STORE KPBL AT (I,J) NEAREST THE OBS
+!*******************************************************
+      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)
+          ERRF(5,N) = kpbl(iob+nint(dxob),job+nint(dyob))
+
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+        ENDIF       ! end IF( MP_LOCAL_COBMASK(N) )
+#endif
+      ENDDO
+!!**********************************************************
+    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)
+
+! 02252010: Go ahead and assign rko for "obs-off" processors here, to
+!           fix the problem where duplicate obs can be dropped from
+!           the "obs-on" processor, but not from the others, due to
+!           rko being -99 on the "obs-off" processors.
+  do n=1,nsta
+    rko(n) = errf(9,n)
+  enddo
+! 02252010: End bugfix.
+#endif
+
+! Print obs information.
+  CALL print_obs_info(iprt,inest,niobf,rio,rjo,rko,                  &
+                      prt_max,prt_freq,obs_prt,stnid_prt,            &
+                      lat_prt,lon_prt,mlat_prt,mlon_prt,             &
+                      timeob,xtime)
+
+! 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, msfx, msfy, nndgv, nerrf, niobf, maxdom,   &
+                       npfi, ionf, rinxy, twindo,                     &
+                       nudge_pbl,                                     &
+                       sfcfact, sfcfacr,                              &
+                       levidn,                                        &
+                       parid, nstat,                                  &
+                       rinfmn, rinfmx, pfree, dcon, tfaci,            &
+                       sfc_scheme_horiz, sfc_scheme_vert, maxsnd_gap, &
+                       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,                           &
+                       vih1, vih2, terrh, zslab,                      &
+                       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
+!     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
+  REAL, intent(in)     :: sfcfact                    ! scale for time window (surface obs) 
+  REAL, intent(in)     :: sfcfacr                    ! scale for hor rad inf (surface obs)
+  LOGICAL, intent(in)  :: nudge_pbl                  ! flag for nudging in pbl
+  INTEGER, INTENT(IN)  :: levidn(maxdom)             ! level of nest
+  INTEGER, INTENT(IN)  :: parid(maxdom)              ! parent domain id
+  INTEGER, INTENT(IN)  :: nstat                      ! number of obs stations
+  REAL,    INTENT(IN)  :: rinfmn          ! minimum radius of influence
+  REAL,    INTENT(IN)  :: rinfmx          ! maximum radius of influence
+  REAL,    INTENT(IN)  :: pfree           ! pressure level (cb) where terrain effect becomes small
+  REAL,    INTENT(IN)  :: dcon            ! 1/DPSMX
+  REAL,    INTENT(IN)  :: tfaci           ! scale factor used for ramp-down in dynamic initialization
+  INTEGER , INTENT(IN) :: sfc_scheme_horiz ! horizontal spreading scheme for surf obs (wrf or orig mm5)
+  INTEGER , INTENT(IN) :: sfc_scheme_vert  ! vertical   spreading scheme for surf obs (orig or regime vif)
+  REAL    , INTENT(IN) :: maxsnd_gap      ! max allowed pressure gap in soundings, for interp (centibars)
+  REAL, INTENT(IN)     :: lev_in_ob(niobf)           ! Level in sounding-type obs.
+  REAL, intent(IN)     :: plfo(niobf)                ! Index for type of obs platform
+  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                      ! Model time step in minutes
+  REAL, INTENT(IN)     :: rio(niobf)                 ! Obs west-east coordinate (non-stag grid).
+  REAL, INTENT(IN)     :: rjo(niobf)                 ! Obs south-north coordinate (non-stag grid).
+  REAL, INTENT(INOUT)  :: rko(niobf)                 ! Obs vertical coordinate.
+  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)     :: msfx(ims:ime)  ! Map scale (only used for vars u & v)
+  REAL, INTENT(IN)     :: msfy(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(ims:ime)
+  INTEGER, INTENT(IN)  :: nscan                      ! number of scans
+  REAL, INTENT(IN)     :: vih1(its:ite) ! Vert infl ht (m) abv grd for full wts
+  REAL, INTENT(IN)     :: vih2(its:ite) ! Vert infl ht (m) abv grd for ramp
+  REAL, INTENT(IN)     :: terrh(ims:ime) ! Terrain height (m)
+! INTEGER, INTENT(IN)  :: vik1(its:ite) ! Vertical infl k-level for full wts
+! INTEGER, INTENT(IN)  :: vik2(its:ite) ! Vertical infl k-level for ramp
+  REAL, INTENT(IN)     :: zslab(ims:ime, kms:kme)    ! model ht above ground (m)
+  LOGICAL, INTENT(IN)  :: iprt                       ! print flag
+
+! Local variables
+  integer :: mm(maxdom)
+  integer :: kobs                  ! k-lev below obs (for obs straddling pblt)
+  integer :: kpbl_obs(nstat)       ! kpbl at grid point (IOB,JOB) (ajb 20090519)
+  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 :: wtij(ims:ime)             ! For holding weights in i-loop
+  real :: reserf(100)
+  character*40 name
+  character*3 chr_hr
+  character(len=200) :: msg            ! Argument to wrf_message
+
+!***  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,ris
+  real :: grfacx,grfacy
+  real :: timewt,pob
+  real :: ri,rj,rx,ry,rsq,pdfac,erfivr,dk,slope,rinfac
+  real :: dprim,dsq,d     ! vars for mm5 surface-ob weighting
+  real :: rinprs,pijk,pobhi,poblo,pdiffj,w2eowt,gitq
+  real :: dz_ramp         ! For ramping weights for surface obs 
+
+  real :: scratch
+  integer :: kk !ajb temp
+
+!      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) then
+        write(msg,*) 'SAVWT must be resized for NSCAN=1'
+        call wrf_message(msg)
+    ENDIF
+    call wrf_error_fatal ( 'wrf_fddaobs_in: in4dob' )
+  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
+
+  INPF=(IRATIO**LEVIDN(INEST))*NPFI
+  INFR=(IRATIO**LEVIDN(INEST))*IONF
+
+  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
+    GRIDX=0.0
+    IGRID=1
+  ELSEIF(IVAR.eq.2) THEN
+    GRIDX=0.5
+    GRIDY=0.0
+    IGRID=1
+  ENDIF
+
+! TRANSFORM THE HORIZONTAL RADIUS OF INFLUENCE, RINXY, FROM
+! KILOMETERS TO GRID LENGTHS, RINDX
+
+  RINDX=RINXY*1000./DX          * RFACTOR   !yliu *RFACTOR
+  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) then
+       write(msg,6) INEST,J,KTAU,XTIME,IVAR,IPL,rindx
+       call wrf_message(msg)
+   ENDIF
+  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)
+
+!********************************************************************
+!ajb_07012008  Setting ra and rb for the fine mesh her is now simple.
+!              Values are no longer calculated here based on the
+!              coarse mesh, since direct use of WRF map projections
+!              on each nest was implemented in subroutine in4dob.
+!********************************************************************
+! SET RA AND RB
+  DO N=1,NSTAT
+    RA(N)=RIO(N)-GRIDX
+    RB(N)=RJO(N)-GRIDY
+  ENDDO
+
+! 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).
+! ajb 05052009: psurf is actually pbase(k=1) interpolated to obs (i,j).
+  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*RINFMX+0.99)                                             !ajb
+  MINJ=J-IFIX(RINDX*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 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
+      kpbl_obs(n) = errf(5,n)   !ajb 20090519
+#endif
+!ajb 20090427 added .45 to rko so KOB is equal to 1 only if RKO > 1.05
+      KOB=nint(RKO(N)+0.45)
+      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
+
+! Compute temporal weight
+        timewt = get_timewt(xtime,dtmin,twindo,sfcfact,timeob(n))
+
+        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*sfcfacr)
+        MAXI=MIN0(ide-1,MAXI)
+        MINI=IFIX(RA(N)-RINDX*sfcfacr-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*sfcfacr/3)                        &
+        .and. RA(N).LE.float(ide)+RINDX*sfcfacr/3                  &
+        .and. RB(N).GE.(0.-RINDX*sfcfacr/3)                        &
+        .and. RB(N).LE.float(jde)+RINDX*sfcfacr/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)
+ 
+!ajb Compute and add weights to sum only if nudge_pbl switch is on.
+          if(nudge_pbl) then
+
+! Apply selected horizontal spreading scheme.
+            if(SFC_SCHEME_HORIZ.eq.1) then        ! original mm5 scheme 
+              DO I=max0(its,MINI),min0(ite,MAXI)
+                RI=FLOAT(I)
+                RY=RI-RA(N)
+                RIS=RINDX*RINDX*sfcfacr*sfcfacr
+                RSQ=RX*RX+RY*RY
+! THIS FUNCTION DECREASES WTIJ AS PSFC CHANGES WITHIN SEARCH RADIUS
+                DPRIM=SQRT(RSQ)
+                D=DPRIM+RINDX*DCON*ABS(psurf(n)-pbase(i,1))
+                DSQ=D*D
+                WTIJ(i)=(RIS-DSQ)/(RIS+DSQ)
+                WTIJ(i)=AMAX1(0.0,WTIJ(i))
+              ENDDO
+            else                                 ! wrf scheme 
+              DO I=max0(its,MINI),min0(ite,MAXI)
+                RI=FLOAT(I)
+                RY=RI-RA(N)
+                RIS=RINDX*RINDX*sfcfacr*sfcfacr
+                RSQ=RX*RX+RY*RY
+! THIS FUNCTION DECREASES WTIJ AS PSFC CHANGES WITHIN SEARCH RADIUS
+                wtij(i)=(ris-rsq)/(ris+rsq)
+                scratch = (abs (psurf(n)-.001*pbase(i,1))*DCON)
+                pdfac=1.-AMIN1(1.0,scratch)
+                wtij(i)=wtij(i)*pdfac
+                WTIJ(i)=AMAX1(0.0,WTIJ(i))
+              ENDDO
+            endif
+
+! Apply selected vertical spreading scheme.
+            if(SFC_SCHEME_VERT.eq.1) then         ! original simple scheme 
+
+              DO I=max0(its,MINI),min0(ite,MAXI)
+
+! try making sfc obs weighting go thru pbl
+                komax=max0(3,kpblt(i))
+                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(i)
+
+                  WT2ERR(I,K)=WT2ERR(I,K)+TIMEWT*TIMEWT*WTIJ(i)*WTIJ(i)*WTSIG(K)    &
+                              *WTSIG(K)*ERFIVR
+                enddo
+              ENDDO
+
+            else                                ! regime-based vif scheme
+
+! Here we calculate weights in the vertical coordinate, based on vih1 and vih2.
+! In the equation for wtsig(k), Z=zslab(i,k)-terrh(i) contains the model Z-values
+! (height above ground in meters) on a J-slab. The equation produces wtsig = 1.0 at
+! levels 1 to K, where z(K) < vih1 < z(K+1). For the example below, in the equation
+! for wtsig(k), the expression vih1(i)-Z(i,k) is strictly positive for k=1,2,3 since
+! levels 1, 2, and 3 are below vih1. So xtsig(k)=min(1.0, 1.0-x) where x > 0 ==>
+! wtsig(k)=1 for k=1,2,3.
+!
+!    For levels K+1 and up, wtsig will decrease linearly with height, with values
+! along the ramp that has value 1.0 at vih1 and 0.0 at vih2. In the example:
+!
+!   dz_ramp  = 1/(200-150) = 1/50
+!   xtsig(4) = 1 + (150-175)/50 = 1 - 1/2 = 1/2
+!
+!       WTSIG
+!         1 -|*    *     *     *     *     *
+!            |
+!            |                                *
+!            |
+!            |                                   *
+!            |
+!            |                                      *
+!         0 -|--|-------|-----------|------|----|----|---------|---->  Z = HT ABOVE
+!              15      55          115    150  175  200       250          GROUND
+!              k=1     k=2         k=3    vih1 k=4  vih2      k=5
+ 
+              DO I=max0(its,MINI),min0(ite,MAXI)
+
+                dz_ramp = 1.0 / max( 1.0, vih2(i)-vih1(i) )   ! vih2 >= vih1 by construct
+
+           LML: do k = kts, kte 
+                  wtsig(k) = min( 1.0, 1.0 + ( vih1(i)-zslab(i,k)+terrh(i) ) * dz_ramp )
+                  wtsig(k) = max( 0.0, wtsig(k))
+
+                  if(wtsig(k).le.0.0) EXIT LML
+                    WT(I,K)=WT(I,K)+TIMEWT*WTSIG(K)*WTIJ(i)
+                    WT2ERR(I,K)=WT2ERR(I,K)+TIMEWT*TIMEWT*WTIJ(i)*WTIJ(i)*WTSIG(K)    &
+                                *WTSIG(K)*ERFIVR
+                  enddo LML
+              ENDDO
+            endif
+
+          endif ! end if nudge-pbl switch is on
+
+        endif   ! end check for obs in domain
+! END SURFACE-LAYER OBS NUDGING
+
+      ELSE    
+
+! Compute temporal weight
+        timewt = get_timewt(xtime,dtmin,twindo,1.,timeob(n))
+
+
+! 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 = (RINFMN-RINFMX)/(psurf(n)-PFREE)
+
+        RINFAC=SLOPE*POB+RINFMX-SLOPE*pfree
+        RINFAC=AMAX1(RINFAC,RINFMN)
+        RINFAC=AMIN1(RINFAC,RINFMX)
+!yliu: for multilevel upper-air data, take the maximum
+!      for the I loop.
+        if(nsndlev.gt.1) RINFAC = 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
+            WTIJ(i)=(RIS-RSQ)/(RIS+RSQ)
+
+            WTIJ=AMAX1(0.0,WTIJ(i))
+! 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
+! ajb: Reset komin or komax. if kobs>kpbl_obs, komin=kpbl_obs+1, else komax=kpbl_obs  
+
+              if( (kpblt(i).le.komax) .and. (kpblt(i).ge.komin) ) then
+                 kobs = 1
+                 OBS_K: do k = komin, komax
+                     if( pob .gt. .001*(pbase(i,k)+pp(i,k)) ) then
+                        kobs = k
+                        EXIT OBS_K
+                     endif
+                 enddo OBS_K
+
+                 if(kobs.gt.kpbl_obs(n)) then
+! Obs will act only above the PBL top
+                     komin=max0(kobs, komin)   ! kobs here is kpblt(i)+1
+                 else                          ! Obs acts below PBL top
+! Obs will act only below the PBL top
+                     komax=min0(kpblt(i), komax)
+                 endif
+              endif
+! 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
+
+!ajb Add weights to sum only if nudge_pbl switch is on OR obs is above pbl top.
+              if(nudge_pbl .or. komin.ge.kpblt(i)) then
+                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(i)*wtsig(k)
+
+                  WT2ERR(I,K)=WT2ERR(I,K)+TIMEWT*TIMEWT*WTIJ(i)*WTIJ(i)*        &
+                              reserf(k)*wtsig(k)*wtsig(k)
+                enddo
+              endif
+
+            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
+                  write(msg,*) "n = ",n,"nsndlev = ",nsndlev 
+                  call wrf_message(msg)
+                  write(msg,*) "nlevs_ob,lev_in_ob",                          &
+                           nlevs_ob(n+nsndlev-1),lev_in_ob(n+nsndlev-1)
+                  call wrf_message(msg)
+                  call wrf_message("in nudobs.F: sounding level messed up, stopping")
+                ENDIF
+                call wrf_error_fatal ( 'wrf_fddaobs_in: in4dob' )
+             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 = (RINFMN-RINFMX)/(pdoc(i,j)+PTOP-PFREE)        
+                slope = (RINFMN-RINFMX)/ (.001*pbase(i,1)-PFREE)
+                RINFAC=SLOPE*pijk+RINFMX-SLOPE*PFREE              
+                RINFAC=AMAX1(RINFAC,RINFMN)      
+                RINFAC=AMIN1(RINFAC,RINFMX)
+                RIS=RINDX*RINFAC*RINDX*RINFAC  
+                RSQ=RX*RX+RY*RY               
+
+! for upper-air data, keep D1 influence radii
+                WTIJ(i)=(RIS-RSQ)/(RIS+RSQ)      
+                WTIJ(i)=AMAX1(0.0,WTIJ(i))
+! 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 200 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
+!ajb Add weights to sum only if nudge_pbl switch is on OR k > kpblt.
+                if(nudge_pbl .or. k.gt.kpblt(i)) then
+
+                  WT(I,K)=WT(I,K)+TIMEWT*WTIJ(i)*wtsig(k)
+  
+                  WT2ERR(I,K)=WT2ERR(I,K)+TIMEWT*TIMEWT*WTIJ(i)*WTIJ(i)*        &
+                              reserf(k)*wtsig(k)*wtsig(k)
+                endif
+
+              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.
+
+  IF (IVAR == 1) THEN
+     call calc_rcouple_scales(mu,msfy,rscale,ims,ime,its,ite)
+  ELSE IF (IVAR == 2) THEN
+     call calc_rcouple_scales(mu,msfx,rscale,ims,ime,its,ite)
+  END IF
+ 
+  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)
+
+!        write(6,'(a,4i4,f8.3)') 'i,j,k,ipl,W2EOWT = ',i,j,k,ipl,W2EOWT
+
+      ENDIF
+
+!      if(ivar .eq. 1 .and. i.eq.38 .and. j.eq.78 .and. k.eq.1) then
+!           scratch = GIV*RSCALE(I)*W2EOWT*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 = ',tfaci,' ISWIND = ',iswind,
+!     $               ' GFACTOR = ',gfactor
+!       endif
+!
+!      if(ivar .eq. 2 .and. i.eq.39 .and. j.eq.29) then
+!           scratch = GIV*RSCALE(I)*W2EOWT*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 = ',tfaci,' ISWIND = ',iswind,
+!     $                ' GFACTOR = ',gfactor
+!       endif
+
+!      if(ivar .eq. 1 .and. i.eq.38 .and. (j.ge.36.and.j.le.62) .and. k.eq.7) then
+!           scratch = GIV*RSCALE(I)*W2EOWT*TFACI*ISWIND*GFACTOR
+!           write(6,*)
+!           write(6,*) 'ATEN calc: j = ',j,' k = ',k
+!           write(6,*) 'U before: aten = ',aten(i,k),' scr = ',scratch
+!           write(6,*) 'GIV = ',giv,' rscale = ',rscale(i),' W2EOWT = ',w2eowt
+!           write(6,*) 'TFACI = ',tfaci,' ISWIND = ',iswind,' GFACTOR = ',gfactor
+!       endif
+
+        ATEN(i,k)=ATEN(i,k)+GIV*RSCALE(I)                        &
+                    *W2EOWT*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)
+
+!        write(6,'(a,4i4,f8.3)') 'i,j,k,ipl,savwt = ',i,j,k,ipl,savwt(ipl,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.49) then
+!            scratch = GITQ*MU(I)*W2EOWT*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 = ',tfaci,' ISTQ = ',istq,              &
+!                       ' GFACTOR = ',gfactor
+!        endif
+ 
+!        if(ivar .eq. 4 .and. i.eq.39 .and. j.eq.29) then
+!            scratch = GITQ*MU(I)*W2EOWT*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 = ',tfaci,' ISTQ = ',istq,
+!     $                 ' GFACTOR = ',gfactor
+!        endif
+
+      ATEN(i,k)=ATEN(i,k)+GITQ*MU(I)                       &
+                  *W2EOWT*TFACI*ISTQ       *GFACTOR   !yliu *GFACTOR
+
+!        if(ivar .eq. 3 .and. i.eq.39 .and. j.eq.49) 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 date_string(year, month, day, hour, minute, second, cdate)
+!-----------------------------------------------------------------------
+!  PURPOSE: Form a date string (YYYY-MM-DD_hh:mm:ss) from integer
+!           components.
+!-----------------------------------------------------------------------
+  IMPLICIT NONE
+!-----------------------------------------------------------------------
+
+  INTEGER, INTENT(IN)  :: year
+  INTEGER, INTENT(IN)  :: month
+  INTEGER, INTENT(IN)  :: day
+  INTEGER, INTENT(IN)  :: hour
+  INTEGER, INTENT(IN)  :: minute
+  INTEGER, INTENT(IN)  :: second
+  CHARACTER*19, INTENT(INOUT) :: cdate
+
+! Local variables
+  integer   :: ic                    ! loop counter
+
+      cdate(1:19)  = "0000-00-00_00:00:00"
+      write(cdate( 1: 4),'(i4)') year
+      write(cdate( 6: 7),'(i2)') month
+      write(cdate( 9:10),'(i2)') day
+      write(cdate(12:13),'(i2)') hour
+      write(cdate(15:16),'(i2)') minute
+      write(cdate(18:19),'(i2)') second
+      do ic = 1,19
+        if(cdate(ic:ic) .eq. " ") cdate(ic:ic) = "0"
+      enddo
+
+  RETURN
+  END SUBROUTINE date_string
+
+  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
+
+  SUBROUTINE print_obs_info(iprt,inest,niobf,rio,rjo,rko,                &
+                            prt_max,prt_freq,obs,stnid,lat,lon,          &
+                            mlat,mlon,timeob,xtime)
+!*************************************************************************
+! Purpose: Print obs information.
+!*************************************************************************
+
+  IMPLICIT NONE
+
+  LOGICAL, intent(in)    :: iprt          ! Print flag
+  INTEGER, intent(in)    :: inest         ! Nest level
+  INTEGER, intent(in)    :: niobf         ! Maximum number of observations
+  REAL,    intent(in)    :: rio(niobf)    ! West-east coord (non-stagger)
+  REAL,    intent(in)    :: rjo(niobf)    ! South-north coord (non-stagger)
+  REAL,    intent(in)    :: rko(niobf)    ! Bottom-top north coord (non-stagger)
+  INTEGER, intent(in)    :: prt_max        ! Max no. of obs for diagnostic printout
+  INTEGER, intent(in)    :: prt_freq       ! Frequency for diagnostic printout
+  INTEGER, intent(in)    :: obs(prt_max)  ! Saved obs indices to print
+  INTEGER, intent(in)    :: stnid(40,prt_max) ! Saved station ids
+  REAL,    intent(in)    :: lat(prt_max)  ! Saved latitudes
+  REAL,    intent(in)    :: lon(prt_max)  ! Saved longitudes
+  REAL,    intent(in)    :: mlat(prt_max) ! Saved model latitudes
+  REAL,    intent(in)    :: mlon(prt_max) ! Saved longitudes
+  REAL,    intent(in)    :: timeob(niobf) ! Times of each observation (hours)
+  REAL,    intent(in)    :: xtime         ! Model time in minutes
+
+! Local variables
+  integer :: i                    ! Loop counter over obs station chars
+  integer :: n                    ! Loop counter over obs
+  integer :: pnx                  ! Obs index for printout
+  character(len=200) :: msg       ! Argument to wrf_message
+  character(len=20)  :: station_id ! Station id of observation
+
+  if(iprt) then
+    if(prt_max.gt.0) then
+
+      if(obs(1).ne.-999) then
+
+        call wrf_message("")
+        write(msg,fmt='(a,i4,a,f8.1,a)') 'REPORTING OBS MASS-PT LOCS FOR NEST ',  &
+                                     inest,' AT XTIME=',xtime,' MINUTES'
+        call wrf_message(msg)
+
+        write(msg,fmt='(a,i4,a,i5,a)') 'FREQ=',prt_freq,', MAX=',prt_max,         &
+                           ' LOCS, NEWLY READ OBS ONLY, -999 => OBS OFF PROC'
+        call wrf_message(msg)
+        call wrf_message("")
+
+        write(msg,fmt='(3a)') '    OBS#     I       J       K     OBS LAT',       &
+                          '  OBS LON   XLAT(I,J)  XLONG(I,J)  TIME(hrs)',     &
+                          '  OBS STATION ID'
+        call wrf_message(msg)
+
+      endif
+    endif
+
+! Note: rio and rjo are referenced to non-staggered grid (not mass-point!)
+!       Hence subtract .5 from each to get mass-point coords.
+    do n=1,prt_max
+       pnx = obs(n)
+       if(pnx.ne.-999) then
+!          Retrieve 15 chars of station id
+           do i = 1,15
+              station_id(i:i) = char(stnid(i,n))
+           enddo
+           write(msg,fmt='(2x,i7,3f8.3,2f9.3,2x,f9.3,2x,f9.3,3x,f6.2,7x,a15)')    &
+               pnx,rio(pnx)-.5,rjo(pnx)-.5,rko(pnx),lat(n),lon(n),            &
+               mlat(n),mlon(n),timeob(pnx),station_id
+        call wrf_message(msg)
+       endif
+    enddo
+    if(obs(1).ne.-999) call wrf_message("")
+  endif
+  END SUBROUTINE print_obs_info
+
+  REAL FUNCTION ht_to_p( h, pbbc, ppbc, z, ic, jc, dx, dy,                    &
+                         k_start, k_end, kds,kde, ims,ime, jms,jme, kms,kme )
+
+!******************************************************************************
+! Purpose: Interpolate pressure at a specified x (ic), y (jc), and height (h).
+!          The input pressure column pbbc+ppbc (base and perturbn) must already
+!          be horizontally interpolated to the x, y position. The subroutine
+!          get_height_column is called here to horizontally interpolated the
+!          3D height field z to get a height column at (iob, job).
+!******************************************************************************
+
+  IMPLICIT NONE
+
+  REAL,    INTENT(IN)  :: h                                ! height value (m)
+  INTEGER, INTENT(IN)  :: k_start, k_end                   ! loop bounds  
+  INTEGER, INTENT(IN)  :: kds,kde                          ! vertical dim.
+  INTEGER, INTENT(IN)  :: ims,ime, jms,jme, kms,kme        ! memory dims.
+  REAL,    INTENT(IN)  :: pbbc(kds:kde)                    ! column base pressure (cb)
+  REAL,    INTENT(IN)  :: ppbc(kds:kde)                    ! column pressure perturbation (cb)
+  REAL,    INTENT(IN)  :: z( ims:ime, kms:kme, jms:jme )   ! ht (m) above sl on half-levels
+  INTEGER, INTENT(IN)  :: ic                               ! i-coord of desired p
+  INTEGER, INTENT(IN)  :: jc                               ! j-coord of desired p
+  REAL,    INTENT(IN)  :: dx                               ! interp. fraction (x dir)
+  REAL,    INTENT(IN)  :: dy                               ! interp. fraction (y dir)
+
+! Local variables
+  INTEGER :: k               ! loop counter
+  INTEGER :: klo             ! lower k bound
+  REAL :: zlo                ! lower z bound for h
+  REAL :: zhi                ! upper z bound for h
+  REAL :: p                  ! interpolated pressure value
+  REAL :: ln_p               ! log p
+  REAL :: ln_plo             ! log plo
+  REAL :: ln_phi             ! log phi
+  REAL :: z_at_p( kms:kme )  ! height at p levels
+
+! Get interpolated z column on pressure (half-) levels at (ic,jc)
+  call get_height_column(z, ic, jc, dx, dy, z_at_p,                   &
+                         k_start, k_end, kds,kde,                     &
+                         ims,ime, jms,jme, kms,kme )
+
+! Now we have pbbc, ppbc, z_at_p, so compute p at h. First, find
+! bounding layers klo and khi so that z_at_p(klo) <= h <= z_at_p(khi)
+
+  ZLEVS: do k = k_start+1, k_end
+    klo = k-1
+    if(h .le. z_at_p(k)) then
+      EXIT ZLEVS
+    endif
+  enddo ZLEVS
+
+  zlo = z_at_p(klo)
+  zhi = z_at_p(klo+1)
+
+! Interpolate natural log of pressure
+  ln_plo = log( pbbc(klo+1) + ppbc(klo+1) )
+  ln_phi = log( pbbc(klo) + ppbc(klo) )
+  if(h.le.zlo) then
+    ln_p = ln_phi     ! set to k=1 pressure 
+  else if (h.ge.zhi) then
+    ln_p = ln_plo     ! set to k=k_end pressure 
+  else
+    ln_p = ln_plo + (ln_phi-ln_plo)*((zhi-h)/(zhi-zlo)) 
+  endif
+
+! Return pressure
+  p = exp(ln_p)
+  ht_to_p = p
+  RETURN
+  END FUNCTION ht_to_p
+
+  SUBROUTINE get_height_column( z, ic, jc, dx, dy, z_at_p,                  &
+                                k_start, k_end, kds,kde,                    &
+                                ims,ime, jms,jme, kms,kme )
+!*************************************************************************
+! Purpose: Compute column height at ic, jc location on p levels
+!*************************************************************************
+
+  IMPLICIT NONE
+
+  INTEGER, INTENT(IN)  :: k_start, k_end                   ! Loop bounds  
+  INTEGER, INTENT(IN)  :: kds,kde                          ! vertical dim.
+  INTEGER, INTENT(IN)  :: ims,ime, jms,jme, kms,kme        ! memory dims.
+  REAL,    INTENT(IN)  :: z( ims:ime, kms:kme, jms:jme )   ! ht (m) on half-levels
+  INTEGER, INTENT(IN)  :: ic                               ! i-coord of desired p
+  INTEGER, INTENT(IN)  :: jc                               ! j-coord of desired p
+  REAL,    INTENT(IN)  :: dx                               ! interp. fraction (x dir)
+  REAL,    INTENT(IN)  :: dy                               ! interp. fraction (y dir)
+  REAL,    INTENT(OUT) :: z_at_p( kms:kme )                ! column height at p levels
+
+! Local variables
+  INTEGER :: k             ! loop counter
+
+
+  do k = kds, kde
+      z_at_p(k) =                                     & 
+         (1.-DY)*( (1.-DX)*z(IC,K,JC) +               &
+                            DX *z(IC+1,K,JC) ) +      &
+             DY* ( (1.-DX)*z(IC,K,JC+1) +             &
+                            DX *z(IC+1,K,JC+1) )
+  enddo
+
+  END SUBROUTINE get_height_column
+
+  SUBROUTINE get_base_state_height_column( p_top, p00, t00, a, g, r_d,    &
+                               znu, z_at_p,  k_start, k_end, kds,kde, kms,kme )
+!********************************************************
+! Purpose: Compute base-state column height on p levels.
+!    See, e.g., eqns 1.3-1.5 in MM5 User's Guide.
+!    Height is a function of pressure plus the constants:
+!    p00  - sea level pressure (Pa)
+!    t00  - sea level temperature (K)
+!    a    - base state lapse rate (k/m)
+!    r_d  - gas constant (J/Kg/K)   (Joule=1kg/m**2/s**2)
+!    g    - gravitational constant (m/s**2)
+!********************************************************
+
+  IMPLICIT NONE
+
+  REAL, INTENT(IN)     :: p_top        ! pressure at top of model
+  REAL, INTENT(IN)     :: p00          ! base state pressure
+  REAL, INTENT(IN)     :: t00          ! base state temperature
+  REAL, INTENT(IN)     :: a            ! base state lapse rate
+  REAL, INTENT(IN)     :: g                ! gravity constant
+  REAL, INTENT(IN)     :: r_d              ! gas constant
+  INTEGER, INTENT(IN)  :: k_start, k_end   ! Loop bounds  
+  INTEGER, INTENT(IN)  :: kds,kde          ! vertical dim.
+  INTEGER, INTENT(IN)  :: kms,kme          ! vertical memory dim.
+  REAL, INTENT(IN)  :: znu( kms:kme )      ! eta values on half (mass) levels
+  REAL, INTENT(OUT) :: z_at_p( kms:kme )   ! column height at p levels
+
+! Local variables
+  integer :: k             ! loop counter
+  real    :: ps0           ! base state pressure at surface
+  real    :: pb(kms:kme)   ! pressure on half eta levels
+  real    :: logterm       ! temporary for Z calculation 
+  real    :: ginv          ! 1/g
+  
+  ginv = 1/g
+
+! Compute base state pressure on half eta levels.
+   do k = k_start, k_end
+     pb(k) = znu(k)*(p00 - p_top) + p_top
+   enddo
+
+! Use hydrostatic relation to compute height at pressure levels.
+   do k = k_start, k_end
+     logterm = log(pb(k)/p00)
+     z_at_p(k) = .5*r_d*a*ginv*logterm*logterm - r_d*t00*ginv*logterm
+   enddo
+
+  END SUBROUTINE get_base_state_height_column
+
+  REAL FUNCTION get_timewt(xtime,dtmin,twindo,scalef,obtime)
+!*************************************************************************
+! Purpose: Compute the temporal weight factor for an observation
+!*************************************************************************
+
+  IMPLICIT NONE
+
+  REAL, INTENT(IN)  :: xtime              ! model time (minutes)
+  REAL, INTENT(IN)  :: dtmin              ! model timestep (minutes)
+  REAL, INTENT(IN)  :: twindo             ! half window (hours)
+  REAL, INTENT(IN)  :: scalef             ! window scale factor
+  REAL, INTENT(IN)  :: obtime             ! observation time (hours)
+
+! Local variables
+  real :: fdtim            ! reference time (minutes)
+  real :: tw1              ! half of twindo, scaled, in minutes
+  real :: tw2              ! twindo, scaled, in minutes
+  real :: tconst           ! reciprical of tw1
+  real :: ttim             ! obtime in minutes
+  real :: dift             ! | fdtim-ttim |
+  real :: timewt           ! returned weight
+
+! DETERMINE THE TIME-WEIGHT FACTOR FOR N
+  FDTIM=XTIME-DTMIN
+! TWINDO IS IN MINUTES:
+  TW1=TWINDO/2.*60.*scalef
+  TW2=TWINDO*60.*scalef
+  TCONST=1./TW1
+  TIMEWT=0.0
+  TTIM=obtime*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
+  get_timewt = timewt
+  END FUNCTION get_timewt
+
+  SUBROUTINE print_vif_var(var, vif, nfullmin, nrampmin )
+!********************************************************
+! Purpose: Print a description of the vertical influence
+!          function for a given variable.
+!********************************************************
+  IMPLICIT NONE
+
+  character(len=4), intent(in)  :: var      ! Variable (wind, temp, mois)
+  real,             intent(in)  :: vif(6)   ! Vertical influence function
+  real,             intent(in)  :: nfullmin ! Vert infl fcn full nudge min
+  real,             intent(in)  :: nrampmin ! Vert infl fcn ramp decr min
+
+! Local variables
+  character(len=200) :: msg1, msg2
+  character(len=8) :: regime
+  real :: nfullr1, nrampr1
+  real :: nfullr2, nrampr2
+  real :: nfullr4, nrampr4
+
+  nfullr1 = vif(1)
+  nrampr1 = vif(2)
+  nfullr2 = vif(3)
+  nrampr2 = vif(4)
+  nfullr4 = vif(5)
+  nrampr4 = vif(6)
+
+  if(var.eq.'wind') then
+    write(msg1,fmt='(a)') '  For winds:'
+  elseif (var.eq.'temp') then
+    write(msg1,fmt='(a)') '  For temperature:'
+  elseif (var.eq.'mois') then
+    write(msg1,fmt='(a)') '  For moisture:'
+  else
+    write(msg1,fmt='(a,a4)') 'Unknown variable type: ',var
+    call wrf_message(msg1)
+    call wrf_error_fatal ( 'print_vif_var: module_fddaobs_rtfdda STOP' )
+  endif
+      
+  call wrf_message(msg1)
+
+! For this variable, print a description of the vif for each regime 
+  call print_vif_regime(1, nfullr1, nrampr1, nfullmin, nrampmin) 
+  call print_vif_regime(2, nfullr2, nrampr2, nfullmin, nrampmin) 
+  call print_vif_regime(4, nfullr4, nrampr4, nfullmin, nrampmin) 
+
+  END SUBROUTINE print_vif_var
+
+  SUBROUTINE print_vif_regime(reg, nfullr, nrampr, nfullmin, nrampmin )
+!********************************************************
+! Purpose: Print a description of the vertical influence
+!          function for a given regime.
+!********************************************************
+  IMPLICIT NONE
+
+  integer, intent(in)  :: reg          ! Regime number (1, 2, 4)
+  real,    intent(in)  :: nfullr       ! Full nudge range for regime
+  real,    intent(in)  :: nrampr       ! Rampdown range for regime
+  real,    intent(in)  :: nfullmin     ! Vert infl fcn full nudge min
+  real,    intent(in)  :: nrampmin     ! Vert infl fcn ramp decr min
+
+! Local variables
+  character(len=200) :: msg1, msg2
+  character(len=8) :: regime
+
+  if(reg.eq.1) then
+     write(regime,fmt='(a)') 'Regime 1'
+  elseif (reg.eq.2) then
+     write(regime,fmt='(a)') 'Regime 2'
+  elseif (reg.eq.4) then
+     write(regime,fmt='(a)') 'Regime 4'
+  else
+     write(msg1,fmt='(a,i3)') 'Unknown regime number: ',reg
+     call wrf_message(msg1)
+     call wrf_error_fatal ( 'print_vif_regime: module_fddaobs_rtfdda STOP' )
+  endif
+
+!Set msg1 for description of full weighting range
+  if(nfullr.lt.0) then
+     if(nfullr.eq.-5000) then
+       write(msg1,fmt='(2x,a8,a)') regime, ': Full weighting to the PBL top'
+     elseif (nfullr.lt.-5000) then
+       write(msg1,fmt='(2x,a8,a,i4,a)') regime, ': Full weighting to ',int(-5000.-nfullr), &
+                                          ' m above the PBL top'
+     else
+       write(msg1,fmt='(2x,a8,a,i4,a)') regime, ': Full weighting to ',int(nfullr+5000.),  &
+                                          ' m below the PBL top'
+     endif
+  else
+     write(msg1,fmt='(2x,a8,a,i4,a)') regime, ': Full weighting through ',                 &
+                                     int(max(nfullr,nfullmin)),' m'
+  endif
+
+!Set msg2 for description of rampdown range
+  if(nrampr.lt.0) then
+     if(nrampr.eq.-5000) then
+       write(msg2,fmt='(a)') ' and a vertical rampdown up to the PBL top.'
+     elseif (nrampr.lt.-5000) then
+       write(msg2,fmt='(a,i4,a)') ' and a vertical rampdown to ',int(-5000.-nrampr),    &
+                            ' m above the PBL top.'
+     else
+       write(msg2,fmt='(a,i4,a)') ' and a vertical rampdown to ',int(nrampr+5000.),     &
+                            ' m below the PBL top.'
+     endif
+  else
+     write(msg2,fmt='(a,i4,a)') ' and a vertical rampdown in the next ',                &
+                          int(max(nrampr,nrampmin)),' m.'
+  endif
+  call wrf_message(TRIM(msg1)//msg2)
+
+  END SUBROUTINE print_vif_regime
+#endif
+
+END MODULE module_fddaobs_rtfdda
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_atm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_atm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_atm.F	(revision 17)
@@ -0,0 +1,175 @@
+!WRF:MEDIATION_LAYER:FIRE_MODEL
+! Routines dealing with the atmosphere
+
+module module_fr_sfire_atm
+
+use module_model_constants, only: cp,xlv
+use module_fr_sfire_util
+
+contains
+
+SUBROUTINE fire_tendency( &
+    ids,ide, kds,kde, jds,jde,   & ! dimensions
+    ims,ime, kms,kme, jms,jme,   &
+    its,ite, kts,kte, jts,jte,   &
+    grnhfx,grnqfx,canhfx,canqfx, & ! heat fluxes summed up to  atm grid 
+    alfg,alfc,z1can,             & ! coeffients, properties, geometry 
+    zs,z_at_w,dz8w,mu,rho,       &
+    rthfrten,rqvfrten)             ! theta and Qv tendencies 
+
+! This routine is atmospheric physics 
+! it does NOT go into module_fr_sfire_phys because it is not related to fire physical processes
+
+! --- 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 surface 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
+   REAL :: fact_g, fact_c
+   REAL :: alfg_i, alfc_i
+
+   REAL, DIMENSION( its:ite,kts:kte,jts:jte ) :: hfx,qfx
+   
+!!   character(len=128)::msg
+
+        do j=jts,jte
+            do k=kts,min(kte+1,kde)
+               do i=its,ite
+                   rthfrten(i,k,j)=0.
+                   rqvfrten(i,k,j)=0.
+               enddo
+            enddo
+        enddo
+
+
+! --- set some local constants
+   
+
+   cp_i = 1./cp     ! inverse of specific heat
+   xlv_i = 1./xlv   ! inverse of latent heat
+   alfg_i = 1./alfg
+   alfc_i = 1./alfc
+
+!!write(msg,'(8e11.3)')cp,cp_i,xlv,xlv_i,alfg,alfc,z1can
+!!call message(msg)
+
+   call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme,grnhfx,'fire_tendency:grnhfx')
+   call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme,grnqfx,'fire_tendency:grnqfx')
+
+! --- 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_i * z_w )
+            IF ( z_w < z1can ) THEN
+               fact_c = cp_i
+            ELSE
+               fact_c = cp_i * EXP( - alfc_i * (z_w - z1can) )
+            END IF
+            hfx(i,k,j) = fact_g * grnhfx(i,j) + fact_c * canhfx(i,j) 
+
+!!            write(msg,2)i,k,j,z_w,grnhfx(i,j),hfx(i,k,j)
+!!2           format('hfx:',3i4,6e11.3)
+!!            call message(msg)
+
+            ! --- vapor flux
+
+            fact_g = xlv_i * EXP( - alfg_i * z_w )
+            IF (z_w < z1can) THEN
+               fact_c = xlv_i
+            ELSE
+               fact_c = xlv_i * EXP( - alfc_i * (z_w - z1can) )
+            END IF
+            qfx(i,k,j) = fact_g * grnqfx(i,j) + fact_c * canqfx(i,j) 
+            
+!!            if(hfx(i,k,j).ne.0. .or. qfx(i,k,j) .ne. 0.)then
+!!                write(msg,1)i,k,j,hfx(i,k,j),qfx(i,k,j)
+!!1               format('tend:',3i6,2e11.3)
+!!                call message(msg)
+!            endif
+
+         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
+
+   call print_3d_stats(its,ite,kts,kte,jts,jte,ims,ime,kms,kme,jms,jme,rthfrten,'fire_tendency:rthfrten')
+   call print_3d_stats(its,ite,kts,kte,jts,jte,ims,ime,kms,kme,jms,jme,rqvfrten,'fire_tendency:rqvfrten')
+
+   RETURN
+
+END SUBROUTINE fire_tendency
+
+!
+!***
+!
+
+end module module_fr_sfire_atm
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_core.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_core.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_core.F	(revision 17)
@@ -0,0 +1,1939 @@
+!
+#define DEBUG_OUT
+#define DEBUG_PRINT
+!#define FUEL_LEFT
+!#define DEBUG_OUT_FUEL_LEFT    
+
+module module_fr_sfire_core
+
+use module_fr_sfire_phys, only: fire_params , fire_ros
+use module_fr_sfire_util
+
+! The mathematical core of the fire spread model. No physical constants here.
+! 
+! subroutine sfire_core: only this routine should be called from the outside.
+! subroutine fuel_left:  compute remaining fuel from time of ignition.
+! subroutine prop_ls: propagation of curve in normal direction.
+
+! describe one ignition line
+type ignition_line_type
+  REAL  ros, &          ! subscale rate of spread during the ignition process
+        stop_time, &    ! when the ignition process stops from ignition start (s)
+        wind_red,  &    ! wind reduction factor at the ignition line
+        wrdist,   &     ! distance from the ignition line when the wind reduction stops
+        wrupwind, &     ! use distance interpolated between 0. = nearest 1. = upwind
+        start_x, &      ! x coordinate of the ignition line start point (m, or long/lat)
+        start_y, &      ! y coordinate of the ignition line start point
+        end_x, &        ! x coordinate of the ignition line end point
+        end_y, &        ! y coordinate of the ignition line end point
+        start_time, &   ! ignition time for the start point from simulation start (s)
+        end_time, &     ! ignition time for the end poin from simulation start (s)
+        radius          ! all within this radius ignites immediately
+end type ignition_line_type
+
+contains
+
+!
+!****************************************
+!
+    
+subroutine init_no_fire(&
+    ifds,ifde,jfds,jfde, &
+    ifms,ifme,jfms,jfme, &
+    ifts,ifte,jfts,jfte, &
+    fdx,fdy,time_now,    & ! scalars in
+    fuel_frac,fire_area,lfn,tign)    ! arrays out            
+implicit none
+             
+!*** purpose: initialize model to no fire
+
+!*** arguments
+integer, intent(in):: ifds,ifde,jfds,jfde   ! fire domain bounds
+integer, intent(in):: ifts,ifte,jfts,jfte   ! fire tile bounds
+integer, intent(in):: ifms,ifme,jfms,jfme   ! array bounds
+real, intent(in) :: fdx,fdy,time_now        ! mesh spacing, time
+real, intent(out), dimension (ifms:ifme,jfms:jfme) :: & 
+                   fuel_frac,fire_area,lfn,tign       ! model state
+
+!*** calls
+intrinsic epsilon
+                                                
+!*** local
+integer:: i,j
+real lfn_init,time_init
+
+lfn_init = 2*max((ifde-ifds+1)*fdx,(jfde-jfds+1)*fdy)      ! more than domain diameter
+time_init=time_now + max(time_now,1.0)*epsilon(time_now) ! a bit in future
+ 
+do j=jfts,jfte
+    do i=ifts,ifte
+        fuel_frac(i,j)=1.          ! fuel at start is 1 by definition
+        fire_area(i,j)=0.          ! nothing burning
+        tign(i,j) = time_init      ! ignition in future
+        lfn(i,j) = lfn_init        ! no fire 
+    enddo
+enddo
+call message('init_no_fire: state set to no fire')
+
+end subroutine init_no_fire
+
+!
+!******************
+!
+ 
+
+subroutine ignite_fire( ifds,ifde,jfds,jfde,                    & ! fire domain dims - the whole domain
+                        ifms,ifme,jfms,jfme,                      &
+                        ifts,ifte,jfts,jfte,                      &
+                        ignition_line,                            &
+                        start_ts,end_ts,                    &
+                        coord_xf,coord_yf,                &     
+                        unit_xf,unit_yf,                  &
+                        lfn,tign,ignited)
+implicit none
+
+!*** purpose: ignite a circular/line fire 
+
+!*** description
+! ignite fire in the region within radius r from the line (sx,sy) to (ex,ey).
+! the coordinates of nodes are given as the arrays coord_xf and coord_yf
+! r is given in m
+! one unit of coord_xf is unit_xf m 
+! one unit of coord_yf is unit_yf m 
+! so a node (i,j) will be ignited iff for some (x,y) on the line
+! || ( (coord_xf(i,j) - x)*unit_xf , (coord_yf(i,j) - y)*unit_yf ) || <= r 
+
+
+!*** arguments
+integer, intent(in):: ifds,ifde,jfds,jfde   ! fire domain bounds
+integer, intent(in):: ifts,ifte,jfts,jfte   ! fire tile bounds
+integer, intent(in):: ifms,ifme,jfms,jfme   ! array bounds
+type(ignition_line_type), intent(in):: ignition_line    ! description of the ignition line
+real, intent(in):: start_ts,end_ts          ! the time step start and end 
+real, dimension(ifms:ifme, jfms:jfme), intent(in):: & 
+    coord_xf,coord_yf                       !  node coordinates  
+real, intent(in):: unit_xf,unit_yf          !  coordinate units in m
+real, intent(inout), dimension (ifms:ifme,jfms:jfme) :: & 
+                   lfn, tign                ! level function, ignition time (state)
+integer, intent(out):: ignited              ! number of nodes newly ignited
+                        
+!*** local
+integer:: i,j
+real::lfn_new,time_ign,ax,ay,rels,rele,d
+real:: sx,sy                    ! start of ignition line, from lower left corner
+real:: ex,ey                    ! end of ignition line, or zero
+real:: st,et                    ! start and end of time of the ignition line
+character(len=128):: msg
+real::cx2,cy2,dmax,axmin,axmax,aymin,aymax,dmin
+real:: start_x,start_y          ! start of ignition line, from lower left corner
+real:: end_x,end_y              ! end of ignition line, or zero
+real:: radius                   ! all within the radius of the line will ignite
+real:: start_time,end_time      ! the ignition time for the start and the end of the line
+real:: ros,tos                  ! ignition rate and time of spread
+
+!*** executable
+
+! copy ignition line fields to local variables
+start_x    = ignition_line%start_x ! x coordinate of the ignition line start point (m, or long/lat)
+start_y    = ignition_line%start_y ! y coordinate of the ignition line start point
+end_x      = ignition_line%end_x   ! x coordinate of the ignition line end point
+end_y      = ignition_line%end_y   ! y coordinate of the ignition line end point
+start_time = ignition_line%start_time ! ignition time for the start point from simulation start (s)
+end_time   = ignition_line%end_time! ignition time for the end poin from simulation start (s)
+radius     = ignition_line%radius  ! all within this radius ignites immediately
+ros        = ignition_line%ros     ! rate of spread
+
+
+tos        = radius/ros            ! time of spread to the given radius
+st         = start_time            ! the start time of ignition considered in this time step
+et         = min(end_ts,end_time)  ! the end time of the ignition segment in this time step
+
+! this should be called whenever (start_ts, end_ts) \subset (start_time, end_time + tos) 
+if(start_ts>et+tos .or. end_ts<st)return   ! too late or too early, nothing to do
+
+if(start_time < end_time)then  ! we really want to test start_time .ne. end_time, but avoiding test of floats on equality
+        ! segment of nonzero length
+        !rels =  (st - start_time) / (end_time - start_time)  ! relative position of st in the segment (start,end)
+	!sx = start_x + rels * (end_x - start_x)
+	!sy = start_y + rels * (end_y - start_y)
+        rels = 0.
+        sx = start_x
+        sy = start_y
+        rele =  (et - start_time) / (end_time - start_time)    ! relative position of et in the segment (start,end)
+	ex = start_x + rele * (end_x - start_x)
+	ey = start_y + rele * (end_y - start_y)
+else
+        ! just a point
+        rels = 0.
+        rele = 1.
+	sx = start_x
+	sy = start_y
+	ex = end_x
+	ey = end_y
+endif
+
+
+cx2=unit_xf*unit_xf
+cy2=unit_yf*unit_yf
+
+axmin=coord_xf(ifts,jfts)
+aymin=coord_yf(ifts,jfts)
+axmax=coord_xf(ifte,jfte)
+aymax=coord_yf(ifte,jfte)
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+write(msg,'(a,2f11.6,a,2f11.6)')'IGN from ',sx,sy,' to ',ex,ey
+call message(msg)
+write(msg,'(a,2f10.2,a,2f10.2,a)')'IGN timestep [',start_ts,end_ts,'] in [',start_time,end_time,']'
+call message(msg)
+write(msg,'(a,2g13.6,a,2g13.6)')'IGN tile coord from  ',axmin,aymin,' to ',axmax,aymax
+call message(msg)
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+ignited=0
+dmax=0
+dmin=huge(dmax)
+11      format('IGN ',6(a,g17.7,1x)) 
+12      format('IGN ',4(a,2g13.7,1x))
+do j=jfts,jfte   
+    do i=ifts,ifte
+        ax=coord_xf(i,j)
+        ay=coord_yf(i,j)
+
+        ! get d= distance from the nearest point on the ignition segment
+        ! and time_ign = the ignition time there
+        call nearest(d,time_ign,ax,ay,sx,sy,st,ex,ey,et,cx2,cy2)
+        dmax=max(d,dmax)
+        dmin=min(d,dmin)
+
+        lfn_new=d - min( radius, ros*(end_ts - time_ign) )  ! lft at end_ts
+        if(fire_print_msg.ge.3)then
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+            write(msg,*)'IGN1 i,j=',i,j,' lfn(i,j)=',lfn(i,j),' tign(i,j)=',tign(i,j)
+            call message(msg)
+            write(msg,*)'IGN2 i,j=',i,j,' lfn_new= ',lfn_new, ' time_ign= ',time_ign,' d=',d
+            call message(msg)
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+        endif
+        if(.not.lfn_new>0.) then
+            ignited=ignited+1   ! count
+        endif
+        if(lfn(i,j)>0. .and. .not. lfn_new > 0.) then
+            tign(i,j)=time_ign + d/ros  ! newly ignited now
+            if(fire_print_msg.ge.3)then
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+                write(msg,'(a,2i6,a,2g13.6,a,f10.2,a,2f10.2,a)')'IGN ignited cell ',i,j,' at',ax,ay, &
+                    ' time',tign(i,j),' in [',start_ts,end_ts,']'
+                call message(msg)
+                write(msg,'(a,g10.3,a,f10.2,a,2f10.2,a)')'IGN distance',d,' from ignition line at',time_ign,' in [',st,et,']'
+                call message(msg)
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+            endif
+            if(tign(i,j) < start_ts .or. tign(i,j) > end_ts )then
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+                write(msg,'(a,2i6,a,f11.6,a,2f11.6,a)')'WARNING ',i,j, &
+                ' fixing ignition time ',tign(i,j),' outside of the time step [',start_ts,end_ts,']'
+                call message (msg)
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+                tign(i,j) = min(max(tign(i,j),start_ts),end_ts)
+            endif
+        endif
+        lfn(i,j)=min(lfn(i,j),lfn_new)  ! update the level set function
+        if(fire_print_msg.ge.3)then
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+            write(msg,*)'IGN3 i,j=',i,j,' lfn(i,j)=',lfn(i,j),' tign(i,j)=',tign(i,j)
+            call message(msg)
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+        endif
+    enddo
+enddo
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+write(msg,'(a,2g13.2,a,g10.2,a,g10.2)')'IGN units ',unit_xf,unit_yf,' m max dist ',dmax,' min',dmin
+call message(msg)
+write(msg,'(a,f6.1,a,f8.1,a,i10)')'IGN radius ',radius,' time of spread',tos,' ignited nodes',ignited
+call message(msg)
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+
+return
+99 continue
+
+end subroutine ignite_fire
+
+! called from the inside of a loop, inline if possible
+!DEC$ ATTRIBUTES FORCEINLINE
+SUBROUTINE nearest(d,t,ax,ay,sx,sy,st,ex,ey,et,cx2,cy2)
+        implicit none
+!***    arguments
+        real, intent(out):: d,t
+        real, intent(in):: ax,ay,sx,sy,st,ex,ey,et,cx2,cy2
+        ! input:
+        ! ax, ay       coordinates of point a
+        ! sx,sy,ex,ey  coordinates of endpoints of segment [x,y]
+        ! st,et        values at the endpoints x,y
+        ! cx2,cy2      x and y unit squared for computing distance 
+
+        ! output
+        ! d            the distance of a and the nearest point z on the segment [x,y]
+        ! t            linear interpolation from the values st,et to the point z
+        !
+        ! method: compute d as the distance (ax,ay) from the midpoint (mx,my)
+        ! minus a correction (because of rounding errors): |a-c|^2 = |a-m|^2 - |m-c|^2
+        ! when |m-c| >= |s-e|/2 the nearest point is one of the endpoints
+        ! the computation work also for the case when s=e exactly or approximately 
+        !
+        !
+        !           a    
+        !          /| \
+        !     s---m-c--e
+        !
+        ! |m-c| = |a-m| cos (a-m,e-s) 
+        !       = |a-m| (a-m).(e-s))/(|a-m|*|e-s|)
+!***    local
+        real:: mx,my,dam2,dames,am_es,cos2,dmc2,mcrel,mid_t,dif_t,des2,cx,cy
+        character(len=128):: msg
+!***    executable
+
+11      format('IGN ',6(a,g17.7,1x))
+12      format('IGN ',4(a,2g13.7,1x))
+
+        ! midpoint m = (mx,my)
+        mx = (sx + ex)*0.5
+        my = (sy + ey)*0.5
+        dam2=(ax-mx)*(ax-mx)*cx2+(ay-my)*(ay-my)*cy2      ! |a-m|^2
+        des2 = (ex-sx)*(ex-sx)*cx2+(ey-sy)*(ey-sy)*cy2          ! des2 = |e-s|^2
+        dames = dam2*des2
+        am_es=(ax-mx)*(ex-sx)*cx2+(ay-my)*(ey-sy)*cy2       ! am_es = (a-m).(e-s)
+        if(dames>0)then
+            cos2 = (am_es*am_es)/dames                  ! cos2 = cos^2 (a-m,e-s)
+        else ! point a already is the midpoint
+            cos2 = 0.
+        endif
+        dmc2 = dam2*cos2                                ! dmc2 = |m-c|^2
+        if(4.*dmc2 < des2)then                          ! if |m-c|<=|e-s|/2
+            ! d = sqrt(max(dam2 - dmc2,0.))               ! d=|a-m|^2 - |m-c|^2, guard rounding
+            mcrel = sign(sqrt(4.*dmc2/des2),am_es)      ! relative distance of c from m 
+        elseif(am_es>0)then                             ! if cos > 0, closest is e
+            mcrel = 1.0 
+        else                                            ! closest is s
+            mcrel = -1.0
+        endif
+	cx = (ex + sx)*0.5 + mcrel*(ex - sx)*0.5     ! interpolate to c by going from m
+	cy = (ey + sy)*0.5 + mcrel*(ey - sy)*0.5     ! interpolate to c by going from m
+        d=sqrt((ax-cx)*(ax-cx)*cx2+(ay-cy)*(ay-cy)*cy2) ! |a-c|^2
+	t = (et + st)*0.5 + mcrel*(et - st)*0.5     ! interpolate to c by going from m
+        if(fire_print_msg.ge.3)then
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+            write(msg,12)'find nearest to [',ax,ay,'] from [',sx,sy,'] [',ex,ey,']' ! DEB
+            call message(msg)
+            write(msg,12)'end times',st,et,' scale squared',cx2,cy2 ! DEB
+            call message(msg)
+            write(msg,11)'nearest at mcrel=',mcrel,'from the midpoint, t=',t ! DEB
+            call message(msg)
+            write(msg,12)'nearest is [',cx,cy,'] d=',d ! DEB
+            call message(msg)
+            write(msg,11)'dam2=',dam2,'des2=',des2,'dames=',dames
+            call message(msg)
+            write(msg,11)'am_es=',am_es,'cos2=',cos2,'dmc2=',dmc2 ! DEB
+            call message(msg)
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+        endif
+END SUBROUTINE nearest
+
+
+!
+!**********************
+!            
+
+subroutine fuel_left(&
+    ims,ime,jms,jme, &
+    its,ite,jts,jte, &
+    ifs,ife,jfs,jfe, &
+    lfn, tign, fuel_time, time_now, fuel_frac, fire_area)
+implicit none
+
+!*** purpose: determine fraction of fuel remaining
+!*** NOTE: because variables are cell centered, need halo/sync width 1 before
+
+!*** arguments
+
+integer, intent(in) :: its,ite,jts,jte,ims,ime,jms,jme,ifs,ife,jfs,jfe
+real, intent(in), dimension(ims:ime,jms:jme)::lfn,tign,fuel_time
+real, intent(in):: time_now
+real, intent(out), dimension(ifs:ife,jfs:jfe)::fuel_frac
+real, intent(out), dimension(ims:ime,jms:jme):: fire_area
+
+! ims,ime,jms,jme   in   memory dimensions
+! its,ite,jts,jte   in   tile dimensions (cells where fuel_frac computed)
+! ifs,ife,jfs,jfe   in   fuel_frac memory dimensions
+! lfn               in   level function, at nodes at midpoints of cells
+! tign              in   ignition time, at nodes at nodes at midpoints of cells
+! fuel_time         in   time constant of fuel, per cell
+! time_now          in   time now
+! fuel_frac         out  fraction of fuel remaining, per cell
+! fire_area         out  fraction of cell area on fire
+
+!*** local
+
+integer::i,j,ir,jr,icl,jcl,isubcl,jsubcl,i2,j2,ii,jj
+real::fmax,frat,helpsum1,helpsum2,fuel_left_ff,fire_area_ff,rx,ry,tignf(2,2)
+! help variables instead of arrays fuel_left_f and fire_area_f 
+real::lffij,lffi1j,lffij1,lffi1j1,tifij,tifi1j,tifij1,tifi1j1,tx,ty,txx,tyy
+! variables for calculation instead of lff(i,j) and tif(i,j)is lffij,tifij etc..#define IFCELLS (ite-its+1)*fuel_left_irl
+#define JFCELLS (jte-jts+1)*fuel_left_jrl
+character(len=128)::msg
+integer::m,omp_get_thread_num
+     
+
+call check_mesh_2dim(its-1,ite+1,jts-1,jte+1,ims,ime,jms,jme)
+call check_mesh_2dim(its,ite,jts,jte,ifs,ife,jfs,jfe)
+
+! refinement
+ir=fuel_left_irl
+jr=fuel_left_jrl
+
+if ((ir.ne.2).or.(jr.ne.2)) then 
+   call crash('fuel_left: ir.ne.2 or jr.ne.2 ')
+endif
+
+rx=1./ir 
+ry=1./jr
+
+! interpolate level set function to finer grid
+#ifdef DEBUG_OUT_FUEL_LEFT    
+    call write_array_m(1,IFCELLS+1,1,JFCELLS+1,1,IFCELLS+1,1,JFCELLS+1,lff,'lff',0)
+    call write_array_m(1,IFCELLS+1,1,JFCELLS+1,1,IFCELLS+1,1,JFCELLS+1,tif,'tif',0)
+#endif
+
+!
+! example for ir=2:
+!
+!                     |      coarse cell      |
+!      its-1                     its                                   ite             ite+1
+! -------X------------|-----.-----X-----.-----|--........----|----------X----------|---------X
+!           fine node 1           2           3                   2*(ite-its+1) 
+!                fine cell  1           2                             cell 2*(ite-its+1)
+
+
+
+!  Loop over cells in Tile 
+!  Changes made by Volodymyr Kondratenko 09/24/2009
+do icl=its,ite
+  do jcl=jts,jte
+    helpsum1=0
+    helpsum2=0
+!   Loop over subcells in cell #(icl,jcl)
+    do isubcl=1,ir
+      do jsubcl=1,jr 
+        i=(icl-its)*ir+isubcl
+        j=(jcl-jts)*jr+jsubcl
+
+!       Direct calculation tif and lff, avoiding arrays, just for case ir=jr=2
+        if ((isubcl.eq.1).and.(jsubcl.eq.1)) then
+           i2=icl-1
+           j2=jcl-1
+           ty=0.5
+           tx=0.5
+           tyy=1.0
+           txx=1.0
+        else if ((isubcl.eq.2).and.(jsubcl.eq.1)) then
+           i2=icl
+           j2=jcl-1
+           ty=0.5
+           tx=0
+           tyy=1.0
+           txx=0.5
+        else if ((isubcl.eq.1).and.(jsubcl.eq.2)) then
+           i2=icl-1
+           j2=jcl
+           tx=0.5
+           ty=0
+           txx=1.0
+           tyy=0.5
+        else if ((isubcl.eq.2).and.(jsubcl.eq.2)) then
+           i2=icl
+           j2=jcl
+           tx=0
+           ty=0
+           txx=0.5
+           tyy=0.5
+        else
+           call crash('fuel_left: isubcl,jsubcl should be only 1 or 2')
+        endif 
+
+! calculation lff and tif in 4 endpoints of subcell                    
+        lffij=                             &    
+                  (1-tx)*(1-ty)*lfn(i2,j2)      &
+             +    (1-tx)*ty  *lfn(i2,j2+1)      &
+             +     tx*(1-ty)*lfn(i2+1,j2)       &
+             +       tx*ty  *lfn(i2+1,j2+1)
+        lffi1j=                            &
+                    (1-txx)*(1-ty)*lfn(i2,j2)   &
+             +      (1-txx)*ty  *lfn(i2,j2+1)   &
+             +      (txx)*(1-ty)*lfn(i2+1,j2)   &
+             +      (txx)*ty  *lfn(i2+1,j2+1)
+        lffij1=                            &
+                    (1-tx)*(1-tyy)*lfn(i2,j2)   &
+             +      (1-tx)*(tyy)  *lfn(i2,j2+1) &
+             +      tx*(1-tyy)*lfn(i2+1,j2)     &
+             +      tx*(tyy)  *lfn(i2+1,j2+1)
+        lffi1j1 =                               &
+                      (1-txx)*(1-tyy)*lfn(i2,j2)     &
+             +      (1-txx)*(tyy)  *lfn(i2,j2+1)   &        
+             +      (txx)*(1-tyy)*lfn(i2+1,j2)     &
+             +      (txx)*(tyy)  *lfn(i2+1,j2+1)
+
+        ! get ready to fix up tign values to be interpolated
+        do ii=1,2
+          do jj=1,2
+            tignf(ii,jj)=tign(i2+ii-1,j2+jj-1)
+          enddo
+        enddo
+        tifij=                                 &
+                   (1-tx)*(1-ty)*tignf(1,1)        &
+             +     (1-tx)*ty*tignf(1,1+1)          &
+             +     tx*(1-ty)*tignf(1+1,1)          &
+             +     tx*ty*tignf(1+1,1+1)
+        tifi1j=                               &
+                   (1-txx)*(1-ty)*tignf(1,1)      &
+             +     (1-txx)*ty*tignf(1,1+1)        &
+             +     (txx)*(1-ty)*tignf(1+1,1)      &
+             +     (txx)*(ty)*tignf(1+1,1+1)            
+        tifij1=                               &
+                   (1-tx)*(1-tyy)*tignf(1,1)      &
+             +     (1-tx)*(tyy)*tignf(1,1+1)      &
+             +      tx*(1-tyy)*tignf(1+1,1)       &
+             +      tx*(tyy)*tignf(1+1,1+1)
+        tifi1j1=                               &
+                   (1-txx)*(1-tyy)*tignf(1,1)     &
+             +     (1-txx)*(tyy)*tignf(1,1+1)     &
+             +     (txx)*(1-tyy)*tignf(1+1,1)     &
+             +     (txx)*(tyy)*tignf(1+1,1+1) 
+
+         
+        if(fuel_left_method.eq.1)then
+          call fuel_left_cell_1( fuel_left_ff, fire_area_ff, &
+             lffij,lffij1,lffi1j,lffi1j1,&
+             tifij,tifij1,tifi1j,tifi1j1,&
+             time_now, fuel_time(icl,jcl))
+        elseif(fuel_left_method.eq.2)then
+          fire_area_ff=0  ! initialize to something until computed in fuel_left_f(i,j)
+          fuel_left_ff=fuel_left_cell_2( &
+             lffij,lffij1,lffi1j,lffi1j1,&
+             tifij,tifij1,tifi1j,tifi1j1,&
+             time_now, fuel_time(icl,jcl)) 
+        else
+          call crash('fuel_left: unknown fuel_left_method')
+        endif
+
+        ! consistency check
+        if(fire_area_ff.lt.-1e-6 .or.  &
+          (fire_area_ff.eq.0. .and. fuel_left_ff.lt.1.-1e-6))then
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+           write(msg,'(a,2i6,2(a,f11.8))')'fuel_left: at node',i,j, &
+              ' of refined mesh fuel burnt',1-fuel_left_ff,' fire area',fire_area_ff
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+           call crash(msg)
+        endif
+
+        helpsum1=helpsum1+fuel_left_ff
+        helpsum2=helpsum2+fire_area_ff
+      enddo
+    enddo
+    fuel_frac(icl,jcl)=helpsum1 
+    fire_area(icl,jcl)=helpsum2
+  enddo 
+enddo
+  
+
+
+
+#ifdef DEBUG_OUT_FUEL_LEFT
+    call write_array_m(its,ite,jts,jte,ims,ime,jms,jme,fire_area,'fire_area',0)
+    call write_array_m(its,ite,jts,jte,ims,ime,jms,jme,fuel_frac,'fuel_frac',0)
+    call write_array_m(1,IFCELLS,1,JFCELLS,1,IFCELLS,1,JFCELLS,fuel_left_f,'fuel_left_f',0)
+    call write_array_m(1,IFCELLS,1,JFCELLS,1,IFCELLS,1,JFCELLS,fire_area_f,'fire_area_f',0)
+#endif
+
+! finish the averaging
+do j=jts,jte
+    do i=its,ite        
+        fuel_frac(i,j) = fuel_frac(i,j) /(ir*jr) ! multiply by weight for averaging over coarse cell
+        fire_area(i,j) = fire_area(i,j) /(ir*jr) ! 
+    enddo
+enddo
+
+! consistency check after sum
+fmax=0
+do j=jts,jte
+    do i=its,ite        
+       if(fire_area(i,j).eq.0.)then
+           if(fuel_frac(i,j).lt.1.-1e-6)then
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+               write(msg,'(a,2i6,2(a,f11.8))')'fuel_left: at node',i,j, &
+                   ' fuel burnt',1-fuel_frac(i,j),' but fire area',fire_area(i,j)
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+               call crash(msg)
+           endif
+       else
+           frat=(1-fuel_frac(i,j))/fire_area(i,j)
+           fmax=max(fmax,frat)
+       endif
+    enddo
+enddo
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+write(msg,'(a,4i6,a,f10.7)')'fuel_left: tile',its,ite,jts,jte,' max fuel burnt/area',fmax 
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+call message(msg)
+return
+
+
+end subroutine fuel_left
+
+!
+!************************
+!
+
+subroutine fuel_left_cell_1( fuel_frac_left, fire_frac_area, &
+    lfn00,lfn01,lfn10,lfn11, &
+    tign00,tign01,tign10,tign11,&
+    time_now, fuel_time_cell)
+!*** purpose: compute the fuel fraction left in one cell
+implicit none
+!*** arguments
+real, intent(out):: fuel_frac_left, fire_frac_area ! 
+real, intent(in)::lfn00,lfn01,lfn10,lfn11    ! level set function at 4 corners of the cell
+real, intent(in)::tign00,tign01,tign10,tign11! ignition time at the  4 corners of the cell
+real, intent(in)::time_now                   ! the time now
+real, intent(in)::fuel_time_cell            ! time to burns off to 1/e
+!*** Description
+! The area burning is given by the condition L <= 0, where the function P is
+! interpolated from lfn(i,j)
+!
+! The time since ignition is the function T, interpolated in from tign(i,j)-time_now.
+! The values of tign(i,j) where lfn(i,j)>=0 are ignored, tign(i,j)=0 is taken 
+! when lfn(i,j)=0.
+!
+! The function computes an approxmation  of the integral
+!
+!
+!                                  /\
+!                                  |              
+! fuel_frac_left  =      1   -     | 1 -  exp(-T(x,y)/fuel_time_cell)) dxdy
+!                                  |            
+!                                 \/
+!                                0<x<1
+!                                0<y<1
+!                             L(x,y)<=0
+!
+! When the cell is not burning at all (all lfn>=0), then fuel_frac(i,j)=1.
+! Because of symmetries, the result should not depend on the mesh spacing dx dy
+! so dx=1 and dy=1 assumed.
+!
+! Example:
+!
+!        lfn<0         lfn>0
+!      (0,1) -----O--(1,1)            O = points on the fireline, T=tnow
+!            |      \ |               A = the burning area for computing
+!            |       \|                        fuel_frac(i,j)
+!            |   A    O 
+!            |        |
+!            |        |
+!       (0,0)---------(1,0)
+!       lfn<0          lfn<0
+!
+! Approximations allowed: 
+! The fireline can be approximated by straight line(s).
+! When all cell is burning, approximation by 1 point Gaussian quadrature is OK.
+! 
+! Requirements:
+! 1. The output should be a continuous function of the arrays lfn and
+!  tign whenever lfn(i,j)=0 implies tign(i,j)=tnow.  
+! 2. The output should be invariant to the symmetries of the input in each cell.
+! 3. Arbitrary combinations of the signs of lfn(i,j) should work.
+! 4. The result should be at least 1st order accurate in the sense that it is
+!    exact if the time from ignition is a linear function.
+!
+! If time from ignition is approximated by polynomial in the burnt
+! region of the cell, this is integral of polynomial times exponential
+! over a polygon, which can be computed exactly.
+!
+! Requirement 4 is particularly important when there is a significant decrease
+! of the fuel fraction behind the fireline on the mesh scale, because the
+! rate of fuel decrease right behind the fireline is much larger 
+! (exponential...). This will happen when
+!
+! change of time from ignition within one mesh cell / fuel_time_cell is not << 1
+!
+! This is the same as
+!
+!               mesh cell size
+!  X =    -------------------------      is not << 1
+!       fireline speed * fuel_time_cell
+!         
+!
+! When X is large then the fuel burnt in one timestep in the cell is
+! approximately proportional to length of  fireline in that cell.
+!
+! When X is small then the fuel burnt in one timestep in the cell is
+! approximately proportional to the area of the burning region.
+!
+
+!*** calls
+intrinsic tiny
+
+!*** local
+real::ps,aps,area,ta,out
+real::t00,t01,t10,t11
+real,parameter::safe=tiny(aps)
+character(len=128)::msg
+
+! the following algorithm is a very crude approximation
+
+! minus time since ignition, 0 if no ignition yet
+! it is possible to have 0 in fire region when ignitin time falls in 
+! inside the time step because lfn is updated at the beginning of the time step
+
+t00=tign00-time_now
+if(lfn00>0. .or. t00>0.)t00=0.
+t01=tign01-time_now
+if(lfn01>0. .or. t01>0.)t01=0.
+t10=tign10-time_now
+if(lfn10>0. .or. t10>0.)t10=0.
+t11=tign11-time_now
+if(lfn11>0. .or. t11>0.)t11=0.
+
+! approximate burning area, between 0 and 1   
+ps = lfn00+lfn01+lfn10+lfn11   
+aps = abs(lfn00)+abs(lfn01)+abs(lfn10)+abs(lfn11)
+aps=max(aps,safe)
+area =(-ps/aps+1.)/2.
+area = max(area,0.) ! make sure area is between 0 and 1
+area = min(area,1.)
+    
+! average negative time since ignition
+ta=0.25*(t00+t01+t10+t11)
+
+! exp decay in the burning area
+out=1.
+!if(area>0.)out=1. - area*(1. - exp(ta/fuel_time_cell))
+if(area>0)out=area*exp(ta/fuel_time_cell) + (1. - area)
+
+if(out>1.)then
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+    write(msg,*)'out=',out,'>1 area=',area,' ta=',ta
+    call message(msg)
+    write(msg,*)'tign=',tign00,tign01,tign10,tign11,' time_now=',time_now
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+    call message(msg)
+    !call message('WARNING: fuel_left_cell_1: fuel fraction > 1')
+    call crash('fuel_left_cell_1: fuel fraction > 1')
+endif
+
+!out = max(out,0.) ! make sure out is between 0 and 1
+!out = min(out,1.)
+
+fuel_frac_left = out
+fire_frac_area = area
+
+end subroutine fuel_left_cell_1
+
+!
+!****************************************
+!
+
+real function fuel_left_cell_2(  &
+    lfn00,lfn01,lfn10,lfn11, &
+    tign00,tign01,tign10,tign11,&
+    time_now, fuel_time_cell)
+!*** purpose: compute the fuel fraction left in one cell
+implicit none
+!*** arguments
+real, intent(in)::lfn00,lfn01,lfn10,lfn11    ! level set function at 4 corners of the cell
+real, intent(in)::tign00,tign01,tign10,tign11! ignition time at the  4 corners of the cell
+real, intent(in)::time_now                   ! the time now
+real, intent(in)::fuel_time_cell            ! time to burns off to 1/e
+!*** Description
+! The area burning is given by the condition L <= 0, where the function P is
+! interpolated from lfn(i,j)
+!
+! The time since ignition is the function T, interpolated in from tign(i,j)-time_now.
+! The values of tign(i,j) where lfn(i,j)>=0 are ignored, tign(i,j)=0 is taken 
+! when lfn(i,j)=0.
+!
+! The function computes an approxmation  of the integral
+!
+!
+!                                  /\
+!                                  |              
+! fuel_frac_left  =      1   -     | 1 -  exp(-T(x,y)/fuel_time_cell)) dxdy
+!                                  |            
+!                                 \/
+!                                0<x<1
+!                                0<y<1
+!                             L(x,y)<=0
+!
+! When the cell is not burning at all (all lfn>=0), then fuel_frac(i,j)=1.
+! Because of symmetries, the result should not depend on the mesh spacing dx dy
+! so dx=1 and dy=1 assumed.
+!
+! Example:
+!
+!        lfn<0         lfn>0
+!      (0,1) -----O--(1,1)            O = points on the fireline, T=tnow
+!            |      \ |               A = the burning area for computing
+!            |       \|                        fuel_frac(i,j)
+!            |   A    O 
+!            |        |
+!            |        |
+!       (0,0)---------(1,0)
+!       lfn<0          lfn<0
+!
+! Approximations allowed: 
+! The fireline can be approximated by straight line(s).
+! When all cell is burning, approximation by 1 point Gaussian quadrature is OK.
+! 
+! Requirements:
+! 1. The output should be a continuous function of the arrays lfn and
+!  tign whenever lfn(i,j)=0 implies tign(i,j)=tnow.  
+! 2. The output should be invariant to the symmetries of the input in each cell.
+! 3. Arbitrary combinations of the signs of lfn(i,j) should work.
+! 4. The result should be at least 1st order accurate in the sense that it is
+!    exact if the time from ignition is a linear function.
+!
+! If time from ignition is approximated by polynomial in the burnt
+! region of the cell, this is integral of polynomial times exponential
+! over a polygon, which can be computed exactly.
+!
+! Requirement 4 is particularly important when there is a significant decrease
+! of the fuel fraction behind the fireline on the mesh scale, because the
+! rate of fuel decrease right behind the fireline is much larger 
+! (exponential...). This will happen when
+! 
+! change of time from ignition within one mesh cell * fuel speed is not << 1
+!
+! This is the same as
+!
+!         mesh cell size*fuel_speed 
+!         -------------------------      is not << 1
+!             fireline speed
+!         
+!
+! When X is large then the fuel burnt in one timestep in the cell is
+! approximately proportional to length of  fireline in that cell.
+!
+! When X is small then the fuel burnt in one timestep in the cell is
+! approximately proportional to the area of the burning region.
+!
+
+#ifndef FUEL_LEFT
+call crash('fuel_left_cell_2: not implemented, please use fire_fuel_left_method=1')
+fuel_left_cell_2=0.  ! to avoid compiler warning about value not set
+end function fuel_left_cell_2
+#else
+
+!*** calls
+intrinsic tiny
+
+!*** local
+real::ps,aps,area,ta,out
+real::t00,t01,t10,t11
+real,parameter::safe=tiny(aps)
+character(len=128)::msg
+
+!*** local
+integer::i,j,k
+
+! least squares
+integer::mmax,nb,nmax,pmax,nin,nout
+parameter(mmax=3,nb=64,nmax=8,pmax=8)
+integer lda, ldb, lwork, info
+parameter (lda=nmax, ldb=nmax, lwork=mmax+nmax+nb*(nmax+pmax))
+integer n,m,p
+real,dimension(lda,mmax):: mA
+real,dimension(nmax):: vecD
+real,dimension(lwork):: WORK
+real,dimension(pmax):: vecY
+real,dimension(mmax):: vecX
+real,dimension(ldb,pmax)::mB
+real,dimension(mmax)::u
+
+real::tweight,tdist
+integer::kk,ll,ss
+real::rnorm
+real,dimension(8,2)::xylist,xytlist
+real,dimension(8)::tlist,llist,xt
+real,dimension(5)::xx,yy
+real,dimension(5)::lfn,tign
+
+integer:: npoint
+real::tt,x0,y0,xts,xte,yts,yte,xt1,xt2
+real::lfn0,lfn1,dist,nr,c,s,errQ,ae,ce,ceae,a0,a1,a2,d,cet
+real::s1,s2,s3
+real::upper,lower,ah,ch,aa,cc,aupp,cupp,alow,clow
+real,dimension(2,2)::mQ
+real,dimension(2)::ut
+
+!calls
+intrinsic epsilon
+
+real, parameter:: zero=0.,one=1.,eps=epsilon(zero)
+
+
+! external functions    
+real::snrm2
+double precision :: dnrm2
+external dnrm2
+external snrm2
+! external subroutines
+external sggglm
+external dggglm
+!executable statements
+
+! a very crude approximation - replace by a better code
+! call check_mesh_2dim(ids,ide+1,jds,jde+1,ims,ime,jms,jme)
+t00=tign00-time_now
+if(lfn00>=0. .or. t00>0.)t00=0.
+t01=tign01-time_now
+if(lfn01>=0. .or. t01>0.)t01=0.
+t10=tign10-time_now
+if(lfn10>=0. .or. t10>0.)t10=0.
+t11=tign11-time_now
+if(lfn11>=0. .or. t11>0.)t11=0.
+
+!if (t00<0 .or. t01 <0 .or. t10<0 .or. t11<0) then
+!   print *,'tign00=',tign00,'tign10=',tign10,&
+!          'tign01=',tign01,'tign11=',tign11
+!end if
+
+
+
+!*** case0 Do nothing
+if ( lfn00>=0 .and. lfn10>=0 .and. lfn01>=0 .and. lfn11>=0 ) then
+    out = 1.0 !  fuel_left, no burning
+!*** case4 all four coners are burning
+else if (lfn00<=0 .and. lfn10<=0 .and. lfn01<=0 .and. lfn11<=0) then
+    ! least squares, A matrix for points
+    mA(1,1)=0.0
+    mA(2,1)=1.0
+    mA(3,1)=0.0
+    mA(4,1)=1.0
+    mA(1,2)=0.0
+    mA(2,2)=0.0
+    mA(3,2)=1.0
+    mA(4,2)=1.0
+    mA(1,3)=1.0
+    mA(2,3)=1.0
+    mA(3,3)=1.0
+    mA(4,3)=1.0
+    ! D vector, time from ignition
+    vecD(1)=time_now-tign00
+    vecD(2)=time_now-tign10
+    vecD(3)=time_now-tign01
+    vecD(4)=time_now-tign11
+    ! B matrix, weights
+    do kk=1,4
+    do ll=1,4
+        mB(kk,ll)=0.0
+    end do
+        mB(kk,kk)=2.0
+    end do
+    ! set the m,n,p
+    n=4 ! rows of matrix A and B
+    m=3 ! columns of matrix A
+    p=4 ! columns of matrix B
+    ! call least squqres in LAPACK            
+    call SGGGLM(N,M,P,mA,LDA,mB,LDB,vecD,vecX,vecY, &
+                WORK,LWORK,INFO)
+    rnorm=snrm2(p,vecY,1)            
+    ! integrate
+    u(1)=-vecX(1)/fuel_time_cell
+    u(2)=-vecX(2)/fuel_time_cell
+    u(3)=-vecX(3)/fuel_time_cell            
+    !fuel_burn(i,j)=1-exp(u(3))*intexp(u(1)*dx)*intexp(u(2)*dy)
+    s1=u(1)
+    s2=u(2)            
+    out=1-exp(u(3))*intexp(s1)*intexp(s2)
+    !print *,'intexp
+    if ( out<0 .or. out>1.0 ) then
+        print *,'case4, out should be between 0 and 1'
+    end if
+!*** case 1,2,3
+else
+    ! set xx, yy for the coner points
+    ! move these values out of i and j loop to speed up
+    xx(1) = -0.5
+    xx(2) =  0.5
+    xx(3) =  0.5
+    xx(4) = -0.5
+    xx(5) = -0.5
+    yy(1) = -0.5
+    yy(2) = -0.5
+    yy(3) =  0.5
+    yy(4) =  0.5
+    yy(5) = -0.5     
+    lfn(1)=lfn00
+    lfn(2)=lfn10
+    lfn(3)=lfn11
+    lfn(4)=lfn01
+    lfn(5)=lfn00
+    tign(1)=t00
+    tign(2)=t10
+    tign(3)=t11
+    tign(4)=t01
+    tign(5)=t00
+    npoint = 0 ! number of points in polygon
+    !print *,'time_now=',time_now
+    !print *,'lfn00=',lfn00,'lfn10=',lfn10,&
+    !        'lfn01=',lfn01,'lfn11=',lfn11
+    !print *,'t00=',t00,'t10=',t10,&
+    !        't01=',t01,'t11=',t11
+
+    do k=1,4
+        lfn0=lfn(k  )
+        lfn1=lfn(k+1)
+        if ( lfn0 <= 0.0 ) then
+            npoint = npoint + 1
+            xylist(npoint,1)=xx(k)
+            xylist(npoint,2)=yy(k)
+            tlist(npoint)=-tign(k)
+            llist(npoint)=lfn0
+        end if
+        if ( lfn0*lfn1 < 0 ) then
+            npoint = npoint + 1
+            tt=lfn0/(lfn0-lfn1)
+            x0=xx(k)+( xx(k+1)-xx(k) )*tt
+            y0=yy(k)+( yy(k+1)-yy(k) )*tt
+            xylist(npoint,1)=x0
+            xylist(npoint,2)=y0
+            tlist(npoint)=0 ! on fireline
+            llist(npoint)=0
+        end if
+    end do
+
+    ! make the list circular
+    tlist(npoint+1)=tlist(1)
+    llist(npoint+1)=llist(1)   
+    xylist(npoint+1,1)=xylist(1,1)
+    xylist(npoint+1,2)=xylist(1,2)
+    !* least squares, A matrix for points
+    do kk=1,npoint
+        mA(kk,1)=xylist(kk,1)
+        mA(kk,2)=xylist(kk,2)
+        mA(kk,3)=1.0
+        vecD(kk)=tlist(kk) ! D vector,time from ignition
+    end do
+    ! B matrix, weights
+    do kk=1,ldb
+    do ll=1,pmax
+        mB(kk,ll)=0.0 ! clear
+    end do
+    end do
+        
+    do kk=1,npoint
+        mb(kk,kk) = 10 ! large enough
+        do ll=1,npoint
+            if ( kk .ne. ll ) then
+                dist = sqrt( (xylist(kk,1)-xylist(ll,1))**2+ &
+                             (xylist(kk,2)-xylist(ll,2))**2 )                   
+                mB(kk,kk)=min( mB(kk,kk) , dist )
+            end if              
+        end do !ll
+        mB(kk,kk)=mB(kk,kk)+1.
+    end do ! kk
+    ! set the m,n,p
+    n=npoint ! rows of matrix A and B
+    m=3 ! columns of matrix A
+    p=npoint ! columns of matrix B
+    !* call least squqres in LAPACK                  
+    call SGGGLM(N,M,P,mA,LDA,mB,LDB,vecD,vecX,vecY, &
+                        WORK,LWORK,INFO)
+    !print *,'after LS in case3'
+    !print *,'vecX from LS',vecX
+    !print *,'tign inputed',tign00,tign10,tign11,tign01
+    rnorm=snrm2(p,vecY,1)
+    u(1)=vecX(1)
+    u(2)=vecX(2)
+    u(3)=vecX(3)            
+    ! rotate to gradient on x only
+    nr = sqrt(u(1)**2+u(2)**2)
+    if(.not.nr.gt.eps)then
+        out=1.
+        goto 900
+    endif
+    c = u(1)/nr
+    s = u(2)/nr
+    mQ(1,1)=c
+    mQ(1,2)=s
+    mQ(2,1)=-s
+    mQ(2,2)=c            
+    ! mat vec multiplication
+    call matvec(mQ,2,2,u,3,ut,2,2,2)            
+    errQ = ut(2) ! should be zero            
+    ae = -ut(1)/fuel_time_cell
+    ce = -u(3)/fuel_time_cell      
+    cet=ce!keep ce
+    call matmatp(xylist,8,2,mQ,2,2,xytlist,8,2,npoint+1,2,2)            
+    call sortxt( xytlist, 8,2, xt,8,npoint )            
+    out=0.0
+    aupp=0.0
+    cupp=0.0
+    alow=0.0
+    clow=0.0
+    do k=1,npoint-1
+        xt1=xt(k)
+        xt2=xt(k+1)
+        upper=0
+        lower=0
+        ah=0
+        ch=0
+        if ( xt2-xt1 > eps*100 ) then
+                
+            do ss=1,npoint
+                xts=xytlist(ss,1)
+                yts=xytlist(ss,2)
+                xte=xytlist(ss+1,1)
+                yte=xytlist(ss+1,2)
+                  
+                if ( (xts>xt1 .and. xte>xt1) .or. &
+                     (xts<xt2 .and. xte<xt2) ) then
+                    aa = 0 ! do nothing
+                    cc = 0
+                else
+                    aa = (yts-yte)/(xts-xte)
+                    cc = (xts*yte-xte*yts)/(xts-xte)                    
+                    if (xte<xts) then
+                        aupp = aa
+                        cupp = cc
+                        ah=ah+aa
+                        ch=ch+cc
+                        upper=upper+1
+                    else
+                        alow = aa
+                        clow = cc
+                        lower=lower+1
+                    end if
+                end if!(xts>xt1 .and. xte>xt1)              
+            end do ! ss
+            ce=cet !use stored ce
+            if (ae*xt1+ce > 0 ) then
+              ce=ce-(ae*xt1+ce)!shift small amounts exp(-**)
+            end if
+            if (ae*xt2+ce > 0) then
+            ce=ce-(ae*xt2+ce)
+            end if
+
+            ah = aupp-alow
+            ch = cupp-clow  
+            ! integrate (ah*x+ch)*(1-exp(ae*x+ce) from xt1 to xt2
+            ! numerically sound for ae->0, ae -> infty
+            ! this can be important for different model scales
+            ! esp. if someone runs the model in single precision!!
+            ! s1=int((ah*x+ch),x,xt1,xt2)
+            s1 = (xt2-xt1)*((1./2.)*ah*(xt2+xt1)+ch)            
+            ! s2=int((ch)*(-exp(ae*x+ce)),x,xt1,xt2)
+            ceae=ce/ae;
+            s2 = -ch*exp(ae*(xt1+ceae))*(xt2-xt1)*intexp(ae*(xt2-xt1))                
+            ! s3=int((ah*x)*(-exp(ae*x+ce)),x,xt1,xt2)
+            ! s3=int((ah*x)*(-exp(ae*(x+ceae))),x,xt1,xt2)
+            ! expand in Taylor series around ae=0
+            ! collect(expand(taylor(int(x*(-exp(ae*(x+ceae))),x,xt1,xt2)*ae^2,ae,4)/ae^2),ae)
+            ! =(1/8*xt1^4+1/3*xt1^3*ceae+1/4*xt1^2*ceae^2-1/8*xt2^4-1/3*xt2^3*ceae-1/4*xt2^2*ceae^2)*ae^2
+            !     + (-1/3*xt2^3-1/2*xt2^2*ceae+1/3*xt1^3+1/2*xt1^2*ceae)*ae 
+            !     + 1/2*xt1^2-1/2*xt2^2
+            !
+            ! coefficient at ae^2 in the expansion, after some algebra            
+            a2=(xt1-xt2)*((1./4.)*(xt1+xt2)*ceae**2+(1./3.)* &
+               (xt1**2+xt1*xt2+xt2**2)*ceae+(1./8.)* &
+               (xt1**3+xt1*(xt2**2)+xt1**2*xt2+xt2**3))               
+            d=(ae**4)*a2
+            
+            if (abs(d)>eps) then
+            ! since ae*xt1+ce<=0 ae*xt2+ce<=0 all fine for large ae
+            ! for ae, ce -> 0 rounding error approx eps/ae^2
+                s3=( exp(ae*(xt1+ceae))*(ae*xt1-1)-&
+                     exp(ae*(xt2+ceae))*(ae*xt2-1) )/(ae**2)
+                
+            !we do not worry about rounding as xt1 -> xt2, then s3 -> 0
+            else
+                ! coefficient at ae^1 in the expansion
+                a1=(xt1-xt2)*((1./2.)*ceae*(xt1+xt2)+(1./3.)*&
+                   (xt1**2+xt1*xt2+xt2**2))
+                ! coefficient at ae^0 in the expansion for ae->0
+                a0=(1./2.)*(xt1-xt2)*(xt1+xt2)
+                s3=a0+a1*ae+a2*ae**2; ! approximate the integral
+                            end if
+
+            s3=ah*s3                                                
+            out=out+s1+s2+s3
+            out=1-out !fuel_left
+            if(out<0 .or. out>1) then                                  
+                print *,':fuel_fraction should be between 0 and 1'
+                !print *, 'eps= ', eps
+                !print *, 'xt1= ', xt1, 'xt2= ', xt2
+                !print *,'ae= ',ae,'ce= ',ce,'ah= ',ah,'ch= ',ch
+                !print *,'a0= ', a0,'a1= ', a1,'a2= ', a2
+                print *,'s1= ', s1,'s2= ', s2,'s3= ', s3
+                print *,':fuel_fraction =',out
+            end if!print
+                
+        end if
+    end do ! k     
+    
+end if ! if case0, elseif case4 ,else case123
+
+900 continue 
+if(out>1. .or. out<0.)call crash('fuel_left_cell_2: fuel fraction out of bounds [0,1]')
+fuel_left_cell_2 = out
+end function fuel_left_cell_2
+
+!
+!****************************************
+!
+real function intexp(ab)
+implicit none
+real::ab
+!calls
+intrinsic epsilon
+
+real, parameter:: zero=0.,one=1.,eps=epsilon(zero)
+
+!eps = 2.2204*(10.0**(-8))!from matlab
+if ( eps < abs(ab)**3/6. ) then
+    intexp=(exp(ab)-1)/ab
+  else
+    intexp=1+ab/2.
+end if
+end function
+!
+!****************************************
+!
+subroutine sortxt(xytlist,nrow,ncolumn,xt,nxt,nvec)
+implicit none
+integer::nrow,ncolumn,nxt,nvec
+real,dimension(nrow,ncolumn)::xytlist
+real,dimension(nxt)::xt
+
+integer::i,j
+real::temp
+
+do i=1,nvec
+  xt(i)=xytlist(i,1)
+end do
+
+do i=1,nvec-1
+  do j=i+1,nvec
+    if ( xt(i) > xt(j) ) then
+         temp = xt(i)
+         xt(i)=xt(j)
+         xt(j)=temp
+    end if
+  end do
+end do
+
+end subroutine !sortxt
+!
+!****************************************
+!
+subroutine matvec(A,m,n,V,nv,out,nout,nrow,ncolumn)
+implicit none
+integer::m,n,nv,nout,nrow,ncolumn
+real,dimension(m,n)::A   ! allocated m by n 
+real,dimension(nv)::V    ! allocated nv
+real,dimension(nout)::out! allocated nout 
+
+integer::i,j
+
+do i=1,nrow
+  out(i)=0.0
+  do j=1,ncolumn
+    out(i)=out(i)+A(i,j)*V(j)
+  end do
+end do
+end subroutine
+!
+!****************************************
+!
+subroutine matmatp(A,mA,nA,B,mB,nB,C,mC,nC,nrow,ncolumn,nP)
+implicit none
+integer::mA,nA,mB,nB,mC,nC,nrow,ncolumn,nP
+real,dimension(mA,nA)::A   ! allocated m by n 
+real,dimension(mB,nB)::B   ! allocated m by n 
+real,dimension(mC,nC)::C   ! allocated m by n 
+integer::i,j,k
+do i=1,nrow  
+  do j=1,ncolumn
+    C(i,j)=0.0
+  do k=1,nP
+    C(i,j)=C(i,j)+A(i,k)*B(j,k) ! B'
+  end do
+end do
+end do
+end subroutine
+
+!
+!****************************************
+!
+#endif
+
+subroutine prop_ls( id, &                                ! for debug
+                ids,ide,jds,jde, &                       ! domain dims
+                ims,ime,jms,jme, &                       ! memory dims
+                ips,ipe,jps,jpe, &                ! patch - nodes owned by this process 
+                its,ite,jts,jte, &                       ! tile dims
+                ts,dt,dx,dy,     &                       ! scalars in
+                tbound,          &                       ! scalars out
+                lfn_in,lfn_out,tign,ros,  &              ! arrays inout          
+                fp               &
+                   )
+implicit none
+
+!*** purpose: advance level function in time
+
+!*** description
+!
+! Propagation of closed curve by a level function method. The level function
+! lfn is defined by its values at the nodes of a rectangular grid. 
+! The area where lfn < 0 is inside the curve. The curve is 
+! described implicitly by lfn=0. Points where the curve intersects gridlines
+! can be found by linear interpolation from nodes.
+!
+! The level function is advanced from time ts to time ts + dt. 
+!
+! The level function should be initialized to (an approximation of) the signed
+! distance from the curve. If the initial curve is a circle, the initial level
+! function is simply the distance from the center minus the radius.
+! 
+! The curve moves outside with speed given by function speed_func.
+!   
+! Method: Godunov/ENO method for the normal motion. The timestep is checked for
+! CFL condition. For a straight segment in a constant field and locally linear
+! level function, the method reduces to the exact normal motion. The advantage of 
+! the level set method is that it treats automatically special cases such as
+! the curve approaching itself and merging components of the area inside the curve.
+!
+! Based on S. Osher and R. Fedkiw, Level set methods and dynamic implicit surfaces,
+! Springer, 2003, Sec. 6.4, as implemented in toolboxLS for Matlab by 
+! I. Mitchell, A toolbox of Level Set Methods (Version 1.1), TR-2007-11,
+! Dept. Computer Science, University of British Columbia, 2007
+! http://www.cs.ubc.ca/\~mitchell/Toolbo\LS
+! 
+  
+!*** arguments 
+
+! id                in    unique identification for prints and dumps
+! ids,ide,jds,jde   in    domain dimensions
+! ims,ime,jms,jme   in    memory dimensions
+! its,ite,jts,jte   in    tile dimensions
+! ts                in    start time
+! dt                in    time step
+! dx,dy             in    grid spacing
+! tbound            out   bound on stable time step from CFL condition, if tbound>=dt then OK
+! lfn_in,lfn_out    inout,out the level set function at nodes
+! tign              inout the ignition time at nodes
+
+! The dimensions are cell-based, the nodal value is associated with the south-west corner.
+! The whole computation is on domain indices ids:ide+1,jds:jde+1.
+!
+! The region where new lfn and tign are computed is the tile its:ite,jts:jte 
+! except when the tile is at domain upper boundary, an extra band of points is added:
+! if ite=ide then region goes up to ite+1, if jte=jde then region goes up to jte+1.
+
+! The time step requires values from 2 rows of nodes beyond the region except when at the 
+! domain boundary one-sided derivatives are used. This is implemented by extending the input
+! beyond the domain boundary so sufficient memory bounds must be allocated. 
+! The update on all tiles can be done in parallel. To avoid the race condition (different regions
+! of the same array updated by different threads), the in and out versions of the
+! arrays lft and tign are distinct. If the time step dt is larger
+! that the returned tbound, the routine should be called again with timestep td<=tbound, and then
+! having distinct inputs and outputs comes handy.
+
+!*** calls
+!
+! tend_ls
+!
+
+integer,intent(in)::id,ims,ime,jms,jme,ids,ide,jds,jde,its,ite,jts,jte,ips,ipe,jps,jpe 
+real,dimension(ims:ime,jms:jme),intent(inout)::lfn_in,tign
+real,dimension(ims:ime,jms:jme),intent(out)::lfn_out,ros
+real,intent(in)::dx,dy,ts,dt
+real,intent(out)::tbound
+type(fire_params),intent(in)::fp
+
+!*** local 
+! arrays
+#define IMTS its-1
+#define IMTE ite+1
+#define JMTS jts-1
+#define JMTE jte+1
+real,dimension(IMTS:IMTE,JMTS:JMTE):: tend, lfn1 ! region-sized with halo
+! scalars
+real::grad2,rr,tbound2,a,a1 ! a=0 euler, a=0.5 heun
+
+real::gradx,grady,aspeed,err,aerr,time_now
+integer::ihs,ihe,jhs,jhe
+integer::ihs2,ihe2,jhs2,jhe2
+integer::i,j,its1,ite1,jts1,jte1,k,kk,id1
+character(len=128)::msg
+integer::nfirenodes,nfireline
+real::sum_err,min_err,max_err,sum_aerr,min_aerr,max_aerr   
+
+! constants
+integer,parameter :: mstep=1000, printl=1
+real, parameter:: zero=0.,one=1.,eps=epsilon(zero),tol=100*eps, &
+    safe=2.,rmin=safe*tiny(zero),rmax=huge(zero)/safe
+
+! f90 intrinsic function
+
+intrinsic max,min,sqrt,nint,epsilon,tiny,huge
+  
+!*** executable
+
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+write(msg,'(a8,i5,a6,i5,3(a1,i5))')'prop_ls:',id,' tile ',its,':',ite,',',jts,':',jte
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+call message(msg)
+
+    a=fire_back_weight ! from module_fr_sfire_util
+    a1=1. - a
+    
+    ! tend = F(lfn)
+
+    ihs2=max(its-2,ids)   ! need lfn two beyond the tile but not outside the domain 
+    ihe2=min(ite+2,ide)
+    jhs2=max(jts-2,jds) 
+    jhe2=min(jte+2,jde)
+
+    ihs=max(its-1,ids)   ! compute tend one beyond the tile but not outside the domain 
+    ihe=min(ite+1,ide)
+    jhs=max(jts-1,jds) 
+    jhe=min(jte+1,jde)
+
+#ifdef DEBUG_OUT    
+    call write_array_m(ihs,ihe,jhs,jhe,ims,ime,jms,jme,lfn_in,'lfn_in',id)
+#endif
+
+    ! check array dimensions
+    call check_mesh_2dim(ihs2,ihe2,jhs2,jhe2,ims,ime,jms,jme)
+    call print_2d_stats(ihs2,ihe2,jhs2,jhe2,ims,ime,jms,jme, &
+                   lfn_in,'prop_ls: lfn in')
+    
+    ! NOTE: tend_ls will extrapolate to one node strip at domain boundaries
+    ! so that it can compute gradient at domain boundaries.
+    ! To avoid copying, lfn_in is declared inout.
+    ! At tile boundaries that are not domain boundaries values of lfn_in two nodes
+    ! outside of the tile are needed.
+    id1 = id  ! for debug prints
+    if(id1.ne.0)id1=id1+1000
+    call  tend_ls( id1, &
+    ims,ime,jms,jme, &                       ! memory dims for lfn_in
+    IMTS,IMTE,JMTS,JMTE, &                   ! memory dims for tend 
+    ids,ide,jds,jde, &                       ! domain dims - where lfn exists
+    ips,ipe,jps,jpe, &                       ! patch - nodes owned by this process 
+    ihs,ihe,jhs,jhe, &                       ! where tend computed
+    ims,ime,jms,jme, &                       ! memory dims for ros 
+    its,ite,jts,jte, &                       ! tile dims - where to set ros
+    ts,dt,dx,dy,      &                      ! scalars in
+    lfn_in, &                                ! arrays in
+    tbound, &                                ! scalars out 
+    tend, ros, &                              ! arrays out        
+    fp         &                             ! params
+)
+
+#ifdef DEBUG_OUT    
+    call write_array_m(ihs,ihe,jhs,jhe,IMTS,IMTE,JMTS,JMTE,tend,'tend1',id)
+#endif
+
+    ! Euler method, the half-step, same region as ted
+    do j=jhs,jhe
+        do i=ihs,ihe
+            lfn1(i,j) = lfn_in(i,j) + dt*tend(i,j)
+        enddo
+    enddo
+    
+    call print_2d_stats(ihs,ihe,jhs,jhe,IMTS,IMTE,JMTS,JMTE, &
+                   lfn1,'prop_ls: lfn1')
+    ! tend = F(lfn1) on the tile (not beyond)
+
+    if(id1.ne.0)id1=id1+1000
+    call  tend_ls( id1,&
+    IMTS,IMTE,JMTS,JMTE, &                   ! memory dims for lfn
+    IMTS,IMTE,JMTS,JMTE, &                   ! memory dims for tend 
+    ids,ide,jds,jde,     &                   ! domain dims - where lfn exists
+    ips,ipe,jps,jpe, &                       ! patch - nodes owned by this process 
+    its,ite,jts,jte, &                       ! tile dims - where is tend computed
+    ims,ime,jms,jme, &                       ! memory dims for ros 
+    its,ite,jts,jte, &                       ! tile dims - where is ros set
+    ts+dt,dt,dx,dy,      &                   ! scalars in
+    lfn1, &                                  ! arrays in
+    tbound2, &                               ! scalars out 
+    tend,ros, &                               ! arrays out        
+    fp &
+)
+
+#ifdef DEBUG_OUT    
+    call write_array_m(its,ite,jts,jte,IMTS,IMTE,JMTS,JMTE,tend,'tend2',id)
+#endif
+
+    call print_2d_stats(its,ite,jts,jte,IMTS,IMTE,JMTS,JMTE,tend,'prop_ls: tend2')
+        
+    tbound=min(tbound,tbound2)
+
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+    write(msg,'(a,f10.2,4(a,f7.2))')'prop_ls: time',ts,' dt=',dt,' bound',min(tbound,999.99), &
+        ' dx=',dx,' dy=',dy
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+    call message(msg)
+    if(dt>tbound)then
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+        write(msg,'(2(a,f10.2))')'prop_ls: WARNING: time step ',dt, &
+        ' > bound =',tbound
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+        call message(msg)
+    endif
+    
+    ! combine lfn1 and lfn_in + dt*tend -> lfn_out
+    
+    do j=jts,jte
+        do i=its,ite
+            lfn_out(i,j) = a1*lfn1(i,j) + a*(lfn_in(i,j) + dt*tend(i,j))
+            lfn_out(i,j) = min(lfn_out(i,j),lfn_in(i,j)) ! fire area can only increase
+        enddo
+    enddo      
+
+    ! compute ignition time by interpolation
+    ! the node was not burning at start but it is burning at end
+    ! interpolate from the level functions at start and at end
+    ! lfn_in   is the level set function value at time ts
+    ! lfn_out  is the level set function value at time ts+dt
+    ! 0        is the level set function value at time tign(i,j)
+    ! thus assuming the level function is approximately linear =>
+    ! tign(i,j)= ts + ((ts + td) - ts) * lfn_in / (lfn_in - lfn_out)
+    !        = ts + dt * lfn_in / (lfn_in - lfn_out)
+
+    time_now=ts+dt
+    time_now = time_now + abs(time_now)*epsilon(time_now)*2.
+    do j=jts,jte
+        do i=its,ite
+            ! interpolate the cross-over time
+            if (.not. lfn_out(i,j)>0 .and. lfn_in(i,j)>0)then
+                tign(i,j) = ts + dt * lfn_in(i,j) / (lfn_in(i,j) - lfn_out(i,j))
+            endif
+            ! set the ignition time outside of burning region
+            if(lfn_out(i,j)>0.)tign(i,j)=time_now
+        enddo
+    enddo
+    
+    ! check local speed error and stats 
+    ! may not work correctly in parallel
+    ! init stats
+    nfirenodes=0
+    nfireline=0
+    sum_err=0.
+    min_err=rmax
+    max_err=rmin     
+    sum_aerr=0.
+    min_aerr=rmax
+    max_aerr=rmin    
+    its1=its+1
+    jts1=jts+1
+    ite1=ite-1
+    jte1=jte-1
+    ! loop over right inside of the domain
+    ! cannot use values outside of the domain, would have to reflect and that
+    ! would change lfn_out
+    ! cannot use values outside of tile, not synchronized yet
+    ! so in parallel mode the statistics is not accurate
+    do j=jts1,jte1
+        do i=its1,ite1
+            if(lfn_out(i,j)>0.0)then   ! a point out of burning region
+                if(lfn_out(i+1,j)<=0.or.lfn_out(i,j+1)<=0.or. & ! neighbor in burning region
+                   lfn_out(i-1,j)<=0.or.lfn_out(i,j-1)<=0)then ! point next to fireline
+                   gradx=(lfn_out(i+1,j)-lfn_out(i-1,j))/(2.0*dx) ! central differences
+                   grady=(lfn_out(i,j+1)-lfn_out(i,j-1))/(2.0*dy)
+                   grad2=sqrt(gradx*gradx+grady*grady)
+                   aspeed = (lfn_in(i,j)-lfn_out(i,j))/(dt*max(grad2,rmin))                   
+                    rr = speed_func(gradx,grady,dx,dy,i,j,fp)
+                   err=aspeed-rr
+                   sum_err=sum_err+err
+                   min_err=min(min_err,err)
+                   max_err=max(max_err,err)     
+                   aerr=abs(err)
+                   sum_aerr=sum_aerr+aerr
+                   min_aerr=min(min_aerr,aerr)
+                   max_aerr=max(max_aerr,aerr)
+                   nfireline=nfireline+1
+                endif
+            else
+                nfirenodes=nfirenodes+1
+            endif
+        enddo
+    enddo
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+    write(msg,'(2(a,i6,f8.4))')'prop_ls: nodes burning',nfirenodes, &
+        (100.*nfirenodes)/((ite1-its1+1)*(jte1-jts1+1)),'% next to fireline',nfireline
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+    call message(msg)
+    if(nfireline>0)then
+        call print_stat_line('speed error',its1,ite1,jts1,jte1,min_err,max_err,sum_err/nfireline)
+        call print_stat_line('abs(speed error)',its1,ite1,jts1,jte1,min_aerr,max_aerr,sum_aerr/nfireline)
+    endif
+
+    ! check if the fire did not get to the domain boundary
+    do k=-1,1,2
+        ! do kk=1,(boundary_guard*(ide-ids+1))/100  ! in %
+        do kk=1,boundary_guard   ! measured in cells
+            i=ids+k*kk
+            if(i.ge.its.and.i.le.ite)then
+                do j=jts,jte
+                    if(lfn_out(i,j)<=0.)goto 9
+                enddo
+            endif
+    enddo
+        ! do kk=1,(boundary_guard*(jde-jds+1))/100
+        do kk=1,boundary_guard    ! measured in cells
+            j=jds+k*kk
+            if(j.ge.jts.and.j.le.jte)then
+                do i=its,ite
+                    if(lfn_out(i,j)<=0.)goto 9
+                enddo
+            endif
+        enddo
+    enddo
+    goto 10
+9   continue
+!$OMP CRITICAL(SFIRE_CORE_CRIT)
+    write(msg,'(a,i2,a,2i8)')'prop_ls: fire',boundary_guard, &
+        ' cells from domain boundary at node ',i,j
+!$OMP END CRITICAL(SFIRE_CORE_CRIT)
+    call message(msg)     
+    call crash('prop_ls: increase the fire region')
+10  continue
+
+    call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme, &
+                   lfn_out,'prop_ls: lfn out')
+
+end subroutine prop_ls
+
+!
+!*****************************
+!
+
+subroutine tend_ls( id, &
+    lims,lime,ljms,ljme, &                   ! memory dims for lfn
+    tims,time,tjms,tjme, &                   ! memory dims for tend 
+    ids,ide,jds,jde, &                       ! domain - nodes where lfn defined
+    ips,ipe,jps,jpe, &                       ! patch - nodes owned by this process 
+    ints,inte,jnts,jnte, &                   ! region - nodes where tend computed
+    ims,ime,jms,jme, &                       ! memory dims for ros 
+    its,ite,jts,jte, &                       ! tile dims - where is ros set
+    t,dt,dx,dy,      &                       ! scalars in
+    lfn, &                                   ! arrays in
+    tbound, &                                ! scalars out 
+    tend, ros,  &                              ! arrays out
+    fp &
+)
+
+implicit none
+! purpose
+! compute the right hand side of the level set equation
+
+!*** arguments
+integer,intent(in)::id,lims,lime,ljms,ljme,tims,time,tjms,tjme
+integer,intent(in)::ims,ime,jms,jme,its,ite,jts,jte
+integer, intent(in)::ids,ide,jds,jde,ints,inte,jnts,jnte,ips,ipe,jps,jpe 
+real,intent(in)::t                                     ! time
+real,intent(in)::dt,dx,dy                                 ! mesh step
+real,dimension(lims:lime,ljms:ljme),intent(inout)::lfn ! level set function
+real,intent(out)::tbound                               ! max allowed time step
+real,dimension(tims:time,tjms:tjme),intent(out)::tend  ! tendency (rhs of the level set pde)
+real,dimension(ims:ime,jms:jme),intent(out)::ros  ! rate of spread 
+type(fire_params),intent(in)::fp
+
+!*** local 
+real:: te,diffLx,diffLy,diffRx,diffRy, & 
+   diffCx,diffCy,diff2x,diff2y,grad,rr, &
+   ros_base,ros_wind,ros_slope,ros_back,advx,advy,scale,nvx,nvy, &
+   speed,tanphi
+integer::i,j,itso,iteo,jtso,jteo
+character(len=128)msg
+
+! constants
+real, parameter:: eps=epsilon(0.0)
+!intrinsic epsilon
+real, parameter:: zero=0.,one=1.,tol=100*eps, &
+    safe=2.,rmin=safe*tiny(zero),rmax=huge(zero)/safe
+
+
+! f90 intrinsic function
+
+intrinsic max,min,sqrt,nint,tiny,huge
+
+
+#ifdef DEBUG_OUT
+real,dimension(tims:time,tjms:tjme)::rra,grada,speeda,tanphia
+#endif
+
+!*** executable
+    
+    ! check array dimensions
+    call check_mesh_2dim(ints-1,inte+1,jnts-1,jnte+1,lims,lime,ljms,ljme)
+    call check_mesh_2dim(ints,inte,jnts,jnte,tims,time,tjms,tjme)
+    
+    call continue_at_boundary(1,1,fire_lfn_ext_up, &   !extend by extrapolation but never down 
+    lims,lime,ljms,ljme, &                ! memory dims
+    ids,ide,jds,jde, &                    ! domain - nodes where lfn defined
+    ips,ipe,jps,jpe, &                    ! patch - nodes owned by this process 
+    ints,inte,jnts,jnte, &                ! tile - nodes update by this thread
+    itso,iteo,jtso,jteo, &                ! where set now
+    lfn)                                  ! array
+
+    call print_2d_stats(itso,iteo,jtso,jteo,lims,lime,ljms,ljme, &
+                   lfn,'tend_ls: lfn cont')
+
+#ifdef DEBUG_OUT
+    call write_array_m(ints-1,inte+1,jnts-1,jnte+1,lims,lime,ljms,ljme,lfn,'tend_lfn_in',id)
+#endif
+    
+    tbound=0    
+    do j=jnts,jnte
+        do i=ints,inte
+            ! one sided differences
+            diffRx = (lfn(i+1,j)-lfn(i,j))/dx
+            diffLx = (lfn(i,j)-lfn(i-1,j))/dx
+            diffRy = (lfn(i,j+1)-lfn(i,j))/dy
+            diffLy = (lfn(i,j)-lfn(i,j-1))/dy
+            diffCx = diffLx+diffRx   ! 	TWICE CENTRAL DIFFERENCE
+            diffCy = diffLy+diffRy
+    
+            !upwinding - select right or left derivative
+            select case(fire_upwinding)
+            case(0)  ! none
+                grad=sqrt(diffCx**2 + diffCy**2)
+            case(1) ! standard
+                diff2x=select_upwind(diffLx,diffRx)
+                diff2y=select_upwind(diffLy,diffRy)
+                grad=sqrt(diff2x*diff2x + diff2y*diff2y)
+            case(2) ! godunov per osher/fedkiw
+                diff2x=select_godunov(diffLx,diffRx)
+                diff2y=select_godunov(diffLy,diffRy)
+                grad=sqrt(diff2x*diff2x + diff2y*diff2y)
+            case(3) ! eno
+                diff2x=select_eno(diffLx,diffRx)
+                diff2y=select_eno(diffLy,diffRy)
+                grad=sqrt(diff2x*diff2x + diff2y*diff2y)
+            case(4) ! Sethian - twice stronger pushdown of bumps
+                grad=sqrt(max(diffLx,0.)**2+min(diffRx,0.)**2   &
+                        + max(diffLy,0.)**2+min(diffRy,0.)**2)
+            case default
+                grad=0.
+            end select
+  
+            ! normal direction, from central differences
+            scale=sqrt(diffCx*diffCx+diffCy*diffCy+eps) 
+            nvx=diffCx/scale
+            nvy=diffCy/scale
+                      
+            ! wind speed in direction of spread
+            ! speed =  vx(i,j)*nvx + vy(i,j)*nvy
+        
+    
+            ! get rate of spread from wind speed and slope
+
+            call fire_ros(ros_base,ros_wind,ros_slope, &
+            nvx,nvy,i,j,fp)
+
+            rr=ros_base + ros_wind + ros_slope
+            if(fire_grows_only.gt.0)rr=max(rr,0.)
+
+            ! set ros for output
+            if(i.ge.its.and.i.le.ite.and.j.ge.jts.and.j.le.jte)ros(i,j)=rr
+
+            if(fire_upwind_split.eq.0)then
+
+                ! get rate of spread
+                te = -rr*grad   ! normal term 
+
+            else
+
+                ! normal direction backing rate only
+                te = - ros_base*grad
+
+		! advection in wind direction 
+                if (abs(speed)> eps) then
+                    advx=fp%vx(i,j)*ros_wind/speed
+                    advy=fp%vy(i,j)*ros_wind/speed
+                else 
+                    advx=0
+                    advy=0
+                endif
+
+                ! tanphi =  dzdxf*nvx + dzdyf*nvy
+		! advection from slope direction 
+                if(abs(tanphi)>eps) then
+                    advx=advx+fp%dzdxf(i,j)*ros_slope/tanphi
+                    advy=advy+fp%dzdyf(i,j)*ros_slope/tanphi
+                endif
+
+                if(fire_upwind_split.eq.1)then   
+
+                    ! one-sided upwinding
+                    te = te - max(advx,0.)*diffLx - min(advx,0.)*diffRy &
+                            - max(advy,0.)*diffLy - min(advy,0.)*diffRy
+
+
+                elseif(fire_upwind_split.eq.2)then   
+ 
+                    ! Lax-Friedrichs
+                    call crash('prop_ls: bad fire_upwind_split, Lax-Friedrichs not done yet')
+
+                else
+
+                    call crash('prop_ls: bad fire_upwind_split')
+
+                endif
+            endif
+
+            ! cfl condition
+            if (grad > 0.) then
+                 tbound = max(tbound,rr*(abs(diff2x)/dx+abs(diff2y)/dy)/grad)
+            endif
+
+            ! add numerical viscosity
+            te=te + fire_viscosity*abs(rr)*((diffRx-diffLx)+(diffRy-diffLy))
+
+            tend(i,j)=te
+#ifdef DEBUG_OUT    
+            rra(i,j)=rr
+            grada(i,j)=grad    
+            speeda(i,j)=speed
+            tanphia(i,j)=tanphi
+#endif
+            !write(msg,*)i,j,grad,dzdx,dzdy
+            !call message(msg)
+
+            !if(abs(te)>1e4)then
+            !    write(msg,'(a,2i5,e12.3)')'tend_ls: tend out of bounds at ',i,j,te
+            !    call crash(msg)
+            !endif
+        enddo
+    enddo        
+
+#ifdef DEBUG_OUT    
+    call write_array_m(ints,inte,jnts,jnte,tims,time,tjms,tjme,rra,'rr',id)
+    call write_array_m(ints,inte,jnts,jnte,tims,time,tjms,tjme,grada,'grad',id)
+    call write_array_m(ints,inte,jnts,jnte,tims,time,tjms,tjme,speeda,'speed',id)
+    call write_array_m(ints,inte,jnts,jnte,tims,time,tjms,tjme,tanphia,'tanphi',id)
+    call write_array_m(ints,inte,jnts,jnte,tims,time,tjms,tjme,tend,'tend',id)
+#endif
+
+    call print_2d_stats(ints,inte,jnts,jnte,tims,time,tjms,tjme, &
+                   tend,'tend_ls: tend out')
+
+    ! the final CFL bound
+    tbound = 1/(tbound+tol)
+
+end subroutine tend_ls
+
+!
+!**************************
+!
+
+real function select_upwind(diffLx,diffRx)
+implicit none
+real, intent(in):: diffLx, diffRx
+real diff2x
+
+! upwind differences, L or R if bith same sign, otherwise zero    
+
+diff2x=0
+if (diffLx>0.and.diffRx>0.)diff2x=diffLx
+if (diffLx<0.and.diffRx<0.)diff2x=diffRx
+
+select_upwind=diff2x
+end function select_upwind
+
+
+!
+!**************************
+!
+
+
+real function select_godunov(diffLx,diffRx)
+implicit none
+real, intent(in):: diffLx, diffRx
+real diff2x,diffCx
+
+! Godunov scheme: upwind differences, L or R or none    
+! always test on > or < never = , much faster because of IEEE
+! central diff >= 0 => take left diff if >0, ortherwise 0
+! central diff <= 0 => take right diff if <0, ortherwise 0
+
+diff2x=0
+diffCx=diffRx+diffLx
+if (diffLx>0.and..not.diffCx<0)diff2x=diffLx
+if (diffRx<0.and.     diffCx<0)diff2x=diffRx
+
+select_godunov=diff2x
+end function select_godunov
+
+!
+!**************************
+!
+
+real function select_eno(diffLx,diffRx)
+implicit none
+real, intent(in):: diffLx, diffRx
+real diff2x
+
+! 1st order ENO scheme
+
+if    (.not.diffLx>0 .and. .not.diffRx>0)then
+    diff2x=diffRx
+elseif(.not.diffLx<0 .and. .not.diffRx<0)then
+    diff2x=diffLx
+elseif(.not.diffLx<0 .and. .not.diffRx>0)then
+    if(.not. abs(diffRx) < abs(diffLx))then
+        diff2x=diffRx
+    else
+        diff2x=diffLx
+    endif
+else
+    diff2x=0.
+endif
+
+select_eno=diff2x
+end function select_eno
+      
+!
+!**************************
+!
+
+real function speed_func(diffCx,diffCy,dx,dy,i,j,fp)
+!*** purpose
+!    the level set method speed function
+implicit none
+!*** arguments
+real, intent(in)::diffCx,diffCy  ! x and y coordinates of the direction of propagation
+real, intent(in)::dx,dy  ! x and y coordinates of the direction of propagation
+integer, intent(in)::i,j         ! indices of the node to compute the speed at
+type(fire_params),intent(in)::fp
+!*** local
+real::scale,nvx,nvy,r
+real::ros_base , ros_wind , ros_slope
+real, parameter:: eps=epsilon(0.0)
+!*** executable
+            ! normal direction, from central differences
+            scale=sqrt(diffCx*diffCx+diffCy*diffCy+eps) 
+            nvx=diffCx/scale
+            nvy=diffCy/scale
+                      
+            ! get rate of spread from wind speed and slope
+
+            call fire_ros(ros_base,ros_wind,ros_slope, &
+            nvx,nvy,i,j,fp)
+
+            r=ros_base + ros_wind + ros_slope
+            if(fire_grows_only.gt.0)r=max(r,0.)
+            speed_func=r
+
+end function speed_func
+
+end module module_fr_sfire_core
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_driver.F	(revision 17)
@@ -0,0 +1,1401 @@
+!
+! This module is the entry point from WRF ARW to the wildland 
+! fire module. The call to sfire_driver advances the fire module by 
+! one timestep. The fire module inputs the wind and outputs 
+! temperature and humidity tendencies. The fire module also inputs a 
+! number of constant arrays (fuel data, topography). Additional 
+! arguments are model state (for data assimilation) and constant arrays 
+! the model gives to WRF for safekeeping because it is not allowed 
+! to save anything.
+!
+! Contributions to this wildland fire module have come from individuals at
+! NCAR, the U.S.D.A. Forest Service, the Australian Bureau of Meteorology, 
+! and the University of Colorado at Denver. 
+!
+
+module module_fr_sfire_driver
+! use this module for standalone call, you only need to provide some mock-up wrf modules  
+
+use module_fr_sfire_model
+use module_fr_sfire_phys, only : fire_params , init_fuel_cats
+use module_fr_sfire_util
+use module_fr_sfire_core, only: ignition_line_type
+
+USE module_domain, only: domain
+USE module_configure, only: grid_config_rec_type
+use module_model_constants, only: reradius,    & ! 1/earth radiusw
+                                  g,           & ! gravitation acceleration
+                                  pi2            ! 2*pi
+
+implicit none
+
+
+private
+public sfire_driver_em,use_atm_vars
+
+logical:: use_atm_vars=.true.   !  interpolate wind from atm mesh and average output fluxes back
+
+contains
+
+#define DEBUG_OUT
+subroutine sfire_driver_em ( grid , config_flags                    & 
+            ,fire_ifun_start,fire_ifun_end,tsteps                   &
+            ,ids,ide, kds,kde, jds,jde                              &
+            ,ims,ime, kms,kme, jms,jme                              &
+            ,ips,ipe, kps,kpe, jps,jpe                              &
+            ,ifds,ifde, jfds,jfde                                   &
+            ,ifms,ifme, jfms,jfme                                   &
+            ,ifps,ifpe, jfps,jfpe )
+
+!*** purpose: driver from grid structure
+
+! Driver layer modules
+#ifdef DM_PARALLEL
+    USE module_dm        , ONLY : ntasks_x,ntasks_y,local_communicator,mytask,ntasks
+    USE module_comm_dm , ONLY : halo_fire_fuel_sub, halo_fire_tign_sub, halo_fire_wind_f_sub, &
+halo_fire_wind_a_sub, halo_fire_ph_sub, halo_fire_zsf_sub, halo_fire_longlat_sub, &
+halo_fire_phb_sub, halo_fire_z0_sub, halo_fire_lfn_sub
+#endif
+
+    implicit none
+!*** arguments
+    TYPE(domain) , TARGET :: grid                             ! state 
+    TYPE (grid_config_rec_type) , INTENT(IN)  :: config_flags ! namelist
+    integer, intent(in)::     fire_ifun_start,fire_ifun_end,tsteps ! driver cycle controls
+    integer, intent(in):: &
+             ids,ide, kds,kde, jds,jde,                              &
+             ims,ime, kms,kme, jms,jme,                              &
+             ips,ipe, kps,kpe, jps,jpe,                              &
+             ifds,ifde, jfds,jfde,                                   &
+             ifms,ifme, jfms,jfme,                                   &
+             ifps,ifpe, jfps,jfpe 
+
+!*** local
+    INTEGER:: fire_num_ignitions
+    integer, parameter::fire_max_ignitions=5
+    TYPE(ignition_line_type), DIMENSION(fire_max_ignitions):: ignition_line
+    integer::fire_ifun,ir,jr,fire_ignition_longlat,istep,itimestep
+    logical::need_lfn_update,restart
+    real, dimension(ifms:ifme, jfms:jfme)::lfn_out  
+    real:: corner_ll,corner_ul,corner_ur,corner_lr
+    character(len=128)msg
+    real:: unit_fxlong ,unit_fxlat
+    type(fire_params)::fp
+
+
+!*** executable
+
+! populate our structures from wrf
+
+    ! pointers to be passed to fire rate of spread formulas
+    fp%vx => grid%uf         ! W-E winds used in fire module
+    fp%vy => grid%vf         ! S-N winds used in fire module
+    fp%zsf => grid%zsf       ! terrain height 
+    fp%dzdxf => grid%dzdxf   ! terrain grad 
+    fp%dzdyf => grid%dzdyf   ! terrain grad 
+    fp%bbb => grid%bbb       ! a rate of spread formula coeff 
+    fp%betafl => grid%betafl ! a rate of spread formula variable 
+    fp%phiwc => grid%phiwc   ! a rate of spread formula coeff 
+    fp%r_0 => grid%r_0       ! a rate of spread formula variable
+    fp%fgip => grid%fgip     ! a rate of spread formula coeff 
+    fp%ischap => grid%ischap ! a rate of spread formula switch
+            
+    ! get ignition data 
+    call fire_ignition_convert (config_flags,fire_max_ignitions,fire_ignition_longlat, &
+        ignition_line,fire_num_ignitions,unit_fxlong,unit_fxlat)
+
+    ! copy configuration flags to sfire internal structures
+    call set_flags(config_flags)
+
+    ! refinement r
+    ir=grid%sr_x ! refinement ratio
+    jr=grid%sr_y
+    itimestep=grid%itimestep
+    restart=config_flags%restart
+
+    
+
+!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+    write(msg,'(a,i1,a,i1,a,i4)') &
+       'sfire_driver_em: ifun from ',fire_ifun_start,' to ',fire_ifun_end,' test steps',tsteps
+!$OMP END CRITICAL(SFIRE_DRIVER_CRIT)
+    call message(msg)
+
+    do istep=0,tsteps ! istep >0 is for testing only, exit after the first call
+      itimestep = grid%itimestep + istep ! in the first call, do fire_test_steps steps of the fire model
+
+      need_lfn_update=.false.
+      do fire_ifun=fire_ifun_start,fire_ifun_end
+
+        ! 1 = initialize run pass 1: interpolate height to zsf=terrain
+        ! 2 = initialize run pass 2: set fuel data, terrain gradient
+        ! 3 = initialize timestep: interpolate winds, check for ignition
+        ! 4 = do one timestep 
+        ! 5 = copy timestep output to input
+        ! 6 = compute output fluxes
+
+#ifdef DM_PARALLEL
+        if(need_lfn_update)then
+!           halo exchange on lfn width 2
+#include "HALO_FIRE_LFN.inc"
+        endif
+
+        if(fire_ifun.eq.1)then
+!       halo exchange on topography
+#include "HALO_FIRE_LONGLAT.inc"
+!!            if(fire_topo_from_atm.eq.1)then
+!!#include "HALO_FIRE_HT.inc"
+!!            endif 
+! base geopotential and roughness
+#include "HALO_FIRE_PHB.inc"
+#include "HALO_FIRE_Z0.inc"
+
+        elseif(fire_ifun.eq.2)then
+!           halo exchange on zsf width 2
+#include "HALO_FIRE_ZSF.inc"
+
+        elseif(fire_ifun.eq.3)then
+!           halo exchange on atm winds and geopotential, width 1 for interpolation
+#include "HALO_FIRE_WIND_A.inc"
+#include "HALO_FIRE_PH.inc"
+
+        elseif(fire_ifun.eq.4)then
+!           halo exchange on fire winds width 2 for a 2-step RK method
+#include "HALO_FIRE_WIND_F.inc"
+
+        elseif(fire_ifun.eq.6)then
+!           computing fuel_left needs ignition time from neighbors
+#include "HALO_FIRE_TIGN.inc"
+
+        endif
+#endif
+        ! need domain by 1 smaller, in last row.col winds are not set properly
+        call sfire_driver_phys ( &
+            fire_ifun,need_lfn_update,                  &
+            ids,ide-1, kds,kde, jds,jde-1,                          &
+            ims,ime, kms,kme, jms,jme,                          &
+            ips,min(ipe,ide-1), kps,kpe, jps,min(jpe,jde-1),                          & 
+            ifds,ifde-ir, jfds,jfde-jr,                    &
+            ifms,ifme, jfms,jfme,                    &
+            ifps,min(ifpe,ifde-ir), jfps,min(jfpe,jfde-jr),      &
+            ir,jr,                                      & ! atm/fire grid ratio
+            grid%num_tiles,                             & ! atm grid tiling
+            grid%i_start,min(grid%i_end,ide-1),                    &
+            grid%j_start,min(grid%j_end,jde-1),                    &                 
+            itimestep,restart,config_flags%fire_fuel_read,config_flags%fire_fuel_cat, &  ! in scalars
+            grid%dt,grid%dx,grid%dy,                    &
+            grid%u_frame,grid%v_frame,                  &
+            unit_fxlong,unit_fxlat,                           & ! coordinates of grid center
+            config_flags%fire_ext_grnd,config_flags%fire_ext_crwn,config_flags%fire_crwn_hgt, &
+            config_flags%fire_wind_height,              &  ! height of wind input to fire spread formula
+            fire_num_ignitions,                                & 
+            fire_ignition_longlat,      &
+            ignition_line,              &
+            grid%u_2,grid%v_2,           &          ! atm arrays in
+            grid%ph_2,grid%phb,               & ! geopotential
+            grid%z0,                        & ! roughness height
+            grid%ht,                        &                         ! terrain height
+            grid%xlong,grid%xlat,                         & ! coordinates of atm grid centers, for ignition location           
+            grid%lfn,grid%tign_g,grid%fuel_frac,          & ! state arrays, fire grid
+            grid%fire_area,                               & ! redundant, for display, fire grid
+            lfn_out,                                      & ! work - one timestep    
+            grid%avg_fuel_frac,                           & ! out redundant arrays, atm grid
+            grid%grnhfx,grid%grnqfx,grid%canhfx,grid%canqfx, & ! out redundant arrays, atm grid
+            grid%uah,grid%vah,                          &
+            grid%fgrnhfx,grid%fgrnqfx,grid%fcanhfx,grid%fcanqfx, & ! out redundant arrays, atm grid
+            grid%ros,                                   & ! rate of spread
+            grid%fxlong,grid%fxlat,                           &       
+            grid%nfuel_cat,                               & ! input, or internal for safekeeping
+            grid%fuel_time,                      & 
+            fp &
+        )
+
+#ifdef DM_PARALLEL
+            if(fire_ifun.eq.2)then
+!               halo exchange on all fuel data width 2
+#include "HALO_FIRE_FUEL.inc"
+            endif
+#endif
+
+                
+
+      enddo
+    enddo
+    if(tsteps>0)call crash('sfire_driver_em: test run of uncoupled fire model completed')
+
+end subroutine sfire_driver_em
+
+!
+!*******************
+!
+
+! module_fr_sfire_driver%%sfire_driver
+subroutine sfire_driver_phys (ifun,need_lfn_update,    &
+    ids,ide, kds,kde, jds,jde,                    & ! atm grid dimensions
+    ims,ime, kms,kme, jms,jme,                    &
+    ips,ipe, kps,kpe, jps,jpe,                    &
+    ifds, ifde, jfds, jfde,                       & ! fire grid dimensions
+    ifms, ifme, jfms, jfme,                       &
+    ifps, ifpe, jfps, jfpe,                       & ! fire patch in - will use smaller
+    ir,jr,                                        & ! atm/fire grid ratio
+    num_tiles,i_start,i_end,j_start,j_end,        & ! atm grid tiling
+    itimestep,restart,ifuelread,nfuel_cat0,dt,dx,dy,      & ! in scalars
+    u_frame,v_frame,                              &
+    unit_fxlong,unit_fxlat,                       & ! fxlong, fxlat units in m  
+    fire_ext_grnd,fire_ext_crwn,fire_crwn_hgt,    &
+    fire_wind_height,                             & ! for vertical wind interpolation
+    num_ignitions,                                & 
+    ignition_longlat,                             &
+    ignition_line,                                &
+    u,v,                                       & ! in arrays, atm grid
+    ph,phb,                                       &
+    z0,zs,                                        & 
+    xlong,xlat,                                   &
+    lfn,tign,fuel_frac,                           & ! state arrays, fire grid
+    fire_area,                                    & ! redundant state, fire grid
+    lfn_out,                                      & ! out level set function    
+    avg_fuel_frac,                                &
+    grnhfx,grnqfx,canhfx,canqfx,                  & ! out redundant arrays, atm grid  
+    uah,vah,                                      & ! out atm grid
+    fgrnhfx,fgrnqfx,fcanhfx,fcanqfx,              & ! out redundant arrays, fire grid
+    ros,                                          &
+    fxlong,fxlat,                                 & !  
+    nfuel_cat,                                    & ! in array, data, fire grid, or constant internal
+    fuel_time,                                & ! save constant internal data, fire grid
+    fp                                           & ! fire params
+    )
+USE module_dm, only:wrf_dm_maxval
+
+implicit none
+
+!*** arguments
+
+integer, intent(in)::ifun,                        &
+    ids,ide, kds,kde, jds,jde,                    & ! atm domain bounds
+    ims,ime, kms,kme, jms,jme,                    & ! atm memory bounds 
+    ips,ipe, kps,kpe, jps,jpe,                    & ! atm patch bounds
+    ifds, ifde, jfds, jfde,                       & ! fire domain bounds
+    ifms, ifme, jfms, jfme,                       & ! fire memory bounds
+    ifps, ifpe, jfps, jfpe,                       & ! fire patch bounds
+    ir,jr,                                        & ! atm/fire grid refinement ratio
+    itimestep,                                    & ! number of this timestep
+    ifuelread,                                    & ! how to initialize nfuel_cat:
+                                                       ! -1=not at all, done outside 
+                                                       ! 0=from nfuel_cat0
+                                                       ! 1=from altitude
+                                                       ! 2=from file
+    nfuel_cat0,                                   & ! fuel category to initialize everything to
+    num_tiles                                       ! number of tiles
+
+logical, intent(in)::restart
+    
+
+logical, intent(out)::need_lfn_update
+
+integer,dimension(num_tiles),intent(in) :: i_start,i_end,j_start,j_end  ! atm grid tiling
+
+real, intent(in):: &
+    dt,                                           & ! time step
+    dx,dy,                                        & ! atm grid step
+    u_frame,v_frame,                              & ! velocity offset
+    unit_fxlong,unit_fxlat,                       & ! fxlong, fxlat units in m  
+    fire_crwn_hgt,                                & ! lowest height crown fire heat is released (m)
+    fire_ext_grnd,                                & ! extinction depth of surface fire heat flux (m)
+    fire_ext_crwn,                                & ! wind height for vertical interploation to fire spread
+    fire_wind_height 
+
+
+integer, intent(in):: num_ignitions                 ! number of ignitions, can be 0
+integer, intent(in):: ignition_longlat       ! if 1 ignition give as long/lat, otherwise as m from lower left corner
+TYPE (ignition_line_type), DIMENSION(num_ignitions), intent(out):: ignition_line
+
+real,intent(in),dimension(ims:ime,kms:kme,jms:jme)::u,v, & ! wind velocity (m/s) (staggered atm grid) 
+                              ph, phb                      ! geopotential (w-points atm grid)
+real,intent(in),dimension(ims:ime, jms:jme)::   z0, &    ! roughness height
+                                                zs       ! terrain height  
+real,intent(out),dimension(ims:ime,jms:jme)::&
+    uah,                                           & ! atm wind at fire_wind_height, diagnostics
+    vah                                              ! atm wind at fire_wind_height, diagnostics
+
+real, dimension(ims:ime, jms:jme), intent(inout)::xlong, xlat ! inout because of extension at bdry
+    
+real, intent(inout), dimension(ifms:ifme,jfms:jfme):: &
+    nfuel_cat                                       ! fuel data; can be also set inside (cell based, fire grid)
+
+real, intent(inout), dimension(ifms:ifme, jfms:jfme)::     &
+    lfn,tign,fuel_frac,                        &     ! state: level function, ign time, fuel left
+    lfn_out                                    ! fire wind velocities
+
+real, intent(out), dimension(ifms:ifme, jfms:jfme)::  &
+    fire_area                                        ! fraction of each cell burning
+
+real, intent(out), dimension(ims:ime, jms:jme):: &  ! redundant arrays, for display purposes only (atm grid)
+    avg_fuel_frac,                               &  ! average fuel fraction
+    grnhfx,                                      &  ! heat flux from surface fire (W/m^2) 
+    grnqfx,                                      &  ! moisture flux from surface fire (W/m^2) 
+    canhfx,                                      &  ! heat flux from crown fire (W/m^2) 
+    canqfx                                         ! moisture flux from crown fire (W/m^2) 
+
+real, intent(out), dimension(ifms:ifme, jfms:jfme):: &  ! redundant arrays, for display only, fire grid
+    fgrnhfx,                                      &  ! heat flux from surface fire (W/m^2) 
+    fgrnqfx,                                      &  ! moisture flux from surface fire (W/m^2) 
+    fcanhfx,                                      &  ! heat flux from crown fire (W/m^2) 
+    fcanqfx,                                      &   ! moisture flux from crown fire (W/m^2) 
+    ros                                             ! fire rate of spread (m/s)
+
+!  ***** data (constant in time) *****
+
+real, dimension(ifms:ifme, jfms:jfme), intent(inout)::fxlong,fxlat ! fire mesh coordinates
+real, intent(out), dimension(ifms:ifme, jfms:jfme)::fuel_time   ! fire params arrays
+
+type(fire_params),intent(inout)::fp
+    
+!*** local
+real :: dxf,dyf,time_start,latm, s
+integer :: its,ite,jts,jte,kts,kte, &            ! tile
+    ij,i,j,k,id,pid,ipe1,jpe1,ite1,jte1, &
+    ifts,ifte,jfts,jfte                          ! fire tile
+character(len=128)::msg
+character(len=3)::kk
+integer::ignitions_done_tile(num_tiles),ignited_tile(num_ignitions,num_tiles)
+integer::ignitions_done,ignited_patch(num_ignitions),idex,jdex
+
+
+!*** executable
+
+! time - assume dt does not change
+time_start = itimestep * dt
+
+! fire mesh step
+dxf=dx/ir
+dyf=dy/jr
+
+
+
+!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+write(msg,'(a,2f15.6)')'atmosphere mesh step:',dx,dy
+call message(msg)
+write(msg,'(a,2f15.6)')'fire mesh step:      ',dxf,dyf
+call message(msg)
+write(msg,7001)'atm domain      ','ids',ids,ide,jds,jde
+call message(msg)                    
+write(msg,7001)'atm memory      ','ims',ims,ime,jms,jme
+call message(msg)                    
+write(msg,7001)'atm patch       ','ips',ips,ipe,jps,jpe
+call message(msg)                    
+write(msg,7001)'fire domain     ','ifds',ifds,ifde,jfds,jfde
+call message(msg)                    
+write(msg,7001)'fire memory     ','ifms',ifms,ifme,jfms,jfme
+call message(msg)                    
+write(msg,7001)'fire patch      ','ifps',ifps,ifpe,jfps,jfpe
+call message(msg)                    
+!$OMP END CRITICAL(SFIRE_DRIVER_CRIT)
+
+! check mesh dimensions
+call check_fmesh(ids,ide,ifds,ifde,ir,'id')           ! check if atm and fire grids line up
+call check_fmesh(jds,jde,jfds,jfde,jr,'jd')
+call check_fmesh(ips,ipe,ifps,ifpe,ir,'ip')
+call check_fmesh(jps,jpe,jfps,jfpe,jr,'jp')
+call check_mesh_2dim(ips,ipe,jps,jpe,ims,ime,jms,jme)        ! check if atm patch fits in atm array
+call check_mesh_2dim(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme) ! check if fire patch fits in fire array
+call check_mesh_2dim(ips,ipe,jps,jpe,ids,ide,jds,jde)        ! check if atm patch fits in atm domain
+call check_mesh_2dim(ifps,ifpe,jfps,jfpe,ifds,ifde,jfds,jfde) ! check if fire patch fits in fire domain
+
+!$OMP SINGLE
+! init rest of fuel tables with derived constants
+if(ifun.eq.1) then
+   call init_fuel_cats  ! common for all threads
+endif
+!$OMP END SINGLE
+
+
+pid=0
+if(fire_print_file.gt.0)then
+    if(itimestep.le.fire_print_file.or.mod(itimestep,fire_print_file).eq.0)pid=itimestep ! print 1-fire_print_file then every fire_print_file-th
+endif
+
+if(ifun.eq.3)then
+ call print_chsum(itimestep,ims,ime,kms,kme,jms,jme,ids,ide,kds,kde,jds,jde,ips,ipe,kps,kpe,jps,jpe,1,0,0,u,'u')
+ call print_chsum(itimestep,ims,ime,kms,kme,jms,jme,ids,ide,kds,kde,jds,jde,ips,ipe,kps,kpe,jps,jpe,0,0,1,v,'v')
+ call print_chsum(itimestep,ims,ime,kms,kme,jms,jme,ids,ide,kds,kde,jds,jde,ips,ipe,kps,kpe,jps,jpe,0,1,0,ph,'ph')
+endif
+
+! fake atm tile bounds
+kts=kps
+kte=kpe
+
+! staggered atm patch bounds
+ipe1=ifval(ipe.eq.ide,ipe+1,ipe)
+jpe1=ifval(jpe.eq.jde,jpe+1,jpe)
+
+! set up fire tiles & interpolate to fire grid
+!$OMP PARALLEL DO PRIVATE(ij,its,ite,jts,jte,ite1,jte1,ifts,ifte,jfts,jfte,msg,id) &
+!$OMP SCHEDULE(STATIC)
+do ij=1,num_tiles
+
+    id = ifval(pid.ne.0,pid+ij*10000,0) ! for print
+
+    ignitions_done_tile(ij)=0
+
+    ! set up tile bounds    
+    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
+    ifts= (its-ids)*ir+ifds       ! start fire tile in i
+    ifte= (ite-ids+1)*ir+ifds-1   ! end fire tile in i
+    jfts= (jts-jds)*jr+jfds       ! start fire tile in j
+    jfte= (jte-jds+1)*jr+jfds-1   ! end fire tile in j
+        
+! staggered atm tile bounds
+    ite1=ifval(ite.eq.ide,ite+1,ite)
+    jte1=ifval(jte.eq.jde,jte+1,jte)
+
+!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+    write(msg,'(a,i3,1x,a,i7,1x,a,i3)')'tile=',ij,' id=',id,' ifun=',ifun
+    call message(msg)
+    write(msg,7001)'atm tile   ','its',its,ite,jts,jte
+    call message(msg)                   
+    write(msg,7001)'fire tile  ','ifts',ifts,ifte,jfts,jfte
+    call message(msg)                    
+!$OMP END CRITICAL(SFIRE_DRIVER_CRIT)
+
+    ! check the tiles
+    call check_mesh_2dim(its,ite,jts,jte,ips,ipe,jps,jpe)                 ! check if atm tile fits in atm patch
+    call check_mesh_2dim(ifts,ifte,jfts,jfte,ifps,ifpe,jfps,jfpe)         ! check if fire tile fits in fire patch
+    call check_mesh_2dim(ifts-2,ifte+2,jfts-2,jfte+2,ifms,ifme,jfms,jfme)! check if fire node tile fits in memory
+
+
+!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+    write(msg,'(a,i6,a,2(f15.6,a))')'time step',itimestep,' at',time_start,' duration',dt,'s'
+    call message(msg)
+    7001 format(a,' dimensions ',a4,':',i6,' to ',i6,' by ',i6,' to ',i6)
+    write(msg,'(a,2i9)')'refinement ratio:',ir,jr
+!$OMP END CRITICAL(SFIRE_DRIVER_CRIT)
+
+    if(ifun.eq.1)then   ! set terrain
+
+      if(restart)then
+          
+          call message('restart - topo initialization skipped')
+
+      else
+!
+!        call print_2d_stats(ips,ipe,jps,jpe,ims,ime,jms,jme,zs,'driver:zs')
+!    
+!        ! interpolate terrain height
+!        if(fire_topo_from_atm.eq.1)then
+!            call interpolate_z2fire(id,                 & ! for debug output, <= 0 no output
+!                ids,ide,  jds,jde,                    & ! atm grid dimensions
+!                ims,ime,  jms,jme,                    &
+!                ips,ipe,jps,jpe,                              &
+!                its,ite,jts,jte,                              &
+!                ifds, ifde, jfds, jfde,                       & ! fire grid dimensions
+!                ifms, ifme, jfms, jfme,                       &
+!                ifts,ifte,jfts,jfte,                          &
+!                ir,jr,                                        & ! atm/fire grid ratio
+!                zs,                                       & ! atm grid arrays in
+!                fp%zsf)                                      ! fire grid arrays out
+!        else
+!!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+!           write(msg,'(a,i3,a)')'fire_topo_from_atm=',fire_topo_from_atm,' assuming ZSF set, interpolation skipped'
+!!$OMP END CRITICAL(SFIRE_DRIVER_CRIT)
+!        endif
+
+        if(ignition_longlat .eq.0)then
+            ! set ideal fire mesh coordinates - used for ignition only
+            ! do not forget to set unit_fxlong, unit_fxlat outside of parallel loop
+            !call set_ideal_coord( dxf,dyf, &
+            !    ifds,ifde,jfds,jfde,  &
+            !    ifms,ifme,jfms,jfme,  &
+            !    ifts,ifte,jfts,jfte,  &
+            !    fxlong,fxlat          )
+            !call set_ideal_coord( dx,dy, &
+            !    ids,ide,jds,jde,  &
+            !    ims,ime,jms,jme,  &
+            !    its,ite,jts,jte,  &
+            !    xlong,xlat          )
+        elseif(use_atm_vars)then
+            ! assume halo xlong xlat
+            ! interpolate nodal coordinates
+
+#ifdef DEBUG_OUT
+         call write_array_m(its,ite,jts,jte,ims,ime,jms,jme,xlat,'xlat',id)
+         call write_array_m(its,ite,jts,jte,ims,ime,jms,jme,xlong,'xlong',id)
+#endif
+        call interpolate_z2fire(id,                 & ! for debug output, <= 0 no output
+            ids,ide,  jds,jde,                    & ! atm grid dimensions
+            ims,ime,  jms,jme,                    &
+            ips,ipe,jps,jpe,                              &
+            its,ite,jts,jte,                              &
+            ifds, ifde, jfds, jfde,                       & ! fire grid dimensions
+            ifms, ifme, jfms, jfme,                       &
+            ifts,ifte,jfts,jfte,                          &
+            ir,jr,                                        & ! atm/fire grid ratio
+            xlat,                                       & ! atm grid arrays in
+            fxlat)                                      ! fire grid arrays out
+
+        call interpolate_z2fire(id,                 & ! for debug output, <= 0 no output
+            ids,ide,  jds,jde,                    & ! atm grid dimensions
+            ims,ime,  jms,jme,                    &
+            ips,ipe,jps,jpe,                              &
+            its,ite,jts,jte,                              &
+            ifds, ifde, jfds, jfde,                       & ! fire grid dimensions
+            ifms, ifme, jfms, jfme,                       &
+            ifts,ifte,jfts,jfte,                          &
+            ir,jr,                                        & ! atm/fire grid ratio
+            xlong,                                       & ! atm grid arrays in
+            fxlong)                                      ! fire grid arrays out
+
+        endif
+
+     endif
+
+    elseif(ifun.eq.2)then  
+               
+        ! after the loop where zsf created exited and all synced
+        call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fp%zsf,'driver_phys:zsf')        
+
+    elseif(ifun.eq.3)then  ! interpolate winds to the fire grid
+    
+      if(use_atm_vars)then                                  
+     
+        call write_array_m(its,ite,jts,jte,ims,ime,jms,jme,z0,'z0',id)
+        call write_array_m3(its,ite1,kts,kde-1,jts,jte,ims,ime,kms,kme,jms,jme,u,'u_2',id)
+        call write_array_m3(its,ite,kts,kde-1,jts,jte1,ims,ime,kms,kme,jms,jme,v,'v_2',id)
+        call write_array_m3(its,ite,kts,kde,jts,jte,ims,ime,kms,kme,jms,jme,ph,'ph_2',id)
+        call write_array_m3(its,ite,kts,kde,jts,jte,ims,ime,kms,kme,jms,jme,phb,'phb',id)
+        call interpolate_atm2fire(id,                     & ! flag for debug output
+            fire_wind_height,                             & ! height to interpolate to
+            ids,ide, kds,kde, jds,jde,                    & ! atm grid dimensions
+            ims,ime, kms,kme, jms,jme,                    &
+            ips,ipe, jps,jpe,                             &
+            its,ite,jts,jte,                              &                    
+            ifds, ifde, jfds, jfde,                       & ! fire grid dimensions
+            ifms, ifme, jfms, jfme,                       &
+            ifps, ifpe, jfps, jfpe,                       & ! fire patch bounds
+            ifts, ifte, jfts, jfte,                       &
+            ir,jr,                                        & ! atm/fire grid ratio
+            u_frame, v_frame,                             & ! velocity frame correction
+            u,v,                                          & ! 3D atm grid arrays in
+            ph,phb,                                       &
+            z0,zs,                                        & ! 2D atm grid arrays in
+            uah,vah,                                      & ! 2D atm grid out
+            fp%vx,fp%vy)                                    ! fire grid arrays out
+      endif
+    
+    endif
+
+!   the following executes in any case
+
+    call sfire_model (id,ifun,restart,need_lfn_update,  &
+        num_ignitions,                          & ! switches
+        ifuelread,nfuel_cat0,                   & ! initialize fuel categories
+        ifds,ifde,jfds,jfde,                    & ! fire domain dims
+        ifms,ifme,jfms,jfme,                    & ! fire memory dims
+        ifps,ifpe,jfps,jfpe,                    &
+        ifts,ifte,jfts,jfte,                    & ! fire patch dims
+        time_start,dt,                          & ! time and increment
+        dxf,dyf,                                & ! fire mesh spacing
+        ignition_line,                          & ! description of ignition lines
+        ignitions_done_tile(ij),ignited_tile(1,ij),  &
+        fxlong,fxlat,unit_fxlong,unit_fxlat,      & ! fire mesh coordinates
+        lfn,lfn_out,tign,fuel_frac,                     & ! state: level function, ign time, fuel left
+        fire_area,                              & ! output: fraction of cell burning
+        fgrnhfx,fgrnqfx,                        & ! output: heat fluxes
+        ros,                                    & ! output: rate of spread for display
+        nfuel_cat,                              & ! fuel data per point 
+        fuel_time,                              & ! save derived internal data
+        fp                                      & ! fire coefficients
+    )
+    
+    if(ifun.eq.6)then ! heat fluxes into the atmosphere    
+    
+        call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fgrnhfx,'fire_driver:fgrnhfx')
+        call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fgrnqfx,'fire_driver:fgrnqfx')
+    
+        ! sum the fluxes over atm cells
+        if(use_atm_vars)then                                  
+          call sum_2d_cells(        &
+            ifms,ifme,jfms,jfme,  &
+            ifts,ifte,jfts,jfte,  &
+            fuel_frac,              &
+            ims, ime, jms, jme,   &
+            its,ite,jts,jte,      &
+            avg_fuel_frac)
+          call sum_2d_cells(        &
+            ifms,ifme,jfms,jfme,  &
+            ifts,ifte,jfts,jfte,  &
+            fgrnhfx,              &
+            ims, ime, jms, jme,   &
+            its,ite,jts,jte,      &
+            grnhfx)
+!comment out the next call to get results as before commit 55fd92051196b796891b60cb7ec1c4bdb8800078
+          call sum_2d_cells(        &
+            ifms,ifme,jfms,jfme,  &
+            ifts,ifte,jfts,jfte,  &
+            fgrnqfx,              &
+            ims, ime, jms, jme,   &
+            its,ite,jts,jte,      &
+            grnqfx)
+
+!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+          write(msg,'(a,f6.3)')'fire-atmosphere feedback scaling ',fire_atm_feedback
+!$OMP end CRITICAL(SFIRE_DRIVER_CRIT)
+	  call message(msg)
+          s = 1./(ir*jr)
+          do j=jts,jte
+            do i=its,ite
+                ! scale surface fluxes to get the averages
+                avg_fuel_frac(i,j)=avg_fuel_frac(i,j)*s
+                grnhfx(i,j)=fire_atm_feedback*grnhfx(i,j)*s
+                grnqfx(i,j)=fire_atm_feedback*grnqfx(i,j)*s
+                ! we do not have canopy fluxes yet...
+                canhfx(i,j)=0
+                canqfx(i,j)=0
+            enddo
+          enddo
+
+          call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme,grnhfx,'fire_driver:grnhfx')
+          call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme,grnqfx,'fire_driver:grnqfx')
+       endif
+
+    endif ! ifun=6
+
+enddo ! tiles
+!$OMP END PARALLEL DO
+
+#ifdef DEBUG_OUT
+if(ifun.eq.1)then
+    if(pid.ne.0)then
+        call write_array_m(ips,ipe,jps,jpe,ims,ime,jms,jme,zs,'zs',pid)
+        call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,fp%zsf,'zsf',pid)
+    endif
+endif
+#endif
+
+if (ifun.eq.3)then
+    ignitions_done=ignitions_done_tile(1) ! all should be the same
+    do i=1,ignitions_done
+!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+        write(msg,'(2(a,i4,1x))')'sfire_driver_phys: checking ignition ',i,' of ',ignitions_done
+!$OMP END CRITICAL(SFIRE_DRIVER_CRIT)
+        call message(msg)
+        ignited_patch(i)=0
+        do ij=1,num_tiles
+            ignited_patch(i)=ignited_patch(i)+ignited_tile(i,ij)
+        enddo
+#ifdef DM_PARALLEL
+        call message('sfire_driver_phys: checking ignitions, collect counts')
+        call wrf_dm_maxval(ignited_patch(i),idex,jdex)
+        call message('sfire_driver_phys: collected')
+#endif
+        if(ignited_patch(i).eq.0)then
+            call crash('sfire_driver_phys: Ignition failed, no nodes ignited. Bad coordinates?')
+        endif
+    enddo
+
+ call print_chsum(itimestep,ims,ime,1,1,jms,jme,ids,ide,1,1,jds,jde,ips,ipe,1,1,jps,jpe,1,0,0,uah,'uah')
+ call print_chsum(itimestep,ims,ime,1,1,jms,jme,ids,ide,1,1,jds,jde,ips,ipe,1,1,jps,jpe,0,0,1,vah,'vah')
+ call print_chsum(itimestep,ifms,ifme,1,1,jfms,jfme,ifds,ifde,1,1,jfds,jfde,ifps,ifpe,1,1,jfps,jfpe,0,0,0,fp%vx,'uf')
+ call print_chsum(itimestep,ifms,ifme,1,1,jfms,jfme,ifds,ifde,1,1,jfds,jfde,ifps,ifpe,1,1,jfps,jfpe,0,0,0,fp%vy,'vf')
+#ifdef DEBUG_OUT
+    if(pid.gt.0)then
+        call write_array_m(ips,ipe1,jps,jpe,ims,ime,jms,jme,uah,'uah',pid)
+        call write_array_m(ips,ipe,jps,jpe1,ims,ime,jms,jme,vah,'vah',pid)
+        call write_array_m(ips,ipe,jps,jpe,ims,ime,jms,jme,grnhfx,'grnhfx',pid)
+        call write_array_m(ips,ipe,jps,jpe,ims,ime,jms,jme,grnqfx,'grnqfx',pid)
+        call write_array_m3(ips,ipe1,kds,kde+1,jps,jpe,ims,ime,kms,kme,jms,jme,u,'u',pid)
+        call write_array_m3(ips,ipe,kds,kde+1,jps,jpe1,ims,ime,kms,kme,jms,jme,v,'v',pid)
+        call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,fp%vx,'uf',pid)
+        call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,fp%vy,'vf',pid)
+    endif
+#endif
+endif
+
+if(ifun.eq.5)then
+#ifdef DEBUG_OUT
+    if(pid.gt.0)then
+        call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,lfn,'lfn',pid)
+        call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,tign,'tign',pid)
+    endif
+#endif
+endif
+
+if(ifun.eq.6)then
+    call print_chsum(itimestep,ifms,ifme,1,1,jfms,jfme,ifds,ifde,1,1,jfds,jfde,ifps,ifpe,1,1,jfps,jfpe,0,0,0,fgrnhfx,'fgrnhfx')
+    call print_chsum(itimestep,ifms,ifme,1,1,jfms,jfme,ifds,ifde,1,1,jfds,jfde,ifps,ifpe,1,1,jfps,jfpe,0,0,0,fgrnqfx,'fgrnqfx')
+    call print_chsum(itimestep,ims,ime,1,1,jms,jme,ids,ide,1,1,jds,jde,ips,ipe,1,1,jps,jpe,0,0,0,grnhfx,'grnhfx')
+    call print_chsum(itimestep,ims,ime,1,1,jms,jme,ids,ide,1,1,jds,jde,ips,ipe,1,1,jps,jpe,0,0,0,grnqfx,'grnqfx')
+#ifdef DEBUG_OUT
+    if(pid.gt.0)then
+        call write_array_m(ips,ipe,jps,jpe,ims,ime,jms,jme,grnhfx,'grnhfx',pid)
+        call write_array_m(ips,ipe,jps,jpe,ims,ime,jms,jme,grnqfx,'grnqfx',pid)
+        call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,fuel_frac,'fuel_frac',pid)
+        call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,fgrnhfx,'fgrnhfx',pid)
+        call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,fgrnqfx,'fgrnqfx',pid)
+    endif
+#endif
+endif
+
+end subroutine sfire_driver_phys
+!
+!*******************
+!
+
+subroutine fire_ignition_convert (config_flags,fire_max_ignitions,fire_ignition_longlat, &
+    ignition_line,fire_num_ignitions,unit_fxlong,unit_fxlat)
+    USE module_configure, only : grid_config_rec_type
+    implicit none
+! create ignition arrays from scalar flags
+!*** arguments
+    TYPE (grid_config_rec_type) , INTENT(IN)          :: config_flags
+    integer, intent(in)::fire_max_ignitions
+    TYPE (ignition_line_type), DIMENSION(fire_max_ignitions), intent(out):: ignition_line ! any values from input discarded 
+    integer, intent(out)::fire_num_ignitions,fire_ignition_longlat
+    real, intent(out)::unit_fxlong,unit_fxlat
+!*** local
+    integer::i
+    logical:: real,ideal
+    real::lat_ctr,lon_ctr
+!*** executable
+    ! this is only until I figure out how to input arrays through the namelist...
+    if(fire_max_ignitions.lt.5)call crash('fire_max_ignitions too small')
+    ! figure out which kind of coordinates from the first given
+    ideal=config_flags%fire_ignition_start_x1 .ne.0. .or. config_flags%fire_ignition_start_y1 .ne. 0.
+    real=config_flags%fire_ignition_start_lon1 .ne. 0. .or. config_flags%fire_ignition_start_lat1 .ne. 0.
+    if(ideal)call message('Using ideal ignition coordinates, m from the lower left domain corner')
+    if(real)call message('Using real ignition coordinates, longitude and latitude')
+    if(ideal.and.real)call crash('Only one of the ideal or real coordinates may be given')
+
+    fire_ignition_longlat=0  ! default, if no ignition
+    if(ideal)then
+       ! use values from _x and _y variables
+       fire_ignition_longlat=0
+       ignition_line(1)%start_x=config_flags%fire_ignition_start_x1
+       ignition_line(1)%start_y=config_flags%fire_ignition_start_y1
+       ignition_line(1)%end_x=config_flags%fire_ignition_end_x1
+       ignition_line(1)%end_y=config_flags%fire_ignition_end_y1
+       ignition_line(2)%start_x=config_flags%fire_ignition_start_x2
+       ignition_line(2)%start_y=config_flags%fire_ignition_start_y2
+       ignition_line(2)%end_x=config_flags%fire_ignition_end_x2
+       ignition_line(2)%end_y=config_flags%fire_ignition_end_y2
+       ignition_line(3)%start_x=config_flags%fire_ignition_start_x3
+       ignition_line(3)%start_y=config_flags%fire_ignition_start_y3
+       ignition_line(3)%end_x=config_flags%fire_ignition_end_x3
+       ignition_line(3)%end_y=config_flags%fire_ignition_end_y3
+       ignition_line(4)%start_x=config_flags%fire_ignition_start_x4
+       ignition_line(4)%start_y=config_flags%fire_ignition_start_y4
+       ignition_line(4)%end_x=config_flags%fire_ignition_end_x4
+       ignition_line(4)%end_y=config_flags%fire_ignition_end_y4
+       ignition_line(5)%start_x=config_flags%fire_ignition_start_x5
+       ignition_line(5)%start_y=config_flags%fire_ignition_start_y5
+       ignition_line(5)%end_x=config_flags%fire_ignition_end_x5
+       ignition_line(5)%end_y=config_flags%fire_ignition_end_y5
+    endif
+    if(real)then
+        ! use values from _long and _lat
+       fire_ignition_longlat=1
+       ignition_line(1)%start_x=config_flags%fire_ignition_start_lon1
+       ignition_line(1)%start_y=config_flags%fire_ignition_start_lat1
+       ignition_line(1)%end_x=config_flags%fire_ignition_end_lon1
+       ignition_line(1)%end_y=config_flags%fire_ignition_end_lat1
+       ignition_line(2)%start_x=config_flags%fire_ignition_start_lon2
+       ignition_line(2)%start_y=config_flags%fire_ignition_start_lat2
+       ignition_line(2)%end_x=config_flags%fire_ignition_end_lon2
+       ignition_line(2)%end_y=config_flags%fire_ignition_end_lat2
+       ignition_line(3)%start_x=config_flags%fire_ignition_start_lon3
+       ignition_line(3)%start_y=config_flags%fire_ignition_start_lat3
+       ignition_line(3)%end_x=config_flags%fire_ignition_end_lon3
+       ignition_line(3)%end_y=config_flags%fire_ignition_end_lat3
+       ignition_line(4)%start_x=config_flags%fire_ignition_start_lon4
+       ignition_line(4)%start_y=config_flags%fire_ignition_start_lat4
+       ignition_line(4)%end_x=config_flags%fire_ignition_end_lon4
+       ignition_line(4)%end_y=config_flags%fire_ignition_end_lat4
+       ignition_line(5)%start_x=config_flags%fire_ignition_start_lon5
+       ignition_line(5)%start_y=config_flags%fire_ignition_start_lat5
+       ignition_line(5)%end_x=config_flags%fire_ignition_end_lon5
+       ignition_line(5)%end_y=config_flags%fire_ignition_end_lat5
+    endif
+    ! common to both cases
+       ignition_line(1)%ros=config_flags%fire_ignition_ros1 
+       ignition_line(1)%radius=config_flags%fire_ignition_radius1 
+       ignition_line(1)%start_time=config_flags%fire_ignition_start_time1 
+       ignition_line(1)%end_time=config_flags%fire_ignition_end_time1 
+       ignition_line(2)%ros=config_flags%fire_ignition_ros2 
+       ignition_line(2)%radius=config_flags%fire_ignition_radius2 
+       ignition_line(2)%start_time=config_flags%fire_ignition_start_time2 
+       ignition_line(2)%end_time=config_flags%fire_ignition_end_time2 
+       ignition_line(3)%ros=config_flags%fire_ignition_ros3 
+       ignition_line(3)%radius=config_flags%fire_ignition_radius3 
+       ignition_line(3)%start_time=config_flags%fire_ignition_start_time3 
+       ignition_line(3)%end_time=config_flags%fire_ignition_end_time3 
+       ignition_line(4)%ros=config_flags%fire_ignition_ros4 
+       ignition_line(4)%radius=config_flags%fire_ignition_radius4 
+       ignition_line(4)%start_time=config_flags%fire_ignition_start_time4 
+       ignition_line(4)%end_time=config_flags%fire_ignition_end_time4 
+       ignition_line(5)%ros=config_flags%fire_ignition_ros5 
+       ignition_line(5)%radius=config_flags%fire_ignition_radius5 
+       ignition_line(5)%start_time=config_flags%fire_ignition_start_time5
+       ignition_line(5)%end_time=config_flags%fire_ignition_end_time5
+
+    ! 
+        fire_num_ignitions=0      
+        do i=1,min(5,config_flags%fire_num_ignitions)
+            ! count the ignitions 
+            if(ignition_line(i)%radius.gt.0.)fire_num_ignitions=i
+            ! expand ignition data given as zero
+            if(ignition_line(i)%end_x.eq.0.)ignition_line(i)%end_x=ignition_line(i)%start_x
+            if(ignition_line(i)%end_y.eq.0.)ignition_line(i)%end_y=ignition_line(i)%start_y
+            if(ignition_line(i)%end_time.eq.0.)ignition_line(i)%end_time=ignition_line(i)%start_time
+        enddo
+
+    if(fire_ignition_longlat .eq. 0)then
+       ! ideal
+       !  ignition is in m
+       unit_fxlong=1.  
+       unit_fxlat=1.
+       ! will set fire mesh coordinates to uniform mesh below
+    else
+       ! real
+       lat_ctr=config_flags%cen_lat
+       lon_ctr=config_flags%cen_lon
+       ! 1 degree in m (approximate OK)
+       unit_fxlat=pi2/(360.*reradius)  ! earth circumference in m / 360 degrees
+       unit_fxlong=cos(lat_ctr*pi2/360.)*unit_fxlat  ! latitude
+    endif
+
+end subroutine fire_ignition_convert
+
+!
+!*****************************
+!
+
+subroutine interpolate_z2fire(id,                 & ! for debug output, <= 0 no output
+    ids,ide, jds,jde,                    & ! atm grid dimensions
+    ims,ime, jms,jme,                    &
+    ips,ipe,jps,jpe,                              &
+    its,ite,jts,jte,                              &
+    ifds, ifde, jfds, jfde,                       & ! fire grid dimensions
+    ifms, ifme, jfms, jfme,                       &
+    ifts,ifte,jfts,jfte,                          &
+    ir,jr,                                        & ! atm/fire grid ratio
+    zs,                                       & ! atm grid arrays in
+    zsf)                                      ! fire grid arrays out
+    
+implicit none
+!*** purpose: interpolate height
+
+!*** arguments
+integer, intent(in)::id,                          &
+    ids,ide, jds,jde,                    & ! atm domain bounds
+    ims,ime,jms,jme,                    & ! atm memory bounds 
+    ips,ipe,jps,jpe,                              &
+    its,ite,jts,jte,                              & ! atm tile bounds
+    ifds, ifde, jfds, jfde,                       & ! fire domain bounds
+    ifms, ifme, jfms, jfme,                       & ! fire memory bounds
+    ifts,ifte,jfts,jfte,                          & ! fire tile bounds
+    ir,jr                                         ! atm/fire grid refinement ratio
+real, intent(in), dimension(ims:ime, jms:jme):: zs  ! terrain height at atm cell centers                                        & ! terrain height  
+real,intent(out), dimension(ifms:ifme,jfms:jfme)::&
+    zsf                                             ! terrain height fire grid nodes
+    
+    
+!*** local
+real, dimension(its-2:ite+2,jts-2:jte+2):: za      ! terrain height
+integer:: i,j,jts1,jte1,its1,ite1,jfts1,jfte1,ifts1,ifte1,itso,jtso,iteo,jteo
+
+! terrain height
+
+    jts1=max(jts-1,jds) ! lower loop limit by one less when at end of domain
+    its1=max(its-1,ids) ! ASSUMES THE HALO IS THERE if patch != domain
+    jte1=min(jte+1,jde) 
+    ite1=min(ite+1,ide)
+    do j = jts1,jte1
+        do i = its1,ite1 
+            ! copy to local array
+            za(i,j)=zs(i,j)           
+        enddo
+    enddo
+
+    call continue_at_boundary(1,1,0., & ! do x direction or y direction
+    its-2,ite+2,jts-2,jte+2,           &                ! memory dims
+    ids,ide,jds,jde, &            ! domain dims - winds defined up to +1
+    ips,ipe,jps,jpe, &            ! patch dims - winds defined up to +1
+    its1,ite1,jts1,jte1, &                ! tile dims
+    itso,jtso,iteo,jteo, &
+    za)                               ! array
+
+    ! interpolate to tile plus strip along domain boundary if at boundary
+    jfts1=snode(jfts,jfds,-1) ! lower loop limit by one less when at end of domain
+    ifts1=snode(ifts,ifds,-1)
+    jfte1=snode(jfte,jfde,+1) 
+    ifte1=snode(ifte,ifde,+1)
+                     
+    call interpolate_2d(  &
+        its-2,ite+2,jts-2,jte+2, & ! memory dims atm grid tile
+        its1-1,ite1+1,jts1-1,jte1+1, & ! where atm grid values set
+        ifms,ifme,jfms,jfme,    & ! array dims fire grid
+        ifts1,ifte1,jfts1,jfte1,  & ! dimensions fire grid tile
+        ir,jr,                  & ! refinement ratio
+        real(ids),real(jds),ifds+(ir-1)*0.5,jfds+(jr-1)*0.5, & ! line up by lower left corner of domain
+        za,                     & ! in atm grid     
+        zsf)                      ! out fire grid
+
+end subroutine interpolate_z2fire
+!
+!*****************************
+!
+
+subroutine interpolate_atm2fire(id,               & ! for debug output, <= 0 no output
+    fire_wind_height,                             & ! interpolation height
+    ids,ide, kds,kde, jds,jde,                    & ! atm grid dimensions
+    ims,ime, kms,kme, jms,jme,                    &
+    ips,ipe,jps,jpe,                              &
+    its,ite,jts,jte,                              &
+    ifds, ifde, jfds, jfde,                       & ! fire grid dimensions
+    ifms, ifme, jfms, jfme,                       &
+    ifps, ifpe, jfps, jfpe,                       & ! fire patch bounds
+    ifts,ifte,jfts,jfte,                          &
+    ir,jr,                                        & ! atm/fire grid ratio
+    u_frame, v_frame,                             & ! velocity frame correction
+    u,v,                                          & ! atm grid arrays in
+    ph,phb,                                       &
+    z0,zs,                                        &
+    uah,vah,                                      &
+    uf,vf)                                          ! fire grid arrays out
+    
+implicit none
+!*** purpose: interpolate winds and height
+
+!*** arguments
+integer, intent(in)::id                           
+real, intent(in):: fire_wind_height                 ! height above the terrain for vertical interpolation
+integer, intent(in)::                             &
+    ids,ide, kds,kde, jds,jde,                    & ! atm domain bounds
+    ims,ime, kms,kme, jms,jme,                    & ! atm memory bounds 
+    ips,ipe,jps,jpe,                              &
+    its,ite,jts,jte,                              & ! atm tile bounds
+    ifds, ifde, jfds, jfde,                       & ! fire domain bounds
+    ifms, ifme, jfms, jfme,                       & ! fire memory bounds
+    ifps, ifpe, jfps, jfpe,                       & ! fire patch bounds
+    ifts,ifte,jfts,jfte,                          & ! fire tile bounds
+    ir,jr                                         ! atm/fire grid refinement ratio
+real, intent(in):: u_frame, v_frame                 ! velocity frame correction
+real,intent(in),dimension(ims:ime,kms:kme,jms:jme)::&
+    u,v,                                          & ! atm wind velocity, staggered  
+    ph,phb                                          ! geopotential
+real,intent(in),dimension(ims:ime,jms:jme)::&
+    z0,                                           & ! roughness height
+    zs                                              ! terrain height
+real,intent(out),dimension(ims:ime,jms:jme)::&
+    uah,                                           & ! atm wind at fire_wind_height, diagnostics
+    vah                                              ! 
+real,intent(out), dimension(ifms:ifme,jfms:jfme)::&
+    uf,vf                                           ! wind velocity fire grid nodes 
+    
+    
+!*** local
+character(len=256)::msg
+#define TDIMS its-2,ite+2,jts-2,jte+2
+real, dimension(its-2:ite+2,jts-2:jte+2):: ua,va   ! atm winds, interpolated over height, still staggered grid
+real, dimension(its-2:ite+2,kds:kde,jts-2:jte+2):: altw,altub,altvb,hgtu,hgtv ! altitudes
+integer:: i,j,k,ifts1,ifte1,jfts1,jfte1,ite1,jte1
+integer::itst,itet,jtst,jtet,itsu,iteu,jtsu,jteu,itsv,itev,jtsv,jtev
+integer::kdmax,its1,jts1,ips1,jps1
+integer::itsou,iteou,jtsou,jteou,itsov,iteov,jtsov,jteov
+real:: ground,loght,loglast,logz0,logfwh,ht,zr
+real::r_nan
+integer::i_nan
+equivalence (i_nan,r_nan)
+
+!*** executable
+
+! debug init local arrays
+i_nan=2147483647
+ua=r_nan
+va=r_nan
+altw=r_nan
+altub=r_nan
+hgtu=r_nan
+hgtv=r_nan
+
+
+if(kds.ne.1)then
+!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+  write(msg,*)'WARNING: bottom index kds=',kds,' should be 1?'
+  call message(msg)
+!$OMP END CRITICAL(SFIRE_DRIVER_CRIT)
+endif
+
+!                            ^ j
+!        ------------        |
+!        |          |         ----> i
+!        u    p     |
+!        |          |    nodes in cell (i,j)
+!        ------v-----    view from top     
+!
+!             v(ide,jde+1)
+!            -------x------        
+!            |            |      
+!            |            |      
+! u(ide,jde) x      x     x u(ide+1,jde) 
+!            | p(ide,hde) |   
+!            |            |   p=ph,phb,z0,...
+!            -------x------        
+!              v(ide,jde)
+!
+! staggered values set u(ids:ide+1,jds:jde) v(ids:ide,jds:jde+1)
+! p=ph+phb set at (ids:ide,jds:jde) 
+! location of u(i,j) needs p(i-1,j) and p(i,j)
+! location of v(i,j) needs p(i,j-1) and p(i,j)
+! *** NOTE need HALO in ph, phb
+! so we can compute only u(ids+1:ide,jds:jde) v(ids:ide,jds+1,jde)
+! unless we extend p at the boundary
+! but because we care about the fire way in the inside it does not matter
+! if the fire gets close to domain boundary the simulation is over anyway
+
+    ite1=snode(ite,ide,1)
+    jte1=snode(jte,jde,1)
+    ! do this in any case to check for nans
+    call print_3d_stats(its,ite1,kds,kde,jts,jte,ims,ime,kms,kme,jms,jme,u,'wind U in')
+    call print_3d_stats(its,ite,kds,kde,jts,jte1,ims,ime,kms,kme,jms,jme,v,'wind V in')
+
+    if(fire_print_msg.gt.0)then
+!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+       write(msg,'(a,f7.2,a)')'interpolate_atm2fire: log-interpolation of wind to',fire_wind_height,' m'
+       call message(msg)
+!$OMP END CRITICAL(SFIRE_DRIVER_CRIT)
+    endif
+
+    ! indexing
+       
+    ! file for u
+    itst=ifval(ids.eq.its,its,its-1)
+    itet=ifval(ide.eq.ite,ite,ite+1)
+    jtst=ifval(jds.ge.jts,jts,jts-1)
+    jtet=ifval(jde.eq.jte,jte,jte+1)
+
+if(fire_print_msg.ge.1)then
+!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+  write(msg,7001)'atm input  ','tile',its,ite,jts,jte
+  call message(msg)
+  write(msg,7001)'altw       ','tile',itst,itet,jtst,jtet
+  call message(msg)
+!$OMP END CRITICAL(SFIRE_DRIVER_CRIT)
+endif
+7001 format(a,' dimensions ',a4,':',i6,' to ',i6,' by ',i6,' to ',i6)
+
+    kdmax=kde-1   ! max layer to interpolate from, can be less
+
+    do j = jtst,jtet
+      do k=kds,kdmax+1
+        do i = itst,itet       
+          altw(i,k,j) = (ph(i,k,j)+phb(i,k,j))/g             ! altitude of the bottom w-point 
+        enddo
+      enddo
+    enddo
+
+! values at u points
+    itsu=ifval(ids.eq.its,its+1,its)  ! staggered direction
+    iteu=ifval(ide.eq.ite,ite,ite+1)  ! staggered direction
+    jtsu=ifval(jds.ge.jts,jts,jts-1)
+    jteu=ifval(jde.eq.jte,jte,jte+1)
+
+if(fire_print_msg.ge.1)then
+!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+  write(msg,7001)'u interp at','tile',itsu,iteu,jtsu,jteu
+  call message(msg)
+!$OMP END CRITICAL(SFIRE_DRIVER_CRIT)
+endif
+
+    do j = jtsu,jteu          
+      do k=kds,kdmax+1
+        do i = itsu,iteu       
+          altub(i,k,j)= 0.5*(altw(i-1,k,j)+altw(i,k,j))      ! altitude of the bottom point under u-point
+        enddo
+      enddo
+      do k=kds,kdmax
+        do i = itsu,iteu       
+          hgtu(i,k,j) =  0.5*(altub(i,k,j)+altub(i,k+1,j)) - altub(i,kds,j)  ! height of the u-point above the ground
+        enddo
+      enddo
+    enddo
+
+! values at v points
+    jtsv=ifval(jds.eq.jts,jts+1,jts)  ! staggered direction
+    jtev=ifval(jde.eq.jte,jte,jte+1)  ! staggered direction
+    itsv=ifval(ids.ge.its,its,its-1)
+    itev=ifval(ide.eq.ite,ite,ite+1)
+
+if(fire_print_msg.ge.1)then
+!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+  write(msg,7001)'v interp at','tile',itsv,itev,jtsv,jtev
+  call message(msg)
+!$OMP END CRITICAL(SFIRE_DRIVER_CRIT)
+endif
+    do j = jtsv,jtev          
+      do k=kds,kdmax+1
+        do i = itsv,itev       
+          altvb(i,k,j)= 0.5*(altw(i,k,j-1)+altw(i,k,j))      ! altitude of the bottom point under v-point
+        enddo
+      enddo
+      do k=kds,kdmax
+        do i = itsv,itev       
+          hgtv(i,k,j) =  0.5*(altvb(i,k,j)+altvb(i,k+1,j)) - altvb(i,kds,j)  ! height of the v-point above the ground
+        enddo
+      enddo
+    enddo
+
+#ifdef DEBUG_OUT
+        call write_array_m3(itsu,iteu,kds,kdmax,jtsu,jteu,its-2,ite+2,kds,kde,jts-2,jte+2,altub,'altub',id)
+        call write_array_m3(itsv,itev,kds,kdmax,jtsv,jtev,its-2,ite+2,kds,kde,jts-2,jte+2,altvb,'altvb',id)
+        call write_array_m3(itsu,iteu,kds,kdmax,jtsu,jteu,its-2,ite+2,kds,kde,jts-2,jte+2,hgtu,'hgtu',id)
+        call write_array_m3(itsv,itev,kds,kdmax,jtsv,jtev,its-2,ite+2,kds,kde,jts-2,jte+2,hgtv,'hgtv',id)
+#endif
+    logfwh = log(fire_wind_height)
+
+    ! interpolate u, staggered in X
+
+    do j = jtsu,jteu            ! compute on domain by 1 smaller, otherwise z0 and ph not available
+      do i = itsu,iteu        ! compute with halo 2
+        zr = 0.5*(z0(i,j)+z0(i-1,j)) ! interpolated roughness length under this u point
+        if(fire_wind_height > zr)then       !  
+          do k=kds,kdmax
+            ht = hgtu(i,k,j)      ! height of this u point above the ground
+            if( .not. ht < fire_wind_height) then ! found layer k this point is in
+              loght = log(ht)
+              if(k.eq.kds)then               ! first layer, log linear interpolation from 0 at zr
+                logz0 = log(zr)
+                ua(i,j)= u(i,k,j)*(logfwh-logz0)/(loght-logz0)
+              else                           ! log linear interpolation
+                loglast=log(hgtu(i,k-1,j))
+                ua(i,j)= u(i,k-1,j) + (u(i,k,j) - u(i,k-1,j)) * ( logfwh - loglast) / (loght - loglast)
+              endif
+              goto 10
+            endif
+            if(k.eq.kdmax)then                 ! last layer, still not high enough
+              ua(i,j)=u(i,k,j) 
+            endif
+          enddo
+10        continue
+        else  ! roughness higher than the fire wind height
+          ua(i,j)=0.
+        endif
+      enddo
+    enddo
+
+    ! interpolate v, staggered in Y
+
+    do j = jtsv,jtev
+      do i = itsv,itev
+        zr = 0.5*(z0(i,j-1)+z0(i,j)) ! roughness length under this v point
+        if(fire_wind_height > zr)then       !  
+          do k=kds,kdmax
+            ht = hgtv(i,k,j)      ! height of this u point above the ground
+            if( .not. ht < fire_wind_height) then ! found layer k this point is in
+              loght = log(ht)
+              if(k.eq.kds)then               ! first layer, log linear interpolation from 0 at zr
+                logz0 = log(zr)
+                va(i,j)= v(i,k,j)*(logfwh-logz0)/(loght-logz0)
+              else                           ! log linear interpolation
+                loglast=log(hgtv(i,k-1,j))
+                va(i,j)= v(i,k-1,j) + (v(i,k,j) - v(i,k-1,j)) * ( logfwh - loglast) / (loght - loglast)
+              endif
+              goto 11
+            endif
+            if(k.eq.kdmax)then                 ! last layer, still not high enough
+              va(i,j)=v(i,k,j) 
+            endif
+          enddo
+11        continue
+        else  ! roughness higher than the fire wind height
+          va(i,j)=0.
+        endif
+      enddo
+    enddo
+
+#ifdef DEBUG_OUT
+!   store the output for diagnostics
+    do j = jts,jte1
+      do i = its,ite1
+        uah(i,j)=ua(i,j)
+        vah(i,j)=va(i,j)
+      enddo
+    enddo
+
+    call write_array_m(its,ite1,jts,jte,ims,ime,jms,jme,uah,'uah_n',id) ! no reflection
+    call write_array_m(its,ite,jts,jte1,ims,ime,jms,jme,vah,'vah_n',id)
+#endif
+
+    ips1 = ifval(ips.eq.ids,ips+1,ips)
+    call continue_at_boundary(1,1,0., & ! x direction 
+       TDIMS,                  &! memory dims atm grid tile
+       ids+1,ide,jds,jde, &     ! domain dims - where u defined
+       ips1,ipe,jps,jpe, &     ! patch dims 
+       itsu,iteu,jtsu,jteu, & ! tile dims - in nonextended direction one beyond if at patch boundary but not domain
+       itsou,iteou,jtsou,jteou, & ! out, where set
+       ua)                           ! array
+
+    jps1 = ifval(jps.eq.jds,jps+1,jps)
+    call continue_at_boundary(1,1,0., & ! y direction 
+       TDIMS,                  & ! memory dims atm grid tile
+       ids,ide,jds+1,jde, &      ! domain dims - where v wind defined
+       ips,ipe,jps1,jpe, &        ! patch dims 
+       itsv,itev,jtsv,jtev, & ! tile dims
+       itsov,iteov,jtsov,jteov, & ! where set
+       va)                           ! array
+
+!   store the output for diagnostics
+    do j = jts,jte1
+      do i = its,ite1
+        uah(i,j)=ua(i,j)
+        vah(i,j)=va(i,j)
+      enddo
+    enddo
+
+#ifdef DEBUG_OUT
+        call write_array_m(itsou,iteou,jtsou,jteou,TDIMS,ua,'ua',id)
+        call write_array_m(itsov,iteov,jtsov,jteov,TDIMS,va,'va',id)
+#endif
+
+!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+    ! don't have all values valid, don't check
+     write(msg,12)'atm mesh wind U at',fire_wind_height,' m'
+     call print_2d_stats(itsou,iteou,jtsou,jteou,TDIMS,ua,msg)
+     write(msg,12)'atm mesh wind V at',fire_wind_height,' m'
+     call print_2d_stats(itsov,iteov,jtsov,jteov,TDIMS,va,msg)
+12  format(a,f6.2,a)
+    call print_2d_stats(its,ite1,jts,jte,ims,ime,jms,jme,uah,'UAH')
+    call print_2d_stats(its,ite,jts,jte1,ims,ime,jms,jme,vah,'VAH')
+    !call write_array_m(its,ite1,jts,jte,ims,ime,jms,jme,uah,'uah',id)
+    !call write_array_m(its,ite,jts,jte1,ims,ime,jms,jme,vah,'vah',id)
+!$OMP END CRITICAL(SFIRE_DRIVER_CRIT)
+
+!      ---------------
+!     | F | F | F | F |   Example of atmospheric and fire grid with
+!     |-------|-------|   ir=jr=4.
+!     | F | F | F | F |   Winds are given at the midpoints of the sides of the atmosphere grid,
+!     ua------z-------|   interpolated to midpoints of the cells of the fine fire grid F.
+!     | F | F | F | F |   This is (1,1) cell of atmosphere grid, and [*] is the (1,1) cell of the fire grid.
+!     |---------------|   ua(1,1) <--> uf(0.5,2.5)
+!     | * | F | F | F |   va(1,1) <--> vf(2.5,0.5)
+!      -------va------    za(1,1) <--> zf(2.5,2.5)
+!
+!   ^ x2
+!   |  --------va(1,2)---------
+!   | |            |           |   Example of atmospheric and fire grid with
+!   | |            |           |   ir=jr=1.
+!   | |          za,zf         |   Winds are given at the midpoints of the sides of the atmosphere grid,
+!   | ua(1,1)----uf,vf-----ua(2,1) interpolated to midpoints of the cells of the (the same) fire grid 
+!   | |           (1,1)        |   ua(1,1) <--> uf(0.5,1) 
+!   | |            |           |   va(1,1) <--> vf(1,0.5) 
+!   | |            |           |   za(1,1) <--> zf(1,1)
+!   |  --------va(1,1)---------
+!   |--------------------> x1 
+!
+! Meshes are aligned by the lower left cell of the domain. Then in the above figure
+! u = node with the ua component of the wind at (ids,jds), midpoint of side
+! v = node with the va component of the wind at (ids,jds), midpoint of side
+! * = fire grid node at (ifds,jfds)
+! z = node with height, midpoint of cell
+! 
+! ua(ids,jds)=uf(ifds-0.5,jfds+jr*0.5-0.5)         = uf(ifds-0.5,jfds+(jr-1)*0.5)
+! va(ids,jds)=vf(ifds+ir*0.5-0.5,jfds-0.5)         = vf(ifds+(ir-1)*0.5,jfds-0.5)
+! za(ids,jds)=zf(ifds+ir*0.5-0.5,jfds+jr*0.5-0.5)  = zf(ifds+(ir-1)*0.5,jfds+(jr-1)*0.5)
+    
+    ! ifts1=max(snode(ifts,ifps,-1),ifds) ! go 1 beyond patch boundary but not at domain boundary
+    ! ifte1=min(snode(ifte,ifpe,+1),ifde)
+    ! jfts1=max(snode(jfts,jfps,-1),jfds)
+    ! jfte1=min(snode(jfte,jfpe,+1),jfde)
+
+    call interpolate_2d(  &
+        TDIMS,                  & ! memory dims atm grid tile
+        itsou,iteou,jtsou,jteou,& ! where set
+        ifms,ifme,jfms,jfme,    & ! array dims fire grid
+        ifts,ifte,jfts,jfte,& ! dimensions on the fire grid to interpolate to
+        ir,jr,                  & ! refinement ratio
+        real(ids),real(jds),ifds-0.5,jfds+(jr-1)*0.5, & ! line up by lower left corner of domain
+        ua,                     & ! in atm grid     
+        uf)                      ! out fire grid
+
+    call interpolate_2d(  &
+        TDIMS,                  & ! memory dims atm grid tile
+        itsov,iteov,jtsov,jteov,& ! where set 
+        ifms,ifme,jfms,jfme,    & ! array dims fire grid
+        ifts,ifte,jfts,jfte,& ! dimensions on the fire grid to interpolate to
+        ir,jr,                  & ! refinement ratio
+        real(ids),real(jds),ifds+(ir-1)*0.5,jfds-0.5, & ! line up by lower left corner of domain
+        va,                     & ! in atm grid     
+        vf)                      ! out fire grid
+
+call print_2d_stats_vec(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,uf,vf,'fire wind (m/s)')
+! call print_2d_stats_vec(ifts1,ifte1,jfts1,jfte1,ifms,ifme,jfms,jfme,uf,vf,'fire wind extended')
+#ifdef DEBUG_OUT
+        call write_array_m(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,uf,'uf1',id)
+        call write_array_m(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,vf,'vf1',id)
+        ! call write_array_m(ifts1,ifte1,jfts1,jfte1,ifms,ifme,jfms,jfme,uf,'uf1',id)
+        ! call write_array_m(ifts1,ifte1,jfts1,jfte1,ifms,ifme,jfms,jfme,vf,'vf1',id)
+#endif
+return
+
+end subroutine interpolate_atm2fire
+
+!
+!***
+!
+
+subroutine check_fmesh(ids,ide,ifds,ifde,ir,s)
+!*** purpose: check if fire and atm meshes line up
+implicit none
+!*** arguments
+integer, intent(in)::ids,ide,ifds,ifde,ir
+character(len=*),intent(in)::s
+!*** local
+character(len=128)msg
+!*** executable
+if ((ide-ids+1)*ir.ne.(ifde-ifds+1))then
+!$OMP CRITICAL(SFIRE_DRIVER_CRIT)
+    write(msg,1)s,ids,ide,ifds,ifde,ir
+1   format('module_fr_sfire_driver: incompatible bounds ',a,' atm ',i5,':',i5,' fire ',i5,':',i5,' ratio ',i3)    
+!$OMP END CRITICAL(SFIRE_DRIVER_CRIT)
+    call crash(msg)
+endif
+end subroutine check_fmesh
+
+!
+!*****************************
+!
+subroutine set_flags(config_flags)
+implicit none
+TYPE (grid_config_rec_type) , INTENT(IN)          :: config_flags
+! copy flags from wrf to module_fr_sfire_util
+! for instructions how to add a flag see the top of module_fr_sfire_util.F
+
+
+fire_print_msg          = config_flags%fire_print_msg
+fire_print_file         = config_flags%fire_print_file
+fuel_left_method        = config_flags%fire_fuel_left_method
+fuel_left_irl           = config_flags%fire_fuel_left_irl
+fuel_left_jrl           = config_flags%fire_fuel_left_jrl
+fire_const_time         = config_flags%fire_const_time
+fire_const_grnhfx       = config_flags%fire_const_grnhfx
+fire_const_grnqfx       = config_flags%fire_const_grnqfx
+fire_atm_feedback       = config_flags%fire_atm_feedback
+boundary_guard          = config_flags%fire_boundary_guard
+fire_back_weight        = config_flags%fire_back_weight
+fire_grows_only         = config_flags%fire_grows_only
+fire_upwinding          = config_flags%fire_upwinding
+fire_upwind_split       = config_flags%fire_upwind_split 
+fire_viscosity          = config_flags%fire_viscosity 
+fire_lfn_ext_up         = config_flags%fire_lfn_ext_up 
+fire_test_steps         = config_flags%fire_test_steps 
+!fire_topo_from_atm      = config_flags%fire_topo_from_atm
+fire_advection          = config_flags%fire_advection
+
+
+
+
+end subroutine set_flags
+
+end module module_fr_sfire_driver
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_driver_wrf.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_driver_wrf.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_driver_wrf.F	(revision 17)
@@ -0,0 +1,146 @@
+! WRF:MEDIATION_LAYER:FIRE_MODEL
+
+
+#define DEBUG_OUT
+
+module module_fr_sfire_driver_wrf
+! wrf-specific driver
+
+use module_fr_sfire_driver
+use module_fr_sfire_atm
+implicit none
+
+contains
+
+subroutine sfire_driver_em_init (grid , config_flags               & 
+            ,ids,ide, kds,kde, jds,jde                              &
+            ,ims,ime, kms,kme, jms,jme                              &
+            ,ips,ipe, kps,kpe, jps,jpe)
+
+    ! stub to call sfire_driver_em with irun=0 and omit last 3 args
+
+    USE module_domain , only: domain , get_ijk_from_subgrid
+    USE module_configure , only : grid_config_rec_type
+    implicit none
+
+    TYPE(domain) , TARGET          :: grid   ! data
+    TYPE (grid_config_rec_type) , INTENT(IN)          :: config_flags
+    integer, intent(in):: &
+             ids,ide, kds,kde, jds,jde                              &
+            ,ims,ime, kms,kme, jms,jme                              &
+            ,ips,ipe, kps,kpe, jps,jpe
+
+    ! local
+    integer :: &  ! fire mesh sizes
+             ifds,ifde, kfds,kfde, jfds,jfde,                              &
+             ifms,ifme, kfms,kfme, jfms,jfme,                              &
+             ifps,ifpe, kfps,kfpe, jfps,jfpe                              
+    ! dummies
+
+    real,dimension(1,1,1)::rho,z_at_w,dz8w
+
+    call message('sfire_driver_em_init: SFIRE initialization start')
+
+    ! get fire mesh dimensions
+    CALL get_ijk_from_subgrid (  grid ,                   &
+                            ifds,ifde, jfds,jfde,kfds,kfde,                        &
+                            ifms,ifme, jfms,jfme,kfms,kfme,                        &
+                            ifps,ifpe, jfps,jfpe,kfps,kfpe) 
+
+    call sfire_driver_em ( grid , config_flags               & 
+            ,1,3,0                        & ! ifun start, end, test steps
+            ,ids,ide, kds,kde, jds,jde                              &
+            ,ims,ime, kms,kme, jms,jme                              &
+            ,ips,ipe, kps,kpe, jps,jpe                              &
+            ,ifds,ifde, jfds,jfde                                   &
+            ,ifms,ifme, jfms,jfme                                   &
+            ,ifps,ifpe, jfps,jfpe                                   &
+            ) 
+
+    call message('sfire_driver_em_init: SFIRE initialization complete')
+
+end subroutine sfire_driver_em_init
+
+!
+!***
+!
+
+subroutine sfire_driver_em_step (grid , config_flags               & 
+            ,ids,ide, kds,kde, jds,jde                              &
+            ,ims,ime, kms,kme, jms,jme                              &
+            ,ips,ipe, kps,kpe, jps,jpe                              &
+            ,rho,z_at_w,dz8w ) 
+
+    ! stub to call sfire_driver_em 
+
+    USE module_domain, only: domain , get_ijk_from_subgrid
+    USE module_configure , only : grid_config_rec_type
+    USE module_fr_sfire_util, only : fire_test_steps
+    implicit none
+
+    TYPE(domain) , TARGET          :: grid   ! data
+    TYPE (grid_config_rec_type) , INTENT(IN)          :: config_flags
+    integer, intent(in):: &
+             ids,ide, kds,kde, jds,jde                              &
+            ,ims,ime, kms,kme, jms,jme                              &
+            ,ips,ipe, kps,kpe, jps,jpe
+    real,dimension(ims:ime, kms:kme, jms:jme),intent(in)::rho,z_at_w,dz8w
+
+    ! local
+    integer :: &  ! fire mesh sizes
+             ifds,ifde, kfds,kfde, jfds,jfde,                              &
+             ifms,ifme, kfms,kfme, jfms,jfme,                              &
+             ifps,ifpe, kfps,kfpe, jfps,jfpe                              
+    integer :: its,ite,jts,jte,kts,kte            ! atm tile
+    integer:: ij 
+
+    call message('sfire_driver_em_step: SFIRE step start')
+
+    ! get fire mesh dimensions
+    CALL get_ijk_from_subgrid (  grid ,                   &
+                            ifds,ifde, jfds,jfde,kfds,kfde,                        &
+                            ifms,ifme, jfms,jfme,kfms,kfme,                        &
+                            ifps,ifpe, jfps,jfpe,kfps,kfpe) 
+
+    call sfire_driver_em ( grid , config_flags               & 
+            ,3,6,fire_test_steps                                &
+            ,ids,ide, kds,kde, jds,jde                              &
+            ,ims,ime, kms,kme, jms,jme                              &
+            ,ips,ipe, kps,kpe, jps,jpe                              &
+            ,ifds,ifde, jfds,jfde                                   &
+            ,ifms,ifme, jfms,jfme                                   &
+            ,ifps,ifpe, jfps,jfpe                                   &
+            ) 
+
+    ! --- add heat and moisture fluxes to tendency variables by postulated decay
+    do ij=1,grid%num_tiles
+       ! SFIRE works on domain by 1 smaller, in last row&col winds are not set properly
+       its = grid%i_start(ij)             ! start atmospheric tile in i
+       ite = min(grid%i_end(ij),ide-1)    ! end atmospheric tile in i
+       jts = grid%j_start(ij)             ! start atmospheric tile in j
+       jte = min(grid%j_end(ij),jde-1)    ! end atmospheric tile in j
+       kts=kds
+       kte=kde
+
+       call fire_tendency(                 &
+            ids,ide-1, kds,kde, jds,jde-1, & ! domain dimensions
+            ims,ime, kms,kme, jms,jme,      &
+            its,ite, kts,kte, jts,jte,      & ! 
+            grid%grnhfx,grid%grnqfx,grid%canhfx,grid%canqfx,        & ! fluxes on atm grid 
+            config_flags%fire_ext_grnd,config_flags%fire_ext_crwn,config_flags%fire_crwn_hgt,                &
+            grid%ht,z_at_w,dz8w,grid%mut,rho,          &
+            grid%rthfrten,grid%rqvfrten)                ! out
+
+     enddo
+
+       ! debug print to compare
+
+       call print_3d_stats(its,ite,kts,kte,jts,jte,ims,ime,kms,kme,jms,jme,grid%rthfrten,'fire_driver_phys:rthfrten')
+       call print_3d_stats(its,ite,kts,kte,jts,jte,ims,ime,kms,kme,jms,jme,grid%rqvfrten,'fire_driver_phys:rqvfrten')
+
+    call message('sfire_driver_em_step: SFIRE step complete')
+            
+end subroutine sfire_driver_em_step
+
+end module module_fr_sfire_driver_wrf
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_model.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_model.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_model.F	(revision 17)
@@ -0,0 +1,444 @@
+!
+#define DEBUG_OUT
+
+module module_fr_sfire_model
+
+use module_fr_sfire_core
+use module_fr_sfire_util
+use module_fr_sfire_phys
+
+contains
+
+subroutine sfire_model (                    &
+    id,                                     & ! unique number for prints and debug
+    ifun,                                   & ! what to do see below
+    restart,                                &
+    need_lfn_update,                          & ! if lfn needs to be synced between tiles
+    num_ignitions,                          & ! number of ignitions before advancing
+    ifuelread,nfuel_cat0,                   & ! initialize fuel categories
+    ifds,ifde,jfds,jfde,                    & ! fire domain dims - the whole domain
+    ifms,ifme,jfms,jfme,                    & ! fire memory dims - how declared
+    ifps,ifpe,jfps,jfpe,                    & ! patch - nodes owned by this process
+    ifts,ifte,jfts,jfte,                    & ! fire tile dims  - this thread
+    time_start,dt,                          & ! time and increment
+    fdx,fdy,                                & ! fire mesh spacing,
+    ignition_line,                          & ! small array of ignition line descriptions
+    ignitions_done,ignited_tile,            &
+    coord_xf,coord_yf,unit_xf,unit_yf,      & ! fire mesh coordinates
+    lfn,lfn_out,tign,fuel_frac,fire_area,   & ! state: level function, ign time, fuel left, area burning
+    grnhfx,grnqfx,                          & ! output: heat fluxes
+    ros,                                    & ! output: rate of spread
+    nfuel_cat,                              & ! fuel data per point 
+    fuel_time,                              & ! save derived internal data
+    fp &
+) 
+
+! This subroutine implements the fire spread model.
+! All quantities are on the fire grid. It inputs
+! winds given on the nodes of the fire grid
+! and outputs the heat fluxes on the cells of the fire grid.
+! This subroutine has no knowledge of any atmospheric model.
+! This code was written to conform with the WRF parallelism model, however it
+! does not depend on it. It can be called with domain equal to tile.
+! Wind and height must be given on 1 more node beyond the domain bounds. 
+! The subroutine changes only array entries of the arguments in the tile.
+! Upon exit with ifun=2 (time step), lfn_out is to be copied into lfn by the caller.
+! When this subroutine is used on separate tiles that make a domain the value, the
+! it uses lfn on a strip of width 2 from neighboring tiles.
+!
+! All computation is done on one tile. 
+!
+! This subroutine is intended to be called in a loop like
+!
+! 
+! do ifun=1,6 (if initizalize run, otherwise 3,6)
+!   start parallel loop over tiles
+!       if ifun=1, set z and fuel data
+!       if ifun=3, set the wind arrays
+!       call sfire_model(....)
+!   end parallel loop over tiles
+!
+!   if need_lfn_update, halo exchange on lfn width 2
+!   
+!   if ifun=0
+!       halo exchange on z width 2
+!       halo exchange on fuel data width 1
+!   endif
+!   
+!   if ifun=3, halo exchange on winds width 2
+!    
+! enddo
+
+implicit none
+
+!*** arguments
+
+! control switches
+integer, intent(in) :: id
+integer, intent(in) :: ifun                 ! 1 = initialize run pass 1
+                                            ! 2 = initialize run pass 2
+                                            ! 3 = initialize timestep
+                                            ! 4 = do one timestep 
+                                            ! 5 = copy timestep output to input
+                                            ! 6 = compute output fluxes
+logical, intent(in):: restart               ! if true, use existing state
+logical, intent(out)::need_lfn_update       ! if true, halo update on lfn afterwards
+! scalar data
+integer, intent(in) :: num_ignitions        ! number of ignition lines
+integer, intent(in) :: ifuelread,nfuel_cat0 ! for set_fire_params
+integer, intent(in) :: ifds,ifde,jfds,jfde,&  ! fire domain bounds
+        ifps,ifpe,jfps,jfpe                ! patch - nodes owned by this process
+integer, intent(in) :: ifts,ifte,jfts,jfte  ! fire tile bounds
+integer, intent(in) :: ifms,ifme,jfms,jfme  ! fire memory array bounds
+REAL,INTENT(in) :: time_start,dt            ! starting time, time step
+REAL,INTENT(in) :: fdx,fdy                  ! spacing of the fire mesh
+! array data
+type(ignition_line_type), dimension (num_ignitions), intent(in):: ignition_line ! descriptions of ignition lines
+integer, intent(out):: ignited_tile(num_ignitions),ignitions_done
+real, dimension(ifms:ifme, jfms:jfme), intent(in):: & 
+    coord_xf,coord_yf                       !  node coordinates  
+real, intent(in):: unit_xf,unit_yf          !  coordinate units in m
+    
+! state
+REAL, INTENT(inout), dimension(ifms:ifme,jfms:jfme):: &
+    lfn   , &                               ! level function: fire is where lfn<0 (node)
+    tign  , &                               ! absolute time of ignition (node)
+    fuel_frac                               ! fuel fraction (node), currently redundant
+
+REAL, INTENT(out), dimension(ifms:ifme,jfms:jfme):: &
+    fire_area                               ! fraction of each cell burning
+    
+! output
+REAL, INTENT(out), dimension(ifms:ifme,jfms:jfme):: &
+    lfn_out, &                              !                              
+    grnhfx,grnqfx, &                        ! heat fluxes J/m^2/s  (cell)             
+    ros                                     ! output: rate of spread
+ 
+! constant arrays - set at initialization
+real, intent(inout), dimension(ifms:ifme, jfms:jfme)::nfuel_cat ! cell based, data, constant
+real,intent(inout),dimension(ifms:ifme,jfms:jfme):: fuel_time
+type(fire_params),intent(inout)::fp
+
+!*** local
+
+integer :: xifms,xifme,xjfms,xjfme  ! memory bounds for pass-through arguments to normal spread
+real, dimension(ifts:ifte,jfts:jfte)::fuel_frac_burnt,fuel_frac_end
+integer::ignited,ig,i,j,itso,iteo,jtso,jteo
+real::tbound,err,erri,errj,maxgrad,grad,tfa,thf,mhf,tqf,mqf,aw,mw
+character(len=128)::msg
+logical:: freeze_fire
+integer:: stat_lev=1
+
+!*** executable
+
+call check_mesh_2dim(ifts-1,ifte+1,jfts-1,jfte+1,ifms,ifme,jfms,jfme)
+
+xifms=ifms  ! dimensions for the include file
+xifme=ifme
+xjfms=jfms
+xjfme=jfme
+
+
+! init flags
+need_lfn_update=.false.
+ignitions_done=0
+freeze_fire = fire_const_time > 0. .and. time_start < fire_const_time
+
+if(ifun.eq.1)then       ! do nothing, init pass 1 is outside only
+elseif(ifun.eq.2)then   
+        ! initialize all arrays that the model will not change later
+
+        ! assuming halo on zsf done
+        ! extrapolate on 1 row of cells beyond the domain boundary
+        ! including on the halo regions 
+
+        call continue_at_boundary(1,1,0., & ! do x direction or y direction
+            ifms,ifme,jfms,jfme,           &                ! memory dims
+            ifds,ifde,jfds,jfde, &                     ! domain dims 
+            ifps,ifpe,jfps,jfpe, &            ! patch dims - winds defined up to +1
+            ifts,ifte,jfts,jfte, &                ! tile dims
+            itso,iteo,jtso,jteo, &              ! where set now
+            fp%zsf)                               ! array
+
+!       compute the gradients once for all
+        err=0.
+        maxgrad=0.
+        do j=jfts,jfte
+            do i=ifts,ifte
+                erri = fp%dzdxf(i,j) - (fp%zsf(i+1,j)-fp%zsf(i-1,j))/(2.*fdx)
+                errj = fp%dzdyf(i,j) - (fp%zsf(i,j+1)-fp%zsf(i,j-1))/(2.*fdy)
+                err=max(err,abs(erri),abs(errj))
+                grad=sqrt(fp%dzdxf(i,j)**2+fp%dzdyf(i,j)**2)
+                maxgrad=max(maxgrad,grad)
+            enddo
+        enddo
+!$OMP CRITICAL(SFIRE_MODEL_CRIT)
+        write(msg,*)'max gradient ',maxgrad,' max error against zsf',err
+!$OMP END CRITICAL(SFIRE_MODEL_CRIT)
+        call message(msg)
+
+        if(.not.restart)call set_nfuel_cat( &
+            ifms,ifme,jfms,jfme, &
+            ifts,ifte,jfts,jfte, &
+            ifuelread,nfuel_cat0,&
+            fp%zsf,nfuel_cat)            ! better not use the extrapolated zsf!!
+
+        ! uses nfuel_cat to set the other fuel data arrays
+        ! needs zsf on halo width 1 to compute the terrain gradient
+        if(.not.restart)call set_fire_params(   & 
+            ifds,ifde,jfds,jfde, &
+            ifms,ifme,jfms,jfme, &
+            ifts,ifte,jfts,jfte, &
+            fdx,fdy,nfuel_cat0,  &
+            nfuel_cat,fuel_time, &
+            fp  &
+)
+
+        ! initialize model state to no fire
+        if(.not.restart)then
+            call init_no_fire  ( &
+            ifds,ifde,jfds,jfde, &
+            ifms,ifme,jfms,jfme, &
+            ifts,ifte,jfts,jfte, &
+            fdx,fdy,time_start,  &
+            fuel_frac,fire_area,lfn,tign)
+            
+            need_lfn_update=.true. ! because we have set lfn 
+
+        endif
+
+elseif(ifun.eq.3)then   ! ignition if so specified
+
+    
+elseif (ifun.eq.4) then  ! do the timestep
+
+    if(fire_print_msg.ge.stat_lev)then
+      aw=fun_real(RNRM_SUM,  &
+        ifms,ifme,1,1,jfms,jfme, &                ! memory dims
+        ifds,ifde,1,1,jfds,jfde, &                ! domain dims
+        ifts,ifte,1,1,jfts,jfte, &                ! patch or tile dims
+        0,0,0,       &                            ! staggering
+        fp%vx,fp%vy)/((ifde-ifds+1)*(jfde-jfds+1))
+      mw=fun_real(RNRM_MAX,  &
+        ifms,ifme,1,1,jfms,jfme, &                ! memory dims
+        ifds,ifde,1,1,jfds,jfde, &                ! domain dims
+        ifts,ifte,1,1,jfts,jfte, &                ! patch or tile dims
+        0,0,0,       &                            ! staggering
+        fp%vx,fp%vy)
+!$OMP MASTER 
+      write(msg,91)time_start,'Average wind        ',aw,'m/s'
+      call message(msg,stat_lev)
+      write(msg,91)time_start,'Maximum wind        ',mw,'m/s'
+      call message(msg,stat_lev)
+!$OMP END MASTER 
+    endif
+
+!   compute fuel fraction at start
+!    call fuel_left( &
+!        ifms,ifme,jfms,jfme, &
+!        ifts,ifte,jfts,jfte, &
+!        ifms,ifme,jfms,jfme, &
+!        lfn,tign,fuel_time,time_start,fuel_frac,fire_area) ! fuel frac is shared
+
+    call print_2d_stats(ifts,ifte,jfts,jfte, &
+                   ifms,ifme,jfms,jfme, &
+                   fuel_frac,'model: fuel_frac start')
+
+    ! advance the model from time_start to time_start+dt
+    ! return the fuel fraction burnt this call in each fire cell
+    ! will call module_fr_sfire_speed::normal_spread for propagation speed
+    ! We cannot simply compute the spread rate here because that will change with the
+    ! angle of the wind and the direction of propagation, thus it is done in subroutine
+    ! normal_spread at each fire time step. Instead, we pass arguments that 
+    ! the speed function may use as fp. 
+
+!   propagate level set function in time
+!   set lfn_out tign
+!   lfn does not change, tign has no halos
+
+    if(.not. freeze_fire)then
+
+    call prop_ls(id,     &
+        ifds,ifde,jfds,jfde,                      & ! fire domain dims - the whole domain
+        ifms,ifme,jfms,jfme,                      &
+        ifps,ifpe,jfps,jfpe, &                ! patch - nodes owned by this process
+        ifts,ifte,jfts,jfte,                      &
+        time_start,dt,fdx,fdy,tbound,  &
+        lfn,lfn_out,tign,ros, fp &
+    ) 
+    else
+        call message('sfire_model: EXPERIMENTAL: skipping fireline propagation')
+
+    endif
+    
+elseif (ifun.eq.5) then ! copy the result of timestep back to input
+    ! this cannot be done in the time step itself because of race condition
+    ! some thread may still be using lfn as input in their tile halo
+
+    if(.not. freeze_fire)then
+    
+    do j=jfts,jfte
+        do i=ifts,ifte
+            lfn(i,j)=lfn_out(i,j)
+            ! if want to try timestep again treat tign the same way here
+            ! even if tign does not need a halo
+        enddo
+    enddo
+
+    endif
+
+    ! check for ignitions
+    do ig = 1,num_ignitions
+    
+!  for now, check for ignition every time step...
+!        if(ignition_line(ig)%end_time>=time_start.and.ignition_line(ig)%start_time<time_start+dt)then 
+            call ignite_fire(                             &
+                ifds,ifde,jfds,jfde,                      & ! fire domain dims - the whole domain
+                ifms,ifme,jfms,jfme,                      &
+                ifts,ifte,jfts,jfte,                      &
+                ignition_line(ig),                        &
+                time_start,time_start+dt,                 &
+                coord_xf,coord_yf,unit_xf,unit_yf,        & 
+                lfn,tign,ignited)
+
+            ignitions_done=ignitions_done+1
+            ignited_tile(ignitions_done)=ignited
+                
+!            need_lfn_update=.true. ! if ignition, lfn changed
+#ifdef DEBUG_OUT    
+            call write_array_m(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn,'lfn_ig',id)
+            call write_array_m(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,coord_xf,'coord_xf_ig',id)
+            call write_array_m(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,coord_yf,'coord_yf_ig',id)
+#endif
+!        endif
+        
+    enddo
+            
+    call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme, &
+                   lfn,'sfire_model: lfn out')
+
+    
+    need_lfn_update=.true. ! duh
+
+elseif (ifun.eq.6) then ! timestep postprocessing
+
+  if(.not. freeze_fire)then
+
+    ! compute the heat fluxes from the fuel burned
+    ! needs lfn and tign from neighbors so halo must be updated before
+    call fuel_left(&
+        ifms,ifme,jfms,jfme, &
+        ifts,ifte,jfts,jfte, &
+        ifts,ifte,jfts,jfte, &
+        lfn,tign,fuel_time,time_start+dt,fuel_frac_end,fire_area) !fuel_frac_end is private and tile based
+
+    call print_2d_stats(ifts,ifte,jfts,jfte, &
+                   ifts,ifte,jfts,jfte, &
+                   fuel_frac_end,'model: fuel_frac end')
+    
+    do j=jfts,jfte
+        do i=ifts,ifte
+            fuel_frac_burnt(i,j)=fuel_frac(i,j)-fuel_frac_end(i,j) ! fuel lost this timestep
+            fuel_frac(i,j)=fuel_frac_end(i,j) ! copy new value to state array
+        enddo
+    enddo
+
+    call print_2d_stats(ifts,ifte,jfts,jfte, &
+                   ifts,ifte,jfts,jfte, &
+                   fuel_frac_burnt,'model: fuel_frac burned')
+        
+    call heat_fluxes(dt,                          &
+        ifms,ifme,jfms,jfme,                      &
+        ifts,ifte,jfts,jfte,                      &
+        ifts,ifte,jfts,jfte,                      &  ! fuel_frac_burned is tile dimensioned
+        fp%fgip,                                     &
+        fuel_frac_burnt,                          & !
+        grnhfx,grnqfx)                              !out
+
+    if(fire_print_msg.ge.stat_lev)then
+      tfa=fun_real(REAL_SUM,  &
+        ifms,ifme,1,1,jfms,jfme, &                ! memory dims
+        ifds,ifde,1,1,jfds,jfde, &                ! domain dims
+        ifts,ifte,1,1,jfts,jfte, &                ! patch or tile dims
+        0,0,0,       &                            ! staggering
+        fire_area,fire_area) * fdx * fdy
+      thf=fun_real(REAL_SUM,  &
+        ifms,ifme,1,1,jfms,jfme, &                ! memory dims
+        ifds,ifde,1,1,jfds,jfde, &                ! domain dims
+        ifts,ifte,1,1,jfts,jfte, &                ! patch or tile dims
+        0,0,0,       &                            ! staggering
+        grnhfx,grnhfx) * fdx * fdy
+      mhf=fun_real(REAL_MAX,  &
+        ifms,ifme,1,1,jfms,jfme, &                ! memory dims
+        ifds,ifde,1,1,jfds,jfde, &                ! domain dims
+        ifts,ifte,1,1,jfts,jfte, &                ! patch or tile dims
+        0,0,0,       &                            ! staggering
+        grnhfx,grnhfx) 
+      tqf=fun_real(REAL_SUM,  &
+        ifms,ifme,1,1,jfms,jfme, &                ! memory dims
+        ifds,ifde,1,1,jfds,jfde, &                ! domain dims
+        ifts,ifte,1,1,jfts,jfte, &                ! patch or tile dims
+        0,0,0,       &                            ! staggering
+        grnqfx,grnqfx) * fdx * fdy
+      mqf=fun_real(REAL_MAX,  &
+        ifms,ifme,1,1,jfms,jfme, &                ! memory dims
+        ifds,ifde,1,1,jfds,jfde, &                ! domain dims
+        ifts,ifte,1,1,jfts,jfte, &                ! patch or tile dims
+        0,0,0,       &                            ! staggering
+        grnqfx,grnqfx) 
+!$OMP MASTER 
+      write(msg,91)time_start,'Fire area           ',tfa,'m^2'
+      call message(msg,stat_lev)
+      write(msg,91)time_start,'Heat output         ',thf,'W'
+      call message(msg,stat_lev)
+      write(msg,91)time_start,'Max heat flux       ',mhf,'W/m^2'
+      call message(msg,stat_lev)
+      write(msg,91)time_start,'Latent heat output  ',tqf,'W'
+      call message(msg,stat_lev)
+      write(msg,91)time_start,'Max latent heat flux',mqf,'W/m^2'
+      call message(msg,stat_lev)
+!$OMP END MASTER
+91  format('Time ',f11.3,' s ',a,e12.3,1x,a)
+    endif
+        
+
+  else
+     call message('sfire_model: EXPERIMENTAL: skipping fuel burnt computation')
+
+     if (fire_const_grnhfx >= 0. .and. fire_const_grnqfx >= 0.) then
+
+!$OMP CRITICAL(SFIRE_MODEL_CRIT)
+        write(msg,'(a,2e12.3,a)')'sfire_model: EXPERIMENTAL output constant heat flux', &
+           fire_const_grnhfx, fire_const_grnqfx, ' W/s'
+!$OMP END CRITICAL(SFIRE_MODEL_CRIT)
+        call message(msg)
+        
+        do j=jfts,jfte
+            do i=ifts,ifte
+                grnhfx(i,j)=fire_const_grnhfx
+                grnqfx(i,j)=fire_const_grnqfx
+            enddo
+        enddo
+
+      endif
+
+   endif
+
+    call print_2d_stats(ifts,ifte,jfts,jfte, &
+                   ifms,ifme,jfms,jfme, &
+                   grnhfx,'model: heat flux(J/m^2/s)')
+
+else
+!$OMP CRITICAL(SFIRE_MODEL_CRIT)
+    write(msg,*)'sfire_model: bad ifun=',ifun
+!$OMP END CRITICAL(SFIRE_MODEL_CRIT)
+    call crash(msg)
+endif
+
+end subroutine sfire_model
+
+!
+!*****************
+!
+            
+end module module_fr_sfire_model
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_phys.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_phys.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_phys.F	(revision 17)
@@ -0,0 +1,782 @@
+!
+module module_fr_sfire_phys
+
+use module_model_constants, only: cp,xlv
+use module_fr_sfire_util
+
+PRIVATE
+
+! subroutines and functions 
+PUBLIC:: init_fuel_cats,fire_ros,heat_fluxes,set_nfuel_cat,set_fire_params,write_fuels_m
+
+PUBLIC::fire_params
+
+! arrays passed to fire_ros
+type fire_params
+real,pointer,dimension(:,:):: vx,vy                ! wind velocity (m/s)
+real,pointer,dimension(:,:):: zsf                  ! terrain height (m) 
+real,pointer,dimension(:,:):: dzdxf,dzdyf          ! terrain grad (1) 
+real,pointer,dimension(:,:):: bbb,betafl,phiwc,r_0 ! spread formula coefficients
+real,pointer,dimension(:,:):: fgip                 ! init mass of surface fuel (kg/m^2)
+real,pointer,dimension(:,:):: ischap               ! if fuel is chaparral and want rate of spread treated differently
+end type fire_params
+
+! use as
+! type(fire_params)::fp
+
+!D in col 2 means quantity derived from the others
+!
+!  Scalar constants (data same for all fuel categories):
+!       HFGL           SURFACE FIRE HEAT FLUX THRESHOLD TO IGNITE CANOPY (W/m^2)
+!       CMBCNST        JOULES PER KG OF DRY FUEL
+!       FUELHEAT       FUEL PARTICLE LOW HEAT CONTENT, BTU/LB
+!       FUELMC_G       FUEL PARTICLE (SURFACE) MOISTURE CONTENT
+!D      BMST           RATIO OF LATENT TO SENSIBLE HEAT FROM SFC BURN:
+!                        % of total fuel mass that is water (not quite
+!                        = % fuel moisture).    BMST= (H20)/(H20+DRY)
+!                        so BMST = FUELMC_G / (1 + FUELMC_G)  where
+!                        FUELMC_G = moisture content of surface fuel
+!
+!  Data arrays indexed by fuel category:
+!       FGI            INITIAL TOTAL MASS OF SURFACE FUEL (KG/M**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.
+!       FUELMCE        MOISTURE CONTENT OF EXTINCTION; 0.30 FOR MANY DEAD FUELS; 0.15 FOR GRASS
+!       FUELDENS       OVENDRY PARTICLE DENSITY, LB/FT^3
+!       ST             FUEL PARTICLE TOTAL MINERAL CONTENT
+!       SE             FUEL PARTICLE EFFECTIVE MINERAL CONTENT
+!       WEIGHT         WEIGHTING PARAMETER THAT DETERMINES THE SLOPE OF THE MASS LOSS CURVE
+!                        RANGES FROM ~5 (FAST BURNUP) TO 1000 ( ~40% DECR OVER 10 MIN).
+!       FCI_D          INITIAL DRY MASS OF CANOPY FUEL
+!       FCT            BURN OUT TIME FOR CANOPY FUEL, AFTER DRY (S)
+!       ichap          Set=1 if fuel is chaparral and want the rate of spread treated differently, 0 if not
+!D      FCI            INITIAL TOTAL MASS OF CANOPY FUEL
+!D      FCBR           FUEL CANOPY BURN RATE (KG/M**2/S) 
+
+! =============================================================================
+! Anderson 13 surface fire fuel models, along with some
+!          estimated canopy properties (for crown fire).
+! =============================================================================
+!  --- Grass-dominated fuel models
+!  FUEL MODEL 1: Short grass (1 ft)
+!  FUEL MODEL 2: Timber (grass and understory)
+!  FUEL MODEL 3: Tall grass (2.5 ft)
+!  --- Shrub-dominated fuel models
+!  FUEL MODEL 4: Chaparral (6 ft)
+!  FUEL MODEL 5: Brush (2 ft) 
+!  FUEL MODEL 6: Dormant brush, hardwood slash
+!  FUEL MODEL 7: Southern rough
+!  --- Forest litter-dominated fuel models
+!  FUEL MODEL 8: Closed timber litter
+!  FUEL MODEL 9: Hardwood litter
+!  FUEL MODEL 10: Timber (litter + understory)
+!  --- Logging debris-dominated fuel models
+!  FUEL MODEL 11: Light logging slash
+!  FUEL MODEL 12: Medium logging slash
+!  FUEL MODEL 13: Heavy logging slash
+!  --- Fuel-free 
+!  FUEL MODEL 14: no fuel
+
+! scalar fuel coefficients
+   REAL, SAVE:: cmbcnst,hfgl,fuelmc_g,fuelmc_c
+! computed values
+   REAL, SAVE:: bmst,fuelheat
+
+! defaults, may be changed in init_fuel_cats
+   DATA cmbcnst  / 17.433e+06/             ! J/kg dry fuel
+   DATA hfgl     / 17.e4 /                ! W/m^2
+   DATA fuelmc_g / 0.08  /                ! set = 0 for dry surface fuel
+   DATA fuelmc_c / 1.00  /                ! set = 0 for dry canopy
+!  REAL, PARAMETER :: bmst     = fuelmc_g/(1+fuelmc_g)
+!  REAL, PARAMETER :: fuelheat = cmbcnst * 4.30e-04     ! convert J/kg to BTU/lb
+!  real, parameter :: xlv      = 2.5e6                  ! to make it selfcontained
+!  real, parameter :: cp      =  7.*287./2              ! to make it selfcontained
+
+
+! fuel categorytables
+   INTEGER, PARAMETER :: nf=14              ! number of fuel categories in data stmts
+   INTEGER, SAVE      :: nfuelcats = 13     ! number of fuel categories that are specified
+   INTEGER, PARAMETER :: mfuelcats = 30     ! allowable number of fuel categories 
+   INTEGER, PARAMETER :: zf = mfuelcats-nf  ! number of zero fillers in data stmt 
+   INTEGER, SAVE      :: no_fuel_cat = 14   ! special category outside of 1:nfuelcats
+   CHARACTER (len=80), DIMENSION(mfuelcats ), save :: fuel_name
+   INTEGER, DIMENSION( mfuelcats ), save :: ichap
+   REAL   , DIMENSION( mfuelcats ), save :: windrf,weight,fgi,fci,fci_d,fct,fcbr, &
+                                            fueldepthm,fueldens,fuelmce,   &
+                                            savr,st,se
+   DATA windrf /0.36, 0.36, 0.44,  0.55,  0.42,  0.44,  0.44, &     
+                0.36, 0.36, 0.36,  0.36,  0.43,  0.46,  1e-7, zf*0 /
+   DATA fgi / 0.166, 0.896, 0.674, 3.591, 0.784, 1.344, 1.091, &
+              1.120, 0.780, 2.692, 2.582, 7.749, 13.024, 1.e-7, zf*0.  /
+   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,zf*0. /
+   DATA savr / 3500., 2784., 1500., 1739., 1683., 1564., 1562.,  &
+               1889., 2484., 1764., 1182., 1145., 1159., 3500., zf*0. /
+   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 , zf*0. / 
+   DATA fueldens / nf * 32., zf*0. /   ! 32 if solid, 19 if rotten.
+   DATA st / nf* 0.0555 , zf*0./
+   DATA se / nf* 0.010 , zf*0./
+! ----- Notes on weight: (4) - best fit of data from D. Latham (pers. comm.);
+!              (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. , zf*0./ 
+! ----- 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., zf*0./
+   DATA fct / 60., 60., 60., 60., 60., 60., 60.,  &
+            60., 120., 180., 180., 180., 180. , 60. , zf*0.   /
+   DATA ichap / 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 , zf*0/ 
+! =========================================================================
+
+contains
+
+subroutine init_fuel_cats
+implicit none
+!*** purpose: initialize fuel tables and variables by constants
+!*** arguments: none
+logical, external:: wrf_dm_on_monitor
+!$ integer, external:: OMP_GET_THREAD_NUM
+!*** local
+integer:: i,j,k,ii,iounit
+character(len=128):: msg
+!*** executable
+
+! read 
+namelist /fuel_scalars/ cmbcnst,hfgl,fuelmc_g,fuelmc_c,nfuelcats,no_fuel_cat
+namelist /fuel_categories/ fuel_name,windrf,fgi,fueldepthm,savr, &
+    fuelmce,fueldens,st,se,weight,fci_d,fct,ichap
+
+!$  if (OMP_GET_THREAD_NUM() .ne. 0)then
+!$     call crash('init_fuel_cats: must be called from master thread')
+!$  endif
+
+IF ( wrf_dm_on_monitor() ) THEN
+    ! if we are the master task, read the file
+    iounit=open_text_file('namelist.fire','read')
+    read(iounit,fuel_scalars)
+    read(iounit,fuel_categories)
+    CLOSE(iounit)
+    
+    if (nfuelcats>mfuelcats) then
+        write(msg,*)'nfuelcats=',nfuelcats,' is too large, increase mfuelcats'
+        call crash(msg)
+    endif
+        if (no_fuel_cat >= 1 .and. no_fuel_cat <= nfuelcats)then
+        write(msg,*)'no_fuel_cat=',no_fuel_cat,' may not be between 1 and nfuelcats=',nfuelcats
+        call crash(msg)
+    endif
+ENDIF
+
+! broadcast the contents of the file
+call wrf_dm_bcast_real(cmbcnst,1)
+call wrf_dm_bcast_real(hfgl,1)
+call wrf_dm_bcast_real(fuelmc_g,1)
+call wrf_dm_bcast_real(fuelmc_c,1)
+call wrf_dm_bcast_integer(nfuelcats,1)
+call wrf_dm_bcast_integer(no_fuel_cat,1)
+call wrf_dm_bcast_real(windrf,    nfuelcats)
+call wrf_dm_bcast_real(fgi,       nfuelcats)
+call wrf_dm_bcast_real(fueldepthm,nfuelcats)
+call wrf_dm_bcast_real(savr,      nfuelcats)
+call wrf_dm_bcast_real(fuelmce,   nfuelcats)
+call wrf_dm_bcast_real(fueldens,  nfuelcats)
+call wrf_dm_bcast_real(st,        nfuelcats)
+call wrf_dm_bcast_real(se,        nfuelcats)
+call wrf_dm_bcast_real(weight,    nfuelcats)
+call wrf_dm_bcast_real(fci_d,     nfuelcats)
+call wrf_dm_bcast_real(fct,       nfuelcats)
+call wrf_dm_bcast_integer(ichap,  nfuelcats)
+
+! compute derived scalars
+
+bmst     = fuelmc_g/(1+fuelmc_g)
+fuelheat = cmbcnst * 4.30e-04     ! convert J/kg to BTU/lb
+
+! compute derived fuel category coefficients 
+
+DO i = 1,nfuelcats
+    fci(i) = (1.+fuelmc_c)*fci_d(i)
+    if(fct(i) .ne.  0.)then
+        fcbr(i) = fci_d(i)/fct(i) !  avoid division by zero
+    else
+        fcbr(i) = 0
+    endif
+END DO
+
+! prints
+
+call message('**********************************************************')
+call message('FUEL COEFFICIENTS')
+write(msg,8)'cmbcnst    ',cmbcnst
+call message(msg)
+write(msg,8)'hfgl       ',hfgl
+call message(msg)
+write(msg,8)'fuelmc_g   ',fuelmc_g
+call message(msg)
+write(msg,8)'fuelmc_c   ',fuelmc_c
+call message(msg)
+write(msg,8)'bmst       ',bmst
+call message(msg)
+write(msg,8)'fuelheat   ',fuelheat
+call message(msg)
+write(msg,7)'nfuelcats  ',nfuelcats
+call message(msg)
+write(msg,7)'no_fuel_cat',no_fuel_cat
+call message(msg)
+
+j=1
+7 format(a,5(1x,i8,4x))
+8 format(a,5(1x,g12.5e2))
+9 format(a,5(1x,a))
+do i=1,nfuelcats,j
+    k=min(i+j-1,nfuelcats)
+    call message(' ')
+    write(msg,7)'CATEGORY  ',(ii,ii=i,k)
+    call message(msg)
+    write(msg,9)'fuel name ',(fuel_name(ii),ii=i,k)
+    call message(msg)
+!    write(msg,8)'windrf    ',(windrf(ii),ii=i,k)
+!    call message(msg)
+    write(msg,8)'fgi       ',(fgi(ii),ii=i,k)
+    call message(msg)
+    write(msg,8)'fueldepthm',(fueldepthm(ii),ii=i,k)
+    call message(msg)
+    write(msg,8)'savr      ',(savr(ii),ii=i,k)
+    call message(msg)
+    write(msg,8)'fuelmce   ',(fuelmce(ii),ii=i,k)
+    call message(msg)
+    write(msg,8)'fueldens  ',(fueldens(ii),ii=i,k)
+    call message(msg)
+    write(msg,8)'st        ',(st(ii),ii=i,k)
+    call message(msg)
+    write(msg,8)'se        ',(se(ii),ii=i,k)
+    call message(msg)
+    write(msg,8)'weight    ',(weight(ii),ii=i,k)
+    call message(msg)
+    write(msg,8)'fci_d     ',(fci_d(ii),ii=i,k)
+    call message(msg)
+    write(msg,8)'fct       ',(fct(ii),ii=i,k)
+    call message(msg)
+    write(msg,7)'ichap     ',(ichap(ii),ii=i,k)
+    call message(msg)
+    write(msg,8)'fci       ',(fci(ii),ii=i,k)
+    call message(msg)
+    write(msg,8)'fcbr      ',(fcbr(ii),ii=i,k)
+    call message(msg)
+enddo
+call message('**********************************************************')
+
+! and print to file
+IF ( wrf_dm_on_monitor() ) THEN
+  call write_fuels_m(61,30.,1.)
+ENDIF
+end subroutine init_fuel_cats
+
+
+subroutine write_fuels_m(nsteps,maxwind,maxslope)
+implicit none
+integer, intent(in):: nsteps   ! number of steps for speed computation
+real, intent(in):: maxwind,maxslope ! computer from zero to these
+
+integer:: iounit,k,j,i
+type(fire_params)::fp
+!type fire_params
+!real,pointer,dimension(:,:):: vx,vy                ! wind velocity (m/s)
+!real,pointer,dimension(:,:):: zsf                  ! terrain height (m) 
+!real,pointer,dimension(:,:):: dzdxf,dzdyf          ! terrain grad (1) 
+!real,pointer,dimension(:,:):: bbb,betafl,phiwc,r_0 ! spread formula coefficients
+!real,pointer,dimension(:,:):: fgip                 ! init mass of surface fuel (kg/m^2)
+!real,pointer,dimension(:,:):: ischap               ! 1 if chapparal
+!end type fire_params
+real, dimension(1:2,1:nsteps), target::vx,vy,zsf,dzdxf,dzdyf,bbb,betafl,phiwc,r_0,fgip,ischap
+real, dimension(1:2,1:nsteps)::nfuel_cat,fuel_time,ros
+real::ros_base,ros_wind,ros_slope,propx,propy,r
+
+fp%vx=>vx
+fp%vy=>vy
+fp%dzdxf=>dzdxf
+fp%dzdyf=>dzdyf
+fp%bbb=>bbb
+fp%betafl=>betafl
+fp%phiwc=>phiwc
+fp%r_0=>r_0
+fp%fgip=>fgip
+fp%ischap=>ischap
+
+iounit = open_text_file('fuels.m','write')
+
+10 format('fuel(',i3,').',a,'=',"'",a,"'",';% ',a)
+do k=1,nfuelcats
+    write(iounit,10)k,'fuel_name',trim(fuel_name(k)),'FUEL MODEL NAME'
+    call write_var(k,'windrf',windrf(k),'WIND REDUCTION FACTOR FROM 20ft TO MIDFLAME HEIGHT' )
+    call write_var(k,'fgi',fgi(k),'INITIAL TOTAL MASS OF SURFACE FUEL (KG/M**2)' )
+    call write_var(k,'fueldepthm',fueldepthm(k),'FUEL DEPTH (M)')
+    call write_var(k,'savr',savr(k),'FUEL PARTICLE SURFACE-AREA-TO-VOLUME RATIO, 1/FT')
+    call write_var(k,'fuelmce',fuelmce(k),'MOISTURE CONTENT OF EXTINCTION')
+    call write_var(k,'fueldens',fueldens(k),'OVENDRY PARTICLE DENSITY, LB/FT^3')
+    call write_var(k,'st',st(k),'FUEL PARTICLE TOTAL MINERAL CONTENT')
+    call write_var(k,'se',se(k),'FUEL PARTICLE EFFECTIVE MINERAL CONTENT')
+    call write_var(k,'weight',weight(k),'WEIGHTING PARAMETER THAT DETERMINES THE SLOPE OF THE MASS LOSS CURVE')
+    call write_var(k,'fci_d',fci_d(k),'INITIAL DRY MASS OF CANOPY FUEL')
+    call write_var(k,'fct',fct(k),'BURN OUT TIME FOR CANOPY FUEL, AFTER DRY (S)')
+    call write_var(k,'ichap',float(ichap(k)),'1 if chaparral, 0 if not')
+    call write_var(k,'fci',fci(k),'INITIAL TOTAL MASS OF CANOPY FUEL')
+    call write_var(k,'fcbr',fcbr(k),'FUEL CANOPY BURN RATE (KG/M**2/S)')
+    call write_var(k,'hfgl',hfgl,'SURFACE FIRE HEAT FLUX THRESHOLD TO IGNITE CANOPY (W/m^2)')
+    call write_var(k,'cmbcnst',cmbcnst,'JOULES PER KG OF DRY FUEL')
+    call write_var(k,'fuelheat',fuelheat,'FUEL PARTICLE LOW HEAT CONTENT, BTU/LB')
+    call write_var(k,'fuelmc_g',fuelmc_g,'FUEL PARTICLE (SURFACE) MOISTURE CONTENT')
+    call write_var(k,'fuelmc_c',fuelmc_c,'FUEL PARTICLE (CANOPY) MOISTURE CONTENT')
+    ! set up fuel arrays 
+    !subroutine set_fire_params( &
+    !                       ifds,ifde,jfds,jfde, &
+    !                       ifms,ifme,jfms,jfme, &
+    !                       ifts,ifte,jfts,jfte, &
+    !                       fdx,fdy,nfuel_cat0,  &
+    !                       nfuel_cat,fuel_time, &
+    !                       fp ) 
+    nfuel_cat = k
+    call set_fire_params( &
+                           1,2,1,nsteps, &
+                           1,2,1,nsteps, &
+                           1,2,1,nsteps, &
+                           0.,0.,k,  &
+                           nfuel_cat,fuel_time, &
+                           fp ) 
+    ! set up windspeed and slope table
+    propx=1.
+    propy=0.
+    do j=1,nsteps
+       r=float(j-1)/float(nsteps-1)
+       ! line 1 varies windspeed (in x direction), zero slope
+       vx(1,j)=maxwind*r
+       vy(1,j)=0.
+       dzdxf(1,j)=0.
+       dzdyf(1,j)=0.
+       ! line 2 varies slope (in x direction), zero slope
+       vx(2,j)=0.
+       vy(2,j)=0.
+       dzdxf(2,j)=maxslope*r
+       dzdyf(2,j)=0.
+    enddo
+    do j=1,nsteps
+       do i=1,2
+          call fire_ros(ros_base,ros_wind,ros_slope, &
+             propx,propy,i,j,fp)
+          ros(i,j)=ros_base+ros_wind+ros_slope
+       enddo
+       write(iounit,13)k,'wind',j,vx(1,j),'wind speed'
+       write(iounit,13)k,'ros_wind',j,ros(1,j),'rate of spread for the wind speed'
+       write(iounit,13)k,'slope',j,dzdxf(2,j),'slope'
+       write(iounit,13)k,'ros_slope',j,ros(2,j),'rate of spread for the slope'
+    enddo
+enddo
+13 format('fuel(',i3,').',a,'(',i3,')=',g12.5e2,';% ',a)
+ 
+close(iounit)
+! stop
+
+contains
+
+subroutine write_var(k,name,value,descr)
+! write entry for one variable
+integer, intent(in)::k
+character(len=*), intent(in)::name,descr
+real, intent(in)::value
+write(iounit,11)k,name,value
+write(iounit,12)k,name,descr
+11 format('fuel(',i3,').',a,'=',g12.5e2,  ';')
+12 format('fuel(',i3,').',a,"_descr='",a,"';")
+end subroutine write_var
+
+end subroutine write_fuels_m
+
+!
+!*******************
+!
+
+subroutine set_fire_params( &
+                           ifds,ifde,jfds,jfde, &
+                           ifms,ifme,jfms,jfme, &
+                           ifts,ifte,jfts,jfte, &
+                           fdx,fdy,nfuel_cat0,  &
+                           nfuel_cat,fuel_time, &
+                           fp ) 
+
+implicit none
+
+!*** purpose: Set all fire model params arrays, constant values.
+
+!*** arguments
+integer, intent(in)::ifds,ifde,jfds,jfde                        ! fire domain bounds
+integer, intent(in)::ifts,ifte,jfts,jfte                        ! fire tile bounds
+integer, intent(in)::ifms,ifme,jfms,jfme                        ! memory array bounds
+real, intent(in):: fdx,fdy                                      ! fire mesh spacing
+integer,intent(in)::nfuel_cat0                                  ! default fuel category, if nfuel_cat=0
+real, intent(in),dimension(ifms:ifme, jfms:jfme)::nfuel_cat  ! fuel data
+real, intent(out), dimension(ifms:ifme, jfms:jfme)::fuel_time   ! fire params arrays
+type(fire_params),intent(inout)::fp
+
+!*** local
+
+real::  fuelload, fueldepth, rtemp1, rtemp2, &
+        qig, epsilon, rhob, wn, betaop, e, c, &
+        xifr, etas, etam, a, gammax, gamma, ratio, ir, &
+        fuelloadm,fdxinv,fdyinv
+integer:: i,j,k
+integer::nerr
+character(len=128)::msg
+
+!*** executable
+
+nerr=0
+do j=jfts,jfte
+   do i=ifts,ifte
+     ! fuel category 
+     k=int( nfuel_cat(i,j) )
+     if(k.eq.no_fuel_cat)then   ! no fuel 
+        fp%fgip(i,j)=0.            ! no mass 
+        fp%ischap(i,j)=0.
+        fp%betafl(i,j)=0.          ! to prevent division by zero
+        fp%bbb(i,j)=1.             !
+        fuel_time(i,j)=7./0.85  ! does not matter, just what was there before
+        fp%phiwc(i,j)=0.
+        fp%r_0(i,j)=0.             ! no fuel, no spread.
+     else
+        if(k.eq.0.and.nfuel_cat0.ge.1.and.nfuel_cat0.le.nfuelcats)then
+            ! replace k=0 by default
+            k=nfuel_cat0
+            nerr=nerr+1
+        endif
+   
+        if(k.lt.1.or.k.gt.nfuelcats)then
+!$OMP CRITICAL(SFIRE_PHYS_CRIT)
+            write(msg,'(3(a,i5))')'nfuel_cat(', i ,',',j,')=',k
+!$OMP END CRITICAL(SFIRE_PHYS_CRIT)
+            call message(msg)
+            call crash('set_fire_params: fuel category out of bounds')
+        endif
+
+        fuel_time(i,j)=weight(k)/0.85 ! cell based
+        
+        ! set fuel time constant: weight=1000 => 40% decrease over 10 min
+        ! fuel decreases as exp(-t/fuel_time) 
+        ! exp(-600*0.85/1000) = approx 0.6 
+
+        fp%ischap(i,j)=ichap(k)
+        fp%fgip(i,j)=fgi(k)
+
+        !     ...Settings of fire spread parameters from Rothermel follows. These
+        !        don't need to be recalculated later.
+        
+        fuelloadm= (1.-bmst) * fgi(k)  !  fuelload without moisture
+        fuelload = fuelloadm * (.3048)**2 * 2.205    ! to lb/ft^2
+        fueldepth = fueldepthm(k)/0.3048               ! to ft
+        fp%betafl(i,j) = fuelload/(fueldepth * fueldens(k))! packing ratio
+        betaop = 3.348 * savr(k)**(-0.8189)     ! optimum packing ratio
+        qig = 250. + 1116.*fuelmc_g            ! heat of preignition, btu/lb
+        epsilon = exp(-138./savr(k) )    ! effective heating number
+        rhob = fuelload/fueldepth    ! ovendry bulk density, lb/ft^3
+
+        c = 7.47 * exp( -0.133 * savr(k)**0.55)    ! const in wind coef
+        fp%bbb(i,j) = 0.02526 * savr(k)**0.54      ! const in wind coef
+        e = 0.715 * exp( -3.59e-4 * savr(k))       ! const in wind coef
+        fp%phiwc(i,j) = c * (fp%betafl(i,j)/betaop)**(-e)
+
+        rtemp2 = savr(k)**1.5
+        gammax = rtemp2/(495. + 0.0594*rtemp2)              ! maximum rxn vel, 1/min
+        a = 1./(4.774 * savr(k)**0.1 - 7.27)   ! coef for optimum rxn vel
+        ratio = fp%betafl(i,j)/betaop
+        gamma = gammax *(ratio**a) *exp(a*(1.-ratio)) !optimum rxn vel, 1/min
+
+        wn = fuelload/(1 + st(k))       ! net fuel loading, lb/ft^2
+        rtemp1 = fuelmc_g/fuelmce(k)
+        etam = 1.-2.59*rtemp1 +5.11*rtemp1**2 -3.52*rtemp1**3  !moist damp coef
+        etas = 0.174* se(k)**(-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
+
+        xifr = exp( (0.792 + 0.681*savr(k)**0.5) &
+            * (fp%betafl(i,j)+0.1)) /(192. + 0.2595*savr(k)) ! propagating flux ratio
+
+!        ... r_0 is the spread rate for a fire on flat ground with no wind.
+        fp%r_0(i,j) = ir*xifr/(rhob * epsilon *qig)    ! default spread rate in ft/min
+
+     endif
+  enddo
+enddo
+
+if(nerr.gt.1)then
+!$OMP CRITICAL(SFIRE_PHYS_CRIT)
+    write(msg,'(a,i6,a)')'set_fire_params: WARNING: fuel category 0 replaced in',nerr,' cells'
+!$OMP END CRITICAL(SFIRE_PHYS_CRIT)
+    call message(msg)
+endif
+
+end subroutine set_fire_params
+
+!
+!*******************
+!
+
+subroutine heat_fluxes(dt,                        &
+        ifms,ifme,jfms,jfme,                      &  ! memory dims
+        ifts,ifte,jfts,jfte,                      &  ! tile dims
+        iffs,iffe,jffs,jffe,                      &  ! fuel_frac_burnt dims
+        fgip,fuel_frac_burnt,                     & !in
+        grnhft,grnqft)                              !out
+implicit none
+
+!*** purpose        
+! compute the heat fluxes on the fire grid cells
+
+!*** arguments
+real, intent(in)::dt          ! dt  the fire time step (the fire model advances time by this)
+integer, intent(in)::ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,iffs,iffe,jffs,jffe   ! dimensions                   
+real, intent(in),dimension(ifms:ifme,jfms:jfme):: fgip
+real, intent(in),dimension(iffs:iffe,jffs:jffe):: fuel_frac_burnt
+real, intent(out),dimension(ifms:ifme,jfms:jfme):: grnhft,grnqft
+
+!*** local
+integer::i,j
+real:: dmass
+
+!*** executable        
+do j=jfts,jfte
+    do i=ifts,ifte
+         dmass =                     &     ! surface fuel dry mass burnt this call (kg/m^2)
+             fgip(i,j)               &     ! init mass from fuel model no (kg/m^2) = fgi(nfuel_cat(i,j)
+             * fuel_frac_burnt(i,j)        ! fraction burned this call    (1)
+         grnhft(i,j) = (dmass/dt)*(1.-bmst)*cmbcnst         ! surface fire sensible heat flux W/m^2
+         grnqft(i,j) = (bmst+(1.-bmst)*.56)*(dmass/dt)*xlv  ! surface fire latent heat flux W/m
+         ! xlv is defined in module_model_constants.. Assume 56% of cellulose molecule mass is water.
+    enddo
+enddo
+
+end subroutine heat_fluxes
+
+!
+!**********************
+!            
+
+
+subroutine set_nfuel_cat(   &
+    ifms,ifme,jfms,jfme,               &
+    ifts,ifte,jfts,jfte,               &
+    ifuelread,nfuel_cat0,zsf,nfuel_cat)
+
+implicit none
+
+! set fuel distributions for testing
+integer, intent(in)::   ifts,ifte,jfts,jfte,               &
+                        ifms,ifme,jfms,jfme               
+
+integer, intent(in)::ifuelread,nfuel_cat0
+real, intent(in), dimension(ifms:ifme, jfms:jfme)::zsf
+real, intent(out), dimension(ifms:ifme, jfms:jfme)::nfuel_cat
+
+!*** local
+
+! parameters to control execution
+integer:: i,j,iu1
+real:: t1
+character(len=128)msg
+
+!$OMP CRITICAL(SFIRE_PHYS_CRIT)
+    write(msg,'(a,i3)')'set_nfuel_cat: ifuelread=',ifuelread 
+!$OMP END CRITICAL(SFIRE_PHYS_CRIT)
+    call message(msg)
+
+if (ifuelread .eq. -1 .or. ifuelread .eq. 2) then
+!$OMP CRITICAL(SFIRE_PHYS_CRIT)
+    call message('set_nfuel_cat: assuming nfuel_cat initialized already') 
+    call message(msg)
+!$OMP END CRITICAL(SFIRE_PHYS_CRIT)
+else if (ifuelread .eq. 0) then
+!
+    do j=jfts,jfte
+        do  i=ifts,ifte
+            nfuel_cat(i,j)=real(nfuel_cat0)
+        enddo
+    enddo
+!$OMP CRITICAL(SFIRE_PHYS_CRIT)
+    write(msg,'(a,i3)')'set_nfuel_cat: fuel initialized with category',nfuel_cat0
+!$OMP END CRITICAL(SFIRE_PHYS_CRIT)
+    call message(msg)
+         
+else if (ifuelread .eq. 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=jfts,jfte
+        do  i=ifts,ifte
+            ! nfuel_cat(i,j)= 2     ! grass with understory ! jm does nothing
+            !jm t1=zsf(i,j)*slngth/100.
+            t1 = zsf(i,j)  ! this is in m
+            if(t1.le.1524.)then   !  up to 5000 ft
+                nfuel_cat(i,j)= 3  ! tall grass
+            else if(t1.ge.1524. .and. t1.le.2073.)then  ! 5.0-6.8 kft.
+                nfuel_cat(i,j)= 2  ! grass with understory
+            else if(t1.ge.2073..and.t1.le.2438.)then  ! 6.8-8.0 kft.
+                nfuel_cat(i,j)= 8  ! timber litter - 10 (ponderosa)
+            else if(t1.gt.2438. .and. t1.le. 3354.) then ! 8.0-11.0 kft.
+!                 ... could also be mixed conifer.
+                nfuel_cat(i,j)= 10 ! timber litter - 8 (lodgepole)
+            else if(t1.gt.3354. .and. t1.le. 3658.) then ! 11.0-12.0 kft
+                nfuel_cat(i,j)= 1  ! alpine meadow - 1
+            else if(t1.gt.3658. ) then  ! > 12.0 kft
+                nfuel_cat(i,j)= 14 ! no fuel.
+            endif
+        enddo
+    enddo
+
+    call message('set_nfuel_cat: fuel initialized by altitude')
+else
+
+    call crash('set_nfuel_cat: bad ifuelread')
+endif
+!     .............end  load fuel categories (or constant) here.
+
+end subroutine set_nfuel_cat            
+
+!
+!**********************
+!            
+
+subroutine fire_ros(ros_base,ros_wind,ros_slope, &
+propx,propy,i,j,fp)
+
+implicit none
+
+! copied with the following changes ONLY: 
+!   0.5*(speed + abs(speed)) -> max(speed,0.)
+!   index l -> j 
+!   not using nfuel_cat here - cell info was put into arrays passed as arguments
+!       in include file to avoid transcription errors when used elsewhere
+!   betaop is absorbed in phiwc, see module_fr_sfire_model/fire_startup
+!   return the base, wind, and slope contributions to the rate of spread separately
+!       because they may be needed to take advantage of known wind and slope vectors.
+!       They should add up to get the total rate of spread.
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!     ... calculates fire spread rate with McArthur formula or Rothermel
+!           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
+!      
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+!*** arguments
+real, intent(out)::ros_base,ros_wind,ros_slope ! rate of spread contribution due to fuel, wind, and slope
+real, intent(in)::propx,propy
+integer, intent(in)::i,j         ! node mesh coordinates
+type(fire_params),intent(in)::fp
+
+!*** local
+real:: speed, tanphi ! windspeed and slope in the direction normal to the fireline
+real:: umid, phis, phiw, spdms, umidm, excess
+real:: ros_back
+integer, parameter::ibeh=1
+real, parameter::ros_max=6.
+character(len=128)msg
+real::cor_wind,cor_slope,nvx,nvy,scale
+
+
+!*** executable
+
+! make sure normal direction is size 1
+!scale=sqrt(propx*propx+propy*propy)+tiny(scale)
+scale=1.
+nvx=propx/scale
+nvy=propy/scale
+if (fire_advection.ne.0) then ! from flags in module_fr_sfire_util
+    ! wind speed is total speed 
+    speed =  sqrt(fp%vx(i,j)*fp%vx(i,j)+ fp%vy(i,j)*fp%vy(i,j))+tiny(speed)
+    ! slope is total slope
+    tanphi = sqrt(fp%dzdxf(i,j)*fp%dzdxf(i,j) + fp%dzdyf(i,j)*fp%dzdyf(i,j))+tiny(tanphi)
+    ! cos of wind and spread, if >0
+    cor_wind =  max(0.,(fp%vx(i,j)*nvx + fp%vy(i,j)*nvy)/speed)
+    ! cos of slope and spread, if >0
+    cor_slope = max(0., (fp%dzdxf(i,j)*nvx + fp%dzdyf(i,j)*nvy)/tanphi)
+else
+    ! wind speed in spread direction
+    speed =  fp%vx(i,j)*nvx + fp%vy(i,j)*nvy
+    ! slope in spread direction
+    tanphi = fp%dzdxf(i,j)*nvx + fp%dzdyf(i,j)*nvy
+    cor_wind=1.
+    cor_slope=1.
+endif
+
+if (.not. fp%ischap(i,j) > 0.) then      ! if fuel is not chaparral, calculate rate of spread one of these ways
+    if (ibeh .eq. 1) then                ! use Rothermel formula
+!       ... if wind is 0 or into fireline, phiw = 0, &this reduces to backing ros.
+        spdms = max(speed,0.)            ! 
+        umidm = min(spdms,30.)           ! max input wind spd is 30 m/s   !param!
+        umid = umidm * 196.850           ! m/s to ft/min
+        !  eqn.: phiw = c * umid**bbb(i,j) * (fp%betafl(i,j)/betaop)**(-e) ! wind coef
+        phiw = umid**fp%bbb(i,j) * fp%phiwc(i,j) ! wind coef
+        phis=0.
+        if (tanphi .gt. 0.) then
+            phis = 5.275 *(fp%betafl(i,j))**(-0.3) *tanphi**2   ! slope factor
+        endif
+        ! rosm = fp%r_0(i,j)*(1. + phiw + phis)  * .00508 ! spread rate, m/s
+        ros_base = fp%r_0(i,j) * .00508
+        ros_wind = ros_base*phiw
+        ros_slope= ros_base*phis
+        
+
+    else                                   ! McArthur formula (Australian)
+        ! rosm = 0.18*exp(0.8424*max(speed,0.))
+        ros_base = 0.18*exp(0.8424)
+        ros_wind = 0.18*exp(0.8424*max(speed,0.))
+        ros_slope =0.
+    endif
+!
+else   ! chaparral
+!        .... spread rate has no dependency on fuel character, only windspeed.
+    spdms = max(speed,0.)      
+    ! rosm = 1.2974 * spdms**1.41       ! spread rate, m/s
+    ! note: backing ros is 0 for chaparral without setting nozero value below
+    !sp_n=.03333  
+    ! chaparral backing fire spread rate 0.033 m/s   ! param!
+    !rosm= max(rosm, sp_n)   ! no less than backing r.o.s.
+
+    ros_back=.03333    ! chaparral backing fire spread rate 0.033 m/s   ! param!
+    ros_wind = 1.2974 * spdms**1.41       ! spread rate, m/s
+    ros_wind = max(ros_wind, ros_back)
+    ros_slope =0.
+
+endif
+! if advection, multiply by the cosines
+ros_wind=ros_wind*cor_wind
+ros_slope=ros_slope*cor_slope
+!
+!     ----------note!  put an 6 m/s cap on max spread rate -----------
+! rosm= min(rosm, 6.)         ! no faster than this cap   ! param !
+
+excess = ros_base + ros_wind + ros_slope - ros_max
+
+if (excess > 0.)then
+    ! take it out of wind and slope in proportion
+    ros_wind = ros_wind - excess*ros_wind/(ros_wind+ros_slope)
+    ros_slope = ros_slope - excess*ros_slope/(ros_wind+ros_slope)
+endif
+
+!write(msg,*)i,j,' speed=',speed,' tanphi',tanphi,' ros=',ros_base,ros_wind,ros_slope
+!call message(msg)
+      return
+
+contains
+real function nrm2(u,v)
+real, intent(in)::u,v
+nrm2=sqrt(u*u+v*v)
+end function nrm2
+
+end subroutine fire_ros 
+
+end module module_fr_sfire_phys
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_util.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_util.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_fr_sfire_util.F	(revision 17)
@@ -0,0 +1,1509 @@
+!
+! This module contains general purpose utilities and WRF wrappers because some
+! applications require this module to run standalone. No physics here.
+! Some are dependent on WRF indexing scheme. Some violate WRF conventions but these
+! are not called from the WRF dependent code. Some are not called at all.
+! 
+
+module module_fr_sfire_util
+
+! various method selection parameters
+! 1. add the parameter and its static default here
+! optional:
+! 2. add copy from config_flags in module_fr_sfire_driver%%set_flags
+! 3. add a line in Registry.EM to define the variable and set default value
+! 4. add the variable and value in namelist.input
+
+
+integer,save::          &
+ fire_print_msg=1,      &  ! print SFIRE progress 
+ fire_print_file=1,     &  ! write many files by write_array_m; compile with DEBUG_OUT, do not run in parallel
+ fuel_left_method=1,    &  ! 1=simple, 2=exact in linear case
+ fuel_left_irl=2,       &  ! refinement for fuel calculation, must be even
+ fuel_left_jrl=2,       &
+ boundary_guard=-1,     &  ! crash if fire gets this many cells to domain boundary, -1=off
+ fire_grows_only=1,     &  ! fire can spread out only (level set functions may not increase)
+ fire_upwinding=3,      &  ! upwind normal spread: 1=standard, 2=godunov, 3=eno, 4=sethian 
+ fire_upwind_split=0,   &  ! 1=upwind advection separately from normal direction spread
+ fire_test_steps=0,     &  ! 0=no fire, 1=normal, >1 = do specified number of steps and terminate (testing only)
+ fire_topo_from_atm=1,  &  ! 0 = expect ZSF set correctly on entry, 1 = populate by interploating from atmosphere
+ fire_advection=0          ! 0 = fire spread from normal wind/slope (CAWFE), 1 = full speed projected
+ 
+
+real, save::            &
+ fire_const_time=-1,    &  ! time from ignition to start constant heat output  <0=never
+ fire_const_grnhfx=-1., &  ! if both >=0, the constant heat flux to output then
+ fire_const_grnqfx=-1., &  ! if both >=0, the constant heat flux to output then
+ fire_atm_feedback=1. , &  ! 1 = normal, 0. = one way coupling atmosphere -> fire only
+ fire_back_weight=0.5,  &  ! RK parameter, 0 = Euler method, 0.5 = Heun, 1 = fake backward Euler
+ fire_viscosity=0.4,    &  ! artificial viscosity
+ fire_lfn_ext_up=1.        ! 0.=extend level set function at boundary by reflection, 1.=always up
+
+integer, parameter:: REAL_SUM=10, REAL_MAX=20, RNRM_SUM=30, RNRM_MAX=40
+
+contains
+
+!
+!****************
+!
+subroutine crash(s)
+use module_wrf_error
+implicit none
+character(len=*), intent(in)::s
+character(len=128)msg
+msg='crash: '//s
+call message(msg,level=0)
+!$OMP CRITICAL(SFIRE_MESSAGE_CRIT)
+call wrf_error_fatal(msg)
+!$OMP END CRITICAL(SFIRE_MESSAGE_CRIT)
+end subroutine crash
+
+!
+!****************
+!
+
+subroutine message(s,level)
+use module_wrf_error
+#ifdef _OPENMP
+use OMP_LIB 
+#endif
+implicit none
+!*** arguments
+character(len=*), intent(in)::s
+integer,intent(in),optional::level
+!*** local
+character(len=128)::msg
+character(len=118)::t
+integer m,mlevel
+logical op
+!*** executable
+if(present(level))then
+    mlevel=level
+else
+    mlevel=2  ! default message level
+endif
+if(fire_print_msg.ge.mlevel)then
+      m=0
+!$OMP CRITICAL(SFIRE_MESSAGE_CRIT)
+#ifdef _OPENMP
+      m=omp_get_thread_num()
+      t=s
+      write(msg,'(a6,i3,a1,a118)')'SFIRE:',m,':',t
+#else
+      msg='SFIRE:'//s
+#endif
+      call wrf_message(msg)
+!      flush(6)
+!      flush(0)
+!$OMP END CRITICAL(SFIRE_MESSAGE_CRIT)
+endif
+end subroutine message
+
+!
+!****************
+!
+
+
+integer function open_text_file(filename,rw)
+implicit none
+character(len=*),intent(in):: filename,rw
+!$ integer, external:: OMP_GET_THREAD_NUM
+character(len=128):: msg
+character(len=1)::act
+integer::iounit,ierr
+logical::op
+
+!$  if (OMP_GET_THREAD_NUM() .ne. 0)then
+!$     call crash('open_input_text_file: called from parallel loop')
+!$  endif
+
+    do iounit=19,99
+       inquire(iounit,opened=op)
+       if(.not.op)goto 1
+    enddo
+    call crash('open_text_file: Cannot find any available I/O unit')
+1   continue
+    act=rw(1:1)
+    select case (act)
+        case ('r','R')
+            OPEN(iounit, FILE=filename,FORM='FORMATTED',STATUS='OLD',ACTION='READ',IOSTAT=ierr)
+        case ('w','W')
+            OPEN(iounit, FILE=filename,FORM='FORMATTED',STATUS='UNKNOWN',ACTION='WRITE',IOSTAT=ierr)
+        case default
+            write(msg,*)'open_text_file: bad mode ',trim(rw),' for file ',trim(filename)
+    end select
+    
+    if(ierr.ne.0)then 
+	write(msg,*)'open_text_file: Cannot open file ',filename
+        call crash(msg)
+    endif
+    open_text_file=iounit
+
+end function open_text_file
+
+!
+!****************
+!
+
+
+subroutine set_ideal_coord( dxf,dyf, &
+                ifds,ifde,jfds,jfde,  &
+                ifms,ifme,jfms,jfme,  &
+                ifts,ifte,jfts,jfte,  &
+                fxlong,fxlat          &
+            )
+implicit none
+! arguments
+real, intent(in)::dxf,dyf
+integer, intent(in):: &
+                ifds,ifde,jfds,jfde,  &
+                ifms,ifme,jfms,jfme,  &
+                ifts,ifte,jfts,jfte
+real, intent(out),dimension(ifms:ifme,jfms:jfme)::fxlong,fxlat
+! local
+integer::i,j
+                ! set fake  coordinates, in m 
+                do j=jfts,jfte
+                    do i=ifts,ifte
+                        ! uniform mesh, lower left domain corner is (0,0)
+                        fxlong(i,j)=(i-ifds+0.5)*dxf
+                        fxlat (i,j)=(j-jfds+0.5)*dyf
+                    enddo
+                enddo
+end subroutine set_ideal_coord
+
+!
+!****************
+!
+
+
+subroutine continue_at_boundary(ix,iy,bias, & ! do x direction or y direction
+    ims,ime,jms,jme, &                ! memory dims
+    ids,ide,jds,jde, &                ! domain dims
+    ips,ipe,jps,jpe, &                ! patch dims
+    its,ite,jts,jte, &                ! tile dims
+    itso,iteo,jtso,jteo, &            ! tile dims where set
+    lfn)                              ! array
+implicit none
+!*** description
+! extend array by one beyond the domain by linear continuation
+!*** arguments
+integer, intent(in)::ix,iy              ! not 0 = do x or y (1 or 2) direction
+real,intent(in)::bias                   ! 0=none, 1.=max
+integer, intent(in)::ims,ime,jms,jme, &                ! memory dims
+    ids,ide,jds,jde, &                ! domain dims
+    ips,ipe,jps,jpe, &                ! patch dims
+    its,ite,jts,jte                   ! tile dims
+integer, intent(out)::itso,jtso,iteo,jteo ! where set
+real,intent(inout),dimension(ims:ime,jms:jme)::lfn
+!*** local
+integer i,j
+character(len=128)::msg
+integer::its1,ite1,jts1,jte1
+integer,parameter::halo=1           ! width of halo region to update 
+!*** executable
+! check if there is space for the extension
+call check_mesh_2dim(its-1,ite+1,jts-1,jte+1,ims,ime,jms,jme)
+! for dislay only
+itso=its
+jtso=jts
+iteo=ite
+jteo=jte
+! go halo width beyond if at patch boundary but not at domain boudnary 
+! assume we have halo need to compute the value we do not have 
+! the next thread that would conveniently computer the extended values at patch corners
+! besides halo may not transfer values outside of the domain
+! 
+its1=its
+jts1=jts
+ite1=ite
+jte1=jte
+if(its.eq.ips.and..not.its.eq.ids)its1=its-halo
+if(jts.eq.jps.and..not.jts.eq.jds)jts1=jts-halo
+if(ite.eq.ipe.and..not.ite.eq.ide)ite1=ite+halo
+if(jte.eq.jpe.and..not.jte.eq.jde)jte1=jte+halo
+!$OMP CRITICAL(SFIRE_UTIL_CRIT)
+write(msg,'(a,2i5,a,f5.2)')'continue_at_boundary: directions',ix,iy,' bias ',bias 
+call message(msg)
+!$OMP END CRITICAL(SFIRE_UTIL_CRIT)
+if(ix.ne.0)then
+    if(its.eq.ids)then
+        do j=jts1,jte1
+            lfn(ids-1,j)=EX(lfn(ids,j),lfn(ids+1,j))
+        enddo
+        itso=ids-1
+    endif
+    if(ite.eq.ide)then
+        do j=jts1,jte1
+            lfn(ide+1,j)=EX(lfn(ide,j),lfn(ide-1,j))
+        enddo
+        iteo=ide+1
+    endif
+!$OMP CRITICAL(SFIRE_UTIL_CRIT)
+    write(msg,'(8(a,i5))')'continue_at_boundary: x:',its,':',ite,',',jts,':',jte,' ->',itso,':',iteo,',',jts1,':',jte1
+    call message(msg)
+!$OMP END CRITICAL(SFIRE_UTIL_CRIT)
+endif
+if(iy.ne.0)then
+    if(jts.eq.jds)then
+        do i=its1,ite1
+            lfn(i,jds-1)=EX(lfn(i,jds),lfn(i,jds+1))
+        enddo
+        jtso=jds-1
+    endif
+    if(jte.eq.jde)then
+        do i=its1,ite1
+            lfn(i,jde+1)=EX(lfn(i,jde),lfn(i,jde-1))
+        enddo
+        jteo=jde+1
+    endif
+!$OMP CRITICAL(SFIRE_UTIL_CRIT)
+    write(msg,'(8(a,i5))')'continue_at_boundary: y:',its,':',ite,',',jts,':',jte,' ->',its1,':',ite1,',',jtso,':',jteo
+!$OMP END CRITICAL(SFIRE_UTIL_CRIT)
+    call message(msg)
+endif
+! corners of the domain
+if(ix.ne.0.and.iy.ne.0)then
+    if(its.eq.ids.and.jts.eq.jds)lfn(ids-1,jds-1)=EX(lfn(ids,jds),lfn(ids+1,jds+1))
+    if(its.eq.ids.and.jte.eq.jde)lfn(ids-1,jde+1)=EX(lfn(ids,jde),lfn(ids+1,jde-1))
+    if(ite.eq.ide.and.jts.eq.jds)lfn(ide+1,jds-1)=EX(lfn(ide,jds),lfn(ide-1,jds+1))
+    if(ite.eq.ide.and.jte.eq.jde)lfn(ide+1,jde+1)=EX(lfn(ide,jde),lfn(ide-1,jde-1))
+endif
+return
+contains
+real function EX(a,b)
+!*** statement function
+real a,b
+EX=(1.-bias)*(2.*a-b)+bias*max(2.*a-b,a,b)   ! extrapolation, max quarded
+end function EX
+end subroutine continue_at_boundary
+
+!
+!*****************************
+!
+
+subroutine check_mesh_2dim(ids,ide,jds,jde,ims,ime,jms,jme)
+implicit none
+integer, intent(in)::ids,ide,jds,jde,ims,ime,jms,jme
+character(len=128)msg
+if(ids<ims.or.ide>ime.or.jds<jms.or.jde>jme)then
+!$OMP CRITICAL(SFIRE_UTIL_CRIT)
+    write(msg,*)'mesh dimensions:  ',ids,ide,jds,jde
+    call message(msg)
+    write(msg,*)'memory dimensions:',ims,ime,jms,jme
+!$OMP END CRITICAL(SFIRE_UTIL_CRIT)
+    call message(msg)
+    call crash('check_mesh_2dim: memory dimensions too small')
+endif
+end subroutine check_mesh_2dim
+
+!
+!****************
+!
+
+subroutine check_mesh_3dim(ids,ide,kds,kde,jds,jde,ims,ime,kms,kme,jms,jme)
+integer, intent(in)::ids,ide,jds,jde,ims,ime,jms,jme,kds,kde,kms,kme
+if(ids<ims.or.ide>ime.or.jds<jms.or.jde>jme.or.kds<kms.or.kde>kme) then
+    call crash('memory dimensions too small')
+endif
+end subroutine check_mesh_3dim
+
+!
+!****************
+!
+
+subroutine sum_2d_cells(       &
+       ims2,ime2,jms2,jme2,    &
+       its2,ite2,jts2,jte2,    &
+       v2,                     &  ! input       
+       ims1,ime1,jms1,jme1,    &
+       its1,ite1,jts1,jte1,    &
+       v1)                        ! output
+implicit none
+
+!*** purpose
+! sum cell values in mesh2 to cell values of coarser mesh1
+
+!*** arguments
+! the dimensions are in cells, not nodes!
+
+integer, intent(in)::its1,ite1,jts1,jte1,ims1,ime1,jms1,jme1
+real, intent(out)::v1(ims1:ime1,jms1:jme1)
+integer, intent(in)::its2,ite2,jts2,jte2,ims2,ime2,jms2,jme2
+real, intent(in)::v2(ims2:ime2,jms2:jme2)
+
+!*** local
+integer:: i1,i2,j1,j2,ir,jr,isz1,isz2,jsz1,jsz2,ioff,joff,ibase,jbase
+real t
+character(len=128)msg
+
+!*** executable
+
+!check mesh dimensions and domain dimensions
+call check_mesh_2dim(its1,ite1,jts1,jte1,ims1,ime1,jms1,jme1)
+call check_mesh_2dim(its2,ite2,jts2,jte2,ims2,ime2,jms2,jme2)
+
+! compute mesh sizes
+isz1 = ite1-its1+1
+jsz1 = jte1-jts1+1
+isz2 = ite2-its2+1
+jsz2 = jte2-jts2+1
+
+! check mesh sizes
+if(isz1.le.0.or.jsz1.le.0.or.isz2.le.0.or.jsz2.le.0)then
+    call message('all mesh sizes must be positive')
+    goto 9
+endif
+
+! compute mesh ratios
+ir=isz2/isz1
+jr=jsz2/jsz1
+
+if(isz2.ne.isz1*ir .or. jsz2.ne.jsz1*jr)then
+    call message('input mesh size must be multiple of output mesh size')
+    goto 9
+endif
+
+
+! v1 = sum(v2)
+do j1=jts1,jte1
+    jbase=jts2+jr*(j1-jts1)
+    do i1=its1,ite1
+       ibase=its2+ir*(i1-its1)
+       t=0.
+       do joff=0,jr-1
+           j2=joff+jbase
+           do ioff=0,ir-1
+               i2=ioff+ibase
+               t=t+v2(i2,j2)
+           enddo
+       enddo
+       v1(i1,j1)=t
+    enddo
+enddo
+
+return
+
+9 continue
+!$OMP CRITICAL(SFIRE_UTIL_CRIT)
+write(msg,91)its2,ite2,jts2,jte2,ims2,ime2,jms2,jme2
+call message(msg)
+write(msg,91)its1,ite1,jts1,jte1,ims1,ime1,jms1,jme1
+call message(msg)
+write(msg,92)'input  mesh size:',isz2,jsz2
+call message(msg)
+91 format('dimensions: ',8i8)
+write(msg,92)'output mesh size:',isz1,jsz1
+call message(msg)
+92 format(a,2i8)
+!$OMP END CRITICAL(SFIRE_UTIL_CRIT)
+call crash('module_fr_spread_util:sum_mesh_cells: bad mesh sizes')
+
+end subroutine sum_2d_cells
+
+
+
+! module_fr_sfire_util%%interpolate_2d
+subroutine interpolate_2d(  &
+    ims2,ime2,jms2,jme2, & ! array coarse grid
+    its2,ite2,jts2,jte2, & ! dimensions coarse grid
+    ims1,ime1,jms1,jme1, & ! array coarse grid
+    its1,ite1,jts1,jte1, & ! dimensions fine grid
+    ir,jr,               & ! refinement ratio
+    rip2,rjp2,rip1,rjp1, & ! (rip2,rjp2) on grid 2 lines up with (rip1,rjp1) on grid 1 
+    v2, &                  ! in coarse grid  
+    v1  )                  ! out fine grid
+implicit none
+
+!*** purpose
+! interpolate nodal values in mesh2 to nodal values in mesh1
+! interpolation runs over the mesh2 region its2:ite2,jts2:jte2 
+! only the part of mesh 1 in the region its1:ite1,jts1:jte1 is modified
+
+!*** arguments
+
+integer, intent(in)::its1,ite1,jts1,jte1,ims1,ime1,jms1,jme1
+integer, intent(in)::its2,ite2,jts2,jte2,ims2,ime2,jms2,jme2
+integer, intent(in)::ir,jr
+real,intent(in):: rjp1,rip1,rjp2,rip2
+real, intent(out)::v1(ims1:ime1,jms1:jme1)
+real, intent(in)::v2(ims2:ime2,jms2:jme2)
+
+!*** local
+integer:: i1,i2,j1,j2,is,ie,js,je
+real:: tx,ty,rx,ry
+real:: rio,rjo
+intrinsic::ceiling,floor
+
+!*** executable
+
+!check mesh dimensions and domain dimensions
+call check_mesh_2dim(its1,ite1,jts1,jte1,ims1,ime1,jms1,jme1)
+call check_mesh_2dim(its2,ite2,jts2,jte2,ims2,ime2,jms2,jme2)
+
+! compute mesh ratios
+rx=1./ir
+ry=1./jr
+
+do j2=jts2,jte2-1               ! loop over mesh 2 cells
+    rjo=rjp1+jr*(j2-rjp2)       ! mesh 1 coordinate of the mesh 2 patch start
+    js=max(jts1,ceiling(rjo))   ! lower bound of mesh 1 patch for this mesh 2 cell
+    je=min(jte1,floor(rjo)+jr)  ! upper bound of mesh 1 patch for this mesh 2 cell 
+    do i2=its2,ite2-1
+        rio=rip1+ir*(i2-rip2)
+        is=max(its1,ceiling(rio))
+        ie=min(ite1,floor(rio)+ir)
+        do j1=js,je
+            ty = (j1-rjo)*ry
+            do i1=is,ie
+                ! in case mesh 1 node lies on the boundary of several mesh 2 cells
+                ! the result will be written multiple times with the same value
+                ! up to a rounding error
+                tx = (i1-rio)*rx
+                !print *,'coarse ',i2,j2,'to',i2+1,j2+1,' fine ',is,js,' to ',ie,je
+                v1(i1,j1)=                     &
+                      (1-tx)*(1-ty)*v2(i2,j2)  &
+                 +    (1-tx)*ty  *v2(i2,j2+1)  &
+                 +      tx*(1-ty)*v2(i2+1,j2)  &
+                 +        tx*ty  *v2(i2+1,j2+1)  
+                !print *,'coarse ',i2,j2,' fine ',i1,j1, ' offset ',io,jo,' weights ',tx,ty, &
+                ! 'in ',v2(i2,j2),v2(i2,j2+1),v2(i2+1,j2),v2(i2+1,j2+1),' out ',v1(i1,j1)
+                !write(*,'(a,2i5,a,2f8.2,a,4f8.2,a,2i5,a,f8.2)') &
+                !'coarse ',i2,j2,' coord',rio,rjo,' val',v2(i2,j2),v2(i2,j2+1),v2(i2+1,j2),v2(i2+1,j2+1),&
+                !' fine ',i1,j1,' out ',v1(i1,j1)
+           enddo
+       enddo
+    enddo
+enddo
+
+end subroutine interpolate_2d
+
+!
+!****************
+!
+
+subroutine interpolate_2d_cells2cells(              &
+      ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2,v2, &  ! in  
+      ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1,v1  )  ! out
+implicit none
+
+!*** purpose
+! interpolate nodal values in mesh2 to nodal values in mesh1
+! input mesh 2 is coarse output mesh 1 is fine
+
+!*** arguments
+
+integer, intent(in)::ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1
+real, intent(out)::v1(ims1:ime1,jms1:jme1)
+integer, intent(in)::ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2
+real, intent(in)::v2(ims2:ime2,jms2:jme2)
+
+! Example with mesh ratio=4. | = cell boundary,  x = cell center
+!
+!  mesh2   |-------x-------|-------x-------|
+!  mesh1   |-x-|-x-|-x-|-x-|-x-|-x-|-x-|-x-| 
+!
+
+!*** local
+integer:: ir,jr,isz1,isz2,jsz1,jsz2,ip,jp,ih,jh
+character(len=128)msg
+
+!*** executable
+
+!check mesh dimensions and domain dimensions
+call check_mesh_2dim(ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1)
+call check_mesh_2dim(ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2)
+
+! compute mesh sizes
+isz1 = ide1-ids1+1
+jsz1 = jde1-jds1+1
+isz2 = ide2-ids2+1
+jsz2 = jde2-jds2+1
+
+! check mesh sizes
+if(isz1.le.0.or.jsz1.le.0.or.isz2.le.0.or.jsz2.le.0)goto 9
+if(mod(isz1,isz2).ne.0.or.mod(jsz1,jsz2).ne.0)goto 9
+
+! compute mesh ratios
+ir=isz1/isz2
+jr=jsz1/jsz2
+!
+!  mesh2   |-------x-------|-------x-------|
+!  mesh1   |-x-|-x-|-x-|-x-|-x-|-x-|-x-|-x-| 
+
+!  mesh2   |-----x-----|-----x-----|  rx=3
+!  mesh1   |-x-|-x-|-x-|-x-|-x-|-x-| 
+!  i2            1   1   1   2
+!  i1        1   2   3   4   5
+!  ioff          0   1   2   0
+!  tx            0  1/3 2/3
+
+!  mesh2   |---x---|---x---| rx=2
+!  mesh1   |-x-|-x-|-x-|-x-| 
+!  i2            1   1   2  
+!  i1            2   3   4
+!  ioff          0   1   2   
+!  tx           1/4 3/4
+
+
+! offset of the last node in the 1st half of the cell
+ih=ir/2
+jh=jr/2
+! 0 if coarse cell center coincides with fine, 1 if not
+ip=mod(ir+1,2)
+jp=mod(jr+1,2)
+
+call interpolate_2d_w(ip,jp,ih,jh,ir,jr,              &
+      ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2,v2, &  ! in  
+      ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1,v1  )  ! out
+
+return
+
+9 continue
+!$OMP CRITICAL(SFIRE_UTIL_CRIT)
+write(msg,91)ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2
+call message(msg)
+write(msg,91)ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1
+call message(msg)
+write(msg,92)'input  mesh size:',isz2,jsz2
+call message(msg)
+91 format('dimensions: ',8i8)
+write(msg,92)'output mesh size:',isz1,jsz1
+call message(msg)
+92 format(a,2i8)
+call crash("module_fr_sfire_util:interpolate_2dmesh_cells: bad mesh sizes")
+!$OMP END CRITICAL(SFIRE_UTIL_CRIT)
+end subroutine interpolate_2d_cells2cells
+
+!
+!****************
+!
+
+subroutine interpolate_2d_cells2nodes(              &
+      ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2,v2, &  ! in  
+      ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1,v1  )  ! out
+implicit none
+
+!*** purpose
+! interpolate nodal values in mesh2 to nodal values in mesh1
+! input mesh 2 is coarse output mesh 1 is fine
+
+!*** arguments
+
+integer, intent(in)::ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1
+real, intent(out)::v1(ims1:ime1,jms1:jme1)
+integer, intent(in)::ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2
+real, intent(in)::v2(ims2:ime2,jms2:jme2)
+
+! Example with mesh ratio=4. | = cell boundary,  x = cell center
+!
+!  mesh2   |-------x-------|-------x-------|
+!  mesh1   x-|-x-|-x-|-x-|-x-|-x-|-x-|-x-|-x 
+!
+
+!*** local
+integer:: ir,jr,isz1,isz2,jsz1,jsz2,ip,jp,ih,jh
+character(len=128)msg
+
+!*** executable
+
+!check mesh dimensions and domain dimensions
+call check_mesh_2dim(ids1,ide1+1,jds1,jde1+1,ims1,ime1,jms1,jme1)
+call check_mesh_2dim(ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2)
+
+! compute mesh sizes
+isz1 = ide1-ids1+1
+jsz1 = jde1-jds1+1
+isz2 = ide2-ids2+1
+jsz2 = jde2-jds2+1
+
+! check mesh sizes
+if(isz1.le.0.or.jsz1.le.0.or.isz2.le.0.or.jsz2.le.0)goto 9
+if(mod(isz1,isz2).ne.0.or.mod(jsz1,jsz2).ne.0)goto 9
+
+! compute mesh ratios
+ir=isz1/isz2
+jr=jsz1/jsz2
+!
+!  mesh2   |-------x-------|-------x-------|
+!  mesh1   x-|-x-|-x-|-x-|-x-|-x-|-x-|-x-|-x 
+
+!  mesh2   |-----x-----|-----x-----|  rx=3
+!  mesh1   x-|-x-|-x-|-x-|-x-|-x-|-x 
+
+!  mesh2   |---x---|---x---| rx=2
+!  mesh1   x-|-x-|-x-|-x-|-x 
+
+! offset of the last node in the 1st half of the cell
+ih=(ir+1)/2
+jh=(jr+1)/2
+! 0 if coarse cell center coincides with fine, 1 if not
+ip=mod(ir,2)
+jp=mod(jr,2)
+
+
+call interpolate_2d_w(ip,jp,ih,jh,ir,jr,              &
+      ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2,v2, &  ! in  
+      ids1,ide1+1,jds1,jde1+1,ims1,ime1,jms1,jme1,v1  )  ! out
+
+
+return
+9 continue
+!$OMP CRITICAL(SFIRE_UTIL_CRIT)
+write(msg,91)ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2
+call message(msg)
+write(msg,91)ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1
+call message(msg)
+write(msg,92)'input  mesh size:',isz2,jsz2
+call message(msg)
+91 format('dimensions: ',8i8)
+write(msg,92)'output mesh size:',isz1,jsz1
+call message(msg)
+92 format(a,2i8)
+call crash("module_fr_sfire_util:interpolate_2d_cells2nodes: bad mesh sizes")
+!$OMP END CRITICAL(SFIRE_UTIL_CRIT)
+end subroutine interpolate_2d_cells2nodes
+!
+!****************
+!
+
+subroutine interpolate_2d_w(ip,jp,ih,jh,ir,jr,             &
+      ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2,v2, &  ! in  
+      ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1,v1  )  ! out
+implicit none
+!*** EXCEPTION: THIS SUBROUTINE IS NEITHER CELL NOR NODE BASED.
+
+integer, intent(in)::ip,jp,ih,jh,ir,jr
+integer, intent(in)::ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1
+real, intent(out)::v1(ims1:ime1,jms1:jme1)
+integer, intent(in)::ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2
+real, intent(in)::v2(ims2:ime2,jms2:jme2)
+
+real:: tx,ty,rx,ry,half,xoff,yoff
+integer:: i1,i2,j1,j2,ioff,joff
+parameter(half=0.5)
+
+rx=ir
+ry=jr
+
+xoff = ip*half
+yoff = jp*half
+
+! the inside, ids1+ih:ide1-ih,jds1+jh:jde1-jh 
+do j2=jds2,jde2-1     ! interpolate from nodes j2 and j2+1
+    do i2=ids2,ide2-1
+        do ioff=0,ir-ip
+            do joff=0,jr-jp
+                ! compute fine mesh index
+                i1=ioff+(ih+ids1)+ir*(i2-ids2)
+                j1=joff+(jh+jds1)+jr*(j2-jds2)
+                ! weights
+                tx = (ioff+xoff)/rx
+                ty = (joff+yoff)/ry
+                ! interpolation
+                v1(i1,j1)=                     &
+                      (1-tx)*(1-ty)*v2(i2,j2)  &
+                 +    (1-tx)*ty  *v2(i2,j2+1)  &
+                 +      tx*(1-ty)*v2(i2+1,j2)  &
+                 +        tx*ty  *v2(i2+1,j2+1)  
+                !write(*,'(3(a,2i5),a,2f7.4)')'coarse ',i2,j2,' fine ',i1,j1, &
+                ! ' offset ',ioff,joff,' weights ',tx,ty
+                !write(*,'(a,4f7.4,a,f7.4)')'in ',v2(i2,j2),v2(i2,j2+1),v2(i2+1,j2), &
+                !  v2(i2+1,j2+1),' out ',v1(i1,j1)
+           enddo
+       enddo
+    enddo
+enddo
+
+! extend to the boundary strips from the nearest known
+do ioff=0,ih-1  ! top and bottom strips
+    do j2=jds2,jde2-1
+        do joff=0,jr-jp
+           j1=joff+(jh+jds1)+jr*(j2-jds2)
+           ! weights
+           ty = (joff+yoff)/ry
+           ! interpolation
+           v1(ids1+ioff,j1)=(1-ty)*v2(ids2,j2)+ty*v2(ids2,j2+1)
+           v1(ide1-ioff,j1)=(1-ty)*v2(ide2,j2)+ty*v2(ide2,j2+1)
+       enddo
+    enddo
+enddo
+do joff=0,jh-1  ! left and right strips
+    do i2=ids2,ide2-1
+        do ioff=0,ir-ip
+           i1=ioff+(ih+ids1)+ir*(i2-ids2)
+           ! weights
+           tx = (ioff+xoff)/rx
+           ! interpolation
+           v1(i1,jds1+joff)=(1-tx)*v2(i2,jds2)+tx*v2(i2+1,jds2)
+           v1(i1,jde1-joff)=(1-tx)*v2(i2,jde2)+tx*v2(i2+1,jde2)
+       enddo
+    enddo
+enddo
+! extend to the 4 corner squares from the nearest known
+do ioff=0,ih-1  
+    do joff=0,jh-1
+        v1(ids1+ioff,jds1+joff)=v2(ids2,jds2)
+        v1(ide1-ioff,jds1+joff)=v2(ide2,jds2)
+        v1(ids1+ioff,jde1-joff)=v2(ids2,jde2)
+        v1(ide1-ioff,jde1-joff)=v2(ide2,jde2)
+    enddo
+enddo         
+end subroutine interpolate_2d_w  
+
+!
+!****************
+!
+                
+real function interp(ids,ide,jds,jde,ims,ime,jms,jme,x,y,v)
+implicit none
+!*** purpose
+! general interpolation in a rectangular
+
+!*** arguments
+
+integer, intent(in)::ids,ide,jds,jde,ims,ime,jms,jme
+real, intent(in)::x,y,v(ims:ime,jms:jme)
+! the mesh is cell based so the used dimension of v is ids:ide+1,jds:jde+1
+
+!*** calls
+intrinsic floor,min,max
+
+!*** local
+integer i,j
+real tx,ty
+
+! executable
+
+! indices of the lower left corner of the cell in the mesh that contains (x,y)
+i = floor(x)
+i=max(min(i,ide),ids)
+j = floor(y)
+j=max(min(j,jde),jds)
+
+! the leftover
+tx = x - real(i)
+ty = y - real(j)
+
+! interpolate the values
+interp = &
+                    (1-tx)*(1-ty)*v(i,j)    &
+                 +    tx*(1-ty)  *v(i+1,j)  &
+                 +    (1-tx)*ty  *v(i,j+1)  &
+                 +        tx*ty  *v(i+1,j+1)  
+
+!print *,'x,y=',x,y,'i1,i2=',i1,j1,'tx,ty=',tx,ty,' interp=',interp
+end function interp
+
+subroutine meshdiffc_2d(ids, ide, jds,jde , &    ! mesh area used (in cells, end +1)
+                   ims1,ime1,jms1,jme1, &       ! memory dimensiuons 
+                   dx,dy,               &       ! mesh spacing
+                   lfn,                 &       ! input
+                   diffCx,diffCy) ! output
+implicit none
+
+!*** purpose
+! central differences on a 2d mesh
+
+!*** arguments
+
+integer, intent(in)::ids,ide,jds,jde,ims1,ime1,jms1,jme1
+real, intent(in):: dx,dy
+real, intent(in), dimension(ims1:ime1,jms1:jme1):: lfn
+real, intent(out), dimension(ims1:ime1,jms1:jme1):: diffCx,diffCy
+
+!*** local
+integer:: i,j
+real, dimension(ims1:ime1,jms1:jme1):: diffLx,diffRx,diffLy,diffRy
+
+! get one-sided differences; dumb but had that already...
+call meshdiff_2d(ids, ide, jds,jde , &    ! mesh area used (in cells, end +1)
+                   ims1,ime1,jms1,jme1, &       ! dimensions of lfn 
+                   dx,dy,               &       ! mesh spacing
+                   lfn,                 &       ! input
+                   diffLx,diffRx,diffLy,diffRy) ! output
+
+! make into central
+do j=jds,jde+1
+    do i=ids,ide+1
+        diffCx(i,j)=0.5*(diffLx(i,j) + diffRx(i,j))
+        diffCy(i,j)=0.5*(diffLy(i,j) + diffRy(i,j))
+    enddo
+enddo
+end subroutine meshdiffc_2d 
+
+subroutine meshdiff_2d(ids, ide, jds,jde , &    ! mesh area used (in cells, end +1)
+                   ims1,ime1,jms1,jme1, &       ! dimensions of lfn 
+                   dx,dy,               &       ! mesh spacing
+                   lfn,                 &       ! input
+                   diffLx,diffRx,diffLy,diffRy) ! output
+implicit none
+
+!*** purpose
+! one-sided differences on a 2d mesh
+
+!*** arguments
+
+integer, intent(in)::ids,ide,jds,jde,ims1,ime1,jms1,jme1
+real, intent(in):: dx,dy
+real, intent(in), dimension(ims1:ime1,jms1:jme1):: lfn
+real, intent(out), dimension(ims1:ime1,jms1:jme1):: diffLx,diffRx,diffLy,diffRy
+
+!*** local
+integer:: i,j
+real:: tmpx,tmpy
+
+!*** executable
+
+    call check_mesh_2dim(ids,ide+1,jds,jde+1,ims1,ime1,jms1,jme1)
+  
+    ! the bulk of the work
+    do j=jds,jde
+        do i=ids,ide
+            tmpx = (lfn(i+1,j)-lfn(i,j))/dx
+            diffLx(i+1,j) = tmpx
+            diffRx(i,j)   = tmpx
+            tmpy = (lfn(i,j+1)-lfn(i,j))/dy
+            diffLy(i,j+1) = tmpy
+            diffRy(i,j)   = tmpy
+        enddo
+        ! missing values - put there the other one
+        diffLx(ids,j)  = diffLx(ids+1,j)
+        diffRx(ide+1,j)= diffRx(ide,j)
+    enddo
+    ! cleanup
+    ! j=jde+1 from above loop
+    do i=ids,ide
+        tmpx = (lfn(i+1,j)-lfn(i,j))/dx
+        diffLx(i+1,j) = tmpx
+        diffRx(i,j)   = tmpx
+    enddo
+    ! i=ide+1 from above loop
+    do j=jds,jde
+        tmpy = (lfn(i,j+1)-lfn(i,j))/dy
+        diffLy(i,j+1) = tmpy
+        diffRy(i,j)   = tmpy
+    enddo
+    ! missing values - put there the other one
+    ! j=jde+1 from above loop, j=jds:jde done before in main bulk loop
+    diffLx(ids,j)   = diffLx(ids+1,j)
+    diffRx(ide+1,j) = diffRx(ide,j)
+    do i=ids,ide+1
+        diffLy(i,jds)   = diffLy(i,jds+1)
+        diffRy(i,jde+1) = diffRy(i,jde)
+    enddo    
+
+end subroutine meshdiff_2d
+
+
+
+
+real pure function sum_2darray( its,ite,jts,jte,               &
+                                ims,ime,jms,jme,               &
+                                a)
+integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme
+real, intent(in)::a(ims:ime,jms:jme)
+!*** local
+integer:: i,j
+real:: t
+t=0.
+do j=jts,jte
+    do i=its,ite
+        t=t+a(i,j)
+    enddo
+enddo
+sum_2darray = t
+end function sum_2darray
+
+real pure function max_2darray( its,ite,jts,jte,               &
+                                ims,ime,jms,jme,               &
+                                a)
+integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme
+real, intent(in)::a(ims:ime,jms:jme)
+!*** local
+integer:: i,j
+real:: t
+t=0.
+do j=jts,jte
+    do i=its,ite
+        t=max(t,a(i,j))
+    enddo
+enddo
+max_2darray = t
+end function max_2darray
+
+subroutine print_2d_stats_vec(ips,ipe,jps,jpe, &
+                         ims,ime,jms,jme, &
+                         ax,ay,name)
+implicit none
+integer, intent(in)::ips,ipe,jps,jpe,ims,ime,jms,jme
+real, intent(in), dimension(ims:ime,jms:jme)::ax,ay
+character(len=*),intent(in)::name
+integer:: i,j
+real:: t 
+real:: avg_a,max_a,min_a 
+character(len=25)::id
+id=name
+call print_2d_stats(ips,ipe,jps,jpe, &
+                         ims,ime,jms,jme, &
+                         ax,id//'/x ')
+call print_2d_stats(ips,ipe,jps,jpe, &
+                         ims,ime,jms,jme, &
+                         ay,id//'/y ')
+avg_a=0
+max_a=-huge(max_a)
+min_a= huge(min_a)
+do j=jps,jpe
+    do i=ips,ipe
+        t=sqrt(ax(i,j)**2+ay(i,j)**2)
+        max_a=max(max_a,t)
+        min_a=min(min_a,t)
+        avg_a=avg_a+t
+    enddo
+enddo
+avg_a = avg_a/((ipe-ips+1)*(jpe-jps+1))
+call print_stat_line(id//'/sz',ips,ipe,jps,jpe,min_a,max_a,avg_a)
+end subroutine print_2d_stats_vec
+
+
+subroutine print_stat_line(name,ips,ipe,jps,jpe,min_a,max_a,avg_a)
+!*** encapsulate line with statistics
+implicit none
+!*** arguments
+integer, intent(in)::ips,ipe,jps,jpe
+character(len=*),intent(in)::name
+real,intent(in)::min_a,max_a,avg_a
+!*** local
+character(len=128)::msg
+character(len=24)::id
+if(fire_print_msg.eq.0)return
+id=name
+!$OMP CRITICAL(SFIRE_UTIL_CRIT)
+write(msg,'(a,4i4,3g11.3)')id,ips,ipe,jps,jpe,min_a,max_a,avg_a
+!$OMP END CRITICAL(SFIRE_UTIL_CRIT)
+call message(msg)
+if(.not.avg_a.eq.avg_a)call crash('NaN detected')
+end subroutine print_stat_line
+
+
+subroutine print_3d_stats(ips,ipe,kps,kpe,jps,jpe, &
+                         ims,ime,kms,kme,jms,jme, &
+                         a,name)
+implicit none
+integer, intent(in)::ips,ipe,jps,jpe,ims,ime,jms,jme,kms,kme,kps,kpe
+real, intent(in)::a(ims:ime,kms:kme,jms:jme)
+character(len=*),intent(in)::name
+integer:: i,j,k
+real:: avg_a,max_a,min_a,t,aa,bb
+character(len=128)::msg
+! if(fire_print_msg.eq.0)return
+! check for nans in any case
+bb=0.
+do j=jps,jpe
+  do k=kps,kpe
+    do i=ips,ipe
+       bb=bb+a(i,k,j)
+    enddo
+  enddo
+enddo
+if(bb.eq.bb.and.fire_print_msg.eq.0)return
+avg_a=0
+max_a=-huge(max_a)
+min_a= huge(min_a)
+t=huge(t)
+do j=jps,jpe
+  do k=kps,kpe
+    do i=ips,ipe
+        aa=a(i,k,j)
+        if(aa.ne.aa.or..not.aa.le.t.or..not.aa.ge.-t)goto 9
+        max_a=max(max_a,aa)
+        min_a=min(min_a,aa)
+        avg_a=avg_a+aa
+    enddo
+  enddo
+enddo
+if(bb.ne.bb)goto 10 ! should never happen 
+if(fire_print_msg.eq.0)return
+avg_a = avg_a/((ipe-ips+1)*(jpe-jps+1)*(kpe-kps+1))
+call print_stat_line(name,ips,ipe,jps,jpe,min_a,max_a,avg_a)
+return
+9 continue
+!$OMP CRITICAL(SFIRE_UTIL_CRIT)
+write(msg,1)name,i,k,j,aa
+call message(msg)
+1 format(a30,'(',i6,',',i6,',',i6,') = ',g13.5)
+!$OMP END CRITICAL(SFIRE_UTIL_CRIT)
+call print_stat_line(name,ips,ipe,jps,jpe,aa,aa,aa)
+if(aa.ne.aa)goto 10
+msg='Invalid floating point number detected in '//name
+call crash(msg)
+10 msg='NaN detected in '//name
+call crash(msg)
+end subroutine print_3d_stats
+
+subroutine print_2d_stats(ips,ipe,jps,jpe, &
+                         ims,ime,jms,jme, &
+                         a,name)
+implicit none
+integer, intent(in)::ips,ipe,jps,jpe,ims,ime,jms,jme
+real, intent(in)::a(ims:ime,jms:jme)
+character(len=*),intent(in)::name
+!!character(len=128)::msg
+!if(fire_print_msg.eq.0)return
+call print_3d_stats(ips,ipe,1,1,jps,jpe, &
+                         ims,ime,1,1,jms,jme, &
+                         a,name)
+!!write(msg,'(2a,z16)')name,' address =',loc(a)
+!!call message(msg)
+end subroutine print_2d_stats
+
+real pure function avg_2darray( its,ite,jts,jte,               &
+                                ims,ime,jms,jme,               &
+                                a)
+integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme
+real, intent(in)::a(ims:ime,jms:jme)
+!*** local
+!*** executable
+avg_2darray = sum_2darray( its,ite,jts,jte,               &
+                           ims,ime,jms,jme,               &
+                           a)/((ite-its+1)*(jte-jts+1))
+end function avg_2darray
+
+real pure function avg_2darray_vec( its,ite,jts,jte,           &
+                                ims,ime,jms,jme,               &
+                                ax,ay)
+integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme
+real, intent(in), dimension(ims:ime,jms:jme):: ax,ay
+!*** local
+integer:: i,j
+real:: t
+t=0.
+do j=jts,jte
+    do i=its,ite
+        t=t+sqrt(ax(i,j)**2+ay(i,j)**2)
+    enddo
+enddo
+t = t/((ite-its+1)*(jte-jts+1))
+avg_2darray_vec = t
+end function avg_2darray_vec
+
+
+subroutine print_array(its,ite,jts,jte,           &
+                         ims,ime,jms,jme,               &
+                         a,name,id)
+! debug
+!*** arguments
+integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme,id
+real, intent(in), dimension(ims:ime,jms:jme):: a
+character(len=*),intent(in)::name
+!****
+integer i,j
+character(len=128)::msg
+!****
+!$OMP CRITICAL(SFIRE_UTIL_CRIT)
+write(msg,*)name,' start ',id,' dim ',its,ite,jts,jte
+call message(msg)
+do j=jts,jte
+    do i=its,ite
+         write(msg,*)i,j,a(i,j)
+         call message(msg)
+    enddo
+enddo
+write(msg,*)name,' end ',id
+call message(msg)
+!$OMP END CRITICAL(SFIRE_UTIL_CRIT)
+end subroutine print_array
+
+subroutine write_array_m(its,ite,jts,jte,           &
+                         ims,ime,jms,jme,               &
+                         a,name,id)
+! debug
+!*** arguments
+integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme,id
+real, intent(in), dimension(ims:ime,jms:jme):: a
+character(len=*),intent(in)::name
+!****
+call write_array_m3(its,ite,1,1,jts,jte,           &
+                         ims,ime,1,1,jms,jme,               &
+                         a,name,id)
+end subroutine write_array_m
+
+
+subroutine write_array_m3(its,ite,kts,kte,jts,jte,           &
+                         ims,ime,kms,kme,jms,jme,               &
+                         a,name,id)
+
+implicit none
+! debug
+!*** arguments
+integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme,kts,kte,kms,kme,id
+real, intent(in), dimension(ims:ime,kms:kme,jms:jme):: a
+character(len=*),intent(in)::name
+!****
+integer i,j,k,iu,ilen,myproc,nprocs
+logical op
+character(len=128)::fname,msg
+!****
+if(fire_print_file.eq.0.or.id.le.0)return
+call check_mesh_2dim(its,ite,jts,jte,ims,ime,jms,jme)
+call wrf_get_nproc (nprocs)
+call wrf_get_myproc(myproc)
+
+!$OMP CRITICAL(SFIRE_UTIL_CRIT)
+if(nprocs.eq.1)then
+    write(fname,3)name,'_',id,'.txt'
+else
+    write(fname,4)name,'_',id,'.',myproc,'.txt'
+endif
+
+iu=0
+do i=6,99
+    inquire(unit=i,opened=op)
+    if(.not.op.and.iu.le.0)iu=i
+enddo
+if(iu.gt.0)open(iu,file=trim(fname),form='formatted',status='unknown')
+
+if(iu.le.0)call crash('write_array_m: cannot find available fortran unit')
+
+write(iu,1)real(its)
+write(iu,1)real(ite)
+write(iu,1)real(jts)
+write(iu,1)real(jte)
+write(iu,1)real(kts)
+write(iu,1)real(kte)
+write(iu,1)(((a(i,k,j),i=its,ite),j=jts,jte),k=kts,kte)
+close(iu)
+write(msg,2)name,'(',its,':',ite,',',jts,':',jte,',', &
+kts,':',kte,') -> ',trim(fname) 
+!$OMP END CRITICAL(SFIRE_UTIL_CRIT)
+call message(msg)
+return
+
+1 format(e20.12)
+2 format(2a,3(i5,a,i5,a),2a)
+3 format(a,a,i8.8,a)
+4 format(a,a,i8.8,a,i4.4,a)
+
+
+end subroutine write_array_m3
+!
+!***
+!
+subroutine read_array_2d_integer(filename,ia,its,ite,jts,jte,ims,ime,jms,jme)
+!*** arguments
+integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme
+integer, intent(out), dimension(ims:ime,jms:jme):: ia
+character(len=*),intent(in)::filename
+!*** local
+real, allocatable, dimension(:,:)::a
+integer::i,j
+real::r
+character(len=256)msg
+!*** executable
+allocate(a(ims:ime,jms:jme))
+call read_array_2d_real(filename,a,its,ite,jts,jte,ims,ime,jms,jme)
+do j=jts,jte
+    do i=its,ite
+        ia(i,j)=a(i,j)
+	r=ia(i,j)
+	if(r.ne.a(i,j))then
+           write(6,*)'Reading file ',trim(filename)
+           write(6,*)'value at position ',i,j,' cannot be converted to integer'
+           write(6,*)'read ',a(i,j),' converted as',k,' converted as ',r
+	   msg=trim(filename)//' is not integer file'
+	   call crash(msg)
+        endif
+    enddo
+enddo
+end subroutine read_array_2d_integer
+
+        
+
+subroutine read_array_2d_real(filename,a,its,ite,jts,jte,ims,ime,jms,jme)
+#ifdef _OPENMP
+use OMP_LIB 
+#endif
+implicit none
+!*** purpose: read a 2D array from a text file
+! file format: line 1: array dimensions ni,nj
+!              following lines: one row of a at a time
+!              each row may be split between several lines
+!*** arguments
+integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme
+real, intent(out), dimension(ims:ime,jms:jme):: a
+character(len=*),intent(in)::filename
+!*** local
+integer i,j,ni,nj,mi,mj,nprocs,myproc,mythread,iu
+logical op
+character(len=128)::fname,msg
+!*** executable
+
+call wrf_get_nproc (nprocs)
+call wrf_get_myproc( myproc )
+mythread=0
+#ifdef _OPENMP
+    mythread=omp_get_thread_num()
+#endif
+if(nprocs.ne.1.or.myproc.ne.0.or.mythread.ne.0) &
+   call crash('read_array_2d: parallel execution not supported')
+
+! print line
+mi=ite-its+1
+mj=jte-jts+1
+write(msg,2)'reading array size ',mi,mj,' from file ',trim(filename)
+2 format(a,2i6,2a)
+call message(msg)
+
+! check array index overflow
+call check_mesh_2dim(its,ite,jts,jte,ims,ime,jms,jme)
+
+! find available unit
+iu=0
+do i=11,99
+    inquire(unit=i,opened=op)
+    if(.not.op.and.iu.le.0)iu=i
+enddo
+if(iu.le.0)call crash('read_array_2d: cannot find available fortran unit')
+
+if(iu.gt.0)open(iu,file=filename,form='formatted',status='old',err=9)
+rewind(iu,err=9)
+
+read(iu,*,err=10)ni,nj
+if(ni.ne.mi.or.nj.ne.mj)then
+    write(msg,'(a,2i6,a,2i6)')'Array dimensions',ni,nj,' in the input file should be ',mi,mj
+    call message(msg)
+    goto 10
+endif
+do i=its,ite
+   read(iu,*,err=10)(a(i,j),j=jts,jte)
+enddo
+close(iu,err=11)
+return
+
+9  msg='Error opening file '//trim(filename)
+call crash(msg)
+10 msg='Error reading file '//trim(filename)
+call crash(msg)
+11 msg='Error closing file '//trim(filename)
+call crash(msg)
+end subroutine read_array_2d_real
+!
+!***
+!
+
+! general conditional expression
+pure integer function ifval(l,i,j)
+implicit none
+logical, intent(in)::l
+integer, intent(in)::i,j
+if(l)then
+	ifval=i
+else
+	ifval=j
+endif
+end function ifval
+
+! function to go beyond domain boundary if tile is next to it
+pure integer function snode(t,d,i)
+implicit none
+integer, intent(in)::t,d,i
+if(t.ne.d)then
+    snode=t
+else
+    snode=t+i
+endif
+end function snode
+
+subroutine print_chsum( id, & 
+    ims,ime,kms,kme,jms,jme, &                ! memory dims
+    ids,ide,kds,kde,jds,jde, &                ! domain dims
+    ips,ipe,kps,kpe,jps,jpe, &                ! patch or tile dims
+    istag,kstag,jstag,       &
+    a,name)                      
+
+#ifdef DM_PARALLEL
+    USE module_dm , only : wrf_dm_bxor_integer
+#endif
+
+integer, intent(in):: id, &
+    ims,ime,kms,kme,jms,jme, &                ! memory dims
+    ids,ide,kds,kde,jds,jde, &                ! domain dims
+    ips,ipe,kps,kpe,jps,jpe, &                ! patch dims
+    istag,kstag,jstag
+real, intent(in),dimension(ims:ime,kms:kme,jms:jme)::a
+character(len=*)::name
+
+!$ external, logical:: omp_in_parallel
+!$ external, integer:: omp_get_thread_num
+
+!*** local
+integer::lsum
+integer::i,j,k,n,ipe1,jpe1,kpe1,iel,thread,is,js,ks
+integer, save::psum,gsum
+real::rel
+equivalence(rel,iel)
+character(len=256)msg
+
+if(fire_print_msg.le.0)return
+
+ipe1=ifval(ipe.eq.ide.and.istag.ne.0,ipe+1,ipe)
+kpe1=ifval(kpe.eq.kde.and.kstag.ne.0,kpe+1,kpe)
+jpe1=ifval(jpe.eq.jde.and.jstag.ne.0,jpe+1,jpe)
+is=ifval(istag.ne.0,1,0)
+ks=ifval(kstag.ne.0,1,0)
+js=ifval(jstag.ne.0,1,0)
+
+lsum=0
+do j=jps,jpe1
+  do k=kps,kpe1
+    do i=ips,ipe1
+      rel=a(i,k,j)
+      lsum=ieor(lsum,iel)
+    enddo
+  enddo
+enddo
+
+! get process sum over all threads
+thread=0
+!$ thread=omp_get_thread_num()
+if(thread.eq.0)psum=0
+!$OMP BARRIER
+!$OMP CRITICAL(CHSUM)
+psum=ieor(psum,lsum)
+!$OMP END CRITICAL(CHSUM)
+!$OMP BARRIER
+
+! get global sum over all processes
+if(thread.eq.0)then
+#ifdef DM_PARALLEL
+    gsum = wrf_dm_bxor_integer ( psum )
+#else
+    gsum = psum
+#endif
+    write(msg,1)id,name,ids,ide+is,kds,kde+ks,jds,jde+js,gsum
+1   format(i6,1x,a10,' dims',6i5,' chsum ',z8.8)
+    call message(msg)
+endif
+
+end subroutine print_chsum 
+
+
+real function fun_real(fun,  & 
+    ims,ime,kms,kme,jms,jme, &                ! memory dims
+    ids,ide,kds,kde,jds,jde, &                ! domain dims
+    ips,ipe,kps,kpe,jps,jpe, &                ! patch or tile dims
+    istag,kstag,jstag,       &                ! staggering
+    a,b)                      
+
+#ifdef DM_PARALLEL
+    USE module_dm , only : wrf_dm_sum_real , wrf_dm_max_real
+#endif
+
+integer, intent(in)::  fun, &
+    ims,ime,kms,kme,jms,jme, &                ! memory dims
+    ids,ide,kds,kde,jds,jde, &                ! domain dims
+    ips,ipe,kps,kpe,jps,jpe, &                ! patch dims
+    istag,kstag,jstag                         ! staggering
+real, intent(in),dimension(ims:ime,kms:kme,jms:jme)::a,b
+
+!*** local
+real::lsum,void
+integer::i,j,k,n,ipe1,jpe1,kpe1,iel,thread,is,js,ks
+real, save::psum,gsum
+real::rel
+logical:: dosum,domax
+character(len=256)msg
+
+ipe1=ifval(ipe.eq.ide.and.istag.ne.0,ipe+1,ipe)
+kpe1=ifval(kpe.eq.kde.and.kstag.ne.0,kpe+1,kpe)
+jpe1=ifval(jpe.eq.jde.and.jstag.ne.0,jpe+1,jpe)
+is=ifval(istag.ne.0,1,0)
+ks=ifval(kstag.ne.0,1,0)
+js=ifval(jstag.ne.0,1,0)
+
+if(fun.eq.REAL_SUM)then
+  void=0.
+  lsum=void
+  do j=jps,jpe1
+    do k=kps,kpe1
+      do i=ips,ipe1
+        lsum=lsum+a(i,k,j)
+      enddo
+    enddo
+  enddo
+elseif(fun.eq.RNRM_SUM)then
+  void=0.
+  lsum=void
+  do j=jps,jpe1
+    do k=kps,kpe1
+      do i=ips,ipe1
+        lsum=lsum+sqrt(a(i,k,j)*a(i,k,j)+b(i,k,j)*b(i,k,j))
+      enddo
+    enddo
+  enddo
+elseif(fun.eq.REAL_MAX)then
+  void=-huge(lsum)
+  lsum=void
+  do j=jps,jpe1
+    do k=kps,kpe1
+      do i=ips,ipe1
+        lsum=max(lsum,a(i,k,j))
+      enddo
+    enddo
+  enddo
+elseif(fun.eq.RNRM_MAX)then
+  void=0.
+  lsum=void
+  do j=jps,jpe1
+    do k=kps,kpe1
+      do i=ips,ipe1
+        lsum=max(lsum,sqrt(a(i,k,j)*a(i,k,j)+b(i,k,j)*b(i,k,j)))
+      enddo
+    enddo
+  enddo
+else
+  call crash('fun_real: bad fun')
+endif
+
+if(lsum.ne.lsum)call crash('fun_real: NaN detected')
+
+dosum=fun.eq.REAL_SUM.or.fun.eq.RNRM_SUM
+domax=fun.eq.REAL_MAX.or.fun.eq.RNRM_MAX
+
+! get process sum over all threads
+!$OMP SINGLE
+! only one thread should write to shared variable
+psum=void
+!$OMP END SINGLE
+!$OMP BARRIER
+! now all threads know psum
+
+!$OMP CRITICAL(RDSUM)
+! each thread adds its own lsum
+if(dosum)psum=psum+lsum
+if(domax)psum=max(psum,lsum)
+!$OMP END CRITICAL(RDSUM)
+
+! wait till all theads are done
+!$OMP BARRIER
+
+! get global sum over all processes
+!$OMP SINGLE
+! only one threads will do the mpi communication
+#ifdef DM_PARALLEL
+    if(dosum) gsum = wrf_dm_sum_real ( psum )
+    if(domax) gsum = wrf_dm_max_real ( psum )
+#else
+    gsum = psum
+#endif
+if(gsum.ne.gsum)call crash('fun_real: NaN detected')
+!$OMP END SINGLE
+
+!$OMP BARRIER
+! now gsum is known to all threads
+
+fun_real=gsum
+
+end function fun_real
+
+end module module_fr_sfire_util
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_gfs_funcphys.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_gfs_funcphys.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_gfs_funcphys.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_gfs_machine.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_gfs_machine.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_gfs_machine.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_gfs_physcons.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_gfs_physcons.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_gfs_physcons.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_gocart_seasalt.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_gocart_seasalt.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_gocart_seasalt.F	(revision 17)
@@ -0,0 +1,261 @@
+MODULE GOCART_SEASALT
+
+CONTAINS
+  subroutine gocart_seasalt_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u_phy,  &
+         v_phy,chem,rho_phy,dz8w,u10,v10,p8w,                  &
+         xland,xlat,xlong,dx,g,emis_seas, &
+         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, ONLY: mwdry
+  IMPLICIT NONE
+   TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
+
+   INTEGER,      INTENT(IN   ) :: julday, ktau,                     &
+                                  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_moist ),                &
+         INTENT(IN ) ::                                   moist
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),                 &
+         INTENT(INOUT ) ::                                   chem
+   REAL, DIMENSION( ims:ime, 1, jms:jme,num_emis_seas),OPTIONAL,&
+         INTENT(INOUT ) ::                                                 &
+         emis_seas
+   REAL,  DIMENSION( ims:ime , jms:jme )                   ,               &
+          INTENT(IN   ) ::                                                 &
+                                                     u10,                  &
+                                                     v10,                  &
+                                                     xland,                &
+                                                     xlat,                 &
+                                                     xlong
+   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ),                        &
+          INTENT(IN   ) ::                                                 &
+                                                        alt,               &
+                                                      t_phy,               &
+                                                     dz8w,p8w,             &
+                                              u_phy,v_phy,rho_phy
+
+  REAL, INTENT(IN   ) :: dt,dx,g
+!
+! local variables
+!
+  integer :: ipr,nmx,i,j,k,ndt,imx,jmx,lmx
+  integer,dimension (1,1) :: ilwi
+  real*8, DIMENSION (4) :: tc,bems
+  real*8, dimension (1,1) :: w10m,gwet,airden,airmas
+  real*8, dimension (1) :: dxy
+  real*8 conver,converi
+  conver=1.d-9
+  converi=1.d9
+!
+! number of dust bins
+!
+  imx=1
+  jmx=1
+  lmx=1
+  nmx=4
+  k=kts
+  do j=jts,jte
+  do i=its,ite
+!
+! doná¹« do dust over water!!!
+!
+     if(xland(i,j).gt.1.5)then
+     ilwi(1,1)=0
+     tc(1)=chem(i,kts,j,p_seas_1)*conver
+     tc(2)=chem(i,kts,j,p_seas_2)*conver
+     tc(3)=chem(i,kts,j,p_seas_3)*conver
+     tc(4)=chem(i,kts,j,p_seas_4)*conver
+     w10m(1,1)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
+     airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*dx*dx/g
+!
+! we doná¹« trust the u10,v10 values, is model layers are very thin near surface
+!
+     if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j))
+!
+     dxy(1)=dx*dx
+       ipr=0
+
+    call source_ss( imx,jmx,lmx,nmx, dt, tc,ilwi, dxy, w10m, airmas, bems,ipr)
+     chem(i,kts,j,p_seas_1)=tc(1)*converi
+     chem(i,kts,j,p_seas_2)=tc(2)*converi
+     chem(i,kts,j,p_seas_3)=tc(3)*converi
+     chem(i,kts,j,p_seas_4)=tc(4)*converi
+! for output diagnostics
+     emis_seas(i,1,j,p_edust1)=bems(1)
+     emis_seas(i,1,j,p_edust2)=bems(2)
+     emis_seas(i,1,j,p_edust3)=bems(3)
+     emis_seas(i,1,j,p_edust4)=bems(4)
+     endif
+  enddo
+  enddo
+!
+
+end subroutine gocart_seasalt_driver
+!
+SUBROUTINE source_ss(imx,jmx,lmx,nmx, dt1, tc, &
+                     ilwi, dxy, w10m, airmas, &
+                     bems,ipr)
+
+! ****************************************************************************
+! *  Evaluate the source of each seasalt particles size classes  (kg/m3) 
+! *  by soil emission.
+! *  Input:
+! *         SSALTDEN  Sea salt density                               (kg/m3)
+! *         DXY       Surface of each grid cell                     (m2)
+! *         NDT1      Time step                                     (s)
+! *         W10m      Velocity at the anemometer level (10meters)   (m/s)
+! *      
+! *  Output:
+! *         DSRC      Source of each sea salt bins       (kg/timestep/cell) 
+! *
+! *
+! * Number flux density: Original formula by Monahan et al. (1986) adapted
+! * by Sunling Gong (JGR 1997 (old) and GBC 2003 (new)).  The new version is
+! * to better represent emission of sub-micron sea salt particles.
+!
+! * dFn/dr = c1*u10**c2/(r**A) * (1+c3*r**c4)*10**(c5*exp(-B**2))
+! * where B = (b1 -log(r))/b2
+! * see c_old, c_new, b_old, b_new below for the constants.
+! * number fluxes are at 80% RH.
+! *
+! * To calculate the flux:
+! * 1) Calculate dFn based on Monahan et al. (1986) and Gong (2003)
+! * 2) Assume that wet radius r at 80% RH = dry radius r_d *frh
+! * 3) Convert particles flux to mass flux :
+! *    dFM/dr_d = 4/3*pi*rho_d*r_d^3 *(dr/dr_d) * dFn/dr
+! *             = 4/3*pi*rho_d*r_d^3 * frh * dFn/dr
+! *               where rho_p is particle density [kg/m3]
+! *    The factor 1.e-18 is to convert in micro-meter r_d^3
+! ****************************************************************************
+ 
+
+  USE module_data_gocart_seas
+
+  IMPLICIT NONE
+
+  INTEGER, INTENT(IN)    :: nmx,imx,jmx,lmx,ipr
+  INTEGER, INTENT(IN)    :: ilwi(imx,jmx)
+  REAL*8,    INTENT(IN)    :: dxy(jmx), w10m(imx,jmx)
+  REAL*8,    INTENT(IN)    :: airmas(imx,jmx,lmx)
+  REAL*8,    INTENT(INOUT) :: tc(imx,jmx,lmx,nmx)
+  REAL*8,    INTENT(OUT)   :: bems(imx,jmx,nmx)
+
+  REAL*8 :: c0(5), b0(2)
+!  REAL*8, PARAMETER :: c_old(5)=(/1.373, 3.41, 0.057, 1.05, 1.190/) 
+!  REAL*8, PARAMETER :: c_new(5)=(/1.373, 3.41, 0.057, 3.45, 1.607/)
+  ! Change suggested by MC
+  REAL*8, PARAMETER :: c_old(5)=(/1.373, 3.2, 0.057, 1.05, 1.190/) 
+  REAL*8, PARAMETER :: c_new(5)=(/1.373, 3.2, 0.057, 3.45, 1.607/)
+  REAL*8, PARAMETER :: b_old(2)=(/0.380, 0.650/)
+  REAL*8, PARAMETER :: b_new(2)=(/0.433, 0.433/)
+  REAL*8, PARAMETER :: dr=5.0D-2 ! um   
+  REAL*8, PARAMETER :: theta=30.0
+  ! Swelling coefficient frh (d rwet / d rd)
+!!!  REAL*8,    PARAMETER :: frh = 1.65
+  REAL*8,    PARAMETER :: frh = 2.d0
+  LOGICAL, PARAMETER :: old=.TRUE., new=.FALSE.
+  REAL*8 :: rho_d, r0, r1, r, r_w, a, b, dfn, r_d, dfm, src
+  INTEGER :: i, j, n, nr, ir
+  REAL :: dt1
+
+
+  REAL*8                  :: tcmw(nmx), ar(nmx), tcvv(nmx)
+  REAL*8                  :: ar_wetdep(nmx), kc(nmx)
+  CHARACTER(LEN=20)     :: tcname(nmx), tcunits(nmx)
+  LOGICAL               :: aerosol(nmx)
+
+
+  REAL*8 :: tc1(imx,jmx,lmx,nmx)
+  REAL*8, TARGET :: tcms(imx,jmx,lmx,nmx) ! tracer mass (kg; kgS for sulfur case)
+  REAL*8, TARGET :: tcgm(imx,jmx,lmx,nmx) ! g/m3
+
+  !-----------------------------------------------------------------------  
+  ! sea salt specific
+  !-----------------------------------------------------------------------  
+! REAL*8, DIMENSION(nmx) :: ra, rb
+! REAL*8 :: ch_ss(nmx,12)
+
+  !-----------------------------------------------------------------------  
+  ! emissions (input)
+  !-----------------------------------------------------------------------  
+  REAL*8 :: e_an(imx,jmx,2,nmx), e_bb(imx,jmx,nmx), &
+          e_ac(imx,jmx,lmx,nmx)
+
+  !-----------------------------------------------------------------------  
+  ! diagnostics (budget)
+  !-----------------------------------------------------------------------
+!  ! tendencies per time step and process
+!  REAL*8, TARGET :: bems(imx,jmx,nmx), bdry(imx,jmx,nmx), bstl(imx,jmx,nmx)
+!  REAL*8, TARGET :: bwet(imx,jmx,nmx), bcnv(imx,jmx,nmx)!
+
+!  ! integrated tendencies per process
+!  REAL*8, TARGET :: tems(imx,jmx,nmx), tstl(imx,jmx,nmx)
+!  REAL*8, TARGET :: tdry(imx,jmx,nmx), twet(imx,jmx,nmx), tcnv(imx,jmx,nmx)
+
+  ! global mass balance per time step 
+  REAL*8 :: tmas0(nmx), tmas1(nmx)
+  REAL*8 :: dtems(nmx), dttrp(nmx), dtdif(nmx), dtcnv(nmx)
+  REAL*8 :: dtwet(nmx), dtdry(nmx), dtstl(nmx)
+  REAL*8 :: dtems2(nmx), dttrp2(nmx), dtdif2(nmx), dtcnv2(nmx)
+  REAL*8 :: dtwet2(nmx), dtdry2(nmx), dtstl2(nmx)
+
+  ! detailed integrated budgets for individual emissions
+  REAL*8, TARGET :: ems_an(imx,jmx,nmx),    ems_bb(imx,jmx,nmx), ems_tp(imx,jmx)
+  REAL*8, TARGET :: ems_ac(imx,jmx,lmx,nmx)
+  REAL*8, TARGET :: ems_co(imx,jmx,nmx)
+
+
+  ! executable statements
+
+  DO n = 1,nmx
+!    if(ipr.eq.1)write(0,*)'in seasalt',n,ipr,ilwi
+     bems(:,:,n) = 0.0
+     rho_d = den_seas(n)
+     r0 = ra(n)*frh
+     r1 = rb(n)*frh
+     r = r0
+     nr = INT((r1-r0)/dr+.001)
+!    if(ipr.eq.1.and.n.eq.1)write(0,*)'in seasalt',nr,r1,r0,dr,rho_d
+     DO ir = 1,nr
+        r_w = r + dr*0.5
+        r = r + dr
+        IF (new) THEN
+           a = 4.7*(1.0 + theta*r_w)**(-0.017*r_w**(-1.44))
+           c0 = c_new
+           b0 = b_new
+        ELSE
+           a = 3.0
+           c0 = c_old
+           b0 = b_old
+        END IF
+        !
+        b = (b0(1) - LOG10(r_w))/b0(2)
+        dfn = (c0(1)/r_w**a)*(1.0 + c0(3)*r_w**c0(4))* &
+             10**(c0(5)*EXP(-(b**2)))
+        
+        r_d = r_w/frh*1.0D-6  ! um -> m
+        dfm = 4.0/3.0*pi*r_d**3*rho_d*frh*dfn*dr*dt1
+        DO i = 1,imx
+           DO j = 1,jmx
+!              IF (water(i,j) > 0.0) THEN
+              IF (ilwi(i,j) == 0) THEN
+!                 src = dfm*dxy(j)*water(i,j)*w10m(i,j)**c0(2)
+                 src = dfm*dxy(j)*w10m(i,j)**c0(2)
+!                 src = ch_ss(n,dt(1)%mn)*dfm*dxy(j)*w10m(i,j)**c0(2)
+                 tc(i,j,1,n) = tc(i,j,1,n) + src/airmas(i,j,1)
+!                if(ipr.eq.1)write(0,*)n,dfm,c0(2),dxy(j),w10m(i,j),src,airmas(i,j,1)
+              ELSE
+                 src = 0.0
+              END IF
+              bems(i,j,n) = bems(i,j,n) + src
+           END DO  ! i
+        END DO ! j
+     END DO ! ir
+  END DO ! n
+
+END SUBROUTINE source_ss
+END MODULE GOCART_SEASALT
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_lmdz_phys.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_lmdz_phys.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_lmdz_phys.F	(revision 17)
@@ -0,0 +1,1708 @@
+MODULE module_lmdz_phys
+!
+! Module to include LMDZ (http://lmdz.lmd.jussieu.fr/) physical packages in WRF
+!
+! L. Fita, Laboratoire Meterologie Dynamique, IPSL, UPMC, CNRS, Jussieu, Paris, France
+!   July 2013
+!
+  CONTAINS
+
+  SUBROUTINE call_lmdz_phys(wrf_grid, wrf_xtime, wrf_restart_alarm,                  &
+     &        wrf_Lon, wrf_Lat,                                                      &
+     &        wrf_T, wrf_U, wrf_V,                                                   &
+     &        wrf_perP, wrf_baseP,                                                   &
+     &        wbdyw, wrf_isrestart,                                                  &
+     &        wrf_islowbdyin                                                         &
+                  ! dimension arguments
+     &             ,wids,wide, wjds,wjde, wkds,wkde                                  &
+     &             ,wims,wime, wjms,wjme, wkms,wkme                                  &
+     &             ,wips,wipe, wjps,wjpe, wkps,wkpe                                  &
+     &             ,wi_start,wi_end                                                  &
+     &             ,wj_start,wj_end                                                  &
+     &             ,wkts, wkte                                                       &
+     &             ,wnum_tiles                                                       &
+     &             ,wnum3dm, wparfirstscal,                                          &
+     &        wnx, wny, wnz,                                                         &
+     &        wjulday, wgmt, wtime_step,                                             &
+     &        wrf_fulleta, wrf_halfeta, wrf_dfulleta,                                &
+     &        wrf_fullpres, wrf_pergeopot, wrf_basegeopot,                           &
+     &        wrf_MOIST, wrf_w, wrf_ptop,                                            &
+     &        wrf_permass, wrf_basemass,                                             &
+     &        wrf_mut, wrf_muu, wrf_muv,                                             &
+     &        wrf_Utend, wrf_Vtend, wrf_Ttend,                                       &
+     &        wrf_MOISTtend, wrf_psfctend,                                           &
+     &        wrf_qvid, wrf_qcid, wrf_qrid,                                          &
+     &        wrf_qsid, wrf_qiid, wrf_qhid, wrf_qgid,                                &
+     &        wrf_mapft, wrf_mapfu, wrf_mapfv, wrf_dx, wrf_dy,                       &
+     &        wrf_dbg, landcat, soilcat,                                             &
+     &        wrf_l_pbl, wrf_l_con, wrf_l_thermals, wrf_l_wake,                      & 
+     &        wrf_nsoillayers,                                                       &
+     &        icheck_p, jcheck_p, kcheck_p                                           &
+     &                                                 )
+
+! WRF modules
+    USE module_model_constants
+    USE module_domain_type
+
+! LMDZ modules
+    USE infotrac, ONLY: infotrac_init, type_trac
+    USE comgeomphy
+    USE control_mod
+    USE indice_sol_mod
+    USE phys_state_var_mod
+!    USE fonte_neige_mod, ONLY: fonte_neige_init, fonte_neige_final
+    USE fonte_neige_mod
+    USE iostart, ONLY: get_var
+    USE surface_data
+    USE pbl_surface_mod
+    USE mod_grid_phy_lmdz, only : klon_glo
+
+! WRF+LMDZ 
+
+! Used to initialize variables in an old fashion way... Now using 'lmdz_wrf_variables_mod'
+    USE wrf_lmdz_mod
+    USE lmdz_wrf_variables_mod
+    USE NOread_limit_sub_variables
+    USE output_lmdz_NOmodule
+
+    IMPLICIT NONE
+
+    INCLUDE "../lmdz/dimensions.h"
+    INCLUDE "../lmdz/comvert.h"
+    INCLUDE "../lmdz/temps.h"
+    INCLUDE "../lmdz/dimsoil.h"
+
+    TYPE(domain) , TARGET                                :: wrf_grid
+
+    REAL, INTENT(IN)                                     :: wrf_xtime, wrf_Ptop,     &
+        wgmt, wrf_dx, wrf_dy
+    LOGICAL, INTENT(IN)                                  :: wrf_restart_alarm,       &
+        wrf_isrestart, wrf_islowbdyin
+
+    INTEGER, INTENT(IN)                                  :: wnx, wny, wnz, wbdyw
+
+    INTEGER, INTENT(IN)                                  ::                          &
+        &                               wids,wide, wjds,wjde, wkds,wkde,             &
+                                        wims,wime, wjms,wjme, wkms,wkme,             &
+                                        wips,wipe, wjps,wjpe, wkps,wkpe,             &
+                                        wkts,wkte, wnum_tiles
+
+    INTEGER, DIMENSION(wnum_tiles), INTENT(IN)           ::                          &
+         & wi_start,wi_end,wj_start,wj_end
+    INTEGER, INTENT(IN)                                  :: wparfirstscal, wnum3dm
+    REAL, INTENT(IN)                                     :: wjulday
+    REAL, INTENT(IN)                                     :: wtime_step
+    INTEGER, INTENT(IN)                                  :: wrf_qvid, wrf_qcid,      &
+         & wrf_qrid, wrf_qsid, wrf_qiid, wrf_qhid, wrf_qgid, wrf_dbg
+
+    REAL, INTENT(IN), DIMENSION(wkms:wkme)               :: wrf_fulleta
+    REAL, INTENT(IN), DIMENSION(wkms:wkme)               :: wrf_halfeta, wrf_dfulleta
+
+    REAL, INTENT(IN), DIMENSION(wims:wime,wkms:wkme,wjms:wjme) ::                    &
+        & wrf_T, wrf_perP, wrf_baseP, wrf_U, wrf_V
+
+    REAL, INTENT(OUT), DIMENSION(wims:wime,wkms:wkme,wjms:wjme) ::                   &
+        & wrf_Ttend, wrf_Utend, wrf_Vtend
+
+    REAL, INTENT(IN), DIMENSION(wims:wime,wkms:wkme,wjms:wjme) ::                    &
+        & wrf_fullpres, wrf_pergeopot, wrf_basegeopot, wrf_w
+
+    REAL, INTENT(IN), DIMENSION(wims:wime,wjms:wjme)     :: wrf_Lon, wrf_Lat,        &
+        & wrf_basemass, wrf_permass, wrf_mapft, wrf_mapfu, wrf_mapfv, wrf_mut,       &
+        & wrf_muu, wrf_muv
+
+    REAL, INTENT(OUT), DIMENSION(wims:wime,wjms:wjme)    :: wrf_psfctend
+
+    REAL, INTENT(IN), DIMENSION(wims:wime,wkms:wkme,wjms:wjme,1:wnum3dm) ::          &
+        & wrf_MOIST
+
+    REAL, INTENT(OUT), DIMENSION(wims:wime,wkms:wkme,wjms:wjme,1:wnum3dm) ::         &
+        & wrf_MOISTtend
+
+    CHARACTER(LEN=256), INTENT(IN)                       :: landcat, soilcat
+    INTEGER, INTENT(IN)                                  :: wrf_l_pbl, wrf_l_con,    &
+      wrf_l_thermals, wrf_l_wake
+    INTEGER, INTENT(IN)                                  :: wrf_nsoillayers
+    INTEGER, INTENT(IN)                                  :: icheck_p, jcheck_p,      &
+      kcheck_p
+! Local
+    INTEGER                                              :: ip, jp, kp, lp
+
+    REAL, DIMENSION(wims:wime,wkms:wkme,wjms:wjme)       :: wrf_Temp,                &
+       & wrf_Temptend, wrf_P, wrfMASSValues
+    REAL, DIMENSION(wims:wime,wkms:wkme,wjms:wjme)       :: wrfUdestagg, wrfVdestagg,&
+       & wrfUtenddestagg, wrfVtenddestagg
+    REAL, DIMENSION((wime-wims-2*wbdyw)*(wjme-wjms-2*wbdyw), wkms:wkme-1) ::         &
+       & TValues, TtendValues, HalfPressValues, WFluxMassValues
+    REAL, DIMENSION((wime-wims-2*wbdyw)*(wjme-wjms-2*wbdyw), wkms:wkme-1) ::         &  !! DE-STAGGED !!
+       & UValues, UtendValues
+    REAL, DIMENSION((wime-wims-2*wbdyw)*(wjme-wjms-2*wbdyw), wkms:wkme-1) ::         &  !! DE-STAGGED !!
+       & VValues, VtendValues
+    REAL, DIMENSION((wime-wims-2*wbdyw)*(wjme-wjms-2*wbdyw), wkms:wkme) ::           &  !! Z-STAGG !!
+       & FullPressValues, GeopotValues
+    REAL, DIMENSION((wime-wims-2*wbdyw)*(wjme-wjms-2*wbdyw)) ::                      &  
+       & sfcGeopotValues
+    REAL, ALLOCATABLE, DIMENSION(:,:,:)                  :: MixingRatioValues,       &
+       & MixingRatiotendValues
+
+    REAL, DIMENSION(wims:wime,wkms:wkme,wjms:wjme)       :: wrfWValues,              &
+       & wrfPERMASSValues, wrfZFluxMassValues
+    REAL, DIMENSION(wims:wime,wkms:wkme,wjms:wjme)       :: wrf_geopot, w3Dmat
+    REAL, DIMENSION(wims:wime,wjms:wjme)                 :: wrf_sfcgeopot
+
+    LOGICAL                                              :: lmdz_debut, lmdz_lafin
+
+    INTEGER                                              :: k, ix, iy, iz, iq, ixy,  &
+       & lmdzp, ilmdz, jlmdz, ir, ixx, iyy
+    INTEGER                                              :: dimx, dimy, dimz, dimxy
+    INTEGER                                              :: ddimx, ddimy, ddimxy, ddimxy2
+    INTEGER                                              :: dim_klon_glo, dim_ngridmx
+    INTEGER                                              :: im2, jm2, km2
+    INTEGER                                              :: lmdzmixingratios
+    CHARACTER (LEN=1024)                                 :: message, wrf_err_message
+
+    INTEGER, PARAMETER                                   :: Nphykeys=20
+    REAL, DIMENSION(Nphykeys)                            :: phykeys
+
+    REAL, DIMENSION(2,(wime-wims-2*wbdyw)*(wjme-wjms-2*wbdyw),wkms:wkme-1) ::        &
+        & lmdz_dudyn, l3Dmat
+    REAL, DIMENSION((wime-wims-2*wbdyw)*(wjme-wjms-2*wbdyw),3) :: lmdz_PVtheta
+    REAL, DIMENSION(wkms:wkme-1)                         :: lmdzoutP
+    REAL, DIMENSION((wime-wims-2*wbdyw),(wjme-wjms-2*wbdyw)) :: wrf_area
+    REAL, DIMENSION((wime-wims-2*wbdyw),(wjme-wjms-2*wbdyw)) :: wrf_cu
+    REAL, DIMENSION((wime-wims-2*wbdyw),(wjme-wjms-2*wbdyw)) :: wrf_cv
+    REAL, DIMENSION((wime-wims-2*wbdyw)*(wjme-wjms-2*wbdyw)) :: AreaValues,          &
+        LonValues, LatValues, PsfctendValues
+    REAL, DIMENSION((wime-wims-2*wbdyw)*(wjme-wjms-2*wbdyw)) :: CUValues, CVValues
+    REAL, DIMENSION((wime-wims-2*wbdyw)*(wjme-wjms-2*wbdyw)) :: runoff_lic
+    LOGICAL                                              :: existsfile
+    INTEGER                                              :: ierr
+    CHARACTER(LEN=50)                                    :: errmsg, wrnmsg, subname
+    CHARACTER(LEN=100)                                   :: defilen, defvarn, defstr
+    INTEGER                                              :: funit, defint
+    LOGICAL                                              :: is_used, defbool
+    REAL, DIMENSION(20)                                  :: lmdz_clesphy0
+    INTEGER                                              :: iflag_phys
+    REAL                                                 :: defreal,ksoilmax
+    REAL, DIMENSION(4)                                   :: ksoils
+    REAL                                                 :: Pi
+    CHARACTER(LEN=50)                                    :: LMDZvarmethod, Spt, Spt3D
+    CHARACTER(LEN=4)                                     :: ipS, jpS, kpS
+    CHARACTER(LEN=8)                                     :: lpS
+    INTEGER                                              :: nlanduse
+    REAL, DIMENSION(11)                                  :: ORCHIDEElevels
+    INTEGER                                              :: Nsoillayers,begdataset,  &
+      Nvars,Nrs,Ncs,Nwrfsoiltypes
+    REAL                                                 :: soilTmass
+    CHARACTER(LEN=50)                                    :: datasetname
+    CHARACTER(LEN=100)                                   :: tablename
+    REAL, ALLOCATABLE, DIMENSION(:,:,:)                  :: soilvals
+    CHARACTER(LEN=50), ALLOCATABLE, DIMENSION(:)         :: soilvalns
+    INTEGER                                              :: lpbl, lcon, lth, lwake 
+    TYPE(WRFU_Alarm), TARGET, DIMENSION(MAX_WRF_ALARMS)  :: wrf_alarms
+   
+!!!!!!! Variables
+! 
+! wrf_xtime: WRF actual timestep (in minutes since simulation started)
+! wrf_restart_alarm: WRF value indicating whether this is a restart time-step
+! wrf_T: WRF 3D temperature
+! wrf_perP: WRF 3D perturbation of the pressure
+! wrf_baseP: WRF 3D base pressure
+! wn[x/y/z]: WRF dimensions at each axis
+! wbdyw: number of grid points in the sponge zone
+! wids: start for i in domain
+! wide: end for i in domain
+! wjds: start for j in domain
+! wjde: end for j in domain
+! wkds: start for k in domain
+! wkde: end for k in domain
+! wims: start for i in memory
+! wime: end for i in memory
+! wjms: start for j in memory
+! wjme: end for j in memory
+! wips: start for i in patch
+! wipe: end for i in patch
+! wjps: start for j in patch
+! wjpe: end for j in patch
+! wkms: start for k in memory
+! wkme: end for k in memory
+! wi_start: start indices for i in tile
+! wi_end: end indices for i in tile
+! wj_start: start indices for j in tile
+! wj_end: end indices for j in tile
+! wkts: start for k in tile
+! wkte: end for k in tile
+! wnum_tiles: number of tiles
+! wjulday: WRF julian day
+! wgmt: WRF gmt hour (0, 1)
+! wtime_step: WRF time-step (in seconds)
+! wrf_dbg: level of debug from WRF
+! wrf_isrestart: flag indicating whether simulation is beggining from a restart or 
+!   not (zero time since simulation started )
+!
+! lmdz_debut: flag indicating if this is the first step for LMDZ
+! lmdz_lafin: flag indicating if this is the last step for LMDZ
+! wrf_fulleta: WRF full mass eta levels (w)
+! wrf_dfulleta: WRF full mass high between eta levels (w)
+! wrf_halfeta: WRF half mass eta levels (t, u, v, h)
+! wrf_Ptop: WRF top pressure
+! wrf_Lon: WRF longitudes
+! wrf_Lat: WRF latitudes
+! wrf_T: WRF potential temperature
+! wrf_Ttend: WRF potential temperature tendency
+! wrf_Temp: WRF temperature
+! wrf_Temptend: WRF temperature tendency
+! wrf_perP: WRF perturbation of pressure
+! wrf_baseP: WRF base of pressure
+! wrf_P: WRF pressure
+! wrf_U: WRF x-wind speed
+! wrf_Utend: WRF x-wind speed tendency
+! wrf_V: WRF y-wind speed
+! wrf_Vtend: WRF y-wind speed tendency
+! wrf_fullpres: WRF pressure in full eta levels
+! wrf_pergeopot: WRF perturbation of geopotential
+! wrf_basegeopot: WRF base of geopotential
+! wrf_geopot: WRF geopotential
+! wrf_psfctend: WRF surface pressure tendency
+! wrf_sfcgeopot: WRF surface geopotential
+! wrf_MOIST: WRF MOIST ARRAY (water spieces and tracers)
+! wrf_MOISTtend: WRF MOIST tendency ARRAY (water spieces and tracers)
+! wrf_qvid: WRF water vapor index of wrf_MOIST
+! wrf_qcid: WRF cloud liquid water index of wrf_MOIST
+! wrf_qrid: WRF rain liquid water index of wrf_MOIST
+! wnum3dm: WRF number of water species
+! wrf_w: WRF vertical velocity
+! wrf_permass: WRF perturbation dry air mass in column
+! wrf_basemass: WRF base dry air mass in column
+! wrf_mut: WRF total dry air mass column on mass points
+! wrf_muu: WRF total dry air mass column on u-wind grid points
+! wrf_muv: WRF total dry air mass column on v-wind gid points
+! wrfWValues: staggered WRF vertical velocity (in m s-1)
+! wrfPERMASSValues: de-staggered WRF perturbation of dry mass column (in Pa)
+! wrfMASSValues: de-staggered WRF perturbation of dry mass column (in kg)
+! wrfZFluxMassValues: WRF vertical flux mass values (kg s-1)
+! wrf_mapf[t/u/v]: WRF map factor for Temperature, u-wind and v-wind grid points
+! wrf_d[x/y]: length of the grid spacing in the x and y direction (in m)
+! wrf_area: WRF area of the grid cells
+! wrf_c[u/v]: WRF covariant values for wind components
+! landcat: land category used in the simulation
+! nlanduse: number of soil types in the WRF landuse variable
+!
+! LonValues: 2D-LMDZ array of WRF longitudes (in rad)
+! LatValues: 2D-LMDZ array of WRF latitudes (in rad)
+! TValues: 2D-LMDZ array of WRF temperatures (in K)
+! TtendValues: 2D-LMDZ tendency array of WRF temperatures (in K)
+! HalfPressValues: 2D-LMDZ array of WRF pressure at half-mass levels (in Pa)
+! UValues: 2D-LMDZ array of WRF x-wind speed (in m s-1)
+! UtendValues: 2D-LMDZ array of WRF tendency x-wind speed (in m s-2)
+! VValues: 2D-LMDZ array of WRF y-wind speed (in m s-1)
+! VtendValues: 2D-LMDZ array of WRF tendency y-wind speed (in m s-2)
+! PsfctendValues: 2D-LMDZ array of surface pressure tendency y-wind speed (in Pa s-1)
+! FullPressValues: 2D-LMDZ array of WRF pressure at full-mass levels (in Pa)
+! GeopotValues: 2D-LMDZ array of WRF geopotential (in m2 s-2)
+! sfcGeopotValues: LMDZ array of WRF sfc geopotential (in m2 s-2)
+! lmdzmixingratios: number of 'mixing ratios' to pass to the LMDZ physics
+! MixingRatioValues: 2D-LMDZ array of Mixing Ratios (in kg kg-1)
+! MixingRatiotendValues: 2D-LMDZ array of tendency Mixing Ratios (in kg kg-1 s-1)
+! WFluxMassValues: 2Dvertical mass flux values (in kg m s-1)
+! phykeys: LMDZ obsolete control I/O vector
+! lmdz_dudyn: LMDZ obsolete vector
+! lmdz_PVtheta: LMDZ obsolete PV values at given theta levels
+! lmdzoutP: LMDZ output pressure values (using same eta levels, but imposing Psfc=1000 hPa)
+! preff: refernce pressure for lmdzouP
+! AreaValues: LMDZ area (m2)
+! CUArea: LMDZ cu coeff. (u_covariant = cu * u)
+! CVArea: LMDZ cv coeff. (v_covariant = cv * v)
+! 
+!!!!!!! Subroutines/Functions
+! WRFmoist_LMDZmoist: Subroutine to transform from WRF moisture array to the LMDZ moisture array
+! eta_to_pressure: Subroutine to transform from eta levels to pressure levels
+! vect_mat: Subroutine to transform a LMDZ physic 1D vector to a 3D matrix
+! mat_vect: Subroutine to transform a 3D matrix to a LMDZ physic 1D vector
+! temp_to_theta: Subroutine to transform from temperatures to WRF potential temperatures
+! theta_to_temp: Subroutine to transform from WRF potential temperatures to temperature
+! physiq: Subroutine with the LMDZ physics
+
+! CAPITAL variables stand for the name of the variables inside the subroutines/functions
+
+!!!!!!! !!!!!! !!!!! !!!! !!! !! !
+    WRITE(message, *)'  starting: module_lmdz_phys.F'
+    CALL wrf_debug(75, message)
+
+    PRINT *,' --------------------------------------------------------------------------------------------------'
+
+! Basic definitions
+!!
+    errmsg='ERROR -- error -- ERROR -- error'
+    wrnmsg='WARNING -- warning -- WARNING -- warning'
+    subname='module_lmdz_phys'
+
+    Pi = 2.*ASIN(1.)
+
+    type_trac = 'lmdz'
+
+    dimx=wime-wims
+    dimy=wjme-wjms
+    dimz=wkme-wkms
+    dimxy=dimx*dimy
+    dim_klon_glo = dimx*dimy
+    dim_ngridmx = dimx*dimy
+    ddimx = dimx-2*wbdyw
+    ddimy = dimy-2*wbdyw
+    ddimxy=ddimx*ddimy
+    ddimxy2=ddimx*(ddimy/2-1)+ddimx/2
+
+! Point to retrieve values for debugging
+!    ip=ddimx/2
+!    jp=ddimy/2
+!    kp=dimz/2
+!    ip=5
+!    jp=11
+    ip=icheck_p
+    jp=jcheck_p
+    kp=kcheck_p
+
+    lp=ddimx*(jp-1)+ip
+    WRITE(ipS,'(I4)')ip
+    WRITE(jpS,'(I4)')jp
+    WRITE(kpS,'(I4)')kp
+    WRITE(lpS,'(I8)')lp
+    Spt = TRIM(ipS) // ', '//TRIM(jpS)
+    Spt3D = TRIM(ipS) // ', '//TRIM(jpS)//', '//TRIM(kpS)
+    PRINT *,'  checking point ip: ',ip,' jp: ',jp,' kp: ',kp,' lp: ',lp
+
+    PRINT *,'  Lluis in module_lmdz_phy itime_step= ', wrf_grid%itimestep,           &
+      ' wrf_xtime: ',wrf_xtime,' wrf_rst: ', wrf_isrestart,' wrf_lwbdy: ',           &
+      wrf_islowbdyin
+
+    phykeys=0.
+    lmdz_dudyn=0.
+    lmdz_PVtheta=0.
+
+! Checking of first/last time-step for LMDZ
+!!
+    lmdz_debut = .FALSE.
+    lmdz_lafin = .FALSE.
+
+    DO iy=1,ddimy
+      DO ix=1,ddimx
+        IF (wrf_Lon(ix,iy) < 0.) THEN
+          LonValues(ddimx*(iy-1)+ix) = (360. + wrf_Lon(ix,iy))*Pi/180.
+        ELSE
+          LonValues(ddimx*(iy-1)+ix) = wrf_Lon(ix,iy)*Pi/180.
+        END IF
+        LatValues(ddimx*(iy-1)+ix) = wrf_Lat(ix,iy)*Pi/180.
+        PsfctendValues(ddimx*(iy-1)+ix) = wrf_psfctend(ix,iy)
+      END DO
+    END DO
+
+! Reshape can not be used? Different initial/ending indices !
+!      LonValues = RESHAPE(wrf_Lon, (/ dimx*dimy/), ORDER=(/1/))
+!      LatValues = RESHAPE(wrf_Lat, (/ dimx*dimy/), ORDER=(/1/))
+
+    firststep: IF ( wrf_xtime == 0 .OR. wrf_isrestart) THEN
+      lmdz_debut = .TRUE.
+
+      DO funit=10,100
+        INQUIRE(UNIT=funit, OPENED=is_used)
+        IF (.NOT. is_used) EXIT
+      END DO
+      lmdz_clesphy0 = 0.
+
+      CALL conf_gcm(funit, .TRUE., lmdz_clesphy0)
+! L. Fita, wee need to provide the value
+      annee_ref = anneeref
+      day_ref = dayref
+
+! Uploading LMDZ general configuration
+! used instead call conf_gcm, since variables are not found in memory (or at least with a value)
+      defilen = 'gcm.def'
+      defvarn = 'iflag_phys'
+      CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+      iflag_phys = defint
+
+! Is not working it has an space...
+!      defvarn = 'type_trac'
+!      CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+!      type_trac = TRIM(defstr)
+
+! used instead call conf_gcm, since variables are not found in memory (or at least with a value)
+      defilen = 'config.def'
+      defvarn = 'type_ocean'
+      CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+      type_ocean= TRIM(defstr)
+
+! used instead call conf_gcm, since variables are not found in memory (or at least with a value)
+! Looking for consistency for some namelist variables and *.def LMDZ values
+      PRINT *,'  Checking consistency between namelist and LMDZ *.def values'
+      defilen = 'physiq.def'
+      defvarn = 'iflag_pbl'
+      CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+      lpbl = defint
+      defvarn = 'iflag_con'
+      CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+      lcon = defint
+      defvarn = 'iflag_thermals'
+      CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+      lth = defint
+      defvarn = 'iflag_wake'
+      CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+      lwake = defint
+
+      IF (wrf_l_pbl /= lpbl) THEN
+        PRINT *,TRIM(errmsg)
+        PRINT *,'  ' // TRIM(subname) // ' namelist LMDZ pbl value: ',               &
+          wrf_l_pbl,' differs from iflag_pbl= ',lpbl ,' in physiq.def !!!!'
+        WRITE(wrf_err_message,*)'  wrong namelist.input value !!'
+        CALL wrf_error_fatal(TRIM(wrf_err_message))
+      END IF
+      IF (wrf_l_con /= lcon) THEN
+        PRINT *,TRIM(errmsg)
+        PRINT *,'  ' // TRIM(subname) // ' namelist LMDZ convection value: ',        &
+          wrf_l_con,' differs from iflag_con= ',lcon ,' in physiq.def !!!!'
+        WRITE(wrf_err_message,*)'  wrong namelist.input value !!'
+        CALL wrf_error_fatal(TRIM(wrf_err_message))
+      END IF
+      IF (wrf_l_thermals /= lth) THEN
+        PRINT *,TRIM(errmsg)
+        PRINT *,'  ' // TRIM(subname) // ' namelist LMDZ thermals value: ',          &
+          wrf_l_thermals,' differs from iflag_thermals= ',lth ,' in physiq.def !!!!'
+        WRITE(wrf_err_message,*)'  wrong namelist.input value !!'
+        CALL wrf_error_fatal(TRIM(wrf_err_message))
+      END IF
+      IF (wrf_l_wake /= lwake) THEN
+        PRINT *,TRIM(errmsg)
+        PRINT *,'  ' // TRIM(subname) // ' namelist LMDZ wakes value: ',             &
+          wrf_l_wake,' differs from iflag_wake= ',lwake ,' in physiq.def !!!!'
+        WRITE(wrf_err_message,*)'  wrong namelist.input value !!'
+        CALL wrf_error_fatal(TRIM(wrf_err_message))
+      END IF
+
+! Initialization of the variables
+!!
+
+      INQUIRE(FILE='traceur.def', EXIST=existsfile)
+
+! L. Fita, LMD. August, this would be much more nice if it is in config_flags structure....
+      IF (existsfile) THEN
+        DO funit=10,100
+          INQUIRE(UNIT=funit, OPENED=is_used)
+          IF (.NOT. is_used) EXIT
+        END DO
+        OPEN(UNIT=funit, FILE='traceur.def', STATUS='OLD')
+        READ(funit,*)lmdzmixingratios
+        CLOSE(UNIT=funit)
+      ELSE
+        WRITE(message, *)errmsg
+        CALL wrf_debug(75, message)
+        WRITE(wrf_err_message,*)'  required file traceur.def not found !!'
+        CALL wrf_error_fatal(TRIM(wrf_err_message))
+      END IF
+
+      CALL infotrac_init
+
+! Initializing LMDZ matrices...
+
+      CALL Init_Phys_lmdz(1,ddimxy,dimz,1,(/ddimxy/))
+      CALL InitComgeomphy()
+
+      CALL phys_state_var_init(0)
+!!        CALL neige_initialize()
+!!        CALL limit_initialize()
+
+!!        CALL pbl_initialize()
+
+      PRINT *,'Lluis after initializing all LMDZ!'
+
+      rlon=LonValues
+      rlat=LatValues
+
+      xtime0: IF (wrf_xtime == 0.) THEN
+
+        nlanduse=UBOUND(wrf_grid%landusef, 2)
+        CALL WRFlanduse_LMDZKsoil(landcat,wims,wime,wjms,wjme,ddimx,ddimy,nlanduse,  &
+          wrf_grid%landusef,wrf_grid%landmask,wrf_grid%lter,wrf_grid%llic,           &
+          wrf_grid%loce,wrf_grid%lsic)
+
+! LANDMASK in LMDZ as fractions
+        wrf_grid%lmsk = wrf_grid%lter + wrf_grid%llic
+! Pseudo WRF-initialization
+
+! LANDMASK in LMDZ as 1/0
+!        wrf_grid%lmsk=0.
+!        DO ix=1,ddimx
+!          DO iy=1,ddimy
+!            IF (wrf_grid%lter(ix,iy) >= 0.5) THEN
+!              wrf_grid%lmsk(ix,iy)=1.
+!              wrf_grid%lter(ix,iy)=1.
+!              wrf_grid%llic(ix,iy)=0.
+!              wrf_grid%loce(ix,iy)=0.
+!              wrf_grid%lsic(ix,iy)=0.
+!            ELSE
+!              wrf_grid%lmsk(ix,iy)=0.
+!              wrf_grid%lter(ix,iy)=0.
+!              wrf_grid%llic(ix,iy)=0.
+!              wrf_grid%loce(ix,iy)=1.
+!              wrf_grid%lsic(ix,iy)=0.
+!            END IF
+!          END DO
+!        END DO
+! End of Pseudo WRF-initialization
+!!!!! 
+
+! Value is given at the first time-step, not any more, since it will be continuously 
+!   used by LMDZ
+! l. Fita, LMD. January 2014
+! This should be in this way, but, because we can not use any scheme DZS=0., so 
+!    direct met_em values (Registry modified) are used. soil layers are in [cm]!
+!        DO iz=1,SIZE(wrf_grid%soil_layers(ip,:,jp))
+!          wrf_grid%lwsol = wrf_grid%lwsol + wrf_grid%sm(:,iz,:)*                     &
+!            wrf_grid%soil_layers(:,iz,:)/100.
+!        END DO
+        DO iz=1,4
+          wrf_grid%ltksoil(:,iz,:)=wrf_grid%st(:,1,:)
+        END DO
+!
+! Only using SST on that ocean grid points
+        DO ix=1,ddimx
+          DO iy=1,ddimy
+            IF (wrf_grid%loce(ix,iy) > 0.) THEN
+! Full SST grid points must have a SST value from the wrfinput (WRF 1/0 landmask)
+!   but that LMDZ points with fractions of land/mask could not. Using the closest one
+!   if it is an isolated grid point, using TSK instead
+              IF (wrf_grid%sst(ix,iy) < 200.15) THEN
+                wrf_grid%ltksoil(ix,3,iy) = -9.
+                IF ( (ix > 1).AND.(ix < ddimx) .AND. (iy > 1).AND.(iy < ddimy) ) THEN
+                  DO ixx=-1,1
+                    DO iyy=-1,1
+!                      PRINT *,ixx,iyy,wrf_grid%sst(ix+ixx,iy+iyy)
+                      IF (wrf_grid%sst(ix+ixx,iy+iyy) > 200.15) THEN
+                        wrf_grid%ltksoil(ix,3,iy) = wrf_grid%sst(ix+ixx,iy+iyy)
+                        EXIT
+                      END IF
+                    END DO
+                    IF ( wrf_grid%ltksoil(ix,3,iy) > 200.15) EXIT
+                  END DO
+                  IF ( wrf_grid%ltksoil(ix,3,iy) == -9.) wrf_grid%ltksoil(ix,3,iy) = &
+                    wrf_grid%tsk(ix,iy)
+                ELSE
+                  wrf_grid%ltksoil(ix,3,iy) = wrf_grid%tsk(ix,iy)
+                END IF
+              ELSE
+                wrf_grid%ltksoil(ix,3,iy) = wrf_grid%sst(ix,iy)
+              END IF
+              IF ( (wrf_grid%ltksoil(ix,3,iy) < 200.15) .OR.                         &
+                (wrf_grid%ltksoil(ix,3,iy) > 370.) ) THEN
+                PRINT *,TRIM(errmsg)
+                WRITE(wrf_err_message,*) '  ' // TRIM(subname) //                    &
+                  ' SST inconsistency at point: ', ix, ', ', iy,' with loce: ',      &
+                  wrf_grid%loce(ix,iy),' has a tsoil(oce)= ',                        &
+                  wrf_grid%ltksoil(ix,3,iy),' sst: ',wrf_grid%sst(ix,iy),' tsk: ',   &
+                  wrf_grid%tsk(ix,iy)
+                CALL wrf_error_fatal(TRIM(wrf_err_message))
+              END IF
+            END IF
+          END DO
+        END DO
+
+!! Soil temperature, humidity, water-content...
+! This should go on the namelist... later!
+        ORCHIDEElevels = (/ 0.098, 0.1955, 0.5865, 1.3685, 2.9326, 6.0606, 12.3167,  &
+          24.8289, 49.8534, 99.9022, 200. /)
+
+        datasetname = soilcat
+        tablename = 'SOILPARM.TBL'
+
+        PRINT *,'  Lluis reading dataset "' // TRIM(datasetname) // '" from "' //    &
+          TRIM(tablename) // '"'
+
+        CALL table_characteristics(datasetname,tablename,begdataset,Nvars,Nrs,Ncs)
+
+! L. Fita, LMD. Feburary 2014
+! Again (as in the landuses case), the files content more categeories that the really ones used by the model...
+        Nsoillayers=SIZE(wrf_grid%soil_layers(ip,:,jp))
+        Nwrfsoiltypes=SIZE(wrf_grid%soilctop(ip,:,jp))
+        IF (Nrs > Nwrfsoiltypes) THEN
+          PRINT *,TRIM(wrnmsg)
+          PRINT *,"  '" // TRIM(datasetname)//"' from '"//TRIM(tablename)//"' has ", &
+            Nrs,' soil layers, meanwhile WRF data has ',Nwrfsoiltypes
+          PRINT *,'  using only the first ',  Nwrfsoiltypes, ' of the dataset !!!!'
+          Nrs=Nsoillayers
+        ELSE IF (Nrs < Nwrfsoiltypes) THEN
+          PRINT *,TRIM(errmsg)
+          PRINT *,"  '" // TRIM(datasetname)//"' from '"//TRIM(tablename)//"' has ", &
+            Nrs,' soil layers, meanwhile WRF data has ',Nwrfsoiltypes
+          WRITE(wrf_err_message,*)'  wrong the dataset !!!!'
+          CALL wrf_error_fatal(TRIM(wrf_err_message))
+        END IF
+
+        IF (ALLOCATED(soilvals)) DEALLOCATE(soilvals)
+        ALLOCATE(soilvals(Nvars,Nrs,Ncs))
+
+        IF (ALLOCATED(soilvalns)) DEALLOCATE(soilvalns)
+        ALLOCATE(soilvalns(Nrs))
+
+        CALL read_table(datasetname, tablename, begdataset, Nvars, Nrs, Ncs,         &
+          soilvals, soilvalns)
+
+        DO ix=1,ddimx
+          DO iy=1,ddimy
+!L. Fita, LMD. January 2014 Soil layers are in cm!
+
+
+! NOTE: wrf_dx, wrf_dy should be matrix !!!
+            CALL compute_TOTsoil_mass_water_values(datasetname, Nvars, Nrs, Ncs,     &
+              soilvals, soilvalns, ix, iy, Nrs, wrf_grid%soilctop(ix,:,iy),          &
+              wrf_grid%soilcbot(ix,:,iy), Nsoillayers, wrf_grid%sm(ix,:,iy),         &
+              wrf_grid%soil_layers(ix,Nsoillayers:1:-1,iy)/100., wrf_dx, wrf_dy,     &
+              soilTmass, wrf_grid%lwsol(ix,iy))
+
+            wrf_grid%lwsol(ix,iy) =  wrf_grid%lwsol(ix,iy)/(wrf_dx*wrf_dy*1000.)
+
+            CALL interpolate_layers(SIZE(wrf_grid%soil_layers(ix,:,iy)),             &
+              wrf_grid%soil_layers(ix,SIZE(wrf_grid%soil_layers(ix,:,iy)):1:-1,iy),  &
+              wrf_grid%st(ix,:,iy),11, ORCHIDEElevels,wrf_grid%lotter(ix,:,iy))
+          END DO
+        END DO
+
+        wrf_grid%lotlic=wrf_grid%lotter
+        wrf_grid%lotoce=wrf_grid%lotter
+        wrf_grid%lotsic=wrf_grid%lotter
+
+        DEALLOCATE(soilvals)
+        DEALLOCATE(soilvalns)
+
+! LMDZ does not distinguish among species, use it as a whole
+        wrf_grid%lclwcon=SUM(wrf_MOIST,4)
+        DO ix=wims,wime
+          DO iz=wkms,wkme
+            DO iy=wjms,wjme
+              IF (wrf_grid%lclwcon(ix,iz,iy) /= 0.) THEN
+                wrf_grid%lratqs=(wrf_MOIST(ix,iz,iy,wrf_qrid)+                       &
+                wrf_MOIST(ix,iz,iy,wrf_qsid)+wrf_MOIST(ix,iz,iy,wrf_qiid)+           &
+                wrf_MOIST(ix,iz,iy,wrf_qhid)+wrf_MOIST(ix,iz,iy,wrf_qgid))/          &
+                wrf_grid%lclwcon(ix,iz,iy)
+              END IF
+            END DO
+          END DO
+        END DO 
+
+!        wrf_grid%znt = wrf_grid%z0
+!        wrf_grid%albedo = wrf_grid%albbck
+        wrf_grid%lbils=0.
+        wrf_grid%lfder=0.
+        wrf_grid%lrnebcon=0.
+        DO ix=1,ddimx
+          DO iy=1,ddimy
+            ksoils = (/ wrf_grid%lter(ix,iy), wrf_grid%llic(ix,iy),                  &
+              wrf_grid%loce(ix,iy), wrf_grid%lsic(ix,iy) /)
+            ksoilmax = MAXVAL(ksoils)
+            DO iz = 1,4
+              IF (ksoilmax == ksoils(iz)) wrf_grid%lnat(ix,iy) = iz
+            END DO
+          END DO
+        END DO
+        wrf_grid%lrads = wrf_grid%swdown
+
+        wrf_grid%lcontrol(1) = wtime_step
+        defilen = 'config.def'
+        defvarn = 'nbapp_rad'
+        CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+        wrf_grid%lcontrol(6) = defint
+        wrf_grid%lcontrol(2) = NINT (86400./wtime_step/ FLOAT(defint) )
+!L. Fita, LMD. February 2014: current value of atmospheric CO2 should be 
+!!   co2_ppm0 + delta_co2_ppm, from 'carbon_cycle_mod.F90'
+        defvarn = 'co2_ppm'
+        CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+        wrf_grid%lcontrol(3) = defint
+!!c co2_ppm0 : initial value of atmospheric CO2
+        wrf_grid%lcontrol(16) = defint
+        defvarn = 'solaire'
+        CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+        wrf_grid%lcontrol(4) = defreal
+        wrf_grid%lcontrol(5) = wrf_l_con
+
+! Default value cycle_diurne = .T.
+        wrf_grid%lcontrol(7) = 1.
+        defvarn = 'soil_model'
+        CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+        IF(defbool) wrf_grid%lcontrol(8) = 1.
+        defilen = 'physiq.def'
+        defvarn = 'new_oliq'
+        CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+        IF(defbool) wrf_grid%lcontrol(9) = 1.
+        defvarn = 'ok_orodr'
+        CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+        IF(defbool) wrf_grid%lcontrol(10) = 1.
+        defvarn = 'ok_orolf'
+        CALL def_get_scalar_value(defilen, defvarn, defstr, defint, defreal, defbool)
+        IF(defbool) wrf_grid%lcontrol(11) = 1.
+
+        wrf_grid%lcontrol(13) = dayref + nday
+        wrf_grid%lcontrol(14) = annee_ref
+        wrf_grid%lcontrol(15) = wrf_grid%itimestep
+
+! Let's split rugosity by Ksoils
+!! Static roughness length
+        wrf_grid%lrug=wrf_grid%znt
+
+!! Dynamic roughness length (It should work if we use WRF schemes...)
+!        wrf_grid%lrug=wrf_grid%znt
+! First split by Ksoil types.
+!   NOTE: in somehow we should read again the table 'VEGPARM.TBL' and recompute the
+!     roughness length in case that appear a new soil type. (but what left below a 
+!     melted glacier?)
+!
+        LMDZvarmethod='prod'
+        wrf_grid%lrugksoil(:,1,:) = wrf_grid%znt
+
+        CALL lmdz_varKsoil(wims,wime,wjms,wjme,dimx,dimy,wbdyw,wrf_grid%snow,        &
+          LMDZvarmethod,wrf_grid%lter,wrf_grid%llic,wrf_grid%loce,wrf_grid%lsic,     &
+          wrf_grid%lsnowksoil(:,1,:),wrf_grid%lsnowksoil(:,2,:),                     &
+          wrf_grid%lsnowksoil(:,3,:),wrf_grid%lsnowksoil(:,4,:))
+! All the iced soil types have the same roughtness length 0.001
+        wrf_grid%lrugksoil(:,2,:)=0.001
+        wrf_grid%lrugksoil(:,3,:)=0.0001
+        wrf_grid%lrugksoil(:,4,:)=0.001
+
+! Recomputig again the total roughness length
+        CALL wrf_varKsoil(wims,wime,wjms,wjme,dimx,dimy,wbdyw,LMDZvarmethod,         &
+          wrf_grid%lter,wrf_grid%llic,wrf_grid%loce,wrf_grid%lsic,                   &
+          wrf_grid%lrugksoil(:,1,:),wrf_grid%lrugksoil(:,2,:),                       &
+          wrf_grid%lrugksoil(:,3,:),wrf_grid%lrugksoil(:,4,:),wrf_grid%lrug)
+
+! Air surface moisture for each soil type. First order?
+        DO iz=1,4
+          wrf_grid%lqksoil(:,iz,:)=wrf_grid%q2
+        END DO
+
+! Let's split albedo by Ksoils
+        wrf_grid%lalbksoil=0.
+
+        DO iz=1,4
+!! Static roughness length (changing on time in wrflwbdy_d01)
+          wrf_grid%lalbksoil(:,iz,:)=wrf_grid%albedo
+!! Dynamic roughness length (It should work if we use WRF schemes...)
+!          wrf_grid%lalbksoil(:,iz,:)=wrf_grid%albedo
+        END DO
+! First split by Ksoil types.
+!   NOTE: in somehow we should read again the table 'VEGPARM.TBL' and recompute the
+!     albedo in case that appear a new soil type. (but what left below a melted 
+!     glacier?)
+!
+! All the iced soil types have the same albedo
+! For snow/ice there is zmin=0.55, zmax=0.70, tacking the mean value: 0.625
+        wrf_grid%lalbksoil(:,2,:)=0.625
+        wrf_grid%lalbksoil(:,3,:)=0.08
+        wrf_grid%lalbksoil(:,4,:)=0.625
+
+! Recomputig again the total roughness length
+        CALL wrf_varKsoil(wims,wime,wjms,wjme,dimx,dimy,wbdyw,LMDZvarmethod,         &
+          wrf_grid%lter,wrf_grid%llic,wrf_grid%loce,wrf_grid%lsic,                   &
+          wrf_grid%lalbksoil(:,1,:),wrf_grid%lalbksoil(:,2,:),                       &
+          wrf_grid%lalbksoil(:,3,:),wrf_grid%lalbksoil(:,4,:),wrf_grid%albedo)
+! Using the same values for the LW albedo
+        wrf_grid%llwalbksoil = wrf_grid%lalbksoil
+
+! Orography values just beacuse there is no other way right now (they should come 
+!   from geogrid.exe)
+        wrf_grid%lzmea = wrf_grid%ht
+        wrf_grid%lzstd = wrf_grid%topostdv
+        wrf_grid%lzsig = wrf_grid%slope
+        wrf_grid%lzgam = SQRT((wrf_grid%toposlpx**2. + wrf_grid%toposlpy**2.))/      &
+          (1. + wrf_grid%slope)
+        wrf_grid%lzthe = ACOS(wrf_grid%toposlpx/SQRT(wrf_grid%toposlpx**2. +         &
+          wrf_grid%toposlpy**2.))
+        wrf_grid%lzpic = wrf_grid%ht*1.10
+        wrf_grid%lzval = wrf_grid%ht*0.90
+        wrf_grid%lzrugsrel = wrf_grid%lrugKsoil(:,1,:)
+
+! R = 8.3144621 ([J mol/K] http://en.wikipedia.org/wiki/Gas_constant)
+! mu = 28.97 (Molecular Mass of Air [kg/kmol] from http://www.engineeringtoolbox.com/molecular-mass-air-d_679.html)
+! R / mu =? r_d
+
+!        lmdz_Area = dLon * dLat * cos(lat) * Earth_rad
+
+      END IF xtime0
+
+!  Grids do not start/end at the same index
+      wrf_area = 0.
+      wrf_cu = 0.
+      wrf_cv = 0.
+      DO iy=1,ddimy
+        DO ix=1,ddimx
+          wrf_area(ix,iy) = wrf_dx*wrf_dy/wrf_mapft(ix,iy)
+          wrf_cu(ix,iy) = wrf_dx/wrf_mapfu(ix,iy)
+          wrf_cv(ix,iy) = wrf_dy/wrf_mapfv(ix,iy)
+        END DO
+      END DO
+
+!      cu = dLon * Earth_rad
+!      cv = dLat * Earth_rad * cos(Lat)
+
+!      lmdz_cu(1) = cu(1)
+!      lmdz_cv(1) = cv(1)
+!      DO j=2,dimy
+!        DO i=1,dimx
+!          lmdz_cu((j-2)*dimx+1+i) = cu((j-1)*(dimx+1)+i)
+!          lmdz_cv((j-2)*dimx+1+i) = cv((j-1)*(dimx+1)+i)
+!        ENDDO
+!      ENDDO
+!      lmdz_cu(dim_ngridmx) = cu(dimxy+1)
+!      lmdz_cv(dim_ngridmx) = cv(dimxy-dimx)
+
+      AreaValues = RESHAPE(wrf_area, (/ ddimx*ddimy/), ORDER=(/1/))
+      CUValues = RESHAPE(wrf_cu, (/ ddimx*ddimy/), ORDER=(/1/))
+      CVValues = RESHAPE(wrf_cv, (/ ddimx*ddimy/), ORDER=(/1/))
+
+      CALL lmdz_vars_init(ddimxy) 
+
+      CALL load_lmdz(wrf_grid,ddimx,ddimy,dimz,wbdyw,ddimxy,4,11,rlon,rlat,zmasq,    &
+        pctsrf,ftsol,ftsoil_rst,qsurf_rst,qsol_rst,falb1,falb2,evap_rst,snow_rst,    &
+        radsol,solsw,sollw,fder_rst,rain_fall,snow_fall,agesno_rst,zmea,zstd,zgam,   &
+        zthe,zpic,zval,rugoro,rugos_rst,restart_runoff,zmax0,f0,wake_s,wake_cstar,   &
+        wake_pe,wake_fip,sst,albedo,t_ancien,q_ancien,u_ancien,v_ancien,clwcon,      &
+        rnebcon,ratqs,ema_work1,ema_work2,wake_deltat,wake_deltaq,fm_therm,          &
+        entr_therm,detr_therm,phy_glo)
+
+      CALL pbl_surface_init(qsol_rst, fder_rst, snow_rst, qsurf_rst, evap_rst,       &
+        rugos_rst, agesno_rst, ftsoil_rst)
+      CALL fonte_neige_init(restart_runoff)
+
+      DO ix=1,ddimx
+        DO iy=1,ddimy
+          ixy=ddimx*(iy-1)+ix
+          IF (wrf_grid%lter(ix,iy) /= pctsrf(ixy,1)) PRINT *,'    ' //               &
+            TRIM(subname) // ' ter DOES NOT COINCIDE! ', ix,', ',iy,' lter: ',       &
+            wrf_grid%lter(ix,iy),' pctsrf: ',pctsrf(ixy,1)
+          IF (wrf_grid%llic(ix,iy) /= pctsrf(ixy,2)) PRINT *,'    ' //               &
+            TRIM(subname) // ' lic DOES NOT COINCIDE! ', ix,', ',iy,' llic: ',       &
+            wrf_grid%llic(ix,iy),' pctsrf: ',pctsrf(ixy,2)
+          IF (wrf_grid%loce(ix,iy) /= pctsrf(ixy,3)) PRINT *,'    ' //               &
+            TRIM(subname) // ' oce DOES NOT COINCIDE! ', ix,', ',iy,' loce: ',       &
+            wrf_grid%loce(ix,iy),' pctsrf: ',pctsrf(ixy,3)
+          IF (wrf_grid%lsic(ix,iy) /= pctsrf(ixy,4)) PRINT *,'    ' //               &
+            TRIM(subname) // ' sic DOES NOT COINCIDE! ', ix,', ',iy,' lsic: ',       &
+            wrf_grid%lsic(ix,iy),' pctsrf: ',pctsrf(ixy,4)
+        END DO
+      END DO
+
+      CALL NOread_limit_init(ddimxy, klon_glo)
+
+      sst_glo = sst(1:ddimxy)
+! In ocean_forced_mod is used as tsurf_limit = sst(knindex(1:knon))
+      tsurf_limit = ftsol(:,3)
+
+! In surf_land_bucket_mod is used as z0_new=rugos(knindex(1:knon),1) [z0_new == z0_limit]
+      z0_limit = rugos_rst(:,1)
+      alb_limit = albedo
+
+      rug_glo = rugos_rst(:,is_ter)
+      pct_glo(klon_glo,:) = pctsrf(klon_glo,:)
+
+! It is not clear how to deal with 'limit.nc' times...
+!      temps=wjulday
+
+      CALL iniphysiq(ddimx*ddimy, dimz, 86400., wjulday, wtime_step,                    &
+        & LatValues, LonValues, wrf_area, CUValues, CVValues, 1./reradius, g, r_d, cp,  &
+        & iflag_phys)
+
+! NO NEED to do this, using wrfinput_d[nn], wrfbdy_d[nn] and wrflowinput_d[nn]
+! Checking for 'startphy.nc' presence
+!!      INQUIRE(FILE='startphy.nc', EXIST=existsfile)
+!!      IF (.NOT.existsfile) THEN
+!!        WRITE(wrf_err_message,*)"  file 'startphy.nc' with initial conditions " //   &
+!!          & ' for LMDZphys does not exist!!!!'
+!!        CALL wrf_error_fatal(TRIM(wrf_err_message))
+!!      END IF
+
+      CALL init_ovars_lmdz_NOmodule(ddimxy,dimz,nbsrf)
+
+      PRINT *,'  Lluis: END of firststep !!!!!'
+    END IF firststep
+
+    ip=icheck_p
+    jp=jcheck_p
+! WRF alarms
+! I can not print them !!!!
+!!
+!    wrf_grid%alarms => wrf_alarms 
+!    PRINT *,'  Lluis WRF alarms: time-step', wrf_grid%itimestep,' _______'
+!    DO ix=1,3*INT(MAX_WRF_ALARMS/3),3
+!      PRINT *,(ix+iy,': ',wrf_alarms(ix+iy), iy=0,2)
+!    END DO
+!    PRINT *,(iy,': ',wrf_alarms(iy), iy=3*INT(MAX_WRF_ALARMS/3)+1, MAX_WRF_ALARMS)
+
+! What to do with this?
+!!!    IF ( wrf_restart_alarm ) lmdz_lafin = .TRUE.
+
+    INQUIRE(FILE='traceur.def', EXIST=existsfile)
+    IF (existsfile) THEN
+      DO funit=10,100
+        INQUIRE(UNIT=funit, OPENED=is_used)
+        IF (.NOT. is_used) EXIT
+      END DO
+      OPEN(UNIT=10, FILE='traceur.def', STATUS='OLD')
+      READ(10,*)lmdzmixingratios
+      CLOSE(UNIT=10)
+    ELSE
+
+      WRITE(message, *)errmsg
+      CALL wrf_debug(75, message)
+      WRITE(wrf_err_message,*)'  required file traceur.def not found !!'
+      CALL wrf_error_fatal(TRIM(wrf_err_message))
+    END IF
+
+! Regarding if it is a lowbdy input time
+!!
+    PRINT *,'  ',wrf_grid%itimestep,' wrf_islowbdyin: ',wrf_islowbdyin
+!    IF ((wrf_islowbdyin) .AND. .NOT.wrf_restart_alarm) THEN
+    IF ((wrf_islowbdyin)) THEN
+      PRINT *,'  LOWBDY time-step!!!!!!! '
+      PRINT *,'    before: wsst ', wrf_grid%sst(ip,jp),' lsst: ',sst(lp)
+      CALL get_lowbdy(ddimx, ddimy, dimz, wbdyw, ddimxy, 4, 11, klon_glo,            &
+        wrf_grid, pctsrf, ftsol, rugos_rst, albedo, sst, tsurf_limit, z0_limit,      &
+        alb_limit, rug_glo, pct_glo)
+      PRINT *,'    after: wsst ', wrf_grid%sst(ip,jp),' lsst: ',sst(lp)
+!      STOP
+    END IF
+
+    IF (ALLOCATED(MixingRatioValues)) DEALLOCATE(MixingRatioValues)
+    ALLOCATE(MixingRatioValues(ddimxy,dimz,lmdzmixingratios), STAT=ierr)
+    IF (ierr /= 0) THEN
+      PRINT *,errmsg
+      PRINT *,'  ' // subname // ': Problem allocating WRF moisture array!', ierr
+    END IF
+
+    IF (ALLOCATED(MixingRatiotendValues)) DEALLOCATE(MixingRatiotendValues)
+    ALLOCATE(MixingRatiotendValues(ddimxy,dimz,lmdzmixingratios))
+
+! Transforming from WRF theta temperature to LMDZ temperature (in K)
+!!
+    wrf_P = wrf_baseP + wrf_perP
+    wrf_geopot = wrf_basegeopot + wrf_pergeopot
+    wrf_sfcgeopot = wrf_grid%ht*g
+! de-staggering winds
+!!
+
+    wrfUdestagg(wims:wime-1,:,wjms:wjme-1) = (wrf_U(wims:wime-1,:,wjms:wjme-1) +     &
+      wrf_U(wims+1:wime,:,wjms:wjme-1))/2.
+    wrfVdestagg(wims:wime-1,:,wjms:wjme-1) = (wrf_V(wims:wime-1,:,wjms:wjme-1) +     &
+      wrf_V(wims:wime-1,:,wjms+1:wjme))/2.
+    wrfUtenddestagg(wims:wime-1,:,wjms:wjme-1) =                                     &
+      (wrf_Utend(wims:wime-1,:,wjms:wjme-1) + wrf_Utend(wims+1:wime,:,wjms:wjme-1))/2.
+    wrfVtenddestagg(wims:wime-1,:,wjms:wjme-1) =                                     &
+      (wrf_Vtend(wims:wime-1,:,wjms:wjme-1) + wrf_Vtend(wims:wime-1,:,wjms+1:wjme))/2.
+
+!! NO de-stagger in z
+!!    wrfWValues = (wrf_w(:,wkms:wkme-1,:)+wrf_w(:,wkms+1:wkme,:))/2.
+!!    wrfPERMASSValues = (wrf_permass(:,wkms:wkme-1,:)+wrf_permass(:,wkms+1:wkme,:))/2.
+!!    DO k=wkms,wkme
+!!      wrfMASSValues(:,k,:)=-(wrfPERMASSVAlues(:,k,:)+wrf_basemass)*wrf_dfulleta(k)/g
+!!    END DO
+    wrfWValues=wrf_w
+    DO iz=wkms,wkme
+      wrfMASSValues(:,iz,:) = -(wrf_permass+wrf_basemass)*wrf_dfulleta(iz)/g
+    END DO
+    wrfZFluxMassValues=wrfWValues*wrfMASSValues
+
+!!    CALL theta_to_temp(THETAVALUES=wrf_T, PRESSVALUES=wrf_P, TEMPVALUES=wrf_Temp     &
+!!                  ! Dimension arguments           
+!!       &             ,IDS=wids,IDE=wide, JDS=wjds,JDE=wjde, KDS=wkds,KDE=wkde        &
+!!       &             ,IMS=wims,IME=wime, JMS=wjms,JME=wjme, KMS=wkms,KME=wkme        &
+!!       &             ,IPS=wips,IPE=wipe, JPS=wjps,JPE=wjpe, KPS=wkps,KPE=wkpe        &
+!!       &             ,I_START=wi_start,I_END=wi_end                                  &
+!!       &             ,J_START=wj_start,J_END=wj_end                                  &
+!!       &             ,KTS=wkts, KTE=wkte                                             &
+!!       &             ,NUM_TILES=wnum_tiles                                           &
+!!       &                                                          )
+
+    CALL theta_to_temp(wrf_T, wrf_P, wrf_Temp                                        &
+                  ! Dimension arguments           
+       &             ,wids,wide, wjds,wjde, wkds,wkde                                &
+       &             ,wims,wime, wjms,wjme, wkms,wkme                                &
+       &             ,wips,wipe, wjps,wjpe, wkps,wkpe                                &
+       &             ,wi_start,wi_end                                                &
+       &             ,wj_start,wj_end                                                &
+       &             ,wkts, wkte                                                     &
+       &             ,wnum_tiles                                                     &
+       &                                                          )
+
+!!    CALL theta_to_temp(THETAVALUES=wrf_Ttend, PRESSVALUES=wrf_P,                     &
+!!       &              TEMPVALUES=wrf_Temptend                                        &
+!!                  ! Dimension arguments           
+!!       &             ,IDS=wids,IDE=wide, JDS=wjds,JDE=wjde, KDS=wkds,KDE=wkde        &
+!!       &             ,IMS=wims,IME=wime, JMS=wjms,JME=wjme, KMS=wkms,KME=wkme        &
+!!       &             ,IPS=wips,IPE=wipe, JPS=wjps,JPE=wjpe, KPS=wkps,KPE=wkpe        &
+!!       &             ,I_START=wi_start,I_END=wi_end                                  &
+!!       &             ,J_START=wj_start,J_END=wj_end                                  &
+!!       &             ,KTS=wkts, KTE=wkte                                             &
+!!       &             ,NUM_TILES=wnum_tiles                                           &
+!!       &                                                          )
+
+    CALL theta_to_temp(wrf_Ttend, wrf_P, wrf_Temptend                                  &
+                  ! Dimension arguments            
+       &             ,wids,wide, wjds,wjde, wkds,wkde                                  &
+       &             ,wims,wime, wjms,wjme, wkms,wkme                                  &
+       &             ,wips,wipe, wjps,wjpe, wkps,wkpe                                  &
+       &             ,wi_start,wi_end                                                  &
+       &             ,wj_start,wj_end                                                  &
+       &             ,wkts, wkte                                                       &
+       &             ,wnum_tiles                                                       &
+       &                                                          )
+
+    DO ix=1,ddimx
+      DO iy=1,ddimy
+        sfcGeopotValues(ddimx*(iy-1)+ix) = wrf_grid%ht(ix,iy)*g
+      END DO 
+    END DO
+
+    CALL mat_vect(wrf_Temp, dimx, dimy, dimz, wbdyw, TValues)
+    CALL mat_vect(wrf_Temptend, dimx, dimy, dimz, wbdyw, TtendValues)
+    CALL mat_vect(wrfUdestagg, dimx, dimy, dimz, wbdyw, UValues)
+    CALL mat_vect(wrfUtenddestagg, dimx, dimy, dimz, wbdyw, UtendValues)
+    CALL mat_vect(wrfVdestagg, dimx, dimy, dimz, wbdyw, VValues)
+    CALL mat_vect(wrfVtenddestagg, dimx, dimy, dimz, wbdyw, VtendValues)
+!    CALL mat_vect(wrf_U, dimx, dimy, dimz, wbdyw, UValues)
+!    CALL mat_vect(wrf_Utend, dimx, dimy, dimz, wbdyw, UtendValues)
+!    CALL mat_vect(wrf_V, dimx, dimy, dimz, wbdyw, VValues)
+!    CALL mat_vect(wrf_Vtend, dimx, dimy, dimz, wbdyw, VtendValues)
+    CALL mat_vect(wrf_P, dimx, dimy, dimz, wbdyw, HalfPressValues)
+    CALL mat_vect_zstagg(wrf_fullpres, dimx, dimy, dimz+1, wbdyw, FullPressValues)
+    CALL mat_vect_zstagg(wrf_geopot, dimx, dimy, dimz+1, wbdyw, GeopotValues)
+    CALL mat_vect(wrfZFluxMassValues, dimx, dimy, dimz, wbdyw, WFluxMassValues)
+
+    CALL WRFmoist_LMDZmoist(wrf_MOIST, dimx, dimy, dimz, wnum3dm, wbdyw, wrf_qvid,   &
+       & wrf_qcid, wrf_qrid, lmdzmixingratios, MixingRatioValues)
+
+    CALL WRFmoist_LMDZmoist(wrf_MOISTtend, dimx, dimy, dimz, wnum3dm, wbdyw, wrf_qvid,&
+       & wrf_qcid, wrf_qrid, lmdzmixingratios, MixingRatiotendValues)
+
+    preff=100000.
+    CALL eta_to_pressure(wrf_halfeta, preff, wrf_Ptop, dimz, lmdzoutP)
+
+! We need to provide values to these variables in order to make it works
+    presnivs=lmdzoutP
+
+! Lluis Testing water species
+    MixingRatioValues(:,:,2)=0.
+
+    IF (wrf_dbg >= 200) THEN
+
+!! Values at a given LMDZ matrix point
+      lmdzp=lp
+      jlmdz=INT(lmdzp/ddimx) + 1
+      ilmdz=lmdzp-(jlmdz-1)*ddimx
+!! Values at a given WRF 2D point
+!      ilmdz=ip
+!      jlmdz=jp
+!      lmdzp=ddimx*(jlmdz-1)+ilmdz
+
+      PRINT *,'  WRF+LMDZ lmdzp: ',lmdzp,' : ',ilmdz,jlmdz
+      PRINT *,'k wrf_T wrf_Temp TValues_______________'
+      DO iz=1,dimz
+        PRINT *,iz, wrf_T(ilmdz,iz,jlmdz), wrf_Temp(ilmdz,iz,jlmdz), TValues(lmdzp,iz)
+      END DO
+      PRINT *,'k wrf_U Uvalues wrf_V VValues _______________'
+      DO iz=1,dimz
+        PRINT *,iz, wrf_U(ilmdz,iz,jlmdz), UValues(lmdzp,iz), wrf_V(ilmdz,iz,jlmdz), &
+          VValues(lmdzp,iz)
+      END DO
+      PRINT *,'k wrf_fullpres FUllPressValues wrf_sfcgeopot hgt sfcGeopotValues______'
+      DO iz=1,dimz+1
+        PRINT *,iz,wrf_fullpres(ilmdz,iz,jlmdz), FullPressValues(lmdzp,iz),          &
+          wrf_sfcgeopot(ilmdz,jlmdz), wrf_grid%ht(ilmdz,jlmdz), sfcGeopotValues(lmdzp)
+      END DO
+      PRINT *,'k wrf_halfpress HalfPressValues wrf_Geopot GeopotValues lmdz outP ' //&
+        '_______________'
+      DO iz=1,dimz
+        PRINT *,iz, wrf_P(ilmdz,iz,jlmdz), HalfPressValues(lmdzp,iz),                &
+          wrf_geopot(ilmdz,iz,jlmdz), GeopotValues(lmdzp,iz), lmdzoutP(iz)
+      END DO
+      PRINT *,'k wrf_MOIST MixingRatioValues _______________'
+      DO iz=1,dimz
+        PRINT *,iz,wrf_MOIST(ilmdz,iz,jlmdz,wrf_qvid), MixingRatioValues(lmdzp,iz,1),&
+          wrf_MOIST(ix,iz,jlmdz,wrf_qcid), MixingRatioValues(lmdzp,iz,2)
+      END DO
+      PRINT *,'k wrf_mass wrf_W wrf_dfulleta wrfMASSValues wrfZFluxMassValues ' //   &
+        'WFluxMassValues ____________'
+      DO iz=1,dimz
+        PRINT *,iz,wrf_permass(ilmdz,jlmdz)+wrf_basemass(ilmdz,jlmdz),               &
+          wrf_W(ilmdz,iz,jlmdz), wrf_dfulleta(iz), wrfMASSValues(ilmdz,iz,jlmdz),    &
+          wrfZFluxMassValues(ilmdz,iz,jlmdz), WFluxMassValues(lmdzp,iz)
+      END DO
+    END IF
+
+    ip=icheck_p
+    jp=jcheck_p
+
+!! L. Fita, July 2013. 
+!! Misteriously 'physiq' suborutine from LMDZ can not be called using keys
+!!
+!!    CALL physiq(NLON=dimxy, NLEV=dimz,                                               &
+!!       &  DEBUT=lmdz_debut, LAFIN=lmdz_lafin,                                        &
+!!       &  JD_CUR=wjulday, JH_CUR=wgmt, PDTPHYS=wtime_step,                           &
+!!       &  PAPRS=FullPressValues, PPLAY=HalfPressValues,                              &
+!!       &  PPHI=GeopotValues, PPHIS=wrf_sfcgeopot,                                    &
+!!       &  PRESNIVS=lmdzoutP, CLESPHY0=phykeys,                                       &
+!!       &  U=UValues, V=VValues, T=TValues, QX=MixingRatioValues,                     &
+!!       &  FLXMASS_W=WFluxMassValues,                                                 &
+!!       &  D_U=UtendValues, D_V=VtendValues, D_T=TtendValues,                         &
+!!       &  D_QX=MixingRatiotendValues, D_PS=wrf_psfctend,                             &
+!!       &  DUDYN=lmdz_dudyn, PVTETA=lmdz_PVtheta)
+
+!!    PRINT *,'  Lluis: going to physiq'
+
+    CALL physiq(ddimxy, dimz,                                                        &
+       &  lmdz_debut, lmdz_lafin,                                                    &
+       &  wjulday, wgmt, wtime_step,                                                 &
+       &  FullPressValues, HalfPressValues,                                          &
+       &  GeopotValues, sfcGeopotValues,                                             &
+       &  lmdzoutP, phykeys,                                                         &
+       &  UValues, VValues, TValues, MixingRatioValues,                              &
+       &  WFluxMassValues,                                                           &
+       &  UtendValues, VtendValues, TtendValues,                                     &
+       &  MixingRatiotendValues, psfctendValues,                                     &
+       &  lmdz_dudyn, lmdz_PVtheta)
+
+    ip=icheck_p
+    jp=jcheck_p
+! Lluis Testing water species
+!!    MixingRatiotendValues(:,:,1)=1000.*MixingRatiotendValues(:,:,1)
+!!    MixingRatiotendValues(:,:,1)=MixingRatiotendValues(:,:,1)+MixingRatiotendValues(:,:,2)
+    MixingRatiotendValues(:,:,2)=0.
+
+!!    PRINT *,'  Lluis: outgoing from physiq'
+
+!! Tvalues, [U/V/T]Values, are not given back just inputs
+    CALL vect_mat(TtendValues, dimx, dimy, dimz, wbdyw, wrf_Temptend)
+    CALL vect_mat(UtendValues, dimx, dimy, dimz, wbdyw, wrfUtenddestagg)
+    CALL vect_mat(VtendValues, dimx, dimy, dimz, wbdyw, wrfVtenddestagg)
+!    CALL vect_mat(UtendValues, dimx, dimy, dimz, wbdyw, wrf_Utend)
+!    CALL vect_mat(VtendValues, dimx, dimy, dimz, wbdyw, wrf_Vtend)
+!!    CALL vect_mat(TValues, dimx, dimy, dimz, wbdyw, wrf_Temp)
+!!    CALL vect_mat(UValues, dimx, dimy, dimz, wbdyw, wrf_U)
+!!    CALL vect_mat(VValues, dimx, dimy, dimz, wbdyw, wrf_V)
+!!    CALL vect_mat(HalfPressValues, dimx, dimy, dimz, wbdyw, wrf_P)
+!!    CALL vect_mat(FullPressValues, dimx, dimy, dimz, wbdyw, wrf_fullpres)
+!!    CALL vect_mat(GeopotValues, dimx, dimy, dimz, wbdyw, wrf_geopot)
+
+    DO iy=1,ddimy
+      DO ix=1,ddimx
+        wrf_psfctend(ix,iy) = PsfctendValues(ddimx*(iy-1)+ix)
+      END DO
+    END DO
+
+!! No changes are suffered not need to give it back
+!!    CALL temp_to_theta(TEMPVALUES=wrf_Temp, PRESSVALUES=wrf_P, THETAVALUES=wrf_T     &
+!!                  ! Dimension arguments           
+!!       &             ,IDS=wids,IDE=wide, JDS=wjds,JDE=wjde, KDS=wkds,KDE=wkde        &
+!!       &             ,IMS=wims,IME=wime, JMS=wjms,JME=wjme, KMS=wkms,KME=wkme        &
+!!       &             ,IPS=wips,IPE=wipe, JPS=wjps,JPE=wjpe, KPS=wkps,KPE=wkpe        &
+!!       &             ,I_START=wi_start,I_END=wi_end                                  &
+!!       &             ,J_START=wj_start,J_END=wj_end                                  &
+!!       &             ,KTS=wkts, KTE=wkte                                             &
+!!       &             ,NUM_TILES=wnum_tiles                                           &
+!!       &                                                          )
+
+    CALL temp_to_theta(TEMPVALUES=wrf_Temptend, PRESSVALUES=wrf_P,                   &
+       &              THETAVALUES=wrf_Ttend                                          &
+                  ! Dimension arguments           
+       &             ,IDS=wids,IDE=wide, JDS=wjds,JDE=wjde, KDS=wkds,KDE=wkde        &
+       &             ,IMS=wims,IME=wime, JMS=wjms,JME=wjme, KMS=wkms,KME=wkme        &
+       &             ,IPS=wips,IPE=wipe, JPS=wjps,JPE=wjpe, KPS=wkps,KPE=wkpe        &
+       &             ,I_START=wi_start,I_END=wi_end                                  &
+       &             ,J_START=wj_start,J_END=wj_end                                  &
+       &             ,KTS=wkts, KTE=wkte                                             &
+       &             ,NUM_TILES=wnum_tiles                                           &
+       &                                                          )
+
+    wrf_Ttend = wrf_Ttend + 300.
+
+! Re-staggering wind tendencies
+!!
+
+    wrf_Utend(wims,:,wjms:wjme-1) = wrfUtenddestagg(wims,:,wjms:wjme-1)
+    wrf_Vtend(wims:wime-1,:,wjms) = wrfVtenddestagg(wims:wime-1,:,wjms)
+    wrf_Utend(wims,:,wjme-1) = wrfUtenddestagg(wims,:,wjme-1)
+    wrf_Vtend(wime-1,:,wjms) = wrfVtenddestagg(wime-1,:,wjms)
+    wrf_Utend(wims+1:wime-1,:,wjms:wjme-1) =                                         &
+       &  (wrfUtenddestagg(wims:wime-2,:,wjms:wjme-1) +                              &
+       &   wrfUtenddestagg(wims+1:wime-1,:,wjms:wjme-1))/2.
+    wrf_Vtend(wims:wime-1,:,wjms+1:wjme-1) =                                         &
+       & (wrfVtenddestagg(wims:wime-1,:,wjms:wjme-2) +                               &
+       &   wrfVtenddestagg(wims:wime-1,:,wjms+1:wjme-1))/2.
+    wrf_Utend(wime,:,wjms:wjme-1) = wrfUtenddestagg(wime-1,:,wjms:wjme-1)
+    wrf_Vtend(wims:wime-1,:,wjme) = wrfVtenddestagg(wims:wime-1,:,wjme-1)
+    wrf_Utend(wime,:,wjme) = wrfUtenddestagg(wime-1,:,wjme-1)
+    wrf_Vtend(wime,:,wjme) = wrfVtenddestagg(wime-1,:,wjme-1)
+
+!!    wrf_Ttend = wrf_Temptend
+
+!!    wrf_perP = wrf_P - wrf_baseP
+!!    wrf_pergeopot = wrf_geopot - wrf_basegeopot
+
+!!    CALL LMDZmoist_WRFmoist(MixingRatioValues, dimx, dimy, dimz, wnum3dm, wrf_qvid,  &
+!!       & wrf_qcid, wrf_qrid, lmdzmixingratios, wrf_MOIST)
+
+    CALL LMDZmoist_WRFmoist(MixingRatiotendValues, dimx, dimy, dimz, wnum3dm, wbdyw, &
+       & wrf_qvid, wrf_qcid, wrf_qrid, lmdzmixingratios, wrf_MOISTtend)
+
+    IF (wrf_dbg >= 200) THEN
+      PRINT *,'  WRF+LMDZ lmdzp: ',lmdzp
+      PRINT *,'k T tendencies _______________'
+      DO iz=1,dimz
+        PRINT *,iz, TtendValues(lmdzp,iz), wrf_Temptend(ilmdz,iz,jlmdz),             &
+          wrf_Ttend(ilmdz,iz,jlmdz)
+      END DO
+      PRINT *,'k U tendencies V tendencies_______________'
+      DO iz=1,dimz
+        PRINT *,iz, UtendValues(lmdzp,iz), wrf_Utend(ilmdz,iz,jlmdz),                &
+          VtendValues(lmdzp,iz), wrf_Vtend(ilmdz,iz,jlmdz)
+      END DO
+      PRINT *,'k MixingRatiotendValues wrf_MOISTtend _______________'
+      DO iz=1,dimz
+        PRINT *,iz, MixingRatiotendValues(lmdzp,iz,1),                               &
+          wrf_MOISTtend(ilmdz,iz,jlmdz,wrf_qvid), MixingRatiotendValues(lmdzp,iz,2), &
+          wrf_MOISTtend(ilmdz,iz,jlmdz,wrf_qcid)
+      END DO
+      PRINT *,'wrf_sfcgeopot psfc_tendencies sfcGeopotValues_______________'
+      PRINT *,wrf_sfcgeopot(ilmdz,jlmdz), wrf_psfctend(ilmdz,jlmdz),                 &
+        sfcGeopotValues(lmdzp)
+    END IF
+
+    PRINT *,'  Lluis psfctendValues ______________ '
+    DO ix=1,4*INT(ddimxy/4),4
+      PRINT *,(ix+iy,':',psfctendValues(ix+iy), iy=0,3)
+    END DO
+    PRINT *,(iy,':',psfctendValues(iy), iy=4*INT(ddimxy/4)+1,ddimxy)
+
+! All the tendencies have to be given as decoupled from the dry air mass column! (see dyn_em/module_em.F:rk_update_scalar) 
+!!
+    DO iz=1,dimz
+      wrf_Ttend(:,iz,:) = wrf_Ttend(:,iz,:)*wrf_mut
+      wrf_Utend(:,iz,:) = wrf_Utend(:,iz,:)*wrf_muu
+      wrf_Vtend(:,iz,:) = wrf_Vtend(:,iz,:)*wrf_muv
+      DO iq=1,wnum3dm
+        wrf_MOISTtend(:,iz,:,iq) = wrf_MOISTtend(:,iz,:,iq)*wrf_mut
+      END DO
+    END DO
+
+    CALL get_lmdz(ddimx,ddimy,dimz,wbdyw,ddimxy,4,11,rlon,rlat,zmasq,                &
+      pctsrf,ftsol,ftsoil,zxqsurf,qsurf,falb1,falb2,fevap,zxsnow,radsol,solsw,       &
+      sollw,fder,rain_fall,snow_fall,agesno,zmea,zstd,zgam,zthe,zpic,zval,rugoro,    &
+      frugs,zmax0,f0,wake_s,wake_cstar,wake_pe,wake_fip,sst,albedo,                  &
+      t_ancien,q_ancien,u_ancien,v_ancien,clwcon,rnebcon,ratqs,ema_work1,ema_work2,  &
+      wake_deltat,wake_deltaq,fm_therm,entr_therm,detr_therm,phy_glo,wrf_grid)
+!    CALL fonte_neige_final(runoff_lic)     
+
+! Some re-start variables
+    PRINT *,'   Lluis lrunofflic: ',LBOUND(wrf_grid%lrunofflic), ':',                &
+      UBOUND(wrf_grid%lrunofflic),' ruonff_lic: ',UBOUND(runoff_lic),' ddimx: ',     &
+      ddimx,' ddimy: ',ddimy
+
+!    PRINT *,'    iy ix ddimx*(iy-1)+ix runoff_lic wrf_grid%lrunofflic_______'
+!    DO iy=1,ddimy
+!      DO ix=1,ddimx
+!        PRINT *,iy,ix,ddimx*(iy-1)+ix
+!        wrf_grid%lrunofflic(ix,iy) = runoff_lic(ddimx*(iy-1)+ix)
+!        PRINT *,iy,ix,ddimx*(iy-1)+ix,runoff_lic(ddimx*(iy-1)+ix),wrf_grid%lrunofflic(ix,iy)
+!      END DO
+!    END DO
+
+!    STOP
+!!    CALL get_lmdz(ddimx,ddimy,dimz,wbdyw,ddimxy,4,11,zmasq,pctsrf,ftsol,             &
+!!        ftsoil,fqsurf,qsol_d,falb1,falb2,fevap,zxsnow,radsol,solsw,sollw,fder,       &
+!!        rain_fall,snow_fall,agesno,zmea,zstd,zgam,zthe,zpic,zval,rugoro,             &
+!!        frugs,run_off_lic,zmax0,f0,wake_s,wake_cstar,wake_pe,wake_fip,sst,           &
+!!        albedo,t_ancien,q_ancien,u_ancien,v_ancien,clwcon,rnebcon,ratqs,             &
+!!        ema_work1,ema_work2,wake_deltat,wake_deltaq,fm_therm,entr_therm,             &
+!!        detr_therm,phy_glo,wrf_grid)
+
+    PRINT *,'  Lluis after get '//TRIM(Spt)//' ltksoil: ',wrf_grid%ltksoil(ip,:,jp), &
+      ' ftsol: ',ftsol(lp,:)
+
+    PRINT *,'  Lluis after get '//TRIM(Spt)//' fqsurf: ',zxqsurf(lp),' qsurf_rst: ', &
+        qsurf_rst(lp,:),' smois :',wrf_grid%smois(ip,:,jp),' lqksoil: ',             &
+        wrf_grid%lqksoil(ip,:,jp)
+
+! Recomputig again the total roughness length
+    LMDZvarmethod = 'prod'
+
+    CALL wrf_varKsoil(wims,wime,wjms,wjme,dimx,dimy,wbdyw,LMDZvarmethod,             &
+      wrf_grid%lter,wrf_grid%llic,wrf_grid%loce,wrf_grid%lsic,                       &
+      wrf_grid%lrugksoil(:,1,:),wrf_grid%lrugksoil(:,2,:),wrf_grid%lrugksoil(:,3,:), &
+      wrf_grid%lrugksoil(:,4,:),wrf_grid%lrug)
+
+    CALL wrf_varKsoil(wims,wime,wjms,wjme,dimx,dimy,wbdyw,LMDZvarmethod,             &
+      wrf_grid%lter,wrf_grid%llic,wrf_grid%loce,wrf_grid%lsic,                       &
+      wrf_grid%lalbksoil(:,1,:),wrf_grid%lalbksoil(:,2,:),wrf_grid%lalbksoil(:,3,:), &
+      wrf_grid%lalbksoil(:,4,:),wrf_grid%albedo)
+
+! L. Fita, LMD January 2014. 
+!  It should work nicely in this way... but memory got crazy...
+    CALL get_lmdz_out(ddimx, ddimy, dimz, wbdyw, ddimxy, nbsrf, nsoilmx,             &
+       & lmdzmixingratios, 1, 2, wrf_l_pbl, wrf_l_con, wrf_l_thermals, wrf_l_wake,   &
+       & 0, wrf_grid%itimestep, wtime_step, FullPressValues, HalfPressValues,        &
+       & GeopotValues, sfcGeopotValues, lmdzoutP, MixingRatioValues,                 &
+       & UtendValues, VtendValues, TtendValues, MixingRatiotendValues,               &
+       & psfctendValues, wrf_grid)
+
+    ip=icheck_p
+    jp=jcheck_p
+
+    CALL put_lmdz_in_WRFout(wims, wime, wjms, wjme, wkms, wkme, ddimx, ddimy, dimz,  &
+       & wbdyw, ddimxy, ip, jp, lp, nbsrf, nsoilmx,                                  &
+       & lmdzmixingratios, 1, 2, wrf_l_pbl, wrf_l_con, wrf_l_thermals, wrf_l_wake,   &
+       & wrf_grid%itimestep, wtime_step, FullPressValues, HalfPressValues,           &
+       & GeopotValues, sfcGeopotValues, lmdzoutP, MixingRatioValues,                 &
+       & UtendValues, VtendValues, TtendValues, MixingRatiotendValues,               &
+       & psfctendValues, ORCHIDEElevels, ftsoil, WRF_nsoillayers,                    &
+       & wrf_grid%soil_layers/100., wrf_grid%zs, wrf_grid%dzs, wrf_grid%nest_pos,    &
+       & wrf_grid%q2, wrf_grid%t2, wrf_grid%th2, wrf_grid%psfc, wrf_grid%u10,        &
+       & wrf_grid%v10, wrf_grid%resm, wrf_grid%zetatop, wrf_grid%tslb,wrf_grid%smois,&
+       & wrf_grid%sh2o, wrf_grid%smcrel, wrf_grid%sfcrunoff, wrf_grid%udrunoff,      &
+       & wrf_grid%grdflx, wrf_grid%acgrdflx, wrf_grid%snow, wrf_grid%snowh,          &
+       & wrf_grid%canwat, wrf_grid%sst, wrf_grid%sstsk, wrf_grid%lai,                &
+       & wrf_grid%h_diabatic, wrf_grid%sina, wrf_grid%tsk, wrf_grid%tiso,            &
+       & wrf_grid%max_msftx, wrf_grid%max_msfty, wrf_grid%rainc, wrf_grid%raincv,    &
+       & wrf_grid%rainsh, wrf_grid%rainshv, wrf_grid%rainnc, wrf_grid%rainncv,       &
+       & wrf_grid%snownc, wrf_grid%snowncv, wrf_grid%graupelnc, wrf_grid%graupelncv, &
+       & wrf_grid%hailnc, wrf_grid%hailncv, wrf_grid%stepave_count, wrf_grid%cldfra, &
+       & wrf_grid%swdown, wrf_grid%glw, wrf_grid%swnorm, wrf_grid%olr,               &
+       & wrf_grid%emiss, wrf_grid%tmn, wrf_grid%ust, wrf_grid%pblh, wrf_grid%hfx,    &
+       & wrf_grid%qfx, wrf_grid%lh, wrf_grid%achfx, wrf_grid%aclhf,                  &
+       & wrf_grid%snowc, wrf_grid%sr, wrf_grid%potevp, wrf_grid%snopcx,              &
+       & wrf_grid%soiltb)
+!       & wrf_grid%save_topo_from_real,                                               &
+!       & wrf_grid%avg_fuel_frac, wrf_grid%uah, wrf_grid%vah, wrf_grid%seed1,         &
+!       & wrf_grid%seed2)
+
+    ip=icheck_p
+    jp=jcheck_p
+
+
+! So it is done in a more larger to type and less elegant way...
+!
+!    CALL get_lmdz_out2D_i(wims, wime, wjms, wjme, wkms, wkme, ddimx, ddimy, dimz,    &
+!       & wbdyw, ddimxy, nbsrf, nsoilmx, lmdzmixingratios, 1, 2, wrf_l_thermals,      &
+!       & wrf_l_wake, wrf_grid%itimestep, wtime_step, FullPressValues2,               &
+!       & HalfPressValues2, GeopotValues2,                                            &
+!       & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                              &
+!       & UtendValues2, VtendValues2, TtendValues2,                                   &
+!       & MixingRatiotendValues2, psfctendValues2, wrf_grid%lages_ter,                &
+!       & wrf_grid%lages_lic, wrf_grid%lages_oce, wrf_grid%lages_sic, wrf_grid%laire, &
+!       & wrf_grid%laireter, wrf_grid%lalb1, wrf_grid%lalb2, wrf_grid%lalbe_ter,      &
+!       & wrf_grid%lalbe_lic, wrf_grid%lalbe_oce, wrf_grid%lalbe_sic, wrf_grid%lale,  &
+!       & wrf_grid%lale_bl, wrf_grid%lale_wk, wrf_grid%lalp, wrf_grid%lalp_bl,        &
+!       & wrf_grid%lalp_wk, wrf_grid%lbils, wrf_grid%lbils_diss, wrf_grid%lbils_ec,   &
+!       & wrf_grid%lbils_enthalp, wrf_grid%lbils_kinetic, wrf_grid%lbils_latent,      &
+!       & wrf_grid%lbils_tke, wrf_grid%lcape, wrf_grid%lcape_max, wrf_grid%lcdrh,     &
+!       & wrf_grid%lcdrm, wrf_grid%lcldh, wrf_grid%lcldl, wrf_grid%lcldm,             &
+!       & wrf_grid%lcldq, wrf_grid%lcldt, wrf_grid%lcontfracatm, wrf_grid%lcontfracor,&
+!       & wrf_grid%ldthmin, wrf_grid%ldtsvdft, wrf_grid%ldtsvdfo, wrf_grid%ldtsvdfg,  &
+!       & wrf_grid%ldtsvdfi)
+
+!    CALL get_lmdz_out2D_ii(wims, wime, wjms, wjme, wkms, wkme, ddimx, ddimy, dimz,   &
+!       & wbdyw, ddimxy, nbsrf, nsoilmx, lmdzmixingratios, 1, 2, wrf_l_thermals,      &
+!       & wrf_l_wake, wrf_grid%itimestep, wtime_step, FullPressValues2,               &
+!       & HalfPressValues2, GeopotValues2,                                            &
+!       & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                              &
+!       & UtendValues2, VtendValues2, TtendValues2,                                   &
+!       & MixingRatiotendValues2, psfctendValues2, wrf_grid%levap, wrf_grid%levap_ter,&
+!       & wrf_grid%levap_lic,                                                         &
+!       & wrf_grid%levap_oce, wrf_grid%levap_sic, wrf_grid%levappot_ter,              &
+!       & wrf_grid%levappot_lic, wrf_grid%levappot_oce, wrf_grid%levappot_sic,        & 
+!       & wrf_grid%lfbase, wrf_grid%lffonte, wrf_grid%lflat, wrf_grid%lflw_ter,       &
+!       & wrf_grid%lflw_lic, wrf_grid%lflw_oce, wrf_grid%lflw_sic,                    &
+!       & wrf_grid%lfqcalving, wrf_grid%lfqfonte, wrf_grid%lfract_ter,                &
+!       & wrf_grid%lfract_lic, wrf_grid%lfract_oce, wrf_grid%lfract_sic,              & 
+!       & wrf_grid%lfsnow, wrf_grid%lfsw_ter, wrf_grid%lfsw_lic, wrf_grid%lfsw_oce,   &
+!       & wrf_grid%lfsw_sic, wrf_grid%lftime_th, wrf_grid%liwp, wrf_grid%llat_ter,    &
+!       & wrf_grid%llat_lic, wrf_grid%llat_oce, wrf_grid%llat_sic, wrf_grid%llmaxth,  &
+!       & wrf_grid%llwp, wrf_grid%lmsnow)
+
+!    CALL get_lmdz_out2D_iii(wims, wime, wjms, wjme, wkms, wkme, ddimx, ddimy, dimz,  &
+!       & wbdyw, ddimxy, ip, jp, lp, nbsrf, nsoilmx, lmdzmixingratios, 1, 2,          &
+!       & wrf_l_thermals, wrf_l_wake, wrf_grid%itimestep,                             &
+!       & wtime_step, FullPressValues2, HalfPressValues2, GeopotValues2,              &
+!       & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                              &
+!       & UtendValues2, VtendValues2, TtendValues2,                                   &
+!       & MixingRatiotendValues2, psfctendValues2,wrf_grid%lndayrain,wrf_grid%lnettop,&
+!       & wrf_grid%lpbase, wrf_grid%lphis, wrf_grid%lplcl, wrf_grid%lplfc,            &
+!       & wrf_grid%lpluc, wrf_grid%lplul, wrf_grid%lplulst, wrf_grid%lplulth,         &
+!       & wrf_grid%lpourc_ter, wrf_grid%lpourc_lic, wrf_grid%lpourc_oce,              &
+!       & wrf_grid%lpourc_sic, wrf_grid%lprecip, wrf_grid%lprw, wrf_grid%lpsol,       &
+!       & wrf_grid%lptop, wrf_grid%lqsat2m, wrf_grid%lqsol, wrf_grid%lqsurf,          &
+!       & wrf_grid%lradsol, wrf_grid%lrh2m, wrf_grid%lrh2m_max, wrf_grid%lrh2m_min,   &
+!       & wrf_grid%lrugs, wrf_grid%lrugs_ter, wrf_grid%lrugs_lic, wrf_grid%lrugs_oce, &
+!       & wrf_grid%lrugs_sic, wrf_grid%lsens, wrf_grid%lsicf, wrf_grid%ls_lcl,        &
+!       & wrf_grid%lslp, wrf_grid%lsnow, wrf_grid%lsnowl, wrf_grid%lsoll,             &
+!       & wrf_grid%lsoll0, wrf_grid%lsollwdown, wrf_grid%lsols, wrf_grid%lsols0,      &
+!       & wrf_grid%ls_pblh, wrf_grid%ls_pblt, wrf_grid%ls_therm)
+
+!    CALL get_lmdz_out2D_iv(wims, wime, wjms, wjme, wkms, wkme, ddimx, ddimy, dimz,   &
+!       & wbdyw, ddimxy, nbsrf, nsoilmx, lmdzmixingratios, 1, 2, wrf_l_thermals,      &
+!       & wrf_l_wake, wrf_grid%itimestep,                                             &
+!       & wtime_step, FullPressValues2, HalfPressValues2, GeopotValues2,              &
+!       & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                              &
+!       & UtendValues2, VtendValues2, TtendValues2,                                   &
+!       & MixingRatiotendValues2, psfctendValues2,  wrf_grid%lt2m,                    &
+!       & wrf_grid%lt2m_max, wrf_grid%lt2m_min, wrf_grid%lt2m_ter, wrf_grid%lt2m_lic, &
+!       & wrf_grid%lt2m_oce, wrf_grid%lt2m_sic, wrf_grid%ltaux, wrf_grid%ltauy,       &
+!       & wrf_grid%ltaux_ter, wrf_grid%ltaux_lic, wrf_grid%ltaux_oce,                 &
+!       & wrf_grid%ltaux_sic, wrf_grid%ltauy_ter, wrf_grid%ltauy_lic,                 & 
+!       & wrf_grid%ltauy_oce, wrf_grid%ltauy_sic, wrf_grid%lt_oce_sic, wrf_grid%ltopl,&
+!       & wrf_grid%ltopl0, wrf_grid%ltops, wrf_grid%ltops0, wrf_grid%ltpot,           &
+!       & wrf_grid%ltpote, wrf_grid%ltsol, wrf_grid%ltsol_ter, wrf_grid%ltsol_lic,    &
+!       & wrf_grid%ltsol_oce, wrf_grid%ltsol_sic)
+
+!    CALL get_lmdz_out2D_v(wims, wime, wjms, wjme, wkms, wkme, ddimx, ddimy, dimz,    &
+!       & wbdyw, ddimxy, nbsrf, nsoilmx, lmdzmixingratios, 1, 2, wrf_l_thermals,      &
+!       & wrf_l_wake, wrf_grid%itimestep,                                             &
+!       & wtime_step, FullPressValues2, HalfPressValues2, GeopotValues2,              &
+!       & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                              &
+!       & UtendValues2, VtendValues2, TtendValues2,                                   &
+!       & MixingRatiotendValues2, psfctendValues2,wrf_grid%lu10m, wrf_grid%lu10m_ter, &
+!       & wrf_grid%lu10m_lic, wrf_grid%lu10m_oce, wrf_grid%lu10m_sic, wrf_grid%lue,   &
+!       & wrf_grid%luq, wrf_grid%lustar, wrf_grid%lustar_ter, wrf_grid%lustar_lic,    &
+!       & wrf_grid%lustar_oce, wrf_grid%lustar_sic, wrf_grid%lv10m,                   &
+!       & wrf_grid%lv10m_ter, wrf_grid%lv10m_lic, wrf_grid%lv10m_oce,                 &
+!       & wrf_grid%lv10m_sic, wrf_grid%lve, wrf_grid%lvq, wrf_grid%lwake_h,           &
+!       & wrf_grid%lwake_s, wrf_grid%lwbeff, wrf_grid%lwbilo_ter, wrf_grid%lwbilo_lic,&
+!       & wrf_grid%lwbilo_oce, wrf_grid%lwbilo_sic, wrf_grid%lwbils_ter,              &
+!       & wrf_grid%lwbils_lic, wrf_grid%lwbils_oce, wrf_grid%lwbils_sic,              &
+!       & wrf_grid%lweakinv, wrf_grid%lwind10m, wrf_grid%lwind10max, wrf_grid%lzmax_th)
+
+!    DO iz=wkms, wkme-2
+!      CALL get_lmdz_out3D_z_i(wims, wime, wjms, wjme, iz, ddimx, ddimy, dimz, wbdyw, &
+!        & ddimxy, ip, jp, lp, nbsrf, nsoilmx, lmdzmixingratios, 1, 2, wrf_l_con,     &
+!        & wrf_l_thermals, wrf_l_wake,                                                &
+!        & wrf_grid%itimestep,                                                        &
+!        & wtime_step, FullPressValues2, HalfPressValues2, GeopotValues2,             &
+!        & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                             &
+!        & UtendValues2, VtendValues2, TtendValues2,                                  &
+!        & MixingRatiotendValues2, psfctendValues2,                                   &
+!        & wrf_grid%la_th(wims:wime,iz,wjms:wjme),                                    &
+!        & wrf_grid%lbeta_prec(wims:wime,iz,wjms:wjme),                               &
+!        & wrf_grid%ldmc(wims:wime,iz,wjms:wjme),                                     &
+!        & wrf_grid%ldnwd(wims:wime,iz,wjms:wjme),                                    &
+!        & wrf_grid%ldnwd0(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldqajs(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldqcon(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldqdyn(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldqeva(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldqlsc(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldqlscst(wims:wime,iz,wjms:wjme),                                 &
+!        & wrf_grid%ldqlscth(wims:wime,iz,wjms:wjme),                                 &
+!        & wrf_grid%ldqphy(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldqthe(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldqvdf(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldqwak(wims:wime,iz,wjms:wjme))
+
+!      CALL get_lmdz_out3D_z_ii(wims, wime, wjms, wjme, iz, ddimx, ddimy, dimz,       &
+!        & wbdyw, ddimxy, ip, jp, lp, nbsrf, nsoilmx, lmdzmixingratios, 1, 2,         &
+!        & wrf_l_thermals, wrf_l_wake,                                                &
+!        & wrf_grid%itimestep,                                                        &
+!        & wtime_step, FullPressValues2, HalfPressValues2, GeopotValues2,             &
+!        & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                             &
+!        & UtendValues2, VtendValues2, TtendValues2,                                  &
+!        & MixingRatiotendValues2, psfctendValues2,                                   &
+!        & wrf_grid%ldtajs(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtcon(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtdis(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtdyn(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtec(wims:wime,iz,wjms:wjme),                                    &
+!        & wrf_grid%ldteva(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ld_th(wims:wime,iz,wjms:wjme),                                    &
+!        & wrf_grid%lcldemi(wims:wime,iz,wjms:wjme),                                  &
+!        & wrf_grid%lcldtau(wims:wime,iz,wjms:wjme),                                  &
+!        & wrf_grid%lclwcon(wims:wime,iz,wjms:wjme),                                  &
+!        & wrf_grid%ldtlif(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtlsc(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtlschr(wims:wime,iz,wjms:wjme),                                 &
+!        & wrf_grid%ldtlscst(wims:wime,iz,wjms:wjme),                                 &
+!        & wrf_grid%ldtlscth(wims:wime,iz,wjms:wjme),                                 &
+!        & wrf_grid%ldtlw0(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtlwr(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtoro(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtphy(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtsw0(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtswr(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtthe(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtvdf(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldtwak(wims:wime,iz,wjms:wjme))
+
+!      CALL get_lmdz_out3D_z_iii(wims, wime, wjms, wjme, iz, ddimx, ddimy,            &
+!        & dimz, wbdyw, ddimxy, ip, jp, lp, nbsrf, nsoilmx, lmdzmixingratios, 1, 2,   &
+!        & wrf_l_con, wrf_l_thermals, wrf_l_wake, wrf_grid%itimestep,                 &
+!        & wtime_step, FullPressValues2, HalfPressValues2, GeopotValues2,             &
+!        & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                             &
+!        & UtendValues2, VtendValues2, TtendValues2,                                  &
+!        & MixingRatiotendValues2, psfctendValues2,                                   &
+!        & wrf_grid%lducon(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldudyn(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldulif(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%lduoro(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%lduvdf(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldvcon(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldvdyn(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldvlif(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldvoro(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%ldvvdf(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%le_th(wims:wime,iz,wjms:wjme),                                    &
+!        & wrf_grid%levu(wims:wime,iz,wjms:wjme),                                     &
+!        & wrf_grid%lfl(wims:wime,iz,wjms:wjme),                                      &
+!        & wrf_grid%lgeop(wims:wime,iz,wjms:wjme),                                    &
+!        & wrf_grid%lh2o(wims:wime,iz,wjms:wjme),                                     &
+!        & wrf_grid%liwcon(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%lkz(wims:wime,iz,wjms:wjme),                                      &
+!        & wrf_grid%lkz_max(wims:wime,iz,wjms:wjme),                                  &
+!        & wrf_grid%llambda_th(wims:wime,iz,wjms:wjme),                               &
+!        & wrf_grid%llwcon(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%lma(wims:wime,iz,wjms:wjme),                                      &
+!        & wrf_grid%lmc(wims:wime,iz,wjms:wjme),                                      &
+!        & wrf_grid%lmcd(wims:wime,iz,wjms:wjme),                                     &
+!        & wrf_grid%lmass(wims:wime,iz,wjms:wjme))
+
+!     CALL get_lmdz_out3D_z_iv(wims, wime, wjms, wjme, iz, ddimx, ddimy, dimz,        &
+!        & wbdyw, ddimxy, nbsrf, nsoilmx, lmdzmixingratios, 1, 2, wrf_l_thermals,     &
+!        & wrf_l_wake, wrf_grid%itimestep,                                            &
+!        & wtime_step, FullPressValues2, HalfPressValues2, GeopotValues2,             &
+!        & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                             &
+!        & UtendValues2, VtendValues2, TtendValues2,                                  &
+!        & MixingRatiotendValues2, psfctendValues2,                                   &
+!        & wrf_grid%loliq(wims:wime,iz,wjms:wjme),                                    &
+!        & wrf_grid%lovap(wims:wime,iz,wjms:wjme),                                    &
+!        & wrf_grid%lovapinit(wims:wime,iz,wjms:wjme),                                &
+!        & wrf_grid%lpaprs(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%lpr_con_i(wims:wime,iz,wjms:wjme),                                &
+!        & wrf_grid%lpr_con_l(wims:wime,iz,wjms:wjme),                                &
+!        & wrf_grid%lpres(wims:wime,iz,wjms:wjme),                                    &
+!        & wrf_grid%lpr_lsc_i(wims:wime,iz,wjms:wjme),                                &
+!        & wrf_grid%lpr_lsc_l(wims:wime,iz,wjms:wjme),                                &
+!        & wrf_grid%lptconv(wims:wime,iz,wjms:wjme),                                  &
+!        & wrf_grid%lq_th(wims:wime,iz,wjms:wjme),                                    &
+!        & wrf_grid%lratqs(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%lre(wims:wime,iz,wjms:wjme),                                      &
+!        & wrf_grid%lref_ice(wims:wime,iz,wjms:wjme),                                 &
+!        & wrf_grid%lref_liq(wims:wime,iz,wjms:wjme),                                 &
+!        & wrf_grid%lrhum(wims:wime,iz,wjms:wjme),                                    &
+!        & wrf_grid%lrld(wims:wime,iz,wjms:wjme),                                     &
+!        & wrf_grid%lrldcs(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%lrlu(wims:wime,iz,wjms:wjme),                                     &
+!        & wrf_grid%lrlucs(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%lrneb(wims:wime,iz,wjms:wjme),                                    &
+!        & wrf_grid%lrnebcon(wims:wime,iz,wjms:wjme),                                 &
+!        & wrf_grid%lrnebls(wims:wime,iz,wjms:wjme),                                  &
+!        & wrf_grid%lrsd(wims:wime,iz,wjms:wjme),                                     &
+!        & wrf_grid%lrsdcs(wims:wime,iz,wjms:wjme),                                   &
+!        & wrf_grid%lrsu(wims:wime,iz,wjms:wjme),                                     &
+!        & wrf_grid%lrsucs(wims:wime,iz,wjms:wjme))
+
+!     CALL get_lmdz_out3D_z_v(wims, wime, wjms, wjme, iz, ddimx, ddimy, dimz,         &
+!       & wbdyw, ddimxy, ip, jp, lp, nbsrf, nsoilmx, lmdzmixingratios, 1, 2, 1,       &
+!       & wrf_l_con, wrf_l_thermals, wrf_l_wake, wrf_grid%itimestep,                  &
+!       & wtime_step, FullPressValues2, HalfPressValues2, GeopotValues2,              &
+!       & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                              &
+!       & UtendValues2, VtendValues2, TtendValues2,                                   &
+!       & MixingRatiotendValues2, psfctendValues2,                                    &
+!       & wrf_grid%lsens_ter(wims:wime,iz,wjms:wjme),                                 &
+!       & wrf_grid%lsens_lic(wims:wime,iz,wjms:wjme),                                 &
+!       & wrf_grid%lsens_oce(wims:wime,iz,wjms:wjme),                                 &
+!       & wrf_grid%lsens_sic(wims:wime,iz,wjms:wjme),                                 &
+!       & wrf_grid%ltemp(wims:wime,iz,wjms:wjme),                                     &
+!       & wrf_grid%ltheta(wims:wime,iz,wjms:wjme),                                    &
+!       & wrf_grid%ltke(wims:wime,iz,wjms:wjme),                                      &
+!       & wrf_grid%ltke_max(wims:wime,iz,wjms:wjme),                                  &
+!       & wrf_grid%ltke_ter(wims:wime,iz,wjms:wjme),                                  &
+!       & wrf_grid%ltke_lic(wims:wime,iz,wjms:wjme),                                  &
+!       & wrf_grid%ltke_oce(wims:wime,iz,wjms:wjme),                                  &
+!       & wrf_grid%ltke_sic(wims:wime,iz,wjms:wjme),                                  &
+!       & wrf_grid%ltnhus(wims:wime,iz,wjms:wjme),                                    &
+!       & wrf_grid%ltnhusc(wims:wime,iz,wjms:wjme),                                   &
+!       & wrf_grid%ltnhusscpbl(wims:wime,iz,wjms:wjme),                               &
+!       & wrf_grid%ltnt(wims:wime,iz,wjms:wjme),                                      &
+!       & wrf_grid%ltntc(wims:wime,iz,wjms:wjme),                                     &
+!       & wrf_grid%ltntr(wims:wime,iz,wjms:wjme),                                     &
+!       & wrf_grid%ltntscpbl(wims:wime,iz,wjms:wjme),                                 &
+!       & wrf_grid%lupwd(wims:wime,iz,wjms:wjme),                                     &
+!       & wrf_grid%lvitu(wims:wime,iz,wjms:wjme),                                     &
+!       & wrf_grid%lvitv(wims:wime,iz,wjms:wjme),                                     &
+!       & wrf_grid%lvitw(wims:wime,iz,wjms:wjme),                                     &
+!       & wrf_grid%lvprecip(wims:wime,iz,wjms:wjme),                                  &
+!       & wrf_grid%lwake_omg(wims:wime,iz,wjms:wjme),                                 &
+!       & wrf_grid%lwdtraina(wims:wime,iz,wjms:wjme),                                 &
+!       & wrf_grid%lwdtrainm(wims:wime,iz,wjms:wjme),                                 &
+!       & wrf_grid%lzfull(wims:wime,iz,wjms:wjme),                                    &
+!       & wrf_grid%lzhalf(wims:wime,iz,wjms:wjme))
+
+!    END DO
+
+!    CALL get_lmdz_out3D_ii(wims, wime, wjms, wjme, wkms, wkme, ddimx, ddimy, dimz,   &
+!      & wbdyw, ddimxy, nbsrf, nsoilmx, lmdzmixingratios, 1, 2, wrf_l_thermals,       &
+!        & wrf_l_wake, wrf_grid%itimestep,      &
+!       & wtime_step, FullPressValues2, HalfPressValues2, GeopotValues2,              &
+!       & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                              &
+!       & UtendValues2, VtendValues2, TtendValues2,                                   &
+!       & MixingRatiotendValues2, psfctendValues2,                                    &
+!       & wrf_grid%ldtajs,                                                            &
+!       & wrf_grid%ldtcon, wrf_grid%ldtdis, wrf_grid%ldtdyn, wrf_grid%ldtec,          &
+!       & wrf_grid%ldteva, wrf_grid%ld_th, wrf_grid%lcldemi, wrf_grid%lcldtau,        &
+!       & wrf_grid%lclwcon, wrf_grid%ldtlif, wrf_grid%ldtlsc, wrf_grid%ldtlschr,      &
+!       & wrf_grid%ldtlscst, wrf_grid%ldtlscth, wrf_grid%ldtlw0, wrf_grid%ldtlwr,     &
+!       & wrf_grid%ldtoro, wrf_grid%ldtphy, wrf_grid%ldtsw0, wrf_grid%ldtswr,         &
+!       & wrf_grid%ldtthe, wrf_grid%ldtvdf, wrf_grid%ldtwak)
+
+!    CALL get_lmdz_out3D_iii(wims, wime, wjms, wjme, wkms, wkme, ddimx, ddimy, dimz,  &
+!       & wbdyw, ddimxy, nbsrf, nsoilmx, lmdzmixingratios, 1, 2, wrf_l_thermals, wrf_l_wake, wrf_grid%itimestep,     &
+!       & wtime_step, FullPressValues2, HalfPressValues2, GeopotValues2,              &
+!       & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                                &
+!       & UtendValues2, VtendValues2, TtendValues2,                                   &
+!       & MixingRatiotendValues2, psfctendValues2,                                    &
+!       & wrf_grid%lducon,                                                            &
+!       & wrf_grid%ldudyn, wrf_grid%ldulif, wrf_grid%lduoro, wrf_grid%lduvdf,         &
+!       & wrf_grid%ldvcon, wrf_grid%ldvdyn, wrf_grid%ldvlif, wrf_grid%ldvoro,         &
+!       & wrf_grid%ldvvdf, wrf_grid%le_th, wrf_grid%levu, wrf_grid%lfl,wrf_grid%lgeop,&
+!        & wrf_grid%lh2o, wrf_grid%liwcon, wrf_grid%lkz, wrf_grid%lkz_max,             &
+!        & wrf_grid%llambda_th, wrf_grid%llwcon, wrf_grid%lma, wrf_grid%lmass)
+
+!     CALL get_lmdz_out3D_iv(wims, wime, wjms, wjme, wkms, wkme, ddimx, ddimy, dimz,   &
+!       & wbdyw, ddimxy, nbsrf, nsoilmx, lmdzmixingratios, 1, 2, wrf_l_thermals, wrf_l_wake, wrf_grid%itimestep,     &
+!       & wtime_step, FullPressValues2, HalfPressValues2, GeopotValues2,              &
+!       & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                                &
+!       & UtendValues2, VtendValues2, TtendValues2,                                   &
+!       & MixingRatiotendValues2, psfctendValues2,                                    &
+!       & wrf_grid%loliq, wrf_grid%lovap,                                             &
+!       & wrf_grid%lovapinit, wrf_grid%lpaprs, wrf_grid%lpr_con_i, wrf_grid%lpr_con_l,&
+!       & wrf_grid%lpres, wrf_grid%lpr_lsc_i, wrf_grid%lpr_lsc_l, wrf_grid%lptconv,   &
+!       & wrf_grid%lq_th, wrf_grid%lratqs, wrf_grid%lre, wrf_grid%lref_ice,           &
+!       & wrf_grid%lref_liq, wrf_grid%lrhum, wrf_grid%lrld, wrf_grid%lrldcs,          &
+!       & wrf_grid%lrlu, wrf_grid%lrlucs, wrf_grid%lrneb, wrf_grid%lrnebcon,          &
+!       & wrf_grid%lrnebls, wrf_grid%lrsd, wrf_grid%lrsdcs, wrf_grid%lrsu,            &
+!       & wrf_grid%lrsucs)
+
+!    CALL get_lmdz_out3D_v(wims, wime, wjms, wjme, wkms, wkme, ddimx, ddimy, dimz,    &
+!       & wbdyw, ddimxy, nbsrf, nsoilmx, lmdzmixingratios, 1, 2, wrf_l_thermals, wrf_l_wake, wrf_grid%itimestep,     &
+!       & wtime_step, FullPressValues2, HalfPressValues2, GeopotValues2,              &
+!       & sfcGeopotValues, lmdzoutP, MixingRatioValues2,                                &
+!       & UtendValues2, VtendValues2, TtendValues2,                                   &
+!       & MixingRatiotendValues2, psfctendValues2,                                    &
+!       & wrf_grid%lsens_ter, wrf_grid%lsens_lic, wrf_grid%lsens_oce,                 &
+!       & wrf_grid%lsens_sic, wrf_grid%ltemp, wrf_grid%ltheta, wrf_grid%ltke,         &
+!       & wrf_grid%ltke_max, wrf_grid%ltke_ter, wrf_grid%ltke_lic, wrf_grid%ltke_oce, &
+!       & wrf_grid%ltke_sic, wrf_grid%ltnhus, wrf_grid%ltnhusc, wrf_grid%ltnhusscpbl, &
+!       & wrf_grid%ltnt, wrf_grid%ltntc, wrf_grid%ltntr, wrf_grid%ltntscpbl,          &
+!       & wrf_grid%lupwd, wrf_grid%lvitu, wrf_grid%lvitv, wrf_grid%lvitw,             &
+!       & wrf_grid%lwake_deltaq, wrf_grid%lwake_deltat, wrf_grid%lwake_omg,           &
+!       & wrf_grid%lwdtraina, wrf_grid%lwdtrainm, wrf_grid%lzfull, wrf_grid%lzhalf)
+
+    DEALLOCATE(MixingRatioValues)
+    DEALLOCATE(MixingRatiotendValues)
+
+    WRITE(message, *)'  exiting: module_lmdz_phys.F'
+    CALL wrf_debug(75, message)
+
+  END SUBROUTINE call_lmdz_phys
+
+END MODULE module_lmdz_phys
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_microphysics_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_microphysics_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_microphysics_driver.F	(revision 17)
@@ -0,0 +1,1012 @@
+!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                                               &
+                      ,chem_opt, progn                                   &
+                      ,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                         &
+                      ,ips,ipe, jps,jpe, kps,kpe                         &
+                      ,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,qh_curr,qnh_curr             &
+                      ,qzr_curr,qzi_curr,qzs_curr,qzg_curr,qzh_curr      &
+                      ,qns_curr,qnr_curr,qng_curr,qnn_curr,qnc_curr      &
+                      ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop,f_qni      &
+                      ,f_qns,f_qnr,f_qng,f_qnc,f_qnn,f_qh,f_qnh          &
+                      ,            f_qzr,f_qzi,f_qzs,f_qzg,f_qzh         &
+                      ,qrcuten, qscuten, qicuten, mu                     &
+                      ,qt_curr,f_qt                                      &
+                      ,mp_restart_state,tbpvs_state,tbpvs0_state         & ! for etampnew
+                      ,hail,ice2                                         & ! for mp_gsfcgce
+!                     ,ccntype                                           & ! for mp_milbrandt2mom
+                      ,w ,z                                              &
+                      ,rainnc,    rainncv                                &
+                      ,snownc,    snowncv                                &
+                      ,hailnc,    hailncv                                &
+                      ,graupelnc, graupelncv                             &
+                      ,refl_10cm                                         & ! HM, 9/22/09, add for refl
+! YLIN
+! Added the RI_CURR array to the call
+                      ,ri_curr                                           &
+                                                   )
+! Framework
+#if(NMM_CORE==1)
+   USE module_state_description, ONLY :                                  &
+                     KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME    &
+                    ,WSM6SCHEME, ETAMPNEW, etamp_HWRF,THOMPSON, MORR_TWO_MOMENT     &
+                    ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME  &
+                    ,MILBRANDT2MOM !,MILBRANDT3MOM
+#else
+   USE module_state_description, ONLY :                                  &
+                     KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME    &
+                    ,WSM6SCHEME, ETAMPNEW,THOMPSON, MORR_TWO_MOMENT     &
+                    ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME &
+                    ,MILBRANDT2MOM !,MILBRANDT3MOM
+#endif
+
+! 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_sbu_ylin
+   USE module_mp_wsm3
+   USE module_mp_wsm5
+   USE module_mp_wsm6
+   USE module_mp_etanew
+   USE module_mp_thompson
+   USE module_mp_gsfcgce
+   USE module_mp_morr_two_moment
+   USE module_mp_wdm5
+   USE module_mp_wdm6
+   USE module_mp_milbrandt2mom
+!  USE module_mp_milbrandt3mom
+
+   USE module_mp_HWRF
+   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)
+   ! Milbrandt and Yau (2005)
+
+!----------------------------------------------------------------------
+   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)
+! Qg         graupel        mixing ratio (kg/kg)
+! Qh         hail           mixing ratio (kg/kg)
+! Qndrop     droplet number mixing ratio (#/kg)
+! Qni        cloud ice number concentration (#/kg)
+! Qns        snow      number concentration (#/kg)
+! Qnr        rain      number concentration (#/kg)
+! Qng        graupel   number concentration (#/kg)
+! Qnh        hail      number concentration (#/kg)
+
+! Qzr        rain             reflectivity (m6/kg)
+! Qzi        ice              reflectivity (m6/kg)
+! Qzs        snow             reflectivity (m6/kg)
+! Qzg        graupel          reflectivity (m6/kg)
+! Qzh        hail             reflectivity (m6/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)
+!-- HAILNC        grid scale hail (mm)
+!-- HAILNCV       one time step grid scale hail (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_QH          species index for hail
+!-- P_QNDROP      species index for cloud drop mixing ratio
+!-- P_QNR         species index for rain number concentration,
+!-- P_QNI         species index for cloud ice number concentration
+!-- P_QNS         species index for snow number concentration,
+!-- P_QNG         species index for graupel number concentration,
+!-- P_QNH         species index for hail number concentration,
+!-- P_QZR         species index for rain    reflectivity
+!-- P_QZI         species index for ice     reflectivity
+!-- P_QZS         species index for snow    reflectivity
+!-- P_QZG         species index for graupel reflectivity
+!-- P_QZH         species index for hail    reflectivity
+!-- 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, OPTIONAL, INTENT(IN   )    :: chem_opt, progn
+   INTEGER, OPTIONAL, INTENT(IN   )    :: hail, ice2 !, ccntype
+!
+   INTEGER,      INTENT(IN   )    ::       ids,ide, jds,jde, kds,kde
+   INTEGER,      INTENT(IN   )    ::       ims,ime, jms,jme, kms,kme
+   INTEGER, OPTIONAL, INTENT(IN   )    ::       ips,ipe, jps,jpe, kps,kpe
+   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
+!
+   REAL, OPTIONAL, DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(OUT) :: refl_10cm
+
+   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,qh_curr,qnh_curr   &
+                 ,qns_curr,qnr_curr,qng_curr,qnn_curr,qnc_curr    &
+                 ,qzr_curr,qzi_curr,qzs_curr,qzg_curr,qzh_curr
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
+         OPTIONAL,                                                &
+         INTENT(IN) :: qrcuten, qscuten, qicuten
+   REAL, DIMENSION( ims:ime, jms:jme ),                           &
+         OPTIONAL,                                                &
+         INTENT(IN) :: mu
+! YLIN
+! Added RI_CURR similar to microphysics fields above
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
+         OPTIONAL,                                                &
+         INTENT(INOUT) :: ri_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 &
+                                                          ,HAILNC &
+                                                         ,HAILNCV
+   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    &
+                       ,f_qns,f_qnr,f_qng,f_qnn,f_qnc,f_qh,f_qnh,f_qzr       &
+                       ,f_qzi,f_qzs,f_qzg,f_qzh
+
+! 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
+
+#ifndef RUN_ON_GPU
+   !$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)
+#else
+   DO ij = 1 , 1
+       IF (channel) THEN
+         its = max(ips,ids)
+         ite = min(ipe,ide-1)
+       ELSE
+         its = max(ips,ids+sz)
+         ite = min(ipe,ide-1-sz)
+       ENDIF
+       jts = max(jps,jds+sz)
+       jte = min(jpe,jde-1-sz)
+#endif
+
+
+! 2009-06009 rce - zero all these for safety
+       IF( PRESENT(qlsink) ) qlsink(its:ite,kts:kte,jts:jte) = 0.
+       IF( PRESENT(precr ) ) precr(its:ite,kts:kte,jts:jte)  = 0.
+       IF( PRESENT(preci ) ) preci(its:ite,kts:kte,jts:jte)  = 0.
+       IF( PRESENT(precs ) ) precs(its:ite,kts:kte,jts:jte)  = 0.
+       IF( PRESENT(precg ) ) precg(its:ite,kts:kte,jts:jte)  = 0.
+
+!-----------
+       IF( PRESENT(chem_opt) .AND. PRESENT(progn) ) THEN
+       IF( chem_opt==0 .AND. progn==1 .AND. (mp_physics==LINSCHEME  .OR. mp_physics==MORR_TWO_MOMENT)) THEN
+          IF( PRESENT( QNDROP_CURR ) ) 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,                                      &
+                  ids,ide, jds,jde, kds,kde,                    &
+                  ims,ime, jms,jme, kms,kme,                    &
+                  its,ite, jts,jte, kts,kte,                    &
+                  F_QC=f_qc, F_QI=f_qi                          )
+          END IF
+       ELSE IF( progn==1 .AND. mp_physics/=LINSCHEME .AND. mp_physics/=MORR_TWO_MOMENT) THEN
+             call wrf_error_fatal("SETTINGS ERROR: Prognostic cloud droplet number can only be used with the mp_physics=LINSCHEME or MORRISON.")
+       END IF
+       END IF
+
+     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' )
+             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( QNR_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,                        &
+                     NR=qnr_curr,                        &
+                     TH=th,                              &
+                     PII=pi_phy,                         &
+                     P=p,                                &
+                     DZ=dz8w,                            &
+                     DT_IN=dt,                           &
+                     ITIMESTEP=itimestep,                &
+                     RAINNC=RAINNC,                      &
+                     RAINNCV=RAINNCV,                    &
+                     SNOWNC=SNOWNC,                      &
+                     SNOWNCV=SNOWNCV,                    &
+                     GRAUPELNC=GRAUPELNC,                &
+                     GRAUPELNCV=GRAUPELNCV,              &
+                     SR=SR                               &
+!                    refl_10cm, grid_clock, grid_alarms, &
+                 ,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 (MORR_TWO_MOMENT)
+         CALL wrf_debug(100, 'microphysics_driver: calling morrison two moment')
+         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 (QR_CURR) .AND. PRESENT (QI_CURR) .AND. &
+         PRESENT (QNS_CURR) .AND. PRESENT (QNI_CURR).AND. &
+         PRESENT (QNR_CURR) .AND. PRESENT (QNG_CURR).AND. &
+         PRESENT (MU) .AND. PRESENT (QSCUTEN).AND. &
+         PRESENT (QRCUTEN) .AND. PRESENT (QICUTEN).AND. &
+         PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. &
+         PRESENT (Z      ) .AND.PRESENT ( W      )  ) THEN
+         CALL mp_morr_two_moment(                            &
+                     ITIMESTEP=itimestep,                &  !*
+                     TH=th,                              &  !*
+                     QV=qv_curr,                         &  !*
+                     QC=qc_curr,                         &  !*
+                     QR=qr_curr,                         &  !*
+                     QI=qi_curr,                         &  !*
+                     QS=qs_curr,                         &  !*
+                     QG=qg_curr,                         &  !*
+                     NI=qni_curr,                        &  !*
+                     NS=qns_curr,                        &  !* ! VVT
+                     NR=qnr_curr,                        &  !* ! VVT
+                     NG=qng_curr,                        &  !* ! VVT
+                     RHO=rho,                            &  !*
+                     PII=pi_phy,                         &  !*
+                     P=p,                                &  !*
+                     DT_IN=dt,                           &  !*
+                     DZ=dz8w,                            &  !* !hm
+                     HT=ht,                              &  !*
+                     W=w                                 &  !*
+                    ,RAINNC=RAINNC                       &  !*
+                    ,RAINNCV=RAINNCV                     &  !*
+                    ,SR=SR                               &  !* !hm
+                    ,qrcuten=qrcuten                     &  ! hm
+                    ,qscuten=qscuten                     &  ! hm
+                    ,qicuten=qicuten                     &  ! hm
+                    ,mu=mu                          &  ! hm
+                    ,F_QNDROP=f_qndrop                   &  ! hm for wrf-chem
+                 ,QNDROP=qndrop_curr                     &  ! hm for wrf-chem
+                 ,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 &
+                 ,QLSINK=qlsink                                     & ! jdf for wrf-chem
+                 ,PRECR=precr,PRECI=preci,PRECS=precs,PRECG=precg   & ! jdf for wrf-chem
+                                                                    )
+        ELSE
+           Call wrf_error_fatal( 'arguments not present for calling morrison two moment')
+        ENDIF
+
+
+    CASE (MILBRANDT2MOM)
+         CALL wrf_debug(100, 'microphysics_driver: calling milbrandt2mom')
+         IF (PRESENT (QV_CURR) .AND.                           &
+             PRESENT (QC_CURR) .AND. PRESENT (QNC_CURR)  .AND. &
+             PRESENT (QR_CURR) .AND. PRESENT (QNR_CURR)  .AND. &
+             PRESENT (QI_CURR) .AND. PRESENT (QNI_CURR)  .AND. &
+             PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR)  .AND. &
+             PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR)  .AND. &
+             PRESENT (QH_CURR) .AND. PRESENT (QNH_CURR)  .AND. &
+             PRESENT (RAINNC ) .AND. PRESENT (RAINNCV)   .AND. &
+             PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV)   .AND. &
+             PRESENT (HAILNC ) .AND. PRESENT (HAILNCV)   .AND. &
+             PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. &
+             PRESENT (Z      ) .AND. PRESENT ( W      )  ) THEN
+!            PRESENT (ccntype)                                 &
+
+         CALL mp_milbrandt2mom_driver(                   &
+                     ITIMESTEP=itimestep,                &
+                     TH=th,                              &
+                     QV=qv_curr,                         &
+                     QC=qc_curr,                         &
+                     QR=qr_curr,                         &
+                     QI=qi_curr,                         &
+                     QS=qs_curr,                         &
+                     QG=qg_curr,                         &
+                     QH=qh_curr,                         &
+                     NC=qnc_curr,                        &
+                     NR=qnr_curr,                        &
+                     NI=qni_curr,                        &
+                     NS=qns_curr,                        &
+                     NG=qng_curr,                        &
+                     NH=qnh_curr,                        &
+                     PII=pi_phy,                         &
+                     P=p,                                &
+                     DT_IN=dt,                           &
+                     DZ=dz8w,                            &
+                     W=w,                                &
+                     RAINNC   = RAINNC,                  &
+                     RAINNCV  = RAINNCV,                 &
+                     SNOWNC   = SNOWNC,                  &
+                     SNOWNCV  = SNOWNCV,                 &
+                     HAILNC   = HAILNC,                  &
+                     HAILNCV  = HAILNCV,                 &
+                     GRPLNC   = GRAUPELNC,               &
+                     GRPLNCV  = GRAUPELNCV,              &
+                     SR=SR,                              &
+!                    ccntype  = ccntype,                 &
+                     Zet      = refl_10cm,               & ! HM, 9/22/09 for refl
+                  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 milbrandt2mom')
+        ENDIF
+
+
+!     CASE (MILBRANDT3MOM)
+!          CALL wrf_debug(100, 'microphysics_driver: calling milbrandt3mom')
+!          IF (PRESENT (QV_CURR) .AND.                          &
+!              PRESENT (QC_CURR) .AND. PRESENT (QNC_CURR) .AND. &
+!              PRESENT (QR_CURR) .AND. PRESENT (QNR_CURR) .AND. PRESENT (QZR_CURR) .AND.  &
+!              PRESENT (QI_CURR) .AND. PRESENT (QNI_CURR) .AND. PRESENT (QZI_CURR) .AND.  &
+!              PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR) .AND. PRESENT (QZS_CURR) .AND.  &
+!              PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. PRESENT (QZG_CURR) .AND.  &
+!              PRESENT (QH_CURR) .AND. PRESENT (QNH_CURR) .AND. PRESENT (QZH_CURR) .AND.  &
+!              PRESENT (RAINNC ) .AND. PRESENT (RAINNCV)  .AND. &
+!              PRESENT (Z      ) .AND. PRESENT ( W      )  ) THEN
+!          CALL mp_milbrandt3mom_driver(                   &
+!                      ITIMESTEP=itimestep,                &  !*
+!                      TH=th,                              &  !*
+!                      QV=qv_curr,                         &  !*
+!                      QC=qc_curr,                         &  !*
+!                      QR=qr_curr,                         &  !*
+!                      QI=qi_curr,                         &  !*
+!                      QS=qs_curr,                         &  !*
+!                      QG=qg_curr,                         &  !*
+!                      QH=qh_curr,                         &  !*
+!                      NC=qnc_curr,                        &  !*
+!                      NR=qnr_curr,                        &  !*
+!                      NI=qni_curr,                        &  !*
+!                      NS=qns_curr,                        &  !*
+!                      NG=qng_curr,                        &  !*
+!                      NH=qnh_curr,                        &  !*
+!                      ZR=qzr_curr,                        &  !*
+!                      ZI=qzi_curr,                        &  !*
+!                      ZS=qzs_curr,                        &  !*
+!                      ZG=qzg_curr,                        &  !*
+!                      ZH=qzh_curr,                        &  !*
+!                      PII=pi_phy,                         &  !*
+!                      P=p,                                &  !*
+!                      DT_IN=dt,                           &  !*
+!                      DZ=dz8w,                            &  !* ! h
+!                      W=w                                 &  !*
+!                     ,RAINNC=RAINNC                       &  !*
+!                     ,RAINNCV=RAINNCV                     &  !*
+!                     ,SR=SR                               &  !* !hm
+!                  ,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 milbrandt3mom')
+!         ENDIF
+
+!
+        CASE (GSFCGCESCHEME)
+             CALL wrf_debug ( 100 , 'microphysics_driver: calling GSFCGCE' )
+             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( HAIL    ) .AND. PRESENT ( ICE2    ) .AND.  &
+                  PRESENT( Z       ) .AND. PRESENT ( W       )  ) THEN
+               CALL gsfcgce(                                        &
+                  TH=th                                             &
+                 ,QV=qv_curr                                        &
+                 ,QL=qc_curr                                        &
+                 ,QR=qr_curr                                        &
+                 ,QI=qi_curr                                        &
+                 ,QS=qs_curr                                        &
+                 ,RHO=rho, PII=pi_phy, P=p, DT_IN=dt, Z=z           &
+                 ,HT=ht, DZ8W=dz8w, GRAV=G                          &
+                 ,RHOWATER=rhowater, RHOSNOW=rhosnow                &
+                 ,ITIMESTEP=itimestep                               &
+                 ,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 &
+                 ,RAINNC=rainnc, RAINNCV=rainncv                    &
+                 ,SNOWNC=snownc, SNOWNCV=snowncv ,SR=sr             &
+                 ,GRAUPELNC=graupelnc ,GRAUPELNCV=graupelncv        &
+                 ,F_QG=f_qg                                         &
+                 ,QG=qg_curr                                        &
+                 ,IHAIL=hail, ICE2=ice2                             &
+                                                                    )
+! HAIL = 1,  run gsfcgce with hail option
+!        0,  run gsfcgce with graupel option   <---- default
+!        note: no effect if ice2 = 1
+! ICE2 = 1,  run gsfcgce with only snow, ice
+!        2,  run gsfcgce with only graupel, ice
+!        0,  run gsfcgce with snow, ice and hail/graupel   <---- default
+
+             ELSE
+                CALL wrf_error_fatal ( 'arguments not present for calling GSFCGCE' )
+             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                    &
+                 ,SNOWNC=snownc, SNOWNCV=snowncv                    &
+                 ,GRAUPELNC=graupelnc, GRAUPELNCV=graupelncv, 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 &
+                 ,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 (SBU_YLINSCHEME)
+             CALL wrf_debug ( 100 , 'microphysics_driver: calling sbu_ylin' )
+             IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND.  &
+                  PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND.  &
+                  PRESENT( QS_CURR )                           .AND.  &
+                  PRESENT( RI_CURR )                           .AND.  &
+                  PRESENT( RAINNC  ) .AND. PRESENT ( RAINNCV ) .AND.  &
+                  PRESENT( Z       ) ) THEN
+               CALL sbu_ylin(                                       &
+                  TH=th                                             &
+                 ,QV=qv_curr                                        &
+                 ,QL=qc_curr                                        &
+                 ,QR=qr_curr                                        &
+                 ,QI=qi_curr                                        &
+                 ,QS=qs_curr                                        &
+                 ,RI3D=ri_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                    &
+!                 ,SNOWNC=snownc, SNOWNCV=snowncv                    &
+!                 ,GRAUPELNC=graupelnc, GRAUPELNCV=graupelncv, 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 &
+!                 ,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 sbu_ylin' )
+             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 (WDM5SCHEME)
+             CALL wrf_debug ( 100 , 'microphysics_driver: calling wdm5' )
+             IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR ) .AND.  &
+                  PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND.  &
+                  PRESENT( QS_CURR ) .AND. PRESENT( QNN_CURR ) .AND.  &
+                  PRESENT ( QNC_CURR ) .AND. PRESENT( QNR_CURR ).AND.  &
+                  PRESENT( RAINNC  ) .AND. PRESENT ( RAINNCV )  ) THEN
+             CALL wdm5(                                             &
+                  TH=th                                             &
+                 ,Q=qv_curr                                         &
+                 ,QC=qc_curr                                        &
+                 ,QR=qr_curr                                        &
+                 ,QI=qi_curr                                        &
+                 ,QS=qs_curr                                        &
+                 ,NN=qnn_curr                                       &
+                 ,NC=qnc_curr                                       &
+                 ,NR=qnr_curr                                       &
+                 ,DEN=rho,PII=pi_phy,P=p,DELZ=dz8w                  &
+                 ,DELT=dt,G=g,CPD=cp,CPV=cpv,CCN0=n_ccn0            &
+                 ,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                                             &
+                 ,ITIMESTEP=itimestep                               & 
+                 ,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 wdm5')
+             ENDIF
+
+       CASE (WDM6SCHEME)
+             CALL wrf_debug ( 100 , 'microphysics_driver: calling wdm6' )
+             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( QNN_CURR ) .AND. PRESENT ( QNC_CURR ) .AND. &
+                  PRESENT( QNR_CURR ).AND.                            &
+                 PRESENT( RAINNC  ) .AND. PRESENT ( RAINNCV )  ) THEN
+             CALL wdm6(                                             &
+                  TH=th                                             &
+                 ,Q=qv_curr                                         &
+                 ,QC=qc_curr                                        &
+                 ,QR=qr_curr                                        &
+                 ,QI=qi_curr                                        &
+                 ,QS=qs_curr                                        &
+                 ,QG=qg_curr                                        &
+                 ,NN=qnn_curr                                       &
+                 ,NC=qnc_curr                                       &
+                 ,NR=qnr_curr                                       &
+                 ,DEN=rho,PII=pi_phy,P=p,DELZ=dz8w                  &
+                 ,DELT=dt,G=g,CPD=cp,CPV=cpv,CCN0=n_ccn0            &
+                 ,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          &
+                 ,ITIMESTEP=itimestep                               & 
+                 ,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 wdm6')
+             ENDIF
+#if(NMM_CORE==1)
+        CASE (ETAMP_HWRF)
+             CALL wrf_debug ( 100 , 'microphysics_driver: calling etampnew_HWRF')
+
+             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_HWRF(                                      &
+                  ITIMESTEP=itimestep,DT=dt,DX=dx,DY=dy, GID=id &
+                 ,RAINNC=rainnc,RAINNCV=rainncv                     &
+                 ,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,PI_PHY=pi_phy,TH_PHY=th &
+                 ,QV=qv_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                           &
+                 ,QC=qc_curr,QR=Qr_curr,QI=Qi_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 &
+                                                                    )
+             ELSE
+                CALL wrf_error_fatal ( 'arguments not present for calling etampnew' )
+             ENDIF
+#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 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
+#ifndef RUN_ON_GPU
+   !$OMP END PARALLEL DO
+#endif
+
+   CALL wrf_debug ( 200 , 'microphysics_driver: returning from' )
+
+   RETURN
+
+   END SUBROUTINE microphysics_driver
+
+END MODULE module_microphysics_driver
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_microphysics_zero_out.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_microphysics_zero_out.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_microphysics_zero_out.F	(revision 17)
@@ -0,0 +1,155 @@
+!WRF:MEDIATION_LAYER:PHYSICS
+!
+MODULE module_microphysics_zero_out
+CONTAINS
+
+SUBROUTINE microphysics_zero_outa (                                      &
+                       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
+END SUBROUTINE microphysics_zero_outa
+
+SUBROUTINE microphysics_zero_outb (                                      &
+                       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
+
+   ! 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_outb
+
+END MODULE module_microphysics_zero_out
+
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mixactivate.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mixactivate.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mixactivate.F	(revision 17)
@@ -0,0 +1,2743 @@
+!************************************************************************
+! 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 chem/module_mosaic_driver.F for references and terms
+! of use
+!************************************************************************
+
+MODULE module_mixactivate
+PRIVATE
+PUBLIC prescribe_aerosol_mixactivate, 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,                                              &
+		ids,ide, jds,jde, kds,kde,                            &
+		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,                  &
+		ids, ide, jds, jde, kds, kde,   &
+		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),    & ! median diameter (cm) of number distrib of mode
+	     dens_aer( maxd_acomp, maxd_atype),    & ! density (g/cm3) of material
+	     mw_aer( maxd_acomp, maxd_atype),      & ! molecular weight (g/mole)
+	     dpvolmean_aer(maxd_asize, maxd_atype)   ! mean-volume diameter (cm) of mode
+! terminology:  (pi/6) * (mean-volume diameter)**3 ==
+!       (volume mixing ratio of section/mode)/(number mixing ratio)
+	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(its:ite,kts:kte,jts:jte)=th_phy(its:ite,kts:kte,jts:jte)*pi_phy(its:ite,kts:kte,jts:jte)
+
+      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       ! median diameter (cm) of number distrib of mode
+	  dpvolmean_aer(m,n) = dgnum_aer(m,n) * exp( 1.5 * (log(sigmag_aer(m,n)))**2 )
+	  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(its:ite,kts:kte,jts:jte,ptr)=naer
+	  else
+	     chem(its:ite,kts:kte,jts:jte,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 wrf_error_fatal("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(its:ite,kts:kte,jts:jte,ptr)=maer
+	     else
+	        chem(its:ite,kts:kte,jts:jte,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 wrf_error_fatal("1")
+	  endif
+!wig	  waterptr_aer(m, n)=ptr
+	  waterptr_aer(m, n)=-1
+	end do ! size
+	end do ! type
+	ddvel(its:ite,jts:jte,:)=0.
+    hygro(its:ite,kts:kte,jts:jte,:,:) = 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, dpvolmean_aer,  &
+            dens_aer, mw_aer,           &
+            waterptr_aer, hygro,  ai_phase, cw_phase,                &
+            ids,ide, jds,jde, kds,kde,                            &
+            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, dpvolmean_aer,  &
+           dens_aer, mw_aer,               &
+           waterptr_aer, hygro, ai_phase, cw_phase,              &
+           ids,ide, jds,jde, kds,kde,                            &
+           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) ::         ids,ide, jds,jde, kds,kde,    &
+                                 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
+       dens_aer( maxd_acomp, maxd_atype),    & ! density (g/cm3) of material
+       mw_aer( maxd_acomp, maxd_atype),      & ! molecular weight (g/mole)
+       dpvolmean_aer(maxd_asize, maxd_atype)   ! mean-volume diameter (cm) of mode
+! terminology:  (pi/6) * (mean-volume diameter)**3 ==
+!       (volume mixing ratio of section/mode)/(number mixing ratio)
+
+
+  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 :: dgnum_aer(maxd_asize, maxd_atype) ! median diameter (cm) of number distrib of mode
+  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, parameter :: zkmin = 0.01
+  real, parameter :: zkmax = 100.
+  real cs(kms:kme)             ! air density (kg/m3) at layer center
+  real csbot(kms:kme)          ! air density (kg/m3) at layer bottom
+  real csbot_cscen(kms:kme)    ! csbot(k)/cs(k)
+  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, parameter :: sq2pi = 2.5066282746
+  real dtinv
+
+  integer km1,kp1
+  real wbar,wmix,wmin,wmax
+  real dum
+  real tmpa, tmpb, tmpc, tmpc1, tmpc2, tmpd, tmpe, tmpf
+  real tmpcourno
+  real dact
+  real fluxntot         ! (#/cm2/s)
+  real fac_srflx
+  real depvel_drop, depvel_tmp
+  real, parameter :: depvel_uplimit = 1.0 ! upper limit for dep vels (m/s)
+  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, save :: count_submix(100)=0 ! wig: Note that this is a no-no for tile threads with OMP
+
+  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)
+  real ::   flux_fullact(kms:kme)              ! 100%    activation fraction flux (m/s)
+!     note:  activation fraction fluxes are defined as
+!     fluxn = [flux of activated aero. number into cloud (#/m2/s)]
+!           / [aero. number conc. in updraft, just below cloudbase (#/m3)]
+
+  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, 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, parameter :: surften = 0.076 ! surface tension of water w/respect to air (N/m)
+  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
+
+  integer,parameter :: icheck_colmass = 0
+           ! icheck_colmass > 0 turns on mass/number conservation checking
+           ! values of 1, 10, 100 produce less to more diagnostics
+  integer :: colmass_worst_ij( 2, 0:maxd_acomp, maxd_asize, maxd_atype )
+  integer :: colmass_maxworst_i(3)
+  real :: colmass_bgn( 0:maxd_acomp, maxd_asize, maxd_atype, maxd_aphase )
+  real :: colmass_end( 0:maxd_acomp, maxd_asize, maxd_atype, maxd_aphase )
+  real :: colmass_sfc( 0:maxd_acomp, maxd_asize, maxd_atype, maxd_aphase )
+  real :: colmass_worst( 0:maxd_acomp, maxd_asize, maxd_atype )
+  real :: colmass_maxworst_r
+  real :: rhodz( kts:kte ), rhodzsum
+
+!!$#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'/)
+
+
+  colmass_worst(:,:,:) = 0.0
+  colmass_worst_ij(:,:,:,:) = -1
+
+
+  arg = 1.0
+  if (abs(0.8427-ERF_ALT(arg))/0.8427>0.001) then
+     write (6,*) 'erf_alt(1.0) = ',ERF_ALT(arg)
+     call wrf_error_fatal('dropmixnuc: Error function error')
+  endif
+  arg = 0.0
+  if (ERF_ALT(arg) /= 0.0) then
+     write (6,*) 'erf_alt(0.0) = ',ERF_ALT(arg)
+     call wrf_error_fatal('dropmixnuc: Error function error')
+  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
+  depvel_drop =  min(depvel_drop,depvel_uplimit)
+
+  do n=1,ntype_aer
+     do m=1,nsize_aer(n)
+        ncomp(n)=ncomp_aer(n)
+        alogsig(m,n)=alog(sigmag_aer(m,n))
+        dgnum_aer(m,n) = dpvolmean_aer(m,n) * exp( -1.5*alogsig(m,n)*alogsig(m,n) )
+!    print *,'sigmag_aer,dgnum_aer=',sigmag_aer(m,n),dgnum_aer(m,n)
+        ! npv is 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.15   !wig, 1-Mar-2009: Added .15
+  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(its:ite,jts:jte,:) = 0.
+
+!     start loop over columns
+
+OVERALL_MAIN_J_LOOP: do j=jts,jte
+OVERALL_MAIN_I_LOOP: do i=its,ite
+
+!        load number nucleated into qndrop on cloud boundaries
+
+! initialization for current i .........................................
+
+     do k=kts+1,kte
+	    zs(k)=1./(zm(i,k,j)-zm(i,k-1,j))
+	 enddo
+	 zs(kts)=zs(kts+1)
+     zs(kte+1)=0.
+
+     do k=kts,kte
+!!$	    if(qndrop3d(i,k,j).lt.-10.e6.or.qndrop3d(i,k,j).gt.1.E20)then
+!!$!	       call wrf_error_fatal("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 wrf_error_fatal("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
+     nsource(i,kte+1,j) = 0.
+     qndrop(kte+1)      = 0.
+     zn(kte+1)          = 0.
+
+     do k = kts+1, kte
+        tmpa = dz(k-1) ; tmpb = dz(k)
+        tmpc = tmpa/(tmpa + tmpb)
+        csbot(k) = cs(k-1)*(1.0-tmpc) + cs(k)*tmpc
+        csbot_cscen(k) = csbot(k)/cs(k)
+     end do
+     csbot(kts) = cs(kts)
+     csbot_cscen(kts) = 1.0
+     csbot(kte+1) = cs(kte)
+     csbot_cscen(kte+1) = 1.0
+
+    !  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
+              depvel_tmp = max( 0.0, min( ddvel(i,j,lnum), depvel_uplimit ) )
+              surfrate(lnum)=depvel_tmp/dz(kts)
+              surfrate(lnumcw)=surfrate_drop
+              surfratemax = max( surfratemax, surfrate(lnum) )
+!             scale = 1000./mwdry ! moles/kg
+              scale = 1.
+              raercol(kts:kte,lnumcw,nsav)=chem(i,kts:kte,j,lnumcw)*scale ! #/kg
+              raercol(kts:kte,lnum,nsav)=chem(i,kts:kte,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
+              depvel_tmp = max( 0.0, min( ddvel(i,j,lmass), depvel_uplimit ) )
+              surfrate(lmass)=depvel_tmp/dz(kts)
+              surfrate(lmasscw)=surfrate_drop
+              surfratemax = max( surfratemax, surfrate(lmass) )
+              raercol(kts:kte,lmasscw,nsav)=chem(i,kts:kte,j,lmasscw)*scale ! kg/kg
+              raercol(kts:kte,lmass,nsav)=chem(i,kts:kte,j,lmass)*scale ! kg/kg
+           enddo
+           lwater=waterptr_aer(m,n)
+           if(lwater>0)then
+              depvel_tmp = max( 0.0, min( ddvel(i,j,lwater), depvel_uplimit ) )
+              surfrate(lwater)=depvel_tmp/dz(kts)
+              surfratemax = max( surfratemax, surfrate(lwater) )
+              raercol(kts:kte,lwater,nsav)=chem(i,kts:kte,j,lwater) ! don't bother to convert units,
+             ! because it doesn't contribute to aerosol mass
+           endif
+        enddo ! size
+     enddo ! type
+
+
+! mass conservation checking
+     if (icheck_colmass > 0) then
+
+! calc initial column burdens
+        colmass_bgn(:,:,:,:) = 0.0
+        colmass_end(:,:,:,:) = 0.0
+        colmass_sfc(:,:,:,:) = 0.0
+        rhodz(kts:kte) = 1.0/zn(kts:kte)
+        rhodzsum = sum( rhodz(kts:kte) )
+        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
+                 colmass_bgn(0,m,n,1) = sum( chem(i,kts:kte,j,lnum  )*rhodz(kts:kte) )
+                 colmass_bgn(0,m,n,2) = sum( chem(i,kts:kte,j,lnumcw)*rhodz(kts:kte) )
+              endif
+              do l=1,ncomp(n)
+                 lmass=massptr_aer(l,m,n,ai_phase)
+                 lmasscw=massptr_aer(l,m,n,cw_phase)
+                 colmass_bgn(l,m,n,1) = sum( chem(i,kts:kte,j,lmass  )*rhodz(kts:kte) )
+                 colmass_bgn(l,m,n,2) = sum( chem(i,kts:kte,j,lmasscw)*rhodz(kts:kte) )
+              enddo
+           enddo ! size
+        enddo ! type
+     endif ! (icheck_colmass > 0)
+
+
+!        droplet nucleation/aerosol activation
+
+! k-loop for growing/shrinking cloud calcs .............................
+GROW_SHRINK_MAIN_K_LOOP: do k=kts,kte
+        km1=max0(k-1,1)
+        kp1=min0(k+1,kde-1)
+
+
+!       if(lcldfra(k)-lcldfra_old(k).gt.0.01)then   ! this line is the "old" criterion
+!       go to 10
+
+!       growing cloud PLUS
+!       upwards vertical advection when lcldfra(k-1) < lcldfra(k)
+!
+! tmpc1 = cloud fraction increase from previous time step
+        tmpc1 = max( (lcldfra(k)-lcldfra_old(k)), 0.0 )
+        if (k > kts) then
+! tmpc2 = fraction of layer for which vertical advection from below
+!             (over dtstep) displaces cloudy air with clear air
+!       = (courant number using upwards w at layer bottom)*(difference in cloud fraction)
+           tmpcourno = dtstep*max(w(i,k,j),0.0)/dz(k)
+           tmpc2 = max( (lcldfra(k)-lcldfra(km1)), 0.0 ) * tmpcourno
+           tmpc2 = min( tmpc2, 1.0 )
+!          tmpc2 = 0.0   ! this turns off the vertical advect part
+        else
+           tmpc2 = 0.0
+        endif
+
+        if ((tmpc1 > 0.001) .or. (tmpc2 > 0.001)) then
+
+!                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,flux_fullact(k), grid_id, ktau, i, j, 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)
+                 if (tmpc1 > 0.0) then
+                    dact = tmpc1*fn(m,n)*raercol(k,lnum,nsav) ! interstitial only
+                 else
+                    dact = 0.0
+                 endif
+                 if (tmpc2 > 0.0) then
+                    dact = dact + tmpc2*fn(m,n)*raercol(km1,lnum,nsav) ! interstitial only
+                 endif
+                 dact = min( dact, 0.99*raercol(k,lnum,nsav) )
+                 raercol(k,lnumcw,nsav) = raercol(k,lnumcw,nsav)+dact
+                 raercol(k,lnum,  nsav) = raercol(k,lnum,  nsav)-dact
+                 qndrop(k) = qndrop(k)+dact
+                 nsource(i,k,j) = nsource(i,k,j)+dact*dtinv
+                 do l = 1,ncomp(n)
+                    lmass   = massptr_aer(l,m,n,ai_phase)
+                    lmasscw = massptr_aer(l,m,n,cw_phase)
+                    if (tmpc1 > 0.0) then
+                       dact = tmpc1*fm(m,n)*raercol(k,lmass,nsav) ! interstitial only
+                    else
+                       dact = 0.0
+                    endif
+                    if (tmpc2 > 0.0) then
+                       dact = dact + tmpc2*fm(m,n)*raercol(km1,lmass,nsav) ! interstitial only
+                    endif
+                    dact = min( dact, 0.99*raercol(k,lmass,nsav) )
+                    raercol(k,lmasscw,nsav)  =  raercol(k,lmasscw,nsav)+dact
+                    raercol(k,lmass,  nsav)  =  raercol(k,lmass,  nsav)-dact
+                 enddo
+              enddo
+           enddo
+!   10 continue
+        endif   ! ((tmpc1 > 0.001) .or. (tmpc2 > 0.001))
+
+
+        if(lcldfra(k) < lcldfra_old(k) .and. lcldfra_old(k) > 1.e-20)then   ! this line is the "old" criterion
+!         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
+
+           tmpc = (lcldfra(k)-lcldfra_old(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)
+                 if(lnum.gt.0)then
+                    dact=raercol(k,lnumcw,nsav)*tmpc
+                    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)*tmpc
+                    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 GROW_SHRINK_MAIN_K_LOOP
+! end of k-loop for growing/shrinking cloud calcs ......................
+
+
+
+! ......................................................................
+! start of main k-loop for calc of old cloud activation tendencies ..........
+! this loop does "set up" for the nsubmix loop
+!
+! rce-comment
+!    changed this part of code to use current cloud fraction (lcldfra) exclusively
+
+OLD_CLOUD_MAIN_K_LOOP: do k=kts,kte
+        km1=max0(k-1,kts)
+        kp1=min0(k+1,kde-1)
+        flux_fullact(k) = 0.0
+        if(lcldfra(k).gt.0.01)then
+!          go to 30
+
+!               old cloud
+              if(lcldfra(k)-lcldfra(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.
+                 ekd(k)=wtke(k)*dz(k)/sq2pi
+                 alogarg=max(1.e-20,1/lcldfra(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,flux_fullact(k), grid_id, ktau, i, j, k )
+                 
+! rce-comment
+!    the activation-fraction fluxes (fluxn, fluxm) from subr activate assume that
+!       wbar << wmix, which is valid for global-model scale but not mesoscale
+!    for wrf-chem application, divide these by flux_fullact to get a 
+!       "flux-weighted-average" activation fraction, then multiply by (ekd(k)*zs(k)) 
+!       which is the local "turbulent vertical-mixing velocity"
+                 if (k > kts) then
+                    if (flux_fullact(k) > 1.0e-20) then
+                       tmpa = ekd(k)*zs(k)
+                       tmpf = flux_fullact(k)
+                       do n=1,ntype_aer
+                       do m=1,nsize_aer(n)
+                          tmpb = max( fluxn(m,n), 0.0 ) / max( fluxn(m,n), tmpf )
+                          fluxn(m,n) = tmpa*tmpb
+                          tmpb = max( fluxm(m,n), 0.0 ) / max( fluxm(m,n), tmpf )
+                          fluxm(m,n) = tmpa*tmpb
+                       enddo
+                       enddo
+                    else
+                       fluxn(:,:) = 0.0
+                       fluxm(:,:) = 0.0
+                    endif
+                 endif
+
+                 if(k.gt.kts)then
+                    tmpc = lcldfra(k)-lcldfra(km1)
+                 else
+                    tmpc=lcldfra(k)
+                 endif
+! rce-comment
+!    flux of activated mass into layer k (in kg/m2/s)
+!       = "actmassflux" = dumc*fluxm*raercol(kp1,lmass)*csbot(k)
+!    source of activated mass (in kg/kg/s) = flux divergence
+!       = actmassflux/(cs(i,k)*dz(i,k))
+!    so need factor of csbot_cscen = csbot(k)/cs(i,k)
+!                tmpe=1./(dz(k))
+                 tmpe = csbot_cscen(k)/(dz(k))
+                 fluxntot=0.
+                 do n=1,ntype_aer
+                 do m=1,nsize_aer(n)
+                    fluxn(m,n)=fluxn(m,n)*tmpc
+!                   fluxs(m,n)=fluxs(m,n)*tmpc
+                    fluxm(m,n)=fluxm(m,n)*tmpc
+                    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 tmpc=',tmpc,' fn=',fn(m,n),' for m,n=',m,n
+                    nact(k,m,n)=nact(k,m,n)+fluxn(m,n)*tmpe
+                    mact(k,m,n)=mact(k,m,n)+fluxm(m,n)*tmpe
+                 enddo
+                 enddo
+                 flux_fullact(k) = flux_fullact(k)*tmpe
+                 nsource(i,k,j)=nsource(i,k,j)+fluxntot*zs(k)
+                 fluxntot=fluxntot*cs(k)
+              endif
+!       30 continue
+
+        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 OLD_CLOUD_MAIN_K_LOOP
+
+!    cycle OVERALL_MAIN_I_LOOP
+
+
+!    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
+! rce-comment -- ekd(k) is eddy-diffusivity at k/k-1 interface
+!   want ekk(k) = ekd(k) * (density at k/k-1 interface)
+     do k=kts+1,kte
+        ekk(k)=ekd(k)*csbot(k)
+     enddo
+     ekk(kte+1)=0.0
+     do k=kts,kte
+        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
+        kp1=min(k+1,kde-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
+
+
+
+! ......................................................................
+! start of nsubmix-loop for calc of old cloud activation tendencies ....
+OLD_CLOUD_NSUBMIX_LOOP: do nsub=1,nsubmix
+        qndrop_new(kts:kte)=qndrop(kts:kte)
+!           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
+! rce-comment - activation source in layer k involves particles from k-1
+!             srcn(kts  :kte)=srcn(kts  :kte)+nact(kts  :kte,m,n)*(raercol(kts:kte  ,lnum,nsav))
+              srcn(kts+1:kte)=srcn(kts+1:kte)+nact(kts+1:kte,m,n)*(raercol(kts:kte-1,lnum,nsav))
+! rce-comment - new formulation for k=kts should be implemented
+              srcn(kts      )=srcn(kts      )+nact(kts      ,m,n)*(raercol(kts      ,lnum,nsav))
+           enddo
+        enddo
+        call explmix(qndrop,srcn,ekkp,ekkm,overlapp,overlapm,   &
+             qndrop_new,surfrate_drop,kms,kme,kts,kte,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
+! rce-comment - activation source in layer k involves particles from k-1
+!                source(kts  :kte)= nact(kts  :kte,m,n)*(raercol(kts:kte  ,lnum,nsav))
+                 source(kts+1:kte)= nact(kts+1:kte,m,n)*(raercol(kts:kte-1,lnum,nsav))
+! rce-comment - new formulation for k=kts should be implemented
+                 source(kts      )= nact(kts      ,m,n)*(raercol(kts      ,lnum,nsav))
+                 call explmix(raercol(1,lnumcw,nnew),source,ekkp,ekkm,overlapp,overlapm, &
+                      raercol(1,lnumcw,nsav),surfrate(lnumcw),kms,kme,kts,kte,dtmix,&
+                      .false.)
+                 call explmix(raercol(1,lnum,nnew),source,ekkp,ekkm,overlapp,overlapm,  &
+                      raercol(1,lnum,nsav),surfrate(lnum),kms,kme,kts,kte,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)
+                 if (icheck_colmass > 0) then
+                    tmpf = dtmix*rhodz(kts)
+                    colmass_sfc(0,m,n,1) = colmass_sfc(0,m,n,1) &
+                          + raercol(kts,lnum  ,nsav)*surfrate(lnum  )*tmpf
+                    colmass_sfc(0,m,n,2) = colmass_sfc(0,m,n,2) &
+                          + raercol(kts,lnumcw,nsav)*surfrate(lnumcw)*tmpf
+                 endif
+              endif
+              do l=1,ncomp(n)
+                 lmass=massptr_aer(l,m,n,ai_phase)
+                 lmasscw=massptr_aer(l,m,n,cw_phase)
+! rce-comment - activation source in layer k involves particles from k-1
+!                source(kts  :kte)= mact(kts  :kte,m,n)*(raercol(kts:kte  ,lmass,nsav))
+                 source(kts+1:kte)= mact(kts+1:kte,m,n)*(raercol(kts:kte-1,lmass,nsav))
+! rce-comment - new formulation for k=kts should be implemented
+                 source(kts      )= mact(kts      ,m,n)*(raercol(kts      ,lmass,nsav))
+                 call explmix(raercol(1,lmasscw,nnew),source,ekkp,ekkm,overlapp,overlapm, &
+                      raercol(1,lmasscw,nsav),surfrate(lmasscw),kms,kme,kts,kte,dtmix,  &
+                      .false.)
+                 call explmix(raercol(1,lmass,nnew),source,ekkp,ekkm,overlapp,overlapm,  &
+                      raercol(1,lmass,nsav),surfrate(lmass),kms,kme,kts,kte,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)
+                 if (icheck_colmass > 0) then
+                    ! colmass_sfc calculation
+                    !    colmass_bgn/end = bgn/end column burden = sum.over.k.of{ rho(k)*dz(k)*chem(k,l) }
+                    !    colmass_sfc = surface loss over dtstep
+                    !       = sum.over.nsubmix.substeps{ depvel(l)*rho(kts)*chem(kts,l)*dtmix }
+                    !    surfrate(l) = depvel(l)/dz(kts) so need to multiply by dz(kts)
+                    !    for mass, raercol(k,l) = chem(k,l)*1.0e-9, so need to multiply by 1.0e9
+                    tmpf = dtmix*rhodz(kts)*1.0e9
+                    colmass_sfc(l,m,n,1) = colmass_sfc(l,m,n,1) &
+                          + raercol(kts,lmass  ,nsav)*surfrate(lmass  )*tmpf
+                    colmass_sfc(l,m,n,2) = colmass_sfc(l,m,n,2) &
+                          + raercol(kts,lmasscw,nsav)*surfrate(lmasscw)*tmpf
+                 endif
+              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),kms,kme,kts,kte,dtmix,  &
+                      .true.,source)
+              endif
+           enddo ! size
+        enddo ! type
+
+     enddo OLD_CLOUD_NSUBMIX_LOOP
+
+!    cycle OVERALL_MAIN_I_LOOP
+
+!        evaporate particles again if no cloud
+
+     do k=kts,kte
+        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
+
+!         cycle OVERALL_MAIN_I_LOOP
+
+!        droplet number
+
+     do k=kts,kte
+!       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
+        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 qndrop3d=',qndrop3d(i,k,j),' for i,k,j=',i,k,j
+        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 wrf_error_fatal("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 wrf_error_fatal("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 wrf_error_fatal("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
+
+!    cycle OVERALL_MAIN_I_LOOP
+
+!        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,j,lnumcw)= raercol(kts:kte,lnumcw,nnew)*scale
+              chem(i,kts:kte,j,lnum)= raercol(kts:kte,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,j,lmasscw)=raercol(kts:kte,lmasscw,nnew)*scale ! ug/kg
+              chem(i,kts:kte,j,lmass)=raercol(kts:kte,lmass,nnew)*scale ! ug/kg
+           enddo
+           lwater=waterptr_aer(m,n)
+           if(lwater>0)chem(i,kts:kte,j,lwater)=raercol(kts:kte,lwater,nnew) ! don't convert units
+           do k=kts,kte
+              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
+
+! mass conservation checking
+     if (icheck_colmass > 0) then
+! calc final column burdens
+        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
+              colmass_end(0,m,n,1) = sum( chem(i,kts:kte,j,lnum  )*rhodz(kts:kte) )
+              colmass_end(0,m,n,2) = sum( chem(i,kts:kte,j,lnumcw)*rhodz(kts:kte) )
+           endif
+           do l=1,ncomp(n)
+              lmass=massptr_aer(l,m,n,ai_phase)
+              lmasscw=massptr_aer(l,m,n,cw_phase)
+              colmass_end(l,m,n,1) = sum( chem(i,kts:kte,j,lmass  )*rhodz(kts:kte) )
+              colmass_end(l,m,n,2) = sum( chem(i,kts:kte,j,lmasscw)*rhodz(kts:kte) )
+           enddo
+        enddo ! size
+        enddo ! type
+! calc burden change errors for each interstitial/activated pair
+        do n=1,ntype_aer
+        do m=1,nsize_aer(n)
+           do l=0,ncomp(n)
+              ! tmpa & tmpb = beginning & ending column burden divided by rhodzsum,
+              !             = beginning & ending column-mean mixing ratios
+              ! tmpc = loss to surface divided by rhodzsum,
+              tmpa = ( colmass_bgn(l,m,n,1) + colmass_bgn(l,m,n,2) )/rhodzsum
+              tmpb = ( colmass_end(l,m,n,1) + colmass_end(l,m,n,2) )/rhodzsum
+              tmpc = ( colmass_sfc(l,m,n,1) + colmass_sfc(l,m,n,2) )/rhodzsum
+
+              ! tmpd = ((final burden) + (sfc loss)) - (initial burden)
+              !      = burden change error
+              tmpd = (tmpb + tmpc) - tmpa
+              tmpe = max( tmpa, 1.0e-20 )
+
+              ! tmpf = (burden change error) / (initial burden)
+              if (abs(tmpd) < 1.0e5*tmpe) then
+                 tmpf = tmpd/tmpe
+              else if (tmpf < 0.0) then
+                 tmpf = -1.0e5
+              else
+                 tmpf = 1.0e5
+              end if
+              if (abs(tmpf) > abs(colmass_worst(l,m,n))) then
+                 colmass_worst(l,m,n) = tmpf
+                 colmass_worst_ij(1,l,m,n) = i
+                 colmass_worst_ij(2,l,m,n) = j
+              endif
+           enddo
+        enddo ! size
+        enddo ! type
+     endif ! (icheck_colmass > 0)
+
+
+     enddo OVERALL_MAIN_I_LOOP ! end of main loop over i
+     enddo OVERALL_MAIN_J_LOOP ! end of main loop over j
+
+
+! mass conservation checking
+     if (icheck_colmass > 0) then
+        if (icheck_colmass >= 100) write(*,'(a)') &
+             'mixactivate colmass worst errors bgn - type, size, comp, err, i, j'
+        colmass_maxworst_r = 0.0
+        colmass_maxworst_i(:) = -1
+        do n=1,ntype_aer
+        do m=1,nsize_aer(n)
+           do l=0,ncomp(n)
+              if (icheck_colmass >= 100) &
+                 write(*,'(3i3,1p,e10.2,2i4)') n, m, l, &
+                 colmass_worst(l,m,n), colmass_worst_ij(1:2,l,m,n) 
+              if (abs(colmass_worst(l,m,n)) > abs(colmass_maxworst_r)) then
+                 colmass_maxworst_r = colmass_worst(l,m,n) 
+                 colmass_maxworst_i(1) = n
+                 colmass_maxworst_i(2) = m
+                 colmass_maxworst_i(3) = l
+              end if
+           enddo
+        enddo ! size
+        enddo ! type
+        if ((icheck_colmass >= 10) .or. (abs(colmass_maxworst_r) >= 1.0e-6)) &
+             write(*,'(a,3i3,1p,e10.2)') 'mixactivate colmass maxworst', &
+             colmass_maxworst_i(1:3), colmass_maxworst_r
+     endif ! (icheck_colmass > 0)
+
+
+     return
+   end subroutine mixactivate
+
+
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+   subroutine explmix( q, src, ekkp, ekkm, overlapp, overlapm, &
+                       qold, surfrate, kms, kme, kts, kte, dt, &
+                       is_unact, qactold )
+
+!  explicit integration of droplet/aerosol mixing
+!     with source due to activation/nucleation
+
+
+   implicit none
+   integer, intent(in) :: kms,kme ! number of levels for array definition
+   integer, intent(in) :: kts,kte ! number of levels for looping
+   real, intent(inout) :: q(kms:kme) ! mixing ratio to be updated
+   real, intent(in) :: qold(kms:kme) ! mixing ratio from previous time step
+   real, intent(in) :: src(kms:kme) ! source due to activation/nucleation (/s)
+   real, intent(in) :: ekkp(kms:kme) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface
+                      ! below layer k  (k,k+1 interface)
+   real, intent(in) :: ekkm(kms:kme) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface
+                      ! above layer k  (k,k+1 interface)
+   real, intent(in) :: overlapp(kms:kme) ! cloud overlap below
+   real, intent(in) :: overlapm(kms:kme) ! 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(kms:kme)
+          ! 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
+
+!  dry deposition 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, flux_fullact, &
+                      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 aerosol mode.
+!      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)
+      real,intent(inout) :: flux_fullact                 ! flux when activation fraction = 100% (m/s)
+
+!      local
+
+!!$      external erf,erfc
+!!$      real erf,erfc
+!      external qsat_water
+      integer, parameter:: nx=200
+      integer iquasisect_option, isectional
+      real integ,integf
+      real, parameter :: surften = 0.076 ! surface tension of water w/respect to air (N/m)
+      real, parameter :: p0 = 1013.25e2  ! reference pressure (Pa)
+      real, parameter :: t0 = 273.15     ! reference temperature (K)
+      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 f1(maxd_asize,maxd_atype) ! array to hold parameter for maxsat
+      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
+      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 sumflx_fullact
+      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, parameter :: eps = 0.3
+      real, parameter :: fmax = 0.99
+      real, parameter :: sds = 3.
+
+!      mathematical constants
+      real third, twothird, sixth, zero, one, two, three
+
+      real, parameter :: sq2  = 1.4142135624
+      real, parameter :: sqpi = 1.7724538509
+      real, parameter :: pi   = 3.1415926536
+
+!      integer, save :: ndist(nx)  ! accumulates frequency distribution of integration bins required
+!      data ndist/nx*0/
+
+!     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
+
+! The flag for cloud top is no longer used so set it to false. This is an
+! antiquated feature related to radiation enhancing mass fluxes at cloud
+! top. It is currently, as of Feb. 2009, set to false in the CAM version
+! as well.
+      top = .false.
+
+!.......................................................................
+!
+!   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.
+         flux_fullact=0.
+         return
+        endif
+      enddo
+
+      zero = 0.0
+      one = 1.0
+      two = 2.0
+      three = 3.0
+      third = 1.0/3.0
+      twothird = 2.0/3.0 !wig, 1-Mar-2009: Corrected value from 2/6
+      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
+            flux_fullact=0.
+            return
+         endif
+
+
+
+         if (isectional .le. 0) then
+            ! Initialize maxsat at this cell and timestep for the
+            ! modal setup (the sectional case is handled below).
+            call maxsat_init(maxd_atype, ntype_aer, &
+                 maxd_asize, nsize_aer, alnsign, f1)
+
+            goto 30000
+         end if
+
+         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
+         
+         ! Initialize maxsat at this cell and timestep for the
+         ! sectional setup (the modal case is handled above)...
+         call maxsat_init(maxd_atype, ntype_aer, &
+              maxd_asize, (/1/), gmlnsig, f1)
+
+!.......................................................................
+!   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 numerical 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
+                  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
+                  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
+            flux_fullact=0.
+            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
+         sumflx_fullact=0.
+
+         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,f1,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,f1,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
+
+!           same form as sumflxm(m,n) but replace the fm/fmold(m,n) with 1.0
+            sumflx_fullact = sumflx_fullact &
+                           + sixth*(wb*(gaus+gold) + (gaus*w + gold*wold))*dw
+!            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
+         call wrf_error_fatal("STOP: activate before 48000")
+
+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
+!           same form as sumflxm(m,n) but replace the fm(m,n) with 1.0
+            sumflx_fullact = sumflx_fullact + integf
+!            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
+             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
+!        same form as fluxm(m,n)
+         flux_fullact = sumflx_fullact/(sq2*sqpi*sigw)
+
+      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
+            flux_fullact=0.
+            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,f1,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,f1,smax)
+
+            endif
+
+            lnsmax=log(smax)
+            xmincoeff=alogaten-2.*third*(lnsmax-alog2)-alog3
+
+            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
+
+            if((top.and.wbar.lt.0.).or.(.not.top.and.wbar.gt.0.))then
+               flux_fullact = w
+            else
+               flux_fullact = 0.0
+            endif
+
+! 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,f1,smax)
+
+!      Calculates maximum supersaturation for multiple competing aerosol
+!      modes. Note that maxsat_init must be called before calling this
+!      subroutine.
+
+!      Abdul-Razzak and Ghan, A parameterization of aerosol activation.
+!      2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844.
+
+      implicit none
+
+      integer, intent(in) :: maxd_atype
+      integer, intent(in) :: ntype_aer
+      integer, intent(in) :: maxd_asize
+      integer, intent(in) :: nsize_aer(maxd_atype) ! number of size bins
+      real, intent(in) :: sm(maxd_asize,maxd_atype) ! critical supersaturation for number mode radius
+      real, intent(in) :: zeta, eta(maxd_asize,maxd_atype)
+      real, intent(in) :: alnsign(maxd_asize,maxd_atype) ! ln(sigma)
+      real, intent(in) :: f1(maxd_asize,maxd_atype)
+      real, intent(out) :: smax ! maximum supersaturation
+
+      real :: g1, g2
+      real thesum
+      integer m ! size index
+      integer n ! type index
+
+      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
+
+      thesum=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
+            thesum=thesum + &
+                 (f1(m,n)*g1+(1.+0.25*alnsign(m,n))*g2)/(sm(m,n)*sm(m,n))
+         else
+            thesum=1.e20
+         endif
+      end do
+      end do
+
+      smax=1./sqrt(thesum)
+
+      return
+      end subroutine maxsat
+
+
+
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+      subroutine maxsat_init(maxd_atype, ntype_aer, &
+           maxd_asize, nsize_aer, alnsign, f1)
+
+!     Calculates the f1 paramter needed by maxsat.
+
+!     Abdul-Razzak and Ghan, A parameterization of aerosol activation.
+!     2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844.
+
+      implicit none
+
+      integer, intent(in)  :: maxd_atype
+      integer, intent(in)  :: ntype_aer ! number of aerosol types
+      integer, intent(in)  :: maxd_asize
+      integer, intent(in)  :: nsize_aer(maxd_atype) ! number of size bins
+      real,    intent(in)  :: alnsign(maxd_asize,maxd_atype) ! ln(sigma)
+      real,    intent(out) :: f1(maxd_asize,maxd_atype)
+
+      integer m ! size index
+      integer n ! type index
+
+!  calculate and save f1(sigma), assumes sigma is invariant
+!  between calls to this init routine
+
+      do n=1,ntype_aer
+         do m=1,nsize_aer(n)
+            f1(m,n)=0.5*exp(2.5*alnsign(m,n)*alnsign(m,n))
+         end do
+      end do
+
+      end subroutine maxsat_init
+
+
+
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+! 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, intent(in) ::  num_chem ! maximum number of consituents
+       integer, intent(in) ::  k,kmn,kmx
+       real,    intent(in) ::  chem(kmn:kmx,num_chem) ! aerosol mass, number mixing ratios
+       real,    intent(in) ::  cs  ! air density (kg/m3)
+       real,    intent(in) ::  npv ! number per volume concentration (/m3)
+       integer, intent(in) ::  maxd_acomp,ncomp
+       integer, intent(in) ::  numptr_aer,numptrcw_aer
+       integer, intent(in) ::  massptr_aer(maxd_acomp), massptrcw_aer(maxd_acomp)
+       real,    intent(in) ::  dens_aer(maxd_acomp) ! aerosol material density (g/cm3)
+       real,    intent(in) ::  dlo_sect,dhi_sect ! minimum, maximum diameter of section (cm)
+       integer, intent(in) ::  grid_id, ktau, i, j, isize, itype
+
+!      output
+
+       real, intent(out) ::  naerosol                ! interstitial number conc (/m3)
+       real, intent(out) ::  naerosolcw              ! activated    number conc (/m3)
+       real, intent(out) ::  maerosol(maxd_acomp)   ! interstitial mass conc (kg/m3)
+       real, intent(out) ::  maerosolcw(maxd_acomp) ! activated    mass conc (kg/m3)
+       real, intent(out) ::  maerosol_tot   ! total-over-species interstitial mass conc (kg/m3)
+       real, intent(out) ::  maerosol_totcw ! total-over-species activated    mass conc (kg/m3)
+       real, intent(out) ::  vaerosol       ! interstitial volume conc (m3/m3)
+       real, intent(out) ::  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, parameter :: pi = 3.1415926526
+       real specvol ! inverse aerosol material density (m3/kg)
+
+          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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_HWRF.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_HWRF.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_HWRF.F	(revision 17)
@@ -0,0 +1,2629 @@
+!WRF:MODEL_MP:PHYSICS
+!
+MODULE module_mp_HWRF
+!-----------------------------------------------------------------------
+!-- The following changes were made on 24 July 2006.
+!   (1) All known version 2.1 dependencies were removed from the 
+!       operational WRF NMM model code (search for "!HWRF")
+!   (2) Incorporated code changes from the GFDL model (search for "!GFDL")
+!-----------------------------------------------------------------------
+      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
+        REAL:: WC
+!
+! ======================================================================
+!--- Important tunable parameters that are exported to other modules
+!GFDL * RHgrd - generic reference to the threshold relative humidity for 
+!GFDL           the onset of condensation
+!GFDL (new) * RHgrd_in  - "RHgrd" for the inner domain
+!GFDL (new) * RHgrd_out - "RHgrd" for the outer domain
+!  * 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
+!  * PRINT_diag - for extended model diagnostics (code currently commented out)
+!  * PRINT_err - for run-time prints when water budgets are not conserved (for debugging)
+! ======================================================================
+      REAL, PUBLIC,PARAMETER ::                                         &
+!     &  RHgrd=1.                                                        &
+     &  RHgrd_in=1.                                                     &  !GFDL
+     & ,RHgrd_out=0.975                                                 &  !GFDL
+     & ,T_ICE=-40.                                                      &  !GFDL
+!GFDL     & ,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=60.E6                                                       &  !GFDL
+!HWRF     & ,NCW=100.E6                                                 &
+     & ,FLARGE1=1.                                                      &
+     & ,FLARGE2=.2
+!      LOGICAL, PARAMETER :: PRINT_diag=.FALSE.  !GFDL
+      LOGICAL, PARAMETER :: PRINT_err=.TRUE.    !GFDL** => eventually set this to .false.
+!--- Other public variables passed to other routines:
+      REAL,PUBLIC,SAVE ::  QAUT0
+      REAL, PUBLIC,DIMENSION(MDImin:MDImax) :: MASSI
+!
+!
+      CONTAINS
+
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+      SUBROUTINE ETAMP_NEW_HWRF (itimestep,DT,DX,DY,GID,RAINNC,RAINNCV,    & !GID
+     &                      dz8w,rho_phy,p_phy,pi_phy,th_phy,qv,qt,   & !gopal's doing
+     &                      LOWLYR,SR,                                &
+     &                      F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,         &
+     &                      QC,QR,QI,                                 &
+     &                      ids,ide, jds,jde, kds,kde,                &
+     &                      ims,ime, jms,jme, kms,kme,                &
+     &                      its,ite, jts,jte, kts,kte                 )
+!HWRF      SUBROUTINE ETAMP_NEW (itimestep,DT,DX,DY,                         &
+!HWRF     &                      dz8w,rho_phy,p_phy,pi_phy,th_phy,qv,qc,     &
+!HWRF     &                      LOWLYR,SR,                                  &
+!HWRF     &                      F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,           &
+!HWRF     &                      mp_restart_state,tbpvs_state,tbpvs0_state,  &
+!HWRF     &                      RAINNC,RAINNCV,                             &
+!HWRF     &                      ids,ide, jds,jde, kds,kde,		        &
+!HWRF     &                      ims,ime, jms,jme, kms,kme,		        &
+!HWRF     &                      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,GID  ! GID gopal's doing
+
+      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,qc,qr,qi
+      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
+!
+!HWRF      REAL,DIMENSION(*),INTENT(INOUT) :: MP_RESTART_STATE
+!
+!HWRF      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
+!
+!-----------------------------------------------------------------------
+!**********************************************************************
+!-----------------------------------------------------------------------
+!
+!HWRF      MY_GROWTH(MY_T1:MY_T2)=MP_RESTART_STATE(MY_T1:MY_T2)
+!HWRF!
+!HWRF      C1XPVS0=MP_RESTART_STATE(MY_T2+1)
+!HWRF      C2XPVS0=MP_RESTART_STATE(MY_T2+2)
+!HWRF      C1XPVS =MP_RESTART_STATE(MY_T2+3)
+!HWRF      C2XPVS =MP_RESTART_STATE(MY_T2+4)
+!HWRF      CIACW  =MP_RESTART_STATE(MY_T2+5)
+!HWRF      CIACR  =MP_RESTART_STATE(MY_T2+6)
+!HWRF      CRACW  =MP_RESTART_STATE(MY_T2+7)
+!HWRF      CRAUT  =MP_RESTART_STATE(MY_T2+8)
+!HWRF!
+!HWRF      TBPVS(1:NX) =TBPVS_STATE(1:NX)
+!HWRF      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(GID,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)
+           QI(I,K,J)=0.
+           QR(I,K,J)=0.
+           QC(I,K,J)=0.
+           IF(F_ICE_PHY(I,K,J)>=1.)THEN
+             QI(I,K,J)=WC
+           ELSEIF(F_ICE_PHY(I,K,J)<=0.)THEN
+             QC(I,K,J)=WC
+           ELSE
+             QI(I,K,J)=F_ICE_PHY(I,K,J)*WC
+             QC(I,K,J)=WC-QI(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
+!
+!HWRF     MP_RESTART_STATE(MY_T1:MY_T2)=MY_GROWTH(MY_T1:MY_T2)
+!HWRF     MP_RESTART_STATE(MY_T2+1)=C1XPVS0
+!HWRF     MP_RESTART_STATE(MY_T2+2)=C2XPVS0
+!HWRF     MP_RESTART_STATE(MY_T2+3)=C1XPVS
+!HWRF     MP_RESTART_STATE(MY_T2+4)=C2XPVS
+!HWRF     MP_RESTART_STATE(MY_T2+5)=CIACW
+!HWRF     MP_RESTART_STATE(MY_T2+6)=CIACR
+!HWRF     MP_RESTART_STATE(MY_T2+7)=CRACW
+!HWRF     MP_RESTART_STATE(MY_T2+8)=CRAUT
+!HWRF!
+!HWRF     TBPVS_STATE(1:NX) =TBPVS(1:NX)
+!HWRF     TBPVS0_STATE(1:NX)=TBPVS0(1:NX)
+
+!-----------------------------------------------------------------------
+
+  END SUBROUTINE ETAMP_NEW_HWRF
+
+!-----------------------------------------------------------------------
+
+      SUBROUTINE EGCP01DRV(GID,                            & !GID gopal's doing
+     &  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
+!     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
+      INTEGER,INTENT(IN ) :: GID     ! grid%id gopal's doing
+      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
+!-----------------------------------------------------------------------
+!
+!HWRF - Below are directives in the operational code that have been removed,
+!       where "TEMP_DEX" has been replaced with "I,J,L" and "TEMP_DIMS" has
+!       been replaced with "its:ite,jts:jte,kts:kte"
+!HWRF#define CACHE_FRIENDLY_MP_ETANEW
+!HWRF#ifdef CACHE_FRIENDLY_MP_ETANEW
+!HWRF#  define TEMP_DIMS  kts:kte,its:ite,jts:jte
+!HWRF#  define TEMP_DEX   L,I,J
+!HWRF#else
+!HWRF#  define TEMP_DIMS  its:ite,jts:jte,kts:kte
+!HWRF#  define TEMP_DEX   I,J,L
+!HWRF#endif
+!HWRF!
+      INTEGER :: LSFC,I,J,I_index,J_index,L,K,KFLIP
+!HWRF      REAL,DIMENSION(TEMP_DIMS) :: CWM,T,Q,TRAIN,TLATGS,P
+      REAL,DIMENSION(its:ite,jts:jte,kts:kte) ::                        &
+     &   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, RHC_col, DPCOL    !GFDL
+      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(I,J,L)=CWM_PHY(I,KFLIP,J)
+             T(I,J,L)=T_PHY(I,KFLIP,J)
+             Q(I,J,L)=Q_PHY(I,KFLIP,J)
+             P(I,J,L)=P_PHY(I,KFLIP,J)
+             TLATGS(I,J,L)=TLATGS_PHY(I,KFLIP,J)
+             TRAIN(I,J,L)=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)
+   !
+          IF (CWM(I,J,1) .LE. EPSQ) CWM(I,J,1)=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(I,J,L)
+      !
+      !--- Layer thickness = RHO*DZ = -DP/G = (Psfc-Ptop)*D_ETA/(G*ETA_sfc)
+      !
+            THICK_col(L)=DPCOL(L)*RGRAV
+            T_col(L)=T(I,J,L)
+            TC=T_col(L)-T0C
+            QV_col(L)=max(EPSQ, Q(I,J,L))
+            IF (CWM(I,J,L) .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(I,J,L)
+            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)
+            QI_col(L)=QI
+            QR_col(L)=QR
+            QW_col(L)=QW
+!GFDL => New.  Added RHC_col to allow for height- and grid-dependent values for
+!GFDL          the relative humidity threshold for condensation ("RHgrd")
+!------------------------------------------------------------
+            IF(GID .EQ. 1 .AND. L .LE. 10)THEN  ! gopal's doing based on GFDL
+              RHC_col(L)=RHgrd_out        
+            ELSE
+              RHC_col(L)=RHgrd_in       
+            ENDIF
+!------------------------------------------------------------
+          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, RHC_col, KTS,KTE,NSTATS,QMAX,QTOT )   !GFDL
+
+
+   !
+!#######################################################################
+!
+   !
+   !--- Update storage arrays
+   !
+          DO L=1,LSFC
+            TRAIN(I,J,L)=(T_col(L)-T(I,J,L))/DTPH
+            TLATGS(I,J,L)=T_col(L)-T(I,J,L)
+            T(I,J,L)=T_col(L)
+            Q(I,J,L)=QV_col(L)
+            CWM(I,J,L)=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(I,J,L)
+             T_PHY(I,KFLIP,J)=T(I,J,L)
+             Q_PHY(I,KFLIP,J)=Q(I,J,L)
+             TLATGS_PHY(I,KFLIP,J)=TLATGS(I,J,L)
+             TRAIN_PHY(I,KFLIP,J)=TRAIN(I,J,L)
+             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, RHC_col, KTS,KTE,NSTATS,QMAX,QTOT)   !GFDL
+!
+!###############################################################################
+!###############################################################################
+!
+!-------------------------------------------------------------------------------
+!----- 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)
+!   RHC_col    - vertical column of threshold relative humidity for onset of condensation (ratio)   !GFDL
+!   
+!
+! 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, RHC_col   !GFDL
+!
+!------------------------------------------------------------------------- 
+!-------------- 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.
+!
+!-----------------------------------------------------------------------
+!--- Local variables
+!-----------------------------------------------------------------------
+!
+      REAL EMAIRI, N0r, NLICE, NSmICE, RHgrd   !GFDL
+      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)
+          RHgrd=RHC_col(L)    ! Threshold relative humidity for the onset of condensation
+!
+!-----------------------------------------------------------------------
+!--- 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
+!GFDL          XLV2=XLV*XLV*QSW*TK2/RV    ! Lv**2*Qsw/(Rv*TK**2)
+          XLV2=XLV*XLV*QSWgrd*TK2/RV    ! Lv**2*QSWgrd/(Rv*TK**2)   !GFDL
+          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)
+!GFDL  => turned on in GFDL code, but not here =>           FLARGE=1.0
+            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 T<T_ICE (-10C) if supersaturated.
+   !    Sources of ice due to nucleation and convective detrainment are
+   !    either poorly understood, poorly resolved at typical NWP 
+   !    resolutions, or are not represented (e.g., no detrained 
+   !    condensate in BMJ Cu scheme).
+   !    
+            PCOND=-QW
+            DUM1=TK+XLV1*PCOND                 ! Updated (dummy) temperature (deg K)
+            DUM2=WV+QW                         ! Updated (dummy) water vapor mixing ratio
+            DUM=1000.*FPVS(DUM1)               ! Updated (dummy) saturation vapor pressure w/r/t ice
+            DUM=RHgrd*EPS*DUM/(PP-DUM)         ! Updated (dummy) saturation mixing ratio w/r/t ice
+            IF (DUM2 .GT. DUM) PIDEP=DEPOSIT (PP, DUM1, DUM2, RHgrd)  !GFDL
+            DWVi=0.    ! Used only for debugging
+   !
+          ELSE IF (TC .LT. 0.) THEN
+   !
+   !--- These quantities are handy for ice deposition/sublimation
+   !    PIDEP_max - max deposition or minimum sublimation to ice saturation
+   !
+!GFDL            DENOMI=1.+XLS2*QSI*TK2
+!GFDL            DWVi=MIN(WVQW,QSW)-QSI
+            DENOMI=1.+XLS2*QSIgrd*TK2   !GFDL
+            DWVi=MIN(WVQW,QSWgrd)-QSIgrd   !GFDL
+            PIDEP_max=MAX(PILOSS, DWVi/DENOMI)
+            IF (QTICE .GT. 0.) THEN
+      !
+      !--- Calculate ice deposition/sublimation
+      !      * SFACTOR - [VEL_INC**.5]*[Schmidt**(1./3.)]*[(RHO/DYNVIS)**.5],
+      !        where Schmidt (Schmidt Number) =DYNVIS/(RHO*DIFFUS)
+      !      * Units: SFACTOR - s**.5/m ;  ABI - m**2/s ;  NLICE - m**-3 ;
+      !               VENTIL, VENTIS - m**-2 ;  VENTI1 - m ;  
+      !               VENTI2 - m**2/s**.5 ; DIDEP - unitless
+      !
+              SFACTOR=SQRT(VEL_INC)*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2   !GFDL
+              ABI=1./(RHO*XLS3*QSI*TK2/THERM_COND+1./DIFFUS)
+      !
+      !--- VENTIL - Number concentration * ventilation factors for large ice
+      !--- VENTIS - Number concentration * ventilation factors for small ice
+      !
+      !--- Variation in the number concentration of ice with time is not
+      !      accounted for in these calculations (could be in the future).
+      !
+              VENTIL=(VENTI1(INDEXS)+SFACTOR*VENTI2(INDEXS))*NLICE
+              VENTIS=(VENTI1(MDImin)+SFACTOR*VENTI2(MDImin))*NSmICE
+              DIDEP=ABI*(VENTIL+VENTIS)*DTPH
+      !
+      !--- Account for change in water vapor supply w/ time
+      !
+              IF (DIDEP .GE. Xratio)then
+                DIDEP=(1.-EXP(-DIDEP*DENOMI))/DENOMI
+              endif
+              IF (DWVi .GT. 0.) THEN
+                PIDEP=MIN(DWVi*DIDEP, PIDEP_max)
+              ELSE IF (DWVi .LT. 0.) THEN
+                PIDEP=MAX(DWVi*DIDEP, PIDEP_max)
+              ENDIF
+      !
+!GFDL            ELSE IF (WVQW.GT.QSI .AND. TC.LE.T_ICE_init) THEN
+            ELSE IF (WVQW.GT.QSIgrd .AND. TC.LE.T_ICE_init) THEN   !GFDL
+      !
+      !--- Ice nucleation in near water-saturated conditions.  Ice crystal
+      !    growth during time step calculated using Miller & Young (1979, JAS).
+      !--- These deposition rates could drive conditions below water saturation,
+      !    which is the basis of these calculations.  Intended to approximate
+      !    more complex & computationally intensive calculations.
+      !
+              INDEX_MY=MAX(MY_T1, MIN( INT(.5-TC), MY_T2 ) )
+      !
+      !--- DUM1 is the supersaturation w/r/t ice at water-saturated conditions
+      !
+      !--- DUM2 is the number of ice crystals nucleated at water-saturated 
+      !    conditions based on Meyers et al. (JAM, 1992).
+      !
+      !--- Prevent unrealistically large ice initiation (limited by PIDEP_max)
+      !      if DUM2 values are increased in future experiments
+      !
+              DUM1=QSW/QSI-1.      
+              DUM2=1.E3*EXP(12.96*DUM1-.639)
+              PIDEP=MIN(PIDEP_max, DUM2*MY_GROWTH(INDEX_MY)*RRHO)
+      !
+            ENDIF       ! End IF (QTICE .GT. 0.)
+   !
+          ENDIF         ! End IF (TC.LT.T_ICE .AND. (WV.GT.QSIgrd .OR. QW.GT.EPSQ))
+!
+!------------------------------------------------------------------------
+!
+20      CONTINUE     ! Jump here if conditions for ice are not present
+
+
+!
+!------------------------------------------------------------------------
+!
+!--- Cloud water condensation
+!
+          IF (TC.GE.T_ICE .AND. (QW.GT.EPSQ .OR. WV.GT.QSWgrd)) THEN
+            IF (PIACWI.EQ.0. .AND. PIDEP.EQ.0.) THEN
+              PCOND=CONDENSE (PP, QW, TK, WV, RHgrd)   !GFDL
+            ELSE
+   !
+   !--- Modify cloud condensation in response to ice processes
+   !
+              DUM=XLV*QSWgrd*RCPRV*TK2
+              DENOMWI=1.+XLS*DUM
+              DENOMF=XLF*DUM
+              DUM=MAX(0., PIDEP)
+              PCOND=(WV-QSWgrd-DENOMWI*DUM-DENOMF*PIACWI)/DENOMW
+              DUM1=-QW
+              DUM2=PCOND-PIACW
+              IF (DUM2 .LT. DUM1) THEN
+      !
+      !--- Limit cloud water sinks
+      !
+                DUM=DUM1/DUM2
+                PCOND=DUM*PCOND
+                PIACW=DUM*PIACW
+                PIACWI=DUM*PIACWI
+              ENDIF        ! End IF (DUM2 .LT. DUM1)
+            ENDIF          ! End IF (PIACWI.EQ.0. .AND. PIDEP.EQ.0.)
+          ENDIF            ! End IF (TC.GE.T_ICE .AND. (QW.GT.EPSQ .OR. WV.GT.QSWgrd))
+!
+!--- Limit freezing of accreted rime to prevent temperature oscillations,
+!    a crude Schumann-Ludlam limit (p. 209 of Young, 1993). 
+!
+          TCC=TC+XLV1*PCOND+XLS1*PIDEP+XLF1*PIACWI
+          IF (TCC .GT. 0.) THEN
+            PIACWI=0.
+            TCC=TC+XLV1*PCOND+XLS1*PIDEP
+          ENDIF
+          IF (TC.GT.0. .AND. TCC.GT.0. .AND. ICE_logical) THEN
+   !
+   !--- Calculate melting and evaporation/condensation
+   !      * Units: SFACTOR - s**.5/m ;  ABI - m**2/s ;  NLICE - m**-3 ;
+   !               VENTIL - m**-2 ;  VENTI1 - m ;  
+   !               VENTI2 - m**2/s**.5 ; CIEVP - /s
+   !
+            SFACTOR=SQRT(VEL_INC)*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2   !GFDL
+            VENTIL=NLICE*(VENTI1(INDEXS)+SFACTOR*VENTI2(INDEXS))
+            AIEVP=VENTIL*DIFFUS*DTPH
+            IF (AIEVP .LT. Xratio) THEN
+              DIEVP=AIEVP
+            ELSE
+              DIEVP=1.-EXP(-AIEVP)
+            ENDIF
+            QSW0=EPS*ESW0/(PP-ESW0)
+!GFDL            DWV0=MIN(WV,QSW)-QSW0
+            DWV0=MIN(WV,QSWgrd)-QSW0*RHgrd   !GFDL
+            DUM=QW+PCOND
+!GFDL            IF (WV.LT.QSW .AND. DUM.LE.EPSQ) THEN
+            IF (WV.LT.QSWgrd .AND. DUM.LE.EPSQ) THEN   !GFDL
+   !
+   !--- Evaporation from melting snow (sink of snow) or shedding
+   !    of water condensed onto melting snow (source of rain)
+   !
+              DUM=DWV0*DIEVP
+              PIEVP=MAX( MIN(0., DUM), PILOSS)
+              PICND=MAX(0., DUM)
+            ENDIF            ! End IF (WV.LT.QSW .AND. DUM.LE.EPSQ)
+            PIMLT=THERM_COND*TCC*VENTIL*RRHO*DTPH/XLF
+   !
+   !--- Limit melting to prevent temperature oscillations across 0C
+   !
+            DUM1=MAX( 0., (TCC+XLV1*PIEVP)/XLF1 )
+            PIMLT=MIN(PIMLT, DUM1)
+   !
+   !--- Limit loss of snow by melting (>0) 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.
+          INDEXR=MDRmin
+          INDEXR1=INDEXR    ! For debugging only
+          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
+!GFDL              DWVr=WV-PCOND-QSW
+              DWVr=WV-PCOND-QSWgrd   !GFDL
+              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=SQRT(GAMMAR)*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2   !GFDL
+                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=SQRT(DUM1*DUM1+.04*DUM*VSNOW)    !GFDL
+                  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
+!
+          IF (PRINT_err) THEN
+           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) 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      !-- IF (WVnew.LT.EPSQ .OR. DBG_logical) THEN
+          ENDIF      !-- IF (PRINT_err) THEN
+
+!
+!-----------------------------------------------------------------------
+!--------------- 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, RHgrd)   !GFDL
+!
+!---------------------------------------------------------------------------------
+!------   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,RHgrd   !GFDL
+      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<T_ICE ------------------
+!#######################################################################
+!
+      REAL FUNCTION DEPOSIT (PP, Tdum, WVdum, RHgrd)   !GFDL
+!
+!--- Also uses the Asai (1965) algorithm, but uses a different target
+!      vapor pressure for the adjustment
+!
+      IMPLICIT NONE      
+!
+      INTEGER, PARAMETER :: HIGH_PRES=Selected_Real_Kind(15)
+      REAL (KIND=HIGH_PRES), PARAMETER :: RHLIMIT=.001,                 &
+     & RHLIMIT1=-RHLIMIT
+      REAL (KIND=HIGH_PRES) :: DEP, SSAT
+!    
+      real,INTENT(IN) ::  PP,RHgrd   !GFDL
+      real,INTENT(INOUT) ::  WVdum,Tdum
+      real ESI,WS,DWV
+!
+!-----------------------------------------------------------------------
+!
+      ESI=1000.*FPVS(Tdum)                      ! Saturation vapor press w/r/t ice
+      WS=RHgrd*EPS*ESI/(PP-ESI)                 ! Saturation mixing ratio
+      DWV=WVdum-WS                              ! Deficit grid-scale water vapor mixing ratio
+      SSAT=DWV/WS                               ! Supersaturation ratio
+      DEPOSIT=0.
+      DO WHILE (SSAT.GT.RHLIMIT .OR. SSAT.LT.RHLIMIT1)
+   !
+   !--- Note that XLVS2=LS*LV/(CP*RV)=LV*WS/(RV*T*T)*(LS/CP*DEP1), 
+   !     where WS is the saturation mixing ratio following Clausius-
+   !     Clapeyron (see Asai,1965; Young,1993,p.405) 
+   !
+        DEP=DWV/(1.+XLS2*WS/(Tdum*Tdum))        ! Asai (1965, J. Japan)
+        Tdum=Tdum+XLS1*DEP                      ! Updated temperature
+        WVdum=WVdum-DEP                         ! Updated ice mixing ratio
+        DEPOSIT=DEPOSIT+DEP                     ! Total ice deposition
+        ESI=1000.*FPVS(Tdum)                    ! Updated saturation vapor press w/r/t ice
+        WS=RHgrd*EPS*ESI/(PP-ESI)               ! Updated saturation mixing ratio w/r/t ice
+        DWV=WVdum-WS                            ! Deficit grid-scale water vapor mixing ratio
+        SSAT=DWV/WS                             ! Grid-scale supersaturation ratio
+      ENDDO
+!
+      END FUNCTION DEPOSIT
+!
+      END SUBROUTINE EGCP01COLUMN 
+
+!#######################################################################
+!------- Initialize constants & lookup tables for microphysics ---------
+!#######################################################################
+!
+
+! SH 0211/2002
+
+!-----------------------------------------------------------------------
+      SUBROUTINE etanewinit_HWRF (GSMDT,DT,DELX,DELY,LOWLYR,restart,         &
+     &   F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,                              &
+!HWRF     &   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                                       )
+!-----------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!---  SUBPROGRAM DOCUMENTATION BLOCK
+!   PRGRMMR: Ferrier         ORG: W/NP22     DATE: February 2001
+!            Jin             ORG: W/NP22     DATE: January 2002 
+!        (Modification for WRF structure)
+!                                               
+!-------------------------------------------------------------------------------
+! ABSTRACT:
+!   * Reads various microphysical lookup tables used in COLUMN_MICRO
+!   * Lookup tables were created "offline" and are read in during execution
+!   * Creates lookup tables for saturation vapor pressure w/r/t water & ice
+!-------------------------------------------------------------------------------
+!     
+! USAGE: CALL etanewinit FROM SUBROUTINE GSMDRIVE AT MODEL START TIME
+!
+!   INPUT ARGUMENT LIST:
+!       DTPH - physics time step (s)
+!  
+!   OUTPUT ARGUMENT LIST: 
+!     NONE
+!     
+!   OUTPUT FILES:
+!     NONE
+!     
+!   SUBROUTINES:
+!     MY_GROWTH_RATES - lookup table for growth of nucleated ice
+!     GPVS            - lookup tables for saturation vapor pressure (water, ice)
+!
+!   UNIQUE: NONE
+!  
+!   LIBRARY: NONE
+!  
+!   COMMON BLOCKS:
+!     CMICRO_CONS - constants used in GSMCOLUMN
+!     CMY600       - 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
+!     MAPOT        - Need lat/lon grid resolution
+!     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
+!
+!-----------------------------------------------------------------------
+!
+!
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+!------------------------------------------------------------------------- 
+!-------------- Parameters & arrays for lookup tables -------------------- 
+!------------------------------------------------------------------------- 
+!
+!--- Common block of constants used in column microphysics
+!
+!WRF
+!     real DLMD,DPHD
+!WRF
+!
+!-----------------------------------------------------------------------
+!--- Parameters & data statement for local calculations
+!-----------------------------------------------------------------------
+!
+      INTEGER, PARAMETER :: MDR1=XMR1, MDR2=XMR2, MDR3=XMR3
+!
+!     VARIABLES PASSED IN
+      integer,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     & 
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE       
+!WRF
+       INTEGER, DIMENSION(ims:ime,jms:jme),INTENT(INOUT) :: LOWLYR
+!
+      real, INTENT(IN) ::  DELX,DELY
+!HWRF      real,DIMENSION(*), INTENT(INOUT) :: MP_RESTART_STATE
+!HWRF      real,DIMENSION(NX), INTENT(INOUT) :: TBPVS_STATE,TBPVS0_STATE
+      real,DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(OUT) ::          &
+     &  F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY
+      INTEGER, PARAMETER :: ITLO=-60, ITHI=40
+!     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,INTENT(INOUT) :: PRECtot(2),PRECmax(2)
+      real,INTENT(IN) :: DT,GSMDT
+      LOGICAL,INTENT(IN) :: allowed_to_read,restart
+!
+!-----------------------------------------------------------------------
+!     LOCAL VARIABLES
+!-----------------------------------------------------------------------
+      REAL :: BBFR,DTPH,PI,DX,Thour_print
+      INTEGER :: I,IM,J,L,K,JTF,KTF,ITF
+      INTEGER :: etampnew_unit1
+      LOGICAL :: opened
+      LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
+      CHARACTER*80 errmess
+!
+!-----------------------------------------------------------------------
+!
+      JTF=MIN0(JTE,JDE-1)
+      KTF=MIN0(KTE,KDE-1)
+      ITF=MIN0(ITE,IDE-1)
+!
+      DO J=JTS,JTF
+      DO I=ITS,ITF
+        LOWLYR(I,J)=1
+      ENDDO
+      ENDDO
+!    
+      IF(.NOT.RESTART .AND. ALLOWED_TO_READ) THEN    !HWRF
+        CALL wrf_debug(1,'WARNING: F_ICE_PHY,F_RAIN_PHY AND F_RIMEF_PHY IS REINITIALIZED')   !HWRF
+        DO J = jts,jte
+        DO K = kts,kte
+        DO I= its,ite
+          F_ICE_PHY(i,k,j)=0.
+          F_RAIN_PHY(i,k,j)=0.
+          F_RIMEF_PHY(i,k,j)=1.
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDIF
+!    
+!-----------------------------------------------------------------------
+      IF(ALLOWED_TO_READ)THEN
+!-----------------------------------------------------------------------
+!
+        DX=SQRT((DELX)**2+(DELY)**2)/1000.    ! Model resolution at equator (km)  !GFDL
+        DX=MIN(100., MAX(5., DX) )
+!
+!-- Relative humidity threshold for the onset of grid-scale condensation
+!!-- 9/1/01:  Assume the following functional dependence for 5 - 100 km resolution:
+!!       RHgrd=0.90 for dx=100 km, 0.98 for dx=5 km, where
+!        RHgrd=0.90+.08*((100.-DX)/95.)**.5
+!
+        DTPH=MAX(GSMDT*60.,DT)
+        DTPH=NINT(DTPH/DT)*DT
+!
+!--- Create lookup tables for saturation vapor pressure w/r/t water & ice
+!
+        CALL GPVS
+!
+!--- Read in various lookup tables
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              etampnew_unit1 = i
+              GOTO 2061
+            ENDIF
+          ENDDO
+          etampnew_unit1 = -1
+ 2061     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( etampnew_unit1 , IWORDSIZE )
+!
+        IF ( etampnew_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_hwrf: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+!!was     OPEN (UNIT=1,FILE="eta_micro_lookup.dat",FORM="UNFORMATTED")
+          OPEN(UNIT=etampnew_unit1,FILE="ETAMPNEW_DATA",                  &
+     &        FORM="UNFORMATTED",STATUS="OLD",ERR=9061)
+!
+          READ(etampnew_unit1) VENTR1
+          READ(etampnew_unit1) VENTR2
+          READ(etampnew_unit1) ACCRR
+          READ(etampnew_unit1) MASSR
+          READ(etampnew_unit1) VRAIN
+          READ(etampnew_unit1) RRATE
+          READ(etampnew_unit1) VENTI1
+          READ(etampnew_unit1) VENTI2
+          READ(etampnew_unit1) ACCRI
+          READ(etampnew_unit1) MASSI
+          READ(etampnew_unit1) VSNOWI
+          READ(etampnew_unit1) VEL_RF
+!        read(etampnew_unit1) my_growth    ! Applicable only for DTPH=180 s
+          CLOSE (etampnew_unit1)
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( VENTR1 , size ( VENTR1 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VENTR2 , size ( VENTR2 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( ACCRR , size ( ACCRR ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( MASSR , size ( MASSR ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VRAIN , size ( VRAIN ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( RRATE , size ( RRATE ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VENTI1 , size ( VENTI1 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VENTI2 , size ( VENTI2 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( ACCRI , size ( ACCRI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( MASSI , size ( MASSI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VSNOWI , size ( VSNOWI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VEL_RF , size ( VEL_RF ) * RWORDSIZE )
+!
+!--- Calculates coefficients for growth rates of ice nucleated in water
+!    saturated conditions, scaled by physics time step (lookup table)
+!
+        CALL MY_GROWTH_RATES (DTPH)
+!       CALL MY_GROWTH_RATES (DTPH,MY_GROWTH)
+!
+        PI=ACOS(-1.)
+!
+!--- Constants associated with Biggs (1953) freezing of rain, as parameterized
+!    following Lin et al. (JCAM, 1983) & Reisner et al. (1998, QJRMS).
+!
+        ABFR=-0.66
+        BBFR=100.
+        CBFR=20.*PI*PI*BBFR*RHOL*1.E-21
+!
+!--- CIACW is used in calculating riming rates
+!      The assumed effective collection efficiency of cloud water rimed onto
+!      ice is =0.5 below:
+!
+        CIACW=DTPH*0.25*PI*0.5*(1.E5)**C1
+!
+!--- CIACR is used in calculating freezing of rain colliding with large ice
+!      The assumed collection efficiency is 1.0
+!
+        CIACR=PI*DTPH
+!
+!--- Based on rain lookup tables for mean diameters from 0.05 to 0.45 mm
+!    * Four different functional relationships of mean drop diameter as 
+!      a function of rain rate (RR), derived based on simple fits to 
+!      mass-weighted fall speeds of rain as functions of mean diameter
+!      from the lookup tables.  
+!
+        RR_DRmin=N0r0*RRATE(MDRmin)     ! RR for mean drop diameter of .05 mm
+        RR_DR1=N0r0*RRATE(MDR1)         ! RR for mean drop diameter of .10 mm
+        RR_DR2=N0r0*RRATE(MDR2)         ! RR for mean drop diameter of .20 mm
+        RR_DR3=N0r0*RRATE(MDR3)         ! RR for mean drop diameter of .32 mm
+        RR_DRmax=N0r0*RRATE(MDRmax)     ! RR for mean drop diameter of .45 mm
+!
+        RQR_DRmin=N0r0*MASSR(MDRmin)    ! Rain content for mean drop diameter of .05 mm
+        RQR_DR1=N0r0*MASSR(MDR1)        ! Rain content for mean drop diameter of .10 mm
+        RQR_DR2=N0r0*MASSR(MDR2)        ! Rain content for mean drop diameter of .20 mm
+        RQR_DR3=N0r0*MASSR(MDR3)        ! Rain content for mean drop diameter of .32 mm
+        RQR_DRmax=N0r0*MASSR(MDRmax)    ! Rain content for mean drop diameter of .45 mm
+        C_N0r0=PI*RHOL*N0r0
+        CN0r0=1.E6/C_N0r0**.25
+        CN0r_DMRmin=1./(PI*RHOL*DMRmin**4)
+        CN0r_DMRmax=1./(PI*RHOL*DMRmax**4)
+!
+!--- CRACW is used in calculating collection of cloud water by rain (an
+!      assumed collection efficiency of 1.0)
+!
+        CRACW=DTPH*0.25*PI*1.0
+!
+        ESW0=1000.*FPVS0(T0C)     ! Saturation vapor pressure at 0C
+        RFmax=1.1**Nrime          ! Maximum rime factor allowed
+!
+!------------------------------------------------------------------------
+!--------------- Constants passed through argument list -----------------
+!------------------------------------------------------------------------
+!
+!--- Important parameters for self collection (autoconversion) of 
+!    cloud water to rain. 
+!
+!--- CRAUT is proportional to the rate that cloud water is converted by
+!      self collection to rain (autoconversion rate)
+!
+        CRAUT=1.-EXP(-1.E-3*DTPH)
+!
+!--- QAUT0 is the threshold cloud content for autoconversion to rain 
+!      needed for droplets to reach a diameter of 20 microns (following
+!      Manton and Cotton, 1977; Banta and Hanson, 1987, JCAM)
+!--- QAUT0=1.2567, 0.8378, or 0.4189 g/m**3 for droplet number concentrations
+!          of 300, 200, and 100 cm**-3, respectively
+!
+        QAUT0=PI*RHOL*NCW*(20.E-6)**3/6.
+!
+!--- For calculating snow optical depths by considering bulk density of
+!      snow based on emails from Q. Fu (6/27-28/01), where optical 
+!      depth (T) = 1.5*SWP/(Reff*DENS), SWP is snow water path, Reff 
+!      is effective radius, and DENS is the bulk density of snow.
+!
+!    SWP (kg/m**2)=(1.E-3 kg/g)*SWPrad, SWPrad in g/m**2 used in radiation
+!    T = 1.5*1.E3*SWPrad/(Reff*DENS)
+!  
+!    See derivation for MASSI(INDEXS), note equal to RHO*QSNOW/NSNOW
+!
+!      SDENS=1.5e3/DENS, DENS=MASSI(INDEXS)/[PI*(1.E-6*INDEXS)**3]
+!
+        DO I=MDImin,MDImax
+          SDENS(I)=PI*1.5E-15*FLOAT(I*I*I)/MASSI(I)
+        ENDDO
+!
+        Thour_print=-DTPH/3600.
+
+! SH 0211/2002
+!       IF (PRINT_diag) THEN
+!       
+!      !-------- Total and maximum quantities
+!      !
+!         NSTATS=0      ! Microphysical statistics dealing w/ grid-point counts
+!         QMAX=0.       ! Microphysical statistics dealing w/ hydrometeor mass
+!         QTOT=0.       ! Microphysical statistics dealing w/ hydrometeor mass
+!         PRECmax=0.    ! Maximum precip rates (rain, snow) at surface (mm/h)
+!         PRECtot=0.    ! Total precipitation (rain, snow) accumulation at surface
+!       ENDIF
+
+!wrf
+!HWRF        IF(.NOT.RESTART)THEN
+!HWRF          MP_RESTART_STATE(MY_T1:MY_T2)=MY_GROWTH(MY_T1:MY_T2)
+!HWRF          MP_RESTART_STATE(MY_T2+1)=C1XPVS0
+!HWRF          MP_RESTART_STATE(MY_T2+2)=C2XPVS0
+!HWRF          MP_RESTART_STATE(MY_T2+3)=C1XPVS
+!HWRF          MP_RESTART_STATE(MY_T2+4)=C2XPVS
+!HWRF          MP_RESTART_STATE(MY_T2+5)=CIACW
+!HWRF          MP_RESTART_STATE(MY_T2+6)=CIACR
+!HWRF          MP_RESTART_STATE(MY_T2+7)=CRACW
+!HWRF          MP_RESTART_STATE(MY_T2+8)=CRAUT
+!HWRF          TBPVS_STATE(1:NX) =TBPVS(1:NX)
+!HWRF          TBPVS0_STATE(1:NX)=TBPVS0(1:NX)
+!HWRF        ENDIF
+
+      ENDIF  ! Allowed_to_read
+
+      RETURN
+!
+!-----------------------------------------------------------------------
+!
+9061 CONTINUE
+      WRITE( errmess , '(A,I4)' )                                        &
+       'module_mp_hwrf: error opening ETAMPNEW_DATA on unit '          &
+     &, etampnew_unit1
+      CALL wrf_error_fatal(errmess)
+!
+!-----------------------------------------------------------------------
+      END SUBROUTINE etanewinit_HWRF
+!
+      SUBROUTINE MY_GROWTH_RATES (DTPH)
+!     SUBROUTINE MY_GROWTH_RATES (DTPH,MY_GROWTH)
+!
+!--- Below are tabulated values for the predicted mass of ice crystals
+!    after 600 s of growth in water saturated conditions, based on 
+!    calculations from Miller and Young (JAS, 1979).  These values are
+!    crudely estimated from tabulated curves at 600 s from Fig. 6.9 of
+!    Young (1993).  Values at temperatures colder than -27C were 
+!    assumed to be invariant with temperature.  
+!
+!--- Used to normalize Miller & Young (1979) calculations of ice growth
+!    over large time steps using their tabulated values at 600 s.
+!    Assumes 3D growth with time**1.5 following eq. (6.3) in Young (1993).
+!
+      IMPLICIT NONE
+!
+      REAL,INTENT(IN) :: DTPH
+!
+      REAL  DT_ICE
+      REAL,DIMENSION(35) :: MY_600
+!WRF
+!
+!-----------------------------------------------------------------------
+      DATA MY_600 /                                                     &
+     & 5.5e-8, 1.4E-7, 2.8E-7, 6.E-7, 3.3E-6,                           & 
+     & 2.E-6, 9.E-7, 8.8E-7, 8.2E-7, 9.4e-7,                            & 
+     & 1.2E-6, 1.85E-6, 5.5E-6, 1.5E-5, 1.7E-5,                         & 
+     & 1.5E-5, 1.E-5, 3.4E-6, 1.85E-6, 1.35E-6,                         & 
+     & 1.05E-6, 1.E-6, 9.5E-7, 9.0E-7, 9.5E-7,                          & 
+     & 9.5E-7, 9.E-7, 9.E-7, 9.E-7, 9.E-7,                              & 
+     & 9.E-7, 9.E-7, 9.E-7, 9.E-7, 9.E-7 /        ! -31 to -35 deg C
+!
+!-----------------------------------------------------------------------
+!
+      DT_ICE=(DTPH/600.)**1.5
+      MY_GROWTH=DT_ICE*MY_600
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE MY_GROWTH_RATES
+!
+!-----------------------------------------------------------------------
+!---------  Old GFS saturation vapor pressure lookup tables  -----------
+!-----------------------------------------------------------------------
+!
+      SUBROUTINE GPVS
+!     ******************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    GPVS        COMPUTE SATURATION VAPOR PRESSURE TABLE
+!   AUTHOR: N PHILLIPS       W/NP2      DATE: 30 DEC 82
+!
+! ABSTRACT: COMPUTE 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.0 TO 330.0 KELVIN.
+!
+! PROGRAM HISTORY LOG:
+!   91-05-07  IREDELL
+!   94-12-30  IREDELL             EXPAND TABLE
+!   96-02-19  HONG                ICE EFFECT
+!   01-11-29  JIN                 MODIFIED FOR WRF
+!
+! USAGE:  CALL GPVS
+!
+! SUBPROGRAMS CALLED:
+!   (FPVSX)  - INLINABLE FUNCTION TO COMPUTE SATURATION VAPOR PRESSURE
+!
+! COMMON BLOCKS:
+!   COMPVS   - SCALING PARAMETERS AND TABLE FOR FUNCTION FPVS.
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!
+!$$$
+      IMPLICIT NONE
+      real :: X,XINC,T
+      integer :: JX
+!----------------------------------------------------------------------
+      XINC=(XMAX-XMIN)/(NX-1)
+      C1XPVS=1.-XMIN/XINC
+      C2XPVS=1./XINC
+      C1XPVS0=1.-XMIN/XINC
+      C2XPVS0=1./XINC
+!
+      DO JX=1,NX
+        X=XMIN+(JX-1)*XINC
+        T=X
+        TBPVS(JX)=FPVSX(T)
+        TBPVS0(JX)=FPVSX0(T)
+      ENDDO
+! 
+      END SUBROUTINE GPVS
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+                     REAL   FUNCTION FPVS(T)
+!-----------------------------------------------------------------------
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    FPVS        COMPUTE SATURATION VAPOR PRESSURE
+!   AUTHOR: N PHILLIPS            W/NP2      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
+!   96-02-19  HONG                ICE EFFECT
+!   01-11-29  JIN                 MODIFIED FOR WRF
+!
+! USAGE:   PVS=FPVS(T)
+!
+!   INPUT ARGUMENT LIST:
+!     T        - REAL TEMPERATURE IN KELVIN
+!
+!   OUTPUT ARGUMENT LIST:
+!     FPVS     - REAL SATURATION VAPOR PRESSURE IN KILOPASCALS (CB)
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!$$$
+      IMPLICIT NONE
+      real,INTENT(IN) :: T
+      real XJ
+      integer :: JX
+!-----------------------------------------------------------------------
+      XJ=MIN(MAX(C1XPVS+C2XPVS*T,1.),FLOAT(NX))
+      JX=MIN(XJ,NX-1.)
+      FPVS=TBPVS(JX)+(XJ-JX)*(TBPVS(JX+1)-TBPVS(JX))
+!
+      END FUNCTION FPVS
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+                     REAL FUNCTION FPVS0(T)
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+      real,INTENT(IN) :: T
+      real :: XJ1
+      integer :: JX1
+!-----------------------------------------------------------------------
+      XJ1=MIN(MAX(C1XPVS0+C2XPVS0*T,1.),FLOAT(NX))
+      JX1=MIN(XJ1,NX-1.)
+      FPVS0=TBPVS0(JX1)+(XJ1-JX1)*(TBPVS0(JX1+1)-TBPVS0(JX1))
+!
+      END FUNCTION FPVS0
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+                    REAL FUNCTION FPVSX(T)
+!-----------------------------------------------------------------------
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    FPVSX       COMPUTE SATURATION VAPOR PRESSURE
+!   AUTHOR: N PHILLIPS            W/NP2      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
+!       PVS=PSATK*(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
+!   96-02-19  HONG                ICE EFFECT 
+!   01-11-29  JIN                 MODIFIED FOR WRF
+!
+! USAGE:   PVS=FPVSX(T)
+! REFERENCE:   EMANUEL(1994),116-117
+!
+!   INPUT ARGUMENT LIST:
+!     T        - REAL TEMPERATURE IN KELVIN
+!
+!   OUTPUT ARGUMENT LIST:
+!     FPVSX    - REAL SATURATION VAPOR PRESSURE IN KILOPASCALS (CB)
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!$$$
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+       real, parameter :: TTP=2.7316E+2,HVAP=2.5000E+6,PSAT=6.1078E+2   &
+      ,         CLIQ=4.1855E+3,CVAP= 1.8460E+3                          &
+      ,         CICE=2.1060E+3,HSUB=2.8340E+6
+!
+      real, parameter :: PSATK=PSAT*1.E-3
+      real, parameter :: DLDT=CVAP-CLIQ,XA=-DLDT/RV,XB=XA+HVAP/(RV*TTP)
+      real, parameter :: DLDTI=CVAP-CICE                                &
+      ,                  XAI=-DLDTI/RV,XBI=XAI+HSUB/(RV*TTP)
+      real T,TR
+!-----------------------------------------------------------------------
+      TR=TTP/T
+!
+      IF(T.GE.TTP)THEN
+        FPVSX=PSATK*(TR**XA)*EXP(XB*(1.-TR))
+      ELSE
+        FPVSX=PSATK*(TR**XAI)*EXP(XBI*(1.-TR))
+      ENDIF
+! 
+      END FUNCTION FPVSX
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+                 REAL   FUNCTION FPVSX0(T)
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+      real,parameter :: TTP=2.7316E+2,HVAP=2.5000E+6,PSAT=6.1078E+2     &
+      ,         CLIQ=4.1855E+3,CVAP=1.8460E+3                           &
+      ,         CICE=2.1060E+3,HSUB=2.8340E+6
+      real,PARAMETER :: PSATK=PSAT*1.E-3
+      real,PARAMETER :: DLDT=CVAP-CLIQ,XA=-DLDT/RV,XB=XA+HVAP/(RV*TTP)
+      real,PARAMETER :: DLDTI=CVAP-CICE                                 &
+      ,                 XAI=-DLDT/RV,XBI=XA+HSUB/(RV*TTP)
+      real :: T,TR
+!-----------------------------------------------------------------------
+      TR=TTP/T
+      FPVSX0=PSATK*(TR**XA)*EXP(XB*(1.-TR))
+!
+      END FUNCTION FPVSX0
+!
+      END MODULE module_mp_HWRF
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_etanew.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_etanew.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_etanew.F	(revision 17)
@@ -0,0 +1,2623 @@
+!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),SAVE :: TBPVS,TBPVS0
+      REAL, 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=-40.                                                      &
+     & ,T_ICEK=T0C+T_ICE                                                &
+     & ,T_ICE_init=-15.                                                 &
+     & ,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
+
+!-- 6/11/2010: Update QT, F_ice, F_rain arrays
+!
+!-- NOTE:  The total ice array in this code is "QS" because the vast
+!          majority of the ice mass is in the form of snow, and using
+!          the "QS" array should result in better coupling with the
+!          Dudhia SW package.
+
+      DO j = jts,jte
+      DO k = kts,kte
+      DO i = its,ite
+#if (NMM_CORE==1)
+! Note ARW QT has been advected, while QR, QS and QC have not, so use updated QT
+! NMM calls microphysics after other physics, so use updated QR, QS and QC
+         QT(I,K,J)=QC(I,K,J)+QR(I,K,J)+QS(I,K,J)
+#endif
+         IF (QS(I,K,J) <= EPSQ) THEN
+            F_ICE_PHY(I,K,J)=0.
+            IF (T_PHY(I,K,J) < T_ICEK) F_ICE_PHY(I,K,J)=1.
+         ELSE
+            F_ICE_PHY(I,K,J)=MAX( 0., MIN(1., QS(I,K,J)/QT(I,K,J) ) )
+         ENDIF
+         IF (QR(I,K,J) <= EPSQ) THEN
+            F_RAIN_PHY(I,K,J)=0.
+         ELSE
+            F_RAIN_PHY(I,K,J)=QR(I,K,J)/(QC(I,K,J)+QR(I,K,J))
+         ENDIF
+      ENDDO
+      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
+            IF (QI .LE. 0.) F_RimeF(L,I,J)=1.
+            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
+      !
+            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.
+              F_RimeF(L,I,J)=1.
+            ELSE
+              F_ice(L,I,J)=MAX( 0., MIN(1., QI_col(L)/WC_col(L)) )
+              F_RimeF(L,I,J)=MAX(1., RimeF_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
+                  IF (TC < 0) THEN
+                    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
+                    ENDIF             ! End IF (XLI .LE. MASSI(MDImin) )
+                  ENDIF               ! End IF (TC < 0)
+        !
+        !--- Reduce excessive accumulation of ice at upper levels
+        !    associated with strong grid-resolved ascent
+        !
+        !--- Force NLICE to be between NLImin and NLImax
+        !
+        !
+        !--- 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.
+        !
+                  DUM=MAX(NLImin, MIN(NLImax, NLICE) )
+                  IF (DUM.GE.NLImax .AND. INDEXS.GE.MDImax)             &
+     &                RimeF1=RHO*(QTICE/NLImax-XSIMASS)/MASSI(INDEXS)
+!            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 T<T_ICE (-10C) if supersaturated.
+   !    Sources of ice due to nucleation and convective detrainment are
+   !    either poorly understood, poorly resolved at typical NWP 
+   !    resolutions, or are not represented (e.g., no detrained 
+   !    condensate in BMJ Cu scheme).
+   !    
+            PCOND=-QW
+            DUM1=TK+XLV1*PCOND                 ! Updated (dummy) temperature (deg K)
+            DUM2=WV+QW                         ! Updated (dummy) water vapor mixing ratio
+            DUM=1000.*FPVS(DUM1)               ! Updated (dummy) saturation vapor pressure w/r/t ice
+            DUM=RHgrd*EPS*DUM/(PP-DUM)         ! Updated (dummy) saturation mixing ratio w/r/t ice
+            IF (DUM2 .GT. DUM) PIDEP=DEPOSIT (PP, DUM1, DUM2)
+            DWVi=0.    ! Used only for debugging
+   !
+          ELSE IF (TC .LT. 0.) THEN
+   !
+   !--- These quantities are handy for ice deposition/sublimation
+   !    PIDEP_max - max deposition or minimum sublimation to ice saturation
+   !
+            DENOMI=1.+XLS2*QSI*TK2
+            DWVi=MIN(WVQW,QSW)-QSI
+            PIDEP_max=MAX(PILOSS, DWVi/DENOMI)
+            IF (QTICE .GT. 0.) THEN
+      !
+      !--- Calculate ice deposition/sublimation
+      !      * SFACTOR - [VEL_INC**.5]*[Schmidt**(1./3.)]*[(RHO/DYNVIS)**.5],
+      !        where Schmidt (Schmidt Number) =DYNVIS/(RHO*DIFFUS)
+      !      * Units: SFACTOR - s**.5/m ;  ABI - m**2/s ;  NLICE - m**-3 ;
+      !               VENTIL, VENTIS - m**-2 ;  VENTI1 - m ;  
+      !               VENTI2 - m**2/s**.5 ; DIDEP - unitless
+      !
+              SFACTOR=VEL_INC**.5*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2
+              ABI=1./(RHO*XLS3*QSI*TK2/THERM_COND+1./DIFFUS)
+      !
+      !--- VENTIL - Number concentration * ventilation factors for large ice
+      !--- VENTIS - Number concentration * ventilation factors for small ice
+      !
+      !--- Variation in the number concentration of ice with time is not
+      !      accounted for in these calculations (could be in the future).
+      !
+              VENTIL=(VENTI1(INDEXS)+SFACTOR*VENTI2(INDEXS))*NLICE
+              VENTIS=(VENTI1(MDImin)+SFACTOR*VENTI2(MDImin))*NSmICE
+              DIDEP=ABI*(VENTIL+VENTIS)*DTPH
+      !
+      !--- Account for change in water vapor supply w/ time
+      !
+              IF (DIDEP .GE. Xratio)then
+                DIDEP=(1.-EXP(-DIDEP*DENOMI))/DENOMI
+              endif
+              IF (DWVi .GT. 0.) THEN
+                PIDEP=MIN(DWVi*DIDEP, PIDEP_max)
+              ELSE IF (DWVi .LT. 0.) THEN
+                PIDEP=MAX(DWVi*DIDEP, PIDEP_max)
+              ENDIF
+      !
+            ELSE IF (WVQW.GT.QSI .AND. TC.LE.T_ICE_init) THEN
+      !
+      !--- Ice nucleation in near water-saturated conditions.  Ice crystal
+      !    growth during time step calculated using Miller & Young (1979, JAS).
+      !--- These deposition rates could drive conditions below water saturation,
+      !    which is the basis of these calculations.  Intended to approximate
+      !    more complex & computationally intensive calculations.
+      !
+              INDEX_MY=MAX(MY_T1, MIN( INT(.5-TC), MY_T2 ) )
+      !
+      !--- DUM1 is the supersaturation w/r/t ice at water-saturated conditions
+      !
+      !--- DUM2 is the number of ice crystals nucleated at water-saturated 
+      !    conditions based on Meyers et al. (JAM, 1992).
+      !
+      !--- Prevent unrealistically large ice initiation (limited by PIDEP_max)
+      !      if DUM2 values are increased in future experiments
+      !
+              DUM1=QSW/QSI-1.      
+              DUM2=1.E3*EXP(12.96*DUM1-.639)
+              PIDEP=MIN(PIDEP_max, DUM2*MY_GROWTH(INDEX_MY)*RRHO)
+      !
+            ENDIF       ! End IF (QTICE .GT. 0.)
+   !
+          ENDIF         ! End IF (TC.LT.T_ICE .AND. (WV.GT.QSIgrd .OR. QW.GT.EPSQ))
+!
+!------------------------------------------------------------------------
+!
+20      CONTINUE     ! Jump here if conditions for ice are not present
+
+
+!
+!------------------------------------------------------------------------
+!
+!--- Cloud water condensation
+!
+          IF (TC.GE.T_ICE .AND. (QW.GT.EPSQ .OR. WV.GT.QSWgrd)) THEN
+            IF (PIACWI.EQ.0. .AND. PIDEP.EQ.0.) THEN
+              PCOND=CONDENSE (PP, QW, TK, WV)
+            ELSE
+   !
+   !--- Modify cloud condensation in response to ice processes
+   !
+              DUM=XLV*QSWgrd*RCPRV*TK2
+              DENOMWI=1.+XLS*DUM
+              DENOMF=XLF*DUM
+              DUM=MAX(0., PIDEP)
+              PCOND=(WV-QSWgrd-DENOMWI*DUM-DENOMF*PIACWI)/DENOMW
+              DUM1=-QW
+              DUM2=PCOND-PIACW
+              IF (DUM2 .LT. DUM1) THEN
+      !
+      !--- Limit cloud water sinks
+      !
+                DUM=DUM1/DUM2
+                PCOND=DUM*PCOND
+                PIACW=DUM*PIACW
+                PIACWI=DUM*PIACWI
+              ENDIF        ! End IF (DUM2 .LT. DUM1)
+            ENDIF          ! End IF (PIACWI.EQ.0. .AND. PIDEP.EQ.0.)
+          ENDIF            ! End IF (TC.GE.T_ICE .AND. (QW.GT.EPSQ .OR. WV.GT.QSWgrd))
+!
+!--- Limit freezing of accreted rime to prevent temperature oscillations,
+!    a crude Schumann-Ludlam limit (p. 209 of Young, 1993). 
+!
+          TCC=TC+XLV1*PCOND+XLS1*PIDEP+XLF1*PIACWI
+          IF (TCC .GT. 0.) THEN
+            PIACWI=0.
+            TCC=TC+XLV1*PCOND+XLS1*PIDEP
+          ENDIF
+          IF (TC.GT.0. .AND. TCC.GT.0. .AND. ICE_logical) THEN
+   !
+   !--- Calculate melting and evaporation/condensation
+   !      * Units: SFACTOR - s**.5/m ;  ABI - m**2/s ;  NLICE - m**-3 ;
+   !               VENTIL - m**-2 ;  VENTI1 - m ;  
+   !               VENTI2 - m**2/s**.5 ; CIEVP - /s
+   !
+            SFACTOR=VEL_INC**.5*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2
+            VENTIL=NLICE*(VENTI1(INDEXS)+SFACTOR*VENTI2(INDEXS))
+            AIEVP=VENTIL*DIFFUS*DTPH
+            IF (AIEVP .LT. Xratio) THEN
+              DIEVP=AIEVP
+            ELSE
+              DIEVP=1.-EXP(-AIEVP)
+            ENDIF
+            QSW0=EPS*ESW0/(PP-ESW0)
+            DWV0=MIN(WV,QSW)-QSW0
+            DUM=QW+PCOND
+            IF (WV.LT.QSW .AND. DUM.LE.EPSQ) THEN
+   !
+   !--- Evaporation from melting snow (sink of snow) or shedding
+   !    of water condensed onto melting snow (source of rain)
+   !
+              DUM=DWV0*DIEVP
+              PIEVP=MAX( MIN(0., DUM), PILOSS)
+              PICND=MAX(0., DUM)
+            ENDIF            ! End IF (WV.LT.QSW .AND. DUM.LE.EPSQ)
+            PIMLT=THERM_COND*TCC*VENTIL*RRHO*DTPH/XLF
+   !
+   !--- Limit melting to prevent temperature oscillations across 0C
+   !
+            DUM1=MAX( 0., (TCC+XLV1*PIEVP)/XLF1 )
+            PIMLT=MIN(PIMLT, DUM1)
+   !
+   !--- Limit loss of snow by melting (>0) 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.
+          INDEXR=MDRmin
+          INDEXR1=INDEXR    !-- For debugging only
+          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<T_ICE ------------------
+!#######################################################################
+!
+      REAL FUNCTION DEPOSIT (PP, Tdum, WVdum)
+!
+!--- Also uses the Asai (1965) algorithm, but uses a different target
+!      vapor pressure for the adjustment
+!
+      IMPLICIT NONE      
+!
+      INTEGER, PARAMETER :: HIGH_PRES=Selected_Real_Kind(15)
+      REAL (KIND=HIGH_PRES), PARAMETER :: RHLIMIT=.001,                 &
+     & RHLIMIT1=-RHLIMIT
+      REAL (KIND=HIGH_PRES) :: DEP, SSAT
+!    
+      real,INTENT(IN) ::  PP
+      real,INTENT(INOUT) ::  WVdum,Tdum
+      real ESI,WS,DWV
+!
+!-----------------------------------------------------------------------
+!
+      ESI=1000.*FPVS(Tdum)                      ! Saturation vapor press w/r/t ice
+      WS=RHgrd*EPS*ESI/(PP-ESI)                 ! Saturation mixing ratio
+      DWV=WVdum-WS                              ! Deficit grid-scale water vapor mixing ratio
+      SSAT=DWV/WS                               ! Supersaturation ratio
+      DEPOSIT=0.
+      DO WHILE (SSAT.GT.RHLIMIT .OR. SSAT.LT.RHLIMIT1)
+   !
+   !--- Note that XLVS2=LS*LV/(CP*RV)=LV*WS/(RV*T*T)*(LS/CP*DEP1), 
+   !     where WS is the saturation mixing ratio following Clausius-
+   !     Clapeyron (see Asai,1965; Young,1993,p.405) 
+   !
+        DEP=DWV/(1.+XLS2*WS/(Tdum*Tdum))        ! Asai (1965, J. Japan)
+        Tdum=Tdum+XLS1*DEP                      ! Updated temperature
+        WVdum=WVdum-DEP                         ! Updated ice mixing ratio
+        DEPOSIT=DEPOSIT+DEP                     ! Total ice deposition
+        ESI=1000.*FPVS(Tdum)                    ! Updated saturation vapor press w/r/t ice
+        WS=RHgrd*EPS*ESI/(PP-ESI)               ! Updated saturation mixing ratio w/r/t ice
+        DWV=WVdum-WS                            ! Deficit grid-scale water vapor mixing ratio
+        SSAT=DWV/WS                             ! Grid-scale supersaturation ratio
+      ENDDO
+!
+      END FUNCTION DEPOSIT
+!
+      END SUBROUTINE EGCP01COLUMN 
+
+!#######################################################################
+!------- Initialize constants & lookup tables for microphysics ---------
+!#######################################################################
+!
+
+! SH 0211/2002
+
+!-----------------------------------------------------------------------
+      SUBROUTINE etanewinit (GSMDT,DT,DELX,DELY,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                                       )
+!-----------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!---  SUBPROGRAM DOCUMENTATION BLOCK
+!   PRGRMMR: Ferrier         ORG: W/NP22     DATE: February 2001
+!            Jin             ORG: W/NP22     DATE: January 2002 
+!        (Modification for WRF structure)
+!                                               
+!-------------------------------------------------------------------------------
+! ABSTRACT:
+!   * Reads various microphysical lookup tables used in COLUMN_MICRO
+!   * Lookup tables were created "offline" and are read in during execution
+!   * Creates lookup tables for saturation vapor pressure w/r/t water & ice
+!-------------------------------------------------------------------------------
+!     
+! USAGE: CALL etanewinit FROM SUBROUTINE GSMDRIVE AT MODEL START TIME
+!
+!   INPUT ARGUMENT LIST:
+!       DTPH - physics time step (s)
+!  
+!   OUTPUT ARGUMENT LIST: 
+!     NONE
+!     
+!   OUTPUT FILES:
+!     NONE
+!     
+!   SUBROUTINES:
+!     MY_GROWTH_RATES - lookup table for growth of nucleated ice
+!     GPVS            - lookup tables for saturation vapor pressure (water, ice)
+!
+!   UNIQUE: NONE
+!  
+!   LIBRARY: NONE
+!  
+!   COMMON BLOCKS:
+!     CMICRO_CONS - constants used in GSMCOLUMN
+!     CMY600       - 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
+!     MAPOT        - Need lat/lon grid resolution
+!     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
+!
+!-----------------------------------------------------------------------
+!
+!
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+!------------------------------------------------------------------------- 
+!-------------- Parameters & arrays for lookup tables -------------------- 
+!------------------------------------------------------------------------- 
+!
+!--- Common block of constants used in column microphysics
+!
+!WRF
+!     real DLMD,DPHD
+!WRF
+!
+!-----------------------------------------------------------------------
+!--- Parameters & data statement for local calculations
+!-----------------------------------------------------------------------
+!
+      INTEGER, PARAMETER :: MDR1=XMR1, MDR2=XMR2, MDR3=XMR3
+!
+!     VARIABLES PASSED IN
+      integer,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     & 
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE       
+!WRF
+       INTEGER, DIMENSION(ims:ime,jms:jme),INTENT(INOUT) :: LOWLYR
+!
+      real, INTENT(IN) ::  DELX,DELY
+      real,DIMENSION(*), INTENT(INOUT) :: MP_RESTART_STATE
+      real,DIMENSION(NX), INTENT(INOUT) :: TBPVS_STATE,TBPVS0_STATE
+      real,DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(OUT) ::          &
+     &  F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY
+      INTEGER, PARAMETER :: ITLO=-60, ITHI=40
+!     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,INTENT(INOUT) :: PRECtot(2),PRECmax(2)
+      real,INTENT(IN) :: DT,GSMDT
+      LOGICAL,INTENT(IN) :: allowed_to_read,restart
+!
+!-----------------------------------------------------------------------
+!     LOCAL VARIABLES
+!-----------------------------------------------------------------------
+      REAL :: BBFR,DTPH,PI,DX,Thour_print
+      INTEGER :: I,IM,J,L,K,JTF,KTF,ITF
+      INTEGER :: etampnew_unit1
+      LOGICAL, PARAMETER :: PRINT_diag=.FALSE.
+      LOGICAL :: opened
+      LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
+      CHARACTER*80 errmess
+!
+!-----------------------------------------------------------------------
+!
+      JTF=MIN0(JTE,JDE-1)
+      KTF=MIN0(KTE,KDE-1)
+      ITF=MIN0(ITE,IDE-1)
+!
+      DO J=JTS,JTF
+      DO I=ITS,ITF
+        LOWLYR(I,J)=1
+      ENDDO
+      ENDDO
+!    
+      IF(.NOT.RESTART)THEN
+        DO J = jts,jte
+        DO K = kts,kte
+        DO I= its,ite
+          F_ICE_PHY(i,k,j)=0.
+          F_RAIN_PHY(i,k,j)=0.
+          F_RIMEF_PHY(i,k,j)=1.
+        ENDDO
+        ENDDO
+        ENDDO
+      ENDIF
+!    
+!-----------------------------------------------------------------------
+      IF(ALLOWED_TO_READ)THEN
+!-----------------------------------------------------------------------
+!
+        DX=((DELX)**2+(DELY)**2)**.5/1000.    ! Model resolution at equator (km)
+        DX=MIN(100., MAX(5., DX) )
+!
+!-- Relative humidity threshold for the onset of grid-scale condensation
+!!-- 9/1/01:  Assume the following functional dependence for 5 - 100 km resolution:
+!!       RHgrd=0.90 for dx=100 km, 0.98 for dx=5 km, where
+!        RHgrd=0.90+.08*((100.-DX)/95.)**.5
+!
+        DTPH=MAX(GSMDT*60.,DT)
+        DTPH=NINT(DTPH/DT)*DT
+!
+!--- Create lookup tables for saturation vapor pressure w/r/t water & ice
+!
+        CALL GPVS
+!
+!--- Read in various lookup tables
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              etampnew_unit1 = i
+              GOTO 2061
+            ENDIF
+          ENDDO
+          etampnew_unit1 = -1
+ 2061     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( etampnew_unit1 , IWORDSIZE )
+!
+        IF ( etampnew_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_etanew: etanewinit: Can not find '// &
+                                 'unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+!!was     OPEN (UNIT=1,FILE="eta_micro_lookup.dat",FORM="UNFORMATTED")
+          OPEN(UNIT=etampnew_unit1,FILE="ETAMPNEW_DATA",                  &
+     &        FORM="UNFORMATTED",STATUS="OLD",ERR=9061)
+!
+          READ(etampnew_unit1) VENTR1
+          READ(etampnew_unit1) VENTR2
+          READ(etampnew_unit1) ACCRR
+          READ(etampnew_unit1) MASSR
+          READ(etampnew_unit1) VRAIN
+          READ(etampnew_unit1) RRATE
+          READ(etampnew_unit1) VENTI1
+          READ(etampnew_unit1) VENTI2
+          READ(etampnew_unit1) ACCRI
+          READ(etampnew_unit1) MASSI
+          READ(etampnew_unit1) VSNOWI
+          READ(etampnew_unit1) VEL_RF
+!        read(etampnew_unit1) my_growth    ! Applicable only for DTPH=180 s
+          CLOSE (etampnew_unit1)
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( VENTR1 , size ( VENTR1 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VENTR2 , size ( VENTR2 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( ACCRR , size ( ACCRR ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( MASSR , size ( MASSR ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VRAIN , size ( VRAIN ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( RRATE , size ( RRATE ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VENTI1 , size ( VENTI1 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VENTI2 , size ( VENTI2 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( ACCRI , size ( ACCRI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( MASSI , size ( MASSI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VSNOWI , size ( VSNOWI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VEL_RF , size ( VEL_RF ) * RWORDSIZE )
+!
+!--- Calculates coefficients for growth rates of ice nucleated in water
+!    saturated conditions, scaled by physics time step (lookup table)
+!
+        CALL MY_GROWTH_RATES (DTPH)
+!       CALL MY_GROWTH_RATES (DTPH,MY_GROWTH)
+!
+        PI=ACOS(-1.)
+!
+!--- Constants associated with Biggs (1953) freezing of rain, as parameterized
+!    following Lin et al. (JCAM, 1983) & Reisner et al. (1998, QJRMS).
+!
+        ABFR=-0.66
+        BBFR=100.
+        CBFR=20.*PI*PI*BBFR*RHOL*1.E-21
+!
+!--- CIACW is used in calculating riming rates
+!      The assumed effective collection efficiency of cloud water rimed onto
+!      ice is =0.5 below:
+!
+        CIACW=DTPH*0.25*PI*0.5*(1.E5)**C1
+!
+!--- CIACR is used in calculating freezing of rain colliding with large ice
+!      The assumed collection efficiency is 1.0
+!
+        CIACR=PI*DTPH
+!
+!--- Based on rain lookup tables for mean diameters from 0.05 to 0.45 mm
+!    * Four different functional relationships of mean drop diameter as 
+!      a function of rain rate (RR), derived based on simple fits to 
+!      mass-weighted fall speeds of rain as functions of mean diameter
+!      from the lookup tables.  
+!
+        RR_DRmin=N0r0*RRATE(MDRmin)     ! RR for mean drop diameter of .05 mm
+        RR_DR1=N0r0*RRATE(MDR1)         ! RR for mean drop diameter of .10 mm
+        RR_DR2=N0r0*RRATE(MDR2)         ! RR for mean drop diameter of .20 mm
+        RR_DR3=N0r0*RRATE(MDR3)         ! RR for mean drop diameter of .32 mm
+        RR_DRmax=N0r0*RRATE(MDRmax)     ! RR for mean drop diameter of .45 mm
+!
+        RQR_DRmin=N0r0*MASSR(MDRmin)    ! Rain content for mean drop diameter of .05 mm
+        RQR_DR1=N0r0*MASSR(MDR1)        ! Rain content for mean drop diameter of .10 mm
+        RQR_DR2=N0r0*MASSR(MDR2)        ! Rain content for mean drop diameter of .20 mm
+        RQR_DR3=N0r0*MASSR(MDR3)        ! Rain content for mean drop diameter of .32 mm
+        RQR_DRmax=N0r0*MASSR(MDRmax)    ! Rain content for mean drop diameter of .45 mm
+        C_N0r0=PI*RHOL*N0r0
+        CN0r0=1.E6/C_N0r0**.25
+        CN0r_DMRmin=1./(PI*RHOL*DMRmin**4)
+        CN0r_DMRmax=1./(PI*RHOL*DMRmax**4)
+!
+!--- CRACW is used in calculating collection of cloud water by rain (an
+!      assumed collection efficiency of 1.0)
+!
+        CRACW=DTPH*0.25*PI*1.0
+!
+        ESW0=1000.*FPVS0(T0C)     ! Saturation vapor pressure at 0C
+        RFmax=1.1**Nrime          ! Maximum rime factor allowed
+!
+!------------------------------------------------------------------------
+!--------------- Constants passed through argument list -----------------
+!------------------------------------------------------------------------
+!
+!--- Important parameters for self collection (autoconversion) of 
+!    cloud water to rain. 
+!
+!--- CRAUT is proportional to the rate that cloud water is converted by
+!      self collection to rain (autoconversion rate)
+!
+        CRAUT=1.-EXP(-1.E-3*DTPH)
+!
+!--- QAUT0 is the threshold cloud content for autoconversion to rain 
+!      needed for droplets to reach a diameter of 20 microns (following
+!      Manton and Cotton, 1977; Banta and Hanson, 1987, JCAM)
+!--- QAUT0=1.2567, 0.8378, or 0.4189 g/m**3 for droplet number concentrations
+!          of 300, 200, and 100 cm**-3, respectively
+!
+        QAUT0=PI*RHOL*NCW*(20.E-6)**3/6.
+!
+!--- For calculating snow optical depths by considering bulk density of
+!      snow based on emails from Q. Fu (6/27-28/01), where optical 
+!      depth (T) = 1.5*SWP/(Reff*DENS), SWP is snow water path, Reff 
+!      is effective radius, and DENS is the bulk density of snow.
+!
+!    SWP (kg/m**2)=(1.E-3 kg/g)*SWPrad, SWPrad in g/m**2 used in radiation
+!    T = 1.5*1.E3*SWPrad/(Reff*DENS)
+!  
+!    See derivation for MASSI(INDEXS), note equal to RHO*QSNOW/NSNOW
+!
+!      SDENS=1.5e3/DENS, DENS=MASSI(INDEXS)/[PI*(1.E-6*INDEXS)**3]
+!
+        DO I=MDImin,MDImax
+          SDENS(I)=PI*1.5E-15*FLOAT(I*I*I)/MASSI(I)
+        ENDDO
+!
+        Thour_print=-DTPH/3600.
+
+! SH 0211/2002
+!       IF (PRINT_diag) THEN
+       
+      !-------- Total and maximum quantities
+      !
+!         NSTATS=0      ! Microphysical statistics dealing w/ grid-point counts
+!         QMAX=0.       ! Microphysical statistics dealing w/ hydrometeor mass
+!         QTOT=0.       ! Microphysical statistics dealing w/ hydrometeor mass
+!         PRECmax=0.    ! Maximum precip rates (rain, snow) at surface (mm/h)
+!         PRECtot=0.    ! Total precipitation (rain, snow) accumulation at surface
+!       ENDIF
+
+!wrf
+        IF(.NOT.RESTART)THEN
+          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)
+        ENDIF
+
+      ENDIF  ! Allowed_to_read
+
+      RETURN
+!
+!-----------------------------------------------------------------------
+!
+9061 CONTINUE
+      WRITE( errmess , '(A,I4)' )                                        &
+       'module_mp_etanew: error opening ETAMPNEW_DATA on unit '          &
+     &, etampnew_unit1
+      CALL wrf_error_fatal(errmess)
+!
+!-----------------------------------------------------------------------
+      END SUBROUTINE etanewinit
+!
+      SUBROUTINE MY_GROWTH_RATES (DTPH)
+!     SUBROUTINE MY_GROWTH_RATES (DTPH,MY_GROWTH)
+!
+!--- Below are tabulated values for the predicted mass of ice crystals
+!    after 600 s of growth in water saturated conditions, based on 
+!    calculations from Miller and Young (JAS, 1979).  These values are
+!    crudely estimated from tabulated curves at 600 s from Fig. 6.9 of
+!    Young (1993).  Values at temperatures colder than -27C were 
+!    assumed to be invariant with temperature.  
+!
+!--- Used to normalize Miller & Young (1979) calculations of ice growth
+!    over large time steps using their tabulated values at 600 s.
+!    Assumes 3D growth with time**1.5 following eq. (6.3) in Young (1993).
+!
+      IMPLICIT NONE
+!
+      REAL,INTENT(IN) :: DTPH
+!
+      REAL  DT_ICE
+      REAL,DIMENSION(35) :: MY_600
+!WRF
+!
+!-----------------------------------------------------------------------
+      DATA MY_600 /                                                     &
+     & 5.5e-8, 1.4E-7, 2.8E-7, 6.E-7, 3.3E-6,                           & 
+     & 2.E-6, 9.E-7, 8.8E-7, 8.2E-7, 9.4e-7,                            & 
+     & 1.2E-6, 1.85E-6, 5.5E-6, 1.5E-5, 1.7E-5,                         & 
+     & 1.5E-5, 1.E-5, 3.4E-6, 1.85E-6, 1.35E-6,                         & 
+     & 1.05E-6, 1.E-6, 9.5E-7, 9.0E-7, 9.5E-7,                          & 
+     & 9.5E-7, 9.E-7, 9.E-7, 9.E-7, 9.E-7,                              & 
+     & 9.E-7, 9.E-7, 9.E-7, 9.E-7, 9.E-7 /        ! -31 to -35 deg C
+!
+!-----------------------------------------------------------------------
+!
+      DT_ICE=(DTPH/600.)**1.5
+      MY_GROWTH=DT_ICE*MY_600
+!
+!-----------------------------------------------------------------------
+!
+      END SUBROUTINE MY_GROWTH_RATES
+!
+!-----------------------------------------------------------------------
+!---------  Old GFS saturation vapor pressure lookup tables  -----------
+!-----------------------------------------------------------------------
+!
+      SUBROUTINE GPVS
+!     ******************************************************************
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    GPVS        COMPUTE SATURATION VAPOR PRESSURE TABLE
+!   AUTHOR: N PHILLIPS       W/NP2      DATE: 30 DEC 82
+!
+! ABSTRACT: COMPUTE 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.0 TO 330.0 KELVIN.
+!
+! PROGRAM HISTORY LOG:
+!   91-05-07  IREDELL
+!   94-12-30  IREDELL             EXPAND TABLE
+!   96-02-19  HONG                ICE EFFECT
+!   01-11-29  JIN                 MODIFIED FOR WRF
+!
+! USAGE:  CALL GPVS
+!
+! SUBPROGRAMS CALLED:
+!   (FPVSX)  - INLINABLE FUNCTION TO COMPUTE SATURATION VAPOR PRESSURE
+!
+! COMMON BLOCKS:
+!   COMPVS   - SCALING PARAMETERS AND TABLE FOR FUNCTION FPVS.
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!
+!$$$
+      IMPLICIT NONE
+      real :: X,XINC,T
+      integer :: JX
+!----------------------------------------------------------------------
+      XINC=(XMAX-XMIN)/(NX-1)
+      C1XPVS=1.-XMIN/XINC
+      C2XPVS=1./XINC
+      C1XPVS0=1.-XMIN/XINC
+      C2XPVS0=1./XINC
+!
+      DO JX=1,NX
+        X=XMIN+(JX-1)*XINC
+        T=X
+        TBPVS(JX)=FPVSX(T)
+        TBPVS0(JX)=FPVSX0(T)
+      ENDDO
+! 
+      END SUBROUTINE GPVS
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+                     REAL   FUNCTION FPVS(T)
+!-----------------------------------------------------------------------
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    FPVS        COMPUTE SATURATION VAPOR PRESSURE
+!   AUTHOR: N PHILLIPS            W/NP2      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
+!   96-02-19  HONG                ICE EFFECT
+!   01-11-29  JIN                 MODIFIED FOR WRF
+!
+! USAGE:   PVS=FPVS(T)
+!
+!   INPUT ARGUMENT LIST:
+!     T        - REAL TEMPERATURE IN KELVIN
+!
+!   OUTPUT ARGUMENT LIST:
+!     FPVS     - REAL SATURATION VAPOR PRESSURE IN KILOPASCALS (CB)
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!$$$
+      IMPLICIT NONE
+      real,INTENT(IN) :: T
+      real XJ
+      integer :: JX
+!-----------------------------------------------------------------------
+      XJ=MIN(MAX(C1XPVS+C2XPVS*T,1.),FLOAT(NX))
+      JX=MIN(XJ,NX-1.)
+      FPVS=TBPVS(JX)+(XJ-JX)*(TBPVS(JX+1)-TBPVS(JX))
+!
+      END FUNCTION FPVS
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+                     REAL FUNCTION FPVS0(T)
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+      real,INTENT(IN) :: T
+      real :: XJ1
+      integer :: JX1
+!-----------------------------------------------------------------------
+      XJ1=MIN(MAX(C1XPVS0+C2XPVS0*T,1.),FLOAT(NX))
+      JX1=MIN(XJ1,NX-1.)
+      FPVS0=TBPVS0(JX1)+(XJ1-JX1)*(TBPVS0(JX1+1)-TBPVS0(JX1))
+!
+      END FUNCTION FPVS0
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+                    REAL FUNCTION FPVSX(T)
+!-----------------------------------------------------------------------
+!$$$  SUBPROGRAM DOCUMENTATION BLOCK
+!                .      .    .
+! SUBPROGRAM:    FPVSX       COMPUTE SATURATION VAPOR PRESSURE
+!   AUTHOR: N PHILLIPS            W/NP2      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
+!       PVS=PSATK*(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
+!   96-02-19  HONG                ICE EFFECT 
+!   01-11-29  JIN                 MODIFIED FOR WRF
+!
+! USAGE:   PVS=FPVSX(T)
+! REFERENCE:   EMANUEL(1994),116-117
+!
+!   INPUT ARGUMENT LIST:
+!     T        - REAL TEMPERATURE IN KELVIN
+!
+!   OUTPUT ARGUMENT LIST:
+!     FPVSX    - REAL SATURATION VAPOR PRESSURE IN KILOPASCALS (CB)
+!
+! ATTRIBUTES:
+!   LANGUAGE: FORTRAN 90
+!$$$
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+       real, parameter :: TTP=2.7316E+2,HVAP=2.5000E+6,PSAT=6.1078E+2   &
+      ,         CLIQ=4.1855E+3,CVAP= 1.8460E+3                          &
+      ,         CICE=2.1060E+3,HSUB=2.8340E+6
+!
+      real, parameter :: PSATK=PSAT*1.E-3
+      real, parameter :: DLDT=CVAP-CLIQ,XA=-DLDT/RV,XB=XA+HVAP/(RV*TTP)
+      real, parameter :: DLDTI=CVAP-CICE                                &
+      ,                  XAI=-DLDTI/RV,XBI=XAI+HSUB/(RV*TTP)
+      real T,TR
+!-----------------------------------------------------------------------
+      TR=TTP/T
+!
+      IF(T.GE.TTP)THEN
+        FPVSX=PSATK*(TR**XA)*EXP(XB*(1.-TR))
+      ELSE
+        FPVSX=PSATK*(TR**XAI)*EXP(XBI*(1.-TR))
+      ENDIF
+! 
+      END FUNCTION FPVSX
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+                 REAL   FUNCTION FPVSX0(T)
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+      real,parameter :: TTP=2.7316E+2,HVAP=2.5000E+6,PSAT=6.1078E+2     &
+      ,         CLIQ=4.1855E+3,CVAP=1.8460E+3                           &
+      ,         CICE=2.1060E+3,HSUB=2.8340E+6
+      real,PARAMETER :: PSATK=PSAT*1.E-3
+      real,PARAMETER :: DLDT=CVAP-CLIQ,XA=-DLDT/RV,XB=XA+HVAP/(RV*TTP)
+      real,PARAMETER :: DLDTI=CVAP-CICE                                 &
+      ,                 XAI=-DLDT/RV,XBI=XA+HSUB/(RV*TTP)
+      real :: T,TR
+!-----------------------------------------------------------------------
+      TR=TTP/T
+      FPVSX0=PSATK*(TR**XA)*EXP(XB*(1.-TR))
+!
+      END FUNCTION FPVSX0
+!
+      END MODULE module_mp_etanew
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_gsfcgce.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_gsfcgce.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_gsfcgce.F	(revision 17)
@@ -0,0 +1,2838 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+
+MODULE module_mp_gsfcgce
+
+   USE     module_wrf_error
+
+!JJS 1/3/2008     vvvvv
+
+!  common /bt/
+   REAL,    PRIVATE ::          rd1,  rd2,   al,   cp
+
+!  common /cont/
+   REAL,    PRIVATE ::          c38, c358, c610, c149, &
+                               c879, c172, c409,  c76, &
+                               c218, c580, c141
+!  common /b3cs/
+   REAL,    PRIVATE ::           ag,   bg,   as,   bs, &
+                                 aw,   bw,  bgh,  bgq, &
+                                bsh,  bsq,  bwh,  bwq
+
+!  common /size/
+   REAL,    PRIVATE ::          tnw,  tns,  tng,       &
+                               roqs, roqg, roqr
+
+!  common /bterv/
+   REAL,    PRIVATE ::          zrc,  zgc,  zsc,       &
+                                vrc,  vgc,  vsc
+
+!  common /bsnw/
+   REAL,    PRIVATE ::          alv,  alf,  als,   t0,   t00,     &
+                                avc,  afc,  asc,  rn1,  bnd1,     &
+                                rn2, bnd2,  rn3,  rn4,   rn5,     &
+                                rn6,  rn7,  rn8,  rn9,  rn10,     &
+                              rn101,rn10a, rn11,rn11a,  rn12
+
+   REAL,    PRIVATE ::         rn14, rn15,rn15a, rn16,  rn17,     &
+                              rn17a,rn17b,rn17c, rn18, rn18a,     &
+                               rn19,rn19a,rn19b, rn20, rn20a,     &
+                              rn20b, bnd3, rn21, rn22,  rn23,     &
+                              rn23a,rn23b, rn25,rn30a, rn30b,     &
+                              rn30c, rn31, beta, rn32
+
+   REAL,    PRIVATE, DIMENSION( 31 ) ::    rn12a, rn12b, rn13, rn25a
+
+!  common /rsnw1/
+   REAL,    PRIVATE ::         rn10b, rn10c, rnn191, rnn192,  rn30,     &
+                             rnn30a,  rn33,  rn331,  rn332
+
+!
+   REAL,    PRIVATE, DIMENSION( 31 )  ::      aa1,  aa2
+   DATA aa1/.7939e-7, .7841e-6, .3369e-5, .4336e-5, .5285e-5,     &
+           .3728e-5, .1852e-5, .2991e-6, .4248e-6, .7434e-6,     &
+           .1812e-5, .4394e-5, .9145e-5, .1725e-4, .3348e-4,     &
+           .1725e-4, .9175e-5, .4412e-5, .2252e-5, .9115e-6,     &
+           .4876e-6, .3473e-6, .4758e-6, .6306e-6, .8573e-6,     &
+           .7868e-6, .7192e-6, .6513e-6, .5956e-6, .5333e-6,     &
+           .4834e-6/
+   DATA aa2/.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/
+
+!JJS 1/3/2008     ^^^^^
+
+CONTAINS
+
+!-------------------------------------------------------------------
+!  NASA/GSFC GCE
+!  Tao et al, 2001, Meteo. & Atmos. Phy., 97-137
+!-------------------------------------------------------------------
+!  SUBROUTINE gsfcgce(  th, th_old,                                 &
+  SUBROUTINE gsfcgce(  th,                                         &
+                       qv, ql,                                     &
+                       qr, qi,                                     &
+                       qs,                                         &
+!                       qvold, qlold,                               &
+!                       qrold, qiold,                               &
+!                       qsold,                                      &
+                       rho, pii, p, dt_in, z,                      &
+                       ht, dz8w, grav,                             &
+                       rhowater, rhosnow,                          &
+                       itimestep,                                  &
+                       ids,ide, jds,jde, kds,kde,                  & ! domain dims
+                       ims,ime, jms,jme, kms,kme,                  & ! memory dims
+                       its,ite, jts,jte, kts,kte,                  & ! tile   dims
+                       rainnc, rainncv,                            &
+                       snownc, snowncv, sr,                        &
+                       graupelnc, graupelncv,                      &
+!                       f_qg, qg, pgold,                            &
+                       f_qg, qg,                                   &
+                       ihail, ice2                                 &
+                                                                   )
+
+!-------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------
+!
+! JJS 2/15/2005
+!
+  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, ihail, ice2 
+
+  REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
+        INTENT(INOUT) ::                                          &
+                                                              th, &
+                                                              qv, &
+                                                              ql, &
+                                                              qr, &
+                                                              qi, &
+                                                              qs, &
+                                                              qg
+!
+  REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
+        INTENT(IN   ) ::                                          &
+!                                                         th_old, &
+!                                                          qvold, &
+!                                                          qlold, &
+!                                                          qrold, &
+!                                                          qiold, &
+!                                                          qsold, &
+!                                                          qgold, &
+                                                             rho, &
+                                                             pii, &
+                                                               p, &
+                                                            dz8w, &
+                                                               z
+
+  REAL, DIMENSION( ims:ime , jms:jme ),                           &
+        INTENT(INOUT) ::                               rainnc,    &
+                                                       rainncv,   &
+                                                       snownc,    &   
+                                                       snowncv,   &
+                                                       sr,        &
+                                                       graupelnc, &
+                                                       graupelncv 
+
+  REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) ::       ht
+
+  REAL, INTENT(IN   ) ::                                   dt_in, &
+                                                            grav, &
+                                                        rhowater, &
+                                                         rhosnow
+
+  LOGICAL, INTENT(IN), OPTIONAL :: F_QG
+
+!  LOCAL VAR
+
+
+!jjs  INTEGER             ::                            min_q, max_q
+
+!jjs  REAL, DIMENSION( its:ite , jts:jte )                            &
+!jjs                               ::        rain, snow, graupel,ice
+
+!
+!  INTEGER :: IHAIL, itaobraun, ice2, istatmin, new_ice_sat, id
+  INTEGER ::  itaobraun, istatmin, new_ice_sat, id
+
+  INTEGER :: i, j, k
+  INTEGER :: iskip, ih, icount, ibud, i24h 
+  REAL    :: hour
+  REAL    , PARAMETER :: cmin=1.e-20
+  REAL    :: dth, dqv, dqrest, dqall, dqall1, rhotot, a1, a2 
+!  REAL, DIMENSION( its:ite , kts:kte , jts:jte ) ::                   &
+!                         th1, qv1, ql1, qr1, qi1, qs1, qg1
+ 
+  LOGICAL :: flag_qg
+
+!
+!c  ihail = 0    for graupel, for tropical region
+!c  ihail = 1    for hail, for mid-lat region
+
+! itaobraun: 0 for Tao's constantis, 1 for Braun's constants
+!c        if ( itaobraun.eq.1 ) --> betah=0.5*beta=-.46*0.5=-0.23;   cn0=1.e-6
+!c        if ( itaobraun.eq.0 ) --> betah=0.5*beta=-.6*0.5=-0.30;    cn0=1.e-8
+   itaobraun = 1
+
+!c  ice2 = 0    for 3 ice --- ice, snow and graupel/hail
+!c  ice2 = 1    for 2 ice --- ice and snow only
+!c  ice2 = 2    for 2 ice --- ice and graupel only, use ihail = 0 only
+!c  ice2 = 3    for 0 ice --- no ice, warm only
+
+!  if (ice2 .eq. 2) ihail = 0
+
+  i24h=nint(86400./dt_in)
+  if (mod(itimestep,i24h).eq.1) then
+     write(6,*) 'ihail=',ihail,'  ice2=',ice2
+     if (ice2.eq.0) then
+        write(6,*) 'Running 3-ice scheme in GSFCGCE with'
+        if (ihail.eq.0) then 
+           write(6,*) '     ice, snow and graupel'
+        else if (ihail.eq.1) then
+                write(6,*) '     ice, snow and hail'
+        else
+             write(6,*) 'ihail has to be either 1 or 0'
+             stop
+        endif !ihail
+     else if (ice2.eq.1) then
+             write(6,*) 'Running 2-ice scheme in GSFCGCE with'
+             write(6,*) '     ice and snow'
+     else if (ice2.eq.2) then
+             write(6,*) 'Running 2-ice scheme in GSFCGCE with'
+             write(6,*) '     ice and graupel'
+     else if (ice2.eq.3) then
+             write(6,*) 'Running warm rain only scheme in GSFCGCE without any ice'
+     else
+             write(6,*) 'gsfcgce_2ice in namelist.input has to be 0, 1, 2, or 3'
+             stop
+     endif !ice2
+  endif !itimestep
+
+!c  new_ice_sat = 0, 1 or 2 
+    new_ice_sat = 2 
+
+!c istatmin
+    istatmin = 180
+
+!c id = 0  without in-line staticstics
+!c id = 1  with in-line staticstics
+    id = 0
+
+!c ibud = 0 no calculation of dth, dqv, dqrest and dqall
+!c ibud = 1 yes
+    ibud = 0
+
+!jjs   dt=dt_in
+!jjs   rhoe_s=1.29
+!
+!   IF (P_QI .lt. P_FIRST_SCALAR .or. P_QS .lt. P_FIRST_SCALAR) THEN
+!      CALL wrf_error_fatal3 ( "module_mp_lin.b" , 130 ,  'module_mp_lin: Improper use of Lin et al scheme; no ice phase. Please chose another one.')
+!   ENDIF
+
+! calculte fallflux and precipiation in MKS system
+
+   call fall_flux(dt_in, qr, qi, qs, qg, p,                   &
+                      rho, z, dz8w, ht, rainnc,               &
+                      rainncv, grav,itimestep,                &
+                      rhowater, rhosnow,                      &
+                      snownc, snowncv, sr,                    &
+                      graupelnc, graupelncv,                  &
+                      ihail, ice2,                            &
+                      ims,ime, jms,jme, kms,kme,              & ! memory dims
+                      its,ite, jts,jte, kts,kte               ) ! tile   dims
+!-----------------------------------------------------------------------
+
+!c  set up constants used internally in GCE
+
+   call consat_s (ihail, itaobraun)
+
+
+!c Negative values correction
+
+   iskip = 1
+ 
+   if (iskip.eq.0) then
+      call negcor(qv,rho,dz8w,ims,ime,jms,jme,kms,kme, &
+                           itimestep,1,             &
+                           its,ite,jts,jte,kts,kte)
+      call negcor(ql,rho,dz8w,ims,ime,jms,jme,kms,kme, &
+                           itimestep,2,             &
+                           its,ite,jts,jte,kts,kte)
+      call negcor(qr,rho,dz8w,ims,ime,jms,jme,kms,kme, &
+                           itimestep,3,             &
+                           its,ite,jts,jte,kts,kte)
+      call negcor(qi,rho,dz8w,ims,ime,jms,jme,kms,kme, &
+                           itimestep,4,             &
+                           its,ite,jts,jte,kts,kte)
+      call negcor(qs,rho,dz8w,ims,ime,jms,jme,kms,kme, &
+                           itimestep,5,             &
+                           its,ite,jts,jte,kts,kte)
+      call negcor(qg,rho,dz8w,ims,ime,jms,jme,kms,kme, &
+                           itimestep,6,             &
+                           its,ite,jts,jte,kts,kte)
+!   else if (mod(itimestep,i24h).eq.1) then
+!      print *,'no neg correction in mp at timestep=',itimestep
+   endif ! iskip
+
+!c microphysics in GCE
+
+   call SATICEL_S( dt_in, IHAIL, itaobraun, ICE2, istatmin,     &
+                   new_ice_sat, id,                             &
+!                   th, th_old, qv, ql, qr,                      &
+                   th, qv, ql, qr,                      &
+                   qi, qs, qg,                                  &
+!                   qvold, qlold, qrold,                         &
+!                   qiold, qsold, qgold,                         &
+                   rho, pii, p, itimestep,                      & 
+                   ids,ide, jds,jde, kds,kde,                   & ! domain dims
+                   ims,ime, jms,jme, kms,kme,                   & ! memory dims
+                   its,ite, jts,jte, kts,kte                    & ! tile   dims
+                                                                ) 
+
+   END SUBROUTINE gsfcgce
+
+!-----------------------------------------------------------------------
+   SUBROUTINE fall_flux ( dt, qr, qi, qs, qg, p,              &
+                      rho, z, dz8w, topo, rainnc,             &
+                      rainncv, grav, itimestep,               &
+                      rhowater, rhosnow,                      &
+                      snownc, snowncv, sr,                    &
+                      graupelnc, graupelncv,                  &
+                      ihail, ice2,                            &
+                      ims,ime, jms,jme, kms,kme,              & ! memory dims
+                      its,ite, jts,jte, kts,kte               ) ! tile   dims
+!-----------------------------------------------------------------------
+! adopted from Jiun-Dar Chern's codes for Purdue Regional Model
+! adopted by Jainn J. Shi, 6/10/2005
+!-----------------------------------------------------------------------
+
+  IMPLICIT NONE
+  INTEGER, INTENT(IN   )               :: ihail, ice2,                &
+                                          ims,ime, jms,jme, kms,kme,  &
+                                          its,ite, jts,jte, kts,kte 
+  INTEGER, INTENT(IN   )               :: itimestep
+  REAL,    DIMENSION( ims:ime , kms:kme , jms:jme ),                  &
+           INTENT(INOUT)               :: qr, qi, qs, qg       
+  REAL,    DIMENSION( ims:ime , jms:jme ),                            &
+           INTENT(INOUT)               :: rainnc, rainncv,            &
+                                          snownc, snowncv, sr,        &
+                                          graupelnc, graupelncv
+  REAL,    DIMENSION( ims:ime , kms:kme , jms:jme ),                  &
+           INTENT(IN   )               :: rho, z, dz8w, p     
+
+  REAL,    INTENT(IN   )               :: dt, grav, rhowater, rhosnow
+
+
+  REAL,    DIMENSION( ims:ime , jms:jme ),                            &
+           INTENT(IN   )               :: topo   
+
+! temperary vars
+
+  REAL,    DIMENSION( kts:kte )           :: sqrhoz
+  REAL                                    :: tmp1, term0
+  REAL                                :: pptrain, pptsnow,        &
+                                         pptgraul, pptice
+  REAL,    DIMENSION( kts:kte )       :: qrz, qiz, qsz, qgz,      &
+                                         zz, dzw, prez, rhoz,     &
+                                         orhoz
+
+
+   INTEGER                    :: k, i, j
+!
+
+  REAL, DIMENSION( kts:kte )    :: vtr, vts, vtg, vti
+
+  REAL                          :: dtb, pi, consta, constc, gambp4,    &
+                                   gamdp4, gam4pt5, gam4bbar
+
+!  Lin
+   REAL    , PARAMETER ::     xnor = 8.0e6
+!   REAL    , PARAMETER ::     xnos = 3.0e6
+   REAL    , PARAMETER ::     xnos = 1.6e7   ! Tao's value
+   REAL    , PARAMETER ::                              &
+!             constb = 0.8, constd = 0.25, o6 = 1./6.,           &
+             constb = 0.8, constd = 0.11, o6 = 1./6.,           &
+             cdrag = 0.6
+!  Lin
+!  REAL    , PARAMETER ::     xnoh = 4.0e4
+  REAL    , PARAMETER ::     xnoh = 2.0e5    ! Tao's value
+  REAL    , PARAMETER ::     rhohail = 917.
+
+! Hobbs
+  REAL    , PARAMETER ::     xnog = 4.0e6
+  REAL    , PARAMETER ::     rhograul = 400.
+  REAL    , PARAMETER ::     abar = 19.3, bbar = 0.37,      &
+                                      p0 = 1.0e5
+
+  REAL    , PARAMETER ::     rhoe_s = 1.29
+
+! for terminal velocity flux
+  INTEGER                       :: min_q, max_q
+  REAL                          :: t_del_tv, del_tv, flux, fluxin, fluxout ,tmpqrz
+  LOGICAL                       :: notlast
+
+!  if (itimestep.eq.1) then
+!     write(6, *) 'in fall_flux'
+!     write(6, *) 'ims=', ims, '  ime=', ime
+!     write(6, *) 'jms=', jms, '  jme=', jme
+!     write(6, *) 'kms=', kms, '  kme=', kme
+!     write(6, *) 'its=', its, '  ite=', ite
+!     write(6, *) 'jts=', jts, '  jte=', jte
+!     write(6, *) 'kts=', kts, '  kte=', kte
+!     write(6, *) 'dt=', dt
+!     write(6, *) 'ihail=', ihail
+!     write(6, *) 'ICE2=', ICE2
+!     write(6, *) 'dt=', dt
+!   endif 
+
+!-----------------------------------------------------------------------
+!  This program calculates precipitation fluxes due to terminal velocities.
+!-----------------------------------------------------------------------
+
+   dtb=dt
+   pi=acos(-1.)
+   consta=2115.0*0.01**(1-constb)
+!   constc=152.93*0.01**(1-constd)
+   constc=78.63*0.01**(1-constd)
+
+!  Gamma function
+   gambp4=ggamma(constb+4.)
+   gamdp4=ggamma(constd+4.)
+   gam4pt5=ggamma(4.5)
+   gam4bbar=ggamma(4.+bbar)
+
+!***********************************************************************
+! Calculate precipitation fluxes due to terminal velocities.
+!***********************************************************************
+!
+!- Calculate termianl velocity (vt?)  of precipitation q?z
+!- Find maximum vt? to determine the small delta t
+
+ j_loop:  do j = jts, jte
+ i_loop:  do i = its, ite
+
+   pptrain = 0.
+   pptsnow = 0.
+   pptgraul = 0.
+   pptice  = 0.
+
+   do k = kts, kte
+      qrz(k)=qr(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/rhoz(k))
+      zz(k)=z(i,k,j)
+      dzw(k)=dz8w(i,k,j)
+   enddo !k
+
+      DO k = kts, kte
+         qiz(k)=qi(i,k,j)
+      ENDDO
+
+      DO k = kts, kte
+         qsz(k)=qs(i,k,j)
+      ENDDO
+
+   IF (ice2 .eq. 0) THEN
+      DO k = kts, kte
+         qgz(k)=qg(i,k,j)
+      ENDDO
+   ELSE
+      DO k = kts, kte
+         qgz(k)=0.
+      ENDDO
+   ENDIF
+
+
+!
+!-- 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/rhoz(k)/qrz(k))
+            tmp1=sqrt(tmp1)
+            vtr(k)=consta*gambp4*sqrhoz(k)/tmp1**constb
+            vtr(k)=vtr(k)/6.
+            if (k .eq. 1) then
+               del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vtr(k))
+            else
+               del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtr(k))
+            endif
+         else
+            vtr(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
+
+! use small delta t to calculate the qrz flux
+! termi is the qrz flux pass in the grid box through the upper boundary
+! termo is the qrz flux pass out the grid box through the lower boundary
+!
+         fluxin=0.
+         do k=max_q,min_q,-1
+            fluxout=rhoz(k)*vtr(k)*qrz(k)
+            flux=(fluxin-fluxout)/rhoz(k)/dzw(k)
+!            tmpqrz=qrz(k)
+            qrz(k)=qrz(k)+del_tv*flux
+            qrz(k)=amax1(0.,qrz(k))
+            qr(i,k,j)=qrz(k)
+            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/rhoz(min_q-1)/dzw(min_q-1)
+            qr(i,min_q-1,j)=qrz(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/rhoz(k)/qsz(k))
+            tmp1=sqrt(tmp1)
+            vts(k)=constc*gamdp4*sqrhoz(k)/tmp1**constd
+            vts(k)=vts(k)/6.
+            if (k .eq. 1) then
+               del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vts(k))
+            else
+               del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vts(k))
+            endif
+         else
+            vts(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
+
+! use small delta t to calculate the qsz flux
+! termi is the qsz flux pass in the grid box through the upper boundary
+! termo is the qsz flux pass out the grid box through the lower boundary
+!
+         fluxin=0.
+         do k=max_q,min_q,-1
+            fluxout=rhoz(k)*vts(k)*qsz(k)
+            flux=(fluxin-fluxout)/rhoz(k)/dzw(k)
+            qsz(k)=qsz(k)+del_tv*flux
+            qsz(k)=amax1(0.,qsz(k))
+            qs(i,k,j)=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/rhoz(min_q-1)/dzw(min_q-1)
+            qs(i,min_q-1,j)=qsz(min_q-1)
+         endif
+!
+      else
+         notlast=.false.
+      endif
+
+    ENDDO
+
+!
+!   ice2=0 --- with hail/graupel 
+!   ice2=1 --- without hail/graupel 
+!
+  if (ice2.eq.0) then 
+!
+!-- If IHAIL=1, use hail.
+!-- If IHAIL=0, use graupel.
+!
+!    if (ihail .eq. 1) then
+!       xnog = xnoh
+!       rhograul = rhohail
+!    endif
+
+    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
+            if (ihail .eq. 1) then
+!  for hail, based on Lin et al (1983)
+              min_q=min0(min_q,k)
+              max_q=max0(max_q,k)
+              tmp1=sqrt(pi*rhohail*xnoh/rhoz(k)/qgz(k))
+              tmp1=sqrt(tmp1)
+              term0=sqrt(4.*grav*rhohail/3./rhoz(k)/cdrag)
+              vtg(k)=gam4pt5*term0*sqrt(1./tmp1)
+              vtg(k)=vtg(k)/6.
+              if (k .eq. 1) then
+                 del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vtg(k))
+              else
+                 del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtg(k))
+              endif !k
+            else
+! added by JJS
+! for graupel, based on RH (1984)
+              min_q=min0(min_q,k)
+              max_q=max0(max_q,k)
+              tmp1=sqrt(pi*rhograul*xnog/rhoz(k)/qgz(k))
+              tmp1=sqrt(tmp1)
+              tmp1=tmp1**bbar
+              tmp1=1./tmp1
+              term0=abar*gam4bbar/6.
+              vtg(k)=term0*tmp1*(p0/prez(k))**0.4
+              if (k .eq. 1) then
+                 del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vtg(k))
+              else
+                 del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vtg(k))
+              endif !k
+            endif !ihail
+         else
+            vtg(k)=0.
+         endif !qgz
+      enddo !k
+
+      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
+
+! use small delta t to calculate the qgz flux
+! termi is the qgz flux pass in the grid box through the upper boundary
+! termo is the qgz flux pass out the grid box through the lower boundary
+!
+         fluxin=0.
+         do k=max_q,min_q,-1
+            fluxout=rhoz(k)*vtg(k)*qgz(k)
+            flux=(fluxin-fluxout)/rhoz(k)/dzw(k)
+            qgz(k)=qgz(k)+del_tv*flux
+            qgz(k)=amax1(0.,qgz(k))
+            qg(i,k,j)=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/rhoz(min_q-1)/dzw(min_q-1)
+            qg(i,min_q-1,j)=qgz(min_q-1)
+         endif
+!
+      else
+         notlast=.false.
+      endif
+!
+    ENDDO
+ ENDIF !ice2
+!
+!-- 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)
+            vti(k)= 3.29 * (rhoz(k)* qiz(k))** 0.16  ! Heymsfield and Donner
+            if (k .eq. 1) then
+               del_tv=amin1(del_tv,0.9*(zz(k)-topo(i,j))/vti(k))
+            else
+               del_tv=amin1(del_tv,0.9*(zz(k)-zz(k-1))/vti(k))
+            endif
+         else
+            vti(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
+
+! use small delta t to calculate the qiz flux
+! termi is the qiz flux pass in the grid box through the upper boundary
+! termo is the qiz flux pass out the grid box through the lower boundary
+!
+
+         fluxin=0.
+         do k=max_q,min_q,-1
+            fluxout=rhoz(k)*vti(k)*qiz(k)
+            flux=(fluxin-fluxout)/rhoz(k)/dzw(k)
+            qiz(k)=qiz(k)+del_tv*flux
+            qiz(k)=amax1(0.,qiz(k))
+            qi(i,k,j)=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/rhoz(min_q-1)/dzw(min_q-1)
+            qi(i,min_q-1,j)=qiz(min_q-1)
+         endif
+!
+      else
+         notlast=.false.
+      endif
+!
+   ENDDO !notlast
+
+!   prnc(i,j)=prnc(i,j)+pptrain
+!   psnowc(i,j)=psnowc(i,j)+pptsnow
+!   pgrauc(i,j)=pgrauc(i,j)+pptgraul
+!   picec(i,j)=picec(i,j)+pptice
+!                     
+
+!   write(6,*) 'i=',i,' j=',j,'   ', pptrain, pptsnow, pptgraul, pptice
+!   call flush(6)
+
+   snowncv(i,j) = pptsnow
+   snownc(i,j) = snownc(i,j) + pptsnow
+   graupelncv(i,j) = pptgraul
+   graupelnc(i,j) = graupelnc(i,j) + pptgraul 
+   RAINNCV(i,j) = pptrain + pptsnow + pptgraul + pptice                 
+   RAINNC(i,j)  = RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice
+   sr(i,j) = 0.
+   if (RAINNCV(i,j) .gt. 0.) sr(i,j) = (pptsnow + pptgraul + pptice) / RAINNCV(i,j) 
+
+  ENDDO i_loop
+  ENDDO j_loop
+
+!  if (itimestep.eq.6480) then
+!     write(51,*) 'in the end of fallflux, itimestep=',itimestep
+!     do j=jts,jte
+!        do i=its,ite 
+!           if (rainnc(i,j).gt.400.) then
+!              write(50,*) 'i=',i,' j=',j,' rainnc=',rainnc
+!           endif
+!        enddo
+!     enddo
+!  endif
+
+  END SUBROUTINE fall_flux
+
+!----------------------------------------------------------------
+   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_gsfcgce: 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
+
+!-----------------------------------------------------------------------
+!c Correction of negative values  
+   SUBROUTINE negcor ( X, rho, dz8w,                         &
+                      ims,ime, jms,jme, kms,kme,              & ! memory dims
+                      itimestep, ics,                         &
+                      its,ite, jts,jte, kts,kte               ) ! tile   dims
+!-----------------------------------------------------------------------
+  REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
+        INTENT(INOUT) ::                                     X   
+  REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
+        INTENT(IN   ) ::                              rho, dz8w  
+  integer, INTENT(IN   ) ::                           itimestep, ics 
+
+!c Local variables
+!  REAL, DIMENSION( kts:kte ) ::  Y1, Y2
+  REAL   ::   A0, A1, A2
+
+  A1=0.
+  A2=0.
+  do k=kts,kte
+     do j=jts,jte
+        do i=its,ite
+        A1=A1+max(X(i,k,j), 0.)*rho(i,k,j)*dz8w(i,k,j)
+        A2=A2+max(-X(i,k,j), 0.)*rho(i,k,j)*dz8w(i,k,j)
+        enddo
+     enddo
+  enddo
+
+!  A1=0.0
+!  A2=0.0
+!  do k=kts,kte
+!     A1=A1+Y1(k)
+!     A2=A2+Y2(k)
+!  enddo
+
+  A0=0.0
+
+  if (A1.NE.0.0.and.A1.GT.A2) then 
+     A0=(A1-A2)/A1
+
+  if (mod(itimestep,540).eq.0) then
+     if (ics.eq.1) then
+        write(61,*) 'kms=',kms,'  kme=',kme,'  kts=',kts,'  kte=',kte
+        write(61,*) 'jms=',jms,'  jme=',jme,'  jts=',jts,'  jte=',jte 
+        write(61,*) 'ims=',ims,'  ime=',ime,'  its=',its,'  ite=',ite 
+     endif 
+     if (ics.eq.1) then
+         write(61,*) 'qv timestep=',itimestep
+         write(61,*) '  A1=',A1,'   A2=',A2,'   A0=',A0
+     else if (ics.eq.2) then
+             write(61,*) 'ql timestep=',itimestep
+             write(61,*) '  A1=',A1,'   A2=',A2,'   A0=',A0
+     else if (ics.eq.3) then
+             write(61,*) 'qr timestep=',itimestep
+             write(61,*) '  A1=',A1,'   A2=',A2,'   A0=',A0
+     else if (ics.eq.4) then
+             write(61,*) 'qi timestep=',itimestep
+             write(61,*) '  A1=',A1,'   A2=',A2,'   A0=',A0
+     else if (ics.eq.5) then
+             write(61,*) 'qs timestep=',itimestep
+             write(61,*) '  A1=',A1,'   A2=',A2,'   A0=',A0
+     else if (ics.eq.6) then
+             write(61,*) 'qg timestep=',itimestep
+             write(61,*) '  A1=',A1,'   A2=',A2,'   A0=',A0
+     else
+             write(61,*) 'wrong cloud specieis number'
+     endif 
+  endif 
+
+     do k=kts,kte
+        do j=jts,jte
+           do i=its,ite
+           X(i,k,j)=A0*AMAX1(X(i,k,j), 0.0)
+           enddo
+        enddo
+     enddo
+  endif
+
+  END SUBROUTINE negcor
+
+ SUBROUTINE consat_s (ihail,itaobraun)
+
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!                                                                      c
+!   Tao, W.-K., and J. Simpson, 1989: Modeling study of a tropical     c
+!   squall-type convective line. J. Atmos. Sci., 46, 177-202.          c
+!                                                                      c
+!   Tao, W.-K., J. Simpson and M. McCumber, 1989: An ice-water         c
+!   saturation adjustment. Mon. Wea. Rev., 117, 231-235.               c
+!                                                                      c
+!   Tao, W.-K., and J. Simpson, 1993: The Goddard Cumulus Ensemble     c
+!   Model. Part I: Model description. Terrestrial, Atmospheric and     c
+!   Oceanic Sciences, 4, 35-72.                                        c
+!                                                                      c
+!   Tao, W.-K., J. Simpson, D. Baker, S. Braun, M.-D. Chou, B.         c
+!   Ferrier,D. Johnson, A. Khain, S. Lang,  B. Lynn, C.-L. Shie,       c
+!   D. Starr, C.-H. Sui, Y. Wang and P. Wetzel, 2003: Microphysics,    c
+!   radiation and surface processes in the Goddard Cumulus Ensemble    c
+!   (GCE) model, A Special Issue on Non-hydrostatic Mesoscale          c
+!   Modeling, Meteorology and Atmospheric Physics, 82, 97-137.         c
+!                                                                      c
+!   Lang, S., W.-K. Tao, R. Cifelli, W. Olson, J. Halverson, S.        c
+!   Rutledge, and J. Simpson, 2007: Improving simulations of           c
+!   convective system from TRMM LBA: Easterly and Westerly regimes.    c
+!   J. Atmos. Sci., 64, 1141-1164.                                     c
+!                                                                      c
+!   Coded by Tao (1989-2003), modified by S. Lang (2006/07)            c
+!                                                                      c
+!   Implemented into WRF  by Roger Shi 2006/2007                       c
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+!        itaobraun=0   ! see Tao and Simpson (1993)
+!        itaobraun=1   ! see Tao et al. (2003)
+
+ integer :: itaobraun
+ real    :: cn0
+
+!JJS 1/3/2008  vvvvv
+!JJS   the following common blocks have been moved to the top of
+!JJS   module_mp_gsfcgce_driver_instat.F
+!
+! real,   dimension (1:31) ::  a1, a2
+! data a1/.7939e-7,.7841e-6,.3369e-5,.4336e-5,.5285e-5,.3728e-5, &
+!         .1852e-5,.2991e-6,.4248e-6,.7434e-6,.1812e-5,.4394e-5,.9145e-5, &
+!         .1725e-4,.3348e-4,.1725e-4,.9175e-5,.4412e-5,.2252e-5,.9115e-6, &
+!         .4876e-6,.3473e-6,.4758e-6,.6306e-6,.8573e-6,.7868e-6,.7192e-6, &
+!         .6513e-6,.5956e-6,.5333e-6,.4834e-6/
+! data a2/.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/
+!JJS 1/3/2008  ^^^^^
+
+
+!     ******************************************************************
+!JJS
+      al = 2.5e10
+      cp = 1.004e7
+      rd1 = 1.e-3
+      rd2 = 2.2
+!JJS
+      cpi=4.*atan(1.)
+      cpi2=cpi*cpi
+      grvt=980.
+      cd1=6.e-1
+      cd2=4.*grvt/(3.*cd1)
+      tca=2.43e3
+      dwv=.226
+      dva=1.718e-4
+      amw=18.016
+      ars=8.314e7
+      scv=2.2904487
+      t0=273.16
+      t00=238.16
+      alv=2.5e10
+      alf=3.336e9
+      als=2.8336e10
+      avc=alv/cp
+      afc=alf/cp
+      asc=als/cp
+      rw=4.615e6
+      cw=4.187e7
+      ci=2.093e7
+      c76=7.66
+      c358=35.86
+      c172=17.26939
+      c409=4098.026
+      c218=21.87456
+      c580=5807.695
+      c610=6.1078e3
+      c149=1.496286e-5
+      c879=8.794142
+      c141=1.4144354e7
+!***   DEFINE THE COEFFICIENTS USED IN TERMINAL VELOCITY
+!***   DEFINE THE DENSITY AND SIZE DISTRIBUTION OF PRECIPITATION
+!**********   HAIL OR GRAUPEL PARAMETERS   **********
+      if(ihail .eq. 1) then
+         roqg=.9
+         ag=sqrt(cd2*roqg)
+         bg=.5
+         tng=.002
+      else
+         roqg=.4
+         ag=351.2
+!        AG=372.3 ! if ice913=1 6/15/02 tao's
+         bg=.37
+         tng=.04
+      endif
+!**********         SNOW PARAMETERS        **********
+!ccshie 6/15/02 tao's
+!      TNS=1.
+!      TNS=.08 ! if ice913=1, tao's
+      tns=.16 ! if ice913=0, tao's
+      roqs=.1
+!      AS=152.93
+      as=78.63
+!      BS=.25
+      bs=.11
+!**********         RAIN PARAMETERS        **********
+      aw=2115.
+      bw=.8
+      roqr=1.
+      tnw=.08
+!*****************************************************************
+      bgh=.5*bg
+      bsh=.5*bs
+      bwh=.5*bw
+      bgq=.25*bg
+      bsq=.25*bs
+      bwq=.25*bw
+!**********GAMMA FUNCTION CALCULATIONS*************
+      ga3b  = gammagce(3.+bw)
+      ga4b  = gammagce(4.+bw)
+      ga6b  = gammagce(6.+bw)
+      ga5bh = gammagce((5.+bw)/2.)
+      ga3g  = gammagce(3.+bg)
+      ga4g  = gammagce(4.+bg)
+      ga5gh = gammagce((5.+bg)/2.)
+      ga3d  = gammagce(3.+bs)
+      ga4d  = gammagce(4.+bs)
+      ga5dh = gammagce((5.+bs)/2.)
+!CCCCC        LIN ET AL., 1983 OR LORD ET AL., 1984   CCCCCCCCCCCCCCCCC
+      ac1=aw
+!JJS
+      ac2=ag
+      ac3=as
+!JJS
+      bc1=bw
+      cc1=as
+      dc1=bs
+      zrc=(cpi*roqr*tnw)**0.25
+      zsc=(cpi*roqs*tns)**0.25
+      zgc=(cpi*roqg*tng)**0.25
+      vrc=aw*ga4b/(6.*zrc**bw)
+      vsc=as*ga4d/(6.*zsc**bs)
+      vgc=ag*ga4g/(6.*zgc**bg)
+!     ****************************
+!     RN1=1.E-3
+      rn1=9.4e-15 ! 6/15/02 tao's
+      bnd1=6.e-4
+      rn2=1.e-3
+!     BND2=1.25E-3
+!     BND2=1.5E-3 ! if ice913=1 6/15/02 tao's
+      bnd2=2.0e-3 ! if ice913=0 6/15/02 tao's
+      rn3=.25*cpi*tns*cc1*ga3d
+      esw=1.
+      rn4=.25*cpi*esw*tns*cc1*ga3d
+!     ERI=1.
+      eri=.1  ! 6/17/02 tao's ice913=0 (not 1)
+      rn5=.25*cpi*eri*tnw*ac1*ga3b
+!     AMI=1./(24.*4.19E-10)
+      ami=1./(24.*6.e-9) ! 6/15/02 tao's
+      rn6=cpi2*eri*tnw*ac1*roqr*ga6b*ami
+!     ESR=1. ! also if ice913=1 for tao's
+      esr=.5 ! 6/15/02 for ice913=0 tao's
+      rn7=cpi2*esr*tnw*tns*roqs
+      esr=1.
+      rn8=cpi2*esr*tnw*tns*roqr
+      rn9=cpi2*tns*tng*roqs
+      rn10=2.*cpi*tns
+      rn101=.31*ga5dh*sqrt(cc1)
+      rn10a=als*als/rw
+!JJS
+       rn10b=alv/tca
+       rn10c=ars/(dwv*amw)
+!JJS
+      rn11=2.*cpi*tns/alf
+      rn11a=cw/alf
+!     AMI50=1.51e-7
+      ami50=3.84e-6 ! 6/15/02 tao's
+!     AMI40=2.41e-8
+      ami40=3.08e-8 ! 6/15/02 tao's
+      eiw=1.
+!     UI50=20.
+      ui50=100. ! 6/15/02 tao's
+      ri50=2.*5.e-3
+      cmn=1.05e-15
+      rn12=cpi*eiw*ui50*ri50**2
+
+      do 10 k=1,31
+         y1=1.-aa2(k)
+         rn13(k)=aa1(k)*y1/(ami50**y1-ami40**y1)
+         rn12a(k)=rn13(k)/ami50
+         rn12b(k)=aa1(k)*ami50**aa2(k)
+         rn25a(k)=aa1(k)*cmn**aa2(k)
+   10 continue
+
+      egw=1.
+      rn14=.25*cpi*egw*tng*ga3g*ag
+      egi=.1
+      rn15=.25*cpi*egi*tng*ga3g*ag
+      egi=1.
+      rn15a=.25*cpi*egi*tng*ga3g*ag
+      egr=1.
+      rn16=cpi2*egr*tng*tnw*roqr
+      rn17=2.*cpi*tng
+      rn17a=.31*ga5gh*sqrt(ag)
+      rn17b=cw-ci
+      rn17c=cw
+      apri=.66
+      bpri=1.e-4
+      bpri=0.5*bpri ! 6/17/02 tao's
+      rn18=20.*cpi2*bpri*tnw*roqr
+      rn18a=apri
+      rn19=2.*cpi*tng/alf
+      rn19a=.31*ga5gh*sqrt(ag)
+      rn19b=cw/alf
+!
+       rnn191=.78
+       rnn192=.31*ga5gh*sqrt(ac2/dva)
+!
+      rn20=2.*cpi*tng
+      rn20a=als*als/rw
+      rn20b=.31*ga5gh*sqrt(ag)
+      bnd3=2.e-3
+      rn21=1.e3*1.569e-12/0.15
+      erw=1.
+      rn22=.25*cpi*erw*ac1*tnw*ga3b
+      rn23=2.*cpi*tnw
+      rn23a=.31*ga5bh*sqrt(ac1)
+      rn23b=alv*alv/rw
+
+
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!cc
+!cc        "c0" in routine      "consat" (2d), "consatrh" (3d)
+!cc        if ( itaobraun.eq.1 ) --> betah=0.5*beta=-.46*0.5=-0.23;   cn0=1.e-6
+!cc        if ( itaobraun.eq.0 ) --> betah=0.5*beta=-.6*0.5=-0.30;    cn0=1.e-8
+
+       if (itaobraun .eq. 0) then
+         cn0=1.e-8
+         beta=-.6
+       elseif (itaobraun .eq. 1) then
+         cn0=1.e-6
+         beta=-.46
+       endif
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!      CN0=1.E-6
+!      CN0=1.E-8 ! 6/15/02 tao's
+!      BETA=-.46
+!      BETA=-.6  ! 6/15/02 tao's
+
+      rn25=cn0
+      rn30a=alv*als*amw/(tca*ars)
+      rn30b=alv/tca
+      rn30c=ars/(dwv*amw)
+      rn31=1.e-17
+
+      rn32=4.*51.545e-4
+!
+      rn30=2.*cpi*tng
+      rnn30a=alv*alv*amw/(tca*ars)
+!
+      rn33=4.*tns
+       rn331=.65
+       rn332=.44*sqrt(ac3/dva)*ga5dh
+!
+
+    return
+ END SUBROUTINE consat_s
+
+ SUBROUTINE saticel_s (dt, ihail, itaobraun, ice2, istatmin, &
+                       new_ice_sat, id, &
+                       ptwrf, qvwrf, qlwrf, qrwrf, &
+                       qiwrf, qswrf, qgwrf, &
+                       rho_mks, pi_mks, p0_mks,itimestep, &
+                       ids,ide, jds,jde, kds,kde, &
+                       ims,ime, jms,jme, kms,kme, &
+                       its,ite, jts,jte, kts,kte  &
+                           )
+    IMPLICIT NONE
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!                                                                      c
+!   Tao, W.-K., and J. Simpson, 1989: Modeling study of a tropical     c
+!   squall-type convective line. J. Atmos. Sci., 46, 177-202.          c
+!                                                                      c
+!   Tao, W.-K., J. Simpson and M. McCumber, 1989: An ice-water         c
+!   saturation adjustment. Mon. Wea. Rev., 117, 231-235.               c
+!                                                                      c
+!   Tao, W.-K., and J. Simpson, 1993: The Goddard Cumulus Ensemble     c
+!   Model. Part I: Model description. Terrestrial, Atmospheric and     c
+!   Oceanic Sciences, 4, 35-72.                                        c
+!                                                                      c
+!   Tao, W.-K., J. Simpson, D. Baker, S. Braun, M.-D. Chou, B.         c
+!   Ferrier,D. Johnson, A. Khain, S. Lang,  B. Lynn, C.-L. Shie,       c
+!   D. Starr, C.-H. Sui, Y. Wang and P. Wetzel, 2003: Microphysics,    c
+!   radiation and surface processes in the Goddard Cumulus Ensemble    c
+!   (GCE) model, A Special Issue on Non-hydrostatic Mesoscale          c
+!   Modeling, Meteorology and Atmospheric Physics, 82, 97-137.         c
+!                                                                      c
+!   Lang, S., W.-K. Tao, R. Cifelli, W. Olson, J. Halverson, S.        c
+!   Rutledge, and J. Simpson, 2007: Improving simulations of           c
+!   convective system from TRMM LBA: Easterly and Westerly regimes.    c
+!   J. Atmos. Sci., 64, 1141-1164.                                     c
+!                                                                      c
+!   Tao, W.-K., J. J. Shi,  S. Lang, C. Peters-Lidard, A. Hou, S.      c
+!   Braun, and J. Simpson, 2007: New, improved bulk-microphysical      c
+!   schemes for studying precipitation processes in WRF. Part I:       c
+!   Comparisons with other schemes. to appear on Mon. Wea. Rev.        C
+!                                                                      c
+!   Coded by Tao (1989-2003), modified by S. Lang (2006/07)            c
+!                                                                      c
+!   Implemented into WRF  by Roger Shi 2006/2007                       c
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!
+!      COMPUTE ICE PHASE MICROPHYSICS AND SATURATION PROCESSES
+!
+  integer,    parameter ::  nt=2880, nt2=2*nt 
+
+!cc   using scott braun's way for pint, pidep computations
+  integer  ::   itaobraun,ice2,ihail,new_ice_sat,id,istatmin
+  integer  ::   itimestep
+  real     ::   tairccri, cn0, dt
+!cc
+
+!JJS      common/bxyz/ n,isec,nran,kt1,kt2
+!JJS      common/option/ lipps,ijkadv,istatmin,iwater,itoga,imlifting,lin,
+!JJS     1   irf,iadvh,irfg,ismg,id
+
+!JJS      common/timestat/ ndt_stat,idq
+!JJS      common/iice/ new_ice_sat
+!JJS      common/bt/ dt,d2t,rijl2,dts,f5,rd1,rd2,bound,al,cp,ra,ck,ce,eps,
+!JJS     1    psfc,fcor,sec,aminut,rdt
+
+!JJS   the following common blocks have been moved to the top of 
+!JJS   module_mp_gsfcgce_driver_instat.F
+
+!      common/bt/ rd1,rd2,al,cp
+!
+!
+!      common/bterv/ zrc,zgc,zsc,vrc,vgc,vsc
+!      common/size/ tnw,tns,tng,roqs,roqg,roqr
+!      common/cont/ c38,c358,c610,c149,c879,c172,c409,c76,c218,c580,c141
+!        common/b3cs/ ag,bg,as,bs,aw,bw,bgh,bgq,bsh,bsq,bwh,bwq
+!      common/bsnw/ alv,alf,als,t0,t00,avc,afc,asc,rn1,bnd1,rn2,bnd2, &
+!         rn3,rn4,rn5,rn6,rn7,rn8,rn9,rn10,rn101,rn10a,rn11,rn11a, &
+!         rn12,rn12a(31),rn12b(31),rn13(31),rn14,rn15,rn15a,rn16,rn17, &
+!         rn17a,rn17b,rn17c,rn18,rn18a,rn19,rn19a,rn19b,rn20,rn20a,rn20b, &
+!         bnd3,rn21,rn22,rn23,rn23a,rn23b,rn25,rn25a(31),rn30a,rn30b, &
+!         rn30c,rn31,beta,rn32
+!      common/rsnw1/ rn10b,rn10c,rnn191,rnn192,rn30,rnn30a,rn33,rn331, &
+!                    rn332
+!JJS
+
+  integer ids,ide,jds,jde,kds,kde
+  integer ims,ime,jms,jme,kms,kme
+  integer its,ite,jts,jte,kts,kte
+  integer i,j,k, kp
+
+  real :: a0 ,a1 ,a2 ,afcp ,alvr ,ami100 ,ami40 ,ami50 ,ascp ,avcp ,betah &
+   ,bg3 ,bgh5 ,bs3 ,bs6 ,bsh5 ,bw3 ,bw6 ,bwh5 ,cmin ,cmin1 ,cmin2 ,cp409 &
+   ,cp580 ,cs580 ,cv409 ,d2t ,del ,dwvp ,ee1 ,ee2 ,f00 ,f2 ,f3 ,ft ,fv0 ,fvs &
+   ,pi0 ,pir ,pr0 ,qb0 ,r00 ,r0s ,r101f ,r10ar ,r10t ,r11at ,r11rt ,r12r ,r14f &
+   ,r14r ,r15af ,r15ar ,r15f ,r15r ,r16r ,r17aq ,r17as ,r17r ,r18r ,r19aq ,r19as &
+   ,r19bt ,r19rt ,r20bq ,r20bs ,r20t ,r22f ,r23af ,r23br ,r23t ,r25a ,r25rt ,r2ice &
+   ,r31r ,r32rt ,r3f ,r4f ,r5f ,r6f ,r7r ,r8r ,r9r ,r_nci ,rft ,rijl2 ,rp0 ,rr0 &
+   ,rrq ,rrs ,rt0 ,scc ,sccc ,sddd ,see ,seee ,sfff ,smmm ,ssss ,tb0 ,temp ,ucog &
+   ,ucor ,ucos ,uwet ,vgcf ,vgcr ,vrcf ,vscf ,zgr ,zrr ,zsr
+
+
+  real, dimension (its:ite,jts:jte,kts:kte) ::  fv
+  real, dimension (its:ite,jts:jte,kts:kte) ::  dpt, dqv
+  real, dimension (its:ite,jts:jte,kts:kte) ::  qcl, qrn,      &
+                                                qci, qcs, qcg
+!JJS 10/16/06    vvvv
+!      real dpt1(ims:ime,jms:jme,kms:kme)
+!      real dqv1(ims:ime,jms:jme,kms:kme),
+!     1             qcl1(ims:ime,jms:jme,kms:kme)
+!      real qrn1(ims:ime,jms:jme,kms:kme),
+!     1             qci1(ims:ime,jms:jme,kms:kme)
+!      real qcs1(ims:ime,jms:jme,kms:kme),
+!     1             qcg1(ims:ime,jms:jme,kms:kme)
+!JJS 10/16/06    ^^^^
+
+!JJS
+
+  real, dimension (ims:ime, kms:kme, jms:jme) ::  ptwrf, qvwrf 
+  real, dimension (ims:ime, kms:kme, jms:jme) ::  qlwrf, qrwrf,        &
+                                                  qiwrf, qswrf, qgwrf
+!JJS 10/16/06    vvvv
+!      real ptwrfold(ims:ime, kms:kme, jms:jme)
+!      real qvwrfold(ims:ime, kms:kme, jms:jme),
+!     1             qlwrfold(ims:ime, kms:kme, jms:jme)
+!      real qrwrfold(ims:ime, kms:kme, jms:jme),
+!     1             qiwrfold(ims:ime, kms:kme, jms:jme)
+!      real qswrfold(ims:ime, kms:kme, jms:jme),
+!     1             qgwrfold(ims:ime, kms:kme, jms:jme)
+!JJS 10/16/06    ^^^^
+
+!JJS in MKS
+  real, dimension (ims:ime, kms:kme, jms:jme) ::  rho_mks
+  real, dimension (ims:ime, kms:kme, jms:jme) ::  pi_mks
+  real, dimension (ims:ime, kms:kme, jms:jme) ::  p0_mks
+!JJS
+!  real, dimension (its:ite,jts:jte,kts:kte) ::  ww1
+!  real, dimension (its:ite,jts:jte,kts:kte) ::  rsw
+!  real, dimension (its:ite,jts:jte,kts:kte) ::  rlw
+
+!JJS      COMMON /BADV/
+  real, dimension (its:ite,jts:jte) ::        &
+           vg,      zg,       &
+           ps,      pg,       &
+          prn,     psn,       &
+        pwacs,   wgacr,       &
+        pidep,    pint,       &
+          qsi,     ssi,       &
+          esi,     esw,       &
+          qsw,      pr,       &
+          ssw,   pihom,       &
+         pidw,   pimlt,       &
+        psaut,   qracs,       &
+        psaci,   psacw,       &
+        qsacw,   praci,       &
+        pmlts,   pmltg,       &
+        asss,       y1,    y2
+!JJS       Y2(its:ite,jts:jte),    DDE(NB)
+
+!JJS      COMMON/BSAT/
+  real, dimension (its:ite,jts:jte) ::        &
+        praut,   pracw,       &
+         psfw,    psfi,       &
+        dgacs,   dgacw,       &
+        dgaci,   dgacr,       &
+        pgacs,   wgacs,       &
+        qgacw,   wgaci,       &
+        qgacr,   pgwet,       &
+        pgaut,   pracs,       &
+        psacr,   qsacr,       &
+         pgfr,   psmlt,       &
+        pgmlt,   psdep,       &
+        pgdep,   piacr,       &
+           y5,     scv,       &
+          tca,     dwv,       &
+          egs,      y3,       &
+           y4,     ddb
+
+!JJS      COMMON/BSAT1/
+  real, dimension (its:ite,jts:jte) ::        &
+           pt,      qv,       &
+           qc,      qr,       &
+           qi,      qs,       &
+           qg,    tair,       &
+        tairc,   rtair,       &
+          dep,      dd,       &
+          dd1,     qvs,       &
+           dm,      rq,       &
+        rsub1,     col,       &
+          cnd,     ern,       &
+         dlt1,    dlt2,       &
+         dlt3,    dlt4,       &
+           zr,      vr,       &
+           zs,      vs,       &
+                 pssub,       &
+        pgsub,     dda
+
+!JJS      COMMON/B5/
+  real, dimension (its:ite,jts:jte,kts:kte) ::  rho
+  real, dimension (kts:kte) ::                 & 
+           tb,      qb,    rho1,              &
+           ta,      qa,     ta1,     qa1,     &
+         coef,      z1,      z2,      z3,     &
+           am,     am1,      ub,      vb,     &
+           wb,     ub1,     vb1,    rrho,     &
+        rrho1,     wbx
+
+!JJS      COMMON/B6/
+  real, dimension (its:ite,jts:jte,kts:kte) ::  p0, pi, f0
+  real, dimension (kts:kte) ::    & 
+           fd,      fe,        &
+           st,      sv,        &
+           sq,      sc,        &
+           se,     sqa
+
+!JJS      COMMON/BRH1/
+  real, dimension (kts:kte) ::    & 
+         srro,    qrro,    sqc,    sqr,    &
+          sqi,     sqs,    sqg,   stqc,    &
+         stqr,    stqi,   stqs,   stqg
+  real, dimension (nt) ::    & 
+          tqc,     tqr,    tqi,    tqs,    tqg
+
+!JJS     common/bls/ y0(nx,ny),ts0new(nx,ny),qss0new(nx,ny)
+
+!JJS      COMMON/BLS/
+  real, dimension (ims:ime,jms:jme) ::     &
+           y0,     ts0,   qss0
+
+!JJS      COMMON/BI/ IT(its:ite,jts:jte), ICS(its:ite,jts:jte,4)
+  integer, dimension (its:ite,jts:jte) ::        it  
+  integer, dimension (its:ite,jts:jte, 4) ::    ics 
+
+  integer :: i24h
+  integer :: iwarm
+  real :: r2is, r2ig
+  
+
+!JJS      COMMON/MICRO/
+!  real, dimension (ims:ime,kms:kme,jms:jme)  ::    dbz 
+
+!23456789012345678901234567890123456789012345678901234567890123456789012
+
+!
+!JJS 1/3/2008  vvvvv
+!JJS   the following common blocks have been moved to the top of
+!JJS   module_mp_gsfcgce_driver.F
+
+!  real, dimension (31)   ::      aa1,  aa2
+!  data aa1/.7939e-7, .7841e-6, .3369e-5, .4336e-5, .5285e-5,     &
+!           .3728e-5, .1852e-5, .2991e-6, .4248e-6, .7434e-6,     &
+!           .1812e-5, .4394e-5, .9145e-5, .1725e-4, .3348e-4,     &
+!           .1725e-4, .9175e-5, .4412e-5, .2252e-5, .9115e-6,     &
+!           .4876e-6, .3473e-6, .4758e-6, .6306e-6, .8573e-6,     &
+!           .7868e-6, .7192e-6, .6513e-6, .5956e-6, .5333e-6,     &
+!           .4834e-6/
+!  data aa2/.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/
+
+!JJS 1/3/2008  ^^^^^
+
+!
+!jm 20090220      save
+
+!    i24h=nint(86400./dt) 
+!    if (mod(itimestep,i24h).eq.1) then
+!       write(6, *) 'ims=', ims, '  ime=', ime
+!       write(6, *) 'jms=', jms, '  jme=', jme
+!       write(6, *) 'kms=', kms, '  kme=', kme
+!       write(6, *) 'its=', its, '  ite=', ite
+!       write(6, *) 'jts=', jts, '  jte=', jte
+!       write(6, *) 'kts=', kts, '  kte=', kte
+!       write(6, *) '    ihail=', ihail
+!       write(6, *) 'itaobraun=',itaobraun
+!       write(6, *) '    ice2=', ICE2
+!       write(6, *) 'istatmin=',istatmin
+!       write(6, *) 'new_ice_sat=', new_ice_sat
+!       write(6, *) 'id=', id
+!       write(6, *) 'dt=', dt
+!    endif
+
+!JJS  convert from mks to cgs, and move from WRF grid to GCE grid
+      do k=kts,kte
+         do j=jts,jte
+         do i=its,ite
+         rho(i,j,k)=rho_mks(i,k,j)*0.001
+         p0(i,j,k)=p0_mks(i,k,j)*10.0
+         pi(i,j,k)=pi_mks(i,k,j)
+         dpt(i,j,k)=ptwrf(i,k,j)
+         dqv(i,j,k)=qvwrf(i,k,j)
+         qcl(i,j,k)=qlwrf(i,k,j)
+         qrn(i,j,k)=qrwrf(i,k,j)
+         qci(i,j,k)=qiwrf(i,k,j)
+         qcs(i,j,k)=qswrf(i,k,j)
+         qcg(i,j,k)=qgwrf(i,k,j)
+!JJS 10/16/06    vvvv
+!         dpt1(i,j,k)=ptwrfold(i,k,j)
+!         dqv1(i,j,k)=qvwrfold(i,k,j)
+!         qcl1(i,j,k)=qlwrfold(i,k,j)
+!         qrn1(i,j,k)=qrwrfold(i,k,j)
+!         qci1(i,j,k)=qiwrfold(i,k,j)
+!         qcs1(i,j,k)=qswrfold(i,k,j)
+!         qcg1(i,j,k)=qgwrfold(i,k,j)
+!JJS 10/16/06     ^^^^
+         enddo !i
+         enddo !j
+      enddo !k
+
+      do k=kts,kte
+         do j=jts,jte
+         do i=its,ite
+         fv(i,j,k)=sqrt(rho(i,j,2)/rho(i,j,k))
+         enddo !i
+         enddo !j
+      enddo !k
+!JJS
+
+!
+!     ******   THREE CLASSES OF ICE-PHASE   (LIN ET AL, 1983)  *********
+
+!JJS       D22T=D2T
+!JJS       IF(IJKADV .EQ. 0) THEN
+!JJS         D2T=D2T
+!JJS       ELSE
+         d2t=dt
+!JJS       ENDIF
+!
+!       itaobraun=0 ! original pint and pidep & see Tao and Simpson 1993
+        itaobraun=1 ! see Tao et al. (2003)
+!
+       if ( itaobraun.eq.0 ) then
+          cn0=1.e-8
+!c        beta=-.6
+       elseif ( itaobraun.eq.1 ) then
+          cn0=1.e-6
+!         cn0=1.e-8  ! special
+!c        beta=-.46
+       endif
+!C  TAO 2007 START
+!   ICE2=0 ! default, 3ice with loud ice, snow and graupel
+!              r2is=1., r2ig=1.
+!   ICE2=1 ! 2ice with cloud ice and snow (no graupel) - r2iceg=1, r2ice=0.
+!              r2is=1., r2ig=0.
+!   ICE2=2 ! 2ice with cloud ice and graupel (no snow) - r2ice=1, r2iceg=0.
+!              r2is=0., r2ig=1.
+!c
+!        r2ice=1.
+!        r2iceg=1.
+         r2ig=1.
+         r2is=1.
+          if (ice2 .eq. 1) then
+!              r2ice=0.
+!              r2iceg=1.
+              r2ig=0.
+              r2is=1.
+          endif
+          if (ice2 .eq. 2) then
+!              r2ice=1.
+!              r2iceg=0.
+              r2ig=1.
+              r2is=0.
+          endif
+!C  TAO 2007 END
+     
+!JJS  10/7/2008
+!   ICE2=3 ! no ice, warm rain only
+    iwarm = 0
+    if (ice2 .eq. 3 ) iwarm = 1
+
+
+
+      cmin=1.e-19
+      cmin1=1.e-20
+      cmin2=1.e-12
+      ucor=3071.29/tnw**0.75
+      ucos=687.97*roqs**0.25/tns**0.75
+      ucog=687.97*roqg**0.25/tng**0.75
+      uwet=4.464**0.95
+
+      rijl2 = 1. / (ide-ids) / (jde-jds)
+
+!JJScap $doacross local(j,i)
+
+!JJS      DO 1 J=1,JMAX
+!JJS      DO 1 I=1,IMAX
+       do j=jts,jte
+          do i=its,ite
+          it(i,j)=1
+          enddo
+       enddo
+
+      f2=rd1*d2t
+      f3=rd2*d2t
+
+      ft=dt/d2t
+      rft=rijl2*ft
+      a0=.5*istatmin*rijl2
+      rt0=1./(t0-t00)
+      bw3=bw+3.
+      bs3=bs+3.
+      bg3=bg+3.
+      bsh5=2.5+bsh
+      bgh5=2.5+bgh
+      bwh5=2.5+bwh
+      bw6=bw+6.
+      bs6=bs+6.
+      betah=.5*beta
+      r10t=rn10*d2t
+      r11at=rn11a*d2t
+      r19bt=rn19b*d2t
+      r20t=-rn20*d2t
+      r23t=-rn23*d2t
+      r25a=rn25
+
+!     ami50 for use in PINT
+       ami50=3.76e-8
+       ami100=1.51e-7
+       ami40=2.41e-8
+
+!C    ******************************************************************
+
+!JJS      DO 1000 K=2,kles
+      do 1000 k=kts,kte
+         kp=k+1
+!JJS         tb0=ta1(k)
+!JJS         qb0=qa1(k)
+         tb0=0.
+         qb0=0.
+
+      do 2000 j=jts,jte
+         do 2000 i=its,ite
+
+         rp0=3.799052e3/p0(i,j,k)
+         pi0=pi(i,j,k)
+         pir=1./(pi(i,j,k))
+         pr0=1./p0(i,j,k)
+         r00=rho(i,j,k)
+         r0s=sqrt(rho(i,j,k))
+!JJS         RR0=RRHO(K)
+         rr0=1./rho(i,j,k)
+!JJS         RRS=SRRO(K)
+         rrs=sqrt(rr0)
+!JJS         RRQ=QRRO(K)
+         rrq=sqrt(rrs)
+         f0(i,j,k)=al/cp/pi(i,j,k)
+         f00=f0(i,j,k)
+         fv0=fv(i,j,k)
+         fvs=sqrt(fv(i,j,k))
+         zrr=1.e5*zrc*rrq
+         zsr=1.e5*zsc*rrq
+         zgr=1.e5*zgc*rrq
+         cp409=c409*pi0
+         cv409=c409*avc
+         cp580=c580*pi0
+         cs580=c580*asc
+         alvr=r00*alv
+         afcp=afc*pir
+         avcp=avc*pir
+         ascp=asc*pir
+         vrcf=vrc*fv0
+         vscf=vsc*fv0
+         vgcf=vgc*fv0
+         vgcr=vgc*rrs
+         dwvp=c879*pr0
+         r3f=rn3*fv0
+         r4f=rn4*fv0
+         r5f=rn5*fv0
+         r6f=rn6*fv0
+         r7r=rn7*rr0
+         r8r=rn8*rr0
+         r9r=rn9*rr0
+         r101f=rn101*fvs
+         r10ar=rn10a*r00
+         r11rt=rn11*rr0*d2t
+         r12r=rn12*r00
+         r14r=rn14*rrs
+         r14f=rn14*fv0
+         r15r=rn15*rrs
+         r15ar=rn15a*rrs
+         r15f=rn15*fv0
+         r15af=rn15a*fv0
+         r16r=rn16*rr0
+         r17r=rn17*rr0
+         r17aq=rn17a*rrq
+         r17as=rn17a*fvs
+         r18r=rn18*rr0
+         r19rt=rn19*rr0*d2t
+         r19aq=rn19a*rrq
+         r19as=rn19a*fvs
+         r20bq=rn20b*rrq
+         r20bs=rn20b*fvs
+         r22f=rn22*fv0
+         r23af=rn23a*fvs
+         r23br=rn23b*r00
+         r25rt=rn25*rr0*d2t
+         r31r=rn31*rr0
+         r32rt=rn32*d2t*rrs
+
+!JJS       DO 100 J=3,JLES
+!JJS       DO 100 I=3,ILES
+        pt(i,j)=dpt(i,j,k)
+        qv(i,j)=dqv(i,j,k)
+        qc(i,j)=qcl(i,j,k)
+        qr(i,j)=qrn(i,j,k)
+        qi(i,j)=qci(i,j,k)
+        qs(i,j)=qcs(i,j,k)
+        qg(i,j)=qcg(i,j,k)
+!        IF (QV(I,J)+QB0 .LE. 0.) QV(I,J)=-QB0
+         if (qc(i,j) .le.  cmin1) qc(i,j)=0.0
+         if (qr(i,j) .le.  cmin1) qr(i,j)=0.0
+         if (qi(i,j) .le.  cmin1) qi(i,j)=0.0
+         if (qs(i,j) .le.  cmin1) qs(i,j)=0.0
+         if (qg(i,j) .le.  cmin1) qg(i,j)=0.0
+        tair(i,j)=(pt(i,j)+tb0)*pi0
+        tairc(i,j)=tair(i,j)-t0
+         zr(i,j)=zrr
+         zs(i,j)=zsr
+         zg(i,j)=zgr
+         vr(i,j)=0.0
+         vs(i,j)=0.0
+         vg(i,j)=0.0
+
+!JJS 10/7/2008     vvvvv
+    IF (IWARM .EQ. 1) THEN
+!JJS   for calculating processes related to warm rain only
+                qi(i,j)=0.0
+                qs(i,j)=0.0
+                qg(i,j)=0.0
+                dep(i,j)=0.
+                pint(i,j)=0.
+                psdep(i,j)=0.
+                pgdep(i,j)=0.
+                dd1(i,j)=0.
+                pgsub(i,j)=0.
+                psmlt(i,j)=0.
+                pgmlt(i,j)=0.
+                pimlt(i,j)=0.
+                psacw(i,j)=0.
+                piacr(i,j)=0.
+                psfw(i,j)=0.
+                pgfr(i,j)=0.
+                dgacw(i,j)=0.
+                dgacr(i,j)=0.
+                psacr(i,j)=0.
+                wgacr(i,j)=0.
+                pihom(i,j)=0.
+                pidw(i,j)=0.
+
+                if (qr(i,j) .gt. cmin1) then
+                   dd(i,j)=r00*qr(i,j)
+                   y1(i,j)=dd(i,j)**.25
+                   zr(i,j)=zrc/y1(i,j)
+                   vr(i,j)=max(vrcf*dd(i,j)**bwq, 0.)
+                endif
+
+!* 21 * PRAUT   AUTOCONVERSION OF QC TO QR                        **21**
+!* 22 * PRACW : ACCRETION OF QC BY QR                             **22**
+                pracw(i,j)=0.
+                praut(i,j)=0.0
+                pracw(i,j)=r22f*qc(i,j)/zr(i,j)**bw3
+                y1(i,j)=qc(i,j)-bnd3
+                if (y1(i,j).gt.0.0) then
+                    praut(i,j)=r00*y1(i,j)*y1(i,j)/(1.2e-4+rn21/y1(i,j))
+                 endif
+
+!C********   HANDLING THE NEGATIVE CLOUD WATER (QC)    ******************
+                 Y1(I,J)=QC(I,J)/D2T
+                 PRAUT(I,J)=MIN(Y1(I,J), PRAUT(I,J))
+                 PRACW(I,J)=MIN(Y1(I,J), PRACW(I,J))
+                 Y1(I,J)=(PRAUT(I,J)+PRACW(I,J))*D2T
+               
+               if (qc(i,j) .lt. y1(i,j) .and. y1(i,j) .ge. cmin2) then
+                   y2(i,j)=qc(i,j)/(y1(i,j)+cmin2)
+                   praut(i,j)=praut(i,j)*y2(i,j)
+                   pracw(i,j)=pracw(i,j)*y2(i,j)
+                   qc(i,j)=0.0
+               else
+                  qc(i,j)=qc(i,j)-y1(i,j)
+               endif
+               
+               PR(I,J)=(PRAUT(I,J)+PRACW(I,J))*D2T
+               QR(I,J)=QR(I,J)+PR(I,J)
+                        
+!*****   TAO ET AL (1989) SATURATION TECHNIQUE  ***********************
+           
+           cnd(i,j)=0.0
+           tair(i,j)=(pt(i,j)+tb0)*pi0
+              y1(i,j)=1./(tair(i,j)-c358)
+              qsw(i,j)=rp0*exp(c172-c409*y1(i,j))
+              dd(i,j)=cp409*y1(i,j)*y1(i,j)
+              dm(i,j)=qv(i,j)+qb0-qsw(i,j)
+              cnd(i,j)=dm(i,j)/(1.+avcp*dd(i,j)*qsw(i,j))
+!c    ******   condensation or evaporation of qc  ******
+              cnd(i,j)=max(-qc(i,j), cnd(i,j))
+                         pt(i,j)=pt(i,j)+avcp*cnd(i,j)
+             qv(i,j)=qv(i,j)-cnd(i,j)
+                         qc(i,j)=qc(i,j)+cnd(i,j)
+
+!C     ******   EVAPORATION   ******
+!* 23 * ERN : EVAPORATION OF QR (SUBSATURATION)                   **23**
+            ern(i,j)=0.0
+
+            if(qr(i,j).gt.0.0) then
+               tair(i,j)=(pt(i,j)+tb0)*pi0
+               rtair(i,j)=1./(tair(i,j)-c358)
+               qsw(i,j)=rp0*exp(c172-c409*rtair(i,j))
+               ssw(i,j)=(qv(i,j)+qb0)/qsw(i,j)-1.0
+               dm(i,j)=qv(i,j)+qb0-qsw(i,j)
+               rsub1(i,j)=cv409*qsw(i,j)*rtair(i,j)*rtair(i,j)
+               dd1(i,j)=max(-dm(i,j)/(1.+rsub1(i,j)), 0.0)
+               y1(i,j)=.78/zr(i,j)**2+r23af*scv(i,j)/zr(i,j)**bwh5
+               y2(i,j)=r23br/(tca(i,j)*tair(i,j)**2)+1./(dwv(i,j) &
+                       *qsw(i,j))
+!cccc
+               ern(i,j)=r23t*ssw(i,j)*y1(i,j)/y2(i,j)
+               ern(i,j)=min(dd1(i,j),qr(i,j),max(ern(i,j),0.))
+               pt(i,j)=pt(i,j)-avcp*ern(i,j)
+               qv(i,j)=qv(i,j)+ern(i,j)
+               qr(i,j)=qr(i,j)-ern(i,j)
+            endif
+
+       ELSE       ! part of if (iwarm.eq.1) then
+!JJS 10/7/2008     ^^^^^
+
+!JJS   for calculating processes related to both ice and warm rain
+
+!     ***   COMPUTE ZR,ZS,ZG,VR,VS,VG      *****************************
+
+            if (qr(i,j) .gt. cmin1) then
+               dd(i,j)=r00*qr(i,j)
+               y1(i,j)=dd(i,j)**.25
+               zr(i,j)=zrc/y1(i,j)
+               vr(i,j)=max(vrcf*dd(i,j)**bwq, 0.)
+            endif
+
+            if (qs(i,j) .gt. cmin1) then
+               dd(i,j)=r00*qs(i,j)
+               y1(i,j)=dd(i,j)**.25
+               zs(i,j)=zsc/y1(i,j)
+               vs(i,j)=max(vscf*dd(i,j)**bsq, 0.)
+            endif
+
+            if (qg(i,j) .gt. cmin1) then
+               dd(i,j)=r00*qg(i,j)
+               y1(i,j)=dd(i,j)**.25
+               zg(i,j)=zgc/y1(i,j)
+               if(ihail .eq. 1) then
+                  vg(i,j)=max(vgcr*dd(i,j)**bgq, 0.)
+               else
+                  vg(i,j)=max(vgcf*dd(i,j)**bgq, 0.)
+               endif
+            endif
+
+            if (qr(i,j) .le. cmin2) vr(i,j)=0.0
+            if (qs(i,j) .le. cmin2) vs(i,j)=0.0
+            if (qg(i,j) .le. cmin2) vg(i,j)=0.0
+
+!     ******************************************************************
+!     ***   Y1 : DYNAMIC VISCOSITY OF AIR (U)
+!     ***   DWV : DIFFUSIVITY OF WATER VAPOR IN AIR (PI)
+!     ***   TCA : THERMAL CONDUCTIVITY OF AIR (KA)
+!     ***   Y2 : KINETIC VISCOSITY (V)
+
+            y1(i,j)=c149*tair(i,j)**1.5/(tair(i,j)+120.)
+            dwv(i,j)=dwvp*tair(i,j)**1.81
+            tca(i,j)=c141*y1(i,j)
+            scv(i,j)=1./((rr0*y1(i,j))**.1666667*dwv(i,j)**.3333333)
+!JJS  100    CONTINUE
+
+!*  1 * PSAUT : AUTOCONVERSION OF QI TO QS                        ***1**
+!*  3 * PSACI : ACCRETION OF QI TO QS                             ***3**
+!*  4 * PSACW : ACCRETION OF QC BY QS (RIMING) (QSACW FOR PSMLT)  ***4**
+!*  5 * PRACI : ACCRETION OF QI BY QR                             ***5**
+!*  6 * PIACR : ACCRETION OF QR OR QG BY QI                       ***6**
+
+!JJS         DO 125 J=3,JLES
+!JJS         DO 125 I=3,ILES
+            psaut(i,j)=0.0
+            psaci(i,j)=0.0
+            praci(i,j)=0.0
+            piacr(i,j)=0.0
+            psacw(i,j)=0.0
+            qsacw(i,j)=0.0
+            dd(i,j)=1./zs(i,j)**bs3
+
+            if (tair(i,j).lt.t0) then
+               esi(i,j)=exp(.025*tairc(i,j))
+               psaut(i,j)=r2is*max(rn1*esi(i,j)*(qi(i,j)-bnd1) ,0.0)
+               psaci(i,j)=r2is*r3f*esi(i,j)*qi(i,j)*dd(i,j)
+!JJS 3/30/06
+!    to cut water to snow accretion by half
+!               PSACW(I,J)=R4F*QC(I,J)*DD(I,J)
+               psacw(i,j)=r2is*0.5*r4f*qc(i,j)*dd(i,j)
+!JJS 3/30/06
+               praci(i,j)=r2is*r5f*qi(i,j)/zr(i,j)**bw3
+               piacr(i,j)=r2is*r6f*qi(i,j)*(zr(i,j)**(-bw6))
+!JJS               PIACR(I,J)=R6F*QI(I,J)/ZR(I,J)**BW6
+            else
+               qsacw(i,j)=r2is*r4f*qc(i,j)*dd(i,j)
+            endif
+
+!* 21 * PRAUT   AUTOCONVERSION OF QC TO QR                        **21**
+!* 22 * PRACW : ACCRETION OF QC BY QR                             **22**
+
+            pracw(i,j)=r22f*qc(i,j)/zr(i,j)**bw3
+            praut(i,j)=0.0
+            y1(i,j)=qc(i,j)-bnd3
+            if (y1(i,j).gt.0.0) then
+               praut(i,j)=r00*y1(i,j)*y1(i,j)/(1.2e-4+rn21/y1(i,j))
+            endif
+
+!* 12 * PSFW : BERGERON PROCESSES FOR QS (KOENING, 1971)          **12**
+!* 13 * PSFI : BERGERON PROCESSES FOR QS                          **13**
+
+            psfw(i,j)=0.0
+            psfi(i,j)=0.0
+            pidep(i,j)=0.0
+
+            if(tair(i,j).lt.t0.and.qi(i,j).gt.cmin) then
+               y1(i,j)=max( min(tairc(i,j), -1.), -31.)
+               it(i,j)=int(abs(y1(i,j)))
+               y1(i,j)=rn12a(it(i,j))
+               y2(i,j)=rn12b(it(i,j))
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+          psfw(i,j)=r2is* &
+                    max(d2t*y1(i,j)*(y2(i,j)+r12r*qc(i,j))*qi(i,j),0.0)
+               rtair(i,j)=1./(tair(i,j)-c76)
+               y2(i,j)=exp(c218-c580*rtair(i,j))
+               qsi(i,j)=rp0*y2(i,j)
+               esi(i,j)=c610*y2(i,j)
+               ssi(i,j)=(qv(i,j)+qb0)/qsi(i,j)-1.
+               r_nci=min(1.e-6*exp(-.46*tairc(i,j)),1.)
+!              R_NCI=min(1.e-8*EXP(-.6*TAIRC(I,J)),1.) ! use Tao's
+               dm(i,j)=max( (qv(i,j)+qb0-qsi(i,j)), 0.)
+               rsub1(i,j)=cs580*qsi(i,j)*rtair(i,j)*rtair(i,j)
+               y3(i,j)=1./tair(i,j)
+          dd(i,j)=y3(i,j)*(rn30a*y3(i,j)-rn30b)+rn30c*tair(i,j)/esi(i,j)
+               y1(i,j)=206.18*ssi(i,j)/dd(i,j)
+               pidep(i,j)=y1(i,j)*sqrt(r_nci*qi(i,j)/r00)
+               dep(i,j)=dm(i,j)/(1.+rsub1(i,j))/d2t
+               if(dm(i,j).gt.cmin2) then
+                  a2=1.
+                if(pidep(i,j).gt.dep(i,j).and.pidep(i,j).gt.cmin2) then
+                     a2=dep(i,j)/pidep(i,j)
+                     pidep(i,j)=dep(i,j)
+                endif
+                  psfi(i,j)=r2is*a2*.5*qi(i,j)*y1(i,j)/(sqrt(ami100) &
+                          -sqrt(ami40))
+                  elseif(dm(i,j).lt.-cmin2) then
+!
+!        SUBLIMATION TERMS USED ONLY WHEN SATURATION ADJUSTMENT FOR ICE
+!        IS TURNED OFF
+!
+                  pidep(i,j)=0.
+                  psfi(i,j)=0.
+               else
+                  pidep(i,j)=0.
+                  psfi(i,j)=0.
+               endif
+            endif
+
+!TTT***** QG=QG+MIN(PGDRY,PGWET)
+!*  9 * PGACS : ACCRETION OF QS BY QG (DGACS,WGACS: DRY AND WET)  ***9**
+!* 14 * DGACW : ACCRETION OF QC BY QG (QGACW FOR PGMLT)           **14**
+!* 16 * DGACR : ACCRETION OF QR TO QG (QGACR FOR PGMLT)           **16**
+
+            if(qc(i,j)+qr(i,j).lt.1.e-4) then
+               ee1=.01
+              else
+                 ee1=1.
+              endif
+            ee2=0.09
+            egs(i,j)=ee1*exp(ee2*tairc(i,j))
+!            EGS(I,J)=0.1 ! 6/15/02 tao's
+            if (tair(i,j).ge.t0) egs(i,j)=1.0
+            y1(i,j)=abs(vg(i,j)-vs(i,j))
+            y2(i,j)=zs(i,j)*zg(i,j)
+            y3(i,j)=5./y2(i,j)
+            y4(i,j)=.08*y3(i,j)*y3(i,j)
+            y5(i,j)=.05*y3(i,j)*y4(i,j)
+            dd(i,j)=y1(i,j)*(y3(i,j)/zs(i,j)**5+y4(i,j)/zs(i,j)**3 &
+                    +y5(i,j)/zs(i,j))
+            pgacs(i,j)=r2ig*r2is*r9r*egs(i,j)*dd(i,j)
+!JJS 1/3/06 from Steve and Chunglin
+            if (ihail.eq.1) then
+               dgacs(i,j)=pgacs(i,j)
+            else
+               dgacs(i,j)=0.
+            endif
+!JJS 1/3/06 from Steve and Chunglin
+            wgacs(i,j)=r2ig*r2is*r9r*dd(i,j)
+!            WGACS(I,J)=0.  ! 6/15/02 tao's
+            y1(i,j)=1./zg(i,j)**bg3
+
+            if(ihail .eq. 1) then
+               dgacw(i,j)=r2ig*max(r14r*qc(i,j)*y1(i,j), 0.0)
+            else
+               dgacw(i,j)=r2ig*max(r14f*qc(i,j)*y1(i,j), 0.0)
+            endif
+
+            qgacw(i,j)=dgacw(i,j)
+            y1(i,j)=abs(vg(i,j)-vr(i,j))
+            y2(i,j)=zr(i,j)*zg(i,j)
+            y3(i,j)=5./y2(i,j)
+            y4(i,j)=.08*y3(i,j)*y3(i,j)
+            y5(i,j)=.05*y3(i,j)*y4(i,j)
+            dd(i,j)=r16r*y1(i,j)*(y3(i,j)/zr(i,j)**5+y4(i,j)/zr(i,j)**3 &
+                    +y5(i,j)/zr(i,j))
+            dgacr(i,j)=r2ig*max(dd(i,j), 0.0)
+            qgacr(i,j)=dgacr(i,j)
+
+            if (tair(i,j).ge.t0) then
+               dgacs(i,j)=0.0
+               wgacs(i,j)=0.0
+               dgacw(i,j)=0.0
+               dgacr(i,j)=0.0
+            else
+               pgacs(i,j)=0.0
+               qgacw(i,j)=0.0
+               qgacr(i,j)=0.0
+            endif
+
+!*******PGDRY : DGACW+DGACI+DGACR+DGACS                           ******
+!* 15 * DGACI : ACCRETION OF QI BY QG (WGACI FOR WET GROWTH)      **15**
+!* 17 * PGWET : WET GROWTH OF QG                                  **17**
+
+            dgaci(i,j)=0.0
+            wgaci(i,j)=0.0
+            pgwet(i,j)=0.0
+
+            if (tair(i,j).lt.t0) then
+               y1(i,j)=qi(i,j)/zg(i,j)**bg3
+               if (ihail.eq.1) then
+                  dgaci(i,j)=r2ig*r15r*y1(i,j)
+                  wgaci(i,j)=r2ig*r15ar*y1(i,j)
+!                  WGACI(I,J)=0.  ! 6/15/02 tao's
+               else
+
+!JJS                  DGACI(I,J)=r2ig*R15F*Y1(I,J)
+                   dgaci(i,j)=0.
+                  wgaci(i,j)=r2ig*r15af*y1(i,j)
+!                  WGACI(I,J)=0.  ! 6/15/02 tao's
+               endif
+!
+               if (tairc(i,j).ge.-50.) then
+                if (alf+rn17c*tairc(i,j) .eq. 0.) then
+                   write(91,*) itimestep, i,j,k, alf, rn17c, tairc(i,j)
+                endif
+                y1(i,j)=1./(alf+rn17c*tairc(i,j))
+                if (ihail.eq.1) then
+                   y3(i,j)=.78/zg(i,j)**2+r17aq*scv(i,j)/zg(i,j)**bgh5
+                else
+                   y3(i,j)=.78/zg(i,j)**2+r17as*scv(i,j)/zg(i,j)**bgh5
+                endif
+                y4(i,j)=alvr*dwv(i,j)*(rp0-(qv(i,j)+qb0)) &
+                        -tca(i,j)*tairc(i,j)
+                dd(i,j)=y1(i,j)*(r17r*y4(i,j)*y3(i,j) &
+                       +(wgaci(i,j)+wgacs(i,j))*(alf+rn17b*tairc(i,j)))
+                pgwet(i,j)=r2ig*max(dd(i,j), 0.0)
+               endif
+            endif
+!JJS  125    CONTINUE
+
+!********   HANDLING THE NEGATIVE CLOUD WATER (QC)    ******************
+!********   HANDLING THE NEGATIVE CLOUD ICE (QI)      ******************
+
+!JJS         DO 150 J=3,JLES
+!JJS         DO 150 I=3,ILES
+
+            y1(i,j)=qc(i,j)/d2t
+            psacw(i,j)=min(y1(i,j), psacw(i,j))
+            praut(i,j)=min(y1(i,j), praut(i,j))
+            pracw(i,j)=min(y1(i,j), pracw(i,j))
+            psfw(i,j)= min(y1(i,j), psfw(i,j))
+            dgacw(i,j)=min(y1(i,j), dgacw(i,j))
+            qsacw(i,j)=min(y1(i,j), qsacw(i,j))
+            qgacw(i,j)=min(y1(i,j), qgacw(i,j))
+
+            y1(i,j)=(psacw(i,j)+praut(i,j)+pracw(i,j)+psfw(i,j) &
+                    +dgacw(i,j)+qsacw(i,j)+qgacw(i,j))*d2t
+            qc(i,j)=qc(i,j)-y1(i,j)
+
+            if (qc(i,j) .lt. 0.0) then
+               a1=1.
+               if (y1(i,j) .ne. 0.0) a1=qc(i,j)/y1(i,j)+1.
+               psacw(i,j)=psacw(i,j)*a1
+               praut(i,j)=praut(i,j)*a1
+               pracw(i,j)=pracw(i,j)*a1
+               psfw(i,j)=psfw(i,j)*a1
+               dgacw(i,j)=dgacw(i,j)*a1
+               qsacw(i,j)=qsacw(i,j)*a1
+               qgacw(i,j)=qgacw(i,j)*a1
+               qc(i,j)=0.0
+            endif
+!c
+!
+!******** SHED PROCESS (WGACR=PGWET-DGACW-WGACI-WGACS)
+!c
+            wgacr(i,j)=pgwet(i,j)-dgacw(i,j)-wgaci(i,j)-wgacs(i,j)
+            y2(i,j)=dgacw(i,j)+dgaci(i,j)+dgacr(i,j)+dgacs(i,j)
+            if (pgwet(i,j).ge.y2(i,j)) then
+               wgacr(i,j)=0.0
+               wgaci(i,j)=0.0
+               wgacs(i,j)=0.0
+            else
+               dgacr(i,j)=0.0
+               dgaci(i,j)=0.0
+               dgacs(i,j)=0.0
+            endif
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!c
+            y1(i,j)=qi(i,j)/d2t
+            psaut(i,j)=min(y1(i,j), psaut(i,j))
+            psaci(i,j)=min(y1(i,j), psaci(i,j))
+            praci(i,j)=min(y1(i,j), praci(i,j))
+            psfi(i,j)= min(y1(i,j), psfi(i,j))
+            dgaci(i,j)=min(y1(i,j), dgaci(i,j))
+            wgaci(i,j)=min(y1(i,j), wgaci(i,j))
+!
+            y2(i,j)=(psaut(i,j)+psaci(i,j)+praci(i,j)+psfi(i,j) &
+                   +dgaci(i,j)+wgaci(i,j))*d2t
+            qi(i,j)=qi(i,j)-y2(i,j)+pidep(i,j)*d2t
+
+            if (qi(i,j).lt.0.0) then
+               a2=1.
+               if (y2(i,j) .ne. 0.0) a2=qi(i,j)/y2(i,j)+1.
+               psaut(i,j)=psaut(i,j)*a2
+               psaci(i,j)=psaci(i,j)*a2
+               praci(i,j)=praci(i,j)*a2
+               psfi(i,j)=psfi(i,j)*a2
+               dgaci(i,j)=dgaci(i,j)*a2
+               wgaci(i,j)=wgaci(i,j)*a2
+               qi(i,j)=0.0
+            endif
+!
+            dlt3(i,j)=0.0
+            dlt2(i,j)=0.0
+!
+
+!            DLT4(I,J)=1.0
+!            if(qc(i,j) .gt. 5.e-4) dlt4(i,j)=0.0
+!            if(qs(i,j) .le. 1.e-4) dlt4(i,j)=1.0
+!
+!            IF (TAIR(I,J).ge.T0) THEN
+!               DLT4(I,J)=0.0
+!            ENDIF
+
+            if (tair(i,j).lt.t0) then
+               if (qr(i,j).lt.1.e-4) then
+                  dlt3(i,j)=1.0
+                  dlt2(i,j)=1.0
+               endif
+               if (qs(i,j).ge.1.e-4) then
+                  dlt2(i,j)=0.0
+               endif
+            endif
+
+            if (ice2 .eq. 1) then
+                  dlt3(i,j)=1.0
+                  dlt2(i,j)=1.0
+            endif
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+            pr(i,j)=(qsacw(i,j)+praut(i,j)+pracw(i,j)+qgacw(i,j))*d2t
+            ps(i,j)=(psaut(i,j)+psaci(i,j)+psacw(i,j)+psfw(i,j) &
+                    +psfi(i,j)+dlt3(i,j)*praci(i,j))*d2t
+!           PS(I,J)=(PSAUT(I,J)+PSACI(I,J)+dlt4(i,j)*PSACW(I,J)
+!    1              +PSFW(I,J)+PSFI(I,J)+DLT3(I,J)*PRACI(I,J))*D2T
+            pg(i,j)=((1.-dlt3(i,j))*praci(i,j)+dgaci(i,j)+wgaci(i,j) &
+                    +dgacw(i,j))*d2t
+!           PG(I,J)=((1.-DLT3(I,J))*PRACI(I,J)+DGACI(I,J)+WGACI(I,J)
+!    1              +DGACW(I,J)+(1.-dlt4(i,j))*PSACW(I,J))*D2T
+
+!JJS  150    CONTINUE
+
+!*  7 * PRACS : ACCRETION OF QS BY QR                             ***7**
+!*  8 * PSACR : ACCRETION OF QR BY QS (QSACR FOR PSMLT)           ***8**
+
+!JJS         DO 175 J=3,JLES
+!JJS         DO 175 I=3,ILES
+
+            y1(i,j)=abs(vr(i,j)-vs(i,j))
+            y2(i,j)=zr(i,j)*zs(i,j)
+            y3(i,j)=5./y2(i,j)
+            y4(i,j)=.08*y3(i,j)*y3(i,j)
+            y5(i,j)=.05*y3(i,j)*y4(i,j)
+            pracs(i,j)=r2ig*r2is*r7r*y1(i,j)*(y3(i,j)/zs(i,j)**5 &
+                      +y4(i,j)/zs(i,j)**3+y5(i,j)/zs(i,j))
+            psacr(i,j)=r2is*r8r*y1(i,j)*(y3(i,j)/zr(i,j)**5 &
+                      +y4(i,j)/zr(i,j)**3+y5(i,j)/zr(i,j))
+            qsacr(i,j)=psacr(i,j)
+
+            if (tair(i,j).ge.t0) then
+               pracs(i,j)=0.0
+               psacr(i,j)=0.0
+            else
+               qsacr(i,j)=0.0
+            endif
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!*  2 * PGAUT : AUTOCONVERSION OF QS TO QG                        ***2**
+!* 18 * PGFR : FREEZING OF QR TO QG                               **18**
+
+            pgaut(i,j)=0.0
+            pgfr(i,j)=0.0
+
+            if (tair(i,j) .lt. t0) then
+!               Y1(I,J)=EXP(.09*TAIRC(I,J))
+!               PGAUT(I,J)=r2is*max(RN2*Y1(I,J)*(QS(I,J)-BND2), 0.0)
+!         IF(IHAIL.EQ.1) PGAUT(I,J)=max(RN2*Y1(I,J)*(QS(I,J)-BND2),0.0)
+               y2(i,j)=exp(rn18a*(t0-tair(i,j)))
+!JJS              PGFR(I,J)=r2ig*max(R18R*(Y2(I,J)-1.)/ZR(I,J)**7., 0.0)
+!              pgfr(i,j)=r2ice*max(r18r*(y2(i,j)-1.)* &
+!                                    (zr(i,j)**(-7.)), 0.0)
+!        modify to prevent underflow on some computers (JD)
+               temp = 1./zr(i,j)
+               temp = temp*temp*temp*temp*temp*temp*temp
+               pgfr(i,j)=r2ig*max(r18r*(y2(i,j)-1.)* &
+                                    temp, 0.0)
+            endif
+
+!JJS  175    CONTINUE
+
+!********   HANDLING THE NEGATIVE RAIN WATER (QR)    *******************
+!********   HANDLING THE NEGATIVE SNOW (QS)          *******************
+
+!JJS         DO 200 J=3,JLES
+!JJS         DO 200 I=3,ILES
+
+            y1(i,j)=qr(i,j)/d2t
+            y2(i,j)=-qg(i,j)/d2t
+            piacr(i,j)=min(y1(i,j), piacr(i,j))
+            dgacr(i,j)=min(y1(i,j), dgacr(i,j))
+            wgacr(i,j)=min(y1(i,j), wgacr(i,j))
+            wgacr(i,j)=max(y2(i,j), wgacr(i,j))
+            psacr(i,j)=min(y1(i,j), psacr(i,j))
+            pgfr(i,j)= min(y1(i,j), pgfr(i,j))
+            del=0.
+            if(wgacr(i,j) .lt. 0.) del=1.
+            y1(i,j)=(piacr(i,j)+dgacr(i,j)+(1.-del)*wgacr(i,j) &
+                    +psacr(i,j)+pgfr(i,j))*d2t
+            qr(i,j)=qr(i,j)+pr(i,j)-y1(i,j)-del*wgacr(i,j)*d2t
+            if (qr(i,j) .lt. 0.0) then
+               a1=1.
+               if(y1(i,j) .ne. 0.) a1=qr(i,j)/y1(i,j)+1.
+               piacr(i,j)=piacr(i,j)*a1
+               dgacr(i,j)=dgacr(i,j)*a1
+               if (wgacr(i,j).gt.0.) wgacr(i,j)=wgacr(i,j)*a1
+               pgfr(i,j)=pgfr(i,j)*a1
+               psacr(i,j)=psacr(i,j)*a1
+               qr(i,j)=0.0
+            endif
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+            prn(i,j)=d2t*((1.-dlt3(i,j))*piacr(i,j)+dgacr(i,j) &
+                     +wgacr(i,j)+(1.-dlt2(i,j))*psacr(i,j)+pgfr(i,j))
+            ps(i,j)=ps(i,j)+d2t*(dlt3(i,j)*piacr(i,j) &
+                    +dlt2(i,j)*psacr(i,j))
+            pracs(i,j)=(1.-dlt2(i,j))*pracs(i,j)
+            y1(i,j)=qs(i,j)/d2t
+            pgacs(i,j)=min(y1(i,j), pgacs(i,j))
+            dgacs(i,j)=min(y1(i,j), dgacs(i,j))
+            wgacs(i,j)=min(y1(i,j), wgacs(i,j))
+            pgaut(i,j)=min(y1(i,j), pgaut(i,j))
+            pracs(i,j)=min(y1(i,j), pracs(i,j))
+            psn(i,j)=d2t*(pgacs(i,j)+dgacs(i,j)+wgacs(i,j) &
+                     +pgaut(i,j)+pracs(i,j))
+            qs(i,j)=qs(i,j)+ps(i,j)-psn(i,j)
+
+            if (qs(i,j).lt.0.0) then
+               a2=1.
+               if (psn(i,j) .ne. 0.0) a2=qs(i,j)/psn(i,j)+1.
+               pgacs(i,j)=pgacs(i,j)*a2
+               dgacs(i,j)=dgacs(i,j)*a2
+               wgacs(i,j)=wgacs(i,j)*a2
+               pgaut(i,j)=pgaut(i,j)*a2
+               pracs(i,j)=pracs(i,j)*a2
+               psn(i,j)=psn(i,j)*a2
+               qs(i,j)=0.0
+            endif
+!
+!C           PSN(I,J)=D2T*(PGACS(I,J)+DGACS(I,J)+WGACS(I,J)
+!c                    +PGAUT(I,J)+PRACS(I,J))
+            y2(i,j)=d2t*(psacw(i,j)+psfw(i,j)+dgacw(i,j)+piacr(i,j) &
+                    +dgacr(i,j)+wgacr(i,j)+psacr(i,j)+pgfr(i,j))
+            pt(i,j)=pt(i,j)+afcp*y2(i,j)
+            qg(i,j)=qg(i,j)+pg(i,j)+prn(i,j)+psn(i,j)
+
+!JJS  200    CONTINUE
+
+!* 11 * PSMLT : MELTING OF QS                                     **11**
+!* 19 * PGMLT : MELTING OF QG TO QR                               **19**
+
+!JJS         DO 225 J=3,JLES
+!JJS         DO 225 I=3,ILES
+
+            psmlt(i,j)=0.0
+            pgmlt(i,j)=0.0
+            tair(i,j)=(pt(i,j)+tb0)*pi0
+
+            if (tair(i,j).ge.t0) then
+               tairc(i,j)=tair(i,j)-t0
+               y1(i,j)=tca(i,j)*tairc(i,j)-alvr*dwv(i,j) &
+                               *(rp0-(qv(i,j)+qb0))
+               y2(i,j)=.78/zs(i,j)**2+r101f*scv(i,j)/zs(i,j)**bsh5
+               dd(i,j)=r11rt*y1(i,j)*y2(i,j)+r11at*tairc(i,j) &
+                       *(qsacw(i,j)+qsacr(i,j))
+               psmlt(i,j)=r2is*max(0.0, min(dd(i,j), qs(i,j)))
+
+               if(ihail.eq.1) then
+                  y3(i,j)=.78/zg(i,j)**2+r19aq*scv(i,j)/zg(i,j)**bgh5
+               else
+                  y3(i,j)=.78/zg(i,j)**2+r19as*scv(i,j)/zg(i,j)**bgh5
+               endif
+
+               dd1(i,j)=r19rt*y1(i,j)*y3(i,j)+r19bt*tairc(i,j) &
+                        *(qgacw(i,j)+qgacr(i,j))
+               pgmlt(i,j)=r2ig*max(0.0, min(dd1(i,j), qg(i,j)))
+               pt(i,j)=pt(i,j)-afcp*(psmlt(i,j)+pgmlt(i,j))
+               qr(i,j)=qr(i,j)+psmlt(i,j)+pgmlt(i,j)
+               qs(i,j)=qs(i,j)-psmlt(i,j)
+               qg(i,j)=qg(i,j)-pgmlt(i,j)
+            endif
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!* 24 * PIHOM : HOMOGENEOUS FREEZING OF QC TO QI (T < T00)        **24**
+!* 25 * PIDW : DEPOSITION GROWTH OF QC TO QI ( T0 < T <= T00)     **25**
+!* 26 * PIMLT : MELTING OF QI TO QC (T >= T0)                     **26**
+
+            if (qc(i,j).le.cmin1) qc(i,j)=0.0
+            if (qi(i,j).le.cmin1) qi(i,j)=0.0
+            tair(i,j)=(pt(i,j)+tb0)*pi0
+
+            if(tair(i,j).le.t00) then
+               pihom(i,j)=qc(i,j)
+            else
+               pihom(i,j)=0.0
+            endif
+            if(tair(i,j).ge.t0) then
+               pimlt(i,j)=qi(i,j)
+            else
+               pimlt(i,j)=0.0
+            endif
+            pidw(i,j)=0.0
+
+            if (tair(i,j).lt.t0 .and. tair(i,j).gt.t00) then
+               tairc(i,j)=tair(i,j)-t0
+               y1(i,j)=max( min(tairc(i,j), -1.), -31.)
+               it(i,j)=int(abs(y1(i,j)))
+               y2(i,j)=aa1(it(i,j))
+               y3(i,j)=aa2(it(i,j))
+               y4(i,j)=exp(abs(beta*tairc(i,j)))
+               y5(i,j)=(r00*qi(i,j)/(r25a*y4(i,j)))**y3(i,j)
+               pidw(i,j)=min(r25rt*y2(i,j)*y4(i,j)*y5(i,j), qc(i,j))
+            endif
+
+            y1(i,j)=pihom(i,j)-pimlt(i,j)+pidw(i,j)
+            pt(i,j)=pt(i,j)+afcp*y1(i,j)+ascp*(pidep(i,j))*d2t
+            qv(i,j)=qv(i,j)-(pidep(i,j))*d2t
+            qc(i,j)=qc(i,j)-y1(i,j)
+            qi(i,j)=qi(i,j)+y1(i,j)
+
+!* 31 * PINT  : INITIATION OF QI                                  **31**
+!* 32 * PIDEP : DEPOSITION OF QI                                  **32**
+!
+!     CALCULATION OF PINT USES DIFFERENT VALUES OF THE INTERCEPT AND SLOPE FOR
+!     THE FLETCHER EQUATION. ALSO, ONLY INITIATE MORE ICE IF THE NEW NUMBER
+!     CONCENTRATION EXCEEDS THAT ALREADY PRESENT.
+!* 31 * pint  : initiation of qi                                  **31**
+!* 32 * pidep : deposition of qi                                  **32**
+           pint(i,j)=0.0
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+        if ( itaobraun.eq.1 ) then
+            tair(i,j)=(pt(i,j)+tb0)*pi0
+            if (tair(i,j) .lt. t0) then
+!             if (qi(i,j) .le. cmin) qi(i,j)=0.
+              if (qi(i,j) .le. cmin2) qi(i,j)=0.
+               tairc(i,j)=tair(i,j)-t0
+               rtair(i,j)=1./(tair(i,j)-c76)
+               y2(i,j)=exp(c218-c580*rtair(i,j))
+              qsi(i,j)=rp0*y2(i,j)
+               esi(i,j)=c610*y2(i,j)
+              ssi(i,j)=(qv(i,j)+qb0)/qsi(i,j)-1.
+                        ami50=3.76e-8
+
+!ccif ( itaobraun.eq.1 ) --> betah=0.5*beta=-.46*0.5=-0.23;   cn0=1.e-6
+!ccif ( itaobraun.eq.0 ) --> betah=0.5*beta=-.6*0.5=-0.30;    cn0=1.e-8
+
+             y1(i,j)=1./tair(i,j)
+
+!cc insert a restriction on ice collection that ice collection
+!cc should be stopped at -30 c (with cn0=1.e-6, beta=-.46)
+
+             tairccri=tairc(i,j)          ! in degree c
+             if(tairccri.le.-30.) tairccri=-30.
+
+!            y2(i,j)=exp(betah*tairc(i,j))
+             y2(i,j)=exp(betah*tairccri)
+             y3(i,j)=sqrt(qi(i,j))
+             dd(i,j)=y1(i,j)*(rn10a*y1(i,j)-rn10b)+rn10c*tair(i,j) &
+                                                /esi(i,j)
+          pidep(i,j)=max(r32rt*ssi(i,j)*y2(i,j)*y3(i,j)/dd(i,j), 0.e0)
+
+           r_nci=min(cn0*exp(beta*tairc(i,j)),1.)
+!          r_nci=min(1.e-6*exp(-.46*tairc(i,j)),1.)
+
+           dd(i,j)=max(1.e-9*r_nci/r00-qi(i,j)*1.e-9/ami50, 0.)
+                dm(i,j)=max( (qv(i,j)+qb0-qsi(i,j)), 0.0)
+                rsub1(i,j)=cs580*qsi(i,j)*rtair(i,j)*rtair(i,j)
+              dep(i,j)=dm(i,j)/(1.+rsub1(i,j))
+              pint(i,j)=max(min(dd(i,j), dm(i,j)), 0.)
+
+!             pint(i,j)=min(pint(i,j), dep(i,j))
+              pint(i,j)=min(pint(i,j)+pidep(i,j), dep(i,j))
+
+!              if (pint(i,j) .le. cmin) pint(i,j)=0.
+               if (pint(i,j) .le. cmin2) pint(i,j)=0.
+              pt(i,j)=pt(i,j)+ascp*pint(i,j)
+              qv(i,j)=qv(i,j)-pint(i,j)
+              qi(i,j)=qi(i,j)+pint(i,j)
+           endif
+        endif  ! if ( itaobraun.eq.1 )
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+        if ( itaobraun.eq.0 ) then
+             tair(i,j)=(pt(i,j)+tb0)*pi0
+             if (tair(i,j) .lt. t0) then
+               if (qi(i,j) .le. cmin1) qi(i,j)=0.
+               tairc(i,j)=tair(i,j)-t0
+               dd(i,j)=r31r*exp(beta*tairc(i,j))
+               rtair(i,j)=1./(tair(i,j)-c76)
+               y2(i,j)=exp(c218-c580*rtair(i,j))
+               qsi(i,j)=rp0*y2(i,j)
+               esi(i,j)=c610*y2(i,j)
+               ssi(i,j)=(qv(i,j)+qb0)/qsi(i,j)-1.
+               dm(i,j)=max( (qv(i,j)+qb0-qsi(i,j)), 0.)
+               rsub1(i,j)=cs580*qsi(i,j)*rtair(i,j)*rtair(i,j)
+               dep(i,j)=dm(i,j)/(1.+rsub1(i,j))
+              pint(i,j)=max(min(dd(i,j), dm(i,j)), 0.)
+               y1(i,j)=1./tair(i,j)
+               y2(i,j)=exp(betah*tairc(i,j))
+               y3(i,j)=sqrt(qi(i,j))
+               dd(i,j)=y1(i,j)*(rn10a*y1(i,j)-rn10b) &
+                     +rn10c*tair(i,j)/esi(i,j)
+             pidep(i,j)=max(r32rt*ssi(i,j)*y2(i,j)*y3(i,j)/dd(i,j), 0.)
+              pint(i,j)=pint(i,j)+pidep(i,j)
+              pint(i,j)=min(pint(i,j),dep(i,j))
+!c          if (pint(i,j) .le. cmin2) pint(i,j)=0.
+             pt(i,j)=pt(i,j)+ascp*pint(i,j)
+             qv(i,j)=qv(i,j)-pint(i,j)
+             qi(i,j)=qi(i,j)+pint(i,j)
+            endif
+        endif  ! if ( itaobraun.eq.0 )
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+!JJS  225    CONTINUE
+
+!*****   TAO ET AL (1989) SATURATION TECHNIQUE  ***********************
+
+         if (new_ice_sat .eq. 0) then
+
+!JJS            DO 250 J=3,JLES
+!JJS            DO 250 I=3,ILES
+               tair(i,j)=(pt(i,j)+tb0)*pi0
+               cnd(i,j)=rt0*(tair(i,j)-t00)
+               dep(i,j)=rt0*(t0-tair(i,j))
+               y1(i,j)=1./(tair(i,j)-c358)
+               y2(i,j)=1./(tair(i,j)-c76)
+               qsw(i,j)=rp0*exp(c172-c409*y1(i,j))
+               qsi(i,j)=rp0*exp(c218-c580*y2(i,j))
+               dd(i,j)=cp409*y1(i,j)*y1(i,j)
+               dd1(i,j)=cp580*y2(i,j)*y2(i,j)
+               if (qc(i,j).le.cmin) qc(i,j)=cmin
+               if (qi(i,j).le.cmin) qi(i,j)=cmin
+               if (tair(i,j).ge.t0) then
+                  dep(i,j)=0.0
+                  cnd(i,j)=1.
+                  qi(i,j)=0.0
+               endif
+
+               if (tair(i,j).lt.t00) then
+                  cnd(i,j)=0.0
+                  dep(i,j)=1.
+                  qc(i,j)=0.0
+               endif
+
+               y5(i,j)=avcp*cnd(i,j)+ascp*dep(i,j)
+!               if (qc(i,j) .ge. cmin .or. qi(i,j) .ge. cmin) then
+               y1(i,j)=qc(i,j)*qsw(i,j)/(qc(i,j)+qi(i,j))
+               y2(i,j)=qi(i,j)*qsi(i,j)/(qc(i,j)+qi(i,j))
+               y4(i,j)=dd(i,j)*y1(i,j)+dd1(i,j)*y2(i,j)
+               qvs(i,j)=y1(i,j)+y2(i,j)
+               rsub1(i,j)=(qv(i,j)+qb0-qvs(i,j))/(1.+y4(i,j)*y5(i,j))
+               cnd(i,j)=cnd(i,j)*rsub1(i,j)
+               dep(i,j)=dep(i,j)*rsub1(i,j)
+               if (qc(i,j).le.cmin) qc(i,j)=0.
+               if (qi(i,j).le.cmin) qi(i,j)=0.
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!c    ******   condensation or evaporation of qc  ******
+
+               cnd(i,j)=max(-qc(i,j),cnd(i,j))
+
+!c    ******   deposition or sublimation of qi    ******
+
+               dep(i,j)=max(-qi(i,j),dep(i,j))
+
+               pt(i,j)=pt(i,j)+avcp*cnd(i,j)+ascp*dep(i,j)
+               qv(i,j)=qv(i,j)-cnd(i,j)-dep(i,j)
+               qc(i,j)=qc(i,j)+cnd(i,j)
+               qi(i,j)=qi(i,j)+dep(i,j)
+!JJS  250       continue
+         endif
+
+         if (new_ice_sat .eq. 1) then
+
+!JJS            DO J=3,JLES
+!JJS            DO I=3,ILES
+
+               tair(i,j)=(pt(i,j)+tb0)*pi0
+               cnd(i,j)=rt0*(tair(i,j)-t00)
+               dep(i,j)=rt0*(t0-tair(i,j))
+               y1(i,j)=1./(tair(i,j)-c358)
+               y2(i,j)=1./(tair(i,j)-c76)
+               qsw(i,j)=rp0*exp(c172-c409*y1(i,j))
+               qsi(i,j)=rp0*exp(c218-c580*y2(i,j))
+               dd(i,j)=cp409*y1(i,j)*y1(i,j)
+               dd1(i,j)=cp580*y2(i,j)*y2(i,j)
+               y5(i,j)=avcp*cnd(i,j)+ascp*dep(i,j)
+               y1(i,j)=rt0*(tair(i,j)-t00)*qsw(i,j)
+               y2(i,j)=rt0*(t0-tair(i,j))*qsi(i,j)
+!               IF (QC(I,J).LE.CMIN) QC(I,J)=CMIN
+!               IF (QI(I,J).LE.CMIN) QI(I,J)=CMIN
+
+               if (tair(i,j).ge.t0) then
+!                 QI(I,J)=0.0
+                  dep(i,j)=0.0
+                  cnd(i,j)=1.
+                  y2(i,j)=0.
+                  y1(i,j)=qsw(i,j)
+               endif
+               if (tair(i,j).lt.t00) then
+                  cnd(i,j)=0.0
+                  dep(i,j)=1.
+                  y2(i,j)=qsi(i,j)
+                  y1(i,j)=0.
+!                 QC(I,J)=0.0
+               endif
+
+!            Y1(I,J)=QC(I,J)*QSW(I,J)/(QC(I,J)+QI(I,J))
+!            Y2(I,J)=QI(I,J)*QSI(I,J)/(QC(I,J)+QI(I,J))
+
+               y4(i,j)=dd(i,j)*y1(i,j)+dd1(i,j)*y2(i,j)
+               qvs(i,j)=y1(i,j)+y2(i,j)
+               rsub1(i,j)=(qv(i,j)+qb0-qvs(i,j))/(1.+y4(i,j)*y5(i,j))
+               cnd(i,j)=cnd(i,j)*rsub1(i,j)
+               dep(i,j)=dep(i,j)*rsub1(i,j)
+!               IF (QC(I,J).LE.CMIN) QC(I,J)=0.
+!               IF (QI(I,J).LE.CMIN) QI(I,J)=0.
+
+!C    ******   CONDENSATION OR EVAPORATION OF QC  ******
+
+               cnd(i,j)=max(-qc(i,j),cnd(i,j))
+
+!C    ******   DEPOSITION OR SUBLIMATION OF QI    ******
+
+               dep(i,j)=max(-qi(i,j),dep(i,j))
+
+               pt(i,j)=pt(i,j)+avcp*cnd(i,j)+ascp*dep(i,j)
+               qv(i,j)=qv(i,j)-cnd(i,j)-dep(i,j)
+               qc(i,j)=qc(i,j)+cnd(i,j)
+               qi(i,j)=qi(i,j)+dep(i,j)
+!JJS            ENDDO
+!JJS            ENDDO
+         endif
+
+!c
+!
+          if (new_ice_sat .eq. 2) then
+!JJS          do j=3,jles
+!JJS             do i=3,iles
+          dep(i,j)=0.0
+          cnd(i,j)=0.0
+          tair(i,j)=(pt(i,j)+tb0)*pi0
+          if (tair(i,j) .ge. 253.16) then
+              y1(i,j)=1./(tair(i,j)-c358)
+              qsw(i,j)=rp0*exp(c172-c409*y1(i,j))
+              dd(i,j)=cp409*y1(i,j)*y1(i,j)
+              dm(i,j)=qv(i,j)+qb0-qsw(i,j)
+              cnd(i,j)=dm(i,j)/(1.+avcp*dd(i,j)*qsw(i,j))
+!c    ******   condensation or evaporation of qc  ******
+              cnd(i,j)=max(-qc(i,j), cnd(i,j))
+             pt(i,j)=pt(i,j)+avcp*cnd(i,j)
+             qv(i,j)=qv(i,j)-cnd(i,j)
+             qc(i,j)=qc(i,j)+cnd(i,j)
+         endif
+          if (tair(i,j) .le. 258.16) then
+!c             cnd(i,j)=0.0
+           y2(i,j)=1./(tair(i,j)-c76)
+           qsi(i,j)=rp0*exp(c218-c580*y2(i,j))
+          dd1(i,j)=cp580*y2(i,j)*y2(i,j)
+         dep(i,j)=(qv(i,j)+qb0-qsi(i,j))/(1.+ascp*dd1(i,j)*qsi(i,j))
+!c    ******   deposition or sublimation of qi    ******
+             dep(i,j)=max(-qi(i,j),dep(i,j))
+             pt(i,j)=pt(i,j)+ascp*dep(i,j)
+             qv(i,j)=qv(i,j)-dep(i,j)
+             qi(i,j)=qi(i,j)+dep(i,j)
+         endif
+!JJS       enddo
+!JJS       enddo
+      endif
+
+!c
+!
+!* 10 * PSDEP : DEPOSITION OR SUBLIMATION OF QS                   **10**
+!* 20 * PGSUB : SUBLIMATION OF QG                                 **20**
+
+!JJS         DO 275 J=3,JLES
+!JJS         DO 275 I=3,ILES
+
+            psdep(i,j)=0.0
+            pgdep(i,j)=0.0
+            pssub(i,j)=0.0
+            pgsub(i,j)=0.0
+            tair(i,j)=(pt(i,j)+tb0)*pi0
+
+            if(tair(i,j).lt.t0) then
+               if(qs(i,j).lt.cmin1) qs(i,j)=0.0
+               if(qg(i,j).lt.cmin1) qg(i,j)=0.0
+               rtair(i,j)=1./(tair(i,j)-c76)
+               qsi(i,j)=rp0*exp(c218-c580*rtair(i,j))
+               ssi(i,j)=(qv(i,j)+qb0)/qsi(i,j)-1.
+!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+               y1(i,j)=r10ar/(tca(i,j)*tair(i,j)**2)+1./(dwv(i,j) &
+                      *qsi(i,j))
+               y2(i,j)=.78/zs(i,j)**2+r101f*scv(i,j)/zs(i,j)**bsh5
+               psdep(i,j)=r10t*ssi(i,j)*y2(i,j)/y1(i,j)
+               pssub(i,j)=psdep(i,j)
+               psdep(i,j)=r2is*max(psdep(i,j), 0.)
+               pssub(i,j)=r2is*max(-qs(i,j), min(pssub(i,j), 0.))
+
+               if(ihail.eq.1) then
+                  y2(i,j)=.78/zg(i,j)**2+r20bq*scv(i,j)/zg(i,j)**bgh5
+               else
+                  y2(i,j)=.78/zg(i,j)**2+r20bs*scv(i,j)/zg(i,j)**bgh5
+               endif
+
+               pgsub(i,j)=r2ig*r20t*ssi(i,j)*y2(i,j)/y1(i,j)
+               dm(i,j)=qv(i,j)+qb0-qsi(i,j)
+               rsub1(i,j)=cs580*qsi(i,j)*rtair(i,j)*rtair(i,j)
+
+!     ********   DEPOSITION OR SUBLIMATION OF QS  **********************
+
+               y1(i,j)=dm(i,j)/(1.+rsub1(i,j))
+               psdep(i,j)=r2is*min(psdep(i,j),max(y1(i,j),0.))
+               y2(i,j)=min(y1(i,j),0.)
+               pssub(i,j)=r2is*max(pssub(i,j),y2(i,j))
+
+!     ********   SUBLIMATION OF QG   ***********************************
+
+               dd(i,j)=max((-y2(i,j)-qs(i,j)), 0.)
+              pgsub(i,j)=r2ig*min(dd(i,j), qg(i,j), max(pgsub(i,j),0.))
+
+               if(qc(i,j)+qi(i,j).gt.1.e-5) then
+                  dlt1(i,j)=1.
+               else
+                  dlt1(i,j)=0.
+               endif
+
+               psdep(i,j)=dlt1(i,j)*psdep(i,j)
+               pssub(i,j)=(1.-dlt1(i,j))*pssub(i,j)
+               pgsub(i,j)=(1.-dlt1(i,j))*pgsub(i,j)
+
+               pt(i,j)=pt(i,j)+ascp*(psdep(i,j)+pssub(i,j)-pgsub(i,j))
+               qv(i,j)=qv(i,j)+pgsub(i,j)-pssub(i,j)-psdep(i,j)
+               qs(i,j)=qs(i,j)+psdep(i,j)+pssub(i,j)
+               qg(i,j)=qg(i,j)-pgsub(i,j)
+            endif
+
+!* 23 * ERN : EVAPORATION OF QR (SUBSATURATION)                   **23**
+
+            ern(i,j)=0.0
+
+            if(qr(i,j).gt.0.0) then
+               tair(i,j)=(pt(i,j)+tb0)*pi0
+               rtair(i,j)=1./(tair(i,j)-c358)
+               qsw(i,j)=rp0*exp(c172-c409*rtair(i,j))
+               ssw(i,j)=(qv(i,j)+qb0)/qsw(i,j)-1.0
+               dm(i,j)=qv(i,j)+qb0-qsw(i,j)
+               rsub1(i,j)=cv409*qsw(i,j)*rtair(i,j)*rtair(i,j)
+               dd1(i,j)=max(-dm(i,j)/(1.+rsub1(i,j)), 0.0)
+               y1(i,j)=.78/zr(i,j)**2+r23af*scv(i,j)/zr(i,j)**bwh5
+               y2(i,j)=r23br/(tca(i,j)*tair(i,j)**2)+1./(dwv(i,j) &
+                       *qsw(i,j))
+!cccc
+               ern(i,j)=r23t*ssw(i,j)*y1(i,j)/y2(i,j)
+               ern(i,j)=min(dd1(i,j),qr(i,j),max(ern(i,j),0.))
+               pt(i,j)=pt(i,j)-avcp*ern(i,j)
+               qv(i,j)=qv(i,j)+ern(i,j)
+               qr(i,j)=qr(i,j)-ern(i,j)
+            endif
+
+!JJS 10/7/2008     vvvvv
+    ENDIF    ! part of if (iwarm.eq.1) then
+!JJS 10/7/2008     ^^^^^
+
+!            IF (QV(I,J)+QB0 .LE. 0.) QV(I,J)=-QB0
+            if (qc(i,j) .le. cmin1) qc(i,j)=0.
+            if (qr(i,j) .le. cmin1) qr(i,j)=0.
+            if (qi(i,j) .le. cmin1) qi(i,j)=0.
+            if (qs(i,j) .le. cmin1) qs(i,j)=0.
+            if (qg(i,j) .le. cmin1) qg(i,j)=0.
+            dpt(i,j,k)=pt(i,j)
+            dqv(i,j,k)=qv(i,j)
+            qcl(i,j,k)=qc(i,j)
+            qrn(i,j,k)=qr(i,j)
+            qci(i,j,k)=qi(i,j)
+            qcs(i,j,k)=qs(i,j)
+            qcg(i,j,k)=qg(i,j)
+
+!JJS  275    CONTINUE
+
+         scc=0.
+         see=0.
+
+!         DO 110 J=3,JLES
+!         DO 110 I=3,ILES
+!            DD(I,J)=MAX(-CND(I,J), 0.)
+!            CND(I,J)=MAX(CND(I,J), 0.)
+!            DD1(I,J)=MAX(-DEP(I,J), 0.)
+
+!ccshie 2/21/02 shie follow tao
+!CC for reference    QI(I,J)=QI(I,J)-Y2(I,J)+PIDEP(I,J)*D2T
+!CC for reference    QV(I,J)=QV(I,J)-(PIDEP(I,J))*D2T
+
+!c            DEP(I,J)=MAX(DEP(I,J), 0.)
+!            DEP(I,J)=MAX(DEP(I,J), 0.)+PIDEP(I,J)*D2T
+!            SCC=SCC+CND(I,J)
+!            SEE=SEE+DD(I,J)+ERN(I,J)
+
+!  110    CONTINUE
+
+!         SC(K)=SCC+SC(K)
+!         SE(K)=SEE+SE(K)
+
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!c     henry:  please take a look  (start)
+!JJS modified by JJS on 5/1/2007  vvvvv
+
+!JJS       do 305 j=3,jles
+!JJS       do 305 i=3,iles
+            dd(i,j)=max(-cnd(i,j), 0.)
+            cnd(i,j)=max(cnd(i,j), 0.)
+            dd1(i,j)=max(-dep(i,j), 0.)+pidep(i,j)*d2t
+            dep(i,j)=max(dep(i,j), 0.)
+!JJS  305  continue
+
+!JJS       do 306 j=3,jles
+!JJS       do 306 i=3,iles
+!JJS              scc=scc+cnd(i,j)
+!JJS              see=see+(dd(i,j)+ern(i,j))
+!
+!JJS            sddd=sddd+(dep(i,j)+pint(i,j)+psdep(i,j)+pgdep(i,j))
+!JJS          ssss=ssss+dd1(i,j)
+!JJS
+!            shhh=shhh+rsw(i,j,k)*d2t
+!            sccc=sccc+rlw(i,j,k)*d2t
+!jjs
+!JJS              smmm=smmm+(psmlt(i,j)+pgmlt(i,j)+pimlt(i,j))
+!JJS              sfff=sfff+d2t*(psacw(i,j)+piacr(i,j)+psfw(i,j)
+!JJS     1         +pgfr(i,j)+dgacw(i,j)+dgacr(i,j)+psacr(i,j))
+!JJS     2        -qracs(i,j)+pihom(i,j)+pidw(i,j)
+
+
+              sccc=cnd(i,j)
+              seee=dd(i,j)+ern(i,j)
+              sddd=dep(i,j)+pint(i,j)+psdep(i,j)+pgdep(i,j)
+              ssss=dd1(i,j) + pgsub(i,j)
+              smmm=psmlt(i,j)+pgmlt(i,j)+pimlt(i,j)
+              sfff=d2t*(psacw(i,j)+piacr(i,j)+psfw(i,j) &
+               +pgfr(i,j)+dgacw(i,j)+dgacr(i,j)+psacr(i,j) &
+               +wgacr(i,j))+pihom(i,j)+pidw(i,j)
+
+!           physc(i,k,j) = avcp * sccc / d2t
+!           physe(i,k,j) = avcp * seee / d2t
+!           physd(i,k,j) = ascp * sddd / d2t
+!           physs(i,k,j) = ascp * ssss / d2t
+!           physf(i,k,j) = afcp * sfff / d2t
+!           physm(i,k,j) = afcp * smmm / d2t
+!           physc(i,k,j) = physc(i,k,j) + avcp * sccc 
+!           physe(i,k,j) = physc(i,k,j) + avcp * seee 
+!           physd(i,k,j) = physd(i,k,j) + ascp * sddd 
+!           physs(i,k,j) = physs(i,k,j) + ascp * ssss 
+!           physf(i,k,j) = physf(i,k,j) + afcp * sfff 
+!           physm(i,k,j) = physm(i,k,j) + afcp * smmm 
+
+!JJS modified by JJS on 5/1/2007  ^^^^^
+
+ 2000 continue
+
+ 1000 continue
+
+!JJS  ****************************************************************
+!JJS  convert from GCE grid back to WRF grid
+      do k=kts,kte
+         do j=jts,jte
+         do i=its,ite
+         ptwrf(i,k,j) = dpt(i,j,k)
+         qvwrf(i,k,j) = dqv(i,j,k)
+         qlwrf(i,k,j) = qcl(i,j,k)
+         qrwrf(i,k,j) = qrn(i,j,k)
+         qiwrf(i,k,j) = qci(i,j,k)
+         qswrf(i,k,j) = qcs(i,j,k)
+         qgwrf(i,k,j) = qcg(i,j,k)
+         enddo !i
+         enddo !j
+      enddo !k
+
+!     ****************************************************************
+
+      return
+ END SUBROUTINE saticel_s
+
+!JJS
+!JJS      REAL FUNCTION GAMMA(X)
+!JJS        Y=GAMMLN(X)
+!JJS        GAMMA=EXP(Y)
+!JJS      RETURN
+!JJS      END
+!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+!JJS      real function GAMMLN (xx)
+  real function gammagce (xx)
+!**********************************************************************
+  real*8 cof(6),stp,half,one,fpf,x,tmp,ser
+  data cof,stp /  76.18009173,-86.50532033,24.01409822, &
+     -1.231739516,.120858003e-2,-.536382e-5, 2.50662827465 /
+  data half,one,fpf / .5, 1., 5.5 /
+!
+      x=xx-one
+      tmp=x+fpf
+      tmp=(x+half)*log(tmp)-tmp
+      ser=one
+      do  j=1,6
+         x=x+one
+        ser=ser+cof(j)/x
+      enddo !j
+      gammln=tmp+log(stp*ser)
+!JJS
+      gammagce=exp(gammln)
+!JJS
+      return
+ END FUNCTION gammagce
+
+END MODULE  module_mp_gsfcgce
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_kessler.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_kessler.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_kessler.F	(revision 17)
@@ -0,0 +1,244 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+
+MODULE module_mp_kessler
+
+CONTAINS
+!----------------------------------------------------------------
+   SUBROUTINE kessler( t, qv, qc, qr, rho, pii                  &
+                      ,dt_in, z, xlv, cp                        &
+                      ,EP2,SVP1,SVP2,SVP3,SVPT0,rhowater        &
+                      ,dz8w                                     &
+                      ,RAINNC, RAINNCV                          &
+                      ,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
+!----------------------------------------------------------------
+   !  taken from the COMMAS code - WCS 10 May 1999.
+   !  converted from FORTRAN 77 to 90, tiled, WCS 10 May 1999.
+!----------------------------------------------------------------
+   REAL    , PARAMETER ::  c1 = .001 
+   REAL    , PARAMETER ::  c2 = .001 
+   REAL    , PARAMETER ::  c3 = 2.2 
+   REAL    , PARAMETER ::  c4 = .875 
+   REAL    , PARAMETER ::  fudge = 1.0 
+   REAL    , PARAMETER ::  mxfall = 10.0 
+!----------------------------------------------------------------
+   INTEGER,      INTENT(IN   )    :: ids,ide, jds,jde, kds,kde, &
+                                     ims,ime, jms,jme, kms,kme, &
+                                     its,ite, jts,jte, kts,kte
+   REAL   ,      INTENT(IN   )    :: xlv, cp
+   REAL   ,      INTENT(IN   )    :: EP2,SVP1,SVP2,SVP3,SVPT0
+   REAL   ,      INTENT(IN   )    :: rhowater
+
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+         INTENT(INOUT) ::                                       &
+                                                            t , &
+                                                            qv, &
+                                                            qc, &
+                                                            qr
+
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+         INTENT(IN   ) ::                                       &
+                                                           rho, &
+                                                           pii, &
+                                                          dz8w 
+
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+         INTENT(IN   ) ::                                    z
+
+   REAL, INTENT(IN   ) :: dt_in
+
+   REAL, DIMENSION( ims:ime , jms:jme ),                        &
+         INTENT(INOUT) ::                               RAINNC, &
+                                                       RAINNCV
+
+
+
+   ! local variables
+
+   REAL :: qrprod, ern, gam, rcgs, rcgsi
+   REAL, DIMENSION( its:ite , kts:kte, jts:jte ) ::     prod
+   REAL, DIMENSION(kts:kte) :: vt, prodk, vtden,rdzk,rhok,factor,rdzw
+   INTEGER :: i,j,k
+   INTEGER :: nfall, n, nfall_new
+   REAL    :: qrr, pressure, temp, es, qvs, dz, dt
+   REAL    :: f5, dtfall, rdz, product
+   REAL    :: max_heating, max_condense, max_rain, maxqrp
+   REAL    :: vtmax, ernmax, crmax, factorn, time_sediment
+   REAL    :: qcr, factorr, ppt
+   REAL, PARAMETER :: max_cr_sedimentation = 0.75
+!----------------------------------------------------------------
+
+   INTEGER :: imax, kmax
+
+    dt = dt_in
+
+!   f5 = 237.3 * 17.27 * 2.5e6 / cp 
+    f5 = svp2*(svpt0-svp3)*xlv/cp
+    ernmax = 0.
+    maxqrp = -100.
+
+!------------------------------------------------------------------------------
+! parameters for the time split terminal advection
+!------------------------------------------------------------------------------
+
+      max_heating = 0.
+      max_condense = 0.
+      max_rain = 0.
+
+!-----------------------------------------------------------------------------
+! outer J loop for entire microphysics, outer i loop for sedimentation
+!-----------------------------------------------------------------------------
+
+  microphysics_outer_j_loop: DO j = jts, jte
+
+  sedimentation_outer_i_loop: DO i = its,ite
+
+!   vtmax = 0.
+   crmax = 0.
+
+
+!------------------------------------------------------------------------------
+! Terminal velocity calculation and advection, set up coefficients and
+! compute stable timestep
+!------------------------------------------------------------------------------
+
+   DO k = 1, kte
+     prodk(k)   = qr(i,k,j)
+     rhok(k) = rho(i,k,j)
+     qrr = amax1(0.,qr(i,k,j)*0.001*rhok(k))
+     vtden(k) = sqrt(rhok(1)/rhok(k))
+     vt(k) = 36.34*(qrr**0.1364) * vtden(k)
+!     vtmax = amax1(vt(k), vtmax)
+     rdzw(k) = 1./dz8w(i,k,j)
+     crmax = amax1(vt(k)*dt*rdzw(k),crmax)
+   ENDDO
+   DO k = 1, kte-1
+     rdzk(k) = 1./(z(i,k+1,j) - z(i,k,j))
+   ENDDO
+   rdzk(kte) = 1./(z(i,kte,j) - z(i,kte-1,j))
+
+   nfall = max(1,nint(0.5+crmax/max_cr_sedimentation))  ! courant number for big timestep.
+   dtfall = dt / float(nfall)                           ! splitting so courant number for sedimentation
+   time_sediment = dt                                   ! is stable
+
+!------------------------------------------------------------------------------
+! Terminal velocity calculation and advection
+! Do a time split loop on this for stability.
+!------------------------------------------------------------------------------
+
+   column_sedimentation: DO WHILE ( nfall > 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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_lin.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_lin.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_lin.F	(revision 17)
@@ -0,0 +1,2701 @@
+!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
+!  May 2009 - Changes and corrections from P. Blossey (U. Washington)
+!-------------------------------------------------------------------
+  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                            &
+                      , SNOWNC, SNOWNCV                            &
+                      , GRAUPELNC, GRAUPELNCV, SR                  &
+                      ,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, &
+                                                              SR
+
+! Optional
+  REAL, DIMENSION( ims:ime , jms:jme ),                           &
+        OPTIONAL,                                                 &
+        INTENT(INOUT) ::                                  SNOWNC, &
+                                                         SNOWNCV, &
+                                                       GRAUPELNC, &
+                                                      GRAUPELNCV
+
+  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
+   sr(i,j)=(pptice+pptsnow+pptgraul)/(pptice+pptsnow+pptgraul+pptrain+1.e-12)
+!
+   RAINNCV(i,j)= pptrain + pptsnow + pptgraul + pptice
+   RAINNC(i,j)=RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice
+   IF(PRESENT(SNOWNCV))SNOWNCV(i,j)= pptsnow + pptice
+   IF(PRESENT(SNOWNC))SNOWNC(i,j)=SNOWNC(i,j) + pptsnow + pptice
+   IF(PRESENT(GRAUPELNCV))GRAUPELNCV(i,j)= pptgraul
+   IF(PRESENT(GRAUPELNC))GRAUPELNC(i,j)=GRAUPELNC(i,j) + pptgraul
+
+!
+!- 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
+!
+  REAL                          :: tmp_tem, tmp_temcc !bloss
+!
+  real :: liqconc, dis, beta, kappa, p0, xc, capn,rhocgs
+
+!sg: begin
+! liqconc = liquid water content (g cm^-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 * (threshold function)
+! p0 = "base" autoconversion rate (g cm^-3 s^-1)
+! kappa = constant in Long kernel = [kappa2 * (3/(4*pi*rhow))^3] in Liu papers
+! beta = Condensation rate constant = (beta6)^6 in Liu papers
+! xc = Normalized critical mass
+! ***********************************************************
+  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)
+
+         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
+   
+
+! Microphysics processes
+!
+      DO 2000 k=kts,kte
+!
+         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) )
+!***********************************************************************
+!*****   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) )
+!
+!bloss: BEGIN
+!the old implementation would give the wrong results if olambdas(k) ==0
+!which can lead to positive pssub, i.e. tmp2=0 but tmp3> 0
+!          if( tmp2 .le. 0.0) then
+          if( tmp3 .le. 0.0) then
+            tmp2=amax1( tmp2,tmp3)
+            pssub(k)=amin1(0.,amax1( tmp2,-qszodt(k) ))
+!bloss: END
+            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)   ! (kg/kg) to (g/cm3)
+              capn=1.0e-3*rhocgs*qndropz(k)   ! (#/kg) to (#/cm3)
+!         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)*exp(-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)
+!bloss: BEGIN
+!         tmpd=amin1(0.0,(qvoqswz(k)-0.90)*qswz(k)*odtb)
+
+! set max allowed evaporation to 90% of the amount that
+!   would induce saturation wrt liquid in a single step.
+         tmpd = qswz(k)*xlv/(rvapor*tem(k)**2) ! d(qsat_liq)/dT 
+         tmpd = min( 0., 0.9*odtb*(qvz(k) + qlz(k) - qswz(k)) &
+                          / (1. + xlvocp * tmpd) )
+
+         abr=2.0*pi*(qvoqswz(k)-1.0)*tmpc/(tmpa+tmpb)
+
+!         abr=2.0*pi*(qvoqswz(k)-0.90)*tmpc/(tmpa+tmpb)
+!bloss: END
+!
+!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)=amin1(tmp3,qlzodt(k)+qszodt(k)+qizodt(k) ) !bloss
+
+!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
+            term0=constg*olambdag(k)**5.5/visc(k)
+            constg2=vf1s*olambdag(k)*olambdag(k)+  &
+                    vf2s*schmidt(k)**0.33334*gam2pt75*sqrt(term0)
+            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
+           if(delta4.lt.0.5) then
+             !Re-define pgwet to account for limiting of pgacrp,
+             !         pgacip, pgacw and pgacsp above
+             pgwet(k) = pgacrp(k) + pgacw(k) + pgacip(k) + pgacsp(k)
+           end if
+           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
+
+!bloss: Moves computation of saturation mixing ratio below
+
+!         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)*gindex
+          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) )
+
+!bloss: Moved computation of saturation mixing ratio below
+
+!          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                **********
+!***********************************************************************
+!bloss: BEGIN
+!
+!     compute saturation specific humidity at the temperature
+!     which would be experienced if all cloud liquid and ice
+!     were to become vapor.  This will make for a consistent
+!     check of saturation.  Previously, qvsbar was computed
+!     without accounting for the change in temperature due to
+!     evaporation/sublimation, and as a result would
+!     incorrectly identify some points as subsaturated.
+
+      tmp_tem = tem(k)          ! updated temperature from above.
+
+      if(qlz(k)+qiz(k).gt. 0.) then
+         ! account for latent heat if all qlz and qiz were converted to vapor
+         tmp_tem = tem(k) - xlvocp*qlz(k) - (xlvocp+xlfocp)*qiz(k)
+      end if
+
+     ! compute temperature in celsius
+      tmp_temcc = tmp_tem - 273.15
+
+      ! estimate lower bound on saturation vapor pressure 
+      !   (ice if <0C, liquid aboce)
+      if (tmp_temcc .lt. 0.) then
+         es=1000.*svp1*exp( 21.8745584*(tmp_tem-273.16)/(tmp_tem-7.66) ) !ice
+      else
+         es=1000.*svp1*exp( svp2*tmp_temcc/(tmp_tem-svp3) ) !liquid
+      end if
+
+      ! compute lower bound on saturation mixing ratio.
+      qvsbar(k)=ep2*es/(prez(k)-es)
+!
+!bloss: END
+!
+!    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
+
+  REAL ::   tem_noliqice, qsat_noliqice !bloss
+!
+!---------------------------------------------------------------------
+
+      thz(k)=theiz(k)-(xLvocp*qvz(k)-xLfocp*qiz(k))/tothz(k)
+
+      tem(k)=tothz(k)*thz(k)
+
+!bloss: BEGIN
+      tem_noliqice = tem(k) - xlvocp*qlz(k) - (xLvocp+xLfocp)*qiz(k)
+
+      if (tem_noliqice .gt. 273.15) then
+         es=1000.*svp1*exp( svp2*(tem_noliqice-svpt0)/(tem_noliqice-svp3) )
+         qsat_noliqice=ep2*es/(prez(k)-es)
+      else
+        qsat_noliqice=episp0k/prez(k)*  &
+             exp( 21.8745584*(tem_noliqice-273.15)/(tem_noliqice-7.66) )
+      end if
+!bloss: END
+      qpz=qvz(k)+qlz(k)+qiz(k)
+      if (qpz .lt. qsat_noliqice) 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
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_milbrandt2mom.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_milbrandt2mom.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_milbrandt2mom.F	(revision 17)
@@ -0,0 +1,4438 @@
+!_______________________________________________________________________________!
+!                                                                               !
+!  This module contains the microphysics sub-driver for the 2-moment version of !
+!  the Milbrandt-Yau (2005, JAS) microphysics scheme, along with all associated !
+!  subprograms.  The main subroutine, 'mp_milbrandt2mom_main', is essentially   !
+!  directly from the RPN-CMC physics library of the Canadian GEM model.  It is  !
+!  called by the wrapper 'mp_milbrandt2mom_driver' which makes the necessary    !
+!  adjustments to the calling parameters for the interface to WRF.              !
+!                                                                               !
+!  For questions, bug reports, etc. pertaining to the scheme, or to request     !
+!  updates to the code (before the next offical WRF release) please contact     !
+!  Jason Milbrandt (Environment Canada) at jason.milbrandt@ec.gc.ca             !
+!                                                                               !
+!  Last modified:  2011-03-02                                                   !
+!_______________________________________________________________________________!
+
+module my_fncs_mod
+
+!==============================================================================!
+!  The following functions are used by the schemes in the multimoment package. !
+!                                                                              !
+!  Package version:  2.19.0      (internal bookkeeping)                        !
+!  Last modified  :  2009-04-27                                                !
+!==============================================================================!
+
+   implicit none
+
+   private
+   public  :: NccnFNC,SxFNC,gamma,gammaDP,gser,gammln,gammp,cfg,gamminc
+
+   contains
+
+!==============================================================================!
+
+ REAL FUNCTION NccnFNC(Win,Tin,Pin,CCNtype)
+
+!---------------------------------------------------------------------------!
+! This function returns number concentration (activated aerosols) as a
+! function of w,T,p, based on polynomial approximations of detailed
+! approach using a hypergeometric function, following Cohard and Pinty (2000a).
+!---------------------------------------------------------------------------!
+
+  IMPLICIT NONE
+
+! PASSING PARAMETERS:
+  real,    intent(in) :: Win, Tin, Pin
+  integer, intent(in) :: CCNtype
+
+! LOCAL PARAMETERS:
+  real :: T,p,x,y,a,b,c,d,e,f,g,h,T2,T3,T4,x2,x3,x4,p2
+
+  x= log10(Win*100.);   x2= x*x;  x3= x2*x;  x4= x2*x2
+  T= Tin - 273.15;      T2= T*T;  T3= T2*T;  T4= T2*T2
+  p= Pin*0.01;          p2= p*p
+
+  if (CCNtype==1) then  !Maritime
+
+     a= 1.47e-9*T4 -6.944e-8*T3 -9.933e-7*T2 +2.7278e-4*T -6.6853e-4
+     b=-1.41e-8*T4 +6.662e-7*T3 +4.483e-6*T2 -2.0479e-3*T +4.0823e-2
+     c= 5.12e-8*T4 -2.375e-6*T3 +4.268e-6*T2 +3.9681e-3*T -3.2356e-1
+     d=-8.25e-8*T4 +3.629e-6*T3 -4.044e-5*T2 +2.1846e-3*T +9.1227e-1
+     e= 5.02e-8*T4 -1.973e-6*T3 +3.944e-5*T2 -9.0734e-3*T +1.1256e0
+     f= -1.424e-6*p2 +3.631e-3*p -1.986
+     g= -0.0212*x4 +0.1765*x3 -0.3770*x2 -0.2200*x +1.0081
+     h= 2.47e-6*T3 -3.654e-5*T2 +2.3327e-3*T +0.1938
+     y= a*x4 + b*x3 + c*x2 + d*x + e + f*g*h
+     NccnFNC= 10.**min(2.,max(0.,y)) *1.e6                ![m-3]
+
+  else if (CCNtype==2) then  !Continental
+
+     a= 0.
+     b= 0.
+     c=-2.112e-9*T4 +3.9836e-8*T3 +2.3703e-6*T2 -1.4542e-4*T -0.0698
+     d=-4.210e-8*T4 +5.5745e-7*T3 +1.8460e-5*T2 +9.6078e-4*T +0.7120
+     e= 1.434e-7*T4 -1.6455e-6*T3 -4.3334e-5*T2 -7.6720e-3*T +1.0056
+     f= 1.340e-6*p2 -3.5114e-3*p  +1.9453
+     g= 4.226e-3*x4 -5.6012e-3*x3 -8.7846e-2*x2 +2.7435e-2*x +0.9932
+     h= 5.811e-9*T4 +1.5589e-7*T3 -3.8623e-5*T2 +1.4471e-3*T +0.1496
+     y= a*x4 +b*x3 +c*x2 + d*x + e + (f*g*h)
+     NccnFNC= 10.**max(0.,y) *1.e6
+
+  else
+
+    print*, '*** STOPPED in MODULE ### NccnFNC  *** '
+    print*, '    Parameter CCNtype incorrectly specified'
+    stop
+
+  endif
+
+ END FUNCTION NccnFNC
+!======================================================================!
+
+   real FUNCTION SxFNC(Win,Tin,Pin,Qsw,Qsi,CCNtype,WRT)
+
+!---------------------------------------------------------------------------!
+! This function returns the peak supersaturation achieved during ascent with
+! activation of CCN aerosols as a function of w,T,p, based on polynomial
+! approximations of detailed approach using a hypergeometric function,
+! following Cohard and Pinty (2000a).
+!---------------------------------------------------------------------------!
+
+ IMPLICIT NONE
+
+! PASSING PARAMETERS:
+  integer, intent(IN) :: WRT
+  integer, intent(IN) :: CCNtype
+  real,    intent(IN) :: Win, Tin, Pin, Qsw, Qsi
+
+! LOCAL PARAMETERS:
+  real   ::  Si,Sw,Qv,T,p,x,a,b,c,d,f,g,h,Pcorr,T2corr,T2,T3,T4,x2,x3,x4,p2
+  real, parameter :: TRPL= 273.15
+
+  x= log10(max(Win,1.e-20)*100.);   x2= x*x;  x3= x2*x;  x4= x2*x2
+  T= Tin;                           T2= T*T;  T3= T2*T;  T4= T2*T2
+  p= Pin*0.01;                      p2= p*p
+
+  if (CCNtype==1) then  !Maritime
+
+     a= -5.109e-7*T4 -3.996e-5*T3 -1.066e-3*T2 -1.273e-2*T +0.0659
+     b=  2.014e-6*T4 +1.583e-4*T3 +4.356e-3*T2 +4.943e-2*T -0.1538
+     c= -2.037e-6*T4 -1.625e-4*T3 -4.541e-3*T2 -5.118e-2*T +0.1428
+     d=  3.812e-7*T4 +3.065e-5*T3 +8.795e-4*T2 +9.440e-3*T +6.14e-3
+     f= -2.012e-6*p2 + 4.1913e-3*p    - 1.785e0
+     g=  2.832e-1*x3 -5.6990e-1*x2 +5.1105e-1*x -4.1747e-4
+     h=  1.173e-6*T3 +3.2174e-5*T2 -6.8832e-4*T +6.7888e-2
+     Pcorr= f*g*h
+     T2corr= 0.9581-4.449e-3*T-2.016e-4*T2-3.307e-6*T3-1.725e-8*T4
+
+  else if (CCNtype==2) then  !Continental [computed for -35<T<-5C]
+
+     a=  3.80e-5*T2 +1.65e-4*T +9.88e-2
+     b= -7.38e-5*T2 -2.53e-3*T -3.23e-1
+     c=  8.39e-5*T2 +3.96e-3*T +3.50e-1
+     d= -1.88e-6*T2 -1.33e-3*T -3.73e-2
+     f= -1.9761e-6*p2 + 4.1473e-3*p - 1.771e0
+     g=  0.1539*x4 -0.5575*x3 +0.9262*x2 -0.3498*x -0.1293
+     h=-8.035e-9*T4+3.162e-7*T3+1.029e-5*T2-5.931e-4*T+5.62e-2
+     Pcorr= f*g*h
+     T2corr= 0.98888-5.0525e-4*T-1.7598e-5*T2-8.3308e-8*T3
+
+  else
+
+    print*, '*** STOPPED in MODULE ### SxFNC  *** '
+    print*, '    Parameter CCNtype incorrectly specified'
+    stop
+
+  endif
+
+  Sw= (a*x3 + b*x2 +c*x + d) + Pcorr
+  Sw= 1. + 0.01*Sw
+  Qv= Qsw*Sw
+  Si= Qv/Qsi
+  Si= Si*T2corr
+  if (WRT.eq.1) then
+     SxFNC= Sw
+  else
+     SxFNC= Si
+  endif
+  if (Win.le.0.) SxFNC= 1.
+
+ END function SxFNC
+!======================================================================!
+
+ real FUNCTION gamma(xx)
+
+!  Modified from "Numerical Recipes"
+
+  IMPLICIT NONE
+
+! PASSING PARAMETERS:
+  real, intent(IN) :: xx
+
+! LOCAL PARAMETERS:
+  integer  :: j
+  real*8   :: ser,stp,tmp,x,y,cof(6),gammadp
+
+
+  SAVE cof,stp
+  DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,               &
+       24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,  &
+       -.5395239384953d-5,2.5066282746310005d0/
+  x=dble(xx)
+  y=x
+  tmp=x+5.5d0
+  tmp=(x+0.5d0)*log(tmp)-tmp
+  ser=1.000000000190015d0
+! do j=1,6   !original
+  do j=1,4
+!!do j=1,3   !gives result to within ~ 3 %
+     y=y+1.d0
+     ser=ser+cof(j)/y
+  enddo
+  gammadp=tmp+log(stp*ser/x)
+  gammadp= exp(gammadp)
+
+#if (DWORDSIZE == 8 && RWORDSIZE == 8)
+  gamma  =      gammadp
+#elif (DWORDSIZE == 8 && RWORDSIZE == 4)
+  gamma  = sngl(gammadp)
+#else
+     This is a temporary hack assuming double precision is 8 bytes.
+#endif
+
+ END FUNCTION gamma
+!======================================================================!
+! ! !
+! ! ! -- USED BY DIAGNOSTIC-ALPHA DOUBLE-MOMENT (SINGLE-PRECISION) VERSION --
+! ! !      FOR FUTURE VERSIONS OF M-Y PACKAGE WITH, THIS S/R CAN BE USED
+! ! !
+! ! !  real FUNCTION diagAlpha(Dm,x)
+! ! !
+! ! !   IMPLICIT NONE
+! ! !
+! ! !   integer :: x
+! ! !   real    :: Dm
+! ! !   real, dimension(5) :: c1,c2,c3,c4
+! ! !   real, parameter    :: pi = 3.14159265
+! ! !   real, parameter    :: alphaMAX= 80.e0
+! ! !   data c1 /19.0, 12.0, 4.5, 5.5, 3.7/
+! ! !   data c2 / 0.6,  0.7, 0.5, 0.7, 0.3/
+! ! !   data c3 / 1.8,  1.7, 5.0, 4.5, 9.0/
+! ! !   data c4 /17.0, 11.0, 5.5, 8.5, 6.5/
+! ! !   diagAlpha= c1(x)*tanh(c2(x)*(1.e3*Dm-c3(x)))+c4(x)
+! ! !   if (x==5.and.Dm>0.008) diagAlpha= 1.e3*Dm-2.6
+! ! !   diagAlpha= min(diagAlpha, alphaMAX)
+! ! !
+! ! !  END function diagAlpha
+! ! !
+! ! ! !======================================================================!
+! ! !
+! ! ! -- USED BY DIAGNOSTIC-ALPHA DOUBLE-MOMENT (SINGLE-PRECISION) VERSION --
+! ! !      FOR FUTURE VERSIONS OF M-Y PACKAGE WITH, THIS S/R CAN BE USED
+! ! !
+! ! !  real FUNCTION solveAlpha(Q,N,Z,Cx,rho)
+! ! !
+! ! !  IMPLICIT NONE
+! ! !
+! ! ! ! PASSING PARAMETERS:
+! ! !   real, intent(IN) :: Q, N, Z, Cx, rho
+! ! !
+! ! ! ! LOCAL PARAMETERS:
+! ! !   real             :: a,g,a1,g1,g2,tmp1
+! ! !   integer          :: i
+! ! !   real, parameter  :: alphaMax= 40.
+! ! !   real, parameter  :: epsQ    = 1.e-14
+! ! !   real, parameter  :: epsN    = 1.e-3
+! ! !   real, parameter  :: epsZ    = 1.e-32
+! ! !
+! ! ! !  Q         mass mixing ratio
+! ! ! !  N         total concentration
+! ! ! !  Z         reflectivity
+! ! ! !  Cx        (pi/6)*RHOx
+! ! ! !  rho       air density
+! ! ! !  a         alpha (returned as solveAlpha)
+! ! ! !  g         function g(a)= [(6+a)(5+a)(4+a)]/[(3+a)(2+a)(1+a)],
+! ! ! !              where g = (Cx/(rho*Q))**2.*(Z*N)
+! ! !
+! ! !
+! ! !   if (Q==0. .or. N==0. .or. Z==0. .or. Cx==0. .or. rho==0.) then
+! ! !   ! For testing/debugging only; this module should never be called
+! ! !   ! if the above condition is true.
+! ! !     print*,'*** STOPPED in MODULE ### solveAlpha *** '
+! ! !     print*,'*** : ',Q,N,Z,Cx*1.9099,rho
+! ! !     stop
+! ! !   endif
+! ! !
+! ! !   IF (Q>epsQ .and. N>epsN .and. Z>epsZ ) THEN
+! ! !
+! ! !      tmp1= Cx/(rho*Q)
+! ! !      g   = tmp1*Z*tmp1*N    ! g = (Z*N)*[Cx / (rho*Q)]^2
+! ! !
+! ! !  !Note: The above order avoids OVERFLOW, since tmp1*tmp1 is very large
+! ! !
+! ! ! !----------------------------------------------------------!
+! ! ! ! !Solve alpha numerically: (brute-force; for testing only)
+! ! ! !      a= 0.
+! ! ! !      g2= 999.
+! ! ! !      do i=0,4000
+! ! ! !         a1= i*0.01
+! ! ! !         g1= (6.+a1)*(5.+a1)*(4.+a1)/((3.+a1)*(2.+a1)*(1.+a1))
+! ! ! !         if(abs(g-g1)<abs(g-g2)) then
+! ! ! !            a = a1
+! ! ! !            g2= g1
+! ! ! !         endif
+! ! ! !      enddo
+! ! ! !----------------------------------------------------------!
+! ! !
+! ! ! !Piecewise-polynomial approximation of g(a) to solve for a:  [2004-11-29]
+! ! !      if (g>=20.) then
+! ! !        a= 0.
+! ! !      else
+! ! !        g2= g*g
+! ! !        if (g<20.  .and.g>=13.31) a= 3.3638e-3*g2 - 1.7152e-1*g + 2.0857e+0
+! ! !        if (g<13.31.and.g>=7.123) a= 1.5900e-2*g2 - 4.8202e-1*g + 4.0108e+0
+! ! !        if (g<7.123.and.g>=4.200) a= 1.0730e-1*g2 - 1.7481e+0*g + 8.4246e+0
+! ! !        if (g<4.200.and.g>=2.946) a= 5.9070e-1*g2 - 5.7918e+0*g + 1.6919e+1
+! ! !        if (g<2.946.and.g>=1.793) a= 4.3966e+0*g2 - 2.6659e+1*g + 4.5477e+1
+! ! !        if (g<1.793.and.g>=1.405) a= 4.7552e+1*g2 - 1.7958e+2*g + 1.8126e+2
+! ! !        if (g<1.405.and.g>=1.230) a= 3.0889e+2*g2 - 9.0854e+2*g + 6.8995e+2
+! ! !        if (g<1.230) a= alphaMax
+! ! !      endif
+! ! !
+! ! !      solveAlpha= max(0.,min(a,alphaMax))
+! ! !
+! ! !   ELSE
+! ! !
+! ! !      solveAlpha= 0.
+! ! !
+! ! !   ENDIF
+! ! !
+! ! !  END FUNCTION solveAlpha
+!======================================================================!
+
+ FUNCTION gammaDP(xx)
+
+!  Modified from "Numerical Recipes"
+
+  IMPLICIT NONE
+
+! PASSING PARAMETERS:
+  DOUBLE PRECISION, INTENT(IN) :: xx
+
+! LOCAL PARAMETERS:
+  DOUBLE PRECISION  :: gammaDP
+  INTEGER  :: j
+  DOUBLE PRECISION  :: ser,stp,tmp,x,y,cof(6)
+
+
+  SAVE cof,stp
+  DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,               &
+       24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,  &
+       -.5395239384953d-5,2.5066282746310005d0/
+  x=xx
+  y=x
+  tmp=x+5.5d0
+  tmp=(x+0.5d0)*log(tmp)-tmp
+  ser=1.000000000190015d0
+! do j=1,6   !original
+  do j=1,4
+!!do j=1,3   !gives result to within ~ 3 %
+     y=y+1.d0
+     ser=ser+cof(j)/y
+  enddo
+  gammaDP=tmp+log(stp*ser/x)
+  gammaDP= exp(gammaDP)
+
+ END FUNCTION gammaDP
+!======================================================================!
+
+ SUBROUTINE gser(gamser,a,x,gln)
+
+! USES gammln
+
+!   Returns the incomplete gamma function P(a,x) evaluated by its series
+!   representation as gamser.  Also returns GAMMA(a) as gln.
+
+ implicit none
+
+ integer :: itmax
+ real    :: a,gamser,gln,x,eps
+ parameter (itmax=100, eps=3.e-7)
+ integer :: n
+ real :: ap,de1,summ
+
+ gln=gammln(a)
+ if(x.le.0.)then
+    if(x.lt.0.)pause 'x <0 in gser'
+    gamser=0.
+    return
+ endif
+ ap=a
+ summ=1./a
+ de1=summ
+ do n=1,itmax
+    ap=ap+1.
+    de1=de1*x/ap
+    summ=summ+de1
+    if(abs(de1).lt.abs(summ)*eps) goto 1
+ enddo
+ pause 'a too large, itmax too small in gser'
+1 gamser=summ*exp(-x+a*log(x)-gln)
+ return
+
+END SUBROUTINE gser
+!======================================================================!
+
+ real FUNCTION gammln(xx)
+
+!  Returns value of ln(GAMMA(xx)) for xx>0
+!   (modified from "Numerical Recipes")
+
+  IMPLICIT NONE
+
+! PASSING PARAMETERS:
+  real, intent(IN) :: xx
+
+! LOCAL PARAMETERS:
+  integer  :: j
+  real*8   :: ser,stp,tmp,x,y,cof(6)
+
+  SAVE cof,stp
+  DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,               &
+       24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,  &
+       -.5395239384953d-5,2.5066282746310005d0/
+  x=dble(xx)
+  y=x
+  tmp=x+5.5d0
+  tmp=(x+0.5d0)*log(tmp)-tmp
+  ser=1.000000000190015d0
+  do j=1,6   !original
+!  do j=1,4
+     y=y+1.d0
+     ser=ser+cof(j)/y
+  enddo
+#if (DWORDSIZE == 8 && RWORDSIZE == 8)
+  gammln=       tmp+log(stp*ser/x)
+#elif (DWORDSIZE == 8 && RWORDSIZE == 4)
+  gammln= sngl( tmp+log(stp*ser/x)  )
+#else
+     This is a temporary hack assuming double precision is 8 bytes.
+#endif
+
+ END FUNCTION gammln
+!======================================================================!
+
+ real FUNCTION gammp(a,x)
+
+! USES gcf,gser
+
+! Returns the incomplete gamma function P(a,x)
+
+ implicit none
+
+ real :: a,x,gammcf,gamser,gln
+
+ if(x.lt.0..or.a.le.0.) pause 'bad arguments in gammq'
+ if(x.lt.a+1.)then
+    call gser(gamser,a,x,gln)
+    gammp=gamser
+ else
+    call cfg(gammcf,a,x,gln)
+    gammp=1.-gammcf
+ endif
+ return
+
+ END FUNCTION gammp
+!======================================================================!
+
+ SUBROUTINE cfg(gammcf,a,x,gln)
+
+! USES gammln
+
+! Returns the incomplete gamma function (Q(a,x) evaluated by tis continued fraction
+! representation as gammcf.  Also returns ln(GAMMA(a)) as gln.  ITMAX is the maximum
+! allowed number of iterations; EPS is the relative accuracy; FPMIN is a number near
+! the smallest representable floating-point number.
+
+ implicit none
+
+ integer :: i,itmax
+ real    :: a,gammcf,gln,x,eps,fpmin
+ real    :: an,b,c,d,de1,h
+ parameter (itmax=100,eps=3.e-7)
+
+ gln=gammln(a)
+ b=x+1.-a
+ c=1./fpmin
+ d=1./b
+ h=d
+ do 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
+   de1=d*c
+   h=h*de1
+   if(abs(de1-1.).lt.eps) goto 1
+ enddo
+ pause 'a too large, itmax too small in gcf'
+1 gammcf=exp(-x+a*log(x)-gln)*h
+ return
+
+END SUBROUTINE cfg
+!======================================================================!
+
+ real FUNCTION gamminc(p,xmax)
+
+! USES gammp, gammln
+! Returns incomplete gamma function, gamma(p,xmax)= P(p,xmax)*GAMMA(p)
+ real :: p,xmax
+ gamminc= gammp(p,xmax)*exp(gammln(p))
+
+ end FUNCTION gamminc
+
+!======================================================================!
+!  real function x_tothe_y(x,y)
+!
+!     implicit none
+!     real, intent(in) :: x,y
+!     x_tothe_y= exp(y*log(x))
+!
+!  end function x_tothe_y
+!======================================================================!
+
+end module my_fncs_mod
+
+!________________________________________________________________________________________!
+
+module my_sedi_mod
+
+!================================================================================!
+!  The following subroutines are used by the schemes in the multimoment package. !
+!                                                                                !
+!  Package version:  2.19.0     (internal bookkeeping)                           !
+!  Last modified  :  2011-01-07                                                  !
+!================================================================================!
+
+   implicit none
+
+  private
+  public :: SEDI_main_1b,SEDI_main_2,countColumns
+
+   contains
+
+!=====================================================================================!
+ SUBROUTINE SEDI_main_2(QX,NX,cat,Q,T,DE,iDE,gamfact,epsQ,epsN,afx,bfx,cmx,dmx,      &
+                        ckQx1,ckQx2,ckQx4,LXP,ni,nk,VxMax,DxMax,dt,DZ,massFlux,      &
+                        ktop_sedi,GRAV,massFlux3D)
+
+!-------------------------------------------------------------------------------------!
+!  DOUBLE-MOMENT version of sedimentation subroutine for categories whose
+!  fall velocity equation is V(D) = gamfact * afx * D^bfx
+!-------------------------------------------------------------------------------------!
+
+! Passing parameters:
+!
+!  VAR   Description
+!  ---   ------------
+!  QX    mass mixing ratio of category x
+!  NX    number concentration of category x
+!  cat:  hydrometeor category:
+!   1     rain
+!   2     ice
+!   3     snow
+!   4     graupel
+!   5     hail
+!-------------------------------------------------------------------------------------!
+
+  use my_fncs_mod
+
+  implicit none
+
+! PASSING PARAMETERS:
+  real, dimension(:,:), intent(inout) :: QX,NX,Q,T
+  real, dimension(:),    intent(out)  :: massFlux
+  real, optional, dimension(:,:), intent(out) :: massFlux3D
+  real, dimension(:,:), intent(in)    :: DE,iDE,DZ
+  real, intent(in) :: epsQ,epsN,VxMax,LXP,afx,bfx,cmx,dmx,ckQx1,ckQx2,ckQx4,DxMax,dt,GRAV
+  integer, dimension(:), intent(in)   :: ktop_sedi
+  integer, intent(in)                 :: ni,nk,cat
+
+! LOCAL PARAMETERS:
+  logical                :: slabHASmass,locallim,QxPresent
+  integer                :: nnn,a,i,k,counter,l,km1,kp1,ks,kw,idzmin
+  integer, dimension(nk) :: flim_Q,flim_N
+  integer, dimension(ni) :: activeColumn,npassx,ke
+  real                   :: VqMax,VnMax,iLAMx,iLAMxB0,tmp1,tmp2,tmp3,Dx,iDxMax,icmx,     &
+                            VincFact,ratio_Vn2Vq,zmax_Q,zmax_N,tempo,idmx,Nos_Thompson,  &
+                            No_s,iLAMs
+  real, dimension(ni,nk) :: VVQ,VVN,RHOQX,gamfact
+  real, dimension(ni)    :: dzMIN,dtx,VxMaxx
+  real, dimension(nk)    :: vp_Q,vp_N,zt_Q,zt_N,zb_Q,zb_N,dzi,Q_star,N_star
+  real, dimension(0:nk)  :: zz
+  real, parameter        :: epsilon = 1.e-2
+  real, parameter        :: thrd    = 1./3.
+  real, parameter        :: sxth    = 1./6.
+  real, parameter        :: CoMAX   = 2.0
+
+!-------------------------------------------------------------------------------------!
+
+   massFlux = 0.
+
+  !Factor to estimate increased V from size-sorting:
+  ! - this factor should be higher for categories with more time-splitting, since Vmax
+  !   increases after each sedimentation split step (to be tuned)
+   VincFact = 1.
+   if (present(massFlux3D)) massFlux3D= 0.  !(for use in MAIN for diagnostics)
+
+  !Determine for which slabs and columns sedimentation should be computes:
+   call countColumns(QX,ni,nk,epsQ,counter,activeColumn,ktop_sedi)
+
+   ratio_Vn2Vq= ckQx2/ckQx1
+   iDxMax= 1./DxMax
+   icmx  = 1./cmx
+   idmx  = 1./dmx
+   ks    = nk
+   ke    = ktop_sedi  !(i-array) - formerly ke=1; now depends on max. level with hydrometeor
+   kw    = -1         !direction of vertical leveling; -1 implies nk is bottom
+
+   VVQ  = 0.
+   VVN  = 0.
+   VqMax= 0.
+   VnMax= 0.
+
+   DO a= 1,counter
+      i= activeColumn(a)
+
+      VVQ(i,:) = 0.
+      do k= ktop_sedi(i),nk  !formerly do k= 1,nk
+         QxPresent =  (QX(i,k)>epsQ .and. NX(i,k)>epsN)
+         if (QxPresent) VVQ(i,k)= calcVV()*ckQx1
+         if (present(massFlux3D)) massFlux3D(i,k)= VVQ(i,k)*DE(i,k)*QX(i,k)  !(for use in MAIN)
+      enddo  !k-loop
+      Vxmaxx(i)= min( VxMax, maxval(VVQ(i,:))*VincFact )
+
+     !note: dzMIN is min. value in column (not necessarily lowest layer in general)
+      dzMIN(i) = minval(DZ(i,:))
+      npassx(i)= max(1, nint( dt*Vxmaxx(i)/(CoMAX*dzMIN(i)) ))
+      dtx(i)   = dt/float(npassx(i))
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+      DO nnn= 1,npassx(i)
+
+         locallim = (nnn==1)
+
+         do k= ktop_sedi(i),nk  !formerly do k= 1,nk
+           RHOQX(i,k) = DE(i,k)*QX(i,k)
+           QxPresent  = (QX(i,k)>epsQ .and. NX(i,k)>epsN)
+           if (QxPresent) then
+              if (locallim) then     !to avoid re-computing VVQ on first pass
+                 VVQ(i,k)= -VVQ(i,k)
+              else
+                 VVQ(i,k)= -calcVV()*ckQx1
+              endif
+              VVN(i,k)= VVQ(i,k)*ratio_Vn2Vq
+              VqMax   = max(VxMAX,-VVQ(i,k))
+              VnMax   = max(VxMAX,-VVN(i,k))
+           else
+              VVQ(i,k)= 0.
+              VVN(i,k)= 0.
+              VqMax   = 0.
+              VnMax   = 0.
+           endif
+         enddo  !k-loop
+
+        !sum instantaneous surface mass flux at each split step: (for division later)
+         massFlux(i)= massFlux(i) - VVQ(i,nk)*DE(i,nk)*QX(i,nk)
+
+     !-- Perform single split sedimentation step:
+     !   (formerly by calls to s/r 'blg4sedi', a modified [JM] version of 'blg2.ftn')
+         zz(ks)= 0.
+         do k= ks,ke(i),kw
+            zz(k+kw)= zz(k)+dz(i,k)
+            dzi(k)  = 1./dz(i,k)
+            vp_Q(k) = 0.
+            vp_N(k) = 0.
+         enddo
+
+         do k=ks,ke(i),kw
+            zb_Q(k)= zz(k) + VVQ(i,k)*dtx(i)
+            zb_N(k)= zz(k) + VVN(i,k)*dtx(i)
+         enddo
+
+         zt_Q(ke(i))= zb_Q(ke(i)) + dz(i,ke(i))
+         zt_N(ke(i))= zb_N(ke(i)) + dz(i,ke(i))
+         do k= ks,ke(i)-kw,kw
+            zb_Q(k)= min(zb_Q(k+kw)-epsilon*dz(i,k), zz(k)+VVQ(i,k)*dtx(i))
+            zb_N(k)= min(zb_N(k+kw)-epsilon*dz(i,k), zz(k)+VVN(i,k)*dtx(i))
+            zt_Q(k)= zb_Q(k+kw)
+            zt_N(k)= zb_N(k+kw)
+         enddo
+
+         do k=ks,ke(i),kw    !formerly k=1,nk
+            Q_star(k)= RHOQX(i,k)*dz(i,k)/(zt_Q(k)-zb_Q(k))
+            N_star(k)=    NX(i,k)*dz(i,k)/(zt_N(k)-zb_N(k))
+         enddo
+
+         if (locallim) then
+            zmax_Q= abs(VqMax*dtx(i))
+            zmax_N= abs(VnMax*dtx(i))
+            do l=ks,ke(i),kw
+               flim_Q(l)= l
+               flim_N(l)= l
+               do k= l,ke(i),kw
+                  if (zmax_Q.ge.zz(k)-zz(l+kw)) flim_Q(l)= k
+                  if (zmax_N.ge.zz(k)-zz(l+kw)) flim_N(l)= k
+               enddo
+            enddo
+         endif
+
+         do l=ks,ke(i),kw
+            do k=l,flim_Q(l),kw
+               vp_Q(l)= vp_Q(l) + Q_star(k)*max(0.,min(zz(l+kw),zt_Q(k))-max(zz(l),zb_Q(k)))
+            enddo
+            do k=l,flim_N(l),kw
+               vp_N(l)= vp_N(l) + N_star(k)*max(0.,min(zz(l+kw),zt_N(k))-max(zz(l),zb_N(k)))
+            enddo
+         enddo
+
+         do k=ks,ke(i),kw
+            RHOQX(i,k)= vp_Q(k)*dzi(k)
+               NX(i,k)= vp_N(k)*dzi(k)
+         enddo
+     !--
+
+         do k= ktop_sedi(i),nk  !formerly do k= 1,nk
+           QX(i,k)= RHOQX(i,k)*iDE(i,k)
+
+         !Prevent levels with zero N and nonzero Q and size-limiter:
+           QxPresent=  (QX(i,k)>epsQ .and. NX(i,k)>epsN)
+           if (QxPresent) then    !size limiter
+              Dx= (DE(i,k)*QX(i,k)/(NX(i,k)*cmx))**idmx
+              if (cat==1 .and. Dx>3.e-3) then
+                 tmp1   =  Dx-3.e-3;   tmp1= tmp1*tmp1
+                 tmp2   = (Dx/DxMAX);  tmp2= tmp2*tmp2*tmp2
+                 NX(i,k)= NX(i,k)*max((1.+2.e4*tmp1),tmp2)
+              else
+                 NX(i,k)= NX(i,k)*(max(Dx,DxMAX)*iDxMAX)**dmx   !impose Dx_max
+              endif
+           else   !here, "QxPresent" implies correlated QX and NX
+              Q(i,k) = Q(i,k) + QX(i,k)
+              T(i,k) = T(i,k) - LXP*QX(i,k)   !LCP for rain; LSP for i,s,g,h
+              QX(i,k)= 0.
+              NX(i,k)= 0.
+           endif
+
+         enddo
+
+       ENDDO  !nnn-loop
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+      !compute average mass flux during the full time step: (used to compute the
+      !instantaneous sedimentation rate [liq. equiv. volume flux] in the main s/r)
+       massFlux(i)= massFlux(i)/float(npassx(i))
+
+    ENDDO  !a(i)-loop
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+
+CONTAINS
+
+   real function calcVV()
+   !Calculates portion of moment-weighted fall velocities
+      iLAMx   = ((QX(i,k)*DE(i,k)/NX(i,k))*ckQx4)**idmx
+      iLAMxB0 = iLAMx**bfx
+      calcVV  = gamfact(i,k)*iLAMxB0
+   end function calcVV
+
+ END SUBROUTINE SEDI_main_2
+
+!=====================================================================================!
+ SUBROUTINE SEDI_main_1b(QX,cat,T,DE,iDE,gamfact,epsQ,afx,bfx,icmx,dmx,ckQx1,ckQx4, &
+                         ni,nk,VxMax,DxMax,dt,DZ,massFlux,No_x,ktop_sedi,GRAV,      &
+                         massFlux3D)
+
+!-------------------------------------------------------------------------------------!
+!  SINGLE-MOMENT version of sedimentation subroutine for categories whose
+!  fall velocity equation is V(D) = gamfact * afx * D^bfx
+!-------------------------------------------------------------------------------------!
+
+! Passing parameters:
+!
+!  VAR   Description
+!  ---   ------------
+!  QX    mass mixing ratio of category x
+!  cat:  hydrometeor category:
+!   1     rain
+!   2     ice
+!   3     snow
+!   4     graupel
+!   5     hail
+!-------------------------------------------------------------------------------------!
+
+  use my_fncs_mod
+
+  implicit none
+
+! PASSING PARAMETERS:
+  real, dimension(:,:), intent(inout) :: QX,T
+  real, dimension(:),    intent(out)   :: massFlux
+  real, optional, dimension(:,:), intent(out) :: massFlux3D
+  real, dimension(:,:), intent(in)    :: DE,iDE,DZ
+  real,    intent(in)    :: epsQ,VxMax,afx,bfx,icmx,dmx,ckQx1,ckQx4,DxMax,dt,GRAV,No_x
+  integer, dimension(:), intent(in) :: ktop_sedi
+  integer, intent(in)    :: ni,nk,cat !,ktop_sedi
+
+! LOCAL PARAMETERS:
+  logical                :: slabHASmass,locallim,QxPresent
+  integer                :: nnn,a,i,k,counter,l,km1,kp1,ks,kw,idzmin !,ke
+  integer, dimension(nk) :: flim_Q
+  integer, dimension(ni) :: activeColumn,npassx,ke
+  real                   :: VqMax,iLAMx,iLAMxB0,tmp1,tmp2,Dx,iDxMax,VincFact,NX,iNo_x,   &
+                            zmax_Q,zmax_N,tempo
+  real, dimension(ni,nk) :: VVQ,RHOQX,gamfact
+  real, dimension(ni)    :: dzMIN,dtx,VxMaxx
+  real, dimension(nk)    :: vp_Q,zt_Q,zb_Q,dzi,Q_star
+  real, dimension(0:nk)  :: zz
+  real, parameter        :: epsilon = 1.e-2
+  real, parameter        :: thrd  = 1./3.
+  real, parameter        :: sxth  = 1./6.
+  real, parameter        :: CoMAX = 2.0
+
+!-------------------------------------------------------------------------------------!
+
+   massFlux= 0.
+  !Factor to estimate increased V from size-sorting:
+  ! - this factor should be higher for categories with more time-splitting, since Vmax
+  !   increases after each sedimentation split step (to be tuned)
+   VincFact= 1.
+   if (present(massFlux3D)) massFlux3D= 0.  !(for use in MAIN for diagnostics)
+
+  !Determine for which slabs and columns sedimentation should be computes:
+   call countColumns(QX,ni,nk,epsQ,counter,activeColumn,ktop_sedi)
+   iNo_x = 1./No_x
+   iDxMax= 1./DxMax
+   ks    = nk
+   ke    = ktop_sedi  !(i-array) - old: ke=1
+   kw    = -1         !direction of vertical leveling
+
+   VVQ  = 0.
+   VqMax= 0.
+
+   DO a= 1,counter
+      i= activeColumn(a)
+
+      VVQ(i,:) = 0.
+      do k= ktop_sedi(i),nk  !do k= 1,nk
+         QxPresent =  (QX(i,k)>epsQ)
+!        if (QxPresent) VVQ(i,k)= calcVV()*ckQx1
+
+         if (QxPresent) then
+            !ice:
+              if (cat==2) then
+                 NX    = 5.*exp(0.304*(273.15-max(233.,T(i,k))))
+                 iLAMx = (ckQx4*QX(i,k)*DE(i,k)/NX)**thrd
+            !snow:
+              else if (cat==3) then
+                 iNo_x = 1./min(2.e+8, 2.e+6*exp(-0.12*min(-0.001,T(i,k)-273.15)))
+                 iLAMx = sqrt(sqrt(QX(i,k)*DE(i,k)*icmx*sxth*iNo_x))
+            !rain, graupel, hail:
+              else
+                 iLAMx = sqrt(sqrt(QX(i,k)*DE(i,k)*icmx*sxth*iNo_x))
+              endif
+              VVQ(i,k) = -gamfact(i,k)*ckQx1*iLAMx**bfx
+         !    VqMax    = max(VxMAX,-VVQ(i,k))
+         endif
+         if (present(massFlux3D)) massFlux3D(i,k)= -VVQ(i,k)*DE(i,k)*QX(i,k)  !(for use in MAIN)
+
+      enddo  !k-loop
+      Vxmaxx(i)= min( VxMax, maxval(VVQ(i,:))*VincFact )
+
+     !note: dzMIN is min. value in column (not necessarily lowest layer in general)
+      dzMIN(i) = minval(DZ(i,:))
+      npassx(i)= max(1, nint( dt*Vxmaxx(i)/(CoMAX*dzMIN(i)) ))
+      dtx(i)   = dt/float(npassx(i))
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+      DO nnn= 1,npassx(i)
+
+         locallim = (nnn==1)
+
+         do k= ktop_sedi(i),nk  !do k= 1,nk
+           RHOQX(i,k) = DE(i,k)*QX(i,k)
+           QxPresent  = (QX(i,k)>epsQ)
+            if (QxPresent) then
+             !ice:
+               if (cat==2) then
+                  NX    = 5.*exp(0.304*(273.15-max(233.,T(i,k))))
+                  iLAMx = (ckQx4*QX(i,k)*DE(i,k)/NX)**thrd
+             !snow:
+               else if (cat==3) then
+                  iNo_x = 1./min(2.e+8, 2.e+6*exp(-0.12*min(-0.001,T(i,k)-273.15)))
+                  iLAMx = sqrt(sqrt(QX(i,k)*DE(i,k)*icmx*sxth*iNo_x))
+             !rain, graupel, hail:
+               else
+                  iLAMx = sqrt(sqrt(QX(i,k)*DE(i,k)*icmx*sxth*iNo_x))
+               endif
+               VVQ(i,k) = -gamfact(i,k)*ckQx1*iLAMx**bfx
+               VqMax    = max(VxMAX,-VVQ(i,k))
+            endif
+
+         enddo  !k-loop
+
+     !-- Perform single split sedimentation step:  (formerly by calls to s/r 'blg4sedi')
+         zz(ks)= 0.
+         do k= ks,ke(i),kw
+            zz(k+kw)= zz(k)+dz(i,k)
+            dzi(k)  = 1./dz(i,k)
+            vp_Q(k) = 0.
+         enddo
+
+         do k=ks,ke(i),kw
+            zb_Q(k)= zz(k) + VVQ(i,k)*dtx(i)
+         enddo
+
+         zt_Q(ke(i))= zb_Q(ke(i)) + dz(i,ke(i))
+         do k= ks,ke(i)-kw,kw
+            zb_Q(k)= min(zb_Q(k+kw)-epsilon*dz(i,k), zz(k)+VVQ(i,k)*dtx(i))
+            zt_Q(k)= zb_Q(k+kw)
+         enddo
+
+         do k=ks,ke(i),kw    !k=1,nk
+            Q_star(k)= RHOQX(i,k)*dz(i,k)/(zt_Q(k)-zb_Q(k))
+         enddo
+
+         if (locallim) then
+            zmax_Q= abs(VqMax*dtx(i))
+            do l=ks,ke(i),kw
+               flim_Q(l)= l
+               do k= l,ke(i),kw
+                  if (zmax_Q.ge.zz(k)-zz(l+kw)) flim_Q(l)= k
+               enddo
+            enddo
+         endif
+
+         do l=ks,ke(i),kw
+            do k=l,flim_Q(l),kw
+               vp_Q(l)= vp_Q(l) + Q_star(k)*max(0.,min(zz(l+kw),zt_Q(k))-max(zz(l),zb_Q(k)))
+            enddo
+         enddo
+
+         do k=ks,ke(i),kw
+            RHOQX(i,k)= vp_Q(k)*dzi(k)
+         enddo
+     !--
+
+         do k= ktop_sedi(i),nk  ! do k= 1,nk
+           QX(i,k)= RHOQX(i,k)*iDE(i,k)
+         enddo
+
+        !sum instantaneous flux at each split step: (for division later)
+         massFlux(i)= massFlux(i) - VVQ(i,nk)*DE(i,nk)*QX(i,nk)
+
+       ENDDO  !nnn-loop
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+      !compute average flux during the full time step: (this will be used to compute
+      ! the instantaneous sedimentation rate [volume flux] in the main s/r)
+       massFlux(i)= massFlux(i)/float(npassx(i))
+
+    ENDDO  !a(i)-loop
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+
+ END SUBROUTINE SEDI_main_1b
+
+!=====================================================================================!
+ SUBROUTINE countColumns(QX,ni,nk,minQX,counter,activeColumn,ktop_sedi)
+
+! Searches the hydrometeor array QX(ni,nk) for non-zero (>minQX) values.
+! Returns the array if i-indices (activeColumn) for the columns (i)
+! which contain at least one non-zero value, as well as the number of such
+! columns (counter).
+
+  implicit none
+
+!PASSING PARAMETERS:
+  integer, intent(in)                   :: ni,nk !,ktop_sedi
+  integer, dimension(:), intent(in)     :: ktop_sedi
+  integer,                 intent(out)  :: counter
+  integer, dimension(:), intent(out)    :: activeColumn
+  real,    dimension(:,:), intent(in)   :: QX
+  real,    intent(in)                   :: minQX
+
+!LOCAL PARAMETERS:
+  integer                               :: i !,k
+  integer, dimension(ni)                :: k
+
+!    k= ktop_sedi-1  !  k=0
+   counter     = 0
+   activeColumn= 0
+
+   do i=1,ni
+      k(i)= ktop_sedi(i)-1  !  k=0
+      do
+         k(i)=k(i)+1
+         if (QX(i,k(i))>minQX) then
+            counter=counter+1
+            activeColumn(counter)=i
+            k(i)=0
+            exit
+         else
+            if (k(i)==nk) then
+               k(i)=0
+               exit
+            endif
+         endif
+      enddo
+   enddo  !i-loop
+
+ END SUBROUTINE countColumns
+
+!=====================================================================================!
+
+end module my_sedi_mod
+
+!________________________________________________________________________________________!
+
+module my_dmom_mod
+
+  implicit none
+
+  private
+  public :: mp_milbrandt2mom_main
+
+  contains
+
+!_______________________________________________________________________________________!
+
+ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS,TM,  &
+     QM,QCM,QRM,QIM,QNM,QGM,QHM,NCM,NRM,NYM,NNM,NGM,NHM,PSM,S,RT_rn1,RT_rn2,RT_fr1,RT_fr2,&
+     RT_sn1,RT_sn2,RT_sn3,RT_pe1,RT_pe2,RT_peL,RT_snd,GZ,T_TEND,Q_TEND,QCTEND,QRTEND,     &
+     QITEND,QNTEND,QGTEND,QHTEND,NCTEND,NRTEND,NYTEND,NNTEND,NGTEND,NHTEND,dt,NI,N,NK,    &
+     J,KOUNT,CCNtype,precipDiag_ON,sedi_ON,warmphase_ON,autoconv_ON,icephase_ON,snow_ON,  &
+     initN,dblMom_c,dblMom_r,dblMom_i,dblMom_s,dblMom_g,dblMom_h,Dm_c,Dm_r,Dm_i,Dm_s,     &
+     Dm_g,Dm_h,ZET,ZEC,SLW,VIS,VIS1,VIS2,VIS3,h_CB,h_ML1,h_ML2,h_SN,SS01,SS02,SS03,SS04,  &
+     SS05,SS06,SS07,SS08,SS09,SS10,SS11,SS12,SS13,SS14,SS15,SS16,SS17,SS18,SS19,SS20)
+
+
+  use my_fncs_mod
+  use my_sedi_mod
+!--WRF:
+    use module_model_constants, ONLY: CPD => cp, CPV => cpv, RGASD => r_d, RGASV => r_v, &
+        EPS1 => EP_2, DELTA => EP_1, CAPPA => rcp, GRAV => g, CHLC => XLV, CHLF => XLF
+!==
+
+  implicit none
+
+!CALLING PARAMETERS:
+  integer,               intent(in)    :: NI,NK,N,J,KOUNT,CCNtype
+  real,                  intent(in)    :: dt
+  real, dimension(:),    intent(in)    :: PS,PSM
+  real, dimension(:),    intent(out)   :: h_CB,h_ML1,h_ML2,h_SN
+  real, dimension(:),    intent(out)   :: RT_rn1,RT_rn2,RT_fr1,RT_fr2,RT_sn1,RT_sn2,   &
+                                          RT_sn3,RT_pe1,RT_pe2,RT_peL,ZEC,RT_snd
+  real, dimension(:,:),  intent(in)    :: W_omega,S,GZ
+  real, dimension(:,:),  intent(inout) :: T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,     &
+        TM,QM,QCM,QRM,QIM,QNM,QGM,QHM,NCM,NRM,NYM,NNM,NGM,NHM
+  real, dimension(:,:),  intent(out)   :: T_TEND,QCTEND,QRTEND,QITEND,QNTEND,          &
+        QGTEND,QHTEND,Q_TEND,NCTEND,NRTEND,NYTEND,NNTEND,NGTEND,NHTEND,ZET,Dm_c,       &
+        Dm_r,Dm_i,Dm_s,Dm_g,Dm_h,SLW,VIS,VIS1,VIS2,VIS3,SS01,SS02,SS03,SS04,SS05,SS06, &
+        SS07,SS08,SS09,SS10,SS11,SS12,SS13,SS14,SS15,SS16,SS17,SS18,SS19,SS20
+  logical,               intent(in)    :: dblMom_c,dblMom_r,dblMom_i,dblMom_s,         &
+        dblMom_g,dblMom_h,precipDiag_ON,sedi_ON,icephase_ON,snow_ON,warmphase_ON,      &
+        autoconv_ON,initN
+
+!_______________________________________________________________________________________
+!                                                                                       !
+!                    Milbrandt-Yau Multimoment Bulk Microphysics Scheme                 !
+!                              - double-moment version   -                              !
+!_______________________________________________________________________________________!
+!  Package version:   2.19.0      (internal bookkeeping)                                !
+!  Last modified  :   2011-03-02                                                        !
+!_______________________________________________________________________________________!
+!
+!  Author:
+!       J. Milbrandt, McGill University (August 2004)
+!
+!  Major revisions:
+!
+!  001  J. Milbrandt  (Dec 2006) - Converted the full Milbrandt-Yau (2005) multimoment
+!        (RPN)                     scheme to an efficient fixed-dispersion double-moment
+!                                  version
+!  002  J. Milbrandt  (Mar 2007) - Added options for single-moment/double-moment for
+!                                  each hydrometeor category
+!  003  J. Milbrandt  (Feb 2008) - Modified single-moment version for use in GEM-LAM-2.5
+!  004  J. Milbrandt  (Nov 2008) - Modified double-moment version for use in 2010 Vancouver
+!                                  Olympics GEM-LAM configuration
+!  005  J. Milbrandt  (Aug 2009) - Modified (dmom) for PHY_v5.0.4, for use in V2010 system:
+!                                  + reduced ice/snow capacitance to C=0.25D (from C=0.5D)
+!                                  + added diagnostic fields (VIS, levels, etc.)
+!                                  + added constraints to snow size distribution (No_s and
+!                                    LAMDA_s limits, plus changed m-D parameters
+!                                  + modified solid-to-liquid ratio calculation, based on
+!                                    volume flux (and other changes)
+!                                  + added back sedimentation of ice category
+!                                  + modified condition for conversion of graupel to hail
+!                                  + corrected bug it diagnostic "ice pellets" vs. "hail"
+!                                  + minor bug corrections (uninitialized values, etc.)
+!  006  J. Milbrandt  (Jan 2011) - Bug fixes and minor code clean-up from PHY_v5.1.3 version
+!                                  + corrected latent heat constants in thermodynamic functions
+!                                    (ABi and ABw) for sublimation and evaporation
+!                                  + properly initialized variables No_g and No_h
+!                                  + changed max ice crystal size (fallspeed) to 5 mm (2 m s-1)
+!                                  + imposed maximum ice number concentration of 1.e+7 m-3
+!                                  + removed unused supersaturation reduction
+!
+!  Object:
+!          Computes changes to the temperature, water vapor mixing ratio, and the
+!          mixing ratios and total number concentrations of six hydrometeor species
+!          resulting from cloud microphysical interactions at saturated grid points.
+!          Liquid and solid surface precipitation rates from sedimenting hydrometeor
+!          categories are also computed.
+!
+!          This subroutine and the associated modules form the single/double-moment
+!          switchable verion of the multimoment bulk microphysics package, the full
+!          version of which is described in the references below.
+!
+!  References:  Milbrandt and Yau, (2005a), J. Atmos. Sci., vol.62, 3051-3064
+!               --------- and ---, (2005b), J. Atmos. Sci., vol.62, 3065-3081
+!               (and references therein)
+!
+!  Please report bugs to:  jason.milbrandt@ec.gc.ca
+!_______________________________________________________________________________________!
+!
+! Arguments:         Description:                                         Units:
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+!            - Input -
+!
+! NI                 number of x-dir points (in local subdomain)
+! NK                 number of vertical levels
+! N                  not used (to be removed)
+! J                  y-dir index (local subdomain)
+! KOUNT              current model time step number
+! dt                 model time step                                      [s]
+! CCNtype            switch for airmass type
+!                      1 = maritime                   --> N_c =  80 cm-3  (1-moment cloud)
+!                      2 = continental 1              --> N_c = 200 cm-3     "       "
+!                      3 = continental 2  (polluted)  --> N_c = 500 cm-3     "       "
+!                      4 = land-sea-mask-dependent (TBA)
+! W_omega            vertical velocity                                    [Pa s-1]
+! S                  sigma (=p/p_sfc)
+! GZ                 geopotential
+! dblMom_(x)         logical switch for double(T)-single(F)-moment for category (x)
+! precipDiag_ON      logical switch, .F. to suppress calc. of sfc precip types
+! sedi_ON            logical switch, .F. to suppress sedimentation
+! warmphase_ON       logical switch, .F. to suppress warm-phase (Part II)
+! autoconv_ON        logical switch, .F. to supppress autoconversion (cld->rn)
+! icephase_ON        logical switch, .F. to suppress ice-phase (Part I)
+! snow_ON            logical switch, .F. to suppress snow initiation
+!
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+!            - Input/Output -
+!
+! T                  air temperature at time (t*)                         [K]
+! TM                 air temperature at time (t-dt)                       [K]
+! Q                  water vapor mixing ratio at (t*)                     [kg kg-1]
+! QM                 water vapor mixing ratio at (t-dt)                   [kg kg-1]
+! PS                 surface pressure at time (t*)                        [Pa]
+! PSM                surface pressure at time (t-dt)                      [Pa]
+!
+!  For x = (C,R,I,N,G,H):  C = cloud
+!                          R = rain
+!                          I = ice (pristine) [except 'NY', not 'NI']
+!                          N = snow
+!                          G = graupel
+!                          H = hail
+!
+! Q(x)               mixing ratio for hydrometeor x at (t*)               [kg kg-1]
+! Q(x)M              mixing ratio for hydrometeor x at (t-dt)             [kg kg-1]
+! N(x)               total number concentration for hydrometeor x  (t*)   [m-3]
+! N(x)M              total number concentration for hydrometeor x  (t-dt) [m-3]
+!
+! Note:  The arrays "VM" (e.g. variables TM,QM,QCM etc.) are declared as INTENT(INOUT)
+!        such that their values are modified in the code [VM = 0.5*(VM + V)].
+!        This is to approxiate the values at time level (t), which are needed by
+!        this routine but are unavailable to the PHYSICS.  The new values are discared
+!        by the calling routine ('vkuocon6.ftn').  However, care should be taken with
+!        interfacing with other modelling systems.  For GEM/MC2, it does not matter if
+!        VM is modified since the calling module passes back only the tendencies
+!        (VTEND) to the model.
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+!            - Output -
+!
+! Q_TEND             tendency for water vapor mixing ratio                [kg kg-1 s-1]
+! T_TEND             tendency for air temperature                         [K s-1]
+! Q(x)TEND           tendency for mixing ratio for hydrometeor x          [kg kg-1 s-1]
+! N(x)TEND           tendency for number concentration for hydrometeor x  [m-3 s-1]
+! Dm_(x)             mean-mass diameter for hydrometeor x                 [m]
+! H_CB               height of cloud base                                 [m]
+! h_ML1              height of first melting level from ground            [m]
+! h_ML2              height of first melting level from top               [m]
+! h_SN               height of snow level                                 [m]
+! RT_rn1             precipitation rate (at sfc) of liquid rain           [m+3 m-2 s-1]
+! RT_rn2             precipitation rate (at sfc) of liquid drizzle        [m+3 m-2 s-1]
+! RT_fr1             precipitation rate (at sfc) of freezing rain         [m+3 m-2 s-1]
+! RT_fr2             precipitation rate (at sfc) of freezing drizzle      [m+3 m-2 s-1]
+! RT_sn1             precipitation rate (at sfc) of ice crystals (liq-eq) [m+3 m-2 s-1]
+! RT_sn2             precipitation rate (at sfc) of snow    (liq-equiv)   [m+3 m-2 s-1]
+! RT_sn3             precipitation rate (at sfc) of graupel (liq-equiv)   [m+3 m-2 s-1]
+! RT_snd             precipitation rate (at sfc) of snow    (frozen)      [m+3 m-2 s-1]
+! RT_pe1             precipitation rate (at sfc) of ice pellets (liq-eq)  [m+3 m-2 s-1]
+! RT_pe2             precipitation rate (at sfc) of hail (total; liq-eq)  [m+3 m-2 s-1]
+! RT_peL             precipitation rate (at sfc) of hail (large only)     [m+3 m-2 s-1]
+! SSxx               S/S terms (for testing purposes)
+! SLW                supercooled liquid water content                     [kg m-3]
+! VIS                visibility resulting from fog, rain, snow            [m]
+! VIS1               visibility component through liquid cloud (fog)      [m]
+! VIS2               visibility component through rain                    [m]
+! VIS3               visibility component through snow                    [m]
+! ZET                total equivalent radar reflectivity                  [dBZ]
+! ZEC                composite (column-max) of ZET                        [dBZ]
+!_______________________________________________________________________________________!
+
+
+!LOCAL VARIABLES:
+
+ !Variables to count active grid points:
+  logical :: log1,log2,log3,log4,doneK,rainPresent,calcDiag,CB_found,ML_found,      &
+             SN_found
+  logical, dimension(size(QC,dim=1),size(QC,dim=2)) :: activePoint
+  integer, dimension(size(QC,dim=1)) :: ktop_sedi
+  integer :: i,k,niter,ll,start
+
+  real    :: tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,tmp7,tmp8,tmp9,tmp10,                    &
+       VDmax,NNUmax,X,D,DEL,QREVP,NuDEPSOR,NuCONTA,NuCONTB,NuCONTC,iMUkin,Ecg,Erg,  &
+       NuCONT,GG,Na,Tcc,F1,F2,Kdiff,PSIa,Kn,source,sink,sour,ratio,qvs0,Kstoke,     &
+       DELqvs,ft,esi,Si,Simax,Vq,Vn,Vz,LAMr,No_r_DM,No_i,No_s,No_g,No_h,D_sll,      &
+       iABi,ABw,VENTr,VENTs,VENTg,VENTi,VENTh,Cdiff,Ka,MUdyn,MUkin,DEo,Ng_tail,     &
+       gam,ScTHRD,Tc,mi,ff,Ec,Ntr,Dho,DMrain,Ech,DMice,DMsnow,DMgrpl,DMhail,        &
+       ssat,Swmax,dey,Esh,Eii,Eis,Ess,Eig,Eih,FRAC,JJ,Dirg,Dirh,Dsrs,Dsrg,Dsrh,     &
+       Dgrg,Dgrh,SIGc,L,TAU,DrAUT,DrINIT,Di,Ds,Dg,Dh,qFact,nFact,Ki,Rz,NgCNgh,      &
+       vr0,vi0,vs0,vg0,vh0,Dc,Dr,QCLcs,QCLrs,QCLis,QCLcg,QCLrg,QCLig,NhCNgh,        &
+       QCLch,QCLrh,QCLsh,QMLir,QMLsr,QMLgr,QMLhr,QCLih,QVDvg,QVDvh,QSHhr,           &
+       QFZci,QNUvi,QVDvi,QCNis,QCNis1,QCNis2,QCLir,QCLri,QCNsg,QCLsr,QCNgh,         &
+       QCLgr,QHwet,QVDvs,QFZrh,QIMsi,QIMgi,NMLhr,NVDvh,NCLir,NCLri,NCLrh,           &
+       NCLch,NCLsr,NCLirg,NCLirh,NrFZrh,NhFZrh,NCLsrs,NCLsrg,NCLsrh,NCLgrg,         &
+       NCLgrh,NVDvg,NMLgr,NiCNis,NsCNis,NVDvs,NMLsr,NCLsh,NCLss,NNUvi,NFZci,NVDvi,  &
+       NCLis,NCLig,NCLih,NMLir,NCLrs,NCNsg,NCLcs,NCLcg,NIMsi,NIMgi,NCLgr,NCLrg,     &
+       NSHhr,RCAUTR,RCACCR,CCACCR,CCSCOC,CCAUTR,CRSCOR,ALFx,des_pmlt,Ecs,des,ides,  &
+       LAMx,iLAMx,iLAMxB0,Dx,ffx,iLAMc,iNCM,iNRM,iNYM,iNNM,iNGM,iLAMs_D3,           &
+       iLAMg,iLAMg2,iLAMgB0,iLAMgB1,iLAMgB2,iLAMh,iLAMhB0,iLAMhB1,iLAMhB2,iNHM,     &
+       iLAMi,iLAMi2,iLAMi3,iLAMi4,iLAMi5,iLAMiB0,iLAMiB1,iLAMiB2,iLAMr6,iLAMh2,     &
+       iLAMs,iLAMs2,iLAMsB0,iLAMsB1,iLAMsB2,iLAMr,iLAMr2,iLAMr3,iLAMr4,iLAMr5,      &
+       iLAMc2,iLAMc3,iLAMc4,iLAMc5,iLAMc6,iQCM,iQRM,iQIM,iQNM,iQGM,iQHM,iEih,iEsh,  &
+       N_c,N_r,N_i,N_s,N_g,N_h,fluxV_i,fluxV_g,fluxV_s,rhos_mlt,fracLiq
+
+ !Variables that only need to be calulated on the first step (and saved):
+  real, save :: idt,iMUc,cmr,cmi,cms,cmg,cmh,icmr,icmi,icmg,icms,icmh,idew,idei,    &
+       ideh,ideg,GC1,imso,icexc9,cexr1,cexr2,cexr3,No_s_SM,No_r,idms,imgo,icexs2,   &
+       cexr4,cexr5,cexr6,cexr9,icexr9,ckQr1,ckQr2,ckQr3,ckQi1,ckQi2,ckQi3,ckQi4,    &
+       icexi9,ckQs1,ckQs2,cexs1,cexs2,ckQg1,ckQg2,ckQg4,ckQh1,ckQh2,ckQh4,GR37,dms, &
+       LCP,LFP,LSP,ck5,ck6,PI2,PIov4,PIov6,CHLS,iCHLF,cxr,cxi,Gzr,Gzi,Gzs,Gzg,Gzh,  &
+       N_c_SM,iGC1,GC2,GC3,GC4,GC5,iGC5,GC6,GC7,GC8,GC11,GC12,GC13,GC14,iGR34,mso,  &
+       GC15,GR1,GR3,GR13,GR14,GR15,GR17,GR31,iGR31,GR32,GR33,GR34,GR35,GR36,GI4,    &
+       GI6,GI20,GI21,GI22,GI31,GI32,GI33,GI34,GI35,iGI31,GI11,GI36,GI37,GI40,iGG34, &
+       GS09,GS11,GS12,GS13,iGS20,GS31,iGS31,GS32,GS33,GS34,GS35,GS36,GS40,iGS40,    &
+       GS50,GG09,GG11,GG12,GG13,GG31,iGG31,GG32,GG33,GG34,GG35,GG36,GG40,iGG99,GH09,&
+       GH11,GH12,GH13,GH31,GH32,GH33,GH40,GR50,GG50,iGH34,GH50,iGH99,iGH31,iGS34,   &
+       iGS20_D3,GS40_D3,cms_D3,eds,fds,rfact_FvFm
+
+!Size distribution parameters:
+  real, parameter :: MUc      =  3.    !shape parameter for cloud
+  real, parameter :: alpha_c  =  1.    !shape parameter for cloud
+  real, parameter :: alpha_r  =  0.    !shape parameter for rain
+  real, parameter :: alpha_i  =  0.    !shape parameter for ice
+  real, parameter :: alpha_s  =  0.    !shape parameter for snow
+  real, parameter :: alpha_g  =  0.    !shape parameter for graupel
+  real, parameter :: alpha_h  =  0.    !shape parameter for hail
+  real, parameter :: No_s_max =  1.e+8 !max. allowable intercept for snow [m-4]
+  real, parameter :: lamdas_min= 500.  !min. allowable LAMDA_s [m-1]
+
+ !For single-moment:
+  real, parameter :: No_r_SM  =  1.e+7  !intercept parameter for rain    [m-4]
+  real, parameter :: No_g_SM  =  4.e+6  !intercept parameter for graupel [m-4]
+  real, parameter :: No_h_SM  =  1.e+5  !intercept parameter for hail    [m-4]
+  !note: No_s = f(T), rather than a fixed value
+  !------------------------------------!
+  ! Symbol convention: (dist. params.) ! MY05: Milbrandt & Yau, 2005a,b (JAS)
+  !       MY05    F94       CP00       ! F94:  Ferrier, 1994            (JAS)
+  !       ------  --------  ------     ! CP00: Cohard & Pinty, 2000a,b  (QJGR)
+  !       ALFx    ALPHAx    MUx-1      !
+  !       MUx     (1)       ALPHAx     !
+  !       ALFx+1  ALPHAx+1  MUx        !
+  !------------------------------------!
+  !  Note: The symbols for MU and ALPHA are REVERSED from that of CP2000a,b
+  !        Explicit appearance of MUr = 1. has been removed.
+
+  ! Fallspeed parameters:
+  real, parameter :: afr=  149.100,  bfr= 0.5000   !Tripoloi and Cotton (1980)
+  real, parameter :: afi=   71.340,  bfi= 0.6635   !Ferrier (1994)
+  real, parameter :: afs=   11.720,  bfs= 0.4100   !Locatelli and Hobbs (1974)
+  real, parameter :: afg=   19.300,  bfg= 0.3700   !Ferrier (1994)
+  real, parameter :: afh=  206.890,  bfh= 0.6384   !Ferrier (1994)
+ !options:
+ !real, parameter :: afs=    8.996,  bfs= 0.4200   !Ferrier (1994)
+ !real, parameter :: afg=   6.4800,  bfg= 0.2400   !LH74 (grpl-like snow of lump type)
+
+  real, parameter :: epsQ  = 1.e-14   !kg kg-1, min. allowable mixing ratio
+  real, parameter :: epsN  = 1.e-3    !m-3,     min. allowable number concentration
+  real, parameter :: epsQ2 = 1.e-6    !kg kg-1, mixing ratio threshold for diagnostics
+  real, parameter :: epsVIS= 1.       !m,       min. allowable visibility
+
+  real, parameter :: iLAMmin1= 1.e-6  !min. iLAMx (prevents underflow in Nox and VENTx calcs)
+  real, parameter :: iLAMmin2= 1.e-10 !min. iLAMx (prevents underflow in Nox and VENTx calcs)
+  real, parameter :: eps   = 1.e-32
+  real, parameter :: k1    = 0.001
+  real, parameter :: k2    = 0.0005
+  real, parameter :: k3    = 2.54
+  real, parameter :: CPW   = 4218., CPI=2093.
+
+  real, parameter :: deg   =  400., mgo= 1.6e-10
+  real, parameter :: deh   =  900.
+  real, parameter :: dei   =  500., mio=1.e-12, Nti0=1.e3
+  real, parameter :: dew   = 1000.
+  real, parameter :: desFix=  100.  !used for snowSpherical = .true.
+  real, parameter :: desMax=  500.
+  real, parameter :: Dso   =  125.e-6  ![m]; embryo snow diameter (mean-volume particle)
+  real, parameter :: dmr   = 3., dmi= 3., dmg= 3., dmh= 3.
+
+  ! NOTE: VxMAX below are the max.allowable mass-weighted fallspeeds for sedimentation.
+  !       Thus, Vx corresponds to DxMAX (at sea-level) times the max. density factor, GAM.
+  !       [GAMmax=sqrt(DEo/DEmin)=sqrt(1.25/0.4)~2.]  e.g. VrMAX = 2.*8.m/s = 16.m/s
+  real, parameter :: DrMax=  5.e-3,   VrMax= 16.,   epsQr_sedi= 1.e-8
+  real, parameter :: DiMax=  5.e-3,   ViMax=  2.,   epsQi_sedi= 1.e-10
+  real, parameter :: DsMax=  5.e-3,   VsMax=  2.,   epsQs_sedi= 1.e-8
+  real, parameter :: DgMax= 50.e-3,   VgMax=  8.,   epsQg_sedi= 1.e-8
+  real, parameter :: DhMax= 80.e-3,   VhMax= 25.,   epsQh_sedi= 1.e-10
+
+  real, parameter :: thrd    = 1./3.
+  real, parameter :: sixth   = 0.5*thrd
+  real, parameter :: Ers     = 1., Eci= 1.        !collection efficiencies, Exy, between categories x and y
+  real, parameter :: Eri     = 1., Erh= 1.
+  real, parameter :: Xdisp   = 0.25               !dispersion of the fall velocity of ice
+  real, parameter :: aa11    = 9.44e15, aa22= 5.78e3, Rh= 41.e-6
+  real, parameter :: Avx     = 0.78, Bvx= 0.30    !ventilation coefficients [F94 (B.36)]
+  real, parameter :: Abigg   = 0.66, Bbigg= 100.  !parameters in probabilistic freezing
+  real, parameter :: fdielec     = 4.464          !ratio of dielectric factor, |K|w**2/|K|i**2
+  real, parameter :: zfact       = 1.e+18         !conversion factor for m-3 to mm2 m-6 for Ze
+  real, parameter :: minZET      = -99.           ![dBZ] min threshold for ZET
+  real, parameter :: maxVIS      = 99.e+3         ![m] max. allowable VIS (visibility)
+  real, parameter :: Drshed      = 0.001          ![m] mean diam. of drop shed during wet growth
+  real, parameter :: SIGcTHRS    = 15.e-6         !threshold cld std.dev. before autoconversion
+  real, parameter :: KK1         = 3.03e3         !parameter in Long (1974) kernel
+  real, parameter :: KK2         = 2.59e15        !parameter in Long (1974) kernel
+  real, parameter :: Dhh         = 82.e-6         ![m] diameter that rain hump first appears
+  real, parameter :: gzMax_sedi  = 200000.        !GZ value below which sedimentation is computed
+  real, parameter :: Dr_large    = 200.e-6        ![m] size threshold to distinguish rain/drizzle for precip rates
+  real, parameter :: Ds_large    = 200.e-6        ![m] size threshold to distinguish snow/snow-grains for precip rates
+  real, parameter :: Dh_large    = 1.0e-2         ![m] size threshold for "large" hail precipitation rate
+  real, parameter :: Dh_min      = 5.0e-3         ![m] size threhsold for below which hail converts to graupel
+  real, parameter :: Dr_3cmpThrs = 2.5e-3         ![m] size threshold for hail production from 3-comp freezing
+  real, parameter :: w_CNgh      = 3.             ![m s-1] vertical motion  threshold for CNgh
+! real, parameter :: r_CNgh      = 0.05           !Dg/Dho ratio threshold for CNgh
+  real, parameter :: Ngh_crit    = 0.01           ![m-3] critical graupel concentration for CNgh
+  real, parameter :: Tc_FZrh     = -10.           !temp-threshold (C) for FZrh
+  real, parameter :: CNsgThres   = 1.0            !threshold for CLcs/VDvs ratio for CNsg
+  real, parameter :: capFact_i   = 0.5            !capacitace factor for ice  (C= 0.5*D*capFact_i)
+  real, parameter :: capFact_s   = 0.5            !capacitace factor for snow (C= 0.5*D*capFact_s)
+  real, parameter :: noVal_h_XX  = -1.            !non-value indicator for h_CB, h_ML1, h_ML2, h_SN
+  real, parameter :: minSnowSize = 1.e-4          ![m] snow size threshold to compute h_SN
+  real, parameter :: Fv_Dsmin    = 125.e-6        ![m] min snow size to compute volume flux
+  real, parameter :: Fv_Dsmax    = 0.008          ![m] max snow size to compute volume flux
+  real, parameter :: Ni_max      = 1.e+7          ![m-3] max ice crystal concentration
+
+!-- For GEM:
+!#include "consphy.cdk"
+!#include "dintern.cdk"
+!#include "fintern.cdk"
+
+!-- For WRF:
+!------------------------------------------------------------------------------!
+!#include "consphy.cdk"
+! real, parameter :: CPD      =.100546e+4         !J K-1 kg-1; specific heat of dry air
+! real, parameter :: CPV      =.186946e+4         !J K-1 kg-1; specific heat of water vapour
+! real, parameter :: RGASD    =.28705e+3          !J K-1 kg-1; gas constant for dry air
+! real, parameter :: RGASV    =.46151e+3          !J K-1 kg-1; gas constant for water vapour
+  real, parameter :: TRPL     =.27316e+3          !K; triple point of water
+  real, parameter :: TCDK     =.27315e+3          !conversion from kelvin to celsius
+  real, parameter :: RAUW     =.1e+4              !density of liquid H2O
+! real, parameter :: EPS1     =.62194800221014    !RGASD/RGASV
+  real, parameter :: EPS2     =.3780199778986     !1 - EPS1
+! real, parameter :: DELTA    =.6077686814144     !1/EPS1 - 1
+! real, parameter :: CAPPA    =.28549121795       !RGASD/CPD
+  real, parameter :: TGL      =.27316e+3          !K; ice temperature in the atmosphere
+  real, parameter :: CONSOL   =.1367e+4           !W m-2; solar constant
+! real, parameter :: GRAV     =.980616e+1         !M s-2; gravitational acceleration
+  real, parameter :: RAYT     =.637122e+7         !M; mean radius of the earth
+  real, parameter :: STEFAN   =.566948e-7         !J m-2 s-1 K-4; Stefan-Boltzmann constant
+  real, parameter :: PI       =.314159265359e+1   !PI constant = ACOS(-1)
+  real, parameter :: OMEGA    =.7292e-4           !s-1; angular speed of rotation of the earth
+  real, parameter :: KNAMS    =.514791            !conversion from knots to m/s
+  real, parameter :: STLO     =.6628486583943e-3  !K s2 m-2; Schuman-Newell Lapse Rate
+  real, parameter :: KARMAN   =.35                !Von Karman constant
+  real, parameter :: RIC      =.2                 !Critical Richardson number
+! real, parameter :: CHLC     =.2501e+7           !J kg-1; latent heat of condensation
+! real, parameter :: CHLF     =.334e+6            !J kg-1; latent heat of fusion
+
+!------------------------------------------------------------------------------!
+!#include "dintern.cdk"
+      REAL   TTT, PRS, QQQ, EEE, TVI, QST, QQH
+      REAL   T00, PR0, TF, PF,FFF , DDFF
+      REAL   QSM , DLEMX
+      REAL*8 FOEW,FODLE,FOQST,FODQS,FOEFQ,FOQFE,FOTVT,FOTTV,FOHR
+      REAL*8 FOLV,FOLS,FOPOIT,FOPOIP,FOTTVH,FOTVHT
+      REAL*8 FOEWA,FODLA,FOQSA,FODQA,FOHRA
+      REAL*8 FESI,FDLESI,FESMX,FDLESMX,FQSMX,FDQSMX
+
+!------------------------------------------------------------------------------!
+!#include "fintern.cdk"
+!   DEFINITION DES FONCTIONS THERMODYNAMIQUES DE BASE
+!   POUR LES CONSTANTES, UTILISER LE COMMON /CONSPHY/
+!     NOTE: TOUTES LES FONCTIONS TRAVAILLENT AVEC LES UNITES S.I.
+!           I.E. TTT EN DEG K, PRS EN PA, QQQ EN KG/KG
+!          *** N. BRUNET - MAI 90 ***
+!          * REVISION 01 - MAI 94 - N. BRUNET
+!                          NOUVELLE VERSION POUR FAIBLES PRESSIONS
+!          * REVISION 02 - AOUT 2000 - J-P TOVIESSI
+!                          CALCUL EN REAL*8
+!          * REVISION 03 - SEPT 2000 - N. BRUNET
+!                          AJOUT DE NOUVELLES FONCTIONS
+!          * REVISION 04 - JANV 2000 - J. MAILHOT
+!                          FONCTIONS EN PHASE MIXTE
+!          * REVISION 05 - DEC 2001 - G. LEMAY
+!                          DOUBLE PRECISION POUR PHASE MIXTE
+!          * REVISION 06 - AVR 2002 - A. PLANTE
+!                          AJOUT DES NOUVELLES FONCTIONS FOTTVH ET FOTVHT
+!
+!     FONCTION DE TENSION DE VAPEUR SATURANTE (TETENS) - EW OU EI SELON TT
+      FOEW(TTT) = 610.78D0*DEXP( DMIN1(DSIGN(17.269D0,                     &
+       DBLE(TTT)-DBLE(TRPL)),DSIGN                                         &
+       (21.875D0,DBLE(TTT)-DBLE(TRPL)))*DABS(DBLE(TTT)-DBLE(TRPL))/        &
+       (DBLE(TTT)-35.86D0+DMAX1(0.D0,DSIGN                                 &
+       (28.2D0,DBLE(TRPL)-DBLE(TTT)))))
+!
+!     FONCTION CALCULANT LA DERIVEE SELON T DE  LN EW (OU LN EI)
+      FODLE(TTT)=(4097.93D0+DMAX1(0.D0,DSIGN(1709.88D0,                    &
+       DBLE(TRPL)-DBLE(TTT))))                                             &
+       /((DBLE(TTT)-35.86D0+DMAX1(0.D0,DSIGN(28.2D0,                       &
+       DBLE(TRPL)-DBLE(TTT))))*(DBLE(TTT)-35.86D0+DMAX1(0.D0               &
+       ,DSIGN(28.2D0,DBLE(TRPL)-DBLE(TTT)))))
+!
+!     FONCTION CALCULANT L'HUMIDITE SPECIFIQUE SATURANTE (QSAT)
+      FOQST(TTT,PRS) = DBLE(EPS1)/(DMAX1(1.D0,DBLE(PRS)/FOEW(TTT))-        &
+       DBLE(EPS2))
+!
+!     FONCTION CALCULANT LA DERIVEE DE QSAT SELON T
+      FODQS(QST,TTT)=DBLE(QST)*(1.D0+DBLE(DELTA)*DBLE(QST))*FODLE(TTT)
+!     QST EST LA SORTIE DE FOQST
+!
+!     FONCTION CALCULANT TENSION VAP (EEE) FN DE HUM SP (QQQ) ET PRS
+      FOEFQ(QQQ,PRS) = DMIN1(DBLE(PRS),(DBLE(QQQ)*DBLE(PRS)) /             &
+       (DBLE(EPS1) + DBLE(EPS2)*DBLE(QQQ)))
+!
+!      FONCTION CALCULANT HUM SP (QQQ) DE TENS. VAP (EEE) ET PRES (PRS)
+      FOQFE(EEE,PRS) = DMIN1(1.D0,DBLE(EPS1)*DBLE(EEE)/(DBLE(PRS)-         &
+       DBLE(EPS2)*DBLE(EEE)))
+!
+!      FONCTION CALCULANT TEMP VIRT. (TVI) DE TEMP (TTT) ET HUM SP (QQQ)
+      FOTVT(TTT,QQQ) = DBLE(TTT) * (1.0D0 + DBLE(DELTA)*DBLE(QQQ))
+
+!      FONCTION CALCULANT TEMP VIRT. (TVI) DE TEMP (TTT), HUM SP (QQQ) ET
+!      MASSE SP DES HYDROMETEORES.
+      FOTVHT(TTT,QQQ,QQH) = DBLE(TTT) *                                    &
+           (1.0D0 + DBLE(DELTA)*DBLE(QQQ) - DBLE(QQH))
+!
+!      FONCTION CALCULANT TTT DE TEMP VIRT. (TVI) ET HUM SP (QQQ)
+      FOTTV(TVI,QQQ) = DBLE(TVI) / (1.0D0 + DBLE(DELTA)*DBLE(QQQ))
+
+!      FONCTION CALCULANT TTT DE TEMP VIRT. (TVI), HUM SP (QQQ) ET
+!      MASSE SP DES HYDROMETEORES (QQH)
+      FOTTVH(TVI,QQQ,QQH) = DBLE(TVI) /                                    &
+           (1.0D0 + DBLE(DELTA)*DBLE(QQQ) - DBLE(QQH))
+!
+!      FONCTION CALCULANT HUM REL DE HUM SP (QQQ), TEMP (TTT) ET PRES (PRS)
+!      HR = E/ESAT
+#if (DWORDSIZE == 8 && RWORDSIZE == 8)
+       FOHR(QQQ,TTT,PRS) = MIN(     PRS ,FOEFQ(QQQ,PRS)) / FOEW(TTT)
+#elif (DWORDSIZE == 8 && RWORDSIZE == 4)
+       FOHR(QQQ,TTT,PRS) = MIN(DBLE(PRS),FOEFQ(QQQ,PRS)) / FOEW(TTT)
+#else
+     This is a temporary hack assuming double precision is 8 bytes.
+#endif
+!
+!     FONCTION CALCULANT LA CHALEUR LATENTE DE CONDENSATION
+      FOLV(TTT) =DBLE(CHLC) - 2317.D0*(DBLE(TTT)-DBLE(TRPL))
+!
+!     FONCTION CALCULANT LA CHALEUR LATENTE DE SUBLIMATION
+      FOLS(TTT) = DBLE(CHLC)+DBLE(CHLF)+(DBLE(CPV)-                        &
+                  (7.24D0*DBLE(TTT)+128.4D0))*(DBLE(TTT)-DBLE(TRPL))
+!
+!     FONCTION RESOLVANT L'EQN. DE POISSON POUR LA TEMPERATURE
+!     NOTE: SI PF=1000*100, "FOPOIT" DONNE LE THETA STANDARD
+      FOPOIT(T00,PR0,PF)=DBLE(T00)*(DBLE(PR0)/DBLE(PF))**                  &
+                       (-DBLE(CAPPA))
+!
+!     FONCTION RESOLVANT L'EQN. DE POISSON POUR LA PRESSION
+      FOPOIP(T00,TF,PR0)=DBLE(PR0)*DEXP(-(DLOG(DBLE(T00)/DBLE(TF))/        &
+                       DBLE(CAPPA)))
+!
+!     LES 5 FONCTIONS SUIVANTES SONT VALIDES DANS LE CONTEXTE OU ON
+!     NE DESIRE PAS TENIR COMPTE DE LA PHASE GLACE DANS LES CALCULS
+!     DE SATURATION.
+!   FONCTION DE VAPEUR SATURANTE (TETENS)
+      FOEWA(TTT)=610.78D0*DEXP(17.269D0*(DBLE(TTT)-DBLE(TRPL))/            &
+       (DBLE(TTT)-35.86D0))
+!   FONCTION CALCULANT LA DERIVEE SELON T DE LN EW
+      FODLA(TTT)=17.269D0*(DBLE(TRPL)-35.86D0)/(DBLE(TTT)-35.86D0)**2
+!   FONCTION CALCULANT L'HUMIDITE SPECIFIQUE SATURANTE
+      FOQSA(TTT,PRS)=DBLE(EPS1)/(DMAX1(1.D0,DBLE(PRS)/FOEWA(TTT))-         &
+       DBLE(EPS2))
+!   FONCTION CALCULANT LA DERIVEE DE QSAT SELON T
+      FODQA(QST,TTT)=DBLE(QST)*(1.D0+DBLE(DELTA)*DBLE(QST))*FODLA(TTT)
+!   FONCTION CALCULANT L'HUMIDITE RELATIVE
+#if (DWORDSIZE == 8 && RWORDSIZE == 8)
+      FOHRA(QQQ,TTT,PRS)=MIN(     PRS ,FOEFQ(QQQ,PRS))/FOEWA(TTT)
+#elif (DWORDSIZE == 8 && RWORDSIZE == 4)
+      FOHRA(QQQ,TTT,PRS)=MIN(DBLE(PRS),FOEFQ(QQQ,PRS))/FOEWA(TTT)
+#else
+     This is a temporary hack assuming double precision is 8 bytes.
+#endif
+!
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!
+!   Definition of basic thermodynamic functions in mixed-phase mode
+!     FFF is the fraction of ice and DDFF its derivative w/r to T
+!     NOTE: S.I. units are used
+!           i.e. TTT in deg K, PRS in Pa
+!          *** J. Mailhot - Jan. 2000 ***
+!
+!     Saturation calculations in presence of liquid phase only
+!     Function for saturation vapor pressure (TETENS)
+      FESI(TTT)=610.78D0*DEXP(21.875D0*(DBLE(TTT)-DBLE(TRPL))/             &
+             (DBLE(TTT)-7.66D0)  )
+      FDLESI(TTT)=21.875D0*(DBLE(TRPL)-7.66D0)/(DBLE(TTT)-7.66D0)**2
+      FESMX(TTT,FFF) = (1.D0-DBLE(FFF))*FOEWA(TTT)+DBLE(FFF)*FESI(TTT)
+      FDLESMX(TTT,FFF,DDFF) = ( (1.D0-DBLE(FFF))*FOEWA(TTT)*FODLA(TTT)     &
+                            + DBLE(FFF)*FESI(TTT)*FDLESI(TTT)              &
+                  + DBLE(DDFF)*(FESI(TTT)-FOEWA(TTT)) )/FESMX(TTT,FFF)
+      FQSMX(TTT,PRS,FFF) = DBLE(EPS1)/                                     &
+              (DMAX1(1.D0,DBLE(PRS)/FESMX(TTT,FFF) ) - DBLE(EPS2)  )
+      FDQSMX(QSM,DLEMX) = DBLE(QSM ) *(1.D0 + DBLE(DELTA)* DBLE(QSM ) )    &
+                           * DBLE(DLEMX )
+!
+! ! !------------------------------------------------------------------------------!
+!***** END of Replace 3 #includes (for WRF) ***
+
+  ! Constants used for contact ice nucleation:
+  real, parameter :: LAMa0  = 6.6e-8     ![m] mean free path at T0 and p0 [W95_eqn58]
+  real, parameter :: T0     = 293.15     ![K] ref. temp.
+  real, parameter :: p0     = 101325.    ![Pa] ref. pres.
+  real, parameter :: Ra     = 1.e-6      ![m] aerosol (IN) radius         [M92 p.713; W95_eqn60]
+  real, parameter :: kBoltz = 1.381e-23  !Boltzmann's constant
+  real, parameter :: KAPa   = 5.39e5     !aerosol thermal conductivity
+
+ !Test switches:
+  logical, parameter :: iceDep_ON     = .true.  !.false. to suppress depositional growth of ice
+  logical, parameter :: grpl_ON       = .true.  !.false. to suppress graupel initiation
+  logical, parameter :: hail_ON       = .true.  !.false. to suppress hail initiation
+  logical, parameter :: rainAccr_ON   = .true.  ! rain accretion and self-collection ON/OFF
+  logical, parameter :: snowSpherical = .false. !.true.: m(D)=(pi/6)*const_des*D^3 | .false.: m(D)= 0.069*D^2
+  integer, parameter :: primIceNucl   = 1       !1= Meyers+contact ;  2= Cooper
+  real,    parameter :: outfreq       =  60.    !frequency to compute output diagnostics [s]
+
+!Passed as physics namelist parameters:
+! logical, parameter :: precipDiag_ON = .true.  !.false. to suppress calc. of sfc precip types
+! logical, parameter :: sedi_ON       = .true.  !.false. to suppress sedimentation
+! logical, parameter :: warmphase_ON  = .true.  !.false. to suppress warm-phase (Part II)
+! logical, parameter :: autoconv_ON   = .true.  ! autoconversion ON/OFF
+! logical, parameter :: icephase_ON   = .true.  !.false. to suppress ice-phase (Part I)
+! logical, parameter :: snow_ON       = .true.  !.false. to suppress snow initiation
+! logical, parameter :: initN         = .true.  !.true.  to initialize Nx of Qx>0 and Nx=0
+
+  real, dimension(size(QC,dim=1),size(QC,dim=2)) :: DE,iDE,DP,QSS,QSW,QSI,WZ,DZ,RHOQX,FLIM,  &
+        VQQ,gamfact,gamfact_r,massFlux3D_r,massFlux3D_s
+  real, dimension(size(QC,dim=1))                :: fluxM_r,fluxM_i,fluxM_s,fluxM_g,fluxM_h, &
+        HPS,dum
+  integer, dimension(size(QC,dim=1))             :: activeColumn
+
+
+  !==================================================================================!
+
+  !----------------------------------------------------------------------------------!
+  !                      PART 1:   Prelimiary Calculations                           !
+  !----------------------------------------------------------------------------------!
+
+!-------------
+!Convert N from #/kg to #/m3:
+  do k= 1,nk
+    do i= 1,ni
+      tmp1= S(i,k)*PSM(i)/(RGASD*TM(i,k))  !air density at time (t-1)
+      tmp2= S(i,k)*PS(i)/(RGASD*T(i,k))    !air density at time (*)
+
+      NCM(i,k)= NCM(i,k)*tmp1;   NC(i,k)= NC(i,k)*tmp2
+      NRM(i,k)= NRM(i,k)*tmp1;   NR(i,k)= NR(i,k)*tmp2
+      NYM(i,k)= NYM(i,k)*tmp1;   NY(i,k)= NY(i,k)*tmp2
+      NNM(i,k)= NNM(i,k)*tmp1;   NN(i,k)= NN(i,k)*tmp2
+      NGM(i,k)= NGM(i,k)*tmp1;   NG(i,k)= NG(i,k)*tmp2
+      NHM(i,k)= NHM(i,k)*tmp1;   NH(i,k)= NH(i,k)*tmp2
+    enddo
+  enddo
+!=============
+
+  ! The SSxx arrays are for passed to the volatile bus for output as 3-D diagnostic
+  ! output variables, for testing purposes.  For example, to output the
+  ! instantanous value of the deposition rate, add 'SS01(i,k) = QVDvi'  in the
+  ! appropriate place.  It can then be output as a 3-D physics variable by adding
+  ! it to the sortie_p list in 'outcfgs.out'
+
+  SS01= 0.; SS02= 0.; SS03= 0.; SS04= 0.; SS05= 0.; SS06= 0.; SS07= 0.; SS08= 0.
+  SS09= 0.; SS10= 0.; SS11= 0.; SS12= 0.; SS13= 0.; SS14= 0.; SS15= 0.; SS16= 0.
+  SS17= 0.; SS18= 0.; SS19= 0.; SS20= 0.
+
+ !Determine the upper-most level in each column to which to compute sedimentation:
+  ktop_sedi= 0
+  do i=1,ni
+     do k=1,nk
+       ktop_sedi(i)= k
+       if (GZ(i,k)<gzMax_sedi) exit
+     enddo
+  enddo
+
+ !Compute diagnostic values only every 'outfreq' minutes:
+ !calcDiag= (mod(DT*float(KOUNT),outfreq)==0.)
+  calcDiag = .true.  !compute diagnostics every step (for time-series output)
+
+!####  These need only to be computed once per model integration:
+!      (note:  These variables must be declared with the SAVE attribute)
+
+! if (KOUNT==0) then
+!*** For restarts, these values are not saved.  Therefore, the condition statement
+!    must be modified to something like: IF (MOD(Step_rsti,KOUNT).eq.0) THEN
+!    in order that these be computed only on the first step of a given restart.
+!    (...to be done.  For now, changing condition to IF(TRUE) to compute at each step.)
+
+
+  if (.TRUE.) then
+
+   PI2    = PI*2.
+   PIov4  = 0.25*PI
+   PIov6  = PI*sixth
+   CHLS   = CHLC+CHLF  !J k-1; latent heat of sublimation
+   LCP    = CHLC/CPD
+   LFP    = CHLF/CPD
+   iCHLF  = 1./CHLF
+   LSP    = LCP+LFP
+   ck5    = 4098.170*LCP
+   ck6    = 5806.485*LSP
+   idt    = 1./dt
+   imgo   = 1./mgo
+   idew   = 1./dew
+   idei   = 1./dei
+   ideg   = 1./deg
+   ideh   = 1./deh
+
+   !Constants based on size distribution parameters:
+
+   ! Mass parameters [ m(D) = cD^d ]
+   cmr    = PIov6*dew;  icmr= 1./cmr
+   cmi    = 440.;       icmi= 1./cmi
+   cmg    = PIov6*deg;  icmg= 1./cmg
+   cmh    = PIov6*deh;  icmh= 1./cmh
+
+   cms_D3 = PIov6*desFix !used for snowSpherical = .T. or .F.
+   if (snowSpherical) then
+      cms = cms_D3
+      dms = 3.
+   else
+!     cms = 0.0690;  dms = 2.000   !Cox, 1988 (QJRMS)
+      cms = 0.1597;  dms = 2.078   !Brandes et al., 2007 (JAMC)
+   endif
+   icms   = 1./cms
+   idms   = 1./dms
+   mso    = cms*Dso**dms
+   imso   = 1./mso
+  !bulk density parameters: [rho(D) = eds*D^fds]
+  !  These are implied by the mass-diameter parameters, by computing the bulk
+  !  density of a sphere with the equaivalent mass.
+  !  e.g. m(D) = cD^d = (pi/6)rhoD^3 and solve for rho(D)
+   eds    = cms/PIov6
+   fds    = dms-3.
+   if (fds/=-1. .and..not.snowSpherical) GS50= gamma(1.+fds+alpha_s)
+
+   ! Cloud:
+   iMUc   =  1./MUc
+   GC1    =  gamma(alpha_c+1.0)
+   iGC1   = 1./GC1
+   GC2    =  gamma(alpha_c+1.+3.0*iMUc)  !i.e. gamma(alf + 4)
+   GC3    =  gamma(alpha_c+1.+6.0*iMUc)  !i.e. gamma(alf + 7)
+   GC4    =  gamma(alpha_c+1.+9.0*iMUc)  !i.e. gamma(alf + 10)
+   GC11   =  gamma(1.0*iMUc+1.0+alpha_c)
+   GC12   =  gamma(2.0*iMUc+1.0+alpha_c)
+   GC5    =  gamma(1.0+alpha_c)
+   iGC5   = 1./GC5
+   GC6    =  gamma(1.0+alpha_c+1.0*iMUc)
+   GC7    =  gamma(1.0+alpha_c+2.0*iMUc)
+   GC8    =  gamma(1.0+alpha_c+3.0*iMUc)
+   GC13   =  gamma(3.0*iMUc+1.0+alpha_c)
+   GC14   =  gamma(4.0*iMUc+1.0+alpha_c)
+   GC15   =  gamma(5.0*iMUc+1.0+alpha_c)
+   icexc9 =  1./(GC2*iGC1*PIov6*dew)
+  !specify cloud droplet number concentration [m-3] based on 'CCNtype' (1-moment):
+   if     (CCNtype==1) then
+      N_c_SM =  0.8e+8          !maritime
+   elseif (CCNtype==2) then
+      N_c_SM =  2.0e+8          !continental 1
+   elseif (CCNtype==3) then
+      N_c_SM =  5.0e+8          !continental 2 (polluted)
+   else
+      N_c_SM =  2.0e+8          !default (cont1), if 'CCNtype' specified incorrectly
+   endif
+
+   ! Rain:
+   cexr1  = 1.+alpha_r+dmr+bfr
+   cexr2  = 1.+alpha_r+dmr
+   GR17   = gamma(2.5+alpha_r+0.5*bfr)
+   GR31   = gamma(1.+alpha_r)
+   iGR31  = 1./GR31
+   GR32   = gamma(2.+alpha_r)
+   GR33   = gamma(3.+alpha_r)
+   GR34   = gamma(4.+alpha_r)
+   iGR34  = 1./GR34
+   GR35   = gamma(5.+alpha_r)
+   GR36   = gamma(6.+alpha_r)
+   GR37   = gamma(7.+alpha_r)
+   GR50   = (No_r_SM*GR31)**0.75  !for 1-moment or Nr-initialization
+   cexr5  = 2.+alpha_r
+   cexr6  = 2.5+alpha_r+0.5*bfr
+   cexr9  = cmr*GR34*iGR31;    icexr9= 1./cexr9
+   cexr3  = 1.+bfr+alpha_r
+   cexr4  = 1.+alpha_r
+   ckQr1  = afr*gamma(1.+alpha_r+dmr+bfr)/gamma(1.+alpha_r+dmr)
+   ckQr2  = afr*gamma(1.+alpha_r+bfr)*GR31
+   ckQr3  = afr*gamma(7.+alpha_r+bfr)/GR37
+   if (.not.dblMom_r) then
+      No_r = No_r_SM
+   endif
+
+   ! Ice:
+   GI4    = gamma(alpha_i+dmi+bfi)
+   GI6    = gamma(2.5+bfi*0.5+alpha_i)
+   GI11   = gamma(1.+bfi+alpha_i)
+   GI20   = gamma(0.+bfi+1.+alpha_i)
+   GI21   = gamma(1.+bfi+1.+alpha_i)
+   GI22   = gamma(2.+bfi+1.+alpha_i)
+   GI31   = gamma(1.+alpha_i)
+   iGI31  = 1./GI31
+   GI32   = gamma(2.+alpha_i)
+   GI33   = gamma(3.+alpha_i)
+   GI34   = gamma(4.+alpha_i)
+   GI35   = gamma(5.+alpha_i)
+   GI36   = gamma(6.+alpha_i)
+   GI40   = gamma(1.+alpha_i+dmi)
+   icexi9 = 1./(cmi*gamma(1.+alpha_i+dmi)*iGI31)
+   ckQi1  = afi*gamma(1.+alpha_i+dmi+bfi)/GI40
+   ckQi2  = afi*GI11*iGI31
+   ckQi4  = 1./(cmi*GI40*iGI31)
+
+   ! Snow:
+   cexs1  = 2.5+0.5*bfs+alpha_s
+   cexs2  = 1.+alpha_s+dms
+   icexs2 = 1./cexs2
+   GS09   = gamma(2.5+bfs*0.5+alpha_s)
+   GS11   = gamma(1.+bfs+alpha_s)
+   GS12   = gamma(2.+bfs+alpha_s)
+   GS13   = gamma(3.+bfs+alpha_s)
+   GS31   = gamma(1.+alpha_s)
+   iGS31  = 1./GS31
+   GS32   = gamma(2.+alpha_s)
+   GS33   = gamma(3.+alpha_s)
+   GS34   = gamma(4.+alpha_s)
+   iGS34  = 1./GS34
+   GS35   = gamma(5.+alpha_s)
+   GS36   = gamma(6.+alpha_s)
+   GS40   = gamma(1.+alpha_s+dms)
+   iGS40  = 1./GS40
+   iGS20  = 1./(GS40*iGS31*cms)
+   ckQs1  = afs*gamma(1.+alpha_s+dms+bfs)*iGS40
+   ckQs2  = afs*GS11*iGS31
+   GS40_D3 = gamma(1.+alpha_s+3.)
+   iGS20_D3= 1./(GS40_D3*iGS31*cms_D3)
+   rfact_FvFm= PIov6*icms*gamma(4.+bfs+alpha_s)/gamma(1.+dms+bfs+alpha_s)
+
+   ! Graupel:
+   GG09   = gamma(2.5+0.5*bfg+alpha_g)
+   GG11   = gamma(1.+bfg+alpha_g)
+   GG12   = gamma(2.+bfg+alpha_g)
+   GG13   = gamma(3.+bfg+alpha_g)
+   GG31   = gamma(1.+alpha_g)
+   iGG31  = 1./GG31
+   GG32   = gamma(2.+alpha_g)
+   GG33   = gamma(3.+alpha_g)
+   GG34   = gamma(4.+alpha_g)
+   iGG34  = 1./GG34
+   GG35   = gamma(5.+alpha_g)
+   GG36   = gamma(6.+alpha_g)
+   GG40   = gamma(1.+alpha_g+dmg)
+   iGG99  = 1./(GG40*iGG31*cmg)
+   GG50   = (No_g_SM*GG31)**0.75     !for 1-moment only
+   ckQg1  = afg*gamma(1.+alpha_g+dmg+bfg)/GG40
+   ckQg2  = afg*GG11*iGG31
+   ckQg4  = 1./(cmg*GG40*iGG31)
+
+   ! Hail:
+   GH09   = gamma(2.5+bfh*0.5+alpha_h)
+   GH11   = gamma(1.+bfh+alpha_h)
+   GH12   = gamma(2.+bfh+alpha_h)
+   GH13   = gamma(3.+bfh+alpha_h)
+   GH31   = gamma(1.+alpha_h)
+   iGH31  = 1./GH31
+   GH32   = gamma(2.+alpha_h)
+   GH33   = gamma(3.+alpha_h)
+   iGH34  = 1./gamma(4.+alpha_h)
+   GH40   = gamma(1.+alpha_h+dmh)
+   iGH99  = 1./(GH40*iGH31*cmh)
+   GH50   = (No_h_SM*GH31)**0.75     !for 1-moment only
+   ckQh1  = afh*gamma(1.+alpha_h+dmh+bfh)/GH40
+   ckQh2  = afh*GH11*iGH31
+   ckQh4  = 1./(cmh*GH40*iGH31)
+
+  endif  !if (KOUNT=0)
+!####
+
+!=======================================================================================!
+
+  !Compute thickness of layers for sedimentation calcuation:
+  ! (note; 'GZ' passed in is geopotential, not geopotential height)
+  tmp1= 1./GRAV
+  do k=2,nk
+     DZ(:,k)= (GZ(:,k-1)-GZ(:,k))*tmp1
+  enddo
+  DZ(:,1)= DZ(:,2)
+
+! Temporarily store arrays at time (t*) in order to compute (at the end of subroutine)
+! the final VXTEND as VXTEND = ( VX{t+1} - VX{t*} )/dt :
+  T_TEND = T ;  Q_TEND = Q
+  QCTEND = QC;  QRTEND = QR;  QITEND = QI;  QNTEND = QN;  QGTEND = QG;  QHTEND = QH
+  NCTEND = NC;  NRTEND = NR;  NYTEND = NY;  NNTEND = NN;  NGTEND = NG;  NHTEND = NH
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+! Initialize Nx if Qx>0 and Nx=0:  (for nesting from 1-moment to 2-moment):
+  IF (initN) THEN
+     do k= 1,nk
+        do i= 1,ni
+           tmp1= S(i,k)*PSM(i)/(RGASD*TM(i,k))  !air density at time (t-1)
+           tmp2= S(i,k)*PS(i)/(RGASD*T(i,k))    !air density at time (*)
+
+        !cloud:
+           if (QCM(i,k)>epsQ .and. NCM(i,k)<epsN)                                        &
+              NCM(i,k)= N_c_SM
+           if (QC(i,k)>epsQ  .and. NC(i,k)<epsN)                                         &
+              NC(i,k) = N_c_SM
+        !rain
+           if (QRM(i,k)>epsQ .and. NRM(i,k)<epsN)                                        &
+              NRM(i,k)= (No_r_SM*GR31)**(3./(4.+alpha_r))*(GR31*iGR34*tmp1*QRM(i,k)*     &
+                        icmr)**((1.+alpha_r)/(4.+alpha_r))
+           if (QR(i,k)>epsQ  .and. NR(i,k)<epsN)                                         &
+              NR(i,k)= (No_r_SM*GR31)**(3./(4.+alpha_r))*(GR31*iGR34*tmp2*QR(i,k)*       &
+                       icmr)**((1.+alpha_r)/(4.+alpha_r))
+        !ice:
+           if (QIM(i,k)>epsQ .and. NYM(i,k)<epsN)                                        &
+              NYM(i,k)= N_Cooper(TRPL,TM(i,k))
+           if (QI(i,k)>epsQ  .and. NY(i,k)<epsN)                                         &
+              NY(i,k)= N_Cooper(TRPL,T(i,k))
+        !snow:
+           if (QNM(i,k)>epsQ .and. NNM(i,k)<epsN) then
+              No_s= Nos_Thompson(TRPL,TM(i,k))
+              NNM(i,k)= (No_s*GS31)**(dms*icexs2)*(GS31*iGS40*icms*tmp1*QNM(i,k))**      &
+                        ((1.+alpha_s)*icexs2)
+           endif
+           if (QN(i,k)>epsQ  .and. NN(i,k)<epsN)  then
+              No_s= Nos_Thompson(TRPL,T(i,k))
+              NN(i,k)= (No_s*GS31)**(dms*icexs2)*(GS31*iGS40*icms*tmp2*QN(i,k))**        &
+                       ((1.+alpha_s)*icexs2)
+           endif
+        !grpl:
+           if (QGM(i,k)>epsQ .and. NGM(i,k)<epsN)                                        &
+              NGM(i,k)= (No_g_SM*GG31)**(3./(4.+alpha_g))*(GG31*iGG34*tmp1*QGM(i,k)*     &
+                        icmg)**((1.+alpha_g)/(4.+alpha_g))
+           if (QG(i,k)>epsQ  .and. NG(i,k)<epsN)                                         &
+              NG(i,k)= (No_g_SM*GG31)**(3./(4.+alpha_g))*(GG31*iGG34*tmp2*QG(i,k)*       &
+                   icmg)**((1.+alpha_g)/(4.+alpha_g))
+        !hail:
+           if (QHM(i,k)>epsQ .and. NHM(i,k)<epsN)                                        &
+              NHM(i,k)= (No_h_SM*GH31)**(3./(4.+alpha_h))*(GH31*iGH34*tmp1*QHM(i,k)*     &
+                        icmh)**((1.+alpha_h)/(4.+alpha_h))
+           if (QH(i,k)>epsQ  .and. NH(i,k)<epsN)                                         &
+              NH(i,k)= (No_h_SM*GH31)**(3./(4.+alpha_h))*(GH31*iGH34*tmp2*QH(i,k)*       &
+                        icmh)**((1.+alpha_h)/(4.+alpha_h))
+
+        enddo !i-loop
+     enddo    !k-loop
+  ENDIF  !N-initialization
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+! Clip all moments to zero if one or more corresponding category moments are less than
+!  the minimum allowable value:
+! (Note: Clipped mass is added back to water vapor field to conserve total mass)
+  do k= 1,nk
+     do i= 1,ni
+
+       IF (dblMom_c) THEN
+         if(QC(i,k)<epsQ .or. NC(i,k)<epsN)    then
+            Q(i,k) = Q(i,k) + QC(i,k)
+            QC(i,k)= 0.;   NC(i,k)= 0.
+         endif
+         if(QCM(i,k)<epsQ .or. NCM(i,k)<epsN)  then
+            QM(i,k) = QM(i,k) + QCM(i,k)
+            QCM(i,k)= 0.;  NCM(i,k)= 0.
+         endif
+       ELSE
+         if(QC(i,k)<epsQ)    then
+            Q(i,k) = Q(i,k) + QC(i,k)
+            QC(i,k)= 0.
+         endif
+         if(QCM(i,k)<epsQ)  then
+            QM(i,k) = QM(i,k) + QCM(i,k)
+            QCM(i,k)= 0.
+         endif
+       ENDIF
+
+       IF (dblMom_r) THEN
+         if (QR(i,k)<epsQ .or. NR(i,k)<epsN)   then
+            Q(i,k) = Q(i,k) + QR(i,k)
+            QR(i,k)= 0.;  NR(i,k)= 0.
+         endif
+         if (QRM(i,k)<epsQ .or. NRM(i,k)<epsN) then
+            QM(i,k) = QM(i,k) + QRM(i,k)
+            QRM(i,k)= 0.;  NRM(i,k)= 0.
+         endif
+       ELSE
+         if (QR(i,k)<epsQ)   then
+            Q(i,k) = Q(i,k) + QR(i,k)
+            QR(i,k)= 0.
+         endif
+         if (QRM(i,k)<epsQ) then
+            QM(i,k) = QM(i,k) + QRM(i,k)
+            QRM(i,k)= 0.
+         endif
+       ENDIF
+
+       IF (dblMom_i) THEN
+         if (QI(i,k)<epsQ .or. NY(i,k)<epsN)   then
+            Q(i,k) = Q(i,k) + QI(i,k)
+            QI(i,k)= 0.;  NY(i,k)= 0.
+         endif
+         if (QIM(i,k)<epsQ .or. NYM(i,k)<epsN) then
+            QM(i,k) = QM(i,k) + QIM(i,k)
+            QIM(i,k)= 0.;  NYM(i,k)= 0.
+         endif
+       ELSE
+         if (QI(i,k)<epsQ)   then
+            Q(i,k) = Q(i,k) + QI(i,k)
+            QI(i,k)= 0.
+         endif
+         if (QIM(i,k)<epsQ) then
+            QM(i,k) = QM(i,k) + QIM(i,k)
+            QIM(i,k)= 0.
+         endif
+       ENDIF
+
+       IF (dblMom_s) THEN
+         if (QN(i,k)<epsQ .or. NN(i,k)<epsN)   then
+            Q(i,k) = Q(i,k) + QN(i,k)
+            QN(i,k)= 0.;  NN(i,k)= 0.
+         endif
+         if (QNM(i,k)<epsQ .or. NNM(i,k)<epsN) then
+            QM(i,k) = QM(i,k) + QNM(i,k)
+            QNM(i,k)= 0.;  NNM(i,k)= 0.
+         endif
+       ELSE
+         if (QN(i,k)<epsQ)   then
+            Q(i,k) = Q(i,k) + QN(i,k)
+            QN(i,k)= 0.
+         endif
+         if (QNM(i,k)<epsQ) then
+            QM(i,k) = QM(i,k) + QNM(i,k)
+            QNM(i,k)= 0.
+         endif
+       ENDIF
+
+       IF (dblMom_g) THEN
+         if (QG(i,k)<epsQ .or. NG(i,k)<epsN)   then
+            Q(i,k) = Q(i,k) + QG(i,k)
+            QG(i,k)= 0.;  NG(i,k)= 0.
+         endif
+         if (QGM(i,k)<epsQ  .or. NGM(i,k)<epsN) then
+            QM(i,k) = QM(i,k) + QGM(i,k)
+            QGM(i,k)= 0.;  NGM(i,k)= 0.
+         endif
+       ELSE
+         if (QG(i,k)<epsQ)   then
+            Q(i,k) = Q(i,k) + QG(i,k)
+            QG(i,k)= 0.
+         endif
+         if (QGM(i,k)<epsQ) then
+            QM(i,k) = QM(i,k) + QGM(i,k)
+            QGM(i,k)= 0.
+         endif
+       ENDIF
+
+       IF (dblMom_h) THEN
+         if (QH(i,k)<epsQ .or. NH(i,k)<epsN)   then
+            Q(i,k) = Q(i,k) + QH(i,k)
+            QH(i,k)= 0.;  NH(i,k)= 0.
+         endif
+         if (QHM(i,k)<epsQ .or. NHM(i,k)<epsN) then
+            QM(i,k) = QM(i,k) + QHM(i,k)
+            QHM(i,k)= 0.;  NHM(i,k)= 0.
+         endif
+       ELSE
+         if (QH(i,k)<epsQ)   then
+            Q(i,k) = Q(i,k) + QH(i,k)
+            QH(i,k)= 0.
+         endif
+         if (QHM(i,k)<epsQ) then
+            QM(i,k) = QM(i,k) + QHM(i,k)
+            QHM(i,k)= 0.
+         endif
+       ENDIF
+
+    enddo  !i-loop
+  enddo    !k-loop;    (clipping)
+  QM = max(QM,0.)
+  Q  = max(Q ,0.)
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+
+! Approximate values at time {t}:
+!  [ ave. of values at {*} (advected, but no physics tendency added) and {t-dt} ]:
+  HPS= 0.5*(PSM+PS);   TM = 0.5*(TM + T);   QM = 0.5*(QM + Q)
+  QCM= 0.5*(QCM+QC);   QRM= 0.5*(QRM+QR);   QIM= 0.5*(QIM+QI)
+  QNM= 0.5*(QNM+QN);   QGM= 0.5*(QGM+QG);   QHM= 0.5*(QHM+QH)
+
+  if (dblMom_c) NCM= 0.5*(NCM+NC)
+  if (dblMom_r) NRM= 0.5*(NRM+NR)
+  if (dblMom_i) NYM= 0.5*(NYM+NY)
+  if (dblMom_s) NNM= 0.5*(NNM+NN)
+  if (dblMom_g) NGM= 0.5*(NGM+NG)
+  if (dblMom_h) NHM= 0.5*(NHM+NH)
+
+  do k=1,nk
+     do i=1,ni
+!WRF:
+#if (DWORDSIZE == 8 && RWORDSIZE == 8)
+        QSW(i,k)=      FOQSA(TM(i,k),HPS(i)*S(i,k))       !wrt. liquid water at (t)
+        QSS(i,k)=      FOQST( T(i,k), PS(i)*S(i,k))       !wrt. ice surface  at (*)
+        QSI(i,k)=      FOQST(TM(i,k),HPS(i)*S(i,k))       !wrt. ice surface  at (t)
+#elif (DWORDSIZE == 8 && RWORDSIZE == 4)
+        QSW(i,k)= sngl(FOQSA(TM(i,k),HPS(i)*S(i,k)))      !wrt. liquid water at (t)
+        QSS(i,k)= sngl(FOQST( T(i,k), PS(i)*S(i,k)))      !wrt. ice surface  at (*)
+        QSI(i,k)= sngl(FOQST(TM(i,k),HPS(i)*S(i,k)))      !wrt. ice surface  at (t)
+#else
+!!     This is a temporary hack assuming double precision is 8 bytes.
+#endif
+      !Air density at time (t)
+        DE(i,k) = S(i,k)*HPS(i)/(RGASD*TM(i,k))           !air density at time  (t)
+        iDE(i,k)= 1./DE(i,k)
+     enddo
+  enddo
+
+  do i= 1,ni
+    !Air-density factor: (for fall velocity computations)
+     DEo           = DE(i,nk)
+     gamfact(i,:)  = sqrt(DEo/(DE(i,:)))
+     gamfact_r(i,:)= sqrt( 1./(DE(i,:)))
+    !Convert 'W_omega' (on thermodynamic levels) to 'w' (on momentum):
+     do k= 2,nk-1
+        WZ(i,k)= -0.5/(DE(i,k)*GRAV)*(W_omega(i,k-1)+W_omega(i,k+1))
+     enddo
+     WZ(i,1) = -0.5/(DE(i,1) *GRAV)*W_omega(i,1)
+     WZ(i,nk)= -0.5/(DE(i,nk)*GRAV)*W_omega(i,nk)
+  enddo
+
+  !----------------------------------------------------------------------------------!
+  !                 End of Preliminary Calculation section (Part 1)                  !
+  !----------------------------------------------------------------------------------!
+
+  !----------------------------------------------------------------------------------!
+  !                      PART 2: Cold Microphysics Processes                         !
+  !----------------------------------------------------------------------------------!
+
+! Determine the active grid points (i.e. those which scheme should treat):
+  activePoint = .false.
+  DO k=2,nk
+     DO i=1,ni
+        log1= ((QIM(i,k)+QGM(i,k)+QNM(i,k)+QHM(i,k))<epsQ)  !no solid  (i,g,s,h)
+        log2= ((QCM(i,k)+QRM(i,k))                  <epsQ)  !no liquid (c,r)
+        log3= ((TM(i,k)>TRPL) .and. log1)                   !T>0C & no i,g,s,h
+        log4= log1.and.log2.and.(QM(i,k)<QSI(i,k))          !no sol. or liq.; subsat(i)
+        if (.not.( log3 .or. log4 ) .and. icephase_ON) then
+          activePoint(i,k)= .true.
+        endif
+     ENDDO
+  ENDDO
+
+    ! Size distribution parameters:
+    !  Note: + 'thrd' should actually be '1/dmx'(but dmx=3 for all categories x)
+    !        + If Qx=0, LAMx etc. are never be used in any calculations
+    !          (If Qc=0, CLcy etc. will never be calculated. iLAMx is set to 0
+    !           to avoid possible problems due to bugs.)
+
+  DO k= 2,nk                       !Main loop for Part 2
+    DO i= 1,ni
+      IF (activePoint(i,k)) THEN
+
+
+       Tc= TM(i,k)-TRPL
+       if (Tc<-120. .or. Tc>50.)   &
+        print*, '***WARNING*** -- In MICROPHYSICS --  Ambient Temp.(C):',Tc
+       Cdiff = (2.2157e-5+0.0155e-5*Tc)*1.e5/(S(i,k)*HPS(i))
+       MUdyn = 1.72e-5*(393./(TM(i,k)+120.))*(TM(i,k)/TRPL)**1.5 !RYp.102
+       MUkin = MUdyn*iDE(i,k)
+       iMUkin= 1./MUkin
+       ScTHRD= (MUkin/Cdiff)**thrd       ! i.e. Sc^(1/3)
+       Ka    = 2.3971e-2 + 0.0078e-2*Tc                                   !therm.cond.(air)
+       Kdiff = (9.1018e-11*TM(i,k)*TM(i,k)+8.8197e-8*TM(i,k)-(1.0654e-5)) !therm.diff.(air)
+       gam   = gamfact(i,k)
+
+      !Collection efficiencies:
+       Eis   = min(0.05*exp(0.1*Tc),1.)     !Ferrier, 1995 (Table 1)
+       Eig   = min(0.01*exp(0.1*Tc),1.)     !dry (Eig=1.0 for wet growth)
+       Eii   = 0.1*Eis
+       Ess   = Eis;   Eih = Eig;   Esh = Eig
+       iEih  = 1./Eih
+       iEsh  = 1./Esh
+       !note:  Eri=Ers=Erh=1. (constant parameters)
+       !       - Ecs is computed in CLcs section
+       !       - Ech is computed in CLch section
+       !       - Ecg is computed in CLcg section
+       !       - Erg is computed in CLrg section
+
+!WRF:
+#if (DWORDSIZE == 8 && RWORDSIZE == 8)
+       qvs0  =      FOQSA(TRPL,HPS(i)*S(i,k))       !sat.mix.ratio at 0C
+#elif (DWORDSIZE == 8 && RWORDSIZE == 4)
+       qvs0  = sngl(FOQSA(TRPL,HPS(i)*S(i,k)))      !sat.mix.ratio at 0C
+#else
+!!     This is a temporary hack assuming double precision is 8 bytes.
+#endif
+       DELqvs= qvs0-(QM(i,k))
+
+    ! Cloud:
+       if (QCM(i,k)>epsQ) then
+          if (.not. dblMom_c) NCM(i,k)= N_c_SM
+          iQCM   = 1./QCM(i,k)
+          iNCM   = 1./NCM(i,k)
+          Dc     = Dm_x(DE(i,k),QCM(i,k),iNCM,icmr,thrd)
+
+          iLAMc  = iLAMDA_x(DE(i,k),QCM(i,k),iNCM,icexc9,thrd)
+          iLAMc2 = iLAMc *iLAMc
+          iLAMc3 = iLAMc2*iLAMc
+          iLAMc4 = iLAMc2*iLAMc2
+          iLAMc5 = iLAMc3*iLAMc2
+       else
+          Dc     = 0.;   iLAMc3= 0.
+          iLAMc  = 0.;   iLAMc4= 0.
+          iLAMc2 = 0.;   iLAMc5= 0.
+       endif
+
+    ! Rain:
+       if (QRM(i,k)>epsQ) then
+          if (.not. dblMom_r) NRM(i,k)= GR50*sqrt(sqrt(GR31*iGR34*DE(i,k)*QRM(i,k)*icmr))
+          iQRM   = 1./QRM(i,k)
+          iNRM   = 1./NRM(i,k)
+          Dr     = Dm_x(DE(i,k),QRM(i,k),iNRM,icmr,thrd)
+          iLAMr  = max( iLAMmin1, iLAMDA_x(DE(i,k),QRM(i,k),iNRM,icexr9,thrd) )
+          tmp1   = 1./iLAMr
+          iLAMr2 = iLAMr *iLAMr
+          iLAMr3 = iLAMr2*iLAMr
+          iLAMr4 = iLAMr2*iLAMr2
+          iLAMr5 = iLAMr3*iLAMr2
+          if (Dr>40.e-6) then
+             vr0 = gamfact_r(i,k)*ckQr1*iLAMr**bfr
+          else
+             vr0 = 0.
+          endif
+       else
+          iLAMr  = 0.;  Dr    = 0.;  vr0   = 0.
+          iLAMr2 = 0.;  iLAMr3= 0.;  iLAMr4= 0.;  iLAMr5 = 0.
+       endif
+
+    ! Ice:
+       if (QIM(i,k)>epsQ) then
+          if (.not. dblMom_i) NYM(i,k)= N_Cooper(TRPL,TM(i,k))
+
+          iQIM   = 1./QIM(i,k)
+          iNYM   = 1./NYM(i,k)
+          iLAMi  = max( iLAMmin2, iLAMDA_x(DE(i,k),QIM(i,k),iNYM,icexi9,thrd) )
+          iLAMi2 = iLAMi *iLAMi
+          iLAMi3 = iLAMi2*iLAMi
+          iLAMi4 = iLAMi2*iLAMi2
+          iLAMi5 = iLAMi3*iLAMi2
+          iLAMiB0= iLAMi**(bfi)
+          iLAMiB1= iLAMi**(bfi+1.)
+          iLAMiB2= iLAMi**(bfi+2.)
+          vi0    = gamfact(i,k)*ckQi1*iLAMiB0
+          Di     = Dm_x(DE(i,k),QIM(i,k),iNYM,icmi,thrd)
+       else
+          iLAMi  = 0.;  vi0    = 0.;  Di     = 0.
+          iLAMi2 = 0.;  iLAMi3 = 0.;  iLAMi4 = 0.;  iLAMi5= 0.
+          iLAMiB0= 0.;  iLAMiB1= 0.;  iLAMiB2= 0.
+       endif
+
+    ! Snow:
+       if (QNM(i,k)>epsQ) then
+          if (.not.dblMom_s) then
+             No_s_SM = Nos_Thompson(TRPL,TM(i,k))
+             NNM(i,k)= (No_s*GS31)**(dms*icexs2)*(GS31*iGS40*icms*DE(i,k)*QNM(i,k))**    &
+                       ((1.+alpha_s)*icexs2)
+          endif
+          iQNM   = 1./QNM(i,k)
+          iNNM   = 1./NNM(i,k)
+          iLAMs  = max( iLAMmin2, iLAMDA_x(DE(i,k),QNM(i,k),iNNM,iGS20,idms) )
+          iLAMs_D3= max(iLAMmin2, iLAMDA_x(DE(i,k),QNM(i,k),iNNM,iGS20_D3,thrd) )
+          iLAMs2 = iLAMs*iLAMs
+          iLAMsB0= iLAMs**(bfs)
+          iLAMsB1= iLAMs**(bfs+1.)
+          iLAMsB2= iLAMs**(bfs+2.)
+          vs0    = gamfact(i,k)*ckQs1*iLAMsB0
+          Ds     = min(DsMax, Dm_x(DE(i,k),QNM(i,k),iNNM,icms,idms))
+          if (snowSpherical) then
+             des = desFix
+          else
+             des = des_OF_Ds(Ds,desMax,eds,fds)
+          endif
+         !!-- generalized equations (any alpha_s):
+         !    No_s  = (NNM(i,k))*iGS31/iLAMs**(1.+alpha_s)
+         !    VENTs = Avx*GS32*iLAMs**(2.+alpha_s)+Bvx*ScTHRD*sqrt(gam*afs*iMUkin)*      &
+         !!--         GS09*iLAMs**(2.5+0.5*bfs+alpha_s)
+         !The following equations for No_s and VENTs is based on m(D)=(pi/6)*100.*D**3 for snow.
+         !  Strict application of m(D)=c*D**2 would require re-derivation using implied
+         !  definition of D as the MAXIMUM DIMENSION of an ellipsoid, rather than a sphere.
+         !  For simplicity, the m-D^3 relation is applied -- used for VDvs and MLsr only.
+         if (dblMom_s) then
+           !No_s= NNM(i,k)*iGS31/iLAMs     !optimized for alpha_s=0
+            No_s= NNM(i,k)*iGS31/iLAMs_D3  !based on m-D^3 (consistent with VENTs, below)
+         else
+            No_s= No_s_SM
+         endif
+         VENTs= Avx*GS32*iLAMs_D3**2. + Bvx*ScTHRD*sqrt(gamfact(i,k)*afs*iMUkin)*GS09*   &
+                iLAMs_D3**cexs1
+       else
+          iLAMs  = 0.;  vs0    = 0.;  Ds     = 0.;  iLAMs2= 0.
+          iLAMsB0= 0.;  iLAMsB1= 0.;  iLAMsB1= 0.
+          des    = desFix !used for 3-component freezing if QNM=0 (even for snowSpherical=.F.)
+       endif
+       ides  = 1./des
+
+
+    ! Graupel:
+       if (QGM(i,k)>epsQ) then
+          if (.not.dblMom_g) NGM(i,k)= GG50*sqrt(sqrt(GG31*GG34*DE(i,k)*QGM(i,k)*icmg))
+          iQGM   = 1./QGM(i,k)
+          iNGM   = 1./NGM(i,k)
+          iLAMg  = max( iLAMmin1, iLAMDA_x(DE(i,k),QGM(i,k),iNGM,iGG99,thrd) )
+          iLAMg2 = iLAMg *iLAMg
+          iLAMgB0= iLAMg**(bfg)
+          iLAMgB1= iLAMg**(bfg+1.)
+          iLAMgB2= iLAMg**(bfg+2.)
+          if (dblMom_g) then
+            !No_g = (NGM(i,k))*iGG31/iLAMg**(1.+alpha_g)
+             No_g= NGM(i,k)*iGG31/iLAMg     !optimized for alpha_g=0
+          else
+             No_g= No_g_SM
+          endif
+          vg0    = gamfact(i,k)*ckQg1*iLAMgB0
+          Dg     = Dm_x(DE(i,k),QGM(i,k),iNGM,icmg,thrd)
+       else
+          iLAMg  = 0.;  vg0    = 0.;  Dg     = 0.;  No_g   = 0.
+          iLAMg2 = 0.;  iLAMgB0= 0.;  iLAMgB1= 0.;  iLAMgB1= 0.
+       endif
+
+    ! Hail:
+       if (QHM(i,k)>epsQ) then
+          if (.not.dblMom_h) NHM(i,k)= GH50*sqrt(sqrt(GH31*iGH34*DE(i,k)*QHM(i,k)*icmh))
+          iQHM   = 1./QHM(i,k)
+          iNHM   = 1./NHM(i,k)
+          iLAMh  = max( iLAMmin1, iLAMDA_x(DE(i,k),QHM(i,k),iNHM,iGH99,thrd) )
+          iLAMh2 = iLAMh*iLAMh
+          iLAMhB0= iLAMh**(bfh)
+          iLAMhB1= iLAMh**(bfh+1.)
+          iLAMhB2= iLAMh**(bfh+2.)
+          if (dblMom_h) then
+               No_h= NHM(i,k)*iGH31/iLAMh**(1.+alpha_h)
+          else
+               No_h= No_h_SM
+          endif
+          vh0    = gamfact(i,k)*ckQh1*iLAMhB0
+          Dh     = Dm_x(DE(i,k),QHM(i,k),iNHM,icmh,thrd)
+       else
+          iLAMh  = 0.;  vh0    = 0.;  Dh     = 0.;  No_h= 0.
+          iLAMhB0= 0.;  iLAMhB1= 0.;  iLAMhB1= 0.
+       endif
+!------
+
+ !Calculating ice-phase source/sink terms:
+
+ ! Initialize all source terms to zero:
+       QNUvi=0.;  QVDvi=0.;  QVDvs=0.;  QVDvg=0.;  QVDvh=0.
+       QCLcs=0.;  QCLcg=0.;  QCLch=0.;  QFZci=0.;  QCLri=0.;   QMLsr=0.
+       QCLrs=0.;  QCLrg=0.;  QMLgr=0.;  QCLrh=0.;  QMLhr=0.;   QFZrh=0.
+       QMLir=0.;  QCLsr=0.;  QCLsh=0.;  QCLgr=0.;  QCNgh=0.
+       QCNis=0.;  QCLir=0.;  QCLis=0.;  QCLih=0.
+       QIMsi=0.;  QIMgi=0.;  QCNsg=0.;  QHwet=0.
+
+       NCLcs= 0.; NCLcg=0.;  NCLch=0.;  NFZci=0.;  NMLhr=0.;   NhCNgh=0.
+       NCLri= 0.; NCLrs=0.;  NCLrg=0.;  NCLrh=0.;  NMLsr=0.;   NMLgr=0.
+       NMLir= 0.; NSHhr=0.;  NNUvi=0.;  NVDvi=0.;  NVDvh=0.;   QCLig=0.
+       NCLir= 0.; NCLis=0.;  NCLig=0.;  NCLih=0.;  NIMsi=0.;   NIMgi=0.
+       NiCNis=0.; NsCNis=0.; NVDvs=0.;  NCNsg=0.;  NCLgr=0.;   NCLsrh=0.
+       NCLss= 0.; NCLsr=0.;  NCLsh=0.;  NCLsrs=0.; NCLgrg=0.;  NgCNgh=0.
+       NVDvg= 0.; NCLirg=0.; NCLsrg=0.; NCLgrh=0.; NrFZrh=0.;  NhFZrh=0.
+       NCLirh=0.
+
+       Dirg=0.; Dirh=0.; Dsrs= 0.; Dsrg= 0.; Dsrh= 0.; Dgrg=0.; Dgrh=0.
+
+   !-------------------------------------------------------------------------------------------!
+
+           ! COLLECTION by snow, graupel, hail:
+           !  (i.e. wet or dry ice-categories [=> excludes ice crystals])
+
+           ! Collection by SNOW:
+       if (QNM(i,k)>epsQ) then
+          ! cloud:
+          if (QCM(i,k)>epsQ) then
+
+            !Approximation of Ecs based on Pruppacher & Klett (1997) Fig. 14-11
+             Ecs= min(Dc,30.e-6)*3.333e+4*sqrt(min(Ds,1.e-3)*1.e+3)
+             QCLcs= dt*gam*afs*cmr*Ecs*PIov4*iDE(i,k)*(NCM(i,k)*NNM(i,k))*iGC5*iGS31*    &
+                    (GC13*GS13*iLAMc3*iLAMsB2+2.*GC14*GS12*iLAMc4*iLAMsB1+GC15*GS11*     &
+                    iLAMc5*iLAMsB0)
+
+             NCLcs= dt*gam*afs*PIov4*Ecs*(NCM(i,k)*NNM(i,k))*iGC5*iGS31*(GC5*GS13*       &
+                    iLAMsB2+2.*GC11*GS12*iLAMc*iLAMsB1+GC12*GS11*iLAMc2*iLAMsB0)
+
+            !continuous collection: (alternative; gives values ~0.95 of SCE [above])
+            !QCLcs= dt*gam*Ecs*PIov4*afs*QCM(i,k)*NNM(i,k)*iLAMs**(2.+bfs)*GS13*iGS31
+            !NCLcs= QCLcs*NCM(i,k)/QCM(i,k)
+
+            !Correction factor for non-spherical snow [D = maximum dimension] which
+            !changes projected area:   [assumption: A=0.50*D**2 (vs. A=(PI/4)*D**2)]
+            ! note: Strictly speaking, this correction should only be applied to
+            !       continuous growth approximation for cloud.  [factor = 0.50/(pi/4)]
+             if (.not. snowSpherical) then
+                tmp1 = 0.6366      !factor = 0.50/(pi/4)
+                QCLcs= tmp1*QCLcs
+                NCLcs= tmp1*NCLcs
+             endif
+
+             QCLcs= min(QCLcs, QCM(i,k))
+             NCLcs= min(NCLcs, NCM(i,k))
+          else
+             QCLcs= 0.;   NCLcs= 0.
+          endif
+
+          ! ice:
+          if (QIM(i,k)>epsQ) then
+             tmp1= vs0-vi0
+             tmp3= sqrt(tmp1*tmp1+0.04*vs0*vi0)
+
+             QCLis= dt*cmi*iDE(i,k)*PI*6.*Eis*(NYM(i,k)*NNM(i,k))*tmp3*iGI31*iGS31*(0.5* &
+                    iLAMs2*iLAMi3+2.*iLAMs*iLAMi4+5.*iLAMi5)
+
+             NCLis= dt*PIov4*Eis*(NYM(i,k)*NNM(i,k))*GI31*GS31*tmp3*(GI33*GS31*iLAMi2+   &
+                    2.*GI32*GS32*iLAMi*iLAMs+GI31*GS33*iLAMs2)
+
+             QCLis= min(QCLis, (QIM(i,k)))
+             NCLis= min(QCLis*(NYM(i,k)*iQIM), NCLis)
+          else
+             QCLis= 0.;   NCLis= 0.
+          endif
+
+          if (dblMom_s) then
+             !snow: (i.e. self-collection [aggregation])
+             NCLss= dt*0.93952*Ess*(DE(i,k)*(QNM(i,k)))**((2.+bfs)*thrd)*(NNM(i,k))**    &
+                    ((4.-bfs)*thrd)
+               !Note: 0.91226 = I(bfs)*afs*PI^((1-bfs)/3)*des^((-2-bfs)/3); I(bfs=0.41)=1138
+               !      0.93952 = I(bfs)*afs*PI^((1-bfs)/3)*des^((-2-bfs)/3); I(bfs=0.42)=1172
+               !      [interpolated from 3rd-order polynomial approx. of values given in RRB98;
+               !       see eqn(A.35)]
+             NCLss= min(NCLss, 0.5*(NNM(i,k)))
+          endif
+
+       else
+          QCLcs= 0.;   NCLcs= 0.;   QCLis= 0.;   NCLis= 0.;  NCLss= 0.
+       endif
+
+       ! Collection by GRAUPEL:
+       if (QGM(i,k)>epsQ) then
+
+          ! cloud:
+          if (QCM(i,k)>epsQ) then
+
+            !(parameterization of Ecg based on Cober and List, 1993 [JAS])
+             Kstoke = dew*vg0*Dc*Dc/(9.*MUdyn*Dg)
+             Kstoke = max(1.5,min(10.,Kstoke))
+             Ecg    = 0.55*log10(2.51*Kstoke)
+
+             QCLcg= dt*gam*afg*cmr*Ecg*PIov4*iDE(i,k)*(NCM(i,k)*NGM(i,k))*iGC5*iGG31*    &
+                    (GC13*GG13*iLAMc3*iLAMgB2+ 2.*GC14*GG12*iLAMc4*iLAMgB1+GC15*GG11*    &
+                    iLAMc5*iLAMgB0)
+
+             NCLcg= dt*gam*afg*PIov4*Ecg*(NCM(i,k)*NGM(i,k))*iGC5*iGG31*(GC5*GG13*       &
+                    iLAMgB2+2.*GC11*GG12*iLAMc*iLAMgB1+GC12*GG11*iLAMc2*iLAMgB0)
+
+             QCLcg= min(QCLcg, (QCM(i,k)))
+             NCLcg= min(NCLcg, (NCM(i,k)))
+          else
+             QCLcg= 0.;   NCLcg= 0.
+          endif
+
+          ! ice:
+          if (QIM(i,k)>epsQ) then
+             tmp1= vg0-vi0
+             tmp3= sqrt(tmp1*tmp1+0.04*vg0*vi0)
+
+             QCLig= dt*cmi*iDE(i,k)*PI*6.*Eig*(NYM(i,k)*NGM(i,k))*tmp3*iGI31*iGG31*(0.5* &
+                    iLAMg2*iLAMi3+2.*iLAMg*iLAMi4+5.*iLAMi5)
+             NCLig= dt*PIov4*Eig*(NYM(i,k)*NGM(i,k))*GI31*GG31*tmp3*(GI33*GG31*iLAMi2+   &
+                    2.*GI32*GG32*iLAMi*iLAMg+GI31*GG33*iLAMg2)
+
+             QCLig= min(QCLig, (QIM(i,k)))
+             NCLig= min(QCLig*(NYM(i,k)*iQIM), NCLig)
+          else
+             QCLig= 0.;   NCLig= 0.
+          endif
+
+       else
+          QCLcg= 0.;   QCLrg= 0.;   QCLig= 0.
+          NCLcg= 0.;   NCLrg= 0.;   NCLig= 0.
+       endif
+
+       ! Collection by HAIL:
+       if (QHM(i,k)>epsQ) then
+
+         ! cloud:
+          if (QCM(i,k)>epsQ) then
+             Ech  = exp(-8.68e-7*Dc**(-1.6)*Dh)    !Ziegler (1985) A24
+
+             QCLch= dt*gam*afh*cmr*Ech*PIov4*iDE(i,k)*(NCM(i,k)*NHM(i,k))*iGC5*iGH31*    &
+                    (GC13*GH13*iLAMc3*iLAMhB2+2.*GC14*GH12*iLAMc4*iLAMhB1+GC15*GH11*     &
+                    iLAMc5*iLAMhB0)
+
+             NCLch= dt*gam*afh*PIov4*Ech*(NCM(i,k)*NHM(i,k))*iGC5*iGH31*(GC5*GH13*       &
+                    iLAMhB2+2.*GC11*GH12*iLAMc*iLAMhB1+GC12*GH11*iLAMc2*iLAMhB0)
+
+             QCLch= min(QCLch, QCM(i,k))
+             NCLch= min(NCLch, NCM(i,k))
+          else
+             QCLch= 0.;   NCLch= 0.
+          endif
+
+          ! rain:
+          if (QRM(i,k)>epsQ) then
+             tmp1= vh0-vr0
+             tmp3= sqrt(tmp1*tmp1+0.04*vh0*vr0)
+             QCLrh= dt*cmr*Erh*PIov4*iDE(i,k)*(NHM(i,k)*NRM(i,k))*iGR31*iGH31*tmp3*      &
+                    (GR36*GH31*iLAMr5+2.*GR35*GH32*iLAMr4*iLAMh+GR34*GH33*iLAMr3*iLAMh2)
+
+             NCLrh= dt*PIov4*Erh*(NHM(i,k)*NRM(i,k))*iGR31*iGH31*tmp3*(GR33*GH31*        &
+                    iLAMr2+2.*GR32*GH32*iLAMr*iLAMh+GR31*GH33*iLAMh2)
+
+             QCLrh= min(QCLrh, QRM(i,k))
+             NCLrh= min(NCLrh, QCLrh*(NRM(i,k)*iQRM))
+          else
+             QCLrh= 0.;   NCLrh= 0.
+          endif
+
+          ! ice:
+          if (QIM(i,k)>epsQ) then
+             tmp1 = vh0-vi0
+             tmp3 = sqrt(tmp1*tmp1+0.04*vh0*vi0)
+
+             QCLih= dt*cmi*iDE(i,k)*PI*6.*Eih*(NYM(i,k)*NHM(i,k))*tmp3*iGI31*iGH31*(0.5* &
+                    iLAMh2*iLAMi3+2.*iLAMh*iLAMi4+5.*iLAMi5)
+
+             NCLih= dt*PIov4*Eih*(NYM(i,k)*NHM(i,k))*GI31*GH31*tmp3*(GI33*GH31*iLAMi2+   &
+                    2.*GI32*GH32*iLAMi*iLAMh+GI31*GH33*iLAMh2)
+
+             QCLih= min(QCLih, QIM(i,k))
+             NCLih= min(QCLih*(NYM(i,k)*iQIM), NCLih)
+          else
+             QCLih= 0.;   NCLih= 0.
+          endif
+
+          ! snow:
+          if (QNM(i,k)>epsQ) then
+             tmp1 = vh0-vs0
+             tmp3 = sqrt(tmp1*tmp1+0.04*vh0*vs0)
+             tmp4 = iLAMs2*iLAMs2
+
+             if (snowSpherical) then
+               !hardcoded for dms=3:
+                QCLsh= dt*cms*iDE(i,k)*PI*6.*Esh*(NNM(i,k)*NHM(i,k))*tmp3*iGS31*iGH31*  &
+                       (0.5*iLAMh2*iLAMs2*iLAMs+2.*iLAMh*tmp4+5.*tmp4*iLAMs)
+             else
+               !hardcoded for dms=2:
+                QCLsh= dt*cms*iDE(i,k)*PI*0.25*Esh*tmp3*NNM(i,k)*NHM(i,k)*iGS31*iGH31*  &
+                       (GH33*GS33*iLAMh**2.*iLAMs**2. + 2.*GH32*GS34*iLAMh*iLAMs**3. +  &
+                        GH31*GS35*iLAMs**4.)
+             endif
+
+             NCLsh= dt*PIov4*Esh*(NNM(i,k)*NHM(i,k))*GS31*GH31*tmp3*(GS33*GH31*iLAMs2+  &
+                    2.*GS32*GH32*iLAMs*iLAMh+GS31*GH33*iLAMh2)
+
+             QCLsh= min(QCLsh, (QNM(i,k)))
+             NCLsh= min((NNM(i,k)*iQNM)*QCLsh, NCLsh, (NNM(i,k)))
+          else
+             QCLsh= 0.;   NCLsh= 0.
+          endif
+
+         !wet growth:
+          VENTh= Avx*GH32*iLAMh**(2.+alpha_h) + Bvx*ScTHRD*sqrt(gam*afh*iMUkin)*GH09*    &
+                 iLAMh**(2.5+0.5*bfh+alpha_h)
+          QHwet= max(0., dt*PI2*(DE(i,k)*CHLC*Cdiff*DELqvs-Ka*Tc)*No_h*iDE(i,k)/(CHLF+   &
+                 CPW*Tc)*VENTh+(QCLih*iEih+QCLsh*iEsh)*(1.-CPI*Tc/(CHLF+CPW*Tc)) )
+
+       else
+          QCLch= 0.;   QCLrh= 0.;   QCLih= 0.;   QCLsh= 0.;   QHwet= 0.
+          NCLch= 0.;   NCLrh= 0.;   NCLsh= 0.;   NCLih= 0.
+       endif
+
+       IF (TM(i,k)>TRPL .and. warmphase_ON) THEN
+          !**********!
+          !  T > To  !
+          !**********!
+
+          ! MELTING of frozen particles:
+          !  ICE:
+          QMLir   = QIM(i,k)  !all pristine ice melts in one time step
+          QIM(i,k)= 0.
+          NMLir   = NYM(i,k)
+
+          !  SNOW:
+          if (QNM(i,k)>epsQ) then
+             QMLsr= dt*(PI2*iDE(i,k)*iCHLF*No_s*VENTs*(Ka*Tc-CHLC*Cdiff*DELqvs) + CPW*   &
+                    iCHLF*Tc*(QCLcs+QCLrs)*idt)
+             QMLsr= min(max(QMLsr,0.), QNM(i,k))
+             NMLsr= NNM(i,k)*iQNM*QMLsr
+          else
+             QMLsr= 0.;   NMLsr= 0.
+          endif
+
+          !  GRAUPEL:
+          if (QGM(i,k)>epsQ) then
+             VENTg= Avx*GG32*iLAMg*iLAMg+Bvx*ScTHRD*sqrt(gam*afg*iMUkin)*GG09*iLAMg**    &
+                    (2.5+0.5*bfg+alpha_g)
+             QMLgr= dt*(PI2*iDE(i,k)*iCHLF*No_g*VENTg*(Ka*Tc-CHLC*Cdiff*DELqvs) + CPW*   &
+                    iCHLF*Tc*(QCLcg+QCLrg)*idt)
+             QMLgr= min(max(QMLgr,0.), QGM(i,k))
+             NMLgr= NGM(i,k)*iQGM*QMLgr
+          else
+             QMLgr= 0.;   NMLgr= 0.
+          endif
+
+          !  HAIL:
+          if (QHM(i,k)>epsQ.and.Tc>5.) then
+             VENTh= Avx*GH32*iLAMh**(2.+alpha_h) + Bvx*ScTHRD*sqrt(gam*afh*iMUkin)*GH09* &
+                    iLAMh**(2.5+0.5*bfh+alpha_h)
+             QMLhr= dt*(PI2*iDE(i,k)*iCHLF*No_h*VENTh*(Ka*Tc-CHLC*Cdiff*DELqvs) + CPW/   &
+                    CHLF*Tc*(QCLch+QCLrh)*idt)
+             QMLhr= min(max(QMLhr,0.), QHM(i,k))
+             NMLhr= NHM(i,k)*iQHM*QMLhr
+             if(QCLrh>0.) NMLhr= NMLhr*0.1   !Prevents problems when hail is ML & CL
+          else
+             QMLhr= 0.;   NMLhr= 0.
+          endif
+
+         ! Cold (sub-zero) source/sink terms:
+          QNUvi= 0.;   QFZci= 0.;   QVDvi= 0.;   QVDvs= 0.;   QVDvg= 0.
+          QCLis= 0.;   QCNis1=0.;   QCNis2=0.
+          QCNgh= 0.;   QIMsi= 0.;   QIMgi= 0.;   QCLir= 0.;   QCLri= 0.
+          QCLrs= 0.;   QCLgr= 0.;   QCLrg= 0.;   QCNis= 0.;   QVDvh= 0.
+          QCNsg= 0.;   QCLsr= 0.
+
+          NNUvi= 0.;   NFZci= 0.;   NCLgr= 0.;   NCLrg= 0.;   NgCNgh= 0.
+          NCLis= 0.;   NVDvi= 0.;   NVDvs= 0.;   NVDvg= 0.;   NVDvh= 0.
+          NCNsg= 0.;   NhCNgh= 0.;  NiCNis=0.;   NsCNis=0.;   NCLrs= 0.
+          NIMsi= 0.;   NIMgi= 0.;   NCLir= 0.;   NCLri= 0.;   NCLsr= 0.
+
+       ELSE
+          !----------!
+          !  T < To  !
+          !----------!
+          tmp1  = 1./QSI(i,k)
+          Si    = QM(i,k) *tmp1
+          tmp2  = TM(i,k)*TM(i,k)
+          iABi  = 1./( CHLS*CHLS/(Ka*RGASV*tmp2) + 1./(DE(i,k)*(QSI(i,k))*Cdiff) )
+
+          ! Warm-air-only source/sink terms:
+          QMLir= 0.;   QMLsr= 0.;   QMLgr= 0.;   QMLhr= 0.
+          NMLir= 0.;   NMLsr= 0.;   NMLgr= 0.;   NMLhr= 0.
+
+          !Probabilistic freezing (Bigg) of rain:
+          if (Tc<Tc_FZrh .and. QRM(i,k)>epsQ .and. hail_ON) then
+             !note: - (Tc<-10.C) condition is based on Pruppacher-Klett (1997) Fig. 9-41
+             !      - Small raindrops will freeze to hail. However, if after all S/S terms
+             !        are added Dh<Dh_min, then hail will be converted to graupel. Thus,
+             !        probabilistic freezing of small rain is effectively a source of graupel.
+             NrFZrh= -dt*Bbigg*(exp(Abigg*Tc)-1.)*DE(i,k)*QRM(i,k)*idew
+             Rz= 1.  !N and Z (and Q) are conserved for FZrh with triple-moment
+           ! The Rz factor serves to conserve reflectivity when a rain distribution
+           !  converts to an distribution with a different shape parameter, alpha.
+           !  (e.g. when rain freezes to hail)  The factor Rz non-conserves N while
+           !  acting to conserve Z for double-moment.  See Ferrier, 1994 App. D)
+           ! Rz= (gamma(7.d0+alpha_h)*GH31*GR34*GR34)/(GR36(i,k)*GR31*   &
+           !      gamma(4.d0+alpha_h)*gamma(4.d0+alpha_h))
+             NhFZrh= Rz*NrFZrh
+             QFZrh = NrFZrh*(QRM(i,k)*iNRM)
+          else
+             QFZrh= 0.;   NrFZrh= 0.;  NhFZrh= 0.
+          endif
+
+          !--------!
+          !  ICE:  !
+          !--------!
+          ! Homogeneous freezing of cloud to ice:
+          if (dblMom_c) then
+             if (QCM(i,k)>epsQ) then
+                tmp2  = Tc*Tc; tmp3= tmp2*Tc; tmp4= tmp2*tmp2
+                JJ    = (10.**max(-20.,(-606.3952-52.6611*Tc-1.7439*tmp2-0.0265*tmp3-    &
+                         1.536e-4*tmp4)))
+                tmp1  = 1.e6*(DE(i,k)*(QCM(i,k)*iNCM)*icmr) !i.e. Dc[cm]**3
+                FRAC  = 1.-exp(-JJ*PIov6*tmp1*dt)
+                if (Tc>-30.) FRAC= 0.
+                if (Tc<-50.) FRAC= 1.
+                QFZci= FRAC*QCM(i,k)
+                NFZci= FRAC*NCM(i,k)
+             else
+                QFZci= 0.;   NFZci= 0.
+             endif
+          else
+             !Homogeneous freezing of cloud to ice:  (simplified)
+             if (QCM(i,k)>epsQ .and. Tc<-35.) then
+                FRAC= 1.  !if T<-35
+                QFZci= FRAC*QCM(i,k)
+                NFZci= FRAC*N_c_SM
+             else
+                QFZci= 0.;   NFZci= 0.
+             endif
+          endif
+
+          if (dblMom_i) then
+            !Primary ice nucleation:
+            NNUvi= 0.;   QNUvi= 0.
+            if (primIceNucl==1) then
+
+               NuDEPSOR= 0.;   NuCONT= 0.
+               Simax   = min(Si, SxFNC(WZ(i,k),Tc,HPS(i)*S(i,k),QSW(i,k),QSI(i,k),CCNtype, &
+                              2))
+               tmp1    = T(i,k)-7.66
+               NNUmax  = max(0., DE(i,k)/mio*(Q(i,k)-QSS(i,k))/(1.+ck6*(QSS(i,k)/(tmp1*    &
+                        tmp1))))
+               !Deposition/sorption nucleation:
+               if (Tc<-5. .and. Si>1.) then
+                  NuDEPSOR= max(0., 1.e3*exp(12.96*(Simax-1.)-0.639)-(NYM(i,k))) !Meyers(1992)
+               endif
+               !Contact nucleation:
+               if (QCM(i,k)>epsQ .and. Tc<-2.) then
+                  GG     =  1.*idew/(RGASV*(TM(i,k))/((QSW(i,k)*HPS(i)*S(i,k))/EPS1)/      &
+                              Cdiff+CHLC/Ka/(TM(i,k))*(CHLC/RGASV/(TM(i,k))-1.))  !CP00a
+                  Swmax  =  SxFNC(WZ(i,k),Tc,HPS(i)*S(i,k),QSW(i,k),QSI(i,k),CCNtype,1)
+                  ssat   =  min((QM(i,k)/QSW(i,k)), Swmax) -1.
+                  Tcc    =  Tc + GG*ssat*CHLC/Kdiff                            !C86_eqn64
+                  Na     =  exp(4.11-0.262*Tcc)                                !W95_eqn60/M92_2.6
+                  Kn     =  LAMa0*(TM(i,k))*p0/(T0*(HPS(i)*S(i,k))*Ra)         !W95_eqn59
+                  PSIa   =  -kBoltz*Tcc/(6.*pi*Ra*MUdyn)*(1.+Kn)               !W95_eqn58
+                  ft     =  0.4*(1.+1.45*Kn+0.4*Kn*exp(-1./Kn))*(Ka+2.5*Kn*KAPa)/          &
+                           (1.+3.*Kn)/(2.*Ka+5.*KAPa*Kn+KAPa)                  !W95_eqn57
+                  Dc     =  (DE(i,k)*(QCM(i,k)*iNCM)*icmr)**thrd
+                  F1     =  PI2*Dc*Na*(NCM(i,k))                               !W95_eqn55
+                  F2     =  Ka/(HPS(i)*S(i,k))*(Tc-Tcc)                        !W95_eqn56
+                  NuCONTA= -F1*F2*RGASV*(TM(i,k))/CHLC*iDE(i,k)                !diffusiophoresis
+                  NuCONTB=  F1*F2*ft*iDE(i,k)                                  !thermeophoresis
+                  NuCONTC=  F1*PSIa                                            !Brownian diffusion
+                  NuCONT =  max(0.,(NuCONTA+NuCONTB+NuCONTC)*dt)
+               endif
+               !Total primary ice nucleation:
+               if (icephase_ON) then
+                  NNUvi= min(NNUmax, NuDEPSOR + NuCONT )
+                  QNUvi= mio*iDE(i,k)*NNUvi
+                  QNUvi= min(QNUvi,(Q(i,k)))
+               endif
+
+            elseif (primIceNucl==2) then
+               if (Tc<-5. .and. Si>1.08) then !following Thompson etal (2006)
+                  NNUvi= max(N_Cooper(TRPL,T(i,k))-NYM(i,k),0.)
+                  QNUvi= min(mio*iDE(i,k)*NNUvi, Q(i,k))
+               endif
+           !elseif (primIceNucl==3) then
+           !! (for alternative [future] ice nucleation parameterizations)
+           !   NNUvi=...
+           !   QNUvi=...
+            endif !if (primIceNucl==1)
+
+          else !dblMom_i
+          !Ice initiation (single-moment):
+             if (QIM(i,k)<=epsQ .and. Tc<-5. .and. Si>1.08) then !following Thompson etal (2006)
+                NNUvi = N_Cooper(TRPL,T(i,k))
+                QNUvi= mio*iDE(i,k)*NNUvi
+                QNUvi= min(QNUvi,Q(i,k))
+             endif
+          endif !dblMom_i
+
+
+          IF (QIM(i,k)>epsQ) THEN
+
+             !Deposition/sublimation:
+!            No_i  = NYM(i,k)*iGI31/iLAMi**(1.+alpha_i)
+!            VENTi= Avx*GI32*iLAMi**(2.+alpha_i)+Bvx*ScTHRD*sqrt(gam*afi*iMUkin)*GI6*    &
+!                     iLAMi**(2.5+0.5*bfi+alpha_i)
+             No_i  = NYM(i,k)*iGI31/iLAMi    !optimized for alpha_i=0
+             VENTi= Avx*GI32*iLAMi*iLAMi+Bvx*ScTHRD*sqrt(gam*afi*iMUkin)*GI6*iLAMi**     &
+                    (2.5+0.5*bfi+alpha_i)
+            !Note: ice crystal capacitance is implicitly C = 0.5*D*capFact_i
+             QVDvi= dt*capFact_i*iABi*(PI2*(Si-1.)*No_i*VENTi)
+
+             ! Prevent overdepletion of vapor:
+             tmp1  = T(i,k)-7.66
+             VDmax = (Q(i,k)-QSS(i,k))/(1.+ck6*(QSS(i,k))/(tmp1*tmp1))
+             if(Si>=1.) then
+                QVDvi= min(max(QVDvi,0.),VDmax)
+             else
+                if (VDmax<0.) QVDvi= max(QVDvi,VDmax)
+               !IF prevents subl.(QVDvi<0 at t) changing to dep.(VDmax>0 at t*)  2005-06-28
+             endif
+             if (.not. iceDep_ON) QVDvi= 0. !suppresses depositional growth
+             NVDvi= min(0., (NYM(i,k)*iQIM)*QVDvi) !dNi/dt=0 for deposition
+
+             ! Conversion to snow:
+             !   +depostion of ice:
+             mi= DE(i,k)*(QIM(i,k)*iNYM)
+             if (mi<=0.5*mso.and.abs(0.5*mso-mi)>1.e-20) then
+                QCNis1= (mi/(mso-mi))*QVDvi
+             else
+                QCNis1= QVDvi + (1.-0.5*mso/mi)*QIM(i,k)
+             endif
+             QCNis1= max(0., QCNis1)
+             !   +aggregation of ice:
+             if(Di<0.5*Dso) then
+                Ki    = PIov6*Di*Di*vi0*Eii*Xdisp
+                tmp1  = log(Di/Dso)
+                tmp2  = tmp1*tmp1*tmp1
+                QCNis2= -dt*0.5*(QIM(i,k)*NYM(i,k))*Ki/tmp2
+             else
+                Ki= 0.;   QCNis2= 0.
+             endif
+             !   +total conversion rate:
+             QCNis = QCNis1 + QCNis2
+             NsCNis= DE(i,k)*imso*QCNis                               !source for snow (Ns)
+             NiCNis= (DE(i,k)*imso*QCNis1 + 0.5*Ki*NYM(i,k)*NYM(i,k)) !sink for ice (Ni)
+             NiCNis= min(NiCNis, NYM(i,k)*0.1) !Prevents overdepl. of NY when final QI>0
+
+             if (.not.(snow_ON)) then
+                QCNis= 0.; NiCNis= 0.; NsCNis= 0.  !Suppress SNOW initiation
+             endif
+
+             ! 3-component freezing (collisions with rain):
+             if (QRM(i,k)>epsQ .and. QIM(i,k)>epsQ) then
+                tmp1 = vr0-vi0
+                tmp3 = sqrt(tmp1*tmp1+0.04*vr0*vi0)
+
+                QCLir= dt*cmi*Eri*PIov4*iDE(i,k)*(NRM(i,k)*NYM(i,k))*iGI31*iGR31*tmp3*   &
+                       (GI36*GR31*iLAMi5+2.*GI35*GR32*iLAMi4*iLAMr+GI34*GR33*iLAMi3*     &
+                       iLAMr2)
+
+                NCLri= dt*PIov4*Eri*(NRM(i,k)*NYM(i,k))*iGI31*iGR31*tmp3*(GI33*GR31*     &
+                       iLAMi2+2.*GI32*GR32*iLAMi*iLAMr+GI31*GR33*iLAMr2)
+
+                QCLri= dt*cmr*Eri*PIov4*iDE(i,k)*(NYM(i,k)*NRM(i,k))*iGR31*iGI31*tmp3*   &
+                       (GR36*GI31 *iLAMr5+2.*GR35*GI32*iLAMr4*iLAMi+GR34*GI33*iLAMr3*    &
+                       iLAMi2)
+
+               !note: For explicit eqns, both NCLri and NCLir are mathematically identical)
+                NCLir= min(QCLir*(NYM(i,k)*iQIM), NCLri)
+                QCLri= min(QCLri, (QRM(i,k)));  QCLir= min(QCLir, (QIM(i,k)))
+                NCLri= min(NCLri, (NRM(i,k)));  NCLir= min(NCLir, (NYM(i,k)))
+
+                !Determine destination of 3-comp.freezing:
+                tmp1= max(Di,Dr)
+                dey= (dei*Di*Di*Di+dew*Dr*Dr*Dr)/(tmp1*tmp1*tmp1)
+                if (dey>0.5*(deg+deh) .and. Dr>Dr_3cmpThrs .and. hail_ON) then
+                   Dirg= 0.;  Dirh= 1.
+                else
+                   Dirg= 1.;  Dirh= 0.
+                endif
+                if (.not. grpl_ON) Dirg= 0.
+
+             else
+                QCLir= 0.;  NCLir= 0.;  QCLri= 0.
+                NCLri= 0.;  Dirh = 0.;  Dirg= 0.
+             endif
+
+             !  Rime-splintering (ice multiplication):
+             ff= 0.
+             if(Tc>=-8..and.Tc<=-5.) ff= 3.5e8*(Tc +8.)*thrd
+             if(Tc> -5..and.Tc< -3.) ff= 3.5e8*(-3.-Tc)*0.5
+             NIMsi= DE(i,k)*ff*QCLcs
+             NIMgi= DE(i,k)*ff*QCLcg
+             QIMsi= mio*iDE(i,k)*NIMsi
+             QIMgi= mio*iDE(i,k)*NIMgi
+
+          ELSE
+
+             QVDvi= 0.;  QCNis= 0.
+             QIMsi= 0.;  QIMgi= 0.;   QCLri= 0.;   QCLir= 0.
+             NVDvi= 0.;  NCLir= 0.;   NIMsi= 0.
+             NiCNis=0.;  NsCNis=0.;   NIMgi= 0.;   NCLri= 0.
+
+          ENDIF
+          !---------!
+          !  SNOW:  !
+          !---------!
+          IF (QNM(i,k)>epsQ) THEN
+
+            !Deposition/sublimation:
+             !note: - snow crystal capacitance is implicitly C = 0.5*D*capFact_s
+             !      - No_s and VENTs are computed above
+             QVDvs = dt*capFact_s*iABi*(PI2*(Si-1.)*No_s*VENTs - CHLS*CHLF/(Ka*RGASV*    &
+                     TM(i,k)*TM(i,k))*QCLcs*idt)
+
+             ! Prevent overdepletion of vapor:
+             tmp1  = T(i,k)-7.66
+             VDmax = (Q(i,k)-QSS(i,k))/(1.+ck6*(QSS(i,k))/(tmp1*tmp1))  !KY97_A.33
+             if(Si>=1.) then
+                QVDvs= min(max(QVDvs,0.),VDmax)
+             else
+                if (VDmax<0.) QVDvs= max(QVDvs,VDmax)
+                !IF prevents subl.(QVDvs<0 at t) changing to dep.(VDmax>0 at t*)
+             endif
+             NVDvs= -min(0.,(NNM(i,k)*iQNM)*QVDvs)  !pos. quantity
+
+             ! Conversion to graupel:
+             if (QCLcs>CNsgThres*QVDvs .and. 0.99*deg>des) then
+               !note: The (deg>des) condition equates to (Ds>330microns) for m(D)=0.069D^2
+               !      relation for snow, which implies a variable bulk density.  The physical
+               !      assumption in the QCNsg equation is that snow converts to graupel due
+               !      to densification from riming.
+               !      The 0.99 is to prevent overflow if des~deg
+                QCNsg= (deg/(deg-des))*QCLcs
+             else
+                QCNsg= 0.
+             endif
+             if (.not. grpl_ON) QCNsg= 0.
+             NCNsg= DE(i,k)*imgo*QCNsg
+             NCNsg= min(NCNsg, (0.5*NNM(i,k)*iQNM)*QCNsg) !Prevents incorrect Ns-depletion
+
+             ! 3-component freezing (collisions with rain):
+              if (QRM(i,k)>epsQ .and. QNM(i,k)>epsQ .and. Tc<-5.) then
+                tmp1 = vs0-vr0
+                tmp2 = sqrt(tmp1*tmp1+0.04*vs0*vr0)
+                tmp6 = iLAMs2*iLAMs2*iLAMs
+
+                QCLrs= dt*cmr*Ers*PIov4*iDE(i,k)*NNM(i,k)*NRM(i,k)*iGR31*iGS31*tmp2*     &
+                       (GR36*GS31*iLAMr5+2.*GR35*GS32*iLAMr4*iLAMs+GR34*GS33*iLAMr3*     &
+                       iLAMs2)
+
+                NCLrs= dt*0.25e0*PI*Ers*(NNM(i,k)*NRM(i,k))*iGR31*iGS31*tmp2*(GR33*      &
+                       GS31*iLAMr2+2.*GR32*GS32*iLAMr*iLAMs+GR31*GS33*iLAMs2)
+
+                if (snowSpherical) then
+                  !hardcoded for dms=3:
+                   QCLsr= dt*cms*Ers*PIov4*iDE(i,k)*(NRM(i,k)*NNM(i,k))*iGS31*iGR31*     &
+                          tmp2*(GS36*GR31*tmp6+2.*GS35*GR32*iLAMs2*iLAMs2*iLAMr+GS34*    &
+                          GR33*iLAMs2*iLAMs*iLAMr2)
+                else
+                  !hardcoded for dms=2:
+                   QCLsr= dt*cms*iDE(i,k)*PI*0.25*ERS*tmp2*NNM(i,k)*NRM(i,k)*iGS31*      &
+                          iGR31*(GR33*GS33*iLAMr**2.*iLAMs**2. + 2.*GR32*GS34*iLAMr*     &
+                          iLAMs**3. +GR31*GS35*iLAMs**4.)
+                endif
+
+               !note: For explicit eqns, NCLsr = NCLrs
+                NCLsr= min(QCLsr*(NNM(i,k)*iQNM), NCLrs)
+                QCLrs= min(QCLrs, QRM(i,k));  QCLsr= min(QCLsr, QNM(i,k))
+                NCLrs= min(NCLrs, NRM(i,k));  NCLsr= min(NCLsr, NNM(i,k))
+
+                ! Determine destination of 3-comp.freezing:
+                Dsrs= 0.;   Dsrg= 0.;    Dsrh= 0.
+                tmp1= max(Ds,Dr)
+                tmp2= tmp1*tmp1*tmp1
+                dey = (des*Ds*Ds*Ds + dew*Dr*Dr*Dr)/tmp2
+                if (dey<=0.5*(des+deg)                        ) Dsrs= 1.  !snow
+                if (dey >0.5*(des+deg) .and. dey<0.5*(deg+deh)) Dsrg= 1.  !graupel
+                if (dey>=0.5*(deg+deh)) then
+                   Dsrh= 1.                                               !hail
+                   if (.not.hail_ON .or. Dr<Dr_3cmpThrs) then
+                      Dsrg= 1.;   Dsrh= 0.                                !graupel
+                   endif
+                endif
+                if (.not. grpl_ON) Dsrg=0.
+             else
+                QCLrs= 0.;   QCLsr= 0.;   NCLrs= 0.;   NCLsr= 0.
+             endif
+
+          ELSE
+
+             QVDvs= 0.;  QCLcs= 0.;  QCNsg= 0.;  QCLsr= 0.;  QCLrs= 0.
+             NVDvs= 0.;  NCLcs= 0.;  NCLsr= 0.;  NCLrs= 0.;  NCNsg= 0.
+
+          ENDIF
+          !------------!
+          !  GRAUPEL:  !
+          !------------!
+          IF (QGM(i,k)>epsQ) THEN
+
+           !Conversion to hail:    (D_sll given by S-L limit)
+             if (WZ(i,k)>w_CNgh .and. hail_ON) then
+                D_sll = 0.01*(exp(min(20.,-Tc/(1.1e4*DE(i,k)*(QCM(i,k)+QRM(i,k))-1.3e3*  &
+                        DE(i,k)*(QIM(i,k))+1.)))-1.)
+               !Add correction factor: [to account error in equation of Ziegler (1985), as per Young (1993)]
+                D_sll = 2.0*D_sll
+                D_sll = min(1., max(0.0001,D_sll))    !smallest D_sll=0.1mm; largest=1m
+
+            !Old approach:  (pre-my-2.15.0)
+!                 ratio= Dg/D_sll
+!                 if (ratio>r_CNgh) then
+!                    QCNgh= (0.5*ratio)*(QCLcg+QCLrg+QCLig)
+!                    QCNgh= min(QCNgh,(QGM(i,k))+QCLcg+QCLrg+QCLig)
+!                    NCNgh= DE(i,k)*QCNgh*icmh/(D_sll*D_sll*D_sll)
+!                 else
+!                    QCNgh= 0.
+!                    NCNgh= 0.
+!                 endif
+            !New approach:
+                tmp1     = exp(-D_sll/iLAMg)
+                Ng_tail  = No_g*iLAMg*tmp1  !integral(Dsll,inf) of N(D)dD
+                if (Ng_tail > Ngh_crit) then
+                   QCNgh = idt*cmg*No_g*tmp1*(D_sll**3.*iLAMg + 3.*D_sll**2.*iLAMg**2.   &
+                           + 6.*D_sll*iLAMg**3. + 6.*iLAMg**4.)
+                   NgCNgh= idt*No_g*iLAMg*tmp1
+                   Rz= 1.
+                   !---
+                   ! The Rz factor (<>1) serves to conserve reflectivity when graupel
+                   ! converts to hail with a a different shape parameter, alpha.
+                   ! The factor Rz non-conserves N while acting to conserve Z for
+                   ! double-moment.  See Ferrier, 1994 App. D).  However, Rz=1 is
+                   ! used since it is deemed more important to conserve concentration
+                   ! than reflectivity (see Milbrandt and McTaggart-Cowan, 2010 JAS).
+                   !---
+                   ! Code to conserve total reflectivity:
+                   ! if  (QHM(i,k)>epsQ) then
+                   !    Rz= (gamma(7.+alpha_h)*GH31*GG34**2.)/(GG36*GG31*GH34**2.)
+                   ! else
+                   !    Rz= 1.
+                   ! endif
+                   !---
+                   NhCNgh= Rz*NgCNgh
+                else
+                   QCNgh  = 0.;   NgCNgh = 0.;   NhCNgh = 0.
+                endif
+             endif
+
+          !3-component freezing (collisions with rain):
+             if (QRM(i,k)>epsQ) then
+                tmp1 = vg0-vr0
+                tmp2 = sqrt(tmp1*tmp1 + 0.04*vg0*vr0)
+                tmp8 = iLAMg2*iLAMg      ! iLAMg**3
+                tmp9 = tmp8*iLAMg        ! iLAMg**4
+                tmp10= tmp9*iLAMg        ! iLAMg**5
+
+               !(parameterization of Erg based on Cober and List, 1993 [JAS])
+                Kstoke = dew*abs(vg0-vr0)*Dr*Dr/(9.*MUdyn*Dg)
+                Kstoke = max(1.5,min(10.,Kstoke))
+                Erg    = 0.55*log10(2.51*Kstoke)
+
+                QCLrg= dt*cmr*Erg*PIov4*iDE(i,k)*(NGM(i,k)*NRM(i,k))*iGR31*iGG31*tmp2*   &
+                       (GR36*GG31*iLAMr5+2.*GR35*GG32*iLAMr4*iLAMg+GR34*GG33*iLAMr3*     &
+                       iLAMg2)
+
+                NCLrg= dt*PIov4*Erg*(NGM(i,k)*NRM(i,k))*iGR31*iGG31*tmp2*(GR33*GG31*     &
+                       iLAMr2+2.*GR32*GG32*iLAMr*iLAMg+GR31*GG33*iLAMg2)
+
+                QCLgr= dt*cmg*Erg*PIov4*iDE(i,k)*(NRM(i,k)*NGM(i,k))*iGG31*iGR31*tmp2*   &
+                       (GG36*GR31*tmp10+2.*GG35*GR32*tmp9*iLAMr+GG34*GR33*tmp8*iLAMr2)
+
+               !(note: For explicit eqns, NCLgr= NCLrg)
+                NCLgr= min(NCLrg, QCLgr*(NGM(i,k)*iQGM))
+                QCLrg= min(QCLrg, QRM(i,k));  QCLgr= min(QCLgr, QGM(i,k))
+                NCLrg= min(NCLrg, NRM(i,k));  NCLgr= min(NCLgr, NGM(i,k))
+
+               ! Determine destination of 3-comp.freezing:
+                tmp1= max(Dg,Dr)
+                tmp2= tmp1*tmp1*tmp1
+                dey = (deg*Dg*Dg*Dg + dew*Dr*Dr*Dr)/tmp2
+                if (dey>0.5*(deg+deh) .and. Dr>Dr_3cmpThrs .and. hail_ON) then
+                   Dgrg= 0.;  Dgrh= 1.
+                else
+                   Dgrg= 1.;  Dgrh= 0.
+                endif
+             else
+                QCLgr= 0.;  QCLrg= 0.;  NCLgr= 0.;  NCLrg= 0.
+             endif
+
+          ELSE
+
+             QVDvg= 0.;  QCNgh= 0.;  QCLgr= 0.;  QCLrg= 0.;  NgCNgh= 0.
+             NVDvg= 0.;  NhCNgh= 0.; NCLgr= 0.;  NCLrg= 0.
+
+          ENDIF
+          !---------!
+          !  HAIL:  !
+          !---------!
+          IF (QHM(i,k)>epsQ) THEN
+
+            !Wet growth:
+             if (QHwet<(QCLch+QCLrh+QCLih+QCLsh) .and. Tc>-40.) then
+                QCLih= min(QCLih*iEih, QIM(i,k))  !change Eih to 1. in CLih
+                NCLih= min(NCLih*iEih, NYM(i,k))  !  "    "
+                QCLsh= min(QCLsh*iEsh, QNM(i,k))  !change Esh to 1. in CLsh
+                NCLsh= min(NCLsh*iEsh, NNM(i,k))  !  "    "
+                tmp3 = QCLrh
+                QCLrh= QHwet-(QCLch+QCLih+QCLsh)  !actual QCLrh minus QSHhr
+                QSHhr= tmp3-QCLrh                 !QSHhr used here only
+                NSHhr= DE(i,k)*QSHhr/(cmr*Drshed*Drshed*Drshed)
+             else
+                NSHhr= 0.
+             endif
+          ELSE
+             QVDvh= 0.;   NVDvh= 0.;   NSHhr= 0.
+          ENDIF
+
+       ENDIF  ! ( if Tc<0C Block )
+
+     !------------  End of source/sink term calculation  -------------!
+
+     !-- Adjustment of source/sink terms to prevent  overdepletion: --!
+       do niter= 1,2
+
+          ! (1) Vapor:
+          source= Q(i,k) +dim(-QVDvi,0.)+dim(-QVDvs,0.)+dim(-QVDvg,0.)+dim(-QVDvh,0.)
+          sink  = QNUvi+dim(QVDvi,0.)+dim(QVDvs,0.)
+          sour  = max(source,0.)
+          if(sink>sour) then
+             ratio= sour/sink
+             QNUvi= ratio*QNUvi;   NNUvi= ratio*NNUvi
+             if(QVDvi>0.) then
+               QVDvi= ratio*QVDvi; NVDvi= ratio*NVDvi
+             endif
+             if(QVDvs>0.) then
+               QVDvs=ratio*QVDvs;  NVDvs=ratio*NVDvs
+             endif
+             QVDvg= ratio*QVDvg;   NVDvg= ratio*NVDvg
+             QVDvh= ratio*QVDvh;   NVDvh= ratio*NVDvh
+          endif
+
+          ! (2) Cloud:
+          source= QC(i,k)
+          sink  = QCLcs+QCLcg+QCLch+QFZci
+          sour  = max(source,0.)
+          if(sink>sour) then
+             ratio= sour/sink
+             QFZci= ratio*QFZci;   NFZci= ratio*NFZci
+             QCLcs= ratio*QCLcs;   NCLcs= ratio*NCLcs
+             QCLcg= ratio*QCLcg;   NCLcg= ratio*NCLcg
+             QCLch= ratio*QCLch;   NCLch= ratio*NCLch
+          endif
+
+          ! (3) Rain:
+          source= QR(i,k)+QMLsr+QMLgr+QMLhr+QMLir
+          sink  = QCLri+QCLrs+QCLrg+QCLrh+QFZrh
+          sour  = max(source,0.)
+          if(sink>sour) then
+             ratio= sour/sink
+             QCLrg= ratio*QCLrg;   QCLri= ratio*QCLri;   NCLri= ratio*NCLri
+             QCLrs= ratio*QCLrs;   NCLrs= ratio*NCLrs;   QCLrg= ratio*QCLrg
+             NCLrg= ratio*NCLrg;   QCLrh= ratio*QCLrh;   NCLrh= ratio*NCLrh
+             QFZrh= ratio*QFZrh;   NrFZrh=ratio*NrFZrh;  NhFZrh=ratio*NhFZrh
+             if (ratio==0.) then
+                Dirg= 0.; Dirh= 0.; Dgrg= 0.; Dgrh= 0.
+                Dsrs= 0.; Dsrg= 0.; Dsrh= 0.
+              endif
+          endif
+
+          ! (4) Ice:
+          source= QI(i,k)+QNUvi+dim(QVDvi,0.)+QFZci
+          sink  = QCNis+QCLir+dim(-QVDvi,0.)+QCLis+QCLig+QCLih+QMLir
+          sour  = max(source,0.)
+          if(sink>sour) then
+             ratio= sour/sink
+             QMLir= ratio*QMLir;    NMLir= ratio*NMLir
+             if (QVDvi<0.) then
+                QVDvi= ratio*QVDvi; NVDvi= ratio*NVDvi
+             endif
+             QCNis=  ratio*QCNis;   NiCNis= ratio*NiCNis;   NsCNis= ratio*NsCNis
+             QCLir=  ratio*QCLir;   NCLir=  ratio*NCLir;    QCLig=  ratio*QCLig
+             QCLis=  ratio*QCLis;   NCLis=  ratio*NCLis
+             QCLih=  ratio*QCLih;   NCLih=  ratio*NCLih
+             if (ratio==0.) then
+                Dirg= 0.; Dirh= 0.
+             endif
+          endif
+
+          ! (5) Snow:
+          source= QN(i,k)+QCNis+dim(QVDvs,0.)+QCLis+Dsrs*(QCLrs+QCLsr)+QCLcs
+          sink  = dim(-QVDvs,0.)+QCNsg+QMLsr+QCLsr+QCLsh
+          sour  = max(source,0.)
+          if(sink>sour) then
+             ratio= sour/sink
+             if(QVDvs<=0.) then
+                QVDvs= ratio*QVDvs;   NVDvs= ratio*NVDvs
+             endif
+             QCNsg= ratio*QCNsg;   NCNsg= ratio*NCNsg;   QMLsr= ratio*QMLsr
+             NMLsr= ratio*NMLsr;   QCLsr= ratio*QCLsr;   NCLsr= ratio*NCLsr
+             QCLsh= ratio*QCLsh;   NCLsh= ratio*NCLsh
+             if (ratio==0.) then
+                Dsrs= 0.; Dsrg= 0.; Dsrh= 0.
+             endif
+          endif
+
+          !  (6) Graupel:
+          source= QG(i,k)+QCNsg+dim(QVDvg,0.)+Dirg*(QCLri+QCLir)+Dgrg*(QCLrg+QCLgr)+     &
+                  QCLcg+Dsrg*(QCLrs+QCLsr)+QCLig
+          sink  = dim(-QVDvg,0.)+QMLgr+QCNgh+QCLgr
+          sour  = max(source,0.)
+          if(sink>sour) then
+             ratio= sour/sink
+             QVDvg= ratio*QVDvg;   NVDvg= ratio*NVDvg;   QMLgr = ratio*QMLgr
+             NMLgr= ratio*NMLgr;   QCNgh= ratio*QCNgh;   NgCNgh= ratio*NgCNgh
+             QCLgr= ratio*QCLgr;   NCLgr= ratio*NCLgr;   NhCNgh= ratio*NhCNgh
+             if (ratio==0.) then
+                Dgrg= 0.; Dgrh= 0.
+             endif
+          endif
+
+          !  (7) Hail:
+          source= QH(i,k)+dim(QVDvh,0.)+QCLch+QCLrh+Dirh*(QCLri+QCLir)+QCLih+QCLsh+    &
+                  Dsrh*(QCLrs+QCLsr)+QCNgh+Dgrh*(QCLrg+QCLgr)+QFZrh
+          sink  = dim(-QVDvh,0.)+QMLhr
+          sour  = max(source,0.)
+          if(sink>sour) then
+             ratio= sour/sink
+             QVDvh= ratio*QVDvh;   NVDvh= ratio*NVDvh
+             QMLhr= ratio*QMLhr;   NMLhr= ratio*NMLhr
+          endif
+
+       enddo
+       !---------------  End of source/sink term adjustment  ------------------!
+
+      !Compute N-tendencies for destination categories of 3-comp.freezing:
+       NCLirg= 0.;  NCLirh= 0.;  NCLsrs= 0.;  NCLsrg= 0.
+       NCLsrh= 0.;  NCLgrg= 0.;  NCLgrh= 0.
+
+       if (QCLir+QCLri>0.) then
+          tmp1  = max(Dr,Di)
+          tmp2  = tmp1*tmp1*tmp1*PIov6
+          NCLirg= Dirg*DE(i,k)*(QCLir+QCLri)/(deg*tmp2)
+          NCLirh= Dirh*DE(i,k)*(QCLir+QCLri)/(deh*tmp2)
+       endif
+
+       if (QCLsr+QCLrs>0.) then
+          tmp1  = max(Dr,Ds)
+          tmp2  = tmp1*tmp1*tmp1*PIov6
+          NCLsrs= Dsrs*DE(i,k)*(QCLsr+QCLrs)/(des*tmp2)
+          NCLsrg= Dsrg*DE(i,k)*(QCLsr+QCLrs)/(deg*tmp2)
+          NCLsrh= Dsrh*DE(i,k)*(QCLsr+QCLrs)/(deh*tmp2)
+       endif
+
+       if (QCLgr+QCLrg>0.) then
+          tmp1  = max(Dr,Dg)
+          tmp2  = tmp1*tmp1*tmp1*PIov6
+          NCLgrg= Dgrg*DE(i,k)*(QCLgr+QCLrg)/(deg*tmp2)
+          NCLgrh= Dgrh*DE(i,k)*(QCLgr+QCLrg)/(deh*tmp2)
+       endif
+
+       !========================================================================!
+       !           Add all source/sink terms to all predicted moments:          !
+       !========================================================================!
+
+      !Diagnostic S/S terms:  (to facilitate output of 3D variables for diagnostics)
+      !SS01(i,k)= QVDvs*idt  (e.g., for depositional growth rate of snow, kg kg-1 s-1)
+
+       ! Q-Source/Sink Terms:
+       Q(i,k) = Q(i,k)  -QNUvi -QVDvi -QVDvs -QVDvg -QVDvh
+       QC(i,k)= QC(i,k) -QCLcs -QCLcg -QCLch -QFZci
+       QR(i,k)= QR(i,k) -QCLri +QMLsr -QCLrs -QCLrg +QMLgr -QCLrh +QMLhr -QFZrh +QMLir
+       QI(i,k)= QI(i,k) +QNUvi +QVDvi +QFZci -QCNis -QCLir -QCLis -QCLig                 &
+                        -QMLir -QCLih +QIMsi +QIMgi
+       QG(i,k)= QG(i,k) +QCNsg +QVDvg +QCLcg -QCLgr-QMLgr -QCNgh -QIMgi +QCLig           &
+                        +Dirg*(QCLri+QCLir) +Dgrg*(QCLrg+QCLgr) +Dsrg*(QCLrs+QCLsr)
+       QN(i,k)= QN(i,k) +QCNis +QVDvs +QCLcs -QCNsg -QMLsr -QIMsi -QCLsr +QCLis -QCLsh   &
+                        +Dsrs*(QCLrs+QCLsr)
+       QH(i,k)= QH(i,k) +Dirh*(QCLri+QCLir) -QMLhr +QVDvh +QCLch +Dsrh*(QCLrs+QCLsr)     &
+                        +QCLih +QCLsh +QFZrh +QCLrh +QCNgh +Dgrh*(QCLrg+QCLgr)
+
+       ! N-Source/Sink Terms:
+       if (dblMom_c) NC(i,k)= NC(i,k) -NCLcs -NCLcg -NCLch -NFZci
+       if (dblMom_r) NR(i,k)= NR(i,k) -NCLri -NCLrs -NCLrg -NCLrh +NMLsr +NMLgr +NMLhr   &
+                                      -NrFZrh +NMLir +NSHhr
+       if (dblMom_i) NY(i,k)= NY(i,k) +NNUvi +NVDvi +NFZci -NCLir -NCLis -NCLig -NCLih   &
+                                      -NMLir +NIMsi +NIMgi -NiCNis
+       if (dblMom_s) NN(i,k)= NN(i,k) +NsCNis -NVDvs -NCNsg -NMLsr -NCLss -NCLsr -NCLsh  &
+                                      +NCLsrs
+       if (dblMom_g) NG(i,k)= NG(i,k) +NCNsg -NCLgr -NVDvg -NMLgr +NCLirg +NCLsrg        &
+                                      +NCLgrg -NgCNgh
+       if (dblMom_h) NH(i,k)= NH(i,k) +NhFZrh +NhCNgh -NMLhr -NVDvh +NCLirh +NCLsrh       &
+                                      +NCLgrh
+
+       T(i,k)= T(i,k)   +LFP*(QCLri+QCLcs+QCLrs+QFZci-QMLsr+QCLcg+QCLrg-QMLir-QMLgr      &
+                        -QMLhr+QCLch+QCLrh+QFZrh) +LSP*(QNUvi+QVDvi+QVDvs+QVDvg+QVDvh)
+
+     !Prevent overdepletion:
+       IF (dblMom_c) THEN
+         if(QC(i,k)<epsQ .or. NC(i,k)<epsN)    then
+            Q(i,k) = Q(i,k) + QC(i,k)
+            T(i,k) = T(i,k) - LCP*QC(i,k)
+            QC(i,k)= 0.;   NC(i,k)= 0.
+         endif
+       ELSE
+         if(QC(i,k)<epsQ)    then
+            Q(i,k) = Q(i,k) + QC(i,k)
+            T(i,k) = T(i,k) - LCP*QC(i,k)
+            QC(i,k)= 0.
+         endif
+       ENDIF
+
+       IF (dblMom_r) THEN
+         if (QR(i,k)<epsQ .or. NR(i,k)<epsN)   then
+            Q(i,k) = Q(i,k) + QR(i,k)
+            T(i,k) = T(i,k) - LCP*QR(i,k)
+            QR(i,k)= 0.;  NR(i,k)= 0.
+         endif
+       ELSE
+         if (QR(i,k)<epsQ)   then
+            Q(i,k) = Q(i,k) + QR(i,k)
+            T(i,k) = T(i,k) - LCP*QR(i,k)
+           QR(i,k)= 0.
+         endif
+       ENDIF
+
+       IF (dblMom_i) THEN
+         if (QI(i,k)<epsQ .or. NY(i,k)<epsN)   then
+            Q(i,k) = Q(i,k) + QI(i,k)
+            T(i,k) = T(i,k) - LSP*QI(i,k)
+            QI(i,k)= 0.;  NY(i,k)= 0.
+         endif
+       ELSE
+         if (QI(i,k)<epsQ)   then
+            Q(i,k) = Q(i,k) + QI(i,k)
+            T(i,k) = T(i,k) - LSP*QI(i,k)
+            QI(i,k)= 0.
+         endif
+       ENDIF
+
+       IF (dblMom_s) THEN
+         if (QN(i,k)<epsQ .or. NN(i,k)<epsN)   then
+            Q(i,k) = Q(i,k) + QN(i,k)
+            T(i,k) = T(i,k) - LSP*QN(i,k)
+            QN(i,k)= 0.;  NN(i,k)= 0.
+         endif
+       ELSE
+         if (QN(i,k)<epsQ)   then
+            Q(i,k) = Q(i,k) + QN(i,k)
+            T(i,k) = T(i,k) - LSP*QN(i,k)
+            QN(i,k)= 0.
+         endif
+       ENDIF
+
+       IF (dblMom_g) THEN
+         if (QG(i,k)<epsQ .or. NG(i,k)<epsN)   then
+            Q(i,k) = Q(i,k) + QG(i,k)
+            T(i,k) = T(i,k) - LSP*QG(i,k)
+            QG(i,k)= 0.;  NG(i,k)= 0.
+         endif
+       ELSE
+         if (QG(i,k)<epsQ)   then
+            Q(i,k) = Q(i,k) + QG(i,k)
+            T(i,k) = T(i,k) - LSP*QG(i,k)
+            QG(i,k)= 0.
+         endif
+       ENDIF
+
+       IF (dblMom_h) THEN
+         if (QH(i,k)<epsQ .or. NH(i,k)<epsN)   then
+            Q(i,k) = Q(i,k) + QH(i,k)
+            T(i,k) = T(i,k) - LSP*QH(i,k)
+            QH(i,k)= 0.;  NH(i,k)= 0.
+         else if (QH(i,k)>epsQ .and. NH(i,k)>epsN) then
+          !Conversion to graupel of hail is small:
+            Dh= (DE(i,k)*QH(i,k)/NH(i,k)*icmh)**thrd
+            if (Dh<Dh_min) then
+               QG(i,k)= QG(i,k) + QH(i,k)
+               NG(i,k)= NG(i,k) + NH(i,k)
+               QH(i,k)= 0.;  NH(i,k)= 0.
+            endif
+         endif
+       ELSE
+         if (QH(i,k)<epsQ)   then
+            Q(i,k) = Q(i,k) + QH(i,k)
+            T(i,k) = T(i,k) - LSP*QH(i,k)
+            QH(i,k)= 0.
+         endif
+       ENDIF
+       Q(i,k)= max(Q(i,k),0.)
+       NY(i,k)= min(NY(i,k), Ni_max)
+
+      ENDIF  !if (activePoint)
+    ENDDO
+  ENDDO
+
+  !----------------------------------------------------------------------------------!
+  !                    End of ice phase microphysics (Part 2)                        !
+  !----------------------------------------------------------------------------------!
+
+  !----------------------------------------------------------------------------------!
+  !                       PART 3: Warm Microphysics Processes                        !
+  !                                                                                  !
+  !  Equations for warm-rain coalescence based on Cohard and Pinty (2000a,b; QJRMS)  !
+  !  Condensation/evaportaion equations based on Kong and Yau (1997; Atmos-Ocean)    !
+  !  Equations for rain reflectivity (ZR) based on Milbrandt and Yau (2005b; JAS)    !
+  !----------------------------------------------------------------------------------!
+
+  ! Part 3a - Warm-rain Coallescence:
+
+ IF (warmphase_ON) THEN
+
+  DO k= 2,nk
+     DO i= 1,ni
+
+        RCAUTR= 0.;  CCACCR= 0.;  Dc= 0.;  iLAMc= 0.;  L  = 0.
+        RCACCR= 0.;  CCSCOC= 0.;  Dr= 0.;  iLAMr= 0.;  TAU= 0.
+        CCAUTR= 0.;  CRSCOR= 0.;  SIGc= 0.;  DrINIT= 0.
+        iLAMc3= 0.;  iLAMc6= 0.;  iLAMr3= 0.;  iLAMr6= 0.
+
+        if (dblMom_r) then
+           rainPresent= (QRM(i,k)>epsQ .and. NRM(i,k)>epsN)
+        else
+           rainPresent= (QRM(i,k)>epsQ)
+        endif
+
+        if (.not. dblMom_c) NCM(i,k)= N_c_SM
+        if (QCM(i,k)>epsQ .and. NCM(i,k)>epsN) then
+           iLAMc = iLAMDA_x(DE(i,k),QCM(i,k),1./NCM(i,k),icexc9,thrd)
+           iLAMc3= iLAMc*iLAMc*iLAMc
+           iLAMc6= iLAMc3*iLAMc3
+           Dc    = iLAMc*(GC2*iGC1)**thrd
+           SIGc  = iLAMc*( GC3*iGC1- (GC2*iGC1)*(GC2*iGC1) )**sixth
+           L     = 0.027*DE(i,k)*QCM(i,k)*(6.25e18*SIGc*SIGc*SIGc*Dc-0.4)
+           if (SIGc>SIGcTHRS) TAU= 3.7/(DE(i,k)*(QCM(i,k))*(0.5e6*SIGc-7.5))
+        endif
+
+        if (rainPresent) then
+           if (dblMom_r) then
+              Dr = Dm_x(DE(i,k),QRM(i,k),1./NRM(i,k),icmr,thrd)
+             !Drop-size limiter [prevents initially large drops from melted hail]
+              if (Dr>3.e-3) then
+                 tmp1    = (Dr-3.e-3);  tmp2= (Dr/DrMAX); tmp3= tmp2*tmp2*tmp2
+                 NRM(i,k)= NRM(i,k)*max((1.+2.e4*tmp1*tmp1),tmp3)
+                 tmp1    = DE(i,k)*QRM(i,k)*icmr
+                 Dr      = (tmp1/NRM(i,k))**thrd
+              endif
+           else
+              NRM(i,k)= GR50*sqrt(sqrt(GR31*iGR34*DE(i,k)*QRM(i,k)*icmr))
+              Dr = Dm_x(DE(i,k),QRM(i,k),1./NRM(i,k),icmr,thrd)
+           endif
+           iLAMr = iLAMDA_x(DE(i,k),QRM(i,k),1./NRM(i,k),icexr9,thrd)
+           iLAMr3= iLAMr*iLAMr*iLAMr
+           iLAMr6= iLAMr3*iLAMr3
+        endif
+
+        !  Autoconversion:
+        if (QCM(i,k)>epsQ .and. SIGc>SIGcTHRS .and. autoconv_ON) then
+           RCAUTR= min( max(L/TAU,0.), QCM(i,k)*idt )
+           DrINIT= max(83.e-6, 12.6e-4/(0.5e6*SIGc-3.5))  !initiation regime Dr
+           DrAUT = max(DrINIT, Dr)                     !init. or feeding DrAUT
+           CCAUTR= RCAUTR*DE(i,k)/(cmr*DrAUT*DrAUT*DrAUT)
+
+           ! ---------------------------------------------------------------------------- !
+           ! NOTE: The formulation for CCAUTR here (dNr/dt|initiation) does NOT follow
+           !       eqn (18) in CP2000a, but rather it comes from the F90 code provided
+           !       by J-P Pinty (subroutine: 'rain_c2r2.f90').
+           !       (See notes: 2001-10-17; 2001-10-22)
+           !
+           !       Similarly, the condition for the activation of accretion and self-
+           !       collection depends on whether or not autoconversion is in the feeding
+           !       regime (see notes 2002-01-07).  This is apparent in the F90 code, but
+           !       NOT in CP2000a.
+           ! ---------------------------------------------------------------------------- !
+
+           ! cloud self-collection: (dNc/dt_autoconversion)   {CP eqn(25)}
+           if (dblMom_c) CCSCOC= min(KK2*NCM(i,k)*NCM(i,k)*GC3*iGC1*iLAMc6, NCM(i,k)*    &
+                                 idt)  !{CP00a eqn(25)}
+        endif
+
+        ! Accretion, rain self-collection, and collisional breakup:
+        if (((QRM(i,k))>1.2*max(L,0.)*iDE(i,k).or.Dr>max(5.e-6,DrINIT)).and.rainAccr_ON  &
+             .and. rainPresent) then
+
+           !  Accretion:                                                      !{CP00a eqn(22)}
+           if (QCM(i,k)>epsQ.and.L>0.) then
+              if (Dr.ge.100.e-6) then
+                 CCACCR = KK1*(NCM(i,k)*NRM(i,k))*(GC2*iGC1*iLAMc3+GR34*iGR31*iLAMr3)
+                 RCACCR = cmr*iDE(i,k)*KK1*(NCM(i,k)*NRM(i,k))*iLAMc3*(GC3*iGC1*iLAMc3+  &
+                          GC2*iGC1*GR34*iGR31*iLAMr3)
+              else
+                 CCACCR = KK2*(NCM(i,k)*NRM(i,k))*(GC3*iGC1*iLAMc6+GR37*iGR31*iLAMr6)
+
+!                  RCACCR= cmr*iDE(i,k)*KK2*(NCM(i,k)*NRM(i,k))*iLAMc3*                  &
+!                          (GC4*iGR31*iLAMc6+GC2*iGC1*GR37*iGR31*iLAMr6)
+!++  The following calculation of RCACCR avoids overflow:
+                 tmp1   = cmr*iDE(i,k)
+                 tmp2   = KK2*(NCM(i,k)*NRM(i,k))*iLAMc3
+                 RCACCR = tmp1 * tmp2
+                 tmp1   = GC4*iGR31
+                 tmp1   = (tmp1)*iLAMc6
+                 tmp2   = GC2*iGC1
+                 tmp2   = tmp2*GR37*iGR31
+                 tmp2   = (tmp2)*iLAMr6
+                 RCACCR = RCACCR * (tmp1 + tmp2)
+!++
+              endif
+              CCACCR = min(CCACCR,(NC(i,k))*idt)
+              RCACCR = min(RCACCR,(QC(i,k))*idt)
+            endif
+
+           if (dblMom_r) then
+            !Rain self-collection:
+              tmp1= NRM(i,k)*NRM(i,k)
+              if (Dr.ge.100.e-6) then
+                 CRSCOR= KK1*tmp1*GR34*iGR31*iLAMr3                        !{CP00a eqn(24)}
+              else
+                 CRSCOR= KK2*tmp1*GR37*iGR31*iLAMr6                        !{CP00a eqn(25)}
+              endif
+            !Raindrop breakup:                                             !{CP00a eqn(26)}
+              Ec= 1.
+              if (Dr >=  600.e-6) Ec= exp(-2.5e3*(Dr-6.e-4))
+              if (Dr >= 2000.e-6) Ec= 0.
+              CRSCOR= min(Ec*CRSCOR,(0.5*NR(i,k))*idt) !0.5 prevents depletion of NR
+           endif
+
+        endif  !accretion/self-collection/breakup
+
+        ! Prevent overdepletion of cloud:
+        source= QC(i,k)
+        sink  = (RCAUTR+RCACCR)*dt
+        if (sink>source) then
+           ratio = source/sink
+           RCAUTR= ratio*RCAUTR
+           RCACCR= ratio*RCACCR
+           CCACCR= ratio*CCACCR
+        endif
+
+        ! Apply tendencies:
+        QC(i,k)= max(0., QC(i,k)+(-RCAUTR-RCACCR)*dt )
+        QR(i,k)= max(0., QR(i,k)+( RCAUTR+RCACCR)*dt )
+        if (dblMom_c) NC(i,k)= max(0., NC(i,k)+(-CCACCR-CCSCOC)*dt )
+        if (dblMom_r) NR(i,k)= max(0., NR(i,k)+( CCAUTR-CRSCOR)*dt )
+
+        if (dblMom_r) then
+           if (QR(i,k)>epsQ .and. NR(i,k)>epsN) then
+              Dr = Dm_x(DE(i,k),QR(i,k),1./NR(i,k),icmr,thrd)
+              if (Dr>3.e-3) then
+                 tmp1= (Dr-3.e-3);   tmp2= tmp1*tmp1
+                 tmp3= (Dr/DrMAX);   tmp4= tmp3*tmp3*tmp3
+                 NR(i,k)= NR(i,k)*(max((1.+2.e4*tmp2),tmp4))
+              elseif (Dr<Dhh) then
+              !Convert small raindrops to cloud:
+                 QC(i,k)= QC(i,k) + QR(i,k)
+                 NC(i,k)= NC(i,k) + NR(i,k)
+                 QR(i,k)= 0.;   NR(i,k)= 0.
+              endif
+           else
+              QR(i,k)= 0.;   NR(i,k)= 0.
+           endif  !(Qr,Nr>eps)
+        endif
+
+     ENDDO
+  ENDDO
+
+  ! Part 3b - Condensation/Evaporation:
+
+  DO k=1,nk
+     DO i=1,ni
+
+        DEo     = DE(i,nk)
+        gam     = sqrt(DEo*iDE(i,k))
+#if (DWORDSIZE == 8 && RWORDSIZE == 8)
+        QSS(i,k)=      FOQSA(T(i,k), PS(i)*S(i,k))   ! Re-calculates QS with new T (w.r.t. liquid)
+#elif (DWORDSIZE == 8 && RWORDSIZE == 4)
+        QSS(i,k)= sngl(FOQSA(T(i,k), PS(i)*S(i,k)))  ! Re-calculates QS with new T (w.r.t. liquid)
+#else
+     This is a temporary hack assuming double precision is 8 bytes.
+#endif
+        ssat    = Q(i,k)/QSS(i,k)-1.
+        Tc      = T(i,k)-TRPL
+        Cdiff   = max(1.62e-5, (2.2157e-5 + 0.0155e-5*Tc)) *1.e5/(S(i,k)*PS(i))
+        MUdyn   = max(1.51e-5, (1.7153e-5 + 0.0050e-5*Tc))
+        MUkin   = MUdyn*iDE(i,k)
+        iMUkin  = 1./MUkin
+        Ka      = max(2.07e-2, (2.3971e-2 + 0.0078e-2*Tc))
+        ScTHRD  = (MUkin/Cdiff)**thrd ! i.e. Sc^(1/3)
+
+        !Condensation/evaporation:
+        ! Capacity of evap/cond in one time step is determined by saturation
+        ! adjustment technique [Kong and Yau, 1997 App.A].  Equation for rain evaporation rate
+        ! comes from Cohard and Pinty, 2000a.  Explicit condensation rate is not considered
+        ! (as it is in Ziegler, 1985), but rather complete removal of supersaturation is assumed.
+
+        X= Q(i,k)-QSS(i,k)
+        if (dblMom_r) then
+           rainPresent= (QR(i,k)>epsQ .and. NR(i,k)>epsN)
+        else
+           rainPresent= (QR(i,k)>epsQ)
+        endif
+        IF(X>0. .or. QC(i,k)>epsQ .or. rainPresent) THEN
+           tmp1 = T(i,k)-35.86
+           X    = X/(1.+ck5*QSS(i,k)/(tmp1*tmp1))
+           if (X<(-QC(i,k))) then
+              D= 0.
+              if(rainPresent) then
+                 if(QM(i,k)<QSW(i,k)) then
+                    MUkin = (1.715e-5+5.e-8*Tc)*iDE(i,k)
+                    iMUkin= 1./MUkin
+                    if (dblMom_r) then
+                        Dr   = Dm_x(DE(i,k),QR(i,k),1./NR(i,k),icmr,thrd)
+                        iLAMr= iLAMDA_x(DE(i,k),QR(i,k),1./NR(i,k),icexr9,thrd)
+                        LAMr = 1./iLAMr
+                        !note: The following coding of 'No_r=...' prevents overflow:
+                       !No_r_DM= NR(i,k)*LAMr**(1.+alpha_r))*iGR31
+                        No_r_DM= sngl(dble(NR(i,k))*dble(LAMr)**dble(1.+alpha_r))*iGR31
+                        No_r   = No_r_DM
+                    else
+                       iLAMr = sqrt(sqrt( (QR(i,k)*DE(i,k))/(GR34*cmr*No_r) ))
+                    !note: No_r= No_r_SM   is already done (in Part 1)
+                    endif
+                    !note: There is an error in MY05a_eq(8) for VENTx (corrected in code)
+                    VENTr= Avx*GR32*iLAMr**cexr5 + Bvx*ScTHRD*sqrt(gam*afr*iMUkin)*GR17* &
+                           iLAMr**cexr6
+                    ABw  = CHLC*CHLC/(Ka*RGASV*T(i,k)*T(i,k))+1./(DE(i,k)*(QSS(i,k))*    &
+                           Cdiff)
+                    QREVP= -dt*(PI2*ssat*No_r*VENTr/ABw)
+                !!  QREVP= 0.  !to suppress evaporation of rain
+                    if ((QR(i,k))>QREVP) then             !Note: QREVP is [(dQ/dt)*dt]
+                       DEL= -QREVP
+                    else
+                       DEL= -QR(i,k)
+                    endif
+                    D= max(X+QC(i,k), DEL)
+                 endif  !QM< QSM
+              endif   !QR<eps & NR<eps
+              X= D - QC(i,k)
+
+              QR(i,k)= QR(i,k) + D
+              if (QR(i,k)>0. .and. dblMom_r)                                              &
+                   NR(i,k)= max(0.,NR(i,k)+D*NR(i,k)/QR(i,k)) !(dNr/dt)|evap
+              ! The above expression of (dNr/dt)|evap is from Ferrier, 1994.
+              ! In CP2000a, Nr is not affected by evap. (except if Qr goes to zero).
+              QC(i,k)= 0.;   NC(i,k)= 0.
+              T(i,k) = T(i,k) + LCP*X
+              Q(i,k) = Q(i,k) - X
+
+           else  ![if(X >= -QC)]
+
+              ! Nucleation of cloud droplets:
+              if (ssat>0. .and. WZ(i,k)>0. .and. dblMom_c)                                &
+                   NC(i,k)= max(NC(i,k),NccnFNC(WZ(i,k),TM(i,k),HPS(i)*S(i,k),CCNtype))
+
+              ! All supersaturation is removed (condensed onto cloud field).
+              T(i,k)  = T(i,k)  + LCP*X
+              Q(i,k)  = Q(i,k)  - X
+              QC(i,k) = QC(i,k) + X
+              if (dblMom_c) then
+                  if (X<0.) then
+                     if (QC(i,k)>0.) then
+                        NC(i,k)= max(0., NC(i,k) + X*NC(i,k)/QC(i,k) ) !(dNc/dt)|evap
+                     else
+                        NC(i,k)= 0.
+                     endif
+                  endif
+                  if (QC(i,k)>0..and.NC(i,k)==0.) NC(i,k)= 1.e7 !prevents non-zero_Q & zero_N
+              endif
+
+           endif
+
+        ENDIF
+
+       !Protect against negative values due to overdepletion:
+        if (dblMom_r) then
+            if (QR(i,k)<epsQ.or.NR(i,k)<epsN)  then
+               Q(i,k) = Q(i,k) + QR(i,k)
+               T(i,k) = T(i,k) - QR(i,k)*LCP
+               QR(i,k)= 0.;  NR(i,k)= 0.
+            endif
+        else
+            if (QR(i,k)<epsQ)  then
+               Q(i,k) = Q(i,k) + QR(i,k)
+               T(i,k) = T(i,k) - QR(i,k)*LCP
+               QR(i,k)= 0.
+            endif
+        endif
+
+     ENDDO
+  ENDDO    !cond/evap [k-loop]
+
+ ENDIF  !if warmphase_ON
+
+  !----------------------------------------------------------------------------------!
+  !                    End of warm-phase microphysics (Part 3)                       !
+  !----------------------------------------------------------------------------------!
+
+  !----------------------------------------------------------------------------------!
+  !                            PART 4:  Sedimentation                                !
+  !----------------------------------------------------------------------------------!
+
+  !----------------------------------------------------------------------------------!
+  !  Sedimentation is computed using a modified version of the box-Lagrangian        !
+  !  scheme.  Sedimentation is only computed for columns containing non-zero         !
+  !  hydrometeor quantities (at at least one level).                                 !
+  !----------------------------------------------------------------------------------!
+
+ IF (sedi_ON) THEN
+
+   fluxM_r= 0.;  fluxM_i= 0.;  fluxM_s= 0.;  fluxM_g= 0.;  fluxM_h= 0.
+   RT_rn1 = 0.;  RT_rn2 = 0.;  RT_fr1 = 0.;  RT_fr2 = 0.;  RT_sn1 = 0.
+   RT_sn2 = 0.;  RT_sn3 = 0.;  RT_pe1 = 0.;  RT_pe2 = 0.;  RT_peL = 0.
+
+!--  RAIN sedimentation:
+   if (DblMom_r) then
+     call SEDI_main_2(QR,NR,1,Q,T,DE,iDE,gamfact_r,epsQr_sedi,epsN,afr,bfr,cmr,dmr,      &
+                      ckQr1,ckQr2,icexr9,LCP,ni,nk,VrMax,DrMax,dt,DZ,fluxM_r,ktop_sedi,  &
+                      GRAV,massFlux3D=massFlux3D_r)
+   else  !if DblMom_r
+      call SEDI_main_1b(QR,1,T,DE,iDE,gamfact_r,epsQr_sedi,afr,bfr,icmr,dmr,ckQr1,       &
+                        icexr9,ni,nk,VrMax,DrMax,dt,DZ,fluxM_r,No_r_SM,ktop_sedi,GRAV,   &
+                        massFlux3D=massFlux3D_r)
+   endif  !if DblMom_r
+
+
+!--  ICE sedimentation:
+   if (DblMom_i) then
+     call SEDI_main_2(QI,NY,2,Q,T,DE,iDE,gamfact,epsQi_sedi,epsN,afi,bfi,cmi,dmi,ckQi1,  &
+                      ckQi2,ckQi4,LSP,ni,nk,ViMax,DiMax,dt,DZ,fluxM_i,ktop_sedi,GRAV)
+   else
+     call SEDI_main_1b(QI,2,T,DE,iDE,gamfact,epsQi_sedi,afi,bfi,icmi,dmi,ckQi1,ckQi4,    &
+                     ni,nk,ViMax,DiMax,dt,DZ,fluxM_i,-99.,ktop_sedi,GRAV)
+   endif
+
+
+!--  SNOW sedimentation:
+   if (DblMom_s) then
+     call SEDI_main_2(QN,NN,3,Q,T,DE,iDE,gamfact,epsQs_sedi,epsN,afs,bfs,cms,dms,ckQs1,  &
+                      ckQs2,iGS20,LSP,ni,nk,VsMax,DsMax,dt,DZ,fluxM_s,ktop_sedi,GRAV,    &
+                      massFlux3D=massFlux3D_s)
+   else
+     call SEDI_main_1b(QN,3,T,DE,iDE,gamfact,epsQs_sedi,afs,bfs,icms,dms,ckQs1,iGS20,    &
+                      ni,nk,VsMax,DsMax,dt,DZ,fluxM_s,-99.,ktop_sedi,GRAV,massFlux3D=    &
+                      massFlux3D_s)
+   endif
+
+
+!--  GRAUPEL sedimentation:
+   if (DblMom_g) then
+     call SEDI_main_2(QG,NG,4,Q,T,DE,iDE,gamfact,epsQg_sedi,epsN,afg,bfg,cmg,dmg,ckQg1,  &
+                      ckQg2,ckQg4,LSP,ni,nk,VgMax,DgMax,dt,DZ,fluxM_g,ktop_sedi,GRAV)
+   else
+     call SEDI_main_1b(QG,4,T,DE,iDE,gamfact,epsQg_sedi,afg,bfg,icmg,dmg,ckQg1,ckQg4,    &
+                      ni,nk,VgMax,DgMax,dt,DZ,fluxM_g,No_g_SM,ktop_sedi,GRAV)
+   endif
+
+
+!--  HAIL sedimentation:
+   if (DblMom_h) then
+     call SEDI_main_2(QH,NH,5,Q,T,DE,iDE,gamfact,epsQh_sedi,epsN,afh,bfh,cmh,dmh,ckQh1,  &
+                      ckQh2,ckQh4,LSP,ni,nk,VhMax,DhMax,dt,DZ,fluxM_h,ktop_sedi,GRAV)
+   else
+     call SEDI_main_1b(QH,5,T,DE,iDE,gamfact,epsQh_sedi,afh,bfh,icmh,dmh,ckQh1,ckQh4,    &
+                      ni,nk,VhMax,DhMax,dt,DZ,fluxM_h,No_h_SM,ktop_sedi,GRAV)
+   endif
+
+!=======  End of sedimentation for each category ========!
+
+!---  Impose constraints on size distribution parameters ---!
+   do k= 1,nk
+      do i= 1,ni
+
+       !snow:
+         if (QN(i,k)>epsQ .and. NN(i,k)>epsN) then
+
+         !Impose No_s max for snow: (assumes alpha_s=0.)
+            iLAMs  = max( iLAMmin2, iLAMDA_x(DE(i,k),QN(i,k), 1./NN(i,k),iGS20,idms) )
+            tmp1   = min(NN(i,k)/iLAMs,No_s_max)                 !min. No_s
+            NN(i,k)= tmp1**(dms/(1.+dms))*(iGS20*DE(i,k)*QN(i,k))**(1./(1.+dms)) !impose Nos_max
+
+         !Impose LAMDAs_min (by increasing LAMDAs if it is below LAMDAs_min2 [2xLAMDAs_min])
+            iLAMs  = max( iLAMmin2, iLAMDA_x(DE(i,k),QN(i,k),1./NN(i,k),iGS20,idms) )
+            tmp2   = 1./iLAMs                                   !LAMs before adjustment
+           !adjust value of lamdas_min to be applied:
+           !  This adjusts for multiple corrections (each time step).  The factor 0.6 was obtained by
+           !  trial-and-error to ultimately give reasonable LAMs profiles, smooth and with min LAMs~lamdas_min
+            tmp4   = 0.6*lamdas_min
+            tmp5   = 2.*tmp4
+            tmp3   = tmp2 + tmp4*(max(0.,tmp5-tmp2)/tmp5)**2.   !LAMs after adjustment
+            tmp3   = max(tmp3, lamdas_min)                      !final correction
+            NN(i,k)= NN(i,k)*(tmp3*iLAMs)**dms                  !re-compute NN after LAMs adjustment
+         endif
+
+      enddo !i-loop
+   enddo !k-loop
+!===
+
+  !Compute melted (liquid-equivalent) volume fluxes [m3 (liquid) m-2 (sfc area) s-1]:
+  !  (note: For other precipitation schemes in RPN-CMC physics, this is computed in 'vkuocon6.ftn')
+   RT_rn1 = fluxM_r *idew
+   RT_sn1 = fluxM_i *idew
+   RT_sn2 = fluxM_s *idew
+   RT_sn3 = fluxM_g *idew
+   RT_pe1 = fluxM_h *idew
+
+!----
+  !Compute sum of solid (unmelted) volume fluxes [m3 (bulk hydrometeor) m-2 (sfc area) s-1]:
+  !(this is the precipitation rate for UNmelted total snow [i+s+g])
+
+  !    Note:  In 'calcdiagn.ftn', the total solid precipitation (excluding hail) SN is computed
+  !           from the sum of the liq-eq.vol fluxes, tss_sn1 + tss_sn2 + tss_sn3.  With the
+  !           accumulation of SND (in 'calcdiag.ftn'), the solid-to-liquid ratio for the total
+  !           accumulated "snow" (i+s+g) can be compute as SND/SN.  Likewise, the instantaneous
+  !           solid-to-liquid ratio of solid precipitation is computed (in 'calcdiag.ftn') as
+  !           RS2L = RSND/RSN.
+
+   do i= 1,ni
+
+      fluxV_i= fluxM_i(i)*idei
+      fluxV_g= fluxM_g(i)*ideg
+     !Compute unmelted volume flux for snow:
+         ! note: This is based on the strict calculation of the volume flux, where vol=(pi/6)D^3,
+         !       and remains in the integral calculation Fv = int[V(D)*vol(D)*N(D)*dD].
+         !       For a constant density (ice and graupel), vol(D) = m(D)/dex, dex comes out of
+         !       integral and Fv_x=Fm_x/dex
+         !       Optimized for alpha_s = 0.
+      if (QN(i,nk)>epsQ .and. NN(i,nk)>epsN .and. fluxM_s(i)>0.) then
+         tmp1= 1./iLAMDA_x(DE(i,nk),QN(i,nk),1./NN(i,nk),iGS20,idms) !LAMDA_s
+         fluxV_s= fluxM_s(i)*rfact_FvFm*tmp1**(dms-3.)
+      else
+         fluxV_s=0.
+      endif
+
+     !total solid unmelted volume flux, before accounting for partial melting:
+      tmp1= fluxV_i + fluxV_g + fluxV_s
+
+     !liquid-fraction of partially-melted solid precipitation:
+     !  The physical premise is that if QR>0, QN+QI+QG>0, and T>0, then QR
+     !  originates from melting and can be used to estimate the liquid portion
+     !  of the partially-melted solid hydrometeor.
+      tmp2= QR(i,nk) + QI(i,nk) + QN(i,nk) + QG(i,nk)
+      if (T(i,nk)>TRPL .and. tmp2>epsQ) then
+         fracLiq= QR(i,nk)/tmp2
+      else
+         fracLiq= 0.
+      endif
+
+     !Tend total volume flux towards the liquid-equivalent as the liquid-fraction increases to 1:
+      tmp3= RT_sn1(i) + RT_sn2(i) + RT_sn3(i)      !total liquid-equivalent volume flux    (RSN,  Fv_sol)
+      RT_snd(i)= (1.-fracLiq)*tmp1 + fracLiq*tmp3  !total volume flux with partial melting (RSND, Fvsle_sol)
+      !Note:  Calculation of instantaneous solid-to-liquid ratio [RS2L = RSND/RSN]
+      !       is based on the above quantities and is done on 'calcdiag.ftn'.
+
+   enddo  !i-loop
+!====
+
+ !++++
+ ! Diagnose surface precipitation types:
+ !
+ ! The following involves diagnostic conditions to determine surface precipitation rates
+ ! for various precipitation elements defined in Canadian Meteorological Operational Internship
+ ! Program module 3.1 (plus one for large hail) based on the sedimentation rates of the five
+ ! sedimenting hydrometeor categories.
+ !
+ ! With the diagnostics shut off (precipDiag_ON=.false.), 5 rates are just the 5 category
+ ! rates, with the other 6 rates just 0.  The model output variables will have:
+ !
+ !   total liquid = RT_rn1 [RAIN]
+ !   total solid  = RT_sn1 [ICE] + RT_sn2 [SNOW] + RT_sn3 [GRAUPEL] + RT_pe1 [HAIL]
+ !
+ ! With the diagnostics on, the 5 sedimentation rates are partitioned into 9 rates,
+ ! with the following model output variable:
+ !
+ !  total liquid = RT_rn1 [liquid rain] + RT_rn2 [liquid drizzle]
+ !  total solid  = RT_fr1 [freezing rain] + RT_fr2 [freezing drizzle] + RT_sn1 [ice crystals] +
+ !                 RT_sn2 [snow] + RT_sn3 [graupel] + RT_pe1 [ice pellets] + RT_pe2 [hail]
+ !
+ ! NOTE:  - The above total liquid/solid rates are computed in 'calcdiag.ftn' (as R2/R4).
+ !        - RT_peL [large hail] is a sub-set of RT_pe2 [hail] and is thus not added to the total
+ !          solid precipitation.
+
+!   call tmg_start0(98,'mmCalcDIAG')
+
+   IF (precipDiag_ON) THEN
+      DO i= 1,ni
+
+         DE(i,nk)= S(i,nk)*PS(i)/(RGASD*T(i,nk))
+
+      !rain vs. drizzle:
+         if (DblMom_r) then
+            N_r= NR(i,nk)
+         else
+            N_r= (No_r*GR31)**(3./(4.+alpha_r))*(GR31*iGR34*DE(i,nk)*QR(i,nk)*icmr)**    &
+                  ((1.+alpha_r)/(4.+alpha_r))             !i.e. NR = f(No_r,QR)
+         endif
+         if (QR(i,nk)>epsQ .and. N_r>epsN) then
+            Dm_r(i,nk)= (DE(i,nk)*icmr*QR(i,nk)/N_r)**thrd
+            if (Dm_r(i,nk)>Dr_large) then  !Dr_large is rain/drizzle size threshold
+               RT_rn2(i)= RT_rn1(i);   RT_rn1(i)= 0.
+            endif
+         endif
+
+      !liquid vs. freezing rain or drizzle:
+         if (T(i,nk)<TRPL) then
+            RT_fr1(i)= RT_rn1(i);   RT_rn1(i)= 0.
+            RT_fr2(i)= RT_rn2(i);   RT_rn2(i)= 0.
+         endif
+
+      !ice pellets vs. hail:
+         if (T(i,nk)>(TRPL+5.0)) then
+         !note: The condition (T_sfc<5C) for ice pellets is a simply proxy for the presence
+         !      of a warm layer aloft, though which falling snow or graupel will melt to rain,
+         !      over a sub-freezinglayer, where the rain will freeze into the 'hail' category
+            RT_pe2(i)= RT_pe1(i);   RT_pe1(i)= 0.
+         endif
+
+      !large hail:
+         if (QH(i,nk)>epsQ) then
+            if (DblMom_h) then
+               N_h= NH(i,nk)
+            else
+               N_h= (No_h_SM*GH31)**(3./(4.+alpha_h))*(GH31*iGH34*DE(i,nk)*QH(i,nk)*     &
+                  icmh)**((1.+alpha_h)/(4.+alpha_h))   !i.e. Nh = f(No_h,Qh)
+            endif
+            Dm_h(i,nk)= Dm_x(DE(i,nk),QH(i,nk),1./N_h,icmh,thrd)
+            if (DM_h(i,nk)>Dh_large) RT_peL(i)= RT_pe2(i)
+            !note: large hail (RT_peL) is a subset of the total hail (RT_pe2)
+         endif
+
+      ENDDO
+   ENDIF  !if (precipDiag_ON)
+ !
+ !++++
+
+ ELSE
+
+    massFlux3D_r= 0.
+    massFlux3D_s= 0.
+
+ ENDIF  ! if (sedi_ON)
+
+ where (Q<0.) Q= 0.
+
+ !-----------------------------------------------------------------------------------!
+ !                     End of sedimentation calculations (Part 4)                    !
+ !-----------------------------------------------------------------------------------!
+
+
+ !===================================================================================!
+ !                             End of microphysics scheme                            !
+ !===================================================================================!
+
+ !-----------------------------------------------------------------------------------!
+ !                    Calculation of diagnostic output variables:                    !
+
+  IF (calcDiag) THEN
+
+   !For reflectivity calculations:
+     ZEC= minZET
+     cxr=            icmr*icmr   !for rain
+     cxi= 1./fdielec*icmr*icmr   !for all frozen categories
+     Gzr= (6.+alpha_r)*(5.+alpha_r)*(4.+alpha_r)/((3.+alpha_r)*(2.+alpha_r)*(1.+alpha_r))
+     Gzi= (6.+alpha_i)*(5.+alpha_i)*(4.+alpha_i)/((3.+alpha_i)*(2.+alpha_i)*(1.+alpha_i))
+     if (snowSpherical) then  !dms=3
+        Gzs= (6.+alpha_s)*(5.+alpha_s)*(4.+alpha_s)/((3.+alpha_s)*(2.+alpha_s)*          &
+             (1.+alpha_s))
+     else                     !dms=2
+        Gzs= (4.+alpha_s)*(3.+alpha_s)/((2.+alpha_s)*(1.+alpha_s))
+     endif
+     Gzg= (6.+alpha_g)*(5.+alpha_g)*(4.+alpha_g)/((3.+alpha_g)*(2.+alpha_g)*(1.+alpha_g))
+     Gzh= (6.+alpha_h)*(5.+alpha_h)*(4.+alpha_h)/((3.+alpha_h)*(2.+alpha_h)*(1.+alpha_h))
+
+     do k= 1,nk
+       do i= 1,ni
+           DE(i,k)= S(i,k)*PS(i)/(RGASD*T(i,k))
+           tmp9= DE(i,k)*DE(i,k)
+
+        !Compute N_x for single-moment categories:
+           if (DblMom_c) then
+              N_c= NC(i,k)
+           else
+              N_c= N_c_SM
+           endif
+           if (DblMom_r) then
+              N_r= NR(i,k)
+           else
+              N_r= (No_r_SM*GR31)**(3./(4.+alpha_r))*(GR31*iGR34*DE(i,k)*QR(i,k)*icmr)** &
+                   ((1.+alpha_r)/(4.+alpha_r))             !i.e. NR = f(No_r,QR)
+           endif
+           if (DblMom_i) then
+              N_i= NY(i,k)
+           else
+              N_i= N_Cooper(TRPL,T(i,k))
+           endif
+           if (DblMom_s) then
+              N_s= NN(i,k)
+           else
+              No_s= Nos_Thompson(TRPL,T(i,k))
+              N_s = (No_s*GS31)**(dms/(1.+dms+alpha_s))*(GS31*iGS34*DE(i,k)*QN(i,k)*     &
+                    icms)**((1.+alpha_s)/(1.+dms+alpha_s))
+           endif
+           if (DblMom_g) then
+              N_g= NG(i,k)
+           else
+              N_g= (No_g_SM*GG31)**(3./(4.+alpha_g))*(GG31*GG34*DE(i,k)*QG(i,k)*icmg)**  &
+                   ((1.+alpha_g)/(4.+alpha_g))             !i.e. NX = f(No_x,QX)
+           endif
+           if (DblMom_h) then
+              N_h= NH(i,k)
+           else
+              N_h= (No_h_SM*GH31)**(3./(4.+alpha_h))*(GH31*iGH34*DE(i,k)*QH(i,k)*icmh)** &
+                   ((1.+alpha_h)/(4.+alpha_h))             !i.e. NX = f(No_x,QX)
+           endif
+
+        !Total equivalent reflectivity:     (units of [dBZ])
+           tmp1= 0.;  tmp2= 0.;  tmp3= 0.;  tmp4= 0.;  tmp5= 0.
+           if (QR(i,k)>epsQ .and. N_r>epsN) tmp1 = cxr*Gzr*tmp9*QR(i,k)*QR(i,k)/N_r
+           if (QI(i,k)>epsQ .and. N_i>epsN) tmp2 = cxi*Gzi*tmp9*QI(i,k)*QI(i,k)/N_i
+           if (QN(i,k)>epsQ .and. N_s>epsN) tmp3 = cxi*Gzs*tmp9*QN(i,k)*QN(i,k)/N_s
+           if (QG(i,k)>epsQ .and. N_g>epsN) tmp4 = cxi*Gzg*tmp9*QG(i,k)*QG(i,k)/N_g
+           if (QH(i,k)>epsQ .and. N_h>epsN) tmp5 = cxi*Gzh*tmp9*QH(i,k)*QH(i,k)/N_h
+          !Modifiy dielectric constant for melting ice-phase categories:
+           if ( T(i,k)>TRPL) then
+             tmp2= tmp2*fdielec
+             tmp3= tmp3*fdielec
+             tmp4= tmp4*fdielec
+             tmp5= tmp5*fdielec
+           endif
+           ZET(i,k) = tmp1 + tmp2 + tmp3 + tmp4 + tmp5   != Zr+Zi+Zs+Zg+Zh
+           if (ZET(i,k)>0.) then
+              ZET(i,k)= 10.*log10((ZET(i,k)*Zfact))      !convert to dBZ
+           else
+              ZET(i,k)= minZET
+           endif
+           ZET(i,k)= max(ZET(i,k),minZET)
+           ZEC(i)= max(ZEC(i),ZET(i,k))  !composite (max in column) of ZET
+
+         !Mean-mass diameters:  (units of [m])
+           Dm_c(i,k)= 0.;   Dm_r(i,k)= 0.;   Dm_i(i,k)= 0.
+           Dm_s(i,k)= 0.;   Dm_g(i,k)= 0.;   Dm_h(i,k)= 0.
+           if(QC(i,k)>epsQ.and.N_c>epsN) Dm_c(i,k)=Dm_x(DE(i,k),QC(i,k),1./N_c,icmr,thrd)
+           if(QR(i,k)>epsQ.and.N_r>epsN) Dm_r(i,k)=Dm_x(DE(i,k),QR(i,k),1./N_r,icmr,thrd)
+           if(QI(i,k)>epsQ.and.N_i>epsN) Dm_i(i,k)=Dm_x(DE(i,k),QI(i,k),1./N_i,icmi,thrd)
+           if(QN(i,k)>epsQ.and.N_s>epsN) Dm_s(i,k)=Dm_x(DE(i,k),QN(i,k),1./N_s,icms,idms)
+           if(QG(i,k)>epsQ.and.N_g>epsN) Dm_g(i,k)=Dm_x(DE(i,k),QG(i,k),1./N_g,icmg,thrd)
+           if(QH(i,k)>epsQ.and.N_h>epsN) Dm_h(i,k)=Dm_x(DE(i,k),QH(i,k),1./N_h,icmh,thrd)
+
+         !Supercooled liquid water:
+           SLW(i,k)= 0.
+           if (T(i,k)<TRPL) SLW(i,k)= DE(i,k)*(QC(i,k)+QR(i,k))   !(units of [kg/m3])
+
+         !Visibility:
+          !VIS1:  component through liquid cloud (fog) [m]
+          ! (following parameterization of Gultepe and Milbrandt, 2007)
+           tmp1= QC(i,k)*DE(i,k)*1.e+3             !LWC [g m-3]
+           tmp2= N_c*1.e-6                         !Nc  [cm-3]
+           if (tmp1>0.005 .and. tmp2>1.) then
+              VIS1(i,k)= max(epsVIS,1000.*(1.13*(tmp1*tmp2)**(-0.51))) !based on FRAM [GM2007, eqn (4)
+             !VIS1(i,k)= max(epsVIS,min(maxVIS, (tmp1*tmp2)**(-0.65))) !based on RACE [GM2007, eqn (3)
+           else
+              VIS1(i,k)= 3.*maxVIS  !gets set to maxVIS after calc. of VIS
+           endif
+
+          !VIS2: component through rain  !based on Gultepe and Milbrandt, 2008, Table 2 eqn (1)
+           tmp1= massFlux3D_r(i,k)*idew*3.6e+6                        !rain rate [mm h-1]
+           if (tmp1>0.01) then
+              VIS2(i,k)= max(epsVIS,1000.*(-4.12*tmp1**0.176+9.01))   ![m]
+           else
+              VIS2(i,k)= 3.*maxVIS
+           endif
+
+          !VIS3: component through snow  !based on Gultepe and Milbrandt, 2008, Table 2 eqn (6)
+           tmp1= massFlux3D_s(i,k)*idew*3.6e+6                        !snow rate, liq-eq [mm h-1]
+           if (tmp1>0.01) then
+              VIS3(i,k)= max(epsVIS,1000.*(1.10*tmp1**(-0.701)))      ![m]
+           else
+              VIS3(i,k)= 3.*maxVIS
+           endif
+
+          !VIS:  visibility due to reduction from all components 1, 2, and 3
+          !      (based on sum of extinction coefficients and Koschmieders's Law)
+           VIS(i,k) = min(maxVIS, 1./(1./VIS1(i,k) + 1./VIS2(i,k) + 1./VIS3(i,k)))
+           VIS1(i,k)= min(maxVIS, VIS1(i,k))
+           VIS2(i,k)= min(maxVIS, VIS2(i,k))
+           VIS3(i,k)= min(maxVIS, VIS3(i,k))
+
+        enddo  !i-loop
+     enddo     !k-loop
+
+    !Diagnostic levels:
+     h_CB = noVal_h_XX   !height (AGL) of cloud base
+     h_SN = noVal_h_XX   !height (AGL) of snow level [conventional snow (not just QN>0.)]
+     h_ML1= noVal_h_XX   !height (AGL) of melting level [first 0C isotherm from ground]
+     h_ML2= noVal_h_XX   !height (AGL) of melting level [first 0C isotherm from top]
+                         ! note: h_ML2 = h_ML1 implies only 1 melting level
+     tmp1= 1./GRAV
+     do i= 1,ni
+        CB_found= .false.;   SN_found= .false.;   ML_found= .false.
+        do k= nk,2,-1
+          !cloud base:
+           if ((QC(i,k)>epsQ2.or.QI(i,k)>epsQ2) .and. .not.CB_found)  then
+              h_CB(i) = GZ(i,k)*tmp1
+              CB_found= .true.
+           endif
+          !snow level:
+           if ( ((QN(i,k)>epsQ2 .and. Dm_s(i,k)>minSnowSize)  .or.                       &
+                 (QG(i,k)>epsQ2 .and. Dm_g(i,k)>minSnowSize)) .and. .not.SN_found) then
+              h_SN(i) = GZ(i,k)*tmp1
+              SN_found= .true.
+           endif
+          !melting level: (height of lowest 0C isotherm)
+           if (T(i,k)>TRPL .and. T(i,k-1)<TRPL .and. .not.ML_found) then
+              h_ML1(i) = GZ(i,k)*tmp1
+              ML_found= .true.
+           endif
+        enddo
+     enddo
+     do i= 1,ni
+        ML_found= .false.  !from top
+        do k= 2,nk
+          !melting level: (height of highest 0C isotherm)
+           if (T(i,k)>TRPL .and. T(i,k-1)<TRPL .and. .not.ML_found) then
+              h_ML2(i) = GZ(i,k)*tmp1
+              ML_found= .true.
+           endif
+        enddo
+     enddo
+
+  ENDIF
+ !                                                                                   !
+
+!-------------
+!Convert N from #/m3 to #/kg:
+! note: - at this point, NX is updated NX (at t+1); NXTEND is NX before S/S (at t*)
+!       - NXM is no longer used (it does not need a unit conversion)
+  do k= 1,nk
+     DE(:,k) = S(:,k)*PS(:)/(RGASD*T(:,k))     !air density at time (t)
+     iDE(:,k)= 1./DE(:,k)
+  enddo
+  NC= NC*iDE;   NCTEND= NCTEND*iDE
+  NR= NR*iDE;   NRTEND= NRTEND*iDE
+  NY= NY*iDE;   NYTEND= NYTEND*iDE
+  NN= NN*iDE;   NNTEND= NNTEND*iDE
+  NG= NG*iDE;   NGTEND= NGTEND*iDE
+  NH= NH*iDE;   NHTEND= NHTEND*iDE
+!=============
+
+ !-----------------------------------------------------------------------------------!
+ !   Compute the tendencies of  T, Q, QC, etc. (to be passed back to model dynamics) !
+ !   and reset the fields to their initial (saved) values at time {*}:               !
+
+      do k= 1,nk
+         do i= 1,ni
+
+            tmp1=T_TEND(i,k);  T_TEND(i,k)=(T(i,k) -T_TEND(i,k))*iDT;  T(i,k) = tmp1
+            tmp1=Q_TEND(i,k);  Q_TEND(i,k)=(Q(i,k) -Q_TEND(i,k))*iDT;  Q(i,k) = tmp1
+            tmp1=QCTEND(i,k);  QCTEND(i,k)=(QC(i,k)-QCTEND(i,k))*iDT;  QC(i,k)= tmp1
+            tmp1=QRTEND(i,k);  QRTEND(i,k)=(QR(i,k)-QRTEND(i,k))*iDT;  QR(i,k)= tmp1
+            tmp1=QITEND(i,k);  QITEND(i,k)=(QI(i,k)-QITEND(i,k))*iDT;  QI(i,k)= tmp1
+            tmp1=QNTEND(i,k);  QNTEND(i,k)=(QN(i,k)-QNTEND(i,k))*iDT;  QN(i,k)= tmp1
+            tmp1=QGTEND(i,k);  QGTEND(i,k)=(QG(i,k)-QGTEND(i,k))*iDT;  QG(i,k)= tmp1
+            tmp1=QHTEND(i,k);  QHTEND(i,k)=(QH(i,k)-QHTEND(i,k))*iDT;  QH(i,k)= tmp1
+
+            if (DblMom_c) then
+             tmp1=NCTEND(i,k);  NCTEND(i,k)=(NC(i,k)-NCTEND(i,k))*iDT; NC(i,k)= tmp1
+            endif
+            if (DblMom_r) then
+             tmp1=NRTEND(i,k);  NRTEND(i,k)=(NR(i,k)-NRTEND(i,k))*iDT; NR(i,k)= tmp1
+            endif
+            if (DblMom_i) then
+             tmp1=NYTEND(i,k);  NYTEND(i,k)=(NY(i,k)-NYTEND(i,k))*iDT; NY(i,k)= tmp1
+            endif
+            if (DblMom_s) then
+             tmp1=NNTEND(i,k);  NNTEND(i,k)=(NN(i,k)-NNTEND(i,k))*iDT; NN(i,k)= tmp1
+            endif
+            if (DblMom_g) then
+             tmp1=NGTEND(i,k);  NGTEND(i,k)=(NG(i,k)-NGTEND(i,k))*iDT; NG(i,k)= tmp1
+            endif
+            if (DblMom_h) then
+             tmp1=NHTEND(i,k);  NHTEND(i,k)=(NH(i,k)-NHTEND(i,k))*iDT; NH(i,k)= tmp1
+            endif
+
+         enddo
+      enddo
+ !                                                                                   !
+ !-----------------------------------------------------------------------------------!
+END SUBROUTINE mp_milbrandt2mom_main
+ !___________________________________________________________________________________!
+
+   real function des_OF_Ds(Ds_local,desMax_local,eds_local,fds_local)
+   !Computes density of equivalent-volume snow particle based on (pi/6*des)*Ds^3 = cms*Ds^dms
+      real :: Ds_local,desMax_local,eds_local,fds_local
+!     des_OF_Ds= min(desMax_local, eds_local*Ds_local**fds_local)
+      des_OF_Ds= min(desMax_local, eds_local*exp(fds_local*log(Ds_local)))   !IBM optimization
+   end function des_OF_Ds
+
+
+   real function Dm_x(DE_local,QX_local,iNX_local,icmx_local,idmx_local)
+   !Computes mean-mass diameter
+      real :: DE_local,QX_local,iNX_local,icmx_local,idmx_local
+     !Dm_x = (DE_local*QX_local*iNX_local*icmx_local)**idmx_local
+      Dm_x = exp(idmx_local*log(DE_local*QX_local*iNX_local*icmx_local))     !IBM optimization
+   end function Dm_x
+
+
+   real function iLAMDA_x(DE_local,QX_local,iNX_local,icex_local,idmx_local)
+   !Computes 1/LAMDA ("slope" parameter):
+      real :: DE_local,QX_local,iNX_local,icex_local,idmx_local
+     !iLAMDA_x = (DE_local*QX_local*iNX_local*icex_local)**idmx_local
+      iLAMDA_x = exp(idmx_local*log(DE_local*QX_local*iNX_local*icex_local)) !IBM optimization
+   end function
+
+
+   real function N_Cooper(TRPL_local,T_local)
+   !Computes total number concentration of ice as a function of temperature
+   !according to parameterization of Cooper (1986):
+      real :: TRPL_local,T_local
+      N_Cooper= 5.*exp(0.304*(TRPL_local-max(233.,T_local)))
+   end function N_Cooper
+
+   real function Nos_Thompson(TRPL_local,T_local)
+   !Computes the snow intercept, No_s, as a function of temperature
+   !according to the parameterization of Thompson et al. (2004):
+      real :: TRPL_local,T_local
+      Nos_Thompson= min(2.e+8, 2.e+6*exp(-0.12*min(-0.001,T_local-TRPL_local)))
+   end function Nos_Thompson
+
+!===================================================================================================!
+
+END MODULE my_dmom_mod
+
+!________________________________________________________________________________________!
+
+ MODULE module_mp_milbrandt2mom
+
+      use module_wrf_error
+      use my_dmom_mod
+
+      implicit none
+
+! To be done later.  Currently, parameters are initialized in the main routine
+! (at every time step).
+
+      CONTAINS
+
+!----------------------------------------------------------------------------------------!
+      SUBROUTINE milbrandt2mom_init
+
+! To be done later.  Currently, parameters are initialized in the main routine (at every time step).
+
+      END SUBROUTINE milbrandt2mom_init
+
+!----------------------------------------------------------------------------------------!
+
+ !+---------------------------------------------------------------------+
+ ! This is a wrapper routine designed to transfer values from 3D to 2D. !
+ !+---------------------------------------------------------------------+
+
+
+      SUBROUTINE mp_milbrandt2mom_driver(qv, qc, qr, qi, qs, qg, qh, nc, nr, ni, ns, ng,  &
+                              nh, th, pii, p, w, dz, dt_in, itimestep,                    &
+                              RAINNC, RAINNCV, SNOWNC, SNOWNCV, GRPLNC, GRPLNCV,          &
+!                             HAILNC, HAILNCV, SR, Zet, ccntype,                          &
+                              HAILNC, HAILNCV, SR, Zet,                                   &
+                              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,qh,nc,nr,ni,ns,ng,nh,th,Zet
+      real, dimension(ims:ime, kms:kme, jms:jme), intent(in)::                           &
+                            pii,p,w,dz
+      real, dimension(ims:ime, jms:jme), intent(inout)::                                 &
+                            RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,HAILNC,HAILNCV, &
+                            SR
+      real, intent(in)::    dt_in
+      integer, intent(in):: itimestep !, ccntype
+
+ !Local variables:
+      real, dimension(1:ite-its+1,1:kte-kts+1) :: t2d,qv2d,qc2d,qr2d,qi2d,qs2d,qg2d,qh2d,&
+            nc2d,nr2d,ni2d,ns2d,ng2d,nh2d,p2d,dz2d,rho,irho,omega2d,t2d_m,qv2d_m,qc2d_m, &
+            qr2d_m,qi2d_m,qs2d_m,qg2d_m,qh2d_m,nc2d_m,nr2d_m,ni2d_m,ns2d_m,ng2d_m,nh2d_m,&
+            sigma2d,tmp01,tmp02,tmp03,tmp04,tmp05,tmp06,tmp07,tmp08,tmp09,tmp10,tmp11,   &
+            tmp12,tmp13,tmp14,tmp15,tmp16,tmp17,tmp18,gz2d,zet2d
+
+     !tentatively local; to be passed out as output variables later
+      real, dimension(1:ite-its+1,1:kte-kts+1) :: Dm_c,Dm_r,Dm_i,Dm_s,Dm_g,Dm_h,         &
+            SLW,VIS,VIS1,VIS2,VIS3,SS01,SS02,SS03,SS04,SS05,SS06,SS07,SS08,SS09,SS10,    &
+            SS11,SS12,SS13,SS14,SS15,SS16,SS17,SS18,SS19,SS20,T_tend,Q_tend,QCtend,      &
+            QRtend,QItend,QStend,QGtend,QHtend,NCtend,NRtend,NItend,NStend,NGtend,NHtend
+
+      real, dimension(1:ite-its+1) :: rt_rn1,rt_rn2,rt_fr1,rt_fr2,rt_sn1,rt_sn2,rt_sn3,  &
+            rt_pe1,rt_pe2,rt_peL,rt_snd,ZEC,h_CB,h_ML1,h_ML2,h_SN,p_src
+
+      real    :: dt,ms2mmstp
+      real    :: qc_max,qr_max,qs_max,qi_max,qg_max,qh_max,nc_max,nr_max,ns_max,ni_max,  &
+                 ng_max,nh_max
+      integer :: i,j,k,i2d,j2d,k2d,i2d_max,k2d_max
+      integer :: imax_qc, imax_qr, imax_qi, imax_qs, imax_qg, imax_qh
+      integer :: imax_nc, imax_nr, imax_ni, imax_ns, imax_ng, imax_nh
+      integer :: jmax_qc, jmax_qr, jmax_qi, jmax_qs, jmax_qg, jmax_qh
+      integer :: jmax_nc, jmax_nr, jmax_ni, jmax_ns, jmax_ng, jmax_nh
+      integer :: kmax_qc, kmax_qr, kmax_qi, kmax_qs, kmax_qg, kmax_qh
+      integer :: kmax_nc, kmax_nr, kmax_ni, kmax_ns, kmax_ng, kmax_nh
+      integer :: i_start, j_start, i_end, j_end, CCNtype
+      logical :: precipDiag_ON,sedi_ON,warmphase_ON,autoconv_ON,icephase_ON,snow_ON,     &
+                 initN,dblMom_c,dblMom_r,dblMom_i,dblMom_s,dblMom_g,dblMom_h
+
+      real, parameter :: ms2mmh = 3.6e+6   !conversion factor for precipitation rates
+      real, parameter :: R_d    = 287.04   !gas constant for dry air
+      character*512   :: mp_debug
+!+---+
+      i2d_max = ite-its+1
+      k2d_max = kte-kts+1
+
+      dt = dt_in
+      ms2mmstp = 1.e+3*dt    !conversion factor: m/2 to mm/step
+
+   !--- temporary initialization (until variables are put as namelist options:
+!     CCNtype       = 1.  !maritime      --> N_c =  80 cm-3 for dblMom_c = .F.
+      CCNtype       = 2.  !continental   --> N_c = 200 cm-3 for dblMom_c = .F.
+
+      precipDiag_ON = .true.;     dblMom_c = .true.
+      sedi_ON       = .true.;     dblMom_r = .true.
+      warmphase_ON  = .true.;     dblMom_i = .true.
+      autoconv_ON   = .true.;     dblMom_s = .true.
+      icephase_ON   = .true.;     dblMom_g = .true.
+      snow_ON       = .true.;     dblMom_h = .true.
+      initN         = .true.
+   !---
+
+
+      qc_max = 0.;   nc_max = 0.
+      qr_max = 0.;   nr_max = 0.
+      qi_max = 0.;   ni_max = 0.
+      qs_max = 0.;   ns_max = 0.
+      qg_max = 0.;   ng_max = 0.
+      qh_max = 0.;   nh_max = 0.
+
+      imax_qc = 0;   imax_nc = 0;   jmax_qc = 0;   jmax_nc = 0;   kmax_qc = 0;   kmax_nc = 0
+      imax_qr = 0;   imax_nr = 0;   jmax_qr = 0;   jmax_nr = 0;   kmax_qr = 0;   kmax_nr = 0
+      imax_qi = 0;   imax_ni = 0;   jmax_qi = 0;   jmax_ni = 0;   kmax_qi = 0;   kmax_ni = 0
+      imax_qs = 0;   imax_ns = 0;   jmax_qs = 0;   jmax_ns = 0;   kmax_qs = 0;   kmax_ns = 0
+      imax_qg = 0;   imax_ng = 0;   jmax_qg = 0;   jmax_ng = 0;   kmax_qg = 0;   kmax_ng = 0
+      imax_qh = 0;   imax_nh = 0;   jmax_qh = 0;   jmax_nh = 0;   kmax_qh = 0;   kmax_nh = 0
+
+      RAINNCV = 0.
+      SNOWNCV = 0.
+      GRPLNCV = 0.
+      HAILNCV = 0.
+      SR      = 0.
+
+      do i = 1, 512
+         mp_debug(i:i) = char(0)
+      enddo
+
+      j_loop1:  do j = jts, jte
+
+         j2d = j-jts+1  !index value for 2D arrays, to be passed to main micro scheme
+
+       i_loop1:  do i = its, ite
+
+         i2d = i-its+1  !index value for 2D arrays, to be passed to main micro scheme
+
+        !Approximate geopotential:
+        ! (assumes lowest model level is at sea-level; acceptable for purposes of scheme)
+         gz2d(i2d,kts)= 0.
+         do k = kts+1, kte
+             gz2d(i2d,k)= gz2d(i2d,k-1) + dz(i,k,j)*9.81
+         enddo
+
+         k_loop1:  do k = kts, kte
+            k2d = k-kts+1  !index value for 2D arrays, to be passed to main micro scheme
+
+         !Note: The 3D number concentration variables (seen by WRF dynamics) are in units of 1/kg.
+         !      However, the 2D variables must be converted to units of 1/m3 (by multiplying by air
+         !      density) before being passed to the main subroutine mp_milbrandtsmom.  They are then
+         !      converted back after the call, upon putting them back from 2D to 3D variables.
+
+         !Convert 3D to 2D arrays (etc.):
+            t2d(i2d,k2d)  = th(i,k,j)*pii(i,k,j)
+            p2d(i2d,k2d)  = p(i,k,j)
+            dz2d(i2d,k2d) = dz(i,k,j)
+            qv2d(i2d,k2d) = qv(i,k,j)
+          !chen  rho(i2d,k2d)  = p2d(i2d,k2d)/(R_d*t2d(i2d,k2d))
+          !chen  omega2d(i2d,k2d)= -w(i,k,j)*p2d(i2d,k2d)*9.81
+            rho(i2d,k2d)  = p2d(i2d,k)/(R_d*t2d(i2d,k))
+            omega2d(i2d,k2d)= -w(i,k,j)*rho(i2d,k2d)*9.81
+            qc2d(i2d,k2d) = qc(i,k,j);   nc2d(i2d,k2d) = nc(i,k,j)
+            qi2d(i2d,k2d) = qi(i,k,j);   ni2d(i2d,k2d) = ni(i,k,j)
+            qr2d(i2d,k2d) = qr(i,k,j);   nr2d(i2d,k2d) = nr(i,k,j)
+            qs2d(i2d,k2d) = qs(i,k,j);   ns2d(i2d,k2d) = ns(i,k,j)
+            qg2d(i2d,k2d) = qg(i,k,j);   ng2d(i2d,k2d) = ng(i,k,j)
+            qh2d(i2d,k2d) = qh(i,k,j);   nh2d(i2d,k2d) = nh(i,k,j)
+            sigma2d(i2d,k2d)= p2d(i2d,k2d)/p2d(i2d,kte-kts+1)
+
+         enddo k_loop1
+
+           K_loop9: do k= kts, kte
+            k2d = k-kts+1  !index value for 2D arrays, to be passed to main micro scheme
+            sigma2d(i2d,k2d)= p2d(i2d,k2d)/p2d(i2d,kte-kts+1)
+           enddo K_loop9
+
+       enddo i_loop1
+
+       p_src(:)= p2d(:,k2d_max)
+
+      !Flip arrays: (to conform to vertical leveling in GEM)
+        ! Note:  This step (and the flipping back) could be avoided by changing the indexing
+        !        in the sedimentation subroutine.  It is done this way to allow for directly
+        !        pasting the GEM code directly into this subdriver without having to change
+        !        the code.
+       tmp01= omega2d;  tmp02= t2d;  tmp03= qv2d;  tmp04= qc2d;  tmp05=qr2d;  tmp06=qi2d
+       tmp07= qs2d;     tmp08= qg2d; tmp09= qh2d;  tmp10= nc2d;  tmp11=nr2d;  tmp12=ni2d
+       tmp13= ns2d;     tmp14= ng2d; tmp15= nh2d;  tmp16= sigma2d; tmp17=dz2d; tmp18=gz2d
+       do k = kts-1,kte-1
+          k2d = k-kts+1
+          omega2d(:,k2d+1)= tmp01(:,k2d_max-k2d)
+          t2d(:,k2d+1)    = tmp02(:,k2d_max-k2d)
+          qv2d(:,k2d+1)   = tmp03(:,k2d_max-k2d)
+          qc2d(:,k2d+1)   = tmp04(:,k2d_max-k2d)
+          qr2d(:,k2d+1)   = tmp05(:,k2d_max-k2d)
+          qi2d(:,k2d+1)   = tmp06(:,k2d_max-k2d)
+          qs2d(:,k2d+1)   = tmp07(:,k2d_max-k2d)
+          qg2d(:,k2d+1)   = tmp08(:,k2d_max-k2d)
+          qh2d(:,k2d+1)   = tmp09(:,k2d_max-k2d)
+          nc2d(:,k2d+1)   = tmp10(:,k2d_max-k2d)
+          nr2d(:,k2d+1)   = tmp11(:,k2d_max-k2d)
+          ni2d(:,k2d+1)   = tmp12(:,k2d_max-k2d)
+          ns2d(:,k2d+1)   = tmp13(:,k2d_max-k2d)
+          ng2d(:,k2d+1)   = tmp14(:,k2d_max-k2d)
+          nh2d(:,k2d+1)   = tmp15(:,k2d_max-k2d)
+          sigma2d(:,k2d+1)= tmp16(:,k2d_max-k2d)
+          dz2d(:,k2d+1)   = tmp17(:,k2d_max-k2d)
+          gz2d(:,k2d+1)   = tmp18(:,k2d_max-k2d)
+       enddo
+
+      !Copy 2d arrays xx2d to xx2d_m: (to facilitate inclusion of main milbrandt2mom
+      ! subroutine which uses arrays at two different time levels, for GEM model)
+       t2d_m  = t2d;    qv2d_m = qv2d
+       qc2d_m = qc2d;   nc2d_m = nc2d
+       qr2d_m = qr2d;   nr2d_m = nr2d
+       qi2d_m = qi2d;   ni2d_m = ni2d
+       qs2d_m = qs2d;   ns2d_m = ns2d
+       qg2d_m = qg2d;   ng2d_m = ng2d
+       qh2d_m = qh2d;   nh2d_m = nh2d
+       call mp_milbrandt2mom_main(omega2d,t2d,qv2d,qc2d,qr2d,qi2d,qs2d,qg2d,qh2d,nc2d,   &
+            nr2d,ni2d,ns2d,ng2d,nh2d,p_src,t2d_m,qv2d_m,qc2d_m,qr2d_m,qi2d_m,qs2d_m,     &
+            qg2d_m,qh2d_m,nc2d_m,nr2d_m,ni2d_m,ns2d_m,ng2d_m,nh2d_m,p_src,sigma2d,       &
+            rt_rn1,rt_rn2,rt_fr1,rt_fr2,rt_sn1,rt_sn2,rt_sn3,rt_pe1,rt_pe2,rt_peL,rt_snd,&
+            gz2d,T_tend,Q_tend,QCtend,QRtend,QItend,QStend,QGtend,QHtend,NCtend,NRtend,  &
+            NItend,NStend,NGtend,NHtend,dt,i2d_max,1,k2d_max,j,itimestep,CCNtype,precipDiag_ON,&
+            sedi_ON,warmphase_ON,autoconv_ON,icephase_ON,snow_ON,initN,dblMom_c,dblMom_r,&
+            dblMom_i,dblMom_s,dblMom_g,dblMom_h,Dm_c,Dm_r,Dm_i,Dm_s,Dm_g,Dm_h,Zet2d,ZEC, &
+            SLW,VIS,VIS1,VIS2,VIS3,h_CB,h_ML1,h_ML2,h_SN,SS01,SS02,SS03,SS04,SS05,SS06,  &
+            SS07,SS08,SS09,SS10,SS11,SS12,SS13,SS14,SS15,SS16,SS17,SS18,SS19,SS20)
+
+      !Add tendencies:
+       t2d(:,:) = t2d(:,:)  + T_tend(:,:)*dt
+       qv2d(:,:)= qv2d(:,:) + Q_tend(:,:)*dt
+       qc2d(:,:)= qc2d(:,:) + QCtend(:,:)*dt;  nc2d(:,:)= nc2d(:,:) + NCtend(:,:)*dt
+       qr2d(:,:)= qr2d(:,:) + QRtend(:,:)*dt;  nr2d(:,:)= nr2d(:,:) + NRtend(:,:)*dt
+       qi2d(:,:)= qi2d(:,:) + QItend(:,:)*dt;  ni2d(:,:)= ni2d(:,:) + NItend(:,:)*dt
+       qs2d(:,:)= qs2d(:,:) + QStend(:,:)*dt;  ns2d(:,:)= ns2d(:,:) + NStend(:,:)*dt
+       qg2d(:,:)= qg2d(:,:) + QGtend(:,:)*dt;  ng2d(:,:)= ng2d(:,:) + NGtend(:,:)*dt
+       qh2d(:,:)= qh2d(:,:) + QHtend(:,:)*dt;  nh2d(:,:)= nh2d(:,:) + NHtend(:,:)*dt
+
+
+      !Flip arrays back : (to conform to vertical leveling in WRF)
+       tmp02= t2d;    tmp03= qv2d; tmp04= qc2d;  tmp05=qr2d;   tmp06=qi2d
+       tmp07= qs2d;   tmp08= qg2d; tmp09= qh2d;  tmp10= nc2d;  tmp11=nr2d;  tmp12=ni2d
+       tmp13= ns2d;   tmp14= ng2d; tmp15= nh2d;  tmp16= Zet2d; tmp17=ss01;  tmp18=ss02
+       do k = kts-1,kte-1
+          k2d = k-kts+1
+          t2d(:,k2d+1)    = tmp02(:,k2d_max-k2d)
+          qv2d(:,k2d+1)   = tmp03(:,k2d_max-k2d)
+          qc2d(:,k2d+1)   = tmp04(:,k2d_max-k2d)
+          qr2d(:,k2d+1)   = tmp05(:,k2d_max-k2d)
+          qi2d(:,k2d+1)   = tmp06(:,k2d_max-k2d)
+          qs2d(:,k2d+1)   = tmp07(:,k2d_max-k2d)
+          qg2d(:,k2d+1)   = tmp08(:,k2d_max-k2d)
+          qh2d(:,k2d+1)   = tmp09(:,k2d_max-k2d)
+          nc2d(:,k2d+1)   = tmp10(:,k2d_max-k2d)
+          nr2d(:,k2d+1)   = tmp11(:,k2d_max-k2d)
+          ni2d(:,k2d+1)   = tmp12(:,k2d_max-k2d)
+          ns2d(:,k2d+1)   = tmp13(:,k2d_max-k2d)
+          ng2d(:,k2d+1)   = tmp14(:,k2d_max-k2d)
+          nh2d(:,k2d+1)   = tmp15(:,k2d_max-k2d)
+          Zet2d(:,k2d+1)  = tmp16(:,k2d_max-k2d)
+       enddo
+       i_loop2:  do i = its, ite
+         i2d = i-its+1
+
+       !Convert individual precipitation rates (in m/s) to WRF precipitation fields:
+       !  note:  RAINNC is not actually "rain"; it is the total precipitation.
+       !         The liquid precipitation is the total multiplied by the liquid fraction,
+       !         --> rain = RAINNC*(1-SR)  (done elsewhere in WRF)
+
+         RAINNCV(i,j) = (rt_rn1(i2d)+rt_rn2(i2d)+rt_fr1(i2d)+rt_fr2(i2d)+rt_sn1(i2d)+         &
+                         rt_sn2(i2d)+rt_sn3(i2d)+rt_pe1(i2d)+rt_pe2(i2d))*ms2mmstp
+         SNOWNCV(i,j) = (rt_sn1(i2d) + rt_sn2(i2d))*ms2mmstp
+         HAILNCV(i,j) = (rt_pe1(i2d) + rt_pe2(i2d))*ms2mmstp
+         GRPLNCV(i,j) =              rt_sn3(i2d) *ms2mmstp
+         RAINNC(i,j)  = RAINNC(i,j) + RAINNCV(i,j)
+         SNOWNC(i,j)  = SNOWNC(i,j) + SNOWNCV(i,j)
+         HAILNC(i,j)  = HAILNC(i,j) + HAILNCV(i,j)
+         GRPLNC(i,j)  = GRPLNC(i,j) + GRPLNCV(i,j)
+         SR(i,j)      = (SNOWNCV(i,j)+HAILNCV(i,j)+GRPLNCV(i,j))/(RAINNCV(i,j)+1.e-12)
+
+         k_loop2:  do k = kts, kte
+            k2d = k-kts+1
+            if(.not.(t2d(i2d,k2d)>=173.) .or. (t2d(i2d,k2d)>1000.)) then
+               write(6,*)
+               write(6,*) '*** Stopping in mp_milbrandt2mom_driver due to unrealistic temperature ***'
+               write(6,*) ' step: ',itimestep
+               write(6,'(a5,5i5,8e15.5)') 'i,k: ',i,j,k,i2d,k2d,t2d(i2d,k2d),qv2d(i2d,k2d),qc2d(i2d,k2d),qr2d(i2d,k2d), &
+                                                     qi2d(i2d,k2d),qs2d(i2d,k2d),qg2d(i2d,k2d),qh2d(i2d,k2d)
+               write(6,*)
+               stop
+            endif
+
+          !Convert back to 3D arrays (and change units of number concentrations back to kg-1):
+            th(i,k,j) = t2d(i2d,k2d)/pii(i,k,j)
+            qv(i,k,j) = qv2d(i2d,k2d)
+         !   irho(i,k) = R_d*t2d(i2d,k2d)/p2d(i2d,k2d)
+            qc(i,k,j) = qc2d(i2d,k2d);   nc(i,k,j) = nc2d(i2d,k2d)
+            qi(i,k,j) = qi2d(i2d,k2d);   ni(i,k,j) = ni2d(i2d,k2d)
+            qr(i,k,j) = qr2d(i2d,k2d);   nr(i,k,j) = nr2d(i2d,k2d)
+            qs(i,k,j) = qs2d(i2d,k2d);   ns(i,k,j) = ns2d(i2d,k2d)
+            qg(i,k,j) = qg2d(i2d,k2d);   ng(i,k,j) = ng2d(i2d,k2d)
+            qh(i,k,j) = qh2d(i2d,k2d);   nh(i,k,j) = nh2d(i2d,k2d)
+            Zet(i,k,j)= Zet2d(i2d,k2d)
+
+         enddo k_loop2
+       enddo i_loop2
+
+      enddo j_loop1
+
+      do i = 1, 256
+         mp_debug(i:i) = char(0)
+      enddo
+
+      END SUBROUTINE mp_milbrandt2mom_driver
+
+!+---+-----------------------------------------------------------------+
+!________________________________________________________________________________________!
+
+END MODULE module_mp_milbrandt2mom
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_morr_two_moment.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_morr_two_moment.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_morr_two_moment.F	(revision 17)
@@ -0,0 +1,4237 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+
+! THIS MODULE CONTAINS THE TWO-MOMENT MICROPHYSICS CODE DESCRIBED BY
+!     MORRISON ET AL. (2009, MWR)
+
+! CHANGES FOR V3.2, RELATIVE TO MOST RECENT (BUG-FIX) CODE FOR V3.1
+
+! 1) ADDED ACCELERATED MELTING OF GRAUPEL/SNOW DUE TO COLLISION WITH RAIN, FOLLOWING LIN ET AL. (1983)
+! 2) INCREASED MINIMUM LAMBDA FOR RAIN, AND ADDED RAIN DROP BREAKUP FOLLOWING MODIFIED VERSION
+!     OF VERLINDE AND COTTON (1993)
+! 3) CHANGE MINIMUM ALLOWED MIXING RATIOS IN DRY CONDITIONS (RH < 90%), THIS IMPROVES RADAR REFLECTIIVITY
+!     IN LOW REFLECTIVITY REGIONS
+! 4) BUG FIX TO MAXIMUM ALLOWED PARTICLE FALLSPEEDS AS A FUNCTION OF AIR DENSITY
+! 5) BUG FIX TO CALCULATION OF LIQUID WATER SATURATION VAPOR PRESSURE (CHANGE IS VERY MINOR)
+! 6) INCLUDE WRF CONSTANTS PER SUGGESTION OF JIMY
+
+! bug fix, 5/12/10
+! 7) bug fix for saturation vapor pressure in low pressure, to avoid division by zero
+! 8) include 'EP2' WRF constant for saturation mixing ratio calculation, instead of hardwire constant
+
+! CHANGES FOR V3.3
+! 1) MODIFICATION FOR COUPLING WITH WRF-CHEM (PREDICTED DROPLET NUMBER CONCENTRATION) AS AN OPTION
+! 2) MODIFY FALLSPEED BELOW THE LOWEST LEVEL OF PRECIPITATION, WHICH PREVENTS
+!      POTENTIAL FOR SPURIOUS ACCUMULATION OF PRECIPITATION DURING SUB-STEPPING FOR SEDIMENTATION
+! 3) BUG FIX TO LATENT HEAT RELEASE DUE TO COLLISIONS OF CLOUD ICE WITH RAIN
+! 4) CLEAN UP OF COMMENTS IN THE CODE
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! THIS SCHEME IS A BULK DOUBLE-MOMENT SCHEME THAT PREDICTS MIXING
+! RATIOS AND NUMBER CONCENTRATIONS OF FIVE HYDROMETEOR SPECIES:
+! CLOUD DROPLETS, CLOUD (SMALL) ICE, RAIN, SNOW, AND GRAUPEL.
+
+MODULE MODULE_MP_MORR_TWO_MOMENT
+   USE     module_wrf_error
+!      USE module_utility, ONLY: WRFU_Clock, WRFU_Alarm  ! GT
+!      USE module_domain, ONLY : HISTORY_ALARM, Is_alarm_tstep  ! GT
+
+! USE WRF PHYSICS CONSTANTS
+  use module_model_constants, ONLY: CP, G, R => r_d, RV => r_v, EP_2
+
+!  USE module_state_description
+
+   IMPLICIT NONE
+
+   REAL, PARAMETER :: PI = 3.1415926535897932384626434
+   REAL, PARAMETER :: SQRTPI = 0.9189385332046727417803297
+
+   PUBLIC  ::  MP_MORR_TWO_MOMENT
+   PUBLIC  ::  POLYSVP
+
+   PRIVATE :: GAMMA, DERF1
+   PRIVATE :: PI, SQRTPI
+   PRIVATE :: MORR_TWO_MOMENT_MICRO
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! SWITCHES FOR MICROPHYSICS SCHEME
+! IACT = 1, USE POWER-LAW CCN SPECTRA, NCCN = CS^K
+! IACT = 2, USE LOGNORMAL AEROSOL SIZE DIST TO DERIVE CCN SPECTRA
+! IACT = 3, ACTIVATION CALCULATED IN MODULE_MIXACTIVATE
+
+     INTEGER, PRIVATE ::  IACT
+
+! INUM = 0, PREDICT DROPLET CONCENTRATION
+! INUM = 1, ASSUME CONSTANT DROPLET CONCENTRATION   
+! !!!NOTE: PREDICTED DROPLET CONCENTRATION NOT AVAILABLE IN THIS VERSION
+! CONTACT HUGH MORRISON (morrison@ucar.edu) FOR FURTHER INFORMATION
+
+     INTEGER, PRIVATE ::  INUM
+
+! FOR INUM = 1, SET CONSTANT DROPLET CONCENTRATION (CM-3)
+     REAL, PRIVATE ::      NDCNST
+
+! SWITCH FOR LIQUID-ONLY RUN
+! ILIQ = 0, INCLUDE ICE
+! ILIQ = 1, LIQUID ONLY, NO ICE
+
+     INTEGER, PRIVATE ::  ILIQ
+
+! SWITCH FOR ICE NUCLEATION
+! INUC = 0, USE FORMULA FROM RASMUSSEN ET AL. 2002 (MID-LATITUDE)
+!      = 1, USE MPACE OBSERVATIONS
+
+     INTEGER, PRIVATE ::  INUC
+
+! IBASE = 1, NEGLECT DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO 
+!             UNRESOLVED ENTRAINMENT AND MIXING, ACTIVATE
+!             AT CLOUD BASE OR IN REGION WITH LITTLE CLOUD WATER USING 
+!             NON-EQULIBRIUM SUPERSATURATION, 
+!             IN CLOUD INTERIOR ACTIVATE USING EQUILIBRIUM SUPERSATURATION
+! IBASE = 2, ASSUME DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO 
+!             UNRESOLVED ENTRAINMENT AND MIXING DOMINATES,
+!             ACTIVATE DROPLETS EVERYWHERE IN THE CLOUD USING NON-EQUILIBRIUM
+!             SUPERSATURATION, BASED ON THE 
+!             LOCAL SUB-GRID AND/OR GRID-SCALE VERTICAL VELOCITY 
+!             AT THE GRID POINT
+
+! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0)
+
+     INTEGER, PRIVATE ::  IBASE
+
+! INCLUDE SUB-GRID VERTICAL VELOCITY IN DROPLET ACTIVATION
+! ISUB = 0, INCLUDE SUB-GRID W (RECOMMENDED FOR LOWER RESOLUTION)
+! ISUB = 1, EXCLUDE SUB-GRID W, ONLY USE GRID-SCALE W
+
+     INTEGER, PRIVATE ::  ISUB      
+
+! SWITCH FOR GRAUPEL/NO GRAUPEL
+! IGRAUP = 0, INCLUDE GRAUPEL
+! IGRAUP = 1, NO GRAUPEL
+
+     INTEGER, PRIVATE ::  IGRAUP
+
+! HM ADDED NEW OPTION FOR HAIL
+! SWITCH FOR HAIL/GRAUPEL
+! IHAIL = 0, DENSE PRECIPITATING ICE IS GRAUPEL
+! IHAIL = 1, DENSE PRECIPITATING GICE IS HAIL
+
+     INTEGER, PRIVATE ::  IHAIL
+
+! CLOUD MICROPHYSICS CONSTANTS
+
+     REAL, PRIVATE ::      AI,AC,AS,AR,AG ! 'A' PARAMETER IN FALLSPEED-DIAM RELATIONSHIP
+     REAL, PRIVATE ::      BI,BC,BS,BR,BG ! 'B' PARAMETER IN FALLSPEED-DIAM RELATIONSHIP
+!     REAL, PRIVATE ::      R           ! GAS CONSTANT FOR AIR
+!     REAL, PRIVATE ::      RV          ! GAS CONSTANT FOR WATER VAPOR
+!     REAL, PRIVATE ::      CP          ! SPECIFIC HEAT AT CONSTANT PRESSURE FOR DRY AIR
+     REAL, PRIVATE ::      RHOSU       ! STANDARD AIR DENSITY AT 850 MB
+     REAL, PRIVATE ::      RHOW        ! DENSITY OF LIQUID WATER
+     REAL, PRIVATE ::      RHOI        ! BULK DENSITY OF CLOUD ICE
+     REAL, PRIVATE ::      RHOSN       ! BULK DENSITY OF SNOW
+     REAL, PRIVATE ::      RHOG        ! BULK DENSITY OF GRAUPEL
+     REAL, PRIVATE ::      AIMM        ! PARAMETER IN BIGG IMMERSION FREEZING
+     REAL, PRIVATE ::      BIMM        ! PARAMETER IN BIGG IMMERSION FREEZING
+     REAL, PRIVATE ::      ECR         ! COLLECTION EFFICIENCY BETWEEN DROPLETS/RAIN AND SNOW/RAIN
+     REAL, PRIVATE ::      DCS         ! THRESHOLD SIZE FOR CLOUD ICE AUTOCONVERSION
+     REAL, PRIVATE ::      MI0         ! INITIAL SIZE OF NUCLEATED CRYSTAL
+     REAL, PRIVATE ::      MG0         ! MASS OF EMBRYO GRAUPEL
+     REAL, PRIVATE ::      F1S         ! VENTILATION PARAMETER FOR SNOW
+     REAL, PRIVATE ::      F2S         ! VENTILATION PARAMETER FOR SNOW
+     REAL, PRIVATE ::      F1R         ! VENTILATION PARAMETER FOR RAIN
+     REAL, PRIVATE ::      F2R         ! VENTILATION PARAMETER FOR RAIN
+!     REAL, PRIVATE ::      G           ! GRAVITATIONAL ACCELERATION
+     REAL, PRIVATE ::      QSMALL      ! SMALLEST ALLOWED HYDROMETEOR MIXING RATIO
+     REAL, PRIVATE ::      CI,DI,CS,DS,CG,DG ! SIZE DISTRIBUTION PARAMETERS FOR CLOUD ICE, SNOW, GRAUPEL
+     REAL, PRIVATE ::      EII         ! COLLECTION EFFICIENCY, ICE-ICE COLLISIONS
+     REAL, PRIVATE ::      ECI         ! COLLECTION EFFICIENCY, ICE-DROPLET COLLISIONS
+     REAL, PRIVATE ::      RIN     ! RADIUS OF CONTACT NUCLEI (M)
+! hm, add for V3.2
+     REAL, PRIVATE ::      CPW     ! SPECIFIC HEAT OF LIQUID WATER
+
+! CCN SPECTRA FOR IACT = 1
+
+     REAL, PRIVATE ::      C1     ! 'C' IN NCCN = CS^K (CM-3)
+     REAL, PRIVATE ::      K1     ! 'K' IN NCCN = CS^K
+
+! AEROSOL PARAMETERS FOR IACT = 2
+
+     REAL, PRIVATE ::      MW      ! MOLECULAR WEIGHT WATER (KG/MOL)
+     REAL, PRIVATE ::      OSM     ! OSMOTIC COEFFICIENT
+     REAL, PRIVATE ::      VI      ! NUMBER OF ION DISSOCIATED IN SOLUTION
+     REAL, PRIVATE ::      EPSM    ! AEROSOL SOLUBLE FRACTION
+     REAL, PRIVATE ::      RHOA    ! AEROSOL BULK DENSITY (KG/M3)
+     REAL, PRIVATE ::      MAP     ! MOLECULAR WEIGHT AEROSOL (KG/MOL)
+     REAL, PRIVATE ::      MA      ! MOLECULAR WEIGHT OF 'AIR' (KG/MOL)
+     REAL, PRIVATE ::      RR      ! UNIVERSAL GAS CONSTANT
+     REAL, PRIVATE ::      BACT    ! ACTIVATION PARAMETER
+     REAL, PRIVATE ::      RM1     ! GEOMETRIC MEAN RADIUS, MODE 1 (M)
+     REAL, PRIVATE ::      RM2     ! GEOMETRIC MEAN RADIUS, MODE 2 (M)
+     REAL, PRIVATE ::      NANEW1  ! TOTAL AEROSOL CONCENTRATION, MODE 1 (M^-3)
+     REAL, PRIVATE ::      NANEW2  ! TOTAL AEROSOL CONCENTRATION, MODE 2 (M^-3)
+     REAL, PRIVATE ::      SIG1    ! STANDARD DEVIATION OF AEROSOL S.D., MODE 1
+     REAL, PRIVATE ::      SIG2    ! STANDARD DEVIATION OF AEROSOL S.D., MODE 2
+     REAL, PRIVATE ::      F11     ! CORRECTION FACTOR FOR ACTIVATION, MODE 1
+     REAL, PRIVATE ::      F12     ! CORRECTION FACTOR FOR ACTIVATION, MODE 1
+     REAL, PRIVATE ::      F21     ! CORRECTION FACTOR FOR ACTIVATION, MODE 2
+     REAL, PRIVATE ::      F22     ! CORRECTION FACTOR FOR ACTIVATION, MODE 2     
+     REAL, PRIVATE ::      MMULT   ! MASS OF SPLINTERED ICE PARTICLE
+     REAL, PRIVATE ::      LAMMAXI,LAMMINI,LAMMAXR,LAMMINR,LAMMAXS,LAMMINS,LAMMAXG,LAMMING
+
+! CONSTANTS TO IMPROVE EFFICIENCY
+
+     REAL, PRIVATE :: CONS1,CONS2,CONS3,CONS4,CONS5,CONS6,CONS7,CONS8,CONS9,CONS10
+     REAL, PRIVATE :: CONS11,CONS12,CONS13,CONS14,CONS15,CONS16,CONS17,CONS18,CONS19,CONS20
+     REAL, PRIVATE :: CONS21,CONS22,CONS23,CONS24,CONS25,CONS26,CONS27,CONS28,CONS29,CONS30
+     REAL, PRIVATE :: CONS31,CONS32,CONS33,CONS34,CONS35,CONS36,CONS37,CONS38,CONS39,CONS40
+     REAL, PRIVATE :: CONS41
+
+CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+SUBROUTINE MORR_TWO_MOMENT_INIT
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! THIS SUBROUTINE INITIALIZES ALL PHYSICAL CONSTANTS AMND PARAMETERS 
+! NEEDED BY THE MICROPHYSICS SCHEME.
+! NEEDS TO BE CALLED AT FIRST TIME STEP, PRIOR TO CALL TO MAIN MICROPHYSICS INTERFACE
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      IMPLICIT NONE
+
+      integer n,i
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! THE FOLLOWING PARAMETERS ARE USER-DEFINED SWITCHES AND NEED TO BE
+! SET PRIOR TO CODE COMPILATION
+
+! INUM IS AUTOMATICALLY SET TO 0 FOR WRF-CHEM BELOW,
+! ALLOWING PREDICTION OF DROPLET CONCENTRATION
+! THUS, THIS PARAMETER SHOULD NOT BE CHANGED HERE
+! AND SHOULD BE LEFT TO 1
+
+      INUM = 1
+
+! SET CONSTANT DROPLET CONCENTRATION (UNITS OF CM-3)
+! IF NO COUPLING WITH WRF-CHEM
+
+      NDCNST = 250.
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! NOTE, THE FOLLOWING OPTIONS RELATED TO DROPLET ACTIVATION 
+! (IACT, IBASE, ISUB) ARE NOT AVAILABLE IN CURRENT VERSION
+! FOR WRF-CHEM, DROPLET ACTIVATION IS PERFORMED 
+! IN 'MIX_ACTIVATE', NOT IN MICROPHYSICS SCHEME
+
+
+! IACT = 1, USE POWER-LAW CCN SPECTRA, NCCN = CS^K
+! IACT = 2, USE LOGNORMAL AEROSOL SIZE DIST TO DERIVE CCN SPECTRA
+
+      IACT = 2
+
+! IBASE = 1, NEGLECT DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO 
+!             UNRESOLVED ENTRAINMENT AND MIXING, ACTIVATE
+!             AT CLOUD BASE OR IN REGION WITH LITTLE CLOUD WATER USING 
+!             NON-EQULIBRIUM SUPERSATURATION ASSUMING NO INITIAL CLOUD WATER, 
+!             IN CLOUD INTERIOR ACTIVATE USING EQUILIBRIUM SUPERSATURATION
+! IBASE = 2, ASSUME DROPLET ACTIVATION AT LATERAL CLOUD EDGES DUE TO 
+!             UNRESOLVED ENTRAINMENT AND MIXING DOMINATES,
+!             ACTIVATE DROPLETS EVERYWHERE IN THE CLOUD USING NON-EQUILIBRIUM
+!             SUPERSATURATION ASSUMING NO INITIAL CLOUD WATER, BASED ON THE 
+!             LOCAL SUB-GRID AND/OR GRID-SCALE VERTICAL VELOCITY 
+!             AT THE GRID POINT
+
+! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0)
+ 
+      IBASE = 2
+
+! INCLUDE SUB-GRID VERTICAL VELOCITY (standard deviation of w) IN DROPLET ACTIVATION
+! ISUB = 0, INCLUDE SUB-GRID W (RECOMMENDED FOR LOWER RESOLUTION)
+! currently, sub-grid w is constant of 0.5 m/s (not coupled with PBL/turbulence scheme)
+! ISUB = 1, EXCLUDE SUB-GRID W, ONLY USE GRID-SCALE W
+
+! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0)
+
+      ISUB = 0      
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+! SWITCH FOR LIQUID-ONLY RUN
+! ILIQ = 0, INCLUDE ICE
+! ILIQ = 1, LIQUID ONLY, NO ICE
+
+      ILIQ = 0
+
+! SWITCH FOR ICE NUCLEATION
+! INUC = 0, USE FORMULA FROM RASMUSSEN ET AL. 2002 (MID-LATITUDE)
+!      = 1, USE MPACE OBSERVATIONS (ARCTIC ONLY)
+
+      INUC = 0
+
+! SWITCH FOR GRAUPEL/HAIL NO GRAUPEL/HAIL
+! IGRAUP = 0, INCLUDE GRAUPEL/HAIL
+! IGRAUP = 1, NO GRAUPEL/HAIL
+
+      IGRAUP = 0
+
+! HM ADDED 11/7/07
+! SWITCH FOR HAIL/GRAUPEL
+! IHAIL = 0, DENSE PRECIPITATING ICE IS GRAUPEL
+! IHAIL = 1, DENSE PRECIPITATING ICE IS HAIL
+! NOTE ---> RECOMMEND IHAIL = 1 FOR CONTINENTAL DEEP CONVECTION
+
+      IHAIL = 0
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! SET PHYSICAL CONSTANTS
+
+! FALLSPEED PARAMETERS (V=AD^B)
+         AI = 700.
+         AC = 3.E7
+         AS = 11.72
+         AR = 841.99667
+         BI = 1.
+         BC = 2.
+         BS = 0.41
+         BR = 0.8
+         IF (IHAIL.EQ.0) THEN
+	 AG = 19.3
+	 BG = 0.37
+         ELSE ! (MATSUN AND HUGGINS 1980)
+         AG = 114.5 
+         BG = 0.5
+         END IF
+
+! CONSTANTS AND PARAMETERS
+!         R = 287.15
+!         RV = 461.5
+!         CP = 1005.
+         RHOSU = 85000./(287.15*273.15)
+         RHOW = 997.
+         RHOI = 500.
+         RHOSN = 100.
+         IF (IHAIL.EQ.0) THEN
+	 RHOG = 400.
+         ELSE
+         RHOG = 900.
+         END IF
+         AIMM = 0.66
+         BIMM = 100.
+         ECR = 1.
+         DCS = 125.E-6
+         MI0 = 4./3.*PI*RHOI*(10.E-6)**3
+	 MG0 = 1.6E-10
+         F1S = 0.86
+         F2S = 0.28
+         F1R = 0.78
+         F2R = 0.32
+!         G = 9.806
+         QSMALL = 1.E-14
+         EII = 0.1
+         ECI = 0.7
+! HM, ADD FOR V3.2
+         CPW = 4218.
+
+! SIZE DISTRIBUTION PARAMETERS
+
+         CI = RHOI*PI/6.
+         DI = 3.
+         CS = RHOSN*PI/6.
+         DS = 3.
+         CG = RHOG*PI/6.
+         DG = 3.
+
+! RADIUS OF CONTACT NUCLEI
+         RIN = 0.1E-6
+
+         MMULT = 4./3.*PI*RHOI*(5.E-6)**3
+
+! SIZE LIMITS FOR LAMBDA
+
+         LAMMAXI = 1./1.E-6
+         LAMMINI = 1./(2.*DCS+100.E-6)
+         LAMMAXR = 1./20.E-6
+!         LAMMINR = 1./500.E-6
+         LAMMINR = 1./2800.E-6
+
+         LAMMAXS = 1./10.E-6
+         LAMMINS = 1./2000.E-6
+         LAMMAXG = 1./20.E-6
+         LAMMING = 1./2000.E-6
+
+! CCN SPECTRA FOR IACT = 1
+
+! MARITIME
+! MODIFIED FROM RASMUSSEN ET AL. 2002
+! NCCN = C*S^K, NCCN IS IN CM-3, S IS SUPERSATURATION RATIO IN %
+
+              K1 = 0.4
+              C1 = 120. 
+
+! CONTINENTAL
+
+!              K1 = 0.5
+!              C1 = 1000. 
+
+! AEROSOL ACTIVATION PARAMETERS FOR IACT = 2
+! PARAMETERS CURRENTLY SET FOR AMMONIUM SULFATE
+
+         MW = 0.018
+         OSM = 1.
+         VI = 3.
+         EPSM = 0.7
+         RHOA = 1777.
+         MAP = 0.132
+         MA = 0.0284
+         RR = 8.3187
+         BACT = VI*OSM*EPSM*MW*RHOA/(MAP*RHOW)
+
+! AEROSOL SIZE DISTRIBUTION PARAMETERS CURRENTLY SET FOR MPACE 
+! (see morrison et al. 2007, JGR)
+! MODE 1
+
+         RM1 = 0.052E-6
+         SIG1 = 2.04
+         NANEW1 = 72.2E6
+         F11 = 0.5*EXP(2.5*(LOG(SIG1))**2)
+         F21 = 1.+0.25*LOG(SIG1)
+
+! MODE 2
+
+         RM2 = 1.3E-6
+         SIG2 = 2.5
+         NANEW2 = 1.8E6
+         F12 = 0.5*EXP(2.5*(LOG(SIG2))**2)
+         F22 = 1.+0.25*LOG(SIG2)
+
+! CONSTANTS FOR EFFICIENCY
+
+         CONS1=GAMMA(1.+DS)*CS
+         CONS2=GAMMA(1.+DG)*CG
+         CONS3=GAMMA(4.+BS)/6.
+         CONS4=GAMMA(4.+BR)/6.
+         CONS5=GAMMA(1.+BS)
+         CONS6=GAMMA(1.+BR)
+         CONS7=GAMMA(4.+BG)/6.
+         CONS8=GAMMA(1.+BG)
+         CONS9=GAMMA(5./2.+BR/2.)
+         CONS10=GAMMA(5./2.+BS/2.)
+         CONS11=GAMMA(5./2.+BG/2.)
+         CONS12=GAMMA(1.+DI)*CI
+         CONS13=GAMMA(BS+3.)*PI/4.*ECI
+         CONS14=GAMMA(BG+3.)*PI/4.*ECI
+         CONS15=-1108.*EII*PI**((1.-BS)/3.)*RHOSN**((-2.-BS)/3.)/(4.*720.)
+         CONS16=GAMMA(BI+3.)*PI/4.*ECI
+         CONS17=4.*2.*3.*RHOSU*PI*ECI*ECI*GAMMA(2.*BS+2.)/(8.*(RHOG-RHOSN))
+         CONS18=RHOSN*RHOSN
+         CONS19=RHOW*RHOW
+         CONS20=20.*PI*PI*RHOW*BIMM
+         CONS21=4./(DCS*RHOI)
+         CONS22=PI*RHOI*DCS**3/6.
+         CONS23=PI/4.*EII*GAMMA(BS+3.)
+         CONS24=PI/4.*ECR*GAMMA(BR+3.)
+         CONS25=PI*PI/24.*RHOW*ECR*GAMMA(BR+6.)
+         CONS26=PI/6.*RHOW
+         CONS27=GAMMA(1.+BI)
+         CONS28=GAMMA(4.+BI)/6.
+         CONS29=4./3.*PI*RHOW*(25.E-6)**3
+         CONS30=4./3.*PI*RHOW
+         CONS31=PI*PI*ECR*RHOSN
+         CONS32=PI/2.*ECR
+         CONS33=PI*PI*ECR*RHOG
+         CONS34=5./2.+BR/2.
+         CONS35=5./2.+BS/2.
+         CONS36=5./2.+BG/2.
+         CONS37=4.*PI*1.38E-23/(6.*PI*RIN)
+         CONS38=PI*PI/3.*RHOW
+         CONS39=PI*PI/36.*RHOW*BIMM
+         CONS40=PI/6.*BIMM
+         CONS41=PI*PI*ECR*RHOW
+
+END SUBROUTINE MORR_TWO_MOMENT_INIT
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! THIS SUBROUTINE IS MAIN INTERFACE WITH THE TWO-MOMENT MICROPHYSICS SCHEME
+! THIS INTERFACE TAKES IN 3D VARIABLES FROM DRIVER MODEL, CONVERTS TO 1D FOR
+! CALL TO THE MAIN MICROPHYSICS SUBROUTINE (SUBROUTINE MORR_TWO_MOMENT_MICRO) 
+! WHICH OPERATES ON 1D VERTICAL COLUMNS.
+! 1D VARIABLES FROM THE MAIN MICROPHYSICS SUBROUTINE ARE THEN REASSIGNED BACK TO 3D FOR OUTPUT
+! BACK TO DRIVER MODEL USING THIS INTERFACE.
+! MICROPHYSICS TENDENCIES ARE ADDED TO VARIABLES HERE BEFORE BEING PASSED BACK TO DRIVER MODEL.
+
+! THIS CODE WAS WRITTEN BY HUGH MORRISON (NCAR) AND SLAVA TATARSKII (GEORGIA TECH).
+
+! FOR QUESTIONS, CONTACT: HUGH MORRISON, E-MAIL: MORRISON@UCAR.EDU, PHONE:303-497-8916
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP,                       &
+                TH, QV, QC, QR, QI, QS, QG, NI, NS, NR, NG, &
+                RHO, PII, P, DT_IN, DZ, HT, W,          &
+                RAINNC, RAINNCV, SR,                    &
+                qrcuten, qscuten, qicuten, mu           & ! hm added
+               ,F_QNDROP, qndrop                        & ! hm added, wrf-chem 
+               ,IDS,IDE, JDS,JDE, KDS,KDE               & ! domain dims
+               ,IMS,IME, JMS,JME, KMS,KME               & ! memory dims
+               ,ITS,ITE, JTS,JTE, KTS,KTE               & ! tile   dims            )
+!jdf		   ,C2PREC3D,CSED3D,ISED3D,SSED3D,GSED3D,RSED3D & ! HM ADD, WRF-CHEM
+		   ,QLSINK,PRECR,PRECI,PRECS,PRECG &        ! HM ADD, WRF-CHEM
+                                            )
+ 
+! 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)
+! QG - graupel mixing ratio (KG/KG)
+! NI - cloud ice number concentration (1/kg)
+! NS - Snow Number concentration (1/kg)
+! NR - Rain Number concentration (1/kg)
+! NG - Graupel number concentration (1/kg)
+! NOTE: RHO AND HT NOT USED BY THIS SCHEME AND DO NOT NEED TO BE PASSED INTO SCHEME!!!!
+! P - AIR PRESSURE (PA)
+! W - VERTICAL AIR VELOCITY (M/S)
+! TH - POTENTIAL TEMPERATURE (K)
+! PII - exner function - used to convert potential temp to temp
+! DZ - difference in height over interface (m)
+! DT_IN - model time step (sec)
+! ITIMESTEP - time step counter
+! RAINNC - accumulated grid-scale precipitation (mm)
+! RAINNCV - one time step grid scale precipitation (mm/time step)
+! SR - one time step mass ratio of snow to total precip
+! qrcuten, rain tendency from parameterized cumulus convection
+! qscuten, snow tendency from parameterized cumulus convection
+! qicuten, cloud ice tendency from parameterized cumulus convection
+
+! variables below currently not in use, not coupled to PBL or radiation codes
+! TKE - turbulence kinetic energy (m^2 s-2), NEEDED FOR DROPLET ACTIVATION (SEE CODE BELOW)
+! NCTEND - droplet concentration tendency from pbl (kg-1 s-1)
+! NCTEND - CLOUD ICE concentration tendency from pbl (kg-1 s-1)
+! KZH - heat eddy diffusion coefficient from YSU scheme (M^2 S-1), NEEDED FOR DROPLET ACTIVATION (SEE CODE BELOW)
+! EFFCS - CLOUD DROPLET EFFECTIVE RADIUS OUTPUT TO RADIATION CODE (micron)
+! EFFIS - CLOUD DROPLET EFFECTIVE RADIUS OUTPUT TO RADIATION CODE (micron)
+! HM, ADDED FOR WRF-CHEM COUPLING
+! QLSINK - TENDENCY OF CLOUD WATER TO RAIN, SNOW, GRAUPEL (KG/KG/S)
+! CSED,ISED,SSED,GSED,RSED - SEDIMENTATION FLUXES (KG/M^2/S) FOR CLOUD WATER, ICE, SNOW, GRAUPEL, RAIN
+! PRECI,PRECS,PRECG,PRECR - SEDIMENTATION FLUXES (KG/M^2/S) FOR ICE, SNOW, GRAUPEL, RAIN
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! reflectivity currently not included!!!!
+! REFL_10CM - CALCULATED RADAR REFLECTIVITY AT 10 CM (DBZ)
+!................................
+! GRID_CLOCK, GRID_ALARMS - parameters to limit radar reflectivity calculation only when needed
+! otherwise radar reflectivity calculation every time step is too slow
+! only needed for coupling with WRF, see code below for details
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! EFFC - DROPLET EFFECTIVE RADIUS (MICRON)
+! EFFR - RAIN EFFECTIVE RADIUS (MICRON)
+! EFFS - SNOW EFFECTIVE RADIUS (MICRON)
+! EFFI - CLOUD ICE EFFECTIVE RADIUS (MICRON)
+
+! ADDITIONAL OUTPUT FROM MICRO - SEDIMENTATION TENDENCIES, NEEDED FOR LIQUID-ICE STATIC ENERGY
+
+! QGSTEN - GRAUPEL SEDIMENTATION TEND (KG/KG/S)
+! QRSTEN - RAIN SEDIMENTATION TEND (KG/KG/S)
+! QISTEN - CLOUD ICE SEDIMENTATION TEND (KG/KG/S)
+! QNISTEN - SNOW SEDIMENTATION TEND (KG/KG/S)
+! QCSTEN - CLOUD WATER SEDIMENTATION TEND (KG/KG/S)
+
+! WVAR - STANDARD DEVIATION OF SUB-GRID VERTICAL VELOCITY (M/S)
+
+   IMPLICIT NONE
+
+   INTEGER,      INTENT(IN   )    ::   ids, ide, jds, jde, kds, kde , &
+                                       ims, ime, jms, jme, kms, kme , &
+                                       its, ite, jts, jte, kts, kte
+! Temporary changed from INOUT to IN
+
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: &
+                          qv, qc, qr, qi, qs, qg, ni, ns, nr, TH, NG   
+!jdf                      qndrop ! hm added, wrf-chem
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop
+!jdf  REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(INOUT):: CSED3D, &
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: QLSINK, &
+                          PRECI,PRECS,PRECG,PRECR ! HM, WRF-CHEM
+!, effcs, effis
+
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: &
+                          pii, p, dz, rho, w !, tke, nctend, nitend,kzh
+   REAL, INTENT(IN):: dt_in
+   INTEGER, INTENT(IN):: ITIMESTEP
+
+   REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: &
+                          RAINNC, RAINNCV, SR
+
+!   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT)::       &  ! GT
+!                          refl_10cm
+
+   REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) ::       ht
+
+!      TYPE (WRFU_Clock):: grid_clock                  ! GT
+!      TYPE (WRFU_Alarm), POINTER:: grid_alarms(:)     ! GT
+
+   ! LOCAL VARIABLES
+
+   REAL, DIMENSION(its:ite, kts:kte, jts:jte)::                     &
+                      effi, effs, effr, EFFG
+
+   REAL, DIMENSION(its:ite, kts:kte, jts:jte)::                     &
+                      T, WVAR, EFFC
+
+   REAL, DIMENSION(kts:kte) ::                                                                & 
+                            QC_TEND1D, QI_TEND1D, QNI_TEND1D, QR_TEND1D,                      &
+                            NI_TEND1D, NS_TEND1D, NR_TEND1D,                                  &
+                            QC1D, QI1D, QR1D,NI1D, NS1D, NR1D, QS1D,                          &
+                            T_TEND1D,QV_TEND1D, T1D, QV1D, P1D, W1D, WVAR1D,         &
+                            EFFC1D, EFFI1D, EFFS1D, EFFR1D,DZ1D,   &
+   ! HM ADD GRAUPEL
+                            QG_TEND1D, NG_TEND1D, QG1D, NG1D, EFFG1D, &
+
+! ADD SEDIMENTATION TENDENCIES (UNITS OF KG/KG/S)
+                            QGSTEN,QRSTEN, QISTEN, QNISTEN, QCSTEN, &
+! ADD CUMULUS TENDENCIES
+                            QRCU1D, QSCU1D, QICU1D
+
+! add cumulus tendencies
+
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: &
+      qrcuten, qscuten, qicuten
+   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN):: &
+      mu
+
+  LOGICAL, INTENT(IN), OPTIONAL ::                F_QNDROP  ! wrf-chem
+  LOGICAL :: flag_qndrop  ! wrf-chem
+  integer :: iinum ! wrf-chem
+
+! wrf-chem
+   REAL, DIMENSION(kts:kte) :: nc1d, nc_tend1d,C2PREC,CSED,ISED,SSED,GSED,RSED    
+! HM add reflectivity      
+!                            dbz
+                          
+   REAL PRECPRT1D, SNOWRT1D
+
+   INTEGER I,K,J
+
+   REAL DT
+
+!   LOGICAL:: dBZ_tstep ! GT
+! below for wrf-chem
+   flag_qndrop = .false.
+   IF ( PRESENT ( f_qndrop ) ) flag_qndrop = f_qndrop
+!!!!!!!!!!!!!!!!!!!!!!
+
+   ! Initialize tendencies (all set to 0) and transfer
+   ! array to local variables
+   DT = DT_IN   
+
+   DO I=ITS,ITE
+   DO J=JTS,JTE
+   DO K=KTS,KTE
+       T(I,K,J)        = TH(i,k,j)*PII(i,k,j)
+
+! NOTE: WVAR NOT CURRENTLY USED IN CODE !!!!!!!!!!
+! currently assign wvar to 0.5 m/s (not coupled with PBL scheme)
+
+       WVAR(I,K,J)     = 0.5
+
+! currently mixing of number concentrations also is neglected (not coupled with PBL schemes)
+
+   END DO
+   END DO
+   END DO
+
+   do i=its,ite      ! i loop (east-west)
+   do j=jts,jte      ! j loop (north-south)
+   !
+   ! Transfer 3D arrays into 1D for microphysical calculations
+   !
+
+! hm , initialize 1d tendency arrays to zero
+
+      do k=kts,kte   ! k loop (vertical)
+
+          QC_TEND1D(k)  = 0.
+          QI_TEND1D(k)  = 0.
+          QNI_TEND1D(k) = 0.
+          QR_TEND1D(k)  = 0.
+          NI_TEND1D(k)  = 0.
+          NS_TEND1D(k)  = 0.
+          NR_TEND1D(k)  = 0.
+          T_TEND1D(k)   = 0.
+          QV_TEND1D(k)  = 0.
+          nc_tend1d(k) = 0. ! wrf-chem
+
+          QC1D(k)       = QC(i,k,j)
+          QI1D(k)       = QI(i,k,j)
+          QS1D(k)       = QS(i,k,j)
+          QR1D(k)       = QR(i,k,j)
+
+          NI1D(k)       = NI(i,k,j)
+
+          NS1D(k)       = NS(i,k,j)
+          NR1D(k)       = NR(i,k,j)
+! HM ADD GRAUPEL
+          QG1D(K)       = QG(I,K,j)
+          NG1D(K)       = NG(I,K,j)
+          QG_TEND1D(K)  = 0.
+          NG_TEND1D(K)  = 0.
+
+          T1D(k)        = T(i,k,j)
+          QV1D(k)       = QV(i,k,j)
+          P1D(k)        = P(i,k,j)
+          DZ1D(k)       = DZ(i,k,j)
+          W1D(k)        = W(i,k,j)
+          WVAR1D(k)     = WVAR(i,k,j)
+! add cumulus tendencies, decouple from mu
+          qrcu1d(k)     = qrcuten(i,k,j)/mu(i,j)
+          qscu1d(k)     = qscuten(i,k,j)/mu(i,j)
+          qicu1d(k)     = qicuten(i,k,j)/mu(i,j)
+      end do  !jdf added this
+! below for wrf-chem
+   IF (flag_qndrop .AND. PRESENT( qndrop )) THEN
+      iact = 3
+      DO k = kts, kte
+         nc1d(k)=qndrop(i,k,j)
+         iinum=0
+      ENDDO
+   ELSE
+      DO k = kts, kte
+         nc1d(k)=0. ! temporary placeholder, set to constant in microphysics subroutine
+         iinum=1
+      ENDDO
+   ENDIF
+
+!jdf  end do
+
+      call MORR_TWO_MOMENT_MICRO(QC_TEND1D, QI_TEND1D, QNI_TEND1D, QR_TEND1D,            &
+       NI_TEND1D, NS_TEND1D, NR_TEND1D,                                                  &
+       QC1D, QI1D, QS1D, QR1D,NI1D, NS1D, NR1D,                                          &
+       T_TEND1D,QV_TEND1D, T1D, QV1D, P1D, DZ1D, W1D, WVAR1D,                   &
+       PRECPRT1D,SNOWRT1D,                                                               &
+       EFFC1D,EFFI1D,EFFS1D,EFFR1D,DT,                                                   &
+                                            IMS,IME, JMS,JME, KMS,KME,                   &
+                                            ITS,ITE, JTS,JTE, KTS,KTE,                   & ! HM ADD GRAUPEL
+                                    QG_TEND1D,NG_TEND1D,QG1D,NG1D,EFFG1D, &
+                                    qrcu1d, qscu1d, qicu1d, &
+! ADD SEDIMENTATION TENDENCIES
+                                  QGSTEN,QRSTEN,QISTEN,QNISTEN,QCSTEN, &
+                                  nc1d, nc_tend1d, iinum, C2PREC,CSED,ISED,SSED,GSED,RSED & !wrf-chem
+                       )
+
+   !
+   ! Transfer 1D arrays back into 3D arrays
+   !
+      do k=kts,kte
+
+! hm, add tendencies to update global variables 
+! HM, TENDENCIES FOR Q AND N NOW ADDED IN M2005MICRO, SO WE
+! ONLY NEED TO TRANSFER 1D VARIABLES BACK TO 3D
+
+          QC(i,k,j)        = QC1D(k)
+          QI(i,k,j)        = QI1D(k)
+          QS(i,k,j)        = QS1D(k)
+          QR(i,k,j)        = QR1D(k)
+          NI(i,k,j)        = NI1D(k)
+          NS(i,k,j)        = NS1D(k)          
+          NR(i,k,j)        = NR1D(k)
+	  QG(I,K,j)        = QG1D(K)
+          NG(I,K,j)        = NG1D(K)
+
+          T(i,k,j)         = T1D(k)
+          TH(I,K,J)        = T(i,k,j)/PII(i,k,j) ! CONVERT TEMP BACK TO POTENTIAL TEMP
+          QV(i,k,j)        = QV1D(k)
+
+          EFFC(i,k,j)      = EFFC1D(k)
+          EFFI(i,k,j)      = EFFI1D(k)
+          EFFS(i,k,j)      = EFFS1D(k)
+          EFFR(i,k,j)      = EFFR1D(k)
+	  EFFG(I,K,j)      = EFFG1D(K)
+
+! wrf-chem
+          IF (flag_qndrop .AND. PRESENT( qndrop )) THEN
+             qndrop(i,k,j) = nc1d(k)
+!jdf         CSED3D(I,K,J) = CSED(K)
+          END IF
+          IF ( PRESENT( QLSINK ) ) THEN
+             if(qc(i,k,j)>1.e-10) then
+                QLSINK(I,K,J)  = C2PREC(K)/QC(I,K,J)
+             else
+                QLSINK(I,K,J)  = 0.0
+             endif
+          END IF
+          IF ( PRESENT( PRECR ) ) PRECR(I,K,J) = RSED(K)
+          IF ( PRESENT( PRECI ) ) PRECI(I,K,J) = ISED(K)
+          IF ( PRESENT( PRECS ) ) PRECS(I,K,J) = SSED(K)
+          IF ( PRESENT( PRECG ) ) PRECG(I,K,J) = GSED(K)
+! EFFECTIVE RADIUS FOR RADIATION CODE (currently not coupled)
+! HM, ADD LIMIT TO PREVENT BLOWING UP OPTICAL PROPERTIES, 8/18/07
+!          EFFCS(I,K,J)     = MIN(EFFC(I,K,J),50.)
+!          EFFCS(I,K,J)     = MAX(EFFCS(I,K,J),1.)
+!          EFFIS(I,K,J)     = MIN(EFFI(I,K,J),130.)
+!          EFFIS(I,K,J)     = MAX(EFFIS(I,K,J),13.)
+
+      end do
+
+! hm modified so that m2005 precip variables correctly match wrf precip variables
+      RAINNC(i,j) = RAINNC(I,J)+PRECPRT1D
+      RAINNCV(i,j) = PRECPRT1D
+      SR(i,j) = SNOWRT1D/(PRECPRT1D+1.E-12)
+
+   end do
+   end do   
+
+END SUBROUTINE MP_MORR_TWO_MOMENT
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+      SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
+       NI3DTEN,NS3DTEN,NR3DTEN,QC3D,QI3D,QNI3D,QR3D,NI3D,NS3D,NR3D,              &
+       T3DTEN,QV3DTEN,T3D,QV3D,PRES,DZQ,W3D,WVAR,PRECRT,SNOWRT,            &
+       EFFC,EFFI,EFFS,EFFR,DT,                                                   &
+                                            IMS,IME, JMS,JME, KMS,KME,           &
+                                            ITS,ITE, JTS,JTE, KTS,KTE,           & ! ADD GRAUPEL
+                        QG3DTEN,NG3DTEN,QG3D,NG3D,EFFG,qrcu1d,qscu1d, qicu1d,    &
+                        QGSTEN,QRSTEN,QISTEN,QNISTEN,QCSTEN, &
+                        nc3d,nc3dten,iinum, & ! wrf-chem
+				c2prec,CSED,ISED,SSED,GSED,RSED  &  ! hm added, wrf-chem
+                        )
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! THIS PROGRAM IS THE MAIN TWO-MOMENT MICROPHYSICS SUBROUTINE DESCRIBED BY
+! MORRISON ET AL. 2005 JAS; MORRISON AND PINTO 2005 JAS.
+! ADDITIONAL CHANGES ARE DESCRIBED IN DETAIL BY MORRISON, THOMPSON, TATARSKII (MWR, SUBMITTED)
+
+! THIS SCHEME IS A BULK DOUBLE-MOMENT SCHEME THAT PREDICTS MIXING
+! RATIOS AND NUMBER CONCENTRATIONS OF FIVE HYDROMETEOR SPECIES:
+! CLOUD DROPLETS, CLOUD (SMALL) ICE, RAIN, SNOW, AND GRAUPEL.
+
+! CODE STRUCTURE: MAIN SUBROUTINE IS 'MORR_TWO_MOMENT'. ALSO INCLUDED IN THIS FILE IS
+! 'FUNCTION POLYSVP', 'FUNCTION DERF1', AND
+! 'FUNCTION GAMMA'.
+
+! NOTE: THIS SUBROUTINE USES 1D ARRAY IN VERTICAL (COLUMN), EVEN THOUGH VARIABLES ARE CALLED '3D'......
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+! DECLARATIONS
+
+      IMPLICIT NONE
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! THESE VARIABLES BELOW MUST BE LINKED WITH THE MAIN MODEL.
+! DEFINE ARRAY SIZES
+
+! INPUT NUMBER OF GRID CELLS
+
+! INPUT/OUTPUT PARAMETERS                                 ! DESCRIPTION (UNITS)
+      INTEGER, INTENT( IN)  :: IMS,IME, JMS,JME, KMS,KME,          &
+                               ITS,ITE, JTS,JTE, KTS,KTE
+
+      REAL, DIMENSION(KTS:KTE) ::  QC3DTEN            ! CLOUD WATER MIXING RATIO TENDENCY (KG/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  QI3DTEN            ! CLOUD ICE MIXING RATIO TENDENCY (KG/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  QNI3DTEN           ! SNOW MIXING RATIO TENDENCY (KG/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  QR3DTEN            ! RAIN MIXING RATIO TENDENCY (KG/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  NI3DTEN            ! CLOUD ICE NUMBER CONCENTRATION (1/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  NS3DTEN            ! SNOW NUMBER CONCENTRATION (1/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  NR3DTEN            ! RAIN NUMBER CONCENTRATION (1/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  QC3D               ! CLOUD WATER MIXING RATIO (KG/KG)
+      REAL, DIMENSION(KTS:KTE) ::  QI3D               ! CLOUD ICE MIXING RATIO (KG/KG)
+      REAL, DIMENSION(KTS:KTE) ::  QNI3D              ! SNOW MIXING RATIO (KG/KG)
+      REAL, DIMENSION(KTS:KTE) ::  QR3D               ! RAIN MIXING RATIO (KG/KG)
+      REAL, DIMENSION(KTS:KTE) ::  NI3D               ! CLOUD ICE NUMBER CONCENTRATION (1/KG)
+      REAL, DIMENSION(KTS:KTE) ::  NS3D               ! SNOW NUMBER CONCENTRATION (1/KG)
+      REAL, DIMENSION(KTS:KTE) ::  NR3D               ! RAIN NUMBER CONCENTRATION (1/KG)
+      REAL, DIMENSION(KTS:KTE) ::  T3DTEN             ! TEMPERATURE TENDENCY (K/S)
+      REAL, DIMENSION(KTS:KTE) ::  QV3DTEN            ! WATER VAPOR MIXING RATIO TENDENCY (KG/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  T3D                ! TEMPERATURE (K)
+      REAL, DIMENSION(KTS:KTE) ::  QV3D               ! WATER VAPOR MIXING RATIO (KG/KG)
+      REAL, DIMENSION(KTS:KTE) ::  PRES               ! ATMOSPHERIC PRESSURE (PA)
+      REAL, DIMENSION(KTS:KTE) ::  DZQ                ! DIFFERENCE IN HEIGHT ACROSS LEVEL (m)
+      REAL, DIMENSION(KTS:KTE) ::  W3D                ! GRID-SCALE VERTICAL VELOCITY (M/S)
+      REAL, DIMENSION(KTS:KTE) ::  WVAR               ! SUB-GRID VERTICAL VELOCITY (M/S)
+! below for wrf-chem
+      REAL, DIMENSION(KTS:KTE) ::  nc3d
+      REAL, DIMENSION(KTS:KTE) ::  nc3dten
+      integer, intent(in) :: iinum
+
+! HM ADDED GRAUPEL VARIABLES
+      REAL, DIMENSION(KTS:KTE) ::  QG3DTEN            ! GRAUPEL MIX RATIO TENDENCY (KG/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  NG3DTEN            ! GRAUPEL NUMB CONC TENDENCY (1/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  QG3D            ! GRAUPEL MIX RATIO (KG/KG)
+      REAL, DIMENSION(KTS:KTE) ::  NG3D            ! GRAUPEL NUMBER CONC (1/KG)
+
+! HM, ADD 1/16/07, SEDIMENTATION TENDENCIES FOR MIXING RATIO
+
+      REAL, DIMENSION(KTS:KTE) ::  QGSTEN            ! GRAUPEL SED TEND (KG/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  QRSTEN            ! RAIN SED TEND (KG/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  QISTEN            ! CLOUD ICE SED TEND (KG/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  QNISTEN           ! SNOW SED TEND (KG/KG/S)
+      REAL, DIMENSION(KTS:KTE) ::  QCSTEN            ! CLOUD WAT SED TEND (KG/KG/S)      
+
+! hm add cumulus tendencies for precip
+        REAL, DIMENSION(KTS:KTE) ::   qrcu1d
+        REAL, DIMENSION(KTS:KTE) ::   qscu1d
+        REAL, DIMENSION(KTS:KTE) ::   qicu1d
+
+! OUTPUT VARIABLES
+
+        REAL PRECRT                ! TOTAL PRECIP PER TIME STEP (mm)
+        REAL SNOWRT                ! SNOW PER TIME STEP (mm)
+
+        REAL, DIMENSION(KTS:KTE) ::   EFFC            ! DROPLET EFFECTIVE RADIUS (MICRON)
+        REAL, DIMENSION(KTS:KTE) ::   EFFI            ! CLOUD ICE EFFECTIVE RADIUS (MICRON)
+        REAL, DIMENSION(KTS:KTE) ::   EFFS            ! SNOW EFFECTIVE RADIUS (MICRON)
+        REAL, DIMENSION(KTS:KTE) ::   EFFR            ! RAIN EFFECTIVE RADIUS (MICRON)
+        REAL, DIMENSION(KTS:KTE) ::   EFFG            ! GRAUPEL EFFECTIVE RADIUS (MICRON)
+
+! MODEL INPUT PARAMETERS (FORMERLY IN COMMON BLOCKS)
+
+        REAL DT         ! MODEL TIME STEP (SEC)
+
+!.....................................................................................................
+! LOCAL VARIABLES: ALL PARAMETERS BELOW ARE LOCAL TO SCHEME AND DON'T NEED TO COMMUNICATE WITH THE
+! REST OF THE MODEL.
+
+! SIZE PARAMETER VARIABLES
+
+     REAL, DIMENSION(KTS:KTE) :: LAMC          ! SLOPE PARAMETER FOR DROPLETS (M-1)
+     REAL, DIMENSION(KTS:KTE) :: LAMI          ! SLOPE PARAMETER FOR CLOUD ICE (M-1)
+     REAL, DIMENSION(KTS:KTE) :: LAMS          ! SLOPE PARAMETER FOR SNOW (M-1)
+     REAL, DIMENSION(KTS:KTE) :: LAMR          ! SLOPE PARAMETER FOR RAIN (M-1)
+     REAL, DIMENSION(KTS:KTE) :: LAMG          ! SLOPE PARAMETER FOR GRAUPEL (M-1)
+     REAL, DIMENSION(KTS:KTE) :: CDIST1        ! PSD PARAMETER FOR DROPLETS
+     REAL, DIMENSION(KTS:KTE) :: N0I           ! INTERCEPT PARAMETER FOR CLOUD ICE (KG-1 M-1)
+     REAL, DIMENSION(KTS:KTE) :: N0S           ! INTERCEPT PARAMETER FOR SNOW (KG-1 M-1)
+     REAL, DIMENSION(KTS:KTE) :: N0RR          ! INTERCEPT PARAMETER FOR RAIN (KG-1 M-1)
+     REAL, DIMENSION(KTS:KTE) :: N0G           ! INTERCEPT PARAMETER FOR GRAUPEL (KG-1 M-1)
+     REAL, DIMENSION(KTS:KTE) :: PGAM          ! SPECTRAL SHAPE PARAMETER FOR DROPLETS
+
+! MICROPHYSICAL PROCESSES
+
+     REAL, DIMENSION(KTS:KTE) ::  NSUBC     ! LOSS OF NC DURING EVAP
+     REAL, DIMENSION(KTS:KTE) ::  NSUBI     ! LOSS OF NI DURING SUB.
+     REAL, DIMENSION(KTS:KTE) ::  NSUBS     ! LOSS OF NS DURING SUB.
+     REAL, DIMENSION(KTS:KTE) ::  NSUBR     ! LOSS OF NR DURING EVAP
+     REAL, DIMENSION(KTS:KTE) ::  PRD       ! DEP CLOUD ICE
+     REAL, DIMENSION(KTS:KTE) ::  PRE       ! EVAP OF RAIN
+     REAL, DIMENSION(KTS:KTE) ::  PRDS      ! DEP SNOW
+     REAL, DIMENSION(KTS:KTE) ::  NNUCCC    ! CHANGE N DUE TO CONTACT FREEZ DROPLETS
+     REAL, DIMENSION(KTS:KTE) ::  MNUCCC    ! CHANGE Q DUE TO CONTACT FREEZ DROPLETS
+     REAL, DIMENSION(KTS:KTE) ::  PRA       ! ACCRETION DROPLETS BY RAIN
+     REAL, DIMENSION(KTS:KTE) ::  PRC       ! AUTOCONVERSION DROPLETS
+     REAL, DIMENSION(KTS:KTE) ::  PCC       ! COND/EVAP DROPLETS
+     REAL, DIMENSION(KTS:KTE) ::  NNUCCD    ! CHANGE N FREEZING AEROSOL (PRIM ICE NUCLEATION)
+     REAL, DIMENSION(KTS:KTE) ::  MNUCCD    ! CHANGE Q FREEZING AEROSOL (PRIM ICE NUCLEATION)
+     REAL, DIMENSION(KTS:KTE) ::  MNUCCR    ! CHANGE Q DUE TO CONTACT FREEZ RAIN
+     REAL, DIMENSION(KTS:KTE) ::  NNUCCR    ! CHANGE N DUE TO CONTACT FREEZ RAIN
+     REAL, DIMENSION(KTS:KTE) ::  NPRA      ! CHANGE IN N DUE TO DROPLET ACC BY RAIN
+     REAL, DIMENSION(KTS:KTE) ::  NRAGG     ! SELF-COLLECTION OF RAIN
+     REAL, DIMENSION(KTS:KTE) ::  NSAGG     ! SELF-COLLECTION OF SNOW
+     REAL, DIMENSION(KTS:KTE) ::  NPRC      ! CHANGE NC AUTOCONVERSION DROPLETS
+     REAL, DIMENSION(KTS:KTE) ::  NPRC1      ! CHANGE NR AUTOCONVERSION DROPLETS
+     REAL, DIMENSION(KTS:KTE) ::  PRAI      ! CHANGE Q AUTOCONVERSION CLOUD ICE
+     REAL, DIMENSION(KTS:KTE) ::  PRCI      ! CHANGE Q ACCRETION CLOUD ICE BY SNOW
+     REAL, DIMENSION(KTS:KTE) ::  PSACWS    ! CHANGE Q DROPLET ACCRETION BY SNOW
+     REAL, DIMENSION(KTS:KTE) ::  NPSACWS   ! CHANGE N DROPLET ACCRETION BY SNOW
+     REAL, DIMENSION(KTS:KTE) ::  PSACWI    ! CHANGE Q DROPLET ACCRETION BY CLOUD ICE
+     REAL, DIMENSION(KTS:KTE) ::  NPSACWI   ! CHANGE N DROPLET ACCRETION BY CLOUD ICE
+     REAL, DIMENSION(KTS:KTE) ::  NPRCI     ! CHANGE N AUTOCONVERSION CLOUD ICE BY SNOW
+     REAL, DIMENSION(KTS:KTE) ::  NPRAI     ! CHANGE N ACCRETION CLOUD ICE
+     REAL, DIMENSION(KTS:KTE) ::  NMULTS    ! ICE MULT DUE TO RIMING DROPLETS BY SNOW
+     REAL, DIMENSION(KTS:KTE) ::  NMULTR    ! ICE MULT DUE TO RIMING RAIN BY SNOW
+     REAL, DIMENSION(KTS:KTE) ::  QMULTS    ! CHANGE Q DUE TO ICE MULT DROPLETS/SNOW
+     REAL, DIMENSION(KTS:KTE) ::  QMULTR    ! CHANGE Q DUE TO ICE RAIN/SNOW
+     REAL, DIMENSION(KTS:KTE) ::  PRACS     ! CHANGE Q RAIN-SNOW COLLECTION
+     REAL, DIMENSION(KTS:KTE) ::  NPRACS    ! CHANGE N RAIN-SNOW COLLECTION
+     REAL, DIMENSION(KTS:KTE) ::  PCCN      ! CHANGE Q DROPLET ACTIVATION
+     REAL, DIMENSION(KTS:KTE) ::  PSMLT     ! CHANGE Q MELTING SNOW TO RAIN
+     REAL, DIMENSION(KTS:KTE) ::  EVPMS     ! CHNAGE Q MELTING SNOW EVAPORATING
+     REAL, DIMENSION(KTS:KTE) ::  NSMLTS    ! CHANGE N MELTING SNOW
+     REAL, DIMENSION(KTS:KTE) ::  NSMLTR    ! CHANGE N MELTING SNOW TO RAIN
+! HM ADDED 12/13/06
+     REAL, DIMENSION(KTS:KTE) ::  PIACR     ! CHANGE QR, ICE-RAIN COLLECTION
+     REAL, DIMENSION(KTS:KTE) ::  NIACR     ! CHANGE N, ICE-RAIN COLLECTION
+     REAL, DIMENSION(KTS:KTE) ::  PRACI     ! CHANGE QI, ICE-RAIN COLLECTION
+     REAL, DIMENSION(KTS:KTE) ::  PIACRS     ! CHANGE QR, ICE RAIN COLLISION, ADDED TO SNOW
+     REAL, DIMENSION(KTS:KTE) ::  NIACRS     ! CHANGE N, ICE RAIN COLLISION, ADDED TO SNOW
+     REAL, DIMENSION(KTS:KTE) ::  PRACIS     ! CHANGE QI, ICE RAIN COLLISION, ADDED TO SNOW
+     REAL, DIMENSION(KTS:KTE) ::  EPRD      ! SUBLIMATION CLOUD ICE
+     REAL, DIMENSION(KTS:KTE) ::  EPRDS     ! SUBLIMATION SNOW
+! HM ADDED GRAUPEL PROCESSES
+     REAL, DIMENSION(KTS:KTE) ::  PRACG    ! CHANGE IN Q COLLECTION RAIN BY GRAUPEL
+     REAL, DIMENSION(KTS:KTE) ::  PSACWG    ! CHANGE IN Q COLLECTION DROPLETS BY GRAUPEL
+     REAL, DIMENSION(KTS:KTE) ::  PGSACW    ! CONVERSION Q TO GRAUPEL DUE TO COLLECTION DROPLETS BY SNOW
+     REAL, DIMENSION(KTS:KTE) ::  PGRACS    ! CONVERSION Q TO GRAUPEL DUE TO COLLECTION RAIN BY SNOW
+     REAL, DIMENSION(KTS:KTE) ::  PRDG    ! DEP OF GRAUPEL
+     REAL, DIMENSION(KTS:KTE) ::  EPRDG    ! SUB OF GRAUPEL
+     REAL, DIMENSION(KTS:KTE) ::  EVPMG    ! CHANGE Q MELTING OF GRAUPEL AND EVAPORATION
+     REAL, DIMENSION(KTS:KTE) ::  PGMLT    ! CHANGE Q MELTING OF GRAUPEL
+     REAL, DIMENSION(KTS:KTE) ::  NPRACG    ! CHANGE N COLLECTION RAIN BY GRAUPEL
+     REAL, DIMENSION(KTS:KTE) ::  NPSACWG    ! CHANGE N COLLECTION DROPLETS BY GRAUPEL
+     REAL, DIMENSION(KTS:KTE) ::  NSCNG    ! CHANGE N CONVERSION TO GRAUPEL DUE TO COLLECTION DROPLETS BY SNOW
+     REAL, DIMENSION(KTS:KTE) ::  NGRACS    ! CHANGE N CONVERSION TO GRAUPEL DUE TO COLLECTION RAIN BY SNOW
+     REAL, DIMENSION(KTS:KTE) ::  NGMLTG    ! CHANGE N MELTING GRAUPEL
+     REAL, DIMENSION(KTS:KTE) ::  NGMLTR    ! CHANGE N MELTING GRAUPEL TO RAIN
+     REAL, DIMENSION(KTS:KTE) ::  NSUBG    ! CHANGE N SUB/DEP OF GRAUPEL
+     REAL, DIMENSION(KTS:KTE) ::  PSACR    ! CONVERSION DUE TO COLL OF SNOW BY RAIN
+     REAL, DIMENSION(KTS:KTE) ::  NMULTG    ! ICE MULT DUE TO ACC DROPLETS BY GRAUPEL
+     REAL, DIMENSION(KTS:KTE) ::  NMULTRG    ! ICE MULT DUE TO ACC RAIN BY GRAUPEL
+     REAL, DIMENSION(KTS:KTE) ::  QMULTG    ! CHANGE Q DUE TO ICE MULT DROPLETS/GRAUPEL
+     REAL, DIMENSION(KTS:KTE) ::  QMULTRG    ! CHANGE Q DUE TO ICE MULT RAIN/GRAUPEL
+
+! TIME-VARYING ATMOSPHERIC PARAMETERS
+
+     REAL, DIMENSION(KTS:KTE) ::   KAP   ! THERMAL CONDUCTIVITY OF AIR
+     REAL, DIMENSION(KTS:KTE) ::   EVS   ! SATURATION VAPOR PRESSURE
+     REAL, DIMENSION(KTS:KTE) ::   EIS   ! ICE SATURATION VAPOR PRESSURE
+     REAL, DIMENSION(KTS:KTE) ::   QVS   ! SATURATION MIXING RATIO
+     REAL, DIMENSION(KTS:KTE) ::   QVI   ! ICE SATURATION MIXING RATIO
+     REAL, DIMENSION(KTS:KTE) ::   QVQVS ! SAUTRATION RATIO
+     REAL, DIMENSION(KTS:KTE) ::   QVQVSI! ICE SATURAION RATIO
+     REAL, DIMENSION(KTS:KTE) ::   DV    ! DIFFUSIVITY OF WATER VAPOR IN AIR
+     REAL, DIMENSION(KTS:KTE) ::   XXLS  ! LATENT HEAT OF SUBLIMATION
+     REAL, DIMENSION(KTS:KTE) ::   XXLV  ! LATENT HEAT OF VAPORIZATION
+     REAL, DIMENSION(KTS:KTE) ::   CPM   ! SPECIFIC HEAT AT CONST PRESSURE FOR MOIST AIR
+     REAL, DIMENSION(KTS:KTE) ::   MU    ! VISCOCITY OF AIR
+     REAL, DIMENSION(KTS:KTE) ::   SC    ! SCHMIDT NUMBER
+     REAL, DIMENSION(KTS:KTE) ::   XLF   ! LATENT HEAT OF FREEZING
+     REAL, DIMENSION(KTS:KTE) ::   RHO   ! AIR DENSITY
+     REAL, DIMENSION(KTS:KTE) ::   AB    ! CORRECTION TO CONDENSATION RATE DUE TO LATENT HEATING
+     REAL, DIMENSION(KTS:KTE) ::   ABI    ! CORRECTION TO DEPOSITION RATE DUE TO LATENT HEATING
+
+! TIME-VARYING MICROPHYSICS PARAMETERS
+
+     REAL, DIMENSION(KTS:KTE) ::   DAP    ! DIFFUSIVITY OF AEROSOL
+     REAL    NACNT                    ! NUMBER OF CONTACT IN
+     REAL    FMULT                    ! TEMP.-DEP. PARAMETER FOR RIME-SPLINTERING
+     REAL    COFFI                    ! ICE AUTOCONVERSION PARAMETER
+
+! FALL SPEED WORKING VARIABLES (DEFINED IN CODE)
+
+      REAL, DIMENSION(KTS:KTE) ::    DUMI,DUMR,DUMFNI,DUMG,DUMFNG
+      REAL UNI, UMI,UMR
+      REAL, DIMENSION(KTS:KTE) ::    FR, FI, FNI,FG,FNG
+      REAL RGVM
+      REAL, DIMENSION(KTS:KTE) ::   FALOUTR,FALOUTI,FALOUTNI
+      REAL FALTNDR,FALTNDI,FALTNDNI,RHO2
+      REAL, DIMENSION(KTS:KTE) ::   DUMQS,DUMFNS
+      REAL UMS,UNS
+      REAL, DIMENSION(KTS:KTE) ::   FS,FNS, FALOUTS,FALOUTNS,FALOUTG,FALOUTNG
+      REAL FALTNDS,FALTNDNS,UNR,FALTNDG,FALTNDNG
+      REAL, DIMENSION(KTS:KTE) ::    DUMC,DUMFNC
+      REAL UNC,UMC,UNG,UMG
+      REAL, DIMENSION(KTS:KTE) ::   FC,FALOUTC,FALOUTNC
+      REAL FALTNDC,FALTNDNC
+      REAL, DIMENSION(KTS:KTE) ::   FNC,DUMFNR,FALOUTNR
+      REAL FALTNDNR
+      REAL, DIMENSION(KTS:KTE) ::   FNR
+
+! FALL-SPEED PARAMETER 'A' WITH AIR DENSITY CORRECTION
+
+      REAL, DIMENSION(KTS:KTE) ::    AIN,ARN,ASN,ACN,AGN
+
+! EXTERNAL FUNCTION CALL RETURN VARIABLES
+
+!      REAL GAMMA,      ! EULER GAMMA FUNCTION
+!      REAL POLYSVP,    ! SAT. PRESSURE FUNCTION
+!      REAL DERF1        ! ERROR FUNCTION
+
+! DUMMY VARIABLES
+
+     REAL DUM,DUM1,DUM2,DUMT,DUMQV,DUMQSS,DUMQSI,DUMS
+
+! PROGNOSTIC SUPERSATURATION
+
+     REAL DQSDT    ! CHANGE OF SAT. MIX. RAT. WITH TEMPERATURE
+     REAL DQSIDT   ! CHANGE IN ICE SAT. MIXING RAT. WITH T
+     REAL EPSI     ! 1/PHASE REL. TIME (SEE M2005), ICE
+     REAL EPSS     ! 1/PHASE REL. TIME (SEE M2005), SNOW
+     REAL EPSR     ! 1/PHASE REL. TIME (SEE M2005), RAIN
+     REAL EPSG     ! 1/PHASE REL. TIME (SEE M2005), GRAUPEL
+
+! NEW DROPLET ACTIVATION VARIABLES
+     REAL TAUC     ! PHASE REL. TIME (SEE M2005), DROPLETS
+     REAL TAUR     ! PHASE REL. TIME (SEE M2005), RAIN
+     REAL TAUI     ! PHASE REL. TIME (SEE M2005), CLOUD ICE
+     REAL TAUS     ! PHASE REL. TIME (SEE M2005), SNOW
+     REAL TAUG     ! PHASE REL. TIME (SEE M2005), GRAUPEL
+     REAL DUMACT,DUM3
+
+! COUNTING/INDEX VARIABLES
+
+     INTEGER K,NSTEP,N ! ,I
+
+! LTRUE IS ONLY USED TO SPEED UP THE CODE !!
+! LTRUE, SWITCH = 0, NO HYDROMETEORS IN COLUMN, 
+!               = 1, HYDROMETEORS IN COLUMN
+
+      INTEGER LTRUE
+
+! DROPLET ACTIVATION/FREEZING AEROSOL
+
+
+     REAL    CT      ! DROPLET ACTIVATION PARAMETER
+     REAL    TEMP1   ! DUMMY TEMPERATURE
+     REAL    SAT1    ! DUMMY SATURATION
+     REAL    SIGVL   ! SURFACE TENSION LIQ/VAPOR
+     REAL    KEL     ! KELVIN PARAMETER
+     REAL    KC2     ! TOTAL ICE NUCLEATION RATE
+
+       REAL CRY,KRY   ! AEROSOL ACTIVATION PARAMETERS
+
+! MORE WORKING/DUMMY VARIABLES
+
+     REAL DUMQI,DUMNI,DC0,DS0,DG0
+     REAL DUMQC,DUMQR,RATIO,SUM_DEP,FUDGEF
+
+! EFFECTIVE VERTICAL VELOCITY  (M/S)
+     REAL WEF
+
+! WORKING PARAMETERS FOR ICE NUCLEATION
+
+      REAL ANUC,BNUC
+
+! WORKING PARAMETERS FOR AEROSOL ACTIVATION
+
+        REAL AACT,GAMM,GG,PSI,ETA1,ETA2,SM1,SM2,SMAX,UU1,UU2,ALPHA
+
+! DUMMY SIZE DISTRIBUTION PARAMETERS
+
+        REAL DLAMS,DLAMR,DLAMI,DLAMC,DLAMG,LAMMAX,LAMMIN
+
+        INTEGER IDROP
+
+! FOR WRF-CHEM
+	REAL, DIMENSION(KTS:KTE)::C2PREC,CSED,ISED,SSED,GSED,RSED 
+
+! comment lines for wrf-chem since these are intent(in) in that case
+!       REAL, DIMENSION(KTS:KTE) ::  NC3DTEN            ! CLOUD DROPLET NUMBER CONCENTRATION (1/KG/S)
+!       REAL, DIMENSION(KTS:KTE) ::  NC3D               ! CLOUD DROPLET NUMBER CONCENTRATION (1/KG)
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+! SET LTRUE INITIALLY TO 0
+
+         LTRUE = 0
+
+! ATMOSPHERIC PARAMETERS THAT VARY IN TIME AND HEIGHT
+         DO K = KTS,KTE
+
+! NC3DTEN LOCAL ARRAY INITIALIZED
+               NC3DTEN(K) = 0.
+! INITIALIZE VARIABLES FOR WRF-CHEM OUTPUT TO ZERO
+
+		C2PREC(K)=0.
+		CSED(K)=0.
+		ISED(K)=0.
+		SSED(K)=0.
+		GSED(K)=0.
+		RSED(K)=0.
+
+! LATENT HEAT OF VAPORATION
+
+            XXLV(K) = 3.1484E6-2370.*T3D(K)
+
+! LATENT HEAT OF SUBLIMATION
+
+            XXLS(K) = 3.15E6-2370.*T3D(K)+0.3337E6
+
+            CPM(K) = CP*(1.+0.887*QV3D(K))
+
+! SATURATION VAPOR PRESSURE AND MIXING RATIO
+
+! hm, add fix for low pressure, 5/12/10
+            EVS(K) = min(0.99*pres(k),POLYSVP(T3D(K),0))   ! PA
+            EIS(K) = min(0.99*pres(k),POLYSVP(T3D(K),1))   ! PA
+
+! MAKE SURE ICE SATURATION DOESN'T EXCEED WATER SAT. NEAR FREEZING
+
+            IF (EIS(K).GT.EVS(K)) EIS(K) = EVS(K)
+
+            QVS(K) = EP_2*EVS(K)/(PRES(K)-EVS(K))
+            QVI(K) = EP_2*EIS(K)/(PRES(K)-EIS(K))
+
+            QVQVS(K) = QV3D(K)/QVS(K)
+            QVQVSI(K) = QV3D(K)/QVI(K)
+
+! AIR DENSITY
+
+            RHO(K) = PRES(K)/(R*T3D(K))
+
+! ADD NUMBER CONCENTRATION DUE TO CUMULUS TENDENCY
+! ASSUME N0 ASSOCIATED WITH CUMULUS PARAM RAIN IS 10^7 M^-4
+! ASSUME N0 ASSOCIATED WITH CUMULUS PARAM SNOW IS 2 X 10^7 M^-4
+! FOR DETRAINED CLOUD ICE, ASSUME MEAN VOLUME DIAM OF 80 MICRON
+
+            IF (QRCU1D(K).GE.1.E-10) THEN
+            DUM=1.8e5*(QRCU1D(K)*DT/(PI*RHOW*RHO(K)**3))**0.25
+            NR3D(K)=NR3D(K)+DUM
+            END IF
+            IF (QSCU1D(K).GE.1.E-10) THEN
+            DUM=3.e5*(QSCU1D(K)*DT/(CONS1*RHO(K)**3))**(1./(DS+1.))
+            NS3D(K)=NS3D(K)+DUM
+            END IF
+            IF (QICU1D(K).GE.1.E-10) THEN
+            DUM=QICU1D(K)*DT/(CI*(80.E-6)**DI)
+            NI3D(K)=NI3D(K)+DUM
+            END IF
+
+! AT SUBSATURATION, REMOVE SMALL AMOUNTS OF CLOUD/PRECIP WATER
+! hm modify 7/0/09 change limit to 1.e-8
+
+             IF (QVQVS(K).LT.0.9) THEN
+               IF (QR3D(K).LT.1.E-8) THEN
+                  QV3D(K)=QV3D(K)+QR3D(K)
+                  T3D(K)=T3D(K)-QR3D(K)*XXLV(K)/CPM(K)
+                  QR3D(K)=0.
+               END IF
+               IF (QC3D(K).LT.1.E-8) THEN
+                  QV3D(K)=QV3D(K)+QC3D(K)
+                  T3D(K)=T3D(K)-QC3D(K)*XXLV(K)/CPM(K)
+                  QC3D(K)=0.
+               END IF
+             END IF
+
+             IF (QVQVSI(K).LT.0.9) THEN
+               IF (QI3D(K).LT.1.E-8) THEN
+                  QV3D(K)=QV3D(K)+QI3D(K)
+                  T3D(K)=T3D(K)-QI3D(K)*XXLS(K)/CPM(K)
+                  QI3D(K)=0.
+               END IF
+               IF (QNI3D(K).LT.1.E-8) THEN
+                  QV3D(K)=QV3D(K)+QNI3D(K)
+                  T3D(K)=T3D(K)-QNI3D(K)*XXLS(K)/CPM(K)
+                  QNI3D(K)=0.
+               END IF
+               IF (QG3D(K).LT.1.E-8) THEN
+                  QV3D(K)=QV3D(K)+QG3D(K)
+                  T3D(K)=T3D(K)-QG3D(K)*XXLS(K)/CPM(K)
+                  QG3D(K)=0.
+               END IF
+             END IF
+
+! HEAT OF FUSION
+
+            XLF(K) = XXLS(K)-XXLV(K)
+
+!..................................................................
+! IF MIXING RATIO < QSMALL SET MIXING RATIO AND NUMBER CONC TO ZERO
+
+       IF (QC3D(K).LT.QSMALL) THEN
+         QC3D(K) = 0.
+         NC3D(K) = 0.
+         EFFC(K) = 0.
+       END IF
+       IF (QR3D(K).LT.QSMALL) THEN
+         QR3D(K) = 0.
+         NR3D(K) = 0.
+         EFFR(K) = 0.
+       END IF
+       IF (QI3D(K).LT.QSMALL) THEN
+         QI3D(K) = 0.
+         NI3D(K) = 0.
+         EFFI(K) = 0.
+       END IF
+       IF (QNI3D(K).LT.QSMALL) THEN
+         QNI3D(K) = 0.
+         NS3D(K) = 0.
+         EFFS(K) = 0.
+       END IF
+       IF (QG3D(K).LT.QSMALL) THEN
+         QG3D(K) = 0.
+         NG3D(K) = 0.
+         EFFG(K) = 0.
+       END IF
+
+! INITIALIZE SEDIMENTATION TENDENCIES FOR MIXING RATIO
+
+      QRSTEN(K) = 0.
+      QISTEN(K) = 0.
+      QNISTEN(K) = 0.
+      QCSTEN(K) = 0.
+      QGSTEN(K) = 0.
+
+!..................................................................
+! MICROPHYSICS PARAMETERS VARYING IN TIME/HEIGHT
+
+! FALL SPEED WITH DENSITY CORRECTION (HEYMSFIELD AND BENSSEMER 2006)
+
+            DUM = (RHOSU/RHO(K))**0.54
+
+            AIN(K) = DUM*AI
+            ARN(K) = DUM*AR
+            ASN(K) = DUM*AS
+            ACN(K) = DUM*AC
+! HM ADD GRAUPEL 8/28/06
+            AGN(K) = DUM*AG
+
+!hm 4/7/09 bug fix, initialize lami to prevent later division by zero
+            LAMI(K)=0.
+
+!..................................
+! IF THERE IS NO CLOUD/PRECIP WATER, AND IF SUBSATURATED, THEN SKIP MICROPHYSICS
+! FOR THIS LEVEL
+
+            IF (QC3D(K).LT.QSMALL.AND.QI3D(K).LT.QSMALL.AND.QNI3D(K).LT.QSMALL &
+                 .AND.QR3D(K).LT.QSMALL.AND.QG3D(K).LT.QSMALL) THEN
+                 IF (T3D(K).LT.273.15.AND.QVQVSI(K).LT.0.999) GOTO 200
+                 IF (T3D(K).GE.273.15.AND.QVQVS(K).LT.0.999) GOTO 200
+            END IF
+
+! THERMAL CONDUCTIVITY FOR AIR
+
+            DUM = 1.496E-6*T3D(K)**1.5/(T3D(K)+120.)
+
+!            KAP(K) = 1.414E3*1.496E-6*T3D(K)**1.5/(T3D(K)+120.)
+            KAP(K) = 1.414E3*DUM
+
+! DIFFUSIVITY OF WATER VAPOR
+
+            DV(K) = 8.794E-5*T3D(K)**1.81/PRES(K)
+
+! VISCOSITY OF AIR
+! SCHMIT NUMBER
+
+!            MU(K) = 1.496E-6*T3D(K)**1.5/(T3D(K)+120.)/RHO(K)
+            MU(K) = DUM/RHO(K)
+            SC(K) = MU(K)/DV(K)
+
+! PSYCHOMETIC CORRECTIONS
+
+! RATE OF CHANGE SAT. MIX. RATIO WITH TEMPERATURE
+
+            DUM = (RV*T3D(K)**2)
+
+            DQSDT = XXLV(K)*QVS(K)/DUM
+            DQSIDT =  XXLS(K)*QVI(K)/DUM
+
+            ABI(K) = 1.+DQSIDT*XXLS(K)/CPM(K)
+            AB(K) = 1.+DQSDT*XXLV(K)/CPM(K)
+
+! 
+!.....................................................................
+!.....................................................................
+! CASE FOR TEMPERATURE ABOVE FREEZING
+
+            IF (T3D(K).GE.273.15) THEN
+
+!......................................................................
+!HM ADD, ALLOW FOR CONSTANT DROPLET NUMBER
+! INUM = 0, PREDICT DROPLET NUMBER
+! INUM = 1, SET CONSTANT DROPLET NUMBER
+
+         IF (iinum.EQ.1) THEN
+! CONVERT NDCNST FROM CM-3 TO KG-1
+            NC3D(K)=NDCNST*1.E6/RHO(K)
+         END IF
+
+! GET SIZE DISTRIBUTION PARAMETERS
+
+! MELT VERY SMALL SNOW AND GRAUPEL MIXING RATIOS, ADD TO RAIN
+       IF (QNI3D(K).LT.1.E-6) THEN
+          QR3D(K)=QR3D(K)+QNI3D(K)
+          NR3D(K)=NR3D(K)+NS3D(K)
+          T3D(K)=T3D(K)-QNI3D(K)*XLF(K)/CPM(K)
+          QNI3D(K) = 0.
+          NS3D(K) = 0.
+       END IF
+       IF (QG3D(K).LT.1.E-6) THEN
+          QR3D(K)=QR3D(K)+QG3D(K)
+          NR3D(K)=NR3D(K)+NG3D(K)
+          T3D(K)=T3D(K)-QG3D(K)*XLF(K)/CPM(K)
+          QG3D(K) = 0.
+          NG3D(K) = 0.
+       END IF
+
+       IF (QC3D(K).LT.QSMALL.AND.QNI3D(K).LT.1.E-8.AND.QR3D(K).LT.QSMALL.AND.QG3D(K).LT.1.E-8) GOTO 300
+
+! MAKE SURE NUMBER CONCENTRATIONS AREN'T NEGATIVE
+
+      NS3D(K) = MAX(0.,NS3D(K))
+      NC3D(K) = MAX(0.,NC3D(K))
+      NR3D(K) = MAX(0.,NR3D(K))
+      NG3D(K) = MAX(0.,NG3D(K))
+
+!......................................................................
+! RAIN
+
+      IF (QR3D(K).GE.QSMALL) THEN
+      LAMR(K) = (PI*RHOW*NR3D(K)/QR3D(K))**(1./3.)
+      N0RR(K) = NR3D(K)*LAMR(K)
+
+! CHECK FOR SLOPE
+
+! ADJUST VARS
+
+      IF (LAMR(K).LT.LAMMINR) THEN
+
+      LAMR(K) = LAMMINR
+
+      N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW)
+
+      NR3D(K) = N0RR(K)/LAMR(K)
+      ELSE IF (LAMR(K).GT.LAMMAXR) THEN
+      LAMR(K) = LAMMAXR
+      N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW)
+
+      NR3D(K) = N0RR(K)/LAMR(K)
+      END IF
+      END IF
+
+!......................................................................
+! CLOUD DROPLETS
+
+! MARTIN ET AL. (1994) FORMULA FOR PGAM
+
+      IF (QC3D(K).GE.QSMALL) THEN
+
+         DUM = PRES(K)/(287.15*T3D(K))
+         PGAM(K)=0.0005714*(NC3D(K)/1.E6*DUM)+0.2714
+         PGAM(K)=1./(PGAM(K)**2)-1.
+         PGAM(K)=MAX(PGAM(K),2.)
+         PGAM(K)=MIN(PGAM(K),10.)
+
+! CALCULATE LAMC
+
+      LAMC(K) = (CONS26*NC3D(K)*GAMMA(PGAM(K)+4.)/   &
+                 (QC3D(K)*GAMMA(PGAM(K)+1.)))**(1./3.)
+
+! LAMMIN, 60 MICRON DIAMETER
+! LAMMAX, 1 MICRON
+
+      LAMMIN = (PGAM(K)+1.)/60.E-6
+      LAMMAX = (PGAM(K)+1.)/1.E-6
+
+      IF (LAMC(K).LT.LAMMIN) THEN
+      LAMC(K) = LAMMIN
+
+      NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+              &
+                LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26
+      ELSE IF (LAMC(K).GT.LAMMAX) THEN
+      LAMC(K) = LAMMAX
+
+      NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+              &
+                LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26
+
+      END IF
+
+      END IF
+
+!......................................................................
+! SNOW
+
+      IF (QNI3D(K).GE.QSMALL) THEN
+      LAMS(K) = (CONS1*NS3D(K)/QNI3D(K))**(1./DS)
+      N0S(K) = NS3D(K)*LAMS(K)
+
+! CHECK FOR SLOPE
+
+! ADJUST VARS
+
+      IF (LAMS(K).LT.LAMMINS) THEN
+      LAMS(K) = LAMMINS
+      N0S(K) = LAMS(K)**4*QNI3D(K)/CONS1
+
+      NS3D(K) = N0S(K)/LAMS(K)
+
+      ELSE IF (LAMS(K).GT.LAMMAXS) THEN
+
+      LAMS(K) = LAMMAXS
+      N0S(K) = LAMS(K)**4*QNI3D(K)/CONS1
+
+      NS3D(K) = N0S(K)/LAMS(K)
+      END IF
+      END IF
+
+!......................................................................
+! GRAUPEL
+
+      IF (QG3D(K).GE.QSMALL) THEN
+      LAMG(K) = (CONS2*NG3D(K)/QG3D(K))**(1./DG)
+      N0G(K) = NG3D(K)*LAMG(K)
+
+! ADJUST VARS
+
+      IF (LAMG(K).LT.LAMMING) THEN
+      LAMG(K) = LAMMING
+      N0G(K) = LAMG(K)**4*QG3D(K)/CONS2
+
+      NG3D(K) = N0G(K)/LAMG(K)
+
+      ELSE IF (LAMG(K).GT.LAMMAXG) THEN
+
+      LAMG(K) = LAMMAXG
+      N0G(K) = LAMG(K)**4*QG3D(K)/CONS2
+
+      NG3D(K) = N0G(K)/LAMG(K)
+      END IF
+      END IF
+
+!.....................................................................
+! ZERO OUT PROCESS RATES
+
+            PRC(K) = 0.
+            NPRC(K) = 0.
+            NPRC1(K) = 0.
+            PRA(K) = 0.
+            NPRA(K) = 0.
+            NRAGG(K) = 0.
+            PSMLT(K) = 0.
+            NSMLTS(K) = 0.
+            NSMLTR(K) = 0.
+            EVPMS(K) = 0.
+            PCC(K) = 0.
+            PRE(K) = 0.
+            NSUBC(K) = 0.
+            NSUBR(K) = 0.
+            PRACG(K) = 0.
+            NPRACG(K) = 0.
+            PSMLT(K) = 0.
+            EVPMS(K) = 0.
+            PGMLT(K) = 0.
+            EVPMG(K) = 0.
+            PRACS(K) = 0.
+            NPRACS(K) = 0.
+            NGMLTG(K) = 0.
+            NGMLTR(K) = 0.
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! CALCULATION OF MICROPHYSICAL PROCESS RATES, T > 273.15 K
+
+!.................................................................
+!.......................................................................
+! AUTOCONVERSION OF CLOUD LIQUID WATER TO RAIN
+! FORMULA FROM BEHENG (1994)
+! USING NUMERICAL SIMULATION OF STOCHASTIC COLLECTION EQUATION
+! AND INITIAL CLOUD DROPLET SIZE DISTRIBUTION SPECIFIED
+! AS A GAMMA DISTRIBUTION
+
+! USE MINIMUM VALUE OF 1.E-6 TO PREVENT FLOATING POINT ERROR
+
+         IF (QC3D(K).GE.1.E-6) THEN
+
+! HM ADD 12/13/06, REPLACE WITH NEWER FORMULA
+! FROM KHAIROUTDINOV AND KOGAN 2000, MWR
+
+                PRC(K)=1350.*QC3D(K)**2.47*  &
+           (NC3D(K)/1.e6*RHO(K))**(-1.79)
+
+! note: nprc1 is change in Nr,
+! nprc is change in Nc
+
+        NPRC1(K) = PRC(K)/CONS29
+        NPRC(K) = PRC(K)/(QC3D(k)/NC3D(K))
+
+                NPRC(K) = MIN(NPRC(K),NC3D(K)/DT)
+
+         END IF
+
+!.......................................................................
+! HM ADD 12/13/06, COLLECTION OF SNOW BY RAIN ABOVE FREEZING
+! FORMULA FROM IKAWA AND SAITO (1991)
+
+         IF (QR3D(K).GE.1.E-8.AND.QNI3D(K).GE.1.E-8) THEN
+
+            UMS = ASN(K)*CONS3/(LAMS(K)**BS)
+            UMR = ARN(K)*CONS4/(LAMR(K)**BR)
+            UNS = ASN(K)*CONS5/LAMS(K)**BS
+            UNR = ARN(K)*CONS6/LAMR(K)**BR
+
+! SET REASLISTIC LIMITS ON FALLSPEEDS
+
+! bug fix, 10/08/09
+            dum=(rhosu/rho(k))**0.54
+            UMS=MIN(UMS,1.2*dum)
+            UNS=MIN(UNS,1.2*dum)
+            UMR=MIN(UMR,9.1*dum)
+            UNR=MIN(UNR,9.1*dum)
+
+            PRACS(K) = CONS31*(((1.2*UMR-0.95*UMS)**2+              &
+                  0.08*UMS*UMR)**0.5*RHO(K)*                     &
+                 N0RR(K)*N0S(K)/LAMS(K)**3*                    &
+                  (5./(LAMS(K)**3*LAMR(K))+                    &
+                  2./(LAMS(K)**2*LAMR(K)**2)+                  &
+                  0.5/(LAMS(K)*LAMR(K)**3)))
+
+            NPRACS(K) = CONS32*RHO(K)*(1.7*(UNR-UNS)**2+            &
+                0.3*UNR*UNS)**0.5*N0RR(K)*N0S(K)*              &
+                (1./(LAMR(K)**3*LAMS(K))+                      &
+                 1./(LAMR(K)**2*LAMS(K)**2)+                   &
+                 1./(LAMR(K)*LAMS(K)**3))
+
+         END IF
+
+! ADD COLLECTION OF GRAUPEL BY RAIN ABOVE FREEZING
+! ASSUME ALL RAIN COLLECTION BY GRAUPEL ABOVE FREEZING IS SHED
+! ASSUME SHED DROPS ARE 1 MM IN SIZE
+
+         IF (QR3D(K).GE.1.E-8.AND.QG3D(K).GE.1.E-8) THEN
+
+            UMG = AGN(K)*CONS7/(LAMG(K)**BG)
+            UMR = ARN(K)*CONS4/(LAMR(K)**BR)
+            UNG = AGN(K)*CONS8/LAMG(K)**BG
+            UNR = ARN(K)*CONS6/LAMR(K)**BR
+
+! SET REASLISTIC LIMITS ON FALLSPEEDS
+! bug fix, 10/08/09
+            dum=(rhosu/rho(k))**0.54
+            UMG=MIN(UMG,20.*dum)
+            UNG=MIN(UNG,20.*dum)
+            UMR=MIN(UMR,9.1*dum)
+            UNR=MIN(UNR,9.1*dum)
+
+! PRACG IS MIXING RATIO OF RAIN PER SEC COLLECTED BY GRAUPEL/HAIL
+            PRACG(K) = CONS41*(((1.2*UMR-0.95*UMG)**2+                   &
+                  0.08*UMG*UMR)**0.5*RHO(K)*                      &
+                  N0RR(K)*N0G(K)/LAMR(K)**3*                              &
+                  (5./(LAMR(K)**3*LAMG(K))+                    &
+                  2./(LAMR(K)**2*LAMG(K)**2)+				   &
+				  0.5/(LAMR(k)*LAMG(k)**3)))
+
+! ASSUME 1 MM DROPS ARE SHED, GET NUMBER SHED PER SEC
+
+            DUM = PRACG(K)/5.2E-7
+
+            NPRACG(K) = CONS32*RHO(K)*(1.7*(UNR-UNG)**2+            &
+                0.3*UNR*UNG)**0.5*N0RR(K)*N0G(K)*              &
+                (1./(LAMR(K)**3*LAMG(K))+                      &
+                 1./(LAMR(K)**2*LAMG(K)**2)+                   &
+                 1./(LAMR(K)*LAMG(K)**3))
+
+            NPRACG(K)=MAX(NPRACG(K)-DUM,0.)
+
+	    END IF
+
+!.......................................................................
+! ACCRETION OF CLOUD LIQUID WATER BY RAIN
+! CONTINUOUS COLLECTION EQUATION WITH
+! GRAVITATIONAL COLLECTION KERNEL, DROPLET FALL SPEED NEGLECTED
+
+         IF (QR3D(K).GE.1.E-8 .AND. QC3D(K).GE.1.E-8) THEN
+
+! 12/13/06 HM ADD, REPLACE WITH NEWER FORMULA FROM
+! KHAIROUTDINOV AND KOGAN 2000, MWR
+
+           DUM=(QC3D(K)*QR3D(K))
+           PRA(K) = 67.*(DUM)**1.15
+           NPRA(K) = PRA(K)/(QC3D(K)/NC3D(K))
+
+         END IF
+!.......................................................................
+! SELF-COLLECTION OF RAIN DROPS
+! FROM BEHENG(1994)
+! FROM NUMERICAL SIMULATION OF THE STOCHASTIC COLLECTION EQUATION
+! AS DESCRINED ABOVE FOR AUTOCONVERSION
+
+         IF (QR3D(K).GE.1.E-8) THEN
+! include breakup add 10/09/09
+            dum1=300.e-6
+            if (1./lamr(k).lt.dum1) then
+            dum=1.
+            else if (1./lamr(k).ge.dum1) then
+            dum=2.-exp(2300.*(1./lamr(k)-dum1))
+            end if
+!            NRAGG(K) = -8.*NR3D(K)*QR3D(K)*RHO(K)
+            NRAGG(K) = -5.78*dum*NR3D(K)*QR3D(K)*RHO(K)
+         END IF
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! CALCULATE EVAP OF RAIN (RUTLEDGE AND HOBBS 1983)
+
+      IF (QR3D(K).GE.QSMALL) THEN
+        EPSR = 2.*PI*N0RR(K)*RHO(K)*DV(K)*                           &
+                   (F1R/(LAMR(K)*LAMR(K))+                       &
+                    F2R*(ARN(K)*RHO(K)/MU(K))**0.5*                      &
+                    SC(K)**(1./3.)*CONS9/                   &
+                (LAMR(K)**CONS34))
+      ELSE
+      EPSR = 0.
+      END IF
+
+! NO CONDENSATION ONTO RAIN, ONLY EVAP ALLOWED
+
+           IF (QV3D(K).LT.QVS(K)) THEN
+              PRE(K) = EPSR*(QV3D(K)-QVS(K))/AB(K)
+              PRE(K) = MIN(PRE(K),0.)
+           ELSE
+              PRE(K) = 0.
+           END IF
+
+!.......................................................................
+! MELTING OF SNOW
+
+! SNOW MAY PERSITS ABOVE FREEZING, FORMULA FROM RUTLEDGE AND HOBBS, 1984
+! IF WATER SUPERSATURATION, SNOW MELTS TO FORM RAIN
+
+          IF (QNI3D(K).GE.1.E-8) THEN
+
+! HM, MODIFY FOR V3.2, ADD ACCELERATED MELTING DUE TO COLLISION WITH RAIN
+             DUM = -CPW/XLF(K)*T3D(K)*PRACS(K)
+
+             PSMLT(K)=2.*PI*N0S(K)*KAP(K)*(273.15-T3D(K))/       &
+                    XLF(K)*RHO(K)*(F1S/(LAMS(K)*LAMS(K))+        &
+                    F2S*(ASN(K)*RHO(K)/MU(K))**0.5*                      &
+                    SC(K)**(1./3.)*CONS10/                   &
+                   (LAMS(K)**CONS35))+DUM
+
+! IN WATER SUBSATURATION, SNOW MELTS AND EVAPORATES
+
+      IF (QVQVS(K).LT.1.) THEN
+        EPSS = 2.*PI*N0S(K)*RHO(K)*DV(K)*                            &
+                   (F1S/(LAMS(K)*LAMS(K))+                       &
+                    F2S*(ASN(K)*RHO(K)/MU(K))**0.5*                      &
+                    SC(K)**(1./3.)*CONS10/                   &
+               (LAMS(K)**CONS35))
+! hm fix 8/4/08
+        EVPMS(K) = (QV3D(K)-QVS(K))*EPSS/AB(K)    
+        EVPMS(K) = MAX(EVPMS(K),PSMLT(K))
+        PSMLT(K) = PSMLT(K)-EVPMS(K)
+      END IF
+      END IF
+
+!.......................................................................
+! MELTING OF GRAUPEL
+
+! GRAUPEL MAY PERSITS ABOVE FREEZING, FORMULA FROM RUTLEDGE AND HOBBS, 1984
+! IF WATER SUPERSATURATION, GRAUPEL MELTS TO FORM RAIN
+
+          IF (QG3D(K).GE.1.E-8) THEN
+
+! HM, MODIFY FOR V3.2, ADD ACCELERATED MELTING DUE TO COLLISION WITH RAIN
+             DUM = -CPW/XLF(K)*T3D(K)*PRACG(K)
+
+             PGMLT(K)=2.*PI*N0G(K)*KAP(K)*(273.15-T3D(K))/ 		 &
+                    XLF(K)*RHO(K)*(F1S/(LAMG(K)*LAMG(K))+                &
+                    F2S*(AGN(K)*RHO(K)/MU(K))**0.5*                      &
+                    SC(K)**(1./3.)*CONS11/                   &
+                   (LAMG(K)**CONS36))+DUM
+
+! IN WATER SUBSATURATION, GRAUPEL MELTS AND EVAPORATES
+
+      IF (QVQVS(K).LT.1.) THEN
+        EPSG = 2.*PI*N0G(K)*RHO(K)*DV(K)*                                &
+                   (F1S/(LAMG(K)*LAMG(K))+                               &
+                    F2S*(AGN(K)*RHO(K)/MU(K))**0.5*                      &
+                    SC(K)**(1./3.)*CONS11/                   &
+               (LAMG(K)**CONS36))
+! hm fix 8/4/08
+        EVPMG(K) = (QV3D(K)-QVS(K))*EPSG/AB(K)
+        EVPMG(K) = MAX(EVPMG(K),PGMLT(K))
+        PGMLT(K) = PGMLT(K)-EVPMG(K)
+      END IF
+      END IF
+
+! HM, V3.2
+! RESET PRACG AND PRACS TO ZERO, THIS IS DONE BECAUSE THERE IS NO
+! TRANSFER OF MASS FROM SNOW AND GRAUPEL TO RAIN DIRECTLY FROM COLLECTION
+! ABOVE FREEZING, IT IS ONLY USED FOR ENHANCEMENT OF MELTING AND SHEDDING
+
+      PRACG(K) = 0.
+      PRACS(K) = 0.
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+! FOR CLOUD ICE, ONLY PROCESSES OPERATING AT T > 273.15 IS
+! MELTING, WHICH IS ALREADY CONSERVED DURING PROCESS
+! CALCULATION
+
+! CONSERVATION OF QC
+
+      DUM = (PRC(K)+PRA(K))*DT
+
+      IF (DUM.GT.QC3D(K).AND.QC3D(K).GE.QSMALL) THEN
+
+        RATIO = QC3D(K)/DUM
+
+        PRC(K) = PRC(K)*RATIO
+        PRA(K) = PRA(K)*RATIO
+
+        END IF
+
+! CONSERVATION OF SNOW
+
+        DUM = (-PSMLT(K)-EVPMS(K)+PRACS(K))*DT
+
+        IF (DUM.GT.QNI3D(K).AND.QNI3D(K).GE.QSMALL) THEN
+
+! NO SOURCE TERMS FOR SNOW AT T > FREEZING
+        RATIO = QNI3D(K)/DUM
+
+        PSMLT(K) = PSMLT(K)*RATIO
+        EVPMS(K) = EVPMS(K)*RATIO
+        PRACS(K) = PRACS(K)*RATIO
+
+        END IF
+
+! CONSERVATION OF GRAUPEL
+
+        DUM = (-PGMLT(K)-EVPMG(K)+PRACG(K))*DT
+
+        IF (DUM.GT.QG3D(K).AND.QG3D(K).GE.QSMALL) THEN
+
+! NO SOURCE TERM FOR GRAUPEL ABOVE FREEZING
+        RATIO = QG3D(K)/DUM
+
+        PGMLT(K) = PGMLT(K)*RATIO
+        EVPMG(K) = EVPMG(K)*RATIO
+        PRACG(K) = PRACG(K)*RATIO
+
+        END IF
+
+! CONSERVATION OF QR
+! HM 12/13/06, ADDED CONSERVATION OF RAIN SINCE PRE IS NEGATIVE
+
+        DUM = (-PRACS(K)-PRACG(K)-PRE(K)-PRA(K)-PRC(K)+PSMLT(K)+PGMLT(K))*DT
+
+        IF (DUM.GT.QR3D(K).AND.QR3D(K).GE.QSMALL) THEN
+
+        RATIO = (QR3D(K)/DT+PRACS(K)+PRACG(K)+PRA(K)+PRC(K)-PSMLT(K)-PGMLT(K))/ &
+                        (-PRE(K))
+        PRE(K) = PRE(K)*RATIO
+        
+        END IF
+
+!....................................
+
+      QV3DTEN(K) = QV3DTEN(K)+(-PRE(K)-EVPMS(K)-EVPMG(K))
+
+      T3DTEN(K) = T3DTEN(K)+(PRE(K)*XXLV(K)+(EVPMS(K)+EVPMG(K))*XXLS(K)+&
+                    (PSMLT(K)+PGMLT(K)-PRACS(K)-PRACG(K))*XLF(K))/CPM(K)
+
+      QC3DTEN(K) = QC3DTEN(K)+(-PRA(K)-PRC(K))
+      QR3DTEN(K) = QR3DTEN(K)+(PRE(K)+PRA(K)+PRC(K)-PSMLT(K)-PGMLT(K)+PRACS(K)+PRACG(K))
+      QNI3DTEN(K) = QNI3DTEN(K)+(PSMLT(K)+EVPMS(K)-PRACS(K))
+      QG3DTEN(K) = QG3DTEN(K)+(PGMLT(K)+EVPMG(K)-PRACG(K))
+      NS3DTEN(K) = NS3DTEN(K)-NPRACS(K)
+! HM, bug fix 5/12/08, npracg is subtracted from nr not ng
+!      NG3DTEN(K) = NG3DTEN(K)
+      NC3DTEN(K) = NC3DTEN(K)+ (-NPRA(K)-NPRC(K))
+      NR3DTEN(K) = NR3DTEN(K)+ (NPRC1(K)+NRAGG(K)-NPRACG(K))
+
+! HM ADD, WRF-CHEM, ADD TENDENCIES FOR C2PREC
+
+	C2PREC(K) = PRA(K)+PRC(K)
+      IF (PRE(K).LT.0.) THEN
+         DUM = PRE(K)*DT/QR3D(K)
+           DUM = MAX(-1.,DUM)
+         NSUBR(K) = DUM*NR3D(K)/DT
+      END IF
+
+        IF (EVPMS(K)+PSMLT(K).LT.0.) THEN
+         DUM = (EVPMS(K)+PSMLT(K))*DT/QNI3D(K)
+           DUM = MAX(-1.,DUM)
+         NSMLTS(K) = DUM*NS3D(K)/DT
+        END IF
+        IF (PSMLT(K).LT.0.) THEN
+          DUM = PSMLT(K)*DT/QNI3D(K)
+          DUM = MAX(-1.0,DUM)
+          NSMLTR(K) = DUM*NS3D(K)/DT
+        END IF
+        IF (EVPMG(K)+PGMLT(K).LT.0.) THEN
+         DUM = (EVPMG(K)+PGMLT(K))*DT/QG3D(K)
+           DUM = MAX(-1.,DUM)
+         NGMLTG(K) = DUM*NG3D(K)/DT
+        END IF
+        IF (PGMLT(K).LT.0.) THEN
+          DUM = PGMLT(K)*DT/QG3D(K)
+          DUM = MAX(-1.0,DUM)
+          NGMLTR(K) = DUM*NG3D(K)/DT
+        END IF
+
+         NS3DTEN(K) = NS3DTEN(K)+(NSMLTS(K))
+         NG3DTEN(K) = NG3DTEN(K)+(NGMLTG(K))
+         NR3DTEN(K) = NR3DTEN(K)+(NSUBR(K)-NSMLTR(K)-NGMLTR(K))
+
+ 300  CONTINUE
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! NOW CALCULATE SATURATION ADJUSTMENT TO CONDENSE EXTRA VAPOR ABOVE
+! WATER SATURATION
+
+      DUMT = T3D(K)+DT*T3DTEN(K)
+      DUMQV = QV3D(K)+DT*QV3DTEN(K)
+! hm, add fix for low pressure, 5/12/10
+      dum=min(0.99*pres(k),POLYSVP(DUMT,0))
+      DUMQSS = EP_2*dum/(PRES(K)-dum)
+      DUMQC = QC3D(K)+DT*QC3DTEN(K)
+      DUMQC = MAX(DUMQC,0.)
+
+! SATURATION ADJUSTMENT FOR LIQUID
+
+      DUMS = DUMQV-DUMQSS
+      PCC(K) = DUMS/(1.+XXLV(K)**2*DUMQSS/(CPM(K)*RV*DUMT**2))/DT
+      IF (PCC(K)*DT+DUMQC.LT.0.) THEN
+           PCC(K) = -DUMQC/DT
+      END IF
+
+      QV3DTEN(K) = QV3DTEN(K)-PCC(K)
+      T3DTEN(K) = T3DTEN(K)+PCC(K)*XXLV(K)/CPM(K)
+      QC3DTEN(K) = QC3DTEN(K)+PCC(K)
+
+!.......................................................................
+! ACTIVATION OF CLOUD DROPLETS
+! ACTIVATION OF DROPLET CURRENTLY NOT CALCULATED
+! DROPLET CONCENTRATION IS SPECIFIED !!!!!
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! SUBLIMATE, MELT, OR EVAPORATE NUMBER CONCENTRATION
+! THIS FORMULATION ASSUMES 1:1 RATIO BETWEEN MASS LOSS AND
+! LOSS OF NUMBER CONCENTRATION
+
+!     IF (PCC(K).LT.0.) THEN
+!        DUM = PCC(K)*DT/QC3D(K)
+!           DUM = MAX(-1.,DUM)
+!        NSUBC(K) = DUM*NC3D(K)/DT
+!     END IF
+
+! UPDATE TENDENCIES
+
+!        NC3DTEN(K) = NC3DTEN(K)+NSUBC(K)
+
+!.....................................................................
+!.....................................................................
+         ELSE  ! TEMPERATURE < 273.15
+
+!......................................................................
+!HM ADD, ALLOW FOR CONSTANT DROPLET NUMBER
+! INUM = 0, PREDICT DROPLET NUMBER
+! INUM = 1, SET CONSTANT DROPLET NUMBER
+
+         IF (iinum.EQ.1) THEN
+! CONVERT NDCNST FROM CM-3 TO KG-1
+            NC3D(K)=NDCNST*1.E6/RHO(K)
+         END IF
+
+! CALCULATE SIZE DISTRIBUTION PARAMETERS
+! MAKE SURE NUMBER CONCENTRATIONS AREN'T NEGATIVE
+
+      NI3D(K) = MAX(0.,NI3D(K))
+      NS3D(K) = MAX(0.,NS3D(K))
+      NC3D(K) = MAX(0.,NC3D(K))
+      NR3D(K) = MAX(0.,NR3D(K))
+      NG3D(K) = MAX(0.,NG3D(K))
+
+!......................................................................
+! CLOUD ICE
+
+      IF (QI3D(K).GE.QSMALL) THEN
+         LAMI(K) = (CONS12*                 &
+              NI3D(K)/QI3D(K))**(1./DI)
+         N0I(K) = NI3D(K)*LAMI(K)
+
+! CHECK FOR SLOPE
+
+! ADJUST VARS
+
+      IF (LAMI(K).LT.LAMMINI) THEN
+
+      LAMI(K) = LAMMINI
+
+      N0I(K) = LAMI(K)**4*QI3D(K)/CONS12
+
+      NI3D(K) = N0I(K)/LAMI(K)
+      ELSE IF (LAMI(K).GT.LAMMAXI) THEN
+      LAMI(K) = LAMMAXI
+      N0I(K) = LAMI(K)**4*QI3D(K)/CONS12
+
+      NI3D(K) = N0I(K)/LAMI(K)
+      END IF
+      END IF
+
+!......................................................................
+! RAIN
+
+      IF (QR3D(K).GE.QSMALL) THEN
+      LAMR(K) = (PI*RHOW*NR3D(K)/QR3D(K))**(1./3.)
+      N0RR(K) = NR3D(K)*LAMR(K)
+
+! CHECK FOR SLOPE
+
+! ADJUST VARS
+
+      IF (LAMR(K).LT.LAMMINR) THEN
+
+      LAMR(K) = LAMMINR
+
+      N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW)
+
+      NR3D(K) = N0RR(K)/LAMR(K)
+      ELSE IF (LAMR(K).GT.LAMMAXR) THEN
+      LAMR(K) = LAMMAXR
+      N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW)
+
+      NR3D(K) = N0RR(K)/LAMR(K)
+      END IF
+      END IF
+
+!......................................................................
+! CLOUD DROPLETS
+
+! MARTIN ET AL. (1994) FORMULA FOR PGAM
+
+      IF (QC3D(K).GE.QSMALL) THEN
+
+         DUM = PRES(K)/(287.15*T3D(K))
+         PGAM(K)=0.0005714*(NC3D(K)/1.E6*DUM)+0.2714
+         PGAM(K)=1./(PGAM(K)**2)-1.
+         PGAM(K)=MAX(PGAM(K),2.)
+         PGAM(K)=MIN(PGAM(K),10.)
+
+! CALCULATE LAMC
+
+      LAMC(K) = (CONS26*NC3D(K)*GAMMA(PGAM(K)+4.)/   &
+                 (QC3D(K)*GAMMA(PGAM(K)+1.)))**(1./3.)
+
+! LAMMIN, 60 MICRON DIAMETER
+! LAMMAX, 1 MICRON
+
+      LAMMIN = (PGAM(K)+1.)/60.E-6
+      LAMMAX = (PGAM(K)+1.)/1.E-6
+
+      IF (LAMC(K).LT.LAMMIN) THEN
+      LAMC(K) = LAMMIN
+
+      NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+              &
+                LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26
+      ELSE IF (LAMC(K).GT.LAMMAX) THEN
+      LAMC(K) = LAMMAX
+      NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+              &
+                LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26
+
+      END IF
+
+! TO CALCULATE DROPLET FREEZING
+
+        CDIST1(K) = NC3D(K)/GAMMA(PGAM(K)+1.)
+
+      END IF
+
+!......................................................................
+! SNOW
+
+      IF (QNI3D(K).GE.QSMALL) THEN
+      LAMS(K) = (CONS1*NS3D(K)/QNI3D(K))**(1./DS)
+      N0S(K) = NS3D(K)*LAMS(K)
+
+! CHECK FOR SLOPE
+
+! ADJUST VARS
+
+      IF (LAMS(K).LT.LAMMINS) THEN
+      LAMS(K) = LAMMINS
+      N0S(K) = LAMS(K)**4*QNI3D(K)/CONS1
+
+      NS3D(K) = N0S(K)/LAMS(K)
+
+      ELSE IF (LAMS(K).GT.LAMMAXS) THEN
+
+      LAMS(K) = LAMMAXS
+      N0S(K) = LAMS(K)**4*QNI3D(K)/CONS1
+
+      NS3D(K) = N0S(K)/LAMS(K)
+      END IF
+      END IF
+
+!......................................................................
+! GRAUPEL
+
+      IF (QG3D(K).GE.QSMALL) THEN
+      LAMG(K) = (CONS2*NG3D(K)/QG3D(K))**(1./DG)
+      N0G(K) = NG3D(K)*LAMG(K)
+
+! CHECK FOR SLOPE
+
+! ADJUST VARS
+
+      IF (LAMG(K).LT.LAMMING) THEN
+      LAMG(K) = LAMMING
+      N0G(K) = LAMG(K)**4*QG3D(K)/CONS2
+
+      NG3D(K) = N0G(K)/LAMG(K)
+
+      ELSE IF (LAMG(K).GT.LAMMAXG) THEN
+
+      LAMG(K) = LAMMAXG
+      N0G(K) = LAMG(K)**4*QG3D(K)/CONS2
+
+      NG3D(K) = N0G(K)/LAMG(K)
+      END IF
+      END IF
+
+!.....................................................................
+! ZERO OUT PROCESS RATES
+
+            MNUCCC(K) = 0.
+            NNUCCC(K) = 0.
+            PRC(K) = 0.
+            NPRC(K) = 0.
+            NPRC1(K) = 0.
+            NSAGG(K) = 0.
+            PSACWS(K) = 0.
+            NPSACWS(K) = 0.
+            PSACWI(K) = 0.
+            NPSACWI(K) = 0.
+            PRACS(K) = 0.
+            NPRACS(K) = 0.
+            NMULTS(K) = 0.
+            QMULTS(K) = 0.
+            NMULTR(K) = 0.
+            QMULTR(K) = 0.
+            NMULTG(K) = 0.
+            QMULTG(K) = 0.
+            NMULTRG(K) = 0.
+            QMULTRG(K) = 0.
+            MNUCCR(K) = 0.
+            NNUCCR(K) = 0.
+            PRA(K) = 0.
+            NPRA(K) = 0.
+            NRAGG(K) = 0.
+            PRCI(K) = 0.
+            NPRCI(K) = 0.
+            PRAI(K) = 0.
+            NPRAI(K) = 0.
+            NNUCCD(K) = 0.
+            MNUCCD(K) = 0.
+            PCC(K) = 0.
+            PRE(K) = 0.
+            PRD(K) = 0.
+            PRDS(K) = 0.
+            EPRD(K) = 0.
+            EPRDS(K) = 0.
+            NSUBC(K) = 0.
+            NSUBI(K) = 0.
+            NSUBS(K) = 0.
+            NSUBR(K) = 0.
+            PIACR(K) = 0.
+            NIACR(K) = 0.
+            PRACI(K) = 0.
+            PIACRS(K) = 0.
+            NIACRS(K) = 0.
+            PRACIS(K) = 0.
+! HM: ADD GRAUPEL PROCESSES
+            PRACG(K) = 0.
+            PSACR(K) = 0.
+	    PSACWG(K) = 0.
+	    PGSACW(K) = 0.
+            PGRACS(K) = 0.
+	    PRDG(K) = 0.
+	    EPRDG(K) = 0.
+	    NPRACG(K) = 0.
+	    NPSACWG(K) = 0.
+	    NSCNG(K) = 0.
+ 	    NGRACS(K) = 0.
+	    NSUBG(K) = 0.
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! CALCULATION OF MICROPHYSICAL PROCESS RATES
+! ACCRETION/AUTOCONVERSION/FREEZING/MELTING/COAG.
+!.......................................................................
+! FREEZING OF CLOUD DROPLETS
+! ONLY ALLOWED BELOW -4 C
+        IF (QC3D(K).GE.QSMALL .AND. T3D(K).LT.269.15) THEN
+
+! NUMBER OF CONTACT NUCLEI (M^-3) FROM MEYERS ET AL., 1992
+! FACTOR OF 1000 IS TO CONVERT FROM L^-1 TO M^-3
+
+! MEYERS CURVE
+
+           NACNT = EXP(-2.80+0.262*(273.15-T3D(K)))*1000.
+
+! COOPER CURVE
+!        NACNT =  5.*EXP(0.304*(273.15-T3D(K)))
+
+! FLECTHER
+!     NACNT = 0.01*EXP(0.6*(273.15-T3D(K)))
+
+! CONTACT FREEZING
+
+! MEAN FREE PATH
+
+            DUM = 7.37*T3D(K)/(288.*10.*PRES(K))/100.
+
+! EFFECTIVE DIFFUSIVITY OF CONTACT NUCLEI
+! BASED ON BROWNIAN DIFFUSION
+
+            DAP(K) = CONS37*T3D(K)*(1.+DUM/RIN)/MU(K)
+ 
+           MNUCCC(K) = CONS38*DAP(K)*NACNT*EXP(LOG(CDIST1(K))+   &
+                   LOG(GAMMA(PGAM(K)+5.))-4.*LOG(LAMC(K)))
+           NNUCCC(K) = 2.*PI*DAP(K)*NACNT*CDIST1(K)*           &
+                    GAMMA(PGAM(K)+2.)/                         &
+                    LAMC(K)
+
+! IMMERSION FREEZING (BIGG 1953)
+
+           MNUCCC(K) = MNUCCC(K)+CONS39*                   &
+                  EXP(LOG(CDIST1(K))+LOG(GAMMA(7.+PGAM(K)))-6.*LOG(LAMC(K)))*             &
+                   EXP(AIMM*(273.15-T3D(K)))
+
+           NNUCCC(K) = NNUCCC(K)+                                  &
+            CONS40*EXP(LOG(CDIST1(K))+LOG(GAMMA(PGAM(K)+4.))-3.*LOG(LAMC(K)))              &
+                *EXP(AIMM*(273.15-T3D(K)))
+
+! PUT IN A CATCH HERE TO PREVENT DIVERGENCE BETWEEN NUMBER CONC. AND
+! MIXING RATIO, SINCE STRICT CONSERVATION NOT CHECKED FOR NUMBER CONC
+
+           NNUCCC(K) = MIN(NNUCCC(K),NC3D(K)/DT)
+
+        END IF
+
+!.................................................................
+!.......................................................................
+! AUTOCONVERSION OF CLOUD LIQUID WATER TO RAIN
+! FORMULA FROM BEHENG (1994)
+! USING NUMERICAL SIMULATION OF STOCHASTIC COLLECTION EQUATION
+! AND INITIAL CLOUD DROPLET SIZE DISTRIBUTION SPECIFIED
+! AS A GAMMA DISTRIBUTION
+
+! USE MINIMUM VALUE OF 1.E-6 TO PREVENT FLOATING POINT ERROR
+
+         IF (QC3D(K).GE.1.E-6) THEN
+
+! HM ADD 12/13/06, REPLACE WITH NEWER FORMULA
+! FROM KHAIROUTDINOV AND KOGAN 2000, MWR
+
+                PRC(K)=1350.*QC3D(K)**2.47*  &
+           (NC3D(K)/1.e6*RHO(K))**(-1.79)
+
+! note: nprc1 is change in Nr,
+! nprc is change in Nc
+
+        NPRC1(K) = PRC(K)/CONS29
+        NPRC(K) = PRC(K)/(QC3D(K)/NC3D(K))
+
+                NPRC(K) = MIN(NPRC(K),NC3D(K)/DT)
+
+         END IF
+
+!.......................................................................
+! SELF-COLLECTION OF DROPLET NOT INCLUDED IN KK2000 SCHEME
+
+! SNOW AGGREGATION FROM PASSARELLI, 1978, USED BY REISNER, 1998
+! THIS IS HARD-WIRED FOR BS = 0.4 FOR NOW
+
+         IF (QNI3D(K).GE.1.E-8) THEN
+             NSAGG(K) = CONS15*ASN(K)*RHO(K)**            &
+            ((2.+BS)/3.)*QNI3D(K)**((2.+BS)/3.)*                  &
+            (NS3D(K)*RHO(K))**((4.-BS)/3.)/                       &
+            (RHO(K))
+         END IF
+
+!.......................................................................
+! ACCRETION OF CLOUD DROPLETS ONTO SNOW/GRAUPEL
+! HERE USE CONTINUOUS COLLECTION EQUATION WITH
+! SIMPLE GRAVITATIONAL COLLECTION KERNEL IGNORING
+
+! SNOW
+
+         IF (QNI3D(K).GE.1.E-8 .AND. QC3D(K).GE.QSMALL) THEN
+
+           PSACWS(K) = CONS13*ASN(K)*QC3D(K)*RHO(K)*               &
+                  N0S(K)/                        &
+                  LAMS(K)**(BS+3.)
+           NPSACWS(K) = CONS13*ASN(K)*NC3D(K)*RHO(K)*              &
+                  N0S(K)/                        &
+                  LAMS(K)**(BS+3.)
+
+         END IF
+
+!............................................................................
+! COLLECTION OF CLOUD WATER BY GRAUPEL
+
+         IF (QG3D(K).GE.1.E-8 .AND. QC3D(K).GE.QSMALL) THEN
+
+           PSACWG(K) = CONS14*AGN(K)*QC3D(K)*RHO(K)*               &
+                  N0G(K)/                        &
+                  LAMG(K)**(BG+3.)
+           NPSACWG(K) = CONS14*AGN(K)*NC3D(K)*RHO(K)*              &
+                  N0G(K)/                        &
+                  LAMG(K)**(BG+3.)
+	    END IF
+
+!.......................................................................
+! HM, ADD 12/13/06
+! CLOUD ICE COLLECTING DROPLETS, ASSUME THAT CLOUD ICE MEAN DIAM > 100 MICRON
+! BEFORE RIMING CAN OCCUR
+! ASSUME THAT RIME COLLECTED ON CLOUD ICE DOES NOT LEAD
+! TO HALLET-MOSSOP SPLINTERING
+
+         IF (QI3D(K).GE.1.E-8 .AND. QC3D(K).GE.QSMALL) THEN
+
+! PUT IN SIZE DEPENDENT COLLECTION EFFICIENCY BASED ON STOKES LAW
+! FROM THOMPSON ET AL. 2004, MWR
+
+            IF (1./LAMI(K).GE.100.E-6) THEN
+
+           PSACWI(K) = CONS16*AIN(K)*QC3D(K)*RHO(K)*               &
+                  N0I(K)/                        &
+                  LAMI(K)**(BI+3.)
+           NPSACWI(K) = CONS16*AIN(K)*NC3D(K)*RHO(K)*              &
+                  N0I(K)/                        &
+                  LAMI(K)**(BI+3.)
+           END IF
+         END IF
+
+!.......................................................................
+! ACCRETION OF RAIN WATER BY SNOW
+! FORMULA FROM IKAWA AND SAITO, 1991, USED BY REISNER ET AL, 1998
+
+         IF (QR3D(K).GE.1.E-8.AND.QNI3D(K).GE.1.E-8) THEN
+
+            UMS = ASN(K)*CONS3/(LAMS(K)**BS)
+            UMR = ARN(K)*CONS4/(LAMR(K)**BR)
+            UNS = ASN(K)*CONS5/LAMS(K)**BS
+            UNR = ARN(K)*CONS6/LAMR(K)**BR
+
+! SET REASLISTIC LIMITS ON FALLSPEEDS
+
+! bug fix, 10/08/09
+            dum=(rhosu/rho(k))**0.54
+            UMS=MIN(UMS,1.2*dum)
+            UNS=MIN(UNS,1.2*dum)
+            UMR=MIN(UMR,9.1*dum)
+            UNR=MIN(UNR,9.1*dum)
+
+            PRACS(K) = CONS41*(((1.2*UMR-0.95*UMS)**2+                   &
+                  0.08*UMS*UMR)**0.5*RHO(K)*                      &
+                  N0RR(K)*N0S(K)/LAMR(K)**3*                              &
+                  (5./(LAMR(K)**3*LAMS(K))+                    &
+                  2./(LAMR(K)**2*LAMS(K)**2)+                  &				 
+                  0.5/(LAMR(k)*LAMS(k)**3)))
+
+            NPRACS(K) = CONS32*RHO(K)*(1.7*(UNR-UNS)**2+            &
+                0.3*UNR*UNS)**0.5*N0RR(K)*N0S(K)*              &
+                (1./(LAMR(K)**3*LAMS(K))+                      &
+                 1./(LAMR(K)**2*LAMS(K)**2)+                   &
+                 1./(LAMR(K)*LAMS(K)**3))
+
+! MAKE SURE PRACS DOESN'T EXCEED TOTAL RAIN MIXING RATIO
+! AS THIS MAY OTHERWISE RESULT IN TOO MUCH TRANSFER OF WATER DURING
+! RIME-SPLINTERING
+
+            PRACS(K) = MIN(PRACS(K),QR3D(K)/DT)
+
+! COLLECTION OF SNOW BY RAIN - NEEDED FOR GRAUPEL CONVERSION CALCULATIONS
+! ONLY CALCULATE IF SNOW AND RAIN MIXING RATIOS EXCEED 0.1 G/KG
+
+! ASSUME COLLECTION OF SNOW BY RAIN PRODUCES GRAUPEL NOT HAIL
+
+! HM MODIFY FOR WRFV3.1
+!            IF (IHAIL.EQ.0) THEN
+            IF (QNI3D(K).GE.0.1E-3.AND.QR3D(K).GE.0.1E-3) THEN
+            PSACR(K) = CONS31*(((1.2*UMR-0.95*UMS)**2+              &
+                  0.08*UMS*UMR)**0.5*RHO(K)*                     &
+                 N0RR(K)*N0S(K)/LAMS(K)**3*                               &
+                  (5./(LAMS(K)**3*LAMR(K))+                    &
+                  2./(LAMS(K)**2*LAMR(K)**2)+                  &
+                  0.5/(LAMS(K)*LAMR(K)**3)))            
+            END IF
+!            END IF
+
+         END IF
+
+!.......................................................................
+
+! COLLECTION OF RAINWATER BY GRAUPEL, FROM IKAWA AND SAITO 1990, 
+! USED BY REISNER ET AL 1998
+         IF (QR3D(K).GE.1.E-8.AND.QG3D(K).GE.1.E-8) THEN
+
+            UMG = AGN(K)*CONS7/(LAMG(K)**BG)
+            UMR = ARN(K)*CONS4/(LAMR(K)**BR)
+            UNG = AGN(K)*CONS8/LAMG(K)**BG
+            UNR = ARN(K)*CONS6/LAMR(K)**BR
+
+! SET REASLISTIC LIMITS ON FALLSPEEDS
+! bug fix, 10/08/09
+            dum=(rhosu/rho(k))**0.54
+            UMG=MIN(UMG,20.*dum)
+            UNG=MIN(UNG,20.*dum)
+            UMR=MIN(UMR,9.1*dum)
+            UNR=MIN(UNR,9.1*dum)
+
+            PRACG(K) = CONS41*(((1.2*UMR-0.95*UMG)**2+                   &
+                  0.08*UMG*UMR)**0.5*RHO(K)*                      &
+                  N0RR(K)*N0G(K)/LAMR(K)**3*                              &
+                  (5./(LAMR(K)**3*LAMG(K))+                    &
+                  2./(LAMR(K)**2*LAMG(K)**2)+				   &
+				  0.5/(LAMR(k)*LAMG(k)**3)))
+
+            NPRACG(K) = CONS32*RHO(K)*(1.7*(UNR-UNG)**2+            &
+                0.3*UNR*UNG)**0.5*N0RR(K)*N0G(K)*              &
+                (1./(LAMR(K)**3*LAMG(K))+                      &
+                 1./(LAMR(K)**2*LAMG(K)**2)+                   &
+                 1./(LAMR(K)*LAMG(K)**3))
+
+! MAKE SURE PRACG DOESN'T EXCEED TOTAL RAIN MIXING RATIO
+! AS THIS MAY OTHERWISE RESULT IN TOO MUCH TRANSFER OF WATER DURING
+! RIME-SPLINTERING
+
+            PRACG(K) = MIN(PRACG(K),QR3D(K)/DT)
+
+	    END IF
+
+!.......................................................................
+! RIME-SPLINTERING - SNOW
+! HALLET-MOSSOP (1974)
+! NUMBER OF SPLINTERS FORMED IS BASED ON MASS OF RIMED WATER
+
+! DUM1 = MASS OF INDIVIDUAL SPLINTERS
+
+! HM ADD THRESHOLD SNOW AND DROPLET MIXING RATIO FOR RIME-SPLINTERING
+! TO LIMIT RIME-SPLINTERING IN STRATIFORM CLOUDS
+! THESE THRESHOLDS CORRESPOND WITH GRAUPEL THRESHOLDS IN RH 1984
+
+!v1.4
+         IF (QNI3D(K).GE.0.1E-3) THEN
+         IF (QC3D(K).GE.0.5E-3.OR.QR3D(K).GE.0.1E-3) THEN
+         IF (PSACWS(K).GT.0..OR.PRACS(K).GT.0.) THEN
+            IF (T3D(K).LT.270.16 .AND. T3D(K).GT.265.16) THEN
+
+               IF (T3D(K).GT.270.16) THEN
+                  FMULT = 0.
+               ELSE IF (T3D(K).LE.270.16.AND.T3D(K).GT.268.16)  THEN
+                  FMULT = (270.16-T3D(K))/2.
+               ELSE IF (T3D(K).GE.265.16.AND.T3D(K).LE.268.16)   THEN
+                  FMULT = (T3D(K)-265.16)/3.
+               ELSE IF (T3D(K).LT.265.16) THEN
+                  FMULT = 0.
+               END IF
+
+! 1000 IS TO CONVERT FROM KG TO G
+
+! SPLINTERING FROM DROPLETS ACCRETED ONTO SNOW
+
+               IF (PSACWS(K).GT.0.) THEN
+                  NMULTS(K) = 35.E4*PSACWS(K)*FMULT*1000.
+                  QMULTS(K) = NMULTS(K)*MMULT
+
+! CONSTRAIN SO THAT TRANSFER OF MASS FROM SNOW TO ICE CANNOT BE MORE MASS
+! THAN WAS RIMED ONTO SNOW
+
+                  QMULTS(K) = MIN(QMULTS(K),PSACWS(K))
+                  PSACWS(K) = PSACWS(K)-QMULTS(K)
+
+               END IF
+
+! RIMING AND SPLINTERING FROM ACCRETED RAINDROPS
+
+               IF (PRACS(K).GT.0.) THEN
+                   NMULTR(K) = 35.E4*PRACS(K)*FMULT*1000.
+                   QMULTR(K) = NMULTR(K)*MMULT
+
+! CONSTRAIN SO THAT TRANSFER OF MASS FROM SNOW TO ICE CANNOT BE MORE MASS
+! THAN WAS RIMED ONTO SNOW
+
+                   QMULTR(K) = MIN(QMULTR(K),PRACS(K))
+
+                   PRACS(K) = PRACS(K)-QMULTR(K)
+
+               END IF
+
+            END IF
+         END IF
+         END IF
+         END IF
+
+!.......................................................................
+! RIME-SPLINTERING - GRAUPEL 
+! HALLET-MOSSOP (1974)
+! NUMBER OF SPLINTERS FORMED IS BASED ON MASS OF RIMED WATER
+
+! DUM1 = MASS OF INDIVIDUAL SPLINTERS
+
+! HM ADD THRESHOLD SNOW MIXING RATIO FOR RIME-SPLINTERING
+! TO LIMIT RIME-SPLINTERING IN STRATIFORM CLOUDS
+
+! ONLY CALCULATE FOR GRAUPEL NOT HAIL
+!         IF (IHAIL.EQ.0) THEN
+! v1.4
+         IF (QG3D(K).GE.0.1E-3) THEN
+         IF (QC3D(K).GE.0.5E-3.OR.QR3D(K).GE.0.1E-3) THEN
+         IF (PSACWG(K).GT.0..OR.PRACG(K).GT.0.) THEN
+            IF (T3D(K).LT.270.16 .AND. T3D(K).GT.265.16) THEN
+
+               IF (T3D(K).GT.270.16) THEN
+                  FMULT = 0.
+               ELSE IF (T3D(K).LE.270.16.AND.T3D(K).GT.268.16)  THEN
+                  FMULT = (270.16-T3D(K))/2.
+               ELSE IF (T3D(K).GE.265.16.AND.T3D(K).LE.268.16)   THEN
+                  FMULT = (T3D(K)-265.16)/3.
+               ELSE IF (T3D(K).LT.265.16) THEN
+                  FMULT = 0.
+               END IF
+
+! 1000 IS TO CONVERT FROM KG TO G
+
+! SPLINTERING FROM DROPLETS ACCRETED ONTO GRAUPEL
+
+               IF (PSACWG(K).GT.0.) THEN
+                  NMULTG(K) = 35.E4*PSACWG(K)*FMULT*1000.
+                  QMULTG(K) = NMULTG(K)*MMULT
+
+! CONSTRAIN SO THAT TRANSFER OF MASS FROM GRAUPEL TO ICE CANNOT BE MORE MASS
+! THAN WAS RIMED ONTO GRAUPEL
+
+                  QMULTG(K) = MIN(QMULTG(K),PSACWG(K))
+                  PSACWG(K) = PSACWG(K)-QMULTG(K)
+
+               END IF
+
+! RIMING AND SPLINTERING FROM ACCRETED RAINDROPS
+
+               IF (PRACG(K).GT.0.) THEN
+                   NMULTRG(K) = 35.E4*PRACG(K)*FMULT*1000.
+                   QMULTRG(K) = NMULTRG(K)*MMULT
+
+! CONSTRAIN SO THAT TRANSFER OF MASS FROM GRAUPEL TO ICE CANNOT BE MORE MASS
+! THAN WAS RIMED ONTO GRAUPEL
+
+                   QMULTRG(K) = MIN(QMULTRG(K),PRACG(K))
+                   PRACG(K) = PRACG(K)-QMULTRG(K)
+
+               END IF
+               END IF
+               END IF
+            END IF
+            END IF
+!         END IF
+
+!........................................................................
+! CONVERSION OF RIMED CLOUD WATER ONTO SNOW TO GRAUPEL
+! ASSUME CONVERTED SNOW FORMS GRAUPEL NOT HAIL
+! HAIL ASSUMED TO ONLY FORM BY FREEZING OF RAIN
+! OR COLLISIONS OF RAIN WITH CLOUD ICE
+
+!           IF (IHAIL.EQ.0) THEN
+	   IF (PSACWS(K).GT.0.) THEN
+! ONLY ALLOW CONVERSION IF QNI > 0.1 AND QC > 0.5 G/KG FOLLOWING RUTLEDGE AND HOBBS (1984)
+              IF (QNI3D(K).GE.0.1E-3.AND.QC3D(K).GE.0.5E-3) THEN
+
+! PORTION OF RIMING CONVERTED TO GRAUPEL (REISNER ET AL. 1998, ORIGINALLY IS1991)
+	     PGSACW(K) = MIN(PSACWS(K),CONS17*DT*N0S(K)*QC3D(K)*QC3D(K)* &
+                          ASN(K)*ASN(K)/ &
+                           (RHO(K)*LAMS(K)**(2.*BS+2.))) 
+
+! MIX RAT CONVERTED INTO GRAUPEL AS EMBRYO (REISNER ET AL. 1998, ORIG M1990)
+	     DUM = MAX(RHOSN/(RHOG-RHOSN)*PGSACW(K),0.) 
+
+! NUMBER CONCENTRAITON OF EMBRYO GRAUPEL FROM RIMING OF SNOW
+	     NSCNG(K) = DUM/MG0*RHO(K)
+! LIMIT MAX NUMBER CONVERTED TO SNOW NUMBER
+             NSCNG(K) = MIN(NSCNG(K),NS3D(K)/DT)
+
+! PORTION OF RIMING LEFT FOR SNOW
+             PSACWS(K) = PSACWS(K) - PGSACW(K)
+             END IF
+	   END IF
+
+! CONVERSION OF RIMED RAINWATER ONTO SNOW CONVERTED TO GRAUPEL
+
+	   IF (PRACS(K).GT.0.) THEN
+! ONLY ALLOW CONVERSION IF QNI > 0.1 AND QR > 0.1 G/KG FOLLOWING RUTLEDGE AND HOBBS (1984)
+              IF (QNI3D(K).GE.0.1E-3.AND.QR3D(K).GE.0.1E-3) THEN
+! PORTION OF COLLECTED RAINWATER CONVERTED TO GRAUPEL (REISNER ET AL. 1998)
+	      DUM = CONS18*(4./LAMS(K))**3*(4./LAMS(K))**3 &    
+                   /(CONS18*(4./LAMS(K))**3*(4./LAMS(K))**3+ &  
+                   CONS19*(4./LAMR(K))**3*(4./LAMR(K))**3)
+              DUM=MIN(DUM,1.)
+              DUM=MAX(DUM,0.)
+	      PGRACS(K) = (1.-DUM)*PRACS(K)
+            NGRACS(K) = (1.-DUM)*NPRACS(K)
+! LIMIT MAX NUMBER CONVERTED TO MIN OF EITHER RAIN OR SNOW NUMBER CONCENTRATION
+            NGRACS(K) = MIN(NGRACS(K),NR3D(K)/DT)
+            NGRACS(K) = MIN(NGRACS(K),NS3D(K)/DT)
+
+! AMOUNT LEFT FOR SNOW PRODUCTION
+            PRACS(K) = PRACS(K) - PGRACS(K)
+            NPRACS(K) = NPRACS(K) - NGRACS(K)
+! CONVERSION TO GRAUPEL DUE TO COLLECTION OF SNOW BY RAIN
+            PSACR(K)=PSACR(K)*(1.-DUM)
+            END IF
+	   END IF
+!           END IF
+
+!.......................................................................
+! FREEZING OF RAIN DROPS
+! FREEZING ALLOWED BELOW -4 C
+
+         IF (T3D(K).LT.269.15.AND.QR3D(K).GE.QSMALL) THEN
+
+! IMMERSION FREEZING (BIGG 1953)
+            MNUCCR(K) = CONS20*NR3D(K)*EXP(AIMM*(273.15-T3D(K)))/LAMR(K)**3 &
+                 /LAMR(K)**3
+
+            NNUCCR(K) = PI*NR3D(K)*BIMM*EXP(AIMM*(273.15-T3D(K)))/LAMR(K)**3
+
+! PREVENT DIVERGENCE BETWEEN MIXING RATIO AND NUMBER CONC
+            NNUCCR(K) = MIN(NNUCCR(K),NR3D(K)/DT)
+
+         END IF
+
+!.......................................................................
+! ACCRETION OF CLOUD LIQUID WATER BY RAIN
+! CONTINUOUS COLLECTION EQUATION WITH
+! GRAVITATIONAL COLLECTION KERNEL, DROPLET FALL SPEED NEGLECTED
+
+         IF (QR3D(K).GE.1.E-8 .AND. QC3D(K).GE.1.E-8) THEN
+
+! 12/13/06 HM ADD, REPLACE WITH NEWER FORMULA FROM
+! KHAIROUTDINOV AND KOGAN 2000, MWR
+
+           DUM=(QC3D(K)*QR3D(K))
+           PRA(K) = 67.*(DUM)**1.15
+           NPRA(K) = PRA(K)/(QC3D(K)/NC3D(K))
+
+         END IF
+!.......................................................................
+! SELF-COLLECTION OF RAIN DROPS
+! FROM BEHENG(1994)
+! FROM NUMERICAL SIMULATION OF THE STOCHASTIC COLLECTION EQUATION
+! AS DESCRINED ABOVE FOR AUTOCONVERSION
+
+         IF (QR3D(K).GE.1.E-8) THEN
+! include breakup add 10/09/09
+            dum1=300.e-6
+            if (1./lamr(k).lt.dum1) then
+            dum=1.
+            else if (1./lamr(k).ge.dum1) then
+            dum=2.-exp(2300.*(1./lamr(k)-dum1))
+            end if
+!            NRAGG(K) = -8.*NR3D(K)*QR3D(K)*RHO(K)
+            NRAGG(K) = -5.78*dum*NR3D(K)*QR3D(K)*RHO(K)
+         END IF
+
+!.......................................................................
+! AUTOCONVERSION OF CLOUD ICE TO SNOW
+! FOLLOWING HARRINGTON ET AL. (1995) WITH MODIFICATION
+! HERE IT IS ASSUMED THAT AUTOCONVERSION CAN ONLY OCCUR WHEN THE
+! ICE IS GROWING, I.E. IN CONDITIONS OF ICE SUPERSATURATION
+
+         IF (QI3D(K).GE.1.E-8 .AND.QVQVSI(K).GE.1.) THEN
+
+!           COFFI = 2./LAMI(K)
+!           IF (COFFI.GE.DCS) THEN
+              NPRCI(K) = CONS21*(QV3D(K)-QVI(K))*RHO(K)                         &
+                *N0I(K)*EXP(-LAMI(K)*DCS)*DV(K)/ABI(K)
+              PRCI(K) = CONS22*NPRCI(K)
+              NPRCI(K) = MIN(NPRCI(K),NI3D(K)/DT)
+
+!           END IF
+         END IF
+
+!.......................................................................
+! ACCRETION OF CLOUD ICE BY SNOW
+! FOR THIS CALCULATION, IT IS ASSUMED THAT THE VS >> VI
+! AND DS >> DI FOR CONTINUOUS COLLECTION
+
+         IF (QNI3D(K).GE.1.E-8 .AND. QI3D(K).GE.QSMALL) THEN
+            PRAI(K) = CONS23*ASN(K)*QI3D(K)*RHO(K)*N0S(K)/     &
+                     LAMS(K)**(BS+3.)
+            NPRAI(K) = CONS23*ASN(K)*NI3D(K)*                                       &
+                  RHO(K)*N0S(K)/                                 &
+                  LAMS(K)**(BS+3.)
+            NPRAI(K)=MIN(NPRAI(K),NI3D(K)/DT)
+         END IF
+
+!.......................................................................
+! HM, ADD 12/13/06, COLLISION OF RAIN AND ICE TO PRODUCE SNOW OR GRAUPEL
+! FOLLOWS REISNER ET AL. 1998
+! ASSUMED FALLSPEED AND SIZE OF ICE CRYSTAL << THAN FOR RAIN
+
+         IF (QR3D(K).GE.1.E-8.AND.QI3D(K).GE.1.E-8.AND.T3D(K).LE.273.15) THEN
+
+! ALLOW GRAUPEL FORMATION FROM RAIN-ICE COLLISIONS ONLY IF RAIN MIXING RATIO > 0.1 G/KG,
+! OTHERWISE ADD TO SNOW
+
+            IF (QR3D(K).GE.0.1E-3) THEN
+            NIACR(K)=CONS24*NI3D(K)*N0RR(K)*ARN(K) &
+                /LAMR(K)**(BR+3.)*RHO(K)
+            PIACR(K)=CONS25*NI3D(K)*N0RR(K)*ARN(K) &
+                /LAMR(K)**(BR+3.)/LAMR(K)**3*RHO(K)
+            PRACI(K)=CONS24*QI3D(K)*N0RR(K)*ARN(K)/ &
+                LAMR(K)**(BR+3.)*RHO(K)
+            NIACR(K)=MIN(NIACR(K),NR3D(K)/DT)
+            NIACR(K)=MIN(NIACR(K),NI3D(K)/DT)
+            ELSE 
+            NIACRS(K)=CONS24*NI3D(K)*N0RR(K)*ARN(K) &
+                /LAMR(K)**(BR+3.)*RHO(K)
+            PIACRS(K)=CONS25*NI3D(K)*N0RR(K)*ARN(K) &
+                /LAMR(K)**(BR+3.)/LAMR(K)**3*RHO(K)
+            PRACIS(K)=CONS24*QI3D(K)*N0RR(K)*ARN(K)/ &
+                LAMR(K)**(BR+3.)*RHO(K)
+            NIACRS(K)=MIN(NIACRS(K),NR3D(K)/DT)
+            NIACRS(K)=MIN(NIACRS(K),NI3D(K)/DT)
+            END IF
+         END IF
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! NUCLEATION OF CLOUD ICE FROM HOMOGENEOUS AND HETEROGENEOUS FREEZING ON AEROSOL
+
+         IF (INUC.EQ.0) THEN
+
+! add threshold according to Greg Thomspon
+
+         if ((QVQVS(K).GE.0.999.and.T3D(K).le.265.15).or. &
+              QVQVSI(K).ge.1.08) then
+
+! hm, modify dec. 5, 2006, replace with cooper curve
+      kc2 = 0.005*exp(0.304*(273.15-T3D(K)))*1000. ! convert from L-1 to m-3
+! limit to 500 L-1
+      kc2 = min(kc2,500.e3)
+      kc2=MAX(kc2/rho(k),0.)  ! convert to kg-1
+
+          IF (KC2.GT.NI3D(K)+NS3D(K)+NG3D(K)) THEN
+             NNUCCD(K) = (KC2-NI3D(K)-NS3D(K)-NG3D(K))/DT
+             MNUCCD(K) = NNUCCD(K)*MI0
+          END IF
+
+          END IF
+
+          ELSE IF (INUC.EQ.1) THEN
+
+          IF (T3D(K).LT.273.15.AND.QVQVSI(K).GT.1.) THEN
+
+             KC2 = 0.16*1000./RHO(K)  ! CONVERT FROM L-1 TO KG-1
+          IF (KC2.GT.NI3D(K)+NS3D(K)+NG3D(K)) THEN
+             NNUCCD(K) = (KC2-NI3D(K)-NS3D(K)-NG3D(K))/DT
+             MNUCCD(K) = NNUCCD(K)*MI0
+          END IF
+          END IF
+
+         END IF
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+ 101      CONTINUE
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! CALCULATE EVAP/SUB/DEP TERMS FOR QI,QNI,QR
+
+! NO VENTILATION FOR CLOUD ICE
+
+        IF (QI3D(K).GE.QSMALL) THEN
+
+         EPSI = 2.*PI*N0I(K)*RHO(K)*DV(K)/(LAMI(K)*LAMI(K))
+
+      ELSE
+         EPSI = 0.
+      END IF
+
+      IF (QNI3D(K).GE.QSMALL) THEN
+        EPSS = 2.*PI*N0S(K)*RHO(K)*DV(K)*                            &
+                   (F1S/(LAMS(K)*LAMS(K))+                       &
+                    F2S*(ASN(K)*RHO(K)/MU(K))**0.5*                      &
+                    SC(K)**(1./3.)*CONS10/                   &
+               (LAMS(K)**CONS35))
+      ELSE
+      EPSS = 0.
+      END IF
+
+      IF (QG3D(K).GE.QSMALL) THEN
+        EPSG = 2.*PI*N0G(K)*RHO(K)*DV(K)*                                &
+                   (F1S/(LAMG(K)*LAMG(K))+                               &
+                    F2S*(AGN(K)*RHO(K)/MU(K))**0.5*                      &
+                    SC(K)**(1./3.)*CONS11/                   &
+               (LAMG(K)**CONS36))
+
+
+      ELSE
+      EPSG = 0.
+      END IF
+
+      IF (QR3D(K).GE.QSMALL) THEN
+        EPSR = 2.*PI*N0RR(K)*RHO(K)*DV(K)*                           &
+                   (F1R/(LAMR(K)*LAMR(K))+                       &
+                    F2R*(ARN(K)*RHO(K)/MU(K))**0.5*                      &
+                    SC(K)**(1./3.)*CONS9/                   &
+                (LAMR(K)**CONS34))
+      ELSE
+      EPSR = 0.
+      END IF
+
+! ONLY INCLUDE REGION OF ICE SIZE DIST < DCS
+! DUM IS FRACTION OF D*N(D) < DCS
+
+! LOGIC BELOW FOLLOWS THAT OF HARRINGTON ET AL. 1995 (JAS)
+              IF (QI3D(K).GE.QSMALL) THEN              
+              DUM=(1.-EXP(-LAMI(K)*DCS)*(1.+LAMI(K)*DCS))
+              PRD(K) = EPSI*(QV3D(K)-QVI(K))/ABI(K)*DUM
+              ELSE
+              DUM=0.
+              END IF
+! ADD DEPOSITION IN TAIL OF ICE SIZE DIST TO SNOW IF SNOW IS PRESENT
+              IF (QNI3D(K).GE.QSMALL) THEN
+              PRDS(K) = EPSS*(QV3D(K)-QVI(K))/ABI(K)+ &
+                EPSI*(QV3D(K)-QVI(K))/ABI(K)*(1.-DUM)
+! OTHERWISE ADD TO CLOUD ICE
+              ELSE
+              PRD(K) = PRD(K)+EPSI*(QV3D(K)-QVI(K))/ABI(K)*(1.-DUM)
+              END IF
+! VAPOR DPEOSITION ON GRAUPEL
+              PRDG(K) = EPSG*(QV3D(K)-QVI(K))/ABI(K)
+
+! NO CONDENSATION ONTO RAIN, ONLY EVAP
+
+           IF (QV3D(K).LT.QVS(K)) THEN
+              PRE(K) = EPSR*(QV3D(K)-QVS(K))/AB(K)
+              PRE(K) = MIN(PRE(K),0.)
+           ELSE
+              PRE(K) = 0.
+           END IF
+
+! MAKE SURE NOT PUSHED INTO ICE SUPERSAT/SUBSAT
+! FORMULA FROM REISNER 2 SCHEME
+
+           DUM = (QV3D(K)-QVI(K))/DT
+
+           FUDGEF = 0.9999
+           SUM_DEP = PRD(K)+PRDS(K)+MNUCCD(K)+PRDG(K)
+
+           IF( (DUM.GT.0. .AND. SUM_DEP.GT.DUM*FUDGEF) .OR.                      &
+               (DUM.LT.0. .AND. SUM_DEP.LT.DUM*FUDGEF) ) THEN
+               MNUCCD(K) = FUDGEF*MNUCCD(K)*DUM/SUM_DEP
+               PRD(K) = FUDGEF*PRD(K)*DUM/SUM_DEP
+               PRDS(K) = FUDGEF*PRDS(K)*DUM/SUM_DEP
+	       PRDG(K) = FUDGEF*PRDG(K)*DUM/SUM_DEP
+           ENDIF
+
+! IF CLOUD ICE/SNOW/GRAUPEL VAP DEPOSITION IS NEG, THEN ASSIGN TO SUBLIMATION PROCESSES
+
+           IF (PRD(K).LT.0.) THEN
+              EPRD(K)=PRD(K)
+              PRD(K)=0.
+           END IF
+           IF (PRDS(K).LT.0.) THEN
+              EPRDS(K)=PRDS(K)
+              PRDS(K)=0.
+           END IF
+           IF (PRDG(K).LT.0.) THEN
+              EPRDG(K)=PRDG(K)
+              PRDG(K)=0.
+           END IF
+
+!.......................................................................
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+! CONSERVATION OF WATER
+! THIS IS ADOPTED LOOSELY FROM MM5 RESINER CODE. HOWEVER, HERE WE
+! ONLY ADJUST PROCESSES THAT ARE NEGATIVE, RATHER THAN ALL PROCESSES.
+
+! IF MIXING RATIOS LESS THAN QSMALL, THEN NO DEPLETION OF WATER
+! THROUGH MICROPHYSICAL PROCESSES, SKIP CONSERVATION
+
+! NOTE: CONSERVATION CHECK NOT APPLIED TO NUMBER CONCENTRATION SPECIES. ADDITIONAL CATCH
+! BELOW WILL PREVENT NEGATIVE NUMBER CONCENTRATION
+! FOR EACH MICROPHYSICAL PROCESS WHICH PROVIDES A SOURCE FOR NUMBER, THERE IS A CHECK
+! TO MAKE SURE THAT CAN'T EXCEED TOTAL NUMBER OF DEPLETED SPECIES WITH THE TIME
+! STEP
+
+!****SENSITIVITY - NO ICE
+
+      IF (ILIQ.EQ.1) THEN
+      MNUCCC(K)=0.
+      NNUCCC(K)=0.
+      MNUCCR(K)=0.
+      NNUCCR(K)=0.
+      MNUCCD(K)=0.
+      NNUCCD(K)=0.
+      END IF
+
+! ****SENSITIVITY - NO GRAUPEL
+      IF (IGRAUP.EQ.1) THEN
+            PRACG(K) = 0.
+            PSACR(K) = 0.
+	    PSACWG(K) = 0.
+	    PGSACW(K) = 0.
+            PGRACS(K) = 0.
+	    PRDG(K) = 0.
+	    EPRDG(K) = 0.
+            EVPMG(K) = 0.
+            PGMLT(K) = 0.
+	    NPRACG(K) = 0.
+	    NPSACWG(K) = 0.
+	    NSCNG(K) = 0.
+ 	    NGRACS(K) = 0.
+	    NSUBG(K) = 0.
+	    NGMLTG(K) = 0.
+            NGMLTR(K) = 0.
+       END IF
+
+! CONSERVATION OF QC
+
+      DUM = (PRC(K)+PRA(K)+MNUCCC(K)+PSACWS(K)+PSACWI(K)+QMULTS(K)+PSACWG(K)+PGSACW(K)+QMULTG(K))*DT
+
+      IF (DUM.GT.QC3D(K).AND.QC3D(K).GE.QSMALL) THEN
+        RATIO = QC3D(K)/DUM
+
+        PRC(K) = PRC(K)*RATIO
+        PRA(K) = PRA(K)*RATIO
+        MNUCCC(K) = MNUCCC(K)*RATIO
+        PSACWS(K) = PSACWS(K)*RATIO
+        PSACWI(K) = PSACWI(K)*RATIO
+        QMULTS(K) = QMULTS(K)*RATIO
+        QMULTG(K) = QMULTG(K)*RATIO
+        PSACWG(K) = PSACWG(K)*RATIO
+	PGSACW(K) = PGSACW(K)*RATIO
+        END IF
+ 
+! CONSERVATION OF QI
+
+      DUM = (-PRD(K)-MNUCCC(K)+PRCI(K)+PRAI(K)-QMULTS(K)-QMULTG(K)-QMULTR(K)-QMULTRG(K) &
+                -MNUCCD(K)+PRACI(K)+PRACIS(K)-EPRD(K)-PSACWI(K))*DT
+
+      IF (DUM.GT.QI3D(K).AND.QI3D(K).GE.QSMALL) THEN
+
+        RATIO = (QI3D(K)/DT+PRD(K)+MNUCCC(K)+QMULTS(K)+QMULTG(K)+QMULTR(K)+QMULTRG(K)+ &
+                     MNUCCD(K)+PSACWI(K))/ &
+                      (PRCI(K)+PRAI(K)+PRACI(K)+PRACIS(K)-EPRD(K))
+
+        PRCI(K) = PRCI(K)*RATIO
+        PRAI(K) = PRAI(K)*RATIO
+        PRACI(K) = PRACI(K)*RATIO
+        PRACIS(K) = PRACIS(K)*RATIO
+        EPRD(K) = EPRD(K)*RATIO
+
+        END IF
+
+! CONSERVATION OF QR
+
+      DUM=((PRACS(K)-PRE(K))+(QMULTR(K)+QMULTRG(K)-PRC(K))+(MNUCCR(K)-PRA(K))+ &
+             PIACR(K)+PIACRS(K)+PGRACS(K)+PRACG(K))*DT
+
+      IF (DUM.GT.QR3D(K).AND.QR3D(K).GE.QSMALL) THEN
+
+        RATIO = (QR3D(K)/DT+PRC(K)+PRA(K))/ &
+             (-PRE(K)+QMULTR(K)+QMULTRG(K)+PRACS(K)+MNUCCR(K)+PIACR(K)+PIACRS(K)+PGRACS(K)+PRACG(K))
+
+        PRE(K) = PRE(K)*RATIO
+        PRACS(K) = PRACS(K)*RATIO
+        QMULTR(K) = QMULTR(K)*RATIO
+        QMULTRG(K) = QMULTRG(K)*RATIO
+        MNUCCR(K) = MNUCCR(K)*RATIO
+        PIACR(K) = PIACR(K)*RATIO
+        PIACRS(K) = PIACRS(K)*RATIO
+        PGRACS(K) = PGRACS(K)*RATIO
+        PRACG(K) = PRACG(K)*RATIO
+
+        END IF
+
+! CONSERVATION OF QNI
+! CONSERVATION FOR GRAUPEL SCHEME
+
+        IF (IGRAUP.EQ.0) THEN
+
+      DUM = (-PRDS(K)-PSACWS(K)-PRAI(K)-PRCI(K)-PRACS(K)-EPRDS(K)+PSACR(K)-PIACRS(K)-PRACIS(K))*DT
+
+      IF (DUM.GT.QNI3D(K).AND.QNI3D(K).GE.QSMALL) THEN
+
+        RATIO = (QNI3D(K)/DT+PRDS(K)+PSACWS(K)+PRAI(K)+PRCI(K)+PRACS(K)+PIACRS(K)+PRACIS(K))/(-EPRDS(K)+PSACR(K))
+
+       EPRDS(K) = EPRDS(K)*RATIO
+       PSACR(K) = PSACR(K)*RATIO
+
+       END IF
+
+! FOR NO GRAUPEL, NEED TO INCLUDE FREEZING OF RAIN FOR SNOW
+       ELSE IF (IGRAUP.EQ.1) THEN
+
+      DUM = (-PRDS(K)-PSACWS(K)-PRAI(K)-PRCI(K)-PRACS(K)-EPRDS(K)+PSACR(K)-PIACRS(K)-PRACIS(K)-MNUCCR(K))*DT
+
+      IF (DUM.GT.QNI3D(K).AND.QNI3D(K).GE.QSMALL) THEN
+
+       RATIO = (QNI3D(K)/DT+PRDS(K)+PSACWS(K)+PRAI(K)+PRCI(K)+PRACS(K)+PIACRS(K)+PRACIS(K)+MNUCCR(K))/(-EPRDS(K)+PSACR(K))
+
+       EPRDS(K) = EPRDS(K)*RATIO
+       PSACR(K) = PSACR(K)*RATIO
+
+       END IF
+
+       END IF
+
+! CONSERVATION OF QG
+
+      DUM = (-PSACWG(K)-PRACG(K)-PGSACW(K)-PGRACS(K)-PRDG(K)-MNUCCR(K)-EPRDG(K)-PIACR(K)-PRACI(K)-PSACR(K))*DT
+
+      IF (DUM.GT.QG3D(K).AND.QG3D(K).GE.QSMALL) THEN
+
+        RATIO = (QG3D(K)/DT+PSACWG(K)+PRACG(K)+PGSACW(K)+PGRACS(K)+PRDG(K)+MNUCCR(K)+PSACR(K)+&
+                  PIACR(K)+PRACI(K))/(-EPRDG(K))
+
+       EPRDG(K) = EPRDG(K)*RATIO
+
+      END IF
+
+! TENDENCIES
+
+      QV3DTEN(K) = QV3DTEN(K)+(-PRE(K)-PRD(K)-PRDS(K)-MNUCCD(K)-EPRD(K)-EPRDS(K)-PRDG(K)-EPRDG(K))
+
+! BUG FIX HM, 3/1/11, INCLUDE PIACR AND PIACRS
+      T3DTEN(K) = T3DTEN(K)+(PRE(K)                                 &
+               *XXLV(K)+(PRD(K)+PRDS(K)+                            &
+                MNUCCD(K)+EPRD(K)+EPRDS(K)+PRDG(K)+EPRDG(K))*XXLS(K)+         &
+               (PSACWS(K)+PSACWI(K)+MNUCCC(K)+MNUCCR(K)+                      &
+                QMULTS(K)+QMULTG(K)+QMULTR(K)+QMULTRG(K)+PRACS(K) &
+                +PSACWG(K)+PRACG(K)+PGSACW(K)+PGRACS(K)+PIACR(K)+PIACRS(K))*XLF(K))/CPM(K)
+
+      QC3DTEN(K) = QC3DTEN(K)+                                      &
+                 (-PRA(K)-PRC(K)-MNUCCC(K)+PCC(K)-                  &
+                  PSACWS(K)-PSACWI(K)-QMULTS(K)-QMULTG(K)-PSACWG(K)-PGSACW(K))
+      QI3DTEN(K) = QI3DTEN(K)+                                      &
+         (PRD(K)+EPRD(K)+PSACWI(K)+MNUCCC(K)-PRCI(K)-                                 &
+                  PRAI(K)+QMULTS(K)+QMULTG(K)+QMULTR(K)+QMULTRG(K)+MNUCCD(K)-PRACI(K)-PRACIS(K))
+      QR3DTEN(K) = QR3DTEN(K)+                                      &
+                 (PRE(K)+PRA(K)+PRC(K)-PRACS(K)-MNUCCR(K)-QMULTR(K)-QMULTRG(K) &
+             -PIACR(K)-PIACRS(K)-PRACG(K)-PGRACS(K))
+
+      IF (IGRAUP.EQ.0) THEN
+
+      QNI3DTEN(K) = QNI3DTEN(K)+                                    &
+           (PRAI(K)+PSACWS(K)+PRDS(K)+PRACS(K)+PRCI(K)+EPRDS(K)-PSACR(K)+PIACRS(K)+PRACIS(K))
+      NS3DTEN(K) = NS3DTEN(K)+(NSAGG(K)+NPRCI(K)-NSCNG(K)-NGRACS(K)+NIACRS(K))
+      QG3DTEN(K) = QG3DTEN(K)+(PRACG(K)+PSACWG(K)+PGSACW(K)+PGRACS(K)+ &
+                    PRDG(K)+EPRDG(K)+MNUCCR(K)+PIACR(K)+PRACI(K)+PSACR(K))
+      NG3DTEN(K) = NG3DTEN(K)+(NSCNG(K)+NGRACS(K)+NNUCCR(K)+NIACR(K))
+
+! FOR NO GRAUPEL, NEED TO INCLUDE FREEZING OF RAIN FOR SNOW
+      ELSE IF (IGRAUP.EQ.1) THEN
+
+      QNI3DTEN(K) = QNI3DTEN(K)+                                    &
+           (PRAI(K)+PSACWS(K)+PRDS(K)+PRACS(K)+PRCI(K)+EPRDS(K)-PSACR(K)+PIACRS(K)+PRACIS(K)+MNUCCR(K))
+      NS3DTEN(K) = NS3DTEN(K)+(NSAGG(K)+NPRCI(K)-NSCNG(K)-NGRACS(K)+NIACRS(K)+NNUCCR(K))
+
+      END IF
+
+      NC3DTEN(K) = NC3DTEN(K)+(-NNUCCC(K)-NPSACWS(K)                &
+            -NPRA(K)-NPRC(K)-NPSACWI(K)-NPSACWG(K))
+
+      NI3DTEN(K) = NI3DTEN(K)+                                      &
+       (NNUCCC(K)-NPRCI(K)-NPRAI(K)+NMULTS(K)+NMULTG(K)+NMULTR(K)+NMULTRG(K)+ &
+               NNUCCD(K)-NIACR(K)-NIACRS(K))
+
+      NR3DTEN(K) = NR3DTEN(K)+(NPRC1(K)-NPRACS(K)-NNUCCR(K)      &
+                   +NRAGG(K)-NIACR(K)-NIACRS(K)-NPRACG(K)-NGRACS(K))
+
+! HM ADD, WRF-CHEM, ADD TENDENCIES FOR C2PREC
+
+	C2PREC(K) = PRA(K)+PRC(K)+PSACWS(K)+QMULTS(K)+QMULTG(K)+PSACWG(K)+ &
+       PGSACW(K)+MNUCCC(K)+PSACWI(K)
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! NOW CALCULATE SATURATION ADJUSTMENT TO CONDENSE EXTRA VAPOR ABOVE
+! WATER SATURATION
+
+      DUMT = T3D(K)+DT*T3DTEN(K)
+      DUMQV = QV3D(K)+DT*QV3DTEN(K)
+! hm, add fix for low pressure, 5/12/10
+      dum=min(0.99*pres(k),POLYSVP(DUMT,0))
+      DUMQSS = EP_2*dum/(PRES(K)-dum)
+      DUMQC = QC3D(K)+DT*QC3DTEN(K)
+      DUMQC = MAX(DUMQC,0.)
+
+! SATURATION ADJUSTMENT FOR LIQUID
+
+      DUMS = DUMQV-DUMQSS
+      PCC(K) = DUMS/(1.+XXLV(K)**2*DUMQSS/(CPM(K)*RV*DUMT**2))/DT
+      IF (PCC(K)*DT+DUMQC.LT.0.) THEN
+           PCC(K) = -DUMQC/DT
+      END IF
+
+      QV3DTEN(K) = QV3DTEN(K)-PCC(K)
+      T3DTEN(K) = T3DTEN(K)+PCC(K)*XXLV(K)/CPM(K)
+      QC3DTEN(K) = QC3DTEN(K)+PCC(K)
+
+!.......................................................................
+! ACTIVATION OF CLOUD DROPLETS
+! ACTIVATION OF DROPLET CURRENTLY NOT CALCULATED
+! DROPLET CONCENTRATION IS SPECIFIED !!!!!
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! SUBLIMATE, MELT, OR EVAPORATE NUMBER CONCENTRATION
+! THIS FORMULATION ASSUMES 1:1 RATIO BETWEEN MASS LOSS AND
+! LOSS OF NUMBER CONCENTRATION
+
+!     IF (PCC(K).LT.0.) THEN
+!        DUM = PCC(K)*DT/QC3D(K)
+!           DUM = MAX(-1.,DUM)
+!        NSUBC(K) = DUM*NC3D(K)/DT
+!     END IF
+
+      IF (EPRD(K).LT.0.) THEN
+         DUM = EPRD(K)*DT/QI3D(K)
+            DUM = MAX(-1.,DUM)
+         NSUBI(K) = DUM*NI3D(K)/DT
+      END IF
+      IF (EPRDS(K).LT.0.) THEN
+         DUM = EPRDS(K)*DT/QNI3D(K)
+           DUM = MAX(-1.,DUM)
+         NSUBS(K) = DUM*NS3D(K)/DT
+      END IF
+      IF (PRE(K).LT.0.) THEN
+         DUM = PRE(K)*DT/QR3D(K)
+           DUM = MAX(-1.,DUM)
+         NSUBR(K) = DUM*NR3D(K)/DT
+      END IF
+      IF (EPRDG(K).LT.0.) THEN
+         DUM = EPRDG(K)*DT/QG3D(K)
+           DUM = MAX(-1.,DUM)
+         NSUBG(K) = DUM*NG3D(K)/DT
+      END IF
+
+!        nsubr(k)=0.
+!        nsubs(k)=0.
+!        nsubg(k)=0.
+
+! UPDATE TENDENCIES
+
+!        NC3DTEN(K) = NC3DTEN(K)+NSUBC(K)
+         NI3DTEN(K) = NI3DTEN(K)+NSUBI(K)
+         NS3DTEN(K) = NS3DTEN(K)+NSUBS(K)
+         NG3DTEN(K) = NG3DTEN(K)+NSUBG(K)
+         NR3DTEN(K) = NR3DTEN(K)+NSUBR(K)
+
+         END IF !!!!!! TEMPERATURE
+
+! SWITCH LTRUE TO 1, SINCE HYDROMETEORS ARE PRESENT
+         LTRUE = 1
+
+ 200     CONTINUE
+
+        END DO
+
+! INITIALIZE PRECIP AND SNOW RATES
+      PRECRT = 0.
+      SNOWRT = 0.
+
+! IF THERE ARE NO HYDROMETEORS, THEN SKIP TO END OF SUBROUTINE
+
+        IF (LTRUE.EQ.0) GOTO 400
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+!.......................................................................
+! CALCULATE SEDIMENATION
+! THE NUMERICS HERE FOLLOW FROM REISNER ET AL. (1998)
+! FALLOUT TERMS ARE CALCULATED ON SPLIT TIME STEPS TO ENSURE NUMERICAL
+! STABILITY, I.E. COURANT# < 1
+
+!.......................................................................
+
+      NSTEP = 1
+
+      DO K = KTE,KTS,-1
+
+        DUMI(K) = QI3D(K)+QI3DTEN(K)*DT
+        DUMQS(K) = QNI3D(K)+QNI3DTEN(K)*DT
+        DUMR(K) = QR3D(K)+QR3DTEN(K)*DT
+        DUMFNI(K) = NI3D(K)+NI3DTEN(K)*DT
+        DUMFNS(K) = NS3D(K)+NS3DTEN(K)*DT
+        DUMFNR(K) = NR3D(K)+NR3DTEN(K)*DT
+        DUMC(K) = QC3D(K)+QC3DTEN(K)*DT
+        DUMFNC(K) = NC3D(K)+NC3DTEN(K)*DT
+	DUMG(K) = QG3D(K)+QG3DTEN(K)*DT
+	DUMFNG(K) = NG3D(K)+NG3DTEN(K)*DT
+
+! SWITCH FOR CONSTANT DROPLET NUMBER
+        IF (iinum.EQ.1) THEN
+        DUMFNC(K) = NC3D(K)
+        END IF
+
+! GET DUMMY LAMDA FOR SEDIMENTATION CALCULATIONS
+
+! MAKE SURE NUMBER CONCENTRATIONS ARE POSITIVE
+      DUMFNI(K) = MAX(0.,DUMFNI(K))
+      DUMFNS(K) = MAX(0.,DUMFNS(K))
+      DUMFNC(K) = MAX(0.,DUMFNC(K))
+      DUMFNR(K) = MAX(0.,DUMFNR(K))
+      DUMFNG(K) = MAX(0.,DUMFNG(K))
+
+!......................................................................
+! CLOUD ICE
+
+      IF (DUMI(K).GE.QSMALL) THEN
+        DLAMI = (CONS12*DUMFNI(K)/DUMI(K))**(1./DI)
+        DLAMI=MAX(DLAMI,LAMMINI)
+        DLAMI=MIN(DLAMI,LAMMAXI)
+      END IF
+!......................................................................
+! RAIN
+
+      IF (DUMR(K).GE.QSMALL) THEN
+        DLAMR = (PI*RHOW*DUMFNR(K)/DUMR(K))**(1./3.)
+        DLAMR=MAX(DLAMR,LAMMINR)
+        DLAMR=MIN(DLAMR,LAMMAXR)
+      END IF
+!......................................................................
+! CLOUD DROPLETS
+
+      IF (DUMC(K).GE.QSMALL) THEN
+         DUM = PRES(K)/(287.15*T3D(K))
+         PGAM(K)=0.0005714*(NC3D(K)/1.E6*DUM)+0.2714
+         PGAM(K)=1./(PGAM(K)**2)-1.
+         PGAM(K)=MAX(PGAM(K),2.)
+         PGAM(K)=MIN(PGAM(K),10.)
+
+        DLAMC = (CONS26*DUMFNC(K)*GAMMA(PGAM(K)+4.)/(DUMC(K)*GAMMA(PGAM(K)+1.)))**(1./3.)
+        LAMMIN = (PGAM(K)+1.)/60.E-6
+        LAMMAX = (PGAM(K)+1.)/1.E-6
+        DLAMC=MAX(DLAMC,LAMMIN)
+        DLAMC=MIN(DLAMC,LAMMAX)
+      END IF
+!......................................................................
+! SNOW
+
+      IF (DUMQS(K).GE.QSMALL) THEN
+        DLAMS = (CONS1*DUMFNS(K)/ DUMQS(K))**(1./DS)
+        DLAMS=MAX(DLAMS,LAMMINS)
+        DLAMS=MIN(DLAMS,LAMMAXS)
+      END IF
+!......................................................................
+! GRAUPEL
+
+      IF (DUMG(K).GE.QSMALL) THEN
+        DLAMG = (CONS2*DUMFNG(K)/ DUMG(K))**(1./DG)
+        DLAMG=MAX(DLAMG,LAMMING)
+        DLAMG=MIN(DLAMG,LAMMAXG)
+      END IF
+
+!......................................................................
+! CALCULATE NUMBER-WEIGHTED AND MASS-WEIGHTED TERMINAL FALL SPEEDS
+
+! CLOUD WATER
+
+      IF (DUMC(K).GE.QSMALL) THEN
+      UNC =  ACN(K)*GAMMA(1.+BC+PGAM(K))/ (DLAMC**BC*GAMMA(PGAM(K)+1.))
+      UMC = ACN(K)*GAMMA(4.+BC+PGAM(K))/  (DLAMC**BC*GAMMA(PGAM(K)+4.))
+      ELSE
+      UMC = 0.
+      UNC = 0.
+      END IF
+
+      IF (DUMI(K).GE.QSMALL) THEN
+      UNI =  AIN(K)*CONS27/DLAMI**BI
+      UMI = AIN(K)*CONS28/(DLAMI**BI)
+      ELSE
+      UMI = 0.
+      UNI = 0.
+      END IF
+
+      IF (DUMR(K).GE.QSMALL) THEN
+      UNR = ARN(K)*CONS6/DLAMR**BR
+      UMR = ARN(K)*CONS4/(DLAMR**BR)
+      ELSE
+      UMR = 0.
+      UNR = 0.
+      END IF
+
+      IF (DUMQS(K).GE.QSMALL) THEN
+      UMS = ASN(K)*CONS3/(DLAMS**BS)
+      UNS = ASN(K)*CONS5/DLAMS**BS
+      ELSE
+      UMS = 0.
+      UNS = 0.
+      END IF
+
+      IF (DUMG(K).GE.QSMALL) THEN
+      UMG = AGN(K)*CONS7/(DLAMG**BG)
+      UNG = AGN(K)*CONS8/DLAMG**BG
+      ELSE
+      UMG = 0.
+      UNG = 0.
+      END IF
+
+! SET REALISTIC LIMITS ON FALLSPEED
+
+! bug fix, 10/08/09
+        dum=(rhosu/rho(k))**0.54
+        UMS=MIN(UMS,1.2*dum)
+        UNS=MIN(UNS,1.2*dum)
+        UMI=MIN(UMI,1.2*dum)
+        UNI=MIN(UNI,1.2*dum)
+        UMR=MIN(UMR,9.1*dum)
+        UNR=MIN(UNR,9.1*dum)
+        UMG=MIN(UMG,20.*dum)
+        UNG=MIN(UNG,20.*dum)
+
+      FR(K) = UMR
+      FI(K) = UMI
+      FNI(K) = UNI
+      FS(K) = UMS
+      FNS(K) = UNS
+      FNR(K) = UNR
+      FC(K) = UMC
+      FNC(K) = UNC
+      FG(K) = UMG
+      FNG(K) = UNG
+
+! V3.3 MODIFY FALLSPEED BELOW LEVEL OF PRECIP
+
+	IF (K.LE.KTE-1) THEN
+        IF (FR(K).LT.1.E-10) THEN
+	FR(K)=FR(K+1)
+	END IF
+        IF (FI(K).LT.1.E-10) THEN
+	FI(K)=FI(K+1)
+	END IF
+        IF (FNI(K).LT.1.E-10) THEN
+	FNI(K)=FNI(K+1)
+	END IF
+        IF (FS(K).LT.1.E-10) THEN
+	FS(K)=FS(K+1)
+	END IF
+        IF (FNS(K).LT.1.E-10) THEN
+	FNS(K)=FNS(K+1)
+	END IF
+        IF (FNR(K).LT.1.E-10) THEN
+	FNR(K)=FNR(K+1)
+	END IF
+        IF (FC(K).LT.1.E-10) THEN
+	FC(K)=FC(K+1)
+	END IF
+        IF (FNC(K).LT.1.E-10) THEN
+	FNC(K)=FNC(K+1)
+	END IF
+        IF (FG(K).LT.1.E-10) THEN
+	FG(K)=FG(K+1)
+	END IF
+        IF (FNG(K).LT.1.E-10) THEN
+	FNG(K)=FNG(K+1)
+	END IF
+	END IF ! K LE KTE-1
+
+! CALCULATE NUMBER OF SPLIT TIME STEPS
+
+      RGVM = MAX(FR(K),FI(K),FS(K),FC(K),FNI(K),FNR(K),FNS(K),FNC(K),FG(K),FNG(K))
+! VVT CHANGED IFIX -> INT (GENERIC FUNCTION)
+      NSTEP = MAX(INT(RGVM*DT/DZQ(K)+1.),NSTEP)
+
+! MULTIPLY VARIABLES BY RHO
+      DUMR(k) = DUMR(k)*RHO(K)
+      DUMI(k) = DUMI(k)*RHO(K)
+      DUMFNI(k) = DUMFNI(K)*RHO(K)
+      DUMQS(k) = DUMQS(K)*RHO(K)
+      DUMFNS(k) = DUMFNS(K)*RHO(K)
+      DUMFNR(k) = DUMFNR(K)*RHO(K)
+      DUMC(k) = DUMC(K)*RHO(K)
+      DUMFNC(k) = DUMFNC(K)*RHO(K)
+      DUMG(k) = DUMG(K)*RHO(K)
+      DUMFNG(k) = DUMFNG(K)*RHO(K)
+
+      END DO
+
+      DO N = 1,NSTEP
+
+      DO K = KTS,KTE
+      FALOUTR(K) = FR(K)*DUMR(K)
+      FALOUTI(K) = FI(K)*DUMI(K)
+      FALOUTNI(K) = FNI(K)*DUMFNI(K)
+      FALOUTS(K) = FS(K)*DUMQS(K)
+      FALOUTNS(K) = FNS(K)*DUMFNS(K)
+      FALOUTNR(K) = FNR(K)*DUMFNR(K)
+      FALOUTC(K) = FC(K)*DUMC(K)
+      FALOUTNC(K) = FNC(K)*DUMFNC(K)
+      FALOUTG(K) = FG(K)*DUMG(K)
+      FALOUTNG(K) = FNG(K)*DUMFNG(K)
+      END DO
+
+! TOP OF MODEL
+
+      K = KTE
+      FALTNDR = FALOUTR(K)/DZQ(k)
+      FALTNDI = FALOUTI(K)/DZQ(k)
+      FALTNDNI = FALOUTNI(K)/DZQ(k)
+      FALTNDS = FALOUTS(K)/DZQ(k)
+      FALTNDNS = FALOUTNS(K)/DZQ(k)
+      FALTNDNR = FALOUTNR(K)/DZQ(k)
+      FALTNDC = FALOUTC(K)/DZQ(k)
+      FALTNDNC = FALOUTNC(K)/DZQ(k)
+      FALTNDG = FALOUTG(K)/DZQ(k)
+      FALTNDNG = FALOUTNG(K)/DZQ(k)
+! ADD FALLOUT TERMS TO EULERIAN TENDENCIES
+
+      QRSTEN(K) = QRSTEN(K)-FALTNDR/NSTEP/RHO(k)
+      QISTEN(K) = QISTEN(K)-FALTNDI/NSTEP/RHO(k)
+      NI3DTEN(K) = NI3DTEN(K)-FALTNDNI/NSTEP/RHO(k)
+      QNISTEN(K) = QNISTEN(K)-FALTNDS/NSTEP/RHO(k)
+      NS3DTEN(K) = NS3DTEN(K)-FALTNDNS/NSTEP/RHO(k)
+      NR3DTEN(K) = NR3DTEN(K)-FALTNDNR/NSTEP/RHO(k)
+      QCSTEN(K) = QCSTEN(K)-FALTNDC/NSTEP/RHO(k)
+      NC3DTEN(K) = NC3DTEN(K)-FALTNDNC/NSTEP/RHO(k)
+      QGSTEN(K) = QGSTEN(K)-FALTNDG/NSTEP/RHO(k)
+      NG3DTEN(K) = NG3DTEN(K)-FALTNDNG/NSTEP/RHO(k)
+
+      DUMR(K) = DUMR(K)-FALTNDR*DT/NSTEP
+      DUMI(K) = DUMI(K)-FALTNDI*DT/NSTEP
+      DUMFNI(K) = DUMFNI(K)-FALTNDNI*DT/NSTEP
+      DUMQS(K) = DUMQS(K)-FALTNDS*DT/NSTEP
+      DUMFNS(K) = DUMFNS(K)-FALTNDNS*DT/NSTEP
+      DUMFNR(K) = DUMFNR(K)-FALTNDNR*DT/NSTEP
+      DUMC(K) = DUMC(K)-FALTNDC*DT/NSTEP
+      DUMFNC(K) = DUMFNC(K)-FALTNDNC*DT/NSTEP
+      DUMG(K) = DUMG(K)-FALTNDG*DT/NSTEP
+      DUMFNG(K) = DUMFNG(K)-FALTNDNG*DT/NSTEP
+
+      DO K = KTE-1,KTS,-1
+      FALTNDR = (FALOUTR(K+1)-FALOUTR(K))/DZQ(K)
+      FALTNDI = (FALOUTI(K+1)-FALOUTI(K))/DZQ(K)
+      FALTNDNI = (FALOUTNI(K+1)-FALOUTNI(K))/DZQ(K)
+      FALTNDS = (FALOUTS(K+1)-FALOUTS(K))/DZQ(K)
+      FALTNDNS = (FALOUTNS(K+1)-FALOUTNS(K))/DZQ(K)
+      FALTNDNR = (FALOUTNR(K+1)-FALOUTNR(K))/DZQ(K)
+      FALTNDC = (FALOUTC(K+1)-FALOUTC(K))/DZQ(K)
+      FALTNDNC = (FALOUTNC(K+1)-FALOUTNC(K))/DZQ(K)
+      FALTNDG = (FALOUTG(K+1)-FALOUTG(K))/DZQ(K)
+      FALTNDNG = (FALOUTNG(K+1)-FALOUTNG(K))/DZQ(K)
+
+! ADD FALLOUT TERMS TO EULERIAN TENDENCIES
+
+      QRSTEN(K) = QRSTEN(K)+FALTNDR/NSTEP/RHO(k)
+      QISTEN(K) = QISTEN(K)+FALTNDI/NSTEP/RHO(k)
+      NI3DTEN(K) = NI3DTEN(K)+FALTNDNI/NSTEP/RHO(k)
+      QNISTEN(K) = QNISTEN(K)+FALTNDS/NSTEP/RHO(k)
+      NS3DTEN(K) = NS3DTEN(K)+FALTNDNS/NSTEP/RHO(k)
+      NR3DTEN(K) = NR3DTEN(K)+FALTNDNR/NSTEP/RHO(k)
+      QCSTEN(K) = QCSTEN(K)+FALTNDC/NSTEP/RHO(k)
+      NC3DTEN(K) = NC3DTEN(K)+FALTNDNC/NSTEP/RHO(k)
+      QGSTEN(K) = QGSTEN(K)+FALTNDG/NSTEP/RHO(k)
+      NG3DTEN(K) = NG3DTEN(K)+FALTNDNG/NSTEP/RHO(k)
+
+      DUMR(K) = DUMR(K)+FALTNDR*DT/NSTEP
+      DUMI(K) = DUMI(K)+FALTNDI*DT/NSTEP
+      DUMFNI(K) = DUMFNI(K)+FALTNDNI*DT/NSTEP
+      DUMQS(K) = DUMQS(K)+FALTNDS*DT/NSTEP
+      DUMFNS(K) = DUMFNS(K)+FALTNDNS*DT/NSTEP
+      DUMFNR(K) = DUMFNR(K)+FALTNDNR*DT/NSTEP
+      DUMC(K) = DUMC(K)+FALTNDC*DT/NSTEP
+      DUMFNC(K) = DUMFNC(K)+FALTNDNC*DT/NSTEP
+      DUMG(K) = DUMG(K)+FALTNDG*DT/NSTEP
+      DUMFNG(K) = DUMFNG(K)+FALTNDNG*DT/NSTEP
+
+! FOR WRF-CHEM, NEED PRECIP RATES (UNITS OF KG/M^2/S)
+	  CSED(K)=CSED(K)+FALOUTC(K)/NSTEP
+	  ISED(K)=ISED(K)+FALOUTI(K)/NSTEP
+	  SSED(K)=SSED(K)+FALOUTS(K)/NSTEP
+	  GSED(K)=GSED(K)+FALOUTG(K)/NSTEP
+	  RSED(K)=RSED(K)+FALOUTR(K)/NSTEP
+      END DO
+
+! GET PRECIPITATION AND SNOWFALL ACCUMULATION DURING THE TIME STEP
+! FACTOR OF 1000 CONVERTS FROM M TO MM, BUT DIVISION BY DENSITY
+! OF LIQUID WATER CANCELS THIS FACTOR OF 1000
+
+        PRECRT = PRECRT+(FALOUTR(KTS)+FALOUTC(KTS)+FALOUTS(KTS)+FALOUTI(KTS)+FALOUTG(KTS))  &
+                     *DT/NSTEP
+        SNOWRT = SNOWRT+(FALOUTS(KTS)+FALOUTI(KTS)+FALOUTG(KTS))*DT/NSTEP
+
+      END DO
+
+        DO K=KTS,KTE
+
+! ADD ON SEDIMENTATION TENDENCIES FOR MIXING RATIO TO REST OF TENDENCIES
+
+        QR3DTEN(K)=QR3DTEN(K)+QRSTEN(K)
+        QI3DTEN(K)=QI3DTEN(K)+QISTEN(K)
+        QC3DTEN(K)=QC3DTEN(K)+QCSTEN(K)
+        QG3DTEN(K)=QG3DTEN(K)+QGSTEN(K)
+        QNI3DTEN(K)=QNI3DTEN(K)+QNISTEN(K)
+
+! PUT ALL CLOUD ICE IN SNOW CATEGORY IF MEAN DIAMETER EXCEEDS 2 * dcs
+
+!hm 4/7/09 bug fix
+!        IF (QI3D(K).GE.QSMALL.AND.T3D(K).LT.273.15) THEN
+        IF (QI3D(K).GE.QSMALL.AND.T3D(K).LT.273.15.AND.LAMI(K).GE.1.E-10) THEN
+        IF (1./LAMI(K).GE.2.*DCS) THEN
+           QNI3DTEN(K) = QNI3DTEN(K)+QI3D(K)/DT+ QI3DTEN(K)
+           NS3DTEN(K) = NS3DTEN(K)+NI3D(K)/DT+   NI3DTEN(K)
+           QI3DTEN(K) = -QI3D(K)/DT
+           NI3DTEN(K) = -NI3D(K)/DT
+        END IF
+        END IF
+
+! hm add tendencies here, then call sizeparameter
+! to ensure consisitency between mixing ratio and number concentration
+
+          QC3D(k)        = QC3D(k)+QC3DTEN(k)*DT
+          QI3D(k)        = QI3D(k)+QI3DTEN(k)*DT
+          QNI3D(k)        = QNI3D(k)+QNI3DTEN(k)*DT
+          QR3D(k)        = QR3D(k)+QR3DTEN(k)*DT
+          NC3D(k)        = NC3D(k)+NC3DTEN(k)*DT
+          NI3D(k)        = NI3D(k)+NI3DTEN(k)*DT
+          NS3D(k)        = NS3D(k)+NS3DTEN(k)*DT
+          NR3D(k)        = NR3D(k)+NR3DTEN(k)*DT
+
+          IF (IGRAUP.EQ.0) THEN
+          QG3D(k)        = QG3D(k)+QG3DTEN(k)*DT
+          NG3D(k)        = NG3D(k)+NG3DTEN(k)*DT
+          END IF
+
+! ADD TEMPERATURE AND WATER VAPOR TENDENCIES FROM MICROPHYSICS
+          T3D(K)         = T3D(K)+T3DTEN(k)*DT
+          QV3D(K)        = QV3D(K)+QV3DTEN(k)*DT
+
+! SATURATION VAPOR PRESSURE AND MIXING RATIO
+
+! hm, add fix for low pressure, 5/12/10
+            EVS(K) = min(0.99*pres(k),POLYSVP(T3D(K),0))   ! PA
+            EIS(K) = min(0.99*pres(k),POLYSVP(T3D(K),1))   ! PA
+
+! MAKE SURE ICE SATURATION DOESN'T EXCEED WATER SAT. NEAR FREEZING
+
+            IF (EIS(K).GT.EVS(K)) EIS(K) = EVS(K)
+
+            QVS(K) = EP_2*EVS(K)/(PRES(K)-EVS(K))
+            QVI(K) = EP_2*EIS(K)/(PRES(K)-EIS(K))
+
+            QVQVS(K) = QV3D(K)/QVS(K)
+            QVQVSI(K) = QV3D(K)/QVI(K)
+
+! AT SUBSATURATION, REMOVE SMALL AMOUNTS OF CLOUD/PRECIP WATER
+! hm 7/9/09 change limit to 1.e-8
+
+             IF (QVQVS(K).LT.0.9) THEN
+               IF (QR3D(K).LT.1.E-8) THEN
+                  QV3D(K)=QV3D(K)+QR3D(K)
+                  T3D(K)=T3D(K)-QR3D(K)*XXLV(K)/CPM(K)
+                  QR3D(K)=0.
+               END IF
+               IF (QC3D(K).LT.1.E-8) THEN
+                  QV3D(K)=QV3D(K)+QC3D(K)
+                  T3D(K)=T3D(K)-QC3D(K)*XXLV(K)/CPM(K)
+                  QC3D(K)=0.
+               END IF
+             END IF
+
+             IF (QVQVSI(K).LT.0.9) THEN
+               IF (QI3D(K).LT.1.E-8) THEN
+                  QV3D(K)=QV3D(K)+QI3D(K)
+                  T3D(K)=T3D(K)-QI3D(K)*XXLS(K)/CPM(K)
+                  QI3D(K)=0.
+               END IF
+               IF (QNI3D(K).LT.1.E-8) THEN
+                  QV3D(K)=QV3D(K)+QNI3D(K)
+                  T3D(K)=T3D(K)-QNI3D(K)*XXLS(K)/CPM(K)
+                  QNI3D(K)=0.
+               END IF
+               IF (QG3D(K).LT.1.E-8) THEN
+                  QV3D(K)=QV3D(K)+QG3D(K)
+                  T3D(K)=T3D(K)-QG3D(K)*XXLS(K)/CPM(K)
+                  QG3D(K)=0.
+               END IF
+             END IF
+
+!..................................................................
+! IF MIXING RATIO < QSMALL SET MIXING RATIO AND NUMBER CONC TO ZERO
+
+       IF (QC3D(K).LT.QSMALL) THEN
+         QC3D(K) = 0.
+         NC3D(K) = 0.
+         EFFC(K) = 0.
+       END IF
+       IF (QR3D(K).LT.QSMALL) THEN
+         QR3D(K) = 0.
+         NR3D(K) = 0.
+         EFFR(K) = 0.
+       END IF
+       IF (QI3D(K).LT.QSMALL) THEN
+         QI3D(K) = 0.
+         NI3D(K) = 0.
+         EFFI(K) = 0.
+       END IF
+       IF (QNI3D(K).LT.QSMALL) THEN
+         QNI3D(K) = 0.
+         NS3D(K) = 0.
+         EFFS(K) = 0.
+       END IF
+       IF (QG3D(K).LT.QSMALL) THEN
+         QG3D(K) = 0.
+         NG3D(K) = 0.
+         EFFG(K) = 0.
+       END IF
+
+!..................................
+! IF THERE IS NO CLOUD/PRECIP WATER, THEN SKIP CALCULATIONS
+
+            IF (QC3D(K).LT.QSMALL.AND.QI3D(K).LT.QSMALL.AND.QNI3D(K).LT.QSMALL &
+                 .AND.QR3D(K).LT.QSMALL.AND.QG3D(K).LT.QSMALL) GOTO 500
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+! CALCULATE INSTANTANEOUS PROCESSES
+
+! ADD MELTING OF CLOUD ICE TO FORM RAIN
+
+        IF (QI3D(K).GE.QSMALL.AND.T3D(K).GE.273.15) THEN
+           QR3D(K) = QR3D(K)+QI3D(K)
+           T3D(K) = T3D(K)-QI3D(K)*XLF(K)/CPM(K)
+           QI3D(K) = 0.
+           NR3D(K) = NR3D(K)+NI3D(K)
+           NI3D(K) = 0.
+        END IF
+
+! ****SENSITIVITY - NO ICE
+        IF (ILIQ.EQ.1) GOTO 778
+
+! HOMOGENEOUS FREEZING OF CLOUD WATER
+
+        IF (T3D(K).LE.233.15.AND.QC3D(K).GE.QSMALL) THEN
+           QI3D(K)=QI3D(K)+QC3D(K)
+           T3D(K)=T3D(K)+QC3D(K)*XLF(K)/CPM(K)
+           QC3D(K)=0.
+           NI3D(K)=NI3D(K)+NC3D(K)
+           NC3D(K)=0.
+        END IF
+
+! HOMOGENEOUS FREEZING OF RAIN
+
+        IF (IGRAUP.EQ.0) THEN
+
+        IF (T3D(K).LE.233.15.AND.QR3D(K).GE.QSMALL) THEN
+           QG3D(K) = QG3D(K)+QR3D(K)
+           T3D(K) = T3D(K)+QR3D(K)*XLF(K)/CPM(K)
+           QR3D(K) = 0.
+           NG3D(K) = NG3D(K)+ NR3D(K)
+           NR3D(K) = 0.
+        END IF
+
+        ELSE IF (IGRAUP.EQ.1) THEN
+
+        IF (T3D(K).LE.233.15.AND.QR3D(K).GE.QSMALL) THEN
+           QNI3D(K) = QNI3D(K)+QR3D(K)
+           T3D(K) = T3D(K)+QR3D(K)*XLF(K)/CPM(K)
+           QR3D(K) = 0.
+           NS3D(K) = NS3D(K)+NR3D(K)
+           NR3D(K) = 0.
+        END IF
+
+        END IF
+
+ 778    CONTINUE
+
+! MAKE SURE NUMBER CONCENTRATIONS AREN'T NEGATIVE
+
+      NI3D(K) = MAX(0.,NI3D(K))
+      NS3D(K) = MAX(0.,NS3D(K))
+      NC3D(K) = MAX(0.,NC3D(K))
+      NR3D(K) = MAX(0.,NR3D(K))
+      NG3D(K) = MAX(0.,NG3D(K))
+
+!......................................................................
+! CLOUD ICE
+
+      IF (QI3D(K).GE.QSMALL) THEN
+         LAMI(K) = (CONS12*                 &
+              NI3D(K)/QI3D(K))**(1./DI)
+
+! CHECK FOR SLOPE
+
+! ADJUST VARS
+
+      IF (LAMI(K).LT.LAMMINI) THEN
+
+      LAMI(K) = LAMMINI
+
+      N0I(K) = LAMI(K)**4*QI3D(K)/CONS12
+
+      NI3D(K) = N0I(K)/LAMI(K)
+      ELSE IF (LAMI(K).GT.LAMMAXI) THEN
+      LAMI(K) = LAMMAXI
+      N0I(K) = LAMI(K)**4*QI3D(K)/CONS12
+
+      NI3D(K) = N0I(K)/LAMI(K)
+      END IF
+      END IF
+
+!......................................................................
+! RAIN
+
+      IF (QR3D(K).GE.QSMALL) THEN
+      LAMR(K) = (PI*RHOW*NR3D(K)/QR3D(K))**(1./3.)
+
+! CHECK FOR SLOPE
+
+! ADJUST VARS
+
+      IF (LAMR(K).LT.LAMMINR) THEN
+
+      LAMR(K) = LAMMINR
+
+      N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW)
+
+      NR3D(K) = N0RR(K)/LAMR(K)
+      ELSE IF (LAMR(K).GT.LAMMAXR) THEN
+      LAMR(K) = LAMMAXR
+      N0RR(K) = LAMR(K)**4*QR3D(K)/(PI*RHOW)
+
+      NR3D(K) = N0RR(K)/LAMR(K)
+      END IF
+
+      END IF
+
+!......................................................................
+! CLOUD DROPLETS
+
+! MARTIN ET AL. (1994) FORMULA FOR PGAM
+
+      IF (QC3D(K).GE.QSMALL) THEN
+
+         DUM = PRES(K)/(287.15*T3D(K))
+         PGAM(K)=0.0005714*(NC3D(K)/1.E6*DUM)+0.2714
+         PGAM(K)=1./(PGAM(K)**2)-1.
+         PGAM(K)=MAX(PGAM(K),2.)
+         PGAM(K)=MIN(PGAM(K),10.)
+
+! CALCULATE LAMC
+
+      LAMC(K) = (CONS26*NC3D(K)*GAMMA(PGAM(K)+4.)/   &
+                 (QC3D(K)*GAMMA(PGAM(K)+1.)))**(1./3.)
+
+! LAMMIN, 60 MICRON DIAMETER
+! LAMMAX, 1 MICRON
+
+      LAMMIN = (PGAM(K)+1.)/60.E-6
+      LAMMAX = (PGAM(K)+1.)/1.E-6
+
+      IF (LAMC(K).LT.LAMMIN) THEN
+      LAMC(K) = LAMMIN
+      NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+              &
+                LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26
+
+      ELSE IF (LAMC(K).GT.LAMMAX) THEN
+      LAMC(K) = LAMMAX
+      NC3D(K) = EXP(3.*LOG(LAMC(K))+LOG(QC3D(K))+              &
+                LOG(GAMMA(PGAM(K)+1.))-LOG(GAMMA(PGAM(K)+4.)))/CONS26
+
+      END IF
+
+      END IF
+
+!......................................................................
+! SNOW
+
+      IF (QNI3D(K).GE.QSMALL) THEN
+      LAMS(K) = (CONS1*NS3D(K)/QNI3D(K))**(1./DS)
+
+! CHECK FOR SLOPE
+
+! ADJUST VARS
+
+      IF (LAMS(K).LT.LAMMINS) THEN
+      LAMS(K) = LAMMINS
+      N0S(K) = LAMS(K)**4*QNI3D(K)/CONS1
+
+      NS3D(K) = N0S(K)/LAMS(K)
+
+      ELSE IF (LAMS(K).GT.LAMMAXS) THEN
+
+      LAMS(K) = LAMMAXS
+      N0S(K) = LAMS(K)**4*QNI3D(K)/CONS1
+      NS3D(K) = N0S(K)/LAMS(K)
+      END IF
+
+      END IF
+
+!......................................................................
+! GRAUPEL
+
+      IF (QG3D(K).GE.QSMALL) THEN
+      LAMG(K) = (CONS2*NG3D(K)/QG3D(K))**(1./DG)
+
+! CHECK FOR SLOPE
+
+! ADJUST VARS
+
+      IF (LAMG(K).LT.LAMMING) THEN
+      LAMG(K) = LAMMING
+      N0G(K) = LAMG(K)**4*QG3D(K)/CONS2
+
+      NG3D(K) = N0G(K)/LAMG(K)
+
+      ELSE IF (LAMG(K).GT.LAMMAXG) THEN
+
+      LAMG(K) = LAMMAXG
+      N0G(K) = LAMG(K)**4*QG3D(K)/CONS2
+
+      NG3D(K) = N0G(K)/LAMG(K)
+      END IF
+
+      END IF
+
+ 500  CONTINUE
+
+! CALCULATE EFFECTIVE RADIUS
+
+      IF (QI3D(K).GE.QSMALL) THEN
+         EFFI(K) = 3./LAMI(K)/2.*1.E6
+      ELSE
+         EFFI(K) = 25.
+      END IF
+
+      IF (QNI3D(K).GE.QSMALL) THEN
+         EFFS(K) = 3./LAMS(K)/2.*1.E6
+      ELSE
+         EFFS(K) = 25.
+      END IF
+
+      IF (QR3D(K).GE.QSMALL) THEN
+         EFFR(K) = 3./LAMR(K)/2.*1.E6
+      ELSE
+         EFFR(K) = 25.
+      END IF
+
+      IF (QC3D(K).GE.QSMALL) THEN
+      EFFC(K) = GAMMA(PGAM(K)+4.)/                        &
+             GAMMA(PGAM(K)+3.)/LAMC(K)/2.*1.E6
+      ELSE
+      EFFC(K) = 25.
+      END IF
+
+      IF (QG3D(K).GE.QSMALL) THEN
+         EFFG(K) = 3./LAMG(K)/2.*1.E6
+      ELSE
+         EFFG(K) = 25.
+      END IF
+
+! HM ADD 1/10/06, ADD UPPER BOUND ON ICE NUMBER, THIS IS NEEDED
+! TO PREVENT VERY LARGE ICE NUMBER DUE TO HOMOGENEOUS FREEZING
+! OF DROPLETS, ESPECIALLY WHEN INUM = 1, SET MAX AT 10 CM-3
+          NI3D(K) = MIN(NI3D(K),10.E6/RHO(K))
+! ADD BOUND ON DROPLET NUMBER - CANNOT EXCEED AEROSOL CONCENTRATION
+          IF (iinum.EQ.0.AND.IACT.EQ.2) THEN
+          NC3D(K) = MIN(NC3D(K),(NANEW1+NANEW2)/RHO(K))
+          END IF
+! SWITCH FOR CONSTANT DROPLET NUMBER
+          IF (iinum.EQ.1) THEN 
+! CHANGE NDCNST FROM CM-3 TO KG-1
+             NC3D(K) = NDCNST*1.E6/RHO(K)
+          END IF
+
+      END DO !!! K LOOP
+
+ 400         CONTINUE
+
+! ALL DONE !!!!!!!!!!!
+      RETURN
+      END SUBROUTINE MORR_TWO_MOMENT_MICRO
+
+!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
+
+      REAL FUNCTION POLYSVP (T,TYPE)
+
+!-------------------------------------------
+
+!  COMPUTE SATURATION VAPOR PRESSURE
+
+!  POLYSVP RETURNED IN UNITS OF PA.
+!  T IS INPUT IN UNITS OF K.
+!  TYPE REFERS TO SATURATION WITH RESPECT TO LIQUID (0) OR ICE (1)
+
+! REPLACE GOFF-GRATCH WITH FASTER FORMULATION FROM FLATAU ET AL. 1992, TABLE 4 (RIGHT-HAND COLUMN)
+
+      IMPLICIT NONE
+
+      REAL DUM
+      REAL T
+      INTEGER TYPE
+! ice
+      real a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i 
+      data a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i /&
+	6.11147274, 0.503160820, 0.188439774e-1, &
+        0.420895665e-3, 0.615021634e-5,0.602588177e-7, &
+        0.385852041e-9, 0.146898966e-11, 0.252751365e-14/	
+
+! liquid
+      real a0,a1,a2,a3,a4,a5,a6,a7,a8 
+
+! V1.7
+      data a0,a1,a2,a3,a4,a5,a6,a7,a8 /&
+	6.11239921, 0.443987641, 0.142986287e-1, &
+        0.264847430e-3, 0.302950461e-5, 0.206739458e-7, &
+        0.640689451e-10,-0.952447341e-13,-0.976195544e-15/
+      real dt
+
+! ICE
+
+      IF (TYPE.EQ.1) THEN
+
+!         POLYSVP = 10.**(-9.09718*(273.16/T-1.)-3.56654*                &
+!          LOG10(273.16/T)+0.876793*(1.-T/273.16)+						&
+!          LOG10(6.1071))*100.
+
+
+      dt = max(-80.,t-273.16)
+      polysvp = a0i + dt*(a1i+dt*(a2i+dt*(a3i+dt*(a4i+dt*(a5i+dt*(a6i+dt*(a7i+a8i*dt))))))) 
+      polysvp = polysvp*100.
+
+      END IF
+
+! LIQUID
+
+      IF (TYPE.EQ.0) THEN
+
+       dt = max(-80.,t-273.16)
+       polysvp = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt)))))))
+       polysvp = polysvp*100.
+
+!         POLYSVP = 10.**(-7.90298*(373.16/T-1.)+                        &
+!             5.02808*LOG10(373.16/T)-									&
+!             1.3816E-7*(10**(11.344*(1.-T/373.16))-1.)+				&
+!             8.1328E-3*(10**(-3.49149*(373.16/T-1.))-1.)+				&
+!             LOG10(1013.246))*100.
+
+         END IF
+
+
+      END FUNCTION POLYSVP
+
+!------------------------------------------------------------------------------
+
+      REAL FUNCTION GAMMA(X)
+!----------------------------------------------------------------------
+!
+! THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A REAL ARGUMENT X.
+!   COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCE 1.
+!   THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA
+!   FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS.  COEFFICIENTS
+!   FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED.
+!   THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM REFERENCE 2.
+!   THE ACCURACY ACHIEVED DEPENDS ON THE ARITHMETIC SYSTEM, THE
+!   COMPILER, THE INTRINSIC FUNCTIONS, AND PROPER SELECTION OF THE
+!   MACHINE-DEPENDENT CONSTANTS.
+!
+!
+!*******************************************************************
+!*******************************************************************
+!
+! EXPLANATION OF MACHINE-DEPENDENT CONSTANTS
+!
+! BETA   - RADIX FOR THE FLOATING-POINT REPRESENTATION
+! MAXEXP - THE SMALLEST POSITIVE POWER OF BETA THAT OVERFLOWS
+! XBIG   - THE LARGEST ARGUMENT FOR WHICH GAMMA(X) IS REPRESENTABLE
+!          IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION
+!                  GAMMA(XBIG) = BETA**MAXEXP
+! XINF   - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER;
+!          APPROXIMATELY BETA**MAXEXP
+! EPS    - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
+!          1.0+EPS .GT. 1.0
+! XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
+!          1/XMININ IS MACHINE REPRESENTABLE
+!
+!     APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE:
+!
+!                            BETA       MAXEXP        XBIG
+!
+! CRAY-1         (S.P.)        2         8191        966.961
+! CYBER 180/855
+!   UNDER NOS    (S.P.)        2         1070        177.803
+! IEEE (IBM/XT,
+!   SUN, ETC.)   (S.P.)        2          128        35.040
+! IEEE (IBM/XT,
+!   SUN, ETC.)   (D.P.)        2         1024        171.624
+! IBM 3033       (D.P.)       16           63        57.574
+! VAX D-FORMAT   (D.P.)        2          127        34.844
+! VAX G-FORMAT   (D.P.)        2         1023        171.489
+!
+!                            XINF         EPS        XMININ
+!
+! CRAY-1         (S.P.)   5.45E+2465   7.11E-15    1.84E-2466
+! CYBER 180/855
+!   UNDER NOS    (S.P.)   1.26E+322    3.55E-15    3.14E-294
+! IEEE (IBM/XT,
+!   SUN, ETC.)   (S.P.)   3.40E+38     1.19E-7     1.18E-38
+! IEEE (IBM/XT,
+!   SUN, ETC.)   (D.P.)   1.79D+308    2.22D-16    2.23D-308
+! IBM 3033       (D.P.)   7.23D+75     2.22D-16    1.39D-76
+! VAX D-FORMAT   (D.P.)   1.70D+38     1.39D-17    5.88D-39
+! VAX G-FORMAT   (D.P.)   8.98D+307    1.11D-16    1.12D-308
+!
+!*******************************************************************
+!*******************************************************************
+!
+! ERROR RETURNS
+!
+!  THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR
+!     WHEN OVERFLOW WOULD OCCUR.  THE COMPUTATION IS BELIEVED
+!     TO BE FREE OF UNDERFLOW AND OVERFLOW.
+!
+!
+!  INTRINSIC FUNCTIONS REQUIRED ARE:
+!
+!     INT, DBLE, EXP, LOG, REAL, SIN
+!
+!
+! REFERENCES:  AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL
+!              FUNCTIONS   W. J. CODY, LECTURE NOTES IN MATHEMATICS,
+!              506, NUMERICAL ANALYSIS DUNDEE, 1975, G. A. WATSON
+!              (ED.), SPRINGER VERLAG, BERLIN, 1976.
+!
+!              COMPUTER APPROXIMATIONS, HART, ET. AL., WILEY AND
+!              SONS, NEW YORK, 1968.
+!
+!  LATEST MODIFICATION: OCTOBER 12, 1989
+!
+!  AUTHORS: W. J. CODY AND L. STOLTZ
+!           APPLIED MATHEMATICS DIVISION
+!           ARGONNE NATIONAL LABORATORY
+!           ARGONNE, IL 60439
+!
+!----------------------------------------------------------------------
+      implicit none
+      INTEGER I,N
+      LOGICAL PARITY
+      REAL                                                          &
+          CONV,EPS,FACT,HALF,ONE,RES,SUM,TWELVE,                    &
+          TWO,X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
+      REAL, DIMENSION(7) :: C
+      REAL, DIMENSION(8) :: P
+      REAL, DIMENSION(8) :: Q
+!----------------------------------------------------------------------
+!  MATHEMATICAL CONSTANTS
+!----------------------------------------------------------------------
+      DATA ONE,HALF,TWELVE,TWO,ZERO/1.0E0,0.5E0,12.0E0,2.0E0,0.0E0/
+
+
+!----------------------------------------------------------------------
+!  MACHINE DEPENDENT PARAMETERS
+!----------------------------------------------------------------------
+      DATA XBIG,XMININ,EPS/35.040E0,1.18E-38,1.19E-7/,XINF/3.4E38/
+!----------------------------------------------------------------------
+!  NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX
+!     APPROXIMATION OVER (1,2).
+!----------------------------------------------------------------------
+      DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1,  &
+             -3.79804256470945635097577E+2,6.29331155312818442661052E+2,  &
+             8.66966202790413211295064E+2,-3.14512729688483675254357E+4,  &
+             -3.61444134186911729807069E+4,6.64561438202405440627855E+4/
+      DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2,  &
+             -1.01515636749021914166146E+3,-3.10777167157231109440444E+3, &
+              2.25381184209801510330112E+4,4.75584627752788110767815E+3,  &
+            -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/
+!----------------------------------------------------------------------
+!  COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF).
+!----------------------------------------------------------------------
+      DATA C/-1.910444077728E-03,8.4171387781295E-04,                      &
+           -5.952379913043012E-04,7.93650793500350248E-04,				   &
+           -2.777777777777681622553E-03,8.333333333333333331554247E-02,	   &
+            5.7083835261E-03/
+!----------------------------------------------------------------------
+!  STATEMENT FUNCTIONS FOR CONVERSION BETWEEN INTEGER AND FLOAT
+!----------------------------------------------------------------------
+      CONV(I) = REAL(I)
+      PARITY=.FALSE.
+      FACT=ONE
+      N=0
+      Y=X
+      IF(Y.LE.ZERO)THEN
+!----------------------------------------------------------------------
+!  ARGUMENT IS NEGATIVE
+!----------------------------------------------------------------------
+        Y=-X
+        Y1=AINT(Y)
+        RES=Y-Y1
+        IF(RES.NE.ZERO)THEN
+          IF(Y1.NE.AINT(Y1*HALF)*TWO)PARITY=.TRUE.
+          FACT=-PI/SIN(PI*RES)
+          Y=Y+ONE
+        ELSE
+          RES=XINF
+          GOTO 900
+        ENDIF
+      ENDIF
+!----------------------------------------------------------------------
+!  ARGUMENT IS POSITIVE
+!----------------------------------------------------------------------
+      IF(Y.LT.EPS)THEN
+!----------------------------------------------------------------------
+!  ARGUMENT .LT. EPS
+!----------------------------------------------------------------------
+        IF(Y.GE.XMININ)THEN
+          RES=ONE/Y
+        ELSE
+          RES=XINF
+          GOTO 900
+        ENDIF
+      ELSEIF(Y.LT.TWELVE)THEN
+        Y1=Y
+        IF(Y.LT.ONE)THEN
+!----------------------------------------------------------------------
+!  0.0 .LT. ARGUMENT .LT. 1.0
+!----------------------------------------------------------------------
+          Z=Y
+          Y=Y+ONE
+        ELSE
+!----------------------------------------------------------------------
+!  1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY
+!----------------------------------------------------------------------
+          N=INT(Y)-1
+          Y=Y-CONV(N)
+          Z=Y-ONE
+        ENDIF
+!----------------------------------------------------------------------
+!  EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0
+!----------------------------------------------------------------------
+        XNUM=ZERO
+        XDEN=ONE
+        DO I=1,8
+          XNUM=(XNUM+P(I))*Z
+          XDEN=XDEN*Z+Q(I)
+        END DO
+        RES=XNUM/XDEN+ONE
+        IF(Y1.LT.Y)THEN
+!----------------------------------------------------------------------
+!  ADJUST RESULT FOR CASE  0.0 .LT. ARGUMENT .LT. 1.0
+!----------------------------------------------------------------------
+          RES=RES/Y1
+        ELSEIF(Y1.GT.Y)THEN
+!----------------------------------------------------------------------
+!  ADJUST RESULT FOR CASE  2.0 .LT. ARGUMENT .LT. 12.0
+!----------------------------------------------------------------------
+          DO I=1,N
+            RES=RES*Y
+            Y=Y+ONE
+          END DO
+        ENDIF
+      ELSE
+!----------------------------------------------------------------------
+!  EVALUATE FOR ARGUMENT .GE. 12.0,
+!----------------------------------------------------------------------
+        IF(Y.LE.XBIG)THEN
+          YSQ=Y*Y
+          SUM=C(7)
+          DO I=1,6
+            SUM=SUM/YSQ+C(I)
+          END DO
+          SUM=SUM/Y-Y+SQRTPI
+          SUM=SUM+(Y-HALF)*LOG(Y)
+          RES=EXP(SUM)
+        ELSE
+          RES=XINF
+          GOTO 900
+        ENDIF
+      ENDIF
+!----------------------------------------------------------------------
+!  FINAL ADJUSTMENTS AND RETURN
+!----------------------------------------------------------------------
+      IF(PARITY)RES=-RES
+      IF(FACT.NE.ONE)RES=FACT/RES
+  900 GAMMA=RES
+      RETURN
+! ---------- LAST LINE OF GAMMA ----------
+      END FUNCTION GAMMA
+
+
+      REAL FUNCTION DERF1(X)
+      IMPLICIT NONE
+      REAL X
+      REAL, DIMENSION(0 : 64) :: A, B
+      REAL W,T,Y
+      INTEGER K,I
+      DATA A/                                                 &
+         0.00000000005958930743E0, -0.00000000113739022964E0, &
+         0.00000001466005199839E0, -0.00000016350354461960E0, &
+         0.00000164610044809620E0, -0.00001492559551950604E0, &
+         0.00012055331122299265E0, -0.00085483269811296660E0, &
+         0.00522397762482322257E0, -0.02686617064507733420E0, &
+         0.11283791670954881569E0, -0.37612638903183748117E0, &
+         1.12837916709551257377E0,	                          &
+         0.00000000002372510631E0, -0.00000000045493253732E0, &
+         0.00000000590362766598E0, -0.00000006642090827576E0, &
+         0.00000067595634268133E0, -0.00000621188515924000E0, &
+         0.00005103883009709690E0, -0.00037015410692956173E0, &
+         0.00233307631218880978E0, -0.01254988477182192210E0, &
+         0.05657061146827041994E0, -0.21379664776456006580E0, &
+         0.84270079294971486929E0,							  &
+         0.00000000000949905026E0, -0.00000000018310229805E0, &
+         0.00000000239463074000E0, -0.00000002721444369609E0, &
+         0.00000028045522331686E0, -0.00000261830022482897E0, &
+         0.00002195455056768781E0, -0.00016358986921372656E0, &
+         0.00107052153564110318E0, -0.00608284718113590151E0, &
+         0.02986978465246258244E0, -0.13055593046562267625E0, &
+         0.67493323603965504676E0, 							  &
+         0.00000000000382722073E0, -0.00000000007421598602E0, &
+         0.00000000097930574080E0, -0.00000001126008898854E0, &
+         0.00000011775134830784E0, -0.00000111992758382650E0, &
+         0.00000962023443095201E0, -0.00007404402135070773E0, &
+         0.00050689993654144881E0, -0.00307553051439272889E0, &
+         0.01668977892553165586E0, -0.08548534594781312114E0, &
+         0.56909076642393639985E0,							  &
+         0.00000000000155296588E0, -0.00000000003032205868E0, &
+         0.00000000040424830707E0, -0.00000000471135111493E0, &
+         0.00000005011915876293E0, -0.00000048722516178974E0, &
+         0.00000430683284629395E0, -0.00003445026145385764E0, &
+         0.00024879276133931664E0, -0.00162940941748079288E0, &
+         0.00988786373932350462E0, -0.05962426839442303805E0, &
+         0.49766113250947636708E0 /
+      DATA (B(I), I = 0, 12) /                                  &
+         -0.00000000029734388465E0,  0.00000000269776334046E0, 	&
+         -0.00000000640788827665E0, -0.00000001667820132100E0,  &
+         -0.00000021854388148686E0,  0.00000266246030457984E0, 	&
+          0.00001612722157047886E0, -0.00025616361025506629E0, 	&
+          0.00015380842432375365E0,  0.00815533022524927908E0, 	&
+         -0.01402283663896319337E0, -0.19746892495383021487E0,  &
+          0.71511720328842845913E0 /
+      DATA (B(I), I = 13, 25) /                                 &
+         -0.00000000001951073787E0, -0.00000000032302692214E0,  &
+          0.00000000522461866919E0,  0.00000000342940918551E0, 	&
+         -0.00000035772874310272E0,  0.00000019999935792654E0, 	&
+          0.00002687044575042908E0, -0.00011843240273775776E0, 	&
+         -0.00080991728956032271E0,  0.00661062970502241174E0, 	&
+          0.00909530922354827295E0, -0.20160072778491013140E0, 	&
+          0.51169696718727644908E0 /
+      DATA (B(I), I = 26, 38) /                                 &
+         0.00000000003147682272E0, -0.00000000048465972408E0,   &
+         0.00000000063675740242E0,  0.00000003377623323271E0, 	&
+        -0.00000015451139637086E0, -0.00000203340624738438E0, 	&
+         0.00001947204525295057E0,  0.00002854147231653228E0, 	&
+        -0.00101565063152200272E0,  0.00271187003520095655E0, 	&
+         0.02328095035422810727E0, -0.16725021123116877197E0, 	&
+         0.32490054966649436974E0 /
+      DATA (B(I), I = 39, 51) /                                 &
+         0.00000000002319363370E0, -0.00000000006303206648E0,   &
+        -0.00000000264888267434E0,  0.00000002050708040581E0, 	&
+         0.00000011371857327578E0, -0.00000211211337219663E0, 	&
+         0.00000368797328322935E0,  0.00009823686253424796E0, 	&
+        -0.00065860243990455368E0, -0.00075285814895230877E0, 	&
+         0.02585434424202960464E0, -0.11637092784486193258E0, 	&
+         0.18267336775296612024E0 /
+      DATA (B(I), I = 52, 64) /                                 &
+        -0.00000000000367789363E0,  0.00000000020876046746E0, 	&
+        -0.00000000193319027226E0, -0.00000000435953392472E0, 	&
+         0.00000018006992266137E0, -0.00000078441223763969E0, 	&
+        -0.00000675407647949153E0,  0.00008428418334440096E0, 	&
+        -0.00017604388937031815E0, -0.00239729611435071610E0, 	&
+         0.02064129023876022970E0, -0.06905562880005864105E0,   &
+         0.09084526782065478489E0 /
+      W = ABS(X)
+      IF (W .LT. 2.2D0) THEN
+          T = W * W
+          K = INT(T)
+          T = T - K
+          K = K * 13
+          Y = ((((((((((((A(K) * T + A(K + 1)) * T +              &
+              A(K + 2)) * T + A(K + 3)) * T + A(K + 4)) * T +     &
+              A(K + 5)) * T + A(K + 6)) * T + A(K + 7)) * T +     &
+              A(K + 8)) * T + A(K + 9)) * T + A(K + 10)) * T + 	  &
+              A(K + 11)) * T + A(K + 12)) * W
+      ELSE IF (W .LT. 6.9D0) THEN
+          K = INT(W)
+          T = W - K
+          K = 13 * (K - 2)
+          Y = (((((((((((B(K) * T + B(K + 1)) * T +               &
+              B(K + 2)) * T + B(K + 3)) * T + B(K + 4)) * T + 	  &
+              B(K + 5)) * T + B(K + 6)) * T + B(K + 7)) * T + 	  &
+              B(K + 8)) * T + B(K + 9)) * T + B(K + 10)) * T + 	  &
+              B(K + 11)) * T + B(K + 12)
+          Y = Y * Y
+          Y = Y * Y
+          Y = Y * Y
+          Y = 1 - Y * Y
+      ELSE
+          Y = 1
+      END IF
+      IF (X .LT. 0) Y = -Y
+      DERF1 = Y
+      END FUNCTION DERF1
+
+!+---+-----------------------------------------------------------------+
+
+END MODULE module_mp_morr_two_moment
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_sbu_ylin.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_sbu_ylin.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_sbu_ylin.F	(revision 17)
@@ -0,0 +1,1752 @@
+!WRF:MODEL_LAYER:PHYSICS
+
+!--- The code is based on Lin and Colle (A New Bulk Microphysical Scheme 
+!             that Includes Riming Intensity and Temperature Dependent Ice Characteristics, 2011, MWR)
+!             and Lin et al. (Parameterization of riming intensity and its impact on ice fall speed using ARM data, 2011, MWR)
+!--- NOTE: 1) Prognose variables are: qi,PI(precipitating ice, qs, which includes snow, partially rimed snow and graupel),qw,qr
+!---       2) Sedimentation flux is based on Prudue Lin scheme 
+!---       2) PI has varying properties depending on riming intensity (Ri, diagnosed currently following Lin et al. (2011, MWR) and T 
+!---       3) Autoconverion is based on Liu and Daum (2004)         
+!---       4) PI size distribution assuming Gamma distribution, but mu_s=0 (Exponential) currently
+!---       5) No density dependent fall speed since the V-D is derived using Best number approach, which already includes density effect 
+!---       6) Future work will include radar equivalent reflectivity using the new PI property (A-D, M-D, N(D)). If you use RIP for reflectivity 
+!---          computation, please note that snow is (1-Ri)*qs and graupel is Ri*qs. Otherwise, reflectivity will be underestimated.      
+!---       7) The Liu and Daum autoconverion is quite sensitive on Nt_c. For mixed-phase cloud and marine environment, Nt_c of 10 or 20 is suggested.
+!---          default value is 10E.6. Change accordingly for your use.
+!---       8)   Eq.7 and 8 are not in SI units and need to be converted in the code. the
+!              paper treats the units in Eq.7 and 8 as cgs,  and so need 1e-2^(2-ba) in
+!              the code, and that would give the plots in the paper. However, there is
+!              large uncertainty with this parameter, and one could argue that the units
+!              for these equations could be mm-g-s instead, which would mean 1e-3^(2-ba)
+!              in the code. This increases the snow fallspeed and gives an even
+!              better comparison of aa and ba with obs in paper.
+
+
+      MODULE module_mp_sbu_ylin
+      USE    module_wrf_error
+!
+!..Parameters user might change based on their need
+      REAL, PARAMETER, PRIVATE :: RH = 1.0
+      REAL, PARAMETER, PRIVATE :: xnor = 8.0e6
+      REAL, PARAMETER, PRIVATE :: Nt_c = 10.E6
+!..Water vapor and air gas constants at constant pressure
+      REAL, PARAMETER, PRIVATE :: Rvapor = 461.5
+      REAL, PARAMETER, PRIVATE :: oRv    = 1./Rvapor
+      REAL, PARAMETER, PRIVATE :: Rair   = 287.04
+      REAL, PARAMETER, PRIVATE :: Cp     = 1004.0
+      REAL, PARAMETER, PRIVATE :: grav   = 9.81
+      REAL, PARAMETER, PRIVATE :: rhowater = 1000.0
+      REAL, PARAMETER, PRIVATE :: rhosnow  = 100.0
+
+      REAL, PARAMETER, PRIVATE :: SVP1=0.6112
+      REAL, PARAMETER, PRIVATE :: SVP2=17.67
+      REAL, PARAMETER, PRIVATE :: SVP3=29.65
+      REAL, PARAMETER, PRIVATE :: SVPT0=273.15
+      REAL, PARAMETER, PRIVATE :: EP1=Rvapor/Rair-1.
+      REAL, PARAMETER, PRIVATE :: EP2=Rair/Rvapor
+!..Enthalpy of sublimation, vaporization, and fusion at 0C.
+      REAL, PARAMETER, PRIVATE :: XLS = 2.834E6
+      REAL, PARAMETER, PRIVATE :: XLV = 2.5E6
+      REAL, PARAMETER, PRIVATE :: XLF = XLS - XLV
+
+!
+      REAL, PARAMETER, PRIVATE ::                           &
+             qi0 = 1.0e-3,                                  &   !--- ice aggregation to snow threshold
+             xmi50 = 4.8e-10, xmi40 = 2.46e-10,             &
+             xni0 = 1.0e-2, xmnin = 1.05e-18, bni = 0.5,    &
+             di50 = 1.0e-4, xmi = 4.19e-13,                 &   !--- parameters used in BF process
+             bv_r = 0.8, bv_i = 0.25,                       &
+             o6 = 1./6.,  cdrag = 0.6,                      &
+             avisc = 1.49628e-6, adiffwv = 8.7602e-5,       &
+             axka = 1.4132e3, cw = 4.187e3,  ci = 2.093e3
+CONTAINS
+
+!-------------------------------------------------------------------
+!  Lin et al., 1983, JAM, 1065-1092, and
+!  Rutledge and Hobbs, 1984, JAS, 2949-2972
+!-------------------------------------------------------------------
+      SUBROUTINE sbu_ylin(th                                       &
+                      ,qv, ql, qr                                  &
+                      ,qi, qs, Ri3D                                &
+                      ,rho, pii, p                                 &
+                      ,dt_in                                       &
+                      ,z,ht, dz8w                                  &
+                      ,RAINNC, 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
+
+     REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+        INTENT(INOUT) ::                                          &
+                                                              th, &
+                                                              qv, &
+                                                           qi,ql, &
+                                                           qs,qr
+
+! YLIN
+! Adding RI3D as a variable to the interface
+     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                &
+        INTENT(INOUT) :: Ri3D
+
+
+!
+     REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+        INTENT(IN   ) ::                                          &
+                                                             rho, &
+                                                             pii, &
+                                                             z,p, &
+                                                            dz8w
+
+
+     REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) ::       ht
+     REAL, INTENT(IN   ) ::                                   dt_in  
+
+     REAL, DIMENSION( ims:ime , jms:jme ),                           &
+        INTENT(INOUT) ::                                  RAINNC, &
+                                                          RAINNCV
+
+! LOCAL VAR
+
+     INTEGER             ::                            min_q, max_q
+
+     REAL, DIMENSION( its:ite , jts:jte )                            &
+                               ::        rain, snow,ice
+
+     REAL, DIMENSION( kts:kte )   ::                  qvz, qlz, qrz, &
+                                                      qiz, qsz, qgz, &
+                                                                thz, &
+                                                        tothz, rhoz, &
+                                                      orhoz, sqrhoz, &
+                                                           prez, zz, &
+                                                        dzw
+
+! Added vertical profile of Ri (riz) as a variable
+     REAL, DIMENSION( kts:kte ) :: riz
+
+!
+     REAL    ::         dt, pptice, pptrain, pptsnow, pptgraul, rhoe_s
+
+     INTEGER ::               i,j,k
+
+      dt=dt_in
+      rhoe_s=1.29
+  
+      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)
+       qiz(k)=qi(i,k,j)
+       qsz(k)=qs(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))
+! no density dependence of fall speed as Note #5, you can turn it on to increase fall speed at low pressure.
+       sqrhoz(k)=1.0
+       tothz(k)=pii(i,k,j)
+       zz(k)=z(i,k,j)
+       dzw(k)=dz8w(i,k,j)
+      END DO
+!
+      pptrain=0.
+      pptsnow=0.
+      pptice =0.
+
+!     CALL wrf_debug ( 100 , 'microphysics_driver: calling clphy1d_ylin' )
+
+     CALL clphy1d_ylin(  dt, qvz, qlz, qrz, qiz, qsz,              &
+                         thz, tothz, rhoz, orhoz, sqrhoz,          &
+                         prez, zz, dzw, ht(I,J),                   &
+                         pptrain, pptsnow, pptice,                 &
+                         kts, kte, i, j, riz                       )
+
+!
+! Precipitation from cloud microphysics -- only for one time step
+!
+! unit is transferred from m to mm
+!
+      rain(i,j)= pptrain
+      snow(i,j)= pptsnow
+      ice(i,j) = pptice
+!
+      RAINNCV(i,j)= pptrain + pptsnow + pptice
+      RAINNC(i,j) = RAINNC(i,j) + pptrain + pptsnow + pptice
+
+!
+!- update data from 1-D back to 3-D
+!
+      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)
+       qi(i,k,j)=qiz(k)
+       qs(i,k,j)=qsz(k)
+       ri3d(i,k,j)=riz(k)
+      END DO
+!
+      ENDDO i_loop
+      ENDDO j_loop
+
+      END SUBROUTINE sbu_ylin
+
+
+!-----------------------------------------------------------------------
+      SUBROUTINE clphy1d_ylin(dt, qvz, qlz, qrz, qiz, qsz,             &
+                      thz, tothz, rho, orho, sqrho,                    &
+                      prez, zz, dzw, zsfc, pptrain, pptsnow,pptice,    &
+                      kts, kte, i, j,riz                               )
+!-----------------------------------------------------------------------
+      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)
+
+! av_r: av_r in empirical formular for terminal
+!         velocity of raindrop
+!         =2115.0 [cm**(1-b)/s] = 2115.0*0.01**(1-b) [m**(1-b)/s]
+! bv_r: bv_r in empirical formular for terminal
+!         velocity of raindrop
+!         =0.8
+! av_i: av_i in empirical formular for terminal
+!         velocity of snow
+!         =152.93 [cm**(1-d)/s] = 152.93*0.01**(1-d) [m**(1-d)/s]
+! bv_i: bv_i in empirical formular for terminal
+!         velocity of snow
+!         =0.25
+! vf1r: ventilation factors for rain =0.78
+! vf2r: ventilation factors for rain =0.31
+! vf1s: ventilation factors for snow =0.65
+! vf2s: ventilation factors for snow =0.44
+!
+!----------------------------------------------------------------------
+
+     INTEGER, INTENT(IN   )               :: kts, kte, i, j
+
+     REAL,    DIMENSION( kts:kte ),                                   &
+           INTENT(INOUT)               :: qvz, qlz, qrz, qiz, qsz,    &
+                                          thz
+
+     REAL,    DIMENSION( kts:kte ),                                   &
+           INTENT(IN   )               :: tothz, rho, orho, sqrho,    &
+                                          prez, zz, dzw
+
+
+     REAL,    INTENT(INOUT)               :: pptrain, pptsnow, pptice
+
+     REAL,    INTENT(IN   )               :: dt, zsfc
+
+! local vars
+
+     REAL                                :: obp4, bp3, bp5, bp6, odp4,  &
+                                            dp3, dp5, dp5o2
+
+! temperary vars
+
+     REAL                              :: tmp, tmp0, tmp1, tmp2,tmp3,  &
+                                          tmp4, tmpa,tmpb,tmpc,tmpd,alpha1,  &
+                                          qic, abi,abr, abg, odtberg,  &
+                                          vti50,eiw,eri,esi,esr, esw,  &
+                                          erw,delrs,term0,term1,       &
+                                          Ap, Bp,                      &
+                                          factor, tmp_r, tmp_s,tmp_g,  &
+                                          qlpqi, rsat, a1, a2, xnin
+
+!
+     REAL, DIMENSION( kts:kte )    ::  oprez, tem, temcc, theiz, qswz,    &
+                                       qsiz, qvoqswz, qvoqsiz, qvzodt,    &
+                                       qlzodt, qizodt, qszodt, qrzodt
+
+!--- microphysical processes
+
+     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, pgfr,                 &
+                                      qschg
+!
+
+     REAL, DIMENSION( kts:kte )    :: qvsbar, rs0, viscmu, visc, diffwv,  &
+                                      schmidt, xka
+!---- new snow parameters
+
+     REAL, DIMENSION( kts:kte ):: ab_s,ab_r,ab_riming,lamc 
+     REAL, DIMENSION( kts:kte ):: cap_s       !---- capacitance of snow
+ 
+     REAL, PARAMETER :: vf1s = 0.65, vf2s = 0.44, vf1r =0.78 , vf2r = 0.31 
+
+     REAL, PARAMETER :: am_c1=0.004, am_c2= 6e-5,    am_c3=0.15
+     REAL, PARAMETER :: bm_c1=1.85,  bm_c2= 0.003,   bm_c3=1.25
+     REAL, PARAMETER :: aa_c1=1.28,  aa_c2= -0.012,  aa_c3=-0.6
+     REAL, PARAMETER :: ba_c1=1.5,   ba_c2= 0.0075,  ba_c3=0.5
+
+     REAL, PARAMETER :: best_a=1.08 ,  best_b = 0.499
+     REAL, DIMENSION(kts:kte):: am_s,bm_s,av_s,bv_s,Ri,N0_s,tmp_ss,lams  
+     REAL, DIMENSION(kts:kte):: aa_s,ba_s,tmp_sa  
+     REAL, PARAMETER :: mu_s=0.,mu_i=0.,mu_r=0.
+
+     REAL :: tc0, disp, Dc_liu, eta, mu_c, R6c      !--- for Liu's autoconversion
+
+! Adding variable Riz, which will duplicate Ri but be a copy passed upward
+
+     REAL, DIMENSION(kts:kte) :: Riz
+
+     REAL, DIMENSION( kts:kte )    :: vtr, vts,                   &
+                                      vtrold, vtsold, vtiold,     &
+                                      xlambdar, xlambdas,            &
+                                      olambdar, olambdas
+
+     REAL                          :: episp0k, dtb, odtb, pi, pio4,       &
+                                      pio6, oxLf, xLvocp, xLfocp, av_r,   &
+                                      av_i, ocdrag, gambp4, gamdp4,       &
+                                      gam4pt5, Cpor, oxmi, gambp3, gamdp3,&
+                                      gambp6, gam3pt5, gam2pt75, gambp5o2,&
+                                      gamdp5o2, cwoxlf, ocp, xni50, es
+!
+     REAL                          :: qvmin=1.e-20
+     REAL                          :: temc1,save1,save2,xni50mx
+
+! for terminal velocity flux
+
+     INTEGER                       :: min_q, max_q, max_ri_k, k
+     REAL                          :: max_ri
+     REAL                          :: t_del_tv, del_tv, flux, fluxin, fluxout ,tmpqrz
+     LOGICAL                       :: notlast
+!
+      mu_c = AMIN1(15., (1000.E6/Nt_c + 2.))
+      R6c  = 10.0E-6      !---- 10 micron, threshold radius of cloud droplet
+      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
+      Cpor=cp/Rair
+      oxmi=1.0/xmi
+      cwoxlf=cw/xlf 
+      av_r=2115.0*0.01**(1-bv_r)
+      av_i=152.93*0.01**(1-bv_i)
+      ocdrag=1./Cdrag
+      episp0k=RH*ep2*1000.*svp1
+!
+      gambp4=ggamma(bv_r+4.)
+      gamdp4=ggamma(bv_i+4.)
+      gambp3=ggamma(bv_r+3.)
+      gambp6=ggamma(bv_r+6)
+      gambp5o2=ggamma((bv_r+5.)/2.)
+      gamdp5o2=ggamma((bv_i+5.)/2.)
+!
+!     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  = 611.2 hPa (Rogers and Yau 1989)
+!     qvoqsw      qv/qsw
+!     qvoqsi      qv/qsi
+!     qvzodt      qv/dt
+!     qlzodt      ql/dt
+!     qizodt      qi/dt
+!     qszodt      qs/dt
+!     qrzodt      qr/dt
+!     temcc       temperature in dregee C
+!
+
+      obp4=1.0/(bv_r+4.0)
+      bp3=bv_r+3.0
+      bp5=bv_r+5.0
+      bp6=bv_r+6.0
+      odp4=1.0/(bv_i+4.0)
+      dp3=bv_i+3.0
+      dp5=bv_i+5.0
+      dp5o2=0.5*(bv_i+5.0)
+!
+      do k=kts,kte
+         oprez(k)=1./prez(k)
+         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) )
+         tem(k)=thz(k)*tothz(k)
+         temcc(k)=tem(k)-273.15
+         es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) )  !--- RY89 Eq(2.17)
+         qswz(k)=ep2*es/(prez(k)-es)
+         if (tem(k) .lt. 273.15 ) then
+            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) )
+         theiz(k)=thz(k)+(xlvocp*qvz(k)-xlfocp*qiz(k))/tothz(k)
+      enddo
+
+      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
+         pgfr(k)=0.0
+
+         pvapor(k)=0.0
+
+         pclw(k)=0.0
+         pladj(k)=0.0
+
+         pcli(k)=0.0
+         pimlt(k)=0.0
+         pihom(k)=0.0
+         pidw(k)=0.0
+         piadj(k)=0.0
+
+         qschg(k)=0.
+
+      enddo
+
+!***********************************************************************
+!*****  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------------------------------------------------------------------
+      DO k=kts,kte
+        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)
+        rs0(k)=ep2*1000.*svp1/(prez(k)-1000.*svp1)
+      END DO
+!
+! ---- YLIN, set snow variables
+!
+!---- A+B in depositional growth, the first try just take from Rogers and Yau(1989)
+!         ab_s(k) = lsub*lsub*orv/(tcond(k)*temp(k))+&
+!                   rv*temp(k)/(diffu(k)*qvsi(k))
+
+       do k = kts, kte
+         tc0   = tem(k)-273.15       
+        if (rho(k)*qlz(k) .gt. 1e-5 .AND. rho(k)*qsz(k) .gt. 1e-5) then 
+         Ri(k) = 1.0/(1.0+6e-5/(rho(k)**1.170*qlz(k)*qsz(k)**0.170))
+        else
+         Ri(k) = 0
+        endif
+       enddo
+!
+!--- make sure Ri does not decrease downward in a column
+!
+       max_ri_k = MAXLOC(Ri,dim=1)
+       max_ri   = MAXVAL(Ri)
+
+       do k = kts, max_ri_k
+         Ri(k) = max_ri
+       enddo
+
+!--- YLIN, get PI properties
+      do k = kts, kte
+         Ri(k) = AMAX1(0.,AMIN1(Ri(k),1.0))      
+! Store the value of Ri(k) as Riz(k)
+         Riz(k) = Ri(k)
+
+         cap_s(k)= 0.25*(1+Ri(k))
+         tc0     = AMIN1(-0.1, tem(k)-273.15)          
+         N0_s(k) = amin1(2.0E8, 2.0E6*exp(-0.12*tc0))          
+         am_s(k) = am_c1+am_c2*tc0+am_c3*Ri(k)*Ri(k)   !--- Heymsfield 2007
+         am_s(k) = AMAX1(0.000023,am_s(k))             !--- use the a_min in table 1 of Heymsfield
+         bm_s(k) = bm_c1+bm_c2*tc0+bm_c3*Ri(k)
+         bm_s(k) = AMIN1(bm_s(k),3.0)                  !---- capped by 3
+!---  converting from cgs to SI unit
+         am_s(k) =  10**(2*bm_s(k)-3.0)*am_s(k)
+         aa_s(k) = aa_c1 + aa_c2*tc0 + aa_c3*Ri(k)
+         ba_s(k) = ba_c1 + ba_c2*tc0 + ba_c3*Ri(k)
+!---  convert from mm.g.s to SI unit (this will give larger PI fall speed than in the paper)
+         aa_s(k) = (1e-3)**(2.0-ba_s(k))*aa_s(k)
+!---- get v from Mitchell 1996
+         av_s(k) = best_a*viscmu(k)*(2*grav*am_s(k)/rho(k)/aa_s(k)/(viscmu(k)**2))**best_b
+         bv_s(k) = best_b*(bm_s(k)-ba_s(k)+2)-1
+        
+         tmp_ss(k)= bm_s(k)+mu_s+1
+         tmp_sa(k)= ba_s(k)+mu_s+1
+
+      enddo 
+
+!
+!***********************************************************************
+! 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
+!
+!       CALL wrf_debug ( 100 , 'module_ylin, start precip fluxes' )
+
+      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*av_r*gambp4*sqrho(k)/tmp1**bv_r
+            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= (am_s(k)*N0_s(k)*ggamma(tmp_ss(k))*orho(k)/qsz(k))&
+                   **(1./tmp_ss(k))
+
+            vtsold(k)= sqrho(k)*av_s(k)*ggamma(bv_s(k)+tmp_ss(k))/ &
+                      ggamma(tmp_ss(k))/(tmp1**bv_s(k))
+
+            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
+
+!
+!-- cloud ice  (03/21/02) using Heymsfield and Donner (1990) Vi=3.29*qi^0.16
+!
+      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
+
+!     CALL wrf_debug ( 100 , 'module_ylin: end precip flux' )
+
+! Microphpysics processes
+
+      DO 2000 k=kts,kte
+!
+         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) )
+
+!***********************************************************************
+!*****   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
+!!  then
+!!     skip these processes and jump to line 2000
+!
+!
+        tmp=qiz(k)+qlz(k)+qsz(k)+qrz(k)
+        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*av_r*gambp4*sqrho(k)*olambdar(k)**bv_r
+        else
+            vtrold(k)=0.
+            olambdar(k)=0.
+        endif
+!
+        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*av_r*gambp4*sqrho(k)*olambdar(k)**bv_r
+        else
+            vtr(k)=0.
+            olambdar(k)=0.
+        endif
+!
+!! calculate terminal velocity of snow
+!
+        if (qsz(k) .gt. 1.0e-8) then
+            tmp1= (am_s(k)*N0_s(k)*ggamma(tmp_ss(k))*orho(k)/qsz(k))&
+                   **(1./tmp_ss(k))
+            olambdas(k)=1.0/tmp1
+            vtsold(k)= sqrho(k)*av_s(k)*ggamma(bv_s(k)+tmp_ss(k))/ &
+                      ggamma(tmp_ss(k))/(tmp1**bv_s(k))
+
+        else
+            vtsold(k)=0.
+            olambdas(k)=0.
+        endif
+!
+        if (qsz(k) .gt. 1.0e-8) then
+             tmp1= (am_s(k)*N0_s(k)*ggamma(tmp_ss(k))*orho(k)/qsz(k))&
+                   **(1./tmp_ss(k))
+             olambdas(k)=1.0/tmp1
+             vts(k)= sqrho(k)*av_s(k)*ggamma(bv_s(k)+tmp_ss(k))/ &
+                      ggamma(tmp_ss(k))/(tmp1**bv_s(k))
+
+        else
+            vts(k)=0.
+            olambdas(k)=0.
+        endif
+
+!---------- start of snow/ice processes below freezing
+
+        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) )
+!
+           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
+
+           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!
+
+          if( qlz(k) .gt. 1.0e-10 ) then
+            temc1=amax1(-30.99,temcc(k))
+            a1=parama1( temc1 )
+            a2=parama2( temc1 )
+            tmp1=1.0-a2
+!!   change unit from cgs to mks
+            a1=a1*0.001**tmp1
+!!   dtberg is the time needed for a crystal to grow from 40 to 50 um
+!!   odtberg=1.0/dtberg
+            odtberg=(a1*tmp1)/(xmi50**tmp1-xmi40**tmp1)
+!
+!!   compute terminal velocity of a 50 micron ice cystal
+!
+            vti50=av_i*di50**bv_i*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) )
+!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))
+          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     produce PI
+!c
+          eri=1.0
+          save1=pio4*eri*xnor*av_r*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
+          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 = aa_s(k)*sqrho(k)*N0_s(k)* &
+                  ggamma(bv_s(k)+tmp_sa(k))*olambdas(k)**(bv_s(k)+tmp_sa(k))
+
+          tmp1=esi*save1
+          psaci(k)=qizodt(k)*( 1.0-exp(-tmp1*dtb) )
+
+!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) )
+
+!c
+!c (8) DEPOSITION/SUBLIMATION OF SNOW (Psdep/Pssub): Lin (31)
+!c     includes consideration of ventilation effect
+!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=4.0*pi*cap_s(k)*(qvoqsiz(k)-1.0)*tmpc/(tmpa+tmpb)
+          tmp1=av_s(k)*sqrho(k)*olambdas(k)**(5+bv_s(k)+2*mu_s)/visc(k)
+
+!---- YLIN, here there is some approximation assuming mu_s =1, so gamma(2)=1, etc.
+
+          tmp2= abi*N0_s(k)*( vf1s*olambdas(k)*olambdas(k)+ &
+                vf2s*schmidt(k)**0.33334* &
+                ggamma(2.5+0.5*bv_s(k)+mu_s)*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
+
+!
+          if(qrz(k) .le. 0.0) go to 1200
+!
+! Compute processes (9) and (10) only when qsz > 0.0 and qrz > 0.0
+! these two terms need to be refined in the future, they should be equal
+!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*N0_s(k)*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) )
+          pracs(k)=0.0
+!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) )
+!
+!c
+!c (2) FREEZING OF RAIN TO FORM GRAUPEL  (pgfr): Lin (45), added to PI
+!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
+
+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
+
+            save1 =aa_s(k)*sqrho(k)*N0_s(k)* &
+                   ggamma(bv_s(k)+tmp_sa(k))*olambdas(k)**(bv_s(k)+tmp_sa(k))
+
+            tmp1=esw*save1
+            psacw(k)=qlzodt(k)*( 1.0-exp(-tmp1*dtb) )
+
+!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*N0_s(k)*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= av_s(k)*sqrho(k)*olambdas(k)**(5+bv_s(k)+2*mu_s)/visc(k)
+            tmp2= N0_s(k)*( vf1s*olambdas(k)*olambdas(k)+ &
+                  vf2s*schmidt(k)**0.33334* &
+                  ggamma(2.5+0.5*bv_s(k)+mu_s)*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)-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.
+!
+            tmp1=av_s(k)*sqrho(k)*olambdas(k)**(5+bv_s(k)+2*mu_s)/visc(k)
+            tmp2= N0_s(k)*( vf1s*olambdas(k)*olambdas(k)+ &
+                  vf2s*schmidt(k)**0.33334* &
+                  ggamma(2.5+0.5*bv_s(k)+mu_s)*sqrt(tmp1) )
+            tmp3=amin1(0.0,tmp2)
+            tmp3=amax1( tmp3,tmpd )
+            psmltevp(k)=amax1( tmp3,-qszodt(k) )
+1400     continue
+!
+        end if      !---- end of snow/ice processes
+
+!         CALL wrf_debug ( 100 , 'module_ylin: finish ice/snow processes' )
+
+
+!***********************************************************************
+!*********           rain production processes                **********
+!***********************************************************************
+
+!c
+!c (1) AUTOCONVERSION OF RAIN (Praut): using Liu and Daum (2004)
+!c
+
+!---- YLIN, autoconversion use Liu and Daum (2004), unit = g cm-3 s-1, in the scheme kg/kg s-1, so
+
+       if (qlz(k) .gt. 1e-6) then
+           lamc(k) = (Nt_c*rhowater*pi*ggamma(4.+mu_c)/(6.*rho(k)*qlz(k))/ &        !--- N(D) = N0*D^mu*exp(-lamc*D)
+                    ggamma(1+mu_c))**0.3333
+           Dc_liu  = (ggamma(6+1+mu_c)/ggamma(1+mu_c))**(1./6.)/lamc(k)             !----- R6 in m
+
+           if (Dc_liu .gt. R6c) then
+             disp = 1./(mu_c+1.)      !--- square of relative dispersion
+             eta  = (0.75/pi/(1e-3*rhowater))**2*1.9e11*((1+3*disp)*(1+4*disp)*&
+                   (1+5*disp)/(1+disp)/(1+2*disp))
+             praut(k) = eta*(1e-3*rho(k)*qlz(k))**3/(1e-6*Nt_c)                      !--- g cm-3 s-1
+             praut(k) = praut(k)/(1e-3*rho(k))                                       !--- kg kg-1 s-1
+           else
+            praut(k) = 0.0
+           endif
+       else
+         praut(k) = 0.0
+       endif 
+
+!c
+!c (2) ACCRETION OF CLOUD WATER BY RAIN (Pracw): Lin (51)
+!c
+        erw=1.0
+
+        tmp1=pio4*erw*xnor*av_r*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)-0.90)*tmpc/(tmpa+tmpb)
+         tmp1=av_r*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) )
+
+!        CALL wrf_debug ( 100 , 'module_ylin: finish rain processes' )
+
+!c
+!c**********************************************************************
+!c*****     combine all processes together and avoid negative      *****
+!c*****     water substances
+!***********************************************************************
+!c
+      if ( temcc(k) .lt. 0.0) then
+!c
+!c  combined water vapor depletions
+!c
+           tmp=psdep(k)
+           if ( tmp .gt. qvzodt(k) ) then
+              factor=qvzodt(k)/tmp
+              psdep(k)=psdep(k)*factor
+           end if
+!c
+!c  combined cloud water depletions
+!c
+           tmp=praut(k)+psacw(k)+psfw(k)+pracw(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
+           end if
+!c
+!c  combined cloud ice depletions
+!c
+           tmp=psaut(k)+psaci(k)+praci(k)+psfi(k)
+           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
+           endif
+!c
+!c  combined all rain processes
+!c
+          tmp_r=piacr(k)+psacr(k)-prevp(k)-praut(k)-pracw(k)+pgfr(k) 
+          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
+             pgfr(k)=pgfr(k)*factor
+          endif
+!c
+!c   combined all snow processes
+!c
+          tmp_s=-pssub(k)-(psaut(k)+psaci(k)+psacw(k)+psfw(k)+pgfr(k)+ &
+                 psfi(k)+praci(k)+piacr(k)+ &
+                 psdep(k)+psacr(k)-pracs(k))
+          if ( tmp_s .gt. qszodt(k) ) then
+             factor=qszodt(k)/tmp_s
+             pssub(k)=pssub(k)*factor
+             Pracs(k)=Pracs(k)*factor
+          endif
+
+!c
+!c  calculate new water substances, thetae, tem, and qvsbar
+!c
+
+         pvapor(k)=-pssub(k)-psdep(k)-prevp(k)
+         qvz(k)=amax1( qvmin,qvz(k)+dtb*pvapor(k) )
+         pclw(k)=-praut(k)-pracw(k)-psacw(k)-psfw(k)
+         qlz(k)=amax1( 0.0,qlz(k)+dtb*pclw(k) )
+         pcli(k)=-psaut(k)-psfi(k)-psaci(k)-praci(k)
+         qiz(k)=amax1( 0.0,qiz(k)+dtb*pcli(k) )
+         tmp_r=piacr(k)+psacr(k)-prevp(k)-praut(k)-pracw(k)+pgfr(k)-pracs(k) 
+         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)+pgfr(k)+  &
+                psfi(k)+praci(k)+piacr(k)+  &
+                psdep(k)+psacr(k)-pracs(k))
+         psnow(k)=-tmp_s
+         qsz(k)=amax1( 0.0,qsz(k)+dtb*psnow(k) )
+
+         qschg(k)=qschg(k)+psnow(k)
+         qschg(k)=psnow(k)
+
+         tmp=ocp/tothz(k)*xLf*qschg(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                  !>0 C
+!c
+!c  combined cloud water depletions
+!c
+          tmp=praut(k)+psacw(k)+pracw(k)
+          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
+          end if
+!c
+!c  combined all snow processes
+!c
+          tmp_s=-(psmlt(k)+psmltevp(k))
+          if (tmp_s .gt. qszodt(k) ) then
+             factor=qszodt(k)/tmp_s
+             psmlt(k)=psmlt(k)*factor
+             psmltevp(k)=psmltevp(k)*factor
+          endif
+!c
+!c  combined all rain processes
+!c
+          tmp_r=-prevp(k)-(praut(k)+pracw(k)+psacw(k)-psmlt(k)) 
+          if (tmp_r .gt. qrzodt(k) ) then
+             factor=qrzodt(k)/tmp_r
+             prevp(k)=prevp(k)*factor
+          endif
+!c
+!c  calculate new water substances and thetae
+!c
+          pvapor(k)=-psmltevp(k)-prevp(k)
+          qvz(k)=amax1( qvmin,qvz(k)+dtb*pvapor(k))
+          pclw(k)=-praut(k)-pracw(k)-psacw(k)
+          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)) 
+          prain(k)=-tmp_r
+          tmpqrz=qrz(k)
+          qrz(k)=amax1( 0.0,qrz(k)+dtb*prain(k) )
+          tmp_s=-(psmlt(k)+psmltevp(k))
+          psnow(k)=-tmp_s
+          qsz(k)=amax1( 0.0,qsz(k)+dtb*psnow(k) )
+          qschg(k)=psnow(k)
+!
+          tmp=ocp/tothz(k)*xLf*qschg(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
+          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
+!      CALL wrf_debug ( 100 , 'module_ylin: finish sum of all processes' )
+
+!
+!***********************************************************************
+!**********              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
+         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
+
+          es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) )
+          qswz(k)=ep2*es/(prez(k)-es)
+          if (tem(k) .lt. 273.15 ) then
+             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
+
+        es=1000.*svp1*exp( svp2*temcc(k)/(tem(k)-svp3) )
+        qswz(k)=ep2*es/(prez(k)-es)
+
+        if (tem(k) .lt. 273.15 ) then
+           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     **********
+!***********************************************************************
+!
+2000  continue
+
+!
+!**** 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
+!
+
+!      CALL wrf_debug ( 100 , 'module_ylin: finish saturation adjustment' )
+
+      END SUBROUTINE clphy1d_ylin
+
+
+
+
+!---------------------------------------------------------------------
+!                         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,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
+
+!+---+-----------------------------------------------------------------+
+! 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
+!+---+-----------------------------------------------------------------+
+
+!----------------------------------------------------------------
+      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_sbu_ylin
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_thompson.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_thompson.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_thompson.F	(revision 17)
@@ -0,0 +1,3586 @@
+!+---+-----------------------------------------------------------------+
+!.. This subroutine computes the moisture tendencies of water vapor,
+!.. cloud droplets, rain, cloud ice (pristine), snow, and graupel.
+!.. Prior to WRFv2.2 this code was based on Reisner et al (1998), but
+!.. few of those pieces remain.  A complete description is now found in
+!.. Thompson, G., P. R. Field, R. M. Rasmussen, and W. D. Hall, 2008:
+!.. Explicit Forecasts of winter precipitation using an improved bulk
+!.. microphysics scheme. Part II: Implementation of a new snow
+!.. parameterization.  Mon. Wea. Rev., 136, 5095-5115.
+!.. Prior to WRFv3.1, this code was single-moment rain prediction as
+!.. described in the reference above, but in v3.1 and higher, the
+!.. scheme is two-moment rain (predicted rain number concentration).
+!..
+!.. 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: 21 Nov 2010
+!+---+-----------------------------------------------------------------+
+!wrft:model_layer:physics
+!+---+-----------------------------------------------------------------+
+!
+      MODULE module_mp_thompson
+
+      USE module_wrf_error
+!     USE module_utility, ONLY: WRFU_Clock, WRFU_Alarm
+!     USE module_domain, ONLY : HISTORY_ALARM, Is_alarm_tstep
+
+      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 parameter for graupel is not constant and depends on
+!.. mixing ratio.  Also, when mu_g is non-zero, these become equiv
+!.. y-intercept for an exponential distrib and proper values are
+!.. computed based on same mixing ratio and total number concentration.
+      REAL, PARAMETER, PRIVATE:: gonv_min = 1.E4
+      REAL, PARAMETER, PRIVATE:: gonv_max = 1.E6
+
+!..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 = PI*rho_i/6.0
+      REAL, PARAMETER, PRIVATE:: bm_i = 3.0
+
+!..Fallspeed power laws relations:  v = (av*D**bv)*exp(-fv*D)
+!.. Rain from Ferrier (1994), ice, snow, and graupel from
+!.. Thompson et al (2008). 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 = 1847.5
+      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_sw, Ef_gw respectively) and
+!.. get computed elsewhere because they are dependent on stokes
+!.. number.
+      REAL, PARAMETER, PRIVATE:: Ef_si = 0.05
+      REAL, PARAMETER, PRIVATE:: Ef_rs = 0.95
+      REAL, PARAMETER, PRIVATE:: Ef_rg = 0.75
+      REAL, PARAMETER, PRIVATE:: Ef_ri = 0.95
+
+!..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 = 200.E-6
+      REAL, PARAMETER, PRIVATE:: D0g = 250.E-6
+      REAL, PRIVATE:: D0i, xm0s, xm0g
+
+!..Lookup table dimensions
+      INTEGER, PARAMETER, PRIVATE:: nbins = 100
+      INTEGER, PARAMETER, PRIVATE:: nbc = nbins
+      INTEGER, PARAMETER, PRIVATE:: nbi = nbins
+      INTEGER, PARAMETER, PRIVATE:: nbr = nbins
+      INTEGER, PARAMETER, PRIVATE:: nbs = nbins
+      INTEGER, PARAMETER, PRIVATE:: nbg = nbins
+      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_g1 = 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, nig3
+
+      DOUBLE PRECISION, DIMENSION(nbins+1):: xDx
+      DOUBLE PRECISION, DIMENSION(nbc):: Dc, dtc
+      DOUBLE PRECISION, DIMENSION(nbi):: Di, dti
+      DOUBLE PRECISION, DIMENSION(nbr):: Dr, dtr
+      DOUBLE PRECISION, DIMENSION(nbs):: Ds, dts
+      DOUBLE PRECISION, DIMENSION(nbg):: Dg, dtg
+
+!..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 graupel y-intercept parameter (/m**4).
+      REAL, DIMENSION(ntb_g1), PARAMETER, PRIVATE:: &
+      N0g_exp = (/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,2.e6,3.e6,4.e6,5.e6,6.e6,7.e6,8.e6,9.e6, &
+                  1.e7/)
+
+!..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/)
+
+!..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 t-p/c/m/n
+!.. represent lookup tables.  Save compile-time memory by making
+!.. allocatable (2009Jun12, J. Michalakes).
+      INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8
+      REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:)::             &
+                tcg_racg, tmr_racg, tcr_gacr, tmg_gacr,                 &
+                tnr_racg, tnr_gacr
+      REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:)::             &
+                tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2,             &
+                tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2,             &
+                tnr_racs1, tnr_racs2, tnr_sacr1, tnr_sacr2
+      REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:)::                 &
+                tpi_qcfz, tni_qcfz
+      REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:)::               &
+                tpi_qrfz, tpg_qrfz, tni_qrfz, tnr_qrfz
+      REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:)::                 &
+                tps_iaus, tni_iaus, tpi_ide
+      REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efrw
+      REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efsw
+      REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:):: tnr_rev
+
+!..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(7), PRIVATE:: cie, cig
+      REAL, PRIVATE:: oig1, oig2, obmi
+      REAL, DIMENSION(13), PRIVATE:: cre, crg
+      REAL, PRIVATE:: ore1, org1, org2, org3, obmr
+      REAL, DIMENSION(18), PRIVATE:: cse, csg
+      REAL, PRIVATE:: oams, obms, ocms
+      REAL, DIMENSION(12), PRIVATE:: cge, cgg
+      REAL, PRIVATE:: oge1, ogg1, ogg2, ogg3, oamg, obmg, ocmg
+
+!..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
+
+      CHARACTER*256:: mp_debug
+
+!+---+
+!+---+-----------------------------------------------------------------+
+!..END DECLARATIONS
+!+---+-----------------------------------------------------------------+
+!+---+
+!ctrlL
+
+      CONTAINS
+
+      SUBROUTINE thompson_init
+
+      IMPLICIT NONE
+
+      INTEGER:: i, j, k, m, n
+      LOGICAL:: micro_init
+
+!..Allocate space for lookup tables (J. Michalakes 2009Jun08).
+      micro_init = .FALSE.
+
+      if (.NOT. ALLOCATED(tcg_racg) ) then
+         ALLOCATE(tcg_racg(ntb_g1,ntb_g,ntb_r1,ntb_r))
+         micro_init = .TRUE.
+      endif
+
+      if (.NOT. ALLOCATED(tmr_racg)) ALLOCATE(tmr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tcr_gacr)) ALLOCATE(tcr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tmg_gacr)) ALLOCATE(tmg_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tnr_racg)) ALLOCATE(tnr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tnr_gacr)) ALLOCATE(tnr_gacr(ntb_g1,ntb_g,ntb_r1,ntb_r))
+
+      if (.NOT. ALLOCATED(tcs_racs1)) ALLOCATE(tcs_racs1(ntb_s,ntb_t,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tmr_racs1)) ALLOCATE(tmr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tcs_racs2)) ALLOCATE(tcs_racs2(ntb_s,ntb_t,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tmr_racs2)) ALLOCATE(tmr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tcr_sacr1)) ALLOCATE(tcr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tms_sacr1)) ALLOCATE(tms_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tcr_sacr2)) ALLOCATE(tcr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tms_sacr2)) ALLOCATE(tms_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tnr_racs1)) ALLOCATE(tnr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tnr_racs2)) ALLOCATE(tnr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tnr_sacr1)) ALLOCATE(tnr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r))
+      if (.NOT. ALLOCATED(tnr_sacr2)) ALLOCATE(tnr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r))
+
+      if (.NOT. ALLOCATED(tpi_qcfz)) ALLOCATE(tpi_qcfz(ntb_c,45))
+      if (.NOT. ALLOCATED(tni_qcfz)) ALLOCATE(tni_qcfz(ntb_c,45))
+
+      if (.NOT. ALLOCATED(tpi_qrfz)) ALLOCATE(tpi_qrfz(ntb_r,ntb_r1,45))
+      if (.NOT. ALLOCATED(tpg_qrfz)) ALLOCATE(tpg_qrfz(ntb_r,ntb_r1,45))
+      if (.NOT. ALLOCATED(tni_qrfz)) ALLOCATE(tni_qrfz(ntb_r,ntb_r1,45))
+      if (.NOT. ALLOCATED(tnr_qrfz)) ALLOCATE(tnr_qrfz(ntb_r,ntb_r1,45))
+
+      if (.NOT. ALLOCATED(tps_iaus)) ALLOCATE(tps_iaus(ntb_i,ntb_i1))
+      if (.NOT. ALLOCATED(tni_iaus)) ALLOCATE(tni_iaus(ntb_i,ntb_i1))
+      if (.NOT. ALLOCATED(tpi_ide)) ALLOCATE(tpi_ide(ntb_i,ntb_i1))
+
+      if (.NOT. ALLOCATED(t_Efrw)) ALLOCATE(t_Efrw(nbr,nbc))
+      if (.NOT. ALLOCATED(t_Efsw)) ALLOCATE(t_Efsw(nbs,nbc))
+
+      if (.NOT. ALLOCATED(tnr_rev)) ALLOCATE(tnr_rev(nbr, ntb_r1, ntb_r))
+
+      if (micro_init) then
+
+!..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*0.5 + mu_i + bv_i + 1.
+      cie(7) = bm_i*0.5 + mu_i + 1.
+      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))
+      cig(7) = WGAMMA(cie(7))
+      oig1 = 1./cig(1)
+      oig2 = 1./cig(2)
+      obmi = 1./bm_i
+
+      cre(1) = bm_r + 1.
+      cre(2) = mu_r + 1.
+      cre(3) = bm_r + mu_r + 1.
+      cre(4) = bm_r*2. + mu_r + 1.
+      cre(5) = mu_r + bv_r + 1.
+      cre(6) = bm_r + mu_r + bv_r + 1.
+      cre(7) = bm_r*0.5 + mu_r + bv_r + 1.
+      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*0.5 + mu_r + 1.
+      cre(13) = bm_r*2. + mu_r + bv_r + 1.
+      do n = 1, 13
+         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*2.
+      cse(4) = bm_s + bv_s + 1.
+      cse(5) = bm_s*2. + bv_s + 1.
+      cse(6) = bm_s*2. + 1.
+      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*2. + mu_s + bv_s + 1.
+      cse(12) = bm_s*2. + mu_s + 1.
+      cse(13) = bv_s + 2.
+      cse(14) = bm_s + bv_s
+      cse(15) = mu_s + 1.
+      cse(16) = 1.0 + (1.0 + bv_s)/2.
+      cse(17) = cse(16) + mu_s + 1.
+      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
+      ocms = oams**obms
+
+      cge(1) = bm_g + 1.
+      cge(2) = mu_g + 1.
+      cge(3) = bm_g + mu_g + 1.
+      cge(4) = bm_g*2. + mu_g + 1.
+      cge(5) = bm_g*2. + mu_g + bv_g + 1.
+      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
+      oamg = 1./am_g
+      obmg = 1./bm_g
+      ocmg = oamg**obmg
+      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)))
+      nig3 = NINT(ALOG10(N0g_exp(1)))
+
+!..Create bins of cloud water (from min diameter up to 100 microns).
+      Dc(1) = D0c*1.0d0
+      dtc(1) = D0c*1.0d0
+      do n = 2, nbc
+         Dc(n) = Dc(n-1) + 1.0D-6
+         dtc(n) = (Dc(n) - Dc(n-1))
+      enddo
+
+!..Create bins of cloud ice (from min diameter up to 5x min snow size).
+      xDx(1) = D0i*1.0d0
+      xDx(nbi+1) = 5.0d0*D0s
+      do n = 2, nbi
+         xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) &
+                  *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1)))
+      enddo
+      do n = 1, nbi
+         Di(n) = DSQRT(xDx(n)*xDx(n+1))
+         dti(n) = xDx(n+1) - xDx(n)
+      enddo
+
+!..Create bins of rain (from min diameter up to 5 mm).
+      xDx(1) = D0r*1.0d0
+      xDx(nbr+1) = 0.005d0
+      do n = 2, nbr
+         xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbr) &
+                  *DLOG(xDx(nbr+1)/xDx(1)) +DLOG(xDx(1)))
+      enddo
+      do n = 1, nbr
+         Dr(n) = DSQRT(xDx(n)*xDx(n+1))
+         dtr(n) = xDx(n+1) - xDx(n)
+      enddo
+
+!..Create bins of snow (from min diameter up to 2 cm).
+      xDx(1) = D0s*1.0d0
+      xDx(nbs+1) = 0.02d0
+      do n = 2, nbs
+         xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) &
+                  *DLOG(xDx(nbs+1)/xDx(1)) +DLOG(xDx(1)))
+      enddo
+      do n = 1, nbs
+         Ds(n) = DSQRT(xDx(n)*xDx(n+1))
+         dts(n) = xDx(n+1) - xDx(n)
+      enddo
+
+!..Create bins of graupel (from min diameter up to 5 cm).
+      xDx(1) = D0g*1.0d0
+      xDx(nbg+1) = 0.05d0
+      do n = 2, nbg
+         xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) &
+                  *DLOG(xDx(nbg+1)/xDx(1)) +DLOG(xDx(1)))
+      enddo
+      do n = 1, nbg
+         Dg(n) = DSQRT(xDx(n)*xDx(n+1))
+         dtg(n) = xDx(n+1) - xDx(n)
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Create lookup tables for most costly calculations.
+!+---+-----------------------------------------------------------------+
+
+      do m = 1, ntb_r
+         do k = 1, ntb_r1
+            do j = 1, ntb_g
+               do i = 1, ntb_g1
+                  tcg_racg(i,j,k,m) = 0.0d0
+                  tmr_racg(i,j,k,m) = 0.0d0
+                  tcr_gacr(i,j,k,m) = 0.0d0
+                  tmg_gacr(i,j,k,m) = 0.0d0
+                  tnr_racg(i,j,k,m) = 0.0d0
+                  tnr_gacr(i,j,k,m) = 0.0d0
+               enddo
+            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
+                  tnr_racs1(i,j,k,m) = 0.0d0
+                  tnr_racs2(i,j,k,m) = 0.0d0
+                  tnr_sacr1(i,j,k,m) = 0.0d0
+                  tnr_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
+               tnr_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
+
+      do j = 1, nbc
+         do i = 1, nbr
+            t_Efrw(i,j) = 0.0
+         enddo
+         do i = 1, nbs
+            t_Efsw(i,j) = 0.0
+         enddo
+      enddo
+
+      do k = 1, ntb_r
+         do j = 1, ntb_r1
+            do i = 1, nbr
+               tnr_rev(i,j,k) = 0.0d0
+            enddo
+         enddo
+      enddo
+
+      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)
+
+!..Collision efficiency between rain/snow and cloud water.
+      CALL wrf_debug(200, '  creating qc collision eff tables')
+      call table_Efrw
+      call table_Efsw
+
+!..Drop evaporation.
+!     CALL wrf_debug(200, '  creating rain evap table')
+!     call table_dropEvap
+
+!..Initialize various constants for computing radar reflectivity.
+!     call radar_init
+
+      if (.not. iiwarm) then
+
+!..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
+
+      endif
+
+      CALL wrf_debug(150, ' ... DONE microphysical lookup tables')
+
+      endif
+
+      END SUBROUTINE thompson_init
+!+---+-----------------------------------------------------------------+
+!ctrlL
+!+---+-----------------------------------------------------------------+
+!..This is a wrapper routine designed to transfer values from 3D to 1D.
+!+---+-----------------------------------------------------------------+
+      SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
+                              th, pii, p, dz, dt_in, itimestep, &
+                              RAINNC, RAINNCV, &
+                              SNOWNC, SNOWNCV, &
+                              GRAUPELNC, GRAUPELNCV, &
+                              SR, &
+!                             refl_10cm, grid_clock, grid_alarms, &
+                              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, nr, 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, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT)::      &
+                          SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV
+!     REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT)::       &
+!                         refl_10cm
+      REAL, INTENT(IN):: dt_in
+      INTEGER, INTENT(IN):: itimestep
+
+!     TYPE (WRFU_Clock):: grid_clock
+!     TYPE (WRFU_Alarm), POINTER:: grid_alarms(:)
+
+!..Local variables
+      REAL, DIMENSION(kts:kte):: &
+                          qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
+                          nr1d, t1d, p1d, dz1d, dBZ
+      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, nr_max
+      INTEGER:: i, j, k
+      INTEGER:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr
+      INTEGER:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr
+      INTEGER:: kmax_qc,kmax_qr,kmax_qi,kmax_qs,kmax_qg,kmax_ni,kmax_nr
+      INTEGER:: i_start, j_start, i_end, j_end
+      LOGICAL:: dBZ_tstep
+
+!+---+
+
+      dBZ_tstep = .false.
+!     if ( Is_alarm_tstep(grid_clock, grid_alarms(HISTORY_ALARM)) ) then
+!        dBZ_tstep = .true.
+!     endif
+
+      i_start = its
+      j_start = jts
+      i_end   = ite
+      j_end   = jte
+
+!..For idealized testing by developer.
+      if ( (ide-ids+1).gt.4 .and. (jde-jds+1).lt.4 .and.                &
+           ids.eq.its.and.ide.eq.ite.and.jds.eq.jts.and.jde.eq.jte) then
+         i_start = its + 2
+         i_end   = ite - 1
+         j_start = jts
+         j_end   = jte
+      endif
+
+      dt = dt_in
+   
+      qc_max = 0.
+      qr_max = 0.
+      qs_max = 0.
+      qi_max = 0.
+      qg_max = 0
+      ni_max = 0.
+      nr_max = 0.
+      imax_qc = 0
+      imax_qr = 0
+      imax_qi = 0
+      imax_qs = 0
+      imax_qg = 0
+      imax_ni = 0
+      imax_nr = 0
+      jmax_qc = 0
+      jmax_qr = 0
+      jmax_qi = 0
+      jmax_qs = 0
+      jmax_qg = 0
+      jmax_ni = 0
+      jmax_nr = 0
+      kmax_qc = 0
+      kmax_qr = 0
+      kmax_qi = 0
+      kmax_qs = 0
+      kmax_qg = 0
+      kmax_ni = 0
+      kmax_nr = 0
+      do i = 1, 256
+         mp_debug(i:i) = char(0)
+      enddo
+
+      j_loop:  do j = j_start, j_end
+      i_loop:  do i = i_start, i_end
+
+         pptrain = 0.
+         pptsnow = 0.
+         pptgraul = 0.
+         pptice = 0.
+         RAINNCV(i,j) = 0.
+         IF ( PRESENT (snowncv) ) THEN
+            SNOWNCV(i,j) = 0.
+         ENDIF
+         IF ( PRESENT (graupelncv) ) THEN
+            GRAUPELNCV(i,j) = 0.
+         ENDIF
+         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)
+            nr1d(k) = nr(i,k,j)
+         enddo
+
+         call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
+                      nr1d, 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
+         IF ( PRESENT(snowncv) .AND. PRESENT(snownc) ) THEN
+            SNOWNCV(i,j) = pptsnow + pptice
+            SNOWNC(i,j) = SNOWNC(i,j) + pptsnow + pptice
+         ENDIF
+         IF ( PRESENT(graupelncv) .AND. PRESENT(graupelnc) ) THEN
+            GRAUPELNCV(i,j) = pptgraul
+            GRAUPELNC(i,j) = GRAUPELNC(i,j) + pptgraul
+         ENDIF
+         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)
+            nr(i,k,j) = nr1d(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 (nr1d(k) .gt. nr_max) then
+             imax_nr = i
+             jmax_nr = j
+             kmax_nr = k
+             nr_max = nr1d(k)
+            elseif (nr1d(k) .lt. 0.0) then
+             write(mp_debug,*) 'WARNING, negative nr ', nr1d(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
+            if (qv1d(k) .lt. 0.0) then
+             if (k.lt.kte-2 .and. k.gt.kts+1) then
+                qv(i,k,j) = 0.5*(qv(i,k-1,j) + qv(i,k+1,j))
+             else
+                qv(i,k,j) = 1.E-7
+             endif
+             write(mp_debug,*) 'WARNING, negative qv ', qv1d(k),        &
+                        ' at i,j,k=', i,j,k
+             CALL wrf_debug(150, mp_debug)
+            endif
+         enddo
+
+!        if (dBZ_tstep) then
+!         call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d,       &
+!                     t1d, p1d, dBZ, kts, kte, i, j)
+!         do k = kts, kte
+!            refl_10cm(i,k,j) = MAX(-35., dBZ(k))
+!         enddo
+!        endif
+
+      enddo i_loop
+      enddo j_loop
+
+! DEBUG - GT
+      write(mp_debug,'(a,7(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, ')', &
+         'nr: ', nr_max, '(', imax_nr, ',', jmax_nr, ',', kmax_nr, ')'
+      CALL wrf_debug(150, mp_debug)
+! END DEBUG - GT
+
+      do i = 1, 256
+         mp_debug(i:i) = char(0)
+      enddo
+
+      END SUBROUTINE mp_gt_driver
+
+!+---+-----------------------------------------------------------------+
+!ctrlL
+!+---+-----------------------------------------------------------------+
+!+---+-----------------------------------------------------------------+
+!.. 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, 2008).
+!+---+-----------------------------------------------------------------+
+!
+      subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
+                          nr1d, 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, &
+                          nr1d, 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, nrten
+
+      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,          &
+           pnr_wau, pnr_rcs, pnr_rcg, &
+           pnr_rci, pnr_sml, pnr_gml, &
+           pnr_rev, pnr_rcr, pnr_rfz
+
+      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, nr
+      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, smo0, &
+           smoc, smod, smoe, smof
+
+      REAL, DIMENSION(kts:kte):: sed_r, sed_s, sed_g, sed_i, sed_n
+
+      REAL:: rgvm, delta_tp, orho, lfus2
+      REAL, DIMENSION(4):: onstep
+      DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamc, lamr, lamg
+      DOUBLE PRECISION:: lami, ilami
+      REAL:: xDc, Dc_b, Dc_g, xDi, xDr, xDs, xDg, Ds_m, Dg_m
+      DOUBLE PRECISION:: Dr_star
+      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, vtnik, vtrk, vtnrk, 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, xrr, xnr
+      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_sw, Ef_gw, Ef_rr
+      REAL:: dtsave, odts, odt, odzq
+      REAL:: xslw1, ygra1, zans1
+      INTEGER:: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq
+      INTEGER, DIMENSION(4):: ksed1
+      INTEGER:: nir, nis, nig, nii, nic
+      INTEGER:: idx_tc, idx_t, idx_s, idx_g1, idx_g, idx_r1, idx_r,     &
+                idx_i1, idx_i, idx_c, idx, idx_d
+      LOGICAL:: melti, no_micro
+      LOGICAL, DIMENSION(kts:kte):: L_qc, L_qi, L_qr, L_qs, L_qg
+      LOGICAL:: debug_flag
+
+!+---+
+
+      debug_flag = .false.
+      if (ii.eq.315 .and. jj.eq.2) debug_flag = .true.
+
+      no_micro = .true.
+      dtsave = dt
+      odt = 1./dt
+      odts = 1./dtsave
+      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.
+         nrten(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.
+         pnr_wau(k) = 0.
+         pnr_rcs(k) = 0.
+         pnr_rcg(k) = 0.
+         pnr_rci(k) = 0.
+         pnr_sml(k) = 0.
+         pnr_gml(k) = 0.
+         pnr_rev(k) = 0.
+         pnr_rcr(k) = 0.
+         pnr_rfz(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(R2, ni1d(k)*rho(k))
+            L_qi(k) = .true.
+            lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
+            ilami = 1./lami
+            xDi = (bm_i + mu_i + 1.) * ilami
+            if (xDi.lt. 20.E-6) then
+             lami = cie(2)/20.E-6
+             ni(k) = MIN(500.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i)
+            elseif (xDi.gt. 300.E-6) then
+             lami = cie(2)/300.E-6
+             ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i
+            endif
+         else
+            qi1d(k) = 0.0
+            ni1d(k) = 0.0
+            ri(k) = R1
+            ni(k) = R2
+            L_qi(k) = .false.
+         endif
+
+         if (qr1d(k) .gt. R1) then
+            no_micro = .false.
+            rr(k) = qr1d(k)*rho(k)
+            nr(k) = MAX(R2, nr1d(k)*rho(k))
+            L_qr(k) = .true.
+            if (nr(k) .gt. R2) then
+             lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
+             mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
+             if (mvd_r(k) .gt. 2.5E-3) then
+                mvd_r(k) = 2.5E-3
+                lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
+                nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
+             elseif (mvd_r(k) .lt. D0r*0.75) then
+                mvd_r(k) = D0r*0.75
+                lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
+                nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
+             endif
+            else
+             if (qr1d(k) .gt. R2) then
+                mvd_r(k) = 1.0E-3
+             else
+                mvd_r(k) = 2.5E-3 / 3.0**(ALOG10(R2)-ALOG10(qr1d(k)))
+             endif
+             lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
+             nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
+            endif
+         else
+            qr1d(k) = 0.0
+            nr1d(k) = 0.0
+            rr(k) = R1
+            nr(k) = R2
+            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 0th moment.  Represents snow number concentration.
+         loga_ = sa(1) + sa(2)*tc0 + sa(5)*tc0*tc0 + sa(9)*tc0*tc0*tc0
+         a_ = 10.0**loga_
+         b_ = sb(1) + sb(2)*tc0 + sb(5)*tc0*tc0 + sb(9)*tc0*tc0*tc0
+         smo0(k) = a_ * smo2(k)**b_
+
+!..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 (temp(k).lt.T_0 .and. (rc(k)+rr(k)).gt.1.E-5) then
+            xslw1 = 5. + alog10(max(1.E-5, min(1.E-2, (rc(k)+rr(k)))))
+         else
+            xslw1 = 0.
+         endif
+         ygra1 = 5. + alog10(max(1.E-5, min(1.E-2, rg(k))))
+         zans1 = 3.324 + (3./(5.*xslw1*ygra1/(5.*xslw1+1.+0.25*ygra1)+1.+0.25*ygra1))
+         N0_exp = 10.**(zans1)
+         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)
+!+---+-----------------------------------------------------------------+
+!     if( debug_flag .and. k.lt.42) then
+!        if (k.eq.41) write(mp_debug,*) 'DEBUG-GT:   K,   zans1,      rc,        rr,         rg,        N0_g'
+!        if (k.eq.41) CALL wrf_debug(0, mp_debug)
+!        write(mp_debug, 'a, i2, 1x, f6.3, 1x, 4(1x,e13.6,1x)')         &
+!                   '  GT ', k, zans1, rc(k), rr(k), rg(k), N0_g(k)
+!        CALL wrf_debug(0, mp_debug)
+!     endif
+!+---+-----------------------------------------------------------------+
+      enddo
+
+      endif
+
+!+---+-----------------------------------------------------------------+
+!..Calculate y-intercept, slope values for rain.
+!+---+-----------------------------------------------------------------+
+      do k = kte, kts, -1
+         lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
+         ilamr(k) = 1./lamr
+         mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
+         N0_r(k) = nr(k)*org2*lamr**cre(2)
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Compute warm-rain process terms (except evap done later).
+!+---+-----------------------------------------------------------------+
+
+      do k = kts, kte
+
+!..Rain self-collection follows Seifert, 1994 and drop break-up
+!.. follows Verlinde and Cotton, 1993.                                        RAIN2M
+         if (L_qr(k) .and. mvd_r(k).gt. D0r) then
+          Ef_rr = 1.0
+          if (mvd_r(k) .gt. 1750.0E-6) then
+             Ef_rr = 2.0 - EXP(2300.0*(mvd_r(k)-1750.0E-6))
+          endif
+          pnr_rcr(k) = Ef_rr * 8.*nr(k)*rr(k)
+         endif
+
+         if (.not. L_qc(k)) CYCLE
+         xDc = 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 = (xDc*xDc*xDc*Dc_g*Dc_g*Dc_g - xDc*xDc*xDc*xDc*xDc*xDc) &
+                 **(1./6.)
+          zeta1 = 0.5*((6.25E-6*xDc*Dc_b*Dc_b*Dc_b - 0.4) &
+                     + abs(6.25E-6*xDc*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))
+          pnr_wau(k) = prr_wau(k) / (am_r*mu_c/3.*D0r*D0r*D0r/rho(k))       ! RAIN2M
+         endif
+
+!..Rain collecting cloud water.  In CE, assume Dc<<Dr and vtc=~0.
+         if (L_qr(k) .and. mvd_r(k).gt. D0r .and. mvd_c(k).gt. D0c) then
+          lamr = 1./ilamr(k)
+          idx = 1 + INT(nbr*DLOG(mvd_r(k)/Dr(1))/DLOG(Dr(nbr)/Dr(1)))
+          idx = MIN(idx, nbr)
+          Ef_rw = t_Efrw(idx, INT(mvd_c(k)*1.E6))
+          prr_rcw(k) = rhof(k)*t1_qr_qc*Ef_rw*rc(k)*N0_r(k) &
+                         *((lamr+fv_r)**(-cre(9)))
+          prr_rcw(k) = MIN(DBLE(rc(k)*odts), prr_rcw(k))
+         endif
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Compute all frozen hydrometeor species' process terms.
+!+---+-----------------------------------------------------------------+
+      if (.not. iiwarm) then
+      do k = kts, kte
+         vts_boost(k) = 1.5
+
+!..Temperature lookup table indexes.
+         tempc = temp(k) - 273.15
+         idx_tc = MAX(1, MIN(NINT(-tempc), 45) )
+         idx_t = INT( (tempc-2.5)/5. ) - 1
+         idx_t = MAX(1, -idx_t)
+         idx_t = MIN(idx_t, ntb_t)
+         IT = MAX(1, MIN(NINT(-tempc), 31) )
+
+!..Cloud water lookup table index.
+         if (rc(k).gt. r_c(1)) then
+          nic = NINT(ALOG10(rc(k)))
+          do nn = nic-1, nic+1
+             n = nn
+             if ( (rc(k)/10.**nn).ge.1.0 .and. &
+                  (rc(k)/10.**nn).lt.10.0) goto 141
+          enddo
+ 141      continue
+          idx_c = INT(rc(k)/10.**n) + 10*(n-nic2) - (n-nic2)
+          idx_c = MAX(1, MIN(idx_c, ntb_c))
+         else
+          idx_c = 1
+         endif
+
+!..Cloud ice lookup table indexes.
+         if (ri(k).gt. r_i(1)) then
+          nii = NINT(ALOG10(ri(k)))
+          do nn = nii-1, nii+1
+             n = nn
+             if ( (ri(k)/10.**nn).ge.1.0 .and. &
+                  (ri(k)/10.**nn).lt.10.0) goto 142
+          enddo
+ 142      continue
+          idx_i = INT(ri(k)/10.**n) + 10*(n-nii2) - (n-nii2)
+          idx_i = MAX(1, MIN(idx_i, ntb_i))
+         else
+          idx_i = 1
+         endif
+
+         if (ni(k).gt. Nt_i(1)) then
+          nii = NINT(ALOG10(ni(k)))
+          do nn = nii-1, nii+1
+             n = nn
+             if ( (ni(k)/10.**nn).ge.1.0 .and. &
+                  (ni(k)/10.**nn).lt.10.0) goto 143
+          enddo
+ 143      continue
+          idx_i1 = INT(ni(k)/10.**n) + 10*(n-nii3) - (n-nii3)
+          idx_i1 = MAX(1, MIN(idx_i1, ntb_i1))
+         else
+          idx_i1 = 1
+         endif
+
+!..Rain lookup table indexes.
+         if (rr(k).gt. r_r(1)) then
+          nir = NINT(ALOG10(rr(k)))
+          do nn = nir-1, nir+1
+             n = nn
+             if ( (rr(k)/10.**nn).ge.1.0 .and. &
+                  (rr(k)/10.**nn).lt.10.0) goto 144
+          enddo
+ 144      continue
+          idx_r = INT(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2)
+          idx_r = MAX(1, MIN(idx_r, ntb_r))
+
+          lamr = 1./ilamr(k)
+          lam_exp = lamr * (crg(3)*org2*org1)**bm_r
+          N0_exp = org1*rr(k)/am_r * lam_exp**cre(1)
+          nir = NINT(DLOG10(N0_exp))
+          do nn = nir-1, nir+1
+             n = nn
+             if ( (N0_exp/10.**nn).ge.1.0 .and. &
+                  (N0_exp/10.**nn).lt.10.0) goto 145
+          enddo
+ 145      continue
+          idx_r1 = INT(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3)
+          idx_r1 = MAX(1, MIN(idx_r1, ntb_r1))
+         else
+          idx_r = 1
+          idx_r1 = ntb_r1
+         endif
+
+!..Snow lookup table index.
+         if (rs(k).gt. r_s(1)) then
+          nis = NINT(ALOG10(rs(k)))
+          do nn = nis-1, nis+1
+             n = nn
+             if ( (rs(k)/10.**nn).ge.1.0 .and. &
+                  (rs(k)/10.**nn).lt.10.0) goto 146
+          enddo
+ 146      continue
+          idx_s = INT(rs(k)/10.**n) + 10*(n-nis2) - (n-nis2)
+          idx_s = MAX(1, MIN(idx_s, ntb_s))
+         else
+          idx_s = 1
+         endif
+
+!..Graupel lookup table index.
+         if (rg(k).gt. r_g(1)) then
+          nig = NINT(ALOG10(rg(k)))
+          do nn = nig-1, nig+1
+             n = nn
+             if ( (rg(k)/10.**nn).ge.1.0 .and. &
+                  (rg(k)/10.**nn).lt.10.0) goto 147
+          enddo
+ 147      continue
+          idx_g = INT(rg(k)/10.**n) + 10*(n-nig2) - (n-nig2)
+          idx_g = MAX(1, MIN(idx_g, ntb_g))
+
+          lamg = 1./ilamg(k)
+          lam_exp = lamg * (cgg(3)*ogg2*ogg1)**bm_g
+          N0_exp = ogg1*rg(k)/am_g * lam_exp**cge(1)
+          nig = NINT(DLOG10(N0_exp))
+          do nn = nig-1, nig+1
+             n = nn
+             if ( (N0_exp/10.**nn).ge.1.0 .and. &
+                  (N0_exp/10.**nn).lt.10.0) goto 148
+          enddo
+ 148      continue
+          idx_g1 = INT(N0_exp/10.**n) + 10*(n-nig3) - (n-nig3)
+          idx_g1 = MAX(1, MIN(idx_g1, ntb_g1))
+         else
+          idx_g = 1
+          idx_g1 = ntb_g1
+         endif
+
+!..Deposition/sublimation prefactor (from Srivastava & Coen 1992).
+         otemp = 1./temp(k)
+         rvs = rho(k)*qvsi(k)
+         rvs_p = rvs*otemp*(lsub*otemp*oRv - 1.)
+         rvs_pp = rvs * ( otemp*(lsub*otemp*oRv - 1.) &
+                         *otemp*(lsub*otemp*oRv - 1.) &
+                         + (-2.*lsub*otemp*otemp*otemp*oRv) &
+                         + otemp*otemp)
+         gamsc = lsub*diffu(k)/tcond(k) * rvs_p
+         alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) &
+                    * rvs_pp/rvs_p * rvs/rvs_p
+         alphsc = MAX(1.E-9, alphsc)
+         xsat = ssati(k)
+         if (abs(xsat).lt. 1.E-9) xsat=0.
+         t1_subl = 4.*PI*( 1.0 - alphsc*xsat &
+                + 2.*alphsc*alphsc*xsat*xsat &
+                - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) &
+                / (1.+gamsc)
+
+!..Snow collecting cloud water.  In CE, assume Dc<<Ds and vtc=~0.
+         if (L_qc(k) .and. mvd_c(k).gt. D0c) then
+          xDs = 0.0
+          if (L_qs(k)) xDs = smoc(k) / smob(k)
+          if (xDs .gt. D0s) then
+           idx = 1 + INT(nbs*DLOG(xDs/Ds(1))/DLOG(Ds(nbs)/Ds(1)))
+           idx = MIN(idx, nbs)
+           Ef_sw = t_Efsw(idx, INT(mvd_c(k)*1.E6))
+           prs_scw(k) = rhof(k)*t1_qs_qc*Ef_sw*rc(k)*smoe(k)
+          endif
+
+!..Graupel collecting cloud water.  In CE, assume Dc<<Dg and vtc=~0.
+          if (rg(k).ge. r_g(1) .and. mvd_c(k).gt. D0c) then
+           xDg = (bm_g + mu_g + 1.) * ilamg(k)
+           vtg = rhof(k)*av_g*cgg(6)*ogg3 * ilamg(k)**bv_g
+           stoke_g = mvd_c(k)*mvd_c(k)*vtg*rho_w/(9.*visco(k)*xDg)
+           if (xDg.gt. D0g) then
+            if (stoke_g.ge.0.4 .and. stoke_g.le.10.) then
+             Ef_gw = 0.55*ALOG10(2.51*stoke_g)
+            elseif (stoke_g.lt.0.4) then
+             Ef_gw = 0.0
+            elseif (stoke_g.gt.10) then
+             Ef_gw = 0.77
+            endif
+            prg_gcw(k) = rhof(k)*t1_qg_qc*Ef_gw*rc(k)*N0_g(k) &
+                          *ilamg(k)**cge(9)
+           endif
+          endif
+         endif
+
+!..Rain collecting snow.  Cannot assume Wisner (1972) approximation
+!.. or Mizuno (1990) approach so we solve the CE explicitly and store
+!.. results in lookup table.
+         if (rr(k).ge. r_r(1)) then
+          if (rs(k).ge. r_s(1)) then
+           if (temp(k).lt.T_0) then
+            prr_rcs(k) = -(tmr_racs2(idx_s,idx_t,idx_r1,idx_r) &
+                           + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) &
+                           + tmr_racs1(idx_s,idx_t,idx_r1,idx_r) &
+                           + tcr_sacr1(idx_s,idx_t,idx_r1,idx_r))
+            prs_rcs(k) = tmr_racs2(idx_s,idx_t,idx_r1,idx_r) &
+                         + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r) &
+                         - tcs_racs1(idx_s,idx_t,idx_r1,idx_r) &
+                         - tms_sacr1(idx_s,idx_t,idx_r1,idx_r)
+            prg_rcs(k) = tmr_racs1(idx_s,idx_t,idx_r1,idx_r) &
+                         + tcr_sacr1(idx_s,idx_t,idx_r1,idx_r) &
+                         + tcs_racs1(idx_s,idx_t,idx_r1,idx_r) &
+                         + tms_sacr1(idx_s,idx_t,idx_r1,idx_r)
+            prr_rcs(k) = MAX(DBLE(-rr(k)*odts), prr_rcs(k))
+            prs_rcs(k) = MAX(DBLE(-rs(k)*odts), prs_rcs(k))
+            prg_rcs(k) = MIN(DBLE((rr(k)+rs(k))*odts), prg_rcs(k))
+            pnr_rcs(k) = tnr_racs1(idx_s,idx_t,idx_r1,idx_r)            &   ! RAIN2M
+                         + tnr_racs2(idx_s,idx_t,idx_r1,idx_r)          &
+                         + tnr_sacr1(idx_s,idx_t,idx_r1,idx_r)          &
+                         + tnr_sacr2(idx_s,idx_t,idx_r1,idx_r)
+           else
+            prs_rcs(k) = -tcs_racs1(idx_s,idx_t,idx_r1,idx_r)           &
+                         - tms_sacr1(idx_s,idx_t,idx_r1,idx_r)          &
+                         + tmr_racs2(idx_s,idx_t,idx_r1,idx_r)          &
+                         + tcr_sacr2(idx_s,idx_t,idx_r1,idx_r)
+            prs_rcs(k) = MAX(DBLE(-rs(k)*odts), prs_rcs(k))
+            prr_rcs(k) = -prs_rcs(k)
+            pnr_rcs(k) = tnr_racs2(idx_s,idx_t,idx_r1,idx_r)            &   ! RAIN2M
+                         + tnr_sacr2(idx_s,idx_t,idx_r1,idx_r)
+           endif
+           pnr_rcs(k) = MIN(DBLE(nr(k)*odts), pnr_rcs(k))
+          endif
+
+!..Rain collecting graupel.  Cannot assume Wisner (1972) approximation
+!.. or Mizuno (1990) approach so we solve the CE explicitly and store
+!.. results in lookup table.
+          if (rg(k).ge. r_g(1)) then
+           if (temp(k).lt.T_0) then
+            prg_rcg(k) = tmr_racg(idx_g1,idx_g,idx_r1,idx_r) &
+                         + tcr_gacr(idx_g1,idx_g,idx_r1,idx_r)
+            prg_rcg(k) = MIN(DBLE(rr(k)*odts), prg_rcg(k))
+            prr_rcg(k) = -prg_rcg(k)
+            pnr_rcg(k) = tnr_racg(idx_g1,idx_g,idx_r1,idx_r)            &   ! RAIN2M
+                         + tnr_gacr(idx_g1,idx_g,idx_r1,idx_r)
+            pnr_rcg(k) = MIN(DBLE(nr(k)*odts), pnr_rcg(k))
+           else
+            prr_rcg(k) = tcg_racg(idx_g1,idx_g,idx_r1,idx_r)
+            prr_rcg(k) = MIN(DBLE(rg(k)*odts), prr_rcg(k))
+            prg_rcg(k) = -prr_rcg(k)
+           endif
+          endif
+         endif
+
+!+---+-----------------------------------------------------------------+
+!..Next IF block handles only those processes below 0C.
+!+---+-----------------------------------------------------------------+
+
+         if (temp(k).lt.T_0) then
+
+          vts_boost(k) = 1.0
+          rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999
+
+!..Freezing of water drops into graupel/cloud ice (Bigg 1953).
+          if (rr(k).gt. r_r(1)) then
+           prg_rfz(k) = tpg_qrfz(idx_r,idx_r1,idx_tc)*odts
+           pri_rfz(k) = tpi_qrfz(idx_r,idx_r1,idx_tc)*odts
+           pni_rfz(k) = tni_qrfz(idx_r,idx_r1,idx_tc)*odts
+           pnr_rfz(k) = tnr_qrfz(idx_r,idx_r1,idx_tc)*odts                 ! RAIN2M
+           pnr_rfz(k) = MIN(DBLE(nr(k)*odts), pnr_rfz(k))
+          elseif (rr(k).gt. R1 .and. temp(k).lt.HGFR) then
+           pri_rfz(k) = rr(k)*odts
+           pnr_rfz(k) = nr(k)*odts                                         ! RAIN2M
+           pni_rfz(k) = pnr_rfz(k)
+          endif
+          if (rc(k).gt. r_c(1)) then
+           pri_wfz(k) = tpi_qcfz(idx_c,idx_tc)*odts
+           pri_wfz(k) = MIN(DBLE(rc(k)*odts), pri_wfz(k))
+           pni_wfz(k) = tni_qcfz(idx_c,idx_tc)*odts
+           pni_wfz(k) = MIN(DBLE(Nt_c*odts), pri_wfz(k)/(2.*xm0i), &
+                                pni_wfz(k))
+          endif
+
+!..Nucleate ice from deposition & condensation freezing (Cooper 1986)
+!.. but only if water sat and T<-12C or 25%+ ice supersaturated.
+          if ( (ssati(k).ge. 0.25) .or. (ssatw(k).gt. eps &
+                                .and. temp(k).lt.261.15) ) then
+           xnc = MIN(250.E3, TNO*EXP(ATO*(T_0-temp(k))))
+           xni = ni(k) + (pni_rfz(k)+pni_wfz(k))*dtsave
+           pni_inu(k) = 0.5*(xnc-xni + abs(xnc-xni))*odts
+           pri_inu(k) = MIN(DBLE(rate_max), xm0i*pni_inu(k))
+           pni_inu(k) = pri_inu(k)/xm0i
+          endif
+
+!..Deposition/sublimation of cloud ice (Srivastava & Coen 1992).
+          if (L_qi(k)) then
+           lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
+           ilami = 1./lami
+           xDi = MAX(DBLE(D0i), (bm_i + mu_i + 1.) * ilami)
+           xmi = am_i*xDi**bm_i
+           oxmi = 1./xmi
+           pri_ide(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
+                  *oig1*cig(5)*ni(k)*ilami
+
+           if (pri_ide(k) .lt. 0.0) then
+            pri_ide(k) = MAX(DBLE(-ri(k)*odts), pri_ide(k), DBLE(rate_max))
+            pni_ide(k) = pri_ide(k)*oxmi
+            pni_ide(k) = MAX(DBLE(-ni(k)*odts), pni_ide(k))
+           else
+            pri_ide(k) = MIN(pri_ide(k), DBLE(rate_max))
+            prs_ide(k) = (1.0D0-tpi_ide(idx_i,idx_i1))*pri_ide(k)
+            pri_ide(k) = tpi_ide(idx_i,idx_i1)*pri_ide(k)
+           endif
+
+!..Some cloud ice needs to move into the snow category.  Use lookup
+!.. table that resulted from explicit bin representation of distrib.
+           if ( (idx_i.eq. ntb_i) .or. (xDi.gt. 5.0*D0s) ) then
+            prs_iau(k) = ri(k)*.99*odts
+            pni_iau(k) = ni(k)*.95*odts
+           elseif (xDi.lt. 0.1*D0s) then
+            prs_iau(k) = 0.
+            pni_iau(k) = 0.
+           else
+            prs_iau(k) = tps_iaus(idx_i,idx_i1)*odts
+            prs_iau(k) = MIN(DBLE(ri(k)*.99*odts), prs_iau(k))
+            pni_iau(k) = tni_iaus(idx_i,idx_i1)*odts
+            pni_iau(k) = MIN(DBLE(ni(k)*.95*odts), pni_iau(k))
+           endif
+          endif
+
+!..Deposition/sublimation of snow/graupel follows Srivastava & Coen
+!.. (1992).
+          if (L_qs(k)) then
+           C_snow = C_sqrd + (tempc+15.)*(C_cube-C_sqrd)/(-30.+15.)
+           C_snow = MAX(C_sqrd, MIN(C_snow, C_cube))
+           prs_sde(k) = C_snow*t1_subl*diffu(k)*ssati(k)*rvs &
+                        * (t1_qs_sd*smo1(k) &
+                         + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k))
+           if (prs_sde(k).lt. 0.) then
+            prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k), DBLE(rate_max))
+           else
+            prs_sde(k) = MIN(prs_sde(k), DBLE(rate_max))
+           endif
+          endif
+
+          if (L_qg(k) .and. ssati(k).lt. -eps) then
+           prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
+               * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) &
+               + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11))
+           if (prg_gde(k).lt. 0.) then
+            prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k), DBLE(rate_max))
+           else
+            prg_gde(k) = MIN(prg_gde(k), DBLE(rate_max))
+           endif
+          endif
+
+!..Snow collecting cloud ice.  In CE, assume Di<<Ds and vti=~0.
+          if (L_qi(k)) then
+           lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
+           ilami = 1./lami
+           xDi = MAX(DBLE(D0i), (bm_i + mu_i + 1.) * ilami)
+           xmi = am_i*xDi**bm_i
+           oxmi = 1./xmi
+           if (rs(k).ge. r_s(1)) then
+            prs_sci(k) = t1_qs_qi*rhof(k)*Ef_si*ri(k)*smoe(k)
+            pni_sci(k) = prs_sci(k) * oxmi
+           endif
+
+!..Rain collecting cloud ice.  In CE, assume Di<<Dr and vti=~0.
+           if (rr(k).ge. r_r(1) .and. mvd_r(k).gt. 4.*xDi) then
+            lamr = 1./ilamr(k)
+            pri_rci(k) = rhof(k)*t1_qr_qi*Ef_ri*ri(k)*N0_r(k) &
+                           *((lamr+fv_r)**(-cre(9)))
+            pnr_rci(k) = rhof(k)*t1_qr_qi*Ef_ri*ni(k)*N0_r(k)           &   ! RAIN2M
+                           *((lamr+fv_r)**(-cre(9)))
+            pni_rci(k) = pri_rci(k) * oxmi
+            prr_rci(k) = rhof(k)*t2_qr_qi*Ef_ri*ni(k)*N0_r(k) &
+                           *((lamr+fv_r)**(-cre(8)))
+            prr_rci(k) = MIN(DBLE(rr(k)*odts), prr_rci(k))
+            prg_rci(k) = pri_rci(k) + prr_rci(k)
+           endif
+          endif
+
+!..Ice multiplication from rime-splinters (Hallet & Mossop 1974).
+          if (prg_gcw(k).gt. eps .and. tempc.gt.-8.0) then
+           tf = 0.
+           if (tempc.ge.-5.0 .and. tempc.lt.-3.0) then
+            tf = 0.5*(-3.0 - tempc)
+           elseif (tempc.gt.-8.0 .and. tempc.lt.-5.0) then
+            tf = 0.33333333*(8.0 + tempc)
+           endif
+           pni_ihm(k) = 3.5E8*tf*prg_gcw(k)
+           pri_ihm(k) = xm0i*pni_ihm(k)
+           prs_ihm(k) = prs_scw(k)/(prs_scw(k)+prg_gcw(k)) &
+                          * pri_ihm(k)
+           prg_ihm(k) = prg_gcw(k)/(prs_scw(k)+prg_gcw(k)) &
+                          * pri_ihm(k)
+          endif
+
+!..A portion of rimed snow converts to graupel but some remains snow.
+!.. Interp from 5 to 75% as riming factor increases from 5.0 to 30.0
+!.. 0.028 came from (.75-.05)/(30.-5.).  This remains ad-hoc and should
+!.. be revisited.
+          if (prs_scw(k).gt.5.0*prs_sde(k) .and. &
+                         prs_sde(k).gt.eps) then
+           r_frac = MIN(30.0D0, prs_scw(k)/prs_sde(k))
+           g_frac = MIN(0.75, 0.05 + (r_frac-5.)*.028)
+           vts_boost(k) = MIN(1.5, 1.1 + (r_frac-5.)*.016)
+           prg_scw(k) = g_frac*prs_scw(k)
+           prs_scw(k) = (1. - g_frac)*prs_scw(k)
+          endif
+
+         else
+
+!..Melt snow and graupel and enhance from collisions with liquid.
+!.. We also need to sublimate snow and graupel if subsaturated.
+          if (L_qs(k)) then
+           prr_sml(k) = tempc*tcond(k)*(t1_qs_me*smo1(k) &
+                      + t2_qs_me*rhof2(k)*vsc2(k)*smof(k))
+           prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc &
+                                   * (prr_rcs(k)+prs_scw(k))
+           prr_sml(k) = MIN(DBLE(rs(k)*odts), prr_sml(k))
+           pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.50*tempc)      ! RAIN2M
+           pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k))
+           if (tempc.gt.3.5 .or. rs(k).lt.0.005E-3) pnr_sml(k)=0.0
+
+           if (ssati(k).lt. 0.) then
+            prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
+                         * (t1_qs_sd*smo1(k) &
+                          + t2_qs_sd*rhof2(k)*vsc2(k)*smof(k))
+            prs_sde(k) = MAX(DBLE(-rs(k)*odts), prs_sde(k))
+           endif
+          endif
+
+          if (L_qg(k)) then
+           prr_gml(k) = tempc*N0_g(k)*tcond(k) &
+                    *(t1_qg_me*ilamg(k)**cge(10) &
+                    + t2_qg_me*rhof2(k)*vsc2(k)*ilamg(k)**cge(11))
+           prr_gml(k) = prr_gml(k) + 4218.*olfus*tempc &
+                                   * (prr_rcg(k)+prg_gcw(k))
+           prr_gml(k) = MIN(DBLE(rg(k)*odts), prr_gml(k))
+           pnr_gml(k) = (N0_g(k) / (cgg(1)*am_g*N0_g(k)/rg(k))**oge1)   &   ! RAIN2M
+                      / rg(k) * prr_gml(k) * 10.0**(-0.35*tempc)
+           if (rg(k).lt.0.005E-3) pnr_gml(k)=0.0
+
+           if (ssati(k).lt. 0.) then
+            prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
+                * N0_g(k) * (t1_qg_sd*ilamg(k)**cge(10) &
+                + t2_qg_sd*vsc2(k)*rhof2(k)*ilamg(k)**cge(11))
+            prg_gde(k) = MAX(DBLE(-rg(k)*odts), prg_gde(k))
+           endif
+          endif
+
+!.. This change will be required if users run adaptive time step that
+!.. results in delta-t that is generally too long to allow cloud water
+!.. collection by snow/graupel above melting temperature.
+!.. Credit to Bjorn-Egil Nygaard for discovering.
+          if (dt .gt. 120.) then
+             prr_rcw(k)=prr_rcw(k)+prs_scw(k)+prg_gcw(k)
+             prs_scw(k)=0.
+             prg_gcw(k)=0.
+          endif
+
+         endif
+
+      enddo
+      endif
+
+!+---+-----------------------------------------------------------------+
+!..Ensure we do not deplete more hydrometeor species than exists.
+!+---+-----------------------------------------------------------------+
+      do k = kts, kte
+
+!..If ice supersaturated, ensure sum of depos growth terms does not
+!.. deplete more vapor than possibly exists.  If subsaturated, limit
+!.. sum of sublimation terms such that vapor does not reproduce ice
+!.. supersat again.
+         sump = pri_inu(k) + pri_ide(k) + prs_ide(k) &
+              + prs_sde(k) + prg_gde(k)
+         rate_max = (qv(k)-qvsi(k))*odts*0.999
+         if ( (sump.gt. eps .and. sump.gt. rate_max) .or. &
+              (sump.lt. -eps .and. sump.lt. rate_max) ) then
+          ratio = rate_max/sump
+          pri_inu(k) = pri_inu(k) * ratio
+          pri_ide(k) = pri_ide(k) * ratio
+          pni_ide(k) = pni_ide(k) * ratio
+          prs_ide(k) = prs_ide(k) * ratio
+          prs_sde(k) = prs_sde(k) * ratio
+          prg_gde(k) = prg_gde(k) * ratio
+         endif
+
+!..Cloud water conservation.
+         sump = -prr_wau(k) - pri_wfz(k) - prr_rcw(k) &
+                - prs_scw(k) - prg_scw(k) - prg_gcw(k)
+         rate_max = -rc(k)*odts
+         if (sump.lt. rate_max .and. L_qc(k)) then
+          ratio = rate_max/sump
+          prr_wau(k) = prr_wau(k) * ratio
+          pri_wfz(k) = pri_wfz(k) * ratio
+          prr_rcw(k) = prr_rcw(k) * ratio
+          prs_scw(k) = prs_scw(k) * ratio
+          prg_scw(k) = prg_scw(k) * ratio
+          prg_gcw(k) = prg_gcw(k) * ratio
+         endif
+
+!..Cloud ice conservation.
+         sump = pri_ide(k) - prs_iau(k) - prs_sci(k) &
+                - pri_rci(k)
+         rate_max = -ri(k)*odts
+         if (sump.lt. rate_max .and. L_qi(k)) then
+          ratio = rate_max/sump
+          pri_ide(k) = pri_ide(k) * ratio
+          prs_iau(k) = prs_iau(k) * ratio
+          prs_sci(k) = prs_sci(k) * ratio
+          pri_rci(k) = pri_rci(k) * ratio
+         endif
+
+!..Rain conservation.
+         sump = -prg_rfz(k) - pri_rfz(k) - prr_rci(k) &
+                + prr_rcs(k) + prr_rcg(k)
+         rate_max = -rr(k)*odts
+         if (sump.lt. rate_max .and. L_qr(k)) then
+          ratio = rate_max/sump
+          prg_rfz(k) = prg_rfz(k) * ratio
+          pri_rfz(k) = pri_rfz(k) * ratio
+          prr_rci(k) = prr_rci(k) * ratio
+          prr_rcs(k) = prr_rcs(k) * ratio
+          prr_rcg(k) = prr_rcg(k) * ratio
+         endif
+
+!..Snow conservation.
+         sump = prs_sde(k) - prs_ihm(k) - prr_sml(k) &
+                + prs_rcs(k)
+         rate_max = -rs(k)*odts
+         if (sump.lt. rate_max .and. L_qs(k)) then
+          ratio = rate_max/sump
+          prs_sde(k) = prs_sde(k) * ratio
+          prs_ihm(k) = prs_ihm(k) * ratio
+          prr_sml(k) = prr_sml(k) * ratio
+          prs_rcs(k) = prs_rcs(k) * ratio
+         endif
+
+!..Graupel conservation.
+         sump = prg_gde(k) - prg_ihm(k) - prr_gml(k) &
+              + prg_rcg(k)
+         rate_max = -rg(k)*odts
+         if (sump.lt. rate_max .and. L_qg(k)) then
+          ratio = rate_max/sump
+          prg_gde(k) = prg_gde(k) * ratio
+          prg_ihm(k) = prg_ihm(k) * ratio
+          prr_gml(k) = prr_gml(k) * ratio
+          prg_rcg(k) = prg_rcg(k) * ratio
+         endif
+
+!..Re-enforce proper mass conservation for subsequent elements in case
+!.. any of the above terms were altered.  Thanks P. Blossey. 2009Sep28
+         pri_ihm(k) = prs_ihm(k) + prg_ihm(k)
+         ratio = MIN( ABS(prr_rcg(k)), ABS(prg_rcg(k)) )
+         prr_rcg(k) = ratio * SIGN(1.0, SNGL(prr_rcg(k)))
+         prg_rcg(k) = -prr_rcg(k)
+         if (temp(k).gt.T_0) then
+            ratio = MIN( ABS(prr_rcs(k)), ABS(prs_rcs(k)) )
+            prr_rcs(k) = ratio * SIGN(1.0, SNGL(prr_rcs(k)))
+            prs_rcs(k) = -prr_rcs(k)
+         endif
+
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Calculate tendencies of all species but constrain the number of ice
+!.. to reasonable values.
+!+---+-----------------------------------------------------------------+
+      do k = kts, kte
+         orho = 1./rho(k)
+         lfus2 = lsub - lvap(k)
+
+!..Water vapor tendency
+         qvten(k) = qvten(k) + (-pri_inu(k) - pri_ide(k) &
+                      - prs_ide(k) - prs_sde(k) - prg_gde(k)) &
+                      * orho
+
+!..Cloud water tendency
+         qcten(k) = qcten(k) + (-prr_wau(k) - pri_wfz(k) &
+                      - prr_rcw(k) - prs_scw(k) - prg_scw(k) &
+                      - prg_gcw(k)) &
+                      * orho
+
+!..Cloud ice mixing ratio tendency
+         qiten(k) = qiten(k) + (pri_inu(k) + pri_ihm(k) &
+                      + pri_wfz(k) + pri_rfz(k) + pri_ide(k) &
+                      - prs_iau(k) - prs_sci(k) - pri_rci(k)) &
+                      * orho
+
+!..Cloud ice number tendency.
+         niten(k) = niten(k) + (pni_inu(k) + pni_ihm(k) &
+                      + pni_wfz(k) + pni_rfz(k) + pni_ide(k) &
+                      - pni_iau(k) - pni_sci(k) - pni_rci(k)) &
+                      * orho
+
+!..Cloud ice mass/number balance; keep mass-wt mean size between
+!.. 20 and 300 microns.  Also no more than 500 xtals per liter.
+         xri=MAX(R1,(qi1d(k) + qiten(k)*dtsave)*rho(k))
+         xni=MAX(R2,(ni1d(k) + niten(k)*dtsave)*rho(k))
+         if (xri.gt. R1) then
+           lami = (am_i*cig(2)*oig1*xni/xri)**obmi
+           ilami = 1./lami
+           xDi = (bm_i + mu_i + 1.) * ilami
+           if (xDi.lt. 20.E-6) then
+            lami = cie(2)/20.E-6
+            xni = MIN(500.D3, cig(1)*oig2*xri/am_i*lami**bm_i)
+            niten(k) = (xni-ni1d(k)*rho(k))*odts*orho
+           elseif (xDi.gt. 300.E-6) then
+            lami = cie(2)/300.E-6
+            xni = cig(1)*oig2*xri/am_i*lami**bm_i
+            niten(k) = (xni-ni1d(k)*rho(k))*odts*orho
+           endif
+         else
+          niten(k) = -ni1d(k)*odts
+         endif
+         xni=MAX(0.,(ni1d(k) + niten(k)*dtsave)*rho(k))
+         if (xni.gt.500.E3) &
+                niten(k) = (500.E3-ni1d(k)*rho(k))*odts*orho
+
+!..Rain tendency
+         qrten(k) = qrten(k) + (prr_wau(k) + prr_rcw(k) &
+                      + prr_sml(k) + prr_gml(k) + prr_rcs(k) &
+                      + prr_rcg(k) - prg_rfz(k) &
+                      - pri_rfz(k) - prr_rci(k)) &
+                      * orho
+
+!..Rain number tendency
+         nrten(k) = nrten(k) + (pnr_wau(k) + pnr_sml(k) + pnr_gml(k)    &
+                      - (pnr_rfz(k) + pnr_rcr(k) + pnr_rcg(k)           &
+                      + pnr_rcs(k) + pnr_rci(k)) )                      &
+                      * orho
+
+!..Rain mass/number balance; keep median volume diameter between
+!.. 37 microns (D0r*0.75) and 2.5 mm.
+         xrr=MAX(R1,(qr1d(k) + qrten(k)*dtsave)*rho(k))
+         xnr=MAX(R2,(nr1d(k) + nrten(k)*dtsave)*rho(k))
+         if (xrr.gt. R1) then
+           lamr = (am_r*crg(3)*org2*xnr/xrr)**obmr
+           mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
+           if (mvd_r(k) .gt. 2.5E-3) then
+              mvd_r(k) = 2.5E-3
+              lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
+              xnr = crg(2)*org3*xrr*lamr**bm_r / am_r
+              nrten(k) = (xnr-nr1d(k)*rho(k))*odts*orho
+           elseif (mvd_r(k) .lt. D0r*0.75) then
+              mvd_r(k) = D0r*0.75
+              lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
+              xnr = crg(2)*org3*xrr*lamr**bm_r / am_r
+              nrten(k) = (xnr-nr1d(k)*rho(k))*odts*orho
+           endif
+         else
+           qrten(k) = -qr1d(k)*odts
+           nrten(k) = -nr1d(k)*odts
+         endif
+
+!..Snow tendency
+         qsten(k) = qsten(k) + (prs_iau(k) + prs_sde(k) &
+                      + prs_sci(k) + prs_scw(k) + prs_rcs(k) &
+                      + prs_ide(k) - prs_ihm(k) - prr_sml(k)) &
+                      * orho
+
+!..Graupel tendency
+         qgten(k) = qgten(k) + (prg_scw(k) + prg_rfz(k) &
+                      + prg_gde(k) + prg_rcg(k) + prg_gcw(k) &
+                      + prg_rci(k) + prg_rcs(k) - prg_ihm(k) &
+                      - prr_gml(k)) &
+                      * orho
+
+!..Temperature tendency
+         if (temp(k).lt.T_0) then
+          tten(k) = tten(k) &
+                    + ( lsub*ocp(k)*(pri_inu(k) + pri_ide(k) &
+                                     + prs_ide(k) + prs_sde(k) &
+                                     + prg_gde(k)) &
+                     + lfus2*ocp(k)*(pri_wfz(k) + pri_rfz(k) &
+                                     + prg_rfz(k) + prs_scw(k) &
+                                     + prg_scw(k) + prg_gcw(k) &
+                                     + prg_rcs(k) + prs_rcs(k) &
+                                     + prr_rci(k) + prg_rcg(k)) &
+                       )*orho * (1-IFDRY)
+         else
+          tten(k) = tten(k) &
+                    + ( lfus*ocp(k)*(-prr_sml(k) - prr_gml(k) &
+                                     - prr_rcg(k) - prr_rcs(k)) &
+                      + lsub*ocp(k)*(prs_sde(k) + prg_gde(k)) &
+                       )*orho * (1-IFDRY)
+         endif
+
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Update variables for TAU+1 before condensation & sedimention.
+!+---+-----------------------------------------------------------------+
+      do k = kts, kte
+         temp(k) = t1d(k) + DT*tten(k)
+         otemp = 1./temp(k)
+         tempc = temp(k) - 273.15
+         qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k))
+         rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622))
+         rhof(k) = SQRT(RHO_NOT/rho(k))
+         rhof2(k) = SQRT(rhof(k))
+         qvs(k) = rslf(pres(k), temp(k))
+         ssatw(k) = qv(k)/qvs(k) - 1.
+         if (abs(ssatw(k)).lt. eps) ssatw(k) = 0.0
+         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
+         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
+         ocp(k) = 1./(Cp*(1.+0.887*qv(k)))
+         lvt2(k)=lvap(k)*lvap(k)*ocp(k)*oRv*otemp*otemp
+
+         if ((qc1d(k) + qcten(k)*DT) .gt. R1) then
+            rc(k) = (qc1d(k) + qcten(k)*DT)*rho(k)
+            L_qc(k) = .true.
+         else
+            rc(k) = R1
+            L_qc(k) = .false.
+         endif
+
+         if ((qi1d(k) + qiten(k)*DT) .gt. R1) then
+            ri(k) = (qi1d(k) + qiten(k)*DT)*rho(k)
+            ni(k) = MAX(R2, (ni1d(k) + niten(k)*DT)*rho(k))
+            L_qi(k) = .true. 
+         else
+            ri(k) = R1
+            ni(k) = R2
+            L_qi(k) = .false.
+         endif
+
+         if ((qr1d(k) + qrten(k)*DT) .gt. R1) then
+            rr(k) = (qr1d(k) + qrten(k)*DT)*rho(k)
+            nr(k) = MAX(R2, (nr1d(k) + nrten(k)*DT)*rho(k))
+            L_qr(k) = .true.
+         else
+            rr(k) = R1
+            nr(k) = R2
+            L_qr(k) = .false.
+         endif
+               
+         if ((qs1d(k) + qsten(k)*DT) .gt. R1) then
+            rs(k) = (qs1d(k) + qsten(k)*DT)*rho(k)
+            L_qs(k) = .true.
+         else
+            rs(k) = R1
+            L_qs(k) = .false.
+         endif
+
+         if ((qg1d(k) + qgten(k)*DT) .gt. R1) then
+            rg(k) = (qg1d(k) + qgten(k)*DT)*rho(k)
+            L_qg(k) = .true.
+         else
+            rg(k) = R1
+            L_qg(k) = .false.
+         endif
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..With tendency-updated mixing ratios, recalculate snow moments and
+!.. intercepts/slopes of graupel and rain.
+!+---+-----------------------------------------------------------------+
+      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 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 bm_s+bv_s (th) moment.  Useful for sedimentation.
+         loga_ = sa(1) + sa(2)*tc0 + sa(3)*cse(14) &
+               + sa(4)*tc0*cse(14) + sa(5)*tc0*tc0 &
+               + sa(6)*cse(14)*cse(14) + sa(7)*tc0*tc0*cse(14) &
+               + sa(8)*tc0*cse(14)*cse(14) + sa(9)*tc0*tc0*tc0 &
+               + sa(10)*cse(14)*cse(14)*cse(14)
+         a_ = 10.0**loga_
+         b_ = sb(1)+ sb(2)*tc0 + sb(3)*cse(14) + sb(4)*tc0*cse(14) &
+              + sb(5)*tc0*tc0 + sb(6)*cse(14)*cse(14) &
+              + sb(7)*tc0*tc0*cse(14) + sb(8)*tc0*cse(14)*cse(14) &
+              + sb(9)*tc0*tc0*tc0 + sb(10)*cse(14)*cse(14)*cse(14)
+         smod(k) = a_ * smo2(k)**b_
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Calculate y-intercept, slope values for graupel.
+!+---+-----------------------------------------------------------------+
+      N0_min = gonv_max
+      do k = kte, kts, -1
+         if (temp(k).lt.T_0 .and. (rc(k)+rr(k)).gt.1.E-5) then
+            xslw1 = 5. + alog10(max(1.E-5, min(1.E-2, (rc(k)+rr(k)))))
+         else
+            xslw1 = 0.
+         endif
+         ygra1 = 5. + alog10(max(1.E-5, min(1.E-2, rg(k))))
+         zans1 = 3.324 + (3./(5.*xslw1*ygra1/(5.*xslw1+1.+0.25*ygra1)+1.+0.25*ygra1))
+         N0_exp = 10.**(zans1)
+         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.
+!+---+-----------------------------------------------------------------+
+      do k = kte, kts, -1
+         lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
+         ilamr(k) = 1./lamr
+         mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
+         N0_r(k) = nr(k)*org2*lamr**cre(2)
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Cloud water condensation and evaporation.  Newly formulated using
+!.. Newton-Raphson iterations (3 should suffice) as provided by B. Hall.
+!+---+-----------------------------------------------------------------+
+      do k = kts, kte
+         if ( (ssatw(k).gt. eps) .or. (ssatw(k).lt. -eps .and. &
+                   L_qc(k)) ) then
+          clap = (qv(k)-qvs(k))/(1. + lvt2(k)*qvs(k))
+          do n = 1, 3
+             fcd = qvs(k)* EXP(lvt2(k)*clap) - qv(k) + clap
+             dfcd = qvs(k)*lvt2(k)* EXP(lvt2(k)*clap) + 1.
+             clap = clap - fcd/dfcd
+          enddo
+          xrc = rc(k) + clap
+          if (xrc.gt. 0.0) then
+             prw_vcd(k) = clap*odt
+          else
+             prw_vcd(k) = -rc(k)/rho(k)*odt
+          endif
+
+          qcten(k) = qcten(k) + prw_vcd(k)
+          qvten(k) = qvten(k) - prw_vcd(k)
+          tten(k) = tten(k) + lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)
+          rc(k) = MAX(R1, (qc1d(k) + DT*qcten(k))*rho(k))
+          qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k))
+          temp(k) = t1d(k) + DT*tten(k)
+          rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622))
+          qvs(k) = rslf(pres(k), temp(k))
+          ssatw(k) = qv(k)/qvs(k) - 1.
+         endif
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!.. If still subsaturated, allow rain to evaporate, following
+!.. Srivastava & Coen (1992).
+!+---+-----------------------------------------------------------------+
+      do k = kts, kte
+         if ( (ssatw(k).lt. -eps) .and. L_qr(k) &
+                     .and. (.not.(prw_vcd(k).gt. 0.)) ) then
+          tempc = temp(k) - 273.15
+          otemp = 1./temp(k)
+          rhof(k) = SQRT(RHO_NOT/rho(k))
+          rhof2(k) = SQRT(rhof(k))
+          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
+          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
+          ocp(k) = 1./(Cp*(1.+0.887*qv(k)))
+
+          rvs = rho(k)*qvs(k)
+          rvs_p = rvs*otemp*(lvap(k)*otemp*oRv - 1.)
+          rvs_pp = rvs * ( otemp*(lvap(k)*otemp*oRv - 1.) &
+                          *otemp*(lvap(k)*otemp*oRv - 1.) &
+                          + (-2.*lvap(k)*otemp*otemp*otemp*oRv) &
+                          + otemp*otemp)
+          gamsc = lvap(k)*diffu(k)/tcond(k) * rvs_p
+          alphsc = 0.5*(gamsc/(1.+gamsc))*(gamsc/(1.+gamsc)) &
+                     * rvs_pp/rvs_p * rvs/rvs_p
+          alphsc = MAX(1.E-9, alphsc)
+          xsat   = MIN(-1.E-9, ssatw(k))
+          t1_evap = 2.*PI*( 1.0 - alphsc*xsat  &
+                 + 2.*alphsc*alphsc*xsat*xsat  &
+                 - 5.*alphsc*alphsc*alphsc*xsat*xsat*xsat ) &
+                 / (1.+gamsc)
+
+          lamr = 1./ilamr(k)
+          prv_rev(k) = t1_evap*diffu(k)*(-ssatw(k))*N0_r(k)*rvs &
+              * (t1_qr_ev*ilamr(k)**cre(10) &
+              + t2_qr_ev*vsc2(k)*rhof2(k)*((lamr+0.5*fv_r)**(-cre(11))))
+          rate_max = MIN((rr(k)/rho(k)*odts), (qvs(k)-qv(k))*odts)
+          prv_rev(k) = MIN(DBLE(rate_max), prv_rev(k)/rho(k))
+          pnr_rev(k) = MIN(DBLE(nr(k)*0.99/rho(k)*odts),                &   ! RAIN2M
+                       prv_rev(k) * nr(k)/rr(k))
+
+          qrten(k) = qrten(k) - prv_rev(k)
+          qvten(k) = qvten(k) + prv_rev(k)
+          nrten(k) = nrten(k) - pnr_rev(k)
+          tten(k) = tten(k) - lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY)
+
+          rr(k) = MAX(R1, (qr1d(k) + DT*qrten(k))*rho(k))
+          qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k))
+          nr(k) = MAX(R2, (nr1d(k) + DT*nrten(k))*rho(k))
+          temp(k) = t1d(k) + DT*tten(k)
+          rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622))
+         endif
+
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Find max terminal fallspeed (distribution mass-weighted mean
+!.. velocity) and use it to determine if we need to split the timestep
+!.. (var nstep>1).  Either way, only bother to do sedimentation below
+!.. 1st level that contains any sedimenting particles (k=ksed1 on down).
+!.. New in v3.0+ is computing separate for rain, ice, snow, and
+!.. graupel species thus making code faster with credit to J. Schmidt.
+!+---+-----------------------------------------------------------------+
+      nstep = 0
+      onstep(:) = 1.0
+      ksed1(:) = 1
+      do k = kte+1, kts, -1
+         vtrk(k) = 0.
+         vtnrk(k) = 0.
+         vtik(k) = 0.
+         vtnik(k) = 0.
+         vtsk(k) = 0.
+         vtgk(k) = 0.
+      enddo
+      do k = kte, kts, -1
+         vtr = 0.
+         rhof(k) = SQRT(RHO_NOT/rho(k))
+
+         if (rr(k).gt. R1) then
+          lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
+          vtr = rhof(k)*av_r*crg(6)*org3 * lamr**cre(3)                 &
+                      *((lamr+fv_r)**(-cre(6)))
+          vtrk(k) = vtr
+! First below is technically correct:
+!         vtr = rhof(k)*av_r*crg(5)*org2 * lamr**cre(2)                 &
+!                     *((lamr+fv_r)**(-cre(5)))
+! Test: make number fall faster (but still slower than mass)
+! Goal: less prominent size sorting
+          vtr = rhof(k)*av_r*crg(7)/crg(12) * lamr**cre(12)             &
+                      *((lamr+fv_r)**(-cre(7)))
+          vtnrk(k) = vtr
+         endif
+
+         if (MAX(vtrk(k),vtnrk(k)) .gt. 1.E-3) then
+            ksed1(1) = MAX(ksed1(1), k)
+            delta_tp = dzq(k)/(MAX(vtrk(k),vtnrk(k)))
+            nstep = MAX(nstep, INT(DT/delta_tp + 1.))
+         endif
+      enddo
+      if (ksed1(1) .eq. kte) ksed1(1) = kte-1
+      if (nstep .gt. 0) onstep(1) = 1./REAL(nstep)
+
+!+---+-----------------------------------------------------------------+
+
+      if (.not. iiwarm) then
+
+       nstep = 0
+       do k = kte, kts, -1
+          vti = 0.
+
+          if (ri(k).gt. R1) 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
+! First below is technically correct:
+!          vti = rhof(k)*av_i*cig(4)*oig1 * ilami**bv_i
+! Goal: less prominent size sorting
+           vti = rhof(k)*av_i*cig(6)/cig(7) * ilami**bv_i
+           vtnik(k) = vti
+          endif
+
+          if (vtik(k) .gt. 1.E-3) then
+             ksed1(2) = MAX(ksed1(2), k)
+             delta_tp = dzq(k)/vtik(k)
+             nstep = MAX(nstep, INT(DT/delta_tp + 1.))
+          endif
+       enddo
+       if (ksed1(2) .eq. kte) ksed1(2) = kte-1
+       if (nstep .gt. 0) onstep(2) = 1./REAL(nstep)
+
+!+---+-----------------------------------------------------------------+
+
+       nstep = 0
+       do k = kte, kts, -1
+          vts = 0.
+
+          if (rs(k).gt. R2) then
+           xDs = smoc(k) / smob(k)
+           Mrat = 1./xDs
+           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)
+           ils1 = 1./(Mrat*Lam0)
+           ils2 = 1./(Mrat*Lam1)
+           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 (vtsk(k) .gt. 1.E-3) then
+             ksed1(3) = MAX(ksed1(3), k)
+             delta_tp = dzq(k)/vtsk(k)
+             nstep = MAX(nstep, INT(DT/delta_tp + 1.))
+          endif
+       enddo
+       if (ksed1(3) .eq. kte) ksed1(3) = kte-1
+       if (nstep .gt. 0) onstep(3) = 1./REAL(nstep)
+
+!+---+-----------------------------------------------------------------+
+
+       nstep = 0
+       do k = kte, kts, -1
+          vtg = 0.
+
+          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
+
+          if (vtgk(k) .gt. 1.E-3) then
+             ksed1(4) = MAX(ksed1(4), k)
+             delta_tp = dzq(k)/vtgk(k)
+             nstep = MAX(nstep, INT(DT/delta_tp + 1.))
+          endif
+       enddo
+       if (ksed1(4) .eq. kte) ksed1(4) = kte-1
+       if (nstep .gt. 0) onstep(4) = 1./REAL(nstep)
+      endif
+
+!+---+-----------------------------------------------------------------+
+!..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.
+!.. New in v3.0+ is computing separate for rain, ice, snow, and
+!.. graupel species thus making code faster with credit to J. Schmidt.
+!+---+-----------------------------------------------------------------+
+
+      nstep = NINT(1./onstep(1))
+      do n = 1, nstep
+         do k = kte, kts, -1
+            sed_r(k) = vtrk(k)*rr(k)
+            sed_n(k) = vtnrk(k)*nr(k)
+         enddo
+         k = kte
+         odzq = 1./dzq(k)
+         orho = 1./rho(k)
+         qrten(k) = qrten(k) - sed_r(k)*odzq*onstep(1)*orho
+         nrten(k) = nrten(k) - sed_n(k)*odzq*onstep(1)*orho
+         rr(k) = MAX(R1, rr(k) - sed_r(k)*odzq*DT*onstep(1))
+         nr(k) = MAX(R2, nr(k) - sed_n(k)*odzq*DT*onstep(1))
+         do k = ksed1(1), kts, -1
+            odzq = 1./dzq(k)
+            orho = 1./rho(k)
+            qrten(k) = qrten(k) + (sed_r(k+1)-sed_r(k)) &
+                                               *odzq*onstep(1)*orho
+            nrten(k) = nrten(k) + (sed_n(k+1)-sed_n(k)) &
+                                               *odzq*onstep(1)*orho
+            rr(k) = MAX(R1, rr(k) + (sed_r(k+1)-sed_r(k)) &
+                                           *odzq*DT*onstep(1))
+            nr(k) = MAX(R2, nr(k) + (sed_n(k+1)-sed_n(k)) &
+                                           *odzq*DT*onstep(1))
+         enddo
+
+         pptrain = pptrain + sed_r(kts)*DT*onstep(1)
+      enddo
+
+!+---+-----------------------------------------------------------------+
+
+      nstep = NINT(1./onstep(2))
+      do n = 1, nstep
+         do k = kte, kts, -1
+            sed_i(k) = vtik(k)*ri(k)
+            sed_n(k) = vtnik(k)*ni(k)
+         enddo
+         k = kte
+         odzq = 1./dzq(k)
+         orho = 1./rho(k)
+         qiten(k) = qiten(k) - sed_i(k)*odzq*onstep(2)*orho
+         niten(k) = niten(k) - sed_n(k)*odzq*onstep(2)*orho
+         ri(k) = MAX(R1, ri(k) - sed_i(k)*odzq*DT*onstep(2))
+         ni(k) = MAX(R2, ni(k) - sed_n(k)*odzq*DT*onstep(2))
+         do k = ksed1(2), kts, -1
+            odzq = 1./dzq(k)
+            orho = 1./rho(k)
+            qiten(k) = qiten(k) + (sed_i(k+1)-sed_i(k)) &
+                                               *odzq*onstep(2)*orho
+            niten(k) = niten(k) + (sed_n(k+1)-sed_n(k)) &
+                                               *odzq*onstep(2)*orho
+            ri(k) = MAX(R1, ri(k) + (sed_i(k+1)-sed_i(k)) &
+                                           *odzq*DT*onstep(2))
+            ni(k) = MAX(R2, ni(k) + (sed_n(k+1)-sed_n(k)) &
+                                           *odzq*DT*onstep(2))
+         enddo
+
+         pptice = pptice + sed_i(kts)*DT*onstep(2)
+      enddo
+
+!+---+-----------------------------------------------------------------+
+
+      nstep = NINT(1./onstep(3))
+      do n = 1, nstep
+         do k = kte, kts, -1
+            sed_s(k) = vtsk(k)*rs(k)
+         enddo
+         k = kte
+         odzq = 1./dzq(k)
+         orho = 1./rho(k)
+         qsten(k) = qsten(k) - sed_s(k)*odzq*onstep(3)*orho
+         rs(k) = MAX(R1, rs(k) - sed_s(k)*odzq*DT*onstep(3))
+         do k = ksed1(3), kts, -1
+            odzq = 1./dzq(k)
+            orho = 1./rho(k)
+            qsten(k) = qsten(k) + (sed_s(k+1)-sed_s(k)) &
+                                               *odzq*onstep(3)*orho
+            rs(k) = MAX(R1, rs(k) + (sed_s(k+1)-sed_s(k)) &
+                                           *odzq*DT*onstep(3))
+         enddo
+
+         pptsnow = pptsnow + sed_s(kts)*DT*onstep(3)
+      enddo
+
+!+---+-----------------------------------------------------------------+
+
+      nstep = NINT(1./onstep(4))
+      do n = 1, nstep
+         do k = kte, kts, -1
+            sed_g(k) = vtgk(k)*rg(k)
+         enddo
+         k = kte
+         odzq = 1./dzq(k)
+         orho = 1./rho(k)
+         qgten(k) = qgten(k) - sed_g(k)*odzq*onstep(4)*orho
+         rg(k) = MAX(R1, rg(k) - sed_g(k)*odzq*DT*onstep(4))
+         do k = ksed1(4), kts, -1
+            odzq = 1./dzq(k)
+            orho = 1./rho(k)
+            qgten(k) = qgten(k) + (sed_g(k+1)-sed_g(k)) &
+                                               *odzq*onstep(4)*orho
+            rg(k) = MAX(R1, rg(k) + (sed_g(k+1)-sed_g(k)) &
+                                           *odzq*DT*onstep(4))
+         enddo
+
+         pptgraul = pptgraul + sed_g(kts)*DT*onstep(4)
+      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) = qiten(k) - xri*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/xm0i * odt
+          qcten(k) = 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. R2) then
+            lami = (am_i*cig(2)*oig1*ni1d(k)/qi1d(k))**obmi
+            ilami = 1./lami
+            xDi = (bm_i + mu_i + 1.) * ilami
+            if (xDi.lt. 20.E-6) then
+             lami = cie(2)/20.E-6
+            elseif (xDi.gt. 300.E-6) then
+             lami = cie(2)/300.E-6
+            endif
+           else
+            lami = cie(2)/D0s
+           endif
+           ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i,           &
+                         500.D3/rho(k))
+         endif
+         qr1d(k) = qr1d(k) + qrten(k)*DT
+         nr1d(k) = nr1d(k) + nrten(k)*DT
+         if (qr1d(k) .le. R1) then
+           qr1d(k) = 0.0
+           nr1d(k) = 0.0
+         else
+           if (nr1d(k) .gt. R2) then
+            lamr = (am_r*crg(3)*org2*nr1d(k)/qr1d(k))**obmr
+            mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
+            if (mvd_r(k) .gt. 2.5E-3) then
+               mvd_r(k) = 2.5E-3
+            elseif (mvd_r(k) .lt. D0r*0.75) then
+               mvd_r(k) = D0r*0.75
+            endif
+           else
+            if (qr1d(k) .gt. R2) then
+               mvd_r(k) = 2.5E-3
+            else
+               mvd_r(k) = 2.5E-3 / 3.0**(ALOG10(R2)-ALOG10(qr1d(k)))
+            endif
+           endif
+           lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
+           nr1d(k) = crg(2)*org3*qr1d(k)*lamr**bm_r / am_r
+         endif
+         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
+!+---+-----------------------------------------------------------------+
+!ctrlL
+!+---+-----------------------------------------------------------------+
+!..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, m, n, n2
+      INTEGER:: km, km_s, km_e
+      DOUBLE PRECISION, DIMENSION(nbg):: vg, N_g
+      DOUBLE PRECISION, DIMENSION(nbr):: vr, N_r
+      DOUBLE PRECISION:: N0_r, N0_g, lam_exp, lamg, lamr
+      DOUBLE PRECISION:: massg, massr, dvg, dvr, t1, t2, z1, z2, y1, y2
+
+!+---+
+
+      do n2 = 1, nbr
+!        vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2))
+         vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2)     &
+              + 0.07934E9*Dr(n2)*Dr(n2)*Dr(n2)                          &
+              - 0.002362E12*Dr(n2)*Dr(n2)*Dr(n2)*Dr(n2)
+      enddo
+      do n = 1, nbg
+         vg(n) = av_g*Dg(n)**bv_g
+      enddo
+
+!..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for
+!.. fortran indices.  J. Michalakes, 2009Oct30.
+
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+      CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e )
+#else
+      km_s = 0
+      km_e = ntb_r*ntb_r1 - 1
+#endif
+
+      do km = km_s, km_e
+         m = km / ntb_r1 + 1
+         k = mod( km , ntb_r1 ) + 1
+
+         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_g
+         do i = 1, ntb_g1
+            lam_exp = (N0g_exp(i)*am_g*cgg(1)/r_g(j))**oge1
+            lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
+            N0_g = N0g_exp(i)/(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
+            y1 = 0.0d0
+            y2 = 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)
+                  y1 = y1+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) &
+                      *dvg       * 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)
+                  y2 = y2+ PI*.25*Ef_rg*(Dg(n)+Dr(n2))*(Dg(n)+Dr(n2)) &
+                      *dvr       * 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,m) = t1
+            tmr_racg(i,j,k,m) = DMIN1(z1, r_r(m)*1.0d0)
+            tcr_gacr(i,j,k,m) = t2
+            tmg_gacr(i,j,k,m) = z2
+            tnr_racg(i,j,k,m) = y1
+            tnr_gacr(i,j,k,m) = y2
+         enddo
+         enddo
+      enddo
+
+!..Note wrf_dm_gatherv expects zero-based km_s, km_e (J. Michalakes, 2009Oct30).
+
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+      CALL wrf_dm_gatherv(tcg_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tmr_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tcr_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tmg_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tnr_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tnr_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE)
+#endif
+
+
+      end subroutine qr_acr_qg
+!+---+-----------------------------------------------------------------+
+!ctrlL
+!+---+-----------------------------------------------------------------+
+!..Rain collecting snow (and inverse).  Explicit CE integration.
+!+---+-----------------------------------------------------------------+
+
+      subroutine qr_acr_qs
+
+      implicit none
+
+!..Local variables
+      INTEGER:: i, j, k, m, n, n2
+      INTEGER:: km, km_s, km_e
+      DOUBLE PRECISION, DIMENSION(nbr):: vr, D1, N_r
+      DOUBLE PRECISION, DIMENSION(nbs):: vs, N_s
+      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
+      DOUBLE PRECISION:: y1, y2, y3, y4
+
+!+---+
+
+      do n2 = 1, nbr
+!        vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2))
+         vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2)     &
+              + 0.07934E9*Dr(n2)*Dr(n2)*Dr(n2)                          &
+              - 0.002362E12*Dr(n2)*Dr(n2)*Dr(n2)*Dr(n2)
+         D1(n2) = (vr(n2)/av_s)**(1./bv_s)
+      enddo
+      do n = 1, nbs
+         vs(n) = 1.5*av_s*Ds(n)**bv_s * DEXP(-fv_s*Ds(n))
+      enddo
+
+!..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for
+!.. fortran indices.  J. Michalakes, 2009Oct30.
+
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+      CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e )
+#else
+      km_s = 0
+      km_e = ntb_r*ntb_r1 - 1
+#endif
+
+      do km = km_s, km_e
+         m = km / ntb_r1 + 1
+         k = mod( km , ntb_r1 ) + 1
+
+         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
+               y1 = 0.0d0
+               y2 = 0.0d0
+               y3 = 0.0d0
+               y4 = 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. 2.5*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)
+                     y1 = y1+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
+                         *dvs       * 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)
+                     y3 = y3+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
+                         *dvs       * N_s(n)* N_r(n2)
+                     endif
+
+                     if (massr .gt. 2.5*masss) then
+                     t2 = t2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
+                         *dvr*massr * N_s(n)* N_r(n2)
+                     y2 = y2+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
+                         *dvr       * 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)
+                     y4 = y4+ PI*.25*Ef_rs*(Ds(n)+Dr(n2))*(Ds(n)+Dr(n2)) &
+                         *dvr       * 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
+               tnr_racs1(i,j,k,m) = y1
+               tnr_racs2(i,j,k,m) = y3
+               tnr_sacr1(i,j,k,m) = y2
+               tnr_sacr2(i,j,k,m) = y4
+            enddo
+         enddo
+      enddo
+
+!..Note wrf_dm_gatherv expects zero-based km_s, km_e (J. Michalakes, 2009Oct30).
+
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+      CALL wrf_dm_gatherv(tcs_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tmr_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tcs_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tmr_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tcr_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tms_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tcr_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tms_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tnr_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tnr_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tnr_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE)
+      CALL wrf_dm_gatherv(tnr_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE)
+#endif
+
+
+      end subroutine qr_acr_qs
+!+---+-----------------------------------------------------------------+
+!ctrlL
+!+---+-----------------------------------------------------------------+
+!..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
+      DOUBLE PRECISION, DIMENSION(nbr):: N_r, massr
+      DOUBLE PRECISION, DIMENSION(nbc):: N_c, 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
+
+      do n2 = 1, nbr
+         massr(n2) = am_r*Dr(n2)**bm_r
+      enddo
+      do n = 1, nbc
+         massc(n) = am_r*Dc(n)**bm_r
+      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
+               sumn2 = 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
+                     sumn2 = sumn2 + prob*N_r(n2)
+                     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
+               tnr_qrfz(i,j,k) = sumn2
+            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.0D24 * 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
+!+---+-----------------------------------------------------------------+
+!ctrlL
+!+---+-----------------------------------------------------------------+
+!..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
+      DOUBLE PRECISION, DIMENSION(nbi):: N_i
+      DOUBLE PRECISION:: N0_i, lami, Di_mean, t1, t2
+      REAL:: xlimit_intg
+
+!+---+
+
+      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
+             xlimit_intg = lami*D0s
+             tpi_ide(i,j) = GAMMP(mu_i+2.0, xlimit_intg) * 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
+!ctrlL
+!+---+-----------------------------------------------------------------+
+!..Variable collision efficiency for rain collecting cloud water using
+!.. method of Beard and Grover, 1974 if a/A less than 0.25; otherwise
+!.. uses polynomials to get close match of Pruppacher & Klett Fig 14-9.
+!+---+-----------------------------------------------------------------+
+
+      subroutine table_Efrw
+
+      implicit none
+
+!..Local variables
+      DOUBLE PRECISION:: vtr, stokes, reynolds, Ef_rw
+      DOUBLE PRECISION:: p, yc0, F, G, H, z, K0, X
+      INTEGER:: i, j
+
+      do j = 1, nbc
+      do i = 1, nbr
+         Ef_rw = 0.0
+         p = Dc(j)/Dr(i)
+         if (Dr(i).lt.50.E-6 .or. Dc(j).lt.3.E-6) then
+          t_Efrw(i,j) = 0.0
+         elseif (p.gt.0.25) then
+          X = Dc(j)*1.D6
+          if (Dr(i) .lt. 75.e-6) then
+             Ef_rw = 0.026794*X - 0.20604
+          elseif (Dr(i) .lt. 125.e-6) then
+             Ef_rw = -0.00066842*X*X + 0.061542*X - 0.37089
+          elseif (Dr(i) .lt. 175.e-6) then
+             Ef_rw = 4.091e-06*X*X*X*X - 0.00030908*X*X*X               &
+                   + 0.0066237*X*X - 0.0013687*X - 0.073022
+          elseif (Dr(i) .lt. 250.e-6) then
+             Ef_rw = 9.6719e-5*X*X*X - 0.0068901*X*X + 0.17305*X        &
+                   - 0.65988
+          elseif (Dr(i) .lt. 350.e-6) then
+             Ef_rw = 9.0488e-5*X*X*X - 0.006585*X*X + 0.16606*X         &
+                   - 0.56125
+          else
+             Ef_rw = 0.00010721*X*X*X - 0.0072962*X*X + 0.1704*X        &
+                   - 0.46929
+          endif
+         else
+          vtr = -0.1021 + 4.932E3*Dr(i) - 0.9551E6*Dr(i)*Dr(i) &
+              + 0.07934E9*Dr(i)*Dr(i)*Dr(i) &
+              - 0.002362E12*Dr(i)*Dr(i)*Dr(i)*Dr(i)
+          stokes = Dc(j)*Dc(j)*vtr*rho_w/(9.*1.718E-5*Dr(i))
+          reynolds = 9.*stokes/(p*p*rho_w)
+
+          F = DLOG(reynolds)
+          G = -0.1007D0 - 0.358D0*F + 0.0261D0*F*F
+          K0 = DEXP(G)
+          z = DLOG(stokes/(K0+1.D-15))
+          H = 0.1465D0 + 1.302D0*z - 0.607D0*z*z + 0.293D0*z*z*z
+          yc0 = 2.0D0/PI * ATAN(H)
+          Ef_rw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p))
+
+         endif
+
+         t_Efrw(i,j) = MAX(0.0, MIN(SNGL(Ef_rw), 0.95))
+
+      enddo
+      enddo
+
+      end subroutine table_Efrw
+!ctrlL
+!+---+-----------------------------------------------------------------+
+!..Variable collision efficiency for snow collecting cloud water using
+!.. method of Wang and Ji, 2000 except equate melted snow diameter to
+!.. their "effective collision cross-section."
+!+---+-----------------------------------------------------------------+
+
+      subroutine table_Efsw
+
+      implicit none
+
+!..Local variables
+      DOUBLE PRECISION:: Ds_m, vts, vtc, stokes, reynolds, Ef_sw
+      DOUBLE PRECISION:: p, yc0, F, G, H, z, K0
+      INTEGER:: i, j
+
+      do j = 1, nbc
+      vtc = 1.19D4 * (1.0D4*Dc(j)*Dc(j)*0.25D0)
+      do i = 1, nbs
+         vts = av_s*Ds(i)**bv_s * DEXP(-fv_s*Ds(i)) - vtc
+         Ds_m = (am_s*Ds(i)**bm_s / am_r)**obmr
+         p = Dc(j)/Ds_m
+         if (p.gt.0.25 .or. Ds(i).lt.D0s .or. Dc(j).lt.6.E-6 &
+               .or. vts.lt.1.E-3) then
+          t_Efsw(i,j) = 0.0
+         else
+          stokes = Dc(j)*Dc(j)*vts*rho_w/(9.*1.718E-5*Ds_m)
+          reynolds = 9.*stokes/(p*p*rho_w)
+
+          F = DLOG(reynolds)
+          G = -0.1007D0 - 0.358D0*F + 0.0261D0*F*F
+          K0 = DEXP(G)
+          z = DLOG(stokes/(K0+1.D-15))
+          H = 0.1465D0 + 1.302D0*z - 0.607D0*z*z + 0.293D0*z*z*z
+          yc0 = 2.0D0/PI * ATAN(H)
+          Ef_sw = (yc0+p)*(yc0+p) / ((1.+p)*(1.+p))
+
+          t_Efsw(i,j) = MAX(0.0, MIN(SNGL(Ef_sw), 0.95))
+         endif
+
+      enddo
+      enddo
+
+      end subroutine table_Efsw
+!ctrlL
+!+---+-----------------------------------------------------------------+
+!..Integrate rain size distribution from zero to D-star to compute the
+!.. number of drops smaller than D-star that evaporate in a single
+!.. timestep.  Drops larger than D-star dont evaporate entirely so do
+!.. not affect number concentration.
+!+---+-----------------------------------------------------------------+
+
+      subroutine table_dropEvap
+
+      implicit none
+
+!..Local variables
+      DOUBLE PRECISION:: Nt_r, N0, lam_exp, lam
+      REAL:: xlimit_intg
+      INTEGER:: i, j, k
+
+      do k = 1, ntb_r
+      do j = 1, ntb_r1
+         lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(k))**ore1
+         lam = lam_exp * (crg(3)*org2*org1)**obmr
+         N0 = N0r_exp(j)/(crg(2)*lam_exp) * lam**cre(2)
+         Nt_r = N0 * crg(2) / lam**cre(2)
+
+         do i = 1, nbr
+            xlimit_intg = lam*Dr(i)
+            tnr_rev(i,j,k) = GAMMP(mu_r+1.0, xlimit_intg) * Nt_r
+         enddo
+
+      enddo
+      enddo
+
+      end subroutine table_dropEvap
+
+! TO APPLY TABLE ABOVE
+!..Rain lookup table indexes.
+!         Dr_star = DSQRT(-2.D0*DT * t1_evap/(2.*PI) &
+!                 * 0.78*4.*diffu(k)*xsat*rvs/rho_w)
+!         idx_d = NINT(1.0 + FLOAT(nbr) * DLOG(Dr_star/D0r)             &
+!               / DLOG(Dr(nbr)/D0r))
+!         idx_d = MAX(1, MIN(idx_d, nbr))
+!
+!         nir = NINT(ALOG10(rr(k)))
+!         do nn = nir-1, nir+1
+!            n = nn
+!            if ( (rr(k)/10.**nn).ge.1.0 .and. &
+!                 (rr(k)/10.**nn).lt.10.0) goto 154
+!         enddo
+!154      continue
+!         idx_r = INT(rr(k)/10.**n) + 10*(n-nir2) - (n-nir2)
+!         idx_r = MAX(1, MIN(idx_r, ntb_r))
+!
+!         lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
+!         lam_exp = lamr * (crg(3)*org2*org1)**bm_r
+!         N0_exp = org1*rr(k)/am_r * lam_exp**cre(1)
+!         nir = NINT(DLOG10(N0_exp))
+!         do nn = nir-1, nir+1
+!            n = nn
+!            if ( (N0_exp/10.**nn).ge.1.0 .and. &
+!                 (N0_exp/10.**nn).lt.10.0) goto 155
+!         enddo
+!155      continue
+!         idx_r1 = INT(N0_exp/10.**n) + 10*(n-nir3) - (n-nir3)
+!         idx_r1 = MAX(1, MIN(idx_r1, ntb_r1))
+!
+!         pnr_rev(k) = MIN(nr(k)*odts, SNGL(tnr_rev(idx_d,idx_r1,idx_r) &   ! RAIN2M
+!                    * odts))
+!
+!ctrlL
+!+---+-----------------------------------------------------------------+
+!+---+-----------------------------------------------------------------+
+      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)
+
+!    ALTERNATIVE
+!  ; Source: Murphy and Koop, Review of the vapour pressure of ice and
+!             supercooled water for atmospheric applications, Q. J. R.
+!             Meteorol. Soc (2005), 131, pp. 1539-1565.
+!    ESL = EXP(54.842763 - 6763.22 / T - 4.210 * ALOG(T) + 0.000367 * T
+!        + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22
+!        / T - 9.44523 * ALOG(T) + 0.014025 * T))
+
+      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)
+
+!    ALTERNATIVE
+!  ; Source: Murphy and Koop, Review of the vapour pressure of ice and
+!             supercooled water for atmospheric applications, Q. J. R.
+!             Meteorol. Soc (2005), 131, pp. 1539-1565.
+!     ESI = EXP(9.550426 - 5723.265/T + 3.53068*ALOG(T) - 0.00728332*T)
+
+      END FUNCTION RSIF
+!+---+-----------------------------------------------------------------+
+
+!+---+-----------------------------------------------------------------+
+END MODULE module_mp_thompson
+!+---+-----------------------------------------------------------------+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wdm5.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wdm5.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wdm5.F	(revision 17)
@@ -0,0 +1,2014 @@
+#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_wdm5
+!
+!
+   REAL, PARAMETER, PRIVATE :: dtcldcr     = 120. ! maximum time step for minor loops
+   REAL, PARAMETER, PRIVATE :: n0r = 8.e6         ! intercept parameter rain
+   REAL, PARAMETER, PRIVATE :: avtr = 841.9       ! a constant for terminal velocity of rain  
+   REAL, PARAMETER, PRIVATE :: bvtr = 0.8         ! a constant for terminal velocity of rain
+   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       ! a constant for terminal velocity of snow
+   REAL, PARAMETER, PRIVATE :: bvts = .41         ! a constant for terminal velocity of snow
+   REAL, PARAMETER, PRIVATE :: n0smax =  1.e11    ! maximum n0s (t=-90C unlimited)
+   REAL, PARAMETER, PRIVATE :: lamdacmax = 1.e10  ! limited maximum value for slope parameter of cloud water 
+   REAL, PARAMETER, PRIVATE :: lamdarmax = 1.e8   ! limited maximum value for slope parameter of rain
+   REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5   ! limited maximum value for slope parameter of snow
+   REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4   ! limited maximum value for slope parameter of graupel
+   REAL, PARAMETER, PRIVATE :: dicon = 11.9       ! constant for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: dimax = 500.e-6    ! limited maximum value for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: n0s = 2.e6         ! temperature dependent intercept parameter snow 
+   REAL, PARAMETER, PRIVATE :: alpha = .12        ! .122 exponen factor for n0s
+   REAL, PARAMETER, PRIVATE :: pfrz1 = 100.       ! constant in Biggs freezing  
+   REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66       ! constant in Biggs freezing
+   REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9     ! minimun values for qr, qs, and qg
+   REAL, PARAMETER, PRIVATE :: ncmin = 1.e1       ! minimum value for Nc 
+   REAL, PARAMETER, PRIVATE :: nrmin = 1.e-2      ! minimum value for Nr
+   REAL, PARAMETER, PRIVATE :: eacrc = 1.0        ! Snow/cloud-water collection efficiency
+!
+   REAL, PARAMETER, PRIVATE :: satmax = 1.0048    ! maximum saturation value for CCN activation
+                                                  ! 1.008 for maritime air mass /1.0048 for conti
+   REAL, PARAMETER, PRIVATE :: actk = 0.6         ! parameter for the CCN activation  
+   REAL, PARAMETER, PRIVATE :: actr = 1.5         ! radius of activated CCN drops
+   REAL, PARAMETER, PRIVATE :: ncrk1 = 3.03e3     ! Long's collection kernel coefficient 
+   REAL, PARAMETER, PRIVATE :: ncrk2 = 2.59e15    ! Long's collection kernel coefficient
+   REAL, PARAMETER, PRIVATE :: di100 = 1.e-4      ! parameter related with accretion and collection of cloud drops
+   REAL, PARAMETER, PRIVATE :: di600 = 6.e-4      ! parameter related with accretion and collection of cloud drops
+   REAL, PARAMETER, PRIVATE :: di2000 = 20.e-4    ! parameter related with accretion and collection of cloud drops
+   REAL, PARAMETER, PRIVATE :: di82 = 82.e-6      ! dimater related with raindrops evaporation
+   REAL, PARAMETER, PRIVATE :: di15 = 15.e-6      ! auto conversion takes place beyond this diameter 
+   REAL, SAVE ::                                      &
+             qc0, qck1,pidnc,bvtr1,bvtr2,bvtr3,bvtr4, &
+             bvtr5,bvtr7,bvtr2o5,bvtr3o5,g1pbr,g2pbr, &
+             g3pbr,g4pbr,g5pbr,g7pbr,g5pbro2,g7pbro2, &
+             pvtr,pvtrn,eacrr,pacrr, pi,              &
+             precr1,precr2,xmmax,roqimax,bvts1,       &
+             bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs,     &
+             g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, &
+             pidn0s,pidnr,xlv1,pacrc,                 &
+             rslopecmax,rslopec2max,rslopec3max,      &
+             rslopermax,rslopesmax,rslopegmax,        &
+             rsloperbmax,rslopesbmax,rslopegbmax,     &
+             rsloper2max,rslopes2max,rslopeg2max,     &
+             rsloper3max,rslopes3max,rslopeg3max
+!
+! Specifies code-inlining of fpvs function in WDM52D below. JM 20040507
+!
+CONTAINS
+!===================================================================
+!
+  SUBROUTINE wdm5(th, q, qc, qr, qi, qs                            &
+                 ,nn, nc, nr                                       &
+                 ,den, pii, p, delz                                &
+                 ,delt,g, cpd, cpv, ccn0, rd, rv, t0c              &
+                 ,ep1, ep2, qmin                                   &
+                 ,XLS, XLV0, XLF0, den0, denr                      &
+                 ,cliq,cice,psat                                   &
+                 ,rain, rainncv                                    &
+                 ,snow, snowncv                                    &
+                 ,sr                                               &
+                 ,itimestep                                        &
+                 ,ids,ide, jds,jde, kds,kde                        &
+                 ,ims,ime, jms,jme, kms,kme                        &
+                 ,its,ite, jts,jte, kts,kte                        &
+                                                                   )
+!-------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------
+!
+!  This code is a WRF double-moment 5-class  mixed ice
+!  microphyiscs scheme (WDM5). The WDM microphysics scheme predicts
+!  number concentrations for warm rain species including clouds and
+!  rain. cloud condensation nuclei (CCN) is also predicted.
+!  The cold rain species including ice, snow, graupel follow the
+!  WRF single-moment 5-class microphysics (WSM5)
+!  in which theoretical background for WSM ice phase microphysics is
+!  based on Hong et al. (2004). 
+!  The WDM scheme is described in Lim and Hong (2010).
+!  All units are in m.k.s. and source/sink terms in kgkg-1s-1.
+!
+!  WDM5 cloud scheme
+!
+!  Coded by Kyo-Sun Lim and Song-You Hong (Yonsei Univ.) Fall 2008
+!
+!  Implemented by Kyo-Sun Lim and Jimy Dudhia (NCAR) Winter 2008
+!
+!  Reference) Lim and Hong (LH, 2010) Mon. Wea. Rev. 
+!             Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev.
+!             Hong and Lim (HL, 2006) J. Korean Meteor. Soc.
+!             Cohard and Pinty (CP, 2000) Quart. J. Roy. Meteor. Soc.
+!             Khairoutdinov and Kogan (KK, 2000) Mon. Wea. Rev.
+!             Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan
+!
+!             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, &
+                                                              nn, & 
+                                                              nc, &
+                                                              nr   
+  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, &
+                                                            ccn0, &
+                                                             ep1, &
+                                                             ep2, &
+                                                            qmin, &
+                                                             XLS, &
+                                                            XLV0, &
+                                                            XLF0, &
+                                                            cliq, &
+                                                            cice, &
+                                                            psat, &
+                                                            denr
+  INTEGER, INTENT(IN   ) ::                            itimestep
+  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
+  REAL, DIMENSION( its:ite , kts:kte, 3 ) ::   ncr
+  CHARACTER*256 :: emess
+  INTEGER :: mkx_test
+  INTEGER ::               i,j,k
+!-------------------------------------------------------------------
+#ifndef RUN_ON_GPU
+      IF (itimestep .eq. 1) THEN
+        DO j=jms,jme
+           DO k=kms,kme
+           DO i=ims,ime
+              nn(i,k,j) = ccn0
+           ENDDO
+           ENDDO
+        ENDDO
+      ENDIF
+!
+      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)
+            ncr(i,k,1) = nn(i,k,j)                          
+            ncr(i,k,2) = nc(i,k,j)                         
+            ncr(i,k,3) = nr(i,k,j)                          
+         ENDDO
+         ENDDO
+         !  Sending array starting locations of optional variables may cause
+         !  troubles, so we explicitly change the call.
+         CALL wdm52D(t, q(ims,kms,j), qci, qrs, ncr               &
+                    ,den(ims,kms,j)                               &
+                    ,p(ims,kms,j), delz(ims,kms,j)                &
+                    ,delt,g, cpd, cpv, ccn0, 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)
+            nn(i,k,j) = ncr(i,k,1)
+            nc(i,k,j) = ncr(i,k,2)
+            nr(i,k,j) = ncr(i,k,3)
+         ENDDO
+         ENDDO
+      ENDDO
+#else
+      CALL get_wsm5_gpu_levels ( mkx_test )
+      IF ( mkx_test .LT. kte ) THEN
+        WRITE(emess,*)'Number of levels compiled for GPU WSM5 too small. ',    &
+                      mkx_test,' < ',kte
+        CALL wrf_error_fatal(emess)
+      ENDIF
+      CALL wsm5_host (                                                         &
+                    th(its:ite,kts:kte,jts:jte), pii(its:ite,kts:kte,jts:jte)  &
+                   ,q(its:ite,kts:kte,jts:jte), qc(its:ite,kts:kte,jts:jte)    &
+                   ,qi(its:ite,kts:kte,jts:jte), qr(its:ite,kts:kte,jts:jte)   &
+                   ,qs(its:ite,kts:kte,jts:jte), den(its:ite,kts:kte,jts:jte)  &
+                   ,p(its:ite,kts:kte,jts:jte), delz(its:ite,kts:kte,jts:jte)  &
+                   ,delt                                                       &
+                   ,rain(its:ite,jts:jte),rainncv(its:ite,jts:jte)             &
+                   ,snow(its:ite,jts:jte),snowncv(its:ite,jts:jte)             &
+                   ,sr(its:ite,jts:jte)                                        &
+                   ,its, ite,  jts, jte,  kts, kte                             &
+                   ,its, ite,  jts, jte,  kts, kte                             &
+                   ,its, ite,  jts, jte,  kts, kte                             &
+          )
+#endif
+  END SUBROUTINE wdm5
+!===================================================================
+!
+  SUBROUTINE wdm52D(t, q, qci, qrs, ncr, den, p, delz             &
+                   ,delt,g, cpd, cpv, ccn0, 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( its:ite , kts:kte, 3 ),                        &
+        INTENT(INOUT) ::                                          &
+                                                             ncr
+  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, &
+                                                            ccn0, &
+                                                             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, qrs_tmp
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+        rslopec, rslopec2,rslopec3                           
+  REAL, DIMENSION( its:ite , kts:kte,  2) ::                      &
+        avedia 
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+        workn,falln,falkn
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+        works
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+        den_tmp, delz_tmp, ncr_tmp
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+              falkc, work1c, work2c, fallc
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+        pcact, praut, psaut, prevp, psdep, pracw, psaci, psacw,   &  
+        pigen, pidep, pcond,                                      &
+        xl, cpm, work2, psmlt, psevp, denfac, xni,                &
+        n0sfac, denqrs2, denqci
+  REAL, DIMENSION( its:ite ) ::                                   &
+        delqrs2, delqi
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+        nraut, nracw, ncevp, nccol, nrcol,                        &
+        nsacw, nseml, ncact 
+  REAL :: ifac, sfac
+  REAL, DIMENSION(its:ite) :: tstepsnow
+!
+#define WSM_NO_CONDITIONAL_IN_VECTOR
+#ifdef WSM_NO_CONDITIONAL_IN_VECTOR
+  REAL, DIMENSION(its:ite) :: xal, xbl
+#endif
+! variables for optimization
+  REAL, DIMENSION( its:ite )           :: tvec1
+  INTEGER, DIMENSION( its:ite ) :: mnstep, numndt
+  INTEGER, DIMENSION( its:ite ) :: mstep, numdt
+  REAL, DIMENSION(its:ite) :: rmstep
+  REAL dtcldden, rdelz, rdtcld
+  LOGICAL, DIMENSION( its:ite ) :: flgcld
+  REAL  ::                                                        &
+            cpmcal, xlcal, lamdac, diffus,                        &
+            viscos, xka, venfac, conden, diffac,                  &
+            x, y, z, a, b, c, d, e,                               &
+            ndt, qdt, holdrr, holdrs, supcol, supcolt, pvt,       &
+            coeres, supsat, dtcld, xmi, eacrs, satdt,             &
+            vt2i,vt2s,acrfac, coecol,                             &
+            nfrzdtr, nfrzdtc,                                     &
+            taucon, lencon, lenconcr,                             &
+            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, idim, kdim
+! Temporaries used for inlining fpvs function
+  REAL  :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp
+  REAL  :: logtr
+!
+!=================================================================
+!   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))
+      lamdac(x,y,z)= exp(log(((pidnc*z)/(x*y)))*((.33333333)))
+!
+!----------------------------------------------------------------
+!     diffus: diffusion coefficient of the water vapor
+!     viscos: kinematic viscosity(m2s-1)
+!     diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y       
+!     viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(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))
+!
+!
+      idim = ite-its+1
+      kdim = kte-kts+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)
+          ncr(i,k,1) = max(ncr(i,k,1),0.)
+          ncr(i,k,2) = max(ncr(i,k,2),0.)
+          ncr(i,k,3) = max(ncr(i,k,3),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))
+          delz_tmp(i,k) = delz(i,k)
+          den_tmp(i,k) = den(i,k)
+        enddo
+      enddo
+!
+!----------------------------------------------------------------
+!    initialize the surface rain, snow
+!
+      do i = its, ite
+        rainncv(i) = 0.
+        if(PRESENT (snowncv) .AND. PRESENT (snow)) snowncv(i) = 0.
+        sr(i) = 0.
+! new local array to catch step snow 
+        tstepsnow(i) = 0.
+      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
+        mnstep(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)
+! this is for compilers where the conditional inhibits vectorization
+#ifdef WSM_NO_CONDITIONAL_IN_VECTOR
+      do k = kts, kte
+        do i = its, ite
+          if(t(i,k).lt.ttp) then
+            xal(i) = xai
+            xbl(i) = xbi
+          else
+            xal(i) = xa
+            xbl(i) = xb
+          endif
+        enddo
+        do i = its, ite
+          tr=ttp/t(i,k)
+          logtr=log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k))
+          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)=psat*exp(logtr*(xal(i))+xbl(i)*(1.-tr))
+          qs(i,k,2) = min(qs(i,k,2),0.99*p(i,k))
+          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
+#else
+      do k = kts, kte
+        do i = its, ite
+          tr=ttp/t(i,k)
+          logtr=log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k))
+          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)
+          if(t(i,k).lt.ttp) then
+            qs(i,k,2)=psat*exp(logtr*(xai)+xbi*(1.-tr))
+          else
+            qs(i,k,2)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          endif
+          qs(i,k,2) = min(qs(i,k,2),0.99*p(i,k))
+          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
+#endif
+!
+!----------------------------------------------------------------
+!     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.
+          pcact(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.
+          falln(i,k) = 0.
+          falkn(i,k) = 0.
+          xni(i,k) = 1.e3
+          nsacw(i,k) = 0.
+          nseml(i,k) = 0.
+          nracw(i,k) = 0.
+          nccol(i,k) = 0.
+          nrcol(i,k) = 0.
+          ncact(i,k) = 0.
+          nraut(i,k) = 0.
+          ncevp(i,k) = 0.
+        enddo
+      enddo
+!
+!----------------------------------------------------------------
+!     compute the fallout term:
+!     first, vertical terminal velosity for minor loops
+!
+      do k = kts, kte
+        do i = its, ite
+          if(qci(i,k,1).le.qmin .or. ncr(i,k,2).le.ncmin)then
+            rslopec(i,k) = rslopecmax
+            rslopec2(i,k) = rslopec2max
+            rslopec3(i,k) = rslopec3max
+          else
+            rslopec(i,k) = 1./lamdac(qci(i,k,1),den(i,k),ncr(i,k,2))
+            rslopec2(i,k) = rslopec(i,k)*rslopec(i,k)
+            rslopec3(i,k) = rslopec2(i,k)*rslopec(i,k)
+          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
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k,1) = qrs(i,k,1)
+          qrs_tmp(i,k,2) = qrs(i,k,2)
+          ncr_tmp(i,k) = ncr(i,k,3)
+        enddo
+      enddo
+      call slope_wdm5(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, &
+                     rslope3,work1,workn,its,ite,kts,kte)
+!----------------------------------------------------------------
+!     compute the fallout term:
+!     first, vertical terminal velosity for minor loops
+!----------------------------------------------------------------
+!
+! vt update for qr and nr
+      mstepmax = 1
+      numdt = 1
+      do k = kte, kts, -1
+        do i = its, ite
+          work1(i,k,1) = work1(i,k,1)/delz(i,k)
+          workn(i,k) = workn(i,k)/delz(i,k)
+          numdt(i) = max(nint(max(work1(i,k,1),workn(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,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i)
+            falkn(i,k) = ncr(i,k,3)*workn(i,k)/mstep(i)
+            fall(i,k,1) = fall(i,k,1)+falk(i,k,1)
+            falln(i,k) = falln(i,k)+falkn(i,k)
+            qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.)
+            ncr(i,k,3) = max(ncr(i,k,3)-falkn(i,k)*dtcld,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)
+              falkn(i,k) = ncr(i,k,3)*workn(i,k)/mstep(i)
+              fall(i,k,1) = fall(i,k,1)+falk(i,k,1)
+              falln(i,k) = falln(i,k)+falkn(i,k)
+              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.)
+              ncr(i,k,3) = max(ncr(i,k,3)-(falkn(i,k)-falkn(i,k+1)*delz(i,k+1) &
+                          /delz(i,k))*dtcld,0.)
+            endif
+          enddo
+        enddo
+        do k = kts, kte
+          do i = its, ite
+            qrs_tmp(i,k,1) = qrs(i,k,1)
+            ncr_tmp(i,k) = ncr(i,k,3)
+          enddo
+        enddo
+        call slope_rain(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, &
+                     rslope3,work1,workn,its,ite,kts,kte)
+        do k = kte, kts, -1
+          do i = its, ite
+            work1(i,k,1) = work1(i,k,1)/delz(i,k)
+            workn(i,k) = workn(i,k)/delz(i,k)
+          enddo
+        enddo
+      enddo
+! for semi
+      do k = kte, kts, -1
+        do i = its, ite
+          works(i,k) = work1(i,k,2)
+          denqrs2(i,k) = den(i,k)*qrs(i,k,2)
+          if(qrs(i,k,2).le.0.0) works(i,k) = 0.0
+        enddo
+      enddo
+      call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,works,denqrs2,  &
+                           delqrs2,dtcld,2,1)
+      do k = kts, kte
+        do i = its, ite
+          qrs(i,k,2) = max(denqrs2(i,k)/den(i,k),0.)
+          fall(i,k,2) = denqrs2(i,k)*works(i,k)/delz(i,k)
+        enddo
+      enddo
+      do i = its, ite
+        fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld
+      enddo
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k,1) = qrs(i,k,1)
+          qrs_tmp(i,k,2) = qrs(i,k,2)
+          ncr_tmp(i,k) = ncr(i,k,3)
+        enddo
+      enddo
+      call slope_wdm5(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, &
+                     rslope3,work1,workn,its,ite,kts,kte)
+!
+      do k = kte, kts, -1
+        do i = its, ite
+          supcol = t0c-t(i,k)
+          n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.)
+          if(t(i,k).gt.t0c.and.qrs(i,k,2).gt.0.) then
+!----------------------------------------------------------------
+! psmlt: melting of snow [HL A33] [RH83 A25]
+!       (T>T0: QS->QR)
+!----------------------------------------------------------------
+            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.)
+!-------------------------------------------------------------------
+! nsmlt: melgin of snow  [LH A27]
+!       (T>T0: ->NR)
+!-------------------------------------------------------------------
+            if(qrs(i,k,2).gt.qcrmin) then
+              sfac = rslope(i,k,2)*n0s*n0sfac(i,k)*mstep(i)/qrs(i,k,2)
+              ncr(i,k,3) = ncr(i,k,3) - sfac*psmlt(i,k)
+            endif
+            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
+        enddo
+      enddo
+!---------------------------------------------------------------
+! Vice [ms-1] : fallout of ice crystal [HDC 5a]
+!---------------------------------------------------------------
+      do k = kte, kts, -1
+        do i = its, ite
+          if(qci(i,k,2).le.0.) then
+            work1c(i,k) = 0.
+          else
+            xmi = den(i,k)*qci(i,k,2)/xni(i,k)
+            diameter  = max(min(dicon * sqrt(xmi),dimax), 1.e-25)
+            work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31))
+          endif
+        enddo
+      enddo
+!
+!  forward semi-laglangian scheme (JH), PCM (piecewise constant),  (linear)
+!
+      do k = kte, kts, -1
+        do i = its, ite
+          denqci(i,k) = den(i,k)*qci(i,k,2)
+        enddo
+      enddo
+      call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci,  &
+                           delqi,dtcld,1,0)
+      do k = kts, kte
+        do i = its, ite
+          qci(i,k,2) = max(denqci(i,k)/den(i,k),0.)
+        enddo
+      enddo
+      do i = its, ite
+        fallc(i,1) = delqi(i)/delz(i,1)/dtcld
+      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)
+        if(fallsum.gt.0.) then
+          rainncv(i) = fallsum*delz(i,1)/denr*dtcld*1000. + rainncv(i)
+          rain(i) = fallsum*delz(i,1)/denr*dtcld*1000.+rain(i)
+        endif
+        if(fallsum_qsi.gt.0.) then
+            tstepsnow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + tstepsnow(i)
+        if (PRESENT (snowncv) .and. PRESENT (snow)) then 
+            snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snowncv(i)
+            snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000.+snow(i)
+        endif 
+        endif
+!       if(fallsum.gt.0.)sr(i)= snowncv(i)/(rainncv(i)+1.e-12)
+        if(fallsum.gt.0.)sr(i)= tstepsnow(i)/(rainncv(i)+1.e-12)
+      enddo
+!
+!---------------------------------------------------------------
+! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28]
+!       (T>T0: QI->QC)
+!---------------------------------------------------------------
+      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)
+!---------------------------------------------------------------
+! nimlt: instantaneous melting of cloud ice  [LH A18]
+!        (T>T0: ->NC)
+!--------------------------------------------------------------          
+            ncr(i,k,2) = ncr(i,k,2) + xni(i,k)
+            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: QC->QI)
+!---------------------------------------------------------------
+          if(supcol.gt.40. .and. qci(i,k,1).gt.0.) then
+            qci(i,k,2) = qci(i,k,2) + qci(i,k,1)
+!---------------------------------------------------------------
+! nihmf: homogeneous  of cloud water below -40c [LH A17] 
+!        (T<-40C: NC->)
+!---------------------------------------------------------------
+            if(ncr(i,k,2).gt.0.) ncr(i,k,2) = 0.
+            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: QC->QI)
+!---------------------------------------------------------------
+          if(supcol.gt.0. .and. qci(i,k,1).gt.0.) then
+            supcolt=min(supcol,70.)
+            pfrzdtc = min(pi*pi*pfrz1*(exp(pfrz2*supcolt)-1.)*denr/den(i,k)    &
+                   *ncr(i,k,2)*rslopec3(i,k)*rslopec3(i,k)/18.*dtcld,qci(i,k,1))       
+!---------------------------------------------------------------
+! nihtf: heterogeneous  of cloud water  [LH A16]
+!         (T0>T>-40C: NC->)
+!---------------------------------------------------------------
+            if(ncr(i,k,2).gt.ncmin) then
+              nfrzdtc = min(pi*pfrz1*(exp(pfrz2*supcolt)-1.)*ncr(i,k,2)        &
+                      *rslopec3(i,k)/6.*dtcld,ncr(i,k,2))
+              ncr(i,k,2) = ncr(i,k,2) - nfrzdtc
+            endif
+            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]
+!        (T<T0, QR->QS)
+!---------------------------------------------------------------
+          if(supcol.gt.0. .and. qrs(i,k,1).gt.0.) then
+            supcolt=min(supcol,70.)
+            pfrzdtr = min(140.*(pi*pi)*pfrz1*ncr(i,k,3)*denr/den(i,k)          &
+                  *(exp(pfrz2*supcolt)-1.)*rslope3(i,k,1)*rslope3(i,k,1)       &
+                  *dtcld,qrs(i,k,1)) 
+!---------------------------------------------------------------
+! nsfrz: freezing of rain water [LH A26]
+!        (T<T0, NR-> )
+!---------------------------------------------------------------
+            if(ncr(i,k,3).gt.nrmin) then
+              nfrzdtr = min(4.*pi*pfrz1*ncr(i,k,3)*(exp(pfrz2*supcolt)-1.)     &
+                       *rslope3(i,k,1)*dtcld,ncr(i,k,3))
+              ncr(i,k,3) = ncr(i,k,3)-nfrzdtr
+            endif
+            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
+!
+      do k = kts, kte
+        do i = its, ite
+          ncr(i,k,2) = max(ncr(i,k,2),0.0)
+          ncr(i,k,3) = max(ncr(i,k,3),0.0)
+        enddo
+      enddo
+!----------------------------------------------------------------
+!     update the slope parameters for microphysics computation
+!
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k,1) = qrs(i,k,1)
+          qrs_tmp(i,k,2) = qrs(i,k,2)
+          ncr_tmp(i,k) = ncr(i,k,3)
+        enddo
+      enddo
+      call slope_wdm5(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, &
+                     rslope3,work1,workn,its,ite,kts,kte)
+      do k = kts, kte
+        do i = its, ite
+!-----------------------------------------------------------------
+! compute the mean-volume drop diameter                  [LH A10]
+! for raindrop distribution
+!-----------------------------------------------------------------
+          avedia(i,k,2) = rslope(i,k,1)*((24.)**(.3333333))
+          if(qci(i,k,1).le.qmin .or. ncr(i,k,2).le.ncmin) then
+            rslopec(i,k) = rslopecmax
+            rslopec2(i,k) = rslopec2max
+            rslopec3(i,k) = rslopec3max
+          else
+            rslopec(i,k) = 1./lamdac(qci(i,k,1),den(i,k),ncr(i,k,2))
+            rslopec2(i,k) = rslopec(i,k)*rslopec(i,k)
+            rslopec3(i,k) = rslopec2(i,k)*rslopec(i,k)
+          endif
+!--------------------------------------------------------------------
+! compute the mean-volume drop diameter                   [LH A7]
+! for cloud-droplet distribution
+!--------------------------------------------------------------------
+          avedia(i,k,1) = rslopec(i,k)
+        enddo
+      enddo
+!----------------------------------------------------------------
+!     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
+!         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 [LH 9] [CP 17] 
+!        (QC->QR)
+!---------------------------------------------------------------
+          lencon  = 2.7e-2*den(i,k)*qci(i,k,1)*(1.e20/16.*rslopec2(i,k)        &
+                   *rslopec2(i,k)-0.4)
+          lenconcr = max(1.2*lencon,qcrmin)
+          if(avedia(i,k,1).gt.di15) then
+            taucon = 3.7/den(i,k)/qci(i,k,1)/(0.5e6*rslopec(i,k)-7.5)
+            praut(i,k) = lencon/taucon
+            praut(i,k) = min(max(praut(i,k),0.),qci(i,k,1)/dtcld)
+!---------------------------------------------------------------
+! nraut: auto conversion rate from cloud to rain [LH A6][CP 18 & 19]
+!        (NC->NR)
+!---------------------------------------------------------------
+            nraut(i,k) = 3.5e9*den(i,k)*praut(i,k)
+            if(qrs(i,k,1).gt.lenconcr)                                         &
+            nraut(i,k) = ncr(i,k,3)/qrs(i,k,1)*praut(i,k)
+            nraut(i,k) = min(nraut(i,k),ncr(i,k,2)/dtcld)
+          endif
+!---------------------------------------------------------------
+! pracw: accretion of cloud water by rain   [LH 10][CP 22 & 23]
+!        (QC->QR)
+! nracw: accretion of cloud water by rain   [LH A9]
+!        (NC->)
+!---------------------------------------------------------------
+          if(qrs(i,k,1).ge.lenconcr) then
+            if(avedia(i,k,2).ge.di100) then
+              nracw(i,k) = min(ncrk1*ncr(i,k,2)*ncr(i,k,3)*(rslopec3(i,k)      &
+                         + 24.*rslope3(i,k,1)),ncr(i,k,2)/dtcld)
+              pracw(i,k) = min(pi/6.*(denr/den(i,k))*ncrk1*ncr(i,k,2)          &
+                         *ncr(i,k,3)*rslopec3(i,k)*(2.*rslopec3(i,k)           &
+                         + 24.*rslope3(i,k,1)),qci(i,k,1)/dtcld)
+            else
+              nracw(i,k) = min(ncrk2*ncr(i,k,2)*ncr(i,k,3)*(2.*rslopec3(i,k)   &
+                         *rslopec3(i,k)+5040.*rslope3(i,k,1)                   &
+                         *rslope3(i,k,1)),ncr(i,k,2)/dtcld)
+              pracw(i,k) = min(pi/6.*(denr/den(i,k))*ncrk2*ncr(i,k,2)          &
+                         *ncr(i,k,3)*rslopec3(i,k)*(6.*rslopec3(i,k)           &
+                         *rslopec3(i,k)+5040.*rslope3(i,k,1)                   &
+                         *rslope3(i,k,1)),qci(i,k,1)/dtcld)
+            endif
+          endif
+!----------------------------------------------------------------
+! nccol: self collection of cloud water         [LH A8][CP 24 & 25]    
+!        (NC->)
+!----------------------------------------------------------------
+          if(avedia(i,k,1).ge.di100) then
+            nccol(i,k) = ncrk1*ncr(i,k,2)*ncr(i,k,2)*rslopec3(i,k)
+          else
+            nccol(i,k) = 2.*ncrk2*ncr(i,k,2)*ncr(i,k,2)*rslopec3(i,k)        & 
+                        *rslopec3(i,k)
+          endif
+!----------------------------------------------------------------
+! nrcol: self collection of rain-drops and break-up [LH A21][CP 24 & 25]
+!        (NR->)
+!----------------------------------------------------------------
+          if(qrs(i,k,1).ge.lenconcr) then
+            if(avedia(i,k,2).lt.di100) then
+              nrcol(i,k) = 5040.*ncrk2*ncr(i,k,3)*ncr(i,k,3)*rslope3(i,k,1)    &
+                          *rslope3(i,k,1)
+            elseif(avedia(i,k,2).ge.di100 .and. avedia(i,k,2).lt.di600) then
+              nrcol(i,k) = 24.*ncrk1*ncr(i,k,3)*ncr(i,k,3)*rslope3(i,k,1)
+            elseif(avedia(i,k,2).ge.di600 .and. avedia(i,k,2).lt.di2000) then
+              coecol = -2.5e3*(avedia(i,k,2)-di600)
+              nrcol(i,k) = 24.*exp(coecol)*ncrk1*ncr(i,k,3)*ncr(i,k,3)         &
+                         *rslope3(i,k,1)
+            else
+              nrcol(i,k) = 0.
+            endif
+          endif
+!---------------------------------------------------------------
+! prevp: evaporation/condensation rate of rain  [HL A41]
+!        (QV->QR or QR->QV)
+!---------------------------------------------------------------
+          if(qrs(i,k,1).gt.0.) then
+            coeres = rslope(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1))
+            prevp(i,k) = (rh(i,k,1)-1.)*ncr(i,k,3)*(precr1*rslope(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)
+!----------------------------------------------------------------
+! Nrevp: evaporation/condensation rate of rain  [LH A14] 
+!        (NR->NCCN)
+!----------------------------------------------------------------
+              if(prevp(i,k).eq.-qrs(i,k,1)/dtcld) then
+                 ncr(i,k,1) = ncr(i,k,1) + ncr(i,k,3)
+                 ncr(i,k,3) = 0.
+              endif
+            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)
+          n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.)
+          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]
+!        (T<T0: QI->QS)
+!-------------------------------------------------------------
+              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
+          endif
+!-------------------------------------------------------------
+! psacw: Accretion of cloud water by snow  [HL A7] [LFO 24]
+!        (T<T0: QC->QS, and T>=T0: QC->QR)
+!-------------------------------------------------------------
+          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)*rdtcld)
+          endif
+!-------------------------------------------------------------
+! nsacw: Accretion of cloud water by snow  [LH A12]
+!        (NC ->)
+!-------------------------------------------------------------
+         if(qrs(i,k,2).gt.qcrmin .and. ncr(i,k,2).gt.ncmin) then
+           nsacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2)    &
+                       *ncr(i,k,2)*denfac(i,k),ncr(i,k,2)/dtcld)
+         endif
+         if(supcol.le.0) then
+           xlf = xlf0
+!--------------------------------------------------------------
+! nseml: Enhanced melting of snow by accretion of water  [LH A29]
+!        (T>=T0: ->NR)
+!--------------------------------------------------------------
+              if  (qrs(i,k,2).gt.qcrmin) then
+                sfac = rslope(i,k,2)*n0s*n0sfac(i,k)/qrs(i,k,2)
+                nseml(i,k) = -sfac*min(max(cliq*supcol*(psacw(i,k))/xlf        &
+                            ,-qrs(i,k,2)/dtcld),0.)
+              endif   
+         endif
+         if(supcol.gt.0) then
+!-------------------------------------------------------------
+! pidep: Deposition/Sublimation rate of ice [HDC 9]
+!       (T<T0: QV->QI or QI->QV)
+!-------------------------------------------------------------
+            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
+!-------------------------------------------------------------
+! psdep: deposition/sublimation rate of snow [HDC 14]
+!        (QV->QS or QS->QV)
+!-------------------------------------------------------------
+            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]
+!       (T<T0: QV->QI)
+!-------------------------------------------------------------
+            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.))*rdtcld)
+              pigen(i,k) = min(min(pigen(i,k),satdt),supice)
+            endif
+!
+!-------------------------------------------------------------
+! psaut: conversion(aggregation) of ice to snow [HDC 12]
+!       (T<T0: QI->QS)
+!-------------------------------------------------------------
+            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: QS->QV)
+!-------------------------------------------------------------
+          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
+!
+!     Q_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
+!
+!     Q_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
+!
+!     Q_rain
+!
+!
+            value = max(qmin,qrs(i,k,1))
+            source = (-praut(i,k)-pracw(i,k)-prevp(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
+              prevp(i,k) = prevp(i,k)*factor
+            endif
+!
+!    Q_snow
+!
+            value = max(qmin,qrs(i,k,2))
+            source = (-psdep(i,k)-psaut(i,k)-psaci(i,k)-psacw(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
+              psaci(i,k) = psaci(i,k)*factor
+              psacw(i,k) = psacw(i,k)*factor
+            endif
+!
+!     N_cloud
+!
+            value = max(ncmin,ncr(i,k,2))
+            source = (+nraut(i,k)+nccol(i,k)+nracw(i,k)+nsacw(i,k))*dtcld
+            if (source.gt.value) then
+              factor = value/source
+              nraut(i,k) = nraut(i,k)*factor
+              nccol(i,k) = nccol(i,k)*factor
+              nracw(i,k) = nracw(i,k)*factor
+              nsacw(i,k) = nsacw(i,k)*factor
+            endif
+!
+!     N_rain
+!
+            value = max(nrmin,ncr(i,k,3))
+            source = (-nraut(i,k)+nrcol(i,k))*dtcld
+            if (source.gt.value) then
+              factor = value/source
+              nraut(i,k) = nraut(i,k)*factor
+              nrcol(i,k) = nrcol(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.)
+            ncr(i,k,2) = max(ncr(i,k,2)+(-nraut(i,k)-nccol(i,k)-nracw(i,k)     &
+                         -nsacw(i,k))*dtcld,0.)
+            ncr(i,k,3) = max(ncr(i,k,3)+(nraut(i,k)-nrcol(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
+!
+!     Q_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
+!
+!     Q_rain
+!
+            value = max(qmin,qrs(i,k,1))
+            source = (-praut(i,k)-pracw(i,k)-prevp(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
+              prevp(i,k) = prevp(i,k)*factor
+              psacw(i,k) = psacw(i,k)*factor
+            endif  
+!
+!     Q_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
+!
+!     N_cloud
+!
+            value = max(ncmin,ncr(i,k,2))
+            source = (+nraut(i,k)+nccol(i,k)+nracw(i,k)+nsacw(i,k))*dtcld
+            if (source.gt.value) then
+              factor = value/source
+              nraut(i,k) = nraut(i,k)*factor
+              nccol(i,k) = nccol(i,k)*factor
+              nracw(i,k) = nracw(i,k)*factor
+              nsacw(i,k) = nsacw(i,k)*factor
+            endif
+!
+!     N_rain
+!
+            value = max(nrmin,ncr(i,k,3))
+            source = (-nraut(i,k)-nseml(i,k)+nrcol(i,k))*dtcld
+            if (source.gt.value) then
+              factor = value/source
+              nraut(i,k) = nraut(i,k)*factor
+              nseml(i,k) = nseml(i,k)*factor
+              nrcol(i,k) = nrcol(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.)
+            ncr(i,k,2) = max(ncr(i,k,2)+(-nraut(i,k)-nccol(i,k)-nracw(i,k)     &
+                        -nsacw(i,k))*dtcld,0.)
+            ncr(i,k,3) = max(ncr(i,k,3)+(nraut(i,k)+nseml(i,k)-nrcol(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)
+          logtr = log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k))
+          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)
+        enddo
+      enddo
+!
+      call slope_wdm5(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, &
+                     rslope3,work1,workn,its,ite,kts,kte)
+      do k = kts, kte
+        do i = its, ite
+!-----------------------------------------------------------------
+! re-compute the mean-volume drop diameter            [LH A10]
+! for raindrop distribution
+!-----------------------------------------------------------------
+          avedia(i,k,2) = rslope(i,k,1)*((24.)**(.3333333))       
+!----------------------------------------------------------------
+! Nrevp_s: evaporation/condensation rate of rain   [LH A14]
+!        (NR->NC)
+!----------------------------------------------------------------
+          if(avedia(i,k,2).le.di82) then
+            ncr(i,k,2) = ncr(i,k,2)+ncr(i,k,3)
+            ncr(i,k,3) = 0.
+!----------------------------------------------------------------
+! Prevp_s: evaporation/condensation rate of rain [LH A15] [KK 23]
+!        (QR->QC)
+!----------------------------------------------------------------
+            qci(i,k,1) = qci(i,k,1)+qrs(i,k,1)
+            qrs(i,k,1) = 0.
+          endif
+        enddo
+      enddo
+!
+      do k = kts, kte
+        do i = its, ite
+!-------------------------------------------------------------------
+! rate of change of cloud drop concentration due to CCN activation
+! pcact: QV -> QC                                 [LH 8]  [KK 14]
+! ncact: NCCN -> NC                               [LH A2] [KK 12]
+!-------------------------------------------------------------------
+          if(rh(i,k,1).gt.1.) then
+            ncact(i,k) = max(0.,((ncr(i,k,1)+ncr(i,k,2))                       &
+                       *min(1.,(rh(i,k,1)/satmax)**actk) - ncr(i,k,2)))/dtcld
+            ncact(i,k) =min(ncact(i,k),max(ncr(i,k,1),0.)/dtcld)
+            pcact(i,k) = min(4.*pi*denr*(actr*1.E-6)**3*ncact(i,k)/            &
+                         (3.*den(i,k)),max(q(i,k),0.)/dtcld)
+            q(i,k) = max(q(i,k)-pcact(i,k)*dtcld,0.)
+            qci(i,k,1) = max(qci(i,k,1)+pcact(i,k)*dtcld,0.)
+            ncr(i,k,1) = max(ncr(i,k,1)-ncact(i,k)*dtcld,0.)
+            ncr(i,k,2) = max(ncr(i,k,2)+ncact(i,k)*dtcld,0.)
+            t(i,k) = t(i,k)+pcact(i,k)*xl(i,k)/cpm(i,k)*dtcld
+          endif
+!---------------------------------------------------------------------
+!  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
+!  (QV->QC or QC->QV)
+!---------------------------------------------------------------------
+          tr=ttp/t(i,k)
+          qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr))
+          qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k))
+          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)
+          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
+!----------------------------------------------------------------------
+! ncevp: evpration of Cloud number concentration  [LH A3]
+! (NC->NCCN)
+!----------------------------------------------------------------------
+          if(pcond(i,k).eq.-qci(i,k,1)/dtcld) then
+            ncr(i,k,2) = 0.
+            ncr(i,k,1) = ncr(i,k,1)+ncr(i,k,2)
+          endif
+!
+          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 wdm52d
+! ...................................................................
+      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 wdm5init(den0,denr,dens,cl,cpv,ccn0,allowed_to_read)
+!-------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------
+!.... constants which may not be tunable
+   REAL, INTENT(IN) :: den0,denr,dens,cl,cpv,ccn0
+   LOGICAL, INTENT(IN) :: allowed_to_read
+!
+   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
+   pidnc = pi*denr/6.
+!
+   bvtr1 = 1.+bvtr
+   bvtr2 = 2.+bvtr
+   bvtr3 = 3.+bvtr
+   bvtr4 = 4.+bvtr
+   bvtr5 = 5.+bvtr
+   bvtr7 = 7.+bvtr
+   bvtr2o5 = 2.5+.5*bvtr
+   bvtr3o5 = 3.5+.5*bvtr
+   g1pbr = rgmma(bvtr1)
+   g2pbr = rgmma(bvtr2)
+   g3pbr = rgmma(bvtr3)
+   g4pbr = rgmma(bvtr4)            ! 17.837825
+   g5pbr = rgmma(bvtr5)
+   g7pbr = rgmma(bvtr7)
+   g5pbro2 = rgmma(bvtr2o5)
+   g7pbro2 = rgmma(bvtr3o5)
+   pvtr = avtr*g5pbr/24.
+   pvtrn = avtr*g2pbr
+   eacrr = 1.0
+   pacrr = pi*n0r*avtr*g3pbr*.25*eacrr
+   precr1 = 2.*pi*1.56
+   precr2 = 2.*pi*.31*avtr**.5*g7pbro2
+   pidn0r =  pi*denr*n0r
+   pidnr = 4.*pi*denr
+   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
+   pidn0s =  pi*dens*n0s
+   pacrc = pi*n0s*avts*g3pbs*.25*eacrc
+!
+   rslopecmax = 1./lamdacmax
+   rslopermax = 1./lamdarmax
+   rslopesmax = 1./lamdasmax
+   rsloperbmax = rslopermax ** bvtr
+   rslopesbmax = rslopesmax ** bvts
+   rslopec2max = rslopecmax * rslopecmax
+   rsloper2max = rslopermax * rslopermax
+   rslopes2max = rslopesmax * rslopesmax
+   rslopec3max = rslopec2max * rslopecmax
+   rsloper3max = rsloper2max * rslopermax
+   rslopes3max = rslopes2max * rslopesmax
+!
+  END SUBROUTINE wdm5init
+!------------------------------------------------------------------------------
+      subroutine slope_wdm5(qrs,ncr,den,denfac,t,rslope,rslopeb,rslope2,rslope3, &
+                            vt,vtn,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte,2) ::                                     &
+                                                                          qrs, &
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                           vt
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          ncr, &
+                                                                          vtn, &
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdar, lamdas, x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     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,z)= exp(log(((pidnr*z)/(x*y)))*((.33333333)))
+      lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y)))    ! (pidn0s*z/(x*y))**.25
+!
+      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 .or. ncr(i,k).le.nrmin ) 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) = min(1./lamdar(qrs(i,k,1),den(i,k),ncr(i,k)),1.e-3)
+            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
+          vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)
+          vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)
+          vtn(i,k) = pvtrn*rslopeb(i,k,1)*denfac(i,k)
+          if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0
+          if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0
+          if(ncr(i,k).le.0.0) vtn(i,k) = 0.0
+        enddo
+      enddo
+  END subroutine slope_wdm5
+!-----------------------------------------------------------------------------
+      subroutine slope_rain(qrs,ncr,den,denfac,t,rslope,rslopeb,rslope2,rslope3,   &
+                            vt,vtn,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          qrs, &
+                                                                          ncr, &
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                           vt, &
+                                                                          vtn, &
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdar, x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     size distributions: (x=mixing ratio, y=air density):
+!     valid for mixing ratio > 1.e-9 kg/kg.
+      lamdar(x,y,z)= exp(log(((pidnr*z)/(x*y)))*((.33333333)))
+!
+      do k = kts, kte
+        do i = its, ite
+          if(qrs(i,k).le.qcrmin .or. ncr(i,k).le.nrmin) then
+            rslope(i,k) = rslopermax
+            rslopeb(i,k) = rsloperbmax
+            rslope2(i,k) = rsloper2max
+            rslope3(i,k) = rsloper3max
+          else
+            rslope(i,k) = min(1./lamdar(qrs(i,k),den(i,k),ncr(i,k)),1.e-3)
+            rslopeb(i,k) = rslope(i,k)**bvtr
+            rslope2(i,k) = rslope(i,k)*rslope(i,k)
+            rslope3(i,k) = rslope2(i,k)*rslope(i,k)
+          endif
+          vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k)
+          vtn(i,k) = pvtrn*rslopeb(i,k)*denfac(i,k)
+          if(qrs(i,k).le.0.0) vt(i,k) = 0.0
+          if(ncr(i,k).le.0.0) vtn(i,k) = 0.0
+        enddo
+      enddo
+  END subroutine slope_rain
+!------------------------------------------------------------------------------
+      subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,   &
+                            vt,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          qrs, &
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                           vt, &
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdas, x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     size distributions: (x=mixing ratio, y=air density):
+!     valid for mixing ratio > 1.e-9 kg/kg.
+      lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y)))    ! (pidn0s*z/(x*y))**.25
+!
+      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).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
+            rslope2(i,k) = rslope(i,k)*rslope(i,k)
+            rslope3(i,k) = rslope2(i,k)*rslope(i,k)
+          endif
+          vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k)
+          if(qrs(i,k).le.0.0) vt(i,k) = 0.0
+        enddo
+      enddo
+  END subroutine slope_snow
+!-------------------------------------------------------------------
+      SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter)
+!-------------------------------------------------------------------
+!
+! for non-iteration semi-Lagrangain forward advection for cloud
+! with mass conservation and positive definite advection
+! 2nd order interpolation with monotonic piecewise linear method
+! this routine is under assumption of decfl < 1 for semi_Lagrangian
+!
+! dzl    depth of model layer in meter
+! wwl    terminal velocity at model layer m/s
+! rql    cloud density*mixing ration
+! precip precipitation
+! dt     time step
+! id     kind of precip: 0 test case; 1 raindrop  2: snow
+! iter   how many time to guess mean terminal velocity: 0 pure forward.
+!        0 : use departure wind for advection
+!        1 : use mean wind for advection
+!        > 1 : use mean wind after iter-1 iterations
+!
+! author: hann-ming henry juang <henry.juang@noaa.gov>
+!         implemented by song-you hong
+!
+      implicit none
+      integer  im,km,id
+      real  dt
+      real  dzl(im,km),wwl(im,km),rql(im,km),precip(im)
+      real  denl(im,km),denfacl(im,km),tkl(im,km)
+!
+      integer  i,k,n,m,kk,kb,kt,iter
+      real  tl,tl2,qql,dql,qqd
+      real  th,th2,qqh,dqh
+      real  zsum,qsum,dim,dip,c1,con1,fa1,fa2
+      real  allold, allnew, zz, dzamin, cflmax, decfl
+      real  dz(km), ww(km), qq(km), wd(km), wa(km), was(km)
+      real  den(km), denfac(km), tk(km)
+      real  wi(km+1), zi(km+1), za(km+1)
+      real  qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km)
+      real  dza(km+1), qa(km+1), qmi(km+1), qpi(km+1)
+!
+      precip(:) = 0.0
+!
+      i_loop : do i=1,im
+! -----------------------------------
+      dz(:) = dzl(i,:)
+      qq(:) = rql(i,:)
+      ww(:) = wwl(i,:)
+      den(:) = denl(i,:)
+      denfac(:) = denfacl(i,:)
+      tk(:) = tkl(i,:)
+! skip for no precipitation for all layers
+      allold = 0.0
+      do k=1,km
+        allold = allold + qq(k)
+      enddo
+      if(allold.le.0.0) then
+        cycle i_loop
+      endif
+!
+! compute interface values
+      zi(1)=0.0
+      do k=1,km
+        zi(k+1) = zi(k)+dz(k)
+      enddo
+!
+! save departure wind
+      wd(:) = ww(:)
+      n=1
+ 100  continue
+! plm is 2nd order, we can use 2nd order wi or 3rd order wi
+! 2nd order interpolation to get wi
+      wi(1) = ww(1)
+      wi(km+1) = ww(km)
+      do k=2,km
+        wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k))
+      enddo
+! 3rd order interpolation to get wi
+      fa1 = 9./16.
+      fa2 = 1./16.
+      wi(1) = ww(1)
+      wi(2) = 0.5*(ww(2)+ww(1))
+      do k=3,km-1
+        wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2))
+      enddo
+      wi(km) = 0.5*(ww(km)+ww(km-1))
+      wi(km+1) = ww(km)
+!
+! terminate of top of raingroup
+      do k=2,km
+        if( ww(k).eq.0.0 ) wi(k)=ww(k-1)
+      enddo
+!
+! diffusivity of wi
+      con1 = 0.05
+      do k=km,1,-1
+        decfl = (wi(k+1)-wi(k))*dt/dz(k)
+        if( decfl .gt. con1 ) then
+          wi(k) = wi(k+1) - con1*dz(k)/dt
+        endif
+      enddo
+! compute arrival point
+      do k=1,km+1
+        za(k) = zi(k) - wi(k)*dt
+      enddo
+!
+      do k=1,km
+        dza(k) = za(k+1)-za(k)
+      enddo
+      dza(km+1) = zi(km+1) - za(km+1)
+!
+! computer deformation at arrival point
+      do k=1,km
+        qa(k) = qq(k)*dz(k)/dza(k)
+        qr(k) = qa(k)/den(k)
+      enddo
+      qa(km+1) = 0.0
+!     call maxmin(km,1,qa,' arrival points ')
+!
+! compute arrival terminal velocity, and estimate mean terminal velocity
+! then back to use mean terminal velocity
+      if( n.le.iter ) then
+!        if (id.eq.1) then
+!
+!          call slope_rain(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km)
+!        else
+          call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km)
+!        endif
+        if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km))
+        do k=1,km
+!#ifdef DEBUG
+!        print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k)
+!#endif
+! mean wind is average of departure and new arrival winds
+          ww(k) = 0.5* ( wd(k)+wa(k) )
+        enddo
+        was(:) = wa(:)
+        n=n+1
+        go to 100
+      endif
+!
+! estimate values at arrival cell interface with monotone
+      do k=2,km
+        dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k))
+        dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k))
+        if( dip*dim.le.0.0 ) then
+          qmi(k)=qa(k)
+          qpi(k)=qa(k)
+        else
+          qpi(k)=qa(k)+0.5*(dip+dim)*dza(k)
+          qmi(k)=2.0*qa(k)-qpi(k)
+          if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then
+            qpi(k) = qa(k)
+            qmi(k) = qa(k)
+          endif
+        endif
+      enddo
+      qpi(1)=qa(1)
+      qmi(1)=qa(1)
+      qmi(km+1)=qa(km+1)
+      qpi(km+1)=qa(km+1)
+!
+! interpolation to regular point
+      qn = 0.0
+      kb=1
+      kt=1
+      intp : do k=1,km
+             kb=max(kb-1,1)
+             kt=max(kt-1,1)
+! find kb and kt
+             if( zi(k).ge.za(km+1) ) then
+               exit intp
+             else
+               find_kb : do kk=kb,km
+                         if( zi(k).le.za(kk+1) ) then
+                           kb = kk
+                           exit find_kb
+                         else
+                           cycle find_kb
+                         endif
+               enddo find_kb
+               find_kt : do kk=kt,km
+                         if( zi(k+1).le.za(kk) ) then
+                           kt = kk
+                           exit find_kt
+                         else
+                           cycle find_kt
+                         endif
+               enddo find_kt
+               kt = kt - 1
+! compute q with piecewise constant method
+               if( kt.eq.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 th=(zi(k+1)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 th2=th*th
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qqh=qqd*th2+qmi(kb)*th
+                 qql=qqd*tl2+qmi(kb)*tl
+                 qn(k) = (qqh-qql)/(th-tl)
+               else if( kt.gt.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qql=qqd*tl2+qmi(kb)*tl
+                 dql = qa(kb)-qql
+                 zsum  = (1.-tl)*dza(kb)
+                 qsum  = dql*dza(kb)
+                 if( kt-kb.gt.1 ) then
+                 do m=kb+1,kt-1
+                   zsum = zsum + dza(m)
+                   qsum = qsum + qa(m) * dza(m)
+                 enddo
+                 endif
+                 th=(zi(k+1)-za(kt))/dza(kt)
+                 th2=th*th
+                 qqd=0.5*(qpi(kt)-qmi(kt))
+                 dqh=qqd*th2+qmi(kt)*th
+                 zsum  = zsum + th*dza(kt)
+                 qsum  = qsum + dqh*dza(kt)
+                 qn(k) = qsum/zsum
+               endif
+               cycle intp
+             endif
+!
+       enddo intp
+!
+! rain out
+      sum_precip: do k=1,km
+                    if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*dza(k)
+                      cycle sum_precip
+                    else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*(0.0-za(k))
+                      exit sum_precip
+                    endif
+                    exit sum_precip
+      enddo sum_precip
+!
+! replace the new values
+      rql(i,:) = qn(:)
+!
+! ----------------------------------
+      enddo i_loop
+!
+  END SUBROUTINE nislfv_rain_plm
+END MODULE module_mp_wdm5
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wdm6.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wdm6.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wdm6.F	(revision 17)
@@ -0,0 +1,2656 @@
+#if ( RWORDSIZE == 4 )
+#  define VREC vsrec
+#  define VSQRT vssqrt
+#else
+#  define VREC vrec
+#  define VSQRT vsqrt
+#endif
+
+MODULE module_mp_wdm6
+!
+!
+!
+   REAL, PARAMETER, PRIVATE :: dtcldcr     = 120. ! maximum time step for minor loops
+   REAL, PARAMETER, PRIVATE :: n0r = 8.e6         ! intercept parameter rain
+   REAL, PARAMETER, PRIVATE :: n0g = 4.e6         ! intercept parameter graupel
+   REAL, PARAMETER, PRIVATE :: avtr = 841.9       ! a constant for terminal velocity of rain
+   REAL, PARAMETER, PRIVATE :: bvtr = 0.8         ! a constant for terminal velocity of rain
+   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       ! a constant for terminal velocity of snow
+   REAL, PARAMETER, PRIVATE :: bvts = .41         ! a constant for terminal velocity of snow 
+   REAL, PARAMETER, PRIVATE :: avtg = 330.        ! a constant for terminal velocity of graupel 
+   REAL, PARAMETER, PRIVATE :: bvtg = 0.8         ! a constant for terminal velocity of graupel
+   REAL, PARAMETER, PRIVATE :: deng = 500.        ! density of graupel
+   REAL, PARAMETER, PRIVATE :: n0smax =  1.e11    ! maximum n0s (t=-90C unlimited)
+   REAL, PARAMETER, PRIVATE :: lamdacmax = 1.e10  ! limited maximum value for slope parameter of cloud water 
+   REAL, PARAMETER, PRIVATE :: lamdarmax = 1.e8   ! limited maximum value for slope parameter of rain
+   REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5   ! limited maximum value for slope parameter of snow
+   REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4   ! limited maximum value for slope parameter of graupel
+   REAL, PARAMETER, PRIVATE :: dicon = 11.9       ! constant for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: dimax = 500.e-6    ! limited maximum value for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: n0s = 2.e6         ! temperature dependent intercept parameter snow 
+   REAL, PARAMETER, PRIVATE :: alpha = .12        ! .122 exponen factor for n0s
+   REAL, PARAMETER, PRIVATE :: pfrz1 = 100.       ! constant in Biggs freezing
+   REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66       ! constant in Biggs freezing
+   REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9     ! minimun values for qr, qs, and qg 
+   REAL, PARAMETER, PRIVATE :: ncmin = 1.e1       ! minimum value for Nc 
+   REAL, PARAMETER, PRIVATE :: nrmin = 1.e-2      ! minimum value for Nr
+   REAL, PARAMETER, PRIVATE :: eacrc = 1.0        ! Snow/cloud-water collection efficiency
+   REAL, PARAMETER, PRIVATE :: dens  =  100.0     ! Density of snow
+   REAL, PARAMETER, PRIVATE :: qs0   =  6.e-4     ! threshold amount for aggretion to occur
+!
+   REAL, PARAMETER, PRIVATE :: satmax = 1.0048    ! maximum saturation value for CCN activation 
+                                                  ! 1.008 for maritime /1.0048 for conti 
+   REAL, PARAMETER, PRIVATE :: actk = 0.6         ! parameter for the CCN activation
+   REAL, PARAMETER, PRIVATE :: actr = 1.5         ! radius of activated CCN drops
+   REAL, PARAMETER, PRIVATE :: ncrk1 = 3.03e3     ! Long's collection kernel coefficient
+   REAL, PARAMETER, PRIVATE :: ncrk2 = 2.59e15    ! Long's collection kernel coefficient
+   REAL, PARAMETER, PRIVATE :: di100 = 1.e-4      ! parameter related with accretion and collection of cloud drops
+   REAL, PARAMETER, PRIVATE :: di600 = 6.e-4      ! parameter related with accretion and collection of cloud drops
+   REAL, PARAMETER, PRIVATE :: di2000 = 2000.e-6  ! parameter related with accretion and collection of cloud drops 
+   REAL, PARAMETER, PRIVATE :: di82    = 82.e-6   ! dimater related with raindrops evaporation
+   REAL, PARAMETER, PRIVATE :: di15    = 15.e-6   ! auto conversion takes place beyond this diameter 
+!
+   REAL, SAVE ::                                           &
+             qc0,qck1,pidnc,bvtr1,bvtr2,bvtr3,bvtr4,bvtr5, &
+             bvtr6,bvtr7, bvtr2o5,bvtr3o5,                 &
+             g1pbr,g2pbr,g3pbr,g4pbr,g5pbr,g6pbr,g7pbr,    &
+             g5pbro2,g7pbro2,pi,                           &
+             pvtr,pvtrn,eacrr,pacrr,pidn0r,pidnr,          &
+             precr1,precr2,xmmax,roqimax,bvts1,bvts2,      &
+             bvts3,bvts4,g1pbs,g3pbs,g4pbs,g5pbso2,        &
+             pvts,pacrs,precs1,precs2,pidn0s,xlv1,pacrc,   &
+             bvtg1,bvtg2,bvtg3,bvtg4,g1pbg,g3pbg,g4pbg,    &
+             g5pbgo2,pvtg,pacrg,precg1,precg2,pidn0g,      &
+             rslopecmax,rslopec2max,rslopec3max,           &
+             rslopermax,rslopesmax,rslopegmax,             &
+             rsloperbmax,rslopesbmax,rslopegbmax,          &
+             rsloper2max,rslopes2max,rslopeg2max,          &
+             rsloper3max,rslopes3max,rslopeg3max
+CONTAINS
+!===================================================================
+!
+  SUBROUTINE wdm6(th, q, qc, qr, qi, qs, qg,               &
+                    nn, nc, nr,                            &
+                    den, pii, p, delz,                     &
+                    delt,g, cpd, cpv, ccn0, rd, rv, t0c,   &
+                    ep1, ep2, qmin,                        &
+                    XLS, XLV0, XLF0, den0, denr,           &
+                    cliq,cice,psat,                        &
+                    rain, rainncv,                         &
+                    snow, snowncv,                         &
+                    sr,                                    &
+                    graupel, graupelncv,                   &
+                    itimestep,                             &
+                    ids,ide, jds,jde, kds,kde,             &
+                    ims,ime, jms,jme, kms,kme,             &
+                    its,ite, jts,jte, kts,kte              &
+                                                           )
+!-------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------
+!
+!  This code is a WRF double-moment 6-class GRAUPEL phase 
+!  microphyiscs scheme (WDM6). The WDM microphysics scheme predicts 
+!  number concentrations for warm rain species including clouds and 
+!  rain. cloud condensation nuclei (CCN) is also predicted.
+!  The cold rain species including ice, snow, graupel follow the 
+!  WRF single-moment 6-class microphysics (WSM6, Hong and Lim 2006)
+!  in which theoretical background for WSM ice phase microphysics is 
+!  based on Hong et al. (2004). A new mixed-phase terminal velocity
+!  for precipitating ice is introduced in WSM6 (Dudhia et al. 2008). 
+!  The WDM scheme is described in Lim and Hong (2010).
+!  All units are in m.k.s. and source/sink terms in kgkg-1s-1.
+!
+!  WDM6 cloud scheme
+!
+!  Coded by Kyo-Sun Lim and Song-You Hong (Yonsei Univ.) Fall 2008
+!
+!  Implemented by Kyo-Sun Lim and Jimy Dudhia (NCAR) Winter 2008
+!
+!  Reference) Lim and Hong (LH, 2010) Mon. Wea. Rev. 
+!             Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. 
+!             Hong and Lim (HL, 2006) J. Korean Meteor. Soc. 
+!             Cohard and Pinty (CP, 2000) Quart. J. Roy. Meteor. Soc.
+!             Khairoutdinov and Kogan (KK, 2000) Mon. Wea. Rev.
+!             Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan
+!             
+!             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, &
+                                                              nn, & 
+                                                              nc, &
+                                                              nr
+  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, &
+                                                            ccn0, &
+                                                             ep1, &
+                                                             ep2, &
+                                                            qmin, &
+                                                             XLS, &
+                                                            XLV0, &
+                                                            XLF0, &
+                                                            cliq, &
+                                                            cice, &
+                                                            psat, &
+                                                            denr
+  INTEGER, INTENT(IN   ) ::                            itimestep
+  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, ncr
+  INTEGER ::               i,j,k
+!-------------------------------------------------------------------
+      IF (itimestep .eq. 1) THEN 
+        DO j=jms,jme
+           DO k=kms,kme    
+           DO i=ims,ime
+              nn(i,k,j) = ccn0   
+           ENDDO
+           ENDDO
+        ENDDO
+      ENDIF
+!
+      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)
+            ncr(i,k,1) = nn(i,k,j)
+            ncr(i,k,2) = nc(i,k,j)
+            ncr(i,k,3) = nr(i,k,j)     
+         ENDDO
+         ENDDO
+         !  Sending array starting locations of optional variables may cause
+         !  troubles, so we explicitly change the call.
+         CALL wdm62D(t, q(ims,kms,j), qci, qrs, ncr               &
+                    ,den(ims,kms,j)                               &
+                    ,p(ims,kms,j), delz(ims,kms,j)                &
+                    ,delt,g, cpd, cpv, ccn0, 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)
+            nn(i,k,j) = ncr(i,k,1)
+            nc(i,k,j) = ncr(i,k,2)
+            nr(i,k,j) = ncr(i,k,3)   
+         ENDDO
+         ENDDO
+      ENDDO
+  END SUBROUTINE wdm6
+!===================================================================
+!
+  SUBROUTINE wdm62D(t, q, qci, qrs, ncr, den, p, delz             &
+                   ,delt,g, cpd, cpv, ccn0, 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, &
+                                                             ncr 
+  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, &
+                                                            ccn0, &
+                                                             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, qrs_tmp
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         & 
+        rslopec, rslopec2,rslopec3 
+  REAL, DIMENSION( its:ite , kts:kte,  2) ::                      &
+        avedia 
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+        workn,falln,falkn
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+        worka,workr
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+        den_tmp, delz_tmp, ncr_tmp 
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+        falkc, work1c, work2c, fallc
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+        pcact, 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 ) :: paacw
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+        nraut, nracw, ncevp, nccol, nrcol,                        &
+        nsacw, ngacw, niacr, nsacr, ngacr, naacw,                 &
+        nseml, ngeml, ncact 
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+        pigen, pidep, pcond, xl, cpm, work2, psmlt, psevp,        &
+        denfac, xni, pgevp,n0sfac, qsum,                          &
+        denqrs1, denqr1, denqrs2, denqrs3, denncr3, denqci  
+  REAL, DIMENSION( its:ite ) ::                                   &
+        delqrs1, delqrs2, delqrs3, delncr3, delqi
+  REAL, DIMENSION( its:ite ) :: tstepsnow, tstepgraup
+  REAL :: gfac, sfac
+! variables for optimization
+  REAL, DIMENSION( its:ite )           :: tvec1
+  REAL :: temp
+  INTEGER, DIMENSION( its:ite ) :: mnstep, numndt
+  INTEGER, DIMENSION( its:ite ) :: mstep, numdt
+  LOGICAL, DIMENSION( its:ite ) :: flgcld
+  REAL  ::                                                        &
+            cpmcal, xlcal, lamdac,                                &
+            diffus,                                               &
+            viscos, xka, venfac, conden, diffac,                  &
+            x, y, z, a, b, c, d, e,                               &
+            ndt, qdt, holdrr, holdrs, holdrg, supcol, supcolt,    &
+            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, coecol,               &
+            nfrzdtr, nfrzdtc,                                     &
+            taucon, lencon, lenconcr,                       &
+            xlf, pfrzdtc, pfrzdtr, supice, alpha2, delta2, delta3 
+  REAL  :: vt2ave
+  REAL  :: holdc, holdci
+!
+  INTEGER :: i, j, k, mstepmax,                                                &
+            iprt, latd, lond, loop, loops, ifsat, n, idim, kdim
+! 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)) 
+      lamdac(x,y,z)= exp(log(((pidnc*z)/(x*y)))*((.33333333)))
+!----------------------------------------------------------------
+!     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))
+!
+      idim = ite-its+1
+      kdim = kte-kts+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)
+          ncr(i,k,1) = max(ncr(i,k,1),0.0)
+          ncr(i,k,2) = max(ncr(i,k,2),0.0)
+          ncr(i,k,3) = max(ncr(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
+      do k = kts, kte
+        do i = its, ite
+          delz_tmp(i,k) = delz(i,k)
+          den_tmp(i,k) = den(i,k)
+        enddo
+      enddo
+!
+!----------------------------------------------------------------
+!    initialize the surface rain, snow, graupel
+!
+      do i = its, ite
+        rainncv(i) = 0.
+        if(PRESENT (snowncv) .AND. PRESENT (snow)) snowncv(i) = 0.
+        if(PRESENT (graupelncv) .AND. PRESENT (graupel)) graupelncv(i) = 0.
+        sr(i) = 0.
+! new local array to catch step snow and graupel
+        tstepsnow(i) = 0.
+        tstepgraup(i) = 0.
+      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
+        mnstep(i) = 1
+        flgcld(i) = .true.
+      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) = min(qs(i,k,1),0.99*p(i,k))
+          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) = min(qs(i,k,2),0.99*p(i,k))
+          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.
+          paacw(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.
+          pcact(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.
+          falln(i,k) =0.
+          falkn(i,k) =0.
+          xni(i,k) = 1.e3
+          nsacw(i,k) = 0.
+          ngacw(i,k) = 0.
+          naacw(i,k) = 0.
+          niacr(i,k) = 0.
+          nsacr(i,k) = 0.
+          ngacr(i,k) = 0.
+          nseml(i,k) = 0.
+          ngeml(i,k) = 0.
+          nracw(i,k) = 0.
+          nccol(i,k) = 0.
+          nrcol(i,k) = 0.
+          ncact(i,k) = 0.
+          nraut(i,k) = 0.
+          ncevp(i,k) = 0.
+        enddo
+      enddo
+      do k = kts, kte
+        do i = its, ite
+          if(qci(i,k,1).le.qmin .or. ncr(i,k,2).le.ncmin ) then
+            rslopec(i,k) = rslopecmax
+            rslopec2(i,k) = rslopec2max
+            rslopec3(i,k) = rslopec3max
+          else
+            rslopec(i,k) = 1./lamdac(qci(i,k,1),den(i,k),ncr(i,k,2))
+            rslopec2(i,k) = rslopec(i,k)*rslopec(i,k)
+            rslopec3(i,k) = rslopec2(i,k)*rslopec(i,k)
+          endif
+!-------------------------------------------------------------
+! Ni: ice crystal number concentraiton   [HDC 5c]
+!-------------------------------------------------------------
+          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
+!----------------------------------------------------------------
+!     compute the fallout term:
+!     first, vertical terminal velosity for minor loops
+!----------------------------------------------------------------
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k,1) = qrs(i,k,1)
+          qrs_tmp(i,k,2) = qrs(i,k,2)
+          qrs_tmp(i,k,3) = qrs(i,k,3)
+          ncr_tmp(i,k) = ncr(i,k,3)
+        enddo
+      enddo
+      call slope_wdm6(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, & 
+                     rslope3,work1,workn,its,ite,kts,kte)
+!
+! vt update for qr and nr
+      mstepmax = 1
+      numdt = 1
+      do k = kte, kts, -1
+        do i = its, ite
+          work1(i,k,1) = work1(i,k,1)/delz(i,k)
+          workn(i,k) = workn(i,k)/delz(i,k)
+          numdt(i) = max(nint(max(work1(i,k,1),workn(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,1) = den(i,k)*qrs(i,k,1)*work1(i,k,1)/mstep(i)
+            falkn(i,k) = ncr(i,k,3)*workn(i,k)/mstep(i)
+            fall(i,k,1) = fall(i,k,1)+falk(i,k,1)
+            falln(i,k) = falln(i,k)+falkn(i,k)
+            qrs(i,k,1) = max(qrs(i,k,1)-falk(i,k,1)*dtcld/den(i,k),0.)
+            ncr(i,k,3) = max(ncr(i,k,3)-falkn(i,k)*dtcld,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)
+              falkn(i,k) = ncr(i,k,3)*workn(i,k)/mstep(i)
+              fall(i,k,1) = fall(i,k,1)+falk(i,k,1)
+              falln(i,k) = falln(i,k)+falkn(i,k)
+              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.)
+              ncr(i,k,3) = max(ncr(i,k,3)-(falkn(i,k)-falkn(i,k+1)*delz(i,k+1) &
+                          /delz(i,k))*dtcld,0.)
+            endif
+          enddo
+        enddo
+        do k = kts, kte
+          do i = its, ite
+            qrs_tmp(i,k,1) = qrs(i,k,1)
+            ncr_tmp(i,k) = ncr(i,k,3)
+          enddo
+        enddo
+        call slope_rain(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, &
+                     rslope3,work1,workn,its,ite,kts,kte)
+        do k = kte, kts, -1
+          do i = its, ite
+            work1(i,k,1) = work1(i,k,1)/delz(i,k)
+            workn(i,k) = workn(i,k)/delz(i,k)
+          enddo
+        enddo
+      enddo
+! for semi
+      do k = kte, kts, -1
+        do i = its, ite
+          qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15)
+          if(qsum(i,k) .gt. 1.e-15 ) then
+            worka(i,k) = (work1(i,k,2)*qrs(i,k,2) + work1(i,k,3)*qrs(i,k,3)) &
+                      /qsum(i,k)
+          else
+            worka(i,k) = 0.
+          endif
+          denqrs2(i,k) = den(i,k)*qrs(i,k,2)
+          denqrs3(i,k) = den(i,k)*qrs(i,k,3)
+        enddo
+      enddo
+      call nislfv_rain_plm6(idim,kdim,den_tmp,denfac,t,delz_tmp,worka,         &
+                           denqrs2,denqrs3,delqrs2,delqrs3,dtcld,1,1)
+      do k = kts, kte
+        do i = its, ite
+          qrs(i,k,2) = max(denqrs2(i,k)/den(i,k),0.)
+          qrs(i,k,3) = max(denqrs3(i,k)/den(i,k),0.)
+          fall(i,k,2) = denqrs2(i,k)*worka(i,k)/delz(i,k)
+          fall(i,k,3) = denqrs3(i,k)*worka(i,k)/delz(i,k)
+        enddo
+      enddo
+      do i = its, ite
+        fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld
+        fall(i,1,3) = delqrs3(i)/delz(i,1)/dtcld
+      enddo
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k,1) = qrs(i,k,1)
+          qrs_tmp(i,k,2) = qrs(i,k,2)
+          qrs_tmp(i,k,3) = qrs(i,k,3)
+          ncr_tmp(i,k) = ncr(i,k,3)
+        enddo
+      enddo
+      call slope_wdm6(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, &
+                     rslope3,work1,workn,its,ite,kts,kte)
+!
+      do k = kte, kts, -1
+        do i = its, ite
+          supcol = t0c-t(i,k)
+          n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.)
+          if(t(i,k).gt.t0c) then
+!---------------------------------------------------------------
+! psmlt: melting of snow [HL A33] [RH83 A25]
+!       (T>T0: QS->QR)
+!---------------------------------------------------------------
+            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)
+!-------------------------------------------------------------------
+! nsmlt: melting of snow [LH A27]
+!       (T>T0: ->NR)
+!-------------------------------------------------------------------
+              if(qrs(i,k,2).gt.qcrmin) then
+                sfac = rslope(i,k,2)*n0s*n0sfac(i,k)/qrs(i,k,2)
+                ncr(i,k,3) = ncr(i,k,3) - sfac*psmlt(i,k)
+              endif
+              t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k)
+            endif
+!---------------------------------------------------------------
+! pgmlt: melting of graupel [HL A23]  [LFO 47]
+!       (T>T0: QG->QR)
+!---------------------------------------------------------------
+            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)
+!-------------------------------------------------------------------
+! ngmlt: melting of graupel [LH A28]
+!       (T>T0: ->NR)
+!-------------------------------------------------------------------
+              if(qrs(i,k,3).gt.qcrmin) then
+                gfac = rslope(i,k,3)*n0g/qrs(i,k,3)
+                ncr(i,k,3) = ncr(i,k,3) - gfac*pgmlt(i,k)
+              endif
+              t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!---------------------------------------------------------------
+! Vice [ms-1] : fallout of ice crystal [HDC 5a]
+!---------------------------------------------------------------
+      do k = kte, kts, -1
+        do i = its, ite
+          if(qci(i,k,2).le.0.) then
+            work1c(i,k) = 0.
+          else
+            xmi = den(i,k)*qci(i,k,2)/xni(i,k)
+            diameter  = max(min(dicon * sqrt(xmi),dimax), 1.e-25)
+            work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31))
+          endif
+        enddo
+      enddo
+!
+!  forward semi-laglangian scheme (JH), PCM (piecewise constant),  (linear)
+!
+      do k = kte, kts, -1
+        do i = its, ite
+          denqci(i,k) = den(i,k)*qci(i,k,2)
+        enddo
+      enddo
+      call nislfv_rain_plmr(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci,denqci,  &
+                           delqi,dtcld,1,0,0)
+      do k = kts, kte
+        do i = its, ite
+          qci(i,k,2) = max(denqci(i,k)/den(i,k),0.)
+        enddo
+      enddo
+      do i = its, ite
+        fallc(i,1) = delqi(i)/delz(i,1)/dtcld
+      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)
+        if(fallsum.gt.0.) then
+          rainncv(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rainncv(i)
+          rain(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rain(i)
+        endif
+        if(fallsum_qsi.gt.0.) then
+            tstepsnow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + tstepsnow(i)
+        IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN
+            snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snowncv(i)     
+            snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i)
+        ENDIF
+        endif
+        if(fallsum_qg.gt.0.) then
+            tstepgraup(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000.            &
+                            + tstepgraup(i)
+        IF ( PRESENT (graupelncv) .AND. PRESENT (graupel)) THEN
+            graupelncv(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000.            &  
+                            + graupelncv(i)
+            graupel(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i)
+        ENDIF
+        endif
+!       if(fallsum.gt.0.) sr(i) = (snowncv(i) + graupelncv(i))                 &  
+        if(fallsum.gt.0.) sr(i) = (tstepsnow(i) + tstepgraup(i))               &  
+                                  /(rainncv(i)+1.e-12)
+      enddo
+!
+!---------------------------------------------------------------
+! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28]
+!       (T>T0: QI->QC)
+!---------------------------------------------------------------
+      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)
+!---------------------------------------------------------------
+! nimlt: instantaneous melting of cloud ice  [LH A18]
+!        (T>T0: ->NC)
+!--------------------------------------------------------------
+            ncr(i,k,2) = ncr(i,k,2) + xni(i,k)
+            t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2)
+            qci(i,k,2) = 0.
+          endif
+!---------------------------------------------------------------
+! pihmf: homogeneous  of cloud water below -40c [HL A45]
+!        (T<-40C: QC->QI)
+!---------------------------------------------------------------
+          if(supcol.gt.40. .and. qci(i,k,1).gt.0.) then
+            qci(i,k,2) = qci(i,k,2) + qci(i,k,1)
+!---------------------------------------------------------------
+! nihmf: homogeneous  of cloud water below -40c [LH A17]
+!        (T<-40C: NC->) 
+!---------------------------------------------------------------
+            if(ncr(i,k,2).gt.0.) ncr(i,k,2) = 0. 
+            t(i,k) = t(i,k) + xlf/cpm(i,k)*qci(i,k,1)
+            qci(i,k,1) = 0.
+          endif
+!---------------------------------------------------------------
+! pihtf: heterogeneous  of cloud water [HL A44]
+!        (T0>T>-40C: QC->QI)
+!---------------------------------------------------------------
+          if(supcol.gt.0. .and. qci(i,k,1).gt.qmin) then
+            supcolt=min(supcol,70.)
+            pfrzdtc = min(pi*pi*pfrz1*(exp(pfrz2*supcolt)-1.)*denr/den(i,k)    & 
+                     *ncr(i,k,2)*rslopec3(i,k)*rslopec3(i,k)/18.*dtcld         &
+                     ,qci(i,k,1))
+!---------------------------------------------------------------
+! nihtf: heterogeneous  of cloud water [LH A16]
+!         (T0>T>-40C: NC->) 
+!---------------------------------------------------------------
+            if(ncr(i,k,2).gt.ncmin) then
+              nfrzdtc = min(pi*pfrz1*(exp(pfrz2*supcolt)-1.)*ncr(i,k,2)        &
+                      *rslopec3(i,k)/6.*dtcld,ncr(i,k,2))
+              ncr(i,k,2) = ncr(i,k,2) - nfrzdtc
+            endif
+            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]
+!        (T<T0, QR->QG)
+!---------------------------------------------------------------
+          if(supcol.gt.0. .and. qrs(i,k,1).gt.0.) then
+            supcolt=min(supcol,70.)
+            pfrzdtr = min(140.*(pi*pi)*pfrz1*ncr(i,k,3)*denr/den(i,k)          &
+                  *(exp(pfrz2*supcolt)-1.)*rslope3(i,k,1)*rslope3(i,k,1)       & 
+                  *dtcld,qrs(i,k,1))        
+!---------------------------------------------------------------
+! ngfrz: freezing of rain water [LH A26]
+!        (T<T0, NR-> ) 
+!---------------------------------------------------------------
+            if(ncr(i,k,3).gt.nrmin) then
+              nfrzdtr = min(4.*pi*pfrz1*ncr(i,k,3)*(exp(pfrz2*supcolt)-1.)     &
+                       *rslope3(i,k,1)*dtcld, ncr(i,k,3)) 
+              ncr(i,k,3) = ncr(i,k,3) - nfrzdtr
+            endif
+            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
+!
+      do k = kts, kte
+        do i = its, ite
+          ncr(i,k,2) = max(ncr(i,k,2),0.0)
+          ncr(i,k,3) = max(ncr(i,k,3),0.0)
+        enddo
+      enddo
+!
+!----------------------------------------------------------------
+!     update the slope parameters for microphysics computation
+!
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k,1) = qrs(i,k,1)
+          qrs_tmp(i,k,2) = qrs(i,k,2)
+          qrs_tmp(i,k,3) = qrs(i,k,3)
+          ncr_tmp(i,k) = ncr(i,k,3)
+        enddo
+      enddo
+      call slope_wdm6(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, &
+                     rslope3,work1,workn,its,ite,kts,kte)
+      do k = kts, kte
+        do i = its, ite
+!-----------------------------------------------------------------
+! compute the mean-volume drop diameter                  [LH A10] 
+! for raindrop distribution                          
+!-----------------------------------------------------------------
+          avedia(i,k,2) = rslope(i,k,1)*((24.)**(.3333333))
+!
+          if(qci(i,k,1).le.qmin .or. ncr(i,k,2).le.ncmin) then
+            rslopec(i,k) = rslopecmax
+            rslopec2(i,k) = rslopec2max
+            rslopec3(i,k) = rslopec3max
+          else
+            rslopec(i,k) = 1./lamdac(qci(i,k,1),den(i,k),ncr(i,k,2))
+            rslopec2(i,k) = rslopec(i,k)*rslopec(i,k)
+            rslopec3(i,k) = rslopec2(i,k)*rslopec(i,k)
+          endif
+!--------------------------------------------------------------------
+! compute the mean-volume drop diameter                   [LH A7]
+! for cloud-droplet distribution
+!--------------------------------------------------------------------
+          avedia(i,k,1) = rslopec(i,k)
+        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 double-moment processes in Lim and Hong
+!
+!===============================================================
+!
+      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  [LH 9] [CP 17]
+!        (QC->QR)
+!--------------------------------------------------------------
+          lencon  = 2.7e-2*den(i,k)*qci(i,k,1)*(1.e20/16.*rslopec2(i,k)        &
+                   *rslopec2(i,k)-0.4)
+          lenconcr = max(1.2*lencon, qcrmin)
+          if(avedia(i,k,1).gt.di15) then
+            taucon = 3.7/den(i,k)/qci(i,k,1)/(0.5e6*rslopec(i,k)-7.5)
+            praut(i,k) = lencon/taucon
+            praut(i,k) = min(max(praut(i,k),0.),qci(i,k,1)/dtcld)
+!---------------------------------------------------------------
+! nraut: auto conversion rate from cloud to rain [LH A6] [CP 18 & 19]
+!        (NC->NR)
+!---------------------------------------------------------------
+            nraut(i,k) = 3.5e9*den(i,k)*praut(i,k)
+            if(qrs(i,k,1).gt.lenconcr)                                         &
+            nraut(i,k) = ncr(i,k,3)/qrs(i,k,1)*praut(i,k)
+            nraut(i,k) = min(nraut(i,k),ncr(i,k,2)/dtcld)
+          endif
+!---------------------------------------------------------------
+! pracw: accretion of cloud water by rain     [LH 10] [CP 22 & 23]
+!        (QC->QR)
+! nracw: accretion of cloud water by rain     [LH A9]
+!        (NC->)
+!---------------------------------------------------------------
+          if(qrs(i,k,1).ge.lenconcr) then
+            if(avedia(i,k,2).ge.di100) then
+              nracw(i,k) = min(ncrk1*ncr(i,k,2)*ncr(i,k,3)*(rslopec3(i,k)      &
+                         + 24.*rslope3(i,k,1)),ncr(i,k,2)/dtcld)
+              pracw(i,k) = min(pi/6.*(denr/den(i,k))*ncrk1*ncr(i,k,2)          &
+                         *ncr(i,k,3)*rslopec3(i,k)*(2.*rslopec3(i,k)           &
+                         + 24.*rslope3(i,k,1)),qci(i,k,1)/dtcld)   
+            else
+              nracw(i,k) = min(ncrk2*ncr(i,k,2)*ncr(i,k,3)*(2.*rslopec3(i,k)   &
+                         *rslopec3(i,k)+5040.*rslope3(i,k,1)                   &
+                         *rslope3(i,k,1)),ncr(i,k,2)/dtcld)
+              pracw(i,k) = min(pi/6.*(denr/den(i,k))*ncrk2*ncr(i,k,2)          &
+                         *ncr(i,k,3)*rslopec3(i,k)*(6.*rslopec3(i,k)           &     
+                         *rslopec3(i,k)+5040.*rslope3(i,k,1)*rslope3(i,k,1))   & 
+                         ,qci(i,k,1)/dtcld)
+            endif
+          endif 
+!----------------------------------------------------------------
+! nccol: self collection of cloud water             [LH A8] [CP 24 & 25]     
+!        (NC->)
+!----------------------------------------------------------------
+          if(avedia(i,k,1).ge.di100) then
+            nccol(i,k) = ncrk1*ncr(i,k,2)*ncr(i,k,2)*rslopec3(i,k)
+          else
+            nccol(i,k) = 2.*ncrk2*ncr(i,k,2)*ncr(i,k,2)*rslopec3(i,k)        &     
+                         *rslopec3(i,k)
+          endif
+!----------------------------------------------------------------
+! nrcol: self collection of rain-drops and break-up [LH A21] [CP 24 & 25]
+!        (NR->)
+!----------------------------------------------------------------
+          if(qrs(i,k,1).ge.lenconcr) then
+            if(avedia(i,k,2).lt.di100) then 
+              nrcol(i,k) = 5040.*ncrk2*ncr(i,k,3)*ncr(i,k,3)*rslope3(i,k,1)    &
+                          *rslope3(i,k,1)
+            elseif(avedia(i,k,2).ge.di100 .and. avedia(i,k,2).lt.di600) then
+              nrcol(i,k) = 24.*ncrk1*ncr(i,k,3)*ncr(i,k,3)*rslope3(i,k,1)
+            elseif(avedia(i,k,2).ge.di600 .and. avedia(i,k,2).lt.di2000) then
+              coecol = -2.5e3*(avedia(i,k,2)-di600) 
+              nrcol(i,k) = 24.*exp(coecol)*ncrk1*ncr(i,k,3)*ncr(i,k,3)         &
+                         *rslope3(i,k,1)
+            else
+              nrcol(i,k) = 0.
+            endif
+          endif
+!---------------------------------------------------------------
+! prevp: evaporation/condensation rate of rain   [HL A41]  
+!        (QV->QR or QR->QV)
+!---------------------------------------------------------------
+          if(qrs(i,k,1).gt.0.) then
+            coeres = rslope(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1))
+            prevp(i,k) = (rh(i,k,1)-1.)*ncr(i,k,3)*(precr1*rslope(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)
+!----------------------------------------------------------------
+! Nrevp: evaporation/condensation rate of rain   [LH A14] 
+!        (NR->NCCN) 
+!----------------------------------------------------------------
+              if(prevp(i,k).eq.-qrs(i,k,1)/dtcld) then 
+                ncr(i,k,1) = ncr(i,k,1)+ncr(i,k,3)
+                ncr(i,k,3) = 0. 
+              endif
+            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)
+          n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.)
+          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)
+          qsum(i,k) = max((qrs(i,k,2)+qrs(i,k,3)),1.e-15)
+          if(qsum(i,k) .gt. 1.e-15) then
+            vt2ave=(vt2s*qrs(i,k,2)+vt2g*qrs(i,k,3))/(qsum(i,k))          
+          else    
+            vt2ave=0.
+          endif
+          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]
+!        (T<T0: QI->QR)
+!-------------------------------------------------------------
+              acrfac = 6.*rslope2(i,k,1)+4.*diameter*rslope(i,k,1) + diameter**2
+              praci(i,k) = pi*qci(i,k,2)*ncr(i,k,3)*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]
+!        (T<T0: QR->QS or QR->QG)
+!-------------------------------------------------------------
+              piacr(i,k) = pi*pi*avtr*ncr(i,k,3)*denr*xni(i,k)*denfac(i,k)     &
+                          *g7pbr*rslope3(i,k,1)*rslope2(i,k,1)*rslopeb(i,k,1)  &
+                          /24./den(i,k)
+              piacr(i,k) = min(piacr(i,k),qrs(i,k,1)/dtcld)
+            endif
+!-------------------------------------------------------------
+! niacr: Accretion of rain by cloud ice  [LH A25]
+!        (T<T0: NR->) 
+!-------------------------------------------------------------
+            if(ncr(i,k,3).gt.nrmin) then
+              niacr(i,k) = pi*avtr*ncr(i,k,3)*xni(i,k)*denfac(i,k)*g4pbr       &
+                          *rslope2(i,k,1)*rslopeb(i,k,1)/4.
+              niacr(i,k) = min(niacr(i,k),ncr(i,k,3)/dtcld)
+            endif
+!-------------------------------------------------------------
+! psaci: Accretion of cloud ice by snow [HDC 10]
+!        (T<T0: QI->QS)
+!-------------------------------------------------------------
+            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(vt2ave-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]
+!        (T<T0: QI->QG)
+!-------------------------------------------------------------
+            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(vt2ave-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]
+!        (T<T0: QC->QS, and T>=T0: QC->QR)
+!-------------------------------------------------------------
+          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
+!-------------------------------------------------------------
+! nsacw: Accretion of cloud water by snow  [LH A12]
+!        (NC ->) 
+!-------------------------------------------------------------
+         if(qrs(i,k,2).gt.qcrmin .and. ncr(i,k,2).gt.ncmin) then
+           nsacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2)    &
+                       *ncr(i,k,2)*denfac(i,k),ncr(i,k,2)/dtcld)
+         endif
+!-------------------------------------------------------------
+! pgacw: Accretion of cloud water by graupel [HL A6] [LFO 40]
+!        (T<T0: QC->QG, and T>=T0: QC->QR)
+!-------------------------------------------------------------
+          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
+!-------------------------------------------------------------
+! ngacw: Accretion of cloud water by graupel [LH A13]
+!        (NC-> 
+!-------------------------------------------------------------
+          if(qrs(i,k,3).gt.qcrmin .and. ncr(i,k,2).gt.ncmin) then
+            ngacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3)*ncr(i,k,2)    &
+                        *denfac(i,k),ncr(i,k,2)/dtcld)
+          endif
+!-------------------------------------------------------------
+! paacw: Accretion of cloud water by averaged snow/graupel 
+!        (T<T0: QC->QG or QS, and T>=T0: QC->QR) 
+!-------------------------------------------------------------
+          if(qrs(i,k,2).gt.qcrmin .and. qrs(i,k,3).gt.qcrmin) then
+            paacw(i,k) = (qrs(i,k,2)*psacw(i,k)+qrs(i,k,3)*pgacw(i,k))/(qsum(i,k))
+!-------------------------------------------------------------
+! naacw: Accretion of cloud water by averaged snow/graupel
+!        (Nc->)
+!-------------------------------------------------------------
+            naacw(i,k) = (qrs(i,k,2)*nsacw(i,k)+qrs(i,k,3)*ngacw(i,k))/(qsum(i,k))
+          endif      
+!-------------------------------------------------------------
+! pracs: Accretion of snow by rain [HL A11] [LFO 27]
+!         (T<T0: QS->QG)
+!-------------------------------------------------------------
+          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)                        &
+                      + 4.*rslope3(i,k,2)*rslope2(i,k,2)*rslope(i,k,1)         &
+                      + 1.5*rslope2(i,k,2)*rslope2(i,k,2)*rslope2(i,k,1)
+              pracs(i,k) = pi*pi*ncr(i,k,3)*n0s*n0sfac(i,k)*abs(vt2r-vt2ave)   &
+                          *(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]
+!         (T<T0:QR->QS or QR->QG) (T>=T0: enhance melting of snow)
+!-------------------------------------------------------------
+            acrfac = 30.*rslope3(i,k,1)*rslope2(i,k,1)*rslope(i,k,2)           &
+                     + 5.*rslope2(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2)         &
+                     + 2.*rslope3(i,k,1)*rslope3(i,k,2)
+            psacr(i,k) = pi*pi*ncr(i,k,3)*n0s*n0sfac(i,k)*abs(vt2ave-vt2r)     &
+                        *(denr/den(i,k))*acrfac
+            psacr(i,k) = min(psacr(i,k),qrs(i,k,1)/dtcld)
+          endif
+          if(qrs(i,k,2).gt.qcrmin .and. ncr(i,k,3).gt.nrmin) then
+!-------------------------------------------------------------
+! nsacr: Accretion of rain by snow  [LH A23] 
+!       (T<T0:NR->)
+!-------------------------------------------------------------
+            acrfac = 1.5*rslope2(i,k,1)*rslope(i,k,2)                          &
+                    + 1.0*rslope(i,k,1)*rslope2(i,k,2)+.5*rslope3(i,k,2)        
+            nsacr(i,k) = pi*ncr(i,k,3)*n0s*n0sfac(i,k)*abs(vt2ave-vt2r)        &
+                        *acrfac
+            nsacr(i,k) = min(nsacr(i,k),ncr(i,k,3)/dtcld)
+          endif
+!-------------------------------------------------------------
+! pgacr: Accretion of rain by graupel [HL A12] [LFO 42]
+!         (T<T0: QR->QG) (T>=T0: enhance melting of graupel)
+!-------------------------------------------------------------
+          if(qrs(i,k,3).gt.qcrmin .and. qrs(i,k,1).gt.qcrmin) then
+            acrfac = 30.*rslope3(i,k,1)*rslope2(i,k,1)*rslope(i,k,3)           &
+                    + 5.*rslope2(i,k,1)*rslope2(i,k,1)*rslope2(i,k,3)          &
+                    + 2.*rslope3(i,k,1)*rslope3(i,k,3)
+            pgacr(i,k) = pi*pi*ncr(i,k,3)*n0g*abs(vt2ave-vt2r)*(denr/den(i,k)) &
+                        *acrfac
+            pgacr(i,k) = min(pgacr(i,k),qrs(i,k,1)/dtcld)
+          endif
+!-------------------------------------------------------------
+! ngacr: Accretion of rain by graupel  [LH A24] 
+!        (T<T0: NR->) 
+!-------------------------------------------------------------
+          if(qrs(i,k,3).gt.qcrmin .and. ncr(i,k,3).gt.nrmin) then
+            acrfac = 1.5*rslope2(i,k,1)*rslope(i,k,3)                          &
+                    + 1.0*rslope(i,k,1)*rslope2(i,k,3) + .5*rslope3(i,k,3)   
+            ngacr(i,k) = pi*ncr(i,k,3)*n0g*abs(vt2ave-vt2r)*acrfac
+            ngacr(i,k) = min(ngacr(i,k),ncr(i,k,3)/dtcld)
+          endif
+!
+!-------------------------------------------------------------
+! pgacs: Accretion of snow by graupel [HL A13] [LFO 29]
+!        (QS->QG) : This process is eliminated in V3.0 with the
+!        new combined snow/graupel fall speeds
+!-------------------------------------------------------------
+          if(qrs(i,k,3).gt.qcrmin .and. qrs(i,k,2).gt.qcrmin) then
+            pgacs(i,k) = 0. 
+          endif
+          if(supcol.le.0) then
+            xlf = xlf0
+!-------------------------------------------------------------
+! pseml: Enhanced melting of snow by accretion of water [HL A34]
+!        (T>=T0: QS->QR)
+!-------------------------------------------------------------
+            if(qrs(i,k,2).gt.0.)                                               & 
+              pseml(i,k) = min(max(cliq*supcol*(paacw(i,k)+psacr(i,k))         &
+                          /xlf,-qrs(i,k,2)/dtcld),0.)
+!--------------------------------------------------------------
+! nseml: Enhanced melting of snow by accretion of water    [LH A29]
+!        (T>=T0: ->NR)
+!--------------------------------------------------------------
+              if  (qrs(i,k,2).gt.qcrmin) then
+                sfac = rslope(i,k,2)*n0s*n0sfac(i,k)/qrs(i,k,2)
+                nseml(i,k) = -sfac*pseml(i,k)
+              endif
+!-------------------------------------------------------------
+! pgeml: Enhanced melting of graupel by accretion of water [HL A24] [RH84 A21-A22]
+!        (T>=T0: QG->QR)
+!-------------------------------------------------------------
+            if(qrs(i,k,3).gt.0.)                                               &
+              pgeml(i,k) = min(max(cliq*supcol*(paacw(i,k)+pgacr(i,k))/xlf     &
+                          ,-qrs(i,k,3)/dtcld),0.)
+!--------------------------------------------------------------
+! ngeml: Enhanced melting of graupel by accretion of water [LH A30] 
+!         (T>=T0: -> NR)
+!--------------------------------------------------------------
+              if (qrs(i,k,3).gt.qcrmin) then
+                gfac = rslope(i,k,3)*n0g/qrs(i,k,3)
+                ngeml(i,k) = -gfac*pgeml(i,k)
+              endif
+          endif
+          if(supcol.gt.0) then
+!-------------------------------------------------------------
+! pidep: Deposition/Sublimation rate of ice [HDC 9]
+!       (T<T0: QV->QI or QI->QV)
+!-------------------------------------------------------------
+            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]
+!        (T<T0: QV->QS or QS->QV)
+!-------------------------------------------------------------
+            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]
+!        (T<T0: QV->QG or QG->QV)
+!-------------------------------------------------------------
+            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]
+!       (T<T0: QV->QI)
+!-------------------------------------------------------------
+            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]
+!        (T<T0: QI->QS)
+!-------------------------------------------------------------
+            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]
+!        (T<T0: QS->QG)
+!-------------------------------------------------------------
+            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: QS->QV)
+!-------------------------------------------------------------
+          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: QG->QV)
+!-------------------------------------------------------------
+            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)+paacw(i,k)+paacw(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
+              paacw(i,k) = paacw(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)+paacw(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
+              paacw(i,k) = paacw(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)+paacw(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
+              paacw(i,k) = paacw(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
+!
+!     cloud
+!
+            value = max(ncmin,ncr(i,k,2))
+            source = (nraut(i,k)+nccol(i,k)+nracw(i,k)                         &
+                    +naacw(i,k)+naacw(i,k))*dtcld
+            if (source.gt.value) then
+              factor = value/source
+              nraut(i,k) = nraut(i,k)*factor
+              nccol(i,k) = nccol(i,k)*factor
+              nracw(i,k) = nracw(i,k)*factor
+              naacw(i,k) = naacw(i,k)*factor
+            endif
+!
+!     rain
+!
+            value = max(nrmin,ncr(i,k,3))
+            source = (-nraut(i,k)+nrcol(i,k)+niacr(i,k)+nsacr(i,k)+ngacr(i,k)  &
+                     )*dtcld
+            if (source.gt.value) then
+              factor = value/source
+              nraut(i,k) = nraut(i,k)*factor
+              nrcol(i,k) = nrcol(i,k)*factor
+              niacr(i,k) = niacr(i,k)*factor
+              nsacr(i,k) = nsacr(i,k)*factor
+              ngacr(i,k) = ngacr(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)                 &
+                           +paacw(i,k)+paacw(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)+paacw(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)+paacw(i,k)       &
+                           +pgacr(i,k)+pgacs(i,k))*dtcld,0.)
+            ncr(i,k,2) = max(ncr(i,k,2)+(-nraut(i,k)-nccol(i,k)-nracw(i,k)     &
+                           -naacw(i,k)-naacw(i,k))*dtcld,0.)
+            ncr(i,k,3) = max(ncr(i,k,3)+(nraut(i,k)-nrcol(i,k)-niacr(i,k)      &
+                           -nsacr(i,k)-ngacr(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)+paacw(i,k)           &
+                      +paacw(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)+paacw(i,k)+paacw(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
+              paacw(i,k) = paacw(i,k)*factor
+            endif
+!
+!     rain
+!
+            value = max(qmin,qrs(i,k,1))
+            source = (-paacw(i,k)-praut(i,k)+pseml(i,k)+pgeml(i,k)             &
+                     -pracw(i,k)-paacw(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
+              pracw(i,k) = pracw(i,k)*factor
+              paacw(i,k) = paacw(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
+!
+!     cloud
+!
+            value = max(ncmin,ncr(i,k,2))
+            source = (+nraut(i,k)+nccol(i,k)+nracw(i,k)+naacw(i,k)             &
+                     +naacw(i,k))*dtcld
+            if (source.gt.value) then
+              factor = value/source
+              nraut(i,k) = nraut(i,k)*factor
+              nccol(i,k) = nccol(i,k)*factor
+              nracw(i,k) = nracw(i,k)*factor
+              naacw(i,k) = naacw(i,k)*factor
+            endif
+!
+!     rain
+!
+            value = max(nrmin,ncr(i,k,3))
+            source = (-nraut(i,k)+nrcol(i,k)-nseml(i,k)-ngeml(i,k)             &
+                      )*dtcld
+            if (source.gt.value) then
+              factor = value/source
+              nraut(i,k) = nraut(i,k)*factor
+              nrcol(i,k) = nrcol(i,k)*factor
+              nseml(i,k) = nseml(i,k)*factor
+              ngeml(i,k) = ngeml(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)                 &
+                    +paacw(i,k)+paacw(i,k))*dtcld,0.)
+            qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k)                 &
+                    +prevp(i,k)+paacw(i,k)+paacw(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.)
+            ncr(i,k,2) = max(ncr(i,k,2)+(-nraut(i,k)-nccol(i,k)-nracw(i,k)     &
+                   -naacw(i,k)-naacw(i,k))*dtcld,0.)
+            ncr(i,k,3) = max(ncr(i,k,3)+(nraut(i,k)-nrcol(i,k)+nseml(i,k)      &
+                           +ngeml(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) = min(qs(i,k,1),0.99*p(i,k))
+          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) = min(qs(i,k,2),0.99*p(i,k))
+          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,1) = max(q(i,k) / qs(i,k,1),qmin)
+        enddo
+      enddo
+!
+      call slope_wdm6(qrs_tmp,ncr_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2, &
+                     rslope3,work1,workn,its,ite,kts,kte)
+      do k = kts, kte
+        do i = its, ite
+!-----------------------------------------------------------------             
+! re-compute the mean-volume drop diameter       [LH A10]
+! for raindrop distribution                          
+!-----------------------------------------------------------------
+          avedia(i,k,2) = rslope(i,k,1)*((24.)**(.3333333))
+!----------------------------------------------------------------
+! Nrevp_s: evaporation/condensation rate of rain   [LH A14]
+!        (NR->NC)
+!----------------------------------------------------------------
+          if(avedia(i,k,2).le.di82) then
+            ncr(i,k,2) = ncr(i,k,2)+ncr(i,k,3)
+            ncr(i,k,3) = 0.
+!----------------------------------------------------------------
+! Prevp_s: evaporation/condensation rate of rain [LH A15] [KK 23]
+!        (QR->QC)
+!----------------------------------------------------------------
+            qci(i,k,1) = qci(i,k,1)+qrs(i,k,1)
+            qrs(i,k,1) = 0.    
+          endif
+        enddo
+      enddo
+!
+      do k = kts, kte
+        do i = its, ite
+!---------------------------------------------------------------
+! rate of change of cloud drop concentration due to CCN activation
+! pcact: QV -> QC                                 [LH 8]  [KK 14]
+! ncact: NCCN -> NC                               [LH A2] [KK 12]
+!---------------------------------------------------------------
+          if(rh(i,k,1).gt.1.) then
+            ncact(i,k) = max(0.,((ncr(i,k,1)+ncr(i,k,2))                       &
+                       *min(1.,(rh(i,k,1)/satmax)**actk) - ncr(i,k,2)))/dtcld
+            ncact(i,k) =min(ncact(i,k),max(ncr(i,k,1),0.)/dtcld)
+            pcact(i,k) = min(4.*pi*denr*(actr*1.E-6)**3*ncact(i,k)/            &
+                         (3.*den(i,k)),max(q(i,k),0.)/dtcld)
+            q(i,k) = max(q(i,k)-pcact(i,k)*dtcld,0.)
+            qci(i,k,1) = max(qci(i,k,1)+pcact(i,k)*dtcld,0.)
+            ncr(i,k,1) = max(ncr(i,k,1)-ncact(i,k)*dtcld,0.)
+            ncr(i,k,2) = max(ncr(i,k,2)+ncact(i,k)*dtcld,0.)
+            t(i,k) = t(i,k)+pcact(i,k)*xl(i,k)/cpm(i,k)*dtcld
+          endif  
+!---------------------------------------------------------------
+!  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
+!  (QV->QC or QC->QV)     
+!---------------------------------------------------------------
+          tr=ttp/t(i,k)
+          qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr))
+          qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k))
+          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)
+          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
+!----------------------------------------------------------------
+! ncevp: evpration of Cloud number concentration  [LH A3] 
+! (NC->NCCN) 
+!----------------------------------------------------------------
+          if(pcond(i,k).eq.-qci(i,k,1)/dtcld) then
+            ncr(i,k,2) = 0.
+            ncr(i,k,1) = ncr(i,k,1)+ncr(i,k,2)
+          endif
+!
+          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 wdm62d
+! ...................................................................
+      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 wdm6init(den0,denr,dens,cl,cpv, ccn0, allowed_to_read)
+!-------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------
+!.... constants which may not be tunable
+   REAL, INTENT(IN) :: den0,denr,dens,cl,cpv,ccn0
+   LOGICAL, INTENT(IN) :: allowed_to_read
+!
+   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
+   pidnc = pi*denr/6.
+!
+   bvtr1 = 1.+bvtr
+   bvtr2 = 2.+bvtr
+   bvtr3 = 3.+bvtr
+   bvtr4 = 4.+bvtr
+   bvtr5 = 5.+bvtr
+   bvtr6 = 6.+bvtr
+   bvtr7 = 7.+bvtr
+   bvtr2o5 = 2.5+.5*bvtr
+   bvtr3o5 = 3.5+.5*bvtr
+   g1pbr = rgmma(bvtr1)
+   g2pbr = rgmma(bvtr2)
+   g3pbr = rgmma(bvtr3)
+   g4pbr = rgmma(bvtr4)            ! 17.837825
+   g5pbr = rgmma(bvtr5)
+   g6pbr = rgmma(bvtr6)
+   g7pbr = rgmma(bvtr7)
+   g5pbro2 = rgmma(bvtr2o5) 
+   g7pbro2 = rgmma(bvtr3o5)
+   pvtr = avtr*g5pbr/24.
+   pvtrn = avtr*g2pbr
+   eacrr = 1.0
+   pacrr = pi*n0r*avtr*g3pbr*.25*eacrr
+   precr1 = 2.*pi*1.56
+   precr2 = 2.*pi*.31*avtr**.5*g7pbro2
+   pidn0r =  pi*denr*n0r
+   pidnr = 4.*pi*denr
+!
+   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
+   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)
+   g5pbgo2 = rgmma(bvtg2)
+   pacrg = pi*n0g*avtg*g3pbg*.25
+   pvtg = avtg*g4pbg/6.
+   precg1 = 2.*pi*n0g*.78
+   precg2 = 2.*pi*n0g*.31*avtg**.5*g5pbgo2
+   pidn0g =  pi*deng*n0g
+!
+   rslopecmax = 1./lamdacmax
+   rslopermax = 1./lamdarmax
+   rslopesmax = 1./lamdasmax
+   rslopegmax = 1./lamdagmax
+   rsloperbmax = rslopermax ** bvtr
+   rslopesbmax = rslopesmax ** bvts
+   rslopegbmax = rslopegmax ** bvtg
+   rslopec2max = rslopecmax * rslopecmax
+   rsloper2max = rslopermax * rslopermax
+   rslopes2max = rslopesmax * rslopesmax
+   rslopeg2max = rslopegmax * rslopegmax
+   rslopec3max = rslopec2max * rslopecmax
+   rsloper3max = rsloper2max * rslopermax
+   rslopes3max = rslopes2max * rslopesmax
+   rslopeg3max = rslopeg2max * rslopegmax
+!
+  END SUBROUTINE wdm6init
+!------------------------------------------------------------------------------
+      subroutine slope_wdm6(qrs,ncr,den,denfac,t,rslope,rslopeb,rslope2,rslope3, &
+                            vt,vtn,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte,3) ::                                     &
+                                                                          qrs, &
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, & 
+                                                                           vt
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          ncr, & 
+                                                                          vtn, & 
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdar, lamdas, lamdag, x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     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,z)= exp(log(((pidnr*z)/(x*y)))*((.33333333)))
+      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
+!
+      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 .or. ncr(i,k).le.nrmin ) 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) = min(1./lamdar(qrs(i,k,1),den(i,k),ncr(i,k)),1.e-3)
+            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
+          vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)
+          vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)
+          vt(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k)
+          vtn(i,k) = pvtrn*rslopeb(i,k,1)*denfac(i,k)
+          if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0 
+          if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0
+          if(qrs(i,k,3).le.0.0) vt(i,k,3) = 0.0
+          if(ncr(i,k).le.0.0) vtn(i,k) = 0.0 
+        enddo
+      enddo
+  END subroutine slope_wdm6
+!-----------------------------------------------------------------------------
+      subroutine slope_rain(qrs,ncr,den,denfac,t,rslope,rslopeb,rslope2,rslope3,   &
+                            vt,vtn,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          qrs, &
+                                                                          ncr, & 
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                           vt, &
+                                                                          vtn, &
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdar, x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     size distributions: (x=mixing ratio, y=air density):
+!     valid for mixing ratio > 1.e-9 kg/kg.
+      lamdar(x,y,z)= exp(log(((pidnr*z)/(x*y)))*((.33333333)))
+!
+      do k = kts, kte
+        do i = its, ite
+          if(qrs(i,k).le.qcrmin .or. ncr(i,k).le.nrmin) then
+            rslope(i,k) = rslopermax
+            rslopeb(i,k) = rsloperbmax
+            rslope2(i,k) = rsloper2max
+            rslope3(i,k) = rsloper3max
+          else
+            rslope(i,k) = min(1./lamdar(qrs(i,k),den(i,k),ncr(i,k)),1.e-3)
+            rslopeb(i,k) = rslope(i,k)**bvtr
+            rslope2(i,k) = rslope(i,k)*rslope(i,k)
+            rslope3(i,k) = rslope2(i,k)*rslope(i,k)
+          endif
+          vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k)
+          vtn(i,k) = pvtrn*rslopeb(i,k)*denfac(i,k)
+          if(qrs(i,k).le.0.0) vt(i,k) = 0.0
+          if(ncr(i,k).le.0.0) vtn(i,k) = 0.0 
+        enddo
+      enddo
+  END subroutine slope_rain
+!------------------------------------------------------------------------------
+      subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,   &
+                            vt,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          qrs, &
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                           vt, &
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdas, x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     size distributions: (x=mixing ratio, y=air density):
+!     valid for mixing ratio > 1.e-9 kg/kg.
+      lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y)))    ! (pidn0s*z/(x*y))**.25
+!
+      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).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
+            rslope2(i,k) = rslope(i,k)*rslope(i,k)
+            rslope3(i,k) = rslope2(i,k)*rslope(i,k)
+          endif
+          vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k)
+          if(qrs(i,k).le.0.0) vt(i,k) = 0.0
+        enddo
+      enddo
+  END subroutine slope_snow
+!----------------------------------------------------------------------------------
+      subroutine slope_graup(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,   &
+                            vt,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          qrs, &
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                           vt, &
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdag, x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     size distributions: (x=mixing ratio, y=air density):
+!     valid for mixing ratio > 1.e-9 kg/kg.
+      lamdag(x,y)=   sqrt(sqrt(pidn0g/(x*y)))      ! (pidn0g/(x*y))**.25
+!
+      do k = kts, kte
+        do i = its, ite
+!---------------------------------------------------------------
+! n0s: Intercept parameter for snow [m-4] [HDC 6]
+!---------------------------------------------------------------
+          if(qrs(i,k).le.qcrmin)then
+            rslope(i,k) = rslopegmax
+            rslopeb(i,k) = rslopegbmax
+            rslope2(i,k) = rslopeg2max
+            rslope3(i,k) = rslopeg3max
+          else
+            rslope(i,k) = 1./lamdag(qrs(i,k),den(i,k))
+            rslopeb(i,k) = rslope(i,k)**bvtg
+            rslope2(i,k) = rslope(i,k)*rslope(i,k)
+            rslope3(i,k) = rslope2(i,k)*rslope(i,k)
+          endif
+          vt(i,k) = pvtg*rslopeb(i,k)*denfac(i,k)
+          if(qrs(i,k).le.0.0) vt(i,k) = 0.0
+        enddo
+      enddo
+  END subroutine slope_graup
+!---------------------------------------------------------------------------------
+!-------------------------------------------------------------------
+      SUBROUTINE nislfv_rain_plmr(im,km,denl,denfacl,tkl,dzl,wwl,rql,rnl,precip,dt,id,iter,rid)
+!-------------------------------------------------------------------
+!
+! for non-iteration semi-Lagrangain forward advection for cloud
+! with mass conservation and positive definite advection
+! 2nd order interpolation with monotonic piecewise linear method
+! this routine is under assumption of decfl < 1 for semi_Lagrangian
+!
+! dzl    depth of model layer in meter
+! wwl    terminal velocity at model layer m/s
+! rql    cloud density*mixing ration
+! precip precipitation
+! dt     time step
+! id     kind of precip: 0 test case; 1 raindrop
+! iter   how many time to guess mean terminal velocity: 0 pure forward.
+!        0 : use departure wind for advection
+!        1 : use mean wind for advection
+!        > 1 : use mean wind after iter-1 iterations
+!        rid : 1 for number 0 for mixing ratio
+!
+! author: hann-ming henry juang <henry.juang@noaa.gov>
+!         implemented by song-you hong
+!
+      implicit none
+      integer  im,km,id
+      real  dt
+      real  dzl(im,km),wwl(im,km),rql(im,km),rnl(im,km),precip(im)
+      real  denl(im,km),denfacl(im,km),tkl(im,km)
+!
+      integer  i,k,n,m,kk,kb,kt,iter,rid
+      real  tl,tl2,qql,dql,qqd
+      real  th,th2,qqh,dqh
+      real  zsum,qsum,dim,dip,c1,con1,fa1,fa2
+      real  allold, allnew, zz, dzamin, cflmax, decfl
+      real  dz(km), ww(km), qq(km), nr(km), wd(km), wa(km), wa2(km), was(km)
+      real  den(km), denfac(km), tk(km)
+      real  wi(km+1), zi(km+1), za(km+1)
+      real  qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km)
+      real  dza(km+1), qa(km+1), qmi(km+1), qpi(km+1)
+!
+      precip(:) = 0.0
+!
+      i_loop : do i=1,im
+! -----------------------------------
+      dz(:) = dzl(i,:)
+      qq(:) = rql(i,:)
+      nr(:) = rnl(i,:)
+      if(rid .eq. 1) nr(:) = rnl(i,:)/denl(i,:)
+      ww(:) = wwl(i,:)
+      den(:) = denl(i,:)
+      denfac(:) = denfacl(i,:)
+      tk(:) = tkl(i,:)
+! skip for no precipitation for all layers
+      allold = 0.0
+      do k=1,km
+        allold = allold + qq(k)
+      enddo
+      if(allold.le.0.0) then
+        cycle i_loop
+      endif
+!
+! compute interface values
+      zi(1)=0.0
+      do k=1,km
+        zi(k+1) = zi(k)+dz(k)
+      enddo
+!
+! save departure wind
+      wd(:) = ww(:)
+      n=1
+ 100  continue
+! plm is 2nd order, we can use 2nd order wi or 3rd order wi
+! 2nd order interpolation to get wi
+      wi(1) = ww(1)
+      wi(km+1) = ww(km)
+      do k=2,km
+        wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k))
+      enddo
+! 3rd order interpolation to get wi
+      fa1 = 9./16.
+      fa2 = 1./16.
+      wi(1) = ww(1)
+      wi(2) = 0.5*(ww(2)+ww(1))
+      do k=3,km-1
+        wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2))
+      enddo
+      wi(km) = 0.5*(ww(km)+ww(km-1))
+      wi(km+1) = ww(km)
+!
+! terminate of top of raingroup
+      do k=2,km
+        if( ww(k).eq.0.0 ) wi(k)=ww(k-1)
+      enddo
+!
+! diffusivity of wi
+      con1 = 0.05
+      do k=km,1,-1
+        decfl = (wi(k+1)-wi(k))*dt/dz(k)
+        if( decfl .gt. con1 ) then
+          wi(k) = wi(k+1) - con1*dz(k)/dt
+        endif
+      enddo
+! compute arrival point
+      do k=1,km+1
+        za(k) = zi(k) - wi(k)*dt
+      enddo
+!
+      do k=1,km
+        dza(k) = za(k+1)-za(k)
+      enddo
+      dza(km+1) = zi(km+1) - za(km+1)
+!     
+! computer deformation at arrival point
+      do k=1,km
+        qa(k) = qq(k)*dz(k)/dza(k)
+        qr(k) = qa(k)/den(k)
+        if(rid .eq. 1) qr(k) = qa(K)
+      enddo
+      qa(km+1) = 0.0
+!     call maxmin(km,1,qa,' arrival points ')
+!     
+! compute arrival terminal velocity, and estimate mean terminal velocity
+! then back to use mean terminal velocity
+      if( n.le.iter ) then
+        if(rid.eq.1) then
+        call slope_rain(nr,qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,wa2,1,1,1,km)
+        else
+        call slope_rain(qr,nr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,wa2,1,1,1,km)
+        endif
+        if(rid.eq.1) wa(:) = wa2(:)
+        if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km))
+        do k=1,km
+!#ifdef DEBUG 
+!        print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k)
+!#endif
+! mean wind is average of departure and new arrival winds
+          ww(k) = 0.5* ( wd(k)+wa(k) )
+        enddo
+        was(:) = wa(:)
+        n=n+1
+        go to 100
+      endif
+!     
+! estimate values at arrival cell interface with monotone
+      do k=2,km
+        dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k))
+        dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k))
+        if( dip*dim.le.0.0 ) then
+          qmi(k)=qa(k)
+          qpi(k)=qa(k)
+        else
+          qpi(k)=qa(k)+0.5*(dip+dim)*dza(k)
+          qmi(k)=2.0*qa(k)-qpi(k)
+          if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then
+            qpi(k) = qa(k)
+            qmi(k) = qa(k)
+          endif
+        endif
+      enddo
+      qpi(1)=qa(1)
+      qmi(1)=qa(1)
+      qmi(km+1)=qa(km+1)
+      qpi(km+1)=qa(km+1)
+!
+! interpolation to regular point
+      qn = 0.0
+      kb=1
+      kt=1
+      intp : do k=1,km
+             kb=max(kb-1,1)
+             kt=max(kt-1,1)
+! find kb and kt
+             if( zi(k).ge.za(km+1) ) then
+               exit intp
+             else
+               find_kb : do kk=kb,km
+                         if( zi(k).le.za(kk+1) ) then
+                           kb = kk
+                           exit find_kb
+                         else
+                           cycle find_kb
+                         endif
+               enddo find_kb
+               find_kt : do kk=kt,km
+                         if( zi(k+1).le.za(kk) ) then
+                           kt = kk
+                           exit find_kt
+                         else
+                           cycle find_kt
+                         endif
+               enddo find_kt
+               kt = kt - 1
+! compute q with piecewise constant method
+               if( kt.eq.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 th=(zi(k+1)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 th2=th*th
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qqh=qqd*th2+qmi(kb)*th
+                 qql=qqd*tl2+qmi(kb)*tl
+                 qn(k) = (qqh-qql)/(th-tl)
+               else if( kt.gt.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qql=qqd*tl2+qmi(kb)*tl
+                 dql = qa(kb)-qql
+                 zsum  = (1.-tl)*dza(kb)
+                 qsum  = dql*dza(kb)
+                 if( kt-kb.gt.1 ) then
+                 do m=kb+1,kt-1
+                   zsum = zsum + dza(m)
+                   qsum = qsum + qa(m) * dza(m)
+                 enddo
+                 endif
+                 th=(zi(k+1)-za(kt))/dza(kt)
+                 th2=th*th
+                 qqd=0.5*(qpi(kt)-qmi(kt))
+                 dqh=qqd*th2+qmi(kt)*th
+                 zsum  = zsum + th*dza(kt)
+                 qsum  = qsum + dqh*dza(kt)
+                 qn(k) = qsum/zsum
+               endif
+               cycle intp
+             endif
+!     
+       enddo intp
+!            
+! rain out
+      sum_precip: do k=1,km
+                    if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*dza(k)
+                      cycle sum_precip
+                    else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*(0.0-za(k))
+                      exit sum_precip
+                    endif
+                    exit sum_precip
+      enddo sum_precip
+!              
+! replace the new values 
+      rql(i,:) = qn(:)     
+!                          
+! ----------------------------------
+      enddo i_loop         
+!                        
+  END SUBROUTINE nislfv_rain_plmr
+!-------------------------------------------------------------------
+      SUBROUTINE nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2, precip1, precip2,dt,id,iter)
+!-------------------------------------------------------------------
+!
+! for non-iteration semi-Lagrangain forward advection for cloud
+! with mass conservation and positive definite advection
+! 2nd order interpolation with monotonic piecewise linear method
+! this routine is under assumption of decfl < 1 for semi_Lagrangian
+!
+! dzl    depth of model layer in meter
+! wwl    terminal velocity at model layer m/s
+! rql    cloud density*mixing ration
+! precip precipitation
+! dt     time step
+! id     kind of precip: 0 test case; 1 raindrop
+! iter   how many time to guess mean terminal velocity: 0 pure forward.
+!        0 : use departure wind for advection
+!        1 : use mean wind for advection
+!        > 1 : use mean wind after iter-1 iterations
+!
+! author: hann-ming henry juang <henry.juang@noaa.gov>
+!         implemented by song-you hong
+!
+      implicit none
+      integer  im,km,id
+      real  dt
+      real  dzl(im,km),wwl(im,km),rql(im,km),rql2(im,km),precip(im),precip1(im),precip2(im)
+      real  denl(im,km),denfacl(im,km),tkl(im,km)
+!
+      integer  i,k,n,m,kk,kb,kt,iter,ist
+      real  tl,tl2,qql,dql,qqd
+      real  th,th2,qqh,dqh
+      real  zsum,qsum,dim,dip,c1,con1,fa1,fa2
+      real  allold, allnew, zz, dzamin, cflmax, decfl
+      real  dz(km), ww(km), qq(km), qq2(km), wd(km), wa(km), wa2(km), was(km)
+      real  den(km), denfac(km), tk(km)
+      real  wi(km+1), zi(km+1), za(km+1)
+      real  qn(km), qr(km),qr2(km),tmp(km),tmp1(km),tmp2(km),tmp3(km)
+      real  dza(km+1), qa(km+1), qa2(km+1),qmi(km+1), qpi(km+1)
+!
+      precip(:) = 0.0
+      precip1(:) = 0.0
+      precip2(:) = 0.0
+!
+      i_loop : do i=1,im
+! -----------------------------------
+      dz(:) = dzl(i,:)
+      qq(:) = rql(i,:)
+      qq2(:) = rql2(i,:)
+      ww(:) = wwl(i,:)
+      den(:) = denl(i,:)
+      denfac(:) = denfacl(i,:)
+      tk(:) = tkl(i,:)
+! skip for no precipitation for all layers
+      allold = 0.0
+      do k=1,km
+        allold = allold + qq(k)
+      enddo
+      if(allold.le.0.0) then
+        cycle i_loop
+      endif
+!
+! compute interface values
+      zi(1)=0.0
+      do k=1,km
+        zi(k+1) = zi(k)+dz(k)
+      enddo
+!
+! save departure wind
+      wd(:) = ww(:)
+      n=1
+ 100  continue
+! plm is 2nd order, we can use 2nd order wi or 3rd order wi
+! 2nd order interpolation to get wi
+      wi(1) = ww(1)
+      wi(km+1) = ww(km)
+      do k=2,km
+        wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k))
+      enddo
+! 3rd order interpolation to get wi
+      fa1 = 9./16.
+      fa2 = 1./16.
+      wi(1) = ww(1)
+      wi(2) = 0.5*(ww(2)+ww(1))
+      do k=3,km-1
+        wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2))
+      enddo
+      wi(km) = 0.5*(ww(km)+ww(km-1))
+      wi(km+1) = ww(km)
+!
+! terminate of top of raingroup
+      do k=2,km
+        if( ww(k).eq.0.0 ) wi(k)=ww(k-1)
+      enddo
+!
+! diffusivity of wi
+      con1 = 0.05
+      do k=km,1,-1
+        decfl = (wi(k+1)-wi(k))*dt/dz(k)
+        if( decfl .gt. con1 ) then
+          wi(k) = wi(k+1) - con1*dz(k)/dt
+        endif
+      enddo
+! compute arrival point
+      do k=1,km+1
+        za(k) = zi(k) - wi(k)*dt
+      enddo
+!
+      do k=1,km
+        dza(k) = za(k+1)-za(k)
+      enddo
+      dza(km+1) = zi(km+1) - za(km+1)
+!
+! computer deformation at arrival point
+      do k=1,km
+        qa(k) = qq(k)*dz(k)/dza(k)
+        qa2(k) = qq2(k)*dz(k)/dza(k)
+        qr(k) = qa(k)/den(k)
+        qr2(k) = qa2(k)/den(k)
+      enddo
+      qa(km+1) = 0.0
+      qa2(km+1) = 0.0
+!     call maxmin(km,1,qa,' arrival points ')
+!
+! compute arrival terminal velocity, and estimate mean terminal velocity
+! then back to use mean terminal velocity
+      if( n.le.iter ) then
+        call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km)
+        call slope_graup(qr2,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa2,1,1,1,km)
+        do k = 1, km
+          tmp(k) = max((qr(k)+qr2(k)), 1.E-15)
+          IF ( tmp(k) .gt. 1.e-15 ) THEN
+            wa(k) = (wa(k)*qr(k) + wa2(k)*qr2(k))/tmp(k)
+          ELSE
+            wa(k) = 0.
+          ENDIF
+        enddo
+        if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km))
+        do k=1,km
+!#ifdef DEBUG
+!        print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k), &
+!           ww(k),wa(k)
+!#endif
+! mean wind is average of departure and new arrival winds
+          ww(k) = 0.5* ( wd(k)+wa(k) )
+        enddo
+        was(:) = wa(:)
+        n=n+1
+        go to 100
+      endif
+      ist_loop : do ist = 1, 2
+      if (ist.eq.2) then
+       qa(:) = qa2(:)
+      endif
+!
+      precip(i) = 0.
+!
+! estimate values at arrival cell interface with monotone
+      do k=2,km
+        dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k))
+        dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k))
+        if( dip*dim.le.0.0 ) then
+          qmi(k)=qa(k)
+          qpi(k)=qa(k)
+        else
+          qpi(k)=qa(k)+0.5*(dip+dim)*dza(k)
+          qmi(k)=2.0*qa(k)-qpi(k)
+          if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then
+            qpi(k) = qa(k)
+            qmi(k) = qa(k)
+          endif
+        endif
+      enddo
+      qpi(1)=qa(1)
+      qmi(1)=qa(1)
+      qmi(km+1)=qa(km+1)
+      qpi(km+1)=qa(km+1)
+!
+! interpolation to regular point
+      qn = 0.0
+      kb=1
+      kt=1
+      intp : do k=1,km
+             kb=max(kb-1,1)
+             kt=max(kt-1,1)
+! find kb and kt
+             if( zi(k).ge.za(km+1) ) then
+               exit intp
+             else
+               find_kb : do kk=kb,km
+                         if( zi(k).le.za(kk+1) ) then
+                           kb = kk
+                           exit find_kb
+                         else
+                           cycle find_kb
+                         endif
+               enddo find_kb
+               find_kt : do kk=kt,km
+                         if( zi(k+1).le.za(kk) ) then
+                           kt = kk
+                           exit find_kt
+                         else
+                           cycle find_kt
+                         endif
+               enddo find_kt
+               kt = kt - 1
+! compute q with piecewise constant method
+               if( kt.eq.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 th=(zi(k+1)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 th2=th*th
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qqh=qqd*th2+qmi(kb)*th
+                 qql=qqd*tl2+qmi(kb)*tl
+                 qn(k) = (qqh-qql)/(th-tl)
+               else if( kt.gt.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qql=qqd*tl2+qmi(kb)*tl
+                 dql = qa(kb)-qql
+                 zsum  = (1.-tl)*dza(kb)
+                 qsum  = dql*dza(kb)
+                 if( kt-kb.gt.1 ) then
+                 do m=kb+1,kt-1
+                   zsum = zsum + dza(m)
+                   qsum = qsum + qa(m) * dza(m)
+                 enddo
+                 endif
+                 th=(zi(k+1)-za(kt))/dza(kt)
+                 th2=th*th
+                 qqd=0.5*(qpi(kt)-qmi(kt))
+                 dqh=qqd*th2+qmi(kt)*th
+                 zsum  = zsum + th*dza(kt)
+                 qsum  = qsum + dqh*dza(kt)
+                 qn(k) = qsum/zsum
+               endif
+               cycle intp
+             endif
+!
+       enddo intp
+!
+! rain out
+      sum_precip: do k=1,km
+                    if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*dza(k)
+                      cycle sum_precip
+                    else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*(0.0-za(k))
+                      exit sum_precip
+                    endif
+                    exit sum_precip
+      enddo sum_precip
+!
+! replace the new values
+      if(ist.eq.1) then
+        rql(i,:) = qn(:)
+        precip1(i) = precip(i)
+      else
+        rql2(i,:) = qn(:)
+        precip2(i) = precip(i)
+      endif
+      enddo ist_loop
+!
+! ----------------------------------
+      enddo i_loop
+!
+  END SUBROUTINE nislfv_rain_plm6
+END MODULE module_mp_wdm6
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm3.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm3.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm3.F	(revision 17)
@@ -0,0 +1,1420 @@
+#ifdef _ACCEL
+#  include "module_mp_wsm3_accel.F"
+#else
+#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. ! maximum time step for minor loops
+   REAL, PARAMETER, PRIVATE :: n0r = 8.e6         ! intercept parameter rain
+   REAL, PARAMETER, PRIVATE :: avtr = 841.9       ! a constant for terminal velocity of rain
+   REAL, PARAMETER, PRIVATE :: bvtr = 0.8         ! a constant for terminal velocity of rain
+   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       ! a constant for terminal velocity of snow
+   REAL, PARAMETER, PRIVATE :: bvts = .41         ! a constant for terminal velocity of snow
+   REAL, PARAMETER, PRIVATE :: n0smax =  1.e11    ! maximum n0s (t=-90C unlimited)
+   REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4   ! limited maximum value for slope parameter of rain
+   REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5   ! limited maximum value for slope parameter of snow
+   REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4   ! limited maximum value for slope parameter of graupel
+   REAL, PARAMETER, PRIVATE :: dicon = 11.9       ! constant for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: dimax = 500.e-6    ! limited maximum value for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: n0s = 2.e6         ! temperature dependent intercept parameter snow 
+   REAL, PARAMETER, PRIVATE :: alpha = .12        ! .122 exponen factor for n0s
+   REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9     ! minimun values for qr, qs, and qg
+   REAL, SAVE ::                                      &
+             qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, &
+             g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr,    &
+             precr1,precr2,xmmax,roqimax,bvts1,       &
+             bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs,     &
+             g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, &
+             pidn0s,xlv1,pi,                          &
+             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
+!-------------------------------------------------------------------
+!
+  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
+  REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL,                              &
+        INTENT(INOUT) ::                                                 snow, &
+                                                                      snowncv, &
+                                                                           sr
+! 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)                               &
+                    ,snow(ims,j),snowncv(ims,j)                                &
+                    ,sr(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 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                                              &
+                   ,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 
+!  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
+!
+!  Developed 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
+!
+!  History :  semi-lagrangian scheme sedimentation(JH), and clean up
+!             Hong, August 2009
+!
+!  Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev.
+!             Dudhia (D89, 1989) J. Atmos. Sci.
+!             Hong and Lim (HL, 2006) J. Korean Meteor. Soc.
+!             Juang and Hong (JH, 2010) Mon. Wea. Rev.
+!
+  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
+  REAL, DIMENSION( ims:ime ),     OPTIONAL,                                    &
+        INTENT(INOUT) ::                                                 snow, &
+                                                                      snowncv, &
+                                                                           sr
+! LOCAL VAR
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                           rh, &
+                                                                           qs, &
+                                                                       denfac, &
+                                                                       rslope, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                      qrs_tmp, &
+                                                                      den_tmp, &
+                                                                     delz_tmp, &
+                                                                      rslopeb
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                         pgen, &
+                                                                         pisd, &
+                                                                         paut, &
+                                                                         pacr, &
+                                                                         pres, &
+                                                                         pcon
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                         fall, &
+                                                                         falk, &
+                                                                           xl, &
+                                                                          cpm, &
+                                                                        work1, &
+                                                                        work2, &
+                                                                          xni, &
+                                                                          qs0, &
+                                                                       denqci, &
+                                                                       denqrs, &
+                                                                       n0sfac, &
+                                                                        falkc, &
+                                                                       work1c, &
+                                                                       work2c, &
+                                                                        fallc
+  REAL, DIMENSION( its:ite ) ::                                         delqrs,&
+                                                                         delqi
+  REAL, DIMENSION(its:ite) ::                                        tstepsnow
+  INTEGER, DIMENSION( its:ite ) ::                                      kwork1,&
+                                                                        kwork2
+  INTEGER, DIMENSION( its:ite ) ::                                      mstep, &
+                                                                        numdt
+  LOGICAL, DIMENSION( its:ite ) :: flgcld
+  REAL  ::                                                                     &
+            cpmcal, xlcal, 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,holdc, holdci
+  INTEGER :: i, j, k, mstepmax,                                                &
+            iprt, latd, lond, loop, loops, ifsat, kk, n, idim, kdim
+! Temporaries used for inlining fpvs function
+  REAL  :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp
+! variables for optimization
+  REAL, DIMENSION( its:ite )    :: tvec1
+!
+!=================================================================
+!   compute internal functions
+!
+      cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv
+      xlcal(x) = xlv0-xlv1*(x-t0c)
+!----------------------------------------------------------------
+!     diffus: diffusion coefficient of the water vapor
+!     viscos: kinematic viscosity(m2s-1)
+!     Optimizatin : A**B => exp(log(A)*(B))
+!
+      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))
+!
+      idim = ite-its+1
+      kdim = kte-kts+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
+      do k = kts, kte
+        do i = its, ite
+          delz_tmp(i,k) = delz(i,k)
+          den_tmp(i,k) = den(i,k)
+        enddo
+      enddo
+!
+!----------------------------------------------------------------
+!    initialize the surface rain, snow
+!
+      do i = its, ite
+        rainncv(i) = 0.
+        if(PRESENT (snowncv) .AND. PRESENT (snow)) snowncv(i) = 0.
+        sr(i) = 0.
+! new local array to catch step snow
+        tstepsnow(i) = 0.
+      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
+        flgcld(i) = .true.
+      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*(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) = min(qs(i,k),0.99*p(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
+!-------------------------------------------------------------
+! Ni: ice crystal number concentraiton   [HDC 5c]
+!-------------------------------------------------------------
+      do k = kts, kte
+        do i = its, ite
+          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
+!
+!----------------------------------------------------------------
+!     compute the fallout term:
+!     first, vertical terminal velosity for minor loops
+!---------------------------------------------------------------
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k) = qrs(i,k)
+        enddo
+      enddo
+      call slope_wsm3(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, &
+                      work1,its,ite,kts,kte)
+!
+!
+!  forward semi-laglangian scheme (JH), PCM (piecewise constant),  (linear)
+!
+      do k = kte, kts, -1
+        do i = its, ite
+          denqrs(i,k) = den(i,k)*qrs(i,k)
+        enddo
+      enddo
+      call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1,denqrs,   &
+                           delqrs,dtcld,1,1)
+      do k = kts, kte
+        do i = its, ite
+          qrs(i,k) = max(denqrs(i,k)/den(i,k),0.)
+          fall(i,k) = denqrs(i,k)*work1(i,k)/delz(i,k)
+        enddo
+      enddo
+      do i = its, ite
+        fall(i,1) = delqrs(i)/delz(i,1)/dtcld
+      enddo
+!---------------------------------------------------------------
+! Vice [ms-1] : fallout of ice crystal [HDC 5a]
+!---------------------------------------------------------------
+      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  = max(dicon * sqrt(xmi), 1.e-25)
+            work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31))
+          else
+            work1c(i,k) = 0.
+          endif
+        enddo
+      enddo
+!
+!  forward semi-laglangian scheme (JH), PCM (piecewise constant),  (linear)
+!
+      do k = kte, kts, -1
+        do i = its, ite
+          denqci(i,k) = den(i,k)*qci(i,k)
+        enddo
+      enddo
+      call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci,  &
+                           delqi,dtcld,1,0)
+      do k = kts, kte
+        do i = its, ite
+          qci(i,k) = max(denqci(i,k)/den(i,k),0.)
+        enddo
+      enddo
+      do i = its, ite
+        fallc(i,1) = delqi(i)/delz(i,1)/dtcld
+      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
+        kwork2(i) = mstep(i)
+        kwork1(i) = mstep(i)
+        if(mstep(i).ne.0) then
+          if (w(i,mstep(i)).gt.0.) then
+            kwork1(i) = mstep(i) + 1
+          endif
+        endif
+      enddo
+!
+      do i = its, ite
+        k  = kwork1(i)
+        kk = kwork2(i)
+        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
+        if(fallsum.gt.0.) then
+          rainncv(i) = fallsum*delz(i,1)/denr*dtcld*1000. + rainncv(i)
+          rain(i) = fallsum*delz(i,1)/denr*dtcld*1000. + rain(i)
+        endif
+        if(fallsum_qsi.gt.0.) then
+          tstepsnow(i)   = fallsum_qsi*delz(i,kts)/denr*dtcld*1000.            &
+                           +tstepsnow(i)
+        IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN
+          snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snowncv(i)
+          snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i)
+        ENDIF
+        endif
+!       if(fallsum.gt.0.) sr(i) = snowncv(i)/(rainncv(i)+1.e-12)
+        if(fallsum.gt.0.) sr(i) = tstepsnow(i)/(rainncv(i)+1.e-12)
+      enddo
+!
+!----------------------------------------------------------------
+!     update the slope parameters for microphysics computation 
+!
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k) = qrs(i,k)
+        enddo
+      enddo
+      call slope_wsm3(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, &
+                      work1,its,ite,kts,kte)
+!
+!     work1: the thermodynamic term in the denominator associated with
+!             heat conduction and vapor diffusion
+!     work2: parameter associated with the ventilation effects(y93)
+!
+      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)
+            n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.)
+            ifsat = 0
+!-------------------------------------------------------------
+! Ni: ice crystal number concentraiton   [HDC 5c]
+!-------------------------------------------------------------
+            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]
+!        (T<T0: I->R)
+!-------------------------------------------------------------
+              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]
+!       (T<T0: V->I 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]
+!       (T<T0: V->I)
+!-------------------------------------------------------------
+            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*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]
+!       (T<T0: I->S)
+!-------------------------------------------------------------
+            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*(exp(log(tr)*(xa)))*exp(xb*(1.-tr))
+          qs(i,k) = min(qs(i,k),0.99*p(i,k))
+          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
+          if(qrs(i,k).le.qcrmin) qrs(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
+!  
+   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
+   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
+!
+      subroutine slope_wsm3(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                          qrs, &
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t, &
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                           vt
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdar,lamdas,x, y, z, supcol, pvt
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     size distributions: (x=mixing ratio, y=air density):
+!     valid for mixing ratio > 1.e-9 kg/kg.
+!
+      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
+!
+      do k = kts, kte
+        do i = its, ite
+          if(t(i,k).ge.t0c) then
+            pvt = pvtr
+            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
+            supcol = t0c-t(i,k)
+            n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.)
+            pvt = pvts
+            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
+          vt(i,k) = pvt*rslopeb(i,k)*denfac(i,k)
+          if(qrs(i,k).le.0.0) vt(i,k) = 0.0
+        enddo
+      enddo
+  END subroutine slope_wsm3
+!-------------------------------------------------------------------
+      SUBROUTINE nislfv_rain_pcm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter)
+!-------------------------------------------------------------------
+!
+! for non-iteration semi-Lagrangain forward advection for cloud
+! with mass conservation and positive definite advection
+! 2nd order interpolation with monotonic piecewise linear method
+! this routine is under assumption of decfl < 1 for semi_Lagrangian
+!
+! dzl    depth of model layer in meter
+! wwl    terminal velocity at model layer m/s
+! rql    cloud density*mixing ration
+! precip precipitation
+! dt     time step
+! id     kind of precip: 0 test case; 1 raindrop
+! iter   how many time to guess mean terminal velocity: 0 pure forward.
+!        0 : use departure wind for advection 
+!        1 : use mean wind for advection 
+!        > 1 : use mean wind after iter-1 iterations
+!
+! author: hann-ming henry juang <henry.juang@noaa.gov>
+!         implemented by song-you hong
+!
+      implicit none
+      integer  im,km,id
+      real  dt
+      real  dzl(im,km),wwl(im,km),rql(im,km),precip(im)
+      real  denl(im,km),denfacl(im,km),tkl(im,km)
+!
+      integer  i,k,n,m,kk,kb,kt,iter
+      real  tl,tl2,qql,dql,qqd
+      real  th,th2,qqh,dqh
+      real  zsum,qsum,dim,dip,c1,con1,fa1,fa2
+      real  zsumt,qsumt,zsumb,qsumb
+      real  allold, allnew, zz, dzamin, cflmax, decfl
+      real  dz(km), ww(km), qq(km), wd(km), wa(km), was(km)
+      real  den(km), denfac(km), tk(km)
+      real  wi(km+1), zi(km+1), za(km+1)
+      real  qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km)
+      real  dza(km+1), qa(km+1), qmi(km+1), qpi(km+1)
+!
+      precip(:) = 0.0
+!
+      i_loop : do i=1,im
+! -----------------------------------
+      dz(:) = dzl(i,:)
+      qq(:) = rql(i,:)
+      ww(:) = wwl(i,:)
+      den(:) = denl(i,:)
+      denfac(:) = denfacl(i,:)
+      tk(:) = tkl(i,:)
+! skip for no precipitation for all layers
+      allold = 0.0
+      do k=1,km
+        allold = allold + qq(k)
+      enddo
+      if(allold.le.0.0) then
+        cycle i_loop
+      endif
+!
+! compute interface values
+      zi(1)=0.0
+      do k=1,km
+        zi(k+1) = zi(k)+dz(k)
+      enddo
+!
+! save departure wind
+      wd(:) = ww(:)
+      n=1
+ 100  continue
+! pcm is 1st order, we should use 2nd order wi
+! 2nd order interpolation to get wi
+      wi(1) = ww(1)
+      do k=2,km
+        wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k))
+      enddo
+      wi(km+1) = ww(km)
+!
+! terminate of top of raingroup
+      do k=2,km
+        if( ww(k).eq.0.0 ) wi(k)=ww(k-1)
+      enddo
+!
+! diffusivity of wi
+      con1 = 0.05
+      do k=km,1,-1
+        decfl = (wi(k+1)-wi(k))*dt/dz(k)
+        if( decfl .gt. con1 ) then
+          wi(k) = wi(k+1) - con1*dz(k)/dt
+        endif
+      enddo
+! compute arrival point
+      do k=1,km+1
+        za(k) = zi(k) - wi(k)*dt
+      enddo
+!
+      do k=1,km
+        dza(k) = za(k+1)-za(k)
+      enddo
+      dza(km+1) = zi(km+1) - za(km+1)
+!
+! computer deformation at arrival point
+      do k=1,km
+        qa(k) = qq(k)*dz(k)/dza(k)
+        qr(k) = qa(k)/den(k)
+      enddo
+      qa(km+1) = 0.0
+!     call maxmin(km,1,qa,' arrival points ')
+!
+! compute arrival terminal velocity, and estimate mean terminal velocity
+! then back to use mean terminal velocity
+      if( n.le.iter ) then
+        call slope_wsm3(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km)
+        if( n.eq.2 ) wa(1:km) = 0.5*(wa(1:km)+was(1:km))
+        do k=1,km
+!#ifdef DEBUG
+!      print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k)
+!#endif
+! mean wind is average of departure and new arrival winds
+          ww(k) = 0.5* ( wd(k)+wa(k) )
+        enddo
+        was(:) = wa(:)
+        n=n+1
+        go to 100
+      endif
+!
+!
+! interpolation to regular point
+      qn = 0.0
+      kb=1
+      kt=1
+      intp : do k=1,km
+             kb=max(kb-1,1)
+             kt=max(kt-1,1)
+! find kb and kt
+             if( zi(k).ge.za(km+1) ) then
+               exit intp
+             else
+               find_kb : do kk=kb,km
+                         if( zi(k).le.za(kk+1) ) then
+                           kb = kk
+                           exit find_kb
+                         else
+                           cycle find_kb
+                         endif
+               enddo find_kb
+               find_kt : do kk=kt,km
+                         if( zi(k+1).le.za(kk) ) then
+                           kt = kk
+                           exit find_kt
+                         else
+                           cycle find_kt
+                         endif
+               enddo find_kt
+! compute q with piecewise constant method
+               if( kt-kb.eq.1 ) then
+                 qn(k) = qa(kb)
+               else if( kt-kb.ge.2 ) then
+                 zsumb = za(kb+1)-zi(k)
+                 qsumb = qa(kb) * zsumb
+                 zsumt = zi(k+1)-za(kt-1)
+                 qsumt = qa(kt-1) * zsumt
+                 qsum = 0.0
+                 zsum = 0.0
+                 if( kt-kb.ge.3 ) then
+                 do m=kb+1,kt-2
+                   qsum = qsum + qa(m) * dza(m)
+                   zsum = zsum + dza(m)
+                 enddo
+                 endif
+                 qn(k) = (qsumb+qsum+qsumt)/(zsumb+zsum+zsumt)
+               endif
+               cycle intp
+             endif
+!
+       enddo intp
+!
+! rain out
+      sum_precip: do k=1,km
+                    if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*dza(k)
+                      cycle sum_precip
+                    else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*(0.0-za(k))
+                      exit sum_precip
+                    endif
+                    exit sum_precip
+      enddo sum_precip
+!
+! replace the new values
+      rql(i,:) = qn(:)
+!
+! ----------------------------------
+      enddo i_loop
+!
+  END SUBROUTINE nislfv_rain_pcm
+!-------------------------------------------------------------------
+      SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter)
+!-------------------------------------------------------------------
+!
+! for non-iteration semi-Lagrangain forward advection for cloud
+! with mass conservation and positive definite advection
+! 2nd order interpolation with monotonic piecewise linear method
+! this routine is under assumption of decfl < 1 for semi_Lagrangian
+!
+! dzl    depth of model layer in meter
+! wwl    terminal velocity at model layer m/s
+! rql    cloud density*mixing ration
+! precip precipitation
+! dt     time step
+! id     kind of precip: 0 test case; 1 raindrop
+! iter   how many time to guess mean terminal velocity: 0 pure forward.
+!        0 : use departure wind for advection 
+!        1 : use mean wind for advection 
+!        > 1 : use mean wind after iter-1 iterations
+!
+! author: hann-ming henry juang <henry.juang@noaa.gov>
+!         implemented by song-you hong
+!
+      implicit none
+      integer  im,km,id
+      real  dt
+      real  dzl(im,km),wwl(im,km),rql(im,km),precip(im)
+      real  denl(im,km),denfacl(im,km),tkl(im,km)
+!
+      integer  i,k,n,m,kk,kb,kt,iter
+      real  tl,tl2,qql,dql,qqd
+      real  th,th2,qqh,dqh
+      real  zsum,qsum,dim,dip,c1,con1,fa1,fa2
+      real  allold, allnew, zz, dzamin, cflmax, decfl
+      real  dz(km), ww(km), qq(km), wd(km), wa(km), was(km)
+      real  den(km), denfac(km), tk(km)
+      real  wi(km+1), zi(km+1), za(km+1)
+      real  qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km)
+      real  dza(km+1), qa(km+1), qmi(km+1), qpi(km+1)
+!
+      precip(:) = 0.0
+!
+      i_loop : do i=1,im
+! -----------------------------------
+      dz(:) = dzl(i,:)
+      qq(:) = rql(i,:)
+      ww(:) = wwl(i,:)
+      den(:) = denl(i,:)
+      denfac(:) = denfacl(i,:)
+      tk(:) = tkl(i,:)
+! skip for no precipitation for all layers
+      allold = 0.0
+      do k=1,km
+        allold = allold + qq(k)
+      enddo
+      if(allold.le.0.0) then
+        cycle i_loop
+      endif
+!
+! compute interface values
+      zi(1)=0.0
+      do k=1,km
+        zi(k+1) = zi(k)+dz(k)
+      enddo
+!
+! save departure wind
+      wd(:) = ww(:)
+      n=1
+ 100  continue
+! plm is 2nd order, we can use 2nd order wi or 3rd order wi
+! 2nd order interpolation to get wi
+      wi(1) = ww(1)
+      wi(km+1) = ww(km)
+      do k=2,km
+        wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k))
+      enddo
+! 3rd order interpolation to get wi
+      fa1 = 9./16.
+      fa2 = 1./16.
+      wi(1) = ww(1)
+      wi(2) = 0.5*(ww(2)+ww(1))
+      do k=3,km-1
+        wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2))
+      enddo
+      wi(km) = 0.5*(ww(km)+ww(km-1))
+      wi(km+1) = ww(km)
+!
+! terminate of top of raingroup
+      do k=2,km
+        if( ww(k).eq.0.0 ) wi(k)=ww(k-1)
+      enddo
+!
+! diffusivity of wi
+      con1 = 0.05
+      do k=km,1,-1
+        decfl = (wi(k+1)-wi(k))*dt/dz(k)
+        if( decfl .gt. con1 ) then
+          wi(k) = wi(k+1) - con1*dz(k)/dt
+        endif
+      enddo
+! compute arrival point
+      do k=1,km+1
+        za(k) = zi(k) - wi(k)*dt
+      enddo
+!
+      do k=1,km
+        dza(k) = za(k+1)-za(k)
+      enddo
+      dza(km+1) = zi(km+1) - za(km+1)
+!
+! computer deformation at arrival point
+      do k=1,km
+        qa(k) = qq(k)*dz(k)/dza(k)
+        qr(k) = qa(k)/den(k)
+      enddo
+      qa(km+1) = 0.0
+!     call maxmin(km,1,qa,' arrival points ')
+!
+! compute arrival terminal velocity, and estimate mean terminal velocity
+! then back to use mean terminal velocity
+      if( n.le.iter ) then
+        call slope_wsm3(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km)
+        if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km))
+        do k=1,km
+!#ifdef DEBUG
+!        print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k)
+!#endif
+! mean wind is average of departure and new arrival winds
+          ww(k) = 0.5* ( wd(k)+wa(k) )
+        enddo
+        was(:) = wa(:)
+        n=n+1
+        go to 100
+      endif
+!
+! estimate values at arrival cell interface with monotone
+      do k=2,km
+        dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k))
+        dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k))
+        if( dip*dim.le.0.0 ) then
+          qmi(k)=qa(k)
+          qpi(k)=qa(k)
+        else
+          qpi(k)=qa(k)+0.5*(dip+dim)*dza(k)
+          qmi(k)=2.0*qa(k)-qpi(k)
+          if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then
+            qpi(k) = qa(k)
+            qmi(k) = qa(k)
+          endif
+        endif
+      enddo
+      qpi(1)=qa(1)
+      qmi(1)=qa(1)
+      qmi(km+1)=qa(km+1)
+      qpi(km+1)=qa(km+1)
+!
+! interpolation to regular point
+      qn = 0.0
+      kb=1
+      kt=1
+      intp : do k=1,km
+             kb=max(kb-1,1)
+             kt=max(kt-1,1)
+! find kb and kt
+             if( zi(k).ge.za(km+1) ) then
+               exit intp
+             else
+               find_kb : do kk=kb,km
+                         if( zi(k).le.za(kk+1) ) then
+                           kb = kk
+                           exit find_kb
+                         else
+                           cycle find_kb
+                         endif
+               enddo find_kb
+               find_kt : do kk=kt,km
+                         if( zi(k+1).le.za(kk) ) then
+                           kt = kk
+                           exit find_kt
+                         else
+                           cycle find_kt
+                         endif
+               enddo find_kt
+               kt = kt - 1
+! compute q with piecewise constant method
+               if( kt.eq.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 th=(zi(k+1)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 th2=th*th
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qqh=qqd*th2+qmi(kb)*th
+                 qql=qqd*tl2+qmi(kb)*tl
+                 qn(k) = (qqh-qql)/(th-tl)
+               else if( kt.gt.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qql=qqd*tl2+qmi(kb)*tl
+                 dql = qa(kb)-qql
+                 zsum  = (1.-tl)*dza(kb)
+                 qsum  = dql*dza(kb)
+                 if( kt-kb.gt.1 ) then
+                 do m=kb+1,kt-1
+                   zsum = zsum + dza(m)
+                   qsum = qsum + qa(m) * dza(m)
+                 enddo
+                 endif
+                 th=(zi(k+1)-za(kt))/dza(kt)
+                 th2=th*th
+                 qqd=0.5*(qpi(kt)-qmi(kt))
+                 dqh=qqd*th2+qmi(kt)*th
+                 zsum  = zsum + th*dza(kt)
+                 qsum  = qsum + dqh*dza(kt)
+                 qn(k) = qsum/zsum
+               endif
+               cycle intp
+             endif
+!
+       enddo intp
+!
+! rain out
+      sum_precip: do k=1,km
+                    if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*dza(k)
+                      cycle sum_precip
+                    else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*(0.0-za(k))
+                      exit sum_precip
+                    endif
+                    exit sum_precip
+      enddo sum_precip
+!
+! replace the new values
+      rql(i,:) = qn(:)
+!
+! ----------------------------------
+      enddo i_loop
+!
+  END SUBROUTINE nislfv_rain_plm
+!
+END MODULE module_mp_wsm3
+#endif
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm3_accel.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm3_accel.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm3_accel.F	(revision 17)
@@ -0,0 +1,1683 @@
+#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. ! maximum time step for minor loops
+   REAL, PARAMETER, PRIVATE :: n0r = 8.e6         ! intercept parameter rain
+   REAL, PARAMETER, PRIVATE :: avtr = 841.9       ! a constant for terminal velocity of rain
+   REAL, PARAMETER, PRIVATE :: bvtr = 0.8         ! a constant for terminal velocity of rain
+   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       ! a constant for terminal velocity of snow
+   REAL, PARAMETER, PRIVATE :: bvts = .41         ! a constant for terminal velocity of snow
+   REAL, PARAMETER, PRIVATE :: n0smax =  1.e11    ! maximum n0s (t=-90C unlimited)
+   REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4   ! limited maximum value for slope parameter of rain
+   REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5   ! limited maximum value for slope parameter of snow
+   REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4   ! limited maximum value for slope parameter of graupel
+   REAL, PARAMETER, PRIVATE :: dicon = 11.9       ! constant for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: dimax = 500.e-6    ! limited maximum value for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: n0s = 2.e6         ! temperature dependent intercept parameter snow 
+   REAL, PARAMETER, PRIVATE :: alpha = .12        ! .122 exponen factor for n0s
+   REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9     ! minimun values for qr, qs, and qg
+   REAL, SAVE ::                                      &
+             qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, &
+             g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr,    &
+             precr1,precr2,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        &
+                                                      )
+!-------------------------------------------------------------------
+#ifdef _OPENMP
+  use omp_lib
+#endif
+  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
+
+  REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL,                              &
+        INTENT(INOUT) ::                                                 snow, &
+                                                                      snowncv, &
+                                                                           sr
+
+! LOCAL VAR
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                   t
+  INTEGER ::                                                            i,j,k
+#ifdef _ACCEL_PROF
+  integer :: l
+  real*8 wsm3_t(8,256), wsm5_t(8,256), t1, t2
+  common /wsm_times/ wsm3_t(8,256), wsm5_t(8,256)
+#endif
+!-------------------------------------------------------------------
+#ifdef _ACCEL_PROF
+  call cpu_time(t1)
+#endif
+
+#ifdef _ACCEL
+
+        CALL wsm32D(th, q, qci, qrs,                               &
+                     w, den, pii, p, delz, rain, rainncv,          &
+                     delt,g, cpd, cpv, rd, rv, t0c,                &
+                     ep1, ep2, qmin,                               &
+                     XLS, XLV0, XLF0, den0, denr,                  &
+                     cliq,cice,psat,                               &
+                     ids,ide, jds,jde, kds,kde,                    &
+                     ims,ime, jms,jme, kms,kme,                    &
+                     its,ite, jts,jte, kts,kte                     )
+
+#else
+
+      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)                               &
+                    ,snow(ims,j),snowncv(ims,j)                                &
+                    ,sr(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
+#endif
+
+
+#ifdef _ACCEL_PROF
+  call cpu_time(t2)
+#ifdef _OPENMP
+  l = omp_get_thread_num() + 1
+#else
+  l = 1
+#endif
+  wsm3_t(1,l) = wsm3_t(1,l) + (t2 - t1)
+#endif
+
+  END SUBROUTINE wsm3
+
+
+#ifdef _ACCEL
+
+!===================================================================
+!{
+  SUBROUTINE wsm32D(th, q, qci, qrs,                               &
+                     w, den, pii, p, delz, rain, rainncv,          &
+                     delt,g, cpd, cpv, rd, rv, t0c,                &
+                     ep1, ep2, qmin,                               &
+                     XLS, XLV0, XLF0, den0, denr,                  &
+                     cliq,cice,psat,                               &
+                     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, ims:ims ),                  &
+        INTENT(INOUT) ::                                          &
+                                                               th
+  REAL, DIMENSION( ims:ime , kms:kme, ims:ims ),                  &
+        INTENT(IN) ::                                             &
+                                                               pii
+  REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),                  &
+        INTENT(INOUT) ::                                          &
+                                                               q, &
+                                                             qci, &
+                                                             qrs
+  REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),                  &
+        INTENT(IN   ) ::                                       w, &
+                                                             den, &
+                                                               p, &
+                                                            delz
+  REAL, DIMENSION( ims:ime , jms:jme ),                           &
+        INTENT(INOUT) ::                                    rain, &
+                                                         rainncv
+  REAL, INTENT(IN   ) ::                                    delt, &
+                                                               g, &
+                                                             cpd, &
+                                                             cpv, &
+                                                             t0c, &
+                                                            den0, &
+                                                              rd, &
+                                                              rv, &
+                                                             ep1, &
+                                                             ep2, &
+                                                            qmin, &
+                                                             XLS, &
+                                                            XLV0, &
+                                                            XLF0, &
+                                                            cliq, &
+                                                            cice, &
+                                                            psat, &
+                                                            denr
+! 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
+! LOCAL VAR
+  REAL, DIMENSION( its:ite , kts:kte, jts:jte ) ::   t
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+              falkc, work1c, work2c, fallc
+  INTEGER :: 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,                               &
+            qdt, pvt, qik, delq, facq, qrsci, frzmlt,             &
+            snomlt, hold, holdrs, facqci, supcol, coeres,         &
+            supsat, dtcld, xmi, qciik, delqci, eacrs, satdt,      &
+            qimax, diameter, xni0, roqi0
+  REAL  :: holdc, holdci
+  INTEGER :: i, k, j,                                 &
+            iprt, latd, lond, loop, loops, ifsat, kk, n
+!
+
+#define INL
+#ifdef INL
+! Temporaries used for inlining fpvs function
+  REAL  :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp
+#endif
+
+
+
+!=================================================================
+!   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-9 kg/kg.
+!
+      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.)
+!
+!----------------------------------------------------------------
+!     compute the minor time steps.
+!
+      loops = max(int(delt/dtcldcr+0.5),1)
+      dtcld = delt/loops
+      if(delt.le.dtcldcr) dtcld = delt
+#ifdef INL
+      cvap = cpv
+      hvap=xlv0
+      hsub=xls
+      ttp=t0c+0.1
+      dldt=cvap-cliq
+      xa=-dldt/rv
+      xb=xa+hvap/(rv*ttp)
+      dldti=cvap-cice
+      xai=-dldti/rv
+      xbi=xai+hsub/(rv*ttp)
+#endif
+!
+!----------------------------------------------------------------
+!     paddint 0 for negative values generated by dynamics
+!
+!$acc region &
+!$acc        local(t) &
+!$acc        copyin(delz(:,:,:),p(:,:,:)) &
+!$acc        copyin(den(:,:,:),w(:,:,:)) &
+!$acc        copy(q(:,:,:),qci(:,:,:),qrs(:,:,:))
+!$acc do &
+!$acc        private(rh,qs,denfac,rslope,rslope2,rslope3,rslopeb) &
+!$acc        private(pgen,paut,pacr,pisd,pres,pcon,fall,falk) &
+!$acc        private(xl,cpm,work1,work2,xni,qs0,n0sfac) &
+!$acc        private(falkc,work1c,work2c,fallc) &
+!$acc        parallel
+      do j = jts, jte
+!$acc do &
+!$acc        private(numdt,mstep) &
+!$acc        kernel vector(96)
+      do i = its, ite
+      do k = kts, kte
+            t(i,k,j)=th(i,k,j)*pii(i,k,j)
+          qci(i,k,j) = max(qci(i,k,j),0.0)
+          qrs(i,k,j) = max(qrs(i,k,j),0.0)
+        enddo
+!
+!----------------------------------------------------------------
+!     latent heat for phase changes and heat capacity. neglect the
+!     changes during microphysical process calculation
+!     emanuel(1994)
+!
+      do k = kts, kte
+          cpm(i,k) = cpmcal(q(i,k,j))
+          xl(i,k) = xlcal(t(i,k,j))
+      enddo
+!
+      do loop = 1,loops
+!
+!----------------------------------------------------------------
+!     initialize the large scale variables
+!
+        mstep = 1
+        flgcld(i) = .true.
+!
+      do k = kts, kte
+          denfac(i,k) = sqrt(den0/den(i,k,j))
+      enddo
+!
+      do k = kts, kte
+#ifndef INL
+          qs(i,k) = fpvs(t(i,k,j),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c)
+          qs0(i,k) = fpvs(t(i,k,j),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c)
+#else
+          tr=ttp/t(i,k,j)
+          if(t(i,k,j).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))
+#endif
+          qs0(i,k) = (qs0(i,k)-qs(i,k))/qs(i,k)
+          qs(i,k) = ep2 * qs(i,k) / (p(i,k,j) - qs(i,k))
+          qs(i,k) = max(qs(i,k),qmin)
+          rh(i,k) = max(q(i,k,j) / qs(i,k),qmin)
+      enddo
+!
+!----------------------------------------------------------------
+!     initialize the variables for microphysical physics
+!
+!
+      do k = kts, kte
+          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
+!
+!----------------------------------------------------------------
+!     compute the fallout term:
+!     first, vertical terminal velosity for minor loops
+!---------------------------------------------------------------
+! n0s: Intercept parameter for snow [m-4] [HDC 6]
+!---------------------------------------------------------------
+      do k = kts, kte
+          supcol = t0c-t(i,k,j)
+          n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.)
+          if(t(i,k,j).ge.t0c) then
+            if(qrs(i,k,j).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,j),den(i,k,j))
+              rslopeb(i,k) = 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,j).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,j),den(i,k,j),n0sfac(i,k))
+              rslopeb(i,k) = 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,j)                           &
+                    *max(qci(i,k,j),qmin))**0.75,1.e3),1.e6)
+      enddo
+!
+      numdt = 1
+      do k = kte, kts, -1
+          if(t(i,k,j).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,j)
+          numdt = max(int(work2(i,k)*dtcld+1.),1)
+          if(numdt.ge.mstep) mstep = numdt
+      enddo
+!
+      do n = 1, mstep
+        k = kte
+            falk(i,k) = den(i,k,j)*qrs(i,k,j)*work2(i,k)/mstep
+            hold = falk(i,k)
+            fall(i,k) = fall(i,k)+falk(i,k)
+            holdrs = qrs(i,k,j)
+            qrs(i,k,j) = max(qrs(i,k,j)-falk(i,k)*dtcld/den(i,k,j),0.)
+        do k = kte-1, kts, -1
+              falk(i,k) = den(i,k,j)*qrs(i,k,j)*work2(i,k)/mstep
+              hold = falk(i,k)
+              fall(i,k) = fall(i,k)+falk(i,k)
+              holdrs = qrs(i,k,j)
+              qrs(i,k,j) = max(qrs(i,k,j)-(falk(i,k)                        &
+                        -falk(i,k+1)*delz(i,k+1,j)/delz(i,k,j))*dtcld/den(i,k,j),0.)
+        enddo
+      enddo
+!---------------------------------------------------------------
+! Vice [ms-1] : fallout of ice crystal [HDC 5a]
+!---------------------------------------------------------------
+      mstep = 1
+      numdt = 1
+      do k = kte, kts, -1
+          if(t(i,k,j).lt.t0c.and.qci(i,k,j).gt.0.) then
+            xmi = den(i,k,j)*qci(i,k,j)/xni(i,k)
+            diameter  = dicon * sqrt(xmi)
+            work1c(i,k) = 1.49e4*diameter**1.31
+          else
+            work1c(i,k) = 0.
+          endif
+          if(qci(i,k,j).le.0.) then
+            work2c(i,k) = 0.
+          else
+            work2c(i,k) = work1c(i,k)/delz(i,k,j)
+          endif
+          numdt = max(int(work2c(i,k)*dtcld+1.),1)
+          if(numdt.ge.mstep) mstep = numdt
+      enddo
+!
+      do n = 1, mstep
+        k = kte
+            falkc(i,k) = den(i,k,j)*qci(i,k,j)*work2c(i,k)/mstep
+            holdc = falkc(i,k)
+            fallc(i,k) = fallc(i,k)+falkc(i,k)
+            holdci = qci(i,k,j)
+            qci(i,k,j) = max(qci(i,k,j)-falkc(i,k)*dtcld/den(i,k,j),0.)
+        do k = kte-1, kts, -1
+              falkc(i,k) = den(i,k,j)*qci(i,k,j)*work2c(i,k)/mstep
+              holdc = falkc(i,k)
+              fallc(i,k) = fallc(i,k)+falkc(i,k)
+              holdci = qci(i,k,j)
+              qci(i,k,j) = max(qci(i,k,j)-(falkc(i,k)                       &
+                        -falkc(i,k+1)*delz(i,k+1,j)/delz(i,k,j))*dtcld/den(i,k,j),0.)
+        enddo
+      enddo
+!
+!----------------------------------------------------------------
+!     compute the freezing/melting term. [D89 B16-B17]
+!     freezing occurs one layer above the melting level
+!
+        mstep = 0
+!
+      do k = kts, kte
+          if(t(i,k,j).ge.t0c) then
+            mstep = k
+          endif
+      enddo
+!
+        if(mstep.ne.0.and.w(i,mstep,j).gt.0.) then
+          work1(i,1) = float(mstep + 1)
+          work1(i,2) = float(mstep)
+        else
+          work1(i,1) = float(mstep)
+          work1(i,2) = float(mstep)
+        endif
+!
+        k  = int(work1(i,1)+0.5)
+        kk = int(work1(i,2)+0.5)
+        if(k*kk.ge.1) then
+          qrsci = qrs(i,k,j) + qci(i,k,j)
+          if(qrsci.gt.0..or.fall(i,kk).gt.0.) then
+            frzmlt = min(max(-w(i,k,j)*qrsci/delz(i,k,j),-qrsci/dtcld),    &
+                     qrsci/dtcld)
+            snomlt = min(max(fall(i,kk)/den(i,kk,j),-qrs(i,k,j)/dtcld),    &
+                     qrs(i,k,j)/dtcld)
+            if(k.eq.kk) then
+              t(i,k,j) = t(i,k,j) - xlf0/cpm(i,k)*(frzmlt+snomlt)*dtcld
+            else
+              t(i,k,j) = t(i,k,j) - xlf0/cpm(i,k)*frzmlt*dtcld
+              t(i,kk,j) = t(i,kk,j) - xlf0/cpm(i,kk)*snomlt*dtcld
+            endif
+          endif
+        endif
+!
+!----------------------------------------------------------------
+!      rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf
+!
+        if(fall(i,1).gt.0.) then
+          rainncv(i,j) = fall(i,1)*delz(i,1,j)/denr*dtcld*1000.
+          rain(i,j) = fall(i,1)*delz(i,1,j)/denr*dtcld*1000.                &
+                  + rain(i,j)
+        endif
+!
+!----------------------------------------------------------------
+!     rsloper: reverse of the slope parameter of the rain(m,j)
+!     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
+          if(t(i,k,j).ge.t0c) then
+            if(qrs(i,k,j).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,j),den(i,k,j))
+              rslopeb(i,k) = 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,j).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,j),den(i,k,j),n0sfac(i,k))
+              rslopeb(i,k) = 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
+!
+      do k = kts, kte
+          if(t(i,k,j).ge.t0c) then
+            work1(i,k) = diffac(xl(i,k),p(i,k,j),t(i,k,j),den(i,k,j),qs(i,k))
+          else
+            work1(i,k) = diffac(xls,p(i,k,j),t(i,k,j),den(i,k,j),qs(i,k))
+          endif
+          work2(i,k) = venfac(p(i,k,j),t(i,k,j),den(i,k,j))
+      enddo
+!
+      do k = kts, kte
+          supsat = max(q(i,k,j),qmin)-qs(i,k)
+          satdt = supsat/dtcld
+          if(t(i,k,j).ge.t0c) then
+!
+!===============================================================
+!
+! warm rain processes
+!
+! - follows the processes in RH83 and LFO except for autoconcersion
+!
+!===============================================================
+!---------------------------------------------------------------
+! paut1: auto conversion rate from cloud to rain [HDC 16]
+!        (C->R)
+!---------------------------------------------------------------
+            if(qci(i,k,j).gt.qc0) then
+              paut(i,k) = qck1*qci(i,k,j)**(7./3.)
+              paut(i,k) = min(paut(i,k),qci(i,k,j)/dtcld)
+            endif
+!---------------------------------------------------------------
+! pracw: accretion of cloud water by rain [D89 B15]
+!        (C->R)
+!---------------------------------------------------------------
+            if(qrs(i,k,j).gt.qcrmin.and.qci(i,k,j).gt.qmin) then
+                pacr(i,k) = min(pacrr*rslope3(i,k)*rslopeb(i,k)          &
+                     *qci(i,k,j)*denfac(i,k),qci(i,k,j)/dtcld)
+            endif
+!---------------------------------------------------------------
+! pres1: evaporation/condensation rate of rain [HDC 14]
+!        (V->R or R->V)
+!---------------------------------------------------------------
+            if(qrs(i,k,j).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,j)/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,j)
+            ifsat = 0
+!-------------------------------------------------------------
+! Ni: ice crystal number concentraiton   [HDC 5c]
+!-------------------------------------------------------------
+            xni(i,k) = min(max(5.38e7*(den(i,k,j)                         &
+                      *max(qci(i,k,j),qmin))**0.75,1.e3),1.e6)
+            eacrs = exp(0.05*(-supcol))
+!
+            if(qrs(i,k,j).gt.qcrmin.and.qci(i,k,j).gt.qmin) then
+              pacr(i,k) = min(pacrs*n0sfac(i,k)*eacrs*rslope3(i,k)       &
+                       *rslopeb(i,k)*qci(i,k,j)*denfac(i,k),qci(i,k,j)/dtcld)
+            endif
+!-------------------------------------------------------------
+! pisd: Deposition/Sublimation rate of ice [HDC 9]
+!       (T<T0: V->I or I->V)
+!-------------------------------------------------------------
+            if(qci(i,k,j).gt.0.) then
+              xmi = den(i,k,j)*qci(i,k,j)/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,j)/dtcld)
+              else
+                pisd(i,k) = min(pisd(i,k),satdt/2)
+              endif
+              if(abs(pisd(i,k)).ge.abs(satdt)) ifsat = 1
+            endif
+!-------------------------------------------------------------
+! pres2: deposition/sublimation rate of snow [HDC 14]
+!        (V->S or S->V)
+!-------------------------------------------------------------
+            if(qrs(i,k,j).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)
+              if(pres(i,k).lt.0.) then
+                pres(i,k) = max(pres(i,k),-qrs(i,k,j)/dtcld)
+                pres(i,k) = max(pres(i,k),satdt/2)
+              else
+                pres(i,k) = min(pres(i,k),satdt/2)
+              endif
+              if(abs(pisd(i,k)+pres(i,k)).ge.abs(satdt)) ifsat = 1
+            endif
+!-------------------------------------------------------------
+! pgen: generation(nucleation) of ice from vapor [HDC 7-8]
+!       (T<T0: V->I)
+!-------------------------------------------------------------
+            if(supsat.gt.0.and.ifsat.ne.1) then
+              xni0 = 1.e3*exp(0.1*supcol)
+              roqi0 = 4.92e-11*xni0**1.33
+              pgen(i,k) = max(0.,(roqi0/den(i,k,j)-max(qci(i,k,j),0.))/dtcld)
+              pgen(i,k) = min(pgen(i,k),satdt)
+            endif
+!-------------------------------------------------------------
+! paut2: conversion(aggregation) of ice to snow [HDC 12]
+!       (T<T0: I->S)
+!-------------------------------------------------------------
+            if(qci(i,k,j).gt.0.) then
+              qimax = roqimax/den(i,k,j)
+              paut(i,k) = max(0.,(qci(i,k,j)-qimax)/dtcld)
+            endif
+          endif
+      enddo
+!
+!----------------------------------------------------------------
+!     check mass conservation of generation terms and feedback to the
+!     large scale
+!
+      do k = kts, kte
+          qciik = max(qmin,qci(i,k,j))
+          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,j))
+          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,j) = q(i,k,j)+work2(i,k)*dtcld
+          qci(i,k,j) = max(qci(i,k,j)-(paut(i,k)+pacr(i,k)-pgen(i,k)     &
+                   -pisd(i,k))*dtcld,0.)
+          qrs(i,k,j) = max(qrs(i,k,j)+(paut(i,k)+pacr(i,k)               &
+                   +pres(i,k))*dtcld,0.)
+          if(t(i,k,j).lt.t0c) then
+            t(i,k,j) = t(i,k,j)-xls*work2(i,k)/cpm(i,k)*dtcld
+          else
+            t(i,k,j) = t(i,k,j)-xl(i,k)*work2(i,k)/cpm(i,k)*dtcld
+          endif
+      enddo
+!
+      do k = kts, kte
+#ifndef INL
+          qs(i,k) = fpvs(t(i,k,j),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c)
+#else
+          tr=ttp/t(i,k,j)
+          qs(i,k)=psat*(tr**xa)*exp(xb*(1.-tr))
+#endif
+          qs(i,k) = ep2 * qs(i,k) / (p(i,k,j) - qs(i,k))
+          qs(i,k) = max(qs(i,k),qmin)
+          denfac(i,k) = sqrt(den0/den(i,k,j))
+      enddo
+!
+!----------------------------------------------------------------
+!  pcon: condensational/evaporational rate of cloud water [RH83 A6]
+!     if there exists additional water vapor condensated/if
+!     evaporation of cloud water is not enough to remove subsaturation
+!
+      do k = kts, kte
+          work1(i,k) = conden(t(i,k,j),q(i,k,j),qs(i,k),xl(i,k),cpm(i,k))
+          work2(i,k) = qci(i,k,j)+work1(i,k)
+          pcon(i,k) = min(max(work1(i,k),0.),max(q(i,k,j),0.))/dtcld
+          if(qci(i,k,j).gt.0..and.work1(i,k).lt.0.and.t(i,k,j).gt.t0c)      &
+            pcon(i,k) = max(work1(i,k),-qci(i,k,j))/dtcld
+          q(i,k,j) = q(i,k,j)-pcon(i,k)*dtcld
+          qci(i,k,j) = max(qci(i,k,j)+pcon(i,k)*dtcld,0.)
+          t(i,k,j) = t(i,k,j)+pcon(i,k)*xl(i,k)/cpm(i,k)*dtcld
+      enddo
+!
+!----------------------------------------------------------------
+!     padding for small values
+!
+      do k = kts, kte
+          if(qci(i,k,j).le.qmin) qci(i,k,j) = 0.0
+      enddo
+!
+      enddo                  ! big loops
+         DO K=kts,kte
+            th(i,k,j)=t(i,k,j)/pii(i,k,j)
+         ENDDO
+      enddo
+      enddo
+!$acc end region
+  END SUBROUTINE wsm32D !}
+
+#else
+
+
+!===================================================================
+!
+  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                                              &
+                   ,snow,snowncv                                               &
+                   ,sr                                                         &
+                   ,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
+
+  REAL, DIMENSION( ims:ime ),     OPTIONAL,                                    &
+        INTENT(INOUT) ::                                                 snow, &
+                                                                      snowncv, &
+                                                                           sr
+! LOCAL VAR
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                           rh, &
+                                                                           qs, &
+                                                                       denfac, &
+                                                                       rslope, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                      rslopeb
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                         pgen, &
+                                                                         pisd, &
+                                                                         paut, &
+                                                                         pacr, &
+                                                                         pres, &
+                                                                         pcon
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                         fall, &
+                                                                         falk, &
+                                                                           xl, &
+                                                                          cpm, &
+                                                                        work1, &
+                                                                        work2, &
+                                                                          xni, &
+                                                                          qs0, &
+                                                                       n0sfac
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                        falkc, &
+                                                                       work1c, &
+                                                                       work2c, &
+                                                                        fallc
+
+  INTEGER, DIMENSION( its:ite ) ::                                      kwork1,&
+                                                                        kwork2
+
+  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,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
+! variables for optimization
+  REAL, DIMENSION( its:ite )    :: tvec1
+!
+!=================================================================
+!   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
+        kwork2(i) = mstep(i)
+        kwork1(i) = mstep(i)
+        if(mstep(i).ne.0) then
+          if (w(i,mstep(i)).gt.0.) then
+            kwork1(i) = mstep(i) + 1
+          endif
+        endif
+      enddo
+!
+      do i = its, ite
+        k  = kwork1(i)
+        kk = kwork2(i)
+        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
+!             vt2i = 1.49e4*exp((log(diameter))*(1.31))
+              vt2s = pvts*rslopeb(i,k)*denfac(i,k)
+!-------------------------------------------------------------
+! praci: Accretion of cloud ice by rain [HL A15] [LFO 25]
+!        (T<T0: I->R)
+!-------------------------------------------------------------
+              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]
+!       (T<T0: V->I 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]
+!       (T<T0: V->I)
+!-------------------------------------------------------------
+            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]
+!       (T<T0: I->S)
+!-------------------------------------------------------------
+            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
+#endif
+
+! ...................................................................
+      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
+   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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm5.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm5.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm5.F	(revision 17)
@@ -0,0 +1,1631 @@
+#ifdef _ACCEL
+#  include "module_mp_wsm5_accel.F"
+#else
+#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. ! maximum time step for minor loops
+   REAL, PARAMETER, PRIVATE :: n0r = 8.e6         ! intercept parameter rain
+   REAL, PARAMETER, PRIVATE :: avtr = 841.9       ! a constant for terminal velocity of rain
+   REAL, PARAMETER, PRIVATE :: bvtr = 0.8         ! a constant for terminal velocity of rain
+   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       ! a constant for terminal velocity of snow
+   REAL, PARAMETER, PRIVATE :: bvts = .41         ! a constant for terminal velocity of snow
+   REAL, PARAMETER, PRIVATE :: n0smax =  1.e11    ! maximum n0s (t=-90C unlimited)
+   REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4   ! limited maximum value for slope parameter of rain
+   REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5   ! limited maximum value for slope parameter of snow
+   REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4   ! limited maximum value for slope parameter of graupel
+   REAL, PARAMETER, PRIVATE :: dicon = 11.9       ! constant for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: dimax = 500.e-6    ! limited maximum value for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: n0s = 2.e6         ! temperature dependent intercept parameter snow
+   REAL, PARAMETER, PRIVATE :: alpha = .12        ! .122 exponen factor for n0s
+   REAL, PARAMETER, PRIVATE :: pfrz1 = 100.       ! constant in Biggs freezing
+   REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66       ! constant in Biggs freezing
+   REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9     ! minimun values for qr, qs, and qg
+   REAL, PARAMETER, PRIVATE :: eacrc = 1.0        ! Snow/cloud-water collection efficiency
+   REAL, SAVE ::                                      &
+             qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, &
+             g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr,    &
+             precr1,precr2,xmmax,roqimax,bvts1,       &
+             bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs,     &
+             g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, &
+             pidn0s,xlv1,pacrc,pi,                    &
+             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
+!-------------------------------------------------------------------
+!
+  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
+  CHARACTER*256 :: emess
+  INTEGER :: mkx_test
+  INTEGER ::               i,j,k
+!-------------------------------------------------------------------
+
+#ifndef RUN_ON_GPU
+      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
+         !  Sending array starting locations of optional variables may cause
+         !  troubles, so we explicitly change the call.
+         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,snowncv                                  &
+                                                                   )
+         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
+#else
+      CALL get_wsm5_gpu_levels ( mkx_test )
+      IF ( mkx_test .LT. kte ) THEN
+        WRITE(emess,*)'Number of levels compiled for GPU WSM5 too small. ',      &
+                      mkx_test,' < ',kte
+        CALL wrf_error_fatal(emess)
+      ENDIF
+      CALL wsm5_host (                                                           &
+                    th(its:ite,kts:kte,jts:jte), pii(its:ite,kts:kte,jts:jte)    &
+                   ,q(its:ite,kts:kte,jts:jte), qc(its:ite,kts:kte,jts:jte)      &
+                   ,qi(its:ite,kts:kte,jts:jte), qr(its:ite,kts:kte,jts:jte)     &
+                   ,qs(its:ite,kts:kte,jts:jte), den(its:ite,kts:kte,jts:jte)    &
+                   ,p(its:ite,kts:kte,jts:jte), delz(its:ite,kts:kte,jts:jte)    &
+                   ,delt                                                         &
+                   ,rain(its:ite,jts:jte),rainncv(its:ite,jts:jte)               &
+                   ,snow(its:ite,jts:jte),snowncv(its:ite,jts:jte)               &
+                   ,sr(its:ite,jts:jte)                                          &
+                   ,its, ite,  jts, jte,  kts, kte                               &
+                   ,its, ite,  jts, jte,  kts, kte                               &
+                   ,its, ite,  jts, jte,  kts, kte                               &
+          )
+#endif
+
+  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
+!-------------------------------------------------------------------
+!
+!  This code is a 5-class mixed ice microphyiscs scheme (WSM5) of the 
+!  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,  &
+                                      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, jms:jme ),     OPTIONAL,              &
+        INTENT(INOUT) ::                                    snow, &
+                                                         snowncv
+! LOCAL VAR
+  REAL, DIMENSION( its:ite , kts:kte , 2) ::                      &
+                                                              rh, &
+                                                              qs, &
+                                                          rslope, &
+                                                         rslope2, &
+                                                         rslope3, &
+                                                         rslopeb, &
+                                                         qrs_tmp, &
+                                                            falk, &
+                                                            fall, &
+                                                           work1
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+                                                           falkc, &
+                                                           fallc, &
+                                                              xl, &
+                                                             cpm, &
+                                                          denfac, &
+                                                             xni, &
+                                                         denqrs1, &
+                                                         denqrs2, &
+                                                          denqci, &
+                                                          n0sfac, &
+                                                           work2, &
+                                                           workr, &
+                                                           works, &
+                                                          work1c, &
+                                                          work2c
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+                                                         den_tmp, &
+                                                        delz_tmp
+  REAL, DIMENSION( its:ite ) ::                                   &
+                                                         delqrs1, &
+                                                         delqrs2, &
+                                                           delqi
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+                                                           pigen, &
+                                                           pidep, &
+                                                           psdep, &
+                                                           praut, &
+                                                           psaut, &
+                                                           prevp, &
+                                                           psevp, &
+                                                           pracw, &
+                                                           psacw, &
+                                                           psaci, &
+                                                           pcond, &
+                                                           psmlt
+  INTEGER, DIMENSION( its:ite ) ::                                &
+                                                           mstep, &
+                                                           numdt
+  REAL, DIMENSION(its:ite) ::                             tstepsnow
+  REAL, DIMENSION(its:ite) ::                             rmstep
+  REAL dtcldden, rdelz, rdtcld
+  LOGICAL, DIMENSION( its:ite ) ::                        flgcld
+#define WSM_NO_CONDITIONAL_IN_VECTOR
+#ifdef WSM_NO_CONDITIONAL_IN_VECTOR
+  REAL, DIMENSION(its:ite) :: xal, xbl
+#endif
+  REAL  ::                                                        &
+            cpmcal, xlcal, diffus,                                &
+            viscos, xka, venfac, conden, diffac,                  &
+            x, y, z, a, b, c, d, e,                               &
+            qdt, holdrr, holdrs, supcol, supcolt, 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,  holdc, holdci
+! variables for optimization
+  REAL, DIMENSION( its:ite )           ::                    tvec1
+  REAL ::                                                    temp 
+  INTEGER :: i, j, k, mstepmax,                                   &
+            iprt, latd, lond, loop, loops, ifsat, n, idim, kdim
+! Temporaries used for inlining fpvs function
+  REAL  :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp
+  REAL  :: logtr
+!
+!=================================================================
+!   compute internal functions
+!
+      cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv
+      xlcal(x) = xlv0-xlv1*(x-t0c)
+!----------------------------------------------------------------
+!     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))
+!
+!----------------------------------------------------------------
+      idim = ite-its+1
+      kdim = kte-kts+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
+      do k = kts, kte
+        do i = its, ite
+          delz_tmp(i,k) = delz(i,k)
+          den_tmp(i,k) = den(i,k)
+        enddo
+      enddo
+!
+!----------------------------------------------------------------
+!    initialize the surface rain, snow
+!
+      do i = its, ite
+        rainncv(i) = 0.
+        if(PRESENT (snowncv) .AND. PRESENT (snow)) snowncv(i,lat) = 0.
+        sr(i) = 0.
+! new local array to catch step snow
+        tstepsnow(i) = 0.
+      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)
+! this is for compilers where the conditional inhibits vectorization
+#ifdef WSM_NO_CONDITIONAL_IN_VECTOR
+      do k = kts, kte
+        do i = its, ite
+          if(t(i,k).lt.ttp) then
+            xal(i) = xai
+            xbl(i) = xbi
+          else
+            xal(i) = xa
+            xbl(i) = xb
+          endif
+        enddo
+        do i = its, ite
+          tr=ttp/t(i,k)
+          logtr=log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k))
+          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)=psat*exp(logtr*(xal(i))+xbl(i)*(1.-tr))
+          qs(i,k,2) = min(qs(i,k,2),0.99*p(i,k))
+          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)
+#else
+      do k = kts, kte
+        do i = its, ite
+          tr=ttp/t(i,k)
+          logtr=log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k))
+          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)
+          if(t(i,k).lt.ttp) then
+            qs(i,k,2)=psat*exp(logtr*(xai)+xbi*(1.-tr))
+          else
+            qs(i,k,2)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          endif
+          qs(i,k,2) = min(qs(i,k,2),0.99*p(i,k))
+          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
+#endif
+        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
+!-------------------------------------------------------------
+! Ni: ice crystal number concentraiton   [HDC 5c]
+!-------------------------------------------------------------
+      do k = kts, kte
+        do i = its, ite
+          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
+!
+!----------------------------------------------------------------
+!     compute the fallout term:
+!     first, vertical terminal velosity for minor loops
+!----------------------------------------------------------------
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k,1) = qrs(i,k,1)
+          qrs_tmp(i,k,2) = qrs(i,k,2)
+        enddo
+      enddo
+      call slope_wsm5(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, &
+                     work1,its,ite,kts,kte)
+!
+      do k = kte, kts, -1
+        do i = its, ite
+          workr(i,k) = work1(i,k,1) 
+          works(i,k) = work1(i,k,2) 
+          denqrs1(i,k) = den(i,k)*qrs(i,k,1)
+          denqrs2(i,k) = den(i,k)*qrs(i,k,2)
+          if(qrs(i,k,1).le.0.0) workr(i,k) = 0.0
+          if(qrs(i,k,2).le.0.0) works(i,k) = 0.0
+        enddo
+      enddo
+      call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,workr,denqrs1,  &
+                           delqrs1,dtcld,1,1)
+      call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,works,denqrs2,  &
+                           delqrs2,dtcld,2,1)
+      do k = kts, kte
+        do i = its, ite
+          qrs(i,k,1) = max(denqrs1(i,k)/den(i,k),0.)
+          qrs(i,k,2) = max(denqrs2(i,k)/den(i,k),0.)
+          fall(i,k,1) = denqrs1(i,k)*workr(i,k)/delz(i,k)
+          fall(i,k,2) = denqrs2(i,k)*works(i,k)/delz(i,k)
+        enddo
+      enddo
+      do i = its, ite
+        fall(i,1,1) = delqrs1(i)/delz(i,1)/dtcld
+        fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld
+      enddo
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k,1) = qrs(i,k,1)
+          qrs_tmp(i,k,2) = qrs(i,k,2)
+        enddo
+      enddo
+      call slope_wsm5(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, &
+                     work1,its,ite,kts,kte)
+      do k = kte, kts, -1
+        do i = its, ite
+          supcol = t0c-t(i,k)
+          n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.)
+          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) = (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
+        enddo
+      enddo
+!---------------------------------------------------------------
+! Vice [ms-1] : fallout of ice crystal [HDC 5a]
+!---------------------------------------------------------------
+      do k = kte, kts, -1
+        do i = its, ite
+          if(qci(i,k,2).le.0.) then
+            work1c(i,k) = 0.
+          else
+            xmi = den(i,k)*qci(i,k,2)/xni(i,k)
+            diameter  = max(min(dicon * sqrt(xmi),dimax), 1.e-25)
+            work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31))
+          endif
+        enddo
+      enddo
+!
+!  forward semi-laglangian scheme (JH), PCM (piecewise constant),  (linear)
+!
+      do k = kte, kts, -1
+        do i = its, ite
+          denqci(i,k) = den(i,k)*qci(i,k,2)
+        enddo
+      enddo
+      call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci,  &
+                           delqi,dtcld,1,0)
+      do k = kts, kte
+        do i = its, ite
+          qci(i,k,2) = max(denqci(i,k)/den(i,k),0.)
+        enddo
+      enddo
+      do i = its, ite
+        fallc(i,1) = delqi(i)/delz(i,1)/dtcld
+      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)
+        if(fallsum.gt.0.) then
+          rainncv(i) = fallsum*delz(i,1)/denr*dtcld*1000. + rainncv(i)
+          rain(i) = fallsum*delz(i,1)/denr*dtcld*1000. + rain(i)
+        endif
+        if(fallsum_qsi.gt.0.) then
+          tstepsnow(i)   = fallsum_qsi*delz(i,kts)/denr*dtcld*1000.            &
+                           +tstepsnow(i) 
+        IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN
+          snowncv(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000.            & 
+                           +snowncv(i,lat)    
+          snow(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i,lat)
+        ENDIF
+        endif
+!       if(fallsum.gt.0.)sr(i)=snowncv(i,lat)/(rainncv(i)+1.e-12)
+        if(fallsum.gt.0.)sr(i)=tstepsnow(i)/(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
+            supcolt=min(supcol,50.)
+!           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*supcolt)-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]
+!        (T<T0, R->S)
+!---------------------------------------------------------------
+          if(supcol.gt.0..and.qrs(i,k,1).gt.0.) then
+            supcolt=min(supcol,50.)
+!           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*supcolt)-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
+!
+!----------------------------------------------------------------
+!     update the slope parameters for microphysics computation
+!
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k,1) = qrs(i,k,1)
+          qrs_tmp(i,k,2) = qrs(i,k,2)
+        enddo
+      enddo
+      call slope_wsm5(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, &
+                     work1,its,ite,kts,kte)
+!------------------------------------------------------------------
+!     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
+!         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)
+          n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.)
+          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]
+!        (T<T0: I->S)
+!-------------------------------------------------------------
+              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
+          endif
+!-------------------------------------------------------------
+! psacw: Accretion of cloud water by snow  [HL A7] [LFO 24]
+!        (T<T0: C->S, 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
+          if(supcol .gt. 0) then
+!-------------------------------------------------------------
+! pidep: Deposition/Sublimation rate of ice [HDC 9]
+!       (T<T0: V->I 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
+!-------------------------------------------------------------
+! 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]
+!       (T<T0: V->I)
+!-------------------------------------------------------------
+            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]
+!       (T<T0: I->S)
+!-------------------------------------------------------------
+            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
+!
+!     rain
+!
+!
+            value = max(qmin,qrs(i,k,1))
+            source = (-praut(i,k)-pracw(i,k)-prevp(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
+              prevp(i,k) = prevp(i,k)*factor
+            endif
+!
+!    snow
+!
+            value = max(qmin,qrs(i,k,2))
+            source = (-psdep(i,k)-psaut(i,k)-psaci(i,k)-psacw(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
+              psaci(i,k) = psaci(i,k)*factor
+              psacw(i,k) = psacw(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
+!
+!     rain
+!
+            value = max(qmin,qrs(i,k,1))
+            source = (-praut(i,k)-pracw(i,k)-prevp(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
+              prevp(i,k) = prevp(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)
+          logtr = log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k))
+          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)
+        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
+!
+   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
+   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
+!------------------------------------------------------------------------------
+      subroutine slope_wsm5(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,   &
+                            vt,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte,2) ::                                     &
+                                                                          qrs, &
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                           vt
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdar, lamdas,  x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     size distributions: (x=mixing ratio, y=air density):
+!     valid for mixing ratio > 1.e-9 kg/kg.
+      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
+!
+      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
+          vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)
+          vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)
+          if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0
+          if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0
+        enddo
+      enddo
+  END subroutine slope_wsm5
+!-----------------------------------------------------------------------------
+      subroutine slope_rain(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,   &
+                            vt,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          qrs, &
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                           vt, &
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdar, x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     size distributions: (x=mixing ratio, y=air density):
+!     valid for mixing ratio > 1.e-9 kg/kg.
+      lamdar(x,y)=   sqrt(sqrt(pidn0r/(x*y)))      ! (pidn0r/(x*y))**.25
+!
+      do k = kts, kte
+        do i = its, ite
+          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
+            rslope2(i,k) = rslope(i,k)*rslope(i,k)
+            rslope3(i,k) = rslope2(i,k)*rslope(i,k)
+          endif
+          vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k)
+          if(qrs(i,k).le.0.0) vt(i,k) = 0.0
+        enddo
+      enddo
+  END subroutine slope_rain
+!------------------------------------------------------------------------------
+      subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,   &
+                            vt,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          qrs, &
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                           vt, &
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdas, x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     size distributions: (x=mixing ratio, y=air density):
+!     valid for mixing ratio > 1.e-9 kg/kg.
+      lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y)))    ! (pidn0s*z/(x*y))**.25
+!
+      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).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
+            rslope2(i,k) = rslope(i,k)*rslope(i,k)
+            rslope3(i,k) = rslope2(i,k)*rslope(i,k)
+          endif
+          vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k)
+          if(qrs(i,k).le.0.0) vt(i,k) = 0.0
+        enddo
+      enddo
+  END subroutine slope_snow
+!-------------------------------------------------------------------
+      SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter)
+!-------------------------------------------------------------------
+!
+! for non-iteration semi-Lagrangain forward advection for cloud
+! with mass conservation and positive definite advection
+! 2nd order interpolation with monotonic piecewise linear method
+! this routine is under assumption of decfl < 1 for semi_Lagrangian
+!
+! dzl    depth of model layer in meter
+! wwl    terminal velocity at model layer m/s
+! rql    cloud density*mixing ration
+! precip precipitation
+! dt     time step
+! id     kind of precip: 0 test case; 1 raindrop  2: snow
+! iter   how many time to guess mean terminal velocity: 0 pure forward.
+!        0 : use departure wind for advection
+!        1 : use mean wind for advection
+!        > 1 : use mean wind after iter-1 iterations
+!
+! author: hann-ming henry juang <henry.juang@noaa.gov>
+!         implemented by song-you hong
+!
+      implicit none
+      integer  im,km,id
+      real  dt
+      real  dzl(im,km),wwl(im,km),rql(im,km),precip(im)
+      real  denl(im,km),denfacl(im,km),tkl(im,km)
+!
+      integer  i,k,n,m,kk,kb,kt,iter
+      real  tl,tl2,qql,dql,qqd
+      real  th,th2,qqh,dqh
+      real  zsum,qsum,dim,dip,c1,con1,fa1,fa2
+      real  allold, allnew, zz, dzamin, cflmax, decfl
+      real  dz(km), ww(km), qq(km), wd(km), wa(km), was(km)
+      real  den(km), denfac(km), tk(km)
+      real  wi(km+1), zi(km+1), za(km+1)
+      real  qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km)
+      real  dza(km+1), qa(km+1), qmi(km+1), qpi(km+1)
+!
+      precip(:) = 0.0
+!
+      i_loop : do i=1,im
+! -----------------------------------
+      dz(:) = dzl(i,:)
+      qq(:) = rql(i,:)
+      ww(:) = wwl(i,:)
+      den(:) = denl(i,:)
+      denfac(:) = denfacl(i,:)
+      tk(:) = tkl(i,:)
+! skip for no precipitation for all layers
+      allold = 0.0
+      do k=1,km
+        allold = allold + qq(k)
+      enddo
+      if(allold.le.0.0) then
+        cycle i_loop
+      endif
+!
+! compute interface values
+      zi(1)=0.0
+      do k=1,km
+        zi(k+1) = zi(k)+dz(k)
+      enddo
+!
+! save departure wind
+      wd(:) = ww(:)
+      n=1
+ 100  continue
+! plm is 2nd order, we can use 2nd order wi or 3rd order wi
+! 2nd order interpolation to get wi
+      wi(1) = ww(1)
+      wi(km+1) = ww(km)
+      do k=2,km
+        wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k))
+      enddo
+! 3rd order interpolation to get wi
+      fa1 = 9./16.
+      fa2 = 1./16.
+      wi(1) = ww(1)
+      wi(2) = 0.5*(ww(2)+ww(1))
+      do k=3,km-1
+        wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2))
+      enddo
+      wi(km) = 0.5*(ww(km)+ww(km-1))
+      wi(km+1) = ww(km)
+!
+! terminate of top of raingroup
+      do k=2,km
+        if( ww(k).eq.0.0 ) wi(k)=ww(k-1)
+      enddo
+!
+! diffusivity of wi
+      con1 = 0.05
+      do k=km,1,-1
+        decfl = (wi(k+1)-wi(k))*dt/dz(k)
+        if( decfl .gt. con1 ) then
+          wi(k) = wi(k+1) - con1*dz(k)/dt
+        endif
+      enddo
+! compute arrival point
+      do k=1,km+1
+        za(k) = zi(k) - wi(k)*dt
+      enddo
+!
+      do k=1,km
+        dza(k) = za(k+1)-za(k)
+      enddo
+      dza(km+1) = zi(km+1) - za(km+1)
+!
+! computer deformation at arrival point
+      do k=1,km
+        qa(k) = qq(k)*dz(k)/dza(k)
+        qr(k) = qa(k)/den(k)
+      enddo
+      qa(km+1) = 0.0
+!     call maxmin(km,1,qa,' arrival points ')
+!
+! compute arrival terminal velocity, and estimate mean terminal velocity
+! then back to use mean terminal velocity
+      if( n.le.iter ) then
+        if (id.eq.1) then
+          call slope_rain(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km)
+        else
+          call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km)
+        endif 
+        if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km))
+        do k=1,km
+!#ifdef DEBUG
+!        print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k)
+!#endif
+! mean wind is average of departure and new arrival winds
+          ww(k) = 0.5* ( wd(k)+wa(k) )
+        enddo
+        was(:) = wa(:)
+        n=n+1
+        go to 100
+      endif
+!
+! estimate values at arrival cell interface with monotone
+      do k=2,km
+        dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k))
+        dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k))
+        if( dip*dim.le.0.0 ) then
+          qmi(k)=qa(k)
+          qpi(k)=qa(k)
+        else
+          qpi(k)=qa(k)+0.5*(dip+dim)*dza(k)
+          qmi(k)=2.0*qa(k)-qpi(k)
+          if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then
+            qpi(k) = qa(k)
+            qmi(k) = qa(k)
+          endif
+        endif
+      enddo
+      qpi(1)=qa(1)
+      qmi(1)=qa(1)
+      qmi(km+1)=qa(km+1)
+      qpi(km+1)=qa(km+1)
+!
+! interpolation to regular point
+      qn = 0.0
+      kb=1
+      kt=1
+      intp : do k=1,km
+             kb=max(kb-1,1)
+             kt=max(kt-1,1)
+! find kb and kt
+             if( zi(k).ge.za(km+1) ) then
+               exit intp
+             else
+               find_kb : do kk=kb,km
+                         if( zi(k).le.za(kk+1) ) then
+                           kb = kk
+                           exit find_kb
+                         else
+                           cycle find_kb
+                         endif
+               enddo find_kb
+               find_kt : do kk=kt,km
+                         if( zi(k+1).le.za(kk) ) then
+                           kt = kk
+                           exit find_kt
+                         else
+                           cycle find_kt
+                         endif
+               enddo find_kt
+               kt = kt - 1
+! compute q with piecewise constant method
+               if( kt.eq.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 th=(zi(k+1)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 th2=th*th
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qqh=qqd*th2+qmi(kb)*th
+                 qql=qqd*tl2+qmi(kb)*tl
+                 qn(k) = (qqh-qql)/(th-tl)
+               else if( kt.gt.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qql=qqd*tl2+qmi(kb)*tl
+                 dql = qa(kb)-qql
+                 zsum  = (1.-tl)*dza(kb)
+                 qsum  = dql*dza(kb)
+                 if( kt-kb.gt.1 ) then
+                 do m=kb+1,kt-1
+                   zsum = zsum + dza(m)
+                   qsum = qsum + qa(m) * dza(m)
+                 enddo
+                 endif
+                 th=(zi(k+1)-za(kt))/dza(kt)
+                 th2=th*th
+                 qqd=0.5*(qpi(kt)-qmi(kt))
+                 dqh=qqd*th2+qmi(kt)*th
+                 zsum  = zsum + th*dza(kt)
+                 qsum  = qsum + dqh*dza(kt)
+                 qn(k) = qsum/zsum
+               endif
+               cycle intp
+             endif
+!
+       enddo intp
+!
+! rain out
+      sum_precip: do k=1,km
+                    if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*dza(k)
+                      cycle sum_precip
+                    else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*(0.0-za(k))
+                      exit sum_precip
+                    endif
+                    exit sum_precip
+      enddo sum_precip
+!
+! replace the new values
+      rql(i,:) = qn(:)
+!
+! ----------------------------------
+      enddo i_loop
+!
+  END SUBROUTINE nislfv_rain_plm
+END MODULE module_mp_wsm5
+#endif
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm5_accel.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm5_accel.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm5_accel.F	(revision 17)
@@ -0,0 +1,3093 @@
+#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. ! maximum time step for minor loops
+   REAL, PARAMETER, PRIVATE :: n0r = 8.e6         ! intercept parameter rain
+   REAL, PARAMETER, PRIVATE :: avtr = 841.9       ! a constant for terminal velocity of rain
+   REAL, PARAMETER, PRIVATE :: bvtr = 0.8         ! a constant for terminal velocity of rain
+   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       ! a constant for terminal velocity of snow
+   REAL, PARAMETER, PRIVATE :: bvts = .41         ! a constant for terminal velocity of snow
+   REAL, PARAMETER, PRIVATE :: n0smax =  1.e11    ! maximum n0s (t=-90C unlimited)
+   REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4   ! limited maximum value for slope parameter of rain
+   REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5   ! limited maximum value for slope parameter of snow
+   REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4   ! limited maximum value for slope parameter of graupel
+   REAL, PARAMETER, PRIVATE :: dicon = 11.9       ! constant for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: dimax = 500.e-6    ! limited maximum value for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: n0s = 2.e6         ! temperature dependent intercept parameter snow
+   REAL, PARAMETER, PRIVATE :: alpha = .12        ! .122 exponen factor for n0s
+   REAL, PARAMETER, PRIVATE :: pfrz1 = 100.       ! constant in Biggs freezing
+   REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66       ! constant in Biggs freezing
+   REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9     ! minimun values for qr, qs, and qg
+   REAL, PARAMETER, PRIVATE :: eacrc = 1.0        ! Snow/cloud-water collection efficiency
+   REAL, SAVE ::                                      &
+             qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, &
+             g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr,    &
+             precr1,precr2,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                        &
+                                                                   )
+#ifdef _OPENMP
+  use omp_lib
+#endif
+!-------------------------------------------------------------------
+  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
+  CHARACTER*256 :: emess
+  INTEGER :: mkx_test
+  INTEGER ::               i,j,k
+
+#ifdef _ACCEL_PROF
+  INTEGER :: l
+  real*8 wsm3_t(8,256), wsm5_t(8,256), t1, t2
+  common /wsm_times/ wsm3_t(8,256), wsm5_t(8,256)
+#endif
+
+
+!-------------------------------------------------------------------
+
+#ifdef _ACCEL_PROF
+call cpu_time(t1)
+#endif
+
+#ifndef RUN_ON_GPU
+
+#ifdef _ACCEL
+
+      !  Need to send th, pii, qc, qi, qr, qs
+      !  Don't send t
+
+      CALL wsm52D(th, pii, q, qc, qr, qi, qs                       &
+                  ,den                                             &
+                  ,p, delz                                         &
+                  ,delt,g, cpd, cpv, rd, rv, t0c                   &
+                  ,ep1, ep2, qmin                                  &
+                  ,XLS, XLV0, XLF0, den0, denr                     &
+                  ,cliq,cice,psat                                  &
+                  ,rain,rainncv                                    &
+                  ,sr                                              &
+                  ,ids,ide, jds,jde, kds,kde                       &
+                  ,ims,ime, jms,jme, kms,kme                       &
+                  ,its,ite, jts,jte, kts,kte                       &
+                  ,snow,snowncv                                    &
+                                                                   )
+
+#else
+
+      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
+
+         !  Sending array starting locations of optional variables may cause
+         !  troubles, so we explicitly change the call.
+
+         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,snowncv                                  &
+                                                                   )
+
+         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
+#endif
+#else
+      CALL get_wsm5_gpu_levels ( mkx_test )
+      IF ( mkx_test .LT. kte ) THEN
+        WRITE(emess,*)'Number of levels compiled for GPU WSM5 too small. ',      &
+                      mkx_test,' < ',kte
+        CALL wrf_error_fatal(emess)
+      ENDIF
+      CALL wsm5_host (                                                           &
+                    th(its:ite,kts:kte,jts:jte), pii(its:ite,kts:kte,jts:jte)    &
+                   ,q(its:ite,kts:kte,jts:jte), qc(its:ite,kts:kte,jts:jte)      &
+                   ,qi(its:ite,kts:kte,jts:jte), qr(its:ite,kts:kte,jts:jte)     &
+                   ,qs(its:ite,kts:kte,jts:jte), den(its:ite,kts:kte,jts:jte)    &
+                   ,p(its:ite,kts:kte,jts:jte), delz(its:ite,kts:kte,jts:jte)    &
+                   ,delt                                                         &
+                   ,rain(its:ite,jts:jte),rainncv(its:ite,jts:jte)               &
+                   ,snow(its:ite,jts:jte),snowncv(its:ite,jts:jte)               &
+                   ,sr(its:ite,jts:jte)                                          &
+                   ,its, ite,  jts, jte,  kts, kte                               &
+                   ,its, ite,  jts, jte,  kts, kte                               &
+                   ,its, ite,  jts, jte,  kts, kte                               &
+          )
+#endif
+
+
+#ifdef _ACCEL_PROF
+  call cpu_time(t2)
+#ifdef _OPENMP
+  l = omp_get_thread_num() + 1
+#else
+  l = 1
+#endif
+  wsm5_t(1,l) = wsm5_t(1,l) + (t2 - t1)
+#endif
+
+  END SUBROUTINE wsm5
+
+
+#ifdef _ACCEL
+
+!===================================================================
+!
+  SUBROUTINE wsm52D(th, pii, q, qc, qr, qi, qqs, den, p, delz     &
+                   ,delt,g, cpd, cpv, rd, rv, t0c                 &
+                   ,ep1, ep2, qmin                                &
+                   ,XLS, XLV0, XLF0, den0, denr                   &
+                   ,cliq,cice,psat                                &
+                   ,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
+  REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
+        INTENT(INOUT) ::                                          &
+                                                              th
+  REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
+        INTENT(IN) ::                                             &
+                                                             pii
+  REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),                  &
+        INTENT(INOUT) ::                                          &
+                                                              qc, &
+                                                              qr, &
+                                                              qi, &
+                                                             qqs
+  REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),                  &
+        INTENT(INOUT) ::                                          &
+                                                               q
+  REAL, DIMENSION( ims:ime , kms:kme, jms:jme ),                  &
+        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, 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 , 2) ::                      &
+                                                              rh, &
+                                                              qs, &
+                                                          rslope, &
+                                                         rslope2, &
+                                                         rslope3, &
+                                                         rslopeb, &
+                                                            falk, &
+                                                            fall, &
+                                                           work1
+  REAL, DIMENSION( its:ite , kts:kte, jts:jte ) ::                &
+                                                               t
+  REAL, DIMENSION( its:ite , kts:kte , 2 ) ::                     &
+                                                             qci, &
+                                                             qrs
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+                                                           falkc, &
+                                                           fallc, &
+                                                              xl, &
+                                                             cpm, &
+                                                          denfac, &
+                                                             xni, &
+                                                          n0sfac, &
+                                                           work2, &
+                                                          work1c, &
+                                                          work2c
+
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+                                                           pigen, &
+                                                           pidep, &
+                                                           psdep, &
+                                                           praut, &
+                                                           psaut, &
+                                                           prevp, &
+                                                           psevp, &
+                                                           pracw, &
+                                                           psacw, &
+                                                           psaci, &
+                                                           pcond, &
+                                                           psmlt
+  INTEGER ::                                                      &
+                                                           mstep, &
+                                                           numdt
+  REAL ::                                                 rmstep
+  REAL dtcldden, rdelz, rdtcld
+  LOGICAL ::                                              flgcld
+
+#define WSM_NO_CONDITIONAL_IN_VECTOR
+#ifdef WSM_NO_CONDITIONAL_IN_VECTOR
+  REAL ::                     xal, xbl
+#endif
+
+  REAL  ::  pi,                                                   &
+            cpmcal, xlcal, lamdar, lamdas, diffus,                &
+            viscos, xka, venfac, conden, diffac,                  &
+            x, y, z, a, b, c, d, e,                               &
+            qdt, holdrr, holdrs, supcol, supcolt, 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,  holdc, holdci
+! variables for optimization
+  REAL, DIMENSION( its:ite )           ::                    tvec1
+  REAL ::                                                    temp 
+  INTEGER :: i, j, k,                                             &
+            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
+  REAL  :: logtr
+!
+!=================================================================
+!   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
+!
+
+!
+! Moved outside of accelerator region
+!
+      loops = max(nint(delt/dtcldcr),1)
+      dtcld = delt/loops
+      if(delt.le.dtcldcr) dtcld = delt
+!
+
+!....!$acc        local(t) &
+
+      IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN
+
+!$acc region &
+!$acc        local(t) &
+!$acc        copyin(delz(:,:,:),p(:,:,:),den(:,:,:),pii(:,:,:)) &
+!$acc        copyout(snowncv(:,:),rainncv(:,:),sr(:,:)) &
+!$acc        copy(qqs(:,:,:),qr(:,:,:),qi(:,:,:),qc(:,:,:)) &
+!$acc        copy(th(:,:,:),q(:,:,:),snow(:,:),rain(:,:))
+!$acc do &
+!$acc        private(rh,qs,rslope,rslope2,rslope3,rslopeb,falk,fall) &
+!$acc        private(work1,qci,qrs,falkc,fallc,xl,cpm,denfac,xni) &
+!$acc        private(n0sfac,work2,work1c,work2c,pigen,pidep,psdep) &
+!$acc        private(praut,psaut,prevp,psevp) &
+!$acc        private(pracw,psacw,psaci,pcond,psmlt) &
+!$acc        parallel
+      do j = jts, jte
+!$acc do &
+!$acc        private(numdt,mstep) &
+!$acc        kernel vector
+        do i = its, ite
+        do k = kts, kte
+          t(i,k,j)=th(i,k,j)*pii(i,k,j)
+          qci(i,k,1) = max(qc(i,k,j),0.0)
+          qci(i,k,2) = max(qi(i,k,j),0.0)
+          qrs(i,k,1) = max(qr(i,k,j),0.0)
+          qrs(i,k,2) = max(qqs(i,k,j),0.0)
+        enddo
+!
+!----------------------------------------------------------------
+!     latent heat for phase changes and heat capacity. neglect the
+!     changes during microphysical process calculation
+!     emanuel(1994)
+!
+      do k = kts, kte
+          cpm(i,k) = cpmcal(q(i,k,j))
+          xl(i,k) = xlcal(t(i,k,j))
+      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
+!
+        mstep = 1
+        flgcld = .true.
+!
+      do k = kts, kte
+          denfac(i,k) = sqrt(den0/den(i,k,j))
+      enddo
+!     do k = kts, kte
+!       CALL VREC( tvec1(its), den(its,k,j), 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,j),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c)
+!         qs(i,k,2) = fpvs(t(i,k,j),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)
+
+! this is for compilers where the conditional inhibits vectorization
+#ifdef WSM_NO_CONDITIONAL_IN_VECTOR
+      do k = kts, kte
+          if(t(i,k,j).lt.ttp) then
+            xal = xai
+            xbl = xbi
+          else
+            xal = xa
+            xbl = xb
+          endif
+          tr=ttp/t(i,k,j)
+          logtr=log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k,j) - qs(i,k,1))
+          qs(i,k,1) = max(qs(i,k,1),qmin)
+          rh(i,k,1) = max(q(i,k,j) / qs(i,k,1),qmin)
+          qs(i,k,2)=psat*exp(logtr*(xal)+xbl*(1.-tr))
+          qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k,j) - qs(i,k,2))
+          qs(i,k,2) = max(qs(i,k,2),qmin)
+          rh(i,k,2) = max(q(i,k,j) / qs(i,k,2),qmin)
+      enddo
+#else
+      do k = kts, kte
+          tr=ttp/t(i,k,j)
+          logtr=log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k,j) - qs(i,k,1))
+          qs(i,k,1) = max(qs(i,k,1),qmin)
+          rh(i,k,1) = max(q(i,k,j) / qs(i,k,1),qmin)
+          if(t(i,k,j).lt.ttp) then
+            qs(i,k,2)=psat*exp(logtr*(xai)+xbi*(1.-tr))
+          else
+            qs(i,k,2)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          endif
+          qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k,j) - qs(i,k,2))
+          qs(i,k,2) = max(qs(i,k,2),qmin)
+          rh(i,k,2) = max(q(i,k,j) / qs(i,k,2),qmin)
+      enddo
+#endif
+
+!
+!----------------------------------------------------------------
+!     initialize the variables for microphysical physics
+!
+!
+      do k = kts, kte
+          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
+!
+!----------------------------------------------------------------
+!     compute the fallout term:
+!     first, vertical terminal velosity for minor loops
+!
+      do k = kts, kte
+          supcol = t0c-t(i,k,j)
+!---------------------------------------------------------------
+! 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,j))
+            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,j),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,j)                                  &
+!                   *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6)
+          temp = (den(i,k,j)*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
+!
+      numdt = 1
+      do k = kte, kts, -1
+          work1(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)/delz(i,k,j)
+          work1(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)/delz(i,k,j)
+          numdt = max(nint(max(work1(i,k,1),work1(i,k,2))*dtcld+.5),1)
+          if(numdt.ge.mstep) mstep = numdt
+      enddo
+        rmstep = 1./mstep
+!
+      do n = 1, mstep
+        k = kte
+!             falk(i,k,1) = den(i,k,j)*qrs(i,k,1)*work1(i,k,1)/mstep(i)
+!             falk(i,k,2) = den(i,k,j)*qrs(i,k,2)*work1(i,k,2)/mstep(i)
+              falk(i,k,1) = den(i,k,j)*qrs(i,k,1)*work1(i,k,1)*rmstep
+              falk(i,k,2) = den(i,k,j)*qrs(i,k,2)*work1(i,k,2)*rmstep
+              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,j),0.)
+!             qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcld/den(i,k,j),0.)
+              dtcldden = dtcld/den(i,k,j)
+              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
+        do k = kte-1, kts, -1
+              falk(i,k,1) = den(i,k,j)*qrs(i,k,1)*work1(i,k,1)*rmstep
+              falk(i,k,2) = den(i,k,j)*qrs(i,k,2)*work1(i,k,2)*rmstep
+              fall(i,k,1) = fall(i,k,1)+falk(i,k,1)
+              fall(i,k,2) = fall(i,k,2)+falk(i,k,2)
+              dtcldden = dtcld/den(i,k,j)
+              rdelz = 1./delz(i,k,j)
+              qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1)           &
+                          *delz(i,k+1,j)*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,j)*rdelz)*dtcldden,0.)
+        enddo
+        do k = kte, kts, -1
+              if(t(i,k,j).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,j),den(i,k,j))
+                work2(i,k)= (exp(log(((1.496e-6*((t(i,k,j))*sqrt(t(i,k,j)))        &
+                            /((t(i,k,j))+120.)/(den(i,k,j)))/(8.794e-5             &
+                            *exp(log(t(i,k,j))*(1.81))/p(i,k,j))))                 &
+                            *((.3333333)))/sqrt((1.496e-6*((t(i,k,j))            &
+                            *sqrt(t(i,k,j)))/((t(i,k,j))+120.)/(den(i,k,j))))        &
+                            *sqrt(sqrt(den0/(den(i,k,j)))))
+                coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2))
+!               psmlt(i,k) = xka(t(i,k,j),den(i,k,j))/xlf*(t0c-t(i,k,j))*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,j))*sqrt(t(i,k,j)))        &         
+                            /((t(i,k,j))+120.)/(den(i,k,j)) )*(den(i,k,j)))          &
+                            /xlf*(t0c-t(i,k,j))*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,                &
+                            -qrs(i,k,2)/mstep),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,j) = t(i,k,j) + xlf/cpm(i,k)*psmlt(i,k)
+              endif
+        enddo
+      enddo
+
+
+!---------------------------------------------------------------
+! Vice [ms-1] : fallout of ice crystal [HDC 5a]
+!---------------------------------------------------------------
+      mstep = 1
+      numdt = 1
+      do k = kte, kts, -1
+          if(qci(i,k,2).le.0.) then
+            work2c(i,k) = 0.
+          else
+            xmi = den(i,k,j)*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,j)
+          endif
+          numdt = max(nint(work2c(i,k)*dtcld+.5),1)
+          if(numdt.ge.mstep) mstep = numdt
+      enddo
+!
+      do n = 1, mstep
+        k = kte
+            falkc(i,k) = den(i,k,j)*qci(i,k,2)*work2c(i,k)/mstep
+            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,j),0.)
+!         endif
+        do k = kte-1, kts, -1
+              falkc(i,k) = den(i,k,j)*qci(i,k,2)*work2c(i,k)/mstep
+              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,j)/delz(i,k,j))*dtcld/den(i,k,j),0.)
+!           endif
+        enddo
+      enddo
+!
+!
+!----------------------------------------------------------------
+!      rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf
+!
+        fallsum = fall(i,1,1)+fall(i,1,2)+fallc(i,1)
+        fallsum_qsi = fall(i,1,2)+fallc(i,1)
+        rainncv(i,j) = 0.
+        if(fallsum.gt.0.) then
+          rainncv(i,j) = fallsum*delz(i,1,j)/denr*dtcld*1000.
+          rain(i,j) = fallsum*delz(i,1,j)/denr*dtcld*1000. + rain(i,j)
+        endif
+        snowncv(i,j) = 0.
+        if(fallsum_qsi.gt.0.) then
+          snowncv(i,j) = fallsum_qsi*delz(i,kts,j)/denr*dtcld*1000.
+          snow(i,j) = fallsum_qsi*delz(i,kts,j)/denr*dtcld*1000. + snow(i,j)
+        endif
+        sr(i,j) = 0.
+        if(fallsum.gt.0.)sr(i,j)=fallsum_qsi*delz(i,kts,j)/denr*dtcld*1000.        &    
+        /(rainncv(i,j)+1.e-12)
+!
+!---------------------------------------------------------------
+! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28]
+!       (T>T0: I->C)
+!---------------------------------------------------------------
+      do k = kts, kte
+          supcol = t0c-t(i,k,j)
+          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,j) = t(i,k,j) - 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,j) = t(i,k,j) + 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
+            supcolt=min(supcol,50.)
+!           pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.)                         &
+!              *den(i,k,j)/denr/xncr*qci(i,k,1)**2*dtcld,qci(i,k,1))
+            pfrzdtc = min(pfrz1*(exp(pfrz2*supcolt)-1.)                        &
+            *den(i,k,j)/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,j) = t(i,k,j) + xlf/cpm(i,k)*pfrzdtc
+            qci(i,k,1) = qci(i,k,1)-pfrzdtc
+          endif
+!---------------------------------------------------------------
+! psfrz: freezing of rain water [HL A20] [LFO 45]
+!        (T<T0, R->S)
+!---------------------------------------------------------------
+          if(supcol.gt.0..and.qrs(i,k,1).gt.0.) then
+            supcolt=min(supcol,50.)
+!           pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k,j)                    &
+!                 *(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,j)                  &
+                  *(exp(pfrz2*supcolt)-1.)*temp*dtcld,                         &
+                  qrs(i,k,1))
+            qrs(i,k,2) = qrs(i,k,2) + pfrzdtr
+            t(i,k,j) = t(i,k,j) + xlf/cpm(i,k)*pfrzdtr
+            qrs(i,k,1) = qrs(i,k,1)-pfrzdtr
+          endif
+      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
+          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,j))
+            rslope(i,k,1) = 1./(sqrt(sqrt(pidn0r/((qrs(i,k,1))*(den(i,k,j))))))
+            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,j),n0sfac(i,k))
+            rslope(i,k,2) = 1./(sqrt(sqrt(pidn0s*(n0sfac(i,k))/((qrs(i,k,2))   &  
+                          *(den(i,k,j))))))
+            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
+!
+      do k = kts, kte
+!         work1(i,k,1) = diffac(xl(i,k),p(i,k,j),t(i,k,j),den(i,k,j),qs(i,k,1))
+          work1(i,k,1) = ((((den(i,k,j))*(xl(i,k))*(xl(i,k)))*((t(i,k,j))+120.)    &
+                       *(den(i,k,j)))/(1.414e3*(1.496e-6*((t(i,k,j))*sqrt(t(i,k,j))))&
+                       *(den(i,k,j))*(rv*(t(i,k,j))*(t(i,k,j)))))                    &
+                      +  p(i,k,j)/((qs(i,k,1))*(8.794e-5*exp(log(t(i,k,j))*(1.81))))
+!         work1(i,k,2) = diffac(xls,p(i,k,j),t(i,k,j),den(i,k,j),qs(i,k,2))
+          work1(i,k,2) = ((((den(i,k,j))*(xls)*(xls))*((t(i,k,j))+120.)*(den(i,k,j)))&
+                       /(1.414e3*(1.496e-6*((t(i,k,j))*sqrt(t(i,k,j))))*(den(i,k,j)) &
+                       *(rv*(t(i,k,j))*(t(i,k,j))))                                &
+                      + p(i,k,j)/(qs(i,k,2)*(8.794e-5*exp(log(t(i,k,j))*(1.81)))))
+!         work2(i,k) = venfac(p(i,k,j),t(i,k,j),den(i,k,j))
+          work2(i,k) = (exp(.3333333*log(((1.496e-6 * ((t(i,k,j))*sqrt(t(i,k,j)))) &
+                     *p(i,k,j))/(((t(i,k,j))+120.)*den(i,k,j)*(8.794e-5              &
+                     *exp(log(t(i,k,j))*(1.81))))))*sqrt(sqrt(den0/(den(i,k,j))))) &
+                      /sqrt((1.496e-6*((t(i,k,j))*sqrt(t(i,k,j))))                 &
+                      /(((t(i,k,j))+120.)*den(i,k,j)))
+      enddo 
+!
+!===============================================================
+!
+! warm rain processes
+!
+! - follows the processes in RH83 and LFO except for autoconcersion
+!
+!===============================================================
+!
+      do k = kts, kte
+          supsat = max(q(i,k,j),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
+!
+!===============================================================
+!
+! 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
+          supcol = t0c-t(i,k,j)
+          supsat = max(q(i,k,j),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,j)                                  &
+!                      *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6)
+          temp = (den(i,k,j)*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,j)*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]
+!        (T<T0: I->S)
+!-------------------------------------------------------------
+              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
+          endif
+!-------------------------------------------------------------
+! psacw: Accretion of cloud water by snow  [HL A7] [LFO 24]
+!        (T<T0: C->S, 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
+          if(supcol .gt. 0) then
+!-------------------------------------------------------------
+! pidep: Deposition/Sublimation rate of ice [HDC 9]
+!       (T<T0: V->I or I->V)
+!-------------------------------------------------------------
+            if(qci(i,k,2).gt.0.and.ifsat.ne.1) then
+              xmi = den(i,k,j)*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
+!-------------------------------------------------------------
+! 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]
+!       (T<T0: V->I)
+!-------------------------------------------------------------
+            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,j)-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]
+!       (T<T0: I->S)
+!-------------------------------------------------------------
+            if(qci(i,k,2).gt.0.) then
+              qimax = roqimax/den(i,k,j)
+!             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
+!
+!
+!----------------------------------------------------------------
+!     check mass conservation of generation terms and feedback to the
+!     large scale
+!
+      do k = kts, kte
+          if(t(i,k,j).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
+!
+!     rain
+!
+!
+            value = max(qmin,qrs(i,k,1))
+            source = (-praut(i,k)-pracw(i,k)-prevp(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
+              prevp(i,k) = prevp(i,k)*factor
+            endif
+!
+!    snow
+!
+            value = max(qmin,qrs(i,k,2))
+            source = (-psdep(i,k)-psaut(i,k)-psaci(i,k)-psacw(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
+              psaci(i,k) = psaci(i,k)*factor
+              psacw(i,k) = psacw(i,k)*factor
+            endif
+!
+            work2(i,k)=-(prevp(i,k)+psdep(i,k)+pigen(i,k)+pidep(i,k))
+!     update
+            q(i,k,j) = q(i,k,j)+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,j) = t(i,k,j)-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
+!
+!     rain
+!
+            value = max(qmin,qrs(i,k,1))
+            source = (-praut(i,k)-pracw(i,k)-prevp(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
+              prevp(i,k) = prevp(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,j) = q(i,k,j)+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,j) = t(i,k,j)-xlwork2/cpm(i,k)*dtcld
+          endif
+      enddo
+!
+! Inline expansion for fpvs
+!         qs(i,k,1) = fpvs(t(i,k,j),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c)
+!         qs(i,k,2) = fpvs(t(i,k,j),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
+          tr=ttp/t(i,k,j)
+          logtr = log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k,j) - qs(i,k,1))
+          qs(i,k,1) = max(qs(i,k,1),qmin)
+      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
+!         work1(i,k,1) = conden(t(i,k,j),q(i,k,j),qs(i,k,1),xl(i,k),cpm(i,k))
+          work1(i,k,1) = ((max(q(i,k,j),qmin)-(qs(i,k,1)))/(1.+(xl(i,k))         &   
+                        *(xl(i,k))/(rv*(cpm(i,k)))*(qs(i,k,1))                 &
+                        /((t(i,k,j))*(t(i,k,j)))))
+          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,j),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,j) = q(i,k,j)-pcond(i,k)*dtcld
+          qci(i,k,1) = max(qci(i,k,1)+pcond(i,k)*dtcld,0.)
+          t(i,k,j) = t(i,k,j)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld
+      enddo
+!
+!
+!----------------------------------------------------------------
+!     padding for small values
+!
+      do k = kts, kte
+          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                  ! big loops
+
+         DO K=kts,kte
+            th(i,k,j)=t(i,k,j)/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)
+            qqs(i,k,j) = qrs(i,k,2)
+         ENDDO
+
+
+
+      ENDDO     !  i loop
+      enddo     !  j loop
+!$acc end region
+
+    ELSE
+
+!
+! Moved outside of accelerator region
+!
+      loops = max(nint(delt/dtcldcr),1)
+      dtcld = delt/loops
+      if(delt.le.dtcldcr) dtcld = delt
+
+!$acc region &
+!$acc        local(t) &
+!$acc        copyin(delz(:,:,:),p(:,:,:),den(:,:,:),pii(:,:,:)) &
+!$acc        copyout(rainncv(:,:),sr(:,:)) &
+!$acc        copy(qqs(:,:,:),qr(:,:,:),qi(:,:,:),qc(:,:,:)) &
+!$acc        copy(th(:,:,:),q(:,:,:),rain(:,:))
+!$acc do &
+!$acc        private(rh,qs,rslope,rslope2,rslope3,rslopeb,falk,fall) &
+!$acc        private(work1,qci,qrs,falkc,fallc,xl,cpm,denfac,xni) &
+!$acc        private(n0sfac,work2,work1c,work2c,pigen,pidep,psdep) &
+!$acc        private(praut,psaut,prevp,psevp) &
+!$acc        private(pracw,psacw,psaci,pcond,psmlt) &
+!$acc        parallel
+      do j = jts, jte
+!$acc do &
+!$acc        private(numdt,mstep) &
+!$acc        kernel vector
+        do i = its, ite
+        do k = kts, kte
+          t(i,k,j)=th(i,k,j)*pii(i,k,j)
+          qci(i,k,1) = max(qc(i,k,j),0.0)
+          qci(i,k,2) = max(qi(i,k,j),0.0)
+          qrs(i,k,1) = max(qr(i,k,j),0.0)
+          qrs(i,k,2) = max(qqs(i,k,j),0.0)
+        enddo
+!
+!----------------------------------------------------------------
+!     latent heat for phase changes and heat capacity. neglect the
+!     changes during microphysical process calculation
+!     emanuel(1994)
+!
+      do k = kts, kte
+          cpm(i,k) = cpmcal(q(i,k,j))
+          xl(i,k) = xlcal(t(i,k,j))
+      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
+!
+        mstep = 1
+        flgcld = .true.
+!
+      do k = kts, kte
+          denfac(i,k) = sqrt(den0/den(i,k,j))
+      enddo
+!     do k = kts, kte
+!       CALL VREC( tvec1(its), den(its,k,j), 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,j),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c)
+!         qs(i,k,2) = fpvs(t(i,k,j),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)
+
+! this is for compilers where the conditional inhibits vectorization
+#ifdef WSM_NO_CONDITIONAL_IN_VECTOR
+      do k = kts, kte
+          if(t(i,k,j).lt.ttp) then
+            xal = xai
+            xbl = xbi
+          else
+            xal = xa
+            xbl = xb
+          endif
+          tr=ttp/t(i,k,j)
+          logtr=log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k,j) - qs(i,k,1))
+          qs(i,k,1) = max(qs(i,k,1),qmin)
+          rh(i,k,1) = max(q(i,k,j) / qs(i,k,1),qmin)
+          qs(i,k,2)=psat*exp(logtr*(xal)+xbl*(1.-tr))
+          qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k,j) - qs(i,k,2))
+          qs(i,k,2) = max(qs(i,k,2),qmin)
+          rh(i,k,2) = max(q(i,k,j) / qs(i,k,2),qmin)
+      enddo
+#else
+      do k = kts, kte
+          tr=ttp/t(i,k,j)
+          logtr=log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k,j) - qs(i,k,1))
+          qs(i,k,1) = max(qs(i,k,1),qmin)
+          rh(i,k,1) = max(q(i,k,j) / qs(i,k,1),qmin)
+          if(t(i,k,j).lt.ttp) then
+            qs(i,k,2)=psat*exp(logtr*(xai)+xbi*(1.-tr))
+          else
+            qs(i,k,2)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          endif
+          qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k,j) - qs(i,k,2))
+          qs(i,k,2) = max(qs(i,k,2),qmin)
+          rh(i,k,2) = max(q(i,k,j) / qs(i,k,2),qmin)
+      enddo
+#endif
+!
+!----------------------------------------------------------------
+!     initialize the variables for microphysical physics
+!
+!
+      do k = kts, kte
+          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
+!
+!----------------------------------------------------------------
+!     compute the fallout term:
+!     first, vertical terminal velosity for minor loops
+!
+      do k = kts, kte
+          supcol = t0c-t(i,k,j)
+!---------------------------------------------------------------
+! 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,j))
+            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,j),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,j)                                  &
+!                   *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6)
+          temp = (den(i,k,j)*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
+!
+      numdt = 1
+      do k = kte, kts, -1
+          work1(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)/delz(i,k,j)
+          work1(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)/delz(i,k,j)
+          numdt = max(nint(max(work1(i,k,1),work1(i,k,2))*dtcld+.5),1)
+          if(numdt.ge.mstep) mstep = numdt
+      enddo
+        rmstep = 1./mstep
+!
+      do n = 1, mstep
+        k = kte
+!             falk(i,k,1) = den(i,k,j)*qrs(i,k,1)*work1(i,k,1)/mstep(i)
+!             falk(i,k,2) = den(i,k,j)*qrs(i,k,2)*work1(i,k,2)/mstep(i)
+              falk(i,k,1) = den(i,k,j)*qrs(i,k,1)*work1(i,k,1)*rmstep
+              falk(i,k,2) = den(i,k,j)*qrs(i,k,2)*work1(i,k,2)*rmstep
+              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,j),0.)
+!             qrs(i,k,2) = max(qrs(i,k,2)-falk(i,k,2)*dtcld/den(i,k,j),0.)
+              dtcldden = dtcld/den(i,k,j)
+              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
+        do k = kte-1, kts, -1
+              falk(i,k,1) = den(i,k,j)*qrs(i,k,1)*work1(i,k,1)*rmstep
+              falk(i,k,2) = den(i,k,j)*qrs(i,k,2)*work1(i,k,2)*rmstep
+              fall(i,k,1) = fall(i,k,1)+falk(i,k,1)
+              fall(i,k,2) = fall(i,k,2)+falk(i,k,2)
+              dtcldden = dtcld/den(i,k,j)
+              rdelz = 1./delz(i,k,j)
+              qrs(i,k,1) = max(qrs(i,k,1)-(falk(i,k,1)-falk(i,k+1,1)           &
+                          *delz(i,k+1,j)*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,j)*rdelz)*dtcldden,0.)
+        enddo
+        do k = kte, kts, -1
+              if(t(i,k,j).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,j),den(i,k,j))
+                work2(i,k)= (exp(log(((1.496e-6*((t(i,k,j))*sqrt(t(i,k,j)))        &
+                            /((t(i,k,j))+120.)/(den(i,k,j)))/(8.794e-5             &
+                            *exp(log(t(i,k,j))*(1.81))/p(i,k,j))))                 &
+                            *((.3333333)))/sqrt((1.496e-6*((t(i,k,j))            &
+                            *sqrt(t(i,k,j)))/((t(i,k,j))+120.)/(den(i,k,j))))        &
+                            *sqrt(sqrt(den0/(den(i,k,j)))))
+                coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2))
+!               psmlt(i,k) = xka(t(i,k,j),den(i,k,j))/xlf*(t0c-t(i,k,j))*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,j))*sqrt(t(i,k,j)))        &         
+                            /((t(i,k,j))+120.)/(den(i,k,j)) )*(den(i,k,j)))          &
+                            /xlf*(t0c-t(i,k,j))*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,                &
+                            -qrs(i,k,2)/mstep),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,j) = t(i,k,j) + xlf/cpm(i,k)*psmlt(i,k)
+              endif
+        enddo
+      enddo
+!---------------------------------------------------------------
+! Vice [ms-1] : fallout of ice crystal [HDC 5a]
+!---------------------------------------------------------------
+      mstep = 1
+      numdt = 1
+      do k = kte, kts, -1
+          if(qci(i,k,2).le.0.) then
+            work2c(i,k) = 0.
+          else
+            xmi = den(i,k,j)*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,j)
+          endif
+          numdt = max(nint(work2c(i,k)*dtcld+.5),1)
+          if(numdt.ge.mstep) mstep = numdt
+      enddo
+!
+      do n = 1, mstep
+        k = kte
+            falkc(i,k) = den(i,k,j)*qci(i,k,2)*work2c(i,k)/mstep
+            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,j),0.)
+        do k = kte-1, kts, -1
+              falkc(i,k) = den(i,k,j)*qci(i,k,2)*work2c(i,k)/mstep
+              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,j)/delz(i,k,j))*dtcld/den(i,k,j),0.)
+        enddo
+      enddo
+!
+!
+!----------------------------------------------------------------
+!      rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf
+!
+        fallsum = fall(i,1,1)+fall(i,1,2)+fallc(i,1)
+        fallsum_qsi = fall(i,1,2)+fallc(i,1)
+        rainncv(i,j) = 0.
+        if(fallsum.gt.0.) then
+          rainncv(i,j) = fallsum*delz(i,1,j)/denr*dtcld*1000.
+          rain(i,j) = fallsum*delz(i,1,j)/denr*dtcld*1000. + rain(i,j)
+        endif
+        sr(i,j) = 0.
+        if(fallsum.gt.0.)sr(i,j)=fallsum_qsi*delz(i,kts,j)/denr*dtcld*1000.        &    
+        /(rainncv(i,j)+1.e-12)
+!
+!---------------------------------------------------------------
+! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28]
+!       (T>T0: I->C)
+!---------------------------------------------------------------
+      do k = kts, kte
+          supcol = t0c-t(i,k,j)
+          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,j) = t(i,k,j) - 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,j) = t(i,k,j) + 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
+            supcolt=min(supcol,50.)
+!           pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.)                         &
+!              *den(i,k,j)/denr/xncr*qci(i,k,1)**2*dtcld,qci(i,k,1))
+            pfrzdtc = min(pfrz1*(exp(pfrz2*supcolt)-1.)                        &
+            *den(i,k,j)/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,j) = t(i,k,j) + xlf/cpm(i,k)*pfrzdtc
+            qci(i,k,1) = qci(i,k,1)-pfrzdtc
+          endif
+!---------------------------------------------------------------
+! psfrz: freezing of rain water [HL A20] [LFO 45]
+!        (T<T0, R->S)
+!---------------------------------------------------------------
+          if(supcol.gt.0..and.qrs(i,k,1).gt.0.) then
+            supcolt=min(supcol,50.)
+!           pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k,j)                    &
+!                 *(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,j)                  &
+                  *(exp(pfrz2*supcolt)-1.)*temp*dtcld,                         &
+                  qrs(i,k,1))
+            qrs(i,k,2) = qrs(i,k,2) + pfrzdtr
+            t(i,k,j) = t(i,k,j) + xlf/cpm(i,k)*pfrzdtr
+            qrs(i,k,1) = qrs(i,k,1)-pfrzdtr
+          endif
+      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
+          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,j))
+            rslope(i,k,1) = 1./(sqrt(sqrt(pidn0r/((qrs(i,k,1))*(den(i,k,j))))))
+            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,j),n0sfac(i,k))
+            rslope(i,k,2) = 1./(sqrt(sqrt(pidn0s*(n0sfac(i,k))/((qrs(i,k,2))   &  
+                          *(den(i,k,j))))))
+            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
+!
+      do k = kts, kte
+!         work1(i,k,1) = diffac(xl(i,k),p(i,k,j),t(i,k,j),den(i,k,j),qs(i,k,1))
+          work1(i,k,1) = ((((den(i,k,j))*(xl(i,k))*(xl(i,k)))*((t(i,k,j))+120.)    &
+                       *(den(i,k,j)))/(1.414e3*(1.496e-6*((t(i,k,j))*sqrt(t(i,k,j))))&
+                       *(den(i,k,j))*(rv*(t(i,k,j))*(t(i,k,j)))))                    &
+                      +  p(i,k,j)/((qs(i,k,1))*(8.794e-5*exp(log(t(i,k,j))*(1.81))))
+!         work1(i,k,2) = diffac(xls,p(i,k,j),t(i,k,j),den(i,k,j),qs(i,k,2))
+          work1(i,k,2) = ((((den(i,k,j))*(xls)*(xls))*((t(i,k,j))+120.)*(den(i,k,j)))&
+                       /(1.414e3*(1.496e-6*((t(i,k,j))*sqrt(t(i,k,j))))*(den(i,k,j)) &
+                       *(rv*(t(i,k,j))*(t(i,k,j))))                                &
+                      + p(i,k,j)/(qs(i,k,2)*(8.794e-5*exp(log(t(i,k,j))*(1.81)))))
+!         work2(i,k) = venfac(p(i,k,j),t(i,k,j),den(i,k,j))
+          work2(i,k) = (exp(.3333333*log(((1.496e-6 * ((t(i,k,j))*sqrt(t(i,k,j)))) &
+                     *p(i,k,j))/(((t(i,k,j))+120.)*den(i,k,j)*(8.794e-5              &
+                     *exp(log(t(i,k,j))*(1.81))))))*sqrt(sqrt(den0/(den(i,k,j))))) &
+                      /sqrt((1.496e-6*((t(i,k,j))*sqrt(t(i,k,j))))                 &
+                      /(((t(i,k,j))+120.)*den(i,k,j)))
+      enddo 
+!
+!===============================================================
+!
+! warm rain processes
+!
+! - follows the processes in RH83 and LFO except for autoconcersion
+!
+!===============================================================
+!
+      do k = kts, kte
+          supsat = max(q(i,k,j),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
+!
+!===============================================================
+!
+! 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
+          supcol = t0c-t(i,k,j)
+          supsat = max(q(i,k,j),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,j)                                  &
+!                      *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6)
+          temp = (den(i,k,j)*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,j)*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]
+!        (T<T0: I->S)
+!-------------------------------------------------------------
+              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
+          endif
+!-------------------------------------------------------------
+! psacw: Accretion of cloud water by snow  [HL A7] [LFO 24]
+!        (T<T0: C->S, 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
+          if(supcol .gt. 0) then
+!-------------------------------------------------------------
+! pidep: Deposition/Sublimation rate of ice [HDC 9]
+!       (T<T0: V->I or I->V)
+!-------------------------------------------------------------
+            if(qci(i,k,2).gt.0.and.ifsat.ne.1) then
+              xmi = den(i,k,j)*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
+!-------------------------------------------------------------
+! 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]
+!       (T<T0: V->I)
+!-------------------------------------------------------------
+            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,j)-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]
+!       (T<T0: I->S)
+!-------------------------------------------------------------
+            if(qci(i,k,2).gt.0.) then
+              qimax = roqimax/den(i,k,j)
+!             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
+!
+!
+!----------------------------------------------------------------
+!     check mass conservation of generation terms and feedback to the
+!     large scale
+!
+      do k = kts, kte
+          if(t(i,k,j).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
+!
+!     rain
+!
+!
+            value = max(qmin,qrs(i,k,1))
+            source = (-praut(i,k)-pracw(i,k)-prevp(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
+              prevp(i,k) = prevp(i,k)*factor
+            endif
+!
+!    snow
+!
+            value = max(qmin,qrs(i,k,2))
+            source = (-psdep(i,k)-psaut(i,k)-psaci(i,k)-psacw(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
+              psaci(i,k) = psaci(i,k)*factor
+              psacw(i,k) = psacw(i,k)*factor
+            endif
+!
+            work2(i,k)=-(prevp(i,k)+psdep(i,k)+pigen(i,k)+pidep(i,k))
+!     update
+            q(i,k,j) = q(i,k,j)+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,j) = t(i,k,j)-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
+!
+!     rain
+!
+            value = max(qmin,qrs(i,k,1))
+            source = (-praut(i,k)-pracw(i,k)-prevp(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
+              prevp(i,k) = prevp(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,j) = q(i,k,j)+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,j) = t(i,k,j)-xlwork2/cpm(i,k)*dtcld
+          endif
+      enddo
+!
+! Inline expansion for fpvs
+!         qs(i,k,1) = fpvs(t(i,k,j),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c)
+!         qs(i,k,2) = fpvs(t(i,k,j),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
+          tr=ttp/t(i,k,j)
+          logtr = log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+xb*(1.-tr))
+          qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k,j) - qs(i,k,1))
+          qs(i,k,1) = max(qs(i,k,1),qmin)
+      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
+!         work1(i,k,1) = conden(t(i,k,j),q(i,k,j),qs(i,k,1),xl(i,k),cpm(i,k))
+          work1(i,k,1) = ((max(q(i,k,j),qmin)-(qs(i,k,1)))/(1.+(xl(i,k))         &   
+                        *(xl(i,k))/(rv*(cpm(i,k)))*(qs(i,k,1))                 &
+                        /((t(i,k,j))*(t(i,k,j)))))
+          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,j),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,j) = q(i,k,j)-pcond(i,k)*dtcld
+          qci(i,k,1) = max(qci(i,k,1)+pcond(i,k)*dtcld,0.)
+          t(i,k,j) = t(i,k,j)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld
+      enddo
+!
+!
+!----------------------------------------------------------------
+!     padding for small values
+!
+      do k = kts, kte
+          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                  ! big loops
+
+         DO K=kts,kte
+            th(i,k,j)=t(i,k,j)/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)
+            qqs(i,k,j) = qrs(i,k,2)
+         ENDDO
+
+      ENDDO     !  i loop
+      enddo     !  j loop
+!$acc end region
+
+    ENDIF
+
+  END SUBROUTINE wsm52d
+
+
+#else
+
+!===================================================================
+!
+  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, jms:jme ),     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, &
+                                                           fallc, &
+                                                              xl, &
+                                                             cpm, &
+                                                          denfac, &
+                                                             xni, &
+                                                          n0sfac, &
+                                                           work2, &
+                                                          work1c, &
+                                                          work2c
+
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+                                                           pigen, &
+                                                           pidep, &
+                                                           psdep, &
+                                                           praut, &
+                                                           psaut, &
+                                                           prevp, &
+                                                           psevp, &
+                                                           pracw, &
+                                                           psacw, &
+                                                           psaci, &
+                                                           pcond, &
+                                                           psmlt
+  INTEGER, DIMENSION( its:ite ) ::                                &
+                                                           mstep, &
+                                                           numdt
+  REAL, DIMENSION(its:ite) ::                             rmstep
+  REAL dtcldden, rdelz, rdtcld
+  LOGICAL, DIMENSION( its:ite ) ::                        flgcld
+
+#define WSM_NO_CONDITIONAL_IN_VECTOR
+#ifdef WSM_NO_CONDITIONAL_IN_VECTOR
+  REAL, DIMENSION(its:ite) :: xal, xbl
+#endif
+
+  REAL  ::  pi,                                                   &
+            cpmcal, xlcal, lamdar, lamdas, diffus,                &
+            viscos, xka, venfac, conden, diffac,                  &
+            x, y, z, a, b, c, d, e,                               &
+            qdt, holdrr, holdrs, supcol, supcolt, 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,  holdc, holdci
+! variables for optimization
+  REAL, DIMENSION( its:ite )           ::                    tvec1
+  REAL ::                                                    temp 
+  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
+  REAL  :: logtr
+!
+!=================================================================
+!   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)
+
+! this is for compilers where the conditional inhibits vectorization
+#ifdef WSM_NO_CONDITIONAL_IN_VECTOR
+      do k = kts, kte
+        do i = its, ite
+          if(t(i,k).lt.ttp) then
+            xal(i) = xai
+            xbl(i) = xbi
+          else
+            xal(i) = xa
+            xbl(i) = xb
+          endif
+        enddo
+        do i = its, ite
+          tr=ttp/t(i,k)
+          logtr=log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+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)
+          qs(i,k,2)=psat*exp(logtr*(xal(i))+xbl(i)*(1.-tr))
+          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
+#else
+      do k = kts, kte
+        do i = its, ite
+          tr=ttp/t(i,k)
+          logtr=log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+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)
+          if(t(i,k).lt.ttp) then
+            qs(i,k,2)=psat*exp(logtr*(xai)+xbi*(1.-tr))
+          else
+            qs(i,k,2)=psat*exp(logtr*(xa)+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
+#endif
+!
+!----------------------------------------------------------------
+!     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)*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)
+              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,lat) = 0.
+        if(fallsum_qsi.gt.0.) then
+          snowncv(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000.
+          snow(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i,lat)
+        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
+            supcolt=min(supcol,50.)
+!           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*supcolt)-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]
+!        (T<T0, R->S)
+!---------------------------------------------------------------
+          if(supcol.gt.0..and.qrs(i,k,1).gt.0.) then
+            supcolt=min(supcol,50.)
+!           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*supcolt)-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]
+!        (T<T0: I->S)
+!-------------------------------------------------------------
+              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
+          endif
+!-------------------------------------------------------------
+! psacw: Accretion of cloud water by snow  [HL A7] [LFO 24]
+!        (T<T0: C->S, 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
+          if(supcol .gt. 0) then
+!-------------------------------------------------------------
+! pidep: Deposition/Sublimation rate of ice [HDC 9]
+!       (T<T0: V->I 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
+!-------------------------------------------------------------
+! 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]
+!       (T<T0: V->I)
+!-------------------------------------------------------------
+            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]
+!       (T<T0: I->S)
+!-------------------------------------------------------------
+            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
+!
+!     rain
+!
+!
+            value = max(qmin,qrs(i,k,1))
+            source = (-praut(i,k)-pracw(i,k)-prevp(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
+              prevp(i,k) = prevp(i,k)*factor
+            endif
+!
+!    snow
+!
+            value = max(qmin,qrs(i,k,2))
+            source = (-psdep(i,k)-psaut(i,k)-psaci(i,k)-psacw(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
+              psaci(i,k) = psaci(i,k)*factor
+              psacw(i,k) = psacw(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
+!
+!     rain
+!
+            value = max(qmin,qrs(i,k,1))
+            source = (-praut(i,k)-pracw(i,k)-prevp(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
+              prevp(i,k) = prevp(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)
+          logtr = log(tr)
+          qs(i,k,1)=psat*exp(logtr*(xa)+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)
+        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
+
+#endif
+
+! ...................................................................
+      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
+   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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm6.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm6.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_mp_wsm6.F	(revision 17)
@@ -0,0 +1,2218 @@
+#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. ! maximum time step for minor loops
+   REAL, PARAMETER, PRIVATE :: n0r = 8.e6         ! intercept parameter rain
+   REAL, PARAMETER, PRIVATE :: n0g = 4.e6         ! intercept parameter graupel
+   REAL, PARAMETER, PRIVATE :: avtr = 841.9       ! a constant for terminal velocity of rain
+   REAL, PARAMETER, PRIVATE :: bvtr = 0.8         ! a constant for terminal velocity of rain
+   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       ! a constant for terminal velocity of snow
+   REAL, PARAMETER, PRIVATE :: bvts = .41         ! a constant for terminal velocity of snow
+   REAL, PARAMETER, PRIVATE :: avtg = 330.        ! a constant for terminal velocity of graupel
+   REAL, PARAMETER, PRIVATE :: bvtg = 0.8         ! a constant for terminal velocity of graupel
+   REAL, PARAMETER, PRIVATE :: deng = 500.        ! density of graupel
+   REAL, PARAMETER, PRIVATE :: n0smax =  1.e11    ! maximum n0s (t=-90C unlimited)
+   REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4   ! limited maximum value for slope parameter of rain
+   REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5   ! limited maximum value for slope parameter of snow
+   REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4   ! limited maximum value for slope parameter of graupel
+   REAL, PARAMETER, PRIVATE :: dicon = 11.9       ! constant for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: dimax = 500.e-6    ! limited maximum value for the cloud-ice diamter
+   REAL, PARAMETER, PRIVATE :: n0s = 2.e6         ! temperature dependent intercept parameter snow
+   REAL, PARAMETER, PRIVATE :: alpha = .12        ! .122 exponen factor for n0s
+   REAL, PARAMETER, PRIVATE :: pfrz1 = 100.       ! constant in Biggs freezing
+   REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66       ! constant in Biggs freezing
+   REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9     ! minimun values for qr, qs, and qg
+   REAL, PARAMETER, PRIVATE :: eacrc = 1.0        ! Snow/cloud-water collection efficiency
+   REAL, PARAMETER, PRIVATE :: dens  =  100.0     ! Density of snow
+   REAL, PARAMETER, PRIVATE :: qs0   =  6.e-4     ! threshold amount for aggretion to occur
+   REAL, SAVE ::                                      &
+             qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, &
+             g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr,    &
+             bvtr6,g6pbr,                             &
+             precr1,precr2,roqimax,bvts1,             &
+             bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs,     &
+             g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, &
+             pidn0s,xlv1,pacrc,pi,                    &
+             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                                    &
+                 ,sr                                               &
+                 ,graupel, graupelncv                              &
+                 ,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) ::                                          &
+                                                             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
+         !  Sending array starting locations of optional variables may cause
+         !  troubles, so we explicitly change the call.
+         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,snowncv                                  &
+                    ,graupel,graupelncv                            &
+                                                                   )
+         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
+!-------------------------------------------------------------------
+!
+!  This code is a 6-class GRAUPEL phase microphyiscs scheme (WSM6) of the 
+!  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
+!
+!  History :  semi-lagrangian scheme sedimentation(JH), and clean up
+!             Hong, August 2009
+!
+!  Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev.
+!             Hong and Lim (HL, 2006) J. Korean Meteor. Soc.
+!             Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan
+!             Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor.
+!             Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci.
+!             Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci.
+!             Juang and Hong (JH, 2010) Mon. Wea. Rev.
+!
+  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, 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 , 3) ::                      &
+                                                              rh, &
+                                                              qs, &
+                                                          rslope, &
+                                                         rslope2, &
+                                                         rslope3, &
+                                                         rslopeb, &
+                                                         qrs_tmp, & 
+                                                            falk, &
+                                                            fall, &
+                                                           work1
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+                                                           fallc, &
+                                                           falkc, &
+                                                          work1c, &
+                                                          work2c, &
+                                                           workr, &
+                                                           worka
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+                                                         den_tmp, &
+                                                        delz_tmp
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+                                                           pigen, &
+                                                           pidep, &
+                                                           pcond, &
+                                                           prevp, &
+                                                           psevp, &
+                                                           pgevp, &
+                                                           psdep, &
+                                                           pgdep, &
+                                                           praut, &
+                                                           psaut, &
+                                                           pgaut, &
+                                                           piacr, &
+                                                           pracw, &
+                                                           praci, &
+                                                           pracs, &
+                                                           psacw, &
+                                                           psaci, &
+                                                           psacr, &
+                                                           pgacw, &
+                                                           pgaci, &
+                                                           pgacr, &
+                                                           pgacs, &
+                                                           paacw, &
+                                                           psmlt, &
+                                                           pgmlt, &
+                                                           pseml, &
+                                                           pgeml
+  REAL, DIMENSION( its:ite , kts:kte ) ::                         &
+                                                            qsum, &
+                                                              xl, &
+                                                             cpm, &
+                                                           work2, &
+                                                          denfac, &
+                                                             xni, &
+                                                         denqrs1, &
+                                                         denqrs2, &
+                                                         denqrs3, &
+                                                          denqci, & 
+                                                          n0sfac
+  REAL, DIMENSION( its:ite ) ::                          delqrs1, &
+                                                         delqrs2, &
+                                                         delqrs3, &
+                                                           delqi  
+  REAL, DIMENSION( its:ite ) ::                        tstepsnow, &
+                                                      tstepgraup
+  INTEGER, DIMENSION( its:ite ) ::                         mstep, &
+                                                           numdt
+  LOGICAL, DIMENSION( its:ite ) ::                        flgcld
+  REAL  ::                                                        &
+            cpmcal, xlcal, diffus,                                &
+            viscos, xka, venfac, conden, diffac,                  &
+            x, y, z, a, b, c, d, e,                               &
+            qdt, holdrr, holdrs, holdrg, supcol, supcolt, 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  :: vt2ave
+  REAL  :: holdc, holdci
+  INTEGER :: i, j, k, mstepmax,                                   &
+            iprt, latd, lond, loop, loops, ifsat, n, idim, kdim
+! Temporaries used for inlining fpvs function
+  REAL  :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp
+! variables for optimization
+  REAL, DIMENSION( its:ite ) ::                             tvec1
+  REAL                       ::                              temp
+!
+!=================================================================
+!   compute internal functions
+!
+      cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv
+      xlcal(x) = xlv0-xlv1*(x-t0c)
+!----------------------------------------------------------------
+!     diffus: diffusion coefficient of the water vapor
+!     viscos: kinematic viscosity(m2s-1)
+!     Optimizatin : A**B => exp(log(A)*(B))
+!
+      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))
+!
+!
+      idim = ite-its+1
+      kdim = kte-kts+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
+      do k = kts, kte
+        do i = its, ite
+          delz_tmp(i,k) = delz(i,k)
+          den_tmp(i,k) = den(i,k)
+        enddo
+      enddo
+!
+!----------------------------------------------------------------
+!    initialize the surface rain, snow, graupel
+!
+      do i = its, ite
+        rainncv(i) = 0.
+        if(PRESENT (snowncv) .AND. PRESENT (snow)) snowncv(i,lat) = 0.
+        if(PRESENT (graupelncv) .AND. PRESENT (graupel)) graupelncv(i,lat) = 0.
+        sr(i) = 0.
+! new local array to catch step snow and graupel
+        tstepsnow(i) = 0.
+        tstepgraup(i) = 0.
+      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) = min(qs(i,k,1),0.99*p(i,k))
+          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) = min(qs(i,k,2),0.99*p(i,k))
+          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.
+          paacw(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
+!-------------------------------------------------------------
+! Ni: ice crystal number concentraiton   [HDC 5c]
+!-------------------------------------------------------------
+      do k = kts, kte
+        do i = its, ite
+          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
+!
+!----------------------------------------------------------------
+!     compute the fallout term:
+!     first, vertical terminal velosity for minor loops
+!----------------------------------------------------------------
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k,1) = qrs(i,k,1)
+          qrs_tmp(i,k,2) = qrs(i,k,2)
+          qrs_tmp(i,k,3) = qrs(i,k,3)
+        enddo
+      enddo
+      call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & 
+                     work1,its,ite,kts,kte)
+!
+      do k = kte, kts, -1
+        do i = its, ite
+          workr(i,k) = work1(i,k,1)
+          qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15)
+          IF ( qsum(i,k) .gt. 1.e-15 ) THEN
+            worka(i,k) = (work1(i,k,2)*qrs(i,k,2) + work1(i,k,3)*qrs(i,k,3)) &
+                      /qsum(i,k)
+          ELSE
+            worka(i,k) = 0.
+          ENDIF
+          denqrs1(i,k) = den(i,k)*qrs(i,k,1)
+          denqrs2(i,k) = den(i,k)*qrs(i,k,2)
+          denqrs3(i,k) = den(i,k)*qrs(i,k,3)
+          if(qrs(i,k,1).le.0.0) workr(i,k) = 0.0
+        enddo
+      enddo
+      call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,workr,denqrs1,  &
+                           delqrs1,dtcld,1,1)
+      call nislfv_rain_plm6(idim,kdim,den_tmp,denfac,t,delz_tmp,worka,         & 
+                           denqrs2,denqrs3,delqrs2,delqrs3,dtcld,1,1)
+      do k = kts, kte
+        do i = its, ite
+          qrs(i,k,1) = max(denqrs1(i,k)/den(i,k),0.)
+          qrs(i,k,2) = max(denqrs2(i,k)/den(i,k),0.)
+          qrs(i,k,3) = max(denqrs3(i,k)/den(i,k),0.)
+          fall(i,k,1) = denqrs1(i,k)*workr(i,k)/delz(i,k)
+          fall(i,k,2) = denqrs2(i,k)*worka(i,k)/delz(i,k)
+          fall(i,k,3) = denqrs3(i,k)*worka(i,k)/delz(i,k)
+        enddo
+      enddo
+      do i = its, ite
+        fall(i,1,1) = delqrs1(i)/delz(i,1)/dtcld
+        fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld
+        fall(i,1,3) = delqrs3(i)/delz(i,1)/dtcld
+      enddo
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k,1) = qrs(i,k,1)
+          qrs_tmp(i,k,2) = qrs(i,k,2)
+          qrs_tmp(i,k,3) = qrs(i,k,3)
+        enddo
+      enddo
+      call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, &
+                     work1,its,ite,kts,kte)
+!
+      do k = kte, kts, -1 
+        do i = its, ite
+          supcol = t0c-t(i,k)
+          n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.)
+          if(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
+!---------------------------------------------------------------
+! Vice [ms-1] : fallout of ice crystal [HDC 5a]
+!---------------------------------------------------------------
+      do k = kte, kts, -1
+        do i = its, ite
+          if(qci(i,k,2).le.0.) then
+            work1c(i,k) = 0.
+          else
+            xmi = den(i,k)*qci(i,k,2)/xni(i,k)
+            diameter  = max(min(dicon * sqrt(xmi),dimax), 1.e-25)
+            work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31))
+          endif
+        enddo
+      enddo
+!
+!  forward semi-laglangian scheme (JH), PCM (piecewise constant),  (linear)
+!
+      do k = kte, kts, -1
+        do i = its, ite
+          denqci(i,k) = den(i,k)*qci(i,k,2)
+        enddo
+      enddo
+      call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci,  &
+                           delqi,dtcld,1,0)
+      do k = kts, kte
+        do i = its, ite
+          qci(i,k,2) = max(denqci(i,k)/den(i,k),0.)
+        enddo
+      enddo
+      do i = its, ite
+        fallc(i,1) = delqi(i)/delz(i,1)/dtcld
+      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)
+        if(fallsum.gt.0.) then
+          rainncv(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rainncv(i)
+          rain(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rain(i)
+        endif
+        if(fallsum_qsi.gt.0.) then
+          tstepsnow(i)   = fallsum_qsi*delz(i,kts)/denr*dtcld*1000.            &
+                           +tstepsnow(i)
+        IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN
+          snowncv(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000.            & 
+                           +snowncv(i,lat)
+          snow(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i,lat)
+        ENDIF
+        endif
+        if(fallsum_qg.gt.0.) then
+          tstepgraup(i)  = fallsum_qsi*delz(i,kts)/denr*dtcld*1000.            &
+                           +tstepgraup(i)
+        IF ( PRESENT (graupelncv) .AND. PRESENT (graupel)) THEN
+          graupelncv(i,lat) = fallsum_qg*delz(i,kts)/denr*dtcld*1000.          &   
+                              + graupelncv(i,lat)
+          graupel(i,lat) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i,lat)
+        ENDIF
+        endif
+!       if(fallsum.gt.0.)sr(i)=(snowncv(i,lat) + graupelncv(i,lat))/(rainncv(i)+1.e-12)
+        if(fallsum.gt.0.)sr(i)=(tstepsnow(i) + tstepgraup(i))/(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))
+            supcolt=min(supcol,50.)
+            pfrzdtc = min(pfrz1*(exp(pfrz2*supcolt)-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]
+!        (T<T0, R->G)
+!---------------------------------------------------------------
+          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)
+            supcolt=min(supcol,50.)
+            pfrzdtr = min(20.*(pi*pi)*pfrz1*n0r*denr/den(i,k)                  &
+                  *(exp(pfrz2*supcolt)-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
+!
+!
+!----------------------------------------------------------------
+!     update the slope parameters for microphysics computation
+!
+      do k = kts, kte
+        do i = its, ite
+          qrs_tmp(i,k,1) = qrs(i,k,1)
+          qrs_tmp(i,k,2) = qrs(i,k,2)
+          qrs_tmp(i,k,3) = qrs(i,k,3)
+        enddo
+      enddo
+      call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, &
+                     work1,its,ite,kts,kte)
+!------------------------------------------------------------------
+!     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
+          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)
+          n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.)
+          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)
+          qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15)
+          if(qsum(i,k) .gt. 1.e-15) then
+          vt2ave=(vt2s*qrs(i,k,2)+vt2g*qrs(i,k,3))/(qsum(i,k))
+          else
+          vt2ave=0.
+          endif
+          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]
+!        (T<T0: I->R)
+!-------------------------------------------------------------
+              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]
+!        (T<T0: R->S 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]
+!        (T<T0: I->S)
+!-------------------------------------------------------------
+            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(vt2ave-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]
+!        (T<T0: I->G)
+!-------------------------------------------------------------
+            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(vt2ave-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]
+!        (T<T0: C->S, 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]
+!        (T<T0: C->G, 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
+!-------------------------------------------------------------
+! paacw: Accretion of cloud water by averaged snow/graupel 
+!        (T<T0: C->G or S, and T>=T0: C->R) 
+!-------------------------------------------------------------
+          if(qrs(i,k,2).gt.qcrmin.and.qrs(i,k,3).gt.qcrmin) then
+            paacw(i,k) = (qrs(i,k,2)*psacw(i,k)+qrs(i,k,3)*pgacw(i,k))         & 
+                        /(qsum(i,k))
+           endif      
+!-------------------------------------------------------------
+! pracs: Accretion of snow by rain [HL A11] [LFO 27]
+!         (T<T0: S->G)
+!-------------------------------------------------------------
+          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-vt2ave)          &
+                          *(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]
+!         (T<T0:R->S 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(vt2ave-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]
+!         (T<T0: R->G) (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(vt2ave-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): This process is eliminated in V3.0 with the 
+!        new combined snow/graupel fall speeds
+!-------------------------------------------------------------
+          if(qrs(i,k,3).gt.qcrmin.and.qrs(i,k,2).gt.qcrmin) then
+            pgacs(i,k) = 0.
+          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*(paacw(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*(paacw(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]
+!       (T<T0: V->I 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]
+!        (T<T0: 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)
+              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]
+!        (T<T0: V->G 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]
+!       (T<T0: V->I)
+!-------------------------------------------------------------
+            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]
+!        (T<T0: I->S)
+!-------------------------------------------------------------
+            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]
+!        (T<T0: S->G)
+!-------------------------------------------------------------
+            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)+paacw(i,k)+paacw(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
+              paacw(i,k) = paacw(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)+paacw(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
+              paacw(i,k) = paacw(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)+paacw(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
+              paacw(i,k) = paacw(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)                 &
+                           +paacw(i,k)+paacw(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)+paacw(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)+paacw(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)+paacw(i,k)           &
+                      +paacw(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)+paacw(i,k)+paacw(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
+              paacw(i,k) = paacw(i,k)*factor
+            endif
+!
+!     rain
+!
+            value = max(qmin,qrs(i,k,1))
+            source = (-paacw(i,k)-praut(i,k)+pseml(i,k)+pgeml(i,k)-pracw(i,k)  &  
+                     -paacw(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
+              pracw(i,k) = pracw(i,k)*factor
+              paacw(i,k) = paacw(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)                 &
+                    +paacw(i,k)+paacw(i,k))*dtcld,0.)
+            qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k)                 &
+                    +prevp(i,k)+paacw(i,k)+paacw(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) = min(qs(i,k,1),0.99*p(i,k))
+          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) = min(qs(i,k,2),0.99*p(i,k))
+          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
+!
+   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
+   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
+!------------------------------------------------------------------------------
+      subroutine slope_wsm6(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,   &
+                            vt,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte,3) ::                                     &
+                                                                          qrs, &
+                                                                       rslope, &
+                                                                      rslopeb, &                                                 
+                                                                      rslope2, &                                                 
+                                                                      rslope3, &                                                 
+                                                                           vt
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdar, lamdas, lamdag, x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     size distributions: (x=mixing ratio, y=air density):
+!     valid for mixing ratio > 1.e-9 kg/kg.
+      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
+!
+      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
+          vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k)
+          vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k)
+          vt(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k)
+          if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0
+          if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0
+          if(qrs(i,k,3).le.0.0) vt(i,k,3) = 0.0
+        enddo
+      enddo
+  END subroutine slope_wsm6
+!-----------------------------------------------------------------------------
+      subroutine slope_rain(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,   & 
+                            vt,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          qrs, &
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                           vt, &      
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdar, x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     size distributions: (x=mixing ratio, y=air density):
+!     valid for mixing ratio > 1.e-9 kg/kg.
+      lamdar(x,y)=   sqrt(sqrt(pidn0r/(x*y)))      ! (pidn0r/(x*y))**.25
+!
+      do k = kts, kte
+        do i = its, ite
+          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
+            rslope2(i,k) = rslope(i,k)*rslope(i,k)
+            rslope3(i,k) = rslope2(i,k)*rslope(i,k)
+          endif
+          vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k)
+          if(qrs(i,k).le.0.0) vt(i,k) = 0.0
+        enddo
+      enddo
+  END subroutine slope_rain
+!------------------------------------------------------------------------------
+      subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,   &
+                            vt,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          qrs, &
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                           vt, &  
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdas, x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     size distributions: (x=mixing ratio, y=air density):
+!     valid for mixing ratio > 1.e-9 kg/kg.
+      lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y)))    ! (pidn0s*z/(x*y))**.25
+!
+      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).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
+            rslope2(i,k) = rslope(i,k)*rslope(i,k)
+            rslope3(i,k) = rslope2(i,k)*rslope(i,k)
+          endif
+          vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k)
+          if(qrs(i,k).le.0.0) vt(i,k) = 0.0
+        enddo
+      enddo
+  END subroutine slope_snow
+!----------------------------------------------------------------------------------
+      subroutine slope_graup(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,   &
+                            vt,its,ite,kts,kte)
+  IMPLICIT NONE
+  INTEGER       ::               its,ite, jts,jte, kts,kte
+  REAL, DIMENSION( its:ite , kts:kte) ::                                       &
+                                                                          qrs, &
+                                                                       rslope, &
+                                                                      rslopeb, &
+                                                                      rslope2, &
+                                                                      rslope3, &
+                                                                           vt, &  
+                                                                          den, &
+                                                                       denfac, &
+                                                                            t
+  REAL, PARAMETER  :: t0c = 273.15
+  REAL, DIMENSION( its:ite , kts:kte ) ::                                      &
+                                                                       n0sfac
+  REAL       ::  lamdag, x, y, z, supcol
+  integer :: i, j, k
+!----------------------------------------------------------------
+!     size distributions: (x=mixing ratio, y=air density):
+!     valid for mixing ratio > 1.e-9 kg/kg.
+      lamdag(x,y)=   sqrt(sqrt(pidn0g/(x*y)))      ! (pidn0g/(x*y))**.25
+!
+      do k = kts, kte
+        do i = its, ite
+!---------------------------------------------------------------
+! n0s: Intercept parameter for snow [m-4] [HDC 6]
+!---------------------------------------------------------------
+          if(qrs(i,k).le.qcrmin)then
+            rslope(i,k) = rslopegmax
+            rslopeb(i,k) = rslopegbmax
+            rslope2(i,k) = rslopeg2max
+            rslope3(i,k) = rslopeg3max
+          else
+            rslope(i,k) = 1./lamdag(qrs(i,k),den(i,k))
+            rslopeb(i,k) = rslope(i,k)**bvtg
+            rslope2(i,k) = rslope(i,k)*rslope(i,k)
+            rslope3(i,k) = rslope2(i,k)*rslope(i,k)
+          endif
+          vt(i,k) = pvtg*rslopeb(i,k)*denfac(i,k)
+          if(qrs(i,k).le.0.0) vt(i,k) = 0.0
+        enddo
+      enddo
+  END subroutine slope_graup
+!---------------------------------------------------------------------------------
+!-------------------------------------------------------------------
+      SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter)
+!-------------------------------------------------------------------
+!
+! for non-iteration semi-Lagrangain forward advection for cloud
+! with mass conservation and positive definite advection
+! 2nd order interpolation with monotonic piecewise linear method
+! this routine is under assumption of decfl < 1 for semi_Lagrangian
+!
+! dzl    depth of model layer in meter
+! wwl    terminal velocity at model layer m/s
+! rql    cloud density*mixing ration
+! precip precipitation
+! dt     time step
+! id     kind of precip: 0 test case; 1 raindrop
+! iter   how many time to guess mean terminal velocity: 0 pure forward.
+!        0 : use departure wind for advection
+!        1 : use mean wind for advection
+!        > 1 : use mean wind after iter-1 iterations
+!
+! author: hann-ming henry juang <henry.juang@noaa.gov>
+!         implemented by song-you hong
+!
+      implicit none
+      integer  im,km,id
+      real  dt
+      real  dzl(im,km),wwl(im,km),rql(im,km),precip(im)
+      real  denl(im,km),denfacl(im,km),tkl(im,km)
+!
+      integer  i,k,n,m,kk,kb,kt,iter
+      real  tl,tl2,qql,dql,qqd
+      real  th,th2,qqh,dqh
+      real  zsum,qsum,dim,dip,c1,con1,fa1,fa2
+      real  allold, allnew, zz, dzamin, cflmax, decfl
+      real  dz(km), ww(km), qq(km), wd(km), wa(km), was(km)
+      real  den(km), denfac(km), tk(km)
+      real  wi(km+1), zi(km+1), za(km+1)
+      real  qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km)
+      real  dza(km+1), qa(km+1), qmi(km+1), qpi(km+1)
+!
+      precip(:) = 0.0
+!
+      i_loop : do i=1,im
+! -----------------------------------
+      dz(:) = dzl(i,:)
+      qq(:) = rql(i,:)
+      ww(:) = wwl(i,:)
+      den(:) = denl(i,:)
+      denfac(:) = denfacl(i,:)
+      tk(:) = tkl(i,:)
+! skip for no precipitation for all layers
+      allold = 0.0
+      do k=1,km
+        allold = allold + qq(k)
+      enddo
+      if(allold.le.0.0) then
+        cycle i_loop
+      endif
+!
+! compute interface values
+      zi(1)=0.0
+      do k=1,km
+        zi(k+1) = zi(k)+dz(k)
+      enddo
+!
+! save departure wind
+      wd(:) = ww(:)
+      n=1
+ 100  continue
+! plm is 2nd order, we can use 2nd order wi or 3rd order wi
+! 2nd order interpolation to get wi
+      wi(1) = ww(1)
+      wi(km+1) = ww(km)
+      do k=2,km
+        wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k))
+      enddo
+! 3rd order interpolation to get wi
+      fa1 = 9./16.
+      fa2 = 1./16.
+      wi(1) = ww(1)
+      wi(2) = 0.5*(ww(2)+ww(1))
+      do k=3,km-1
+        wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2))
+      enddo
+      wi(km) = 0.5*(ww(km)+ww(km-1))
+      wi(km+1) = ww(km)
+!
+! terminate of top of raingroup
+      do k=2,km
+        if( ww(k).eq.0.0 ) wi(k)=ww(k-1)
+      enddo
+!
+! diffusivity of wi
+      con1 = 0.05
+      do k=km,1,-1
+        decfl = (wi(k+1)-wi(k))*dt/dz(k)
+        if( decfl .gt. con1 ) then
+          wi(k) = wi(k+1) - con1*dz(k)/dt
+        endif
+      enddo
+! compute arrival point
+      do k=1,km+1
+        za(k) = zi(k) - wi(k)*dt
+      enddo
+!
+      do k=1,km
+        dza(k) = za(k+1)-za(k)
+      enddo
+      dza(km+1) = zi(km+1) - za(km+1)
+!
+! computer deformation at arrival point
+      do k=1,km
+        qa(k) = qq(k)*dz(k)/dza(k)
+        qr(k) = qa(k)/den(k)
+      enddo
+      qa(km+1) = 0.0
+!     call maxmin(km,1,qa,' arrival points ')
+!
+! compute arrival terminal velocity, and estimate mean terminal velocity
+! then back to use mean terminal velocity
+      if( n.le.iter ) then
+        call slope_rain(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km)
+        if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km))
+        do k=1,km
+!#ifdef DEBUG
+!        print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k)
+!#endif
+! mean wind is average of departure and new arrival winds
+          ww(k) = 0.5* ( wd(k)+wa(k) )
+        enddo
+        was(:) = wa(:)
+        n=n+1
+        go to 100
+      endif
+!
+! estimate values at arrival cell interface with monotone
+      do k=2,km
+        dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k))
+        dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k))
+        if( dip*dim.le.0.0 ) then
+          qmi(k)=qa(k)
+          qpi(k)=qa(k)
+        else
+          qpi(k)=qa(k)+0.5*(dip+dim)*dza(k)
+          qmi(k)=2.0*qa(k)-qpi(k)
+          if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then
+            qpi(k) = qa(k)
+            qmi(k) = qa(k)
+          endif
+        endif
+      enddo
+      qpi(1)=qa(1)
+      qmi(1)=qa(1)
+      qmi(km+1)=qa(km+1)
+      qpi(km+1)=qa(km+1)
+!
+! interpolation to regular point
+      qn = 0.0
+      kb=1
+      kt=1
+      intp : do k=1,km
+             kb=max(kb-1,1)
+             kt=max(kt-1,1)
+! find kb and kt
+             if( zi(k).ge.za(km+1) ) then
+               exit intp
+             else
+               find_kb : do kk=kb,km
+                         if( zi(k).le.za(kk+1) ) then
+                           kb = kk
+                           exit find_kb
+                         else
+                           cycle find_kb
+                         endif
+               enddo find_kb
+               find_kt : do kk=kt,km
+                         if( zi(k+1).le.za(kk) ) then
+                           kt = kk
+                           exit find_kt
+                         else
+                           cycle find_kt
+                         endif
+               enddo find_kt
+               kt = kt - 1
+! compute q with piecewise constant method
+               if( kt.eq.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 th=(zi(k+1)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 th2=th*th
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qqh=qqd*th2+qmi(kb)*th
+                 qql=qqd*tl2+qmi(kb)*tl
+                 qn(k) = (qqh-qql)/(th-tl)
+               else if( kt.gt.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qql=qqd*tl2+qmi(kb)*tl
+                 dql = qa(kb)-qql
+                 zsum  = (1.-tl)*dza(kb)
+                 qsum  = dql*dza(kb)
+                 if( kt-kb.gt.1 ) then
+                 do m=kb+1,kt-1
+                   zsum = zsum + dza(m)
+                   qsum = qsum + qa(m) * dza(m)
+                 enddo
+                 endif
+                 th=(zi(k+1)-za(kt))/dza(kt)
+                 th2=th*th
+                 qqd=0.5*(qpi(kt)-qmi(kt))
+                 dqh=qqd*th2+qmi(kt)*th
+                 zsum  = zsum + th*dza(kt)
+                 qsum  = qsum + dqh*dza(kt)
+                 qn(k) = qsum/zsum
+               endif
+               cycle intp
+             endif
+!
+       enddo intp
+!
+! rain out
+      sum_precip: do k=1,km
+                    if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*dza(k)
+                      cycle sum_precip
+                    else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*(0.0-za(k))
+                      exit sum_precip
+                    endif
+                    exit sum_precip
+      enddo sum_precip
+!
+! replace the new values
+      rql(i,:) = qn(:)
+!
+! ----------------------------------
+      enddo i_loop
+!
+  END SUBROUTINE nislfv_rain_plm
+!-------------------------------------------------------------------
+      SUBROUTINE nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2, precip1, precip2,dt,id,iter)
+!-------------------------------------------------------------------
+!
+! for non-iteration semi-Lagrangain forward advection for cloud
+! with mass conservation and positive definite advection
+! 2nd order interpolation with monotonic piecewise linear method
+! this routine is under assumption of decfl < 1 for semi_Lagrangian
+!
+! dzl    depth of model layer in meter
+! wwl    terminal velocity at model layer m/s
+! rql    cloud density*mixing ration
+! precip precipitation
+! dt     time step
+! id     kind of precip: 0 test case; 1 raindrop
+! iter   how many time to guess mean terminal velocity: 0 pure forward.
+!        0 : use departure wind for advection
+!        1 : use mean wind for advection
+!        > 1 : use mean wind after iter-1 iterations
+!
+! author: hann-ming henry juang <henry.juang@noaa.gov>
+!         implemented by song-you hong
+!
+      implicit none
+      integer  im,km,id
+      real  dt
+      real  dzl(im,km),wwl(im,km),rql(im,km),rql2(im,km),precip(im),precip1(im),precip2(im)
+      real  denl(im,km),denfacl(im,km),tkl(im,km)
+!
+      integer  i,k,n,m,kk,kb,kt,iter,ist
+      real  tl,tl2,qql,dql,qqd
+      real  th,th2,qqh,dqh
+      real  zsum,qsum,dim,dip,c1,con1,fa1,fa2
+      real  allold, allnew, zz, dzamin, cflmax, decfl
+      real  dz(km), ww(km), qq(km), qq2(km), wd(km), wa(km), wa2(km), was(km)
+      real  den(km), denfac(km), tk(km)
+      real  wi(km+1), zi(km+1), za(km+1)
+      real  qn(km), qr(km),qr2(km),tmp(km),tmp1(km),tmp2(km),tmp3(km)
+      real  dza(km+1), qa(km+1), qa2(km+1),qmi(km+1), qpi(km+1)
+!
+      precip(:) = 0.0
+      precip1(:) = 0.0
+      precip2(:) = 0.0
+!
+      i_loop : do i=1,im
+! -----------------------------------
+      dz(:) = dzl(i,:)
+      qq(:) = rql(i,:)
+      qq2(:) = rql2(i,:)
+      ww(:) = wwl(i,:)
+      den(:) = denl(i,:)
+      denfac(:) = denfacl(i,:)
+      tk(:) = tkl(i,:)
+! skip for no precipitation for all layers
+      allold = 0.0
+      do k=1,km
+        allold = allold + qq(k)
+      enddo
+      if(allold.le.0.0) then
+        cycle i_loop
+      endif
+!
+! compute interface values
+      zi(1)=0.0
+      do k=1,km
+        zi(k+1) = zi(k)+dz(k)
+      enddo
+!
+! save departure wind
+      wd(:) = ww(:)
+      n=1
+ 100  continue
+! plm is 2nd order, we can use 2nd order wi or 3rd order wi
+! 2nd order interpolation to get wi
+      wi(1) = ww(1)
+      wi(km+1) = ww(km)
+      do k=2,km
+        wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k))
+      enddo
+! 3rd order interpolation to get wi
+      fa1 = 9./16.
+      fa2 = 1./16.
+      wi(1) = ww(1)
+      wi(2) = 0.5*(ww(2)+ww(1))
+      do k=3,km-1
+        wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2))
+      enddo
+      wi(km) = 0.5*(ww(km)+ww(km-1))
+      wi(km+1) = ww(km)
+!
+! terminate of top of raingroup
+      do k=2,km
+        if( ww(k).eq.0.0 ) wi(k)=ww(k-1)
+      enddo
+!
+! diffusivity of wi
+      con1 = 0.05
+      do k=km,1,-1
+        decfl = (wi(k+1)-wi(k))*dt/dz(k)
+        if( decfl .gt. con1 ) then
+          wi(k) = wi(k+1) - con1*dz(k)/dt
+        endif
+      enddo
+! compute arrival point
+      do k=1,km+1
+        za(k) = zi(k) - wi(k)*dt
+      enddo
+!
+      do k=1,km
+        dza(k) = za(k+1)-za(k)
+      enddo
+      dza(km+1) = zi(km+1) - za(km+1)
+!
+! computer deformation at arrival point
+      do k=1,km
+        qa(k) = qq(k)*dz(k)/dza(k)
+        qa2(k) = qq2(k)*dz(k)/dza(k)
+        qr(k) = qa(k)/den(k)
+        qr2(k) = qa2(k)/den(k)
+      enddo
+      qa(km+1) = 0.0
+      qa2(km+1) = 0.0
+!     call maxmin(km,1,qa,' arrival points ')
+!
+! compute arrival terminal velocity, and estimate mean terminal velocity
+! then back to use mean terminal velocity
+      if( n.le.iter ) then
+        call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km)
+        call slope_graup(qr2,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa2,1,1,1,km)
+        do k = 1, km
+          tmp(k) = max((qr(k)+qr2(k)), 1.E-15)
+          IF ( tmp(k) .gt. 1.e-15 ) THEN
+            wa(k) = (wa(k)*qr(k) + wa2(k)*qr2(k))/tmp(k)
+          ELSE
+            wa(k) = 0.
+          ENDIF
+        enddo
+        if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km))
+        do k=1,km
+!#ifdef DEBUG
+!        print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k), &
+!           ww(k),wa(k)
+!#endif
+! mean wind is average of departure and new arrival winds
+          ww(k) = 0.5* ( wd(k)+wa(k) )
+        enddo
+        was(:) = wa(:)
+        n=n+1
+        go to 100
+      endif
+      ist_loop : do ist = 1, 2
+      if (ist.eq.2) then
+       qa(:) = qa2(:)
+      endif
+!
+      precip(i) = 0.
+!
+! estimate values at arrival cell interface with monotone
+      do k=2,km
+        dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k))
+        dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k))
+        if( dip*dim.le.0.0 ) then
+          qmi(k)=qa(k)
+          qpi(k)=qa(k)
+        else
+          qpi(k)=qa(k)+0.5*(dip+dim)*dza(k)
+          qmi(k)=2.0*qa(k)-qpi(k)
+          if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then
+            qpi(k) = qa(k)
+            qmi(k) = qa(k)
+          endif
+        endif
+      enddo
+      qpi(1)=qa(1)
+      qmi(1)=qa(1)
+      qmi(km+1)=qa(km+1)
+      qpi(km+1)=qa(km+1)
+!
+! interpolation to regular point
+      qn = 0.0
+      kb=1
+      kt=1
+      intp : do k=1,km
+             kb=max(kb-1,1)
+             kt=max(kt-1,1)
+! find kb and kt
+             if( zi(k).ge.za(km+1) ) then
+               exit intp
+             else
+               find_kb : do kk=kb,km
+                         if( zi(k).le.za(kk+1) ) then
+                           kb = kk
+                           exit find_kb
+                         else
+                           cycle find_kb
+                         endif
+               enddo find_kb
+               find_kt : do kk=kt,km
+                         if( zi(k+1).le.za(kk) ) then
+                           kt = kk
+                           exit find_kt
+                         else
+                           cycle find_kt
+                         endif
+               enddo find_kt
+               kt = kt - 1
+! compute q with piecewise constant method
+               if( kt.eq.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 th=(zi(k+1)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 th2=th*th
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qqh=qqd*th2+qmi(kb)*th
+                 qql=qqd*tl2+qmi(kb)*tl
+                 qn(k) = (qqh-qql)/(th-tl)
+               else if( kt.gt.kb ) then
+                 tl=(zi(k)-za(kb))/dza(kb)
+                 tl2=tl*tl
+                 qqd=0.5*(qpi(kb)-qmi(kb))
+                 qql=qqd*tl2+qmi(kb)*tl
+                 dql = qa(kb)-qql
+                 zsum  = (1.-tl)*dza(kb)
+                 qsum  = dql*dza(kb)
+                 if( kt-kb.gt.1 ) then
+                 do m=kb+1,kt-1
+                   zsum = zsum + dza(m)
+                   qsum = qsum + qa(m) * dza(m)
+                 enddo
+                 endif
+                 th=(zi(k+1)-za(kt))/dza(kt)
+                 th2=th*th
+                 qqd=0.5*(qpi(kt)-qmi(kt))
+                 dqh=qqd*th2+qmi(kt)*th
+                 zsum  = zsum + th*dza(kt)
+                 qsum  = qsum + dqh*dza(kt)
+                 qn(k) = qsum/zsum
+               endif
+               cycle intp
+             endif
+!
+       enddo intp
+!
+! rain out
+      sum_precip: do k=1,km
+                    if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*dza(k)
+                      cycle sum_precip
+                    else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then
+                      precip(i) = precip(i) + qa(k)*(0.0-za(k))
+                      exit sum_precip
+                    endif
+                    exit sum_precip
+      enddo sum_precip
+!
+! replace the new values
+      if(ist.eq.1) then
+        rql(i,:) = qn(:)
+        precip1(i) = precip(i)
+      else
+        rql2(i,:) = qn(:)
+        precip2(i) = precip(i)
+      endif
+      enddo ist_loop
+!
+! ----------------------------------
+      enddo i_loop
+!
+  END SUBROUTINE nislfv_rain_plm6
+END MODULE module_mp_wsm6
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_pbl_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_pbl_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_pbl_driver.F	(revision 17)
@@ -0,0 +1,1693 @@
+!WRF:MEDIATION_LAYER:PHYSICS
+!
+
+MODULE module_pbl_driver
+CONTAINS
+
+!------------------------------------------------------------------
+   SUBROUTINE pbl_driver(                                          &
+                  itimestep,dt,u_frame,v_frame                     &
+                 ,bldt,curr_secs,adapt_step_flag                   &
+                 ,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                    &
+                 ,exch_h,exch_m,akhs,akms                          &
+                 ,thz0,qz0,uz0,vz0,qsfc,f                          &
+                 ,lowlyr,u10,v10,t2                                   &
+                 ,psim,psih,gz1oz0, wspd,br,chklowq                &
+                 ,bl_pbl_physics, ra_lw_physics, dx                &
+                 ,stepbl,warm_rain                                 &
+                 ,kpbl,mixht,ct,lh,snow,xice                       &
+                 ,znu, znw, mut, p_top                             &
+              ! OPTIONAL for TEMF scheme
+                 ,te_temf,km_temf,kh_temf                     &
+                 ,shf_temf,qf_temf,uw_temf,vw_temf                &
+                 ,hd_temf,lcl_temf,hct_temf                       &
+                 ,wupd_temf,mf_temf,thup_temf,qtup_temf,qlup_temf &
+                 ,exch_temf,cf3d_temf,cfm_temf                    &
+                 ,flhc,flqc                                        &
+              ! 
+                 ,qke,tsq,qsq,cov,rmol,ch,qcg,grav_settling        &
+#if (NMM_CORE==1)
+                 ,DISHEAT                                          &
+#endif
+                 ,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 gravity-wave drag             
+                 ,gwd_opt                                          &
+                 ,dtaux3d,dtauy3d                                  &
+                 ,dusfcg,dvsfcg,var2d,oc12d                        &
+                 ,oa1,oa2,oa3,oa4,ol1,ol2,ol3,ol4                  &
+             !  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                                   &
+! variables added for BEP
+               ,frc_urb2d                                  &
+               ,a_u_bep,a_v_bep,a_t_bep,a_q_bep            &
+               ,b_u_bep,b_v_bep,b_t_bep,b_q_bep            &
+               ,sf_bep,vl_bep                              &
+               ,sf_sfclay_physics,sf_urban_physics         &
+               ,tke_pbl,el_pbl                             &
+#if (NMM_CORE != 1)
+               ,wu_tur,wv_tur,wt_tur,wq_tur &
+#endif
+               ,a_e_bep,b_e_bep,dlg_bep                              &
+               ,dl_u_bep                                             &
+! Wind Turbine Parameterizations
+               ,phb,xlat_u,xlong_u,xlat_v,xlong_v,id                 &
+! variables required for camuwpbl scheme
+               , z_at_w,cldfra,rthratenlw,tauresx2d,tauresy2d        &
+               , tpert2d,qpert2d,wpert2d                 &
+                                                                     )       
+!------------------------------------------------------------------
+#if (EM_CORE==1)
+   USE module_state_description, ONLY :                            &
+                   YSUSCHEME,MRFSCHEME,GFSSCHEME,MYJPBLSCHEME,ACMPBLSCHEME,&
+                   QNSEPBLSCHEME,MYNNPBLSCHEME2,MYNNPBLSCHEME3,BOULACSCHEME,&
+                   CAMUWPBLSCHEME,BEPSCHEME,BEP_BEMSCHEME,MYJSFCSCHEME, &
+                   TEMFPBLSCHEME, &
+                   p_qi,param_first_scalar 
+   USE module_wind_generic, ONLY : windspec
+#else
+   USE module_state_description, ONLY :                            &
+                   YSUSCHEME,MRFSCHEME,GFSSCHEME,MYJPBLSCHEME,ACMPBLSCHEME &
+                   , QNSEPBLSCHEME, p_qi,param_first_scalar &
+                   , TEMFPBLSCHEME                          &
+                   , MYJSFCSCHEME
+#endif
+
+   USE module_model_constants
+
+! *** add new modules of schemes here
+
+   USE module_bl_myjpbl
+   USE module_bl_qnsepbl
+   USE module_bl_ysu
+   USE module_bl_mrf
+   USE module_bl_gfs
+   USE module_bl_acm
+   USE module_bl_gwdo
+   USE module_bl_myjurb
+   USE module_bl_boulac
+   USE module_bl_camuwpbl_driver, only:CAMUWPBL
+   USE module_bl_temf
+#if (EM_CORE==1)
+   USE module_bl_mynn
+   USE module_wind_fitch
+#endif
+
+   !  This driver calls subroutines for the PBL parameterizations.
+   !
+   !  pbl scheme:
+   !      1. ysupbl
+   !      2. myjpbl
+   !      4. qnsepbl
+   !      5. mynnpbl2
+   !      6. mynnpbl3
+   !      7. acmpbl
+   !      8. boulacpbl
+   !      9. camuwpbl
+   !      10. temfpbl
+   !      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)
+!-- id            WRF grid id  (optional, only needed by turbine drag schemes)
+!-- 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.)
+!-- akhs          sfc exchange coefficient of heat/moisture from MYJ
+!-- akms          sfc exchange coefficient of momentum from MYJ
+!-- tke_pbl       turbulence kinetic energy from PBL schemes (m^2/s^2)
+!-- el_pbl        length scale from PBL schemes (m)
+!-- wu_tur        turbulent flux of momentum (x) (m^2/s^2)
+!-- wv_tur        turbulent flux of momentum (y) (m^2/s^2)
+!-- wt_tur        turbulent flux of potential temperature  (K m/s)
+!-- wq_tur        turbulent flux of water vapor  (- m/s)
+!-- te_temf       Total energy from TEMF BL scheme
+!-- km_temf       Exchange coefficient for momentum from TEMF BL scheme
+!-- kh_temf       Exchange coefficient for heat from TEMF BL scheme
+!-- shf_temf      Sensible heat flux from TEMF BL scheme
+!-- qf_temf       Water vapor flux from TEMF BL scheme
+!-- uw_temf       Momentum flux in U direction from TEMF BL scheme
+!-- vw_temf       Momentum flux in V direction from TEMF BL scheme
+!-- wupd_temf     Updraft velocity from TEMF BL scheme
+!-- mf_temf       Mass flux from TEMF BL scheme
+!-- thup_temf     Updraft thetal from TEMF BL scheme
+!-- qtup_temf     Updraft qt from TEMF BL scheme
+!-- qlup_temf     Updraft ql from TEMF BL scheme
+!-- cf3d_temf     3D cloud fraction from TEMF PBL
+!-- cfm_temf      Column cloud fraction from TEMF PBL
+!-- exch_temf     Surface exchange coefficient (as for moisture) from TEMF surface layer scheme
+!-- flhc          Surface exchange coefficient for heat (for TEMF)
+!-- flqc          Surface exchange coefficient for moisture (for TEMF)
+!-- 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,sf_sfclay_physics,sf_urban_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
+#if (NMM_CORE==1)
+   LOGICAL,      INTENT(IN   )    ::   DISHEAT ! (for HWRF)
+#endif
+
+   REAL,       DIMENSION( kms:kme ),                              &
+               OPTIONAL, INTENT(IN   )    ::               znu,   &
+                                                           znw
+!
+   REAL,       INTENT(IN   )    ::     DT,DX
+   REAL,       INTENT(IN   ),OPTIONAL    ::     bldt
+   REAL,       INTENT(IN   ),OPTIONAL    ::     curr_secs
+   LOGICAL,    INTENT(IN   ),OPTIONAL    ::     adapt_step_flag
+! Optional for Wind Turbine Parameterizations
+   REAL, DIMENSION( ims:ime, kms:kme ,jms:jme ), &
+         INTENT(IN), OPTIONAL    :: phb
+   REAL, DIMENSION( ims:ime, jms:jme ), &
+         INTENT(IN), OPTIONAL    :: xlat_u,xlong_u,xlat_v,xlong_v
+
+!
+   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                                                             
+!3D Variables for camuwpbl scheme
+    REAL,       DIMENSION( ims:ime, kms:kme, jms:jme ),           &
+               INTENT(IN   ), OPTIONAL    ::              z_at_w, &
+                                                          cldfra, &
+                                                      rthratenlw
+
+!2D Variables required by camuwpbl scheme
+    REAL,       DIMENSION( ims:ime , jms:jme ),                   &
+               INTENT(INOUT   ), OPTIONAL    ::        tauresx2d, &
+                                                       tauresy2d, &
+                                                         tpert2d, &
+                                                         qpert2d, &
+                                                         wpert2d
+!
+!
+   REAL,       DIMENSION( ims:ime , jms:jme ),                    &
+               INTENT(IN   )    ::                         XLAND, &
+                                                              HT, &
+                                                            PSIM, &
+                                                            PSIH, &
+                                                          GZ1OZ0, &
+                                                              BR, &
+                                                               F, &
+                                                         CHKLOWQ
+!
+   REAL,       DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(INOUT)    ::                           TSK, &
+                                                             UST, &
+                                                            PBLH, &
+                                                             HFX, &
+                                                             QFX, &
+                                                             ZNT, &
+                                                            QSFC, &
+                                                            AKHS, &
+                                                            AKMS, &
+                                                           MIXHT, &
+                                                             QZ0, &
+                                                            THZ0, &
+                                                             UZ0, &
+                                                             VZ0, &
+                                                              CT, &
+                                                          GRDFLX, &
+                                                             U10, &
+                                                             V10, &
+                                                              T2, &
+                                                            WSPD
+
+!
+   REAL,       DIMENSION( ims:ime, kms:kme, jms:jme ),            &
+               INTENT(INOUT)    ::                       RUBLTEN, &
+                                                         RVBLTEN, &
+                                                        RTHBLTEN, &
+                                                  EXCH_H,EXCH_M,TKE_PBL
+#if (NMM_CORE != 1)
+ REAL,       DIMENSION( ims:ime, kms:kme, jms:jme ),            &
+               INTENT(OUT)    ::                       WU_TUR,WV_TUR,WT_TUR,WQ_TUR
+!
+#endif
+
+   REAL,       DIMENSION( ims:ime, kms:kme, jms:jme ), &
+        &OPTIONAL, INTENT(INOUT) :: &
+        & qke,tsq,qsq,cov!,k_m,k_h,k_q
+   INTEGER, OPTIONAL :: id
+
+   REAL,    DIMENSION( ims:ime , jms:jme ), &
+        &OPTIONAL, INTENT(IN) ::  &
+        & qcg, rmol, ch
+
+   
+   INTEGER, OPTIONAL, INTENT(IN)  :: grav_settling
+   
+
+
+
+!
+   REAL,       DIMENSION( ims:ime, kms:kme, jms:jme ),            &
+               INTENT(OUT)    ::                          EL_PBL
+
+   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
+
+! Bep changes: variable added for urban
+   real, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) ::FRC_URB2D   ! URBAN Landuse fraction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_u_bep        ! Implicit component for the momemtum in X-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_v_bep        ! Implicit component for the momemtum in Y-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_t_bep        ! Implicit component for the Pot. Temp.
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_q_bep        ! Implicit component for Moisture
+
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_e_bep        ! Implicit component for the TKE
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_u_bep        ! Explicit component for the momemtum in X-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_v_bep        ! Explicit component for the momemtum in Y-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_t_bep        ! Explicit component for the Pot. Temp.
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_q_bep        ! Explicit component for Moisture
+
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_e_bep        ! Explicit component for the TKE
+
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dlg_bep        ! Height above ground (L_ground in formula (24) of the BLM paper). 
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dl_u_bep        ! Length scale (lb in formula (22) ofthe BLM paper).
+! urban surface and volumes        
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::sf_bep           ! surfaces
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::vl_bep            ! volumes
+ 
+! Bep changes end
+!  New variables for TEMF scheme
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            &
+               INTENT(INOUT) :: te_temf
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            &
+               INTENT(  OUT) :: km_temf, kh_temf,        &
+                         shf_temf,qf_temf,uw_temf,vw_temf,        &
+                         wupd_temf,mf_temf,thup_temf,qtup_temf,   &
+                         qlup_temf,cf3d_temf
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),            &
+               INTENT(INOUT) :: flhc,flqc
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),            &
+               INTENT(  OUT) :: hd_temf, lcl_temf, hct_temf, cfm_temf
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),            &
+               INTENT(INOUT) :: exch_temf
+
+!
+!
+! 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
+   REAL,       DIMENSION( ims:ime, jms:jme )                    , &
+               OPTIONAL                                         , &
+               INTENT(IN)    ::                           mut
+!
+   INTEGER,    OPTIONAL, INTENT(IN)    ::               gwd_opt
+   REAL,       OPTIONAL, INTENT(IN)    ::               p_top
+!
+  real,   dimension( ims:ime, kms:kme, jms:jme )                             , &
+          optional                                                           , &
+             intent(inout  )   ::                                     dtaux3d, &
+                                                                      dtauy3d
+!
+  real,   dimension( ims:ime, jms:jme )                                      , &
+          optional                                                           , &
+             intent(inout  )   ::                                      dusfcg, &
+                                                                       dvsfcg
+!
+  real,   dimension( ims:ime, jms:jme )                                      , &
+          optional                                                           , &
+             intent(in  )   ::                                          var2d, &
+                                                                        oc12d, &
+                                                              oa1,oa2,oa3,oa4, &
+                                                              ol1,ol2,ol3,ol4
+
+!  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
+! make these allocatable depending on the setting of idiff
+! Typically, we try to avoide allocating and deallocating local storage like this
+! so as not to fragment the stack. But at this point, the idiff = 1 case is disabled
+! (set to 0 for all cases) and has to be set manually by users who want to work with
+! it.  When it becomes a more standard option, this should be redone, either defining
+! these as state with package clauses to turn them on and off and passing them in,
+! or pass in an integer flag that can be used to dimension the arrays to 1:1:1 as
+! local variables.  JM 20100316
+
+   REAL, ALLOCATABLE, DIMENSION( :, :, : )::a_u        ! Implicit component for the momemtum in X-direction
+   REAL, ALLOCATABLE, DIMENSION( :, :, : )::a_v        ! Implicit component for the momemtum in Y-direction
+   REAL, ALLOCATABLE, DIMENSION( :, :, : )::a_t        ! Implicit component for the Pot. Temp.
+   REAL, ALLOCATABLE, DIMENSION( :, :, : )::a_q        ! Implicit component for the water vapor
+
+   REAL, ALLOCATABLE, DIMENSION( :, :, : )::b_u        ! Explicit component for the momemtum in X-direction
+   REAL, ALLOCATABLE, DIMENSION( :, :, : )::b_v        ! Explicit component for the momemtum in Y-direction
+   REAL, ALLOCATABLE, DIMENSION( :, :, : )::b_t        ! Explicit component for the Pot. Temp.
+   REAL, ALLOCATABLE, DIMENSION( :, :, : )::b_q        ! Explicit component for the water vapor
+
+   REAL, ALLOCATABLE, DIMENSION( :, :, : )::sf         ! surfaces
+   REAL, ALLOCATABLE, DIMENSION( :, :, : )::vl         ! volumes
+
+   REAL    :: DTMIN,DTBL
+!
+
+   INTEGER :: initflag
+!
+
+
+
+   INTEGER :: i,J,K,NK,jj,ij,its,ite,jts,jte
+   LOGICAL :: radiation
+   LOGICAL :: flag_bep
+   LOGICAL :: flag_myjsfc
+   LOGICAL :: flag_qv, flag_qc, flag_qr, flag_qi, flag_qs, flag_qg
+   CHARACTER*256 :: message
+   REAL    :: next_bl_time
+   LOGICAL :: run_param
+   LOGICAL :: do_adapt
+   integer iu_bep,iurb,idiff
+   real seamask,thsk,zzz,unew,vnew,tnew,qnew,umom,vmom
+
+!------------------------------------------------------------------
+!
+!!!!!!!if using BEP set flag_bep to true
+    SELECT CASE(sf_urban_physics)
+#if (NMM_CORE != 1)
+      CASE (BEPSCHEME)
+        flag_bep=.true.
+      CASE (BEP_BEMSCHEME)
+        flag_bep=.true.
+#endif
+      CASE DEFAULT
+        flag_bep=.false.
+    END SELECT
+
+    SELECT CASE(sf_sfclay_physics)
+      CASE (MYJSFCSCHEME)
+         flag_myjsfc=.true.
+      CASE DEFAULT
+         flag_myjsfc=.false.
+    END SELECT
+!
+  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)
+!
+! Modified for adaptive time step
+!
+  IF ( (itimestep .EQ. 1) .OR. (MOD(itimestep,STEPBL) .EQ. 0) ) THEN
+    run_param = .TRUE.
+  ELSE
+    run_param = .FALSE.
+  ENDIF
+
+  IF (PRESENT(adapt_step_flag)) THEN
+    IF ((adapt_step_flag)) THEN
+      IF ( (itimestep .EQ. 1) .OR. (bldt .EQ. 0) .OR. &
+           ( CURR_SECS + dt >= ( INT( CURR_SECS / ( bldt * 60 ) + 1 ) * bldt * 60) ) ) THEN
+        run_param = .TRUE.
+      ELSE
+        run_param = .FALSE.
+      ENDIF
+    ENDIF
+  ENDIF
+
+ IF (run_param) THEN
+  radiation = .false.
+  IF (ra_lw_physics .gt. 0) radiation = .true.
+
+!---- 
+! CALCULATE CONSTANT
+ 
+   DTMIN=DT/60.
+! PBL schemes need PBL time step for updates
+
+    if (PRESENT(adapt_step_flag)) then
+       if (adapt_step_flag) then
+          do_adapt = .TRUE.
+       else
+          do_adapt = .FALSE.
+       endif
+    else
+       do_adapt = .FALSE.
+    endif
+
+   if (PRESENT(BLDT)) then
+      if (bldt .eq. 0) then
+         DTBL = dt
+      ELSE
+         if (do_adapt) then
+            call wrf_message("WARNING: When using an adaptive time-step the boundary layer"// &
+                             " time-step should be 0 (i.e., equivalent to model time-step).  "// &
+                             "In order to proceed, for boundary layer calculations, the "// &
+                             "boundary layer time-step"// &
+                             " will be rounded to the nearest minute, possibly resulting in"// &
+                             " innacurate results.")
+            DTBL=bldt*60
+         else
+            DTBL=DT*STEPBL
+         endif
+      endif
+   else
+      DTBL=DT*STEPBL
+   endif
+
+#if (NMM_CORE != 1)
+!!Alberto. If idiff=1, then compute the tendencies at the end in the routine diff3d
+!!Alberto. If idiff=0, then compute the tendencies in each PBL routine (standard version).
+       idiff=0
+#else
+! Added this else clause so that idiff is always initialized regardless of which core we are using
+       idiff=0
+#endif
+
+   IF ( idiff .EQ. 1 ) THEN
+     ALLOCATE (a_u(ims:ime,kms:kme,jms:jme))       ! Implicit component for the momemtum in X-direction
+     ALLOCATE (a_v(ims:ime,kms:kme,jms:jme))       ! Implicit component for the momemtum in Y-direction
+     ALLOCATE (a_t(ims:ime,kms:kme,jms:jme))       ! Implicit component for the Pot. Temp.
+     ALLOCATE (a_q(ims:ime,kms:kme,jms:jme))       ! Implicit component for the water vapor
+     ALLOCATE (b_u(ims:ime,kms:kme,jms:jme))       ! Explicit component for the momemtum in X-direction
+     ALLOCATE (b_v(ims:ime,kms:kme,jms:jme))       ! Explicit component for the momemtum in Y-direction
+     ALLOCATE (b_t(ims:ime,kms:kme,jms:jme))       ! Explicit component for the Pot. Temp.
+     ALLOCATE (b_q(ims:ime,kms:kme,jms:jme))       ! Explicit component for the water vapor
+     ALLOCATE (sf(ims:ime,kms:kme,jms:jme) )       ! surfaces
+     ALLOCATE (vl(ims:ime,kms:kme,jms:jme) )       ! volumes
+   ENDIF
+
+
+! 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
+
+#if (NMM_CORE != 1)
+      IF ( idiff.eq.1 ) THEN
+!Alberto
+! Here we should put a switch: 
+! if we do not use BEP, just initialize the values of the a, and b to zero, except for the lowest model level, 
+! where the heat and momentum fluxes are introduced         
+! if we use BEP, use the values computed by BEP weigthed by the urban fraction.
+! for the moment I put a simple "if" but it should be changed to a more elegant way after(using the CASE, maybe?)
+!!!!!!!!!!!!!!
+! This is the more general way to go, however some of these variables (e. g. a_t, a_q) may be zero nearly all time. 
+! if we need to be as tight as possible for the memory we can think how to reduce the storage.
+!!!!!!!!!!!!!!!!!!
+! This stuff is becoming large, probably better to put in a subroutine
+!!!!!!!!!!!!!!!!!!!
+! preparing the a, b, sf, and vl terms
+         
+         IF (flag_bep) THEN    
+           do j=j_start(ij),j_end(ij)
+           do i=i_start(ij),i_end(ij)            
+           do k=kts,kte
+             a_u(i,k,j)=a_u_bep(i,k,j)
+             a_v(i,k,j)=a_v_bep(i,k,j)
+             a_t(i,k,j)=a_t_bep(i,k,j)
+             a_q(i,k,j)=a_q_bep(i,k,j)
+             b_u(i,k,j)=b_u_bep(i,k,j)
+             b_v(i,k,j)=b_v_bep(i,k,j)
+             b_t(i,k,j)=b_t_bep(i,k,j)
+             b_q(i,k,j)=b_q_bep(i,k,j)
+             vl(i,k,j)=vl_bep(i,k,j)
+             sf(i,k,j)=sf_bep(i,k,j)
+           enddo
+           sf(i,kte+1,j)=1.
+           enddo
+           enddo
+         ELSE
+           do j=j_start(ij),j_end(ij)
+           do i=i_start(ij),i_end(ij)
+           do k=kts,kte
+             a_u(i,k,j)=0.
+             a_v(i,k,j)=0.
+             a_t(i,k,j)=0.
+             a_q(i,k,j)=0.
+             b_u(i,k,j)=0.
+             b_v(i,k,j)=0.
+             b_t(i,k,j)=0.
+             b_q(i,k,j)=0.
+             vl(i,k,j)=1.
+             sf(i,k,j)=1.
+           enddo
+           sf(i,kte+1,j)=1.
+! fix the values for the surface fluxes (source/sink terms)
+! here for momentum the resolution is done implicitely
+! while for heat and moisture is done explicitely 
+            a_u(i,1,j)=(-ust(I,J)*ust(I,J))/dz8w(i,1,j)/((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)           
+            a_v(i,1,j)=(-ust(I,J)*ust(I,J))/dz8w(i,1,j)/((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)
+            b_t(i,1,j)=hfx(i,j)/rho(i,1,j)/CP/dz8w(i,1,j)
+            b_q(i,1,j)=qfx(i,j)/rho(i,1,j)/dz8w(i,1,j)
+!! if you want to solve also the heat and moisture fluxes implicitely, uncomment the following lines.
+!! (of course you will need the values of thz0,qz0,akhs).
+!             b_t(i,1,j)=akhs(i,j)*(thz0(I,J))/dz8w(i,1,j)
+!             b_q(i,1,j)=akhs(i,j)*(qz0(I,J))/dz8w(i,1,j)
+!             a_t(i,1,j)=-1.*akhs(i,j)/dz8w(i,1,j)
+!             a_q(i,1,j)=-1.*akhs(i,j)/dz8w(i,1,j)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+           enddo
+           enddo
+           
+         ENDIF
+
+        endif      
+                                           
+     
+ 
+!Alberto. From this point if some PBL scheme has a non local term 
+! (not dependent on the local values of the variable)
+! this can be added to b_t, b_q, or b_u, b_v.
+!!!!!!!!!!!!!!!!!!!           
+ 
+#endif 
+      
+   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 (TEMFPBLSCHEME)
+! WA Test
+       ! WRITE( message , * ) 'Calling TEMF PBL scheme, timestep = ', itimestep
+       ! CALL wrf_message ( message )
+       ! print *,'Calling TEMF PBL scheme'
+        CALL wrf_debug(100,'in TEMF PBL')
+           IF ( PRESENT( qv_curr )  .AND. PRESENT( qc_curr )  .AND. &
+                PRESENT( qi_curr )                            .AND. &
+                PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. &
+                PRESENT( rqiblten )                           .AND. &
+                PRESENT( te_temf ) .AND. PRESENT( cfm_temf ) .AND. &
+                PRESENT( hol      ) ) THEN
+             CALL temfpbl(                                              &
+               U3D=u_phytmp,V3D=v_phytmp,TH3D=th_phy,T3D=t_phy      &
+              ,QV3D=qv_curr,QC3D=qc_curr,QI3D=qi_curr               &
+              ,P3D=p_phy,P3DI=p8w,PI3D=pi_phy,RHO=rho               &
+              ,RUBLTEN=rublten,RVBLTEN=rvblten                      &
+              ,RTHBLTEN=rthblten,RQVBLTEN=rqvblten                  &
+              ,RQCBLTEN=rqcblten,RQIBLTEN=rqiblten                  &
+              ,FLAG_QI=flag_qi                                      &
+              ,g=g,cp=cp,rcp=rcp,r_d=r_d,r_v=r_v,cpv=cpv                    &
+              ,Z=z,XLV=XLV,PSFC=PSFC               &
+              ,MUT=mut,P_TOP=p_top                  &
+              ,ZNT=znt,HT=ht,UST=ust,ZOL=zol,HOL=hol,HPBL=pblh      &
+              ,PSIM=psim,PSIH=psih,XLAND=xland                      &
+              ,HFX=hfx,QFX=qfx,TSK=tskold,QSFC=qsfc,GZ1OZ0=gz1oz0   &
+              ,U10=u10,V10=v10,T2=t2                                &
+              ,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                                       &
+              ,te_temf=te_temf,kh_temf=kh_temf,km_temf=km_temf      &
+              ,shf_temf=shf_temf,qf_temf=qf_temf                    &
+              ,uw_temf=uw_temf,vw_temf=vw_temf                      &
+              ,hd_temf=hd_temf,lcl_temf=lcl_temf,hct_temf=hct_temf  &
+              ,wupd_temf=wupd_temf,mf_temf=mf_temf                  &
+              ,thup_temf=thup_temf,qtup_temf=qtup_temf,qlup_temf=qlup_temf  &
+              ,cf3d_temf=cf3d_temf,cfm_temf=cfm_temf                &
+              ,flhc=flhc,flqc=flqc,exch_temf=exch_temf              &
+              ,fCor=f                                            &
+              ,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 TEMF pbl')
+           ENDIF
+
+      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,P3DI=p8w,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,XLV=XLV,RV=r_v,PSFC=PSFC                   &
+              ,ZNU=znu,ZNW=znw,MUT=mut,P_TOP=p_top                  &
+              ,ZNT=znt,UST=ust,HPBL=pblh                            &
+              ,PSIM=psim,PSIH=psih,XLAND=xland                      &
+              ,HFX=hfx,QFX=qfx,GZ1OZ0=gz1oz0                        &
+              ,U10=u10,V10=v10                                      &
+              ,WSPD=wspd,BR=br,DT=dtbl,KPBL2D=kpbl                  &
+              ,EP1=ep_1,EP2=ep_2,KARMAN=karman                      &
+              ,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
+               WRITE ( message , FMT = '(A,7(L1,1X))' )             &
+                 'present: '//                                      &
+                 'qv_curr, '//                                      &
+                 'qc_curr, '//                                      &
+                 'qi_curr, '//                                      &
+                 'rqvblten, '//                                     &
+                 'rqcblten, '//                                     &
+                 'rqiblten, '//                                     &
+                 'hol = ' ,                                         &
+                  PRESENT( qv_curr ) ,                              &
+                  PRESENT( qc_curr ) ,                              &
+                  PRESENT( qi_curr ) ,                              &
+                  PRESENT( rqvblten ) ,                             &
+                  PRESENT( rqcblten ) ,                             &
+                  PRESENT( rqiblten ) ,                             &
+                  PRESENT( hol      )
+               CALL wrf_debug(0,message)
+               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               &
+              ,P1000MB=p1000mb                                      &
+              ,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
+               WRITE ( message , FMT = '(A,5(L1,1X))' )             &
+                 'present: '//                                      &
+                 'qv_curr, '//                                      &
+                 'qc_curr, '//                                      &
+                 'rqvblten, '//                                     &
+                 'rqcblten, '//                                     &
+                 'hol = ' ,                                         &
+                  PRESENT( qv_curr ) ,                              &
+                  PRESENT( qc_curr ) ,                              &
+                  PRESENT( rqvblten ) ,                             &
+                  PRESENT( rqcblten ) ,                             &
+                  PRESENT( hol      )
+               CALL wrf_debug(0,message)
+               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                  &
+              ,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           &
+#if (NMM_CORE==1)
+              ,DISHEAT=DISHEAT                                      &
+#endif
+              ,P_QI=p_qi,P_FIRST_SCALAR=param_first_scalar          &
+              ,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
+               WRITE ( message , FMT = '(A,4(L1,1X))' )             &
+                 'present: '//                                      &
+                 'qv_curr, '//                                      &
+                 'qc_curr, '//                                      &
+                 'rqvblten, '//                                     &
+                 'rqcblten = ',                                     &
+                  PRESENT( qv_curr ) ,                              &
+                  PRESENT( qc_curr ) ,                              &
+                  PRESENT( rqvblten ) ,                             &
+                  PRESENT( rqcblten )
+               CALL wrf_debug(0,message)
+               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')
+            IF ( .not.flag_bep .and. idiff.ne.1) THEN
+             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,QCW=qc_curr,QCI=qi_curr,QCS=qs_curr       & !BSF
+              ,QCR=qr_curr,QCG=qg_curr                              & !BSF
+              ,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_pbl,EXCH_H=exch_h,USTAR=ust,ZNT=znt      &
+              ,EL_MYJ=el_pbl,PBLH=pblh,KPBL=kpbl,CT=ct              &
+              ,AKHS=akhs,AKMS=akms,ELFLX=lh,MIXHT=mixht             &  
+              ,RUBLTEN=rublten,RVBLTEN=rvblten,RTHBLTEN=rthblten    &
+              ,RQVBLTEN=rqvblten,RQCBLTEN=rqcblten                  &
+              ,RQIBLTEN=rqiblten,RQSBLTEN=rqsblten                  & !BSF
+              ,RQRBLTEN=rqrblten,RQGBLTEN=rqgblten                  & !BSF
+              ,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 !(SF_URBAN_PHYSICS.EQ.2)
+! Bep changes begin
+
+             CALL myjurb(IDIFF=idiff,FLAG_BEP=flag_bep              &
+              ,DT=dtbl,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_pbl,EXCH_H=exch_h,EXCH_M=exch_m          &
+              ,USTAR=ust,ZNT=znt                                    &
+              ,EL_MYJ=el_pbl,PBLH=pblh,KPBL=kpbl,CT=ct              &
+              ,AKHS=akhs,AKMS=akms,ELFLX=lh                         &
+              ,RUBLTEN=rublten,RVBLTEN=rvblten,RTHBLTEN=rthblten    &
+              ,RQVBLTEN=rqvblten,RQCBLTEN=rqcblten                  &
+! Multi-layer UCM
+              ,FRC_URB2D=frc_urb2d                                  &
+              ,A_U_BEP=a_u_bep,A_V_BEP=a_v_bep,A_T_BEP=a_t_bep      &
+              ,A_Q_BEP=a_q_bep                                      &
+              ,A_E_BEP=a_e_bep,B_U_BEP=b_u_bep,B_V_BEP=b_v_bep      &
+              ,B_T_BEP=b_t_bep,B_Q_BEP=b_q_bep                      &
+              ,B_E_BEP=b_e_bep,DLG_BEP=dlg_bep                      &
+              ,DL_U_BEP=dl_u_bep,SF_BEP=sf_bep,VL_BEP=vl_bep        &
+! UCM end
+              ,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      &
+                                                                    )
+            ENDIF
+
+           ELSE
+               WRITE ( message , FMT = '(A,4(L1,1X))' )             &
+                 'present: '//                                      &
+                 'qv_curr, '//                                      &
+                 'qc_curr, '//                                      &
+                 'rqvblten, '//                                     &
+                 'rqcblten = ' ,                                    &
+                  PRESENT( qv_curr ) ,                              &
+                  PRESENT( qc_curr ) ,                              &
+                  PRESENT( rqvblten ) ,                             &
+                  PRESENT( rqcblten )
+               CALL wrf_debug(0,message)
+               CALL wrf_error_fatal('Lack arguments to call MYJ pbl')
+           ENDIF
+ 
+      CASE (QNSEPBLSCHEME)
+           IF ( PRESENT( qv_curr )  .AND. PRESENT( qc_curr )  .AND. &
+                PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. &
+                                                        .TRUE.  ) THEN
+             CALL wrf_debug(100,'in QNSEPBL')
+             CALL qnsepbl(                                           &
+               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,CORF=f                       &
+              ,LOWLYR=lowlyr                                        &
+              ,XLAND=xland,SICE=xice,SNOW=snow                      &
+              ,TKE=tke_pbl,EXCH_H=exch_h,EXCH_M=exch_m,USTAR=ust,ZNT=znt      &
+              ,EL_MYJ=el_pbl,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
+               WRITE ( message , FMT = '(A,4(L1,1X))' )             &
+                 'present: '//                                      &
+                 'qv_curr, '//                                      &
+                 'qc_curr, '//                                      &
+                 'rqvblten, '//                                     &
+                 'rqcblten = ' ,                                    &
+                  PRESENT( qv_curr ) ,                              &
+                  PRESENT( qc_curr ) ,                              &
+                  PRESENT( rqvblten ) ,                             &
+                  PRESENT( rqcblten )
+               CALL wrf_debug(0,message)
+               CALL wrf_error_fatal('Lack arguments to call QNSE pbl')
+           ENDIF
+
+      CASE (ACMPBLSCHEME)
+           
+           !!  These are values that are not supplied to pbl driver, but are required by ACM
+           IF ( PRESENT( qv_curr )  .AND. PRESENT( qc_curr )  .AND. &
+                PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. &
+                                                        .TRUE.  ) THEN
+             CALL wrf_debug(100,'in ACM PBL')
+
+             CALL ACMPBL(                                                        &
+               XTIME=itimestep, DTPBL=dtbl, ZNW=znw, SIGMAH=znu               &
+              ,U3D=u_phytmp, V3D=v_phytmp, PP3D=p_phy, DZ8W=dz8w, TH3D=th_phy, T3D=t_phy            &
+              ,QV3D=qv_curr, QC3D=qc_curr, QI3D=qi_curr, RR3D=rho                &
+              ,UST=UST, HFX=HFX, QFX=QFX, TSK=tsk                               &
+              ,PSFC=PSFC, EP1=EP_1, G=g, ROVCP=rcp,RD=r_D,CPD=cp                 &
+              ,PBLH=pblh, KPBL2D=kpbl, REGIME=regime                            &
+              ,GZ1OZ0=gz1oz0,WSPD=wspd,PSIM=psim, MUT=mut                        &
+              ,RUBLTEN=rublten,RVBLTEN=rvblten,RTHBLTEN=rthblten                 &
+              ,RQVBLTEN=rqvblten,RQCBLTEN=rqcblten,RQIBLTEN=rqiblten             &
+              ,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
+               WRITE ( message , FMT = '(A,4(L1,1X))' )             &
+                 'present: '//                                      &
+                 'qv_curr, '//                                      &
+                 'qc_curr, '//                                      &
+                 'rqvblten, '//                                     &
+                 'rqcblten = ' ,                                    &
+                  PRESENT( qv_curr ) ,                              &
+                  PRESENT( qc_curr ) ,                              &
+                  PRESENT( rqvblten ) ,                             &
+                  PRESENT( rqcblten )
+               CALL wrf_debug(0,message)
+               CALL wrf_error_fatal('Lack arguments to call ACM2 pbl')
+           ENDIF
+
+#if (EM_CORE==1)
+
+        CASE (MYNNPBLSCHEME2, MYNNPBLSCHEME3)
+
+           IF ( PRESENT( qv_curr )  .AND. PRESENT( qc_curr )  .AND. &
+                PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. &
+                & PRESENT(qke) .AND. PRESENT(tsq) .AND. &
+                & PRESENT(qsq) .AND. PRESENT(cov) .AND. &
+                & PRESENT(rmol) .AND. &
+                & PRESENT(qcg) .AND. PRESENT(ch) .AND. &
+                & PRESENT(grav_settling) ) THEN
+
+              CALL wrf_debug(100,'in MYNNPBL')
+
+              IF (itimestep==1) THEN
+                 initflag=1
+              ELSE
+                 initflag=0
+              ENDIF
+              
+              CALL  mynn_bl_driver(&
+                   &initflag=initflag,&
+                   &grav_settling=grav_settling,&
+                   &delt=dtbl,&
+                   &dz=dz8w,&
+                   &u=u_phy,v=v_phy,th=th_phy,qv=qv_curr,qc=qc_curr,&
+                   &p=p_phy,exner=pi_phy,rho=rho,&
+                   &xland=xland,ts=tsk,qsfc=qsfc,qcg=qcg,ps=psfc,&
+                   &ust=ust,ch=ch,hfx=hfx,qfx=qfx,rmol=rmol,wspd=wspd,&
+                   &Qke=qke,Tsq=tsq,Qsq=qsq,Cov=cov,&
+                   &Du=rublten,Dv=rvblten,Dth=rthblten,&
+                   &Dqv=rqvblten,Dqc=rqcblten,&
+                   &k_h=exch_h,k_m=exch_m,&
+                   &pblh=pblh&
+                   ,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      &
+                   )
+
+               IF (windspec.GT.0                                         &
+                   .AND.PRESENT(id)                                      &
+                   .AND.PRESENT(phb)                                     &
+                   .AND.PRESENT(xlat_u).AND.PRESENT(xlong_u)             &
+                   .AND.PRESENT(xlat_v).AND.PRESENT(xlong_v)) THEN
+                 CALL turbine_drag(                                         &
+                     & ID=id                                                &
+                     &,PHB=phb,u=u_phy,v=v_phy                              &
+                     &,XLAT_U=xlat_u,XLONG_U=xlong_u                        &
+                     &,XLAT_V=xlat_v,XLONG_V=xlong_v                        &
+                     &,DX=dx,DZ=dz8w,DT=dt                                  &
+                     &,QKE=qke,DU=rublten,DV=rvblten                        &
+                     &,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      &
+                     &)
+               ENDIF
+
+           ELSE
+               WRITE ( message , FMT = '(A,12(L1,1X))' )            &
+                 'present: '//                                      &
+                 'qv_curr, '//                                      &
+                 'qc_curr, '//                                      &
+                 'rqvblten, '//                                     &
+                 'rqcblten, '//                                     &
+                 'qke, '//                                          &
+                 'tsq = '//                                         &
+                 'qsq = '//                                         &
+                 'cov = '//                                         &
+                 'rmol = '//                                        &
+                 'qcg = '//                                         &
+                 'ch = '//                                          &
+                 'grav_settling = ',                                &
+                  PRESENT( qv_curr ) ,                              &
+                  PRESENT( qc_curr ) ,                              &
+                  PRESENT( rqvblten ) ,                             &
+                  PRESENT( rqcblten ) ,                             &
+                  PRESENT( qke      ) ,                             &
+                  PRESENT( tsq      ) ,                             &
+                  PRESENT( qsq      ) ,                             &
+                  PRESENT( cov      ) ,                             &
+                  PRESENT( rmol     ) ,                             &
+                  PRESENT( qcg      ) ,                             &
+                  PRESENT( ch       ) ,                             &
+                  PRESENT( grav_settling)
+               CALL wrf_debug(0,message)
+              CALL wrf_error_fatal('Lack arguments to call MYNN pbl')
+           ENDIF
+
+        CASE (BOULACSCHEME)
+
+             CALL wrf_debug(100,'in boulac')
+
+             CALL BOULAC(FRC_URB2D=frc_urb2d,IDIFF=idiff,FLAG_BEP=flag_bep     &
+              ,DZ8W=dz8w,DT=dt,U_PHY=u_phytmp                                  &
+              ,V_PHY=v_phytmp,TH_PHY=th_phy                                    &
+              ,RHO=rho,QV_CURR=qv_curr,HFX=hfx                                 &
+              ,QFX=qfx,USTAR=ust,CP=cp,G=g                                     &
+              ,RUBLTEN=rublten,RVBLTEN=rvblten,RTHBLTEN=rthblten               &
+              ,RQVBLTEN=rqvblten,RQCBLTEN=rqvblten                             &
+              ,TKE=tke_pbl,DLK=el_pbl,WU=wu_tur,WV=wv_tur,WT=wt_tur,WQ=wq_tur  &
+              ,EXCH_H=exch_h,EXCH_M=exch_m,PBLH=pblh                           &
+              ,A_U_BEP=a_u_bep,A_V_BEP=a_v_bep,A_T_BEP=a_t_bep                 &
+              ,A_Q_BEP=a_q_bep                                                 &
+              ,A_E_BEP=a_e_bep,B_U_BEP=b_u_bep,B_V_BEP=b_v_bep                 &
+              ,B_T_BEP=b_t_bep,B_E_BEP=b_e_bep,DLG_BEP=dlg_bep                 &
+              ,B_Q_BEP=b_q_bep                                                 &
+              ,DL_U_BEP=dl_u_bep,SF_BEP=sf_bep,VL_BEP=vl_bep                   &
+              ,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 (CAMUWPBLSCHEME)
+              
+           IF ( PRESENT( z_at_w )  .AND. PRESENT( tauresx2d )) THEN 
+              CALL wrf_debug(100,'in camuwpbl')
+              
+              CALL CAMUWPBL(DT=dt,U_PHY=u_phy,V_PHY=v_phy,TH_PHY=th_phy,RHO=rho   &
+               ,QV_CURR=qv_curr,HFX=hfx,QFX=qfx,USTAR=ust,RUBLTEN=rublten         &
+               ,RVBLTEN=rvblten,RTHBLTEN=rthblten,RQVBLTEN=rqvblten               &
+               ,RQCBLTEN=rqcblten,TKE_PBL=tke_pbl,PBLH2D=pblh,KPBL2D=kpbl         &
+               ,P8W=p8w,P_PHY=p_phy,Z=z,T_PHY=t_phy,QC_CURR=qc_curr               &
+               ,QI_CURR=qi_curr,Z_AT_W=z_at_w,CLDFRA=cldfra,HT=ht                 &
+               ,RTHRATENLW=rthratenlw,EXNER=pi_phy,ITIMESTEP=itimestep            &
+               ,TAURESX2D=tauresx2d,TAURESY2D=tauresy2d,KVH3D=exch_h,KVM3D=exch_m &
+               ,TPERT2D=tpert2d,QPERT2D=qpert2d,WPERT2D=wpert2d                   & 
+               ,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_debug(0,message)
+               CALL wrf_error_fatal('Lack arguments to call CAMUWPBL pbl')
+           ENDIF
+#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
+
+   IF (PRESENT(dtaux3d)) THEN
+       IF(gwd_opt .EQ. 1)THEN
+             CALL gwdo(                                              &
+               U3D=u_phytmp,V3D=v_phytmp,T3D=t_phy      &
+              ,QV3D=qv_curr                                         &
+              ,P3D=p_phy,P3DI=p8w,PI3D=pi_phy,Z=z                        &
+              ,RUBLTEN=rublten,RVBLTEN=rvblten                      &
+              ,DTAUX3D=dtaux3d,DTAUY3D=dtauy3d                      &
+              ,DUSFCG=dusfcg,DVSFCG=dvsfcg &
+              ,VAR2D=var2d,OC12D=oc12d     &
+              ,OA2D1=oa1,OA2D2=oa2,OA2D3=oa3,OA2D4=oa4  &
+              ,OL2D1=ol1,OL2D2=ol2,OL2D3=ol3,OL2D4=ol4  &
+              ,ZNU=znu,ZNW=znw,MUT=mut,P_TOP=p_top                  &
+              ,CP=cp,G=g,RD=r_d                           &
+              ,RV=r_v,EP1=ep_1,PI=3.141592653                        &
+              ,DT=dtbl,DX=dx,KPBL2D=kpbl,ITIMESTEP=itimestep      &
+              ,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      )
+       ENDIF
+   ENDIF
+
+
+#if (NMM_CORE != 1)
+
+     IF (idiff.eq.1) THEN
+
+!Alberto: here we call the general routine to solve the diffusion
+! + all the source/sink terms.
+! the only thing that should be passed from the PBL schemes is the value of the exch_h, and exch_m 
+! (and the non local terms, if present, through the b).
+! So, this routine can be used by any of the previous schemes. We only need to pass the right variables
+! (and eliminate the computation of the tendencies from the previous routines, to avoid doing twice the job).
+! As I explain below, in the routine, here we could extract the vertical turbulent 
+! fluxes (something that will be general for all the routines).
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    
+            
+          CALL diff3d  (DT=dtbl,CP=cp,DZ=dz8w,TH=th_phy,QV=qv_curr,QC=qc_curr,T=t_phy  &
+              ,U=u_phy,V=v_phy,RHO=rho,EXCH_H=exch_h                  &
+              ,EXCH_M=exch_m                                          &
+              ,RUBLTEN=rublten,RVBLTEN=rvblten,RTHBLTEN=rthblten      &
+             ,RQVBLTEN=rqvblten,RQCBLTEN=rqcblten                    &
+              ,WU=wu_tur,WV=wv_tur,WT=wt_tur,WQ=wq_tur                    &
+              ,A_U=a_u,A_V=a_v,A_T=a_t,A_Q=a_q        &
+              ,B_U=b_u,B_V=b_v,B_T=b_t,B_Q=b_q        &
+              ,SF=sf,VL=vl            &
+              ,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)
+
+          DEALLOCATE (a_u)       ! Implicit component for the momemtum in X-direction
+          DEALLOCATE (a_v)       ! Implicit component for the momemtum in Y-direction
+          DEALLOCATE (a_t)       ! Implicit component for the Pot. Temp.
+          DEALLOCATE (a_q)       ! Implicit component for the water vapor
+          DEALLOCATE (b_u)       ! Explicit component for the momemtum in X-direction
+          DEALLOCATE (b_v)       ! Explicit component for the momemtum in Y-direction
+          DEALLOCATE (b_t)       ! Explicit component for the Pot. Temp.
+          DEALLOCATE (b_q)       ! Explicit component for the water vapor
+          DEALLOCATE (sf )       ! surfaces
+          DEALLOCATE (vl )       ! volumes
+      
+     ENDIF       !idiff
+#endif
+
+   ENDDO
+   !$OMP END PARALLEL DO
+
+   ENDIF
+!
+ 
+
+
+   END SUBROUTINE pbl_driver
+
+!=============================================================================
+          SUBROUTINE diff3d(DT,CP,DZ,TH ,QV,QC,T,U,V,RHO                              &
+              ,EXCH_H,EXCH_M                   &  
+              ,RUBLTEN,RVBLTEN,RTHBLTEN    &
+              ,RQVBLTEN,RQCBLTEN                  &
+              ,WU,WV,WT,WQ                 &
+              ,A_U,A_V,A_T,A_Q      &
+              ,B_U,B_V,B_T,B_Q      &
+              ,SF,VL        &
+              ,IDS,IDE,JDS,JDE,KDS,KDE      &
+              ,IMS,IME,JMS,JME,KMS,KME      &
+              ,ITS,ITE,JTS,JTE,KTS,KTE      &
+                                                                    )
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!    Subroutine written by Alberto Martilli, CIEMAT, Spain,
+!    e-mail:alberto_martilli@ciemat.es
+!    August 2008.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! ALberto
+! This routine solves the vertical diffusion 
+! + other source/sink terms (surface fluxes, building drag, non local terms, etc.)
+! for U,V, potential temperature and moisture. The equation should be written 
+! as follow, for a generic variable M:
+! 
+!      dM      1     d      dM
+!     ---- =----  ---(rho*K----)+AM+B
+!      dt     rho    dz     dz  
+! where A and B are the implict and explcit coefficients of the source/sink terms
+! (at the lowest level the surface fluxes should go in these terms)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!-----------------------------------------------------------------------
+
+      IMPLICIT NONE
+!
+!----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                    &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                    &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE
+
+! INputs
+      real DT,CP
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: DZ ! Depth of vertical levels
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: TH ! Potential Temperature
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: QV ! water vapor mixing ratio (kg/kg)
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: QC ! cloud water mixing ratio (kg/kg)
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: T  ! temperature
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: U ! X-compnent of the wind
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: V ! Y-compnent of the wind
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: RHO ! Air Density
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: EXCH_H ! Turbulent coefficient for heat
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: EXCH_M ! Turbulent coefficient for momentum 
+      
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: A_U ! Implicit coefficient for DRAG (x -component)
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: B_U ! Explicit coefficient for DRAG (x -component)
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: A_V ! Implicit coefficient for DRAG (y -component)
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: B_V ! Explicit coefficient for DRAG (y -component)
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: A_T ! Implicit coefficient for Heat flux from buildings
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: B_T ! Explicit coefficient for Heat flux from buildings
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: A_Q ! Implicit coefficient for moisture flux
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: B_Q ! Explicit coefficient for moisture flux 
+    
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: VL ! fraction of air volume in the grid cell
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: SF ! fraction of air at the face of the grid cell
+!outputs
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: RUBLTEN ! tendency for x-wind component
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: RVBLTEN ! tendency for y-wind component
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: RTHBLTEN ! tendency for Potential Temperature
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: RQVBLTEN ! tendency for water vapor mixing ratio (kg/kg)
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: RQCBLTEN ! tendency for cloud water mixing ratio (kg/kg)
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: WU ! turbulent flux of momentum (x)
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: WV ! turbulent flux of momentum (y)
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: WT ! turbulent flux of potential temperature
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: WQ ! turbulent flux of water vapor
+! Parameters
+     REAL ELOCP 
+! locals (same meaning as above, but 1D)
+
+      real u1d(kms:kme),v1d(kms:kme),exch_h1d(kms:kme)
+      real the1d(kms:kme) ! Equivalent potential temperature
+      real exch_m1d(kms:kme),qv1d(kms:kme),qc1d(kms:kme)
+      real dz1d(kms:kme),rho1d(kms:kme),rhoz1d(kms:kme)
+      real sf1d(kms:kme),vl1d(kms:kme)   
+      real a_u1d(kms:kme),b_u1d(kms:kme)
+      real a_v1d(kms:kme),b_v1d(kms:kme)
+      real a_t1d(kms:kme),b_t1d(kms:kme)
+      real a_q1d(kms:kme),b_q1d(kms:kme)
+      real a_qc1d(kms:kme),b_qc1d(kms:kme)
+      real wu1d(kms:kme),wv1d(kms:kme),wt1d(kms:kme),wq1d(kms:kme),wqc1d(kms:kme)
+      real thnew
+!
+      integer i,k,j  
+!----------------------------------------------------------------------
+      ELOCP=2.72E6/CP
+      u1d=0.
+      v1d=0.
+      exch_h1d=0.
+      exch_m1d=0.
+      qv1d=0.
+      qc1d=0.
+      dz1d=0.
+      rho1d=0.
+      rhoz1d=0.
+      sf1d=0.
+      vl1d=0.
+      a_u1d=0.
+      a_v1d=0.
+      a_t1d=0.
+      a_q1d=0.
+      a_qc1d=0.
+      b_u1d=0.
+      b_v1d=0.
+      b_t1d=0.
+      b_q1d=0.
+      b_qc1d=0.
+       
+      do j=jts,jte
+      do i=its,ite
+
+! put three D variables in temporary 1D variables
+
+       do k=kts,kte
+        u1d(k)=U(i,k,j)
+        v1d(k)=V(i,k,j)
+        the1d(k)=TH(i,k,j)*(QC(i,k,j)*(-ELOCP/T(i,k,j))+1)
+        qv1d(k)=qv(i,k,j)
+        dz1d(k)=dz(i,k,j)
+        rho1d(k)=rho(i,k,j) 
+        a_u1d(k)=a_u(i,k,j)
+        b_u1d(k)=b_u(i,k,j)
+        a_v1d(k)=a_v(i,k,j)
+        b_v1d(k)=b_v(i,k,j)
+        a_t1d(k)=a_t(i,k,j)
+        b_t1d(k)=b_t(i,k,j)
+        a_q1d(k)=a_q(i,k,j)
+        b_q1d(k)=b_q(i,k,j)
+        a_qc1d(k)=0.
+        b_qc1d(k)=0.
+        vl1d(k)=vl(i,k,j)
+        sf1d(k)=sf(i,k,j)
+       enddo
+       sf1d(kte+1)=1. 
+       do k=kts,kte    
+        exch_h1d(k)=exch_h(i,k,j)
+        exch_m1d(k)=exch_m(i,k,j)
+       enddo
+       exch_h1d(kts)=0.
+!       exch_h1d(kte+1)=0  
+       exch_m1d(kts)=0.
+!       exch_m1d(kte+1)=0
+        rhoz1d(kts)=rho1d(kts)
+        do k=kts+1,kte
+         rhoz1d(k)=(rho1d(k)*dz1d(k-1)+rho1d(k-1)*dz1d(k))/       &
+     &                      (dz1d(k-1)+dz1d(k))
+        enddo
+        rhoz1d(kte+1)=rho1d(kte)
+
+
+! solve the diffusion for x-component of the wind   
+          
+       call diff(kms,kme,kts,kte,dt,u1d,rho1d,rhoz1d,exch_m1d,a_u1d,b_u1d,sf1d, &
+     &            vl1d,dz1d,wu1d) 
+
+! solve the diffusion for y-component of the wind              
+
+       call diff(kms,kme,kts,kte,dt,v1d,rho1d,rhoz1d,exch_m1d,a_v1d,b_v1d,sf1d, &
+     &            vl1d,dz1d,wv1d) 
+
+! solve the diffusion for equivalent potential temperature
+
+       call diff(kms,kme,kts,kte,dt,the1d,rho1d,rhoz1d,exch_h1d,a_t1d,b_t1d,sf1d, &
+     &            vl1d,dz1d,wt1d) 
+
+! solve the diffusion for the water vapor mixing ratio
+
+       call diff(kms,kme,kts,kte,dt,qv1d,rho1d,rhoz1d,exch_h1d,a_q1d,b_q1d,sf1d, &
+     &            vl1d,dz1d,wq1d) 
+
+! solve the diffusion for the cloud water mixing ratio
+
+       call diff(kms,kme,kts,kte,dt,qc1d,rho1d,rhoz1d,exch_h1d,a_qc1d,b_qc1d,sf1d, &
+     &            vl1d,dz1d,wqc1d)        
+
+!     
+! compute the tendencies
+
+        do k=kts,kte
+          rublten(i,k,j)=(u1d(k)-u(i,k,j))/dt
+          rvblten(i,k,j)=(v1d(k)-v(i,k,j))/dt
+          thnew=the1d(k)/(QC(i,k,j)*(-ELOCP/T(i,k,j))+1)
+          rthblten(i,k,j)=(thnew-th(i,k,j))/dt
+          rqvblten(i,k,j)=(qv1d(k)-qv(i,k,j))/dt
+          rqcblten(i,k,j)=(qc1d(k)-qc(i,k,j))/dt
+          wu(i,k,j)=wu1d(k)
+          wv(i,k,j)=wv1d(k)
+          wt(i,k,j)=wt1d(k)
+          wq(i,k,j)=wq1d(k)
+        enddo
+      enddo
+      enddo 
+!!!!!!!!!!!!
+
+        
+      END SUBROUTINE diff3d
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+       subroutine diff(kms,kme,kts,kte,dt,co,da,daz,cd,aa,bb,sf,vl,dz,fc)
+
+!------------------------------------------------------------------------
+!           Calculation of the diffusion in 1D
+!------------------------------------------------------------------------
+!  - Input:
+!       nz    : number of points
+!       iz1   : first calculated point
+!       co    : concentration of the variable of interest
+!       dz    : vertical levels
+!       cd    : diffusion coefficients
+!       da    : density of the air at the center
+!       daz   : density of the air at the face
+!       dt    : diffusion time step
+!  - Output:
+!       co :concentration of the variable of interest
+
+!  - Internal:
+!       cddz  : constant terms in the equations
+!---------------------------------------------------------------------
+
+        implicit none
+        integer iz,iz1,izf
+        integer kms,kme,kts,kte
+        real dt,dzv
+        real co(kms:kme),cd(kms:kme),dz(kms:kme)
+        real da(kms:kme),daz(kms:kme)
+        real cddz(kms:kme),fc(kms:kme),df(kms:kme)
+        real a(kms:kme,3),c(kms:kme)
+        real sf(kms:kme),vl(kms:kme)
+        real aa(kms:kme),bb(kms:kme)
+
+        
+! Compute cddz=2*cd/dz
+
+        cddz(kts)=sf(kts)*daz(kts)*cd(kts)/dz(kts)
+        do iz=kts+1,kte
+         cddz(iz)=2.*sf(iz)*daz(iz)*cd(iz)/(dz(iz)+dz(iz-1))
+        enddo
+        cddz(kte+1)=sf(kte+1)*daz(kte+1)*cd(kte+1)/dz(kte)
+
+          iz1=1
+          izf=1
+
+          do iz=iz1,kte-1
+
+           dzv=vl(iz)*dz(iz)
+           a(iz,1)=-cddz(iz)*dt/dzv/da(iz)
+           a(iz,2)=1+dt*(cddz(iz)+cddz(iz+1))/dzv/da(iz)-aa(iz)*dt
+           a(iz,3)=-cddz(iz+1)*dt/dzv/da(iz)
+           c(iz)=co(iz)+bb(iz)*dt
+          enddo
+
+          do iz=kte-(izf-1),kte
+           a(iz,1)=0.
+           a(iz,2)=1
+           a(iz,3)=0.
+           c(iz)=co(iz)
+          enddo
+          call invert (kms,kme,kts,kte,a,c,co)
+           
+!let compute the fluxes, as diagnostic variable
+
+          do iz=kts,iz1
+           fc(iz)=0.
+          enddo
+
+          do iz=iz1+1,kte
+           fc(iz)=-(cddz(iz)*(co(iz)-co(iz-1)))/da(iz)
+          enddo
+
+
+
+       return
+       end subroutine diff
+! ===6=8===============================================================72
+
+       subroutine invert(kms,kme,kts,kte,a,c,x)
+
+!ccccccccccccccccccccccccccccccc
+! Aim: Inversion and resolution of a tridiagonal matrix
+!          A X = C
+! Input:
+!  a(*,1) lower diagonal (Ai,i-1)
+!  a(*,2) principal diagonal (Ai,i)
+!  a(*,3) upper diagonal (Ai,i+1)
+!  c
+! Output
+!  x     results
+!ccccccccccccccccccccccccccccccc
+
+       implicit none
+       integer kms,kme,kts,kte,in
+       real a(kms:kme,3),c(kms:kme),x(kms:kme)
+
+        do in=kte-1,kts,-1
+         c(in)=c(in)-a(in,3)*c(in+1)/a(in+1,2)
+         a(in,2)=a(in,2)-a(in,3)*a(in+1,1)/a(in+1,2)
+        enddo
+
+        do in=kts+1,kte
+         c(in)=c(in)-a(in,1)*c(in-1)/a(in-1,2)
+        enddo
+
+        do in=kts,kte
+         x(in)=c(in)/a(in,2)
+        enddo
+
+        return
+        end subroutine invert
+
+! ===6=8===============================================================72
+
+
+
+
+
+
+
+
+
+
+
+
+
+END MODULE module_pbl_driver
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_physics_addtendc.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_physics_addtendc.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_physics_addtendc.F	(revision 17)
@@ -0,0 +1,2022 @@
+!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(rph_tendf,rt_tendf,ru_tendf,rv_tendf,moist_tendf, &
+                      scalar_tendf,mu_tendf,                                &
+                      RTHRATEN,RTHBLTEN,RTHCUTEN,RTHSHTEN,                  &
+                      RUBLTEN,RUCUTEN,RUSHTEN,                              &
+                      RVBLTEN,RVCUTEN,RVSHTEN,                              &
+                      RQVBLTEN,RQCBLTEN,RQIBLTEN,                           &
+                      RQVCUTEN,RQCCUTEN,RQRCUTEN,RQICUTEN,RQSCUTEN,         &
+                      RQVSHTEN,RQCSHTEN,RQRSHTEN,RQISHTEN,RQSSHTEN,RQGSHTEN,&
+                      RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RPHNDGDTEN,            &
+                      RQVNDGDTEN,RMUNDGDTEN,                                &
+                      rthfrten,rqvfrten,                                    & !fire
+                      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, &
+                                                         rph_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, &
+                                                       RTHSHTEN, &
+                                                        RUBLTEN, &
+                                                        RUCUTEN, &
+                                                        RUSHTEN, &
+                                                        RVBLTEN, &
+                                                        RVCUTEN, &
+                                                        RVSHTEN, &
+                                                       RQVBLTEN, &
+                                                       RQCBLTEN, &
+                                                       RQIBLTEN, &
+                                                       RQVCUTEN, &
+                                                       RQCCUTEN, &
+                                                       RQRCUTEN, &
+                                                       RQICUTEN, &
+                                                       RQSCUTEN, &
+                                                       RQVSHTEN, &
+                                                       RQCSHTEN, &
+                                                       RQRSHTEN, &
+                                                       RQISHTEN, &
+                                                       RQSSHTEN, &
+                                                       RQGSHTEN, &
+                                                     RTHNDGDTEN, &
+                                                     RPHNDGDTEN, &
+                                                     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,n_scalar,   &
+                      rt_tendf,ru_tendf,rv_tendf,              &
+                      RUCUTEN,RVCUTEN,RTHCUTEN,                &
+                      RQVCUTEN,RQCCUTEN,RQRCUTEN,              &
+                      RQICUTEN,RQSCUTEN,moist_tendf,           &
+                      scalar_tendf,adv_moist_cond,             &
+                      ids, ide, jds, jde, kds, kde,            &
+                      ims, ime, jms, jme, kms, kme,            &
+                      its, ite, jts, jte, kts, kte             )
+
+   if (config_flags%shcu_physics .gt. 0)                       &
+      CALL phy_shcu_ten(config_flags,rk_step,n_moist,          &
+                      rt_tendf,ru_tendf,rv_tendf,              &
+                      RUSHTEN,RVSHTEN,RTHSHTEN,                &
+                      RQVSHTEN,RQCSHTEN,RQRSHTEN,              &
+                      RQISHTEN,RQSSHTEN,RQGSHTEN,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,            &
+                      rph_tendf,rt_tendf,ru_tendf,rv_tendf,    &
+                      mu_tendf, moist_tendf,                   &
+                      RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,          &
+                      RPHNDGDTEN,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 (ACMPBLSCHEME)
+
+           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)THEN
+           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                     )
+
+           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
+     
+       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                     )
+     
+        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                     )
+     
+!       if (P_QT .ge. PARAM_FIRST_SCALAR)                                         &
+!          CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQSBLTEN,  &
+!               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),RQRBLTEN,  &
+!               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),RQGBLTEN,  &
+!               config_flags,                                    &
+!               ids,ide, jds, jde, kds, kde,                     &
+!               ims, ime, jms, jme, kms, kme,                    &
+!               its, ite, jts, jte, kts, kte                     )
+     
+       ELSE
+
+        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 (P_QS .ge. PARAM_FIRST_SCALAR)                                         &
+!          CALL add_a2a(moist_tendf(ims,kms,jms,P_QS),RQSBLTEN,  &
+!               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),RQRBLTEN,  &
+!               config_flags,                                    &
+!               ids,ide, jds, jde, kds, kde,                     &
+!               ims, ime, jms, jme, kms, kme,                    &
+!               its, ite, jts, jte, kts, kte                     )
+!    
+!       if (P_QG .ge. PARAM_FIRST_SCALAR)                                         &
+!          CALL add_a2a(moist_tendf(ims,kms,jms,P_QG),RQGBLTEN,  &
+!               config_flags,                                    &
+!               ids,ide, jds, jde, kds, kde,                     &
+!               ims, ime, jms, jme, kms, kme,                    &
+!               its, ite, jts, jte, kts, kte                     )
+     
+       ENDIF
+
+      CASE (QNSEPBLSCHEME)
+
+           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                     )
+     
+       ELSE
+
+        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                     )
+
+       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 (MYNNPBLSCHEME2,MYNNPBLSCHEME3)
+
+           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(.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 (BOULACSCHEME)
+
+           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                     )
+
+       ELSE
+
+        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                     )
+       ENDIF
+
+       CASE (CAMUWPBLSCHEME)
+           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                     )
+
+       ELSE
+
+        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                     )
+       ENDIF
+
+
+      CASE (TEMFPBLSCHEME)
+           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                     )
+
+      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,n_scalar,     &
+                      rt_tendf,ru_tendf,rv_tendf,                &
+                      RUCUTEN,RVCUTEN,RTHCUTEN,                  &
+                      RQVCUTEN,RQCCUTEN,RQRCUTEN,                &
+                      RQICUTEN,RQSCUTEN,moist_tendf,             &
+                      scalar_tendf,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, 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  ) ::   &
+                                                        RUCUTEN, &
+                                                        RVCUTEN, &
+                                                       RTHCUTEN, &
+                                                       RQVCUTEN, &
+                                                       RQCCUTEN, &
+                                                       RQRCUTEN, &
+                                                       RQICUTEN, &
+                                                       RQSCUTEN
+
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::  &
+                                                       rt_tendf, &
+                                                       ru_tendf, &
+                                                       rv_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                     )
+
+       IF(.not. adv_moist_cond)THEN
+
+        if (P_QT .ge. PARAM_FIRST_SCALAR)                        &
+           CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQCCUTEN, &
+                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),RQRCUTEN, &
+                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),RQICUTEN, &
+                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),RQSCUTEN, &
+                config_flags,                                    &
+                ids,ide, jds, jde, kds, kde,                     &
+                ims, ime, jms, jme, kms, kme,                    &
+                its, ite, jts, jte, kts, kte                     )
+
+       ENDIF
+
+   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                     )
+
+       IF(.not. adv_moist_cond)THEN
+
+        if (P_QT .ge. PARAM_FIRST_SCALAR)                        &
+           CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQCCUTEN, &
+                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),RQRCUTEN, &
+                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),RQICUTEN, &
+                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),RQSCUTEN, &
+                config_flags,                                    &
+                ids,ide, jds, jde, kds, kde,                     &
+                ims, ime, jms, jme, kms, kme,                    &
+                its, ite, jts, jte, kts, kte                     )
+
+       ENDIF
+   CASE (GDSCHEME, G3SCHEME)
+        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                     )
+
+       IF(.not. adv_moist_cond)THEN
+
+        if (P_QT .ge. PARAM_FIRST_SCALAR)                        &
+           CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQCCUTEN, &
+                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),RQICUTEN, &
+                config_flags,                                    &
+                ids,ide, jds, jde, kds, kde,                     &
+                ims, ime, jms, jme, kms, kme,                    &
+                its, ite, jts, jte, kts, kte                     )
+
+       ENDIF
+
+   CASE (NSASSCHEME)
+        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                     )
+
+        CALL add_a2c_u(ru_tendf,RUCUTEN,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,RVCUTEN,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                     )
+
+       IF(.not. adv_moist_cond)THEN
+
+        if (P_QT .ge. PARAM_FIRST_SCALAR)                        &
+           CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQCCUTEN, &
+                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),RQICUTEN, &
+                config_flags,                                    &
+                ids,ide, jds, jde, kds, kde,                     &
+                ims, ime, jms, jme, kms, kme,                    &
+                its, ite, jts, jte, kts, kte                     )
+
+       ENDIF
+
+   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                     )
+
+       IF(.not. adv_moist_cond)THEN
+
+        if (P_QT .ge. PARAM_FIRST_SCALAR)                        &
+           CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQCCUTEN, &
+                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),RQICUTEN, &
+                config_flags,                                    &
+                ids,ide, jds, jde, kds, kde,                     &
+                ims, ime, jms, jme, kms, kme,                    &
+                its, ite, jts, jte, kts, kte                     )
+
+       ENDIF
+
+   CASE (CAMZMSCHEME)
+        CALL add_a2c_u(ru_tendf,RUCUTEN,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,RVCUTEN,config_flags,            &
+                ids,ide, jds, jde, kds, kde,                     &
+                ims, ime, jms, jme, kms, kme,                    &
+                its, ite, jts, jte, kts, kte                     )
+
+        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                     )
+       IF(.not. adv_moist_cond)THEN
+
+        if (P_QT .ge. PARAM_FIRST_SCALAR)                        &
+           CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQCCUTEN, &
+                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),RQICUTEN, &
+                config_flags,                                    &
+                ids,ide, jds, jde, kds, kde,                     &
+                ims, ime, jms, jme, kms, kme,                    &
+                its, ite, jts, jte, kts, kte                     )
+
+       ENDIF
+
+   CASE (TIEDTKESCHEME)
+        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                     )
+
+        CALL add_a2c_u(ru_tendf,RUCUTEN,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,RVCUTEN,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                     )
+
+       IF(.not. adv_moist_cond)THEN
+
+        if (P_QT .ge. PARAM_FIRST_SCALAR)                        &
+           CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQCCUTEN, &
+                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),RQICUTEN, &
+                config_flags,                                    &
+                ids,ide, jds, jde, kds, kde,                     &
+                ims, ime, jms, jme, kms, kme,                    &
+                its, ite, jts, jte, kts, kte                     )
+
+       ENDIF
+
+   CASE DEFAULT
+
+   END SELECT
+
+END SUBROUTINE phy_cu_ten
+
+!=================================================================
+SUBROUTINE phy_shcu_ten(config_flags,rk_step,n_moist,            &
+                      rt_tendf,ru_tendf,rv_tendf,                &
+                      RUSHTEN,RVSHTEN,RTHSHTEN,                  &
+                      RQVSHTEN,RQCSHTEN,RQRSHTEN,                &
+                      RQISHTEN,RQSSHTEN,RQGSHTEN,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  ) ::   &
+                                                        RUSHTEN, &
+                                                        RVSHTEN, &
+                                                       RTHSHTEN, &
+                                                       RQVSHTEN, &
+                                                       RQCSHTEN, &
+                                                       RQRSHTEN, &
+                                                       RQISHTEN, &
+                                                       RQSSHTEN, &
+                                                       RQGSHTEN
+
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::  &
+                                                       rt_tendf, &
+                                                       ru_tendf, &
+                                                       rv_tendf
+
+! LOCAL VARS
+
+   INTEGER :: i,j,k
+
+   SELECT CASE (config_flags%shcu_physics)
+
+   CASE (CAMUWSHCUSCHEME)
+        CALL add_a2c_u(ru_tendf,RUSHTEN,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,RVSHTEN,config_flags,            &
+                ids,ide, jds, jde, kds, kde,                     &
+                ims, ime, jms, jme, kms, kme,                    &
+                its, ite, jts, jte, kts, kte                     )
+
+        CALL add_a2a(rt_tendf,RTHSHTEN,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),RQVSHTEN,     &
+                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),RQCSHTEN,     &
+                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),RQRSHTEN,     &
+                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),RQISHTEN,     &
+                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),RQSSHTEN,     &
+                config_flags,                                    &
+                ids,ide, jds, jde, kds, kde,                     &
+                ims, ime, jms, jme, kms, kme,                    &
+                its, ite, jts, jte, kts, kte                     )
+
+        if (P_QG .ge. PARAM_FIRST_SCALAR)                        &
+        CALL add_a2a(moist_tendf(ims,kms,jms,P_QG),RQGSHTEN,     &
+                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_shcu_ten
+
+!=================================================================
+SUBROUTINE phy_fg_ten(config_flags,rk_step,n_moist,            &
+                      rph_tendf,rt_tendf,ru_tendf,rv_tendf,    &
+                      mu_tendf, moist_tendf,                   &
+                      RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,          &
+                      RPHNDGDTEN,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, &
+                                                       RPHNDGDTEN, &
+                                                        RUNDGDTEN, &
+                                                        RVNDGDTEN, &
+                                                       RQVNDGDTEN
+
+   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN  ) ::  RMUNDGDTEN
+
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT)::   &
+                                                       rph_tendf,&
+                                                       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 (SPNUDGING)
+
+! 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(rt_tendf,RTHNDGDTEN,config_flags,        &
+                ids,ide, jds, jde, kds, kde,                     &
+                ims, ime, jms, jme, kms, kme,                    &
+                its, ite, jts, jte, kts, kte                     )
+
+           CALL add_a2a_ph(rph_tendf,RPHNDGDTEN,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_SFIRE
+!-----------------------------------------------------------------
+   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_SFIRE)
+
+           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,RAINSH,PRATEC,PRATESH,  &
+                     NCA, HTOP,HBOT,CUTOP,CUBOT,                      &
+                     CUPPT, DT, 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, &
+                                                         RAINSH, &
+                                                         RAINCV, &
+                                                         PRATEC, &
+                                                        PRATESH, &
+                                                            NCA, &
+                                                           HTOP, &
+                                                           HBOT, &
+                                                          CUTOP, &
+                                                          CUBOT, &
+                                                          CUPPT
+   REAL, INTENT(IN) ::                                       DT
+
+! 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) + PRATEC(I,J)*DT
+      RAINSH(I,J) = RAINSH(I,J) + PRATESH(I,J)*DT
+      CUPPT(I,J)  = CUPPT(I,J) + (PRATEC(I,J)+PRATESH(I,J))*DT/1000.
+   ENDDO
+   ENDDO
+
+   SELECT CASE (config_flags%cu_physics)
+
+   CASE (KFSCHEME)
+
+        DO J = j_start,j_end
+        DO i = i_start,i_end
+
+           IF ( NCA(I,J) .GT. 0 ) THEN
+
+              IF ( NINT(NCA(I,J) / DT) .le. 0 ) THEN
+
+              ! set tendency to zero
+!                PRATEC(I,J)=0.
+!                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)-DT ! Decrease NCA
+
+           ENDIF
+!
+        ENDDO
+        ENDDO
+
+   CASE (BMJSCHEME, CAMZMSCHEME)
+ 
+        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.NCUTOP<KDE)THEN
+             HTOP(I,J)=MAX(CUTOP(I,J),HTOP(I,J))
+           ENDIF
+           IF(NCUBOT>0.AND.NCUBOT<KDE)THEN
+             HBOT(I,J)=MIN(CUBOT(I,J),HBOT(I,J))
+           ENDIF
+
+        ENDDO
+        ENDDO
+
+   CASE (KFETASCHEME)
+
+        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.NCUTOP<KDE)THEN
+             HTOP(I,J)=MAX(CUTOP(I,J),HTOP(I,J))
+           ENDIF
+           IF(NCUBOT>0.AND.NCUBOT<KDE)THEN
+             HBOT(I,J)=MIN(CUBOT(I,J),HBOT(I,J))
+           ENDIF
+
+           IF ( NCA(I,J) .GT. 0 ) THEN
+
+
+              IF ( NINT(NCA(I,J) / DT) .LE. 1 ) THEN
+
+              ! set tendency to zero
+!                PRATEC(I,J)=0.
+!                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)-DT ! Decrease NCA
+!              NCA(I,J)=NCA(I,J)-1. ! Decrease NCA
+
+           ENDIF
+!
+        ENDDO
+        ENDDO
+
+   CASE DEFAULT
+
+   END SELECT
+
+END SUBROUTINE advance_ppt
+
+SUBROUTINE add_a2a(lvar,rvar,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   ) ::&
+                                                      rvar
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme),INTENT(INOUT) ::&
+                                                      lvar
+
+! LOCAL VARS
+   INTEGER :: i,j,k,i_start,i_end,j_start,j_end,ktf
+
+   i_start = its
+   i_end   = MIN(ite,ide-1)
+   j_start = jts
+   j_end   = MIN(jte,jde-1)
+   ktf = min(kte,kde-1)
+
+   IF ( config_flags%specified .or. &
+        config_flags%nested) i_start = MAX(ids+1,its)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) i_end   = MIN(ide-2,ite)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) j_start = MAX(jds+1,jts)
+   IF ( 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
+      lvar(i,k,j) = lvar(i,k,j) + rvar(i,k,j)
+   ENDDO
+   ENDDO
+   ENDDO
+
+END SUBROUTINE add_a2a
+
+SUBROUTINE add_a2a_ph(lvar,rvar,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   ) ::&
+                                                      rvar
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme),INTENT(INOUT) ::&
+                                                      lvar
+
+! LOCAL VARS
+   INTEGER :: i,j,k,i_start,i_end,j_start,j_end
+
+   i_start = its
+   i_end   = MIN(ite,ide-1)
+   j_start = jts
+   j_end   = MIN(jte,jde-1)
+
+   IF ( config_flags%specified .or. &
+        config_flags%nested) i_start = MAX(ids+1,its)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) i_end   = MIN(ide-2,ite)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) j_start = MAX(jds+1,jts)
+   IF ( 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,kte
+   DO i = i_start,i_end
+      lvar(i,k,j) = lvar(i,k,j) + rvar(i,k,j)
+   ENDDO
+   ENDDO
+   ENDDO
+
+END SUBROUTINE add_a2a_ph
+
+!------------------------------------------------------------
+SUBROUTINE add_a2c_u(lvar,rvar,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   ) ::&
+                                                      rvar
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme),INTENT(INOUT) ::&
+                                                      lvar
+
+! LOCAL VARS
+
+   INTEGER :: i,j,k,i_start,i_end,j_start,j_end,ktf
+
+   ktf=min(kte,kde-1)
+
+   i_start = its
+   i_end   = ite
+   j_start = jts
+   j_end   = MIN(jte,jde-1)
+
+   IF ( config_flags%specified .or. &
+        config_flags%nested) i_start = MAX(ids+1,its)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) i_end   = MIN(ide-1,ite)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) j_start = MAX(jds+1,jts)
+   IF ( 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
+
+   DO j = j_start,j_end
+   DO k = kts,ktf
+   DO i = i_start,i_end
+      lvar(i,k,j) = lvar(i,k,j) + &
+                       0.5*(rvar(i,k,j)+rvar(i-1,k,j))
+   ENDDO
+   ENDDO
+   ENDDO
+
+END SUBROUTINE add_a2c_u
+
+!------------------------------------------------------------
+SUBROUTINE add_a2c_v(lvar,rvar,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   ) ::&
+                                                      rvar
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme),INTENT(INOUT) ::&
+                                                      lvar
+
+! LOCAL VARS
+
+   INTEGER :: i,j,k,i_start,i_end,j_start,j_end,ktf
+
+   ktf=min(kte,kde-1)
+
+   i_start = its
+   i_end   = MIN(ite,ide-1)
+   j_start = jts
+   j_end   = jte
+
+   IF ( config_flags%specified .or. &
+        config_flags%nested) i_start = MAX(ids+1,its)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) i_end   = MIN(ide-2,ite)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) j_start = MAX(jds+1,jts)
+   IF ( 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 )
+
+   DO j = j_start,j_end
+   DO k = kts,kte
+   DO i = i_start,i_end
+      lvar(i,k,j) = lvar(i,k,j) + &
+                     0.5*(rvar(i,k,j)+rvar(i,k,j-1))
+   ENDDO
+   ENDDO
+   ENDDO
+
+END SUBROUTINE add_a2c_v
+
+!------------------------------------------------------------
+SUBROUTINE add_c2c_u(lvar,rvar,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   ) ::&
+                                                      rvar
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme),INTENT(INOUT) ::&
+                                                      lvar
+
+! LOCAL VARS
+
+   INTEGER :: i,j,k,i_start,i_end,j_start,j_end,ktf
+
+   ktf=min(kte,kde-1)
+
+   i_start = its
+   i_end   = ite
+   j_start = jts
+   j_end   = MIN(jte,jde-1)
+
+
+   IF ( config_flags%specified .or. &
+        config_flags%nested) i_start = MAX(ids+1,its)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) i_end   = MIN(ide-1,ite)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) j_start = MAX(jds+1,jts)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) j_end   = MIN(jde-2,jte)
+
+!  write(*,'(a,6i4)') 'call c2cu, i_start, i_end, j_start, j_end=', i_start, i_end, j_start, j_end
+
+   DO j = j_start,j_end
+   DO k = kts,ktf
+   DO i = i_start,i_end
+      lvar(i,k,j) = lvar(i,k,j) + rvar(i,k,j)
+   ENDDO
+   ENDDO
+   ENDDO
+
+END SUBROUTINE add_c2c_u
+
+SUBROUTINE add_c2c_v(lvar,rvar,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   ) ::&
+                                                      rvar
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme),INTENT(INOUT) ::&
+                                                      lvar
+
+! LOCAL VARS
+
+   INTEGER :: i,j,k,i_start,i_end,j_start,j_end,ktf
+
+   ktf=min(kte,kde-1)
+
+   i_start = its
+   i_end   = MIN(ite,ide-1)
+   j_start = jts
+   j_end   = jte
+
+   IF ( config_flags%specified .or. &
+        config_flags%nested) i_start = MAX(ids+1,its)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) i_end   = MIN(ide-2,ite)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) j_start = MAX(jds+1,jts)
+   IF ( config_flags%specified .or. &
+        config_flags%nested) j_end   = MIN(jde-1,jte)
+
+!  write(*,'(a,6i4)') 'call c2cv, i_start, i_end, j_start, j_end=', i_start, i_end, j_start, j_end
+
+   DO j = j_start,j_end
+   DO k = kts,kte
+   DO i = i_start,i_end
+      lvar(i,k,j) = lvar(i,k,j) + rvar(i,k,j)
+   ENDDO
+   ENDDO
+   ENDDO
+
+END SUBROUTINE add_c2c_v
+
+#endif
+
+END MODULE module_physics_addtendc
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_physics_init.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_physics_init.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_physics_init.F	(revision 17)
@@ -0,0 +1,2597 @@
+!WRF:MODEL_LAYER:INITIALIZATION
+!
+
+!  This MODULE holds the routines which are used to perform model start-up operations
+!  for the individual domains.  This is the stage after inputting wrfinput and before
+!  calling 'integrate'.
+
+!  This MODULE CONTAINS the following routines:
+
+
+MODULE module_physics_init
+
+   USE module_state_description
+   USE module_model_constants
+   USE module_configure, ONLY : grid_config_rec_type
+
+CONTAINS
+
+
+!=================================================================
+   SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf,     &
+                         p_top, TSK,RADT,BLDT,CUDT,MPDT,         &
+                         RUCUTEN, RVCUTEN,                       &
+                         RTHCUTEN, RQVCUTEN, RQRCUTEN,           &
+                         RQCCUTEN, RQSCUTEN, RQICUTEN,           &
+                         RUSHTEN,  RVSHTEN,  RTHSHTEN,           &
+                         RQVSHTEN, RQRSHTEN, RQCSHTEN,           &
+                         RQSSHTEN, RQISHTEN, RQGSHTEN,           &
+                         RUBLTEN,RVBLTEN,RTHBLTEN,               &
+                         RQVBLTEN,RQCBLTEN,RQIBLTEN,             &
+                         RTHRATEN,RTHRATENLW,RTHRATENSW,         &
+                         STEPBL,STEPRA,STEPCU,                   &
+                         W0AVG, RAINNC, RAINC, RAINCV, RAINNCV,  &
+                         SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV, &
+                         NCA,swrad_scat,                         &
+                         CLDEFI,LOWLYR,                          &
+                         MASS_FLUX,                              &
+                         RTHFTEN, RQVFTEN,                       &
+                         CLDFRA,CLDFRA_OLD,GLW,GSW,EMISS,EMBCK,  & !EMBCK new
+                         LU_INDEX,                               &
+                         landuse_ISICE, landuse_LUCATS,          &
+                         landuse_LUSEAS, landuse_ISN,            &
+                         lu_state,                               &
+                         XLAT,XLONG,ALBEDO,ALBBCK,GMT,JULYR,JULDAY,&
+                         levsiz, n_ozmixm, n_aerosolc, paerlev,  &
+                         TMN,XLAND,ZNT,Z0,UST,MOL,PBLH,TKE_PBL,  &
+                         EXCH_H,THC,SNOWC,MAVAIL,HFX,QFX,RAINBL, &
+                         TSLB,ZS,DZS,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,XICEM,VEGFRA,SNOW,CANWAT,SMSTAV,   &
+                         SMSTOT, SFCRUNOFF,UDRUNOFF,GRDFLX,ACSNOW,&
+                         ACSNOM,IVGTYP,ISLTYP, SFCEVP, SMOIS,    &
+                         SH2O, SNOWH, SMFR3D,                    &  ! temporary
+                         SNOALB,                                 &
+                         DX,DY,F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, &
+                         mp_restart_state,tbpvs_state,tbpvs0_state,&
+                         allowed_to_read, moved, start_of_simulation,&
+                         LAGDAY,                                 &
+                         ids, ide, jds, jde, kds, kde,           &
+                         ims, ime, jms, jme, kms, kme,           &
+                         its, ite, jts, jte, kts, kte,           &
+                         NUM_URBAN_LAYERS,                       &
+                         ozmixm,pin,                             &    ! Optional
+                         m_ps_1,m_ps_2,m_hybi,aerosolc_1,aerosolc_2,& ! Optional
+                         RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,         &    ! Optional
+                         RPHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN,       &    ! Optional
+                         FGDT,STEPFG,                            &    ! Optional
+                         cugd_tten,cugd_ttens,cugd_qvten,        &    ! Optional
+                         cugd_qvtens,cugd_qcten,                 &    ! Optional
+!                        num_roof_layers,num_wall_layers,        & !Optional urban
+!                        num_road_layers,                        & !Optional urban
+                         DZR, DZB, DZG,                          & !Optional urban
+                         TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,    & !Optional urban
+                         QC_URB2D, XXXR_URB2D,XXXB_URB2D,        & !Optional urban
+                         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,       & !Optional urban
+                         TRB_URB4D,TW1_URB4D,TW2_URB4D,          & !Optional multi-layer urban
+                         TGB_URB4D,TLEV_URB3D,QLEV_URB3D,        & !Optional multi-layer urban
+                         TW1LEV_URB3D,TW2LEV_URB3D,              & !Optional multi-layer urban
+                         TGLEV_URB3D,TFLEV_URB3D,                & !Optional multi-layer urban
+                         SF_AC_URB3D,LF_AC_URB3D,CM_AC_URB3D,    & !Optional multi-layer urban
+                         SFVENT_URB3D,LFVENT_URB3D,              & !Optional multi-layer urban
+                         SFWIN1_URB3D,SFWIN2_URB3D,              & !Optional multi-layer urban
+                         SFW1_URB3D,SFW2_URB3D,                  & !Optional multi-layer urban
+                         SFR_URB3D,SFG_URB3D,                    & !Optional multi-layer urban
+                         A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP,        & !Optional multi-layer urban
+                         A_E_BEP,B_U_BEP,B_V_BEP,                & !Optional multi-layer urban
+                         B_T_BEP,B_Q_BEP,B_E_BEP,DLG_BEP,        & !Optional multi-layer urban
+                         DL_U_BEP,SF_BEP,VL_BEP,                 & !Optional multi-layer urban
+                         TML,T0ML,HML,H0ML,HUML,HVML,TMOML,      & !Optional oml
+                         itimestep,                              & !Optional obs fdda
+#if ( EM_CORE == 1 )
+                         fdob,                                   & !Optional obs fdda
+#endif
+                         t00, p00, tlp,                          & !for obs-nudging
+                         TYR,TYRA,TDLY,TLAG,NYEAR,NDAY,tmn_update,   &
+                         ACHFX,ACLHF,ACGRDFLX                    &
+   ! OPTIONAL 
+                         ,te_temf          & ! WA 12/21/09
+                         ,cf3d_temf        & ! WA 9/27/10
+                         ,wm_temf          & ! WA 2/22/11
+                         )
+
+!-----------------------------------------------------------------
+   USE module_domain
+   USE module_wrf_error
+   USE module_wind_generic
+   USE module_wind_fitch
+   IMPLICIT NONE
+!-----------------------------------------------------------------
+   TYPE (grid_config_rec_type)              :: config_flags
+
+   INTEGER , INTENT(IN)        :: id
+   INTEGER , INTENT(IN) ,OPTIONAL       :: tmn_update
+   LOGICAL , INTENT(OUT)       :: warm_rain,adv_moist_cond
+!   LOGICAL , INTENT (IN)       :: FNDSOILW, FNDSNOWH
+   LOGICAL, PARAMETER          :: FNDSOILW=.true., FNDSNOWH=.true.
+   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)        :: lagday
+   INTEGER , INTENT(OUT) ,OPTIONAL      :: nyear
+   REAL    , INTENT(OUT) ,OPTIONAL      :: nday
+
+   LOGICAL,  INTENT(IN)        :: start_of_simulation
+   REAL,     INTENT(IN)        :: DT, p_top, DX, DY
+   LOGICAL,  INTENT(IN)        :: restart
+   REAL,     INTENT(IN)        :: RADT,BLDT,CUDT,MPDT
+   REAL,     INTENT(IN)        :: swrad_scat
+
+   REAL,     DIMENSION( kms:kme ) , INTENT(IN) :: zfull, zhalf
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: TSK, XLAT, XLONG
+
+   INTEGER,      INTENT(IN   )    ::   levsiz, n_ozmixm
+   INTEGER,      INTENT(IN   )    ::   paerlev, n_aerosolc
+
+   REAL,  DIMENSION( ims:ime, levsiz, jms:jme, n_ozmixm ), OPTIONAL, &
+          INTENT(INOUT) ::                                  OZMIXM
+
+   REAL,  DIMENSION(levsiz), OPTIONAL, INTENT(INOUT)  ::        PIN
+
+   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( ims:ime , 1:num_soil_layers , jms:jme ),&
+                 INTENT(INOUT) :: SMOIS, SH2O,TSLB
+   REAL,     DIMENSION( ims:ime , 1:num_soil_layers , jms:jme ), INTENT(OUT) :: SMFR3D
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(INOUT)    ::                           SNOW, &
+                                                         SNOWC, &
+                                                         SNOWH, &
+                                                        CANWAT, &
+                                                        SMSTAV, &
+                                                        SMSTOT, &
+                                                     SFCRUNOFF, &
+                                                      UDRUNOFF, &
+                                                        SFCEVP, &
+                                                        GRDFLX, &
+                                                        ACSNOW, &
+                                                          XICE, &
+                                                         XICEM, &
+                                                        VEGFRA, &
+                                                        ACSNOM
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            OPTIONAL, INTENT(INOUT)    ::                ACHFX, &
+                                                         ACLHF, &
+                                                      ACGRDFLX
+
+   INTEGER, DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(INOUT)    ::                         IVGTYP, &
+                                                        ISLTYP
+
+! rad
+
+   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) ::         &
+             GSW,ALBEDO,ALBBCK,GLW,EMISS,EMBCK                          !EMBCK new
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) ::   SNOALB
+
+
+   REAL,     INTENT(IN) :: GMT
+
+   INTEGER , INTENT(OUT) :: STEPRA, STEPBL, STEPCU
+   INTEGER , INTENT(IN) :: JULYR, JULDAY
+
+! cps
+
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: &
+             RUCUTEN, RVCUTEN, RTHCUTEN, RQVCUTEN, RQRCUTEN, RQCCUTEN, &
+             RQSCUTEN, RQICUTEN,                                       &
+             RUSHTEN, RVSHTEN, RTHSHTEN, RQVSHTEN, RQRSHTEN, RQCSHTEN, &
+             RQSSHTEN, RQISHTEN, RQGSHTEN
+
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: W0AVG
+
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) :: MASS_FLUX,   &
+                      APR_GR,APR_W,APR_MC,APR_ST,APR_AS,          &
+                      APR_CAPMA,APR_CAPME,APR_CAPMI
+
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::    &
+             RTHFTEN, RQVFTEN
+
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) ::           &
+             RAINNC, RAINC, RAINCV, RAINNCV,  &
+             SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV
+
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) :: CLDEFI, NCA
+
+   INTEGER,  DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) :: LOWLYR
+
+!pbl
+
+   ! soil layer
+
+
+   REAL,     DIMENSION(1:num_soil_layers),      INTENT(INOUT) :: ZS,DZS
+
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::    &
+             RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN,RQIBLTEN,EXCH_H,TKE_PBL
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , OPTIONAL, INTENT(OUT) ::    &
+             cugd_tten,cugd_ttens,cugd_qvten,                &
+             cugd_qvtens,cugd_qcten
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) ::         &
+             XLAND,ZNT,Z0,UST,MOL,LU_INDEX,                         &
+             PBLH,THC,MAVAIL,HFX,QFX,RAINBL
+   INTEGER , INTENT(INOUT)  :: landuse_ISICE, landuse_LUCATS
+   INTEGER , INTENT(INOUT)  :: landuse_LUSEAS, landuse_ISN
+   REAL    , INTENT(INOUT)  , DIMENSION( : ) :: lu_state
+
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: TMN
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT),OPTIONAL :: TYR
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT),OPTIONAL :: TYRA
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT),OPTIONAL :: TDLY
+   REAL,     DIMENSION( ims:ime , 1:lagday , jms:jme ) , INTENT(INOUT),OPTIONAL :: TLAG
+
+!mp
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::   &
+             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, moved
+
+! ocean mixed layer
+   REAL,     DIMENSION( ims:ime , jms:jme ) , OPTIONAL, INTENT(INOUT) ::    &
+             TML,T0ML,HML,H0ML,HUML,HVML,TMOML
+
+!fdda
+   REAL,     OPTIONAL, INTENT(IN) :: FGDT
+   INTEGER , OPTIONAL, INTENT(OUT) :: STEPFG
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , OPTIONAL, INTENT(OUT) ::    &
+             RUNDGDTEN, RVNDGDTEN, RTHNDGDTEN, RPHNDGDTEN, RQVNDGDTEN
+   REAL,     DIMENSION( ims:ime , jms:jme ) , OPTIONAL, INTENT(OUT) ::    &
+             RMUNDGDTEN
+
+!URBAN
+!   REAL, DIMENSION(1:num_roof_layers), INTENT(INOUT) :: DZR   !urban
+!   REAL, DIMENSION(1:num_wall_layers), INTENT(INOUT) :: DZB   !urban
+!   REAL, DIMENSION(1:num_road_layers), INTENT(INOUT) :: DZG   !urban
+   REAL, OPTIONAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZR    !urban
+   REAL, OPTIONAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZB    !urban
+   REAL, OPTIONAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: 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) :: 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, DIMENSION(ims:ime, 1:num_roof_layers, jms:jme), INTENT(INOUT) :: TRL_URB3D !urban
+!   REAL, DIMENSION(ims:ime, 1:num_wall_layers, jms:jme), INTENT(INOUT) :: TBL_URB3D !urban
+!   REAL, DIMENSION(ims:ime, 1:num_road_layers, jms:jme), INTENT(INOUT) :: TGL_URB3D !urban
+   REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TRL_URB3D  !urban
+   REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TBL_URB3D  !urban
+   REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), 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
+
+   INTEGER , INTENT(IN)        :: num_urban_layers
+   REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TRB_URB4D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW1_URB4D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW2_URB4D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TGB_URB4D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TLEV_URB3D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: QLEV_URB3D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW1LEV_URB3D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW2LEV_URB3D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TGLEV_URB3D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TFLEV_URB3D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LF_AC_URB3D !multi-layer UCM
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SF_AC_URB3D !multi-layer UCM
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CM_AC_URB3D !multi-layer UCM
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SFVENT_URB3D !multi-layer UCM
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LFVENT_URB3D !multi-layer UCM
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN1_URB3D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN2_URB3D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFG_URB3D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFR_URB3D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFW1_URB3D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFW2_URB3D ! multi-layer UCM
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_U_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_V_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_T_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_Q_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_E_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_U_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_V_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_T_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_Q_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_E_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: VL_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: DLG_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme,jms:jme), INTENT(INOUT) :: SF_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: DL_U_BEP
+
+!obs fdda
+   INTEGER, OPTIONAL, INTENT(IN) :: itimestep
+#if ( EM_CORE == 1 )
+   TYPE(fdob_type), OPTIONAL, INTENT(INOUT) :: fdob
+#endif
+   REAL, OPTIONAL, INTENT(IN) :: p00, t00, tlp   ! for obs-nudging base-state calcn
+
+! WA 12/21/09
+   REAL,OPTIONAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
+          INTENT(OUT) ::    te_temf, cf3d_temf    
+! WA 2/22/11
+   REAL,OPTIONAL, DIMENSION( ims:ime , jms:jme ) , &
+          INTENT(OUT) ::    wm_temf
+
+! Local data
+
+   REAL    :: ALBLND,ZZLND,ZZWTR,THINLD,XMAVA,CEN_LAT,pptop
+   REAL,     DIMENSION( kms:kme )  :: sfull, shalf
+   REAL :: obs_twindo_cg, obs_twindo
+
+   CHARACTER*256 :: MMINLU_loc
+   CHARACTER*80 :: message
+   INTEGER :: ISWATER
+   INTEGER :: ISICE
+   INTEGER :: ISURBAN
+   INTEGER :: sf_urban_physics
+   INTEGER :: omlcall
+   REAL    :: oml_hml0
+   LOGICAL :: usemonalb
+   LOGICAL :: rdmaxalb
+
+   INTEGER :: i, j, k, itf, jtf, n
+integer myproc
+
+!-----------------------------------------------------------------
+
+   sf_urban_physics=config_flags%sf_urban_physics
+   usemonalb=config_flags%usemonalb
+   rdmaxalb=config_flags%rdmaxalb
+#if ( EM_CORE == 1 )
+   obs_twindo_cg=model_config_rec%obs_twindo(1)
+   obs_twindo=config_flags%obs_twindo
+   oml_hml0=config_flags%oml_hml0
+   omlcall=config_flags%omlcall
+#endif
+
+!-- should be from the namelist
+
+   sfull = 0.
+   shalf = 0.
+
+   CALL wrf_debug(100,'top of phy_init')
+
+   WRITE(wrf_err_message,*) 'phy_init:  start_of_simulation = ',start_of_simulation
+   CALL wrf_debug ( 100, TRIM(wrf_err_message) )
+
+   itf=min0(ite,ide-1)
+   jtf=min0(jte,jde-1)
+
+   ZZLND=0.1
+   ZZWTR=0.0001
+   THINLD=0.04
+   ALBLND=0.2
+   XMAVA=0.3
+
+#if (NMM_CORE == 1)
+   if (.not.usemonalb) CALL wrf_error_fatal('usemonalb should always be true for NMM')
+#endif
+
+   CALL nl_get_cen_lat(id,cen_lat)
+   CALL wrf_debug(100,'calling nl_get_iswater, nl_get_isice, nl_get_mminlu_loc')
+   CALL nl_get_iswater(id,iswater)
+   CALL nl_get_isice(id,isice)
+   CALL nl_get_isurban(id,isurban)
+   CALL nl_get_mminlu( 1, mminlu_loc )
+   CALL wrf_debug(100,'after nl_get_iswater, nl_get_isice, nl_get_mminlu_loc')
+!-- temporary fix by ww
+   landuse_ISICE = isice
+
+! Added for Wind Turbine parameterization code -- This will only read in an optional 
+! configuration file with information that will be used by inividual turbine init routines 
+! as each domain is initialized.
+  IF ( id .EQ. 1 ) THEN
+    CALL init_module_wind_generic
+    CALL init_module_wind_fitch
+  ENDIF
+!
+
+  IF(.not.restart)THEN
+!-- initialize common variables
+
+   IF ( .NOT. moved ) THEN
+   DO j=jts,jtf
+   DO i=its,itf
+      XLAND(i,j)=1.
+      GSW(i,j)=0.
+      GLW(i,j)=0.
+!-- initialize ust to a small value
+      UST(i,j)=0.0001
+      MOL(i,j)=0.0
+      PBLH(i,j)=0.0
+      HFX(i,j)=0.
+      QFX(i,j)=0.
+      RAINBL(i,j)=0.
+      RAINNCV(i,j)=0.
+      SNOWNCV(i,j)=0.
+      GRAUPELNCV(i,j)=0.
+      ACSNOW(i,j)=0.
+      DO k=kms,kme  !wig, 17-May-2006: Added for idealized chem. runs
+         EXCH_H(i,k,j) = 0.
+      END DO
+   ENDDO
+   ENDDO
+   ENDIF
+!
+   IF(PRESENT(TMN_UPDATE))THEN
+   if(tmn_update.eq.1) then
+   nyear=1
+   nday=0.
+   DO j=jts,jtf
+   DO i=its,itf
+      TYR(i,j)=TMN(i,j)
+      TYRA(i,j)=TMN(i,j)
+      TDLY(i,j)=TMN(i,j)
+    DO n=1,lagday
+      TLAG(i,n,j)=TMN(i,j)
+    ENDDO
+   ENDDO
+   ENDDO
+   endif
+   ENDIF
+!
+
+!
+   DO j=jts,jtf
+   DO i=its,itf
+     IF(XLAND(i,j) .LT. 1.5)THEN
+       IF(mminlu_loc .EQ. '    ') ALBBCK(i,j)=ALBLND
+       EMBCK(i,j)=0.85
+       ALBEDO(i,j)=ALBBCK(i,j)
+       EMISS(i,j)=EMBCK(i,j)
+       THC(i,j)=THINLD
+       ZNT(i,j)=ZZLND
+#if  ! ( NMM_CORE == 1 )
+       Z0(i,j)=ZZLND
+#endif
+       MAVAIL(i,j)=XMAVA
+     ELSE
+       IF(mminlu_loc .EQ. '    ') ALBBCK(i,j)=0.08
+       ALBEDO(i,j)=ALBBCK(i,j)
+       EMBCK(i,j)=0.98
+       EMISS(i,j)=EMBCK(i,j)
+       THC(i,j)=THINLD
+       ZNT(i,j)=ZZWTR
+#if  ! ( NMM_CORE == 1 )
+       Z0(i,j)=ZZWTR
+#endif
+       MAVAIL(i,j)=1.0
+     ENDIF
+
+   ENDDO
+   ENDDO
+
+   CALL wrf_debug ( 200 , 'module_start: phy_init: Before call to landuse_init' )
+
+   IF(mminlu_loc .ne. '    ')THEN
+!-- initialize surface properties
+
+     CALL landuse_init(lu_index, snowc, albedo, albbck, snoalb, mavail, emiss, embck, &
+                znt, Z0, thc, xland, xice, xicem, julday, cen_lat, iswater, &
+                TRIM ( mminlu_loc ) ,                               &
+                landuse_ISICE, landuse_LUCATS,                      &
+                landuse_LUSEAS, landuse_ISN,                        &
+                config_flags%fractional_seaice,                      &
+                lu_state,                                           &
+                allowed_to_read , usemonalb ,                       &
+                ids, ide, jds, jde, kds, kde,                       &
+                ims, ime, jms, jme, kms, kme,                       &
+                its, ite, jts, jte, kts, kte                       )
+   ENDIF
+
+  ENDIF
+
+!-- convert zfull and zhalf to sigma values for ra_init (Eta CO2 needs these)
+!-- zfull/zhalf may be either zeta or eta
+!-- what is done here depends on coordinate (check this code if adding new coordinates)
+   CALL z2sigma(zfull,zhalf,sfull,shalf,p_top,pptop,config_flags, &
+                allowed_to_read,                                  &
+                kds,kde,kms,kme,kts,kte)
+
+!-- initialize physics
+!-- ra: radiation
+!-- bl: pbl
+!-- cu: cumulus
+!-- mp: microphysics
+
+   CALL wrf_debug ( 200 , 'module_start: phy_init: Before call to ra_init' )
+
+   CALL ra_init(id=id,STEPRA=STEPRA,RADT=RADT,DT=DT,RTHRATEN=RTHRATEN,RTHRATENLW=RTHRATENLW,             &
+                RTHRATENSW=RTHRATENSW,CLDFRA=CLDFRA,EMISS=EMISS,cen_lat=cen_lat,JULYR=JULYR,JULDAY=JULDAY,GMT=GMT,    &
+                levsiz=levsiz,XLAT=XLAT,n_ozmixm=n_ozmixm,                           &
+                cldfra_old=cldfra_old,                                     & ! Optional
+                ozmixm=ozmixm,pin=pin,                                     & ! Optional
+                m_ps_1=m_ps_1,m_ps_2=m_ps_2,m_hybi=m_hybi,aerosolc_1=aerosolc_1,aerosolc_2=aerosolc_2,     & ! Optional
+                paerlev=paerlev,n_aerosolc=n_aerosolc,                             &
+                sfull=sfull,shalf=shalf,pptop=pptop,swrad_scat=swrad_scat,p_top=p_top,       &
+                config_flags=config_flags,restart=restart,                           &
+                allowed_to_read=allowed_to_read, start_of_simulation=start_of_simulation,           &
+                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                    )
+
+   CALL wrf_debug ( 200 , 'module_start: phy_init: Before call to bl_init' )
+   CALL 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_PBL,                        &
+                EXCH_H,VEGFRA,                                  &
+                SNOW,SNOWC, CANWAT,SMSTAV,                      &
+                SMSTOT, SFCRUNOFF,UDRUNOFF,ACSNOW,ACSNOM,       &
+                IVGTYP,ISLTYP,ISURBAN,SMOIS,SMFR3D,MAVAIL,      &
+                SNOWH,SH2O,SNOALB,FNDSOILW,FNDSNOWH,RDMAXALB,   &
+#if (NMM_CORE == 1)
+                Z0,XLAND,XICE,                                  &
+#else
+                ZNT,XLAND,XICE,                                 &
+#endif
+                SFCEVP,GRDFLX,                                  &
+                TRIM (MMINLU_LOC),                              &
+                allowed_to_read ,                               &
+                start_of_simulation ,                           &
+                te_temf,cf3d_temf,wm_temf,                      & ! WA
+                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,               & 
+                SF_URBAN_PHYSICS,                               & !Optional urban
+                NUM_URBAN_LAYERS,                               & !Optional multi-layer urban
+                TRB_URB4D,TW1_URB4D,TW2_URB4D,                  & !Optional multi-layer urban
+                TGB_URB4D,TLEV_URB3D,QLEV_URB3D,                & !Optional multi-layer urban
+                TW1LEV_URB3D,TW2LEV_URB3D,                      & !Optional multi-layer urban
+                TGLEV_URB3D,TFLEV_URB3D,                        & !Optional multi-layer urban
+                SF_AC_URB3D,LF_AC_URB3D,CM_AC_URB3D,            & !Optional multi-layer urban
+                SFVENT_URB3D,LFVENT_URB3D,                      & !Optional multi-layer urban
+                SFWIN1_URB3D,SFWIN2_URB3D,                      & !Optional multi-layer urban
+                SFW1_URB3D,SFW2_URB3D,                          & !Optional multi-layer urban
+                SFR_URB3D,SFG_URB3D,                            & !Optional multi-layer urban
+                A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP,                & !Optional multi-layer urban
+                A_E_BEP,B_U_BEP,B_V_BEP,                        & !Optional multi-layer urban
+                B_T_BEP,B_Q_BEP,B_E_BEP,DLG_BEP,                & !Optional multi-layer urban
+                DL_U_BEP,SF_BEP,VL_BEP,                         & !Optional multi-layer urban
+                ids, ide, jds, jde, kds, kde,                   &
+                ims, ime, jms, jme, kms, kme,                   &
+                its, ite, jts, jte, kts, kte,                   &
+                ACHFX,ACLHF,ACGRDFLX,                           &
+                oml_hml0, omlcall,                              & !Optional oml
+                TML,T0ML,HML,H0ML,HUML,HVML,TMOML               ) !Optional oml
+
+   CALL wrf_debug ( 200 , 'module_start: phy_init: Before call to cu_init' )
+
+   CALL cu_init(STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,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,                  &
+                cugd_tten,cugd_ttens,cugd_qvten,                &
+                cugd_qvtens,cugd_qcten,                         &
+                allowed_to_read, start_of_simulation,           &
+                ids, ide, jds, jde, kds, kde,                   &
+                ims, ime, jms, jme, kms, kme,                   &
+                its, ite, jts, jte, kts, kte                    )
+
+   CALL wrf_debug ( 200 , 'module_start: phy_init: Before call to shcu_init' )
+
+   CALL shcu_init(STEPCU,CUDT,DT,RUSHTEN,RVSHTEN,RTHSHTEN,      &
+                RQVSHTEN,RQRSHTEN,RQCSHTEN,                     &
+                RQSSHTEN,RQISHTEN,RQGSHTEN,                     &
+                NCA,RAINC,RAINCV,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                    )
+
+   CALL wrf_debug ( 200 , 'module_start: phy_init: Before call to mp_init' )
+
+   CALL mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain,          &
+                adv_moist_cond,                                 &
+                MPDT, DT, DX, DY, LOWLYR,                       &
+                F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,               &
+                mp_restart_state,tbpvs_state,tbpvs0_state,      &
+                allowed_to_read, start_of_simulation,           &
+                ids, ide, jds, jde, kds, kde,                   &
+                ims, ime, jms, jme, kms, kme,                   &
+                its, ite, jts, jte, kts, kte                    )
+
+#if  ( EM_CORE == 1 )
+   CALL wrf_debug ( 200 , 'module_start: phy_init: Before call to fg_init' )
+
+   CALL fg_init(STEPFG,FGDT,DT,id,RUNDGDTEN,RVNDGDTEN,          &
+                RTHNDGDTEN,RPHNDGDTEN,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                    )
+
+   CALL wrf_debug ( 200 , 'module_start: phy_init: Before call to fdob_init' )
+
+   CALL fdob_init(model_config_rec%obs_nudge_opt,               &
+                  model_config_rec%max_dom,                     &
+                  id,                                           &
+                  model_config_rec%parent_id,                   &
+                  model_config_rec%obs_idynin,                  &
+                  model_config_rec%obs_dtramp,                  &
+                  model_config_rec%fdda_end,                    &
+                  model_config_rec%restart,                     &
+                  obs_twindo_cg, obs_twindo,                    &
+                  itimestep,                                    &
+                  model_config_rec%obs_no_pbl_nudge_uv,         &
+                  model_config_rec%obs_no_pbl_nudge_t,          &
+                  model_config_rec%obs_no_pbl_nudge_q,          &
+                  model_config_rec%obs_sfc_scheme_horiz,        &
+                  model_config_rec%obs_sfc_scheme_vert,         &
+                  model_config_rec%obs_max_sndng_gap,           &
+                  model_config_rec%obs_sfcfact,                 &
+                  model_config_rec%obs_sfcfacr,                 &
+                  model_config_rec%obs_dpsmx,                   &
+                  model_config_rec%obs_nudge_wind,              &
+                  model_config_rec%obs_nudge_temp,              &
+                  model_config_rec%obs_nudge_mois,              &
+                  model_config_rec%obs_nudgezfullr1_uv,         &
+                  model_config_rec%obs_nudgezrampr1_uv,         &
+                  model_config_rec%obs_nudgezfullr2_uv,         &
+                  model_config_rec%obs_nudgezrampr2_uv,         &
+                  model_config_rec%obs_nudgezfullr4_uv,         &
+                  model_config_rec%obs_nudgezrampr4_uv,         &
+                  model_config_rec%obs_nudgezfullr1_t,          &
+                  model_config_rec%obs_nudgezrampr1_t,          &
+                  model_config_rec%obs_nudgezfullr2_t,          &
+                  model_config_rec%obs_nudgezrampr2_t,          &
+                  model_config_rec%obs_nudgezfullr4_t,          &
+                  model_config_rec%obs_nudgezrampr4_t,          &
+                  model_config_rec%obs_nudgezfullr1_q,          &
+                  model_config_rec%obs_nudgezrampr1_q,          &
+                  model_config_rec%obs_nudgezfullr2_q,          &
+                  model_config_rec%obs_nudgezrampr2_q,          &
+                  model_config_rec%obs_nudgezfullr4_q,          &
+                  model_config_rec%obs_nudgezrampr4_q,          &
+                  model_config_rec%obs_nudgezfullmin,           &
+                  model_config_rec%obs_nudgezrampmin,           &
+                  model_config_rec%obs_nudgezmax,               &
+                  xlat,                                         &
+                  xlong,                                        &
+                  model_config_rec%start_year(id),              &
+                  model_config_rec%start_month(id),             &
+                  model_config_rec%start_day(id),               &
+                  model_config_rec%start_hour(id),              &
+                  model_config_rec%start_minute(id),            &
+                  model_config_rec%start_second(id),            &
+                  p00, t00, tlp,                                &
+                  zhalf, p_top,                                 &
+                  fdob,                                         &
+                  model_config_rec%obs_ipf_init,                &
+                  ids, ide, jds, jde, kds, kde,                 &
+                  ims, ime, jms, jme, kms, kme,                 &
+                  its, ite, jts, jte, kts, kte                  )
+
+#endif
+
+   END SUBROUTINE phy_init
+
+!=====================================================================
+   SUBROUTINE landuse_init(lu_index, snowc, albedo, albbck, snoalb, mavail, emiss, embck, &
+                znt,Z0,thc,xland, xice, xicem, julday, cen_lat, iswater, mminlu,  &
+                ISICE, LUCATS, LUSEAS, ISN,                         &
+                fractional_seaice,                                  &
+                lu_state,                                           &
+                allowed_to_read , usemonalb ,                       &
+                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
+
+   INTEGER , INTENT(IN)           :: iswater, julday
+   REAL    , INTENT(IN)           :: cen_lat
+   CHARACTER(LEN=*), INTENT(IN)        :: mminlu
+   LOGICAL,  INTENT(IN)           :: allowed_to_read , usemonalb
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: lu_index, snowc, xice, snoalb 
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(OUT  ) :: albedo, albbck, mavail, emiss, &
+                                                               embck,                         &
+                                                               znt, Z0, thc, xland, xicem
+   INTEGER , INTENT(INOUT)  :: ISICE, LUCATS, LUSEAS, ISN, fractional_seaice
+   REAL    , INTENT(INOUT)  , DIMENSION( : ) :: lu_state
+
+   REAL :: xice_threshold
+!---------------------------------------------------------------------
+! Local
+   CHARACTER*256 LUTYPE
+   CHARACTER*80 :: message
+   INTEGER  :: landuse_unit, LS, LC, LI, LUN, NSN
+   INTEGER  :: i, j, itf, jtf, is, cats, seas, curs
+   INTEGER , PARAMETER :: OPEN_OK = 0
+   INTEGER :: ierr
+   INTEGER , PARAMETER :: max_cats = 100 , max_seas = 12
+   REAL    , DIMENSION( max_cats, max_seas ) :: ALBD, SLMO, SFEM, SFZ0, THERIN, SFHC
+   REAL    , DIMENSION( max_cats )     :: SCFX
+! save these fields in case nest moves or has to be reinitialized
+! and this routine is called with allowed_to_read set to false
+! note that by saving these, we're locking in the same landuse for
+! the duration of a run; possible implications for long climate runs
+   LOGICAL :: found_lu, end_of_file
+   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
+
+!---------------------------------------------------------------------
+
+   CALL wrf_debug( 100 , 'top of landuse_init' )
+
+   NSN=-1  ! set this to suppress uninitalized data messages from tools
+
+  if ( fractional_seaice == 0 ) then
+     xice_threshold = 0.5
+  else if ( fractional_seaice == 1 ) then
+     xice_threshold = 0.02
+  endif
+
+! recover LU variables from state
+   IF ( 6*(max_cats*max_seas)+1*max_cats .GT. 7501 ) THEN
+      WRITE(message,*)'landuse_init: lu_state overflow. Make Registry dimspec p > ',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
+!     ELSE IF (MMINLU .EQ. 'MODIFIED_IGBP_MODIS_NOAH') THEN
+!       ISICE = 15
+!     ELSE
+!        call wrf_error_fatal ("INPUT LandUse not found: "//TRIM(MMINLU))
+!     ENDIF
+      call wrf_message ( 'INPUT LandUse = "' // TRIM(MMINLU) // '"' )
+      FOUND_LU = .FALSE.
+      end_of_file = .FALSE.
+!!! BEGINNING OF 1999 LOOP
+ 1999 CONTINUE
+      IF ( wrf_dm_on_monitor() ) THEN
+        READ (landuse_unit,*,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, 256)
+        CALL wrf_dm_bcast_bytes (lucats,  IWORDSIZE )
+        CALL wrf_dm_bcast_bytes (luseas,  IWORDSIZE )
+        CALL wrf_dm_bcast_bytes (found_lu,  LWORDSIZE )
+        IF(FOUND_LU)THEN
+          LUN=LUCATS
+          NSN=LUSEAS
+            PRINT *, 'LANDUSE TYPE = "' // TRIM (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(usemonalb)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.usemonalb)ALBBCK(I,J)=ALBD(IS,ISN)/100.
+          ALBEDO(I,J)=ALBBCK(I,J)
+          IF(SNOWC(I,J) .GT. 0.5) THEN 
+             IF (usemonalb) THEN
+                 ALBEDO(I,J)=SNOALB(I,J)
+             ELSE
+                 ALBEDO(I,J)=ALBBCK(I,J)*(1.+SCFX(IS))
+             ENDIF
+          ENDIF
+          THC(I,J)=THERIN(IS,ISN)/100.
+          Z0(I,J)=SFZ0(IS,ISN)/100.
+          ZNT(I,J)=Z0(I,J)
+          EMBCK(I,J)=SFEM(IS,ISN)
+          EMISS(I,J)=EMBCK(I,J)
+          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
+          XICEM(I,J)=XICE(I,J)
+          IF(XICE(I,J).GE.xice_threshold)THEN
+            XLAND(I,J)=1.0
+            ALBBCK(I,J)=ALBD(ISICE,ISN)/100.
+            EMBCK(I,J)=SFEM(ISICE,ISN)
+            IF (FRACTIONAL_SEAICE == 1) THEN
+               ! The 0.08 value is the albedo over open water.
+               ! The 0.98 value is the emissivity over open water.
+               ALBEDO(I,J) = ( XICE(I,J) * ALBBCK(I,J) ) + ( (1.0-XICE(I,J)) * 0.08 )
+               EMISS(I,J)  = ( XICE(I,J) * EMBCK(I,J)  ) + ( (1.0-XICE(I,J)) * 0.98 )
+            ELSE
+               ALBEDO(I,J)=ALBBCK(I,J)
+               EMISS(I,J)=EMBCK(I,J)
+            ENDIF
+            THC(I,J)=THERIN(ISICE,ISN)/100.
+            Z0(I,J)=SFZ0(ISICE,ISN)/100.
+            ZNT(I,J)=Z0(I,J)
+            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
+
+
+   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,p_top,            &
+                      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      , ONLY : rrtminit
+   USE module_ra_rrtmg_lw  , ONLY : rrtmg_lwinit
+   USE module_ra_rrtmg_sw  , ONLY : rrtmg_swinit
+   USE module_ra_cam       , ONLY : camradinit
+   USE module_ra_sw        , ONLY : swinit
+   USE module_ra_gsfcsw    , ONLY : gsfc_swinit
+   USE module_ra_gfdleta   , ONLY : gfdletainit
+#if(NMM_CORE==1)
+   USE module_ra_hwrf      , ONLY : hwrfrainit
+#endif
+   USE module_ra_hs        , ONLY : hsinit
+   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, p_top
+   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 :: hwrflw= .false.
+   LOGICAL :: camlw = .false.
+   LOGICAL :: etamp = .false.
+   LOGICAL :: acswalloc = .false.
+   LOGICAL :: aclwalloc = .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(                                 &
+                           p_top, 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.
+             aclwalloc = .true.
+
+        CASE (RRTMG_LWSCHEME)
+             CALL rrtmg_lwinit(                             &
+                           p_top, allowed_to_read ,         &
+                           ids, ide, jds, jde, kds, kde,    &
+                           ims, ime, jms, jme, kms, kme,    &
+                           its, ite, jts, jte, kts, kte     )
+
+             aclwalloc = .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.
+#if(NMM_CORE==1)
+        CASE (HWRFLWSCHEME)
+             CALL nl_get_start_month(id,month)
+             CALL nl_get_start_day(id,iday)
+! test this with standard jul-day calls
+!     CALL nl_get_start_year(id,start_year)
+!     CALL nl_get_start_month(id,start_month)
+!     CALL nl_get_start_day(id,start_day)
+!     CALL nl_get_start_hour(id,start_hour)
+!     CALL nl_get_start_minute(id,start_minute)
+!     CALL nl_get_start_second(id,start_second)
+!     CALL jdn_sec(day_in_sec,start_year,start_month,start_day,0,0,0)
+!     CALL jdn_sec(day_in_sec_ref,start_year,1,1,0,0,0)
+!     julyr_start=start_year
+!     julday_start=(day_in_sec-day_in_sec_ref)/(3600.*24.)+1
+!     gmt_start=start_hour+real(start_minute)/60.+real(start_second)/3600.
+              CALL hwrfrainit(sfull,shalf,pptop,JULYR,MONTH,IDAY,GMT,&
+!             CALL hwrfrainit(sfull,shalf,pptop,JULYR_start,MONTH,IDAY,GMT_start,&
+                           allowed_to_read ,                         &
+                           kds, kde, kms, kme, kts, kte     )
+             hwrflw = .true.
+#endif
+        CASE (HELDSUAREZ)
+             CALL hsinit(RTHRATEN,restart,             &
+                         ids, ide, jds, jde, kds, kde, &
+                         ims, ime, jms, jme, kms, kme, &
+                         its, ite, jts, jte, kts, kte )
+        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
+             acswalloc = .true.
+
+        CASE (GSFCSWSCHEME)
+             CALL gsfc_swinit(cen_lat, allowed_to_read )
+
+        CASE (RRTMG_SWSCHEME)
+             CALL rrtmg_swinit(                             &
+                           allowed_to_read ,                &
+                           ids, ide, jds, jde, kds, kde,    &
+                           ims, ime, jms, jme, kms, kme,    &
+                           its, ite, jts, jte, kts, kte     )
+
+             acswalloc = .true.
+
+        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
+#if(NMM_CORE==1)
+        CASE (HWRFSWSCHEME)
+             IF(.not.hwrflw)THEN
+             CALL nl_get_start_month(id,month)
+             CALL nl_get_start_day(id,iday)
+             CALL hwrfrainit(sfull,shalf,pptop,JULYR,MONTH,IDAY,GMT,&
+                           allowed_to_read,                          &
+                           kds, kde, kms, kme, kts, kte     )
+             ENDIF
+#endif
+        CASE DEFAULT
+
+   END SELECT swrad_select
+
+#if ( EM_CORE == 1 ) 
+   ! test for conditionally allocated arrays when using bucket_J
+
+   IF(config_flags%bucket_J .gt. 0.0)THEN
+     IF(.not. (acswalloc .and. aclwalloc))THEN
+           CALL wrf_error_fatal ( 'Need CAM or RRTMG radiation for bucket_J option')
+     ENDIF
+   ENDIF
+#endif
+
+   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_PBL,                        &
+                EXCH_H,VEGFRA,                                  &
+                SNOW,SNOWC, CANWAT,SMSTAV,                      &
+                SMSTOT, SFCRUNOFF,UDRUNOFF,ACSNOW,ACSNOM,       &
+                IVGTYP,ISLTYP,ISURBAN,SMOIS,SMFR3D,mavail,      &
+                SNOWH,SH2O,SNOALB,FNDSOILW,FNDSNOWH,RDMAXALB,   &
+#if  ( NMM_CORE == 1 )
+                Z0,XLAND,XICE,                                  &
+#else
+                ZNT,XLAND,XICE,                                 &
+#endif
+                SFCEVP,GRDFLX,                                  &
+                MMINLU,                                         &
+                allowed_to_read,                                &
+                start_of_simulation,                            &
+                te_temf,cf3d_temf,wm_temf,                      & ! WA
+!                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,               &
+                SF_URBAN_PHYSICS,                               & !Optional urban
+                NUM_URBAN_LAYERS,                               & !Optional multi-layer urban
+                TRB_URB4D,TW1_URB4D,TW2_URB4D,                  & !Optional multi-layer urban
+                TGB_URB4D,TLEV_URB3D,QLEV_URB3D,                & !Optional multi-layer urban
+                TW1LEV_URB3D,TW2LEV_URB3D,                      & !Optional multi-layer urban
+                TGLEV_URB3D,TFLEV_URB3D,                        & !Optional multi-layer urban
+                SF_AC_URB3D,LF_AC_URB3D,CM_AC_URB3D,            & !Optional multi-layer urban
+                SFVENT_URB3D,LFVENT_URB3D,                      & !Optional multi-layer urban
+                SFWIN1_URB3D,SFWIN2_URB3D,                      & !Optional multi-layer urban
+                SFW1_URB3D,SFW2_URB3D,                          & !Optional multi-layer urban
+                SFR_URB3D,SFG_URB3D,                            & !Optional multi-layer urban
+                A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP,                & !Optional multi-layer urban
+                A_E_BEP,B_U_BEP,B_V_BEP,                        & !Optional multi-layer urban
+                B_T_BEP,B_Q_BEP,B_E_BEP,DLG_BEP,                & !Optional multi-layer urban
+                DL_U_BEP,SF_BEP,VL_BEP,                         & !Optional multi-layer urban
+                ids, ide, jds, jde, kds, kde,                   &
+                ims, ime, jms, jme, kms, kme,                   &
+                its, ite, jts, jte, kts, kte,                   &
+                ACHFX,ACLHF,ACGRDFLX,                           &
+                oml_hml0, omlcall,                              & !Optional oml
+                TML,T0ML,HML,H0ML,HUML,HVML,TMOML               ) !Optional oml
+!--------------------------------------------------------------------
+   USE module_sf_sfclay
+   USE module_sf_slab
+   USE module_sf_pxsfclay
+   USE module_bl_ysu
+   USE module_bl_mrf
+   USE module_bl_gfs
+   USE module_bl_acm
+   USE module_sf_myjsfc
+   USE module_sf_qnsesfc
+   USE module_sf_noahdrv
+   USE module_sf_urban
+   USE module_sf_bep                                  !BEP
+   USE module_sf_bep_bem
+   USE module_sf_ruclsm
+   USE module_sf_pxlsm
+   USE module_sf_oml
+   USE module_bl_myjpbl
+   USE module_bl_myjurb
+   USE module_bl_boulac
+   USE module_bl_camuwpbl_driver, ONLY :  camuwpblinit
+   USE module_bl_qnsepbl
+#if ( EM_CORE == 1 )
+   USE module_bl_mynn
+   USE module_bl_temf
+   USE module_sf_temfsfclay
+   USE module_sf_mynn
+#endif
+
+#if (NMM_CORE == 1)
+   USE module_sf_gfdl
+#endif
+!--------------------------------------------------------------------
+   IMPLICIT NONE
+!--------------------------------------------------------------------
+   TYPE (grid_config_rec_type) ::     config_flags
+   LOGICAL , INTENT(IN)        :: restart
+   LOGICAL, INTENT(IN)         ::   FNDSOILW, FNDSNOWH
+   LOGICAL, INTENT(IN)         ::   RDMAXALB
+
+   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)        ::     SF_URBAN_PHYSICS 
+
+   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, &
+                                                        SNOALB, &
+                                                        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_PBL
+   REAL,  DIMENSION( ims:ime , jms:jme ) , INTENT(IN) ::     TSK
+   REAL,  DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) ::  TMN
+   CHARACTER(LEN=*), INTENT(IN)   :: MMINLU
+   LOGICAL,  INTENT(IN)           :: allowed_to_read
+   INTEGER,  INTENT(IN)           :: ISURBAN
+   INTEGER :: isn, isfc
+   INTEGER :: k
+
+   REAL, OPTIONAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , &
+            INTENT(OUT) :: te_temf, cf3d_temf !WA 
+   REAL, OPTIONAL, DIMENSION( ims:ime , jms:jme ) , &
+            INTENT(OUT) :: wm_temf
+
+!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
+
+    INTEGER , INTENT(IN)        ::     num_urban_layers
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TRB_URB4D !Optional UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW1_URB4D !Optional UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW2_URB4D !Optional UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TGB_URB4D !Optional UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TLEV_URB3D !Optional UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: QLEV_URB3D !Optional UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW1LEV_URB3D ! multi-layer UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW2LEV_URB3D ! multi-layer UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TGLEV_URB3D ! multi-layer UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TFLEV_URB3D ! multi-layer UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LF_AC_URB3D  !multi-layer UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SF_AC_URB3D  !multi-layer UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CM_AC_URB3D  !multi-layer UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SFVENT_URB3D !multi-layer UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LFVENT_URB3D !multi-layer UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN1_URB3D ! multi-layer UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN2_URB3D ! multi-layer UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFW1_URB3D !Optional UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFW2_URB3D !Optional UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFR_URB3D !Optional UCM
+    REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFG_URB3D !Optional UCM
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_U_BEP 
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_V_BEP 
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_T_BEP 
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_Q_BEP 
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_E_BEP 
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_U_BEP 
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_V_BEP 
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_T_BEP 
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_Q_BEP 
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_E_BEP 
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: VL_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: DLG_BEP 
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme,jms:jme),INTENT(INOUT) :: SF_BEP
+   REAL, OPTIONAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: DL_U_BEP
+
+   REAL,  DIMENSION( ims:ime , jms:jme ) , OPTIONAL, INTENT(INOUT) ::    &
+                                        ACHFX,ACLHF,ACGRDFLX
+! Optional OML variables
+   REAL,  DIMENSION( ims:ime , jms:jme ) , OPTIONAL, INTENT(INOUT) ::    &
+                                        TML,T0ML,HML,H0ML,HUML,HVML,TMOML
+   INTEGER,  OPTIONAL,  INTENT(IN) :: omlcall
+   REAL,  OPTIONAL,  INTENT(IN) :: oml_hml0
+   LOGICAL,  INTENT(IN) :: start_of_simulation
+   INTEGER :: i,j
+
+
+#if ( EM_CORE == 1 )
+!local mynn 
+   INTEGER :: mynn_closure_level
+#endif
+
+!-- calculate pbl time step
+
+   STEPBL = nint(BLDT*60./DT)
+   STEPBL = max(STEPBL,1)
+!-- initialization
+
+   IF(PRESENT(ACHFX))THEN
+   IF(.not.restart)THEN
+     DO j=jts,jte
+     DO i=its,ite
+        ACHFX(i,j)=0.
+        ACLHF(i,j)=0.
+        ACGRDFLX(i,j)=0.
+        SFCEVP(i,j)=0.
+     ENDDO
+     ENDDO
+   ENDIF
+   ENDIF
+
+!-- initialize surface layer scheme
+
+   sfclay_select: SELECT CASE(config_flags%sf_sfclay_physics)
+
+      CASE (SFCLAYSCHEME)
+           CALL sfclayinit( allowed_to_read )
+           isfc = 1
+      CASE (PXSFCSCHEME)
+           CALL pxsfclayinit( allowed_to_read )
+           isfc = 7
+      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 (QNSESFCSCHEME)
+           CALL qnsesfcinit(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 = 4
+
+      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 = 2
+#if (NMM_CORE==1)
+      CASE (GFDLSFCSCHEME)
+           CALL myjsfcinit(LOWLYR,UST,                         &
+                                      Z0,                      &
+                                          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
+#endif
+
+#if ( EM_CORE == 1 )
+!mynn 
+
+        CASE (MYNNSFCSCHEME)
+
+           CALL mynn_sf_init_driver(allowed_to_read)
+           isfc=5
+!          isfc=3
+
+      CASE (TEMFSFCSCHEME)
+           CALL wrf_debug( 100, 'calling temfsfclayinit' )
+           CALL temfsfclayinit( restart, allowed_to_read ,        &
+                             wm_temf,                          &
+                         ids, ide, jds, jde, kds, kde,         &
+                         ims, ime, jms, jme, kms, kme,         &
+                         its, ite, jts, jte, kts, kte          )
+#endif
+
+      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,          &
+                         allowed_to_read ,start_of_simulation ,&
+                         ids, ide, jds, jde, kds, kde,         &
+                         ims, ime, jms, jme, kms, kme,         &
+                         its, ite, jts, jte, kts, kte          )
+
+#if (NMM_CORE == 1)
+     CASE (GFDLSLAB)
+           CALL hwrfsfcinit(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, &
+                     MMINLU,                                   &
+                     SNOALB, FNDSOILW, FNDSNOWH, RDMAXALB,     &
+                     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 ((SF_URBAN_PHYSICS.eq.1).OR.(SF_URBAN_PHYSICS.EQ.2).OR.(SF_URBAN_PHYSICS.EQ.3)) THEN
+
+             IF ( PRESENT( FRC_URB2D ) .AND. PRESENT( UTYPE_URB2D )) THEN
+                
+                CALL urban_param_init(DZR,DZB,DZG,num_soil_layers,                   & !urban
+                                sf_urban_physics)
+!                                num_roof_layers,num_wall_layers,road_soil_layers)   !urban
+                               
+                
+                CALL urban_var_init(ISURBAN,TSK,TSLB,TMN,IVGTYP,                     & !urban
+                              ims,ime,jms,jme,kms,kme,num_soil_layers,               & !urban
+!                              num_roof_layers,num_wall_layers,num_road_layers, & !urban
+                              restart,sf_urban_physics,                        & !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
+                              num_urban_layers,                                & !urban
+                              TRB_URB4D,TW1_URB4D,TW2_URB4D,TGB_URB4D,         & !urban
+                              TLEV_URB3D,QLEV_URB3D,                           & !urban
+                              TW1LEV_URB3D,TW2LEV_URB3D,                       & !urban
+                              TGLEV_URB3D,TFLEV_URB3D,                         & !urban
+                              SF_AC_URB3D,LF_AC_URB3D,CM_AC_URB3D,             & !urban
+                              SFVENT_URB3D,LFVENT_URB3D,                       & !urban
+                              SFWIN1_URB3D,SFWIN2_URB3D,                       & !urban
+                              SFW1_URB3D,SFW2_URB3D,SFR_URB3D,SFG_URB3D,       & !urban
+                              A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP,                 & !multi-layer urban
+                              A_E_BEP,B_U_BEP,B_V_BEP,                         & !multi-layer urban
+                              B_T_BEP,B_Q_BEP,B_E_BEP,DLG_BEP,                 & !multi-layer urban
+                              DL_U_BEP,SF_BEP,VL_BEP,                          & !multi-layer 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 ruclsminit( SH2O,SMFR3D,TSLB,SMOIS,ISLTYP,IVGTYP,XICE,  &
+                     mavail,num_soil_layers, config_flags%iswater,      &
+                     config_flags%isice, restart,                  &
+                     allowed_to_read ,                             &
+                     ids,ide, jds,jde, kds,kde,                    &
+                     ims,ime, jms,jme, kms,kme,                    &
+                     its,ite, jts,jte, kts,kte                     )
+
+      CASE (PXLSMSCHEME)
+          CALL LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV,  &
+                     SMSTOT, SFCRUNOFF,UDRUNOFF,ACSNOW,        &
+                     ACSNOM,IVGTYP,ISLTYP,TSLB,SMOIS,SH2O,ZS,DZS, &
+                     MMINLU,                                   &
+                     SNOALB, FNDSOILW, FNDSNOWH, RDMAXALB,     &
+                     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
+
+   IF(PRESENT(OMLCALL))THEN
+     IF (omlcall .EQ. 1) THEN
+        CALL omlinit(oml_hml0, tsk,                           &
+                     tml,t0ml,hml,h0ml,huml,hvml,tmoml,       &
+                     allowed_to_read, start_of_simulation,    &
+                     ids,ide, jds,jde, kds,kde,               &
+                     ims,ime, jms,jme, kms,kme,               &
+                     its,ite, jts,jte, kts,kte                )
+     ENDIF
+   ENDIF
+
+!-- 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' )
+           IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal &
+            ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' )
+           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' )
+           IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal &
+            ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' )
+           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 (ACMPBLSCHEME)
+           if(isfc .ne. 1 .and. isfc .ne. 7)CALL wrf_error_fatal &
+            ( 'module_physics_init: use sfclay or pxsfc scheme for this pbl option' )
+           IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal &
+            ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' )
+           CALL acminit(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. 2)CALL wrf_error_fatal &
+            ( 'module_physics_init: use myjsfc scheme for this pbl option' )
+           IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal &
+            ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' )
+           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' )
+          IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) THEN
+           CALL myjurbinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, &
+                        TKE_PBL,EXCH_H,restart,               &
+                        allowed_to_read ,                     &
+                        ids, ide, jds, jde, kds, kde,         &
+                        ims, ime, jms, jme, kms, kme,         &
+                        its, ite, jts, jte, kts, kte          )
+          ELSE
+
+           CALL myjpblinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, &
+                        TKE_PBL,EXCH_H,restart,               &
+                        allowed_to_read ,                     &
+                        ids, ide, jds, jde, kds, kde,         &
+                        ims, ime, jms, jme, kms, kme,         &
+                        its, ite, jts, jte, kts, kte          )
+          END IF
+      CASE (QNSEPBLSCHEME)
+           if(isfc .ne. 4)CALL wrf_error_fatal &
+            ( 'module_physics_init: use qnsesfc scheme for this pbl option' )
+           IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal &
+            ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' )
+           CALL qnsepblinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, &
+                        TKE_PBL,EXCH_H,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 (BOULACSCHEME)
+           if(isfc .ne. 1 .and. isfc .ne. 2)CALL wrf_error_fatal &
+            ( 'module_physics_init: use sfclay or myjsfc scheme for this pbl option' )
+           CALL boulacinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, &
+                         TKE_PBL,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 (CAMUWPBLSCHEME)
+           IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal &
+            ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' )
+           CALL camuwpblinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, &
+                restart,TKE_PBL,config_flags%grid_id,           &
+                ids, ide, jds, jde, kds, kde,         &
+                ims, ime, jms, jme, kms, kme,         &
+                its, ite, jts, jte, kts, kte          )
+#endif
+
+#if ( EM_CORE == 1 )
+
+!mynn 
+           
+        CASE (MYNNPBLSCHEME2, MYNNPBLSCHEME3)
+           IF(isfc .NE. 5 .AND. isfc .NE. 1 .AND. isfc .NE. 2) CALL wrf_error_fatal &
+                ( 'module_physics_init: use mynnsfc or sfclay or myjsfc scheme for this pbl option')
+           IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal &
+            ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' )
+           
+           SELECT CASE(config_flags%bl_pbl_physics)
+
+             CASE(MYNNPBLSCHEME2)
+                mynn_closure_level=2
+
+             CASE(MYNNPBLSCHEME3)
+                mynn_closure_level=3
+
+             CASE DEFAULT
+
+           END SELECT
+
+           CALL mynn_bl_init_driver(&
+                &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN&
+                &,restart,allowed_to_read,mynn_closure_level &
+                &,IDS,IDE,JDS,JDE,KDS,KDE                    &
+                &,IMS,IME,JMS,JME,KMS,KME                    &
+                &,ITS,ITE,JTS,JTE,KTS,KTE)
+
+      CASE (TEMFPBLSCHEME)
+           ! if(isfc .ne. 0)CALL wrf_error_fatal &
+           !  ( 'module_physics_init: use sfclay scheme = 0 for this pbl option' )
+           IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal &
+            ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' )
+         IF ( PRESENT( te_temf ) .AND. PRESENT( cf3d_temf )) THEN
+           CALL temfinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,    &
+                        RQCBLTEN,RQIBLTEN,P_QI,               &
+                        PARAM_FIRST_SCALAR,                   &
+                        restart,                              &
+                        allowed_to_read ,                     &
+                        te_temf,cf3d_temf,                    & ! WA
+                        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 TEMF scheme' )
+         ENDIF
+
+#endif
+
+      CASE DEFAULT
+
+   END SELECT pbl_select
+
+
+   END SUBROUTINE bl_init
+
+!==================================================================
+   SUBROUTINE cu_init(STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,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,               &
+                      cugd_tten,cugd_ttens,cugd_qvten,             &
+                      cugd_qvtens,cugd_qcten,                      &
+                      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,  ONLY : GDINIT
+   USE module_cu_g3,  ONLY : G3INIT
+   USE module_cu_sas
+   USE module_cu_camzm_driver, ONLY : zm_conv_init
+   USE module_cu_nsas
+   USE module_cu_tiedtke
+!------------------------------------------------------------------
+   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) ::    &
+            RUCUTEN, RVCUTEN, RTHCUTEN, &
+            RQVCUTEN, RQCCUTEN, RQRCUTEN, RQICUTEN, RQSCUTEN
+   REAL ,   DIMENSION( ims:ime , kms:kme , jms:jme ) , OPTIONAL, INTENT(INOUT) ::    &
+                        cugd_tten,cugd_ttens,cugd_qvten,            &
+                        cugd_qvtens,cugd_qcten
+
+   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
+
+!-- deep convection and hybrid deep-shallow convection schemes
+   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 (NSASSCHEME)
+         CALL nsasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,       &
+                      RUCUTEN,RVCUTEN,                            & 
+                      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                )
+
+#if ( EM_CORE == 1 )
+     CASE (G3SCHEME)
+          CALL g3init(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,              &
+                      cugd_tten,cugd_ttens,cugd_qvten,            &
+                      cugd_qvtens,cugd_qcten,                     &
+                      allowed_to_read ,                           &
+                      ids, ide, jds, jde, kds, kde,               &
+                      ims, ime, jms, jme, kms, kme,               &
+                      its, ite, jts, jte, kts, kte                )
+#endif
+     CASE (SASSCHEME)
+          CALL sasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,       &
+                      RUCUTEN,RVCUTEN,                            &   ! gopal's doing for SAS
+                      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 (CAMZMSCHEME)
+          CALL zm_conv_init(rucuten, rvcuten, rthcuten, rqvcuten,       &
+                      rqccuten, rqicuten,                               &
+                      p_qc, p_qi, param_first_scalar,                   &
+                      restart,                                          &
+                      ids, ide, jds, jde, kds, kde,                     &
+                      ims, ime, jms, jme, kms, kme,                     &
+                      its, ite, jts, jte, kts, kte                      )
+
+! Tiedtke Scheme - ZCX&YQW
+      CASE (TIEDTKESCHEME)
+          CALL tiedtkeinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,   &
+                      RUCUTEN,RVCUTEN,                            & 
+                      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 shcu_init(STEPCU,CUDT,DT,RUSHTEN,RVSHTEN,RTHSHTEN,   &
+                      RQVSHTEN,RQRSHTEN,RQCSHTEN,                  &
+                      RQSSHTEN,RQISHTEN,RQGSHTEN,                  &
+                      NCA,RAINC,RAINCV,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 uwshcu,        ONLY: init_uwshcu
+   USE physconst,     ONLY: cpair, gravit, latice, latvap, mwdry, mwh2o, &
+                            rair, zvir
+   USE shr_kind_mod,  ONLY: r8 => shr_kind_r8
+
+!------------------------------------------------------------------
+   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) ::    &
+            RUSHTEN, RVSHTEN, RTHSHTEN, &
+            RQVSHTEN, RQCSHTEN, RQRSHTEN, RQISHTEN, RQSSHTEN, RQGSHTEN
+
+   REAL ,   DIMENSION( ims:ime , jms:jme ), INTENT(OUT):: RAINC, RAINCV
+
+   REAL ,   DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: NCA
+
+! LOCAL VAR
+
+  INTEGER :: i,j,itf,jtf
+
+!--------------------------------------------------------------------
+
+! Some of this stuff is redundant with deep convection, but redo it
+! in case deep is turned off...
+
+!-- 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
+
+!-- independent shallow convection schemes
+   shcu_select: SELECT CASE(config_flags%shcu_physics)
+
+   CASE (CAMUWSHCUSCHEME)
+      CALL init_uwshcu(r8,latvap,cpair,latice,zvir,rair,gravit,      &
+           mwh2o/mwdry,                                              &
+           rushten, rvshten, rthshten, rqvshten,                     &
+           rqcshten, rqrshten, rqishten, rqsshten, rqgshten,         &
+           p_qc, p_qr, p_qi, p_qs, p_qg,                             &
+           config_flags%bl_pbl_physics, param_first_scalar, restart, &
+           config_flags%grid_id,                                     &
+           ids, ide, jds, jde, kds, kde,                             &
+           ims, ime, jms, jme, kms, kme,                             &
+           its, ite, jts, jte, kts, kte                              )
+
+   CASE DEFAULT
+
+   END SELECT shcu_select
+
+   END SUBROUTINE shcu_init
+
+!==================================================================
+   SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,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_wsm3
+   USE module_mp_wsm5
+   USE module_mp_wsm6
+   USE module_mp_etanew
+#if (NMM_CORE == 1)
+   USE module_mp_HWRF
+#endif
+   USE module_mp_thompson
+   USE module_mp_morr_two_moment
+   USE module_mp_milbrandt2mom
+!  USE module_mp_milbrandt3mom
+   USE module_mp_wdm5
+   USE module_mp_wdm6
+!------------------------------------------------------------------
+   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,SNOWNC,GRAUPELNC
+   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.
+        SNOWNC(i,j) = 0.
+        GRAUPELNC(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,cpv, allowed_to_read )
+     CASE (WSM5SCHEME)
+          CALL wsm5init(rhoair0,rhowater,rhosnow,cliq,cpv, allowed_to_read )
+     CASE (WSM6SCHEME)
+          CALL wsm6init(rhoair0,rhowater,rhosnow,cliq,cpv, 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            )
+#if(NMM_CORE==1)
+     CASE (etamp_HWRF)
+         CALL etanewinit_HWRF (MPDT,DT,DX,DY,LOWLYR,restart,           &
+                          F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,       &
+                          allowed_to_read,                        &
+                          ids, ide, jds, jde, kds, kde,           &
+                          ims, ime, jms, jme, kms, kme,           &
+                          its, ite, jts, jte, kts, kte            )
+#endif 
+     CASE (THOMPSON)
+! Cycling the WRF forecast with moving nests will cause this initialization to be
+! called for each nest move. This is potentially very computationally expensive.
+         IF(start_of_simulation.or.restart.or.config_flags%cycling)CALL thompson_init
+
+     CASE (MORR_TWO_MOMENT)
+         CALL morr_two_moment_init
+     CASE (MILBRANDT2MOM)
+         CALL milbrandt2mom_init
+!      CASE (MILBRANDT3MOM)
+!          CALL milbrandt3mom_init
+     CASE (WDM5SCHEME)
+          CALL wdm5init(rhoair0,rhowater,rhosnow,cliq,cpv,n_ccn0,allowed_to_read )
+     CASE (WDM6SCHEME)
+          CALL wdm6init(rhoair0,rhowater,rhosnow,cliq,cpv,n_ccn0,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,RPHNDGDTEN,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
+   USE module_fdda_spnudging, ONLY : fddaspnudginginit
+!--------------------------------------------------------------------
+   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, &
+                                                          RPHNDGDTEN, &
+                                                          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%auxinput10_end_h, &
+               config_flags%grid_sfdda, &
+               config_flags%guv_sfc, &
+               config_flags%gt_sfc, &
+               config_flags%gq_sfc, &
+                      restart, allowed_to_read,                    &
+                      ids, ide, jds, jde, kds, kde,                &
+                      ims, ime, jms, jme, kms, kme,                &
+                      its, ite, jts, jte, kts, kte                 )
+
+      CASE (SPNUDGING)
+           CALL fddaspnudginginit(id,rundgdten,rvndgdten,rthndgdten,rphndgdten,&
+               config_flags%run_hours, &
+               config_flags%if_no_pbl_nudging_uv, &
+               config_flags%if_no_pbl_nudging_t, &
+               config_flags%if_no_pbl_nudging_ph, &
+               config_flags%if_zfac_uv, &
+               config_flags%k_zfac_uv, &
+               config_flags%dk_zfac_uv, &
+               config_flags%if_zfac_t, &
+               config_flags%k_zfac_t, &
+               config_flags%dk_zfac_t, &
+               config_flags%if_zfac_ph, &
+               config_flags%k_zfac_ph, &
+               config_flags%dk_zfac_ph, &
+               config_flags%guv, &
+               config_flags%gt, config_flags%gph, &
+               config_flags%if_ramping, config_flags%dtramp_min, &
+               config_flags%auxinput9_end_h, &
+               config_flags%xwavenum,config_flags%ywavenum, &
+                      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,       &
+                        idynin, dtramp, fdaend, restart,           &
+                        obs_twindo_cg, obs_twindo, itimestep,      &
+                        no_pbl_nudge_uv,                           &
+                        no_pbl_nudge_t,                            &
+                        no_pbl_nudge_q,                            &
+                        sfc_scheme_horiz, sfc_scheme_vert,         &
+                        maxsnd_gap,                                &
+                        sfcfact, sfcfacr, dpsmx,                   &
+                        nudge_wind, nudge_temp, nudge_mois,        &
+                        nudgezfullr1_uv, nudgezrampr1_uv,          &
+                        nudgezfullr2_uv, nudgezrampr2_uv,          &
+                        nudgezfullr4_uv, nudgezrampr4_uv,          &
+                        nudgezfullr1_t,  nudgezrampr1_t,           &
+                        nudgezfullr2_t,  nudgezrampr2_t,           &
+                        nudgezfullr4_t,  nudgezrampr4_t,           &
+                        nudgezfullr1_q,  nudgezrampr1_q,           &
+                        nudgezfullr2_q,  nudgezrampr2_q,           &
+                        nudgezfullr4_q,  nudgezrampr4_q,           &
+                        nudgezfullmin, nudgezrampmin, nudgezmax,   &
+                        xlat, xlong,                               &
+                        start_year, start_month, start_day,        &
+                        start_hour, start_minute, start_second,    &
+                        p00, t00, tlp,                             &
+                        znu, p_top,                                &
+                        fdob, ipf_init,                            &
+                        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
+   USE module_llxy
+!--------------------------------------------------------------------
+   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)
+   INTEGER , INTENT(IN)    :: idynin          ! flag for dynamic initialization
+   REAL    , INTENT(IN)    :: dtramp          ! time period for ramping (idynin)
+   REAL    , INTENT(IN)    :: fdaend(maxdom)  ! nudging end time for domain (min)
+   LOGICAL , INTENT(IN)    :: restart
+   REAL    , INTENT(IN)    :: obs_twindo_cg   ! twindo on course grid
+   REAL    , INTENT(IN)    :: obs_twindo
+   INTEGER , INTENT(IN)    :: itimestep
+   INTEGER , INTENT(IN)    :: no_pbl_nudge_uv(maxdom)  ! flags for no wind nudging in pbl
+   INTEGER , INTENT(IN)    :: no_pbl_nudge_t(maxdom)   ! flags for no temperature nudging in pbl
+   INTEGER , INTENT(IN)    :: no_pbl_nudge_q(maxdom)   ! flags for no moisture nudging in pbl
+   INTEGER , INTENT(IN)    :: sfc_scheme_horiz ! horizontal spreading scheme for surf obs (wrf or orig mm5)
+   INTEGER , INTENT(IN)    :: sfc_scheme_vert  ! vertical   spreading scheme for surf obs (orig or regime vif)
+   REAL    , INTENT(IN)    :: maxsnd_gap       ! max allowed pressure gap in soundings for interp (centibars) 
+   REAL    , INTENT(IN)    :: sfcfact      ! scale factor applied to time window for surface obs
+   REAL    , INTENT(IN)    :: sfcfacr      ! scale fac applied to horiz rad of infl for sfc obs
+   REAL    , INTENT(IN)    :: dpsmx        ! max pressure change allowed within horiz. infl. range
+   INTEGER , INTENT(IN)    :: nudge_wind(maxdom)       ! wind-nudging flag
+   INTEGER , INTENT(IN)    :: nudge_temp(maxdom)       ! temperature-nudging flag
+   INTEGER , INTENT(IN)    :: nudge_mois(maxdom)       ! moisture-nudging flag
+   REAL    , INTENT(IN)    :: nudgezfullr1_uv  ! vert infl fcn, regime=1 full-wt   hght, winds
+   REAL    , INTENT(IN)    :: nudgezrampr1_uv  ! vert infl fcn, regime=1 ramp down hght, winds
+   REAL    , INTENT(IN)    :: nudgezfullr2_uv  ! vert infl fcn, regime=2 full-wt   hght, winds
+   REAL    , INTENT(IN)    :: nudgezrampr2_uv  ! vert infl fcn, regime=2 ramp down hght, winds
+   REAL    , INTENT(IN)    :: nudgezfullr4_uv  ! vert infl fcn, regime=4 full-wt   hght, winds
+   REAL    , INTENT(IN)    :: nudgezrampr4_uv  ! vert infl fcn, regime=4 ramp down hght, winds
+   REAL    , INTENT(IN)    :: nudgezfullr1_t   ! vert infl fcn, regime=1 full-wt   hght, temp
+   REAL    , INTENT(IN)    :: nudgezrampr1_t   ! vert infl fcn, regime=1 ramp down hght, temp
+   REAL    , INTENT(IN)    :: nudgezfullr2_t   ! vert infl fcn, regime=2 full-wt   hght, temp
+   REAL    , INTENT(IN)    :: nudgezrampr2_t   ! vert infl fcn, regime=2 ramp down hght, temp
+   REAL    , INTENT(IN)    :: nudgezfullr4_t   ! vert infl fcn, regime=4 full-wt   hght, temp
+   REAL    , INTENT(IN)    :: nudgezrampr4_t   ! vert infl fcn, regime=4 ramp down hght, temp
+   REAL    , INTENT(IN)    :: nudgezfullr1_q   ! vert infl fcn, regime=1 full-wt   hght, mois
+   REAL    , INTENT(IN)    :: nudgezrampr1_q   ! vert infl fcn, regime=1 ramp down hght, mois
+   REAL    , INTENT(IN)    :: nudgezfullr2_q   ! vert infl fcn, regime=2 full-wt   hght, mois
+   REAL    , INTENT(IN)    :: nudgezrampr2_q   ! vert infl fcn, regime=2 ramp down hght, mois
+   REAL    , INTENT(IN)    :: nudgezfullr4_q   ! vert infl fcn, regime=4 full-wt   hght, mois
+   REAL    , INTENT(IN)    :: nudgezrampr4_q   ! vert infl fcn, regime=4 ramp down hght, mois
+   REAL    , INTENT(IN)    :: nudgezfullmin    ! min dpth thru which vert infl fcn remains 1.0 (m)
+   REAL    , INTENT(IN)    :: nudgezrampmin    ! min dpth thru which vif decreases 1.0 to 0.0 (m)
+   REAL    , INTENT(IN)    :: nudgezmax        ! max dpth in which vif is nonzero (m)
+   REAL    , INTENT(IN)    :: xlat ( ims:ime, jms:jme )        ! latitudes on mass-point grid
+   REAL    , INTENT(IN)    :: xlong( ims:ime, jms:jme )        ! longitudes on mass-point grid
+   INTEGER , INTENT(INOUT) :: start_year
+   INTEGER , INTENT(INOUT) :: start_month
+   INTEGER , INTENT(INOUT) :: start_day
+   INTEGER , INTENT(INOUT) :: start_hour
+   INTEGER , INTENT(INOUT) :: start_minute
+   INTEGER , INTENT(INOUT) :: start_second
+   REAL    , INTENT(IN)    :: p00                      ! base state pressure
+   REAL    , INTENT(IN)    :: t00                      ! base state temperature
+   REAL    , INTENT(IN)    :: tlp                      ! base state lapse rate
+   REAL    , INTENT(IN)    :: znu( kms:kme )           ! eta values on half (mass) levels
+   REAL    , INTENT(IN)    :: p_top                    ! pressure at top of model
+   TYPE(fdob_type), INTENT(INOUT)  :: fdob
+
+   INTEGER                 :: e_sn         ! ending   north-south grid index
+   LOGICAL                 :: ipf_init     ! print warnings detected at initialzn
+!--------------------------------------------------------------------
+!-- initialize fdda obs-nudging scheme
+
+      IF ( obs_nudge_opt(inest) .eq. 0 ) RETURN
+
+      e_sn = jde
+      CALL fddaobs_init(obs_nudge_opt, maxdom, inest, parid,       &
+                        idynin, dtramp, fdaend, restart,           &
+                        obs_twindo_cg,                             &
+                        obs_twindo, itimestep,                     &
+                        no_pbl_nudge_uv,                           &
+                        no_pbl_nudge_t,                            &
+                        no_pbl_nudge_q,                            &
+                        sfc_scheme_horiz, sfc_scheme_vert,         &
+                        maxsnd_gap,                                &
+                        sfcfact, sfcfacr, dpsmx,                   &
+                        nudge_wind, nudge_temp, nudge_mois,        &
+                        nudgezfullr1_uv, nudgezrampr1_uv,          &
+                        nudgezfullr2_uv, nudgezrampr2_uv,          &
+                        nudgezfullr4_uv, nudgezrampr4_uv,          &
+                        nudgezfullr1_t,  nudgezrampr1_t,           &
+                        nudgezfullr2_t,  nudgezrampr2_t,           &
+                        nudgezfullr4_t,  nudgezrampr4_t,           &
+                        nudgezfullr1_q,  nudgezrampr1_q,           &
+                        nudgezfullr2_q,  nudgezrampr2_q,           &
+                        nudgezfullr4_q,  nudgezrampr4_q,           &
+                        nudgezfullmin,  nudgezrampmin, nudgezmax,  &
+                        xlat, xlong,                               &
+                        start_year, start_month, start_day,        &
+                        start_hour, start_minute, start_second,    &
+                        p00, t00, tlp,                             &
+                        znu, p_top,                                &
+                        fdob, ipf_init,                            &
+                        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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_progtm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_progtm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_progtm.F	(revision 17)
@@ -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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_HWRF.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_HWRF.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_HWRF.F	(revision 17)
@@ -0,0 +1,10028 @@
+!WRF:MODEL_RA:RADIATION
+!
+!-----------------------------------------------------------------------
+!--  Search for "!GFDL" for changes to improve coupling with microphysics
+!-----------------------------------------------------------------------
+MODULE MODULE_RA_HWRF
+      USE MODULE_MODEL_CONSTANTS
+!GFDL      USE MODULE_MP_ETANEW, ONLY : RHGRD,FPVS
+      USE MODULE_MP_HWRF, ONLY : RHGRD_in,RHGRD_out,FPVS   !GFDL
+      INTEGER,PARAMETER :: NL=81
+      INTEGER,PARAMETER :: NBLY=15
+      REAL,PARAMETER :: RTHRESH=1.E-15
+
+      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
+! 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))
+CONTAINS
+
+!-----------------------------------------------------------------------
+      SUBROUTINE HWRFRAINIT(SFULL,SHALF,PPTOP,JULYR,MONTH,IDAY,GMT,    &
+     &                       ALLOWED_TO_READ,                           &
+     &                       KDS,KDE,KMS,KME,KTS,KTE)
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+      INTEGER,INTENT(IN) :: KDS,KDE,KMS,KME,KTS,KTE
+      REAL,DIMENSION(KMS:KME),INTENT(IN) :: SFULL, SHALF
+      INTEGER,INTENT(IN) :: JULYR,MONTH,IDAY
+      REAL,INTENT(IN) :: GMT,PPTOP
+      LOGICAL,INTENT(IN) :: ALLOWED_TO_READ
+      INTEGER :: IHRST,N
+      REAL :: PCLD
+      REAL :: SSLP=1013.25
+      REAL :: PTOP_HI=150.,PTOP_MID=350.,PTOP_LO=642.
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+!
+!***  INITIALIZE DIAGNOSTIC LOW,MIDDLE,HIGH CLOUD LAYER PRESSURE LIMITS.
+!
+      LTOP(1)=0
+      LTOP(2)=0
+      LTOP(3)=0
+!
+!dule      DO N=1,KTE
+      DO N=1,KTE-1
+        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
+!
+!***  USE CALL TO CONRAD FOR DIRECT READ OF CO2 FUNCTIONS
+!***  OTHERWISE CALL CO2O3.
+!
+      IF(ALLOWED_TO_READ)THEN
+#if (EM_CORE==1)
+        CALL CO2O3(SFULL,SHALF,PPTOP,KME-KMS,KME-KMS+1,KME-KMS+2)
+#endif
+#if (NMM_CORE==1)
+        CALL CONRAD(KDS,KDE,KMS,KME,KTS,KTE)
+#endif
+!
+        CALL O3CLIM
+        CALL TABLE
+        IHRST=NINT(GMT)
+        CALL SOLARD(IHRST,IDAY,MONTH,JULYR)
+      ENDIF
+!
+!-----------------------------------------------------------------------
+      END SUBROUTINE HWRFRAINIT
+!-----------------------------------------------------------------------
+!
+!
+!-----------------------------------------------------------------------
+      SUBROUTINE HWRFRA(DT,THRATEN,THRATENLW,THRATENSW,PI3D              & 
+     &                ,XLAND,P8W,DZ8W,RHO_PHY,P_PHY,T                   &
+     &                ,QV,QW,QI                                         & 
+     &                ,TSK2D,GLW,GSW                                    &
+     &                ,TOTSWDN,TOTLWDN,RSWTOA,RLWTOA,CZMEAN             & 
+     &                ,GLAT,GLON,HTOP,HBOT,htopr,hbotr,ALBEDO,CUPPT                 &
+     &                ,VEGFRA,SNOW,G,GMT                                &
+     &                ,NSTEPRA,NPHS,ITIMESTEP                           &
+     &                ,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
+
+      REAL,INTENT(INOUT),DIMENSION(ims:ime, kms:kme, jms:jme)::         &
+                                         THRATEN,THRATENLW,THRATENSW
+      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,            &
+     &                                               TOTLWDN,TOTSWDN
+      REAL,INTENT(OUT),DIMENSION(ims:ime, jms:jme):: CFRACL,CFRACM,     & !Added
+     &                                               CFRACH               !Added
+      REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QI,QV,   &
+     &                                                         QW,T
+!     REAL, INTENT(IN), DIMENSION(37*kte) :: RAD1,RAD2,RAD3,RAD4
+      LOGICAL, INTENT(IN) :: gfdl_lw,gfdl_sw
+
+      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
+
+      INTEGER :: IDAT(3),Jmonth,Jday
+      INTEGER :: I,J,K,KFLIP,IHRST
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      IF(GFDL_LW.AND.GFDL_SW )GO TO 100
+!
+! 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
+          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
+        HBOTR(I,J)=HBOT(I,J)
+        HTOPR(I,J)=HTOP(I,J)        
+      ENDDO
+      ENDDO
+
+      DO J=JTS,JTE
+      DO I=ITS,ITE
+        HBOT(I,J)=KTE+1-HBOT(I,J)
+        HTOP(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 SOLARD(R1,IHRST,IDAT)
+!     CALL SOLARD(R1,IHRST,JULDAY)
+!-----------------------------------------------------------------------
+      CALL RADTN (DT,TFLIP,QFLIP,QWFLIP,QIFLIP,                         &
+     &            PFLIP,P8WFLIP,XLAND,TSK2D,                            &
+     &            GLAT,GLON,HTOP,HBOT,ALBEDO,CUPPT,                     &
+     &            ACFRCV,NCFRCV,ACFRST,NCFRST,                          &
+     &            VEGFRA,SNOW,GLW,GSW,                                  &
+     &            TOTSWDN,TOTLWDN,                                      &
+     &            IDAT,IHRST,                                           &
+     &            NSTEPRA,NSTEPRA,NPHS,ITIMESTEP,                       &
+     &            TENDS,TENDL,RSWTOA,RLWTOA,CZMEAN,                     &
+     &            CFRACL,CFRACM,CFRACH,                                 &
+     &            IDS,IDE,JDS,JDE,KDS,KDE,                              &
+     &            IMS,IME,JMS,JME,KMS,KME,                              &
+     &            ITS,ITE,JTS,JTE,KTS,KTE                              )
+!-----------------------------------------------------------------------
+!
+      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) !Put in SW section
+            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.
+!
+      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)
+!!!         THRATEN(I,K,J)=THRATEN(I,K,J)+THRATENSW(I,K,J)  !Added
+          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
+!!!!    HBOT(I,J)=KTE+1-HBOT(I,J)
+!!!!    HTOP(I,J)=KTE+1-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 HWRFRA
+!
+!-----------------------------------------------------------------------
+      SUBROUTINE RADTN(DT,T,Q,QCW,QICE,                                 &
+     &                 PFLIP,P8WFLIP,XLAND,TSK2D,                       &
+     &                 GLAT,GLON,HTOP,HBOT,ALB,CUPPT,                   &
+!    &                 RAD1,RAD2,RAD3,RAD4,                             &
+!    &                 TABLE1,TABLE2,TABLE3,EM1,EM1WDE,EM3,             &
+     &                 ACFRCV,NCFRCV,ACFRST,NCFRST,                     &
+     &                 VEGFRC,SNO,GLW,GSW,                              & 
+     &                 RSWIN,RLWIN,                                     & !Added
+!    &                 IDAT,LTOP,IHRST,PRGFDL,                          &
+     &                 IDAT,IHRST,                                      &
+     &                 NRADS,NRADL,NPHS,NTSD,                           &
+!    &                 SKO3R,AB15WD,SKC1R,SKO2D,                        &
+!#$  &                 TENDS,TENDL,                                     &
+     &                 TENDS,TENDL,RSWTOA,RLWTOA,CZMEAN,                &
+     &                 CFRACL,CFRACM,CFRACH,                            & !Added
+     &                 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.
+
+! HTOP : (REAL) model layer number that is highest in the atmosphere
+!        in which convective cloud occurred since the previous call to the
+!        radiation driver.
+
+! HBOT : (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.
+
+! THS : potential temperature of the ground surface.
+
+! 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.
+
+! R1     : earth-sun distance in astronomical units.
+
+! NRADS : integer number of fundamental timesteps (our smallest
+!         timestep, i.e., the one for inertial gravity wave adjustment) 
+!         between updates of the shortwave tendencies.  Currently we 
+!         update the shortwave every hour.
+
+! NRADL : integer number of fundamental timesteps between updates of
+!         the longwave tendencies.  Currently we update the longwave 
+!         every two hours.
+
+! NTSD   : integer counter of the fundamental timesteps that have
+!         elapsed since the start of the forecast.
+!
+!**********************************************************************
+!****************************** 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
+!     REAL   , INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4
+      INTEGER, INTENT(IN), DIMENSION(3) :: IDAT
+!-----------------------------------------------------------------------
+      REAL,    PARAMETER :: CAPA=R_D/CP,DTR=3.1415926/180.
+      INTEGER            :: LM1,LP1,LM
+      INTEGER, INTENT(IN)               :: IHRST
+!     REAL,    INTENT(IN), DIMENSION(NL)    :: PRGFDL
+!
+      REAL,    PARAMETER :: ALPHA0=100.,CLFRMIN=0.1,CUPRATE=24.*1000.,  &
+     &                      EPS=R_D/R_V,EPSO3=1.E-10,                   &
+     &                      EPSQ=1.E-12,EPSQ1=1.E-5,                    &
+     &                      GAMMA=0.49,H0=0.,H1=1.,H69=-6.9,HPINC=1.E1, &
+     &                      PBOT=10000.0,PEXP=0.25,                     &
+     &                      QCLDMIN=EPSQ,RLAG=14.8125,                  &
+     &                      STBOL=STBOLT,T_ICE=-10.
+!
+      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,BITS,BITCP1,BITSP1
+      LOGICAL :: CNCLD,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
+      REAL, INTENT(IN), DIMENSION(its:ite, kms:kme, jts:jte):: 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,RLWIN      & !Added
+     &                                                ,CFRACL,CFRACM    &
+     &                                                ,CFRACH
+
+!     REAL,   INTENT(IN), DIMENSION(kms:kme)   :: ETAD
+!     REAL,   INTENT(IN), DIMENSION(kms:kme)   :: AETA
+!-----------------------------------------------------------------------
+      REAL,   INTENT(INOUT), DIMENSION(ims:ime,jms:jme)  :: HTOP,HBOT
+      REAL,   INTENT(IN   ), DIMENSION(ims:ime,jms:jme)  :: ALB,SNO
+      REAL,   INTENT(IN   ), DIMENSION(ims:ime,jms:jme)  :: GLAT,GLON
+!-----------------------------------------------------------------------
+      REAL,   DIMENSION(ims:ime,jms:jme)  :: CZEN
+!#$   REAL,   DIMENSION(its:ite,jts:jte)  :: CZMEAN,SIGT4
+      REAL,   DIMENSION(its:ite,jts:jte)  :: SIGT4
+       INTEGER, DIMENSION(its:ite, jts:jte):: LMH
+!-----------------------------------------------------------------------
+      REAL,   INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: CUPPT
+!     REAL,   DIMENSION(37*kte)          :: RAD1,RAD2,RAD3,RAD4
+!-----------------------------------------------------------------------
+!     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,   DIMENSION(its:ite,jts:jte) :: RLWIN,RLWOUT
+      REAL,   DIMENSION(its:ite,jts:jte) :: RLWOUT
+!-----------------------------------------------------------------------
+      REAL,   INTENT(IN),   DIMENSION(ims:ime,jms:jme) :: VEGFRC
+      REAL,   INTENT(INOUT),DIMENSION(its:ite,kts:kte,jts:jte) :: TENDL,&
+     &                                                            TENDS 
+!#$   REAL,   DIMENSION(its:ite,jts:jte) :: RSWIN,RSWOUT,RSWTOA
+!#$   REAL,   DIMENSION(its:ite,jts:jte) :: RSWIN,RSWOUT
+      REAL,   DIMENSION(its:ite,jts:jte) :: RSWOUT
+      REAL,   DIMENSION(its:ite,kts:kte,jts:jte):: RSWTT,RLWTT
+!-----------------------------------------------------------------------
+      REAL :: CTHK(3)
+      DATA CTHK/20000.0,20000.0,20000.0/
+
+      REAL    :: PTOPC(4)
+      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
+
+      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
+      REAL,SAVE :: PLOMD,PMDHI,PHITP,P400,PLBTM
+      INTEGER,SAVE :: NFILE
+
+!-----------------------------------------------------------------------
+      REAL    :: CLSTP,TIME,DAYI,HOUR,ADDL,RANG,RSIN1,RCOS1,RCOS2
+      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,DENOM,FCTRA,FCTRB,PDSLIJ,CFRAVG,SNOMM
+      REAL    :: TAUC,THICK,CONVPRATE,CLFR,ESAT,QSAT,RHUM,QCLD,RHGRID
+      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
+
+!     REAL,DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW,EM3V
+
+!     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))
+
+      DATA    PLOMD/64200./,PMDHI/35000./,PHITP/15000./,P400/40000./,   &
+              PLBTM/105000./
+      DATA    NFILE/14/
+      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./
+
+!-----------------------------------------------------------------------
+!***********************************************************************
+!-----------------------------------------------------------------------
+      MYJS=jts
+      MYJE=jte
+      MYIS=its
+      MYIE=ite
+      MYJS1=jts !????
+      MYJE1=jte
+      MYJS2=jts
+      MYJE2=jte
+      LM=kte
+      LM1=LM-1
+      LP1=LM+1
+      CNCLD=.TRUE.
+!
+      DO J=JTS,JTE
+      DO I=ITS,ITE
+        LMH(I,J)=KME-1
+        LVL(I,J)=0
+      ENDDO
+      ENDDO
+!***  
+!***  ASSIGN THE PRESSURES FOR CLOUD DOMAIN BOUNDARIES
+!***
+      PTOPC(1)=PLBTM
+      PTOPC(2)=PLOMD
+      PTOPC(3)=PMDHI
+      PTOPC(4)=PHITP
+!**********************************************************************
+!***  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
+!GFDL      RHGRID=RHGRD
+      RHGRID=RHgrd_in   !GFDL => simple right now w/o height-dependencies
+!----------------------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
+!     CALL ZENITH(TIME,DAYI,HOUR)
+!-----------------------------------------------------------------------
+      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                         )
+!-----------------------------------------------------------------------
+
+      JD=INT(DAYI+0.50)
+      ADDL=0.
+      IF(MOD(IDAT(3),4).EQ.0)ADDL=1.
+      RANG=PI2*(DAYI-RLAG)/(365.25+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=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).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
+!
+!***  MODIFY CZEN TO BE AT THE TOP OF THE HOUR.
+!
+!       TIMES=NTSD*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                         )
+      ENDIF
+!-----------------------------------------------------------------------
+!
+!***********************************************************************
+!***  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
+!       IR=IRAD(I)
+        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))**CAPA
+        TMID(I,L+LVLIJ)=T(I,L,J)
+        THMID(I,L+LVLIJ)=T(I,L,J)*EXNER
+        QMID(I,L+LVLIJ)=Q(I,L,J)
+!--- Note that rain is ignored, only effects from cloud water and ice 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)*0.5*HPINC
+          PINT(I,L+1)=PMID(I,L)+0.5*HPINC
+          EXNER=(1.E5/PMID(I,L))**CAPA
+          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)-0.5*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)**CAPA
+!     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.)
+      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
+!     (modified by Ferrier, Feb '02)
+!
+!---  Cloud fraction parameterization follows Randall, 1994
+!     (see Hong et al., 1998)
+!-----------------------------------------------------------------------
+!
+      DO I=MYIS,MYIE
+        LML=LMH(I,J)
+        LVLIJ=LVL(I,J)
+        DO L=1,LML
+          LL=L+LVLIJ
+!
+!--- Water vapor mixing ratio
+!
+          WV=QMID(I,LL)/(1.-QMID(I,LL))
+!
+!--- Saturation vapor pressure w/r/t water ( >=0C ) or ice ( <0C )
+!
+          ESAT=1000.*FPVS(TMID(I,LL))         !--- Saturation vapor pressure (Pa)
+          QSAT=EPS*ESAT/(PMID(I,LL)-ESAT)     !--- Saturation mixing ratio
+          RHUM=WV/QSAT                        !--- Relative humidity
+!
+!--- Total "cloud" mixing ratio, QCLD.  Rain is not part of cloud,
+!    only cloud water + cloud ice + snow
+!
+          QCLD=QWMID(I,LL)+QIMID(I,LL)
+!
+!--- Determine cloud fraction (modified from original algorithm)
+!
+          IF (QCLD .LT. QCLDMIN) THEN
+!
+!--- Assume zero cloud fraction if there is no cloud mixing ratio
+!
+            CLFR=H0
+          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
+!
+            CLFR=H1
+          ELSE
+!
+!--- Adaptation of original algorithm (Randall, 1994; Zhao, 1995)
+!    modified based on assumed grid-scale saturation at RH=RHgrid.
+!
+            DENOM=(RHGRID*QSAT-WV)**GAMMA
+            ARG=MAX(H69, -ALPHA0*QCLD/DENOM)    ! <-- EXP(-6.9)=.001
+            CLFR=(RHUM/RHGRID)**PEXP*(1.-EXP(ARG))
+!!              ARG=-1000*QCLD/(RHUM-RHGRID)
+!!              ARG=MAX(ARG, ARGMIN)
+!!              CLFR=(RHUM/RHGRID)*(1.-EXP(ARG))
+            IF (CLFR .LT. .01) CLFR=0.
+          ENDIF          !--- End IF (QCLD .LT. QCLDmin) ...
+          CSMID(I,LL)=MIN(H1,CLFR)
+        ENDDO            !--- End DO L ...
+      ENDDO                !--- End DO I ...
+!***********************************************************************
+!********************END OF STRATIFORM CLOUD SECTION********************
+!***********************************************************************
+!
+!-----------------------------------------------------------------------
+!---  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 (HBOT(I,J)-HTOP(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(HTOP(I,J))+LVLIJ
+            LCNVT=MIN(LM,LCNVT)
+            LCNVB=NINT(HBOT(I,J))+LVLIJ
+            LCNVB=MIN(LM,LCNVB)
+!
+            DO LL=LCNVT,LCNVB
+              CCMID(I,LL)=CLFR
+            ENDDO
+          ENDIF    !--- IF (HBOT(I,J)-HTOP(I,J) .GT. 1.0) ...
+        ENDDO      !--- End DO I loop
+      ENDIF        !--- End IF (CNCLD) ...
+!*********************************************************************
+!*****************END OF CONVECTIVE CLOUD SECTION*****************
+!*********************************************************************
+!***
+!***  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
+!***
+!*** 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.0   ! Total optical depth for each cloud layer
+        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)-273.16
+            QSUM=QSUM+QMID(I,LL)*DELP*(PRS1+PRS2)                       &     
+     &           /(120.1612*SQRT(TMID(I,LL)))
+!
+!--- 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.
+!
+!--- For convection, assume simple optical depth coefficients of
+!      1) CTau=0.16 for ice, assumed to be for T<=T_ICE (=-10C in GSMCOLUMN)
+!         This was referenced as "optically thick anvil associated with
+!         convection in
+!      2) CTau=0.08 for water, assumed to be present for T>T_ICE
+!
+!--- For grid-scale processes in the absence of convection:
+!      1) CTau=0.08*min(1., Qc/Q0) for cloud water, 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).
+!      2) CTau=500*Qi for ice particles.  This is based on the optical depth
+!         of snow.  Prof. Q. Fu (U. Washington) provided the following eq.:
+!           Tau-1.5*SWP/(Res*RHOs)
+!         SWP is snow water path, Res is the snow effective radius, RHOs is
+!         the snow density.  Based on derivations using Petch (1998, JAS, 1846-
+!         1858) as a starting point, Res=1.5*Ds with Ds being the mean diameter
+!         of an exponential distribution of ice particles ("snow").  After some
+!         manipulation,
+!           Tau=CTau*DELP => CTau=CSTau*Qice, where
+!         CSTau=100./(G*Ds*RHOs) ~ 500 based on values of Ds and RHOs in the
+!         ice lookup tables (actually varies from 920 for Ds=.1 mm to ~520 for
+!         Ds>0.5 mm), and units of DELP in mb (must convert from Pascals).
+!         "Snow" (precipitating ice) is assumed because of it dominates over
+!         cloud ice in the scheme.
+!
+            CTAU=0.
+            IF (CCMID(I,LL) .GE. CLFRMIN) THEN
+!-- Crude convective cloud properties
+              IF (TCLD .GT. T_ICE) THEN
+                CTAU=0.08      !--- Cloud water
+              ELSE
+                CTAU=0.16      !--- Ice
+              ENDIF
+            ENDIF
+!-- Crude grid-scale cloud properties
+            IF (CSMID(I,LL) .GE. CLFRMIN)                               &
+     &        CTAU=CTAU+800.*QWMID(I,LL)+500.*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)
+!GFDL => should consider using this =>        IF(BITX)EMIS(I,NC)=1.0-EXP(-1.66*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 PRESSURES SO THAT THE ENTIRE COLUMN OF OZONE (TO 0 MB)
+!***  IS INCLUDED IN THE MODEL COLUMN EVEN WHEN PT > 0 MB
+!***
+      DO L=1,LM
+      DO I=MYIS,MYIE
+        DENOM=1./(PINT(I,LP1)-PINT(I,1))
+        FCTRA=PINT(I,LP1)*DENOM
+        FCTRB=-PINT(I,1)*PINT(I,LP1)*DENOM
+        POZN(I,L)=PMID(I,L)*FCTRA+FCTRB
+      ENDDO
+      ENDDO
+!
+      CALL OZON2D(LM,POZN,XLAT,RSIN1,RCOS1,RCOS2,OZN,              &
+!                 XDUO3N,XDO3N4,XDO3N2,XDO3N3,                     &
+!                 PRGFDL,MYIS,MYIE,                                &
+                  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
+!***
+!***
+      CALL RADFS &
+     &     (PSFC,PMID,PINT,QMID,TMID,OZN,TSKN,SLMSK,ALBEDO,XLAT         &
+     &,     CAMT,KTOP,KBTM,NCLDS,EMIS,RRCL,TTCL                         &
+     &,     COSZ,TAUDAR,1                                               &
+     &,     1,0                                                         &
+     &,     ITIMSW,ITIMLW,JD,HOUR                                       &
+     &,     TENDS(ITS,KTS,J),TENDL(ITS,KTS,J)                           &
+     &,     FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS               &
+     &,     ids,ide, jds,jde, kds,kde                                   &
+     &,     ims,ime, jms,jme, kms,kme                                   &
+     &,     its,ite, jts,jte, kts,kte                           )
+!----------------------------------------------------------------------
+      IF(LONG)THEN
+        DO I=MYIS,MYIE
+          GLW(I,J)=FLWDNS(I)
+        ENDDO
+      ENDIF
+!
+      IF(SHORT)THEN
+        DO I=MYIS,MYIE
+          GSW(I,J)=FSWDNS(I)-FSWUPS(I)
+        ENDDO
+      ENDIF
+!
+      DO 650 I=MYIS,MYIE
+      CFRACL(I,J)=CLDCFR(I,1)
+      CFRACM(I,J)=CLDCFR(I,2)
+      CFRACH(I,J)=CLDCFR(I,3)
+!     
+!***  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.
+!
+      CFRAVG=1.-(1.-CFRACL(I,J))*(1.-CFRACM(I,J))*(1.-CFRACH(I,J))
+!
+      IF(CNCLD)THEN
+        IF(HBOT(I,J)-HTOP(I,J).GT.1.)THEN
+!--- Count locations with convective cloudiness
+          ACFRST(I,J)=ACFRST(I,J)+CFRAVG
+          NCFRST(I,J)=NCFRST(I,J)+1
+        ENDIF
+        BITS=.FALSE.
+        DO LL=1,LM
+          BITS=CSMID(I,LL).GE.CLFRMIN  !--- Existence of grid-scale cloud in layer
+          IF(BITS)EXIT
+        ENDDO
+        IF(BITS)THEN
+!--- Count locations with grid-scale cloudiness
+          ACFRST(I,J)=ACFRST(I,J)+CFRAVG
+          NCFRST(I,J)=NCFRST(I,J)+1
+        ENDIF
+      ELSE
+!--- Count only locations with grid-scale cloudiness
+        ACFRCV(I,J)=ACFRCV(I,J)+CFRAVG
+        NCFRCV(I,J)=NCFRCV(I,J)+1
+      ENDIF
+  650 CONTINUE
+!***
+!***  COLLECT ATMOSPHERIC TEMPERATURE TENDENCIES DUE TO RADIATION.
+!***  ALSO COLLECT THE TOTAL SW AND INCOMING LW RADIATION (W/M**2)
+!***  AND CONVERT TO FORM NEEDED FOR PREDICTION OF THS IN SURFCE.
+!***
+      DO 660 I=MYIS,MYIE
+      DO L=1,LM
+        LL=LVL(I,J)+L
+        IF(SHORT)RSWTT(I,L,J)=TENDS(I,LL,J)
+        IF(LONG) RLWTT(I,L,J)=TENDL(I,LL,J)
+        IF(LL.EQ.LM)GO TO 660
+      ENDDO
+  660 CONTINUE
+!***
+!***  SUM THE LW INCOMING AND SW RADIATION (W/M**2) FOR RADIN.
+!***
+      DO 675 I=MYIS,MYIE
+      IF(LONG)THEN
+        SIGT4(I,J)=STBOL*TMID(I,LM)*TMID(I,LM)* &
+                   TMID(I,LM)*TMID(I,LM)
+      ENDIF
+!     
+!***  ACCUMULATE VARIOUS LW AND SW RADIATIVE FLUXES FOR POST
+!***  PROCESSOR.  PASSED VIA COMMON ACMRDL AND ACMRDS.
+!
+      IF(LONG)THEN
+        RLWIN(I,J) =FLWDNS(I)
+        RLWOUT(I,J)=FLWUPS(I)
+        RLWTOA(I,J)=FLWUP(I)
+      ENDIF
+      IF(SHORT)THEN
+        RSWIN(I,J) =FSWDNS(I)
+        RSWOUT(I,J)=FSWUPS(I)
+        RSWTOA(I,J)=FSWUP(I)
+      ENDIF
+  675 CONTINUE
+!***
+!***  THIS ROW IS FINISHED. GO TO NEXT
+!***
+!                        *********************
+  700                          CONTINUE
+!                        *********************
+!----------------------------------------------------------------------
+!***
+!***  CALLS TO RADIATION THIS TIME STEP ARE COMPLETE.
+!***
+!----------------------------------------------------------------------
+!----------------------------------------------------------------------
+!***
+!***  HORIZONTAL SMOOTHING OF TEMPERATURE TENDENCIES
+!***
+!----------------------------------------------------------------------
+      IF(SHORT) THEN
+        DO 800 L=1,LM
+!       CALL ZERO2(TL,  &                  
+!                  ids,ide, jds,jde, kds,kde,                         &
+!                  ims,ime, jms,jme, kms,kme,                         &
+!                  its,ite, jts,jte, kts,kte                          )
+!       CALL ZERO2(FNE, &
+!                  ids,ide, jds,jde, kds,kde,                         &
+!                  ims,ime, jms,jme, kms,kme,                         &
+!                  its,ite, jts,jte, kts,kte                          )
+!       CALL ZERO2(FSE, &
+!                  ids,ide, jds,jde, kds,kde,                         &
+!                  ims,ime, jms,jme, kms,kme,                         &
+!                  its,ite, jts,jte, kts,kte                          )
+!
+!        IF(KSMUD.GE.1)THEN
+!          DO 750 KS=1,KSMUD
+!!
+!          DO J=MYJS,MYJE
+!          DO I=MYIS,MYIE
+!            TL(I,J)=RSWTT(I,L,J)
+!!           TL(I,J)=RSWTT(I,L,J)*HTM(I,L,J)
+!          ENDDO
+!          ENDDO
+!!
+!          DO J=MYJS,MYJE
+!          DO I=MYIS,MYIE
+!            FNE(I,J)=(TL(I+IHE(J),J+1)-TL(I,J)) 
+!!                    *HTM(I,L,J)*HTM(I+IHE(J),J+1,L)
+!          ENDDO
+!          ENDDO
+!!
+!          DO J=MYJS1,MYJE
+!          DO I=MYIS,MYIE
+!            FSE(I,J)=(TL(I+IHE(J),J-1)-TL(I,J)) 
+!!                    *HTM(I+IHE(J),J-1,L)*HTM(I,L,J)
+!          ENDDO
+!          ENDDO
+!!
+!          DO J=MYJS2,MYJE2
+!          DO I=MYIS,MYIE
+!            TL(I,J)=(FNE(I,J)-FNE(I+IHW(J),J-1)  &
+!                    +FSE(I,J)-FSE(I+IHW(J),J+1)) &
+!                    *0.125+TL(I,J)
+!!                   *HBM2(I,J)*0.125+TL(I,J)
+!          ENDDO
+!          ENDDO
+!!
+!          DO J=MYJS,MYJE
+!          DO I=MYIS,MYIE
+!            RSWTT(I,L,J)=TL(I,J)
+!          ENDDO
+!          ENDDO
+!!
+!  750     CONTINUE
+!        ENDIF
+!
+  800   CONTINUE
+      ENDIF
+!----------------------------------------------------------------------
+!
+      IF(LONG)THEN
+!
+        DO 900 L=1,LM
+!       CALL ZERO2(TL, &
+!                  ids,ide, jds,jde, kds,kde,                         &
+!                  ims,ime, jms,jme, kms,kme,                         &
+!                  its,ite, jts,jte, kts,kte                          )
+!       CALL ZERO2(FNE, &
+!                  ids,ide, jds,jde, kds,kde,                         &
+!                  ims,ime, jms,jme, kms,kme,                         &
+!                  its,ite, jts,jte, kts,kte                          )
+!       CALL ZERO2(FSE, &
+!                  ids,ide, jds,jde, kds,kde,                         &
+!                  ims,ime, jms,jme, kms,kme,                         &
+!                  its,ite, jts,jte, kts,kte                          )
+!
+!        IF(KSMUD.GE.1)THEN
+!          DO 850 KS=1,KSMUD
+!!
+!          DO J=MYJS,MYJE
+!          DO I=MYIS,MYIE
+!            TL(I,J)=RLWTT(I,L,J)
+!!           TL(I,J)=RLWTT(I,L,J)*HTM(I,L,J)
+!          ENDDO
+!          ENDDO
+!!
+!          DO J=MYJS,MYJE1
+!          DO I=MYIS,MYIE
+!            FNE(I,J)=(TL(I+IHE(J),J+1)-TL(I,J))  
+!!                    *HTM(I,L,J)*HTM(I+IHE(J),J+1,L)
+!          ENDDO
+!          ENDDO
+!!
+!          DO J=MYJS1,MYJE
+!          DO I=MYIS,MYIE
+!            FSE(I,J)=(TL(I+IHE(J),J-1)-TL(I,J))  
+!!                    *HTM(I+IHE(J),J-1,L)*HTM(I,L,J)
+!          ENDDO
+!          ENDDO
+!!
+!          DO J=MYJS2,MYJE2
+!          DO I=MYIS,MYIE
+!            TL(I,J)=(FNE(I,J)-FNE(I+IHW(J),J-1) &
+!                    +FSE(I,J)-FSE(I+IHW(J),J+1)) &
+!                    *0.125+TL(I,J)
+!!                   *HBM2(I,J)*0.125+TL(I,J)
+!          ENDDO
+!          ENDDO
+!!
+!          DO J=MYJS,MYJE
+!          DO I=MYIS,MYIE
+!            RLWTT(I,L,J)=TL(I,J)
+!          ENDDO
+!          ENDDO
+!!
+!  850     CONTINUE
+!        ENDIF
+  900   CONTINUE
+      ENDIF
+!----------------------------------------------------------------------
+
+      END SUBROUTINE RADTN
+
+!----------------------------------------------------------------------
+
+      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)
+!----------------------------------------------------------------------
+      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,    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+GSTC2*TU+GSTC3*TU**2+GSTC4*TU**3
+      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
+  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,RSIN1,RCOS1,RCOS2,QO3,              &
+!                    XDUO3N,XDO3N4,XDO3N2,XDO3N3,                     &
+!                    PRGFDL,MYIS,MYIE,                                &
+                     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
+      REAL,    INTENT(IN)  :: RSIN1,RCOS1,RCOS2
+!----------------------------------------------------------------------
+      INTEGER, PARAMETER ::  NL=81,NLP1=NL+1,LNGTH=37*NL
+      REAL, PARAMETER :: RTD=57.2957795
+
+!     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))**2
+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        *
+!     *                                                               *
+!     * UPDATE: R1 HAS BEEN ADDED TO THE INPUTS FROM RADTN TO         *
+!     *         COMPUTE THE VARIATION OF SOLAR CONSTANT AT THE TOP    *
+!     *         OF ATMOSPHERE WITH JULIAN DAY IN A YEAR.              *
+!     *                                QINGYUN  ZHAO   96-7-23        *
+!     *****************************************************************
+!***
+!***  REQUIRED INPUT:
+!***
+                (QS,PP,PPI,QQH2O,TT,O3QO3,TSFC,SLMSK,ALBEDO,XLAT &
+      ,          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
+!*   SLMRF(LP1):	THE INTERFACE'S ETA (LP1=L+1)
+!*   SLYMRF(L):		THE MIDLAYER ETA 
+!*   ITIMSW:		=1/0 (SHORTWAVE CALC. ARE DESIRED/NOT DESIRED)
+!*   ITIMLW:		=1/0 (LONGWAVE CALC. ARE DESIRED/NOT DESIRED)
+!************************************************************************
+!***
+!*** THE FOLLOWING ARE ADDITIONAL FOR ETA MODEL
+!***
+      ,          JD,GMT &
+!**************************************************************************
+!*   JD: JULIAN DAY IN A YEAR
+!*   R1: THE NON-DIMENSIONAL SUN-EARTH DISTANCE
+!*   GMT:HOUR
+!**************************************************************************
+!***
+!*** GENERATED OUTPUT REQUIRED BY THE ETA MODEL
+!***
+      ,          SWH,HLW &
+!     ,          T1,T2,T4,EM1V,EM1VW,EM3V                       &
+      ,          FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS  &
+!     ,          DDUO3N,DDO3N2,DDO3N3,DDO3N4                    &
+!     ,          SKO3R,AB15WD,SKC1R,SKO2D                       &
+      ,          ids,ide, jds,jde, kds,kde                      &
+      ,          ims,ime, jms,jme, kms,kme                      &
+      ,          its,ite, jts,jte, kts,kte                      )
+!************************************************************************
+!*    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).
+!************************************************************************
+!***
+!*** 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 ::      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 ::      Q14330=1.43306E-6
+ 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,JD
+      REAL,    INTENT(IN)        :: GMT
+!----------------------------------------------------------------------
+!      ****************************************************************
+!      *  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...     *
+!      *    SLMRF = INTERFACE (LEVELS) SIGMA                          *
+!      *    SLYMRF= LAYER SIGMA                                       *
+!      *  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
+      
+!        *********************************************
+!====>   *   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
+
+!     DIMENSION RAD1(37*kte), RAD2(37*kte), RAD3(37*kte), RAD4(37*kte)
+!     EQUIVALENCE (RAD1(1),DDUO3N(1,1)),(RAD2(1),DDO3N2(1,1))
+!     EQUIVALENCE (RAD3(1),DDO3N3(1,1)),(RAD4(1),DDO3N4(1,1))
+!====>    **************************************************************
+!
+      REAL,   DIMENSION(21,20) :: ALBD
+      REAL,   DIMENSION(20)    :: ZA
+      REAL,   DIMENSION(21)    :: TRN
+      REAL,   DIMENSION(19)    :: DZA
+
+      REAL    :: YEAR,RLAG,TPI,SC,SSOLAR,DATE,RANG,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 :: SOLC,RSIN1,RCOS1,RCOS2
+
+       REAL    :: ALBD0,ALVD1,ALND1,RRVCO2,RRCO2
+       INTEGER :: N
+
+!====>    BEGIN HERE             .......................
+!
+!         SOLC,THE SOLAR CONSTANT IS SCALED TO A MORE CURRENT VALUE.
+!          I.E. IF SOLC=2.0 LY/MIN THEN SSOLAR=1.96 LY/MIN.
+!..     RE-COMPUTED CAUSE SSOLAR OVERWRITTEN AS PART OF SCRATCH COMMON
+!
+
+
+      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
+      YEAR=365.25
+      RLAG=14.8125
+      TPI=6.283185308
+      SC=2.
+      SOLC=SC/(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
+!****************************
+      SSOLAR=SOLC*HP98
+      SSOLAR=SSOLAR*0.97
+      DATE=JD+GMT/24.0
+      RANG=TPI*(DATE-RLAG)/YEAR
+      RSIN1=SIN(RANG)
+      RCOS1=COS(RANG)
+      RCOS2=COS(2.0*RANG)
+      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 L=1,LM1
+            PHALF(L+1)=PP(I,L) !  AETA(L)*PDIF+PT
+         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)
+!.....     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
+         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                    )
+
+!....
+      DO 280 I=MYIS,MYIE
+        IR = I + IBEG - 1
+        FLWUP(IR) = TOPFLX(I) * .001E0
+        GRNFLX(I)=Q14330*(HSIGMA*TEMP(I,LP1)**4-GRNFLX(I))
+!.... GET LW FLUX DOWN AND UP AT GROUND(WATTS/M**2) - GRNFLX=LW DOWN.
+        FLWDNS(IR)=GRNFLX(I)/(1.43306E-06*1000.E0)
+        FLWUPS(IR)=HSIGMA*.001E0 * TEMP(I,LP1)**4
+  280 CONTINUE
+!....      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
+!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
+!...    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
+      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: gopal's doing
+
+!----------------------------------------------------------------------
+!                           EQUIVALENCE &
+!       (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) &
+!      ,(PH1(1),PH(1)),(PH2(1),PH(46)) &
+!      ,(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: gopal's doing 
+      ,(P1(1),PXX(1)),(P2(1),PXX(49))                   ! fix for nesting: gopal's doing 
+
+
+!----------------------------------------------------------------------
+!                          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)=PYY(K)*1013250.         ! fix for nesting: gopal's doing 
+        P(K)=PXX(K)*1013250.
+      ENDDO
+!
+      PH(NKP)=PYY(NKP)*1013250.        ! fixed; dusan
+!
+      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 ::      Q14330=1.43306E-6
+ 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.
+!     
+! 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 :: JYR,JMNTH,JDAY,JHRJD,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
+!    --------------------------------------------------------------------
+
+!     JYR=IDAT(3)
+!     JMNTH=IDAT(1)
+!     JDAY=IDAT(2)
+      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(6,1000)JYR,JMNTH,JDAY,JHR,R1
+!     WRITE(6,*)JHR,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))
+      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_hwrf: 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_hwrf: 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_hwrf: 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_hwrf: error reading tr49t85 on unit ',etarad_unit61
+     write(0,*)' IERROR=',IERROR
+     CALL wrf_error_fatal(errmess)
+9062 CONTINUE
+     WRITE( errmess , '(A49,I4)' ) 'module_ra_hwrf: error reading tr49t67 on unit ',etarad_unit62
+     write(0,*)' IERROR=',IERROR
+     CALL wrf_error_fatal(errmess)
+9063 CONTINUE
+     WRITE( errmess , '(A49,I4)' ) 'module_ra_hwrf: 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
+          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)
+          REWIND NUNIT_CO2
+        ENDIF
+
+
+!----------------------------------------------------------------------
+!
+!***  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.
+!    This is gopal's doing
+!
+      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_hwrf: error reading co2_trans on unit ',nunit_co2
+     CALL wrf_error_fatal(errmess)
+!----------------------------------------------------------------------
+      END SUBROUTINE CONRAD
+!----------------------------------------------------------------------
+!
+      END MODULE module_RA_HWRF
+!
+!----------------------------------------------------------------------
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_cam.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_cam.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_cam.F	(revision 17)
@@ -0,0 +1,7835 @@
+MODULE module_ra_cam
+  use module_ra_cam_support
+  use module_cam_support, only: endrun
+
+  implicit none
+! 
+! 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/
+
+#if 0
+! moved and changed to local variables into radcswmx for thread-safety, JM 20100217
+   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
+#endif
+! 
+! 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/
+
+#if 0
+! moved and changed to local variables into radcswmx for thread-safety, JM 20100217
+   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
+#endif
+! 
+   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 /
+
+! 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
+   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
+!
+   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 &
+        )
+
+   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/
+
+   real(r8) amo                 ! Molecular weight of ozone (g/mol)
+   save     amo
+
+   data amo   /  48.0000   /
+
+contains
+subroutine camrad(RTHRATENLW,RTHRATENSW,                           &
+                     dolw,dosw,                                    &
+                     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,YR,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
+   LOGICAL,    INTENT(IN   ) ::        dolw,dosw
+
+   INTEGER,    INTENT(IN  )  ::        n_cldadv
+   INTEGER,    INTENT(IN  )  ::        JULDAY
+   REAL,       INTENT(IN  )  ::        JULIAN
+   INTEGER,    INTENT(IN  )  ::        YR
+   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
+   integer :: nyrm, nyrp
+   real(r8) doymodel, doydatam, doydatap, deltat, fact1, fact2
+
+   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( 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)
+   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 
+
+! update CO2 volume mixing ratio (co2vmr)
+  
+! determine time interpolation factors, check sanity
+! of interpolation factors to within 32-bit roundoff
+! assume that day of year is 1 for all input data
+!
+   nyrm     = yr - yrdata(1) + 1
+   nyrp     = nyrm + 1
+   doymodel = yr*365.    + julian
+   doydatam = yrdata(nyrm)*365. + 1.
+   doydatap = yrdata(nyrp)*365. + 1.
+   deltat   = doydatap - doydatam
+   fact1    = (doydatap - doymodel)/deltat
+   fact2    = (doymodel - doydatam)/deltat
+   co2vmr = (co2(nyrm)*fact1 + co2(nyrp)*fact2)*1.e-06
+
+   co2mmr=co2vmr*mwco2/mwdry
+!
+!===================================================
+! 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 .and. dolw)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
+!    convert to specific humidity
+      q(ii,kk,1) = max(1.e-10,qv3d(i,k,j)/(1.+qv3d(i,k,j)))
+     IF ( F_QI .and. F_QC .and. F_QS ) THEN
+      q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
+      q(ii,kk,ixcldice) = max(0.,(qi3d(i,k,j)+qs3d(i,k,j))/(1.+qv3d(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)/(1.+qv3d(i,k,j)))
+      if(t_phy(i,k,j).le.273.15)q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
+     ELSE IF ( F_QC .and. F_QS ) THEN
+! For Ferrier (note that currently Ferrier has QI, so this section will not be used)
+      q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j))*f_ice_phy(i,k,j))
+      q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(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-1
+      do k=1,levsiz
+      do i = its,ite
+      ii = i - its + 1
+      ozmixmj(ii,k,m) = ozmixm(i,k,j,m+1)
+      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
+
+      do k = kts,kte+1
+      kk = kte - k + kts + 1
+      do i = its,ite
+      ii = i - its + 1
+      pint(ii,kk) = p8w(i,k,j)
+      if(k.eq.kts)ps(ii)=pint(ii,kk)
+      lnpint(ii,kk) = log(pint(ii,kk))
+      enddo
+      enddo
+
+      if(.not.doabsems .and. dolw)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) = p_phy(i,k,j)
+      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, &
+                   dolw, dosw, 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
+      if(dolw)RTHRATENLW(I,K,J) = 1.e4*qrl(ii,kk)/(cpair*pi_phy(i,k,j))
+      if(dosw)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 .and. dolw)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
+      if(dosw)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)
+       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)
+       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)
+       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)
+!            1234 format (a6,4i4,4f10.3)
+!            endif
+     enddo
+      enddo
+      endif
+      if(dolw)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
+!      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
+         lwupt(i,j)     = flup(ii,kk)
+         lwuptc(i,j)    = flupc(ii,kk)
+         lwdnt(i,j)     = fldn(ii,kk)
+         lwdntc(i,j)    = fldnc(ii,kk)
+       endif
+       if(k.eq.kts)then
+         lwupb(i,j)     = flup(ii,kk)
+         lwupbc(i,j)    = flupc(ii,kk)
+         lwdnb(i,j)     = fldn(ii,kk)
+         lwdnbc(i,j)    = fldnc(ii,kk)
+       endif
+!            if(i.eq.30.and.j.eq.30) then
+!            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
+      ENDIF
+
+      do i = its,ite
+      ii = i - its + 1
+! Added shortwave and longwave cloud forcing at TOA and surface
+      if(dolw)then
+        GLW(I,J) = flwds(ii)
+        lwcf(i,j) = lwcftoa(ii)
+        olr(i,j)  = olrtoa(ii)
+      endif
+      if(dosw)then
+        GSW(I,J) = fsns(ii)
+        swcf(i,j) = swcftoa(ii)
+        coszr(i,j) = coszrs(ii)
+      endif
+      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_state_description
+   !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
+
+! These were made allocatable 20090612 to save static memory allocation. JM
+   IF ( .NOT. ALLOCATED( ksul   ) ) ALLOCATE( ksul( nrh, nspint ) )
+   IF ( .NOT. ALLOCATED( wsul   ) ) ALLOCATE( wsul( nrh, nspint ) )
+   IF ( .NOT. ALLOCATED( gsul   ) ) ALLOCATE( gsul( nrh, nspint ) )
+   IF ( .NOT. ALLOCATED( ksslt  ) ) ALLOCATE( ksslt( nrh, nspint ) )
+   IF ( .NOT. ALLOCATED( wsslt  ) ) ALLOCATE( wsslt( nrh, nspint ) )
+   IF ( .NOT. ALLOCATED( gsslt  ) ) ALLOCATE( gsslt( nrh, nspint ) )
+   IF ( .NOT. ALLOCATED( kcphil ) ) ALLOCATE( kcphil( nrh, nspint ) )
+   IF ( .NOT. ALLOCATED( wcphil ) ) ALLOCATE( wcphil( nrh, nspint ) )
+   IF ( .NOT. ALLOCATED( gcphil ) ) ALLOCATE( gcphil( nrh, nspint ) )
+
+   IF ( .NOT. ALLOCATED(ah2onw  ) ) ALLOCATE( ah2onw(n_p, n_tp, n_u, n_te, n_rh) )
+   IF ( .NOT. ALLOCATED(eh2onw  ) ) ALLOCATE( eh2onw(n_p, n_tp, n_u, n_te, n_rh) )
+   IF ( .NOT. ALLOCATED(ah2ow   ) ) ALLOCATE( ah2ow(n_p, n_tp, n_u, n_te, n_rh) )
+   IF ( .NOT. ALLOCATED(cn_ah2ow) ) ALLOCATE( cn_ah2ow(n_p, n_tp, n_u, n_te, n_rh) )
+   IF ( .NOT. ALLOCATED(cn_eh2ow) ) ALLOCATE( cn_eh2ow(n_p, n_tp, n_u, n_te, n_rh) )
+   IF ( .NOT. ALLOCATED(ln_ah2ow) ) ALLOCATE( ln_ah2ow(n_p, n_tp, n_u, n_te, n_rh) )
+   IF ( .NOT. ALLOCATED(ln_eh2ow) ) ALLOCATE( ln_eh2ow(n_p, n_tp, n_u, n_te, n_rh) )
+
+#if !defined(MAC_KLUDGE)
+   ozncyc = .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)
+
+
+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
+   do m=1,12
+   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 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 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 <comctl.h>
+
+  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 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 <crdcon.h>
+
+!     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  ,                   &
+                  dolw, dosw, 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) :: dolw,dosw,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
+         swcf(i)  = fsntoa(i) - fsntoac(i)
+      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
+
+      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)
+
+!
+! 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)
+      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
+
+
+
+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:
+! <Describe the algorithm(s) used in the routine.>
+! <Also include any applicable external references.>
+!
+! 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 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)-------------
+
+!-------------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 
+   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
+! 
+   real(r8) wgtint           ! Weight for specific spectral interval
+
+! 
+! 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
+
+! moved to here from the module storage above, because these have to be thread-private.  JM 20100217
+   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
+
+   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
+! JM 20100217
+
+! 
+!-----------------------------------------------------------------------
+! 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 <aerod>/<frc_day>
+      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 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: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! 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) vmmr                ! Ozone volume mixing ratio
+   real(r8) delta               ! Solar declination angle
+
+!
+!-----------------------------------------------------------------------
+!
+!  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: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! 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
+
+
+#endif
+
+end MODULE module_ra_cam
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_cam_support.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_cam_support.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_cam_support.F	(revision 17)
@@ -0,0 +1,3861 @@
+MODULE module_ra_cam_support
+  use module_cam_support, only: endrun
+  implicit none
+      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)
+
+! These are now allocatable. JM 20090612
+  real(r8), allocatable, dimension(:,:,:,:,:)  :: ah2onw   ! (n_p, n_tp, n_u, n_te, n_rh)   ! absorptivity (non-window)
+  real(r8), allocatable, dimension(:,:,:,:,:)  :: eh2onw   ! (n_p, n_tp, n_u, n_te, n_rh)   ! emissivity   (non-window)
+  real(r8), allocatable, dimension(:,:,:,:,:)  :: ah2ow    ! (n_p, n_tp, n_u, n_te, n_rh)    ! absorptivity (window, for adjacent layers)
+  real(r8), allocatable, dimension(:,:,:,:,:)  :: cn_ah2ow ! (n_p, n_tp, n_u, n_te, n_rh)    ! continuum transmission for absorptivity (window)
+  real(r8), allocatable, dimension(:,:,:,:,:)  :: cn_eh2ow ! (n_p, n_tp, n_u, n_te, n_rh)    ! continuum transmission for emissivity   (window)
+  real(r8), allocatable, dimension(:,:,:,:,:)  :: ln_ah2ow ! (n_p, n_tp, n_u, n_te, n_rh)    ! line-only transmission for absorptivity (window)
+  real(r8), allocatable, dimension(:,:,:,:,:)  :: 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
+!
+  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/) )
+
+  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
+!
+  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/) )
+
+
+      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
+
+! These are now allocatable,  JM 20090612
+real(r8), allocatable, dimension(:,:) :: ksul    ! (nrh, nspint)    ! sulfate specific extinction  ( m^2 g-1 )
+real(r8), allocatable, dimension(:,:) :: wsul    ! (nrh, nspint)    ! sulfate single scattering albedo
+real(r8), allocatable, dimension(:,:) :: gsul    ! (nrh, nspint)    ! sulfate asymmetry parameter
+real(r8), allocatable, dimension(:,:) :: ksslt   ! (nrh, nspint)   ! sea-salt specific extinction  ( m^2 g-1 )
+real(r8), allocatable, dimension(:,:) :: wsslt   ! (nrh, nspint)   ! sea-salt single scattering albedo
+real(r8), allocatable, dimension(:,:) :: gsslt   ! (nrh, nspint)   ! sea-salt asymmetry parameter
+real(r8), allocatable, dimension(:,:) :: kcphil  ! (nrh, nspint)  ! hydrophilic carbon specific extinction  ( m^2 g-1 )
+real(r8), allocatable, dimension(:,:) :: wcphil  ! (nrh, nspint)  ! hydrophilic carbon single scattering albedo
+real(r8), allocatable, dimension(:,:) :: gcphil  ! (nrh, nspint)  ! hydrophilic carbon 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) :: 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, parameter :: cyr = 233  ! number of years of co2 data
+
+   integer  :: yrdata(cyr) = &
+ (/ 1869, 1870, 1871, 1872, 1873, 1874, 1875, &
+    1876, 1877, 1878, 1879, 1880, 1881, 1882, &
+    1883, 1884, 1885, 1886, 1887, 1888, 1889, &
+    1890, 1891, 1892, 1893, 1894, 1895, 1896, &
+    1897, 1898, 1899, 1900, 1901, 1902, 1903, &
+    1904, 1905, 1906, 1907, 1908, 1909, 1910, &
+    1911, 1912, 1913, 1914, 1915, 1916, 1917, &
+    1918, 1919, 1920, 1921, 1922, 1923, 1924, &
+    1925, 1926, 1927, 1928, 1929, 1930, 1931, &
+    1932, 1933, 1934, 1935, 1936, 1937, 1938, &
+    1939, 1940, 1941, 1942, 1943, 1944, 1945, &
+    1946, 1947, 1948, 1949, 1950, 1951, 1952, &
+    1953, 1954, 1955, 1956, 1957, 1958, 1959, &
+    1960, 1961, 1962, 1963, 1964, 1965, 1966, &
+    1967, 1968, 1969, 1970, 1971, 1972, 1973, &
+    1974, 1975, 1976, 1977, 1978, 1979, 1980, &
+    1981, 1982, 1983, 1984, 1985, 1986, 1987, &
+    1988, 1989, 1990, 1991, 1992, 1993, 1994, &
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, &
+    2002, 2003, 2004, 2005, 2006, 2007, 2008, &
+    2009, 2010, 2011, 2012, 2013, 2014, 2015, &
+    2016, 2017, 2018, 2019, 2020, 2021, 2022, &
+    2023, 2024, 2025, 2026, 2027, 2028, 2029, &
+    2030, 2031, 2032, 2033, 2034, 2035, 2036, &
+    2037, 2038, 2039, 2040, 2041, 2042, 2043, &
+    2044, 2045, 2046, 2047, 2048, 2049, 2050, &
+    2051, 2052, 2053, 2054, 2055, 2056, 2057, &
+    2058, 2059, 2060, 2061, 2062, 2063, 2064, &
+    2065, 2066, 2067, 2068, 2069, 2070, 2071, &
+    2072, 2073, 2074, 2075, 2076, 2077, 2078, &
+    2079, 2080, 2081, 2082, 2083, 2084, 2085, &
+    2086, 2087, 2088, 2089, 2090, 2091, 2092, &
+    2093, 2094, 2095, 2096, 2097, 2098, 2099, &
+    2100, 2101                               /)
+
+! A2 future scenario
+    real(r8)  :: co2(cyr) = &
+ (/ 289.263, 289.263, 289.416, 289.577, 289.745, 289.919, 290.102, &
+    290.293, 290.491, 290.696, 290.909, 291.129, 291.355, 291.587, 291.824, &
+    292.066, 292.313, 292.563, 292.815, 293.071, 293.328, 293.586, 293.843, &
+    294.098, 294.35, 294.598, 294.842, 295.082, 295.32, 295.558, 295.797,   &
+    296.038, 296.284, 296.535, 296.794, 297.062, 297.338, 297.62, 297.91,   &
+    298.204, 298.504, 298.806, 299.111, 299.419, 299.729, 300.04, 300.352,  &
+    300.666, 300.98, 301.294, 301.608, 301.923, 302.237, 302.551, 302.863,  &
+    303.172, 303.478, 303.779, 304.075, 304.366, 304.651, 304.93, 305.206,  &
+    305.478, 305.746, 306.013, 306.28, 306.546, 306.815, 307.087, 307.365,  &
+    307.65, 307.943, 308.246, 308.56, 308.887, 309.228, 309.584, 309.956,   &
+    310.344, 310.749, 311.172, 311.614, 312.077, 312.561, 313.068, 313.599, &
+    314.154, 314.737, 315.347, 315.984, 316.646, 317.328, 318.026, 318.742, &
+    319.489, 320.282, 321.133, 322.045, 323.021, 324.06, 325.155, 326.299,  &
+    327.484, 328.698, 329.933, 331.194, 332.499, 333.854, 335.254, 336.69,  &
+    338.15, 339.628, 341.125, 342.65, 344.206, 345.797, 347.397, 348.98,    &
+    350.551, 352.1, 354.3637, 355.7772, 357.1601, 358.5306, 359.9046,       &
+    361.4157, 363.0445, 364.7761, 366.6064, 368.5322, 370.534, 372.5798,    &
+    374.6564, 376.7656, 378.9087, 381.0864, 383.2994, 385.548, 387.8326,    &
+    390.1536, 392.523, 394.9625, 397.4806, 400.075, 402.7444, 405.4875,     &
+    408.3035, 411.1918, 414.1518, 417.1831, 420.2806, 423.4355, 426.6442,   &
+    429.9076, 433.2261, 436.6002, 440.0303, 443.5168, 447.06, 450.6603,     &
+    454.3059, 457.9756, 461.6612, 465.3649, 469.0886, 472.8335, 476.6008,   &
+    480.3916, 484.2069, 488.0473, 491.9184, 495.8295, 499.7849, 503.7843,   &
+    507.8278, 511.9155, 516.0476, 520.2243, 524.4459, 528.7127, 533.0213,   &
+    537.3655, 541.7429, 546.1544, 550.6005, 555.0819, 559.5991, 564.1525,   &
+    568.7429, 573.3701, 578.0399, 582.7611, 587.5379, 592.3701, 597.2572,   &
+    602.1997, 607.1975, 612.2507, 617.3596, 622.524, 627.7528, 633.0616,    &
+    638.457, 643.9384, 649.505, 655.1568, 660.8936, 666.7153, 672.6219,     &
+    678.6133, 684.6945, 690.8745, 697.1569, 703.5416, 710.0284, 716.6172,   &
+    723.308, 730.1008, 736.9958, 743.993, 751.0975, 758.3183, 765.6594,     &
+    773.1207, 780.702, 788.4033, 796.2249, 804.1667, 812.2289, 820.4118,    &
+    828.6444, 828.6444 /)
+
+      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
+
+    real(r8) retab(95)
+    !
+    !       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
+contains
+
+
+
+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: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! 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 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 <ptrrgrid.h>
+!------------------------------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 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 cldems(lchnk   ,ncol    ,pcols, pver, pverp, clwp    ,fice    ,rei     ,emis    )
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! Compute cloud emissivity using cloud liquid water path (g/m**2)
+! 
+! Method: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! 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: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! 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) corr
+    integer i
+    integer k
+    integer index
+    !
+    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 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 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
+
+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 <CSFF260>/<CSFF296>,
+!     where <> indicates average over wavenumber, is ~2.07
+!
+! fh2oself is (<CSFF260>/<CSFF296>)**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
+
+subroutine esinti(epslon  ,latvap  ,latice  ,rh2o    ,cpair   ,tmelt   )
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! Initialize es lookup tables
+! 
+! Method: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! 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. 
+! <Say what the routine does> 
+! 
+! 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
+
+   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
+
+
+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
+
+
+subroutine radini(gravx   ,cpairx  ,epsilox ,stebolx, pstdx )
+!----------------------------------------------------------------------- 
+! 
+! Purpose: 
+! Initialize various constants for radiation scheme; note that
+! the radiation scheme uses cgs units.
+! 
+! Method: 
+! <Describe the algorithm(s) used in the routine.> 
+! <Also include any applicable external references.> 
+! 
+! 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 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
+! aerosolc arrays are upward cumulative (kg/m2) at each level
+! Here we assume uniform vertical distribution (aerosolc linear with hybi)
+      aerosolcp(i,k,j,idxSUL)=1.e-7*(1.-hybi(k))
+      aerosolcn(i,k,j,idxSUL)=1.e-7*(1.-hybi(k))
+      aerosolcp(i,k,j,idxSSLT)=1.e-22*(1.-hybi(k))
+      aerosolcn(i,k,j,idxSSLT)=1.e-22*(1.-hybi(k))
+      aerosolcp(i,k,j,idxDUSTfirst)=1.e-7*(1.-hybi(k))
+      aerosolcn(i,k,j,idxDUSTfirst)=1.e-7*(1.-hybi(k))
+      aerosolcp(i,k,j,idxDUSTfirst+1)=1.e-7*(1.-hybi(k))
+      aerosolcn(i,k,j,idxDUSTfirst+1)=1.e-7*(1.-hybi(k))
+      aerosolcp(i,k,j,idxDUSTfirst+2)=1.e-7*(1.-hybi(k))
+      aerosolcn(i,k,j,idxDUSTfirst+2)=1.e-7*(1.-hybi(k))
+      aerosolcp(i,k,j,idxDUSTfirst+3)=1.e-7*(1.-hybi(k))
+      aerosolcn(i,k,j,idxDUSTfirst+3)=1.e-7*(1.-hybi(k))
+      aerosolcp(i,k,j,idxOCPHO)=1.e-7*(1.-hybi(k))
+      aerosolcn(i,k,j,idxOCPHO)=1.e-7*(1.-hybi(k))
+      aerosolcp(i,k,j,idxBCPHO)=1.e-9*(1.-hybi(k))
+      aerosolcn(i,k,j,idxBCPHO)=1.e-9*(1.-hybi(k))
+      aerosolcp(i,k,j,idxOCPHI)=1.e-7*(1.-hybi(k))
+      aerosolcn(i,k,j,idxOCPHI)=1.e-7*(1.-hybi(k))
+      aerosolcp(i,k,j,idxBCPHI)=1.e-8*(1.-hybi(k))
+      aerosolcn(i,k,j,idxBCPHI)=1.e-8*(1.-hybi(k))
+     ENDDO
+     ENDDO
+     ENDDO
+
+     call aer_optics_initialize
+ 
+
+END subroutine aerosol_init
+
+  subroutine aer_optics_initialize
+
+USE module_wrf_error
+
+!   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
+
+
+subroutine radaeini( pstdx, mwdryx, mwco2x )
+
+USE module_wrf_error
+
+!
+! 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
+
+ 
+end MODULE module_ra_cam_support
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_gfdleta.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_gfdleta.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_gfdleta.F	(revision 17)
@@ -0,0 +1,10202 @@
+!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,RTD=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=-40.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
+!!     &,  SECANG=-0.75            & !--- 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
+!-----------------------------------------------------------------------
+!
+!
+!-----------------------------------------------------------------------
+      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                                     &
+     &                ,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
+      REAL, DIMENSION(its:ite, kts:kte, jts:jte)::TENDS,TENDL
+      REAL, DIMENSION(ims:ime, jms:jme):: CUTOP,CUBOT
+      INTEGER :: IDAT(3),IHOUR,Jmonth,Jday
+      INTEGER :: I,J,K,KFLIP,IHRST
+
+! 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
+!
+      DO K=KMS,KME
+         KFLIP=KME+1-K
+         DO J=JTS,JTE
+         DO I=ITS,ITE
+           P8WFLIP(I,K,J)=P8W(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)=MAX(QW(I,KFLIP,J),0.)      !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)=MAX(QS(I,KFLIP,J),0.)      !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
+!
+        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)
+
+      IHOUR  =MOD((IHRST+NINT(XTIME/60.0)),24)
+!     write(0,*)' before SOLARD in ETARA ', IHOUR,JDAY,JMONTH,JULYR
+      CALL SOLARD(IHOUR,JDAY,JMONTH,JULYR)
+!-----------------------------------------------------------------------
+      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,                                 &
+     &            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,                            &
+     &                 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
+
+      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                             ) 
+!-----------------------------------------------------------------------
+!     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(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                         ) 
+!         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
+
+!
+!
+!***  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)*RTD
+      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(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                      )
+!----------------------------------------------------------------------
+      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,    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
+  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 ::      DEGRAD1=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=DEGRAD1*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 ::      DEGRAD1=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)
+          REWIND NUNIT_CO2
+        ENDIF
+
+!----------------------------------------------------------------------
+!
+!***  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
+!
+!----------------------------------------------------------------------
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_goddard.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_goddard.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_goddard.F	(revision 17)
@@ -0,0 +1,10219 @@
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+! ------------------ Goddard Radiation Code   ---------------------------------
+!
+! Purpose : 
+!   Drive Goddard radiative transfer to compute radiative heating rate and surface radiation.
+!
+!
+! Method (Calling sequence) :
+! goddardrad(preparation for radiative transfer)
+!     |-- o3_profile (intepolate ozone profile)
+!     |-- swrad(compute SW radiative transfer)
+!     |     |-- sw_uvpar(compute SW radiative transfer for UV band)
+!     |     |     |-cloud_scale(scale cloud optical thickness for diffuse/direct radiation)
+!     |     |     |-delta_eddington(delta-eddington approximation for the bulk scattering properties)
+!     |     |     |-twostream_adding(compute updown fluxes using two-stream adding method)
+!     |     |-- sw_ir(compute SW radiative transfer for IR band)
+!     |     |     |-cloud_scale(scale cloud optical thickness for diffuse/direct radiation)
+!     |     |     |-delta_eddington(delta-eddington approximation for the bulk scattering properties)
+!     |     |     |-twostream_adding(compute updown fluxes using two-stream adding method)
+!     |     |-- rflx(compute the reduction of clear-sky downward solar flux)
+!     |
+!     |-- lwrad(compute LW radiative transfer)
+!           |-- column(compute column-integrated amount of absorber)
+!           |-- h2oexps(compute exponentials for water vapor line absorption)
+!           |-- conexps(compute exponentials for continuum absorption)
+!           |-- co2exps(compute co2 exponentials)
+!           |-- ch4exps(compute ch4 exponentials)
+!           |-- comexps(compute co2-minor exponentials)
+!           |-- cfcexps(compute cfc exponentials)
+!           |-- b10exps(compute band3a exponentials)
+!           |-- tablup(compute water vapor, co2 and o3 transmittances)
+!           |-- h2okdis(compute water vapor transmittance using kdistirubion method)
+!           |-- co2kdis(compute co2 transmittances using k-distribution method)
+!           |-- n2okdis(compute n2o transmittances using k-distribution method)
+!           |-- ch4kdis(compute ch4 transmittances using k-distribution method)
+!           |-- comkdis(compute co2-minor transmittances using k-distribution method)
+!           |-- cfckdis(compute cfc transmittances using k-distribution method)
+!           |-- b10kdis(compute band3a transmittances using k-distribution method)
+!           |-- cldovlp(compute the fractional clear line-of-sight)
+!
+!
+! History :
+!   Aug 2007    , Toshi Matsui : One-dimensinalized swrad to skip swrad in night.
+!   Jun 2007    , Toshi Matsui ; Revise broadband flux reduction to avoid negative SW heating.
+!   May 2007    , Toshi Matsui ; Made driver to plug WRF, GOCCART module, and F90 revision.
+!   Apr 2007    , Toshi Matsui ; SW radiation routine is optimized (add fast_overcast option for CRM).
+!   1996 ~ 2002 , Ming-dah Chou and Max Suarez ; initial and misc changes
+!
+!
+! Refferences :
+!  Chou M.-D., and M. J. Suarez, 1999: A solar radiation parameterization for atmospheric studies. 
+!      NASA Tech. Rep. NASA/TM-1999-10460, vol. 15, 38 pp
+!  Chou M.-D., and M. J. Suarez, 2001: A thermal infrared radiation parameterization for atmospheric
+!      studies. NASA/TM-2001-104606, vol. 19, 55pp
+!  Matsui, T., W.-K. Tao, and J. J. Shi: 2007: Goddard Radiation and Aerosol Direct Effect in Goddard 
+!      WRF, NASA/UMD WRF Meeting, Sep 14 2007.
+!  Shi, J. J., W.-K. Tao, T. Matsui, R. Cifelli, A. Hou, S. Lang, A. Tokey, N.-Y. Wang, 
+!      C. Peters-Lidard, G. Jackson, S. Rutledge, W. Petersen, 2010: WRF Simulations of the 
+!      20-22 January 2007 Snow Events over Eastern Canada: Comparison with in-situ and Satellite 
+!      Observations. J. Applied Meteor. Climatol, 49, 2246-2266.
+!
+!
+!  Bug report: 
+!      If you find any bug, please report to
+!      Toshi Matsui @ NASA GSFC, email:toshihisa.matsui-1@nasa.gov
+!      Jainn J. Shi @ NASA GSFC, email:jainn.j.shi@nasa.gov
+!
+!      We will report bugs to  
+!      Ming-Dah Chou @ National Taiwa University mdchou@webmail.as.ntu.edu.tw 
+!---------------------------------------------------------------------------------------------------------
+ module module_ra_goddard
+
+! encapsulation control
+  private  !-> privatize all variables in this module excepting public parameter (subroutine) below. 
+  public :: goddardrad  !only this subroutine can be called from other module
+
+  integer,parameter :: fp_kind = selected_real_kind(15) !Real precision (6-single 15-double 20-quad)
+
+!-------------------------------------------------------------------------------
+!---------------------    User Modification  -----------------------------------    
+
+! (Both SW and LW radiation option)
+! there is an option of providing either cloud ice/water mixing ratio
+!  (cwc) or optical thickness (taucld).  if the former is provided, set
+!  cldwater=.true., and taucld is computed from cwc and reff as a
+!  function of spectra band. otherwise, set cldwater=.false., and
+!  specify taucld, independent of spectral band.
+  
+   logical,parameter :: cldwater = .true.  !ALWAYS  .true.
+
+! (Both SW and LW radiation option)
+! 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.  otherwise, set the option
+!  overcast=.false. (-> hardwire with WRF module)
+
+   logical,parameter :: overcast = .true.  ! recommend true for CRM or LES 
+
+! (SW radition option)
+! For overcast (=true) option, this option (fast_overcast=.true.) skip the clear-sky
+! two-stream radiative transfer computation, and only compute cloudy ski option. 
+! Fclear/Fcloud is estimated from pre-computed look-up table for the below cloud
+! flux reduction due to CO2 and O2.  So, this option make SW radiation faster 1.5 time.
+! Difference in surface downwelling radiation betweeen true and false option is less than 1.W/m^2. 
+
+   logical,parameter :: fast_overcast = .true. ! recommend true 
+
+! (LW radiation option)
+!  if high = .true., transmission functions in the co2, o3, and the
+!  three water vapor bands with strong absorption are computed using
+!  table look-up.  cooling rates are computed accurately from the
+!  surface up to 0.01 mb. But slightly computationally expensive.
+!
+!  if high = .false., transmission functions in LW radiation are computed using the
+!  k-distribution method with linear pressure scaling for all spectral
+!  bands and gases.  cooling rates are not accurately calculated for
+!  pressures less than 10 mb. But, the computationally slightly cheap. 
+
+   logical,parameter :: high = .false.  !recommend false for CRM
+                                        !recommend true if you include storatosphere (<10mb)
+
+! (LW radiation option)
+!   if trace = .true., absorption due to n2o, ch4, cfcs, and the
+!   two minor co2 bands in the LW window region is included.
+!   if trace = .false., absorption in those minor bands is neglected.
+
+   logical,parameter :: trace = .true.  !recommend true 
+
+   real(Kind=fp_kind),    parameter ::   co2    = 336.77e-6  ! co2 concentration [ppv] (Y1850 = 285.43e-6)
+   real(Kind=fp_kind),    parameter ::   n2o    = 0.32e-6    ! n2o concentration [ppv] (Y1850 = 0.28e-6)
+   real(Kind=fp_kind),    parameter ::   ch4    = 1.79e-6    ! ch4 concentration [ppv] (Y1850 = 0.86e-6)
+   real(Kind=fp_kind),    parameter ::   cfc11  = 268.0e-12  ! cfc11 concentration [ppv] (Y1850 = 0.)
+   real(Kind=fp_kind),    parameter ::   cfc12  = 503.0e-12  ! cfc12 concentration [ppv] (Y1850 = 0.)
+   real(Kind=fp_kind),    parameter ::   cfc22  = 105.0e-12  ! cfc22 concentration [ppv] (Y1850 = 0.)
+
+! some tuning parameters
+   real(Kind=fp_kind),    parameter ::   re = 10.    ! cloud droplet effective radius [micron]
+
+!---------------------   End of User Modification  -----------------------------
+!-------------------------------------------------------------------------------
+
+! number of radiation bands
+   integer, parameter :: ib_sw = 11  !number of shortwave band
+   integer, parameter :: ib_lw = 10  !number of longwave band 
+
+! Threshold values 
+!  - Do not change. These values are the lowest threshold, while avoiding numerical instability. 
+   real(Kind=fp_kind),    parameter ::   cosz_min = 0.0001 ! threshold of minimum cosizne of solar zenith angle for SW rad
+   real(Kind=fp_kind),    parameter ::   fcld_min = 0.01   ! threshold of minimum cloud fraction for account clooud
+   real(Kind=fp_kind),    parameter ::   taux_min = 0.0001 ! threshold of minimum optical depth for accouting cloud (0.02) 
+   real(Kind=fp_kind),    parameter ::   opt_min  = 1.e-6  ! threshold of optical properties to avoid numerical instability. 
+
+   integer :: jloop
+contains
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+   subroutine goddardrad( rthraten, gsf, xlat,xlong               &
+                   ,dz8w,t8w,rho_phy,sw_or_lw                     &
+                   ,alb,emiss,t3d,qv3d,qc3d,qr3d                  &
+                   ,qi3d,qs3d,qg3d                                &
+                   ,p3d,p8w3d,pi3d,cldfra3d                       &
+                   ,gmt,cp,g,julday,xtime,declin,solcon           &
+                   ,center_lat                                    &
+                   ,radfrq,degrad,taucldi,taucldc,warm_rain       &
+                   ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg                 &
+                   ,ids,ide, jds,jde, kds,kde                     & 
+                   ,ims,ime, jms,jme, kms,kme                     &
+                   ,its,ite, jts,jte, kts,kte                     & 
+!                   ,cosz_urb2d,omg_urb2d                          & !optional urban
+                   ,ERBE_out                                      &  !optional sdsu
+                    )
+   implicit none
+
+!------- I / O variables ----------------------------------------------
+
+ character(len=2), intent(in) :: &
+   sw_or_lw   ! 'sw'=shortwave radiation,'lw'=longwave radiation,'is'=ISCCP simulator
+
+ integer,    intent(in) :: &
+    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
+   julday     ! integer of julian date  
+
+ logical,    intent(in) ::  &
+   warm_rain  ! logics for warm_rain only or not
+
+ real, intent(in)      ::  &
+   radfrq, &  ! time for calling radiation (min)                
+   degrad, &  ! conversion factor for degrees to radians (pi/180.) (rad/deg)
+   xtime,  &  ! time since simulation start (min)
+   declin, &  ! solar declination angle (rad)
+   solcon, &  ! solar constant (W/m^2) 
+      gmt, &  ! greenwich mean time hour of model start (hour)
+       cp, &  ! heat capacity at constant pressure for dry air (J/kg/K)
+        g     ! acceleration due to gravity (m/s^2)
+
+ real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: &
+       p3d, &  ! pressure (Pa) 
+     p8w3d, &  ! pressure at full levels (Pa)
+      pi3d, &  ! exner function (-)
+       t3d, &  ! temperature (K)
+       t8w, &  ! temperature at full levels (K)
+      dz8w, &  ! dz between full levels (m)
+   rho_phy, &  ! density (kg/m^3)
+  cldfra3d     ! cloud fraction (0-1)
+
+ real, dimension( ims:ime, jms:jme ), intent(in)  :: &
+       xlat, &  ! latitude, south is negative (degree)
+      xlong, &  ! longitude, west is negative (degree)
+        alb, &  ! broadband surface albedo (between 0 and 1)
+       emiss    ! broadband surface emissivity (between 0 and 1)
+
+ real, dimension( ims:ime, kms:kme, jms:jme ),optional,intent(in) :: &
+     qv3d,   & ! water vapor mixing ratio (kg/kg)  (in)
+     qc3d,   & ! cloud water mixing ratio (kg/kg)  (in)
+     qr3d,   & ! rain water mixing ratio (kg/kg)   (in)
+     qi3d,   & ! cloud ice mixing ratio (kg/kg)    (in)
+     qs3d,   & ! snow mixing ratio (kg/kg)         (in)
+     qg3d      ! graupel mixing ration (kg/kg)     (in)
+
+ logical, optional, intent(in )  ::  f_qv,f_qc,f_qr,f_qi,f_qs,f_qg  !hydrometeor flags 
+!
+ real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout)  :: &
+  rthraten, &  ! theta tendency due to radiative heating (K/sec)
+   taucldi, &  ! ice cloud optical thickness for visible broadband
+   taucldc     ! liquid cloud optical thickness for visible braodband
+
+ real, dimension( ims:ime, jms:jme ), intent(inout)  ::  &
+         gsf    ! (for SW) : net short wave flux at ground surface (W/m^2) 
+                ! (for LW) : downward long wave flux at ground surface (W/m^2)
+
+!
+! 
+! Extra 3D variables (last dimension 1-TOA LW down, 2-TOA LW up, 3-surface LW down, 4-surface LW up)
+!                                    5-TOA SW down, 6-TOA SW up, 7-surface SW down, 8-surface SW up)
+
+   real, optional,dimension(ims:ime, jms:jme, 1:8),intent(out) :: ERBE_out  !extra output for SDSU
+
+!------- Local variables ----------------------------------------------
+
+ integer :: i,j,k,nk,ib,is ! loop indice
+ integer :: mix, mkx !maximum dimension for i and k
+
+
+ real(Kind=fp_kind), dimension( its:ite ) :: &
+    cosz, &  ! cosine of solar zenith angle (0~1)
+  rsuvbm, &  ! surface albedo for direct UV-VIS radiation
+  rsuvdf, &  ! surface albedo for diffuse UV-VIS radiation
+  rsirbm, &  ! surface albedo for direct NIR radiation
+  rsirdf, &  ! surface albedo for diffuse NIR radiation
+    tsfc, &  ! surface air temperature (K)
+   tskin, &  ! surface skin (radiative) temperature (K)
+    p400, &  ! pressure criteria for upper
+    p700     ! pressure criteir for middle
+
+ real(Kind=fp_kind), dimension( its:ite, ib_lw ) :: emis2d !emissivity
+
+ integer, dimension( its:ite ) ::  &
+   ict, & ! 400mb level indice
+   icb    ! 700mb level indice
+
+ real(Kind=fp_kind), dimension( its:ite, kts-1:kte+1 )  :: &
+   flx, & !flux fraction (-) or actual flux (W/m^2) 
+  flxd, & !donwelling flux fraction [-] (for shortwave) , but actual flux [W/m2] (for longwave)
+  flxu    !upwelling flux fraction [-] (for shortwave) , but actual flux [W/m2] (for longwave) 
+
+
+ real(Kind=fp_kind), dimension( its:ite, kts-1:kte ) :: o3  !ozone profile
+
+ real(Kind=fp_kind), dimension( its:ite, kts-1:kte, ib_sw ) :: &
+  taual_sw, &  ! aerosol optical depth for SW bands
+  ssaal_sw, &  ! aerosol single scattering albedo for SW bands
+  asyal_sw     ! aerosol asymetry factor for SW bands
+
+ real(Kind=fp_kind), dimension( its:ite, kts-1:kte, ib_lw ) ::  &
+  taual_lw, &  ! aerosol optical depth for LW bands
+  ssaal_lw, &  ! aerosol single scattering albedo for LW bands
+  asyal_lw     ! aerosol asymetry factor for LW bands
+
+ real(Kind=fp_kind), dimension( its:ite, kts-1:kte, 3 ) :: &  !1-ice cloud, 2-liquid cloud, 3-rain
+      reff, &  !particle effective size (micron)
+       cwc     !hydrometer mixing ratio (kg/kg) or (g/g) 
+
+ real(Kind=fp_kind), dimension( its: ite, kts-1:kte+1 ) :: &
+     p8w2d, &  ! pressure in full level (mb)
+     t8w2d     ! temperature in full level (K)
+
+ real(Kind=fp_kind), dimension( its: ite, kts-1:kte ) ::   &
+     tten2d, &  ! temperature tendency (K/sec)
+       sh2d, &  ! specific humidity (-)
+        p2d, &  ! pressure (mb)
+        t2d, &  ! temperature (K)
+       dz2d, &  ! layer depth
+     fcld2d     ! cloud fraction
+
+   real(Kind=fp_kind), dimension( its:ite , kts:kte+1 ) :: phyd    ! pressure (Pa)
+   real(Kind=fp_kind), dimension( its:ite , kts:kte   ) :: phydmid ! pressure in middle (Pa)
+
+!
+! ozone table
+!
+   integer,    parameter    ::  np    = 75
+   real(Kind=fp_kind), dimension( np, 5 ) ::  pres, ozone
+   real(Kind=fp_kind), dimension( np )    ::  p
+
+  integer  ::  iprof !index for porfile
+  integer,parameter :: is_summer = 80 !summer start indice 
+  integer,parameter :: ie_summer = 265 !summer end indice
+!
+   real(Kind=fp_kind)    :: fac,x
+   real(Kind=fp_kind)    :: xt24,tloctm,hrang,xxlat
+   real, intent(in)    :: center_lat                ! center of latitude
+
+!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
+
+!--------------------------------------------------------------------------------
+!   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/
+
+!--------------------------------------------------------------------------------
+  mix = ite-its+1  ! maximum dimension for i
+  mkx = kte-kts+1  ! maximum dimension for k
+
+
+! 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
+
+!toshi
+!   center_lat = xlat ( mix/2, (jte-jts+1)/2 )
+
+   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
+     jloop=j 
+!-----------------------------------------------------------------------------
+
+      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) !keep this old one consistent to IDS ctl run.
+              phyd(i,k)=phyd(i,k-1)*exp( -9.8/287.04*dz8w(i,k-1,j)/t3d(i,k-1,j) ) !suggested by K. Suzuki
+
+              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
+            t8w2d(i,k) = t8w(i,nk,j)
+         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(i,k)=qv3d(i,nk,j)/(1.+qv3d(i,nk,j))
+            sh2d(i,k)=max(0._fp_kind,sh2d(i,k))
+            p2d(i,k)=phydmid(i,nk)*0.01      ! p2d is in mb
+            fcld2d(i,k)=cldfra3d(i,nk,j)
+            dz2d(i,k)  = dz8w(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 (.not. warm_rain .and. .not. present ( f_qi ) ) 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)  ! ice cloud water mixing ratio
+!               cwc(i,k,2)=0.          ! liquid cloud water mixing ratio
+!            endif
+!         enddo
+!         enddo
+!      endif
+
+!
+! intilize TOA value -> 0. 
+!
+      do i=its,ite
+         tten2d(i,0)=0.
+         t2d(i,0)=t2d(i,1)
+         sh2d(i,0)=0.5*sh2d(i,1)
+         dz2d(i,0)=dz2d(i,1)
+         cwc(i,0,3)=0.
+         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
+
+!
+! vertical profiles for ozone
+!
+      call o3_profile (np, p, ozone(1,iprof), its, ite, kts-1, kte, p2d, o3)
+
+!
+! cloud water mixing ratio
+!
+      if ( present( f_qc ) .and. present( qc3d)  ) then
+         do k=kts,kte
+            do i=its,ite
+               nk=kme-1-k+kms
+               if ( (f_qc) ) then
+                  cwc(i,k,2)=max(0.,qc3d(i,nk,j))
+                  reff(i,k,2) = re !fixed value
+                  x=1.02*10000.*( p8w2d(i,k+1)-p8w2d(i,k) )
+                  taucldc(i,nk,j) = x * cwc(i,k,2) * ( 3.33e-4 + 2.52/reff(i,k,2) ) !output purpose
+               else
+                  cwc(i,k,2) = 0.
+                  reff(i,k,2) =0.
+                  taucldc(i,nk,j) = 0.
+               endif
+            enddo
+         enddo
+      endif
+
+!
+! cloud ice mixing ratio (currently adding the snow.)
+!
+      if ( present( f_qi ) .and. present( qi3d)  ) then ! ice
+         do k=kts,kte          
+            do i=its,ite          
+               nk=kme-1-k+kms
+	       if ( (f_qi) ) then
+                  cwc(i,k,1)=max(0.,qi3d(i,nk,j))
+                  reff(i,k,1) = 125. + (t2d(i,k)-243.16)*5.  ! ice effective radius depends on temp
+                  x=1.02*10000.*( p8w2d(i,k+1)-p8w2d(i,k) )
+                  taucldi(i,nk,j) = x * cwc(i,k,1) * ( -6.59e-3 + 1.65/reff(i,k,1) ) ! output purpose
+               else
+                  cwc(i,k,1)= 0.
+                  reff(i,k,1) = 0.
+                  taucldi(i,nk,j) = 0.
+               endif
+            enddo
+         enddo
+      endif
+
+      if ( present( f_qs ) .and. present( qs3d )  ) then ! snow
+         do k=kts,kte
+            do i=its,ite
+               nk=kme-1-k+kms
+               if ( (f_qs) ) then
+                  if ( cwc(i,k,1) > 0. ) then !ice exist
+                    cwc(i,k,1)=cwc(i,k,1) + max(0.,qs3d(i,nk,j)) ! ice + snow
+                    reff(i,k,1) = 125. + (t2d(i,k)-243.16)*5.    ! ice + snow (use ice definition) 
+                  else
+                    cwc(i,k,1)= max(0.,qs3d(i,nk,j))  ! snow only (define snow is large aggrefated ice)
+                    reff(i,k,1) = 125.                ! snow only (use largest reff of ice)
+                  endif 
+                  x=1.02*10000.*( p8w2d(i,k+1)-p8w2d(i,k) )
+                  taucldi(i,nk,j) = x * cwc(i,k,1) * ( -6.59e-3 + 1.65/reff(i,k,1) ) ! output purpose
+               else
+                  cwc(i,k,1)=cwc(i,k,1)
+               endif
+            enddo
+         enddo
+      endif
+
+!
+! rain mixing ratio (currently adding graupel here, since it's size are much larger than ice and snow)
+!
+
+      if ( present( f_qr ) .and. present( qr3d)  ) then  ! rain
+         do k=kts,kte
+            do i=its,ite
+               nk=kme-1-k+kms
+               if ( (f_qr) ) then
+                   cwc(i,k,3)  = max(0.,qr3d(i,nk,j))
+               else
+                   cwc(i,k,3)  = 0.
+               endif
+            enddo
+         enddo
+      endif
+
+
+      if ( present( f_qg ) .and. present( qg3d)  ) then ! graupel (-> change)
+         do k=kts,kte
+            do i=its,ite
+               nk=kme-1-k+kms
+               if ( (f_qg) ) then
+                  if( cwc(i,k,3) > 0.) then
+                    cwc(i,k,3)=cwc(i,k,3) + max(0.,qg3d(i,nk,j))
+                  else
+                    cwc(i,k,3)= max(0.,qg3d(i,nk,j))
+                  endif
+               else
+                  cwc(i,k,3)=cwc(i,k,3)
+               endif
+            enddo
+         enddo
+      endif
+
+!
+! Vertical profiles for effective particle size (old)
+!
+!      do k = kts-1, kte
+!      do i = its, ite
+!         reff(i,k,1) = 80.
+!         reff(i,k,2) = 10.
+!         reff(i,k,3) = 500.  !dummy not used
+!      end do
+!      end do
+
+!
+! filter min and max value of effective size 
+!
+   do k = kts-1, kte
+      do i = its, ite
+         reff(i,k,1) = max( min(reff(i,k,1),125._fp_kind) ,   25._fp_kind) !ice
+         reff(i,k,2) = max( min(reff(i,k,2), 20._fp_kind) ,    4._fp_kind) !liquid 
+         reff(i,k,3) = max( min(reff(i,k,3), 60._fp_kind) , 1800._fp_kind) !rain (dummy not used)
+      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
+
+
+ rad_select: select case(sw_or_lw)
+
+! ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP
+! ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP
+! ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP ISCCP
+
+     case('is') 
+
+! in case of isccp simulation, all we need is cloud optical depth. So return.
+
+! SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW 
+! SW SW SW SW SW SW SW SW  Shortwave scheme SW SW SW SW SW SW SW SW SW 
+! SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW SW 
+     
+      case ('sw')
+
+
+
+!
+! solar zenith angle and surface albedo
+!
+      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)
+
+!
+! surface spectrum albedo for direct and diffuse radiation
+!
+        rsuvbm(i) = alb(i,j)
+        rsuvdf(i) = alb(i,j)
+        rsirbm(i) = alb(i,j)
+        rsirdf(i) = alb(i,j)
+!
+! urban
+!
+!       if(present(cosz_urb2d)) cosz_urb2d(i,j)=cosz(i)  !urban
+!       if(present(omg_urb2d)) omg_urb2d(i,j)=hrang     !urban
+      end do
+
+!
+! aerosol effects -> gocart aerosol module
+!
+
+   do ib = 1, ib_sw
+      do k = kts-1,kte
+         do i = its,ite
+            taual_sw(i,k,ib) = 0.
+            ssaal_sw(i,k,ib) = 0.
+            asyal_sw(i,k,ib) = 0.
+         end do
+      end do
+   end do
+
+!
+! 1-dimension driver of shortwave radiative transfer scheme
+!
+     do i = its,ite
+      if (cosz(i) .gt. cosz_min) then !for daytime only
+      call swrad ( m=1, np=mkx+1, pl=p8w2d(i,:), ta=t2d(i,:), wa=sh2d(i,:), oa=o3(i,:),         &
+                   cwc=cwc(i,:,:), reff=reff(i,:,:), fcld=fcld2d(i,:), ict=ict(i), icb=icb(i),      &
+                   taual=taual_sw(i,:,:), ssaal=ssaal_sw(i,:,:), asyal=asyal_sw(i,:,:), &
+                   cosz=cosz(i), rsuvbm=rsuvbm(i), rsuvdf=rsuvdf(i), rsirbm=rsirbm(i), rsirdf=rsirdf(i),  &
+                   flx=flx(i,:), flxd=flxd(i,:),flxu=flxu(i,:) )
+      endif
+     enddo
+!
+! convert the units of flx and flc from fraction to w/m^2
+!
+      do k = kts, kte+1
+        do i = its, ite
+          if (cosz(i) .le. cosz_min) 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
+             tten2d(i,k) = - fac * (flx(i,k) - flx(i,k+1))/ (p8w2d(i,k)-p8w2d(i,k+1))
+      end do
+   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
+
+      do i = its, ite
+        if (cosz(i) .le. cosz_min) then
+          gsf(i,j) = 0.
+          if(present(ERBE_out)) then
+             ERBE_out(i,j,5) = 0.   
+             ERBE_out(i,j,6) = 0.  
+             ERBE_out(i,j,7) = 0.  
+             ERBE_out(i,j,8) = 0. 
+          endif
+        else
+!
+! absorbed part in surface energy budget [W/m^2] (Note that flxd in SW is flux fraction)
+!
+          gsf(i,j) = (1. - rsuvbm(i)) * flxd(i,kte+1) * solcon * cosz(i)
+
+!
+! extra output for SDSU
+!       
+          if(present(ERBE_out)) then
+             ERBE_out(i,j,5) = flxd(i,1)     * solcon * cosz(i)  ! TOA SW downwelling flux [W/m2] 
+             ERBE_out(i,j,6) = flxu(i,1)     * solcon * cosz(i)  ! TOA SW upwelling flux   [W/m2]
+             ERBE_out(i,j,7) = flxd(i,kte+1) * solcon * cosz(i)  ! surface SW downwelling flux [W/m2]
+             ERBE_out(i,j,8) = flxu(i,kte+1) * solcon * cosz(i)  ! surface SW upwelling flux   [W/m2]
+          endif
+        endif
+      enddo
+
+! LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW 
+! LW LW LW LW LW LW LW LW  Longwave scheme  LW LW LW LW LW LW LW LW LW 
+! LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW LW 
+
+  case ('lw')
+
+!
+! aerosol effects -> gocart aerosol module
+!
+
+   do ib = 1, ib_lw
+      do k = kts-1,kte
+         do i = its,ite
+            taual_lw(i,k,ib) = 0.
+            ssaal_lw(i,k,ib) = 0.
+            asyal_lw(i,k,ib) = 0.
+         end do
+      end do
+   end do
+
+!
+! surface parameters
+!
+      do i = its,ite
+        emis2d(i,1:ib_lw) = emiss(i,j)
+!toshi
+        tsfc(i)=0.5*t8w2d(i,kme) + 0.5*t2d(i,kte)  !make sure
+        tskin(i)=t8w2d(i,kme)
+      end do
+
+!
+! drive goddard longwave radiative transfer scheme
+!
+      call lwrad (m=mix, np=mkx+1, pl=p8w2d, ta=t2d, wa=sh2d, oa=o3, tb=tsfc, ts=tskin, &
+                  cwc=cwc, emiss=emis2d, reff=reff, fcld=fcld2d, ict=ict, icb=icb,      &
+                   taual=taual_lw, ssaal=ssaal_lw, asyal=asyal_lw,                      &
+                   flx=flx, acflxd=flxd , acflxu=flxu )
+
+!
+! calculate heating rate (deg/sec)
+!
+      fac = .01 * g / cp
+   do k = kts, kte
+      do i = its, ite
+         tten2d(i,k) = - fac * (flx(i,k) - flx(i,k+1))/(p8w2d(i,k)-p8w2d(i,k+1)) 
+      end do
+   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)  !<- potential temperature
+         enddo
+      enddo
+
+!
+! downwelling/upwelling longwave radiation [W/m^2] (Note that flxd/flxu of LW is actual flux [W/m2])
+!
+
+      do i = its, ite
+          gsf(i,j) = flxd(i,kte+1)  !surface downwelling LW radiation
+
+!
+! extra output for SDSU
+!       
+          if(present(ERBE_out)) then
+             ERBE_out(i,j,1) = flxd(i,1)      ! TOA LW downwelling flux [W/m2] 
+             ERBE_out(i,j,2) = flxu(i,1)      ! TOA LW upwelling flux   [W/m2]
+             ERBE_out(i,j,3) = flxd(i,kte+1)  ! surface LW downwelling flux   [W/m2]
+             ERBE_out(i,j,4) = flxu(i,kte+1)  ! surface LW upwelling flux   [W/m2]
+          endif
+      end do
+
+
+  case default
+
+       stop 'the option does not exist: sw_or_lw '
+
+  end select rad_select
+
+!
+!-----------------------------------------------------------------------
+!
+   enddo j_loop                                          
+
+ end subroutine goddardrad
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+  subroutine swrad (m,np,pl,ta,wa,oa, cwc,reff,fcld,ict,icb, &
+                    taual,ssaal,asyal, cosz,rsuvbm,rsuvdf,rsirbm,rsirdf, &
+                    flx,flxd,flxu) 
+
+!------------     corrections for bugs      ----------------------------
+!
+!     a bug was found in "ntop=nctop(m)", it has been corrected to be
+!     "ntop=nctop(i)".   dated march 28, 2000.
+!
+!
+!-----------------------------------------------------------------------
+!
+! following the nasa technical memorandum (nasa/tm-1999-104606, vol. 15)
+!  of chou and suarez (1999), this routine computes solar fluxes due to
+!  absorption by water vapor, ozone, co2, o2, clouds, and aerosols and
+!  due to scattering by clouds, aerosols, and gases.
+!
+! this code computes fluxes simultaneously for m soundings.
+!
+! cloud ice, liquid, and rain particles are allowed to co-exist in a layer.
+!
+! if no information is available for the effective particle size, reff,
+!  default values of 10 micron for liquid water and 75 micron for ice may be
+!  used.
+!  the size of raindrops, reff(3), is irrelevant in this code. it can be
+!  set to any values.
+!  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 "cloud_scale".
+!
+! aerosol optical thickness, single-scattering albedo, and asymmetry
+!  factor can be specified as functions of height and spectral band.
+!
+!----- input parameters:
+!                                                   units      size
+!  number of soundings (m)                          n/d         1
+!  number of atmospheric layers (np)                n/d         1
+!  level pressure (pl)                              mb        m*(np+1)
+!  layer temperature (ta)                           k         m*np
+!  layer specific humidity (wa)                     gm/gm     m*np
+!  layer ozone concentration (oa)                   gm/gm     m*np
+!  co2 mixing ratio by volume (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*np*3
+!        index 1 for ice particles
+!        index 2 for liquid drops
+!        index 3 for rain drops
+!  cloud optical thickness (taucld)                 n/d       m*np*3
+!        index 1 for ice particles
+!        index 2 for liquid drops
+!        index 3 for rain drops
+!  effective cloud-particle size (reff)          micrometer   m*np*3
+!        index 1 for ice particles
+!        index 2 for liquid drops
+!        index 3 for rain drops
+!  cloud amount (fcld)                            fraction    m*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*np*11
+!  aerosol single-scattering albedo (ssaal)         n/d       m*np*11
+!  aerosol asymmetry factor (asyal)                 n/d       m*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
+!   uv+visible sfc albedo for beam radiation
+!        for wavelengths<0.7 micron (rsuvbm)       fraction   m
+!   uv+visible sfc albedo for diffuse radiation
+!        for wavelengths<0.7 micron (rsuvdf)       fraction   m
+!   ir sfc albedo for beam radiation
+!        for wavelengths>0.7 micron  (rsirbm)      fraction   m
+!   ir sfc albedo for diffuse radiation (rsirdf)   fraction   m
+!
+!----- output parameters
+!
+!   all-sky flux divergence (downward minus upward) (flx)     fraction   m*(np+1)
+!   clear-sky flux divergence (downward minus upward) (flc)   fraction   m*(np+1)
+! 
+!   all-sky direct downward uv (0.175-0.4 micron)
+!                flux at the surface (fdiruv)      fraction   m
+!   all-sky diffuse downward uv flux at
+!                the surface (fdifuv)              fraction   m
+!   all-sky direct downward par (0.4-0.7 micron)
+!                flux at the surface (fdirpar)     fraction   m
+!   all-sky diffuse downward par flux at
+!                the surface (fdifpar)             fraction   m
+!   all-sky direct downward ir (0.7-10 micron)
+!                flux at the surface (fdirir)      fraction   m
+!   all-sky diffuse downward ir flux at
+!                the surface (fdifir)              fraction   m
+!
+!----- notes:
+!
+!    (1) the unit of output fluxes (flx,flc,etc.) is fraction of the
+!        insolation at the top of the atmosphere.  therefore, fluxes
+!        are the output fluxes multiplied by the extra-terrestrial solar
+!        flux and the cosine of the solar zenith angle.
+!    (2) pl( ,1) is the pressure at the top of the model, and
+!        pl( ,np+1) is the surface pressure.
+!    (3) the pressure levels ict and icb correspond approximately
+!        to 400 and 700 mb.
+!
+!-----if coding errors are found, please notify ming-dah chou at
+!     chou@climate.gsfc.nasa.gov
+!
+!*************************************************************************
+ implicit none
+
+!-----IO parameters
+ integer,intent(in) :: m,np,ict(m),icb(m)
+ real(Kind=fp_kind),intent(in) :: pl(m,np+1),ta(m,np),wa(m,np),oa(m,np)
+ real(Kind=fp_kind),intent(in) :: cwc(m,np,3),reff(m,np,3),fcld(m,np)
+ real(Kind=fp_kind),intent(in) :: taual(m,np,ib_sw),ssaal(m,np,ib_sw),asyal(m,np,ib_sw)
+ real(Kind=fp_kind),intent(in) :: cosz(m),rsuvbm(m),rsuvdf(m),rsirbm(m),rsirdf(m)
+
+ real(Kind=fp_kind),intent(inout) :: flx(m,np+1)    !flux divergence (down-up) []
+ real(Kind=fp_kind),intent(inout) :: flxd(m,np+1)   !downward flux fraction []
+ real(Kind=fp_kind),intent(inout) :: flxu(m,np+1)   !upwelling flux fraction []
+!-----IO parameter used to be-----
+ real(Kind=fp_kind) flc(m,np+1)
+ real(Kind=fp_kind) fdiruv (m),fdifuv (m)
+ real(Kind=fp_kind) fdirpar(m),fdifpar(m)
+ real(Kind=fp_kind) fdirir (m),fdifir (m)
+
+!-----temporary array
+ integer i,j,k,ntop
+ integer :: nctop(m)
+ real(Kind=fp_kind) x
+ real(Kind=fp_kind) :: taucld(m,np,3)
+ real(Kind=fp_kind) :: taux(m,np)     ! total condensates optical depth
+ real(Kind=fp_kind) :: cwp(m,np,3)
+ real(Kind=fp_kind) :: dp(m,np)
+ real(Kind=fp_kind) :: wh(m,np)
+ real(Kind=fp_kind) :: oh(m,np)
+ real(Kind=fp_kind) :: scal(m,np)
+ real(Kind=fp_kind) :: swu(m,np+1)
+ real(Kind=fp_kind) :: swh(m,np+1)
+ real(Kind=fp_kind) :: so2(m,np+1)    !scaled o2 conc
+ real(Kind=fp_kind) :: df(m,np+1)     !integrated flux refuction rate []
+ real(Kind=fp_kind) :: df_sub(m,np+1) !sub-layer flux reduction rate []
+ real(Kind=fp_kind) :: df_cld(m,np+1) !integrated clear-sky flux reduction rate []
+ real(Kind=fp_kind) :: df_clr(m,np+1) !integrated all-sky flux reduction rate []
+ real(Kind=fp_kind) :: snt(m)         !inverse of cosz
+ real(Kind=fp_kind) :: cnt(m)
+
+! new look-up table for (Fclr/Fall) ratio (overcast_fast option)
+  real(Kind=fp_kind) :: ratio, cld_alb
+  integer :: i_cos, i_tau
+  real(Kind=fp_kind) :: ratio_lut(10,10)
+   data ((ratio_lut(i,j),i=1,10),j=1,10)/ &  !i cosin  j albedo
+   0.796, 0.559, 0.523, 0.474, 0.439, 0.377, 0.298, 0.239, 0.154, 0.086, &
+   0.845, 0.628, 0.566, 0.508, 0.457, 0.392, 0.315, 0.242, 0.156, 0.087, &
+   0.894, 0.697, 0.609, 0.542, 0.475, 0.407, 0.332, 0.245, 0.158, 0.088, &
+   0.924, 0.759, 0.662, 0.581, 0.511, 0.432, 0.350, 0.269, 0.173, 0.092, &
+   0.944, 0.809, 0.713, 0.634, 0.552, 0.471, 0.381, 0.288, 0.183, 0.097, &
+   0.961, 0.848, 0.760, 0.689, 0.602, 0.516, 0.425, 0.323, 0.208, 0.116, &
+   0.971, 0.882, 0.808, 0.730, 0.650, 0.556, 0.456, 0.355, 0.233, 0.134, &
+   0.978, 0.910, 0.844, 0.776, 0.695, 0.601, 0.499, 0.387, 0.256, 0.141, &
+   0.984, 0.934, 0.876, 0.810, 0.731, 0.637, 0.533, 0.405, 0.275, 0.151, &
+   0.988, 0.944, 0.897, 0.844, 0.773, 0.683, 0.561, 0.421, 0.277, 0.156/
+
+!-----parameters for co2 transmission tables---------------------------
+      integer nu,nw,nx2,ny2 ! cccshie 9/15/04
+      parameter (nu=43,nw=37,nx2=62,ny2=101)
+      real(Kind=fp_kind) w1,dw,u1,du,coa(nx2,ny2),cah(nu,nw)
+!-----cah is the co2 absorptance in band 10
+      data ((cah(i,j),i=1,43),j=  1,  1)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000053,  0.0000074, &
+        0.0000104,  0.0000147,  0.0000206,  0.0000288,  0.0000402, &
+        0.0000559,  0.0000772,  0.0001059,  0.0001439,  0.0001936, &
+        0.0002575,  0.0003384,  0.0004400,  0.0005662,  0.0007219, &
+        0.0009131,  0.0011470,  0.0014327,  0.0017806,  0.0022021, &
+        0.0027093,  0.0033141,  0.0040280,  0.0048609,  0.0058217, &
+        0.0069177,  0.0081559,  0.0095430/
+      data ((cah(i,j),i=1,43),j=  2,  2)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000053,  0.0000074, &
+        0.0000104,  0.0000147,  0.0000206,  0.0000288,  0.0000402, &
+        0.0000559,  0.0000772,  0.0001059,  0.0001439,  0.0001936, &
+        0.0002575,  0.0003384,  0.0004400,  0.0005662,  0.0007219, &
+        0.0009130,  0.0011470,  0.0014326,  0.0017805,  0.0022020, &
+        0.0027091,  0.0033139,  0.0040276,  0.0048605,  0.0058211, &
+        0.0069170,  0.0081551,  0.0095420/
+      data ((cah(i,j),i=1,43),j=  3,  3)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000053,  0.0000074, &
+        0.0000104,  0.0000147,  0.0000206,  0.0000288,  0.0000402, &
+        0.0000559,  0.0000772,  0.0001059,  0.0001439,  0.0001936, &
+        0.0002574,  0.0003384,  0.0004399,  0.0005661,  0.0007218, &
+        0.0009129,  0.0011468,  0.0014325,  0.0017803,  0.0022017, &
+        0.0027088,  0.0033135,  0.0040271,  0.0048599,  0.0058204, &
+        0.0069161,  0.0081539,  0.0095406/
+      data ((cah(i,j),i=1,43),j=  4,  4)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000053,  0.0000074, &
+        0.0000104,  0.0000147,  0.0000206,  0.0000288,  0.0000402, &
+        0.0000559,  0.0000772,  0.0001059,  0.0001439,  0.0001936, &
+        0.0002574,  0.0003384,  0.0004399,  0.0005661,  0.0007217, &
+        0.0009128,  0.0011467,  0.0014323,  0.0017800,  0.0022014, &
+        0.0027084,  0.0033130,  0.0040265,  0.0048591,  0.0058194, &
+        0.0069148,  0.0081524,  0.0095387/
+      data ((cah(i,j),i=1,43),j=  5,  5)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000053,  0.0000074, &
+        0.0000104,  0.0000147,  0.0000206,  0.0000288,  0.0000402, &
+        0.0000559,  0.0000772,  0.0001059,  0.0001439,  0.0001935, &
+        0.0002574,  0.0003383,  0.0004398,  0.0005660,  0.0007216, &
+        0.0009127,  0.0011465,  0.0014320,  0.0017797,  0.0022010, &
+        0.0027078,  0.0033123,  0.0040256,  0.0048580,  0.0058180, &
+        0.0069132,  0.0081503,  0.0095361/
+      data ((cah(i,j),i=1,43),j=  6,  6)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000053,  0.0000074, &
+        0.0000104,  0.0000147,  0.0000206,  0.0000288,  0.0000402, &
+        0.0000559,  0.0000772,  0.0001059,  0.0001439,  0.0001935, &
+        0.0002573,  0.0003383,  0.0004398,  0.0005659,  0.0007215, &
+        0.0009125,  0.0011462,  0.0014317,  0.0017792,  0.0022004, &
+        0.0027071,  0.0033113,  0.0040244,  0.0048565,  0.0058162, &
+        0.0069109,  0.0081476,  0.0095328/
+      data ((cah(i,j),i=1,43),j=  7,  7)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000053,  0.0000074, &
+        0.0000104,  0.0000147,  0.0000206,  0.0000288,  0.0000402, &
+        0.0000559,  0.0000772,  0.0001058,  0.0001438,  0.0001935, &
+        0.0002573,  0.0003382,  0.0004396,  0.0005657,  0.0007213, &
+        0.0009122,  0.0011459,  0.0014312,  0.0017786,  0.0021996, &
+        0.0027061,  0.0033100,  0.0040228,  0.0048545,  0.0058137, &
+        0.0069079,  0.0081439,  0.0095283/
+      data ((cah(i,j),i=1,43),j=  8,  8)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000052,  0.0000074, &
+        0.0000104,  0.0000146,  0.0000206,  0.0000288,  0.0000402, &
+        0.0000558,  0.0000772,  0.0001058,  0.0001438,  0.0001934, &
+        0.0002572,  0.0003381,  0.0004395,  0.0005655,  0.0007210, &
+        0.0009119,  0.0011454,  0.0014306,  0.0017778,  0.0021985, &
+        0.0027047,  0.0033084,  0.0040207,  0.0048519,  0.0058105, &
+        0.0069040,  0.0081391,  0.0095225/
+      data ((cah(i,j),i=1,43),j=  9,  9)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000052,  0.0000074, &
+        0.0000104,  0.0000146,  0.0000206,  0.0000288,  0.0000402, &
+        0.0000558,  0.0000771,  0.0001058,  0.0001437,  0.0001933, &
+        0.0002571,  0.0003379,  0.0004393,  0.0005652,  0.0007206, &
+        0.0009114,  0.0011447,  0.0014297,  0.0017767,  0.0021971, &
+        0.0027030,  0.0033061,  0.0040180,  0.0048485,  0.0058064, &
+        0.0068989,  0.0081329,  0.0095149/
+      data ((cah(i,j),i=1,43),j= 10, 10)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000052,  0.0000074, &
+        0.0000104,  0.0000146,  0.0000205,  0.0000288,  0.0000402, &
+        0.0000558,  0.0000771,  0.0001057,  0.0001437,  0.0001932, &
+        0.0002569,  0.0003377,  0.0004390,  0.0005649,  0.0007201, &
+        0.0009107,  0.0011439,  0.0014286,  0.0017753,  0.0021953, &
+        0.0027006,  0.0033032,  0.0040144,  0.0048441,  0.0058009, &
+        0.0068922,  0.0081248,  0.0095051/
+      data ((cah(i,j),i=1,43),j= 11, 11)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000052,  0.0000074, &
+        0.0000104,  0.0000146,  0.0000205,  0.0000287,  0.0000401, &
+        0.0000558,  0.0000770,  0.0001056,  0.0001436,  0.0001931, &
+        0.0002567,  0.0003375,  0.0004387,  0.0005644,  0.0007195, &
+        0.0009098,  0.0011428,  0.0014271,  0.0017734,  0.0021929, &
+        0.0026976,  0.0032995,  0.0040097,  0.0048384,  0.0057939, &
+        0.0068837,  0.0081145,  0.0094926/
+      data ((cah(i,j),i=1,43),j= 12, 12)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000052,  0.0000074, &
+        0.0000104,  0.0000146,  0.0000205,  0.0000287,  0.0000401, &
+        0.0000557,  0.0000770,  0.0001055,  0.0001434,  0.0001929, &
+        0.0002565,  0.0003371,  0.0004382,  0.0005637,  0.0007186, &
+        0.0009087,  0.0011413,  0.0014252,  0.0017709,  0.0021898, &
+        0.0026937,  0.0032946,  0.0040038,  0.0048311,  0.0057850, &
+        0.0068729,  0.0081013,  0.0094768/
+      data ((cah(i,j),i=1,43),j= 13, 13)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000052,  0.0000074, &
+        0.0000104,  0.0000146,  0.0000205,  0.0000287,  0.0000400, &
+        0.0000556,  0.0000769,  0.0001054,  0.0001432,  0.0001926, &
+        0.0002561,  0.0003366,  0.0004376,  0.0005629,  0.0007175, &
+        0.0009073,  0.0011394,  0.0014228,  0.0017678,  0.0021859, &
+        0.0026888,  0.0032885,  0.0039963,  0.0048218,  0.0057738, &
+        0.0068592,  0.0080849,  0.0094570/
+      data ((cah(i,j),i=1,43),j= 14, 14)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000052,  0.0000074, &
+        0.0000104,  0.0000146,  0.0000205,  0.0000286,  0.0000400, &
+        0.0000556,  0.0000767,  0.0001052,  0.0001430,  0.0001923, &
+        0.0002557,  0.0003361,  0.0004368,  0.0005619,  0.0007161, &
+        0.0009054,  0.0011370,  0.0014197,  0.0017639,  0.0021809, &
+        0.0026826,  0.0032809,  0.0039869,  0.0048103,  0.0057597, &
+        0.0068422,  0.0080643,  0.0094323/
+      data ((cah(i,j),i=1,43),j= 15, 15)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000052,  0.0000073, &
+        0.0000103,  0.0000145,  0.0000204,  0.0000286,  0.0000399, &
+        0.0000554,  0.0000766,  0.0001050,  0.0001427,  0.0001919, &
+        0.0002552,  0.0003353,  0.0004358,  0.0005605,  0.0007144, &
+        0.0009032,  0.0011340,  0.0014159,  0.0017590,  0.0021748, &
+        0.0026750,  0.0032715,  0.0039752,  0.0047961,  0.0057424, &
+        0.0068212,  0.0080389,  0.0094019/
+      data ((cah(i,j),i=1,43),j= 16, 16)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000019,  0.0000026,  0.0000037,  0.0000052,  0.0000073, &
+        0.0000103,  0.0000145,  0.0000204,  0.0000285,  0.0000398, &
+        0.0000553,  0.0000764,  0.0001047,  0.0001423,  0.0001914, &
+        0.0002545,  0.0003344,  0.0004345,  0.0005589,  0.0007122, &
+        0.0009003,  0.0011304,  0.0014112,  0.0017531,  0.0021673, &
+        0.0026656,  0.0032598,  0.0039609,  0.0047786,  0.0057211, &
+        0.0067954,  0.0080078,  0.0093646/
+      data ((cah(i,j),i=1,43),j= 17, 17)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000018,  0.0000026,  0.0000037,  0.0000052,  0.0000073, &
+        0.0000103,  0.0000145,  0.0000203,  0.0000284,  0.0000397, &
+        0.0000551,  0.0000761,  0.0001044,  0.0001419,  0.0001908, &
+        0.0002536,  0.0003332,  0.0004330,  0.0005568,  0.0007095, &
+        0.0008968,  0.0011259,  0.0014054,  0.0017458,  0.0021123, &
+        0.0026542,  0.0032457,  0.0039435,  0.0047573,  0.0056951, &
+        0.0067640,  0.0079700,  0.0093194/
+      data ((cah(i,j),i=1,43),j= 18, 18)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000007,  0.0000009,  0.0000013, &
+        0.0000018,  0.0000026,  0.0000037,  0.0000052,  0.0000073, &
+        0.0000102,  0.0000144,  0.0000202,  0.0000283,  0.0000395, &
+        0.0000549,  0.0000758,  0.0001040,  0.0001413,  0.0001900, &
+        0.0002525,  0.0003318,  0.0004311,  0.0005543,  0.0007063, &
+        0.0008926,  0.0011204,  0.0013985,  0.0017370,  0.0021470, &
+        0.0026404,  0.0032285,  0.0039224,  0.0047315,  0.0056637, &
+        0.0067260,  0.0079245,  0.0092651/
+      data ((cah(i,j),i=1,43),j= 19, 19)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000006,  0.0000009,  0.0000013, &
+        0.0000018,  0.0000026,  0.0000036,  0.0000051,  0.0000072, &
+        0.0000102,  0.0000143,  0.0000201,  0.0000282,  0.0000393, &
+        0.0000546,  0.0000754,  0.0001034,  0.0001406,  0.0001890, &
+        0.0002512,  0.0003300,  0.0004287,  0.0005513,  0.0007023, &
+        0.0008875,  0.0011139,  0.0013901,  0.0017264,  0.0021337, &
+        0.0026238,  0.0032080,  0.0038971,  0.0047005,  0.0056261, &
+        0.0066806,  0.0078701,  0.0092003/
+      data ((cah(i,j),i=1,43),j= 20, 20)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000006,  0.0000009,  0.0000013, &
+        0.0000018,  0.0000026,  0.0000036,  0.0000051,  0.0000072, &
+        0.0000101,  0.0000142,  0.0000200,  0.0000280,  0.0000391, &
+        0.0000543,  0.0000750,  0.0001028,  0.0001397,  0.0001878, &
+        0.0002496,  0.0003279,  0.0004259,  0.0005476,  0.0006975, &
+        0.0008813,  0.0011060,  0.0013802,  0.0017138,  0.0021179, &
+        0.0026040,  0.0031835,  0.0038670,  0.0046637,  0.0055814, &
+        0.0066267,  0.0078055,  0.0091235/
+      data ((cah(i,j),i=1,43),j= 21, 21)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000005,  0.0000006,  0.0000009,  0.0000013, &
+        0.0000018,  0.0000025,  0.0000036,  0.0000051,  0.0000071, &
+        0.0000100,  0.0000141,  0.0000198,  0.0000278,  0.0000388, &
+        0.0000539,  0.0000744,  0.0001020,  0.0001386,  0.0001863, &
+        0.0002477,  0.0003253,  0.0004226,  0.0005432,  0.0006918, &
+        0.0008740,  0.0010966,  0.0013683,  0.0016988,  0.0020991, &
+        0.0025806,  0.0031545,  0.0038313,  0.0046201,  0.0055285, &
+        0.0065630,  0.0077294,  0.0090332/
+      data ((cah(i,j),i=1,43),j= 22, 22)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000004,  0.0000006,  0.0000009,  0.0000013, &
+        0.0000018,  0.0000025,  0.0000036,  0.0000050,  0.0000071, &
+        0.0000100,  0.0000140,  0.0000197,  0.0000275,  0.0000384, &
+        0.0000534,  0.0000737,  0.0001011,  0.0001373,  0.0001846, &
+        0.0002453,  0.0003222,  0.0004185,  0.0005265,  0.0006850, &
+        0.0008652,  0.0010855,  0.0013541,  0.0016809,  0.0020768, &
+        0.0025528,  0.0031202,  0.0037892,  0.0045688,  0.0054664, &
+        0.0064883,  0.0076402,  0.0089277/
+      data ((cah(i,j),i=1,43),j= 23, 23)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000004,  0.0000006,  0.0000009,  0.0000013, &
+        0.0000018,  0.0000025,  0.0000035,  0.0000050,  0.0000070, &
+        0.0000098,  0.0000138,  0.0000194,  0.0000272,  0.0000380, &
+        0.0000528,  0.0000729,  0.0000999,  0.0001357,  0.0001825, &
+        0.0002425,  0.0003185,  0.0004137,  0.0005316,  0.0006769, &
+        0.0008548,  0.0010722,  0.0013373,  0.0016599,  0.0020504, &
+        0.0025201,  0.0030799,  0.0037398,  0.0045087,  0.0053938, &
+        0.0064013,  0.0075366,  0.0088053/
+      data ((cah(i,j),i=1,43),j= 24, 24)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000004,  0.0000006,  0.0000009,  0.0000012, &
+        0.0000017,  0.0000025,  0.0000035,  0.0000049,  0.0000069, &
+        0.0000097,  0.0000137,  0.0000192,  0.0000268,  0.0000375, &
+        0.0000520,  0.0000719,  0.0000986,  0.0001339,  0.0001800, &
+        0.0002392,  0.0003142,  0.0004079,  0.0005242,  0.0006673, &
+        0.0008426,  0.0010567,  0.0013177,  0.0016352,  0.0020196, &
+        0.0024820,  0.0030330,  0.0036825,  0.0044391,  0.0053098, &
+        0.0063007,  0.0074172,  0.0084815/
+      data ((cah(i,j),i=1,43),j= 25, 25)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000004,  0.0000006,  0.0000009,  0.0000012, &
+        0.0000017,  0.0000024,  0.0000034,  0.0000048,  0.0000068, &
+        0.0000096,  0.0000134,  0.0000189,  0.0000264,  0.0000369, &
+        0.0000512,  0.0000708,  0.0000970,  0.0001318,  0.0001772, &
+        0.0002354,  0.0003091,  0.0004013,  0.0005156,  0.0006562, &
+        0.0008284,  0.0010386,  0.0012949,  0.0016066,  0.0019840, &
+        0.0024379,  0.0029788,  0.0036164,  0.0043590,  0.0052135, &
+        0.0061857,  0.0072808,  0.0085042/
+      data ((cah(i,j),i=1,43),j= 26, 26)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000002,  0.0000002, &
+        0.0000003,  0.0000004,  0.0000006,  0.0000008,  0.0000012, &
+        0.0000017,  0.0000024,  0.0000034,  0.0000047,  0.0000067, &
+        0.0000094,  0.0000132,  0.0000185,  0.0000259,  0.0000362, &
+        0.0000503,  0.0000695,  0.0000952,  0.0001294,  0.0001739, &
+        0.0002310,  0.0003033,  0.0003937,  0.0005057,  0.0006435, &
+        0.0008121,  0.0010180,  0.0012688,  0.0015739,  0.0019434, &
+        0.0023877,  0.0029172,  0.0035413,  0.0042681,  0.0051043, &
+        0.0060554,  0.0071267,  0.0083234/
+      data ((cah(i,j),i=1,43),j= 27, 27)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000001,  0.0000002, &
+        0.0000003,  0.0000004,  0.0000006,  0.0000008,  0.0000012, &
+        0.0000016,  0.0000023,  0.0000033,  0.0000046,  0.0000065, &
+        0.0000092,  0.0000129,  0.0000181,  0.0000254,  0.0000355, &
+        0.0000493,  0.0000680,  0.0000933,  0.0001267,  0.0001702, &
+        0.0002261,  0.0002968,  0.0003852,  0.0004946,  0.0006291, &
+        0.0007937,  0.0009946,  0.0012394,  0.0015370,  0.0018975, &
+        0.0023310,  0.0028478,  0.0034568,  0.0041660,  0.0049818, &
+        0.0059096,  0.0069544,  0.0081215/
+      data ((cah(i,j),i=1,43),j= 28, 28)/ &
+        0.0000001,  0.0000001,  0.0000001,  0.0000001,  0.0000002, &
+        0.0000003,  0.0000004,  0.0000006,  0.0000008,  0.0000011, &
+        0.0000016,  0.0000023,  0.0000032,  0.0000045,  0.0000064, &
+        0.0000090,  0.0000126,  0.0000177,  0.0000248,  0.0000346, &
+        0.0000481,  0.0000664,  0.0000910,  0.0001236,  0.0001661, &
+        0.0002206,  0.0002895,  0.0003755,  0.0004821,  0.0006130, &
+        0.0007731,  0.0009685,  0.0012065,  0.0014959,  0.0018463, &
+        0.0022680,  0.0027705,  0.0033629,  0.0040526,  0.0048459, &
+        0.0057480,  0.0067639,  0.0078987/
+      data ((cah(i,j),i=1,43),j= 29, 29)/ &
+        0.0000000,  0.0000001,  0.0000001,  0.0000001,  0.0000002, &
+        0.0000003,  0.0000004,  0.0000006,  0.0000008,  0.0000011, &
+        0.0000016,  0.0000022,  0.0000031,  0.0000044,  0.0000062, &
+        0.0000087,  0.0000123,  0.0000173,  0.0000242,  0.0000330, &
+        0.0000468,  0.0000646,  0.0000886,  0.0001203,  0.0001616, &
+        0.0002145,  0.0002814,  0.0003649,  0.0004682,  0.0005951, &
+        0.0007503,  0.0009396,  0.0011701,  0.0014505,  0.0017900, &
+        0.0021986,  0.0026857,  0.0032598,  0.0039283,  0.0046971, &
+        0.0055713,  0.0065558,  0.0076557/
+      data ((cah(i,j),i=1,43),j= 30, 30)/ &
+        0.0000000,  0.0000001,  0.0000001,  0.0000001,  0.0000002, &
+        0.0000003,  0.0000004,  0.0000005,  0.0000008,  0.0000011, &
+        0.0000015,  0.0000021,  0.0000030,  0.0000043,  0.0000060, &
+        0.0000085,  0.0000119,  0.0000167,  0.0000234,  0.0000327, &
+        0.0000454,  0.0000627,  0.0000859,  0.0001166,  0.0001566, &
+        0.0002078,  0.0002724,  0.0003531,  0.0004529,  0.0005755, &
+        0.0007253,  0.0009079,  0.0011304,  0.0014010,  0.0017287, &
+        0.0021232,  0.0025935,  0.0031480,  0.0037936,  0.0045361, &
+        0.0053805,  0.0063314,  0.0073941/
+      data ((cah(i,j),i=1,43),j= 31, 31)/ &
+        0.0000000,  0.0000001,  0.0000001,  0.0000001,  0.0000002, &
+        0.0000003,  0.0000004,  0.0000005,  0.0000007,  0.0000010, &
+        0.0000015,  0.0000021,  0.0000029,  0.0000041,  0.0000058, &
+        0.0000082,  0.0000115,  0.0000162,  0.0000226,  0.0000316, &
+        0.0000438,  0.0000605,  0.0000829,  0.0001125,  0.0001510, &
+        0.0002004,  0.0002626,  0.0003402,  0.0004362,  0.0005540, &
+        0.0006980,  0.0008736,  0.0010874,  0.0013476,  0.0016627, &
+        0.0020421,  0.0024947,  0.0030283,  0.0036497,  0.0043644, &
+        0.0051772,  0.0060928,  0.0071164/
+      data ((cah(i,j),i=1,43),j= 32, 32)/ &
+        0.0000000,  0.0000001,  0.0000001,  0.0000001,  0.0000002, &
+        0.0000003,  0.0000004,  0.0000005,  0.0000007,  0.0000010, &
+        0.0000014,  0.0000020,  0.0000028,  0.0000040,  0.0000056, &
+        0.0000079,  0.0000111,  0.0000155,  0.0000218,  0.0000303, &
+        0.0000421,  0.0000582,  0.0000797,  0.0001081,  0.0001450, &
+        0.0001923,  0.0002519,  0.0003262,  0.0004180,  0.0005308, &
+        0.0006686,  0.0008367,  0.0010414,  0.0012905,  0.0015925, &
+        0.0019561,  0.0023900,  0.0029017,  0.0034978,  0.0041836, &
+        0.0049638,  0.0058430,  0.0068264/
+      data ((cah(i,j),i=1,43),j= 33, 33)/ &
+        0.0000000,  0.0000001,  0.0000001,  0.0000001,  0.0000002, &
+        0.0000002,  0.0000003,  0.0000005,  0.0000007,  0.0000010, &
+        0.0000014,  0.0000019,  0.0000027,  0.0000038,  0.0000053, &
+        0.0000075,  0.0000106,  0.0000149,  0.0000208,  0.0000290, &
+        0.0000403,  0.0000556,  0.0000761,  0.0001032,  0.0001384, &
+        0.0001834,  0.0002402,  0.0003110,  0.0003985,  0.0005059, &
+        0.0006372,  0.0007974,  0.0009926,  0.0012302,  0.0015185, &
+        0.0018657,  0.0022803,  0.0027696,  0.0033398,  0.0039960, &
+        0.0047430,  0.0055851,  0.0065278/
+      data ((cah(i,j),i=1,43),j= 34, 34)/ &
+        0.0000000,  0.0000001,  0.0000001,  0.0000001,  0.0000002, &
+        0.0000002,  0.0000003,  0.0000005,  0.0000006,  0.0000009, &
+        0.0000013,  0.0000018,  0.0000026,  0.0000036,  0.0000051, &
+        0.0000071,  0.0000100,  0.0000141,  0.0000197,  0.0000275, &
+        0.0000382,  0.0000527,  0.0000722,  0.0000979,  0.0001312, &
+        0.0001739,  0.0002277,  0.0002947,  0.0003775,  0.0004793, &
+        0.0006038,  0.0007558,  0.0009412,  0.0011671,  0.0014412, &
+        0.0017717,  0.0021208,  0.0026329,  0.0031768,  0.0038033, &
+        0.0045168,  0.0053220,  0.0062240/
+      data ((cah(i,j),i=1,43),j= 35, 35)/ &
+        0.0000000,  0.0000001,  0.0000001,  0.0000001,  0.0000002, &
+        0.0000002,  0.0000003,  0.0000004,  0.0000006,  0.0000009, &
+        0.0000012,  0.0000017,  0.0000024,  0.0000034,  0.0000048, &
+        0.0000067,  0.0000095,  0.0000133,  0.0000186,  0.0000259, &
+        0.0000360,  0.0000496,  0.0000679,  0.0000921,  0.0001235, &
+        0.0001637,  0.0002143,  0.0002773,  0.0003554,  0.0004513, &
+        0.0005688,  0.0007124,  0.0008876,  0.0011014,  0.0013610, &
+        0.0016745,  0.0020493,  0.0024925,  0.0030099,  0.0036066, &
+        0.0042868,  0.0050553,  0.0059171/
+      data ((cah(i,j),i=1,43),j= 36, 36)/ &
+        0.0000000,  0.0000001,  0.0000001,  0.0000001,  0.0000001, &
+        0.0000002,  0.0000003,  0.0000004,  0.0000006,  0.0000008, &
+        0.0000011,  0.0000016,  0.0000022,  0.0000032,  0.0000045, &
+        0.0000063,  0.0000088,  0.0000124,  0.0000173,  0.0000242, &
+        0.0000336,  0.0000463,  0.0000634,  0.0000860,  0.0001153, &
+        0.0001528,  0.0002001,  0.0002591,  0.0003322,  0.0004221, &
+        0.0005323,  0.0006672,  0.0008322,  0.0010335,  0.0012785, &
+        0.0015746,  0.0019293,  0.0023491,  0.0028399,  0.0034067, &
+        0.0040539,  0.0047860,  0.0056083/
+      data ((cah(i,j),i=1,43),j= 37, 37)/ &
+        0.0000000,  0.0000000,  0.0000001,  0.0000001,  0.0000001, &
+        0.0000002,  0.0000003,  0.0000004,  0.0000005,  0.0000007, &
+        0.0000010,  0.0000015,  0.0000021,  0.0000029,  0.0000041, &
+        0.0000058,  0.0000082,  0.0000114,  0.0000160,  0.0000223, &
+        0.0000310,  0.0000428,  0.0000586,  0.0000795,  0.0001067, &
+        0.0001414,  0.0001853,  0.0002401,  0.0003081,  0.0003918, &
+        0.0004947,  0.0006208,  0.0007751,  0.0009639,  0.0011940, &
+        0.0014726,  0.0018069,  0.0022032,  0.0026674,  0.0032043, &
+        0.0038186,  0.0045147,  0.0052979/
+!-----coa is the co2 absorptance in strong absorption regions of band 11
+      data ((coa(i,j),i=1,62),j=  1,  1)/ &
+        0.0000080,  0.0000089,  0.0000098,  0.0000106,  0.0000114, &
+        0.0000121,  0.0000128,  0.0000134,  0.0000140,  0.0000146, &
+        0.0000152,  0.0000158,  0.0000163,  0.0000168,  0.0000173, &
+        0.0000178,  0.0000182,  0.0000186,  0.0000191,  0.0000195, &
+        0.0000199,  0.0000202,  0.0000206,  0.0000210,  0.0000213, &
+        0.0000217,  0.0000220,  0.0000223,  0.0000226,  0.0000229, &
+        0.0000232,  0.0000235,  0.0000238,  0.0000241,  0.0000244, &
+        0.0000246,  0.0000249,  0.0000252,  0.0000254,  0.0000257, &
+        0.0000259,  0.0000261,  0.0000264,  0.0000266,  0.0000268, &
+        0.0000271,  0.0000273,  0.0000275,  0.0000277,  0.0000279, &
+        0.0000281,  0.0000283,  0.0000285,  0.0000287,  0.0000289, &
+        0.0000291,  0.0000293,  0.0000295,  0.0000297,  0.0000298, &
+        0.0000300,  0.0000302/
+      data ((coa(i,j),i=1,62),j=  2,  2)/ &
+        0.0000085,  0.0000095,  0.0000104,  0.0000113,  0.0000121, &
+        0.0000128,  0.0000136,  0.0000143,  0.0000149,  0.0000155, &
+        0.0000161,  0.0000167,  0.0000172,  0.0000178,  0.0000183, &
+        0.0000187,  0.0000192,  0.0000196,  0.0000201,  0.0000205, &
+        0.0000209,  0.0000213,  0.0000217,  0.0000220,  0.0000224, &
+        0.0000227,  0.0000231,  0.0000234,  0.0000237,  0.0000240, &
+        0.0000243,  0.0000246,  0.0000249,  0.0000252,  0.0000255, &
+        0.0000258,  0.0000260,  0.0000263,  0.0000266,  0.0000268, &
+        0.0000271,  0.0000273,  0.0000275,  0.0000278,  0.0000280, &
+        0.0000282,  0.0000285,  0.0000287,  0.0000289,  0.0000291, &
+        0.0000293,  0.0000295,  0.0000297,  0.0000299,  0.0000301, &
+        0.0000303,  0.0000305,  0.0000307,  0.0000309,  0.0000311, &
+        0.0000313,  0.0000314/
+      data ((coa(i,j),i=1,62),j=  3,  3)/ &
+        0.0000095,  0.0000106,  0.0000116,  0.0000125,  0.0000134, &
+        0.0000143,  0.0000150,  0.0000158,  0.0000165,  0.0000171, &
+        0.0000178,  0.0000184,  0.0000189,  0.0000195,  0.0000200, &
+        0.0000205,  0.0000210,  0.0000215,  0.0000219,  0.0000223, &
+        0.0000228,  0.0000232,  0.0000235,  0.0000239,  0.0000243, &
+        0.0000247,  0.0000250,  0.0000253,  0.0000257,  0.0000260, &
+        0.0000263,  0.0000266,  0.0000269,  0.0000272,  0.0000275, &
+        0.0000278,  0.0000281,  0.0000283,  0.0000286,  0.0000289, &
+        0.0000291,  0.0000294,  0.0000296,  0.0000299,  0.0000301, &
+        0.0000303,  0.0000306,  0.0000308,  0.0000310,  0.0000312, &
+        0.0000315,  0.0000317,  0.0000319,  0.0000321,  0.0000323, &
+        0.0000325,  0.0000327,  0.0000329,  0.0000331,  0.0000333, &
+        0.0000335,  0.0000329/
+      data ((coa(i,j),i=1,62),j=  4,  4)/ &
+        0.0000100,  0.0000111,  0.0000122,  0.0000131,  0.0000141, &
+        0.0000149,  0.0000157,  0.0000165,  0.0000172,  0.0000179, &
+        0.0000185,  0.0000191,  0.0000197,  0.0000203,  0.0000208, &
+        0.0000213,  0.0000218,  0.0000223,  0.0000227,  0.0000232, &
+        0.0000236,  0.0000240,  0.0000244,  0.0000248,  0.0000252, &
+        0.0000255,  0.0000259,  0.0000262,  0.0000266,  0.0000269, &
+        0.0000272,  0.0000275,  0.0000278,  0.0000281,  0.0000284, &
+        0.0000287,  0.0000290,  0.0000293,  0.0000295,  0.0000298, &
+        0.0000300,  0.0000303,  0.0000306,  0.0000308,  0.0000310, &
+        0.0000313,  0.0000315,  0.0000317,  0.0000320,  0.0000322, &
+        0.0000324,  0.0000326,  0.0000328,  0.0000331,  0.0000333, &
+        0.0000335,  0.0000330,  0.0000339,  0.0000341,  0.0000343, &
+        0.0000345,  0.0000346/
+      data ((coa(i,j),i=1,62),j=  5,  5)/ &
+        0.0000109,  0.0000121,  0.0000132,  0.0000143,  0.0000152, &
+        0.0000161,  0.0000170,  0.0000178,  0.0000185,  0.0000192, &
+        0.0000199,  0.0000205,  0.0000211,  0.0000217,  0.0000222, &
+        0.0000228,  0.0000233,  0.0000238,  0.0000242,  0.0000247, &
+        0.0000251,  0.0000255,  0.0000259,  0.0000263,  0.0000267, &
+        0.0000271,  0.0000275,  0.0000278,  0.0000282,  0.0000285, &
+        0.0000288,  0.0000291,  0.0000295,  0.0000298,  0.0000301, &
+        0.0000304,  0.0000307,  0.0000309,  0.0000312,  0.0000315, &
+        0.0000318,  0.0000320,  0.0000323,  0.0000325,  0.0000328, &
+        0.0000330,  0.0000333,  0.0000335,  0.0000330,  0.0000340, &
+        0.0000342,  0.0000344,  0.0000346,  0.0000348,  0.0000351, &
+        0.0000353,  0.0000355,  0.0000357,  0.0000359,  0.0000361, &
+        0.0000363,  0.0000365/
+      data ((coa(i,j),i=1,62),j=  6,  6)/ &
+        0.0000117,  0.0000130,  0.0000142,  0.0000153,  0.0000163, &
+        0.0000173,  0.0000181,  0.0000190,  0.0000197,  0.0000204, &
+        0.0000211,  0.0000218,  0.0000224,  0.0000230,  0.0000235, &
+        0.0000241,  0.0000246,  0.0000251,  0.0000256,  0.0000260, &
+        0.0000265,  0.0000269,  0.0000273,  0.0000277,  0.0000281, &
+        0.0000285,  0.0000289,  0.0000293,  0.0000296,  0.0000299, &
+        0.0000303,  0.0000306,  0.0000309,  0.0000313,  0.0000316, &
+        0.0000319,  0.0000322,  0.0000324,  0.0000327,  0.0000330, &
+        0.0000333,  0.0000336,  0.0000331,  0.0000341,  0.0000343, &
+        0.0000346,  0.0000348,  0.0000351,  0.0000353,  0.0000355, &
+        0.0000358,  0.0000360,  0.0000362,  0.0000365,  0.0000367, &
+        0.0000369,  0.0000371,  0.0000373,  0.0000375,  0.0000377, &
+        0.0000379,  0.0000381/
+      data ((coa(i,j),i=1,62),j=  7,  7)/ &
+        0.0000125,  0.0000139,  0.0000151,  0.0000163,  0.0000173, &
+        0.0000183,  0.0000192,  0.0000200,  0.0000208,  0.0000216, &
+        0.0000223,  0.0000229,  0.0000236,  0.0000242,  0.0000247, &
+        0.0000253,  0.0000258,  0.0000263,  0.0000268,  0.0000273, &
+        0.0000277,  0.0000282,  0.0000286,  0.0000290,  0.0000294, &
+        0.0000298,  0.0000302,  0.0000306,  0.0000309,  0.0000313, &
+        0.0000316,  0.0000320,  0.0000323,  0.0000326,  0.0000329, &
+        0.0000332,  0.0000335,  0.0000331,  0.0000341,  0.0000344, &
+        0.0000347,  0.0000350,  0.0000352,  0.0000355,  0.0000358, &
+        0.0000360,  0.0000363,  0.0000365,  0.0000368,  0.0000370, &
+        0.0000372,  0.0000375,  0.0000377,  0.0000379,  0.0000382, &
+        0.0000384,  0.0000386,  0.0000388,  0.0000390,  0.0000392, &
+        0.0000394,  0.0000396/
+      data ((coa(i,j),i=1,62),j=  8,  8)/ &
+        0.0000132,  0.0000147,  0.0000160,  0.0000172,  0.0000183, &
+        0.0000193,  0.0000202,  0.0000210,  0.0000218,  0.0000226, &
+        0.0000233,  0.0000240,  0.0000246,  0.0000252,  0.0000258, &
+        0.0000264,  0.0000269,  0.0000274,  0.0000279,  0.0000284, &
+        0.0000289,  0.0000293,  0.0000298,  0.0000302,  0.0000306, &
+        0.0000310,  0.0000314,  0.0000318,  0.0000321,  0.0000325, &
+        0.0000328,  0.0000332,  0.0000335,  0.0000331,  0.0000342, &
+        0.0000345,  0.0000348,  0.0000351,  0.0000354,  0.0000357, &
+        0.0000360,  0.0000363,  0.0000365,  0.0000368,  0.0000371, &
+        0.0000373,  0.0000376,  0.0000378,  0.0000381,  0.0000383, &
+        0.0000386,  0.0000388,  0.0000391,  0.0000393,  0.0000395, &
+        0.0000397,  0.0000400,  0.0000402,  0.0000404,  0.0000406, &
+        0.0000408,  0.0000411/
+      data ((coa(i,j),i=1,62),j=  9,  9)/ &
+        0.0000143,  0.0000158,  0.0000172,  0.0000184,  0.0000195, &
+        0.0000206,  0.0000215,  0.0000224,  0.0000232,  0.0000240, &
+        0.0000247,  0.0000254,  0.0000261,  0.0000267,  0.0000273, &
+        0.0000279,  0.0000284,  0.0000290,  0.0000295,  0.0000300, &
+        0.0000305,  0.0000309,  0.0000314,  0.0000318,  0.0000322, &
+        0.0000326,  0.0000330,  0.0000334,  0.0000331,  0.0000342, &
+        0.0000345,  0.0000349,  0.0000352,  0.0000356,  0.0000359, &
+        0.0000362,  0.0000365,  0.0000368,  0.0000371,  0.0000374, &
+        0.0000377,  0.0000380,  0.0000383,  0.0000386,  0.0000389, &
+        0.0000391,  0.0000394,  0.0000397,  0.0000399,  0.0000402, &
+        0.0000404,  0.0000407,  0.0000409,  0.0000412,  0.0000414, &
+        0.0000416,  0.0000419,  0.0000421,  0.0000423,  0.0000426, &
+        0.0000428,  0.0000430/
+      data ((coa(i,j),i=1,62),j= 10, 10)/ &
+        0.0000153,  0.0000169,  0.0000183,  0.0000196,  0.0000207, &
+        0.0000218,  0.0000227,  0.0000236,  0.0000245,  0.0000253, &
+        0.0000260,  0.0000267,  0.0000274,  0.0000281,  0.0000287, &
+        0.0000293,  0.0000298,  0.0000304,  0.0000309,  0.0000314, &
+        0.0000319,  0.0000324,  0.0000328,  0.0000333,  0.0000330, &
+        0.0000341,  0.0000345,  0.0000349,  0.0000353,  0.0000357, &
+        0.0000361,  0.0000364,  0.0000368,  0.0000371,  0.0000375, &
+        0.0000378,  0.0000381,  0.0000384,  0.0000387,  0.0000391, &
+        0.0000394,  0.0000397,  0.0000399,  0.0000402,  0.0000405, &
+        0.0000408,  0.0000411,  0.0000413,  0.0000416,  0.0000419, &
+        0.0000421,  0.0000424,  0.0000426,  0.0000429,  0.0000431, &
+        0.0000434,  0.0000436,  0.0000439,  0.0000441,  0.0000443, &
+        0.0000446,  0.0000448/
+      data ((coa(i,j),i=1,62),j= 11, 11)/ &
+        0.0000165,  0.0000182,  0.0000196,  0.0000209,  0.0000221, &
+        0.0000232,  0.0000242,  0.0000251,  0.0000260,  0.0000268, &
+        0.0000276,  0.0000283,  0.0000290,  0.0000297,  0.0000303, &
+        0.0000309,  0.0000315,  0.0000321,  0.0000326,  0.0000331, &
+        0.0000336,  0.0000341,  0.0000346,  0.0000350,  0.0000355, &
+        0.0000359,  0.0000363,  0.0000367,  0.0000371,  0.0000375, &
+        0.0000379,  0.0000383,  0.0000386,  0.0000390,  0.0000394, &
+        0.0000397,  0.0000400,  0.0000404,  0.0000407,  0.0000410, &
+        0.0000413,  0.0000416,  0.0000419,  0.0000422,  0.0000425, &
+        0.0000428,  0.0000431,  0.0000434,  0.0000437,  0.0000439, &
+        0.0000442,  0.0000445,  0.0000447,  0.0000450,  0.0000453, &
+        0.0000455,  0.0000458,  0.0000460,  0.0000463,  0.0000465, &
+        0.0000468,  0.0000470/
+      data ((coa(i,j),i=1,62),j= 12, 12)/ &
+        0.0000173,  0.0000190,  0.0000205,  0.0000219,  0.0000231, &
+        0.0000242,  0.0000252,  0.0000262,  0.0000271,  0.0000279, &
+        0.0000287,  0.0000294,  0.0000301,  0.0000308,  0.0000314, &
+        0.0000320,  0.0000326,  0.0000332,  0.0000330,  0.0000343, &
+        0.0000348,  0.0000353,  0.0000358,  0.0000362,  0.0000367, &
+        0.0000371,  0.0000376,  0.0000380,  0.0000384,  0.0000388, &
+        0.0000392,  0.0000396,  0.0000399,  0.0000403,  0.0000407, &
+        0.0000410,  0.0000414,  0.0000417,  0.0000420,  0.0000424, &
+        0.0000427,  0.0000430,  0.0000433,  0.0000436,  0.0000439, &
+        0.0000442,  0.0000445,  0.0000448,  0.0000451,  0.0000454, &
+        0.0000457,  0.0000459,  0.0000462,  0.0000465,  0.0000468, &
+        0.0000470,  0.0000473,  0.0000475,  0.0000478,  0.0000481, &
+        0.0000483,  0.0000486/
+      data ((coa(i,j),i=1,62),j= 13, 13)/ &
+        0.0000186,  0.0000204,  0.0000219,  0.0000233,  0.0000246, &
+        0.0000257,  0.0000268,  0.0000277,  0.0000286,  0.0000295, &
+        0.0000303,  0.0000311,  0.0000318,  0.0000325,  0.0000331, &
+        0.0000331,  0.0000344,  0.0000350,  0.0000355,  0.0000361, &
+        0.0000366,  0.0000371,  0.0000376,  0.0000381,  0.0000386, &
+        0.0000390,  0.0000395,  0.0000399,  0.0000403,  0.0000407, &
+        0.0000412,  0.0000416,  0.0000419,  0.0000423,  0.0000427, &
+        0.0000431,  0.0000434,  0.0000438,  0.0000441,  0.0000445, &
+        0.0000448,  0.0000451,  0.0000455,  0.0000458,  0.0000461, &
+        0.0000464,  0.0000467,  0.0000470,  0.0000473,  0.0000476, &
+        0.0000479,  0.0000482,  0.0000485,  0.0000488,  0.0000491, &
+        0.0000494,  0.0000497,  0.0000499,  0.0000502,  0.0000505, &
+        0.0000507,  0.0000510/
+      data ((coa(i,j),i=1,62),j= 14, 14)/ &
+        0.0000198,  0.0000216,  0.0000232,  0.0000246,  0.0000259, &
+        0.0000271,  0.0000281,  0.0000291,  0.0000301,  0.0000310, &
+        0.0000318,  0.0000326,  0.0000333,  0.0000340,  0.0000347, &
+        0.0000354,  0.0000360,  0.0000366,  0.0000372,  0.0000377, &
+        0.0000383,  0.0000388,  0.0000393,  0.0000398,  0.0000403, &
+        0.0000408,  0.0000412,  0.0000417,  0.0000421,  0.0000425, &
+        0.0000430,  0.0000434,  0.0000438,  0.0000442,  0.0000446, &
+        0.0000449,  0.0000453,  0.0000457,  0.0000461,  0.0000464, &
+        0.0000468,  0.0000471,  0.0000475,  0.0000478,  0.0000481, &
+        0.0000485,  0.0000488,  0.0000491,  0.0000494,  0.0000498, &
+        0.0000501,  0.0000504,  0.0000507,  0.0000510,  0.0000513, &
+        0.0000516,  0.0000519,  0.0000522,  0.0000524,  0.0000527, &
+        0.0000530,  0.0000533/
+      data ((coa(i,j),i=1,62),j= 15, 15)/ &
+        0.0000209,  0.0000228,  0.0000244,  0.0000258,  0.0000271, &
+        0.0000283,  0.0000294,  0.0000305,  0.0000314,  0.0000323, &
+        0.0000332,  0.0000340,  0.0000347,  0.0000354,  0.0000361, &
+        0.0000368,  0.0000375,  0.0000381,  0.0000387,  0.0000392, &
+        0.0000398,  0.0000404,  0.0000409,  0.0000414,  0.0000419, &
+        0.0000424,  0.0000429,  0.0000433,  0.0000438,  0.0000442, &
+        0.0000447,  0.0000451,  0.0000455,  0.0000459,  0.0000463, &
+        0.0000467,  0.0000471,  0.0000475,  0.0000479,  0.0000483, &
+        0.0000486,  0.0000490,  0.0000493,  0.0000497,  0.0000501, &
+        0.0000504,  0.0000507,  0.0000511,  0.0000514,  0.0000518, &
+        0.0000521,  0.0000524,  0.0000527,  0.0000530,  0.0000534, &
+        0.0000537,  0.0000540,  0.0000543,  0.0000546,  0.0000549, &
+        0.0000552,  0.0000555/
+      data ((coa(i,j),i=1,62),j= 16, 16)/ &
+        0.0000221,  0.0000240,  0.0000257,  0.0000272,  0.0000285, &
+        0.0000297,  0.0000308,  0.0000319,  0.0000329,  0.0000331, &
+        0.0000347,  0.0000355,  0.0000363,  0.0000370,  0.0000377, &
+        0.0000384,  0.0000391,  0.0000397,  0.0000404,  0.0000409, &
+        0.0000415,  0.0000421,  0.0000426,  0.0000432,  0.0000437, &
+        0.0000442,  0.0000447,  0.0000452,  0.0000456,  0.0000461, &
+        0.0000466,  0.0000470,  0.0000475,  0.0000479,  0.0000483, &
+        0.0000487,  0.0000491,  0.0000496,  0.0000500,  0.0000503, &
+        0.0000507,  0.0000511,  0.0000515,  0.0000519,  0.0000523, &
+        0.0000526,  0.0000530,  0.0000533,  0.0000537,  0.0000540, &
+        0.0000544,  0.0000547,  0.0000551,  0.0000554,  0.0000558, &
+        0.0000561,  0.0000564,  0.0000567,  0.0000571,  0.0000574, &
+        0.0000577,  0.0000580/
+      data ((coa(i,j),i=1,62),j= 17, 17)/ &
+        0.0000234,  0.0000254,  0.0000271,  0.0000286,  0.0000300, &
+        0.0000312,  0.0000324,  0.0000335,  0.0000345,  0.0000354, &
+        0.0000363,  0.0000372,  0.0000380,  0.0000387,  0.0000395, &
+        0.0000402,  0.0000409,  0.0000415,  0.0000422,  0.0000428, &
+        0.0000434,  0.0000440,  0.0000446,  0.0000451,  0.0000457, &
+        0.0000462,  0.0000467,  0.0000472,  0.0000477,  0.0000482, &
+        0.0000487,  0.0000492,  0.0000496,  0.0000501,  0.0000505, &
+        0.0000510,  0.0000514,  0.0000518,  0.0000523,  0.0000527, &
+        0.0000531,  0.0000535,  0.0000539,  0.0000543,  0.0000547, &
+        0.0000551,  0.0000555,  0.0000559,  0.0000562,  0.0000566, &
+        0.0000570,  0.0000573,  0.0000577,  0.0000581,  0.0000584, &
+        0.0000588,  0.0000591,  0.0000595,  0.0000598,  0.0000602, &
+        0.0000605,  0.0000608/
+      data ((coa(i,j),i=1,62),j= 18, 18)/ &
+        0.0000248,  0.0000268,  0.0000285,  0.0000301,  0.0000315, &
+        0.0000328,  0.0000340,  0.0000351,  0.0000362,  0.0000371, &
+        0.0000381,  0.0000389,  0.0000398,  0.0000406,  0.0000413, &
+        0.0000421,  0.0000428,  0.0000435,  0.0000442,  0.0000448, &
+        0.0000454,  0.0000460,  0.0000466,  0.0000472,  0.0000478, &
+        0.0000484,  0.0000489,  0.0000494,  0.0000500,  0.0000505, &
+        0.0000510,  0.0000515,  0.0000520,  0.0000525,  0.0000530, &
+        0.0000534,  0.0000539,  0.0000544,  0.0000548,  0.0000553, &
+        0.0000557,  0.0000561,  0.0000566,  0.0000570,  0.0000574, &
+        0.0000578,  0.0000582,  0.0000586,  0.0000590,  0.0000594, &
+        0.0000598,  0.0000602,  0.0000606,  0.0000610,  0.0000614, &
+        0.0000618,  0.0000621,  0.0000625,  0.0000629,  0.0000633, &
+        0.0000636,  0.0000640/
+      data ((coa(i,j),i=1,62),j= 19, 19)/ &
+        0.0000260,  0.0000281,  0.0000299,  0.0000315,  0.0000330, &
+        0.0000343,  0.0000355,  0.0000367,  0.0000377,  0.0000388, &
+        0.0000397,  0.0000406,  0.0000415,  0.0000423,  0.0000431, &
+        0.0000439,  0.0000446,  0.0000453,  0.0000460,  0.0000467, &
+        0.0000474,  0.0000480,  0.0000487,  0.0000493,  0.0000499, &
+        0.0000505,  0.0000510,  0.0000516,  0.0000522,  0.0000527, &
+        0.0000533,  0.0000538,  0.0000543,  0.0000548,  0.0000553, &
+        0.0000558,  0.0000563,  0.0000568,  0.0000573,  0.0000578, &
+        0.0000582,  0.0000587,  0.0000591,  0.0000596,  0.0000601, &
+        0.0000605,  0.0000609,  0.0000614,  0.0000618,  0.0000622, &
+        0.0000626,  0.0000631,  0.0000635,  0.0000639,  0.0000643, &
+        0.0000647,  0.0000651,  0.0000655,  0.0000659,  0.0000663, &
+        0.0000667,  0.0000670/
+      data ((coa(i,j),i=1,62),j= 20, 20)/ &
+        0.0000275,  0.0000296,  0.0000315,  0.0000332,  0.0000347, &
+        0.0000360,  0.0000373,  0.0000385,  0.0000396,  0.0000407, &
+        0.0000417,  0.0000426,  0.0000435,  0.0000444,  0.0000452, &
+        0.0000460,  0.0000468,  0.0000476,  0.0000483,  0.0000490, &
+        0.0000497,  0.0000504,  0.0000511,  0.0000517,  0.0000524, &
+        0.0000530,  0.0000536,  0.0000542,  0.0000548,  0.0000554, &
+        0.0000560,  0.0000566,  0.0000571,  0.0000577,  0.0000582, &
+        0.0000587,  0.0000593,  0.0000598,  0.0000603,  0.0000608, &
+        0.0000613,  0.0000618,  0.0000623,  0.0000628,  0.0000633, &
+        0.0000638,  0.0000642,  0.0000647,  0.0000652,  0.0000656, &
+        0.0000661,  0.0000665,  0.0000670,  0.0000674,  0.0000678, &
+        0.0000683,  0.0000687,  0.0000691,  0.0000695,  0.0000700, &
+        0.0000704,  0.0000708/
+      data ((coa(i,j),i=1,62),j= 21, 21)/ &
+        0.0000290,  0.0000312,  0.0000331,  0.0000349,  0.0000364, &
+        0.0000379,  0.0000392,  0.0000404,  0.0000416,  0.0000427, &
+        0.0000437,  0.0000447,  0.0000457,  0.0000466,  0.0000475, &
+        0.0000483,  0.0000492,  0.0000500,  0.0000507,  0.0000515, &
+        0.0000523,  0.0000530,  0.0000537,  0.0000544,  0.0000551, &
+        0.0000558,  0.0000564,  0.0000571,  0.0000577,  0.0000583, &
+        0.0000589,  0.0000596,  0.0000602,  0.0000607,  0.0000613, &
+        0.0000619,  0.0000625,  0.0000630,  0.0000636,  0.0000641, &
+        0.0000647,  0.0000652,  0.0000657,  0.0000663,  0.0000668, &
+        0.0000673,  0.0000678,  0.0000683,  0.0000688,  0.0000693, &
+        0.0000698,  0.0000702,  0.0000707,  0.0000712,  0.0000716, &
+        0.0000721,  0.0000726,  0.0000730,  0.0000735,  0.0000739, &
+        0.0000744,  0.0000748/
+      data ((coa(i,j),i=1,62),j= 22, 22)/ &
+        0.0000306,  0.0000329,  0.0000349,  0.0000366,  0.0000383, &
+        0.0000398,  0.0000411,  0.0000424,  0.0000436,  0.0000448, &
+        0.0000459,  0.0000469,  0.0000479,  0.0000489,  0.0000499, &
+        0.0000508,  0.0000516,  0.0000525,  0.0000533,  0.0000542, &
+        0.0000549,  0.0000557,  0.0000565,  0.0000572,  0.0000580, &
+        0.0000587,  0.0000594,  0.0000601,  0.0000608,  0.0000615, &
+        0.0000621,  0.0000628,  0.0000634,  0.0000640,  0.0000647, &
+        0.0000653,  0.0000659,  0.0000665,  0.0000671,  0.0000677, &
+        0.0000683,  0.0000688,  0.0000694,  0.0000700,  0.0000705, &
+        0.0000711,  0.0000716,  0.0000721,  0.0000727,  0.0000732, &
+        0.0000737,  0.0000742,  0.0000747,  0.0000752,  0.0000757, &
+        0.0000762,  0.0000767,  0.0000772,  0.0000777,  0.0000782, &
+        0.0000786,  0.0000791/
+      data ((coa(i,j),i=1,62),j= 23, 23)/ &
+        0.0000323,  0.0000347,  0.0000368,  0.0000386,  0.0000403, &
+        0.0000419,  0.0000433,  0.0000447,  0.0000459,  0.0000472, &
+        0.0000483,  0.0000494,  0.0000505,  0.0000516,  0.0000526, &
+        0.0000535,  0.0000545,  0.0000554,  0.0000563,  0.0000572, &
+        0.0000580,  0.0000589,  0.0000597,  0.0000605,  0.0000613, &
+        0.0000621,  0.0000628,  0.0000636,  0.0000643,  0.0000650, &
+        0.0000657,  0.0000664,  0.0000671,  0.0000678,  0.0000685, &
+        0.0000692,  0.0000698,  0.0000705,  0.0000711,  0.0000717, &
+        0.0000724,  0.0000730,  0.0000736,  0.0000742,  0.0000748, &
+        0.0000754,  0.0000760,  0.0000765,  0.0000771,  0.0000777, &
+        0.0000782,  0.0000788,  0.0000793,  0.0000799,  0.0000804, &
+        0.0000809,  0.0000815,  0.0000820,  0.0000825,  0.0000830, &
+        0.0000835,  0.0000840/
+      data ((coa(i,j),i=1,62),j= 24, 24)/ &
+        0.0000341,  0.0000365,  0.0000387,  0.0000406,  0.0000424, &
+        0.0000440,  0.0000456,  0.0000470,  0.0000483,  0.0000496, &
+        0.0000509,  0.0000521,  0.0000532,  0.0000543,  0.0000554, &
+        0.0000564,  0.0000574,  0.0000584,  0.0000594,  0.0000603, &
+        0.0000613,  0.0000622,  0.0000630,  0.0000639,  0.0000648, &
+        0.0000656,  0.0000664,  0.0000672,  0.0000680,  0.0000688, &
+        0.0000696,  0.0000703,  0.0000711,  0.0000718,  0.0000725, &
+        0.0000732,  0.0000739,  0.0000746,  0.0000753,  0.0000760, &
+        0.0000767,  0.0000773,  0.0000780,  0.0000786,  0.0000793, &
+        0.0000799,  0.0000805,  0.0000811,  0.0000817,  0.0000823, &
+        0.0000829,  0.0000835,  0.0000841,  0.0000847,  0.0000853, &
+        0.0000858,  0.0000864,  0.0000870,  0.0000875,  0.0000881, &
+        0.0000886,  0.0000892/
+      data ((coa(i,j),i=1,62),j= 25, 25)/ &
+        0.0000359,  0.0000385,  0.0000408,  0.0000428,  0.0000447, &
+        0.0000464,  0.0000480,  0.0000495,  0.0000510,  0.0000524, &
+        0.0000537,  0.0000550,  0.0000562,  0.0000574,  0.0000585, &
+        0.0000597,  0.0000608,  0.0000618,  0.0000629,  0.0000639, &
+        0.0000649,  0.0000658,  0.0000668,  0.0000677,  0.0000686, &
+        0.0000695,  0.0000704,  0.0000713,  0.0000721,  0.0000730, &
+        0.0000738,  0.0000746,  0.0000754,  0.0000762,  0.0000770, &
+        0.0000777,  0.0000785,  0.0000792,  0.0000800,  0.0000807, &
+        0.0000814,  0.0000821,  0.0000828,  0.0000835,  0.0000842, &
+        0.0000849,  0.0000856,  0.0000862,  0.0000869,  0.0000875, &
+        0.0000882,  0.0000888,  0.0000894,  0.0000900,  0.0000907, &
+        0.0000913,  0.0000919,  0.0000925,  0.0000931,  0.0000936, &
+        0.0000942,  0.0000948/
+      data ((coa(i,j),i=1,62),j= 26, 26)/ &
+        0.0000380,  0.0000407,  0.0000431,  0.0000453,  0.0000473, &
+        0.0000491,  0.0000508,  0.0000525,  0.0000540,  0.0000555, &
+        0.0000569,  0.0000583,  0.0000596,  0.0000609,  0.0000622, &
+        0.0000634,  0.0000646,  0.0000657,  0.0000668,  0.0000679, &
+        0.0000690,  0.0000700,  0.0000711,  0.0000721,  0.0000731, &
+        0.0000740,  0.0000750,  0.0000759,  0.0000769,  0.0000778, &
+        0.0000786,  0.0000795,  0.0000804,  0.0000812,  0.0000821, &
+        0.0000829,  0.0000837,  0.0000845,  0.0000853,  0.0000861, &
+        0.0000869,  0.0000876,  0.0000884,  0.0000891,  0.0000899, &
+        0.0000906,  0.0000913,  0.0000920,  0.0000927,  0.0000934, &
+        0.0000941,  0.0000948,  0.0000955,  0.0000961,  0.0000968, &
+        0.0000974,  0.0000981,  0.0000987,  0.0000994,  0.0001000, &
+        0.0001006,  0.0001012/
+      data ((coa(i,j),i=1,62),j= 27, 27)/ &
+        0.0000403,  0.0000431,  0.0000456,  0.0000479,  0.0000500, &
+        0.0000520,  0.0000538,  0.0000556,  0.0000573,  0.0000589, &
+        0.0000604,  0.0000619,  0.0000633,  0.0000647,  0.0000661, &
+        0.0000674,  0.0000686,  0.0000699,  0.0000711,  0.0000723, &
+        0.0000734,  0.0000746,  0.0000757,  0.0000768,  0.0000778, &
+        0.0000789,  0.0000799,  0.0000809,  0.0000819,  0.0000829, &
+        0.0000838,  0.0000848,  0.0000857,  0.0000866,  0.0000875, &
+        0.0000884,  0.0000893,  0.0000902,  0.0000910,  0.0000919, &
+        0.0000927,  0.0000935,  0.0000943,  0.0000951,  0.0000959, &
+        0.0000967,  0.0000974,  0.0000982,  0.0000990,  0.0000997, &
+        0.0001004,  0.0001012,  0.0001019,  0.0001026,  0.0001033, &
+        0.0001040,  0.0001047,  0.0001054,  0.0001061,  0.0001067, &
+        0.0001074,  0.0001080/
+      data ((coa(i,j),i=1,62),j= 28, 28)/ &
+        0.0000426,  0.0000456,  0.0000482,  0.0000507,  0.0000529, &
+        0.0000550,  0.0000570,  0.0000589,  0.0000607,  0.0000624, &
+        0.0000641,  0.0000657,  0.0000672,  0.0000687,  0.0000702, &
+        0.0000716,  0.0000730,  0.0000743,  0.0000756,  0.0000769, &
+        0.0000781,  0.0000794,  0.0000806,  0.0000817,  0.0000829, &
+        0.0000840,  0.0000851,  0.0000862,  0.0000873,  0.0000883, &
+        0.0000893,  0.0000904,  0.0000913,  0.0000923,  0.0000933, &
+        0.0000943,  0.0000952,  0.0000961,  0.0000970,  0.0000979, &
+        0.0000988,  0.0000997,  0.0001006,  0.0001014,  0.0001023, &
+        0.0001031,  0.0001039,  0.0001047,  0.0001055,  0.0001063, &
+        0.0001071,  0.0001079,  0.0001087,  0.0001094,  0.0001102, &
+        0.0001109,  0.0001116,  0.0001124,  0.0001131,  0.0001138, &
+        0.0001145,  0.0001152/
+      data ((coa(i,j),i=1,62),j= 29, 29)/ &
+        0.0000451,  0.0000482,  0.0000511,  0.0000537,  0.0000561, &
+        0.0000584,  0.0000605,  0.0000626,  0.0000645,  0.0000664, &
+        0.0000682,  0.0000699,  0.0000715,  0.0000732,  0.0000747, &
+        0.0000763,  0.0000777,  0.0000792,  0.0000806,  0.0000820, &
+        0.0000833,  0.0000846,  0.0000859,  0.0000872,  0.0000884, &
+        0.0000896,  0.0000908,  0.0000920,  0.0000931,  0.0000942, &
+        0.0000953,  0.0000964,  0.0000975,  0.0000986,  0.0000996, &
+        0.0001006,  0.0001016,  0.0001026,  0.0001036,  0.0001046, &
+        0.0001055,  0.0001064,  0.0001074,  0.0001083,  0.0001092, &
+        0.0001101,  0.0001110,  0.0001118,  0.0001127,  0.0001135, &
+        0.0001144,  0.0001152,  0.0001160,  0.0001168,  0.0001176, &
+        0.0001184,  0.0001192,  0.0001200,  0.0001207,  0.0001215, &
+        0.0001222,  0.0001230/
+      data ((coa(i,j),i=1,62),j= 30, 30)/ &
+        0.0000478,  0.0000512,  0.0000543,  0.0000571,  0.0000597, &
+        0.0000621,  0.0000644,  0.0000666,  0.0000687,  0.0000708, &
+        0.0000727,  0.0000746,  0.0000764,  0.0000781,  0.0000798, &
+        0.0000814,  0.0000830,  0.0000846,  0.0000861,  0.0000876, &
+        0.0000891,  0.0000905,  0.0000919,  0.0000932,  0.0000945, &
+        0.0000958,  0.0000971,  0.0000984,  0.0000996,  0.0001008, &
+        0.0001020,  0.0001032,  0.0001043,  0.0001055,  0.0001066, &
+        0.0001077,  0.0001088,  0.0001098,  0.0001109,  0.0001119, &
+        0.0001129,  0.0001139,  0.0001149,  0.0001159,  0.0001168, &
+        0.0001178,  0.0001187,  0.0001197,  0.0001206,  0.0001215, &
+        0.0001224,  0.0001233,  0.0001241,  0.0001250,  0.0001258, &
+        0.0001267,  0.0001275,  0.0001283,  0.0001292,  0.0001300, &
+        0.0001308,  0.0001316/
+      data ((coa(i,j),i=1,62),j= 31, 31)/ &
+        0.0000508,  0.0000544,  0.0000577,  0.0000607,  0.0000635, &
+        0.0000661,  0.0000686,  0.0000710,  0.0000733,  0.0000754, &
+        0.0000775,  0.0000795,  0.0000815,  0.0000834,  0.0000852, &
+        0.0000870,  0.0000887,  0.0000904,  0.0000920,  0.0000936, &
+        0.0000952,  0.0000967,  0.0000982,  0.0000996,  0.0001011, &
+        0.0001025,  0.0001038,  0.0001052,  0.0001065,  0.0001078, &
+        0.0001091,  0.0001103,  0.0001116,  0.0001128,  0.0001140, &
+        0.0001151,  0.0001163,  0.0001174,  0.0001186,  0.0001197, &
+        0.0001207,  0.0001218,  0.0001229,  0.0001239,  0.0001249, &
+        0.0001260,  0.0001270,  0.0001279,  0.0001289,  0.0001299, &
+        0.0001308,  0.0001318,  0.0001327,  0.0001336,  0.0001317, &
+        0.0001325,  0.0001363,  0.0001372,  0.0001380,  0.0001389, &
+        0.0001397,  0.0001406/
+      data ((coa(i,j),i=1,62),j= 32, 32)/ &
+        0.0000540,  0.0000579,  0.0000615,  0.0000647,  0.0000677, &
+        0.0000706,  0.0000733,  0.0000758,  0.0000783,  0.0000806, &
+        0.0000829,  0.0000851,  0.0000872,  0.0000892,  0.0000912, &
+        0.0000931,  0.0000950,  0.0000968,  0.0000985,  0.0001003, &
+        0.0001020,  0.0001036,  0.0001052,  0.0001068,  0.0001083, &
+        0.0001098,  0.0001113,  0.0001127,  0.0001142,  0.0001156, &
+        0.0001169,  0.0001183,  0.0001196,  0.0001209,  0.0001222, &
+        0.0001234,  0.0001246,  0.0001259,  0.0001270,  0.0001282, &
+        0.0001294,  0.0001305,  0.0001317,  0.0001328,  0.0001339, &
+        0.0001321,  0.0001360,  0.0001371,  0.0001381,  0.0001391, &
+        0.0001401,  0.0001411,  0.0001421,  0.0001431,  0.0001440, &
+        0.0001450,  0.0001459,  0.0001469,  0.0001478,  0.0001487, &
+        0.0001496,  0.0001505/
+      data ((coa(i,j),i=1,62),j= 33, 33)/ &
+        0.0000575,  0.0000617,  0.0000655,  0.0000690,  0.0000723, &
+        0.0000754,  0.0000783,  0.0000810,  0.0000837,  0.0000862, &
+        0.0000887,  0.0000910,  0.0000933,  0.0000955,  0.0000976, &
+        0.0000997,  0.0001017,  0.0001036,  0.0001055,  0.0001074, &
+        0.0001092,  0.0001110,  0.0001127,  0.0001144,  0.0001160, &
+        0.0001176,  0.0001192,  0.0001208,  0.0001223,  0.0001238, &
+        0.0001252,  0.0001267,  0.0001281,  0.0001295,  0.0001308, &
+        0.0001322,  0.0001335,  0.0001319,  0.0001360,  0.0001373, &
+        0.0001385,  0.0001397,  0.0001409,  0.0001421,  0.0001433, &
+        0.0001444,  0.0001456,  0.0001467,  0.0001478,  0.0001489, &
+        0.0001499,  0.0001510,  0.0001520,  0.0001531,  0.0001541, &
+        0.0001551,  0.0001561,  0.0001571,  0.0001581,  0.0001590, &
+        0.0001600,  0.0001609/
+      data ((coa(i,j),i=1,62),j= 34, 34)/ &
+        0.0000613,  0.0000659,  0.0000700,  0.0000738,  0.0000773, &
+        0.0000806,  0.0000838,  0.0000868,  0.0000896,  0.0000924, &
+        0.0000950,  0.0000976,  0.0001000,  0.0001024,  0.0001047, &
+        0.0001069,  0.0001091,  0.0001112,  0.0001132,  0.0001152, &
+        0.0001172,  0.0001191,  0.0001209,  0.0001227,  0.0001245, &
+        0.0001262,  0.0001279,  0.0001296,  0.0001312,  0.0001328, &
+        0.0001344,  0.0001359,  0.0001374,  0.0001389,  0.0001403, &
+        0.0001417,  0.0001432,  0.0001445,  0.0001459,  0.0001472, &
+        0.0001485,  0.0001498,  0.0001511,  0.0001524,  0.0001536, &
+        0.0001548,  0.0001560,  0.0001572,  0.0001584,  0.0001595, &
+        0.0001607,  0.0001618,  0.0001629,  0.0001640,  0.0001651, &
+        0.0001661,  0.0001672,  0.0001682,  0.0001693,  0.0001703, &
+        0.0001713,  0.0001723/
+      data ((coa(i,j),i=1,62),j= 35, 35)/ &
+        0.0000654,  0.0000703,  0.0000747,  0.0000789,  0.0000827, &
+        0.0000863,  0.0000897,  0.0000929,  0.0000960,  0.0000990, &
+        0.0001018,  0.0001046,  0.0001072,  0.0001098,  0.0001123, &
+        0.0001147,  0.0001170,  0.0001193,  0.0001214,  0.0001236, &
+        0.0001257,  0.0001277,  0.0001297,  0.0001316,  0.0001335, &
+        0.0001325,  0.0001372,  0.0001389,  0.0001407,  0.0001424, &
+        0.0001440,  0.0001457,  0.0001473,  0.0001488,  0.0001504, &
+        0.0001519,  0.0001534,  0.0001548,  0.0001563,  0.0001577, &
+        0.0001591,  0.0001605,  0.0001618,  0.0001631,  0.0001645, &
+        0.0001658,  0.0001670,  0.0001683,  0.0001695,  0.0001707, &
+        0.0001720,  0.0001732,  0.0001743,  0.0001755,  0.0001767, &
+        0.0001778,  0.0001789,  0.0001800,  0.0001811,  0.0001822, &
+        0.0001833,  0.0001844/
+      data ((coa(i,j),i=1,62),j= 36, 36)/ &
+        0.0000699,  0.0000752,  0.0000800,  0.0000844,  0.0000886, &
+        0.0000925,  0.0000962,  0.0000997,  0.0001030,  0.0001062, &
+        0.0001093,  0.0001123,  0.0001151,  0.0001179,  0.0001205, &
+        0.0001231,  0.0001256,  0.0001280,  0.0001304,  0.0001327, &
+        0.0001321,  0.0001371,  0.0001392,  0.0001413,  0.0001433, &
+        0.0001453,  0.0001472,  0.0001491,  0.0001509,  0.0001527, &
+        0.0001545,  0.0001562,  0.0001579,  0.0001596,  0.0001612, &
+        0.0001629,  0.0001644,  0.0001660,  0.0001675,  0.0001690, &
+        0.0001705,  0.0001720,  0.0001734,  0.0001749,  0.0001762, &
+        0.0001776,  0.0001790,  0.0001803,  0.0001817,  0.0001830, &
+        0.0001842,  0.0001855,  0.0001868,  0.0001880,  0.0001892, &
+        0.0001905,  0.0001917,  0.0001928,  0.0001940,  0.0001952, &
+        0.0001963,  0.0001975/
+      data ((coa(i,j),i=1,62),j= 37, 37)/ &
+        0.0000748,  0.0000805,  0.0000858,  0.0000906,  0.0000951, &
+        0.0000993,  0.0001033,  0.0001071,  0.0001107,  0.0001142, &
+        0.0001175,  0.0001207,  0.0001238,  0.0001267,  0.0001296, &
+        0.0001323,  0.0001322,  0.0001376,  0.0001401,  0.0001426, &
+        0.0001450,  0.0001473,  0.0001496,  0.0001518,  0.0001539, &
+        0.0001560,  0.0001581,  0.0001601,  0.0001620,  0.0001640, &
+        0.0001659,  0.0001677,  0.0001695,  0.0001713,  0.0001731, &
+        0.0001748,  0.0001765,  0.0001781,  0.0001798,  0.0001814, &
+        0.0001830,  0.0001845,  0.0001861,  0.0001876,  0.0001891, &
+        0.0001905,  0.0001920,  0.0001934,  0.0001948,  0.0001962, &
+        0.0001976,  0.0001990,  0.0002003,  0.0002017,  0.0002030, &
+        0.0002043,  0.0002056,  0.0002068,  0.0002081,  0.0002093, &
+        0.0002106,  0.0002118/
+      data ((coa(i,j),i=1,62),j= 38, 38)/ &
+        0.0000802,  0.0000863,  0.0000920,  0.0000972,  0.0001021, &
+        0.0001067,  0.0001110,  0.0001151,  0.0001190,  0.0001227, &
+        0.0001263,  0.0001297,  0.0001330,  0.0001362,  0.0001393, &
+        0.0001422,  0.0001451,  0.0001479,  0.0001506,  0.0001532, &
+        0.0001557,  0.0001582,  0.0001606,  0.0001630,  0.0001653, &
+        0.0001675,  0.0001697,  0.0001719,  0.0001740,  0.0001760, &
+        0.0001780,  0.0001800,  0.0001819,  0.0001839,  0.0001857, &
+        0.0001876,  0.0001894,  0.0001911,  0.0001929,  0.0001946, &
+        0.0001963,  0.0001980,  0.0001996,  0.0002012,  0.0002028, &
+        0.0002044,  0.0002060,  0.0002075,  0.0002090,  0.0002105, &
+        0.0002120,  0.0002135,  0.0002149,  0.0002164,  0.0002178, &
+        0.0002192,  0.0002205,  0.0002219,  0.0002233,  0.0002246, &
+        0.0002259,  0.0002273/
+      data ((coa(i,j),i=1,62),j= 39, 39)/ &
+        0.0000859,  0.0000926,  0.0000987,  0.0001044,  0.0001097, &
+        0.0001146,  0.0001193,  0.0001237,  0.0001279,  0.0001319, &
+        0.0001358,  0.0001395,  0.0001430,  0.0001464,  0.0001497, &
+        0.0001528,  0.0001559,  0.0001589,  0.0001617,  0.0001645, &
+        0.0001673,  0.0001699,  0.0001725,  0.0001750,  0.0001774, &
+        0.0001798,  0.0001822,  0.0001845,  0.0001867,  0.0001889, &
+        0.0001911,  0.0001932,  0.0001953,  0.0001973,  0.0001993, &
+        0.0002013,  0.0002032,  0.0002051,  0.0002070,  0.0002088, &
+        0.0002107,  0.0002124,  0.0002142,  0.0002160,  0.0002177, &
+        0.0002194,  0.0002211,  0.0002227,  0.0002243,  0.0002260, &
+        0.0002276,  0.0002291,  0.0002307,  0.0002322,  0.0002338, &
+        0.0002353,  0.0002368,  0.0002382,  0.0002397,  0.0002412, &
+        0.0002426,  0.0002440/
+      data ((coa(i,j),i=1,62),j= 40, 40)/ &
+        0.0000922,  0.0000995,  0.0001061,  0.0001122,  0.0001179, &
+        0.0001233,  0.0001283,  0.0001331,  0.0001376,  0.0001419, &
+        0.0001460,  0.0001500,  0.0001538,  0.0001574,  0.0001609, &
+        0.0001643,  0.0001676,  0.0001707,  0.0001738,  0.0001768, &
+        0.0001797,  0.0001825,  0.0001853,  0.0001880,  0.0001906, &
+        0.0001932,  0.0001957,  0.0001981,  0.0002006,  0.0002029, &
+        0.0002052,  0.0002075,  0.0002097,  0.0002119,  0.0002141, &
+        0.0002162,  0.0002183,  0.0002203,  0.0002223,  0.0002243, &
+        0.0002263,  0.0002282,  0.0002301,  0.0002320,  0.0002339, &
+        0.0002357,  0.0002375,  0.0002393,  0.0002411,  0.0002428, &
+        0.0002446,  0.0002463,  0.0002480,  0.0002496,  0.0002513, &
+        0.0002529,  0.0002546,  0.0002562,  0.0002578,  0.0002593, &
+        0.0002609,  0.0002625/
+      data ((coa(i,j),i=1,62),j= 41, 41)/ &
+        0.0000990,  0.0001069,  0.0001141,  0.0001207,  0.0001268, &
+        0.0001326,  0.0001380,  0.0001431,  0.0001480,  0.0001526, &
+        0.0001570,  0.0001612,  0.0001653,  0.0001692,  0.0001729, &
+        0.0001766,  0.0001801,  0.0001835,  0.0001868,  0.0001900, &
+        0.0001931,  0.0001961,  0.0001991,  0.0002019,  0.0002048, &
+        0.0002075,  0.0002102,  0.0002129,  0.0002154,  0.0002180, &
+        0.0002205,  0.0002229,  0.0002253,  0.0002277,  0.0002300, &
+        0.0002323,  0.0002346,  0.0002368,  0.0002390,  0.0002411, &
+        0.0002432,  0.0002453,  0.0002474,  0.0002494,  0.0002515, &
+        0.0002535,  0.0002554,  0.0002574,  0.0002593,  0.0002612, &
+        0.0002631,  0.0002649,  0.0002668,  0.0002686,  0.0002704, &
+        0.0002722,  0.0002740,  0.0002757,  0.0002775,  0.0002792, &
+        0.0002809,  0.0002826/
+      data ((coa(i,j),i=1,62),j= 42, 42)/ &
+        0.0001063,  0.0001148,  0.0001226,  0.0001297,  0.0001363, &
+        0.0001425,  0.0001483,  0.0001538,  0.0001590,  0.0001639, &
+        0.0001687,  0.0001732,  0.0001775,  0.0001817,  0.0001857, &
+        0.0001896,  0.0001933,  0.0001970,  0.0002005,  0.0002039, &
+        0.0002073,  0.0002105,  0.0002137,  0.0002168,  0.0002198, &
+        0.0002228,  0.0002257,  0.0002286,  0.0002314,  0.0002341, &
+        0.0002368,  0.0002394,  0.0002420,  0.0002446,  0.0002471, &
+        0.0002496,  0.0002520,  0.0002544,  0.0002568,  0.0002591, &
+        0.0002615,  0.0002637,  0.0002660,  0.0002682,  0.0002704, &
+        0.0002726,  0.0002747,  0.0002768,  0.0002789,  0.0002810, &
+        0.0002831,  0.0002851,  0.0002871,  0.0002891,  0.0002911, &
+        0.0002930,  0.0002950,  0.0002969,  0.0002988,  0.0003007, &
+        0.0003025,  0.0003044/
+      data ((coa(i,j),i=1,62),j= 43, 43)/ &
+        0.0001141,  0.0001233,  0.0001316,  0.0001393,  0.0001464, &
+        0.0001531,  0.0001593,  0.0001652,  0.0001707,  0.0001760, &
+        0.0001811,  0.0001859,  0.0001905,  0.0001950,  0.0001993, &
+        0.0002035,  0.0002075,  0.0002114,  0.0002152,  0.0002189, &
+        0.0002225,  0.0002260,  0.0002294,  0.0002328,  0.0002360, &
+        0.0002393,  0.0002424,  0.0002455,  0.0002485,  0.0002515, &
+        0.0002544,  0.0002573,  0.0002601,  0.0002629,  0.0002656, &
+        0.0002683,  0.0002709,  0.0002736,  0.0002762,  0.0002787, &
+        0.0002812,  0.0002837,  0.0002862,  0.0002886,  0.0002910, &
+        0.0002934,  0.0002957,  0.0002980,  0.0003003,  0.0003026, &
+        0.0003048,  0.0003071,  0.0003093,  0.0003114,  0.0003136, &
+        0.0003157,  0.0003179,  0.0003200,  0.0003221,  0.0003241, &
+        0.0003262,  0.0003282/
+      data ((coa(i,j),i=1,62),j= 44, 44)/ &
+        0.0001224,  0.0001323,  0.0001413,  0.0001496,  0.0001572, &
+        0.0001643,  0.0001709,  0.0001772,  0.0001832,  0.0001888, &
+        0.0001943,  0.0001994,  0.0002044,  0.0002092,  0.0002138, &
+        0.0002183,  0.0002226,  0.0002269,  0.0002309,  0.0002349, &
+        0.0002388,  0.0002426,  0.0002463,  0.0002499,  0.0002535, &
+        0.0002570,  0.0002604,  0.0002637,  0.0002670,  0.0002702, &
+        0.0002734,  0.0002765,  0.0002796,  0.0002826,  0.0002856, &
+        0.0002886,  0.0002915,  0.0002943,  0.0002972,  0.0002999, &
+        0.0003027,  0.0003054,  0.0003081,  0.0003108,  0.0003134, &
+        0.0003160,  0.0003185,  0.0003211,  0.0003236,  0.0003261, &
+        0.0003286,  0.0003310,  0.0003334,  0.0003358,  0.0003382, &
+        0.0003405,  0.0003428,  0.0003451,  0.0003474,  0.0003497, &
+        0.0003519,  0.0003542/
+      data ((coa(i,j),i=1,62),j= 45, 45)/ &
+        0.0001312,  0.0001419,  0.0001515,  0.0001603,  0.0001685, &
+        0.0001761,  0.0001832,  0.0001899,  0.0001963,  0.0002024, &
+        0.0002082,  0.0002138,  0.0002191,  0.0002243,  0.0002292, &
+        0.0002341,  0.0002387,  0.0002433,  0.0002477,  0.0002520, &
+        0.0002562,  0.0002603,  0.0002644,  0.0002683,  0.0002722, &
+        0.0002759,  0.0002796,  0.0002833,  0.0002869,  0.0002904, &
+        0.0002939,  0.0002973,  0.0003006,  0.0003039,  0.0003072, &
+        0.0003104,  0.0003136,  0.0003167,  0.0003198,  0.0003228, &
+        0.0003259,  0.0003288,  0.0003318,  0.0003347,  0.0003376, &
+        0.0003404,  0.0003432,  0.0003460,  0.0003487,  0.0003515, &
+        0.0003542,  0.0003568,  0.0003595,  0.0003621,  0.0003647, &
+        0.0003673,  0.0003698,  0.0003724,  0.0003749,  0.0003773, &
+        0.0003798,  0.0003822/
+      data ((coa(i,j),i=1,62),j= 46, 46)/ &
+        0.0001406,  0.0001520,  0.0001623,  0.0001718,  0.0001805, &
+        0.0001886,  0.0001963,  0.0002035,  0.0002103,  0.0002168, &
+        0.0002231,  0.0002291,  0.0002348,  0.0002404,  0.0002458, &
+        0.0002510,  0.0002561,  0.0002610,  0.0002658,  0.0002705, &
+        0.0002750,  0.0002795,  0.0002839,  0.0002882,  0.0002924, &
+        0.0002965,  0.0003005,  0.0003045,  0.0003084,  0.0003123, &
+        0.0003161,  0.0003198,  0.0003235,  0.0003271,  0.0003307, &
+        0.0003342,  0.0003376,  0.0003411,  0.0003445,  0.0003478, &
+        0.0003511,  0.0003544,  0.0003576,  0.0003608,  0.0003639, &
+        0.0003670,  0.0003701,  0.0003731,  0.0003762,  0.0003791, &
+        0.0003821,  0.0003850,  0.0003879,  0.0003908,  0.0003936, &
+        0.0003965,  0.0003992,  0.0004020,  0.0004047,  0.0004075, &
+        0.0004102,  0.0004128/
+      data ((coa(i,j),i=1,62),j= 47, 47)/ &
+        0.0001506,  0.0001628,  0.0001739,  0.0001840,  0.0001934, &
+        0.0002021,  0.0002103,  0.0002180,  0.0002254,  0.0002324, &
+        0.0002391,  0.0002456,  0.0002518,  0.0002579,  0.0002637, &
+        0.0002694,  0.0002749,  0.0002802,  0.0002854,  0.0002905, &
+        0.0002955,  0.0003004,  0.0003052,  0.0003099,  0.0003145, &
+        0.0003190,  0.0003234,  0.0003278,  0.0003320,  0.0003362, &
+        0.0003404,  0.0003445,  0.0003485,  0.0003524,  0.0003564, &
+        0.0003602,  0.0003640,  0.0003678,  0.0003715,  0.0003751, &
+        0.0003787,  0.0003823,  0.0003858,  0.0003893,  0.0003928, &
+        0.0003962,  0.0003995,  0.0004029,  0.0004062,  0.0004094, &
+        0.0004127,  0.0004159,  0.0004190,  0.0004222,  0.0004253, &
+        0.0004283,  0.0004314,  0.0004344,  0.0004374,  0.0004404, &
+        0.0004433,  0.0004462/
+      data ((coa(i,j),i=1,62),j= 48, 48)/ &
+        0.0001613,  0.0001744,  0.0001863,  0.0001971,  0.0002072, &
+        0.0002165,  0.0002254,  0.0002337,  0.0002417,  0.0002493, &
+        0.0002565,  0.0002636,  0.0002703,  0.0002769,  0.0002832, &
+        0.0002894,  0.0002954,  0.0003013,  0.0003070,  0.0003125, &
+        0.0003180,  0.0003233,  0.0003286,  0.0003337,  0.0003387, &
+        0.0003436,  0.0003485,  0.0003533,  0.0003579,  0.0003625, &
+        0.0003671,  0.0003716,  0.0003760,  0.0003803,  0.0003846, &
+        0.0003888,  0.0003929,  0.0003971,  0.0004011,  0.0004051, &
+        0.0004091,  0.0004130,  0.0004168,  0.0004206,  0.0004244, &
+        0.0004281,  0.0004318,  0.0004354,  0.0004390,  0.0004426, &
+        0.0004461,  0.0004496,  0.0004530,  0.0004565,  0.0004598, &
+        0.0004632,  0.0004665,  0.0004698,  0.0004730,  0.0004763, &
+        0.0004795,  0.0004826/
+      data ((coa(i,j),i=1,62),j= 49, 49)/ &
+        0.0001728,  0.0001868,  0.0001996,  0.0002112,  0.0002220, &
+        0.0002321,  0.0002417,  0.0002507,  0.0002593,  0.0002676, &
+        0.0002755,  0.0002831,  0.0002905,  0.0002977,  0.0003046, &
+        0.0003113,  0.0003179,  0.0003243,  0.0003305,  0.0003366, &
+        0.0003426,  0.0003484,  0.0003542,  0.0003598,  0.0003653, &
+        0.0003707,  0.0003760,  0.0003812,  0.0003863,  0.0003914, &
+        0.0003963,  0.0004012,  0.0004060,  0.0004108,  0.0004154, &
+        0.0004201,  0.0004246,  0.0004291,  0.0004335,  0.0004379, &
+        0.0004422,  0.0004464,  0.0004506,  0.0004548,  0.0004589, &
+        0.0004629,  0.0004669,  0.0004709,  0.0004748,  0.0004787, &
+        0.0004825,  0.0004863,  0.0004900,  0.0004937,  0.0004974, &
+        0.0005010,  0.0005046,  0.0005082,  0.0005117,  0.0005152, &
+        0.0005187,  0.0005221/
+      data ((coa(i,j),i=1,62),j= 50, 50)/ &
+        0.0001851,  0.0002003,  0.0002139,  0.0002265,  0.0002382, &
+        0.0002491,  0.0002595,  0.0002693,  0.0002787,  0.0002877, &
+        0.0002963,  0.0003047,  0.0003127,  0.0003205,  0.0003281, &
+        0.0003355,  0.0003427,  0.0003497,  0.0003565,  0.0003632, &
+        0.0003697,  0.0003761,  0.0003824,  0.0003885,  0.0003945, &
+        0.0004004,  0.0004062,  0.0004119,  0.0004175,  0.0004230, &
+        0.0004285,  0.0004338,  0.0004390,  0.0004442,  0.0004493, &
+        0.0004543,  0.0004593,  0.0004641,  0.0004689,  0.0004737, &
+        0.0004784,  0.0004830,  0.0004875,  0.0004920,  0.0004965, &
+        0.0005009,  0.0005052,  0.0005095,  0.0005138,  0.0005179, &
+        0.0005221,  0.0005262,  0.0005302,  0.0005342,  0.0005268, &
+        0.0005421,  0.0005460,  0.0005499,  0.0005537,  0.0005574, &
+        0.0005612,  0.0005649/
+      data ((coa(i,j),i=1,62),j= 51, 51)/ &
+        0.0001985,  0.0002149,  0.0002297,  0.0002433,  0.0002559, &
+        0.0002679,  0.0002791,  0.0002898,  0.0003001,  0.0003099, &
+        0.0003193,  0.0003285,  0.0003373,  0.0003459,  0.0003542, &
+        0.0003622,  0.0003701,  0.0003778,  0.0003853,  0.0003926, &
+        0.0003997,  0.0004067,  0.0004135,  0.0004202,  0.0004268, &
+        0.0004333,  0.0004396,  0.0004458,  0.0004519,  0.0004579, &
+        0.0004638,  0.0004696,  0.0004753,  0.0004809,  0.0004864, &
+        0.0004919,  0.0004972,  0.0005025,  0.0005077,  0.0005129, &
+        0.0005179,  0.0005229,  0.0005279,  0.0005327,  0.0005375, &
+        0.0005423,  0.0005470,  0.0005516,  0.0005562,  0.0005607, &
+        0.0005652,  0.0005696,  0.0005739,  0.0005782,  0.0005825, &
+        0.0005867,  0.0005909,  0.0005951,  0.0005991,  0.0006032, &
+        0.0006072,  0.0006112/
+      data ((coa(i,j),i=1,62),j= 52, 52)/ &
+        0.0002132,  0.0002309,  0.0002469,  0.0002617,  0.0002755, &
+        0.0002885,  0.0003008,  0.0003125,  0.0003237,  0.0003345, &
+        0.0003449,  0.0003549,  0.0003645,  0.0003739,  0.0003830, &
+        0.0003918,  0.0004004,  0.0004088,  0.0004170,  0.0004250, &
+        0.0004328,  0.0004404,  0.0004478,  0.0004551,  0.0004623, &
+        0.0004693,  0.0004762,  0.0004829,  0.0004895,  0.0004960, &
+        0.0005024,  0.0005087,  0.0005149,  0.0005210,  0.0005269, &
+        0.0005328,  0.0005272,  0.0005443,  0.0005500,  0.0005555, &
+        0.0005609,  0.0005663,  0.0005717,  0.0005769,  0.0005821, &
+        0.0005872,  0.0005922,  0.0005972,  0.0006021,  0.0006070, &
+        0.0006118,  0.0006165,  0.0006212,  0.0006258,  0.0006304, &
+        0.0006349,  0.0006394,  0.0006438,  0.0006482,  0.0006525, &
+        0.0006568,  0.0006611/
+      data ((coa(i,j),i=1,62),j= 53, 53)/ &
+        0.0002293,  0.0002485,  0.0002660,  0.0002821,  0.0002972, &
+        0.0003114,  0.0003249,  0.0003377,  0.0003500,  0.0003618, &
+        0.0003732,  0.0003841,  0.0003947,  0.0004049,  0.0004149, &
+        0.0004245,  0.0004339,  0.0004430,  0.0004520,  0.0004606, &
+        0.0004691,  0.0004774,  0.0004855,  0.0004934,  0.0005012, &
+        0.0005087,  0.0005162,  0.0005235,  0.0005306,  0.0005377, &
+        0.0005446,  0.0005513,  0.0005580,  0.0005646,  0.0005710, &
+        0.0005773,  0.0005836,  0.0005897,  0.0005957,  0.0006017, &
+        0.0006076,  0.0006134,  0.0006191,  0.0006247,  0.0006302, &
+        0.0006357,  0.0006411,  0.0006464,  0.0006517,  0.0006569, &
+        0.0006620,  0.0006671,  0.0006721,  0.0006771,  0.0006820, &
+        0.0006868,  0.0006916,  0.0006963,  0.0007010,  0.0007056, &
+        0.0007102,  0.0007147/
+      data ((coa(i,j),i=1,62),j= 54, 54)/ &
+        0.0002471,  0.0002680,  0.0002871,  0.0003048,  0.0003214, &
+        0.0003369,  0.0003517,  0.0003658,  0.0003792,  0.0003921, &
+        0.0004045,  0.0004165,  0.0004281,  0.0004392,  0.0004501, &
+        0.0004606,  0.0004708,  0.0004807,  0.0004903,  0.0004998, &
+        0.0005089,  0.0005179,  0.0005267,  0.0005352,  0.0005436, &
+        0.0005518,  0.0005598,  0.0005677,  0.0005754,  0.0005829, &
+        0.0005903,  0.0005976,  0.0006048,  0.0006118,  0.0006187, &
+        0.0006255,  0.0006322,  0.0006388,  0.0006453,  0.0006516, &
+        0.0006579,  0.0006641,  0.0006702,  0.0006762,  0.0006822, &
+        0.0006880,  0.0006938,  0.0006995,  0.0007051,  0.0007106, &
+        0.0007161,  0.0007215,  0.0007269,  0.0007321,  0.0007374, &
+        0.0007425,  0.0007476,  0.0007527,  0.0007576,  0.0007626, &
+        0.0007674,  0.0007723/
+      data ((coa(i,j),i=1,62),j= 55, 55)/ &
+        0.0002669,  0.0002898,  0.0003107,  0.0003300,  0.0003482, &
+        0.0003653,  0.0003815,  0.0003969,  0.0004116,  0.0004257, &
+        0.0004392,  0.0004522,  0.0004648,  0.0004769,  0.0004887, &
+        0.0005001,  0.0005111,  0.0005218,  0.0005323,  0.0005425, &
+        0.0005524,  0.0005620,  0.0005714,  0.0005807,  0.0005897, &
+        0.0005985,  0.0006071,  0.0006155,  0.0006238,  0.0006319, &
+        0.0006398,  0.0006476,  0.0006553,  0.0006628,  0.0006702, &
+        0.0006775,  0.0006846,  0.0006917,  0.0006986,  0.0007054, &
+        0.0007121,  0.0007187,  0.0007252,  0.0007316,  0.0007379, &
+        0.0007442,  0.0007503,  0.0007564,  0.0007624,  0.0007683, &
+        0.0007741,  0.0007798,  0.0007855,  0.0007911,  0.0007967, &
+        0.0008022,  0.0008076,  0.0008129,  0.0008182,  0.0008235, &
+        0.0008286,  0.0008337/
+      data ((coa(i,j),i=1,62),j= 56, 56)/ &
+        0.0002889,  0.0003140,  0.0003369,  0.0003582,  0.0003780, &
+        0.0003967,  0.0004144,  0.0004312,  0.0004473,  0.0004626, &
+        0.0004773,  0.0004914,  0.0005050,  0.0005182,  0.0005309, &
+        0.0005432,  0.0005551,  0.0005666,  0.0005779,  0.0005888, &
+        0.0005995,  0.0006098,  0.0006200,  0.0006298,  0.0006395, &
+        0.0006489,  0.0006581,  0.0006672,  0.0006760,  0.0006847, &
+        0.0006932,  0.0007015,  0.0007097,  0.0007177,  0.0007256, &
+        0.0007333,  0.0007409,  0.0007484,  0.0007558,  0.0007630, &
+        0.0007702,  0.0007772,  0.0007841,  0.0007909,  0.0007976, &
+        0.0008043,  0.0008108,  0.0008172,  0.0008236,  0.0008298, &
+        0.0008360,  0.0008421,  0.0008481,  0.0008541,  0.0008600, &
+        0.0008658,  0.0008715,  0.0008772,  0.0008828,  0.0008883, &
+        0.0008938,  0.0008992/
+      data ((coa(i,j),i=1,62),j= 57, 57)/ &
+        0.0003135,  0.0003410,  0.0003662,  0.0003895,  0.0004112, &
+        0.0004316,  0.0004509,  0.0004692,  0.0004866,  0.0005032, &
+        0.0005191,  0.0005344,  0.0005491,  0.0005632,  0.0005769, &
+        0.0005901,  0.0006029,  0.0006153,  0.0006274,  0.0006391, &
+        0.0006505,  0.0006616,  0.0006725,  0.0006830,  0.0006933, &
+        0.0007034,  0.0007132,  0.0007229,  0.0007323,  0.0007415, &
+        0.0007506,  0.0007595,  0.0007682,  0.0007767,  0.0007851, &
+        0.0007933,  0.0008014,  0.0008093,  0.0008172,  0.0008249, &
+        0.0008324,  0.0008399,  0.0008472,  0.0008544,  0.0008615, &
+        0.0008685,  0.0008755,  0.0008823,  0.0008890,  0.0008956, &
+        0.0009021,  0.0009086,  0.0009149,  0.0009212,  0.0009274, &
+        0.0009335,  0.0009396,  0.0009455,  0.0009514,  0.0009573, &
+        0.0009630,  0.0009687/
+      data ((coa(i,j),i=1,62),j= 58, 58)/ &
+        0.0003409,  0.0003711,  0.0003987,  0.0004241,  0.0004478, &
+        0.0004700,  0.0004909,  0.0005107,  0.0005295,  0.0005474, &
+        0.0005645,  0.0005810,  0.0005968,  0.0006120,  0.0006267, &
+        0.0006408,  0.0006545,  0.0006678,  0.0006807,  0.0006932, &
+        0.0007054,  0.0007173,  0.0007288,  0.0007401,  0.0007510, &
+        0.0007618,  0.0007722,  0.0007825,  0.0007925,  0.0008023, &
+        0.0008119,  0.0008213,  0.0008306,  0.0008396,  0.0008485, &
+        0.0008572,  0.0008658,  0.0008742,  0.0008824,  0.0008906, &
+        0.0008986,  0.0009064,  0.0009142,  0.0009218,  0.0009293, &
+        0.0009367,  0.0009439,  0.0009511,  0.0009582,  0.0009652, &
+        0.0009720,  0.0009788,  0.0009855,  0.0009921,  0.0009986, &
+        0.0010050,  0.0010113,  0.0010176,  0.0010238,  0.0010299, &
+        0.0010359,  0.0010419/
+      data ((coa(i,j),i=1,62),j= 59, 59)/ &
+        0.0003715,  0.0004046,  0.0004346,  0.0004623,  0.0004880, &
+        0.0005120,  0.0005346,  0.0005560,  0.0005762,  0.0005955, &
+        0.0006139,  0.0006315,  0.0006485,  0.0006648,  0.0006804, &
+        0.0006956,  0.0007102,  0.0007244,  0.0007382,  0.0007515, &
+        0.0007645,  0.0007771,  0.0007893,  0.0008012,  0.0008129, &
+        0.0008243,  0.0008354,  0.0008463,  0.0008569,  0.0008673, &
+        0.0008774,  0.0008874,  0.0008971,  0.0009067,  0.0009160, &
+        0.0009252,  0.0009342,  0.0009431,  0.0009518,  0.0009604, &
+        0.0009688,  0.0009770,  0.0009851,  0.0009931,  0.0010010, &
+        0.0010088,  0.0010164,  0.0010239,  0.0010313,  0.0010386, &
+        0.0010458,  0.0010529,  0.0010598,  0.0010667,  0.0010735, &
+        0.0010802,  0.0010869,  0.0010934,  0.0010998,  0.0011062, &
+        0.0011125,  0.0011187/
+      data ((coa(i,j),i=1,62),j= 60, 60)/ &
+        0.0004055,  0.0004415,  0.0004742,  0.0005042,  0.0005320, &
+        0.0005579,  0.0005822,  0.0006052,  0.0006269,  0.0006476, &
+        0.0006673,  0.0006862,  0.0007042,  0.0007216,  0.0007383, &
+        0.0007545,  0.0007701,  0.0007851,  0.0007997,  0.0008139, &
+        0.0008276,  0.0008410,  0.0008540,  0.0008666,  0.0008789, &
+        0.0008910,  0.0009027,  0.0009141,  0.0009253,  0.0009362, &
+        0.0009469,  0.0009574,  0.0009676,  0.0009777,  0.0009875, &
+        0.0009972,  0.0010066,  0.0010159,  0.0010250,  0.0010339, &
+        0.0010427,  0.0010514,  0.0010599,  0.0010682,  0.0010764, &
+        0.0010845,  0.0010925,  0.0011003,  0.0011080,  0.0011156, &
+        0.0011231,  0.0011304,  0.0011377,  0.0011449,  0.0011519, &
+        0.0011589,  0.0011658,  0.0011726,  0.0011793,  0.0011859, &
+        0.0011924,  0.0011989/
+      data ((coa(i,j),i=1,62),j= 61, 61)/ &
+        0.0004429,  0.0004821,  0.0005175,  0.0005499,  0.0005798, &
+        0.0006076,  0.0006337,  0.0006583,  0.0006816,  0.0007037, &
+        0.0007247,  0.0007448,  0.0007640,  0.0007825,  0.0008003, &
+        0.0008174,  0.0008339,  0.0008499,  0.0008653,  0.0008803, &
+        0.0008948,  0.0009089,  0.0009226,  0.0009359,  0.0009488, &
+        0.0009615,  0.0009738,  0.0009858,  0.0009975,  0.0010089, &
+        0.0010201,  0.0010311,  0.0010418,  0.0010523,  0.0010625, &
+        0.0010726,  0.0010825,  0.0010921,  0.0011016,  0.0011109, &
+        0.0011201,  0.0011291,  0.0011379,  0.0011466,  0.0011551, &
+        0.0011635,  0.0011718,  0.0011799,  0.0011879,  0.0011958, &
+        0.0012035,  0.0012112,  0.0012187,  0.0012261,  0.0012335, &
+        0.0012407,  0.0012478,  0.0012548,  0.0012618,  0.0012686, &
+        0.0012754,  0.0012821/
+      data ((coa(i,j),i=1,62),j= 62, 62)/ &
+        0.0004840,  0.0005264,  0.0005646,  0.0005994,  0.0006316, &
+        0.0006614,  0.0006893,  0.0007155,  0.0007403,  0.0007638, &
+        0.0007862,  0.0008075,  0.0008279,  0.0008475,  0.0008663, &
+        0.0008844,  0.0009018,  0.0009186,  0.0009349,  0.0009506, &
+        0.0009658,  0.0009806,  0.0009950,  0.0010089,  0.0010225, &
+        0.0010356,  0.0010485,  0.0010610,  0.0010733,  0.0010852, &
+        0.0010968,  0.0011082,  0.0011194,  0.0011303,  0.0011409, &
+        0.0011514,  0.0011616,  0.0011717,  0.0011815,  0.0011912, &
+        0.0012007,  0.0012100,  0.0012191,  0.0012281,  0.0012370, &
+        0.0012457,  0.0012542,  0.0012627,  0.0012709,  0.0012791, &
+        0.0012871,  0.0012951,  0.0013029,  0.0013106,  0.0013181, &
+        0.0013256,  0.0013330,  0.0013403,  0.0013475,  0.0013546, &
+        0.0013616,  0.0013685/
+      data ((coa(i,j),i=1,62),j= 63, 63)/ &
+        0.0005290,  0.0005747,  0.0006157,  0.0006530,  0.0006874, &
+        0.0007192,  0.0007490,  0.0007769,  0.0008032,  0.0008281, &
+        0.0008518,  0.0008743,  0.0008959,  0.0009165,  0.0009362, &
+        0.0009552,  0.0009735,  0.0009911,  0.0010082,  0.0010246, &
+        0.0010405,  0.0010559,  0.0010709,  0.0010854,  0.0010995, &
+        0.0011132,  0.0011266,  0.0011396,  0.0011523,  0.0011647, &
+        0.0011768,  0.0011886,  0.0012002,  0.0012115,  0.0012225, &
+        0.0012334,  0.0012440,  0.0012544,  0.0012646,  0.0012746, &
+        0.0012844,  0.0012941,  0.0013036,  0.0013129,  0.0013220, &
+        0.0013310,  0.0013399,  0.0013486,  0.0013572,  0.0013657, &
+        0.0013740,  0.0013823,  0.0013904,  0.0013983,  0.0014062, &
+        0.0014140,  0.0014217,  0.0014292,  0.0014367,  0.0014441, &
+        0.0014514,  0.0014586/
+      data ((coa(i,j),i=1,62),j= 64, 64)/ &
+        0.0005778,  0.0006269,  0.0006708,  0.0007107,  0.0007473, &
+        0.0007812,  0.0008127,  0.0008423,  0.0008701,  0.0008964, &
+        0.0009213,  0.0009450,  0.0009676,  0.0009892,  0.0010099, &
+        0.0010297,  0.0010488,  0.0010671,  0.0010848,  0.0011020, &
+        0.0011185,  0.0011345,  0.0011500,  0.0011651,  0.0011798, &
+        0.0011940,  0.0012078,  0.0012213,  0.0012345,  0.0012473, &
+        0.0012599,  0.0012721,  0.0012841,  0.0012958,  0.0013073, &
+        0.0013185,  0.0013295,  0.0013403,  0.0013509,  0.0013612, &
+        0.0013714,  0.0013815,  0.0013913,  0.0014010,  0.0014105, &
+        0.0014199,  0.0014291,  0.0014382,  0.0014471,  0.0014559, &
+        0.0014646,  0.0014732,  0.0014816,  0.0014900,  0.0014982, &
+        0.0015063,  0.0015143,  0.0015222,  0.0015300,  0.0015377, &
+        0.0015453,  0.0015528/
+      data ((coa(i,j),i=1,62),j= 65, 65)/ &
+        0.0006307,  0.0006832,  0.0007301,  0.0007725,  0.0008114, &
+        0.0008472,  0.0008805,  0.0009116,  0.0009409,  0.0009684, &
+        0.0009945,  0.0010193,  0.0010428,  0.0010653,  0.0010868, &
+        0.0011075,  0.0011273,  0.0011464,  0.0011647,  0.0011825, &
+        0.0011996,  0.0012162,  0.0012323,  0.0012480,  0.0012631, &
+        0.0012779,  0.0012922,  0.0013062,  0.0013199,  0.0013332, &
+        0.0013462,  0.0013589,  0.0013713,  0.0013835,  0.0013954, &
+        0.0014071,  0.0014186,  0.0014298,  0.0014408,  0.0014516, &
+        0.0014623,  0.0014727,  0.0014830,  0.0014931,  0.0015030, &
+        0.0015128,  0.0015225,  0.0015319,  0.0015413,  0.0015505, &
+        0.0015596,  0.0015686,  0.0015774,  0.0015862,  0.0015948, &
+        0.0016033,  0.0016117,  0.0016200,  0.0016282,  0.0016363, &
+        0.0016443,  0.0016522/
+      data ((coa(i,j),i=1,62),j= 66, 66)/ &
+        0.0006876,  0.0007436,  0.0007934,  0.0008383,  0.0008793, &
+        0.0009170,  0.0009520,  0.0009846,  0.0010150,  0.0010439, &
+        0.0010710,  0.0010968,  0.0011213,  0.0011446,  0.0011669, &
+        0.0011883,  0.0012089,  0.0012287,  0.0012477,  0.0012661, &
+        0.0012839,  0.0013011,  0.0013178,  0.0013340,  0.0013498, &
+        0.0013651,  0.0013800,  0.0013946,  0.0014088,  0.0014227, &
+        0.0014362,  0.0014495,  0.0014624,  0.0014751,  0.0014876, &
+        0.0014998,  0.0015117,  0.0015235,  0.0015350,  0.0015464, &
+        0.0015575,  0.0015685,  0.0015792,  0.0015899,  0.0016003, &
+        0.0016106,  0.0016207,  0.0016307,  0.0016405,  0.0016502, &
+        0.0016598,  0.0016693,  0.0016786,  0.0016878,  0.0016969, &
+        0.0017059,  0.0017147,  0.0017235,  0.0017322,  0.0017407, &
+        0.0017492,  0.0017575/
+      data ((coa(i,j),i=1,62),j= 67, 67)/ &
+        0.0007485,  0.0008080,  0.0008606,  0.0009079,  0.0009509, &
+        0.0009904,  0.0010269,  0.0010608,  0.0010926,  0.0011225, &
+        0.0011507,  0.0011774,  0.0012028,  0.0012270,  0.0012501, &
+        0.0012723,  0.0012936,  0.0013142,  0.0013339,  0.0013531, &
+        0.0013716,  0.0013895,  0.0014069,  0.0014238,  0.0014402, &
+        0.0014562,  0.0014718,  0.0014870,  0.0015019,  0.0015164, &
+        0.0015306,  0.0015445,  0.0015581,  0.0015714,  0.0015845, &
+        0.0015973,  0.0016099,  0.0016223,  0.0016344,  0.0016464, &
+        0.0016581,  0.0016697,  0.0016811,  0.0016922,  0.0017033, &
+        0.0017141,  0.0017249,  0.0017354,  0.0017458,  0.0017561, &
+        0.0017662,  0.0017762,  0.0017861,  0.0017959,  0.0018055, &
+        0.0018150,  0.0018244,  0.0018337,  0.0018429,  0.0018520, &
+        0.0018610,  0.0018698/
+      data ((coa(i,j),i=1,62),j= 68, 68)/ &
+        0.0008135,  0.0008762,  0.0009315,  0.0009811,  0.0010259, &
+        0.0010670,  0.0011050,  0.0011402,  0.0011732,  0.0012042, &
+        0.0012334,  0.0012611,  0.0012874,  0.0013126,  0.0013366, &
+        0.0013597,  0.0013819,  0.0014033,  0.0014239,  0.0014439, &
+        0.0014632,  0.0014820,  0.0015002,  0.0015179,  0.0015351, &
+        0.0015519,  0.0015683,  0.0015843,  0.0016000,  0.0016153, &
+        0.0016302,  0.0016449,  0.0016592,  0.0016733,  0.0016871, &
+        0.0017007,  0.0017140,  0.0017271,  0.0017400,  0.0017526, &
+        0.0017651,  0.0017773,  0.0017894,  0.0018012,  0.0018129, &
+        0.0018245,  0.0018358,  0.0018471,  0.0018581,  0.0018690, &
+        0.0018798,  0.0018904,  0.0019009,  0.0019113,  0.0019215, &
+        0.0019316,  0.0019416,  0.0019515,  0.0019613,  0.0019709, &
+        0.0019805,  0.0019899/
+      data ((coa(i,j),i=1,62),j= 69, 69)/ &
+        0.0008823,  0.0009481,  0.0010059,  0.0010575,  0.0011042, &
+        0.0011468,  0.0011862,  0.0012227,  0.0012569,  0.0012891, &
+        0.0013195,  0.0013483,  0.0013757,  0.0014020,  0.0014271, &
+        0.0014512,  0.0014744,  0.0014968,  0.0015185,  0.0015395, &
+        0.0015598,  0.0015795,  0.0015987,  0.0016174,  0.0016356, &
+        0.0016533,  0.0016707,  0.0016876,  0.0017041,  0.0017203, &
+        0.0017362,  0.0017517,  0.0017669,  0.0017819,  0.0017965, &
+        0.0018109,  0.0018251,  0.0018390,  0.0018527,  0.0018661, &
+        0.0018793,  0.0018924,  0.0019052,  0.0019178,  0.0019303, &
+        0.0019425,  0.0019546,  0.0019665,  0.0019783,  0.0019899, &
+        0.0020014,  0.0020127,  0.0020238,  0.0020348,  0.0020457, &
+        0.0020565,  0.0020671,  0.0020776,  0.0020880,  0.0020983, &
+        0.0021084,  0.0021185/
+      data ((coa(i,j),i=1,62),j= 70, 70)/ &
+        0.0009546,  0.0010233,  0.0010834,  0.0011370,  0.0011854, &
+        0.0012297,  0.0012705,  0.0013085,  0.0013441,  0.0013776, &
+        0.0014093,  0.0014395,  0.0014682,  0.0014957,  0.0015221, &
+        0.0015475,  0.0015720,  0.0015956,  0.0016185,  0.0016406, &
+        0.0016621,  0.0016830,  0.0017033,  0.0017231,  0.0017424, &
+        0.0017613,  0.0017797,  0.0017976,  0.0018152,  0.0018324, &
+        0.0018493,  0.0018658,  0.0018820,  0.0018979,  0.0019135, &
+        0.0019288,  0.0019439,  0.0019587,  0.0019732,  0.0019875, &
+        0.0020016,  0.0020155,  0.0020291,  0.0020425,  0.0020558, &
+        0.0020688,  0.0020817,  0.0020944,  0.0021069,  0.0021192, &
+        0.0021314,  0.0021434,  0.0021095,  0.0021670,  0.0021786, &
+        0.0021900,  0.0022013,  0.0022125,  0.0022235,  0.0022344, &
+        0.0022452,  0.0022558/
+      data ((coa(i,j),i=1,62),j= 71, 71)/ &
+        0.0010302,  0.0011016,  0.0011640,  0.0012195,  0.0012698, &
+        0.0013159,  0.0013584,  0.0013981,  0.0014354,  0.0014705, &
+        0.0015038,  0.0015355,  0.0015658,  0.0015948,  0.0016227, &
+        0.0016496,  0.0016755,  0.0017005,  0.0017248,  0.0017483, &
+        0.0017712,  0.0017934,  0.0018150,  0.0018360,  0.0018566, &
+        0.0018766,  0.0018962,  0.0019153,  0.0019340,  0.0019524, &
+        0.0019703,  0.0019879,  0.0020052,  0.0020221,  0.0020387, &
+        0.0020550,  0.0020710,  0.0020867,  0.0021022,  0.0021174, &
+        0.0021324,  0.0021471,  0.0021159,  0.0021759,  0.0021900, &
+        0.0022039,  0.0022175,  0.0022310,  0.0022443,  0.0022574, &
+        0.0022703,  0.0022830,  0.0022956,  0.0023080,  0.0023203, &
+        0.0023324,  0.0023443,  0.0023562,  0.0023678,  0.0023794, &
+        0.0023908,  0.0024020/
+      data ((coa(i,j),i=1,62),j= 72, 72)/ &
+        0.0011087,  0.0011828,  0.0012476,  0.0013054,  0.0013579, &
+        0.0014060,  0.0014506,  0.0014923,  0.0015315,  0.0015685, &
+        0.0016038,  0.0016373,  0.0016694,  0.0017002,  0.0017298, &
+        0.0017583,  0.0017859,  0.0018125,  0.0018384,  0.0018634, &
+        0.0018877,  0.0019114,  0.0019344,  0.0019568,  0.0019787, &
+        0.0020000,  0.0020209,  0.0020412,  0.0020612,  0.0020807, &
+        0.0020998,  0.0021185,  0.0021368,  0.0021090,  0.0021725, &
+        0.0021898,  0.0022068,  0.0022235,  0.0022399,  0.0022561, &
+        0.0022720,  0.0022876,  0.0023029,  0.0023181,  0.0023330, &
+        0.0023477,  0.0023621,  0.0023764,  0.0023904,  0.0024042, &
+        0.0024179,  0.0024314,  0.0024446,  0.0024577,  0.0024707, &
+        0.0024834,  0.0024960,  0.0025085,  0.0025208,  0.0025329, &
+        0.0025449,  0.0025568/
+      data ((coa(i,j),i=1,62),j= 73, 73)/ &
+        0.0011902,  0.0012672,  0.0013347,  0.0013952,  0.0014502, &
+        0.0015008,  0.0015478,  0.0015919,  0.0016334,  0.0016727, &
+        0.0017101,  0.0017457,  0.0017799,  0.0018126,  0.0018442, &
+        0.0018746,  0.0019039,  0.0019323,  0.0019598,  0.0019865, &
+        0.0020124,  0.0020376,  0.0020621,  0.0020859,  0.0021092, &
+        0.0021319,  0.0021083,  0.0021757,  0.0021969,  0.0022176, &
+        0.0022379,  0.0022577,  0.0022772,  0.0022962,  0.0023149, &
+        0.0023333,  0.0023513,  0.0023690,  0.0023863,  0.0024034, &
+        0.0024202,  0.0024366,  0.0024529,  0.0024688,  0.0024845, &
+        0.0025000,  0.0025152,  0.0025302,  0.0025450,  0.0025595, &
+        0.0025739,  0.0025880,  0.0026019,  0.0026157,  0.0026293, &
+        0.0026426,  0.0026557,  0.0026689,  0.0026817,  0.0026944, &
+        0.0027070,  0.0027194/
+      data ((coa(i,j),i=1,62),j= 74, 74)/ &
+        0.0012749,  0.0013552,  0.0014259,  0.0014895,  0.0015475, &
+        0.0016010,  0.0016509,  0.0016977,  0.0017418,  0.0017836, &
+        0.0018234,  0.0018614,  0.0018978,  0.0019328,  0.0019664, &
+        0.0019987,  0.0020300,  0.0020602,  0.0020895,  0.0021179, &
+        0.0021454,  0.0021722,  0.0021982,  0.0022235,  0.0022482, &
+        0.0022723,  0.0022958,  0.0023187,  0.0023411,  0.0023630, &
+        0.0023844,  0.0024054,  0.0024259,  0.0024460,  0.0024658, &
+        0.0024851,  0.0025040,  0.0025226,  0.0025409,  0.0025588, &
+        0.0025764,  0.0025937,  0.0026107,  0.0026275,  0.0026439, &
+        0.0026601,  0.0026760,  0.0026917,  0.0027071,  0.0027223, &
+        0.0027373,  0.0027520,  0.0027665,  0.0027808,  0.0027950, &
+        0.0028089,  0.0028226,  0.0028361,  0.0028495,  0.0028627, &
+        0.0028757,  0.0028885/
+      data ((coa(i,j),i=1,62),j= 75, 75)/ &
+        0.0013631,  0.0014474,  0.0015220,  0.0015892,  0.0016507, &
+        0.0017076,  0.0017607,  0.0018105,  0.0018575,  0.0019021, &
+        0.0019445,  0.0019850,  0.0020238,  0.0020610,  0.0020967, &
+        0.0021312,  0.0021186,  0.0021965,  0.0022276,  0.0022577, &
+        0.0022868,  0.0023152,  0.0023427,  0.0023695,  0.0023956, &
+        0.0024210,  0.0024457,  0.0024699,  0.0024935,  0.0025165, &
+        0.0025390,  0.0025610,  0.0025826,  0.0026037,  0.0026243, &
+        0.0026445,  0.0026643,  0.0026838,  0.0027028,  0.0027215, &
+        0.0027399,  0.0027579,  0.0027756,  0.0027930,  0.0028101, &
+        0.0028269,  0.0028434,  0.0028596,  0.0028756,  0.0028913, &
+        0.0029068,  0.0029220,  0.0029370,  0.0029518,  0.0029664, &
+        0.0029807,  0.0029949,  0.0030088,  0.0030225,  0.0030361, &
+        0.0030494,  0.0030626/
+      data ((coa(i,j),i=1,62),j= 76, 76)/ &
+        0.0014557,  0.0015446,  0.0016236,  0.0016950,  0.0017605, &
+        0.0018211,  0.0018777,  0.0019308,  0.0019809,  0.0020284, &
+        0.0020736,  0.0021167,  0.0021121,  0.0021973,  0.0022353, &
+        0.0022718,  0.0023069,  0.0023409,  0.0023737,  0.0024055, &
+        0.0024362,  0.0024661,  0.0024950,  0.0025232,  0.0025506, &
+        0.0025772,  0.0026031,  0.0026284,  0.0026531,  0.0026771, &
+        0.0027006,  0.0027235,  0.0027460,  0.0027679,  0.0027893, &
+        0.0028103,  0.0028309,  0.0028510,  0.0028707,  0.0028900, &
+        0.0029090,  0.0029276,  0.0029458,  0.0029637,  0.0029813, &
+        0.0029986,  0.0030156,  0.0030322,  0.0030486,  0.0030647, &
+        0.0030806,  0.0030962,  0.0031115,  0.0031266,  0.0031414, &
+        0.0031560,  0.0031704,  0.0031846,  0.0031986,  0.0032123, &
+        0.0032259,  0.0032392/
+      data ((coa(i,j),i=1,62),j= 77, 77)/ &
+        0.0015532,  0.0016476,  0.0017317,  0.0018078,  0.0018775, &
+        0.0019422,  0.0020024,  0.0020590,  0.0021123,  0.0021169, &
+        0.0022106,  0.0022563,  0.0022999,  0.0023416,  0.0023817, &
+        0.0024202,  0.0024572,  0.0024929,  0.0025273,  0.0025607, &
+        0.0025929,  0.0026241,  0.0026543,  0.0026837,  0.0027122, &
+        0.0027399,  0.0027668,  0.0027931,  0.0028186,  0.0028435, &
+        0.0028678,  0.0028915,  0.0029146,  0.0029372,  0.0029592, &
+        0.0029808,  0.0030019,  0.0030225,  0.0030427,  0.0030625, &
+        0.0030819,  0.0031009,  0.0031195,  0.0031377,  0.0031556, &
+        0.0031732,  0.0031904,  0.0032073,  0.0032239,  0.0032402, &
+        0.0032563,  0.0032720,  0.0032875,  0.0033027,  0.0033177, &
+        0.0033324,  0.0033468,  0.0033611,  0.0033751,  0.0033889, &
+        0.0034025,  0.0034159/
+      data ((coa(i,j),i=1,62),j= 78, 78)/ &
+        0.0016566,  0.0017571,  0.0018467,  0.0019278,  0.0020021, &
+        0.0020708,  0.0021349,  0.0021949,  0.0022514,  0.0023047, &
+        0.0023554,  0.0024035,  0.0024494,  0.0024932,  0.0025352, &
+        0.0025755,  0.0026142,  0.0026515,  0.0026874,  0.0027220, &
+        0.0027555,  0.0027878,  0.0028191,  0.0028495,  0.0028789, &
+        0.0029075,  0.0029352,  0.0029621,  0.0029883,  0.0030138, &
+        0.0030387,  0.0030629,  0.0030864,  0.0031094,  0.0031319, &
+        0.0031538,  0.0031752,  0.0031961,  0.0032166,  0.0032365, &
+        0.0032561,  0.0032752,  0.0032940,  0.0033123,  0.0033303, &
+        0.0033479,  0.0033652,  0.0033821,  0.0033988,  0.0034151, &
+        0.0034310,  0.0034467,  0.0034622,  0.0034773,  0.0034922, &
+        0.0035068,  0.0035211,  0.0035353,  0.0035491,  0.0035628, &
+        0.0035762,  0.0035894/
+      data ((coa(i,j),i=1,62),j= 79, 79)/ &
+        0.0017664,  0.0018736,  0.0019689,  0.0020552,  0.0021342, &
+        0.0022071,  0.0022749,  0.0023383,  0.0023978,  0.0024539, &
+        0.0025070,  0.0025574,  0.0026054,  0.0026511,  0.0026948, &
+        0.0027366,  0.0027767,  0.0028153,  0.0028523,  0.0028880, &
+        0.0029224,  0.0029556,  0.0029877,  0.0030187,  0.0030487, &
+        0.0030778,  0.0031060,  0.0031334,  0.0031599,  0.0031857, &
+        0.0032108,  0.0032352,  0.0032590,  0.0032821,  0.0033047, &
+        0.0033267,  0.0033481,  0.0033690,  0.0033894,  0.0034094, &
+        0.0034289,  0.0034479,  0.0034665,  0.0034847,  0.0035025, &
+        0.0035200,  0.0035371,  0.0035538,  0.0035702,  0.0035862, &
+        0.0036020,  0.0036174,  0.0036325,  0.0036474,  0.0036620, &
+        0.0036763,  0.0036903,  0.0037041,  0.0037177,  0.0037310, &
+        0.0037441,  0.0037569/
+      data ((coa(i,j),i=1,62),j= 80, 80)/ &
+        0.0018832,  0.0019973,  0.0020987,  0.0021902,  0.0022737, &
+        0.0023505,  0.0024220,  0.0024885,  0.0025508,  0.0026093, &
+        0.0026646,  0.0027169,  0.0027666,  0.0028138,  0.0028589, &
+        0.0029018,  0.0029430,  0.0029824,  0.0030202,  0.0030565, &
+        0.0030915,  0.0031252,  0.0031576,  0.0031890,  0.0032192, &
+        0.0032485,  0.0032768,  0.0033042,  0.0033308,  0.0033566, &
+        0.0033816,  0.0034059,  0.0034295,  0.0034525,  0.0034748, &
+        0.0034966,  0.0035177,  0.0035384,  0.0035585,  0.0035781, &
+        0.0035972,  0.0036159,  0.0036341,  0.0036520,  0.0036694, &
+        0.0036864,  0.0037031,  0.0037193,  0.0037353,  0.0037509, &
+        0.0037662,  0.0037811,  0.0037958,  0.0038102,  0.0038243, &
+        0.0038381,  0.0038517,  0.0038650,  0.0038780,  0.0038908, &
+        0.0039034,  0.0039158/
+      data ((coa(i,j),i=1,62),j= 81, 81)/ &
+        0.0020072,  0.0021282,  0.0022356,  0.0023321,  0.0024200, &
+        0.0025006,  0.0025751,  0.0026443,  0.0027089,  0.0027695, &
+        0.0028265,  0.0028803,  0.0029311,  0.0029794,  0.0030252, &
+        0.0030689,  0.0031106,  0.0031504,  0.0031886,  0.0032251, &
+        0.0032602,  0.0032939,  0.0033263,  0.0033575,  0.0033876, &
+        0.0034166,  0.0034447,  0.0034718,  0.0034980,  0.0035234, &
+        0.0035480,  0.0035719,  0.0035950,  0.0036175,  0.0036393, &
+        0.0036605,  0.0036811,  0.0037012,  0.0037207,  0.0037398, &
+        0.0037583,  0.0037764,  0.0037940,  0.0038112,  0.0038280, &
+        0.0038444,  0.0038604,  0.0038761,  0.0038914,  0.0039063, &
+        0.0039210,  0.0039353,  0.0039494,  0.0039631,  0.0039766, &
+        0.0039898,  0.0040027,  0.0040154,  0.0040278,  0.0040400, &
+        0.0040520,  0.0040638/
+      data ((coa(i,j),i=1,62),j= 82, 82)/ &
+        0.0021381,  0.0022661,  0.0023791,  0.0024803,  0.0025719, &
+        0.0026557,  0.0027328,  0.0028041,  0.0028705,  0.0029325, &
+        0.0029905,  0.0030451,  0.0030966,  0.0031453,  0.0031914, &
+        0.0032353,  0.0032769,  0.0033166,  0.0033545,  0.0033908, &
+        0.0034255,  0.0034588,  0.0034907,  0.0035214,  0.0035509, &
+        0.0035793,  0.0036067,  0.0036331,  0.0036586,  0.0036833, &
+        0.0037071,  0.0037302,  0.0037526,  0.0037743,  0.0037953, &
+        0.0038157,  0.0038356,  0.0038548,  0.0038736,  0.0038916, &
+        0.0039095,  0.0039268,  0.0039436,  0.0039600,  0.0039761, &
+        0.0039917,  0.0040069,  0.0040218,  0.0040364,  0.0040506, &
+        0.0040645,  0.0040781,  0.0040914,  0.0041044,  0.0041172, &
+        0.0041296,  0.0041419,  0.0041539,  0.0041656,  0.0041772, &
+        0.0041885,  0.0041996/
+      data ((coa(i,j),i=1,62),j= 83, 83)/ &
+        0.0022756,  0.0024100,  0.0025280,  0.0026332,  0.0027280, &
+        0.0028142,  0.0028931,  0.0029658,  0.0030331,  0.0030957, &
+        0.0031541,  0.0032089,  0.0032603,  0.0033088,  0.0033545, &
+        0.0033978,  0.0034389,  0.0034780,  0.0035151,  0.0035506, &
+        0.0035844,  0.0036168,  0.0036478,  0.0036775,  0.0037061, &
+        0.0037335,  0.0037599,  0.0037853,  0.0038098,  0.0038335, &
+        0.0038563,  0.0038784,  0.0038998,  0.0039205,  0.0039405, &
+        0.0039599,  0.0039788,  0.0039971,  0.0040149,  0.0040322, &
+        0.0040490,  0.0040653,  0.0040813,  0.0040968,  0.0041119, &
+        0.0041267,  0.0041411,  0.0041552,  0.0041689,  0.0041823, &
+        0.0041954,  0.0042082,  0.0042208,  0.0042331,  0.0042451, &
+        0.0042569,  0.0042684,  0.0042797,  0.0042908,  0.0043017, &
+        0.0043123,  0.0043228/
+      data ((coa(i,j),i=1,62),j= 84, 84)/ &
+        0.0024185,  0.0025586,  0.0026808,  0.0027890,  0.0028859, &
+        0.0029735,  0.0030533,  0.0031264,  0.0031938,  0.0032562, &
+        0.0033142,  0.0033683,  0.0034190,  0.0034665,  0.0035113, &
+        0.0035535,  0.0035934,  0.0036313,  0.0036672,  0.0037014, &
+        0.0037340,  0.0037651,  0.0037948,  0.0038232,  0.0038505, &
+        0.0038767,  0.0039018,  0.0039260,  0.0039493,  0.0039717, &
+        0.0039934,  0.0040143,  0.0040345,  0.0040540,  0.0040730, &
+        0.0040913,  0.0041091,  0.0041264,  0.0041432,  0.0041595, &
+        0.0041753,  0.0041907,  0.0042057,  0.0042204,  0.0042346, &
+        0.0042485,  0.0042621,  0.0042754,  0.0042883,  0.0043009, &
+        0.0043133,  0.0043254,  0.0043372,  0.0043488,  0.0043601, &
+        0.0043712,  0.0043821,  0.0043928,  0.0044032,  0.0044135, &
+        0.0044236,  0.0044335/
+      data ((coa(i,j),i=1,62),j= 85, 85)/ &
+        0.0025653,  0.0027099,  0.0028350,  0.0029450,  0.0030428, &
+        0.0031307,  0.0032102,  0.0032828,  0.0033493,  0.0034106, &
+        0.0034673,  0.0035200,  0.0035692,  0.0036152,  0.0036583, &
+        0.0036990,  0.0037373,  0.0037735,  0.0038078,  0.0038404, &
+        0.0038714,  0.0039009,  0.0039291,  0.0039560,  0.0039818, &
+        0.0040065,  0.0040303,  0.0040531,  0.0040751,  0.0040962, &
+        0.0041166,  0.0041363,  0.0041553,  0.0041738,  0.0041916, &
+        0.0042089,  0.0042256,  0.0042419,  0.0042577,  0.0042730, &
+        0.0042879,  0.0043025,  0.0043166,  0.0043304,  0.0043439, &
+        0.0043570,  0.0043698,  0.0043823,  0.0043945,  0.0044064, &
+        0.0044181,  0.0044296,  0.0044407,  0.0044517,  0.0044624, &
+        0.0044730,  0.0044833,  0.0044934,  0.0045033,  0.0045130, &
+        0.0045226,  0.0045320/
+      data ((coa(i,j),i=1,62),j= 86, 86)/ &
+        0.0027124,  0.0028597,  0.0029861,  0.0030963,  0.0031936, &
+        0.0032805,  0.0033586,  0.0034295,  0.0034941,  0.0035534, &
+        0.0036081,  0.0036587,  0.0037058,  0.0037497,  0.0037908, &
+        0.0038294,  0.0038657,  0.0039000,  0.0039324,  0.0039631, &
+        0.0039923,  0.0040201,  0.0040467,  0.0040720,  0.0040963, &
+        0.0041195,  0.0041418,  0.0041633,  0.0041839,  0.0042038, &
+        0.0042230,  0.0042415,  0.0042594,  0.0042768,  0.0042935, &
+        0.0043098,  0.0043256,  0.0043409,  0.0043558,  0.0043703, &
+        0.0043844,  0.0043982,  0.0044115,  0.0044246,  0.0044373, &
+        0.0044497,  0.0044619,  0.0044737,  0.0044853,  0.0044966, &
+        0.0045077,  0.0045186,  0.0045292,  0.0045397,  0.0045499, &
+        0.0045599,  0.0045697,  0.0045793,  0.0045888,  0.0045981, &
+        0.0046072,  0.0046162/
+      data ((coa(i,j),i=1,62),j= 87, 87)/ &
+        0.0028481,  0.0029956,  0.0031209,  0.0032292,  0.0033241, &
+        0.0034083,  0.0034836,  0.0035515,  0.0036132,  0.0036696, &
+        0.0037214,  0.0037692,  0.0038136,  0.0038548,  0.0038934, &
+        0.0039296,  0.0039636,  0.0039956,  0.0040260,  0.0040547, &
+        0.0040820,  0.0041080,  0.0041328,  0.0041565,  0.0041792, &
+        0.0042010,  0.0042219,  0.0042419,  0.0042613,  0.0042800, &
+        0.0042980,  0.0043154,  0.0043322,  0.0043485,  0.0043643, &
+        0.0043796,  0.0043945,  0.0044090,  0.0044231,  0.0044367, &
+        0.0044501,  0.0044631,  0.0044757,  0.0044881,  0.0045001, &
+        0.0045119,  0.0045234,  0.0045347,  0.0045457,  0.0045564, &
+        0.0045670,  0.0045773,  0.0045874,  0.0045973,  0.0046070, &
+        0.0046166,  0.0046259,  0.0046351,  0.0046441,  0.0046530, &
+        0.0046616,  0.0046702/
+      data ((coa(i,j),i=1,62),j= 88, 88)/ &
+        0.0029341,  0.0030768,  0.0031968,  0.0032997,  0.0033892, &
+        0.0034681,  0.0035383,  0.0036014,  0.0036584,  0.0037104, &
+        0.0037581,  0.0038020,  0.0038427,  0.0038805,  0.0039159, &
+        0.0039490,  0.0039801,  0.0040095,  0.0040373,  0.0040637, &
+        0.0040888,  0.0041127,  0.0041355,  0.0041573,  0.0041782, &
+        0.0041983,  0.0042175,  0.0042361,  0.0042540,  0.0042713, &
+        0.0042880,  0.0043041,  0.0043197,  0.0043349,  0.0043495, &
+        0.0043638,  0.0043777,  0.0043911,  0.0044042,  0.0044170, &
+        0.0044294,  0.0044416,  0.0044534,  0.0044649,  0.0044762, &
+        0.0044872,  0.0044980,  0.0045085,  0.0045188,  0.0045289, &
+        0.0045387,  0.0045484,  0.0045579,  0.0045672,  0.0045763, &
+        0.0045852,  0.0045940,  0.0046026,  0.0046110,  0.0046193, &
+        0.0046275,  0.0046355/
+      data ((coa(i,j),i=1,62),j= 89, 89)/ &
+        0.0029122,  0.0030427,  0.0031513,  0.0032438,  0.0033237, &
+        0.0033938,  0.0034559,  0.0035116,  0.0035619,  0.0036076, &
+        0.0036495,  0.0036882,  0.0037238,  0.0037573,  0.0037884, &
+        0.0038176,  0.0038451,  0.0038711,  0.0038957,  0.0039191, &
+        0.0039413,  0.0039626,  0.0039829,  0.0040023,  0.0040209, &
+        0.0040389,  0.0040561,  0.0040727,  0.0040887,  0.0041042, &
+        0.0041192,  0.0041337,  0.0041477,  0.0041613,  0.0041745, &
+        0.0041874,  0.0041998,  0.0042120,  0.0042238,  0.0042353, &
+        0.0042465,  0.0042574,  0.0042681,  0.0042785,  0.0042887, &
+        0.0042986,  0.0043084,  0.0043179,  0.0043272,  0.0043363, &
+        0.0043452,  0.0043539,  0.0043625,  0.0043709,  0.0043791, &
+        0.0043872,  0.0043951,  0.0044029,  0.0044105,  0.0044180, &
+        0.0044254,  0.0044326/
+      data ((coa(i,j),i=1,62),j= 90, 90)/ &
+        0.0027405,  0.0028512,  0.0029426,  0.0030199,  0.0030864, &
+        0.0031447,  0.0031962,  0.0032424,  0.0032841,  0.0033221, &
+        0.0033569,  0.0033891,  0.0034190,  0.0034468,  0.0034729, &
+        0.0034974,  0.0035206,  0.0035424,  0.0035632,  0.0035830, &
+        0.0036018,  0.0036198,  0.0036370,  0.0036535,  0.0036694, &
+        0.0036847,  0.0036993,  0.0037135,  0.0037272,  0.0037404, &
+        0.0037532,  0.0037656,  0.0037776,  0.0037892,  0.0038005, &
+        0.0038115,  0.0038222,  0.0038326,  0.0038427,  0.0038526, &
+        0.0038622,  0.0038716,  0.0038808,  0.0038897,  0.0038984, &
+        0.0039070,  0.0039153,  0.0039235,  0.0039314,  0.0039393, &
+        0.0039469,  0.0039544,  0.0039618,  0.0039690,  0.0039761, &
+        0.0039830,  0.0039898,  0.0039965,  0.0040030,  0.0040095, &
+        0.0040158,  0.0040220/
+      data ((coa(i,j),i=1,62),j= 91, 91)/ &
+        0.0024633,  0.0025514,  0.0026239,  0.0026851,  0.0027377, &
+        0.0027838,  0.0028247,  0.0028613,  0.0028946,  0.0029249, &
+        0.0029529,  0.0029787,  0.0030028,  0.0030253,  0.0030464, &
+        0.0030663,  0.0030851,  0.0031029,  0.0031199,  0.0031360, &
+        0.0031514,  0.0031661,  0.0031803,  0.0031938,  0.0032068, &
+        0.0032194,  0.0032314,  0.0032431,  0.0032544,  0.0032652, &
+        0.0032758,  0.0032860,  0.0032959,  0.0033055,  0.0033148, &
+        0.0033239,  0.0033327,  0.0033413,  0.0033497,  0.0033578, &
+        0.0033658,  0.0033735,  0.0033811,  0.0033885,  0.0033957, &
+        0.0034028,  0.0034097,  0.0034164,  0.0034230,  0.0034295, &
+        0.0034359,  0.0034421,  0.0034482,  0.0034541,  0.0034600, &
+        0.0034657,  0.0034714,  0.0034769,  0.0034823,  0.0034877, &
+        0.0034929,  0.0034981/
+      data ((coa(i,j),i=1,62),j= 92, 92)/ &
+        0.0021142,  0.0022278,  0.0022837,  0.0023309,  0.0023717, &
+        0.0024075,  0.0024394,  0.0024681,  0.0024943,  0.0025182, &
+        0.0025404,  0.0025609,  0.0025801,  0.0025980,  0.0026149, &
+        0.0026308,  0.0026459,  0.0026602,  0.0026738,  0.0026868, &
+        0.0026992,  0.0027111,  0.0027225,  0.0027334,  0.0027439, &
+        0.0027541,  0.0027638,  0.0027733,  0.0027824,  0.0027912, &
+        0.0027997,  0.0028080,  0.0028160,  0.0028238,  0.0028314, &
+        0.0028387,  0.0028459,  0.0028529,  0.0028597,  0.0028663, &
+        0.0028727,  0.0028791,  0.0028852,  0.0028912,  0.0028971, &
+        0.0029028,  0.0029084,  0.0029139,  0.0029193,  0.0029246, &
+        0.0029297,  0.0029348,  0.0029398,  0.0029446,  0.0029494, &
+        0.0029541,  0.0029587,  0.0029632,  0.0029676,  0.0029720, &
+        0.0029761,  0.0029805/
+      data ((coa(i,j),i=1,62),j= 93, 93)/ &
+        0.0018726,  0.0019238,  0.0019660,  0.0020019,  0.0020331, &
+        0.0020606,  0.0020852,  0.0021074,  0.0021278,  0.0021464, &
+        0.0021179,  0.0021798,  0.0021948,  0.0022089,  0.0022221, &
+        0.0022347,  0.0022466,  0.0022578,  0.0022686,  0.0022789, &
+        0.0022887,  0.0022981,  0.0023071,  0.0023158,  0.0023241, &
+        0.0023321,  0.0023399,  0.0023474,  0.0023546,  0.0023616, &
+        0.0023684,  0.0023750,  0.0023814,  0.0023876,  0.0023936, &
+        0.0023995,  0.0024052,  0.0024108,  0.0024162,  0.0024215, &
+        0.0024266,  0.0024317,  0.0024366,  0.0024414,  0.0024461, &
+        0.0024507,  0.0024552,  0.0024596,  0.0024639,  0.0024681, &
+        0.0024722,  0.0024763,  0.0024802,  0.0024841,  0.0024880, &
+        0.0024917,  0.0024954,  0.0024990,  0.0025026,  0.0025060, &
+        0.0025095,  0.0025129/
+      data ((coa(i,j),i=1,62),j= 94, 94)/ &
+        0.0016337,  0.0016718,  0.0017033,  0.0017303,  0.0017537, &
+        0.0017745,  0.0017931,  0.0018100,  0.0018254,  0.0018397, &
+        0.0018529,  0.0018651,  0.0018766,  0.0018874,  0.0018976, &
+        0.0019073,  0.0019164,  0.0019251,  0.0019334,  0.0019413, &
+        0.0019489,  0.0019562,  0.0019631,  0.0019698,  0.0019763, &
+        0.0019825,  0.0019885,  0.0019944,  0.0020000,  0.0020054, &
+        0.0020107,  0.0020158,  0.0020208,  0.0020256,  0.0020303, &
+        0.0020349,  0.0020394,  0.0020437,  0.0020479,  0.0020521, &
+        0.0020561,  0.0020600,  0.0020639,  0.0020676,  0.0020713, &
+        0.0020749,  0.0020784,  0.0020819,  0.0020852,  0.0020886, &
+        0.0020918,  0.0020950,  0.0020981,  0.0021011,  0.0021041, &
+        0.0021071,  0.0021100,  0.0021128,  0.0021156,  0.0021183, &
+        0.0021210,  0.0021236/
+      data ((coa(i,j),i=1,62),j= 95, 95)/ &
+        0.0014740,  0.0015024,  0.0015259,  0.0015460,  0.0015636, &
+        0.0015791,  0.0015931,  0.0016058,  0.0016174,  0.0016282, &
+        0.0016381,  0.0016474,  0.0016561,  0.0016643,  0.0016720, &
+        0.0016793,  0.0016863,  0.0016929,  0.0016992,  0.0017052, &
+        0.0017110,  0.0017165,  0.0017219,  0.0017270,  0.0017319, &
+        0.0017367,  0.0017413,  0.0017458,  0.0017501,  0.0017543, &
+        0.0017584,  0.0017623,  0.0017661,  0.0017699,  0.0017735, &
+        0.0017770,  0.0017804,  0.0017838,  0.0017870,  0.0017902, &
+        0.0017933,  0.0017964,  0.0017993,  0.0018023,  0.0018051, &
+        0.0018079,  0.0018106,  0.0018132,  0.0018158,  0.0018184, &
+        0.0018209,  0.0018233,  0.0018258,  0.0018281,  0.0018304, &
+        0.0018327,  0.0018349,  0.0018371,  0.0018393,  0.0018414, &
+        0.0018434,  0.0018455/
+      data ((coa(i,j),i=1,62),j= 96, 96)/ &
+        0.0013895,  0.0014110,  0.0014289,  0.0014441,  0.0014574, &
+        0.0014692,  0.0014798,  0.0014894,  0.0014982,  0.0015064, &
+        0.0015139,  0.0015210,  0.0015277,  0.0015338,  0.0015398, &
+        0.0015454,  0.0015508,  0.0015558,  0.0015607,  0.0015653, &
+        0.0015698,  0.0015740,  0.0015782,  0.0015821,  0.0015859, &
+        0.0015896,  0.0015932,  0.0015966,  0.0016000,  0.0016032, &
+        0.0016064,  0.0016094,  0.0016124,  0.0016153,  0.0016181, &
+        0.0016208,  0.0016235,  0.0016261,  0.0016286,  0.0016311, &
+        0.0016335,  0.0016358,  0.0016381,  0.0016404,  0.0016426, &
+        0.0016447,  0.0016468,  0.0016489,  0.0016509,  0.0016529, &
+        0.0016548,  0.0016567,  0.0016586,  0.0016604,  0.0016622, &
+        0.0016639,  0.0016657,  0.0016673,  0.0016690,  0.0016706, &
+        0.0016722,  0.0016738/
+      data ((coa(i,j),i=1,62),j= 97, 97)/ &
+        0.0013502,  0.0013669,  0.0013807,  0.0013924,  0.0014027, &
+        0.0014118,  0.0014200,  0.0014274,  0.0014343,  0.0014406, &
+        0.0014465,  0.0014520,  0.0014571,  0.0014620,  0.0014666, &
+        0.0014710,  0.0014751,  0.0014791,  0.0014829,  0.0014865, &
+        0.0014900,  0.0014933,  0.0014966,  0.0014997,  0.0015027, &
+        0.0015055,  0.0015083,  0.0015109,  0.0015136,  0.0015162, &
+        0.0015186,  0.0015210,  0.0015234,  0.0015256,  0.0015278, &
+        0.0015299,  0.0015320,  0.0015340,  0.0015360,  0.0015380, &
+        0.0015398,  0.0015417,  0.0015435,  0.0015452,  0.0015469, &
+        0.0015486,  0.0015503,  0.0015519,  0.0015534,  0.0015550, &
+        0.0015565,  0.0015580,  0.0015594,  0.0015608,  0.0015622, &
+        0.0015636,  0.0015649,  0.0015663,  0.0015676,  0.0015688, &
+        0.0015701,  0.0015713/
+      data ((coa(i,j),i=1,62),j= 98, 98)/ &
+        0.0013341,  0.0013476,  0.0013588,  0.0013683,  0.0013766, &
+        0.0013840,  0.0013907,  0.0013967,  0.0014023,  0.0014074, &
+        0.0014122,  0.0014167,  0.0014209,  0.0014248,  0.0014286, &
+        0.0014321,  0.0014355,  0.0014387,  0.0014418,  0.0014447, &
+        0.0014476,  0.0014503,  0.0014529,  0.0014554,  0.0014578, &
+        0.0014602,  0.0014624,  0.0014646,  0.0014667,  0.0014688, &
+        0.0014708,  0.0014727,  0.0014746,  0.0014764,  0.0014782, &
+        0.0014799,  0.0014816,  0.0014833,  0.0014849,  0.0014864, &
+        0.0014879,  0.0014894,  0.0014909,  0.0014923,  0.0014937, &
+        0.0014950,  0.0014964,  0.0014977,  0.0014989,  0.0015002, &
+        0.0015014,  0.0015026,  0.0015038,  0.0015049,  0.0015060, &
+        0.0015071,  0.0015082,  0.0015093,  0.0015103,  0.0015114, &
+        0.0015124,  0.0015134/
+      data ((coa(i,j),i=1,62),j= 99, 99)/ &
+        0.0013255,  0.0013373,  0.0013470,  0.0013554,  0.0013626, &
+        0.0013691,  0.0013749,  0.0013803,  0.0013851,  0.0013896, &
+        0.0013938,  0.0013977,  0.0014014,  0.0014049,  0.0014082, &
+        0.0014113,  0.0014142,  0.0014171,  0.0014197,  0.0014223, &
+        0.0014248,  0.0014272,  0.0014294,  0.0014316,  0.0014337, &
+        0.0014358,  0.0014378,  0.0014397,  0.0014415,  0.0014433, &
+        0.0014450,  0.0014467,  0.0014483,  0.0014499,  0.0014515, &
+        0.0014530,  0.0014544,  0.0014559,  0.0014573,  0.0014586, &
+        0.0014599,  0.0014612,  0.0014625,  0.0014637,  0.0014649, &
+        0.0014661,  0.0014672,  0.0014684,  0.0014695,  0.0014705, &
+        0.0014716,  0.0014726,  0.0014736,  0.0014746,  0.0014756, &
+        0.0014766,  0.0014775,  0.0014784,  0.0014793,  0.0014802, &
+        0.0014811,  0.0014820/
+      data ((coa(i,j),i=1,62),j=100,100)/ &
+        0.0013126,  0.0013234,  0.0013324,  0.0013401,  0.0013469, &
+        0.0013529,  0.0013583,  0.0013632,  0.0013677,  0.0013719, &
+        0.0013758,  0.0013795,  0.0013829,  0.0013861,  0.0013891, &
+        0.0013920,  0.0013947,  0.0013974,  0.0013998,  0.0014022, &
+        0.0014045,  0.0014067,  0.0014088,  0.0014108,  0.0014127, &
+        0.0014146,  0.0014164,  0.0014181,  0.0014198,  0.0014215, &
+        0.0014230,  0.0014246,  0.0014261,  0.0014275,  0.0014289, &
+        0.0014303,  0.0014316,  0.0014329,  0.0014341,  0.0014354, &
+        0.0014366,  0.0014377,  0.0014389,  0.0014400,  0.0014411, &
+        0.0014421,  0.0014432,  0.0014442,  0.0014452,  0.0014462, &
+        0.0014471,  0.0014480,  0.0014490,  0.0014499,  0.0014507, &
+        0.0014516,  0.0014525,  0.0014533,  0.0014541,  0.0014549, &
+        0.0014557,  0.0014565/
+      data ((coa(i,j),i=1,62),j=101,101)/ &
+        0.0012882,  0.0012983,  0.0013066,  0.0013138,  0.0013202, &
+        0.0013258,  0.0013309,  0.0013355,  0.0013398,  0.0013437, &
+        0.0013473,  0.0013507,  0.0013539,  0.0013569,  0.0013598, &
+        0.0013625,  0.0013650,  0.0013674,  0.0013697,  0.0013719, &
+        0.0013740,  0.0013760,  0.0013780,  0.0013798,  0.0013816, &
+        0.0013833,  0.0013850,  0.0013865,  0.0013881,  0.0013896, &
+        0.0013910,  0.0013924,  0.0013938,  0.0013951,  0.0013963, &
+        0.0013976,  0.0013988,  0.0013999,  0.0014011,  0.0014022, &
+        0.0014033,  0.0014043,  0.0014054,  0.0014064,  0.0014073, &
+        0.0014083,  0.0014092,  0.0014101,  0.0014110,  0.0014119, &
+        0.0014128,  0.0014136,  0.0014145,  0.0014153,  0.0014161, &
+        0.0014168,  0.0014176,  0.0014183,  0.0014191,  0.0014198, &
+        0.0014205,  0.0014212/
+
+!-----
+      do i=1,m
+         swh(i,1)=0.
+         so2(i,1)=0.
+!-----snt is the secant of the solar zenith angle
+!
+         snt(i)=1.0  /cosz(i)
+      enddo
+
+
+      do k=1,np
+       do i=1,m
+!
+!-----compute layer thickness. indices for the surface level and
+!     surface layer are np+1 and np, respectively.
+          dp(i,k)=pl(i,k+1)-pl(i,k)
+!
+!-----compute scaled water vapor amount following eqs. (3.3) and (3.5)
+!     unit is g/cm**2
+!
+          scal(i,k)=dp(i,k)*(.5*(pl(i,k)+pl(i,k+1))/300.)**.8
+          wh(i,k)=1.02*wa(i,k)*scal(i,k) &
+                    *(1.+0.00135*(ta(i,k)-240.)) +1.e-11
+          swh(i,k+1)=swh(i,k)+wh(i,k)
+!-----compute ozone amount, unit is (cm-atm)stp
+!     the number 466.7 is the unit conversion factor
+!     from g/cm**2 to (cm-atm)stp
+          oh(i,k)=1.02*oa(i,k)*dp(i,k)*466.7 +1.e-11
+!-----compute layer cloud water amount (gm/m**2)
+!     the index is 1 for ice crystals, 2 for liquid drops, and
+!     3 for rain drops
+          x=1.02*10000.*dp(i,k)
+          cwp(i,k,1)=x*cwc(i,k,1)
+          cwp(i,k,2)=x*cwc(i,k,2)
+          cwp(i,k,3)=x*cwc(i,k,3)
+       enddo
+      enddo
+
+
+!-----initialize fluxes for all-sky (flx), clear-sky (flc), and
+!     flux reduction (df)
+      do k=1,np+1
+       do i=1,m
+          flx(i,k)=0.
+          flc(i,k)=0.
+          flxu(i,k)=0.
+          flxd(i,k)=0.
+          df(i,k)=0.
+          df_sub(i,k)=0.
+          df_cld(i,k)=0.
+          df_clr(i,k)=0.
+       enddo
+      enddo
+
+
+!-----compute solar uv and par fluxes
+!ccshie 9/18/04
+      call sw_uvpar (m,np,wh,oh,dp, &
+                  cwp,taucld,reff,ict,icb,fcld,cosz, &
+                  taual,ssaal,asyal,taux,rsuvbm,rsuvdf, &
+                  flx,flc,flxd,fdiruv,fdifuv,fdirpar,fdifpar)
+!-----compute and update solar ir fluxes
+      call sw_ir (m,np,wh,dp, &
+                  cwp,taucld,reff,ict,icb,fcld,cosz, &
+                  taual,ssaal,asyal,rsirbm,rsirdf, &
+                  flx,flc,flxd,fdirir,fdifir)
+
+!-----compute pressure-scaled o2 amount following eq. (3.5) with
+!     f=1. unit is (cm-atm)stp.
+!     the constant 165.22 equals (1000/980)*23.14%*(22400/32)
+       do i= 1, m
+        cnt(i)=165.22*snt(i)
+       enddo
+      do k=1,np
+       do i=1,m
+          so2(i,k+1)=so2(i,k)+scal(i,k)*cnt(i)
+       enddo
+      enddo
+!-----compute flux reduction due to o2 following eq. (3.18)
+!     the constant 0.0633 is the fraction of insolation contained
+!     in the oxygen bands 
+       do k= 2, np+1
+        do i= 1, m
+          x=so2(i,k)
+          df(i,k)=0.0633*(1.-exp(-0.000145*sqrt(x)))
+
+        enddo
+       enddo
+
+!-----for solar heating due to co2
+       do i= 1, m
+        cnt(i)=co2*snt(i)
+       enddo
+!-----scale co2 amounts following eq. (3.5) with f=1.
+!     unit is (cm-atm)stp.
+!     the constant 789 equals (1000/980)*(44/28.97)*(22400/44)
+      do k=1,np
+       do i=1,m
+         x=789.*cnt(i)
+         so2(i,k+1)=so2(i,k)+x*scal(i,k)+1.e-11
+       enddo
+      enddo
+!-----for co2 absorption in band 10 where absorption due to
+!     water vapor and co2 are both moderate
+        u1=-3.0
+        du=0.15
+        w1=-4.0
+        dw=0.15
+!-----so2 and swh are the co2 and water vapor amounts integrated
+!     from the top of the atmosphere
+      do k= 2, np+1
+       do i= 1, m
+        swu(i,k)=log10(so2(i,k))
+        swh(i,k)=log10(swh(i,k)*snt(i))
+       enddo
+      enddo
+!-----df is the updated flux reduction given by the second term on the
+!     right-hand-side of eq. (3.24) divided by so
+        call reduce_flux(m,np,swu,u1,du,nu,swh,w1,dw,nw,cah,df)
+!-----for co2 absorption in band 11 where the co2 absorption has
+!     a large impact on the heating of middle atmosphere.
+        u1=0.000250
+        du=0.000050
+        w1=-2.0
+        dw=0.05
+        do i= 1, m
+         swu(i,1)=co2*snt(i)
+        enddo
+!-----co2 mixing ratio is independent of space (spatially homogeneous)
+        do k= 2, np+1
+         do i= 1, m
+          swu(i,k)=swu(i,1)
+         enddo
+        enddo
+!-----swh is the logarithm of pressure
+       do k= 2, np+1
+        do i= 1, m
+          swh(i,k)=log10(pl(i,k))
+        enddo
+       enddo
+!-----df is the updated flux reduction derived from the table given by
+!     eq. (3.19)
+        call reduce_flux(m,np,swu,u1,du,nx2,swh,w1,dw,ny2,coa,df)
+
+! compute layer sub df (also filter negative values)
+   do i=1,m 
+      do k = 2, np+1
+         df_sub(i,k) = max(df(i,k) - df(i,k-1), 0._fp_kind)  !df for each layer (remove negative df_sub) 
+      enddo
+   enddo
+
+! compute clear-sky df
+   do i=1,m
+      do k = 2, np+1
+         df_clr(i,k) = df_clr(i,k-1)+df_sub(i,k)  
+      enddo
+   enddo
+
+!-----adjustment for the effect of o2 cnd co2 on clear-sky fluxes.
+!     both flc and df_clr are positive quantities
+       do k=1,np+1
+         do i=1,m
+          flc(i,k)=max(flc(i,k)-df_clr(i,k),0._fp_kind)  !this filter is for small cosine zenith angle.
+         enddo
+       enddo
+
+!-----identify top cloud-layer
+
+       do i= 1, m
+         nctop(i)=np+1
+       enddo
+
+       do k=1,np
+        do i= 1, m
+         if (fcld(i,k).gt.fcld_min .and. nctop(i).eq.np+1) then
+          nctop(i)=k
+         endif
+        enddo
+       enddo
+
+! adjust df_sub for below cloud
+       do i= 1,m
+         ntop=nctop(i) 
+         if(overcast .and. fast_overcast) then !compute cloud albedo
+!           cld_alb = sum(taux(i,ntop+1:np+1))/(6.7+sum(taux(i,ntop+1:np+1)))
+           cld_alb = sum(taux(i,ntop+1:np))/(6.7+sum(taux(i,ntop+1:np)))
+         endif
+        if (ntop.lt.np+1) then
+         do k= ntop+1,np+1 !cloud top -> surface
+          if(overcast .and. fast_overcast) then  !use ratio in LUT
+            i_cos = int(cosz(i)*10.)+1 !1~10
+            i_tau = int(cld_alb*10.)+1 !1~10
+            ratio = ratio_lut(i_tau,i_cos)
+          else !use computed clear and cloudy flux ratio (not fast_overcast)
+            ratio = max(0.01_fp_kind, min(1._fp_kind,(flx(i,k)/flc(i,k))))
+          endif
+          df_sub(i,k)  = df_sub(i,k)*ratio  !compute cloudy-sky df_sub
+         enddo !k
+        endif
+       enddo !i
+
+!update df for cloudy-sky
+   do i=1,m
+      do k = 2, np+1
+         df_cld(i,k) = df_cld(i,k-1)+df_sub(i,k) 
+      enddo
+   enddo
+
+!-----adjustment for the effect of o2 cnd co2 on all-sky fluxes.
+!      max statement filter negative value in flx for small cosz (for df_cld > flx)
+   do i=1,m
+      do k = 1, np+1
+         flx(i,k)  = max(flx(i,k)-df_cld(i,k) , 0._fp_kind)  !this max is for small cosz
+         flxd(i,k) = max(flxd(i,k)-df_cld(i,k), 0._fp_kind)  !this max is for small cosz
+         flxu(i,k) = flx(i,k)-flxd(i,k)
+      enddo 
+    enddo
+
+!-----adjustment for the direct downward flux
+       do i= 1,m
+        fdirir(i)=fdirir(i)-df_cld(i,np+1)
+        if (fdirir(i) .lt. 0.0) fdirir(i)=0.0
+       enddo
+
+      return
+
+      end subroutine swrad
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine sw_uvpar (m,np,wh,oh,dp, &
+                cwp,taucld,reff,ict,icb,fcld,cosz, &
+                taual,ssaal,asyal,taux,rsuvbm,rsuvdf, &
+                flx,flc,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 (m)                          n/d         1
+!  number of atmospheric layers (np)                n/d         1
+!  layer scaled-water vapor content (wh)          gm/cm^2      m*np
+!  layer ozone content (oh)                      (cm-atm)stp   m*np
+!  layer pressure thickness (dp)                    mb         m*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*np*3
+!        index 1 for ice particles
+!        index 2 for liquid drops
+!        index 3 for rain drops
+!  cloud optical thickness (taucld)                 n/d        m*np*3
+!       index 1 for ice particles
+!       index 2 for liquid drops
+!       index 3 for rain drops
+!  effective cloud-particle size (reff)          micrometer    m*np*3
+!       index 1 for ice paticles
+!       index 2 for liquid drops
+!       index 3 for rain drops
+!  level index separating high and                  n/d        m
+!       middle clouds (ict)
+!  level indiex separating middle and               n/d        m
+!       low clouds (icb)
+!  cloud amount (fcld)                            fraction     m*np
+!  cosine of solar zenith angle (cosz)              n/d        m
+!  aerosol optical thickness (taual)                n/d        m*np*11
+!  aerosol single-scattering albedo (ssaal)         n/d        m*np*11
+!  aerosol asymmetry factor (asyal)                 n/d        m*np*11
+!  uv+par surface albedo for beam                 fraction     m
+!       radiation (rsuvbm)
+!  uv+par surface albedo for diffuse              fraction     m
+!       radiation (rsuvdf)
+!
+!---- temporary array
+!
+!  scaled cloud optical thickness                   n/d        m*np
+!       for beam radiation (tauclb)
+!  scaled cloud optical thickness                   n/d        m*np
+!       for diffuse radiation  (tauclf)
+!
+!----- output (updated) parameters:
+!
+!  all-sky flux divergence (downward-upward) (flx)               fraction      m*(np+1)
+!  clear-sky flux divergence (downward-upward) (flc)             fraction      m*(np+1)
+!  all-sky direct downward uv flux at
+!       the surface (fdiruv)                     fraction      m
+!  all-sky diffuse downward uv flux at
+!       the surface (fdifuv)                     fraction      m
+!  all-sky direct downward par flux at
+!       the surface (fdirpar)                    fraction      m
+!  all-sky diffuse downward par flux at
+!       the surface (fdifpar)                    fraction      m
+!
+!***********************************************************************
+!ccshie 8/19/04
+     implicit none
+!-----input parameters
+      integer m,np,ict(m),icb(m)
+      real(Kind=fp_kind) taucld(m,np,3),reff(m,np,3),fcld(m,np)
+      real(Kind=fp_kind) cwp(m,np,3),wh(m,np),oh(m,np),dp(m,np)
+      real(Kind=fp_kind) taual(m,np,ib_sw),ssaal(m,np,ib_sw),asyal(m,np,ib_sw)
+      real(Kind=fp_kind) rsuvbm(m),rsuvdf(m),cosz(m)
+!-----output (updated) parameter
+      real(Kind=fp_kind) flx(m,np+1),flc(m,np+1)
+      real(Kind=fp_kind) flxd(m,np+1)
+      real(Kind=fp_kind) fdiruv (m),fdifuv (m)
+      real(Kind=fp_kind) fdirpar(m),fdifpar(m)
+      real(Kind=fp_kind) taux(m,np)
+!-----static parameters
+      integer nband
+      parameter (nband=8)
+      real(Kind=fp_kind) hk(nband),wk(nband),zk(nband),ry(nband)
+      real(Kind=fp_kind) aig(3),awg(3),arg(3)
+      real(Kind=fp_kind) aib(2),awb(2),arb(2)
+!-----temporary array
+      integer i,k,ib
+      integer ih1,ih2,im1,im2,is1,is2
+      real(Kind=fp_kind) taurs,tauoz,tauwv
+      real(Kind=fp_kind) :: g1,g2,g3
+      real(Kind=fp_kind) :: dsm(m)
+      real(Kind=fp_kind) :: tauclb(m,np)
+      real(Kind=fp_kind) :: tauclf(m,np)
+      real(Kind=fp_kind) :: asycl(m,np)
+      real(Kind=fp_kind) :: tausto(m,np)
+      real(Kind=fp_kind) :: ssatau(m,np)
+      real(Kind=fp_kind) :: asysto(m,np)
+      real(Kind=fp_kind) :: tautob(m,np)
+      real(Kind=fp_kind) :: ssatob(m,np)
+      real(Kind=fp_kind) :: asytob(m,np)
+      real(Kind=fp_kind) :: tautof(m,np)
+      real(Kind=fp_kind) :: ssatof(m,np)
+      real(Kind=fp_kind) :: asytof(m,np)
+      real(Kind=fp_kind) :: rr(m,np+1,2)
+      real(Kind=fp_kind) :: tt(m,np+1,2)
+      real(Kind=fp_kind) :: td(m,np+1,2)
+      real(Kind=fp_kind) :: rs(m,np+1,2)
+      real(Kind=fp_kind) :: ts(m,np+1,2)
+      real(Kind=fp_kind) :: fall(m,np+1)
+      real(Kind=fp_kind) :: falld(m,np+1)
+      real(Kind=fp_kind) :: fclr(m,np+1)
+      real(Kind=fp_kind) :: fsdir(m)
+      real(Kind=fp_kind) :: fsdif(m)
+      real(Kind=fp_kind) :: asyclt(m)
+      real(Kind=fp_kind) :: cc(m,3)
+      real(Kind=fp_kind) :: rrt(m,np)
+      real(Kind=fp_kind) :: ttt(m,np)
+      real(Kind=fp_kind) :: tdt(m,np)
+      real(Kind=fp_kind) :: rst(m,np)
+      real(Kind=fp_kind) :: tst(m,np)
+      real(Kind=fp_kind) :: dum1(m,np+1)
+      real(Kind=fp_kind) :: dum2(m)
+      real(Kind=fp_kind) :: dum3(m)
+      real(Kind=fp_kind) :: dum(m,np)
+!-----hk is the fractional extra-terrestrial solar flux in each
+!     of the 8 bands. the sum of hk is 0.47074. (table 3)
+      data hk/.00057, .00367, .00083, .00417, &
+              .00600, .00556, .05913, .39081/
+!-----zk is the ozone absorption coefficient. unit: /(cm-atm)stp
+!     (table 3)
+      data zk /30.47, 187.2,  301.9,   42.83, &
+               7.09,  1.25,   0.0345,  0.0572/
+!-----wk is the water vapor absorption coefficient. unit: cm**2/g
+!     (table 3)
+      data wk /7*0.0, 0.00075/
+!-----ry is the extinction coefficient for rayleigh scattering.
+!     unit: /mb. (table 3)
+      data ry /.00604, .00170, .00222, .00132, &
+               .00107, .00091, .00055, .00012/
+!-----coefficients for computing the extinction coefficients of ice,
+!     water, and rain particles, independent of spectral band. (table 4)
+      data aib/ 3.33e-4,2.52/
+      data awb/-6.59e-3,1.65/
+      data arb/ 3.07e-3,0.00/
+!-----coefficients for computing the asymmetry factor of ice, water,
+!     and rain particles, independent of spectral band. (table 6)
+      data aig/.74625,.0010541,-.00000264/
+      data awg/.82562,.0052900,-.00014866/
+      data arg/.883,0.0,0.0/
+!-----initialize fdiruv, fdifuv, surface reflectances and transmittances.
+!     the reflectance and transmittance of the clear and cloudy portions
+!     of a layer are denoted by 1 and 2, respectively.
+!     cc is the maximum cloud cover in each of the high, middle, and low
+!     cloud groups.
+!     1/dsm=1/cos(53) = 1.66
+      do i=1,m
+         dsm(i)=0.602
+         fdiruv(i)=0.0
+         fdifuv(i)=0.0
+         rr(i,np+1,1)=rsuvbm(i)
+         rr(i,np+1,2)=rsuvbm(i)
+         rs(i,np+1,1)=rsuvdf(i)
+         rs(i,np+1,2)=rsuvdf(i)
+         td(i,np+1,1)=0.0
+         td(i,np+1,2)=0.0
+         tt(i,np+1,1)=0.0
+         tt(i,np+1,2)=0.0
+         ts(i,np+1,1)=0.0
+         ts(i,np+1,2)=0.0
+         cc(i,1)=0.0
+         cc(i,2)=0.0
+         cc(i,3)=0.0
+      enddo
+
+      if (cldwater) then
+       do k=1,np
+        do i=1,m
+          taucld(i,k,1)=cwp(i,k,1)*(aib(1)+aib(2)/reff(i,k,1))
+          taucld(i,k,2)=cwp(i,k,2)*(awb(1)+awb(2)/reff(i,k,2))
+          taucld(i,k,3)=cwp(i,k,3)* arb(1)
+        enddo
+       enddo
+      endif
+!-----options for scaling cloud optical thickness
+
+      if (overcast) then
+
+       do k=1,np
+        do i=1,m
+          tauclb(i,k)=taucld(i,k,1)+taucld(i,k,2)+taucld(i,k,3)
+          tauclf(i,k)=tauclb(i,k)
+        enddo
+       enddo
+
+       do k=1,3
+        do i=1,m
+           cc(i,k)=1.0
+        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 (see section 7).
+
+         call cloud_scale (m,np,cosz,fcld,taucld,ict,icb, &
+                       cc,tauclb,tauclf)
+
+      endif
+
+!-----cloud asymmetry factor for a mixture of liquid and ice particles.
+!     unit of reff is micrometers. eqs. (4.8) and (6.4)
+      do k=1,np
+       do i=1,m
+           asyclt(i)=1.0
+           taux(i,k)=taucld(i,k,1)+taucld(i,k,2)+taucld(i,k,3)
+          if (taux(i,k).gt.taux_min .and. fcld(i,k).gt.fcld_min) then
+           g1=(aig(1)+(aig(2)+aig(3)*reff(i,k,1))*reff(i,k,1))*taucld(i,k,1)
+           g2=(awg(1)+(awg(2)+awg(3)*reff(i,k,2))*reff(i,k,2))*taucld(i,k,2)
+           g3= arg(1)*taucld(i,k,3)
+           asyclt(i)=(g1+g2+g3)/taux(i,k)
+         endif
+       enddo
+        do i=1,m
+          asycl(i,k)=asyclt(i)
+        enddo
+      enddo
+
+
+!-----integration over spectral bands---------------------------------
+
+  do 100 ib=1,nband
+
+
+!-----compute reflectance and transmittance of the clear portion of a layer
+
+       do k=1,np
+        do i=1,m
+
+!-----compute rayleigh, ozone and water vapor optical thicknesses
+
+          taurs=ry(ib)*dp(i,k)
+          tauoz=zk(ib)*oh(i,k)
+          tauwv=wk(ib)*wh(i,k)
+
+!-----compute clear-sky optical thickness, single scattering albedo,
+!     and asymmetry factor (eqs. 6.2-6.4)
+
+          tausto(i,k)=max(taurs+tauoz+tauwv+taual(i,k,ib),opt_min)
+          ssatau(i,k)=max(ssaal(i,k,ib)*taual(i,k,ib)+taurs,opt_min) 
+          asysto(i,k)=max(asyal(i,k,ib)*ssaal(i,k,ib)*taual(i,k,ib),opt_min)
+
+       if (overcast .and. fast_overcast ) then ; else
+
+          tautob(i,k)=tausto(i,k)
+          ssatob(i,k)=max(ssatau(i,k)/tautob(i,k),opt_min)
+          ssatob(i,k)=min(ssatob(i,k),0.999999_fp_kind)
+          asytob(i,k)=max(asysto(i,k)/(ssatob(i,k)*tautob(i,k)),opt_min)
+
+!-----Compute delta-eddington approximation of scattering properties
+!     for direct incident radiation
+
+         call delta_eddington(tautob(i,k), ssatob(i,k), asytob(i,k), cosz(i) , &
+                       rrt(i,k),ttt(i,k), tdt(i,k) )
+
+!     
+!-----diffuse incident radiation is approximated by beam radiation with
+!     an incident angle of 53 degrees, eqs. (6.5) and (6.6)
+
+         call delta_eddington(tautob(i,k), ssatob(i,k), asytob(i,k), dsm(i) , &
+                       rst(i,k),tst(i,k), dum(i,k) )
+
+           rr(i,k,1)=rrt(i,k)
+           tt(i,k,1)=ttt(i,k)
+           td(i,k,1)=tdt(i,k)
+           rs(i,k,1)=rst(i,k)
+           ts(i,k,1)=tst(i,k)
+
+         endif ! not overcast .and. not fast_overcast
+
+!-----compute reflectance and transmittance of the cloudy portion of a layer
+        if ( (tauclb(i,k).ge.taux_min .or. fcld(i,k).ge.fcld_min ) .or. &  !cloud exists
+             (overcast .and. fast_overcast ) ) then                        ! overcast .and. fast_overcast
+
+
+!-----for direct incident radiation
+!     the effective layer optical properties. eqs. (6.2)-(6.4)
+           tautob(i,k)=tausto(i,k) + max(tauclb(i,k),opt_min)
+           ssatob(i,k)=max((ssatau(i,k)+tauclb(i,k))/tautob(i,k),opt_min)
+           ssatob(i,k)=min(ssatob(i,k),0.999999_fp_kind)
+           asytob(i,k)=max((asysto(i,k)+asycl(i,k)*tauclb(i,k)) &
+                      /(ssatob(i,k)*tautob(i,k)),opt_min)
+
+!-----for diffuse incident radiation
+           tautof(i,k)=tausto(i,k)+max(tauclf(i,k),opt_min)
+
+           ssatof(i,k)=max((ssatau(i,k)+tauclf(i,k))/tautof(i,k),opt_min)
+           ssatof(i,k)=min(ssatof(i,k),0.999999_fp_kind)
+           asytof(i,k)=max((asysto(i,k)+asycl(i,k)*tauclf(i,k)) &
+                      /(ssatof(i,k)*tautof(i,k)),opt_min)
+
+!-----Compute delta-eddington approximation of scattering properties
+!     for direct incident radiation
+!     note that the cloud optical thickness is scaled differently for direct
+!     and diffuse insolation, eqs. (7.3) and (7.4).
+
+         call delta_eddington(tautob(i,k), ssatob(i,k), asytob(i,k), cosz(i) , &
+                       rrt(i,k),ttt(i,k), tdt(i,k) )
+
+!-----diffuse incident radiation is approximated by beam radiation with
+!     an incident angle of 53 degrees, eqs. (6.5) and (6.6)
+
+         call delta_eddington(tautob(i,k), ssatob(i,k), asytob(i,k), dsm(i) , &
+                       rst(i,k),tst(i,k), dum(i,k) )
+
+        endif 
+
+           rr(i,k,2)=rrt(i,k)
+           tt(i,k,2)=ttt(i,k)
+           td(i,k,2)=tdt(i,k)
+           rs(i,k,2)=rst(i,k)
+           ts(i,k,2)=tst(i,k)
+
+
+
+        enddo !i loop
+       enddo !k loop
+
+
+!-----flux calculations
+
+      if (overcast) then   !cloud fraction 0 or 1 -> CRM 
+
+       if( .not. fast_overcast ) then
+!-----for clear-sky fluxes only (This is needed for equation 6.18 flux redtion due to CO2 and O2 below cloud)
+         ih1=1 ; im1=1 ; is1=1
+         ih2=1 ; im2=1 ; is2=1 
+         call twostream_adding (m,np,ict,icb,ih1,ih2,im1,im2,is1,is2, &
+                      cc,rr,tt,td,rs,ts,fclr,dum1,falld,dum2,dum3) 
+       endif
+
+!-----for cloudy-sky fluxes only
+         ih1=2 ; im1=2 ; is1=2
+         ih2=2 ; im2=2 ; is2=2     
+         call twostream_adding (m,np,ict,icb,ih1,ih2,im1,im2,is1,is2, &
+                      cc,rr,tt,td,rs,ts,dum1,fall,falld,fsdir,fsdif) 
+
+      else  ! non overcast (cloud fraction 0.~1. GCM or RCM ) 
+
+!-----for clear- and all-sky fluxes the all-sky flux, fall is the summation inside the brackets of eq. (7.11)
+         ih1=1 ; im1=1 ; is1=1
+         ih2=2 ; im2=2 ; is2=2   
+         call twostream_adding (m,np,ict,icb,ih1,ih2,im1,im2,is1,is2, &
+                      cc,rr,tt,td,rs,ts,fclr,fall,falld,fsdir,fsdif) 
+
+      endif  ! overcast  
+
+
+!-----flux integration, eq. (6.1)
+
+       do k=1,np+1
+        do i=1,m
+          flx(i,k)=flx(i,k)+fall(i,k)*hk(ib)
+          flxd(i,k)=flxd(i,k)+falld(i,k)*hk(ib)
+
+          if(overcast .and. fast_overcast) then ; else 
+          flc(i,k)=flc(i,k)+fclr(i,k)*hk(ib)
+          endif
+
+        enddo
+
+
+       enddo
+
+!-----compute direct and diffuse downward surface fluxes in the uv
+!     and par regions
+       if(ib.lt.8) then
+        do i=1,m
+          fdiruv(i)=fdiruv(i)+fsdir(i)*hk(ib)
+          fdifuv(i)=fdifuv(i)+fsdif(i)*hk(ib)
+        enddo
+       else
+        do i=1,m
+          fdirpar(i)=fsdir(i)*hk(ib)
+          fdifpar(i)=fsdif(i)*hk(ib)
+        enddo
+       endif
+
+ 100  continue
+
+     return
+      end subroutine sw_uvpar
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine sw_ir (m,np,wh,dp, &
+                        cwp,taucld,reff,ict,icb,fcld,cosz, &
+                        taual,ssaal,asyal, &
+                        rsirbm,rsirdf,flx,flc,flxd,fdirir,fdifir)
+!************************************************************************
+!  compute solar flux in the infrared region. the spectrum is divided
+!   into three bands:
+!
+!          band   wavenumber(/cm)  wavelength (micron)
+!          1( 9)    14280-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 (m)                          n/d         1
+!  number of atmospheric layers (np)                n/d         1
+!  layer scaled-water vapor content (wh)          gm/cm^2      m*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*np*3
+!        index 1 for ice particles
+!        index 2 for liquid drops
+!        index 3 for rain drops
+!  cloud optical thickness (taucld)                 n/d        m*np*3
+!        index 1 for ice paticles
+!        index 2 for liquid drops
+!        index 3 for rain drops
+!  effective cloud-particle size (reff)           micrometer   m*np*3
+!        index 1 for ice paticles
+!        index 2 for liquid drops
+!        index 3 for rain drops
+!  level index separating high and                  n/d        m
+!        middle clouds (ict)
+!  level index separating middle and                n/d        m
+!        low clouds (icb)
+!  cloud amount (fcld)                            fraction     m*np
+!  aerosol optical thickness (taual)                n/d        m*np*11
+!  aerosol single-scattering albedo (ssaal)         n/d        m*np*11
+!  aerosol asymmetry factor (asyal)                 n/d        m*np*11
+!  near ir surface albedo for beam                fraction     m
+!        radiation (rsirbm)
+!  near ir surface albedo for diffuse             fraction     m
+!        radiation (rsirdf)
+!
+!---- temporary array
+!
+!  scaled cloud optical thickness                   n/d        m*np
+!          for beam radiation (tauclb)
+!  scaled cloud optical thickness                   n/d        m*np
+!          for diffuse radiation  (tauclf)
+!
+!----- output (updated) parameters:
+!
+!  all-sky flux divergence (downward-upward) (flx)           fraction     m*(np+1)
+!  clear-sky flux divergence (downward-upward) (flc)         fraction     m*(np+1)
+!  all-sky direct downward ir flux at
+!          the surface (fdirir)                   fraction     m
+!  all-sky diffuse downward ir flux at
+!          the surface (fdifir)                   fraction     m
+!
+!**********************************************************************
+     implicit none
+!-----input parameters
+      integer m,np,ict(m),icb(m)
+      integer ih1,ih2,im1,im2,is1,is2
+      real(Kind=fp_kind) cwp(m,np,3),taucld(m,np,3),reff(m,np,3)
+      real(Kind=fp_kind) fcld(m,np),cosz(m)
+      real(Kind=fp_kind) rsirbm(m),rsirdf(m)
+      real(Kind=fp_kind) taual(m,np,ib_sw),ssaal(m,np,ib_sw),asyal(m,np,ib_sw)
+      real(Kind=fp_kind) dp(m,np),wh(m,np)
+!-----output (updated) parameters
+      real(Kind=fp_kind) flx(m,np+1),flc(m,np+1)
+      real(Kind=fp_kind) flxd(m,np+1)
+      real(Kind=fp_kind) fdirir(m),fdifir(m)
+!-----static parameters
+      integer nk,nband
+      parameter (nk=10,nband=3)
+      real(Kind=fp_kind) :: taux
+      real(Kind=fp_kind) :: w1, w2, w3 !expansion stuff
+      real(Kind=fp_kind) :: g1, g2, g3 !asymetry stuff
+      real(Kind=fp_kind) hk(nband,nk),xk(nk),ry(nband)
+      real(Kind=fp_kind) aib(nband,2),awb(nband,2),arb(nband,2)
+      real(Kind=fp_kind) aia(nband,3),awa(nband,3),ara(nband,3)
+      real(Kind=fp_kind) aig(nband,3),awg(nband,3),arg(nband,3)
+!-----temporary array
+      integer ib,iv,ik,i,k
+      real(Kind=fp_kind) taurs,tauwv
+      real(Kind=fp_kind) :: dsm(m)
+      real(Kind=fp_kind) :: tauclb(m,np)
+      real(Kind=fp_kind) :: tauclf(m,np)
+      real(Kind=fp_kind) :: cc(m,3)
+      real(Kind=fp_kind) :: ssacl(m,np)
+      real(Kind=fp_kind) :: asycl(m,np)
+      real(Kind=fp_kind) :: rr(m,np+1,2)
+      real(Kind=fp_kind) :: tt(m,np+1,2)
+      real(Kind=fp_kind) :: td(m,np+1,2)
+      real(Kind=fp_kind) :: rs(m,np+1,2)
+      real(Kind=fp_kind) :: ts(m,np+1,2)
+      real(Kind=fp_kind) :: fall(m,np+1)
+      real(Kind=fp_kind) :: falld(m,np+1)
+      real(Kind=fp_kind) :: fclr(m,np+1)
+      real(Kind=fp_kind) :: fsdir(m)
+      real(Kind=fp_kind) :: fsdif(m)
+      real(Kind=fp_kind) :: tausto(m,np)
+      real(Kind=fp_kind) :: ssatau(m,np)
+      real(Kind=fp_kind) :: asysto(m,np)
+      real(Kind=fp_kind) :: tautob(m,np)
+      real(Kind=fp_kind) :: ssatob(m,np)
+      real(Kind=fp_kind) :: asytob(m,np)
+      real(Kind=fp_kind) :: tautof(m,np)
+      real(Kind=fp_kind) :: ssatof(m,np)
+      real(Kind=fp_kind) :: asytof(m,np)
+      real(Kind=fp_kind) :: ssaclt(m)
+      real(Kind=fp_kind) :: asyclt(m)
+      real(Kind=fp_kind) :: rrt(m,np)
+      real(Kind=fp_kind) :: ttt(m,np)
+      real(Kind=fp_kind) :: tdt(m,np)
+      real(Kind=fp_kind) :: rst(m,np)
+      real(Kind=fp_kind) :: tst(m,np)
+      real(Kind=fp_kind) :: dum1(m,np+1)
+      real(Kind=fp_kind) :: dum2(m)
+      real(Kind=fp_kind) :: dum3(m)
+      real(Kind=fp_kind) :: dum(m,np)
+!-----water vapor absorption coefficient for 10 k-intervals.
+!     unit: cm^2/gm (table 2)
+      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 (table 2)
+      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/
+!-----ry is the extinction coefficient for rayleigh scattering.
+!     unit: /mb (table 3)
+      data ry /.0000156, .0000018, .000000/
+!-----coefficients for computing the extinction coefficients of
+!     ice, water, and rain particles (table 4)
+      data aib/ &
+        .000333, .000333, .000333, &
+           2.52,    2.52,    2.52/
+      data awb/ &
+        -0.0101, -0.0166, -0.0339, &
+           1.72,    1.85,    2.16/
+      data arb/ &
+         0.00307, 0.00307, 0.00307, &
+         0.0    , 0.0    , 0.0    /
+!-----coefficients for computing the single-scattering co-albedo of
+!     ice, water, and rain particles (table 5)
+      data aia/ &
+       -.00000260, .00215346, .08938331, &
+        .00000746, .00073709, .00299387, &
+        .00000000,-.00000134,-.00001038/
+      data awa/ &
+        .00000007,-.00019934, .01209318, &
+        .00000845, .00088757, .01784739, &
+       -.00000004,-.00000650,-.00036910/
+      data ara/ &
+        .029,      .342,      .466, &
+        .0000,     .000,      .000, &
+        .0000,     .000,      .000/
+!-----coefficients for computing the asymmetry factor of
+!     ice, water, and rain particles (table 6)
+      data aig/ &
+        .74935228, .76098937, .84090400, &
+        .00119715, .00141864, .00126222, &
+       -.00000367,-.00000396,-.00000385/
+      data awg/ &
+        .79375035, .74513197, .83530748, &
+        .00832441, .01370071, .00257181, &
+       -.00023263,-.00038203, .00005519/
+      data arg/ &
+        .891,      .948,      .971, &
+        .0000,     .000,      .000, &
+        .0000,     .000,      .000/
+!-----initialize surface fluxes, reflectances, and transmittances.
+!     the reflectance and transmittance of the clear and cloudy portions
+!     of a layer are denoted by 1 and 2, respectively.
+!     cc is the maximum cloud cover in each of the high, middle, and low
+!     cloud groups.
+!     1/dsm=1/cos(53)=1.66
+      do i=1,m
+         dsm(i)=0.602
+         fdirir(i)=0.0
+         fdifir(i)=0.0
+         rr(i,np+1,1)=rsirbm(i)
+         rr(i,np+1,2)=rsirbm(i)
+         rs(i,np+1,1)=rsirdf(i)
+         rs(i,np+1,2)=rsirdf(i)
+         td(i,np+1,1)=0.0
+         td(i,np+1,2)=0.0
+         tt(i,np+1,1)=0.0
+         tt(i,np+1,2)=0.0
+         ts(i,np+1,1)=0.0
+         ts(i,np+1,2)=0.0
+         cc(i,1)=0.0
+         cc(i,2)=0.0
+         cc(i,3)=0.0
+      enddo
+!-----integration over spectral bands
+      do 100 ib=1,nband
+       iv=ib+8
+!-----compute cloud optical thickness. eqs. (4.6) and (4.11)
+      if (cldwater) then
+       do k=1,np
+        do i=1,m
+          taucld(i,k,1)=cwp(i,k,1)*(aib(ib,1) &
+                          +aib(ib,2)/reff(i,k,1))
+          taucld(i,k,2)=cwp(i,k,2)*(awb(ib,1) &
+                          +awb(ib,2)/reff(i,k,2))
+          taucld(i,k,3)=cwp(i,k,3)*arb(ib,1)
+        enddo
+       enddo
+      endif
+!-----options for scaling cloud optical thickness
+
+      if (overcast) then
+       do k=1,np
+        do i=1,m
+          tauclb(i,k)=taucld(i,k,1)+taucld(i,k,2)+taucld(i,k,3)
+          tauclf(i,k)=tauclb(i,k)
+        enddo
+       enddo
+       do k=1,3
+        do i=1,m
+          cc(i,k)=1.0
+        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 cloud_scale (m,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.
+!     eqs.(4.6)-(4.8), (6.2)-(6.4)
+       do k=1,np
+        do i=1,m
+           ssaclt(i)=0.99999
+           asyclt(i)=1.0
+           taux=taucld(i,k,1)+taucld(i,k,2)+taucld(i,k,3)
+          if (taux.gt.taux_min .and. fcld(i,k).gt.fcld_min) then
+           w1=(1.-(aia(ib,1)+(aia(ib,2)+ &
+               aia(ib,3)*reff(i,k,1))*reff(i,k,1)))*taucld(i,k,1)
+           w2=(1.-(awa(ib,1)+(awa(ib,2)+ &
+               awa(ib,3)*reff(i,k,2))*reff(i,k,2)))*taucld(i,k,2)
+           w3=(1.- ara(ib,1))*taucld(i,k,3)
+           ssaclt(i)=(w1+w2+w3)/taux
+           g1=(aig(ib,1)+(aig(ib,2)+aig(ib,3)*reff(i,k,1))*reff(i,k,1))*w1
+           g2=(awg(ib,1)+(awg(ib,2)+awg(ib,3)*reff(i,k,2))*reff(i,k,2))*w2
+           g3= arg(ib,1)*w3
+           asyclt(i)=(g1+g2+g3)/(w1+w2+w3)
+          endif
+        enddo
+         do i=1,m
+           ssacl(i,k)=ssaclt(i)
+         enddo
+         do i=1,m
+           asycl(i,k)=asyclt(i)
+         enddo
+       enddo
+
+
+!-----integration over the k-distribution function
+       do 200 ik=1,nk
+
+
+!-----compute clear-sky optical thickness, single scattering albedo,
+!     and asymmetry factor. eqs.(6.2)-(6.4)
+        do k=1,np
+         do i=1,m
+           taurs=ry(ib)*dp(i,k)
+           tauwv=xk(ik)*wh(i,k)
+
+           tausto(i,k)=max(taurs+tauwv+taual(i,k,iv),opt_min)
+           ssatau(i,k)=max(ssaal(i,k,iv)*taual(i,k,iv)+taurs,opt_min) !add for stability 
+           asysto(i,k)=max(asyal(i,k,iv)*ssaal(i,k,iv)*taual(i,k,iv),opt_min)
+
+       if (overcast .and. fast_overcast ) then
+       else
+
+!-----compute reflectance and transmittance of the clear portion of a layer
+           tautob(i,k)=tausto(i,k)
+           ssatob(i,k)=max(ssatau(i,k)/tautob(i,k),opt_min)
+           ssatob(i,k)=min(ssatob(i,k),0.999999_fp_kind)
+           asytob(i,k)=max(asysto(i,k)/(ssatob(i,k)*tautob(i,k)),opt_min)
+
+!     delta-eddington approximation for optical propeties
+!-----for direct incident radiation
+
+          call delta_eddington(tautob(i,k), ssatob(i,k), asytob(i,k), cosz(i) , &
+                       rrt(i,k),ttt(i,k), tdt(i,k) )
+
+
+!-----diffuse incident radiation is approximated by beam radiation with
+!     an incident angle of 53 degrees, eqs. (6.5) and (6.6)
+
+         call delta_eddington(tautob(i,k), ssatob(i,k), asytob(i,k), dsm(i) , &
+                       rst(i,k),tst(i,k), dum(i,k) )
+
+            rr(i,k,1)=rrt(i,k)
+            tt(i,k,1)=ttt(i,k)
+            td(i,k,1)=tdt(i,k)
+            rs(i,k,1)=rst(i,k)
+            ts(i,k,1)=tst(i,k)
+
+         endif ! overcast .and. fast_overcast
+
+!-----compute reflectance and transmittance of the cloudy portion of a layer
+        if ( (tauclb(i,k).ge.taux_min .or. fcld(i,k).ge.fcld_min ) .or. &  !cloud exists
+             (overcast .and. fast_overcast ) ) then                        ! overcast .and. fast_overcast
+
+
+!-----for direct incident radiation. eqs.(6.2)-(6.4)
+           tautob(i,k)=tausto(i,k)+max(tauclb(i,k),opt_min)
+           ssatob(i,k)=max((ssatau(i,k)+ssacl(i,k)*tauclb(i,k))/tautob(i,k),opt_min)
+           ssatob(i,k)=min(ssatob(i,k),0.999999_fp_kind)
+           asytob(i,k)=max((asysto(i,k)+asycl(i,k)*ssacl(i,k)*tauclb(i,k)) &
+                      /(ssatob(i,k)*tautob(i,k)),opt_min)
+!-----for diffuse incident radiation
+           tautof(i,k)=tausto(i,k)+max(tauclf(i,k),opt_min)
+           ssatof(i,k)=max((ssatau(i,k)+ssacl(i,k)*tauclf(i,k))/tautof(i,k),opt_min) 
+           ssatof(i,k)=min(ssatof(i,k),0.999999_fp_kind)
+           asytof(i,k)=max((asysto(i,k)+asycl(i,k)*ssacl(i,k)*tauclf(i,k)) &
+                      /(ssatof(i,k)*tautof(i,k)),opt_min)
+
+!     delta-eddington approximation for optical propeties
+!-----for direct incident radiation
+
+          call delta_eddington(tautob(i,k), ssatob(i,k), asytob(i,k), cosz(i) , &
+                       rrt(i,k),ttt(i,k), tdt(i,k) )
+
+!-----diffuse incident radiation is approximated by beam radiation with
+!     an incident angle of 53 degrees, eqs.(6.5) and (6.6)
+
+         call delta_eddington(tautob(i,k), ssatob(i,k), asytob(i,k), dsm(i) , &
+                       rst(i,k),tst(i,k), dum(i,k) )
+        endif
+
+
+            rr(i,k,2)=rrt(i,k)
+            tt(i,k,2)=ttt(i,k)
+            td(i,k,2)=tdt(i,k)
+            rs(i,k,2)=rst(i,k)
+            ts(i,k,2)=tst(i,k)
+
+         enddo
+        enddo
+
+
+!-----flux calculations
+    if (overcast) then  ! overcast  (LES or CRM)
+
+       if( .not. fast_overcast ) then
+!-----for clear-sky fluxes only
+         ih1=1 ; im1=1 ; is1=1
+         ih2=1 ; im2=1 ; is2=1
+         call twostream_adding (m,np,ict,icb,ih1,ih2,im1,im2,is1,is2, &
+                      cc,rr,tt,td,rs,ts,fclr,dum1,falld,dum2,dum3) 
+       endif
+
+!-----for cloudy-sky fluxes only
+        ih1=2 ; im1=2 ; is1=2
+        ih2=2 ; im2=2 ; is2=2
+        call twostream_adding (m,np,ict,icb,ih1,ih2,im1,im2,is1,is2, &
+                      cc,rr,tt,td,rs,ts,dum1,fall,falld,fsdir,fsdif) 
+
+    else  ! NON overcast (GCM or RCM)
+
+!-----for clear- and all-sky fluxes
+!     the all-sky flux, fall is the summation inside the brackets
+!     of eq. (7.11)
+         ih1=1 ; im1=1 ; is1=1
+         ih2=2 ; im2=2 ; is2=2
+         call twostream_adding (m,np,ict,icb,ih1,ih2,im1,im2,is1,is2, &
+                      cc,rr,tt,td,rs,ts,fclr,fall,falld,fsdir,fsdif) 
+
+  endif  ! ovrercast 
+
+
+!-----flux integration following eq. (6.1)
+       do k=1,np+1
+        do i=1,m
+          flx(i,k) = flx(i,k)+fall(i,k)*hk(ib,ik)
+          flxd(i,k) = flxd(i,k)+falld(i,k)*hk(ib,ik)
+          if(overcast .and. fast_overcast) then 
+          else
+            flc(i,k) = flc(i,k)+fclr(i,k)*hk(ib,ik)
+          endif
+        enddo
+       enddo
+!-----compute downward surface fluxes in the ir region
+       do i=1,m
+          fdirir(i) = fdirir(i)+fsdir(i)*hk(ib,ik)
+          fdifir(i) = fdifir(i)+fsdif(i)*hk(ib,ik)
+       enddo
+
+  200 continue !k integration
+  100 continue !iband
+
+
+      return
+      end subroutine sw_ir
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine cloud_scale (m,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 (section 7)
+!
+!   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 atmospheric soundings (m)
+!    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 cloud groups (cc)
+!    scaled cloud optical thickness for direct  radiation (tauclb)
+!    scaled cloud optical thickness for diffuse radiation (tauclf)
+!
+!********************************************************************
+      implicit none
+!-----input parameters
+      integer m,np,ict(m),icb(m)
+      real(Kind=fp_kind) cosz(m),fcld(m,np),taucld(m,np,3)
+!-----output parameters
+      real(Kind=fp_kind) cc(m,3),tauclb(m,np),tauclf(m,np)
+!-----temporary variables
+      integer i,j,k,im,it,ia,kk
+      real(Kind=fp_kind)  fm,ft,fa,xai,taux
+!-----pre-computed table
+!     size of cosz-interval:         dm
+!     size of taucld-interval:       dt
+!     size of cloud amount-interval: da
+      integer   nm,nt,na
+      parameter (nm=11,nt=9,na=11)
+      real(Kind=fp_kind)  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
+!     include "mcai.data"
+      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 i=1,m
+         cc(i,1)=0.0
+         cc(i,2)=0.0
+         cc(i,3)=0.0
+      enddo
+      do i=1,m
+       do k=1,ict(i)-1
+          cc(i,1)=max(cc(i,1),fcld(i,k))
+       enddo
+      enddo
+      do i=1,m
+        do k=ict(i),icb(i)-1
+          cc(i,2)=max(cc(i,2),fcld(i,k))
+       enddo
+      enddo
+      do i=1,m
+       do k=icb(i),np
+          cc(i,3)=max(cc(i,3),fcld(i,k))
+       enddo
+      enddo
+!-----scale the cloud optical thickness.
+!     taucld(i,k,1) is the optical thickness for ice particles
+!     taucld(i,k,2) is the optical thickness for liquid particles
+!     taucld(i,k,3) is the optical thickness for rain drops
+      do i=1,m
+       do k=1,np
+         if(k.lt.ict(i)) then
+            kk=1
+         elseif(k.ge.ict(i) .and. k.lt.icb(i)) then
+            kk=2
+         else
+            kk=3
+         endif
+         tauclb(i,k) = 0.0
+         tauclf(i,k) = 0.0
+         taux=taucld(i,k,1)+taucld(i,k,2)+taucld(i,k,3)
+         if (taux.gt.taux_min .and. fcld(i,k).gt.fcld_min) then
+!-----normalize cloud cover following eq. (7.8)
+           fa=fcld(i,k)/cc(i,kk)
+!-----table look-up
+           taux=min(taux,32._fp_kind)
+           fm=cosz(i)/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 following eq. (7.3)
+!     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_fp_kind)
+           xai=min(xai,1.0_fp_kind)
+           tauclb(i,k) = taux*xai
+!-----scale cloud optical thickness for diffuse radiation following eq. (7.4)
+!     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_fp_kind)
+           xai=min(xai,1.0_fp_kind)
+           tauclf(i,k) = taux*xai
+         endif
+       enddo
+      enddo
+      return
+      end subroutine cloud_scale
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine delta_eddington(tau,ssc,g0,cza,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
+!     cza: cosine of solar 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(Kind=fp_kind) 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(Kind=fp_kind) tau,ssc,g0,cza
+
+!-----output parameters
+      real(Kind=fp_kind) rr,tt,td
+
+!-----temporary parameters
+
+      real(Kind=fp_kind) zth,ff,xx,taup,sscp,gp,gm1,gm2,gm3,akk,alf1,alf2, &
+           all,bll,st7,st8,cll,dll,fll,ell,st1,st2,st3,st4
+       real(Kind=fp_kind) taupdzth,akkdtaup
+
+!---------------------------------------------------------------------
+
+                zth = cza 
+
+!  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
+           if (abs((one-xx)*(one+xx)) .lt. thresh) then
+               zth = zth + 0.001
+               xx  = akk * zth
+           endif
+                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=0.
+                taupdzth=taup/zth
+                if (taupdzth .lt. 40. ) 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=0.
+                akkdtaup=akk*taup
+                if (akkdtaup.lt.40.) st2 = exp(-akkdtaup)
+                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)
+                tt = tt+td
+      end subroutine delta_eddington
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+
+      subroutine twostream_adding (m,np,ict,icb,ih1,ih2,im1,im2,is1,is2, &
+                 cc,rr,tt,td,rs,ts,fclr,fall,falld,fsdir,fsdif)
+
+!*******************************************************************
+!  compute upward and downward fluxes using a two-stream adding method
+!  following equations (6.9)-(6.16).
+!
+!  clouds are grouped into high, middle, and low clouds which are assumed
+!  randomly overlapped. it involves a maximum of 8 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
+!   np:  number of atmospheric layers
+!   ict: the level separating high and middle clouds
+!   icb: the level separating middle and low clouds
+!   ih1,ih2,im1,im2,is1,is2: indices for three group of clouds
+!   cc:  effective cloud covers for high, middle and low clouds
+!   rr:  reflection of a layer illuminated by beam radiation
+!   tt:  total (direct+diffuse) transmission of a layer illuminated
+!        by beam radiation
+!   td:  direct beam transmission
+!   rs:  reflection of a layer illuminated by diffuse radiation
+!   ts:  transmission of a layer illuminated by diffuse radiation
+!
+!  output parameters:
+!
+!     fclr:  clear-sky flux divergence (downward minus upward)
+!     fall:  all-sky flux divergence (downward minus upward)
+!     fsdir: surface direct downward flux
+!     fsdif: surface diffuse downward flux
+!
+!*********************************************************************c
+!ccshie 8/19/04
+     implicit none
+!-----input parameters
+      integer m,np,ict(m),icb(m),ih1,ih2,im1,im2,is1,is2
+      real(Kind=fp_kind) rr(m,np+1,2),tt(m,np+1,2),td(m,np+1,2)
+      real(Kind=fp_kind) rs(m,np+1,2),ts(m,np+1,2)
+      real(Kind=fp_kind) cc(m,3)
+!-----temporary array
+      integer i,k,ih,im,is
+      real(Kind=fp_kind) denm,xx,yy
+      real(Kind=fp_kind) fupdif
+      real(Kind=fp_kind) :: rra(m,np+1,2,2)
+      real(Kind=fp_kind) :: tta(m,np+1,2,2)
+      real(Kind=fp_kind) :: tda(m,np+1,2,2)
+      real(Kind=fp_kind) :: rsa(m,np+1,2,2)
+      real(Kind=fp_kind) :: rxa(m,np+1,2,2)
+      real(Kind=fp_kind) :: ch(m)
+      real(Kind=fp_kind) :: cm(m)
+      real(Kind=fp_kind) :: ct(m)
+      real(Kind=fp_kind) :: flxdn(m,np+1)
+      real(Kind=fp_kind) :: fdndir(m)
+      real(Kind=fp_kind) :: fdndif(m)
+      real(Kind=fp_kind) flxdnu(m,np+1),flxdnd(m,np+1)
+
+!-----output parameters
+      real(Kind=fp_kind) fclr(m,np+1),fall(m,np+1)
+      real(Kind=fp_kind) falld(m,np+1)
+      real(Kind=fp_kind) fsdir(m),fsdif(m)
+
+
+   if(overcast) then
+!      ih1=2 ; im1=2 ; is1=2
+   else
+!      ih1=1 ; im1=1 ; is1=1
+   endif
+!      ih2=2 ; im2=2 ; is2=2
+
+
+
+!-----initialize all-sky flux (fall) and surface downward fluxes
+      do k=1,np+1
+        do i=1,m
+           fclr(i,k)=0.0
+           fall(i,k)=0.0
+           falld(i,k)=0.0
+        enddo
+      enddo
+
+        do i=1,m
+           fsdir(i)=0.0
+           fsdif(i)=0.0
+        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 direct transmittance illuminated by beam radiation
+!     tta is the composite total transmittance illuminated by
+!         beam radiation
+!     rsa is the composite reflectance illuminated from below
+!         by diffuse radiation
+!     tta and rsa are computed from eqs. (6.10) and (6.12)
+!-----for high clouds
+!     ih=1 for clear-sky condition, ih=2 for cloudy-sky condition
+
+      do ih=ih1,ih2
+
+       do i=1,m
+          tda(i,1,ih,1)=td(i,1,ih)
+          tta(i,1,ih,1)=tt(i,1,ih)
+          rsa(i,1,ih,1)=rs(i,1,ih)
+          tda(i,1,ih,2)=td(i,1,ih)
+          tta(i,1,ih,2)=tt(i,1,ih)
+          rsa(i,1,ih,2)=rs(i,1,ih)
+       enddo
+
+       do i=1,m
+         do k=2,ict(i)-1
+          denm = ts(i,k,ih)/( 1.-rsa(i,k-1,ih,1)*rs(i,k,ih))
+          tda(i,k,ih,1)= tda(i,k-1,ih,1)*td(i,k,ih)
+          tta(i,k,ih,1)= tda(i,k-1,ih,1)*tt(i,k,ih) &
+                +(tda(i,k-1,ih,1)*rsa(i,k-1,ih,1)*rr(i,k,ih) &
+                +tta(i,k-1,ih,1)-tda(i,k-1,ih,1))*denm    !additional -tda(i,k-1,ih,1)
+          rsa(i,k,ih,1)= rs(i,k,ih)+ts(i,k,ih) &
+                        *rsa(i,k-1,ih,1)*denm
+          if(tda(i,k,ih,1).lt.1.e-10) tda(i,k,ih,1)=0. !!
+          if(tta(i,k,ih,1).lt.1.e-10) tta(i,k,ih,1)=0. !!
+          tda(i,k,ih,2)= tda(i,k,ih,1)
+          tta(i,k,ih,2)= tta(i,k,ih,1)
+          rsa(i,k,ih,2)= rsa(i,k,ih,1)
+        enddo
+       enddo
+
+!-----for middle clouds
+!     im=1 for clear-sky condition, im=2 for cloudy-sky condition
+
+      do im=im1,im2
+       do i=1,m
+        do k=ict(i),icb(i)-1
+          denm = ts(i,k,im)/( 1.-rsa(i,k-1,ih,im)*rs(i,k,im))
+          tda(i,k,ih,im)= tda(i,k-1,ih,im)*td(i,k,im)
+          tta(i,k,ih,im)= tda(i,k-1,ih,im)*tt(i,k,im) &
+               +(tda(i,k-1,ih,im)*rsa(i,k-1,ih,im)*rr(i,k,im) &
+               +tta(i,k-1,ih,im)-tda(i,k-1,ih,im))*denm   !additional -tda(i,k-1,ih,im)
+          rsa(i,k,ih,im)= rs(i,k,im)+ts(i,k,im) &
+                        *rsa(i,k-1,ih,im)*denm
+          if(tda(i,k,ih,im).lt.1.e-10) tda(i,k,ih,im)=0. !!
+          if(tta(i,k,ih,im).lt.1.e-10) tta(i,k,ih,im)=0. !!
+        enddo
+       enddo
+      enddo                 ! end im loop
+
+      enddo                 ! end ih loop
+
+!-----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. (6.9) and (6.11)
+!-----for the low clouds
+!     is=1 for clear-sky condition, is=2 for cloudy-sky condition
+
+      do is=is1,is2
+
+       do i=1,m
+         rra(i,np+1,1,is)=rr(i,np+1,is)
+         rxa(i,np+1,1,is)=rs(i,np+1,is)
+         rra(i,np+1,2,is)=rr(i,np+1,is)
+         rxa(i,np+1,2,is)=rs(i,np+1,is)
+       enddo
+       do i=1,m
+         do k=np,icb(i),-1
+          denm=ts(i,k,is)/( 1.-rs(i,k,is)*rxa(i,k+1,1,is) )
+          rra(i,k,1,is)=rr(i,k,is)+(td(i,k,is)*rra(i,k+1,1,is) &
+              +(tt(i,k,is)-td(i,k,is))*rxa(i,k+1,1,is))*denm  !additional -td(i,k,is)
+          rxa(i,k,1,is)= rs(i,k,is)+ts(i,k,is) &
+              *rxa(i,k+1,1,is)*denm
+          rra(i,k,2,is)=rra(i,k,1,is)
+          rxa(i,k,2,is)=rxa(i,k,1,is)
+        enddo
+       enddo
+!-----for middle clouds
+      do im=im1,im2
+       do i=1,m
+        do k=icb(i)-1,ict(i),-1
+          denm=ts(i,k,im)/( 1.-rs(i,k,im)*rxa(i,k+1,im,is) )
+          rra(i,k,im,is)= rr(i,k,im)+(td(i,k,im)*rra(i,k+1,im,is) &
+              +(tt(i,k,im)-td(i,k,im))*rxa(i,k+1,im,is))*denm   !additiona -td(i,k,im)
+          rxa(i,k,im,is)= rs(i,k,im)+ts(i,k,im) &
+              *rxa(i,k+1,im,is)*denm
+        enddo
+       enddo
+      enddo                 ! end im loop
+
+      enddo                 ! end is loop
+
+!-----integration over eight sky situations.
+!     ih, im, is denotes high, middle and low cloud groups.
+
+      do ih=ih1,ih2
+
+!-----clear portion
+         if(ih.eq.1) then
+           do i=1,m
+             ch(i)=1.0-cc(i,1)
+           enddo
+          else
+!-----cloudy portion
+           do i=1,m
+             ch(i)=cc(i,1)
+           enddo
+          endif
+
+      do im=im1,im2
+
+!-----clear portion
+         if(im.eq.1) then
+           do i=1,m
+              cm(i)=ch(i)*(1.0-cc(i,2))
+           enddo
+         else
+!-----cloudy portion
+           do i=1,m
+              cm(i)=ch(i)*cc(i,2)
+           enddo
+         endif
+
+      do is=is1,is2
+
+!-----clear portion
+         if(is.eq.1) then
+           do i=1,m
+             ct(i)=cm(i)*(1.0-cc(i,3))
+           enddo
+         else
+!-----cloudy portion
+           do i=1,m
+             ct(i)=cm(i)*cc(i,3)
+           enddo
+         endif
+!-----add one layer at a time, going down.
+       do i=1,m
+        do k=icb(i),np
+          denm = ts(i,k,is)/( 1.-rsa(i,k-1,ih,im)*rs(i,k,is) )
+          tda(i,k,ih,im)= tda(i,k-1,ih,im)*td(i,k,is)
+          tta(i,k,ih,im)=  tda(i,k-1,ih,im)*tt(i,k,is) &
+               +(tda(i,k-1,ih,im)*rr(i,k,is) &
+               *rsa(i,k-1,ih,im)+tta(i,k-1,ih,im)-tda(i,k-1,ih,im))*denm   !additional -tda(i,k-1,ih,im)
+          rsa(i,k,ih,im)= rs(i,k,is)+ts(i,k,is) &
+               *rsa(i,k-1,ih,im)*denm
+          if(tda(i,k,ih,im).lt.1.e-10) tda(i,k,ih,im)=0.  !!
+          if(tta(i,k,ih,im).lt.1.e-10) tta(i,k,ih,im)=0.  !!
+        enddo
+       enddo
+!-----add one layer at a time, going up.
+       do i=1,m
+        do k=ict(i)-1,1,-1
+          denm =ts(i,k,ih)/(1.-rs(i,k,ih)*rxa(i,k+1,im,is))
+          rra(i,k,im,is)= rr(i,k,ih)+(td(i,k,ih)*rra(i,k+1,im,is) &
+              +(tt(i,k,ih)-td(i,k,ih))*rxa(i,k+1,im,is))*denm   !addittional -td(i,k,ih)
+          rxa(i,k,im,is)= rs(i,k,ih)+ts(i,k,ih) &
+              *rxa(i,k+1,im,is)*denm
+        enddo
+       enddo
+!-----compute fluxes following eq. (6.15) for fupdif and
+!     eq. (6.16) for (fdndir+fdndif)
+!     fdndir is the direct  downward flux
+!     fdndif is the diffuse downward flux
+!     fupdif is the diffuse upward flux
+      do k=2,np+1
+       do i=1,m
+         denm= 1./(1.-rsa(i,k-1,ih,im)*rxa(i,k,im,is))
+         fdndir(i)= tda(i,k-1,ih,im)
+         xx= tda(i,k-1,ih,im)*rra(i,k,im,is)
+         yy= tta(i,k-1,ih,im)-tda(i,k-1,ih,im)    !additional -tda(i,k-1,ih,im)
+         fdndif(i)= (xx*rsa(i,k-1,ih,im)+yy)*denm
+         fupdif= (xx+yy*rxa(i,k,im,is))*denm
+         flxdn(i,k)= fdndir(i)+fdndif(i)-fupdif
+         flxdnu(i,k)=-fupdif
+         flxdnd(i,k)=fdndir(i)+fdndif(i)
+       enddo
+      enddo
+       do i=1,m
+         flxdn(i,1)=1.0-rra(i,1,im,is)
+         flxdnu(i,1)=-rra(i,1,im,is)
+         flxdnd(i,1)=1.0
+       enddo
+!-----summation of fluxes over all sky situations;
+!     the term in the brackets of eq. (7.11)
+       do k=1,np+1
+        do i=1,m
+           if(ih.eq.1 .and. im.eq.1 .and. is.eq.1) then
+             fclr(i,k)=flxdn(i,k)
+           endif
+             fall(i,k)=fall(i,k)+flxdn(i,k)*ct(i)
+             falld(i,k)=falld(i,k)+flxdnd(i,k)*ct(i)
+        enddo
+       enddo
+
+        do i=1,m
+            fsdir(i)=fsdir(i)+fdndir(i)*ct(i)
+            fsdif(i)=fsdif(i)+fdndif(i)*ct(i)
+        enddo
+
+       enddo                 ! end is loop
+
+     enddo                 ! end im loop
+
+   enddo                 ! end ih loop
+
+
+      return
+      end subroutine twostream_adding 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine reduce_flux (m,np,swc,u1,du,nu,swh,w1,dw,nw,tbl,df)
+!*****************************************************************
+!-----compute the reduction of clear-sky downward solar flux
+!     due to co2 absorption.
+      implicit none
+!-----input parameters
+      integer m,np,nu,nw
+      real(Kind=fp_kind) u1,du,w1,dw
+      real(Kind=fp_kind) swc(m,np+1),swh(m,np+1),tbl(nu,nw)
+!-----output (undated) parameter
+      real(Kind=fp_kind) df(m,np+1)
+!-----temporary array
+      integer i,k,ic,iw
+      real(Kind=fp_kind) clog,wlog,dc,dd,x0,x1,x2,y0,y1,y2
+!-----table look-up for the reduction of clear-sky solar
+         x0=u1+float(nu)*du
+         y0=w1+float(nw)*dw
+         x1=u1-0.5*du
+         y1=w1-0.5*dw
+      do k= 2, np+1
+       do i= 1, m
+          clog=min(swc(i,k),x0)
+          clog=max(swc(i,k),x1)
+          wlog=min(swh(i,k),y0)
+          wlog=max(swh(i,k),y1)
+          ic=int( (clog-x1)/du+1.)
+          iw=int( (wlog-y1)/dw+1.)
+          if(ic.lt.2)ic=2
+          if(iw.lt.2)iw=2
+          if(ic.gt.nu)ic=nu
+          if(iw.gt.nw)iw=nw
+          dc=clog-float(ic-2)*du-u1
+          dd=wlog-float(iw-2)*dw-w1
+          x2=tbl(ic-1,iw-1)+(tbl(ic-1,iw)-tbl(ic-1,iw-1))/dw*dd
+          y2=x2+(tbl(ic,iw-1)-tbl(ic-1,iw-1))/du*dc
+          df(i,k)=df(i,k)+y2
+       enddo
+      enddo
+      return
+      end subroutine reduce_flux
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine o3_profile (np, pres, ozone, its, ite, kts, kte, p2d, o3)
+      implicit none
+
+      integer m,np,its,ite,kts,kte
+      integer i,k,ko,kk
+      real(Kind=fp_kind) pres(np),ozone(np)
+      real(Kind=fp_kind) p(its:ite,kts:kte),o3(its:ite,kts:kte)
+      real(Kind=fp_kind),intent(in) :: p2d(its:ite,kts:kte)
+!     statement function 
+      real(Kind=fp_kind) linear, x1, y1, x2, y2, x
+      linear(x1, y1, x2, y2, x) =  &
+            (y1 * (x2 - x) + y2 * (x - x1)) / (x2 - x1)
+
+      p = p2d
+!
+      do k = 1,np
+        pres(k) = log(pres(k))  !toshii
+      enddo
+      do k = kts,kte
+        do i = its, ite
+          p(i,k) = log(p(i,k))  !toshii
+        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
+      end do
+
+      end subroutine o3_profile
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine lwrad (m,np,pl,ta,wa,oa,tb,ts,emiss, &
+                        cwc,reff,fcld,ict,icb, &
+                        taual,ssaal,asyal,&
+                        flx,acflxd,acflxu)
+!***********************************************************************
+! this routine computes ir fluxes due to water vapor, co2, o3,
+!   trace gases (n2o, ch4, cfc11, cfc12, cfc22, co2-minor),
+!   clouds, and aerosols.
+!
+! this is a vectorized code.  it computes fluxes simultaneously for
+!   m soundings.
+!
+! some detailed descriptions of the radiation routine are given in
+!   chou and suarez (1994).
+!
+! ice and liquid cloud particles are allowed to co-exist in any of the
+!  np layers.
+!
+! if no information is available for the effective cloud particle size,
+!  reff, default values of 10 micron for liquid water and 75 micron
+!  for ice can be used.
+!
+! the maximum-random assumption is applied for cloud overlapping.
+!  clouds are grouped into high, middle, and low clouds separated by the
+!  level indices ict and icb.  within each of the three groups, clouds
+!  are assumed maximally overlapped, and the cloud cover of a group is
+!  the maximum cloud cover of all the layers in the group.  clouds among
+!  the three groups are assumed randomly overlapped. the indices ict and
+!  icb correpond approximately to the 400 mb and 700 mb levels.
+!
+! aerosols are allowed to be in any of the np layers. aerosol optical
+!  properties can be specified as functions of height and spectral band.
+!
+! the ir spectrum is divided into nine bands:
+!
+!   band     wavenumber (/cm)   absorber
+!
+!    1           0 - 340           h2o
+!    2         340 - 540           h2o
+!    3         540 - 800       h2o,cont,co2
+!    4         800 - 980       h2o,cont
+!                              co2,f11,f12,f22
+!    5         980 - 1100      h2o,cont,o3
+!                              co2,f11
+!    6        1100 - 1215      h2o,cont
+!                              n2o,ch4,f12,f22
+!    7        1215 - 1380      h2o,cont
+!                              n2o,ch4
+!    8        1380 - 1900          h2o
+!    9        1900 - 3000          h2o
+!
+! in addition, a narrow band in the 17 micrometer region is added to
+!    compute flux reduction due to n2o
+!
+!    10        540 - 620       h2o,cont,co2,n2o
+!
+! band 3 (540-800/cm) is further divided into 3 sub-bands :
+!
+!   subband   wavenumber (/cm)
+!
+!    1          540 - 620
+!    2          620 - 720
+!    3          720 - 800
+!
+!---- input parameters                               units    size
+!
+!   number of soundings (m)                            --      1
+!   number of atmospheric layers (np)                  --      1
+!   level pressure (pl)                               mb      m*(np+1)
+!   layer temperature (ta)                            k       m*np
+!   layer specific humidity (wa)                      g/g     m*np
+!   layer ozone mixing ratio by mass (oa)             g/g     m*np
+!   surface air temperature (tb)                      k        m
+!   surface temperature (ts)                          k        m
+!   surface emissivity (emiss)                      fraction   m*10
+!   input option for cloud fractional cover            --      1
+!      (overcast)   (see explanation above)
+!   input option for cloud optical thickness           --      1
+!      (cldwater)   (see explanation above)
+!   cloud water mixing ratio (cwc)                   gm/gm   m*np*3
+!       index 1 for ice particles
+!       index 2 for liquid drops
+!       index 3 for rain drops
+!   cloud optical thickness (taucl)                    --    m*np*3
+!       index 1 for ice particles
+!       index 2 for liquid drops
+!       index 3 for rain drops
+!   effective cloud-particle size (reff)          micrometer m*np*3
+!       index 1 for ice particles
+!       index 2 for liquid drops
+!       index 3 for rain drops
+!   cloud amount (fcld)                             fraction  m*np
+!   level index separating high and middle             --      1
+!       clouds (ict)
+!   level index separating middle and low              --      1
+!       clouds (icb)
+!   aerosol optical thickness (taual)                  --   m*np*10
+!   aerosol single-scattering albedo (ssaal)           --   m*np*10
+!   aerosol asymmetry factor (asyal)                   --   m*np*10
+!   high (see explanation above)                       --      1
+!   trace (see explanation above)                      --      1
+!
+! data used in table look-up for transmittance calculations:
+!
+!   c1 , c2, c3: for co2 (band 3)
+!   o1 , o2, o3: for  o3 (band 5)
+!   h11,h12,h13: for h2o (band 1)
+!   h21,h22,h23: for h2o (band 2)
+!   h81,h82,h83: for h2o (band 8)
+!
+!---- output parameters
+!
+!   net downward flux, all-sky   (flx)             w/m**2  m*(np+1)
+!   net downward flux, clear-sky (flc)             w/m**2  m*(np+1)
+!   sensitivity of net downward flux
+!       to surface temperature (dfdts)            w/m**2/k m*(np+1)
+!   emission by the surface (sfcem)                 w/m**2     m
+!
+! notes:
+!
+!   (1) water vapor continuum absorption is included in 540-1380 /cm.
+!   (2) scattering is parameterized for clouds and aerosols.
+!   (3) diffuse cloud and aerosol transmissions are computed
+!       from exp(-1.66*tau).
+!   (4) if there are no clouds, flx=flc.
+!   (5) plevel(1) is the pressure at the top of the model atmosphere,
+!        and plevel(np+1) is the surface pressure.
+!   (6) downward flux is positive and upward flux is negative.
+!   (7) sfcem and dfdts are negative because upward flux is defined as negative.
+!   (8) for questions and coding errors, plaese contact ming-dah chou,
+!       code 913, nasa/goddard space flight center, greenbelt, md 20771.
+!       phone: 301-614-6192, fax: 301-614-6307,
+!       e-mail: chou@climate.gsfc.nasa.gov
+!
+!***************************************************************************
+     implicit none
+!---- input parameters ------
+      integer,intent(in) ::  m,np,ict(m),icb(m)
+      real(Kind=fp_kind) ,intent(in) :: pl(m,np+1),ta(m,np),wa(m,np),oa(m,np), &
+           tb(m),ts(m), emiss(m,ib_lw)
+      real(Kind=fp_kind) ,intent(in) :: cwc(m,np,3),reff(m,np,3), fcld(m,np)
+
+      real(Kind=fp_kind) , intent(in) :: taual(m,np,ib_lw),ssaal(m,np,ib_lw),asyal(m,np,ib_lw)
+!---- output parameters ------
+      real(Kind=fp_kind),intent(out) :: flx(m,np+1)
+
+
+      real(Kind=fp_kind) :: flc(m,np+1),dfdts(m,np+1), sfcem(m)
+      real(Kind=fp_kind) :: acflxu(m,np+1),acflxd(m,np+1)  !upwelling and downwelling broadband LW flux [W/m2]
+
+!---- static data -----
+      real(Kind=fp_kind) cb(6,10),xkw(9),xke(9),aw(9),bw(9),pm(9),fkw(6,9),gkw(6,3)
+      real(Kind=fp_kind) aib(3,10),awb(4,10),aiw(4,10),aww(4,10),aig(4,10),awg(4,10)
+      integer ne(9),mw(9)
+      real(Kind=fp_kind) :: taucl(m,np,3) 
+!-----parameters defining the size of the pre-computed tables for
+!     transmittance using table look-up.
+!c    "nx" is the number of intervals in pressure
+!     "nx2" is the number of intervals in pressure
+!     "no" is the number of intervals in o3 amount
+!     "nc" is the number of intervals in co2 amount
+!     "nh" is the number of intervals in h2o amount
+      integer nx2,no,nc,nh
+      parameter (nx2=26,no=21,nc=30,nh=31) ! cccshie 9/15/04
+      real(Kind=fp_kind) c1 (nx2,nc),c2 (nx2,nc),c3 (nx2,nc)
+      real(Kind=fp_kind) o1 (nx2,no),o2 (nx2,no),o3 (nx2,no)
+      real(Kind=fp_kind) h11(nx2,nh),h12(nx2,nh),h13(nx2,nh)
+      real(Kind=fp_kind) h21(nx2,nh),h22(nx2,nh),h23(nx2,nh)
+      real(Kind=fp_kind) h71(nx2,nh),h72(nx2,nh),h73(nx2,nh)
+      real(Kind=fp_kind) h81(nx2,nh),h82(nx2,nh),h83(nx2,nh)
+!---- temporary arrays -----
+     real(Kind=fp_kind) pa(m,np),dt(m,np)
+     real(Kind=fp_kind) sh2o(m,np+1),swpre(m,np+1),swtem(m,np+1)
+     real(Kind=fp_kind) sco3(m,np+1),scopre(m,np+1),scotem(m,np+1)
+     real(Kind=fp_kind) dh2o(m,np),dcont(m,np),dco2(m,np),do3(m,np)
+     real(Kind=fp_kind) dn2o(m,np),dch4(m,np)
+     real(Kind=fp_kind) df11(m,np),df12(m,np),df22(m,np)
+     real(Kind=fp_kind) th2o(m,6),tcon(m,3),tco2(m,6,2)
+     real(Kind=fp_kind) tn2o(m,4),tch4(m,4),tcom(m,6)
+     real(Kind=fp_kind) tf11(m),tf12(m),tf22(m)
+     real(Kind=fp_kind) h2oexp(m,np,6),conexp(m,np,3),co2exp(m,np,6,2)
+     real(Kind=fp_kind) n2oexp(m,np,4),ch4exp(m,np,4),comexp(m,np,6)
+     real(Kind=fp_kind) f11exp(m,np),f12exp(m,np),f22exp(m,np)
+     real(Kind=fp_kind) blayer(m,0:np+1),blevel(m,np+1),dblayr(m,np+1),dbs(m)
+     real(Kind=fp_kind) dp(m,np),cwp(m,np,3)
+     real(Kind=fp_kind) trant(m),tranal(m),transfc(m,np+1),trantcr(m,np+1)
+     real(Kind=fp_kind) flxu(m,np+1),flxd(m,np+1),flcu(m,np+1),flcd(m,np+1)
+     real(Kind=fp_kind) rflx(m,np+1),rflc(m,np+1)
+     integer it(m),im(m),ib(m)
+     real(Kind=fp_kind) cldhi(m),cldmd(m),cldlw(m),tcldlyr(m,np),fclr(m)
+     real(Kind=fp_kind) taerlyr(m,np)
+
+!      real(Kind=fp_kind) ,  allocatable :: pa(:,:),dt(:,:)
+!      real(Kind=fp_kind) ,  allocatable :: sh2o(:,:),swpre(:,:),swtem(:,:)
+!      real(Kind=fp_kind) ,  allocatable :: sco3(:,:),scopre(:,:),scotem(:,:)
+!      real(Kind=fp_kind) ,  allocatable :: dh2o(:,:),dcont(:,:),dco2(:,:),do3(:,:)
+!      real(Kind=fp_kind) ,  allocatable :: dn2o(:,:),dch4(:,:)
+!      real(Kind=fp_kind) ,  allocatable :: df11(:,:),df12(:,:),df22(:,:)
+!      real(Kind=fp_kind) ,  allocatable :: th2o(:,:),tcon(:,:),tco2(:,:,:)
+!      real(Kind=fp_kind) ,  allocatable :: tn2o(:,:),tch4(:,:),tcom(:,:)
+!      real(Kind=fp_kind) ,  allocatable :: tf11(:),tf12(:),tf22(:)
+!      real(Kind=fp_kind) ,  allocatable :: h2oexp(:,:,:),conexp(:,:,:),co2exp(:,:,:,:)
+!      real(Kind=fp_kind) ,  allocatable :: n2oexp(:,:,:),ch4exp(:,:,:),comexp(:,:,:)
+!      real(Kind=fp_kind) ,  allocatable :: f11exp(:,:),f12exp(:,:),f22exp(:,:)
+!      real(Kind=fp_kind) ,  allocatable :: blayer(:,:),blevel(:,:),dblayr(:,:),dbs(:)
+!      real(Kind=fp_kind) ,  allocatable :: dp(:,:),cwp(:,:,:)
+!      real(Kind=fp_kind),allocatable :: trant(:),tranal(:),transfc(:,:),trantcr(:,:)
+!      real(Kind=fp_kind) ,  allocatable :: flxu(:,:),flxd(:,:),flcu(:,:),flcd(:,:)
+!      real(Kind=fp_kind) ,  allocatable :: rflx(:,:),rflc(:,:)
+!      integer,  allocatable :: it(:),im(:),ib(:)
+!      real(Kind=fp_kind),allocatable::cldhi(:),cldmd(:),cldlw(:),tcldlyr(:,:),fclr(:)
+!      real(Kind=fp_kind) ,  allocatable :: taerlyr(:,:)
+
+      integer i,j,k,ip,iw,ibn,ik,iq,isb,k1,k2
+      real(Kind=fp_kind) xx,yy,p1,dwe,dpe,a1,b1,fk1,a2,b2,fk2,bu,bd
+      real(Kind=fp_kind) w1,w2,w3,g1,g2,g3,ww,gg,ff,taux,reff1,reff2
+      real(Kind=fp_kind) tauxa
+
+      logical oznbnd,co2bnd,h2otbl,conbnd,n2obnd
+      logical ch4bnd,combnd,f11bnd,f12bnd,f22bnd,b10bnd
+
+!-----the following coefficients are given in table 2 for computing
+!     spectrally integrated planck fluxes using eq. (3.11)
+       data cb/ &
+            5.3443e+0,  -2.0617e-1,   2.5333e-3, &
+           -6.8633e-6,   1.0115e-8,  -6.2672e-12, &
+            2.7148e+1,  -5.4038e-1,   2.9501e-3, &
+            2.7228e-7,  -9.3384e-9,   9.9677e-12, &
+           -3.4860e+1,   1.1132e+0,  -1.3006e-2, &
+            6.4955e-5,  -1.1815e-7,   8.0424e-11, &
+           -6.0513e+1,   1.4087e+0,  -1.2077e-2, &
+            4.4050e-5,  -5.6735e-8,   2.5660e-11, &
+           -2.6689e+1,   5.2828e-1,  -3.4453e-3, &
+            6.0715e-6,   1.2523e-8,  -2.1550e-11, &
+           -6.7274e+0,   4.2256e-2,   1.0441e-3, &
+           -1.2917e-5,   4.7396e-8,  -4.4855e-11, &
+            1.8786e+1,  -5.8359e-1,   6.9674e-3, &
+           -3.9391e-5,   1.0120e-7,  -8.2301e-11, &
+            1.0344e+2,  -2.5134e+0,   2.3748e-2, &
+           -1.0692e-4,   2.1841e-7,  -1.3704e-10, &
+           -1.0482e+1,   3.8213e-1,  -5.2267e-3, &
+            3.4412e-5,  -1.1075e-7,   1.4092e-10, &
+            1.6769e+0,   6.5397e-2,  -1.8125e-3, &
+            1.2912e-5,  -2.6715e-8,   1.9792e-11/
+!-----xkw is the absorption coefficient are given in table 4 for the
+!     first k-distribution interval due to water vapor line absorption.
+!     units are cm**2/g
+      data xkw / 29.55  , 4.167e-1, 1.328e-2, 5.250e-4, &
+                 5.25e-4, 9.369e-3, 4.719e-2, 1.320e-0, 5.250e-4/
+!-----xke is the absorption coefficient given in table 9 for the first
+!     k-distribution function due to water vapor continuum absorption
+!     units are cm**2/g
+      data xke /  0.00,   0.00,   27.40,   15.8, &
+                  9.40,   7.75,    8.78,    0.0,   0.0/
+!-----mw is the ratio between neighboring absorption coefficients
+!     for water vapor line absorption (table 4).
+      data mw /6,6,8,6,6,8,9,6,16/
+!-----aw and bw (table 3) are the coefficients for temperature scaling
+!     in eq. (4.2).
+      data aw/ 0.0021, 0.0140, 0.0167, 0.0302, &
+               0.0307, 0.0195, 0.0152, 0.0008, 0.0096/
+      data bw/ -1.01e-5, 5.57e-5, 8.54e-5, 2.96e-4, &
+                2.86e-4, 1.108e-4, 7.608e-5, -3.52e-6, 1.64e-5/
+!-----pm is the pressure-scaling parameter for water vapor absorption
+!     eq. (4.1) and table 3.
+      data pm/ 1.0, 1.0, 1.0, 1.0, 1.0, 0.77, 0.5, 1.0, 1.0/
+!-----fkw is the planck-weighted k-distribution function due to h2o
+!     line absorption given in table 4.
+!     the k-distribution function for the third band, fkw(*,3),
+!     is not used (see the parameter gkw below).
+      data fkw / 0.2747,0.2717,0.2752,0.1177,0.0352,0.0255, &
+                 0.1521,0.3974,0.1778,0.1826,0.0374,0.0527, &
+                 6*1.00, &
+                 0.4654,0.2991,0.1343,0.0646,0.0226,0.0140, &
+                 0.5543,0.2723,0.1131,0.0443,0.0160,0.0000, &
+                 0.5955,0.2693,0.0953,0.0335,0.0064,0.0000, &
+                 0.1958,0.3469,0.3147,0.1013,0.0365,0.0048, &
+                 0.0740,0.1636,0.4174,0.1783,0.1101,0.0566, &
+                 0.1437,0.2197,0.3185,0.2351,0.0647,0.0183/
+!-----gkw is the planck-weighted k-distribution function due to h2o
+!     line absorption in the 3 subbands (800-720,620-720,540-620 /cm)
+!     of band 3 given in table 10.  note that the order of the sub-bands
+!     is reversed.
+      data gkw/  0.1782,0.0593,0.0215,0.0068,0.0022,0.0000, &
+                 0.0923,0.1675,0.0923,0.0187,0.0178,0.0000, &
+                 0.0000,0.1083,0.1581,0.0455,0.0274,0.0041/
+!-----ne is the number of terms used in each band to compute water vapor
+!     continuum transmittance (table 9).
+      data ne /0,0,3,1,1,1,1,0,0/
+!
+!-----coefficients for computing the extinction coefficient
+!     for cloud ice particles (table 11a, eq. 6.4a).
+!
+      data aib /  -0.44171,    0.62951,   0.06465, &
+                  -0.13727,    0.61291,   0.28962, &
+                  -0.01878,    1.67680,   0.79080, &
+                  -0.01896,    1.06510,   0.69493, &
+                  -0.04788,    0.88178,   0.54492, &
+                  -0.02265,    1.57390,   0.76161, &
+                  -0.01038,    2.15640,   0.89045, &
+                  -0.00450,    2.51370,   0.95989, &
+                  -0.00044,    3.15050,   1.03750, &
+                  -0.02956,    1.44680,   0.71283/
+!
+!-----coefficients for computing the extinction coefficient
+!     for cloud liquid drops. (table 11b, eq. 6.4b)
+!
+      data awb /   0.08641,    0.01769,    -1.5572e-3,   3.4896e-5, &
+                   0.22027,    0.00997,    -1.8719e-3,   5.3112e-5, &
+                   0.38074,   -0.03027,     1.0154e-3,  -1.1849e-5, &
+                   0.15587,    0.00371,    -7.7705e-4,   2.0547e-5, &
+                   0.05518,    0.04544,    -4.2067e-3,   1.0184e-4, &
+                   0.12724,    0.04751,    -5.2037e-3,   1.3711e-4, &
+                   0.30390,    0.01656,    -3.5271e-3,   1.0828e-4, &
+                   0.63617,   -0.06287,     2.2350e-3,  -2.3177e-5, &
+                   1.15470,   -0.19282,     1.2084e-2,  -2.5612e-4, &
+                   0.34021,   -0.02805,     1.0654e-3,  -1.5443e-5/
+!
+!-----coefficients for computing the single-scattering albedo
+!     for cloud ice particles. (table 12a, eq. 6.5)
+!
+      data aiw/    0.17201,    1.2229e-2,  -1.4837e-4,   5.8020e-7, &
+                   0.81470,   -2.7293e-3,   9.7816e-8,   5.7650e-8, &
+                   0.54859,   -4.8273e-4,   5.4353e-6,  -1.5679e-8, &
+                   0.39218,    4.1717e-3, - 4.8869e-5,   1.9144e-7, &
+                   0.71773,   -3.3640e-3,   1.9713e-5,  -3.3189e-8, &
+                   0.77345,   -5.5228e-3,   4.8379e-5,  -1.5151e-7, &
+                   0.74975,   -5.6604e-3,   5.6475e-5,  -1.9664e-7, &
+                   0.69011,   -4.5348e-3,   4.9322e-5,  -1.8255e-7, &
+                   0.83963,   -6.7253e-3,   6.1900e-5,  -2.0862e-7, &
+                   0.64860,   -2.8692e-3,   2.7656e-5,  -8.9680e-8/
+!
+!-----coefficients for computing the single-scattering albedo
+!     for cloud liquid drops. (table 12b, eq. 6.5)
+!
+      data aww/   -7.8566e-2,  8.0875e-2,  -4.3403e-3,   8.1341e-5, &
+                  -1.3384e-2,  9.3134e-2,  -6.0491e-3,   1.3059e-4, &
+                   3.7096e-2,  7.3211e-2,  -4.4211e-3,   9.2448e-5, &
+                  -3.7600e-3,  9.3344e-2,  -5.6561e-3,   1.1387e-4, &
+                   0.40212,    7.8083e-2,  -5.9583e-3,   1.2883e-4, &
+                   0.57928,    5.9094e-2,  -5.4425e-3,   1.2725e-4, &
+                   0.68974,    4.2334e-2,  -4.9469e-3,   1.2863e-4, &
+                   0.80122,    9.4578e-3,  -2.8508e-3,   9.0078e-5, &
+                   1.02340,   -2.6204e-2,   4.2552e-4,   3.2160e-6, &
+                   0.05092,    7.5409e-2,  -4.7305e-3,   1.0121e-4/
+!
+!-----coefficients for computing the asymmetry factor for cloud ice
+!     particles. (table 13a, eq. 6.6)
+!
+      data aig /   0.57867,    1.0135e-2,  -1.1142e-4,   4.1537e-7, &
+                   0.72259,    3.1149e-3,  -1.9927e-5,   5.6024e-8, &
+                   0.76109,    4.5449e-3,  -4.6199e-5,   1.6446e-7, &
+                   0.86934,    2.7474e-3,  -3.1301e-5,   1.1959e-7, &
+                   0.89103,    1.8513e-3,  -1.6551e-5,   5.5193e-8, &
+                   0.86325,    2.1408e-3,  -1.6846e-5,   4.9473e-8, &
+                   0.85064,    2.5028e-3,  -2.0812e-5,   6.3427e-8, &
+                   0.86945,    2.4615e-3,  -2.3882e-5,   8.2431e-8, &
+                   0.80122,    3.1906e-3,  -2.4856e-5,   7.2411e-8, &
+                   0.73290,    4.8034e-3,  -4.4425e-5,   1.4839e-7/
+!
+!-----coefficients for computing the asymmetry factor for cloud liquid
+!     drops. (table 13b, eq. 6.6)
+!
+      data awg /  -0.51930,    0.20290,    -1.1747e-2,   2.3868e-4, &
+                  -0.22151,    0.19708,    -1.2462e-2,   2.6646e-4, &
+                   0.14157,    0.14705,    -9.5802e-3,   2.0819e-4, &
+                   0.41590,    0.10482,    -6.9118e-3,   1.5115e-4, &
+                   0.55338,    7.7016e-2,  -5.2218e-3,   1.1587e-4, &
+                   0.61384,    6.4402e-2,  -4.6241e-3,   1.0746e-4, &
+                   0.67891,    4.8698e-2,  -3.7021e-3,   9.1966e-5, &
+                   0.78169,    2.0803e-2,  -1.4749e-3,   3.9362e-5, &
+                   0.93218,   -3.3425e-2,   2.9632e-3,  -6.9362e-5, &
+                   0.01649,    0.16561,    -1.0723e-2,   2.3220e-4/
+!
+!-----include tables used in the table look-up for co2 (band 3),
+!     o3 (band 5), and h2o (bands 1, 2, and 7) transmission functions.
+!     "co2.tran4" is the new co2 transmission table applicable to a large
+!     range of co2 amount (up to 100 times of the present-time value).
+!     include 'h2o.tran3'
+!     include 'co2.tran4'
+!     include 'o3.tran3'
+      data ((h11(ip,iw),iw=1,31), ip= 1, 1)/ &
+         0.99993843,  0.99990183,  0.99985260,  0.99979079,  0.99971771, &
+         0.99963379,  0.99953848,  0.99942899,  0.99930018,  0.99914461, &
+         0.99895102,  0.99870503,  0.99838799,  0.99797899,  0.99745202, &
+         0.99677002,  0.99587703,  0.99469399,  0.99311298,  0.99097902, &
+         0.98807001,  0.98409998,  0.97864997,  0.97114998,  0.96086001, &
+         0.94682997,  0.92777002,  0.90200001,  0.86739999,  0.82169998, &
+         0.76270002/
+      data ((h12(ip,iw),iw=1,31), ip= 1, 1)/ &
+        -0.2021e-06, -0.3628e-06, -0.5891e-06, -0.8735e-06, -0.1204e-05, &
+        -0.1579e-05, -0.2002e-05, -0.2494e-05, -0.3093e-05, -0.3852e-05, &
+        -0.4835e-05, -0.6082e-05, -0.7591e-05, -0.9332e-05, -0.1128e-04, &
+        -0.1347e-04, -0.1596e-04, -0.1890e-04, -0.2241e-04, -0.2672e-04, &
+        -0.3208e-04, -0.3884e-04, -0.4747e-04, -0.5854e-04, -0.7272e-04, &
+        -0.9092e-04, -0.1146e-03, -0.1458e-03, -0.1877e-03, -0.2435e-03, &
+        -0.3159e-03/
+      data ((h13(ip,iw),iw=1,31), ip= 1, 1)/ &
+         0.5907e-09,  0.8541e-09,  0.1095e-08,  0.1272e-08,  0.1297e-08, &
+         0.1105e-08,  0.6788e-09, -0.5585e-10, -0.1147e-08, -0.2746e-08, &
+        -0.5001e-08, -0.7715e-08, -0.1037e-07, -0.1227e-07, -0.1287e-07, &
+        -0.1175e-07, -0.8517e-08, -0.2920e-08,  0.4786e-08,  0.1407e-07, &
+         0.2476e-07,  0.3781e-07,  0.5633e-07,  0.8578e-07,  0.1322e-06, &
+         0.2013e-06,  0.3006e-06,  0.4409e-06,  0.6343e-06,  0.8896e-06, &
+         0.1216e-05/
+      data ((h11(ip,iw),iw=1,31), ip= 2, 2)/ &
+         0.99993837,  0.99990171,  0.99985230,  0.99979031,  0.99971670, &
+         0.99963200,  0.99953520,  0.99942321,  0.99928987,  0.99912637, &
+         0.99892002,  0.99865198,  0.99830002,  0.99783802,  0.99723297, &
+         0.99643701,  0.99537897,  0.99396098,  0.99204701,  0.98944002, &
+         0.98588002,  0.98098999,  0.97425997,  0.96502000,  0.95236999, &
+         0.93515998,  0.91184998,  0.88040000,  0.83859998,  0.78429997, &
+         0.71560001/
+      data ((h12(ip,iw),iw=1,31), ip= 2, 2)/ &
+        -0.2017e-06, -0.3620e-06, -0.5878e-06, -0.8713e-06, -0.1201e-05, &
+        -0.1572e-05, -0.1991e-05, -0.2476e-05, -0.3063e-05, -0.3808e-05, &
+        -0.4776e-05, -0.6011e-05, -0.7516e-05, -0.9272e-05, -0.1127e-04, &
+        -0.1355e-04, -0.1620e-04, -0.1936e-04, -0.2321e-04, -0.2797e-04, &
+        -0.3399e-04, -0.4171e-04, -0.5172e-04, -0.6471e-04, -0.8150e-04, &
+        -0.1034e-03, -0.1321e-03, -0.1705e-03, -0.2217e-03, -0.2889e-03, &
+        -0.3726e-03/
+      data ((h13(ip,iw),iw=1,31), ip= 2, 2)/ &
+         0.5894e-09,  0.8519e-09,  0.1092e-08,  0.1267e-08,  0.1289e-08, &
+         0.1093e-08,  0.6601e-09, -0.7831e-10, -0.1167e-08, -0.2732e-08, &
+        -0.4864e-08, -0.7334e-08, -0.9581e-08, -0.1097e-07, -0.1094e-07, &
+        -0.8999e-08, -0.4669e-08,  0.2391e-08,  0.1215e-07,  0.2424e-07, &
+         0.3877e-07,  0.5711e-07,  0.8295e-07,  0.1218e-06,  0.1793e-06, &
+         0.2621e-06,  0.3812e-06,  0.5508e-06,  0.7824e-06,  0.1085e-05, &
+         0.1462e-05/
+      data ((h11(ip,iw),iw=1,31), ip= 3, 3)/ &
+         0.99993825,  0.99990153,  0.99985188,  0.99978942,  0.99971509, &
+         0.99962920,  0.99953020,  0.99941432,  0.99927431,  0.99909937, &
+         0.99887401,  0.99857497,  0.99817699,  0.99764699,  0.99694097, &
+         0.99599802,  0.99473000,  0.99301600,  0.99068397,  0.98749000, &
+         0.98311001,  0.97707999,  0.96877003,  0.95738000,  0.94186002, &
+         0.92079002,  0.89230001,  0.85420001,  0.80430001,  0.74049997, &
+         0.66200000/
+      data ((h12(ip,iw),iw=1,31), ip= 3, 3)/ &
+        -0.2011e-06, -0.3609e-06, -0.5859e-06, -0.8680e-06, -0.1195e-05, &
+        -0.1563e-05, -0.1975e-05, -0.2450e-05, -0.3024e-05, -0.3755e-05, &
+        -0.4711e-05, -0.5941e-05, -0.7455e-05, -0.9248e-05, -0.1132e-04, &
+        -0.1373e-04, -0.1659e-04, -0.2004e-04, -0.2431e-04, -0.2966e-04, &
+        -0.3653e-04, -0.4549e-04, -0.5724e-04, -0.7259e-04, -0.9265e-04, &
+        -0.1191e-03, -0.1543e-03, -0.2013e-03, -0.2633e-03, -0.3421e-03, &
+        -0.4350e-03/
+      data ((h13(ip,iw),iw=1,31), ip= 3, 3)/ &
+         0.5872e-09,  0.8484e-09,  0.1087e-08,  0.1259e-08,  0.1279e-08, &
+         0.1077e-08,  0.6413e-09, -0.9334e-10, -0.1161e-08, -0.2644e-08, &
+        -0.4588e-08, -0.6709e-08, -0.8474e-08, -0.9263e-08, -0.8489e-08, &
+        -0.5553e-08,  0.1203e-09,  0.9035e-08,  0.2135e-07,  0.3689e-07, &
+         0.5610e-07,  0.8097e-07,  0.1155e-06,  0.1649e-06,  0.2350e-06, &
+         0.3353e-06,  0.4806e-06,  0.6858e-06,  0.9617e-06,  0.1315e-05, &
+         0.1741e-05/
+      data ((h11(ip,iw),iw=1,31), ip= 4, 4)/ &
+         0.99993813,  0.99990118,  0.99985123,  0.99978811,  0.99971271, &
+         0.99962479,  0.99952239,  0.99940068,  0.99925101,  0.99905968, &
+         0.99880803,  0.99846900,  0.99800998,  0.99738997,  0.99655402, &
+         0.99542397,  0.99389100,  0.99180400,  0.98895001,  0.98501998, &
+         0.97961003,  0.97215003,  0.96191001,  0.94791001,  0.92887998, &
+         0.90311998,  0.86849999,  0.82270002,  0.76370001,  0.69000000, &
+         0.60240000/
+      data ((h12(ip,iw),iw=1,31), ip= 4, 4)/ &
+        -0.2001e-06, -0.3592e-06, -0.5829e-06, -0.8631e-06, -0.1187e-05, &
+        -0.1549e-05, -0.1953e-05, -0.2415e-05, -0.2975e-05, -0.3694e-05, &
+        -0.4645e-05, -0.5882e-05, -0.7425e-05, -0.9279e-05, -0.1147e-04, &
+        -0.1406e-04, -0.1717e-04, -0.2100e-04, -0.2580e-04, -0.3191e-04, &
+        -0.3989e-04, -0.5042e-04, -0.6432e-04, -0.8261e-04, -0.1068e-03, &
+        -0.1389e-03, -0.1820e-03, -0.2391e-03, -0.3127e-03, -0.4021e-03, &
+        -0.5002e-03/
+      data ((h13(ip,iw),iw=1,31), ip= 4, 4)/ &
+         0.5838e-09,  0.8426e-09,  0.1081e-08,  0.1249e-08,  0.1267e-08, &
+         0.1062e-08,  0.6313e-09, -0.8241e-10, -0.1094e-08, -0.2436e-08, &
+        -0.4100e-08, -0.5786e-08, -0.6992e-08, -0.7083e-08, -0.5405e-08, &
+        -0.1259e-08,  0.6099e-08,  0.1732e-07,  0.3276e-07,  0.5256e-07, &
+         0.7756e-07,  0.1103e-06,  0.1547e-06,  0.2159e-06,  0.3016e-06, &
+         0.4251e-06,  0.6033e-06,  0.8499e-06,  0.1175e-05,  0.1579e-05, &
+         0.2044e-05/
+      data ((h11(ip,iw),iw=1,31), ip= 5, 5)/ &
+         0.99993789,  0.99990070,  0.99985009,  0.99978602,  0.99970889, &
+         0.99961799,  0.99951053,  0.99938041,  0.99921662,  0.99900270, &
+         0.99871498,  0.99832201,  0.99778402,  0.99704897,  0.99604702, &
+         0.99468100,  0.99281400,  0.99025702,  0.98673999,  0.98189002, &
+         0.97521001,  0.96600002,  0.95337999,  0.93620998,  0.91292000, &
+         0.88150001,  0.83969998,  0.78530002,  0.71650004,  0.63330001, &
+         0.53799999/
+      data ((h12(ip,iw),iw=1,31), ip= 5, 5)/ &
+        -0.1987e-06, -0.3565e-06, -0.5784e-06, -0.8557e-06, -0.1175e-05, &
+        -0.1530e-05, -0.1923e-05, -0.2372e-05, -0.2919e-05, -0.3631e-05, &
+        -0.4587e-05, -0.5848e-05, -0.7442e-05, -0.9391e-05, -0.1173e-04, &
+        -0.1455e-04, -0.1801e-04, -0.2232e-04, -0.2779e-04, -0.3489e-04, &
+        -0.4428e-04, -0.5678e-04, -0.7333e-04, -0.9530e-04, -0.1246e-03, &
+        -0.1639e-03, -0.2164e-03, -0.2848e-03, -0.3697e-03, -0.4665e-03, &
+        -0.5646e-03/
+      data ((h13(ip,iw),iw=1,31), ip= 5, 5)/ &
+         0.5785e-09,  0.8338e-09,  0.1071e-08,  0.1239e-08,  0.1256e-08, &
+         0.1057e-08,  0.6480e-09, -0.1793e-10, -0.9278e-09, -0.2051e-08, &
+        -0.3337e-08, -0.4514e-08, -0.5067e-08, -0.4328e-08, -0.1545e-08, &
+         0.4100e-08,  0.1354e-07,  0.2762e-07,  0.4690e-07,  0.7190e-07, &
+         0.1040e-06,  0.1459e-06,  0.2014e-06,  0.2764e-06,  0.3824e-06, &
+         0.5359e-06,  0.7532e-06,  0.1047e-05,  0.1424e-05,  0.1873e-05, &
+         0.2356e-05/
+      data ((h11(ip,iw),iw=1,31), ip= 6, 6)/ &
+         0.99993753,  0.99989992,  0.99984848,  0.99978292,  0.99970299, &
+         0.99960762,  0.99949282,  0.99935049,  0.99916708,  0.99892199, &
+         0.99858701,  0.99812400,  0.99748403,  0.99660099,  0.99538797, &
+         0.99372399,  0.99143797,  0.98829001,  0.98395002,  0.97794998, &
+         0.96968001,  0.95832998,  0.94283003,  0.92179000,  0.89330000, &
+         0.85530001,  0.80519998,  0.74140000,  0.66280001,  0.57099998, &
+         0.47049999/
+      data ((h12(ip,iw),iw=1,31), ip= 6, 6)/ &
+        -0.1964e-06, -0.3526e-06, -0.5717e-06, -0.8451e-06, -0.1158e-05, &
+        -0.1504e-05, -0.1886e-05, -0.2322e-05, -0.2861e-05, -0.3576e-05, &
+        -0.4552e-05, -0.5856e-05, -0.7529e-05, -0.9609e-05, -0.1216e-04, &
+        -0.1528e-04, -0.1916e-04, -0.2408e-04, -0.3043e-04, -0.3880e-04, &
+        -0.4997e-04, -0.6488e-04, -0.8474e-04, -0.1113e-03, -0.1471e-03, &
+        -0.1950e-03, -0.2583e-03, -0.3384e-03, -0.4326e-03, -0.5319e-03, &
+        -0.6244e-03/
+      data ((h13(ip,iw),iw=1,31), ip= 6, 6)/ &
+         0.5713e-09,  0.8263e-09,  0.1060e-08,  0.1226e-08,  0.1252e-08, &
+         0.1076e-08,  0.7149e-09,  0.1379e-09, -0.6043e-09, -0.1417e-08, &
+        -0.2241e-08, -0.2830e-08, -0.2627e-08, -0.8950e-09,  0.3231e-08, &
+         0.1075e-07,  0.2278e-07,  0.4037e-07,  0.6439e-07,  0.9576e-07, &
+         0.1363e-06,  0.1886e-06,  0.2567e-06,  0.3494e-06,  0.4821e-06, &
+         0.6719e-06,  0.9343e-06,  0.1280e-05,  0.1705e-05,  0.2184e-05, &
+         0.2651e-05/
+      data ((h11(ip,iw),iw=1,31), ip= 7, 7)/ &
+         0.99993700,  0.99989867,  0.99984592,  0.99977797,  0.99969423, &
+         0.99959219,  0.99946660,  0.99930722,  0.99909681,  0.99880999, &
+         0.99841303,  0.99786001,  0.99708802,  0.99601799,  0.99453998, &
+         0.99250001,  0.98969001,  0.98580003,  0.98041999,  0.97299999, &
+         0.96279001,  0.94881999,  0.92980999,  0.90407002,  0.86949998, &
+         0.82370001,  0.76459998,  0.69089997,  0.60310000,  0.50479996, &
+         0.40219998/
+      data ((h12(ip,iw),iw=1,31), ip= 7, 7)/ &
+        -0.1932e-06, -0.3467e-06, -0.5623e-06, -0.8306e-06, -0.1136e-05, &
+        -0.1472e-05, -0.1842e-05, -0.2269e-05, -0.2807e-05, -0.3539e-05, &
+        -0.4553e-05, -0.5925e-05, -0.7710e-05, -0.9968e-05, -0.1278e-04, &
+        -0.1629e-04, -0.2073e-04, -0.2644e-04, -0.3392e-04, -0.4390e-04, &
+        -0.5727e-04, -0.7516e-04, -0.9916e-04, -0.1315e-03, -0.1752e-03, &
+        -0.2333e-03, -0.3082e-03, -0.3988e-03, -0.4982e-03, -0.5947e-03, &
+        -0.6764e-03/
+      data ((h13(ip,iw),iw=1,31), ip= 7, 7)/ &
+         0.5612e-09,  0.8116e-09,  0.1048e-08,  0.1222e-08,  0.1270e-08, &
+         0.1141e-08,  0.8732e-09,  0.4336e-09, -0.6548e-10, -0.4774e-09, &
+        -0.7556e-09, -0.6577e-09,  0.4377e-09,  0.3359e-08,  0.9159e-08, &
+         0.1901e-07,  0.3422e-07,  0.5616e-07,  0.8598e-07,  0.1251e-06, &
+         0.1752e-06,  0.2392e-06,  0.3228e-06,  0.4389e-06,  0.6049e-06, &
+         0.8370e-06,  0.1150e-05,  0.1547e-05,  0.2012e-05,  0.2493e-05, &
+         0.2913e-05/
+      data ((h11(ip,iw),iw=1,31), ip= 8, 8)/ &
+         0.99993622,  0.99989682,  0.99984211,  0.99977070,  0.99968100, &
+         0.99956948,  0.99942881,  0.99924588,  0.99899900,  0.99865800, &
+         0.99818099,  0.99751103,  0.99657297,  0.99526602,  0.99345201, &
+         0.99094099,  0.98746002,  0.98264998,  0.97599000,  0.96682000, &
+         0.95423001,  0.93708003,  0.91380000,  0.88239998,  0.84060001, &
+         0.78610003,  0.71730000,  0.63400000,  0.53859997,  0.43660003, &
+         0.33510000/
+      data ((h12(ip,iw),iw=1,31), ip= 8, 8)/ &
+        -0.1885e-06, -0.3385e-06, -0.5493e-06, -0.8114e-06, -0.1109e-05, &
+        -0.1436e-05, -0.1796e-05, -0.2219e-05, -0.2770e-05, -0.3535e-05, &
+        -0.4609e-05, -0.6077e-05, -0.8016e-05, -0.1051e-04, -0.1367e-04, &
+        -0.1768e-04, -0.2283e-04, -0.2955e-04, -0.3849e-04, -0.5046e-04, &
+        -0.6653e-04, -0.8813e-04, -0.1173e-03, -0.1569e-03, -0.2100e-03, &
+        -0.2794e-03, -0.3656e-03, -0.4637e-03, -0.5629e-03, -0.6512e-03, &
+        -0.7167e-03/
+      data ((h13(ip,iw),iw=1,31), ip= 8, 8)/ &
+         0.5477e-09,  0.8000e-09,  0.1039e-08,  0.1234e-08,  0.1331e-08, &
+         0.1295e-08,  0.1160e-08,  0.9178e-09,  0.7535e-09,  0.8301e-09, &
+         0.1184e-08,  0.2082e-08,  0.4253e-08,  0.8646e-08,  0.1650e-07, &
+         0.2920e-07,  0.4834e-07,  0.7564e-07,  0.1125e-06,  0.1606e-06, &
+         0.2216e-06,  0.2992e-06,  0.4031e-06,  0.5493e-06,  0.7549e-06, &
+         0.1035e-05,  0.1400e-05,  0.1843e-05,  0.2327e-05,  0.2774e-05, &
+         0.3143e-05/
+      data ((h11(ip,iw),iw=1,31), ip= 9, 9)/ &
+         0.99993503,  0.99989408,  0.99983650,  0.99975997,  0.99966192, &
+         0.99953687,  0.99937540,  0.99916059,  0.99886602,  0.99845397, &
+         0.99787402,  0.99705601,  0.99590701,  0.99430102,  0.99206603, &
+         0.98896003,  0.98465002,  0.97869003,  0.97044003,  0.95911002, &
+         0.94363999,  0.92260998,  0.89419997,  0.85609996,  0.80610001, &
+         0.74220002,  0.66359997,  0.57169998,  0.47100002,  0.36860001, &
+         0.27079999/
+      data ((h12(ip,iw),iw=1,31), ip= 9, 9)/ &
+        -0.1822e-06, -0.3274e-06, -0.5325e-06, -0.7881e-06, -0.1079e-05, &
+        -0.1398e-05, -0.1754e-05, -0.2184e-05, -0.2763e-05, -0.3581e-05, &
+        -0.4739e-05, -0.6341e-05, -0.8484e-05, -0.1128e-04, -0.1490e-04, &
+        -0.1955e-04, -0.2561e-04, -0.3364e-04, -0.4438e-04, -0.5881e-04, &
+        -0.7822e-04, -0.1045e-03, -0.1401e-03, -0.1884e-03, -0.2523e-03, &
+        -0.3335e-03, -0.4289e-03, -0.5296e-03, -0.6231e-03, -0.6980e-03, &
+        -0.7406e-03/
+      data ((h13(ip,iw),iw=1,31), ip= 9, 9)/ &
+         0.5334e-09,  0.7859e-09,  0.1043e-08,  0.1279e-08,  0.1460e-08, &
+         0.1560e-08,  0.1618e-08,  0.1657e-08,  0.1912e-08,  0.2569e-08, &
+         0.3654e-08,  0.5509e-08,  0.8964e-08,  0.1518e-07,  0.2560e-07, &
+         0.4178e-07,  0.6574e-07,  0.9958e-07,  0.1449e-06,  0.2031e-06, &
+         0.2766e-06,  0.3718e-06,  0.5022e-06,  0.6849e-06,  0.9360e-06, &
+         0.1268e-05,  0.1683e-05,  0.2157e-05,  0.2625e-05,  0.3020e-05, &
+         0.3364e-05/
+      data ((h11(ip,iw),iw=1,31), ip=10,10)/ &
+         0.99993336,  0.99989021,  0.99982840,  0.99974459,  0.99963468, &
+         0.99949121,  0.99930137,  0.99904430,  0.99868703,  0.99818403, &
+         0.99747300,  0.99646801,  0.99505299,  0.99307102,  0.99030602, &
+         0.98645997,  0.98111999,  0.97372001,  0.96353000,  0.94957000, &
+         0.93058997,  0.90486002,  0.87029999,  0.82449996,  0.76530004, &
+         0.69159997,  0.60380000,  0.50529999,  0.40259999,  0.30269998, &
+         0.21020001/
+      data ((h12(ip,iw),iw=1,31), ip=10,10)/ &
+        -0.1742e-06, -0.3134e-06, -0.5121e-06, -0.7619e-06, -0.1048e-05, &
+        -0.1364e-05, -0.1725e-05, -0.2177e-05, -0.2801e-05, -0.3694e-05, &
+        -0.4969e-05, -0.6748e-05, -0.9161e-05, -0.1236e-04, -0.1655e-04, &
+        -0.2203e-04, -0.2927e-04, -0.3894e-04, -0.5192e-04, -0.6936e-04, &
+        -0.9294e-04, -0.1250e-03, -0.1686e-03, -0.2271e-03, -0.3027e-03, &
+        -0.3944e-03, -0.4951e-03, -0.5928e-03, -0.6755e-03, -0.7309e-03, &
+        -0.7417e-03/
+      data ((h13(ip,iw),iw=1,31), ip=10,10)/ &
+         0.5179e-09,  0.7789e-09,  0.1071e-08,  0.1382e-08,  0.1690e-08, &
+         0.1979e-08,  0.2297e-08,  0.2704e-08,  0.3466e-08,  0.4794e-08, &
+         0.6746e-08,  0.9739e-08,  0.1481e-07,  0.2331e-07,  0.3679e-07, &
+         0.5726e-07,  0.8716e-07,  0.1289e-06,  0.1837e-06,  0.2534e-06, &
+         0.3424e-06,  0.4609e-06,  0.6245e-06,  0.8495e-06,  0.1151e-05, &
+         0.1536e-05,  0.1991e-05,  0.2468e-05,  0.2891e-05,  0.3245e-05, &
+         0.3580e-05/
+      data ((h11(ip,iw),iw=1,31), ip=11,11)/ &
+         0.99993110,  0.99988490,  0.99981719,  0.99972337,  0.99959719, &
+         0.99942869,  0.99920130,  0.99888903,  0.99845201,  0.99783301, &
+         0.99695599,  0.99571502,  0.99396503,  0.99150997,  0.98808002, &
+         0.98329997,  0.97667003,  0.96750998,  0.95494002,  0.93779999, &
+         0.91453999,  0.88319999,  0.84130001,  0.78689998,  0.71799999, &
+         0.63470000,  0.53909999,  0.43699998,  0.33550000,  0.24010003, &
+         0.15420002/
+      data ((h12(ip,iw),iw=1,31), ip=11,11)/ &
+        -0.1647e-06, -0.2974e-06, -0.4900e-06, -0.7358e-06, -0.1022e-05, &
+        -0.1344e-05, -0.1721e-05, -0.2212e-05, -0.2901e-05, -0.3896e-05, &
+        -0.5327e-05, -0.7342e-05, -0.1011e-04, -0.1382e-04, -0.1875e-04, &
+        -0.2530e-04, -0.3403e-04, -0.4573e-04, -0.6145e-04, -0.8264e-04, &
+        -0.1114e-03, -0.1507e-03, -0.2039e-03, -0.2737e-03, -0.3607e-03, &
+        -0.4599e-03, -0.5604e-03, -0.6497e-03, -0.7161e-03, -0.7443e-03, &
+        -0.7133e-03/
+      data ((h13(ip,iw),iw=1,31), ip=11,11)/ &
+         0.5073e-09,  0.7906e-09,  0.1134e-08,  0.1560e-08,  0.2046e-08, &
+         0.2589e-08,  0.3254e-08,  0.4107e-08,  0.5481e-08,  0.7602e-08, &
+         0.1059e-07,  0.1501e-07,  0.2210e-07,  0.3334e-07,  0.5055e-07, &
+         0.7629e-07,  0.1134e-06,  0.1642e-06,  0.2298e-06,  0.3133e-06, &
+         0.4225e-06,  0.5709e-06,  0.7739e-06,  0.1047e-05,  0.1401e-05, &
+         0.1833e-05,  0.2308e-05,  0.2753e-05,  0.3125e-05,  0.3467e-05, &
+         0.3748e-05/
+      data ((h11(ip,iw),iw=1,31), ip=12,12)/ &
+         0.99992824,  0.99987793,  0.99980247,  0.99969512,  0.99954712, &
+         0.99934530,  0.99906880,  0.99868500,  0.99814498,  0.99738002, &
+         0.99629498,  0.99475700,  0.99258602,  0.98953998,  0.98527998, &
+         0.97934997,  0.97112000,  0.95981002,  0.94433999,  0.92332000, &
+         0.89490002,  0.85680002,  0.80680001,  0.74290001,  0.66420001, &
+         0.57220000,  0.47149998,  0.36900002,  0.27109998,  0.18159997, &
+         0.10460001/
+      data ((h12(ip,iw),iw=1,31), ip=12,12)/ &
+        -0.1548e-06, -0.2808e-06, -0.4683e-06, -0.7142e-06, -0.1008e-05, &
+        -0.1347e-05, -0.1758e-05, -0.2306e-05, -0.3083e-05, -0.4214e-05, &
+        -0.5851e-05, -0.8175e-05, -0.1140e-04, -0.1577e-04, -0.2166e-04, &
+        -0.2955e-04, -0.4014e-04, -0.5434e-04, -0.7343e-04, -0.9931e-04, &
+        -0.1346e-03, -0.1826e-03, -0.2467e-03, -0.3283e-03, -0.4246e-03, &
+        -0.5264e-03, -0.6211e-03, -0.6970e-03, -0.7402e-03, -0.7316e-03, &
+        -0.6486e-03/
+      data ((h13(ip,iw),iw=1,31), ip=12,12)/ &
+         0.5078e-09,  0.8244e-09,  0.1255e-08,  0.1826e-08,  0.2550e-08, &
+         0.3438e-08,  0.4532e-08,  0.5949e-08,  0.8041e-08,  0.1110e-07, &
+         0.1534e-07,  0.2157e-07,  0.3116e-07,  0.4570e-07,  0.6747e-07, &
+         0.9961e-07,  0.1451e-06,  0.2061e-06,  0.2843e-06,  0.3855e-06, &
+         0.5213e-06,  0.7060e-06,  0.9544e-06,  0.1280e-05,  0.1684e-05, &
+         0.2148e-05,  0.2609e-05,  0.3002e-05,  0.3349e-05,  0.3670e-05, &
+         0.3780e-05/
+      data ((h11(ip,iw),iw=1,31), ip=13,13)/ &
+         0.99992472,  0.99986941,  0.99978399,  0.99965900,  0.99948251, &
+         0.99923742,  0.99889702,  0.99842298,  0.99775398,  0.99680400, &
+         0.99545598,  0.99354500,  0.99084800,  0.98706001,  0.98176998, &
+         0.97439998,  0.96423000,  0.95029002,  0.93129998,  0.90557003, &
+         0.87099999,  0.82520002,  0.76600003,  0.69220001,  0.60440004, &
+         0.50580001,  0.40310001,  0.30299997,  0.21039999,  0.12860000, &
+         0.06360000/
+      data ((h12(ip,iw),iw=1,31), ip=13,13)/ &
+        -0.1461e-06, -0.2663e-06, -0.4512e-06, -0.7027e-06, -0.1014e-05, &
+        -0.1387e-05, -0.1851e-05, -0.2478e-05, -0.3373e-05, -0.4682e-05, &
+        -0.6588e-05, -0.9311e-05, -0.1311e-04, -0.1834e-04, -0.2544e-04, &
+        -0.3502e-04, -0.4789e-04, -0.6515e-04, -0.8846e-04, -0.1202e-03, &
+        -0.1635e-03, -0.2217e-03, -0.2975e-03, -0.3897e-03, -0.4913e-03, &
+        -0.5902e-03, -0.6740e-03, -0.7302e-03, -0.7415e-03, -0.6858e-03, &
+        -0.5447e-03/
+      data ((h13(ip,iw),iw=1,31), ip=13,13)/ &
+         0.5236e-09,  0.8873e-09,  0.1426e-08,  0.2193e-08,  0.3230e-08, &
+         0.4555e-08,  0.6200e-08,  0.8298e-08,  0.1126e-07,  0.1544e-07, &
+         0.2130e-07,  0.2978e-07,  0.4239e-07,  0.6096e-07,  0.8829e-07, &
+         0.1280e-06,  0.1830e-06,  0.2555e-06,  0.3493e-06,  0.4740e-06, &
+         0.6431e-06,  0.8701e-06,  0.1169e-05,  0.1547e-05,  0.1992e-05, &
+         0.2460e-05,  0.2877e-05,  0.3230e-05,  0.3569e-05,  0.3782e-05, &
+         0.3591e-05/
+      data ((h11(ip,iw),iw=1,31), ip=14,14)/ &
+         0.99992090,  0.99985969,  0.99976218,  0.99961531,  0.99940270, &
+         0.99910218,  0.99868101,  0.99809098,  0.99725902,  0.99607700, &
+         0.99440002,  0.99202299,  0.98866999,  0.98395997,  0.97737998, &
+         0.96825999,  0.95570999,  0.93857002,  0.91531003,  0.88389999, &
+         0.84210002,  0.78759998,  0.71869999,  0.63530004,  0.53970003, &
+         0.43750000,  0.33590001,  0.24040002,  0.15439999,  0.08300000, &
+         0.03299999/
+      data ((h12(ip,iw),iw=1,31), ip=14,14)/ &
+        -0.1402e-06, -0.2569e-06, -0.4428e-06, -0.7076e-06, -0.1051e-05, &
+        -0.1478e-05, -0.2019e-05, -0.2752e-05, -0.3802e-05, -0.5343e-05, &
+        -0.7594e-05, -0.1082e-04, -0.1536e-04, -0.2166e-04, -0.3028e-04, &
+        -0.4195e-04, -0.5761e-04, -0.7867e-04, -0.1072e-03, -0.1462e-03, &
+        -0.1990e-03, -0.2687e-03, -0.3559e-03, -0.4558e-03, -0.5572e-03, &
+        -0.6476e-03, -0.7150e-03, -0.7439e-03, -0.7133e-03, -0.6015e-03, &
+        -0.4089e-03/
+      data ((h13(ip,iw),iw=1,31), ip=14,14)/ &
+         0.5531e-09,  0.9757e-09,  0.1644e-08,  0.2650e-08,  0.4074e-08, &
+         0.5957e-08,  0.8314e-08,  0.1128e-07,  0.1528e-07,  0.2087e-07, &
+         0.2874e-07,  0.4002e-07,  0.5631e-07,  0.7981e-07,  0.1139e-06, &
+         0.1621e-06,  0.2275e-06,  0.3136e-06,  0.4280e-06,  0.5829e-06, &
+         0.7917e-06,  0.1067e-05,  0.1419e-05,  0.1844e-05,  0.2310e-05, &
+         0.2747e-05,  0.3113e-05,  0.3455e-05,  0.3739e-05,  0.3715e-05, &
+         0.3125e-05/
+      data ((h11(ip,iw),iw=1,31), ip=15,15)/ &
+         0.99991709,  0.99984968,  0.99973857,  0.99956548,  0.99930853, &
+         0.99893898,  0.99841601,  0.99768001,  0.99664098,  0.99516898, &
+         0.99308002,  0.99012297,  0.98594999,  0.98009998,  0.97194999, &
+         0.96066999,  0.94523001,  0.92421001,  0.89579999,  0.85769999, &
+         0.80760002,  0.74360001,  0.66490000,  0.57290000,  0.47200000, &
+         0.36940002,  0.27139997,  0.18180001,  0.10479999,  0.04699999, &
+         0.01359999/
+      data ((h12(ip,iw),iw=1,31), ip=15,15)/ &
+        -0.1378e-06, -0.2542e-06, -0.4461e-06, -0.7333e-06, -0.1125e-05, &
+        -0.1630e-05, -0.2281e-05, -0.3159e-05, -0.4410e-05, -0.6246e-05, &
+        -0.8933e-05, -0.1280e-04, -0.1826e-04, -0.2589e-04, -0.3639e-04, &
+        -0.5059e-04, -0.6970e-04, -0.9552e-04, -0.1307e-03, -0.1784e-03, &
+        -0.2422e-03, -0.3237e-03, -0.4203e-03, -0.5227e-03, -0.6184e-03, &
+        -0.6953e-03, -0.7395e-03, -0.7315e-03, -0.6487e-03, -0.4799e-03, &
+        -0.2625e-03/
+      data ((h13(ip,iw),iw=1,31), ip=15,15)/ &
+         0.5891e-09,  0.1074e-08,  0.1885e-08,  0.3167e-08,  0.5051e-08, &
+         0.7631e-08,  0.1092e-07,  0.1500e-07,  0.2032e-07,  0.2769e-07, &
+         0.3810e-07,  0.5279e-07,  0.7361e-07,  0.1032e-06,  0.1450e-06, &
+         0.2026e-06,  0.2798e-06,  0.3832e-06,  0.5242e-06,  0.7159e-06, &
+         0.9706e-06,  0.1299e-05,  0.1701e-05,  0.2159e-05,  0.2612e-05, &
+         0.2998e-05,  0.3341e-05,  0.3661e-05,  0.3775e-05,  0.3393e-05, &
+         0.2384e-05/
+      data ((h11(ip,iw),iw=1,31), ip=16,16)/ &
+         0.99991363,  0.99984020,  0.99971467,  0.99951237,  0.99920303, &
+         0.99874902,  0.99809903,  0.99717999,  0.99588197,  0.99404502, &
+         0.99144298,  0.98776001,  0.98258001,  0.97533000,  0.96524000, &
+         0.95135999,  0.93241000,  0.90667999,  0.87199998,  0.82620001, &
+         0.76700002,  0.69309998,  0.60510004,  0.50650001,  0.40359998, &
+         0.30350000,  0.21069998,  0.12870002,  0.06370002,  0.02200001, &
+         0.00389999/
+      data ((h12(ip,iw),iw=1,31), ip=16,16)/ &
+        -0.1383e-06, -0.2577e-06, -0.4608e-06, -0.7793e-06, -0.1237e-05, &
+        -0.1850e-05, -0.2652e-05, -0.3728e-05, -0.5244e-05, -0.7451e-05, &
+        -0.1067e-04, -0.1532e-04, -0.2193e-04, -0.3119e-04, -0.4395e-04, &
+        -0.6126e-04, -0.8466e-04, -0.1164e-03, -0.1596e-03, -0.2177e-03, &
+        -0.2933e-03, -0.3855e-03, -0.4874e-03, -0.5870e-03, -0.6718e-03, &
+        -0.7290e-03, -0.7411e-03, -0.6859e-03, -0.5450e-03, -0.3353e-03, &
+        -0.1363e-03/
+      data ((h13(ip,iw),iw=1,31), ip=16,16)/ &
+         0.6217e-09,  0.1165e-08,  0.2116e-08,  0.3685e-08,  0.6101e-08, &
+         0.9523e-08,  0.1400e-07,  0.1959e-07,  0.2668e-07,  0.3629e-07, &
+         0.4982e-07,  0.6876e-07,  0.9523e-07,  0.1321e-06,  0.1825e-06, &
+         0.2505e-06,  0.3420e-06,  0.4677e-06,  0.6416e-06,  0.8760e-06, &
+         0.1183e-05,  0.1565e-05,  0.2010e-05,  0.2472e-05,  0.2882e-05, &
+         0.3229e-05,  0.3564e-05,  0.3777e-05,  0.3589e-05,  0.2786e-05, &
+         0.1487e-05/
+      data ((h11(ip,iw),iw=1,31), ip=17,17)/ &
+         0.99991077,  0.99983180,  0.99969262,  0.99945968,  0.99909151, &
+         0.99853700,  0.99773198,  0.99658400,  0.99496001,  0.99266702, &
+         0.98943001,  0.98484999,  0.97842997,  0.96945000,  0.95703000, &
+         0.93998998,  0.91676998,  0.88540000,  0.84350002,  0.78890002, &
+         0.71990001,  0.63639998,  0.54060000,  0.43820000,  0.33639997, &
+         0.24080002,  0.15460002,  0.08310002,  0.03310001,  0.00770003, &
+         0.00050002/
+      data ((h12(ip,iw),iw=1,31), ip=17,17)/ &
+        -0.1405e-06, -0.2649e-06, -0.4829e-06, -0.8398e-06, -0.1379e-05, &
+        -0.2132e-05, -0.3138e-05, -0.4487e-05, -0.6353e-05, -0.9026e-05, &
+        -0.1290e-04, -0.1851e-04, -0.2650e-04, -0.3772e-04, -0.5319e-04, &
+        -0.7431e-04, -0.1031e-03, -0.1422e-03, -0.1951e-03, -0.2648e-03, &
+        -0.3519e-03, -0.4518e-03, -0.5537e-03, -0.6449e-03, -0.7133e-03, &
+        -0.7432e-03, -0.7133e-03, -0.6018e-03, -0.4092e-03, -0.1951e-03, &
+        -0.5345e-04/
+      data ((h13(ip,iw),iw=1,31), ip=17,17)/ &
+         0.6457e-09,  0.1235e-08,  0.2303e-08,  0.4149e-08,  0.7120e-08, &
+         0.1152e-07,  0.1749e-07,  0.2508e-07,  0.3462e-07,  0.4718e-07, &
+         0.6452e-07,  0.8874e-07,  0.1222e-06,  0.1675e-06,  0.2276e-06, &
+         0.3076e-06,  0.4174e-06,  0.5714e-06,  0.7837e-06,  0.1067e-05, &
+         0.1428e-05,  0.1859e-05,  0.2327e-05,  0.2760e-05,  0.3122e-05, &
+         0.3458e-05,  0.3739e-05,  0.3715e-05,  0.3126e-05,  0.1942e-05, &
+         0.6977e-06/
+      data ((h11(ip,iw),iw=1,31), ip=18,18)/ &
+         0.99990851,  0.99982500,  0.99967349,  0.99941093,  0.99897999, &
+         0.99831200,  0.99732101,  0.99589097,  0.99386197,  0.99099803, &
+         0.98695999,  0.98128998,  0.97333002,  0.96227002,  0.94700998, &
+         0.92614001,  0.89779997,  0.85969996,  0.80949998,  0.74540001, &
+         0.66649997,  0.57420003,  0.47310001,  0.37029999,  0.27200001, &
+         0.18220001,  0.10500002,  0.04710001,  0.01359999,  0.00169998, &
+         0.00000000/
+      data ((h12(ip,iw),iw=1,31), ip=18,18)/ &
+        -0.1431e-06, -0.2731e-06, -0.5072e-06, -0.9057e-06, -0.1537e-05, &
+        -0.2460e-05, -0.3733e-05, -0.5449e-05, -0.7786e-05, -0.1106e-04, &
+        -0.1574e-04, -0.2249e-04, -0.3212e-04, -0.4564e-04, -0.6438e-04, &
+        -0.9019e-04, -0.1256e-03, -0.1737e-03, -0.2378e-03, -0.3196e-03, &
+        -0.4163e-03, -0.5191e-03, -0.6154e-03, -0.6931e-03, -0.7384e-03, &
+        -0.7313e-03, -0.6492e-03, -0.4805e-03, -0.2629e-03, -0.8897e-04, &
+        -0.1432e-04/
+      data ((h13(ip,iw),iw=1,31), ip=18,18)/ &
+         0.6607e-09,  0.1282e-08,  0.2441e-08,  0.4522e-08,  0.8027e-08, &
+         0.1348e-07,  0.2122e-07,  0.3139e-07,  0.4435e-07,  0.6095e-07, &
+         0.8319e-07,  0.1139e-06,  0.1557e-06,  0.2107e-06,  0.2819e-06, &
+         0.3773e-06,  0.5107e-06,  0.6982e-06,  0.9542e-06,  0.1290e-05, &
+         0.1703e-05,  0.2170e-05,  0.2628e-05,  0.3013e-05,  0.3352e-05, &
+         0.3669e-05,  0.3780e-05,  0.3397e-05,  0.2386e-05,  0.1062e-05, &
+         0.2216e-06/
+      data ((h11(ip,iw),iw=1,31), ip=19,19)/ &
+         0.99990678,  0.99981970,  0.99965781,  0.99936831,  0.99887598, &
+         0.99808502,  0.99687898,  0.99510998,  0.99257898,  0.98900002, &
+         0.98398000,  0.97693998,  0.96711999,  0.95353001,  0.93484998, &
+         0.90934002,  0.87479997,  0.82900000,  0.76960003,  0.69550002, &
+         0.60720003,  0.50819999,  0.40490001,  0.30440003,  0.21130002, &
+         0.12910002,  0.06389999,  0.02200001,  0.00389999,  0.00010002, &
+         0.00000000/
+      data ((h12(ip,iw),iw=1,31), ip=19,19)/ &
+        -0.1454e-06, -0.2805e-06, -0.5296e-06, -0.9685e-06, -0.1695e-05, &
+        -0.2812e-05, -0.4412e-05, -0.6606e-05, -0.9573e-05, -0.1363e-04, &
+        -0.1932e-04, -0.2743e-04, -0.3897e-04, -0.5520e-04, -0.7787e-04, &
+        -0.1094e-03, -0.1529e-03, -0.2117e-03, -0.2880e-03, -0.3809e-03, &
+        -0.4834e-03, -0.5836e-03, -0.6692e-03, -0.7275e-03, -0.7408e-03, &
+        -0.6865e-03, -0.5459e-03, -0.3360e-03, -0.1365e-03, -0.2935e-04, &
+        -0.2173e-05/
+      data ((h13(ip,iw),iw=1,31), ip=19,19)/ &
+         0.6693e-09,  0.1312e-08,  0.2538e-08,  0.4802e-08,  0.8778e-08, &
+         0.1528e-07,  0.2501e-07,  0.3836e-07,  0.5578e-07,  0.7806e-07, &
+         0.1069e-06,  0.1456e-06,  0.1970e-06,  0.2631e-06,  0.3485e-06, &
+         0.4642e-06,  0.6268e-06,  0.8526e-06,  0.1157e-05,  0.1545e-05, &
+         0.2002e-05,  0.2478e-05,  0.2897e-05,  0.3245e-05,  0.3578e-05, &
+         0.3789e-05,  0.3598e-05,  0.2792e-05,  0.1489e-05,  0.4160e-06, &
+         0.3843e-07/
+      data ((h11(ip,iw),iw=1,31), ip=20,20)/ &
+         0.99990559,  0.99981570,  0.99964547,  0.99933308,  0.99878299, &
+         0.99786699,  0.99642301,  0.99425799,  0.99111998,  0.98667002, &
+         0.98041999,  0.97170001,  0.95960999,  0.94295001,  0.92012000, &
+         0.88900000,  0.84740001,  0.79280001,  0.72360003,  0.63960004, &
+         0.54330003,  0.44029999,  0.33800000,  0.24190003,  0.15530002, &
+         0.08350003,  0.03320003,  0.00770003,  0.00050002,  0.00000000, &
+         0.00000000/
+      data ((h12(ip,iw),iw=1,31), ip=20,20)/ &
+        -0.1472e-06, -0.2866e-06, -0.5485e-06, -0.1024e-05, -0.1842e-05, &
+        -0.3160e-05, -0.5136e-05, -0.7922e-05, -0.1171e-04, -0.1682e-04, &
+        -0.2381e-04, -0.3355e-04, -0.4729e-04, -0.6673e-04, -0.9417e-04, &
+        -0.1327e-03, -0.1858e-03, -0.2564e-03, -0.3449e-03, -0.4463e-03, &
+        -0.5495e-03, -0.6420e-03, -0.7116e-03, -0.7427e-03, -0.7139e-03, &
+        -0.6031e-03, -0.4104e-03, -0.1957e-03, -0.5358e-04, -0.6176e-05, &
+        -0.1347e-06/
+      data ((h13(ip,iw),iw=1,31), ip=20,20)/ &
+         0.6750e-09,  0.1332e-08,  0.2602e-08,  0.5003e-08,  0.9367e-08, &
+         0.1684e-07,  0.2863e-07,  0.4566e-07,  0.6865e-07,  0.9861e-07, &
+         0.1368e-06,  0.1856e-06,  0.2479e-06,  0.3274e-06,  0.4315e-06, &
+         0.5739e-06,  0.7710e-06,  0.1040e-05,  0.1394e-05,  0.1829e-05, &
+         0.2309e-05,  0.2759e-05,  0.3131e-05,  0.3472e-05,  0.3755e-05, &
+         0.3730e-05,  0.3138e-05,  0.1948e-05,  0.6994e-06,  0.1022e-06, &
+         0.2459e-08/
+      data ((h11(ip,iw),iw=1,31), ip=21,21)/ &
+         0.99990469,  0.99981278,  0.99963617,  0.99930513,  0.99870503, &
+         0.99766999,  0.99597800,  0.99336702,  0.98951000,  0.98399001, &
+         0.97622001,  0.96543998,  0.95059001,  0.93019998,  0.90235001, &
+         0.86470002,  0.81480002,  0.75059998,  0.67129999,  0.57840002, &
+         0.47659999,  0.37279999,  0.27389997,  0.18339998,  0.10570002, &
+         0.04740000,  0.01370001,  0.00169998,  0.00000000,  0.00000000, &
+         0.00000000/
+      data ((h12(ip,iw),iw=1,31), ip=21,21)/ &
+        -0.1487e-06, -0.2912e-06, -0.5636e-06, -0.1069e-05, -0.1969e-05, &
+        -0.3483e-05, -0.5858e-05, -0.9334e-05, -0.1416e-04, -0.2067e-04, &
+        -0.2936e-04, -0.4113e-04, -0.5750e-04, -0.8072e-04, -0.1139e-03, &
+        -0.1606e-03, -0.2246e-03, -0.3076e-03, -0.4067e-03, -0.5121e-03, &
+        -0.6110e-03, -0.6909e-03, -0.7378e-03, -0.7321e-03, -0.6509e-03, &
+        -0.4825e-03, -0.2641e-03, -0.8936e-04, -0.1436e-04, -0.5966e-06, &
+         0.0000e+00/
+      data ((h13(ip,iw),iw=1,31), ip=21,21)/ &
+         0.6777e-09,  0.1344e-08,  0.2643e-08,  0.5138e-08,  0.9798e-08, &
+         0.1809e-07,  0.3185e-07,  0.5285e-07,  0.8249e-07,  0.1222e-06, &
+         0.1730e-06,  0.2351e-06,  0.3111e-06,  0.4078e-06,  0.5366e-06, &
+         0.7117e-06,  0.9495e-06,  0.1266e-05,  0.1667e-05,  0.2132e-05, &
+         0.2600e-05,  0.3001e-05,  0.3354e-05,  0.3679e-05,  0.3796e-05, &
+         0.3414e-05,  0.2399e-05,  0.1067e-05,  0.2222e-06,  0.1075e-07, &
+         0.0000e+00/
+      data ((h11(ip,iw),iw=1,31), ip=22,22)/ &
+         0.99990410,  0.99981070,  0.99962938,  0.99928379,  0.99864298, &
+         0.99750000,  0.99556601,  0.99247700,  0.98780000,  0.98100001, &
+         0.97140002,  0.95810002,  0.93984997,  0.91491997,  0.88110000, &
+         0.83570004,  0.77670002,  0.70239997,  0.61350000,  0.51349998, &
+         0.40910000,  0.30750000,  0.21340001,  0.13040000,  0.06449997, &
+         0.02219999,  0.00389999,  0.00010002,  0.00000000,  0.00000000, &
+         0.00000000/
+      data ((h12(ip,iw),iw=1,31), ip=22,22)/ &
+        -0.1496e-06, -0.2947e-06, -0.5749e-06, -0.1105e-05, -0.2074e-05, &
+        -0.3763e-05, -0.6531e-05, -0.1076e-04, -0.1682e-04, -0.2509e-04, &
+        -0.3605e-04, -0.5049e-04, -0.7012e-04, -0.9787e-04, -0.1378e-03, &
+        -0.1939e-03, -0.2695e-03, -0.3641e-03, -0.4703e-03, -0.5750e-03, &
+        -0.6648e-03, -0.7264e-03, -0.7419e-03, -0.6889e-03, -0.5488e-03, &
+        -0.3382e-03, -0.1375e-03, -0.2951e-04, -0.2174e-05,  0.0000e+00, &
+         0.0000e+00/
+      data ((h13(ip,iw),iw=1,31), ip=22,22)/ &
+         0.6798e-09,  0.1350e-08,  0.2667e-08,  0.5226e-08,  0.1010e-07, &
+         0.1903e-07,  0.3455e-07,  0.5951e-07,  0.9658e-07,  0.1479e-06, &
+         0.2146e-06,  0.2951e-06,  0.3903e-06,  0.5101e-06,  0.6693e-06, &
+         0.8830e-06,  0.1168e-05,  0.1532e-05,  0.1968e-05,  0.2435e-05, &
+         0.2859e-05,  0.3222e-05,  0.3572e-05,  0.3797e-05,  0.3615e-05, &
+         0.2811e-05,  0.1500e-05,  0.4185e-06,  0.3850e-07,  0.0000e+00, &
+         0.0000e+00/
+      data ((h11(ip,iw),iw=1,31), ip=23,23)/ &
+         0.99990374,  0.99980932,  0.99962449,  0.99926788,  0.99859399, &
+         0.99736100,  0.99520397,  0.99163198,  0.98606002,  0.97779000, &
+         0.96600002,  0.94963002,  0.92720997,  0.89670002,  0.85580003, &
+         0.80170000,  0.73269999,  0.64840001,  0.55110002,  0.44669998, &
+         0.34280002,  0.24529999,  0.15750003,  0.08469999,  0.03369999, &
+         0.00779998,  0.00050002,  0.00000000,  0.00000000,  0.00000000, &
+         0.00000000/
+      data ((h12(ip,iw),iw=1,31), ip=23,23)/ &
+        -0.1503e-06, -0.2971e-06, -0.5832e-06, -0.1131e-05, -0.2154e-05, &
+        -0.3992e-05, -0.7122e-05, -0.1211e-04, -0.1954e-04, -0.2995e-04, &
+        -0.4380e-04, -0.6183e-04, -0.8577e-04, -0.1191e-03, -0.1668e-03, &
+        -0.2333e-03, -0.3203e-03, -0.4237e-03, -0.5324e-03, -0.6318e-03, &
+        -0.7075e-03, -0.7429e-03, -0.7168e-03, -0.6071e-03, -0.4139e-03, &
+        -0.1976e-03, -0.5410e-04, -0.6215e-05, -0.1343e-06,  0.0000e+00, &
+         0.0000e+00/
+      data ((h13(ip,iw),iw=1,31), ip=23,23)/ &
+         0.6809e-09,  0.1356e-08,  0.2683e-08,  0.5287e-08,  0.1030e-07, &
+         0.1971e-07,  0.3665e-07,  0.6528e-07,  0.1100e-06,  0.1744e-06, &
+         0.2599e-06,  0.3650e-06,  0.4887e-06,  0.6398e-06,  0.8358e-06, &
+         0.1095e-05,  0.1429e-05,  0.1836e-05,  0.2286e-05,  0.2716e-05, &
+         0.3088e-05,  0.3444e-05,  0.3748e-05,  0.3740e-05,  0.3157e-05, &
+         0.1966e-05,  0.7064e-06,  0.1030e-06,  0.2456e-08,  0.0000e+00, &
+         0.0000e+00/
+      data ((h11(ip,iw),iw=1,31), ip=24,24)/ &
+         0.99990344,  0.99980831,  0.99962109,  0.99925637,  0.99855798, &
+         0.99725199,  0.99489999,  0.99087203,  0.98436999,  0.97447002, &
+         0.96012998,  0.94006002,  0.91254002,  0.87540001,  0.82609999, &
+         0.76240003,  0.68299997,  0.58930004,  0.48589998,  0.38020003, &
+         0.27920002,  0.18699998,  0.10769999,  0.04830003,  0.01400000, &
+         0.00169998,  0.00000000,  0.00000000,  0.00000000,  0.00000000, &
+         0.00000000/
+      data ((h12(ip,iw),iw=1,31), ip=24,24)/ &
+        -0.1508e-06, -0.2989e-06, -0.5892e-06, -0.1151e-05, -0.2216e-05, &
+        -0.4175e-05, -0.7619e-05, -0.1333e-04, -0.2217e-04, -0.3497e-04, &
+        -0.5238e-04, -0.7513e-04, -0.1049e-03, -0.1455e-03, -0.2021e-03, &
+        -0.2790e-03, -0.3757e-03, -0.4839e-03, -0.5902e-03, -0.6794e-03, &
+        -0.7344e-03, -0.7341e-03, -0.6557e-03, -0.4874e-03, -0.2674e-03, &
+        -0.9059e-04, -0.1455e-04, -0.5986e-06,  0.0000e+00,  0.0000e+00, &
+         0.0000e+00/
+      data ((h13(ip,iw),iw=1,31), ip=24,24)/ &
+         0.6812e-09,  0.1356e-08,  0.2693e-08,  0.5328e-08,  0.1045e-07, &
+         0.2021e-07,  0.3826e-07,  0.6994e-07,  0.1218e-06,  0.1997e-06, &
+         0.3069e-06,  0.4428e-06,  0.6064e-06,  0.8015e-06,  0.1043e-05, &
+         0.1351e-05,  0.1733e-05,  0.2168e-05,  0.2598e-05,  0.2968e-05, &
+         0.3316e-05,  0.3662e-05,  0.3801e-05,  0.3433e-05,  0.2422e-05, &
+         0.1081e-05,  0.2256e-06,  0.1082e-07,  0.0000e+00,  0.0000e+00, &
+         0.0000e+00/
+      data ((h11(ip,iw),iw=1,31), ip=25,25)/ &
+         0.99990326,  0.99980772,  0.99961871,  0.99924821,  0.99853098, &
+         0.99716800,  0.99465698,  0.99022102,  0.98281002,  0.97118002, &
+         0.95393997,  0.92948997,  0.89579999,  0.85070002,  0.79189998, &
+         0.71759999,  0.62800002,  0.52639997,  0.41970003,  0.31559998, &
+         0.21899998,  0.13370001,  0.06610000,  0.02280003,  0.00400001, &
+         0.00010002,  0.00000000,  0.00000000,  0.00000000,  0.00000000, &
+         0.00000000/
+      data ((h12(ip,iw),iw=1,31), ip=25,25)/ &
+        -0.1511e-06, -0.3001e-06, -0.5934e-06, -0.1166e-05, -0.2263e-05, &
+        -0.4319e-05, -0.8028e-05, -0.1438e-04, -0.2460e-04, -0.3991e-04, &
+        -0.6138e-04, -0.9005e-04, -0.1278e-03, -0.1778e-03, -0.2447e-03, &
+        -0.3313e-03, -0.4342e-03, -0.5424e-03, -0.6416e-03, -0.7146e-03, &
+        -0.7399e-03, -0.6932e-03, -0.5551e-03, -0.3432e-03, -0.1398e-03, &
+        -0.3010e-04, -0.2229e-05,  0.0000e+00,  0.0000e+00,  0.0000e+00, &
+         0.0000e+00/
+      data ((h13(ip,iw),iw=1,31), ip=25,25)/ &
+         0.6815e-09,  0.1358e-08,  0.2698e-08,  0.5355e-08,  0.1054e-07, &
+         0.2056e-07,  0.3942e-07,  0.7349e-07,  0.1315e-06,  0.2226e-06, &
+         0.3537e-06,  0.5266e-06,  0.7407e-06,  0.9958e-06,  0.1296e-05, &
+         0.1657e-05,  0.2077e-05,  0.2512e-05,  0.2893e-05,  0.3216e-05, &
+         0.3562e-05,  0.3811e-05,  0.3644e-05,  0.2841e-05,  0.1524e-05, &
+         0.4276e-06,  0.3960e-07,  0.0000e+00,  0.0000e+00,  0.0000e+00, &
+         0.0000e+00/
+      data ((h11(ip,iw),iw=1,31), ip=26,26)/ &
+         0.99990320,  0.99980718,  0.99961710,  0.99924242,  0.99851102, &
+         0.99710602,  0.99446702,  0.98969001,  0.98144001,  0.96805000, &
+         0.94762999,  0.91812998,  0.87730002,  0.82290000,  0.75319999, &
+         0.66789997,  0.56879997,  0.46160001,  0.35450000,  0.25370002, &
+         0.16280001,  0.08740002,  0.03479999,  0.00809997,  0.00059998, &
+         0.00000000,  0.00000000,  0.00000000,  0.00000000,  0.00000000, &
+         0.00000000/
+      data ((h12(ip,iw),iw=1,31), ip=26,26)/ &
+        -0.1513e-06, -0.3009e-06, -0.5966e-06, -0.1176e-05, -0.2299e-05, &
+        -0.4430e-05, -0.8352e-05, -0.1526e-04, -0.2674e-04, -0.4454e-04, &
+        -0.7042e-04, -0.1062e-03, -0.1540e-03, -0.2163e-03, -0.2951e-03, &
+        -0.3899e-03, -0.4948e-03, -0.5983e-03, -0.6846e-03, -0.7332e-03, &
+        -0.7182e-03, -0.6142e-03, -0.4209e-03, -0.2014e-03, -0.5530e-04, &
+        -0.6418e-05, -0.1439e-06,  0.0000e+00,  0.0000e+00,  0.0000e+00, &
+         0.0000e+00/
+      data ((h13(ip,iw),iw=1,31), ip=26,26)/ &
+         0.6817e-09,  0.1359e-08,  0.2702e-08,  0.5374e-08,  0.1061e-07, &
+         0.2079e-07,  0.4022e-07,  0.7610e-07,  0.1392e-06,  0.2428e-06, &
+         0.3992e-06,  0.6149e-06,  0.8893e-06,  0.1220e-05,  0.1599e-05, &
+         0.2015e-05,  0.2453e-05,  0.2853e-05,  0.3173e-05,  0.3488e-05, &
+         0.3792e-05,  0.3800e-05,  0.3210e-05,  0.2002e-05,  0.7234e-06, &
+         0.1068e-06,  0.2646e-08,  0.0000e+00,  0.0000e+00,  0.0000e+00, &
+         0.0000e+00/
+      data ((h21(ip,iw),iw=1,31), ip= 1, 1)/ &
+         0.99999607,  0.99999237,  0.99998546,  0.99997294,  0.99995142, &
+         0.99991685,  0.99986511,  0.99979371,  0.99970162,  0.99958909, &
+         0.99945778,  0.99931037,  0.99914628,  0.99895900,  0.99873799, &
+         0.99846601,  0.99813002,  0.99771398,  0.99719697,  0.99655598, &
+         0.99575800,  0.99475598,  0.99348903,  0.99186200,  0.98973000, &
+         0.98688000,  0.98303002,  0.97777998,  0.97059000,  0.96077001, &
+         0.94742000/
+      data ((h22(ip,iw),iw=1,31), ip= 1, 1)/ &
+        -0.5622e-07, -0.1071e-06, -0.1983e-06, -0.3533e-06, -0.5991e-06, &
+        -0.9592e-06, -0.1444e-05, -0.2049e-05, -0.2764e-05, -0.3577e-05, &
+        -0.4469e-05, -0.5467e-05, -0.6654e-05, -0.8137e-05, -0.1002e-04, &
+        -0.1237e-04, -0.1528e-04, -0.1884e-04, -0.2310e-04, -0.2809e-04, &
+        -0.3396e-04, -0.4098e-04, -0.4960e-04, -0.6058e-04, -0.7506e-04, &
+        -0.9451e-04, -0.1207e-03, -0.1558e-03, -0.2026e-03, -0.2648e-03, &
+        -0.3468e-03/
+      data ((h23(ip,iw),iw=1,31), ip= 1, 1)/ &
+        -0.2195e-09, -0.4031e-09, -0.7043e-09, -0.1153e-08, -0.1737e-08, &
+        -0.2395e-08, -0.3020e-08, -0.3549e-08, -0.4034e-08, -0.4421e-08, &
+        -0.4736e-08, -0.5681e-08, -0.8289e-08, -0.1287e-07, -0.1873e-07, &
+        -0.2523e-07, -0.3223e-07, -0.3902e-07, -0.4409e-07, -0.4699e-07, &
+        -0.4782e-07, -0.4705e-07, -0.4657e-07, -0.4885e-07, -0.5550e-07, &
+        -0.6619e-07, -0.7656e-07, -0.8027e-07, -0.7261e-07, -0.4983e-07, &
+        -0.1101e-07/
+      data ((h21(ip,iw),iw=1,31), ip= 2, 2)/ &
+         0.99999607,  0.99999237,  0.99998546,  0.99997294,  0.99995142, &
+         0.99991679,  0.99986511,  0.99979353,  0.99970138,  0.99958861, &
+         0.99945688,  0.99930882,  0.99914342,  0.99895400,  0.99872798, &
+         0.99844801,  0.99809802,  0.99765801,  0.99710101,  0.99639499, &
+         0.99549901,  0.99435198,  0.99287099,  0.99093699,  0.98837000, &
+         0.98491001,  0.98019999,  0.97373998,  0.96490002,  0.95283002, &
+         0.93649000/
+      data ((h22(ip,iw),iw=1,31), ip= 2, 2)/ &
+        -0.5622e-07, -0.1071e-06, -0.1983e-06, -0.3534e-06, -0.5992e-06, &
+        -0.9594e-06, -0.1445e-05, -0.2050e-05, -0.2766e-05, -0.3580e-05, &
+        -0.4476e-05, -0.5479e-05, -0.6677e-05, -0.8179e-05, -0.1009e-04, &
+        -0.1251e-04, -0.1553e-04, -0.1928e-04, -0.2384e-04, -0.2930e-04, &
+        -0.3588e-04, -0.4393e-04, -0.5403e-04, -0.6714e-04, -0.8458e-04, &
+        -0.1082e-03, -0.1400e-03, -0.1829e-03, -0.2401e-03, -0.3157e-03, &
+        -0.4147e-03/
+      data ((h23(ip,iw),iw=1,31), ip= 2, 2)/ &
+        -0.2195e-09, -0.4032e-09, -0.7046e-09, -0.1153e-08, -0.1738e-08, &
+        -0.2395e-08, -0.3021e-08, -0.3550e-08, -0.4035e-08, -0.4423e-08, &
+        -0.4740e-08, -0.5692e-08, -0.8314e-08, -0.1292e-07, -0.1882e-07, &
+        -0.2536e-07, -0.3242e-07, -0.3927e-07, -0.4449e-07, -0.4767e-07, &
+        -0.4889e-07, -0.4857e-07, -0.4860e-07, -0.5132e-07, -0.5847e-07, &
+        -0.6968e-07, -0.8037e-07, -0.8400e-07, -0.7521e-07, -0.4830e-07, &
+        -0.7562e-09/
+      data ((h21(ip,iw),iw=1,31), ip= 3, 3)/ &
+         0.99999607,  0.99999237,  0.99998546,  0.99997294,  0.99995142, &
+         0.99991679,  0.99986500,  0.99979341,  0.99970102,  0.99958777, &
+         0.99945557,  0.99930632,  0.99913889,  0.99894601,  0.99871302, &
+         0.99842101,  0.99805099,  0.99757600,  0.99696302,  0.99617100, &
+         0.99514598,  0.99381000,  0.99205798,  0.98974001,  0.98662001, &
+         0.98238999,  0.97659999,  0.96866000,  0.95776999,  0.94296998, &
+         0.92306000/
+      data ((h22(ip,iw),iw=1,31), ip= 3, 3)/ &
+        -0.5622e-07, -0.1071e-06, -0.1983e-06, -0.3535e-06, -0.5994e-06, &
+        -0.9599e-06, -0.1446e-05, -0.2052e-05, -0.2769e-05, -0.3586e-05, &
+        -0.4487e-05, -0.5499e-05, -0.6712e-05, -0.8244e-05, -0.1021e-04, &
+        -0.1272e-04, -0.1591e-04, -0.1992e-04, -0.2489e-04, -0.3097e-04, &
+        -0.3845e-04, -0.4782e-04, -0.5982e-04, -0.7558e-04, -0.9674e-04, &
+        -0.1254e-03, -0.1644e-03, -0.2167e-03, -0.2863e-03, -0.3777e-03, &
+        -0.4959e-03/
+      data ((h23(ip,iw),iw=1,31), ip= 3, 3)/ &
+        -0.2196e-09, -0.4033e-09, -0.7048e-09, -0.1154e-08, -0.1739e-08, &
+        -0.2396e-08, -0.3022e-08, -0.3551e-08, -0.4036e-08, -0.4425e-08, &
+        -0.4746e-08, -0.5710e-08, -0.8354e-08, -0.1300e-07, -0.1894e-07, &
+        -0.2554e-07, -0.3265e-07, -0.3958e-07, -0.4502e-07, -0.4859e-07, &
+        -0.5030e-07, -0.5053e-07, -0.5104e-07, -0.5427e-07, -0.6204e-07, &
+        -0.7388e-07, -0.8477e-07, -0.8760e-07, -0.7545e-07, -0.4099e-07, &
+         0.2046e-07/
+      data ((h21(ip,iw),iw=1,31), ip= 4, 4)/ &
+         0.99999607,  0.99999237,  0.99998546,  0.99997294,  0.99995142, &
+         0.99991673,  0.99986482,  0.99979299,  0.99970031,  0.99958658, &
+         0.99945343,  0.99930239,  0.99913180,  0.99893302,  0.99869001, &
+         0.99838102,  0.99798000,  0.99745703,  0.99676800,  0.99586397, &
+         0.99467200,  0.99309403,  0.99099600,  0.98817998,  0.98438001, &
+         0.97918999,  0.97206002,  0.96227002,  0.94888997,  0.93080997, &
+         0.90671003/
+      data ((h22(ip,iw),iw=1,31), ip= 4, 4)/ &
+        -0.5623e-07, -0.1071e-06, -0.1984e-06, -0.3536e-06, -0.5997e-06, &
+        -0.9606e-06, -0.1447e-05, -0.2055e-05, -0.2775e-05, -0.3596e-05, &
+        -0.4504e-05, -0.5529e-05, -0.6768e-05, -0.8345e-05, -0.1039e-04, &
+        -0.1304e-04, -0.1645e-04, -0.2082e-04, -0.2633e-04, -0.3322e-04, &
+        -0.4187e-04, -0.5292e-04, -0.6730e-04, -0.8640e-04, -0.1122e-03, &
+        -0.1472e-03, -0.1948e-03, -0.2585e-03, -0.3428e-03, -0.4523e-03, &
+        -0.5915e-03/
+      data ((h23(ip,iw),iw=1,31), ip= 4, 4)/ &
+        -0.2196e-09, -0.4034e-09, -0.7050e-09, -0.1154e-08, -0.1740e-08, &
+        -0.2398e-08, -0.3024e-08, -0.3552e-08, -0.4037e-08, -0.4428e-08, &
+        -0.4756e-08, -0.5741e-08, -0.8418e-08, -0.1310e-07, -0.1910e-07, &
+        -0.2575e-07, -0.3293e-07, -0.3998e-07, -0.4572e-07, -0.4980e-07, &
+        -0.5211e-07, -0.5287e-07, -0.5390e-07, -0.5782e-07, -0.6650e-07, &
+        -0.7892e-07, -0.8940e-07, -0.8980e-07, -0.7119e-07, -0.2452e-07, &
+         0.5823e-07/
+      data ((h21(ip,iw),iw=1,31), ip= 5, 5)/ &
+         0.99999607,  0.99999237,  0.99998546,  0.99997294,  0.99995136, &
+         0.99991661,  0.99986458,  0.99979252,  0.99969929,  0.99958479, &
+         0.99945003,  0.99929619,  0.99912071,  0.99891400,  0.99865502, &
+         0.99831998,  0.99787700,  0.99728799,  0.99650002,  0.99544799, &
+         0.99404198,  0.99215603,  0.98961997,  0.98619002,  0.98153001, &
+         0.97513002,  0.96634001,  0.95428002,  0.93791002,  0.91593999, &
+         0.88700002/
+      data ((h22(ip,iw),iw=1,31), ip= 5, 5)/ &
+        -0.5623e-07, -0.1071e-06, -0.1985e-06, -0.3538e-06, -0.6002e-06, &
+        -0.9618e-06, -0.1450e-05, -0.2059e-05, -0.2783e-05, -0.3611e-05, &
+        -0.4531e-05, -0.5577e-05, -0.6855e-05, -0.8499e-05, -0.1066e-04, &
+        -0.1351e-04, -0.1723e-04, -0.2207e-04, -0.2829e-04, -0.3621e-04, &
+        -0.4636e-04, -0.5954e-04, -0.7690e-04, -0.1002e-03, -0.1317e-03, &
+        -0.1746e-03, -0.2326e-03, -0.3099e-03, -0.4111e-03, -0.5407e-03, &
+        -0.7020e-03/
+      data ((h23(ip,iw),iw=1,31), ip= 5, 5)/ &
+        -0.2197e-09, -0.4037e-09, -0.7054e-09, -0.1155e-08, -0.1741e-08, &
+        -0.2401e-08, -0.3027e-08, -0.3553e-08, -0.4039e-08, -0.4431e-08, &
+        -0.4775e-08, -0.5784e-08, -0.8506e-08, -0.1326e-07, -0.1931e-07, &
+        -0.2600e-07, -0.3324e-07, -0.4048e-07, -0.4666e-07, -0.5137e-07, &
+        -0.5428e-07, -0.5558e-07, -0.5730e-07, -0.6228e-07, -0.7197e-07, &
+        -0.8455e-07, -0.9347e-07, -0.8867e-07, -0.5945e-07,  0.5512e-08, &
+         0.1209e-06/
+      data ((h21(ip,iw),iw=1,31), ip= 6, 6)/ &
+         0.99999607,  0.99999237,  0.99998546,  0.99997288,  0.99995130, &
+         0.99991649,  0.99986428,  0.99979180,  0.99969780,  0.99958187, &
+         0.99944460,  0.99928659,  0.99910372,  0.99888301,  0.99860299, &
+         0.99822998,  0.99773002,  0.99705303,  0.99613500,  0.99489301, &
+         0.99321300,  0.99093801,  0.98785001,  0.98365998,  0.97790998, &
+         0.97000998,  0.95916998,  0.94437003,  0.92440999,  0.89789999, &
+         0.86360002/
+      data ((h22(ip,iw),iw=1,31), ip= 6, 6)/ &
+        -0.5624e-07, -0.1072e-06, -0.1986e-06, -0.3541e-06, -0.6010e-06, &
+        -0.9636e-06, -0.1453e-05, -0.2067e-05, -0.2796e-05, -0.3634e-05, &
+        -0.4572e-05, -0.5652e-05, -0.6987e-05, -0.8733e-05, -0.1107e-04, &
+        -0.1418e-04, -0.1832e-04, -0.2378e-04, -0.3092e-04, -0.4017e-04, &
+        -0.5221e-04, -0.6806e-04, -0.8916e-04, -0.1176e-03, -0.1562e-03, &
+        -0.2087e-03, -0.2793e-03, -0.3724e-03, -0.4928e-03, -0.6440e-03, &
+        -0.8270e-03/
+      data ((h23(ip,iw),iw=1,31), ip= 6, 6)/ &
+        -0.2198e-09, -0.4040e-09, -0.7061e-09, -0.1156e-08, -0.1744e-08, &
+        -0.2405e-08, -0.3032e-08, -0.3556e-08, -0.4040e-08, -0.4444e-08, &
+        -0.4800e-08, -0.5848e-08, -0.8640e-08, -0.1346e-07, -0.1957e-07, &
+        -0.2627e-07, -0.3357e-07, -0.4114e-07, -0.4793e-07, -0.5330e-07, &
+        -0.5676e-07, -0.5873e-07, -0.6152e-07, -0.6783e-07, -0.7834e-07, &
+        -0.9023e-07, -0.9530e-07, -0.8162e-07, -0.3634e-07,  0.5638e-07, &
+         0.2189e-06/
+      data ((h21(ip,iw),iw=1,31), ip= 7, 7)/ &
+         0.99999607,  0.99999237,  0.99998546,  0.99997288,  0.99995124, &
+         0.99991626,  0.99986368,  0.99979049,  0.99969530,  0.99957728, &
+         0.99943632,  0.99927181,  0.99907762,  0.99883801,  0.99852502, &
+         0.99810201,  0.99752498,  0.99673301,  0.99564600,  0.99416101, &
+         0.99213398,  0.98936999,  0.98559999,  0.98043001,  0.97333997, &
+         0.96359003,  0.95025003,  0.93216002,  0.90798998,  0.87639999, &
+         0.83609998/
+      data ((h22(ip,iw),iw=1,31), ip= 7, 7)/ &
+        -0.5626e-07, -0.1072e-06, -0.1987e-06, -0.3545e-06, -0.6022e-06, &
+        -0.9665e-06, -0.1460e-05, -0.2078e-05, -0.2817e-05, -0.3671e-05, &
+        -0.4637e-05, -0.5767e-05, -0.7188e-05, -0.9080e-05, -0.1165e-04, &
+        -0.1513e-04, -0.1981e-04, -0.2609e-04, -0.3441e-04, -0.4534e-04, &
+        -0.5978e-04, -0.7897e-04, -0.1047e-03, -0.1396e-03, -0.1870e-03, &
+        -0.2510e-03, -0.3363e-03, -0.4475e-03, -0.5888e-03, -0.7621e-03, &
+        -0.9647e-03/
+      data ((h23(ip,iw),iw=1,31), ip= 7, 7)/ &
+        -0.2200e-09, -0.4045e-09, -0.7071e-09, -0.1159e-08, -0.1748e-08, &
+        -0.2411e-08, -0.3040e-08, -0.3561e-08, -0.4046e-08, -0.4455e-08, &
+        -0.4839e-08, -0.5941e-08, -0.8815e-08, -0.1371e-07, -0.1983e-07, &
+        -0.2652e-07, -0.3400e-07, -0.4207e-07, -0.4955e-07, -0.5554e-07, &
+        -0.5966e-07, -0.6261e-07, -0.6688e-07, -0.7454e-07, -0.8521e-07, &
+        -0.9470e-07, -0.9275e-07, -0.6525e-07,  0.3686e-08,  0.1371e-06, &
+         0.3623e-06/
+      data ((h21(ip,iw),iw=1,31), ip= 8, 8)/ &
+         0.99999607,  0.99999237,  0.99998540,  0.99997282,  0.99995112, &
+         0.99991590,  0.99986279,  0.99978858,  0.99969149,  0.99957019, &
+         0.99942350,  0.99924922,  0.99903822,  0.99877101,  0.99841398, &
+         0.99792302,  0.99724299,  0.99630302,  0.99500000,  0.99320602, &
+         0.99074000,  0.98736000,  0.98272002,  0.97635001,  0.96758002, &
+         0.95555997,  0.93919998,  0.91722000,  0.88819999,  0.85089999, &
+         0.80439997/
+      data ((h22(ip,iw),iw=1,31), ip= 8, 8)/ &
+        -0.5628e-07, -0.1073e-06, -0.1990e-06, -0.3553e-06, -0.6042e-06, &
+        -0.9710e-06, -0.1469e-05, -0.2096e-05, -0.2849e-05, -0.3728e-05, &
+        -0.4738e-05, -0.5942e-05, -0.7490e-05, -0.9586e-05, -0.1247e-04, &
+        -0.1644e-04, -0.2184e-04, -0.2916e-04, -0.3898e-04, -0.5205e-04, &
+        -0.6948e-04, -0.9285e-04, -0.1244e-03, -0.1672e-03, -0.2251e-03, &
+        -0.3028e-03, -0.4051e-03, -0.5365e-03, -0.6998e-03, -0.8940e-03, &
+        -0.1112e-02/
+      data ((h23(ip,iw),iw=1,31), ip= 8, 8)/ &
+        -0.2204e-09, -0.4052e-09, -0.7088e-09, -0.1162e-08, -0.1755e-08, &
+        -0.2422e-08, -0.3053e-08, -0.3572e-08, -0.4052e-08, -0.4474e-08, &
+        -0.4898e-08, -0.6082e-08, -0.9046e-08, -0.1400e-07, -0.2009e-07, &
+        -0.2683e-07, -0.3463e-07, -0.4334e-07, -0.5153e-07, -0.5811e-07, &
+        -0.6305e-07, -0.6749e-07, -0.7346e-07, -0.8208e-07, -0.9173e-07, &
+        -0.9603e-07, -0.8264e-07, -0.3505e-07,  0.6878e-07,  0.2586e-06, &
+         0.5530e-06/
+      data ((h21(ip,iw),iw=1,31), ip= 9, 9)/ &
+         0.99999607,  0.99999237,  0.99998540,  0.99997276,  0.99995089, &
+         0.99991536,  0.99986148,  0.99978572,  0.99968570,  0.99955928, &
+         0.99940401,  0.99921501,  0.99897999,  0.99867398,  0.99825603, &
+         0.99767601,  0.99686497,  0.99573302,  0.99415499,  0.99196899, &
+         0.98895001,  0.98479998,  0.97907001,  0.97119999,  0.96038002, &
+         0.94559997,  0.92565000,  0.89910001,  0.86470002,  0.82130003, &
+         0.76830000/
+      data ((h22(ip,iw),iw=1,31), ip= 9, 9)/ &
+        -0.5630e-07, -0.1074e-06, -0.1994e-06, -0.3564e-06, -0.6072e-06, &
+        -0.9779e-06, -0.1484e-05, -0.2124e-05, -0.2900e-05, -0.3817e-05, &
+        -0.4891e-05, -0.6205e-05, -0.7931e-05, -0.1031e-04, -0.1362e-04, &
+        -0.1821e-04, -0.2454e-04, -0.3320e-04, -0.4493e-04, -0.6068e-04, &
+        -0.8186e-04, -0.1104e-03, -0.1491e-03, -0.2016e-03, -0.2722e-03, &
+        -0.3658e-03, -0.4873e-03, -0.6404e-03, -0.8253e-03, -0.1037e-02, &
+        -0.1267e-02/
+      data ((h23(ip,iw),iw=1,31), ip= 9, 9)/ &
+        -0.2207e-09, -0.4061e-09, -0.7117e-09, -0.1169e-08, -0.1767e-08, &
+        -0.2439e-08, -0.3074e-08, -0.3588e-08, -0.4062e-08, -0.4510e-08, &
+        -0.4983e-08, -0.6261e-08, -0.9324e-08, -0.1430e-07, -0.2036e-07, &
+        -0.2725e-07, -0.3561e-07, -0.4505e-07, -0.5384e-07, -0.6111e-07, &
+        -0.6731e-07, -0.7355e-07, -0.8112e-07, -0.8978e-07, -0.9616e-07, &
+        -0.9157e-07, -0.6114e-07,  0.1622e-07,  0.1694e-06,  0.4277e-06, &
+         0.7751e-06/
+      data ((h21(ip,iw),iw=1,31), ip=10,10)/ &
+         0.99999607,  0.99999237,  0.99998540,  0.99997264,  0.99995059, &
+         0.99991453,  0.99985939,  0.99978119,  0.99967682,  0.99954277, &
+         0.99937469,  0.99916458,  0.99889499,  0.99853599,  0.99804002, &
+         0.99734300,  0.99636298,  0.99498600,  0.99305803,  0.99037802, &
+         0.98667002,  0.98154002,  0.97447002,  0.96473998,  0.95141000, &
+         0.93333000,  0.90916002,  0.87750000,  0.83710003,  0.78729999, &
+         0.72790003/
+      data ((h22(ip,iw),iw=1,31), ip=10,10)/ &
+        -0.5636e-07, -0.1076e-06, -0.2000e-06, -0.3582e-06, -0.6119e-06, &
+        -0.9888e-06, -0.1507e-05, -0.2168e-05, -0.2978e-05, -0.3952e-05, &
+        -0.5122e-05, -0.6592e-05, -0.8565e-05, -0.1132e-04, -0.1518e-04, &
+        -0.2060e-04, -0.2811e-04, -0.3848e-04, -0.5261e-04, -0.7173e-04, &
+        -0.9758e-04, -0.1326e-03, -0.1801e-03, -0.2442e-03, -0.3296e-03, &
+        -0.4415e-03, -0.5840e-03, -0.7591e-03, -0.9636e-03, -0.1189e-02, &
+        -0.1427e-02/
+      data ((h23(ip,iw),iw=1,31), ip=10,10)/ &
+        -0.2214e-09, -0.4080e-09, -0.7156e-09, -0.1178e-08, -0.1784e-08, &
+        -0.2466e-08, -0.3105e-08, -0.3617e-08, -0.4087e-08, -0.4563e-08, &
+        -0.5110e-08, -0.6492e-08, -0.9643e-08, -0.1461e-07, -0.2069e-07, &
+        -0.2796e-07, -0.3702e-07, -0.4717e-07, -0.5662e-07, -0.6484e-07, &
+        -0.7271e-07, -0.8079e-07, -0.8928e-07, -0.9634e-07, -0.9625e-07, &
+        -0.7776e-07, -0.2242e-07,  0.9745e-07,  0.3152e-06,  0.6388e-06, &
+         0.9992e-06/
+      data ((h21(ip,iw),iw=1,31), ip=11,11)/ &
+         0.99999607,  0.99999237,  0.99998534,  0.99997252,  0.99995011, &
+         0.99991328,  0.99985629,  0.99977452,  0.99966347,  0.99951839, &
+         0.99933177,  0.99909180,  0.99877602,  0.99834698,  0.99774700, &
+         0.99690098,  0.99570400,  0.99401599,  0.99164802,  0.98834997, &
+         0.98377001,  0.97742999,  0.96868002,  0.95666999,  0.94032001, &
+         0.91833997,  0.88929999,  0.85189998,  0.80530000,  0.74909997, &
+         0.68299997/
+      data ((h22(ip,iw),iw=1,31), ip=11,11)/ &
+        -0.5645e-07, -0.1079e-06, -0.2009e-06, -0.3610e-06, -0.6190e-06, &
+        -0.1005e-05, -0.1541e-05, -0.2235e-05, -0.3096e-05, -0.4155e-05, &
+        -0.5463e-05, -0.7150e-05, -0.9453e-05, -0.1269e-04, -0.1728e-04, &
+        -0.2375e-04, -0.3279e-04, -0.4531e-04, -0.6246e-04, -0.8579e-04, &
+        -0.1175e-03, -0.1604e-03, -0.2186e-03, -0.2964e-03, -0.3990e-03, &
+        -0.5311e-03, -0.6957e-03, -0.8916e-03, -0.1112e-02, -0.1346e-02, &
+        -0.1590e-02/
+      data ((h23(ip,iw),iw=1,31), ip=11,11)/ &
+        -0.2225e-09, -0.4104e-09, -0.7217e-09, -0.1192e-08, -0.1811e-08, &
+        -0.2509e-08, -0.3155e-08, -0.3668e-08, -0.4138e-08, -0.4650e-08, &
+        -0.5296e-08, -0.6785e-08, -0.9991e-08, -0.1494e-07, -0.2122e-07, &
+        -0.2911e-07, -0.3895e-07, -0.4979e-07, -0.6002e-07, -0.6964e-07, &
+        -0.7935e-07, -0.8887e-07, -0.9699e-07, -0.9967e-07, -0.8883e-07, &
+        -0.4988e-07,  0.4156e-07,  0.2197e-06,  0.5081e-06,  0.8667e-06, &
+         0.1212e-05/
+      data ((h21(ip,iw),iw=1,31), ip=12,12)/ &
+         0.99999607,  0.99999237,  0.99998528,  0.99997234,  0.99994951, &
+         0.99991143,  0.99985188,  0.99976480,  0.99964428,  0.99948311, &
+         0.99927050,  0.99899000,  0.99861199,  0.99809098,  0.99735999, &
+         0.99632198,  0.99484903,  0.99276900,  0.98984998,  0.98576999, &
+         0.98009998,  0.97224998,  0.96144003,  0.94667000,  0.92672002, &
+         0.90020001,  0.86570001,  0.82220000,  0.76919997,  0.70640004, &
+         0.63330001/
+      data ((h22(ip,iw),iw=1,31), ip=12,12)/ &
+        -0.5658e-07, -0.1083e-06, -0.2023e-06, -0.3650e-06, -0.6295e-06, &
+        -0.1030e-05, -0.1593e-05, -0.2334e-05, -0.3273e-05, -0.4455e-05, &
+        -0.5955e-05, -0.7935e-05, -0.1067e-04, -0.1455e-04, -0.2007e-04, &
+        -0.2788e-04, -0.3885e-04, -0.5409e-04, -0.7503e-04, -0.1036e-03, &
+        -0.1425e-03, -0.1951e-03, -0.2660e-03, -0.3598e-03, -0.4817e-03, &
+        -0.6355e-03, -0.8218e-03, -0.1035e-02, -0.1267e-02, -0.1508e-02, &
+        -0.1755e-02/
+      data ((h23(ip,iw),iw=1,31), ip=12,12)/ &
+        -0.2241e-09, -0.4142e-09, -0.7312e-09, -0.1214e-08, -0.1854e-08, &
+        -0.2578e-08, -0.3250e-08, -0.3765e-08, -0.4238e-08, -0.4809e-08, &
+        -0.5553e-08, -0.7132e-08, -0.1035e-07, -0.1538e-07, -0.2211e-07, &
+        -0.3079e-07, -0.4142e-07, -0.5303e-07, -0.6437e-07, -0.7566e-07, &
+        -0.8703e-07, -0.9700e-07, -0.1025e-06, -0.9718e-07, -0.6973e-07, &
+        -0.5265e-09,  0.1413e-06,  0.3895e-06,  0.7321e-06,  0.1085e-05, &
+         0.1449e-05/
+      data ((h21(ip,iw),iw=1,31), ip=13,13)/ &
+         0.99999607,  0.99999231,  0.99998522,  0.99997205,  0.99994856, &
+         0.99990892,  0.99984580,  0.99975121,  0.99961728,  0.99943388, &
+         0.99918568,  0.99884999,  0.99839199,  0.99775398,  0.99685299, &
+         0.99557197,  0.99375200,  0.99117702,  0.98755997,  0.98250002, &
+         0.97548002,  0.96575999,  0.95244002,  0.93436003,  0.91018999, &
+         0.87849998,  0.83810002,  0.78820002,  0.72870004,  0.65910000, &
+         0.57850003/
+      data ((h22(ip,iw),iw=1,31), ip=13,13)/ &
+        -0.5677e-07, -0.1090e-06, -0.2043e-06, -0.3709e-06, -0.6448e-06, &
+        -0.1066e-05, -0.1669e-05, -0.2480e-05, -0.3532e-05, -0.4887e-05, &
+        -0.6650e-05, -0.9017e-05, -0.1232e-04, -0.1701e-04, -0.2372e-04, &
+        -0.3325e-04, -0.4664e-04, -0.6528e-04, -0.9095e-04, -0.1260e-03, &
+        -0.1737e-03, -0.2381e-03, -0.3238e-03, -0.4359e-03, -0.5789e-03, &
+        -0.7549e-03, -0.9607e-03, -0.1188e-02, -0.1427e-02, -0.1674e-02, &
+        -0.1914e-02/
+      data ((h23(ip,iw),iw=1,31), ip=13,13)/ &
+        -0.2262e-09, -0.4191e-09, -0.7441e-09, -0.1244e-08, -0.1916e-08, &
+        -0.2687e-08, -0.3407e-08, -0.3947e-08, -0.4432e-08, -0.5059e-08, &
+        -0.5896e-08, -0.7538e-08, -0.1079e-07, -0.1606e-07, -0.2346e-07, &
+        -0.3305e-07, -0.4459e-07, -0.5720e-07, -0.6999e-07, -0.8300e-07, &
+        -0.9536e-07, -0.1039e-06, -0.1036e-06, -0.8526e-07, -0.3316e-07, &
+         0.7909e-07,  0.2865e-06,  0.6013e-06,  0.9580e-06,  0.1303e-05, &
+         0.1792e-05/
+      data ((h21(ip,iw),iw=1,31), ip=14,14)/ &
+         0.99999607,  0.99999231,  0.99998510,  0.99997163,  0.99994737, &
+         0.99990571,  0.99983770,  0.99973333,  0.99958128,  0.99936771, &
+         0.99907219,  0.99866599,  0.99810302,  0.99731499,  0.99620003, &
+         0.99461198,  0.99235398,  0.98916000,  0.98466998,  0.97839999, &
+         0.96969002,  0.95769000,  0.94133997,  0.91935998,  0.89029998, &
+         0.85290003,  0.80620003,  0.74989998,  0.68369997,  0.60679996, &
+         0.51899999/
+      data ((h22(ip,iw),iw=1,31), ip=14,14)/ &
+        -0.5703e-07, -0.1098e-06, -0.2071e-06, -0.3788e-06, -0.6657e-06, &
+        -0.1116e-05, -0.1776e-05, -0.2687e-05, -0.3898e-05, -0.5493e-05, &
+        -0.7607e-05, -0.1048e-04, -0.1450e-04, -0.2024e-04, -0.2845e-04, &
+        -0.4014e-04, -0.5658e-04, -0.7947e-04, -0.1110e-03, -0.1541e-03, &
+        -0.2125e-03, -0.2907e-03, -0.3936e-03, -0.5261e-03, -0.6912e-03, &
+        -0.8880e-03, -0.1109e-02, -0.1346e-02, -0.1591e-02, -0.1837e-02, &
+        -0.2054e-02/
+      data ((h23(ip,iw),iw=1,31), ip=14,14)/ &
+        -0.2288e-09, -0.4265e-09, -0.7627e-09, -0.1289e-08, -0.2011e-08, &
+        -0.2861e-08, -0.3673e-08, -0.4288e-08, -0.4812e-08, -0.5475e-08, &
+        -0.6365e-08, -0.8052e-08, -0.1142e-07, -0.1711e-07, -0.2533e-07, &
+        -0.3597e-07, -0.4862e-07, -0.6259e-07, -0.7708e-07, -0.9150e-07, &
+        -0.1035e-06, -0.1079e-06, -0.9742e-07, -0.5928e-07,  0.2892e-07, &
+         0.1998e-06,  0.4789e-06,  0.8298e-06,  0.1172e-05,  0.1583e-05, &
+         0.2329e-05/
+      data ((h21(ip,iw),iw=1,31), ip=15,15)/ &
+         0.99999607,  0.99999225,  0.99998498,  0.99997115,  0.99994600, &
+         0.99990171,  0.99982780,  0.99971092,  0.99953562,  0.99928278, &
+         0.99892598,  0.99842799,  0.99773300,  0.99675500,  0.99536800, &
+         0.99339402,  0.99058902,  0.98662001,  0.98104000,  0.97325999, &
+         0.96249002,  0.94773000,  0.92778003,  0.90125000,  0.86680001, &
+         0.82319999,  0.77010000,  0.70730001,  0.63400000,  0.54960001, &
+         0.45560002/
+      data ((h22(ip,iw),iw=1,31), ip=15,15)/ &
+        -0.5736e-07, -0.1109e-06, -0.2106e-06, -0.3890e-06, -0.6928e-06, &
+        -0.1181e-05, -0.1917e-05, -0.2965e-05, -0.4396e-05, -0.6315e-05, &
+        -0.8891e-05, -0.1242e-04, -0.1736e-04, -0.2442e-04, -0.3454e-04, &
+        -0.4892e-04, -0.6916e-04, -0.9735e-04, -0.1362e-03, -0.1891e-03, &
+        -0.2602e-03, -0.3545e-03, -0.4768e-03, -0.6310e-03, -0.8179e-03, &
+        -0.1032e-02, -0.1265e-02, -0.1508e-02, -0.1757e-02, -0.1989e-02, &
+        -0.2159e-02/
+      data ((h23(ip,iw),iw=1,31), ip=15,15)/ &
+        -0.2321e-09, -0.4350e-09, -0.7861e-09, -0.1347e-08, -0.2144e-08, &
+        -0.3120e-08, -0.4107e-08, -0.4892e-08, -0.5511e-08, -0.6164e-08, &
+        -0.7054e-08, -0.8811e-08, -0.1240e-07, -0.1862e-07, -0.2773e-07, &
+        -0.3957e-07, -0.5371e-07, -0.6939e-07, -0.8564e-07, -0.1006e-06, &
+        -0.1100e-06, -0.1066e-06, -0.8018e-07, -0.1228e-07,  0.1263e-06, &
+         0.3678e-06,  0.7022e-06,  0.1049e-05,  0.1411e-05,  0.2015e-05, &
+         0.3099e-05/
+      data ((h21(ip,iw),iw=1,31), ip=16,16)/ &
+         0.99999791,  0.99999589,  0.99999183,  0.99998391,  0.99996853, &
+         0.99993920,  0.99988472,  0.99978709,  0.99961978,  0.99934620, &
+         0.99892199,  0.99830103,  0.99742401,  0.99619502,  0.99445999, &
+         0.99199599,  0.98851001,  0.98360002,  0.97671002,  0.96710002, &
+         0.95378000,  0.93559003,  0.91112000,  0.87900001,  0.83780003, &
+         0.78680003,  0.72549999,  0.65300000,  0.56830001,  0.47140002, &
+         0.36650002/
+      data ((h22(ip,iw),iw=1,31), ip=16,16)/ &
+        -0.3122e-07, -0.6175e-07, -0.1214e-06, -0.2361e-06, -0.4518e-06, &
+        -0.8438e-06, -0.1524e-05, -0.2643e-05, -0.4380e-05, -0.6922e-05, &
+        -0.1042e-04, -0.1504e-04, -0.2125e-04, -0.2987e-04, -0.4200e-04, &
+        -0.5923e-04, -0.8383e-04, -0.1186e-03, -0.1670e-03, -0.2328e-03, &
+        -0.3204e-03, -0.4347e-03, -0.5802e-03, -0.7595e-03, -0.9703e-03, &
+        -0.1205e-02, -0.1457e-02, -0.1720e-02, -0.1980e-02, -0.2191e-02, &
+        -0.2290e-02/
+      data ((h23(ip,iw),iw=1,31), ip=16,16)/ &
+        -0.1376e-09, -0.2699e-09, -0.5220e-09, -0.9897e-09, -0.1819e-08, &
+        -0.3186e-08, -0.5224e-08, -0.7896e-08, -0.1090e-07, -0.1349e-07, &
+        -0.1443e-07, -0.1374e-07, -0.1386e-07, -0.1673e-07, -0.2237e-07, &
+        -0.3248e-07, -0.5050e-07, -0.7743e-07, -0.1097e-06, -0.1369e-06, &
+        -0.1463e-06, -0.1268e-06, -0.6424e-07,  0.5941e-07,  0.2742e-06, &
+         0.5924e-06,  0.9445e-06,  0.1286e-05,  0.1819e-05,  0.2867e-05, &
+         0.4527e-05/
+      data ((h21(ip,iw),iw=1,31), ip=17,17)/ &
+         0.99999756,  0.99999511,  0.99999028,  0.99998081,  0.99996233, &
+         0.99992681,  0.99986011,  0.99973929,  0.99953061,  0.99918979, &
+         0.99866599,  0.99790198,  0.99681997,  0.99528998,  0.99312103, &
+         0.99004799,  0.98571002,  0.97961998,  0.97105998,  0.95915002, &
+         0.94278002,  0.92061001,  0.89120001,  0.85320002,  0.80550003, &
+         0.74759996,  0.67900002,  0.59829998,  0.50520003,  0.40219998, &
+         0.29600000/
+      data ((h22(ip,iw),iw=1,31), ip=17,17)/ &
+        -0.3547e-07, -0.7029e-07, -0.1386e-06, -0.2709e-06, -0.5218e-06, &
+        -0.9840e-06, -0.1799e-05, -0.3156e-05, -0.5272e-05, -0.8357e-05, &
+        -0.1260e-04, -0.1827e-04, -0.2598e-04, -0.3667e-04, -0.5169e-04, &
+        -0.7312e-04, -0.1037e-03, -0.1467e-03, -0.2060e-03, -0.2857e-03, &
+        -0.3907e-03, -0.5257e-03, -0.6940e-03, -0.8954e-03, -0.1124e-02, &
+        -0.1371e-02, -0.1632e-02, -0.1897e-02, -0.2131e-02, -0.2275e-02, &
+        -0.2265e-02/
+      data ((h23(ip,iw),iw=1,31), ip=17,17)/ &
+        -0.1482e-09, -0.2910e-09, -0.5667e-09, -0.1081e-08, -0.2005e-08, &
+        -0.3554e-08, -0.5902e-08, -0.8925e-08, -0.1209e-07, -0.1448e-07, &
+        -0.1536e-07, -0.1565e-07, -0.1763e-07, -0.2088e-07, -0.2564e-07, &
+        -0.3635e-07, -0.5791e-07, -0.8907e-07, -0.1213e-06, -0.1418e-06, &
+        -0.1397e-06, -0.1000e-06, -0.4427e-08,  0.1713e-06,  0.4536e-06, &
+         0.8086e-06,  0.1153e-05,  0.1588e-05,  0.2437e-05,  0.3905e-05, &
+         0.5874e-05/
+      data ((h21(ip,iw),iw=1,31), ip=18,18)/ &
+         0.99999714,  0.99999428,  0.99998862,  0.99997741,  0.99995553, &
+         0.99991333,  0.99983358,  0.99968803,  0.99943441,  0.99901879, &
+         0.99837899,  0.99744099,  0.99609798,  0.99418801,  0.99147803, &
+         0.98764998,  0.98227000,  0.97469997,  0.96410000,  0.94941998, &
+         0.92940998,  0.90263999,  0.86769998,  0.82330000,  0.76880002, &
+         0.70379996,  0.62720001,  0.53810000,  0.43769997,  0.33149999, &
+         0.22839999/
+      data ((h22(ip,iw),iw=1,31), ip=18,18)/ &
+        -0.4064e-07, -0.8066e-07, -0.1593e-06, -0.3124e-06, -0.6049e-06, &
+        -0.1148e-05, -0.2118e-05, -0.3751e-05, -0.6314e-05, -0.1006e-04, &
+        -0.1526e-04, -0.2232e-04, -0.3196e-04, -0.4525e-04, -0.6394e-04, &
+        -0.9058e-04, -0.1284e-03, -0.1812e-03, -0.2533e-03, -0.3493e-03, &
+        -0.4740e-03, -0.6315e-03, -0.8228e-03, -0.1044e-02, -0.1286e-02, &
+        -0.1544e-02, -0.1810e-02, -0.2061e-02, -0.2243e-02, -0.2291e-02, &
+        -0.2152e-02/
+      data ((h23(ip,iw),iw=1,31), ip=18,18)/ &
+        -0.1630e-09, -0.3213e-09, -0.6266e-09, -0.1201e-08, -0.2248e-08, &
+        -0.4030e-08, -0.6770e-08, -0.1033e-07, -0.1392e-07, -0.1640e-07, &
+        -0.1768e-07, -0.1932e-07, -0.2229e-07, -0.2508e-07, -0.2940e-07, &
+        -0.4200e-07, -0.6717e-07, -0.1002e-06, -0.1286e-06, -0.1402e-06, &
+        -0.1216e-06, -0.5487e-07,  0.8418e-07,  0.3246e-06,  0.6610e-06, &
+         0.1013e-05,  0.1394e-05,  0.2073e-05,  0.3337e-05,  0.5175e-05, &
+         0.7255e-05/
+      data ((h21(ip,iw),iw=1,31), ip=19,19)/ &
+         0.99999672,  0.99999344,  0.99998701,  0.99997419,  0.99994916, &
+         0.99990064,  0.99980861,  0.99963921,  0.99934143,  0.99884701, &
+         0.99807602,  0.99692601,  0.99525797,  0.99287403,  0.98948997, &
+         0.98474002,  0.97804999,  0.96867001,  0.95559001,  0.93761998, &
+         0.91336000,  0.88139999,  0.84029996,  0.78920001,  0.72770000, &
+         0.65499997,  0.56999999,  0.47280002,  0.36760002,  0.26220000, &
+         0.16700000/
+      data ((h22(ip,iw),iw=1,31), ip=19,19)/ &
+        -0.4629e-07, -0.9195e-07, -0.1819e-06, -0.3572e-06, -0.6936e-06, &
+        -0.1323e-05, -0.2456e-05, -0.4385e-05, -0.7453e-05, -0.1200e-04, &
+        -0.1843e-04, -0.2731e-04, -0.3943e-04, -0.5606e-04, -0.7936e-04, &
+        -0.1123e-03, -0.1588e-03, -0.2231e-03, -0.3101e-03, -0.4247e-03, &
+        -0.5713e-03, -0.7522e-03, -0.9651e-03, -0.1202e-02, -0.1456e-02, &
+        -0.1721e-02, -0.1983e-02, -0.2196e-02, -0.2296e-02, -0.2224e-02, &
+        -0.1952e-02/
+      data ((h23(ip,iw),iw=1,31), ip=19,19)/ &
+        -0.1827e-09, -0.3607e-09, -0.7057e-09, -0.1359e-08, -0.2552e-08, &
+        -0.4615e-08, -0.7854e-08, -0.1218e-07, -0.1670e-07, -0.2008e-07, &
+        -0.2241e-07, -0.2516e-07, -0.2796e-07, -0.3015e-07, -0.3506e-07, &
+        -0.4958e-07, -0.7627e-07, -0.1070e-06, -0.1289e-06, -0.1286e-06, &
+        -0.8843e-07,  0.1492e-07,  0.2118e-06,  0.5155e-06,  0.8665e-06, &
+         0.1220e-05,  0.1765e-05,  0.2825e-05,  0.4498e-05,  0.6563e-05, &
+         0.8422e-05/
+      data ((h21(ip,iw),iw=1,31), ip=20,20)/ &
+         0.99999636,  0.99999279,  0.99998569,  0.99997163,  0.99994397, &
+         0.99989033,  0.99978799,  0.99959832,  0.99926043,  0.99868900, &
+         0.99777400,  0.99637598,  0.99431503,  0.99134803,  0.98714000, &
+         0.98122001,  0.97290999,  0.96131998,  0.94528997,  0.92346001, &
+         0.89429998,  0.85650003,  0.80879998,  0.75080001,  0.68190002, &
+         0.60100001,  0.50740004,  0.40399998,  0.29729998,  0.19730002, &
+         0.11479998/
+      data ((h22(ip,iw),iw=1,31), ip=20,20)/ &
+        -0.5164e-07, -0.1026e-06, -0.2031e-06, -0.3994e-06, -0.7771e-06, &
+        -0.1488e-05, -0.2776e-05, -0.5001e-05, -0.8610e-05, -0.1411e-04, &
+        -0.2209e-04, -0.3328e-04, -0.4860e-04, -0.6954e-04, -0.9861e-04, &
+        -0.1393e-03, -0.1961e-03, -0.2738e-03, -0.3778e-03, -0.5132e-03, &
+        -0.6831e-03, -0.8868e-03, -0.1118e-02, -0.1368e-02, -0.1632e-02, &
+        -0.1899e-02, -0.2136e-02, -0.2282e-02, -0.2273e-02, -0.2067e-02, &
+        -0.1679e-02/
+      data ((h23(ip,iw),iw=1,31), ip=20,20)/ &
+        -0.2058e-09, -0.4066e-09, -0.7967e-09, -0.1539e-08, -0.2904e-08, &
+        -0.5293e-08, -0.9116e-08, -0.1447e-07, -0.2058e-07, -0.2608e-07, &
+        -0.3053e-07, -0.3418e-07, -0.3619e-07, -0.3766e-07, -0.4313e-07, &
+        -0.5817e-07, -0.8299e-07, -0.1072e-06, -0.1195e-06, -0.1031e-06, &
+        -0.3275e-07,  0.1215e-06,  0.3835e-06,  0.7220e-06,  0.1062e-05, &
+         0.1504e-05,  0.2367e-05,  0.3854e-05,  0.5842e-05,  0.7875e-05, &
+         0.9082e-05/
+      data ((h21(ip,iw),iw=1,31), ip=21,21)/ &
+         0.99999619,  0.99999237,  0.99998480,  0.99996990,  0.99994045, &
+         0.99988312,  0.99977320,  0.99956751,  0.99919540,  0.99855101, &
+         0.99748802,  0.99581498,  0.99329299,  0.98961997,  0.98439002, &
+         0.97702003,  0.96671999,  0.95245999,  0.93291998,  0.90660000, &
+         0.87199998,  0.82780004,  0.77329999,  0.70819998,  0.63119996, &
+         0.54159999,  0.44059998,  0.33380002,  0.23000002,  0.14029998, &
+         0.07340002/
+      data ((h22(ip,iw),iw=1,31), ip=21,21)/ &
+        -0.5584e-07, -0.1110e-06, -0.2198e-06, -0.4329e-06, -0.8444e-06, &
+        -0.1623e-05, -0.3049e-05, -0.5551e-05, -0.9714e-05, -0.1627e-04, &
+        -0.2609e-04, -0.4015e-04, -0.5955e-04, -0.8603e-04, -0.1223e-03, &
+        -0.1724e-03, -0.2413e-03, -0.3346e-03, -0.4578e-03, -0.6155e-03, &
+        -0.8087e-03, -0.1033e-02, -0.1279e-02, -0.1540e-02, -0.1811e-02, &
+        -0.2065e-02, -0.2251e-02, -0.2301e-02, -0.2163e-02, -0.1828e-02, &
+        -0.1365e-02/
+      data ((h23(ip,iw),iw=1,31), ip=21,21)/ &
+        -0.2274e-09, -0.4498e-09, -0.8814e-09, -0.1708e-08, -0.3247e-08, &
+        -0.5972e-08, -0.1045e-07, -0.1707e-07, -0.2545e-07, -0.3440e-07, &
+        -0.4259e-07, -0.4822e-07, -0.5004e-07, -0.5061e-07, -0.5485e-07, &
+        -0.6687e-07, -0.8483e-07, -0.9896e-07, -0.9646e-07, -0.5557e-07, &
+         0.5765e-07,  0.2752e-06,  0.5870e-06,  0.9188e-06,  0.1291e-05, &
+         0.1971e-05,  0.3251e-05,  0.5115e-05,  0.7221e-05,  0.8825e-05, &
+         0.9032e-05/
+      data ((h21(ip,iw),iw=1,31), ip=22,22)/ &
+         0.99999607,  0.99999213,  0.99998438,  0.99996895,  0.99993849, &
+         0.99987900,  0.99976391,  0.99954629,  0.99914569,  0.99843502, &
+         0.99722600,  0.99526101,  0.99221897,  0.98771000,  0.98123002, &
+         0.97209001,  0.95936000,  0.94187999,  0.91820002,  0.88679999, &
+         0.84609997,  0.79530001,  0.73379999,  0.66090000,  0.57529998, &
+         0.47740000,  0.37129998,  0.26490003,  0.16890001,  0.09340000, &
+         0.04310000/
+      data ((h22(ip,iw),iw=1,31), ip=22,22)/ &
+        -0.5833e-07, -0.1160e-06, -0.2300e-06, -0.4540e-06, -0.8885e-06, &
+        -0.1718e-05, -0.3256e-05, -0.6010e-05, -0.1072e-04, -0.1838e-04, &
+        -0.3026e-04, -0.4772e-04, -0.7223e-04, -0.1057e-03, -0.1512e-03, &
+        -0.2128e-03, -0.2961e-03, -0.4070e-03, -0.5514e-03, -0.7320e-03, &
+        -0.9467e-03, -0.1187e-02, -0.1446e-02, -0.1717e-02, -0.1985e-02, &
+        -0.2203e-02, -0.2307e-02, -0.2237e-02, -0.1965e-02, -0.1532e-02, &
+        -0.1044e-02/
+      data ((h23(ip,iw),iw=1,31), ip=22,22)/ &
+        -0.2426e-09, -0.4805e-09, -0.9447e-09, -0.1841e-08, -0.3519e-08, &
+        -0.6565e-08, -0.1172e-07, -0.1979e-07, -0.3095e-07, -0.4443e-07, &
+        -0.5821e-07, -0.6868e-07, -0.7282e-07, -0.7208e-07, -0.7176e-07, &
+        -0.7562e-07, -0.8110e-07, -0.7934e-07, -0.5365e-07,  0.2483e-07, &
+         0.1959e-06,  0.4731e-06,  0.7954e-06,  0.1123e-05,  0.1652e-05, &
+         0.2711e-05,  0.4402e-05,  0.6498e-05,  0.8392e-05,  0.9154e-05, &
+         0.8261e-05/
+      data ((h21(ip,iw),iw=1,31), ip=23,23)/ &
+         0.99999601,  0.99999207,  0.99998420,  0.99996859,  0.99993771, &
+         0.99987692,  0.99975860,  0.99953198,  0.99910772,  0.99833697, &
+         0.99698901,  0.99473202,  0.99113101,  0.98566002,  0.97770000, &
+         0.96640998,  0.95076001,  0.92943001,  0.90092003,  0.86370003, &
+         0.81659997,  0.75889999,  0.69000000,  0.60870004,  0.51440001, &
+         0.40990001,  0.30190003,  0.20060003,  0.11680001,  0.05760002, &
+         0.02270001/
+      data ((h22(ip,iw),iw=1,31), ip=23,23)/ &
+        -0.5929e-07, -0.1180e-06, -0.2344e-06, -0.4638e-06, -0.9118e-06, &
+        -0.1775e-05, -0.3401e-05, -0.6375e-05, -0.1160e-04, -0.2039e-04, &
+        -0.3444e-04, -0.5575e-04, -0.8641e-04, -0.1287e-03, -0.1856e-03, &
+        -0.2615e-03, -0.3618e-03, -0.4928e-03, -0.6594e-03, -0.8621e-03, &
+        -0.1095e-02, -0.1349e-02, -0.1618e-02, -0.1894e-02, -0.2140e-02, &
+        -0.2293e-02, -0.2290e-02, -0.2085e-02, -0.1696e-02, -0.1212e-02, &
+        -0.7506e-03/
+      data ((h23(ip,iw),iw=1,31), ip=23,23)/ &
+        -0.2496e-09, -0.4954e-09, -0.9780e-09, -0.1915e-08, -0.3697e-08, &
+        -0.6991e-08, -0.1279e-07, -0.2231e-07, -0.3653e-07, -0.5541e-07, &
+        -0.7688e-07, -0.9614e-07, -0.1069e-06, -0.1065e-06, -0.9866e-07, &
+        -0.8740e-07, -0.7192e-07, -0.4304e-07,  0.1982e-07,  0.1525e-06, &
+         0.3873e-06,  0.6947e-06,  0.1000e-05,  0.1409e-05,  0.2253e-05, &
+         0.3739e-05,  0.5744e-05,  0.7812e-05,  0.9067e-05,  0.8746e-05, &
+         0.6940e-05/
+      data ((h21(ip,iw),iw=1,31), ip=24,24)/ &
+         0.99999601,  0.99999207,  0.99998420,  0.99996853,  0.99993742, &
+         0.99987602,  0.99975550,  0.99952233,  0.99907869,  0.99825698, &
+         0.99678302,  0.99424398,  0.99007100,  0.98356003,  0.97387999, &
+         0.96004999,  0.94090003,  0.91503000,  0.88099998,  0.83740002, &
+         0.78350002,  0.71869999,  0.64170003,  0.55149996,  0.44950002, &
+         0.34100002,  0.23540002,  0.14380002,  0.07550001,  0.03240001, &
+         0.01029998/
+      data ((h22(ip,iw),iw=1,31), ip=24,24)/ &
+        -0.5950e-07, -0.1185e-06, -0.2358e-06, -0.4678e-06, -0.9235e-06, &
+        -0.1810e-05, -0.3503e-05, -0.6664e-05, -0.1236e-04, -0.2223e-04, &
+        -0.3849e-04, -0.6396e-04, -0.1017e-03, -0.1545e-03, -0.2257e-03, &
+        -0.3192e-03, -0.4399e-03, -0.5933e-03, -0.7824e-03, -0.1005e-02, &
+        -0.1251e-02, -0.1516e-02, -0.1794e-02, -0.2060e-02, -0.2257e-02, &
+        -0.2318e-02, -0.2186e-02, -0.1853e-02, -0.1386e-02, -0.9021e-03, &
+        -0.5050e-03/
+      data ((h23(ip,iw),iw=1,31), ip=24,24)/ &
+        -0.2515e-09, -0.5001e-09, -0.9904e-09, -0.1951e-08, -0.3800e-08, &
+        -0.7288e-08, -0.1362e-07, -0.2452e-07, -0.4184e-07, -0.6663e-07, &
+        -0.9770e-07, -0.1299e-06, -0.1533e-06, -0.1584e-06, -0.1425e-06, &
+        -0.1093e-06, -0.5972e-07,  0.1426e-07,  0.1347e-06,  0.3364e-06, &
+         0.6209e-06,  0.9169e-06,  0.1243e-05,  0.1883e-05,  0.3145e-05, &
+         0.5011e-05,  0.7136e-05,  0.8785e-05,  0.9048e-05,  0.7686e-05, &
+         0.5368e-05/
+      data ((h21(ip,iw),iw=1,31), ip=25,25)/ &
+         0.99999601,  0.99999207,  0.99998420,  0.99996847,  0.99993724, &
+         0.99987543,  0.99975342,  0.99951530,  0.99905682,  0.99819201, &
+         0.99660802,  0.99381101,  0.98908001,  0.98148000,  0.96991003, &
+         0.95317000,  0.92992002,  0.89880002,  0.85839999,  0.80799997, &
+         0.74689996,  0.67420000,  0.58850002,  0.48979998,  0.38200003, &
+         0.27329999,  0.17479998,  0.09700000,  0.04500002,  0.01620001, &
+         0.00349998/
+      data ((h22(ip,iw),iw=1,31), ip=25,25)/ &
+        -0.5953e-07, -0.1187e-06, -0.2363e-06, -0.4697e-06, -0.9304e-06, &
+        -0.1833e-05, -0.3578e-05, -0.6889e-05, -0.1299e-04, -0.2384e-04, &
+        -0.4227e-04, -0.7201e-04, -0.1174e-03, -0.1825e-03, -0.2710e-03, &
+        -0.3861e-03, -0.5313e-03, -0.7095e-03, -0.9203e-03, -0.1158e-02, &
+        -0.1417e-02, -0.1691e-02, -0.1968e-02, -0.2200e-02, -0.2320e-02, &
+        -0.2263e-02, -0.1998e-02, -0.1563e-02, -0.1068e-02, -0.6300e-03, &
+        -0.3174e-03/
+      data ((h23(ip,iw),iw=1,31), ip=25,25)/ &
+        -0.2520e-09, -0.5016e-09, -0.9963e-09, -0.1971e-08, -0.3867e-08, &
+        -0.7500e-08, -0.1427e-07, -0.2634e-07, -0.4656e-07, -0.7753e-07, &
+        -0.1196e-06, -0.1683e-06, -0.2113e-06, -0.2309e-06, -0.2119e-06, &
+        -0.1518e-06, -0.5200e-07,  0.9274e-07,  0.2973e-06,  0.5714e-06, &
+         0.8687e-06,  0.1152e-05,  0.1621e-05,  0.2634e-05,  0.4310e-05, &
+         0.6418e-05,  0.8347e-05,  0.9162e-05,  0.8319e-05,  0.6209e-05, &
+         0.3844e-05/
+      data ((h21(ip,iw),iw=1,31), ip=26,26)/ &
+         0.99999601,  0.99999207,  0.99998420,  0.99996847,  0.99993718, &
+         0.99987501,  0.99975210,  0.99951041,  0.99904078,  0.99814302, &
+         0.99646801,  0.99344200,  0.98819000,  0.97952002,  0.96597999, &
+         0.94600999,  0.91812003,  0.88099998,  0.83359998,  0.77569997, &
+         0.70669997,  0.62529999,  0.53049999,  0.42449999,  0.31419998, &
+         0.20969999,  0.12269998,  0.06089997,  0.02420002,  0.00660002, &
+         0.00040001/
+      data ((h22(ip,iw),iw=1,31), ip=26,26)/ &
+        -0.5954e-07, -0.1187e-06, -0.2366e-06, -0.4709e-06, -0.9349e-06, &
+        -0.1849e-05, -0.3632e-05, -0.7058e-05, -0.1350e-04, -0.2521e-04, &
+        -0.4564e-04, -0.7958e-04, -0.1329e-03, -0.2114e-03, -0.3200e-03, &
+        -0.4611e-03, -0.6353e-03, -0.8409e-03, -0.1072e-02, -0.1324e-02, &
+        -0.1592e-02, -0.1871e-02, -0.2127e-02, -0.2297e-02, -0.2312e-02, &
+        -0.2123e-02, -0.1738e-02, -0.1247e-02, -0.7744e-03, -0.4117e-03, &
+        -0.1850e-03/
+      data ((h23(ip,iw),iw=1,31), ip=26,26)/ &
+        -0.2522e-09, -0.5025e-09, -0.9997e-09, -0.1983e-08, -0.3912e-08, &
+        -0.7650e-08, -0.1474e-07, -0.2777e-07, -0.5055e-07, -0.8745e-07, &
+        -0.1414e-06, -0.2095e-06, -0.2790e-06, -0.3241e-06, -0.3135e-06, &
+        -0.2269e-06, -0.5896e-07,  0.1875e-06,  0.4996e-06,  0.8299e-06, &
+         0.1115e-05,  0.1467e-05,  0.2236e-05,  0.3672e-05,  0.5668e-05, &
+         0.7772e-05,  0.9094e-05,  0.8827e-05,  0.7041e-05,  0.4638e-05, &
+         0.2539e-05/
+      data ((h81(ip,iw),iw=1,31), ip= 1, 1)/ &
+         0.99998659,  0.99997360,  0.99994862,  0.99990171,  0.99981678, &
+         0.99967158,  0.99944150,  0.99910933,  0.99867302,  0.99814397, &
+         0.99753898,  0.99686199,  0.99610198,  0.99523401,  0.99421698, &
+         0.99299300,  0.99147898,  0.98958999,  0.98721999,  0.98430002, &
+         0.98071998,  0.97639000,  0.97115999,  0.96480000,  0.95695001, &
+         0.94713998,  0.93469000,  0.91873002,  0.89810002,  0.87129998, &
+         0.83679998/
+      data ((h82(ip,iw),iw=1,31), ip= 1, 1)/ &
+        -0.5685e-08, -0.1331e-07, -0.3249e-07, -0.8137e-07, -0.2048e-06, &
+        -0.4973e-06, -0.1118e-05, -0.2246e-05, -0.3982e-05, -0.6290e-05, &
+        -0.9040e-05, -0.1215e-04, -0.1567e-04, -0.1970e-04, -0.2449e-04, &
+        -0.3046e-04, -0.3798e-04, -0.4725e-04, -0.5831e-04, -0.7123e-04, &
+        -0.8605e-04, -0.1028e-03, -0.1212e-03, -0.1413e-03, -0.1635e-03, &
+        -0.1884e-03, -0.2160e-03, -0.2461e-03, -0.2778e-03, -0.3098e-03, &
+        -0.3411e-03/
+      data ((h83(ip,iw),iw=1,31), ip= 1, 1)/ &
+         0.2169e-10,  0.5237e-10,  0.1296e-09,  0.3204e-09,  0.7665e-09, &
+         0.1691e-08,  0.3222e-08,  0.5110e-08,  0.6779e-08,  0.7681e-08, &
+         0.7378e-08,  0.5836e-08,  0.3191e-08, -0.1491e-08, -0.1022e-07, &
+        -0.2359e-07, -0.3957e-07, -0.5553e-07, -0.6927e-07, -0.7849e-07, &
+        -0.8139e-07, -0.7853e-07, -0.7368e-07, -0.7220e-07, -0.7780e-07, &
+        -0.9091e-07, -0.1038e-06, -0.9929e-07, -0.5422e-07,  0.5379e-07, &
+         0.2350e-06/
+      data ((h81(ip,iw),iw=1,31), ip= 2, 2)/ &
+         0.99998659,  0.99997360,  0.99994862,  0.99990171,  0.99981678, &
+         0.99967158,  0.99944139,  0.99910921,  0.99867302,  0.99814397, &
+         0.99753797,  0.99686003,  0.99609798,  0.99522603,  0.99420297, &
+         0.99296701,  0.99142998,  0.98949999,  0.98706001,  0.98400998, &
+         0.98021001,  0.97552001,  0.96976000,  0.96262002,  0.95367002, &
+         0.94234002,  0.92781997,  0.90903997,  0.88459998,  0.85290003, &
+         0.81200004/
+      data ((h82(ip,iw),iw=1,31), ip= 2, 2)/ &
+        -0.5684e-08, -0.1331e-07, -0.3248e-07, -0.8133e-07, -0.2047e-06, &
+        -0.4971e-06, -0.1117e-05, -0.2245e-05, -0.3981e-05, -0.6287e-05, &
+        -0.9035e-05, -0.1215e-04, -0.1565e-04, -0.1967e-04, -0.2444e-04, &
+        -0.3036e-04, -0.3780e-04, -0.4694e-04, -0.5779e-04, -0.7042e-04, &
+        -0.8491e-04, -0.1013e-03, -0.1196e-03, -0.1399e-03, -0.1625e-03, &
+        -0.1879e-03, -0.2163e-03, -0.2474e-03, -0.2803e-03, -0.3140e-03, &
+        -0.3478e-03/
+      data ((h83(ip,iw),iw=1,31), ip= 2, 2)/ &
+         0.2168e-10,  0.5242e-10,  0.1295e-09,  0.3201e-09,  0.7662e-09, &
+         0.1690e-08,  0.3220e-08,  0.5106e-08,  0.6776e-08,  0.7673e-08, &
+         0.7362e-08,  0.5808e-08,  0.3138e-08, -0.1595e-08, -0.1041e-07, &
+        -0.2390e-07, -0.4010e-07, -0.5636e-07, -0.7045e-07, -0.7972e-07, &
+        -0.8178e-07, -0.7677e-07, -0.6876e-07, -0.6381e-07, -0.6583e-07, &
+        -0.7486e-07, -0.8229e-07, -0.7017e-07, -0.1497e-07,  0.1051e-06, &
+         0.2990e-06/
+      data ((h81(ip,iw),iw=1,31), ip= 3, 3)/ &
+         0.99998659,  0.99997360,  0.99994862,  0.99990171,  0.99981678, &
+         0.99967152,  0.99944133,  0.99910891,  0.99867201,  0.99814302, &
+         0.99753499,  0.99685597,  0.99609101,  0.99521297,  0.99418002, &
+         0.99292499,  0.99135399,  0.98935997,  0.98681003,  0.98356998, &
+         0.97947001,  0.97430998,  0.96784997,  0.95972002,  0.94941002, &
+         0.93620002,  0.91912001,  0.89690000,  0.86790001,  0.83020002, &
+         0.78210002/
+      data ((h82(ip,iw),iw=1,31), ip= 3, 3)/ &
+        -0.5682e-08, -0.1330e-07, -0.3247e-07, -0.8129e-07, -0.2046e-06, &
+        -0.4968e-06, -0.1117e-05, -0.2244e-05, -0.3978e-05, -0.6283e-05, &
+        -0.9027e-05, -0.1213e-04, -0.1563e-04, -0.1963e-04, -0.2436e-04, &
+        -0.3021e-04, -0.3754e-04, -0.4649e-04, -0.5709e-04, -0.6940e-04, &
+        -0.8359e-04, -0.9986e-04, -0.1182e-03, -0.1388e-03, -0.1620e-03, &
+        -0.1882e-03, -0.2175e-03, -0.2498e-03, -0.2843e-03, -0.3203e-03, &
+        -0.3573e-03/
+      data ((h83(ip,iw),iw=1,31), ip= 3, 3)/ &
+         0.2167e-10,  0.5238e-10,  0.1294e-09,  0.3198e-09,  0.7656e-09, &
+         0.1688e-08,  0.3217e-08,  0.5104e-08,  0.6767e-08,  0.7661e-08, &
+         0.7337e-08,  0.5764e-08,  0.3051e-08, -0.1752e-08, -0.1068e-07, &
+        -0.2436e-07, -0.4081e-07, -0.5740e-07, -0.7165e-07, -0.8046e-07, &
+        -0.8082e-07, -0.7289e-07, -0.6141e-07, -0.5294e-07, -0.5134e-07, &
+        -0.5552e-07, -0.5609e-07, -0.3464e-07,  0.3275e-07,  0.1669e-06, &
+         0.3745e-06/
+      data ((h81(ip,iw),iw=1,31), ip= 4, 4)/ &
+         0.99998659,  0.99997360,  0.99994862,  0.99990171,  0.99981678, &
+         0.99967140,  0.99944109,  0.99910849,  0.99867100,  0.99814099, &
+         0.99753201,  0.99685001,  0.99607998,  0.99519402,  0.99414498, &
+         0.99286002,  0.99123698,  0.98914999,  0.98644000,  0.98293000, &
+         0.97842002,  0.97263998,  0.96529001,  0.95592999,  0.94392002, &
+         0.92839003,  0.90815997,  0.88169998,  0.84720004,  0.80269998, &
+         0.74629998/
+      data ((h82(ip,iw),iw=1,31), ip= 4, 4)/ &
+        -0.5680e-08, -0.1329e-07, -0.3243e-07, -0.8121e-07, -0.2044e-06, &
+        -0.4963e-06, -0.1115e-05, -0.2242e-05, -0.3974e-05, -0.6276e-05, &
+        -0.9015e-05, -0.1211e-04, -0.1559e-04, -0.1956e-04, -0.2423e-04, &
+        -0.2999e-04, -0.3716e-04, -0.4588e-04, -0.5618e-04, -0.6818e-04, &
+        -0.8218e-04, -0.9847e-04, -0.1171e-03, -0.1382e-03, -0.1621e-03, &
+        -0.1892e-03, -0.2197e-03, -0.2535e-03, -0.2902e-03, -0.3293e-03, &
+        -0.3700e-03/
+      data ((h83(ip,iw),iw=1,31), ip= 4, 4)/ &
+         0.2166e-10,  0.5229e-10,  0.1294e-09,  0.3193e-09,  0.7644e-09, &
+         0.1686e-08,  0.3213e-08,  0.5092e-08,  0.6753e-08,  0.7640e-08, &
+         0.7302e-08,  0.5696e-08,  0.2917e-08, -0.1984e-08, -0.1108e-07, &
+        -0.2497e-07, -0.4171e-07, -0.5849e-07, -0.7254e-07, -0.8017e-07, &
+        -0.7802e-07, -0.6662e-07, -0.5153e-07, -0.3961e-07, -0.3387e-07, &
+        -0.3219e-07, -0.2426e-07,  0.8700e-08,  0.9027e-07,  0.2400e-06, &
+         0.4623e-06/
+      data ((h81(ip,iw),iw=1,31), ip= 5, 5)/ &
+         0.99998659,  0.99997360,  0.99994862,  0.99990165,  0.99981672, &
+         0.99967128,  0.99944091,  0.99910778,  0.99866998,  0.99813801, &
+         0.99752700,  0.99684101,  0.99606299,  0.99516302,  0.99408901, &
+         0.99276000,  0.99105698,  0.98882997,  0.98588997,  0.98202002, &
+         0.97696000,  0.97039002,  0.96192998,  0.95104003,  0.93691999, &
+         0.91851997,  0.89440000,  0.86290002,  0.82200003,  0.76969999, &
+         0.70420003/
+      data ((h82(ip,iw),iw=1,31), ip= 5, 5)/ &
+        -0.5675e-08, -0.1328e-07, -0.3239e-07, -0.8110e-07, -0.2040e-06, &
+        -0.4954e-06, -0.1114e-05, -0.2238e-05, -0.3968e-05, -0.6265e-05, &
+        -0.8996e-05, -0.1208e-04, -0.1553e-04, -0.1945e-04, -0.2404e-04, &
+        -0.2966e-04, -0.3663e-04, -0.4508e-04, -0.5508e-04, -0.6686e-04, &
+        -0.8082e-04, -0.9732e-04, -0.1165e-03, -0.1382e-03, -0.1630e-03, &
+        -0.1913e-03, -0.2234e-03, -0.2593e-03, -0.2989e-03, -0.3417e-03, &
+        -0.3857e-03/
+      data ((h83(ip,iw),iw=1,31), ip= 5, 5)/ &
+         0.2163e-10,  0.5209e-10,  0.1291e-09,  0.3186e-09,  0.7626e-09, &
+         0.1682e-08,  0.3203e-08,  0.5078e-08,  0.6730e-08,  0.7606e-08, &
+         0.7246e-08,  0.5592e-08,  0.2735e-08, -0.2325e-08, -0.1162e-07, &
+        -0.2576e-07, -0.4268e-07, -0.5938e-07, -0.7262e-07, -0.7827e-07, &
+        -0.7297e-07, -0.5786e-07, -0.3930e-07, -0.2373e-07, -0.1295e-07, &
+        -0.3728e-08,  0.1465e-07,  0.6114e-07,  0.1590e-06,  0.3257e-06, &
+         0.5622e-06/
+      data ((h81(ip,iw),iw=1,31), ip= 6, 6)/ &
+         0.99998659,  0.99997360,  0.99994862,  0.99990165,  0.99981672, &
+         0.99967122,  0.99944037,  0.99910682,  0.99866802,  0.99813402, &
+         0.99751902,  0.99682599,  0.99603701,  0.99511498,  0.99400300, &
+         0.99260598,  0.99078500,  0.98835999,  0.98510998,  0.98075998, &
+         0.97499001,  0.96741998,  0.95757002,  0.94476998,  0.92804998, &
+         0.90613002,  0.87739998,  0.83990002,  0.79159999,  0.73049998, &
+         0.65540004/
+      data ((h82(ip,iw),iw=1,31), ip= 6, 6)/ &
+        -0.5671e-08, -0.1326e-07, -0.3234e-07, -0.8091e-07, -0.2035e-06, &
+        -0.4941e-06, -0.1111e-05, -0.2232e-05, -0.3958e-05, -0.6247e-05, &
+        -0.8966e-05, -0.1202e-04, -0.1544e-04, -0.1929e-04, -0.2377e-04, &
+        -0.2921e-04, -0.3593e-04, -0.4409e-04, -0.5385e-04, -0.6555e-04, &
+        -0.7965e-04, -0.9656e-04, -0.1163e-03, -0.1390e-03, -0.1649e-03, &
+        -0.1947e-03, -0.2288e-03, -0.2675e-03, -0.3109e-03, -0.3575e-03, &
+        -0.4039e-03/
+      data ((h83(ip,iw),iw=1,31), ip= 6, 6)/ &
+         0.2155e-10,  0.5188e-10,  0.1288e-09,  0.3175e-09,  0.7599e-09, &
+         0.1675e-08,  0.3190e-08,  0.5059e-08,  0.6699e-08,  0.7551e-08, &
+         0.7154e-08,  0.5435e-08,  0.2452e-08, -0.2802e-08, -0.1235e-07, &
+        -0.2668e-07, -0.4353e-07, -0.5962e-07, -0.7134e-07, -0.7435e-07, &
+        -0.6551e-07, -0.4676e-07, -0.2475e-07, -0.4876e-08,  0.1235e-07, &
+         0.3092e-07,  0.6192e-07,  0.1243e-06,  0.2400e-06,  0.4247e-06, &
+         0.6755e-06/
+      data ((h81(ip,iw),iw=1,31), ip= 7, 7)/ &
+         0.99998659,  0.99997360,  0.99994862,  0.99990165,  0.99981660, &
+         0.99967092,  0.99943972,  0.99910510,  0.99866402,  0.99812698, &
+         0.99750602,  0.99680197,  0.99599499,  0.99504000,  0.99387002, &
+         0.99237198,  0.99038202,  0.98768002,  0.98400998,  0.97903001, &
+         0.97236001,  0.96354002,  0.95196998,  0.93681002,  0.91688001, &
+         0.89069998,  0.85640001,  0.81190002,  0.75520003,  0.68470001, &
+         0.59990001/
+      data ((h82(ip,iw),iw=1,31), ip= 7, 7)/ &
+        -0.5665e-08, -0.1322e-07, -0.3224e-07, -0.8063e-07, -0.2027e-06, &
+        -0.4921e-06, -0.1106e-05, -0.2223e-05, -0.3942e-05, -0.6220e-05, &
+        -0.8920e-05, -0.1194e-04, -0.1530e-04, -0.1905e-04, -0.2337e-04, &
+        -0.2860e-04, -0.3505e-04, -0.4296e-04, -0.5259e-04, -0.6439e-04, &
+        -0.7884e-04, -0.9635e-04, -0.1170e-03, -0.1407e-03, -0.1681e-03, &
+        -0.1998e-03, -0.2366e-03, -0.2790e-03, -0.3265e-03, -0.3763e-03, &
+        -0.4235e-03/
+      data ((h83(ip,iw),iw=1,31), ip= 7, 7)/ &
+         0.2157e-10,  0.5178e-10,  0.1283e-09,  0.3162e-09,  0.7558e-09, &
+         0.1665e-08,  0.3169e-08,  0.5027e-08,  0.6645e-08,  0.7472e-08, &
+         0.7017e-08,  0.5212e-08,  0.2059e-08, -0.3443e-08, -0.1321e-07, &
+        -0.2754e-07, -0.4389e-07, -0.5869e-07, -0.6825e-07, -0.6819e-07, &
+        -0.5570e-07, -0.3343e-07, -0.7592e-08,  0.1778e-07,  0.4322e-07, &
+         0.7330e-07,  0.1190e-06,  0.1993e-06,  0.3348e-06,  0.5376e-06, &
+         0.8030e-06/
+      data ((h81(ip,iw),iw=1,31), ip= 8, 8)/ &
+         0.99998659,  0.99997360,  0.99994856,  0.99990159,  0.99981642, &
+         0.99967051,  0.99943858,  0.99910247,  0.99865901,  0.99811602, &
+         0.99748600,  0.99676597,  0.99592900,  0.99492502,  0.99366802, &
+         0.99202400,  0.98979002,  0.98672003,  0.98249000,  0.97671002, &
+         0.96890998,  0.95854002,  0.94483000,  0.92675000,  0.90289998, &
+         0.87160003,  0.83069998,  0.77829999,  0.71239996,  0.63209999, &
+         0.53839999/
+      data ((h82(ip,iw),iw=1,31), ip= 8, 8)/ &
+        -0.5652e-08, -0.1318e-07, -0.3210e-07, -0.8018e-07, -0.2014e-06, &
+        -0.4888e-06, -0.1099e-05, -0.2210e-05, -0.3918e-05, -0.6179e-05, &
+        -0.8849e-05, -0.1182e-04, -0.1509e-04, -0.1871e-04, -0.2284e-04, &
+        -0.2782e-04, -0.3403e-04, -0.4177e-04, -0.5145e-04, -0.6354e-04, &
+        -0.7853e-04, -0.9681e-04, -0.1185e-03, -0.1437e-03, -0.1729e-03, &
+        -0.2072e-03, -0.2475e-03, -0.2942e-03, -0.3457e-03, -0.3973e-03, &
+        -0.4434e-03/
+      data ((h83(ip,iw),iw=1,31), ip= 8, 8)/ &
+         0.2153e-10,  0.5151e-10,  0.1273e-09,  0.3136e-09,  0.7488e-09, &
+         0.1649e-08,  0.3142e-08,  0.4980e-08,  0.6559e-08,  0.7346e-08, &
+         0.6813e-08,  0.4884e-08,  0.1533e-08, -0.4209e-08, -0.1409e-07, &
+        -0.2801e-07, -0.4320e-07, -0.5614e-07, -0.6312e-07, -0.5976e-07, &
+        -0.4369e-07, -0.1775e-07,  0.1280e-07,  0.4534e-07,  0.8106e-07, &
+         0.1246e-06,  0.1874e-06,  0.2873e-06,  0.4433e-06,  0.6651e-06, &
+         0.9477e-06/
+      data ((h81(ip,iw),iw=1,31), ip= 9, 9)/ &
+         0.99998659,  0.99997360,  0.99994856,  0.99990153,  0.99981618, &
+         0.99966979,  0.99943691,  0.99909842,  0.99865001,  0.99809903, &
+         0.99745399,  0.99670798,  0.99582899,  0.99475002,  0.99336600, &
+         0.99151403,  0.98896003,  0.98540002,  0.98044997,  0.97364998, &
+         0.96445000,  0.95213997,  0.93579000,  0.91412002,  0.88550001, &
+         0.84810001,  0.79970002,  0.73850000,  0.66280001,  0.57309997, &
+         0.47189999/
+      data ((h82(ip,iw),iw=1,31), ip= 9, 9)/ &
+        -0.5629e-08, -0.1310e-07, -0.3186e-07, -0.7948e-07, -0.1995e-06, &
+        -0.4837e-06, -0.1088e-05, -0.2188e-05, -0.3880e-05, -0.6115e-05, &
+        -0.8743e-05, -0.1165e-04, -0.1480e-04, -0.1824e-04, -0.2216e-04, &
+        -0.2691e-04, -0.3293e-04, -0.4067e-04, -0.5057e-04, -0.6314e-04, &
+        -0.7885e-04, -0.9813e-04, -0.1212e-03, -0.1482e-03, -0.1799e-03, &
+        -0.2175e-03, -0.2622e-03, -0.3135e-03, -0.3678e-03, -0.4193e-03, &
+        -0.4627e-03/
+      data ((h83(ip,iw),iw=1,31), ip= 9, 9)/ &
+         0.2121e-10,  0.5076e-10,  0.1257e-09,  0.3091e-09,  0.7379e-09, &
+         0.1623e-08,  0.3097e-08,  0.4904e-08,  0.6453e-08,  0.7168e-08, &
+         0.6534e-08,  0.4458e-08,  0.8932e-09, -0.5026e-08, -0.1469e-07, &
+        -0.2765e-07, -0.4103e-07, -0.5169e-07, -0.5585e-07, -0.4913e-07, &
+        -0.2954e-07,  0.6372e-09,  0.3738e-07,  0.7896e-07,  0.1272e-06, &
+         0.1867e-06,  0.2682e-06,  0.3895e-06,  0.5672e-06,  0.8091e-06, &
+         0.1114e-05/
+      data ((h81(ip,iw),iw=1,31), ip=10,10)/ &
+         0.99998659,  0.99997360,  0.99994850,  0.99990141,  0.99981582, &
+         0.99966878,  0.99943417,  0.99909198,  0.99863601,  0.99807203, &
+         0.99740499,  0.99662101,  0.99567503,  0.99448699,  0.99292302, &
+         0.99078500,  0.98780000,  0.98360002,  0.97773999,  0.96968001, &
+         0.95872998,  0.94401997,  0.92440999,  0.89840001,  0.86409998, &
+         0.81959999,  0.76279998,  0.69190001,  0.60650003,  0.50839996, &
+         0.40249997/
+      data ((h82(ip,iw),iw=1,31), ip=10,10)/ &
+        -0.5597e-08, -0.1300e-07, -0.3148e-07, -0.7838e-07, -0.1964e-06, &
+        -0.4759e-06, -0.1071e-05, -0.2155e-05, -0.3822e-05, -0.6019e-05, &
+        -0.8586e-05, -0.1139e-04, -0.1439e-04, -0.1764e-04, -0.2134e-04, &
+        -0.2591e-04, -0.3188e-04, -0.3978e-04, -0.5011e-04, -0.6334e-04, &
+        -0.7998e-04, -0.1006e-03, -0.1253e-03, -0.1547e-03, -0.1895e-03, &
+        -0.2315e-03, -0.2811e-03, -0.3363e-03, -0.3917e-03, -0.4413e-03, &
+        -0.4809e-03/
+      data ((h83(ip,iw),iw=1,31), ip=10,10)/ &
+         0.2109e-10,  0.5017e-10,  0.1235e-09,  0.3021e-09,  0.7217e-09, &
+         0.1585e-08,  0.3028e-08,  0.4796e-08,  0.6285e-08,  0.6910e-08, &
+         0.6178e-08,  0.3945e-08,  0.2436e-09, -0.5632e-08, -0.1464e-07, &
+        -0.2596e-07, -0.3707e-07, -0.4527e-07, -0.4651e-07, -0.3644e-07, &
+        -0.1296e-07,  0.2250e-07,  0.6722e-07,  0.1202e-06,  0.1831e-06, &
+         0.2605e-06,  0.3627e-06,  0.5062e-06,  0.7064e-06,  0.9725e-06, &
+         0.1304e-05/
+      data ((h81(ip,iw),iw=1,31), ip=11,11)/ &
+         0.99998659,  0.99997354,  0.99994850,  0.99990124,  0.99981529, &
+         0.99966723,  0.99942988,  0.99908209,  0.99861503,  0.99803102, &
+         0.99732900,  0.99648702,  0.99544603,  0.99409997,  0.99228698, &
+         0.98977000,  0.98620999,  0.98120999,  0.97421998,  0.96458000, &
+         0.95146000,  0.93378001,  0.91017002,  0.87889999,  0.83810002, &
+         0.78549999,  0.71930003,  0.63859999,  0.54409999,  0.43970001, &
+         0.33249998/
+      data ((h82(ip,iw),iw=1,31), ip=11,11)/ &
+        -0.5538e-08, -0.1280e-07, -0.3089e-07, -0.7667e-07, -0.1917e-06, &
+        -0.4642e-06, -0.1045e-05, -0.2106e-05, -0.3736e-05, -0.5878e-05, &
+        -0.8363e-05, -0.1104e-04, -0.1387e-04, -0.1692e-04, -0.2044e-04, &
+        -0.2493e-04, -0.3101e-04, -0.3926e-04, -0.5020e-04, -0.6429e-04, &
+        -0.8213e-04, -0.1044e-03, -0.1314e-03, -0.1637e-03, -0.2027e-03, &
+        -0.2498e-03, -0.3042e-03, -0.3617e-03, -0.4163e-03, -0.4625e-03, &
+        -0.4969e-03/
+      data ((h83(ip,iw),iw=1,31), ip=11,11)/ &
+         0.2067e-10,  0.4903e-10,  0.1200e-09,  0.2917e-09,  0.6965e-09, &
+         0.1532e-08,  0.2925e-08,  0.4632e-08,  0.6054e-08,  0.6590e-08, &
+         0.5746e-08,  0.3436e-08, -0.2251e-09, -0.5703e-08, -0.1344e-07, &
+        -0.2256e-07, -0.3120e-07, -0.3690e-07, -0.3520e-07, -0.2164e-07, &
+         0.6510e-08,  0.4895e-07,  0.1037e-06,  0.1702e-06,  0.2502e-06, &
+         0.3472e-06,  0.4710e-06,  0.6379e-06,  0.8633e-06,  0.1159e-05, &
+         0.1514e-05/
+      data ((h81(ip,iw),iw=1,31), ip=12,12)/ &
+         0.99998659,  0.99997354,  0.99994838,  0.99990094,  0.99981439, &
+         0.99966472,  0.99942350,  0.99906689,  0.99858302,  0.99796802, &
+         0.99721497,  0.99628800,  0.99510801,  0.99354398,  0.99139601, &
+         0.98838001,  0.98409998,  0.97807997,  0.96967000,  0.95806998, &
+         0.94226003,  0.92093998,  0.89249998,  0.85510004,  0.80659997, &
+         0.74510002,  0.66909999,  0.57870001,  0.47680002,  0.36919999, &
+         0.26520002/
+      data ((h82(ip,iw),iw=1,31), ip=12,12)/ &
+        -0.5476e-08, -0.1257e-07, -0.3008e-07, -0.7418e-07, -0.1848e-06, &
+        -0.4468e-06, -0.1006e-05, -0.2032e-05, -0.3611e-05, -0.5679e-05, &
+        -0.8058e-05, -0.1059e-04, -0.1324e-04, -0.1612e-04, -0.1956e-04, &
+        -0.2411e-04, -0.3046e-04, -0.3925e-04, -0.5098e-04, -0.6619e-04, &
+        -0.8562e-04, -0.1100e-03, -0.1399e-03, -0.1761e-03, -0.2202e-03, &
+        -0.2726e-03, -0.3306e-03, -0.3885e-03, -0.4404e-03, -0.4820e-03, &
+        -0.5082e-03/
+      data ((h83(ip,iw),iw=1,31), ip=12,12)/ &
+         0.2041e-10,  0.4771e-10,  0.1149e-09,  0.2782e-09,  0.6614e-09, &
+         0.1451e-08,  0.2778e-08,  0.4401e-08,  0.5736e-08,  0.6189e-08, &
+         0.5315e-08,  0.3087e-08, -0.2518e-09, -0.4806e-08, -0.1071e-07, &
+        -0.1731e-07, -0.2346e-07, -0.2659e-07, -0.2184e-07, -0.4261e-08, &
+         0.2975e-07,  0.8112e-07,  0.1484e-06,  0.2308e-06,  0.3296e-06, &
+         0.4475e-06,  0.5942e-06,  0.7859e-06,  0.1041e-05,  0.1369e-05, &
+         0.1726e-05/
+      data ((h81(ip,iw),iw=1,31), ip=13,13)/ &
+         0.99998653,  0.99997348,  0.99994826,  0.99990052,  0.99981320, &
+         0.99966109,  0.99941391,  0.99904412,  0.99853402,  0.99787498, &
+         0.99704498,  0.99599600,  0.99462402,  0.99276501,  0.99017602, &
+         0.98651999,  0.98133999,  0.97403997,  0.96386999,  0.94984001, &
+         0.93071002,  0.90495998,  0.87080002,  0.82620001,  0.76910001, &
+         0.69790000,  0.61199999,  0.51320004,  0.40640002,  0.29970002, &
+         0.20359999/
+      data ((h82(ip,iw),iw=1,31), ip=13,13)/ &
+        -0.5362e-08, -0.1223e-07, -0.2895e-07, -0.7071e-07, -0.1748e-06, &
+        -0.4219e-06, -0.9516e-06, -0.1928e-05, -0.3436e-05, -0.5409e-05, &
+        -0.7666e-05, -0.1005e-04, -0.1254e-04, -0.1533e-04, -0.1880e-04, &
+        -0.2358e-04, -0.3038e-04, -0.3988e-04, -0.5264e-04, -0.6934e-04, &
+        -0.9083e-04, -0.1179e-03, -0.1515e-03, -0.1927e-03, -0.2424e-03, &
+        -0.2994e-03, -0.3591e-03, -0.4155e-03, -0.4634e-03, -0.4982e-03, &
+        -0.5096e-03/
+      data ((h83(ip,iw),iw=1,31), ip=13,13)/ &
+         0.1976e-10,  0.4551e-10,  0.1086e-09,  0.2601e-09,  0.6126e-09, &
+         0.1345e-08,  0.2583e-08,  0.4112e-08,  0.5365e-08,  0.5796e-08, &
+         0.5031e-08,  0.3182e-08,  0.5970e-09, -0.2547e-08, -0.6172e-08, &
+        -0.1017e-07, -0.1388e-07, -0.1430e-07, -0.6118e-08,  0.1624e-07, &
+         0.5791e-07,  0.1205e-06,  0.2025e-06,  0.3032e-06,  0.4225e-06, &
+         0.5619e-06,  0.7322e-06,  0.9528e-06,  0.1243e-05,  0.1592e-05, &
+         0.1904e-05/
+      data ((h81(ip,iw),iw=1,31), ip=14,14)/ &
+         0.99998653,  0.99997348,  0.99994808,  0.99989992,  0.99981129, &
+         0.99965578,  0.99939990,  0.99901080,  0.99846399,  0.99773800, &
+         0.99680001,  0.99558002,  0.99394703,  0.99169999,  0.98853999, &
+         0.98408002,  0.97776002,  0.96888000,  0.95652002,  0.93949002, &
+         0.91631001,  0.88529998,  0.84439999,  0.79159999,  0.72510004, &
+         0.64390004,  0.54890001,  0.44379997,  0.33560002,  0.23449999, &
+         0.15009999/
+      data ((h82(ip,iw),iw=1,31), ip=14,14)/ &
+        -0.5210e-08, -0.1172e-07, -0.2731e-07, -0.6598e-07, -0.1615e-06, &
+        -0.3880e-06, -0.8769e-06, -0.1787e-05, -0.3204e-05, -0.5066e-05, &
+        -0.7197e-05, -0.9451e-05, -0.1185e-04, -0.1465e-04, -0.1831e-04, &
+        -0.2346e-04, -0.3088e-04, -0.4132e-04, -0.5545e-04, -0.7410e-04, &
+        -0.9820e-04, -0.1288e-03, -0.1670e-03, -0.2140e-03, -0.2692e-03, &
+        -0.3293e-03, -0.3886e-03, -0.4417e-03, -0.4840e-03, -0.5073e-03, &
+        -0.4944e-03/
+      data ((h83(ip,iw),iw=1,31), ip=14,14)/ &
+         0.1880e-10,  0.4271e-10,  0.9966e-10,  0.2352e-09,  0.5497e-09, &
+         0.1205e-08,  0.2334e-08,  0.3765e-08,  0.4993e-08,  0.5532e-08, &
+         0.5148e-08,  0.4055e-08,  0.2650e-08,  0.1326e-08,  0.2019e-09, &
+        -0.1124e-08, -0.2234e-08,  0.2827e-09,  0.1247e-07,  0.4102e-07, &
+         0.9228e-07,  0.1682e-06,  0.2676e-06,  0.3885e-06,  0.5286e-06, &
+         0.6904e-06,  0.8871e-06,  0.1142e-05,  0.1466e-05,  0.1800e-05, &
+         0.2004e-05/
+      data ((h81(ip,iw),iw=1,31), ip=15,15)/ &
+         0.99998653,  0.99997336,  0.99994785,  0.99989909,  0.99980879, &
+         0.99964851,  0.99938041,  0.99896401,  0.99836302,  0.99754399, &
+         0.99645603,  0.99500400,  0.99302697,  0.99027801,  0.98640001, &
+         0.98092002,  0.97319001,  0.96234000,  0.94727999,  0.92657000, &
+         0.89850003,  0.86119998,  0.81260002,  0.75080001,  0.67429996, &
+         0.58350003,  0.48089999,  0.37250000,  0.26760000,  0.17650002, &
+         0.10610002/
+      data ((h82(ip,iw),iw=1,31), ip=15,15)/ &
+        -0.5045e-08, -0.1113e-07, -0.2540e-07, -0.6008e-07, -0.1449e-06, &
+        -0.3457e-06, -0.7826e-06, -0.1609e-05, -0.2920e-05, -0.4665e-05, &
+        -0.6691e-05, -0.8868e-05, -0.1127e-04, -0.1422e-04, -0.1820e-04, &
+        -0.2389e-04, -0.3213e-04, -0.4380e-04, -0.5975e-04, -0.8092e-04, &
+        -0.1083e-03, -0.1433e-03, -0.1873e-03, -0.2402e-03, -0.2997e-03, &
+        -0.3607e-03, -0.4178e-03, -0.4662e-03, -0.4994e-03, -0.5028e-03, &
+        -0.4563e-03/
+      data ((h83(ip,iw),iw=1,31), ip=15,15)/ &
+         0.1804e-10,  0.3983e-10,  0.9045e-10,  0.2080e-09,  0.4786e-09, &
+         0.1046e-08,  0.2052e-08,  0.3413e-08,  0.4704e-08,  0.5565e-08, &
+         0.5887e-08,  0.5981e-08,  0.6202e-08,  0.6998e-08,  0.8493e-08, &
+         0.1002e-07,  0.1184e-07,  0.1780e-07,  0.3483e-07,  0.7122e-07, &
+         0.1341e-06,  0.2259e-06,  0.3446e-06,  0.4866e-06,  0.6486e-06, &
+         0.8343e-06,  0.1063e-05,  0.1356e-05,  0.1690e-05,  0.1951e-05, &
+         0.2005e-05/
+      data ((h81(ip,iw),iw=1,31), ip=16,16)/ &
+         0.99998647,  0.99997330,  0.99994755,  0.99989808,  0.99980563, &
+         0.99963909,  0.99935490,  0.99890202,  0.99822801,  0.99728203, &
+         0.99599099,  0.99423301,  0.99181002,  0.98842001,  0.98364002, &
+         0.97689003,  0.96740001,  0.95414001,  0.93575001,  0.91060001, &
+         0.87680000,  0.83219999,  0.77490002,  0.70330000,  0.61689997, &
+         0.51750004,  0.40990001,  0.30239999,  0.20539999,  0.12750000, &
+         0.07150000/
+      data ((h82(ip,iw),iw=1,31), ip=16,16)/ &
+        -0.4850e-08, -0.1045e-07, -0.2334e-07, -0.5367e-07, -0.1265e-06, &
+        -0.2980e-06, -0.6750e-06, -0.1406e-05, -0.2601e-05, -0.4239e-05, &
+        -0.6201e-05, -0.8389e-05, -0.1091e-04, -0.1413e-04, -0.1859e-04, &
+        -0.2500e-04, -0.3432e-04, -0.4761e-04, -0.6595e-04, -0.9030e-04, &
+        -0.1219e-03, -0.1624e-03, -0.2126e-03, -0.2708e-03, -0.3327e-03, &
+        -0.3926e-03, -0.4458e-03, -0.4871e-03, -0.5045e-03, -0.4777e-03, &
+        -0.3954e-03/
+      data ((h83(ip,iw),iw=1,31), ip=16,16)/ &
+         0.1717e-10,  0.3723e-10,  0.8093e-10,  0.1817e-09,  0.4100e-09, &
+         0.8932e-09,  0.1791e-08,  0.3126e-08,  0.4634e-08,  0.6095e-08, &
+         0.7497e-08,  0.9170e-08,  0.1136e-07,  0.1453e-07,  0.1892e-07, &
+         0.2369e-07,  0.2909e-07,  0.3922e-07,  0.6232e-07,  0.1083e-06, &
+         0.1847e-06,  0.2943e-06,  0.4336e-06,  0.5970e-06,  0.7815e-06, &
+         0.9959e-06,  0.1263e-05,  0.1583e-05,  0.1880e-05,  0.2009e-05, &
+         0.1914e-05/
+      data ((h81(ip,iw),iw=1,31), ip=17,17)/ &
+         0.99998647,  0.99997318,  0.99994719,  0.99989688,  0.99980187, &
+         0.99962789,  0.99932390,  0.99882400,  0.99805701,  0.99694502, &
+         0.99538797,  0.99323398,  0.99023998,  0.98604000,  0.98013997, &
+         0.97182000,  0.96016002,  0.94391000,  0.92149997,  0.89100003, &
+         0.85049999,  0.79769999,  0.73089999,  0.64919996,  0.55350000, &
+         0.44760001,  0.33870000,  0.23670000,  0.15149999,  0.08810002, &
+         0.04570001/
+      data ((h82(ip,iw),iw=1,31), ip=17,17)/ &
+        -0.4673e-08, -0.9862e-08, -0.2135e-07, -0.4753e-07, -0.1087e-06, &
+        -0.2512e-06, -0.5671e-06, -0.1199e-05, -0.2281e-05, -0.3842e-05, &
+        -0.5804e-05, -0.8110e-05, -0.1088e-04, -0.1452e-04, -0.1961e-04, &
+        -0.2696e-04, -0.3768e-04, -0.5311e-04, -0.7444e-04, -0.1028e-03, &
+        -0.1397e-03, -0.1865e-03, -0.2427e-03, -0.3047e-03, -0.3667e-03, &
+        -0.4237e-03, -0.4712e-03, -0.5003e-03, -0.4921e-03, -0.4286e-03, &
+        -0.3188e-03/
+      data ((h83(ip,iw),iw=1,31), ip=17,17)/ &
+         0.1653e-10,  0.3436e-10,  0.7431e-10,  0.1605e-09,  0.3548e-09, &
+         0.7723e-09,  0.1595e-08,  0.2966e-08,  0.4849e-08,  0.7169e-08, &
+         0.1003e-07,  0.1366e-07,  0.1825e-07,  0.2419e-07,  0.3186e-07, &
+         0.4068e-07,  0.5064e-07,  0.6618e-07,  0.9684e-07,  0.1536e-06, &
+         0.2450e-06,  0.3730e-06,  0.5328e-06,  0.7184e-06,  0.9291e-06, &
+         0.1180e-05,  0.1484e-05,  0.1798e-05,  0.1992e-05,  0.1968e-05, &
+         0.1736e-05/
+      data ((h81(ip,iw),iw=1,31), ip=18,18)/ &
+         0.99998647,  0.99997312,  0.99994683,  0.99989569,  0.99979800, &
+         0.99961591,  0.99928999,  0.99873698,  0.99785602,  0.99653602, &
+         0.99464101,  0.99198103,  0.98825997,  0.98306000,  0.97574002, &
+         0.96548998,  0.95117003,  0.93129998,  0.90407002,  0.86739999, &
+         0.81910002,  0.75720000,  0.68040001,  0.58880001,  0.48530000, &
+         0.37610000,  0.27029997,  0.17830002,  0.10720003,  0.05790001, &
+         0.02740002/
+      data ((h82(ip,iw),iw=1,31), ip=18,18)/ &
+        -0.4532e-08, -0.9395e-08, -0.1978e-07, -0.4272e-07, -0.9442e-07, &
+        -0.2124e-06, -0.4747e-06, -0.1017e-05, -0.2003e-05, -0.3524e-05, &
+        -0.5567e-05, -0.8108e-05, -0.1127e-04, -0.1547e-04, -0.2138e-04, &
+        -0.2996e-04, -0.4251e-04, -0.6059e-04, -0.8563e-04, -0.1190e-03, &
+        -0.1623e-03, -0.2156e-03, -0.2767e-03, -0.3403e-03, -0.4006e-03, &
+        -0.4530e-03, -0.4912e-03, -0.4995e-03, -0.4563e-03, -0.3592e-03, &
+        -0.2383e-03/
+      data ((h83(ip,iw),iw=1,31), ip=18,18)/ &
+         0.1593e-10,  0.3276e-10,  0.6896e-10,  0.1476e-09,  0.3190e-09, &
+         0.6944e-09,  0.1474e-08,  0.2935e-08,  0.5300e-08,  0.8697e-08, &
+         0.1336e-07,  0.1946e-07,  0.2707e-07,  0.3637e-07,  0.4800e-07, &
+         0.6187e-07,  0.7806e-07,  0.1008e-06,  0.1404e-06,  0.2089e-06, &
+         0.3153e-06,  0.4613e-06,  0.6416e-06,  0.8506e-06,  0.1095e-05, &
+         0.1387e-05,  0.1708e-05,  0.1956e-05,  0.2003e-05,  0.1836e-05, &
+         0.1483e-05/
+      data ((h81(ip,iw),iw=1,31), ip=19,19)/ &
+         0.99998641,  0.99997300,  0.99994648,  0.99989462,  0.99979430, &
+         0.99960452,  0.99925661,  0.99864697,  0.99763900,  0.99607199, &
+         0.99376297,  0.99046898,  0.98584002,  0.97937000,  0.97031999, &
+         0.95766997,  0.94010001,  0.91588002,  0.88300002,  0.83920002, &
+         0.78230000,  0.71060002,  0.62360001,  0.52320004,  0.41450000, &
+         0.30589998,  0.20789999,  0.12900001,  0.07239997,  0.03590000, &
+         0.01539999/
+      data ((h82(ip,iw),iw=1,31), ip=19,19)/ &
+        -0.4448e-08, -0.9085e-08, -0.1877e-07, -0.3946e-07, -0.8472e-07, &
+        -0.1852e-06, -0.4074e-06, -0.8791e-06, -0.1789e-05, -0.3314e-05, &
+        -0.5521e-05, -0.8425e-05, -0.1215e-04, -0.1711e-04, -0.2407e-04, &
+        -0.3421e-04, -0.4905e-04, -0.7032e-04, -0.9985e-04, -0.1394e-03, &
+        -0.1897e-03, -0.2491e-03, -0.3132e-03, -0.3763e-03, -0.4332e-03, &
+        -0.4786e-03, -0.5005e-03, -0.4775e-03, -0.3970e-03, -0.2794e-03, &
+        -0.1652e-03/
+      data ((h83(ip,iw),iw=1,31), ip=19,19)/ &
+         0.1566e-10,  0.3219e-10,  0.6635e-10,  0.1400e-09,  0.2999e-09, &
+         0.6513e-09,  0.1406e-08,  0.2953e-08,  0.5789e-08,  0.1037e-07, &
+         0.1709e-07,  0.2623e-07,  0.3777e-07,  0.5159e-07,  0.6823e-07, &
+         0.8864e-07,  0.1134e-06,  0.1461e-06,  0.1960e-06,  0.2761e-06, &
+         0.3962e-06,  0.5583e-06,  0.7580e-06,  0.9957e-06,  0.1282e-05, &
+         0.1607e-05,  0.1898e-05,  0.2020e-05,  0.1919e-05,  0.1623e-05, &
+         0.1171e-05/
+      data ((h81(ip,iw),iw=1,31), ip=20,20)/ &
+         0.99998641,  0.99997294,  0.99994624,  0.99989372,  0.99979132, &
+         0.99959481,  0.99922693,  0.99856299,  0.99742502,  0.99558598, &
+         0.99278802,  0.98872000,  0.98295999,  0.97491002,  0.96368998, &
+         0.94812000,  0.92662001,  0.89719999,  0.85780001,  0.80599999, &
+         0.73969996,  0.65779996,  0.56130004,  0.45410001,  0.34369999, &
+         0.24030000,  0.15390003,  0.08950001,  0.04640001,  0.02090001, &
+         0.00800002/
+      data ((h82(ip,iw),iw=1,31), ip=20,20)/ &
+        -0.4403e-08, -0.8896e-08, -0.1818e-07, -0.3751e-07, -0.7880e-07, &
+        -0.1683e-06, -0.3640e-06, -0.7852e-06, -0.1640e-05, -0.3191e-05, &
+        -0.5634e-05, -0.9046e-05, -0.1355e-04, -0.1953e-04, -0.2786e-04, &
+        -0.3995e-04, -0.5752e-04, -0.8256e-04, -0.1174e-03, -0.1638e-03, &
+        -0.2211e-03, -0.2854e-03, -0.3507e-03, -0.4116e-03, -0.4633e-03, &
+        -0.4966e-03, -0.4921e-03, -0.4309e-03, -0.3215e-03, -0.2016e-03, &
+        -0.1061e-03/
+      data ((h83(ip,iw),iw=1,31), ip=20,20)/ &
+         0.1551e-10,  0.3147e-10,  0.6419e-10,  0.1356e-09,  0.2860e-09, &
+         0.6178e-09,  0.1353e-08,  0.2934e-08,  0.6095e-08,  0.1174e-07, &
+         0.2067e-07,  0.3346e-07,  0.5014e-07,  0.7024e-07,  0.9377e-07, &
+         0.1226e-06,  0.1592e-06,  0.2056e-06,  0.2678e-06,  0.3584e-06, &
+         0.4892e-06,  0.6651e-06,  0.8859e-06,  0.1160e-05,  0.1488e-05, &
+         0.1814e-05,  0.2010e-05,  0.1984e-05,  0.1748e-05,  0.1338e-05, &
+         0.8445e-06/
+      data ((h81(ip,iw),iw=1,31), ip=21,21)/ &
+         0.99998641,  0.99997288,  0.99994606,  0.99989301,  0.99978900, &
+         0.99958712,  0.99920273,  0.99849200,  0.99723101,  0.99511403, &
+         0.99177098,  0.98677999,  0.97962999,  0.96961999,  0.95573002, &
+         0.93658000,  0.91036999,  0.87500000,  0.82800001,  0.76730001, &
+         0.69110000,  0.59930003,  0.49479997,  0.38370001,  0.27590001, &
+         0.18210000,  0.10949999,  0.05919999,  0.02800000,  0.01130003, &
+         0.00389999/
+      data ((h82(ip,iw),iw=1,31), ip=21,21)/ &
+        -0.4379e-08, -0.8801e-08, -0.1782e-07, -0.3642e-07, -0.7536e-07, &
+        -0.1581e-06, -0.3366e-06, -0.7227e-06, -0.1532e-05, -0.3106e-05, &
+        -0.5810e-05, -0.9862e-05, -0.1540e-04, -0.2279e-04, -0.3292e-04, &
+        -0.4738e-04, -0.6817e-04, -0.9765e-04, -0.1384e-03, -0.1918e-03, &
+        -0.2551e-03, -0.3226e-03, -0.3876e-03, -0.4452e-03, -0.4883e-03, &
+        -0.5005e-03, -0.4598e-03, -0.3633e-03, -0.2416e-03, -0.1349e-03, &
+        -0.6278e-04/
+      data ((h83(ip,iw),iw=1,31), ip=21,21)/ &
+         0.1542e-10,  0.3111e-10,  0.6345e-10,  0.1310e-09,  0.2742e-09, &
+         0.5902e-09,  0.1289e-08,  0.2826e-08,  0.6103e-08,  0.1250e-07, &
+         0.2355e-07,  0.4041e-07,  0.6347e-07,  0.9217e-07,  0.1256e-06, &
+         0.1658e-06,  0.2175e-06,  0.2824e-06,  0.3607e-06,  0.4614e-06, &
+         0.6004e-06,  0.7880e-06,  0.1034e-05,  0.1349e-05,  0.1698e-05, &
+         0.1965e-05,  0.2021e-05,  0.1857e-05,  0.1500e-05,  0.1015e-05, &
+         0.5467e-06/
+      data ((h81(ip,iw),iw=1,31), ip=22,22)/ &
+         0.99998635,  0.99997288,  0.99994594,  0.99989259,  0.99978727, &
+         0.99958128,  0.99918407,  0.99843502,  0.99706697,  0.99468601, &
+         0.99077803,  0.98474997,  0.97593999,  0.96350998,  0.94633001, &
+         0.92282999,  0.89100003,  0.84860003,  0.79330003,  0.72299999, &
+         0.63670003,  0.53600001,  0.42580003,  0.31470001,  0.21410000, &
+         0.13300002,  0.07470000,  0.03710002,  0.01580000,  0.00580001, &
+         0.00169998/
+      data ((h82(ip,iw),iw=1,31), ip=22,22)/ &
+        -0.4366e-08, -0.8749e-08, -0.1761e-07, -0.3578e-07, -0.7322e-07, &
+        -0.1517e-06, -0.3189e-06, -0.6785e-06, -0.1446e-05, -0.3014e-05, &
+        -0.5933e-05, -0.1069e-04, -0.1755e-04, -0.2683e-04, -0.3936e-04, &
+        -0.5675e-04, -0.8137e-04, -0.1160e-03, -0.1630e-03, -0.2223e-03, &
+        -0.2899e-03, -0.3589e-03, -0.4230e-03, -0.4755e-03, -0.5031e-03, &
+        -0.4834e-03, -0.4036e-03, -0.2849e-03, -0.1687e-03, -0.8356e-04, &
+        -0.3388e-04/
+      data ((h83(ip,iw),iw=1,31), ip=22,22)/ &
+         0.1536e-10,  0.3086e-10,  0.6248e-10,  0.1288e-09,  0.2664e-09, &
+         0.5637e-09,  0.1222e-08,  0.2680e-08,  0.5899e-08,  0.1262e-07, &
+         0.2527e-07,  0.4621e-07,  0.7678e-07,  0.1165e-06,  0.1640e-06, &
+         0.2199e-06,  0.2904e-06,  0.3783e-06,  0.4787e-06,  0.5925e-06, &
+         0.7377e-06,  0.9389e-06,  0.1216e-05,  0.1560e-05,  0.1879e-05, &
+         0.2025e-05,  0.1940e-05,  0.1650e-05,  0.1194e-05,  0.6981e-06, &
+         0.3103e-06/
+      data ((h81(ip,iw),iw=1,31), ip=23,23)/ &
+         0.99998635,  0.99997282,  0.99994588,  0.99989229,  0.99978608, &
+         0.99957722,  0.99917048,  0.99839097,  0.99693698,  0.99432403, &
+         0.98987001,  0.98273998,  0.97201002,  0.95668000,  0.93548000, &
+         0.90671998,  0.86830002,  0.81800002,  0.75330001,  0.67299998, &
+         0.57720000,  0.46920002,  0.35659999,  0.25010002,  0.16049999, &
+         0.09350002,  0.04850000,  0.02179998,  0.00840002,  0.00269997, &
+         0.00070000/
+      data ((h82(ip,iw),iw=1,31), ip=23,23)/ &
+        -0.4359e-08, -0.8720e-08, -0.1749e-07, -0.3527e-07, -0.7175e-07, &
+        -0.1473e-06, -0.3062e-06, -0.6451e-06, -0.1372e-05, -0.2902e-05, &
+        -0.5936e-05, -0.1133e-04, -0.1971e-04, -0.3143e-04, -0.4715e-04, &
+        -0.6833e-04, -0.9759e-04, -0.1379e-03, -0.1907e-03, -0.2542e-03, &
+        -0.3239e-03, -0.3935e-03, -0.4559e-03, -0.4991e-03, -0.5009e-03, &
+        -0.4414e-03, -0.3306e-03, -0.2077e-03, -0.1093e-03, -0.4754e-04, &
+        -0.1642e-04/
+      data ((h83(ip,iw),iw=1,31), ip=23,23)/ &
+         0.1531e-10,  0.3070e-10,  0.6184e-10,  0.1257e-09,  0.2578e-09, &
+         0.5451e-09,  0.1159e-08,  0.2526e-08,  0.5585e-08,  0.1225e-07, &
+         0.2576e-07,  0.5017e-07,  0.8855e-07,  0.1417e-06,  0.2078e-06, &
+         0.2858e-06,  0.3802e-06,  0.4946e-06,  0.6226e-06,  0.7572e-06, &
+         0.9137e-06,  0.1133e-05,  0.1438e-05,  0.1772e-05,  0.1994e-05, &
+         0.1994e-05,  0.1779e-05,  0.1375e-05,  0.8711e-06,  0.4273e-06, &
+         0.1539e-06/
+      data ((h81(ip,iw),iw=1,31), ip=24,24)/ &
+         0.99998635,  0.99997282,  0.99994582,  0.99989212,  0.99978542, &
+         0.99957442,  0.99916071,  0.99835902,  0.99683702,  0.99403203, &
+         0.98908001,  0.98084998,  0.96805000,  0.94933999,  0.92330998, &
+         0.88830000,  0.84219998,  0.78270000,  0.70809996,  0.61759996, &
+         0.51330000,  0.40079999,  0.29000002,  0.19239998,  0.11619997, &
+         0.06300002,  0.02980000,  0.01200002,  0.00410002,  0.00120002, &
+         0.00019997/
+      data ((h82(ip,iw),iw=1,31), ip=24,24)/ &
+        -0.4354e-08, -0.8703e-08, -0.1742e-07, -0.3499e-07, -0.7074e-07, &
+        -0.1441e-06, -0.2971e-06, -0.6195e-06, -0.1309e-05, -0.2780e-05, &
+        -0.5823e-05, -0.1165e-04, -0.2152e-04, -0.3616e-04, -0.5604e-04, &
+        -0.8230e-04, -0.1173e-03, -0.1635e-03, -0.2211e-03, -0.2868e-03, &
+        -0.3567e-03, -0.4260e-03, -0.4844e-03, -0.5097e-03, -0.4750e-03, &
+        -0.3779e-03, -0.2522e-03, -0.1409e-03, -0.6540e-04, -0.2449e-04, &
+        -0.6948e-05/
+      data ((h83(ip,iw),iw=1,31), ip=24,24)/ &
+         0.1529e-10,  0.3060e-10,  0.6142e-10,  0.1241e-09,  0.2535e-09, &
+         0.5259e-09,  0.1107e-08,  0.2383e-08,  0.5243e-08,  0.1161e-07, &
+         0.2523e-07,  0.5188e-07,  0.9757e-07,  0.1657e-06,  0.2553e-06, &
+         0.3629e-06,  0.4878e-06,  0.6323e-06,  0.7923e-06,  0.9575e-06, &
+         0.1139e-05,  0.1381e-05,  0.1687e-05,  0.1952e-05,  0.2029e-05, &
+         0.1890e-05,  0.1552e-05,  0.1062e-05,  0.5728e-06,  0.2280e-06, &
+         0.6762e-07/
+      data ((h81(ip,iw),iw=1,31), ip=25,25)/ &
+         0.99998635,  0.99997282,  0.99994582,  0.99989200,  0.99978489, &
+         0.99957252,  0.99915391,  0.99833602,  0.99676299,  0.99380499, &
+         0.98843998,  0.97920001,  0.96427000,  0.94182003,  0.91018999, &
+         0.86769998,  0.81260002,  0.74300003,  0.65770000,  0.55750000, &
+         0.44660002,  0.33310002,  0.22860003,  0.14319998,  0.08090001, &
+         0.04030001,  0.01719999,  0.00620002,  0.00190002,  0.00040001, &
+         0.00000000/
+      data ((h82(ip,iw),iw=1,31), ip=25,25)/ &
+        -0.4352e-08, -0.8693e-08, -0.1738e-07, -0.3483e-07, -0.7006e-07, &
+        -0.1423e-06, -0.2905e-06, -0.6008e-06, -0.1258e-05, -0.2663e-05, &
+        -0.5638e-05, -0.1165e-04, -0.2270e-04, -0.4044e-04, -0.6554e-04, &
+        -0.9855e-04, -0.1407e-03, -0.1928e-03, -0.2534e-03, -0.3197e-03, &
+        -0.3890e-03, -0.4563e-03, -0.5040e-03, -0.4998e-03, -0.4249e-03, &
+        -0.3025e-03, -0.1794e-03, -0.8860e-04, -0.3575e-04, -0.1122e-04, &
+        -0.2506e-05/
+      data ((h83(ip,iw),iw=1,31), ip=25,25)/ &
+         0.1527e-10,  0.3053e-10,  0.6115e-10,  0.1230e-09,  0.2492e-09, &
+         0.5149e-09,  0.1068e-08,  0.2268e-08,  0.4932e-08,  0.1089e-07, &
+         0.2408e-07,  0.5156e-07,  0.1028e-06,  0.1859e-06,  0.3028e-06, &
+         0.4476e-06,  0.6124e-06,  0.7932e-06,  0.9879e-06,  0.1194e-05, &
+         0.1417e-05,  0.1673e-05,  0.1929e-05,  0.2064e-05,  0.1997e-05, &
+         0.1725e-05,  0.1267e-05,  0.7464e-06,  0.3312e-06,  0.1066e-06, &
+         0.2718e-07/
+      data ((h81(ip,iw),iw=1,31), ip=26,26)/ &
+         0.99998635,  0.99997282,  0.99994576,  0.99989188,  0.99978459, &
+         0.99957132,  0.99914938,  0.99831998,  0.99670899,  0.99363601, &
+         0.98794001,  0.97781998,  0.96087998,  0.93456000,  0.89670002, &
+         0.84560001,  0.78020000,  0.69920003,  0.60299999,  0.49400002, &
+         0.37910002,  0.26889998,  0.17460001,  0.10280001,  0.05379999, &
+         0.02429998,  0.00929999,  0.00300002,  0.00080001,  0.00010002, &
+         0.00000000/
+      data ((h82(ip,iw),iw=1,31), ip=26,26)/ &
+        -0.4351e-08, -0.8688e-08, -0.1736e-07, -0.3473e-07, -0.6966e-07, &
+        -0.1405e-06, -0.2857e-06, -0.5867e-06, -0.1218e-05, -0.2563e-05, &
+        -0.5435e-05, -0.1144e-04, -0.2321e-04, -0.4379e-04, -0.7487e-04, &
+        -0.1163e-03, -0.1670e-03, -0.2250e-03, -0.2876e-03, -0.3535e-03, &
+        -0.4215e-03, -0.4826e-03, -0.5082e-03, -0.4649e-03, -0.3564e-03, &
+        -0.2264e-03, -0.1188e-03, -0.5128e-04, -0.1758e-04, -0.4431e-05, &
+        -0.7275e-06/
+      data ((h83(ip,iw),iw=1,31), ip=26,26)/ &
+         0.1525e-10,  0.3048e-10,  0.6097e-10,  0.1223e-09,  0.2466e-09, &
+         0.5021e-09,  0.1032e-08,  0.2195e-08,  0.4688e-08,  0.1027e-07, &
+         0.2279e-07,  0.4999e-07,  0.1046e-06,  0.2009e-06,  0.3460e-06, &
+         0.5335e-06,  0.7478e-06,  0.9767e-06,  0.1216e-05,  0.1469e-05, &
+         0.1735e-05,  0.1977e-05,  0.2121e-05,  0.2103e-05,  0.1902e-05, &
+         0.1495e-05,  0.9541e-06,  0.4681e-06,  0.1672e-06,  0.4496e-07, &
+         0.9859e-08/
+      data ((c1(ip,iw),iw=1,30), ip= 1, 1)/ &
+         0.99985647,  0.99976432,  0.99963892,  0.99948031,  0.99927652, &
+         0.99899602,  0.99860001,  0.99804801,  0.99732202,  0.99640399, &
+         0.99526399,  0.99384302,  0.99204999,  0.98979002,  0.98694998, &
+         0.98334998,  0.97878999,  0.97307003,  0.96592999,  0.95722002, &
+         0.94660002,  0.93366003,  0.91777998,  0.89819998,  0.87419999, &
+         0.84500003,  0.81029999,  0.76989996,  0.72440004,  0.67490000/
+      data ((c2(ip,iw),iw=1,30), ip= 1, 1)/ &
+        -0.1841e-06, -0.4666e-06, -0.1050e-05, -0.2069e-05, -0.3601e-05, &
+        -0.5805e-05, -0.8863e-05, -0.1291e-04, -0.1806e-04, -0.2460e-04, &
+        -0.3317e-04, -0.4452e-04, -0.5944e-04, -0.7884e-04, -0.1036e-03, &
+        -0.1346e-03, -0.1727e-03, -0.2186e-03, -0.2728e-03, -0.3364e-03, &
+        -0.4102e-03, -0.4948e-03, -0.5890e-03, -0.6900e-03, -0.7930e-03, &
+        -0.8921e-03, -0.9823e-03, -0.1063e-02, -0.1138e-02, -0.1214e-02/
+      data ((c3(ip,iw),iw=1,30), ip= 1, 1)/ &
+         0.5821e-10,  0.5821e-10, -0.3201e-09, -0.1804e-08, -0.4336e-08, &
+        -0.7829e-08, -0.1278e-07, -0.1847e-07, -0.2827e-07, -0.4495e-07, &
+        -0.7126e-07, -0.1071e-06, -0.1524e-06, -0.2160e-06, -0.3014e-06, &
+        -0.4097e-06, -0.5349e-06, -0.6718e-06, -0.8125e-06, -0.9755e-06, &
+        -0.1157e-05, -0.1339e-05, -0.1492e-05, -0.1563e-05, -0.1485e-05, &
+        -0.1210e-05, -0.7280e-06, -0.1107e-06,  0.5369e-06,  0.1154e-05/
+      data ((c1(ip,iw),iw=1,30), ip= 2, 2)/ &
+         0.99985647,  0.99976432,  0.99963868,  0.99947977,  0.99927580, &
+         0.99899501,  0.99859601,  0.99804401,  0.99731201,  0.99638498, &
+         0.99523097,  0.99378198,  0.99194402,  0.98961002,  0.98664999, &
+         0.98286998,  0.97807002,  0.97200000,  0.96439999,  0.95503998, &
+         0.94352001,  0.92931998,  0.91175002,  0.88989997,  0.86300004, &
+         0.83039999,  0.79159999,  0.74710000,  0.69790000,  0.64579999/
+      data ((c2(ip,iw),iw=1,30), ip= 2, 2)/ &
+        -0.1831e-06, -0.4642e-06, -0.1048e-05, -0.2067e-05, -0.3596e-05, &
+        -0.5797e-05, -0.8851e-05, -0.1289e-04, -0.1802e-04, -0.2454e-04, &
+        -0.3307e-04, -0.4435e-04, -0.5916e-04, -0.7842e-04, -0.1031e-03, &
+        -0.1342e-03, -0.1725e-03, -0.2189e-03, -0.2739e-03, -0.3386e-03, &
+        -0.4138e-03, -0.5003e-03, -0.5968e-03, -0.7007e-03, -0.8076e-03, &
+        -0.9113e-03, -0.1007e-02, -0.1096e-02, -0.1181e-02, -0.1271e-02/
+      data ((c3(ip,iw),iw=1,30), ip= 2, 2)/ &
+         0.5821e-10,  0.5821e-10, -0.3347e-09, -0.1746e-08, -0.4366e-08, &
+        -0.7858e-08, -0.1262e-07, -0.1866e-07, -0.2849e-07, -0.4524e-07, &
+        -0.7176e-07, -0.1077e-06, -0.1531e-06, -0.2166e-06, -0.3018e-06, &
+        -0.4090e-06, -0.5327e-06, -0.6670e-06, -0.8088e-06, -0.9714e-06, &
+        -0.1151e-05, -0.1333e-05, -0.1483e-05, -0.1548e-05, -0.1467e-05, &
+        -0.1192e-05, -0.7159e-06, -0.1032e-06,  0.5571e-06,  0.1217e-05/
+      data ((c1(ip,iw),iw=1,30), ip= 3, 3)/ &
+         0.99985671,  0.99976432,  0.99963838,  0.99947912,  0.99927449, &
+         0.99899203,  0.99859202,  0.99803501,  0.99729699,  0.99635702, &
+         0.99518001,  0.99369103,  0.99178600,  0.98935002,  0.98623002, &
+         0.98223001,  0.97711003,  0.97060001,  0.96243000,  0.95222998, &
+         0.93957001,  0.92379999,  0.90411001,  0.87959999,  0.84930003, &
+         0.81270003,  0.76980001,  0.72140002,  0.66909999,  0.61539996/
+      data ((c2(ip,iw),iw=1,30), ip= 3, 3)/ &
+        -0.1831e-06, -0.4623e-06, -0.1048e-05, -0.2065e-05, -0.3589e-05, &
+        -0.5789e-05, -0.8833e-05, -0.1286e-04, -0.1797e-04, -0.2446e-04, &
+        -0.3292e-04, -0.4412e-04, -0.5880e-04, -0.7795e-04, -0.1027e-03, &
+        -0.1340e-03, -0.1728e-03, -0.2199e-03, -0.2759e-03, -0.3419e-03, &
+        -0.4194e-03, -0.5081e-03, -0.6078e-03, -0.7156e-03, -0.8270e-03, &
+        -0.9365e-03, -0.1040e-02, -0.1137e-02, -0.1235e-02, -0.1339e-02/
+      data ((c3(ip,iw),iw=1,30), ip= 3, 3)/ &
+         0.2910e-10,  0.5821e-10, -0.3201e-09, -0.1732e-08, -0.4307e-08, &
+        -0.7843e-08, -0.1270e-07, -0.1882e-07, -0.2862e-07, -0.4571e-07, &
+        -0.7225e-07, -0.1082e-06, -0.1535e-06, -0.2171e-06, -0.3021e-06, &
+        -0.4084e-06, -0.5302e-06, -0.6615e-06, -0.8059e-06, -0.9668e-06, &
+        -0.1146e-05, -0.1325e-05, -0.1468e-05, -0.1530e-05, -0.1448e-05, &
+        -0.1168e-05, -0.6907e-06, -0.7148e-07,  0.6242e-06,  0.1357e-05/
+      data ((c1(ip,iw),iw=1,30), ip= 4, 4)/ &
+         0.99985629,  0.99976349,  0.99963838,  0.99947798,  0.99927282, &
+         0.99898797,  0.99858499,  0.99802202,  0.99727303,  0.99631298, &
+         0.99510002,  0.99355298,  0.99155599,  0.98898000,  0.98566002, &
+         0.98136997,  0.97584999,  0.96880001,  0.95986998,  0.94862998, &
+         0.93452001,  0.91681999,  0.89459997,  0.86680001,  0.83270001, &
+         0.79189998,  0.74479997,  0.69290000,  0.63839996,  0.58410001/
+      data ((c2(ip,iw),iw=1,30), ip= 4, 4)/ &
+        -0.1808e-06, -0.4642e-06, -0.1045e-05, -0.2058e-05, -0.3581e-05, &
+        -0.5776e-05, -0.8801e-05, -0.1281e-04, -0.1789e-04, -0.2433e-04, &
+        -0.3273e-04, -0.4382e-04, -0.5840e-04, -0.7755e-04, -0.1024e-03, &
+        -0.1342e-03, -0.1737e-03, -0.2217e-03, -0.2791e-03, -0.3473e-03, &
+        -0.4272e-03, -0.5191e-03, -0.6227e-03, -0.7354e-03, -0.8526e-03, &
+        -0.9688e-03, -0.1081e-02, -0.1189e-02, -0.1300e-02, -0.1417e-02/
+      data ((c3(ip,iw),iw=1,30), ip= 4, 4)/ &
+         0.1019e-09,  0.1601e-09, -0.4075e-09, -0.1746e-08, -0.4366e-08, &
+        -0.7960e-08, -0.1294e-07, -0.1898e-07, -0.2899e-07, -0.4594e-07, &
+        -0.7267e-07, -0.1088e-06, -0.1536e-06, -0.2164e-06, -0.3002e-06, &
+        -0.4055e-06, -0.5260e-06, -0.6571e-06, -0.8022e-06, -0.9624e-06, &
+        -0.1139e-05, -0.1315e-05, -0.1456e-05, -0.1512e-05, -0.1420e-05, &
+        -0.1137e-05, -0.6483e-06,  0.6679e-08,  0.7652e-06,  0.1574e-05/
+      data ((c1(ip,iw),iw=1,30), ip= 5, 5)/ &
+         0.99985641,  0.99976403,  0.99963748,  0.99947661,  0.99926913, &
+         0.99898303,  0.99857402,  0.99800003,  0.99723399,  0.99624503, &
+         0.99498397,  0.99335301,  0.99123502,  0.98847997,  0.98488998, &
+         0.98023999,  0.97421998,  0.96648002,  0.95659000,  0.94404000, &
+         0.92815000,  0.90802002,  0.88270003,  0.85119998,  0.81290001, &
+         0.76770002,  0.71679997,  0.66219997,  0.60670000,  0.55250001/
+      data ((c2(ip,iw),iw=1,30), ip= 5, 5)/ &
+        -0.1827e-06, -0.4608e-06, -0.1042e-05, -0.2053e-05, -0.3565e-05, &
+        -0.5745e-05, -0.8758e-05, -0.1273e-04, -0.1778e-04, -0.2417e-04, &
+        -0.3250e-04, -0.4347e-04, -0.5801e-04, -0.7729e-04, -0.1025e-03, &
+        -0.1349e-03, -0.1755e-03, -0.2249e-03, -0.2842e-03, -0.3549e-03, &
+        -0.4380e-03, -0.5340e-03, -0.6428e-03, -0.7613e-03, -0.8854e-03, &
+        -0.1009e-02, -0.1131e-02, -0.1252e-02, -0.1376e-02, -0.1502e-02/
+      data ((c3(ip,iw),iw=1,30), ip= 5, 5)/ &
+         0.4366e-10, -0.1455e-10, -0.4075e-09, -0.1804e-08, -0.4293e-08, &
+        -0.8178e-08, -0.1301e-07, -0.1915e-07, -0.2938e-07, -0.4664e-07, &
+        -0.7365e-07, -0.1090e-06, -0.1539e-06, -0.2158e-06, -0.2992e-06, &
+        -0.4033e-06, -0.5230e-06, -0.6537e-06, -0.7976e-06, -0.9601e-06, &
+        -0.1135e-05, -0.1305e-05, -0.1440e-05, -0.1490e-05, -0.1389e-05, &
+        -0.1087e-05, -0.5646e-06,  0.1475e-06,  0.9852e-06,  0.1853e-05/
+      data ((c1(ip,iw),iw=1,30), ip= 6, 6)/ &
+         0.99985617,  0.99976331,  0.99963629,  0.99947429,  0.99926388, &
+         0.99897301,  0.99855602,  0.99796802,  0.99717802,  0.99614400, &
+         0.99480897,  0.99306899,  0.99078500,  0.98778999,  0.98387998, &
+         0.97876000,  0.97211999,  0.96350002,  0.95240998,  0.93821001, &
+         0.92009002,  0.89709997,  0.86820000,  0.83249998,  0.78970003, &
+         0.74039996,  0.68630004,  0.63010001,  0.57459998,  0.52069998/
+      data ((c2(ip,iw),iw=1,30), ip= 6, 6)/ &
+        -0.1798e-06, -0.4580e-06, -0.1033e-05, -0.2039e-05, -0.3544e-05, &
+        -0.5709e-05, -0.8696e-05, -0.1264e-04, -0.1763e-04, -0.2395e-04, &
+        -0.3220e-04, -0.4311e-04, -0.5777e-04, -0.7732e-04, -0.1032e-03, &
+        -0.1365e-03, -0.1784e-03, -0.2295e-03, -0.2914e-03, -0.3653e-03, &
+        -0.4527e-03, -0.5541e-03, -0.6689e-03, -0.7947e-03, -0.9265e-03, &
+        -0.1060e-02, -0.1192e-02, -0.1326e-02, -0.1460e-02, -0.1586e-02/
+      data ((c3(ip,iw),iw=1,30), ip= 6, 6)/ &
+         0.8731e-10,  0.0000e+00, -0.3492e-09, -0.1892e-08, -0.4322e-08, &
+        -0.8367e-08, -0.1318e-07, -0.1962e-07, -0.3024e-07, -0.4708e-07, &
+        -0.7359e-07, -0.1087e-06, -0.1534e-06, -0.2152e-06, -0.2978e-06, &
+        -0.4008e-06, -0.5207e-06, -0.6509e-06, -0.7968e-06, -0.9584e-06, &
+        -0.1128e-05, -0.1297e-05, -0.1425e-05, -0.1461e-05, -0.1342e-05, &
+        -0.1009e-05, -0.4283e-06,  0.3666e-06,  0.1272e-05,  0.2171e-05/
+      data ((c1(ip,iw),iw=1,30), ip= 7, 7)/ &
+         0.99985600,  0.99976230,  0.99963462,  0.99947017,  0.99925607, &
+         0.99895698,  0.99852800,  0.99791902,  0.99709100,  0.99599499, &
+         0.99456000,  0.99267203,  0.99017102,  0.98688000,  0.98255002, &
+         0.97685999,  0.96941000,  0.95969999,  0.94709998,  0.93085998, &
+         0.91001999,  0.88360000,  0.85060000,  0.81040001,  0.76319999, &
+         0.71029997,  0.65400004,  0.59740001,  0.54229999,  0.48839998/
+      data ((c2(ip,iw),iw=1,30), ip= 7, 7)/ &
+        -0.1784e-06, -0.4551e-06, -0.1023e-05, -0.2019e-05, -0.3507e-05, &
+        -0.5651e-05, -0.8608e-05, -0.1250e-04, -0.1744e-04, -0.2370e-04, &
+        -0.3189e-04, -0.4289e-04, -0.5777e-04, -0.7787e-04, -0.1045e-03, &
+        -0.1392e-03, -0.1828e-03, -0.2365e-03, -0.3015e-03, -0.3797e-03, &
+        -0.4723e-03, -0.5803e-03, -0.7026e-03, -0.8365e-03, -0.9772e-03, &
+        -0.1120e-02, -0.1265e-02, -0.1409e-02, -0.1547e-02, -0.1665e-02/
+      data ((c3(ip,iw),iw=1,30), ip= 7, 7)/ &
+         0.5821e-10,  0.8731e-10, -0.4366e-09, -0.1935e-08, -0.4555e-08, &
+        -0.8455e-08, -0.1356e-07, -0.2024e-07, -0.3079e-07, -0.4758e-07, &
+        -0.7352e-07, -0.1078e-06, -0.1520e-06, -0.2139e-06, -0.2964e-06, &
+        -0.3997e-06, -0.5185e-06, -0.6493e-06, -0.7943e-06, -0.9568e-06, &
+        -0.1127e-05, -0.1288e-05, -0.1405e-05, -0.1425e-05, -0.1275e-05, &
+        -0.8809e-06, -0.2158e-06,  0.6597e-06,  0.1610e-05,  0.2524e-05/
+      data ((c1(ip,iw),iw=1,30), ip= 8, 8)/ &
+         0.99985582,  0.99976122,  0.99963123,  0.99946368,  0.99924308, &
+         0.99893397,  0.99848598,  0.99784499,  0.99696398,  0.99577999, &
+         0.99421299,  0.99212801,  0.98935997,  0.98569000,  0.98083001, &
+         0.97442001,  0.96595001,  0.95486999,  0.94040000,  0.92163002, &
+         0.89760000,  0.86720002,  0.82969999,  0.78499997,  0.73370004, &
+         0.67799997,  0.62070000,  0.56439996,  0.50960004,  0.45539999/
+      data ((c2(ip,iw),iw=1,30), ip= 8, 8)/ &
+        -0.1760e-06, -0.4451e-06, -0.1004e-05, -0.1989e-05, -0.3457e-05, &
+        -0.5574e-05, -0.8470e-05, -0.1230e-04, -0.1721e-04, -0.2344e-04, &
+        -0.3168e-04, -0.4286e-04, -0.5815e-04, -0.7898e-04, -0.1070e-03, &
+        -0.1434e-03, -0.1892e-03, -0.2460e-03, -0.3152e-03, -0.3985e-03, &
+        -0.4981e-03, -0.6139e-03, -0.7448e-03, -0.8878e-03, -0.1038e-02, &
+        -0.1193e-02, -0.1348e-02, -0.1499e-02, -0.1631e-02, -0.1735e-02/
+      data ((c3(ip,iw),iw=1,30), ip= 8, 8)/ &
+        -0.1455e-10,  0.4366e-10, -0.3929e-09, -0.2081e-08, -0.4700e-08, &
+        -0.8804e-08, -0.1417e-07, -0.2068e-07, -0.3143e-07, -0.4777e-07, &
+        -0.7336e-07, -0.1070e-06, -0.1517e-06, -0.2134e-06, -0.2967e-06, &
+        -0.3991e-06, -0.5164e-06, -0.6510e-06, -0.7979e-06, -0.9575e-06, &
+        -0.1123e-05, -0.1279e-05, -0.1382e-05, -0.1374e-05, -0.1166e-05, &
+        -0.6893e-06,  0.7339e-07,  0.1013e-05,  0.1982e-05,  0.2896e-05/
+      data ((c1(ip,iw),iw=1,30), ip= 9, 9)/ &
+         0.99985498,  0.99975908,  0.99962622,  0.99945402,  0.99922228, &
+         0.99889803,  0.99842203,  0.99773699,  0.99677801,  0.99547797, &
+         0.99373603,  0.99140298,  0.98829001,  0.98413998,  0.97863001, &
+         0.97127002,  0.96156001,  0.94875997,  0.93197000,  0.91017997, &
+         0.88230002,  0.84749997,  0.80540001,  0.75620002,  0.70159996, &
+         0.64429998,  0.58710003,  0.53130001,  0.47640002,  0.42189997/
+      data ((c2(ip,iw),iw=1,30), ip= 9, 9)/ &
+        -0.1717e-06, -0.4327e-06, -0.9759e-06, -0.1943e-05, -0.3391e-05, &
+        -0.5454e-05, -0.8297e-05, -0.1209e-04, -0.1697e-04, -0.2322e-04, &
+        -0.3163e-04, -0.4318e-04, -0.5910e-04, -0.8111e-04, -0.1108e-03, &
+        -0.1493e-03, -0.1982e-03, -0.2588e-03, -0.3333e-03, -0.4237e-03, &
+        -0.5312e-03, -0.6562e-03, -0.7968e-03, -0.9496e-03, -0.1110e-02, &
+        -0.1276e-02, -0.1439e-02, -0.1588e-02, -0.1708e-02, -0.1796e-02/
+      data ((c3(ip,iw),iw=1,30), ip= 9, 9)/ &
+         0.0000e+00,  0.1455e-10, -0.3638e-09, -0.2299e-08, -0.4744e-08, &
+        -0.9284e-08, -0.1445e-07, -0.2141e-07, -0.3162e-07, -0.4761e-07, &
+        -0.7248e-07, -0.1065e-06, -0.1501e-06, -0.2140e-06, -0.2981e-06, &
+        -0.3994e-06, -0.5201e-06, -0.6549e-06, -0.8009e-06, -0.9627e-06, &
+        -0.1125e-05, -0.1266e-05, -0.1348e-05, -0.1292e-05, -0.1005e-05, &
+        -0.4166e-06,  0.4279e-06,  0.1401e-05,  0.2379e-05,  0.3278e-05/
+      data ((c1(ip,iw),iw=1,30), ip=10,10)/ &
+         0.99985462,  0.99975640,  0.99961889,  0.99943668,  0.99919188, &
+         0.99884301,  0.99832898,  0.99757999,  0.99651998,  0.99506402, &
+         0.99309200,  0.99044400,  0.98689002,  0.98215997,  0.97579002, &
+         0.96730000,  0.95603001,  0.94110000,  0.92149001,  0.89609998, &
+         0.86399996,  0.82449996,  0.77759999,  0.72459996,  0.66769999, &
+         0.61000001,  0.55340004,  0.49769998,  0.44250000,  0.38810003/
+      data ((c2(ip,iw),iw=1,30), ip=10,10)/ &
+        -0.1607e-06, -0.4160e-06, -0.9320e-06, -0.1872e-05, -0.3281e-05, &
+        -0.5286e-05, -0.8097e-05, -0.1187e-04, -0.1677e-04, -0.2320e-04, &
+        -0.3190e-04, -0.4402e-04, -0.6081e-04, -0.8441e-04, -0.1162e-03, &
+        -0.1576e-03, -0.2102e-03, -0.2760e-03, -0.3571e-03, -0.4558e-03, &
+        -0.5730e-03, -0.7082e-03, -0.8591e-03, -0.1022e-02, -0.1194e-02, &
+        -0.1368e-02, -0.1533e-02, -0.1671e-02, -0.1775e-02, -0.1843e-02/
+      data ((c3(ip,iw),iw=1,30), ip=10,10)/ &
+        -0.1164e-09, -0.7276e-10, -0.5530e-09, -0.2270e-08, -0.5093e-08, &
+        -0.9517e-08, -0.1502e-07, -0.2219e-07, -0.3171e-07, -0.4712e-07, &
+        -0.7123e-07, -0.1042e-06, -0.1493e-06, -0.2156e-06, -0.2999e-06, &
+        -0.4027e-06, -0.5243e-06, -0.6616e-06, -0.8125e-06, -0.9691e-06, &
+        -0.1126e-05, -0.1251e-05, -0.1294e-05, -0.1163e-05, -0.7639e-06, &
+        -0.7395e-07,  0.8279e-06,  0.1819e-05,  0.2795e-05,  0.3647e-05/
+      data ((c1(ip,iw),iw=1,30), ip=11,11)/ &
+         0.99985212,  0.99975210,  0.99960798,  0.99941242,  0.99914628, &
+         0.99876302,  0.99819702,  0.99736100,  0.99616700,  0.99450397, &
+         0.99225003,  0.98920000,  0.98510998,  0.97961998,  0.97220999, &
+         0.96231002,  0.94909000,  0.93155003,  0.90856999,  0.87910002, &
+         0.84219998,  0.79790002,  0.74669999,  0.69080001,  0.63300002, &
+         0.57570004,  0.51950002,  0.46359998,  0.40829998,  0.35450000/
+      data ((c2(ip,iw),iw=1,30), ip=11,11)/ &
+        -0.1531e-06, -0.3864e-06, -0.8804e-06, -0.1776e-05, -0.3131e-05, &
+        -0.5082e-05, -0.7849e-05, -0.1164e-04, -0.1669e-04, -0.2340e-04, &
+        -0.3261e-04, -0.4546e-04, -0.6380e-04, -0.8932e-04, -0.1237e-03, &
+        -0.1687e-03, -0.2262e-03, -0.2984e-03, -0.3880e-03, -0.4964e-03, &
+        -0.6244e-03, -0.7705e-03, -0.9325e-03, -0.1107e-02, -0.1288e-02, &
+        -0.1466e-02, -0.1623e-02, -0.1746e-02, -0.1831e-02, -0.1875e-02/
+      data ((c3(ip,iw),iw=1,30), ip=11,11)/ &
+         0.1019e-09, -0.2037e-09, -0.8004e-09, -0.2387e-08, -0.5326e-08, &
+        -0.9764e-08, -0.1576e-07, -0.2256e-07, -0.3180e-07, -0.4616e-07, &
+        -0.7026e-07, -0.1031e-06, -0.1520e-06, -0.2181e-06, -0.3037e-06, &
+        -0.4109e-06, -0.5354e-06, -0.6740e-06, -0.8241e-06, -0.9810e-06, &
+        -0.1126e-05, -0.1221e-05, -0.1200e-05, -0.9678e-06, -0.4500e-06, &
+         0.3236e-06,  0.1256e-05,  0.2259e-05,  0.3206e-05,  0.3978e-05/
+      data ((c1(ip,iw),iw=1,30), ip=12,12)/ &
+         0.99985027,  0.99974507,  0.99959022,  0.99937689,  0.99907988, &
+         0.99865198,  0.99801201,  0.99706602,  0.99569201,  0.99377203, &
+         0.99115402,  0.98762000,  0.98286003,  0.97640002,  0.96771997, &
+         0.95604998,  0.94045001,  0.91979003,  0.89289999,  0.85879999, &
+         0.81700003,  0.76800001,  0.71340001,  0.65579998,  0.59810001, &
+         0.54139996,  0.48519999,  0.42909998,  0.37410003,  0.32190001/
+      data ((c2(ip,iw),iw=1,30), ip=12,12)/ &
+        -0.1340e-06, -0.3478e-06, -0.8189e-06, -0.1653e-05, -0.2944e-05, &
+        -0.4852e-05, -0.7603e-05, -0.1150e-04, -0.1682e-04, -0.2400e-04, &
+        -0.3390e-04, -0.4799e-04, -0.6807e-04, -0.9596e-04, -0.1338e-03, &
+        -0.1833e-03, -0.2471e-03, -0.3275e-03, -0.4268e-03, -0.5466e-03, &
+        -0.6862e-03, -0.8439e-03, -0.1017e-02, -0.1201e-02, -0.1389e-02, &
+        -0.1563e-02, -0.1706e-02, -0.1809e-02, -0.1872e-02, -0.1890e-02/
+      data ((c3(ip,iw),iw=1,30), ip=12,12)/ &
+        -0.1455e-10, -0.1892e-09, -0.8295e-09, -0.2547e-08, -0.5544e-08, &
+        -0.1014e-07, -0.1605e-07, -0.2341e-07, -0.3156e-07, -0.4547e-07, &
+        -0.6749e-07, -0.1034e-06, -0.1550e-06, -0.2230e-06, -0.3130e-06, &
+        -0.4219e-06, -0.5469e-06, -0.6922e-06, -0.8448e-06, -0.9937e-06, &
+        -0.1118e-05, -0.1166e-05, -0.1054e-05, -0.6926e-06, -0.7180e-07, &
+         0.7515e-06,  0.1709e-05,  0.2703e-05,  0.3593e-05,  0.4232e-05/
+      data ((c1(ip,iw),iw=1,30), ip=13,13)/ &
+         0.99984729,  0.99973530,  0.99956691,  0.99932659,  0.99898797, &
+         0.99849701,  0.99776399,  0.99667102,  0.99507397,  0.99283201, &
+         0.98977000,  0.98563999,  0.98001999,  0.97241002,  0.96213001, &
+         0.94830000,  0.92980999,  0.90546000,  0.87409997,  0.83510000, &
+         0.78850001,  0.73549998,  0.67850000,  0.62049997,  0.56340003, &
+         0.50699997,  0.45050001,  0.39450002,  0.34060001,  0.29079998/
+      data ((c2(ip,iw),iw=1,30), ip=13,13)/ &
+        -0.1163e-06, -0.3048e-06, -0.7186e-06, -0.1495e-05, -0.2726e-05, &
+        -0.4588e-05, -0.7396e-05, -0.1152e-04, -0.1725e-04, -0.2514e-04, &
+        -0.3599e-04, -0.5172e-04, -0.7403e-04, -0.1051e-03, -0.1469e-03, &
+        -0.2023e-03, -0.2735e-03, -0.3637e-03, -0.4746e-03, -0.6067e-03, &
+        -0.7586e-03, -0.9281e-03, -0.1112e-02, -0.1304e-02, -0.1491e-02, &
+        -0.1653e-02, -0.1777e-02, -0.1860e-02, -0.1896e-02, -0.1891e-02/
+      data ((c3(ip,iw),iw=1,30), ip=13,13)/ &
+        -0.1455e-09, -0.2765e-09, -0.9750e-09, -0.2794e-08, -0.5413e-08, &
+        -0.1048e-07, -0.1625e-07, -0.2344e-07, -0.3105e-07, -0.4304e-07, &
+        -0.6608e-07, -0.1057e-06, -0.1587e-06, -0.2308e-06, -0.3235e-06, &
+        -0.4373e-06, -0.5687e-06, -0.7156e-06, -0.8684e-06, -0.1007e-05, &
+        -0.1094e-05, -0.1062e-05, -0.8273e-06, -0.3485e-06,  0.3463e-06, &
+         0.1206e-05,  0.2173e-05,  0.3132e-05,  0.3919e-05,  0.4370e-05/
+      data ((c1(ip,iw),iw=1,30), ip=14,14)/ &
+         0.99984348,  0.99972272,  0.99953479,  0.99926043,  0.99886698, &
+         0.99829400,  0.99744201,  0.99615997,  0.99429500,  0.99166000, &
+         0.98806000,  0.98316997,  0.97649997,  0.96748000,  0.95525998, &
+         0.93878001,  0.91687000,  0.88830000,  0.85220003,  0.80820000, &
+         0.75699997,  0.70099998,  0.64300001,  0.58550000,  0.52890003, &
+         0.47219998,  0.41560000,  0.36040002,  0.30849999,  0.26169997/
+      data ((c2(ip,iw),iw=1,30), ip=14,14)/ &
+        -0.8581e-07, -0.2557e-06, -0.6103e-06, -0.1305e-05, -0.2472e-05, &
+        -0.4334e-05, -0.7233e-05, -0.1167e-04, -0.1806e-04, -0.2679e-04, &
+        -0.3933e-04, -0.5705e-04, -0.8194e-04, -0.1165e-03, -0.1637e-03, &
+        -0.2259e-03, -0.3068e-03, -0.4082e-03, -0.5318e-03, -0.6769e-03, &
+        -0.8415e-03, -0.1023e-02, -0.1216e-02, -0.1410e-02, -0.1588e-02, &
+        -0.1733e-02, -0.1837e-02, -0.1894e-02, -0.1904e-02, -0.1881e-02/
+      data ((c3(ip,iw),iw=1,30), ip=14,14)/ &
+        -0.2037e-09, -0.4220e-09, -0.1091e-08, -0.2896e-08, -0.5821e-08, &
+        -0.1052e-07, -0.1687e-07, -0.2353e-07, -0.3193e-07, -0.4254e-07, &
+        -0.6685e-07, -0.1072e-06, -0.1638e-06, -0.2427e-06, -0.3421e-06, &
+        -0.4600e-06, -0.5946e-06, -0.7472e-06, -0.8958e-06, -0.1009e-05, &
+        -0.1032e-05, -0.8919e-06, -0.5224e-06,  0.5218e-07,  0.7886e-06, &
+         0.1672e-05,  0.2626e-05,  0.3513e-05,  0.4138e-05,  0.4379e-05/
+      data ((c1(ip,iw),iw=1,30), ip=15,15)/ &
+         0.99983788,  0.99970680,  0.99949580,  0.99917668,  0.99871200, &
+         0.99803603,  0.99703097,  0.99552703,  0.99333203,  0.99023402, &
+         0.98597997,  0.98013997,  0.97223002,  0.96145999,  0.94686002, &
+         0.92727000,  0.90142000,  0.86820000,  0.82700002,  0.77820003, &
+         0.72350001,  0.66569996,  0.60769999,  0.55089998,  0.49430001, &
+         0.43739998,  0.38110000,  0.32749999,  0.27840000,  0.23479998/
+      data ((c2(ip,iw),iw=1,30), ip=15,15)/ &
+        -0.8246e-07, -0.2070e-06, -0.4895e-06, -0.1106e-05, -0.2216e-05, &
+        -0.4077e-05, -0.7150e-05, -0.1202e-04, -0.1920e-04, -0.2938e-04, &
+        -0.4380e-04, -0.6390e-04, -0.9209e-04, -0.1310e-03, -0.1843e-03, &
+        -0.2554e-03, -0.3468e-03, -0.4611e-03, -0.5982e-03, -0.7568e-03, &
+        -0.9340e-03, -0.1126e-02, -0.1324e-02, -0.1514e-02, -0.1676e-02, &
+        -0.1801e-02, -0.1881e-02, -0.1911e-02, -0.1900e-02, -0.1867e-02/
+      data ((c3(ip,iw),iw=1,30), ip=15,15)/ &
+        -0.1601e-09, -0.3492e-09, -0.1019e-08, -0.2634e-08, -0.5632e-08, &
+        -0.1065e-07, -0.1746e-07, -0.2542e-07, -0.3206e-07, -0.4390e-07, &
+        -0.6956e-07, -0.1093e-06, -0.1729e-06, -0.2573e-06, -0.3612e-06, &
+        -0.4904e-06, -0.6342e-06, -0.7834e-06, -0.9175e-06, -0.9869e-06, &
+        -0.9164e-06, -0.6386e-06, -0.1544e-06,  0.4798e-06,  0.1252e-05, &
+         0.2137e-05,  0.3043e-05,  0.3796e-05,  0.4211e-05,  0.4332e-05/
+      data ((c1(ip,iw),iw=1,30), ip=16,16)/ &
+         0.99983227,  0.99968958,  0.99945217,  0.99907941,  0.99852598, &
+         0.99772000,  0.99652398,  0.99475902,  0.99218899,  0.98856002, &
+         0.98348999,  0.97653997,  0.96708000,  0.95420998,  0.93677002, &
+         0.91352999,  0.88330001,  0.84509999,  0.79900002,  0.74599999, &
+         0.68879998,  0.63049996,  0.57319999,  0.51660001,  0.45969999, &
+         0.40289998,  0.34780002,  0.29650003,  0.25070000,  0.20959997/
+      data ((c2(ip,iw),iw=1,30), ip=16,16)/ &
+        -0.7004e-07, -0.1592e-06, -0.3936e-06, -0.9145e-06, -0.1958e-05, &
+        -0.3850e-05, -0.7093e-05, -0.1252e-04, -0.2066e-04, -0.3271e-04, &
+        -0.4951e-04, -0.7268e-04, -0.1045e-03, -0.1487e-03, -0.2092e-03, &
+        -0.2899e-03, -0.3936e-03, -0.5215e-03, -0.6729e-03, -0.8454e-03, &
+        -0.1035e-02, -0.1235e-02, -0.1432e-02, -0.1608e-02, -0.1751e-02, &
+        -0.1854e-02, -0.1907e-02, -0.1913e-02, -0.1888e-02, -0.1857e-02/
+      data ((c3(ip,iw),iw=1,30), ip=16,16)/ &
+        -0.2328e-09, -0.3347e-09, -0.9750e-09, -0.2314e-08, -0.5166e-08, &
+        -0.1052e-07, -0.1726e-07, -0.2605e-07, -0.3532e-07, -0.4949e-07, &
+        -0.7229e-07, -0.1133e-06, -0.1799e-06, -0.2725e-06, -0.3881e-06, &
+        -0.5249e-06, -0.6763e-06, -0.8227e-06, -0.9279e-06, -0.9205e-06, &
+        -0.7228e-06, -0.3109e-06,  0.2583e-06,  0.9390e-06,  0.1726e-05, &
+         0.2579e-05,  0.3376e-05,  0.3931e-05,  0.4161e-05,  0.4369e-05/
+      data ((c1(ip,iw),iw=1,30), ip=17,17)/ &
+         0.99982637,  0.99967217,  0.99940813,  0.99897701,  0.99831802, &
+         0.99734300,  0.99592501,  0.99385202,  0.99086499,  0.98659998, &
+         0.98057997,  0.97229999,  0.96098000,  0.94555002,  0.92479002, &
+         0.89740002,  0.86240000,  0.81919998,  0.76859999,  0.71249998, &
+         0.65419996,  0.59630001,  0.53950000,  0.48259997,  0.42549998, &
+         0.36940002,  0.31629997,  0.26810002,  0.22520000,  0.18580002/
+      data ((c2(ip,iw),iw=1,30), ip=17,17)/ &
+        -0.6526e-07, -0.1282e-06, -0.3076e-06, -0.7454e-06, -0.1685e-05, &
+        -0.3600e-05, -0.7071e-05, -0.1292e-04, -0.2250e-04, -0.3665e-04, &
+        -0.5623e-04, -0.8295e-04, -0.1195e-03, -0.1696e-03, -0.2385e-03, &
+        -0.3298e-03, -0.4465e-03, -0.5887e-03, -0.7546e-03, -0.9408e-03, &
+        -0.1141e-02, -0.1345e-02, -0.1533e-02, -0.1691e-02, -0.1813e-02, &
+        -0.1889e-02, -0.1916e-02, -0.1904e-02, -0.1877e-02, -0.1850e-02/
+      data ((c3(ip,iw),iw=1,30), ip=17,17)/ &
+        -0.1746e-09, -0.2037e-09, -0.8149e-09, -0.2095e-08, -0.4889e-08, &
+        -0.9517e-08, -0.1759e-07, -0.2740e-07, -0.4147e-07, -0.5774e-07, &
+        -0.7909e-07, -0.1199e-06, -0.1877e-06, -0.2859e-06, -0.4137e-06, &
+        -0.5649e-06, -0.7218e-06, -0.8516e-06, -0.9022e-06, -0.7905e-06, &
+        -0.4531e-06,  0.6917e-07,  0.7009e-06,  0.1416e-05,  0.2194e-05, &
+         0.2963e-05,  0.3578e-05,  0.3900e-05,  0.4094e-05,  0.4642e-05/
+      data ((c1(ip,iw),iw=1,30), ip=18,18)/ &
+         0.99982101,  0.99965781,  0.99936712,  0.99887502,  0.99809802, &
+         0.99692702,  0.99523401,  0.99281400,  0.98935997,  0.98435003, &
+         0.97728002,  0.96740997,  0.95381999,  0.93539000,  0.91082001, &
+         0.87889999,  0.83889997,  0.79100001,  0.73660004,  0.67879999, &
+         0.62049997,  0.56330001,  0.50629997,  0.44900000,  0.39209998, &
+         0.33749998,  0.28729999,  0.24229997,  0.20150000,  0.16280001/
+      data ((c2(ip,iw),iw=1,30), ip=18,18)/ &
+        -0.6477e-07, -0.1243e-06, -0.2536e-06, -0.6173e-06, -0.1495e-05, &
+        -0.3353e-05, -0.6919e-05, -0.1337e-04, -0.2418e-04, -0.4049e-04, &
+        -0.6354e-04, -0.9455e-04, -0.1367e-03, -0.1942e-03, -0.2717e-03, &
+        -0.3744e-03, -0.5042e-03, -0.6609e-03, -0.8416e-03, -0.1041e-02, &
+        -0.1249e-02, -0.1448e-02, -0.1622e-02, -0.1760e-02, -0.1857e-02, &
+        -0.1906e-02, -0.1911e-02, -0.1892e-02, -0.1870e-02, -0.1844e-02/
+      data ((c3(ip,iw),iw=1,30), ip=18,18)/ &
+        -0.5821e-10, -0.2328e-09, -0.6985e-09, -0.1368e-08, -0.4351e-08, &
+        -0.8993e-08, -0.1579e-07, -0.2916e-07, -0.4904e-07, -0.7010e-07, &
+        -0.9623e-07, -0.1332e-06, -0.1928e-06, -0.2977e-06, -0.4371e-06, &
+        -0.5992e-06, -0.7586e-06, -0.8580e-06, -0.8238e-06, -0.5811e-06, &
+        -0.1298e-06,  0.4702e-06,  0.1162e-05,  0.1905e-05,  0.2632e-05, &
+         0.3247e-05,  0.3609e-05,  0.3772e-05,  0.4166e-05,  0.5232e-05/
+      data ((c1(ip,iw),iw=1,30), ip=19,19)/ &
+         0.99981648,  0.99964571,  0.99933147,  0.99878597,  0.99787998, &
+         0.99649400,  0.99448699,  0.99166602,  0.98762000,  0.98181999, &
+         0.97352999,  0.96183002,  0.94558001,  0.92363000,  0.89480001, &
+         0.85799998,  0.81309998,  0.76100004,  0.70420003,  0.64590001, &
+         0.58840001,  0.53139997,  0.47380000,  0.41619998,  0.36030000, &
+         0.30809999,  0.26109999,  0.21880001,  0.17909998,  0.14080000/
+      data ((c2(ip,iw),iw=1,30), ip=19,19)/ &
+        -0.7906e-07, -0.1291e-06, -0.2430e-06, -0.5145e-06, -0.1327e-05, &
+        -0.3103e-05, -0.6710e-05, -0.1371e-04, -0.2561e-04, -0.4405e-04, &
+        -0.7051e-04, -0.1070e-03, -0.1560e-03, -0.2217e-03, -0.3090e-03, &
+        -0.4228e-03, -0.5657e-03, -0.7371e-03, -0.9322e-03, -0.1142e-02, &
+        -0.1352e-02, -0.1541e-02, -0.1697e-02, -0.1813e-02, -0.1883e-02, &
+        -0.1906e-02, -0.1898e-02, -0.1882e-02, -0.1866e-02, -0.1832e-02/
+      data ((c3(ip,iw),iw=1,30), ip=19,19)/ &
+         0.2910e-10,  0.1455e-10, -0.2765e-09, -0.1426e-08, -0.2576e-08, &
+        -0.5923e-08, -0.1429e-07, -0.3159e-07, -0.5441e-07, -0.8367e-07, &
+        -0.1161e-06, -0.1526e-06, -0.2060e-06, -0.3007e-06, -0.4450e-06, &
+        -0.6182e-06, -0.7683e-06, -0.8170e-06, -0.6754e-06, -0.3122e-06, &
+         0.2234e-06,  0.8828e-06,  0.1632e-05,  0.2373e-05,  0.3002e-05, &
+         0.3384e-05,  0.3499e-05,  0.3697e-05,  0.4517e-05,  0.6117e-05/
+      data ((c1(ip,iw),iw=1,30), ip=20,20)/ &
+         0.99981302,  0.99963689,  0.99930489,  0.99870700,  0.99768901, &
+         0.99608499,  0.99373102,  0.99039900,  0.98566997,  0.97895002, &
+         0.96930999,  0.95548999,  0.93621999,  0.91029000,  0.87669998, &
+         0.83490002,  0.78549999,  0.73019999,  0.67240000,  0.61469996, &
+         0.55779999,  0.50029999,  0.44220001,  0.38489997,  0.33069998, &
+         0.28149998,  0.23760003,  0.19690001,  0.15759999,  0.11989999/
+      data ((c2(ip,iw),iw=1,30), ip=20,20)/ &
+        -0.7762e-07, -0.1319e-06, -0.2315e-06, -0.4780e-06, -0.1187e-05, &
+        -0.2750e-05, -0.6545e-05, -0.1393e-04, -0.2645e-04, -0.4652e-04, &
+        -0.7657e-04, -0.1190e-03, -0.1766e-03, -0.2520e-03, -0.3499e-03, &
+        -0.4751e-03, -0.6307e-03, -0.8160e-03, -0.1024e-02, -0.1240e-02, &
+        -0.1443e-02, -0.1619e-02, -0.1757e-02, -0.1849e-02, -0.1892e-02, &
+        -0.1896e-02, -0.1886e-02, -0.1878e-02, -0.1861e-02, -0.1807e-02/
+      data ((c3(ip,iw),iw=1,30), ip=20,20)/ &
+         0.8731e-10, -0.7276e-10, -0.2328e-09, -0.6403e-09, -0.1455e-08, &
+        -0.3827e-08, -0.1270e-07, -0.3014e-07, -0.5594e-07, -0.9677e-07, &
+        -0.1422e-06, -0.1823e-06, -0.2296e-06, -0.3094e-06, -0.4399e-06, &
+        -0.6008e-06, -0.7239e-06, -0.7014e-06, -0.4562e-06, -0.7778e-08, &
+         0.5785e-06,  0.1291e-05,  0.2072e-05,  0.2783e-05,  0.3247e-05, &
+         0.3358e-05,  0.3364e-05,  0.3847e-05,  0.5194e-05,  0.7206e-05/
+      data ((c1(ip,iw),iw=1,30), ip=21,21)/ &
+         0.99981070,  0.99962878,  0.99928439,  0.99864298,  0.99752903, &
+         0.99573100,  0.99301797,  0.98905998,  0.98354000,  0.97570997, &
+         0.96449000,  0.94837999,  0.92576003,  0.89539999,  0.85680002, &
+         0.81000000,  0.75660002,  0.69949996,  0.64199996,  0.58529997, &
+         0.52829999,  0.47020000,  0.41200000,  0.35570002,  0.30400002, &
+         0.25800002,  0.21609998,  0.17610002,  0.13709998,  0.10020000/
+      data ((c2(ip,iw),iw=1,30), ip=21,21)/ &
+        -0.1010e-06, -0.1533e-06, -0.2347e-06, -0.4535e-06, -0.1029e-05, &
+        -0.2530e-05, -0.6335e-05, -0.1381e-04, -0.2681e-04, -0.4777e-04, &
+        -0.8083e-04, -0.1296e-03, -0.1966e-03, -0.2836e-03, -0.3937e-03, &
+        -0.5313e-03, -0.6995e-03, -0.8972e-03, -0.1113e-02, -0.1327e-02, &
+        -0.1520e-02, -0.1681e-02, -0.1800e-02, -0.1867e-02, -0.1887e-02, &
+        -0.1884e-02, -0.1881e-02, -0.1879e-02, -0.1849e-02, -0.1764e-02/
+      data ((c3(ip,iw),iw=1,30), ip=21,21)/ &
+         0.8731e-10,  0.1310e-09, -0.2474e-09, -0.2619e-09,  0.8295e-09, &
+        -0.1979e-08, -0.1141e-07, -0.2621e-07, -0.5799e-07, -0.1060e-06, &
+        -0.1621e-06, -0.2281e-06, -0.2793e-06, -0.3335e-06, -0.4277e-06, &
+        -0.5429e-06, -0.5970e-06, -0.4872e-06, -0.1775e-06,  0.3028e-06, &
+         0.9323e-06,  0.1680e-05,  0.2452e-05,  0.3063e-05,  0.3299e-05, &
+         0.3219e-05,  0.3369e-05,  0.4332e-05,  0.6152e-05,  0.8413e-05/
+      data ((c1(ip,iw),iw=1,30), ip=22,22)/ &
+         0.99980962,  0.99962330,  0.99926400,  0.99858999,  0.99741602, &
+         0.99547201,  0.99236798,  0.98776001,  0.98124999,  0.97210997, &
+         0.95902997,  0.94033003,  0.91415000,  0.87919998,  0.83529997, &
+         0.78380001,  0.72749996,  0.66990000,  0.61339998,  0.55720001, &
+         0.49980003,  0.44129997,  0.38360000,  0.32929999,  0.28070003, &
+         0.23710001,  0.19620001,  0.15619999,  0.11769998,  0.08200002/
+      data ((c2(ip,iw),iw=1,30), ip=22,22)/ &
+        -0.1258e-06, -0.1605e-06, -0.2581e-06, -0.4286e-06, -0.8321e-06, &
+        -0.2392e-05, -0.6163e-05, -0.1358e-04, -0.2646e-04, -0.4792e-04, &
+        -0.8284e-04, -0.1369e-03, -0.2138e-03, -0.3141e-03, -0.4393e-03, &
+        -0.5917e-03, -0.7731e-03, -0.9796e-03, -0.1195e-02, -0.1399e-02, &
+        -0.1579e-02, -0.1725e-02, -0.1822e-02, -0.1867e-02, -0.1877e-02, &
+        -0.1879e-02, -0.1886e-02, -0.1879e-02, -0.1825e-02, -0.1706e-02/
+      data ((c3(ip,iw),iw=1,30), ip=22,22)/ &
+        -0.8731e-10,  0.2910e-10,  0.7276e-10,  0.1281e-08,  0.1222e-08, &
+        -0.1935e-08, -0.8004e-08, -0.2258e-07, -0.5428e-07, -0.1085e-06, &
+        -0.1835e-06, -0.2716e-06, -0.3446e-06, -0.3889e-06, -0.4203e-06, &
+        -0.4394e-06, -0.3716e-06, -0.1677e-06,  0.1622e-06,  0.6327e-06, &
+         0.1275e-05,  0.2018e-05,  0.2716e-05,  0.3137e-05,  0.3136e-05, &
+         0.3078e-05,  0.3649e-05,  0.5152e-05,  0.7315e-05,  0.9675e-05/
+      data ((c1(ip,iw),iw=1,30), ip=23,23)/ &
+         0.99980921,  0.99961692,  0.99924570,  0.99854898,  0.99734801, &
+         0.99527103,  0.99182302,  0.98655999,  0.97895002,  0.96814001, &
+         0.95284998,  0.93124998,  0.90130001,  0.86170000,  0.81290001, &
+         0.75740004,  0.69920003,  0.64199996,  0.58640003,  0.53020000, &
+         0.47240001,  0.41399997,  0.35780001,  0.30650002,  0.26069999, &
+         0.21850002,  0.17750001,  0.13739997,  0.09950000,  0.06540000/
+      data ((c2(ip,iw),iw=1,30), ip=23,23)/ &
+        -0.1434e-06, -0.1676e-06, -0.2699e-06, -0.2859e-06, -0.7542e-06, &
+        -0.2273e-05, -0.5898e-05, -0.1292e-04, -0.2538e-04, -0.4649e-04, &
+        -0.8261e-04, -0.1405e-03, -0.2259e-03, -0.3407e-03, -0.4845e-03, &
+        -0.6561e-03, -0.8524e-03, -0.1062e-02, -0.1266e-02, -0.1456e-02, &
+        -0.1621e-02, -0.1748e-02, -0.1823e-02, -0.1854e-02, -0.1868e-02, &
+        -0.1886e-02, -0.1899e-02, -0.1876e-02, -0.1790e-02, -0.1636e-02/
+      data ((c3(ip,iw),iw=1,30), ip=23,23)/ &
+        -0.1892e-09, -0.2474e-09,  0.1892e-09,  0.2561e-08,  0.4366e-09, &
+        -0.1499e-08, -0.4336e-08, -0.1740e-07, -0.5233e-07, -0.1055e-06, &
+        -0.1940e-06, -0.3113e-06, -0.4161e-06, -0.4620e-06, -0.4316e-06, &
+        -0.3031e-06, -0.5438e-07,  0.2572e-06,  0.5773e-06,  0.1008e-05, &
+         0.1609e-05,  0.2290e-05,  0.2817e-05,  0.2940e-05,  0.2803e-05, &
+         0.3061e-05,  0.4235e-05,  0.6225e-05,  0.8615e-05,  0.1095e-04/
+      data ((c1(ip,iw),iw=1,30), ip=24,24)/ &
+         0.99980992,  0.99961102,  0.99922198,  0.99852699,  0.99732202, &
+         0.99510902,  0.99140203,  0.98550999,  0.97672999,  0.96399999, &
+         0.94602001,  0.92101002,  0.88709998,  0.84310001,  0.79020000, &
+         0.73189998,  0.67299998,  0.61619997,  0.56060004,  0.50400001, &
+         0.44610000,  0.38880002,  0.33530003,  0.28740001,  0.24390000, &
+         0.20179999,  0.16009998,  0.11979997,  0.08260000,  0.05049998/
+      data ((c2(ip,iw),iw=1,30), ip=24,24)/ &
+        -0.1529e-06, -0.2005e-06, -0.2861e-06, -0.1652e-06, -0.6334e-06, &
+        -0.1965e-05, -0.5437e-05, -0.1182e-04, -0.2344e-04, -0.4384e-04, &
+        -0.7982e-04, -0.1398e-03, -0.2321e-03, -0.3616e-03, -0.5274e-03, &
+        -0.7239e-03, -0.9363e-03, -0.1142e-02, -0.1328e-02, -0.1499e-02, &
+        -0.1645e-02, -0.1748e-02, -0.1804e-02, -0.1834e-02, -0.1867e-02, &
+        -0.1903e-02, -0.1914e-02, -0.1866e-02, -0.1746e-02, -0.1558e-02/
+      data ((c3(ip,iw),iw=1,30), ip=24,24)/ &
+        -0.3638e-09, -0.9313e-09,  0.1703e-08,  0.2081e-08, -0.1251e-08, &
+        -0.1208e-08, -0.6883e-08, -0.1608e-07, -0.4559e-07, -0.1047e-06, &
+        -0.2040e-06, -0.3312e-06, -0.4624e-06, -0.5198e-06, -0.4326e-06, &
+        -0.1452e-06,  0.3003e-06,  0.7455e-06,  0.1102e-05,  0.1470e-05, &
+         0.1957e-05,  0.2474e-05,  0.2691e-05,  0.2484e-05,  0.2414e-05, &
+         0.3232e-05,  0.5050e-05,  0.7455e-05,  0.9997e-05,  0.1217e-04/
+      data ((c1(ip,iw),iw=1,30), ip=25,25)/ &
+         0.99980998,  0.99960178,  0.99920201,  0.99852800,  0.99729002, &
+         0.99498200,  0.99102801,  0.98461998,  0.97465998,  0.95982999, &
+         0.93866003,  0.90968001,  0.87140000,  0.82340002,  0.76770002, &
+         0.70860004,  0.64999998,  0.59290004,  0.53610003,  0.47860003, &
+         0.42110002,  0.36610001,  0.31639999,  0.27200001,  0.22960001, &
+         0.18690002,  0.14429998,  0.10380000,  0.06739998,  0.03740001/
+      data ((c2(ip,iw),iw=1,30), ip=25,25)/ &
+        -0.1453e-06, -0.2529e-06, -0.1807e-06, -0.1109e-06, -0.4469e-06, &
+        -0.1885e-05, -0.4590e-05, -0.1043e-04, -0.2057e-04, -0.3951e-04, &
+        -0.7466e-04, -0.1356e-03, -0.2341e-03, -0.3783e-03, -0.5688e-03, &
+        -0.7935e-03, -0.1021e-02, -0.1219e-02, -0.1388e-02, -0.1535e-02, &
+        -0.1653e-02, -0.1726e-02, -0.1768e-02, -0.1813e-02, -0.1874e-02, &
+        -0.1925e-02, -0.1927e-02, -0.1851e-02, -0.1697e-02, -0.1478e-02/
+      data ((c3(ip,iw),iw=1,30), ip=25,25)/ &
+        -0.6257e-09, -0.1382e-08,  0.2095e-08,  0.1863e-08, -0.1834e-08, &
+        -0.2125e-08, -0.6985e-08, -0.1634e-07, -0.4128e-07, -0.9924e-07, &
+        -0.1938e-06, -0.3275e-06, -0.4556e-06, -0.5046e-06, -0.3633e-06, &
+         0.2484e-07,  0.6195e-06,  0.1249e-05,  0.1731e-05,  0.2053e-05, &
+         0.2358e-05,  0.2569e-05,  0.2342e-05,  0.1883e-05,  0.2103e-05, &
+         0.3570e-05,  0.5973e-05,  0.8752e-05,  0.1140e-04,  0.1328e-04/
+      data ((c1(ip,iw),iw=1,30), ip=26,26)/ &
+         0.99980712,  0.99958581,  0.99919039,  0.99854302,  0.99724799, &
+         0.99486500,  0.99071401,  0.98379999,  0.97279000,  0.95585001, &
+         0.93112999,  0.89749998,  0.85460001,  0.80320001,  0.74660003, &
+         0.68869996,  0.63100004,  0.57249999,  0.51320004,  0.45450002, &
+         0.39810002,  0.34649998,  0.30119997,  0.25950003,  0.21740001, &
+         0.17379999,  0.13029999,  0.08950001,  0.05400002,  0.02640003/
+      data ((c2(ip,iw),iw=1,30), ip=26,26)/ &
+        -0.1257e-06, -0.2495e-06, -0.1334e-06, -0.8414e-07, -0.1698e-06, &
+        -0.1346e-05, -0.3692e-05, -0.8625e-05, -0.1750e-04, -0.3483e-04, &
+        -0.6843e-04, -0.1305e-03, -0.2362e-03, -0.3971e-03, -0.6127e-03, &
+        -0.8621e-03, -0.1101e-02, -0.1297e-02, -0.1452e-02, -0.1570e-02, &
+        -0.1647e-02, -0.1688e-02, -0.1727e-02, -0.1797e-02, -0.1887e-02, &
+        -0.1947e-02, -0.1935e-02, -0.1833e-02, -0.1647e-02, -0.1401e-02/
+      data ((c3(ip,iw),iw=1,30), ip=26,26)/ &
+        -0.1222e-08, -0.1164e-09,  0.2285e-08,  0.2037e-09,  0.5675e-09, &
+        -0.5239e-08, -0.9211e-08, -0.1483e-07, -0.3981e-07, -0.9641e-07, &
+        -0.1717e-06, -0.2796e-06, -0.3800e-06, -0.3762e-06, -0.1936e-06, &
+         0.1920e-06,  0.8335e-06,  0.1691e-05,  0.2415e-05,  0.2767e-05, &
+         0.2823e-05,  0.2551e-05,  0.1839e-05,  0.1314e-05,  0.1960e-05, &
+         0.4003e-05,  0.6909e-05,  0.1004e-04,  0.1273e-04,  0.1423e-04/
+      data ((o1(ip,iw),iw=1,21), ip= 1, 1)/ &
+         0.99999344,  0.99998689,  0.99997336,  0.99994606,  0.99989170, &
+         0.99978632,  0.99957907,  0.99918377,  0.99844402,  0.99712098, &
+         0.99489498,  0.99144602,  0.98655999,  0.98008001,  0.97165000, &
+         0.96043998,  0.94527000,  0.92462999,  0.89709997,  0.86180001, &
+         0.81800002/
+      data ((o2(ip,iw),iw=1,21), ip= 1, 1)/ &
+         0.6531e-10,  0.5926e-10, -0.1646e-09, -0.1454e-08, -0.7376e-08, &
+        -0.2968e-07, -0.1071e-06, -0.3584e-06, -0.1125e-05, -0.3289e-05, &
+        -0.8760e-05, -0.2070e-04, -0.4259e-04, -0.7691e-04, -0.1264e-03, &
+        -0.1957e-03, -0.2895e-03, -0.4107e-03, -0.5588e-03, -0.7300e-03, &
+        -0.9199e-03/
+      data ((o3(ip,iw),iw=1,21), ip= 1, 1)/ &
+        -0.2438e-10, -0.4826e-10, -0.9474e-10, -0.1828e-09, -0.3406e-09, &
+        -0.6223e-09, -0.1008e-08, -0.1412e-08, -0.1244e-08,  0.8485e-09, &
+         0.6343e-08,  0.1201e-07,  0.2838e-08, -0.4024e-07, -0.1257e-06, &
+        -0.2566e-06, -0.4298e-06, -0.6184e-06, -0.7657e-06, -0.8153e-06, &
+        -0.7552e-06/
+      data ((o1(ip,iw),iw=1,21), ip= 2, 2)/ &
+         0.99999344,  0.99998689,  0.99997348,  0.99994606,  0.99989170, &
+         0.99978632,  0.99957907,  0.99918377,  0.99844402,  0.99712098, &
+         0.99489498,  0.99144298,  0.98654997,  0.98006999,  0.97162998, &
+         0.96042001,  0.94520003,  0.92449999,  0.89690000,  0.86140001, &
+         0.81739998/
+      data ((o2(ip,iw),iw=1,21), ip= 2, 2)/ &
+         0.6193e-10,  0.5262e-10, -0.1774e-09, -0.1478e-08, -0.7416e-08, &
+        -0.2985e-07, -0.1071e-06, -0.3584e-06, -0.1124e-05, -0.3287e-05, &
+        -0.8753e-05, -0.2069e-04, -0.4256e-04, -0.7686e-04, -0.1264e-03, &
+        -0.1956e-03, -0.2893e-03, -0.4103e-03, -0.5580e-03, -0.7285e-03, &
+        -0.9171e-03/
+      data ((o3(ip,iw),iw=1,21), ip= 2, 2)/ &
+        -0.2436e-10, -0.4822e-10, -0.9466e-10, -0.1827e-09, -0.3404e-09, &
+        -0.6220e-09, -0.1008e-08, -0.1414e-08, -0.1247e-08,  0.8360e-09, &
+         0.6312e-08,  0.1194e-07,  0.2753e-08, -0.4040e-07, -0.1260e-06, &
+        -0.2571e-06, -0.4307e-06, -0.6202e-06, -0.7687e-06, -0.8204e-06, &
+        -0.7636e-06/
+      data ((o1(ip,iw),iw=1,21), ip= 3, 3)/ &
+         0.99999344,  0.99998689,  0.99997348,  0.99994606,  0.99989170, &
+         0.99978632,  0.99957907,  0.99918377,  0.99844402,  0.99712098, &
+         0.99489301,  0.99143898,  0.98654997,  0.98005998,  0.97158998, &
+         0.96035999,  0.94509000,  0.92431998,  0.89660001,  0.86080003, &
+         0.81639999/
+      data ((o2(ip,iw),iw=1,21), ip= 3, 3)/ &
+         0.5658e-10,  0.4212e-10, -0.1977e-09, -0.1516e-08, -0.7481e-08, &
+        -0.2995e-07, -0.1072e-06, -0.3583e-06, -0.1123e-05, -0.3283e-05, &
+        -0.8744e-05, -0.2067e-04, -0.4252e-04, -0.7679e-04, -0.1262e-03, &
+        -0.1953e-03, -0.2889e-03, -0.4096e-03, -0.5567e-03, -0.7263e-03, &
+        -0.9130e-03/
+      data ((o3(ip,iw),iw=1,21), ip= 3, 3)/ &
+        -0.2433e-10, -0.4815e-10, -0.9453e-10, -0.1825e-09, -0.3400e-09, &
+        -0.6215e-09, -0.1007e-08, -0.1415e-08, -0.1253e-08,  0.8143e-09, &
+         0.6269e-08,  0.1186e-07,  0.2604e-08, -0.4067e-07, -0.1264e-06, &
+        -0.2579e-06, -0.4321e-06, -0.6229e-06, -0.7732e-06, -0.8277e-06, &
+        -0.7752e-06/
+      data ((o1(ip,iw),iw=1,21), ip= 4, 4)/ &
+         0.99999344,  0.99998689,  0.99997348,  0.99994606,  0.99989200, &
+         0.99978632,  0.99957907,  0.99918377,  0.99844402,  0.99711901, &
+         0.99489301,  0.99143499,  0.98653001,  0.98003000,  0.97153997, &
+         0.96026999,  0.94493997,  0.92404002,  0.89609998,  0.85990000, &
+         0.81480002/
+      data ((o2(ip,iw),iw=1,21), ip= 4, 4)/ &
+         0.4814e-10,  0.2552e-10, -0.2298e-09, -0.1576e-08, -0.7579e-08, &
+        -0.3009e-07, -0.1074e-06, -0.3581e-06, -0.1122e-05, -0.3278e-05, &
+        -0.8729e-05, -0.2063e-04, -0.4245e-04, -0.7667e-04, -0.1260e-03, &
+        -0.1950e-03, -0.2883e-03, -0.4086e-03, -0.5549e-03, -0.7229e-03, &
+        -0.9071e-03/
+      data ((o3(ip,iw),iw=1,21), ip= 4, 4)/ &
+        -0.2428e-10, -0.4805e-10, -0.9433e-10, -0.1821e-09, -0.3394e-09, &
+        -0.6206e-09, -0.1008e-08, -0.1416e-08, -0.1261e-08,  0.7860e-09, &
+         0.6188e-08,  0.1171e-07,  0.2389e-08, -0.4109e-07, -0.1271e-06, &
+        -0.2591e-06, -0.4344e-06, -0.6267e-06, -0.7797e-06, -0.8378e-06, &
+        -0.7901e-06/
+      data ((o1(ip,iw),iw=1,21), ip= 5, 5)/ &
+         0.99999344,  0.99998689,  0.99997348,  0.99994606,  0.99989200, &
+         0.99978638,  0.99957907,  0.99918377,  0.99844402,  0.99711901, &
+         0.99488801,  0.99142599,  0.98650998,  0.97999001,  0.97148001, &
+         0.96011001,  0.94467002,  0.92356998,  0.89530003,  0.85860002, &
+         0.81250000/
+      data ((o2(ip,iw),iw=1,21), ip= 5, 5)/ &
+         0.3482e-10, -0.6492e-12, -0.2805e-09, -0.1671e-08, -0.7740e-08, &
+        -0.3032e-07, -0.1076e-06, -0.3582e-06, -0.1120e-05, -0.3270e-05, &
+        -0.8704e-05, -0.2058e-04, -0.4235e-04, -0.7649e-04, -0.1257e-03, &
+        -0.1945e-03, -0.2874e-03, -0.4070e-03, -0.5521e-03, -0.7181e-03, &
+        -0.8990e-03/
+      data ((o3(ip,iw),iw=1,21), ip= 5, 5)/ &
+        -0.2419e-10, -0.4788e-10, -0.9401e-10, -0.1815e-09, -0.3385e-09, &
+        -0.6192e-09, -0.1006e-08, -0.1417e-08, -0.1273e-08,  0.7404e-09, &
+         0.6068e-08,  0.1148e-07,  0.2021e-08, -0.4165e-07, -0.1281e-06, &
+        -0.2609e-06, -0.4375e-06, -0.6323e-06, -0.7887e-06, -0.8508e-06, &
+        -0.8067e-06/
+      data ((o1(ip,iw),iw=1,21), ip= 6, 6)/ &
+         0.99999344,  0.99998689,  0.99997348,  0.99994606,  0.99989200, &
+         0.99978638,  0.99957931,  0.99918377,  0.99844301,  0.99711698, &
+         0.99488401,  0.99141300,  0.98648000,  0.97992003,  0.97135001, &
+         0.95989001,  0.94428003,  0.92286998,  0.89410001,  0.85640001, &
+         0.80890000/
+      data ((o2(ip,iw),iw=1,21), ip= 6, 6)/ &
+         0.1388e-10, -0.4180e-10, -0.3601e-09, -0.1820e-08, -0.7993e-08, &
+        -0.3068e-07, -0.1081e-06, -0.3580e-06, -0.1117e-05, -0.3257e-05, &
+        -0.8667e-05, -0.2049e-04, -0.4218e-04, -0.7620e-04, -0.1253e-03, &
+        -0.1937e-03, -0.2860e-03, -0.4047e-03, -0.5481e-03, -0.7115e-03, &
+        -0.8885e-03/
+      data ((o3(ip,iw),iw=1,21), ip= 6, 6)/ &
+        -0.2406e-10, -0.4762e-10, -0.9351e-10, -0.1806e-09, -0.3370e-09, &
+        -0.6170e-09, -0.1004e-08, -0.1417e-08, -0.1297e-08,  0.6738e-09, &
+         0.5895e-08,  0.1113e-07,  0.1466e-08, -0.4265e-07, -0.1298e-06, &
+        -0.2636e-06, -0.4423e-06, -0.6402e-06, -0.8005e-06, -0.8658e-06, &
+        -0.8222e-06/
+      data ((o1(ip,iw),iw=1,21), ip= 7, 7)/ &
+         0.99999344,  0.99998689,  0.99997348,  0.99994630,  0.99989200, &
+         0.99978638,  0.99957931,  0.99918360,  0.99844301,  0.99711502, &
+         0.99487501,  0.99138802,  0.98642999,  0.97982001,  0.97114998, &
+         0.95954001,  0.94363999,  0.92176998,  0.89219999,  0.85329998, &
+         0.80379999/
+      data ((o2(ip,iw),iw=1,21), ip= 7, 7)/ &
+        -0.1889e-10, -0.1062e-09, -0.4847e-09, -0.2053e-08, -0.8389e-08, &
+        -0.3140e-07, -0.1089e-06, -0.3577e-06, -0.1112e-05, -0.3236e-05, &
+        -0.8607e-05, -0.2035e-04, -0.4192e-04, -0.7576e-04, -0.1245e-03, &
+        -0.1925e-03, -0.2840e-03, -0.4013e-03, -0.5427e-03, -0.7029e-03, &
+        -0.8756e-03/
+      data ((o3(ip,iw),iw=1,21), ip= 7, 7)/ &
+        -0.2385e-10, -0.4722e-10, -0.9273e-10, -0.1791e-09, -0.3348e-09, &
+        -0.6121e-09, -0.9974e-09, -0.1422e-08, -0.1326e-08,  0.5603e-09, &
+         0.5604e-08,  0.1061e-07,  0.6106e-09, -0.4398e-07, -0.1321e-06, &
+        -0.2676e-06, -0.4490e-06, -0.6507e-06, -0.8145e-06, -0.8801e-06, &
+        -0.8311e-06/
+      data ((o1(ip,iw),iw=1,21), ip= 8, 8)/ &
+         0.99999344,  0.99998689,  0.99997348,  0.99994630,  0.99989229, &
+         0.99978650,  0.99957931,  0.99918288,  0.99844098,  0.99711001, &
+         0.99486202,  0.99135500,  0.98635000,  0.97965997,  0.97083998, &
+         0.95898998,  0.94266999,  0.92009997,  0.88929999,  0.84860003, &
+         0.79640001/
+      data ((o2(ip,iw),iw=1,21), ip= 8, 8)/ &
+        -0.6983e-10, -0.2063e-09, -0.6785e-09, -0.2416e-08, -0.9000e-08, &
+        -0.3243e-07, -0.1100e-06, -0.3574e-06, -0.1104e-05, -0.3205e-05, &
+        -0.8516e-05, -0.2014e-04, -0.4151e-04, -0.7508e-04, -0.1234e-03, &
+        -0.1907e-03, -0.2811e-03, -0.3966e-03, -0.5355e-03, -0.6924e-03, &
+        -0.8613e-03/
+      data ((o3(ip,iw),iw=1,21), ip= 8, 8)/ &
+        -0.2353e-10, -0.4659e-10, -0.9153e-10, -0.1769e-09, -0.3313e-09, &
+        -0.6054e-09, -0.9899e-09, -0.1430e-08, -0.1375e-08,  0.3874e-09, &
+         0.5171e-08,  0.9807e-08, -0.7345e-09, -0.4604e-07, -0.1356e-06, &
+        -0.2731e-06, -0.4577e-06, -0.6632e-06, -0.8284e-06, -0.8894e-06, &
+        -0.8267e-06/
+      data ((o1(ip,iw),iw=1,21), ip= 9, 9)/ &
+         0.99999344,  0.99998689,  0.99997360,  0.99994630,  0.99989229, &
+         0.99978650,  0.99957961,  0.99918252,  0.99843901,  0.99710202, &
+         0.99484003,  0.99130303,  0.98623002,  0.97940999,  0.97038001, &
+         0.95815003,  0.94119000,  0.91755998,  0.88510001,  0.84189999, &
+         0.78610003/
+      data ((o2(ip,iw),iw=1,21), ip= 9, 9)/ &
+        -0.1481e-09, -0.3601e-09, -0.9762e-09, -0.2973e-08, -0.1014e-07, &
+        -0.3421e-07, -0.1121e-06, -0.3569e-06, -0.1092e-05, -0.3156e-05, &
+        -0.8375e-05, -0.1981e-04, -0.4090e-04, -0.7405e-04, -0.1218e-03, &
+        -0.1881e-03, -0.2770e-03, -0.3906e-03, -0.5269e-03, -0.6810e-03, &
+        -0.8471e-03/
+      data ((o3(ip,iw),iw=1,21), ip= 9, 9)/ &
+        -0.2304e-10, -0.4564e-10, -0.8969e-10, -0.1735e-09, -0.3224e-09, &
+        -0.5933e-09, -0.9756e-09, -0.1428e-08, -0.1446e-08,  0.1156e-09, &
+         0.4499e-08,  0.8469e-08, -0.2720e-08, -0.4904e-07, -0.1401e-06, &
+        -0.2801e-06, -0.4681e-06, -0.6761e-06, -0.8387e-06, -0.8879e-06, &
+        -0.8040e-06/
+      data ((o1(ip,iw),iw=1,21), ip=10,10)/ &
+         0.99999344,  0.99998689,  0.99997360,  0.99994630,  0.99989259, &
+         0.99978650,  0.99957931,  0.99918163,  0.99843597,  0.99709100, &
+         0.99480897,  0.99122101,  0.98604000,  0.97902000,  0.96965003, &
+         0.95684999,  0.93896997,  0.91386002,  0.87910002,  0.83249998, &
+         0.77200001/
+      data ((o2(ip,iw),iw=1,21), ip=10,10)/ &
+        -0.2661e-09, -0.5923e-09, -0.1426e-08, -0.3816e-08, -0.1159e-07, &
+        -0.3654e-07, -0.1143e-06, -0.3559e-06, -0.1074e-05, -0.3083e-05, &
+        -0.8159e-05, -0.1932e-04, -0.3998e-04, -0.7253e-04, -0.1194e-03, &
+        -0.1845e-03, -0.2718e-03, -0.3833e-03, -0.5176e-03, -0.6701e-03, &
+        -0.8354e-03/
+      data ((o3(ip,iw),iw=1,21), ip=10,10)/ &
+        -0.2232e-10, -0.4421e-10, -0.8695e-10, -0.1684e-09, -0.3141e-09, &
+        -0.5765e-09, -0.9606e-09, -0.1434e-08, -0.1551e-08, -0.2663e-09, &
+         0.3515e-08,  0.6549e-08, -0.5479e-08, -0.5312e-07, -0.1460e-06, &
+        -0.2883e-06, -0.4787e-06, -0.6863e-06, -0.8399e-06, -0.8703e-06, &
+        -0.7602e-06/
+      data ((o1(ip,iw),iw=1,21), ip=11,11)/ &
+         0.99999356,  0.99998701,  0.99997360,  0.99994630,  0.99989289, &
+         0.99978679,  0.99957907,  0.99917960,  0.99843001,  0.99707502, &
+         0.99475998,  0.99109501,  0.98575002,  0.97843999,  0.96855003, &
+         0.95494002,  0.93572998,  0.90853000,  0.87070000,  0.81970000, &
+         0.75380003/
+      data ((o2(ip,iw),iw=1,21), ip=11,11)/ &
+        -0.4394e-09, -0.9330e-09, -0.2086e-08, -0.5054e-08, -0.1373e-07, &
+        -0.3971e-07, -0.1178e-06, -0.3546e-06, -0.1049e-05, -0.2976e-05, &
+        -0.7847e-05, -0.1860e-04, -0.3864e-04, -0.7038e-04, -0.1162e-03, &
+        -0.1798e-03, -0.2654e-03, -0.3754e-03, -0.5091e-03, -0.6621e-03, &
+        -0.8286e-03/
+      data ((o3(ip,iw),iw=1,21), ip=11,11)/ &
+        -0.2127e-10, -0.4216e-10, -0.8300e-10, -0.1611e-09, -0.3019e-09, &
+        -0.5597e-09, -0.9431e-09, -0.1450e-08, -0.1694e-08, -0.7913e-09, &
+         0.2144e-08,  0.3990e-08, -0.9282e-08, -0.5810e-07, -0.1525e-06, &
+        -0.2965e-06, -0.4869e-06, -0.6894e-06, -0.8281e-06, -0.8350e-06, &
+        -0.6956e-06/
+      data ((o1(ip,iw),iw=1,21), ip=12,12)/ &
+         0.99999368,  0.99998701,  0.99997377,  0.99994630,  0.99989259, &
+         0.99978709,  0.99957848,  0.99917740,  0.99842203,  0.99704897, &
+         0.99468797,  0.99090999,  0.98532999,  0.97758001,  0.96693999, &
+         0.95213997,  0.93109000,  0.90110999,  0.85930002,  0.80290002, &
+         0.73019999/
+      data ((o2(ip,iw),iw=1,21), ip=12,12)/ &
+        -0.6829e-09, -0.1412e-08, -0.3014e-08, -0.6799e-08, -0.1675e-07, &
+        -0.4450e-07, -0.1235e-06, -0.3538e-06, -0.1014e-05, -0.2827e-05, &
+        -0.7407e-05, -0.1759e-04, -0.3676e-04, -0.6744e-04, -0.1120e-03, &
+        -0.1742e-03, -0.2585e-03, -0.3683e-03, -0.5034e-03, -0.6594e-03, &
+        -0.8290e-03/
+      data ((o3(ip,iw),iw=1,21), ip=12,12)/ &
+        -0.1985e-10, -0.3937e-10, -0.7761e-10, -0.1511e-09, -0.2855e-09, &
+        -0.5313e-09, -0.9251e-09, -0.1470e-08, -0.1898e-08, -0.1519e-08, &
+         0.2914e-09,  0.5675e-09, -0.1405e-07, -0.6359e-07, -0.1584e-06, &
+        -0.3020e-06, -0.4893e-06, -0.6821e-06, -0.8021e-06, -0.7834e-06, &
+        -0.6105e-06/
+      data ((o1(ip,iw),iw=1,21), ip=13,13)/ &
+         0.99999368,  0.99998701,  0.99997389,  0.99994695,  0.99989289, &
+         0.99978721,  0.99957782,  0.99917412,  0.99840999,  0.99701297, &
+         0.99458599,  0.99064600,  0.98471999,  0.97632003,  0.96464998, &
+         0.94819999,  0.92467999,  0.89109999,  0.84430003,  0.78139997, &
+         0.70070004/
+      data ((o2(ip,iw),iw=1,21), ip=13,13)/ &
+        -0.1004e-08, -0.2043e-08, -0.4239e-08, -0.9104e-08, -0.2075e-07, &
+        -0.5096e-07, -0.1307e-06, -0.3520e-06, -0.9671e-06, -0.2630e-05, &
+        -0.6825e-05, -0.1624e-04, -0.3429e-04, -0.6369e-04, -0.1069e-03, &
+        -0.1680e-03, -0.2520e-03, -0.3635e-03, -0.5029e-03, -0.6647e-03, &
+        -0.8390e-03/
+      data ((o3(ip,iw),iw=1,21), ip=13,13)/ &
+        -0.1807e-10, -0.3587e-10, -0.7085e-10, -0.1385e-09, -0.2648e-09, &
+        -0.4958e-09, -0.8900e-09, -0.1473e-08, -0.2112e-08, -0.2399e-08, &
+        -0.2002e-08, -0.3646e-08, -0.1931e-07, -0.6852e-07, -0.1618e-06, &
+        -0.3021e-06, -0.4828e-06, -0.6634e-06, -0.7643e-06, -0.7177e-06, &
+        -0.5054e-06/
+      data ((o1(ip,iw),iw=1,21), ip=14,14)/ &
+         0.99999368,  0.99998713,  0.99997389,  0.99994725,  0.99989289, &
+         0.99978679,  0.99957597,  0.99916971,  0.99839503,  0.99696702, &
+         0.99444997,  0.99028301,  0.98387003,  0.97457999,  0.96148002, &
+         0.94284999,  0.91613001,  0.87809998,  0.82520002,  0.75489998, &
+         0.66520000/
+      data ((o2(ip,iw),iw=1,21), ip=14,14)/ &
+        -0.1387e-08, -0.2798e-08, -0.5706e-08, -0.1187e-07, -0.2564e-07, &
+        -0.5866e-07, -0.1398e-06, -0.3516e-06, -0.9148e-06, -0.2398e-05, &
+        -0.6122e-05, -0.1459e-04, -0.3125e-04, -0.5923e-04, -0.1013e-03, &
+        -0.1620e-03, -0.2473e-03, -0.3631e-03, -0.5098e-03, -0.6800e-03, &
+        -0.8603e-03/
+      data ((o3(ip,iw),iw=1,21), ip=14,14)/ &
+        -0.1610e-10, -0.3200e-10, -0.6337e-10, -0.1245e-09, -0.2408e-09, &
+        -0.4533e-09, -0.8405e-09, -0.1464e-08, -0.2337e-08, -0.3341e-08, &
+        -0.4467e-08, -0.8154e-08, -0.2436e-07, -0.7128e-07, -0.1604e-06, &
+        -0.2945e-06, -0.4666e-06, -0.6357e-06, -0.7187e-06, -0.6419e-06, &
+        -0.3795e-06/
+      data ((o1(ip,iw),iw=1,21), ip=15,15)/ &
+         0.99999410,  0.99998724,  0.99997455,  0.99994725,  0.99989331, &
+         0.99978632,  0.99957472,  0.99916393,  0.99837703,  0.99690801, &
+         0.99427801,  0.98982000,  0.98277998,  0.97232002,  0.95731997, &
+         0.93585998,  0.90521002,  0.86180001,  0.80190003,  0.72290003, &
+         0.62380004/
+      data ((o2(ip,iw),iw=1,21), ip=15,15)/ &
+        -0.1788e-08, -0.3588e-08, -0.7244e-08, -0.1479e-07, -0.3083e-07, &
+        -0.6671e-07, -0.1497e-06, -0.3519e-06, -0.8607e-06, -0.2154e-05, &
+        -0.5364e-05, -0.1276e-04, -0.2785e-04, -0.5435e-04, -0.9573e-04, &
+        -0.1570e-03, -0.2455e-03, -0.3682e-03, -0.5253e-03, -0.7065e-03, &
+        -0.8938e-03/
+      data ((o3(ip,iw),iw=1,21), ip=15,15)/ &
+        -0.1429e-10, -0.2843e-10, -0.5645e-10, -0.1115e-09, -0.2181e-09, &
+        -0.4200e-09, -0.7916e-09, -0.1460e-08, -0.2542e-08, -0.4168e-08, &
+        -0.6703e-08, -0.1215e-07, -0.2821e-07, -0.7073e-07, -0.1530e-06, &
+        -0.2791e-06, -0.4426e-06, -0.6027e-06, -0.6707e-06, -0.5591e-06, &
+        -0.2328e-06/
+      data ((o1(ip,iw),iw=1,21), ip=16,16)/ &
+         0.99999434,  0.99998778,  0.99997467,  0.99994761,  0.99989331, &
+         0.99978602,  0.99957269,  0.99915779,  0.99835497,  0.99684399, &
+         0.99408400,  0.98929000,  0.98148000,  0.96954000,  0.95212001, &
+         0.92719001,  0.89170003,  0.84200001,  0.77420002,  0.68620002, &
+         0.57780004/
+      data ((o2(ip,iw),iw=1,21), ip=16,16)/ &
+        -0.2141e-08, -0.4286e-08, -0.8603e-08, -0.1737e-07, -0.3548e-07, &
+        -0.7410e-07, -0.1590e-06, -0.3537e-06, -0.8142e-06, -0.1935e-05, &
+        -0.4658e-05, -0.1099e-04, -0.2444e-04, -0.4948e-04, -0.9067e-04, &
+        -0.1538e-03, -0.2474e-03, -0.3793e-03, -0.5495e-03, -0.7439e-03, &
+        -0.9383e-03/
+      data ((o3(ip,iw),iw=1,21), ip=16,16)/ &
+        -0.1295e-10, -0.2581e-10, -0.5136e-10, -0.1019e-09, -0.2011e-09, &
+        -0.3916e-09, -0.7585e-09, -0.1439e-08, -0.2648e-08, -0.4747e-08, &
+        -0.8301e-08, -0.1499e-07, -0.3024e-07, -0.6702e-07, -0.1399e-06, &
+        -0.2564e-06, -0.4117e-06, -0.5669e-06, -0.6239e-06, -0.4748e-06, &
+        -0.7013e-07/
+      data ((o1(ip,iw),iw=1,21), ip=17,17)/ &
+         0.99999434,  0.99998778,  0.99997479,  0.99994791,  0.99989331, &
+         0.99978608,  0.99957120,  0.99915212,  0.99833500,  0.99677801, &
+         0.99388403,  0.98873001,  0.98005998,  0.96639001,  0.94606000, &
+         0.91689998,  0.87580001,  0.81889999,  0.74280000,  0.64559996, &
+         0.52869999/
+      data ((o2(ip,iw),iw=1,21), ip=17,17)/ &
+        -0.2400e-08, -0.4796e-08, -0.9599e-08, -0.1927e-07, -0.3892e-07, &
+        -0.7954e-07, -0.1661e-06, -0.3540e-06, -0.7780e-06, -0.1763e-05, &
+        -0.4092e-05, -0.9512e-05, -0.2142e-04, -0.4502e-04, -0.8640e-04, &
+        -0.1525e-03, -0.2526e-03, -0.3955e-03, -0.5805e-03, -0.7897e-03, &
+        -0.9899e-03/
+      data ((o3(ip,iw),iw=1,21), ip=17,17)/ &
+        -0.1220e-10, -0.2432e-10, -0.4845e-10, -0.9640e-10, -0.1912e-09, &
+        -0.3771e-09, -0.7392e-09, -0.1420e-08, -0.2702e-08, -0.5049e-08, &
+        -0.9214e-08, -0.1659e-07, -0.3101e-07, -0.6162e-07, -0.1235e-06, &
+        -0.2287e-06, -0.3755e-06, -0.5274e-06, -0.5790e-06, -0.3947e-06, &
+         0.1003e-06/
+      data ((o1(ip,iw),iw=1,21), ip=18,18)/ &
+         0.99999464,  0.99998808,  0.99997497,  0.99994791,  0.99989331, &
+         0.99978518,  0.99957031,  0.99914658,  0.99831802,  0.99671799, &
+         0.99370098,  0.98821002,  0.97867000,  0.96313000,  0.93948001, &
+         0.90534002,  0.85769999,  0.79310000,  0.70840001,  0.60290003, &
+         0.47930002/
+      data ((o2(ip,iw),iw=1,21), ip=18,18)/ &
+        -0.2557e-08, -0.5106e-08, -0.1020e-07, -0.2043e-07, -0.4103e-07, &
+        -0.8293e-07, -0.1697e-06, -0.3531e-06, -0.7531e-06, -0.1645e-05, &
+        -0.3690e-05, -0.8411e-05, -0.1902e-04, -0.4118e-04, -0.8276e-04, &
+        -0.1525e-03, -0.2601e-03, -0.4147e-03, -0.6149e-03, -0.8384e-03, &
+        -0.1042e-02/
+      data ((o3(ip,iw),iw=1,21), ip=18,18)/ &
+        -0.1189e-10, -0.2372e-10, -0.4729e-10, -0.9421e-10, -0.1873e-09, &
+        -0.3713e-09, -0.7317e-09, -0.1437e-08, -0.2764e-08, -0.5243e-08, &
+        -0.9691e-08, -0.1751e-07, -0.3122e-07, -0.5693e-07, -0.1076e-06, &
+        -0.1981e-06, -0.3324e-06, -0.4785e-06, -0.5280e-06, -0.3174e-06, &
+         0.2672e-06/
+      data ((o1(ip,iw),iw=1,21), ip=19,19)/ &
+         0.99999464,  0.99998820,  0.99997509,  0.99994779,  0.99989331, &
+         0.99978518,  0.99956989,  0.99914283,  0.99830401,  0.99667197, &
+         0.99355298,  0.98776001,  0.97741997,  0.96007001,  0.93285000, &
+         0.89310002,  0.83819997,  0.76520002,  0.67250001,  0.56000000, &
+         0.43199998/
+      data ((o2(ip,iw),iw=1,21), ip=19,19)/ &
+        -0.2630e-08, -0.5249e-08, -0.1048e-07, -0.2096e-07, -0.4198e-07, &
+        -0.8440e-07, -0.1710e-06, -0.3513e-06, -0.7326e-06, -0.1562e-05, &
+        -0.3416e-05, -0.7637e-05, -0.1719e-04, -0.3795e-04, -0.7926e-04, &
+        -0.1524e-03, -0.2680e-03, -0.4344e-03, -0.6486e-03, -0.8838e-03, &
+        -0.1089e-02/
+      data ((o3(ip,iw),iw=1,21), ip=19,19)/ &
+        -0.1188e-10, -0.2369e-10, -0.4725e-10, -0.9417e-10, -0.1875e-09, &
+        -0.3725e-09, -0.7365e-09, -0.1445e-08, -0.2814e-08, -0.5384e-08, &
+        -0.1008e-07, -0.1816e-07, -0.3179e-07, -0.5453e-07, -0.9500e-07, &
+        -0.1679e-06, -0.2819e-06, -0.4109e-06, -0.4555e-06, -0.2283e-06, &
+         0.4283e-06/
+      data ((o1(ip,iw),iw=1,21), ip=20,20)/ &
+         0.99999487,  0.99998832,  0.99997520,  0.99994791,  0.99989331, &
+         0.99978459,  0.99956900,  0.99913990,  0.99829400,  0.99663699, &
+         0.99344099,  0.98741001,  0.97643000,  0.95743001,  0.92672002, &
+         0.88099998,  0.81809998,  0.73660004,  0.63620001,  0.51880002, &
+         0.38880002/
+      data ((o2(ip,iw),iw=1,21), ip=20,20)/ &
+        -0.2651e-08, -0.5291e-08, -0.1056e-07, -0.2110e-07, -0.4221e-07, &
+        -0.8462e-07, -0.1705e-06, -0.3466e-06, -0.7155e-06, -0.1501e-05, &
+        -0.3223e-05, -0.7079e-05, -0.1581e-04, -0.3517e-04, -0.7553e-04, &
+        -0.1510e-03, -0.2746e-03, -0.4528e-03, -0.6789e-03, -0.9214e-03, &
+        -0.1124e-02/
+      data ((o3(ip,iw),iw=1,21), ip=20,20)/ &
+        -0.1193e-10, -0.2380e-10, -0.4748e-10, -0.9465e-10, -0.1886e-09, &
+        -0.3751e-09, -0.7436e-09, -0.1466e-08, -0.2872e-08, -0.5508e-08, &
+        -0.1038e-07, -0.1891e-07, -0.3279e-07, -0.5420e-07, -0.8711e-07, &
+        -0.1403e-06, -0.2248e-06, -0.3221e-06, -0.3459e-06, -0.1066e-06, &
+         0.5938e-06/
+      data ((o1(ip,iw),iw=1,21), ip=21,21)/ &
+         0.99999487,  0.99998873,  0.99997509,  0.99994779,  0.99989349, &
+         0.99978501,  0.99956918,  0.99913877,  0.99828798,  0.99661303, &
+         0.99335998,  0.98715001,  0.97566003,  0.95530999,  0.92153001, &
+         0.87000000,  0.79869998,  0.70819998,  0.60109997,  0.48110002, &
+         0.35140002/
+      data ((o2(ip,iw),iw=1,21), ip=21,21)/ &
+        -0.2654e-08, -0.5296e-08, -0.1057e-07, -0.2111e-07, -0.4219e-07, &
+        -0.8445e-07, -0.1696e-06, -0.3428e-06, -0.7013e-06, -0.1458e-05, &
+        -0.3084e-05, -0.6678e-05, -0.1476e-04, -0.3284e-04, -0.7173e-04, &
+        -0.1481e-03, -0.2786e-03, -0.4688e-03, -0.7052e-03, -0.9506e-03, &
+        -0.1148e-02/
+      data ((o3(ip,iw),iw=1,21), ip=21,21)/ &
+        -0.1195e-10, -0.2384e-10, -0.4755e-10, -0.9482e-10, -0.1890e-09, &
+        -0.3761e-09, -0.7469e-09, -0.1476e-08, -0.2892e-08, -0.5603e-08, &
+        -0.1060e-07, -0.1942e-07, -0.3393e-07, -0.5508e-07, -0.8290e-07, &
+        -0.1182e-06, -0.1657e-06, -0.2170e-06, -0.1997e-06,  0.6227e-07, &
+         0.7847e-06/
+      data ((o1(ip,iw),iw=1,21), ip=22,22)/ &
+         0.99999541,  0.99998873,  0.99997497,  0.99994737,  0.99989349, &
+         0.99978501,  0.99956882,  0.99913770,  0.99828303,  0.99659699, &
+         0.99330199,  0.98697001,  0.97510999,  0.95372999,  0.91742998, &
+         0.86080003,  0.78139997,  0.68220001,  0.56920004,  0.44809997, &
+         0.32080001/
+      data ((o2(ip,iw),iw=1,21), ip=22,22)/ &
+        -0.2653e-08, -0.5295e-08, -0.1057e-07, -0.2110e-07, -0.4215e-07, &
+        -0.8430e-07, -0.1690e-06, -0.3403e-06, -0.6919e-06, -0.1427e-05, &
+        -0.2991e-05, -0.6399e-05, -0.1398e-04, -0.3099e-04, -0.6824e-04, &
+        -0.1441e-03, -0.2795e-03, -0.4814e-03, -0.7282e-03, -0.9739e-03, &
+        -0.1163e-02/
+      data ((o3(ip,iw),iw=1,21), ip=22,22)/ &
+        -0.1195e-10, -0.2384e-10, -0.4756e-10, -0.9485e-10, -0.1891e-09, &
+        -0.3765e-09, -0.7483e-09, -0.1481e-08, -0.2908e-08, -0.5660e-08, &
+        -0.1075e-07, -0.1980e-07, -0.3472e-07, -0.5626e-07, -0.8149e-07, &
+        -0.1027e-06, -0.1136e-06, -0.1071e-06, -0.2991e-07,  0.2743e-06, &
+         0.1017e-05/
+      data ((o1(ip,iw),iw=1,21), ip=23,23)/ &
+         0.99999595,  0.99998885,  0.99997479,  0.99994725,  0.99989331, &
+         0.99978518,  0.99956882,  0.99913692,  0.99827999,  0.99658602, &
+         0.99326497,  0.98685002,  0.97474003,  0.95260000,  0.91441000, &
+         0.85360003,  0.76719999,  0.65990001,  0.54190004,  0.42119998, &
+         0.29699999/
+      data ((o2(ip,iw),iw=1,21), ip=23,23)/ &
+        -0.2653e-08, -0.5294e-08, -0.1057e-07, -0.2109e-07, -0.4212e-07, &
+        -0.8420e-07, -0.1686e-06, -0.3388e-06, -0.6858e-06, -0.1406e-05, &
+        -0.2928e-05, -0.6206e-05, -0.1344e-04, -0.2961e-04, -0.6533e-04, &
+        -0.1399e-03, -0.2780e-03, -0.4904e-03, -0.7488e-03, -0.9953e-03, &
+        -0.1175e-02/
+      data ((o3(ip,iw),iw=1,21), ip=23,23)/ &
+        -0.1195e-10, -0.2384e-10, -0.4756e-10, -0.9485e-10, -0.1891e-09, &
+        -0.3767e-09, -0.7492e-09, -0.1485e-08, -0.2924e-08, -0.5671e-08, &
+        -0.1084e-07, -0.2009e-07, -0.3549e-07, -0.5773e-07, -0.8208e-07, &
+        -0.9394e-07, -0.7270e-07, -0.3947e-08,  0.1456e-06,  0.5083e-06, &
+         0.1270e-05/
+      data ((o1(ip,iw),iw=1,21), ip=24,24)/ &
+         0.99999630,  0.99998873,  0.99997401,  0.99994725,  0.99989349, &
+         0.99978501,  0.99956959,  0.99913663,  0.99827701,  0.99658000, &
+         0.99324101,  0.98676997,  0.97447002,  0.95185000,  0.91232002, &
+         0.84850001,  0.75660002,  0.64230001,  0.52030003,  0.40090001, &
+         0.27980000/
+      data ((o2(ip,iw),iw=1,21), ip=24,24)/ &
+        -0.2653e-08, -0.5294e-08, -0.1056e-07, -0.2109e-07, -0.4210e-07, &
+        -0.8413e-07, -0.1684e-06, -0.3379e-06, -0.6820e-06, -0.1393e-05, &
+        -0.2889e-05, -0.6080e-05, -0.1307e-04, -0.2861e-04, -0.6310e-04, &
+        -0.1363e-03, -0.2758e-03, -0.4969e-03, -0.7681e-03, -0.1017e-02, &
+        -0.1186e-02/
+      data ((o3(ip,iw),iw=1,21), ip=24,24)/ &
+        -0.1195e-10, -0.2384e-10, -0.4756e-10, -0.9485e-10, -0.1891e-09, &
+        -0.3768e-09, -0.7497e-09, -0.1487e-08, -0.2933e-08, -0.5710e-08, &
+        -0.1089e-07, -0.2037e-07, -0.3616e-07, -0.5907e-07, -0.8351e-07, &
+        -0.8925e-07, -0.4122e-07,  0.8779e-07,  0.3143e-06,  0.7281e-06, &
+         0.1500e-05/
+      data ((o1(ip,iw),iw=1,21), ip=25,25)/ &
+         0.99999648,  0.99998897,  0.99997377,  0.99994749,  0.99989331, &
+         0.99978501,  0.99956989,  0.99913692,  0.99827600,  0.99657297, &
+         0.99322498,  0.98672003,  0.97431999,  0.95137000,  0.91095001, &
+         0.84500003,  0.74909997,  0.62979996,  0.50510001,  0.38679999, &
+         0.26789999/
+      data ((o2(ip,iw),iw=1,21), ip=25,25)/ &
+        -0.2653e-08, -0.5293e-08, -0.1056e-07, -0.2108e-07, -0.4209e-07, &
+        -0.8409e-07, -0.1682e-06, -0.3373e-06, -0.6797e-06, -0.1383e-05, &
+        -0.2862e-05, -0.5993e-05, -0.1283e-04, -0.2795e-04, -0.6158e-04, &
+        -0.1338e-03, -0.2743e-03, -0.5030e-03, -0.7863e-03, -0.1038e-02, &
+        -0.1196e-02/
+      data ((o3(ip,iw),iw=1,21), ip=25,25)/ &
+        -0.1195e-10, -0.2383e-10, -0.4755e-10, -0.9484e-10, -0.1891e-09, &
+        -0.3768e-09, -0.7499e-09, -0.1489e-08, -0.2939e-08, -0.5741e-08, &
+        -0.1100e-07, -0.2066e-07, -0.3660e-07, -0.6002e-07, -0.8431e-07, &
+        -0.8556e-07, -0.1674e-07,  0.1638e-06,  0.4525e-06,  0.8949e-06, &
+         0.1669e-05/
+      data ((o1(ip,iw),iw=1,21), ip=26,26)/ &
+         0.99999672,  0.99998909,  0.99997377,  0.99994695,  0.99989349, &
+         0.99978518,  0.99956989,  0.99913692,  0.99827498,  0.99657100, &
+         0.99321902,  0.98668998,  0.97421002,  0.95106000,  0.91009998, &
+         0.84280002,  0.74430001,  0.62180001,  0.49519998,  0.37800002, &
+         0.25999999/
+      data ((o2(ip,iw),iw=1,21), ip=26,26)/ &
+        -0.2652e-08, -0.5292e-08, -0.1056e-07, -0.2108e-07, -0.4208e-07, &
+        -0.8406e-07, -0.1681e-06, -0.3369e-06, -0.6784e-06, -0.1378e-05, &
+        -0.2843e-05, -0.5944e-05, -0.1269e-04, -0.2759e-04, -0.6078e-04, &
+        -0.1326e-03, -0.2742e-03, -0.5088e-03, -0.8013e-03, -0.1054e-02, &
+        -0.1202e-02/
+      data ((o3(ip,iw),iw=1,21), ip=26,26)/ &
+        -0.1194e-10, -0.2383e-10, -0.4754e-10, -0.9482e-10, -0.1891e-09, &
+        -0.3768e-09, -0.7499e-09, -0.1489e-08, -0.2941e-08, -0.5752e-08, &
+        -0.1104e-07, -0.2069e-07, -0.3661e-07, -0.6012e-07, -0.8399e-07, &
+        -0.8183e-07,  0.1930e-08,  0.2167e-06,  0.5434e-06,  0.9990e-06, &
+         0.1787e-05/
+
+!xp
+!      allocate(pa(m,np))
+!      allocate(dt(m,np))
+!      allocate(sh2o(m,np+1))
+!      allocate(swpre(m,np+1))
+!      allocate(swtem(m,np+1))
+!      allocate(sco3(m,np+1))
+!      allocate(scopre(m,np+1))
+!      allocate(scotem(m,np+1))
+!      allocate(dh2o(m,np))
+!      allocate(dcont(m,np))
+!      allocate(dco2(m,np))
+!      allocate(do3(m,np))
+!      allocate(dn2o(m,np))
+!      allocate(dch4(m,np))
+!      allocate(df11(m,np))
+!      allocate(df12(m,np))
+!      allocate(df22(m,np))
+!      allocate(th2o(m,6))
+!      allocate(tcon(m,3))
+!      allocate(tco2(m,6,2))
+!      allocate(tn2o(m,4))
+!      allocate(tch4(m,4))
+!      allocate(tcom(m,6))
+!      allocate(tf11(m))
+!      allocate(tf12(m))
+!      allocate(tf22(m))
+!      allocate(h2oexp(m,np,6))
+!      allocate(conexp(m,np,3))
+!      allocate(co2exp(m,np,6,2))
+!      allocate(n2oexp(m,np,4))
+!      allocate(ch4exp(m,np,4))
+!      allocate(comexp(m,np,6))
+!      allocate(f11exp(m,np))
+!      allocate(f12exp(m,np))
+!      allocate(f22exp(m,np))
+!      allocate(blayer(m,0:np+1))
+!      allocate(blevel(m,np+1))
+!      allocate(dblayr(m,np+1))
+!      allocate(dbs(m))
+!      allocate(dp(m,np))
+!      allocate(cwp(m,np,3))
+!      allocate(trant(m))
+!      allocate(tranal(m))
+!      allocate(transfc(m,np+1))
+!      allocate(trantcr(m,np+1))
+!      allocate(flxu(m,np+1))
+!      allocate(flxd(m,np+1))
+!      allocate(flcu(m,np+1))
+!      allocate(flcd(m,np+1))
+!      allocate(rflx(m,np+1))
+!      allocate(rflc(m,np+1))
+!      allocate(it(m))
+!      allocate(im(m))
+!      allocate(ib(m))
+!      allocate(cldhi(m))
+!      allocate(cldmd(m))
+!      allocate(cldlw(m))
+!      allocate(tcldlyr(m,np))
+!      allocate(fclr(m))
+!      allocate(taerlyr(m,np))
+
+!-----compute layer pressure (pa) and layer temperature minus 250k (dt)
+      do k=1,np
+       do i=1,m
+         pa(i,k)=0.5*(pl(i,k)+pl(i,k+1))
+         dt(i,k)=ta(i,k)-250.0
+       enddo
+      enddo
+
+!-----compute layer absorber amount
+!     dh2o : water vapor amount (g/cm**2)
+!     dcont: scaled water vapor amount for continuum absorption
+!            (g/cm**2)
+!     dco2 : co2 amount (cm-atm)stp
+!     do3  : o3 amount (cm-atm)stp
+!     dn2o : n2o amount (cm-atm)stp
+!     dch4 : ch4 amount (cm-atm)stp
+!     df11 : cfc11 amount (cm-atm)stp
+!     df12 : cfc12 amount (cm-atm)stp
+!     df22 : cfc22 amount (cm-atm)stp
+!     the factor 1.02 is equal to 1000/980
+!     factors 789 and 476 are for unit conversion
+!     the factor 0.001618 is equal to 1.02/(.622*1013.25)
+!     the factor 6.081 is equal to 1800/296
+      do k=1,np
+       do i=1,m
+         dp   (i,k) = pl(i,k+1)-pl(i,k)
+         dh2o (i,k) = 1.02*wa(i,k)*dp(i,k)+1.e-10
+         do3  (i,k) = 476.*oa(i,k)*dp(i,k)+1.e-10
+         dco2 (i,k) = 789.*co2*dp(i,k)+1.e-10
+         dch4 (i,k) = 789.*ch4*dp(i,k)+1.e-10
+         dn2o (i,k) = 789.*n2o*dp(i,k)+1.e-10
+         df11 (i,k) = 789.*cfc11*dp(i,k)+1.e-10
+         df12 (i,k) = 789.*cfc12*dp(i,k)+1.e-10
+         df22 (i,k) = 789.*cfc22*dp(i,k)+1.e-10
+!-----compute scaled water vapor amount for h2o continuum absorption
+!     following eq. (4.21).
+         xx=pa(i,k)*0.001618*wa(i,k)*wa(i,k)*dp(i,k)
+         dcont(i,k) = xx*exp(1800./ta(i,k)-6.081)+1.e-10
+       enddo
+      enddo
+!-----compute column-integrated h2o amoumt (sh2o), h2o-weighted pressure
+!     (swpre) and temperature (swtem). it follows eqs. (4.13) and (4.14).
+
+       if (high) then
+        call column(m,np,pa,dt,dh2o,sh2o,swpre,swtem)
+       endif
+
+!-----compute layer cloud water amount (gm/m**2)
+!     index is 1 for ice, 2 for waterdrops and 3 for raindrops.
+
+       if (cldwater) then
+        do k=1,np
+         do i=1,m
+             xx=1.02*10000.*(pl(i,k+1)-pl(i,k))
+             cwp(i,k,1)=xx*cwc(i,k,1)
+             cwp(i,k,2)=xx*cwc(i,k,2)
+             cwp(i,k,3)=xx*cwc(i,k,3)
+         enddo
+        enddo
+       endif
+
+!-----the surface (np+1) is treated as a layer filled with black clouds.
+!     transfc is the transmttance between the surface and a pressure level.
+!     trantcr is the clear-sky transmttance between the surface and a
+!     pressure level.
+
+      do i=1,m
+        sfcem(i)       =0.0
+        transfc(i,np+1)=1.0
+        trantcr(i,np+1)=1.0
+      enddo
+
+!-----initialize fluxes
+
+      do k=1,np+1
+       do i=1,m
+         flx(i,k)  = 0.0
+         flc(i,k)  = 0.0
+         dfdts(i,k)= 0.0
+         rflx(i,k) = 0.0
+         rflc(i,k) = 0.0
+         acflxu(i,k) = 0.0
+         acflxd(i,k) = 0.0
+       enddo
+      enddo
+
+!-----integration over spectral bands
+
+      do 1000 ibn=1,ib_lw
+
+!-----if h2otbl, compute h2o (line) transmittance using table look-up.
+!     if conbnd, compute h2o (continuum) transmittance in bands 3-7.
+!     if co2bnd, compute co2 transmittance in band 3.
+!     if oznbnd, compute  o3 transmittance in band 5.
+!     if n2obnd, compute n2o transmittance in bands 6 and 7.
+!     if ch4bnd, compute ch4 transmittance in bands 6 and 7.
+!     if combnd, compute co2-minor transmittance in bands 4 and 5.
+!     if f11bnd, compute cfc11 transmittance in bands 4 and 5.
+!     if f12bnd, compute cfc12 transmittance in bands 4 and 6.
+!     if f22bnd, compute cfc22 transmittance in bands 4 and 6.
+!     if b10bnd, compute flux reduction due to n2o in band 10.
+       h2otbl=high.and.(ibn.eq.1.or.ibn.eq.2.or.ibn.eq.8)
+       conbnd=ibn.ge.3.and.ibn.le.7
+       co2bnd=ibn.eq.3
+       oznbnd=ibn.eq.5
+       n2obnd=ibn.eq.6.or.ibn.eq.7
+       ch4bnd=ibn.eq.6.or.ibn.eq.7
+       combnd=ibn.eq.4.or.ibn.eq.5
+       f11bnd=ibn.eq.4.or.ibn.eq.5
+       f12bnd=ibn.eq.4.or.ibn.eq.6
+       f22bnd=ibn.eq.4.or.ibn.eq.6
+       b10bnd=ibn.eq.10
+       if (.not. b10bnd .or. trace) then          ! skip b10 and .not.trace
+!-----blayer is the spectrally integrated planck flux of the mean layer
+!     temperature derived from eq. (3.11)
+!     the fitting for the planck flux is valid for the range 160-345 k.
+       do k=1,np
+        do i=1,m
+          blayer(i,k)=ta(i,k)*(ta(i,k)*(ta(i,k)*(ta(i,k) &
+                     *(ta(i,k)*cb(6,ibn)+cb(5,ibn))+cb(4,ibn)) &
+                     +cb(3,ibn))+cb(2,ibn))+cb(1,ibn)
+        enddo
+       enddo
+       do i=1,m
+!-----the earth's surface, with index "np+1", is treated as a layer.
+!     index "0" is the layer above the top of the atmosphere.
+         blayer(i,np+1)=(ts(i)*(ts(i)*(ts(i)*(ts(i) &
+                       *(ts(i)*cb(6,ibn)+cb(5,ibn))+cb(4,ibn)) &
+                       +cb(3,ibn))+cb(2,ibn))+cb(1,ibn))*emiss(i,ibn)
+         blayer(i,0)   = 0.0
+!-----dbs is the derivative of the surface emission with respect to
+!     surface temperature eq. (3.12).
+        dbs(i)=(ts(i)*(ts(i)*(ts(i)*(ts(i)*5.*cb(6,ibn)+4.*cb(5,ibn)) &
+              +3.*cb(4,ibn))+2.*cb(3,ibn))+cb(2,ibn))*emiss(i,ibn)
+       enddo
+!-----difference in planck functions between adjacent layers.
+       do k=1,np+1
+        do i=1,m
+         dblayr(i,k)=blayer(i,k-1)-blayer(i,k)
+        enddo
+       enddo
+!------interpolate planck function at model levels
+       do k=2,np
+        do i=1,m
+         blevel(i,k)=(blayer(i,k-1)*dp(i,k)+blayer(i,k)*dp(i,k-1))/ &
+                     (dp(i,k-1)+dp(i,k))
+        enddo
+       enddo
+       do i=1,m
+         blevel(i,1)=blayer(i,1)+(blayer(i,1)-blayer(i,2))*dp(i,1)/ &
+                     (dp(i,1)+dp(i,2))
+         blevel(i,np+1)=tb(i)*(tb(i)*(tb(i)*(tb(i) &
+                       *(tb(i)*cb(6,ibn)+cb(5,ibn))+cb(4,ibn)) &
+                       +cb(3,ibn))+cb(2,ibn))+cb(1,ibn)
+       enddo
+
+!-----compute column-integrated absorber amoumt, absorber-weighted
+!     pressure and temperature for co2 (band 3) and o3 (band 5).
+!     it follows eqs. (4.13) and (4.14).
+!-----this is in the band loop to save storage
+
+      if (high .and. co2bnd) then
+        call column(m,np,pa,dt,dco2,sco3,scopre,scotem)
+      endif
+      if (oznbnd) then
+        call column(m,np,pa,dt,do3,sco3,scopre,scotem)
+      endif
+
+!-----compute cloud optical thickness following eqs. (6.4a,b) and (6.7)
+!     rain optical thickness is set to 0.00307 /(gm/m**2).
+!     it is for a specific drop size distribution provided by q. fu.
+
+      if (cldwater) then
+       do k=1,np
+        do i=1,m
+          taucl(i,k,1)=cwp(i,k,1)*(aib(1,ibn)+aib(2,ibn)/ &
+            reff(i,k,1)**aib(3,ibn))
+          taucl(i,k,2)=cwp(i,k,2)*(awb(1,ibn)+(awb(2,ibn)+ &
+            (awb(3,ibn)+awb(4,ibn)*reff(i,k,2))*reff(i,k,2)) &
+            *reff(i,k,2))
+          taucl(i,k,3)=0.00307*cwp(i,k,3)
+        enddo
+       enddo
+      endif
+
+!-----compute cloud single-scattering albedo and asymmetry factor for
+!     a mixture of ice particles and liquid drops following
+!     eqs. (6.5), (6.6), (6.11) and (6.12).
+!     single-scattering albedo and asymmetry factor of rain are set
+!     to 0.54 and 0.95, respectively, based on the information provided
+!     by prof. qiang fu.
+
+       do k=1,np
+        do i=1,m
+           tcldlyr(i,k) = 1.0
+           taux=taucl(i,k,1)+taucl(i,k,2)+taucl(i,k,3)
+          if (taux.gt.0.02 .and. fcld(i,k).gt.0.01) then
+            reff1=min(reff(i,k,1),150._fp_kind)
+            reff2=min(reff(i,k,2),20.0_fp_kind)
+           w1=taucl(i,k,1)*(aiw(1,ibn)+(aiw(2,ibn)+(aiw(3,ibn) &
+             +aiw(4,ibn)*reff1)*reff1)*reff1)
+           w2=taucl(i,k,2)*(aww(1,ibn)+(aww(2,ibn)+(aww(3,ibn) &
+             +aww(4,ibn)*reff2)*reff2)*reff2)
+           w3=taucl(i,k,3)*0.54
+           ww=(w1+w2+w3)/taux
+           g1=w1*(aig(1,ibn)+(aig(2,ibn)+(aig(3,ibn) &
+            +aig(4,ibn)*reff1)*reff1)*reff1)
+           g2=w2*(awg(1,ibn)+(awg(2,ibn)+(awg(3,ibn) &
+            +awg(4,ibn)*reff2)*reff2)*reff2)
+           g3=w3*0.95
+           gg=(g1+g2+g3)/(w1+w2+w3)
+!-----parameterization of lw scattering following eqs. (6.8) and (6.9).
+           ff=0.5+(0.3739+(0.0076+0.1185*gg)*gg)*gg
+           taux=taux*(1.-ww*ff)
+!-----compute cloud diffuse transmittance. it is approximated by using
+!     a diffusivity factor of 1.66.
+           tauxa=max(0._fp_kind,1.66*taux)
+           tcldlyr(i,k)=0.
+           if(tauxa.lt.80.)tcldlyr(i,k)=exp(-tauxa)
+          endif
+        enddo
+       enddo
+!-----for aerosol diffuse transmittance
+!     the same scaling of cloud optical thickness is applied to aerosols
+       do k=1,np
+        do i=1,m
+           taerlyr(i,k)=1.0
+          if (taual(i,k,ibn).gt.0.01) then
+           ff=0.5+(0.3739+(0.0076+0.1185*asyal(i,k,ibn)) &
+            *asyal(i,k,ibn))*asyal(i,k,ibn)
+           taux=taual(i,k,ibn)*(1.-ssaal(i,k,ibn)*ff)
+           taerlyr(i,k)=exp(-1.66*taux)
+          endif
+        enddo
+       enddo
+!-----compute the exponential terms (eq. 8.18) at each layer due to
+!     water vapor line absorption when k-distribution is used
+      if (.not.h2otbl .and. .not.b10bnd) then
+        call h2oexps(ibn,m,np,dh2o,pa,dt,xkw,aw,bw,pm,mw,h2oexp)
+      endif
+!-----compute the exponential terms (eq. 8.18) at each layer due to
+!     water vapor continuum absorption
+      if (conbnd) then
+        call conexps(ibn,m,np,dcont,xke,conexp)
+      endif
+!-----compute the exponential terms (eq. 8.18) at each layer due to
+!     co2 absorption
+      if (.not.high .and. co2bnd) then
+        call co2exps(m,np,dco2,pa,dt,co2exp)
+      endif
+!***** for trace gases *****
+      if (trace) then
+!-----compute the exponential terms at each layer due to n2o absorption
+       if (n2obnd) then
+        call n2oexps(ibn,m,np,dn2o,pa,dt,n2oexp)
+       endif
+!-----compute the exponential terms at each layer due to ch4 absorption
+       if (ch4bnd) then
+        call ch4exps(ibn,m,np,dch4,pa,dt,ch4exp)
+       endif
+!-----compute the exponential terms due to co2 minor absorption
+       if (combnd) then
+        call comexps(ibn,m,np,dco2,dt,comexp)
+       endif
+!-----compute the exponential terms due to cfc11 absorption.
+!     the values of the parameters are given in table 7.
+       if (f11bnd) then
+            a1  = 1.26610e-3
+            b1  = 3.55940e-6
+            fk1 = 1.89736e+1
+            a2  = 8.19370e-4
+            b2  = 4.67810e-6
+            fk2 = 1.01487e+1
+        call cfcexps(ibn,m,np,a1,b1,fk1,a2,b2,fk2,df11,dt,f11exp)
+       endif
+!-----compute the exponential terms due to cfc12 absorption.
+       if (f12bnd) then
+            a1  = 8.77370e-4
+            b1  =-5.88440e-6
+            fk1 = 1.58104e+1
+            a2  = 8.62000e-4
+            b2  =-4.22500e-6
+            fk2 = 3.70107e+1
+        call cfcexps(ibn,m,np,a1,b1,fk1,a2,b2,fk2,df12,dt,f12exp)
+       endif
+!-----compute the exponential terms due to cfc22 absorption.
+       if (f22bnd) then
+            a1  = 9.65130e-4
+            b1  = 1.31280e-5
+            fk1 = 6.18536e+0
+            a2  =-3.00010e-5
+            b2  = 5.25010e-7
+            fk2 = 3.27912e+1
+        call cfcexps(ibn,m,np,a1,b1,fk1,a2,b2,fk2,df22,dt,f22exp)
+       endif
+!-----compute the exponential terms at each layer in band 10 due to
+!     h2o line and continuum, co2, and n2o absorption
+       if (b10bnd) then
+        call b10exps(m,np,dh2o,dcont,dco2,dn2o,pa,dt &
+                    ,h2oexp,conexp,co2exp,n2oexp)
+       endif
+      endif
+!-----compute transmittances for regions between levels k1 and k2
+!     and update fluxes at the two levels.
+!-----initialize fluxes
+      do k=1,np+1
+       do i=1,m
+         flxu(i,k) = 0.0
+         flxd(i,k) = 0.0
+         flcu(i,k) = 0.0
+         flcd(i,k) = 0.0
+       enddo
+      enddo
+      do 2000 k1=1,np
+!-----initialization
+!
+!     it, im, and ib are the numbers of cloudy layers in the high,
+!     middle, and low cloud groups between levels k1 and k2.
+!     cldlw, cldmd, and cldhi are the equivalent black-cloud fractions
+!     of low, middle, and high troposphere.
+!     tranal is the aerosol transmission function
+        do i=1,m
+          it(i) = 0
+          im(i) = 0
+          ib(i) = 0
+          cldlw(i) = 0.0
+          cldmd(i) = 0.0
+          cldhi(i) = 0.0
+          tranal(i)= 1.0
+        enddo
+!-----for h2o line transmission
+      if (.not. h2otbl) then
+        do ik=1,6
+         do i=1,m
+           th2o(i,ik)=1.0
+         enddo
+        enddo
+      endif
+!-----for h2o continuum transmission
+         do iq=1,3
+          do i=1,m
+            tcon(i,iq)=1.0
+          enddo
+         enddo
+!-----for co2 transmission using k-distribution method.
+!     band 3 is divided into 3 sub-bands, but sub-bands 3a and 3c
+!     are combined in computing the co2 transmittance.
+       if (.not.high .and. co2bnd) then
+         do isb=1,2
+          do ik=1,6
+           do i=1,m
+             tco2(i,ik,isb)=1.0
+           enddo
+          enddo
+         enddo
+       endif
+!***** for trace gases *****
+      if (trace) then
+!-----for n2o transmission using k-distribution method.
+       if (n2obnd) then
+          do ik=1,4
+           do i=1,m
+             tn2o(i,ik)=1.0
+           enddo
+          enddo
+       endif
+!-----for ch4 transmission using k-distribution method.
+       if (ch4bnd) then
+          do ik=1,4
+           do i=1,m
+             tch4(i,ik)=1.0
+           enddo
+          enddo
+       endif
+!-----for co2-minor transmission using k-distribution method.
+       if (combnd) then
+          do ik=1,6
+           do i=1,m
+             tcom(i,ik)=1.0
+           enddo
+          enddo
+       endif
+!-----for cfc-11 transmission using k-distribution method.
+       if (f11bnd) then
+           do i=1,m
+             tf11(i)=1.0
+           enddo
+       endif
+!-----for cfc-12 transmission using k-distribution method.
+       if (f12bnd) then
+           do i=1,m
+             tf12(i)=1.0
+           enddo
+       endif
+!-----for cfc-22 transmission when using k-distribution method.
+       if (f22bnd) then
+           do i=1,m
+             tf22(i)=1.0
+           enddo
+       endif
+!-----for the transmission in band 10 using k-distribution method.
+       if (b10bnd) then
+          do ik=1,5
+           do i=1,m
+              th2o(i,ik)=1.0
+           enddo
+          enddo
+          do ik=1,6
+           do i=1,m
+              tco2(i,ik,1)=1.0
+           enddo
+          enddo
+          do i=1,m
+             tcon(i,1)=1.0
+          enddo
+          do ik=1,2
+            do i=1,m
+              tn2o(i,ik)=1.0
+           enddo
+          enddo
+       endif
+      endif
+!***** end trace gases *****
+       do i=1,m
+        fclr(i)=1.0
+       enddo
+!-----loop over the bottom level of the region (k2)
+      do 3000 k2=k1+1,np+1
+!-----trant is the total transmittance between levels k1 and k2.
+          do i=1,m
+           trant(i)=1.0
+          enddo
+      if (h2otbl) then
+!-----compute water vapor transmittance using table look-up.
+!     the following values are taken from table 8.
+          w1=-8.0
+          p1=-2.0
+          dwe=0.3
+          dpe=0.2
+          if (ibn.eq.1) then
+           call tablup(k1,k2,m,np,nx2,nh,sh2o,swpre,swtem, &
+                       w1,p1,dwe,dpe,h11,h12,h13,trant)
+          endif
+          if (ibn.eq.2) then
+           call tablup(k1,k2,m,np,nx2,nh,sh2o,swpre,swtem, &
+                       w1,p1,dwe,dpe,h21,h22,h23,trant)
+          endif
+          if (ibn.eq.8) then
+           call tablup(k1,k2,m,np,nx2,nh,sh2o,swpre,swtem, &
+                       w1,p1,dwe,dpe,h81,h82,h83,trant)
+          endif
+      else
+!-----compute water vapor transmittance using k-distribution
+       if (.not.b10bnd) then
+        call h2okdis(ibn,m,np,k2-1,fkw,gkw,ne,h2oexp,conexp, &
+                     th2o,tcon,trant)
+       endif
+      endif
+      if (co2bnd) then
+        if (high) then
+!-----compute co2 transmittance using table look-up method.
+!     the following values are taken from table 8.
+          w1=-4.0
+          p1=-2.0
+          dwe=0.3
+          dpe=0.2
+          call tablup(k1,k2,m,np,nx2,nc,sco3,scopre,scotem, &
+                      w1,p1,dwe,dpe,c1,c2,c3,trant)
+       else
+!-----compute co2 transmittance using k-distribution method
+          call co2kdis(m,np,k2-1,co2exp,tco2,trant)
+        endif
+      endif
+!-----always use table look-up to compute o3 transmittance.
+!     the following values are taken from table 8.
+      if (oznbnd) then
+          w1=-6.0
+          p1=-2.0
+          dwe=0.3
+          dpe=0.2
+          call tablup(k1,k2,m,np,nx2,no,sco3,scopre,scotem, &
+                      w1,p1,dwe,dpe,o1,o2,o3,trant)
+      endif
+!***** for trace gases *****
+      if (trace) then
+!-----compute n2o transmittance using k-distribution method
+       if (n2obnd) then
+          call n2okdis(ibn,m,np,k2-1,n2oexp,tn2o,trant)
+       endif
+!-----compute ch4 transmittance using k-distribution method
+       if (ch4bnd) then
+          call ch4kdis(ibn,m,np,k2-1,ch4exp,tch4,trant)
+       endif
+!-----compute co2-minor transmittance using k-distribution method
+       if (combnd) then
+          call comkdis(ibn,m,np,k2-1,comexp,tcom,trant)
+       endif
+!-----compute cfc11 transmittance using k-distribution method
+       if (f11bnd) then
+          call cfckdis(m,np,k2-1,f11exp,tf11,trant)
+       endif
+!-----compute cfc12 transmittance using k-distribution method
+       if (f12bnd) then
+          call cfckdis(m,np,k2-1,f12exp,tf12,trant)
+       endif
+!-----compute cfc22 transmittance using k-distribution method
+       if (f22bnd) then
+          call cfckdis(m,np,k2-1,f22exp,tf22,trant)
+       endif
+!-----compute transmittance in band 10 using k-distribution method.
+!     for band 10, trant is the change in transmittance due to n2o
+!     absorption.
+       if (b10bnd) then
+          call b10kdis(m,np,k2-1,h2oexp,conexp,co2exp,n2oexp &
+                      ,th2o,tcon,tco2,tn2o,trant)
+       endif
+      endif
+!*****   end trace gases  *****
+!-----include aerosol effect
+      do i=1,m
+         tranal(i)=tranal(i)*taerlyr(i,k2-1)
+         trant (i)=trant(i) *tranal(i)
+      enddo
+!***** cloud overlapping *****
+      if (.not. overcast) then
+        call cldovlp (m,np,k2,ict,icb,it,im,ib, &
+                 cldhi,cldmd,cldlw,fcld,tcldlyr,fclr)
+      else
+       do i=1,m
+        fclr(i)=fclr(i)*tcldlyr(i,k2-1)
+       enddo
+      endif
+!-----compute upward and downward fluxes (bands 1-9). it follows
+!     eqs. (8.14) and (8.15). downward fluxes are positive.
+      if (.not. b10bnd) then
+!-----contribution from the "adjacent layer"
+       if (k2 .eq. k1+1) then
+        do i=1,m
+         yy=min(0.999_fp_kind,trant(i))
+         yy=max(0.001_fp_kind,yy)
+!-hmhj use log instead of alog for default intrinsic function
+         xx=(blevel(i,k1)-blevel(i,k2))/ log(yy)
+         bu=(blevel(i,k1)-blevel(i,k2)*yy)/(1.0-yy)+xx
+         bd=(blevel(i,k2)-blevel(i,k1)*yy)/(1.0-yy)-xx
+!                bu=blayer(i,k1)
+!                bd=blayer(i,k1)
+!-----for clear-sky situation
+         flcu(i,k1)=flcu(i,k1)-bu+(bu-blayer(i,k2))*trant(i)
+         flcd(i,k2)=flcd(i,k2)+bd-(bd-blayer(i,k1-1))*trant(i)
+!-----for all-sky situation
+         flxu(i,k1)=flxu(i,k1)-bu+(bu-blayer(i,k2))*trant(i)*fclr(i)
+         flxd(i,k2)=flxd(i,k2)+bd-(bd-blayer(i,k1-1))*trant(i)*fclr(i)
+        enddo
+       else
+!-----contribution from distant layers.
+         do i=1,m
+          xx=trant(i)*dblayr(i,k2)
+          flcu(i,k1) =flcu(i,k1)+xx
+          flxu(i,k1) =flxu(i,k1)+xx*fclr(i)
+          xx=trant(i)*dblayr(i,k1)
+          flcd(i,k2) =flcd(i,k2)+xx
+          flxd(i,k2) =flxd(i,k2)+xx*fclr(i)
+         enddo
+        endif
+       else
+!-----flux reduction due to n2o in band 10 (eqs. 5.1 and 5.2)
+!     trant is the transmittance change due to n2o absorption (eq. 5.3).
+       do i=1,m
+        rflx(i,k1) = rflx(i,k1)+trant(i)*fclr(i)*dblayr(i,k2)
+        rflx(i,k2) = rflx(i,k2)+trant(i)*fclr(i)*dblayr(i,k1)
+        rflc(i,k1) = rflc(i,k1)+trant(i)*dblayr(i,k2)
+        rflc(i,k2) = rflc(i,k2)+trant(i)*dblayr(i,k1)
+       enddo
+      endif
+ 3000 continue
+!-----here, fclr and trant are, respectively, the clear line-of-sight
+!     and the transmittance between k1 and the surface.
+       do i=1,m
+         trantcr(i,k1) =trant(i)
+         transfc(i,k1) =trant(i)*fclr(i)
+       enddo
+!-----compute the partial derivative of fluxes with respect to
+!     surface temperature (eq. 3.12). note: upward flux is negative.
+       do i=1,m
+         dfdts(i,k1) =dfdts(i,k1)-dbs(i)*transfc(i,k1)
+       enddo
+ 2000 continue
+      if (.not. b10bnd) then
+!-----for surface emission.
+!     note: blayer(i,np+1) and dbs include the surface emissivity effect.
+        do i=1,m
+          flcu(i,np+1)=-blayer(i,np+1)
+          flxu(i,np+1)=-blayer(i,np+1)
+          sfcem(i)=sfcem(i)-blayer(i,np+1)
+          dfdts(i,np+1)=dfdts(i,np+1)-dbs(i)
+        enddo
+!-----add the flux reflected by the surface. (last term on the
+!     rhs of eq. 3.10)
+        do k=1,np+1
+         do i=1,m
+           flcu(i,k)=flcu(i,k)- &
+                flcd(i,np+1)*trantcr(i,k)*(1.-emiss(i,ibn))
+           flxu(i,k)=flxu(i,k)- &
+                flxd(i,np+1)*transfc(i,k)*(1.-emiss(i,ibn))
+         enddo
+        enddo
+      endif
+!-----summation of fluxes over spectral bands
+      do k=1,np+1
+       do i=1,m
+         flc(i,k)=flc(i,k)+flcd(i,k)+flcu(i,k)
+         flx(i,k)=flx(i,k)+flxd(i,k)+flxu(i,k)
+         acflxu(i,k)=acflxu(i,k)+flxu(i,k)   ! (LW upward must hold negative values)
+         acflxd(i,k)=acflxd(i,k)+flxd(i,k)   ! (LW downward must hold postive values, and should=0 a
+       enddo
+      enddo
+!-----adjustment due to n2o absorption in band 10. eqs. (5.4) and (5.5)
+       if (b10bnd) then
+        do k=1,np+1
+         do i=1,m
+          flc(i,k)=flc(i,k)+rflc(i,k)
+          flx(i,k)=flx(i,k)+rflx(i,k)
+          if(rflx(i,k).ge.0.0) acflxd(i,k)=acflxd(i,k)+rflx(i,k)
+          if(rflx(i,k).lt.0.0) acflxu(i,k)=acflxu(i,k)+rflx(i,k)
+         enddo
+        enddo
+       endif
+      endif                            ! endif (.not. b10bnd .or. trace)
+ 1000 continue
+
+!ccshie 8/19/04 based on D. Johnson GCSS Workshop
+!      do i=1,m
+!         (i)=acflxd(i,np+1)    ! downward LW surface
+!        rflux(i,5)=acflxu(i,1)       ! upward LW TOA
+!        rflux(i,7)=acflxu(i,np+1)    ! upward LW surface
+!        rflux(i,8)=acflxd(i,1)       ! downward LW TOA
+!      enddo
+
+!xp
+!      deallocate(pa)
+!      deallocate(dt)
+!      deallocate(sh2o)
+!      deallocate(swpre)
+!      deallocate(swtem)
+!      deallocate(sco3)
+!      deallocate(scopre)
+!      deallocate(scotem)
+!      deallocate(dh2o)
+!      deallocate(dcont)
+!      deallocate(dco2)
+!      deallocate(do3)
+!      deallocate(dn2o)
+!      deallocate(dch4)
+!      deallocate(df11)
+!      deallocate(df12)
+!      deallocate(df22)
+!      deallocate(th2o)
+!      deallocate(tcon)
+!      deallocate(tco2)
+!      deallocate(tn2o)
+!      deallocate(tch4)
+!      deallocate(tcom)
+!      deallocate(tf11)
+!      deallocate(tf12)
+!      deallocate(tf22)
+!      deallocate(h2oexp)
+!      deallocate(conexp)
+!      deallocate(co2exp)
+!      deallocate(n2oexp)
+!      deallocate(ch4exp)
+!      deallocate(comexp)
+!      deallocate(f11exp)
+!      deallocate(f12exp)
+!      deallocate(f22exp)
+!      deallocate(blayer)
+!      deallocate(blevel)
+!      deallocate(dblayr)
+!      deallocate(dbs)
+!      deallocate(dp)
+!      deallocate(cwp)
+!      deallocate(trant)
+!      deallocate(tranal)
+!      deallocate(transfc)
+!      deallocate(trantcr)
+!      deallocate(flxu)
+!      deallocate(flxd)
+!      deallocate(flcu)
+!      deallocate(flcd)
+!      deallocate(rflx)
+!      deallocate(rflc)
+!      deallocate(it)
+!      deallocate(im)
+!      deallocate(ib)
+!      deallocate(cldhi)
+!      deallocate(cldmd)
+!      deallocate(cldlw)
+!      deallocate(tcldlyr)
+!      deallocate(fclr)
+!      deallocate(taerlyr)
+    return
+  end subroutine lwrad
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine column (m,np,pa,dt,sabs0,sabs,spre,stem)
+!***********************************************************************
+!-----compute column-integrated (from top of the model atmosphere)
+!     absorber amount (sabs), absorber-weighted pressure (spre) and
+!     temperature (stem).
+!     computations follow eqs. (8.24) - (8.26).
+!
+!--- input parameters
+!   number of soundings (m)
+!   number of atmospheric layers (np)
+!   layer pressure (pa)
+!   layer temperature minus 250k (dt)
+!   layer absorber amount (sabs0)
+!
+!--- output parameters
+!   column-integrated absorber amount (sabs)
+!   column absorber-weighted pressure (spre)
+!   column absorber-weighted temperature (stem)
+!
+!--- units of pa and dt are mb and k, respectively.
+!    units of sabs are g/cm**2 for water vapor and (cm-atm)stp
+!    for co2 and o3
+!***********************************************************************
+      implicit none
+      integer m,np,i,k
+!---- input parameters -----
+      real(Kind=fp_kind) pa(m,np),dt(m,np),sabs0(m,np)
+!---- output parameters -----
+      real(Kind=fp_kind) sabs(m,np+1),spre(m,np+1),stem(m,np+1)
+!*********************************************************************
+        do i=1,m
+          sabs(i,1)=0.0
+          spre(i,1)=0.0
+          stem(i,1)=0.0
+        enddo
+        do k=1,np
+         do i=1,m
+           sabs(i,k+1)=sabs(i,k)+sabs0(i,k)
+           spre(i,k+1)=spre(i,k)+pa(i,k)*sabs0(i,k)
+           stem(i,k+1)=stem(i,k)+dt(i,k)*sabs0(i,k)
+         enddo
+        enddo
+       return
+       end subroutine column
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine h2oexps(ib,m,np,dh2o,pa,dt,xkw,aw,bw,pm,mw,h2oexp)
+!**********************************************************************
+!   compute exponentials for water vapor line absorption
+!   in individual layers using eqs. (8.18) and (8.19).
+!
+!---- input parameters
+!  spectral band (ib)
+!  number of grid intervals (m)
+!  number of layers (np)
+!  layer water vapor amount for line absorption (dh2o)
+!  layer pressure (pa)
+!  layer temperature minus 250k (dt)
+!  absorption coefficients for the first k-distribution
+!     function due to h2o line absorption (xkw)
+!  coefficients for the temperature and pressure scaling (aw,bw,pm)
+!  ratios between neighboring absorption coefficients for
+!     h2o line absorption (mw)
+!
+!---- output parameters
+!  6 exponentials for each layer  (h2oexp)
+!**********************************************************************
+      implicit none
+      integer ib,m,np,i,k,ik
+!---- input parameters ------
+      real(Kind=fp_kind) dh2o(m,np),pa(m,np),dt(m,np)
+!---- output parameters -----
+      real(Kind=fp_kind) h2oexp(m,np,6)
+!---- static data -----
+      integer mw(9)
+      real(Kind=fp_kind) xkw(9),aw(9),bw(9),pm(9)
+!---- temporary arrays -----
+      real(Kind=fp_kind) xh
+!**********************************************************************
+!    note that the 3 sub-bands in band 3 use the same set of xkw, aw,
+!    and bw,  therefore, h2oexp for these sub-bands are identical.
+!**********************************************************************
+        do k=1,np
+         do i=1,m
+!-----xh is the scaled water vapor amount for line absorption
+!     computed from eq. (4.4).
+           xh = dh2o(i,k)*(pa(i,k)/500.)**pm(ib) &
+              * ( 1.+(aw(ib)+bw(ib)* dt(i,k))*dt(i,k) )
+!-----h2oexp is the water vapor transmittance of the layer k
+!     due to line absorption
+           h2oexp(i,k,1) = exp(-xh*xkw(ib))
+         enddo
+        enddo
+!-----compute transmittances from eq. (8.19)
+         if (mw(ib).eq.6) then
+        do ik=2,6
+          do k=1,np
+           do i=1,m
+             xh = h2oexp(i,k,ik-1)*h2oexp(i,k,ik-1)
+               if(xh.lt.1.e-4)xh=0.
+             h2oexp(i,k,ik) = xh*xh*xh
+           enddo
+          enddo
+        enddo
+        elseif (mw(ib).eq.8) then
+        do ik=2,6
+          do k=1,np
+           do i=1,m
+             xh = h2oexp(i,k,ik-1)*h2oexp(i,k,ik-1)
+             if(xh.lt.1.e-3)xh=0.
+             xh = xh*xh
+             h2oexp(i,k,ik) = xh*xh
+           enddo
+          enddo
+        enddo
+        elseif (mw(ib).eq.9) then
+        do ik=2,6
+          do k=1,np
+           do i=1,m
+             xh=h2oexp(i,k,ik-1)*h2oexp(i,k,ik-1)*h2oexp(i,k,ik-1)
+             if(xh.lt.1.e-4)xh=0.
+             h2oexp(i,k,ik) = xh*xh*xh
+           enddo
+          enddo
+        enddo
+        else
+        do ik=2,6
+          do k=1,np
+           do i=1,m
+             xh = h2oexp(i,k,ik-1)*h2oexp(i,k,ik-1)
+             if(xh.lt.2.e-2)xh=0.
+             xh = xh*xh
+             xh = xh*xh
+             h2oexp(i,k,ik) = xh*xh
+           enddo
+          enddo
+        enddo
+        endif
+      return
+      end subroutine h2oexps
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine conexps(ib,m,np,dcont,xke,conexp)
+!**********************************************************************
+!   compute exponentials for continuum absorption in individual layers.
+!
+!---- input parameters
+!  spectral band (ib)
+!  number of grid intervals (m)
+!  number of layers (np)
+!  layer scaled water vapor amount for continuum absorption (dcont)
+!  absorption coefficients for the first k-distribution function
+!     due to water vapor continuum absorption (xke)
+!
+!---- output parameters
+!  1 or 3 exponentials for each layer (conexp)
+!**********************************************************************
+      implicit none
+      integer ib,m,np,i,k
+!---- input parameters ------
+      real(Kind=fp_kind) dcont(m,np)
+!---- updated parameters -----
+      real(Kind=fp_kind) conexp(m,np,3)
+!---- static data -----
+      real(Kind=fp_kind) xke(9)
+!****************************************************************
+        do k=1,np
+         do i=1,m
+           conexp(i,k,1) = exp(-dcont(i,k)*xke(ib))
+         enddo
+        enddo
+       if (ib .eq. 3) then
+!-----the absorption coefficients for sub-bands 3b and 3a are, respectively,
+!     two and four times the absorption coefficient for sub-band 3c (table 9).
+!     note that conexp(i,k,3) is for sub-band 3a.
+         do k=1,np
+          do i=1,m
+            conexp(i,k,2) = conexp(i,k,1) *conexp(i,k,1)
+            conexp(i,k,3) = conexp(i,k,2) *conexp(i,k,2)
+          enddo
+         enddo
+       endif
+      return
+      end subroutine conexps
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine co2exps(m,np,dco2,pa,dt,co2exp)
+!**********************************************************************
+!   compute co2 exponentials for individual layers.
+!
+!---- input parameters
+!  number of grid intervals (m)
+!  number of layers (np)
+!  layer co2 amount (dco2)
+!  layer pressure (pa)
+!  layer temperature minus 250k (dt)
+!
+!---- output parameters
+!  6 exponentials for each layer (co2exp)
+!**********************************************************************
+      implicit none
+      integer m,np,i,k
+!---- input parameters -----
+      real(Kind=fp_kind) dco2(m,np),pa(m,np),dt(m,np)
+!---- output parameters -----
+      real(Kind=fp_kind) co2exp(m,np,6,2)
+!---- temporary arrays -----
+      real(Kind=fp_kind) xc
+!**********************************************************************
+        do k=1,np
+         do i=1,m
+!-----the scakubg oaraneters are given in table 3, and values of
+!     the absorption coefficient are given in table 10.
+!     scaled co2 amount for band-wings (sub-bands 3a and 3c)
+           xc = dco2(i,k)*(pa(i,k)/300.0)**0.5 &
+                   *(1.+(0.0182+1.07e-4*dt(i,k))*dt(i,k))
+!-----six exponentials by powers of 8 (see eqs. 8.18, 8.19 and table 10).
+           co2exp(i,k,1,1)=exp(-xc*2.656e-5)
+           xc=co2exp(i,k,1,1)*co2exp(i,k,1,1)
+           xc=xc*xc
+           co2exp(i,k,2,1)=xc*xc
+           xc=co2exp(i,k,2,1)*co2exp(i,k,2,1)
+           xc=xc*xc
+           co2exp(i,k,3,1)=xc*xc
+           xc=co2exp(i,k,3,1)*co2exp(i,k,3,1)
+           xc=xc*xc
+           co2exp(i,k,4,1)=xc*xc
+           xc=co2exp(i,k,4,1)*co2exp(i,k,4,1)
+           xc=xc*xc
+           co2exp(i,k,5,1)=xc*xc
+           xc=co2exp(i,k,5,1)*co2exp(i,k,5,1)
+           xc=xc*xc
+           co2exp(i,k,6,1)=xc*xc
+!-----for band-center region (sub-band 3b)
+           xc = dco2(i,k)*(pa(i,k)/30.0)**0.85 &
+                   *(1.+(0.0042+2.00e-5*dt(i,k))*dt(i,k))
+           co2exp(i,k,1,2)=exp(-xc*2.656e-3)
+           xc=co2exp(i,k,1,2)*co2exp(i,k,1,2)
+           xc=xc*xc
+           co2exp(i,k,2,2)=xc*xc
+           xc=co2exp(i,k,2,2)*co2exp(i,k,2,2)
+           xc=xc*xc
+           co2exp(i,k,3,2)=xc*xc
+           xc=co2exp(i,k,3,2)*co2exp(i,k,3,2)
+           xc=xc*xc
+           co2exp(i,k,4,2)=xc*xc
+           xc=co2exp(i,k,4,2)*co2exp(i,k,4,2)
+           xc=xc*xc
+           co2exp(i,k,5,2)=xc*xc
+           xc=co2exp(i,k,5,2)*co2exp(i,k,5,2)
+           xc=xc*xc
+           co2exp(i,k,6,2)=xc*xc
+         enddo
+        enddo
+      return
+      end subroutine co2exps
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine n2oexps(ib,m,np,dn2o,pa,dt,n2oexp)
+!**********************************************************************
+!   compute n2o exponentials for individual layers
+!
+!---- input parameters
+!  spectral band (ib)
+!  number of grid intervals (m)
+!  number of layers (np)
+!  layer n2o amount (dn2o)
+!  layer pressure (pa)
+!  layer temperature minus 250k (dt)
+!
+!---- output parameters
+!  2 or 4 exponentials for each layer (n2oexp)
+!**********************************************************************
+      implicit none
+      integer ib,m,np,i,k
+
+!---- input parameters -----
+
+      real(Kind=fp_kind) dn2o(m,np),pa(m,np),dt(m,np)
+
+!---- output parameters -----
+
+      real(Kind=fp_kind) n2oexp(m,np,4)
+
+!---- temporary arrays -----
+
+      real(Kind=fp_kind) xc,xc1,xc2
+
+!-----scaling and absorpton data are given in table 5.
+!     transmittances are computed using eqs. (8.18) and (8.19).
+
+       do k=1,np
+        do i=1,m
+
+!-----four exponential by powers of 21 for band 6.
+
+          if (ib.eq.6) then
+
+           xc=dn2o(i,k)*(1.+(1.9297e-3+4.3750e-6*dt(i,k))*dt(i,k))
+           n2oexp(i,k,1)=exp(-xc*6.31582e-2)
+
+           xc=n2oexp(i,k,1)*n2oexp(i,k,1)*n2oexp(i,k,1)
+           xc1=xc*xc
+           xc2=xc1*xc1
+           n2oexp(i,k,2)=xc*xc1*xc2
+
+!-----four exponential by powers of 8 for band 7
+
+          else
+
+           xc=dn2o(i,k)*(pa(i,k)/500.0)**0.48 &
+              *(1.+(1.3804e-3+7.4838e-6*dt(i,k))*dt(i,k))
+           n2oexp(i,k,1)=exp(-xc*5.35779e-2)
+
+           xc=n2oexp(i,k,1)*n2oexp(i,k,1)
+           xc=xc*xc
+           n2oexp(i,k,2)=xc*xc
+           xc=n2oexp(i,k,2)*n2oexp(i,k,2)
+           xc=xc*xc
+           n2oexp(i,k,3)=xc*xc
+           xc=n2oexp(i,k,3)*n2oexp(i,k,3)
+           xc=xc*xc
+           n2oexp(i,k,4)=xc*xc
+
+          endif
+
+        enddo
+       enddo
+
+      return
+      end subroutine n2oexps
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine ch4exps(ib,m,np,dch4,pa,dt,ch4exp)
+!**********************************************************************
+!   compute ch4 exponentials for individual layers
+!
+!---- input parameters
+!  spectral band (ib)
+!  number of grid intervals (m)
+!  number of layers (np)
+!  layer ch4 amount (dch4)
+!  layer pressure (pa)
+!  layer temperature minus 250k (dt)
+!
+!---- output parameters
+!  1 or 4 exponentials for each layer (ch4exp)
+!**********************************************************************
+      implicit none
+      integer ib,m,np,i,k
+!---- input parameters -----
+      real(Kind=fp_kind) dch4(m,np),pa(m,np),dt(m,np)
+!---- output parameters -----
+      real(Kind=fp_kind) ch4exp(m,np,4)
+!---- temporary arrays -----
+      real(Kind=fp_kind) xc
+!*****  scaling and absorpton data are given in table 5  *****
+       do k=1,np
+        do i=1,m
+!-----four exponentials for band 6
+          if (ib.eq.6) then
+           xc=dch4(i,k)*(1.+(1.7007e-2+1.5826e-4*dt(i,k))*dt(i,k))
+           ch4exp(i,k,1)=exp(-xc*5.80708e-3)
+!-----four exponentials by powers of 12 for band 7
+          else
+           xc=dch4(i,k)*(pa(i,k)/500.0)**0.65 &
+             *(1.+(5.9590e-4-2.2931e-6*dt(i,k))*dt(i,k))
+           ch4exp(i,k,1)=exp(-xc*6.29247e-2)
+           xc=ch4exp(i,k,1)*ch4exp(i,k,1)*ch4exp(i,k,1)
+           xc=xc*xc
+           ch4exp(i,k,2)=xc*xc
+           xc=ch4exp(i,k,2)*ch4exp(i,k,2)*ch4exp(i,k,2)
+           xc=xc*xc
+           ch4exp(i,k,3)=xc*xc
+           xc=ch4exp(i,k,3)*ch4exp(i,k,3)*ch4exp(i,k,3)
+           xc=xc*xc
+           ch4exp(i,k,4)=xc*xc
+          endif
+        enddo
+       enddo
+      return
+      end subroutine ch4exps
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine comexps(ib,m,np,dcom,dt,comexp)
+!**********************************************************************
+!   compute co2-minor exponentials for individual layers using
+!   eqs. (8.18) and (8.19).
+!
+!---- input parameters
+!  spectral band (ib)
+!  number of grid intervals (m)
+!  number of layers (np)
+!  layer co2 amount (dcom)
+!  layer temperature minus 250k (dt)
+!
+!---- output parameters
+!  6 exponentials for each layer (comexp)
+!**********************************************************************
+      implicit none
+      integer ib,m,np,i,k,ik
+!---- input parameters -----
+      real(Kind=fp_kind) dcom(m,np),dt(m,np)
+!---- output parameters -----
+      real(Kind=fp_kind) comexp(m,np,6)
+!---- temporary arrays -----
+      real(Kind=fp_kind) xc
+!*****  scaling and absorpton data are given in table 6  *****
+       do k=1,np
+        do i=1,m
+          if (ib.eq.4) then
+           xc=dcom(i,k)*(1.+(3.5775e-2+4.0447e-4*dt(i,k))*dt(i,k))
+          endif
+          if (ib.eq.5) then
+           xc=dcom(i,k)*(1.+(3.4268e-2+3.7401e-4*dt(i,k))*dt(i,k))
+          endif
+           comexp(i,k,1)=exp(-xc*1.922e-7)
+          do ik=2,6
+           xc=comexp(i,k,ik-1)*comexp(i,k,ik-1)
+           xc=xc*xc
+           comexp(i,k,ik)=xc*comexp(i,k,ik-1)
+          enddo
+        enddo
+       enddo
+      return
+      end subroutine comexps
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine cfcexps(ib,m,np,a1,b1,fk1,a2,b2,fk2,dcfc,dt,cfcexp)
+!**********************************************************************
+!   compute cfc(-11, -12, -22) exponentials for individual layers.
+!
+!---- input parameters
+!  spectral band (ib)
+!  number of grid intervals (m)
+!  number of layers (np)
+!  parameters for computing the scaled cfc amounts
+!             for temperature scaling (a1,b1,a2,b2)
+!  the absorption coefficients for the
+!     first k-distribution function due to cfcs (fk1,fk2)
+!  layer cfc amounts (dcfc)
+!  layer temperature minus 250k (dt)
+!
+!---- output parameters
+!  1 exponential for each layer (cfcexp)
+!**********************************************************************
+      implicit none
+      integer ib,m,np,i,k
+!---- input parameters -----
+      real(Kind=fp_kind) dcfc(m,np),dt(m,np)
+!---- output parameters -----
+      real(Kind=fp_kind) cfcexp(m,np)
+!---- static data -----
+      real(Kind=fp_kind) a1,b1,fk1,a2,b2,fk2
+!---- temporary arrays -----
+      real(Kind=fp_kind) xf
+!**********************************************************************
+       do k=1,np
+        do i=1,m
+!-----compute the scaled cfc amount (xf) and exponential (cfcexp)
+          if (ib.eq.4) then
+           xf=dcfc(i,k)*(1.+(a1+b1*dt(i,k))*dt(i,k))
+           cfcexp(i,k)=exp(-xf*fk1)
+          else
+           xf=dcfc(i,k)*(1.+(a2+b2*dt(i,k))*dt(i,k))
+           cfcexp(i,k)=exp(-xf*fk2)
+          endif
+        enddo
+       enddo
+      return
+      end subroutine cfcexps
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine b10exps(m,np,dh2o,dcont,dco2,dn2o,pa,dt &
+                ,h2oexp,conexp,co2exp,n2oexp)
+!**********************************************************************
+!   compute band3a exponentials for individual layers
+!
+!---- input parameters
+!  number of grid intervals (m)
+!  number of layers (np)
+!  layer h2o amount for line absorption (dh2o)
+!  layer h2o amount for continuum absorption (dcont)
+!  layer co2 amount (dco2)
+!  layer n2o amount (dn2o)
+!  layer pressure (pa)
+!  layer temperature minus 250k (dt)
+!
+!---- output parameters
+!
+!  exponentials for each layer (h2oexp,conexp,co2exp,n2oexp)
+!**********************************************************************
+      implicit none
+      integer m,np,i,k
+!---- input parameters -----
+      real(Kind=fp_kind) dh2o(m,np),dcont(m,np),dn2o(m,np)
+      real(Kind=fp_kind) dco2(m,np),pa(m,np),dt(m,np)
+!---- output parameters -----
+      real(Kind=fp_kind) h2oexp(m,np,6),conexp(m,np,3),co2exp(m,np,6,2) &
+          ,n2oexp(m,np,4)
+!---- temporary arrays -----
+      real(Kind=fp_kind) xx,xx1,xx2,xx3
+!**********************************************************************
+        do k=1,np
+         do i=1,m
+!-----compute scaled h2o-line amount for band 10 (eq. 4.4 and table 3).
+           xx=dh2o(i,k)*(pa(i,k)/500.0) &
+                 *(1.+(0.0149+6.20e-5*dt(i,k))*dt(i,k))
+!-----six exponentials by powers of 8
+!     the constant 0.10624 is equal to 1.66*0.064
+           h2oexp(i,k,1)=exp(-xx*0.10624)
+           xx=h2oexp(i,k,1)*h2oexp(i,k,1)
+           xx=xx*xx
+           h2oexp(i,k,2)=xx*xx
+           xx=h2oexp(i,k,2)*h2oexp(i,k,2)
+           xx=xx*xx
+           h2oexp(i,k,3)=xx*xx
+           xx=h2oexp(i,k,3)*h2oexp(i,k,3)
+           xx=xx*xx
+           h2oexp(i,k,4)=xx*xx
+           xx=h2oexp(i,k,4)*h2oexp(i,k,4)
+           xx=xx*xx
+           h2oexp(i,k,5)=xx*xx
+           xx=h2oexp(i,k,5)*h2oexp(i,k,5)
+           xx=xx*xx
+!          h2oexp(i,k,6)=xx*xx
+!-----compute scaled co2 amount for the band 10 (eq. 4.4 and table 6).
+           xx=dco2(i,k)*(pa(i,k)/300.0)**0.5 &
+                 *(1.+(0.0179+1.02e-4*dt(i,k))*dt(i,k))
+!-----six exponentials by powers of 8
+!     the constant 2.656e-5 is equal to 1.66*1.60e-5
+           co2exp(i,k,1,1)=exp(-xx*2.656e-5)
+           xx=co2exp(i,k,1,1)*co2exp(i,k,1,1)
+           xx=xx*xx
+           co2exp(i,k,2,1)=xx*xx
+           xx=co2exp(i,k,2,1)*co2exp(i,k,2,1)
+           xx=xx*xx
+           co2exp(i,k,3,1)=xx*xx
+           xx=co2exp(i,k,3,1)*co2exp(i,k,3,1)
+           xx=xx*xx
+           co2exp(i,k,4,1)=xx*xx
+           xx=co2exp(i,k,4,1)*co2exp(i,k,4,1)
+           xx=xx*xx
+           co2exp(i,k,5,1)=xx*xx
+           xx=co2exp(i,k,5,1)*co2exp(i,k,5,1)
+           xx=xx*xx
+           co2exp(i,k,6,1)=xx*xx
+!-----one exponential of h2o continuum for sub-band 3a (table 9).
+            conexp(i,k,1)=exp(-dcont(i,k)*1.04995e+2)
+!-----compute the scaled n2o amount for band 10 (table 5).
+           xx=dn2o(i,k)*(1.+(1.4476e-3+3.6656e-6*dt(i,k))*dt(i,k))
+!-----two exponentials by powers of 58
+           n2oexp(i,k,1)=exp(-xx*0.25238)
+           xx=n2oexp(i,k,1)*n2oexp(i,k,1)
+           xx1=xx*xx
+           xx1=xx1*xx1
+           xx2=xx1*xx1
+           xx3=xx2*xx2
+           n2oexp(i,k,2)=xx*xx1*xx2*xx3
+         enddo
+        enddo
+      return
+      end subroutine b10exps
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine tablup(k1,k2,m,np,nx,nh,sabs,spre,stem,w1,p1, &
+                        dwe,dpe,coef1,coef2,coef3,tran)
+!**********************************************************************
+!   compute water vapor, co2 and o3 transmittances between level
+!   k1 and and level k2 for m soundings, using table look-up.
+!
+!   calculations follow eq. (4.16).
+!
+!---- input ---------------------
+!  indices for layer (k1) and level (k2)
+!  number of grid intervals (m)
+!  number of atmospheric layers (np)
+!  number of pressure intervals in the table (nx)
+!  number of absorber amount intervals in the table (nh)
+!  column-integrated absorber amount (sabs)
+!  column absorber amount-weighted pressure (spre)
+!  column absorber amount-weighted temperature (stem)
+!  first value of absorber amount (log10) in the table (w1)
+!  first value of pressure (log10) in the table (p1)
+!  size of the interval of absorber amount (log10) in the table (dwe)
+!  size of the interval of pressure (log10) in the table (dpe)
+!  pre-computed coefficients (coef1, coef2, and coef3)
+!
+!---- updated ---------------------
+!  transmittance (tran)
+!
+!  note:
+!   (1) units of sabs are g/cm**2 for water vapor and
+!       (cm-atm)stp for co2 and o3.
+!   (2) units of spre and stem are, respectively, mb and k.
+!
+!**********************************************************************
+      implicit none
+      integer k1,k2,m,np,nx,nh,i
+!---- input parameters -----
+      real(Kind=fp_kind) w1,p1,dwe,dpe
+      real(Kind=fp_kind) sabs(m,np+1),spre(m,np+1),stem(m,np+1)
+      real(Kind=fp_kind) coef1(nx,nh),coef2(nx,nh),coef3(nx,nh)
+!---- update parameter -----
+      real(Kind=fp_kind) tran(m)
+!---- temporary variables -----
+      real(Kind=fp_kind) x1,x2,x3,we,pe,fw,fp,pa,pb,pc,ax,ba,bb,t1,ca,cb,t2,xxx
+      integer iw,ip
+!**********************************************************************
+      do i=1,m
+        x1=sabs(i,k2)-sabs(i,k1)
+        we=(log10(x1)-w1)/dwe
+       if (we .ge. (w1-2.)) then
+        x2=(spre(i,k2)-spre(i,k1))/x1
+        x3=(stem(i,k2)-stem(i,k1))/x1
+!-----normalize we and pe
+        pe=(log10(x2)-p1)/dpe
+!-----restrict the magnitudes of the normalized we and pe.
+!        we=min(we,real(nh-1))
+        xxx=real(nh-1)
+        we=min(we,xxx)
+        pe=max(pe,0.0_fp_kind)
+!        pe=min(pe,real(nx-1))
+        xxx=real(nx-1)
+        pe=min(pe,xxx)
+!-----assign iw and ip and compute the distance of we and pe
+!     from iw and ip.
+        iw=int(we+1.0)
+        iw=min(iw,nh-1)
+        iw=max(iw, 2)
+        fw=we-float(iw-1)
+        ip=int(pe+1.0)
+        ip=min(ip,nx-1)
+        ip=max(ip, 1)
+        fp=pe-float(ip-1)
+!-----linear interpolation in pressure
+        pa = coef1(ip,iw-1)*(1.-fp)+coef1(ip+1,iw-1)*fp
+        pb = coef1(ip,  iw)*(1.-fp)+coef1(ip+1,  iw)*fp
+        pc = coef1(ip,iw+1)*(1.-fp)+coef1(ip+1,iw+1)*fp
+!-----quadratic interpolation in absorber amount for coef1
+        ax = (-pa*(1.-fw)+pc*(1.+fw)) *fw*0.5 + pb*(1.-fw*fw)
+!-----linear interpolation in absorber amount for coef2 and coef3
+        ba = coef2(ip,  iw)*(1.-fp)+coef2(ip+1,  iw)*fp
+        bb = coef2(ip,iw+1)*(1.-fp)+coef2(ip+1,iw+1)*fp
+        t1 = ba*(1.-fw) + bb*fw
+        ca = coef3(ip,  iw)*(1.-fp)+coef3(ip+1,  iw)*fp
+        cb = coef3(ip,iw+1)*(1.-fp)+coef3(ip+1,iw+1)*fp
+        t2 = ca*(1.-fw) + cb*fw
+!-----update the total transmittance between levels k1 and k2
+        tran(i)= (ax + (t1+t2*x3) * x3)*tran(i)
+        tran(i)=min(tran(i),0.9999999_fp_kind)
+        tran(i)=max(tran(i),0.0000001_fp_kind)
+       else
+        tran(i)=0.9999999
+       endif
+      enddo
+      return
+      end subroutine tablup
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine h2okdis(ib,m,np,k,fkw,gkw,ne,h2oexp,conexp, &
+                         th2o,tcon,tran)
+!**********************************************************************
+!   compute water vapor transmittance between levels k1 and k2 for
+!   m soundings, using the k-distribution method.
+!
+!---- input parameters
+!  spectral band (ib)
+!  number of grid intervals (m)
+!  number of levels (np)
+!  current level (k)
+!  planck-weighted k-distribution function due to
+!    h2o line absorption (fkw)
+!  planck-weighted k-distribution function due to
+!    h2o continuum absorption (gkw)
+!  number of terms used in each band to compute water vapor
+!     continuum transmittance (ne)
+!  exponentials for line absorption (h2oexp)
+!  exponentials for continuum absorption (conexp)
+!
+!---- updated parameters
+!  transmittance between levels k1 and k2 due to
+!    water vapor line absorption (th2o)
+!  transmittance between levels k1 and k2 due to
+!    water vapor continuum absorption (tcon)
+!  total transmittance (tran)
+!
+!**********************************************************************
+      implicit none
+      integer ib,m,np,i,k
+!---- input parameters ------
+      real(Kind=fp_kind) conexp(m,np,3),h2oexp(m,np,6)
+      integer ne(9)
+      real(Kind=fp_kind)  fkw(6,9),gkw(6,3)
+!---- updated parameters -----
+      real(Kind=fp_kind) th2o(m,6),tcon(m,3),tran(m)
+!---- temporary arrays -----
+      real(Kind=fp_kind) trnth2o
+!-----tco2 are the six exp factors between levels k1 and k2
+!     tran is the updated total transmittance between levels k1 and k2
+!-----th2o is the 6 exp factors between levels k1 and k2 due to
+!     h2o line absorption.
+!-----tcon is the 3 exp factors between levels k1 and k2 due to
+!     h2o continuum absorption.
+!-----trnth2o is the total transmittance between levels k1 and k2 due
+!     to both line and continuum absorption.
+!-----comoute th2o following eq. (8.20).
+         do i=1,m
+           th2o(i,1) = th2o(i,1)*h2oexp(i,k,1)
+           th2o(i,2) = th2o(i,2)*h2oexp(i,k,2)
+           th2o(i,3) = th2o(i,3)*h2oexp(i,k,3)
+           th2o(i,4) = th2o(i,4)*h2oexp(i,k,4)
+           th2o(i,5) = th2o(i,5)*h2oexp(i,k,5)
+           th2o(i,6) = th2o(i,6)*h2oexp(i,k,6)
+         enddo
+      if (ne(ib).eq.0) then
+!-----comoute trnh2o following eq. (8.22). fkw is given in table 4.
+         do i=1,m
+           trnth2o      =(fkw(1,ib)*th2o(i,1) &
+                        + fkw(2,ib)*th2o(i,2) &
+                        + fkw(3,ib)*th2o(i,3) &
+                        + fkw(4,ib)*th2o(i,4) &
+                        + fkw(5,ib)*th2o(i,5) &
+                        + fkw(6,ib)*th2o(i,6))
+          tran(i)=tran(i)*trnth2o
+         enddo
+      elseif (ne(ib).eq.1) then
+!-----comoute trnh2o following eq. (8.22) and (4.27).
+         do i=1,m
+           tcon(i,1)= tcon(i,1)*conexp(i,k,1)
+           trnth2o      =(fkw(1,ib)*th2o(i,1) &
+                        + fkw(2,ib)*th2o(i,2) &
+                        + fkw(3,ib)*th2o(i,3) &
+                        + fkw(4,ib)*th2o(i,4) &
+                        + fkw(5,ib)*th2o(i,5) &
+                        + fkw(6,ib)*th2o(i,6))*tcon(i,1)
+          tran(i)=tran(i)*trnth2o
+         enddo
+      else
+!-----for band 3. this band is divided into 3 subbands.
+         do i=1,m
+           tcon(i,1)= tcon(i,1)*conexp(i,k,1)
+           tcon(i,2)= tcon(i,2)*conexp(i,k,2)
+           tcon(i,3)= tcon(i,3)*conexp(i,k,3)
+!-----comoute trnh2o following eq. (4.29).
+           trnth2o      = (  gkw(1,1)*th2o(i,1) &
+                           + gkw(2,1)*th2o(i,2) &
+                           + gkw(3,1)*th2o(i,3) &
+                           + gkw(4,1)*th2o(i,4) &
+                           + gkw(5,1)*th2o(i,5) &
+                           + gkw(6,1)*th2o(i,6) ) * tcon(i,1) &
+                        + (  gkw(1,2)*th2o(i,1) &
+                           + gkw(2,2)*th2o(i,2) &
+                           + gkw(3,2)*th2o(i,3) &
+                           + gkw(4,2)*th2o(i,4) &
+                           + gkw(5,2)*th2o(i,5) &
+                           + gkw(6,2)*th2o(i,6) ) * tcon(i,2) &
+                        + (  gkw(1,3)*th2o(i,1) &
+                           + gkw(2,3)*th2o(i,2) &
+                           + gkw(3,3)*th2o(i,3) &
+                           + gkw(4,3)*th2o(i,4) &
+                           + gkw(5,3)*th2o(i,5) &
+                           + gkw(6,3)*th2o(i,6) ) * tcon(i,3)
+          tran(i)=tran(i)*trnth2o
+         enddo
+      endif
+      return
+      end subroutine h2okdis
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine co2kdis(m,np,k,co2exp,tco2,tran)
+!**********************************************************************
+!   compute co2 transmittances between levels k1 and k2 for
+!    m soundings, using the k-distribution method with linear
+!    pressure scaling.
+!
+!---- input parameters
+!   number of grid intervals (m)
+!   number of levels (np)
+!   current level (k)
+!   exponentials for co2 absorption (co2exp)
+!
+!---- updated parameters
+!   transmittance between levels k1 and k2 due to co2 absorption
+!     for the various values of the absorption coefficient (tco2)
+!   total transmittance (tran)
+!
+!**********************************************************************
+      implicit none
+      integer m,np,i,k
+!---- input parameters -----
+      real(Kind=fp_kind) co2exp(m,np,6,2)
+!---- updated parameters -----
+      real(Kind=fp_kind) tco2(m,6,2),tran(m)
+!---- temporary arrays -----
+      real(Kind=fp_kind) xc
+!-----tco2 is the 6 exp factors between levels k1 and k2.
+!     xc is the total co2 transmittance given by eq. (4.30).
+!     the k-distribution functions are given in table 10.
+         do i=1,m
+!-----band-wings
+           tco2(i,1,1)=tco2(i,1,1)*co2exp(i,k,1,1)
+           xc=   0.1395 *tco2(i,1,1)
+           tco2(i,2,1)=tco2(i,2,1)*co2exp(i,k,2,1)
+           xc=xc+0.1407 *tco2(i,2,1)
+           tco2(i,3,1)=tco2(i,3,1)*co2exp(i,k,3,1)
+           xc=xc+0.1549 *tco2(i,3,1)
+           tco2(i,4,1)=tco2(i,4,1)*co2exp(i,k,4,1)
+           xc=xc+0.1357 *tco2(i,4,1)
+           tco2(i,5,1)=tco2(i,5,1)*co2exp(i,k,5,1)
+           xc=xc+0.0182 *tco2(i,5,1)
+           tco2(i,6,1)=tco2(i,6,1)*co2exp(i,k,6,1)
+           xc=xc+0.0220 *tco2(i,6,1)
+!-----band-center region
+           tco2(i,1,2)=tco2(i,1,2)*co2exp(i,k,1,2)
+           xc=xc+0.0766 *tco2(i,1,2)
+           tco2(i,2,2)=tco2(i,2,2)*co2exp(i,k,2,2)
+           xc=xc+0.1372 *tco2(i,2,2)
+           tco2(i,3,2)=tco2(i,3,2)*co2exp(i,k,3,2)
+           xc=xc+0.1189 *tco2(i,3,2)
+           tco2(i,4,2)=tco2(i,4,2)*co2exp(i,k,4,2)
+           xc=xc+0.0335 *tco2(i,4,2)
+           tco2(i,5,2)=tco2(i,5,2)*co2exp(i,k,5,2)
+           xc=xc+0.0169 *tco2(i,5,2)
+           tco2(i,6,2)=tco2(i,6,2)*co2exp(i,k,6,2)
+           xc=xc+0.0059 *tco2(i,6,2)
+           tran(i)=tran(i)*xc
+         enddo
+      return
+      end subroutine co2kdis
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine n2okdis(ib,m,np,k,n2oexp,tn2o,tran)
+!**********************************************************************
+!   compute n2o transmittances between levels k1 and k2 for
+!    m soundings, using the k-distribution method with linear
+!    pressure scaling.
+!
+!---- input parameters
+!   spectral band (ib)
+!   number of grid intervals (m)
+!   number of levels (np)
+!   current level (k)
+!   exponentials for n2o absorption (n2oexp)
+!
+!---- updated parameters
+!   transmittance between levels k1 and k2 due to n2o absorption
+!     for the various values of the absorption coefficient (tn2o)
+!   total transmittance (tran)
+!
+!**********************************************************************
+      implicit none
+      integer ib,m,np,i,k
+!---- input parameters -----
+      real(Kind=fp_kind) n2oexp(m,np,4)
+!---- updated parameters -----
+      real(Kind=fp_kind) tn2o(m,4),tran(m)
+!---- temporary arrays -----
+      real(Kind=fp_kind) xc
+!-----tn2o is computed from eq. (8.20).
+!     xc is the total n2o transmittance computed from (8.22)
+!     the k-distribution functions are given in table 5.
+        do i=1,m
+!-----band 6
+          if (ib.eq.6) then
+           tn2o(i,1)=tn2o(i,1)*n2oexp(i,k,1)
+           xc=   0.940414*tn2o(i,1)
+           tn2o(i,2)=tn2o(i,2)*n2oexp(i,k,2)
+           xc=xc+0.059586*tn2o(i,2)
+!-----band 7
+          else
+           tn2o(i,1)=tn2o(i,1)*n2oexp(i,k,1)
+           xc=   0.561961*tn2o(i,1)
+           tn2o(i,2)=tn2o(i,2)*n2oexp(i,k,2)
+           xc=xc+0.138707*tn2o(i,2)
+           tn2o(i,3)=tn2o(i,3)*n2oexp(i,k,3)
+           xc=xc+0.240670*tn2o(i,3)
+           tn2o(i,4)=tn2o(i,4)*n2oexp(i,k,4)
+           xc=xc+0.058662*tn2o(i,4)
+          endif
+           tran(i)=tran(i)*xc
+        enddo
+      return
+      end subroutine n2okdis
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine ch4kdis(ib,m,np,k,ch4exp,tch4,tran)
+!**********************************************************************
+!   compute ch4 transmittances between levels k1 and k2 for
+!    m soundings, using the k-distribution method with
+!    linear pressure scaling.
+!
+!---- input parameters
+!   spectral band (ib)
+!   number of grid intervals (m)
+!   number of levels (np)
+!   current level (k)
+!   exponentials for ch4 absorption (ch4exp)
+!
+!---- updated parameters
+!   transmittance between levels k1 and k2 due to ch4 absorption
+!     for the various values of the absorption coefficient (tch4)
+!   total transmittance (tran)
+!
+!**********************************************************************
+      implicit none
+      integer ib,m,np,i,k
+!---- input parameters -----
+      real(Kind=fp_kind) ch4exp(m,np,4)
+!---- updated parameters -----
+      real(Kind=fp_kind) tch4(m,4),tran(m)
+!---- temporary arrays -----
+      real(Kind=fp_kind) xc
+!-----tch4 is computed from eq. (8.20).
+!     xc is the total ch4 transmittance computed from (8.22)
+!     the k-distribution functions are given in table 5.
+        do i=1,m
+!-----band 6
+          if (ib.eq.6) then
+           tch4(i,1)=tch4(i,1)*ch4exp(i,k,1)
+           xc= tch4(i,1)
+!-----band 7
+          else
+           tch4(i,1)=tch4(i,1)*ch4exp(i,k,1)
+           xc=   0.610650*tch4(i,1)
+           tch4(i,2)=tch4(i,2)*ch4exp(i,k,2)
+           xc=xc+0.280212*tch4(i,2)
+           tch4(i,3)=tch4(i,3)*ch4exp(i,k,3)
+           xc=xc+0.107349*tch4(i,3)
+           tch4(i,4)=tch4(i,4)*ch4exp(i,k,4)
+           xc=xc+0.001789*tch4(i,4)
+          endif
+           tran(i)=tran(i)*xc
+        enddo
+      return
+      end subroutine ch4kdis
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine comkdis(ib,m,np,k,comexp,tcom,tran)
+!**********************************************************************
+!  compute co2-minor transmittances between levels k1 and k2
+!   for m soundings, using the k-distribution method
+!   with linear pressure scaling.
+!
+!---- input parameters
+!   spectral band (ib)
+!   number of grid intervals (m)
+!   number of levels (np)
+!   current level (k)
+!   exponentials for co2-minor absorption (comexp)
+!
+!---- updated parameters
+!   transmittance between levels k1 and k2 due to co2-minor absorption
+!     for the various values of the absorption coefficient (tcom)
+!   total transmittance (tran)
+!
+!**********************************************************************
+      implicit none
+      integer ib,m,np,i,k
+!---- input parameters -----
+      real(Kind=fp_kind) comexp(m,np,6)
+!---- updated parameters -----
+      real(Kind=fp_kind) tcom(m,6),tran(m)
+!---- temporary arrays -----
+      real(Kind=fp_kind) xc
+!-----tcom is computed from eq. (8.20).
+!     xc is the total co2 transmittance computed from (8.22)
+!     the k-distribution functions are given in table 6.
+         do i=1,m
+!-----band 4
+           if (ib.eq.4) then
+            tcom(i,1)=tcom(i,1)*comexp(i,k,1)
+            xc=   0.12159*tcom(i,1)
+            tcom(i,2)=tcom(i,2)*comexp(i,k,2)
+            xc=xc+0.24359*tcom(i,2)
+            tcom(i,3)=tcom(i,3)*comexp(i,k,3)
+            xc=xc+0.24981*tcom(i,3)
+            tcom(i,4)=tcom(i,4)*comexp(i,k,4)
+            xc=xc+0.26427*tcom(i,4)
+            tcom(i,5)=tcom(i,5)*comexp(i,k,5)
+            xc=xc+0.07807*tcom(i,5)
+            tcom(i,6)=tcom(i,6)*comexp(i,k,6)
+            xc=xc+0.04267*tcom(i,6)
+!-----band 5
+           else
+            tcom(i,1)=tcom(i,1)*comexp(i,k,1)
+            xc=   0.06869*tcom(i,1)
+            tcom(i,2)=tcom(i,2)*comexp(i,k,2)
+            xc=xc+0.14795*tcom(i,2)
+            tcom(i,3)=tcom(i,3)*comexp(i,k,3)
+            xc=xc+   0.19512*tcom(i,3)
+            tcom(i,4)=tcom(i,4)*comexp(i,k,4)
+            xc=xc+   0.33446*tcom(i,4)
+            tcom(i,5)=tcom(i,5)*comexp(i,k,5)
+            xc=xc+   0.17199*tcom(i,5)
+            tcom(i,6)=tcom(i,6)*comexp(i,k,6)
+            xc=xc+   0.08179*tcom(i,6)
+           endif
+            tran(i)=tran(i)*xc
+         enddo
+      return
+      end subroutine comkdis
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine cfckdis(m,np,k,cfcexp,tcfc,tran)
+!**********************************************************************
+!  compute cfc-(11,12,22) transmittances between levels k1 and k2
+!   for m soundings, using the k-distribution method with
+!   linear pressure scaling.
+!
+!---- input parameters
+!   number of grid intervals (m)
+!   number of levels (np)
+!   current level (k)
+!   exponentials for cfc absorption (cfcexp)
+!
+!---- updated parameters
+!   transmittance between levels k1 and k2 due to cfc absorption
+!     for the various values of the absorption coefficient (tcfc)
+!   total transmittance (tran)
+!
+!**********************************************************************
+      implicit none
+      integer m,np,i,k
+!---- input parameters -----
+      real(Kind=fp_kind) cfcexp(m,np)
+!---- updated parameters -----
+      real(Kind=fp_kind) tcfc(m),tran(m)
+!-----tcfc is the exp factors between levels k1 and k2.
+         do i=1,m
+            tcfc(i)=tcfc(i)*cfcexp(i,k)
+            tran(i)=tran(i)*tcfc(i)
+         enddo
+      return
+      end subroutine cfckdis
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine b10kdis(m,np,k,h2oexp,conexp,co2exp,n2oexp &
+                ,th2o,tcon,tco2,tn2o,tran)
+!**********************************************************************
+!
+!   compute h2o (line and continuum),co2,n2o transmittances between
+!   levels k1 and k2 for m soundings, using the k-distribution
+!   method with linear pressure scaling.
+!
+!---- input parameters
+!   number of grid intervals (m)
+!   number of levels (np)
+!   current level (k)
+!   exponentials for h2o line absorption (h2oexp)
+!   exponentials for h2o continuum absorption (conexp)
+!   exponentials for co2 absorption (co2exp)
+!   exponentials for n2o absorption (n2oexp)
+!
+!---- updated parameters
+!   transmittance between levels k1 and k2 due to h2o line absorption
+!     for the various values of the absorption coefficient (th2o)
+!   transmittance between levels k1 and k2 due to h2o continuum
+!     absorption for the various values of the absorption
+!     coefficient (tcon)
+!   transmittance between levels k1 and k2 due to co2 absorption
+!     for the various values of the absorption coefficient (tco2)
+!   transmittance between levels k1 and k2 due to n2o absorption
+!     for the various values of the absorption coefficient (tn2o)
+!   total transmittance (tran)
+!
+!**********************************************************************
+      implicit none
+      integer m,np,i,k
+!---- input parameters -----
+      real(Kind=fp_kind) h2oexp(m,np,6),conexp(m,np,3),co2exp(m,np,6,2) &
+          ,n2oexp(m,np,4)
+!---- updated parameters -----
+      real(Kind=fp_kind) th2o(m,6),tcon(m,3),tco2(m,6,2),tn2o(m,4) &
+          ,tran(m)
+!---- temporary arrays -----
+      real(Kind=fp_kind) xx
+!-----for h2o line. the k-distribution functions are given in table 4.
+        do i=1,m
+           th2o(i,1)=th2o(i,1)*h2oexp(i,k,1)
+           xx=   0.3153*th2o(i,1)
+           th2o(i,2)=th2o(i,2)*h2oexp(i,k,2)
+           xx=xx+0.4604*th2o(i,2)
+           th2o(i,3)=th2o(i,3)*h2oexp(i,k,3)
+           xx=xx+0.1326*th2o(i,3)
+           th2o(i,4)=th2o(i,4)*h2oexp(i,k,4)
+           xx=xx+0.0798*th2o(i,4)
+           th2o(i,5)=th2o(i,5)*h2oexp(i,k,5)
+           xx=xx+0.0119*th2o(i,5)
+           tran(i)=xx
+        enddo
+!-----for h2o continuum. note that conexp(i,k,3) is for subband 3a.
+        do i=1,m
+           tcon(i,1)=tcon(i,1)*conexp(i,k,1)
+           tran(i)=tran(i)*tcon(i,1)
+        enddo
+!-----for co2 (table 6)
+        do i=1,m
+           tco2(i,1,1)=tco2(i,1,1)*co2exp(i,k,1,1)
+           xx=    0.2673*tco2(i,1,1)
+           tco2(i,2,1)=tco2(i,2,1)*co2exp(i,k,2,1)
+           xx=xx+ 0.2201*tco2(i,2,1)
+           tco2(i,3,1)=tco2(i,3,1)*co2exp(i,k,3,1)
+           xx=xx+ 0.2106*tco2(i,3,1)
+           tco2(i,4,1)=tco2(i,4,1)*co2exp(i,k,4,1)
+           xx=xx+ 0.2409*tco2(i,4,1)
+           tco2(i,5,1)=tco2(i,5,1)*co2exp(i,k,5,1)
+           xx=xx+ 0.0196*tco2(i,5,1)
+           tco2(i,6,1)=tco2(i,6,1)*co2exp(i,k,6,1)
+           xx=xx+ 0.0415*tco2(i,6,1)
+           tran(i)=tran(i)*xx
+        enddo
+!-----for n2o (table 5)
+        do i=1,m
+           tn2o(i,1)=tn2o(i,1)*n2oexp(i,k,1)
+           xx=   0.970831*tn2o(i,1)
+           tn2o(i,2)=tn2o(i,2)*n2oexp(i,k,2)
+           xx=xx+0.029169*tn2o(i,2)
+           tran(i)=tran(i)*(xx-1.0)
+        enddo
+      return
+      end subroutine b10kdis
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+      subroutine cldovlp (m,np,k2,ict,icb,it,im,ib, &
+                     cldhi,cldmd,cldlw,fcld,tcldlyr,fclr)
+!***********************************************************************
+!     compute the fractional clear line-of-sight between levels k1
+!     and k2
+!
+! input parameters
+!
+!  m:       number of soundings
+!  np:      number of layers
+!  k2:      index for the level
+!  ict:     the level separating high and middle clouds
+!  icb:     the level separating middle and low clouds
+!  it:      number of cloudy layers in the high-cloud group
+!  im:      number of cloudy layers in the middle-cloud group
+!  ib:      number of cloudy layers in the low-cloud group
+!  fcld:    fractional cloud cover of a layer
+!  tcldlyr: transmittance of a cloud layer
+!
+! output parameter
+!
+!  fclr:    clear line-of-sight between levels k1 and k2
+!***********************************************************************
+      implicit none
+      integer m,np,k2,ict(m),icb(m)
+      integer i,j,k,ii,it(m),im(m),ib(m),itx(m,np),imx(m,np),ibx(m,np)
+      real(Kind=fp_kind) cldhi(m),cldmd(m),cldlw(m)
+      real(Kind=fp_kind) fcld(m,np),tcldlyr(m,np),fclr(m)
+!***********************************************************************
+       do i=1,m
+!-----for high clouds
+!     "it" is the number of high-cloud layers
+        if (k2.le.ict(i)) then
+         if(fcld(i,k2-1).gt.0.001) then
+          it(i)=it(i)+1
+          ii=it(i)
+          itx(i,ii)=k2-1
+         if (ii .eq. 1) go to 11
+!-----rearrange the order of cloud layers with increasing cloud amount
+         do k=1,ii-1
+           j=itx(i,k)
+          if(fcld(i,j).gt.fcld(i,k2-1)) then
+           do j=ii-1,k,-1
+            itx(i,j+1)=itx(i,j)
+           enddo
+            itx(i,k)=k2-1
+            go to 11
+          endif
+         enddo
+   11   continue
+!-----compute equivalent black-body high cloud amount
+           cldhi(i)=0.0
+          do k=1,ii
+           j=itx(i,k)
+           cldhi(i)=fcld(i,j)-tcldlyr(i,j)*(fcld(i,j)-cldhi(i))
+          enddo
+        endif
+       endif
+!-----for middle clouds
+!     "im" is the number of middle-cloud layers
+       if (k2.gt.ict(m) .and. k2.le.icb(m)) then
+        if(fcld(i,k2-1).gt.0.001) then
+         im(i)=im(i)+1
+         ii=im(i)
+         imx(i,ii)=k2-1
+        if (ii .eq. 1) go to 21
+!-----rearrange the order of cloud layers with increasing cloud amount
+         do k=1,ii-1
+            j=imx(i,k)
+           if(fcld(i,j).gt.fcld(i,k2-1)) then
+            do j=ii-1,k,-1
+             imx(i,j+1)=imx(i,j)
+            enddo
+             imx(i,k)=k2-1
+             go to 21
+           endif
+          enddo
+   21   continue
+!-----compute equivalent black-body middle cloud amount
+           cldmd(i)=0.0
+          do k=1,ii
+           j=imx(i,k)
+           cldmd(i)=fcld(i,j)-tcldlyr(i,j)*(fcld(i,j)-cldmd(i))
+          enddo
+        endif
+       endif
+!-----for low clouds
+!     "ib" is the number of low-cloud layers
+       if (k2.gt.icb(m)) then
+        if(fcld(i,k2-1).gt.0.001) then
+         ib(i)=ib(i)+1
+         ii=ib(i)
+         ibx(i,ii)=k2-1
+        if (ii .eq. 1) go to 31
+!-----rearrange the order of cloud layers with increasing cloud amount
+         do k=1,ii-1
+          j=ibx(i,k)
+           if(fcld(i,j).gt.fcld(i,k2-1)) then
+            do j=ii-1,k,-1
+             ibx(i,j+1)=ibx(i,j)
+            enddo
+             ibx(i,k)=k2-1
+             go to 31
+           endif
+          enddo
+   31    continue
+!-----compute equivalent black-body low cloud amount
+           cldlw(i)=0.0
+          do k=1,ii
+           j=ibx(i,k)
+           cldlw(i)=fcld(i,j)-tcldlyr(i,j)*(fcld(i,j)-cldlw(i))
+          enddo
+        endif
+       endif
+!-----fclr is the equivalent clear fraction between levels k1 and k2
+!     assuming the three cloud groups are randomly overlapped.
+!     it follows eqs. (10) and (12).
+        fclr(i)=(1.0-cldhi(i))*(1.0-cldmd(i))*(1.0-cldlw(i))
+      enddo !i loop
+      return
+      end subroutine cldovlp
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD
+
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+!GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
+
+end module module_ra_goddard
+
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_gsfcsw.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_gsfcsw.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_gsfcsw.F	(revision 17)
@@ -0,0 +1,3138 @@
+!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
+
+   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                     ) 
+!------------------------------------------------------------------
+   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, &
+                                                              fp, &
+                                                          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( 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
+
+   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
+
+! reverse vars 
+!
+      DO K=kts,kte+1
+      DO I=its,ite
+         NK=kme-K+kms
+         P8W2D(I,K)=p8w3d(i,nk,j)*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)=p3d(i,nk,j)*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)
+        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)
+        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
+! FIX FROM GODDARD FOR NEGATIVE VALUES
+            TTEN2D(I,NK)=MAX(TTEN2D(I,NK),0.)
+            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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_hs.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_hs.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_hs.F	(revision 17)
@@ -0,0 +1,117 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+MODULE module_ra_hs
+
+CONTAINS
+
+!------------------------------------------------------------------
+   SUBROUTINE HSRAD(RTHRATEN,p8w,p_phy,pi_phy,dz8w,t_phy,          &
+                     t8w, rho_phy, R_d,G,CP,dt,xlat,degrad,        &
+                     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    )      ::        DEGRAD
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
+         INTENT(INOUT)  ::                              RTHRATEN
+
+   REAL, INTENT(IN   )   ::                   R_d,CP,G,dt
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
+         INTENT(IN ) ::                                     dz8w, &
+                                                             p8w, &
+                                                           p_phy, &
+                                                          pi_phy, &
+                                                           t_phy, &
+                                                             t8w, &
+                                                         rho_phy  
+   REAL, DIMENSION( ims:ime, jms:jme ),                           &
+         INTENT(IN ) ::                                     xlat
+
+   INTEGER :: i,j,K,NK
+   real :: delty,delthez,p0,sec_p_d,sigb,kka,kks,kkf,rcp
+   real :: ttmp,teq,sig,sigterm,kkt,t_tend
+
+!------------------------------------------------------------------
+! Newtonian relaxation scheme from Held and Suarez, Bull. Amer. Met.
+! Soc., Vol. 75, No. 10., p1825-1830, 1994.  (box on page 1826)
+! CEN and MIR  31-JUL-04
+
+   delty   = 60.0
+   delthez = 10.0
+   p0      = 100000.0
+   sec_p_d = 86400.
+   sigb    = 0.7
+   kka     = 1.0/40.0   ! units of per day
+   kks     = 0.25
+   kkf     = 1.0
+   rcp     = R_d/CP
+
+   j_loop: DO J=jts,MIN(jte,jde-1)
+   k_loop: DO K=kts,MIN(kte,kde-1)
+   i_loop: DO I=its,MIN(ite,ide-1)
+
+      ttmp = 315.0 - delty*(sin(xlat(i,j)*degrad))**2.0- &
+               delthez*alog(p_phy(i,k,j)/p0)*(cos(xlat(i,j)*degrad))**2.0
+               
+      teq=max(200.0,ttmp*(p_phy(i,k,j)/p0)**rcp)
+
+      sig=p_phy(i,k,j)/p8w(i,1,j)
+      sigterm=max(0.0,(sig-sigb)/(1.0-sigb))
+
+      kkt=kka+(kks-kka)*sigterm*(cos(xlat(i,j)*degrad))**4.0
+
+      t_tend=-kkt*(t_phy(i,k,j)-teq)/sec_p_d  ! t_tend in kinetic K/s
+
+      RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+t_tend/pi_phy(i,k,j)
+
+   ENDDO i_loop
+   ENDDO k_loop
+   ENDDO j_loop                                          
+
+   END SUBROUTINE HSRAD
+
+!====================================================================
+   SUBROUTINE hsinit(RTHRATEN,restart,                              &
+                     ids, ide, jds, jde, kds, kde,                  &
+                     ims, ime, jms, jme, kms, kme,                  &
+                     its, ite, jts, jte, kts, kte                   )
+!--------------------------------------------------------------------
+   IMPLICIT NONE
+!--------------------------------------------------------------------
+   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 , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) ::        &
+                                                          RTHRATEN
+   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
+        RTHRATEN(i,k,j)=0.
+     ENDDO
+     ENDDO
+     ENDDO
+   ENDIF
+
+   END SUBROUTINE hsinit
+
+!====================================================================
+
+END MODULE module_ra_hs
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_rrtm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_rrtm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_rrtm.F	(revision 17)
@@ -0,0 +1,7547 @@
+
+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
+      REAL, PARAMETER :: deltap = 4.  ! Pressure interval for buffer layer in mb
+
+! 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,tsk,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, &
+                                                             TSK
+!
+   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
+
+   REAL, DIMENSION( kts:kte ) ::                          TTEN1D, &
+                                                        CLDFRA1D, &
+                                                            DZ1D, &
+                                                             P1D, &
+                                                             T1D, &
+                                                            QV1D, &
+                                                            QC1D, &
+                                                            QR1D, &
+                                                            QI1D, &
+                                                            QS1D, &
+                                                            QG1D
+!
+    REAL   ::                              TSFC,GLW0,OLR0,EMISS0
+!
+    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
+
+         do k=kts,kte+1
+            NK=kme-k+kms
+            Pw1D(K) = p8w(I,NK,J)/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.
+            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=TSK(I,J)
+
+         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:NLAYERS ) ::                ITR
+
+      REAL,    DIMENSION( NGPT,kts:NLAYERS ) ::                PFRAC, &
+                                                               TAUG
+
+      REAL,    DIMENSION( 35,kts:NLAYERS )       ::              WKL
+
+      REAL,    DIMENSION( MAXXSEC,kts:NLAYERS )  ::              WX
+
+      REAL, DIMENSION( kts:kte )  ::                         O3PROF
+
+      REAL, DIMENSION( kts:NLAYERS )  ::                      PAVEL, &
+                                                              TAVEL, &
+                                                            CLDFRAC, &
+                                                           TAUCLOUD, &   
+                                                             COLDRY, & 
+                                                             COLH2O, &
+                                                             COLCO2, &
+                                                              COLO3, &
+                                                             COLN2O, &
+                                                             COLCH4, &
+                                                              COLO2, &
+                                                            CO2MULT, &
+                                                              FAC00, &
+                                                              FAC01, &
+                                                              FAC10, &
+                                                              FAC11, &
+                                                             FORFAC, &
+                                                            SELFFAC, &
+                                                           SELFFRAC
+                                                
+!                       
+      INTEGER, DIMENSION( kts:NLAYERS ) ::                  ICLDLYR, &
+                                                                 JP, &
+                                                                 JT, &
+                                                                JT1, &
+                                                            INDSELF
+
+      REAL, DIMENSION(   0:NLAYERS )  ::                         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
+      ktep1=NLAYERS
+!
+!    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                                              
+           do 2450 k = 1, kte         
+!              qrlc(k) = HTRC(NLAYERS-1-k)/86400.                                
+!              qrl(k) = HTR(NLAYERS-1-k)/86400.                                  
+!              TTEN(K)=HTR(NLAYERS-1-k)/86400. 
+              TTEN(K)=HTR(kte-k)/86400. 
+ 2450      continue                                                              
+           GLW = TOTDFLUX(0)
+!           OLR = TOTUFLUX(NLAYERS)
+           OLR = TOTUFLUX(kte)
+
+   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:NLAYERS ),                    &
+            INTENT(INOUT)        ::                  WKL
+
+      REAL, DIMENSION( MAXXSEC,kts:NLAYERS ),               &
+            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:NLAYERS ), INTENT(INOUT) ::    &
+                                                   PAVEL, &
+                                                   TAVEL, &
+                                                 CLDFRAC, &    
+                                                TAUCLOUD, &
+                                                  COLDRY 
+
+      REAL, DIMENSION(   0:NLAYERS ), 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
+! New declarations for RRTM buffer patch.
+! Steven Cavallo, NCAR/MMM 01/2010
+      
+      INTEGER, PARAMETER :: nproflevs = 60 ! Constant, from the table
+      INTEGER :: L, LL, klev               ! Loop indices      
+      REAL, DIMENSION( kts:NLAYERS ) :: O3PROF2, PZR, varint
+      REAL :: wght,vark,vark1       
+      REAL :: PPROF(nproflevs), TPROF(nproflevs)            
+      ! Mean pressure and temperature profiles from midlatitude 
+      ! summer (MLS),midlatitude winter (MLW), sub-Arctic 
+      ! winter (SAW),and tropical (TROP) standard atmospheres.
+      DATA PPROF   /1000.00,855.47,731.82,626.05,535.57,458.16,     &
+                    391.94,335.29,286.83,245.38,209.91,179.57,      &
+                    153.62,131.41,112.42,96.17,82.27,70.38,         &
+                    60.21,51.51,44.06,37.69,32.25,27.59,            &
+                    23.60,20.19,17.27,14.77,12.64,10.81,            &
+                    9.25,7.91,6.77,5.79,4.95,4.24,                  &
+                    3.63,3.10,2.65,2.27,1.94,1.66,                  &
+                    1.42,1.22,1.04,0.89,0.76,0.65,                  &
+                    0.56,0.48,0.41,0.35,0.30,0.26,                  &
+                    0.22,0.19,0.16,0.14,0.12,0.10/
+      DATA TPROF   /279.94,276.16,270.73,264.14,256.71,249.28,      &
+                    241.97,234.91,228.78,224.02,220.52,217.31,      &
+                    215.21,213.48,211.63,211.45,211.73,212.71,      &
+                    213.81,214.95,215.96,216.73,217.42,218.11,      &
+                    218.89,219.92,221.31,222.84,224.39,226.04,      &
+                    227.78,229.73,231.88,234.22,236.82,239.50,      &
+                    242.30,245.21,248.13,251.08,254.04,257.02,      &
+                    259.84,261.88,263.38,264.67,265.42,265.34,      &
+                    264.45,262.76,260.85,258.78,256.49,254.02,      &
+                    251.07,248.23,245.46,242.77,239.87,237.53/
+
+! End new declarations for buffer layer edit
+
+      CHARACTER*80 errmess
+                           
+      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      
+              amdo,  &  ! Molecular weight of dry air / ozone
+              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 amdo /  0.603461 /                                                    
+      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)                                
+!     Added H2O volume mixing ratio from standard atmosphere 
+!        above 150 mb (Steven Cavallo, 01/2010).
+
+      real :: co2vmr, h2ovmr
+      data co2vmr / 330.e-6 /                                                    
+      data h2ovmr / 5.00e-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 1000 ILAY = kts,NLAYERS
+         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
+      IF(TBOUND .GT. 340.)THEN
+        WRITE( errmess , '(A,F10.3)' ) 'rrtm: TBOUND exceeds table limit: reset ',TBOUND
+        CALL wrf_message (errmess)
+        TBOUND = 339.99
+      ENDIF
+                                                                                 
+!  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 additional levels (L = kte + int(p_top/4) + 1)
+!  from the model top (p_top) to 0 mb, to estimate the downward                  
+!  fluxes between the model top interface and the top of the atmosphere
+!  where kte is the top WRF model level index and p_top is the pressure at 
+!  the top model level. H2O, CO2, N2O, and CH4 vmrs for these extra layers are 
+!  set to the values in the model's top layer, though the O3 value is 
+!  interpolated based on the US Std Atm. For GCMs with a model top near 0 mb, 
+!  these extra layers are 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                                                   
+      DO 2000 L = 1, kte 
+         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
+         ! Set the water vapor mixing ratio constant above 
+         ! the typical level where global and reanalysis data
+         ! does not provide it.  Steven Cavallo 01/2010.
+         !IF (PAVEL(L).LE.100) THEN
+         !   WKL(1,L) = h2ovmr
+         !ENDIF                                            
+         WKL(2,L) = co2vmr
+         WKL(3,L) = o3(kte+1-L)                                                        
+! ozone is already bottom to top array but convert mmr to vmr
+         WKL(3,L) = o3(L)*amdo                                                  
+         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                                                     
+      DO 2100 L=1, kte      
+!        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                                                                   
+  
+!  old section
+   IF ( 1 .EQ. 0 ) THEN                                                                                 
+!  *****                                                                         
+!  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)                                            
+!  *****               
+
+   ENDIF
+   
+!  *****                                                                         
+!  Set up values for extra layers to the top of the atmosphere.                       
+!  Temperature is calculated based on an average temperature profile given
+!  here in a table.  The input table data is linearly interpolated to the
+!  column pressure.  Mixing ratios are held constant except for ozone.  
+!  Caution should be used if model top pressure is less than 5 hPa.
+!  Steven Cavallo, NCAR/MMM, January 2010
+       ! Calculate the column pressure buffer levels above the 
+       ! model top       
+       DO 3000 L=kte+1,NLAYERS-1,1
+          PZ(L) = PZ(L-1) - deltap
+          PAVEL(L) = 0.5*(PZ(L) + PZ(L-1))
+ 3000  CONTINUE          
+       ! Add zero as top level.  This gets the temperature max at the
+       ! stratopause, reducing the downward flux errors in the top 
+       ! levels.  If zero happened to be the top level already,
+       ! this will add another level with zero, but will not affect
+       ! the radiative transfer calculation.
+       PZ(NLAYERS) = 0.00
+       PAVEL(NLAYERS) =  0.5*(PZ(NLAYERS) + PZ(NLAYERS-1))
+
+       ! Interpolate the table temperatures to column pressure levels    
+       DO 3100 L=1,NLAYERS,1
+          IF ( PPROF(nproflevs) .LT. PZ(L) ) THEN
+             DO 3150 LL=2,nproflevs,1       
+                IF ( PPROF(LL) .LT. PZ(L) ) THEN           
+                   klev = LL - 1
+                   exit
+                ENDIF
+ 3150        CONTINUE
+          
+          ELSE
+             klev = nproflevs
+          ENDIF  
+  
+          IF (klev .NE. nproflevs ) THEN
+             vark  = TPROF(klev) 
+             vark1 = TPROF(klev+1)
+             wght=( PZ(L)-PPROF(klev) ) / ( PPROF(klev+1)-PPROF(klev))
+          ELSE
+             vark  = TPROF(klev) 
+             vark1 = TPROF(klev)
+             wght = 0.0
+          ENDIF
+          varint(L) = wght*(vark1-vark)+vark
+
+ 3100 CONTINUE                   
+        
+       ! Match the interpolated table temperature profile to WRF column                    
+       DO 3200 L=kte+1,NLAYERS,1
+          TZ(L) = varint(L) + (TZ(kte) - varint(kte))
+          TAVEL(L) = 0.5*(TZ(L) + TZ(L-1))  
+ 3200  CONTINUE                 
+       
+       ! Get the new ozone profile.  First need to reverse pressure
+       ! array for the ozone interpolator subroutines.     
+       DO 3225 L=kts,NLAYERS,1
+         klev=NLAYERS-L+1
+         PZR(L)=PZ(klev)
+ 3225  CONTINUE     
+       CALL INIRAD (O3PROF2(kts:NLAYERS-1),PZR,kts,NLAYERS-1)       
+       ! Pick the top level to be the closest to zero from the table
+       O3PROF2(NLAYERS) = 6.135E-6      
+       
+       ! Keep all molecular mixing ratios constant in the buffer zone,
+       ! except for ozone
+       IF ( kte .NE. NLAYERS ) THEN 
+          DO 3250 L=1,NLAYERS,1
+             WKL(3,L) = O3PROF2(L)*amdo! O3
+             IF ( L .GT. kte ) THEN
+!               WKL(1,L) = WKL(1,kte)  ! H2O
+                WKL(1,L) = h2ovmr      ! H2O above model top set to constant value
+                WKL(2,L) = co2vmr      ! CO2
+                WKL(4,L) = WKL(4,kte)  ! N2O
+                WKL(6,L) = WKL(6,kte)  ! CH4
+                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)))    
+                WX(2,L) = WX(2,kte)
+                WX(3,L) = WX(3,kte)
+             ENDIF
+ 3250     CONTINUE                
+       ENDIF
+!
+!  End of buffer layer edit.
+!                                                             
+!  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 levels (above   
+!  the model top) are set to zero.                                               
+                                                                                 
+!      DO 7000 L = 1, NLAYERS-1                                                   
+      DO 7000 L = 1, kte   
+         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                                                    
+      DO 7500 L = kte+1,NLAYERS,1
+         CLDFRAC(L) = 0.0   
+         TAUCLOUD(L) = 0.0  
+ 7500 CONTINUE
+        
+   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(                                             &
+                       p_top, 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)               :: p_top 
+!  REAL, PARAMETER                :: deltap = 4  ! Pressure interval for buffer layer (hPa)
+
+   REAL :: pi
+
+   PI = 2.*ASIN(1.) 
+   FLUXFAC  = PI   * 2.D4                     
+  !NLAYERS = kme
+   NLAYERS = kme + nint(p_top*0.01/deltap)- 1 ! Model levels plus new levels
+
+   IF ( allowed_to_read ) THEN
+     CALL rrtm_lookuptable
+   ENDIF
+
+   END SUBROUTINE rrtminit
+
+
+! **************************************************************************     
+      SUBROUTINE rrtm_lookuptable
+! **************************************************************************     
+
+USE module_wrf_error
+!USE module_dm, ONLY : wrf_dm_bcast_bytes
+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.              
+! **************************************************************************     
+        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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_rrtmg_lw.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_rrtmg_lw.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_rrtmg_lw.F	(revision 17)
@@ -0,0 +1,14044 @@
+!MODULE module_ra_rrtmg_lw
+
+      module parkind
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg kinds
+! Define integer and real kinds for various types.
+!
+! Initial version: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+
+!
+!     integer kinds
+!     -------------
+!
+      integer, parameter :: kind_ib = selected_int_kind(13)  ! 8 byte integer
+      integer, parameter :: kind_im = selected_int_kind(6)   ! 4 byte integer
+      integer, parameter :: kind_in = kind(1)                ! native integer
+
+!
+!     real kinds
+!     ----------
+!
+!      integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real
+!      integer, parameter :: kind_rm = selected_real_kind(6)  ! 4 byte real
+!      integer, parameter :: kind_rn = kind(1.0)              ! native real
+
+#if 0
+! Modified for WRF:
+#if (RWORDSIZE == 8)
+      integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real
+#endif
+#if (RWORDSIZE == 4)
+      integer, parameter :: kind_rb = selected_real_kind(6)  ! 4 byte real
+#endif
+#else
+       integer, parameter :: kind_rb = kind(1.0)              ! native real
+#endif
+
+      end module parkind
+
+      module parrrtm
+
+      use parkind ,only : im => kind_im
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_lw main parameters
+!
+! Initial version:  JJMorcrette, ECMWF, Jul 1998
+! Revised: MJIacono, AER, Jun 2006
+! Revised: MJIacono, AER, Aug 2007
+! Revised: MJIacono, AER, Aug 2008
+!------------------------------------------------------------------
+
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+! mxlay  :  integer: maximum number of layers
+! mg     :  integer: number of original g-intervals per spectral band
+! nbndlw :  integer: number of spectral bands
+! maxxsec:  integer: maximum number of cross-section molecules
+!                    (e.g. cfcs)
+! maxinpx:  integer: 
+! ngptlw :  integer: total number of reduced g-intervals for rrtmg_lw
+! ngNN   :  integer: number of reduced g-intervals per spectral band
+! ngsNN  :  integer: cumulative number of g-intervals per band
+!------------------------------------------------------------------
+
+      integer(kind=im), parameter :: mxlay  = 203
+      integer(kind=im), parameter :: mg     = 16
+      integer(kind=im), parameter :: nbndlw = 16
+      integer(kind=im), parameter :: maxxsec= 4
+      integer(kind=im), parameter :: mxmol  = 38
+      integer(kind=im), parameter :: maxinpx= 38
+      integer(kind=im), parameter :: nmol   = 7
+! Use for 140 g-point model 
+      integer(kind=im), parameter :: ngptlw = 140
+! Use for 256 g-point model 
+!      integer(kind=im), parameter :: ngptlw = 256
+
+! Use for 140 g-point model
+      integer(kind=im), parameter :: ng1  = 10
+      integer(kind=im), parameter :: ng2  = 12
+      integer(kind=im), parameter :: ng3  = 16
+      integer(kind=im), parameter :: ng4  = 14
+      integer(kind=im), parameter :: ng5  = 16
+      integer(kind=im), parameter :: ng6  = 8
+      integer(kind=im), parameter :: ng7  = 12
+      integer(kind=im), parameter :: ng8  = 8
+      integer(kind=im), parameter :: ng9  = 12
+      integer(kind=im), parameter :: ng10 = 6
+      integer(kind=im), parameter :: ng11 = 8
+      integer(kind=im), parameter :: ng12 = 8
+      integer(kind=im), parameter :: ng13 = 4
+      integer(kind=im), parameter :: ng14 = 2
+      integer(kind=im), parameter :: ng15 = 2
+      integer(kind=im), parameter :: ng16 = 2
+
+      integer(kind=im), parameter :: ngs1  = 10
+      integer(kind=im), parameter :: ngs2  = 22
+      integer(kind=im), parameter :: ngs3  = 38
+      integer(kind=im), parameter :: ngs4  = 52
+      integer(kind=im), parameter :: ngs5  = 68
+      integer(kind=im), parameter :: ngs6  = 76
+      integer(kind=im), parameter :: ngs7  = 88
+      integer(kind=im), parameter :: ngs8  = 96
+      integer(kind=im), parameter :: ngs9  = 108
+      integer(kind=im), parameter :: ngs10 = 114
+      integer(kind=im), parameter :: ngs11 = 122
+      integer(kind=im), parameter :: ngs12 = 130
+      integer(kind=im), parameter :: ngs13 = 134
+      integer(kind=im), parameter :: ngs14 = 136
+      integer(kind=im), parameter :: ngs15 = 138
+
+! Use for 256 g-point model
+!      integer(kind=im), parameter :: ng1  = 16
+!      integer(kind=im), parameter :: ng2  = 16
+!      integer(kind=im), parameter :: ng3  = 16
+!      integer(kind=im), parameter :: ng4  = 16
+!      integer(kind=im), parameter :: ng5  = 16
+!      integer(kind=im), parameter :: ng6  = 16
+!      integer(kind=im), parameter :: ng7  = 16
+!      integer(kind=im), parameter :: ng8  = 16
+!      integer(kind=im), parameter :: ng9  = 16
+!      integer(kind=im), parameter :: ng10 = 16
+!      integer(kind=im), parameter :: ng11 = 16
+!      integer(kind=im), parameter :: ng12 = 16
+!      integer(kind=im), parameter :: ng13 = 16
+!      integer(kind=im), parameter :: ng14 = 16
+!      integer(kind=im), parameter :: ng15 = 16
+!      integer(kind=im), parameter :: ng16 = 16
+
+!      integer(kind=im), parameter :: ngs1  = 16
+!      integer(kind=im), parameter :: ngs2  = 32
+!      integer(kind=im), parameter :: ngs3  = 48
+!      integer(kind=im), parameter :: ngs4  = 64
+!      integer(kind=im), parameter :: ngs5  = 80
+!      integer(kind=im), parameter :: ngs6  = 96
+!      integer(kind=im), parameter :: ngs7  = 112
+!      integer(kind=im), parameter :: ngs8  = 128
+!      integer(kind=im), parameter :: ngs9  = 144
+!      integer(kind=im), parameter :: ngs10 = 160
+!      integer(kind=im), parameter :: ngs11 = 176
+!      integer(kind=im), parameter :: ngs12 = 192
+!      integer(kind=im), parameter :: ngs13 = 208
+!      integer(kind=im), parameter :: ngs14 = 224
+!      integer(kind=im), parameter :: ngs15 = 240
+!      integer(kind=im), parameter :: ngs16 = 256
+
+      end module parrrtm
+
+      module rrlw_cld
+
+      use parkind, only : rb => kind_rb
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_lw cloud property coefficients
+
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+! abscld1:  real   : 
+! absice0:  real   : 
+! absice1:  real   : 
+! absice2:  real   : 
+! absice3:  real   : 
+! absliq0:  real   : 
+! absliq1:  real   : 
+!------------------------------------------------------------------
+
+      real(kind=rb) :: abscld1
+      real(kind=rb) , dimension(2) :: absice0
+      real(kind=rb) , dimension(2,5) :: absice1
+      real(kind=rb) , dimension(43,16) :: absice2
+      real(kind=rb) , dimension(46,16) :: absice3
+      real(kind=rb) :: absliq0
+      real(kind=rb) , dimension(58,16) :: absliq1
+
+      end module rrlw_cld
+
+      module rrlw_con
+
+      use parkind, only : rb => kind_rb
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_lw constants
+
+! Initial version: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+! fluxfac:  real   : radiance to flux conversion factor 
+! heatfac:  real   : flux to heating rate conversion factor
+!oneminus:  real   : 1.-1.e-6
+! pi     :  real   : pi
+! grav   :  real   : acceleration of gravity
+! planck :  real   : planck constant
+! boltz  :  real   : boltzmann constant
+! clight :  real   : speed of light
+! avogad :  real   : avogadro constant 
+! alosmt :  real   : loschmidt constant
+! gascon :  real   : molar gas constant
+! radcn1 :  real   : first radiation constant
+! radcn2 :  real   : second radiation constant
+! sbcnst :  real   : stefan-boltzmann constant
+!  secdy :  real   : seconds per day  
+!------------------------------------------------------------------
+
+      real(kind=rb) :: fluxfac, heatfac
+      real(kind=rb) :: oneminus, pi, grav
+      real(kind=rb) :: planck, boltz, clight
+      real(kind=rb) :: avogad, alosmt, gascon
+      real(kind=rb) :: radcn1, radcn2
+      real(kind=rb) :: sbcnst, secdy
+
+      end module rrlw_con
+
+      module rrlw_kg01
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 1
+! band 1:  10-250 cm-1 (low - h2o; high - h2o)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+!fracrefbo: real
+! kao     : real     
+! kbo     : real     
+! kao_mn2 : real     
+! kbo_mn2 : real     
+! selfrefo: real     
+! forrefo : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no1  = 16
+
+      real(kind=rb) :: fracrefao(no1)  , fracrefbo(no1)
+      real(kind=rb) :: kao(5,13,no1)
+      real(kind=rb) :: kbo(5,13:59,no1)
+      real(kind=rb) :: kao_mn2(19,no1) , kbo_mn2(19,no1)
+      real(kind=rb) :: selfrefo(10,no1), forrefo(4,no1)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 1
+! band 1:  10-250 cm-1 (low - h2o; high - h2o)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+!fracrefb : real
+! ka      : real     
+! kb      : real     
+! absa    : real
+! absb    : real
+! ka_mn2  : real     
+! kb_mn2  : real     
+! selfref : real     
+! forref  : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng1  = 10
+
+      real(kind=rb) :: fracrefa(ng1)  , fracrefb(ng1)
+      real(kind=rb) :: ka(5,13,ng1)   , absa(65,ng1)
+      real(kind=rb) :: kb(5,13:59,ng1), absb(235,ng1)
+      real(kind=rb) :: ka_mn2(19,ng1) , kb_mn2(19,ng1)
+      real(kind=rb) :: selfref(10,ng1), forref(4,ng1)
+
+      equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
+
+      end module rrlw_kg01
+
+      module rrlw_kg02
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 2
+! band 2:  250-500 cm-1 (low - h2o; high - h2o)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+!fracrefbo: real
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no2  = 16
+
+      real(kind=rb) :: fracrefao(no2)   , fracrefbo(no2)
+      real(kind=rb) :: kao(5,13,no2)
+      real(kind=rb) :: kbo(5,13:59,no2)
+      real(kind=rb) :: selfrefo(10,no2) , forrefo(4,no2)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 2
+! band 2:  250-500 cm-1 (low - h2o; high - h2o)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+!fracrefb : real
+! ka      : real     
+! kb      : real     
+! absa    : real
+! absb    : real
+! selfref : real     
+! forref  : real
+!
+! refparam: real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng2  = 12
+
+      real(kind=rb) :: fracrefa(ng2)  , fracrefb(ng2)
+      real(kind=rb) :: ka(5,13,ng2)   , absa(65,ng2)
+      real(kind=rb) :: kb(5,13:59,ng2), absb(235,ng2)
+      real(kind=rb) :: selfref(10,ng2), forref(4,ng2)
+
+      real(kind=rb) :: refparam(13)
+
+      equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
+
+      end module rrlw_kg02
+
+      module rrlw_kg03
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 3
+! band 3:  500-630 cm-1 (low - h2o,co2; high - h2o,co2)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+!fracrefbo: real
+! kao     : real     
+! kbo     : real     
+! kao_mn2o: real     
+! kbo_mn2o: real     
+! selfrefo: real     
+! forrefo : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no3  = 16
+
+      real(kind=rb) :: fracrefao(no3,9) ,fracrefbo(no3,5)
+      real(kind=rb) :: kao(9,5,13,no3)
+      real(kind=rb) :: kbo(5,5,13:59,no3)
+      real(kind=rb) :: kao_mn2o(9,19,no3), kbo_mn2o(5,19,no3)
+      real(kind=rb) :: selfrefo(10,no3)
+      real(kind=rb) :: forrefo(4,no3)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 3
+! band 3:  500-630 cm-1 (low - h2o,co2; high - h2o,co2)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+!fracrefb : real
+! ka      : real     
+! kb      : real     
+! ka_mn2o : real     
+! kb_mn2o : real     
+! selfref : real     
+! forref  : real
+!
+! absa    : real
+! absb    : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng3  = 16
+
+      real(kind=rb) :: fracrefa(ng3,9) ,fracrefb(ng3,5)
+      real(kind=rb) :: ka(9,5,13,ng3)  ,absa(585,ng3)
+      real(kind=rb) :: kb(5,5,13:59,ng3),absb(1175,ng3)
+      real(kind=rb) :: ka_mn2o(9,19,ng3), kb_mn2o(5,19,ng3)
+      real(kind=rb) :: selfref(10,ng3)
+      real(kind=rb) :: forref(4,ng3)
+
+      equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
+
+      end module rrlw_kg03
+
+      module rrlw_kg04
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 4
+! band 4:  630-700 cm-1 (low - h2o,co2; high - o3,co2)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+!fracrefbo: real
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no4  = 16
+
+      real(kind=rb) :: fracrefao(no4,9)  ,fracrefbo(no4,5)
+      real(kind=rb) :: kao(9,5,13,no4)
+      real(kind=rb) :: kbo(5,5,13:59,no4)
+      real(kind=rb) :: selfrefo(10,no4)  ,forrefo(4,no4)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 4
+! band 4:  630-700 cm-1 (low - h2o,co2; high - o3,co2)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! absa    : real
+! absb    : real
+!fracrefa : real    
+!fracrefb : real
+! ka      : real     
+! kb      : real     
+! selfref : real     
+! forref  : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng4  = 14
+
+      real(kind=rb) :: fracrefa(ng4,9)  ,fracrefb(ng4,5)
+      real(kind=rb) :: ka(9,5,13,ng4)   ,absa(585,ng4)
+      real(kind=rb) :: kb(5,5,13:59,ng4),absb(1175,ng4)
+      real(kind=rb) :: selfref(10,ng4)  ,forref(4,ng4)
+
+      equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
+
+      end module rrlw_kg04
+
+      module rrlw_kg05
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 5
+! band 5:  700-820 cm-1 (low - h2o,co2; high - o3,co2)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+!fracrefbo: real
+! kao     : real     
+! kbo     : real     
+! kao_mo3 : real     
+! selfrefo: real     
+! forrefo : real     
+! ccl4o   : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no5  = 16
+
+      real(kind=rb) :: fracrefao(no5,9) ,fracrefbo(no5,5)
+      real(kind=rb) :: kao(9,5,13,no5)
+      real(kind=rb) :: kbo(5,5,13:59,no5)
+      real(kind=rb) :: kao_mo3(9,19,no5)
+      real(kind=rb) :: selfrefo(10,no5)
+      real(kind=rb) :: forrefo(4,no5)
+      real(kind=rb) :: ccl4o(no5)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 5
+! band 5:  700-820 cm-1 (low - h2o,co2; high - o3,co2)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+!fracrefb : real
+! ka      : real     
+! kb      : real     
+! ka_mo3  : real     
+! selfref : real     
+! forref  : real     
+! ccl4    : real
+!
+! absa    : real
+! absb    : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng5  = 16
+
+      real(kind=rb) :: fracrefa(ng5,9) ,fracrefb(ng5,5)
+      real(kind=rb) :: ka(9,5,13,ng5)   ,absa(585,ng5)
+      real(kind=rb) :: kb(5,5,13:59,ng5),absb(1175,ng5)
+      real(kind=rb) :: ka_mo3(9,19,ng5)
+      real(kind=rb) :: selfref(10,ng5)
+      real(kind=rb) :: forref(4,ng5)
+      real(kind=rb) :: ccl4(ng5)
+      
+      equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
+
+      end module rrlw_kg05
+
+      module rrlw_kg06
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 6
+! band 6:  820-980 cm-1 (low - h2o; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+! kao     : real     
+! kao_mco2: real     
+! selfrefo: real     
+! forrefo : real     
+!cfc11adjo: real
+! cfc12o  : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no6  = 16
+
+      real(kind=rb) , dimension(no6) :: fracrefao
+      real(kind=rb) :: kao(5,13,no6)
+      real(kind=rb) :: kao_mco2(19,no6)
+      real(kind=rb) :: selfrefo(10,no6)
+      real(kind=rb) :: forrefo(4,no6)
+
+      real(kind=rb) , dimension(no6) :: cfc11adjo
+      real(kind=rb) , dimension(no6) :: cfc12o
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 6
+! band 6:  820-980 cm-1 (low - h2o; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+! ka      : real     
+! ka_mco2 : real     
+! selfref : real     
+! forref  : real     
+!cfc11adj : real
+! cfc12   : real
+!
+! absa    : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng6  = 8
+
+      real(kind=rb) , dimension(ng6) :: fracrefa
+      real(kind=rb) :: ka(5,13,ng6),absa(65,ng6)
+      real(kind=rb) :: ka_mco2(19,ng6)
+      real(kind=rb) :: selfref(10,ng6)
+      real(kind=rb) :: forref(4,ng6)
+
+      real(kind=rb) , dimension(ng6) :: cfc11adj
+      real(kind=rb) , dimension(ng6) :: cfc12
+
+      equivalence (ka(1,1,1),absa(1,1))
+
+      end module rrlw_kg06
+
+      module rrlw_kg07
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 7
+! band 7:  980-1080 cm-1 (low - h2o,o3; high - o3)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+!fracrefbo: real    
+! kao     : real     
+! kbo     : real     
+! kao_mco2: real     
+! kbo_mco2: real     
+! selfrefo: real     
+! forrefo : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no7  = 16
+
+      real(kind=rb) , dimension(no7) :: fracrefbo
+      real(kind=rb) :: fracrefao(no7,9)
+      real(kind=rb) :: kao(9,5,13,no7)
+      real(kind=rb) :: kbo(5,13:59,no7)
+      real(kind=rb) :: kao_mco2(9,19,no7)
+      real(kind=rb) :: kbo_mco2(19,no7)
+      real(kind=rb) :: selfrefo(10,no7)
+      real(kind=rb) :: forrefo(4,no7)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 7
+! band 7:  980-1080 cm-1 (low - h2o,o3; high - o3)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+!fracrefb : real    
+! ka      : real     
+! kb      : real     
+! ka_mco2 : real     
+! kb_mco2 : real     
+! selfref : real     
+! forref  : real     
+!
+! absa    : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng7  = 12
+
+      real(kind=rb) , dimension(ng7) :: fracrefb
+      real(kind=rb) :: fracrefa(ng7,9)
+      real(kind=rb) :: ka(9,5,13,ng7) ,absa(585,ng7)
+      real(kind=rb) :: kb(5,13:59,ng7),absb(235,ng7)
+      real(kind=rb) :: ka_mco2(9,19,ng7)
+      real(kind=rb) :: kb_mco2(19,ng7)
+      real(kind=rb) :: selfref(10,ng7)
+      real(kind=rb) :: forref(4,ng7)
+
+      equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
+
+      end module rrlw_kg07
+
+      module rrlw_kg08
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 8
+! band 8:  1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+!fracrefbo: real    
+! kao     : real     
+! kbo     : real     
+! kao_mco2: real     
+! kbo_mco2: real     
+! kao_mn2o: real     
+! kbo_mn2o: real     
+! kao_mo3 : real     
+! selfrefo: real     
+! forrefo : real     
+! cfc12o  : real     
+!cfc22adjo: real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no8  = 16
+
+      real(kind=rb) , dimension(no8) :: fracrefao
+      real(kind=rb) , dimension(no8) :: fracrefbo
+      real(kind=rb) , dimension(no8) :: cfc12o
+      real(kind=rb) , dimension(no8) :: cfc22adjo
+
+      real(kind=rb) :: kao(5,13,no8)
+      real(kind=rb) :: kao_mco2(19,no8)
+      real(kind=rb) :: kao_mn2o(19,no8)
+      real(kind=rb) :: kao_mo3(19,no8)
+      real(kind=rb) :: kbo(5,13:59,no8)
+      real(kind=rb) :: kbo_mco2(19,no8)
+      real(kind=rb) :: kbo_mn2o(19,no8)
+      real(kind=rb) :: selfrefo(10,no8)
+      real(kind=rb) :: forrefo(4,no8)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 8
+! band 8:  1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+!fracrefb : real    
+! ka      : real     
+! kb      : real     
+! ka_mco2 : real     
+! kb_mco2 : real     
+! ka_mn2o : real     
+! kb_mn2o : real     
+! ka_mo3  : real     
+! selfref : real     
+! forref  : real     
+! cfc12   : real     
+! cfc22adj: real     
+!
+! absa    : real
+! absb    : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng8  = 8
+
+      real(kind=rb) , dimension(ng8) :: fracrefa
+      real(kind=rb) , dimension(ng8) :: fracrefb
+      real(kind=rb) , dimension(ng8) :: cfc12
+      real(kind=rb) , dimension(ng8) :: cfc22adj
+
+      real(kind=rb) :: ka(5,13,ng8)    ,absa(65,ng8)
+      real(kind=rb) :: kb(5,13:59,ng8) ,absb(235,ng8)
+      real(kind=rb) :: ka_mco2(19,ng8)
+      real(kind=rb) :: ka_mn2o(19,ng8)
+      real(kind=rb) :: ka_mo3(19,ng8)
+      real(kind=rb) :: kb_mco2(19,ng8)
+      real(kind=rb) :: kb_mn2o(19,ng8)
+      real(kind=rb) :: selfref(10,ng8)
+      real(kind=rb) :: forref(4,ng8)
+
+      equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
+
+      end module rrlw_kg08
+
+      module rrlw_kg09
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 9
+! band 9:  1180-1390 cm-1 (low - h2o,ch4; high - ch4)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+!fracrefbo: real    
+! kao     : real     
+! kbo     : real     
+! kao_mn2o: real     
+! kbo_mn2o: real     
+! selfrefo: real     
+! forrefo : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no9  = 16
+
+      real(kind=rb) , dimension(no9) :: fracrefbo
+
+      real(kind=rb) :: fracrefao(no9,9)
+      real(kind=rb) :: kao(9,5,13,no9)
+      real(kind=rb) :: kbo(5,13:59,no9)
+      real(kind=rb) :: kao_mn2o(9,19,no9)
+      real(kind=rb) :: kbo_mn2o(19,no9)
+      real(kind=rb) :: selfrefo(10,no9)
+      real(kind=rb) :: forrefo(4,no9)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 9
+! band 9:  1180-1390 cm-1 (low - h2o,ch4; high - ch4)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+!fracrefb : real    
+! ka      : real     
+! kb      : real     
+! ka_mn2o : real     
+! kb_mn2o : real     
+! selfref : real     
+! forref  : real     
+!
+! absa    : real
+! absb    : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng9  = 12
+
+      real(kind=rb) , dimension(ng9) :: fracrefb
+      real(kind=rb) :: fracrefa(ng9,9)
+      real(kind=rb) :: ka(9,5,13,ng9) ,absa(585,ng9)
+      real(kind=rb) :: kb(5,13:59,ng9) ,absb(235,ng9)
+      real(kind=rb) :: ka_mn2o(9,19,ng9)
+      real(kind=rb) :: kb_mn2o(19,ng9)
+      real(kind=rb) :: selfref(10,ng9)
+      real(kind=rb) :: forref(4,ng9)
+
+      equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
+
+      end module rrlw_kg09
+
+      module rrlw_kg10
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 10
+! band 10:  1390-1480 cm-1 (low - h2o; high - h2o)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+!fracrefbo: real    
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no10 = 16
+
+      real(kind=rb) , dimension(no10) :: fracrefao
+      real(kind=rb) , dimension(no10) :: fracrefbo
+
+      real(kind=rb) :: kao(5,13,no10)
+      real(kind=rb) :: kbo(5,13:59,no10)
+      real(kind=rb) :: selfrefo(10,no10)
+      real(kind=rb) :: forrefo(4,no10)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 10
+! band 10:  1390-1480 cm-1 (low - h2o; high - h2o)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+!fracrefbo: real    
+! kao     : real     
+! kbo     : real     
+! selfref : real     
+! forref  : real     
+!
+! absa    : real
+! absb    : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng10 = 6
+
+      real(kind=rb) , dimension(ng10) :: fracrefa
+      real(kind=rb) , dimension(ng10) :: fracrefb
+
+      real(kind=rb) :: ka(5,13,ng10)   , absa(65,ng10)
+      real(kind=rb) :: kb(5,13:59,ng10), absb(235,ng10)
+      real(kind=rb) :: selfref(10,ng10)
+      real(kind=rb) :: forref(4,ng10)
+
+      equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
+
+      end module rrlw_kg10
+
+      module rrlw_kg11
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 11
+! band 11:  1480-1800 cm-1 (low - h2o; high - h2o)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+!fracrefbo: real    
+! kao     : real     
+! kbo     : real     
+! kao_mo2 : real     
+! kbo_mo2 : real     
+! selfrefo: real     
+! forrefo : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no11 = 16
+
+      real(kind=rb) , dimension(no11) :: fracrefao
+      real(kind=rb) , dimension(no11) :: fracrefbo
+
+      real(kind=rb) :: kao(5,13,no11)
+      real(kind=rb) :: kbo(5,13:59,no11)
+      real(kind=rb) :: kao_mo2(19,no11)
+      real(kind=rb) :: kbo_mo2(19,no11)
+      real(kind=rb) :: selfrefo(10,no11)
+      real(kind=rb) :: forrefo(4,no11)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 11
+! band 11:  1480-1800 cm-1 (low - h2o; high - h2o)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+!fracrefb : real    
+! ka      : real     
+! kb      : real     
+! ka_mo2  : real     
+! kb_mo2  : real     
+! selfref : real     
+! forref  : real     
+!
+! absa    : real
+! absb    : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng11 = 8
+
+      real(kind=rb) , dimension(ng11) :: fracrefa
+      real(kind=rb) , dimension(ng11) :: fracrefb
+
+      real(kind=rb) :: ka(5,13,ng11)   , absa(65,ng11)
+      real(kind=rb) :: kb(5,13:59,ng11), absb(235,ng11)
+      real(kind=rb) :: ka_mo2(19,ng11)
+      real(kind=rb) :: kb_mo2(19,ng11)
+      real(kind=rb) :: selfref(10,ng11)
+      real(kind=rb) :: forref(4,ng11)
+
+      equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
+
+      end module rrlw_kg11
+
+      module rrlw_kg12
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 12
+! band 12:  1800-2080 cm-1 (low - h2o,co2; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+! kao     : real     
+! selfrefo: real     
+! forrefo : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no12 = 16
+
+      real(kind=rb) :: fracrefao(no12,9)
+      real(kind=rb) :: kao(9,5,13,no12)
+      real(kind=rb) :: selfrefo(10,no12)
+      real(kind=rb) :: forrefo(4,no12)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 12
+! band 12:  1800-2080 cm-1 (low - h2o,co2; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+! ka      : real     
+! selfref : real     
+! forref  : real     
+!
+! absa    : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng12 = 8
+
+      real(kind=rb) :: fracrefa(ng12,9)
+      real(kind=rb) :: ka(9,5,13,ng12) ,absa(585,ng12)
+      real(kind=rb) :: selfref(10,ng12)
+      real(kind=rb) :: forref(4,ng12)
+
+      equivalence (ka(1,1,1,1),absa(1,1))
+
+      end module rrlw_kg12
+
+      module rrlw_kg13
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 13
+! band 13:  2080-2250 cm-1 (low - h2o,n2o; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+! kao     : real     
+! kao_mco2: real     
+! kao_mco : real     
+! kbo_mo3 : real     
+! selfrefo: real     
+! forrefo : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no13 = 16
+
+      real(kind=rb) , dimension(no13) :: fracrefbo
+
+      real(kind=rb) :: fracrefao(no13,9)
+      real(kind=rb) :: kao(9,5,13,no13)
+      real(kind=rb) :: kao_mco2(9,19,no13)
+      real(kind=rb) :: kao_mco(9,19,no13)
+      real(kind=rb) :: kbo_mo3(19,no13)
+      real(kind=rb) :: selfrefo(10,no13)
+      real(kind=rb) :: forrefo(4,no13)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 13
+! band 13:  2080-2250 cm-1 (low - h2o,n2o; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+! ka      : real     
+! ka_mco2 : real     
+! ka_mco  : real     
+! kb_mo3  : real     
+! selfref : real     
+! forref  : real     
+!
+! absa    : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng13 = 4
+
+      real(kind=rb) , dimension(ng13) :: fracrefb
+
+      real(kind=rb) :: fracrefa(ng13,9)
+      real(kind=rb) :: ka(9,5,13,ng13) ,absa(585,ng13)
+      real(kind=rb) :: ka_mco2(9,19,ng13)
+      real(kind=rb) :: ka_mco(9,19,ng13)
+      real(kind=rb) :: kb_mo3(19,ng13)
+      real(kind=rb) :: selfref(10,ng13)
+      real(kind=rb) :: forref(4,ng13)
+
+      equivalence (ka(1,1,1,1),absa(1,1))
+
+      end module rrlw_kg13
+
+      module rrlw_kg14
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 14
+! band 14:  2250-2380 cm-1 (low - co2; high - co2)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+!fracrefbo: real    
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no14 = 16
+
+      real(kind=rb) , dimension(no14) :: fracrefao
+      real(kind=rb) , dimension(no14) :: fracrefbo
+
+      real(kind=rb) :: kao(5,13,no14)
+      real(kind=rb) :: kbo(5,13:59,no14)
+      real(kind=rb) :: selfrefo(10,no14)
+      real(kind=rb) :: forrefo(4,no14)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 14
+! band 14:  2250-2380 cm-1 (low - co2; high - co2)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+!fracrefb : real    
+! ka      : real     
+! kb      : real     
+! selfref : real     
+! forref  : real     
+!
+! absa    : real
+! absb    : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng14 = 2
+
+      real(kind=rb) , dimension(ng14) :: fracrefa
+      real(kind=rb) , dimension(ng14) :: fracrefb
+
+      real(kind=rb) :: ka(5,13,ng14)   ,absa(65,ng14)
+      real(kind=rb) :: kb(5,13:59,ng14),absb(235,ng14)
+      real(kind=rb) :: selfref(10,ng14)
+      real(kind=rb) :: forref(4,ng14)
+
+      equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
+
+      end module rrlw_kg14
+
+      module rrlw_kg15
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 15
+! band 15:  2380-2600 cm-1 (low - n2o,co2; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+! kao     : real     
+! kao_mn2 : real     
+! selfrefo: real     
+! forrefo : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no15 = 16
+
+      real(kind=rb) :: fracrefao(no15,9)
+      real(kind=rb) :: kao(9,5,13,no15)
+      real(kind=rb) :: kao_mn2(9,19,no15)
+      real(kind=rb) :: selfrefo(10,no15)
+      real(kind=rb) :: forrefo(4,no15)
+
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 15
+! band 15:  2380-2600 cm-1 (low - n2o,co2; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+! ka      : real     
+! ka_mn2  : real     
+! selfref : real     
+! forref  : real     
+!
+! absa    : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng15 = 2
+
+      real(kind=rb) :: fracrefa(ng15,9)
+      real(kind=rb) :: ka(9,5,13,ng15) ,absa(585,ng15)
+      real(kind=rb) :: ka_mn2(9,19,ng15)
+      real(kind=rb) :: selfref(10,ng15)
+      real(kind=rb) :: forref(4,ng15)
+
+      equivalence (ka(1,1,1,1),absa(1,1))
+
+      end module rrlw_kg15
+
+      module rrlw_kg16
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_lw ORIGINAL abs. coefficients for interval 16
+! band 16:  2600-3000 cm-1 (low - h2o,ch4; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefao: real    
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no16 = 16
+
+      real(kind=rb) , dimension(no16) :: fracrefbo
+
+      real(kind=rb) :: fracrefao(no16,9)
+      real(kind=rb) :: kao(9,5,13,no16)
+      real(kind=rb) :: kbo(5,13:59,no16)
+      real(kind=rb) :: selfrefo(10,no16)
+      real(kind=rb) :: forrefo(4,no16)
+
+!-----------------------------------------------------------------
+! rrtmg_lw COMBINED abs. coefficients for interval 16
+! band 16:  2600-3000 cm-1 (low - h2o,ch4; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!fracrefa : real    
+! ka      : real     
+! kb      : real     
+! selfref : real     
+! forref  : real     
+!
+! absa    : real
+! absb    : real
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: ng16 = 2
+
+      real(kind=rb) , dimension(ng16) :: fracrefb
+
+      real(kind=rb) :: fracrefa(ng16,9)
+      real(kind=rb) :: ka(9,5,13,ng16) ,absa(585,ng16)
+      real(kind=rb) :: kb(5,13:59,ng16), absb(235,ng16)
+      real(kind=rb) :: selfref(10,ng16)
+      real(kind=rb) :: forref(4,ng16)
+
+      equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
+
+      end module rrlw_kg16
+
+
+      module rrlw_ref
+
+      use parkind, only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_lw reference atmosphere 
+! Based on standard mid-latitude summer profile
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+! pref   :  real   : Reference pressure levels
+! preflog:  real   : Reference pressure levels, ln(pref)
+! tref   :  real   : Reference temperature levels for MLS profile
+! chi_mls:  real   : 
+!------------------------------------------------------------------
+
+      real(kind=rb) , dimension(59) :: pref
+      real(kind=rb) , dimension(59) :: preflog
+      real(kind=rb) , dimension(59) :: tref
+      real(kind=rb) :: chi_mls(7,59)
+
+      end module rrlw_ref
+
+      module rrlw_tbl
+
+      use parkind, only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_lw exponential lookup table arrays
+
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, Jun 2006
+! Revised: MJIacono, AER, Aug 2007
+! Revised: MJIacono, AER, Aug 2008
+!------------------------------------------------------------------
+
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+! ntbl   :  integer: Lookup table dimension
+! tblint :  real   : Lookup table conversion factor
+! tau_tbl:  real   : Clear-sky optical depth (used in cloudy radiative
+!                    transfer)
+! exp_tbl:  real   : Transmittance lookup table
+! tfn_tbl:  real   : 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.
+! pade   :  real   : Pade constant   
+! bpade  :  real   : Inverse of Pade constant   
+!------------------------------------------------------------------
+
+      integer(kind=im), parameter :: ntbl = 10000
+
+      real(kind=rb), parameter :: tblint = 10000.0_rb
+
+      real(kind=rb) , dimension(0:ntbl) :: tau_tbl
+      real(kind=rb) , dimension(0:ntbl) :: exp_tbl
+      real(kind=rb) , dimension(0:ntbl) :: tfn_tbl
+
+      real(kind=rb), parameter :: pade = 0.278_rb
+      real(kind=rb) :: bpade
+
+      end module rrlw_tbl
+
+      module rrlw_vsn
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_lw version information
+
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+!hnamrtm :character: 
+!hnamini :character: 
+!hnamcld :character: 
+!hnamclc :character: 
+!hnamrtr :character: 
+!hnamrtx :character: 
+!hnamrtc :character: 
+!hnamset :character: 
+!hnamtau :character: 
+!hnamatm :character: 
+!hnamutl :character: 
+!hnamext :character: 
+!hnamkg  :character: 
+!
+! hvrrtm :character: 
+! hvrini :character: 
+! hvrcld :character: 
+! hvrclc :character: 
+! hvrrtr :character: 
+! hvrrtx :character: 
+! hvrrtc :character: 
+! hvrset :character: 
+! hvrtau :character: 
+! hvratm :character: 
+! hvrutl :character: 
+! hvrext :character: 
+! hvrkg  :character: 
+!------------------------------------------------------------------
+
+      character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrtr,hvrrtx, &
+                   hvrrtc,hvrset,hvrtau,hvratm,hvrutl,hvrext
+      character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrtr,hnamrtx, &
+                   hnamrtc,hnamset,hnamtau,hnamatm,hnamutl,hnamext
+
+      character*18 hvrkg
+      character*20 hnamkg
+
+      end module rrlw_vsn
+
+      module rrlw_wvn
+
+      use parkind, only : im => kind_im, rb => kind_rb
+      use parrrtm, only : nbndlw, mg, ngptlw, maxinpx
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_lw spectral information
+
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+! ng     :  integer: Number of original g-intervals in each spectral band
+! nspa   :  integer: For the lower atmosphere, the number of reference
+!                    atmospheres that are stored for each spectral band
+!                    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   :  integer: Same as nspa for the upper atmosphere
+!wavenum1:  real   : Spectral band lower boundary in wavenumbers
+!wavenum2:  real   : Spectral band upper boundary in wavenumbers
+! delwave:  real   : Spectral band width in wavenumbers
+! totplnk:  real   : Integrated Planck value for each band; (band 16
+!                    includes total from 2600 cm-1 to infinity)
+!                    Used for calculation across total spectrum
+!totplk16:  real   : Integrated Planck value for band 16 (2600-3250 cm-1)
+!                    Used for calculation in band 16 only if 
+!                    individual band output requested
+!
+! ngc    :  integer: The number of new g-intervals in each band
+! ngs    :  integer: The cumulative sum of new g-intervals for each band
+! ngm    :  integer: The index of each new g-interval relative to the
+!                    original 16 g-intervals in each band
+! ngn    :  integer: The number of original g-intervals that are 
+!                    combined to make each new g-intervals in each band
+! ngb    :  integer: The band index for each new g-interval
+! wt     :  real   : RRTM weights for the original 16 g-intervals
+! rwgt   :  real   : Weights for combining original 16 g-intervals 
+!                    (256 total) into reduced set of g-intervals 
+!                    (140 total)
+! nxmol  :  integer: Number of cross-section molecules
+! ixindx :  integer: Flag for active cross-sections in calculation
+!------------------------------------------------------------------
+
+      integer(kind=im) :: ng(nbndlw)
+      integer(kind=im) :: nspa(nbndlw)
+      integer(kind=im) :: nspb(nbndlw)
+
+      real(kind=rb) :: wavenum1(nbndlw)
+      real(kind=rb) :: wavenum2(nbndlw)
+      real(kind=rb) :: delwave(nbndlw)
+
+      real(kind=rb) :: totplnk(181,nbndlw)
+      real(kind=rb) :: totplk16(181)
+
+      integer(kind=im) :: ngc(nbndlw)
+      integer(kind=im) :: ngs(nbndlw)
+      integer(kind=im) :: ngn(ngptlw)
+      integer(kind=im) :: ngb(ngptlw)
+      integer(kind=im) :: ngm(nbndlw*mg)
+
+      real(kind=rb) :: wt(mg)
+      real(kind=rb) :: rwgt(nbndlw*mg)
+
+      integer(kind=im) :: nxmol
+      integer(kind=im) :: ixindx(maxinpx)
+
+      end module rrlw_wvn
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+!
+
+! Fortran-95 implementation of the Mersenne Twister 19937, following 
+!   the C implementation described below (code mt19937ar-cok.c, dated 2002/2/10), 
+!   adapted cosmetically by making the names more general.  
+! Users must declare one or more variables of type randomNumberSequence in the calling 
+!   procedure which are then initialized using a required seed. If the 
+!   variable is not initialized the random numbers will all be 0. 
+! For example: 
+! program testRandoms 
+!   use RandomNumbers
+!   type(randomNumberSequence) :: randomNumbers
+!   integer                    :: i
+!   
+!   randomNumbers = new_RandomNumberSequence(seed = 100)
+!   do i = 1, 10
+!     print ('(f12.10, 2x)'), getRandomReal(randomNumbers)
+!   end do
+! end program testRandoms
+! 
+! Fortran-95 implementation by 
+!   Robert Pincus
+!   NOAA-CIRES Climate Diagnostics Center
+!   Boulder, CO 80305 
+!   email: Robert.Pincus@colorado.edu
+!
+! This documentation in the original C program reads:
+! -------------------------------------------------------------
+!    A C-program for MT19937, with initialization improved 2002/2/10.
+!    Coded by Takuji Nishimura and Makoto Matsumoto.
+!    This is a faster version by taking Shawn Cokus's optimization,
+!    Matthe Bellew's simplification, Isaku Wada's real version.
+! 
+!    Before using, initialize the state by using init_genrand(seed) 
+!    or init_by_array(init_key, key_length).
+! 
+!    Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura,
+!    All rights reserved.                          
+! 
+!    Redistribution and use in source and binary forms, with or without
+!    modification, are permitted provided that the following conditions
+!    are met:
+! 
+!      1. Redistributions of source code must retain the above copyright
+!         notice, this list of conditions and the following disclaimer.
+! 
+!      2. Redistributions in binary form must reproduce the above copyright
+!         notice, this list of conditions and the following disclaimer in the
+!         documentation and/or other materials provided with the distribution.
+! 
+!      3. The names of its contributors may not be used to endorse or promote 
+!         products derived from this software without specific prior written 
+!         permission.
+! 
+!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+!    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+!    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+!    A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR
+!    CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+!    EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+!    PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+!    PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+!    LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+!    NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+!    SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+! 
+! 
+!    Any feedback is very welcome.
+!    http://www.math.keio.ac.jp/matumoto/emt.html
+!    email: matumoto@math.keio.ac.jp
+! -------------------------------------------------------------
+
+  module MersenneTwister
+! -------------------------------------------------------------
+
+  use parkind, only : im => kind_im, rb => kind_rb 
+
+  implicit none
+  private
+  
+  ! Algorithm parameters
+  ! -------
+  ! Period parameters
+  integer(kind=im), parameter :: blockSize = 624,         &
+                        M         = 397,         &
+                        MATRIX_A  = -1727483681, & ! constant vector a         (0x9908b0dfUL)
+                        UMASK     = -2147483647-1, & ! most significant w-r bits (0x80000000UL)
+                        LMASK     =  2147483647    ! least significant r bits  (0x7fffffffUL)
+  ! Tempering parameters
+  integer(kind=im), parameter :: TMASKB= -1658038656, & ! (0x9d2c5680UL)
+                        TMASKC= -272236544     ! (0xefc60000UL)
+  ! -------
+
+  ! The type containing the state variable  
+  type randomNumberSequence
+    integer(kind=im)                            :: currentElement ! = blockSize
+    integer(kind=im), dimension(0:blockSize -1) :: state ! = 0
+  end type randomNumberSequence
+
+  interface new_RandomNumberSequence
+    module procedure initialize_scalar, initialize_vector
+  end interface new_RandomNumberSequence 
+
+  public :: randomNumberSequence
+  public :: new_RandomNumberSequence, finalize_RandomNumberSequence, &
+            getRandomInt, getRandomPositiveInt, getRandomReal
+! -------------------------------------------------------------
+contains
+  ! -------------------------------------------------------------
+  ! Private functions
+  ! ---------------------------
+  function mixbits(u, v)
+    integer(kind=im), intent( in) :: u, v
+    integer(kind=im)              :: mixbits
+    
+    mixbits = ior(iand(u, UMASK), iand(v, LMASK))
+  end function mixbits
+  ! ---------------------------
+  function twist(u, v)
+    integer(kind=im), intent( in) :: u, v
+    integer(kind=im)              :: twist
+
+    ! Local variable
+    integer(kind=im), parameter, dimension(0:1) :: t_matrix = (/ 0_im, MATRIX_A /)
+    
+    twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im)))
+    twist = ieor(ishft(mixbits(u, v), -1_im), t_matrix(iand(v, 1_im)))
+  end function twist
+  ! ---------------------------
+  subroutine nextState(twister)
+    type(randomNumberSequence), intent(inout) :: twister
+    
+    ! Local variables
+    integer(kind=im) :: k
+    
+    do k = 0, blockSize - M - 1
+      twister%state(k) = ieor(twister%state(k + M), &
+                              twist(twister%state(k), twister%state(k + 1_im)))
+    end do 
+    do k = blockSize - M, blockSize - 2
+      twister%state(k) = ieor(twister%state(k + M - blockSize), &
+                              twist(twister%state(k), twister%state(k + 1_im)))
+    end do 
+    twister%state(blockSize - 1_im) = ieor(twister%state(M - 1_im), &
+                                        twist(twister%state(blockSize - 1_im), twister%state(0_im)))
+    twister%currentElement = 0_im
+
+  end subroutine nextState
+  ! ---------------------------
+  elemental function temper(y)
+    integer(kind=im), intent(in) :: y
+    integer(kind=im)             :: temper
+    
+    integer(kind=im) :: x
+    
+    ! Tempering
+    x      = ieor(y, ishft(y, -11))
+    x      = ieor(x, iand(ishft(x,  7), TMASKB))
+    x      = ieor(x, iand(ishft(x, 15), TMASKC))
+    temper = ieor(x, ishft(x, -18))
+  end function temper
+  ! -------------------------------------------------------------
+  ! Public (but hidden) functions
+  ! --------------------
+  function initialize_scalar(seed) result(twister)
+    integer(kind=im),       intent(in   ) :: seed
+    type(randomNumberSequence)                :: twister 
+    
+    integer(kind=im) :: i
+    ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions, 
+    !   MSBs of the seed affect only MSBs of the array state[].                       
+    !   2002/01/09 modified by Makoto Matsumoto            
+    
+    twister%state(0) = iand(seed, -1_im)
+    do i = 1,  blockSize - 1 ! ubound(twister%state)
+       twister%state(i) = 1812433253_im * ieor(twister%state(i-1), &
+                                            ishft(twister%state(i-1), -30_im)) + i
+       twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
+    end do
+    twister%currentElement = blockSize
+  end function initialize_scalar
+  ! -------------------------------------------------------------
+  function initialize_vector(seed) result(twister)
+    integer(kind=im), dimension(0:), intent(in) :: seed
+    type(randomNumberSequence)                      :: twister 
+    
+    integer(kind=im) :: i, j, k, nFirstLoop, nWraps
+    
+    nWraps  = 0
+    twister = initialize_scalar(19650218_im)
+    
+    nFirstLoop = max(blockSize, size(seed))
+    do k = 1, nFirstLoop
+       i = mod(k + nWraps, blockSize)
+       j = mod(k - 1,      size(seed))
+       if(i == 0) then
+         twister%state(i) = twister%state(blockSize - 1)
+         twister%state(1) = ieor(twister%state(1),                                 &
+                                 ieor(twister%state(1-1),                          & 
+                                      ishft(twister%state(1-1), -30_im)) * 1664525_im) + & 
+                            seed(j) + j ! Non-linear
+         twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
+         nWraps = nWraps + 1
+       else
+         twister%state(i) = ieor(twister%state(i),                                 &
+                                 ieor(twister%state(i-1),                          & 
+                                      ishft(twister%state(i-1), -30_im)) * 1664525_im) + & 
+                            seed(j) + j ! Non-linear
+         twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
+      end if
+    end do
+    
+    !
+    ! Walk through the state array, beginning where we left off in the block above
+    ! 
+    do i = mod(nFirstLoop, blockSize) + nWraps + 1, blockSize - 1
+      twister%state(i) = ieor(twister%state(i),                                 &
+                              ieor(twister%state(i-1),                          & 
+                                   ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear
+      twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
+    end do
+    
+    twister%state(0) = twister%state(blockSize - 1) 
+    
+    do i = 1, mod(nFirstLoop, blockSize) + nWraps
+      twister%state(i) = ieor(twister%state(i),                                 &
+                              ieor(twister%state(i-1),                          & 
+                                   ishft(twister%state(i-1), -30_im)) * 1566083941_im) - i ! Non-linear
+      twister%state(i) = iand(twister%state(i), -1_im) ! for >32 bit machines
+    end do
+    
+    twister%state(0) = UMASK 
+    twister%currentElement = blockSize
+    
+  end function initialize_vector
+  ! -------------------------------------------------------------
+  ! Public functions
+  ! --------------------
+  function getRandomInt(twister)
+    type(randomNumberSequence), intent(inout) :: twister
+    integer(kind=im)                        :: getRandomInt
+    ! Generate a random integer on the interval [0,0xffffffff]
+    !   Equivalent to genrand_int32 in the C code. 
+    !   Fortran doesn't have a type that's unsigned like C does, 
+    !   so this is integers in the range -2**31 - 2**31
+    ! All functions for getting random numbers call this one, 
+    !   then manipulate the result
+    
+    if(twister%currentElement >= blockSize) call nextState(twister)
+      
+    getRandomInt = temper(twister%state(twister%currentElement))
+    twister%currentElement = twister%currentElement + 1
+  
+  end function getRandomInt
+  ! --------------------
+  function getRandomPositiveInt(twister)
+    type(randomNumberSequence), intent(inout) :: twister
+    integer(kind=im)                        :: getRandomPositiveInt
+    ! Generate a random integer on the interval [0,0x7fffffff]
+    !   or [0,2**31]
+    !   Equivalent to genrand_int31 in the C code. 
+    
+    ! Local integers
+    integer(kind=im) :: localInt
+
+    localInt = getRandomInt(twister)
+    getRandomPositiveInt = ishft(localInt, -1)
+  
+  end function getRandomPositiveInt
+  ! --------------------
+!! mji - modified Jan 2007, double converted to rrtmg real kind type
+  function getRandomReal(twister)
+    type(randomNumberSequence), intent(inout) :: twister
+!    double precision             :: getRandomReal
+    real(kind=rb)             :: getRandomReal
+    ! Generate a random number on [0,1]
+    !   Equivalent to genrand_real1 in the C code
+    !   The result is stored as double precision but has 32 bit resolution
+    
+    integer(kind=im) :: localInt
+    
+    localInt = getRandomInt(twister)
+    if(localInt < 0) then
+!      getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0)
+      getRandomReal = (localInt + 2.0**32_rb)/(2.0**32_rb - 1.0_rb)
+    else
+!      getRandomReal = dble(localInt            )/(2.0d0**32 - 1.0d0)
+      getRandomReal = (localInt            )/(2.0**32_rb - 1.0_rb)
+    end if
+
+  end function getRandomReal
+  ! --------------------
+  subroutine finalize_RandomNumberSequence(twister)
+    type(randomNumberSequence), intent(inout) :: twister
+    
+      twister%currentElement = blockSize
+      twister%state(:) = 0_im
+  end subroutine finalize_RandomNumberSequence
+
+  ! --------------------  
+  
+  end module MersenneTwister
+
+
+  module mcica_random_numbers
+
+  ! Generic module to wrap random number generators. 
+  !   The module defines a type that identifies the particular stream of random 
+  !   numbers, and has procedures for initializing it and getting real numbers 
+  !   in the range 0 to 1. 
+  ! This version uses the Mersenne Twister to generate random numbers on [0, 1]. 
+  !
+  use MersenneTwister, only: randomNumberSequence, & ! The random number engine.
+                             new_RandomNumberSequence, getRandomReal
+!! mji
+!!  use time_manager_mod, only: time_type, get_date
+
+  use parkind, only : im => kind_im, rb => kind_rb 
+
+  implicit none
+  private
+  
+  type randomNumberStream
+    type(randomNumberSequence) :: theNumbers
+  end type randomNumberStream
+  
+  interface getRandomNumbers
+    module procedure getRandomNumber_Scalar, getRandomNumber_1D, getRandomNumber_2D
+  end interface getRandomNumbers
+  
+  interface initializeRandomNumberStream
+    module procedure initializeRandomNumberStream_S, initializeRandomNumberStream_V
+  end interface initializeRandomNumberStream
+
+  public :: randomNumberStream,                             &
+            initializeRandomNumberStream, getRandomNumbers
+!! mji
+!!            initializeRandomNumberStream, getRandomNumbers, &
+!!            constructSeed
+contains
+  ! ---------------------------------------------------------
+  ! Initialization
+  ! ---------------------------------------------------------
+  function initializeRandomNumberStream_S(seed) result(new) 
+    integer(kind=im), intent( in)     :: seed
+    type(randomNumberStream) :: new
+    
+    new%theNumbers = new_RandomNumberSequence(seed)
+    
+  end function initializeRandomNumberStream_S
+  ! ---------------------------------------------------------
+  function initializeRandomNumberStream_V(seed) result(new) 
+    integer(kind=im), dimension(:), intent( in) :: seed
+    type(randomNumberStream)           :: new
+    
+    new%theNumbers = new_RandomNumberSequence(seed)
+    
+  end function initializeRandomNumberStream_V
+  ! ---------------------------------------------------------
+  ! Procedures for drawing random numbers
+  ! ---------------------------------------------------------
+  subroutine getRandomNumber_Scalar(stream, number)
+    type(randomNumberStream), intent(inout) :: stream
+    real(kind=rb),                     intent(  out) :: number
+    
+    number = getRandomReal(stream%theNumbers)
+  end subroutine getRandomNumber_Scalar
+  ! ---------------------------------------------------------
+  subroutine getRandomNumber_1D(stream, numbers)
+    type(randomNumberStream), intent(inout) :: stream
+    real(kind=rb), dimension(:),       intent(  out) :: numbers
+    
+    ! Local variables
+    integer(kind=im) :: i
+    
+    do i = 1, size(numbers)
+      numbers(i) = getRandomReal(stream%theNumbers)
+    end do
+  end subroutine getRandomNumber_1D
+  ! ---------------------------------------------------------
+  subroutine getRandomNumber_2D(stream, numbers)
+    type(randomNumberStream), intent(inout) :: stream
+    real(kind=rb), dimension(:, :),    intent(  out) :: numbers
+    
+    ! Local variables
+    integer(kind=im) :: i
+    
+    do i = 1, size(numbers, 2)
+      call getRandomNumber_1D(stream, numbers(:, i))
+    end do
+  end subroutine getRandomNumber_2D
+! mji
+!  ! ---------------------------------------------------------
+!  ! Constructing a unique seed from grid cell index and model date/time
+!  !   Once we have the GFDL stuff we'll add the year, month, day, hour, minute
+!  ! ---------------------------------------------------------
+!  function constructSeed(i, j, time) result(seed)
+!    integer(kind=im),         intent( in)  :: i, j
+!    type(time_type), intent( in) :: time
+!    integer(kind=im), dimension(8) :: seed
+!    
+!    ! Local variables
+!    integer(kind=im) :: year, month, day, hour, minute, second
+!    
+!    
+!    call get_date(time, year, month, day, hour, minute, second)
+!    seed = (/ i, j, year, month, day, hour, minute, second /)
+!  end function constructSeed
+
+  end module mcica_random_numbers
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+!
+      module mcica_subcol_gen_lw
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2006-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! Purpose: Create McICA stochastic arrays for cloud physical or optical properties.
+! Two options are possible:
+! 1) Input cloud physical properties: cloud fraction, ice and liquid water
+!    paths, ice fraction, and particle sizes.  Output will be stochastic
+!    arrays of these variables.  (inflag = 1)
+! 2) Input cloud optical properties directly: cloud optical depth, single
+!    scattering albedo and asymmetry parameter.  Output will be stochastic
+!    arrays of these variables.  (inflag = 0; longwave scattering is not
+!    yet available, ssac and asmc are for future expansion)
+
+! --------- Modules ----------
+
+      use parkind, only : im => kind_im, rb => kind_rb
+      use parrrtm, only : nbndlw, ngptlw
+      use rrlw_con, only: grav
+      use rrlw_wvn, only: ngb
+      use rrlw_vsn
+
+      implicit none
+
+! public interfaces/functions/subroutines
+      public :: mcica_subcol_lw, generate_stochastic_clouds 
+
+      contains
+
+!------------------------------------------------------------------
+! Public subroutines
+!------------------------------------------------------------------
+
+      subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
+                       cldfrac, ciwp, clwp, rei, rel, tauc, cldfmcl, &
+                       ciwpmcl, clwpmcl, reicmcl, relqmcl, taucmcl)
+
+! ----- Input -----
+! Control
+      integer(kind=im), intent(in) :: iplon           ! column/longitude index
+      integer(kind=im), intent(in) :: ncol            ! number of columns
+      integer(kind=im), intent(in) :: nlay            ! number of model layers
+      integer(kind=im), intent(in) :: icld            ! clear/cloud, cloud overlap flag
+      integer(kind=im), intent(in) :: permuteseed     ! if the cloud generator is called multiple times, 
+                                                      ! permute the seed between each call.
+                                                      ! between calls for LW and SW, recommended
+                                                      ! permuteseed differes by 'ngpt'
+      integer(kind=im), intent(inout) :: irng         ! flag for random number generator
+                                                      !  0 = kissvec
+                                                      !  1 = Mersenne Twister
+
+! Atmosphere
+      real(kind=rb), intent(in) :: play(:,:)          ! layer pressures (mb) 
+                                                      !    Dimensions: (ncol,nlay)
+
+! Atmosphere/clouds - cldprop
+      real(kind=rb), intent(in) :: cldfrac(:,:)       ! layer cloud fraction
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: tauc(:,:,:)        ! in-cloud optical depth
+                                                      !    Dimensions: (nbndlw,ncol,nlay)
+!      real(kind=rb), intent(in) :: ssac(:,:,:)       ! in-cloud single scattering albedo
+                                                      !    Dimensions: (nbndlw,ncol,nlay)
+!      real(kind=rb), intent(in) :: asmc(:,:,:)       ! in-cloud asymmetry parameter
+                                                      !    Dimensions: (nbndlw,ncol,nlay)
+      real(kind=rb), intent(in) :: ciwp(:,:)          ! in-cloud ice water path
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: clwp(:,:)          ! in-cloud liquid water path
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: rei(:,:)           ! cloud ice particle size
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: rel(:,:)           ! cloud liquid particle size
+                                                      !    Dimensions: (ncol,nlay)
+
+! ----- Output -----
+! Atmosphere/clouds - cldprmc [mcica]
+      real(kind=rb), intent(out) :: cldfmcl(:,:,:)    ! cloud fraction [mcica]
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(out) :: ciwpmcl(:,:,:)    ! in-cloud ice water path [mcica]
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(out) :: clwpmcl(:,:,:)    ! in-cloud liquid water path [mcica]
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(out) :: relqmcl(:,:)      ! liquid particle size (microns)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(out) :: reicmcl(:,:)      ! ice partcle size (microns)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(out) :: taucmcl(:,:,:)    ! in-cloud optical depth [mcica]
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+!      real(kind=rb), intent(out) :: ssacmcl(:,:,:)   ! in-cloud single scattering albedo [mcica]
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+!      real(kind=rb), intent(out) :: asmcmcl(:,:,:)   ! in-cloud asymmetry parameter [mcica]
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+
+! ----- Local -----
+
+! Stochastic cloud generator variables [mcica]
+      integer(kind=im), parameter :: nsubclw = ngptlw ! number of sub-columns (g-point intervals)
+      integer(kind=im) :: ilev                        ! loop index
+
+      real(kind=rb) :: pmid(ncol, nlay)               ! layer pressures (Pa) 
+!      real(kind=rb) :: pdel(ncol, nlay)              ! layer pressure thickness (Pa) 
+!      real(kind=rb) :: qi(ncol, nlay)                ! ice water (specific humidity)
+!      real(kind=rb) :: ql(ncol, nlay)                ! liq water (specific humidity)
+
+
+! Return if clear sky; or stop if icld out of range
+      if (icld.eq.0) return
+      if (icld.lt.0.or.icld.gt.3) then 
+         stop 'MCICA_SUBCOL: INVALID ICLD'
+      endif 
+
+! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least the number of subcolumns
+
+
+! Pass particle sizes to new arrays, no subcolumns for these properties yet
+! Convert pressures from mb to Pa
+
+      reicmcl(:ncol,:nlay) = rei(:ncol,:nlay)
+      relqmcl(:ncol,:nlay) = rel(:ncol,:nlay)
+      pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb
+
+! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components 
+
+!      cwp =  (q * pdel * 1000.) / gravit)
+!           = (kg/kg * kg m-1 s-2 *1000.) / m s-2
+!           = (g m-2)
+!
+!      q  = (cwp * gravit) / (pdel *1000.)
+!         = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.)
+!         =  kg/kg
+
+!      do ilev = 1, nlay
+!         qi(ilev) = (ciwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
+!         ql(ilev) = (clwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
+!      enddo
+
+!  Generate the stochastic subcolumns of cloud optical properties for the longwave;
+      call generate_stochastic_clouds (ncol, nlay, nsubclw, icld, irng, pmid, cldfrac, clwp, ciwp, tauc, &
+                               cldfmcl, clwpmcl, ciwpmcl, taucmcl, permuteseed)
+
+      end subroutine mcica_subcol_lw
+
+
+!-------------------------------------------------------------------------------------------------
+      subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, cld, clwp, ciwp, tauc, &
+                                   cld_stoch, clwp_stoch, ciwp_stoch, tauc_stoch, changeSeed) 
+!-------------------------------------------------------------------------------------------------
+
+  !----------------------------------------------------------------------------------------------------------------
+  ! ---------------------
+  ! Contact: Cecile Hannay (hannay@ucar.edu)
+  ! 
+  ! Original code: Based on Raisanen et al., QJRMS, 2004.
+  ! 
+  ! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default
+  !   random number generator, which can be changed to the optional kissvec random number generator
+  !   with flag 'irng'. Some extra functionality has been commented or removed.  
+  !   Michael J. Iacono, AER, Inc., February 2007
+  !
+  ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns.
+  ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one 
+  ! and uniform cloud liquid and cloud ice concentration.
+  ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer 
+  ! and obeys an overlap assumption in the vertical.   
+  ! 
+  ! Overlap assumption:
+  !  The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential. 
+  !  The default option is maximum-random (option 3)
+  !  The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap
+  !  This is set with the variable "overlap" 
+  !mji - Exponential overlap option (overlap=4) has been deactivated in this version
+  !  The exponential overlap uses also a length scale, Zo. (real,    parameter  :: Zo = 2500. ) 
+  ! 
+  ! Seed:
+  !  If the stochastic cloud generator is called several times during the same timestep, 
+  !  one should change the seed between the call to insure that the subcolumns are different.
+  !  This is done by changing the argument 'changeSeed'
+  !  For example, if one wants to create a set of columns for the shortwave and another set for the longwave ,
+  !  use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call 
+  !
+  ! PDF assumption:
+  !  We can use arbitrary complicated PDFS. 
+  !  In the present version, we produce homogeneuous clouds (the simplest case).  
+  !  Future developments include using the PDF scheme of Ben Johnson. 
+  !
+  ! History file:
+  !  Option to add diagnostics variables in the history file. (using FINCL in the namelist)
+  !  nsubcol = number of subcolumns
+  !  overlap = overlap type (1-3)
+  !  Zo = length scale 
+  !  CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic)
+  !  CLDLIQ_S = mean of the subcolumn cloud water
+  !  CLDICE_S = mean of the subcolumn cloud ice 
+  !
+  ! Note:
+  !   Here: we force that the cloud condensate to be consistent with the cloud fraction 
+  !   i.e we only have cloud condensate when the cell is cloudy. 
+  !   In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations 
+  !   and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction 
+  !   without cloud condensate or the opposite).
+  !---------------------------------------------------------------------------------------------------------------
+
+      use mcica_random_numbers
+! The Mersenne Twister random number engine
+      use MersenneTwister, only: randomNumberSequence, &   
+                                 new_RandomNumberSequence, getRandomReal
+
+      type(randomNumberSequence) :: randomNumbers
+
+! -- Arguments
+
+      integer(kind=im), intent(in) :: ncol            ! number of columns
+      integer(kind=im), intent(in) :: nlay            ! number of layers
+      integer(kind=im), intent(in) :: icld            ! clear/cloud, cloud overlap flag
+      integer(kind=im), intent(inout) :: irng         ! flag for random number generator
+                                                      !  0 = kissvec
+                                                      !  1 = Mersenne Twister
+      integer(kind=im), intent(in) :: nsubcol         ! number of sub-columns (g-point intervals)
+      integer(kind=im), optional, intent(in) :: changeSeed     ! allows permuting seed
+
+! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state 
+      real(kind=rb), intent(in) :: pmid(:,:)          ! layer pressure (Pa)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: cld(:,:)           ! cloud fraction 
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: clwp(:,:)          ! in-cloud liquid water path
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: ciwp(:,:)          ! in-cloud ice water path
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: tauc(:,:,:)        ! in-cloud optical depth
+                                                      !    Dimensions: (nbndlw,ncol,nlay)
+!      real(kind=rb), intent(in) :: ssac(:,:,:)       ! in-cloud single scattering albedo
+                                                      !    Dimensions: (nbndlw,ncol,nlay)
+                                                      !   inactive - for future expansion
+!      real(kind=rb), intent(in) :: asmc(:,:,:)       ! in-cloud asymmetry parameter
+                                                      !    Dimensions: (nbndlw,ncol,nlay)
+                                                      !   inactive - for future expansion
+
+      real(kind=rb), intent(out) :: cld_stoch(:,:,:)  ! subcolumn cloud fraction 
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+!      real(kind=rb), intent(out) :: ssac_stoch(:,:,:)! subcolumn in-cloud single scattering albedo
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+                                                      !   inactive - for future expansion
+!      real(kind=rb), intent(out) :: asmc_stoch(:,:,:)! subcolumn in-cloud asymmetry parameter
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+                                                      !   inactive - for future expansion
+
+! -- Local variables
+      real(kind=rb) :: cldf(ncol,nlay)                ! cloud fraction 
+    
+! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive
+!      real(kind=rb) :: mean_cld_stoch(ncol, nlay)    ! cloud fraction 
+!      real(kind=rb) :: mean_clwp_stoch(ncol, nlay)   ! cloud water
+!      real(kind=rb) :: mean_ciwp_stoch(ncol, nlay)   ! cloud ice
+!      real(kind=rb) :: mean_tauc_stoch(ncol, nlay)   ! cloud optical depth
+!      real(kind=rb) :: mean_ssac_stoch(ncol, nlay)   ! cloud single scattering albedo
+!      real(kind=rb) :: mean_asmc_stoch(ncol, nlay)   ! cloud asymmetry parameter
+
+! Set overlap
+      integer(kind=im) :: overlap                     ! 1 = random overlap, 2 = maximum/random,
+                                                      ! 3 = maximum overlap, 
+!      real(kind=rb), parameter  :: Zo = 2500._rb        ! length scale (m) 
+!      real(kind=rb) :: zm(ncol,nlay)                 ! Height of midpoints (above surface)
+!      real(kind=rb), dimension(nlay) :: alpha=0.0_rb    ! overlap parameter  
+
+! Constants (min value for cloud fraction and cloud water and ice)
+      real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction
+!      real(kind=rb), parameter :: qmin   = 1.0e-10_rb   ! min cloud water and cloud ice (not used)
+
+! Variables related to random number and seed 
+      real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2      ! random numbers
+      integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number (kissvec)
+      real(kind=rb), dimension(ncol) :: rand_num      ! random number (kissvec)
+      integer(kind=im) :: iseed                       ! seed to create random number (Mersenne Teister)
+      real(kind=rb) :: rand_num_mt                    ! random number (Mersenne Twister)
+
+! Flag to identify cloud fraction in subcolumns
+      logical,  dimension(nsubcol, ncol, nlay) :: iscloudy   ! flag that says whether a gridbox is cloudy
+
+! Indices
+      integer(kind=im) :: ilev, isubcol, i, n         ! indices
+
+!------------------------------------------------------------------------------------------ 
+
+! Check that irng is in bounds; if not, set to default
+      if (irng .ne. 0) irng = 1
+
+! Pass input cloud overlap setting to local variable
+      overlap = icld
+
+! Ensure that cloud fractions are in bounds 
+      do ilev = 1, nlay
+         do i = 1, ncol
+            cldf(i,ilev) = cld(i,ilev)
+            if (cldf(i,ilev) < cldmin) then
+               cldf(i,ilev) = 0._rb
+            endif
+         enddo
+      enddo
+
+! ----- Create seed  --------
+   
+! Advance randum number generator by changeseed values
+      if (irng.eq.0) then   
+! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works.  
+! Must use pmid from bottom four layers. 
+         do i=1,ncol
+            if (pmid(i,1).lt.pmid(i,2)) then 
+               stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM BOTTOM FOUR LAYERS.'
+            endif 
+            seed1(i) = (pmid(i,1) - int(pmid(i,1)))  * 1000000000_im
+            seed2(i) = (pmid(i,2) - int(pmid(i,2)))  * 1000000000_im
+            seed3(i) = (pmid(i,3) - int(pmid(i,3)))  * 1000000000_im
+            seed4(i) = (pmid(i,4) - int(pmid(i,4)))  * 1000000000_im
+          enddo
+         do i=1,changeSeed
+            call kissvec(seed1, seed2, seed3, seed4, rand_num)
+         enddo
+      elseif (irng.eq.1) then
+         randomNumbers = new_RandomNumberSequence(seed = changeSeed)
+      endif 
+
+
+! ------ Apply overlap assumption --------
+
+! generate the random numbers  
+
+      select case (overlap)
+
+      case(1) 
+! Random overlap
+! i) pick a random value at every level
+  
+         if (irng.eq.0) then 
+            do isubcol = 1,nsubcol
+               do ilev = 1,nlay
+                  call kissvec(seed1, seed2, seed3, seed4, rand_num)  ! we get different random number for each level
+                  CDF(isubcol,:,ilev) = rand_num
+               enddo
+            enddo
+         elseif (irng.eq.1) then
+            do isubcol = 1, nsubcol
+               do i = 1, ncol
+                  do ilev = 1, nlay
+                     rand_num_mt = getRandomReal(randomNumbers)
+                     CDF(isubcol,i,ilev) = rand_num_mt
+                  enddo
+               enddo
+             enddo
+         endif
+
+      case(2) 
+! Maximum-Random overlap
+! i) pick a random number for top layer.
+! ii) walk down the column: 
+!    - if the layer above is cloudy, we use the same random number than in the layer above
+!    - if the layer above is clear, we use a new random number 
+
+         if (irng.eq.0) then 
+            do isubcol = 1,nsubcol
+               do ilev = 1,nlay
+                  call kissvec(seed1, seed2, seed3, seed4, rand_num) 
+                  CDF(isubcol,:,ilev) = rand_num
+               enddo
+            enddo
+         elseif (irng.eq.1) then
+            do isubcol = 1, nsubcol
+               do i = 1, ncol
+                  do ilev = 1, nlay
+                     rand_num_mt = getRandomReal(randomNumbers)
+                     CDF(isubcol,i,ilev) = rand_num_mt
+                  enddo
+               enddo
+             enddo
+         endif
+
+         do ilev = 2,nlay
+            do i = 1, ncol
+               do isubcol = 1, nsubcol
+                  if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) ) then
+                     CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1) 
+                  else
+                     CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb - cldf(i,ilev-1)) 
+                  endif
+               enddo
+            enddo
+         enddo
+       
+      case(3) 
+! Maximum overlap
+! i) pick the same random numebr at every level  
+
+         if (irng.eq.0) then 
+            do isubcol = 1,nsubcol
+               call kissvec(seed1, seed2, seed3, seed4, rand_num)
+               do ilev = 1,nlay
+                  CDF(isubcol,:,ilev) = rand_num
+               enddo
+            enddo
+         elseif (irng.eq.1) then
+            do isubcol = 1, nsubcol
+               do i = 1, ncol
+                  rand_num_mt = getRandomReal(randomNumbers)
+                  do ilev = 1, nlay
+                     CDF(isubcol,i,ilev) = rand_num_mt
+                  enddo
+               enddo
+             enddo
+         endif
+
+!    case(4) - inactive
+!       ! Exponential overlap: weighting between maximum and random overlap increases with the distance. 
+!       ! The random numbers for exponential overlap verify:
+!       ! j=1   RAN(j)=RND1
+!       ! j>1   if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1)
+!       !                                 RAN(j) = RND2
+!       ! alpha is obtained from the equation
+!       ! alpha = exp(- (Zi-Zj-1)/Zo) where Zo is a characteristic length scale    
+
+
+!       ! compute alpha
+!       zm    = state%zm     
+!       alpha(:, 1) = 0.
+!       do ilev = 2,nlay
+!          alpha(:, ilev) = exp( -( zm (:, ilev-1) -  zm (:, ilev)) / Zo)
+!       end do
+       
+!       ! generate 2 streams of random numbers
+!       do isubcol = 1,nsubcol
+!          do ilev = 1,nlay
+!             call kissvec(seed1, seed2, seed3, seed4, rand_num)
+!             CDF(isubcol, :, ilev) = rand_num
+!             call kissvec(seed1, seed2, seed3, seed4, rand_num)
+!             CDF2(isubcol, :, ilev) = rand_num
+!          end do
+!       end do
+
+!       ! generate random numbers
+!       do ilev = 2,nlay
+!          where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) )
+!             CDF(:,:,ilev) = CDF(:,:,ilev-1) 
+!          end where
+!       end do
+
+      end select
+
+ 
+! -- generate subcolumns for homogeneous clouds -----
+      do ilev = 1,nlay
+         iscloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) )
+      enddo
+
+! where the subcolumn is cloudy, the subcolumn cloud fraction is 1;
+! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0;
+! where there is a cloud, define the subcolumn cloud properties, 
+! otherwise set these to zero
+
+      do ilev = 1,nlay
+         do i = 1, ncol
+            do isubcol = 1, nsubcol
+               if (iscloudy(isubcol,i,ilev) ) then
+                  cld_stoch(isubcol,i,ilev) = 1._rb
+                  clwp_stoch(isubcol,i,ilev) = clwp(i,ilev)
+                  ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev)
+                  n = ngb(isubcol)
+                  tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev)
+!                  ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev)
+!                  asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev)
+               else
+                  cld_stoch(isubcol,i,ilev) = 0._rb
+                  clwp_stoch(isubcol,i,ilev) = 0._rb
+                  ciwp_stoch(isubcol,i,ilev) = 0._rb
+                  tauc_stoch(isubcol,i,ilev) = 0._rb
+!                  ssac_stoch(isubcol,i,ilev) = 1._rb
+!                  asmc_stoch(isubcol,i,ilev) = 1._rb
+               endif
+            enddo
+         enddo
+      enddo
+
+! -- compute the means of the subcolumns ---
+!      mean_cld_stoch(:,:) = 0._rb
+!      mean_clwp_stoch(:,:) = 0._rb
+!      mean_ciwp_stoch(:,:) = 0._rb
+!      mean_tauc_stoch(:,:) = 0._rb
+!      mean_ssac_stoch(:,:) = 0._rb
+!      mean_asmc_stoch(:,:) = 0._rb
+!      do i = 1, nsubcol
+!         mean_cld_stoch(:,:) =  cld_stoch(i,:,:) + mean_cld_stoch(:,:) 
+!         mean_clwp_stoch(:,:) =  clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) 
+!         mean_ciwp_stoch(:,:) =  ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) 
+!         mean_tauc_stoch(:,:) =  tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) 
+!         mean_ssac_stoch(:,:) =  ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) 
+!         mean_asmc_stoch(:,:) =  asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) 
+!      end do
+!      mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol
+!      mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol
+!      mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol
+!      mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol
+!      mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol
+!      mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol
+
+      end subroutine generate_stochastic_clouds
+
+
+!------------------------------------------------------------------
+! Private subroutines
+!------------------------------------------------------------------
+
+!-------------------------------------------------------------------------------------------------- 
+      subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr)
+!-------------------------------------------------------------------------------------------------- 
+
+! public domain code
+! made available from http://www.fortran.com/
+! downloaded by pjr on 03/16/04 for NCAR CAM
+! converted to vector form, functions inlined by pjr,mvr on 05/10/2004
+
+! The  KISS (Keep It Simple Stupid) random number generator. Combines:
+! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32.
+! (2) A 3-shift shift-register generator, period 2^32-1,
+! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59
+!  Overall period>2^123; 
+!
+      real(kind=rb), dimension(:), intent(inout)  :: ran_arr
+      integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4
+      integer(kind=im) :: i,sz,kiss
+      integer(kind=im) :: m, k, n
+
+! inline function 
+      m(k, n) = ieor (k, ishft (k, n) )
+
+      sz = size(ran_arr)
+      do i = 1, sz
+         seed1(i) = 69069_im * seed1(i) + 1327217885_im
+         seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im)
+         seed3(i) = 18000_im * iand (seed3(i), 65535_im) + ishft (seed3(i), - 16_im)
+         seed4(i) = 30903_im * iand (seed4(i), 65535_im) + ishft (seed4(i), - 16_im)
+         kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i)
+         ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb
+      end do
+    
+      end subroutine kissvec
+
+      end module mcica_subcol_gen_lw
+
+!     path:      $Source: /storm/rc1/cvsroot/rc/rrtmg_lw/src/rrtmg_lw_cldprmc.f90,v $
+!     author:    $Author: mike $
+!     revision:  $Revision: 1.8 $
+!     created:   $Date: 2009/05/22 21:04:30 $
+!
+      module rrtmg_lw_cldprmc
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! --------- Modules ----------
+
+      use parkind, only : im => kind_im, rb => kind_rb
+      use parrrtm, only : ngptlw, nbndlw
+      use rrlw_cld, only: abscld1, absliq0, absliq1, &
+                          absice0, absice1, absice2, absice3
+      use rrlw_wvn, only: ngb
+      use rrlw_vsn, only: hvrclc, hnamclc
+
+      implicit none
+
+      contains
+
+! ------------------------------------------------------------------------------
+      subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, &
+                         ciwpmc, clwpmc, reicmc, relqmc, ncbands, taucmc)
+! ------------------------------------------------------------------------------
+
+! Purpose:  Compute the cloud optical depth(s) for each cloudy layer.
+
+! ------- Input -------
+
+      integer(kind=im), intent(in) :: nlayers         ! total number of layers
+      integer(kind=im), intent(in) :: inflag          ! see definitions
+      integer(kind=im), intent(in) :: iceflag         ! see definitions
+      integer(kind=im), intent(in) :: liqflag         ! see definitions
+
+      real(kind=rb), intent(in) :: cldfmc(:,:)        ! cloud fraction [mcica]
+                                                      !    Dimensions: (ngptlw,nlayers)
+      real(kind=rb), intent(in) :: ciwpmc(:,:)        ! cloud ice water path [mcica]
+                                                      !    Dimensions: (ngptlw,nlayers)
+      real(kind=rb), intent(in) :: clwpmc(:,:)        ! cloud liquid water path [mcica]
+                                                      !    Dimensions: (ngptlw,nlayers)
+      real(kind=rb), intent(in) :: relqmc(:)          ! liquid particle effective radius (microns)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: reicmc(:)          ! ice particle effective radius (microns)
+                                                      !    Dimensions: (nlayers)
+                                                      ! specific definition of reicmc depends on setting of iceflag:
+                                                      ! iceflag = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
+                                                      !              r_ec must be >= 10.0 microns
+                                                      ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
+                                                      !              r_ec range is limited to 13.0 to 130.0 microns
+                                                      ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
+                                                      !              r_k range is limited to 5.0 to 131.0 microns
+                                                      ! iceflag = 3: generalized effective size, dge, (Fu, 1996),
+                                                      !              dge range is limited to 5.0 to 140.0 microns
+                                                      !              [dge = 1.0315 * r_ec]
+
+! ------- Output -------
+
+      integer(kind=im), intent(out) :: ncbands        ! number of cloud spectral bands
+      real(kind=rb), intent(inout) :: taucmc(:,:)     ! cloud optical depth [mcica]
+                                                      !    Dimensions: (ngptlw,nlayers)
+
+! ------- Local -------
+
+      integer(kind=im) :: lay                         ! Layer index
+      integer(kind=im) :: ib                          ! spectral band index
+      integer(kind=im) :: ig                          ! g-point interval index
+      integer(kind=im) :: index 
+      integer(kind=im) :: icb(nbndlw)
+
+      real(kind=rb) :: abscoice(ngptlw)               ! ice absorption coefficients
+      real(kind=rb) :: abscoliq(ngptlw)               ! liquid absorption coefficients
+      real(kind=rb) :: cwp                            ! cloud water path
+      real(kind=rb) :: radice                         ! cloud ice effective size (microns)
+      real(kind=rb) :: factor                         ! 
+      real(kind=rb) :: fint                           ! 
+      real(kind=rb) :: radliq                         ! cloud liquid droplet radius (microns)
+      real(kind=rb), parameter :: eps = 1.e-6_rb      ! epsilon
+      real(kind=rb), parameter :: cldmin = 1.e-20_rb  ! minimum value for cloud quantities
+
+! ------- Definitions -------
+
+!     Explanation of the method for each value of INFLAG.  Values of
+!     0 or 1 for INFLAG do not distingish being liquid and ice clouds.
+!     INFLAG = 2 does distinguish between liquid and ice clouds, and
+!     requires further user input to specify the method to be used to 
+!     compute the aborption due to each.
+!     INFLAG = 0:  For each cloudy layer, the cloud fraction and (gray)
+!                  optical depth are input.  
+!     INFLAG = 1:  For each cloudy layer, the cloud fraction and cloud
+!                  water path (g/m2) are input.  The (gray) cloud optical 
+!                  depth is computed as in CCM2.
+!     INFLAG = 2:  For each cloudy layer, the cloud fraction, cloud 
+!                  water path (g/m2), and cloud ice fraction are input.
+!       ICEFLAG = 0:  The ice effective radius (microns) is input and the
+!                     optical depths due to ice clouds are computed as in CCM3.
+!       ICEFLAG = 1:  The ice effective radius (microns) is input and the
+!                     optical depths due to ice clouds are computed as in 
+!                     Ebert and Curry, JGR, 97, 3831-3836 (1992).  The 
+!                     spectral regions in this work have been matched with
+!                     the spectral bands in RRTM to as great an extent 
+!                     as possible:  
+!                     E&C 1      IB = 5      RRTM bands 9-16
+!                     E&C 2      IB = 4      RRTM bands 6-8
+!                     E&C 3      IB = 3      RRTM bands 3-5
+!                     E&C 4      IB = 2      RRTM band 2
+!                     E&C 5      IB = 1      RRTM band 1
+!       ICEFLAG = 2:  The ice effective radius (microns) is input and the
+!                     optical properties due to ice clouds are computed from
+!                     the optical properties stored in the RT code,
+!                     STREAMER v3.0 (Reference: Key. J., Streamer 
+!                     User's Guide, Cooperative Institute for
+!                     Meteorological Satellite Studies, 2001, 96 pp.).
+!                     Valid range of values for re are between 5.0 and
+!                     131.0 micron.
+!       ICEFLAG = 3: The ice generalized effective size (dge) is input
+!                    and the optical properties, are calculated as in
+!                    Q. Fu, J. Climate, (1998). Q. Fu provided high resolution
+!                    tables which were appropriately averaged for the
+!                    bands in RRTM_LW.  Linear interpolation is used to
+!                    get the coefficients from the stored tables.
+!                    Valid range of values for dge are between 5.0 and
+!                    140.0 micron.
+!       LIQFLAG = 0:  The optical depths due to water clouds are computed as
+!                     in CCM3.
+!       LIQFLAG = 1:  The water droplet effective radius (microns) is input 
+!                     and the optical depths due to water clouds are computed 
+!                     as in Hu and Stamnes, J., Clim., 6, 728-742, (1993).
+!                     The values for absorption coefficients appropriate for
+!                     the spectral bands in RRTM have been obtained for a 
+!                     range of effective radii by an averaging procedure 
+!                     based on the work of J. Pinto (private communication).
+!                     Linear interpolation is used to get the absorption 
+!                     coefficients for the input effective radius.
+
+      data icb /1,2,3,3,3,4,4,4,5, 5, 5, 5, 5, 5, 5, 5/
+
+      hvrclc = '$Revision: 1.8 $'
+
+      ncbands = 1
+
+! This initialization is done in rrtmg_lw_subcol.F90.
+!      do lay = 1, nlayers
+!         do ig = 1, ngptlw
+!            taucmc(ig,lay) = 0.0_rb
+!         enddo
+!      enddo
+
+! Main layer loop
+      do lay = 1, nlayers
+
+        do ig = 1, ngptlw
+          cwp = ciwpmc(ig,lay) + clwpmc(ig,lay)
+          if (cldfmc(ig,lay) .ge. cldmin .and. &
+             (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then
+
+! Ice clouds and water clouds combined.
+            if (inflag .eq. 0) then
+! Cloud optical depth already defined in taucmc, return to main program
+               return
+
+            elseif(inflag .eq. 1) then 
+                stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA'
+!               cwp = ciwpmc(ig,lay) + clwpmc(ig,lay)
+!               taucmc(ig,lay) = abscld1 * cwp
+
+! Separate treatement of ice clouds and water clouds.
+            elseif(inflag .eq. 2) then
+               radice = reicmc(lay)
+
+! Calculation of absorption coefficients due to ice clouds.
+               if (ciwpmc(ig,lay) .eq. 0.0_rb) then
+                  abscoice(ig) = 0.0_rb
+
+               elseif (iceflag .eq. 0) then
+                  if (radice .lt. 10.0_rb) stop 'ICE RADIUS TOO SMALL'
+                  abscoice(ig) = absice0(1) + absice0(2)/radice
+
+               elseif (iceflag .eq. 1) then
+                  if (radice .lt. 13.0_rb .or. radice .gt. 130._rb) stop &
+                      'ICE RADIUS OUT OF BOUNDS'
+                  ncbands = 5
+                  ib = icb(ngb(ig))
+                  abscoice(ig) = absice1(1,ib) + absice1(2,ib)/radice
+
+! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns
+
+               elseif (iceflag .eq. 2) then
+                  if (radice .lt. 5.0_rb .or. radice .gt. 131.0_rb) stop 'ICE RADIUS OUT OF BOUNDS'
+                     ncbands = 16
+                     factor = (radice - 2._rb)/3._rb
+                     index = int(factor)
+                     if (index .eq. 43) index = 42
+                     fint = factor - float(index)
+                     ib = ngb(ig)
+                     abscoice(ig) = &
+                         absice2(index,ib) + fint * &
+                         (absice2(index+1,ib) - (absice2(index,ib))) 
+               
+! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns
+
+               elseif (iceflag .eq. 3) then
+                  if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'
+                     ncbands = 16
+                     factor = (radice - 2._rb)/3._rb
+                     index = int(factor)
+                     if (index .eq. 46) index = 45
+                     fint = factor - float(index)
+                     ib = ngb(ig)
+                     abscoice(ig) = &
+                         absice3(index,ib) + fint * &
+                         (absice3(index+1,ib) - (absice3(index,ib)))
+   
+               endif
+                  
+! Calculation of absorption coefficients due to water clouds.
+               if (clwpmc(ig,lay) .eq. 0.0_rb) then
+                  abscoliq(ig) = 0.0_rb
+
+               elseif (liqflag .eq. 0) then
+                   abscoliq(ig) = absliq0
+
+               elseif (liqflag .eq. 1) then
+                  radliq = relqmc(lay)
+                  if (radliq .lt. 2.5_rb .or. radliq .gt. 60._rb) stop &
+                       'LIQUID EFFECTIVE RADIUS OUT OF BOUNDS'
+                  index = int(radliq - 1.5_rb)
+                  if (index .eq. 0) index = 1
+                  if (index .eq. 58) index = 57
+                  fint = radliq - 1.5_rb - float(index)
+                  ib = ngb(ig)
+                  abscoliq(ig) = &
+                        absliq1(index,ib) + fint * &
+                        (absliq1(index+1,ib) - (absliq1(index,ib)))
+               endif
+
+               taucmc(ig,lay) = ciwpmc(ig,lay) * abscoice(ig) + &
+                                clwpmc(ig,lay) * abscoliq(ig)
+
+            endif
+         endif
+         enddo
+      enddo
+
+      end subroutine cldprmc
+
+      end module rrtmg_lw_cldprmc
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+!
+      module rrtmg_lw_rtrnmc
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! --------- Modules ----------
+
+      use parkind, only : im => kind_im, rb => kind_rb
+      use parrrtm, only : mg, nbndlw, ngptlw
+      use rrlw_con, only: fluxfac, heatfac
+      use rrlw_wvn, only: delwave, ngb, ngs
+      use rrlw_tbl, only: tblint, bpade, tau_tbl, exp_tbl, tfn_tbl
+      use rrlw_vsn, only: hvrrtc, hnamrtc
+
+      implicit none
+
+      real(kind=rb) :: wtdiff, rec_6
+      real(kind=rb) :: a0(nbndlw),a1(nbndlw),a2(nbndlw)! diffusivity angle adjustment coefficients
+
+! This secant and weight corresponds to the standard diffusivity 
+! angle.  This initial value is redefined below for some bands.
+      data wtdiff /0.5_rb/
+      data rec_6 /0.166667_rb/
+
+! Reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50
+! and 1.80) as a function of total column water vapor.  The function
+! has been defined to minimize flux and cooling rate errors in these bands
+! over a wide range of precipitable water values.
+      data a0 / 1.66_rb,  1.55_rb,  1.58_rb,  1.66_rb, &
+                1.54_rb, 1.454_rb,  1.89_rb,  1.33_rb, &
+               1.668_rb,  1.66_rb,  1.66_rb,  1.66_rb, &
+                1.66_rb,  1.66_rb,  1.66_rb,  1.66_rb /
+      data a1 / 0.00_rb,  0.25_rb,  0.22_rb,  0.00_rb, &
+                0.13_rb, 0.446_rb, -0.10_rb,  0.40_rb, &
+              -0.006_rb,  0.00_rb,  0.00_rb,  0.00_rb, &
+                0.00_rb,  0.00_rb,  0.00_rb,  0.00_rb /
+      data a2 / 0.00_rb, -12.0_rb, -11.7_rb,  0.00_rb, &
+               -0.72_rb,-0.243_rb,  0.19_rb,-0.062_rb, &
+               0.414_rb,  0.00_rb,  0.00_rb,  0.00_rb, &
+                0.00_rb,  0.00_rb,  0.00_rb,  0.00_rb /
+
+      contains
+
+!-----------------------------------------------------------------------------
+      subroutine rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, &
+                        cldfmc, taucmc, planklay, planklev, plankbnd, &
+                        pwvcm, fracs, taut, &
+                        totuflux, totdflux, fnet, htr, &
+                        totuclfl, totdclfl, fnetc, htrc ) 
+!-----------------------------------------------------------------------------
+!
+!  Original version:   E. J. Mlawer, et al. RRTM_V3.0
+!  Revision for GCMs:  Michael J. Iacono; October, 2002
+!  Revision for F90:  Michael J. Iacono; June, 2006
+!
+!  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.  A variable diffusivity 
+!  angle (SECDIFF) is used for the angle integration.  Bands 2-3 and 5-9 
+!  use a value for SECDIFF that varies from 1.50 to 1.80 as a function of 
+!  the column water vapor, and other bands use a value of 1.66.  The Gaussian 
+!  weight appropriate to this angle (WTDIFF=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.  
+!  Clouds are treated with the McICA stochastic approach and maximum-random
+!  cloud overlap. 
+!***************************************************************************
+
+! ------- Declarations -------
+
+! ----- Input -----
+      integer(kind=im), intent(in) :: nlayers         ! total number of layers
+      integer(kind=im), intent(in) :: istart          ! beginning band of calculation
+      integer(kind=im), intent(in) :: iend            ! ending band of calculation
+      integer(kind=im), intent(in) :: iout            ! output option flag
+
+! Atmosphere
+      real(kind=rb), intent(in) :: pz(0:)             ! level (interface) pressures (hPa, mb)
+                                                      !    Dimensions: (0:nlayers)
+      real(kind=rb), intent(in) :: pwvcm              ! precipitable water vapor (cm)
+      real(kind=rb), intent(in) :: semiss(:)          ! lw surface emissivity
+                                                      !    Dimensions: (nbndlw)
+      real(kind=rb), intent(in) :: planklay(:,:)      ! 
+                                                      !    Dimensions: (nlayers,nbndlw)
+      real(kind=rb), intent(in) :: planklev(0:,:)     ! 
+                                                      !    Dimensions: (0:nlayers,nbndlw)
+      real(kind=rb), intent(in) :: plankbnd(:)        ! 
+                                                      !    Dimensions: (nbndlw)
+      real(kind=rb), intent(in) :: fracs(:,:)         ! 
+                                                      !    Dimensions: (nlayers,ngptw)
+      real(kind=rb), intent(in) :: taut(:,:)          ! gaseous + aerosol optical depths
+                                                      !    Dimensions: (nlayers,ngptlw)
+
+! Clouds
+      integer(kind=im), intent(in) :: ncbands         ! number of cloud spectral bands
+      real(kind=rb), intent(in) :: cldfmc(:,:)        ! layer cloud fraction [mcica]
+                                                      !    Dimensions: (ngptlw,nlayers)
+      real(kind=rb), intent(in) :: taucmc(:,:)        ! layer cloud optical depth [mcica]
+                                                      !    Dimensions: (ngptlw,nlayers)
+
+! ----- Output -----
+      real(kind=rb), intent(out) :: totuflux(0:)      ! upward longwave flux (w/m2)
+                                                      !    Dimensions: (0:nlayers)
+      real(kind=rb), intent(out) :: totdflux(0:)      ! downward longwave flux (w/m2)
+                                                      !    Dimensions: (0:nlayers)
+      real(kind=rb), intent(out) :: fnet(0:)          ! net longwave flux (w/m2)
+                                                      !    Dimensions: (0:nlayers)
+      real(kind=rb), intent(out) :: htr(0:)           ! longwave heating rate (k/day)
+                                                      !    Dimensions: (0:nlayers)
+      real(kind=rb), intent(out) :: totuclfl(0:)      ! clear sky upward longwave flux (w/m2)
+                                                      !    Dimensions: (0:nlayers)
+      real(kind=rb), intent(out) :: totdclfl(0:)      ! clear sky downward longwave flux (w/m2)
+                                                      !    Dimensions: (0:nlayers)
+      real(kind=rb), intent(out) :: fnetc(0:)         ! clear sky net longwave flux (w/m2)
+                                                      !    Dimensions: (0:nlayers)
+      real(kind=rb), intent(out) :: htrc(0:)          ! clear sky longwave heating rate (k/day)
+                                                      !    Dimensions: (0:nlayers)
+
+! ----- Local -----
+! Declarations for radiative transfer
+      real(kind=rb) :: abscld(nlayers,ngptlw)
+      real(kind=rb) :: atot(nlayers)
+      real(kind=rb) :: atrans(nlayers)
+      real(kind=rb) :: bbugas(nlayers)
+      real(kind=rb) :: bbutot(nlayers)
+      real(kind=rb) :: clrurad(0:nlayers)
+      real(kind=rb) :: clrdrad(0:nlayers)
+      real(kind=rb) :: efclfrac(nlayers,ngptlw)
+      real(kind=rb) :: uflux(0:nlayers)
+      real(kind=rb) :: dflux(0:nlayers)
+      real(kind=rb) :: urad(0:nlayers)
+      real(kind=rb) :: drad(0:nlayers)
+      real(kind=rb) :: uclfl(0:nlayers)
+      real(kind=rb) :: dclfl(0:nlayers)
+      real(kind=rb) :: odcld(nlayers,ngptlw)
+
+
+      real(kind=rb) :: secdiff(nbndlw)                 ! secant of diffusivity angle
+      real(kind=rb) :: transcld, radld, radclrd, plfrac, blay, dplankup, dplankdn
+      real(kind=rb) :: odepth, odtot, odepth_rec, odtot_rec, gassrc
+      real(kind=rb) :: tblind, tfactot, bbd, bbdtot, tfacgas, transc, tausfac
+      real(kind=rb) :: rad0, reflect, radlu, radclru
+
+      integer(kind=im) :: icldlyr(nlayers)                  ! flag for cloud in layer
+      integer(kind=im) :: ibnd, ib, iband, lay, lev, l, ig  ! loop indices
+      integer(kind=im) :: igc                               ! g-point interval counter
+      integer(kind=im) :: iclddn                            ! flag for cloud in down path
+      integer(kind=im) :: ittot, itgas, itr                 ! lookup table indices
+
+! ------- Definitions -------
+! input
+!    nlayers                      ! number of model layers
+!    ngptlw                       ! total number of g-point subintervals
+!    nbndlw                       ! number of longwave spectral bands
+!    ncbands                      ! number of spectral bands for clouds
+!    secdiff                      ! diffusivity angle
+!    wtdiff                       ! weight for radiance to flux conversion
+!    pavel                        ! layer pressures (mb)
+!    pz                           ! level (interface) pressures (mb)
+!    tavel                        ! layer temperatures (k)
+!    tz                           ! level (interface) temperatures(mb)
+!    tbound                       ! surface temperature (k)
+!    cldfrac                      ! layer cloud fraction
+!    taucloud                     ! layer cloud optical depth
+!    itr                          ! integer look-up table index
+!    icldlyr                      ! flag for cloudy layers
+!    iclddn                       ! flag for cloud in column at any layer
+!    semiss                       ! surface emissivities for each band
+!    reflect                      ! surface reflectance
+!    bpade                        ! 1/(pade constant)
+!    tau_tbl                      ! clear sky optical depth look-up table
+!    exp_tbl                      ! exponential look-up table for transmittance
+!    tfn_tbl                      ! tau transition function look-up table
+
+! local
+!    atrans                       ! gaseous absorptivity
+!    abscld                       ! cloud absorptivity
+!    atot                         ! combined gaseous and cloud absorptivity
+!    odclr                        ! clear sky (gaseous) optical depth
+!    odcld                        ! cloud optical depth
+!    odtot                        ! optical depth of gas and cloud
+!    tfacgas                      ! gas-only pade factor, used for planck fn
+!    tfactot                      ! gas and cloud pade factor, used for planck fn
+!    bbdgas                       ! gas-only planck function for downward rt
+!    bbugas                       ! gas-only planck function for upward rt
+!    bbdtot                       ! gas and cloud planck function for downward rt
+!    bbutot                       ! gas and cloud planck function for upward calc.
+!    gassrc                       ! source radiance due to gas only
+!    efclfrac                     ! effective cloud fraction
+!    radlu                        ! spectrally summed upward radiance 
+!    radclru                      ! spectrally summed clear sky upward radiance 
+!    urad                         ! upward radiance by layer
+!    clrurad                      ! clear sky upward radiance by layer
+!    radld                        ! spectrally summed downward radiance 
+!    radclrd                      ! spectrally summed clear sky downward radiance 
+!    drad                         ! downward radiance by layer
+!    clrdrad                      ! clear sky downward radiance by layer
+
+! output
+!    totuflux                     ! upward longwave flux (w/m2)
+!    totdflux                     ! downward longwave flux (w/m2)
+!    fnet                         ! net longwave flux (w/m2)
+!    htr                          ! longwave heating rate (k/day)
+!    totuclfl                     ! clear sky upward longwave flux (w/m2)
+!    totdclfl                     ! clear sky downward longwave flux (w/m2)
+!    fnetc                        ! clear sky net longwave flux (w/m2)
+!    htrc                         ! clear sky longwave heating rate (k/day)
+
+
+      hvrrtc = '$Revision: 1.3 $'
+
+      do ibnd = 1,nbndlw
+         if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then
+           secdiff(ibnd) = 1.66_rb
+         else
+           secdiff(ibnd) = a0(ibnd) + a1(ibnd)*exp(a2(ibnd)*pwvcm)
+           if (secdiff(ibnd) .gt. 1.80_rb) secdiff(ibnd) = 1.80_rb
+           if (secdiff(ibnd) .lt. 1.50_rb) secdiff(ibnd) = 1.50_rb
+         endif
+      enddo
+
+      urad(0) = 0.0_rb
+      drad(0) = 0.0_rb
+      totuflux(0) = 0.0_rb
+      totdflux(0) = 0.0_rb
+      clrurad(0) = 0.0_rb
+      clrdrad(0) = 0.0_rb
+      totuclfl(0) = 0.0_rb
+      totdclfl(0) = 0.0_rb
+
+      do lay = 1, nlayers
+         urad(lay) = 0.0_rb
+         drad(lay) = 0.0_rb
+         totuflux(lay) = 0.0_rb
+         totdflux(lay) = 0.0_rb
+         clrurad(lay) = 0.0_rb
+         clrdrad(lay) = 0.0_rb
+         totuclfl(lay) = 0.0_rb
+         totdclfl(lay) = 0.0_rb
+         icldlyr(lay) = 0
+
+! Change to band loop?
+         do ig = 1, ngptlw
+            if (cldfmc(ig,lay) .eq. 1._rb) then
+               ib = ngb(ig)
+               odcld(lay,ig) = secdiff(ib) * taucmc(ig,lay)
+               transcld = exp(-odcld(lay,ig))
+               abscld(lay,ig) = 1._rb - transcld
+               efclfrac(lay,ig) = abscld(lay,ig) * cldfmc(ig,lay)
+               icldlyr(lay) = 1
+            else
+               odcld(lay,ig) = 0.0_rb
+               abscld(lay,ig) = 0.0_rb
+               efclfrac(lay,ig) = 0.0_rb
+            endif
+         enddo
+
+      enddo
+
+      igc = 1
+! Loop over frequency bands.
+      do iband = istart, iend
+
+! Reinitialize g-point counter for each band if output for each band is requested.
+         if (iout.gt.0.and.iband.ge.2) igc = ngs(iband-1)+1
+
+! Loop over g-channels.
+ 1000    continue
+
+! Radiative transfer starts here.
+         radld = 0._rb
+         radclrd = 0._rb
+         iclddn = 0
+
+! Downward radiative transfer loop.  
+
+         do lev = nlayers, 1, -1
+               plfrac = fracs(lev,igc)
+               blay = planklay(lev,iband)
+               dplankup = planklev(lev,iband) - blay
+               dplankdn = planklev(lev-1,iband) - blay
+               odepth = secdiff(iband) * taut(lev,igc)
+               if (odepth .lt. 0.0_rb) odepth = 0.0_rb
+!  Cloudy layer
+               if (icldlyr(lev).eq.1) then
+                  iclddn = 1
+                  odtot = odepth + odcld(lev,igc)
+                  if (odtot .lt. 0.06_rb) then
+                     atrans(lev) = odepth - 0.5_rb*odepth*odepth
+                     odepth_rec = rec_6*odepth
+                     gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev)
+
+                     atot(lev) =  odtot - 0.5_rb*odtot*odtot
+                     odtot_rec = rec_6*odtot
+                     bbdtot =  plfrac * (blay+dplankdn*odtot_rec)
+                     bbd = plfrac*(blay+dplankdn*odepth_rec)
+                     radld = radld - radld * (atrans(lev) + &
+                         efclfrac(lev,igc) * (1. - atrans(lev))) + &
+                         gassrc + cldfmc(igc,lev) * &
+                         (bbdtot * atot(lev) - gassrc)
+                     drad(lev-1) = drad(lev-1) + radld
+                  
+                     bbugas(lev) =  plfrac * (blay+dplankup*odepth_rec)
+                     bbutot(lev) =  plfrac * (blay+dplankup*odtot_rec)
+
+                  elseif (odepth .le. 0.06_rb) then
+                     atrans(lev) = odepth - 0.5_rb*odepth*odepth
+                     odepth_rec = rec_6*odepth
+                     gassrc = plfrac*(blay+dplankdn*odepth_rec)*atrans(lev)
+
+                     odtot = odepth + odcld(lev,igc)
+                     tblind = odtot/(bpade+odtot)
+                     ittot = tblint*tblind + 0.5_rb
+                     tfactot = tfn_tbl(ittot)
+                     bbdtot = plfrac * (blay + tfactot*dplankdn)
+                     bbd = plfrac*(blay+dplankdn*odepth_rec)
+                     atot(lev) = 1. - exp_tbl(ittot)
+
+                     radld = radld - radld * (atrans(lev) + &
+                         efclfrac(lev,igc) * (1._rb - atrans(lev))) + &
+                         gassrc + cldfmc(igc,lev) * &
+                         (bbdtot * atot(lev) - gassrc)
+                     drad(lev-1) = drad(lev-1) + radld
+
+                     bbugas(lev) = plfrac * (blay + dplankup*odepth_rec)
+                     bbutot(lev) = plfrac * (blay + tfactot * dplankup)
+
+                  else
+
+                     tblind = odepth/(bpade+odepth)
+                     itgas = tblint*tblind+0.5_rb
+                     odepth = tau_tbl(itgas)
+                     atrans(lev) = 1._rb - exp_tbl(itgas)
+                     tfacgas = tfn_tbl(itgas)
+                     gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn)
+
+                     odtot = odepth + odcld(lev,igc)
+                     tblind = odtot/(bpade+odtot)
+                     ittot = tblint*tblind + 0.5_rb
+                     tfactot = tfn_tbl(ittot)
+                     bbdtot = plfrac * (blay + tfactot*dplankdn)
+                     bbd = plfrac*(blay+tfacgas*dplankdn)
+                     atot(lev) = 1._rb - exp_tbl(ittot)
+
+                  radld = radld - radld * (atrans(lev) + &
+                    efclfrac(lev,igc) * (1._rb - atrans(lev))) + &
+                    gassrc + cldfmc(igc,lev) * &
+                    (bbdtot * atot(lev) - gassrc)
+                  drad(lev-1) = drad(lev-1) + radld
+                  bbugas(lev) = plfrac * (blay + tfacgas * dplankup)
+                  bbutot(lev) = plfrac * (blay + tfactot * dplankup)
+                  endif
+!  Clear layer
+               else
+                  if (odepth .le. 0.06_rb) then
+                     atrans(lev) = odepth-0.5_rb*odepth*odepth
+                     odepth = rec_6*odepth
+                     bbd = plfrac*(blay+dplankdn*odepth)
+                     bbugas(lev) = plfrac*(blay+dplankup*odepth)
+                  else
+                     tblind = odepth/(bpade+odepth)
+                     itr = tblint*tblind+0.5_rb
+                     transc = exp_tbl(itr)
+                     atrans(lev) = 1._rb-transc
+                     tausfac = tfn_tbl(itr)
+                     bbd = plfrac*(blay+tausfac*dplankdn)
+                     bbugas(lev) = plfrac * (blay + tausfac * dplankup)
+                  endif   
+                  radld = radld + (bbd-radld)*atrans(lev)
+                  drad(lev-1) = drad(lev-1) + radld
+               endif
+!  Set clear sky stream to total sky stream as long as layers
+!  remain clear.  Streams diverge when a cloud is reached (iclddn=1),
+!  and clear sky stream must be computed separately from that point.
+                  if (iclddn.eq.1) then
+                     radclrd = radclrd + (bbd-radclrd) * atrans(lev) 
+                     clrdrad(lev-1) = clrdrad(lev-1) + radclrd
+                  else
+                     radclrd = radld
+                     clrdrad(lev-1) = drad(lev-1)
+                  endif
+            enddo
+
+! 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
+!  diffusivity angle flux integration used here.
+
+         rad0 = fracs(1,igc) * plankbnd(iband)
+!  Add in specular reflection of surface downward radiance.
+         reflect = 1._rb - semiss(iband)
+         radlu = rad0 + reflect * radld
+         radclru = rad0 + reflect * radclrd
+
+
+! Upward radiative transfer loop.
+         urad(0) = urad(0) + radlu
+         clrurad(0) = clrurad(0) + radclru
+
+         do lev = 1, nlayers
+!  Cloudy layer
+            if (icldlyr(lev) .eq. 1) then
+               gassrc = bbugas(lev) * atrans(lev)
+               radlu = radlu - radlu * (atrans(lev) + &
+                   efclfrac(lev,igc) * (1._rb - atrans(lev))) + &
+                   gassrc + cldfmc(igc,lev) * &
+                   (bbutot(lev) * atot(lev) - gassrc)
+               urad(lev) = urad(lev) + radlu
+!  Clear layer
+            else
+               radlu = radlu + (bbugas(lev)-radlu)*atrans(lev)
+               urad(lev) = urad(lev) + radlu
+            endif
+!  Set clear sky stream to total sky stream as long as all layers
+!  are clear (iclddn=0).  Streams must be calculated separately at 
+!  all layers when a cloud is present (ICLDDN=1), because surface 
+!  reflectance is different for each stream.
+               if (iclddn.eq.1) then
+                  radclru = radclru + (bbugas(lev)-radclru)*atrans(lev) 
+                  clrurad(lev) = clrurad(lev) + radclru
+               else
+                  radclru = radlu
+                  clrurad(lev) = urad(lev)
+               endif
+         enddo
+
+! Increment g-point counter
+         igc = igc + 1
+! Return to continue radiative transfer for all g-channels in present band
+         if (igc .le. ngs(iband)) go to 1000
+
+! Process longwave output from band for total and clear streams.
+! Calculate upward, downward, and net flux.
+         do lev = nlayers, 0, -1
+            uflux(lev) = urad(lev)*wtdiff
+            dflux(lev) = drad(lev)*wtdiff
+            urad(lev) = 0.0_rb
+            drad(lev) = 0.0_rb
+            totuflux(lev) = totuflux(lev) + uflux(lev) * delwave(iband)
+            totdflux(lev) = totdflux(lev) + dflux(lev) * delwave(iband)
+            uclfl(lev) = clrurad(lev)*wtdiff
+            dclfl(lev) = clrdrad(lev)*wtdiff
+            clrurad(lev) = 0.0_rb
+            clrdrad(lev) = 0.0_rb
+            totuclfl(lev) = totuclfl(lev) + uclfl(lev) * delwave(iband)
+            totdclfl(lev) = totdclfl(lev) + dclfl(lev) * delwave(iband)
+         enddo
+
+! End spectral band loop
+      enddo
+
+! Calculate fluxes at surface
+      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)
+
+! Calculate fluxes at model levels
+      do 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 at model layers
+         htr(l)=heatfac*(fnet(l)-fnet(lev))/(pz(l)-pz(lev)) 
+         htrc(l)=heatfac*(fnetc(l)-fnetc(lev))/(pz(l)-pz(lev)) 
+      enddo
+
+! Set heating rate to zero in top layer
+      htr(nlayers) = 0.0_rb
+      htrc(nlayers) = 0.0_rb
+
+      end subroutine rtrnmc
+
+      end module rrtmg_lw_rtrnmc
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+!
+      module rrtmg_lw_setcoef
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parkind, only : im => kind_im, rb => kind_rb
+      use parrrtm, only : nbndlw, mg, maxxsec, mxmol
+      use rrlw_wvn, only: totplnk, totplk16
+      use rrlw_ref
+      use rrlw_vsn, only: hvrset, hnamset
+
+      implicit none
+
+      contains
+
+!----------------------------------------------------------------------------
+      subroutine setcoef(nlayers, istart, pavel, tavel, tz, tbound, semiss, &
+                         coldry, wkl, wbroad, &
+                         laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
+                         colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
+                         colbrd, fac00, fac01, fac10, fac11, &
+                         rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
+                         rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
+                         rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
+                         selffac, selffrac, indself, forfac, forfrac, indfor, &
+                         minorfrac, scaleminor, scaleminorn2, indminor)
+!----------------------------------------------------------------------------
+!
+!  Purpose:  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.
+
+! ------- Declarations -------
+
+! ----- Input -----
+      integer(kind=im), intent(in) :: nlayers         ! total number of layers
+      integer(kind=im), intent(in) :: istart          ! beginning band of calculation
+
+      real(kind=rb), intent(in) :: pavel(:)           ! layer pressures (mb) 
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: tavel(:)           ! layer temperatures (K)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: tz(0:)             ! level (interface) temperatures (K)
+                                                      !    Dimensions: (0:nlayers)
+      real(kind=rb), intent(in) :: tbound             ! surface temperature (K)
+      real(kind=rb), intent(in) :: coldry(:)          ! dry air column density (mol/cm2)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: wbroad(:)          ! broadening gas column density (mol/cm2)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: wkl(:,:)           ! molecular amounts (mol/cm-2)
+                                                      !    Dimensions: (mxmol,nlayers)
+      real(kind=rb), intent(in) :: semiss(:)          ! lw surface emissivity
+                                                      !    Dimensions: (nbndlw)
+
+! ----- Output -----
+      integer(kind=im), intent(out) :: laytrop        ! tropopause layer index
+      integer(kind=im), intent(out) :: jp(:)          ! 
+                                                      !    Dimensions: (nlayers)
+      integer(kind=im), intent(out) :: jt(:)          !
+                                                      !    Dimensions: (nlayers)
+      integer(kind=im), intent(out) :: jt1(:)         !
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: planklay(:,:)     ! 
+                                                      !    Dimensions: (nlayers,nbndlw)
+      real(kind=rb), intent(out) :: planklev(0:,:)    ! 
+                                                      !    Dimensions: (0:nlayers,nbndlw)
+      real(kind=rb), intent(out) :: plankbnd(:)       ! 
+                                                      !    Dimensions: (nbndlw)
+
+      real(kind=rb), intent(out) :: colh2o(:)         ! column amount (h2o)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: colco2(:)         ! column amount (co2)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: colo3(:)          ! column amount (o3)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: coln2o(:)         ! column amount (n2o)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: colco(:)          ! column amount (co)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: colch4(:)         ! column amount (ch4)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: colo2(:)          ! column amount (o2)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: colbrd(:)         ! column amount (broadening gases)
+                                                      !    Dimensions: (nlayers)
+
+      integer(kind=im), intent(out) :: indself(:)
+                                                      !    Dimensions: (nlayers)
+      integer(kind=im), intent(out) :: indfor(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: selffac(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: selffrac(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: forfac(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: forfrac(:)
+                                                      !    Dimensions: (nlayers)
+
+      integer(kind=im), intent(out) :: indminor(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: minorfrac(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: scaleminor(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: scaleminorn2(:)
+                                                      !    Dimensions: (nlayers)
+
+      real(kind=rb), intent(out) :: &                 !
+                       fac00(:), fac01(:), &          !    Dimensions: (nlayers)
+                       fac10(:), fac11(:) 
+                                                        
+      real(kind=rb), intent(out) :: &                 !
+                       rat_h2oco2(:),rat_h2oco2_1(:), &
+                       rat_h2oo3(:),rat_h2oo3_1(:), & !    Dimensions: (nlayers)
+                       rat_h2on2o(:),rat_h2on2o_1(:), &
+                       rat_h2och4(:),rat_h2och4_1(:), &
+                       rat_n2oco2(:),rat_n2oco2_1(:), &
+                       rat_o3co2(:),rat_o3co2_1(:)
+                                                        
+
+! ----- Local -----
+      integer(kind=im) :: indbound, indlev0
+      integer(kind=im) :: lay, indlay, indlev, iband
+      integer(kind=im) :: jp1
+      real(kind=rb) :: stpfac, tbndfrac, t0frac, tlayfrac, tlevfrac
+      real(kind=rb) :: dbdtlev, dbdtlay
+      real(kind=rb) :: plog, fp, ft, ft1, water, scalefac, factor, compfp
+
+
+      hvrset = '$Revision: 1.3 $'
+
+      stpfac = 296._rb/1013._rb
+
+      indbound = tbound - 159._rb
+      if (indbound .lt. 1) then
+         indbound = 1
+      elseif (indbound .gt. 180) then
+         indbound = 180
+      endif
+      tbndfrac = tbound - 159._rb - float(indbound)
+      indlev0 = tz(0) - 159._rb
+      if (indlev0 .lt. 1) then
+         indlev0 = 1
+      elseif (indlev0 .gt. 180) then
+         indlev0 = 180
+      endif
+      t0frac = tz(0) - 159._rb - float(indlev0)
+      laytrop = 0
+
+! Begin layer loop 
+!  Calculate the integrated Planck functions for each band at the
+!  surface, level, and layer temperatures.
+      do lay = 1, nlayers
+         indlay = tavel(lay) - 159._rb
+         if (indlay .lt. 1) then
+            indlay = 1
+         elseif (indlay .gt. 180) then
+            indlay = 180
+         endif
+         tlayfrac = tavel(lay) - 159._rb - float(indlay)
+         indlev = tz(lay) - 159._rb
+         if (indlev .lt. 1) then
+            indlev = 1
+         elseif (indlev .gt. 180) then
+            indlev = 180
+         endif
+         tlevfrac = tz(lay) - 159._rb - float(indlev)
+
+! Begin spectral band loop 
+         do iband = 1, 15
+            if (lay.eq.1) then
+               dbdtlev = totplnk(indbound+1,iband) - totplnk(indbound,iband)
+               plankbnd(iband) = semiss(iband) * &
+                   (totplnk(indbound,iband) + tbndfrac * dbdtlev)
+               dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
+               planklev(0,iband) = totplnk(indlev0,iband) + t0frac * dbdtlev
+            endif
+            dbdtlev = totplnk(indlev+1,iband) - totplnk(indlev,iband)
+            dbdtlay = totplnk(indlay+1,iband) - totplnk(indlay,iband)
+            planklay(lay,iband) = totplnk(indlay,iband) + tlayfrac * dbdtlay
+            planklev(lay,iband) = totplnk(indlev,iband) + tlevfrac * dbdtlev
+         enddo
+
+!  For band 16, if radiative transfer will be performed on just
+!  this band, use integrated Planck values up to 3250 cm-1.  
+!  If radiative transfer will be performed across all 16 bands,
+!  then include in the integrated Planck values for this band
+!  contributions from 2600 cm-1 to infinity.
+         iband = 16
+         if (istart .eq. 16) then
+            if (lay.eq.1) then
+               dbdtlev = totplk16(indbound+1) - totplk16(indbound)
+               plankbnd(iband) = semiss(iband) * &
+                    (totplk16(indbound) + tbndfrac * dbdtlev)
+               dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
+               planklev(0,iband) = totplk16(indlev0) + &
+                    t0frac * dbdtlev
+            endif
+            dbdtlev = totplk16(indlev+1) - totplk16(indlev)
+            dbdtlay = totplk16(indlay+1) - totplk16(indlay)
+            planklay(lay,iband) = totplk16(indlay) + tlayfrac * dbdtlay
+            planklev(lay,iband) = totplk16(indlev) + tlevfrac * dbdtlev
+         else
+            if (lay.eq.1) then
+               dbdtlev = totplnk(indbound+1,iband) - totplnk(indbound,iband)
+               plankbnd(iband) = semiss(iband) * &
+                    (totplnk(indbound,iband) + tbndfrac * dbdtlev)
+               dbdtlev = totplnk(indlev0+1,iband)-totplnk(indlev0,iband)
+               planklev(0,iband) = totplnk(indlev0,iband) + t0frac * dbdtlev
+            endif
+            dbdtlev = totplnk(indlev+1,iband) - totplnk(indlev,iband)
+            dbdtlay = totplnk(indlay+1,iband) - totplnk(indlay,iband)
+            planklay(lay,iband) = totplnk(indlay,iband) + tlayfrac * dbdtlay
+            planklev(lay,iband) = totplnk(indlev,iband) + tlevfrac * dbdtlev
+         endif
+
+!  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))
+!         plog = dlog(pavel(lay))
+         jp(lay) = int(36._rb - 5*(plog+0.04_rb))
+         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._rb *(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._rb + (tavel(lay)-tref(jp(lay)))/15._rb)
+         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._rb) - float(jt(lay)-3)
+         jt1(lay) = int(3._rb + (tavel(lay)-tref(jp1))/15._rb)
+         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._rb) - 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_rb) go to 5300
+         laytrop =  laytrop + 1
+
+         forfac(lay) = scalefac / (1.+water)
+         factor = (332.0_rb-tavel(lay))/36.0_rb
+         indfor(lay) = min(2, max(1, int(factor)))
+         forfrac(lay) = factor - float(indfor(lay))
+
+!  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_rb)/7.2_rb
+         indself(lay) = min(9, max(1, int(factor)-7))
+         selffrac(lay) = factor - float(indself(lay) + 7)
+
+!  Set up factors needed to separately include the minor gases
+!  in the calculation of absorption coefficient
+         scaleminor(lay) = pavel(lay)/tavel(lay)
+         scaleminorn2(lay) = (pavel(lay)/tavel(lay)) &
+             *(wbroad(lay)/(coldry(lay)+wkl(1,lay)))
+         factor = (tavel(lay)-180.8_rb)/7.2_rb
+         indminor(lay) = min(18, max(1, int(factor)))
+         minorfrac(lay) = factor - float(indminor(lay))
+
+!  Setup reference ratio to be used in calculation of binary
+!  species parameter in lower atmosphere.
+         rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay))
+         rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1)
+
+         rat_h2oo3(lay)=chi_mls(1,jp(lay))/chi_mls(3,jp(lay))
+         rat_h2oo3_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(3,jp(lay)+1)
+
+         rat_h2on2o(lay)=chi_mls(1,jp(lay))/chi_mls(4,jp(lay))
+         rat_h2on2o_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(4,jp(lay)+1)
+
+         rat_h2och4(lay)=chi_mls(1,jp(lay))/chi_mls(6,jp(lay))
+         rat_h2och4_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(6,jp(lay)+1)
+
+         rat_n2oco2(lay)=chi_mls(4,jp(lay))/chi_mls(2,jp(lay))
+         rat_n2oco2_1(lay)=chi_mls(4,jp(lay)+1)/chi_mls(2,jp(lay)+1)
+
+!  Calculate needed column amounts.
+         colh2o(lay) = 1.e-20_rb * wkl(1,lay)
+         colco2(lay) = 1.e-20_rb * wkl(2,lay)
+         colo3(lay) = 1.e-20_rb * wkl(3,lay)
+         coln2o(lay) = 1.e-20_rb * wkl(4,lay)
+         colco(lay) = 1.e-20_rb * wkl(5,lay)
+         colch4(lay) = 1.e-20_rb * wkl(6,lay)
+         colo2(lay) = 1.e-20_rb * wkl(7,lay)
+         if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
+         if (colo3(lay) .eq. 0._rb) colo3(lay) = 1.e-32_rb * coldry(lay)
+         if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
+         if (colco(lay) .eq. 0._rb) colco(lay) = 1.e-32_rb * coldry(lay)
+         if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
+         colbrd(lay) = 1.e-20_rb * wbroad(lay)
+         go to 5400
+
+!  Above laytrop.
+ 5300    continue
+
+         forfac(lay) = scalefac / (1.+water)
+         factor = (tavel(lay)-188.0_rb)/36.0_rb
+         indfor(lay) = 3
+         forfrac(lay) = factor - 1.0_rb
+
+!  Set up factors needed to separately include the water vapor
+!  self-continuum in the calculation of absorption coefficient.
+         selffac(lay) = water * forfac(lay)
+
+!  Set up factors needed to separately include the minor gases
+!  in the calculation of absorption coefficient
+         scaleminor(lay) = pavel(lay)/tavel(lay)         
+         scaleminorn2(lay) = (pavel(lay)/tavel(lay)) &
+             * (wbroad(lay)/(coldry(lay)+wkl(1,lay)))
+         factor = (tavel(lay)-180.8_rb)/7.2_rb
+         indminor(lay) = min(18, max(1, int(factor)))
+         minorfrac(lay) = factor - float(indminor(lay))
+
+!  Setup reference ratio to be used in calculation of binary
+!  species parameter in upper atmosphere.
+         rat_h2oco2(lay)=chi_mls(1,jp(lay))/chi_mls(2,jp(lay))
+         rat_h2oco2_1(lay)=chi_mls(1,jp(lay)+1)/chi_mls(2,jp(lay)+1)         
+
+         rat_o3co2(lay)=chi_mls(3,jp(lay))/chi_mls(2,jp(lay))
+         rat_o3co2_1(lay)=chi_mls(3,jp(lay)+1)/chi_mls(2,jp(lay)+1)         
+
+!  Calculate needed column amounts.
+         colh2o(lay) = 1.e-20_rb * wkl(1,lay)
+         colco2(lay) = 1.e-20_rb * wkl(2,lay)
+         colo3(lay) = 1.e-20_rb * wkl(3,lay)
+         coln2o(lay) = 1.e-20_rb * wkl(4,lay)
+         colco(lay) = 1.e-20_rb * wkl(5,lay)
+         colch4(lay) = 1.e-20_rb * wkl(6,lay)
+         colo2(lay) = 1.e-20_rb * wkl(7,lay)
+         if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
+         if (colo3(lay) .eq. 0._rb) colo3(lay) = 1.e-32_rb * coldry(lay)
+         if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
+         if (colco(lay)  .eq. 0._rb) colco(lay) = 1.e-32_rb * coldry(lay)
+         if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
+         colbrd(lay) = 1.e-20_rb * wbroad(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._rb - ft)
+         fac11(lay) = fp * ft1
+         fac01(lay) = fp * (1._rb - ft1)
+
+!  Rescale selffac and forfac for use in taumol
+         selffac(lay) = colh2o(lay)*selffac(lay)
+         forfac(lay) = colh2o(lay)*forfac(lay)
+
+! End layer loop
+      enddo
+
+      end subroutine setcoef
+
+!***************************************************************************
+      subroutine lwatmref
+!***************************************************************************
+
+      save
+ 
+! 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.
+
+      pref(:) = (/ &
+          1.05363e+03_rb,8.62642e+02_rb,7.06272e+02_rb,5.78246e+02_rb,4.73428e+02_rb, &
+          3.87610e+02_rb,3.17348e+02_rb,2.59823e+02_rb,2.12725e+02_rb,1.74164e+02_rb, &
+          1.42594e+02_rb,1.16746e+02_rb,9.55835e+01_rb,7.82571e+01_rb,6.40715e+01_rb, &
+          5.24573e+01_rb,4.29484e+01_rb,3.51632e+01_rb,2.87892e+01_rb,2.35706e+01_rb, &
+          1.92980e+01_rb,1.57998e+01_rb,1.29358e+01_rb,1.05910e+01_rb,8.67114e+00_rb, &
+          7.09933e+00_rb,5.81244e+00_rb,4.75882e+00_rb,3.89619e+00_rb,3.18993e+00_rb, &
+          2.61170e+00_rb,2.13828e+00_rb,1.75067e+00_rb,1.43333e+00_rb,1.17351e+00_rb, &
+          9.60789e-01_rb,7.86628e-01_rb,6.44036e-01_rb,5.27292e-01_rb,4.31710e-01_rb, &
+          3.53455e-01_rb,2.89384e-01_rb,2.36928e-01_rb,1.93980e-01_rb,1.58817e-01_rb, &
+          1.30029e-01_rb,1.06458e-01_rb,8.71608e-02_rb,7.13612e-02_rb,5.84256e-02_rb, &
+          4.78349e-02_rb,3.91639e-02_rb,3.20647e-02_rb,2.62523e-02_rb,2.14936e-02_rb, &
+          1.75975e-02_rb,1.44076e-02_rb,1.17959e-02_rb,9.65769e-03_rb/)
+
+      preflog(:) = (/ &
+           6.9600e+00_rb, 6.7600e+00_rb, 6.5600e+00_rb, 6.3600e+00_rb, 6.1600e+00_rb, &
+           5.9600e+00_rb, 5.7600e+00_rb, 5.5600e+00_rb, 5.3600e+00_rb, 5.1600e+00_rb, &
+           4.9600e+00_rb, 4.7600e+00_rb, 4.5600e+00_rb, 4.3600e+00_rb, 4.1600e+00_rb, &
+           3.9600e+00_rb, 3.7600e+00_rb, 3.5600e+00_rb, 3.3600e+00_rb, 3.1600e+00_rb, &
+           2.9600e+00_rb, 2.7600e+00_rb, 2.5600e+00_rb, 2.3600e+00_rb, 2.1600e+00_rb, &
+           1.9600e+00_rb, 1.7600e+00_rb, 1.5600e+00_rb, 1.3600e+00_rb, 1.1600e+00_rb, &
+           9.6000e-01_rb, 7.6000e-01_rb, 5.6000e-01_rb, 3.6000e-01_rb, 1.6000e-01_rb, &
+          -4.0000e-02_rb,-2.4000e-01_rb,-4.4000e-01_rb,-6.4000e-01_rb,-8.4000e-01_rb, &
+          -1.0400e+00_rb,-1.2400e+00_rb,-1.4400e+00_rb,-1.6400e+00_rb,-1.8400e+00_rb, &
+          -2.0400e+00_rb,-2.2400e+00_rb,-2.4400e+00_rb,-2.6400e+00_rb,-2.8400e+00_rb, &
+          -3.0400e+00_rb,-3.2400e+00_rb,-3.4400e+00_rb,-3.6400e+00_rb,-3.8400e+00_rb, &
+          -4.0400e+00_rb,-4.2400e+00_rb,-4.4400e+00_rb,-4.6400e+00_rb/)
+
+! These are the temperatures associated with the respective 
+! pressures for the mls standard atmosphere. 
+
+      tref(:) = (/ &
+           2.9420e+02_rb, 2.8799e+02_rb, 2.7894e+02_rb, 2.6925e+02_rb, 2.5983e+02_rb, &
+           2.5017e+02_rb, 2.4077e+02_rb, 2.3179e+02_rb, 2.2306e+02_rb, 2.1578e+02_rb, &
+           2.1570e+02_rb, 2.1570e+02_rb, 2.1570e+02_rb, 2.1706e+02_rb, 2.1858e+02_rb, &
+           2.2018e+02_rb, 2.2174e+02_rb, 2.2328e+02_rb, 2.2479e+02_rb, 2.2655e+02_rb, &
+           2.2834e+02_rb, 2.3113e+02_rb, 2.3401e+02_rb, 2.3703e+02_rb, 2.4022e+02_rb, &
+           2.4371e+02_rb, 2.4726e+02_rb, 2.5085e+02_rb, 2.5457e+02_rb, 2.5832e+02_rb, &
+           2.6216e+02_rb, 2.6606e+02_rb, 2.6999e+02_rb, 2.7340e+02_rb, 2.7536e+02_rb, &
+           2.7568e+02_rb, 2.7372e+02_rb, 2.7163e+02_rb, 2.6955e+02_rb, 2.6593e+02_rb, &
+           2.6211e+02_rb, 2.5828e+02_rb, 2.5360e+02_rb, 2.4854e+02_rb, 2.4348e+02_rb, &
+           2.3809e+02_rb, 2.3206e+02_rb, 2.2603e+02_rb, 2.2000e+02_rb, 2.1435e+02_rb, &
+           2.0887e+02_rb, 2.0340e+02_rb, 1.9792e+02_rb, 1.9290e+02_rb, 1.8809e+02_rb, &
+           1.8329e+02_rb, 1.7849e+02_rb, 1.7394e+02_rb, 1.7212e+02_rb/)
+
+       chi_mls(1,1:12) = (/ &
+        1.8760e-02_rb, 1.2223e-02_rb, 5.8909e-03_rb, 2.7675e-03_rb, 1.4065e-03_rb, &
+        7.5970e-04_rb, 3.8876e-04_rb, 1.6542e-04_rb, 3.7190e-05_rb, 7.4765e-06_rb, &
+        4.3082e-06_rb, 3.3319e-06_rb/)
+       chi_mls(1,13:59) = (/ &
+        3.2039e-06_rb,  3.1619e-06_rb,  3.2524e-06_rb,  3.4226e-06_rb,  3.6288e-06_rb, &
+        3.9148e-06_rb,  4.1488e-06_rb,  4.3081e-06_rb,  4.4420e-06_rb,  4.5778e-06_rb, &
+        4.7087e-06_rb,  4.7943e-06_rb,  4.8697e-06_rb,  4.9260e-06_rb,  4.9669e-06_rb, &
+        4.9963e-06_rb,  5.0527e-06_rb,  5.1266e-06_rb,  5.2503e-06_rb,  5.3571e-06_rb, &
+        5.4509e-06_rb,  5.4830e-06_rb,  5.5000e-06_rb,  5.5000e-06_rb,  5.4536e-06_rb, &
+        5.4047e-06_rb,  5.3558e-06_rb,  5.2533e-06_rb,  5.1436e-06_rb,  5.0340e-06_rb, &
+        4.8766e-06_rb,  4.6979e-06_rb,  4.5191e-06_rb,  4.3360e-06_rb,  4.1442e-06_rb, &
+        3.9523e-06_rb,  3.7605e-06_rb,  3.5722e-06_rb,  3.3855e-06_rb,  3.1988e-06_rb, &
+        3.0121e-06_rb,  2.8262e-06_rb,  2.6407e-06_rb,  2.4552e-06_rb,  2.2696e-06_rb, &
+        4.3360e-06_rb,  4.1442e-06_rb/)
+       chi_mls(2,1:12) = (/ &
+        3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb, &
+        3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb, &
+        3.5500e-04_rb,  3.5500e-04_rb/)
+       chi_mls(2,13:59) = (/ &
+        3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb, &
+        3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb, &
+        3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb, &
+        3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb, &
+        3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb, &
+        3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb, &
+        3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb, &
+        3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb,  3.5500e-04_rb, &
+        3.5500e-04_rb,  3.5471e-04_rb,  3.5427e-04_rb,  3.5384e-04_rb,  3.5340e-04_rb, &
+        3.5500e-04_rb,  3.5500e-04_rb/)
+       chi_mls(3,1:12) = (/ &
+        3.0170e-08_rb,  3.4725e-08_rb,  4.2477e-08_rb,  5.2759e-08_rb,  6.6944e-08_rb, &
+        8.7130e-08_rb,  1.1391e-07_rb,  1.5677e-07_rb,  2.1788e-07_rb,  3.2443e-07_rb, &
+        4.6594e-07_rb,  5.6806e-07_rb/)
+       chi_mls(3,13:59) = (/ &
+        6.9607e-07_rb,  1.1186e-06_rb,  1.7618e-06_rb,  2.3269e-06_rb,  2.9577e-06_rb, &
+        3.6593e-06_rb,  4.5950e-06_rb,  5.3189e-06_rb,  5.9618e-06_rb,  6.5113e-06_rb, &
+        7.0635e-06_rb,  7.6917e-06_rb,  8.2577e-06_rb,  8.7082e-06_rb,  8.8325e-06_rb, &
+        8.7149e-06_rb,  8.0943e-06_rb,  7.3307e-06_rb,  6.3101e-06_rb,  5.3672e-06_rb, &
+        4.4829e-06_rb,  3.8391e-06_rb,  3.2827e-06_rb,  2.8235e-06_rb,  2.4906e-06_rb, &
+        2.1645e-06_rb,  1.8385e-06_rb,  1.6618e-06_rb,  1.5052e-06_rb,  1.3485e-06_rb, &
+        1.1972e-06_rb,  1.0482e-06_rb,  8.9926e-07_rb,  7.6343e-07_rb,  6.5381e-07_rb, &
+        5.4419e-07_rb,  4.3456e-07_rb,  3.6421e-07_rb,  3.1194e-07_rb,  2.5967e-07_rb, &
+        2.0740e-07_rb,  1.9146e-07_rb,  1.9364e-07_rb,  1.9582e-07_rb,  1.9800e-07_rb, &
+        7.6343e-07_rb,  6.5381e-07_rb/)
+       chi_mls(4,1:12) = (/ &
+        3.2000e-07_rb,  3.2000e-07_rb,  3.2000e-07_rb,  3.2000e-07_rb,  3.2000e-07_rb, &
+        3.1965e-07_rb,  3.1532e-07_rb,  3.0383e-07_rb,  2.9422e-07_rb,  2.8495e-07_rb, &
+        2.7671e-07_rb,  2.6471e-07_rb/)
+       chi_mls(4,13:59) = (/ &
+        2.4285e-07_rb,  2.0955e-07_rb,  1.7195e-07_rb,  1.3749e-07_rb,  1.1332e-07_rb, &
+        1.0035e-07_rb,  9.1281e-08_rb,  8.5463e-08_rb,  8.0363e-08_rb,  7.3372e-08_rb, &
+        6.5975e-08_rb,  5.6039e-08_rb,  4.7090e-08_rb,  3.9977e-08_rb,  3.2979e-08_rb, &
+        2.6064e-08_rb,  2.1066e-08_rb,  1.6592e-08_rb,  1.3017e-08_rb,  1.0090e-08_rb, &
+        7.6249e-09_rb,  6.1159e-09_rb,  4.6672e-09_rb,  3.2857e-09_rb,  2.8484e-09_rb, &
+        2.4620e-09_rb,  2.0756e-09_rb,  1.8551e-09_rb,  1.6568e-09_rb,  1.4584e-09_rb, &
+        1.3195e-09_rb,  1.2072e-09_rb,  1.0948e-09_rb,  9.9780e-10_rb,  9.3126e-10_rb, &
+        8.6472e-10_rb,  7.9818e-10_rb,  7.5138e-10_rb,  7.1367e-10_rb,  6.7596e-10_rb, &
+        6.3825e-10_rb,  6.0981e-10_rb,  5.8600e-10_rb,  5.6218e-10_rb,  5.3837e-10_rb, &
+        9.9780e-10_rb,  9.3126e-10_rb/)
+       chi_mls(5,1:12) = (/ &
+        1.5000e-07_rb,  1.4306e-07_rb,  1.3474e-07_rb,  1.3061e-07_rb,  1.2793e-07_rb, &
+        1.2038e-07_rb,  1.0798e-07_rb,  9.4238e-08_rb,  7.9488e-08_rb,  6.1386e-08_rb, &
+        4.5563e-08_rb,  3.3475e-08_rb/)
+       chi_mls(5,13:59) = (/ &
+        2.5118e-08_rb,  1.8671e-08_rb,  1.4349e-08_rb,  1.2501e-08_rb,  1.2407e-08_rb, &
+        1.3472e-08_rb,  1.4900e-08_rb,  1.6079e-08_rb,  1.7156e-08_rb,  1.8616e-08_rb, &
+        2.0106e-08_rb,  2.1654e-08_rb,  2.3096e-08_rb,  2.4340e-08_rb,  2.5643e-08_rb, &
+        2.6990e-08_rb,  2.8456e-08_rb,  2.9854e-08_rb,  3.0943e-08_rb,  3.2023e-08_rb, &
+        3.3101e-08_rb,  3.4260e-08_rb,  3.5360e-08_rb,  3.6397e-08_rb,  3.7310e-08_rb, &
+        3.8217e-08_rb,  3.9123e-08_rb,  4.1303e-08_rb,  4.3652e-08_rb,  4.6002e-08_rb, &
+        5.0289e-08_rb,  5.5446e-08_rb,  6.0603e-08_rb,  6.8946e-08_rb,  8.3652e-08_rb, &
+        9.8357e-08_rb,  1.1306e-07_rb,  1.4766e-07_rb,  1.9142e-07_rb,  2.3518e-07_rb, &
+        2.7894e-07_rb,  3.5001e-07_rb,  4.3469e-07_rb,  5.1938e-07_rb,  6.0407e-07_rb, &
+        6.8946e-08_rb,  8.3652e-08_rb/)
+       chi_mls(6,1:12) = (/ &
+        1.7000e-06_rb,  1.7000e-06_rb,  1.6999e-06_rb,  1.6904e-06_rb,  1.6671e-06_rb, &
+        1.6351e-06_rb,  1.6098e-06_rb,  1.5590e-06_rb,  1.5120e-06_rb,  1.4741e-06_rb, &
+        1.4385e-06_rb,  1.4002e-06_rb/)
+       chi_mls(6,13:59) = (/ &
+        1.3573e-06_rb,  1.3130e-06_rb,  1.2512e-06_rb,  1.1668e-06_rb,  1.0553e-06_rb, &
+        9.3281e-07_rb,  8.1217e-07_rb,  7.5239e-07_rb,  7.0728e-07_rb,  6.6722e-07_rb, &
+        6.2733e-07_rb,  5.8604e-07_rb,  5.4769e-07_rb,  5.1480e-07_rb,  4.8206e-07_rb, &
+        4.4943e-07_rb,  4.1702e-07_rb,  3.8460e-07_rb,  3.5200e-07_rb,  3.1926e-07_rb, &
+        2.8646e-07_rb,  2.5498e-07_rb,  2.2474e-07_rb,  1.9588e-07_rb,  1.8295e-07_rb, &
+        1.7089e-07_rb,  1.5882e-07_rb,  1.5536e-07_rb,  1.5304e-07_rb,  1.5072e-07_rb, &
+        1.5000e-07_rb,  1.5000e-07_rb,  1.5000e-07_rb,  1.5000e-07_rb,  1.5000e-07_rb, &
+        1.5000e-07_rb,  1.5000e-07_rb,  1.5000e-07_rb,  1.5000e-07_rb,  1.5000e-07_rb, &
+        1.5000e-07_rb,  1.5000e-07_rb,  1.5000e-07_rb,  1.5000e-07_rb,  1.5000e-07_rb, &
+        1.5000e-07_rb,  1.5000e-07_rb/)
+       chi_mls(7,1:12) = (/ &
+        0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb, &
+        0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb, &
+        0.2090_rb,  0.2090_rb/)
+       chi_mls(7,13:59) = (/ &
+        0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb, &
+        0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb, &
+        0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb, &
+        0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb, &
+        0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb, &
+        0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb, &
+        0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb, &
+        0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb, &
+        0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb,  0.2090_rb, &
+        0.2090_rb,  0.2090_rb/)
+
+      end subroutine lwatmref
+
+!***************************************************************************
+      subroutine lwavplank
+!***************************************************************************
+
+      save
+ 
+      totplnk(1:50,  1) = (/ &
+      0.14783e-05_rb,0.15006e-05_rb,0.15230e-05_rb,0.15455e-05_rb,0.15681e-05_rb, &
+      0.15908e-05_rb,0.16136e-05_rb,0.16365e-05_rb,0.16595e-05_rb,0.16826e-05_rb, &
+      0.17059e-05_rb,0.17292e-05_rb,0.17526e-05_rb,0.17762e-05_rb,0.17998e-05_rb, &
+      0.18235e-05_rb,0.18473e-05_rb,0.18712e-05_rb,0.18953e-05_rb,0.19194e-05_rb, &
+      0.19435e-05_rb,0.19678e-05_rb,0.19922e-05_rb,0.20166e-05_rb,0.20412e-05_rb, &
+      0.20658e-05_rb,0.20905e-05_rb,0.21153e-05_rb,0.21402e-05_rb,0.21652e-05_rb, &
+      0.21902e-05_rb,0.22154e-05_rb,0.22406e-05_rb,0.22659e-05_rb,0.22912e-05_rb, &
+      0.23167e-05_rb,0.23422e-05_rb,0.23678e-05_rb,0.23934e-05_rb,0.24192e-05_rb, &
+      0.24450e-05_rb,0.24709e-05_rb,0.24968e-05_rb,0.25229e-05_rb,0.25490e-05_rb, &
+      0.25751e-05_rb,0.26014e-05_rb,0.26277e-05_rb,0.26540e-05_rb,0.26805e-05_rb/)
+      totplnk(51:100,  1) = (/ &
+      0.27070e-05_rb,0.27335e-05_rb,0.27602e-05_rb,0.27869e-05_rb,0.28136e-05_rb, &
+      0.28404e-05_rb,0.28673e-05_rb,0.28943e-05_rb,0.29213e-05_rb,0.29483e-05_rb, &
+      0.29754e-05_rb,0.30026e-05_rb,0.30298e-05_rb,0.30571e-05_rb,0.30845e-05_rb, &
+      0.31119e-05_rb,0.31393e-05_rb,0.31669e-05_rb,0.31944e-05_rb,0.32220e-05_rb, &
+      0.32497e-05_rb,0.32774e-05_rb,0.33052e-05_rb,0.33330e-05_rb,0.33609e-05_rb, &
+      0.33888e-05_rb,0.34168e-05_rb,0.34448e-05_rb,0.34729e-05_rb,0.35010e-05_rb, &
+      0.35292e-05_rb,0.35574e-05_rb,0.35857e-05_rb,0.36140e-05_rb,0.36424e-05_rb, &
+      0.36708e-05_rb,0.36992e-05_rb,0.37277e-05_rb,0.37563e-05_rb,0.37848e-05_rb, &
+      0.38135e-05_rb,0.38421e-05_rb,0.38708e-05_rb,0.38996e-05_rb,0.39284e-05_rb, &
+      0.39572e-05_rb,0.39861e-05_rb,0.40150e-05_rb,0.40440e-05_rb,0.40730e-05_rb/)
+      totplnk(101:150,  1) = (/ &
+      0.41020e-05_rb,0.41311e-05_rb,0.41602e-05_rb,0.41893e-05_rb,0.42185e-05_rb, &
+      0.42477e-05_rb,0.42770e-05_rb,0.43063e-05_rb,0.43356e-05_rb,0.43650e-05_rb, &
+      0.43944e-05_rb,0.44238e-05_rb,0.44533e-05_rb,0.44828e-05_rb,0.45124e-05_rb, &
+      0.45419e-05_rb,0.45715e-05_rb,0.46012e-05_rb,0.46309e-05_rb,0.46606e-05_rb, &
+      0.46903e-05_rb,0.47201e-05_rb,0.47499e-05_rb,0.47797e-05_rb,0.48096e-05_rb, &
+      0.48395e-05_rb,0.48695e-05_rb,0.48994e-05_rb,0.49294e-05_rb,0.49594e-05_rb, &
+      0.49895e-05_rb,0.50196e-05_rb,0.50497e-05_rb,0.50798e-05_rb,0.51100e-05_rb, &
+      0.51402e-05_rb,0.51704e-05_rb,0.52007e-05_rb,0.52309e-05_rb,0.52612e-05_rb, &
+      0.52916e-05_rb,0.53219e-05_rb,0.53523e-05_rb,0.53827e-05_rb,0.54132e-05_rb, &
+      0.54436e-05_rb,0.54741e-05_rb,0.55047e-05_rb,0.55352e-05_rb,0.55658e-05_rb/)
+      totplnk(151:181,  1) = (/ &
+      0.55964e-05_rb,0.56270e-05_rb,0.56576e-05_rb,0.56883e-05_rb,0.57190e-05_rb, &
+      0.57497e-05_rb,0.57804e-05_rb,0.58112e-05_rb,0.58420e-05_rb,0.58728e-05_rb, &
+      0.59036e-05_rb,0.59345e-05_rb,0.59653e-05_rb,0.59962e-05_rb,0.60272e-05_rb, &
+      0.60581e-05_rb,0.60891e-05_rb,0.61201e-05_rb,0.61511e-05_rb,0.61821e-05_rb, &
+      0.62131e-05_rb,0.62442e-05_rb,0.62753e-05_rb,0.63064e-05_rb,0.63376e-05_rb, &
+      0.63687e-05_rb,0.63998e-05_rb,0.64310e-05_rb,0.64622e-05_rb,0.64935e-05_rb, &
+      0.65247e-05_rb/)
+      totplnk(1:50,  2) = (/ &
+      0.20262e-05_rb,0.20757e-05_rb,0.21257e-05_rb,0.21763e-05_rb,0.22276e-05_rb, &
+      0.22794e-05_rb,0.23319e-05_rb,0.23849e-05_rb,0.24386e-05_rb,0.24928e-05_rb, &
+      0.25477e-05_rb,0.26031e-05_rb,0.26591e-05_rb,0.27157e-05_rb,0.27728e-05_rb, &
+      0.28306e-05_rb,0.28889e-05_rb,0.29478e-05_rb,0.30073e-05_rb,0.30673e-05_rb, &
+      0.31279e-05_rb,0.31890e-05_rb,0.32507e-05_rb,0.33129e-05_rb,0.33757e-05_rb, &
+      0.34391e-05_rb,0.35029e-05_rb,0.35674e-05_rb,0.36323e-05_rb,0.36978e-05_rb, &
+      0.37638e-05_rb,0.38304e-05_rb,0.38974e-05_rb,0.39650e-05_rb,0.40331e-05_rb, &
+      0.41017e-05_rb,0.41708e-05_rb,0.42405e-05_rb,0.43106e-05_rb,0.43812e-05_rb, &
+      0.44524e-05_rb,0.45240e-05_rb,0.45961e-05_rb,0.46687e-05_rb,0.47418e-05_rb, &
+      0.48153e-05_rb,0.48894e-05_rb,0.49639e-05_rb,0.50389e-05_rb,0.51143e-05_rb/)
+      totplnk(51:100,  2) = (/ &
+      0.51902e-05_rb,0.52666e-05_rb,0.53434e-05_rb,0.54207e-05_rb,0.54985e-05_rb, &
+      0.55767e-05_rb,0.56553e-05_rb,0.57343e-05_rb,0.58139e-05_rb,0.58938e-05_rb, &
+      0.59742e-05_rb,0.60550e-05_rb,0.61362e-05_rb,0.62179e-05_rb,0.63000e-05_rb, &
+      0.63825e-05_rb,0.64654e-05_rb,0.65487e-05_rb,0.66324e-05_rb,0.67166e-05_rb, &
+      0.68011e-05_rb,0.68860e-05_rb,0.69714e-05_rb,0.70571e-05_rb,0.71432e-05_rb, &
+      0.72297e-05_rb,0.73166e-05_rb,0.74039e-05_rb,0.74915e-05_rb,0.75796e-05_rb, &
+      0.76680e-05_rb,0.77567e-05_rb,0.78459e-05_rb,0.79354e-05_rb,0.80252e-05_rb, &
+      0.81155e-05_rb,0.82061e-05_rb,0.82970e-05_rb,0.83883e-05_rb,0.84799e-05_rb, &
+      0.85719e-05_rb,0.86643e-05_rb,0.87569e-05_rb,0.88499e-05_rb,0.89433e-05_rb, &
+      0.90370e-05_rb,0.91310e-05_rb,0.92254e-05_rb,0.93200e-05_rb,0.94150e-05_rb/)
+      totplnk(101:150,  2) = (/ &
+      0.95104e-05_rb,0.96060e-05_rb,0.97020e-05_rb,0.97982e-05_rb,0.98948e-05_rb, &
+      0.99917e-05_rb,0.10089e-04_rb,0.10186e-04_rb,0.10284e-04_rb,0.10382e-04_rb, &
+      0.10481e-04_rb,0.10580e-04_rb,0.10679e-04_rb,0.10778e-04_rb,0.10877e-04_rb, &
+      0.10977e-04_rb,0.11077e-04_rb,0.11178e-04_rb,0.11279e-04_rb,0.11380e-04_rb, &
+      0.11481e-04_rb,0.11583e-04_rb,0.11684e-04_rb,0.11786e-04_rb,0.11889e-04_rb, &
+      0.11992e-04_rb,0.12094e-04_rb,0.12198e-04_rb,0.12301e-04_rb,0.12405e-04_rb, &
+      0.12509e-04_rb,0.12613e-04_rb,0.12717e-04_rb,0.12822e-04_rb,0.12927e-04_rb, &
+      0.13032e-04_rb,0.13138e-04_rb,0.13244e-04_rb,0.13349e-04_rb,0.13456e-04_rb, &
+      0.13562e-04_rb,0.13669e-04_rb,0.13776e-04_rb,0.13883e-04_rb,0.13990e-04_rb, &
+      0.14098e-04_rb,0.14206e-04_rb,0.14314e-04_rb,0.14422e-04_rb,0.14531e-04_rb/)
+      totplnk(151:181,  2) = (/ &
+      0.14639e-04_rb,0.14748e-04_rb,0.14857e-04_rb,0.14967e-04_rb,0.15076e-04_rb, &
+      0.15186e-04_rb,0.15296e-04_rb,0.15407e-04_rb,0.15517e-04_rb,0.15628e-04_rb, &
+      0.15739e-04_rb,0.15850e-04_rb,0.15961e-04_rb,0.16072e-04_rb,0.16184e-04_rb, &
+      0.16296e-04_rb,0.16408e-04_rb,0.16521e-04_rb,0.16633e-04_rb,0.16746e-04_rb, &
+      0.16859e-04_rb,0.16972e-04_rb,0.17085e-04_rb,0.17198e-04_rb,0.17312e-04_rb, &
+      0.17426e-04_rb,0.17540e-04_rb,0.17654e-04_rb,0.17769e-04_rb,0.17883e-04_rb, &
+      0.17998e-04_rb/)
+      totplnk(1:50, 3) = (/ &
+      1.34822e-06_rb,1.39134e-06_rb,1.43530e-06_rb,1.48010e-06_rb,1.52574e-06_rb, &
+      1.57222e-06_rb,1.61956e-06_rb,1.66774e-06_rb,1.71678e-06_rb,1.76666e-06_rb, &
+      1.81741e-06_rb,1.86901e-06_rb,1.92147e-06_rb,1.97479e-06_rb,2.02898e-06_rb, &
+      2.08402e-06_rb,2.13993e-06_rb,2.19671e-06_rb,2.25435e-06_rb,2.31285e-06_rb, &
+      2.37222e-06_rb,2.43246e-06_rb,2.49356e-06_rb,2.55553e-06_rb,2.61837e-06_rb, &
+      2.68207e-06_rb,2.74664e-06_rb,2.81207e-06_rb,2.87837e-06_rb,2.94554e-06_rb, &
+      3.01356e-06_rb,3.08245e-06_rb,3.15221e-06_rb,3.22282e-06_rb,3.29429e-06_rb, &
+      3.36662e-06_rb,3.43982e-06_rb,3.51386e-06_rb,3.58876e-06_rb,3.66451e-06_rb, &
+      3.74112e-06_rb,3.81857e-06_rb,3.89688e-06_rb,3.97602e-06_rb,4.05601e-06_rb, &
+      4.13685e-06_rb,4.21852e-06_rb,4.30104e-06_rb,4.38438e-06_rb,4.46857e-06_rb/)
+      totplnk(51:100, 3) = (/ &
+      4.55358e-06_rb,4.63943e-06_rb,4.72610e-06_rb,4.81359e-06_rb,4.90191e-06_rb, &
+      4.99105e-06_rb,5.08100e-06_rb,5.17176e-06_rb,5.26335e-06_rb,5.35573e-06_rb, &
+      5.44892e-06_rb,5.54292e-06_rb,5.63772e-06_rb,5.73331e-06_rb,5.82970e-06_rb, &
+      5.92688e-06_rb,6.02485e-06_rb,6.12360e-06_rb,6.22314e-06_rb,6.32346e-06_rb, &
+      6.42455e-06_rb,6.52641e-06_rb,6.62906e-06_rb,6.73247e-06_rb,6.83664e-06_rb, &
+      6.94156e-06_rb,7.04725e-06_rb,7.15370e-06_rb,7.26089e-06_rb,7.36883e-06_rb, &
+      7.47752e-06_rb,7.58695e-06_rb,7.69712e-06_rb,7.80801e-06_rb,7.91965e-06_rb, &
+      8.03201e-06_rb,8.14510e-06_rb,8.25891e-06_rb,8.37343e-06_rb,8.48867e-06_rb, &
+      8.60463e-06_rb,8.72128e-06_rb,8.83865e-06_rb,8.95672e-06_rb,9.07548e-06_rb, &
+      9.19495e-06_rb,9.31510e-06_rb,9.43594e-06_rb,9.55745e-06_rb,9.67966e-06_rb/)
+      totplnk(101:150, 3) = (/ &
+      9.80254e-06_rb,9.92609e-06_rb,1.00503e-05_rb,1.01752e-05_rb,1.03008e-05_rb, &
+      1.04270e-05_rb,1.05539e-05_rb,1.06814e-05_rb,1.08096e-05_rb,1.09384e-05_rb, &
+      1.10679e-05_rb,1.11980e-05_rb,1.13288e-05_rb,1.14601e-05_rb,1.15922e-05_rb, &
+      1.17248e-05_rb,1.18581e-05_rb,1.19920e-05_rb,1.21265e-05_rb,1.22616e-05_rb, &
+      1.23973e-05_rb,1.25337e-05_rb,1.26706e-05_rb,1.28081e-05_rb,1.29463e-05_rb, &
+      1.30850e-05_rb,1.32243e-05_rb,1.33642e-05_rb,1.35047e-05_rb,1.36458e-05_rb, &
+      1.37875e-05_rb,1.39297e-05_rb,1.40725e-05_rb,1.42159e-05_rb,1.43598e-05_rb, &
+      1.45044e-05_rb,1.46494e-05_rb,1.47950e-05_rb,1.49412e-05_rb,1.50879e-05_rb, &
+      1.52352e-05_rb,1.53830e-05_rb,1.55314e-05_rb,1.56803e-05_rb,1.58297e-05_rb, &
+      1.59797e-05_rb,1.61302e-05_rb,1.62812e-05_rb,1.64327e-05_rb,1.65848e-05_rb/)
+      totplnk(151:181, 3) = (/ &
+      1.67374e-05_rb,1.68904e-05_rb,1.70441e-05_rb,1.71982e-05_rb,1.73528e-05_rb, &
+      1.75079e-05_rb,1.76635e-05_rb,1.78197e-05_rb,1.79763e-05_rb,1.81334e-05_rb, &
+      1.82910e-05_rb,1.84491e-05_rb,1.86076e-05_rb,1.87667e-05_rb,1.89262e-05_rb, &
+      1.90862e-05_rb,1.92467e-05_rb,1.94076e-05_rb,1.95690e-05_rb,1.97309e-05_rb, &
+      1.98932e-05_rb,2.00560e-05_rb,2.02193e-05_rb,2.03830e-05_rb,2.05472e-05_rb, &
+      2.07118e-05_rb,2.08768e-05_rb,2.10423e-05_rb,2.12083e-05_rb,2.13747e-05_rb, &
+      2.15414e-05_rb/)
+      totplnk(1:50, 4) = (/ &
+      8.90528e-07_rb,9.24222e-07_rb,9.58757e-07_rb,9.94141e-07_rb,1.03038e-06_rb, &
+      1.06748e-06_rb,1.10545e-06_rb,1.14430e-06_rb,1.18403e-06_rb,1.22465e-06_rb, &
+      1.26618e-06_rb,1.30860e-06_rb,1.35193e-06_rb,1.39619e-06_rb,1.44136e-06_rb, &
+      1.48746e-06_rb,1.53449e-06_rb,1.58246e-06_rb,1.63138e-06_rb,1.68124e-06_rb, &
+      1.73206e-06_rb,1.78383e-06_rb,1.83657e-06_rb,1.89028e-06_rb,1.94495e-06_rb, &
+      2.00060e-06_rb,2.05724e-06_rb,2.11485e-06_rb,2.17344e-06_rb,2.23303e-06_rb, &
+      2.29361e-06_rb,2.35519e-06_rb,2.41777e-06_rb,2.48134e-06_rb,2.54592e-06_rb, &
+      2.61151e-06_rb,2.67810e-06_rb,2.74571e-06_rb,2.81433e-06_rb,2.88396e-06_rb, &
+      2.95461e-06_rb,3.02628e-06_rb,3.09896e-06_rb,3.17267e-06_rb,3.24741e-06_rb, &
+      3.32316e-06_rb,3.39994e-06_rb,3.47774e-06_rb,3.55657e-06_rb,3.63642e-06_rb/)
+      totplnk(51:100, 4) = (/ &
+      3.71731e-06_rb,3.79922e-06_rb,3.88216e-06_rb,3.96612e-06_rb,4.05112e-06_rb, &
+      4.13714e-06_rb,4.22419e-06_rb,4.31227e-06_rb,4.40137e-06_rb,4.49151e-06_rb, &
+      4.58266e-06_rb,4.67485e-06_rb,4.76806e-06_rb,4.86229e-06_rb,4.95754e-06_rb, &
+      5.05383e-06_rb,5.15113e-06_rb,5.24946e-06_rb,5.34879e-06_rb,5.44916e-06_rb, &
+      5.55053e-06_rb,5.65292e-06_rb,5.75632e-06_rb,5.86073e-06_rb,5.96616e-06_rb, &
+      6.07260e-06_rb,6.18003e-06_rb,6.28848e-06_rb,6.39794e-06_rb,6.50838e-06_rb, &
+      6.61983e-06_rb,6.73229e-06_rb,6.84573e-06_rb,6.96016e-06_rb,7.07559e-06_rb, &
+      7.19200e-06_rb,7.30940e-06_rb,7.42779e-06_rb,7.54715e-06_rb,7.66749e-06_rb, &
+      7.78882e-06_rb,7.91110e-06_rb,8.03436e-06_rb,8.15859e-06_rb,8.28379e-06_rb, &
+      8.40994e-06_rb,8.53706e-06_rb,8.66515e-06_rb,8.79418e-06_rb,8.92416e-06_rb/)
+      totplnk(101:150, 4) = (/ &
+      9.05510e-06_rb,9.18697e-06_rb,9.31979e-06_rb,9.45356e-06_rb,9.58826e-06_rb, &
+      9.72389e-06_rb,9.86046e-06_rb,9.99793e-06_rb,1.01364e-05_rb,1.02757e-05_rb, &
+      1.04159e-05_rb,1.05571e-05_rb,1.06992e-05_rb,1.08422e-05_rb,1.09861e-05_rb, &
+      1.11309e-05_rb,1.12766e-05_rb,1.14232e-05_rb,1.15707e-05_rb,1.17190e-05_rb, &
+      1.18683e-05_rb,1.20184e-05_rb,1.21695e-05_rb,1.23214e-05_rb,1.24741e-05_rb, &
+      1.26277e-05_rb,1.27822e-05_rb,1.29376e-05_rb,1.30939e-05_rb,1.32509e-05_rb, &
+      1.34088e-05_rb,1.35676e-05_rb,1.37273e-05_rb,1.38877e-05_rb,1.40490e-05_rb, &
+      1.42112e-05_rb,1.43742e-05_rb,1.45380e-05_rb,1.47026e-05_rb,1.48680e-05_rb, &
+      1.50343e-05_rb,1.52014e-05_rb,1.53692e-05_rb,1.55379e-05_rb,1.57074e-05_rb, &
+      1.58778e-05_rb,1.60488e-05_rb,1.62207e-05_rb,1.63934e-05_rb,1.65669e-05_rb/)
+      totplnk(151:181, 4) = (/ &
+      1.67411e-05_rb,1.69162e-05_rb,1.70920e-05_rb,1.72685e-05_rb,1.74459e-05_rb, &
+      1.76240e-05_rb,1.78029e-05_rb,1.79825e-05_rb,1.81629e-05_rb,1.83440e-05_rb, &
+      1.85259e-05_rb,1.87086e-05_rb,1.88919e-05_rb,1.90760e-05_rb,1.92609e-05_rb, &
+      1.94465e-05_rb,1.96327e-05_rb,1.98199e-05_rb,2.00076e-05_rb,2.01961e-05_rb, &
+      2.03853e-05_rb,2.05752e-05_rb,2.07658e-05_rb,2.09571e-05_rb,2.11491e-05_rb, &
+      2.13418e-05_rb,2.15352e-05_rb,2.17294e-05_rb,2.19241e-05_rb,2.21196e-05_rb, &
+      2.23158e-05_rb/)
+      totplnk(1:50, 5) = (/ &
+      5.70230e-07_rb,5.94788e-07_rb,6.20085e-07_rb,6.46130e-07_rb,6.72936e-07_rb, &
+      7.00512e-07_rb,7.28869e-07_rb,7.58019e-07_rb,7.87971e-07_rb,8.18734e-07_rb, &
+      8.50320e-07_rb,8.82738e-07_rb,9.15999e-07_rb,9.50110e-07_rb,9.85084e-07_rb, &
+      1.02093e-06_rb,1.05765e-06_rb,1.09527e-06_rb,1.13378e-06_rb,1.17320e-06_rb, &
+      1.21353e-06_rb,1.25479e-06_rb,1.29698e-06_rb,1.34011e-06_rb,1.38419e-06_rb, &
+      1.42923e-06_rb,1.47523e-06_rb,1.52221e-06_rb,1.57016e-06_rb,1.61910e-06_rb, &
+      1.66904e-06_rb,1.71997e-06_rb,1.77192e-06_rb,1.82488e-06_rb,1.87886e-06_rb, &
+      1.93387e-06_rb,1.98991e-06_rb,2.04699e-06_rb,2.10512e-06_rb,2.16430e-06_rb, &
+      2.22454e-06_rb,2.28584e-06_rb,2.34821e-06_rb,2.41166e-06_rb,2.47618e-06_rb, &
+      2.54178e-06_rb,2.60847e-06_rb,2.67626e-06_rb,2.74514e-06_rb,2.81512e-06_rb/)
+      totplnk(51:100, 5) = (/ &
+      2.88621e-06_rb,2.95841e-06_rb,3.03172e-06_rb,3.10615e-06_rb,3.18170e-06_rb, &
+      3.25838e-06_rb,3.33618e-06_rb,3.41511e-06_rb,3.49518e-06_rb,3.57639e-06_rb, &
+      3.65873e-06_rb,3.74221e-06_rb,3.82684e-06_rb,3.91262e-06_rb,3.99955e-06_rb, &
+      4.08763e-06_rb,4.17686e-06_rb,4.26725e-06_rb,4.35880e-06_rb,4.45150e-06_rb, &
+      4.54537e-06_rb,4.64039e-06_rb,4.73659e-06_rb,4.83394e-06_rb,4.93246e-06_rb, &
+      5.03215e-06_rb,5.13301e-06_rb,5.23504e-06_rb,5.33823e-06_rb,5.44260e-06_rb, &
+      5.54814e-06_rb,5.65484e-06_rb,5.76272e-06_rb,5.87177e-06_rb,5.98199e-06_rb, &
+      6.09339e-06_rb,6.20596e-06_rb,6.31969e-06_rb,6.43460e-06_rb,6.55068e-06_rb, &
+      6.66793e-06_rb,6.78636e-06_rb,6.90595e-06_rb,7.02670e-06_rb,7.14863e-06_rb, &
+      7.27173e-06_rb,7.39599e-06_rb,7.52142e-06_rb,7.64802e-06_rb,7.77577e-06_rb/)
+      totplnk(101:150, 5) = (/ &
+      7.90469e-06_rb,8.03477e-06_rb,8.16601e-06_rb,8.29841e-06_rb,8.43198e-06_rb, &
+      8.56669e-06_rb,8.70256e-06_rb,8.83957e-06_rb,8.97775e-06_rb,9.11706e-06_rb, &
+      9.25753e-06_rb,9.39915e-06_rb,9.54190e-06_rb,9.68580e-06_rb,9.83085e-06_rb, &
+      9.97704e-06_rb,1.01243e-05_rb,1.02728e-05_rb,1.04224e-05_rb,1.05731e-05_rb, &
+      1.07249e-05_rb,1.08779e-05_rb,1.10320e-05_rb,1.11872e-05_rb,1.13435e-05_rb, &
+      1.15009e-05_rb,1.16595e-05_rb,1.18191e-05_rb,1.19799e-05_rb,1.21418e-05_rb, &
+      1.23048e-05_rb,1.24688e-05_rb,1.26340e-05_rb,1.28003e-05_rb,1.29676e-05_rb, &
+      1.31361e-05_rb,1.33056e-05_rb,1.34762e-05_rb,1.36479e-05_rb,1.38207e-05_rb, &
+      1.39945e-05_rb,1.41694e-05_rb,1.43454e-05_rb,1.45225e-05_rb,1.47006e-05_rb, &
+      1.48797e-05_rb,1.50600e-05_rb,1.52413e-05_rb,1.54236e-05_rb,1.56070e-05_rb/)
+      totplnk(151:181, 5) = (/ &
+      1.57914e-05_rb,1.59768e-05_rb,1.61633e-05_rb,1.63509e-05_rb,1.65394e-05_rb, &
+      1.67290e-05_rb,1.69197e-05_rb,1.71113e-05_rb,1.73040e-05_rb,1.74976e-05_rb, &
+      1.76923e-05_rb,1.78880e-05_rb,1.80847e-05_rb,1.82824e-05_rb,1.84811e-05_rb, &
+      1.86808e-05_rb,1.88814e-05_rb,1.90831e-05_rb,1.92857e-05_rb,1.94894e-05_rb, &
+      1.96940e-05_rb,1.98996e-05_rb,2.01061e-05_rb,2.03136e-05_rb,2.05221e-05_rb, &
+      2.07316e-05_rb,2.09420e-05_rb,2.11533e-05_rb,2.13657e-05_rb,2.15789e-05_rb, &
+      2.17931e-05_rb/)
+      totplnk(1:50, 6) = (/ &
+      2.73493e-07_rb,2.87408e-07_rb,3.01848e-07_rb,3.16825e-07_rb,3.32352e-07_rb, &
+      3.48439e-07_rb,3.65100e-07_rb,3.82346e-07_rb,4.00189e-07_rb,4.18641e-07_rb, &
+      4.37715e-07_rb,4.57422e-07_rb,4.77774e-07_rb,4.98784e-07_rb,5.20464e-07_rb, &
+      5.42824e-07_rb,5.65879e-07_rb,5.89638e-07_rb,6.14115e-07_rb,6.39320e-07_rb, &
+      6.65266e-07_rb,6.91965e-07_rb,7.19427e-07_rb,7.47666e-07_rb,7.76691e-07_rb, &
+      8.06516e-07_rb,8.37151e-07_rb,8.68607e-07_rb,9.00896e-07_rb,9.34029e-07_rb, &
+      9.68018e-07_rb,1.00287e-06_rb,1.03860e-06_rb,1.07522e-06_rb,1.11274e-06_rb, &
+      1.15117e-06_rb,1.19052e-06_rb,1.23079e-06_rb,1.27201e-06_rb,1.31418e-06_rb, &
+      1.35731e-06_rb,1.40141e-06_rb,1.44650e-06_rb,1.49257e-06_rb,1.53965e-06_rb, &
+      1.58773e-06_rb,1.63684e-06_rb,1.68697e-06_rb,1.73815e-06_rb,1.79037e-06_rb/)
+      totplnk(51:100, 6) = (/ &
+      1.84365e-06_rb,1.89799e-06_rb,1.95341e-06_rb,2.00991e-06_rb,2.06750e-06_rb, &
+      2.12619e-06_rb,2.18599e-06_rb,2.24691e-06_rb,2.30895e-06_rb,2.37212e-06_rb, &
+      2.43643e-06_rb,2.50189e-06_rb,2.56851e-06_rb,2.63628e-06_rb,2.70523e-06_rb, &
+      2.77536e-06_rb,2.84666e-06_rb,2.91916e-06_rb,2.99286e-06_rb,3.06776e-06_rb, &
+      3.14387e-06_rb,3.22120e-06_rb,3.29975e-06_rb,3.37953e-06_rb,3.46054e-06_rb, &
+      3.54280e-06_rb,3.62630e-06_rb,3.71105e-06_rb,3.79707e-06_rb,3.88434e-06_rb, &
+      3.97288e-06_rb,4.06270e-06_rb,4.15380e-06_rb,4.24617e-06_rb,4.33984e-06_rb, &
+      4.43479e-06_rb,4.53104e-06_rb,4.62860e-06_rb,4.72746e-06_rb,4.82763e-06_rb, &
+      4.92911e-06_rb,5.03191e-06_rb,5.13603e-06_rb,5.24147e-06_rb,5.34824e-06_rb, &
+      5.45634e-06_rb,5.56578e-06_rb,5.67656e-06_rb,5.78867e-06_rb,5.90213e-06_rb/)
+      totplnk(101:150, 6) = (/ &
+      6.01694e-06_rb,6.13309e-06_rb,6.25060e-06_rb,6.36947e-06_rb,6.48968e-06_rb, &
+      6.61126e-06_rb,6.73420e-06_rb,6.85850e-06_rb,6.98417e-06_rb,7.11120e-06_rb, &
+      7.23961e-06_rb,7.36938e-06_rb,7.50053e-06_rb,7.63305e-06_rb,7.76694e-06_rb, &
+      7.90221e-06_rb,8.03887e-06_rb,8.17690e-06_rb,8.31632e-06_rb,8.45710e-06_rb, &
+      8.59928e-06_rb,8.74282e-06_rb,8.88776e-06_rb,9.03409e-06_rb,9.18179e-06_rb, &
+      9.33088e-06_rb,9.48136e-06_rb,9.63323e-06_rb,9.78648e-06_rb,9.94111e-06_rb, &
+      1.00971e-05_rb,1.02545e-05_rb,1.04133e-05_rb,1.05735e-05_rb,1.07351e-05_rb, &
+      1.08980e-05_rb,1.10624e-05_rb,1.12281e-05_rb,1.13952e-05_rb,1.15637e-05_rb, &
+      1.17335e-05_rb,1.19048e-05_rb,1.20774e-05_rb,1.22514e-05_rb,1.24268e-05_rb, &
+      1.26036e-05_rb,1.27817e-05_rb,1.29612e-05_rb,1.31421e-05_rb,1.33244e-05_rb/)
+      totplnk(151:181, 6) = (/ &
+      1.35080e-05_rb,1.36930e-05_rb,1.38794e-05_rb,1.40672e-05_rb,1.42563e-05_rb, &
+      1.44468e-05_rb,1.46386e-05_rb,1.48318e-05_rb,1.50264e-05_rb,1.52223e-05_rb, &
+      1.54196e-05_rb,1.56182e-05_rb,1.58182e-05_rb,1.60196e-05_rb,1.62223e-05_rb, &
+      1.64263e-05_rb,1.66317e-05_rb,1.68384e-05_rb,1.70465e-05_rb,1.72559e-05_rb, &
+      1.74666e-05_rb,1.76787e-05_rb,1.78921e-05_rb,1.81069e-05_rb,1.83230e-05_rb, &
+      1.85404e-05_rb,1.87591e-05_rb,1.89791e-05_rb,1.92005e-05_rb,1.94232e-05_rb, &
+      1.96471e-05_rb/)
+      totplnk(1:50, 7) = (/ &
+      1.25349e-07_rb,1.32735e-07_rb,1.40458e-07_rb,1.48527e-07_rb,1.56954e-07_rb, &
+      1.65748e-07_rb,1.74920e-07_rb,1.84481e-07_rb,1.94443e-07_rb,2.04814e-07_rb, &
+      2.15608e-07_rb,2.26835e-07_rb,2.38507e-07_rb,2.50634e-07_rb,2.63229e-07_rb, &
+      2.76301e-07_rb,2.89864e-07_rb,3.03930e-07_rb,3.18508e-07_rb,3.33612e-07_rb, &
+      3.49253e-07_rb,3.65443e-07_rb,3.82195e-07_rb,3.99519e-07_rb,4.17428e-07_rb, &
+      4.35934e-07_rb,4.55050e-07_rb,4.74785e-07_rb,4.95155e-07_rb,5.16170e-07_rb, &
+      5.37844e-07_rb,5.60186e-07_rb,5.83211e-07_rb,6.06929e-07_rb,6.31355e-07_rb, &
+      6.56498e-07_rb,6.82373e-07_rb,7.08990e-07_rb,7.36362e-07_rb,7.64501e-07_rb, &
+      7.93420e-07_rb,8.23130e-07_rb,8.53643e-07_rb,8.84971e-07_rb,9.17128e-07_rb, &
+      9.50123e-07_rb,9.83969e-07_rb,1.01868e-06_rb,1.05426e-06_rb,1.09073e-06_rb/)
+      totplnk(51:100, 7) = (/ &
+      1.12810e-06_rb,1.16638e-06_rb,1.20558e-06_rb,1.24572e-06_rb,1.28680e-06_rb, &
+      1.32883e-06_rb,1.37183e-06_rb,1.41581e-06_rb,1.46078e-06_rb,1.50675e-06_rb, &
+      1.55374e-06_rb,1.60174e-06_rb,1.65078e-06_rb,1.70087e-06_rb,1.75200e-06_rb, &
+      1.80421e-06_rb,1.85749e-06_rb,1.91186e-06_rb,1.96732e-06_rb,2.02389e-06_rb, &
+      2.08159e-06_rb,2.14040e-06_rb,2.20035e-06_rb,2.26146e-06_rb,2.32372e-06_rb, &
+      2.38714e-06_rb,2.45174e-06_rb,2.51753e-06_rb,2.58451e-06_rb,2.65270e-06_rb, &
+      2.72210e-06_rb,2.79272e-06_rb,2.86457e-06_rb,2.93767e-06_rb,3.01201e-06_rb, &
+      3.08761e-06_rb,3.16448e-06_rb,3.24261e-06_rb,3.32204e-06_rb,3.40275e-06_rb, &
+      3.48476e-06_rb,3.56808e-06_rb,3.65271e-06_rb,3.73866e-06_rb,3.82595e-06_rb, &
+      3.91456e-06_rb,4.00453e-06_rb,4.09584e-06_rb,4.18851e-06_rb,4.28254e-06_rb/)
+      totplnk(101:150, 7) = (/ &
+      4.37796e-06_rb,4.47475e-06_rb,4.57293e-06_rb,4.67249e-06_rb,4.77346e-06_rb, &
+      4.87583e-06_rb,4.97961e-06_rb,5.08481e-06_rb,5.19143e-06_rb,5.29948e-06_rb, &
+      5.40896e-06_rb,5.51989e-06_rb,5.63226e-06_rb,5.74608e-06_rb,5.86136e-06_rb, &
+      5.97810e-06_rb,6.09631e-06_rb,6.21597e-06_rb,6.33713e-06_rb,6.45976e-06_rb, &
+      6.58388e-06_rb,6.70950e-06_rb,6.83661e-06_rb,6.96521e-06_rb,7.09531e-06_rb, &
+      7.22692e-06_rb,7.36005e-06_rb,7.49468e-06_rb,7.63084e-06_rb,7.76851e-06_rb, &
+      7.90773e-06_rb,8.04846e-06_rb,8.19072e-06_rb,8.33452e-06_rb,8.47985e-06_rb, &
+      8.62674e-06_rb,8.77517e-06_rb,8.92514e-06_rb,9.07666e-06_rb,9.22975e-06_rb, &
+      9.38437e-06_rb,9.54057e-06_rb,9.69832e-06_rb,9.85762e-06_rb,1.00185e-05_rb, &
+      1.01810e-05_rb,1.03450e-05_rb,1.05106e-05_rb,1.06777e-05_rb,1.08465e-05_rb/)
+      totplnk(151:181, 7) = (/ &
+      1.10168e-05_rb,1.11887e-05_rb,1.13621e-05_rb,1.15372e-05_rb,1.17138e-05_rb, &
+      1.18920e-05_rb,1.20718e-05_rb,1.22532e-05_rb,1.24362e-05_rb,1.26207e-05_rb, &
+      1.28069e-05_rb,1.29946e-05_rb,1.31839e-05_rb,1.33749e-05_rb,1.35674e-05_rb, &
+      1.37615e-05_rb,1.39572e-05_rb,1.41544e-05_rb,1.43533e-05_rb,1.45538e-05_rb, &
+      1.47558e-05_rb,1.49595e-05_rb,1.51647e-05_rb,1.53716e-05_rb,1.55800e-05_rb, &
+      1.57900e-05_rb,1.60017e-05_rb,1.62149e-05_rb,1.64296e-05_rb,1.66460e-05_rb, &
+      1.68640e-05_rb/)
+      totplnk(1:50, 8) = (/ &
+      6.74445e-08_rb,7.18176e-08_rb,7.64153e-08_rb,8.12456e-08_rb,8.63170e-08_rb, &
+      9.16378e-08_rb,9.72168e-08_rb,1.03063e-07_rb,1.09184e-07_rb,1.15591e-07_rb, &
+      1.22292e-07_rb,1.29296e-07_rb,1.36613e-07_rb,1.44253e-07_rb,1.52226e-07_rb, &
+      1.60540e-07_rb,1.69207e-07_rb,1.78236e-07_rb,1.87637e-07_rb,1.97421e-07_rb, &
+      2.07599e-07_rb,2.18181e-07_rb,2.29177e-07_rb,2.40598e-07_rb,2.52456e-07_rb, &
+      2.64761e-07_rb,2.77523e-07_rb,2.90755e-07_rb,3.04468e-07_rb,3.18673e-07_rb, &
+      3.33381e-07_rb,3.48603e-07_rb,3.64352e-07_rb,3.80638e-07_rb,3.97474e-07_rb, &
+      4.14871e-07_rb,4.32841e-07_rb,4.51395e-07_rb,4.70547e-07_rb,4.90306e-07_rb, &
+      5.10687e-07_rb,5.31699e-07_rb,5.53357e-07_rb,5.75670e-07_rb,5.98652e-07_rb, &
+      6.22315e-07_rb,6.46672e-07_rb,6.71731e-07_rb,6.97511e-07_rb,7.24018e-07_rb/)
+      totplnk(51:100, 8) = (/ &
+      7.51266e-07_rb,7.79269e-07_rb,8.08038e-07_rb,8.37584e-07_rb,8.67922e-07_rb, &
+      8.99061e-07_rb,9.31016e-07_rb,9.63797e-07_rb,9.97417e-07_rb,1.03189e-06_rb, &
+      1.06722e-06_rb,1.10343e-06_rb,1.14053e-06_rb,1.17853e-06_rb,1.21743e-06_rb, &
+      1.25726e-06_rb,1.29803e-06_rb,1.33974e-06_rb,1.38241e-06_rb,1.42606e-06_rb, &
+      1.47068e-06_rb,1.51630e-06_rb,1.56293e-06_rb,1.61056e-06_rb,1.65924e-06_rb, &
+      1.70894e-06_rb,1.75971e-06_rb,1.81153e-06_rb,1.86443e-06_rb,1.91841e-06_rb, &
+      1.97350e-06_rb,2.02968e-06_rb,2.08699e-06_rb,2.14543e-06_rb,2.20500e-06_rb, &
+      2.26573e-06_rb,2.32762e-06_rb,2.39068e-06_rb,2.45492e-06_rb,2.52036e-06_rb, &
+      2.58700e-06_rb,2.65485e-06_rb,2.72393e-06_rb,2.79424e-06_rb,2.86580e-06_rb, &
+      2.93861e-06_rb,3.01269e-06_rb,3.08803e-06_rb,3.16467e-06_rb,3.24259e-06_rb/)
+      totplnk(101:150, 8) = (/ &
+      3.32181e-06_rb,3.40235e-06_rb,3.48420e-06_rb,3.56739e-06_rb,3.65192e-06_rb, &
+      3.73779e-06_rb,3.82502e-06_rb,3.91362e-06_rb,4.00359e-06_rb,4.09494e-06_rb, &
+      4.18768e-06_rb,4.28182e-06_rb,4.37737e-06_rb,4.47434e-06_rb,4.57273e-06_rb, &
+      4.67254e-06_rb,4.77380e-06_rb,4.87651e-06_rb,4.98067e-06_rb,5.08630e-06_rb, &
+      5.19339e-06_rb,5.30196e-06_rb,5.41201e-06_rb,5.52356e-06_rb,5.63660e-06_rb, &
+      5.75116e-06_rb,5.86722e-06_rb,5.98479e-06_rb,6.10390e-06_rb,6.22453e-06_rb, &
+      6.34669e-06_rb,6.47042e-06_rb,6.59569e-06_rb,6.72252e-06_rb,6.85090e-06_rb, &
+      6.98085e-06_rb,7.11238e-06_rb,7.24549e-06_rb,7.38019e-06_rb,7.51646e-06_rb, &
+      7.65434e-06_rb,7.79382e-06_rb,7.93490e-06_rb,8.07760e-06_rb,8.22192e-06_rb, &
+      8.36784e-06_rb,8.51540e-06_rb,8.66459e-06_rb,8.81542e-06_rb,8.96786e-06_rb/)
+      totplnk(151:181, 8) = (/ &
+      9.12197e-06_rb,9.27772e-06_rb,9.43513e-06_rb,9.59419e-06_rb,9.75490e-06_rb, &
+      9.91728e-06_rb,1.00813e-05_rb,1.02471e-05_rb,1.04144e-05_rb,1.05835e-05_rb, &
+      1.07543e-05_rb,1.09267e-05_rb,1.11008e-05_rb,1.12766e-05_rb,1.14541e-05_rb, &
+      1.16333e-05_rb,1.18142e-05_rb,1.19969e-05_rb,1.21812e-05_rb,1.23672e-05_rb, &
+      1.25549e-05_rb,1.27443e-05_rb,1.29355e-05_rb,1.31284e-05_rb,1.33229e-05_rb, &
+      1.35193e-05_rb,1.37173e-05_rb,1.39170e-05_rb,1.41185e-05_rb,1.43217e-05_rb, &
+      1.45267e-05_rb/)
+      totplnk(1:50, 9) = (/ &
+      2.61522e-08_rb,2.80613e-08_rb,3.00838e-08_rb,3.22250e-08_rb,3.44899e-08_rb, &
+      3.68841e-08_rb,3.94129e-08_rb,4.20820e-08_rb,4.48973e-08_rb,4.78646e-08_rb, &
+      5.09901e-08_rb,5.42799e-08_rb,5.77405e-08_rb,6.13784e-08_rb,6.52001e-08_rb, &
+      6.92126e-08_rb,7.34227e-08_rb,7.78375e-08_rb,8.24643e-08_rb,8.73103e-08_rb, &
+      9.23832e-08_rb,9.76905e-08_rb,1.03240e-07_rb,1.09039e-07_rb,1.15097e-07_rb, &
+      1.21421e-07_rb,1.28020e-07_rb,1.34902e-07_rb,1.42075e-07_rb,1.49548e-07_rb, &
+      1.57331e-07_rb,1.65432e-07_rb,1.73860e-07_rb,1.82624e-07_rb,1.91734e-07_rb, &
+      2.01198e-07_rb,2.11028e-07_rb,2.21231e-07_rb,2.31818e-07_rb,2.42799e-07_rb, &
+      2.54184e-07_rb,2.65983e-07_rb,2.78205e-07_rb,2.90862e-07_rb,3.03963e-07_rb, &
+      3.17519e-07_rb,3.31541e-07_rb,3.46039e-07_rb,3.61024e-07_rb,3.76507e-07_rb/)
+      totplnk(51:100, 9) = (/ &
+      3.92498e-07_rb,4.09008e-07_rb,4.26050e-07_rb,4.43633e-07_rb,4.61769e-07_rb, &
+      4.80469e-07_rb,4.99744e-07_rb,5.19606e-07_rb,5.40067e-07_rb,5.61136e-07_rb, &
+      5.82828e-07_rb,6.05152e-07_rb,6.28120e-07_rb,6.51745e-07_rb,6.76038e-07_rb, &
+      7.01010e-07_rb,7.26674e-07_rb,7.53041e-07_rb,7.80124e-07_rb,8.07933e-07_rb, &
+      8.36482e-07_rb,8.65781e-07_rb,8.95845e-07_rb,9.26683e-07_rb,9.58308e-07_rb, &
+      9.90732e-07_rb,1.02397e-06_rb,1.05803e-06_rb,1.09292e-06_rb,1.12866e-06_rb, &
+      1.16526e-06_rb,1.20274e-06_rb,1.24109e-06_rb,1.28034e-06_rb,1.32050e-06_rb, &
+      1.36158e-06_rb,1.40359e-06_rb,1.44655e-06_rb,1.49046e-06_rb,1.53534e-06_rb, &
+      1.58120e-06_rb,1.62805e-06_rb,1.67591e-06_rb,1.72478e-06_rb,1.77468e-06_rb, &
+      1.82561e-06_rb,1.87760e-06_rb,1.93066e-06_rb,1.98479e-06_rb,2.04000e-06_rb/)
+      totplnk(101:150, 9) = (/ &
+      2.09631e-06_rb,2.15373e-06_rb,2.21228e-06_rb,2.27196e-06_rb,2.33278e-06_rb, &
+      2.39475e-06_rb,2.45790e-06_rb,2.52222e-06_rb,2.58773e-06_rb,2.65445e-06_rb, &
+      2.72238e-06_rb,2.79152e-06_rb,2.86191e-06_rb,2.93354e-06_rb,3.00643e-06_rb, &
+      3.08058e-06_rb,3.15601e-06_rb,3.23273e-06_rb,3.31075e-06_rb,3.39009e-06_rb, &
+      3.47074e-06_rb,3.55272e-06_rb,3.63605e-06_rb,3.72072e-06_rb,3.80676e-06_rb, &
+      3.89417e-06_rb,3.98297e-06_rb,4.07315e-06_rb,4.16474e-06_rb,4.25774e-06_rb, &
+      4.35217e-06_rb,4.44802e-06_rb,4.54532e-06_rb,4.64406e-06_rb,4.74428e-06_rb, &
+      4.84595e-06_rb,4.94911e-06_rb,5.05376e-06_rb,5.15990e-06_rb,5.26755e-06_rb, &
+      5.37671e-06_rb,5.48741e-06_rb,5.59963e-06_rb,5.71340e-06_rb,5.82871e-06_rb, &
+      5.94559e-06_rb,6.06403e-06_rb,6.18404e-06_rb,6.30565e-06_rb,6.42885e-06_rb/)
+      totplnk(151:181, 9) = (/ &
+      6.55364e-06_rb,6.68004e-06_rb,6.80806e-06_rb,6.93771e-06_rb,7.06898e-06_rb, &
+      7.20190e-06_rb,7.33646e-06_rb,7.47267e-06_rb,7.61056e-06_rb,7.75010e-06_rb, &
+      7.89133e-06_rb,8.03423e-06_rb,8.17884e-06_rb,8.32514e-06_rb,8.47314e-06_rb, &
+      8.62284e-06_rb,8.77427e-06_rb,8.92743e-06_rb,9.08231e-06_rb,9.23893e-06_rb, &
+      9.39729e-06_rb,9.55741e-06_rb,9.71927e-06_rb,9.88291e-06_rb,1.00483e-05_rb, &
+      1.02155e-05_rb,1.03844e-05_rb,1.05552e-05_rb,1.07277e-05_rb,1.09020e-05_rb, &
+      1.10781e-05_rb/)
+      totplnk(1:50,10) = (/ &
+      8.89300e-09_rb,9.63263e-09_rb,1.04235e-08_rb,1.12685e-08_rb,1.21703e-08_rb, &
+      1.31321e-08_rb,1.41570e-08_rb,1.52482e-08_rb,1.64090e-08_rb,1.76428e-08_rb, &
+      1.89533e-08_rb,2.03441e-08_rb,2.18190e-08_rb,2.33820e-08_rb,2.50370e-08_rb, &
+      2.67884e-08_rb,2.86402e-08_rb,3.05969e-08_rb,3.26632e-08_rb,3.48436e-08_rb, &
+      3.71429e-08_rb,3.95660e-08_rb,4.21179e-08_rb,4.48040e-08_rb,4.76294e-08_rb, &
+      5.05996e-08_rb,5.37201e-08_rb,5.69966e-08_rb,6.04349e-08_rb,6.40411e-08_rb, &
+      6.78211e-08_rb,7.17812e-08_rb,7.59276e-08_rb,8.02670e-08_rb,8.48059e-08_rb, &
+      8.95508e-08_rb,9.45090e-08_rb,9.96873e-08_rb,1.05093e-07_rb,1.10733e-07_rb, &
+      1.16614e-07_rb,1.22745e-07_rb,1.29133e-07_rb,1.35786e-07_rb,1.42711e-07_rb, &
+      1.49916e-07_rb,1.57410e-07_rb,1.65202e-07_rb,1.73298e-07_rb,1.81709e-07_rb/)
+      totplnk(51:100,10) = (/ &
+      1.90441e-07_rb,1.99505e-07_rb,2.08908e-07_rb,2.18660e-07_rb,2.28770e-07_rb, &
+      2.39247e-07_rb,2.50101e-07_rb,2.61340e-07_rb,2.72974e-07_rb,2.85013e-07_rb, &
+      2.97467e-07_rb,3.10345e-07_rb,3.23657e-07_rb,3.37413e-07_rb,3.51623e-07_rb, &
+      3.66298e-07_rb,3.81448e-07_rb,3.97082e-07_rb,4.13212e-07_rb,4.29848e-07_rb, &
+      4.47000e-07_rb,4.64680e-07_rb,4.82898e-07_rb,5.01664e-07_rb,5.20991e-07_rb, &
+      5.40888e-07_rb,5.61369e-07_rb,5.82440e-07_rb,6.04118e-07_rb,6.26410e-07_rb, &
+      6.49329e-07_rb,6.72887e-07_rb,6.97095e-07_rb,7.21964e-07_rb,7.47506e-07_rb, &
+      7.73732e-07_rb,8.00655e-07_rb,8.28287e-07_rb,8.56635e-07_rb,8.85717e-07_rb, &
+      9.15542e-07_rb,9.46122e-07_rb,9.77469e-07_rb,1.00960e-06_rb,1.04251e-06_rb, &
+      1.07623e-06_rb,1.11077e-06_rb,1.14613e-06_rb,1.18233e-06_rb,1.21939e-06_rb/)
+      totplnk(101:150,10) = (/ &
+      1.25730e-06_rb,1.29610e-06_rb,1.33578e-06_rb,1.37636e-06_rb,1.41785e-06_rb, &
+      1.46027e-06_rb,1.50362e-06_rb,1.54792e-06_rb,1.59319e-06_rb,1.63942e-06_rb, &
+      1.68665e-06_rb,1.73487e-06_rb,1.78410e-06_rb,1.83435e-06_rb,1.88564e-06_rb, &
+      1.93797e-06_rb,1.99136e-06_rb,2.04582e-06_rb,2.10137e-06_rb,2.15801e-06_rb, &
+      2.21576e-06_rb,2.27463e-06_rb,2.33462e-06_rb,2.39577e-06_rb,2.45806e-06_rb, &
+      2.52153e-06_rb,2.58617e-06_rb,2.65201e-06_rb,2.71905e-06_rb,2.78730e-06_rb, &
+      2.85678e-06_rb,2.92749e-06_rb,2.99946e-06_rb,3.07269e-06_rb,3.14720e-06_rb, &
+      3.22299e-06_rb,3.30007e-06_rb,3.37847e-06_rb,3.45818e-06_rb,3.53923e-06_rb, &
+      3.62161e-06_rb,3.70535e-06_rb,3.79046e-06_rb,3.87695e-06_rb,3.96481e-06_rb, &
+      4.05409e-06_rb,4.14477e-06_rb,4.23687e-06_rb,4.33040e-06_rb,4.42538e-06_rb/)
+      totplnk(151:181,10) = (/ &
+      4.52180e-06_rb,4.61969e-06_rb,4.71905e-06_rb,4.81991e-06_rb,4.92226e-06_rb, &
+      5.02611e-06_rb,5.13148e-06_rb,5.23839e-06_rb,5.34681e-06_rb,5.45681e-06_rb, &
+      5.56835e-06_rb,5.68146e-06_rb,5.79614e-06_rb,5.91242e-06_rb,6.03030e-06_rb, &
+      6.14978e-06_rb,6.27088e-06_rb,6.39360e-06_rb,6.51798e-06_rb,6.64398e-06_rb, &
+      6.77165e-06_rb,6.90099e-06_rb,7.03198e-06_rb,7.16468e-06_rb,7.29906e-06_rb, &
+      7.43514e-06_rb,7.57294e-06_rb,7.71244e-06_rb,7.85369e-06_rb,7.99666e-06_rb, &
+      8.14138e-06_rb/)
+      totplnk(1:50,11) = (/ &
+      2.53767e-09_rb,2.77242e-09_rb,3.02564e-09_rb,3.29851e-09_rb,3.59228e-09_rb, &
+      3.90825e-09_rb,4.24777e-09_rb,4.61227e-09_rb,5.00322e-09_rb,5.42219e-09_rb, &
+      5.87080e-09_rb,6.35072e-09_rb,6.86370e-09_rb,7.41159e-09_rb,7.99628e-09_rb, &
+      8.61974e-09_rb,9.28404e-09_rb,9.99130e-09_rb,1.07437e-08_rb,1.15436e-08_rb, &
+      1.23933e-08_rb,1.32953e-08_rb,1.42522e-08_rb,1.52665e-08_rb,1.63410e-08_rb, &
+      1.74786e-08_rb,1.86820e-08_rb,1.99542e-08_rb,2.12985e-08_rb,2.27179e-08_rb, &
+      2.42158e-08_rb,2.57954e-08_rb,2.74604e-08_rb,2.92141e-08_rb,3.10604e-08_rb, &
+      3.30029e-08_rb,3.50457e-08_rb,3.71925e-08_rb,3.94476e-08_rb,4.18149e-08_rb, &
+      4.42991e-08_rb,4.69043e-08_rb,4.96352e-08_rb,5.24961e-08_rb,5.54921e-08_rb, &
+      5.86277e-08_rb,6.19081e-08_rb,6.53381e-08_rb,6.89231e-08_rb,7.26681e-08_rb/)
+      totplnk(51:100,11) = (/ &
+      7.65788e-08_rb,8.06604e-08_rb,8.49187e-08_rb,8.93591e-08_rb,9.39879e-08_rb, &
+      9.88106e-08_rb,1.03834e-07_rb,1.09063e-07_rb,1.14504e-07_rb,1.20165e-07_rb, &
+      1.26051e-07_rb,1.32169e-07_rb,1.38525e-07_rb,1.45128e-07_rb,1.51982e-07_rb, &
+      1.59096e-07_rb,1.66477e-07_rb,1.74132e-07_rb,1.82068e-07_rb,1.90292e-07_rb, &
+      1.98813e-07_rb,2.07638e-07_rb,2.16775e-07_rb,2.26231e-07_rb,2.36015e-07_rb, &
+      2.46135e-07_rb,2.56599e-07_rb,2.67415e-07_rb,2.78592e-07_rb,2.90137e-07_rb, &
+      3.02061e-07_rb,3.14371e-07_rb,3.27077e-07_rb,3.40186e-07_rb,3.53710e-07_rb, &
+      3.67655e-07_rb,3.82031e-07_rb,3.96848e-07_rb,4.12116e-07_rb,4.27842e-07_rb, &
+      4.44039e-07_rb,4.60713e-07_rb,4.77876e-07_rb,4.95537e-07_rb,5.13706e-07_rb, &
+      5.32392e-07_rb,5.51608e-07_rb,5.71360e-07_rb,5.91662e-07_rb,6.12521e-07_rb/)
+      totplnk(101:150,11) = (/ &
+      6.33950e-07_rb,6.55958e-07_rb,6.78556e-07_rb,7.01753e-07_rb,7.25562e-07_rb, &
+      7.49992e-07_rb,7.75055e-07_rb,8.00760e-07_rb,8.27120e-07_rb,8.54145e-07_rb, &
+      8.81845e-07_rb,9.10233e-07_rb,9.39318e-07_rb,9.69113e-07_rb,9.99627e-07_rb, &
+      1.03087e-06_rb,1.06286e-06_rb,1.09561e-06_rb,1.12912e-06_rb,1.16340e-06_rb, &
+      1.19848e-06_rb,1.23435e-06_rb,1.27104e-06_rb,1.30855e-06_rb,1.34690e-06_rb, &
+      1.38609e-06_rb,1.42614e-06_rb,1.46706e-06_rb,1.50886e-06_rb,1.55155e-06_rb, &
+      1.59515e-06_rb,1.63967e-06_rb,1.68512e-06_rb,1.73150e-06_rb,1.77884e-06_rb, &
+      1.82715e-06_rb,1.87643e-06_rb,1.92670e-06_rb,1.97797e-06_rb,2.03026e-06_rb, &
+      2.08356e-06_rb,2.13791e-06_rb,2.19330e-06_rb,2.24975e-06_rb,2.30728e-06_rb, &
+      2.36589e-06_rb,2.42560e-06_rb,2.48641e-06_rb,2.54835e-06_rb,2.61142e-06_rb/)
+      totplnk(151:181,11) = (/ &
+      2.67563e-06_rb,2.74100e-06_rb,2.80754e-06_rb,2.87526e-06_rb,2.94417e-06_rb, &
+      3.01429e-06_rb,3.08562e-06_rb,3.15819e-06_rb,3.23199e-06_rb,3.30704e-06_rb, &
+      3.38336e-06_rb,3.46096e-06_rb,3.53984e-06_rb,3.62002e-06_rb,3.70151e-06_rb, &
+      3.78433e-06_rb,3.86848e-06_rb,3.95399e-06_rb,4.04084e-06_rb,4.12907e-06_rb, &
+      4.21868e-06_rb,4.30968e-06_rb,4.40209e-06_rb,4.49592e-06_rb,4.59117e-06_rb, &
+      4.68786e-06_rb,4.78600e-06_rb,4.88561e-06_rb,4.98669e-06_rb,5.08926e-06_rb, &
+      5.19332e-06_rb/)
+      totplnk(1:50,12) = (/ &
+      2.73921e-10_rb,3.04500e-10_rb,3.38056e-10_rb,3.74835e-10_rb,4.15099e-10_rb, &
+      4.59126e-10_rb,5.07214e-10_rb,5.59679e-10_rb,6.16857e-10_rb,6.79103e-10_rb, &
+      7.46796e-10_rb,8.20335e-10_rb,9.00144e-10_rb,9.86671e-10_rb,1.08039e-09_rb, &
+      1.18180e-09_rb,1.29142e-09_rb,1.40982e-09_rb,1.53757e-09_rb,1.67529e-09_rb, &
+      1.82363e-09_rb,1.98327e-09_rb,2.15492e-09_rb,2.33932e-09_rb,2.53726e-09_rb, &
+      2.74957e-09_rb,2.97710e-09_rb,3.22075e-09_rb,3.48145e-09_rb,3.76020e-09_rb, &
+      4.05801e-09_rb,4.37595e-09_rb,4.71513e-09_rb,5.07672e-09_rb,5.46193e-09_rb, &
+      5.87201e-09_rb,6.30827e-09_rb,6.77205e-09_rb,7.26480e-09_rb,7.78794e-09_rb, &
+      8.34304e-09_rb,8.93163e-09_rb,9.55537e-09_rb,1.02159e-08_rb,1.09151e-08_rb, &
+      1.16547e-08_rb,1.24365e-08_rb,1.32625e-08_rb,1.41348e-08_rb,1.50554e-08_rb/)
+      totplnk(51:100,12) = (/ &
+      1.60264e-08_rb,1.70500e-08_rb,1.81285e-08_rb,1.92642e-08_rb,2.04596e-08_rb, &
+      2.17171e-08_rb,2.30394e-08_rb,2.44289e-08_rb,2.58885e-08_rb,2.74209e-08_rb, &
+      2.90290e-08_rb,3.07157e-08_rb,3.24841e-08_rb,3.43371e-08_rb,3.62782e-08_rb, &
+      3.83103e-08_rb,4.04371e-08_rb,4.26617e-08_rb,4.49878e-08_rb,4.74190e-08_rb, &
+      4.99589e-08_rb,5.26113e-08_rb,5.53801e-08_rb,5.82692e-08_rb,6.12826e-08_rb, &
+      6.44245e-08_rb,6.76991e-08_rb,7.11105e-08_rb,7.46634e-08_rb,7.83621e-08_rb, &
+      8.22112e-08_rb,8.62154e-08_rb,9.03795e-08_rb,9.47081e-08_rb,9.92066e-08_rb, &
+      1.03879e-07_rb,1.08732e-07_rb,1.13770e-07_rb,1.18998e-07_rb,1.24422e-07_rb, &
+      1.30048e-07_rb,1.35880e-07_rb,1.41924e-07_rb,1.48187e-07_rb,1.54675e-07_rb, &
+      1.61392e-07_rb,1.68346e-07_rb,1.75543e-07_rb,1.82988e-07_rb,1.90688e-07_rb/)
+      totplnk(101:150,12) = (/ &
+      1.98650e-07_rb,2.06880e-07_rb,2.15385e-07_rb,2.24172e-07_rb,2.33247e-07_rb, &
+      2.42617e-07_rb,2.52289e-07_rb,2.62272e-07_rb,2.72571e-07_rb,2.83193e-07_rb, &
+      2.94147e-07_rb,3.05440e-07_rb,3.17080e-07_rb,3.29074e-07_rb,3.41430e-07_rb, &
+      3.54155e-07_rb,3.67259e-07_rb,3.80747e-07_rb,3.94631e-07_rb,4.08916e-07_rb, &
+      4.23611e-07_rb,4.38725e-07_rb,4.54267e-07_rb,4.70245e-07_rb,4.86666e-07_rb, &
+      5.03541e-07_rb,5.20879e-07_rb,5.38687e-07_rb,5.56975e-07_rb,5.75751e-07_rb, &
+      5.95026e-07_rb,6.14808e-07_rb,6.35107e-07_rb,6.55932e-07_rb,6.77293e-07_rb, &
+      6.99197e-07_rb,7.21656e-07_rb,7.44681e-07_rb,7.68278e-07_rb,7.92460e-07_rb, &
+      8.17235e-07_rb,8.42614e-07_rb,8.68606e-07_rb,8.95223e-07_rb,9.22473e-07_rb, &
+      9.50366e-07_rb,9.78915e-07_rb,1.00813e-06_rb,1.03802e-06_rb,1.06859e-06_rb/)
+      totplnk(151:181,12) = (/ &
+      1.09986e-06_rb,1.13184e-06_rb,1.16453e-06_rb,1.19796e-06_rb,1.23212e-06_rb, &
+      1.26703e-06_rb,1.30270e-06_rb,1.33915e-06_rb,1.37637e-06_rb,1.41440e-06_rb, &
+      1.45322e-06_rb,1.49286e-06_rb,1.53333e-06_rb,1.57464e-06_rb,1.61679e-06_rb, &
+      1.65981e-06_rb,1.70370e-06_rb,1.74847e-06_rb,1.79414e-06_rb,1.84071e-06_rb, &
+      1.88821e-06_rb,1.93663e-06_rb,1.98599e-06_rb,2.03631e-06_rb,2.08759e-06_rb, &
+      2.13985e-06_rb,2.19310e-06_rb,2.24734e-06_rb,2.30260e-06_rb,2.35888e-06_rb, &
+      2.41619e-06_rb/)
+      totplnk(1:50,13) = (/ &
+      4.53634e-11_rb,5.11435e-11_rb,5.75754e-11_rb,6.47222e-11_rb,7.26531e-11_rb, &
+      8.14420e-11_rb,9.11690e-11_rb,1.01921e-10_rb,1.13790e-10_rb,1.26877e-10_rb, &
+      1.41288e-10_rb,1.57140e-10_rb,1.74555e-10_rb,1.93665e-10_rb,2.14613e-10_rb, &
+      2.37548e-10_rb,2.62633e-10_rb,2.90039e-10_rb,3.19948e-10_rb,3.52558e-10_rb, &
+      3.88073e-10_rb,4.26716e-10_rb,4.68719e-10_rb,5.14331e-10_rb,5.63815e-10_rb, &
+      6.17448e-10_rb,6.75526e-10_rb,7.38358e-10_rb,8.06277e-10_rb,8.79625e-10_rb, &
+      9.58770e-10_rb,1.04410e-09_rb,1.13602e-09_rb,1.23495e-09_rb,1.34135e-09_rb, &
+      1.45568e-09_rb,1.57845e-09_rb,1.71017e-09_rb,1.85139e-09_rb,2.00268e-09_rb, &
+      2.16464e-09_rb,2.33789e-09_rb,2.52309e-09_rb,2.72093e-09_rb,2.93212e-09_rb, &
+      3.15740e-09_rb,3.39757e-09_rb,3.65341e-09_rb,3.92579e-09_rb,4.21559e-09_rb/)
+      totplnk(51:100,13) = (/ &
+      4.52372e-09_rb,4.85115e-09_rb,5.19886e-09_rb,5.56788e-09_rb,5.95928e-09_rb, &
+      6.37419e-09_rb,6.81375e-09_rb,7.27917e-09_rb,7.77168e-09_rb,8.29256e-09_rb, &
+      8.84317e-09_rb,9.42487e-09_rb,1.00391e-08_rb,1.06873e-08_rb,1.13710e-08_rb, &
+      1.20919e-08_rb,1.28515e-08_rb,1.36514e-08_rb,1.44935e-08_rb,1.53796e-08_rb, &
+      1.63114e-08_rb,1.72909e-08_rb,1.83201e-08_rb,1.94008e-08_rb,2.05354e-08_rb, &
+      2.17258e-08_rb,2.29742e-08_rb,2.42830e-08_rb,2.56545e-08_rb,2.70910e-08_rb, &
+      2.85950e-08_rb,3.01689e-08_rb,3.18155e-08_rb,3.35373e-08_rb,3.53372e-08_rb, &
+      3.72177e-08_rb,3.91818e-08_rb,4.12325e-08_rb,4.33727e-08_rb,4.56056e-08_rb, &
+      4.79342e-08_rb,5.03617e-08_rb,5.28915e-08_rb,5.55270e-08_rb,5.82715e-08_rb, &
+      6.11286e-08_rb,6.41019e-08_rb,6.71951e-08_rb,7.04119e-08_rb,7.37560e-08_rb/)
+      totplnk(101:150,13) = (/ &
+      7.72315e-08_rb,8.08424e-08_rb,8.45927e-08_rb,8.84866e-08_rb,9.25281e-08_rb, &
+      9.67218e-08_rb,1.01072e-07_rb,1.05583e-07_rb,1.10260e-07_rb,1.15107e-07_rb, &
+      1.20128e-07_rb,1.25330e-07_rb,1.30716e-07_rb,1.36291e-07_rb,1.42061e-07_rb, &
+      1.48031e-07_rb,1.54206e-07_rb,1.60592e-07_rb,1.67192e-07_rb,1.74015e-07_rb, &
+      1.81064e-07_rb,1.88345e-07_rb,1.95865e-07_rb,2.03628e-07_rb,2.11643e-07_rb, &
+      2.19912e-07_rb,2.28443e-07_rb,2.37244e-07_rb,2.46318e-07_rb,2.55673e-07_rb, &
+      2.65316e-07_rb,2.75252e-07_rb,2.85489e-07_rb,2.96033e-07_rb,3.06891e-07_rb, &
+      3.18070e-07_rb,3.29576e-07_rb,3.41417e-07_rb,3.53600e-07_rb,3.66133e-07_rb, &
+      3.79021e-07_rb,3.92274e-07_rb,4.05897e-07_rb,4.19899e-07_rb,4.34288e-07_rb, &
+      4.49071e-07_rb,4.64255e-07_rb,4.79850e-07_rb,4.95863e-07_rb,5.12300e-07_rb/)
+      totplnk(151:181,13) = (/ &
+      5.29172e-07_rb,5.46486e-07_rb,5.64250e-07_rb,5.82473e-07_rb,6.01164e-07_rb, &
+      6.20329e-07_rb,6.39979e-07_rb,6.60122e-07_rb,6.80767e-07_rb,7.01922e-07_rb, &
+      7.23596e-07_rb,7.45800e-07_rb,7.68539e-07_rb,7.91826e-07_rb,8.15669e-07_rb, &
+      8.40076e-07_rb,8.65058e-07_rb,8.90623e-07_rb,9.16783e-07_rb,9.43544e-07_rb, &
+      9.70917e-07_rb,9.98912e-07_rb,1.02754e-06_rb,1.05681e-06_rb,1.08673e-06_rb, &
+      1.11731e-06_rb,1.14856e-06_rb,1.18050e-06_rb,1.21312e-06_rb,1.24645e-06_rb, &
+      1.28049e-06_rb/)
+      totplnk(1:50,14) = (/ &
+      1.40113e-11_rb,1.59358e-11_rb,1.80960e-11_rb,2.05171e-11_rb,2.32266e-11_rb, &
+      2.62546e-11_rb,2.96335e-11_rb,3.33990e-11_rb,3.75896e-11_rb,4.22469e-11_rb, &
+      4.74164e-11_rb,5.31466e-11_rb,5.94905e-11_rb,6.65054e-11_rb,7.42522e-11_rb, &
+      8.27975e-11_rb,9.22122e-11_rb,1.02573e-10_rb,1.13961e-10_rb,1.26466e-10_rb, &
+      1.40181e-10_rb,1.55206e-10_rb,1.71651e-10_rb,1.89630e-10_rb,2.09265e-10_rb, &
+      2.30689e-10_rb,2.54040e-10_rb,2.79467e-10_rb,3.07128e-10_rb,3.37190e-10_rb, &
+      3.69833e-10_rb,4.05243e-10_rb,4.43623e-10_rb,4.85183e-10_rb,5.30149e-10_rb, &
+      5.78755e-10_rb,6.31255e-10_rb,6.87910e-10_rb,7.49002e-10_rb,8.14824e-10_rb, &
+      8.85687e-10_rb,9.61914e-10_rb,1.04385e-09_rb,1.13186e-09_rb,1.22631e-09_rb, &
+      1.32761e-09_rb,1.43617e-09_rb,1.55243e-09_rb,1.67686e-09_rb,1.80992e-09_rb/)
+      totplnk(51:100,14) = (/ &
+      1.95212e-09_rb,2.10399e-09_rb,2.26607e-09_rb,2.43895e-09_rb,2.62321e-09_rb, &
+      2.81949e-09_rb,3.02844e-09_rb,3.25073e-09_rb,3.48707e-09_rb,3.73820e-09_rb, &
+      4.00490e-09_rb,4.28794e-09_rb,4.58819e-09_rb,4.90647e-09_rb,5.24371e-09_rb, &
+      5.60081e-09_rb,5.97875e-09_rb,6.37854e-09_rb,6.80120e-09_rb,7.24782e-09_rb, &
+      7.71950e-09_rb,8.21740e-09_rb,8.74271e-09_rb,9.29666e-09_rb,9.88054e-09_rb, &
+      1.04956e-08_rb,1.11434e-08_rb,1.18251e-08_rb,1.25422e-08_rb,1.32964e-08_rb, &
+      1.40890e-08_rb,1.49217e-08_rb,1.57961e-08_rb,1.67140e-08_rb,1.76771e-08_rb, &
+      1.86870e-08_rb,1.97458e-08_rb,2.08553e-08_rb,2.20175e-08_rb,2.32342e-08_rb, &
+      2.45077e-08_rb,2.58401e-08_rb,2.72334e-08_rb,2.86900e-08_rb,3.02122e-08_rb, &
+      3.18021e-08_rb,3.34624e-08_rb,3.51954e-08_rb,3.70037e-08_rb,3.88899e-08_rb/)
+      totplnk(101:150,14) = (/ &
+      4.08568e-08_rb,4.29068e-08_rb,4.50429e-08_rb,4.72678e-08_rb,4.95847e-08_rb, &
+      5.19963e-08_rb,5.45058e-08_rb,5.71161e-08_rb,5.98309e-08_rb,6.26529e-08_rb, &
+      6.55857e-08_rb,6.86327e-08_rb,7.17971e-08_rb,7.50829e-08_rb,7.84933e-08_rb, &
+      8.20323e-08_rb,8.57035e-08_rb,8.95105e-08_rb,9.34579e-08_rb,9.75488e-08_rb, &
+      1.01788e-07_rb,1.06179e-07_rb,1.10727e-07_rb,1.15434e-07_rb,1.20307e-07_rb, &
+      1.25350e-07_rb,1.30566e-07_rb,1.35961e-07_rb,1.41539e-07_rb,1.47304e-07_rb, &
+      1.53263e-07_rb,1.59419e-07_rb,1.65778e-07_rb,1.72345e-07_rb,1.79124e-07_rb, &
+      1.86122e-07_rb,1.93343e-07_rb,2.00792e-07_rb,2.08476e-07_rb,2.16400e-07_rb, &
+      2.24568e-07_rb,2.32988e-07_rb,2.41666e-07_rb,2.50605e-07_rb,2.59813e-07_rb, &
+      2.69297e-07_rb,2.79060e-07_rb,2.89111e-07_rb,2.99455e-07_rb,3.10099e-07_rb/)
+      totplnk(151:181,14) = (/ &
+      3.21049e-07_rb,3.32311e-07_rb,3.43893e-07_rb,3.55801e-07_rb,3.68041e-07_rb, &
+      3.80621e-07_rb,3.93547e-07_rb,4.06826e-07_rb,4.20465e-07_rb,4.34473e-07_rb, &
+      4.48856e-07_rb,4.63620e-07_rb,4.78774e-07_rb,4.94325e-07_rb,5.10280e-07_rb, &
+      5.26648e-07_rb,5.43436e-07_rb,5.60652e-07_rb,5.78302e-07_rb,5.96397e-07_rb, &
+      6.14943e-07_rb,6.33949e-07_rb,6.53421e-07_rb,6.73370e-07_rb,6.93803e-07_rb, &
+      7.14731e-07_rb,7.36157e-07_rb,7.58095e-07_rb,7.80549e-07_rb,8.03533e-07_rb, &
+      8.27050e-07_rb/)
+      totplnk(1:50,15) = (/ &
+      3.90483e-12_rb,4.47999e-12_rb,5.13122e-12_rb,5.86739e-12_rb,6.69829e-12_rb, &
+      7.63467e-12_rb,8.68833e-12_rb,9.87221e-12_rb,1.12005e-11_rb,1.26885e-11_rb, &
+      1.43534e-11_rb,1.62134e-11_rb,1.82888e-11_rb,2.06012e-11_rb,2.31745e-11_rb, &
+      2.60343e-11_rb,2.92087e-11_rb,3.27277e-11_rb,3.66242e-11_rb,4.09334e-11_rb, &
+      4.56935e-11_rb,5.09455e-11_rb,5.67338e-11_rb,6.31057e-11_rb,7.01127e-11_rb, &
+      7.78096e-11_rb,8.62554e-11_rb,9.55130e-11_rb,1.05651e-10_rb,1.16740e-10_rb, &
+      1.28858e-10_rb,1.42089e-10_rb,1.56519e-10_rb,1.72243e-10_rb,1.89361e-10_rb, &
+      2.07978e-10_rb,2.28209e-10_rb,2.50173e-10_rb,2.73999e-10_rb,2.99820e-10_rb, &
+      3.27782e-10_rb,3.58034e-10_rb,3.90739e-10_rb,4.26067e-10_rb,4.64196e-10_rb, &
+      5.05317e-10_rb,5.49631e-10_rb,5.97347e-10_rb,6.48689e-10_rb,7.03891e-10_rb/)
+      totplnk(51:100,15) = (/ &
+      7.63201e-10_rb,8.26876e-10_rb,8.95192e-10_rb,9.68430e-10_rb,1.04690e-09_rb, &
+      1.13091e-09_rb,1.22079e-09_rb,1.31689e-09_rb,1.41957e-09_rb,1.52922e-09_rb, &
+      1.64623e-09_rb,1.77101e-09_rb,1.90401e-09_rb,2.04567e-09_rb,2.19647e-09_rb, &
+      2.35690e-09_rb,2.52749e-09_rb,2.70875e-09_rb,2.90127e-09_rb,3.10560e-09_rb, &
+      3.32238e-09_rb,3.55222e-09_rb,3.79578e-09_rb,4.05375e-09_rb,4.32682e-09_rb, &
+      4.61574e-09_rb,4.92128e-09_rb,5.24420e-09_rb,5.58536e-09_rb,5.94558e-09_rb, &
+      6.32575e-09_rb,6.72678e-09_rb,7.14964e-09_rb,7.59526e-09_rb,8.06470e-09_rb, &
+      8.55897e-09_rb,9.07916e-09_rb,9.62638e-09_rb,1.02018e-08_rb,1.08066e-08_rb, &
+      1.14420e-08_rb,1.21092e-08_rb,1.28097e-08_rb,1.35446e-08_rb,1.43155e-08_rb, &
+      1.51237e-08_rb,1.59708e-08_rb,1.68581e-08_rb,1.77873e-08_rb,1.87599e-08_rb/)
+      totplnk(101:150,15) = (/ &
+      1.97777e-08_rb,2.08423e-08_rb,2.19555e-08_rb,2.31190e-08_rb,2.43348e-08_rb, &
+      2.56045e-08_rb,2.69302e-08_rb,2.83140e-08_rb,2.97578e-08_rb,3.12636e-08_rb, &
+      3.28337e-08_rb,3.44702e-08_rb,3.61755e-08_rb,3.79516e-08_rb,3.98012e-08_rb, &
+      4.17265e-08_rb,4.37300e-08_rb,4.58143e-08_rb,4.79819e-08_rb,5.02355e-08_rb, &
+      5.25777e-08_rb,5.50114e-08_rb,5.75393e-08_rb,6.01644e-08_rb,6.28896e-08_rb, &
+      6.57177e-08_rb,6.86521e-08_rb,7.16959e-08_rb,7.48520e-08_rb,7.81239e-08_rb, &
+      8.15148e-08_rb,8.50282e-08_rb,8.86675e-08_rb,9.24362e-08_rb,9.63380e-08_rb, &
+      1.00376e-07_rb,1.04555e-07_rb,1.08878e-07_rb,1.13349e-07_rb,1.17972e-07_rb, &
+      1.22751e-07_rb,1.27690e-07_rb,1.32793e-07_rb,1.38064e-07_rb,1.43508e-07_rb, &
+      1.49129e-07_rb,1.54931e-07_rb,1.60920e-07_rb,1.67099e-07_rb,1.73473e-07_rb/)
+      totplnk(151:181,15) = (/ &
+      1.80046e-07_rb,1.86825e-07_rb,1.93812e-07_rb,2.01014e-07_rb,2.08436e-07_rb, &
+      2.16082e-07_rb,2.23957e-07_rb,2.32067e-07_rb,2.40418e-07_rb,2.49013e-07_rb, &
+      2.57860e-07_rb,2.66963e-07_rb,2.76328e-07_rb,2.85961e-07_rb,2.95868e-07_rb, &
+      3.06053e-07_rb,3.16524e-07_rb,3.27286e-07_rb,3.38345e-07_rb,3.49707e-07_rb, &
+      3.61379e-07_rb,3.73367e-07_rb,3.85676e-07_rb,3.98315e-07_rb,4.11287e-07_rb, &
+      4.24602e-07_rb,4.38265e-07_rb,4.52283e-07_rb,4.66662e-07_rb,4.81410e-07_rb, &
+      4.96535e-07_rb/)
+      totplnk(1:50,16) = (/ &
+      0.28639e-12_rb,0.33349e-12_rb,0.38764e-12_rb,0.44977e-12_rb,0.52093e-12_rb, &
+      0.60231e-12_rb,0.69522e-12_rb,0.80111e-12_rb,0.92163e-12_rb,0.10586e-11_rb, &
+      0.12139e-11_rb,0.13899e-11_rb,0.15890e-11_rb,0.18138e-11_rb,0.20674e-11_rb, &
+      0.23531e-11_rb,0.26744e-11_rb,0.30352e-11_rb,0.34401e-11_rb,0.38936e-11_rb, &
+      0.44011e-11_rb,0.49681e-11_rb,0.56010e-11_rb,0.63065e-11_rb,0.70919e-11_rb, &
+      0.79654e-11_rb,0.89357e-11_rb,0.10012e-10_rb,0.11205e-10_rb,0.12526e-10_rb, &
+      0.13986e-10_rb,0.15600e-10_rb,0.17380e-10_rb,0.19342e-10_rb,0.21503e-10_rb, &
+      0.23881e-10_rb,0.26494e-10_rb,0.29362e-10_rb,0.32509e-10_rb,0.35958e-10_rb, &
+      0.39733e-10_rb,0.43863e-10_rb,0.48376e-10_rb,0.53303e-10_rb,0.58679e-10_rb, &
+      0.64539e-10_rb,0.70920e-10_rb,0.77864e-10_rb,0.85413e-10_rb,0.93615e-10_rb/)
+      totplnk(51:100,16) = (/ &
+      0.10252e-09_rb,0.11217e-09_rb,0.12264e-09_rb,0.13397e-09_rb,0.14624e-09_rb, &
+      0.15950e-09_rb,0.17383e-09_rb,0.18930e-09_rb,0.20599e-09_rb,0.22399e-09_rb, &
+      0.24339e-09_rb,0.26427e-09_rb,0.28674e-09_rb,0.31090e-09_rb,0.33686e-09_rb, &
+      0.36474e-09_rb,0.39466e-09_rb,0.42676e-09_rb,0.46115e-09_rb,0.49800e-09_rb, &
+      0.53744e-09_rb,0.57964e-09_rb,0.62476e-09_rb,0.67298e-09_rb,0.72448e-09_rb, &
+      0.77945e-09_rb,0.83809e-09_rb,0.90062e-09_rb,0.96725e-09_rb,0.10382e-08_rb, &
+      0.11138e-08_rb,0.11941e-08_rb,0.12796e-08_rb,0.13704e-08_rb,0.14669e-08_rb, &
+      0.15694e-08_rb,0.16781e-08_rb,0.17934e-08_rb,0.19157e-08_rb,0.20453e-08_rb, &
+      0.21825e-08_rb,0.23278e-08_rb,0.24815e-08_rb,0.26442e-08_rb,0.28161e-08_rb, &
+      0.29978e-08_rb,0.31898e-08_rb,0.33925e-08_rb,0.36064e-08_rb,0.38321e-08_rb/)
+      totplnk(101:150,16) = (/ &
+      0.40700e-08_rb,0.43209e-08_rb,0.45852e-08_rb,0.48636e-08_rb,0.51567e-08_rb, &
+      0.54652e-08_rb,0.57897e-08_rb,0.61310e-08_rb,0.64897e-08_rb,0.68667e-08_rb, &
+      0.72626e-08_rb,0.76784e-08_rb,0.81148e-08_rb,0.85727e-08_rb,0.90530e-08_rb, &
+      0.95566e-08_rb,0.10084e-07_rb,0.10638e-07_rb,0.11217e-07_rb,0.11824e-07_rb, &
+      0.12458e-07_rb,0.13123e-07_rb,0.13818e-07_rb,0.14545e-07_rb,0.15305e-07_rb, &
+      0.16099e-07_rb,0.16928e-07_rb,0.17795e-07_rb,0.18699e-07_rb,0.19643e-07_rb, &
+      0.20629e-07_rb,0.21656e-07_rb,0.22728e-07_rb,0.23845e-07_rb,0.25010e-07_rb, &
+      0.26223e-07_rb,0.27487e-07_rb,0.28804e-07_rb,0.30174e-07_rb,0.31600e-07_rb, &
+      0.33084e-07_rb,0.34628e-07_rb,0.36233e-07_rb,0.37902e-07_rb,0.39637e-07_rb, &
+      0.41440e-07_rb,0.43313e-07_rb,0.45259e-07_rb,0.47279e-07_rb,0.49376e-07_rb/)
+      totplnk(151:181,16) = (/ &
+      0.51552e-07_rb,0.53810e-07_rb,0.56153e-07_rb,0.58583e-07_rb,0.61102e-07_rb, &
+      0.63713e-07_rb,0.66420e-07_rb,0.69224e-07_rb,0.72129e-07_rb,0.75138e-07_rb, &
+      0.78254e-07_rb,0.81479e-07_rb,0.84818e-07_rb,0.88272e-07_rb,0.91846e-07_rb, &
+      0.95543e-07_rb,0.99366e-07_rb,0.10332e-06_rb,0.10740e-06_rb,0.11163e-06_rb, &
+      0.11599e-06_rb,0.12050e-06_rb,0.12515e-06_rb,0.12996e-06_rb,0.13493e-06_rb, &
+      0.14005e-06_rb,0.14534e-06_rb,0.15080e-06_rb,0.15643e-06_rb,0.16224e-06_rb, &
+      0.16823e-06_rb/)
+      totplk16(1:50) = (/ &
+      0.28481e-12_rb,0.33159e-12_rb,0.38535e-12_rb,0.44701e-12_rb,0.51763e-12_rb, &
+      0.59836e-12_rb,0.69049e-12_rb,0.79549e-12_rb,0.91493e-12_rb,0.10506e-11_rb, &
+      0.12045e-11_rb,0.13788e-11_rb,0.15758e-11_rb,0.17984e-11_rb,0.20493e-11_rb, &
+      0.23317e-11_rb,0.26494e-11_rb,0.30060e-11_rb,0.34060e-11_rb,0.38539e-11_rb, &
+      0.43548e-11_rb,0.49144e-11_rb,0.55387e-11_rb,0.62344e-11_rb,0.70086e-11_rb, &
+      0.78692e-11_rb,0.88248e-11_rb,0.98846e-11_rb,0.11059e-10_rb,0.12358e-10_rb, &
+      0.13794e-10_rb,0.15379e-10_rb,0.17128e-10_rb,0.19055e-10_rb,0.21176e-10_rb, &
+      0.23508e-10_rb,0.26070e-10_rb,0.28881e-10_rb,0.31963e-10_rb,0.35339e-10_rb, &
+      0.39034e-10_rb,0.43073e-10_rb,0.47484e-10_rb,0.52299e-10_rb,0.57548e-10_rb, &
+      0.63267e-10_rb,0.69491e-10_rb,0.76261e-10_rb,0.83616e-10_rb,0.91603e-10_rb/)
+      totplk16(51:100) = (/ &
+      0.10027e-09_rb,0.10966e-09_rb,0.11983e-09_rb,0.13084e-09_rb,0.14275e-09_rb, &
+      0.15562e-09_rb,0.16951e-09_rb,0.18451e-09_rb,0.20068e-09_rb,0.21810e-09_rb, &
+      0.23686e-09_rb,0.25704e-09_rb,0.27875e-09_rb,0.30207e-09_rb,0.32712e-09_rb, &
+      0.35400e-09_rb,0.38282e-09_rb,0.41372e-09_rb,0.44681e-09_rb,0.48223e-09_rb, &
+      0.52013e-09_rb,0.56064e-09_rb,0.60392e-09_rb,0.65015e-09_rb,0.69948e-09_rb, &
+      0.75209e-09_rb,0.80818e-09_rb,0.86794e-09_rb,0.93157e-09_rb,0.99929e-09_rb, &
+      0.10713e-08_rb,0.11479e-08_rb,0.12293e-08_rb,0.13157e-08_rb,0.14074e-08_rb, &
+      0.15047e-08_rb,0.16079e-08_rb,0.17172e-08_rb,0.18330e-08_rb,0.19557e-08_rb, &
+      0.20855e-08_rb,0.22228e-08_rb,0.23680e-08_rb,0.25214e-08_rb,0.26835e-08_rb, &
+      0.28546e-08_rb,0.30352e-08_rb,0.32257e-08_rb,0.34266e-08_rb,0.36384e-08_rb/)
+      totplk16(101:150) = (/ &
+      0.38615e-08_rb,0.40965e-08_rb,0.43438e-08_rb,0.46041e-08_rb,0.48779e-08_rb, &
+      0.51658e-08_rb,0.54683e-08_rb,0.57862e-08_rb,0.61200e-08_rb,0.64705e-08_rb, &
+      0.68382e-08_rb,0.72240e-08_rb,0.76285e-08_rb,0.80526e-08_rb,0.84969e-08_rb, &
+      0.89624e-08_rb,0.94498e-08_rb,0.99599e-08_rb,0.10494e-07_rb,0.11052e-07_rb, &
+      0.11636e-07_rb,0.12246e-07_rb,0.12884e-07_rb,0.13551e-07_rb,0.14246e-07_rb, &
+      0.14973e-07_rb,0.15731e-07_rb,0.16522e-07_rb,0.17347e-07_rb,0.18207e-07_rb, &
+      0.19103e-07_rb,0.20037e-07_rb,0.21011e-07_rb,0.22024e-07_rb,0.23079e-07_rb, &
+      0.24177e-07_rb,0.25320e-07_rb,0.26508e-07_rb,0.27744e-07_rb,0.29029e-07_rb, &
+      0.30365e-07_rb,0.31753e-07_rb,0.33194e-07_rb,0.34691e-07_rb,0.36246e-07_rb, &
+      0.37859e-07_rb,0.39533e-07_rb,0.41270e-07_rb,0.43071e-07_rb,0.44939e-07_rb/)
+      totplk16(151:181) = (/ &
+      0.46875e-07_rb,0.48882e-07_rb,0.50961e-07_rb,0.53115e-07_rb,0.55345e-07_rb, &
+      0.57655e-07_rb,0.60046e-07_rb,0.62520e-07_rb,0.65080e-07_rb,0.67728e-07_rb, &
+      0.70466e-07_rb,0.73298e-07_rb,0.76225e-07_rb,0.79251e-07_rb,0.82377e-07_rb, &
+      0.85606e-07_rb,0.88942e-07_rb,0.92386e-07_rb,0.95942e-07_rb,0.99612e-07_rb, &
+      0.10340e-06_rb,0.10731e-06_rb,0.11134e-06_rb,0.11550e-06_rb,0.11979e-06_rb, &
+      0.12421e-06_rb,0.12876e-06_rb,0.13346e-06_rb,0.13830e-06_rb,0.14328e-06_rb, &
+      0.14841e-06_rb/)
+
+      end subroutine lwavplank
+
+      end module rrtmg_lw_setcoef
+
+!     path:      $Source: /storm/rc1/cvsroot/rc/rrtmg_lw/src/rrtmg_lw_taumol.f90,v $
+!     author:    $Author: mike $
+!     revision:  $Revision: 1.7 $
+!     created:   $Date: 2009/10/20 15:08:37 $
+!
+      module rrtmg_lw_taumol
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parkind, only : im => kind_im, rb => kind_rb 
+      use parrrtm, only : mg, nbndlw, maxxsec, ngptlw
+      use rrlw_con, only: oneminus
+      use rrlw_wvn, only: nspa, nspb
+      use rrlw_vsn, only: hvrtau, hnamtau
+
+      implicit none
+
+      contains
+
+!----------------------------------------------------------------------------
+      subroutine taumol(nlayers, pavel, wx, coldry, &
+                        laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
+                        colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
+                        colbrd, fac00, fac01, fac10, fac11, &
+                        rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
+                        rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
+                        rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
+                        selffac, selffrac, indself, forfac, forfrac, indfor, &
+                        minorfrac, scaleminor, scaleminorn2, indminor, &
+                        fracs, taug)
+!----------------------------------------------------------------------------
+
+! *******************************************************************************
+! *                                                                             *
+! *                  Optical depths developed for the                           *
+! *                                                                             *
+! *                RAPID RADIATIVE TRANSFER MODEL (RRTM)                        *
+! *                                                                             *
+! *                                                                             *
+! *            ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC.                     *
+! *                        131 HARTWELL AVENUE                                  *
+! *                        LEXINGTON, MA 02421                                  *
+! *                                                                             *
+! *                                                                             *
+! *                           ELI J. MLAWER                                     * 
+! *                         JENNIFER DELAMERE                                   * 
+! *                         STEVEN J. TAUBMAN                                   *
+! *                         SHEPARD A. CLOUGH                                   *
+! *                                                                             *
+! *                                                                             *
+! *                                                                             *
+! *                                                                             *
+! *                       email:  mlawer@aer.com                                *
+! *                       email:  jdelamer@aer.com                              *
+! *                                                                             *
+! *        The authors wish to acknowledge the contributions of the             *
+! *        following people:  Karen Cady-Pereira, Patrick D. Brown,             *  
+! *        Michael J. Iacono, Ronald E. Farren, Luke Chen, Robert Bergstrom.    *
+! *                                                                             *
+! *******************************************************************************
+! *                                                                             *
+! *  Revision for g-point reduction: Michael J. Iacono, AER, Inc.               *
+! *                                                                             *
+! *******************************************************************************
+! *     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,                                              *
+! *    &                  COLH2O(MXLAY),COLCO2(MXLAY),COLO3(MXLAY),             *
+! *    &                  COLN2O(MXLAY),COLCO(MXLAY),COLCH4(MXLAY),             *
+! *    &                  COLO2(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)                                *
+! *     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 for 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      *
+! *     FORFAC  - scale factor needed for water vapor foreign-continuum.        *
+! *     FORFRAC - factor needed for temperature interpolation of reference      *
+! *                water vapor foreign-continuum data                           *
+! *     INDFOR  - index of the lower of the two appropriate reference           *
+! *               temperatures needed for the foreign-continuum interpolation   *
+! *                                                                             *
+! *  Data input                                                                 *
+! *     COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG),*
+! *                 FORREF(4,MG), KA_M'MGAS', KB_M'MGAS'                        *
+! *        (note:  n is the band number,'MGAS' is the species name of the minor *
+! *         gas)                                                                *
+! *                                                                             *
+! *     Description:                                                            *
+! *     KA - k-values for low reference atmospheres (key-species only)          *
+! *          (units: cm**2/molecule)                                            *
+! *     KB - k-values for high reference atmospheres (key-species only)         *
+! *          (units: cm**2/molecule)                                            *
+! *     KA_M'MGAS' - k-values for low reference atmosphere minor species        *
+! *          (units: cm**2/molecule)                                            *
+! *     KB_M'MGAS' - k-values for high reference atmosphere minor species       *
+! *          (units: cm**2/molecule)                                            *
+! *     SELFREF - k-values for water vapor self-continuum for reference         *
+! *               atmospheres (used below LAYTROP)                              *
+! *               (units: cm**2/molecule)                                       *
+! *     FORREF  - k-values for water vapor foreign-continuum for reference      *
+! *               atmospheres (used below/above LAYTROP)                        *
+! *               (units: cm**2/molecule)                                       *
+! *                                                                             *
+! *     DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG)                     *
+! *     EQUIVALENCE (KA,ABSA),(KB,ABSB)                                         *
+! *                                                                             *
+!*******************************************************************************
+
+! ------- Declarations -------
+
+! ----- Input -----
+      integer(kind=im), intent(in) :: nlayers         ! total number of layers
+      real(kind=rb), intent(in) :: pavel(:)           ! layer pressures (mb) 
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: wx(:,:)            ! cross-section amounts (mol/cm2)
+                                                      !    Dimensions: (maxxsec,nlayers)
+      real(kind=rb), intent(in) :: coldry(:)          ! column amount (dry air)
+                                                      !    Dimensions: (nlayers)
+
+      integer(kind=im), intent(in) :: laytrop         ! tropopause layer index
+      integer(kind=im), intent(in) :: jp(:)           ! 
+                                                      !    Dimensions: (nlayers)
+      integer(kind=im), intent(in) :: jt(:)           !
+                                                      !    Dimensions: (nlayers)
+      integer(kind=im), intent(in) :: jt1(:)          !
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: planklay(:,:)      ! 
+                                                      !    Dimensions: (nlayers,nbndlw)
+      real(kind=rb), intent(in) :: planklev(0:,:)     ! 
+                                                      !    Dimensions: (nlayers,nbndlw)
+      real(kind=rb), intent(in) :: plankbnd(:)        ! 
+                                                      !    Dimensions: (nbndlw)
+
+      real(kind=rb), intent(in) :: colh2o(:)          ! column amount (h2o)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colco2(:)          ! column amount (co2)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colo3(:)           ! column amount (o3)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: coln2o(:)          ! column amount (n2o)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colco(:)           ! column amount (co)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colch4(:)          ! column amount (ch4)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colo2(:)           ! column amount (o2)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colbrd(:)          ! column amount (broadening gases)
+                                                      !    Dimensions: (nlayers)
+
+      integer(kind=im), intent(in) :: indself(:)
+                                                      !    Dimensions: (nlayers)
+      integer(kind=im), intent(in) :: indfor(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: selffac(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: selffrac(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: forfac(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: forfrac(:)
+                                                      !    Dimensions: (nlayers)
+
+      integer(kind=im), intent(in) :: indminor(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: minorfrac(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: scaleminor(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: scaleminorn2(:)
+                                                      !    Dimensions: (nlayers)
+
+      real(kind=rb), intent(in) :: &                  !
+                       fac00(:), fac01(:), &          !    Dimensions: (nlayers)
+                       fac10(:), fac11(:) 
+      real(kind=rb), intent(in) :: &                  !
+                       rat_h2oco2(:),rat_h2oco2_1(:), &
+                       rat_h2oo3(:),rat_h2oo3_1(:), & !    Dimensions: (nlayers)
+                       rat_h2on2o(:),rat_h2on2o_1(:), &
+                       rat_h2och4(:),rat_h2och4_1(:), &
+                       rat_n2oco2(:),rat_n2oco2_1(:), &
+                       rat_o3co2(:),rat_o3co2_1(:)
+
+! ----- Output -----
+      real(kind=rb), intent(out) :: fracs(:,:)        ! planck fractions
+                                                      !    Dimensions: (nlayers,ngptlw)
+      real(kind=rb), intent(out) :: taug(:,:)         ! gaseous optical depth 
+                                                      !    Dimensions: (nlayers,ngptlw)
+
+      hvrtau = '$Revision: 1.7 $'
+
+! Calculate gaseous optical depth and planck fractions for each spectral band.
+
+      call taugb1
+      call taugb2
+      call taugb3
+      call taugb4
+      call taugb5
+      call taugb6
+      call taugb7
+      call taugb8
+      call taugb9
+      call taugb10
+      call taugb11
+      call taugb12
+      call taugb13
+      call taugb14
+      call taugb15
+      call taugb16
+
+      contains
+
+!----------------------------------------------------------------------------
+      subroutine taugb1
+!----------------------------------------------------------------------------
+
+! ------- Modifications -------
+!  Written by Eli J. Mlawer, Atmospheric & Environmental Research.
+!  Revised by Michael J. Iacono, Atmospheric & Environmental Research.
+!
+!     band 1:  10-350 cm-1 (low key - h2o; low minor - n2)
+!                          (high key - h2o; high minor - n2)
+!
+!     note: previous versions of rrtm band 1: 
+!           10-250 cm-1 (low - h2o; high - h2o)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng1
+      use rrlw_kg01, only : fracrefa, fracrefb, absa, ka, absb, kb, &
+                            ka_mn2, kb_mn2, selfref, forref
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
+      real(kind=rb) :: pp, corradj, scalen2, tauself, taufor, taun2
+
+
+! Minor gas mapping levels:
+!     lower - n2, p = 142.5490 mbar, t = 215.70 k
+!     upper - n2, p = 142.5490 mbar, t = 215.70 k
+
+! Compute the optical depth by interpolating in ln(pressure) and 
+! temperature.  Below laytrop, the water vapor self-continuum and
+! foreign continuum is interpolated (in temperature) separately.
+
+! Lower atmosphere loop
+      do 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)
+         indf = indfor(lay)
+         indm = indminor(lay)
+         pp = pavel(lay)
+         corradj =  1.
+         if (pp .lt. 250._rb) then
+            corradj = 1._rb - 0.15_rb * (250._rb-pp) / 154.4_rb
+         endif
+
+         scalen2 = colbrd(lay) * scaleminorn2(lay)
+         do ig = 1, ng1
+            tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor =  forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) -  forref(indf,ig))) 
+            taun2 = scalen2*(ka_mn2(indm,ig) + & 
+                 minorfrac(lay) * (ka_mn2(indm+1,ig) - ka_mn2(indm,ig)))
+            taug(lay,ig) = corradj * (colh2o(lay) * &
+                (fac00(lay) * absa(ind0,ig) + &
+                 fac10(lay) * absa(ind0+1,ig) + &
+                 fac01(lay) * absa(ind1,ig) + &
+                 fac11(lay) * absa(ind1+1,ig)) & 
+                 + tauself + taufor + taun2)
+             fracs(lay,ig) = fracrefa(ig)
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do 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
+         indf = indfor(lay)
+         indm = indminor(lay)
+         pp = pavel(lay)
+         corradj =  1._rb - 0.15_rb * (pp / 95.6_rb)
+
+         scalen2 = colbrd(lay) * scaleminorn2(lay)
+         do ig = 1, ng1
+            taufor = forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig))) 
+            taun2 = scalen2*(kb_mn2(indm,ig) + & 
+                 minorfrac(lay) * (kb_mn2(indm+1,ig) - kb_mn2(indm,ig)))
+            taug(lay,ig) = corradj * (colh2o(lay) * &
+                (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + &
+                 fac11(lay) * absb(ind1+1,ig)) &  
+                 + taufor + taun2)
+            fracs(lay,ig) = fracrefb(ig)
+         enddo
+      enddo
+
+      end subroutine taugb1
+
+!----------------------------------------------------------------------------
+      subroutine taugb2
+!----------------------------------------------------------------------------
+!
+!     band 2:  350-500 cm-1 (low key - h2o; high key - h2o)
+!
+!     note: previous version of rrtm band 2: 
+!           250 - 500 cm-1 (low - h2o; high - h2o)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng2, ngs1
+      use rrlw_kg02, only : fracrefa, fracrefb, absa, ka, absb, kb, &
+                            selfref, forref
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
+      real(kind=rb) :: pp, corradj, tauself, taufor
+
+
+! Compute the optical depth by interpolating in ln(pressure) and 
+! temperature.  Below laytrop, the water vapor self-continuum and
+! foreign continuum is interpolated (in temperature) separately.
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(2) + 1
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(2) + 1
+         inds = indself(lay)
+         indf = indfor(lay)
+         pp = pavel(lay)
+         corradj = 1._rb - .05_rb * (pp - 100._rb) / 900._rb
+         do ig = 1, ng2
+            tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor =  forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+            taug(lay,ngs1+ig) = corradj * (colh2o(lay) * &
+                (fac00(lay) * absa(ind0,ig) + &
+                 fac10(lay) * absa(ind0+1,ig) + &
+                 fac01(lay) * absa(ind1,ig) + &
+                 fac11(lay) * absa(ind1+1,ig)) &
+                 + tauself + taufor)
+            fracs(lay,ngs1+ig) = fracrefa(ig)
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(2) + 1
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(2) + 1
+         indf = indfor(lay)
+         do ig = 1, ng2
+            taufor =  forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig))) 
+            taug(lay,ngs1+ig) = colh2o(lay) * &
+                (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + &
+                 fac11(lay) * absb(ind1+1,ig)) &
+                 + taufor
+            fracs(lay,ngs1+ig) = fracrefb(ig)
+         enddo
+      enddo
+
+      end subroutine taugb2
+
+!----------------------------------------------------------------------------
+      subroutine taugb3
+!----------------------------------------------------------------------------
+!
+!     band 3:  500-630 cm-1 (low key - h2o,co2; low minor - n2o)
+!                           (high key - h2o,co2; high minor - n2o)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng3, ngs2
+      use rrlw_ref, only : chi_mls
+      use rrlw_kg03, only : fracrefa, fracrefb, absa, ka, absb, kb, &
+                            ka_mn2o, kb_mn2o, selfref, forref
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
+      integer(kind=im) :: js, js1, jmn2o, jpl
+      real(kind=rb) :: speccomb, specparm, specmult, fs
+      real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
+      real(kind=rb) :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, &
+                       fmn2o, fmn2omf, chi_n2o, ratn2o, adjfac, adjcoln2o
+      real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
+      real(kind=rb) :: p, p4, fk0, fk1, fk2
+      real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
+      real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
+      real(kind=rb) :: tauself, taufor, n2om1, n2om2, absn2o
+      real(kind=rb) :: refrat_planck_a, refrat_planck_b, refrat_m_a, refrat_m_b
+      real(kind=rb) :: tau_major, tau_major1
+
+
+! Minor gas mapping levels:
+!     lower - n2o, p = 706.272 mbar, t = 278.94 k
+!     upper - n2o, p = 95.58 mbar, t = 215.7 k
+
+!  P = 212.725 mb
+      refrat_planck_a = chi_mls(1,9)/chi_mls(2,9)
+
+!  P = 95.58 mb
+      refrat_planck_b = chi_mls(1,13)/chi_mls(2,13)
+
+!  P = 706.270mb
+      refrat_m_a = chi_mls(1,3)/chi_mls(2,3)
+
+!  P = 95.58 mb 
+      refrat_m_b = chi_mls(1,13)/chi_mls(2,13)
+
+! Compute the optical depth by interpolating in ln(pressure) and 
+! temperature, and appropriate species.  Below laytrop, the water vapor 
+! self-continuum and foreign continuum is interpolated (in temperature) 
+! separately.
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+
+         speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
+         specparm = colh2o(lay)/speccomb
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult,1.0_rb)        
+
+         speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
+         specparm1 = colh2o(lay)/speccomb1
+         if (specparm1 .ge. oneminus) specparm1 = oneminus
+         specmult1 = 8._rb*(specparm1)
+         js1 = 1 + int(specmult1)
+         fs1 = mod(specmult1,1.0_rb)
+
+         speccomb_mn2o = colh2o(lay) + refrat_m_a*colco2(lay)
+         specparm_mn2o = colh2o(lay)/speccomb_mn2o
+         if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus
+         specmult_mn2o = 8._rb*specparm_mn2o
+         jmn2o = 1 + int(specmult_mn2o)
+         fmn2o = mod(specmult_mn2o,1.0_rb)
+         fmn2omf = minorfrac(lay)*fmn2o
+!  In atmospheres where the amount of N2O is too great to be considered
+!  a minor species, adjust the column amount of N2O by an empirical factor 
+!  to obtain the proper contribution.
+         chi_n2o = coln2o(lay)/coldry(lay)
+         ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
+         if (ratn2o .gt. 1.5_rb) then
+            adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
+            adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
+         else
+            adjcoln2o = coln2o(lay)
+         endif
+
+         speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
+         specparm_planck = colh2o(lay)/speccomb_planck
+         if (specparm_planck .ge. oneminus) specparm_planck=oneminus
+         specmult_planck = 8._rb*specparm_planck
+         jpl= 1 + int(specmult_planck)
+         fpl = mod(specmult_planck,1.0_rb)
+
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(3) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(3) + js1
+         inds = indself(lay)
+         indf = indfor(lay)
+         indm = indminor(lay)
+
+         if (specparm .lt. 0.125_rb) then
+            p = fs - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else if (specparm .gt. 0.875_rb) then
+            p = -fs 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else
+            fac000 = (1._rb - fs) * fac00(lay)
+            fac010 = (1._rb - fs) * fac10(lay)
+            fac100 = fs * fac00(lay)
+            fac110 = fs * fac10(lay)
+         endif
+         if (specparm1 .lt. 0.125_rb) then
+            p = fs1 - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else if (specparm1 .gt. 0.875_rb) then
+            p = -fs1 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else
+            fac001 = (1._rb - fs1) * fac01(lay)
+            fac011 = (1._rb - fs1) * fac11(lay)
+            fac101 = fs1 * fac01(lay)
+            fac111 = fs1 * fac11(lay)
+         endif
+
+         do ig = 1, ng3
+            tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+            n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * &
+                 (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig))
+            n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * &
+                 (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig))
+            absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
+
+            if (specparm .lt. 0.125_rb) then
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac200 * absa(ind0+2,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig) + &
+                    fac210 * absa(ind0+11,ig))
+            else if (specparm .gt. 0.875_rb) then
+               tau_major = speccomb * &
+                    (fac200 * absa(ind0-1,ig) + &
+                    fac100 * absa(ind0,ig) + &
+                    fac000 * absa(ind0+1,ig) + &
+                    fac210 * absa(ind0+8,ig) + &
+                    fac110 * absa(ind0+9,ig) + &
+                    fac010 * absa(ind0+10,ig))
+            else
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig))
+            endif
+
+            if (specparm1 .lt. 0.125_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac201 * absa(ind1+2,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig) + &
+                    fac211 * absa(ind1+11,ig))
+            else if (specparm1 .gt. 0.875_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac201 * absa(ind1-1,ig) + &
+                    fac101 * absa(ind1,ig) + &
+                    fac001 * absa(ind1+1,ig) + &
+                    fac211 * absa(ind1+8,ig) + &
+                    fac111 * absa(ind1+9,ig) + &
+                    fac011 * absa(ind1+10,ig))
+            else
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) +  &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig))
+            endif
+
+            taug(lay,ngs2+ig) = tau_major + tau_major1 &
+                 + tauself + taufor &
+                 + adjcoln2o*absn2o
+            fracs(lay,ngs2+ig) = fracrefa(ig,jpl) + fpl * &
+                 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+
+         speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
+         specparm = colh2o(lay)/speccomb
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 4._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult,1.0_rb)
+
+         speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
+         specparm1 = colh2o(lay)/speccomb1
+         if (specparm1 .ge. oneminus) specparm1 = oneminus
+         specmult1 = 4._rb*(specparm1)
+         js1 = 1 + int(specmult1)
+         fs1 = mod(specmult1,1.0_rb)
+
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs1) * fac01(lay)
+         fac011 = (1._rb - fs1) * fac11(lay)
+         fac101 = fs1 * fac01(lay)
+         fac111 = fs1 * fac11(lay)
+
+         speccomb_mn2o = colh2o(lay) + refrat_m_b*colco2(lay)
+         specparm_mn2o = colh2o(lay)/speccomb_mn2o
+         if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus
+         specmult_mn2o = 4._rb*specparm_mn2o
+         jmn2o = 1 + int(specmult_mn2o)
+         fmn2o = mod(specmult_mn2o,1.0_rb)
+         fmn2omf = minorfrac(lay)*fmn2o
+!  In atmospheres where the amount of N2O is too great to be considered
+!  a minor species, adjust the column amount of N2O by an empirical factor 
+!  to obtain the proper contribution.
+         chi_n2o = coln2o(lay)/coldry(lay)
+         ratn2o = 1.e20*chi_n2o/chi_mls(4,jp(lay)+1)
+         if (ratn2o .gt. 1.5_rb) then
+            adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
+            adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
+         else
+            adjcoln2o = coln2o(lay)
+         endif
+
+         speccomb_planck = colh2o(lay)+refrat_planck_b*colco2(lay)
+         specparm_planck = colh2o(lay)/speccomb_planck
+         if (specparm_planck .ge. oneminus) specparm_planck=oneminus
+         specmult_planck = 4._rb*specparm_planck
+         jpl= 1 + int(specmult_planck)
+         fpl = mod(specmult_planck,1.0_rb)
+
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(3) + js
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(3) + js1
+         indf = indfor(lay)
+         indm = indminor(lay)
+
+         do ig = 1, ng3
+            taufor = forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * (forref(indf+1,ig) - forref(indf,ig))) 
+            n2om1 = kb_mn2o(jmn2o,indm,ig) + fmn2o * &
+                 (kb_mn2o(jmn2o+1,indm,ig)-kb_mn2o(jmn2o,indm,ig))
+            n2om2 = kb_mn2o(jmn2o,indm+1,ig) + fmn2o * &
+                 (kb_mn2o(jmn2o+1,indm+1,ig)-kb_mn2o(jmn2o,indm+1,ig))
+            absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
+            taug(lay,ngs2+ig) = speccomb * &
+                (fac000 * absb(ind0,ig) + &
+                fac100 * absb(ind0+1,ig) + &
+                fac010 * absb(ind0+5,ig) + &
+                fac110 * absb(ind0+6,ig)) &
+                + speccomb1 * &
+                (fac001 * absb(ind1,ig) +  &
+                fac101 * absb(ind1+1,ig) + &
+                fac011 * absb(ind1+5,ig) + &
+                fac111 * absb(ind1+6,ig))  &
+                + taufor &
+                + adjcoln2o*absn2o
+            fracs(lay,ngs2+ig) = fracrefb(ig,jpl) + fpl * &
+                (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
+         enddo
+      enddo
+
+      end subroutine taugb3
+
+!----------------------------------------------------------------------------
+      subroutine taugb4
+!----------------------------------------------------------------------------
+!
+!     band 4:  630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng4, ngs3
+      use rrlw_ref, only : chi_mls
+      use rrlw_kg04, only : fracrefa, fracrefb, absa, ka, absb, kb, &
+                            selfref, forref
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
+      integer(kind=im) :: js, js1, jpl
+      real(kind=rb) :: speccomb, specparm, specmult, fs
+      real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
+      real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
+      real(kind=rb) :: p, p4, fk0, fk1, fk2
+      real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
+      real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
+      real(kind=rb) :: tauself, taufor
+      real(kind=rb) :: refrat_planck_a, refrat_planck_b
+      real(kind=rb) :: tau_major, tau_major1
+
+
+! P =   142.5940 mb
+      refrat_planck_a = chi_mls(1,11)/chi_mls(2,11)
+
+! P = 95.58350 mb
+      refrat_planck_b = chi_mls(3,13)/chi_mls(2,13)
+
+! Compute the optical depth by interpolating in ln(pressure) and 
+! temperature, and appropriate species.  Below laytrop, the water 
+! vapor self-continuum and foreign continuum is interpolated (in temperature) 
+! separately.
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+
+         speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
+         specparm = colh2o(lay)/speccomb
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult,1.0_rb)
+
+         speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
+         specparm1 = colh2o(lay)/speccomb1
+         if (specparm1 .ge. oneminus) specparm1 = oneminus
+         specmult1 = 8._rb*(specparm1)
+         js1 = 1 + int(specmult1)
+         fs1 = mod(specmult1,1.0_rb)
+
+         speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
+         specparm_planck = colh2o(lay)/speccomb_planck
+         if (specparm_planck .ge. oneminus) specparm_planck=oneminus
+         specmult_planck = 8._rb*specparm_planck
+         jpl= 1 + int(specmult_planck)
+         fpl = mod(specmult_planck,1.0_rb)
+
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(4) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(4) + js1
+         inds = indself(lay)
+         indf = indfor(lay)
+
+         if (specparm .lt. 0.125_rb) then
+            p = fs - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else if (specparm .gt. 0.875_rb) then
+            p = -fs 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else
+            fac000 = (1._rb - fs) * fac00(lay)
+            fac010 = (1._rb - fs) * fac10(lay)
+            fac100 = fs * fac00(lay)
+            fac110 = fs * fac10(lay)
+         endif
+
+         if (specparm1 .lt. 0.125_rb) then
+            p = fs1 - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else if (specparm1 .gt. 0.875_rb) then
+            p = -fs1 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else
+            fac001 = (1._rb - fs1) * fac01(lay)
+            fac011 = (1._rb - fs1) * fac11(lay)
+            fac101 = fs1 * fac01(lay)
+            fac111 = fs1 * fac11(lay)
+         endif
+
+         do ig = 1, ng4
+            tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor =  forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+
+            if (specparm .lt. 0.125_rb) then
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac200 * absa(ind0+2,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig) + &
+                    fac210 * absa(ind0+11,ig))
+            else if (specparm .gt. 0.875_rb) then
+               tau_major = speccomb * &
+                    (fac200 * absa(ind0-1,ig) + &
+                    fac100 * absa(ind0,ig) + &
+                    fac000 * absa(ind0+1,ig) + &
+                    fac210 * absa(ind0+8,ig) + &
+                    fac110 * absa(ind0+9,ig) + &
+                    fac010 * absa(ind0+10,ig))
+            else
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig))
+            endif
+
+            if (specparm1 .lt. 0.125_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) +  &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac201 * absa(ind1+2,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig) + &
+                    fac211 * absa(ind1+11,ig))
+            else if (specparm1 .gt. 0.875_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac201 * absa(ind1-1,ig) + &
+                    fac101 * absa(ind1,ig) + &
+                    fac001 * absa(ind1+1,ig) + &
+                    fac211 * absa(ind1+8,ig) + &
+                    fac111 * absa(ind1+9,ig) + &
+                    fac011 * absa(ind1+10,ig))
+            else
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig))
+            endif
+
+            taug(lay,ngs3+ig) = tau_major + tau_major1 &
+                 + tauself + taufor
+            fracs(lay,ngs3+ig) = fracrefa(ig,jpl) + fpl * &
+                 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+
+         speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay)
+         specparm = colo3(lay)/speccomb
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 4._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult,1.0_rb)
+
+         speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay)
+         specparm1 = colo3(lay)/speccomb1
+         if (specparm1 .ge. oneminus) specparm1 = oneminus
+         specmult1 = 4._rb*(specparm1)
+         js1 = 1 + int(specmult1)
+         fs1 = mod(specmult1,1.0_rb)
+
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs1) * fac01(lay)
+         fac011 = (1._rb - fs1) * fac11(lay)
+         fac101 = fs1 * fac01(lay)
+         fac111 = fs1 * fac11(lay)
+
+         speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay)
+         specparm_planck = colo3(lay)/speccomb_planck
+         if (specparm_planck .ge. oneminus) specparm_planck=oneminus
+         specmult_planck = 4._rb*specparm_planck
+         jpl= 1 + int(specmult_planck)
+         fpl = mod(specmult_planck,1.0_rb)
+
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(4) + js
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(4) + js1
+
+         do ig = 1, ng4
+            taug(lay,ngs3+ig) =  speccomb * &
+                (fac000 * absb(ind0,ig) + &
+                fac100 * absb(ind0+1,ig) + &
+                fac010 * absb(ind0+5,ig) + &
+                fac110 * absb(ind0+6,ig)) &
+                + speccomb1 * &
+                (fac001 * absb(ind1,ig) +  &
+                fac101 * absb(ind1+1,ig) + &
+                fac011 * absb(ind1+5,ig) + &
+                fac111 * absb(ind1+6,ig))
+            fracs(lay,ngs3+ig) = fracrefb(ig,jpl) + fpl * &
+                (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
+         enddo
+
+! Empirical modification to code to improve stratospheric cooling rates
+! for co2.  Revised to apply weighting for g-point reduction in this band.
+
+         taug(lay,ngs3+8)=taug(lay,ngs3+8)*0.92
+         taug(lay,ngs3+9)=taug(lay,ngs3+9)*0.88
+         taug(lay,ngs3+10)=taug(lay,ngs3+10)*1.07
+         taug(lay,ngs3+11)=taug(lay,ngs3+11)*1.1
+         taug(lay,ngs3+12)=taug(lay,ngs3+12)*0.99
+         taug(lay,ngs3+13)=taug(lay,ngs3+13)*0.88
+         taug(lay,ngs3+14)=taug(lay,ngs3+14)*0.943
+
+      enddo
+
+      end subroutine taugb4
+
+!----------------------------------------------------------------------------
+      subroutine taugb5
+!----------------------------------------------------------------------------
+!
+!     band 5:  700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4)
+!                           (high key - o3,co2)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng5, ngs4
+      use rrlw_ref, only : chi_mls
+      use rrlw_kg05, only : fracrefa, fracrefb, absa, ka, absb, kb, &
+                            ka_mo3, selfref, forref, ccl4
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
+      integer(kind=im) :: js, js1, jmo3, jpl
+      real(kind=rb) :: speccomb, specparm, specmult, fs
+      real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
+      real(kind=rb) :: speccomb_mo3, specparm_mo3, specmult_mo3, fmo3
+      real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
+      real(kind=rb) :: p, p4, fk0, fk1, fk2
+      real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
+      real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
+      real(kind=rb) :: tauself, taufor, o3m1, o3m2, abso3
+      real(kind=rb) :: refrat_planck_a, refrat_planck_b, refrat_m_a
+      real(kind=rb) :: tau_major, tau_major1
+
+
+! Minor gas mapping level :
+!     lower - o3, p = 317.34 mbar, t = 240.77 k
+!     lower - ccl4
+
+! Calculate reference ratio to be used in calculation of Planck
+! fraction in lower/upper atmosphere.
+
+! P = 473.420 mb
+      refrat_planck_a = chi_mls(1,5)/chi_mls(2,5)
+
+! P = 0.2369 mb
+      refrat_planck_b = chi_mls(3,43)/chi_mls(2,43)
+
+! P = 317.3480
+      refrat_m_a = chi_mls(1,7)/chi_mls(2,7)
+
+! Compute the optical depth by interpolating in ln(pressure) and 
+! temperature, and appropriate species.  Below laytrop, the 
+! water vapor self-continuum and foreign continuum is 
+! interpolated (in temperature) separately.
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+
+         speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
+         specparm = colh2o(lay)/speccomb
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult,1.0_rb)
+
+         speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
+         specparm1 = colh2o(lay)/speccomb1
+         if (specparm1 .ge. oneminus) specparm1 = oneminus
+         specmult1 = 8._rb*(specparm1)
+         js1 = 1 + int(specmult1)
+         fs1 = mod(specmult1,1.0_rb)
+
+         speccomb_mo3 = colh2o(lay) + refrat_m_a*colco2(lay)
+         specparm_mo3 = colh2o(lay)/speccomb_mo3
+         if (specparm_mo3 .ge. oneminus) specparm_mo3 = oneminus
+         specmult_mo3 = 8._rb*specparm_mo3
+         jmo3 = 1 + int(specmult_mo3)
+         fmo3 = mod(specmult_mo3,1.0_rb)
+
+         speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
+         specparm_planck = colh2o(lay)/speccomb_planck
+         if (specparm_planck .ge. oneminus) specparm_planck=oneminus
+         specmult_planck = 8._rb*specparm_planck
+         jpl= 1 + int(specmult_planck)
+         fpl = mod(specmult_planck,1.0_rb)
+
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(5) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(5) + js1
+         inds = indself(lay)
+         indf = indfor(lay)
+         indm = indminor(lay)
+
+         if (specparm .lt. 0.125_rb) then
+            p = fs - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else if (specparm .gt. 0.875_rb) then
+            p = -fs 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else
+            fac000 = (1._rb - fs) * fac00(lay)
+            fac010 = (1._rb - fs) * fac10(lay)
+            fac100 = fs * fac00(lay)
+            fac110 = fs * fac10(lay)
+         endif
+
+         if (specparm1 .lt. 0.125_rb) then
+            p = fs1 - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else if (specparm1 .gt. 0.875_rb) then
+            p = -fs1 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else
+            fac001 = (1._rb - fs1) * fac01(lay)
+            fac011 = (1._rb - fs1) * fac11(lay)
+            fac101 = fs1 * fac01(lay)
+            fac111 = fs1 * fac11(lay)
+         endif
+
+         do ig = 1, ng5
+            tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor =  forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+            o3m1 = ka_mo3(jmo3,indm,ig) + fmo3 * &
+                 (ka_mo3(jmo3+1,indm,ig)-ka_mo3(jmo3,indm,ig))
+            o3m2 = ka_mo3(jmo3,indm+1,ig) + fmo3 * &
+                 (ka_mo3(jmo3+1,indm+1,ig)-ka_mo3(jmo3,indm+1,ig))
+            abso3 = o3m1 + minorfrac(lay)*(o3m2-o3m1)
+
+            if (specparm .lt. 0.125_rb) then
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac200 * absa(ind0+2,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig) + &
+                    fac210 * absa(ind0+11,ig))
+            else if (specparm .gt. 0.875_rb) then
+               tau_major = speccomb * &
+                    (fac200 * absa(ind0-1,ig) + &
+                    fac100 * absa(ind0,ig) + &
+                    fac000 * absa(ind0+1,ig) + &
+                    fac210 * absa(ind0+8,ig) + &
+                    fac110 * absa(ind0+9,ig) + &
+                    fac010 * absa(ind0+10,ig))
+            else
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig))
+            endif
+
+            if (specparm1 .lt. 0.125_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac201 * absa(ind1+2,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig) + &
+                    fac211 * absa(ind1+11,ig))
+            else if (specparm1 .gt. 0.875_rb) then
+               tau_major1 = speccomb1 * & 
+                    (fac201 * absa(ind1-1,ig) + &
+                    fac101 * absa(ind1,ig) + &
+                    fac001 * absa(ind1+1,ig) + &
+                    fac211 * absa(ind1+8,ig) + &
+                    fac111 * absa(ind1+9,ig) + &
+                    fac011 * absa(ind1+10,ig))
+            else
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig))
+            endif
+
+            taug(lay,ngs4+ig) = tau_major + tau_major1 &
+                 + tauself + taufor &
+                 + abso3*colo3(lay) &
+                 + wx(1,lay) * ccl4(ig)
+            fracs(lay,ngs4+ig) = fracrefa(ig,jpl) + fpl * &
+                 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+
+         speccomb = colo3(lay) + rat_o3co2(lay)*colco2(lay)
+         specparm = colo3(lay)/speccomb
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 4._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult,1.0_rb)
+
+         speccomb1 = colo3(lay) + rat_o3co2_1(lay)*colco2(lay)
+         specparm1 = colo3(lay)/speccomb1
+         if (specparm1 .ge. oneminus) specparm1 = oneminus
+         specmult1 = 4._rb*(specparm1)
+         js1 = 1 + int(specmult1)
+         fs1 = mod(specmult1,1.0_rb)
+
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs1) * fac01(lay)
+         fac011 = (1._rb - fs1) * fac11(lay)
+         fac101 = fs1 * fac01(lay)
+         fac111 = fs1 * fac11(lay)
+
+         speccomb_planck = colo3(lay)+refrat_planck_b*colco2(lay)
+         specparm_planck = colo3(lay)/speccomb_planck
+         if (specparm_planck .ge. oneminus) specparm_planck=oneminus
+         specmult_planck = 4._rb*specparm_planck
+         jpl= 1 + int(specmult_planck)
+         fpl = mod(specmult_planck,1.0_rb)
+
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(5) + js
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(5) + js1
+         
+         do ig = 1, ng5
+            taug(lay,ngs4+ig) = speccomb * &
+                (fac000 * absb(ind0,ig) + &
+                fac100 * absb(ind0+1,ig) + &
+                fac010 * absb(ind0+5,ig) + &
+                fac110 * absb(ind0+6,ig)) &
+                + speccomb1 * &
+                (fac001 * absb(ind1,ig) + &
+                fac101 * absb(ind1+1,ig) + &
+                fac011 * absb(ind1+5,ig) + &
+                fac111 * absb(ind1+6,ig))  &
+                + wx(1,lay) * ccl4(ig)
+            fracs(lay,ngs4+ig) = fracrefb(ig,jpl) + fpl * &
+                (fracrefb(ig,jpl+1)-fracrefb(ig,jpl))
+         enddo
+      enddo
+
+      end subroutine taugb5
+
+!----------------------------------------------------------------------------
+      subroutine taugb6
+!----------------------------------------------------------------------------
+!
+!     band 6:  820-980 cm-1 (low key - h2o; low minor - co2)
+!                           (high key - nothing; high minor - cfc11, cfc12)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng6, ngs5
+      use rrlw_ref, only : chi_mls
+      use rrlw_kg06, only : fracrefa, absa, ka, ka_mco2, &
+                            selfref, forref, cfc11adj, cfc12
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
+      real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
+      real(kind=rb) :: tauself, taufor, absco2
+
+
+! Minor gas mapping level:
+!     lower - co2, p = 706.2720 mb, t = 294.2 k
+!     upper - cfc11, cfc12
+
+! Compute the optical depth by interpolating in ln(pressure) and
+! temperature. The water vapor self-continuum and foreign continuum
+! is interpolated (in temperature) separately.  
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+
+! In atmospheres where the amount of CO2 is too great to be considered
+! a minor species, adjust the column amount of CO2 by an empirical factor 
+! to obtain the proper contribution.
+         chi_co2 = colco2(lay)/(coldry(lay))
+         ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
+         if (ratco2 .gt. 3.0_rb) then
+            adjfac = 2.0_rb+(ratco2-2.0_rb)**0.77_rb
+            adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
+         else
+            adjcolco2 = colco2(lay)
+         endif
+
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(6) + 1
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(6) + 1
+         inds = indself(lay)
+         indf = indfor(lay)
+         indm = indminor(lay)
+
+         do ig = 1, ng6
+            tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor =  forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig)))
+            absco2 =  (ka_mco2(indm,ig) + minorfrac(lay) * &
+                 (ka_mco2(indm+1,ig) - ka_mco2(indm,ig)))
+            taug(lay,ngs5+ig) = colh2o(lay) * &
+                (fac00(lay) * absa(ind0,ig) + &
+                 fac10(lay) * absa(ind0+1,ig) + &
+                 fac01(lay) * absa(ind1,ig) +  &
+                 fac11(lay) * absa(ind1+1,ig))  &
+                 + tauself + taufor &
+                 + adjcolco2 * absco2 &
+                 + wx(2,lay) * cfc11adj(ig) &
+                 + wx(3,lay) * cfc12(ig)
+            fracs(lay,ngs5+ig) = fracrefa(ig)
+         enddo
+      enddo
+
+! Upper atmosphere loop
+! Nothing important goes on above laytrop in this band.
+      do lay = laytrop+1, nlayers
+
+         do ig = 1, ng6
+            taug(lay,ngs5+ig) = 0.0_rb &
+                 + wx(2,lay) * cfc11adj(ig) &
+                 + wx(3,lay) * cfc12(ig)
+            fracs(lay,ngs5+ig) = fracrefa(ig)
+         enddo
+      enddo
+
+      end subroutine taugb6
+
+!----------------------------------------------------------------------------
+      subroutine taugb7
+!----------------------------------------------------------------------------
+!
+!     band 7:  980-1080 cm-1 (low key - h2o,o3; low minor - co2)
+!                            (high key - o3; high minor - co2)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng7, ngs6
+      use rrlw_ref, only : chi_mls
+      use rrlw_kg07, only : fracrefa, fracrefb, absa, ka, absb, kb, &
+                            ka_mco2, kb_mco2, selfref, forref
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
+      integer(kind=im) :: js, js1, jmco2, jpl
+      real(kind=rb) :: speccomb, specparm, specmult, fs
+      real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
+      real(kind=rb) :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2
+      real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
+      real(kind=rb) :: p, p4, fk0, fk1, fk2
+      real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
+      real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
+      real(kind=rb) :: tauself, taufor, co2m1, co2m2, absco2
+      real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
+      real(kind=rb) :: refrat_planck_a, refrat_m_a
+      real(kind=rb) :: tau_major, tau_major1
+
+
+! Minor gas mapping level :
+!     lower - co2, p = 706.2620 mbar, t= 278.94 k
+!     upper - co2, p = 12.9350 mbar, t = 234.01 k
+
+! Calculate reference ratio to be used in calculation of Planck
+! fraction in lower atmosphere.
+
+! P = 706.2620 mb
+      refrat_planck_a = chi_mls(1,3)/chi_mls(3,3)
+
+! P = 706.2720 mb
+      refrat_m_a = chi_mls(1,3)/chi_mls(3,3)
+
+! Compute the optical depth by interpolating in ln(pressure), 
+! temperature, and appropriate species.  Below laytrop, the water
+! vapor self-continuum and foreign continuum is interpolated 
+! (in temperature) separately. 
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+
+         speccomb = colh2o(lay) + rat_h2oo3(lay)*colo3(lay)
+         specparm = colh2o(lay)/speccomb
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult,1.0_rb)
+
+         speccomb1 = colh2o(lay) + rat_h2oo3_1(lay)*colo3(lay)
+         specparm1 = colh2o(lay)/speccomb1
+         if (specparm1 .ge. oneminus) specparm1 = oneminus
+         specmult1 = 8._rb*(specparm1)
+         js1 = 1 + int(specmult1)
+         fs1 = mod(specmult1,1.0_rb)
+
+         speccomb_mco2 = colh2o(lay) + refrat_m_a*colo3(lay)
+         specparm_mco2 = colh2o(lay)/speccomb_mco2
+         if (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus
+         specmult_mco2 = 8._rb*specparm_mco2
+
+         jmco2 = 1 + int(specmult_mco2)
+         fmco2 = mod(specmult_mco2,1.0_rb)
+
+!  In atmospheres where the amount of CO2 is too great to be considered
+!  a minor species, adjust the column amount of CO2 by an empirical factor 
+!  to obtain the proper contribution.
+         chi_co2 = colco2(lay)/(coldry(lay))
+         ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1)
+         if (ratco2 .gt. 3.0_rb) then
+            adjfac = 3.0_rb+(ratco2-3.0_rb)**0.79_rb
+            adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
+         else
+            adjcolco2 = colco2(lay)
+         endif
+
+         speccomb_planck = colh2o(lay)+refrat_planck_a*colo3(lay)
+         specparm_planck = colh2o(lay)/speccomb_planck
+         if (specparm_planck .ge. oneminus) specparm_planck=oneminus
+         specmult_planck = 8._rb*specparm_planck
+         jpl= 1 + int(specmult_planck)
+         fpl = mod(specmult_planck,1.0_rb)
+
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(7) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(7) + js1
+         inds = indself(lay)
+         indf = indfor(lay)
+         indm = indminor(lay)
+
+         if (specparm .lt. 0.125_rb) then
+            p = fs - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else if (specparm .gt. 0.875_rb) then
+            p = -fs 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else
+            fac000 = (1._rb - fs) * fac00(lay)
+            fac010 = (1._rb - fs) * fac10(lay)
+            fac100 = fs * fac00(lay)
+            fac110 = fs * fac10(lay)
+         endif
+         if (specparm .lt. 0.125_rb) then
+            p = fs1 - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else if (specparm1 .gt. 0.875_rb) then
+            p = -fs1 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else
+            fac001 = (1._rb - fs1) * fac01(lay)
+            fac011 = (1._rb - fs1) * fac11(lay)
+            fac101 = fs1 * fac01(lay)
+            fac111 = fs1 * fac11(lay)
+         endif
+
+         do ig = 1, ng7
+            tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+            co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * &
+                 (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
+            co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * &
+                 (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
+            absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
+
+            if (specparm .lt. 0.125_rb) then
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac200 * absa(ind0+2,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig) + &
+                    fac210 * absa(ind0+11,ig))
+            else if (specparm .gt. 0.875_rb) then
+               tau_major = speccomb * &
+                    (fac200 * absa(ind0-1,ig) + &
+                    fac100 * absa(ind0,ig) + &
+                    fac000 * absa(ind0+1,ig) + &
+                    fac210 * absa(ind0+8,ig) + &
+                    fac110 * absa(ind0+9,ig) + &
+                    fac010 * absa(ind0+10,ig))
+            else
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig))
+            endif
+
+            if (specparm1 .lt. 0.125_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac201 * absa(ind1+2,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig) + &
+                    fac211 * absa(ind1+11,ig))
+            else if (specparm1 .gt. 0.875_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac201 * absa(ind1-1,ig) + &
+                    fac101 * absa(ind1,ig) + &
+                    fac001 * absa(ind1+1,ig) + &
+                    fac211 * absa(ind1+8,ig) + &
+                    fac111 * absa(ind1+9,ig) + &
+                    fac011 * absa(ind1+10,ig))
+            else
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) +  &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig))
+            endif
+
+            taug(lay,ngs6+ig) = tau_major + tau_major1 &
+                 + tauself + taufor &
+                 + adjcolco2*absco2
+            fracs(lay,ngs6+ig) = fracrefa(ig,jpl) + fpl * &
+                 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+
+!  In atmospheres where the amount of CO2 is too great to be considered
+!  a minor species, adjust the column amount of CO2 by an empirical factor 
+!  to obtain the proper contribution.
+         chi_co2 = colco2(lay)/(coldry(lay))
+         ratco2 = 1.e20*chi_co2/chi_mls(2,jp(lay)+1)
+         if (ratco2 .gt. 3.0_rb) then
+            adjfac = 2.0_rb+(ratco2-2.0_rb)**0.79_rb
+            adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
+         else
+            adjcolco2 = colco2(lay)
+         endif
+
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(7) + 1
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(7) + 1
+         indm = indminor(lay)
+
+         do ig = 1, ng7
+            absco2 = kb_mco2(indm,ig) + minorfrac(lay) * &
+                 (kb_mco2(indm+1,ig) - kb_mco2(indm,ig))
+            taug(lay,ngs6+ig) = colo3(lay) * &
+                 (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + &
+                 fac11(lay) * absb(ind1+1,ig)) &
+                 + adjcolco2 * absco2
+            fracs(lay,ngs6+ig) = fracrefb(ig)
+         enddo
+
+! Empirical modification to code to improve stratospheric cooling rates
+! for o3.  Revised to apply weighting for g-point reduction in this band.
+
+         taug(lay,ngs6+6)=taug(lay,ngs6+6)*0.92_rb
+         taug(lay,ngs6+7)=taug(lay,ngs6+7)*0.88_rb
+         taug(lay,ngs6+8)=taug(lay,ngs6+8)*1.07_rb
+         taug(lay,ngs6+9)=taug(lay,ngs6+9)*1.1_rb
+         taug(lay,ngs6+10)=taug(lay,ngs6+10)*0.99_rb
+         taug(lay,ngs6+11)=taug(lay,ngs6+11)*0.855_rb
+
+      enddo
+
+      end subroutine taugb7
+
+!----------------------------------------------------------------------------
+      subroutine taugb8
+!----------------------------------------------------------------------------
+!
+!     band 8:  1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o)
+!                             (high key - o3; high minor - co2, n2o)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng8, ngs7
+      use rrlw_ref, only : chi_mls
+      use rrlw_kg08, only : fracrefa, fracrefb, absa, ka, absb, kb, &
+                            ka_mco2, ka_mn2o, ka_mo3, kb_mco2, kb_mn2o, &
+                            selfref, forref, cfc12, cfc22adj
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
+      real(kind=rb) :: tauself, taufor, absco2, abso3, absn2o
+      real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
+
+
+! Minor gas mapping level:
+!     lower - co2, p = 1053.63 mb, t = 294.2 k
+!     lower - o3,  p = 317.348 mb, t = 240.77 k
+!     lower - n2o, p = 706.2720 mb, t= 278.94 k
+!     lower - cfc12,cfc11
+!     upper - co2, p = 35.1632 mb, t = 223.28 k
+!     upper - n2o, p = 8.716e-2 mb, t = 226.03 k
+
+! Compute the optical depth by interpolating in ln(pressure) and 
+! temperature, and appropriate species.  Below laytrop, the water vapor 
+! self-continuum and foreign continuum is interpolated (in temperature) 
+! separately.
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+
+!  In atmospheres where the amount of CO2 is too great to be considered
+!  a minor species, adjust the column amount of CO2 by an empirical factor 
+!  to obtain the proper contribution.
+         chi_co2 = colco2(lay)/(coldry(lay))
+         ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
+         if (ratco2 .gt. 3.0_rb) then
+            adjfac = 2.0_rb+(ratco2-2.0_rb)**0.65_rb
+            adjcolco2 = adjfac*chi_mls(2,jp(lay)+1)*coldry(lay)*1.e-20_rb
+         else
+            adjcolco2 = colco2(lay)
+         endif
+
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(8) + 1
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(8) + 1
+         inds = indself(lay)
+         indf = indfor(lay)
+         indm = indminor(lay)
+
+         do ig = 1, ng8
+            tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig)))
+            absco2 =  (ka_mco2(indm,ig) + minorfrac(lay) * &
+                 (ka_mco2(indm+1,ig) - ka_mco2(indm,ig)))
+            abso3 =  (ka_mo3(indm,ig) + minorfrac(lay) * &
+                 (ka_mo3(indm+1,ig) - ka_mo3(indm,ig)))
+            absn2o =  (ka_mn2o(indm,ig) + minorfrac(lay) * &
+                 (ka_mn2o(indm+1,ig) - ka_mn2o(indm,ig)))
+            taug(lay,ngs7+ig) = colh2o(lay) * &
+                 (fac00(lay) * absa(ind0,ig) + &
+                 fac10(lay) * absa(ind0+1,ig) + &
+                 fac01(lay) * absa(ind1,ig) +  &
+                 fac11(lay) * absa(ind1+1,ig)) &
+                 + tauself + taufor &
+                 + adjcolco2*absco2 &
+                 + colo3(lay) * abso3 &
+                 + coln2o(lay) * absn2o &
+                 + wx(3,lay) * cfc12(ig) &
+                 + wx(4,lay) * cfc22adj(ig)
+            fracs(lay,ngs7+ig) = fracrefa(ig)
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+
+!  In atmospheres where the amount of CO2 is too great to be considered
+!  a minor species, adjust the column amount of CO2 by an empirical factor 
+!  to obtain the proper contribution.
+         chi_co2 = colco2(lay)/coldry(lay)
+         ratco2 = 1.e20_rb*chi_co2/chi_mls(2,jp(lay)+1)
+         if (ratco2 .gt. 3.0_rb) then
+            adjfac = 2.0_rb+(ratco2-2.0_rb)**0.65_rb
+            adjcolco2 = adjfac*chi_mls(2,jp(lay)+1) * coldry(lay)*1.e-20_rb
+         else
+            adjcolco2 = colco2(lay)
+         endif
+
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(8) + 1
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(8) + 1
+         indm = indminor(lay)
+
+         do ig = 1, ng8
+            absco2 =  (kb_mco2(indm,ig) + minorfrac(lay) * &
+                 (kb_mco2(indm+1,ig) - kb_mco2(indm,ig)))
+            absn2o =  (kb_mn2o(indm,ig) + minorfrac(lay) * &
+                 (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig)))
+            taug(lay,ngs7+ig) = colo3(lay) * &
+                 (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + &
+                 fac11(lay) * absb(ind1+1,ig)) &
+                 + adjcolco2*absco2 &
+                 + coln2o(lay)*absn2o & 
+                 + wx(3,lay) * cfc12(ig) &
+                 + wx(4,lay) * cfc22adj(ig)
+            fracs(lay,ngs7+ig) = fracrefb(ig)
+         enddo
+      enddo
+
+      end subroutine taugb8
+
+!----------------------------------------------------------------------------
+      subroutine taugb9
+!----------------------------------------------------------------------------
+!
+!     band 9:  1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o)
+!                             (high key - ch4; high minor - n2o)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng9, ngs8
+      use rrlw_ref, only : chi_mls
+      use rrlw_kg09, only : fracrefa, fracrefb, absa, ka, absb, kb, &
+                            ka_mn2o, kb_mn2o, selfref, forref
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
+      integer(kind=im) :: js, js1, jmn2o, jpl
+      real(kind=rb) :: speccomb, specparm, specmult, fs
+      real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
+      real(kind=rb) :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o
+      real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
+      real(kind=rb) :: p, p4, fk0, fk1, fk2
+      real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
+      real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
+      real(kind=rb) :: tauself, taufor, n2om1, n2om2, absn2o
+      real(kind=rb) :: chi_n2o, ratn2o, adjfac, adjcoln2o
+      real(kind=rb) :: refrat_planck_a, refrat_m_a
+      real(kind=rb) :: tau_major, tau_major1
+
+
+! Minor gas mapping level :
+!     lower - n2o, p = 706.272 mbar, t = 278.94 k
+!     upper - n2o, p = 95.58 mbar, t = 215.7 k
+
+! Calculate reference ratio to be used in calculation of Planck
+! fraction in lower/upper atmosphere.
+
+! P = 212 mb
+      refrat_planck_a = chi_mls(1,9)/chi_mls(6,9)
+
+! P = 706.272 mb 
+      refrat_m_a = chi_mls(1,3)/chi_mls(6,3)
+
+! Compute the optical depth by interpolating in ln(pressure), 
+! temperature, and appropriate species.  Below laytrop, the water
+! vapor self-continuum and foreign continuum is interpolated 
+! (in temperature) separately.  
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+
+         speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay)
+         specparm = colh2o(lay)/speccomb
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult,1.0_rb)
+
+         speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay)
+         specparm1 = colh2o(lay)/speccomb1
+         if (specparm1 .ge. oneminus) specparm1 = oneminus
+         specmult1 = 8._rb*(specparm1)
+         js1 = 1 + int(specmult1)
+         fs1 = mod(specmult1,1.0_rb)
+
+         speccomb_mn2o = colh2o(lay) + refrat_m_a*colch4(lay)
+         specparm_mn2o = colh2o(lay)/speccomb_mn2o
+         if (specparm_mn2o .ge. oneminus) specparm_mn2o = oneminus
+         specmult_mn2o = 8._rb*specparm_mn2o
+         jmn2o = 1 + int(specmult_mn2o)
+         fmn2o = mod(specmult_mn2o,1.0_rb)
+
+!  In atmospheres where the amount of N2O is too great to be considered
+!  a minor species, adjust the column amount of N2O by an empirical factor 
+!  to obtain the proper contribution.
+         chi_n2o = coln2o(lay)/(coldry(lay))
+         ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
+         if (ratn2o .gt. 1.5_rb) then
+            adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
+            adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
+         else
+            adjcoln2o = coln2o(lay)
+         endif
+
+         speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay)
+         specparm_planck = colh2o(lay)/speccomb_planck
+         if (specparm_planck .ge. oneminus) specparm_planck=oneminus
+         specmult_planck = 8._rb*specparm_planck
+         jpl= 1 + int(specmult_planck)
+         fpl = mod(specmult_planck,1.0_rb)
+
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(9) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(9) + js1
+         inds = indself(lay)
+         indf = indfor(lay)
+         indm = indminor(lay)
+
+         if (specparm .lt. 0.125_rb) then
+            p = fs - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else if (specparm .gt. 0.875_rb) then
+            p = -fs 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else
+            fac000 = (1._rb - fs) * fac00(lay)
+            fac010 = (1._rb - fs) * fac10(lay)
+            fac100 = fs * fac00(lay)
+            fac110 = fs * fac10(lay)
+         endif
+
+         if (specparm1 .lt. 0.125_rb) then
+            p = fs1 - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else if (specparm1 .gt. 0.875_rb) then
+            p = -fs1 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else
+            fac001 = (1._rb - fs1) * fac01(lay)
+            fac011 = (1._rb - fs1) * fac11(lay)
+            fac101 = fs1 * fac01(lay)
+            fac111 = fs1 * fac11(lay)
+         endif
+
+         do ig = 1, ng9
+            tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+            n2om1 = ka_mn2o(jmn2o,indm,ig) + fmn2o * &
+                 (ka_mn2o(jmn2o+1,indm,ig) - ka_mn2o(jmn2o,indm,ig))
+            n2om2 = ka_mn2o(jmn2o,indm+1,ig) + fmn2o * &
+                 (ka_mn2o(jmn2o+1,indm+1,ig) - ka_mn2o(jmn2o,indm+1,ig))
+            absn2o = n2om1 + minorfrac(lay) * (n2om2 - n2om1)
+
+            if (specparm .lt. 0.125_rb) then
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac200 * absa(ind0+2,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig) + &
+                    fac210 * absa(ind0+11,ig))
+            else if (specparm .gt. 0.875_rb) then
+               tau_major = speccomb * &
+                    (fac200 * absa(ind0-1,ig) + &
+                    fac100 * absa(ind0,ig) + &
+                    fac000 * absa(ind0+1,ig) + &
+                    fac210 * absa(ind0+8,ig) + &
+                    fac110 * absa(ind0+9,ig) + &
+                    fac010 * absa(ind0+10,ig))
+            else
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig))
+            endif
+
+            if (specparm1 .lt. 0.125_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + & 
+                    fac101 * absa(ind1+1,ig) + &
+                    fac201 * absa(ind1+2,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig) + &
+                    fac211 * absa(ind1+11,ig))
+            else if (specparm1 .gt. 0.875_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac201 * absa(ind1-1,ig) + &
+                    fac101 * absa(ind1,ig) + &
+                    fac001 * absa(ind1+1,ig) + &
+                    fac211 * absa(ind1+8,ig) + &
+                    fac111 * absa(ind1+9,ig) + &
+                    fac011 * absa(ind1+10,ig))
+            else
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig))
+            endif
+
+            taug(lay,ngs8+ig) = tau_major + tau_major1 &
+                 + tauself + taufor &
+                 + adjcoln2o*absn2o
+            fracs(lay,ngs8+ig) = fracrefa(ig,jpl) + fpl * &
+                 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+
+!  In atmospheres where the amount of N2O is too great to be considered
+!  a minor species, adjust the column amount of N2O by an empirical factor 
+!  to obtain the proper contribution.
+         chi_n2o = coln2o(lay)/(coldry(lay))
+         ratn2o = 1.e20_rb*chi_n2o/chi_mls(4,jp(lay)+1)
+         if (ratn2o .gt. 1.5_rb) then
+            adjfac = 0.5_rb+(ratn2o-0.5_rb)**0.65_rb
+            adjcoln2o = adjfac*chi_mls(4,jp(lay)+1)*coldry(lay)*1.e-20_rb
+         else
+            adjcoln2o = coln2o(lay)
+         endif
+
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(9) + 1
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(9) + 1
+         indm = indminor(lay)
+
+         do ig = 1, ng9
+            absn2o = kb_mn2o(indm,ig) + minorfrac(lay) * &
+                (kb_mn2o(indm+1,ig) - kb_mn2o(indm,ig))
+            taug(lay,ngs8+ig) = colch4(lay) * &
+                 (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) +  &
+                 fac11(lay) * absb(ind1+1,ig)) &
+                 + adjcoln2o*absn2o
+            fracs(lay,ngs8+ig) = fracrefb(ig)
+         enddo
+      enddo
+
+      end subroutine taugb9
+
+!----------------------------------------------------------------------------
+      subroutine taugb10
+!----------------------------------------------------------------------------
+!
+!     band 10:  1390-1480 cm-1 (low key - h2o; high key - h2o)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng10, ngs9
+      use rrlw_kg10, only : fracrefa, fracrefb, absa, ka, absb, kb, &
+                            selfref, forref
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
+      real(kind=rb) :: tauself, taufor
+
+
+! Compute the optical depth by interpolating in ln(pressure) and 
+! temperature.  Below laytrop, the water vapor self-continuum and
+! foreign continuum is interpolated (in temperature) separately.
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(10) + 1
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(10) + 1
+         inds = indself(lay)
+         indf = indfor(lay)
+
+         do ig = 1, ng10
+            tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+            taug(lay,ngs9+ig) = colh2o(lay) * &
+                 (fac00(lay) * absa(ind0,ig) + &
+                 fac10(lay) * absa(ind0+1,ig) + &
+                 fac01(lay) * absa(ind1,ig) + &
+                 fac11(lay) * absa(ind1+1,ig))  &
+                 + tauself + taufor
+            fracs(lay,ngs9+ig) = fracrefa(ig)
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do 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
+         indf = indfor(lay)
+
+         do ig = 1, ng10
+            taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+            taug(lay,ngs9+ig) = colh2o(lay) * &
+                 (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) +  &
+                 fac11(lay) * absb(ind1+1,ig)) &
+                 + taufor
+            fracs(lay,ngs9+ig) = fracrefb(ig)
+         enddo
+      enddo
+
+      end subroutine taugb10
+
+!----------------------------------------------------------------------------
+      subroutine taugb11
+!----------------------------------------------------------------------------
+!
+!     band 11:  1480-1800 cm-1 (low - h2o; low minor - o2)
+!                              (high key - h2o; high minor - o2)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng11, ngs10
+      use rrlw_kg11, only : fracrefa, fracrefb, absa, ka, absb, kb, &
+                            ka_mo2, kb_mo2, selfref, forref
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
+      real(kind=rb) :: scaleo2, tauself, taufor, tauo2
+
+
+! Minor gas mapping level :
+!     lower - o2, p = 706.2720 mbar, t = 278.94 k
+!     upper - o2, p = 4.758820 mbarm t = 250.85 k
+
+! Compute the optical depth by interpolating in ln(pressure) and 
+! temperature.  Below laytrop, the water vapor self-continuum and
+! foreign continuum is interpolated (in temperature) separately.
+
+! Lower atmosphere loop
+      do 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)
+         indf = indfor(lay)
+         indm = indminor(lay)
+         scaleo2 = colo2(lay)*scaleminor(lay)
+         do ig = 1, ng11
+            tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig)))
+            tauo2 =  scaleo2 * (ka_mo2(indm,ig) + minorfrac(lay) * &
+                 (ka_mo2(indm+1,ig) - ka_mo2(indm,ig)))
+            taug(lay,ngs10+ig) = colh2o(lay) * &
+                 (fac00(lay) * absa(ind0,ig) + &
+                 fac10(lay) * absa(ind0+1,ig) + &
+                 fac01(lay) * absa(ind1,ig) + &
+                 fac11(lay) * absa(ind1+1,ig)) &
+                 + tauself + taufor &
+                 + tauo2
+            fracs(lay,ngs10+ig) = fracrefa(ig)
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do 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
+         indf = indfor(lay)
+         indm = indminor(lay)
+         scaleo2 = colo2(lay)*scaleminor(lay)
+         do ig = 1, ng11
+            taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+            tauo2 =  scaleo2 * (kb_mo2(indm,ig) + minorfrac(lay) * &
+                 (kb_mo2(indm+1,ig) - kb_mo2(indm,ig)))
+            taug(lay,ngs10+ig) = colh2o(lay) * &
+                 (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + &
+                 fac11(lay) * absb(ind1+1,ig))  &
+                 + taufor &
+                 + tauo2
+            fracs(lay,ngs10+ig) = fracrefb(ig)
+         enddo
+      enddo
+
+      end subroutine taugb11
+
+!----------------------------------------------------------------------------
+      subroutine taugb12
+!----------------------------------------------------------------------------
+!
+!     band 12:  1800-2080 cm-1 (low - h2o,co2; high - nothing)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng12, ngs11
+      use rrlw_ref, only : chi_mls
+      use rrlw_kg12, only : fracrefa, absa, ka, &
+                            selfref, forref
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
+      integer(kind=im) :: js, js1, jpl
+      real(kind=rb) :: speccomb, specparm, specmult, fs
+      real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
+      real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
+      real(kind=rb) :: p, p4, fk0, fk1, fk2
+      real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
+      real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
+      real(kind=rb) :: tauself, taufor
+      real(kind=rb) :: refrat_planck_a
+      real(kind=rb) :: tau_major, tau_major1
+
+
+! Calculate reference ratio to be used in calculation of Planck
+! fraction in lower/upper atmosphere.
+
+! P =   174.164 mb 
+      refrat_planck_a = chi_mls(1,10)/chi_mls(2,10)
+
+! Compute the optical depth by interpolating in ln(pressure), 
+! temperature, and appropriate species.  Below laytrop, the water
+! vapor self-continuum adn foreign continuum is interpolated 
+! (in temperature) separately.  
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+
+         speccomb = colh2o(lay) + rat_h2oco2(lay)*colco2(lay)
+         specparm = colh2o(lay)/speccomb
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult,1.0_rb)
+
+         speccomb1 = colh2o(lay) + rat_h2oco2_1(lay)*colco2(lay)
+         specparm1 = colh2o(lay)/speccomb1
+         if (specparm1 .ge. oneminus) specparm1 = oneminus
+         specmult1 = 8._rb*(specparm1)
+         js1 = 1 + int(specmult1)
+         fs1 = mod(specmult1,1.0_rb)
+
+         speccomb_planck = colh2o(lay)+refrat_planck_a*colco2(lay)
+         specparm_planck = colh2o(lay)/speccomb_planck
+         if (specparm_planck .ge. oneminus) specparm_planck=oneminus
+         specmult_planck = 8._rb*specparm_planck
+         jpl= 1 + int(specmult_planck)
+         fpl = mod(specmult_planck,1.0_rb)
+
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(12) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(12) + js1
+         inds = indself(lay)
+         indf = indfor(lay)
+
+         if (specparm .lt. 0.125_rb) then
+            p = fs - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else if (specparm .gt. 0.875_rb) then
+            p = -fs 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else
+            fac000 = (1._rb - fs) * fac00(lay)
+            fac010 = (1._rb - fs) * fac10(lay)
+            fac100 = fs * fac00(lay)
+            fac110 = fs * fac10(lay)
+         endif
+
+         if (specparm1 .lt. 0.125_rb) then
+            p = fs1 - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else if (specparm1 .gt. 0.875_rb) then
+            p = -fs1 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else
+            fac001 = (1._rb - fs1) * fac01(lay)
+            fac011 = (1._rb - fs1) * fac11(lay)
+            fac101 = fs1 * fac01(lay)
+            fac111 = fs1 * fac11(lay)
+         endif
+
+         do ig = 1, ng12
+            tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+
+            if (specparm .lt. 0.125_rb) then
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac200 * absa(ind0+2,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig) + &
+                    fac210 * absa(ind0+11,ig))
+            else if (specparm .gt. 0.875_rb) then
+               tau_major = speccomb * &
+                    (fac200 * absa(ind0-1,ig) + &
+                    fac100 * absa(ind0,ig) + &
+                    fac000 * absa(ind0+1,ig) + &
+                    fac210 * absa(ind0+8,ig) + &
+                    fac110 * absa(ind0+9,ig) + &
+                    fac010 * absa(ind0+10,ig))
+            else
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig))
+            endif
+
+            if (specparm1 .lt. 0.125_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac201 * absa(ind1+2,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig) + &
+                    fac211 * absa(ind1+11,ig))
+            else if (specparm1 .gt. 0.875_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac201 * absa(ind1-1,ig) + &
+                    fac101 * absa(ind1,ig) + &
+                    fac001 * absa(ind1+1,ig) + &
+                    fac211 * absa(ind1+8,ig) + &
+                    fac111 * absa(ind1+9,ig) + &
+                    fac011 * absa(ind1+10,ig))
+            else
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig))
+            endif
+
+            taug(lay,ngs11+ig) = tau_major + tau_major1 &
+                 + tauself + taufor
+            fracs(lay,ngs11+ig) = fracrefa(ig,jpl) + fpl * &
+                 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+
+         do ig = 1, ng12
+            taug(lay,ngs11+ig) = 0.0_rb
+            fracs(lay,ngs11+ig) = 0.0_rb
+         enddo
+      enddo
+
+      end subroutine taugb12
+
+!----------------------------------------------------------------------------
+      subroutine taugb13
+!----------------------------------------------------------------------------
+!
+!     band 13:  2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng13, ngs12
+      use rrlw_ref, only : chi_mls
+      use rrlw_kg13, only : fracrefa, fracrefb, absa, ka, &
+                            ka_mco2, ka_mco, kb_mo3, selfref, forref
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
+      integer(kind=im) :: js, js1, jmco2, jmco, jpl
+      real(kind=rb) :: speccomb, specparm, specmult, fs
+      real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
+      real(kind=rb) :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2
+      real(kind=rb) :: speccomb_mco, specparm_mco, specmult_mco, fmco
+      real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
+      real(kind=rb) :: p, p4, fk0, fk1, fk2
+      real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
+      real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
+      real(kind=rb) :: tauself, taufor, co2m1, co2m2, absco2 
+      real(kind=rb) :: com1, com2, absco, abso3
+      real(kind=rb) :: chi_co2, ratco2, adjfac, adjcolco2
+      real(kind=rb) :: refrat_planck_a, refrat_m_a, refrat_m_a3
+      real(kind=rb) :: tau_major, tau_major1
+
+! Minor gas mapping levels :
+!     lower - co2, p = 1053.63 mb, t = 294.2 k
+!     lower - co, p = 706 mb, t = 278.94 k
+!     upper - o3, p = 95.5835 mb, t = 215.7 k
+
+! Calculate reference ratio to be used in calculation of Planck
+! fraction in lower/upper atmosphere.
+
+! P = 473.420 mb (Level 5)
+      refrat_planck_a = chi_mls(1,5)/chi_mls(4,5)
+
+! P = 1053. (Level 1)
+      refrat_m_a = chi_mls(1,1)/chi_mls(4,1)
+
+! P = 706. (Level 3)
+      refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3)
+
+! Compute the optical depth by interpolating in ln(pressure), 
+! temperature, and appropriate species.  Below laytrop, the water
+! vapor self-continuum and foreign continuum is interpolated 
+! (in temperature) separately.  
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+
+         speccomb = colh2o(lay) + rat_h2on2o(lay)*coln2o(lay)
+         specparm = colh2o(lay)/speccomb
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult,1.0_rb)
+
+         speccomb1 = colh2o(lay) + rat_h2on2o_1(lay)*coln2o(lay)
+         specparm1 = colh2o(lay)/speccomb1
+         if (specparm1 .ge. oneminus) specparm1 = oneminus
+         specmult1 = 8._rb*(specparm1)
+         js1 = 1 + int(specmult1)
+         fs1 = mod(specmult1,1.0_rb)
+
+         speccomb_mco2 = colh2o(lay) + refrat_m_a*coln2o(lay)
+         specparm_mco2 = colh2o(lay)/speccomb_mco2
+         if (specparm_mco2 .ge. oneminus) specparm_mco2 = oneminus
+         specmult_mco2 = 8._rb*specparm_mco2
+         jmco2 = 1 + int(specmult_mco2)
+         fmco2 = mod(specmult_mco2,1.0_rb)
+
+!  In atmospheres where the amount of CO2 is too great to be considered
+!  a minor species, adjust the column amount of CO2 by an empirical factor 
+!  to obtain the proper contribution.
+         chi_co2 = colco2(lay)/(coldry(lay))
+         ratco2 = 1.e20_rb*chi_co2/3.55e-4_rb
+         if (ratco2 .gt. 3.0_rb) then
+            adjfac = 2.0_rb+(ratco2-2.0_rb)**0.68_rb
+            adjcolco2 = adjfac*3.55e-4*coldry(lay)*1.e-20_rb
+         else
+            adjcolco2 = colco2(lay)
+         endif
+
+         speccomb_mco = colh2o(lay) + refrat_m_a3*coln2o(lay)
+         specparm_mco = colh2o(lay)/speccomb_mco
+         if (specparm_mco .ge. oneminus) specparm_mco = oneminus
+         specmult_mco = 8._rb*specparm_mco
+         jmco = 1 + int(specmult_mco)
+         fmco = mod(specmult_mco,1.0_rb)
+
+         speccomb_planck = colh2o(lay)+refrat_planck_a*coln2o(lay)
+         specparm_planck = colh2o(lay)/speccomb_planck
+         if (specparm_planck .ge. oneminus) specparm_planck=oneminus
+         specmult_planck = 8._rb*specparm_planck
+         jpl= 1 + int(specmult_planck)
+         fpl = mod(specmult_planck,1.0_rb)
+
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(13) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(13) + js1
+         inds = indself(lay)
+         indf = indfor(lay)
+         indm = indminor(lay)
+
+         if (specparm .lt. 0.125_rb) then
+            p = fs - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else if (specparm .gt. 0.875_rb) then
+            p = -fs 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else
+            fac000 = (1._rb - fs) * fac00(lay)
+            fac010 = (1._rb - fs) * fac10(lay)
+            fac100 = fs * fac00(lay)
+            fac110 = fs * fac10(lay)
+         endif
+
+         if (specparm1 .lt. 0.125_rb) then
+            p = fs1 - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else if (specparm1 .gt. 0.875_rb) then
+            p = -fs1 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else
+            fac001 = (1._rb - fs1) * fac01(lay)
+            fac011 = (1._rb - fs1) * fac11(lay)
+            fac101 = fs1 * fac01(lay)
+            fac111 = fs1 * fac11(lay)
+         endif
+
+         do ig = 1, ng13
+            tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor = forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+            co2m1 = ka_mco2(jmco2,indm,ig) + fmco2 * &
+                 (ka_mco2(jmco2+1,indm,ig) - ka_mco2(jmco2,indm,ig))
+            co2m2 = ka_mco2(jmco2,indm+1,ig) + fmco2 * &
+                 (ka_mco2(jmco2+1,indm+1,ig) - ka_mco2(jmco2,indm+1,ig))
+            absco2 = co2m1 + minorfrac(lay) * (co2m2 - co2m1)
+            com1 = ka_mco(jmco,indm,ig) + fmco * &
+                 (ka_mco(jmco+1,indm,ig) - ka_mco(jmco,indm,ig))
+            com2 = ka_mco(jmco,indm+1,ig) + fmco * &
+                 (ka_mco(jmco+1,indm+1,ig) - ka_mco(jmco,indm+1,ig))
+            absco = com1 + minorfrac(lay) * (com2 - com1)
+
+            if (specparm .lt. 0.125_rb) then
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac200 * absa(ind0+2,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig) + &
+                    fac210 * absa(ind0+11,ig))
+            else if (specparm .gt. 0.875_rb) then
+               tau_major = speccomb * &
+                    (fac200 * absa(ind0-1,ig) + &
+                    fac100 * absa(ind0,ig) + &
+                    fac000 * absa(ind0+1,ig) + &
+                    fac210 * absa(ind0+8,ig) + &
+                    fac110 * absa(ind0+9,ig) + &
+                    fac010 * absa(ind0+10,ig))
+            else
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig))
+            endif
+
+            if (specparm1 .lt. 0.125_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac201 * absa(ind1+2,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig) + &
+                    fac211 * absa(ind1+11,ig))
+            else if (specparm1 .gt. 0.875_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac201 * absa(ind1-1,ig) + &
+                    fac101 * absa(ind1,ig) + &
+                    fac001 * absa(ind1+1,ig) + &
+                    fac211 * absa(ind1+8,ig) + &
+                    fac111 * absa(ind1+9,ig) + &
+                    fac011 * absa(ind1+10,ig))
+            else
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig))
+            endif
+
+            taug(lay,ngs12+ig) = tau_major + tau_major1 &
+                 + tauself + taufor &
+                 + adjcolco2*absco2 &
+                 + colco(lay)*absco
+            fracs(lay,ngs12+ig) = fracrefa(ig,jpl) + fpl * &
+                 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         indm = indminor(lay)
+         do ig = 1, ng13
+            abso3 = kb_mo3(indm,ig) + minorfrac(lay) * &
+                 (kb_mo3(indm+1,ig) - kb_mo3(indm,ig))
+            taug(lay,ngs12+ig) = colo3(lay)*abso3
+            fracs(lay,ngs12+ig) =  fracrefb(ig)
+         enddo
+      enddo
+
+      end subroutine taugb13
+
+!----------------------------------------------------------------------------
+      subroutine taugb14
+!----------------------------------------------------------------------------
+!
+!     band 14:  2250-2380 cm-1 (low - co2; high - co2)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng14, ngs13
+      use rrlw_kg14, only : fracrefa, fracrefb, absa, ka, absb, kb, &
+                            selfref, forref
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
+      real(kind=rb) :: tauself, taufor
+
+
+! Compute the optical depth by interpolating in ln(pressure) and 
+! temperature.  Below laytrop, the water vapor self-continuum 
+! and foreign continuum is interpolated (in temperature) separately.  
+
+! Lower atmosphere loop
+      do 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)
+         indf = indfor(lay)
+         do ig = 1, ng14
+            tauself = selffac(lay) * (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor =  forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+            taug(lay,ngs13+ig) = colco2(lay) * &
+                 (fac00(lay) * absa(ind0,ig) + &
+                 fac10(lay) * absa(ind0+1,ig) + &
+                 fac01(lay) * absa(ind1,ig) + &
+                 fac11(lay) * absa(ind1+1,ig)) &
+                 + tauself + taufor
+            fracs(lay,ngs13+ig) = fracrefa(ig)
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do 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 ig = 1, ng14
+            taug(lay,ngs13+ig) = colco2(lay) * &
+                 (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + &
+                 fac11(lay) * absb(ind1+1,ig))
+            fracs(lay,ngs13+ig) = fracrefb(ig)
+         enddo
+      enddo
+
+      end subroutine taugb14
+
+!----------------------------------------------------------------------------
+      subroutine taugb15
+!----------------------------------------------------------------------------
+!
+!     band 15:  2380-2600 cm-1 (low - n2o,co2; low minor - n2)
+!                              (high - nothing)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng15, ngs14
+      use rrlw_ref, only : chi_mls
+      use rrlw_kg15, only : fracrefa, absa, ka, &
+                            ka_mn2, selfref, forref
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, indm, ig
+      integer(kind=im) :: js, js1, jmn2, jpl
+      real(kind=rb) :: speccomb, specparm, specmult, fs
+      real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
+      real(kind=rb) :: speccomb_mn2, specparm_mn2, specmult_mn2, fmn2
+      real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
+      real(kind=rb) :: p, p4, fk0, fk1, fk2
+      real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
+      real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
+      real(kind=rb) :: scalen2, tauself, taufor, n2m1, n2m2, taun2 
+      real(kind=rb) :: refrat_planck_a, refrat_m_a
+      real(kind=rb) :: tau_major, tau_major1
+
+
+! Minor gas mapping level : 
+!     Lower - Nitrogen Continuum, P = 1053., T = 294.
+
+! Calculate reference ratio to be used in calculation of Planck
+! fraction in lower atmosphere.
+! P = 1053. mb (Level 1)
+      refrat_planck_a = chi_mls(4,1)/chi_mls(2,1)
+
+! P = 1053.
+      refrat_m_a = chi_mls(4,1)/chi_mls(2,1)
+
+! Compute the optical depth by interpolating in ln(pressure), 
+! temperature, and appropriate species.  Below laytrop, the water
+! vapor self-continuum and foreign continuum is interpolated 
+! (in temperature) separately.  
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+
+         speccomb = coln2o(lay) + rat_n2oco2(lay)*colco2(lay)
+         specparm = coln2o(lay)/speccomb
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult,1.0_rb)
+
+         speccomb1 = coln2o(lay) + rat_n2oco2_1(lay)*colco2(lay)
+         specparm1 = coln2o(lay)/speccomb1
+         if (specparm1 .ge. oneminus) specparm1 = oneminus
+         specmult1 = 8._rb*(specparm1)
+         js1 = 1 + int(specmult1)
+         fs1 = mod(specmult1,1.0_rb)
+
+         speccomb_mn2 = coln2o(lay) + refrat_m_a*colco2(lay)
+         specparm_mn2 = coln2o(lay)/speccomb_mn2
+         if (specparm_mn2 .ge. oneminus) specparm_mn2 = oneminus
+         specmult_mn2 = 8._rb*specparm_mn2
+         jmn2 = 1 + int(specmult_mn2)
+         fmn2 = mod(specmult_mn2,1.0_rb)
+
+         speccomb_planck = coln2o(lay)+refrat_planck_a*colco2(lay)
+         specparm_planck = coln2o(lay)/speccomb_planck
+         if (specparm_planck .ge. oneminus) specparm_planck=oneminus
+         specmult_planck = 8._rb*specparm_planck
+         jpl= 1 + int(specmult_planck)
+         fpl = mod(specmult_planck,1.0_rb)
+
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(15) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(15) + js1
+         inds = indself(lay)
+         indf = indfor(lay)
+         indm = indminor(lay)
+         
+         scalen2 = colbrd(lay)*scaleminor(lay)
+
+         if (specparm .lt. 0.125_rb) then
+            p = fs - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else if (specparm .gt. 0.875_rb) then
+            p = -fs 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else
+            fac000 = (1._rb - fs) * fac00(lay)
+            fac010 = (1._rb - fs) * fac10(lay)
+            fac100 = fs * fac00(lay)
+            fac110 = fs * fac10(lay)
+         endif
+         if (specparm1 .lt. 0.125_rb) then
+            p = fs1 - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else if (specparm1 .gt. 0.875_rb) then
+            p = -fs1 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else
+            fac001 = (1._rb - fs1) * fac01(lay)
+            fac011 = (1._rb - fs1) * fac11(lay)
+            fac101 = fs1 * fac01(lay)
+            fac111 = fs1 * fac11(lay)
+         endif
+
+         do ig = 1, ng15
+            tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor =  forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+            n2m1 = ka_mn2(jmn2,indm,ig) + fmn2 * &
+                 (ka_mn2(jmn2+1,indm,ig) - ka_mn2(jmn2,indm,ig))
+            n2m2 = ka_mn2(jmn2,indm+1,ig) + fmn2 * &
+                 (ka_mn2(jmn2+1,indm+1,ig) - ka_mn2(jmn2,indm+1,ig))
+            taun2 = scalen2 * (n2m1 + minorfrac(lay) * (n2m2 - n2m1))
+
+            if (specparm .lt. 0.125_rb) then
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac200 * absa(ind0+2,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig) + &
+                    fac210 * absa(ind0+11,ig))
+            else if (specparm .gt. 0.875_rb) then
+               tau_major = speccomb * &
+                    (fac200 * absa(ind0-1,ig) + &
+                    fac100 * absa(ind0,ig) + &
+                    fac000 * absa(ind0+1,ig) + &
+                    fac210 * absa(ind0+8,ig) + &
+                    fac110 * absa(ind0+9,ig) + &
+                    fac010 * absa(ind0+10,ig))
+            else
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig))
+            endif 
+
+            if (specparm1 .lt. 0.125_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac201 * absa(ind1+2,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig) + &
+                    fac211 * absa(ind1+11,ig))
+            else if (specparm1 .gt. 0.875_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac201 * absa(ind1-1,ig) + &
+                    fac101 * absa(ind1,ig) + &
+                    fac001 * absa(ind1+1,ig) + &
+                    fac211 * absa(ind1+8,ig) + &
+                    fac111 * absa(ind1+9,ig) + &
+                    fac011 * absa(ind1+10,ig))
+            else
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig))
+            endif
+
+            taug(lay,ngs14+ig) = tau_major + tau_major1 &
+                 + tauself + taufor &
+                 + taun2
+            fracs(lay,ngs14+ig) = fracrefa(ig,jpl) + fpl * &
+                 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         do ig = 1, ng15
+            taug(lay,ngs14+ig) = 0.0_rb
+            fracs(lay,ngs14+ig) = 0.0_rb
+         enddo
+      enddo
+
+      end subroutine taugb15
+
+!----------------------------------------------------------------------------
+      subroutine taugb16
+!----------------------------------------------------------------------------
+!
+!     band 16:  2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrtm, only : ng16, ngs15
+      use rrlw_ref, only : chi_mls
+      use rrlw_kg16, only : fracrefa, fracrefb, absa, ka, absb, kb, &
+                            selfref, forref
+
+! ------- Declarations -------
+
+! Local 
+      integer(kind=im) :: lay, ind0, ind1, inds, indf, ig
+      integer(kind=im) :: js, js1, jpl
+      real(kind=rb) :: speccomb, specparm, specmult, fs
+      real(kind=rb) :: speccomb1, specparm1, specmult1, fs1
+      real(kind=rb) :: speccomb_planck, specparm_planck, specmult_planck, fpl
+      real(kind=rb) :: p, p4, fk0, fk1, fk2
+      real(kind=rb) :: fac000, fac100, fac200, fac010, fac110, fac210
+      real(kind=rb) :: fac001, fac101, fac201, fac011, fac111, fac211
+      real(kind=rb) :: tauself, taufor
+      real(kind=rb) :: refrat_planck_a
+      real(kind=rb) :: tau_major, tau_major1
+
+
+! Calculate reference ratio to be used in calculation of Planck
+! fraction in lower atmosphere.
+
+! P = 387. mb (Level 6)
+      refrat_planck_a = chi_mls(1,6)/chi_mls(6,6)
+
+! Compute the optical depth by interpolating in ln(pressure), 
+! temperature,and appropriate species.  Below laytrop, the water
+! vapor self-continuum and foreign continuum is interpolated 
+! (in temperature) separately.  
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+
+         speccomb = colh2o(lay) + rat_h2och4(lay)*colch4(lay)
+         specparm = colh2o(lay)/speccomb
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult,1.0_rb)
+
+         speccomb1 = colh2o(lay) + rat_h2och4_1(lay)*colch4(lay)
+         specparm1 = colh2o(lay)/speccomb1
+         if (specparm1 .ge. oneminus) specparm1 = oneminus
+         specmult1 = 8._rb*(specparm1)
+         js1 = 1 + int(specmult1)
+         fs1 = mod(specmult1,1.0_rb)
+
+         speccomb_planck = colh2o(lay)+refrat_planck_a*colch4(lay)
+         specparm_planck = colh2o(lay)/speccomb_planck
+         if (specparm_planck .ge. oneminus) specparm_planck=oneminus
+         specmult_planck = 8._rb*specparm_planck
+         jpl= 1 + int(specmult_planck)
+         fpl = mod(specmult_planck,1.0_rb)
+
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(16) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(16) + js1
+         inds = indself(lay)
+         indf = indfor(lay)
+
+         if (specparm .lt. 0.125_rb) then
+            p = fs - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else if (specparm .gt. 0.875_rb) then
+            p = -fs 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac000 = fk0*fac00(lay)
+            fac100 = fk1*fac00(lay)
+            fac200 = fk2*fac00(lay)
+            fac010 = fk0*fac10(lay)
+            fac110 = fk1*fac10(lay)
+            fac210 = fk2*fac10(lay)
+         else
+            fac000 = (1._rb - fs) * fac00(lay)
+            fac010 = (1._rb - fs) * fac10(lay)
+            fac100 = fs * fac00(lay)
+            fac110 = fs * fac10(lay)
+         endif
+
+         if (specparm1 .lt. 0.125_rb) then
+            p = fs1 - 1
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else if (specparm1 .gt. 0.875_rb) then
+            p = -fs1 
+            p4 = p**4
+            fk0 = p4
+            fk1 = 1 - p - 2.0_rb*p4
+            fk2 = p + p4
+            fac001 = fk0*fac01(lay)
+            fac101 = fk1*fac01(lay)
+            fac201 = fk2*fac01(lay)
+            fac011 = fk0*fac11(lay)
+            fac111 = fk1*fac11(lay)
+            fac211 = fk2*fac11(lay)
+         else
+            fac001 = (1._rb - fs1) * fac01(lay)
+            fac011 = (1._rb - fs1) * fac11(lay)
+            fac101 = fs1 * fac01(lay)
+            fac111 = fs1 * fac11(lay)
+         endif
+
+         do ig = 1, ng16
+            tauself = selffac(lay)* (selfref(inds,ig) + selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig)))
+            taufor =  forfac(lay) * (forref(indf,ig) + forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+
+            if (specparm .lt. 0.125_rb) then
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac200 * absa(ind0+2,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig) + &
+                    fac210 * absa(ind0+11,ig))
+            else if (specparm .gt. 0.875_rb) then
+               tau_major = speccomb * &
+                    (fac200 * absa(ind0-1,ig) + &
+                    fac100 * absa(ind0,ig) + &
+                    fac000 * absa(ind0+1,ig) + &
+                    fac210 * absa(ind0+8,ig) + &
+                    fac110 * absa(ind0+9,ig) + &
+                    fac010 * absa(ind0+10,ig))
+            else
+               tau_major = speccomb * &
+                    (fac000 * absa(ind0,ig) + &
+                    fac100 * absa(ind0+1,ig) + &
+                    fac010 * absa(ind0+9,ig) + &
+                    fac110 * absa(ind0+10,ig))
+            endif
+
+            if (specparm1 .lt. 0.125_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac201 * absa(ind1+2,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig) + &
+                    fac211 * absa(ind1+11,ig))
+            else if (specparm1 .gt. 0.875_rb) then
+               tau_major1 = speccomb1 * &
+                    (fac201 * absa(ind1-1,ig) + &
+                    fac101 * absa(ind1,ig) + &
+                    fac001 * absa(ind1+1,ig) + &
+                    fac211 * absa(ind1+8,ig) + &
+                    fac111 * absa(ind1+9,ig) + &
+                    fac011 * absa(ind1+10,ig))
+            else
+               tau_major1 = speccomb1 * &
+                    (fac001 * absa(ind1,ig) + &
+                    fac101 * absa(ind1+1,ig) + &
+                    fac011 * absa(ind1+9,ig) + &
+                    fac111 * absa(ind1+10,ig))
+            endif
+
+            taug(lay,ngs15+ig) = tau_major + tau_major1 &
+                 + tauself + taufor
+            fracs(lay,ngs15+ig) = fracrefa(ig,jpl) + fpl * &
+                 (fracrefa(ig,jpl+1)-fracrefa(ig,jpl))
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1
+         do ig = 1, ng16
+            taug(lay,ngs15+ig) = colch4(lay) * &
+                 (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + &
+                 fac11(lay) * absb(ind1+1,ig))
+            fracs(lay,ngs15+ig) = fracrefb(ig)
+         enddo
+      enddo
+
+      end subroutine taugb16
+
+      end subroutine taumol
+
+      end module rrtmg_lw_taumol
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+!
+      module rrtmg_lw_init
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! ------- Modules -------
+      use parkind, only : im => kind_im, rb => kind_rb
+      use rrlw_wvn
+      use rrtmg_lw_setcoef, only: lwatmref, lwavplank
+
+! Steven Cavallo: added for buffer layer adjustment
+      implicit none
+
+      integer , save    :: nlayers 
+
+      contains
+
+! **************************************************************************
+      subroutine rrtmg_lw_ini(cpdair)
+! **************************************************************************
+!
+!  Original version:       Michael J. Iacono; July, 1998
+!  First revision for GCMs:   September, 1998
+!  Second revision for RRTM_V3.0:  September, 2002
+!
+!  This subroutine performs calculations necessary for the initialization
+!  of the longwave model.  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-point intervals to 140.
+! **************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw
+      use rrlw_tbl, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl, tfn_tbl
+      use rrlw_vsn, only: hvrini, hnamini
+
+      real(kind=rb), intent(in) :: cpdair     ! Specific heat capacity of dry air
+                                              ! at constant pressure at 273 K
+                                              ! (J kg-1 K-1)
+
+! ------- Local -------
+
+      integer(kind=im) :: itr, ibnd, igc, ig, ind, ipr 
+      integer(kind=im) :: igcsm, iprsm
+
+      real(kind=rb) :: wtsum, wtsm(mg)        !
+      real(kind=rb) :: tfn                    !
+
+      real(kind=rb), parameter :: expeps = 1.e-20   ! Smallest value for exponential table
+
+! ------- Definitions -------
+!     Arrays for 10000-point look-up tables:
+!     TAU_TBL Clear-sky optical depth (used in cloudy radiative transfer)
+!     EXP_TBL Exponential lookup table for ransmittance
+!     TFN_TBL 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.
+!     PADE    Pade approximation constant (= 0.278)
+!     BPADE   Inverse of the Pade approximation constant
+!
+
+      hvrini = '$Revision: 1.3 $'
+
+! Initialize model data
+      call lwdatinit(cpdair)
+      call lwcmbdat               ! g-point interval reduction data
+      call lwcldpr                ! cloud optical properties
+      call lwatmref               ! reference MLS profile
+      call lwavplank              ! Planck function 
+! Moved to module_ra_rrtmg_lw for WRF
+!      call lw_kgb01               ! molecular absorption coefficients
+!      call lw_kgb02
+!      call lw_kgb03
+!      call lw_kgb04
+!      call lw_kgb05
+!      call lw_kgb06
+!      call lw_kgb07
+!      call lw_kgb08
+!      call lw_kgb09
+!      call lw_kgb10
+!      call lw_kgb11
+!      call lw_kgb12
+!      call lw_kgb13
+!      call lw_kgb14
+!      call lw_kgb15
+!      call lw_kgb16
+
+! 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_tbl(0) = 0.0_rb
+      tau_tbl(ntbl) = 1.e10_rb
+      exp_tbl(0) = 1.0_rb
+      exp_tbl(ntbl) = expeps
+      tfn_tbl(0) = 0.0_rb
+      tfn_tbl(ntbl) = 1.0_rb
+      bpade = 1.0_rb / pade
+      do itr = 1, ntbl-1
+         tfn = float(itr) / float(ntbl)
+         tau_tbl(itr) = bpade * tfn / (1._rb - tfn)
+         exp_tbl(itr) = exp(-tau_tbl(itr))
+         if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps
+         if (tau_tbl(itr) .lt. 0.06_rb) then
+            tfn_tbl(itr) = tau_tbl(itr)/6._rb
+         else
+            tfn_tbl(itr) = 1._rb-2._rb*((1._rb/tau_tbl(itr))-(exp_tbl(itr)/(1.-exp_tbl(itr))))
+         endif
+      enddo
+
+! 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 ibnd = 1,nbndlw
+         iprsm = 0
+         if (ngc(ibnd).lt.mg) then
+            do igc = 1,ngc(ibnd) 
+               igcsm = igcsm + 1
+               wtsum = 0._rb
+               do ipr = 1, ngn(igcsm)
+                  iprsm = iprsm + 1
+                  wtsum = wtsum + wt(iprsm)
+               enddo
+               wtsm(igc) = wtsum
+            enddo
+            do ig = 1, ng(ibnd)
+               ind = (ibnd-1)*mg + ig
+               rwgt(ind) = wt(ig)/wtsm(ngm(ind))
+            enddo
+         else
+            do ig = 1, ng(ibnd)
+               igcsm = igcsm + 1
+               ind = (ibnd-1)*mg + ig
+               rwgt(ind) = 1.0_rb
+            enddo
+         endif
+      enddo
+
+! Reduce g-points for absorption coefficient data in each LW spectral band.
+
+      call cmbgb1
+      call cmbgb2
+      call cmbgb3
+      call cmbgb4
+      call cmbgb5
+      call cmbgb6
+      call cmbgb7
+      call cmbgb8
+      call cmbgb9
+      call cmbgb10
+      call cmbgb11
+      call cmbgb12
+      call cmbgb13
+      call cmbgb14
+      call cmbgb15
+      call cmbgb16
+
+      end subroutine rrtmg_lw_ini
+
+!***************************************************************************
+      subroutine lwdatinit(cpdair)
+!***************************************************************************
+
+! --------- Modules ----------
+
+      use parrrtm, only : maxxsec, maxinpx
+      use rrlw_con, only: heatfac, grav, planck, boltz, &
+                          clight, avogad, alosmt, gascon, radcn1, radcn2, &
+                          sbcnst, secdy 
+      use rrlw_vsn
+
+      save 
+ 
+      real(kind=rb), intent(in) :: cpdair      ! Specific heat capacity of dry air
+                                               ! at constant pressure at 273 K
+                                               ! (J kg-1 K-1)
+
+! Longwave spectral band limits (wavenumbers)
+      wavenum1(:) = (/ 10._rb, 350._rb, 500._rb, 630._rb, 700._rb, 820._rb, &
+                      980._rb,1080._rb,1180._rb,1390._rb,1480._rb,1800._rb, &
+                     2080._rb,2250._rb,2380._rb,2600._rb/)
+      wavenum2(:) = (/350._rb, 500._rb, 630._rb, 700._rb, 820._rb, 980._rb, &
+                     1080._rb,1180._rb,1390._rb,1480._rb,1800._rb,2080._rb, &
+                     2250._rb,2380._rb,2600._rb,3250._rb/)
+      delwave(:) =  (/340._rb, 150._rb, 130._rb,  70._rb, 120._rb, 160._rb, &
+                      100._rb, 100._rb, 210._rb,  90._rb, 320._rb, 280._rb, &
+                      170._rb, 130._rb, 220._rb, 650._rb/)
+
+! Spectral band information
+      ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
+      nspa(:) = (/1,1,9,9,9,1,9,1,9,1,1,9,9,1,9,9/)
+      nspb(:) = (/1,1,5,5,5,0,1,1,1,1,1,0,0,1,0,0/)
+
+!     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
+      nxmol = 4
+      ixindx(1) = 1
+      ixindx(2) = 2
+      ixindx(3) = 3
+      ixindx(4) = 4
+      ixindx(5:maxinpx) = 0
+
+! Fundamental physical constants from NIST 2002
+
+      grav = 9.8066_rb                        ! Acceleration of gravity
+                                              ! (m s-2)
+      planck = 6.62606876e-27_rb              ! Planck constant
+                                              ! (ergs s; g cm2 s-1)
+      boltz = 1.3806503e-16_rb                ! Boltzmann constant
+                                              ! (ergs K-1; g cm2 s-2 K-1)
+      clight = 2.99792458e+10_rb              ! Speed of light in a vacuum  
+                                              ! (cm s-1)
+      avogad = 6.02214199e+23_rb              ! Avogadro constant
+                                              ! (mol-1)
+      alosmt = 2.6867775e+19_rb               ! Loschmidt constant
+                                              ! (cm-3)
+      gascon = 8.31447200e+07_rb              ! Molar gas constant
+                                              ! (ergs mol-1 K-1)
+      radcn1 = 1.191042722e-12_rb             ! First radiation constant
+                                              ! (W cm2 sr-1)
+      radcn2 = 1.4387752_rb                   ! Second radiation constant
+                                              ! (cm K)
+      sbcnst = 5.670400e-04_rb                ! Stefan-Boltzmann constant
+                                              ! (W cm-2 K-4)
+      secdy = 8.6400e4_rb                     ! Number of seconds per day
+                                              ! (s d-1)
+!
+!     units are generally cgs
+!
+!     The first and second radiation constants are taken from NIST.
+!     They were previously obtained from the relations:
+!          radcn1 = 2.*planck*clight*clight*1.e-07
+!          radcn2 = planck*clight/boltz
+
+!     Heatfac is the factor by which delta-flux / delta-pressure is
+!     multiplied, with flux in W/m-2 and pressure in mbar, to get 
+!     the heating rate in units of degrees/day.  It is equal to:
+!     Original value:
+!           (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
+!           Here, cpdair (1.004) is in units of J g-1 K-1, and the 
+!           constant (1.e-5) converts mb to Pa and g-1 to kg-1.
+!        =  (9.8066)(86400)(1e-5)/(1.004)
+!      heatfac = 8.4391_rb
+!
+!     Modified value for consistency with CAM3:
+!           (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
+!           Here, cpdair (1.00464) is in units of J g-1 K-1, and the
+!           constant (1.e-5) converts mb to Pa and g-1 to kg-1.
+!        =  (9.80616)(86400)(1e-5)/(1.00464)
+!      heatfac = 8.43339130434_rb
+!
+!     Calculated value:
+!        (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2)
+!           Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2) 
+!           converts mb to Pa when heatfac is multiplied by W m-2 mb-1. 
+      heatfac = grav * secdy / (cpdair * 1.e2_rb)
+
+      end subroutine lwdatinit
+
+!***************************************************************************
+      subroutine lwcmbdat
+!***************************************************************************
+
+      save
+ 
+! ------- Definitions -------
+!     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.  The full 256
+!     g-point set can be restored with ngptlw=256, ngc=16*16, ngn=256*1., etc.
+!     ngptlw  The total number of new g-points
+!     ngc     The number of new g-points in each band
+!     ngs     The cumulative sum of new g-points for 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 -------
+      ngc(:) = (/10,12,16,14,16,8,12,8,12,6,8,8,4,2,2,2/)
+      ngs(:) = (/10,22,38,52,68,76,88,96,108,114,122,130,134,136,138,140/)
+      ngm(:) = (/1,2,3,3,4,4,5,5,6,6,7,7,8,8,9,10, &          ! band 1
+                 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, &     ! 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,2,2,2,2,2,2,2,2,2,2,2,2/)            ! band 16
+      ngn(:) = (/1,1,2,2,2,2,2,2,1,1, &                       ! band 1
+                 1,1,1,1,1,1,1,1,2,2,2,2, &                   ! band 2
+                 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 3
+                 1,1,1,1,1,1,1,1,1,1,1,1,1,3, &               ! band 4
+                 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,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
+                 4,12/)                                       ! band 16
+      ngb(:) = (/1,1,1,1,1,1,1,1,1,1, &                       ! band 1
+                 2,2,2,2,2,2,2,2,2,2,2,2, &                   ! band 2
+                 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, &           ! band 3
+                 4,4,4,4,4,4,4,4,4,4,4,4,4,4, &               ! band 4
+                 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5, &           ! band 5
+                 6,6,6,6,6,6,6,6, &                           ! band 6
+                 7,7,7,7,7,7,7,7,7,7,7,7, &                   ! band 7
+                 8,8,8,8,8,8,8,8, &                           ! band 8
+                 9,9,9,9,9,9,9,9,9,9,9,9, &                   ! band 9
+                 10,10,10,10,10,10, &                         ! band 10
+                 11,11,11,11,11,11,11,11, &                   ! band 11
+                 12,12,12,12,12,12,12,12, &                   ! band 12
+                 13,13,13,13, &                               ! band 13
+                 14,14, &                                     ! band 14
+                 15,15, &                                     ! band 15
+                 16,16/)                                      ! band 16
+      wt(:) = (/ 0.1527534276_rb, 0.1491729617_rb, 0.1420961469_rb, &
+                 0.1316886544_rb, 0.1181945205_rb, 0.1019300893_rb, &
+                 0.0832767040_rb, 0.0626720116_rb, 0.0424925000_rb, &
+                 0.0046269894_rb, 0.0038279891_rb, 0.0030260086_rb, &
+                 0.0022199750_rb, 0.0014140010_rb, 0.0005330000_rb, &
+                 0.0000750000_rb/)
+
+      end subroutine lwcmbdat
+
+!***************************************************************************
+      subroutine cmbgb1
+!***************************************************************************
+!
+!  Original version:    MJIacono; July 1998
+!  Revision for GCMs:   MJIacono; September 1998
+!  Revision for RRTMG:  MJIacono, September 2002
+!  Revision for F90 reformatting:  MJIacono, June 2006
+!
+!  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-350 cm-1 (low key - h2o; low minor - n2)
+!                       (high key - h2o; high minor - n2)
+!  note: previous versions of rrtm band 1: 
+!        10-250 cm-1 (low - h2o; high - h2o)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng1
+      use rrlw_kg01, only: fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, &
+                           selfrefo, forrefo, &
+                           fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2, kb_mn2, &
+                           selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumk1, sumk2, sumf1, sumf2
+
+
+      do jt = 1,5
+         do jp = 1,13
+            iprsm = 0
+            do igc = 1,ngc(1)
+               sumk = 0.
+               do ipr = 1, ngn(igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm)
+               enddo
+               ka(jt,jp,igc) = sumk
+            enddo
+         enddo
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(1)
+               sumk = 0.
+               do ipr = 1, ngn(igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(1)
+            sumk = 0.
+            do ipr = 1, ngn(igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(1)
+            sumk = 0.
+            do ipr = 1, ngn(igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,19
+         iprsm = 0
+         do igc = 1,ngc(1)
+            sumk1 = 0.
+            sumk2 = 0.
+            do ipr = 1, ngn(igc)
+               iprsm = iprsm + 1
+               sumk1 = sumk1 + kao_mn2(jt,iprsm)*rwgt(iprsm)
+               sumk2 = sumk2 + kbo_mn2(jt,iprsm)*rwgt(iprsm)
+            enddo
+            ka_mn2(jt,igc) = sumk1
+            kb_mn2(jt,igc) = sumk2
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(1)
+         sumf1 = 0.
+         sumf2 = 0.
+         do ipr = 1, ngn(igc)
+            iprsm = iprsm + 1
+            sumf1= sumf1+ fracrefao(iprsm)
+            sumf2= sumf2+ fracrefbo(iprsm)
+         enddo
+         fracrefa(igc) = sumf1
+         fracrefb(igc) = sumf2
+      enddo
+
+      end subroutine cmbgb1
+
+!***************************************************************************
+      subroutine cmbgb2
+!***************************************************************************
+!
+!     band 2:  350-500 cm-1 (low key - h2o; high key - h2o)
+!
+!     note: previous version of rrtm band 2: 
+!           250 - 500 cm-1 (low - h2o; high - h2o)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng2
+      use rrlw_kg02, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
+                           fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumf1, sumf2
+
+
+      do jt = 1,5
+         do jp = 1,13
+            iprsm = 0
+            do igc = 1,ngc(2)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(1)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+16)
+               enddo
+               ka(jt,jp,igc) = sumk
+            enddo
+         enddo
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(2)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(1)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+16)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(2)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(1)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(2)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(1)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(2)
+         sumf1 = 0.
+         sumf2 = 0.
+         do ipr = 1, ngn(ngs(1)+igc)
+            iprsm = iprsm + 1
+            sumf1= sumf1+ fracrefao(iprsm)
+            sumf2= sumf2+ fracrefbo(iprsm)
+         enddo
+         fracrefa(igc) = sumf1
+         fracrefb(igc) = sumf2
+      enddo
+
+      end subroutine cmbgb2
+
+!***************************************************************************
+      subroutine cmbgb3
+!***************************************************************************
+!
+!     band 3:  500-630 cm-1 (low key - h2o,co2; low minor - n2o)
+!                           (high key - h2o,co2; high minor - n2o)
+!
+! old band 3:  500-630 cm-1 (low - h2o,co2; high - h2o,co2)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng3
+      use rrlw_kg03, only: fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, &
+                           selfrefo, forrefo, &
+                           fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2o, kb_mn2o, &
+                           selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(3)
+                 sumk = 0.
+                  do ipr = 1, ngn(ngs(2)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+      do jn = 1,5
+         do jt = 1,5
+            do jp = 13,59
+               iprsm = 0
+               do igc = 1,ngc(3)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(2)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+32)
+                  enddo
+                  kb(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jn = 1,9
+         do jt = 1,19
+            iprsm = 0
+            do igc = 1,ngc(3)
+              sumk = 0.
+               do ipr = 1, ngn(ngs(2)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
+               enddo
+               ka_mn2o(jn,jt,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jn = 1,5
+         do jt = 1,19
+            iprsm = 0
+            do igc = 1,ngc(3)
+              sumk = 0.
+               do ipr = 1, ngn(ngs(2)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
+               enddo
+               kb_mn2o(jn,jt,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(3)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(2)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(3)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(2)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(3)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(2)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + fracrefao(iprsm,jp)
+            enddo
+            fracrefa(igc,jp) = sumf
+         enddo
+      enddo
+
+      do jp = 1,5
+         iprsm = 0
+         do igc = 1,ngc(3)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(2)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + fracrefbo(iprsm,jp)
+            enddo
+            fracrefb(igc,jp) = sumf
+         enddo
+      enddo
+
+      end subroutine cmbgb3
+
+!***************************************************************************
+      subroutine cmbgb4
+!***************************************************************************
+!
+!     band 4:  630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
+!
+! old band 4:  630-700 cm-1 (low - h2o,co2; high - o3,co2)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng4
+      use rrlw_kg04, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
+                           fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(4)
+                 sumk = 0.
+                  do ipr = 1, ngn(ngs(3)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+      do jn = 1,5
+         do jt = 1,5
+            do jp = 13,59
+               iprsm = 0
+               do igc = 1,ngc(4)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(3)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+48)
+                  enddo
+                  kb(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(4)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(3)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(4)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(3)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(4)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(3)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + fracrefao(iprsm,jp)
+            enddo
+            fracrefa(igc,jp) = sumf
+         enddo
+      enddo
+
+      do jp = 1,5
+         iprsm = 0
+         do igc = 1,ngc(4)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(3)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + fracrefbo(iprsm,jp)
+            enddo
+            fracrefb(igc,jp) = sumf
+         enddo
+      enddo
+
+      end subroutine cmbgb4
+
+!***************************************************************************
+      subroutine cmbgb5
+!***************************************************************************
+!
+!     band 5:  700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4)
+!                           (high key - o3,co2)
+!
+! old band 5:  700-820 cm-1 (low - h2o,co2; high - o3,co2)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng5
+      use rrlw_kg05, only: fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, &
+                           selfrefo, forrefo, &
+                           fracrefa, fracrefb, absa, ka, absb, kb, ka_mo3, ccl4, &
+                           selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(5)
+                 sumk = 0.
+                  do ipr = 1, ngn(ngs(4)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+64)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+      do jn = 1,5
+         do jt = 1,5
+            do jp = 13,59
+               iprsm = 0
+               do igc = 1,ngc(5)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(4)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+64)
+                  enddo
+                  kb(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jn = 1,9
+         do jt = 1,19
+            iprsm = 0
+            do igc = 1,ngc(5)
+              sumk = 0.
+               do ipr = 1, ngn(ngs(4)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao_mo3(jn,jt,iprsm)*rwgt(iprsm+64)
+               enddo
+               ka_mo3(jn,jt,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(5)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(4)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(5)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(4)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(5)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(4)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + fracrefao(iprsm,jp)
+            enddo
+            fracrefa(igc,jp) = sumf
+         enddo
+      enddo
+
+      do jp = 1,5
+         iprsm = 0
+         do igc = 1,ngc(5)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(4)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + fracrefbo(iprsm,jp)
+            enddo
+            fracrefb(igc,jp) = sumf
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(5)
+         sumk = 0.
+         do ipr = 1, ngn(ngs(4)+igc)
+            iprsm = iprsm + 1
+            sumk = sumk + ccl4o(iprsm)*rwgt(iprsm+64)
+         enddo
+         ccl4(igc) = sumk
+      enddo
+
+      end subroutine cmbgb5
+
+!***************************************************************************
+      subroutine cmbgb6
+!***************************************************************************
+!
+!     band 6:  820-980 cm-1 (low key - h2o; low minor - co2)
+!                           (high key - nothing; high minor - cfc11, cfc12)
+!
+! old band 6:  820-980 cm-1 (low - h2o; high - nothing)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng6
+      use rrlw_kg06, only: fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, &
+                           selfrefo, forrefo, &
+                           fracrefa, absa, ka, ka_mco2, cfc11adj, cfc12, &
+                           selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumf, sumk1, sumk2
+
+
+      do jt = 1,5
+         do jp = 1,13
+            iprsm = 0
+            do igc = 1,ngc(6)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(5)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+80)
+               enddo
+               ka(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,19
+         iprsm = 0
+         do igc = 1,ngc(6)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(5)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + kao_mco2(jt,iprsm)*rwgt(iprsm+80)
+            enddo
+            ka_mco2(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(6)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(5)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(6)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(5)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(6)
+         sumf = 0.
+         sumk1= 0.
+         sumk2= 0.
+         do ipr = 1, ngn(ngs(5)+igc)
+            iprsm = iprsm + 1
+            sumf = sumf + fracrefao(iprsm)
+            sumk1= sumk1+ cfc11adjo(iprsm)*rwgt(iprsm+80)
+            sumk2= sumk2+ cfc12o(iprsm)*rwgt(iprsm+80)
+         enddo
+         fracrefa(igc) = sumf
+         cfc11adj(igc) = sumk1
+         cfc12(igc) = sumk2
+      enddo
+
+      end subroutine cmbgb6
+
+!***************************************************************************
+      subroutine cmbgb7
+!***************************************************************************
+!
+!     band 7:  980-1080 cm-1 (low key - h2o,o3; low minor - co2)
+!                            (high key - o3; high minor - co2)
+!
+! old band 7:  980-1080 cm-1 (low - h2o,o3; high - o3)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng7
+      use rrlw_kg07, only: fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, &
+                           selfrefo, forrefo, &
+                           fracrefa, fracrefb, absa, ka, absb, kb, ka_mco2, kb_mco2, &
+                           selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(7)
+                 sumk = 0.
+                  do ipr = 1, ngn(ngs(6)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+      do jt = 1,5
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(7)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(6)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jn = 1,9
+         do jt = 1,19
+            iprsm = 0
+            do igc = 1,ngc(7)
+              sumk = 0.
+               do ipr = 1, ngn(ngs(6)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+96)
+               enddo
+               ka_mco2(jn,jt,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,19
+         iprsm = 0
+         do igc = 1,ngc(7)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(6)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + kbo_mco2(jt,iprsm)*rwgt(iprsm+96)
+            enddo
+            kb_mco2(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(7)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(6)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(7)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(6)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(7)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(6)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + fracrefao(iprsm,jp)
+            enddo
+            fracrefa(igc,jp) = sumf
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(7)
+         sumf = 0.
+         do ipr = 1, ngn(ngs(6)+igc)
+            iprsm = iprsm + 1
+            sumf = sumf + fracrefbo(iprsm)
+         enddo
+         fracrefb(igc) = sumf
+      enddo
+
+      end subroutine cmbgb7
+
+!***************************************************************************
+      subroutine cmbgb8
+!***************************************************************************
+!
+!     band 8:  1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o)
+!                             (high key - o3; high minor - co2, n2o)
+!
+! old band 8:  1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng8
+      use rrlw_kg08, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, &
+                           kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, &
+                           cfc12o, cfc22adjo, &
+                           fracrefa, fracrefb, absa, ka, ka_mco2, ka_mn2o, &
+                           ka_mo3, absb, kb, kb_mco2, kb_mn2o, selfref, forref, &
+                           cfc12, cfc22adj
+
+! ------- Local -------
+      integer(kind=im) :: jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumk1, sumk2, sumk3, sumk4, sumk5, sumf1, sumf2
+
+
+      do jt = 1,5
+         do jp = 1,13
+            iprsm = 0
+            do igc = 1,ngc(8)
+              sumk = 0.
+               do ipr = 1, ngn(ngs(7)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
+               enddo
+               ka(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+      do jt = 1,5
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(8)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(7)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+112)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(8)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(7)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(8)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(7)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,19
+         iprsm = 0
+         do igc = 1,ngc(8)
+            sumk1 = 0.
+            sumk2 = 0.
+            sumk3 = 0.
+            sumk4 = 0.
+            sumk5 = 0.
+            do ipr = 1, ngn(ngs(7)+igc)
+               iprsm = iprsm + 1
+               sumk1 = sumk1 + kao_mco2(jt,iprsm)*rwgt(iprsm+112)
+               sumk2 = sumk2 + kbo_mco2(jt,iprsm)*rwgt(iprsm+112)
+               sumk3 = sumk3 + kao_mo3(jt,iprsm)*rwgt(iprsm+112)
+               sumk4 = sumk4 + kao_mn2o(jt,iprsm)*rwgt(iprsm+112)
+               sumk5 = sumk5 + kbo_mn2o(jt,iprsm)*rwgt(iprsm+112)
+            enddo
+            ka_mco2(jt,igc) = sumk1
+            kb_mco2(jt,igc) = sumk2
+            ka_mo3(jt,igc) = sumk3
+            ka_mn2o(jt,igc) = sumk4
+            kb_mn2o(jt,igc) = sumk5
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(8)
+         sumf1= 0.
+         sumf2= 0.
+         sumk1= 0.
+         sumk2= 0.
+         do ipr = 1, ngn(ngs(7)+igc)
+            iprsm = iprsm + 1
+            sumf1= sumf1+ fracrefao(iprsm)
+            sumf2= sumf2+ fracrefbo(iprsm)
+            sumk1= sumk1+ cfc12o(iprsm)*rwgt(iprsm+112)
+            sumk2= sumk2+ cfc22adjo(iprsm)*rwgt(iprsm+112)
+         enddo
+         fracrefa(igc) = sumf1
+         fracrefb(igc) = sumf2
+         cfc12(igc) = sumk1
+         cfc22adj(igc) = sumk2
+      enddo
+
+      end subroutine cmbgb8
+
+!***************************************************************************
+      subroutine cmbgb9
+!***************************************************************************
+!
+!     band 9:  1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o)
+!                             (high key - ch4; high minor - n2o)!
+
+! old band 9:  1180-1390 cm-1 (low - h2o,ch4; high - ch4)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng9
+      use rrlw_kg09, only: fracrefao, fracrefbo, kao, kao_mn2o, &
+                           kbo, kbo_mn2o, selfrefo, forrefo, &
+                           fracrefa, fracrefb, absa, ka, ka_mn2o, &
+                           absb, kb, kb_mn2o, selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(9)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(8)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,5
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(9)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(8)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jn = 1,9
+         do jt = 1,19
+            iprsm = 0
+            do igc = 1,ngc(9)
+              sumk = 0.
+               do ipr = 1, ngn(ngs(8)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+128)
+               enddo
+               ka_mn2o(jn,jt,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,19
+         iprsm = 0
+         do igc = 1,ngc(9)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(8)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + kbo_mn2o(jt,iprsm)*rwgt(iprsm+128)
+            enddo
+            kb_mn2o(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(9)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(8)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(9)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(8)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(9)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(8)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + fracrefao(iprsm,jp)
+            enddo
+            fracrefa(igc,jp) = sumf
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(9)
+         sumf = 0.
+         do ipr = 1, ngn(ngs(8)+igc)
+            iprsm = iprsm + 1
+            sumf = sumf + fracrefbo(iprsm)
+         enddo
+         fracrefb(igc) = sumf
+      enddo
+
+      end subroutine cmbgb9
+
+!***************************************************************************
+      subroutine cmbgb10
+!***************************************************************************
+!
+!     band 10:  1390-1480 cm-1 (low key - h2o; high key - h2o)
+!
+! old band 10:  1390-1480 cm-1 (low - h2o; high - h2o)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng10
+      use rrlw_kg10, only: fracrefao, fracrefbo, kao, kbo, &
+                           selfrefo, forrefo, &
+                           fracrefa, fracrefb, absa, ka, absb, kb, &
+                           selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumf1, sumf2
+
+
+      do jt = 1,5
+         do jp = 1,13
+            iprsm = 0
+            do igc = 1,ngc(10)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(9)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
+               enddo
+               ka(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,5
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(10)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(9)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+144)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(10)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(9)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+144)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(10)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(9)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+144)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(10)
+         sumf1= 0.
+         sumf2= 0.
+         do ipr = 1, ngn(ngs(9)+igc)
+            iprsm = iprsm + 1
+            sumf1= sumf1+ fracrefao(iprsm)
+            sumf2= sumf2+ fracrefbo(iprsm)
+         enddo
+         fracrefa(igc) = sumf1
+         fracrefb(igc) = sumf2
+      enddo
+
+      end subroutine cmbgb10
+
+!***************************************************************************
+      subroutine cmbgb11
+!***************************************************************************
+!
+!     band 11:  1480-1800 cm-1 (low - h2o; low minor - o2)
+!                              (high key - h2o; high minor - o2)
+!
+! old band 11:  1480-1800 cm-1 (low - h2o; low minor - o2)
+!                              (high key - h2o; high minor - o2)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng11
+      use rrlw_kg11, only: fracrefao, fracrefbo, kao, kao_mo2, &
+                           kbo, kbo_mo2, selfrefo, forrefo, &
+                           fracrefa, fracrefb, absa, ka, ka_mo2, &
+                           absb, kb, kb_mo2, selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumk1, sumk2, sumf1, sumf2
+
+
+      do jt = 1,5
+         do jp = 1,13
+            iprsm = 0
+            do igc = 1,ngc(11)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(10)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+160)
+               enddo
+               ka(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+      do jt = 1,5
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(11)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(10)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+160)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,19
+         iprsm = 0
+         do igc = 1,ngc(11)
+            sumk1 = 0.
+            sumk2 = 0.
+            do ipr = 1, ngn(ngs(10)+igc)
+               iprsm = iprsm + 1
+               sumk1 = sumk1 + kao_mo2(jt,iprsm)*rwgt(iprsm+160)
+               sumk2 = sumk2 + kbo_mo2(jt,iprsm)*rwgt(iprsm+160)
+            enddo
+            ka_mo2(jt,igc) = sumk1
+            kb_mo2(jt,igc) = sumk2
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(11)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(10)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+160)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(11)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(10)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+160)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(11)
+         sumf1= 0.
+         sumf2= 0.
+         do ipr = 1, ngn(ngs(10)+igc)
+            iprsm = iprsm + 1
+            sumf1= sumf1+ fracrefao(iprsm)
+            sumf2= sumf2+ fracrefbo(iprsm)
+         enddo
+         fracrefa(igc) = sumf1
+         fracrefb(igc) = sumf2
+      enddo
+
+      end subroutine cmbgb11
+
+!***************************************************************************
+      subroutine cmbgb12
+!***************************************************************************
+!
+!     band 12:  1800-2080 cm-1 (low - h2o,co2; high - nothing)
+!
+! old band 12:  1800-2080 cm-1 (low - h2o,co2; high - nothing)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng12
+      use rrlw_kg12, only: fracrefao, kao, selfrefo, forrefo, &
+                           fracrefa, absa, ka, selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(12)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(11)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+176)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(12)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(11)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+176)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(12)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(11)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+176)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(12)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(11)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + fracrefao(iprsm,jp)
+            enddo
+            fracrefa(igc,jp) = sumf
+         enddo
+      enddo
+
+      end subroutine cmbgb12
+
+!***************************************************************************
+      subroutine cmbgb13
+!***************************************************************************
+!
+!     band 13:  2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor)
+!
+! old band 13:  2080-2250 cm-1 (low - h2o,n2o; high - nothing)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng13
+      use rrlw_kg13, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mco, &
+                           kbo_mo3, selfrefo, forrefo, &
+                           fracrefa, fracrefb, absa, ka, ka_mco2, ka_mco, &
+                           kb_mo3, selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumk1, sumk2, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(13)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(12)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jn = 1,9
+         do jt = 1,19
+            iprsm = 0
+            do igc = 1,ngc(13)
+              sumk1 = 0.
+              sumk2 = 0.
+               do ipr = 1, ngn(ngs(12)+igc)
+                  iprsm = iprsm + 1
+                  sumk1 = sumk1 + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+192)
+                  sumk2 = sumk2 + kao_mco(jn,jt,iprsm)*rwgt(iprsm+192)
+               enddo
+               ka_mco2(jn,jt,igc) = sumk1
+               ka_mco(jn,jt,igc) = sumk2
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,19
+         iprsm = 0
+         do igc = 1,ngc(13)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(12)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + kbo_mo3(jt,iprsm)*rwgt(iprsm+192)
+            enddo
+            kb_mo3(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(13)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(12)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+192)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(13)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(12)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+192)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(13)
+         sumf = 0.
+         do ipr = 1, ngn(ngs(12)+igc)
+            iprsm = iprsm + 1
+            sumf = sumf + fracrefbo(iprsm)
+         enddo
+         fracrefb(igc) = sumf
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(13)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(12)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + fracrefao(iprsm,jp)
+            enddo
+            fracrefa(igc,jp) = sumf
+         enddo
+      enddo
+
+      end subroutine cmbgb13
+
+!***************************************************************************
+      subroutine cmbgb14
+!***************************************************************************
+!
+!     band 14:  2250-2380 cm-1 (low - co2; high - co2)
+!
+! old band 14:  2250-2380 cm-1 (low - co2; high - co2)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng14
+      use rrlw_kg14, only: fracrefao, fracrefbo, kao, kbo, &
+                           selfrefo, forrefo, &
+                           fracrefa, fracrefb, absa, ka, absb, kb, &
+                           selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumf1, sumf2
+
+
+      do jt = 1,5
+         do jp = 1,13
+            iprsm = 0
+            do igc = 1,ngc(14)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(13)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
+               enddo
+               ka(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,5
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(14)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(13)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(14)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(13)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(14)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(13)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(14)
+         sumf1= 0.
+         sumf2= 0.
+         do ipr = 1, ngn(ngs(13)+igc)
+            iprsm = iprsm + 1
+            sumf1= sumf1+ fracrefao(iprsm)
+            sumf2= sumf2+ fracrefbo(iprsm)
+         enddo
+         fracrefa(igc) = sumf1
+         fracrefb(igc) = sumf2
+      enddo
+
+      end subroutine cmbgb14
+
+!***************************************************************************
+      subroutine cmbgb15
+!***************************************************************************
+!
+!     band 15:  2380-2600 cm-1 (low - n2o,co2; low minor - n2)
+!                              (high - nothing)
+!
+! old band 15:  2380-2600 cm-1 (low - n2o,co2; high - nothing)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng15
+      use rrlw_kg15, only: fracrefao, kao, kao_mn2, selfrefo, forrefo, &
+                           fracrefa, absa, ka, ka_mn2, selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(15)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(14)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+224)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jn = 1,9
+         do jt = 1,19
+            iprsm = 0
+            do igc = 1,ngc(15)
+              sumk = 0.
+               do ipr = 1, ngn(ngs(14)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao_mn2(jn,jt,iprsm)*rwgt(iprsm+224)
+               enddo
+               ka_mn2(jn,jt,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(15)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(14)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+224)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(15)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(14)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+224)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(15)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(14)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + fracrefao(iprsm,jp)
+            enddo
+            fracrefa(igc,jp) = sumf
+         enddo
+      enddo
+
+      end subroutine cmbgb15
+
+!***************************************************************************
+      subroutine cmbgb16
+!***************************************************************************
+!
+!     band 16:  2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
+!
+! old band 16:  2600-3000 cm-1 (low - h2o,ch4; high - nothing)
+!***************************************************************************
+
+      use parrrtm, only : mg, nbndlw, ngptlw, ng16
+      use rrlw_kg16, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
+                           fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm 
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(16)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(15)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+240)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,5
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(16)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(15)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+240)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(16)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(15)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+240)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(16)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(15)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+240)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(16)
+         sumf = 0.
+         do ipr = 1, ngn(ngs(15)+igc)
+            iprsm = iprsm + 1
+            sumf = sumf + fracrefbo(iprsm)
+         enddo
+         fracrefb(igc) = sumf
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(16)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(15)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + fracrefao(iprsm,jp)
+            enddo
+            fracrefa(igc,jp) = sumf
+         enddo
+      enddo
+
+      end subroutine cmbgb16
+
+!***************************************************************************
+      subroutine lwcldpr
+!***************************************************************************
+
+! --------- Modules ----------
+
+      use rrlw_cld, only: abscld1, absliq0, absliq1, &
+                          absice0, absice1, absice2, absice3
+
+      save
+
+! ABSCLDn is the liquid water absorption coefficient (m2/g). 
+! For INFLAG = 1.
+      abscld1 = 0.0602410_rb
+!  
+! Everything below is for INFLAG = 2.
+
+! ABSICEn(J,IB) are the parameters needed to compute the liquid water 
+! absorption coefficient in spectral region IB for ICEFLAG=n.  The units
+! of ABSICEn(1,IB) are m2/g and ABSICEn(2,IB) has units (microns (m2/g)).
+! For ICEFLAG = 0.
+
+      absice0(:)= (/0.005_rb,  1.0_rb/)
+
+! For ICEFLAG = 1.
+      absice1(1,:) = (/0.0036_rb, 0.0068_rb, 0.0003_rb, 0.0016_rb, 0.0020_rb/)
+      absice1(2,:) = (/1.136_rb , 0.600_rb , 1.338_rb , 1.166_rb , 1.118_rb /)
+
+! For ICEFLAG = 2.  In each band, the absorption
+! coefficients are listed for a range of effective radii from 5.0
+! to 131.0 microns in increments of 3.0 microns.
+! Spherical Ice Particle Parameterization
+! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)]
+      absice2(:,1) = (/ &
+! band 1
+       7.798999e-02_rb,6.340479e-02_rb,5.417973e-02_rb,4.766245e-02_rb,4.272663e-02_rb, &
+       3.880939e-02_rb,3.559544e-02_rb,3.289241e-02_rb,3.057511e-02_rb,2.855800e-02_rb, &
+       2.678022e-02_rb,2.519712e-02_rb,2.377505e-02_rb,2.248806e-02_rb,2.131578e-02_rb, &
+       2.024194e-02_rb,1.925337e-02_rb,1.833926e-02_rb,1.749067e-02_rb,1.670007e-02_rb, &
+       1.596113e-02_rb,1.526845e-02_rb,1.461739e-02_rb,1.400394e-02_rb,1.342462e-02_rb, &
+       1.287639e-02_rb,1.235656e-02_rb,1.186279e-02_rb,1.139297e-02_rb,1.094524e-02_rb, &
+       1.051794e-02_rb,1.010956e-02_rb,9.718755e-03_rb,9.344316e-03_rb,8.985139e-03_rb, &
+       8.640223e-03_rb,8.308656e-03_rb,7.989606e-03_rb,7.682312e-03_rb,7.386076e-03_rb, &
+       7.100255e-03_rb,6.824258e-03_rb,6.557540e-03_rb/)
+      absice2(:,2) = (/ &
+! band 2
+       2.784879e-02_rb,2.709863e-02_rb,2.619165e-02_rb,2.529230e-02_rb,2.443225e-02_rb, &
+       2.361575e-02_rb,2.284021e-02_rb,2.210150e-02_rb,2.139548e-02_rb,2.071840e-02_rb, &
+       2.006702e-02_rb,1.943856e-02_rb,1.883064e-02_rb,1.824120e-02_rb,1.766849e-02_rb, &
+       1.711099e-02_rb,1.656737e-02_rb,1.603647e-02_rb,1.551727e-02_rb,1.500886e-02_rb, &
+       1.451045e-02_rb,1.402132e-02_rb,1.354084e-02_rb,1.306842e-02_rb,1.260355e-02_rb, &
+       1.214575e-02_rb,1.169460e-02_rb,1.124971e-02_rb,1.081072e-02_rb,1.037731e-02_rb, &
+       9.949167e-03_rb,9.526021e-03_rb,9.107615e-03_rb,8.693714e-03_rb,8.284096e-03_rb, &
+       7.878558e-03_rb,7.476910e-03_rb,7.078974e-03_rb,6.684586e-03_rb,6.293589e-03_rb, &
+       5.905839e-03_rb,5.521200e-03_rb,5.139543e-03_rb/)
+      absice2(:,3) = (/ &
+! band 3
+       1.065397e-01_rb,8.005726e-02_rb,6.546428e-02_rb,5.589131e-02_rb,4.898681e-02_rb, &
+       4.369932e-02_rb,3.947901e-02_rb,3.600676e-02_rb,3.308299e-02_rb,3.057561e-02_rb, &
+       2.839325e-02_rb,2.647040e-02_rb,2.475872e-02_rb,2.322164e-02_rb,2.183091e-02_rb, &
+       2.056430e-02_rb,1.940407e-02_rb,1.833586e-02_rb,1.734787e-02_rb,1.643034e-02_rb, &
+       1.557512e-02_rb,1.477530e-02_rb,1.402501e-02_rb,1.331924e-02_rb,1.265364e-02_rb, &
+       1.202445e-02_rb,1.142838e-02_rb,1.086257e-02_rb,1.032445e-02_rb,9.811791e-03_rb, &
+       9.322587e-03_rb,8.855053e-03_rb,8.407591e-03_rb,7.978763e-03_rb,7.567273e-03_rb, &
+       7.171949e-03_rb,6.791728e-03_rb,6.425642e-03_rb,6.072809e-03_rb,5.732424e-03_rb, &
+       5.403748e-03_rb,5.086103e-03_rb,4.778865e-03_rb/)
+      absice2(:,4) = (/ &
+! band 4
+       1.804566e-01_rb,1.168987e-01_rb,8.680442e-02_rb,6.910060e-02_rb,5.738174e-02_rb, &
+       4.902332e-02_rb,4.274585e-02_rb,3.784923e-02_rb,3.391734e-02_rb,3.068690e-02_rb, &
+       2.798301e-02_rb,2.568480e-02_rb,2.370600e-02_rb,2.198337e-02_rb,2.046940e-02_rb, &
+       1.912777e-02_rb,1.793016e-02_rb,1.685420e-02_rb,1.588193e-02_rb,1.499882e-02_rb, &
+       1.419293e-02_rb,1.345440e-02_rb,1.277496e-02_rb,1.214769e-02_rb,1.156669e-02_rb, &
+       1.102694e-02_rb,1.052412e-02_rb,1.005451e-02_rb,9.614854e-03_rb,9.202335e-03_rb, &
+       8.814470e-03_rb,8.449077e-03_rb,8.104223e-03_rb,7.778195e-03_rb,7.469466e-03_rb, &
+       7.176671e-03_rb,6.898588e-03_rb,6.634117e-03_rb,6.382264e-03_rb,6.142134e-03_rb, &
+       5.912913e-03_rb,5.693862e-03_rb,5.484308e-03_rb/)
+      absice2(:,5) = (/ &
+! band 5
+       2.131806e-01_rb,1.311372e-01_rb,9.407171e-02_rb,7.299442e-02_rb,5.941273e-02_rb, &
+       4.994043e-02_rb,4.296242e-02_rb,3.761113e-02_rb,3.337910e-02_rb,2.994978e-02_rb, &
+       2.711556e-02_rb,2.473461e-02_rb,2.270681e-02_rb,2.095943e-02_rb,1.943839e-02_rb, &
+       1.810267e-02_rb,1.692057e-02_rb,1.586719e-02_rb,1.492275e-02_rb,1.407132e-02_rb, &
+       1.329989e-02_rb,1.259780e-02_rb,1.195618e-02_rb,1.136761e-02_rb,1.082583e-02_rb, &
+       1.032552e-02_rb,9.862158e-03_rb,9.431827e-03_rb,9.031157e-03_rb,8.657217e-03_rb, &
+       8.307449e-03_rb,7.979609e-03_rb,7.671724e-03_rb,7.382048e-03_rb,7.109032e-03_rb, &
+       6.851298e-03_rb,6.607615e-03_rb,6.376881e-03_rb,6.158105e-03_rb,5.950394e-03_rb, &
+       5.752942e-03_rb,5.565019e-03_rb,5.385963e-03_rb/)
+      absice2(:,6) = (/ &
+! band 6
+       1.546177e-01_rb,1.039251e-01_rb,7.910347e-02_rb,6.412429e-02_rb,5.399997e-02_rb, &
+       4.664937e-02_rb,4.104237e-02_rb,3.660781e-02_rb,3.300218e-02_rb,3.000586e-02_rb, &
+       2.747148e-02_rb,2.529633e-02_rb,2.340647e-02_rb,2.174723e-02_rb,2.027731e-02_rb, &
+       1.896487e-02_rb,1.778492e-02_rb,1.671761e-02_rb,1.574692e-02_rb,1.485978e-02_rb, &
+       1.404543e-02_rb,1.329489e-02_rb,1.260066e-02_rb,1.195636e-02_rb,1.135657e-02_rb, &
+       1.079664e-02_rb,1.027257e-02_rb,9.780871e-03_rb,9.318505e-03_rb,8.882815e-03_rb, &
+       8.471458e-03_rb,8.082364e-03_rb,7.713696e-03_rb,7.363817e-03_rb,7.031264e-03_rb, &
+       6.714725e-03_rb,6.413021e-03_rb,6.125086e-03_rb,5.849958e-03_rb,5.586764e-03_rb, &
+       5.334707e-03_rb,5.093066e-03_rb,4.861179e-03_rb/)
+      absice2(:,7) = (/ &
+! band 7
+       7.583404e-02_rb,6.181558e-02_rb,5.312027e-02_rb,4.696039e-02_rb,4.225986e-02_rb, &
+       3.849735e-02_rb,3.538340e-02_rb,3.274182e-02_rb,3.045798e-02_rb,2.845343e-02_rb, &
+       2.667231e-02_rb,2.507353e-02_rb,2.362606e-02_rb,2.230595e-02_rb,2.109435e-02_rb, &
+       1.997617e-02_rb,1.893916e-02_rb,1.797328e-02_rb,1.707016e-02_rb,1.622279e-02_rb, &
+       1.542523e-02_rb,1.467241e-02_rb,1.395997e-02_rb,1.328414e-02_rb,1.264164e-02_rb, &
+       1.202958e-02_rb,1.144544e-02_rb,1.088697e-02_rb,1.035218e-02_rb,9.839297e-03_rb, &
+       9.346733e-03_rb,8.873057e-03_rb,8.416980e-03_rb,7.977335e-03_rb,7.553066e-03_rb, &
+       7.143210e-03_rb,6.746888e-03_rb,6.363297e-03_rb,5.991700e-03_rb,5.631422e-03_rb, &
+       5.281840e-03_rb,4.942378e-03_rb,4.612505e-03_rb/)
+      absice2(:,8) = (/ &
+! band 8
+       9.022185e-02_rb,6.922700e-02_rb,5.710674e-02_rb,4.898377e-02_rb,4.305946e-02_rb, &
+       3.849553e-02_rb,3.484183e-02_rb,3.183220e-02_rb,2.929794e-02_rb,2.712627e-02_rb, &
+       2.523856e-02_rb,2.357810e-02_rb,2.210286e-02_rb,2.078089e-02_rb,1.958747e-02_rb, &
+       1.850310e-02_rb,1.751218e-02_rb,1.660205e-02_rb,1.576232e-02_rb,1.498440e-02_rb, &
+       1.426107e-02_rb,1.358624e-02_rb,1.295474e-02_rb,1.236212e-02_rb,1.180456e-02_rb, &
+       1.127874e-02_rb,1.078175e-02_rb,1.031106e-02_rb,9.864433e-03_rb,9.439878e-03_rb, &
+       9.035637e-03_rb,8.650140e-03_rb,8.281981e-03_rb,7.929895e-03_rb,7.592746e-03_rb, &
+       7.269505e-03_rb,6.959238e-03_rb,6.661100e-03_rb,6.374317e-03_rb,6.098185e-03_rb, &
+       5.832059e-03_rb,5.575347e-03_rb,5.327504e-03_rb/)
+      absice2(:,9) = (/ &
+! band 9
+       1.294087e-01_rb,8.788217e-02_rb,6.728288e-02_rb,5.479720e-02_rb,4.635049e-02_rb, &
+       4.022253e-02_rb,3.555576e-02_rb,3.187259e-02_rb,2.888498e-02_rb,2.640843e-02_rb, &
+       2.431904e-02_rb,2.253038e-02_rb,2.098024e-02_rb,1.962267e-02_rb,1.842293e-02_rb, &
+       1.735426e-02_rb,1.639571e-02_rb,1.553060e-02_rb,1.474552e-02_rb,1.402953e-02_rb, &
+       1.337363e-02_rb,1.277033e-02_rb,1.221336e-02_rb,1.169741e-02_rb,1.121797e-02_rb, &
+       1.077117e-02_rb,1.035369e-02_rb,9.962643e-03_rb,9.595509e-03_rb,9.250088e-03_rb, &
+       8.924447e-03_rb,8.616876e-03_rb,8.325862e-03_rb,8.050057e-03_rb,7.788258e-03_rb, &
+       7.539388e-03_rb,7.302478e-03_rb,7.076656e-03_rb,6.861134e-03_rb,6.655197e-03_rb, &
+       6.458197e-03_rb,6.269543e-03_rb,6.088697e-03_rb/)
+      absice2(:,10) = (/ &
+! band 10
+       1.593628e-01_rb,1.014552e-01_rb,7.458955e-02_rb,5.903571e-02_rb,4.887582e-02_rb, &
+       4.171159e-02_rb,3.638480e-02_rb,3.226692e-02_rb,2.898717e-02_rb,2.631256e-02_rb, &
+       2.408925e-02_rb,2.221156e-02_rb,2.060448e-02_rb,1.921325e-02_rb,1.799699e-02_rb, &
+       1.692456e-02_rb,1.597177e-02_rb,1.511961e-02_rb,1.435289e-02_rb,1.365933e-02_rb, &
+       1.302890e-02_rb,1.245334e-02_rb,1.192576e-02_rb,1.144037e-02_rb,1.099230e-02_rb, &
+       1.057739e-02_rb,1.019208e-02_rb,9.833302e-03_rb,9.498395e-03_rb,9.185047e-03_rb, &
+       8.891237e-03_rb,8.615185e-03_rb,8.355325e-03_rb,8.110267e-03_rb,7.878778e-03_rb, &
+       7.659759e-03_rb,7.452224e-03_rb,7.255291e-03_rb,7.068166e-03_rb,6.890130e-03_rb, &
+       6.720536e-03_rb,6.558794e-03_rb,6.404371e-03_rb/)
+      absice2(:,11) = (/ &
+! band 11
+       1.656227e-01_rb,1.032129e-01_rb,7.487359e-02_rb,5.871431e-02_rb,4.828355e-02_rb, &
+       4.099989e-02_rb,3.562924e-02_rb,3.150755e-02_rb,2.824593e-02_rb,2.560156e-02_rb, &
+       2.341503e-02_rb,2.157740e-02_rb,2.001169e-02_rb,1.866199e-02_rb,1.748669e-02_rb, &
+       1.645421e-02_rb,1.554015e-02_rb,1.472535e-02_rb,1.399457e-02_rb,1.333553e-02_rb, &
+       1.273821e-02_rb,1.219440e-02_rb,1.169725e-02_rb,1.124104e-02_rb,1.082096e-02_rb, &
+       1.043290e-02_rb,1.007336e-02_rb,9.739338e-03_rb,9.428223e-03_rb,9.137756e-03_rb, &
+       8.865964e-03_rb,8.611115e-03_rb,8.371686e-03_rb,8.146330e-03_rb,7.933852e-03_rb, &
+       7.733187e-03_rb,7.543386e-03_rb,7.363597e-03_rb,7.193056e-03_rb,7.031072e-03_rb, &
+       6.877024e-03_rb,6.730348e-03_rb,6.590531e-03_rb/)
+      absice2(:,12) = (/ &
+! band 12
+       9.194591e-02_rb,6.446867e-02_rb,4.962034e-02_rb,4.042061e-02_rb,3.418456e-02_rb, &
+       2.968856e-02_rb,2.629900e-02_rb,2.365572e-02_rb,2.153915e-02_rb,1.980791e-02_rb, &
+       1.836689e-02_rb,1.714979e-02_rb,1.610900e-02_rb,1.520946e-02_rb,1.442476e-02_rb, &
+       1.373468e-02_rb,1.312345e-02_rb,1.257858e-02_rb,1.209010e-02_rb,1.164990e-02_rb, &
+       1.125136e-02_rb,1.088901e-02_rb,1.055827e-02_rb,1.025531e-02_rb,9.976896e-03_rb, &
+       9.720255e-03_rb,9.483022e-03_rb,9.263160e-03_rb,9.058902e-03_rb,8.868710e-03_rb, &
+       8.691240e-03_rb,8.525312e-03_rb,8.369886e-03_rb,8.224042e-03_rb,8.086961e-03_rb, &
+       7.957917e-03_rb,7.836258e-03_rb,7.721400e-03_rb,7.612821e-03_rb,7.510045e-03_rb, &
+       7.412648e-03_rb,7.320242e-03_rb,7.232476e-03_rb/)
+      absice2(:,13) = (/ &
+! band 13
+       1.437021e-01_rb,8.872535e-02_rb,6.392420e-02_rb,4.991833e-02_rb,4.096790e-02_rb, &
+       3.477881e-02_rb,3.025782e-02_rb,2.681909e-02_rb,2.412102e-02_rb,2.195132e-02_rb, &
+       2.017124e-02_rb,1.868641e-02_rb,1.743044e-02_rb,1.635529e-02_rb,1.542540e-02_rb, &
+       1.461388e-02_rb,1.390003e-02_rb,1.326766e-02_rb,1.270395e-02_rb,1.219860e-02_rb, &
+       1.174326e-02_rb,1.133107e-02_rb,1.095637e-02_rb,1.061442e-02_rb,1.030126e-02_rb, &
+       1.001352e-02_rb,9.748340e-03_rb,9.503256e-03_rb,9.276155e-03_rb,9.065205e-03_rb, &
+       8.868808e-03_rb,8.685571e-03_rb,8.514268e-03_rb,8.353820e-03_rb,8.203272e-03_rb, &
+       8.061776e-03_rb,7.928578e-03_rb,7.803001e-03_rb,7.684443e-03_rb,7.572358e-03_rb, &
+       7.466258e-03_rb,7.365701e-03_rb,7.270286e-03_rb/)
+      absice2(:,14) = (/ &
+! band 14
+       1.288870e-01_rb,8.160295e-02_rb,5.964745e-02_rb,4.703790e-02_rb,3.888637e-02_rb, &
+       3.320115e-02_rb,2.902017e-02_rb,2.582259e-02_rb,2.330224e-02_rb,2.126754e-02_rb, &
+       1.959258e-02_rb,1.819130e-02_rb,1.700289e-02_rb,1.598320e-02_rb,1.509942e-02_rb, &
+       1.432666e-02_rb,1.364572e-02_rb,1.304156e-02_rb,1.250220e-02_rb,1.201803e-02_rb, &
+       1.158123e-02_rb,1.118537e-02_rb,1.082513e-02_rb,1.049605e-02_rb,1.019440e-02_rb, &
+       9.916989e-03_rb,9.661116e-03_rb,9.424457e-03_rb,9.205005e-03_rb,9.001022e-03_rb, &
+       8.810992e-03_rb,8.633588e-03_rb,8.467646e-03_rb,8.312137e-03_rb,8.166151e-03_rb, &
+       8.028878e-03_rb,7.899597e-03_rb,7.777663e-03_rb,7.662498e-03_rb,7.553581e-03_rb, &
+       7.450444e-03_rb,7.352662e-03_rb,7.259851e-03_rb/)
+      absice2(:,15) = (/ &
+! band 15
+       8.254229e-02_rb,5.808787e-02_rb,4.492166e-02_rb,3.675028e-02_rb,3.119623e-02_rb, &
+       2.718045e-02_rb,2.414450e-02_rb,2.177073e-02_rb,1.986526e-02_rb,1.830306e-02_rb, &
+       1.699991e-02_rb,1.589698e-02_rb,1.495199e-02_rb,1.413374e-02_rb,1.341870e-02_rb, &
+       1.278883e-02_rb,1.223002e-02_rb,1.173114e-02_rb,1.128322e-02_rb,1.087900e-02_rb, &
+       1.051254e-02_rb,1.017890e-02_rb,9.873991e-03_rb,9.594347e-03_rb,9.337044e-03_rb, &
+       9.099589e-03_rb,8.879842e-03_rb,8.675960e-03_rb,8.486341e-03_rb,8.309594e-03_rb, &
+       8.144500e-03_rb,7.989986e-03_rb,7.845109e-03_rb,7.709031e-03_rb,7.581007e-03_rb, &
+       7.460376e-03_rb,7.346544e-03_rb,7.238978e-03_rb,7.137201e-03_rb,7.040780e-03_rb, &
+       6.949325e-03_rb,6.862483e-03_rb,6.779931e-03_rb/)
+      absice2(:,16) = (/ &
+! band 16
+       1.382062e-01_rb,8.643227e-02_rb,6.282935e-02_rb,4.934783e-02_rb,4.063891e-02_rb, &
+       3.455591e-02_rb,3.007059e-02_rb,2.662897e-02_rb,2.390631e-02_rb,2.169972e-02_rb, &
+       1.987596e-02_rb,1.834393e-02_rb,1.703924e-02_rb,1.591513e-02_rb,1.493679e-02_rb, &
+       1.407780e-02_rb,1.331775e-02_rb,1.264061e-02_rb,1.203364e-02_rb,1.148655e-02_rb, &
+       1.099099e-02_rb,1.054006e-02_rb,1.012807e-02_rb,9.750215e-03_rb,9.402477e-03_rb, &
+       9.081428e-03_rb,8.784143e-03_rb,8.508107e-03_rb,8.251146e-03_rb,8.011373e-03_rb, &
+       7.787140e-03_rb,7.577002e-03_rb,7.379687e-03_rb,7.194071e-03_rb,7.019158e-03_rb, &
+       6.854061e-03_rb,6.697986e-03_rb,6.550224e-03_rb,6.410138e-03_rb,6.277153e-03_rb, &
+       6.150751e-03_rb,6.030462e-03_rb,5.915860e-03_rb/)
+
+! ICEFLAG = 3; Fu parameterization. Particle size 5 - 140 micron in 
+! increments of 3 microns.
+! units = m2/g
+! Hexagonal Ice Particle Parameterization
+! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)]
+      absice3(:,1) = (/ &
+! band 1
+       3.110649e-03_rb,4.666352e-02_rb,6.606447e-02_rb,6.531678e-02_rb,6.012598e-02_rb, &
+       5.437494e-02_rb,4.906411e-02_rb,4.441146e-02_rb,4.040585e-02_rb,3.697334e-02_rb, &
+       3.403027e-02_rb,3.149979e-02_rb,2.931596e-02_rb,2.742365e-02_rb,2.577721e-02_rb, &
+       2.433888e-02_rb,2.307732e-02_rb,2.196644e-02_rb,2.098437e-02_rb,2.011264e-02_rb, &
+       1.933561e-02_rb,1.863992e-02_rb,1.801407e-02_rb,1.744812e-02_rb,1.693346e-02_rb, &
+       1.646252e-02_rb,1.602866e-02_rb,1.562600e-02_rb,1.524933e-02_rb,1.489399e-02_rb, &
+       1.455580e-02_rb,1.423098e-02_rb,1.391612e-02_rb,1.360812e-02_rb,1.330413e-02_rb, &
+       1.300156e-02_rb,1.269801e-02_rb,1.239127e-02_rb,1.207928e-02_rb,1.176014e-02_rb, &
+       1.143204e-02_rb,1.109334e-02_rb,1.074243e-02_rb,1.037786e-02_rb,9.998198e-03_rb, &
+       9.602126e-03_rb/)
+      absice3(:,2) = (/ &
+! band 2
+       3.984966e-04_rb,1.681097e-02_rb,2.627680e-02_rb,2.767465e-02_rb,2.700722e-02_rb, &
+       2.579180e-02_rb,2.448677e-02_rb,2.323890e-02_rb,2.209096e-02_rb,2.104882e-02_rb, &
+       2.010547e-02_rb,1.925003e-02_rb,1.847128e-02_rb,1.775883e-02_rb,1.710358e-02_rb, &
+       1.649769e-02_rb,1.593449e-02_rb,1.540829e-02_rb,1.491429e-02_rb,1.444837e-02_rb, &
+       1.400704e-02_rb,1.358729e-02_rb,1.318654e-02_rb,1.280258e-02_rb,1.243346e-02_rb, &
+       1.207750e-02_rb,1.173325e-02_rb,1.139941e-02_rb,1.107487e-02_rb,1.075861e-02_rb, &
+       1.044975e-02_rb,1.014753e-02_rb,9.851229e-03_rb,9.560240e-03_rb,9.274003e-03_rb, &
+       8.992020e-03_rb,8.713845e-03_rb,8.439074e-03_rb,8.167346e-03_rb,7.898331e-03_rb, &
+       7.631734e-03_rb,7.367286e-03_rb,7.104742e-03_rb,6.843882e-03_rb,6.584504e-03_rb, &
+       6.326424e-03_rb/)
+      absice3(:,3) = (/ &
+! band 3
+       6.933163e-02_rb,8.540475e-02_rb,7.701816e-02_rb,6.771158e-02_rb,5.986953e-02_rb, &
+       5.348120e-02_rb,4.824962e-02_rb,4.390563e-02_rb,4.024411e-02_rb,3.711404e-02_rb, &
+       3.440426e-02_rb,3.203200e-02_rb,2.993478e-02_rb,2.806474e-02_rb,2.638464e-02_rb, &
+       2.486516e-02_rb,2.348288e-02_rb,2.221890e-02_rb,2.105780e-02_rb,1.998687e-02_rb, &
+       1.899552e-02_rb,1.807490e-02_rb,1.721750e-02_rb,1.641693e-02_rb,1.566773e-02_rb, &
+       1.496515e-02_rb,1.430509e-02_rb,1.368398e-02_rb,1.309865e-02_rb,1.254634e-02_rb, &
+       1.202456e-02_rb,1.153114e-02_rb,1.106409e-02_rb,1.062166e-02_rb,1.020224e-02_rb, &
+       9.804381e-03_rb,9.426771e-03_rb,9.068205e-03_rb,8.727578e-03_rb,8.403876e-03_rb, &
+       8.096160e-03_rb,7.803564e-03_rb,7.525281e-03_rb,7.260560e-03_rb,7.008697e-03_rb, &
+       6.769036e-03_rb/)
+      absice3(:,4) = (/ &
+! band 4
+       1.765735e-01_rb,1.382700e-01_rb,1.095129e-01_rb,8.987475e-02_rb,7.591185e-02_rb, &
+       6.554169e-02_rb,5.755500e-02_rb,5.122083e-02_rb,4.607610e-02_rb,4.181475e-02_rb, &
+       3.822697e-02_rb,3.516432e-02_rb,3.251897e-02_rb,3.021073e-02_rb,2.817876e-02_rb, &
+       2.637607e-02_rb,2.476582e-02_rb,2.331871e-02_rb,2.201113e-02_rb,2.082388e-02_rb, &
+       1.974115e-02_rb,1.874983e-02_rb,1.783894e-02_rb,1.699922e-02_rb,1.622280e-02_rb, &
+       1.550296e-02_rb,1.483390e-02_rb,1.421064e-02_rb,1.362880e-02_rb,1.308460e-02_rb, &
+       1.257468e-02_rb,1.209611e-02_rb,1.164628e-02_rb,1.122287e-02_rb,1.082381e-02_rb, &
+       1.044725e-02_rb,1.009154e-02_rb,9.755166e-03_rb,9.436783e-03_rb,9.135163e-03_rb, &
+       8.849193e-03_rb,8.577856e-03_rb,8.320225e-03_rb,8.075451e-03_rb,7.842755e-03_rb, &
+       7.621418e-03_rb/)
+      absice3(:,5) = (/ &
+! band 5
+       2.339673e-01_rb,1.692124e-01_rb,1.291656e-01_rb,1.033837e-01_rb,8.562949e-02_rb, &
+       7.273526e-02_rb,6.298262e-02_rb,5.537015e-02_rb,4.927787e-02_rb,4.430246e-02_rb, &
+       4.017061e-02_rb,3.669072e-02_rb,3.372455e-02_rb,3.116995e-02_rb,2.894977e-02_rb, &
+       2.700471e-02_rb,2.528842e-02_rb,2.376420e-02_rb,2.240256e-02_rb,2.117959e-02_rb, &
+       2.007567e-02_rb,1.907456e-02_rb,1.816271e-02_rb,1.732874e-02_rb,1.656300e-02_rb, &
+       1.585725e-02_rb,1.520445e-02_rb,1.459852e-02_rb,1.403419e-02_rb,1.350689e-02_rb, &
+       1.301260e-02_rb,1.254781e-02_rb,1.210941e-02_rb,1.169468e-02_rb,1.130118e-02_rb, &
+       1.092675e-02_rb,1.056945e-02_rb,1.022757e-02_rb,9.899560e-03_rb,9.584021e-03_rb, &
+       9.279705e-03_rb,8.985479e-03_rb,8.700322e-03_rb,8.423306e-03_rb,8.153590e-03_rb, &
+       7.890412e-03_rb/)
+      absice3(:,6) = (/ &
+! band 6
+       1.145369e-01_rb,1.174566e-01_rb,9.917866e-02_rb,8.332990e-02_rb,7.104263e-02_rb, &
+       6.153370e-02_rb,5.405472e-02_rb,4.806281e-02_rb,4.317918e-02_rb,3.913795e-02_rb, &
+       3.574916e-02_rb,3.287437e-02_rb,3.041067e-02_rb,2.828017e-02_rb,2.642292e-02_rb, &
+       2.479206e-02_rb,2.335051e-02_rb,2.206851e-02_rb,2.092195e-02_rb,1.989108e-02_rb, &
+       1.895958e-02_rb,1.811385e-02_rb,1.734245e-02_rb,1.663573e-02_rb,1.598545e-02_rb, &
+       1.538456e-02_rb,1.482700e-02_rb,1.430750e-02_rb,1.382150e-02_rb,1.336499e-02_rb, &
+       1.293447e-02_rb,1.252685e-02_rb,1.213939e-02_rb,1.176968e-02_rb,1.141555e-02_rb, &
+       1.107508e-02_rb,1.074655e-02_rb,1.042839e-02_rb,1.011923e-02_rb,9.817799e-03_rb, &
+       9.522962e-03_rb,9.233688e-03_rb,8.949041e-03_rb,8.668171e-03_rb,8.390301e-03_rb, &
+       8.114723e-03_rb/)
+      absice3(:,7) = (/ &
+! band 7
+       1.222345e-02_rb,5.344230e-02_rb,5.523465e-02_rb,5.128759e-02_rb,4.676925e-02_rb, &
+       4.266150e-02_rb,3.910561e-02_rb,3.605479e-02_rb,3.342843e-02_rb,3.115052e-02_rb, &
+       2.915776e-02_rb,2.739935e-02_rb,2.583499e-02_rb,2.443266e-02_rb,2.316681e-02_rb, &
+       2.201687e-02_rb,2.096619e-02_rb,2.000112e-02_rb,1.911044e-02_rb,1.828481e-02_rb, &
+       1.751641e-02_rb,1.679866e-02_rb,1.612598e-02_rb,1.549360e-02_rb,1.489742e-02_rb, &
+       1.433392e-02_rb,1.380002e-02_rb,1.329305e-02_rb,1.281068e-02_rb,1.235084e-02_rb, &
+       1.191172e-02_rb,1.149171e-02_rb,1.108936e-02_rb,1.070341e-02_rb,1.033271e-02_rb, &
+       9.976220e-03_rb,9.633021e-03_rb,9.302273e-03_rb,8.983216e-03_rb,8.675161e-03_rb, &
+       8.377478e-03_rb,8.089595e-03_rb,7.810986e-03_rb,7.541170e-03_rb,7.279706e-03_rb, &
+       7.026186e-03_rb/)
+      absice3(:,8) = (/ &
+! band 8
+       6.711058e-02_rb,6.918198e-02_rb,6.127484e-02_rb,5.411944e-02_rb,4.836902e-02_rb, &
+       4.375293e-02_rb,3.998077e-02_rb,3.683587e-02_rb,3.416508e-02_rb,3.186003e-02_rb, &
+       2.984290e-02_rb,2.805671e-02_rb,2.645895e-02_rb,2.501733e-02_rb,2.370689e-02_rb, &
+       2.250808e-02_rb,2.140532e-02_rb,2.038609e-02_rb,1.944018e-02_rb,1.855918e-02_rb, &
+       1.773609e-02_rb,1.696504e-02_rb,1.624106e-02_rb,1.555990e-02_rb,1.491793e-02_rb, &
+       1.431197e-02_rb,1.373928e-02_rb,1.319743e-02_rb,1.268430e-02_rb,1.219799e-02_rb, &
+       1.173682e-02_rb,1.129925e-02_rb,1.088393e-02_rb,1.048961e-02_rb,1.011516e-02_rb, &
+       9.759543e-03_rb,9.421813e-03_rb,9.101089e-03_rb,8.796559e-03_rb,8.507464e-03_rb, &
+       8.233098e-03_rb,7.972798e-03_rb,7.725942e-03_rb,7.491940e-03_rb,7.270238e-03_rb, &
+       7.060305e-03_rb/)
+      absice3(:,9) = (/ &
+! band 9
+       1.236780e-01_rb,9.222386e-02_rb,7.383997e-02_rb,6.204072e-02_rb,5.381029e-02_rb, &
+       4.770678e-02_rb,4.296928e-02_rb,3.916131e-02_rb,3.601540e-02_rb,3.335878e-02_rb, &
+       3.107493e-02_rb,2.908247e-02_rb,2.732282e-02_rb,2.575276e-02_rb,2.433968e-02_rb, &
+       2.305852e-02_rb,2.188966e-02_rb,2.081757e-02_rb,1.982974e-02_rb,1.891599e-02_rb, &
+       1.806794e-02_rb,1.727865e-02_rb,1.654227e-02_rb,1.585387e-02_rb,1.520924e-02_rb, &
+       1.460476e-02_rb,1.403730e-02_rb,1.350416e-02_rb,1.300293e-02_rb,1.253153e-02_rb, &
+       1.208808e-02_rb,1.167094e-02_rb,1.127862e-02_rb,1.090979e-02_rb,1.056323e-02_rb, &
+       1.023786e-02_rb,9.932665e-03_rb,9.646744e-03_rb,9.379250e-03_rb,9.129409e-03_rb, &
+       8.896500e-03_rb,8.679856e-03_rb,8.478852e-03_rb,8.292904e-03_rb,8.121463e-03_rb, &
+       7.964013e-03_rb/)
+      absice3(:,10) = (/ &
+! band 10
+       1.655966e-01_rb,1.134205e-01_rb,8.714344e-02_rb,7.129241e-02_rb,6.063739e-02_rb, &
+       5.294203e-02_rb,4.709309e-02_rb,4.247476e-02_rb,3.871892e-02_rb,3.559206e-02_rb, &
+       3.293893e-02_rb,3.065226e-02_rb,2.865558e-02_rb,2.689288e-02_rb,2.532221e-02_rb, &
+       2.391150e-02_rb,2.263582e-02_rb,2.147549e-02_rb,2.041476e-02_rb,1.944089e-02_rb, &
+       1.854342e-02_rb,1.771371e-02_rb,1.694456e-02_rb,1.622989e-02_rb,1.556456e-02_rb, &
+       1.494415e-02_rb,1.436491e-02_rb,1.382354e-02_rb,1.331719e-02_rb,1.284339e-02_rb, &
+       1.239992e-02_rb,1.198486e-02_rb,1.159647e-02_rb,1.123323e-02_rb,1.089375e-02_rb, &
+       1.057679e-02_rb,1.028124e-02_rb,1.000607e-02_rb,9.750376e-03_rb,9.513303e-03_rb, &
+       9.294082e-03_rb,9.092003e-03_rb,8.906412e-03_rb,8.736702e-03_rb,8.582314e-03_rb, &
+       8.442725e-03_rb/)
+      absice3(:,11) = (/ &
+! band 11
+       1.775615e-01_rb,1.180046e-01_rb,8.929607e-02_rb,7.233500e-02_rb,6.108333e-02_rb, &
+       5.303642e-02_rb,4.696927e-02_rb,4.221206e-02_rb,3.836768e-02_rb,3.518576e-02_rb, &
+       3.250063e-02_rb,3.019825e-02_rb,2.819758e-02_rb,2.643943e-02_rb,2.487953e-02_rb, &
+       2.348414e-02_rb,2.222705e-02_rb,2.108762e-02_rb,2.004936e-02_rb,1.909892e-02_rb, &
+       1.822539e-02_rb,1.741975e-02_rb,1.667449e-02_rb,1.598330e-02_rb,1.534084e-02_rb, &
+       1.474253e-02_rb,1.418446e-02_rb,1.366325e-02_rb,1.317597e-02_rb,1.272004e-02_rb, &
+       1.229321e-02_rb,1.189350e-02_rb,1.151915e-02_rb,1.116859e-02_rb,1.084042e-02_rb, &
+       1.053338e-02_rb,1.024636e-02_rb,9.978326e-03_rb,9.728357e-03_rb,9.495613e-03_rb, &
+       9.279327e-03_rb,9.078798e-03_rb,8.893383e-03_rb,8.722488e-03_rb,8.565568e-03_rb, &
+       8.422115e-03_rb/)
+      absice3(:,12) = (/ &
+! band 12
+       9.465447e-02_rb,6.432047e-02_rb,5.060973e-02_rb,4.267283e-02_rb,3.741843e-02_rb, &
+       3.363096e-02_rb,3.073531e-02_rb,2.842405e-02_rb,2.651789e-02_rb,2.490518e-02_rb, &
+       2.351273e-02_rb,2.229056e-02_rb,2.120335e-02_rb,2.022541e-02_rb,1.933763e-02_rb, &
+       1.852546e-02_rb,1.777763e-02_rb,1.708528e-02_rb,1.644134e-02_rb,1.584009e-02_rb, &
+       1.527684e-02_rb,1.474774e-02_rb,1.424955e-02_rb,1.377957e-02_rb,1.333549e-02_rb, &
+       1.291534e-02_rb,1.251743e-02_rb,1.214029e-02_rb,1.178265e-02_rb,1.144337e-02_rb, &
+       1.112148e-02_rb,1.081609e-02_rb,1.052642e-02_rb,1.025178e-02_rb,9.991540e-03_rb, &
+       9.745130e-03_rb,9.512038e-03_rb,9.291797e-03_rb,9.083980e-03_rb,8.888195e-03_rb, &
+       8.704081e-03_rb,8.531306e-03_rb,8.369560e-03_rb,8.218558e-03_rb,8.078032e-03_rb, &
+       7.947730e-03_rb/)
+      absice3(:,13) = (/ &
+! band 13
+       1.560311e-01_rb,9.961097e-02_rb,7.502949e-02_rb,6.115022e-02_rb,5.214952e-02_rb, &
+       4.578149e-02_rb,4.099731e-02_rb,3.724174e-02_rb,3.419343e-02_rb,3.165356e-02_rb, &
+       2.949251e-02_rb,2.762222e-02_rb,2.598073e-02_rb,2.452322e-02_rb,2.321642e-02_rb, &
+       2.203516e-02_rb,2.096002e-02_rb,1.997579e-02_rb,1.907036e-02_rb,1.823401e-02_rb, &
+       1.745879e-02_rb,1.673819e-02_rb,1.606678e-02_rb,1.544003e-02_rb,1.485411e-02_rb, &
+       1.430574e-02_rb,1.379215e-02_rb,1.331092e-02_rb,1.285996e-02_rb,1.243746e-02_rb, &
+       1.204183e-02_rb,1.167164e-02_rb,1.132567e-02_rb,1.100281e-02_rb,1.070207e-02_rb, &
+       1.042258e-02_rb,1.016352e-02_rb,9.924197e-03_rb,9.703953e-03_rb,9.502199e-03_rb, &
+       9.318400e-03_rb,9.152066e-03_rb,9.002749e-03_rb,8.870038e-03_rb,8.753555e-03_rb, &
+       8.652951e-03_rb/)
+      absice3(:,14) = (/ &
+! band 14
+       1.559547e-01_rb,9.896700e-02_rb,7.441231e-02_rb,6.061469e-02_rb,5.168730e-02_rb, &
+       4.537821e-02_rb,4.064106e-02_rb,3.692367e-02_rb,3.390714e-02_rb,3.139438e-02_rb, &
+       2.925702e-02_rb,2.740783e-02_rb,2.578547e-02_rb,2.434552e-02_rb,2.305506e-02_rb, &
+       2.188910e-02_rb,2.082842e-02_rb,1.985789e-02_rb,1.896553e-02_rb,1.814165e-02_rb, &
+       1.737839e-02_rb,1.666927e-02_rb,1.600891e-02_rb,1.539279e-02_rb,1.481712e-02_rb, &
+       1.427865e-02_rb,1.377463e-02_rb,1.330266e-02_rb,1.286068e-02_rb,1.244689e-02_rb, &
+       1.205973e-02_rb,1.169780e-02_rb,1.135989e-02_rb,1.104492e-02_rb,1.075192e-02_rb, &
+       1.048004e-02_rb,1.022850e-02_rb,9.996611e-03_rb,9.783753e-03_rb,9.589361e-03_rb, &
+       9.412924e-03_rb,9.253977e-03_rb,9.112098e-03_rb,8.986903e-03_rb,8.878039e-03_rb, &
+       8.785184e-03_rb/)
+      absice3(:,15) = (/ &
+! band 15
+       1.102926e-01_rb,7.176622e-02_rb,5.530316e-02_rb,4.606056e-02_rb,4.006116e-02_rb, &
+       3.579628e-02_rb,3.256909e-02_rb,3.001360e-02_rb,2.791920e-02_rb,2.615617e-02_rb, &
+       2.464023e-02_rb,2.331426e-02_rb,2.213817e-02_rb,2.108301e-02_rb,2.012733e-02_rb, &
+       1.925493e-02_rb,1.845331e-02_rb,1.771269e-02_rb,1.702531e-02_rb,1.638493e-02_rb, &
+       1.578648e-02_rb,1.522579e-02_rb,1.469940e-02_rb,1.420442e-02_rb,1.373841e-02_rb, &
+       1.329931e-02_rb,1.288535e-02_rb,1.249502e-02_rb,1.212700e-02_rb,1.178015e-02_rb, &
+       1.145348e-02_rb,1.114612e-02_rb,1.085730e-02_rb,1.058633e-02_rb,1.033263e-02_rb, &
+       1.009564e-02_rb,9.874895e-03_rb,9.669960e-03_rb,9.480449e-03_rb,9.306014e-03_rb, &
+       9.146339e-03_rb,9.001138e-03_rb,8.870154e-03_rb,8.753148e-03_rb,8.649907e-03_rb, &
+       8.560232e-03_rb/)
+      absice3(:,16) = (/ &
+! band 16
+       1.688344e-01_rb,1.077072e-01_rb,7.994467e-02_rb,6.403862e-02_rb,5.369850e-02_rb, &
+       4.641582e-02_rb,4.099331e-02_rb,3.678724e-02_rb,3.342069e-02_rb,3.065831e-02_rb, &
+       2.834557e-02_rb,2.637680e-02_rb,2.467733e-02_rb,2.319286e-02_rb,2.188299e-02_rb, &
+       2.071701e-02_rb,1.967121e-02_rb,1.872692e-02_rb,1.786931e-02_rb,1.708641e-02_rb, &
+       1.636846e-02_rb,1.570743e-02_rb,1.509665e-02_rb,1.453052e-02_rb,1.400433e-02_rb, &
+       1.351407e-02_rb,1.305631e-02_rb,1.262810e-02_rb,1.222688e-02_rb,1.185044e-02_rb, &
+       1.149683e-02_rb,1.116436e-02_rb,1.085153e-02_rb,1.055701e-02_rb,1.027961e-02_rb, &
+       1.001831e-02_rb,9.772141e-03_rb,9.540280e-03_rb,9.321966e-03_rb,9.116517e-03_rb, &
+       8.923315e-03_rb,8.741803e-03_rb,8.571472e-03_rb,8.411860e-03_rb,8.262543e-03_rb, &
+       8.123136e-03_rb/)
+
+! For LIQFLAG = 0.
+      absliq0 = 0.0903614_rb
+
+! For LIQFLAG = 1.  In each band, the absorption
+! coefficients are listed for a range of effective radii from 2.5
+! to 59.5 microns in increments of 1.0 micron.
+      absliq1(:, 1) = (/ &
+! band  1
+       1.64047e-03_rb, 6.90533e-02_rb, 7.72017e-02_rb, 7.78054e-02_rb, 7.69523e-02_rb, &
+       7.58058e-02_rb, 7.46400e-02_rb, 7.35123e-02_rb, 7.24162e-02_rb, 7.13225e-02_rb, &
+       6.99145e-02_rb, 6.66409e-02_rb, 6.36582e-02_rb, 6.09425e-02_rb, 5.84593e-02_rb, &
+       5.61743e-02_rb, 5.40571e-02_rb, 5.20812e-02_rb, 5.02245e-02_rb, 4.84680e-02_rb, &
+       4.67959e-02_rb, 4.51944e-02_rb, 4.36516e-02_rb, 4.21570e-02_rb, 4.07015e-02_rb, &
+       3.92766e-02_rb, 3.78747e-02_rb, 3.64886e-02_rb, 3.53632e-02_rb, 3.41992e-02_rb, &
+       3.31016e-02_rb, 3.20643e-02_rb, 3.10817e-02_rb, 3.01490e-02_rb, 2.92620e-02_rb, &
+       2.84171e-02_rb, 2.76108e-02_rb, 2.68404e-02_rb, 2.61031e-02_rb, 2.53966e-02_rb, &
+       2.47189e-02_rb, 2.40678e-02_rb, 2.34418e-02_rb, 2.28392e-02_rb, 2.22586e-02_rb, &
+       2.16986e-02_rb, 2.11580e-02_rb, 2.06356e-02_rb, 2.01305e-02_rb, 1.96417e-02_rb, &
+       1.91682e-02_rb, 1.87094e-02_rb, 1.82643e-02_rb, 1.78324e-02_rb, 1.74129e-02_rb, &
+       1.70052e-02_rb, 1.66088e-02_rb, 1.62231e-02_rb/)
+      absliq1(:, 2) = (/ &
+! band  2
+       2.19486e-01_rb, 1.80687e-01_rb, 1.59150e-01_rb, 1.44731e-01_rb, 1.33703e-01_rb, &
+       1.24355e-01_rb, 1.15756e-01_rb, 1.07318e-01_rb, 9.86119e-02_rb, 8.92739e-02_rb, &
+       8.34911e-02_rb, 7.70773e-02_rb, 7.15240e-02_rb, 6.66615e-02_rb, 6.23641e-02_rb, &
+       5.85359e-02_rb, 5.51020e-02_rb, 5.20032e-02_rb, 4.91916e-02_rb, 4.66283e-02_rb, &
+       4.42813e-02_rb, 4.21236e-02_rb, 4.01330e-02_rb, 3.82905e-02_rb, 3.65797e-02_rb, &
+       3.49869e-02_rb, 3.35002e-02_rb, 3.21090e-02_rb, 3.08957e-02_rb, 2.97601e-02_rb, &
+       2.86966e-02_rb, 2.76984e-02_rb, 2.67599e-02_rb, 2.58758e-02_rb, 2.50416e-02_rb, &
+       2.42532e-02_rb, 2.35070e-02_rb, 2.27997e-02_rb, 2.21284e-02_rb, 2.14904e-02_rb, &
+       2.08834e-02_rb, 2.03051e-02_rb, 1.97536e-02_rb, 1.92271e-02_rb, 1.87239e-02_rb, &
+       1.82425e-02_rb, 1.77816e-02_rb, 1.73399e-02_rb, 1.69162e-02_rb, 1.65094e-02_rb, &
+       1.61187e-02_rb, 1.57430e-02_rb, 1.53815e-02_rb, 1.50334e-02_rb, 1.46981e-02_rb, &
+       1.43748e-02_rb, 1.40628e-02_rb, 1.37617e-02_rb/)
+      absliq1(:, 3) = (/ &
+! band  3
+       2.95174e-01_rb, 2.34765e-01_rb, 1.98038e-01_rb, 1.72114e-01_rb, 1.52083e-01_rb, &
+       1.35654e-01_rb, 1.21613e-01_rb, 1.09252e-01_rb, 9.81263e-02_rb, 8.79448e-02_rb, &
+       8.12566e-02_rb, 7.44563e-02_rb, 6.86374e-02_rb, 6.36042e-02_rb, 5.92094e-02_rb, &
+       5.53402e-02_rb, 5.19087e-02_rb, 4.88455e-02_rb, 4.60951e-02_rb, 4.36124e-02_rb, &
+       4.13607e-02_rb, 3.93096e-02_rb, 3.74338e-02_rb, 3.57119e-02_rb, 3.41261e-02_rb, &
+       3.26610e-02_rb, 3.13036e-02_rb, 3.00425e-02_rb, 2.88497e-02_rb, 2.78077e-02_rb, &
+       2.68317e-02_rb, 2.59158e-02_rb, 2.50545e-02_rb, 2.42430e-02_rb, 2.34772e-02_rb, &
+       2.27533e-02_rb, 2.20679e-02_rb, 2.14181e-02_rb, 2.08011e-02_rb, 2.02145e-02_rb, &
+       1.96561e-02_rb, 1.91239e-02_rb, 1.86161e-02_rb, 1.81311e-02_rb, 1.76673e-02_rb, &
+       1.72234e-02_rb, 1.67981e-02_rb, 1.63903e-02_rb, 1.59989e-02_rb, 1.56230e-02_rb, &
+       1.52615e-02_rb, 1.49138e-02_rb, 1.45791e-02_rb, 1.42565e-02_rb, 1.39455e-02_rb, &
+       1.36455e-02_rb, 1.33559e-02_rb, 1.30761e-02_rb/)
+      absliq1(:, 4) = (/ &
+! band  4
+       3.00925e-01_rb, 2.36949e-01_rb, 1.96947e-01_rb, 1.68692e-01_rb, 1.47190e-01_rb, &
+       1.29986e-01_rb, 1.15719e-01_rb, 1.03568e-01_rb, 9.30028e-02_rb, 8.36658e-02_rb, &
+       7.71075e-02_rb, 7.07002e-02_rb, 6.52284e-02_rb, 6.05024e-02_rb, 5.63801e-02_rb, &
+       5.27534e-02_rb, 4.95384e-02_rb, 4.66690e-02_rb, 4.40925e-02_rb, 4.17664e-02_rb, &
+       3.96559e-02_rb, 3.77326e-02_rb, 3.59727e-02_rb, 3.43561e-02_rb, 3.28662e-02_rb, &
+       3.14885e-02_rb, 3.02110e-02_rb, 2.90231e-02_rb, 2.78948e-02_rb, 2.69109e-02_rb, &
+       2.59884e-02_rb, 2.51217e-02_rb, 2.43058e-02_rb, 2.35364e-02_rb, 2.28096e-02_rb, &
+       2.21218e-02_rb, 2.14700e-02_rb, 2.08515e-02_rb, 2.02636e-02_rb, 1.97041e-02_rb, &
+       1.91711e-02_rb, 1.86625e-02_rb, 1.81769e-02_rb, 1.77126e-02_rb, 1.72683e-02_rb, &
+       1.68426e-02_rb, 1.64344e-02_rb, 1.60427e-02_rb, 1.56664e-02_rb, 1.53046e-02_rb, &
+       1.49565e-02_rb, 1.46214e-02_rb, 1.42985e-02_rb, 1.39871e-02_rb, 1.36866e-02_rb, &
+       1.33965e-02_rb, 1.31162e-02_rb, 1.28453e-02_rb/)
+      absliq1(:, 5) = (/ &
+! band  5
+       2.64691e-01_rb, 2.12018e-01_rb, 1.78009e-01_rb, 1.53539e-01_rb, 1.34721e-01_rb, &
+       1.19580e-01_rb, 1.06996e-01_rb, 9.62772e-02_rb, 8.69710e-02_rb, 7.87670e-02_rb, &
+       7.29272e-02_rb, 6.70920e-02_rb, 6.20977e-02_rb, 5.77732e-02_rb, 5.39910e-02_rb, &
+       5.06538e-02_rb, 4.76866e-02_rb, 4.50301e-02_rb, 4.26374e-02_rb, 4.04704e-02_rb, &
+       3.84981e-02_rb, 3.66948e-02_rb, 3.50394e-02_rb, 3.35141e-02_rb, 3.21038e-02_rb, &
+       3.07957e-02_rb, 2.95788e-02_rb, 2.84438e-02_rb, 2.73790e-02_rb, 2.64390e-02_rb, &
+       2.55565e-02_rb, 2.47263e-02_rb, 2.39437e-02_rb, 2.32047e-02_rb, 2.25056e-02_rb, &
+       2.18433e-02_rb, 2.12149e-02_rb, 2.06177e-02_rb, 2.00495e-02_rb, 1.95081e-02_rb, &
+       1.89917e-02_rb, 1.84984e-02_rb, 1.80269e-02_rb, 1.75755e-02_rb, 1.71431e-02_rb, &
+       1.67283e-02_rb, 1.63303e-02_rb, 1.59478e-02_rb, 1.55801e-02_rb, 1.52262e-02_rb, &
+       1.48853e-02_rb, 1.45568e-02_rb, 1.42400e-02_rb, 1.39342e-02_rb, 1.36388e-02_rb, &
+       1.33533e-02_rb, 1.30773e-02_rb, 1.28102e-02_rb/)
+      absliq1(:, 6) = (/ &
+! band  6
+       8.81182e-02_rb, 1.06745e-01_rb, 9.79753e-02_rb, 8.99625e-02_rb, 8.35200e-02_rb, &
+       7.81899e-02_rb, 7.35939e-02_rb, 6.94696e-02_rb, 6.56266e-02_rb, 6.19148e-02_rb, &
+       5.83355e-02_rb, 5.49306e-02_rb, 5.19642e-02_rb, 4.93325e-02_rb, 4.69659e-02_rb, &
+       4.48148e-02_rb, 4.28431e-02_rb, 4.10231e-02_rb, 3.93332e-02_rb, 3.77563e-02_rb, &
+       3.62785e-02_rb, 3.48882e-02_rb, 3.35758e-02_rb, 3.23333e-02_rb, 3.11536e-02_rb, &
+       3.00310e-02_rb, 2.89601e-02_rb, 2.79365e-02_rb, 2.70502e-02_rb, 2.62618e-02_rb, &
+       2.55025e-02_rb, 2.47728e-02_rb, 2.40726e-02_rb, 2.34013e-02_rb, 2.27583e-02_rb, &
+       2.21422e-02_rb, 2.15522e-02_rb, 2.09869e-02_rb, 2.04453e-02_rb, 1.99260e-02_rb, &
+       1.94280e-02_rb, 1.89501e-02_rb, 1.84913e-02_rb, 1.80506e-02_rb, 1.76270e-02_rb, &
+       1.72196e-02_rb, 1.68276e-02_rb, 1.64500e-02_rb, 1.60863e-02_rb, 1.57357e-02_rb, &
+       1.53975e-02_rb, 1.50710e-02_rb, 1.47558e-02_rb, 1.44511e-02_rb, 1.41566e-02_rb, &
+       1.38717e-02_rb, 1.35960e-02_rb, 1.33290e-02_rb/)
+      absliq1(:, 7) = (/ &
+! band  7
+       4.32174e-02_rb, 7.36078e-02_rb, 6.98340e-02_rb, 6.65231e-02_rb, 6.41948e-02_rb, &
+       6.23551e-02_rb, 6.06638e-02_rb, 5.88680e-02_rb, 5.67124e-02_rb, 5.38629e-02_rb, &
+       4.99579e-02_rb, 4.86289e-02_rb, 4.70120e-02_rb, 4.52854e-02_rb, 4.35466e-02_rb, &
+       4.18480e-02_rb, 4.02169e-02_rb, 3.86658e-02_rb, 3.71992e-02_rb, 3.58168e-02_rb, &
+       3.45155e-02_rb, 3.32912e-02_rb, 3.21390e-02_rb, 3.10538e-02_rb, 3.00307e-02_rb, &
+       2.90651e-02_rb, 2.81524e-02_rb, 2.72885e-02_rb, 2.62821e-02_rb, 2.55744e-02_rb, &
+       2.48799e-02_rb, 2.42029e-02_rb, 2.35460e-02_rb, 2.29108e-02_rb, 2.22981e-02_rb, &
+       2.17079e-02_rb, 2.11402e-02_rb, 2.05945e-02_rb, 2.00701e-02_rb, 1.95663e-02_rb, &
+       1.90824e-02_rb, 1.86174e-02_rb, 1.81706e-02_rb, 1.77411e-02_rb, 1.73281e-02_rb, &
+       1.69307e-02_rb, 1.65483e-02_rb, 1.61801e-02_rb, 1.58254e-02_rb, 1.54835e-02_rb, &
+       1.51538e-02_rb, 1.48358e-02_rb, 1.45288e-02_rb, 1.42322e-02_rb, 1.39457e-02_rb, &
+       1.36687e-02_rb, 1.34008e-02_rb, 1.31416e-02_rb/)
+      absliq1(:, 8) = (/ &
+! band  8
+       1.41881e-01_rb, 7.15419e-02_rb, 6.30335e-02_rb, 6.11132e-02_rb, 6.01931e-02_rb, &
+       5.92420e-02_rb, 5.78968e-02_rb, 5.58876e-02_rb, 5.28923e-02_rb, 4.84462e-02_rb, &
+       4.60839e-02_rb, 4.56013e-02_rb, 4.45410e-02_rb, 4.31866e-02_rb, 4.17026e-02_rb, &
+       4.01850e-02_rb, 3.86892e-02_rb, 3.72461e-02_rb, 3.58722e-02_rb, 3.45749e-02_rb, &
+       3.33564e-02_rb, 3.22155e-02_rb, 3.11494e-02_rb, 3.01541e-02_rb, 2.92253e-02_rb, &
+       2.83584e-02_rb, 2.75488e-02_rb, 2.67925e-02_rb, 2.57692e-02_rb, 2.50704e-02_rb, &
+       2.43918e-02_rb, 2.37350e-02_rb, 2.31005e-02_rb, 2.24888e-02_rb, 2.18996e-02_rb, &
+       2.13325e-02_rb, 2.07870e-02_rb, 2.02623e-02_rb, 1.97577e-02_rb, 1.92724e-02_rb, &
+       1.88056e-02_rb, 1.83564e-02_rb, 1.79241e-02_rb, 1.75079e-02_rb, 1.71070e-02_rb, &
+       1.67207e-02_rb, 1.63482e-02_rb, 1.59890e-02_rb, 1.56424e-02_rb, 1.53077e-02_rb, &
+       1.49845e-02_rb, 1.46722e-02_rb, 1.43702e-02_rb, 1.40782e-02_rb, 1.37955e-02_rb, &
+       1.35219e-02_rb, 1.32569e-02_rb, 1.30000e-02_rb/)
+      absliq1(:, 9) = (/ &
+! band  9
+       6.72726e-02_rb, 6.61013e-02_rb, 6.47866e-02_rb, 6.33780e-02_rb, 6.18985e-02_rb, &
+       6.03335e-02_rb, 5.86136e-02_rb, 5.65876e-02_rb, 5.39839e-02_rb, 5.03536e-02_rb, &
+       4.71608e-02_rb, 4.63630e-02_rb, 4.50313e-02_rb, 4.34526e-02_rb, 4.17876e-02_rb, &
+       4.01261e-02_rb, 3.85171e-02_rb, 3.69860e-02_rb, 3.55442e-02_rb, 3.41954e-02_rb, &
+       3.29384e-02_rb, 3.17693e-02_rb, 3.06832e-02_rb, 2.96745e-02_rb, 2.87374e-02_rb, &
+       2.78662e-02_rb, 2.70557e-02_rb, 2.63008e-02_rb, 2.52450e-02_rb, 2.45424e-02_rb, &
+       2.38656e-02_rb, 2.32144e-02_rb, 2.25885e-02_rb, 2.19873e-02_rb, 2.14099e-02_rb, &
+       2.08554e-02_rb, 2.03230e-02_rb, 1.98116e-02_rb, 1.93203e-02_rb, 1.88482e-02_rb, &
+       1.83944e-02_rb, 1.79578e-02_rb, 1.75378e-02_rb, 1.71335e-02_rb, 1.67440e-02_rb, &
+       1.63687e-02_rb, 1.60069e-02_rb, 1.56579e-02_rb, 1.53210e-02_rb, 1.49958e-02_rb, &
+       1.46815e-02_rb, 1.43778e-02_rb, 1.40841e-02_rb, 1.37999e-02_rb, 1.35249e-02_rb, &
+       1.32585e-02_rb, 1.30004e-02_rb, 1.27502e-02_rb/)
+      absliq1(:,10) = (/ &
+! band 10
+       7.97040e-02_rb, 7.63844e-02_rb, 7.36499e-02_rb, 7.13525e-02_rb, 6.93043e-02_rb, &
+       6.72807e-02_rb, 6.50227e-02_rb, 6.22395e-02_rb, 5.86093e-02_rb, 5.37815e-02_rb, &
+       5.14682e-02_rb, 4.97214e-02_rb, 4.77392e-02_rb, 4.56961e-02_rb, 4.36858e-02_rb, &
+       4.17569e-02_rb, 3.99328e-02_rb, 3.82224e-02_rb, 3.66265e-02_rb, 3.51416e-02_rb, &
+       3.37617e-02_rb, 3.24798e-02_rb, 3.12887e-02_rb, 3.01812e-02_rb, 2.91505e-02_rb, &
+       2.81900e-02_rb, 2.72939e-02_rb, 2.64568e-02_rb, 2.54165e-02_rb, 2.46832e-02_rb, &
+       2.39783e-02_rb, 2.33017e-02_rb, 2.26531e-02_rb, 2.20314e-02_rb, 2.14359e-02_rb, &
+       2.08653e-02_rb, 2.03187e-02_rb, 1.97947e-02_rb, 1.92924e-02_rb, 1.88106e-02_rb, &
+       1.83483e-02_rb, 1.79043e-02_rb, 1.74778e-02_rb, 1.70678e-02_rb, 1.66735e-02_rb, &
+       1.62941e-02_rb, 1.59286e-02_rb, 1.55766e-02_rb, 1.52371e-02_rb, 1.49097e-02_rb, &
+       1.45937e-02_rb, 1.42885e-02_rb, 1.39936e-02_rb, 1.37085e-02_rb, 1.34327e-02_rb, &
+       1.31659e-02_rb, 1.29075e-02_rb, 1.26571e-02_rb/)
+      absliq1(:,11) = (/ &
+! band 11
+       1.49438e-01_rb, 1.33535e-01_rb, 1.21542e-01_rb, 1.11743e-01_rb, 1.03263e-01_rb, &
+       9.55774e-02_rb, 8.83382e-02_rb, 8.12943e-02_rb, 7.42533e-02_rb, 6.70609e-02_rb, &
+       6.38761e-02_rb, 5.97788e-02_rb, 5.59841e-02_rb, 5.25318e-02_rb, 4.94132e-02_rb, &
+       4.66014e-02_rb, 4.40644e-02_rb, 4.17706e-02_rb, 3.96910e-02_rb, 3.77998e-02_rb, &
+       3.60742e-02_rb, 3.44947e-02_rb, 3.30442e-02_rb, 3.17079e-02_rb, 3.04730e-02_rb, &
+       2.93283e-02_rb, 2.82642e-02_rb, 2.72720e-02_rb, 2.61789e-02_rb, 2.53277e-02_rb, &
+       2.45237e-02_rb, 2.37635e-02_rb, 2.30438e-02_rb, 2.23615e-02_rb, 2.17140e-02_rb, &
+       2.10987e-02_rb, 2.05133e-02_rb, 1.99557e-02_rb, 1.94241e-02_rb, 1.89166e-02_rb, &
+       1.84317e-02_rb, 1.79679e-02_rb, 1.75238e-02_rb, 1.70983e-02_rb, 1.66901e-02_rb, &
+       1.62983e-02_rb, 1.59219e-02_rb, 1.55599e-02_rb, 1.52115e-02_rb, 1.48761e-02_rb, &
+       1.45528e-02_rb, 1.42411e-02_rb, 1.39402e-02_rb, 1.36497e-02_rb, 1.33690e-02_rb, &
+       1.30976e-02_rb, 1.28351e-02_rb, 1.25810e-02_rb/)
+      absliq1(:,12) = (/ &
+! band 12
+       3.71985e-02_rb, 3.88586e-02_rb, 3.99070e-02_rb, 4.04351e-02_rb, 4.04610e-02_rb, &
+       3.99834e-02_rb, 3.89953e-02_rb, 3.74886e-02_rb, 3.54551e-02_rb, 3.28870e-02_rb, &
+       3.32576e-02_rb, 3.22444e-02_rb, 3.12384e-02_rb, 3.02584e-02_rb, 2.93146e-02_rb, &
+       2.84120e-02_rb, 2.75525e-02_rb, 2.67361e-02_rb, 2.59618e-02_rb, 2.52280e-02_rb, &
+       2.45327e-02_rb, 2.38736e-02_rb, 2.32487e-02_rb, 2.26558e-02_rb, 2.20929e-02_rb, &
+       2.15579e-02_rb, 2.10491e-02_rb, 2.05648e-02_rb, 1.99749e-02_rb, 1.95704e-02_rb, &
+       1.91731e-02_rb, 1.87839e-02_rb, 1.84032e-02_rb, 1.80315e-02_rb, 1.76689e-02_rb, &
+       1.73155e-02_rb, 1.69712e-02_rb, 1.66362e-02_rb, 1.63101e-02_rb, 1.59928e-02_rb, &
+       1.56842e-02_rb, 1.53840e-02_rb, 1.50920e-02_rb, 1.48080e-02_rb, 1.45318e-02_rb, &
+       1.42631e-02_rb, 1.40016e-02_rb, 1.37472e-02_rb, 1.34996e-02_rb, 1.32586e-02_rb, &
+       1.30239e-02_rb, 1.27954e-02_rb, 1.25728e-02_rb, 1.23559e-02_rb, 1.21445e-02_rb, &
+       1.19385e-02_rb, 1.17376e-02_rb, 1.15417e-02_rb/)
+      absliq1(:,13) = (/ &
+! band 13
+       3.11868e-02_rb, 4.48357e-02_rb, 4.90224e-02_rb, 4.96406e-02_rb, 4.86806e-02_rb, &
+       4.69610e-02_rb, 4.48630e-02_rb, 4.25795e-02_rb, 4.02138e-02_rb, 3.78236e-02_rb, &
+       3.74266e-02_rb, 3.60384e-02_rb, 3.47074e-02_rb, 3.34434e-02_rb, 3.22499e-02_rb, &
+       3.11264e-02_rb, 3.00704e-02_rb, 2.90784e-02_rb, 2.81463e-02_rb, 2.72702e-02_rb, &
+       2.64460e-02_rb, 2.56698e-02_rb, 2.49381e-02_rb, 2.42475e-02_rb, 2.35948e-02_rb, &
+       2.29774e-02_rb, 2.23925e-02_rb, 2.18379e-02_rb, 2.11793e-02_rb, 2.07076e-02_rb, &
+       2.02470e-02_rb, 1.97981e-02_rb, 1.93613e-02_rb, 1.89367e-02_rb, 1.85243e-02_rb, &
+       1.81240e-02_rb, 1.77356e-02_rb, 1.73588e-02_rb, 1.69935e-02_rb, 1.66392e-02_rb, &
+       1.62956e-02_rb, 1.59624e-02_rb, 1.56393e-02_rb, 1.53259e-02_rb, 1.50219e-02_rb, &
+       1.47268e-02_rb, 1.44404e-02_rb, 1.41624e-02_rb, 1.38925e-02_rb, 1.36302e-02_rb, &
+       1.33755e-02_rb, 1.31278e-02_rb, 1.28871e-02_rb, 1.26530e-02_rb, 1.24253e-02_rb, &
+       1.22038e-02_rb, 1.19881e-02_rb, 1.17782e-02_rb/)
+      absliq1(:,14) = (/ &
+! band 14
+       1.58988e-02_rb, 3.50652e-02_rb, 4.00851e-02_rb, 4.07270e-02_rb, 3.98101e-02_rb, &
+       3.83306e-02_rb, 3.66829e-02_rb, 3.50327e-02_rb, 3.34497e-02_rb, 3.19609e-02_rb, &
+       3.13712e-02_rb, 3.03348e-02_rb, 2.93415e-02_rb, 2.83973e-02_rb, 2.75037e-02_rb, &
+       2.66604e-02_rb, 2.58654e-02_rb, 2.51161e-02_rb, 2.44100e-02_rb, 2.37440e-02_rb, &
+       2.31154e-02_rb, 2.25215e-02_rb, 2.19599e-02_rb, 2.14282e-02_rb, 2.09242e-02_rb, &
+       2.04459e-02_rb, 1.99915e-02_rb, 1.95594e-02_rb, 1.90254e-02_rb, 1.86598e-02_rb, &
+       1.82996e-02_rb, 1.79455e-02_rb, 1.75983e-02_rb, 1.72584e-02_rb, 1.69260e-02_rb, &
+       1.66013e-02_rb, 1.62843e-02_rb, 1.59752e-02_rb, 1.56737e-02_rb, 1.53799e-02_rb, &
+       1.50936e-02_rb, 1.48146e-02_rb, 1.45429e-02_rb, 1.42782e-02_rb, 1.40203e-02_rb, &
+       1.37691e-02_rb, 1.35243e-02_rb, 1.32858e-02_rb, 1.30534e-02_rb, 1.28270e-02_rb, &
+       1.26062e-02_rb, 1.23909e-02_rb, 1.21810e-02_rb, 1.19763e-02_rb, 1.17766e-02_rb, &
+       1.15817e-02_rb, 1.13915e-02_rb, 1.12058e-02_rb/)
+      absliq1(:,15) = (/ &
+! band 15
+       5.02079e-03_rb, 2.17615e-02_rb, 2.55449e-02_rb, 2.59484e-02_rb, 2.53650e-02_rb, &
+       2.45281e-02_rb, 2.36843e-02_rb, 2.29159e-02_rb, 2.22451e-02_rb, 2.16716e-02_rb, &
+       2.11451e-02_rb, 2.05817e-02_rb, 2.00454e-02_rb, 1.95372e-02_rb, 1.90567e-02_rb, &
+       1.86028e-02_rb, 1.81742e-02_rb, 1.77693e-02_rb, 1.73866e-02_rb, 1.70244e-02_rb, &
+       1.66815e-02_rb, 1.63563e-02_rb, 1.60477e-02_rb, 1.57544e-02_rb, 1.54755e-02_rb, &
+       1.52097e-02_rb, 1.49564e-02_rb, 1.47146e-02_rb, 1.43684e-02_rb, 1.41728e-02_rb, &
+       1.39762e-02_rb, 1.37797e-02_rb, 1.35838e-02_rb, 1.33891e-02_rb, 1.31961e-02_rb, &
+       1.30051e-02_rb, 1.28164e-02_rb, 1.26302e-02_rb, 1.24466e-02_rb, 1.22659e-02_rb, &
+       1.20881e-02_rb, 1.19131e-02_rb, 1.17412e-02_rb, 1.15723e-02_rb, 1.14063e-02_rb, &
+       1.12434e-02_rb, 1.10834e-02_rb, 1.09264e-02_rb, 1.07722e-02_rb, 1.06210e-02_rb, &
+       1.04725e-02_rb, 1.03269e-02_rb, 1.01839e-02_rb, 1.00436e-02_rb, 9.90593e-03_rb, &
+       9.77080e-03_rb, 9.63818e-03_rb, 9.50800e-03_rb/)
+      absliq1(:,16) = (/ &
+! band 16
+       5.64971e-02_rb, 9.04736e-02_rb, 8.11726e-02_rb, 7.05450e-02_rb, 6.20052e-02_rb, &
+       5.54286e-02_rb, 5.03503e-02_rb, 4.63791e-02_rb, 4.32290e-02_rb, 4.06959e-02_rb, &
+       3.74690e-02_rb, 3.52964e-02_rb, 3.33799e-02_rb, 3.16774e-02_rb, 3.01550e-02_rb, &
+       2.87856e-02_rb, 2.75474e-02_rb, 2.64223e-02_rb, 2.53953e-02_rb, 2.44542e-02_rb, &
+       2.35885e-02_rb, 2.27894e-02_rb, 2.20494e-02_rb, 2.13622e-02_rb, 2.07222e-02_rb, &
+       2.01246e-02_rb, 1.95654e-02_rb, 1.90408e-02_rb, 1.84398e-02_rb, 1.80021e-02_rb, &
+       1.75816e-02_rb, 1.71775e-02_rb, 1.67889e-02_rb, 1.64152e-02_rb, 1.60554e-02_rb, &
+       1.57089e-02_rb, 1.53751e-02_rb, 1.50531e-02_rb, 1.47426e-02_rb, 1.44428e-02_rb, &
+       1.41532e-02_rb, 1.38734e-02_rb, 1.36028e-02_rb, 1.33410e-02_rb, 1.30875e-02_rb, &
+       1.28420e-02_rb, 1.26041e-02_rb, 1.23735e-02_rb, 1.21497e-02_rb, 1.19325e-02_rb, &
+       1.17216e-02_rb, 1.15168e-02_rb, 1.13177e-02_rb, 1.11241e-02_rb, 1.09358e-02_rb, &
+       1.07525e-02_rb, 1.05741e-02_rb, 1.04003e-02_rb/)
+
+      end subroutine lwcldpr
+
+      end module rrtmg_lw_init
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_lw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+!
+       module rrtmg_lw_rad
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+!
+! ****************************************************************************
+! *                                                                          *
+! *                              RRTMG_LW                                    *
+! *                                                                          *
+! *                                                                          *
+! *                                                                          *
+! *                   a rapid radiative transfer model                       *
+! *                       for the longwave region                            * 
+! *             for application to general circulation models                *
+! *                                                                          *
+! *                                                                          *
+! *            Atmospheric and Environmental Research, Inc.                  *
+! *                        131 Hartwell Avenue                               *
+! *                        Lexington, MA 02421                               *
+! *                                                                          *
+! *                                                                          *
+! *                           Eli J. Mlawer                                  *
+! *                        Jennifer S. Delamere                              *
+! *                         Michael J. Iacono                                *
+! *                         Shepard A. Clough                                *
+! *                                                                          *
+! *                                                                          *
+! *                                                                          *
+! *                                                                          *
+! *                                                                          *
+! *                                                                          *
+! *                       email:  miacono@aer.com                            *
+! *                       email:  emlawer@aer.com                            *
+! *                       email:  jdelamer@aer.com                           *
+! *                                                                          *
+! *        The authors wish to acknowledge the contributions of the          *
+! *        following people:  Steven J. Taubman, Karen Cady-Pereira,         *
+! *        Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom.  *
+! *                                                                          *
+! ****************************************************************************
+
+! -------- Modules --------
+      use parkind, only : im => kind_im, rb => kind_rb
+      use rrlw_vsn
+      use mcica_subcol_gen_lw, only: mcica_subcol_lw
+      use rrtmg_lw_cldprmc, only: cldprmc
+! *** Move the required call to rrtmg_lw_ini below and the following 
+! use association to the GCM initialization area ***
+!      use rrtmg_lw_init, only: rrtmg_lw_ini
+      use rrtmg_lw_rtrnmc, only: rtrnmc
+      use rrtmg_lw_setcoef, only: setcoef
+      use rrtmg_lw_taumol, only: taumol
+
+      implicit none
+
+! public interfaces/functions/subroutines
+      public :: rrtmg_lw, inatm
+
+!------------------------------------------------------------------
+      contains
+!------------------------------------------------------------------
+
+!------------------------------------------------------------------
+! Public subroutines
+!------------------------------------------------------------------
+
+      subroutine rrtmg_lw &
+            (ncol    ,nlay    ,icld    , &
+             play    ,plev    ,tlay    ,tlev    ,tsfc    , & 
+             h2ovmr  ,o3vmr   ,co2vmr  ,ch4vmr  ,n2ovmr  ,o2vmr , &
+             cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis    , &
+             inflglw ,iceflglw,liqflglw,cldfmcl , &
+             taucmcl ,ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
+             tauaer  , &
+             uflx    ,dflx    ,hr      ,uflxc   ,dflxc,  hrc)
+
+! -------- Description --------
+
+! This program is the driver subroutine for RRTMG_LW, the AER LW radiation 
+! model for application to GCMs, that has been adapted from RRTM_LW for
+! improved efficiency.
+!
+! NOTE: The call to RRTMG_LW_INI should be moved to the GCM initialization
+!  area, since this has to be called only once. 
+!
+! This routine:
+!    a) calls INATM to read in the atmospheric profile from GCM;
+!       all layering in RRTMG is ordered from surface to toa. 
+!    b) calls CLDPRMC to set cloud optical depth for McICA based 
+!       on input cloud properties 
+!    c) calls SETCOEF to calculate various quantities needed for 
+!       the radiative transfer algorithm
+!    d) calls TAUMOL to calculate gaseous optical depths for each 
+!       of the 16 spectral bands
+!    e) calls RTRNMC (for both clear and cloudy profiles) to perform the
+!       radiative transfer calculation using McICA, the Monte-Carlo 
+!       Independent Column Approximation, to represent sub-grid scale 
+!       cloud variability
+!    f) passes the necessary fluxes and cooling rates back to GCM
+!
+! Two modes of operation are possible:
+!     The mode is chosen by using either rrtmg_lw.nomcica.f90 (to not use
+!     McICA) or rrtmg_lw.f90 (to use McICA) to interface with a GCM. 
+!
+!    1) Standard, single forward model calculation (imca = 0)
+!    2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., 
+!       JC, 2003) method is applied to the forward model calculation (imca = 1)
+!
+! This call to RRTMG_LW must be preceeded by a call to the module
+!     mcica_subcol_gen_lw.f90 to run the McICA sub-column cloud generator,
+!     which will provide the cloud physical or cloud optical properties
+!     on the RRTMG quadrature point (ngpt) dimension.
+!     Two random number generators are available for use when imca = 1.
+!     This is chosen by setting flag irnd on input to mcica_subcol_gen_lw.
+!     1) KISSVEC (irnd = 0)
+!     2) Mersenne-Twister (irnd = 1)
+!
+! Two methods of cloud property input are possible:
+!     Cloud properties can be input in one of two ways (controlled by input 
+!     flags inflglw, iceflglw, and liqflglw; see text file rrtmg_lw_instructions
+!     and subroutine rrtmg_lw_cldprop.f90 for further details):
+!
+!    1) Input cloud fraction and cloud optical depth directly (inflglw = 0)
+!    2) Input cloud fraction and cloud physical properties (inflglw = 1 or 2);  
+!       cloud optical properties are calculated by cldprop or cldprmc based
+!       on input settings of iceflglw and liqflglw.  Ice particle size provided
+!       must be appropriately defined for the ice parameterization selected. 
+!
+! One method of aerosol property input is possible:
+!     Aerosol properties can be input in only one way (controlled by input 
+!     flag iaer; see text file rrtmg_lw_instructions for further details):
+!
+!    1) Input aerosol optical depth directly by layer and spectral band (iaer=10);
+!       band average optical depth at the mid-point of each spectral band.
+!       RRTMG_LW currently treats only aerosol absorption;
+!       scattering capability is not presently available.
+!
+!
+! ------- Modifications -------
+!
+! This version of RRTMG_LW has been modified from RRTM_LW to use a reduced 
+! set of g-points for application to GCMs.  
+!
+!-- Original version (derived from RRTM_LW), reduction of g-points, other
+!   revisions for use with GCMs.  
+!     1999: M. J. Iacono, AER, Inc.
+!-- Adapted for use with NCAR/CAM.
+!     May 2004: M. J. Iacono, AER, Inc.
+!-- Revised to add McICA capability. 
+!     Nov 2005: M. J. Iacono, AER, Inc.
+!-- Conversion to F90 formatting for consistency with rrtmg_sw.
+!     Feb 2007: M. J. Iacono, AER, Inc.
+!-- Modifications to formatting to use assumed-shape arrays.
+!     Aug 2007: M. J. Iacono, AER, Inc.
+!-- Modified to add longwave aerosol absorption.
+!     Apr 2008: M. J. Iacono, AER, Inc.
+
+! --------- Modules ----------
+
+      use parrrtm, only : nbndlw, ngptlw, maxxsec, mxmol
+      use rrlw_con, only: fluxfac, heatfac, oneminus, pi
+      use rrlw_wvn, only: ng, ngb, nspa, nspb, wavenum1, wavenum2, delwave
+
+! ------- Declarations -------
+
+! ----- Input -----
+      integer(kind=im), intent(in) :: ncol            ! Number of horizontal columns
+      integer(kind=im), intent(in) :: nlay            ! Number of model layers
+      integer(kind=im), intent(inout) :: icld         ! Cloud overlap method
+                                                      !    0: Clear only
+                                                      !    1: Random
+                                                      !    2: Maximum/random
+                                                      !    3: Maximum
+      real(kind=rb), intent(in) :: play(:,:)          ! Layer pressures (hPa, mb)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: plev(:,:)          ! Interface pressures (hPa, mb)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(in) :: tlay(:,:)          ! Layer temperatures (K)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: tlev(:,:)          ! Interface temperatures (K)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(in) :: tsfc(:)            ! Surface temperature (K)
+                                                      !    Dimensions: (ncol)
+      real(kind=rb), intent(in) :: h2ovmr(:,:)        ! H2O volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: o3vmr(:,:)         ! O3 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: co2vmr(:,:)        ! CO2 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: ch4vmr(:,:)        ! Methane volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: n2ovmr(:,:)        ! Nitrous oxide volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: o2vmr(:,:)         ! Oxygen volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: cfc11vmr(:,:)      ! CFC11 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: cfc12vmr(:,:)      ! CFC12 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: cfc22vmr(:,:)      ! CFC22 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: ccl4vmr(:,:)       ! CCL4 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: emis(:,:)          ! Surface emissivity
+                                                      !    Dimensions: (ncol,nbndlw)
+
+      integer(kind=im), intent(in) :: inflglw         ! Flag for cloud optical properties
+      integer(kind=im), intent(in) :: iceflglw        ! Flag for ice particle specification
+      integer(kind=im), intent(in) :: liqflglw        ! Flag for liquid droplet specification
+
+      real(kind=rb), intent(in) :: cldfmcl(:,:,:)     ! Cloud fraction
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(in) :: ciwpmcl(:,:,:)     ! In-cloud ice water path (g/m2)
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(in) :: clwpmcl(:,:,:)     ! In-cloud liquid water path (g/m2)
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(in) :: reicmcl(:,:)       ! Cloud ice particle effective size (microns)
+                                                      !    Dimensions: (ncol,nlay)
+                                                      ! specific definition of reicmcl depends on setting of iceflglw:
+                                                      ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
+                                                      !               r_ec must be >= 10.0 microns
+                                                      ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
+                                                      !               r_ec range is limited to 13.0 to 130.0 microns
+                                                      ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
+                                                      !               r_k range is limited to 5.0 to 131.0 microns
+                                                      ! iceflglw = 3: generalized effective size, dge, (Fu, 1996),
+                                                      !               dge range is limited to 5.0 to 140.0 microns
+                                                      !               [dge = 1.0315 * r_ec]
+      real(kind=rb), intent(in) :: relqmcl(:,:)       ! Cloud water drop effective radius (microns)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: taucmcl(:,:,:)     ! In-cloud optical depth
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+!      real(kind=rb), intent(in) :: ssacmcl(:,:,:)    ! In-cloud single scattering albedo
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+                                                      !   for future expansion
+                                                      !   lw scattering not yet available
+!      real(kind=rb), intent(in) :: asmcmcl(:,:,:)    ! In-cloud asymmetry parameter
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+                                                      !   for future expansion
+                                                      !   lw scattering not yet available
+      real(kind=rb), intent(in) :: tauaer(:,:,:)      ! aerosol optical depth
+                                                      !   at mid-point of LW spectral bands
+                                                      !    Dimensions: (ncol,nlay,nbndlw)
+!      real(kind=rb), intent(in) :: ssaaer(:,:,:)     ! aerosol single scattering albedo
+                                                      !    Dimensions: (ncol,nlay,nbndlw)
+                                                      !   for future expansion 
+                                                      !   (lw aerosols/scattering not yet available)
+!      real(kind=rb), intent(in) :: asmaer(:,:,:)     ! aerosol asymmetry parameter
+                                                      !    Dimensions: (ncol,nlay,nbndlw)
+                                                      !   for future expansion 
+                                                      !   (lw aerosols/scattering not yet available)
+
+! ----- Output -----
+
+      real(kind=rb), intent(out) :: uflx(:,:)         ! Total sky longwave upward flux (W/m2)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(out) :: dflx(:,:)         ! Total sky longwave downward flux (W/m2)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(out) :: hr(:,:)           ! Total sky longwave radiative heating rate (K/d)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(out) :: uflxc(:,:)        ! Clear sky longwave upward flux (W/m2)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(out) :: dflxc(:,:)        ! Clear sky longwave downward flux (W/m2)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(out) :: hrc(:,:)          ! Clear sky longwave radiative heating rate (K/d)
+                                                      !    Dimensions: (ncol,nlay)
+
+! ----- Local -----
+
+! Control
+      integer(kind=im) :: nlayers             ! total number of layers
+      integer(kind=im) :: istart              ! beginning band of calculation
+      integer(kind=im) :: iend                ! ending band of calculation
+      integer(kind=im) :: iout                ! output option flag (inactive)
+      integer(kind=im) :: iaer                ! aerosol option flag
+      integer(kind=im) :: iplon               ! column loop index
+      integer(kind=im) :: imca                ! flag for mcica [0=off, 1=on]
+      integer(kind=im) :: ims                 ! value for changing mcica permute seed
+      integer(kind=im) :: k                   ! layer loop index
+      integer(kind=im) :: ig                  ! g-point loop index
+
+! Atmosphere
+      real(kind=rb) :: pavel(nlay+1)          ! layer pressures (mb) 
+      real(kind=rb) :: tavel(nlay+1)          ! layer temperatures (K)
+      real(kind=rb) :: pz(0:nlay+1)           ! level (interface) pressures (hPa, mb)
+      real(kind=rb) :: tz(0:nlay+1)           ! level (interface) temperatures (K)
+      real(kind=rb) :: tbound                 ! surface temperature (K)
+      real(kind=rb) :: coldry(nlay+1)         ! dry air column density (mol/cm2)
+      real(kind=rb) :: wbrodl(nlay+1)         ! broadening gas column density (mol/cm2)
+      real(kind=rb) :: wkl(mxmol,nlay+1)      ! molecular amounts (mol/cm-2)
+      real(kind=rb) :: wx(maxxsec,nlay+1)     ! cross-section amounts (mol/cm-2)
+      real(kind=rb) :: pwvcm                  ! precipitable water vapor (cm)
+      real(kind=rb) :: semiss(nbndlw)         ! lw surface emissivity
+      real(kind=rb) :: fracs(nlay+1,ngptlw)   ! 
+      real(kind=rb) :: taug(nlay+1,ngptlw)    ! gaseous optical depths
+      real(kind=rb) :: taut(nlay+1,ngptlw)    ! gaseous + aerosol optical depths
+
+      real(kind=rb) :: taua(nlay+1,nbndlw)    ! aerosol optical depth
+!      real(kind=rb) :: ssaa(nlay+1,nbndlw)   ! aerosol single scattering albedo
+                                              !   for future expansion 
+                                              !   (lw aerosols/scattering not yet available)
+!      real(kind=rb) :: asma(nlay+1,nbndlw)   ! aerosol asymmetry parameter
+                                              !   for future expansion 
+                                              !   (lw aerosols/scattering not yet available)
+
+! Atmosphere - setcoef
+      integer(kind=im) :: laytrop             ! tropopause layer index
+      integer(kind=im) :: jp(nlay+1)          ! lookup table index 
+      integer(kind=im) :: jt(nlay+1)          ! lookup table index 
+      integer(kind=im) :: jt1(nlay+1)         ! lookup table index 
+      real(kind=rb) :: planklay(nlay+1,nbndlw)! 
+      real(kind=rb) :: planklev(0:nlay+1,nbndlw)! 
+      real(kind=rb) :: plankbnd(nbndlw)       ! 
+
+      real(kind=rb) :: colh2o(nlay+1)         ! column amount (h2o)
+      real(kind=rb) :: colco2(nlay+1)         ! column amount (co2)
+      real(kind=rb) :: colo3(nlay+1)          ! column amount (o3)
+      real(kind=rb) :: coln2o(nlay+1)         ! column amount (n2o)
+      real(kind=rb) :: colco(nlay+1)          ! column amount (co)
+      real(kind=rb) :: colch4(nlay+1)         ! column amount (ch4)
+      real(kind=rb) :: colo2(nlay+1)          ! column amount (o2)
+      real(kind=rb) :: colbrd(nlay+1)         ! column amount (broadening gases)
+
+      integer(kind=im) :: indself(nlay+1)
+      integer(kind=im) :: indfor(nlay+1)
+      real(kind=rb) :: selffac(nlay+1)
+      real(kind=rb) :: selffrac(nlay+1)
+      real(kind=rb) :: forfac(nlay+1)
+      real(kind=rb) :: forfrac(nlay+1)
+
+      integer(kind=im) :: indminor(nlay+1)
+      real(kind=rb) :: minorfrac(nlay+1)
+      real(kind=rb) :: scaleminor(nlay+1)
+      real(kind=rb) :: scaleminorn2(nlay+1)
+
+      real(kind=rb) :: &                      !
+                         fac00(nlay+1), fac01(nlay+1), &
+                         fac10(nlay+1), fac11(nlay+1) 
+      real(kind=rb) :: &                      !
+                         rat_h2oco2(nlay+1),rat_h2oco2_1(nlay+1), &
+                         rat_h2oo3(nlay+1),rat_h2oo3_1(nlay+1), &
+                         rat_h2on2o(nlay+1),rat_h2on2o_1(nlay+1), &
+                         rat_h2och4(nlay+1),rat_h2och4_1(nlay+1), &
+                         rat_n2oco2(nlay+1),rat_n2oco2_1(nlay+1), &
+                         rat_o3co2(nlay+1),rat_o3co2_1(nlay+1)
+
+! Atmosphere/clouds - cldprop
+      integer(kind=im) :: ncbands             ! number of cloud spectral bands
+      integer(kind=im) :: inflag              ! flag for cloud property method
+      integer(kind=im) :: iceflag             ! flag for ice cloud properties
+      integer(kind=im) :: liqflag             ! flag for liquid cloud properties
+
+! Atmosphere/clouds - cldprmc [mcica]
+      real(kind=rb) :: cldfmc(ngptlw,nlay+1)  ! cloud fraction [mcica]
+      real(kind=rb) :: ciwpmc(ngptlw,nlay+1)  ! in-cloud ice water path [mcica]
+      real(kind=rb) :: clwpmc(ngptlw,nlay+1)  ! in-cloud liquid water path [mcica]
+      real(kind=rb) :: relqmc(nlay+1)         ! liquid particle effective radius (microns)
+      real(kind=rb) :: reicmc(nlay+1)         ! ice particle effective size (microns)
+      real(kind=rb) :: taucmc(ngptlw,nlay+1)  ! in-cloud optical depth [mcica]
+!      real(kind=rb) :: ssacmc(ngptlw,nlay+1) ! in-cloud single scattering albedo [mcica]
+                                              !   for future expansion 
+                                              !   (lw scattering not yet available)
+!      real(kind=rb) :: asmcmc(ngptlw,nlay+1) ! in-cloud asymmetry parameter [mcica]
+                                              !   for future expansion 
+                                              !   (lw scattering not yet available)
+
+! Output
+      real(kind=rb) :: totuflux(0:nlay+1)     ! upward longwave flux (w/m2)
+      real(kind=rb) :: totdflux(0:nlay+1)     ! downward longwave flux (w/m2)
+      real(kind=rb) :: fnet(0:nlay+1)         ! net longwave flux (w/m2)
+      real(kind=rb) :: htr(0:nlay+1)          ! longwave heating rate (k/day)
+      real(kind=rb) :: totuclfl(0:nlay+1)     ! clear sky upward longwave flux (w/m2)
+      real(kind=rb) :: totdclfl(0:nlay+1)     ! clear sky downward longwave flux (w/m2)
+      real(kind=rb) :: fnetc(0:nlay+1)        ! clear sky net longwave flux (w/m2)
+      real(kind=rb) :: htrc(0:nlay+1)         ! clear sky longwave heating rate (k/day)
+
+!
+! Initializations
+
+      oneminus = 1._rb - 1.e-6_rb
+      pi = 2._rb * asin(1._rb)
+      fluxfac = pi * 2.e4_rb                  ! orig:   fluxfac = pi * 2.d4  
+      istart = 1
+      iend = 16
+      iout = 0
+      ims = 1
+
+! Set imca to select calculation type:
+!  imca = 0, use standard forward model calculation
+!  imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability
+
+! *** This version uses McICA (imca = 1) ***
+
+! Set icld to select of clear or cloud calculation and cloud overlap method  
+! icld = 0, clear only
+! icld = 1, with clouds using random cloud overlap
+! icld = 2, with clouds using maximum/random cloud overlap
+! icld = 3, with clouds using maximum cloud overlap (McICA only)
+      if (icld.lt.0.or.icld.gt.3) icld = 2
+
+! Set iaer to select aerosol option
+! iaer = 0, no aerosols
+! icld = 10, input total aerosol optical depth (tauaer) directly
+      iaer = 10
+
+! Call model and data initialization, compute lookup tables, perform
+! reduction of g-points from 256 to 140 for input absorption coefficient 
+! data and other arrays.
+!
+! In a GCM this call should be placed in the model initialization
+! area, since this has to be called only once.  
+!      call rrtmg_lw_ini(cpdair)
+
+!  This is the main longitude/column loop within RRTMG.
+      do iplon = 1, ncol
+
+!  Prepare atmospheric profile from GCM for use in RRTMG, and define
+!  other input parameters.  
+
+         call inatm (iplon, nlay, icld, iaer, &
+              play, plev, tlay, tlev, tsfc, h2ovmr, &
+              o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr, &
+              cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, &
+              cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, &
+              nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry, &
+              wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, &
+              cldfmc, taucmc, ciwpmc, clwpmc, reicmc, relqmc, taua)
+
+!  For cloudy atmosphere, use cldprop to set cloud optical properties based on
+!  input cloud physical properties.  Select method based on choices described
+!  in cldprop.  Cloud fraction, water path, liquid droplet and ice particle
+!  effective radius must be passed into cldprop.  Cloud fraction and cloud
+!  optical depth are transferred to rrtmg_lw arrays in cldprop.  
+
+         call cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, &
+                      clwpmc, reicmc, relqmc, ncbands, taucmc)
+
+! 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(nlayers, istart, pavel, tavel, tz, tbound, semiss, &
+                      coldry, wkl, wbrodl, &
+                      laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
+                      colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
+                      colbrd, fac00, fac01, fac10, fac11, &
+                      rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
+                      rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
+                      rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
+                      selffac, selffrac, indself, forfac, forfrac, indfor, &
+                      minorfrac, scaleminor, scaleminorn2, indminor)
+
+!  Calculate the gaseous optical depths and Planck fractions for 
+!  each longwave spectral band.
+
+         call taumol(nlayers, pavel, wx, coldry, &
+                     laytrop, jp, jt, jt1, planklay, planklev, plankbnd, &
+                     colh2o, colco2, colo3, coln2o, colco, colch4, colo2, &
+                     colbrd, fac00, fac01, fac10, fac11, &
+                     rat_h2oco2, rat_h2oco2_1, rat_h2oo3, rat_h2oo3_1, &
+                     rat_h2on2o, rat_h2on2o_1, rat_h2och4, rat_h2och4_1, &
+                     rat_n2oco2, rat_n2oco2_1, rat_o3co2, rat_o3co2_1, &
+                     selffac, selffrac, indself, forfac, forfrac, indfor, &
+                     minorfrac, scaleminor, scaleminorn2, indminor, &
+                     fracs, taug)
+
+
+! Combine gaseous and aerosol optical depths, if aerosol active
+         if (iaer .eq. 0) then
+            do k = 1, nlayers
+               do ig = 1, ngptlw
+                  taut(k,ig) = taug(k,ig)
+               enddo
+            enddo
+         elseif (iaer .eq. 10) then
+            do k = 1, nlayers
+               do ig = 1, ngptlw
+                  taut(k,ig) = taug(k,ig) + taua(k,ngb(ig))
+               enddo
+            enddo
+         endif
+
+! Call the radiative transfer routine.
+! Either routine can be called to do clear sky calculation.  If clouds
+! are present, then select routine based on cloud overlap assumption
+! to be used.  Clear sky calculation is done simultaneously.
+! For McICA, RTRNMC is called for clear and cloudy calculations.
+
+         call rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, &
+                     cldfmc, taucmc, planklay, planklev, plankbnd, &
+                     pwvcm, fracs, taut, &
+                     totuflux, totdflux, fnet, htr, &
+                     totuclfl, totdclfl, fnetc, htrc )
+
+!  Transfer up and down fluxes and heating rate to output arrays.
+!  Vertical indexing goes from bottom to top; reverse here for GCM if necessary.
+
+         do k = 0, nlayers
+            uflx(iplon,k+1) = totuflux(k)
+            dflx(iplon,k+1) = totdflux(k)
+            uflxc(iplon,k+1) = totuclfl(k)
+            dflxc(iplon,k+1) = totdclfl(k)
+         enddo
+         do k = 0, nlayers-1
+            hr(iplon,k+1) = htr(k)
+            hrc(iplon,k+1) = htrc(k)
+         enddo
+
+      enddo
+
+      end subroutine rrtmg_lw
+
+!***************************************************************************
+      subroutine inatm (iplon, nlay, icld, iaer, &
+              play, plev, tlay, tlev, tsfc, h2ovmr, &
+              o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr, &
+              cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, &
+              cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, &
+              nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry, &
+              wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, &
+              cldfmc, taucmc, ciwpmc, clwpmc, reicmc, relqmc, taua)
+!***************************************************************************
+!
+!  Input atmospheric profile from GCM, and prepare it for use in RRTMG_LW.
+!  Set other RRTMG_LW input parameters.  
+!
+!***************************************************************************
+
+! --------- Modules ----------
+
+      use parrrtm, only : nbndlw, ngptlw, nmol, maxxsec, mxmol
+      use rrlw_con, only: fluxfac, heatfac, oneminus, pi, grav, avogad
+      use rrlw_wvn, only: ng, nspa, nspb, wavenum1, wavenum2, delwave, ixindx
+
+! ------- Declarations -------
+
+! ----- Input -----
+      integer(kind=im), intent(in) :: iplon           ! column loop index
+      integer(kind=im), intent(in) :: nlay            ! Number of model layers
+      integer(kind=im), intent(in) :: icld            ! clear/cloud and cloud overlap flag
+      integer(kind=im), intent(in) :: iaer            ! aerosol option flag
+
+      real(kind=rb), intent(in) :: play(:,:)          ! Layer pressures (hPa, mb)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: plev(:,:)          ! Interface pressures (hPa, mb)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(in) :: tlay(:,:)          ! Layer temperatures (K)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: tlev(:,:)          ! Interface temperatures (K)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(in) :: tsfc(:)            ! Surface temperature (K)
+                                                      !    Dimensions: (ncol)
+      real(kind=rb), intent(in) :: h2ovmr(:,:)        ! H2O volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: o3vmr(:,:)         ! O3 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: co2vmr(:,:)        ! CO2 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: ch4vmr(:,:)        ! Methane volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: n2ovmr(:,:)        ! Nitrous oxide volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: o2vmr(:,:)         ! Oxygen volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: cfc11vmr(:,:)      ! CFC11 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: cfc12vmr(:,:)      ! CFC12 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: cfc22vmr(:,:)      ! CFC22 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: ccl4vmr(:,:)       ! CCL4 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: emis(:,:)          ! Surface emissivity
+                                                      !    Dimensions: (ncol,nbndlw)
+
+      integer(kind=im), intent(in) :: inflglw         ! Flag for cloud optical properties
+      integer(kind=im), intent(in) :: iceflglw        ! Flag for ice particle specification
+      integer(kind=im), intent(in) :: liqflglw        ! Flag for liquid droplet specification
+
+      real(kind=rb), intent(in) :: cldfmcl(:,:,:)     ! Cloud fraction
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(in) :: ciwpmcl(:,:,:)     ! In-cloud ice water path (g/m2)
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(in) :: clwpmcl(:,:,:)     ! In-cloud liquid water path (g/m2)
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(in) :: relqmcl(:,:)       ! Cloud water drop effective radius (microns)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: reicmcl(:,:)       ! Cloud ice effective size (microns)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: taucmcl(:,:,:)     ! In-cloud optical depth
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(in) :: tauaer(:,:,:)      ! Aerosol optical depth
+                                                      !    Dimensions: (ncol,nlay,nbndlw)
+
+! ----- Output -----
+! Atmosphere
+      integer(kind=im), intent(out) :: nlayers        ! number of layers
+
+      real(kind=rb), intent(out) :: pavel(:)          ! layer pressures (mb) 
+                                                      !    Dimensions: (nlay)
+      real(kind=rb), intent(out) :: tavel(:)          ! layer temperatures (K)
+                                                      !    Dimensions: (nlay)
+      real(kind=rb), intent(out) :: pz(0:)            ! level (interface) pressures (hPa, mb)
+                                                      !    Dimensions: (0:nlay)
+      real(kind=rb), intent(out) :: tz(0:)            ! level (interface) temperatures (K)
+                                                      !    Dimensions: (0:nlay)
+      real(kind=rb), intent(out) :: tbound            ! surface temperature (K)
+      real(kind=rb), intent(out) :: coldry(:)         ! dry air column density (mol/cm2)
+                                                      !    Dimensions: (nlay)
+      real(kind=rb), intent(out) :: wbrodl(:)         ! broadening gas column density (mol/cm2)
+                                                      !    Dimensions: (nlay)
+      real(kind=rb), intent(out) :: wkl(:,:)          ! molecular amounts (mol/cm-2)
+                                                      !    Dimensions: (mxmol,nlay)
+      real(kind=rb), intent(out) :: wx(:,:)           ! cross-section amounts (mol/cm-2)
+                                                      !    Dimensions: (maxxsec,nlay)
+      real(kind=rb), intent(out) :: pwvcm             ! precipitable water vapor (cm)
+      real(kind=rb), intent(out) :: semiss(:)         ! lw surface emissivity
+                                                      !    Dimensions: (nbndlw)
+
+! Atmosphere/clouds - cldprop
+      integer(kind=im), intent(out) :: inflag         ! flag for cloud property method
+      integer(kind=im), intent(out) :: iceflag        ! flag for ice cloud properties
+      integer(kind=im), intent(out) :: liqflag        ! flag for liquid cloud properties
+
+      real(kind=rb), intent(out) :: cldfmc(:,:)       ! cloud fraction [mcica]
+                                                      !    Dimensions: (ngptlw,nlay)
+      real(kind=rb), intent(out) :: ciwpmc(:,:)       ! in-cloud ice water path [mcica]
+                                                      !    Dimensions: (ngptlw,nlay)
+      real(kind=rb), intent(out) :: clwpmc(:,:)       ! in-cloud liquid water path [mcica]
+                                                      !    Dimensions: (ngptlw,nlay)
+      real(kind=rb), intent(out) :: relqmc(:)         ! liquid particle effective radius (microns)
+                                                      !    Dimensions: (nlay)
+      real(kind=rb), intent(out) :: reicmc(:)         ! ice particle effective size (microns)
+                                                      !    Dimensions: (nlay)
+      real(kind=rb), intent(out) :: taucmc(:,:)       ! in-cloud optical depth [mcica]
+                                                      !    Dimensions: (ngptlw,nlay)
+      real(kind=rb), intent(out) :: taua(:,:)         ! aerosol optical depth
+                                                      !    Dimensions: (nlay,nbndlw)
+
+
+! ----- Local -----
+      real(kind=rb), parameter :: amd = 28.9660_rb    ! Effective molecular weight of dry air (g/mol)
+      real(kind=rb), parameter :: amw = 18.0160_rb    ! Molecular weight of water vapor (g/mol)
+!      real(kind=rb), parameter :: amc = 44.0098_rb    ! Molecular weight of carbon dioxide (g/mol)
+!      real(kind=rb), parameter :: amo = 47.9998_rb    ! Molecular weight of ozone (g/mol)
+!      real(kind=rb), parameter :: amo2 = 31.9999_rb   ! Molecular weight of oxygen (g/mol)
+!      real(kind=rb), parameter :: amch4 = 16.0430_rb  ! Molecular weight of methane (g/mol)
+!      real(kind=rb), parameter :: amn2o = 44.0128_rb  ! Molecular weight of nitrous oxide (g/mol)
+!      real(kind=rb), parameter :: amc11 = 137.3684_rb ! Molecular weight of CFC11 (g/mol) - CCL3F
+!      real(kind=rb), parameter :: amc12 = 120.9138_rb ! Molecular weight of CFC12 (g/mol) - CCL2F2
+!      real(kind=rb), parameter :: amc22 = 86.4688_rb  ! Molecular weight of CFC22 (g/mol) - CHCLF2
+!      real(kind=rb), parameter :: amcl4 = 153.823_rb  ! Molecular weight of CCL4 (g/mol) - CCL4
+
+! Set molecular weight ratios (for converting mmr to vmr)
+!  e.g. h2ovmr = h2ommr * amdw)
+      real(kind=rb), parameter :: amdw = 1.607793_rb  ! Molecular weight of dry air / water vapor
+      real(kind=rb), parameter :: amdc = 0.658114_rb  ! Molecular weight of dry air / carbon dioxide
+      real(kind=rb), parameter :: amdo = 0.603428_rb  ! Molecular weight of dry air / ozone
+      real(kind=rb), parameter :: amdm = 1.805423_rb  ! Molecular weight of dry air / methane
+      real(kind=rb), parameter :: amdn = 0.658090_rb  ! Molecular weight of dry air / nitrous oxide
+      real(kind=rb), parameter :: amdo2 = 0.905140_rb ! Molecular weight of dry air / oxygen
+      real(kind=rb), parameter :: amdc1 = 0.210852_rb ! Molecular weight of dry air / CFC11
+      real(kind=rb), parameter :: amdc2 = 0.239546_rb ! Molecular weight of dry air / CFC12
+
+      integer(kind=im) :: isp, l, ix, n, imol, ib, ig   ! Loop indices
+      real(kind=rb) :: amm, amttl, wvttl, wvsh, summol  
+
+! Add one to nlayers here to include extra model layer at top of atmosphere
+      nlayers = nlay
+
+!  Initialize all molecular amounts and cloud properties to zero here, then pass input amounts
+!  into RRTM arrays below.
+
+      wkl(:,:) = 0.0_rb
+      wx(:,:) = 0.0_rb
+      cldfmc(:,:) = 0.0_rb
+      taucmc(:,:) = 0.0_rb
+      ciwpmc(:,:) = 0.0_rb
+      clwpmc(:,:) = 0.0_rb
+      reicmc(:) = 0.0_rb
+      relqmc(:) = 0.0_rb
+      taua(:,:) = 0.0_rb
+      amttl = 0.0_rb
+      wvttl = 0.0_rb
+ 
+!  Set surface temperature.
+      tbound = tsfc(iplon)
+
+!  Install input GCM arrays into RRTMG_LW arrays for pressure, temperature,
+!  and molecular amounts.  
+!  Pressures are input in mb, or are converted to mb here.
+!  Molecular amounts are input in volume mixing ratio, or are converted from 
+!  mass mixing ratio (or specific humidity for h2o) to volume mixing ratio
+!  here. These are then converted to molecular amount (molec/cm2) below.  
+!  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.  
+!  Note: In RRTMG, layer indexing goes from bottom to top, and coding below
+!  assumes GCM input fields are also bottom to top. Input layer indexing
+!  from GCM fields should be reversed here if necessary.
+
+      pz(0) = plev(iplon,1)
+      tz(0) = tlev(iplon,1)
+      do l = 1, nlayers
+         pavel(l) = play(iplon,l)
+         tavel(l) = tlay(iplon,l)
+         pz(l) = plev(iplon,l+1)
+         tz(l) = tlev(iplon,l+1)
+! For h2o input in vmr:
+         wkl(1,l) = h2ovmr(iplon,l)
+! For h2o input in mmr:
+!         wkl(1,l) = h2o(iplon,l)*amdw
+! For h2o input in specific humidity;
+!         wkl(1,l) = (h2o(iplon,l)/(1._rb - h2o(iplon,l)))*amdw
+         wkl(2,l) = co2vmr(iplon,l)
+         wkl(3,l) = o3vmr(iplon,l)
+         wkl(4,l) = n2ovmr(iplon,l)
+         wkl(6,l) = ch4vmr(iplon,l)
+         wkl(7,l) = o2vmr(iplon,l)
+         amm = (1._rb - wkl(1,l)) * amd + wkl(1,l) * amw            
+         coldry(l) = (pz(l-1)-pz(l)) * 1.e3_rb * avogad / &
+                     (1.e2_rb * grav * amm * (1._rb + wkl(1,l)))
+      enddo
+
+! Set cross section molecule amounts from input; convert to vmr if necessary
+      do l=1, nlayers
+         wx(1,l) = ccl4vmr(iplon,l)
+         wx(2,l) = cfc11vmr(iplon,l)
+         wx(3,l) = cfc12vmr(iplon,l)
+         wx(4,l) = cfc22vmr(iplon,l)
+      enddo      
+
+! The following section can be used to set values for an additional layer (from
+! the GCM top level to 1.e-4 mb) for improved calculation of TOA fluxes. 
+! Temperature and molecular amounts in the extra model layer are set to 
+! their values in the top GCM model layer, though these can be modified
+! here if necessary. 
+! If this feature is utilized, increase nlayers by one above, limit the two
+! loops above to (nlayers-1), and set the top most (extra) layer values here. 
+
+!      pavel(nlayers) = 0.5_rb * pz(nlayers-1)
+!      tavel(nlayers) = tavel(nlayers-1)
+!      pz(nlayers) = 1.e-4_rb
+!      tz(nlayers-1) = 0.5_rb * (tavel(nlayers)+tavel(nlayers-1))
+!      tz(nlayers) = tz(nlayers-1)
+!      wkl(1,nlayers) = wkl(1,nlayers-1)
+!      wkl(2,nlayers) = wkl(2,nlayers-1)
+!      wkl(3,nlayers) = wkl(3,nlayers-1)
+!      wkl(4,nlayers) = wkl(4,nlayers-1)
+!      wkl(6,nlayers) = wkl(6,nlayers-1)
+!      wkl(7,nlayers) = wkl(7,nlayers-1)
+!      amm = (1._rb - wkl(1,nlayers-1)) * amd + wkl(1,nlayers-1) * amw
+!      coldry(nlayers) = (pz(nlayers-1)) * 1.e3_rb * avogad / &
+!                        (1.e2_rb * grav * amm * (1._rb + wkl(1,nlayers-1)))
+!      wx(1,nlayers) = wx(1,nlayers-1)
+!      wx(2,nlayers) = wx(2,nlayers-1)
+!      wx(3,nlayers) = wx(3,nlayers-1)
+!      wx(4,nlayers) = wx(4,nlayers-1)
+
+! At this point all molecular amounts in wkl and wx are in volume mixing ratio; 
+! convert to molec/cm2 based on coldry for use in rrtm.  also, compute precipitable
+! water vapor for diffusivity angle adjustments in rtrn and rtrnmr.
+
+      do l = 1, nlayers
+         summol = 0.0_rb
+         do imol = 2, nmol
+            summol = summol + wkl(imol,l)
+         enddo
+         wbrodl(l) = coldry(l) * (1._rb - summol)
+         do imol = 1, nmol
+            wkl(imol,l) = coldry(l) * wkl(imol,l)
+         enddo
+         amttl = amttl + coldry(l)+wkl(1,l)
+         wvttl = wvttl + wkl(1,l)
+         do ix = 1,maxxsec
+            if (ixindx(ix) .ne. 0) then
+               wx(ixindx(ix),l) = coldry(l) * wx(ix,l) * 1.e-20_rb
+            endif
+         enddo
+      enddo
+
+      wvsh = (amw * wvttl) / (amd * amttl)
+      pwvcm = wvsh * (1.e3_rb * pz(0)) / (1.e2_rb * grav)
+
+! Set spectral surface emissivity for each longwave band.  
+
+      do n=1,nbndlw
+         semiss(n) = emis(iplon,n)
+!          semiss(n) = 1.0_rb
+      enddo
+
+! Transfer aerosol optical properties to RRTM variable;
+! modify to reverse layer indexing here if necessary.
+
+     if (iaer .ge. 1) then
+        do l = 1, nlayers
+           do ib = 1, nbndlw
+              taua(l,ib) = tauaer(iplon,l,ib)
+           enddo
+        enddo
+      endif
+
+! Transfer cloud fraction and cloud optical properties to RRTM variables,
+! modify to reverse layer indexing here if necessary.
+
+      if (icld .ge. 1) then 
+         inflag = inflglw
+         iceflag = iceflglw
+         liqflag = liqflglw
+
+! Move incoming GCM cloud arrays to RRTMG cloud arrays.
+! For GCM input, incoming reicmcl is defined based on selected ice parameterization (inflglw)
+
+         do l = 1, nlayers
+            do ig = 1, ngptlw
+               cldfmc(ig,l) = cldfmcl(ig,iplon,l)
+               taucmc(ig,l) = taucmcl(ig,iplon,l)
+               ciwpmc(ig,l) = ciwpmcl(ig,iplon,l)
+               clwpmc(ig,l) = clwpmcl(ig,iplon,l)
+            enddo
+            reicmc(l) = reicmcl(iplon,l)
+            relqmc(l) = relqmcl(iplon,l)
+         enddo
+
+! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer.
+
+!         cldfmc(:,nlayers) = 0.0_rb
+!         taucmc(:,nlayers) = 0.0_rb
+!         ciwpmc(:,nlayers) = 0.0_rb
+!         clwpmc(:,nlayers) = 0.0_rb
+!         reicmc(nlayers) = 0.0_rb
+!         relqmc(nlayers) = 0.0_rb
+!         taua(nlayers,:) = 0.0_rb
+
+      endif
+      
+      end subroutine inatm
+
+      end module rrtmg_lw_rad
+
+!------------------------------------------------------------------
+MODULE module_ra_rrtmg_lw
+
+use module_model_constants, only : cp
+use module_wrf_error
+!use module_dm
+
+use parrrtm, only : nbndlw, ngptlw
+use rrtmg_lw_init, only: rrtmg_lw_ini
+use rrtmg_lw_rad, only: rrtmg_lw
+use mcica_subcol_gen_lw, only: mcica_subcol_lw
+
+    real retab(95)
+    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
+    ! For buffer layer adjustment.  Steven Cavallo, Dec 2010.
+    integer , save    :: nlayers    
+    real, PARAMETER :: deltap = 4.  ! Pressure interval for buffer layer in mb
+    
+CONTAINS
+
+!------------------------------------------------------------------
+   SUBROUTINE RRTMG_LWRAD(                                        &
+                       rthratenlw,                                &
+                       lwupt, lwuptc, lwdnt, lwdntc,              &
+                       lwupb, lwupbc, lwdnb, lwdnbc,              &
+!                      lwupflx, lwupflxc, lwdnflx, lwdnflxc,      &
+                       glw, olr, lwcf, emiss,                     &
+                       p8w, p3d, pi3d,                            &
+                       dz8w, tsk, t3d, t8w, rho3d, r, g,          &
+                       icloud, warm_rain, cldfra3d,               &
+                       f_ice_phy, f_rain_phy,                     &
+                       xland, xice, snow,                         &
+                       qv3d, qc3d, qr3d,                          &
+                       qi3d, qs3d, qg3d,                          &
+                       f_qv, f_qc, f_qr, f_qi, f_qs, f_qg,        &
+                       tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4,   & ! czhao 
+                       tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8,   & ! czhao 
+                       tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12,   & ! czhao 
+                       tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16,   & ! czhao 
+                       aer_ra_feedback,                           & !czhao
+!jdfcz                 progn,prescribe,                           & !czhao
+                       progn,                                     & !czhao
+                       qndrop3d,f_qndrop,                         & !czhao
+                       ids,ide, jds,jde, kds,kde,                 & 
+                       ims,ime, jms,jme, kms,kme,                 &
+                       its,ite, jts,jte, kts,kte,                 &
+                       lwupflx, lwupflxc, lwdnflx, lwdnflxc       &
+                                                                  )
+!------------------------------------------------------------------
+   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)  ::                            RTHRATENLW
+
+   REAL, DIMENSION( ims:ime, jms:jme )                          , &
+         INTENT(INOUT)  ::                                   GLW, &
+                                                             OLR, &
+                                                            LWCF
+
+   REAL, DIMENSION( ims:ime, jms:jme )                          , &
+         INTENT(IN   )  ::                                 EMISS, &
+                                                             TSK
+
+   REAL, INTENT(IN  )   ::                                   R,G
+
+   REAL, DIMENSION( ims:ime, jms:jme )                          , &
+         INTENT(IN   )  ::                                 XLAND, &
+                                                            XICE, &
+                                                            SNOW
+!
+! Optional
+!
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
+         OPTIONAL                                               , &
+         INTENT(IN   ) ::                                         &
+                                                        CLDFRA3D, &
+                                                            QV3D, &
+                                                            QC3D, &
+                                                            QR3D, &
+                                                            QI3D, &
+                                                            QS3D, &
+                                                            QG3D, &
+                                                        QNDROP3D
+   real pi,third,relconst,lwpmin,rhoh2o
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
+         OPTIONAL                                               , &
+         INTENT(IN   ) ::                                         &
+                                                       F_ICE_PHY, &
+                                                      F_RAIN_PHY
+
+   LOGICAL, OPTIONAL, INTENT(IN)   ::                             &
+                                   F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP
+! Optional
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL ,       &
+         INTENT(IN    ) :: tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao 
+                           tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao 
+                           tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao 
+                           tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16
+
+   INTEGER,    INTENT(IN  ), OPTIONAL   ::       aer_ra_feedback
+!jdfcz   INTEGER,    INTENT(IN  ), OPTIONAL   ::       progn,prescribe
+   INTEGER,    INTENT(IN  ), OPTIONAL   ::       progn
+
+      real, parameter :: thresh=1.e-9
+      real slope
+      character(len=200) :: msg
+
+
+! Top of atmosphere and surface longwave fluxes (W m-2)
+   REAL, DIMENSION( ims:ime, jms:jme ),                           &
+         OPTIONAL, INTENT(INOUT) ::                               &
+                                       LWUPT,LWUPTC,LWDNT,LWDNTC, &
+                                       LWUPB,LWUPBC,LWDNB,LWDNBC
+
+! Layer longwave fluxes (including extra layer above model top)
+! Vertical ordering is from bottom to top (W m-2)
+   REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ),                &
+         OPTIONAL, INTENT(OUT) ::                                 &
+                               LWUPFLX,LWUPFLXC,LWDNFLX,LWDNFLXC
+
+!  LOCAL VARS
+ 
+   REAL, DIMENSION( kts:kte+1 ) ::                          Pw1D, &
+                                                            Tw1D
+
+   REAL, DIMENSION( kts:kte ) ::                          TTEN1D, &
+                                                        CLDFRA1D, &
+                                                            DZ1D, &
+                                                             P1D, &
+                                                             T1D, &
+                                                            QV1D, &
+                                                            QC1D, &
+                                                            QR1D, &
+                                                            QI1D, &
+                                                            QS1D, &
+                                                            QG1D, &
+                                                          qndrop1d 
+
+! Added local arrays for RRTMG
+    integer ::                                              ncol, &
+                                                            nlay, &
+                                                            icld, &
+                                                         inflglw, &
+                                                        iceflglw, &
+                                                        liqflglw
+! Dimension with extra layer from model top to TOA
+    real, dimension( 1, kts:nlayers+1 )  ::                 plev, &
+                                                            tlev
+    real, dimension( 1, kts:nlayers )  ::                   play, &
+                                                            tlay, &
+                                                          h2ovmr, &
+                                                           o3vmr, &
+                                                          co2vmr, &
+                                                           o2vmr, &
+                                                          ch4vmr, &
+                                                          n2ovmr, &
+                                                        cfc11vmr, &
+                                                        cfc12vmr, &
+                                                        cfc22vmr, &
+                                                         ccl4vmr
+    real, dimension( kts:nlayers )  ::                     o3mmr
+! For old cloud property specification for rrtm_lw
+    real, dimension( kts:kte )  ::                          clwp, &
+                                                            ciwp, &
+                                                            plwp, &
+                                                            piwp
+! Surface emissivity (for 16 LW spectral bands)
+    real, dimension( 1, nbndlw )  ::                        emis
+! Dimension with extra layer from model top to TOA, 
+! though no clouds are allowed in extra layer
+    real, dimension( 1, kts:nlayers )  ::                 clwpth, &
+                                                          ciwpth, &
+                                                             rel, &
+                                                             rei, &
+                                                         cldfrac, &
+                                                         relqmcl, &
+                                                         reicmcl
+    real, dimension( nbndlw, 1, kts:nlayers )  ::        taucld
+    real, dimension( ngptlw, 1, kts:nlayers )  ::        cldfmcl, &
+                                                         clwpmcl, &
+                                                         ciwpmcl, &
+                                                         taucmcl
+    real, dimension( 1, kts:nlayers, nbndlw )  ::           tauaer
+
+! Output arrays contain extra layer from model top to TOA
+    real, dimension( 1, kts:nlayers+1 )  ::                 uflx, &
+                                                            dflx, &
+                                                           uflxc, &
+                                                           dflxc
+    real, dimension( 1, kts:nlayers )  ::                    hr, &
+                                                             hrc
+
+    real, dimension ( 1 ) ::                                tsfc, &
+                                                              ps
+    real ::                                                   ro, &
+                                                              dz
+
+! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
+! carbon dioxide (379 ppmv)
+    real :: co2
+    data co2 / 379.e-6 / 
+! methane (1774 ppbv)
+    real :: ch4
+    data ch4 / 1774.e-9 / 
+! nitrous oxide (319 ppbv)
+    real :: n2o
+    data n2o / 319.e-9 / 
+! cfc-11 (251 ppt)
+    real :: cfc11
+    data cfc11 / 0.251e-9 / 
+! cfc-12 (538 ppt)
+    real :: cfc12
+    data cfc12 / 0.538e-9 / 
+! cfc-22 (169 ppt)
+    real :: cfc22
+    data cfc22 / 0.169e-9 / 
+! ccl4 (93 ppt)
+    real :: ccl4
+    data ccl4 / 0.093e-9 / 
+! Set oxygen volume mixing ratio (for o2mmr=0.23143)
+    real :: o2
+    data o2 / 0.209488 /
+
+    integer :: iplon, irng, permuteseed
+    integer :: nb
+
+! For old cloud property specification for rrtm_lw
+! Cloud and precipitation absorption coefficients
+    real :: abcw,abice,abrn,absn
+    data abcw /0.144/
+    data abice /0.0735/
+    data abrn /0.330e-3/
+    data absn /2.34e-3/
+
+! Molecular weights and ratios for converting mmr to vmr units
+!    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 :: amo2      ! Molecular weight of oxygen (g/mol)              
+! Atomic weights for conversion from mass to volume mixing ratios                
+!    data amd   /  28.9660   /                                                  
+!    data amw   /  18.0160   /                                                  
+!    data amo   /  47.9998   /                                                  
+!    data amo2  /  31.9999   /
+                                                                                 
+    real :: amdw     ! Molecular weight of dry air / water vapor  
+    real :: amdo     ! Molecular weight of dry air / ozone
+    real :: amdo2    ! Molecular weight of dry air / oxygen
+    data amdw /  1.607793 /                                                    
+    data amdo /  0.603461 /
+    data amdo2 / 0.905190 /
+    
+!!
+    real, dimension( 1, 1:kte-kts+1 )  :: pdel         ! Layer pressure thickness (mb)
+
+    real, dimension(1, 1:kte-kts+1) ::   cicewp, &     ! in-cloud cloud ice water path
+                                         cliqwp, &     ! in-cloud cloud liquid water path
+                                          reliq, &     ! effective drop radius (microns)
+                                          reice        ! ice effective drop size (microns)
+    real :: gliqwp, gicewp, gravmks
+
+!
+!    REAL   ::  TSFC,GLW0,OLR0,EMISS0,FP
+
+    real, dimension (1) :: landfrac, landm, snowh, icefrac
+
+    integer :: pcols, pver
+
+!
+    INTEGER :: i,j,K
+    LOGICAL :: predicate
+
+! Added for top of model adjustment.  Steven Cavallo NCAR/MMM December 2010
+    INTEGER, PARAMETER :: nproflevs = 60 ! Constant, from the table
+    INTEGER :: L, LL, klev               ! Loop indices      
+    REAL, DIMENSION( kts:nlayers+1 ) :: varint
+    REAL :: wght,vark,vark1       
+    REAL :: PPROF(nproflevs), TPROF(nproflevs)            
+    ! Weighted mean pressure and temperature profiles from midlatitude 
+    ! summer (MLS),midlatitude winter (MLW), sub-Arctic 
+    ! winter (SAW),sub-Arctic summer (SAS), and tropical (TROP) 
+    ! standard atmospheres.
+    DATA PPROF   /1000.00,855.47,731.82,626.05,535.57,458.16,     &
+                  391.94,335.29,286.83,245.38,209.91,179.57,      &
+                  153.62,131.41,112.42,96.17,82.27,70.38,         &
+                  60.21,51.51,44.06,37.69,32.25,27.59,            &
+                  23.60,20.19,17.27,14.77,12.64,10.81,            &
+                  9.25,7.91,6.77,5.79,4.95,4.24,                  &
+                  3.63,3.10,2.65,2.27,1.94,1.66,                  &
+                  1.42,1.22,1.04,0.89,0.76,0.65,                  &
+                  0.56,0.48,0.41,0.35,0.30,0.26,                  &
+                  0.22,0.19,0.16,0.14,0.12,0.10/
+    DATA TPROF   /286.96,281.07,275.16,268.11,260.56,253.02,      &
+         	  245.62,238.41,231.57,225.91,221.72,217.79,      &
+		  215.06,212.74,210.25,210.16,210.69,212.14,      &
+		  213.74,215.37,216.82,217.94,219.03,220.18,      &
+		  221.37,222.64,224.16,225.88,227.63,229.51,      &
+		  231.50,233.73,236.18,238.78,241.60,244.44,      &
+		  247.35,250.33,253.32,256.30,259.22,262.12,      &
+		  264.80,266.50,267.59,268.44,268.69,267.76,      &
+		  266.13,263.96,261.54,258.93,256.15,253.23,      &
+		  249.89,246.67,243.48,240.25,236.66,233.86/	
+!------------------------------------------------------------------
+#ifdef WRF_CHEM
+      IF ( aer_ra_feedback == 1) then
+      IF ( .NOT. &
+      ( PRESENT(tauaerlw1) .AND. &
+        PRESENT(tauaerlw2) .AND. &
+        PRESENT(tauaerlw3) .AND. &
+        PRESENT(tauaerlw4) .AND. &
+        PRESENT(tauaerlw5) .AND. &
+        PRESENT(tauaerlw6) .AND. &
+        PRESENT(tauaerlw7) .AND. &
+        PRESENT(tauaerlw8) .AND. &
+        PRESENT(tauaerlw9) .AND. &
+        PRESENT(tauaerlw10) .AND. &
+        PRESENT(tauaerlw11) .AND. &
+        PRESENT(tauaerlw12) .AND. &
+        PRESENT(tauaerlw13) .AND. &
+        PRESENT(tauaerlw14) .AND. &
+        PRESENT(tauaerlw15) .AND. &
+        PRESENT(tauaerlw16) ) ) THEN
+      CALL wrf_error_fatal  &
+      ('Warning: missing fields required for aerosol radiation' )
+      ENDIF
+      ENDIF
+#endif
+
+
+!-----CALCULATE LONG WAVE RADIATION
+!                                                              
+! All fields are ordered vertically from bottom to top
+! Pressures are in mb
+
+! latitude loop
+  j_loop: do j = jts,jte
+
+! longitude loop
+     i_loop: do i = its,ite
+
+         do k=kts,kte+1
+            Pw1D(K) = p8w(I,K,J)/100.
+            Tw1D(K) = t8w(I,K,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
+            QV1D(K)=QV3D(I,K,J)
+            QV1D(K)=max(0.,QV1D(K))
+         ENDDO
+
+         DO K=kts,kte
+            TTEN1D(K)=0.
+            T1D(K)=T3D(I,K,J)
+            P1D(K)=P3D(I,K,J)/100.
+            DZ1D(K)=dz8w(I,K,J)
+         ENDDO
+
+! moist variables
+
+         IF (ICLOUD .ne. 0) THEN
+            IF ( PRESENT( CLDFRA3D ) ) THEN
+              DO K=kts,kte
+                 CLDFRA1D(k)=CLDFRA3D(I,K,J)
+              ENDDO
+            ENDIF
+
+            IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
+              IF ( F_QC) THEN
+                 DO K=kts,kte
+                    QC1D(K)=QC3D(I,K,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
+                    QR1D(K)=QR3D(I,K,J)
+                    QR1D(K)=max(0.,QR1D(K))
+                 ENDDO
+              ENDIF
+            ENDIF
+
+            IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN
+             IF (F_QNDROP) THEN
+              DO K=kts,kte
+               qndrop1d(K)=qndrop3d(I,K,J)
+              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
+
+! For MP option 3
+            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
+               IF (F_QI) THEN
+                  DO K=kts,kte
+                     QI1D(K)=QI3D(I,K,J)
+                     QI1D(K)=max(0.,QI1D(K))
+                  ENDDO
+               ENDIF
+            ENDIF
+
+            IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
+               IF (F_QS) THEN
+                  DO K=kts,kte
+                     QS1D(K)=QS3D(I,K,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
+                     QG1D(K)=QG3D(I,K,J)
+                     QG1D(K)=max(0.,QG1D(K))
+                  ENDDO
+               ENDIF
+            ENDIF
+
+! mji - For MP option 5
+            IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
+               IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
+                  DO K=kts,kte
+                     qi1d(k) = qs3d(i,k,j)
+                     qc1d(k) = qc3d(i,k,j)
+                     qi1d(k) = max(0.,qi1d(k))
+                     qc1d(k) = max(0.,qc1d(k))
+                  ENDDO
+               ENDIF
+            ENDIF
+
+        ENDIF
+
+!         EMISS0=EMISS(I,J)
+!         GLW0=0. 
+!         OLR0=0. 
+!         TSFC=TSK(I,J)
+         DO K=kts,kte
+            QV1D(K)=AMAX1(QV1D(K),1.E-12) 
+         ENDDO
+
+! Set up input for longwave
+         ncol = 1
+! Add extra layer from top of model to top of atmosphere
+!         nlay = (kte - kts + 1) + 1
+! Edited for top of model adjustment (nlayers = kte + 1).  
+! Steven Cavallo, December 2010
+          nlay = nlayers ! Keep these indices the same
+
+
+! Select cloud liquid and ice optics parameterization options
+! For passing in cloud optical properties directly:
+!         icld = 2
+!         inflglw = 0
+!         iceflglw = 0
+!         liqflglw = 0
+! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
+         icld = 2
+         inflglw = 2
+         iceflglw = 3
+         liqflglw = 1
+
+! Layer indexing goes bottom to top here for all fields.
+! Water vapor and ozone are converted from mmr to vmr. 
+! Pressures are in units of mb here. 
+         plev(ncol,1) = pw1d(1)
+         tlev(ncol,1) = tw1d(1)
+         tsfc(ncol) = tsk(i,j)
+         do k = kts, kte
+            play(ncol,k) = p1d(k)
+            plev(ncol,k+1) = pw1d(k+1)
+            pdel(ncol,k) = plev(ncol,k) - plev(ncol,k+1)
+            tlay(ncol,k) = t1d(k)
+            tlev(ncol,k+1) = tw1d(k+1)
+            h2ovmr(ncol,k) = qv1d(k) * amdw
+            co2vmr(ncol,k) = co2
+            o2vmr(ncol,k) = o2
+            ch4vmr(ncol,k) = ch4
+            n2ovmr(ncol,k) = n2o
+            cfc11vmr(ncol,k) = cfc11
+            cfc12vmr(ncol,k) = cfc12
+            cfc22vmr(ncol,k) = cfc22
+            ccl4vmr(ncol,k) = ccl4
+         enddo
+
+! This section is replaced with a new method to deal with model top
+         if ( 1 == 0 ) then
+
+!  Define profile values for extra layer from model top to top of 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.  
+
+         play(ncol,kte+1) = 0.5 * plev(ncol,kte+1)
+         tlay(ncol,kte+1) = tlev(ncol,kte+1) + 0.0
+         plev(ncol,kte+2) = 1.0e-5
+         tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
+         h2ovmr(ncol,kte+1) = h2ovmr(ncol,kte) 
+         co2vmr(ncol,kte+1) = co2vmr(ncol,kte) 
+         o2vmr(ncol,kte+1) = o2vmr(ncol,kte) 
+         ch4vmr(ncol,kte+1) = ch4vmr(ncol,kte) 
+         n2ovmr(ncol,kte+1) = n2ovmr(ncol,kte) 
+         cfc11vmr(ncol,kte+1) = cfc11vmr(ncol,kte) 
+         cfc12vmr(ncol,kte+1) = cfc12vmr(ncol,kte) 
+         cfc22vmr(ncol,kte+1) = cfc22vmr(ncol,kte) 
+         ccl4vmr(ncol,kte+1) = ccl4vmr(ncol,kte) 
+
+         endif
+
+!  Set up values for extra layers to the top of the atmosphere.                       
+!  Temperature is calculated based on an average temperature profile given
+!  here in a table.  The input table data is linearly interpolated to the
+!  column pressure.  Mixing ratios are held constant except for ozone.  
+!  Caution should be used if model top pressure is less than 5 hPa.
+!  Steven Cavallo, NCAR/MMM, December 2010
+       ! Calculate the column pressure buffer levels above the 
+       ! model top       
+       do L=kte+1,nlayers,1
+          plev(ncol,L+1) = plev(ncol,L) - deltap
+          play(ncol,L) = 0.5*(plev(ncol,L) + plev(ncol,L+1))
+       enddo          
+       ! Add zero as top level.  This gets the temperature max at the
+       ! stratopause, reducing the downward flux errors in the top 
+       ! levels.  If zero happened to be the top level already,
+       ! this will add another level with zero, but will not affect
+       ! the radiative transfer calculation.
+       plev(ncol,nlayers+1) = 0.00
+       play(ncol,nlayers) =  0.5*(plev(ncol,nlayers) + plev(ncol,nlayers+1))
+
+       ! Interpolate the table temperatures to column pressure levels    
+       do L=1,nlayers+1,1
+          if ( PPROF(nproflevs) .lt. plev(ncol,L) ) then
+             do LL=2,nproflevs,1       
+                if ( PPROF(LL) .lt. plev(ncol,L) ) then           
+                   klev = LL - 1
+                   exit
+                endif
+             enddo
+          
+          else
+             klev = nproflevs
+          endif  
+  
+          if (klev .ne. nproflevs ) then
+             vark  = TPROF(klev) 
+             vark1 = TPROF(klev+1)
+             wght=(plev(ncol,L)-PPROF(klev) )/( PPROF(klev+1)-PPROF(klev))
+          else
+             vark  = TPROF(klev) 
+             vark1 = TPROF(klev)
+             wght = 0.0
+          endif
+          varint(L) = wght*(vark1-vark)+vark
+
+       enddo                   
+       
+       ! Match the interpolated table temperature profile to WRF column                    
+       do L=kte+1,nlayers+1,1
+          tlev(ncol,L) = varint(L) + (tlev(ncol,kte) - varint(kte))
+          !if ( L .le. nlay ) then
+	  tlay(ncol,L-1) = 0.5*(tlev(ncol,L) + tlev(ncol,L-1))  
+	  !endif
+       enddo 
+
+       ! Now the chemical species (except for ozone)
+       do L=kte+1,nlayers,1
+          h2ovmr(ncol,L) = h2ovmr(ncol,kte) 
+          co2vmr(ncol,L) = co2vmr(ncol,kte) 
+          o2vmr(ncol,L) = o2vmr(ncol,kte) 
+          ch4vmr(ncol,L) = ch4vmr(ncol,kte) 
+          n2ovmr(ncol,L) = n2ovmr(ncol,kte) 
+          cfc11vmr(ncol,L) = cfc11vmr(ncol,kte) 
+          cfc12vmr(ncol,L) = cfc12vmr(ncol,kte) 
+          cfc22vmr(ncol,L) = cfc22vmr(ncol,kte) 
+          ccl4vmr(ncol,L) = ccl4vmr(ncol,kte) 
+       enddo	 
+! End top of model buffer 
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!	
+! Get ozone profile including amount in extra layer above model top.
+! Steven Cavallo: Must pass nlay-1 into subroutine to get nlayers 
+! dimension for o3mmr
+         call inirad (o3mmr,plev,kts,nlay-1)
+
+! Steven Cavallo: Changed to nlayers from kte+1
+         do k = kts, nlayers
+            o3vmr(ncol,k) = o3mmr(k) * amdo
+         enddo
+
+! Set surface emissivity in each RRTMG longwave band
+         do nb = 1, nbndlw
+            emis(ncol, nb) = emiss(i,j)
+         enddo
+
+! Define cloud optical properties for radiation (inflglw = 0)
+! This is approach used with older RRTM_LW;
+! Cloud and precipitation paths in g/m2 
+! qi=0 if no ice phase
+! qs=0 if no ice phase
+         if (inflglw .eq. 0) then
+            do k = kts,kte
+               ro = p1d(k) / (r * t1d(k))*100. 
+               dz = dz1d(k)
+               clwp(k) = ro*qc1d(k)*dz*1000.         
+               ciwp(k) = ro*qi1d(k)*dz*1000.         
+               plwp(k) = (ro*qr1d(k))**0.75*dz*1000. 
+               piwp(k) = (ro*qs1d(k))**0.75*dz*1000. 
+            enddo
+
+! Cloud fraction and cloud optical depth; old approach used with RRTM_LW
+            do k = kts, kte
+               cldfrac(ncol,k) = cldfra1d(k)
+               do nb = 1, nbndlw
+                  taucld(nb,ncol,k) = abcw*clwp(k) + abice*ciwp(k) & 
+                            +abrn*plwp(k) + absn*piwp(k) 
+                  if (taucld(nb,ncol,k) .gt. 0.01) cldfrac(ncol,k) = 1. 
+               enddo
+            enddo
+
+! Zero out cloud physical property arrays; not used when passing optical properties
+! into radiation
+            do k = kts, kte
+               clwpth(ncol,k) = 0.0
+               ciwpth(ncol,k) = 0.0
+               rel(ncol,k) = 10.0
+               rei(ncol,k) = 10.0
+            enddo
+         endif
+
+! Define cloud physical properties for radiation (inflglw = 1 or 2)
+! Cloud fraction
+! Set cloud arrays if passing cloud physical properties into radiation
+         if (inflglw .gt. 0) then 
+            do k = kts, kte
+               cldfrac(ncol,k) = cldfra1d(k)
+            enddo
+
+! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method)
+            pcols = ncol
+            pver = kte - kts + 1
+            gravmks = g
+            landfrac(ncol) = 2.-XLAND(I,J)
+            landm(ncol) = landfrac(ncol)
+            snowh(ncol) = 0.001*SNOW(I,J)
+            icefrac(ncol) = XICE(I,J)
+
+! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
+! pdel is in mb here; convert back to Pa (*100.)
+! Water paths are in units of g/m2
+! snow added as ice cloud (JD 091022)
+            do k = kts, kte
+               gicewp = (qi1d(k)+qs1d(k)) * pdel(ncol,k)*100.0 / gravmks * 1000.0     ! Grid box ice water path.
+               gliqwp = qc1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0     ! Grid box liquid water path.
+               cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k))               ! In-cloud ice water path.
+               cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k))               ! In-cloud liquid water path.
+            end do
+
+!link the aerosol feedback to cloud  -czhao
+  if( PRESENT( progn ) ) then
+    if (progn == 1) then
+!jdfcz     if(prescribe==0) then
+
+      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, kte
+         reliq(ncol,k) = 10.
+         if( PRESENT( F_QNDROP ) ) then
+            if( F_QNDROP ) then
+              if ( qc1d(k)*pdel(ncol,k).gt.lwpmin.and. &
+                   qndrop1d(k).gt.1000. ) then
+               reliq(ncol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m
+!           apply scaling from Martin et al., JAS 51, 1830.
+               reliq(ncol,k)=1.1*reliq(ncol,k)
+               reliq(ncol,k)=reliq(ncol,k)*1.e6 ! convert from m to microns
+               reliq(ncol,k)=max(reliq(ncol,k),4.)
+               reliq(ncol,k)=min(reliq(ncol,k),20.)
+              end if
+            end if
+         end if
+      end do
+!jdfcz     else ! prescribe 
+! following Kiehl
+      call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
+!     write(0,*) 'lw prescribe aerosol',maxval(qndrop3d)
+!jdfcz     endif
+    else  ! progn   
+      call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
+    endif
+  else   !present(progn) 
+      call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
+  endif
+
+! following Kristjansson and Mitchell
+            call reicalc(ncol, pcols, pver, tlay, reice)
+
+! Limit upper bound of reice for Fu ice parameterization and convert
+! from effective radius to generalized effective size (*1.0315; Fu, 1996)
+            if (iceflglw .eq. 3) then
+               do k = kts, kte
+                  reice(ncol,k) = reice(ncol,k) * 1.0315
+                  reice(ncol,k) = min(140.0,reice(ncol,k))
+               end do
+            endif
+
+! Set cloud physical property arrays
+            do k = kts, kte
+               clwpth(ncol,k) = cliqwp(ncol,k)
+               ciwpth(ncol,k) = cicewp(ncol,k)
+               rel(ncol,k) = reliq(ncol,k)
+               rei(ncol,k) = reice(ncol,k)
+            enddo
+
+! Zero out cloud optical properties here; not used when passing physical properties
+! to radiation and taucld is calculated in radiation 
+            do k = kts, kte
+               do nb = 1, nbndlw
+                  taucld(nb,ncol,k) = 0.0
+               enddo
+            enddo
+         endif
+
+! No clouds are allowed in the extra layer from model top to TOA
+         ! Steven Cavallo: Edited out for buffer adjustment below
+         if ( 1 == 0 ) then
+
+
+         clwpth(ncol,kte+1) = 0.
+         ciwpth(ncol,kte+1) = 0.
+         rel(ncol,kte+1) = 10.
+         rei(ncol,kte+1) = 10.
+         cldfrac(ncol,kte+1) = 0.
+         do nb = 1, nbndlw
+            taucld(nb,ncol,kte+1) = 0.
+         enddo
+
+         endif
+
+         ! Buffer adjustment. Steven Cavallo December 2010
+	 do k=kte+1,nlayers
+	    clwpth(ncol,k) = 0.
+	    ciwpth(ncol,k) = 0.
+	    rel(ncol,k) = 10.
+            rei(ncol,k) = 10.
+            cldfrac(ncol,k) = 0.
+	    do nb = 1,nbndlw
+               taucld(nb,ncol,k) = 0.
+            enddo
+	 enddo	 
+
+         iplon = 1
+         irng = 0
+         permuteseed = 150
+
+! Sub-column generator for McICA
+         call mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
+                       cldfrac, ciwpth, clwpth, rei, rel, taucld, cldfmcl, &
+                       ciwpmcl, clwpmcl, reicmcl, relqmcl, taucmcl)
+
+!--------------------------------------------------------------------------
+! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
+!--------------------------------------------------------------------------
+! Aerosol optical depth by layer for each RRTMG longwave band
+! No aerosols in layer above model top (kte+1)
+! Steven Cavallo: Upper bound of loop changed to nlayers from kte+1
+!        do nb = 1, nbndlw
+!           do k = kts, kte+1
+!              tauaer(ncol,k,nb) = 0.
+!           enddo
+!        enddo
+
+! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
+!
+      do nb = 1, nbndlw
+      do k = kts,nlayers
+         tauaer(ncol,k,nb) = 0.
+      end do
+      end do
+
+#ifdef WRF_CHEM
+   IF ( AER_RA_FEEDBACK == 1) then
+!     do nb = 1, nbndlw 
+      do k = kts,kte      !wig
+        if(tauaerlw1(i,k,j).gt.thresh .and. tauaerlw16(i,k,j).gt.thresh) then
+          tauaer(ncol,k,1)=tauaerlw1(i,k,j)
+          tauaer(ncol,k,2)=tauaerlw2(i,k,j)
+          tauaer(ncol,k,3)=tauaerlw3(i,k,j)
+          tauaer(ncol,k,4)=tauaerlw4(i,k,j)
+          tauaer(ncol,k,5)=tauaerlw5(i,k,j)
+          tauaer(ncol,k,6)=tauaerlw6(i,k,j)
+          tauaer(ncol,k,7)=tauaerlw7(i,k,j)
+          tauaer(ncol,k,8)=tauaerlw8(i,k,j)
+          tauaer(ncol,k,9)=tauaerlw9(i,k,j)
+          tauaer(ncol,k,10)=tauaerlw10(i,k,j)
+          tauaer(ncol,k,11)=tauaerlw11(i,k,j)
+          tauaer(ncol,k,12)=tauaerlw12(i,k,j)
+          tauaer(ncol,k,13)=tauaerlw13(i,k,j)
+          tauaer(ncol,k,14)=tauaerlw14(i,k,j)
+          tauaer(ncol,k,15)=tauaerlw15(i,k,j)
+          tauaer(ncol,k,16)=tauaerlw16(i,k,j)
+        endif
+      enddo ! k
+!     end do ! nb
+
+!wig beg
+      do nb = 1, nbndlw
+         slope = 0.  !use slope as a sum holder
+         do k = kts,kte
+            slope = slope + tauaer(ncol,k,nb)
+         end do
+         if( slope < 0. ) then
+            write(msg,'("ERROR: Negative total lw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
+            call wrf_error_fatal(msg)
+         else if( slope > 5. ) then
+            call wrf_message("-------------------------")
+            write(msg,'("WARNING: Large total lw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
+            call wrf_message(msg)
+
+            call wrf_message("Diagnostics 1: k, tauaerlw1, tauaerlw16")
+            do k=kts,kte
+               write(msg,'(i4,2f8.2)') k, tauaerlw1(i,k,j), tauaerlw16(i,k,j)
+               call wrf_message(msg)
+            end do
+            call wrf_message("-------------------------")
+         endif
+      enddo  ! nb
+      endif  ! aer_ra_feedback
+#endif
+
+! Call RRTMG longwave radiation model
+         call rrtmg_lw &
+            (ncol    ,nlay    ,icld    , &
+             play    ,plev    ,tlay    ,tlev    ,tsfc    , & 
+             h2ovmr  ,o3vmr   ,co2vmr  ,ch4vmr  ,n2ovmr  ,o2vmr , &
+             cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis    , &
+             inflglw ,iceflglw,liqflglw,cldfmcl , &
+             taucmcl ,ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
+             tauaer  , &
+             uflx    ,dflx    ,hr      ,uflxc   ,dflxc,  hrc)
+
+! Output downard surface flux, and outgoing longwave flux and cloud forcing 
+! at the top of atmosphere (W/m2)
+         glw(i,j) = dflx(1,1)
+!         olr(i,j) = uflx(1,kte+2)
+!         lwcf(i,j) = uflxc(1,kte+2) - uflx(1,kte+2)
+! Steven Cavallo: Changed OLR to be valid at the top of atmosphere instead 
+! of top of model.  Dec 2010.
+         olr(i,j) = uflx(1,nlayers+1)
+         lwcf(i,j) = uflxc(1,nlayers+1) - uflx(1,nlayers+1)
+
+         if (present(lwupt)) then 
+! Output up and down toa fluxes for total and clear sky
+            lwupt(i,j)     = uflx(1,kte+2)
+            lwuptc(i,j)    = uflxc(1,kte+2)
+            lwdnt(i,j)     = dflx(1,kte+2)
+            lwdntc(i,j)    = dflxc(1,kte+2)
+! Output up and down surface fluxes for total and clear sky
+            lwupb(i,j)     = uflx(1,1)
+            lwupbc(i,j)    = uflxc(1,1)
+            lwdnb(i,j)     = dflx(1,1)
+            lwdnbc(i,j)    = dflxc(1,1)
+         endif
+
+! Output up and down layer fluxes for total and clear sky.
+! Vertical ordering is from bottom to top in units of W m-2. 
+         if ( present (lwupflx) ) then
+         do k=kts,kte+2
+            lwupflx(i,k,j)  = uflx(1,k)
+            lwupflxc(i,k,j) = uflxc(1,k)
+            lwdnflx(i,k,j)  = dflx(1,k)
+            lwdnflxc(i,k,j) = dflxc(1,k)
+         enddo
+         endif
+
+! Output heating rate tendency; convert heating rate from K/d to K/s
+! Heating rate arrays are ordered vertically from bottom to top here. 
+         do k=kts,kte
+            tten1d(k) = hr(ncol,k)/86400.
+            rthratenlw(i,k,j) = tten1d(k)/pi3d(i,k,j)
+         enddo
+
+!
+      end do i_loop
+   end do j_loop                                           
+
+!-------------------------------------------------------------------
+
+   END SUBROUTINE RRTMG_LWRAD
+
+ 
+!-------------------------------------------------------------------------
+   SUBROUTINE INIRAD (O3PROF,Plev, kts, kte)
+!-------------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------------
+   INTEGER, INTENT(IN   )                        ::    kts,kte
+
+   REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT)    ::    O3PROF
+
+   REAL, DIMENSION( kts:kte+2 ),INTENT(IN   )    ::      Plev
+
+! LOCAL VAR
+  
+   INTEGER :: k
+
+!                                                                                
+!  COMPUTE OZONE MIXING RATIO DISTRIBUTION                                       
+!                                                                                
+   DO K=kts,kte+1
+      O3PROF(K)=0.                                                       
+   ENDDO
+                                                                                 
+   CALL O3DATA(O3PROF, Plev, kts, kte)
+
+   END SUBROUTINE INIRAD
+                                                                                 
+!-------------------------------------------------------------------------
+   SUBROUTINE O3DATA (O3PROF, Plev, kts, kte)
+!-------------------------------------------------------------------------
+   IMPLICIT NONE
+!-------------------------------------------------------------------------
+!
+   INTEGER, INTENT(IN   )   ::       kts, kte
+!
+   REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT)    ::    O3PROF
+
+   REAL, DIMENSION( kts:kte+2 ),INTENT(IN   )    ::      Plev
+
+! LOCAL VAR
+   INTEGER :: K, JJ
+
+   REAL    ::  PRLEVH(kts:kte+2),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                     
+!                                                                                
+
+! Plev is total P at model levels, from bottom to top
+! Plev is in mb
+
+   DO K=kts,kte+2
+      PRLEVH(K)=Plev(K)
+   ENDDO
+!                                                                                
+   PPWRKH(1)=1100.                                                        
+   DO K=2,31                                                           
+      PPWRKH(K)=(PPWRK(K)+PPWRK(K-1))/2.                                   
+   ENDDO
+   PPWRKH(32)=0.                                                          
+   DO K=kts,kte+1
+      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 rrtmg_lwinit(                                         &
+                       p_top, 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)               :: p_top 
+
+! Steven Cavallo.  Added for buffer layer adjustment.   December 2010.
+   NLAYERS = kme + nint(p_top*0.01/deltap)- 1 ! Model levels plus new levels.
+                                              ! nlayers will subsequently 
+					      ! replace kte+1
+
+! Read in absorption coefficients and other data
+   IF ( allowed_to_read ) THEN
+     CALL rrtmg_lwlookuptable
+   ENDIF
+
+! Perform g-point reduction and other initializations
+! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
+   call rrtmg_lw_ini(cp)
+
+   END SUBROUTINE rrtmg_lwinit
+
+
+! **************************************************************************     
+      SUBROUTINE rrtmg_lwlookuptable
+! **************************************************************************     
+
+IMPLICIT NONE
+
+! Local                                    
+      INTEGER :: i
+      LOGICAL                 :: opened
+      LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
+
+      CHARACTER*80 errmess
+      INTEGER rrtmg_unit
+
+      IF ( wrf_dm_on_monitor() ) THEN
+        DO i = 10,99
+          INQUIRE ( i , OPENED = opened )
+          IF ( .NOT. opened ) THEN
+            rrtmg_unit = i
+            GOTO 2010
+          ENDIF
+        ENDDO
+        rrtmg_unit = -1
+ 2010   CONTINUE
+      ENDIF
+      CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE )
+      IF ( rrtmg_unit < 0 ) THEN
+        CALL wrf_error_fatal ( 'module_ra_rrtmg_lw: rrtm_lwlookuptable: Can not '// &
+                               'find unused fortran unit to read in lookup table.' )
+      ENDIF
+
+      IF ( wrf_dm_on_monitor() ) THEN
+        OPEN(rrtmg_unit,FILE='RRTMG_LW_DATA',                  &
+             FORM='UNFORMATTED',STATUS='OLD',ERR=9009)
+      ENDIF
+
+      call lw_kgb01(rrtmg_unit)
+      call lw_kgb02(rrtmg_unit)
+      call lw_kgb03(rrtmg_unit)
+      call lw_kgb04(rrtmg_unit)
+      call lw_kgb05(rrtmg_unit)
+      call lw_kgb06(rrtmg_unit)
+      call lw_kgb07(rrtmg_unit)
+      call lw_kgb08(rrtmg_unit)
+      call lw_kgb09(rrtmg_unit)
+      call lw_kgb10(rrtmg_unit)
+      call lw_kgb11(rrtmg_unit)
+      call lw_kgb12(rrtmg_unit)
+      call lw_kgb13(rrtmg_unit)
+      call lw_kgb14(rrtmg_unit)
+      call lw_kgb15(rrtmg_unit)
+      call lw_kgb16(rrtmg_unit)
+
+     IF ( wrf_dm_on_monitor() ) CLOSE (rrtmg_unit)
+
+     RETURN
+9009 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error opening RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+     END SUBROUTINE rrtmg_lwlookuptable
+
+! **************************************************************************     
+!  RRTMG Longwave Radiative Transfer Model
+!  Atmospheric and Environmental Research, Inc., Cambridge, MA
+!
+!  Original version:   E. J. Mlawer, et al.
+!  Revision for GCMs:  Michael J. Iacono; October, 2002
+!  Revision for F90 formatting:  Michael J. Iacono; June 2006
+!
+!  This file contains 16 READ statements that include the 
+!  absorption coefficients and other data for each of the 16 longwave
+!  spectral bands used in RRTMG_LW.  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 module RRTMG_LW_INIT to reduce
+!  the total number of g-points from 256 to 140 for use in the GCM.
+! **************************************************************************     
+
+! **************************************************************************
+      subroutine lw_kgb01(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg01, only : fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, &
+                           absa, absb, &
+                      selfrefo, forrefo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: P = 212.7250 mbar, T = 223.06 K
+
+!     The array KAO 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 KBO 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 arrays kao_mn2 and kbo_mn2 contain the coefficients of the 
+!     nitrogen continuum for the upper and lower atmosphere.
+!     Minor gas mapping levels: 
+!     Lower - n2: P = 142.5490 mbar, T = 215.70 K
+!     Upper - n2: P = 142.5490 mbar, T = 215.70 K
+
+!     The array FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(fracrefbo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(kao_mn2)
+      DM_BCAST_MACRO(kbo_mn2)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb01
+
+! **************************************************************************
+      subroutine lw_kgb02(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg02, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower: P = 1053.630 mbar, T = 294.2 K
+!     Upper: P = 3.206e-2 mb, T = 197.92 K
+
+!     The array KAO 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 KBO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(fracrefbo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb02
+
+! **************************************************************************
+      subroutine lw_kgb03(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg03, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, &
+                            kbo_mn2o, selfrefo, forrefo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower: P = 212.7250 mbar, T = 223.06 K
+!     Upper: P = 95.8 mbar, T = 215.7 k
+
+!     The array KAO 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 gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.
+!     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 KBO 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 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 KAO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level below 100~ mb.   The first index in the array, JS, runs
+!     from 1 to 10, and corresponds to different gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.  The second index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The third index 
+!     runs over the g-channel (1 to 16).
+
+!     The array KBO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level above 100~ mb.   The first index in the array, JS, runs
+!     from 1 to 10, and corresponds to different gas column amounts ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 to 
+!     that of gas2.  The second index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The third index 
+!     runs over the g-channel (1 to 16).
+
+!     The array FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(fracrefbo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(kao_mn2o)
+      DM_BCAST_MACRO(kbo_mn2o)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb03 
+
+! **************************************************************************
+      subroutine lw_kgb04(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg04, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower : P = 142.5940 mbar, T = 215.70 K
+!     Upper : P = 95.58350 mb, T = 215.70 K
+
+!     The array KAO 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 gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.
+!     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 KBO 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 10, and corresponds to different gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.  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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(fracrefbo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb04
+
+! **************************************************************************
+      subroutine lw_kgb05(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg05, only : fracrefao, fracrefbo, kao, kbo, kao_mo3, &
+                            selfrefo, forrefo, ccl4o
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower: P = 473.42 mb, T = 259.83
+!     Upper: P = 0.2369280 mbar, T = 253.60 K
+
+!     The arrays kao_mo3 and ccl4o contain the coefficients for
+!     ozone and ccl4 in the lower atmosphere.
+!     Minor gas mapping level:
+!     Lower - o3: P = 317.34 mbar, T = 240.77 k
+!     Lower - ccl4:
+
+!     The array KAO 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 gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.
+!     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 KBO 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 10, and corresponds to different gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.  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 KAO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level below 100~ mb.   The first index in the array, JS, runs
+!     from 1 to 10, and corresponds to different gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.  The second index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The third index 
+!     runs over the g-channel (1 to 16).
+
+!     The array FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(fracrefbo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(kao_mo3)
+      DM_BCAST_MACRO(ccl4o)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb05
+
+! **************************************************************************
+      subroutine lw_kgb06(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg06, only : fracrefao, kao, kao_mco2, selfrefo, forrefo, &
+                            cfc11adjo, cfc12o
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower: : P = 473.4280 mb, T = 259.83 K
+
+!     The arrays kao_mco2, cfc11adjo and cfc12o contain the coefficients for
+!     carbon dioxide in the lower atmosphere and cfc11 and cfc12 in the upper
+!     atmosphere.
+!     Original cfc11 is multiplied by 1.385 to account for the 1060-1107 cm-1 band.
+!     Minor gas mapping level:
+!     Lower - co2: P = 706.2720 mb, T = 294.2 k
+!     Upper - cfc11, cfc12
+
+!     The array KAO 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 KAO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level below 100~ mb.   The first index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kao_mco2)
+      DM_BCAST_MACRO(cfc11adjo)
+      DM_BCAST_MACRO(cfc12o)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb06
+
+! **************************************************************************
+      subroutine lw_kgb07(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg07, only : fracrefao, fracrefbo, kao, kbo, kao_mco2, &
+                            kbo_mco2, selfrefo, forrefo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower : P = 706.27 mb, T = 278.94 K
+!     Upper : P = 95.58 mbar, T= 215.70 K
+
+!     The array KAO 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 gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.
+!     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 KBO 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 KAO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level below 100~ mb.   The first index in the array, JS, runs
+!     from 1 to 10, and corresponds to different gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.  The second index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The third index 
+!     runs over the g-channel (1 to 16).
+
+!     The array KBO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level above 100~ mb.   The first index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296_rb,260_rb,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(fracrefbo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(kao_mco2)
+      DM_BCAST_MACRO(kbo_mco2)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb07
+
+! **************************************************************************
+      subroutine lw_kgb08(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg08, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, &
+                            kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, &
+                            cfc12o, cfc22adjo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower: P=473.4280 mb, T = 259.83 K
+!     Upper: P=95.5835 mb, T= 215.7 K
+
+!     The arrays kao_mco2, kbo_mco2, kao_mn2o, kbo_mn2o contain the coefficients for
+!     carbon dioxide and n2o in the lower and upper atmosphere.
+!     The array kao_mo3 contains the coefficients for ozone in the lower atmosphere,
+!     and arrays cfc12o and cfc12adjo contain the coefficients for cfc12 and cfc22.
+!     Original cfc22 is multiplied by 1.485 to account for the 780-850 cm-1 
+!     and 1290-1335 cm-1 bands.
+!     Minor gas mapping level:
+!     Lower - co2: P = 1053.63 mb, T = 294.2 k
+!     Lower - o3: P = 317.348 mb, T = 240.77 k
+!     Lower - n2o: P = 706.2720 mb, T= 278.94 k
+!     Lower - cfc12, cfc22
+!     Upper - co2: P = 35.1632 mb, T = 223.28 k
+!     Upper - n2o: P = 8.716e-2 mb, T = 226.03 k
+
+!     The array KAO 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 KBO 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 KAO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level below 100~ mb.   The first index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array KBO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level above 100~ mb.   The first index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, kao_mn2o, &
+         kbo_mn2o, kao_mo3, cfc12o, cfc22adjo, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(fracrefbo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(kao_mco2)
+      DM_BCAST_MACRO(kbo_mco2)
+      DM_BCAST_MACRO(kao_mn2o)
+      DM_BCAST_MACRO(kbo_mn2o)
+      DM_BCAST_MACRO(kao_mo3)
+      DM_BCAST_MACRO(cfc12o)
+      DM_BCAST_MACRO(cfc22adjo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb08
+
+! **************************************************************************
+      subroutine lw_kgb09(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg09, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, &
+                            kbo_mn2o, selfrefo, forrefo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower: P=212.7250 mb, T = 223.06 K
+!     Upper: P=3.20e-2 mb, T = 197.92 k
+
+!     The array KAO 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 gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.
+!     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 KBO 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 KAO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level below 100~ mb.   The first index in the array, JS, runs
+!     from 1 to 10, and corresponds to different gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.  The second index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The third index 
+!     runs over the g-channel (1 to 16).
+
+!     The array KBO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level above 100~ mb.   The first index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(fracrefbo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(kao_mn2o)
+      DM_BCAST_MACRO(kbo_mn2o)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb09
+
+! **************************************************************************
+      subroutine lw_kgb10(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg10, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower: P = 212.7250 mb, T = 223.06 K
+!     Upper: P = 95.58350 mb, T = 215.70 K
+
+!     The array KAO 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 KBO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(fracrefbo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb10
+
+! **************************************************************************
+      subroutine lw_kgb11(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg11, only : fracrefao, fracrefbo, kao, kbo, kao_mo2, &
+                            kbo_mo2, selfrefo, forrefo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower: P=1053.63 mb, T= 294.2 K
+!     Upper: P=0.353 mb, T = 262.11 K
+
+!     The array KAO 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 KBO 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 KAO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level below 100~ mb.   The first index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array KBO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level above 100~ mb.   The first index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, fracrefbo, kao, kbo, kao_mo2, kbo_mo2, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(fracrefbo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(kao_mo2)
+      DM_BCAST_MACRO(kbo_mo2)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb11
+
+! **************************************************************************
+      subroutine lw_kgb12(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg12, only : fracrefao, kao, selfrefo, forrefo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower: P = 174.1640 mbar, T= 215.78 K
+
+!     The array KAO 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 gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.
+!     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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, kao, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb12
+
+! **************************************************************************
+      subroutine lw_kgb13(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg13, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mco, &
+                            kbo_mo3, selfrefo, forrefo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower: P=473.4280 mb, T = 259.83 K      
+!     Upper: P=4.758820 mb, T = 250.85 K
+
+!     The array KAO 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 gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.
+!     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 KAO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level below 100~ mb.   The first index in the array, JS, runs
+!     from 1 to 10, and corresponds to different gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.  The second index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The third index 
+!     runs over the g-channel (1 to 16).
+
+!     The array KBO_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level above 100~ mb.   The first index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, fracrefbo, kao, kao_mco2, kao_mco, kbo_mo3, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(fracrefbo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kao_mco2)
+      DM_BCAST_MACRO(kao_mco)
+      DM_BCAST_MACRO(kbo_mo3)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb13
+
+! **************************************************************************
+      subroutine lw_kgb14(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg14, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower: P = 142.5940 mb, T = 215.70 K
+!     Upper: P = 4.758820 mb, T = 250.85 K
+
+!     The array KAO 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 gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.
+!     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 KBO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(fracrefbo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb14
+
+! **************************************************************************
+      subroutine lw_kgb15(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg15, only : fracrefao, kao, kao_mn2, selfrefo, forrefo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower: P = 1053. mb, T = 294.2 K
+
+!     The array KAO 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 gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.
+!     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 KA_Mxx contains the absorption coefficient for 
+!     a minor species at the 16 chosen g-values for a reference pressure
+!     level below 100~ mb.   The first index in the array, JS, runs
+!     from 1 to 10, and corresponds to different gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.  The second index refers to temperature 
+!     in 7.2 degree increments.  For instance, JT = 1 refers to a 
+!     temperature of 188.0, JT = 2 refers to 195.2, etc. The third index 
+!     runs over the g-channel (1 to 16).
+
+!     The array FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, kao, kao_mn2, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kao_mn2)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb15
+
+! **************************************************************************
+      subroutine lw_kgb16(rrtmg_unit)
+! **************************************************************************
+
+      use rrlw_kg16, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Arrays fracrefao and fracrefbo are the Planck fractions for the lower
+!     and upper atmosphere.
+!     Planck fraction mapping levels: 
+!     Lower: P = 387.6100 mbar, T = 250.17 K
+!     Upper: P=95.58350 mb, T = 215.70 K
+
+!     The array KAO 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 gas column amount ratios,
+!     as expressed through the binary species parameter eta, defined as
+!     eta = gas1/(gas1 + (rat) * gas2), where rat is the 
+!     ratio of the reference MLS column amount value of gas 1 
+!     to that of gas2.
+!     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 KBO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 (rrtmg_unit,ERR=9010) &
+         fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
+      DM_BCAST_MACRO(fracrefao)
+      DM_BCAST_MACRO(fracrefbo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lw: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine lw_kgb16
+
+!===============================================================================
+  subroutine relcalc(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
+! 
+!-----------------------------------------------------------------------
+    implicit none
+!------------------------------Arguments--------------------------------
+!
+! Input arguments
+!
+    integer, intent(in) :: ncol
+    integer, intent(in) :: pcols, pver
+    real, intent(in) :: landfrac(pcols)      ! Land fraction
+    real, intent(in) :: icefrac(pcols)       ! Ice fraction
+    real, intent(in) :: snowh(pcols)         ! Snow depth over land, water equivalent (m)
+    real, intent(in) :: landm(pcols)         ! Land fraction ramping to zero over ocean
+    real, intent(in) :: t(pcols,pver)        ! Temperature
+
+!
+! Output arguments
+!
+    real, intent(out) :: rel(pcols,pver)      ! Liquid effective drop size (microns)
+!
+!---------------------------Local workspace-----------------------------
+!
+    integer i,k           ! Lon, lev indices
+    real tmelt            ! freezing temperature of fresh water (K)
+    real rliqland         ! liquid drop size if over land
+    real rliqocean        ! liquid drop size if over ocean
+    real rliqice          ! liquid drop size if over sea ice
+!
+!-----------------------------------------------------------------------
+!
+    tmelt = 273.16
+    rliqocean = 14.0
+    rliqice   = 14.0
+    rliqland  = 8.0
+    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,max(0.0,(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,max(0.0,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,max(0.0,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,max(0.0,icefrac(i)))
+! end jrm
+       end do
+    end do
+  end subroutine relcalc
+!===============================================================================
+  subroutine reicalc(ncol, pcols, pver, t, re)
+    !
+
+    integer, intent(in) :: ncol, pcols, pver
+    real, intent(out) :: re(pcols,pver)
+    real, intent(in) :: t(pcols,pver)
+    real corr
+    integer i
+    integer k
+    integer index
+    !
+    !       Tabulated values of re(T) in the temperature interval
+    !       180 K -- 274 K; hexagonal columns assumed:
+    !
+    !
+    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 reicalc
+!------------------------------------------------------------------
+
+END MODULE module_ra_rrtmg_lw
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_rrtmg_sw.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_rrtmg_sw.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_rrtmg_sw.F	(revision 17)
@@ -0,0 +1,11639 @@
+!!MODULE module_ra_rrtmg_sw
+                
+      module parrrsw
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_sw main parameters
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+! mxlay  :  integer: maximum number of layers
+! mg     :  integer: number of original g-intervals per spectral band
+! nbndsw :  integer: number of spectral bands
+! naerec :  integer: number of aerosols (iaer=6, ecmwf aerosol option)
+! ngptsw :  integer: total number of reduced g-intervals for rrtmg_lw
+! ngNN   :  integer: number of reduced g-intervals per spectral band
+! ngsNN  :  integer: cumulative number of g-intervals per band
+!------------------------------------------------------------------
+
+      integer(kind=im), parameter :: mxlay  = 203    !jplay, klev
+      integer(kind=im), parameter :: mg     = 16     !jpg
+      integer(kind=im), parameter :: nbndsw = 14     !jpsw, ksw
+      integer(kind=im), parameter :: naerec  = 6     !jpaer
+      integer(kind=im), parameter :: mxmol  = 38
+      integer(kind=im), parameter :: nstr   = 2
+      integer(kind=im), parameter :: nmol   = 7
+! Use for 112 g-point model   
+      integer(kind=im), parameter :: ngptsw = 112    !jpgpt
+! Use for 224 g-point model   
+!      integer(kind=im), parameter :: ngptsw = 224   !jpgpt
+
+! may need to rename these - from v2.6
+      integer(kind=im), parameter :: jpband   = 29
+      integer(kind=im), parameter :: jpb1     = 16   !istart
+      integer(kind=im), parameter :: jpb2     = 29   !iend
+
+      integer(kind=im), parameter :: jmcmu    = 32
+      integer(kind=im), parameter :: jmumu    = 32
+      integer(kind=im), parameter :: jmphi    = 3
+      integer(kind=im), parameter :: jmxang   = 4
+      integer(kind=im), parameter :: jmxstr   = 16
+
+! Use for 112 g-point model   
+      integer(kind=im), parameter :: ng16 = 6
+      integer(kind=im), parameter :: ng17 = 12
+      integer(kind=im), parameter :: ng18 = 8
+      integer(kind=im), parameter :: ng19 = 8
+      integer(kind=im), parameter :: ng20 = 10
+      integer(kind=im), parameter :: ng21 = 10
+      integer(kind=im), parameter :: ng22 = 2
+      integer(kind=im), parameter :: ng23 = 10
+      integer(kind=im), parameter :: ng24 = 8
+      integer(kind=im), parameter :: ng25 = 6
+      integer(kind=im), parameter :: ng26 = 6
+      integer(kind=im), parameter :: ng27 = 8
+      integer(kind=im), parameter :: ng28 = 6
+      integer(kind=im), parameter :: ng29 = 12
+
+      integer(kind=im), parameter :: ngs16 = 6
+      integer(kind=im), parameter :: ngs17 = 18
+      integer(kind=im), parameter :: ngs18 = 26
+      integer(kind=im), parameter :: ngs19 = 34
+      integer(kind=im), parameter :: ngs20 = 44
+      integer(kind=im), parameter :: ngs21 = 54
+      integer(kind=im), parameter :: ngs22 = 56
+      integer(kind=im), parameter :: ngs23 = 66
+      integer(kind=im), parameter :: ngs24 = 74
+      integer(kind=im), parameter :: ngs25 = 80
+      integer(kind=im), parameter :: ngs26 = 86
+      integer(kind=im), parameter :: ngs27 = 94
+      integer(kind=im), parameter :: ngs28 = 100
+      integer(kind=im), parameter :: ngs29 = 112
+
+! Use for 224 g-point model   
+!      integer(kind=im), parameter :: ng16 = 16
+!      integer(kind=im), parameter :: ng17 = 16
+!      integer(kind=im), parameter :: ng18 = 16
+!      integer(kind=im), parameter :: ng19 = 16
+!      integer(kind=im), parameter :: ng20 = 16
+!      integer(kind=im), parameter :: ng21 = 16
+!      integer(kind=im), parameter :: ng22 = 16
+!      integer(kind=im), parameter :: ng23 = 16
+!      integer(kind=im), parameter :: ng24 = 16
+!      integer(kind=im), parameter :: ng25 = 16
+!      integer(kind=im), parameter :: ng26 = 16
+!      integer(kind=im), parameter :: ng27 = 16
+!      integer(kind=im), parameter :: ng28 = 16
+!      integer(kind=im), parameter :: ng29 = 16
+
+!      integer(kind=im), parameter :: ngs16 = 16
+!      integer(kind=im), parameter :: ngs17 = 32
+!      integer(kind=im), parameter :: ngs18 = 48
+!      integer(kind=im), parameter :: ngs19 = 64
+!      integer(kind=im), parameter :: ngs20 = 80
+!      integer(kind=im), parameter :: ngs21 = 96
+!      integer(kind=im), parameter :: ngs22 = 112
+!      integer(kind=im), parameter :: ngs23 = 128
+!      integer(kind=im), parameter :: ngs24 = 144
+!      integer(kind=im), parameter :: ngs25 = 160
+!      integer(kind=im), parameter :: ngs26 = 176
+!      integer(kind=im), parameter :: ngs27 = 192
+!      integer(kind=im), parameter :: ngs28 = 208
+!      integer(kind=im), parameter :: ngs29 = 224
+
+! Source function solar constant
+      real(kind=rb), parameter :: rrsw_scon = 1.36822e+03     ! W/m2
+ 
+      end module parrrsw
+
+      module rrsw_aer
+
+      use parkind, only : im => kind_im, rb => kind_rb
+      use parrrsw, only : nbndsw, naerec
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_sw aerosol optical properties
+!
+!  Data derived from six ECMWF aerosol types and defined for
+!  the rrtmg_sw spectral intervals
+!
+! Initial: J.-J. Morcrette, ECMWF, mar2003
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+!
+!-- The six ECMWF aerosol types are respectively:
+!
+!  1/ continental average                 2/ maritime
+!  3/ desert                              4/ urban
+!  5/ volcanic active                     6/ stratospheric background
+!
+! computed from Hess and Koepke (con, mar, des, urb)
+!          from Bonnel et al.   (vol, str)
+!
+! rrtmg_sw 14 spectral intervals (microns):
+!  3.846 -  3.077
+!  3.077 -  2.500
+!  2.500 -  2.150
+!  2.150 -  1.942
+!  1.942 -  1.626
+!  1.626 -  1.299
+!  1.299 -  1.242
+!  1.242 -  0.7782
+!  0.7782-  0.6250
+!  0.6250-  0.4415
+!  0.4415-  0.3448
+!  0.3448-  0.2632
+!  0.2632-  0.2000
+! 12.195 -  3.846
+!
+!------------------------------------------------------------------
+!
+!  name     type     purpose
+! -----   : ----   : ----------------------------------------------
+! rsrtaua : real   : ratio of average optical thickness in 
+!                    spectral band to that at 0.55 micron
+! rsrpiza : real   : average single scattering albedo (unitless)
+! rsrasya : real   : average asymmetry parameter (unitless)
+!------------------------------------------------------------------
+
+      real(kind=rb) :: rsrtaua(nbndsw,naerec)
+      real(kind=rb) :: rsrpiza(nbndsw,naerec)
+      real(kind=rb) :: rsrasya(nbndsw,naerec)
+
+      end module rrsw_aer
+
+      module rrsw_cld
+
+      use parkind, only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_sw cloud property coefficients
+!
+! Initial: J.-J. Morcrette, ECMWF, oct1999
+! Revised: J. Delamere/MJIacono, AER, aug2005
+! Revised: MJIacono, AER, nov2005
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+!
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+! xxxliq1 : real   : optical properties (extinction coefficient, single 
+!                    scattering albedo, assymetry factor) from
+!                    Hu & Stamnes, j. clim., 6, 728-742, 1993.  
+! xxxice2 : real   : optical properties (extinction coefficient, single 
+!                    scattering albedo, assymetry factor) from streamer v3.0,
+!                    Key, streamer user's guide, cooperative institude 
+!                    for meteorological studies, 95 pp., 2001.
+! xxxice3 : real   : optical properties (extinction coefficient, single 
+!                    scattering albedo, assymetry factor) from
+!                    Fu, j. clim., 9, 1996.
+! xbari   : real   : optical property coefficients for five spectral 
+!                    intervals (2857-4000, 4000-5263, 5263-7692, 7692-14285,
+!                    and 14285-40000 wavenumbers) following 
+!                    Ebert and Curry, jgr, 97, 3831-3836, 1992.
+!------------------------------------------------------------------
+
+      real(kind=rb) :: extliq1(58,16:29), ssaliq1(58,16:29), asyliq1(58,16:29)
+      real(kind=rb) :: extice2(43,16:29), ssaice2(43,16:29), asyice2(43,16:29)
+      real(kind=rb) :: extice3(46,16:29), ssaice3(46,16:29), asyice3(46,16:29)
+      real(kind=rb) :: fdlice3(46,16:29)
+      real(kind=rb) :: abari(5),bbari(5),cbari(5),dbari(5),ebari(5),fbari(5)
+
+      end module rrsw_cld
+
+      module rrsw_con
+
+      use parkind, only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_sw constants
+
+! Initial version: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+! fluxfac:  real   : radiance to flux conversion factor 
+! heatfac:  real   : flux to heating rate conversion factor
+!oneminus:  real   : 1.-1.e-6
+! pi     :  real   : pi
+! grav   :  real   : acceleration of gravity
+! planck :  real   : planck constant
+! boltz  :  real   : boltzmann constant
+! clight :  real   : speed of light
+! avogad :  real   : avogadro constant 
+! alosmt :  real   : loschmidt constant
+! gascon :  real   : molar gas constant
+! radcn1 :  real   : first radiation constant
+! radcn2 :  real   : second radiation constant
+! sbcnst :  real   : stefan-boltzmann constant
+!  secdy :  real   : seconds per day
+!------------------------------------------------------------------
+
+      real(kind=rb) :: fluxfac, heatfac
+      real(kind=rb) :: oneminus, pi, grav
+      real(kind=rb) :: planck, boltz, clight
+      real(kind=rb) :: avogad, alosmt, gascon
+      real(kind=rb) :: radcn1, radcn2
+      real(kind=rb) :: sbcnst, secdy
+
+      end module rrsw_con
+
+      module rrsw_kg16
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng16
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 16
+! band 16:  2600-3250 cm-1 (low - h2o,ch4; high - ch4)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real
+!sfluxrefo: real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no16 = 16
+
+      real(kind=rb) :: kao(9,5,13,no16)
+      real(kind=rb) :: kbo(5,13:59,no16)
+      real(kind=rb) :: selfrefo(10,no16), forrefo(3,no16)
+      real(kind=rb) :: sfluxrefo(no16)
+
+      integer(kind=im) :: layreffr
+      real(kind=rb) :: rayl, strrat1
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 16
+! band 16:  2600-3250 cm-1 (low - h2o,ch4; high - ch4)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! ka      : real     
+! kb      : real     
+! absa    : real
+! absb    : real
+! selfref : real     
+! forref  : real
+! sfluxref: real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: ka(9,5,13,ng16) , absa(585,ng16)
+      real(kind=rb) :: kb(5,13:59,ng16), absb(235,ng16)
+      real(kind=rb) :: selfref(10,ng16), forref(3,ng16)
+      real(kind=rb) :: sfluxref(ng16)
+
+      equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
+
+      end module rrsw_kg16
+
+      module rrsw_kg17
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng17
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 17
+! band 17:  3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real
+!sfluxrefo: real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no17 = 16
+
+      real(kind=rb) :: kao(9,5,13,no17)
+      real(kind=rb) :: kbo(5,5,13:59,no17)
+      real(kind=rb) :: selfrefo(10,no17), forrefo(4,no17)
+      real(kind=rb) :: sfluxrefo(no17,5)
+
+      integer(kind=im) :: layreffr
+      real(kind=rb) :: rayl, strrat
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 17
+! band 17:  3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! ka      : real     
+! kb      : real     
+! absa    : real
+! absb    : real
+! selfref : real     
+! forref  : real
+! sfluxref: real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: ka(9,5,13,ng17) , absa(585,ng17)
+      real(kind=rb) :: kb(5,5,13:59,ng17), absb(1175,ng17)
+      real(kind=rb) :: selfref(10,ng17), forref(4,ng17)
+      real(kind=rb) :: sfluxref(ng17,5)
+
+      equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
+
+      end module rrsw_kg17
+
+      module rrsw_kg18
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng18
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 18
+! band 18:  4000-4650 cm-1 (low - h2o,ch4; high - ch4)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real
+!sfluxrefo: real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no18 = 16
+
+      real(kind=rb) :: kao(9,5,13,no18)
+      real(kind=rb) :: kbo(5,13:59,no18)
+      real(kind=rb) :: selfrefo(10,no18), forrefo(3,no18)
+      real(kind=rb) :: sfluxrefo(no18,9)
+
+      integer(kind=im) :: layreffr
+      real(kind=rb) :: rayl, strrat
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 18
+! band 18:  4000-4650 cm-1 (low - h2o,ch4; high - ch4)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! ka      : real     
+! kb      : real     
+! absa    : real
+! absb    : real
+! selfref : real     
+! forref  : real
+! sfluxref: real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: ka(9,5,13,ng18), absa(585,ng18)
+      real(kind=rb) :: kb(5,13:59,ng18), absb(235,ng18)
+      real(kind=rb) :: selfref(10,ng18), forref(3,ng18)
+      real(kind=rb) :: sfluxref(ng18,9)
+
+      equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
+
+      end module rrsw_kg18
+
+      module rrsw_kg19
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng19
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 19
+! band 19:  4650-5150 cm-1 (low - h2o,co2; high - co2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real
+!sfluxrefo: real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no19 = 16
+
+      real(kind=rb) :: kao(9,5,13,no19)
+      real(kind=rb) :: kbo(5,13:59,no19)
+      real(kind=rb) :: selfrefo(10,no19), forrefo(3,no19)
+      real(kind=rb) :: sfluxrefo(no19,9)
+
+      integer(kind=im) :: layreffr
+      real(kind=rb) :: rayl, strrat
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 19
+! band 19:  4650-5150 cm-1 (low - h2o,co2; high - co2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! ka      : real     
+! kb      : real     
+! absa    : real
+! absb    : real
+! selfref : real     
+! forref  : real
+! sfluxref: real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: ka(9,5,13,ng19), absa(585,ng19)
+      real(kind=rb) :: kb(5,13:59,ng19), absb(235,ng19)
+      real(kind=rb) :: selfref(10,ng19), forref(3,ng19)
+      real(kind=rb) :: sfluxref(ng19,9)
+
+      equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
+
+      end module rrsw_kg19
+
+      module rrsw_kg20
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng20
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 20
+! band 20:  5150-6150 cm-1 (low - h2o; high - h2o)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real
+!sfluxrefo: real     
+! absch4o : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no20 = 16
+
+      real(kind=rb) :: kao(5,13,no20)
+      real(kind=rb) :: kbo(5,13:59,no20)
+      real(kind=rb) :: selfrefo(10,no20), forrefo(4,no20)
+      real(kind=rb) :: sfluxrefo(no20)
+      real(kind=rb) :: absch4o(no20)
+
+      integer(kind=im) :: layreffr
+      real(kind=rb) :: rayl 
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 20
+! band 20:  5150-6150 cm-1 (low - h2o; high - h2o)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! ka      : real     
+! kb      : real     
+! absa    : real
+! absb    : real
+! selfref : real     
+! forref  : real
+! sfluxref: real     
+! absch4  : real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: ka(5,13,ng20), absa(65,ng20)
+      real(kind=rb) :: kb(5,13:59,ng20), absb(235,ng20)
+      real(kind=rb) :: selfref(10,ng20), forref(4,ng20)
+      real(kind=rb) :: sfluxref(ng20)
+      real(kind=rb) :: absch4(ng20)
+
+      equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
+
+      end module rrsw_kg20
+
+      module rrsw_kg21
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng21
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 21
+! band 21:  6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real
+!sfluxrefo: real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no21 = 16
+
+      real(kind=rb) :: kao(9,5,13,no21)
+      real(kind=rb) :: kbo(5,5,13:59,no21)
+      real(kind=rb) :: selfrefo(10,no21), forrefo(4,no21)
+      real(kind=rb) :: sfluxrefo(no21,9)
+
+      integer(kind=im) :: layreffr
+      real(kind=rb) :: rayl, strrat
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 21
+! band 21:  6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! ka      : real     
+! kb      : real     
+! absa    : real
+! absb    : real
+! selfref : real     
+! forref  : real
+! sfluxref: real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: ka(9,5,13,ng21), absa(585,ng21)
+      real(kind=rb) :: kb(5,5,13:59,ng21), absb(1175,ng21)
+      real(kind=rb) :: selfref(10,ng21), forref(4,ng21)
+      real(kind=rb) :: sfluxref(ng21,9)
+
+      equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
+
+      end module rrsw_kg21
+
+      module rrsw_kg22
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng22
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 22
+! band 22:  7700-8050 cm-1 (low - h2o,o2; high - o2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real
+!sfluxrefo: real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no22 = 16
+
+      real(kind=rb) :: kao(9,5,13,no22)
+      real(kind=rb) :: kbo(5,13:59,no22)
+      real(kind=rb) :: selfrefo(10,no22), forrefo(3,no22)
+      real(kind=rb) :: sfluxrefo(no22,9)
+
+      integer(kind=im) :: layreffr
+      real(kind=rb) :: rayl, strrat
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 22
+! band 22:  7700-8050 cm-1 (low - h2o,o2; high - o2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! ka      : real     
+! kb      : real     
+! absa    : real
+! absb    : real
+! selfref : real     
+! forref  : real
+! sfluxref: real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: ka(9,5,13,ng22), absa(585,ng22)
+      real(kind=rb) :: kb(5,13:59,ng22), absb(235,ng22)
+      real(kind=rb) :: selfref(10,ng22), forref(3,ng22)
+      real(kind=rb) :: sfluxref(ng22,9)
+
+      equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
+
+      end module rrsw_kg22
+
+      module rrsw_kg23
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng23
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 23
+! band 23:  8050-12850 cm-1 (low - h2o; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real
+!sfluxrefo: real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no23 = 16
+
+      real(kind=rb) :: kao(5,13,no23)
+      real(kind=rb) :: selfrefo(10,no23), forrefo(3,no23)
+      real(kind=rb) :: sfluxrefo(no23)
+      real(kind=rb) :: raylo(no23)
+
+      integer(kind=im) :: layreffr
+      real(kind=rb) :: givfac
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 23
+! band 23:  8050-12850 cm-1 (low - h2o; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! ka      : real     
+! kb      : real     
+! absa    : real
+! absb    : real
+! selfref : real     
+! forref  : real
+! sfluxref: real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: ka(5,13,ng23), absa(65,ng23)
+      real(kind=rb) :: selfref(10,ng23), forref(3,ng23)
+      real(kind=rb) :: sfluxref(ng23), rayl(ng23)
+
+      equivalence (ka(1,1,1),absa(1,1))
+
+      end module rrsw_kg23
+
+      module rrsw_kg24
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng24
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 24
+! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real
+!sfluxrefo: real     
+! abso3ao : real     
+! abso3bo : real     
+! raylao  : real     
+! raylbo  : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no24 = 16
+
+      real(kind=rb) :: kao(9,5,13,no24)
+      real(kind=rb) :: kbo(5,13:59,no24)
+      real(kind=rb) :: selfrefo(10,no24), forrefo(3,no24)
+      real(kind=rb) :: sfluxrefo(no24,9)
+      real(kind=rb) :: abso3ao(no24), abso3bo(no24)
+      real(kind=rb) :: raylao(no24,9), raylbo(no24)
+
+      integer(kind=im) :: layreffr
+      real(kind=rb) :: strrat
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 24
+! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! ka      : real     
+! kb      : real     
+! absa    : real
+! absb    : real
+! selfref : real     
+! forref  : real
+! sfluxref: real     
+! abso3a  : real     
+! abso3b  : real     
+! rayla   : real     
+! raylb   : real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: ka(9,5,13,ng24), absa(585,ng24)
+      real(kind=rb) :: kb(5,13:59,ng24), absb(235,ng24)
+      real(kind=rb) :: selfref(10,ng24), forref(3,ng24)
+      real(kind=rb) :: sfluxref(ng24,9)
+      real(kind=rb) :: abso3a(ng24), abso3b(ng24)
+      real(kind=rb) :: rayla(ng24,9), raylb(ng24)
+
+      equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
+
+      end module rrsw_kg24
+
+      module rrsw_kg25
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng25
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 25
+! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! kao     : real     
+!sfluxrefo: real     
+! abso3ao : real     
+! abso3bo : real     
+! raylo   : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no25 = 16
+
+      real(kind=rb) :: kao(5,13,no25)
+      real(kind=rb) :: sfluxrefo(no25)
+      real(kind=rb) :: abso3ao(no25), abso3bo(no25)
+      real(kind=rb) :: raylo(no25)
+
+      integer(kind=im) :: layreffr
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 25
+! band 25: 16000-22650 cm-1 (low - h2o; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! ka      : real     
+! absa    : real
+! sfluxref: real     
+! abso3a  : real     
+! abso3b  : real     
+! rayl    : real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: ka(5,13,ng25), absa(65,ng25)
+      real(kind=rb) :: sfluxref(ng25)
+      real(kind=rb) :: abso3a(ng25), abso3b(ng25)
+      real(kind=rb) :: rayl(ng25)
+
+      equivalence (ka(1,1,1),absa(1,1))
+
+      end module rrsw_kg25
+
+      module rrsw_kg26
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng26
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 26
+! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+!sfluxrefo: real     
+! raylo   : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no26 = 16
+
+      real(kind=rb) :: sfluxrefo(no26)
+      real(kind=rb) :: raylo(no26)
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 26
+! band 26: 22650-29000 cm-1 (low - nothing; high - nothing)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! sfluxref: real     
+! rayl    : real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: sfluxref(ng26)
+      real(kind=rb) :: rayl(ng26)
+
+      end module rrsw_kg26
+
+      module rrsw_kg27
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng27
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 27
+! band 27: 29000-38000 cm-1 (low - o3; high - o3)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! kao     : real     
+! kbo     : real     
+!sfluxrefo: real     
+! raylo   : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no27 = 16
+
+      real(kind=rb) :: kao(5,13,no27)
+      real(kind=rb) :: kbo(5,13:59,no27)
+      real(kind=rb) :: sfluxrefo(no27)
+      real(kind=rb) :: raylo(no27)
+
+      integer(kind=im) :: layreffr
+      real(kind=rb) :: scalekur
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 27
+! band 27: 29000-38000 cm-1 (low - o3; high - o3)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! ka      : real     
+! kb      : real     
+! absa    : real
+! absb    : real
+! sfluxref: real     
+! rayl    : real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: ka(5,13,ng27), absa(65,ng27)
+      real(kind=rb) :: kb(5,13:59,ng27), absb(235,ng27)
+      real(kind=rb) :: sfluxref(ng27)
+      real(kind=rb) :: rayl(ng27)
+
+      equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
+
+      end module rrsw_kg27
+
+      module rrsw_kg28
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng28
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 28
+! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! kao     : real     
+! kbo     : real     
+!sfluxrefo: real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no28 = 16
+
+      real(kind=rb) :: kao(9,5,13,no28)
+      real(kind=rb) :: kbo(5,5,13:59,no28)
+      real(kind=rb) :: sfluxrefo(no28,5)
+
+      integer(kind=im) :: layreffr
+      real(kind=rb) :: rayl, strrat
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 28
+! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! ka      : real     
+! kb      : real     
+! sfluxref: real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: ka(9,5,13,ng28), absa(585,ng28)
+      real(kind=rb) :: kb(5,5,13:59,ng28), absb(1175,ng28)
+      real(kind=rb) :: sfluxref(ng28,5)
+
+      equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1))
+
+      end module rrsw_kg28
+
+      module rrsw_kg29
+
+      use parkind ,only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ng29
+
+!     implicit none
+      save
+
+!-----------------------------------------------------------------
+! rrtmg_sw ORIGINAL abs. coefficients for interval 29
+! band 29:  820-2600 cm-1 (low - h2o; high - co2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! kao     : real     
+! kbo     : real     
+! selfrefo: real     
+! forrefo : real     
+!sfluxrefo: real     
+! absh2oo : real     
+! absco2o : real     
+!-----------------------------------------------------------------
+
+      integer(kind=im), parameter :: no29 = 16
+
+      real(kind=rb) :: kao(5,13,no29)
+      real(kind=rb) :: kbo(5,13:59,no29)
+      real(kind=rb) :: selfrefo(10,no29), forrefo(4,no29)
+      real(kind=rb) :: sfluxrefo(no29)
+      real(kind=rb) :: absh2oo(no29), absco2o(no29)
+
+      integer(kind=im) :: layreffr
+      real(kind=rb) :: rayl
+
+!-----------------------------------------------------------------
+! rrtmg_sw COMBINED abs. coefficients for interval 29
+! band 29:  820-2600 cm-1 (low - h2o; high - co2)
+!
+! Initial version:  JJMorcrette, ECMWF, oct1999
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!-----------------------------------------------------------------
+!
+!  name     type     purpose
+!  ----   : ----   : ---------------------------------------------
+! ka      : real     
+! kb      : real     
+! selfref : real     
+! forref  : real     
+! sfluxref: real     
+! absh2o  : real     
+! absco2  : real     
+!-----------------------------------------------------------------
+
+      real(kind=rb) :: ka(5,13,ng29), absa(65,ng29)
+      real(kind=rb) :: kb(5,13:59,ng29), absb(235,ng29)
+      real(kind=rb) :: selfref(10,ng29), forref(4,ng29)
+      real(kind=rb) :: sfluxref(ng29)
+      real(kind=rb) :: absh2o(ng29), absco2(ng29)
+
+      equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
+
+      end module rrsw_kg29
+
+      module rrsw_ref
+
+      use parkind, only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_sw reference atmosphere 
+! Based on standard mid-latitude summer profile
+!
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jun2006
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+! pref   :  real   : Reference pressure levels
+! preflog:  real   : Reference pressure levels, ln(pref)
+! tref   :  real   : Reference temperature levels for MLS profile
+!------------------------------------------------------------------
+
+      real(kind=rb) , dimension(59) :: pref
+      real(kind=rb) , dimension(59) :: preflog
+      real(kind=rb) , dimension(59) :: tref
+
+      end module rrsw_ref
+
+      module rrsw_tbl
+
+      use parkind, only : im => kind_im, rb => kind_rb
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_sw lookup table arrays
+
+! Initial version: MJIacono, AER, may2007
+! Revised: MJIacono, AER, aug2007
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+! ntbl   :  integer: Lookup table dimension
+! tblint :  real   : Lookup table conversion factor
+! tau_tbl:  real   : Clear-sky optical depth 
+! exp_tbl:  real   : Exponential lookup table for transmittance
+! od_lo  :  real   : Value of tau below which expansion is used
+!                  : in place of lookup table
+! pade   :  real   : Pade approximation constant
+! bpade  :  real   : Inverse of Pade constant
+!------------------------------------------------------------------
+
+      integer(kind=im), parameter :: ntbl = 10000
+
+      real(kind=rb), parameter :: tblint = 10000.0_rb
+
+      real(kind=rb), parameter :: od_lo = 0.06_rb
+
+      real(kind=rb) :: tau_tbl
+      real(kind=rb) , dimension(0:ntbl) :: exp_tbl
+
+      real(kind=rb), parameter :: pade = 0.278_rb
+      real(kind=rb) :: bpade
+
+      end module rrsw_tbl
+
+      module rrsw_vsn
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_sw version information
+
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+!hnamrtm :character: 
+!hnamini :character: 
+!hnamcld :character: 
+!hnamclc :character: 
+!hnamrft :character: 
+!hnamspv :character: 
+!hnamspc :character: 
+!hnamset :character: 
+!hnamtau :character: 
+!hnamvqd :character: 
+!hnamatm :character: 
+!hnamutl :character: 
+!hnamext :character: 
+!hnamkg  :character: 
+!
+! hvrrtm :character: 
+! hvrini :character: 
+! hvrcld :character: 
+! hvrclc :character: 
+! hvrrft :character: 
+! hvrspv :character: 
+! hvrspc :character: 
+! hvrset :character: 
+! hvrtau :character: 
+! hvrvqd :character: 
+! hvratm :character: 
+! hvrutl :character: 
+! hvrext :character: 
+! hvrkg  :character: 
+!------------------------------------------------------------------
+
+      character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrft,hvrspv, &
+                   hvrspc,hvrset,hvrtau,hvrvqd,hvratm,hvrutl,hvrext
+      character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrft,hnamspv, &
+                   hnamspc,hnamset,hnamtau,hnamvqd,hnamatm,hnamutl,hnamext
+
+      character*18 hvrkg
+      character*20 hnamkg
+
+      end module rrsw_vsn
+
+      module rrsw_wvn
+
+      use parkind, only : im => kind_im, rb => kind_rb
+      use parrrsw, only : nbndsw, mg, ngptsw, jpb1, jpb2
+
+!     implicit none
+      save
+
+!------------------------------------------------------------------
+! rrtmg_sw spectral information
+
+! Initial version:  JJMorcrette, ECMWF, jul1998
+! Revised: MJIacono, AER, jul2006
+! Revised: MJIacono, AER, aug2008
+!------------------------------------------------------------------
+
+!  name     type     purpose
+! -----  :  ----   : ----------------------------------------------
+! ng     :  integer: Number of original g-intervals in each spectral band
+! nspa   :  integer: 
+! nspb   :  integer: 
+!wavenum1:  real   : Spectral band lower boundary in wavenumbers
+!wavenum2:  real   : Spectral band upper boundary in wavenumbers
+! delwave:  real   : Spectral band width in wavenumbers
+!
+! ngc    :  integer: The number of new g-intervals in each band
+! ngs    :  integer: The cumulative sum of new g-intervals for each band
+! ngm    :  integer: The index of each new g-interval relative to the
+!                    original 16 g-intervals in each band
+! ngn    :  integer: The number of original g-intervals that are 
+!                    combined to make each new g-intervals in each band
+! ngb    :  integer: The band index for each new g-interval
+! wt     :  real   : RRTM weights for the original 16 g-intervals
+! rwgt   :  real   : Weights for combining original 16 g-intervals 
+!                    (224 total) into reduced set of g-intervals 
+!                    (112 total)
+!------------------------------------------------------------------
+
+      integer(kind=im) :: ng(jpb1:jpb2)
+      integer(kind=im) :: nspa(jpb1:jpb2)
+      integer(kind=im) :: nspb(jpb1:jpb2)
+
+      real(kind=rb) :: wavenum1(jpb1:jpb2)
+      real(kind=rb) :: wavenum2(jpb1:jpb2)
+      real(kind=rb) :: delwave(jpb1:jpb2)
+
+      integer(kind=im) :: ngc(nbndsw)
+      integer(kind=im) :: ngs(nbndsw)
+      integer(kind=im) :: ngn(ngptsw)
+      integer(kind=im) :: ngb(ngptsw)
+      integer(kind=im) :: ngm(nbndsw*mg)
+
+      real(kind=rb) :: wt(mg)
+      real(kind=rb) :: rwgt(nbndsw*mg)
+
+      end module rrsw_wvn
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+!
+      module mcica_subcol_gen_sw
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2006-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! Purpose: Create McICA stochastic arrays for cloud physical or optical properties.   
+! Two options are possible:
+! 1) Input cloud physical properties: cloud fraction, ice and liquid water
+!    paths, ice fraction, and particle sizes.  Output will be stochastic
+!    arrays of these variables.  (inflag = 1)
+! 2) Input cloud optical properties directly: cloud optical depth, single
+!    scattering albedo and asymmetry parameter.  Output will be stochastic
+!    arrays of these variables.  (inflag = 0)
+
+! --------- Modules ----------
+
+      use parkind, only : im => kind_im, rb => kind_rb
+      use parrrsw, only : nbndsw, ngptsw
+      use rrsw_con, only: grav
+      use rrsw_wvn, only: ngb
+      use rrsw_vsn
+
+      implicit none
+
+! public interfaces/functions/subroutines
+      public :: mcica_subcol_sw, generate_stochastic_clouds_sw
+
+      contains
+
+!------------------------------------------------------------------
+! Public subroutines
+!------------------------------------------------------------------
+
+      subroutine mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
+                       cldfrac, ciwp, clwp, rei, rel, tauc, ssac, asmc, fsfc, &
+                       cldfmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, &
+                       taucmcl, ssacmcl, asmcmcl, fsfcmcl)
+
+! ----- Input -----
+! Control
+      integer(kind=im), intent(in) :: iplon           ! column/longitude dimension
+      integer(kind=im), intent(in) :: ncol            ! number of columns
+      integer(kind=im), intent(in) :: nlay            ! number of model layers
+      integer(kind=im), intent(in) :: icld            ! clear/cloud, cloud overlap flag
+      integer(kind=im), intent(in) :: permuteseed     ! if the cloud generator is called multiple times,
+                                                      ! permute the seed between each call;
+                                                      ! between calls for LW and SW, recommended
+                                                      ! permuteseed differs by 'ngpt'
+      integer(kind=im), intent(inout) :: irng         ! flag for random number generator
+                                                      !  0 = kissvec
+                                                      !  1 = Mersenne Twister
+        
+! Atmosphere
+      real(kind=rb), intent(in) :: play(:,:)          ! layer pressures (mb) 
+                                                      !    Dimensions: (ncol,nlay)
+
+! Atmosphere/clouds - cldprop
+      real(kind=rb), intent(in) :: cldfrac(:,:)       ! layer cloud fraction
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: tauc(:,:,:)        ! in-cloud optical depth
+                                                      !    Dimensions: (nbndsw,ncol,nlay)
+      real(kind=rb), intent(in) :: ssac(:,:,:)        ! in-cloud single scattering albedo (non-delta scaled)
+                                                      !    Dimensions: (nbndsw,ncol,nlay)
+      real(kind=rb), intent(in) :: asmc(:,:,:)        ! in-cloud asymmetry parameter (non-delta scaled)
+                                                      !    Dimensions: (nbndsw,ncol,nlay)
+      real(kind=rb), intent(in) :: fsfc(:,:,:)        ! in-cloud forward scattering fraction (non-delta scaled)
+                                                      !    Dimensions: (nbndsw,ncol,nlay)
+      real(kind=rb), intent(in) :: ciwp(:,:)          ! in-cloud ice water path
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: clwp(:,:)          ! in-cloud liquid water path
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: rei(:,:)           ! cloud ice particle size
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: rel(:,:)           ! cloud liquid particle size
+                                                      !    Dimensions: (ncol,nlay)
+
+! ----- Output -----
+! Atmosphere/clouds - cldprmc [mcica]
+      real(kind=rb), intent(out) :: cldfmcl(:,:,:)    ! cloud fraction [mcica]
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: ciwpmcl(:,:,:)    ! in-cloud ice water path [mcica]
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: clwpmcl(:,:,:)    ! in-cloud liquid water path [mcica]
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: relqmcl(:,:)      ! liquid particle size (microns)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(out) :: reicmcl(:,:)      ! ice partcle size (microns)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(out) :: taucmcl(:,:,:)    ! in-cloud optical depth [mcica]
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: ssacmcl(:,:,:)    ! in-cloud single scattering albedo [mcica]
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: asmcmcl(:,:,:)    ! in-cloud asymmetry parameter [mcica]
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: fsfcmcl(:,:,:)    ! in-cloud forward scattering fraction [mcica]
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+
+! ----- Local -----
+
+! Stochastic cloud generator variables [mcica]
+      integer(kind=im), parameter :: nsubcsw = ngptsw ! number of sub-columns (g-point intervals)
+      integer(kind=im) :: ilev                        ! loop index
+
+      real(kind=rb) :: pmid(ncol,nlay)                ! layer pressures (Pa) 
+!      real(kind=rb) :: pdel(ncol,nlay)               ! layer pressure thickness (Pa) 
+!      real(kind=rb) :: qi(ncol,nlay)                 ! ice water (specific humidity)
+!      real(kind=rb) :: ql(ncol,nlay)                 ! liq water (specific humidity)
+
+
+! Return if clear sky; or stop if icld out of range
+      if (icld.eq.0) return
+      if (icld.lt.0.or.icld.gt.3) then 
+         stop 'MCICA_SUBCOL: INVALID ICLD'
+      endif 
+
+! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least number of subcolumns
+
+
+! Pass particle sizes to new arrays, no subcolumns for these properties yet
+! Convert pressures from mb to Pa
+
+      reicmcl(:ncol,:nlay) = rei(:ncol,:nlay)
+      relqmcl(:ncol,:nlay) = rel(:ncol,:nlay)
+      pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb
+
+! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components 
+
+!      cwp =  (q * pdel * 1000.) / gravit)
+!           = (kg/kg * kg m-1 s-2 *1000.) / m s-2
+!           = (g m-2)
+!
+!      q  = (cwp * gravit) / (pdel *1000.)
+!         = (g m-2 * m s-2) / (kg m-1 s-2 * 1000.)
+!         =  kg/kg
+
+!      do ilev = 1, nlay
+!         qi(ilev) = (ciwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
+!         ql(ilev) = (clwp(ilev) * grav) / (pdel(ilev) * 1000._rb)
+!      enddo
+
+!  Generate the stochastic subcolumns of cloud optical properties for the shortwave;
+      call generate_stochastic_clouds_sw (ncol, nlay, nsubcsw, icld, irng, pmid, cldfrac, clwp, ciwp, &
+                               tauc, ssac, asmc, fsfc, cldfmcl, clwpmcl, ciwpmcl, &
+                               taucmcl, ssacmcl, asmcmcl, fsfcmcl, permuteseed)
+
+      end subroutine mcica_subcol_sw
+
+
+!-------------------------------------------------------------------------------------------------
+      subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, irng, pmid, cld, clwp, ciwp, &
+                               tauc, ssac, asmc, fsfc, cld_stoch, clwp_stoch, ciwp_stoch, &
+                               tauc_stoch, ssac_stoch, asmc_stoch, fsfc_stoch, changeSeed) 
+!-------------------------------------------------------------------------------------------------
+
+  !----------------------------------------------------------------------------------------------------------------
+  ! ---------------------
+  ! Contact: Cecile Hannay (hannay@ucar.edu)
+  ! 
+  ! Original code: Based on Raisanen et al., QJRMS, 2004.
+  !
+  ! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default
+  !   random number generator, which can be changed to the optional kissvec random number generator
+  !   with flag 'irng'. Some extra functionality has been commented or removed.  
+  !   Michael J. Iacono, AER, Inc., February 2007
+  !
+  ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns.
+  ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one 
+  ! and uniform cloud liquid and cloud ice concentration.
+  ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer 
+  ! and obeys an overlap assumption in the vertical.   
+  ! 
+  ! Overlap assumption:
+  !  The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential. 
+  !  The default option is maximum-random (option 3)
+  !  The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap
+  !  This is set with the variable "overlap" 
+  !mji - Exponential overlap option (overlap=4) has been deactivated in this version
+  !  The exponential overlap uses also a length scale, Zo. (real,    parameter  :: Zo = 2500. ) 
+  ! 
+  ! Seed:
+  !  If the stochastic cloud generator is called several times during the same timestep, 
+  !  one should change the seed between the call to insure that the subcolumns are different.
+  !  This is done by changing the argument 'changeSeed'
+  !  For example, if one wants to create a set of columns for the shortwave and another set for the longwave ,
+  !  use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call 
+  !
+  ! PDF assumption:
+  !  We can use arbitrary complicated PDFS. 
+  !  In the present version, we produce homogeneuous clouds (the simplest case).  
+  !  Future developments include using the PDF scheme of Ben Johnson. 
+  !
+  ! History file:
+  !  Option to add diagnostics variables in the history file. (using FINCL in the namelist)
+  !  nsubcol = number of subcolumns
+  !  overlap = overlap type (1-3)
+  !  Zo = length scale 
+  !  CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic)
+  !  CLDLIQ_S = mean of the subcolumn cloud water
+  !  CLDICE_S = mean of the subcolumn cloud ice 
+  !
+  ! Note:
+  !   Here: we force that the cloud condensate to be consistent with the cloud fraction 
+  !   i.e we only have cloud condensate when the cell is cloudy. 
+  !   In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations 
+  !   and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction 
+  !   without cloud condensate or the opposite).
+  !---------------------------------------------------------------------------------------------------------------
+
+      use mcica_random_numbers
+! The Mersenne Twister random number engine
+      use MersenneTwister, only: randomNumberSequence, &   
+                                 new_RandomNumberSequence, getRandomReal
+
+      type(randomNumberSequence) :: randomNumbers
+
+! -- Arguments
+
+      integer(kind=im), intent(in) :: ncol            ! number of layers
+      integer(kind=im), intent(in) :: nlay            ! number of layers
+      integer(kind=im), intent(in) :: icld            ! clear/cloud, cloud overlap flag
+      integer(kind=im), intent(inout) :: irng         ! flag for random number generator
+                                                      !  0 = kissvec
+                                                      !  1 = Mersenne Twister
+      integer(kind=im), intent(in) :: nsubcol         ! number of sub-columns (g-point intervals)
+      integer(kind=im), optional, intent(in) :: changeSeed     ! allows permuting seed
+
+! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state 
+      real(kind=rb), intent(in) :: pmid(:,:)          ! layer pressure (Pa)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: cld(:,:)           ! cloud fraction 
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: clwp(:,:)          ! in-cloud liquid water path (g/m2)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: ciwp(:,:)          ! in-cloud ice water path (g/m2)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: tauc(:,:,:)        ! in-cloud optical depth (non-delta scaled)
+                                                      !    Dimensions: (nbndsw,ncol,nlay)
+      real(kind=rb), intent(in) :: ssac(:,:,:)        ! in-cloud single scattering albedo (non-delta scaled)
+                                                      !    Dimensions: (nbndsw,ncol,nlay)
+      real(kind=rb), intent(in) :: asmc(:,:,:)        ! in-cloud asymmetry parameter (non-delta scaled)
+                                                      !    Dimensions: (nbndsw,ncol,nlay)
+      real(kind=rb), intent(in) :: fsfc(:,:,:)        ! in-cloud forward scattering fraction (non-delta scaled)
+                                                      !    Dimensions: (nbndsw,ncol,nlay)
+
+      real(kind=rb), intent(out) :: cld_stoch(:,:,:)  ! subcolumn cloud fraction 
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: ssac_stoch(:,:,:) ! subcolumn in-cloud single scattering albedo
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: asmc_stoch(:,:,:) ! subcolumn in-cloud asymmetry parameter
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: fsfc_stoch(:,:,:) ! subcolumn in-cloud forward scattering fraction
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+
+! -- Local variables
+      real(kind=rb) :: cldf(ncol,nlay)                ! cloud fraction 
+                                                      !    Dimensions: (ncol,nlay)
+
+! Mean over the subcolumns (cloud fraction, cloud water , cloud ice) - inactive
+!      real(kind=rb) :: mean_cld_stoch(ncol,nlay)     ! cloud fraction 
+!      real(kind=rb) :: mean_clwp_stoch(ncol,nlay)    ! cloud water
+!      real(kind=rb) :: mean_ciwp_stoch(ncol,nlay)    ! cloud ice
+!      real(kind=rb) :: mean_tauc_stoch(ncol,nlay)    ! cloud optical depth
+!      real(kind=rb) :: mean_ssac_stoch(ncol,nlay)    ! cloud single scattering albedo
+!      real(kind=rb) :: mean_asmc_stoch(ncol,nlay)    ! cloud asymmetry parameter
+!      real(kind=rb) :: mean_fsfc_stoch(ncol,nlay)    ! cloud forward scattering fraction
+
+! Set overlap
+      integer(kind=im) :: overlap                     ! 1 = random overlap, 2 = maximum/random,
+                                                      ! 3 = maximum overlap, 
+!      real(kind=rb), parameter  :: Zo = 2500._rb        ! length scale (m) 
+!      real(kind=rb) :: zm(ncon,nlay)                    ! Height of midpoints (above surface)
+!      real(kind=rb), dimension(nlay) :: alpha=0.0_rb    ! overlap parameter  
+
+! Constants (min value for cloud fraction and cloud water and ice)
+      real(kind=rb), parameter :: cldmin = 1.0e-20_rb ! min cloud fraction
+!      real(kind=rb), parameter :: qmin   = 1.0e-10_rb   ! min cloud water and cloud ice (not used)
+
+! Variables related to random number and seed 
+      real(kind=rb), dimension(nsubcol, ncol, nlay) :: CDF, CDF2       ! random numbers
+      integer(kind=im), dimension(ncol) :: seed1, seed2, seed3, seed4  ! seed to create random number
+      real(kind=rb), dimension(ncol) :: rand_num       ! random number (kissvec)
+      integer(kind=im) :: iseed                        ! seed to create random number (Mersenne Twister)
+      real(kind=rb) :: rand_num_mt                     ! random number (Mersenne Twister)
+
+! Flag to identify cloud fraction in subcolumns
+      logical,  dimension(nsubcol, ncol, nlay) :: isCloudy   ! flag that says whether a gridbox is cloudy
+
+! Indices
+      integer(kind=im) :: ilev, isubcol, i, n, ngbm    ! indices
+
+!------------------------------------------------------------------------------------------ 
+
+! Check that irng is in bounds; if not, set to default
+      if (irng .ne. 0) irng = 1
+
+! Pass input cloud overlap setting to local variable
+      overlap = icld
+
+! Ensure that cloud fractions are in bounds 
+      do ilev = 1, nlay
+         do i = 1, ncol
+            cldf(i,ilev) = cld(i,ilev)
+            if (cldf(i,ilev) < cldmin) then
+               cldf(i,ilev) = 0._rb
+            endif
+         enddo
+      enddo
+
+! ----- Create seed  --------
+   
+! Advance randum number generator by changeseed values
+      if (irng.eq.0) then   
+! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works.  
+! Must use pmid from bottom four layers. 
+         do i=1,ncol
+            if (pmid(i,1).lt.pmid(i,2)) then
+               stop 'MCICA_SUBCOL: KISSVEC SEED GENERATOR REQUIRES PMID FROM BOTTOM FOUR LAYERS.'
+            endif
+            seed1(i) = (pmid(i,1) - int(pmid(i,1)))  * 1000000000_im
+            seed2(i) = (pmid(i,2) - int(pmid(i,2)))  * 1000000000_im
+            seed3(i) = (pmid(i,3) - int(pmid(i,3)))  * 1000000000_im
+            seed4(i) = (pmid(i,4) - int(pmid(i,4)))  * 1000000000_im
+          enddo
+         do i=1,changeSeed
+            call kissvec(seed1, seed2, seed3, seed4, rand_num)
+         enddo
+      elseif (irng.eq.1) then
+         randomNumbers = new_RandomNumberSequence(seed = changeSeed)
+      endif 
+
+
+! ------ Apply overlap assumption --------
+
+! generate the random numbers  
+
+      select case (overlap)
+
+      case(1) 
+! Random overlap
+! i) pick a random value at every level
+  
+         if (irng.eq.0) then 
+            do isubcol = 1,nsubcol
+               do ilev = 1,nlay
+                  call kissvec(seed1, seed2, seed3, seed4, rand_num)
+                  CDF(isubcol,:,ilev) = rand_num
+               enddo
+            enddo
+         elseif (irng.eq.1) then
+            do isubcol = 1, nsubcol
+               do i = 1, ncol
+                  do ilev = 1, nlay
+                     rand_num_mt = getRandomReal(randomNumbers)
+                     CDF(isubcol,i,ilev) = rand_num_mt
+                  enddo
+               enddo
+             enddo
+         endif
+
+      case(2) 
+! Maximum-Random overlap
+! i) pick  a random number for top layer.
+! ii) walk down the column: 
+!    - if the layer above is cloudy, we use the same random number than in the layer above
+!    - if the layer above is clear, we use a new random number 
+
+         if (irng.eq.0) then 
+            do isubcol = 1,nsubcol
+               do ilev = 1,nlay
+                  call kissvec(seed1, seed2, seed3, seed4, rand_num)
+                  CDF(isubcol,:,ilev) = rand_num
+               enddo
+            enddo
+         elseif (irng.eq.1) then
+            do isubcol = 1, nsubcol
+               do i = 1, ncol
+                  do ilev = 1, nlay
+                     rand_num_mt = getRandomReal(randomNumbers)
+                     CDF(isubcol,i,ilev) = rand_num_mt
+                  enddo
+               enddo
+             enddo
+         endif
+
+         do ilev = 2,nlay
+            do i = 1, ncol
+               do isubcol = 1, nsubcol
+                  if (CDF(isubcol, i, ilev-1) > 1._rb - cldf(i,ilev-1) ) then
+                     CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev-1) 
+                  else
+                     CDF(isubcol,i,ilev) = CDF(isubcol,i,ilev) * (1._rb - cldf(i,ilev-1)) 
+                  endif
+               enddo
+            enddo
+         enddo
+
+      case(3) 
+! Maximum overlap
+! i) pick same random numebr at every level  
+
+         if (irng.eq.0) then 
+            do isubcol = 1,nsubcol
+               call kissvec(seed1, seed2, seed3, seed4, rand_num)
+               do ilev = 1,nlay
+                  CDF(isubcol,:,ilev) = rand_num
+               enddo
+            enddo
+         elseif (irng.eq.1) then
+            do isubcol = 1, nsubcol
+               do i = 1, ncol
+                  rand_num_mt = getRandomReal(randomNumbers)
+                  do ilev = 1, nlay
+                     CDF(isubcol,i,ilev) = rand_num_mt
+                  enddo
+               enddo
+             enddo
+         endif
+
+!    case(4)  - inactive
+!       ! Exponential overlap: weighting between maximum and random overlap increases with the distance. 
+!       ! The random numbers for exponential overlap verify:
+!       ! j=1   RAN(j)=RND1
+!       ! j>1   if RND1 < alpha(j,j-1) => RAN(j) = RAN(j-1)
+!       !                                 RAN(j) = RND2
+!       ! alpha is obtained from the equation
+!       ! alpha = exp(- (Zi-Zj-1)/Zo) where Zo is a characteristic length scale    
+
+
+!       ! compute alpha
+!       zm    = state%zm     
+!       alpha(:, 1) = 0._rb
+!       do ilev = 2,nlay
+!          alpha(:, ilev) = exp( -( zm (:, ilev-1) -  zm (:, ilev)) / Zo)
+!       end do
+       
+!       ! generate 2 streams of random numbers
+!       do isubcol = 1,nsubcol
+!          do ilev = 1,nlay
+!             call kissvec(seed1, seed2, seed3, seed4, rand_num)
+!             CDF(isubcol, :, ilev) = rand_num
+!             call kissvec(seed1, seed2, seed3, seed4, rand_num)
+!             CDF2(isubcol, :, ilev) = rand_num
+!          end do
+!       end do
+
+!       ! generate random numbers
+!       do ilev = 2,nlay
+!          where (CDF2(:, :, ilev) < spread(alpha (:,ilev), dim=1, nCopies=nsubcol) )
+!             CDF(:,:,ilev) = CDF(:,:,ilev-1) 
+!          end where
+!       end do
+
+      end select
+
+ 
+! -- generate subcolumns for homogeneous clouds -----
+      do ilev = 1, nlay
+         isCloudy(:,:,ilev) = (CDF(:,:,ilev) >= 1._rb - spread(cldf(:,ilev), dim=1, nCopies=nsubcol) )
+      enddo
+
+! where the subcolumn is cloudy, the subcolumn cloud fraction is 1;
+! where the subcolumn is not cloudy, the subcolumn cloud fraction is 0;
+! where there is a cloud, define the subcolumn cloud properties,
+! otherwise set these to zero
+
+      ngbm = ngb(1) - 1
+      do ilev = 1,nlay
+         do i = 1, ncol
+            do isubcol = 1, nsubcol
+               if ( iscloudy(isubcol,i,ilev) ) then
+                  cld_stoch(isubcol,i,ilev) = 1._rb
+                  clwp_stoch(isubcol,i,ilev) = clwp(i,ilev)
+                  ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev)
+                  n = ngb(isubcol) - ngbm
+                  tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev)
+                  ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev)
+                  asmc_stoch(isubcol,i,ilev) = asmc(n,i,ilev)
+                  fsfc_stoch(isubcol,i,ilev) = fsfc(n,i,ilev)
+               else
+                  cld_stoch(isubcol,i,ilev) = 0._rb
+                  clwp_stoch(isubcol,i,ilev) = 0._rb
+                  ciwp_stoch(isubcol,i,ilev) = 0._rb
+                  tauc_stoch(isubcol,i,ilev) = 0._rb
+                  ssac_stoch(isubcol,i,ilev) = 1._rb
+                  asmc_stoch(isubcol,i,ilev) = 0._rb
+                  fsfc_stoch(isubcol,i,ilev) = 0._rb
+               endif
+            enddo
+         enddo
+      enddo
+
+! -- compute the means of the subcolumns ---
+!      mean_cld_stoch(:,:) = 0._rb
+!      mean_clwp_stoch(:,:) = 0._rb
+!      mean_ciwp_stoch(:,:) = 0._rb
+!      mean_tauc_stoch(:,:) = 0._rb
+!      mean_ssac_stoch(:,:) = 0._rb
+!      mean_asmc_stoch(:,:) = 0._rb
+!      mean_fsfc_stoch(:,:) = 0._rb
+!      do i = 1, nsubcol
+!         mean_cld_stoch(:,:) =  cld_stoch(i,:,:) + mean_cld_stoch(:,:) 
+!         mean_clwp_stoch(:,:) =  clwp_stoch( i,:,:) + mean_clwp_stoch(:,:) 
+!         mean_ciwp_stoch(:,:) =  ciwp_stoch( i,:,:) + mean_ciwp_stoch(:,:) 
+!         mean_tauc_stoch(:,:) =  tauc_stoch( i,:,:) + mean_tauc_stoch(:,:) 
+!         mean_ssac_stoch(:,:) =  ssac_stoch( i,:,:) + mean_ssac_stoch(:,:) 
+!         mean_asmc_stoch(:,:) =  asmc_stoch( i,:,:) + mean_asmc_stoch(:,:) 
+!         mean_fsfc_stoch(:,:) =  fsfc_stoch( i,:,:) + mean_fsfc_stoch(:,:) 
+!      end do
+!      mean_cld_stoch(:,:) = mean_cld_stoch(:,:) / nsubcol
+!      mean_clwp_stoch(:,:) = mean_clwp_stoch(:,:) / nsubcol
+!      mean_ciwp_stoch(:,:) = mean_ciwp_stoch(:,:) / nsubcol
+!      mean_tauc_stoch(:,:) = mean_tauc_stoch(:,:) / nsubcol
+!      mean_ssac_stoch(:,:) = mean_ssac_stoch(:,:) / nsubcol
+!      mean_asmc_stoch(:,:) = mean_asmc_stoch(:,:) / nsubcol
+!      mean_fsfc_stoch(:,:) = mean_fsfc_stoch(:,:) / nsubcol
+
+      end subroutine generate_stochastic_clouds_sw
+
+
+!-------------------------------------------------------------------------------------------------- 
+      subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr)
+!-------------------------------------------------------------------------------------------------- 
+
+! public domain code
+! made available from http://www.fortran.com/
+! downloaded by pjr on 03/16/04 for NCAR CAM
+! converted to vector form, functions inlined by pjr,mvr on 05/10/2004
+
+! The  KISS (Keep It Simple Stupid) random number generator. Combines:
+! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32.
+! (2) A 3-shift shift-register generator, period 2^32-1,
+! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59
+!  Overall period>2^123; 
+!
+      real(kind=rb), dimension(:), intent(inout)  :: ran_arr
+      integer(kind=im), dimension(:), intent(inout) :: seed1,seed2,seed3,seed4
+      integer(kind=im) :: i,sz,kiss
+      integer(kind=im) :: m, k, n
+
+! inline function 
+      m(k, n) = ieor (k, ishft (k, n) )
+
+      sz = size(ran_arr)
+      do i = 1, sz
+         seed1(i) = 69069_im * seed1(i) + 1327217885_im
+         seed2(i) = m (m (m (seed2(i), 13_im), - 17_im), 5_im)
+         seed3(i) = 18000_im * iand (seed3(i), 65535_im) + ishft (seed3(i), - 16_im)
+         seed4(i) = 30903_im * iand (seed4(i), 65535_im) + ishft (seed4(i), - 16_im)
+         kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16_im) + seed4(i)
+         ran_arr(i) = kiss*2.328306e-10_rb + 0.5_rb
+      end do
+    
+      end subroutine kissvec
+
+      end module mcica_subcol_gen_sw
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+
+      module rrtmg_sw_cldprmc
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parkind, only : im => kind_im, rb => kind_rb
+      use parrrsw, only : ngptsw, jpband, jpb1, jpb2
+      use rrsw_cld, only : extliq1, ssaliq1, asyliq1, &
+                           extice2, ssaice2, asyice2, &
+                           extice3, ssaice3, asyice3, fdlice3, &
+                           abari, bbari, cbari, dbari, ebari, fbari
+      use rrsw_wvn, only : wavenum1, wavenum2, ngb
+      use rrsw_vsn, only : hvrclc, hnamclc
+
+      implicit none
+
+      contains
+
+! ----------------------------------------------------------------------------
+      subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
+                            ciwpmc, clwpmc, reicmc, relqmc, &
+                            taormc, taucmc, ssacmc, asmcmc, fsfcmc)
+! ----------------------------------------------------------------------------
+
+! Purpose: Compute the cloud optical properties for each cloudy layer
+! and g-point interval for use by the McICA method.  
+! Note: Only inflag = 0 and inflag=2/liqflag=1/iceflag=2,3 are available;
+! (Hu & Stamnes, Key, and Fu) are implemented. 
+
+! ------- Input -------
+
+      integer(kind=im), intent(in) :: nlayers         ! total number of layers
+      integer(kind=im), intent(in) :: inflag          ! see definitions
+      integer(kind=im), intent(in) :: iceflag         ! see definitions
+      integer(kind=im), intent(in) :: liqflag         ! see definitions
+
+      real(kind=rb), intent(in) :: cldfmc(:,:)        ! cloud fraction [mcica]
+                                                      !    Dimensions: (ngptsw,nlayers)
+      real(kind=rb), intent(in) :: ciwpmc(:,:)        ! cloud ice water path [mcica]
+                                                      !    Dimensions: (ngptsw,nlayers)
+      real(kind=rb), intent(in) :: clwpmc(:,:)        ! cloud liquid water path [mcica]
+                                                      !    Dimensions: (ngptsw,nlayers)
+      real(kind=rb), intent(in) :: relqmc(:)          ! cloud liquid particle effective radius (microns)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: reicmc(:)          ! cloud ice particle effective radius (microns)
+                                                      !    Dimensions: (nlayers)
+                                                      ! specific definition of reicmc depends on setting of iceflag:
+                                                      ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
+                                                      !              r_ec range is limited to 13.0 to 130.0 microns
+                                                      ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
+                                                      !              r_k range is limited to 5.0 to 131.0 microns
+                                                      ! iceflag = 3: generalized effective size, dge, (Fu, 1996),
+                                                      !              dge range is limited to 5.0 to 140.0 microns
+                                                      !              [dge = 1.0315 * r_ec]
+      real(kind=rb), intent(in) :: fsfcmc(:,:)        ! cloud forward scattering fraction
+                                                      !    Dimensions: (ngptsw,nlayers)
+
+! ------- Output -------
+
+      real(kind=rb), intent(inout) :: taucmc(:,:)     ! cloud optical depth (delta scaled)
+                                                      !    Dimensions: (ngptsw,nlayers)
+      real(kind=rb), intent(inout) :: ssacmc(:,:)     ! single scattering albedo (delta scaled)
+                                                      !    Dimensions: (ngptsw,nlayers)
+      real(kind=rb), intent(inout) :: asmcmc(:,:)     ! asymmetry parameter (delta scaled)
+                                                      !    Dimensions: (ngptsw,nlayers)
+      real(kind=rb), intent(out) :: taormc(:,:)       ! cloud optical depth (non-delta scaled)
+                                                      !    Dimensions: (ngptsw,nlayers)
+
+! ------- Local -------
+
+!      integer(kind=im) :: ncbands
+      integer(kind=im) :: ib, lay, istr, index, icx, ig
+
+      real(kind=rb), parameter :: eps = 1.e-06_rb     ! epsilon
+      real(kind=rb), parameter :: cldmin = 1.e-20_rb  ! minimum value for cloud quantities
+      real(kind=rb) :: cwp                            ! total cloud water path
+      real(kind=rb) :: radliq                         ! cloud liquid droplet radius (microns)
+      real(kind=rb) :: radice                         ! cloud ice effective size (microns)
+      real(kind=rb) :: factor
+      real(kind=rb) :: fint
+
+      real(kind=rb) :: taucldorig_a, taucloud_a, ssacloud_a, ffp, ffp1, ffpssa
+      real(kind=rb) :: tauiceorig, scatice, ssaice, tauice, tauliqorig, scatliq, ssaliq, tauliq
+
+      real(kind=rb) :: fdelta(ngptsw)
+      real(kind=rb) :: extcoice(ngptsw), gice(ngptsw)
+      real(kind=rb) :: ssacoice(ngptsw), forwice(ngptsw)
+      real(kind=rb) :: extcoliq(ngptsw), gliq(ngptsw)
+      real(kind=rb) :: ssacoliq(ngptsw), forwliq(ngptsw)
+
+! Initialize
+
+      hvrclc = '$Revision: 1.3 $'
+
+! Some of these initializations are done elsewhere
+      do lay = 1, nlayers
+         do ig = 1, ngptsw
+            taormc(ig,lay) = taucmc(ig,lay)
+!            taucmc(ig,lay) = 0.0_rb
+!            ssacmc(ig,lay) = 1.0_rb
+!            asmcmc(ig,lay) = 0.0_rb
+         enddo
+      enddo
+
+! Main layer loop
+      do lay = 1, nlayers
+
+! Main g-point interval loop
+         do ig = 1, ngptsw 
+            cwp = ciwpmc(ig,lay) + clwpmc(ig,lay)
+
+            if (cldfmc(ig,lay) .ge. cldmin .and. &
+               (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then
+
+! (inflag=0): Cloud optical properties input directly
+               if (inflag .eq. 0) then
+! Cloud optical properties already defined in taucmc, ssacmc, asmcmc are unscaled;
+! Apply delta-M scaling here (using Henyey-Greenstein approximation)
+                  taucldorig_a = taucmc(ig,lay)
+                  ffp = fsfcmc(ig,lay)
+                  ffp1 = 1.0_rb - ffp
+                  ffpssa = 1.0_rb - ffp * ssacmc(ig,lay)
+                  ssacloud_a = ffp1 * ssacmc(ig,lay) / ffpssa
+                  taucloud_a = ffpssa * taucldorig_a
+
+                  taormc(ig,lay) = taucldorig_a
+                  ssacmc(ig,lay) = ssacloud_a
+                  taucmc(ig,lay) = taucloud_a
+                  asmcmc(ig,lay) = (asmcmc(ig,lay) - ffp) / (ffp1)
+
+               elseif (inflag .eq. 1) then 
+                  stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA'
+
+! (inflag=2): Separate treatement of ice clouds and water clouds.
+               elseif (inflag .eq. 2) then       
+                  radice = reicmc(lay)
+
+! Calculation of absorption coefficients due to ice clouds.
+                  if (ciwpmc(ig,lay) .eq. 0.0_rb) then
+                     extcoice(ig) = 0.0_rb
+                     ssacoice(ig) = 0.0_rb
+                     gice(ig)     = 0.0_rb
+                     forwice(ig)  = 0.0_rb
+
+! (iceflag = 1): 
+! Note: This option uses Ebert and Curry approach for all particle sizes similar to
+! CAM3 implementation, though this is somewhat unjustified for large ice particles
+                  elseif (iceflag .eq. 1) then
+                     ib = ngb(ig)
+                     if (wavenum2(ib) .gt. 1.43e04_rb) then
+                        icx = 1
+                     elseif (wavenum2(ib) .gt. 7.7e03_rb) then
+                        icx = 2
+                     elseif (wavenum2(ib) .gt. 5.3e03_rb) then
+                        icx = 3
+                     elseif (wavenum2(ib) .gt. 4.0e03_rb) then
+                        icx = 4
+                     elseif (wavenum2(ib) .ge. 2.5e03_rb) then
+                        icx = 5
+                     endif
+                     extcoice(ig) = (abari(icx) + bbari(icx)/radice)
+                     ssacoice(ig) = 1._rb - cbari(icx) - dbari(icx) * radice
+                     gice(ig) = ebari(icx) + fbari(icx) * radice
+! Check to ensure upper limit of gice is within physical limits for large particles
+                     if (gice(ig).ge.1._rb) gice(ig) = 1._rb - eps
+                     forwice(ig) = gice(ig)*gice(ig)
+! Check to ensure all calculated quantities are within physical limits.
+                     if (extcoice(ig) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
+                     if (ssacoice(ig) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
+                     if (ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
+                     if (gice(ig) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
+                     if (gice(ig) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
+
+! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns
+
+                  elseif (iceflag .eq. 2) then
+                     if (radice .lt. 5.0_rb .or. radice .gt. 131.0_rb) stop 'ICE RADIUS OUT OF BOUNDS'
+                     factor = (radice - 2._rb)/3._rb
+                     index = int(factor)
+                     if (index .eq. 43) index = 42
+                     fint = factor - float(index)
+                     ib = ngb(ig)
+                     extcoice(ig) = extice2(index,ib) + fint * &
+                                   (extice2(index+1,ib) -  extice2(index,ib))
+                     ssacoice(ig) = ssaice2(index,ib) + fint * &
+                                   (ssaice2(index+1,ib) -  ssaice2(index,ib))
+                     gice(ig) = asyice2(index,ib) + fint * &
+                                   (asyice2(index+1,ib) -  asyice2(index,ib))
+                     forwice(ig) = gice(ig)*gice(ig)
+! Check to ensure all calculated quantities are within physical limits.
+                     if (extcoice(ig) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
+                     if (ssacoice(ig) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
+                     if (ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
+                     if (gice(ig) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
+                     if (gice(ig) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
+
+! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns
+
+                  elseif (iceflag .eq. 3) then
+                     if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'
+                     factor = (radice - 2._rb)/3._rb
+                     index = int(factor)
+                     if (index .eq. 46) index = 45
+                     fint = factor - float(index)
+                     ib = ngb(ig)
+                     extcoice(ig) = extice3(index,ib) + fint * &
+                                   (extice3(index+1,ib) - extice3(index,ib))
+                     ssacoice(ig) = ssaice3(index,ib) + fint * &
+                                   (ssaice3(index+1,ib) - ssaice3(index,ib))
+                     gice(ig) = asyice3(index,ib) + fint * &
+                               (asyice3(index+1,ib) - asyice3(index,ib))
+                     fdelta(ig) = fdlice3(index,ib) + fint * &
+                                 (fdlice3(index+1,ib) - fdlice3(index,ib))
+                     if (fdelta(ig) .lt. 0.0_rb) stop 'FDELTA LESS THAN 0.0'
+                     if (fdelta(ig) .gt. 1.0_rb) stop 'FDELTA GT THAN 1.0'
+                     forwice(ig) = fdelta(ig) + 0.5_rb / ssacoice(ig)
+! See Fu 1996 p. 2067 
+                     if (forwice(ig) .gt. gice(ig)) forwice(ig) = gice(ig)
+! Check to ensure all calculated quantities are within physical limits.  
+                     if (extcoice(ig) .lt. 0.0_rb) stop 'ICE EXTINCTION LESS THAN 0.0'
+                     if (ssacoice(ig) .gt. 1.0_rb) stop 'ICE SSA GRTR THAN 1.0'
+                     if (ssacoice(ig) .lt. 0.0_rb) stop 'ICE SSA LESS THAN 0.0'
+                     if (gice(ig) .gt. 1.0_rb) stop 'ICE ASYM GRTR THAN 1.0'
+                     if (gice(ig) .lt. 0.0_rb) stop 'ICE ASYM LESS THAN 0.0'
+
+                  endif
+
+! Calculation of absorption coefficients due to water clouds.
+                  if (clwpmc(ig,lay) .eq. 0.0_rb) then
+                     extcoliq(ig) = 0.0_rb
+                     ssacoliq(ig) = 0.0_rb
+                     gliq(ig) = 0.0_rb
+                     forwliq(ig) = 0.0_rb
+
+                  elseif (liqflag .eq. 1) then
+                     radliq = relqmc(lay)
+                     if (radliq .lt. 1.5_rb .or. radliq .gt. 60._rb) stop &
+                        'liquid effective radius out of bounds'
+                     index = int(radliq - 1.5_rb)
+                     if (index .eq. 0) index = 1
+                     if (index .eq. 58) index = 57
+                     fint = radliq - 1.5_rb - float(index)
+                     ib = ngb(ig)
+                     extcoliq(ig) = extliq1(index,ib) + fint * &
+                                   (extliq1(index+1,ib) - extliq1(index,ib))
+                     ssacoliq(ig) = ssaliq1(index,ib) + fint * &
+                                   (ssaliq1(index+1,ib) - ssaliq1(index,ib))
+                     if (fint .lt. 0._rb .and. ssacoliq(ig) .gt. 1._rb) &
+                                    ssacoliq(ig) = ssaliq1(index,ib)
+                     gliq(ig) = asyliq1(index,ib) + fint * &
+                               (asyliq1(index+1,ib) - asyliq1(index,ib))
+                     forwliq(ig) = gliq(ig)*gliq(ig)
+! Check to ensure all calculated quantities are within physical limits.
+                     if (extcoliq(ig) .lt. 0.0_rb) stop 'LIQUID EXTINCTION LESS THAN 0.0'
+                     if (ssacoliq(ig) .gt. 1.0_rb) stop 'LIQUID SSA GRTR THAN 1.0'
+                     if (ssacoliq(ig) .lt. 0.0_rb) stop 'LIQUID SSA LESS THAN 0.0'
+                     if (gliq(ig) .gt. 1.0_rb) stop 'LIQUID ASYM GRTR THAN 1.0'
+                     if (gliq(ig) .lt. 0.0_rb) stop 'LIQUID ASYM LESS THAN 0.0'
+                  endif
+   
+                  tauliqorig = clwpmc(ig,lay) * extcoliq(ig)
+                  tauiceorig = ciwpmc(ig,lay) * extcoice(ig)
+                  taormc(ig,lay) = tauliqorig + tauiceorig
+
+                  ssaliq = ssacoliq(ig) * (1._rb - forwliq(ig)) / &
+                          (1._rb - forwliq(ig) * ssacoliq(ig))
+                  tauliq = (1._rb - forwliq(ig) * ssacoliq(ig)) * tauliqorig
+                  ssaice = ssacoice(ig) * (1._rb - forwice(ig)) / &
+                          (1._rb - forwice(ig) * ssacoice(ig))
+                  tauice = (1._rb - forwice(ig) * ssacoice(ig)) * tauiceorig
+
+                  scatliq = ssaliq * tauliq
+                  scatice = ssaice * tauice
+                  taucmc(ig,lay) = tauliq + tauice
+
+! Ensure non-zero taucmc and scatice
+                  if(taucmc(ig,lay).eq.0.) taucmc(ig,lay) = cldmin
+                  if(scatice.eq.0.) scatice = cldmin
+
+                  ssacmc(ig,lay) = (scatliq + scatice) / taucmc(ig,lay)
+
+                  if (iceflag .eq. 3) then
+! In accordance with the 1996 Fu paper, equation A.3, 
+! the moments for ice were calculated depending on whether using spheres
+! or hexagonal ice crystals.
+! Set asymetry parameter to first moment (istr=1)
+                     istr = 1
+                     asmcmc(ig,lay) = (1.0_rb/(scatliq+scatice))* &
+                        (scatliq*(gliq(ig)**istr - forwliq(ig)) / &
+                        (1.0_rb - forwliq(ig)) + scatice * ((gice(ig)-forwice(ig))/ &
+                        (1.0_rb - forwice(ig)))**istr)
+
+                  else 
+! This code is the standard method for delta-m scaling. 
+! Set asymetry parameter to first moment (istr=1)
+                     istr = 1
+                     asmcmc(ig,lay) = (scatliq *  &
+                        (gliq(ig)**istr - forwliq(ig)) / &
+                        (1.0_rb - forwliq(ig)) + scatice * (gice(ig)**istr - forwice(ig)) / &
+                        (1.0_rb - forwice(ig)))/(scatliq + scatice)
+                  endif 
+
+               endif
+
+            endif
+
+! End g-point interval loop
+         enddo
+
+! End layer loop
+      enddo
+
+      end subroutine cldprmc_sw
+
+      end module rrtmg_sw_cldprmc
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+
+      module rrtmg_sw_reftra
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parkind, only : im => kind_im, rb => kind_rb
+      use rrsw_tbl, only : tblint, bpade, od_lo, exp_tbl
+      use rrsw_vsn, only : hvrrft, hnamrft
+
+      implicit none
+
+      contains
+
+! --------------------------------------------------------------------
+      subroutine reftra_sw(nlayers, lrtchk, pgg, prmuz, ptau, pw, &
+                           pref, prefd, ptra, ptrad)
+! --------------------------------------------------------------------
+  
+! Purpose: computes the reflectivity and transmissivity of a clear or 
+!   cloudy layer using a choice of various approximations.
+!
+! Interface:  *rrtmg_sw_reftra* is called by *rrtmg_sw_spcvrt*
+!
+! Description:
+! explicit arguments :
+! --------------------
+! inputs
+! ------ 
+!      lrtchk  = .t. for all layers in clear profile
+!      lrtchk  = .t. for cloudy layers in cloud profile 
+!              = .f. for clear layers in cloud profile
+!      pgg     = assymetry factor
+!      prmuz   = cosine solar zenith angle
+!      ptau    = optical thickness
+!      pw      = single scattering albedo
+!
+! outputs
+! -------
+!      pref    : collimated beam reflectivity
+!      prefd   : diffuse beam reflectivity 
+!      ptra    : collimated beam transmissivity
+!      ptrad   : diffuse beam transmissivity
+!
+!
+! Method:
+! -------
+!      standard delta-eddington, p.i.f.m., or d.o.m. layer calculations.
+!      kmodts  = 1 eddington (joseph et al., 1976)
+!              = 2 pifm (zdunkowski et al., 1980)
+!              = 3 discrete ordinates (liou, 1973)
+!
+!
+! Modifications:
+! --------------
+! Original: J-JMorcrette, ECMWF, Feb 2003
+! Revised for F90 reformatting: MJIacono, AER, Jul 2006
+! Revised to add exponential lookup table: MJIacono, AER, Aug 2007
+! Reformulated some code to avoid potential fpes: MJIacono, AER, Nov 2008
+!
+! ------------------------------------------------------------------
+
+! ------- Declarations ------
+
+! ------- Input -------
+
+      integer(kind=im), intent(in) :: nlayers
+
+      logical, intent(in) :: lrtchk(:)                         ! Logical flag for reflectivity and
+                                                               ! and transmissivity calculation; 
+                                                               !   Dimensions: (nlayers)
+
+      real(kind=rb), intent(in) :: pgg(:)                      ! asymmetry parameter
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: ptau(:)                     ! optical depth
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: pw(:)                       ! single scattering albedo 
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: prmuz                       ! cosine of solar zenith angle
+
+! ------- Output -------
+
+      real(kind=rb), intent(inout) :: pref(:)                  ! direct beam reflectivity
+                                                               !   Dimensions: (nlayers+1)
+      real(kind=rb), intent(inout) :: prefd(:)                 ! diffuse beam reflectivity
+                                                               !   Dimensions: (nlayers+1)
+      real(kind=rb), intent(inout) :: ptra(:)                  ! direct beam transmissivity
+                                                               !   Dimensions: (nlayers+1)
+      real(kind=rb), intent(inout) :: ptrad(:)                 ! diffuse beam transmissivity
+                                                               !   Dimensions: (nlayers+1)
+
+! ------- Local -------
+
+      integer(kind=im) :: jk, jl, kmodts
+      integer(kind=im) :: itind
+
+      real(kind=rb) :: tblind
+      real(kind=rb) :: za, za1, za2
+      real(kind=rb) :: zbeta, zdend, zdenr, zdent
+      real(kind=rb) :: ze1, ze2, zem1, zem2, zemm, zep1, zep2
+      real(kind=rb) :: zg, zg3, zgamma1, zgamma2, zgamma3, zgamma4, zgt
+      real(kind=rb) :: zr1, zr2, zr3, zr4, zr5
+      real(kind=rb) :: zrk, zrk2, zrkg, zrm1, zrp, zrp1, zrpp
+      real(kind=rb) :: zsr3, zt1, zt2, zt3, zt4, zt5, zto1
+      real(kind=rb) :: zw, zwcrit, zwo
+
+      real(kind=rb), parameter :: eps = 1.e-08_rb
+
+!     ------------------------------------------------------------------
+
+! Initialize
+
+      hvrrft = '$Revision: 1.3 $'
+
+      zsr3=sqrt(3._rb)
+      zwcrit=0.9999995_rb
+      kmodts=2
+
+      do jk=1, nlayers
+         if (.not.lrtchk(jk)) then
+            pref(jk) =0._rb
+            ptra(jk) =1._rb
+            prefd(jk)=0._rb
+            ptrad(jk)=1._rb
+         else
+            zto1=ptau(jk)
+            zw  =pw(jk)
+            zg  =pgg(jk)  
+
+! General two-stream expressions
+
+            zg3= 3._rb * zg
+            if (kmodts == 1) then
+               zgamma1= (7._rb - zw * (4._rb + zg3)) * 0.25_rb
+               zgamma2=-(1._rb - zw * (4._rb - zg3)) * 0.25_rb
+               zgamma3= (2._rb - zg3 * prmuz ) * 0.25_rb
+            else if (kmodts == 2) then  
+               zgamma1= (8._rb - zw * (5._rb + zg3)) * 0.25_rb
+               zgamma2=  3._rb *(zw * (1._rb - zg )) * 0.25_rb
+               zgamma3= (2._rb - zg3 * prmuz ) * 0.25_rb
+            else if (kmodts == 3) then  
+               zgamma1= zsr3 * (2._rb - zw * (1._rb + zg)) * 0.5_rb
+               zgamma2= zsr3 * zw * (1._rb - zg ) * 0.5_rb
+               zgamma3= (1._rb - zsr3 * zg * prmuz ) * 0.5_rb
+            end if
+            zgamma4= 1._rb - zgamma3
+    
+! Recompute original s.s.a. to test for conservative solution
+
+            zwo= zw / (1._rb - (1._rb - zw) * (zg / (1._rb - zg))**2)
+
+            if (zwo >= zwcrit) then
+! Conservative scattering
+
+               za  = zgamma1 * prmuz 
+               za1 = za - zgamma3
+               zgt = zgamma1 * zto1
+        
+! Homogeneous reflectance and transmittance,
+! collimated beam
+
+               ze1 = min ( zto1 / prmuz , 500._rb)
+!               ze2 = exp( -ze1 )
+
+! Use exponential lookup table for transmittance, or expansion of 
+! exponential for low tau
+               if (ze1 .le. od_lo) then 
+                  ze2 = 1._rb - ze1 + 0.5_rb * ze1 * ze1
+               else
+                  tblind = ze1 / (bpade + ze1)
+                  itind = tblint * tblind + 0.5_rb
+                  ze2 = exp_tbl(itind)
+               endif
+!
+
+               pref(jk) = (zgt - za1 * (1._rb - ze2)) / (1._rb + zgt)
+               ptra(jk) = 1._rb - pref(jk)
+
+! isotropic incidence
+
+               prefd(jk) = zgt / (1._rb + zgt)
+               ptrad(jk) = 1._rb - prefd(jk)        
+
+! This is applied for consistency between total (delta-scaled) and direct (unscaled) 
+! calculations at very low optical depths (tau < 1.e-4) when the exponential lookup
+! table returns a transmittance of 1.0.
+               if (ze2 .eq. 1.0_rb) then 
+                  pref(jk) = 0.0_rb
+                  ptra(jk) = 1.0_rb
+                  prefd(jk) = 0.0_rb
+                  ptrad(jk) = 1.0_rb
+               endif
+
+            else
+! Non-conservative scattering
+
+               za1 = zgamma1 * zgamma4 + zgamma2 * zgamma3
+               za2 = zgamma1 * zgamma3 + zgamma2 * zgamma4
+               zrk = sqrt ( zgamma1**2 - zgamma2**2)
+               zrp = zrk * prmuz               
+               zrp1 = 1._rb + zrp
+               zrm1 = 1._rb - zrp
+               zrk2 = 2._rb * zrk
+               zrpp = 1._rb - zrp*zrp
+               zrkg = zrk + zgamma1
+               zr1  = zrm1 * (za2 + zrk * zgamma3)
+               zr2  = zrp1 * (za2 - zrk * zgamma3)
+               zr3  = zrk2 * (zgamma3 - za2 * prmuz )
+               zr4  = zrpp * zrkg
+               zr5  = zrpp * (zrk - zgamma1)
+               zt1  = zrp1 * (za1 + zrk * zgamma4)
+               zt2  = zrm1 * (za1 - zrk * zgamma4)
+               zt3  = zrk2 * (zgamma4 + za1 * prmuz )
+               zt4  = zr4
+               zt5  = zr5
+
+! mji - reformulated code to avoid potential floating point exceptions
+!               zbeta = - zr5 / zr4
+               zbeta = (zgamma1 - zrk) / zrkg
+!!
+        
+! Homogeneous reflectance and transmittance
+
+               ze1 = min ( zrk * zto1, 500._rb)
+               ze2 = min ( zto1 / prmuz , 500._rb)
+!
+! Original
+!              zep1 = exp( ze1 )
+!              zem1 = exp(-ze1 )
+!              zep2 = exp( ze2 )
+!              zem2 = exp(-ze2 )
+!
+! Revised original, to reduce exponentials
+!              zep1 = exp( ze1 )
+!              zem1 = 1._rb / zep1
+!              zep2 = exp( ze2 )
+!              zem2 = 1._rb / zep2
+!
+! Use exponential lookup table for transmittance, or expansion of 
+! exponential for low tau
+               if (ze1 .le. od_lo) then 
+                  zem1 = 1._rb - ze1 + 0.5_rb * ze1 * ze1
+                  zep1 = 1._rb / zem1
+               else
+                  tblind = ze1 / (bpade + ze1)
+                  itind = tblint * tblind + 0.5_rb
+                  zem1 = exp_tbl(itind)
+                  zep1 = 1._rb / zem1
+               endif
+
+               if (ze2 .le. od_lo) then 
+                  zem2 = 1._rb - ze2 + 0.5_rb * ze2 * ze2
+                  zep2 = 1._rb / zem2
+               else
+                  tblind = ze2 / (bpade + ze2)
+                  itind = tblint * tblind + 0.5_rb
+                  zem2 = exp_tbl(itind)
+                  zep2 = 1._rb / zem2
+               endif
+
+! collimated beam
+
+! mji - reformulated code to avoid potential floating point exceptions
+!               zdenr = zr4*zep1 + zr5*zem1
+!               pref(jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
+!               zdent = zt4*zep1 + zt5*zem1
+!               ptra(jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
+
+               zdenr = zr4*zep1 + zr5*zem1
+               zdent = zt4*zep1 + zt5*zem1
+               if (zdenr .ge. -eps .and. zdenr .le. eps) then
+                  pref(jk) = eps
+                  ptra(jk) = zem2
+               else
+                  pref(jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr
+                  ptra(jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent
+               endif
+!!
+
+! diffuse beam
+
+               zemm = zem1*zem1
+               zdend = 1._rb / ( (1._rb - zbeta*zemm ) * zrkg)
+               prefd(jk) =  zgamma2 * (1._rb - zemm) * zdend
+               ptrad(jk) =  zrk2*zem1*zdend
+
+            endif
+
+         endif         
+
+      enddo    
+
+      end subroutine reftra_sw
+
+      end module rrtmg_sw_reftra
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+
+      module rrtmg_sw_setcoef
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parkind, only : im => kind_im, rb => kind_rb
+      use parrrsw, only : mxmol
+      use rrsw_ref, only : pref, preflog, tref
+      use rrsw_vsn, only : hvrset, hnamset
+
+      implicit none
+
+      contains
+
+!----------------------------------------------------------------------------
+      subroutine setcoef_sw(nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl, &
+                            laytrop, layswtch, laylow, jp, jt, jt1, &
+                            co2mult, colch4, colco2, colh2o, colmol, coln2o, &
+                            colo2, colo3, fac00, fac01, fac10, fac11, &
+                            selffac, selffrac, indself, forfac, forfrac, indfor)
+!----------------------------------------------------------------------------
+!
+! Purpose:  For a given atmosphere, calculate the indices and
+! fractions related to the pressure and temperature interpolations.
+
+! Modifications:
+! Original: J. Delamere, AER, Inc. (version 2.5, 02/04/01)
+! Revised: Rewritten and adapted to ECMWF F90, JJMorcrette 030224
+! Revised: For uniform rrtmg formatting, MJIacono, Jul 2006
+
+! ------ Declarations -------
+
+! ----- Input -----
+      integer(kind=im), intent(in) :: nlayers         ! total number of layers
+
+      real(kind=rb), intent(in) :: pavel(:)           ! layer pressures (mb) 
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: tavel(:)           ! layer temperatures (K)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: pz(0:)             ! level (interface) pressures (hPa, mb)
+                                                      !    Dimensions: (0:nlayers)
+      real(kind=rb), intent(in) :: tz(0:)             ! level (interface) temperatures (K)
+                                                      !    Dimensions: (0:nlayers)
+      real(kind=rb), intent(in) :: tbound             ! surface temperature (K)
+      real(kind=rb), intent(in) :: coldry(:)          ! dry air column density (mol/cm2)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: wkl(:,:)           ! molecular amounts (mol/cm-2)
+                                                      !    Dimensions: (mxmol,nlayers)
+
+! ----- Output -----
+      integer(kind=im), intent(out) :: laytrop        ! tropopause layer index
+      integer(kind=im), intent(out) :: layswtch       ! 
+      integer(kind=im), intent(out) :: laylow         ! 
+
+      integer(kind=im), intent(out) :: jp(:)          ! 
+                                                      !    Dimensions: (nlayers)
+      integer(kind=im), intent(out) :: jt(:)          !
+                                                      !    Dimensions: (nlayers)
+      integer(kind=im), intent(out) :: jt1(:)         !
+                                                      !    Dimensions: (nlayers)
+
+      real(kind=rb), intent(out) :: colh2o(:)         ! column amount (h2o)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: colco2(:)         ! column amount (co2)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: colo3(:)          ! column amount (o3)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: coln2o(:)         ! column amount (n2o)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: colch4(:)         ! column amount (ch4)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: colo2(:)          ! column amount (o2)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: colmol(:)         ! 
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: co2mult(:)        !
+                                                      !    Dimensions: (nlayers)
+
+      integer(kind=im), intent(out) :: indself(:)
+                                                      !    Dimensions: (nlayers)
+      integer(kind=im), intent(out) :: indfor(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: selffac(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: selffrac(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: forfac(:)
+                                                      !    Dimensions: (nlayers)
+      real(kind=rb), intent(out) :: forfrac(:)
+                                                      !    Dimensions: (nlayers)
+
+      real(kind=rb), intent(out) :: &                 !
+                         fac00(:), fac01(:), &        !    Dimensions: (nlayers)
+                         fac10(:), fac11(:) 
+
+! ----- Local -----
+
+      integer(kind=im) :: indbound
+      integer(kind=im) :: indlev0
+      integer(kind=im) :: lay
+      integer(kind=im) :: jp1
+
+      real(kind=rb) :: stpfac
+      real(kind=rb) :: tbndfrac
+      real(kind=rb) :: t0frac
+      real(kind=rb) :: plog
+      real(kind=rb) :: fp
+      real(kind=rb) :: ft
+      real(kind=rb) :: ft1
+      real(kind=rb) :: water
+      real(kind=rb) :: scalefac
+      real(kind=rb) :: factor
+      real(kind=rb) :: co2reg
+      real(kind=rb) :: compfp
+
+
+! Initializations
+      stpfac = 296._rb/1013._rb
+
+      indbound = tbound - 159._rb
+      tbndfrac = tbound - int(tbound)
+      indlev0  = tz(0) - 159._rb
+      t0frac   = tz(0) - int(tz(0))
+
+      laytrop  = 0
+      layswtch = 0
+      laylow   = 0
+
+! Begin layer loop
+      do 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._rb - 5*(plog+0.04_rb))
+         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._rb * (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._rb + (tavel(lay)-tref(jp(lay)))/15._rb)
+         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._rb) - float(jt(lay)-3)
+         jt1(lay) = int(3._rb + (tavel(lay)-tref(jp1))/15._rb)
+         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._rb) - 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_rb) go to 5300
+         laytrop =  laytrop + 1
+         if (plog .ge. 6.62_rb) laylow = laylow + 1
+
+! Set up factors needed to separately include the water vapor
+! foreign-continuum in the calculation of absorption coefficient.
+
+         forfac(lay) = scalefac / (1.+water)
+         factor = (332.0_rb-tavel(lay))/36.0_rb
+         indfor(lay) = min(2, max(1, int(factor)))
+         forfrac(lay) = factor - float(indfor(lay))
+
+! 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_rb)/7.2_rb
+         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_rb * wkl(1,lay)
+         colco2(lay) = 1.e-20_rb * wkl(2,lay)
+         colo3(lay) = 1.e-20_rb * wkl(3,lay)
+!           colo3(lay) = 0._rb
+!           colo3(lay) = colo3(lay)/1.16_rb
+         coln2o(lay) = 1.e-20_rb * wkl(4,lay)
+         colch4(lay) = 1.e-20_rb * wkl(6,lay)
+         colo2(lay) = 1.e-20_rb * wkl(7,lay)
+         colmol(lay) = 1.e-20_rb * coldry(lay) + colh2o(lay)
+!           colco2(lay) = 0._rb
+!           colo3(lay) = 0._rb
+!           coln2o(lay) = 0._rb
+!           colch4(lay) = 0._rb
+!           colo2(lay) = 0._rb
+!           colmol(lay) = 0._rb
+         if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
+         if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
+         if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
+         if (colo2(lay) .eq. 0._rb) colo2(lay) = 1.e-32_rb * coldry(lay)
+! Using E = 1334.2 cm-1.
+         co2reg = 3.55e-24_rb * coldry(lay)
+         co2mult(lay)= (colco2(lay) - co2reg) * &
+               272.63_rb*exp(-1919.4_rb/tavel(lay))/(8.7604e-4_rb*tavel(lay))
+         goto 5400
+
+! Above laytrop.
+ 5300    continue
+
+! Set up factors needed to separately include the water vapor
+! foreign-continuum in the calculation of absorption coefficient.
+
+         forfac(lay) = scalefac / (1.+water)
+         factor = (tavel(lay)-188.0_rb)/36.0_rb
+         indfor(lay) = 3
+         forfrac(lay) = factor - 1.0_rb
+
+! Calculate needed column amounts.
+
+         colh2o(lay) = 1.e-20_rb * wkl(1,lay)
+         colco2(lay) = 1.e-20_rb * wkl(2,lay)
+         colo3(lay)  = 1.e-20_rb * wkl(3,lay)
+         coln2o(lay) = 1.e-20_rb * wkl(4,lay)
+         colch4(lay) = 1.e-20_rb * wkl(6,lay)
+         colo2(lay)  = 1.e-20_rb * wkl(7,lay)
+         colmol(lay) = 1.e-20_rb * coldry(lay) + colh2o(lay)
+         if (colco2(lay) .eq. 0._rb) colco2(lay) = 1.e-32_rb * coldry(lay)
+         if (coln2o(lay) .eq. 0._rb) coln2o(lay) = 1.e-32_rb * coldry(lay)
+         if (colch4(lay) .eq. 0._rb) colch4(lay) = 1.e-32_rb * coldry(lay)
+         if (colo2(lay)  .eq. 0._rb) colo2(lay)  = 1.e-32_rb * coldry(lay)
+         co2reg = 3.55e-24_rb * coldry(lay)
+         co2mult(lay)= (colco2(lay) - co2reg) * &
+               272.63_rb*exp(-1919.4_rb/tavel(lay))/(8.7604e-4_rb*tavel(lay))
+
+         selffac(lay) = 0._rb
+         selffrac(lay)= 0._rb
+         indself(lay) = 0
+
+ 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._rb - fp
+         fac10(lay) = compfp * ft
+         fac00(lay) = compfp * (1._rb - ft)
+         fac11(lay) = fp * ft1
+         fac01(lay) = fp * (1._rb - ft1)
+
+! End layer loop
+      enddo
+
+      end subroutine setcoef_sw
+
+!***************************************************************************
+      subroutine swatmref
+!***************************************************************************
+
+      save
+ 
+! 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.
+
+      pref(:) = (/ &
+          1.05363e+03_rb,8.62642e+02_rb,7.06272e+02_rb,5.78246e+02_rb,4.73428e+02_rb, &
+          3.87610e+02_rb,3.17348e+02_rb,2.59823e+02_rb,2.12725e+02_rb,1.74164e+02_rb, &
+          1.42594e+02_rb,1.16746e+02_rb,9.55835e+01_rb,7.82571e+01_rb,6.40715e+01_rb, &
+          5.24573e+01_rb,4.29484e+01_rb,3.51632e+01_rb,2.87892e+01_rb,2.35706e+01_rb, &
+          1.92980e+01_rb,1.57998e+01_rb,1.29358e+01_rb,1.05910e+01_rb,8.67114e+00_rb, &
+          7.09933e+00_rb,5.81244e+00_rb,4.75882e+00_rb,3.89619e+00_rb,3.18993e+00_rb, &
+          2.61170e+00_rb,2.13828e+00_rb,1.75067e+00_rb,1.43333e+00_rb,1.17351e+00_rb, &
+          9.60789e-01_rb,7.86628e-01_rb,6.44036e-01_rb,5.27292e-01_rb,4.31710e-01_rb, &
+          3.53455e-01_rb,2.89384e-01_rb,2.36928e-01_rb,1.93980e-01_rb,1.58817e-01_rb, &
+          1.30029e-01_rb,1.06458e-01_rb,8.71608e-02_rb,7.13612e-02_rb,5.84256e-02_rb, &
+          4.78349e-02_rb,3.91639e-02_rb,3.20647e-02_rb,2.62523e-02_rb,2.14936e-02_rb, &
+          1.75975e-02_rb,1.44076e-02_rb,1.17959e-02_rb,9.65769e-03_rb /)
+
+      preflog(:) = (/ &
+           6.9600e+00_rb, 6.7600e+00_rb, 6.5600e+00_rb, 6.3600e+00_rb, 6.1600e+00_rb, &
+           5.9600e+00_rb, 5.7600e+00_rb, 5.5600e+00_rb, 5.3600e+00_rb, 5.1600e+00_rb, &
+           4.9600e+00_rb, 4.7600e+00_rb, 4.5600e+00_rb, 4.3600e+00_rb, 4.1600e+00_rb, &
+           3.9600e+00_rb, 3.7600e+00_rb, 3.5600e+00_rb, 3.3600e+00_rb, 3.1600e+00_rb, &
+           2.9600e+00_rb, 2.7600e+00_rb, 2.5600e+00_rb, 2.3600e+00_rb, 2.1600e+00_rb, &
+           1.9600e+00_rb, 1.7600e+00_rb, 1.5600e+00_rb, 1.3600e+00_rb, 1.1600e+00_rb, &
+           9.6000e-01_rb, 7.6000e-01_rb, 5.6000e-01_rb, 3.6000e-01_rb, 1.6000e-01_rb, &
+          -4.0000e-02_rb,-2.4000e-01_rb,-4.4000e-01_rb,-6.4000e-01_rb,-8.4000e-01_rb, &
+          -1.0400e+00_rb,-1.2400e+00_rb,-1.4400e+00_rb,-1.6400e+00_rb,-1.8400e+00_rb, &
+          -2.0400e+00_rb,-2.2400e+00_rb,-2.4400e+00_rb,-2.6400e+00_rb,-2.8400e+00_rb, &
+          -3.0400e+00_rb,-3.2400e+00_rb,-3.4400e+00_rb,-3.6400e+00_rb,-3.8400e+00_rb, &
+          -4.0400e+00_rb,-4.2400e+00_rb,-4.4400e+00_rb,-4.6400e+00_rb /)
+
+! These are the temperatures associated with the respective 
+! pressures for the MLS standard atmosphere. 
+
+      tref(:) = (/ &
+           2.9420e+02_rb, 2.8799e+02_rb, 2.7894e+02_rb, 2.6925e+02_rb, 2.5983e+02_rb, &
+           2.5017e+02_rb, 2.4077e+02_rb, 2.3179e+02_rb, 2.2306e+02_rb, 2.1578e+02_rb, &
+           2.1570e+02_rb, 2.1570e+02_rb, 2.1570e+02_rb, 2.1706e+02_rb, 2.1858e+02_rb, &
+           2.2018e+02_rb, 2.2174e+02_rb, 2.2328e+02_rb, 2.2479e+02_rb, 2.2655e+02_rb, &
+           2.2834e+02_rb, 2.3113e+02_rb, 2.3401e+02_rb, 2.3703e+02_rb, 2.4022e+02_rb, &
+           2.4371e+02_rb, 2.4726e+02_rb, 2.5085e+02_rb, 2.5457e+02_rb, 2.5832e+02_rb, &
+           2.6216e+02_rb, 2.6606e+02_rb, 2.6999e+02_rb, 2.7340e+02_rb, 2.7536e+02_rb, &
+           2.7568e+02_rb, 2.7372e+02_rb, 2.7163e+02_rb, 2.6955e+02_rb, 2.6593e+02_rb, &
+           2.6211e+02_rb, 2.5828e+02_rb, 2.5360e+02_rb, 2.4854e+02_rb, 2.4348e+02_rb, & 
+           2.3809e+02_rb, 2.3206e+02_rb, 2.2603e+02_rb, 2.2000e+02_rb, 2.1435e+02_rb, &
+           2.0887e+02_rb, 2.0340e+02_rb, 1.9792e+02_rb, 1.9290e+02_rb, 1.8809e+02_rb, &
+           1.8329e+02_rb, 1.7849e+02_rb, 1.7394e+02_rb, 1.7212e+02_rb /)
+
+      end subroutine swatmref
+
+      end module rrtmg_sw_setcoef
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+
+      module rrtmg_sw_taumol
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parkind, only : im => kind_im, rb => kind_rb
+!      use parrrsw, only : mg, jpband, nbndsw, ngptsw
+      use rrsw_con, only: oneminus
+      use rrsw_wvn, only: nspa, nspb
+      use rrsw_vsn, only: hvrtau, hnamtau
+
+      implicit none
+
+      contains
+
+!----------------------------------------------------------------------------
+      subroutine taumol_sw(nlayers, &
+                           colh2o, colco2, colch4, colo2, colo3, colmol, &
+                           laytrop, jp, jt, jt1, &
+                           fac00, fac01, fac10, fac11, &
+                           selffac, selffrac, indself, forfac, forfrac, indfor, &
+                           sfluxzen, taug, taur)
+!----------------------------------------------------------------------------
+
+! ******************************************************************************
+! *                                                                            *
+! *                 Optical depths developed for the                           *
+! *                                                                            *
+! *               RAPID RADIATIVE TRANSFER MODEL (RRTM)                        *
+! *                                                                            *
+! *                                                                            *
+! *           ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC.                     *
+! *                       131 HARTWELL AVENUE                                  *
+! *                       LEXINGTON, MA 02421                                  *
+! *                                                                            *
+! *                                                                            *
+! *                          ELI J. MLAWER                                     *
+! *                        JENNIFER DELAMERE                                   *
+! *                        STEVEN J. TAUBMAN                                   *
+! *                        SHEPARD A. CLOUGH                                   *
+! *                                                                            *
+! *                                                                            *
+! *                                                                            *
+! *                                                                            *
+! *                      email:  mlawer@aer.com                                *
+! *                      email:  jdelamer@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.                       *
+! *                                                                            *
+! ******************************************************************************
+! *    TAUMOL                                                                  *
+! *                                                                            *
+! *    This file contains the subroutines TAUGBn (where n goes from            *
+! *    1 to 28).  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                                                                      *
+! *                                                                            *
+! *    PARAMETER (MG=16, MXLAY=203, NBANDS=14)                                 *
+! *                                                                            *
+! *    COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS)                  *
+! *    COMMON /PRECISE/  ONEMINUS                                              *
+! *    COMMON /PROFILE/  NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY),                    *
+! *   &                  PZ(0:MXLAY),TZ(0:MXLAY),TBOUND                        *
+! *    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)                                         *
+! *                                                                            *
+! *****************************************************************************
+!
+! Modifications
+!
+! Revised: Adapted to F90 coding, J.-J.Morcrette, ECMWF, Feb 2003
+! Revised: Modified for g-point reduction, MJIacono, AER, Dec 2003
+! Revised: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006
+!
+! ------- Declarations -------
+
+! ----- Input -----
+      integer(kind=im), intent(in) :: nlayers            ! total number of layers
+
+      integer(kind=im), intent(in) :: laytrop            ! tropopause layer index
+      integer(kind=im), intent(in) :: jp(:)              ! 
+                                                         !   Dimensions: (nlayers)
+      integer(kind=im), intent(in) :: jt(:)              !
+                                                         !   Dimensions: (nlayers)
+      integer(kind=im), intent(in) :: jt1(:)             !
+                                                         !   Dimensions: (nlayers)
+
+      real(kind=rb), intent(in) :: colh2o(:)             ! column amount (h2o)
+                                                         !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colco2(:)             ! column amount (co2)
+                                                         !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colo3(:)              ! column amount (o3)
+                                                         !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colch4(:)             ! column amount (ch4)
+                                                         !   Dimensions: (nlayers)
+                                                         !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colo2(:)              ! column amount (o2)
+                                                         !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colmol(:)             ! 
+                                                         !   Dimensions: (nlayers)
+
+      integer(kind=im), intent(in) :: indself(:)    
+                                                         !   Dimensions: (nlayers)
+      integer(kind=im), intent(in) :: indfor(:)
+                                                         !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: selffac(:)
+                                                         !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: selffrac(:)
+                                                         !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: forfac(:)
+                                                         !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: forfrac(:)
+                                                         !   Dimensions: (nlayers)
+
+      real(kind=rb), intent(in) :: &                     !
+                       fac00(:), fac01(:), &             !   Dimensions: (nlayers)
+                       fac10(:), fac11(:) 
+
+! ----- Output -----
+      real(kind=rb), intent(out) :: sfluxzen(:)          ! solar source function
+                                                         !   Dimensions: (ngptsw)
+      real(kind=rb), intent(out) :: taug(:,:)            ! gaseous optical depth 
+                                                         !   Dimensions: (nlayers,ngptsw)
+      real(kind=rb), intent(out) :: taur(:,:)            ! Rayleigh 
+                                                         !   Dimensions: (nlayers,ngptsw)
+!      real(kind=rb), intent(out) :: ssa(:,:)            ! single scattering albedo (inactive)
+                                                         !   Dimensions: (nlayers,ngptsw)
+
+      hvrtau = '$Revision: 1.3 $'
+
+! Calculate gaseous optical depth and planck fractions for each spectral band.
+
+      call taumol16
+      call taumol17
+      call taumol18
+      call taumol19
+      call taumol20
+      call taumol21
+      call taumol22
+      call taumol23
+      call taumol24
+      call taumol25
+      call taumol26
+      call taumol27
+      call taumol28
+      call taumol29
+
+!-------------
+      contains
+!-------------
+
+!----------------------------------------------------------------------------
+      subroutine taumol16
+!----------------------------------------------------------------------------
+!
+!     band 16:  2600-3250 cm-1 (low - h2o,ch4; high - ch4)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng16
+      use rrsw_kg16, only : absa, ka, absb, kb, forref, selfref, &
+                            sfluxref, rayl, layreffr, strrat1
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray
+
+! 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.  
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         speccomb = colh2o(lay) + strrat1*colch4(lay)
+         specparm = colh2o(lay)/speccomb 
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult, 1._rb )
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs) * fac01(lay)
+         fac011 = (1._rb - 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)
+         indf = indfor(lay)
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng16
+            taug(lay,ig) = speccomb * &
+                (fac000 * absa(ind0   ,ig) + &
+                 fac100 * absa(ind0 +1,ig) + &
+                 fac010 * absa(ind0 +9,ig) + &
+                 fac110 * absa(ind0+10,ig) + &
+                 fac001 * absa(ind1   ,ig) + &
+                 fac101 * absa(ind1 +1,ig) + &
+                 fac011 * absa(ind1 +9,ig) + &
+                 fac111 * absa(ind1+10,ig)) + &
+                 colh2o(lay) * &
+                 (selffac(lay) * (selfref(inds,ig) + &
+                 selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig))) + &
+                 forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig)))) 
+!            ssa(lay,ig) = tauray/taug(lay,ig)
+            taur(lay,ig) = tauray
+         enddo
+      enddo
+
+      laysolfr = nlayers
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
+            laysolfr = lay
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(16) + 1
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(16) + 1
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng16
+            taug(lay,ig) = colch4(lay) * &
+                (fac00(lay) * absb(ind0  ,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1  ,ig) + &
+                 fac11(lay) * absb(ind1+1,ig)) 
+!            ssa(lay,ig) = tauray/taug(lay,ig)
+            if (lay .eq. laysolfr) sfluxzen(ig) = sfluxref(ig) 
+            taur(lay,ig) = tauray  
+         enddo
+      enddo
+
+      end subroutine taumol16
+
+!----------------------------------------------------------------------------
+      subroutine taumol17
+!----------------------------------------------------------------------------
+!
+!     band 17:  3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng17, ngs16
+      use rrsw_kg17, only : absa, ka, absb, kb, forref, selfref, &
+                            sfluxref, rayl, layreffr, strrat
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray
+
+! 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.  
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         speccomb = colh2o(lay) + strrat*colco2(lay)
+         specparm = colh2o(lay)/speccomb 
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult, 1._rb )
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs) * fac01(lay)
+         fac011 = (1._rb - fs) * fac11(lay)
+         fac101 = fs * fac01(lay)
+         fac111 = fs * fac11(lay)
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(17) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(17) + js
+         inds = indself(lay)
+         indf = indfor(lay)
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng17
+            taug(lay,ngs16+ig) = speccomb * &
+                (fac000 * absa(ind0,ig) + &
+                 fac100 * absa(ind0+1,ig) + &
+                 fac010 * absa(ind0+9,ig) + &
+                 fac110 * absa(ind0+10,ig) + &
+                 fac001 * absa(ind1,ig) + &
+                 fac101 * absa(ind1+1,ig) + &
+                 fac011 * absa(ind1+9,ig) + &
+                 fac111 * absa(ind1+10,ig)) + &
+                 colh2o(lay) * &
+                 (selffac(lay) * (selfref(inds,ig) + &
+                 selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig))) + &
+                 forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig)))) 
+!             ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig)
+            taur(lay,ngs16+ig) = tauray
+         enddo
+      enddo
+
+      laysolfr = nlayers
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
+            laysolfr = lay
+         speccomb = colh2o(lay) + strrat*colco2(lay)
+         specparm = colh2o(lay)/speccomb 
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 4._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult, 1._rb )
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs) * fac01(lay)
+         fac011 = (1._rb - fs) * fac11(lay)
+         fac101 = fs * fac01(lay)
+         fac111 = fs * fac11(lay)
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(17) + js
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(17) + js
+         indf = indfor(lay)
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng17
+            taug(lay,ngs16+ig) = speccomb * &
+                (fac000 * absb(ind0,ig) + &
+                 fac100 * absb(ind0+1,ig) + &
+                 fac010 * absb(ind0+5,ig) + &
+                 fac110 * absb(ind0+6,ig) + &
+                 fac001 * absb(ind1,ig) + &
+                 fac101 * absb(ind1+1,ig) + &
+                 fac011 * absb(ind1+5,ig) + &
+                 fac111 * absb(ind1+6,ig)) + &
+                 colh2o(lay) * &
+                 forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))) 
+!            ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig)
+            if (lay .eq. laysolfr) sfluxzen(ngs16+ig) = sfluxref(ig,js) &
+               + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
+            taur(lay,ngs16+ig) = tauray
+         enddo
+      enddo
+
+      end subroutine taumol17
+
+!----------------------------------------------------------------------------
+      subroutine taumol18
+!----------------------------------------------------------------------------
+!
+!     band 18:  4000-4650 cm-1 (low - h2o,ch4; high - ch4)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng18, ngs17
+      use rrsw_kg18, only : absa, ka, absb, kb, forref, selfref, &
+                            sfluxref, rayl, layreffr, strrat
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray
+
+! 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.  
+
+      laysolfr = laytrop
+      
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
+            laysolfr = min(lay+1,laytrop)
+         speccomb = colh2o(lay) + strrat*colch4(lay)
+         specparm = colh2o(lay)/speccomb 
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult, 1._rb )
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs) * fac01(lay)
+         fac011 = (1._rb - fs) * fac11(lay)
+         fac101 = fs * fac01(lay)
+         fac111 = fs * fac11(lay)
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(18) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(18) + js
+         inds = indself(lay)
+         indf = indfor(lay)
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng18
+            taug(lay,ngs17+ig) = speccomb * &
+                (fac000 * absa(ind0,ig) + &
+                 fac100 * absa(ind0+1,ig) + &
+                 fac010 * absa(ind0+9,ig) + &
+                 fac110 * absa(ind0+10,ig) + &
+                 fac001 * absa(ind1,ig) + &
+                 fac101 * absa(ind1+1,ig) + &
+                 fac011 * absa(ind1+9,ig) + &
+                 fac111 * absa(ind1+10,ig)) + &
+                 colh2o(lay) * &
+                 (selffac(lay) * (selfref(inds,ig) + &
+                 selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig))) + &
+                 forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig)))) 
+!            ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
+            if (lay .eq. laysolfr) sfluxzen(ngs17+ig) = sfluxref(ig,js) &
+               + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
+            taur(lay,ngs17+ig) = tauray
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(18) + 1
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(18) + 1
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng18
+            taug(lay,ngs17+ig) = colch4(lay) * &
+                (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + &	  
+                 fac11(lay) * absb(ind1+1,ig)) 
+!           ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig)
+           taur(lay,ngs17+ig) = tauray
+         enddo
+       enddo
+
+       end subroutine taumol18
+
+!----------------------------------------------------------------------------
+      subroutine taumol19
+!----------------------------------------------------------------------------
+!
+!     band 19:  4650-5150 cm-1 (low - h2o,co2; high - co2)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng19, ngs18
+      use rrsw_kg19, only : absa, ka, absb, kb, forref, selfref, &
+                            sfluxref, rayl, layreffr, strrat
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray
+
+! 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.  
+
+      laysolfr = laytrop
+
+! Lower atmosphere loop      
+      do lay = 1, laytrop
+         if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
+            laysolfr = min(lay+1,laytrop)
+         speccomb = colh2o(lay) + strrat*colco2(lay)
+         specparm = colh2o(lay)/speccomb 
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult, 1._rb )
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs) * fac01(lay)
+         fac011 = (1._rb - fs) * fac11(lay)
+         fac101 = fs * fac01(lay)
+         fac111 = fs * fac11(lay)
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(19) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(19) + js
+         inds = indself(lay)
+         indf = indfor(lay)
+         tauray = colmol(lay) * rayl
+
+         do ig = 1 , ng19
+            taug(lay,ngs18+ig) = speccomb * &
+                (fac000 * absa(ind0,ig) + &
+                 fac100 * absa(ind0+1,ig) + &
+                 fac010 * absa(ind0+9,ig) + &
+                 fac110 * absa(ind0+10,ig) + &
+                 fac001 * absa(ind1,ig) + &
+                 fac101 * absa(ind1+1,ig) + &
+                 fac011 * absa(ind1+9,ig) + &
+                 fac111 * absa(ind1+10,ig)) + &
+                 colh2o(lay) * &
+                 (selffac(lay) * (selfref(inds,ig) + &
+                 selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig))) + & 
+                 forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig)))) 
+!            ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig)
+            if (lay .eq. laysolfr) sfluxzen(ngs18+ig) = sfluxref(ig,js) &
+               + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
+            taur(lay,ngs18+ig) = tauray   
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(19) + 1
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(19) + 1
+         tauray = colmol(lay) * rayl
+
+         do ig = 1 , ng19
+            taug(lay,ngs18+ig) = colco2(lay) * &
+                (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + &
+                 fac11(lay) * absb(ind1+1,ig)) 
+!            ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig) 
+            taur(lay,ngs18+ig) = tauray   
+         enddo
+      enddo
+
+      end subroutine taumol19
+
+!----------------------------------------------------------------------------
+      subroutine taumol20
+!----------------------------------------------------------------------------
+!
+!     band 20:  5150-6150 cm-1 (low - h2o; high - h2o)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng20, ngs19
+      use rrsw_kg20, only : absa, ka, absb, kb, forref, selfref, &
+                            sfluxref, absch4, rayl, layreffr
+
+      implicit none
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray
+
+! 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.  
+
+      laysolfr = laytrop
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
+            laysolfr = min(lay+1,laytrop)
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(20) + 1
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(20) + 1
+         inds = indself(lay)
+         indf = indfor(lay)
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng20
+            taug(lay,ngs19+ig) = colh2o(lay) * &
+               ((fac00(lay) * absa(ind0,ig) + &
+                 fac10(lay) * absa(ind0+1,ig) + &
+                 fac01(lay) * absa(ind1,ig) + &
+                 fac11(lay) * absa(ind1+1,ig)) + &
+                 selffac(lay) * (selfref(inds,ig) + & 
+                 selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig))) + &
+                 forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig)))) &
+                 + colch4(lay) * absch4(ig)
+!            ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
+            taur(lay,ngs19+ig) = tauray 
+            if (lay .eq. laysolfr) sfluxzen(ngs19+ig) = sfluxref(ig) 
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(20) + 1
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(20) + 1
+         indf = indfor(lay)
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng20
+            taug(lay,ngs19+ig) = colh2o(lay) * &
+                (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + &
+                 fac11(lay) * absb(ind1+1,ig) + &
+                 forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig)))) + &
+                 colch4(lay) * absch4(ig)
+!            ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig)
+            taur(lay,ngs19+ig) = tauray 
+         enddo
+      enddo
+
+      end subroutine taumol20
+
+!----------------------------------------------------------------------------
+      subroutine taumol21
+!----------------------------------------------------------------------------
+!
+!     band 21:  6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng21, ngs20
+      use rrsw_kg21, only : absa, ka, absb, kb, forref, selfref, &
+                            sfluxref, rayl, layreffr, strrat
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray
+
+! 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.  
+
+      laysolfr = laytrop
+      
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
+            laysolfr = min(lay+1,laytrop)
+         speccomb = colh2o(lay) + strrat*colco2(lay)
+         specparm = colh2o(lay)/speccomb 
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult, 1._rb )
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs) * fac01(lay)
+         fac011 = (1._rb - fs) * fac11(lay)
+         fac101 = fs * fac01(lay)
+         fac111 = fs * fac11(lay)
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(21) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(21) + js
+         inds = indself(lay)
+         indf = indfor(lay)
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng21
+            taug(lay,ngs20+ig) = speccomb * &
+                (fac000 * absa(ind0,ig) + &
+                 fac100 * absa(ind0+1,ig) + &
+                 fac010 * absa(ind0+9,ig) + &
+                 fac110 * absa(ind0+10,ig) + &
+                 fac001 * absa(ind1,ig) + &
+                 fac101 * absa(ind1+1,ig) + &
+                 fac011 * absa(ind1+9,ig) + &
+                 fac111 * absa(ind1+10,ig)) + &
+                 colh2o(lay) * &
+                 (selffac(lay) * (selfref(inds,ig) + &
+                 selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig))) + &
+                 forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))))
+!            ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
+            if (lay .eq. laysolfr) sfluxzen(ngs20+ig) = sfluxref(ig,js) &
+               + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
+            taur(lay,ngs20+ig) = tauray
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         speccomb = colh2o(lay) + strrat*colco2(lay)
+         specparm = colh2o(lay)/speccomb 
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 4._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult, 1._rb )
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs) * fac01(lay)
+         fac011 = (1._rb - fs) * fac11(lay)
+         fac101 = fs * fac01(lay)
+         fac111 = fs * fac11(lay)
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(21) + js
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(21) + js
+         indf = indfor(lay)
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng21
+            taug(lay,ngs20+ig) = speccomb * &
+                (fac000 * absb(ind0,ig) + &
+                 fac100 * absb(ind0+1,ig) + &
+                 fac010 * absb(ind0+5,ig) + &
+                 fac110 * absb(ind0+6,ig) + &
+                 fac001 * absb(ind1,ig) + &
+                 fac101 * absb(ind1+1,ig) + &
+                 fac011 * absb(ind1+5,ig) + &
+                 fac111 * absb(ind1+6,ig)) + &
+                 colh2o(lay) * &
+                 forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig)))
+!            ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig)
+            taur(lay,ngs20+ig) = tauray
+         enddo
+      enddo
+
+      end subroutine taumol21
+
+!----------------------------------------------------------------------------
+      subroutine taumol22
+!----------------------------------------------------------------------------
+!
+!     band 22:  7700-8050 cm-1 (low - h2o,o2; high - o2)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng22, ngs21
+      use rrsw_kg22, only : absa, ka, absb, kb, forref, selfref, &
+                            sfluxref, rayl, layreffr, strrat
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray, o2adj, o2cont
+
+! The following factor is the ratio of total O2 band intensity (lines 
+! and Mate continuum) to O2 band intensity (line only).  It is needed
+! to adjust the optical depths since the k's include only lines.
+      o2adj = 1.6_rb
+      
+! 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.  
+
+      laysolfr = laytrop
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
+            laysolfr = min(lay+1,laytrop)
+         o2cont = 4.35e-4_rb*colo2(lay)/(350.0_rb*2.0_rb)
+         speccomb = colh2o(lay) + o2adj*strrat*colo2(lay)
+         specparm = colh2o(lay)/speccomb 
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+!         odadj = specparm + o2adj * (1._rb - specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult, 1._rb )
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs) * fac01(lay)
+         fac011 = (1._rb - fs) * fac11(lay)
+         fac101 = fs * fac01(lay)
+         fac111 = fs * fac11(lay)
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(22) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(22) + js
+         inds = indself(lay)
+         indf = indfor(lay)
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng22
+            taug(lay,ngs21+ig) = speccomb * &
+                (fac000 * absa(ind0,ig) + &
+                 fac100 * absa(ind0+1,ig) + &
+                 fac010 * absa(ind0+9,ig) + &
+                 fac110 * absa(ind0+10,ig) + &
+                 fac001 * absa(ind1,ig) + &
+                 fac101 * absa(ind1+1,ig) + &
+                 fac011 * absa(ind1+9,ig) + &
+                 fac111 * absa(ind1+10,ig)) + &
+                 colh2o(lay) * &
+                 (selffac(lay) * (selfref(inds,ig) + &
+                 selffrac(lay) * &
+                  (selfref(inds+1,ig) - selfref(inds,ig))) + &
+                 forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig)))) &
+                 + o2cont
+!            ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
+            if (lay .eq. laysolfr) sfluxzen(ngs21+ig) = sfluxref(ig,js) &
+                + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
+            taur(lay,ngs21+ig) = tauray
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         o2cont = 4.35e-4_rb*colo2(lay)/(350.0_rb*2.0_rb)
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(22) + 1
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(22) + 1
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng22
+            taug(lay,ngs21+ig) = colo2(lay) * o2adj * &
+                (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + &
+                 fac11(lay) * absb(ind1+1,ig)) + &
+                 o2cont
+!            ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig)
+            taur(lay,ngs21+ig) = tauray
+         enddo
+      enddo
+
+      end subroutine taumol22
+
+!----------------------------------------------------------------------------
+      subroutine taumol23
+!----------------------------------------------------------------------------
+!
+!     band 23:  8050-12850 cm-1 (low - h2o; high - nothing)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng23, ngs22
+      use rrsw_kg23, only : absa, ka, forref, selfref, &
+                            sfluxref, rayl, layreffr, givfac
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray
+
+! 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.  
+
+      laysolfr = laytrop
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
+            laysolfr = min(lay+1,laytrop)
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(23) + 1
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(23) + 1
+         inds = indself(lay)
+         indf = indfor(lay)
+
+         do ig = 1, ng23
+            tauray = colmol(lay) * rayl(ig)
+            taug(lay,ngs22+ig) = colh2o(lay) * &
+                (givfac * (fac00(lay) * absa(ind0,ig) + &
+                 fac10(lay) * absa(ind0+1,ig) + &
+                 fac01(lay) * absa(ind1,ig) + &
+                 fac11(lay) * absa(ind1+1,ig)) + &
+                 selffac(lay) * (selfref(inds,ig) + &
+                 selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig))) + &
+                 forfac(lay) * (forref(indf,ig) + &
+                 forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig)))) 
+!            ssa(lay,ngs22+ig) = tauray/taug(lay,ngs22+ig)
+            if (lay .eq. laysolfr) sfluxzen(ngs22+ig) = sfluxref(ig) 
+            taur(lay,ngs22+ig) = tauray
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         do ig = 1, ng23
+!            taug(lay,ngs22+ig) = colmol(lay) * rayl(ig)
+!            ssa(lay,ngs22+ig) = 1.0_rb
+            taug(lay,ngs22+ig) = 0._rb
+            taur(lay,ngs22+ig) = colmol(lay) * rayl(ig) 
+         enddo
+      enddo
+
+      end subroutine taumol23
+
+!----------------------------------------------------------------------------
+      subroutine taumol24
+!----------------------------------------------------------------------------
+!
+!     band 24:  12850-16000 cm-1 (low - h2o,o2; high - o2)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng24, ngs23
+      use rrsw_kg24, only : absa, ka, absb, kb, forref, selfref, &
+                            sfluxref, abso3a, abso3b, rayla, raylb, &
+                            layreffr, strrat
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray
+
+! 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.  
+
+      laysolfr = laytrop
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
+            laysolfr = min(lay+1,laytrop)
+         speccomb = colh2o(lay) + strrat*colo2(lay)
+         specparm = colh2o(lay)/speccomb 
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult, 1._rb )
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs) * fac01(lay)
+         fac011 = (1._rb - fs) * fac11(lay)
+         fac101 = fs * fac01(lay)
+         fac111 = fs * fac11(lay)
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(24) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(24) + js
+         inds = indself(lay)
+         indf = indfor(lay)
+
+         do ig = 1, ng24
+            tauray = colmol(lay) * (rayla(ig,js) + &
+               fs * (rayla(ig,js+1) - rayla(ig,js)))
+            taug(lay,ngs23+ig) = speccomb * &
+                (fac000 * absa(ind0,ig) + &
+                 fac100 * absa(ind0+1,ig) + &
+                 fac010 * absa(ind0+9,ig) + &
+                 fac110 * absa(ind0+10,ig) + &
+                 fac001 * absa(ind1,ig) + &
+                 fac101 * absa(ind1+1,ig) + &
+                 fac011 * absa(ind1+9,ig) + &
+                 fac111 * absa(ind1+10,ig)) + &
+                 colo3(lay) * abso3a(ig) + &
+                 colh2o(lay) * & 
+                 (selffac(lay) * (selfref(inds,ig) + &
+                 selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig))) + &
+                 forfac(lay) * (forref(indf,ig) + & 
+                 forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig))))
+!            ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
+            if (lay .eq. laysolfr) sfluxzen(ngs23+ig) = sfluxref(ig,js) &
+               + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
+            taur(lay,ngs23+ig) = tauray
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(24) + 1
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(24) + 1
+
+         do ig = 1, ng24
+            tauray = colmol(lay) * raylb(ig)
+            taug(lay,ngs23+ig) = colo2(lay) * &
+                (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + &
+                 fac11(lay) * absb(ind1+1,ig)) + &
+                 colo3(lay) * abso3b(ig)
+!            ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig)
+            taur(lay,ngs23+ig) = tauray
+         enddo
+      enddo
+
+      end subroutine taumol24
+
+!----------------------------------------------------------------------------
+      subroutine taumol25
+!----------------------------------------------------------------------------
+!
+!     band 25:  16000-22650 cm-1 (low - h2o; high - nothing)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng25, ngs24
+      use rrsw_kg25, only : absa, ka, &
+                            sfluxref, abso3a, abso3b, rayl, layreffr
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray
+
+! 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.  
+
+      laysolfr = laytrop
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         if (jp(lay) .lt. layreffr .and. jp(lay+1) .ge. layreffr) &
+            laysolfr = min(lay+1,laytrop)
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(25) + 1
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(25) + 1
+
+         do ig = 1, ng25
+            tauray = colmol(lay) * rayl(ig)
+            taug(lay,ngs24+ig) = colh2o(lay) * &
+                (fac00(lay) * absa(ind0,ig) + &
+                 fac10(lay) * absa(ind0+1,ig) + &
+                 fac01(lay) * absa(ind1,ig) + &
+                 fac11(lay) * absa(ind1+1,ig)) + &
+                 colo3(lay) * abso3a(ig) 
+!            ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
+            if (lay .eq. laysolfr) sfluxzen(ngs24+ig) = sfluxref(ig) 
+            taur(lay,ngs24+ig) = tauray
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         do ig = 1, ng25
+            tauray = colmol(lay) * rayl(ig)
+            taug(lay,ngs24+ig) = colo3(lay) * abso3b(ig) 
+!            ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig)
+            taur(lay,ngs24+ig) = tauray
+         enddo
+      enddo
+
+      end subroutine taumol25
+
+!----------------------------------------------------------------------------
+      subroutine taumol26
+!----------------------------------------------------------------------------
+!
+!     band 26:  22650-29000 cm-1 (low - nothing; high - nothing)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng26, ngs25
+      use rrsw_kg26, only : sfluxref, rayl
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray
+
+! 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.  
+
+      laysolfr = laytrop
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         do ig = 1, ng26 
+!            taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
+!            ssa(lay,ngs25+ig) = 1.0_rb
+            if (lay .eq. laysolfr) sfluxzen(ngs25+ig) = sfluxref(ig) 
+            taug(lay,ngs25+ig) = 0._rb
+            taur(lay,ngs25+ig) = colmol(lay) * rayl(ig) 
+         enddo
+      enddo
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         do ig = 1, ng26
+!            taug(lay,ngs25+ig) = colmol(lay) * rayl(ig)
+!            ssa(lay,ngs25+ig) = 1.0_rb
+            taug(lay,ngs25+ig) = 0._rb
+            taur(lay,ngs25+ig) = colmol(lay) * rayl(ig) 
+         enddo
+      enddo
+
+      end subroutine taumol26
+
+!----------------------------------------------------------------------------
+      subroutine taumol27
+!----------------------------------------------------------------------------
+!
+!     band 27:  29000-38000 cm-1 (low - o3; high - o3)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng27, ngs26
+      use rrsw_kg27, only : absa, ka, absb, kb, &
+                            sfluxref, rayl, layreffr, scalekur
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray
+
+! 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.  
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(27) + 1
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(27) + 1
+
+         do ig = 1, ng27
+            tauray = colmol(lay) * rayl(ig)
+            taug(lay,ngs26+ig) = colo3(lay) * &
+                (fac00(lay) * absa(ind0,ig) + &
+                 fac10(lay) * absa(ind0+1,ig) + &
+                 fac01(lay) * absa(ind1,ig) + &
+                 fac11(lay) * absa(ind1+1,ig))
+!            ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
+            taur(lay,ngs26+ig) = tauray
+         enddo
+      enddo
+
+      laysolfr = nlayers
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
+            laysolfr = lay
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(27) + 1
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(27) + 1
+
+         do ig = 1, ng27
+            tauray = colmol(lay) * rayl(ig)
+            taug(lay,ngs26+ig) = colo3(lay) * &
+                (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + & 
+                 fac11(lay) * absb(ind1+1,ig))
+!            ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig)
+            if (lay.eq.laysolfr) sfluxzen(ngs26+ig) = scalekur * sfluxref(ig) 
+            taur(lay,ngs26+ig) = tauray
+         enddo
+      enddo
+
+      end subroutine taumol27
+
+!----------------------------------------------------------------------------
+      subroutine taumol28
+!----------------------------------------------------------------------------
+!
+!     band 28:  38000-50000 cm-1 (low - o3,o2; high - o3,o2)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng28, ngs27
+      use rrsw_kg28, only : absa, ka, absb, kb, &
+                            sfluxref, rayl, layreffr, strrat
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray
+
+! 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.  
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         speccomb = colo3(lay) + strrat*colo2(lay)
+         specparm = colo3(lay)/speccomb 
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 8._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult, 1._rb )
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs) * fac01(lay)
+         fac011 = (1._rb - fs) * fac11(lay)
+         fac101 = fs * fac01(lay)
+         fac111 = fs * fac11(lay)
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(28) + js
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(28) + js
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng28
+            taug(lay,ngs27+ig) = speccomb * &
+                (fac000 * absa(ind0,ig) + &
+                 fac100 * absa(ind0+1,ig) + &
+                 fac010 * absa(ind0+9,ig) + &
+                 fac110 * absa(ind0+10,ig) + &
+                 fac001 * absa(ind1,ig) + &
+                 fac101 * absa(ind1+1,ig) + &
+                 fac011 * absa(ind1+9,ig) + &
+                 fac111 * absa(ind1+10,ig)) 
+!            ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
+            taur(lay,ngs27+ig) = tauray
+         enddo
+      enddo
+
+      laysolfr = nlayers
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
+            laysolfr = lay
+         speccomb = colo3(lay) + strrat*colo2(lay)
+         specparm = colo3(lay)/speccomb 
+         if (specparm .ge. oneminus) specparm = oneminus
+         specmult = 4._rb*(specparm)
+         js = 1 + int(specmult)
+         fs = mod(specmult, 1._rb )
+         fac000 = (1._rb - fs) * fac00(lay)
+         fac010 = (1._rb - fs) * fac10(lay)
+         fac100 = fs * fac00(lay)
+         fac110 = fs * fac10(lay)
+         fac001 = (1._rb - fs) * fac01(lay)
+         fac011 = (1._rb - fs) * fac11(lay)
+         fac101 = fs * fac01(lay)
+         fac111 = fs * fac11(lay)
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(28) + js
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(28) + js
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng28
+            taug(lay,ngs27+ig) = speccomb * &
+                (fac000 * absb(ind0,ig) + &
+                 fac100 * absb(ind0+1,ig) + &
+                 fac010 * absb(ind0+5,ig) + &
+                 fac110 * absb(ind0+6,ig) + &
+                 fac001 * absb(ind1,ig) + &
+                 fac101 * absb(ind1+1,ig) + &
+                 fac011 * absb(ind1+5,ig) + &
+                 fac111 * absb(ind1+6,ig)) 
+!            ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig)
+            if (lay .eq. laysolfr) sfluxzen(ngs27+ig) = sfluxref(ig,js) &
+               + fs * (sfluxref(ig,js+1) - sfluxref(ig,js))
+            taur(lay,ngs27+ig) = tauray
+         enddo
+      enddo
+
+      end subroutine taumol28
+
+!----------------------------------------------------------------------------
+      subroutine taumol29
+!----------------------------------------------------------------------------
+!
+!     band 29:  820-2600 cm-1 (low - h2o; high - co2)
+!
+!----------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parrrsw, only : ng29, ngs28
+      use rrsw_kg29, only : absa, ka, absb, kb, forref, selfref, &
+                            sfluxref, absh2o, absco2, rayl, layreffr
+
+! ------- Declarations -------
+
+! Local
+
+      integer(kind=im) :: ig, ind0, ind1, inds, indf, js, lay, laysolfr
+      real(kind=rb) :: fac000, fac001, fac010, fac011, fac100, fac101, &
+                       fac110, fac111, fs, speccomb, specmult, specparm, &
+                       tauray
+
+! 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.  
+
+! Lower atmosphere loop
+      do lay = 1, laytrop
+         ind0 = ((jp(lay)-1)*5+(jt(lay)-1))*nspa(29) + 1
+         ind1 = (jp(lay)*5+(jt1(lay)-1))*nspa(29) + 1
+         inds = indself(lay)
+         indf = indfor(lay)
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng29
+            taug(lay,ngs28+ig) = colh2o(lay) * &
+               ((fac00(lay) * absa(ind0,ig) + &
+                 fac10(lay) * absa(ind0+1,ig) + &
+                 fac01(lay) * absa(ind1,ig) + &
+                 fac11(lay) * absa(ind1+1,ig)) + &
+                 selffac(lay) * (selfref(inds,ig) + &
+                 selffrac(lay) * &
+                 (selfref(inds+1,ig) - selfref(inds,ig))) + &
+                 forfac(lay) * (forref(indf,ig) + & 
+                 forfrac(lay) * &
+                 (forref(indf+1,ig) - forref(indf,ig)))) &
+                 + colco2(lay) * absco2(ig) 
+!            ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
+            taur(lay,ngs28+ig) = tauray
+         enddo
+      enddo
+
+      laysolfr = nlayers
+
+! Upper atmosphere loop
+      do lay = laytrop+1, nlayers
+         if (jp(lay-1) .lt. layreffr .and. jp(lay) .ge. layreffr) &
+            laysolfr = lay
+         ind0 = ((jp(lay)-13)*5+(jt(lay)-1))*nspb(29) + 1
+         ind1 = ((jp(lay)-12)*5+(jt1(lay)-1))*nspb(29) + 1
+         tauray = colmol(lay) * rayl
+
+         do ig = 1, ng29
+            taug(lay,ngs28+ig) = colco2(lay) * &
+                (fac00(lay) * absb(ind0,ig) + &
+                 fac10(lay) * absb(ind0+1,ig) + &
+                 fac01(lay) * absb(ind1,ig) + &
+                 fac11(lay) * absb(ind1+1,ig)) &  
+                 + colh2o(lay) * absh2o(ig) 
+!            ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig)
+            if (lay .eq. laysolfr) sfluxzen(ngs28+ig) = sfluxref(ig) 
+            taur(lay,ngs28+ig) = tauray
+         enddo
+      enddo
+
+      end subroutine taumol29
+
+      end subroutine taumol_sw
+
+      end module rrtmg_sw_taumol
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+
+      module rrtmg_sw_init
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! ------- Modules -------
+      use parkind, only : im => kind_im, rb => kind_rb
+      use rrsw_wvn
+      use rrtmg_sw_setcoef, only: swatmref
+
+      implicit none
+
+      contains
+
+! **************************************************************************
+      subroutine rrtmg_sw_ini(cpdair)
+! **************************************************************************
+!
+!  Original version:   Michael J. Iacono; February, 2004
+!  Revision for F90 formatting:  M. J. Iacono, July, 2006
+!
+!  This subroutine performs calculations necessary for the initialization
+!  of the shortwave model.  Lookup tables are computed for use in the SW
+!  radiative transfer, and input absorption coefficient data for each
+!  spectral band are reduced from 224 g-point intervals to 112.
+! **************************************************************************
+
+      use parrrsw, only : mg, nbndsw, ngptsw
+      use rrsw_tbl, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl
+      use rrsw_vsn, only: hvrini, hnamini
+
+      real(kind=rb), intent(in) :: cpdair     ! Specific heat capacity of dry air
+                                              ! at constant pressure at 273 K
+                                              ! (J kg-1 K-1)
+
+! ------- Local -------
+
+      integer(kind=im) :: ibnd, igc, ig, ind, ipr
+      integer(kind=im) :: igcsm, iprsm
+      integer(kind=im) :: itr
+
+      real(kind=rb) :: wtsum, wtsm(mg)
+      real(kind=rb) :: tfn
+
+      real(kind=rb), parameter :: expeps = 1.e-20   ! Smallest value for exponential table
+
+! ------- Definitions -------
+!     Arrays for 10000-point look-up tables:
+!     TAU_TBL  Clear-sky optical depth 
+!     EXP_TBL  Exponential lookup table for transmittance
+!     PADE     Pade approximation constant (= 0.278)
+!     BPADE    Inverse of the Pade approximation constant
+!
+
+      hvrini = '$Revision: 1.3 $'
+
+! Initialize model data
+      call swdatinit(cpdair)
+      call swcmbdat              ! g-point interval reduction data
+      call swaerpr               ! aerosol optical properties
+      call swcldpr               ! cloud optical properties
+      call swatmref              ! reference MLS profile
+! Moved to module_ra_rrtmg_sw for WRF
+!      call sw_kgb16              ! molecular absorption coefficients
+!      call sw_kgb17
+!      call sw_kgb18
+!      call sw_kgb19
+!      call sw_kgb20
+!      call sw_kgb21
+!      call sw_kgb22
+!      call sw_kgb23
+!      call sw_kgb24
+!      call sw_kgb25
+!      call sw_kgb26
+!      call sw_kgb27
+!      call sw_kgb28
+!      call sw_kgb29
+
+! Define exponential lookup tables for transmittance. Tau is
+! computed as a function of the tau transition function, and transmittance 
+! is calculated as a function of tau.  All tables are computed at intervals 
+! of 0.0001.  The inverse of the constant used in the Pade approximation to 
+! the tau transition function is set to bpade.
+
+      exp_tbl(0) = 1.0_rb
+      exp_tbl(ntbl) = expeps
+      bpade = 1.0_rb / pade
+      do itr = 1, ntbl-1
+         tfn = float(itr) / float(ntbl)
+         tau_tbl = bpade * tfn / (1._rb - tfn)
+         exp_tbl(itr) = exp(-tau_tbl)
+         if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps
+      enddo
+
+! Perform g-point reduction from 16 per band (224 total points) to
+! a band dependent number (112 total points) for all absorption
+! coefficient input data and Planck fraction input data.
+! Compute relative weighting for new g-point combinations.
+
+      igcsm = 0
+      do ibnd = 1,nbndsw
+         iprsm = 0
+         if (ngc(ibnd).lt.mg) then
+            do igc = 1,ngc(ibnd)
+               igcsm = igcsm + 1
+               wtsum = 0.
+               do ipr = 1, ngn(igcsm)
+                  iprsm = iprsm + 1
+                  wtsum = wtsum + wt(iprsm)
+               enddo
+               wtsm(igc) = wtsum
+            enddo
+            do ig = 1, ng(ibnd+15)
+               ind = (ibnd-1)*mg + ig
+               rwgt(ind) = wt(ig)/wtsm(ngm(ind))
+            enddo
+         else
+            do ig = 1, ng(ibnd+15)
+               igcsm = igcsm + 1
+               ind = (ibnd-1)*mg + ig
+               rwgt(ind) = 1.0_rb
+            enddo
+         endif
+      enddo
+
+! Reduce g-points for absorption coefficient data in each LW spectral band.
+
+      call cmbgb16s
+      call cmbgb17
+      call cmbgb18
+      call cmbgb19
+      call cmbgb20
+      call cmbgb21
+      call cmbgb22
+      call cmbgb23
+      call cmbgb24
+      call cmbgb25
+      call cmbgb26
+      call cmbgb27
+      call cmbgb28
+      call cmbgb29
+
+      end subroutine rrtmg_sw_ini
+
+!***************************************************************************
+      subroutine swdatinit(cpdair)
+!***************************************************************************
+
+! --------- Modules ----------
+
+      use rrsw_con, only: heatfac, grav, planck, boltz, &
+                          clight, avogad, alosmt, gascon, radcn1, radcn2, &
+                          sbcnst, secdy 
+      use rrsw_vsn
+
+      save 
+ 
+      real(kind=rb), intent(in) :: cpdair     ! Specific heat capacity of dry air
+                                              ! at constant pressure at 273 K
+                                              ! (J kg-1 K-1)
+
+! Shortwave spectral band limits (wavenumbers)
+      wavenum1(:) = (/2600._rb, 3250._rb, 4000._rb, 4650._rb, 5150._rb, 6150._rb, 7700._rb, &
+                      8050._rb,12850._rb,16000._rb,22650._rb,29000._rb,38000._rb,  820._rb/)
+      wavenum2(:) = (/3250._rb, 4000._rb, 4650._rb, 5150._rb, 6150._rb, 7700._rb, 8050._rb, &
+                     12850._rb,16000._rb,22650._rb,29000._rb,38000._rb,50000._rb, 2600._rb/)
+      delwave(:) =  (/ 650._rb,  750._rb,  650._rb,  500._rb, 1000._rb, 1550._rb,  350._rb, &
+                      4800._rb, 3150._rb, 6650._rb, 6350._rb, 9000._rb,12000._rb, 1780._rb/)
+
+! Spectral band information
+      ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
+      nspa(:) = (/9,9,9,9,1,9,9,1,9,1,0,1,9,1/)
+      nspb(:) = (/1,5,1,1,1,5,1,0,1,0,0,1,5,1/)
+
+! Fundamental physical constants from NIST 2002
+
+      grav = 9.8066_rb                        ! Acceleration of gravity
+                                              ! (m s-2)
+      planck = 6.62606876e-27_rb              ! Planck constant
+                                              ! (ergs s; g cm2 s-1)
+      boltz = 1.3806503e-16_rb                ! Boltzmann constant
+                                              ! (ergs K-1; g cm2 s-2 K-1)
+      clight = 2.99792458e+10_rb              ! Speed of light in a vacuum  
+                                              ! (cm s-1)
+      avogad = 6.02214199e+23_rb              ! Avogadro constant
+                                              ! (mol-1)
+      alosmt = 2.6867775e+19_rb               ! Loschmidt constant
+                                              ! (cm-3)
+      gascon = 8.31447200e+07_rb              ! Molar gas constant
+                                              ! (ergs mol-1 K-1)
+      radcn1 = 1.191042772e-12_rb             ! First radiation constant
+                                              ! (W cm2 sr-1)
+      radcn2 = 1.4387752_rb                   ! Second radiation constant
+                                              ! (cm K)
+      sbcnst = 5.670400e-04_rb                ! Stefan-Boltzmann constant
+                                              ! (W cm-2 K-4)
+      secdy = 8.6400e4_rb                     ! Number of seconds per day
+                                              ! (s d-1)
+!
+!     units are generally cgs
+!
+!     The first and second radiation constants are taken from NIST.
+!     They were previously obtained from the relations:
+!          radcn1 = 2.*planck*clight*clight*1.e-07
+!          radcn2 = planck*clight/boltz
+
+!     Heatfac is the factor by which delta-flux / delta-pressure is
+!     multiplied, with flux in W/m-2 and pressure in mbar, to get 
+!     the heating rate in units of degrees/day.  It is equal to:
+!     Original value:
+!           (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
+!           Here, cpdair (1.004) is in units of J g-1 K-1, and the 
+!           constant (1.e-5) converts mb to Pa and g-1 to kg-1.
+!        =  (9.8066)(86400)(1e-5)/(1.004)
+!      heatfac = 8.4391_rb
+!
+!     Modified value for consistency with CAM3:
+!           (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
+!           Here, cpdair (1.00464) is in units of J g-1 K-1, and the
+!           constant (1.e-5) converts mb to Pa and g-1 to kg-1.
+!        =  (9.80616)(86400)(1e-5)/(1.00464)
+!      heatfac = 8.43339130434_rb
+!
+!     Calculated value (from constants above and input cpdair)
+!        (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2)
+!           Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2) 
+!           converts mb to Pa when heatfac is multiplied by W m-2 mb-1. 
+      heatfac = grav * secdy / (cpdair * 1.e2_rb)
+
+      end subroutine swdatinit
+
+!***************************************************************************
+      subroutine swcmbdat
+!***************************************************************************
+
+      save
+ 
+! ------- Definitions -------
+!     Arrays for the g-point reduction from 224 to 112 for the 16 LW bands:
+!     This mapping from 224 to 112 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.  The full 224
+!     g-point set can be restored with ngpt=224, ngc=16*16, ngn=224*1., etc.
+!     ngpt    The total number of new g-points
+!     ngc     The number of new g-points in each band
+!     ngs     The cumulative sum of new g-points for 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.
+
+! Use this set for 112 quadrature point (g-point) model
+! ------- Data statements -------
+      ngc(:) = (/ 6,12, 8, 8,10,10, 2,10, 8, 6, 6, 8, 6,12 /)
+      ngs(:) = (/ 6,18,26,34,44,54,56,66,74,80,86,94,100,112 /)
+      ngm(:) = (/ 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, &           ! band 16
+                  1,2,3,4,5,6,6,7,8,8,9,10,10,11,12,12, &      ! band 17
+                  1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, &           ! band 18
+                  1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, &           ! band 19
+                  1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, &     ! band 20
+                  1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, &     ! band 21
+                  1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, &           ! band 22
+                  1,1,2,2,3,4,5,6,7,8,9,9,10,10,10,10, &       ! band 23
+                  1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, &           ! band 24
+                  1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, &           ! band 25
+                  1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, &           ! band 26
+                  1,2,3,4,5,6,7,7,7,7,8,8,8,8,8,8, &           ! band 27
+                  1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, &           ! band 28
+                  1,2,3,4,5,5,6,6,7,7,8,8,9,10,11,12 /)        ! band 29
+      ngn(:) = (/ 2,2,2,2,4,4, &                               ! band 16
+                  1,1,1,1,1,2,1,2,1,2,1,2, &                   ! band 17
+                  1,1,1,1,2,2,4,4, &                           ! band 18
+                  1,1,1,1,2,2,4,4, &                           ! band 19
+                  1,1,1,1,1,1,1,1,2,6, &                       ! band 20
+                  1,1,1,1,1,1,1,1,2,6, &                       ! band 21
+                  8,8, &                                       ! band 22
+                  2,2,1,1,1,1,1,1,2,4, &                       ! band 23
+                  2,2,2,2,2,2,2,2, &                           ! band 24
+                  1,1,2,2,4,6, &                               ! band 25
+                  1,1,2,2,4,6, &                               ! band 26
+                  1,1,1,1,1,1,4,6, &                           ! band 27
+                  1,1,2,2,4,6, &                               ! band 28
+                  1,1,1,1,2,2,2,2,1,1,1,1 /)                   ! band 29
+      ngb(:) = (/ 16,16,16,16,16,16, &                         ! band 16
+                  17,17,17,17,17,17,17,17,17,17,17,17, &       ! band 17
+                  18,18,18,18,18,18,18,18, &                   ! band 18
+                  19,19,19,19,19,19,19,19, &                   ! band 19
+                  20,20,20,20,20,20,20,20,20,20, &             ! band 20
+                  21,21,21,21,21,21,21,21,21,21, &             ! band 21
+                  22,22, &                                     ! band 22
+                  23,23,23,23,23,23,23,23,23,23, &             ! band 23
+                  24,24,24,24,24,24,24,24, &                   ! band 24
+                  25,25,25,25,25,25, &                         ! band 25
+                  26,26,26,26,26,26, &                         ! band 26
+                  27,27,27,27,27,27,27,27, &                   ! band 27
+                  28,28,28,28,28,28, &                         ! band 28
+                  29,29,29,29,29,29,29,29,29,29,29,29 /)       ! band 29
+
+! Use this set for full 224 quadrature point (g-point) model
+! ------- Data statements -------
+!      ngc(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16 /)
+!      ngs(:) = (/ 16,32,48,64,80,96,112,128,144,160,176,192,208,224 /)
+!      ngm(:) = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 16
+!                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 17
+!                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 18
+!                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 19
+!                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 20
+!                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 21
+!                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 22
+!                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 23
+!                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 24
+!                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 25
+!                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 26
+!                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 27
+!                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, &    ! band 28
+!                  1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 /)    ! band 29
+!      ngn(:) = (/ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 16
+!                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 17
+!                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 18
+!                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 19
+!                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 20
+!                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 21
+!                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 22
+!                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 23
+!                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 24
+!                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 25
+!                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 26
+!                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 27
+!                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, &           ! band 28
+!                  1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 /)           ! band 29
+!      ngb(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16, &   ! band 16
+!                  17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17, &   ! band 17
+!                  18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18, &   ! band 18
+!                  19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,19, &   ! band 19
+!                  20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20, &   ! band 20
+!                  21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21, &   ! band 21
+!                  22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22, &   ! band 22
+!                  23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, &   ! band 23
+!                  24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, &   ! band 24
+!                  25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25, &   ! band 25
+!                  26,26,26,26,26,26,26,26,26,26,26,26,26,26,26,26, &   ! band 26
+!                  27,27,27,27,27,27,27,27,27,27,27,27,27,27,27,27, &   ! band 27
+!                  28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28, &   ! band 28
+!                  29,29,29,29,29,29,29,29,29,29,29,29,29,29,29,29 /)   ! band 29
+
+
+      wt(:) =  (/ 0.1527534276_rb, 0.1491729617_rb, 0.1420961469_rb, &
+                  0.1316886544_rb, 0.1181945205_rb, 0.1019300893_rb, &
+                  0.0832767040_rb, 0.0626720116_rb, 0.0424925000_rb, &
+                  0.0046269894_rb, 0.0038279891_rb, 0.0030260086_rb, &
+                  0.0022199750_rb, 0.0014140010_rb, 0.0005330000_rb, &
+                  0.0000750000_rb /)
+
+      end subroutine swcmbdat
+
+!***************************************************************************
+      subroutine swaerpr
+!***************************************************************************
+
+! Purpose: Define spectral aerosol properties for six ECMWF aerosol types
+! as used in the ECMWF IFS model (see module rrsw_aer.F90 for details)
+!
+! Original: Defined for rrtmg_sw 14 spectral bands, JJMorcrette, ECMWF Feb 2003
+! Revision: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006
+
+      use rrsw_aer, only : rsrtaua, rsrpiza, rsrasya
+
+      save
+
+      rsrtaua( 1, :) = (/ &
+        0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
+      rsrtaua( 2, :) = (/ &
+        0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
+      rsrtaua( 3, :) = (/ &
+        0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
+      rsrtaua( 4, :) = (/ &
+        0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
+      rsrtaua( 5, :) = (/ &
+        0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
+      rsrtaua( 6, :) = (/ &
+        0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
+      rsrtaua( 7, :) = (/ &
+        0.20543_rb, 0.84642_rb, 0.84958_rb, 0.21673_rb, 0.28270_rb, 0.10915_rb/)
+      rsrtaua( 8, :) = (/ &
+        0.52838_rb, 0.93285_rb, 0.93449_rb, 0.53078_rb, 0.67148_rb, 0.46608_rb/)
+      rsrtaua( 9, :) = (/ &
+        0.52838_rb, 0.93285_rb, 0.93449_rb, 0.53078_rb, 0.67148_rb, 0.46608_rb/)
+      rsrtaua(10, :) = (/ &
+        1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
+      rsrtaua(11, :) = (/ &
+        1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
+      rsrtaua(12, :) = (/ &
+        1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
+      rsrtaua(13, :) = (/ &
+        1.69446_rb, 1.11855_rb, 1.09212_rb, 1.72145_rb, 1.03858_rb, 1.12044_rb/)
+      rsrtaua(14, :) = (/ &
+        0.10849_rb, 0.66699_rb, 0.65255_rb, 0.11600_rb, 0.06529_rb, 0.04468_rb/)
+ 
+      rsrpiza( 1, :) = (/ &
+        .5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, .8748231_rb, .2355667_rb/)
+      rsrpiza( 2, :) = (/ &
+        .5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, .8748231_rb, .2355667_rb/)
+      rsrpiza( 3, :) = (/ &
+        .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
+      rsrpiza( 4, :) = (/ &
+        .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
+      rsrpiza( 5, :) = (/ &
+        .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
+      rsrpiza( 6, :) = (/ &
+        .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
+      rsrpiza( 7, :) = (/ &
+        .8287144_rb, .9949396_rb, .9279543_rb, .6765051_rb, .9467578_rb, .9955938_rb/)
+      rsrpiza( 8, :) = (/ &
+        .8970131_rb, .9984940_rb, .9245594_rb, .7768385_rb, .9532763_rb, .9999999_rb/)
+      rsrpiza( 9, :) = (/ &
+        .8970131_rb, .9984940_rb, .9245594_rb, .7768385_rb, .9532763_rb, .9999999_rb/)
+      rsrpiza(10, :) = (/ &
+        .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/)
+      rsrpiza(11, :) = (/ &
+        .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/)
+      rsrpiza(12, :) = (/ &
+        .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/)
+      rsrpiza(13, :) = (/ &
+        .9148907_rb, .9956173_rb, .7504584_rb, .8131335_rb, .9401905_rb, .9999999_rb/)
+      rsrpiza(14, :) = (/ &
+        .5230504_rb, .7868518_rb, .8531531_rb, .4048149_rb, .8748231_rb, .2355667_rb/)
+
+      rsrasya( 1, :) = (/ &
+        0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, .4629866_rb, .1907639_rb/)
+      rsrasya( 2, :) = (/ &
+        0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, .4629866_rb, .1907639_rb/)
+      rsrasya( 3, :) = (/ &
+        0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
+      rsrasya( 4, :) = (/ &
+        0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
+      rsrasya( 5, :) = (/ &
+        0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
+      rsrasya( 6, :) = (/ &
+        0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
+      rsrasya( 7, :) = (/ &
+        0.636342_rb, 0.802467_rb, 0.691305_rb, 0.627497_rb, .6105750_rb, .4760794_rb/)
+      rsrasya( 8, :) = (/ &
+        0.668431_rb, 0.788530_rb, 0.698682_rb, 0.657422_rb, .6735182_rb, .6519706_rb/)
+      rsrasya( 9, :) = (/ &
+        0.668431_rb, 0.788530_rb, 0.698682_rb, 0.657422_rb, .6735182_rb, .6519706_rb/)
+      rsrasya(10, :) = (/ &
+        0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/)
+      rsrasya(11, :) = (/ &
+        0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/)
+      rsrasya(12, :) = (/ &
+        0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/)
+      rsrasya(13, :) = (/ &
+        0.729019_rb, 0.803129_rb, 0.784592_rb, 0.712208_rb, .7008249_rb, .7270548_rb/)
+      rsrasya(14, :) = (/ &
+        0.700610_rb, 0.818871_rb, 0.702399_rb, 0.689886_rb, .4629866_rb, .1907639_rb/)
+
+      end subroutine swaerpr
+ 
+!***************************************************************************
+      subroutine cmbgb16s
+!***************************************************************************
+!
+!  Original version:       MJIacono; July 1998
+!  Revision for RRTM_SW:   MJIacono; November 2002
+!  Revision for RRTMG_SW:  MJIacono; December 2003
+!  Revision for F90 reformatting:  MJIacono; July 2006
+!
+!  The subroutines CMBGB16->CMBGB29 input the absorption coefficient
+!  data for each band, which are defined for 16 g-points and 14 spectral
+!  bands. The data are combined with appropriate weighting following the
+!  g-point mapping arrays specified in RRTMG_SW_INIT.  Solar source 
+!  function data in array SFLUXREF are combined without weighting.  All
+!  g-point reduced data are put into new arrays for use in RRTMG_SW.
+!
+!  band 16:  2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
+!
+!-----------------------------------------------------------------------
+
+      use rrsw_kg16, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            absa, ka, absb, kb, selfref, forref, sfluxref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(1)
+                  sumk = 0.
+                  do ipr = 1, ngn(igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,5
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(1)
+               sumk = 0.
+               do ipr = 1, ngn(igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(1)
+            sumk = 0.
+            do ipr = 1, ngn(igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,3
+         iprsm = 0
+         do igc = 1,ngc(1)
+            sumk = 0.
+            do ipr = 1, ngn(igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(1)
+         sumf = 0.
+         do ipr = 1, ngn(igc)
+            iprsm = iprsm + 1
+            sumf = sumf + sfluxrefo(iprsm)
+         enddo
+         sfluxref(igc) = sumf
+      enddo
+
+      end subroutine cmbgb16s
+
+!***************************************************************************
+      subroutine cmbgb17
+!***************************************************************************
+!
+!     band 17:  3250-4000 cm-1 (low - h2o,co2; high - h2o,co2)
+!-----------------------------------------------------------------------
+
+      use rrsw_kg17, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            absa, ka, absb, kb, selfref, forref, sfluxref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(2)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(1)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+16)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jn = 1,5
+         do jt = 1,5
+            do jp = 13,59
+               iprsm = 0
+               do igc = 1,ngc(2)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(1)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+16)
+                  enddo
+                  kb(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(2)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(1)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(2)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(1)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jp = 1,5
+         iprsm = 0
+         do igc = 1,ngc(2)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(1)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + sfluxrefo(iprsm,jp)
+            enddo
+            sfluxref(igc,jp) = sumf
+         enddo
+      enddo
+
+      end subroutine cmbgb17
+
+!***************************************************************************
+      subroutine cmbgb18
+!***************************************************************************
+!
+!     band 18:  4000-4650 cm-1 (low - h2o,ch4; high - ch4)
+!-----------------------------------------------------------------------
+
+      use rrsw_kg18, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            absa, ka, absb, kb, selfref, forref, sfluxref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(3)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(2)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,5
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(3)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(2)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+32)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(3)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(2)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,3
+         iprsm = 0
+         do igc = 1,ngc(3)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(2)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(3)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(2)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + sfluxrefo(iprsm,jp)
+            enddo
+            sfluxref(igc,jp) = sumf
+         enddo
+      enddo
+
+      end subroutine cmbgb18
+
+!***************************************************************************
+      subroutine cmbgb19
+!***************************************************************************
+!
+!     band 19:  4650-5150 cm-1 (low - h2o,co2; high - co2)
+!-----------------------------------------------------------------------
+
+      use rrsw_kg19, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            absa, ka, absb, kb, selfref, forref, sfluxref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(4)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(3)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,5
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(4)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(3)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+48)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(4)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(3)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,3
+         iprsm = 0
+         do igc = 1,ngc(4)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(3)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(4)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(3)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + sfluxrefo(iprsm,jp)
+            enddo
+            sfluxref(igc,jp) = sumf
+         enddo
+      enddo
+
+      end subroutine cmbgb19
+
+!***************************************************************************
+      subroutine cmbgb20
+!***************************************************************************
+!
+!     band 20:  5150-6150 cm-1 (low - h2o; high - h2o)
+!-----------------------------------------------------------------------
+
+      use rrsw_kg20, only : kao, kbo, selfrefo, forrefo, sfluxrefo, absch4o, &
+                            absa, ka, absb, kb, selfref, forref, sfluxref, absch4
+
+! ------- Local -------
+      integer(kind=im) :: jt, jp, igc, ipr, iprsm
+      real(kind=rb) :: sumk, sumf1, sumf2
+
+
+      do jt = 1,5
+         do jp = 1,13
+            iprsm = 0
+            do igc = 1,ngc(5)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(4)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+64)
+               enddo
+               ka(jt,jp,igc) = sumk
+            enddo
+         enddo
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(5)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(4)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+64)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(5)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(4)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(5)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(4)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(5)
+         sumf1 = 0.
+         sumf2 = 0.
+         do ipr = 1, ngn(ngs(4)+igc)
+            iprsm = iprsm + 1
+            sumf1 = sumf1 + sfluxrefo(iprsm)
+            sumf2 = sumf2 + absch4o(iprsm)*rwgt(iprsm+64)
+         enddo
+         sfluxref(igc) = sumf1
+         absch4(igc) = sumf2
+      enddo
+
+      end subroutine cmbgb20
+
+!***************************************************************************
+      subroutine cmbgb21
+!***************************************************************************
+!
+!     band 21:  6150-7700 cm-1 (low - h2o,co2; high - h2o,co2)
+!-----------------------------------------------------------------------
+
+      use rrsw_kg21, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            absa, ka, absb, kb, selfref, forref, sfluxref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(6)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(5)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+80)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jn = 1,5
+         do jt = 1,5
+            do jp = 13,59
+               iprsm = 0
+               do igc = 1,ngc(6)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(5)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+80)
+                  enddo
+                  kb(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(6)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(5)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(6)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(5)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(6)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(5)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + sfluxrefo(iprsm,jp)
+            enddo
+            sfluxref(igc,jp) = sumf
+         enddo
+      enddo
+
+      end subroutine cmbgb21
+
+!***************************************************************************
+      subroutine cmbgb22
+!***************************************************************************
+!
+!     band 22:  7700-8050 cm-1 (low - h2o,o2; high - o2)
+!-----------------------------------------------------------------------
+
+      use rrsw_kg22, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            absa, ka, absb, kb, selfref, forref, sfluxref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(7)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(6)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,5
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(7)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(6)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(7)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(6)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,3
+         iprsm = 0
+         do igc = 1,ngc(7)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(6)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(7)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(6)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + sfluxrefo(iprsm,jp)
+            enddo
+            sfluxref(igc,jp) = sumf
+         enddo
+      enddo
+
+      end subroutine cmbgb22
+
+!***************************************************************************
+      subroutine cmbgb23
+!***************************************************************************
+!
+!     band 23:  8050-12850 cm-1 (low - h2o; high - nothing)
+!-----------------------------------------------------------------------
+
+      use rrsw_kg23, only : kao, selfrefo, forrefo, sfluxrefo, raylo, &
+                            absa, ka, selfref, forref, sfluxref, rayl
+
+! ------- Local -------
+      integer(kind=im) :: jt, jp, igc, ipr, iprsm
+      real(kind=rb) :: sumk, sumf1, sumf2
+
+
+      do jt = 1,5
+         do jp = 1,13
+            iprsm = 0
+            do igc = 1,ngc(8)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(7)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
+               enddo
+               ka(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(8)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(7)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,3
+         iprsm = 0
+         do igc = 1,ngc(8)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(7)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(8)
+         sumf1 = 0.
+         sumf2 = 0.
+         do ipr = 1, ngn(ngs(7)+igc)
+            iprsm = iprsm + 1
+            sumf1 = sumf1 + sfluxrefo(iprsm)
+            sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+112)
+         enddo
+         sfluxref(igc) = sumf1
+         rayl(igc) = sumf2
+      enddo
+
+      end subroutine cmbgb23
+
+!***************************************************************************
+      subroutine cmbgb24
+!***************************************************************************
+!
+!     band 24:  12850-16000 cm-1 (low - h2o,o2; high - o2)
+!-----------------------------------------------------------------------
+
+      use rrsw_kg24, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            abso3ao, abso3bo, raylao, raylbo, &
+                            absa, ka, absb, kb, selfref, forref, sfluxref, &
+                            abso3a, abso3b, rayla, raylb
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
+      real(kind=rb) :: sumk, sumf1, sumf2, sumf3
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(9)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(8)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,5
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(9)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(8)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(9)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(8)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,3
+         iprsm = 0
+         do igc = 1,ngc(9)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(8)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(9)
+         sumf1 = 0.
+         sumf2 = 0.
+         sumf3 = 0.
+         do ipr = 1, ngn(ngs(8)+igc)
+            iprsm = iprsm + 1
+            sumf1 = sumf1 + raylbo(iprsm)*rwgt(iprsm+128)
+            sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+128)
+            sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+128)
+         enddo
+         raylb(igc) = sumf1
+         abso3a(igc) = sumf2
+         abso3b(igc) = sumf3
+      enddo
+
+      do jp = 1,9
+         iprsm = 0
+         do igc = 1,ngc(9)
+            sumf1 = 0.
+            sumf2 = 0.
+            do ipr = 1, ngn(ngs(8)+igc)
+               iprsm = iprsm + 1
+               sumf1 = sumf1 + sfluxrefo(iprsm,jp)
+               sumf2 = sumf2 + raylao(iprsm,jp)*rwgt(iprsm+128)
+            enddo
+            sfluxref(igc,jp) = sumf1
+            rayla(igc,jp) = sumf2
+         enddo
+      enddo
+
+      end subroutine cmbgb24
+
+!***************************************************************************
+      subroutine cmbgb25
+!***************************************************************************
+!
+!     band 25:  16000-22650 cm-1 (low - h2o; high - nothing)
+!-----------------------------------------------------------------------
+
+      use rrsw_kg25, only : kao, sfluxrefo, &
+                            abso3ao, abso3bo, raylo, &
+                            absa, ka, sfluxref, &
+                            abso3a, abso3b, rayl
+
+! ------- Local -------
+      integer(kind=im) :: jt, jp, igc, ipr, iprsm
+      real(kind=rb) :: sumk, sumf1, sumf2, sumf3, sumf4
+
+
+      do jt = 1,5
+         do jp = 1,13
+            iprsm = 0
+            do igc = 1,ngc(10)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(9)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
+               enddo
+               ka(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(10)
+         sumf1 = 0.
+         sumf2 = 0.
+         sumf3 = 0.
+         sumf4 = 0.
+         do ipr = 1, ngn(ngs(9)+igc)
+            iprsm = iprsm + 1
+            sumf1 = sumf1 + sfluxrefo(iprsm)
+            sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+144)
+            sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+144)
+            sumf4 = sumf4 + raylo(iprsm)*rwgt(iprsm+144)
+         enddo
+         sfluxref(igc) = sumf1
+         abso3a(igc) = sumf2
+         abso3b(igc) = sumf3
+         rayl(igc) = sumf4
+      enddo
+
+      end subroutine cmbgb25
+
+!***************************************************************************
+      subroutine cmbgb26
+!***************************************************************************
+!
+!     band 26:  22650-29000 cm-1 (low - nothing; high - nothing)
+!-----------------------------------------------------------------------
+
+      use rrsw_kg26, only : sfluxrefo, raylo, &
+                            sfluxref, rayl
+
+! ------- Local -------
+      integer(kind=im) :: igc, ipr, iprsm
+      real(kind=rb) :: sumf1, sumf2
+
+
+      iprsm = 0
+      do igc = 1,ngc(11)
+         sumf1 = 0.
+         sumf2 = 0.
+         do ipr = 1, ngn(ngs(10)+igc)
+            iprsm = iprsm + 1
+            sumf1 = sumf1 + raylo(iprsm)*rwgt(iprsm+160)
+            sumf2 = sumf2 + sfluxrefo(iprsm)
+         enddo
+         rayl(igc) = sumf1
+         sfluxref(igc) = sumf2
+      enddo
+
+      end subroutine cmbgb26
+
+!***************************************************************************
+      subroutine cmbgb27
+!***************************************************************************
+!
+!     band 27:  29000-38000 cm-1 (low - o3; high - o3)
+!-----------------------------------------------------------------------
+
+      use rrsw_kg27, only : kao, kbo, sfluxrefo, raylo, &
+                            absa, ka, absb, kb, sfluxref, rayl
+
+! ------- Local -------
+      integer(kind=im) :: jt, jp, igc, ipr, iprsm
+      real(kind=rb) :: sumk, sumf1, sumf2
+
+
+      do jt = 1,5
+         do jp = 1,13
+            iprsm = 0
+            do igc = 1,ngc(12)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(11)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+176)
+               enddo
+               ka(jt,jp,igc) = sumk
+            enddo
+         enddo
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(12)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(11)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+176)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(12)
+         sumf1 = 0.
+         sumf2 = 0.
+         do ipr = 1, ngn(ngs(11)+igc)
+            iprsm = iprsm + 1
+            sumf1 = sumf1 + sfluxrefo(iprsm)
+            sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+176)
+         enddo
+         sfluxref(igc) = sumf1
+         rayl(igc) = sumf2
+      enddo
+
+      end subroutine cmbgb27
+
+!***************************************************************************
+      subroutine cmbgb28
+!***************************************************************************
+!
+!     band 28:  38000-50000 cm-1 (low - o3,o2; high - o3,o2)
+!-----------------------------------------------------------------------
+
+      use rrsw_kg28, only : kao, kbo, sfluxrefo, &
+                            absa, ka, absb, kb, sfluxref
+
+! ------- Local -------
+      integer(kind=im) :: jn, jt, jp, igc, ipr, iprsm
+      real(kind=rb) :: sumk, sumf
+
+
+      do jn = 1,9
+         do jt = 1,5
+            do jp = 1,13
+               iprsm = 0
+               do igc = 1,ngc(13)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(12)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
+                  enddo
+                  ka(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jn = 1,5
+         do jt = 1,5
+            do jp = 13,59
+               iprsm = 0
+               do igc = 1,ngc(13)
+                  sumk = 0.
+                  do ipr = 1, ngn(ngs(12)+igc)
+                     iprsm = iprsm + 1
+                     sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+192)
+                  enddo
+                  kb(jn,jt,jp,igc) = sumk
+               enddo
+            enddo
+         enddo
+      enddo
+
+      do jp = 1,5
+         iprsm = 0
+         do igc = 1,ngc(13)
+            sumf = 0.
+            do ipr = 1, ngn(ngs(12)+igc)
+               iprsm = iprsm + 1
+               sumf = sumf + sfluxrefo(iprsm,jp)
+            enddo
+            sfluxref(igc,jp) = sumf
+         enddo
+      enddo
+
+      end subroutine cmbgb28
+
+!***************************************************************************
+      subroutine cmbgb29
+!***************************************************************************
+!
+!     band 29:  820-2600 cm-1 (low - h2o; high - co2)
+!-----------------------------------------------------------------------
+
+      use rrsw_kg29, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            absh2oo, absco2o, &
+                            absa, ka, absb, kb, selfref, forref, sfluxref, &
+                            absh2o, absco2
+
+! ------- Local -------
+      integer(kind=im) :: jt, jp, igc, ipr, iprsm
+      real(kind=rb) :: sumk, sumf1, sumf2, sumf3
+
+
+      do jt = 1,5
+         do jp = 1,13
+            iprsm = 0
+            do igc = 1,ngc(14)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(13)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
+               enddo
+               ka(jt,jp,igc) = sumk
+            enddo
+         enddo
+         do jp = 13,59
+            iprsm = 0
+            do igc = 1,ngc(14)
+               sumk = 0.
+               do ipr = 1, ngn(ngs(13)+igc)
+                  iprsm = iprsm + 1
+                  sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
+               enddo
+               kb(jt,jp,igc) = sumk
+            enddo
+         enddo
+      enddo
+
+      do jt = 1,10
+         iprsm = 0
+         do igc = 1,ngc(14)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(13)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
+            enddo
+            selfref(jt,igc) = sumk
+         enddo
+      enddo
+
+      do jt = 1,4
+         iprsm = 0
+         do igc = 1,ngc(14)
+            sumk = 0.
+            do ipr = 1, ngn(ngs(13)+igc)
+               iprsm = iprsm + 1
+               sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
+            enddo
+            forref(jt,igc) = sumk
+         enddo
+      enddo
+
+      iprsm = 0
+      do igc = 1,ngc(14)
+         sumf1 = 0.
+         sumf2 = 0.
+         sumf3 = 0.
+         do ipr = 1, ngn(ngs(13)+igc)
+            iprsm = iprsm + 1
+            sumf1 = sumf1 + sfluxrefo(iprsm)
+            sumf2 = sumf2 + absco2o(iprsm)*rwgt(iprsm+208)
+            sumf3 = sumf3 + absh2oo(iprsm)*rwgt(iprsm+208)
+         enddo
+         sfluxref(igc) = sumf1
+         absco2(igc) = sumf2
+         absh2o(igc) = sumf3
+      enddo
+
+      end subroutine cmbgb29
+
+!***********************************************************************
+      subroutine swcldpr
+!***********************************************************************
+
+! Purpose: Define cloud extinction coefficient, single scattering albedo
+!          and asymmetry parameter data.
+!
+
+! ------- Modules -------
+
+      use rrsw_cld, only : extliq1, ssaliq1, asyliq1, &
+                           extice2, ssaice2, asyice2, &
+                           extice3, ssaice3, asyice3, fdlice3, &
+                           abari, bbari, cbari, dbari, ebari, fbari
+
+      save
+
+!-----------------------------------------------------------------------
+!
+! Explanation of the method for each value of INFLAG.  A value of
+!  0 for INFLAG do not distingish being liquid and ice clouds.
+!  INFLAG = 2 does distinguish between liquid and ice clouds, and
+!    requires further user input to specify the method to be used to 
+!    compute the aborption due to each.
+!  INFLAG = 0:  For each cloudy layer, the cloud fraction, the cloud optical
+!    depth, the cloud single-scattering albedo, and the
+!    moments of the phase function (0:NSTREAM).  Note
+!    that these values are delta-m scaled within this
+!    subroutine.
+
+!  INFLAG = 2:  For each cloudy layer, the cloud fraction, cloud 
+!    water path (g/m2), and cloud ice fraction are input.
+!  ICEFLAG = 2:  The ice effective radius (microns) is input and the
+!    optical properties due to ice clouds are computed from
+!    the optical properties stored in the RT code, STREAMER v3.0 
+!    (Reference: Key. J., Streamer User's Guide, Cooperative 
+!    Institute for Meteorological Satellite Studies, 2001, 96 pp.).
+!    Valid range of values for re are between 5.0 and
+!    131.0 micron.
+!    This version uses Ebert and Curry, JGR, (1992) method for 
+!    ice particles larger than 131.0 microns. 
+!  ICEFLAG = 3:  The ice generalized effective size (dge) is input
+!    and the optical depths, single-scattering albedo,
+!    and phase function moments are calculated as in
+!    Q. Fu, J. Climate, (1996). Q. Fu provided high resolution
+!    tables which were appropriately averaged for the
+!    bands in RRTM_SW.  Linear interpolation is used to
+!    get the coefficients from the stored tables.
+!    Valid range of values for dge are between 5.0 and
+!    140.0 micron. 
+!    This version uses Ebert and Curry, JGR, (1992) method for 
+!    ice particles larger than 140.0 microns. 
+!  LIQFLAG = 1:  The water droplet effective radius (microns) is input 
+!    and the optical depths due to water clouds are computed 
+!    as in Hu and Stamnes, J., Clim., 6, 728-742, (1993).
+!    The values for absorption coefficients appropriate for
+!    the spectral bands in RRTM have been obtained for a 
+!    range of effective radii by an averaging procedure 
+!    based on the work of J. Pinto (private communication).
+!    Linear interpolation is used to get the absorption 
+!    coefficients for the input effective radius.
+!
+!     ------------------------------------------------------------------
+
+! Everything below is for INFLAG = 2.
+
+! Coefficients for Ebert and Curry method
+      abari(:) = (/ &
+        & 3.448e-03_rb,3.448e-03_rb,3.448e-03_rb,3.448e-03_rb,3.448e-03_rb /)
+      bbari(:) = (/ &
+        & 2.431e+00_rb,2.431e+00_rb,2.431e+00_rb,2.431e+00_rb,2.431e+00_rb /)
+      cbari(:) = (/ &
+        & 1.000e-05_rb,1.100e-04_rb,1.240e-02_rb,3.779e-02_rb,4.666e-01_rb /)
+      dbari(:) = (/ &
+        & 0.000e+00_rb,1.405e-05_rb,6.867e-04_rb,1.284e-03_rb,2.050e-05_rb /)
+      ebari(:) = (/ &
+        & 7.661e-01_rb,7.730e-01_rb,7.865e-01_rb,8.172e-01_rb,9.595e-01_rb /)
+      fbari(:) = (/ &
+        & 5.851e-04_rb,5.665e-04_rb,7.204e-04_rb,7.463e-04_rb,1.076e-04_rb /)
+
+! Extinction coefficient
+      extliq1(:, 16) = (/ &
+        & 8.981463e-01_rb,6.317895e-01_rb,4.557508e-01_rb,3.481624e-01_rb,2.797950e-01_rb,&
+        & 2.342753e-01_rb,2.026934e-01_rb,1.800102e-01_rb,1.632408e-01_rb,1.505384e-01_rb,&
+        & 1.354524e-01_rb,1.246520e-01_rb,1.154342e-01_rb,1.074756e-01_rb,1.005353e-01_rb,&
+        & 9.442987e-02_rb,8.901760e-02_rb,8.418693e-02_rb,7.984904e-02_rb,7.593229e-02_rb,&
+        & 7.237827e-02_rb,6.913887e-02_rb,6.617415e-02_rb,6.345061e-02_rb,6.094001e-02_rb,&
+        & 5.861834e-02_rb,5.646506e-02_rb,5.446250e-02_rb,5.249596e-02_rb,5.081114e-02_rb,&
+        & 4.922243e-02_rb,4.772189e-02_rb,4.630243e-02_rb,4.495766e-02_rb,4.368189e-02_rb,&
+        & 4.246995e-02_rb,4.131720e-02_rb,4.021941e-02_rb,3.917276e-02_rb,3.817376e-02_rb,&
+        & 3.721926e-02_rb,3.630635e-02_rb,3.543237e-02_rb,3.459491e-02_rb,3.379171e-02_rb,&
+        & 3.302073e-02_rb,3.228007e-02_rb,3.156798e-02_rb,3.088284e-02_rb,3.022315e-02_rb,&
+        & 2.958753e-02_rb,2.897468e-02_rb,2.838340e-02_rb,2.781258e-02_rb,2.726117e-02_rb,&
+        & 2.672821e-02_rb,2.621278e-02_rb,2.5714e-02_rb /)
+      extliq1(:, 17) = (/ &
+        & 8.293797e-01_rb,6.048371e-01_rb,4.465706e-01_rb,3.460387e-01_rb,2.800064e-01_rb,&
+        & 2.346584e-01_rb,2.022399e-01_rb,1.782626e-01_rb,1.600153e-01_rb,1.457903e-01_rb,&
+        & 1.334061e-01_rb,1.228548e-01_rb,1.138396e-01_rb,1.060486e-01_rb,9.924856e-02_rb,&
+        & 9.326208e-02_rb,8.795158e-02_rb,8.320883e-02_rb,7.894750e-02_rb,7.509792e-02_rb,&
+        & 7.160323e-02_rb,6.841653e-02_rb,6.549889e-02_rb,6.281763e-02_rb,6.034516e-02_rb,&
+        & 5.805802e-02_rb,5.593615e-02_rb,5.396226e-02_rb,5.202302e-02_rb,5.036246e-02_rb,&
+        & 4.879606e-02_rb,4.731610e-02_rb,4.591565e-02_rb,4.458852e-02_rb,4.332912e-02_rb,&
+        & 4.213243e-02_rb,4.099390e-02_rb,3.990941e-02_rb,3.887522e-02_rb,3.788792e-02_rb,&
+        & 3.694440e-02_rb,3.604183e-02_rb,3.517760e-02_rb,3.434934e-02_rb,3.355485e-02_rb,&
+        & 3.279211e-02_rb,3.205925e-02_rb,3.135458e-02_rb,3.067648e-02_rb,3.002349e-02_rb,&
+        & 2.939425e-02_rb,2.878748e-02_rb,2.820200e-02_rb,2.763673e-02_rb,2.709062e-02_rb,&
+        & 2.656272e-02_rb,2.605214e-02_rb,2.5558e-02_rb /)
+      extliq1(:, 18) = (/ &
+        & 9.193685e-01_rb,6.128292e-01_rb,4.344150e-01_rb,3.303048e-01_rb,2.659500e-01_rb,&
+        & 2.239727e-01_rb,1.953457e-01_rb,1.751012e-01_rb,1.603515e-01_rb,1.493360e-01_rb,&
+        & 1.323791e-01_rb,1.219335e-01_rb,1.130076e-01_rb,1.052926e-01_rb,9.855839e-02_rb,&
+        & 9.262925e-02_rb,8.736918e-02_rb,8.267112e-02_rb,7.844965e-02_rb,7.463585e-02_rb,&
+        & 7.117343e-02_rb,6.801601e-02_rb,6.512503e-02_rb,6.246815e-02_rb,6.001806e-02_rb,&
+        & 5.775154e-02_rb,5.564872e-02_rb,5.369250e-02_rb,5.176284e-02_rb,5.011536e-02_rb,&
+        & 4.856099e-02_rb,4.709211e-02_rb,4.570193e-02_rb,4.438430e-02_rb,4.313375e-02_rb,&
+        & 4.194529e-02_rb,4.081443e-02_rb,3.973712e-02_rb,3.870966e-02_rb,3.772866e-02_rb,&
+        & 3.679108e-02_rb,3.589409e-02_rb,3.503514e-02_rb,3.421185e-02_rb,3.342206e-02_rb,&
+        & 3.266377e-02_rb,3.193513e-02_rb,3.123447e-02_rb,3.056018e-02_rb,2.991081e-02_rb,&
+        & 2.928502e-02_rb,2.868154e-02_rb,2.809920e-02_rb,2.753692e-02_rb,2.699367e-02_rb,&
+        & 2.646852e-02_rb,2.596057e-02_rb,2.5469e-02_rb /)
+      extliq1(:, 19) = (/ &
+        & 9.136931e-01_rb,5.743244e-01_rb,4.080708e-01_rb,3.150572e-01_rb,2.577261e-01_rb,&
+        & 2.197900e-01_rb,1.933037e-01_rb,1.740212e-01_rb,1.595056e-01_rb,1.482756e-01_rb,&
+        & 1.312164e-01_rb,1.209246e-01_rb,1.121227e-01_rb,1.045095e-01_rb,9.785967e-02_rb,&
+        & 9.200149e-02_rb,8.680170e-02_rb,8.215531e-02_rb,7.797850e-02_rb,7.420361e-02_rb,&
+        & 7.077530e-02_rb,6.764798e-02_rb,6.478369e-02_rb,6.215063e-02_rb,5.972189e-02_rb,&
+        & 5.747458e-02_rb,5.538913e-02_rb,5.344866e-02_rb,5.153216e-02_rb,4.989745e-02_rb,&
+        & 4.835476e-02_rb,4.689661e-02_rb,4.551629e-02_rb,4.420777e-02_rb,4.296563e-02_rb,&
+        & 4.178497e-02_rb,4.066137e-02_rb,3.959081e-02_rb,3.856963e-02_rb,3.759452e-02_rb,&
+        & 3.666244e-02_rb,3.577061e-02_rb,3.491650e-02_rb,3.409777e-02_rb,3.331227e-02_rb,&
+        & 3.255803e-02_rb,3.183322e-02_rb,3.113617e-02_rb,3.046530e-02_rb,2.981918e-02_rb,&
+        & 2.919646e-02_rb,2.859591e-02_rb,2.801635e-02_rb,2.745671e-02_rb,2.691599e-02_rb,&
+        & 2.639324e-02_rb,2.588759e-02_rb,2.5398e-02_rb /)
+      extliq1(:, 20) = (/ &
+        & 8.447548e-01_rb,5.326840e-01_rb,3.921523e-01_rb,3.119082e-01_rb,2.597055e-01_rb,&
+        & 2.228737e-01_rb,1.954157e-01_rb,1.741155e-01_rb,1.570881e-01_rb,1.431520e-01_rb,&
+        & 1.302034e-01_rb,1.200491e-01_rb,1.113571e-01_rb,1.038330e-01_rb,9.725657e-02_rb,&
+        & 9.145949e-02_rb,8.631112e-02_rb,8.170840e-02_rb,7.756901e-02_rb,7.382641e-02_rb,&
+        & 7.042616e-02_rb,6.732338e-02_rb,6.448069e-02_rb,6.186672e-02_rb,5.945494e-02_rb,&
+        & 5.722277e-02_rb,5.515089e-02_rb,5.322262e-02_rb,5.132153e-02_rb,4.969799e-02_rb,&
+        & 4.816556e-02_rb,4.671686e-02_rb,4.534525e-02_rb,4.404480e-02_rb,4.281014e-02_rb,&
+        & 4.163643e-02_rb,4.051930e-02_rb,3.945479e-02_rb,3.843927e-02_rb,3.746945e-02_rb,&
+        & 3.654234e-02_rb,3.565518e-02_rb,3.480547e-02_rb,3.399088e-02_rb,3.320930e-02_rb,&
+        & 3.245876e-02_rb,3.173745e-02_rb,3.104371e-02_rb,3.037600e-02_rb,2.973287e-02_rb,&
+        & 2.911300e-02_rb,2.851516e-02_rb,2.793818e-02_rb,2.738101e-02_rb,2.684264e-02_rb,&
+        & 2.632214e-02_rb,2.581863e-02_rb,2.5331e-02_rb /)
+      extliq1(:, 21) = (/ &
+        & 7.727642e-01_rb,5.034865e-01_rb,3.808673e-01_rb,3.080333e-01_rb,2.586453e-01_rb,&
+        & 2.224989e-01_rb,1.947060e-01_rb,1.725821e-01_rb,1.545096e-01_rb,1.394456e-01_rb,&
+        & 1.288683e-01_rb,1.188852e-01_rb,1.103317e-01_rb,1.029214e-01_rb,9.643967e-02_rb,&
+        & 9.072239e-02_rb,8.564194e-02_rb,8.109758e-02_rb,7.700875e-02_rb,7.331026e-02_rb,&
+        & 6.994879e-02_rb,6.688028e-02_rb,6.406807e-02_rb,6.148133e-02_rb,5.909400e-02_rb,&
+        & 5.688388e-02_rb,5.483197e-02_rb,5.292185e-02_rb,5.103763e-02_rb,4.942905e-02_rb,&
+        & 4.791039e-02_rb,4.647438e-02_rb,4.511453e-02_rb,4.382497e-02_rb,4.260043e-02_rb,&
+        & 4.143616e-02_rb,4.032784e-02_rb,3.927155e-02_rb,3.826375e-02_rb,3.730117e-02_rb,&
+        & 3.638087e-02_rb,3.550013e-02_rb,3.465646e-02_rb,3.384759e-02_rb,3.307141e-02_rb,&
+        & 3.232598e-02_rb,3.160953e-02_rb,3.092040e-02_rb,3.025706e-02_rb,2.961810e-02_rb,&
+        & 2.900220e-02_rb,2.840814e-02_rb,2.783478e-02_rb,2.728106e-02_rb,2.674599e-02_rb,&
+        & 2.622864e-02_rb,2.572816e-02_rb,2.5244e-02_rb /)
+      extliq1(:, 22) = (/ &
+        & 7.416833e-01_rb,4.959591e-01_rb,3.775057e-01_rb,3.056353e-01_rb,2.565943e-01_rb,&
+        & 2.206935e-01_rb,1.931479e-01_rb,1.712860e-01_rb,1.534837e-01_rb,1.386906e-01_rb,&
+        & 1.281198e-01_rb,1.182344e-01_rb,1.097595e-01_rb,1.024137e-01_rb,9.598552e-02_rb,&
+        & 9.031320e-02_rb,8.527093e-02_rb,8.075927e-02_rb,7.669869e-02_rb,7.302481e-02_rb,&
+        & 6.968491e-02_rb,6.663542e-02_rb,6.384008e-02_rb,6.126838e-02_rb,5.889452e-02_rb,&
+        & 5.669654e-02_rb,5.465558e-02_rb,5.275540e-02_rb,5.087937e-02_rb,4.927904e-02_rb,&
+        & 4.776796e-02_rb,4.633895e-02_rb,4.498557e-02_rb,4.370202e-02_rb,4.248306e-02_rb,&
+        & 4.132399e-02_rb,4.022052e-02_rb,3.916878e-02_rb,3.816523e-02_rb,3.720665e-02_rb,&
+        & 3.629011e-02_rb,3.541290e-02_rb,3.457257e-02_rb,3.376685e-02_rb,3.299365e-02_rb,&
+        & 3.225105e-02_rb,3.153728e-02_rb,3.085069e-02_rb,3.018977e-02_rb,2.955310e-02_rb,&
+        & 2.893940e-02_rb,2.834742e-02_rb,2.777606e-02_rb,2.722424e-02_rb,2.669099e-02_rb,&
+        & 2.617539e-02_rb,2.567658e-02_rb,2.5194e-02_rb /)
+      extliq1(:, 23) = (/ &
+        & 7.058580e-01_rb,4.866573e-01_rb,3.712238e-01_rb,2.998638e-01_rb,2.513441e-01_rb,&
+        & 2.161972e-01_rb,1.895576e-01_rb,1.686669e-01_rb,1.518437e-01_rb,1.380046e-01_rb,&
+        & 1.267564e-01_rb,1.170399e-01_rb,1.087026e-01_rb,1.014704e-01_rb,9.513729e-02_rb,&
+        & 8.954555e-02_rb,8.457221e-02_rb,8.012009e-02_rb,7.611136e-02_rb,7.248294e-02_rb,&
+        & 6.918317e-02_rb,6.616934e-02_rb,6.340584e-02_rb,6.086273e-02_rb,5.851465e-02_rb,&
+        & 5.634001e-02_rb,5.432027e-02_rb,5.243946e-02_rb,5.058070e-02_rb,4.899628e-02_rb,&
+        & 4.749975e-02_rb,4.608411e-02_rb,4.474303e-02_rb,4.347082e-02_rb,4.226237e-02_rb,&
+        & 4.111303e-02_rb,4.001861e-02_rb,3.897528e-02_rb,3.797959e-02_rb,3.702835e-02_rb,&
+        & 3.611867e-02_rb,3.524791e-02_rb,3.441364e-02_rb,3.361360e-02_rb,3.284577e-02_rb,&
+        & 3.210823e-02_rb,3.139923e-02_rb,3.071716e-02_rb,3.006052e-02_rb,2.942791e-02_rb,&
+        & 2.881806e-02_rb,2.822974e-02_rb,2.766185e-02_rb,2.711335e-02_rb,2.658326e-02_rb,&
+        & 2.607066e-02_rb,2.557473e-02_rb,2.5095e-02_rb /)
+      extliq1(:, 24) = (/ &
+        & 6.822779e-01_rb,4.750373e-01_rb,3.634834e-01_rb,2.940726e-01_rb,2.468060e-01_rb,&
+        & 2.125768e-01_rb,1.866586e-01_rb,1.663588e-01_rb,1.500326e-01_rb,1.366192e-01_rb,&
+        & 1.253472e-01_rb,1.158052e-01_rb,1.076101e-01_rb,1.004954e-01_rb,9.426089e-02_rb,&
+        & 8.875268e-02_rb,8.385090e-02_rb,7.946063e-02_rb,7.550578e-02_rb,7.192466e-02_rb,&
+        & 6.866669e-02_rb,6.569001e-02_rb,6.295971e-02_rb,6.044642e-02_rb,5.812526e-02_rb,&
+        & 5.597500e-02_rb,5.397746e-02_rb,5.211690e-02_rb,5.027505e-02_rb,4.870703e-02_rb,&
+        & 4.722555e-02_rb,4.582373e-02_rb,4.449540e-02_rb,4.323497e-02_rb,4.203742e-02_rb,&
+        & 4.089821e-02_rb,3.981321e-02_rb,3.877867e-02_rb,3.779118e-02_rb,3.684762e-02_rb,&
+        & 3.594514e-02_rb,3.508114e-02_rb,3.425322e-02_rb,3.345917e-02_rb,3.269698e-02_rb,&
+        & 3.196477e-02_rb,3.126082e-02_rb,3.058352e-02_rb,2.993141e-02_rb,2.930310e-02_rb,&
+        & 2.869732e-02_rb,2.811289e-02_rb,2.754869e-02_rb,2.700371e-02_rb,2.647698e-02_rb,&
+        & 2.596760e-02_rb,2.547473e-02_rb,2.4998e-02_rb /)
+      extliq1(:, 25) = (/ &
+        & 6.666233e-01_rb,4.662044e-01_rb,3.579517e-01_rb,2.902984e-01_rb,2.440475e-01_rb,&
+        & 2.104431e-01_rb,1.849277e-01_rb,1.648970e-01_rb,1.487555e-01_rb,1.354714e-01_rb,&
+        & 1.244173e-01_rb,1.149913e-01_rb,1.068903e-01_rb,9.985323e-02_rb,9.368351e-02_rb,&
+        & 8.823009e-02_rb,8.337507e-02_rb,7.902511e-02_rb,7.510529e-02_rb,7.155482e-02_rb,&
+        & 6.832386e-02_rb,6.537113e-02_rb,6.266218e-02_rb,6.016802e-02_rb,5.786408e-02_rb,&
+        & 5.572939e-02_rb,5.374598e-02_rb,5.189830e-02_rb,5.006825e-02_rb,4.851081e-02_rb,&
+        & 4.703906e-02_rb,4.564623e-02_rb,4.432621e-02_rb,4.307349e-02_rb,4.188312e-02_rb,&
+        & 4.075060e-02_rb,3.967183e-02_rb,3.864313e-02_rb,3.766111e-02_rb,3.672269e-02_rb,&
+        & 3.582505e-02_rb,3.496559e-02_rb,3.414196e-02_rb,3.335198e-02_rb,3.259362e-02_rb,&
+        & 3.186505e-02_rb,3.116454e-02_rb,3.049052e-02_rb,2.984152e-02_rb,2.921617e-02_rb,&
+        & 2.861322e-02_rb,2.803148e-02_rb,2.746986e-02_rb,2.692733e-02_rb,2.640295e-02_rb,&
+        & 2.589582e-02_rb,2.540510e-02_rb,2.4930e-02_rb /)
+      extliq1(:, 26) = (/ &
+        & 6.535669e-01_rb,4.585865e-01_rb,3.529226e-01_rb,2.867245e-01_rb,2.413848e-01_rb,&
+        & 2.083956e-01_rb,1.833191e-01_rb,1.636150e-01_rb,1.477247e-01_rb,1.346392e-01_rb,&
+        & 1.236449e-01_rb,1.143095e-01_rb,1.062828e-01_rb,9.930773e-02_rb,9.319029e-02_rb,&
+        & 8.778150e-02_rb,8.296497e-02_rb,7.864847e-02_rb,7.475799e-02_rb,7.123343e-02_rb,&
+        & 6.802549e-02_rb,6.509332e-02_rb,6.240285e-02_rb,5.992538e-02_rb,5.763657e-02_rb,&
+        & 5.551566e-02_rb,5.354483e-02_rb,5.170870e-02_rb,4.988866e-02_rb,4.834061e-02_rb,&
+        & 4.687751e-02_rb,4.549264e-02_rb,4.417999e-02_rb,4.293410e-02_rb,4.175006e-02_rb,&
+        & 4.062344e-02_rb,3.955019e-02_rb,3.852663e-02_rb,3.754943e-02_rb,3.661553e-02_rb,&
+        & 3.572214e-02_rb,3.486669e-02_rb,3.404683e-02_rb,3.326040e-02_rb,3.250542e-02_rb,&
+        & 3.178003e-02_rb,3.108254e-02_rb,3.041139e-02_rb,2.976511e-02_rb,2.914235e-02_rb,&
+        & 2.854187e-02_rb,2.796247e-02_rb,2.740309e-02_rb,2.686271e-02_rb,2.634038e-02_rb,&
+        & 2.583520e-02_rb,2.534636e-02_rb,2.4873e-02_rb /)
+      extliq1(:, 27) = (/ &
+        & 6.448790e-01_rb,4.541425e-01_rb,3.503348e-01_rb,2.850494e-01_rb,2.401966e-01_rb,&
+        & 2.074811e-01_rb,1.825631e-01_rb,1.629515e-01_rb,1.471142e-01_rb,1.340574e-01_rb,&
+        & 1.231462e-01_rb,1.138628e-01_rb,1.058802e-01_rb,9.894286e-02_rb,9.285818e-02_rb,&
+        & 8.747802e-02_rb,8.268676e-02_rb,7.839271e-02_rb,7.452230e-02_rb,7.101580e-02_rb,&
+        & 6.782418e-02_rb,6.490685e-02_rb,6.222991e-02_rb,5.976484e-02_rb,5.748742e-02_rb,&
+        & 5.537703e-02_rb,5.341593e-02_rb,5.158883e-02_rb,4.977355e-02_rb,4.823172e-02_rb,&
+        & 4.677430e-02_rb,4.539465e-02_rb,4.408680e-02_rb,4.284533e-02_rb,4.166539e-02_rb,&
+        & 4.054257e-02_rb,3.947283e-02_rb,3.845256e-02_rb,3.747842e-02_rb,3.654737e-02_rb,&
+        & 3.565665e-02_rb,3.480370e-02_rb,3.398620e-02_rb,3.320198e-02_rb,3.244908e-02_rb,&
+        & 3.172566e-02_rb,3.103002e-02_rb,3.036062e-02_rb,2.971600e-02_rb,2.909482e-02_rb,&
+        & 2.849582e-02_rb,2.791785e-02_rb,2.735982e-02_rb,2.682072e-02_rb,2.629960e-02_rb,&
+        & 2.579559e-02_rb,2.530786e-02_rb,2.4836e-02_rb /)
+      extliq1(:, 28) = (/ &
+        & 6.422688e-01_rb,4.528453e-01_rb,3.497232e-01_rb,2.847724e-01_rb,2.400815e-01_rb,&
+        & 2.074403e-01_rb,1.825502e-01_rb,1.629415e-01_rb,1.470934e-01_rb,1.340183e-01_rb,&
+        & 1.230935e-01_rb,1.138049e-01_rb,1.058201e-01_rb,9.888245e-02_rb,9.279878e-02_rb,&
+        & 8.742053e-02_rb,8.263175e-02_rb,7.834058e-02_rb,7.447327e-02_rb,7.097000e-02_rb,&
+        & 6.778167e-02_rb,6.486765e-02_rb,6.219400e-02_rb,5.973215e-02_rb,5.745790e-02_rb,&
+        & 5.535059e-02_rb,5.339250e-02_rb,5.156831e-02_rb,4.975308e-02_rb,4.821235e-02_rb,&
+        & 4.675596e-02_rb,4.537727e-02_rb,4.407030e-02_rb,4.282968e-02_rb,4.165053e-02_rb,&
+        & 4.052845e-02_rb,3.945941e-02_rb,3.843980e-02_rb,3.746628e-02_rb,3.653583e-02_rb,&
+        & 3.564567e-02_rb,3.479326e-02_rb,3.397626e-02_rb,3.319253e-02_rb,3.244008e-02_rb,&
+        & 3.171711e-02_rb,3.102189e-02_rb,3.035289e-02_rb,2.970866e-02_rb,2.908784e-02_rb,&
+        & 2.848920e-02_rb,2.791156e-02_rb,2.735385e-02_rb,2.681507e-02_rb,2.629425e-02_rb,&
+        & 2.579053e-02_rb,2.530308e-02_rb,2.4831e-02_rb /)
+      extliq1(:, 29) = (/ &
+        & 4.614710e-01_rb,4.556116e-01_rb,4.056568e-01_rb,3.529833e-01_rb,3.060334e-01_rb,&
+        & 2.658127e-01_rb,2.316095e-01_rb,2.024325e-01_rb,1.773749e-01_rb,1.556867e-01_rb,&
+        & 1.455558e-01_rb,1.332882e-01_rb,1.229052e-01_rb,1.140067e-01_rb,1.062981e-01_rb,&
+        & 9.955703e-02_rb,9.361333e-02_rb,8.833420e-02_rb,8.361467e-02_rb,7.937071e-02_rb,&
+        & 7.553420e-02_rb,7.204942e-02_rb,6.887031e-02_rb,6.595851e-02_rb,6.328178e-02_rb,&
+        & 6.081286e-02_rb,5.852854e-02_rb,5.640892e-02_rb,5.431269e-02_rb,5.252561e-02_rb,&
+        & 5.084345e-02_rb,4.925727e-02_rb,4.775910e-02_rb,4.634182e-02_rb,4.499907e-02_rb,&
+        & 4.372512e-02_rb,4.251484e-02_rb,4.136357e-02_rb,4.026710e-02_rb,3.922162e-02_rb,&
+        & 3.822365e-02_rb,3.727004e-02_rb,3.635790e-02_rb,3.548457e-02_rb,3.464764e-02_rb,&
+        & 3.384488e-02_rb,3.307424e-02_rb,3.233384e-02_rb,3.162192e-02_rb,3.093688e-02_rb,&
+        & 3.027723e-02_rb,2.964158e-02_rb,2.902864e-02_rb,2.843722e-02_rb,2.786621e-02_rb,&
+        & 2.731457e-02_rb,2.678133e-02_rb,2.6266e-02_rb /)
+
+! Single scattering albedo     
+      ssaliq1(:, 16) = (/ &
+        & 8.143821e-01_rb,7.836739e-01_rb,7.550722e-01_rb,7.306269e-01_rb,7.105612e-01_rb,&
+        & 6.946649e-01_rb,6.825556e-01_rb,6.737762e-01_rb,6.678448e-01_rb,6.642830e-01_rb,&
+        & 6.679741e-01_rb,6.584607e-01_rb,6.505598e-01_rb,6.440951e-01_rb,6.388901e-01_rb,&
+        & 6.347689e-01_rb,6.315549e-01_rb,6.290718e-01_rb,6.271432e-01_rb,6.255928e-01_rb,&
+        & 6.242441e-01_rb,6.229207e-01_rb,6.214464e-01_rb,6.196445e-01_rb,6.173388e-01_rb,&
+        & 6.143527e-01_rb,6.105099e-01_rb,6.056339e-01_rb,6.108290e-01_rb,6.073939e-01_rb,&
+        & 6.043073e-01_rb,6.015473e-01_rb,5.990913e-01_rb,5.969173e-01_rb,5.950028e-01_rb,&
+        & 5.933257e-01_rb,5.918636e-01_rb,5.905944e-01_rb,5.894957e-01_rb,5.885453e-01_rb,&
+        & 5.877209e-01_rb,5.870003e-01_rb,5.863611e-01_rb,5.857811e-01_rb,5.852381e-01_rb,&
+        & 5.847098e-01_rb,5.841738e-01_rb,5.836081e-01_rb,5.829901e-01_rb,5.822979e-01_rb,&
+        & 5.815089e-01_rb,5.806011e-01_rb,5.795521e-01_rb,5.783396e-01_rb,5.769413e-01_rb,&
+        & 5.753351e-01_rb,5.734986e-01_rb,5.7141e-01_rb /)
+      ssaliq1(:, 17) = (/ &
+        & 8.165821e-01_rb,8.002015e-01_rb,7.816921e-01_rb,7.634131e-01_rb,7.463721e-01_rb,&
+        & 7.312469e-01_rb,7.185883e-01_rb,7.088975e-01_rb,7.026671e-01_rb,7.004020e-01_rb,&
+        & 7.042138e-01_rb,6.960930e-01_rb,6.894243e-01_rb,6.840459e-01_rb,6.797957e-01_rb,&
+        & 6.765119e-01_rb,6.740325e-01_rb,6.721955e-01_rb,6.708391e-01_rb,6.698013e-01_rb,&
+        & 6.689201e-01_rb,6.680339e-01_rb,6.669805e-01_rb,6.655982e-01_rb,6.637250e-01_rb,&
+        & 6.611992e-01_rb,6.578588e-01_rb,6.535420e-01_rb,6.584449e-01_rb,6.553992e-01_rb,&
+        & 6.526547e-01_rb,6.501917e-01_rb,6.479905e-01_rb,6.460313e-01_rb,6.442945e-01_rb,&
+        & 6.427605e-01_rb,6.414094e-01_rb,6.402217e-01_rb,6.391775e-01_rb,6.382573e-01_rb,&
+        & 6.374413e-01_rb,6.367099e-01_rb,6.360433e-01_rb,6.354218e-01_rb,6.348257e-01_rb,&
+        & 6.342355e-01_rb,6.336313e-01_rb,6.329935e-01_rb,6.323023e-01_rb,6.315383e-01_rb,&
+        & 6.306814e-01_rb,6.297122e-01_rb,6.286110e-01_rb,6.273579e-01_rb,6.259333e-01_rb,&
+        & 6.243176e-01_rb,6.224910e-01_rb,6.2043e-01_rb /)
+      ssaliq1(:, 18) = (/ &
+        & 9.900163e-01_rb,9.854307e-01_rb,9.797730e-01_rb,9.733113e-01_rb,9.664245e-01_rb,&
+        & 9.594976e-01_rb,9.529055e-01_rb,9.470112e-01_rb,9.421695e-01_rb,9.387304e-01_rb,&
+        & 9.344918e-01_rb,9.305302e-01_rb,9.267048e-01_rb,9.230072e-01_rb,9.194289e-01_rb,&
+        & 9.159616e-01_rb,9.125968e-01_rb,9.093260e-01_rb,9.061409e-01_rb,9.030330e-01_rb,&
+        & 8.999940e-01_rb,8.970154e-01_rb,8.940888e-01_rb,8.912058e-01_rb,8.883579e-01_rb,&
+        & 8.855368e-01_rb,8.827341e-01_rb,8.799413e-01_rb,8.777423e-01_rb,8.749566e-01_rb,&
+        & 8.722298e-01_rb,8.695605e-01_rb,8.669469e-01_rb,8.643875e-01_rb,8.618806e-01_rb,&
+        & 8.594246e-01_rb,8.570179e-01_rb,8.546589e-01_rb,8.523459e-01_rb,8.500773e-01_rb,&
+        & 8.478516e-01_rb,8.456670e-01_rb,8.435219e-01_rb,8.414148e-01_rb,8.393439e-01_rb,&
+        & 8.373078e-01_rb,8.353047e-01_rb,8.333330e-01_rb,8.313911e-01_rb,8.294774e-01_rb,&
+        & 8.275904e-01_rb,8.257282e-01_rb,8.238893e-01_rb,8.220721e-01_rb,8.202751e-01_rb,&
+        & 8.184965e-01_rb,8.167346e-01_rb,8.1499e-01_rb /)
+      ssaliq1(:, 19) = (/ &
+        & 9.999916e-01_rb,9.987396e-01_rb,9.966900e-01_rb,9.950738e-01_rb,9.937531e-01_rb,&
+        & 9.925912e-01_rb,9.914525e-01_rb,9.902018e-01_rb,9.887046e-01_rb,9.868263e-01_rb,&
+        & 9.849039e-01_rb,9.832372e-01_rb,9.815265e-01_rb,9.797770e-01_rb,9.779940e-01_rb,&
+        & 9.761827e-01_rb,9.743481e-01_rb,9.724955e-01_rb,9.706303e-01_rb,9.687575e-01_rb,&
+        & 9.668823e-01_rb,9.650100e-01_rb,9.631457e-01_rb,9.612947e-01_rb,9.594622e-01_rb,&
+        & 9.576534e-01_rb,9.558734e-01_rb,9.541275e-01_rb,9.522059e-01_rb,9.504258e-01_rb,&
+        & 9.486459e-01_rb,9.468676e-01_rb,9.450921e-01_rb,9.433208e-01_rb,9.415548e-01_rb,&
+        & 9.397955e-01_rb,9.380441e-01_rb,9.363022e-01_rb,9.345706e-01_rb,9.328510e-01_rb,&
+        & 9.311445e-01_rb,9.294524e-01_rb,9.277761e-01_rb,9.261167e-01_rb,9.244755e-01_rb,&
+        & 9.228540e-01_rb,9.212534e-01_rb,9.196748e-01_rb,9.181197e-01_rb,9.165894e-01_rb,&
+        & 9.150851e-01_rb,9.136080e-01_rb,9.121596e-01_rb,9.107410e-01_rb,9.093536e-01_rb,&
+        & 9.079987e-01_rb,9.066775e-01_rb,9.0539e-01_rb /)
+      ssaliq1(:, 20) = (/ &
+        & 9.979493e-01_rb,9.964113e-01_rb,9.950014e-01_rb,9.937045e-01_rb,9.924964e-01_rb,&
+        & 9.913546e-01_rb,9.902575e-01_rb,9.891843e-01_rb,9.881136e-01_rb,9.870238e-01_rb,&
+        & 9.859934e-01_rb,9.849372e-01_rb,9.838873e-01_rb,9.828434e-01_rb,9.818052e-01_rb,&
+        & 9.807725e-01_rb,9.797450e-01_rb,9.787225e-01_rb,9.777047e-01_rb,9.766914e-01_rb,&
+        & 9.756823e-01_rb,9.746771e-01_rb,9.736756e-01_rb,9.726775e-01_rb,9.716827e-01_rb,&
+        & 9.706907e-01_rb,9.697014e-01_rb,9.687145e-01_rb,9.678060e-01_rb,9.668108e-01_rb,&
+        & 9.658218e-01_rb,9.648391e-01_rb,9.638629e-01_rb,9.628936e-01_rb,9.619313e-01_rb,&
+        & 9.609763e-01_rb,9.600287e-01_rb,9.590888e-01_rb,9.581569e-01_rb,9.572330e-01_rb,&
+        & 9.563176e-01_rb,9.554108e-01_rb,9.545128e-01_rb,9.536239e-01_rb,9.527443e-01_rb,&
+        & 9.518741e-01_rb,9.510137e-01_rb,9.501633e-01_rb,9.493230e-01_rb,9.484931e-01_rb,&
+        & 9.476740e-01_rb,9.468656e-01_rb,9.460683e-01_rb,9.452824e-01_rb,9.445080e-01_rb,&
+        & 9.437454e-01_rb,9.429948e-01_rb,9.4226e-01_rb /)
+      ssaliq1(:, 21) = (/ &
+        & 9.988742e-01_rb,9.982668e-01_rb,9.976935e-01_rb,9.971497e-01_rb,9.966314e-01_rb,&
+        & 9.961344e-01_rb,9.956545e-01_rb,9.951873e-01_rb,9.947286e-01_rb,9.942741e-01_rb,&
+        & 9.938457e-01_rb,9.933947e-01_rb,9.929473e-01_rb,9.925032e-01_rb,9.920621e-01_rb,&
+        & 9.916237e-01_rb,9.911875e-01_rb,9.907534e-01_rb,9.903209e-01_rb,9.898898e-01_rb,&
+        & 9.894597e-01_rb,9.890304e-01_rb,9.886015e-01_rb,9.881726e-01_rb,9.877435e-01_rb,&
+        & 9.873138e-01_rb,9.868833e-01_rb,9.864516e-01_rb,9.860698e-01_rb,9.856317e-01_rb,&
+        & 9.851957e-01_rb,9.847618e-01_rb,9.843302e-01_rb,9.839008e-01_rb,9.834739e-01_rb,&
+        & 9.830494e-01_rb,9.826275e-01_rb,9.822083e-01_rb,9.817918e-01_rb,9.813782e-01_rb,&
+        & 9.809675e-01_rb,9.805598e-01_rb,9.801552e-01_rb,9.797538e-01_rb,9.793556e-01_rb,&
+        & 9.789608e-01_rb,9.785695e-01_rb,9.781817e-01_rb,9.777975e-01_rb,9.774171e-01_rb,&
+        & 9.770404e-01_rb,9.766676e-01_rb,9.762988e-01_rb,9.759340e-01_rb,9.755733e-01_rb,&
+        & 9.752169e-01_rb,9.748649e-01_rb,9.7452e-01_rb /)
+      ssaliq1(:, 22) = (/ &
+        & 9.994441e-01_rb,9.991608e-01_rb,9.988949e-01_rb,9.986439e-01_rb,9.984054e-01_rb,&
+        & 9.981768e-01_rb,9.979557e-01_rb,9.977396e-01_rb,9.975258e-01_rb,9.973120e-01_rb,&
+        & 9.971011e-01_rb,9.968852e-01_rb,9.966708e-01_rb,9.964578e-01_rb,9.962462e-01_rb,&
+        & 9.960357e-01_rb,9.958264e-01_rb,9.956181e-01_rb,9.954108e-01_rb,9.952043e-01_rb,&
+        & 9.949987e-01_rb,9.947937e-01_rb,9.945892e-01_rb,9.943853e-01_rb,9.941818e-01_rb,&
+        & 9.939786e-01_rb,9.937757e-01_rb,9.935728e-01_rb,9.933922e-01_rb,9.931825e-01_rb,&
+        & 9.929739e-01_rb,9.927661e-01_rb,9.925592e-01_rb,9.923534e-01_rb,9.921485e-01_rb,&
+        & 9.919447e-01_rb,9.917421e-01_rb,9.915406e-01_rb,9.913403e-01_rb,9.911412e-01_rb,&
+        & 9.909435e-01_rb,9.907470e-01_rb,9.905519e-01_rb,9.903581e-01_rb,9.901659e-01_rb,&
+        & 9.899751e-01_rb,9.897858e-01_rb,9.895981e-01_rb,9.894120e-01_rb,9.892276e-01_rb,&
+        & 9.890447e-01_rb,9.888637e-01_rb,9.886845e-01_rb,9.885070e-01_rb,9.883314e-01_rb,&
+        & 9.881576e-01_rb,9.879859e-01_rb,9.8782e-01_rb /)
+      ssaliq1(:, 23) = (/ &
+        & 9.999138e-01_rb,9.998730e-01_rb,9.998338e-01_rb,9.997965e-01_rb,9.997609e-01_rb,&
+        & 9.997270e-01_rb,9.996944e-01_rb,9.996629e-01_rb,9.996321e-01_rb,9.996016e-01_rb,&
+        & 9.995690e-01_rb,9.995372e-01_rb,9.995057e-01_rb,9.994744e-01_rb,9.994433e-01_rb,&
+        & 9.994124e-01_rb,9.993817e-01_rb,9.993510e-01_rb,9.993206e-01_rb,9.992903e-01_rb,&
+        & 9.992600e-01_rb,9.992299e-01_rb,9.991998e-01_rb,9.991698e-01_rb,9.991398e-01_rb,&
+        & 9.991098e-01_rb,9.990799e-01_rb,9.990499e-01_rb,9.990231e-01_rb,9.989920e-01_rb,&
+        & 9.989611e-01_rb,9.989302e-01_rb,9.988996e-01_rb,9.988690e-01_rb,9.988386e-01_rb,&
+        & 9.988084e-01_rb,9.987783e-01_rb,9.987485e-01_rb,9.987187e-01_rb,9.986891e-01_rb,&
+        & 9.986598e-01_rb,9.986306e-01_rb,9.986017e-01_rb,9.985729e-01_rb,9.985443e-01_rb,&
+        & 9.985160e-01_rb,9.984879e-01_rb,9.984600e-01_rb,9.984324e-01_rb,9.984050e-01_rb,&
+        & 9.983778e-01_rb,9.983509e-01_rb,9.983243e-01_rb,9.982980e-01_rb,9.982719e-01_rb,&
+        & 9.982461e-01_rb,9.982206e-01_rb,9.9820e-01_rb /)
+      ssaliq1(:, 24) = (/ &
+        & 9.999985e-01_rb,9.999979e-01_rb,9.999972e-01_rb,9.999966e-01_rb,9.999961e-01_rb,&
+        & 9.999955e-01_rb,9.999950e-01_rb,9.999944e-01_rb,9.999938e-01_rb,9.999933e-01_rb,&
+        & 9.999927e-01_rb,9.999921e-01_rb,9.999915e-01_rb,9.999910e-01_rb,9.999904e-01_rb,&
+        & 9.999899e-01_rb,9.999893e-01_rb,9.999888e-01_rb,9.999882e-01_rb,9.999877e-01_rb,&
+        & 9.999871e-01_rb,9.999866e-01_rb,9.999861e-01_rb,9.999855e-01_rb,9.999850e-01_rb,&
+        & 9.999844e-01_rb,9.999839e-01_rb,9.999833e-01_rb,9.999828e-01_rb,9.999823e-01_rb,&
+        & 9.999817e-01_rb,9.999812e-01_rb,9.999807e-01_rb,9.999801e-01_rb,9.999796e-01_rb,&
+        & 9.999791e-01_rb,9.999786e-01_rb,9.999781e-01_rb,9.999776e-01_rb,9.999770e-01_rb,&
+        & 9.999765e-01_rb,9.999761e-01_rb,9.999756e-01_rb,9.999751e-01_rb,9.999746e-01_rb,&
+        & 9.999741e-01_rb,9.999736e-01_rb,9.999732e-01_rb,9.999727e-01_rb,9.999722e-01_rb,&
+        & 9.999718e-01_rb,9.999713e-01_rb,9.999709e-01_rb,9.999705e-01_rb,9.999701e-01_rb,&
+        & 9.999697e-01_rb,9.999692e-01_rb,9.9997e-01_rb /)
+      ssaliq1(:, 25) = (/ &
+        & 9.999999e-01_rb,9.999998e-01_rb,9.999997e-01_rb,9.999997e-01_rb,9.999997e-01_rb,&
+        & 9.999996e-01_rb,9.999996e-01_rb,9.999995e-01_rb,9.999995e-01_rb,9.999994e-01_rb,&
+        & 9.999994e-01_rb,9.999993e-01_rb,9.999993e-01_rb,9.999992e-01_rb,9.999992e-01_rb,&
+        & 9.999991e-01_rb,9.999991e-01_rb,9.999991e-01_rb,9.999990e-01_rb,9.999989e-01_rb,&
+        & 9.999989e-01_rb,9.999989e-01_rb,9.999988e-01_rb,9.999988e-01_rb,9.999987e-01_rb,&
+        & 9.999987e-01_rb,9.999986e-01_rb,9.999986e-01_rb,9.999985e-01_rb,9.999985e-01_rb,&
+        & 9.999984e-01_rb,9.999984e-01_rb,9.999984e-01_rb,9.999983e-01_rb,9.999983e-01_rb,&
+        & 9.999982e-01_rb,9.999982e-01_rb,9.999982e-01_rb,9.999981e-01_rb,9.999980e-01_rb,&
+        & 9.999980e-01_rb,9.999980e-01_rb,9.999979e-01_rb,9.999979e-01_rb,9.999978e-01_rb,&
+        & 9.999978e-01_rb,9.999977e-01_rb,9.999977e-01_rb,9.999977e-01_rb,9.999976e-01_rb,&
+        & 9.999976e-01_rb,9.999975e-01_rb,9.999975e-01_rb,9.999974e-01_rb,9.999974e-01_rb,&
+        & 9.999974e-01_rb,9.999973e-01_rb,1.0000e+00_rb /)
+      ssaliq1(:, 26) = (/ &
+        & 9.999997e-01_rb,9.999995e-01_rb,9.999993e-01_rb,9.999992e-01_rb,9.999990e-01_rb,&
+        & 9.999989e-01_rb,9.999988e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999985e-01_rb,&
+        & 9.999984e-01_rb,9.999983e-01_rb,9.999982e-01_rb,9.999981e-01_rb,9.999980e-01_rb,&
+        & 9.999978e-01_rb,9.999977e-01_rb,9.999976e-01_rb,9.999975e-01_rb,9.999974e-01_rb,&
+        & 9.999973e-01_rb,9.999972e-01_rb,9.999970e-01_rb,9.999969e-01_rb,9.999968e-01_rb,&
+        & 9.999967e-01_rb,9.999966e-01_rb,9.999965e-01_rb,9.999964e-01_rb,9.999963e-01_rb,&
+        & 9.999962e-01_rb,9.999961e-01_rb,9.999959e-01_rb,9.999958e-01_rb,9.999957e-01_rb,&
+        & 9.999956e-01_rb,9.999955e-01_rb,9.999954e-01_rb,9.999953e-01_rb,9.999952e-01_rb,&
+        & 9.999951e-01_rb,9.999949e-01_rb,9.999949e-01_rb,9.999947e-01_rb,9.999946e-01_rb,&
+        & 9.999945e-01_rb,9.999944e-01_rb,9.999943e-01_rb,9.999942e-01_rb,9.999941e-01_rb,&
+        & 9.999940e-01_rb,9.999939e-01_rb,9.999938e-01_rb,9.999937e-01_rb,9.999936e-01_rb,&
+        & 9.999935e-01_rb,9.999934e-01_rb,9.9999e-01_rb /)
+      ssaliq1(:, 27) = (/ &
+        & 9.999984e-01_rb,9.999976e-01_rb,9.999969e-01_rb,9.999962e-01_rb,9.999956e-01_rb,&
+        & 9.999950e-01_rb,9.999945e-01_rb,9.999940e-01_rb,9.999935e-01_rb,9.999931e-01_rb,&
+        & 9.999926e-01_rb,9.999920e-01_rb,9.999914e-01_rb,9.999908e-01_rb,9.999903e-01_rb,&
+        & 9.999897e-01_rb,9.999891e-01_rb,9.999886e-01_rb,9.999880e-01_rb,9.999874e-01_rb,&
+        & 9.999868e-01_rb,9.999863e-01_rb,9.999857e-01_rb,9.999851e-01_rb,9.999846e-01_rb,&
+        & 9.999840e-01_rb,9.999835e-01_rb,9.999829e-01_rb,9.999824e-01_rb,9.999818e-01_rb,&
+        & 9.999812e-01_rb,9.999806e-01_rb,9.999800e-01_rb,9.999795e-01_rb,9.999789e-01_rb,&
+        & 9.999783e-01_rb,9.999778e-01_rb,9.999773e-01_rb,9.999767e-01_rb,9.999761e-01_rb,&
+        & 9.999756e-01_rb,9.999750e-01_rb,9.999745e-01_rb,9.999739e-01_rb,9.999734e-01_rb,&
+        & 9.999729e-01_rb,9.999723e-01_rb,9.999718e-01_rb,9.999713e-01_rb,9.999708e-01_rb,&
+        & 9.999703e-01_rb,9.999697e-01_rb,9.999692e-01_rb,9.999687e-01_rb,9.999683e-01_rb,&
+        & 9.999678e-01_rb,9.999673e-01_rb,9.9997e-01_rb /)
+      ssaliq1(:, 28) = (/ &
+        & 9.999981e-01_rb,9.999973e-01_rb,9.999965e-01_rb,9.999958e-01_rb,9.999951e-01_rb,&
+        & 9.999943e-01_rb,9.999937e-01_rb,9.999930e-01_rb,9.999924e-01_rb,9.999918e-01_rb,&
+        & 9.999912e-01_rb,9.999905e-01_rb,9.999897e-01_rb,9.999890e-01_rb,9.999883e-01_rb,&
+        & 9.999876e-01_rb,9.999869e-01_rb,9.999862e-01_rb,9.999855e-01_rb,9.999847e-01_rb,&
+        & 9.999840e-01_rb,9.999834e-01_rb,9.999827e-01_rb,9.999819e-01_rb,9.999812e-01_rb,&
+        & 9.999805e-01_rb,9.999799e-01_rb,9.999791e-01_rb,9.999785e-01_rb,9.999778e-01_rb,&
+        & 9.999771e-01_rb,9.999764e-01_rb,9.999757e-01_rb,9.999750e-01_rb,9.999743e-01_rb,&
+        & 9.999736e-01_rb,9.999729e-01_rb,9.999722e-01_rb,9.999715e-01_rb,9.999709e-01_rb,&
+        & 9.999701e-01_rb,9.999695e-01_rb,9.999688e-01_rb,9.999682e-01_rb,9.999675e-01_rb,&
+        & 9.999669e-01_rb,9.999662e-01_rb,9.999655e-01_rb,9.999649e-01_rb,9.999642e-01_rb,&
+        & 9.999636e-01_rb,9.999630e-01_rb,9.999624e-01_rb,9.999618e-01_rb,9.999612e-01_rb,&
+        & 9.999606e-01_rb,9.999600e-01_rb,9.9996e-01_rb /)
+      ssaliq1(:, 29) = (/ &
+        & 8.505737e-01_rb,8.465102e-01_rb,8.394829e-01_rb,8.279508e-01_rb,8.110806e-01_rb,&
+        & 7.900397e-01_rb,7.669615e-01_rb,7.444422e-01_rb,7.253055e-01_rb,7.124831e-01_rb,&
+        & 7.016434e-01_rb,6.885485e-01_rb,6.767340e-01_rb,6.661029e-01_rb,6.565577e-01_rb,&
+        & 6.480013e-01_rb,6.403373e-01_rb,6.334697e-01_rb,6.273034e-01_rb,6.217440e-01_rb,&
+        & 6.166983e-01_rb,6.120740e-01_rb,6.077796e-01_rb,6.037249e-01_rb,5.998207e-01_rb,&
+        & 5.959788e-01_rb,5.921123e-01_rb,5.881354e-01_rb,5.891285e-01_rb,5.851143e-01_rb,&
+        & 5.814653e-01_rb,5.781606e-01_rb,5.751792e-01_rb,5.724998e-01_rb,5.701016e-01_rb,&
+        & 5.679634e-01_rb,5.660642e-01_rb,5.643829e-01_rb,5.628984e-01_rb,5.615898e-01_rb,&
+        & 5.604359e-01_rb,5.594158e-01_rb,5.585083e-01_rb,5.576924e-01_rb,5.569470e-01_rb,&
+        & 5.562512e-01_rb,5.555838e-01_rb,5.549239e-01_rb,5.542503e-01_rb,5.535420e-01_rb,&
+        & 5.527781e-01_rb,5.519374e-01_rb,5.509989e-01_rb,5.499417e-01_rb,5.487445e-01_rb,&
+        & 5.473865e-01_rb,5.458466e-01_rb,5.4410e-01_rb /)
+
+! asymmetry parameter
+      asyliq1(:, 16) = (/ &
+        & 8.133297e-01_rb,8.133528e-01_rb,8.173865e-01_rb,8.243205e-01_rb,8.333063e-01_rb,&
+        & 8.436317e-01_rb,8.546611e-01_rb,8.657934e-01_rb,8.764345e-01_rb,8.859837e-01_rb,&
+        & 8.627394e-01_rb,8.824569e-01_rb,8.976887e-01_rb,9.089541e-01_rb,9.167699e-01_rb,&
+        & 9.216517e-01_rb,9.241147e-01_rb,9.246743e-01_rb,9.238469e-01_rb,9.221504e-01_rb,&
+        & 9.201045e-01_rb,9.182299e-01_rb,9.170491e-01_rb,9.170862e-01_rb,9.188653e-01_rb,&
+        & 9.229111e-01_rb,9.297468e-01_rb,9.398950e-01_rb,9.203269e-01_rb,9.260693e-01_rb,&
+        & 9.309373e-01_rb,9.349918e-01_rb,9.382935e-01_rb,9.409030e-01_rb,9.428809e-01_rb,&
+        & 9.442881e-01_rb,9.451851e-01_rb,9.456331e-01_rb,9.456926e-01_rb,9.454247e-01_rb,&
+        & 9.448902e-01_rb,9.441503e-01_rb,9.432661e-01_rb,9.422987e-01_rb,9.413094e-01_rb,&
+        & 9.403594e-01_rb,9.395102e-01_rb,9.388230e-01_rb,9.383594e-01_rb,9.381810e-01_rb,&
+        & 9.383489e-01_rb,9.389251e-01_rb,9.399707e-01_rb,9.415475e-01_rb,9.437167e-01_rb,&
+        & 9.465399e-01_rb,9.500786e-01_rb,9.5439e-01_rb /)
+      asyliq1(:, 17) = (/ &
+        & 8.794448e-01_rb,8.819306e-01_rb,8.837667e-01_rb,8.853832e-01_rb,8.871010e-01_rb,&
+        & 8.892675e-01_rb,8.922584e-01_rb,8.964666e-01_rb,9.022940e-01_rb,9.101456e-01_rb,&
+        & 8.839999e-01_rb,9.035610e-01_rb,9.184568e-01_rb,9.292315e-01_rb,9.364282e-01_rb,&
+        & 9.405887e-01_rb,9.422554e-01_rb,9.419703e-01_rb,9.402759e-01_rb,9.377159e-01_rb,&
+        & 9.348345e-01_rb,9.321769e-01_rb,9.302888e-01_rb,9.297166e-01_rb,9.310075e-01_rb,&
+        & 9.347080e-01_rb,9.413643e-01_rb,9.515216e-01_rb,9.306286e-01_rb,9.361781e-01_rb,&
+        & 9.408374e-01_rb,9.446692e-01_rb,9.477363e-01_rb,9.501013e-01_rb,9.518268e-01_rb,&
+        & 9.529756e-01_rb,9.536105e-01_rb,9.537938e-01_rb,9.535886e-01_rb,9.530574e-01_rb,&
+        & 9.522633e-01_rb,9.512688e-01_rb,9.501370e-01_rb,9.489306e-01_rb,9.477126e-01_rb,&
+        & 9.465459e-01_rb,9.454934e-01_rb,9.446183e-01_rb,9.439833e-01_rb,9.436519e-01_rb,&
+        & 9.436866e-01_rb,9.441508e-01_rb,9.451073e-01_rb,9.466195e-01_rb,9.487501e-01_rb,&
+        & 9.515621e-01_rb,9.551185e-01_rb,9.5948e-01_rb /)
+      asyliq1(:, 18) = (/ &
+        & 8.478817e-01_rb,8.269312e-01_rb,8.161352e-01_rb,8.135960e-01_rb,8.173586e-01_rb,&
+        & 8.254167e-01_rb,8.357072e-01_rb,8.461167e-01_rb,8.544952e-01_rb,8.586776e-01_rb,&
+        & 8.335562e-01_rb,8.524273e-01_rb,8.669052e-01_rb,8.775014e-01_rb,8.847277e-01_rb,&
+        & 8.890958e-01_rb,8.911173e-01_rb,8.913038e-01_rb,8.901669e-01_rb,8.882182e-01_rb,&
+        & 8.859692e-01_rb,8.839315e-01_rb,8.826164e-01_rb,8.825356e-01_rb,8.842004e-01_rb,&
+        & 8.881223e-01_rb,8.948131e-01_rb,9.047837e-01_rb,8.855951e-01_rb,8.911796e-01_rb,&
+        & 8.959229e-01_rb,8.998837e-01_rb,9.031209e-01_rb,9.056939e-01_rb,9.076609e-01_rb,&
+        & 9.090812e-01_rb,9.100134e-01_rb,9.105167e-01_rb,9.106496e-01_rb,9.104712e-01_rb,&
+        & 9.100404e-01_rb,9.094159e-01_rb,9.086568e-01_rb,9.078218e-01_rb,9.069697e-01_rb,&
+        & 9.061595e-01_rb,9.054499e-01_rb,9.048999e-01_rb,9.045683e-01_rb,9.045142e-01_rb,&
+        & 9.047962e-01_rb,9.054730e-01_rb,9.066037e-01_rb,9.082472e-01_rb,9.104623e-01_rb,&
+        & 9.133079e-01_rb,9.168427e-01_rb,9.2113e-01_rb /)
+      asyliq1(:, 19) = (/ &
+        & 8.216697e-01_rb,7.982871e-01_rb,7.891147e-01_rb,7.909083e-01_rb,8.003833e-01_rb,&
+        & 8.142516e-01_rb,8.292290e-01_rb,8.420356e-01_rb,8.493945e-01_rb,8.480316e-01_rb,&
+        & 8.212381e-01_rb,8.394984e-01_rb,8.534095e-01_rb,8.634813e-01_rb,8.702242e-01_rb,&
+        & 8.741483e-01_rb,8.757638e-01_rb,8.755808e-01_rb,8.741095e-01_rb,8.718604e-01_rb,&
+        & 8.693433e-01_rb,8.670686e-01_rb,8.655464e-01_rb,8.652872e-01_rb,8.668006e-01_rb,&
+        & 8.705973e-01_rb,8.771874e-01_rb,8.870809e-01_rb,8.678284e-01_rb,8.732315e-01_rb,&
+        & 8.778084e-01_rb,8.816166e-01_rb,8.847146e-01_rb,8.871603e-01_rb,8.890116e-01_rb,&
+        & 8.903266e-01_rb,8.911632e-01_rb,8.915796e-01_rb,8.916337e-01_rb,8.913834e-01_rb,&
+        & 8.908869e-01_rb,8.902022e-01_rb,8.893873e-01_rb,8.885001e-01_rb,8.875986e-01_rb,&
+        & 8.867411e-01_rb,8.859852e-01_rb,8.853891e-01_rb,8.850111e-01_rb,8.849089e-01_rb,&
+        & 8.851405e-01_rb,8.857639e-01_rb,8.868372e-01_rb,8.884185e-01_rb,8.905656e-01_rb,&
+        & 8.933368e-01_rb,8.967899e-01_rb,9.0098e-01_rb /)
+      asyliq1(:, 20) = (/ &
+        & 8.063610e-01_rb,7.938147e-01_rb,7.921304e-01_rb,7.985092e-01_rb,8.101339e-01_rb,&
+        & 8.242175e-01_rb,8.379913e-01_rb,8.486920e-01_rb,8.535547e-01_rb,8.498083e-01_rb,&
+        & 8.224849e-01_rb,8.405509e-01_rb,8.542436e-01_rb,8.640770e-01_rb,8.705653e-01_rb,&
+        & 8.742227e-01_rb,8.755630e-01_rb,8.751004e-01_rb,8.733491e-01_rb,8.708231e-01_rb,&
+        & 8.680365e-01_rb,8.655035e-01_rb,8.637381e-01_rb,8.632544e-01_rb,8.645665e-01_rb,&
+        & 8.681885e-01_rb,8.746346e-01_rb,8.844188e-01_rb,8.648180e-01_rb,8.700563e-01_rb,&
+        & 8.744672e-01_rb,8.781087e-01_rb,8.810393e-01_rb,8.833174e-01_rb,8.850011e-01_rb,&
+        & 8.861485e-01_rb,8.868183e-01_rb,8.870687e-01_rb,8.869579e-01_rb,8.865441e-01_rb,&
+        & 8.858857e-01_rb,8.850412e-01_rb,8.840686e-01_rb,8.830263e-01_rb,8.819726e-01_rb,&
+        & 8.809658e-01_rb,8.800642e-01_rb,8.793260e-01_rb,8.788099e-01_rb,8.785737e-01_rb,&
+        & 8.786758e-01_rb,8.791746e-01_rb,8.801283e-01_rb,8.815955e-01_rb,8.836340e-01_rb,&
+        & 8.863024e-01_rb,8.896592e-01_rb,8.9376e-01_rb /)
+      asyliq1(:, 21) = (/ &
+        & 7.885899e-01_rb,7.937172e-01_rb,8.020658e-01_rb,8.123971e-01_rb,8.235502e-01_rb,&
+        & 8.343776e-01_rb,8.437336e-01_rb,8.504711e-01_rb,8.534421e-01_rb,8.514978e-01_rb,&
+        & 8.238888e-01_rb,8.417463e-01_rb,8.552057e-01_rb,8.647853e-01_rb,8.710038e-01_rb,&
+        & 8.743798e-01_rb,8.754319e-01_rb,8.746786e-01_rb,8.726386e-01_rb,8.698303e-01_rb,&
+        & 8.667724e-01_rb,8.639836e-01_rb,8.619823e-01_rb,8.612870e-01_rb,8.624165e-01_rb,&
+        & 8.658893e-01_rb,8.722241e-01_rb,8.819394e-01_rb,8.620216e-01_rb,8.671239e-01_rb,&
+        & 8.713983e-01_rb,8.749032e-01_rb,8.776970e-01_rb,8.798385e-01_rb,8.813860e-01_rb,&
+        & 8.823980e-01_rb,8.829332e-01_rb,8.830500e-01_rb,8.828068e-01_rb,8.822623e-01_rb,&
+        & 8.814750e-01_rb,8.805031e-01_rb,8.794056e-01_rb,8.782407e-01_rb,8.770672e-01_rb,&
+        & 8.759432e-01_rb,8.749275e-01_rb,8.740784e-01_rb,8.734547e-01_rb,8.731146e-01_rb,&
+        & 8.731170e-01_rb,8.735199e-01_rb,8.743823e-01_rb,8.757625e-01_rb,8.777191e-01_rb,&
+        & 8.803105e-01_rb,8.835953e-01_rb,8.8763e-01_rb /)
+      asyliq1(:, 22) = (/ &
+        & 7.811516e-01_rb,7.962229e-01_rb,8.096199e-01_rb,8.212996e-01_rb,8.312212e-01_rb,&
+        & 8.393430e-01_rb,8.456236e-01_rb,8.500214e-01_rb,8.524950e-01_rb,8.530031e-01_rb,&
+        & 8.251485e-01_rb,8.429043e-01_rb,8.562461e-01_rb,8.656954e-01_rb,8.717737e-01_rb,&
+        & 8.750020e-01_rb,8.759022e-01_rb,8.749953e-01_rb,8.728027e-01_rb,8.698461e-01_rb,&
+        & 8.666466e-01_rb,8.637257e-01_rb,8.616047e-01_rb,8.608051e-01_rb,8.618483e-01_rb,&
+        & 8.652557e-01_rb,8.715487e-01_rb,8.812485e-01_rb,8.611645e-01_rb,8.662052e-01_rb,&
+        & 8.704173e-01_rb,8.738594e-01_rb,8.765901e-01_rb,8.786678e-01_rb,8.801517e-01_rb,&
+        & 8.810999e-01_rb,8.815713e-01_rb,8.816246e-01_rb,8.813185e-01_rb,8.807114e-01_rb,&
+        & 8.798621e-01_rb,8.788290e-01_rb,8.776713e-01_rb,8.764470e-01_rb,8.752152e-01_rb,&
+        & 8.740343e-01_rb,8.729631e-01_rb,8.720602e-01_rb,8.713842e-01_rb,8.709936e-01_rb,&
+        & 8.709475e-01_rb,8.713041e-01_rb,8.721221e-01_rb,8.734602e-01_rb,8.753774e-01_rb,&
+        & 8.779319e-01_rb,8.811825e-01_rb,8.8519e-01_rb /)
+      asyliq1(:, 23) = (/ &
+        & 7.865744e-01_rb,8.093340e-01_rb,8.257596e-01_rb,8.369940e-01_rb,8.441574e-01_rb,&
+        & 8.483602e-01_rb,8.507096e-01_rb,8.523139e-01_rb,8.542834e-01_rb,8.577321e-01_rb,&
+        & 8.288960e-01_rb,8.465308e-01_rb,8.597175e-01_rb,8.689830e-01_rb,8.748542e-01_rb,&
+        & 8.778584e-01_rb,8.785222e-01_rb,8.773728e-01_rb,8.749370e-01_rb,8.717419e-01_rb,&
+        & 8.683145e-01_rb,8.651816e-01_rb,8.628704e-01_rb,8.619077e-01_rb,8.628205e-01_rb,&
+        & 8.661356e-01_rb,8.723803e-01_rb,8.820815e-01_rb,8.616715e-01_rb,8.666389e-01_rb,&
+        & 8.707753e-01_rb,8.741398e-01_rb,8.767912e-01_rb,8.787885e-01_rb,8.801908e-01_rb,&
+        & 8.810570e-01_rb,8.814460e-01_rb,8.814167e-01_rb,8.810283e-01_rb,8.803395e-01_rb,&
+        & 8.794095e-01_rb,8.782971e-01_rb,8.770613e-01_rb,8.757610e-01_rb,8.744553e-01_rb,&
+        & 8.732031e-01_rb,8.720634e-01_rb,8.710951e-01_rb,8.703572e-01_rb,8.699086e-01_rb,&
+        & 8.698084e-01_rb,8.701155e-01_rb,8.708887e-01_rb,8.721872e-01_rb,8.740698e-01_rb,&
+        & 8.765957e-01_rb,8.798235e-01_rb,8.8381e-01_rb /)
+      asyliq1(:, 24) = (/ &
+        & 8.069513e-01_rb,8.262939e-01_rb,8.398241e-01_rb,8.486352e-01_rb,8.538213e-01_rb,&
+        & 8.564743e-01_rb,8.576854e-01_rb,8.585455e-01_rb,8.601452e-01_rb,8.635755e-01_rb,&
+        & 8.337383e-01_rb,8.512655e-01_rb,8.643049e-01_rb,8.733896e-01_rb,8.790535e-01_rb,&
+        & 8.818295e-01_rb,8.822518e-01_rb,8.808533e-01_rb,8.781676e-01_rb,8.747284e-01_rb,&
+        & 8.710690e-01_rb,8.677229e-01_rb,8.652236e-01_rb,8.641047e-01_rb,8.648993e-01_rb,&
+        & 8.681413e-01_rb,8.743640e-01_rb,8.841007e-01_rb,8.633558e-01_rb,8.682719e-01_rb,&
+        & 8.723543e-01_rb,8.756621e-01_rb,8.782547e-01_rb,8.801915e-01_rb,8.815318e-01_rb,&
+        & 8.823347e-01_rb,8.826598e-01_rb,8.825663e-01_rb,8.821135e-01_rb,8.813608e-01_rb,&
+        & 8.803674e-01_rb,8.791928e-01_rb,8.778960e-01_rb,8.765366e-01_rb,8.751738e-01_rb,&
+        & 8.738670e-01_rb,8.726755e-01_rb,8.716585e-01_rb,8.708755e-01_rb,8.703856e-01_rb,&
+        & 8.702483e-01_rb,8.705229e-01_rb,8.712687e-01_rb,8.725448e-01_rb,8.744109e-01_rb,&
+        & 8.769260e-01_rb,8.801496e-01_rb,8.8414e-01_rb /)
+      asyliq1(:, 25) = (/ &
+        & 8.252182e-01_rb,8.379244e-01_rb,8.471709e-01_rb,8.535760e-01_rb,8.577540e-01_rb,&
+        & 8.603183e-01_rb,8.618820e-01_rb,8.630578e-01_rb,8.644587e-01_rb,8.666970e-01_rb,&
+        & 8.362159e-01_rb,8.536817e-01_rb,8.666387e-01_rb,8.756240e-01_rb,8.811746e-01_rb,&
+        & 8.838273e-01_rb,8.841191e-01_rb,8.825871e-01_rb,8.797681e-01_rb,8.761992e-01_rb,&
+        & 8.724174e-01_rb,8.689593e-01_rb,8.663623e-01_rb,8.651632e-01_rb,8.658988e-01_rb,&
+        & 8.691064e-01_rb,8.753226e-01_rb,8.850847e-01_rb,8.641620e-01_rb,8.690500e-01_rb,&
+        & 8.731026e-01_rb,8.763795e-01_rb,8.789400e-01_rb,8.808438e-01_rb,8.821503e-01_rb,&
+        & 8.829191e-01_rb,8.832095e-01_rb,8.830813e-01_rb,8.825938e-01_rb,8.818064e-01_rb,&
+        & 8.807787e-01_rb,8.795704e-01_rb,8.782408e-01_rb,8.768493e-01_rb,8.754557e-01_rb,&
+        & 8.741193e-01_rb,8.728995e-01_rb,8.718561e-01_rb,8.710484e-01_rb,8.705360e-01_rb,&
+        & 8.703782e-01_rb,8.706347e-01_rb,8.713650e-01_rb,8.726285e-01_rb,8.744849e-01_rb,&
+        & 8.769933e-01_rb,8.802136e-01_rb,8.8421e-01_rb /)
+      asyliq1(:, 26) = (/ &
+        & 8.370583e-01_rb,8.467920e-01_rb,8.537769e-01_rb,8.585136e-01_rb,8.615034e-01_rb,&
+        & 8.632474e-01_rb,8.642468e-01_rb,8.650026e-01_rb,8.660161e-01_rb,8.677882e-01_rb,&
+        & 8.369760e-01_rb,8.543821e-01_rb,8.672699e-01_rb,8.761782e-01_rb,8.816454e-01_rb,&
+        & 8.842103e-01_rb,8.844114e-01_rb,8.827872e-01_rb,8.798766e-01_rb,8.762179e-01_rb,&
+        & 8.723500e-01_rb,8.688112e-01_rb,8.661403e-01_rb,8.648758e-01_rb,8.655563e-01_rb,&
+        & 8.687206e-01_rb,8.749072e-01_rb,8.846546e-01_rb,8.636289e-01_rb,8.684849e-01_rb,&
+        & 8.725054e-01_rb,8.757501e-01_rb,8.782785e-01_rb,8.801503e-01_rb,8.814249e-01_rb,&
+        & 8.821620e-01_rb,8.824211e-01_rb,8.822620e-01_rb,8.817440e-01_rb,8.809268e-01_rb,&
+        & 8.798699e-01_rb,8.786330e-01_rb,8.772756e-01_rb,8.758572e-01_rb,8.744374e-01_rb,&
+        & 8.730760e-01_rb,8.718323e-01_rb,8.707660e-01_rb,8.699366e-01_rb,8.694039e-01_rb,&
+        & 8.692271e-01_rb,8.694661e-01_rb,8.701803e-01_rb,8.714293e-01_rb,8.732727e-01_rb,&
+        & 8.757702e-01_rb,8.789811e-01_rb,8.8297e-01_rb /)
+      asyliq1(:, 27) = (/ &
+        & 8.430819e-01_rb,8.510060e-01_rb,8.567270e-01_rb,8.606533e-01_rb,8.631934e-01_rb,&
+        & 8.647554e-01_rb,8.657471e-01_rb,8.665760e-01_rb,8.676496e-01_rb,8.693754e-01_rb,&
+        & 8.384298e-01_rb,8.557913e-01_rb,8.686214e-01_rb,8.774605e-01_rb,8.828495e-01_rb,&
+        & 8.853287e-01_rb,8.854393e-01_rb,8.837215e-01_rb,8.807161e-01_rb,8.769639e-01_rb,&
+        & 8.730053e-01_rb,8.693812e-01_rb,8.666321e-01_rb,8.652988e-01_rb,8.659219e-01_rb,&
+        & 8.690419e-01_rb,8.751999e-01_rb,8.849360e-01_rb,8.638013e-01_rb,8.686371e-01_rb,&
+        & 8.726369e-01_rb,8.758605e-01_rb,8.783674e-01_rb,8.802176e-01_rb,8.814705e-01_rb,&
+        & 8.821859e-01_rb,8.824234e-01_rb,8.822429e-01_rb,8.817038e-01_rb,8.808658e-01_rb,&
+        & 8.797887e-01_rb,8.785323e-01_rb,8.771560e-01_rb,8.757196e-01_rb,8.742828e-01_rb,&
+        & 8.729052e-01_rb,8.716467e-01_rb,8.705666e-01_rb,8.697250e-01_rb,8.691812e-01_rb,&
+        & 8.689950e-01_rb,8.692264e-01_rb,8.699346e-01_rb,8.711795e-01_rb,8.730209e-01_rb,&
+        & 8.755181e-01_rb,8.787312e-01_rb,8.8272e-01_rb /)
+      asyliq1(:, 28) = (/ &
+        & 8.452284e-01_rb,8.522700e-01_rb,8.572973e-01_rb,8.607031e-01_rb,8.628802e-01_rb,&
+        & 8.642215e-01_rb,8.651198e-01_rb,8.659679e-01_rb,8.671588e-01_rb,8.690853e-01_rb,&
+        & 8.383803e-01_rb,8.557485e-01_rb,8.685851e-01_rb,8.774303e-01_rb,8.828245e-01_rb,&
+        & 8.853077e-01_rb,8.854207e-01_rb,8.837034e-01_rb,8.806962e-01_rb,8.769398e-01_rb,&
+        & 8.729740e-01_rb,8.693393e-01_rb,8.665761e-01_rb,8.652247e-01_rb,8.658253e-01_rb,&
+        & 8.689182e-01_rb,8.750438e-01_rb,8.847424e-01_rb,8.636140e-01_rb,8.684449e-01_rb,&
+        & 8.724400e-01_rb,8.756589e-01_rb,8.781613e-01_rb,8.800072e-01_rb,8.812559e-01_rb,&
+        & 8.819671e-01_rb,8.822007e-01_rb,8.820165e-01_rb,8.814737e-01_rb,8.806322e-01_rb,&
+        & 8.795518e-01_rb,8.782923e-01_rb,8.769129e-01_rb,8.754737e-01_rb,8.740342e-01_rb,&
+        & 8.726542e-01_rb,8.713934e-01_rb,8.703111e-01_rb,8.694677e-01_rb,8.689222e-01_rb,&
+        & 8.687344e-01_rb,8.689646e-01_rb,8.696715e-01_rb,8.709156e-01_rb,8.727563e-01_rb,&
+        & 8.752531e-01_rb,8.784659e-01_rb,8.8245e-01_rb /)
+      asyliq1(:, 29) = (/ &
+        & 7.800869e-01_rb,8.091120e-01_rb,8.325369e-01_rb,8.466266e-01_rb,8.515495e-01_rb,&
+        & 8.499371e-01_rb,8.456203e-01_rb,8.430521e-01_rb,8.470286e-01_rb,8.625431e-01_rb,&
+        & 8.402261e-01_rb,8.610822e-01_rb,8.776608e-01_rb,8.904485e-01_rb,8.999294e-01_rb,&
+        & 9.065860e-01_rb,9.108995e-01_rb,9.133503e-01_rb,9.144187e-01_rb,9.145855e-01_rb,&
+        & 9.143320e-01_rb,9.141402e-01_rb,9.144933e-01_rb,9.158754e-01_rb,9.187716e-01_rb,&
+        & 9.236677e-01_rb,9.310503e-01_rb,9.414058e-01_rb,9.239108e-01_rb,9.300719e-01_rb,&
+        & 9.353612e-01_rb,9.398378e-01_rb,9.435609e-01_rb,9.465895e-01_rb,9.489829e-01_rb,&
+        & 9.508000e-01_rb,9.521002e-01_rb,9.529424e-01_rb,9.533860e-01_rb,9.534902e-01_rb,&
+        & 9.533143e-01_rb,9.529177e-01_rb,9.523596e-01_rb,9.516997e-01_rb,9.509973e-01_rb,&
+        & 9.503121e-01_rb,9.497037e-01_rb,9.492317e-01_rb,9.489558e-01_rb,9.489356e-01_rb,&
+        & 9.492311e-01_rb,9.499019e-01_rb,9.510077e-01_rb,9.526084e-01_rb,9.547636e-01_rb,&
+        & 9.575331e-01_rb,9.609766e-01_rb,9.6515e-01_rb /)
+
+! Spherical Ice Particle Parameterization
+! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
+      extice2(:, 16) = (/ &
+! band 16
+        & 4.101824e-01_rb,2.435514e-01_rb,1.713697e-01_rb,1.314865e-01_rb,1.063406e-01_rb,&
+        & 8.910701e-02_rb,7.659480e-02_rb,6.711784e-02_rb,5.970353e-02_rb,5.375249e-02_rb,&
+        & 4.887577e-02_rb,4.481025e-02_rb,4.137171e-02_rb,3.842744e-02_rb,3.587948e-02_rb,&
+        & 3.365396e-02_rb,3.169419e-02_rb,2.995593e-02_rb,2.840419e-02_rb,2.701091e-02_rb,&
+        & 2.575336e-02_rb,2.461293e-02_rb,2.357423e-02_rb,2.262443e-02_rb,2.175276e-02_rb,&
+        & 2.095012e-02_rb,2.020875e-02_rb,1.952199e-02_rb,1.888412e-02_rb,1.829018e-02_rb,&
+        & 1.773586e-02_rb,1.721738e-02_rb,1.673144e-02_rb,1.627510e-02_rb,1.584579e-02_rb,&
+        & 1.544122e-02_rb,1.505934e-02_rb,1.469833e-02_rb,1.435654e-02_rb,1.403251e-02_rb,&
+        & 1.372492e-02_rb,1.343255e-02_rb,1.315433e-02_rb /)
+      extice2(:, 17) = (/ &
+! band 17
+        & 3.836650e-01_rb,2.304055e-01_rb,1.637265e-01_rb,1.266681e-01_rb,1.031602e-01_rb,&
+        & 8.695191e-02_rb,7.511544e-02_rb,6.610009e-02_rb,5.900909e-02_rb,5.328833e-02_rb,&
+        & 4.857728e-02_rb,4.463133e-02_rb,4.127880e-02_rb,3.839567e-02_rb,3.589013e-02_rb,&
+        & 3.369280e-02_rb,3.175027e-02_rb,3.002079e-02_rb,2.847121e-02_rb,2.707493e-02_rb,&
+        & 2.581031e-02_rb,2.465962e-02_rb,2.360815e-02_rb,2.264363e-02_rb,2.175571e-02_rb,&
+        & 2.093563e-02_rb,2.017592e-02_rb,1.947015e-02_rb,1.881278e-02_rb,1.819901e-02_rb,&
+        & 1.762463e-02_rb,1.708598e-02_rb,1.657982e-02_rb,1.610330e-02_rb,1.565390e-02_rb,&
+        & 1.522937e-02_rb,1.482768e-02_rb,1.444706e-02_rb,1.408588e-02_rb,1.374270e-02_rb,&
+        & 1.341619e-02_rb,1.310517e-02_rb,1.280857e-02_rb /)
+      extice2(:, 18) = (/ &
+! band 18
+        & 4.152673e-01_rb,2.436816e-01_rb,1.702243e-01_rb,1.299704e-01_rb,1.047528e-01_rb,&
+        & 8.756039e-02_rb,7.513327e-02_rb,6.575690e-02_rb,5.844616e-02_rb,5.259609e-02_rb,&
+        & 4.781531e-02_rb,4.383980e-02_rb,4.048517e-02_rb,3.761891e-02_rb,3.514342e-02_rb,&
+        & 3.298525e-02_rb,3.108814e-02_rb,2.940825e-02_rb,2.791096e-02_rb,2.656858e-02_rb,&
+        & 2.535869e-02_rb,2.426297e-02_rb,2.326627e-02_rb,2.235602e-02_rb,2.152164e-02_rb,&
+        & 2.075420e-02_rb,2.004613e-02_rb,1.939091e-02_rb,1.878296e-02_rb,1.821744e-02_rb,&
+        & 1.769015e-02_rb,1.719741e-02_rb,1.673600e-02_rb,1.630308e-02_rb,1.589615e-02_rb,&
+        & 1.551298e-02_rb,1.515159e-02_rb,1.481021e-02_rb,1.448726e-02_rb,1.418131e-02_rb,&
+        & 1.389109e-02_rb,1.361544e-02_rb,1.335330e-02_rb /)
+      extice2(:, 19) = (/ &
+! band 19
+        & 3.873250e-01_rb,2.331609e-01_rb,1.655002e-01_rb,1.277753e-01_rb,1.038247e-01_rb,&
+        & 8.731780e-02_rb,7.527638e-02_rb,6.611873e-02_rb,5.892850e-02_rb,5.313885e-02_rb,&
+        & 4.838068e-02_rb,4.440356e-02_rb,4.103167e-02_rb,3.813804e-02_rb,3.562870e-02_rb,&
+        & 3.343269e-02_rb,3.149539e-02_rb,2.977414e-02_rb,2.823510e-02_rb,2.685112e-02_rb,&
+        & 2.560015e-02_rb,2.446411e-02_rb,2.342805e-02_rb,2.247948e-02_rb,2.160789e-02_rb,&
+        & 2.080438e-02_rb,2.006139e-02_rb,1.937238e-02_rb,1.873177e-02_rb,1.813469e-02_rb,&
+        & 1.757689e-02_rb,1.705468e-02_rb,1.656479e-02_rb,1.610435e-02_rb,1.567081e-02_rb,&
+        & 1.526192e-02_rb,1.487565e-02_rb,1.451020e-02_rb,1.416396e-02_rb,1.383546e-02_rb,&
+        & 1.352339e-02_rb,1.322657e-02_rb,1.294392e-02_rb /)
+      extice2(:, 20) = (/ &
+! band 20
+        & 3.784280e-01_rb,2.291396e-01_rb,1.632551e-01_rb,1.263775e-01_rb,1.028944e-01_rb,&
+        & 8.666975e-02_rb,7.480952e-02_rb,6.577335e-02_rb,5.866714e-02_rb,5.293694e-02_rb,&
+        & 4.822153e-02_rb,4.427547e-02_rb,4.092626e-02_rb,3.804918e-02_rb,3.555184e-02_rb,&
+        & 3.336440e-02_rb,3.143307e-02_rb,2.971577e-02_rb,2.817912e-02_rb,2.679632e-02_rb,&
+        & 2.554558e-02_rb,2.440903e-02_rb,2.337187e-02_rb,2.242173e-02_rb,2.154821e-02_rb,&
+        & 2.074249e-02_rb,1.999706e-02_rb,1.930546e-02_rb,1.866212e-02_rb,1.806221e-02_rb,&
+        & 1.750152e-02_rb,1.697637e-02_rb,1.648352e-02_rb,1.602010e-02_rb,1.558358e-02_rb,&
+        & 1.517172e-02_rb,1.478250e-02_rb,1.441413e-02_rb,1.406498e-02_rb,1.373362e-02_rb,&
+        & 1.341872e-02_rb,1.311911e-02_rb,1.283371e-02_rb /)
+      extice2(:, 21) = (/ &
+! band 21
+        & 3.719909e-01_rb,2.259490e-01_rb,1.613144e-01_rb,1.250648e-01_rb,1.019462e-01_rb,&
+        & 8.595358e-02_rb,7.425064e-02_rb,6.532618e-02_rb,5.830218e-02_rb,5.263421e-02_rb,&
+        & 4.796697e-02_rb,4.405891e-02_rb,4.074013e-02_rb,3.788776e-02_rb,3.541071e-02_rb,&
+        & 3.324008e-02_rb,3.132280e-02_rb,2.961733e-02_rb,2.809071e-02_rb,2.671645e-02_rb,&
+        & 2.547302e-02_rb,2.434276e-02_rb,2.331102e-02_rb,2.236558e-02_rb,2.149614e-02_rb,&
+        & 2.069397e-02_rb,1.995163e-02_rb,1.926272e-02_rb,1.862174e-02_rb,1.802389e-02_rb,&
+        & 1.746500e-02_rb,1.694142e-02_rb,1.644994e-02_rb,1.598772e-02_rb,1.555225e-02_rb,&
+        & 1.514129e-02_rb,1.475286e-02_rb,1.438515e-02_rb,1.403659e-02_rb,1.370572e-02_rb,&
+        & 1.339124e-02_rb,1.309197e-02_rb,1.280685e-02_rb /)
+      extice2(:, 22) = (/ &
+! band 22
+        & 3.713158e-01_rb,2.253816e-01_rb,1.608461e-01_rb,1.246718e-01_rb,1.016109e-01_rb,&
+        & 8.566332e-02_rb,7.399666e-02_rb,6.510199e-02_rb,5.810290e-02_rb,5.245608e-02_rb,&
+        & 4.780702e-02_rb,4.391478e-02_rb,4.060989e-02_rb,3.776982e-02_rb,3.530374e-02_rb,&
+        & 3.314296e-02_rb,3.123458e-02_rb,2.953719e-02_rb,2.801794e-02_rb,2.665043e-02_rb,&
+        & 2.541321e-02_rb,2.428868e-02_rb,2.326224e-02_rb,2.232173e-02_rb,2.145688e-02_rb,&
+        & 2.065899e-02_rb,1.992067e-02_rb,1.923552e-02_rb,1.859808e-02_rb,1.800356e-02_rb,&
+        & 1.744782e-02_rb,1.692721e-02_rb,1.643855e-02_rb,1.597900e-02_rb,1.554606e-02_rb,&
+        & 1.513751e-02_rb,1.475137e-02_rb,1.438586e-02_rb,1.403938e-02_rb,1.371050e-02_rb,&
+        & 1.339793e-02_rb,1.310050e-02_rb,1.281713e-02_rb /)
+      extice2(:, 23) = (/ &
+! band 23
+        & 3.605883e-01_rb,2.204388e-01_rb,1.580431e-01_rb,1.229033e-01_rb,1.004203e-01_rb,&
+        & 8.482616e-02_rb,7.338941e-02_rb,6.465105e-02_rb,5.776176e-02_rb,5.219398e-02_rb,&
+        & 4.760288e-02_rb,4.375369e-02_rb,4.048111e-02_rb,3.766539e-02_rb,3.521771e-02_rb,&
+        & 3.307079e-02_rb,3.117277e-02_rb,2.948303e-02_rb,2.796929e-02_rb,2.660560e-02_rb,&
+        & 2.537086e-02_rb,2.424772e-02_rb,2.322182e-02_rb,2.228114e-02_rb,2.141556e-02_rb,&
+        & 2.061649e-02_rb,1.987661e-02_rb,1.918962e-02_rb,1.855009e-02_rb,1.795330e-02_rb,&
+        & 1.739514e-02_rb,1.687199e-02_rb,1.638069e-02_rb,1.591845e-02_rb,1.548276e-02_rb,&
+        & 1.507143e-02_rb,1.468249e-02_rb,1.431416e-02_rb,1.396486e-02_rb,1.363318e-02_rb,&
+        & 1.331781e-02_rb,1.301759e-02_rb,1.273147e-02_rb /)
+      extice2(:, 24) = (/ &
+! band 24
+        & 3.527890e-01_rb,2.168469e-01_rb,1.560090e-01_rb,1.216216e-01_rb,9.955787e-02_rb,&
+        & 8.421942e-02_rb,7.294827e-02_rb,6.432192e-02_rb,5.751081e-02_rb,5.199888e-02_rb,&
+        & 4.744835e-02_rb,4.362899e-02_rb,4.037847e-02_rb,3.757910e-02_rb,3.514351e-02_rb,&
+        & 3.300546e-02_rb,3.111382e-02_rb,2.942853e-02_rb,2.791775e-02_rb,2.655584e-02_rb,&
+        & 2.532195e-02_rb,2.419892e-02_rb,2.317255e-02_rb,2.223092e-02_rb,2.136402e-02_rb,&
+        & 2.056334e-02_rb,1.982160e-02_rb,1.913258e-02_rb,1.849087e-02_rb,1.789178e-02_rb,&
+        & 1.733124e-02_rb,1.680565e-02_rb,1.631187e-02_rb,1.584711e-02_rb,1.540889e-02_rb,&
+        & 1.499502e-02_rb,1.460354e-02_rb,1.423269e-02_rb,1.388088e-02_rb,1.354670e-02_rb,&
+        & 1.322887e-02_rb,1.292620e-02_rb,1.263767e-02_rb /)
+      extice2(:, 25) = (/ &
+! band 25
+        & 3.477874e-01_rb,2.143515e-01_rb,1.544887e-01_rb,1.205942e-01_rb,9.881779e-02_rb,&
+        & 8.366261e-02_rb,7.251586e-02_rb,6.397790e-02_rb,5.723183e-02_rb,5.176908e-02_rb,&
+        & 4.725658e-02_rb,4.346715e-02_rb,4.024055e-02_rb,3.746055e-02_rb,3.504080e-02_rb,&
+        & 3.291583e-02_rb,3.103507e-02_rb,2.935891e-02_rb,2.785582e-02_rb,2.650042e-02_rb,&
+        & 2.527206e-02_rb,2.415376e-02_rb,2.313142e-02_rb,2.219326e-02_rb,2.132934e-02_rb,&
+        & 2.053122e-02_rb,1.979169e-02_rb,1.910456e-02_rb,1.846448e-02_rb,1.786680e-02_rb,&
+        & 1.730745e-02_rb,1.678289e-02_rb,1.628998e-02_rb,1.582595e-02_rb,1.538835e-02_rb,&
+        & 1.497499e-02_rb,1.458393e-02_rb,1.421341e-02_rb,1.386187e-02_rb,1.352788e-02_rb,&
+        & 1.321019e-02_rb,1.290762e-02_rb,1.261913e-02_rb /)
+      extice2(:, 26) = (/ &
+! band 26
+        & 3.453721e-01_rb,2.130744e-01_rb,1.536698e-01_rb,1.200140e-01_rb,9.838078e-02_rb,&
+        & 8.331940e-02_rb,7.223803e-02_rb,6.374775e-02_rb,5.703770e-02_rb,5.160290e-02_rb,&
+        & 4.711259e-02_rb,4.334110e-02_rb,4.012923e-02_rb,3.736150e-02_rb,3.495208e-02_rb,&
+        & 3.283589e-02_rb,3.096267e-02_rb,2.929302e-02_rb,2.779560e-02_rb,2.644517e-02_rb,&
+        & 2.522119e-02_rb,2.410677e-02_rb,2.308788e-02_rb,2.215281e-02_rb,2.129165e-02_rb,&
+        & 2.049602e-02_rb,1.975874e-02_rb,1.907365e-02_rb,1.843542e-02_rb,1.783943e-02_rb,&
+        & 1.728162e-02_rb,1.675847e-02_rb,1.626685e-02_rb,1.580401e-02_rb,1.536750e-02_rb,&
+        & 1.495515e-02_rb,1.456502e-02_rb,1.419537e-02_rb,1.384463e-02_rb,1.351139e-02_rb,&
+        & 1.319438e-02_rb,1.289246e-02_rb,1.260456e-02_rb /)
+      extice2(:, 27) = (/ &
+! band 27
+        & 3.417883e-01_rb,2.113379e-01_rb,1.526395e-01_rb,1.193347e-01_rb,9.790253e-02_rb,&
+        & 8.296715e-02_rb,7.196979e-02_rb,6.353806e-02_rb,5.687024e-02_rb,5.146670e-02_rb,&
+        & 4.700001e-02_rb,4.324667e-02_rb,4.004894e-02_rb,3.729233e-02_rb,3.489172e-02_rb,&
+        & 3.278257e-02_rb,3.091499e-02_rb,2.924987e-02_rb,2.775609e-02_rb,2.640859e-02_rb,&
+        & 2.518695e-02_rb,2.407439e-02_rb,2.305697e-02_rb,2.212303e-02_rb,2.126273e-02_rb,&
+        & 2.046774e-02_rb,1.973090e-02_rb,1.904610e-02_rb,1.840801e-02_rb,1.781204e-02_rb,&
+        & 1.725417e-02_rb,1.673086e-02_rb,1.623902e-02_rb,1.577590e-02_rb,1.533906e-02_rb,&
+        & 1.492634e-02_rb,1.453580e-02_rb,1.416571e-02_rb,1.381450e-02_rb,1.348078e-02_rb,&
+        & 1.316327e-02_rb,1.286082e-02_rb,1.257240e-02_rb /)
+      extice2(:, 28) = (/ &
+! band 28
+        & 3.416111e-01_rb,2.114124e-01_rb,1.527734e-01_rb,1.194809e-01_rb,9.804612e-02_rb,&
+        & 8.310287e-02_rb,7.209595e-02_rb,6.365442e-02_rb,5.697710e-02_rb,5.156460e-02_rb,&
+        & 4.708957e-02_rb,4.332850e-02_rb,4.012361e-02_rb,3.736037e-02_rb,3.495364e-02_rb,&
+        & 3.283879e-02_rb,3.096593e-02_rb,2.929589e-02_rb,2.779751e-02_rb,2.644571e-02_rb,&
+        & 2.522004e-02_rb,2.410369e-02_rb,2.308271e-02_rb,2.214542e-02_rb,2.128195e-02_rb,&
+        & 2.048396e-02_rb,1.974429e-02_rb,1.905679e-02_rb,1.841614e-02_rb,1.781774e-02_rb,&
+        & 1.725754e-02_rb,1.673203e-02_rb,1.623807e-02_rb,1.577293e-02_rb,1.533416e-02_rb,&
+        & 1.491958e-02_rb,1.452727e-02_rb,1.415547e-02_rb,1.380262e-02_rb,1.346732e-02_rb,&
+        & 1.314830e-02_rb,1.284439e-02_rb,1.255456e-02_rb /)
+      extice2(:, 29) = (/ &
+! band 29
+        & 4.196611e-01_rb,2.493642e-01_rb,1.761261e-01_rb,1.357197e-01_rb,1.102161e-01_rb,&
+        & 9.269376e-02_rb,7.992985e-02_rb,7.022538e-02_rb,6.260168e-02_rb,5.645603e-02_rb,&
+        & 5.139732e-02_rb,4.716088e-02_rb,4.356133e-02_rb,4.046498e-02_rb,3.777303e-02_rb,&
+        & 3.541094e-02_rb,3.332137e-02_rb,3.145954e-02_rb,2.978998e-02_rb,2.828419e-02_rb,&
+        & 2.691905e-02_rb,2.567559e-02_rb,2.453811e-02_rb,2.349350e-02_rb,2.253072e-02_rb,&
+        & 2.164042e-02_rb,2.081464e-02_rb,2.004652e-02_rb,1.933015e-02_rb,1.866041e-02_rb,&
+        & 1.803283e-02_rb,1.744348e-02_rb,1.688894e-02_rb,1.636616e-02_rb,1.587244e-02_rb,&
+        & 1.540539e-02_rb,1.496287e-02_rb,1.454295e-02_rb,1.414392e-02_rb,1.376423e-02_rb,&
+        & 1.340247e-02_rb,1.305739e-02_rb,1.272784e-02_rb /)
+
+! single-scattering albedo: unitless
+      ssaice2(:, 16) = (/ &
+! band 16
+        & 6.630615e-01_rb,6.451169e-01_rb,6.333696e-01_rb,6.246927e-01_rb,6.178420e-01_rb,&
+        & 6.121976e-01_rb,6.074069e-01_rb,6.032505e-01_rb,5.995830e-01_rb,5.963030e-01_rb,&
+        & 5.933372e-01_rb,5.906311e-01_rb,5.881427e-01_rb,5.858395e-01_rb,5.836955e-01_rb,&
+        & 5.816896e-01_rb,5.798046e-01_rb,5.780264e-01_rb,5.763429e-01_rb,5.747441e-01_rb,&
+        & 5.732213e-01_rb,5.717672e-01_rb,5.703754e-01_rb,5.690403e-01_rb,5.677571e-01_rb,&
+        & 5.665215e-01_rb,5.653297e-01_rb,5.641782e-01_rb,5.630643e-01_rb,5.619850e-01_rb,&
+        & 5.609381e-01_rb,5.599214e-01_rb,5.589328e-01_rb,5.579707e-01_rb,5.570333e-01_rb,&
+        & 5.561193e-01_rb,5.552272e-01_rb,5.543558e-01_rb,5.535041e-01_rb,5.526708e-01_rb,&
+        & 5.518551e-01_rb,5.510561e-01_rb,5.502729e-01_rb /)
+      ssaice2(:, 17) = (/ &
+! band 17
+        & 7.689749e-01_rb,7.398171e-01_rb,7.205819e-01_rb,7.065690e-01_rb,6.956928e-01_rb,&
+        & 6.868989e-01_rb,6.795813e-01_rb,6.733606e-01_rb,6.679838e-01_rb,6.632742e-01_rb,&
+        & 6.591036e-01_rb,6.553766e-01_rb,6.520197e-01_rb,6.489757e-01_rb,6.461991e-01_rb,&
+        & 6.436531e-01_rb,6.413075e-01_rb,6.391375e-01_rb,6.371221e-01_rb,6.352438e-01_rb,&
+        & 6.334876e-01_rb,6.318406e-01_rb,6.302918e-01_rb,6.288315e-01_rb,6.274512e-01_rb,&
+        & 6.261436e-01_rb,6.249022e-01_rb,6.237211e-01_rb,6.225953e-01_rb,6.215201e-01_rb,&
+        & 6.204914e-01_rb,6.195055e-01_rb,6.185592e-01_rb,6.176492e-01_rb,6.167730e-01_rb,&
+        & 6.159280e-01_rb,6.151120e-01_rb,6.143228e-01_rb,6.135587e-01_rb,6.128177e-01_rb,&
+        & 6.120984e-01_rb,6.113993e-01_rb,6.107189e-01_rb /)
+      ssaice2(:, 18) = (/ &
+! band 18
+        & 9.956167e-01_rb,9.814770e-01_rb,9.716104e-01_rb,9.639746e-01_rb,9.577179e-01_rb,&
+        & 9.524010e-01_rb,9.477672e-01_rb,9.436527e-01_rb,9.399467e-01_rb,9.365708e-01_rb,&
+        & 9.334672e-01_rb,9.305921e-01_rb,9.279118e-01_rb,9.253993e-01_rb,9.230330e-01_rb,&
+        & 9.207954e-01_rb,9.186719e-01_rb,9.166501e-01_rb,9.147199e-01_rb,9.128722e-01_rb,&
+        & 9.110997e-01_rb,9.093956e-01_rb,9.077544e-01_rb,9.061708e-01_rb,9.046406e-01_rb,&
+        & 9.031598e-01_rb,9.017248e-01_rb,9.003326e-01_rb,8.989804e-01_rb,8.976655e-01_rb,&
+        & 8.963857e-01_rb,8.951389e-01_rb,8.939233e-01_rb,8.927370e-01_rb,8.915785e-01_rb,&
+        & 8.904464e-01_rb,8.893392e-01_rb,8.882559e-01_rb,8.871951e-01_rb,8.861559e-01_rb,&
+        & 8.851373e-01_rb,8.841383e-01_rb,8.831581e-01_rb /)
+      ssaice2(:, 19) = (/ &
+! band 19
+        & 9.723177e-01_rb,9.452119e-01_rb,9.267592e-01_rb,9.127393e-01_rb,9.014238e-01_rb,&
+        & 8.919334e-01_rb,8.837584e-01_rb,8.765773e-01_rb,8.701736e-01_rb,8.643950e-01_rb,&
+        & 8.591299e-01_rb,8.542942e-01_rb,8.498230e-01_rb,8.456651e-01_rb,8.417794e-01_rb,&
+        & 8.381324e-01_rb,8.346964e-01_rb,8.314484e-01_rb,8.283687e-01_rb,8.254408e-01_rb,&
+        & 8.226505e-01_rb,8.199854e-01_rb,8.174348e-01_rb,8.149891e-01_rb,8.126403e-01_rb,&
+        & 8.103808e-01_rb,8.082041e-01_rb,8.061044e-01_rb,8.040765e-01_rb,8.021156e-01_rb,&
+        & 8.002174e-01_rb,7.983781e-01_rb,7.965941e-01_rb,7.948622e-01_rb,7.931795e-01_rb,&
+        & 7.915432e-01_rb,7.899508e-01_rb,7.884002e-01_rb,7.868891e-01_rb,7.854156e-01_rb,&
+        & 7.839779e-01_rb,7.825742e-01_rb,7.812031e-01_rb /)
+      ssaice2(:, 20) = (/ &
+! band 20
+        & 9.933294e-01_rb,9.860917e-01_rb,9.811564e-01_rb,9.774008e-01_rb,9.743652e-01_rb,&
+        & 9.718155e-01_rb,9.696159e-01_rb,9.676810e-01_rb,9.659531e-01_rb,9.643915e-01_rb,&
+        & 9.629667e-01_rb,9.616561e-01_rb,9.604426e-01_rb,9.593125e-01_rb,9.582548e-01_rb,&
+        & 9.572607e-01_rb,9.563227e-01_rb,9.554347e-01_rb,9.545915e-01_rb,9.537888e-01_rb,&
+        & 9.530226e-01_rb,9.522898e-01_rb,9.515874e-01_rb,9.509130e-01_rb,9.502643e-01_rb,&
+        & 9.496394e-01_rb,9.490366e-01_rb,9.484542e-01_rb,9.478910e-01_rb,9.473456e-01_rb,&
+        & 9.468169e-01_rb,9.463039e-01_rb,9.458056e-01_rb,9.453212e-01_rb,9.448499e-01_rb,&
+        & 9.443910e-01_rb,9.439438e-01_rb,9.435077e-01_rb,9.430821e-01_rb,9.426666e-01_rb,&
+        & 9.422607e-01_rb,9.418638e-01_rb,9.414756e-01_rb /)
+      ssaice2(:, 21) = (/ &
+! band 21
+        & 9.900787e-01_rb,9.828880e-01_rb,9.779258e-01_rb,9.741173e-01_rb,9.710184e-01_rb,&
+        & 9.684012e-01_rb,9.661332e-01_rb,9.641301e-01_rb,9.623352e-01_rb,9.607083e-01_rb,&
+        & 9.592198e-01_rb,9.578474e-01_rb,9.565739e-01_rb,9.553856e-01_rb,9.542715e-01_rb,&
+        & 9.532226e-01_rb,9.522314e-01_rb,9.512919e-01_rb,9.503986e-01_rb,9.495472e-01_rb,&
+        & 9.487337e-01_rb,9.479549e-01_rb,9.472077e-01_rb,9.464897e-01_rb,9.457985e-01_rb,&
+        & 9.451322e-01_rb,9.444890e-01_rb,9.438673e-01_rb,9.432656e-01_rb,9.426826e-01_rb,&
+        & 9.421173e-01_rb,9.415684e-01_rb,9.410351e-01_rb,9.405164e-01_rb,9.400115e-01_rb,&
+        & 9.395198e-01_rb,9.390404e-01_rb,9.385728e-01_rb,9.381164e-01_rb,9.376707e-01_rb,&
+        & 9.372350e-01_rb,9.368091e-01_rb,9.363923e-01_rb /)
+      ssaice2(:, 22) = (/ &
+! band 22
+        & 9.986793e-01_rb,9.985239e-01_rb,9.983911e-01_rb,9.982715e-01_rb,9.981606e-01_rb,&
+        & 9.980562e-01_rb,9.979567e-01_rb,9.978613e-01_rb,9.977691e-01_rb,9.976798e-01_rb,&
+        & 9.975929e-01_rb,9.975081e-01_rb,9.974251e-01_rb,9.973438e-01_rb,9.972640e-01_rb,&
+        & 9.971855e-01_rb,9.971083e-01_rb,9.970322e-01_rb,9.969571e-01_rb,9.968830e-01_rb,&
+        & 9.968099e-01_rb,9.967375e-01_rb,9.966660e-01_rb,9.965951e-01_rb,9.965250e-01_rb,&
+        & 9.964555e-01_rb,9.963867e-01_rb,9.963185e-01_rb,9.962508e-01_rb,9.961836e-01_rb,&
+        & 9.961170e-01_rb,9.960508e-01_rb,9.959851e-01_rb,9.959198e-01_rb,9.958550e-01_rb,&
+        & 9.957906e-01_rb,9.957266e-01_rb,9.956629e-01_rb,9.955997e-01_rb,9.955367e-01_rb,&
+        & 9.954742e-01_rb,9.954119e-01_rb,9.953500e-01_rb /)
+      ssaice2(:, 23) = (/ &
+! band 23
+        & 9.997944e-01_rb,9.997791e-01_rb,9.997664e-01_rb,9.997547e-01_rb,9.997436e-01_rb,&
+        & 9.997327e-01_rb,9.997219e-01_rb,9.997110e-01_rb,9.996999e-01_rb,9.996886e-01_rb,&
+        & 9.996771e-01_rb,9.996653e-01_rb,9.996533e-01_rb,9.996409e-01_rb,9.996282e-01_rb,&
+        & 9.996152e-01_rb,9.996019e-01_rb,9.995883e-01_rb,9.995743e-01_rb,9.995599e-01_rb,&
+        & 9.995453e-01_rb,9.995302e-01_rb,9.995149e-01_rb,9.994992e-01_rb,9.994831e-01_rb,&
+        & 9.994667e-01_rb,9.994500e-01_rb,9.994329e-01_rb,9.994154e-01_rb,9.993976e-01_rb,&
+        & 9.993795e-01_rb,9.993610e-01_rb,9.993422e-01_rb,9.993230e-01_rb,9.993035e-01_rb,&
+        & 9.992837e-01_rb,9.992635e-01_rb,9.992429e-01_rb,9.992221e-01_rb,9.992008e-01_rb,&
+        & 9.991793e-01_rb,9.991574e-01_rb,9.991352e-01_rb /)
+      ssaice2(:, 24) = (/ &
+! band 24
+        & 9.999949e-01_rb,9.999947e-01_rb,9.999943e-01_rb,9.999939e-01_rb,9.999934e-01_rb,&
+        & 9.999927e-01_rb,9.999920e-01_rb,9.999913e-01_rb,9.999904e-01_rb,9.999895e-01_rb,&
+        & 9.999885e-01_rb,9.999874e-01_rb,9.999863e-01_rb,9.999851e-01_rb,9.999838e-01_rb,&
+        & 9.999824e-01_rb,9.999810e-01_rb,9.999795e-01_rb,9.999780e-01_rb,9.999764e-01_rb,&
+        & 9.999747e-01_rb,9.999729e-01_rb,9.999711e-01_rb,9.999692e-01_rb,9.999673e-01_rb,&
+        & 9.999653e-01_rb,9.999632e-01_rb,9.999611e-01_rb,9.999589e-01_rb,9.999566e-01_rb,&
+        & 9.999543e-01_rb,9.999519e-01_rb,9.999495e-01_rb,9.999470e-01_rb,9.999444e-01_rb,&
+        & 9.999418e-01_rb,9.999392e-01_rb,9.999364e-01_rb,9.999336e-01_rb,9.999308e-01_rb,&
+        & 9.999279e-01_rb,9.999249e-01_rb,9.999219e-01_rb /)
+      ssaice2(:, 25) = (/ &
+! band 25
+        & 9.999997e-01_rb,9.999997e-01_rb,9.999997e-01_rb,9.999996e-01_rb,9.999996e-01_rb,&
+        & 9.999995e-01_rb,9.999994e-01_rb,9.999993e-01_rb,9.999993e-01_rb,9.999992e-01_rb,&
+        & 9.999991e-01_rb,9.999989e-01_rb,9.999988e-01_rb,9.999987e-01_rb,9.999986e-01_rb,&
+        & 9.999984e-01_rb,9.999983e-01_rb,9.999981e-01_rb,9.999980e-01_rb,9.999978e-01_rb,&
+        & 9.999976e-01_rb,9.999974e-01_rb,9.999972e-01_rb,9.999971e-01_rb,9.999969e-01_rb,&
+        & 9.999966e-01_rb,9.999964e-01_rb,9.999962e-01_rb,9.999960e-01_rb,9.999957e-01_rb,&
+        & 9.999955e-01_rb,9.999953e-01_rb,9.999950e-01_rb,9.999947e-01_rb,9.999945e-01_rb,&
+        & 9.999942e-01_rb,9.999939e-01_rb,9.999936e-01_rb,9.999934e-01_rb,9.999931e-01_rb,&
+        & 9.999928e-01_rb,9.999925e-01_rb,9.999921e-01_rb /)
+      ssaice2(:, 26) = (/ &
+! band 26
+        & 9.999997e-01_rb,9.999996e-01_rb,9.999996e-01_rb,9.999995e-01_rb,9.999994e-01_rb,&
+        & 9.999993e-01_rb,9.999992e-01_rb,9.999991e-01_rb,9.999990e-01_rb,9.999989e-01_rb,&
+        & 9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,9.999982e-01_rb,9.999980e-01_rb,&
+        & 9.999978e-01_rb,9.999976e-01_rb,9.999974e-01_rb,9.999972e-01_rb,9.999970e-01_rb,&
+        & 9.999967e-01_rb,9.999965e-01_rb,9.999962e-01_rb,9.999959e-01_rb,9.999956e-01_rb,&
+        & 9.999954e-01_rb,9.999951e-01_rb,9.999947e-01_rb,9.999944e-01_rb,9.999941e-01_rb,&
+        & 9.999938e-01_rb,9.999934e-01_rb,9.999931e-01_rb,9.999927e-01_rb,9.999923e-01_rb,&
+        & 9.999920e-01_rb,9.999916e-01_rb,9.999912e-01_rb,9.999908e-01_rb,9.999904e-01_rb,&
+        & 9.999899e-01_rb,9.999895e-01_rb,9.999891e-01_rb /)
+      ssaice2(:, 27) = (/ &
+! band 27
+        & 9.999987e-01_rb,9.999987e-01_rb,9.999985e-01_rb,9.999984e-01_rb,9.999982e-01_rb,&
+        & 9.999980e-01_rb,9.999978e-01_rb,9.999976e-01_rb,9.999973e-01_rb,9.999970e-01_rb,&
+        & 9.999967e-01_rb,9.999964e-01_rb,9.999960e-01_rb,9.999956e-01_rb,9.999952e-01_rb,&
+        & 9.999948e-01_rb,9.999944e-01_rb,9.999939e-01_rb,9.999934e-01_rb,9.999929e-01_rb,&
+        & 9.999924e-01_rb,9.999918e-01_rb,9.999913e-01_rb,9.999907e-01_rb,9.999901e-01_rb,&
+        & 9.999894e-01_rb,9.999888e-01_rb,9.999881e-01_rb,9.999874e-01_rb,9.999867e-01_rb,&
+        & 9.999860e-01_rb,9.999853e-01_rb,9.999845e-01_rb,9.999837e-01_rb,9.999829e-01_rb,&
+        & 9.999821e-01_rb,9.999813e-01_rb,9.999804e-01_rb,9.999796e-01_rb,9.999787e-01_rb,&
+        & 9.999778e-01_rb,9.999768e-01_rb,9.999759e-01_rb /)
+      ssaice2(:, 28) = (/ &
+! band 28
+        & 9.999989e-01_rb,9.999989e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,&
+        & 9.999982e-01_rb,9.999980e-01_rb,9.999978e-01_rb,9.999975e-01_rb,9.999972e-01_rb,&
+        & 9.999969e-01_rb,9.999966e-01_rb,9.999962e-01_rb,9.999958e-01_rb,9.999954e-01_rb,&
+        & 9.999950e-01_rb,9.999945e-01_rb,9.999941e-01_rb,9.999936e-01_rb,9.999931e-01_rb,&
+        & 9.999925e-01_rb,9.999920e-01_rb,9.999914e-01_rb,9.999908e-01_rb,9.999902e-01_rb,&
+        & 9.999896e-01_rb,9.999889e-01_rb,9.999883e-01_rb,9.999876e-01_rb,9.999869e-01_rb,&
+        & 9.999861e-01_rb,9.999854e-01_rb,9.999846e-01_rb,9.999838e-01_rb,9.999830e-01_rb,&
+        & 9.999822e-01_rb,9.999814e-01_rb,9.999805e-01_rb,9.999796e-01_rb,9.999787e-01_rb,&
+        & 9.999778e-01_rb,9.999769e-01_rb,9.999759e-01_rb /)
+      ssaice2(:, 29) = (/ &
+! band 29
+        & 7.042143e-01_rb,6.691161e-01_rb,6.463240e-01_rb,6.296590e-01_rb,6.166381e-01_rb,&
+        & 6.060183e-01_rb,5.970908e-01_rb,5.894144e-01_rb,5.826968e-01_rb,5.767343e-01_rb,&
+        & 5.713804e-01_rb,5.665256e-01_rb,5.620867e-01_rb,5.579987e-01_rb,5.542101e-01_rb,&
+        & 5.506794e-01_rb,5.473727e-01_rb,5.442620e-01_rb,5.413239e-01_rb,5.385389e-01_rb,&
+        & 5.358901e-01_rb,5.333633e-01_rb,5.309460e-01_rb,5.286277e-01_rb,5.263988e-01_rb,&
+        & 5.242512e-01_rb,5.221777e-01_rb,5.201719e-01_rb,5.182280e-01_rb,5.163410e-01_rb,&
+        & 5.145062e-01_rb,5.127197e-01_rb,5.109776e-01_rb,5.092766e-01_rb,5.076137e-01_rb,&
+        & 5.059860e-01_rb,5.043911e-01_rb,5.028266e-01_rb,5.012904e-01_rb,4.997805e-01_rb,&
+        & 4.982951e-01_rb,4.968326e-01_rb,4.953913e-01_rb /)
+
+! asymmetry factor: unitless
+      asyice2(:, 16) = (/ &
+! band 16
+        & 7.946655e-01_rb,8.547685e-01_rb,8.806016e-01_rb,8.949880e-01_rb,9.041676e-01_rb,&
+        & 9.105399e-01_rb,9.152249e-01_rb,9.188160e-01_rb,9.216573e-01_rb,9.239620e-01_rb,&
+        & 9.258695e-01_rb,9.274745e-01_rb,9.288441e-01_rb,9.300267e-01_rb,9.310584e-01_rb,&
+        & 9.319665e-01_rb,9.327721e-01_rb,9.334918e-01_rb,9.341387e-01_rb,9.347236e-01_rb,&
+        & 9.352551e-01_rb,9.357402e-01_rb,9.361850e-01_rb,9.365942e-01_rb,9.369722e-01_rb,&
+        & 9.373225e-01_rb,9.376481e-01_rb,9.379516e-01_rb,9.382352e-01_rb,9.385010e-01_rb,&
+        & 9.387505e-01_rb,9.389854e-01_rb,9.392070e-01_rb,9.394163e-01_rb,9.396145e-01_rb,&
+        & 9.398024e-01_rb,9.399809e-01_rb,9.401508e-01_rb,9.403126e-01_rb,9.404670e-01_rb,&
+        & 9.406144e-01_rb,9.407555e-01_rb,9.408906e-01_rb /)
+      asyice2(:, 17) = (/ &
+! band 17
+        & 9.078091e-01_rb,9.195850e-01_rb,9.267250e-01_rb,9.317083e-01_rb,9.354632e-01_rb,&
+        & 9.384323e-01_rb,9.408597e-01_rb,9.428935e-01_rb,9.446301e-01_rb,9.461351e-01_rb,&
+        & 9.474555e-01_rb,9.486259e-01_rb,9.496722e-01_rb,9.506146e-01_rb,9.514688e-01_rb,&
+        & 9.522476e-01_rb,9.529612e-01_rb,9.536181e-01_rb,9.542251e-01_rb,9.547883e-01_rb,&
+        & 9.553124e-01_rb,9.558019e-01_rb,9.562601e-01_rb,9.566904e-01_rb,9.570953e-01_rb,&
+        & 9.574773e-01_rb,9.578385e-01_rb,9.581806e-01_rb,9.585054e-01_rb,9.588142e-01_rb,&
+        & 9.591083e-01_rb,9.593888e-01_rb,9.596569e-01_rb,9.599135e-01_rb,9.601593e-01_rb,&
+        & 9.603952e-01_rb,9.606219e-01_rb,9.608399e-01_rb,9.610499e-01_rb,9.612523e-01_rb,&
+        & 9.614477e-01_rb,9.616365e-01_rb,9.618192e-01_rb /)
+      asyice2(:, 18) = (/ &
+! band 18
+        & 8.322045e-01_rb,8.528693e-01_rb,8.648167e-01_rb,8.729163e-01_rb,8.789054e-01_rb,&
+        & 8.835845e-01_rb,8.873819e-01_rb,8.905511e-01_rb,8.932532e-01_rb,8.955965e-01_rb,&
+        & 8.976567e-01_rb,8.994887e-01_rb,9.011334e-01_rb,9.026221e-01_rb,9.039791e-01_rb,&
+        & 9.052237e-01_rb,9.063715e-01_rb,9.074349e-01_rb,9.084245e-01_rb,9.093489e-01_rb,&
+        & 9.102154e-01_rb,9.110303e-01_rb,9.117987e-01_rb,9.125253e-01_rb,9.132140e-01_rb,&
+        & 9.138682e-01_rb,9.144910e-01_rb,9.150850e-01_rb,9.156524e-01_rb,9.161955e-01_rb,&
+        & 9.167160e-01_rb,9.172157e-01_rb,9.176959e-01_rb,9.181581e-01_rb,9.186034e-01_rb,&
+        & 9.190330e-01_rb,9.194478e-01_rb,9.198488e-01_rb,9.202368e-01_rb,9.206126e-01_rb,&
+        & 9.209768e-01_rb,9.213301e-01_rb,9.216731e-01_rb /)
+      asyice2(:, 19) = (/ &
+! band 19
+        & 8.116560e-01_rb,8.488278e-01_rb,8.674331e-01_rb,8.788148e-01_rb,8.865810e-01_rb,&
+        & 8.922595e-01_rb,8.966149e-01_rb,9.000747e-01_rb,9.028980e-01_rb,9.052513e-01_rb,&
+        & 9.072468e-01_rb,9.089632e-01_rb,9.104574e-01_rb,9.117713e-01_rb,9.129371e-01_rb,&
+        & 9.139793e-01_rb,9.149174e-01_rb,9.157668e-01_rb,9.165400e-01_rb,9.172473e-01_rb,&
+        & 9.178970e-01_rb,9.184962e-01_rb,9.190508e-01_rb,9.195658e-01_rb,9.200455e-01_rb,&
+        & 9.204935e-01_rb,9.209130e-01_rb,9.213067e-01_rb,9.216771e-01_rb,9.220262e-01_rb,&
+        & 9.223560e-01_rb,9.226680e-01_rb,9.229636e-01_rb,9.232443e-01_rb,9.235112e-01_rb,&
+        & 9.237652e-01_rb,9.240074e-01_rb,9.242385e-01_rb,9.244594e-01_rb,9.246708e-01_rb,&
+        & 9.248733e-01_rb,9.250674e-01_rb,9.252536e-01_rb /)
+      asyice2(:, 20) = (/ &
+! band 20
+        & 8.047113e-01_rb,8.402864e-01_rb,8.570332e-01_rb,8.668455e-01_rb,8.733206e-01_rb,&
+        & 8.779272e-01_rb,8.813796e-01_rb,8.840676e-01_rb,8.862225e-01_rb,8.879904e-01_rb,&
+        & 8.894682e-01_rb,8.907228e-01_rb,8.918019e-01_rb,8.927404e-01_rb,8.935645e-01_rb,&
+        & 8.942943e-01_rb,8.949452e-01_rb,8.955296e-01_rb,8.960574e-01_rb,8.965366e-01_rb,&
+        & 8.969736e-01_rb,8.973740e-01_rb,8.977422e-01_rb,8.980820e-01_rb,8.983966e-01_rb,&
+        & 8.986889e-01_rb,8.989611e-01_rb,8.992153e-01_rb,8.994533e-01_rb,8.996766e-01_rb,&
+        & 8.998865e-01_rb,9.000843e-01_rb,9.002709e-01_rb,9.004474e-01_rb,9.006146e-01_rb,&
+        & 9.007731e-01_rb,9.009237e-01_rb,9.010670e-01_rb,9.012034e-01_rb,9.013336e-01_rb,&
+        & 9.014579e-01_rb,9.015767e-01_rb,9.016904e-01_rb /)
+      asyice2(:, 21) = (/ &
+! band 21
+        & 8.179122e-01_rb,8.480726e-01_rb,8.621945e-01_rb,8.704354e-01_rb,8.758555e-01_rb,&
+        & 8.797007e-01_rb,8.825750e-01_rb,8.848078e-01_rb,8.865939e-01_rb,8.880564e-01_rb,&
+        & 8.892765e-01_rb,8.903105e-01_rb,8.911982e-01_rb,8.919689e-01_rb,8.926446e-01_rb,&
+        & 8.932419e-01_rb,8.937738e-01_rb,8.942506e-01_rb,8.946806e-01_rb,8.950702e-01_rb,&
+        & 8.954251e-01_rb,8.957497e-01_rb,8.960477e-01_rb,8.963223e-01_rb,8.965762e-01_rb,&
+        & 8.968116e-01_rb,8.970306e-01_rb,8.972347e-01_rb,8.974255e-01_rb,8.976042e-01_rb,&
+        & 8.977720e-01_rb,8.979298e-01_rb,8.980784e-01_rb,8.982188e-01_rb,8.983515e-01_rb,&
+        & 8.984771e-01_rb,8.985963e-01_rb,8.987095e-01_rb,8.988171e-01_rb,8.989195e-01_rb,&
+        & 8.990172e-01_rb,8.991104e-01_rb,8.991994e-01_rb /)
+      asyice2(:, 22) = (/ &
+! band 22
+        & 8.169789e-01_rb,8.455024e-01_rb,8.586925e-01_rb,8.663283e-01_rb,8.713217e-01_rb,&
+        & 8.748488e-01_rb,8.774765e-01_rb,8.795122e-01_rb,8.811370e-01_rb,8.824649e-01_rb,&
+        & 8.835711e-01_rb,8.845073e-01_rb,8.853103e-01_rb,8.860068e-01_rb,8.866170e-01_rb,&
+        & 8.871560e-01_rb,8.876358e-01_rb,8.880658e-01_rb,8.884533e-01_rb,8.888044e-01_rb,&
+        & 8.891242e-01_rb,8.894166e-01_rb,8.896851e-01_rb,8.899324e-01_rb,8.901612e-01_rb,&
+        & 8.903733e-01_rb,8.905706e-01_rb,8.907545e-01_rb,8.909265e-01_rb,8.910876e-01_rb,&
+        & 8.912388e-01_rb,8.913812e-01_rb,8.915153e-01_rb,8.916419e-01_rb,8.917617e-01_rb,&
+        & 8.918752e-01_rb,8.919829e-01_rb,8.920851e-01_rb,8.921824e-01_rb,8.922751e-01_rb,&
+        & 8.923635e-01_rb,8.924478e-01_rb,8.925284e-01_rb /)
+      asyice2(:, 23) = (/ &
+! band 23
+        & 8.387642e-01_rb,8.569979e-01_rb,8.658630e-01_rb,8.711825e-01_rb,8.747605e-01_rb,&
+        & 8.773472e-01_rb,8.793129e-01_rb,8.808621e-01_rb,8.821179e-01_rb,8.831583e-01_rb,&
+        & 8.840361e-01_rb,8.847875e-01_rb,8.854388e-01_rb,8.860094e-01_rb,8.865138e-01_rb,&
+        & 8.869634e-01_rb,8.873668e-01_rb,8.877310e-01_rb,8.880617e-01_rb,8.883635e-01_rb,&
+        & 8.886401e-01_rb,8.888947e-01_rb,8.891298e-01_rb,8.893477e-01_rb,8.895504e-01_rb,&
+        & 8.897393e-01_rb,8.899159e-01_rb,8.900815e-01_rb,8.902370e-01_rb,8.903833e-01_rb,&
+        & 8.905214e-01_rb,8.906518e-01_rb,8.907753e-01_rb,8.908924e-01_rb,8.910036e-01_rb,&
+        & 8.911094e-01_rb,8.912101e-01_rb,8.913062e-01_rb,8.913979e-01_rb,8.914856e-01_rb,&
+        & 8.915695e-01_rb,8.916498e-01_rb,8.917269e-01_rb /)
+      asyice2(:, 24) = (/ &
+! band 24
+        & 8.522208e-01_rb,8.648132e-01_rb,8.711224e-01_rb,8.749901e-01_rb,8.776354e-01_rb,&
+        & 8.795743e-01_rb,8.810649e-01_rb,8.822518e-01_rb,8.832225e-01_rb,8.840333e-01_rb,&
+        & 8.847224e-01_rb,8.853162e-01_rb,8.858342e-01_rb,8.862906e-01_rb,8.866962e-01_rb,&
+        & 8.870595e-01_rb,8.873871e-01_rb,8.876842e-01_rb,8.879551e-01_rb,8.882032e-01_rb,&
+        & 8.884316e-01_rb,8.886425e-01_rb,8.888380e-01_rb,8.890199e-01_rb,8.891895e-01_rb,&
+        & 8.893481e-01_rb,8.894968e-01_rb,8.896366e-01_rb,8.897683e-01_rb,8.898926e-01_rb,&
+        & 8.900102e-01_rb,8.901215e-01_rb,8.902272e-01_rb,8.903276e-01_rb,8.904232e-01_rb,&
+        & 8.905144e-01_rb,8.906014e-01_rb,8.906845e-01_rb,8.907640e-01_rb,8.908402e-01_rb,&
+        & 8.909132e-01_rb,8.909834e-01_rb,8.910507e-01_rb /)
+      asyice2(:, 25) = (/ &
+! band 25
+        & 8.578202e-01_rb,8.683033e-01_rb,8.735431e-01_rb,8.767488e-01_rb,8.789378e-01_rb,&
+        & 8.805399e-01_rb,8.817701e-01_rb,8.827485e-01_rb,8.835480e-01_rb,8.842152e-01_rb,&
+        & 8.847817e-01_rb,8.852696e-01_rb,8.856949e-01_rb,8.860694e-01_rb,8.864020e-01_rb,&
+        & 8.866997e-01_rb,8.869681e-01_rb,8.872113e-01_rb,8.874330e-01_rb,8.876360e-01_rb,&
+        & 8.878227e-01_rb,8.879951e-01_rb,8.881548e-01_rb,8.883033e-01_rb,8.884418e-01_rb,&
+        & 8.885712e-01_rb,8.886926e-01_rb,8.888066e-01_rb,8.889139e-01_rb,8.890152e-01_rb,&
+        & 8.891110e-01_rb,8.892017e-01_rb,8.892877e-01_rb,8.893695e-01_rb,8.894473e-01_rb,&
+        & 8.895214e-01_rb,8.895921e-01_rb,8.896597e-01_rb,8.897243e-01_rb,8.897862e-01_rb,&
+        & 8.898456e-01_rb,8.899025e-01_rb,8.899572e-01_rb /)
+      asyice2(:, 26) = (/ &
+! band 26
+        & 8.625615e-01_rb,8.713831e-01_rb,8.755799e-01_rb,8.780560e-01_rb,8.796983e-01_rb,&
+        & 8.808714e-01_rb,8.817534e-01_rb,8.824420e-01_rb,8.829953e-01_rb,8.834501e-01_rb,&
+        & 8.838310e-01_rb,8.841549e-01_rb,8.844338e-01_rb,8.846767e-01_rb,8.848902e-01_rb,&
+        & 8.850795e-01_rb,8.852484e-01_rb,8.854002e-01_rb,8.855374e-01_rb,8.856620e-01_rb,&
+        & 8.857758e-01_rb,8.858800e-01_rb,8.859759e-01_rb,8.860644e-01_rb,8.861464e-01_rb,&
+        & 8.862225e-01_rb,8.862935e-01_rb,8.863598e-01_rb,8.864218e-01_rb,8.864800e-01_rb,&
+        & 8.865347e-01_rb,8.865863e-01_rb,8.866349e-01_rb,8.866809e-01_rb,8.867245e-01_rb,&
+        & 8.867658e-01_rb,8.868050e-01_rb,8.868423e-01_rb,8.868778e-01_rb,8.869117e-01_rb,&
+        & 8.869440e-01_rb,8.869749e-01_rb,8.870044e-01_rb /)
+      asyice2(:, 27) = (/ &
+! band 27
+        & 8.587495e-01_rb,8.684764e-01_rb,8.728189e-01_rb,8.752872e-01_rb,8.768846e-01_rb,&
+        & 8.780060e-01_rb,8.788386e-01_rb,8.794824e-01_rb,8.799960e-01_rb,8.804159e-01_rb,&
+        & 8.807660e-01_rb,8.810626e-01_rb,8.813175e-01_rb,8.815390e-01_rb,8.817335e-01_rb,&
+        & 8.819057e-01_rb,8.820593e-01_rb,8.821973e-01_rb,8.823220e-01_rb,8.824353e-01_rb,&
+        & 8.825387e-01_rb,8.826336e-01_rb,8.827209e-01_rb,8.828016e-01_rb,8.828764e-01_rb,&
+        & 8.829459e-01_rb,8.830108e-01_rb,8.830715e-01_rb,8.831283e-01_rb,8.831817e-01_rb,&
+        & 8.832320e-01_rb,8.832795e-01_rb,8.833244e-01_rb,8.833668e-01_rb,8.834071e-01_rb,&
+        & 8.834454e-01_rb,8.834817e-01_rb,8.835164e-01_rb,8.835495e-01_rb,8.835811e-01_rb,&
+        & 8.836113e-01_rb,8.836402e-01_rb,8.836679e-01_rb /)
+      asyice2(:, 28) = (/ &
+! band 28
+        & 8.561110e-01_rb,8.678583e-01_rb,8.727554e-01_rb,8.753892e-01_rb,8.770154e-01_rb,&
+        & 8.781109e-01_rb,8.788949e-01_rb,8.794812e-01_rb,8.799348e-01_rb,8.802952e-01_rb,&
+        & 8.805880e-01_rb,8.808300e-01_rb,8.810331e-01_rb,8.812058e-01_rb,8.813543e-01_rb,&
+        & 8.814832e-01_rb,8.815960e-01_rb,8.816956e-01_rb,8.817839e-01_rb,8.818629e-01_rb,&
+        & 8.819339e-01_rb,8.819979e-01_rb,8.820560e-01_rb,8.821089e-01_rb,8.821573e-01_rb,&
+        & 8.822016e-01_rb,8.822425e-01_rb,8.822801e-01_rb,8.823150e-01_rb,8.823474e-01_rb,&
+        & 8.823775e-01_rb,8.824056e-01_rb,8.824318e-01_rb,8.824564e-01_rb,8.824795e-01_rb,&
+        & 8.825011e-01_rb,8.825215e-01_rb,8.825408e-01_rb,8.825589e-01_rb,8.825761e-01_rb,&
+        & 8.825924e-01_rb,8.826078e-01_rb,8.826224e-01_rb /)
+      asyice2(:, 29) = (/ &
+! band 29
+        & 8.311124e-01_rb,8.688197e-01_rb,8.900274e-01_rb,9.040696e-01_rb,9.142334e-01_rb,&
+        & 9.220181e-01_rb,9.282195e-01_rb,9.333048e-01_rb,9.375689e-01_rb,9.412085e-01_rb,&
+        & 9.443604e-01_rb,9.471230e-01_rb,9.495694e-01_rb,9.517549e-01_rb,9.537224e-01_rb,&
+        & 9.555057e-01_rb,9.571316e-01_rb,9.586222e-01_rb,9.599952e-01_rb,9.612656e-01_rb,&
+        & 9.624458e-01_rb,9.635461e-01_rb,9.645756e-01_rb,9.655418e-01_rb,9.664513e-01_rb,&
+        & 9.673098e-01_rb,9.681222e-01_rb,9.688928e-01_rb,9.696256e-01_rb,9.703237e-01_rb,&
+        & 9.709903e-01_rb,9.716280e-01_rb,9.722391e-01_rb,9.728258e-01_rb,9.733901e-01_rb,&
+        & 9.739336e-01_rb,9.744579e-01_rb,9.749645e-01_rb,9.754546e-01_rb,9.759294e-01_rb,&
+        & 9.763901e-01_rb,9.768376e-01_rb,9.772727e-01_rb /)
+
+! Hexagonal Ice Particle Parameterization
+! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)]
+      extice3(:, 16) = (/ &
+! band 16
+        & 5.194013e-01_rb,3.215089e-01_rb,2.327917e-01_rb,1.824424e-01_rb,1.499977e-01_rb,&
+        & 1.273492e-01_rb,1.106421e-01_rb,9.780982e-02_rb,8.764435e-02_rb,7.939266e-02_rb,&
+        & 7.256081e-02_rb,6.681137e-02_rb,6.190600e-02_rb,5.767154e-02_rb,5.397915e-02_rb,&
+        & 5.073102e-02_rb,4.785151e-02_rb,4.528125e-02_rb,4.297296e-02_rb,4.088853e-02_rb,&
+        & 3.899690e-02_rb,3.727251e-02_rb,3.569411e-02_rb,3.424393e-02_rb,3.290694e-02_rb,&
+        & 3.167040e-02_rb,3.052340e-02_rb,2.945654e-02_rb,2.846172e-02_rb,2.753188e-02_rb,&
+        & 2.666085e-02_rb,2.584322e-02_rb,2.507423e-02_rb,2.434967e-02_rb,2.366579e-02_rb,&
+        & 2.301926e-02_rb,2.240711e-02_rb,2.182666e-02_rb,2.127551e-02_rb,2.075150e-02_rb,&
+        & 2.025267e-02_rb,1.977725e-02_rb,1.932364e-02_rb,1.889035e-02_rb,1.847607e-02_rb,&
+        & 1.807956e-02_rb /)
+      extice3(:, 17) = (/ &
+! band 17
+        & 4.901155e-01_rb,3.065286e-01_rb,2.230800e-01_rb,1.753951e-01_rb,1.445402e-01_rb,&
+        & 1.229417e-01_rb,1.069777e-01_rb,9.469760e-02_rb,8.495824e-02_rb,7.704501e-02_rb,&
+        & 7.048834e-02_rb,6.496693e-02_rb,6.025353e-02_rb,5.618286e-02_rb,5.263186e-02_rb,&
+        & 4.950698e-02_rb,4.673585e-02_rb,4.426164e-02_rb,4.203904e-02_rb,4.003153e-02_rb,&
+        & 3.820932e-02_rb,3.654790e-02_rb,3.502688e-02_rb,3.362919e-02_rb,3.234041e-02_rb,&
+        & 3.114829e-02_rb,3.004234e-02_rb,2.901356e-02_rb,2.805413e-02_rb,2.715727e-02_rb,&
+        & 2.631705e-02_rb,2.552828e-02_rb,2.478637e-02_rb,2.408725e-02_rb,2.342734e-02_rb,&
+        & 2.280343e-02_rb,2.221264e-02_rb,2.165242e-02_rb,2.112043e-02_rb,2.061461e-02_rb,&
+        & 2.013308e-02_rb,1.967411e-02_rb,1.923616e-02_rb,1.881783e-02_rb,1.841781e-02_rb,&
+        & 1.803494e-02_rb /)
+      extice3(:, 18) = (/ &
+! band 18
+        & 5.056264e-01_rb,3.160261e-01_rb,2.298442e-01_rb,1.805973e-01_rb,1.487318e-01_rb,&
+        & 1.264258e-01_rb,1.099389e-01_rb,9.725656e-02_rb,8.719819e-02_rb,7.902576e-02_rb,&
+        & 7.225433e-02_rb,6.655206e-02_rb,6.168427e-02_rb,5.748028e-02_rb,5.381296e-02_rb,&
+        & 5.058572e-02_rb,4.772383e-02_rb,4.516857e-02_rb,4.287317e-02_rb,4.079990e-02_rb,&
+        & 3.891801e-02_rb,3.720217e-02_rb,3.563133e-02_rb,3.418786e-02_rb,3.285686e-02_rb,&
+        & 3.162569e-02_rb,3.048352e-02_rb,2.942104e-02_rb,2.843018e-02_rb,2.750395e-02_rb,&
+        & 2.663621e-02_rb,2.582160e-02_rb,2.505539e-02_rb,2.433337e-02_rb,2.365185e-02_rb,&
+        & 2.300750e-02_rb,2.239736e-02_rb,2.181878e-02_rb,2.126937e-02_rb,2.074699e-02_rb,&
+        & 2.024968e-02_rb,1.977567e-02_rb,1.932338e-02_rb,1.889134e-02_rb,1.847823e-02_rb,&
+        & 1.808281e-02_rb /)
+      extice3(:, 19) = (/ &
+! band 19
+        & 4.881605e-01_rb,3.055237e-01_rb,2.225070e-01_rb,1.750688e-01_rb,1.443736e-01_rb,&
+        & 1.228869e-01_rb,1.070054e-01_rb,9.478893e-02_rb,8.509997e-02_rb,7.722769e-02_rb,&
+        & 7.070495e-02_rb,6.521211e-02_rb,6.052311e-02_rb,5.647351e-02_rb,5.294088e-02_rb,&
+        & 4.983217e-02_rb,4.707539e-02_rb,4.461398e-02_rb,4.240288e-02_rb,4.040575e-02_rb,&
+        & 3.859298e-02_rb,3.694016e-02_rb,3.542701e-02_rb,3.403655e-02_rb,3.275444e-02_rb,&
+        & 3.156849e-02_rb,3.046827e-02_rb,2.944481e-02_rb,2.849034e-02_rb,2.759812e-02_rb,&
+        & 2.676226e-02_rb,2.597757e-02_rb,2.523949e-02_rb,2.454400e-02_rb,2.388750e-02_rb,&
+        & 2.326682e-02_rb,2.267909e-02_rb,2.212176e-02_rb,2.159253e-02_rb,2.108933e-02_rb,&
+        & 2.061028e-02_rb,2.015369e-02_rb,1.971801e-02_rb,1.930184e-02_rb,1.890389e-02_rb,&
+        & 1.852300e-02_rb /)
+      extice3(:, 20) = (/ &
+! band 20
+        & 5.103703e-01_rb,3.188144e-01_rb,2.317435e-01_rb,1.819887e-01_rb,1.497944e-01_rb,&
+        & 1.272584e-01_rb,1.106013e-01_rb,9.778822e-02_rb,8.762610e-02_rb,7.936938e-02_rb,&
+        & 7.252809e-02_rb,6.676701e-02_rb,6.184901e-02_rb,5.760165e-02_rb,5.389651e-02_rb,&
+        & 5.063598e-02_rb,4.774457e-02_rb,4.516295e-02_rb,4.284387e-02_rb,4.074922e-02_rb,&
+        & 3.884792e-02_rb,3.711438e-02_rb,3.552734e-02_rb,3.406898e-02_rb,3.272425e-02_rb,&
+        & 3.148038e-02_rb,3.032643e-02_rb,2.925299e-02_rb,2.825191e-02_rb,2.731612e-02_rb,&
+        & 2.643943e-02_rb,2.561642e-02_rb,2.484230e-02_rb,2.411284e-02_rb,2.342429e-02_rb,&
+        & 2.277329e-02_rb,2.215686e-02_rb,2.157231e-02_rb,2.101724e-02_rb,2.048946e-02_rb,&
+        & 1.998702e-02_rb,1.950813e-02_rb,1.905118e-02_rb,1.861468e-02_rb,1.819730e-02_rb,&
+        & 1.779781e-02_rb /)
+      extice3(:, 21) = (/ &
+! band 21
+        & 5.031161e-01_rb,3.144511e-01_rb,2.286942e-01_rb,1.796903e-01_rb,1.479819e-01_rb,&
+        & 1.257860e-01_rb,1.093803e-01_rb,9.676059e-02_rb,8.675183e-02_rb,7.861971e-02_rb,&
+        & 7.188168e-02_rb,6.620754e-02_rb,6.136376e-02_rb,5.718050e-02_rb,5.353127e-02_rb,&
+        & 5.031995e-02_rb,4.747218e-02_rb,4.492952e-02_rb,4.264544e-02_rb,4.058240e-02_rb,&
+        & 3.870979e-02_rb,3.700242e-02_rb,3.543933e-02_rb,3.400297e-02_rb,3.267854e-02_rb,&
+        & 3.145345e-02_rb,3.031691e-02_rb,2.925967e-02_rb,2.827370e-02_rb,2.735203e-02_rb,&
+        & 2.648858e-02_rb,2.567798e-02_rb,2.491555e-02_rb,2.419710e-02_rb,2.351893e-02_rb,&
+        & 2.287776e-02_rb,2.227063e-02_rb,2.169491e-02_rb,2.114821e-02_rb,2.062840e-02_rb,&
+        & 2.013354e-02_rb,1.966188e-02_rb,1.921182e-02_rb,1.878191e-02_rb,1.837083e-02_rb,&
+        & 1.797737e-02_rb /)
+      extice3(:, 22) = (/ &
+! band 22
+        & 4.949453e-01_rb,3.095918e-01_rb,2.253402e-01_rb,1.771964e-01_rb,1.460446e-01_rb,&
+        & 1.242383e-01_rb,1.081206e-01_rb,9.572235e-02_rb,8.588928e-02_rb,7.789990e-02_rb,&
+        & 7.128013e-02_rb,6.570559e-02_rb,6.094684e-02_rb,5.683701e-02_rb,5.325183e-02_rb,&
+        & 5.009688e-02_rb,4.729909e-02_rb,4.480106e-02_rb,4.255708e-02_rb,4.053025e-02_rb,&
+        & 3.869051e-02_rb,3.701310e-02_rb,3.547745e-02_rb,3.406631e-02_rb,3.276512e-02_rb,&
+        & 3.156153e-02_rb,3.044494e-02_rb,2.940626e-02_rb,2.843759e-02_rb,2.753211e-02_rb,&
+        & 2.668381e-02_rb,2.588744e-02_rb,2.513839e-02_rb,2.443255e-02_rb,2.376629e-02_rb,&
+        & 2.313637e-02_rb,2.253990e-02_rb,2.197428e-02_rb,2.143718e-02_rb,2.092649e-02_rb,&
+        & 2.044032e-02_rb,1.997694e-02_rb,1.953478e-02_rb,1.911241e-02_rb,1.870855e-02_rb,&
+        & 1.832199e-02_rb /)
+      extice3(:, 23) = (/ &
+! band 23
+        & 5.052816e-01_rb,3.157665e-01_rb,2.296233e-01_rb,1.803986e-01_rb,1.485473e-01_rb,&
+        & 1.262514e-01_rb,1.097718e-01_rb,9.709524e-02_rb,8.704139e-02_rb,7.887264e-02_rb,&
+        & 7.210424e-02_rb,6.640454e-02_rb,6.153894e-02_rb,5.733683e-02_rb,5.367116e-02_rb,&
+        & 5.044537e-02_rb,4.758477e-02_rb,4.503066e-02_rb,4.273629e-02_rb,4.066395e-02_rb,&
+        & 3.878291e-02_rb,3.706784e-02_rb,3.549771e-02_rb,3.405488e-02_rb,3.272448e-02_rb,&
+        & 3.149387e-02_rb,3.035221e-02_rb,2.929020e-02_rb,2.829979e-02_rb,2.737397e-02_rb,&
+        & 2.650663e-02_rb,2.569238e-02_rb,2.492651e-02_rb,2.420482e-02_rb,2.352361e-02_rb,&
+        & 2.287954e-02_rb,2.226968e-02_rb,2.169136e-02_rb,2.114220e-02_rb,2.062005e-02_rb,&
+        & 2.012296e-02_rb,1.964917e-02_rb,1.919709e-02_rb,1.876524e-02_rb,1.835231e-02_rb,&
+        & 1.795707e-02_rb /)
+      extice3(:, 24) = (/ &
+! band 24
+        & 5.042067e-01_rb,3.151195e-01_rb,2.291708e-01_rb,1.800573e-01_rb,1.482779e-01_rb,&
+        & 1.260324e-01_rb,1.095900e-01_rb,9.694202e-02_rb,8.691087e-02_rb,7.876056e-02_rb,&
+        & 7.200745e-02_rb,6.632062e-02_rb,6.146600e-02_rb,5.727338e-02_rb,5.361599e-02_rb,&
+        & 5.039749e-02_rb,4.754334e-02_rb,4.499500e-02_rb,4.270580e-02_rb,4.063815e-02_rb,&
+        & 3.876135e-02_rb,3.705016e-02_rb,3.548357e-02_rb,3.404400e-02_rb,3.271661e-02_rb,&
+        & 3.148877e-02_rb,3.034969e-02_rb,2.929008e-02_rb,2.830191e-02_rb,2.737818e-02_rb,&
+        & 2.651279e-02_rb,2.570039e-02_rb,2.493624e-02_rb,2.421618e-02_rb,2.353650e-02_rb,&
+        & 2.289390e-02_rb,2.228541e-02_rb,2.170840e-02_rb,2.116048e-02_rb,2.063950e-02_rb,&
+        & 2.014354e-02_rb,1.967082e-02_rb,1.921975e-02_rb,1.878888e-02_rb,1.837688e-02_rb,&
+        & 1.798254e-02_rb /)
+      extice3(:, 25) = (/ &
+! band 25
+        & 5.022507e-01_rb,3.139246e-01_rb,2.283218e-01_rb,1.794059e-01_rb,1.477544e-01_rb,&
+        & 1.255984e-01_rb,1.092222e-01_rb,9.662516e-02_rb,8.663439e-02_rb,7.851688e-02_rb,&
+        & 7.179095e-02_rb,6.612700e-02_rb,6.129193e-02_rb,5.711618e-02_rb,5.347351e-02_rb,&
+        & 5.026796e-02_rb,4.742530e-02_rb,4.488721e-02_rb,4.260724e-02_rb,4.054790e-02_rb,&
+        & 3.867866e-02_rb,3.697435e-02_rb,3.541407e-02_rb,3.398029e-02_rb,3.265824e-02_rb,&
+        & 3.143535e-02_rb,3.030085e-02_rb,2.924551e-02_rb,2.826131e-02_rb,2.734130e-02_rb,&
+        & 2.647939e-02_rb,2.567026e-02_rb,2.490919e-02_rb,2.419203e-02_rb,2.351509e-02_rb,&
+        & 2.287507e-02_rb,2.226903e-02_rb,2.169434e-02_rb,2.114862e-02_rb,2.062975e-02_rb,&
+        & 2.013578e-02_rb,1.966496e-02_rb,1.921571e-02_rb,1.878658e-02_rb,1.837623e-02_rb,&
+        & 1.798348e-02_rb /)
+      extice3(:, 26) = (/ &
+! band 26
+        & 5.068316e-01_rb,3.166869e-01_rb,2.302576e-01_rb,1.808693e-01_rb,1.489122e-01_rb,&
+        & 1.265423e-01_rb,1.100080e-01_rb,9.728926e-02_rb,8.720201e-02_rb,7.900612e-02_rb,&
+        & 7.221524e-02_rb,6.649660e-02_rb,6.161484e-02_rb,5.739877e-02_rb,5.372093e-02_rb,&
+        & 5.048442e-02_rb,4.761431e-02_rb,4.505172e-02_rb,4.274972e-02_rb,4.067050e-02_rb,&
+        & 3.878321e-02_rb,3.706244e-02_rb,3.548710e-02_rb,3.403948e-02_rb,3.270466e-02_rb,&
+        & 3.146995e-02_rb,3.032450e-02_rb,2.925897e-02_rb,2.826527e-02_rb,2.733638e-02_rb,&
+        & 2.646615e-02_rb,2.564920e-02_rb,2.488078e-02_rb,2.415670e-02_rb,2.347322e-02_rb,&
+        & 2.282702e-02_rb,2.221513e-02_rb,2.163489e-02_rb,2.108390e-02_rb,2.056002e-02_rb,&
+        & 2.006128e-02_rb,1.958591e-02_rb,1.913232e-02_rb,1.869904e-02_rb,1.828474e-02_rb,&
+        & 1.788819e-02_rb /)
+      extice3(:, 27) = (/ &
+! band 27
+        & 5.077707e-01_rb,3.172636e-01_rb,2.306695e-01_rb,1.811871e-01_rb,1.491691e-01_rb,&
+        & 1.267565e-01_rb,1.101907e-01_rb,9.744773e-02_rb,8.734125e-02_rb,7.912973e-02_rb,&
+        & 7.232591e-02_rb,6.659637e-02_rb,6.170530e-02_rb,5.748120e-02_rb,5.379634e-02_rb,&
+        & 5.055367e-02_rb,4.767809e-02_rb,4.511061e-02_rb,4.280423e-02_rb,4.072104e-02_rb,&
+        & 3.883015e-02_rb,3.710611e-02_rb,3.552776e-02_rb,3.407738e-02_rb,3.274002e-02_rb,&
+        & 3.150296e-02_rb,3.035532e-02_rb,2.928776e-02_rb,2.829216e-02_rb,2.736150e-02_rb,&
+        & 2.648961e-02_rb,2.567111e-02_rb,2.490123e-02_rb,2.417576e-02_rb,2.349098e-02_rb,&
+        & 2.284354e-02_rb,2.223049e-02_rb,2.164914e-02_rb,2.109711e-02_rb,2.057222e-02_rb,&
+        & 2.007253e-02_rb,1.959626e-02_rb,1.914181e-02_rb,1.870770e-02_rb,1.829261e-02_rb,&
+        & 1.789531e-02_rb /)
+      extice3(:, 28) = (/ &
+! band 28
+        & 5.062281e-01_rb,3.163402e-01_rb,2.300275e-01_rb,1.807060e-01_rb,1.487921e-01_rb,&
+        & 1.264523e-01_rb,1.099403e-01_rb,9.723879e-02_rb,8.716516e-02_rb,7.898034e-02_rb,&
+        & 7.219863e-02_rb,6.648771e-02_rb,6.161254e-02_rb,5.740217e-02_rb,5.372929e-02_rb,&
+        & 5.049716e-02_rb,4.763092e-02_rb,4.507179e-02_rb,4.277290e-02_rb,4.069649e-02_rb,&
+        & 3.881175e-02_rb,3.709331e-02_rb,3.552008e-02_rb,3.407442e-02_rb,3.274141e-02_rb,&
+        & 3.150837e-02_rb,3.036447e-02_rb,2.930037e-02_rb,2.830801e-02_rb,2.738037e-02_rb,&
+        & 2.651132e-02_rb,2.569547e-02_rb,2.492810e-02_rb,2.420499e-02_rb,2.352243e-02_rb,&
+        & 2.287710e-02_rb,2.226604e-02_rb,2.168658e-02_rb,2.113634e-02_rb,2.061316e-02_rb,&
+        & 2.011510e-02_rb,1.964038e-02_rb,1.918740e-02_rb,1.875471e-02_rb,1.834096e-02_rb,&
+        & 1.794495e-02_rb /)
+      extice3(:, 29) = (/ &
+! band 29
+        & 1.338834e-01_rb,1.924912e-01_rb,1.755523e-01_rb,1.534793e-01_rb,1.343937e-01_rb,&
+        & 1.187883e-01_rb,1.060654e-01_rb,9.559106e-02_rb,8.685880e-02_rb,7.948698e-02_rb,&
+        & 7.319086e-02_rb,6.775669e-02_rb,6.302215e-02_rb,5.886236e-02_rb,5.517996e-02_rb,&
+        & 5.189810e-02_rb,4.895539e-02_rb,4.630225e-02_rb,4.389823e-02_rb,4.171002e-02_rb,&
+        & 3.970998e-02_rb,3.787493e-02_rb,3.618537e-02_rb,3.462471e-02_rb,3.317880e-02_rb,&
+        & 3.183547e-02_rb,3.058421e-02_rb,2.941590e-02_rb,2.832256e-02_rb,2.729724e-02_rb,&
+        & 2.633377e-02_rb,2.542675e-02_rb,2.457136e-02_rb,2.376332e-02_rb,2.299882e-02_rb,&
+        & 2.227443e-02_rb,2.158707e-02_rb,2.093400e-02_rb,2.031270e-02_rb,1.972091e-02_rb,&
+        & 1.915659e-02_rb,1.861787e-02_rb,1.810304e-02_rb,1.761055e-02_rb,1.713899e-02_rb,&
+        & 1.668704e-02_rb /)
+
+! single-scattering albedo: unitless
+      ssaice3(:, 16) = (/ &
+! band 16
+        & 6.749442e-01_rb,6.649947e-01_rb,6.565828e-01_rb,6.489928e-01_rb,6.420046e-01_rb,&
+        & 6.355231e-01_rb,6.294964e-01_rb,6.238901e-01_rb,6.186783e-01_rb,6.138395e-01_rb,&
+        & 6.093543e-01_rb,6.052049e-01_rb,6.013742e-01_rb,5.978457e-01_rb,5.946030e-01_rb,&
+        & 5.916302e-01_rb,5.889115e-01_rb,5.864310e-01_rb,5.841731e-01_rb,5.821221e-01_rb,&
+        & 5.802624e-01_rb,5.785785e-01_rb,5.770549e-01_rb,5.756759e-01_rb,5.744262e-01_rb,&
+        & 5.732901e-01_rb,5.722524e-01_rb,5.712974e-01_rb,5.704097e-01_rb,5.695739e-01_rb,&
+        & 5.687747e-01_rb,5.679964e-01_rb,5.672238e-01_rb,5.664415e-01_rb,5.656340e-01_rb,&
+        & 5.647860e-01_rb,5.638821e-01_rb,5.629070e-01_rb,5.618452e-01_rb,5.606815e-01_rb,&
+        & 5.594006e-01_rb,5.579870e-01_rb,5.564255e-01_rb,5.547008e-01_rb,5.527976e-01_rb,&
+        & 5.507005e-01_rb /)
+      ssaice3(:, 17) = (/ &
+! band 17
+        & 7.628550e-01_rb,7.567297e-01_rb,7.508463e-01_rb,7.451972e-01_rb,7.397745e-01_rb,&
+        & 7.345705e-01_rb,7.295775e-01_rb,7.247881e-01_rb,7.201945e-01_rb,7.157894e-01_rb,&
+        & 7.115652e-01_rb,7.075145e-01_rb,7.036300e-01_rb,6.999044e-01_rb,6.963304e-01_rb,&
+        & 6.929007e-01_rb,6.896083e-01_rb,6.864460e-01_rb,6.834067e-01_rb,6.804833e-01_rb,&
+        & 6.776690e-01_rb,6.749567e-01_rb,6.723397e-01_rb,6.698109e-01_rb,6.673637e-01_rb,&
+        & 6.649913e-01_rb,6.626870e-01_rb,6.604441e-01_rb,6.582561e-01_rb,6.561163e-01_rb,&
+        & 6.540182e-01_rb,6.519554e-01_rb,6.499215e-01_rb,6.479099e-01_rb,6.459145e-01_rb,&
+        & 6.439289e-01_rb,6.419468e-01_rb,6.399621e-01_rb,6.379686e-01_rb,6.359601e-01_rb,&
+        & 6.339306e-01_rb,6.318740e-01_rb,6.297845e-01_rb,6.276559e-01_rb,6.254825e-01_rb,&
+        & 6.232583e-01_rb /)
+      ssaice3(:, 18) = (/ &
+! band 18
+        & 9.924147e-01_rb,9.882792e-01_rb,9.842257e-01_rb,9.802522e-01_rb,9.763566e-01_rb,&
+        & 9.725367e-01_rb,9.687905e-01_rb,9.651157e-01_rb,9.615104e-01_rb,9.579725e-01_rb,&
+        & 9.544997e-01_rb,9.510901e-01_rb,9.477416e-01_rb,9.444520e-01_rb,9.412194e-01_rb,&
+        & 9.380415e-01_rb,9.349165e-01_rb,9.318421e-01_rb,9.288164e-01_rb,9.258373e-01_rb,&
+        & 9.229027e-01_rb,9.200106e-01_rb,9.171589e-01_rb,9.143457e-01_rb,9.115688e-01_rb,&
+        & 9.088263e-01_rb,9.061161e-01_rb,9.034362e-01_rb,9.007846e-01_rb,8.981592e-01_rb,&
+        & 8.955581e-01_rb,8.929792e-01_rb,8.904206e-01_rb,8.878803e-01_rb,8.853562e-01_rb,&
+        & 8.828464e-01_rb,8.803488e-01_rb,8.778616e-01_rb,8.753827e-01_rb,8.729102e-01_rb,&
+        & 8.704421e-01_rb,8.679764e-01_rb,8.655112e-01_rb,8.630445e-01_rb,8.605744e-01_rb,&
+        & 8.580989e-01_rb /)
+      ssaice3(:, 19) = (/ &
+! band 19
+        & 9.629413e-01_rb,9.517182e-01_rb,9.409209e-01_rb,9.305366e-01_rb,9.205529e-01_rb,&
+        & 9.109569e-01_rb,9.017362e-01_rb,8.928780e-01_rb,8.843699e-01_rb,8.761992e-01_rb,&
+        & 8.683536e-01_rb,8.608204e-01_rb,8.535873e-01_rb,8.466417e-01_rb,8.399712e-01_rb,&
+        & 8.335635e-01_rb,8.274062e-01_rb,8.214868e-01_rb,8.157932e-01_rb,8.103129e-01_rb,&
+        & 8.050336e-01_rb,7.999432e-01_rb,7.950294e-01_rb,7.902798e-01_rb,7.856825e-01_rb,&
+        & 7.812250e-01_rb,7.768954e-01_rb,7.726815e-01_rb,7.685711e-01_rb,7.645522e-01_rb,&
+        & 7.606126e-01_rb,7.567404e-01_rb,7.529234e-01_rb,7.491498e-01_rb,7.454074e-01_rb,&
+        & 7.416844e-01_rb,7.379688e-01_rb,7.342485e-01_rb,7.305118e-01_rb,7.267468e-01_rb,&
+        & 7.229415e-01_rb,7.190841e-01_rb,7.151628e-01_rb,7.111657e-01_rb,7.070811e-01_rb,&
+        & 7.028972e-01_rb /)
+      ssaice3(:, 20) = (/ &
+! band 20
+        & 9.942270e-01_rb,9.909206e-01_rb,9.876775e-01_rb,9.844960e-01_rb,9.813746e-01_rb,&
+        & 9.783114e-01_rb,9.753049e-01_rb,9.723535e-01_rb,9.694553e-01_rb,9.666088e-01_rb,&
+        & 9.638123e-01_rb,9.610641e-01_rb,9.583626e-01_rb,9.557060e-01_rb,9.530928e-01_rb,&
+        & 9.505211e-01_rb,9.479895e-01_rb,9.454961e-01_rb,9.430393e-01_rb,9.406174e-01_rb,&
+        & 9.382288e-01_rb,9.358717e-01_rb,9.335446e-01_rb,9.312456e-01_rb,9.289731e-01_rb,&
+        & 9.267255e-01_rb,9.245010e-01_rb,9.222980e-01_rb,9.201147e-01_rb,9.179496e-01_rb,&
+        & 9.158008e-01_rb,9.136667e-01_rb,9.115457e-01_rb,9.094359e-01_rb,9.073358e-01_rb,&
+        & 9.052436e-01_rb,9.031577e-01_rb,9.010763e-01_rb,8.989977e-01_rb,8.969203e-01_rb,&
+        & 8.948423e-01_rb,8.927620e-01_rb,8.906778e-01_rb,8.885879e-01_rb,8.864907e-01_rb,&
+        & 8.843843e-01_rb /)
+      ssaice3(:, 21) = (/ &
+! band 21
+        & 9.934014e-01_rb,9.899331e-01_rb,9.865537e-01_rb,9.832610e-01_rb,9.800523e-01_rb,&
+        & 9.769254e-01_rb,9.738777e-01_rb,9.709069e-01_rb,9.680106e-01_rb,9.651862e-01_rb,&
+        & 9.624315e-01_rb,9.597439e-01_rb,9.571212e-01_rb,9.545608e-01_rb,9.520605e-01_rb,&
+        & 9.496177e-01_rb,9.472301e-01_rb,9.448954e-01_rb,9.426111e-01_rb,9.403749e-01_rb,&
+        & 9.381843e-01_rb,9.360370e-01_rb,9.339307e-01_rb,9.318629e-01_rb,9.298313e-01_rb,&
+        & 9.278336e-01_rb,9.258673e-01_rb,9.239302e-01_rb,9.220198e-01_rb,9.201338e-01_rb,&
+        & 9.182700e-01_rb,9.164258e-01_rb,9.145991e-01_rb,9.127874e-01_rb,9.109884e-01_rb,&
+        & 9.091999e-01_rb,9.074194e-01_rb,9.056447e-01_rb,9.038735e-01_rb,9.021033e-01_rb,&
+        & 9.003320e-01_rb,8.985572e-01_rb,8.967766e-01_rb,8.949879e-01_rb,8.931888e-01_rb,&
+        & 8.913770e-01_rb /)
+      ssaice3(:, 22) = (/ &
+! band 22
+        & 9.994833e-01_rb,9.992055e-01_rb,9.989278e-01_rb,9.986500e-01_rb,9.983724e-01_rb,&
+        & 9.980947e-01_rb,9.978172e-01_rb,9.975397e-01_rb,9.972623e-01_rb,9.969849e-01_rb,&
+        & 9.967077e-01_rb,9.964305e-01_rb,9.961535e-01_rb,9.958765e-01_rb,9.955997e-01_rb,&
+        & 9.953230e-01_rb,9.950464e-01_rb,9.947699e-01_rb,9.944936e-01_rb,9.942174e-01_rb,&
+        & 9.939414e-01_rb,9.936656e-01_rb,9.933899e-01_rb,9.931144e-01_rb,9.928390e-01_rb,&
+        & 9.925639e-01_rb,9.922889e-01_rb,9.920141e-01_rb,9.917396e-01_rb,9.914652e-01_rb,&
+        & 9.911911e-01_rb,9.909171e-01_rb,9.906434e-01_rb,9.903700e-01_rb,9.900967e-01_rb,&
+        & 9.898237e-01_rb,9.895510e-01_rb,9.892784e-01_rb,9.890062e-01_rb,9.887342e-01_rb,&
+        & 9.884625e-01_rb,9.881911e-01_rb,9.879199e-01_rb,9.876490e-01_rb,9.873784e-01_rb,&
+        & 9.871081e-01_rb /)
+      ssaice3(:, 23) = (/ &
+! band 23
+        & 9.999343e-01_rb,9.998917e-01_rb,9.998492e-01_rb,9.998067e-01_rb,9.997642e-01_rb,&
+        & 9.997218e-01_rb,9.996795e-01_rb,9.996372e-01_rb,9.995949e-01_rb,9.995528e-01_rb,&
+        & 9.995106e-01_rb,9.994686e-01_rb,9.994265e-01_rb,9.993845e-01_rb,9.993426e-01_rb,&
+        & 9.993007e-01_rb,9.992589e-01_rb,9.992171e-01_rb,9.991754e-01_rb,9.991337e-01_rb,&
+        & 9.990921e-01_rb,9.990505e-01_rb,9.990089e-01_rb,9.989674e-01_rb,9.989260e-01_rb,&
+        & 9.988846e-01_rb,9.988432e-01_rb,9.988019e-01_rb,9.987606e-01_rb,9.987194e-01_rb,&
+        & 9.986782e-01_rb,9.986370e-01_rb,9.985959e-01_rb,9.985549e-01_rb,9.985139e-01_rb,&
+        & 9.984729e-01_rb,9.984319e-01_rb,9.983910e-01_rb,9.983502e-01_rb,9.983094e-01_rb,&
+        & 9.982686e-01_rb,9.982279e-01_rb,9.981872e-01_rb,9.981465e-01_rb,9.981059e-01_rb,&
+        & 9.980653e-01_rb /)
+      ssaice3(:, 24) = (/ &
+! band 24
+        & 9.999978e-01_rb,9.999965e-01_rb,9.999952e-01_rb,9.999939e-01_rb,9.999926e-01_rb,&
+        & 9.999913e-01_rb,9.999900e-01_rb,9.999887e-01_rb,9.999873e-01_rb,9.999860e-01_rb,&
+        & 9.999847e-01_rb,9.999834e-01_rb,9.999821e-01_rb,9.999808e-01_rb,9.999795e-01_rb,&
+        & 9.999782e-01_rb,9.999769e-01_rb,9.999756e-01_rb,9.999743e-01_rb,9.999730e-01_rb,&
+        & 9.999717e-01_rb,9.999704e-01_rb,9.999691e-01_rb,9.999678e-01_rb,9.999665e-01_rb,&
+        & 9.999652e-01_rb,9.999639e-01_rb,9.999626e-01_rb,9.999613e-01_rb,9.999600e-01_rb,&
+        & 9.999587e-01_rb,9.999574e-01_rb,9.999561e-01_rb,9.999548e-01_rb,9.999535e-01_rb,&
+        & 9.999522e-01_rb,9.999509e-01_rb,9.999496e-01_rb,9.999483e-01_rb,9.999470e-01_rb,&
+        & 9.999457e-01_rb,9.999444e-01_rb,9.999431e-01_rb,9.999418e-01_rb,9.999405e-01_rb,&
+        & 9.999392e-01_rb /)
+      ssaice3(:, 25) = (/ &
+! band 25
+        & 9.999994e-01_rb,9.999993e-01_rb,9.999991e-01_rb,9.999990e-01_rb,9.999989e-01_rb,&
+        & 9.999987e-01_rb,9.999986e-01_rb,9.999984e-01_rb,9.999983e-01_rb,9.999982e-01_rb,&
+        & 9.999980e-01_rb,9.999979e-01_rb,9.999977e-01_rb,9.999976e-01_rb,9.999975e-01_rb,&
+        & 9.999973e-01_rb,9.999972e-01_rb,9.999970e-01_rb,9.999969e-01_rb,9.999967e-01_rb,&
+        & 9.999966e-01_rb,9.999965e-01_rb,9.999963e-01_rb,9.999962e-01_rb,9.999960e-01_rb,&
+        & 9.999959e-01_rb,9.999957e-01_rb,9.999956e-01_rb,9.999954e-01_rb,9.999953e-01_rb,&
+        & 9.999952e-01_rb,9.999950e-01_rb,9.999949e-01_rb,9.999947e-01_rb,9.999946e-01_rb,&
+        & 9.999944e-01_rb,9.999943e-01_rb,9.999941e-01_rb,9.999940e-01_rb,9.999939e-01_rb,&
+        & 9.999937e-01_rb,9.999936e-01_rb,9.999934e-01_rb,9.999933e-01_rb,9.999931e-01_rb,&
+        & 9.999930e-01_rb /)
+      ssaice3(:, 26) = (/ &
+! band 26
+        & 9.999997e-01_rb,9.999995e-01_rb,9.999992e-01_rb,9.999990e-01_rb,9.999987e-01_rb,&
+        & 9.999985e-01_rb,9.999983e-01_rb,9.999980e-01_rb,9.999978e-01_rb,9.999976e-01_rb,&
+        & 9.999973e-01_rb,9.999971e-01_rb,9.999969e-01_rb,9.999967e-01_rb,9.999965e-01_rb,&
+        & 9.999963e-01_rb,9.999960e-01_rb,9.999958e-01_rb,9.999956e-01_rb,9.999954e-01_rb,&
+        & 9.999952e-01_rb,9.999950e-01_rb,9.999948e-01_rb,9.999946e-01_rb,9.999944e-01_rb,&
+        & 9.999942e-01_rb,9.999939e-01_rb,9.999937e-01_rb,9.999935e-01_rb,9.999933e-01_rb,&
+        & 9.999931e-01_rb,9.999929e-01_rb,9.999927e-01_rb,9.999925e-01_rb,9.999923e-01_rb,&
+        & 9.999920e-01_rb,9.999918e-01_rb,9.999916e-01_rb,9.999914e-01_rb,9.999911e-01_rb,&
+        & 9.999909e-01_rb,9.999907e-01_rb,9.999905e-01_rb,9.999902e-01_rb,9.999900e-01_rb,&
+        & 9.999897e-01_rb /)
+      ssaice3(:, 27) = (/ &
+! band 27
+        & 9.999991e-01_rb,9.999985e-01_rb,9.999980e-01_rb,9.999974e-01_rb,9.999968e-01_rb,&
+        & 9.999963e-01_rb,9.999957e-01_rb,9.999951e-01_rb,9.999946e-01_rb,9.999940e-01_rb,&
+        & 9.999934e-01_rb,9.999929e-01_rb,9.999923e-01_rb,9.999918e-01_rb,9.999912e-01_rb,&
+        & 9.999907e-01_rb,9.999901e-01_rb,9.999896e-01_rb,9.999891e-01_rb,9.999885e-01_rb,&
+        & 9.999880e-01_rb,9.999874e-01_rb,9.999869e-01_rb,9.999863e-01_rb,9.999858e-01_rb,&
+        & 9.999853e-01_rb,9.999847e-01_rb,9.999842e-01_rb,9.999836e-01_rb,9.999831e-01_rb,&
+        & 9.999826e-01_rb,9.999820e-01_rb,9.999815e-01_rb,9.999809e-01_rb,9.999804e-01_rb,&
+        & 9.999798e-01_rb,9.999793e-01_rb,9.999787e-01_rb,9.999782e-01_rb,9.999776e-01_rb,&
+        & 9.999770e-01_rb,9.999765e-01_rb,9.999759e-01_rb,9.999754e-01_rb,9.999748e-01_rb,&
+        & 9.999742e-01_rb /)
+      ssaice3(:, 28) = (/ &
+! band 28
+        & 9.999975e-01_rb,9.999961e-01_rb,9.999946e-01_rb,9.999931e-01_rb,9.999917e-01_rb,&
+        & 9.999903e-01_rb,9.999888e-01_rb,9.999874e-01_rb,9.999859e-01_rb,9.999845e-01_rb,&
+        & 9.999831e-01_rb,9.999816e-01_rb,9.999802e-01_rb,9.999788e-01_rb,9.999774e-01_rb,&
+        & 9.999759e-01_rb,9.999745e-01_rb,9.999731e-01_rb,9.999717e-01_rb,9.999702e-01_rb,&
+        & 9.999688e-01_rb,9.999674e-01_rb,9.999660e-01_rb,9.999646e-01_rb,9.999631e-01_rb,&
+        & 9.999617e-01_rb,9.999603e-01_rb,9.999589e-01_rb,9.999574e-01_rb,9.999560e-01_rb,&
+        & 9.999546e-01_rb,9.999532e-01_rb,9.999517e-01_rb,9.999503e-01_rb,9.999489e-01_rb,&
+        & 9.999474e-01_rb,9.999460e-01_rb,9.999446e-01_rb,9.999431e-01_rb,9.999417e-01_rb,&
+        & 9.999403e-01_rb,9.999388e-01_rb,9.999374e-01_rb,9.999359e-01_rb,9.999345e-01_rb,&
+        & 9.999330e-01_rb /)
+      ssaice3(:, 29) = (/ &
+! band 29
+        & 4.526500e-01_rb,5.287890e-01_rb,5.410487e-01_rb,5.459865e-01_rb,5.485149e-01_rb,&
+        & 5.498914e-01_rb,5.505895e-01_rb,5.508310e-01_rb,5.507364e-01_rb,5.503793e-01_rb,&
+        & 5.498090e-01_rb,5.490612e-01_rb,5.481637e-01_rb,5.471395e-01_rb,5.460083e-01_rb,&
+        & 5.447878e-01_rb,5.434946e-01_rb,5.421442e-01_rb,5.407514e-01_rb,5.393309e-01_rb,&
+        & 5.378970e-01_rb,5.364641e-01_rb,5.350464e-01_rb,5.336582e-01_rb,5.323140e-01_rb,&
+        & 5.310283e-01_rb,5.298158e-01_rb,5.286914e-01_rb,5.276704e-01_rb,5.267680e-01_rb,&
+        & 5.260000e-01_rb,5.253823e-01_rb,5.249311e-01_rb,5.246629e-01_rb,5.245946e-01_rb,&
+        & 5.247434e-01_rb,5.251268e-01_rb,5.257626e-01_rb,5.266693e-01_rb,5.278653e-01_rb,&
+        & 5.293698e-01_rb,5.312022e-01_rb,5.333823e-01_rb,5.359305e-01_rb,5.388676e-01_rb,&
+        & 5.422146e-01_rb /)
+
+! asymmetry factor: unitless
+      asyice3(:, 16) = (/ &
+! band 16
+        & 8.340752e-01_rb,8.435170e-01_rb,8.517487e-01_rb,8.592064e-01_rb,8.660387e-01_rb,&
+        & 8.723204e-01_rb,8.780997e-01_rb,8.834137e-01_rb,8.882934e-01_rb,8.927662e-01_rb,&
+        & 8.968577e-01_rb,9.005914e-01_rb,9.039899e-01_rb,9.070745e-01_rb,9.098659e-01_rb,&
+        & 9.123836e-01_rb,9.146466e-01_rb,9.166734e-01_rb,9.184817e-01_rb,9.200886e-01_rb,&
+        & 9.215109e-01_rb,9.227648e-01_rb,9.238661e-01_rb,9.248304e-01_rb,9.256727e-01_rb,&
+        & 9.264078e-01_rb,9.270505e-01_rb,9.276150e-01_rb,9.281156e-01_rb,9.285662e-01_rb,&
+        & 9.289806e-01_rb,9.293726e-01_rb,9.297557e-01_rb,9.301435e-01_rb,9.305491e-01_rb,&
+        & 9.309859e-01_rb,9.314671e-01_rb,9.320055e-01_rb,9.326140e-01_rb,9.333053e-01_rb,&
+        & 9.340919e-01_rb,9.349861e-01_rb,9.360000e-01_rb,9.371451e-01_rb,9.384329e-01_rb,&
+        & 9.398744e-01_rb /)
+      asyice3(:, 17) = (/ &
+! band 17
+        & 8.728160e-01_rb,8.777333e-01_rb,8.823754e-01_rb,8.867535e-01_rb,8.908785e-01_rb,&
+        & 8.947611e-01_rb,8.984118e-01_rb,9.018408e-01_rb,9.050582e-01_rb,9.080739e-01_rb,&
+        & 9.108976e-01_rb,9.135388e-01_rb,9.160068e-01_rb,9.183106e-01_rb,9.204595e-01_rb,&
+        & 9.224620e-01_rb,9.243271e-01_rb,9.260632e-01_rb,9.276788e-01_rb,9.291822e-01_rb,&
+        & 9.305817e-01_rb,9.318853e-01_rb,9.331012e-01_rb,9.342372e-01_rb,9.353013e-01_rb,&
+        & 9.363013e-01_rb,9.372450e-01_rb,9.381400e-01_rb,9.389939e-01_rb,9.398145e-01_rb,&
+        & 9.406092e-01_rb,9.413856e-01_rb,9.421511e-01_rb,9.429131e-01_rb,9.436790e-01_rb,&
+        & 9.444561e-01_rb,9.452517e-01_rb,9.460729e-01_rb,9.469270e-01_rb,9.478209e-01_rb,&
+        & 9.487617e-01_rb,9.497562e-01_rb,9.508112e-01_rb,9.519335e-01_rb,9.531294e-01_rb,&
+        & 9.544055e-01_rb /)
+      asyice3(:, 18) = (/ &
+! band 18
+        & 7.897566e-01_rb,7.948704e-01_rb,7.998041e-01_rb,8.045623e-01_rb,8.091495e-01_rb,&
+        & 8.135702e-01_rb,8.178290e-01_rb,8.219305e-01_rb,8.258790e-01_rb,8.296792e-01_rb,&
+        & 8.333355e-01_rb,8.368524e-01_rb,8.402343e-01_rb,8.434856e-01_rb,8.466108e-01_rb,&
+        & 8.496143e-01_rb,8.525004e-01_rb,8.552737e-01_rb,8.579384e-01_rb,8.604990e-01_rb,&
+        & 8.629597e-01_rb,8.653250e-01_rb,8.675992e-01_rb,8.697867e-01_rb,8.718916e-01_rb,&
+        & 8.739185e-01_rb,8.758715e-01_rb,8.777551e-01_rb,8.795734e-01_rb,8.813308e-01_rb,&
+        & 8.830315e-01_rb,8.846799e-01_rb,8.862802e-01_rb,8.878366e-01_rb,8.893534e-01_rb,&
+        & 8.908350e-01_rb,8.922854e-01_rb,8.937090e-01_rb,8.951099e-01_rb,8.964925e-01_rb,&
+        & 8.978609e-01_rb,8.992192e-01_rb,9.005718e-01_rb,9.019229e-01_rb,9.032765e-01_rb,&
+        & 9.046369e-01_rb /)
+      asyice3(:, 19) = (/ &
+! band 19
+        & 7.812615e-01_rb,7.887764e-01_rb,7.959664e-01_rb,8.028413e-01_rb,8.094109e-01_rb,&
+        & 8.156849e-01_rb,8.216730e-01_rb,8.273846e-01_rb,8.328294e-01_rb,8.380166e-01_rb,&
+        & 8.429556e-01_rb,8.476556e-01_rb,8.521258e-01_rb,8.563753e-01_rb,8.604131e-01_rb,&
+        & 8.642481e-01_rb,8.678893e-01_rb,8.713455e-01_rb,8.746254e-01_rb,8.777378e-01_rb,&
+        & 8.806914e-01_rb,8.834948e-01_rb,8.861566e-01_rb,8.886854e-01_rb,8.910897e-01_rb,&
+        & 8.933779e-01_rb,8.955586e-01_rb,8.976402e-01_rb,8.996311e-01_rb,9.015398e-01_rb,&
+        & 9.033745e-01_rb,9.051436e-01_rb,9.068555e-01_rb,9.085185e-01_rb,9.101410e-01_rb,&
+        & 9.117311e-01_rb,9.132972e-01_rb,9.148476e-01_rb,9.163905e-01_rb,9.179340e-01_rb,&
+        & 9.194864e-01_rb,9.210559e-01_rb,9.226505e-01_rb,9.242784e-01_rb,9.259476e-01_rb,&
+        & 9.276661e-01_rb /)
+      asyice3(:, 20) = (/ &
+! band 20
+        & 7.640720e-01_rb,7.691119e-01_rb,7.739941e-01_rb,7.787222e-01_rb,7.832998e-01_rb,&
+        & 7.877304e-01_rb,7.920177e-01_rb,7.961652e-01_rb,8.001765e-01_rb,8.040551e-01_rb,&
+        & 8.078044e-01_rb,8.114280e-01_rb,8.149294e-01_rb,8.183119e-01_rb,8.215791e-01_rb,&
+        & 8.247344e-01_rb,8.277812e-01_rb,8.307229e-01_rb,8.335629e-01_rb,8.363046e-01_rb,&
+        & 8.389514e-01_rb,8.415067e-01_rb,8.439738e-01_rb,8.463560e-01_rb,8.486568e-01_rb,&
+        & 8.508795e-01_rb,8.530274e-01_rb,8.551039e-01_rb,8.571122e-01_rb,8.590558e-01_rb,&
+        & 8.609378e-01_rb,8.627618e-01_rb,8.645309e-01_rb,8.662485e-01_rb,8.679178e-01_rb,&
+        & 8.695423e-01_rb,8.711251e-01_rb,8.726697e-01_rb,8.741792e-01_rb,8.756571e-01_rb,&
+        & 8.771065e-01_rb,8.785307e-01_rb,8.799331e-01_rb,8.813169e-01_rb,8.826854e-01_rb,&
+        & 8.840419e-01_rb /)
+      asyice3(:, 21) = (/ &
+! band 21
+        & 7.602598e-01_rb,7.651572e-01_rb,7.699014e-01_rb,7.744962e-01_rb,7.789452e-01_rb,&
+        & 7.832522e-01_rb,7.874205e-01_rb,7.914538e-01_rb,7.953555e-01_rb,7.991290e-01_rb,&
+        & 8.027777e-01_rb,8.063049e-01_rb,8.097140e-01_rb,8.130081e-01_rb,8.161906e-01_rb,&
+        & 8.192645e-01_rb,8.222331e-01_rb,8.250993e-01_rb,8.278664e-01_rb,8.305374e-01_rb,&
+        & 8.331153e-01_rb,8.356030e-01_rb,8.380037e-01_rb,8.403201e-01_rb,8.425553e-01_rb,&
+        & 8.447121e-01_rb,8.467935e-01_rb,8.488022e-01_rb,8.507412e-01_rb,8.526132e-01_rb,&
+        & 8.544210e-01_rb,8.561675e-01_rb,8.578554e-01_rb,8.594875e-01_rb,8.610665e-01_rb,&
+        & 8.625951e-01_rb,8.640760e-01_rb,8.655119e-01_rb,8.669055e-01_rb,8.682594e-01_rb,&
+        & 8.695763e-01_rb,8.708587e-01_rb,8.721094e-01_rb,8.733308e-01_rb,8.745255e-01_rb,&
+        & 8.756961e-01_rb /)
+      asyice3(:, 22) = (/ &
+! band 22
+        & 7.568957e-01_rb,7.606995e-01_rb,7.644072e-01_rb,7.680204e-01_rb,7.715402e-01_rb,&
+        & 7.749682e-01_rb,7.783057e-01_rb,7.815541e-01_rb,7.847148e-01_rb,7.877892e-01_rb,&
+        & 7.907786e-01_rb,7.936846e-01_rb,7.965084e-01_rb,7.992515e-01_rb,8.019153e-01_rb,&
+        & 8.045011e-01_rb,8.070103e-01_rb,8.094444e-01_rb,8.118048e-01_rb,8.140927e-01_rb,&
+        & 8.163097e-01_rb,8.184571e-01_rb,8.205364e-01_rb,8.225488e-01_rb,8.244958e-01_rb,&
+        & 8.263789e-01_rb,8.281993e-01_rb,8.299586e-01_rb,8.316580e-01_rb,8.332991e-01_rb,&
+        & 8.348831e-01_rb,8.364115e-01_rb,8.378857e-01_rb,8.393071e-01_rb,8.406770e-01_rb,&
+        & 8.419969e-01_rb,8.432682e-01_rb,8.444923e-01_rb,8.456706e-01_rb,8.468044e-01_rb,&
+        & 8.478952e-01_rb,8.489444e-01_rb,8.499533e-01_rb,8.509234e-01_rb,8.518561e-01_rb,&
+        & 8.527528e-01_rb /)
+      asyice3(:, 23) = (/ &
+! band 23
+        & 7.575066e-01_rb,7.606912e-01_rb,7.638236e-01_rb,7.669035e-01_rb,7.699306e-01_rb,&
+        & 7.729046e-01_rb,7.758254e-01_rb,7.786926e-01_rb,7.815060e-01_rb,7.842654e-01_rb,&
+        & 7.869705e-01_rb,7.896211e-01_rb,7.922168e-01_rb,7.947574e-01_rb,7.972428e-01_rb,&
+        & 7.996726e-01_rb,8.020466e-01_rb,8.043646e-01_rb,8.066262e-01_rb,8.088313e-01_rb,&
+        & 8.109796e-01_rb,8.130709e-01_rb,8.151049e-01_rb,8.170814e-01_rb,8.190001e-01_rb,&
+        & 8.208608e-01_rb,8.226632e-01_rb,8.244071e-01_rb,8.260924e-01_rb,8.277186e-01_rb,&
+        & 8.292856e-01_rb,8.307932e-01_rb,8.322411e-01_rb,8.336291e-01_rb,8.349570e-01_rb,&
+        & 8.362244e-01_rb,8.374312e-01_rb,8.385772e-01_rb,8.396621e-01_rb,8.406856e-01_rb,&
+        & 8.416476e-01_rb,8.425479e-01_rb,8.433861e-01_rb,8.441620e-01_rb,8.448755e-01_rb,&
+        & 8.455263e-01_rb /)
+      asyice3(:, 24) = (/ &
+! band 24
+        & 7.568829e-01_rb,7.597947e-01_rb,7.626745e-01_rb,7.655212e-01_rb,7.683337e-01_rb,&
+        & 7.711111e-01_rb,7.738523e-01_rb,7.765565e-01_rb,7.792225e-01_rb,7.818494e-01_rb,&
+        & 7.844362e-01_rb,7.869819e-01_rb,7.894854e-01_rb,7.919459e-01_rb,7.943623e-01_rb,&
+        & 7.967337e-01_rb,7.990590e-01_rb,8.013373e-01_rb,8.035676e-01_rb,8.057488e-01_rb,&
+        & 8.078802e-01_rb,8.099605e-01_rb,8.119890e-01_rb,8.139645e-01_rb,8.158862e-01_rb,&
+        & 8.177530e-01_rb,8.195641e-01_rb,8.213183e-01_rb,8.230149e-01_rb,8.246527e-01_rb,&
+        & 8.262308e-01_rb,8.277483e-01_rb,8.292042e-01_rb,8.305976e-01_rb,8.319275e-01_rb,&
+        & 8.331929e-01_rb,8.343929e-01_rb,8.355265e-01_rb,8.365928e-01_rb,8.375909e-01_rb,&
+        & 8.385197e-01_rb,8.393784e-01_rb,8.401659e-01_rb,8.408815e-01_rb,8.415240e-01_rb,&
+        & 8.420926e-01_rb /)
+      asyice3(:, 25) = (/ &
+! band 25
+        & 7.548616e-01_rb,7.575454e-01_rb,7.602153e-01_rb,7.628696e-01_rb,7.655067e-01_rb,&
+        & 7.681249e-01_rb,7.707225e-01_rb,7.732978e-01_rb,7.758492e-01_rb,7.783750e-01_rb,&
+        & 7.808735e-01_rb,7.833430e-01_rb,7.857819e-01_rb,7.881886e-01_rb,7.905612e-01_rb,&
+        & 7.928983e-01_rb,7.951980e-01_rb,7.974588e-01_rb,7.996789e-01_rb,8.018567e-01_rb,&
+        & 8.039905e-01_rb,8.060787e-01_rb,8.081196e-01_rb,8.101115e-01_rb,8.120527e-01_rb,&
+        & 8.139416e-01_rb,8.157764e-01_rb,8.175557e-01_rb,8.192776e-01_rb,8.209405e-01_rb,&
+        & 8.225427e-01_rb,8.240826e-01_rb,8.255585e-01_rb,8.269688e-01_rb,8.283117e-01_rb,&
+        & 8.295856e-01_rb,8.307889e-01_rb,8.319198e-01_rb,8.329767e-01_rb,8.339579e-01_rb,&
+        & 8.348619e-01_rb,8.356868e-01_rb,8.364311e-01_rb,8.370930e-01_rb,8.376710e-01_rb,&
+        & 8.381633e-01_rb /)
+      asyice3(:, 26) = (/ &
+! band 26
+        & 7.491854e-01_rb,7.518523e-01_rb,7.545089e-01_rb,7.571534e-01_rb,7.597839e-01_rb,&
+        & 7.623987e-01_rb,7.649959e-01_rb,7.675737e-01_rb,7.701303e-01_rb,7.726639e-01_rb,&
+        & 7.751727e-01_rb,7.776548e-01_rb,7.801084e-01_rb,7.825318e-01_rb,7.849230e-01_rb,&
+        & 7.872804e-01_rb,7.896020e-01_rb,7.918862e-01_rb,7.941309e-01_rb,7.963345e-01_rb,&
+        & 7.984951e-01_rb,8.006109e-01_rb,8.026802e-01_rb,8.047009e-01_rb,8.066715e-01_rb,&
+        & 8.085900e-01_rb,8.104546e-01_rb,8.122636e-01_rb,8.140150e-01_rb,8.157072e-01_rb,&
+        & 8.173382e-01_rb,8.189063e-01_rb,8.204096e-01_rb,8.218464e-01_rb,8.232148e-01_rb,&
+        & 8.245130e-01_rb,8.257391e-01_rb,8.268915e-01_rb,8.279682e-01_rb,8.289675e-01_rb,&
+        & 8.298875e-01_rb,8.307264e-01_rb,8.314824e-01_rb,8.321537e-01_rb,8.327385e-01_rb,&
+        & 8.332350e-01_rb /)
+      asyice3(:, 27) = (/ &
+! band 27
+        & 7.397086e-01_rb,7.424069e-01_rb,7.450955e-01_rb,7.477725e-01_rb,7.504362e-01_rb,&
+        & 7.530846e-01_rb,7.557159e-01_rb,7.583283e-01_rb,7.609199e-01_rb,7.634888e-01_rb,&
+        & 7.660332e-01_rb,7.685512e-01_rb,7.710411e-01_rb,7.735009e-01_rb,7.759288e-01_rb,&
+        & 7.783229e-01_rb,7.806814e-01_rb,7.830024e-01_rb,7.852841e-01_rb,7.875246e-01_rb,&
+        & 7.897221e-01_rb,7.918748e-01_rb,7.939807e-01_rb,7.960380e-01_rb,7.980449e-01_rb,&
+        & 7.999995e-01_rb,8.019000e-01_rb,8.037445e-01_rb,8.055311e-01_rb,8.072581e-01_rb,&
+        & 8.089235e-01_rb,8.105255e-01_rb,8.120623e-01_rb,8.135319e-01_rb,8.149326e-01_rb,&
+        & 8.162626e-01_rb,8.175198e-01_rb,8.187025e-01_rb,8.198089e-01_rb,8.208371e-01_rb,&
+        & 8.217852e-01_rb,8.226514e-01_rb,8.234338e-01_rb,8.241306e-01_rb,8.247399e-01_rb,&
+        & 8.252599e-01_rb /)
+      asyice3(:, 28) = (/ &
+! band 28
+        & 7.224533e-01_rb,7.251681e-01_rb,7.278728e-01_rb,7.305654e-01_rb,7.332444e-01_rb,&
+        & 7.359078e-01_rb,7.385539e-01_rb,7.411808e-01_rb,7.437869e-01_rb,7.463702e-01_rb,&
+        & 7.489291e-01_rb,7.514616e-01_rb,7.539661e-01_rb,7.564408e-01_rb,7.588837e-01_rb,&
+        & 7.612933e-01_rb,7.636676e-01_rb,7.660049e-01_rb,7.683034e-01_rb,7.705612e-01_rb,&
+        & 7.727767e-01_rb,7.749480e-01_rb,7.770733e-01_rb,7.791509e-01_rb,7.811789e-01_rb,&
+        & 7.831556e-01_rb,7.850791e-01_rb,7.869478e-01_rb,7.887597e-01_rb,7.905131e-01_rb,&
+        & 7.922062e-01_rb,7.938372e-01_rb,7.954044e-01_rb,7.969059e-01_rb,7.983399e-01_rb,&
+        & 7.997047e-01_rb,8.009985e-01_rb,8.022195e-01_rb,8.033658e-01_rb,8.044357e-01_rb,&
+        & 8.054275e-01_rb,8.063392e-01_rb,8.071692e-01_rb,8.079157e-01_rb,8.085768e-01_rb,&
+        & 8.091507e-01_rb /)
+      asyice3(:, 29) = (/ &
+! band 29
+        & 8.850026e-01_rb,9.005489e-01_rb,9.069242e-01_rb,9.121799e-01_rb,9.168987e-01_rb,&
+        & 9.212259e-01_rb,9.252176e-01_rb,9.289028e-01_rb,9.323000e-01_rb,9.354235e-01_rb,&
+        & 9.382858e-01_rb,9.408985e-01_rb,9.432734e-01_rb,9.454218e-01_rb,9.473557e-01_rb,&
+        & 9.490871e-01_rb,9.506282e-01_rb,9.519917e-01_rb,9.531904e-01_rb,9.542374e-01_rb,&
+        & 9.551461e-01_rb,9.559298e-01_rb,9.566023e-01_rb,9.571775e-01_rb,9.576692e-01_rb,&
+        & 9.580916e-01_rb,9.584589e-01_rb,9.587853e-01_rb,9.590851e-01_rb,9.593729e-01_rb,&
+        & 9.596632e-01_rb,9.599705e-01_rb,9.603096e-01_rb,9.606954e-01_rb,9.611427e-01_rb,&
+        & 9.616667e-01_rb,9.622826e-01_rb,9.630060e-01_rb,9.638524e-01_rb,9.648379e-01_rb,&
+        & 9.659788e-01_rb,9.672916e-01_rb,9.687933e-01_rb,9.705014e-01_rb,9.724337e-01_rb,&
+        & 9.746084e-01_rb /)
+
+! fdelta: unitless
+      fdlice3(:, 16) = (/ &
+! band 16
+        & 4.959277e-02_rb,4.685292e-02_rb,4.426104e-02_rb,4.181231e-02_rb,3.950191e-02_rb,&
+        & 3.732500e-02_rb,3.527675e-02_rb,3.335235e-02_rb,3.154697e-02_rb,2.985578e-02_rb,&
+        & 2.827395e-02_rb,2.679666e-02_rb,2.541909e-02_rb,2.413640e-02_rb,2.294378e-02_rb,&
+        & 2.183639e-02_rb,2.080940e-02_rb,1.985801e-02_rb,1.897736e-02_rb,1.816265e-02_rb,&
+        & 1.740905e-02_rb,1.671172e-02_rb,1.606585e-02_rb,1.546661e-02_rb,1.490917e-02_rb,&
+        & 1.438870e-02_rb,1.390038e-02_rb,1.343939e-02_rb,1.300089e-02_rb,1.258006e-02_rb,&
+        & 1.217208e-02_rb,1.177212e-02_rb,1.137536e-02_rb,1.097696e-02_rb,1.057210e-02_rb,&
+        & 1.015596e-02_rb,9.723704e-03_rb,9.270516e-03_rb,8.791565e-03_rb,8.282026e-03_rb,&
+        & 7.737072e-03_rb,7.151879e-03_rb,6.521619e-03_rb,5.841467e-03_rb,5.106597e-03_rb,&
+        & 4.312183e-03_rb /)
+      fdlice3(:, 17) = (/ &
+! band 17
+        & 5.071224e-02_rb,5.000217e-02_rb,4.933872e-02_rb,4.871992e-02_rb,4.814380e-02_rb,&
+        & 4.760839e-02_rb,4.711170e-02_rb,4.665177e-02_rb,4.622662e-02_rb,4.583426e-02_rb,&
+        & 4.547274e-02_rb,4.514007e-02_rb,4.483428e-02_rb,4.455340e-02_rb,4.429544e-02_rb,&
+        & 4.405844e-02_rb,4.384041e-02_rb,4.363939e-02_rb,4.345340e-02_rb,4.328047e-02_rb,&
+        & 4.311861e-02_rb,4.296586e-02_rb,4.282024e-02_rb,4.267977e-02_rb,4.254248e-02_rb,&
+        & 4.240640e-02_rb,4.226955e-02_rb,4.212995e-02_rb,4.198564e-02_rb,4.183462e-02_rb,&
+        & 4.167494e-02_rb,4.150462e-02_rb,4.132167e-02_rb,4.112413e-02_rb,4.091003e-02_rb,&
+        & 4.067737e-02_rb,4.042420e-02_rb,4.014854e-02_rb,3.984840e-02_rb,3.952183e-02_rb,&
+        & 3.916683e-02_rb,3.878144e-02_rb,3.836368e-02_rb,3.791158e-02_rb,3.742316e-02_rb,&
+        & 3.689645e-02_rb /)
+      fdlice3(:, 18) = (/ &
+! band 18
+        & 1.062938e-01_rb,1.065234e-01_rb,1.067822e-01_rb,1.070682e-01_rb,1.073793e-01_rb,&
+        & 1.077137e-01_rb,1.080693e-01_rb,1.084442e-01_rb,1.088364e-01_rb,1.092439e-01_rb,&
+        & 1.096647e-01_rb,1.100970e-01_rb,1.105387e-01_rb,1.109878e-01_rb,1.114423e-01_rb,&
+        & 1.119004e-01_rb,1.123599e-01_rb,1.128190e-01_rb,1.132757e-01_rb,1.137279e-01_rb,&
+        & 1.141738e-01_rb,1.146113e-01_rb,1.150385e-01_rb,1.154534e-01_rb,1.158540e-01_rb,&
+        & 1.162383e-01_rb,1.166045e-01_rb,1.169504e-01_rb,1.172741e-01_rb,1.175738e-01_rb,&
+        & 1.178472e-01_rb,1.180926e-01_rb,1.183080e-01_rb,1.184913e-01_rb,1.186405e-01_rb,&
+        & 1.187538e-01_rb,1.188291e-01_rb,1.188645e-01_rb,1.188580e-01_rb,1.188076e-01_rb,&
+        & 1.187113e-01_rb,1.185672e-01_rb,1.183733e-01_rb,1.181277e-01_rb,1.178282e-01_rb,&
+        & 1.174731e-01_rb /)
+      fdlice3(:, 19) = (/ &
+! band 19
+        & 1.076195e-01_rb,1.065195e-01_rb,1.054696e-01_rb,1.044673e-01_rb,1.035099e-01_rb,&
+        & 1.025951e-01_rb,1.017203e-01_rb,1.008831e-01_rb,1.000808e-01_rb,9.931116e-02_rb,&
+        & 9.857151e-02_rb,9.785939e-02_rb,9.717230e-02_rb,9.650774e-02_rb,9.586322e-02_rb,&
+        & 9.523623e-02_rb,9.462427e-02_rb,9.402484e-02_rb,9.343544e-02_rb,9.285358e-02_rb,&
+        & 9.227675e-02_rb,9.170245e-02_rb,9.112818e-02_rb,9.055144e-02_rb,8.996974e-02_rb,&
+        & 8.938056e-02_rb,8.878142e-02_rb,8.816981e-02_rb,8.754323e-02_rb,8.689919e-02_rb,&
+        & 8.623517e-02_rb,8.554869e-02_rb,8.483724e-02_rb,8.409832e-02_rb,8.332943e-02_rb,&
+        & 8.252807e-02_rb,8.169175e-02_rb,8.081795e-02_rb,7.990419e-02_rb,7.894796e-02_rb,&
+        & 7.794676e-02_rb,7.689809e-02_rb,7.579945e-02_rb,7.464834e-02_rb,7.344227e-02_rb,&
+        & 7.217872e-02_rb /)
+      fdlice3(:, 20) = (/ &
+! band 20
+        & 1.119014e-01_rb,1.122706e-01_rb,1.126690e-01_rb,1.130947e-01_rb,1.135456e-01_rb,&
+        & 1.140199e-01_rb,1.145154e-01_rb,1.150302e-01_rb,1.155623e-01_rb,1.161096e-01_rb,&
+        & 1.166703e-01_rb,1.172422e-01_rb,1.178233e-01_rb,1.184118e-01_rb,1.190055e-01_rb,&
+        & 1.196025e-01_rb,1.202008e-01_rb,1.207983e-01_rb,1.213931e-01_rb,1.219832e-01_rb,&
+        & 1.225665e-01_rb,1.231411e-01_rb,1.237050e-01_rb,1.242561e-01_rb,1.247926e-01_rb,&
+        & 1.253122e-01_rb,1.258132e-01_rb,1.262934e-01_rb,1.267509e-01_rb,1.271836e-01_rb,&
+        & 1.275896e-01_rb,1.279669e-01_rb,1.283134e-01_rb,1.286272e-01_rb,1.289063e-01_rb,&
+        & 1.291486e-01_rb,1.293522e-01_rb,1.295150e-01_rb,1.296351e-01_rb,1.297104e-01_rb,&
+        & 1.297390e-01_rb,1.297189e-01_rb,1.296480e-01_rb,1.295244e-01_rb,1.293460e-01_rb,&
+        & 1.291109e-01_rb /)
+      fdlice3(:, 21) = (/ &
+! band 21
+        & 1.133298e-01_rb,1.136777e-01_rb,1.140556e-01_rb,1.144615e-01_rb,1.148934e-01_rb,&
+        & 1.153492e-01_rb,1.158269e-01_rb,1.163243e-01_rb,1.168396e-01_rb,1.173706e-01_rb,&
+        & 1.179152e-01_rb,1.184715e-01_rb,1.190374e-01_rb,1.196108e-01_rb,1.201897e-01_rb,&
+        & 1.207720e-01_rb,1.213558e-01_rb,1.219389e-01_rb,1.225194e-01_rb,1.230951e-01_rb,&
+        & 1.236640e-01_rb,1.242241e-01_rb,1.247733e-01_rb,1.253096e-01_rb,1.258309e-01_rb,&
+        & 1.263352e-01_rb,1.268205e-01_rb,1.272847e-01_rb,1.277257e-01_rb,1.281415e-01_rb,&
+        & 1.285300e-01_rb,1.288893e-01_rb,1.292173e-01_rb,1.295118e-01_rb,1.297710e-01_rb,&
+        & 1.299927e-01_rb,1.301748e-01_rb,1.303154e-01_rb,1.304124e-01_rb,1.304637e-01_rb,&
+        & 1.304673e-01_rb,1.304212e-01_rb,1.303233e-01_rb,1.301715e-01_rb,1.299638e-01_rb,&
+        & 1.296983e-01_rb /)
+      fdlice3(:, 22) = (/ &
+! band 22
+        & 1.145360e-01_rb,1.153256e-01_rb,1.161453e-01_rb,1.169929e-01_rb,1.178666e-01_rb,&
+        & 1.187641e-01_rb,1.196835e-01_rb,1.206227e-01_rb,1.215796e-01_rb,1.225522e-01_rb,&
+        & 1.235383e-01_rb,1.245361e-01_rb,1.255433e-01_rb,1.265579e-01_rb,1.275779e-01_rb,&
+        & 1.286011e-01_rb,1.296257e-01_rb,1.306494e-01_rb,1.316703e-01_rb,1.326862e-01_rb,&
+        & 1.336951e-01_rb,1.346950e-01_rb,1.356838e-01_rb,1.366594e-01_rb,1.376198e-01_rb,&
+        & 1.385629e-01_rb,1.394866e-01_rb,1.403889e-01_rb,1.412678e-01_rb,1.421212e-01_rb,&
+        & 1.429469e-01_rb,1.437430e-01_rb,1.445074e-01_rb,1.452381e-01_rb,1.459329e-01_rb,&
+        & 1.465899e-01_rb,1.472069e-01_rb,1.477819e-01_rb,1.483128e-01_rb,1.487976e-01_rb,&
+        & 1.492343e-01_rb,1.496207e-01_rb,1.499548e-01_rb,1.502346e-01_rb,1.504579e-01_rb,&
+        & 1.506227e-01_rb /)
+      fdlice3(:, 23) = (/ &
+! band 23
+        & 1.153263e-01_rb,1.161445e-01_rb,1.169932e-01_rb,1.178703e-01_rb,1.187738e-01_rb,&
+        & 1.197016e-01_rb,1.206516e-01_rb,1.216217e-01_rb,1.226099e-01_rb,1.236141e-01_rb,&
+        & 1.246322e-01_rb,1.256621e-01_rb,1.267017e-01_rb,1.277491e-01_rb,1.288020e-01_rb,&
+        & 1.298584e-01_rb,1.309163e-01_rb,1.319736e-01_rb,1.330281e-01_rb,1.340778e-01_rb,&
+        & 1.351207e-01_rb,1.361546e-01_rb,1.371775e-01_rb,1.381873e-01_rb,1.391820e-01_rb,&
+        & 1.401593e-01_rb,1.411174e-01_rb,1.420540e-01_rb,1.429671e-01_rb,1.438547e-01_rb,&
+        & 1.447146e-01_rb,1.455449e-01_rb,1.463433e-01_rb,1.471078e-01_rb,1.478364e-01_rb,&
+        & 1.485270e-01_rb,1.491774e-01_rb,1.497857e-01_rb,1.503497e-01_rb,1.508674e-01_rb,&
+        & 1.513367e-01_rb,1.517554e-01_rb,1.521216e-01_rb,1.524332e-01_rb,1.526880e-01_rb,&
+        & 1.528840e-01_rb /)
+      fdlice3(:, 24) = (/ &
+! band 24
+        & 1.160842e-01_rb,1.169118e-01_rb,1.177697e-01_rb,1.186556e-01_rb,1.195676e-01_rb,&
+        & 1.205036e-01_rb,1.214616e-01_rb,1.224394e-01_rb,1.234349e-01_rb,1.244463e-01_rb,&
+        & 1.254712e-01_rb,1.265078e-01_rb,1.275539e-01_rb,1.286075e-01_rb,1.296664e-01_rb,&
+        & 1.307287e-01_rb,1.317923e-01_rb,1.328550e-01_rb,1.339149e-01_rb,1.349699e-01_rb,&
+        & 1.360179e-01_rb,1.370567e-01_rb,1.380845e-01_rb,1.390991e-01_rb,1.400984e-01_rb,&
+        & 1.410803e-01_rb,1.420429e-01_rb,1.429840e-01_rb,1.439016e-01_rb,1.447936e-01_rb,&
+        & 1.456579e-01_rb,1.464925e-01_rb,1.472953e-01_rb,1.480642e-01_rb,1.487972e-01_rb,&
+        & 1.494923e-01_rb,1.501472e-01_rb,1.507601e-01_rb,1.513287e-01_rb,1.518511e-01_rb,&
+        & 1.523252e-01_rb,1.527489e-01_rb,1.531201e-01_rb,1.534368e-01_rb,1.536969e-01_rb,&
+        & 1.538984e-01_rb /)
+      fdlice3(:, 25) = (/ &
+! band 25
+        & 1.168725e-01_rb,1.177088e-01_rb,1.185747e-01_rb,1.194680e-01_rb,1.203867e-01_rb,&
+        & 1.213288e-01_rb,1.222923e-01_rb,1.232750e-01_rb,1.242750e-01_rb,1.252903e-01_rb,&
+        & 1.263187e-01_rb,1.273583e-01_rb,1.284069e-01_rb,1.294626e-01_rb,1.305233e-01_rb,&
+        & 1.315870e-01_rb,1.326517e-01_rb,1.337152e-01_rb,1.347756e-01_rb,1.358308e-01_rb,&
+        & 1.368788e-01_rb,1.379175e-01_rb,1.389449e-01_rb,1.399590e-01_rb,1.409577e-01_rb,&
+        & 1.419389e-01_rb,1.429007e-01_rb,1.438410e-01_rb,1.447577e-01_rb,1.456488e-01_rb,&
+        & 1.465123e-01_rb,1.473461e-01_rb,1.481483e-01_rb,1.489166e-01_rb,1.496492e-01_rb,&
+        & 1.503439e-01_rb,1.509988e-01_rb,1.516118e-01_rb,1.521808e-01_rb,1.527038e-01_rb,&
+        & 1.531788e-01_rb,1.536037e-01_rb,1.539764e-01_rb,1.542951e-01_rb,1.545575e-01_rb,&
+        & 1.547617e-01_rb /)
+      fdlice3(:, 26) = (/ &
+!band 26
+        & 1.180509e-01_rb,1.189025e-01_rb,1.197820e-01_rb,1.206875e-01_rb,1.216171e-01_rb,&
+        & 1.225687e-01_rb,1.235404e-01_rb,1.245303e-01_rb,1.255363e-01_rb,1.265564e-01_rb,&
+        & 1.275888e-01_rb,1.286313e-01_rb,1.296821e-01_rb,1.307392e-01_rb,1.318006e-01_rb,&
+        & 1.328643e-01_rb,1.339284e-01_rb,1.349908e-01_rb,1.360497e-01_rb,1.371029e-01_rb,&
+        & 1.381486e-01_rb,1.391848e-01_rb,1.402095e-01_rb,1.412208e-01_rb,1.422165e-01_rb,&
+        & 1.431949e-01_rb,1.441539e-01_rb,1.450915e-01_rb,1.460058e-01_rb,1.468947e-01_rb,&
+        & 1.477564e-01_rb,1.485888e-01_rb,1.493900e-01_rb,1.501580e-01_rb,1.508907e-01_rb,&
+        & 1.515864e-01_rb,1.522428e-01_rb,1.528582e-01_rb,1.534305e-01_rb,1.539578e-01_rb,&
+        & 1.544380e-01_rb,1.548692e-01_rb,1.552494e-01_rb,1.555767e-01_rb,1.558490e-01_rb,&
+        & 1.560645e-01_rb /)
+      fdlice3(:, 27) = (/ &
+! band 27
+        & 1.200480e-01_rb,1.209267e-01_rb,1.218304e-01_rb,1.227575e-01_rb,1.237059e-01_rb,&
+        & 1.246739e-01_rb,1.256595e-01_rb,1.266610e-01_rb,1.276765e-01_rb,1.287041e-01_rb,&
+        & 1.297420e-01_rb,1.307883e-01_rb,1.318412e-01_rb,1.328988e-01_rb,1.339593e-01_rb,&
+        & 1.350207e-01_rb,1.360813e-01_rb,1.371393e-01_rb,1.381926e-01_rb,1.392396e-01_rb,&
+        & 1.402783e-01_rb,1.413069e-01_rb,1.423235e-01_rb,1.433263e-01_rb,1.443134e-01_rb,&
+        & 1.452830e-01_rb,1.462332e-01_rb,1.471622e-01_rb,1.480681e-01_rb,1.489490e-01_rb,&
+        & 1.498032e-01_rb,1.506286e-01_rb,1.514236e-01_rb,1.521863e-01_rb,1.529147e-01_rb,&
+        & 1.536070e-01_rb,1.542614e-01_rb,1.548761e-01_rb,1.554491e-01_rb,1.559787e-01_rb,&
+        & 1.564629e-01_rb,1.568999e-01_rb,1.572879e-01_rb,1.576249e-01_rb,1.579093e-01_rb,&
+        & 1.581390e-01_rb /)
+      fdlice3(:, 28) = (/ &
+! band 28
+        & 1.247813e-01_rb,1.256496e-01_rb,1.265417e-01_rb,1.274560e-01_rb,1.283905e-01_rb,&
+        & 1.293436e-01_rb,1.303135e-01_rb,1.312983e-01_rb,1.322964e-01_rb,1.333060e-01_rb,&
+        & 1.343252e-01_rb,1.353523e-01_rb,1.363855e-01_rb,1.374231e-01_rb,1.384632e-01_rb,&
+        & 1.395042e-01_rb,1.405441e-01_rb,1.415813e-01_rb,1.426140e-01_rb,1.436404e-01_rb,&
+        & 1.446587e-01_rb,1.456672e-01_rb,1.466640e-01_rb,1.476475e-01_rb,1.486157e-01_rb,&
+        & 1.495671e-01_rb,1.504997e-01_rb,1.514117e-01_rb,1.523016e-01_rb,1.531673e-01_rb,&
+        & 1.540073e-01_rb,1.548197e-01_rb,1.556026e-01_rb,1.563545e-01_rb,1.570734e-01_rb,&
+        & 1.577576e-01_rb,1.584054e-01_rb,1.590149e-01_rb,1.595843e-01_rb,1.601120e-01_rb,&
+        & 1.605962e-01_rb,1.610349e-01_rb,1.614266e-01_rb,1.617693e-01_rb,1.620614e-01_rb,&
+        & 1.623011e-01_rb /)
+      fdlice3(:, 29) = (/ &
+! band 29
+        & 1.006055e-01_rb,9.549582e-02_rb,9.063960e-02_rb,8.602900e-02_rb,8.165612e-02_rb,&
+        & 7.751308e-02_rb,7.359199e-02_rb,6.988496e-02_rb,6.638412e-02_rb,6.308156e-02_rb,&
+        & 5.996942e-02_rb,5.703979e-02_rb,5.428481e-02_rb,5.169657e-02_rb,4.926719e-02_rb,&
+        & 4.698880e-02_rb,4.485349e-02_rb,4.285339e-02_rb,4.098061e-02_rb,3.922727e-02_rb,&
+        & 3.758547e-02_rb,3.604733e-02_rb,3.460497e-02_rb,3.325051e-02_rb,3.197604e-02_rb,&
+        & 3.077369e-02_rb,2.963558e-02_rb,2.855381e-02_rb,2.752050e-02_rb,2.652776e-02_rb,&
+        & 2.556772e-02_rb,2.463247e-02_rb,2.371415e-02_rb,2.280485e-02_rb,2.189670e-02_rb,&
+        & 2.098180e-02_rb,2.005228e-02_rb,1.910024e-02_rb,1.811781e-02_rb,1.709709e-02_rb,&
+        & 1.603020e-02_rb,1.490925e-02_rb,1.372635e-02_rb,1.247363e-02_rb,1.114319e-02_rb,&
+        & 9.727157e-03_rb /)
+
+      end subroutine swcldpr
+
+      end module rrtmg_sw_init
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+!
+      module rrtmg_sw_vrtqdr
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parkind, only: im => kind_im, rb => kind_rb
+!      use parrrsw, only: ngptsw
+
+      implicit none
+
+      contains
+
+! --------------------------------------------------------------------------
+      subroutine vrtqdr_sw(klev, kw, &
+                           pref, prefd, ptra, ptrad, &
+                           pdbt, prdnd, prup, prupd, ptdbt, &
+                           pfd, pfu)
+! --------------------------------------------------------------------------
+ 
+! Purpose: This routine performs the vertical quadrature integration
+!
+! Interface:  *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw*
+!
+! Modifications.
+! 
+! Original: H. Barker
+! Revision: Integrated with rrtmg_sw, J.-J. Morcrette, ECMWF, Oct 2002
+! Revision: Reformatted for consistency with rrtmg_lw: MJIacono, AER, Jul 2006
+!
+!-----------------------------------------------------------------------
+
+! ------- Declarations -------
+
+! Input
+
+      integer(kind=im), intent (in) :: klev                   ! number of model layers
+      integer(kind=im), intent (in) :: kw                     ! g-point index
+
+      real(kind=rb), intent(in) :: pref(:)                    ! direct beam reflectivity
+                                                              !   Dimensions: (nlayers+1)
+      real(kind=rb), intent(in) :: prefd(:)                   ! diffuse beam reflectivity
+                                                              !   Dimensions: (nlayers+1)
+      real(kind=rb), intent(in) :: ptra(:)                    ! direct beam transmissivity
+                                                              !   Dimensions: (nlayers+1)
+      real(kind=rb), intent(in) :: ptrad(:)                   ! diffuse beam transmissivity
+                                                              !   Dimensions: (nlayers+1)
+
+      real(kind=rb), intent(in) :: pdbt(:)
+                                                              !   Dimensions: (nlayers+1)
+      real(kind=rb), intent(in) :: ptdbt(:)
+                                                              !   Dimensions: (nlayers+1)
+
+      real(kind=rb), intent(inout) :: prdnd(:)
+                                                              !   Dimensions: (nlayers+1)
+      real(kind=rb), intent(inout) :: prup(:)
+                                                              !   Dimensions: (nlayers+1)
+      real(kind=rb), intent(inout) :: prupd(:)
+                                                              !   Dimensions: (nlayers+1)
+
+! Output
+      real(kind=rb), intent(out) :: pfd(:,:)                  ! downwelling flux (W/m2)
+                                                              !   Dimensions: (nlayers+1,ngptsw)
+                                                              ! unadjusted for earth/sun distance or zenith angle
+      real(kind=rb), intent(out) :: pfu(:,:)                  ! upwelling flux (W/m2)
+                                                              !   Dimensions: (nlayers+1,ngptsw)
+                                                              ! unadjusted for earth/sun distance or zenith angle
+
+! Local
+
+      integer(kind=im) :: ikp, ikx, jk
+
+      real(kind=rb) :: zreflect
+      real(kind=rb) :: ztdn(klev+1)  
+
+! Definitions
+!
+! pref(jk)   direct reflectance
+! prefd(jk)  diffuse reflectance
+! ptra(jk)   direct transmittance
+! ptrad(jk)  diffuse transmittance
+!
+! pdbt(jk)   layer mean direct beam transmittance
+! ptdbt(jk)  total direct beam transmittance at levels
+!
+!-----------------------------------------------------------------------------
+                   
+! Link lowest layer with surface
+             
+      zreflect = 1._rb / (1._rb - prefd(klev+1) * prefd(klev))
+      prup(klev) = pref(klev) + (ptrad(klev) * &
+                 ((ptra(klev) - pdbt(klev)) * prefd(klev+1) + &
+                   pdbt(klev) * pref(klev+1))) * zreflect
+      prupd(klev) = prefd(klev) + ptrad(klev) * ptrad(klev) * &
+                    prefd(klev+1) * zreflect
+
+! Pass from bottom to top 
+
+      do jk = 1,klev-1
+         ikp = klev+1-jk                       
+         ikx = ikp-1
+         zreflect = 1._rb / (1._rb -prupd(ikp) * prefd(ikx))
+         prup(ikx) = pref(ikx) + (ptrad(ikx) * &
+                   ((ptra(ikx) - pdbt(ikx)) * prupd(ikp) + &
+                     pdbt(ikx) * prup(ikp))) * zreflect
+         prupd(ikx) = prefd(ikx) + ptrad(ikx) * ptrad(ikx) * &
+                      prupd(ikp) * zreflect
+      enddo
+    
+! Upper boundary conditions
+
+      ztdn(1) = 1._rb
+      prdnd(1) = 0._rb
+      ztdn(2) = ptra(1)
+      prdnd(2) = prefd(1)
+
+! Pass from top to bottom
+
+      do jk = 2,klev
+         ikp = jk+1
+         zreflect = 1._rb / (1._rb - prefd(jk) * prdnd(jk))
+         ztdn(ikp) = ptdbt(jk) * ptra(jk) + &
+                    (ptrad(jk) * ((ztdn(jk) - ptdbt(jk)) + &
+                     ptdbt(jk) * pref(jk) * prdnd(jk))) * zreflect
+         prdnd(ikp) = prefd(jk) + ptrad(jk) * ptrad(jk) * &
+                      prdnd(jk) * zreflect
+      enddo
+    
+! Up and down-welling fluxes at levels
+
+      do jk = 1,klev+1
+         zreflect = 1._rb / (1._rb - prdnd(jk) * prupd(jk))
+         pfu(jk,kw) = (ptdbt(jk) * prup(jk) + &
+                      (ztdn(jk) - ptdbt(jk)) * prupd(jk)) * zreflect
+         pfd(jk,kw) = ptdbt(jk) + (ztdn(jk) - ptdbt(jk)+ &
+                      ptdbt(jk) * prup(jk) * prdnd(jk)) * zreflect
+      enddo
+
+      end subroutine vrtqdr_sw
+
+      end module rrtmg_sw_vrtqdr
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+
+      module rrtmg_sw_spcvmc
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+
+! ------- Modules -------
+
+      use parkind, only : im => kind_im, rb => kind_rb
+      use parrrsw, only : nbndsw, ngptsw, mxmol, jpband
+      use rrsw_tbl, only : tblint, bpade, od_lo, exp_tbl
+      use rrsw_vsn, only : hvrspc, hnamspc
+      use rrsw_wvn, only : ngc, ngs
+      use rrtmg_sw_reftra, only: reftra_sw
+      use rrtmg_sw_taumol, only: taumol_sw
+      use rrtmg_sw_vrtqdr, only: vrtqdr_sw
+
+      implicit none
+
+      contains
+
+! ---------------------------------------------------------------------------
+      subroutine spcvmc_sw &
+            (nlayers, istart, iend, icpr, iout, &
+             pavel, tavel, pz, tz, tbound, palbd, palbp, &
+             pcldfmc, ptaucmc, pasycmc, pomgcmc, ptaormc, &
+             ptaua, pasya, pomga, prmu0, coldry, wkl, adjflux, &
+             laytrop, layswtch, laylow, jp, jt, jt1, &
+             co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, &
+             fac00, fac01, fac10, fac11, &
+             selffac, selffrac, indself, forfac, forfrac, indfor, &
+             pbbfd, pbbfu, pbbcd, pbbcu, puvfd, puvcd, pnifd, pnicd, &
+             pbbfddir, pbbcddir, puvfddir, puvcddir, pnifddir, pnicddir)
+! ---------------------------------------------------------------------------
+!
+! Purpose: Contains spectral loop to compute the shortwave radiative fluxes, 
+!          using the two-stream method of H. Barker and McICA, the Monte-Carlo
+!          Independent Column Approximation, for the representation of 
+!          sub-grid cloud variability (i.e. cloud overlap).
+!
+! Interface:  *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90*
+!
+! Method:
+!    Adapted from two-stream model of H. Barker;
+!    Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90):
+!        1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates
+!
+! Modifications:
+!
+! Original: H. Barker
+! Revision: Merge with RRTMG_SW: J.-J.Morcrette, ECMWF, Feb 2003
+! Revision: Add adjustment for Earth/Sun distance : MJIacono, AER, Oct 2003
+! Revision: Bug fix for use of PALBP and PALBD: MJIacono, AER, Nov 2003
+! Revision: Bug fix to apply delta scaling to clear sky: AER, Dec 2004
+! Revision: Code modified so that delta scaling is not done in cloudy profiles
+!           if routine cldprop is used; delta scaling can be applied by swithcing
+!           code below if cldprop is not used to get cloud properties. 
+!           AER, Jan 2005
+! Revision: Modified to use McICA: MJIacono, AER, Nov 2005
+! Revision: Uniform formatting for RRTMG: MJIacono, AER, Jul 2006 
+! Revision: Use exponential lookup table for transmittance: MJIacono, AER, 
+!           Aug 2007 
+!
+! ------------------------------------------------------------------
+
+! ------- Declarations ------
+
+! ------- Input -------
+
+      integer(kind=im), intent(in) :: nlayers
+      integer(kind=im), intent(in) :: istart
+      integer(kind=im), intent(in) :: iend
+      integer(kind=im), intent(in) :: icpr
+      integer(kind=im), intent(in) :: iout
+      integer(kind=im), intent(in) :: laytrop
+      integer(kind=im), intent(in) :: layswtch
+      integer(kind=im), intent(in) :: laylow
+
+      integer(kind=im), intent(in) :: indfor(:)
+                                                               !   Dimensions: (nlayers)
+      integer(kind=im), intent(in) :: indself(:)
+                                                               !   Dimensions: (nlayers)
+      integer(kind=im), intent(in) :: jp(:)
+                                                               !   Dimensions: (nlayers)
+      integer(kind=im), intent(in) :: jt(:)
+                                                               !   Dimensions: (nlayers)
+      integer(kind=im), intent(in) :: jt1(:)
+                                                               !   Dimensions: (nlayers)
+
+      real(kind=rb), intent(in) :: pavel(:)                    ! layer pressure (hPa, mb) 
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: tavel(:)                    ! layer temperature (K)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: pz(0:)                      ! level (interface) pressure (hPa, mb)
+                                                               !   Dimensions: (0:nlayers)
+      real(kind=rb), intent(in) :: tz(0:)                      ! level temperatures (hPa, mb)
+                                                               !   Dimensions: (0:nlayers)
+      real(kind=rb), intent(in) :: tbound                      ! surface temperature (K)
+      real(kind=rb), intent(in) :: wkl(:,:)                    ! molecular amounts (mol/cm2) 
+                                                               !   Dimensions: (mxmol,nlayers)
+      real(kind=rb), intent(in) :: coldry(:)                   ! dry air column density (mol/cm2)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colmol(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: adjflux(:)                  ! Earth/Sun distance adjustment
+                                                               !   Dimensions: (jpband)
+
+      real(kind=rb), intent(in) :: palbd(:)                    ! surface albedo (diffuse)
+                                                               !   Dimensions: (nbndsw)
+      real(kind=rb), intent(in) :: palbp(:)                    ! surface albedo (direct)
+                                                               !   Dimensions: (nbndsw)
+      real(kind=rb), intent(in) :: prmu0                       ! cosine of solar zenith angle
+      real(kind=rb), intent(in) :: pcldfmc(:,:)                ! cloud fraction [mcica]
+                                                               !   Dimensions: (nlayers,ngptsw)
+      real(kind=rb), intent(in) :: ptaucmc(:,:)                ! cloud optical depth [mcica]
+                                                               !   Dimensions: (nlayers,ngptsw)
+      real(kind=rb), intent(in) :: pasycmc(:,:)                ! cloud asymmetry parameter [mcica]
+                                                               !   Dimensions: (nlayers,ngptsw)
+      real(kind=rb), intent(in) :: pomgcmc(:,:)                ! cloud single scattering albedo [mcica]
+                                                               !   Dimensions: (nlayers,ngptsw)
+      real(kind=rb), intent(in) :: ptaormc(:,:)                ! cloud optical depth, non-delta scaled [mcica]
+                                                               !   Dimensions: (nlayers,ngptsw)
+      real(kind=rb), intent(in) :: ptaua(:,:)                  ! aerosol optical depth
+                                                               !   Dimensions: (nlayers,nbndsw)
+      real(kind=rb), intent(in) :: pasya(:,:)                  ! aerosol asymmetry parameter
+                                                               !   Dimensions: (nlayers,nbndsw)
+      real(kind=rb), intent(in) :: pomga(:,:)                  ! aerosol single scattering albedo
+                                                               !   Dimensions: (nlayers,nbndsw)
+
+      real(kind=rb), intent(in) :: colh2o(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colco2(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colch4(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: co2mult(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colo3(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: colo2(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: coln2o(:)
+                                                               !   Dimensions: (nlayers)
+
+      real(kind=rb), intent(in) :: forfac(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: forfrac(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: selffac(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: selffrac(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: fac00(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: fac01(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: fac10(:)
+                                                               !   Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: fac11(:)
+                                                               !   Dimensions: (nlayers)
+
+! ------- Output -------
+                                                               !   All Dimensions: (nlayers+1)
+      real(kind=rb), intent(out) :: pbbcd(:)
+      real(kind=rb), intent(out) :: pbbcu(:)
+      real(kind=rb), intent(out) :: pbbfd(:)
+      real(kind=rb), intent(out) :: pbbfu(:)
+      real(kind=rb), intent(out) :: pbbfddir(:)
+      real(kind=rb), intent(out) :: pbbcddir(:)
+
+      real(kind=rb), intent(out) :: puvcd(:)
+      real(kind=rb), intent(out) :: puvfd(:)
+      real(kind=rb), intent(out) :: puvcddir(:)
+      real(kind=rb), intent(out) :: puvfddir(:)
+
+      real(kind=rb), intent(out) :: pnicd(:)
+      real(kind=rb), intent(out) :: pnifd(:)
+      real(kind=rb), intent(out) :: pnicddir(:)
+      real(kind=rb), intent(out) :: pnifddir(:)
+
+! Output - inactive                                            !   All Dimensions: (nlayers+1)
+!      real(kind=rb), intent(out) :: puvcu(:)
+!      real(kind=rb), intent(out) :: puvfu(:)
+!      real(kind=rb), intent(out) :: pnicu(:)
+!      real(kind=rb), intent(out) :: pnifu(:)
+!      real(kind=rb), intent(out) :: pvscd(:)
+!      real(kind=rb), intent(out) :: pvscu(:)
+!      real(kind=rb), intent(out) :: pvsfd(:)
+!      real(kind=rb), intent(out) :: pvsfu(:)
+
+! ------- Local -------
+
+      logical :: lrtchkclr(nlayers),lrtchkcld(nlayers)
+
+      integer(kind=im)  :: klev
+      integer(kind=im) :: ib1, ib2, ibm, igt, ikl, ikp, ikx
+      integer(kind=im) :: iw, jb, jg, jl, jk
+!      integer(kind=im), parameter :: nuv = ?? 
+!      integer(kind=im), parameter :: nvs = ?? 
+      integer(kind=im) :: itind
+
+      real(kind=rb) :: tblind, ze1
+      real(kind=rb) :: zclear, zcloud
+      real(kind=rb) :: zdbt(nlayers+1), zdbt_nodel(nlayers+1)
+      real(kind=rb) :: zgc(nlayers), zgcc(nlayers), zgco(nlayers)
+      real(kind=rb) :: zomc(nlayers), zomcc(nlayers), zomco(nlayers)
+      real(kind=rb) :: zrdnd(nlayers+1), zrdndc(nlayers+1)
+      real(kind=rb) :: zref(nlayers+1), zrefc(nlayers+1), zrefo(nlayers+1)
+      real(kind=rb) :: zrefd(nlayers+1), zrefdc(nlayers+1), zrefdo(nlayers+1)
+      real(kind=rb) :: zrup(nlayers+1), zrupd(nlayers+1)
+      real(kind=rb) :: zrupc(nlayers+1), zrupdc(nlayers+1)
+      real(kind=rb) :: zs1(nlayers+1)
+      real(kind=rb) :: ztauc(nlayers), ztauo(nlayers)
+      real(kind=rb) :: ztdn(nlayers+1), ztdnd(nlayers+1), ztdbt(nlayers+1)
+      real(kind=rb) :: ztoc(nlayers), ztor(nlayers)
+      real(kind=rb) :: ztra(nlayers+1), ztrac(nlayers+1), ztrao(nlayers+1)
+      real(kind=rb) :: ztrad(nlayers+1), ztradc(nlayers+1), ztrado(nlayers+1)
+      real(kind=rb) :: zdbtc(nlayers+1), ztdbtc(nlayers+1)
+      real(kind=rb) :: zincflx(ngptsw), zdbtc_nodel(nlayers+1) 
+      real(kind=rb) :: ztdbt_nodel(nlayers+1), ztdbtc_nodel(nlayers+1)
+
+      real(kind=rb) :: zdbtmc, zdbtmo, zf, zgw, zreflect
+      real(kind=rb) :: zwf, tauorig, repclc
+!     real(kind=rb) :: zincflux                                   ! inactive
+
+! Arrays from rrtmg_sw_taumoln routines
+
+!      real(kind=rb) :: ztaug(nlayers,16), ztaur(nlayers,16)
+!      real(kind=rb) :: zsflxzen(16)
+      real(kind=rb) :: ztaug(nlayers,ngptsw), ztaur(nlayers,ngptsw)
+      real(kind=rb) :: zsflxzen(ngptsw)
+
+! Arrays from rrtmg_sw_vrtqdr routine
+
+      real(kind=rb) :: zcd(nlayers+1,ngptsw), zcu(nlayers+1,ngptsw)
+      real(kind=rb) :: zfd(nlayers+1,ngptsw), zfu(nlayers+1,ngptsw)
+
+! Inactive arrays
+!     real(kind=rb) :: zbbcd(nlayers+1), zbbcu(nlayers+1)
+!     real(kind=rb) :: zbbfd(nlayers+1), zbbfu(nlayers+1)
+!     real(kind=rb) :: zbbfddir(nlayers+1), zbbcddir(nlayers+1)
+
+! ------------------------------------------------------------------
+
+! Initializations
+
+      ib1 = istart
+      ib2 = iend
+      klev = nlayers
+      iw = 0
+      repclc = 1.e-12_rb
+!      zincflux = 0.0_rb
+
+      do jk=1,klev+1
+         pbbcd(jk)=0._rb
+         pbbcu(jk)=0._rb
+         pbbfd(jk)=0._rb
+         pbbfu(jk)=0._rb
+         pbbcddir(jk)=0._rb
+         pbbfddir(jk)=0._rb
+         puvcd(jk)=0._rb
+         puvfd(jk)=0._rb
+         puvcddir(jk)=0._rb
+         puvfddir(jk)=0._rb
+         pnicd(jk)=0._rb
+         pnifd(jk)=0._rb
+         pnicddir(jk)=0._rb
+         pnifddir(jk)=0._rb
+      enddo
+
+
+! Calculate the optical depths for gaseous absorption and Rayleigh scattering
+
+      call taumol_sw(klev, &
+                     colh2o, colco2, colch4, colo2, colo3, colmol, &
+                     laytrop, jp, jt, jt1, &
+                     fac00, fac01, fac10, fac11, &
+                     selffac, selffrac, indself, forfac, forfrac, indfor, &
+                     zsflxzen, ztaug, ztaur)
+
+! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14
+
+      do jb = ib1, ib2
+         ibm = jb-15
+         igt = ngc(ibm)
+
+! Reinitialize g-point counter for each band if output for each band is requested.
+         if (iout.gt.0.and.ibm.ge.2) iw = ngs(ibm-1)
+
+!        do jk=1,klev+1
+!           zbbcd(jk)=0.0_rb
+!           zbbcu(jk)=0.0_rb
+!           zbbfd(jk)=0.0_rb
+!           zbbfu(jk)=0.0_rb
+!        enddo
+
+! Top of g-point interval loop within each band (iw is cumulative counter) 
+         do jg = 1,igt
+            iw = iw+1
+
+! Apply adjustment for correct Earth/Sun distance and zenith angle to incoming solar flux
+            zincflx(iw) = adjflux(jb) * zsflxzen(iw) * prmu0
+!             zincflux = zincflux + adjflux(jb) * zsflxzen(iw) * prmu0           ! inactive
+
+! Compute layer reflectances and transmittances for direct and diffuse sources, 
+! first clear then cloudy
+
+! zrefc(jk)  direct albedo for clear
+! zrefo(jk)  direct albedo for cloud
+! zrefdc(jk) diffuse albedo for clear
+! zrefdo(jk) diffuse albedo for cloud
+! ztrac(jk)  direct transmittance for clear
+! ztrao(jk)  direct transmittance for cloudy
+! ztradc(jk) diffuse transmittance for clear
+! ztrado(jk) diffuse transmittance for cloudy
+!  
+! zref(jk)   direct reflectance
+! zrefd(jk)  diffuse reflectance
+! ztra(jk)   direct transmittance
+! ztrad(jk)  diffuse transmittance
+!
+! zdbtc(jk)  clear direct beam transmittance
+! zdbto(jk)  cloudy direct beam transmittance
+! zdbt(jk)   layer mean direct beam transmittance
+! ztdbt(jk)  total direct beam transmittance at levels
+
+! Clear-sky    
+!   TOA direct beam    
+            ztdbtc(1)=1.0_rb
+            ztdbtc_nodel(1)=1.0_rb
+!   Surface values
+            zdbtc(klev+1) =0.0_rb
+            ztrac(klev+1) =0.0_rb
+            ztradc(klev+1)=0.0_rb
+            zrefc(klev+1) =palbp(ibm)
+            zrefdc(klev+1)=palbd(ibm)
+            zrupc(klev+1) =palbp(ibm)
+            zrupdc(klev+1)=palbd(ibm)
+           
+! Total sky    
+!   TOA direct beam    
+            ztdbt(1)=1.0_rb
+            ztdbt_nodel(1)=1.0_rb
+!   Surface values
+            zdbt(klev+1) =0.0_rb
+            ztra(klev+1) =0.0_rb
+            ztrad(klev+1)=0.0_rb
+            zref(klev+1) =palbp(ibm)
+            zrefd(klev+1)=palbd(ibm)
+            zrup(klev+1) =palbp(ibm)
+            zrupd(klev+1)=palbd(ibm)
+    
+! Top of layer loop
+            do jk=1,klev
+
+! Note: two-stream calculations proceed from top to bottom; 
+!   RRTMG_SW quantities are given bottom to top and are reversed here
+
+               ikl=klev+1-jk
+
+! Set logical flag to do REFTRA calculation
+!   Do REFTRA for all clear layers
+               lrtchkclr(jk)=.true.
+
+!   Do REFTRA only for cloudy layers in profile, since already done for clear layers
+               lrtchkcld(jk)=.false.
+               lrtchkcld(jk)=(pcldfmc(ikl,iw) > repclc)
+
+! Clear-sky optical parameters - this section inactive     
+!   Original
+!               ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw)
+!               zomcc(jk) = ztaur(ikl,iw) / ztauc(jk)
+!               zgcc(jk) = 0.0001_rb
+!   Total sky optical parameters        
+!               ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaucmc(ikl,iw)
+!               zomco(jk) = ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + ztaur(ikl,iw)
+!               zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + &
+!                           ztaur(ikl,iw) * 0.0001_rb) / zomco(jk)
+!               zomco(jk) = zomco(jk) / ztauo(jk)
+
+! Clear-sky optical parameters including aerosols
+               ztauc(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaua(ikl,ibm)
+               zomcc(jk) = ztaur(ikl,iw) * 1.0_rb + ptaua(ikl,ibm) * pomga(ikl,ibm)
+               zgcc(jk) = pasya(ikl,ibm) * pomga(ikl,ibm) * ptaua(ikl,ibm) / zomcc(jk)
+               zomcc(jk) = zomcc(jk) / ztauc(jk)
+
+! Pre-delta-scaling clear and cloudy direct beam transmittance (must use 'orig', unscaled cloud OD)       
+!   \/\/\/ This block of code is only needed for direct beam calculation
+!     
+               zclear = 1.0_rb - pcldfmc(ikl,iw)
+               zcloud = pcldfmc(ikl,iw)
+
+! Clear
+!                zdbtmc = exp(-ztauc(jk) / prmu0)
+
+! Use exponential lookup table for transmittance, or expansion of 
+! exponential for low tau
+               ze1 = ztauc(jk) / prmu0
+               if (ze1 .le. od_lo) then
+                  zdbtmc = 1._rb - ze1 + 0.5_rb * ze1 * ze1
+               else 
+                  tblind = ze1 / (bpade + ze1)
+                  itind = tblint * tblind + 0.5_rb
+                  zdbtmc = exp_tbl(itind)
+               endif
+
+               zdbtc_nodel(jk) = zdbtmc
+               ztdbtc_nodel(jk+1) = zdbtc_nodel(jk) * ztdbtc_nodel(jk)
+
+! Clear + Cloud
+               tauorig = ztauc(jk) + ptaormc(ikl,iw)
+!                zdbtmo = exp(-tauorig / prmu0)
+
+! Use exponential lookup table for transmittance, or expansion of 
+! exponential for low tau
+               ze1 = tauorig / prmu0
+               if (ze1 .le. od_lo) then
+                  zdbtmo = 1._rb - ze1 + 0.5_rb * ze1 * ze1
+               else
+                  tblind = ze1 / (bpade + ze1)
+                  itind = tblint * tblind + 0.5_rb
+                  zdbtmo = exp_tbl(itind)
+               endif
+
+               zdbt_nodel(jk) = zclear*zdbtmc + zcloud*zdbtmo
+               ztdbt_nodel(jk+1) = zdbt_nodel(jk) * ztdbt_nodel(jk)
+!   /\/\/\ Above code only needed for direct beam calculation
+
+
+! Delta scaling - clear   
+               zf = zgcc(jk) * zgcc(jk)
+               zwf = zomcc(jk) * zf
+               ztauc(jk) = (1.0_rb - zwf) * ztauc(jk)
+               zomcc(jk) = (zomcc(jk) - zwf) / (1.0_rb - zwf)
+               zgcc (jk) = (zgcc(jk) - zf) / (1.0_rb - zf)
+
+! Total sky optical parameters (cloud properties already delta-scaled)
+!   Use this code if cloud properties are derived in rrtmg_sw_cldprop       
+               if (icpr .ge. 1) then
+                  ztauo(jk) = ztauc(jk) + ptaucmc(ikl,iw)
+                  zomco(jk) = ztauc(jk) * zomcc(jk) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw) 
+                  zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + &
+                              ztauc(jk) * zomcc(jk) * zgcc(jk)) / zomco(jk)
+                  zomco(jk) = zomco(jk) / ztauo(jk)
+
+! Total sky optical parameters (if cloud properties not delta scaled)
+!   Use this code if cloud properties are not derived in rrtmg_sw_cldprop       
+               elseif (icpr .eq. 0) then
+                  ztauo(jk) = ztaur(ikl,iw) + ztaug(ikl,iw) + ptaua(ikl,ibm) + ptaucmc(ikl,iw)
+                  zomco(jk) = ptaua(ikl,ibm) * pomga(ikl,ibm) + ptaucmc(ikl,iw) * pomgcmc(ikl,iw) + &
+                              ztaur(ikl,iw) * 1.0_rb
+                  zgco (jk) = (ptaucmc(ikl,iw) * pomgcmc(ikl,iw) * pasycmc(ikl,iw) + &
+                              ptaua(ikl,ibm)*pomga(ikl,ibm)*pasya(ikl,ibm)) / zomco(jk)
+                  zomco(jk) = zomco(jk) / ztauo(jk)
+
+! Delta scaling - clouds 
+!   Use only if subroutine rrtmg_sw_cldprop is not used to get cloud properties and to apply delta scaling
+                  zf = zgco(jk) * zgco(jk)
+                  zwf = zomco(jk) * zf
+                  ztauo(jk) = (1._rb - zwf) * ztauo(jk)
+                  zomco(jk) = (zomco(jk) - zwf) / (1.0_rb - zwf)
+                  zgco (jk) = (zgco(jk) - zf) / (1.0_rb - zf)
+               endif 
+
+! End of layer loop
+            enddo    
+
+! Clear sky reflectivities
+            call reftra_sw (klev, &
+                            lrtchkclr, zgcc, prmu0, ztauc, zomcc, &
+                            zrefc, zrefdc, ztrac, ztradc)
+
+! Total sky reflectivities      
+            call reftra_sw (klev, &
+                            lrtchkcld, zgco, prmu0, ztauo, zomco, &
+                            zrefo, zrefdo, ztrao, ztrado)
+
+            do jk=1,klev
+
+! Combine clear and cloudy contributions for total sky
+               ikl = klev+1-jk 
+               zclear = 1.0_rb - pcldfmc(ikl,iw)
+               zcloud = pcldfmc(ikl,iw)
+
+               zref(jk) = zclear*zrefc(jk) + zcloud*zrefo(jk)
+               zrefd(jk)= zclear*zrefdc(jk) + zcloud*zrefdo(jk)
+               ztra(jk) = zclear*ztrac(jk) + zcloud*ztrao(jk)
+               ztrad(jk)= zclear*ztradc(jk) + zcloud*ztrado(jk)
+
+! Direct beam transmittance        
+
+! Clear
+!                zdbtmc = exp(-ztauc(jk) / prmu0)
+
+! Use exponential lookup table for transmittance, or expansion of 
+! exponential for low tau
+               ze1 = ztauc(jk) / prmu0
+               if (ze1 .le. od_lo) then
+                  zdbtmc = 1._rb - ze1 + 0.5_rb * ze1 * ze1
+               else
+                  tblind = ze1 / (bpade + ze1)
+                  itind = tblint * tblind + 0.5_rb
+                  zdbtmc = exp_tbl(itind)
+               endif
+
+               zdbtc(jk) = zdbtmc
+               ztdbtc(jk+1) = zdbtc(jk)*ztdbtc(jk)
+
+! Clear + Cloud
+!                zdbtmo = exp(-ztauo(jk) / prmu0)
+
+! Use exponential lookup table for transmittance, or expansion of 
+! exponential for low tau
+               ze1 = ztauo(jk) / prmu0
+               if (ze1 .le. od_lo) then
+                  zdbtmo = 1._rb - ze1 + 0.5_rb * ze1 * ze1
+               else
+                  tblind = ze1 / (bpade + ze1)
+                  itind = tblint * tblind + 0.5_rb
+                  zdbtmo = exp_tbl(itind)
+               endif
+
+               zdbt(jk) = zclear*zdbtmc + zcloud*zdbtmo
+               ztdbt(jk+1) = zdbt(jk)*ztdbt(jk)
+        
+            enddo           
+                 
+! Vertical quadrature for clear-sky fluxes
+
+            call vrtqdr_sw(klev, iw, &
+                           zrefc, zrefdc, ztrac, ztradc, &
+                           zdbtc, zrdndc, zrupc, zrupdc, ztdbtc, &
+                           zcd, zcu)
+      
+! Vertical quadrature for cloudy fluxes
+
+            call vrtqdr_sw(klev, iw, &
+                           zref, zrefd, ztra, ztrad, &
+                           zdbt, zrdnd, zrup, zrupd, ztdbt, &
+                           zfd, zfu)
+
+! Upwelling and downwelling fluxes at levels
+!   Two-stream calculations go from top to bottom; 
+!   layer indexing is reversed to go bottom to top for output arrays
+
+            do jk=1,klev+1
+               ikl=klev+2-jk
+
+! Accumulate spectral fluxes over bands - inactive
+!               zbbfu(ikl) = zbbfu(ikl) + zincflx(iw)*zfu(jk,iw)  
+!               zbbfd(ikl) = zbbfd(ikl) + zincflx(iw)*zfd(jk,iw)
+!               zbbcu(ikl) = zbbcu(ikl) + zincflx(iw)*zcu(jk,iw)
+!               zbbcd(ikl) = zbbcd(ikl) + zincflx(iw)*zcd(jk,iw)
+!               zbbfddir(ikl) = zbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
+!               zbbcddir(ikl) = zbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
+
+! Accumulate spectral fluxes over whole spectrum  
+               pbbfu(ikl) = pbbfu(ikl) + zincflx(iw)*zfu(jk,iw)
+               pbbfd(ikl) = pbbfd(ikl) + zincflx(iw)*zfd(jk,iw)
+               pbbcu(ikl) = pbbcu(ikl) + zincflx(iw)*zcu(jk,iw)
+               pbbcd(ikl) = pbbcd(ikl) + zincflx(iw)*zcd(jk,iw)
+               pbbfddir(ikl) = pbbfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
+               pbbcddir(ikl) = pbbcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
+
+! Accumulate direct fluxes for UV/visible bands
+               if (ibm >= 10 .and. ibm <= 13) then
+                  puvcd(ikl) = puvcd(ikl) + zincflx(iw)*zcd(jk,iw)
+                  puvfd(ikl) = puvfd(ikl) + zincflx(iw)*zfd(jk,iw)
+                  puvcddir(ikl) = puvcddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
+                  puvfddir(ikl) = puvfddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
+! Accumulate direct fluxes for near-IR bands
+               else if (ibm == 14 .or. ibm <= 9) then  
+                  pnicd(ikl) = pnicd(ikl) + zincflx(iw)*zcd(jk,iw)
+                  pnifd(ikl) = pnifd(ikl) + zincflx(iw)*zfd(jk,iw)
+                  pnicddir(ikl) = pnicddir(ikl) + zincflx(iw)*ztdbtc_nodel(jk)
+                  pnifddir(ikl) = pnifddir(ikl) + zincflx(iw)*ztdbt_nodel(jk)
+               endif
+
+            enddo
+
+! End loop on jg, g-point interval
+         enddo             
+
+! End loop on jb, spectral band
+      enddo                    
+
+      end subroutine spcvmc_sw
+
+      end module rrtmg_sw_spcvmc
+
+!     path:      $Source: /cvsroot/NWP/WRFV3/phys/module_ra_rrtmg_sw.F,v $
+!     author:    $Author: trn $
+!     revision:  $Revision: 1.3 $
+!     created:   $Date: 2009/04/16 19:54:22 $
+!
+       module rrtmg_sw_rad
+
+!  --------------------------------------------------------------------------
+! |                                                                          |
+! |  Copyright 2002-2008, Atmospheric & Environmental Research, Inc. (AER).  |
+! |  This software may be used, copied, or redistributed as long as it is    |
+! |  not sold and this copyright notice is reproduced on each copy made.     |
+! |  This model is provided as is without any express or implied warranties. |
+! |                       (http://www.rtweb.aer.com/)                        |
+! |                                                                          |
+!  --------------------------------------------------------------------------
+!
+! ****************************************************************************
+! *                                                                          *
+! *                             RRTMG_SW                                     *
+! *                                                                          *
+! *                                                                          *
+! *                                                                          *
+! *                 a rapid radiative transfer model                         *
+! *                  for the solar spectral region                           *
+! *           for application to general circulation models                  *
+! *                                                                          *
+! *                                                                          *
+! *           Atmospheric and Environmental Research, Inc.                   *
+! *                       131 Hartwell Avenue                                *
+! *                       Lexington, MA 02421                                *
+! *                                                                          *
+! *                                                                          *
+! *                          Eli J. Mlawer                                   *
+! *                       Jennifer S. Delamere                               *
+! *                        Michael J. Iacono                                 *
+! *                        Shepard A. Clough                                 *
+! *                                                                          *
+! *                                                                          *
+! *                                                                          *
+! *                                                                          *
+! *                                                                          *
+! *                                                                          *
+! *                      email:  miacono@aer.com                             *
+! *                      email:  emlawer@aer.com                             *
+! *                      email:  jdelamer@aer.com                            *
+! *                                                                          *
+! *       The authors wish to acknowledge the contributions of the           *
+! *       following people:  Steven J. Taubman, Patrick D. Brown,            *
+! *       Ronald E. Farren, Luke Chen, Robert Bergstrom.                     *
+! *                                                                          *
+! ****************************************************************************
+
+! --------- Modules ---------
+
+      use parkind, only : im => kind_im, rb => kind_rb
+      use rrsw_vsn
+      use mcica_subcol_gen_sw, only: mcica_subcol_sw
+      use rrtmg_sw_cldprmc, only: cldprmc_sw
+! *** Move the required call to rrtmg_sw_ini below and the following 
+! use association to GCM initialization area ***
+!      use rrtmg_sw_init, only: rrtmg_sw_ini
+      use rrtmg_sw_setcoef, only: setcoef_sw
+      use rrtmg_sw_spcvmc, only: spcvmc_sw
+
+      implicit none
+
+! public interfaces/functions/subroutines
+      public :: rrtmg_sw, inatm_sw, earth_sun
+
+!------------------------------------------------------------------
+      contains
+!------------------------------------------------------------------
+
+!------------------------------------------------------------------
+! Public subroutines
+!------------------------------------------------------------------
+
+      subroutine rrtmg_sw &
+            (ncol    ,nlay    ,icld    , &
+             play    ,plev    ,tlay    ,tlev    ,tsfc   , &
+             h2ovmr , o3vmr   ,co2vmr  ,ch4vmr  ,n2ovmr ,o2vmr , &
+             asdir   ,asdif   ,aldir   ,aldif   , &
+             coszen  ,adjes   ,dyofyr  ,scon    , &
+             inflgsw ,iceflgsw,liqflgsw,cldfmcl , &
+             taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , &
+             ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
+             tauaer  ,ssaaer  ,asmaer  ,ecaer   , &
+             swuflx  ,swdflx  ,swhr    ,swuflxc ,swdflxc ,swhrc)
+
+! ------- Description -------
+
+! This program is the driver for RRTMG_SW, the AER SW radiation model for 
+!  application to GCMs, that has been adapted from RRTM_SW for improved
+!  efficiency and to provide fractional cloudiness and cloud overlap
+!  capability using McICA.
+!
+! Note: The call to RRTMG_SW_INI should be moved to the GCM initialization 
+!  area, since this has to be called only once. 
+!
+! This routine
+!    b) calls INATM_SW to read in the atmospheric profile;
+!       all layering in RRTMG is ordered from surface to toa. 
+!    c) calls CLDPRMC_SW to set cloud optical depth for McICA based
+!       on input cloud properties
+!    d) calls SETCOEF_SW to calculate various quantities needed for 
+!       the radiative transfer algorithm
+!    e) calls SPCVMC to call the two-stream model that in turn 
+!       calls TAUMOL to calculate gaseous optical depths for each 
+!       of the 16 spectral bands and to perform the radiative transfer
+!       using McICA, the Monte-Carlo Independent Column Approximation,
+!       to represent sub-grid scale cloud variability
+!    f) passes the calculated fluxes and cooling rates back to GCM
+!
+! Two modes of operation are possible:
+!     The mode is chosen by using either rrtmg_sw.nomcica.f90 (to not use
+!     McICA) or rrtmg_sw.f90 (to use McICA) to interface with a GCM.
+!
+!    1) Standard, single forward model calculation (imca = 0); this is 
+!       valid only for clear sky or fully overcast clouds
+!    2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., 
+!       JC, 2003) method is applied to the forward model calculation (imca = 1)
+!       This method is valid for clear sky or partial cloud conditions.
+!
+! This call to RRTMG_SW must be preceeded by a call to the module
+!     mcica_subcol_gen_sw.f90 to run the McICA sub-column cloud generator,
+!     which will provide the cloud physical or cloud optical properties
+!     on the RRTMG quadrature point (ngptsw) dimension.
+!
+! Two methods of cloud property input are possible:
+!     Cloud properties can be input in one of two ways (controlled by input 
+!     flags inflag, iceflag and liqflag; see text file rrtmg_sw_instructions
+!     and subroutine rrtmg_sw_cldprop.f90 for further details):
+!
+!    1) Input cloud fraction, cloud optical depth, single scattering albedo 
+!       and asymmetry parameter directly (inflgsw = 0)
+!    2) Input cloud fraction and cloud physical properties: ice fracion,
+!       ice and liquid particle sizes (inflgsw = 1 or 2);  
+!       cloud optical properties are calculated by cldprop or cldprmc based
+!       on input settings of iceflgsw and liqflgsw
+!
+! Two methods of aerosol property input are possible:
+!     Aerosol properties can be input in one of two ways (controlled by input 
+!     flag iaer, see text file rrtmg_sw_instructions for further details):
+!
+!    1) Input aerosol optical depth, single scattering albedo and asymmetry
+!       parameter directly by layer and spectral band (iaer=10)
+!    2) Input aerosol optical depth and 0.55 micron directly by layer and use
+!       one or more of six ECMWF aerosol types (iaer=6)
+!
+!
+! ------- Modifications -------
+!
+! This version of RRTMG_SW has been modified from RRTM_SW to use a reduced
+! set of g-point intervals and a two-stream model for application to GCMs. 
+!
+!-- Original version (derived from RRTM_SW)
+!     2002: AER. Inc.
+!-- Conversion to F90 formatting; addition of 2-stream radiative transfer
+!     Feb 2003: J.-J. Morcrette, ECMWF
+!-- Additional modifications for GCM application
+!     Aug 2003: M. J. Iacono, AER Inc.
+!-- Total number of g-points reduced from 224 to 112.  Original
+!   set of 224 can be restored by exchanging code in module parrrsw.f90 
+!   and in file rrtmg_sw_init.f90.
+!     Apr 2004: M. J. Iacono, AER, Inc.
+!-- Modifications to include output for direct and diffuse 
+!   downward fluxes.  There are output as "true" fluxes without
+!   any delta scaling applied.  Code can be commented to exclude
+!   this calculation in source file rrtmg_sw_spcvrt.f90.
+!     Jan 2005: E. J. Mlawer, M. J. Iacono, AER, Inc.
+!-- Revised to add McICA capability.
+!     Nov 2005: M. J. Iacono, AER, Inc.
+!-- Reformatted for consistency with rrtmg_lw.
+!     Feb 2007: M. J. Iacono, AER, Inc.
+!-- Modifications to formatting to use assumed-shape arrays. 
+!     Aug 2007: M. J. Iacono, AER, Inc.
+
+! --------- Modules ---------
+
+      use parrrsw, only : nbndsw, ngptsw, naerec, nstr, nmol, mxmol, &
+                          jpband, jpb1, jpb2
+      use rrsw_aer, only : rsrtaua, rsrpiza, rsrasya
+      use rrsw_con, only : heatfac, oneminus, pi
+      use rrsw_wvn, only : wavenum1, wavenum2
+
+! ------- Declarations
+
+! ----- Input -----
+
+      integer(kind=im), intent(in) :: ncol            ! Number of horizontal columns     
+      integer(kind=im), intent(in) :: nlay            ! Number of model layers
+      integer(kind=im), intent(inout) :: icld         ! Cloud overlap method
+                                                      !    0: Clear only
+                                                      !    1: Random
+                                                      !    2: Maximum/random
+                                                      !    3: Maximum
+
+      real(kind=rb), intent(in) :: play(:,:)          ! Layer pressures (hPa, mb)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: plev(:,:)          ! Interface pressures (hPa, mb)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(in) :: tlay(:,:)          ! Layer temperatures (K)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: tlev(:,:)          ! Interface temperatures (K)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(in) :: tsfc(:)            ! Surface temperature (K)
+                                                      !    Dimensions: (ncol)
+      real(kind=rb), intent(in) :: h2ovmr(:,:)        ! H2O volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: o3vmr(:,:)         ! O3 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: co2vmr(:,:)        ! CO2 volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: ch4vmr(:,:)        ! Methane volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: n2ovmr(:,:)        ! Nitrous oxide volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: o2vmr(:,:)         ! Oxygen volume mixing ratio
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: asdir(:)           ! UV/vis surface albedo direct rad
+                                                      !    Dimensions: (ncol)
+      real(kind=rb), intent(in) :: aldir(:)           ! Near-IR surface albedo direct rad
+                                                      !    Dimensions: (ncol)
+      real(kind=rb), intent(in) :: asdif(:)           ! UV/vis surface albedo: diffuse rad
+                                                      !    Dimensions: (ncol)
+      real(kind=rb), intent(in) :: aldif(:)           ! Near-IR surface albedo: diffuse rad
+                                                      !    Dimensions: (ncol)
+
+      integer(kind=im), intent(in) :: dyofyr          ! Day of the year (used to get Earth/Sun
+                                                      !  distance if adjflx not provided)
+      real(kind=rb), intent(in) :: adjes              ! Flux adjustment for Earth/Sun distance
+      real(kind=rb), intent(in) :: coszen(:)          ! Cosine of solar zenith angle
+                                                      !    Dimensions: (ncol)
+      real(kind=rb), intent(in) :: scon               ! Solar constant (W/m2)
+
+      integer(kind=im), intent(in) :: inflgsw         ! Flag for cloud optical properties
+      integer(kind=im), intent(in) :: iceflgsw        ! Flag for ice particle specification
+      integer(kind=im), intent(in) :: liqflgsw        ! Flag for liquid droplet specification
+
+      real(kind=rb), intent(in) :: cldfmcl(:,:,:)     ! Cloud fraction
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: taucmcl(:,:,:)     ! In-cloud optical depth
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: ssacmcl(:,:,:)     ! In-cloud single scattering albedo
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: asmcmcl(:,:,:)     ! In-cloud asymmetry parameter
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: fsfcmcl(:,:,:)     ! In-cloud forward scattering fraction
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: ciwpmcl(:,:,:)     ! In-cloud ice water path (g/m2)
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: clwpmcl(:,:,:)     ! In-cloud liquid water path (g/m2)
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: reicmcl(:,:)       ! Cloud ice effective radius (microns)
+                                                      !    Dimensions: (ncol,nlay)
+                                                      ! specific definition of reicmcl depends on setting of iceflglw:
+                                                      ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
+                                                      !               r_ec must be >= 10.0 microns
+                                                      ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
+                                                      !               r_ec range is limited to 13.0 to 130.0 microns
+                                                      ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
+                                                      !               r_k range is limited to 5.0 to 131.0 microns
+                                                      ! iceflglw = 3: generalized effective size, dge, (Fu, 1996),
+                                                      !               dge range is limited to 5.0 to 140.0 microns
+                                                      !               [dge = 1.0315 * r_ec]
+      real(kind=rb), intent(in) :: relqmcl(:,:)       ! Cloud water drop effective radius (microns)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: tauaer(:,:,:)      ! Aerosol optical depth (iaer=10 only)
+                                                      !    Dimensions: (ncol,nlay,nbndsw)
+                                                      ! (non-delta scaled)      
+      real(kind=rb), intent(in) :: ssaaer(:,:,:)      ! Aerosol single scattering albedo (iaer=10 only)
+                                                      !    Dimensions: (ncol,nlay,nbndsw)
+                                                      ! (non-delta scaled)      
+      real(kind=rb), intent(in) :: asmaer(:,:,:)      ! Aerosol asymmetry parameter (iaer=10 only)
+                                                      !    Dimensions: (ncol,nlay,nbndsw)
+                                                      ! (non-delta scaled)      
+      real(kind=rb), intent(in) :: ecaer(:,:,:)       ! Aerosol optical depth at 0.55 micron (iaer=6 only)
+                                                      !    Dimensions: (ncol,nlay,naerec)
+                                                      ! (non-delta scaled)      
+
+! ----- Output -----
+
+      real(kind=rb), intent(out) :: swuflx(:,:)       ! Total sky shortwave upward flux (W/m2)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(out) :: swdflx(:,:)       ! Total sky shortwave downward flux (W/m2)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(out) :: swhr(:,:)         ! Total sky shortwave radiative heating rate (K/d)
+                                                      !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(out) :: swuflxc(:,:)      ! Clear sky shortwave upward flux (W/m2)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(out) :: swdflxc(:,:)      ! Clear sky shortwave downward flux (W/m2)
+                                                      !    Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(out) :: swhrc(:,:)        ! Clear sky shortwave radiative heating rate (K/d)
+                                                      !    Dimensions: (ncol,nlay)
+
+! ----- Local -----
+
+! Control
+      integer(kind=im) :: nlayers             ! total number of layers
+      integer(kind=im) :: istart              ! beginning band of calculation
+      integer(kind=im) :: iend                ! ending band of calculation
+      integer(kind=im) :: icpr                ! cldprop/cldprmc use flag
+      integer(kind=im) :: iout                ! output option flag (inactive)
+      integer(kind=im) :: iaer                ! aerosol option flag
+      integer(kind=im) :: idelm               ! delta-m scaling flag (inactive)
+      integer(kind=im) :: isccos              ! instrumental cosine response flag (inactive)
+      integer(kind=im) :: iplon               ! column loop index
+      integer(kind=im) :: i                   ! layer loop index                       ! jk
+      integer(kind=im) :: ib                  ! band loop index                        ! jsw
+      integer(kind=im) :: ia, ig              ! indices
+      integer(kind=im) :: k                   ! layer loop index
+      integer(kind=im) :: ims                 ! value for changing mcica permute seed
+      integer(kind=im) :: imca                ! flag for mcica [0=off, 1=on]
+
+      real(kind=rb) :: zepsec, zepzen         ! epsilon
+      real(kind=rb) :: zdpgcp                 ! flux to heating conversion ratio
+
+! Atmosphere
+      real(kind=rb) :: pavel(nlay+1)          ! layer pressures (mb) 
+      real(kind=rb) :: tavel(nlay+1)          ! layer temperatures (K)
+      real(kind=rb) :: pz(0:nlay+1)           ! level (interface) pressures (hPa, mb)
+      real(kind=rb) :: tz(0:nlay+1)           ! level (interface) temperatures (K)
+      real(kind=rb) :: tbound                 ! surface temperature (K)
+      real(kind=rb) :: pdp(nlay+1)            ! layer pressure thickness (hPa, mb)
+      real(kind=rb) :: coldry(nlay+1)         ! dry air column amount
+      real(kind=rb) :: wkl(mxmol,nlay+1)      ! molecular amounts (mol/cm-2)
+
+!      real(kind=rb) :: earth_sun             ! function for Earth/Sun distance factor
+      real(kind=rb) :: cossza                 ! Cosine of solar zenith angle
+      real(kind=rb) :: adjflux(jpband)        ! adjustment for current Earth/Sun distance
+      real(kind=rb) :: solvar(jpband)         ! solar constant scaling factor from rrtmg_sw
+                                              !  default value of 1368.22 Wm-2 at 1 AU
+      real(kind=rb) :: albdir(nbndsw)         ! surface albedo, direct          ! zalbp
+      real(kind=rb) :: albdif(nbndsw)         ! surface albedo, diffuse         ! zalbd
+
+      real(kind=rb) :: taua(nlay+1,nbndsw)    ! Aerosol optical depth
+      real(kind=rb) :: ssaa(nlay+1,nbndsw)    ! Aerosol single scattering albedo
+      real(kind=rb) :: asma(nlay+1,nbndsw)    ! Aerosol asymmetry parameter
+
+! Atmosphere - setcoef
+      integer(kind=im) :: laytrop             ! tropopause layer index
+      integer(kind=im) :: layswtch            ! tropopause layer index
+      integer(kind=im) :: laylow              ! tropopause layer index
+      integer(kind=im) :: jp(nlay+1)          ! 
+      integer(kind=im) :: jt(nlay+1)          !
+      integer(kind=im) :: jt1(nlay+1)         !
+
+      real(kind=rb) :: colh2o(nlay+1)         ! column amount (h2o)
+      real(kind=rb) :: colco2(nlay+1)         ! column amount (co2)
+      real(kind=rb) :: colo3(nlay+1)          ! column amount (o3)
+      real(kind=rb) :: coln2o(nlay+1)         ! column amount (n2o)
+      real(kind=rb) :: colch4(nlay+1)         ! column amount (ch4)
+      real(kind=rb) :: colo2(nlay+1)          ! column amount (o2)
+      real(kind=rb) :: colmol(nlay+1)         ! column amount
+      real(kind=rb) :: co2mult(nlay+1)        ! column amount 
+
+      integer(kind=im) :: indself(nlay+1)
+      integer(kind=im) :: indfor(nlay+1)
+      real(kind=rb) :: selffac(nlay+1)
+      real(kind=rb) :: selffrac(nlay+1)
+      real(kind=rb) :: forfac(nlay+1)
+      real(kind=rb) :: forfrac(nlay+1)
+
+      real(kind=rb) :: &                      !
+                         fac00(nlay+1), fac01(nlay+1), &
+                         fac10(nlay+1), fac11(nlay+1) 
+
+! Atmosphere/clouds - cldprop
+      integer(kind=im) :: ncbands             ! number of cloud spectral bands
+      integer(kind=im) :: inflag              ! flag for cloud property method
+      integer(kind=im) :: iceflag             ! flag for ice cloud properties
+      integer(kind=im) :: liqflag             ! flag for liquid cloud properties
+
+!      real(kind=rb) :: cldfrac(nlay+1)        ! layer cloud fraction
+!      real(kind=rb) :: tauc(nlay+1)           ! in-cloud optical depth (non-delta scaled)
+!      real(kind=rb) :: ssac(nlay+1)           ! in-cloud single scattering albedo (non-delta scaled)
+!      real(kind=rb) :: asmc(nlay+1)           ! in-cloud asymmetry parameter (non-delta scaled)
+!      real(kind=rb) :: fsfc(nlay+1)           ! in-cloud forward scattering fraction (non-delta scaled)
+!      real(kind=rb) :: ciwp(nlay+1)           ! in-cloud ice water path
+!      real(kind=rb) :: clwp(nlay+1)           ! in-cloud liquid water path
+!      real(kind=rb) :: rei(nlay+1)            ! cloud ice particle size
+!      real(kind=rb) :: rel(nlay+1)            ! cloud liquid particle size
+
+!      real(kind=rb) :: taucloud(nlay+1,jpband)  ! in-cloud optical depth
+!      real(kind=rb) :: taucldorig(nlay+1,jpband)! in-cloud optical depth (non-delta scaled)
+!      real(kind=rb) :: ssacloud(nlay+1,jpband)  ! in-cloud single scattering albedo
+!      real(kind=rb) :: asmcloud(nlay+1,jpband)  ! in-cloud asymmetry parameter
+
+! Atmosphere/clouds - cldprmc [mcica]
+      real(kind=rb) :: cldfmc(ngptsw,nlay+1)    ! cloud fraction [mcica]
+      real(kind=rb) :: ciwpmc(ngptsw,nlay+1)    ! in-cloud ice water path [mcica]
+      real(kind=rb) :: clwpmc(ngptsw,nlay+1)    ! in-cloud liquid water path [mcica]
+      real(kind=rb) :: relqmc(nlay+1)           ! liquid particle effective radius (microns)
+      real(kind=rb) :: reicmc(nlay+1)           ! ice particle effective size (microns)
+      real(kind=rb) :: taucmc(ngptsw,nlay+1)    ! in-cloud optical depth [mcica]
+      real(kind=rb) :: taormc(ngptsw,nlay+1)    ! unscaled in-cloud optical depth [mcica]
+      real(kind=rb) :: ssacmc(ngptsw,nlay+1)    ! in-cloud single scattering albedo [mcica]
+      real(kind=rb) :: asmcmc(ngptsw,nlay+1)    ! in-cloud asymmetry parameter [mcica]
+      real(kind=rb) :: fsfcmc(ngptsw,nlay+1)    ! in-cloud forward scattering fraction [mcica]
+
+! Atmosphere/clouds/aerosol - spcvrt,spcvmc
+      real(kind=rb) :: ztauc(nlay+1,nbndsw)     ! cloud optical depth
+      real(kind=rb) :: ztaucorig(nlay+1,nbndsw) ! unscaled cloud optical depth
+      real(kind=rb) :: zasyc(nlay+1,nbndsw)     ! cloud asymmetry parameter 
+                                                !  (first moment of phase function)
+      real(kind=rb) :: zomgc(nlay+1,nbndsw)     ! cloud single scattering albedo
+      real(kind=rb) :: ztaua(nlay+1,nbndsw)     ! total aerosol optical depth
+      real(kind=rb) :: zasya(nlay+1,nbndsw)     ! total aerosol asymmetry parameter 
+      real(kind=rb) :: zomga(nlay+1,nbndsw)     ! total aerosol single scattering albedo
+
+      real(kind=rb) :: zcldfmc(nlay+1,ngptsw)   ! cloud fraction [mcica]
+      real(kind=rb) :: ztaucmc(nlay+1,ngptsw)   ! cloud optical depth [mcica]
+      real(kind=rb) :: ztaormc(nlay+1,ngptsw)   ! unscaled cloud optical depth [mcica]
+      real(kind=rb) :: zasycmc(nlay+1,ngptsw)   ! cloud asymmetry parameter [mcica] 
+      real(kind=rb) :: zomgcmc(nlay+1,ngptsw)   ! cloud single scattering albedo [mcica]
+
+      real(kind=rb) :: zbbfu(nlay+2)          ! temporary upward shortwave flux (w/m2)
+      real(kind=rb) :: zbbfd(nlay+2)          ! temporary downward shortwave flux (w/m2)
+      real(kind=rb) :: zbbcu(nlay+2)          ! temporary clear sky upward shortwave flux (w/m2)
+      real(kind=rb) :: zbbcd(nlay+2)          ! temporary clear sky downward shortwave flux (w/m2)
+      real(kind=rb) :: zbbfddir(nlay+2)       ! temporary downward direct shortwave flux (w/m2)
+      real(kind=rb) :: zbbcddir(nlay+2)       ! temporary clear sky downward direct shortwave flux (w/m2)
+      real(kind=rb) :: zuvfd(nlay+2)          ! temporary UV downward shortwave flux (w/m2)
+      real(kind=rb) :: zuvcd(nlay+2)          ! temporary clear sky UV downward shortwave flux (w/m2)
+      real(kind=rb) :: zuvfddir(nlay+2)       ! temporary UV downward direct shortwave flux (w/m2)
+      real(kind=rb) :: zuvcddir(nlay+2)       ! temporary clear sky UV downward direct shortwave flux (w/m2)
+      real(kind=rb) :: znifd(nlay+2)          ! temporary near-IR downward shortwave flux (w/m2)
+      real(kind=rb) :: znicd(nlay+2)          ! temporary clear sky near-IR downward shortwave flux (w/m2)
+      real(kind=rb) :: znifddir(nlay+2)       ! temporary near-IR downward direct shortwave flux (w/m2)
+      real(kind=rb) :: znicddir(nlay+2)       ! temporary clear sky near-IR downward direct shortwave flux (w/m2)
+
+! Optional output fields 
+      real(kind=rb) :: swnflx(nlay+2)         ! Total sky shortwave net flux (W/m2)
+      real(kind=rb) :: swnflxc(nlay+2)        ! Clear sky shortwave net flux (W/m2)
+      real(kind=rb) :: dirdflux(nlay+2)       ! Direct downward shortwave surface flux
+      real(kind=rb) :: difdflux(nlay+2)       ! Diffuse downward shortwave surface flux
+      real(kind=rb) :: uvdflx(nlay+2)         ! Total sky downward shortwave flux, UV/vis  
+      real(kind=rb) :: nidflx(nlay+2)         ! Total sky downward shortwave flux, near-IR 
+      real(kind=rb) :: dirdnuv(nlay+2)        ! Direct downward shortwave flux, UV/vis
+      real(kind=rb) :: difdnuv(nlay+2)        ! Diffuse downward shortwave flux, UV/vis
+      real(kind=rb) :: dirdnir(nlay+2)        ! Direct downward shortwave flux, near-IR
+      real(kind=rb) :: difdnir(nlay+2)        ! Diffuse downward shortwave flux, near-IR
+
+! Output - inactive
+!      real(kind=rb) :: zuvfu(nlay+2)         ! temporary upward UV shortwave flux (w/m2)
+!      real(kind=rb) :: zuvfd(nlay+2)         ! temporary downward UV shortwave flux (w/m2)
+!      real(kind=rb) :: zuvcu(nlay+2)         ! temporary clear sky upward UV shortwave flux (w/m2)
+!      real(kind=rb) :: zuvcd(nlay+2)         ! temporary clear sky downward UV shortwave flux (w/m2)
+!      real(kind=rb) :: zvsfu(nlay+2)         ! temporary upward visible shortwave flux (w/m2)
+!      real(kind=rb) :: zvsfd(nlay+2)         ! temporary downward visible shortwave flux (w/m2)
+!      real(kind=rb) :: zvscu(nlay+2)         ! temporary clear sky upward visible shortwave flux (w/m2)
+!      real(kind=rb) :: zvscd(nlay+2)         ! temporary clear sky downward visible shortwave flux (w/m2)
+!      real(kind=rb) :: znifu(nlay+2)         ! temporary upward near-IR shortwave flux (w/m2)
+!      real(kind=rb) :: znifd(nlay+2)         ! temporary downward near-IR shortwave flux (w/m2)
+!      real(kind=rb) :: znicu(nlay+2)         ! temporary clear sky upward near-IR shortwave flux (w/m2)
+!      real(kind=rb) :: znicd(nlay+2)         ! temporary clear sky downward near-IR shortwave flux (w/m2)
+
+
+! Initializations
+
+      zepsec = 1.e-06_rb
+      zepzen = 1.e-10_rb
+      oneminus = 1.0_rb - zepsec
+      pi = 2._rb * asin(1._rb)
+
+      istart = jpb1
+      iend = jpb2
+      icpr = 0
+      ims = 2
+
+! In a GCM with or without McICA, set nlon to the longitude dimension
+!
+! Set imca to select calculation type:
+!  imca = 0, use standard forward model calculation (clear and overcast only)
+!  imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability
+!            (clear, overcast or partial cloud conditions)
+
+! *** This version uses McICA (imca = 1) ***
+
+! Set icld to select of clear or cloud calculation and cloud 
+! overlap method (read by subroutine readprof from input file INPUT_RRTM):  
+! icld = 0, clear only
+! icld = 1, with clouds using random cloud overlap (McICA only)
+! icld = 2, with clouds using maximum/random cloud overlap (McICA only)
+! icld = 3, with clouds using maximum cloud overlap (McICA only)
+      if (icld.lt.0.or.icld.gt.3) icld = 2
+
+! Set iaer to select aerosol option
+! iaer = 0, no aerosols
+! iaer = 6, use six ECMWF aerosol types
+!           input aerosol optical depth at 0.55 microns for each aerosol type (ecaer)
+! iaer = 10, input total aerosol optical depth, single scattering albedo 
+!            and asymmetry parameter (tauaer, ssaaer, asmaer) directly
+      iaer = 10
+
+! Call model and data initialization, compute lookup tables, perform
+! reduction of g-points from 224 to 112 for input absorption
+! coefficient data and other arrays.
+!
+! In a GCM this call should be placed in the model initialization
+! area, since this has to be called only once.  
+!      call rrtmg_sw_ini(cpdair)
+
+! This is the main longitude/column loop in RRTMG.
+! Modify to loop over all columns (nlon) or over daylight columns
+
+      do iplon = 1, ncol
+
+! Prepare atmosphere profile from GCM for use in RRTMG, and define
+! other input parameters
+
+         call inatm_sw (iplon, nlay, icld, iaer, &
+              play, plev, tlay, tlev, tsfc, h2ovmr, &
+              o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, &
+              adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw, &
+              cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, &
+              reicmcl, relqmcl, tauaer, ssaaer, asmaer, &
+              nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, &
+              adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc, &
+              ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, reicmc, relqmc, &
+              taua, ssaa, asma)
+
+!  For cloudy atmosphere, use cldprop to set cloud optical properties based on
+!  input cloud physical properties.  Select method based on choices described
+!  in cldprop.  Cloud fraction, water path, liquid droplet and ice particle
+!  effective radius must be passed in cldprop.  Cloud fraction and cloud
+!  optical properties are transferred to rrtmg_sw arrays in cldprop.  
+
+         call cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
+                         ciwpmc, clwpmc, reicmc, relqmc, &
+                         taormc, taucmc, ssacmc, asmcmc, fsfcmc)
+         icpr = 1
+
+! Calculate coefficients for the temperature and pressure dependence of the 
+! molecular absorption coefficients by interpolating data from stored
+! reference atmospheres.
+
+         call setcoef_sw(nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl, &
+                         laytrop, layswtch, laylow, jp, jt, jt1, &
+                         co2mult, colch4, colco2, colh2o, colmol, coln2o, &
+                         colo2, colo3, fac00, fac01, fac10, fac11, &
+                         selffac, selffrac, indself, forfac, forfrac, indfor)
+
+
+! Cosine of the solar zenith angle 
+!  Prevent using value of zero; ideally, SW model is not called from host model when sun 
+!  is below horizon
+
+         cossza = coszen(iplon)
+         if (cossza .le. zepzen) cossza = zepzen
+
+! Transfer albedo, cloud and aerosol properties into arrays for 2-stream radiative transfer 
+
+! Surface albedo
+!  Near-IR bands 16-24 and 29 (1-9 and 14), 820-16000 cm-1, 0.625-12.195 microns
+         do ib=1,9
+            albdir(ib) = aldir(iplon)
+            albdif(ib) = aldif(iplon)
+         enddo
+         albdir(nbndsw) = aldir(iplon)
+         albdif(nbndsw) = aldif(iplon)
+!  UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron
+         do ib=10,13
+            albdir(ib) = asdir(iplon)
+            albdif(ib) = asdif(iplon)
+         enddo
+
+
+! Clouds
+         if (icld.eq.0) then
+
+            zcldfmc(:,:) = 0._rb
+            ztaucmc(:,:) = 0._rb
+            ztaormc(:,:) = 0._rb
+            zasycmc(:,:) = 0._rb
+            zomgcmc(:,:) = 1._rb
+
+         elseif (icld.ge.1) then
+            do i=1,nlayers
+               do ig=1,ngptsw
+                  zcldfmc(i,ig) = cldfmc(ig,i)
+                  ztaucmc(i,ig) = taucmc(ig,i)
+                  ztaormc(i,ig) = taormc(ig,i)
+                  zasycmc(i,ig) = asmcmc(ig,i)
+                  zomgcmc(i,ig) = ssacmc(ig,i)
+               enddo
+            enddo
+
+         endif   
+
+! Aerosol
+! IAER = 0: no aerosols
+         if (iaer.eq.0) then
+
+            ztaua(:,:) = 0._rb
+            zasya(:,:) = 0._rb
+            zomga(:,:) = 1._rb
+
+! IAER = 6: Use ECMWF six aerosol types. See rrsw_aer.f90 for details.
+! Input aerosol optical thickness at 0.55 micron for each aerosol type (ecaer), 
+! or set manually here for each aerosol and layer.
+         elseif (iaer.eq.6) then
+
+!            do i = 1, nlayers
+!               do ia = 1, naerec
+!                  ecaer(iplon,i,ia) = 1.0e-15_rb
+!               enddo
+!            enddo
+
+            do i = 1, nlayers
+               do ib = 1, nbndsw
+                  ztaua(i,ib) = 0._rb
+                  zasya(i,ib) = 0._rb
+                  zomga(i,ib) = 1._rb
+                  do ia = 1, naerec
+                     ztaua(i,ib) = ztaua(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia)
+                     zomga(i,ib) = zomga(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia) * &
+                                   rsrpiza(ib,ia)
+                     zasya(i,ib) = zasya(i,ib) + rsrtaua(ib,ia) * ecaer(iplon,i,ia) * &
+                                   rsrpiza(ib,ia) * rsrasya(ib,ia)
+                  enddo
+                  if (zomga(i,ib) /= 0._rb) then
+                     zasya(i,ib) = zasya(i,ib) / zomga(i,ib)
+                  endif
+                  if (ztaua(i,ib) /= 0._rb) then
+                     zomga(i,ib) = zomga(i,ib) / ztaua(i,ib)
+                  endif
+               enddo
+            enddo
+
+! IAER=10: Direct specification of aerosol optical properties from GCM
+         elseif (iaer.eq.10) then
+
+            do i = 1 ,nlayers
+               do ib = 1 ,nbndsw
+                  ztaua(i,ib) = taua(i,ib)
+                  zasya(i,ib) = asma(i,ib)
+                  zomga(i,ib) = ssaa(i,ib)
+               enddo
+            enddo
+
+         endif
+
+
+! Call the 2-stream radiation transfer model
+
+         do i=1,nlayers+1
+            zbbcu(i) = 0._rb
+            zbbcd(i) = 0._rb
+            zbbfu(i) = 0._rb
+            zbbfd(i) = 0._rb
+            zbbcddir(i) = 0._rb
+            zbbfddir(i) = 0._rb
+            zuvcd(i) = 0._rb
+            zuvfd(i) = 0._rb
+            zuvcddir(i) = 0._rb
+            zuvfddir(i) = 0._rb
+            znicd(i) = 0._rb
+            znifd(i) = 0._rb
+            znicddir(i) = 0._rb
+            znifddir(i) = 0._rb
+         enddo
+
+         call spcvmc_sw &
+             (nlayers, istart, iend, icpr, iout, &
+              pavel, tavel, pz, tz, tbound, albdif, albdir, &
+              zcldfmc, ztaucmc, zasycmc, zomgcmc, ztaormc, &
+              ztaua, zasya, zomga, cossza, coldry, wkl, adjflux, &	 
+              laytrop, layswtch, laylow, jp, jt, jt1, &
+              co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, &
+              fac00, fac01, fac10, fac11, &
+              selffac, selffrac, indself, forfac, forfrac, indfor, &
+              zbbfd, zbbfu, zbbcd, zbbcu, zuvfd, zuvcd, znifd, znicd, &
+              zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir)
+
+! Transfer up and down, clear and total sky fluxes to output arrays.
+! Vertical indexing goes from bottom to top; reverse here for GCM if necessary.
+
+         do i = 1, nlayers+1
+            swuflxc(iplon,i) = zbbcu(i)
+            swdflxc(iplon,i) = zbbcd(i)
+            swuflx(iplon,i) = zbbfu(i)
+            swdflx(iplon,i) = zbbfd(i)
+            uvdflx(i) = zuvfd(i)
+            nidflx(i) = znifd(i)
+!  Direct/diffuse fluxes
+            dirdflux(i) = zbbfddir(i)
+            difdflux(i) = swdflx(iplon,i) - dirdflux(i)
+!  UV/visible direct/diffuse fluxes
+            dirdnuv(i) = zuvfddir(i)
+            difdnuv(i) = zuvfd(i) - dirdnuv(i)
+!  Near-IR direct/diffuse fluxes
+            dirdnir(i) = znifddir(i)
+            difdnir(i) = znifd(i) - dirdnir(i)
+         enddo
+
+!  Total and clear sky net fluxes
+         do i = 1, nlayers+1
+            swnflxc(i) = swdflxc(iplon,i) - swuflxc(iplon,i)
+            swnflx(i) = swdflx(iplon,i) - swuflx(iplon,i)
+         enddo
+
+!  Total and clear sky heating rates
+         do i = 1, nlayers
+            zdpgcp = heatfac / pdp(i)
+            swhrc(iplon,i) = (swnflxc(i+1) - swnflxc(i)) * zdpgcp
+            swhr(iplon,i) = (swnflx(i+1) - swnflx(i)) * zdpgcp
+         enddo
+         swhrc(iplon,nlayers) = 0._rb
+         swhr(iplon,nlayers) = 0._rb
+
+! End longitude loop
+      enddo
+
+      end subroutine rrtmg_sw
+
+!*************************************************************************
+      real(kind=rb) function earth_sun(idn)
+!*************************************************************************
+!
+!  Purpose: Function to calculate the correction factor of Earth's orbit
+!  for current day of the year
+
+!  idn        : Day of the year
+!  earth_sun  : square of the ratio of mean to actual Earth-Sun distance
+
+! ------- Modules -------
+
+      use rrsw_con, only : pi
+
+      integer(kind=im), intent(in) :: idn
+
+      real(kind=rb) :: gamma
+
+      gamma = 2._rb*pi*(idn-1)/365._rb
+
+! Use Iqbal's equation 1.2.1
+
+      earth_sun = 1.000110_rb + .034221_rb * cos(gamma) + .001289_rb * sin(gamma) + &
+                   .000719_rb * cos(2._rb*gamma) + .000077_rb * sin(2._rb*gamma)
+
+      end function earth_sun
+
+!***************************************************************************
+      subroutine inatm_sw (iplon, nlay, icld, iaer, &
+            play, plev, tlay, tlev, tsfc, h2ovmr, &
+            o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, &
+            adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw, &
+            cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, &
+            reicmcl, relqmcl, tauaer, ssaaer, asmaer, &
+            nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, &
+            adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc, &
+            ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, reicmc, relqmc, &
+            taua, ssaa, asma)
+!***************************************************************************
+!
+!  Input atmospheric profile from GCM, and prepare it for use in RRTMG_SW.
+!  Set other RRTMG_SW input parameters.  
+!
+!***************************************************************************
+
+! --------- Modules ----------
+
+      use parrrsw, only : nbndsw, ngptsw, nstr, nmol, mxmol, &
+                          jpband, jpb1, jpb2, rrsw_scon
+      use rrsw_con, only : heatfac, oneminus, pi, grav, avogad
+      use rrsw_wvn, only : ng, nspa, nspb, wavenum1, wavenum2, delwave
+
+! ------- Declarations -------
+
+! ----- Input -----
+      integer(kind=im), intent(in) :: iplon           ! column loop index
+      integer(kind=im), intent(in) :: nlay            ! number of model layers
+      integer(kind=im), intent(in) :: icld            ! clear/cloud and cloud overlap flag
+      integer(kind=im), intent(in) :: iaer            ! aerosol option flag
+
+      real(kind=rb), intent(in) :: play(:,:)          ! Layer pressures (hPa, mb)
+                                                      ! Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: plev(:,:)          ! Interface pressures (hPa, mb)
+                                                      ! Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(in) :: tlay(:,:)          ! Layer temperatures (K)
+                                                      ! Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: tlev(:,:)          ! Interface temperatures (K)
+                                                      ! Dimensions: (ncol,nlay+1)
+      real(kind=rb), intent(in) :: tsfc(:)            ! Surface temperature (K)
+                                                      ! Dimensions: (ncol)
+      real(kind=rb), intent(in) :: h2ovmr(:,:)        ! H2O volume mixing ratio
+                                                      ! Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: o3vmr(:,:)         ! O3 volume mixing ratio
+                                                      ! Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: co2vmr(:,:)        ! CO2 volume mixing ratio
+                                                      ! Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: ch4vmr(:,:)        ! Methane volume mixing ratio
+                                                      ! Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: n2ovmr(:,:)        ! Nitrous oxide volume mixing ratio
+                                                      ! Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: o2vmr(:,:)         ! Oxygen volume mixing ratio
+                                                      ! Dimensions: (ncol,nlay)
+
+      integer(kind=im), intent(in) :: dyofyr          ! Day of the year (used to get Earth/Sun
+                                                      !  distance if adjflx not provided)
+      real(kind=rb), intent(in) :: adjes              ! Flux adjustment for Earth/Sun distance
+      real(kind=rb), intent(in) :: scon               ! Solar constant (W/m2)
+
+      integer(kind=im), intent(in) :: inflgsw         ! Flag for cloud optical properties
+      integer(kind=im), intent(in) :: iceflgsw        ! Flag for ice particle specification
+      integer(kind=im), intent(in) :: liqflgsw        ! Flag for liquid droplet specification
+
+      real(kind=rb), intent(in) :: cldfmcl(:,:,:)     ! Cloud fraction
+                                                      ! Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: taucmcl(:,:,:)     ! In-cloud optical depth (optional)
+                                                      ! Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: ssacmcl(:,:,:)     ! In-cloud single scattering albedo
+                                                      ! Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: asmcmcl(:,:,:)     ! In-cloud asymmetry parameter
+                                                      ! Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: fsfcmcl(:,:,:)     ! In-cloud forward scattering fraction
+                                                      ! Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: ciwpmcl(:,:,:)     ! In-cloud ice water path (g/m2)
+                                                      ! Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: clwpmcl(:,:,:)     ! In-cloud liquid water path (g/m2)
+                                                      ! Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: reicmcl(:,:)       ! Cloud ice effective size (microns)
+                                                      ! Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: relqmcl(:,:)       ! Cloud water drop effective radius (microns)
+                                                      ! Dimensions: (ncol,nlay)
+
+      real(kind=rb), intent(in) :: tauaer(:,:,:)      ! Aerosol optical depth
+                                                      ! Dimensions: (ncol,nlay,nbndsw)
+      real(kind=rb), intent(in) :: ssaaer(:,:,:)      ! Aerosol single scattering albedo
+                                                      ! Dimensions: (ncol,nlay,nbndsw)
+      real(kind=rb), intent(in) :: asmaer(:,:,:)      ! Aerosol asymmetry parameter
+                                                      ! Dimensions: (ncol,nlay,nbndsw)
+
+! Atmosphere
+      integer(kind=im), intent(out) :: nlayers        ! number of layers
+
+      real(kind=rb), intent(out) :: pavel(:)          ! layer pressures (mb) 
+                                                      ! Dimensions: (nlay)
+      real(kind=rb), intent(out) :: tavel(:)          ! layer temperatures (K)
+                                                      ! Dimensions: (nlay)
+      real(kind=rb), intent(out) :: pz(0:)            ! level (interface) pressures (hPa, mb)
+                                                      ! Dimensions: (0:nlay)
+      real(kind=rb), intent(out) :: tz(0:)            ! level (interface) temperatures (K)
+                                                      ! Dimensions: (0:nlay)
+      real(kind=rb), intent(out) :: tbound            ! surface temperature (K)
+      real(kind=rb), intent(out) :: pdp(:)            ! layer pressure thickness (hPa, mb)
+                                                      ! Dimensions: (nlay)
+      real(kind=rb), intent(out) :: coldry(:)         ! dry air column density (mol/cm2)
+                                                      ! Dimensions: (nlay)
+      real(kind=rb), intent(out) :: wkl(:,:)          ! molecular amounts (mol/cm-2)
+                                                      ! Dimensions: (mxmol,nlay)
+
+      real(kind=rb), intent(out) :: adjflux(:)        ! adjustment for current Earth/Sun distance
+                                                      ! Dimensions: (jpband)
+      real(kind=rb), intent(out) :: solvar(:)         ! solar constant scaling factor from rrtmg_sw
+                                                      ! Dimensions: (jpband)
+                                                      !  default value of 1368.22 Wm-2 at 1 AU
+      real(kind=rb), intent(out) :: taua(:,:)         ! Aerosol optical depth
+                                                      ! Dimensions: (nlay,nbndsw)
+      real(kind=rb), intent(out) :: ssaa(:,:)         ! Aerosol single scattering albedo
+                                                      ! Dimensions: (nlay,nbndsw)
+      real(kind=rb), intent(out) :: asma(:,:)         ! Aerosol asymmetry parameter
+                                                      ! Dimensions: (nlay,nbndsw)
+
+! Atmosphere/clouds - cldprop
+      integer(kind=im), intent(out) :: inflag         ! flag for cloud property method
+      integer(kind=im), intent(out) :: iceflag        ! flag for ice cloud properties
+      integer(kind=im), intent(out) :: liqflag        ! flag for liquid cloud properties
+
+      real(kind=rb), intent(out) :: cldfmc(:,:)       ! layer cloud fraction
+                                                      ! Dimensions: (ngptsw,nlay)
+      real(kind=rb), intent(out) :: taucmc(:,:)       ! in-cloud optical depth (non-delta scaled)
+                                                      ! Dimensions: (ngptsw,nlay)
+      real(kind=rb), intent(out) :: ssacmc(:,:)       ! in-cloud single scattering albedo (non-delta-scaled)
+                                                      ! Dimensions: (ngptsw,nlay)
+      real(kind=rb), intent(out) :: asmcmc(:,:)       ! in-cloud asymmetry parameter (non-delta scaled)
+                                                      ! Dimensions: (ngptsw,nlay)
+      real(kind=rb), intent(out) :: fsfcmc(:,:)       ! in-cloud forward scattering fraction (non-delta scaled)
+                                                      ! Dimensions: (ngptsw,nlay)
+      real(kind=rb), intent(out) :: ciwpmc(:,:)       ! in-cloud ice water path
+                                                      ! Dimensions: (ngptsw,nlay)
+      real(kind=rb), intent(out) :: clwpmc(:,:)       ! in-cloud liquid water path
+                                                      ! Dimensions: (ngptsw,nlay)
+      real(kind=rb), intent(out) :: relqmc(:)         ! liquid particle effective radius (microns)
+                                                      ! Dimensions: (nlay)
+      real(kind=rb), intent(out) :: reicmc(:)         ! ice particle effective size (microns)
+                                                      ! Dimensions: (nlay)
+
+! ----- Local -----
+      real(kind=rb), parameter :: amd = 28.9660_rb    ! Effective molecular weight of dry air (g/mol)
+      real(kind=rb), parameter :: amw = 18.0160_rb    ! Molecular weight of water vapor (g/mol)
+!      real(kind=rb), parameter :: amc = 44.0098_rb   ! Molecular weight of carbon dioxide (g/mol)
+!      real(kind=rb), parameter :: amo = 47.9998_rb   ! Molecular weight of ozone (g/mol)
+!      real(kind=rb), parameter :: amo2 = 31.9999_rb  ! Molecular weight of oxygen (g/mol)
+!      real(kind=rb), parameter :: amch4 = 16.0430_rb ! Molecular weight of methane (g/mol)
+!      real(kind=rb), parameter :: amn2o = 44.0128_rb ! Molecular weight of nitrous oxide (g/mol)
+
+! Set molecular weight ratios (for converting mmr to vmr)
+!  e.g. h2ovmr = h2ommr * amdw)
+      real(kind=rb), parameter :: amdw = 1.607793_rb  ! Molecular weight of dry air / water vapor
+      real(kind=rb), parameter :: amdc = 0.658114_rb  ! Molecular weight of dry air / carbon dioxide
+      real(kind=rb), parameter :: amdo = 0.603428_rb  ! Molecular weight of dry air / ozone
+      real(kind=rb), parameter :: amdm = 1.805423_rb  ! Molecular weight of dry air / methane
+      real(kind=rb), parameter :: amdn = 0.658090_rb  ! Molecular weight of dry air / nitrous oxide
+      real(kind=rb), parameter :: amdo2 = 0.905140_rb ! Molecular weight of dry air / oxygen
+
+      real(kind=rb), parameter :: sbc = 5.67e-08_rb   ! Stefan-Boltzmann constant (W/m2K4)
+
+      integer(kind=im) :: isp, l, ix, n, imol, ib, ig   ! Loop indices
+      real(kind=rb) :: amm, summol                      ! 
+      real(kind=rb) :: adjflx                           ! flux adjustment for Earth/Sun distance
+!      real(kind=rb) :: earth_sun                        ! function for Earth/Sun distance adjustment
+
+      nlayers = nlay
+
+!  Initialize all molecular amounts to zero here, then pass input amounts
+!  into RRTM array WKL below.
+
+       wkl(:,:) = 0.0_rb
+       cldfmc(:,:) = 0.0_rb
+       taucmc(:,:) = 0.0_rb
+       ssacmc(:,:) = 1.0_rb
+       asmcmc(:,:) = 0.0_rb
+       fsfcmc(:,:) = 0.0_rb
+       ciwpmc(:,:) = 0.0_rb
+       clwpmc(:,:) = 0.0_rb
+       reicmc(:) = 0.0_rb
+       relqmc(:) = 0.0_rb
+       taua(:,:) = 0.0_rb
+       ssaa(:,:) = 1.0_rb
+       asma(:,:) = 0.0_rb
+ 
+! Set flux adjustment for current Earth/Sun distance (two options).
+! 1) Use Earth/Sun distance flux adjustment provided by GCM (input as adjes);
+      adjflx = adjes
+!
+! 2) Calculate Earth/Sun distance from DYOFYR, the cumulative day of the year.
+!    (Set adjflx to 1. to use constant Earth/Sun distance of 1 AU). 
+      if (dyofyr .gt. 0) then
+         adjflx = earth_sun(dyofyr)
+      endif
+
+! Set incoming solar flux adjustment to include adjustment for
+! current Earth/Sun distance (ADJFLX) and scaling of default internal
+! solar constant (rrsw_scon = 1368.22 Wm-2) by band (SOLVAR).  SOLVAR can be set 
+! to a single scaling factor as needed, or to a different value in each 
+! band, which may be necessary for paleoclimate simulations. 
+! 
+      do ib = jpb1,jpb2
+!         solvar(ib) = 1._rb
+         solvar(ib) = scon / rrsw_scon 
+         adjflux(ib) = adjflx * solvar(ib)
+      enddo
+
+!  Set surface temperature.
+      tbound = tsfc(iplon)
+
+!  Install input GCM arrays into RRTMG_SW arrays for pressure, temperature,
+!  and molecular amounts.  
+!  Pressures are input in mb, or are converted to mb here.
+!  Molecular amounts are input in volume mixing ratio, or are converted from 
+!  mass mixing ratio (or specific humidity for h2o) to volume mixing ratio
+!  here. These are then converted to molecular amount (molec/cm2) below.  
+!  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.  
+!  Note: In RRTMG, layer indexing goes from bottom to top, and coding below
+!  assumes GCM input fields are also bottom to top. Input layer indexing
+!  from GCM fields should be reversed here if necessary.
+
+      pz(0) = plev(iplon,1)
+      tz(0) = tlev(iplon,1)
+      do l = 1, nlayers
+         pavel(l) = play(iplon,l)
+         tavel(l) = tlay(iplon,l)
+         pz(l) = plev(iplon,l+1)
+         tz(l) = tlev(iplon,l+1)
+         pdp(l) = pz(l-1) - pz(l)
+! For h2o input in vmr:
+         wkl(1,l) = h2ovmr(iplon,l)
+! For h2o input in mmr:
+!         wkl(1,l) = h2o(iplon,l)*amdw
+! For h2o input in specific humidity;
+!         wkl(1,l) = (h2o(iplon,l)/(1._rb - h2o(iplon,l)))*amdw
+         wkl(2,l) = co2vmr(iplon,l)
+         wkl(3,l) = o3vmr(iplon,l)
+         wkl(4,l) = n2ovmr(iplon,l)
+         wkl(6,l) = ch4vmr(iplon,l)
+         wkl(7,l) = o2vmr(iplon,l)
+         amm = (1._rb - wkl(1,l)) * amd + wkl(1,l) * amw            
+         coldry(l) = (pz(l-1)-pz(l)) * 1.e3_rb * avogad / &
+                     (1.e2_rb * grav * amm * (1._rb + wkl(1,l)))
+      enddo
+
+! The following section can be used to set values for an additional layer (from
+! the GCM top level to 1.e-4 mb) for improved calculation of TOA fluxes. 
+! Temperature and molecular amounts in the extra model layer are set to 
+! their values in the top GCM model layer, though these can be modified
+! here if necessary. 
+! If this feature is utilized, increase nlayers by one above, limit the two
+! loops above to (nlayers-1), and set the top most (nlayers) layer values here. 
+
+!      pavel(nlayers) = 0.5_rb * pz(nlayers-1)
+!      tavel(nlayers) = tavel(nlayers-1)
+!      pz(nlayers) = 1.e-4_rb
+!      tz(nlayers-1) = 0.5_rb * (tavel(nlayers)+tavel(nlayers-1))
+!      tz(nlayers) = tz(nlayers-1)
+!      pdp(nlayers) = pz(nlayers-1) - pz(nlayers)
+!      wkl(1,nlayers) = wkl(1,nlayers-1)
+!      wkl(2,nlayers) = wkl(2,nlayers-1)
+!      wkl(3,nlayers) = wkl(3,nlayers-1)
+!      wkl(4,nlayers) = wkl(4,nlayers-1)
+!      wkl(6,nlayers) = wkl(6,nlayers-1)
+!      wkl(7,nlayers) = wkl(7,nlayers-1)
+!      amm = (1._rb - wkl(1,nlayers-1)) * amd + wkl(1,nlayers-1) * amw
+!      coldry(nlayers) = (pz(nlayers-1)) * 1.e3_rb * avogad / &
+!                        (1.e2_rb * grav * amm * (1._rb + wkl(1,nlayers-1)))
+
+! At this point all molecular amounts in wkl are in volume mixing ratio; 
+! convert to molec/cm2 based on coldry for use in rrtm.  
+
+      do l = 1, nlayers
+         do imol = 1, nmol
+            wkl(imol,l) = coldry(l) * wkl(imol,l)
+         enddo
+      enddo
+
+! Transfer aerosol optical properties to RRTM variables;
+! modify to reverse layer indexing here if necessary.
+
+      if (iaer .ge. 1) then 
+         do l = 1, nlayers
+            do ib = 1, nbndsw
+               taua(l,ib) = tauaer(iplon,l,ib)
+               ssaa(l,ib) = ssaaer(iplon,l,ib)
+               asma(l,ib) = asmaer(iplon,l,ib)
+            enddo
+         enddo
+      endif
+
+! Transfer cloud fraction and cloud optical properties to RRTM variables;
+! modify to reverse layer indexing here if necessary.
+
+      if (icld .ge. 1) then 
+         inflag = inflgsw
+         iceflag = iceflgsw
+         liqflag = liqflgsw
+
+! Move incoming GCM cloud arrays to RRTMG cloud arrays.
+! For GCM input, incoming reicmcl is defined based on selected ice parameterization (inflgsw)
+
+         do l = 1, nlayers
+            do ig = 1, ngptsw
+               cldfmc(ig,l) = cldfmcl(ig,iplon,l)
+               taucmc(ig,l) = taucmcl(ig,iplon,l)
+               ssacmc(ig,l) = ssacmcl(ig,iplon,l)
+               asmcmc(ig,l) = asmcmcl(ig,iplon,l)
+               fsfcmc(ig,l) = fsfcmcl(ig,iplon,l)
+               ciwpmc(ig,l) = ciwpmcl(ig,iplon,l)
+               clwpmc(ig,l) = clwpmcl(ig,iplon,l)
+            enddo
+            reicmc(l) = reicmcl(iplon,l)
+            relqmc(l) = relqmcl(iplon,l)
+         enddo
+
+! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer.
+
+!         cldfmc(:,nlayers) = 0.0_rb
+!         taucmc(:,nlayers) = 0.0_rb
+!         ssacmc(:,nlayers) = 1.0_rb
+!         asmcmc(:,nlayers) = 0.0_rb
+!         fsfcmc(:,nlayers) = 0.0_rb
+!         ciwpmc(:,nlayers) = 0.0_rb
+!         clwpmc(:,nlayers) = 0.0_rb
+!         reicmc(nlayers) = 0.0_rb
+!         relqmc(nlayers) = 0.0_rb
+      
+      endif
+
+      end subroutine inatm_sw
+
+      end module rrtmg_sw_rad
+
+!------------------------------------------------------------------
+MODULE module_ra_rrtmg_sw
+
+use module_model_constants, only : cp
+USE module_wrf_error
+!USE module_dm
+
+use parrrsw, only : nbndsw, ngptsw, naerec
+use rrtmg_sw_init, only: rrtmg_sw_ini
+use rrtmg_sw_rad, only: rrtmg_sw
+use mcica_subcol_gen_sw, only: mcica_subcol_sw
+
+use module_ra_rrtmg_lw, only : inirad, o3data, relcalc, reicalc
+!                               mcica_random_numbers, randomNumberSequence, &
+!                               new_RandomNumberSequence, getRandomReal
+
+CONTAINS
+
+!------------------------------------------------------------------
+   SUBROUTINE RRTMG_SWRAD(                                        &
+                       rthratensw,                                &
+                       swupt, swuptc, swdnt, swdntc,              &
+                       swupb, swupbc, swdnb, swdnbc,              &
+!                      swupflx, swupflxc, swdnflx, swdnflxc,      &
+                       swcf, gsw,                                 &
+                       xtime, gmt, xlat, xlong,                   &
+                       radt, degrad, declin,                      &
+                       coszr, julday, solcon,                     &
+                       albedo, t3d, t8w, tsk,                     &
+                       p3d, p8w, pi3d, rho3d,                     &
+                       dz8w, cldfra3d, r, g,                      &
+                       icloud, warm_rain,                         &
+                       f_ice_phy, f_rain_phy,                     &
+                       xland, xice, snow,                         &
+                       qv3d, qc3d, qr3d,                          &
+                       qi3d, qs3d, qg3d,                          &
+                       f_qv, f_qc, f_qr, f_qi, f_qs, f_qg,        &
+                       tauaer300,tauaer400,tauaer600,tauaer999,   & ! czhao 
+                       gaer300,gaer400,gaer600,gaer999,           & ! czhao 
+                       waer300,waer400,waer600,waer999,           & ! czhao 
+                       aer_ra_feedback,                           &
+!jdfcz                 progn,prescribe,                           &
+                       progn,                                     &
+                       qndrop3d,f_qndrop,                         & !czhao
+                       ids,ide, jds,jde, kds,kde,                 & 
+                       ims,ime, jms,jme, kms,kme,                 &
+                       its,ite, jts,jte, kts,kte,                 &
+                       swupflx, swupflxc, swdnflx, swdnflxc       &
+                                                                  )
+!------------------------------------------------------------------
+   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, &
+                                                             p3d, &
+                                                             p8w, &
+                                                            pi3d, &
+                                                           rho3d
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
+         INTENT(INOUT)  ::                            RTHRATENSW
+
+   REAL, DIMENSION( ims:ime, jms:jme )                          , &
+         INTENT(INOUT)  ::                                   GSW, &
+                                                            SWCF, &
+                                                           COSZR
+
+   INTEGER, INTENT(IN  )     ::                           JULDAY
+   REAL, INTENT(IN    )      ::                      RADT,DEGRAD, &
+                                         XTIME,DECLIN,SOLCON,GMT
+
+   REAL, DIMENSION( ims:ime, jms:jme )                          , &
+         INTENT(IN   )  ::                                  XLAT, &
+                                                           XLONG, &
+                                                           XLAND, &
+                                                            XICE, &
+                                                            SNOW, &
+                                                             TSK, &
+                                                          ALBEDO
+!
+   REAL, INTENT(IN  )   ::                                   R,G
+!
+! Optional
+!
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
+         OPTIONAL                                               , &
+         INTENT(IN   ) ::                                         &
+                                                        CLDFRA3D, &
+                                                            QV3D, &
+                                                            QC3D, &
+                                                            QR3D, &
+                                                            QI3D, &
+                                                            QS3D, &
+                                                            QG3D, &
+                                                        QNDROP3D
+
+   real pi,third,relconst,lwpmin,rhoh2o
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
+         OPTIONAL                                               , &
+         INTENT(IN   ) ::                                         &
+                                                       F_ICE_PHY, &
+                                                      F_RAIN_PHY
+
+   LOGICAL, OPTIONAL, INTENT(IN)   ::                             &
+                                F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP
+
+! Optional
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL ,       &
+         INTENT(IN    ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao 
+                                 gaer300,gaer400,gaer600,gaer999, & ! czhao 
+                                 waer300,waer400,waer600,waer999    ! czhao 
+
+   INTEGER,    INTENT(IN  ), OPTIONAL   ::       aer_ra_feedback
+!jdfcz   INTEGER,    INTENT(IN  ), OPTIONAL   ::       progn,prescribe
+   INTEGER,    INTENT(IN  ), OPTIONAL   ::       progn
+
+      !wavelength corresponding to wavenum1 and wavenum2 (cm-1)
+      real, save :: wavemin(nbndsw) ! Min wavelength (um) of 14 intervals
+      data wavemin /3.077,2.500,2.150,1.942,1.626,1.299, &
+      1.242,0.778,0.625,0.442,0.345,0.263,0.200,3.846/
+      real, save :: wavemax(nbndsw) ! Max wavelength (um) of interval
+      data wavemax/3.846,3.077,2.500,2.150,1.942,1.626, &
+      1.299,1.242,0.778,0.625,0.442,0.345,0.263,12.195/
+      real wavemid(nbndsw) ! Mid wavelength (um) of interval
+      real, parameter :: thresh=1.e-9
+      real ang,slope
+      character(len=200) :: msg
+
+! Top of atmosphere and surface shortwave fluxes (W m-2)
+   REAL, DIMENSION( ims:ime, jms:jme ),                           &
+         OPTIONAL, INTENT(INOUT) ::                               &
+                                       SWUPT,SWUPTC,SWDNT,SWDNTC, &
+                                       SWUPB,SWUPBC,SWDNB,SWDNBC
+
+! Layer shortwave fluxes (including extra layer above model top)
+! Vertical ordering is from bottom to top (W m-2)
+   REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ),                &
+         OPTIONAL, INTENT(OUT) ::                                 &
+                               SWUPFLX,SWUPFLXC,SWDNFLX,SWDNFLXC
+
+!  LOCAL VARS
+ 
+   REAL, DIMENSION( kts:kte+1 ) ::                          Pw1D, &
+                                                            Tw1D
+
+   REAL, DIMENSION( kts:kte ) ::                          TTEN1D, &
+                                                        CLDFRA1D, &
+                                                            DZ1D, &
+                                                             P1D, &
+                                                             T1D, &
+                                                            QV1D, &
+                                                            QC1D, &
+                                                            QR1D, &
+                                                            QI1D, &
+                                                            QS1D, &
+                                                            QG1D, &
+                                                          qndrop1d 
+
+! Added local arrays for RRTMG
+    integer ::                                              ncol, &
+                                                            nlay, &
+                                                            icld, &
+                                                         inflgsw, &
+                                                        iceflgsw, &
+                                                        liqflgsw
+! Dimension with extra layer from model top to TOA
+    real, dimension( 1, kts:kte+2 )  ::                     plev, &
+                                                            tlev
+    real, dimension( 1, kts:kte+1 )  ::                     play, &
+                                                            tlay, &
+                                                          h2ovmr, &
+                                                           o3vmr, &
+                                                          co2vmr, &
+                                                           o2vmr, &
+                                                          ch4vmr, &
+                                                          n2ovmr
+    real, dimension( kts:kte+1 )  ::                       o3mmr
+! Surface albedo (for UV/visible and near-IR spectral regions,
+! and for direct and diffuse radiation)
+    real, dimension( 1 )  ::                               asdir, &
+                                                           asdif, &
+                                                           aldir, &
+                                                           aldif
+! Dimension with extra layer from model top to TOA, 
+! though no clouds are allowed in extra layer
+    real, dimension( 1, kts:kte+1 )  ::                   clwpth, &
+                                                          ciwpth, &
+                                                             rel, &
+                                                             rei, &
+                                                         cldfrac, &
+                                                         relqmcl, &
+                                                         reicmcl
+    real, dimension( nbndsw, 1, kts:kte+1 )  ::           taucld, &
+                                                          ssacld, &
+                                                          asmcld, &
+                                                          fsfcld
+    real, dimension( ngptsw, 1, kts:kte+1 )  ::          cldfmcl, &
+                                                         clwpmcl, &
+                                                         ciwpmcl, &
+                                                         taucmcl, &
+                                                         ssacmcl, &
+                                                         asmcmcl, &
+                                                         fsfcmcl
+    real, dimension( 1, kts:kte+1, nbndsw )  ::           tauaer, &
+                                                          ssaaer, &
+                                                          asmaer   
+    real, dimension( 1, kts:kte+1, naerec )  ::            ecaer
+
+! Output arrays contain extra layer from model top to TOA
+    real, dimension( 1, kts:kte+2 )  ::                   swuflx, &
+                                                          swdflx, &
+                                                         swuflxc, &
+                                                         swdflxc
+    real, dimension( 1, kts:kte+1 )  ::                     swhr, &
+                                                           swhrc
+
+    real, dimension ( 1 ) ::                                tsfc, &
+                                                              ps, &
+                                                          coszen
+    real ::                                                   ro, &
+                                                              dz, &
+                                                           adjes, &
+                                                            scon
+    integer ::                                            dyofyr
+
+! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
+! carbon dioxide (379 ppmv)
+    real :: co2
+    data co2 / 379.e-6 / 
+! methane (1774 ppbv)
+    real :: ch4
+    data ch4 / 1774.e-9 / 
+! nitrous oxide (319 ppbv)
+    real :: n2o
+    data n2o / 319.e-9 / 
+! Set oxygen volume mixing ratio (for o2mmr=0.23143)
+    real :: o2
+    data o2 / 0.209488 /
+
+    integer :: iplon, irng, permuteseed
+    integer :: nb
+
+! For old lw cloud property specification
+! Cloud and precipitation absorption coefficients
+!    real :: abcw,abice,abrn,absn
+!    data abcw /0.144/
+!    data abice /0.0735/
+!    data abrn /0.330e-3/
+!    data absn /2.34e-3/
+
+! Molecular weights and ratios for converting mmr to vmr units
+!    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 :: amo2      ! Molecular weight of oxygen (g/mol)              
+! Atomic weights for conversion from mass to volume mixing ratios                
+!    data amd   /  28.9660   /                                                  
+!    data amw   /  18.0160   /                                                  
+!    data amo   /  47.9998   /                                                  
+!    data amo2  /  31.9999   /
+                                                                                 
+    real :: amdw     ! Molecular weight of dry air / water vapor  
+    real :: amdo     ! Molecular weight of dry air / ozone
+    real :: amdo2    ! Molecular weight of dry air / oxygen
+    data amdw /  1.607793 /                                                    
+    data amdo /  0.603461 /
+    data amdo2 / 0.905190 /
+    
+!!
+    real, dimension(1, 1:kte-kts+1 )  :: pdel          ! Layer pressure thickness (mb)
+
+    real, dimension(1, 1:kte-kts+1) ::   cicewp, &     ! in-cloud cloud ice water path
+                                         cliqwp, &     ! in-cloud cloud liquid water path
+                                          reliq, &     ! effective drop radius (microns)
+                                          reice        ! ice effective drop size (microns)
+    real :: gliqwp, gicewp, gravmks
+
+!
+!    REAL   ::  TSFC,GLW0,OLR0,EMISS0,FP
+    REAL   ::  FP
+
+!    real, dimension(1:ite-its+1 )          ::   clat     ! latitude in radians for columns
+    real :: coszrs                      ! Cosine of solar zenith angle for present latitude 
+    logical :: dorrsw                   ! Flag to allow shortwave calculation
+
+    real, dimension (1) :: landfrac, landm, snowh, icefrac
+
+    integer :: pcols, pver
+
+    REAL :: XT24, TLOCTM, HRANG, XXLAT
+
+    INTEGER :: i,j,K, na
+    LOGICAL :: predicate
+
+!------------------------------------------------------------------
+#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
+
+!-----CALCULATE SHORT WAVE RADIATION
+!                                                              
+! All fields are ordered vertically from bottom to top
+! Pressures are in mb
+
+! latitude loop
+  j_loop: do j = jts,jte
+
+! longitude loop
+     i_loop: do i = its,ite
+!
+! Do shortwave by default, deactivate below if sun below horizon
+         dorrsw = .true.
+
+! Cosine solar zenith angle for current time step
+!
+! 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(i) = xxlat
+         coszrs = sin(xxlat) * sin(declin) + cos(xxlat) * cos(declin) * cos(hrang)
+         coszr(i,j) = coszrs
+
+! Set flag to prevent shortwave calculation when sun below horizon
+         if (coszrs.le.0.0) dorrsw = .false.
+! Perform shortwave calculation if sun above horizon
+         if (dorrsw) then
+
+         do k=kts,kte+1
+            Pw1D(K) = p8w(I,K,J)/100.
+            Tw1D(K) = t8w(I,K,J)
+         enddo
+
+         DO K=kts,kte
+            QV1D(K)=0.
+            QC1D(K)=0.
+            QR1D(K)=0.
+            QI1D(K)=0.
+            QS1D(K)=0.
+            CLDFRA1D(k)=0.
+            QNDROP1D(k)=0.
+         ENDDO
+
+         DO K=kts,kte
+            QV1D(K)=QV3D(I,K,J)
+            QV1D(K)=max(0.,QV1D(K))
+         ENDDO
+
+         DO K=kts,kte
+            TTEN1D(K)=0.
+            T1D(K)=t3d(I,K,J)
+            P1D(K)=p3d(I,K,J)/100.
+            DZ1D(K)=dz8w(I,K,J)
+         ENDDO
+
+! moist variables
+
+         IF (ICLOUD .ne. 0) THEN
+            IF ( PRESENT( CLDFRA3D ) ) THEN
+              DO K=kts,kte
+                 CLDFRA1D(k)=CLDFRA3D(I,K,J)
+              ENDDO
+            ENDIF
+
+            IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
+              IF ( F_QC) THEN
+                 DO K=kts,kte
+                    QC1D(K)=QC3D(I,K,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
+                    QR1D(K)=QR3D(I,K,J)
+                    QR1D(K)=max(0.,QR1D(K))
+                 ENDDO
+              ENDIF
+            ENDIF
+
+            IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN
+             IF (F_QNDROP) THEN
+              DO K=kts,kte
+               qndrop1d(K)=qndrop3d(I,K,J)
+              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
+
+! For MP option 3
+            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
+               IF (F_QI) THEN
+                  DO K=kts,kte
+                     QI1D(K)=QI3D(I,K,J)
+                     QI1D(K)=max(0.,QI1D(K))
+                  ENDDO
+               ENDIF
+            ENDIF
+
+            IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
+               IF (F_QS) THEN
+                  DO K=kts,kte
+                     QS1D(K)=QS3D(I,K,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
+                     QG1D(K)=QG3D(I,K,J)
+                     QG1D(K)=max(0.,QG1D(K))
+                  ENDDO
+               ENDIF
+            ENDIF
+
+! mji - For MP option 5
+            IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
+               IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
+                  DO K=kts,kte
+                     qi1d(k) = qs3d(i,k,j)
+                     qc1d(k) = qc3d(i,k,j)
+                     qi1d(k) = max(0.,qi1d(k))
+                     qc1d(k) = max(0.,qc1d(k))
+                  ENDDO
+               ENDIF
+            ENDIF
+
+         ENDIF
+
+!         EMISS0=EMISS(I,J)
+!         GLW0=0. 
+!         OLR0=0. 
+!         TSFC=TSK(I,J)
+         DO K=kts,kte
+            QV1D(K)=AMAX1(QV1D(K),1.E-12) 
+         ENDDO
+
+! Set up input for shortwave
+         ncol = 1
+! Add extra layer from top of model to top of atmosphere
+         nlay = (kte - kts + 1) + 1
+
+! Select cloud liquid and ice optics parameterization options
+! For passing in cloud optical properties directly:
+!         icld = 2
+!         inflgsw = 0
+!         iceflgsw = 0
+!         liqflgsw = 0
+! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
+         icld = 2
+         inflgsw = 2
+         iceflgsw = 3
+         liqflgsw = 1
+
+! Set cosine of solar zenith angle
+         coszen(ncol) = coszrs
+! Set solar constant
+         scon = solcon
+! For Earth/Sun distance adjustment in RRTMG
+!         dyofyr = julday
+!         adjes = 0.0 
+! For WRF, solar constant is already provided with eccentricity adjustment,
+! so do not do this in RRTMG
+         dyofyr = 0
+         adjes = 1.0 
+
+! Layer indexing goes bottom to top here for all fields.
+! Water vapor and ozone are converted from mmr to vmr. 
+! Pressures are in units of mb here. 
+         plev(ncol,1) = pw1d(1)
+         tlev(ncol,1) = tw1d(1)
+         tsfc(ncol) = tsk(i,j)
+         do k = kts, kte
+            play(ncol,k) = p1d(k)
+            plev(ncol,k+1) = pw1d(k+1)
+            pdel(ncol,k) = plev(ncol,k) - plev(ncol,k+1)
+            tlay(ncol,k) = t1d(k)
+            tlev(ncol,k+1) = tw1d(k+1)
+            h2ovmr(ncol,k) = qv1d(k) * amdw
+            co2vmr(ncol,k) = co2
+            o2vmr(ncol,k) = o2
+            ch4vmr(ncol,k) = ch4
+            n2ovmr(ncol,k) = n2o
+         enddo
+
+!  Define profile values for extra layer from model top to top of 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.  
+
+         play(ncol,kte+1) = 0.5 * plev(ncol,kte+1)
+         tlay(ncol,kte+1) = tlev(ncol,kte+1) + 0.0
+         plev(ncol,kte+2) = 1.0e-5
+         tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
+         tlev(ncol,kte+2) = tlev(ncol,kte+1) + 0.0
+         h2ovmr(ncol,kte+1) = h2ovmr(ncol,kte) 
+         co2vmr(ncol,kte+1) = co2vmr(ncol,kte) 
+         o2vmr(ncol,kte+1) = o2vmr(ncol,kte) 
+         ch4vmr(ncol,kte+1) = ch4vmr(ncol,kte) 
+         n2ovmr(ncol,kte+1) = n2ovmr(ncol,kte) 
+
+! Get ozone profile including amount in extra layer above model top
+         call inirad (o3mmr,plev,kts,kte)
+
+         do k = kts, kte+1
+            o3vmr(ncol,k) = o3mmr(k) * amdo
+         enddo
+
+! Set surface albedo for direct and diffuse radiation in UV/visible and
+! near-IR spectral regions
+         asdir(ncol) = albedo(i,j)
+         asdif(ncol) = albedo(i,j)
+         aldir(ncol) = albedo(i,j)
+         aldif(ncol) = albedo(i,j)
+
+! Define cloud optical properties for radiation (inflgsw = 0)
+! This option is not currently active
+! Cloud and precipitation paths in g/m2 
+! qi=0 if no ice phase
+! qs=0 if no ice phase
+         if (inflgsw .eq. 0) then
+
+! Set cloud fraction and cloud optical properties here; not yet active
+            do k = kts, kte
+               cldfrac(ncol,k) = cldfra1d(k)
+               do nb = 1, nbndsw
+                  taucld(nb,ncol,k) = 0.0
+                  ssacld(nb,ncol,k) = 1.0
+                  asmcld(nb,ncol,k) = 0.0
+                  fsfcld(nb,ncol,k) = 0.0
+               enddo
+            enddo
+
+! Zero out cloud physical property arrays; not used when passing optical properties
+! into radiation
+            do k = kts, kte
+               clwpth(ncol,k) = 0.0
+               ciwpth(ncol,k) = 0.0
+               rel(ncol,k) = 10.0
+               rei(ncol,k) = 10.
+            enddo
+         endif
+
+! Define cloud physical properties for radiation (inflgsw = 1 or 2)
+! Cloud fraction
+! Set cloud arrays if passing cloud physical properties into radiation
+         if (inflgsw .gt. 0) then 
+            do k = kts, kte
+               cldfrac(ncol,k) = cldfra1d(k)
+            enddo
+
+! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method)
+            pcols = ncol
+            pver = kte - kts + 1
+            gravmks = g
+            landfrac(ncol) = 2.-XLAND(I,J)
+            landm(ncol) = landfrac(ncol)
+            snowh(ncol) = 0.001*SNOW(I,J)
+            icefrac(ncol) = XICE(I,J)
+
+! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
+! pdel is in mb here; convert back to Pa (*100.)
+! Water paths are in units of g/m2
+! snow added as ice cloud (JD 091022)
+            do k = kts, kte
+               gicewp = (qi1d(k)+qs1d(k)) * pdel(ncol,k)*100.0 / gravmks * 1000.0     ! Grid box ice water path.
+               gliqwp = qc1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0     ! Grid box liquid water path.
+               cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k))               ! In-cloud ice water path.
+               cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k))               ! In-cloud liquid water path.
+            end do
+
+!link the aerosol feedback to cloud  -czhao
+  if( PRESENT( progn ) ) then
+    if (progn == 1) then
+!jdfcz     if(prescribe==0) then
+
+      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, kte
+         reliq(ncol,k) = 10.
+         if( PRESENT( F_QNDROP ) ) then
+            if( F_QNDROP ) then
+              if ( qc1d(k)*pdel(ncol,k).gt.lwpmin.and. &
+                   qndrop1d(k).gt.1000. ) then
+               reliq(ncol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m
+!           apply scaling from Martin et al., JAS 51, 1830.
+               reliq(ncol,k)=1.1*reliq(ncol,k)
+               reliq(ncol,k)=reliq(ncol,k)*1.e6 ! convert from m to microns
+               reliq(ncol,k)=max(reliq(ncol,k),4.)
+               reliq(ncol,k)=min(reliq(ncol,k),20.)
+              end if
+            end if
+         end if
+      end do
+!jdfcz     else ! prescribe 
+! following Kiehl
+      call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
+!      write(0,*) 'sw prescribe aerosol',maxval(qndrop3d)
+!jdfcz     endif
+    else  ! progn   
+      call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
+    endif
+  else   !progn 
+      call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
+  endif
+
+! following Kristjansson and Mitchell
+      call reicalc(ncol, pcols, pver, tlay, reice)
+
+      if (i==80.and.j==30) then
+#if defined( DM_PARALLEL ) && ! defined( STUBMPI) 
+      if( PRESENT( progn ) ) write(0,*) 'aerosol indirect',progn
+      write(0,*)'sw water eff radius',reliq(ncol,10),reliq(ncol,20),reliq(ncol,25)
+      write(0,*)'sw ice eff radius',reice(ncol,10),reice(ncol,20),reice(ncol,25)
+#endif
+      endif
+
+! Limit upper bound of reice for Fu ice parameterization and convert
+! from effective radius to generalized effective size (*1.0315; Fu, 1996)
+            if (iceflgsw .eq. 3) then
+               do k = kts, kte
+                  reice(ncol,k) = reice(ncol,k) * 1.0315
+                  reice(ncol,k) = min(140.0,reice(ncol,k))
+               end do
+            endif
+
+! Set cloud physical property arrays
+            do k = kts, kte
+               clwpth(ncol,k) = cliqwp(ncol,k)
+               ciwpth(ncol,k) = cicewp(ncol,k)
+               rel(ncol,k) = reliq(ncol,k)
+               rei(ncol,k) = reice(ncol,k)
+            enddo
+
+! Zero out cloud optical properties here, calculated in radiation 
+            do k = kts, kte
+               do nb = 1, nbndsw
+                  taucld(nb,ncol,k) = 0.0
+                  ssacld(nb,ncol,k) = 1.0
+                  asmcld(nb,ncol,k) = 0.0
+                  fsfcld(nb,ncol,k) = 0.0
+               enddo
+            enddo
+         endif
+
+! No clouds are allowed in the extra layer from model top to TOA
+         clwpth(ncol,kte+1) = 0.
+         ciwpth(ncol,kte+1) = 0.
+         rel(ncol,kte+1) = 10.
+         rei(ncol,kte+1) = 10.
+         cldfrac(ncol,kte+1) = 0.
+         do nb = 1, nbndsw
+            taucld(nb,ncol,kte+1) = 0.
+            ssacld(nb,ncol,kte+1) = 1.
+            asmcld(nb,ncol,kte+1) = 0.
+            fsfcld(nb,ncol,kte+1) = 0.
+         enddo
+
+         iplon = 1
+         irng = 0
+         permuteseed = 1
+
+! Sub-column generator for McICA
+
+         call mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
+                       cldfrac, ciwpth, clwpth, rei, rel, taucld, ssacld, asmcld, fsfcld, &
+                       cldfmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, &
+                       taucmcl, ssacmcl, asmcmcl, fsfcmcl)
+
+!--------------------------------------------------------------------------
+! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
+!--------------------------------------------------------------------------
+! by layer for each RRTMG shortwave band
+! No aerosols in top layer above model top (kte+1).
+!cz        do nb = 1, nbndsw
+!cz           do k = kts, kte+1
+!cz              tauaer(ncol,k,nb) = 0.
+!cz              ssaaer(ncol,k,nb) = 1.
+!cz              asmaer(ncol,k,nb) = 0.
+!cz           enddo
+!cz        enddo
+
+! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
+!
+      do nb = 1, nbndsw
+      do k = kts,kte+1
+         tauaer(ncol,k,nb) = 0.
+         ssaaer(ncol,k,nb) = 1.
+         asmaer(ncol,k,nb) = 0.
+      end do
+      end do
+
+#ifdef WRF_CHEM
+   IF ( AER_RA_FEEDBACK == 1) then
+      do nb = 1, nbndsw
+         wavemid(nb)=0.5*(wavemin(nb)+wavemax(nb))  ! um
+      do k = kts,kte      !wig
+
+! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths
+! tauaer - use angstrom exponent
+        if(tauaer300(i,k,j).gt.thresh .and. tauaer999(i,k,j).gt.thresh) then
+           ang=alog(tauaer300(i,k,j)/tauaer999(i,k,j))/alog(999./300.)
+           tauaer(ncol,k,nb)=tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
+           !tauaer(ncol,k,nb)=tauaer600(i,k,j)*(0.6/wavemid(nb))**ang 
+           if (i==30.and.j==49.and.k==2.and.nb==12) then
+            write(0,*) 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
+            print*, 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j)
+            write(0,*) tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
+            print*, tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang
+           endif
+! ssa - linear interpolation; extrapolation
+           slope=(waer600(i,k,j)-waer400(i,k,j))/.2
+           ssaaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+waer600(i,k,j)
+           if(ssaaer(ncol,k,nb).lt.0.4) ssaaer(ncol,k,nb)=0.4
+           if(ssaaer(ncol,k,nb).ge.1.0) ssaaer(ncol,k,nb)=1.0
+! g - linear interpolation;extrapolation
+           slope=(gaer600(i,k,j)-gaer400(i,k,j))/.2
+           asmaer(ncol,k,nb) = slope*(wavemid(nb)-.6)+gaer600(i,k,j) ! notice reversed varaibles
+           if(asmaer(ncol,k,nb).lt.0.5) asmaer(ncol,k,nb)=0.5
+           if(asmaer(ncol,k,nb).ge.1.0) asmaer(ncol,k,nb)=1.0
+        endif
+      end do ! k
+      end do ! nb
+
+!wig beg
+      do nb = 1, nbndsw
+         slope = 0.  !use slope as a sum holder
+         do k = kts,kte
+            slope = slope + tauaer(ncol,k,nb)
+         end do
+         if( slope < 0. ) then
+            write(msg,'("ERROR: Negative total optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
+            call wrf_error_fatal(msg)
+         else if( slope > 6. ) then
+            call wrf_message("-------------------------")
+            write(msg,'("WARNING: Large total sw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
+            call wrf_message(msg)
+
+            call wrf_message("Diagnostics 1: k, tauaer300, tauaer400, tauaer600, tauaer999, tauaer")
+            do k=kts,kte
+               write(msg,'(i4,5f8.2)') k, tauaer300(i,k,j), tauaer400(i,k,j), &
+                    tauaer600(i,k,j), tauaer999(i,k,j),tauaer(ncol,k,nb)
+               call wrf_message(msg)
+               !czhao set an up-limit here to avoid segmentation fault 
+               !from extreme AOD
+               tauaer(ncol,k,nb)=tauaer(ncol,k,nb)*6.0/slope 
+            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, ssaaer(i,k,nb), asmaer(i,k,nb), tauaer(i,k,nb)
+               call wrf_message(msg)
+            end do
+            call wrf_message("-------------------------")
+         endif
+      enddo  ! nb
+      endif  ! aer_ra_feedback
+#endif
+
+
+! Zero array for input of aerosol optical thickness for use with
+! ECMWF aerosol types (not used)
+         do na = 1, naerec
+            do k = kts, kte+1
+               ecaer(ncol,k,na) = 0.
+            enddo
+         enddo
+
+! Call RRTMG shortwave radiation model
+
+         call rrtmg_sw &
+            (ncol    ,nlay    ,icld    , &
+             play    ,plev    ,tlay    ,tlev    ,tsfc   , &
+             h2ovmr , o3vmr   ,co2vmr  ,ch4vmr  ,n2ovmr ,o2vmr , &
+             asdir   ,asdif   ,aldir   ,aldif   , &
+             coszen  ,adjes   ,dyofyr  ,scon    , &
+             inflgsw ,iceflgsw,liqflgsw,cldfmcl , &
+             taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , &
+             ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
+             tauaer  ,ssaaer  ,asmaer  ,ecaer   , &
+             swuflx  ,swdflx  ,swhr    ,swuflxc ,swdflxc ,swhrc)
+
+! Output net absorbed shortwave surface flux and shortwave cloud forcing
+! at the top of atmosphere (W/m2)
+         gsw(i,j) = swdflx(1,1) - swuflx(1,1)
+         swcf(i,j) = (swdflx(1,kte+2) - swuflx(1,kte+2)) - (swdflxc(1,kte+2) - swuflxc(1,kte+2))
+
+         if (present(swupt)) then 
+! Output up and down toa fluxes for total and clear sky
+            swupt(i,j)     = swuflx(1,kte+2)
+            swuptc(i,j)    = swuflxc(1,kte+2)
+            swdnt(i,j)     = swdflx(1,kte+2)
+            swdntc(i,j)    = swdflxc(1,kte+2)
+! Output up and down surface fluxes for total and clear sky
+            swupb(i,j)     = swuflx(1,1)
+            swupbc(i,j)    = swuflxc(1,1)
+            swdnb(i,j)     = swdflx(1,1)
+            swdnbc(i,j)    = swdflxc(1,1)
+         endif
+
+! Output up and down layer fluxes for total and clear sky.
+! Vertical ordering is from bottom to top in units of W m-2. 
+         if ( present (swupflx) ) then
+         do k=kts,kte+2
+            swupflx(i,k,j)  = swuflx(1,k)
+            swupflxc(i,k,j) = swuflxc(1,k)
+            swdnflx(i,k,j)  = swdflx(1,k)
+            swdnflxc(i,k,j) = swdflxc(1,k)
+         enddo
+         endif
+
+! Output heating rate tendency; convert heating rate from K/d to K/s
+! Heating rate arrays are ordered vertically from bottom to top here. 
+         do k=kts,kte 
+            tten1d(k) = swhr(ncol,k)/86400.
+            rthratensw(i,k,j) = tten1d(k)/pi3d(i,k,j)
+         enddo
+      else
+         if (present(swupt)) then 
+! Output up and down toa fluxes for total and clear sky
+            swupt(i,j)     = 0.
+            swuptc(i,j)    = 0.
+            swdnt(i,j)     = 0.
+            swdntc(i,j)    = 0.
+! Output up and down surface fluxes for total and clear sky
+            swupb(i,j)     = 0.
+            swupbc(i,j)    = 0.
+            swdnb(i,j)     = 0.
+            swdnbc(i,j)    = 0.
+         endif
+
+      endif
+!
+      end do i_loop
+   end do j_loop                                           
+
+
+!-------------------------------------------------------------------
+
+   END SUBROUTINE RRTMG_SWRAD
+
+ 
+!====================================================================
+   SUBROUTINE rrtmg_swinit(                                         &
+                       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
+
+! Read in absorption coefficients and other data
+   IF ( allowed_to_read ) THEN
+     CALL rrtmg_swlookuptable
+   ENDIF
+
+! Perform g-point reduction and other initializations
+! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
+   call rrtmg_sw_ini(cp)
+
+   END SUBROUTINE rrtmg_swinit
+
+
+! **************************************************************************     
+      SUBROUTINE rrtmg_swlookuptable
+! **************************************************************************     
+
+IMPLICIT NONE
+
+! Local                                    
+      INTEGER :: i
+      LOGICAL                 :: opened
+      LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
+
+      CHARACTER*80 errmess
+      INTEGER rrtmg_unit
+
+      IF ( wrf_dm_on_monitor() ) THEN
+        DO i = 10,99
+          INQUIRE ( i , OPENED = opened )
+          IF ( .NOT. opened ) THEN
+            rrtmg_unit = i
+            GOTO 2010
+          ENDIF
+        ENDDO
+        rrtmg_unit = -1
+ 2010   CONTINUE
+      ENDIF
+      CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE )
+      IF ( rrtmg_unit < 0 ) THEN
+        CALL wrf_error_fatal ( 'module_ra_rrtmg_sw: rrtm_swlookuptable: Can not '// &
+                               'find unused fortran unit to read in lookup table.' )
+      ENDIF
+
+      IF ( wrf_dm_on_monitor() ) THEN
+        OPEN(rrtmg_unit,FILE='RRTMG_SW_DATA',                  &
+             FORM='UNFORMATTED',STATUS='OLD',ERR=9009)
+      ENDIF
+
+      call sw_kgb16(rrtmg_unit)
+      call sw_kgb17(rrtmg_unit)
+      call sw_kgb18(rrtmg_unit)
+      call sw_kgb19(rrtmg_unit)
+      call sw_kgb20(rrtmg_unit)
+      call sw_kgb21(rrtmg_unit)
+      call sw_kgb22(rrtmg_unit)
+      call sw_kgb23(rrtmg_unit)
+      call sw_kgb24(rrtmg_unit)
+      call sw_kgb25(rrtmg_unit)
+      call sw_kgb26(rrtmg_unit)
+      call sw_kgb27(rrtmg_unit)
+      call sw_kgb28(rrtmg_unit)
+      call sw_kgb29(rrtmg_unit)
+
+     IF ( wrf_dm_on_monitor() ) CLOSE (rrtmg_unit)
+
+     RETURN
+9009 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error opening RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+     END SUBROUTINE rrtmg_swlookuptable
+
+! **************************************************************************
+!  RRTMG Shortwave Radiative Transfer Model
+!  Atmospheric and Environmental Research, Inc., Cambridge, MA
+!
+!  Original by J.Delamere, Atmospheric & Environmental Research.
+!  Reformatted for F90: JJMorcrette, ECMWF
+!  Revision for GCMs:  Michael J. Iacono, AER, July 2002
+!  Further F90 reformatting:  Michael J. Iacono, AER, June 2006
+!
+!  This file contains 14 READ statements that include the 
+!  absorption coefficients and other data for each of the 14 shortwave
+!  spectral bands used in RRTMG_SW.  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 module RRTMG_SW_INIT to reduce
+!  the total number of g-points from 224 to 112 for use in the GCM.
+! **************************************************************************
+
+! **************************************************************************
+      subroutine sw_kgb16(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg16, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            rayl, strrat1, layreffr
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+
+!     Array rayl contains the Rayleigh extinction coefficient at v = 2925 cm-1.
+
+!     The array KAO 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 KBO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 )
+#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
+#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         rayl, strrat1, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
+      DM_BCAST_REAL(rayl)
+      DM_BCAST_REAL(strrat1)
+      DM_BCAST_INTEGER(layreffr)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb16
+
+! **************************************************************************
+      subroutine sw_kgb17(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg17, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            rayl, strrat, layreffr
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+
+!     Array rayl contains the Rayleigh extinction coefficient at v = 3625 cm-1.
+
+!     The array KAO 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 KBO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 )
+#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
+#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
+      DM_BCAST_REAL(rayl)
+      DM_BCAST_REAL(strrat)
+      DM_BCAST_INTEGER(layreffr)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb17
+
+! **************************************************************************
+      subroutine sw_kgb18(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg18, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            rayl, strrat, layreffr
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+
+!     Array rayl contains the Rayleigh extinction coefficient at v = 4325 cm-1.
+
+!     The array KAO 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 KBO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 )
+#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
+#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
+      DM_BCAST_REAL(rayl)
+      DM_BCAST_REAL(strrat)
+      DM_BCAST_INTEGER(layreffr)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb18 
+
+! **************************************************************************
+      subroutine sw_kgb19(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg19, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            rayl, strrat, layreffr
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+
+!     Array rayl contains the Rayleigh extinction coefficient at v = 4900 cm-1.
+
+!     The array KAO 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 KBO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 )
+#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
+#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
+      DM_BCAST_REAL(rayl)
+      DM_BCAST_REAL(strrat)
+      DM_BCAST_INTEGER(layreffr)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb19
+
+! **************************************************************************
+      subroutine sw_kgb20(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg20, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            absch4o, rayl, layreffr
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+
+!     Array rayl contains the Rayleigh extinction coefficient at v = 5670 cm-1.
+
+!     Array absch4o contains the absorption coefficients for methane.
+
+!     The array KAO 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 KBO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 )
+#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
+#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         rayl, layreffr, absch4o, kao, kbo, selfrefo, forrefo, sfluxrefo
+      DM_BCAST_REAL(rayl)
+      DM_BCAST_INTEGER(layreffr)
+      DM_BCAST_MACRO(absch4o)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb20
+
+! **************************************************************************
+      subroutine sw_kgb21(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg21, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            rayl, strrat, layreffr
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+
+!     Array rayl contains the Rayleigh extinction coefficient at v = 6925 cm-1.
+
+!     The array KAO 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 KBO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 )
+#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
+#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
+      DM_BCAST_REAL(rayl)
+      DM_BCAST_REAL(strrat)
+      DM_BCAST_INTEGER(layreffr)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb21
+
+! **************************************************************************
+      subroutine sw_kgb22(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg22, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            rayl, strrat, layreffr
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+
+!     Array rayl contains the Rayleigh extinction coefficient at v = 8000 cm-1.
+
+!     The array KAO 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 KBO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296_rb,260_rb,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 )
+#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
+#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo
+      DM_BCAST_REAL(rayl)
+      DM_BCAST_REAL(strrat)
+      DM_BCAST_INTEGER(layreffr)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb22
+
+! **************************************************************************
+      subroutine sw_kgb23(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg23, only : kao, selfrefo, forrefo, sfluxrefo, &
+                            raylo, givfac, layreffr
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+
+!     Array raylo contains the Rayleigh extinction coefficient at all v for this band
+
+!     Array givfac is the average Giver et al. correction factor for this band. 
+
+!     The array KAO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 )
+#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
+#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         raylo, givfac, layreffr, kao, selfrefo, forrefo, sfluxrefo
+      DM_BCAST_MACRO(raylo)
+      DM_BCAST_REAL(givfac)
+      DM_BCAST_INTEGER(layreffr)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb23
+
+! **************************************************************************
+      subroutine sw_kgb24(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg24, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            raylao, raylbo, abso3ao, abso3bo, strrat, layreffr
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+
+!     Arrays raylao and raylbo contain the Rayleigh extinction coefficient at 
+!     all v for this band for the upper and lower atmosphere.
+
+!     Arrays abso3ao and abso3bo contain the ozone absorption coefficient at 
+!     all v for this band for the upper and lower atmosphere.
+
+!     The array KAO 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 KBO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 )
+#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
+#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         raylao, raylbo, strrat, layreffr, abso3ao, abso3bo, kao, kbo, selfrefo, &
+         forrefo, sfluxrefo
+      DM_BCAST_MACRO(raylao)
+      DM_BCAST_MACRO(raylbo)
+      DM_BCAST_REAL(strrat)
+      DM_BCAST_INTEGER(layreffr)
+      DM_BCAST_MACRO(abso3ao)
+      DM_BCAST_MACRO(abso3bo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb24
+
+! **************************************************************************
+      subroutine sw_kgb25(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg25, only : kao, sfluxrefo, &
+                            raylo, abso3ao, abso3bo, layreffr
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+
+!     Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1.
+
+!     Arrays abso3ao and abso3bo contain the ozone absorption coefficient at 
+!     all v for this band for the upper and lower atmosphere.
+
+!     The array KAO 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.
+
+#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
+#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         raylo, layreffr, abso3ao, abso3bo, kao, sfluxrefo
+      DM_BCAST_MACRO(raylo)
+      DM_BCAST_INTEGER(layreffr)
+      DM_BCAST_MACRO(abso3ao)
+      DM_BCAST_MACRO(abso3bo)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb25
+
+! **************************************************************************
+      subroutine sw_kgb26(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg26, only : sfluxrefo, raylo
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+
+!     Array raylo contains the Rayleigh extinction coefficient at all v for this band.
+
+#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         raylo, sfluxrefo
+      DM_BCAST_MACRO(raylo)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb26
+
+! **************************************************************************
+      subroutine sw_kgb27(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg27, only : kao, kbo, sfluxrefo, raylo, &
+                            scalekur, layreffr
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+!     The values in array sfluxrefo were obtained using the "low resolution"
+!     version of the Kurucz solar source function.  For unknown reasons,
+!     the total irradiance in this band differs from the corresponding
+!     total in the "high-resolution" version of the Kurucz function.
+!     Therefore, these values are scaled by the factor SCALEKUR.
+
+!     Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1.
+
+!     The array KAO 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 KBO 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.
+
+#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
+#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
+#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         raylo, scalekur, layreffr, kao, kbo, sfluxrefo
+      DM_BCAST_MACRO(raylo)
+      DM_BCAST_REAL(scalekur)
+      DM_BCAST_INTEGER(layreffr)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb27
+
+! **************************************************************************
+      subroutine sw_kgb28(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg28, only : kao, kbo, sfluxrefo, &
+                            rayl, strrat, layreffr
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+
+!     Array raylo contains the Rayleigh extinction coefficient at all v = ???? cm-1.
+
+!     The array KAO 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 KBO 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.
+
+#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
+#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
+#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         rayl, strrat, layreffr, kao, kbo, sfluxrefo
+      DM_BCAST_REAL(rayl)
+      DM_BCAST_REAL(strrat)
+      DM_BCAST_INTEGER(layreffr)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb28
+
+! **************************************************************************
+      subroutine sw_kgb29(rrtmg_unit)
+! **************************************************************************
+
+      use rrsw_kg29, only : kao, kbo, selfrefo, forrefo, sfluxrefo, &
+                            absh2oo, absco2o, rayl, layreffr
+
+      implicit none
+      save
+
+! Input
+      integer, intent(in) :: rrtmg_unit
+
+! Local                                    
+      character*80 errmess
+      logical, external  :: wrf_dm_on_monitor
+
+!     Array sfluxrefo contains the Kurucz solar source function for this band. 
+
+!     Array rayl contains the Rayleigh extinction coefficient at all v = 2200 cm-1.
+
+!     Array absh2oo contains the water vapor absorption coefficient for this band.
+
+!     Array absco2o contains the carbon dioxide absorption coefficient for this band.
+
+!     The array KAO 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 KBO 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 FORREFO contains the coefficient of the water vapor
+!     foreign-continuum (including the energy term).  The first 
+!     index refers to reference temperature (296,260,224,260) and 
+!     pressure (970,475,219,3 mbar) levels.  The second index 
+!     runs over the g-channel (1 to 16).
+
+!     The array SELFREFO 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 )
+#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 )
+#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 )
+
+      IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
+         rayl, layreffr, absh2oo, absco2o, kao, kbo, selfrefo, forrefo, sfluxrefo
+      DM_BCAST_REAL(rayl)
+      DM_BCAST_INTEGER(layreffr)
+      DM_BCAST_MACRO(absh2oo)
+      DM_BCAST_MACRO(absco2o)
+      DM_BCAST_MACRO(kao)
+      DM_BCAST_MACRO(kbo)
+      DM_BCAST_MACRO(selfrefo)
+      DM_BCAST_MACRO(forrefo)
+      DM_BCAST_MACRO(sfluxrefo)
+
+     RETURN
+9010 CONTINUE
+     WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_sw: error reading RRTMG_SW_DATA on unit ',rrtmg_unit
+     CALL wrf_error_fatal(errmess)
+
+      end subroutine sw_kgb29
+
+!------------------------------------------------------------------
+
+END MODULE module_ra_rrtmg_sw
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_sw.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_sw.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_ra_sw.F	(revision 17)
@@ -0,0 +1,520 @@
+!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                     &
+                    )
+!------------------------------------------------------------------
+   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
+
+!
+   INTEGER :: i,j,K,NK
+   LOGICAL :: predicate , do_topo_shading
+   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)
+! slope code removed - factor now done in surface driver
+           CALL SWPARA(TTEN1D,GSW0,XLAT0,XLONG0,ALB0,              &
+                       T1D,QV1D,QC1D,QR1D,QI1D,QS1D,QG1D,P1D,      &
+                       XTIME,GMT,RHO01D,DZ,                        &
+                       R,CP,G,DECLIN,SOLCON,                       &
+                       RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1,   &
+                       kts,kte      )
+         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,             		  &
+                     RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1,    &
+                     kts,kte,slope_rad,shadow,slp_azi,slope       )
+!------------------------------------------------------------------
+!     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
+! For slope-dependent radiation
+
+   INTEGER, OPTIONAL, INTENT(IN) :: slope_rad,shadow
+   REAL, OPTIONAL,    INTENT(IN) :: slp_azi,slope
+
+! 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 :: 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
+
+! For slope-dependent radiation
+
+   REAL :: diffuse_frac, corr_fac, csza_slp
+
+
+      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)
+
+!     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)
+
+    IF (PRESENT(slope_rad)) THEN
+! Slope-dependent solar radiation part
+
+      if (slope_rad.eq.1) then
+
+!  Parameterize diffuse fraction of global solar radiation as a function of the ratio between TOA radiation and surface global radiation
+
+        diffuse_frac = min(1.,1/(max(0.1,2.1-2.8*log(log(SDOWN(kts)/max(SDOWN(kte+1),1.e-3))))))
+        if ((slope.eq.0).or.(diffuse_frac.eq.1).or.(csza.lt.1.e-2)) then  ! no topographic effects when all radiation is diffuse or the sun is too close to the horizon
+        corr_fac = 1
+        goto 140
+        endif
+
+! cosine of zenith angle over sloping topography
+
+        csza_slp = ((SIN(XXLAT)*COS(HRANG))*                                          &
+                    (-cos(slp_azi)*sin(slope))-SIN(HRANG)*(sin(slp_azi)*sin(slope))+  &
+                    (COS(XXLAT)*COS(HRANG))*cos(slope))*                              &
+                   COS(DECLIN)+(COS(XXLAT)*(cos(slp_azi)*sin(slope))+                 &
+                   SIN(XXLAT)*cos(slope))*SIN(DECLIN)
+        IF(csza_slp.LE.1.E-4) csza_slp = 0
+
+! Topographic shading
+
+        if (shadow.eq.1) csza_slp = 0
+
+! Correction factor for sloping topography; the diffuse fraction of solar radiation is assumed to be unaffected by the slope
+        corr_fac = diffuse_frac + (1-diffuse_frac)*csza_slp/csza
+
+ 140	continue   
+
+        GSW=(1.-ALBEDO)*SDOWN(kte+1)*corr_fac 
+        
+      endif
+    ENDIF
+
+    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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_radiation_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_radiation_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_radiation_driver.F	(revision 17)
@@ -0,0 +1,2396 @@
+!WRF:MEDIATION_LAYER:PHYSICS
+!
+MODULE module_radiation_driver
+CONTAINS
+!BOP
+! !IROUTINE: radiation_driver - interface to radiation physics options
+
+! !INTERFACE:
+   SUBROUTINE radiation_driver (                                  &
+               ACFRCV ,ACFRST ,ALBEDO  &
+              ,CFRACH ,CFRACL ,CFRACM  &
+              ,CUPPT  ,CZMEAN ,DT      &
+              ,DZ8W   ,EMISS  ,GLW     &
+              ,GMT    ,GSW    ,HBOT    &
+              ,HTOP   ,HBOTR  ,HTOPR   &
+              ,ICLOUD                  &
+              ,ITIMESTEP,JULDAY, JULIAN &
+              ,JULYR  ,LW_PHYSICS       &
+              ,NCFRCV ,NCFRST ,NPHS     &
+              ,P8W    ,P ,PI            &
+              ,RADT   ,RA_CALL_OFFSET   &
+              ,RHO    ,RLWTOA           &
+              ,RSWTOA ,RTHRATEN         &
+              ,RTHRATENLW      ,RTHRATENSW    &
+              ,SNOW   ,STEPRA ,SWDOWN  &
+              ,SWDOWNC ,SW_PHYSICS     &
+              ,T8W     ,T ,TAUCLDC &
+              ,TAUCLDI ,TSK ,VEGFRA  &
+              ,WARM_RAIN ,XICE ,XLAND   &
+              ,XLAT ,XLONG ,YR          &
+!Optional solar variables
+              ,DECLINX ,SOLCONX ,COSZEN ,HRANG    &
+              , CEN_LAT                                      &
+              ,Z                                             &
+              ,LEVSIZ, N_OZMIXM                    &
+              ,N_AEROSOLC                                    &
+              ,PAERLEV                                       &
+              ,CAM_ABS_DIM1, CAM_ABS_DIM2 &
+              ,CAM_ABS_FREQ_S                         &
+              ,XTIME                                           &
+              ,CURR_SECS, ADAPT_STEP_FLAG       &
+            ! indexes
+              ,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
+              , TLWDN, TLWUP                        & ! goddard schemes
+              , SLWDN, SLWUP                        & ! goddard schemes
+              , TSWDN, TSWUP                        & ! goddard schemes
+              , SSWDN, SSWUP                        & ! goddard schemes
+              , CLDFRA                                        &
+              , PB                                                &
+              , F_ICE_PHY,F_RAIN_PHY       &
+              , QV, F_QV                     &
+              , QC, F_QC                     &
+              , QR, F_QR                     &
+              , QI, F_QI                     &
+              , QS, F_QS                     &
+              , QG, F_QG                     &
+              , QNDROP, F_QNDROP    &
+              ,ACSWUPT   ,ACSWUPTC            &
+              ,ACSWDNT   ,ACSWDNTC            &
+              ,ACSWUPB   ,ACSWUPBC            &
+              ,ACSWDNB   ,ACSWDNBC            &
+              ,ACLWUPT   ,ACLWUPTC            &
+              ,ACLWDNT   ,ACLWDNTC            &
+              ,ACLWUPB   ,ACLWUPBC            &
+              ,ACLWDNB   ,ACLWDNBC            &
+              ,SWUPT ,SWUPTC                  &
+              ,SWDNT ,SWDNTC                  &
+              ,SWUPB ,SWUPBC                  &
+              ,SWDNB ,SWDNBC                  &
+              ,LWUPT ,LWUPTC                  &
+              ,LWDNT ,LWDNTC                  &
+              ,LWUPB ,LWUPBC                  &
+              ,LWDNB ,LWDNBC                  &
+              ,LWCF                           &
+              ,SWCF                           &
+              ,OLR                            &
+              ,OZMIXM, PIN                    &
+              ,M_PS_1, M_PS_2, AEROSOLC_1     &
+              ,AEROSOLC_2, M_HYBI0            &
+              ,ABSTOT, ABSNXT, EMSTOT         &
+              ,CU_RAD_FEEDBACK                &
+              ,AER_RA_FEEDBACK                &
+              ,QC_ADJUST , QI_ADJUST          &
+              ,PM2_5_DRY, PM2_5_WATER         &
+              ,PM2_5_DRY_EC                   &
+              ,TAUAER300, TAUAER400 & ! jcb
+              ,TAUAER600, TAUAER999 & ! jcb
+              ,GAER300, GAER400, GAER600, GAER999 & ! jcb
+              ,WAER300, WAER400, WAER600, WAER999 & ! jcb
+              ,TAUAERlw1,  TAUAERlw2  &
+              ,TAUAERlw3,  TAUAERlw4  &
+              ,TAUAERlw5,  TAUAERlw6  &
+              ,TAUAERlw7,  TAUAERlw8  &
+              ,TAUAERlw9,  TAUAERlw10   &
+              ,TAUAERlw11, TAUAERlw12   &
+              ,TAUAERlw13, TAUAERlw14   &
+              ,TAUAERlw15, TAUAERlw16  &
+              ,progn                                            &
+              ,slope_rad,topo_shading     &
+              ,shadowmask,ht,dx,dy                 &
+              ,SWUPFLX,SWUPFLXC,SWDNFLX,SWDNFLXC                          & ! Optional
+              ,LWUPFLX,LWUPFLXC,LWDNFLX,LWDNFLXC                          & ! Optional
+                                                                          )
+
+
+!-------------------------------------------------------------------------
+
+! !USES:
+   USE module_state_description, ONLY : RRTMSCHEME, GFDLLWSCHEME        &
+                                       ,RRTMG_LWSCHEME, RRTMG_SWSCHEME  &
+                                       ,SWRADSCHEME, GSFCSWSCHEME       &
+                                       ,GFDLSWSCHEME, CAMLWSCHEME, CAMSWSCHEME &
+                                       ,HELDSUAREZ                      &
+#ifdef HWRF
+                                       ,HWRFSWSCHEME, HWRFLWSCHEME  &
+#endif
+                                       ,goddardlwscheme                 & 
+                                       ,goddardswscheme                   
+
+
+   USE module_model_constants
+   USE module_wrf_error , ONLY : wrf_err_message
+
+! *** add new modules of schemes here
+
+   USE module_ra_sw         , ONLY : swrad
+   USE module_ra_gsfcsw     , ONLY : gsfcswrad
+   USE module_ra_rrtm       , ONLY : rrtmlwrad
+   USE module_ra_rrtmg_lw   , ONLY : rrtmg_lwrad
+   USE module_ra_rrtmg_sw   , ONLY : rrtmg_swrad
+   USE module_ra_cam        , ONLY : camrad
+   USE module_ra_gfdleta    , ONLY : etara
+#ifdef HWRF
+   USE module_ra_hwrf
+#endif
+   USE module_ra_hs         , ONLY : hsrad
+
+   USE module_ra_goddard    , ONLY : goddardrad
+
+
+
+   !  This driver calls subroutines for the radiation parameterizations.
+   !
+   !  short wave radiation choices:
+   !  1. swrad (19??)
+   !  4. rrtmg_sw - Added November 2008, MJIacono, AER, Inc.
+   !
+   !  long wave radiation choices:
+   !  1. rrtmlwrad
+   !  4. rrtmg_lw - Added November 2008, MJIacono, AER, Inc.
+   !
+!----------------------------------------------------------------------
+   IMPLICIT NONE
+!<DESCRIPTION>
+!
+! 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
+! <tt>n_moist - PARAM_FIRST_SCALAR + 1</tt> , 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 <a href=set_scalar_indices_from_config.html>set_scalar_indices_from_config</a> 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.
+!</DESCRIPTION>
+! 
+!======================================================================
+! 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
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL ,       &
+         INTENT(IN ) ::  tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao 
+                         tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao 
+                         tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao 
+                         tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16
+
+   LOGICAL, OPTIONAL :: cu_rad_feedback
+
+   INTEGER, INTENT(IN   ), OPTIONAL  ::   aer_ra_feedback
+
+!jdfcz   INTEGER, OPTIONAL, INTENT(IN   )    :: progn,prescribe
+   INTEGER, OPTIONAL, INTENT(IN   )    :: progn
+!
+! 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
+
+! TOA and surface, upward and downward, total and clear fluxes
+   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
+
+! Upward and downward, total and clear sky layer fluxes (W m-2)
+   REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ),                &
+         OPTIONAL, INTENT(INOUT) ::                               &
+                               SWUPFLX,SWUPFLXC,SWDNFLX,SWDNFLXC, &
+                               LWUPFLX,LWUPFLXC,LWDNFLX,LWDNFLXC
+
+   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  ),OPTIONAL ::                          YR
+!
+   INTEGER, INTENT(IN  ) ::                    JULDAY, itimestep
+   REAL, INTENT(IN ),OPTIONAL     ::                    CURR_SECS
+   LOGICAL, INTENT(IN ),OPTIONAL  ::              ADAPT_STEP_FLAG
+
+   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 for Goddard LW and SW
+   REAL, DIMENSION(IMS:IME, JMS:JME, 1:8)       :: ERBE_out  !extra output for SDSU
+   REAL, DIMENSION(IMS:IME, JMS:JME), OPTIONAL, INTENT(OUT) ::   &
+                                               TLWDN, TLWUP,     &
+                                               SLWDN, SLWUP,     &
+                                               TSWDN, TSWUP,     &
+                                               SSWDN, SSWUP        ! for Goddard schemes
+
+! 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
+
+! Variables for slope-dependent radiation
+
+     REAL, OPTIONAL, INTENT(IN) :: dx,dy
+     INTEGER, OPTIONAL, INTENT(IN) :: slope_rad,topo_shading
+     REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN)  :: ht
+     INTEGER, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: shadowmask
+
+
+! 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,XXLAT,TLOCTM,XT24, CEN_LAT
+   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
+
+   REAL    ::    next_rad_time
+   LOGICAL ::    run_param
+!------------------------------------------------------------------
+! solar related variables are added to declaration
+!-------------------------------------------------
+   REAL, OPTIONAL, INTENT(OUT) :: DECLINX,SOLCONX
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: COSZEN
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: HRANG
+!------------------------------------------------------------------
+
+   CALL wrf_debug (1, 'Top of Radiation Driver')
+   WRITE ( wrf_err_message , * ) 'itimestep = ',itimestep,', dt = ',dt,', lw and sw options = ',lw_physics,sw_physics
+   CALL wrf_debug (1, wrf_err_message )
+   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
+! also need to account for stepra=1 which always has zero modulo output
+
+!
+! Calculate whether or not to run the radiation step.
+! If CURR_SECS is passed in, we will calculate based upon that.  If it
+!   is not passed in, we'll do the old method of using the time STEP number
+!   
+
+   IF ( (itimestep .EQ. 1) .OR. (MOD(itimestep,STEPRA) .EQ. 1 + ra_call_offset) .OR. &
+        (STEPRA .EQ. 1) ) THEN
+     run_param = .TRUE.
+   ELSE
+     run_param = .FALSE.
+   ENDIF
+   IF (PRESENT(adapt_step_flag)) THEN
+     IF ((adapt_step_flag)) THEN
+       IF ( (itimestep .EQ. 1) .OR. (radt .EQ. 0) .OR. &
+           ( CURR_SECS + dt >= ( INT( CURR_SECS / ( radt * 60 ) + 1 ) * radt * 60) ) ) THEN
+         run_param = .TRUE.
+       ELSE
+         run_param = .FALSE.
+       ENDIF
+     ENDIF
+   ENDIF
+
+   Radiation_step: IF ( run_param ) 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 &
+                                        .or. STEPABS .eq. 1 ) THEN
+       doabsems = .true.
+     ELSE
+       doabsems = .false.
+     ENDIF
+   IF (PRESENT(adapt_step_flag)) THEN
+     IF ((adapt_step_flag)) THEN
+       IF ( (itimestep .EQ. 1) .OR. (cam_abs_freq_s .EQ. 0) .OR. &
+           ( CURR_SECS + dt >= ( INT( CURR_SECS / ( cam_abs_freq_s ) + 1 ) * cam_abs_freq_s) ) ) THEN
+         doabsems = .true.
+       ELSE
+         doabsems = .false.
+       ENDIF
+     ENDIF
+   ENDIF
+
+   gfdl_lw = .false.
+   gfdl_sw = .false.
+
+
+! moved up and out of OMP loop because it only needs to be computed once
+! and because it is not entirely thread-safe (XT24, TOLOCTM and XXLAT need
+! their thread-privacy)  JM 20100217
+   DO ij = 1 , num_tiles
+     its = i_start(ij)
+     ite = i_end(ij)
+     jts = j_start(ij)
+     jte = j_end(ij)
+     CALL radconst(XTIME,DECLIN,SOLCON,JULIAN,               &
+                   DEGRAD,DPD                                )
+
+     IF(PRESENT(declinx).AND.PRESENT(solconx))THEN
+! saved to state arrays used in surface driver
+       declinx=declin
+       solconx=solcon
+     ENDIF
+
+     IF(PRESENT(coszen).AND.PRESENT(hrang))THEN
+! state arrays of hrang and coszen used in surface driver
+       XT24=MOD(XTIME+RADT*0.5,1440.)
+       DO j=jts,jte
+       DO i=its,ite
+          TLOCTM=GMT+XT24/60.+XLONG(I,J)/15.
+          HRANG(I,J)=15.*(TLOCTM-12.)*DEGRAD
+          XXLAT=XLAT(I,J)*DEGRAD
+          COSZEN(I,J)=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG(I,J))
+       ENDDO
+       ENDDO
+     ENDIF
+   ENDDO
+
+!---------------
+   !$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.
+        RTHRATENLW(I,K,J)=0.
+        RTHRATENSW(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
+
+     IF ( PRESENT( SWUPFLX ) ) THEN
+        DO j=jts,jte
+        DO k=kts,kte+2
+        DO i=its,ite
+           SWUPFLX(I,K,J) = 0.0
+           SWDNFLX(I,K,J) = 0.0
+           SWUPFLXC(I,K,J) = 0.0
+           SWDNFLXC(I,K,J) = 0.0
+           LWUPFLX(I,K,J) = 0.0
+           LWDNFLX(I,K,J) = 0.0
+           LWUPFLXC(I,K,J) = 0.0
+           LWDNFLXC(I,K,J) = 0.0
+        ENDDO
+        ENDDO
+        ENDDO
+     ENDIF
+
+! 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
+
+     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 (RRTMG_LWSCHEME)
+
+     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    
+
+     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,TSK=tsk,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 (goddardlwscheme)
+
+             CALL wrf_debug (100, 'CALL goddard longwave radiation scheme ')
+             IF (itimestep.eq.1) then
+                call wrf_message('running goddard lw radiation')
+             ENDIF
+             CALL goddardrad(sw_or_lw='lw'                             &
+                    ,rthraten=rthraten,gsf=glw,xlat=xlat,xlong=xlong   &
+                    ,alb=albedo,t3d=t,p3d=p,p8w3d=p8w,pi3d=pi          &
+                    ,dz8w=dz8w,rho_phy=rho,emiss=emiss                 &
+                    ,cldfra3d=cldfra                                   &
+                    ,gmt=gmt,cp=cp,g=g,t8w=t8w                         &
+                    ,julday=julday,xtime=xtime                         &
+                    ,declin=declin,solcon=solcon                       &
+                    , center_lat = cen_lat                             &
+                    ,radfrq=radt,degrad=degrad                         &
+                    ,taucldi=taucldi,taucldc=taucldc                   &
+                    ,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                     &
+                    ,erbe_out=erbe_out                                 & !optional
+                                                                       )
+
+        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                         &
+                 ,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
+
+#ifdef HWRF
+       CASE (HWRFLWSCHEME)
+
+             CALL wrf_debug (100, 'CALL hwrflw')
+
+             gfdl_lw  = .true.
+
+               CALL HWRFRA(DT=dt,thraten=RTHRATEN,thratenlw=RTHRATENLW,thratensw=RTHRATENSW,pi3d=pi, &
+                        XLAND=xland,P8w=p8w,DZ8w=dz8w,RHO_PHY=rho,P_PHY=p,T=t,          &
+                        QV=qv,QW=qc_temp,QI=Qi,                      &
+                        TSK2D=tsk,GLW=GLW,GSW=GSW,                                 &
+                        TOTSWDN=swdown,TOTLWDN=glw,RSWTOA=rswtoa,RLWTOA=rlwtoa,CZMEAN=czmean,        & !Added
+                        GLAT=glat,GLON=glon,HTOP=htop,HBOT=hbot,htopr=htopr,hbotr=hbotr,ALBEDO=albedo,CUPPT=cuppt,&
+                        VEGFRA=vegfra,SNOW=snow,G=g,GMT=gmt,                           & !Modified
+                        NSTEPRA=stepra,NPHS=nphs,itimestep=itimestep,                       & !Modified
+                        julyr=julyr,julday=julday,gfdl_lw=gfdl_lw,gfdl_sw=gfdl_sw,                &
+                        CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach,                        & !Added
+                        ACFRST=acfrst,NCFRST=ncfrst,ACFRCV=acfrcv,NCFRCV=ncfrcv,                 & !Added
+                        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                    )
+
+
+#endif
+
+        CASE (CAMLWSCHEME)
+
+             CALL wrf_debug(100, 'CALL camrad lw')
+
+             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,    &
+                     dolw=.true.,dosw=.false.,                         &
+                     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,YR=YR,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 (RRTMG_LWSCHEME)
+             CALL wrf_debug (100, 'CALL rrtmg_lw')
+
+             CALL RRTMG_LWRAD(                                      &
+                  RTHRATENLW=RTHRATEN,                              &
+                  LWUPT=LWUPT,LWUPTC=LWUPTC,                        &
+                  LWDNT=LWDNT,LWDNTC=LWDNTC,                        &
+                  LWUPB=LWUPB,LWUPBC=LWUPBC,                        &
+                  LWDNB=LWDNB,LWDNBC=LWDNBC,                        &
+                  GLW=GLW,OLR=RLWTOA,LWCF=LWCF,                     &
+                  EMISS=EMISS,                                      &
+                  P8W=p8w,P3D=p,PI3D=pi,DZ8W=dz8w,TSK=tsk,T3D=t,    &
+                  T8W=t8w,RHO3D=rho,R=R_d,G=G,                      &
+                  ICLOUD=icloud,WARM_RAIN=warm_rain,CLDFRA3D=CLDFRA,&
+                  F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY,        &
+                  XLAND=XLAND,XICE=XICE,SNOW=SNOW,                  &
+                  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,                    &
+#ifdef WRF_CHEM
+                  TAUAERLW1=tauaerlw1,TAUAERLW2=tauaerlw2,          & ! jcb
+                  TAUAERLW3=tauaerlw3,TAUAERLW4=tauaerlw4,          & ! jcb
+                  TAUAERLW5=tauaerlw5,TAUAERLW6=tauaerlw6,          & ! jcb
+                  TAUAERLW7=tauaerlw7,TAUAERLW8=tauaerlw8,          & ! jcb
+                  TAUAERLW9=tauaerlw9,TAUAERLW10=tauaerlw10,          & ! jcb
+                  TAUAERLW11=tauaerlw11,TAUAERLW12=tauaerlw12,          & ! jcb
+                  TAUAERLW13=tauaerlw13,TAUAERLW14=tauaerlw14,          & ! jcb
+                  TAUAERLW15=tauaerlw15,TAUAERLW16=tauaerlw16,          & ! jcb
+                  aer_ra_feedback=aer_ra_feedback,                  &
+!jdfcz            progn=progn,prescribe=prescribe,                   &
+                  progn=progn,                                       &
+#endif
+                  QNDROP3D=qndrop,F_QNDROP=f_qndrop,                &
+                  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,&
+                  LWUPFLX=LWUPFLX,LWUPFLXC=LWUPFLXC,                &
+                  LWDNFLX=LWDNFLX,LWDNFLXC=LWDNFLXC                 &
+                                                                    )
+
+        CASE (HELDSUAREZ)
+             CALL wrf_debug (100, 'CALL heldsuarez')
+
+             CALL HSRAD(RTHRATEN,p8w,p,pi,dz8w,t,          &
+                     t8w, rho, R_d,G,CP, dt, xlat, degrad, &
+                     ids,ide, jds,jde, kds,kde,            &
+                     ims,ime, jms,jme, kms,kme,            &
+                     its,ite, jts,jte, kts,kte            )
+
+        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
+
+     IF (lw_physics .eq. goddardlwscheme) THEN
+          IF ( PRESENT (tlwdn) ) THEN
+        DO j=jts,jte
+        DO i=its,ite
+           tlwdn(i,j) = erbe_out(i,j,1)    ! TOA LW downwelling flux [W/m2]
+           tlwup(i,j) = erbe_out(i,j,2)    ! TOA LW upwelling flux [W/m2]
+           slwdn(i,j) = erbe_out(i,j,3)    ! surface LW downwelling flux [W/m2]
+           slwup(i,j) = erbe_out(i,j,4)    ! surface LW upwelling flux [W/m2]
+        ENDDO    
+        ENDDO    
+          ENDIF
+     ENDIF       
+
+!
+     swrad_cldfra_select: SELECT CASE(sw_physics)
+
+        CASE (CAMSWSCHEME)
+
+     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 (RRTMG_SWSCHEME)
+
+     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
+
+     END SELECT swrad_cldfra_select    
+
+     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           &
+                    ,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 &
+                    ,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                                 &
+                    ,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 &
+                    ,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 (goddardswscheme)
+
+             CALL wrf_debug(100, 'CALL goddard shortwave radiation scheme ')
+             IF (itimestep.eq.1) then
+                call wrf_message('running goddard sw radiation')
+             ENDIF
+             CALL goddardrad(sw_or_lw='sw'                             &
+                    ,rthraten=rthraten,gsf=gsw,xlat=xlat,xlong=xlong   &
+                    ,alb=albedo,t3d=t,p3d=p,p8w3d=p8w,pi3d=pi          &
+                    ,dz8w=dz8w,rho_phy=rho,emiss=emiss                 &
+                    ,cldfra3d=cldfra                                   &
+                    ,gmt=gmt,cp=cp,g=g,t8w=t8w                         &
+                    ,julday=julday,xtime=xtime                         &
+                    ,declin=declin,solcon=solcon                       &
+                    , center_lat = cen_lat                             &
+                    ,radfrq=radt,degrad=degrad                         &
+                    ,taucldi=taucldi,taucldc=taucldc                   &
+                    ,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                     &
+                    ,erbe_out=erbe_out                                 & !optional
+                                                                       )
+
+        CASE (CAMSWSCHEME)
+             CALL wrf_debug(100, 'CALL camrad sw')
+             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,    &
+                     dolw=.false.,dosw=.true.,                         &
+                     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,YR=YR,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
+             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 (RRTMG_SWSCHEME)
+             CALL wrf_debug(100, 'CALL rrtmg_sw')
+             CALL RRTMG_SWRAD(                                         &
+                     RTHRATENSW=RTHRATENSW,                            &
+                     SWUPT=SWUPT,SWUPTC=SWUPTC,                        &
+                     SWDNT=SWDNT,SWDNTC=SWDNTC,                        &
+                     SWUPB=SWUPB,SWUPBC=SWUPBC,                        &
+                     SWDNB=SWDNB,SWDNBC=SWDNBC,                        &
+                     SWCF=SWCF,GSW=GSW,                                &
+                     XTIME=XTIME,GMT=GMT,XLAT=XLAT,XLONG=XLONG,        &
+                     RADT=RADT,DEGRAD=DEGRAD,DECLIN=DECLIN,            &
+                     COSZR=COSZR,JULDAY=JULDAY,SOLCON=SOLCON,          &
+                     ALBEDO=ALBEDO,t3d=t,t8w=t8w,TSK=TSK,              &
+                     p3d=p,p8w=p8w,pi3d=pi,rho3d=rho,                  &
+                     dz8w=dz8w,CLDFRA3D=CLDFRA,R=R_D,G=G,              &
+                     ICLOUD=icloud,WARM_RAIN=warm_rain,                &
+                     F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY,        &
+                     XLAND=XLAND,XICE=XICE,SNOW=SNOW,                  &
+                     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,                    &
+#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,                  &
+!jdfcz               progn=progn,prescribe=prescribe,                  &
+                     progn=progn,                                      &
+#endif
+                     QNDROP3D=qndrop,F_QNDROP=f_qndrop,                &
+                     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,&
+                     SWUPFLX=SWUPFLX,SWUPFLXC=SWUPFLXC,                &
+                     SWDNFLX=SWDNFLX,SWDNFLXC=SWDNFLXC                 &
+                                                                       )
+             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                         &
+                 ,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
+
+#ifdef HWRF
+      CASE (HWRFSWSCHEME)
+
+             CALL wrf_debug (100, 'CALL hwrfsw')
+
+             gfdl_sw = .true.
+               CALL HWRFRA(DT=dt,thraten=RTHRATEN,thratenlw=RTHRATENLW,thratensw=RTHRATENSW,pi3d=pi, &
+                        XLAND=xland,P8w=p8w,DZ8w=dz8w,RHO_PHY=rho,P_PHY=p,T=t,          &
+                        QV=qv,QW=qc_temp,QI=Qi,                      &
+                        TSK2D=tsk,GLW=GLW,GSW=GSW,                                 &
+                        TOTSWDN=swdown,TOTLWDN=glw,RSWTOA=rswtoa,RLWTOA=rlwtoa,CZMEAN=czmean,        & !Added
+                        GLAT=glat,GLON=glon,HTOP=htop,HBOT=hbot,htopr=htopr,hbotr=hbotr,ALBEDO=albedo,CUPPT=cuppt,            &
+                        VEGFRA=vegfra,SNOW=snow,G=g,GMT=gmt,                           & !Modified
+                        NSTEPRA=stepra,NPHS=nphs,itimestep=itimestep,                       & !Modified
+                        julyr=julyr,julday=julday,gfdl_lw=gfdl_lw,gfdl_sw=gfdl_sw,                &
+                        CFRACL=cfracl,CFRACM=cfracm,CFRACH=cfrach,                        & !Added
+                        ACFRST=acfrst,NCFRST=ncfrst,ACFRCV=acfrcv,NCFRCV=ncfrcv,                 & !Added
+                        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                    )
+#endif
+
+        CASE (0)
+
+           ! Here in case we don't want to call a sw radiation scheme
+           ! For example, the Held-Suarez idealized test case
+           IF (lw_physics /= HELDSUAREZ) THEN
+             WRITE( wrf_err_message , * ) &
+'You have selected a longwave radiation option, but not a shortwave option (sw_physics = 0, lw_physics = ',lw_physics,')'
+             CALL wrf_error_fatal ( wrf_err_message )
+           END IF
+
+        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 .eq. goddardswscheme) THEN
+          IF ( PRESENT (tswdn) ) THEN
+        DO j=jts,jte
+        DO i=its,ite
+           tswdn(i,j) = erbe_out(i,j,5)    ! TOA SW downwelling flux [W/m2]
+           tswup(i,j) = erbe_out(i,j,6)    ! TOA SW upwelling flux [W/m2]
+           sswdn(i,j) = erbe_out(i,j,7)    ! surface SW downwelling flux [W/m2]
+           sswup(i,j) = erbe_out(i,j,8)    ! surface SW upwelling flux [W/m2]
+        ENDDO
+        ENDDO
+          ENDIF
+     ENDIF
+
+     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,RRTMG_LWSCHEME)
+   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,RRTMG_SWSCHEME)
+   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
+
+   SUBROUTINE pre_radiation_driver ( grid, config_flags                   &
+              ,itimestep, ra_call_offset                                  &
+              ,XLAT, XLONG, GMT, julian, xtime, RADT, STEPRA              &
+              ,ht,dx,dy,sina,cosa,shadowmask,slope_rad ,topo_shading      &
+              ,shadlen,ht_shad,ht_loc                                     &
+              ,ht_shad_bxs, ht_shad_bxe                                   &
+              ,ht_shad_bys, ht_shad_bye                                   &
+              ,nested, min_ptchsz                                         &
+              ,spec_bdy_width                                             &
+              ,ids, ide, jds, jde, kds, kde                               &
+              ,ims, ime, jms, jme, kms, kme                               &
+              ,ips, ipe, jps, jpe, kps, kpe                               &
+              ,i_start, i_end                                             &
+              ,j_start, j_end                                             &
+              ,kts, kte                                                   &
+              ,num_tiles                                                  )
+
+   USE module_domain  , ONLY : domain
+#ifdef DM_PARALLEL
+   USE module_dm        , ONLY : ntasks_x,ntasks_y,local_communicator,mytask,ntasks,wrf_dm_minval_integer
+# if (EM_CORE == 1)
+   USE module_comm_dm   , ONLY : halo_toposhad_sub
+# endif
+#endif
+   USE module_bc
+   USE module_model_constants
+
+   IMPLICIT NONE
+
+   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
+
+   TYPE(domain)                   , INTENT(INOUT)  :: grid
+   TYPE(grid_config_rec_type   ) ,   INTENT(IN   ) :: config_flags
+
+   INTEGER, INTENT(IN  ) :: itimestep, ra_call_offset, stepra,    &
+                            slope_rad, topo_shading,              &
+                            spec_bdy_width
+
+   INTEGER, INTENT(INOUT) :: min_ptchsz
+
+   INTEGER, DIMENSION(num_tiles), INTENT(IN) ::                   &
+                i_start,i_end,j_start,j_end
+
+   REAL, INTENT(IN  )   :: GMT, radt, julian, xtime, dx, dy, shadlen
+
+   REAL, DIMENSION( ims:ime, jms:jme ),                           &
+         INTENT(IN   )  ::                                  XLAT, &
+                                                           XLONG, &
+                                                              HT, &
+                                                            SINA, &
+                                                            COSA
+
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT)  ::  ht_shad,ht_loc
+
+   REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ),        &
+                      INTENT(IN   ) :: ht_shad_bxs, ht_shad_bxe
+   REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width ),        &
+                      INTENT(IN   ) :: ht_shad_bys, ht_shad_bye
+
+   INTEGER, DIMENSION( ims:ime, jms:jme ),                        &
+         INTENT(INOUT)  ::                            shadowmask
+
+   LOGICAL,      INTENT(IN   )    :: nested
+
+!Local
+! For orographic shading
+   INTEGER :: niter,ni,psx,psy,idum,jdum,i,j,ij
+   REAL :: DECLIN,SOLCON
+
+! Determine minimum patch size for slope-dependent radiation
+   if (itimestep .eq. 1) then
+     psx = ipe-ips+1
+     psy = jpe-jps+1
+     min_ptchsz = min(psx,psy)
+     idum = 0
+     jdum = 0
+   endif
+
+# ifdef DM_PARALLEL
+   if (itimestep .eq. 1) then
+     call wrf_dm_minval_integer (psx,idum,jdum)
+     call wrf_dm_minval_integer (psy,idum,jdum)
+     min_ptchsz = min(psx,psy)
+   endif
+# endif
+
+! Topographic shading
+   
+   if ((topo_shading.eq.1).and.(itimestep .eq. 1 .or. &
+        mod(itimestep,STEPRA) .eq. 1 + ra_call_offset))  then
+
+!---------------
+! Calculate constants for short wave radiation
+   
+   CALL radconst(XTIME,DECLIN,SOLCON,JULIAN,DEGRAD,DPD)
+   
+! Make a local copy of terrain height field
+     do j=jms,jme
+     do i=ims,ime
+       ht_loc(i,j) = ht(i,j)
+     enddo
+     enddo
+! Determine if iterations are necessary for shadows to propagate from one patch to another
+     if ((ids.eq.ips).and.(ide.eq.ipe).and.(jds.eq.jps).and.(jde.eq.jpe)) then
+       niter = 1
+     else
+       niter = int(shadlen/(dx*min_ptchsz)+3)
+     endif
+
+
+
+    IF( nested ) THEN
+
+      !$OMP PARALLEL DO   &
+      !$OMP PRIVATE ( ij )
+
+      DO ij = 1 , num_tiles
+
+           CALL spec_bdyfield(ht_shad,                         &
+                               ht_shad_bxs, ht_shad_bxe,       &
+                               ht_shad_bys, ht_shad_bye,       &
+                               'm', config_flags, spec_bdy_width, 2,&
+                               ids,ide, jds,jde, 1  ,1  ,  & ! domain dims
+                               ims,ime, jms,jme, 1  ,1  ,  & ! memory dims
+                               ips,ipe, jps,jpe, 1  ,1  ,  & ! patch  dims
+                               i_start(ij), i_end(ij),         &
+                               j_start(ij), j_end(ij),         &
+                               1    , 1             )
+      ENDDO
+    ENDIF
+
+     do ni = 1, niter
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij,i,j )
+         do ij = 1 , num_tiles
+
+         call toposhad_init (ht_shad,ht_loc,                         &
+                       shadowmask,nested,ni,                         &
+                       ids,ide, jds,jde, kds,kde,                    &
+                       ims,ime, jms,jme, kms,kme,                    &
+                       ips,min(ipe,ide-1), jps,min(jpe,jde-1), kps,kpe,      &
+                       i_start(ij),min(i_end(ij), ide-1),j_start(ij),&
+                       min(j_end(ij), jde-1), kts, kte               )
+
+         enddo
+   !$OMP END PARALLEL DO
+
+
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij,i,j )
+       do ij = 1 , num_tiles
+
+       call toposhad (xlat,xlong,sina,cosa,xtime,gmt,radt,declin,    &
+                       dx,dy,ht_shad,ht_loc,ni,                      &
+                       shadowmask,shadlen,                           &
+                       ids,ide, jds,jde, kds,kde,                    &
+                       ims,ime, jms,jme, kms,kme,                    &
+                       ips,min(ipe,ide-1), jps,min(jpe,jde-1), kps,kpe,        &
+                       i_start(ij),min(i_end(ij), ide-1),j_start(ij),&
+                       min(j_end(ij), jde-1), kts, kte               )
+
+       enddo
+   !$OMP END PARALLEL DO
+
+#if defined( DM_PARALLEL ) && (EM_CORE == 1)
+#     include "HALO_TOPOSHAD.inc"
+#endif
+     enddo
+   endif
+
+   END SUBROUTINE pre_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
+   
+   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
+!                                                              p_phy, &
+!                                                          F_ICE_PHY, &
+!                                                         F_RAIN_PHY
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                     &
+         OPTIONAL,                                                   &
+         INTENT(IN   ) ::                                            &
+                                                          F_ICE_PHY, &
+                                                         F_RAIN_PHY
+
+   LOGICAL,OPTIONAL,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 ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) ) THEN
+
+! mji - For MP options 2, 4, 6, 7, 8, etc. (qc = liquid, qi = ice, qs = snow)
+         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
+         ENDIF
+
+! mji - For MP options 1 and 3, (qc only)
+!  For MP=1, qc = liquid, for MP=3, qc = liquid or ice depending on temperature
+         IF ( F_QC .and. .not. F_QI .and. .not. F_QS ) THEN
+            QCLD = QC(i,k,j)
+            IF (QCLD .LT. QCLDMIN) THEN
+               weight = 0.
+            ELSE
+               if (t_phy(i,k,j) .gt. 273.15) weight = 0.
+               if (t_phy(i,k,j) .le. 273.15) weight = 1.
+            ENDIF
+         ENDIF
+
+! mji - For MP option 5; (qc = liquid, qs = ice)
+         IF ( F_QC .and. .not. F_QI .and. F_QS .and. PRESENT(F_ICE_PHY) ) 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 = QS(i,k,j)
+           QWMID = QC(i,k,j)
+! old method
+!           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
+         ENDIF
+
+      ELSE
+         CLDFRA(i,k,j)=0.
+
+      ENDIF !  IF ( F_QI .and. F_QC .and. F_QS)
+
+
+      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
+
+
+   SUBROUTINE toposhad_init(ht_shad,ht_loc,shadowmask,nested,iter,   &
+                       ids,ide, jds,jde, kds,kde,                    & 
+                       ims,ime, jms,jme, kms,kme,                    &
+                       ips,ipe, jps,jpe, kps,kpe,                    &
+                       its,ite, jts,jte, kts,kte                     )
+
+   USE module_model_constants
+
+ implicit none
+
+   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
+
+   LOGICAL, INTENT(IN)      :: nested
+
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT)  ::  ht_shad, ht_loc
+
+   INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT)  :: shadowmask
+   INTEGER, INTENT(IN)      :: iter
+
+! Local variables
+
+   INTEGER :: i, j
+
+ if (iter.eq.1) then
+
+! Initialize shadow mask
+   do j=jts,jte
+   do i=its,ite
+     shadowmask(i,j) = 0
+   ENDDO
+   ENDDO
+
+! Initialize shading height 
+
+   IF ( nested ) THEN  ! Do not overwrite input from parent domain
+     do j=max(jts,jds+2),min(jte,jde-3)
+     do i=max(its,ids+2),min(ite,ide-3)
+       ht_shad(i,j) = ht_loc(i,j)-0.001
+     ENDDO
+     ENDDO
+   ELSE
+     do j=jts,jte
+     do i=its,ite
+       ht_shad(i,j) = ht_loc(i,j)-0.001
+     ENDDO
+     ENDDO
+   ENDIF
+
+   IF ( nested ) THEN  ! Check if a shadow exceeding the topography height is available at the lateral domain edge from nesting
+     if (its.eq.ids) then
+       do j=jts,jte
+         if (ht_shad(its,j) .gt. ht_loc(its,j)) then
+           shadowmask(its,j) = 1
+           ht_loc(its,j) = ht_shad(its,j)
+         endif
+         if (ht_shad(its+1,j) .gt. ht_loc(its+1,j)) then
+           shadowmask(its+1,j) = 1
+           ht_loc(its+1,j) = ht_shad(its+1,j)
+         endif
+       enddo
+     endif
+     if (ite.eq.ide-1) then
+       do j=jts,jte
+         if (ht_shad(ite,j) .gt. ht_loc(ite,j)) then
+           shadowmask(ite,j) = 1
+           ht_loc(ite,j) = ht_shad(ite,j)
+         endif
+         if (ht_shad(ite-1,j) .gt. ht_loc(ite-1,j)) then
+           shadowmask(ite-1,j) = 1
+           ht_loc(ite-1,j) = ht_shad(ite-1,j)
+         endif
+       enddo
+     endif
+     if (jts.eq.jds) then
+       do i=its,ite
+         if (ht_shad(i,jts) .gt. ht_loc(i,jts)) then
+           shadowmask(i,jts) = 1
+           ht_loc(i,jts) = ht_shad(i,jts)
+         endif
+         if (ht_shad(i,jts+1) .gt. ht_loc(i,jts+1)) then
+           shadowmask(i,jts+1) = 1
+           ht_loc(i,jts+1) = ht_shad(i,jts+1)
+         endif
+       enddo
+     endif
+     if (jte.eq.jde-1) then
+       do i=its,ite
+         if (ht_shad(i,jte) .gt. ht_loc(i,jte)) then
+           shadowmask(i,jte) = 1
+           ht_loc(i,jte) = ht_shad(i,jte)
+         endif
+         if (ht_shad(i,jte-1) .gt. ht_loc(i,jte-1)) then
+           shadowmask(i,jte-1) = 1
+           ht_loc(i,jte-1) = ht_shad(i,jte-1)
+         endif
+       enddo
+     endif
+   ENDIF
+
+ else
+
+! Fill the local topography field at the points next to internal tile boundaries with ht_shad values
+! A 2-pt halo has been applied to the ht_shad before the repeated call of this subroutine
+
+   if ((its.ne.ids).and.(its.eq.ips)) then
+     do j=jts-2,jte+2
+       ht_loc(its-1,j) = max(ht_loc(its-1,j),ht_shad(its-1,j))
+       ht_loc(its-2,j) = max(ht_loc(its-2,j),ht_shad(its-2,j))
+     enddo
+   endif
+   if ((ite.ne.ide-1).and.(ite.eq.ipe)) then
+     do j=jts-2,jte+2
+       ht_loc(ite+1,j) = max(ht_loc(ite+1,j),ht_shad(ite+1,j))
+       ht_loc(ite+2,j) = max(ht_loc(ite+2,j),ht_shad(ite+2,j))
+     enddo
+   endif
+   if ((jts.ne.jds).and.(jts.eq.jps)) then
+     do i=its-2,ite+2
+       ht_loc(i,jts-1) = max(ht_loc(i,jts-1),ht_shad(i,jts-1))
+       ht_loc(i,jts-2) = max(ht_loc(i,jts-2),ht_shad(i,jts-2))
+     enddo
+   endif
+   if ((jte.ne.jde-1).and.(jte.eq.jpe)) then
+     do i=its-2,ite+2
+       ht_loc(i,jte+1) = max(ht_loc(i,jte+1),ht_shad(i,jte+1))
+       ht_loc(i,jte+2) = max(ht_loc(i,jte+2),ht_shad(i,jte+2))
+     enddo
+   endif
+
+ endif
+
+   END SUBROUTINE toposhad_init
+
+
+
+
+   SUBROUTINE toposhad(xlat,xlong,sina,cosa,xtime,gmt,radfrq,declin, &
+                       dx,dy,ht_shad,ht_loc,iter,                    &
+                       shadowmask,shadlen,                    &
+                       ids,ide, jds,jde, kds,kde,                    & 
+                       ims,ime, jms,jme, kms,kme,                    &
+                       ips,ipe, jps,jpe, kps,kpe,                    &
+                       its,ite, jts,jte, kts,kte                     )
+
+
+   USE module_model_constants
+
+ implicit none
+
+   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) ::      iter
+
+   REAL, INTENT(IN)      ::        RADFRQ,XTIME,DECLIN,dx,dy,gmt,shadlen
+
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN)  :: XLAT, XLONG, sina, cosa
+
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT)  ::  ht_shad,ht_loc
+
+   INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT)  :: shadowmask
+
+! Local variables
+
+   REAL :: pi, xt24, wgt, ri, rj, argu, sol_azi, topoelev, dxabs, tloctm, hrang, xxlat, csza
+   INTEGER :: gpshad, ii, jj, i1, i2, j1, j2, i, j
+
+
+
+ XT24=MOD(XTIME+RADFRQ*0.5,1440.)
+ pi = 4.*atan(1.)
+ gpshad = int(shadlen/dx+1.)
+
+ if (iter.eq.1) then  
+
+
+   j_loop1: DO J=jts,jte
+   i_loop1: DO I=its,ite
+
+     TLOCTM=GMT+XT24/60.+XLONG(i,j)/15.
+     HRANG=15.*(TLOCTM-12.)*DEGRAD
+     XXLAT=XLAT(i,j)*DEGRAD
+     CSZA=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG)
+
+     if (csza.lt.1.e-2) then   ! shadow mask does not need to be computed
+     shadowmask(i,j) = 0
+     ht_shad(i,j) = ht_loc(i,j)-0.001
+     goto 120
+     endif
+
+! Solar azimuth angle
+
+     argu=(csza*sin(XXLAT)-sin(DECLIN))/(sin(acos(csza))*cos(XXLAT))
+     if (argu.gt.1) argu = 1
+     if (argu.lt.-1) argu = -1
+     sol_azi = sign(acos(argu),sin(HRANG))+pi  ! azimuth angle of the sun
+     if (cosa(i,j).ge.0) then
+       sol_azi = sol_azi + asin(sina(i,j))  ! rotation towards WRF grid 
+     else
+       sol_azi = sol_azi + pi - asin(sina(i,j)) 
+     endif
+
+! Scan for higher surrounding topography
+
+          if ((sol_azi.gt.1.75*pi).or.(sol_azi.lt.0.25*pi)) then ! sun is in the northern quarter
+
+            do jj = j+1,j+gpshad
+              ri = i + (jj-j)*tan(sol_azi)
+              i1 = int(ri) 
+              i2 = i1+1
+              wgt = ri-i1
+              dxabs = sqrt((dy*(jj-j))**2+(dx*(ri-i))**2)
+              if ((jj.ge.jpe+1).or.(i1.le.ips-1).or.(i2.ge.ipe+1)) then
+                if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1
+                goto 120
+              endif
+              topoelev=atan((wgt*ht_loc(i2,jj)+(1.-wgt)*ht_loc(i1,jj)-ht_loc(i,j))/dxabs)
+              if (sin(topoelev).ge.csza) then
+                shadowmask(i,j) = 1
+                ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
+              endif
+            enddo
+
+          else if (sol_azi.lt.0.75*pi) then  ! sun is in the eastern quarter
+            do ii = i+1,i+gpshad
+              rj = j - (ii-i)*tan(pi/2.+sol_azi)
+              j1 = int(rj)
+              j2 = j1+1
+              wgt = rj-j1
+              dxabs = sqrt((dx*(ii-i))**2+(dy*(rj-j))**2)
+              if ((ii.ge.ipe+1).or.(j1.le.jps-1).or.(j2.ge.jpe+1)) then
+                if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1
+                goto 120
+              endif
+              topoelev=atan((wgt*ht_loc(ii,j2)+(1.-wgt)*ht_loc(ii,j1)-ht_loc(i,j))/dxabs)
+              if (sin(topoelev).ge.csza) then
+                shadowmask(i,j) = 1
+                ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
+              endif
+            enddo
+
+          else if (sol_azi.lt.1.25*pi) then ! sun is in the southern quarter
+            do jj = j-1,j-gpshad,-1
+              ri = i + (jj-j)*tan(sol_azi)
+              i1 = int(ri)
+              i2 = i1+1
+              wgt = ri-i1
+              dxabs = sqrt((dy*(jj-j))**2+(dx*(ri-i))**2)
+              if ((jj.le.jps-1).or.(i1.le.ips-1).or.(i2.ge.ipe+1)) then
+                if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1
+                goto 120
+              endif
+              topoelev=atan((wgt*ht_loc(i2,jj)+(1.-wgt)*ht_loc(i1,jj)-ht_loc(i,j))/dxabs)
+              if (sin(topoelev).ge.csza) then
+                shadowmask(i,j) = 1
+                ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
+              endif
+            enddo
+
+          else                          ! sun is in the western quarter
+            do ii = i-1,i-gpshad,-1
+              rj = j - (ii-i)*tan(pi/2.+sol_azi)
+              j1 = int(rj)
+              j2 = j1+1
+              wgt = rj-j1
+              dxabs = sqrt((dx*(ii-i))**2+(dy*(rj-j))**2)
+              if ((ii.le.ips-1).or.(j1.le.jps-1).or.(j2.ge.jpe+1)) then
+                if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1
+                goto 120
+              endif
+              topoelev=atan((wgt*ht_loc(ii,j2)+(1.-wgt)*ht_loc(ii,j1)-ht_loc(i,j))/dxabs)
+              if (sin(topoelev).ge.csza) then
+                shadowmask(i,j) = 1
+                ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
+              endif
+            enddo
+          endif
+
+ 120      continue
+
+   ENDDO i_loop1
+   ENDDO j_loop1
+
+ else   ! iteration > 1
+
+
+   j_loop2: DO J=jts,jte
+   i_loop2: DO I=its,ite
+
+!     if (shadowmask(i,j).eq.-1) then  ! this indicates that the search ended at a lateral boundary during iteration 1
+
+       TLOCTM=GMT+XT24/60.+XLONG(i,j)/15.
+       HRANG=15.*(TLOCTM-12.)*DEGRAD
+       XXLAT=XLAT(i,j)*DEGRAD
+       CSZA=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG)
+
+! Solar azimuth angle
+
+       argu=(csza*sin(XXLAT)-sin(DECLIN))/(sin(acos(csza))*cos(XXLAT))
+       if (argu.gt.1) argu = 1
+       if (argu.lt.-1) argu = -1
+       sol_azi = sign(acos(argu),sin(HRANG))+pi  ! azimuth angle of the sun
+       if (cosa(i,j).ge.0) then
+         sol_azi = sol_azi + asin(sina(i,j))  ! rotation towards WRF grid 
+       else
+         sol_azi = sol_azi + pi - asin(sina(i,j)) 
+       endif
+
+! Scan for higher surrounding topography
+
+          if ((sol_azi.gt.1.75*pi).or.(sol_azi.lt.0.25*pi)) then ! sun is in the northern quarter
+
+            do jj = j+1,j+gpshad
+              ri = i + (jj-j)*tan(sol_azi)
+              i1 = int(ri) 
+              i2 = i1+1
+              wgt = ri-i1
+              dxabs = sqrt((dy*(jj-j))**2+(dx*(ri-i))**2)
+              if ((jj.ge.min(jde,jpe+3)).or.(i1.le.max(ids-1,ips-3)).or.(i2.ge.min(ide,ipe+3))) goto 220
+              topoelev=atan((wgt*ht_loc(i2,jj)+(1.-wgt)*ht_loc(i1,jj)-ht_loc(i,j))/dxabs)
+              if (sin(topoelev).ge.csza) then
+                shadowmask(i,j) = 1
+                ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
+              endif
+            enddo
+
+          else if (sol_azi.lt.0.75*pi) then  ! sun is in the eastern quarter
+            do ii = i+1,i+gpshad
+              rj = j - (ii-i)*tan(pi/2.+sol_azi)
+              j1 = int(rj)
+              j2 = j1+1
+              wgt = rj-j1
+              dxabs = sqrt((dx*(ii-i))**2+(dy*(rj-j))**2)
+              if ((ii.ge.min(ide,ipe+3)).or.(j1.le.max(jds-1,jps-3)).or.(j2.ge.min(jde,jpe+3))) goto 220
+              topoelev=atan((wgt*ht_loc(ii,j2)+(1.-wgt)*ht_loc(ii,j1)-ht_loc(i,j))/dxabs)
+              if (sin(topoelev).ge.csza) then
+                shadowmask(i,j) = 1
+                ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
+              endif
+            enddo
+
+          else if (sol_azi.lt.1.25*pi) then ! sun is in the southern quarter
+            do jj = j-1,j-gpshad,-1
+              ri = i + (jj-j)*tan(sol_azi)
+              i1 = int(ri)
+              i2 = i1+1
+              wgt = ri-i1
+              dxabs = sqrt((dy*(jj-j))**2+(dx*(ri-i))**2)
+              if ((jj.le.max(jds-1,jps-3)).or.(i1.le.max(ids-1,ips-3)).or.(i2.ge.min(ide,ipe+3))) goto 220
+              topoelev=atan((wgt*ht_loc(i2,jj)+(1.-wgt)*ht_loc(i1,jj)-ht_loc(i,j))/dxabs)
+              if (sin(topoelev).ge.csza) then
+                shadowmask(i,j) = 1
+                ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
+              endif
+            enddo
+
+          else                          ! sun is in the western quarter
+            do ii = i-1,i-gpshad,-1
+              rj = j - (ii-i)*tan(pi/2.+sol_azi)
+              j1 = int(rj)
+              j2 = j1+1
+              wgt = rj-j1
+              dxabs = sqrt((dx*(ii-i))**2+(dy*(rj-j))**2)
+              if ((ii.le.max(ids-1,ips-3)).or.(j1.le.max(jds-1,jps-3)).or.(j2.ge.min(jde,jpe+3))) goto 220
+              topoelev=atan((wgt*ht_loc(ii,j2)+(1.-wgt)*ht_loc(ii,j1)-ht_loc(i,j))/dxabs)
+              if (sin(topoelev).ge.csza) then
+                shadowmask(i,j) = 1
+                ht_shad(i,j) = max(ht_shad(i,j),ht_loc(i,j)+dxabs*(tan(topoelev)-tan(asin(csza))))
+              endif
+            enddo
+          endif
+
+ 220      continue
+!     endif
+
+   ENDDO i_loop2
+   ENDDO j_loop2
+
+ endif ! iteration
+
+   END SUBROUTINE toposhad
+
+END MODULE module_radiation_driver
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_bem.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_bem.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_bem.F	(revision 17)
@@ -0,0 +1,2345 @@
+MODULE module_sf_bem
+! -----------------------------------------------------------------------
+!  Variables and constants used in the BEM module
+! -----------------------------------------------------------------------
+         
+        real emins		!emissivity of the internal walls
+        parameter (emins=0.9) 
+        real albins	        !albedo of the internal walls
+!!      parameter (albins=0.5)
+        parameter (albins=0.3)
+
+        real thickwin           !thickness of the window [m] 
+        parameter (thickwin=0.006)
+        real cswin		!Specific heat of the windows [J/(m3.K)]
+        parameter(cswin= 2.268e+06)
+
+        real temp_rat            !power of the A.C. heating/cooling the indoor air [K/s]
+        parameter(temp_rat=0.001)
+
+        real hum_rat            !power of the A.C. drying/moistening the indoor air [(Kg/kg)/s]
+        parameter(hum_rat=1.e-06)
+
+
+    CONTAINS
+
+!====6================================================================72
+!====6================================================================72	
+	
+	subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev,            &
+                       nwal,nflo,nrof,ngrd,hswalout,gswal,             &
+                       hswinout,hsrof,gsrof,                           &
+                       latent,sigma,albwal,albwin,albrof,              &
+     		       emrof,emwal,emwin,rswal,rlwal,rair,cp,          &
+     		       rhoout,tout,humout,press,                       &
+     		       rs,rl,dzwal,cswal,kwal,pwin,cop,beta,sw_cond,   &
+                       timeon,timeoff,targtemp,gaptemp,targhum,gaphum, &
+                       perflo,hsesf,hsequip,dzflo,                     &
+     		       csflo,kflo,dzgrd,csgrd,kgrd,dzrof,csrof,        &
+     		       krof,tlev,shumlev,twal,twin,tflo,tgrd,trof,     &
+     		       hsout,hlout,consump,hsvent,hlvent)
+
+
+! ---------------------------------------------------------------------
+	implicit none
+	
+! ---------------------------------------------------------------------	
+!		       TOP
+!	      ---------------------	
+!	      !	----------------- !--->roof	(-) : level number	
+!	      !	!		! !		rem: the windows are given 
+!	      !	!---------------! !                  with respect to the 
+!	      !	!---------------! !                  vertical walls-->win(2) 
+!	   (n)! !(1)	     (1)!-!(n)
+!	      !	!---------------! !		2D vision of the building
+!   WEST      ! !-------4-------! !	EAST
+!	    I ! ! 1    ilev    2! ! II               ^
+!	      !	!-------3--------! !		     !  	
+!	      ! !---------------! !--->floor 1	     ! 				
+!	      !	!		! !                  !
+!	      ! !		! !                  !
+!	      !	----------------- !          <--------------(n)  	
+!	      ------------------------>ground	------------(1)
+!		     BOTTOM
+!				i(6)			
+!			        i
+!                     +---------v-----+ 
+!                    /|              /|    3D vision of a room	
+!                   / | 4           / |		
+!                  /  |            /  |
+!                 /   |           /   |
+!                /    |          /    |
+!               +---------------+     |
+!               |  1   |        |  2  |
+!               |     +---------|-----+
+!       dzlev   |    /          |    /
+!               |   /    3      |   /
+!               |  /bw          |  /
+!               | /             | /  
+!               |/              |/
+!               +---------------+
+!                     ^ bl
+!		      i          
+!                     i
+!		     (5)	
+!-----------------------------------------------------------------------
+
+
+! Input:
+! -----	
+
+	real dt				!time step [s]
+                                       
+        integer nzcanm                  !Maximum number of vertical levels in the urban grid
+	integer nlev			!number of floors in the building
+	integer nwal                    !number of levels inside the wall
+	integer nrof                    !number of levels inside the roof
+	integer nflo                    !number of levels inside the floor
+	integer ngrd                    !number of levels inside the ground
+	real dzlev			!vertical grid resolution [m]			
+	real bl				!Building length [m]
+	real bw                         !Building width [m]
+	
+	real albwal			!albedo of the walls 				
+	real albwin		 	!albedo of the windows
+	real albrof			!albedo of the roof
+	
+	real emwal 	          	!emissivity of the walls
+	
+	real emrof			!emissivity of the roof
+        real emwin                      !emissivity of the windows
+
+	real pwin                       !window proportion
+	real,    intent(in) :: cop      !Coefficient of performance of the A/C systems
+	real,    intent(in) :: beta     !Thermal efficiency of the heat exchanger
+        integer, intent(in) :: sw_cond  ! Air Conditioning switch
+        real,    intent(in) :: timeon   ! Initial local time of A/C systems
+        real,    intent(in) :: timeoff  ! Ending local time of A/C systems
+        real,    intent(in) :: targtemp ! Target temperature of A/C systems
+        real,    intent(in) :: gaptemp  ! Comfort range of indoor temperature
+        real,    intent(in) :: targhum  ! Target humidity of A/C systems
+        real,    intent(in) :: gaphum   ! Comfort range of specific humidity
+        real,    intent(in) :: perflo   ! Peak number of occupants per unit floor area
+        real,    intent(in) :: hsesf    ! 
+        real,    intent(in) :: hsequip(24) ! 
+	
+	real cswal(nwal)		!Specific heat of the wall [J/(m3.K)] 
+	
+	real csflo(nflo)		!Specific heat of the floor [J/(m3.K)]
+	real csrof(nrof)		!Specific heat of the roof [J/(m3.K)] 
+	real csgrd(ngrd)		!Specific heat of the ground [J/(m3.K)]
+	
+	real kwal(nwal+1)		!Thermal conductivity in each layers of the walls (face) [W/(m.K)]
+	real kflo(nflo+1)		!Thermal diffusivity in each layers of the floors (face) [W/(m.K)]
+	real krof(nrof+1)		!Thermal diffusivity in each layers of the roof (face) [W/(m.K)]
+	real kgrd(ngrd+1)		!Thermal diffusivity in each layers of the ground (face) [W/(m.K)]
+	
+	real dzwal(nwal)		!Layer sizes of walls [m]
+	real dzflo(nflo)		!Layer sizes of floors [m]
+	real dzrof(nrof)		!Layer sizes of roof [m]
+	real dzgrd(ngrd)		!Layer sizes of ground [m]
+	
+	real latent                      !latent heat of evaporation [J/Kg]	
+
+
+	real rs				!external short wave radiation [W/m2]
+	real rl				!external long wave radiation [W/m2]
+	real rswal(4,nzcanm)		!short wave radiation reaching the exterior walls [W/m2]
+        real rlwal(4,nzcanm)		!long wave radiation reaching the walls [W/m2]	
+	real rhoout(nzcanm)		!exterior air density [kg/m3]
+	real tout(nzcanm)		!external temperature [K]
+	real humout(nzcanm)		!absolute humidity [Kgwater/Kgair]
+	real press(nzcanm)		!external air pressure [Pa]
+	
+	real hswalout(4,nzcanm)	        !outside walls sensible heat flux [W/m2]
+	real hswinout(4,nzcanm)	        !outside window sensible heat flux [W/m2]
+	real hsrof			!Sensible heat flux at the roof [W/m2]
+	
+	real rair			!ideal gas constant  [J.kg-1.K-1]
+	real sigma			!parameter (wall is not black body) [W/m2.K4]
+	real cp				!specific heat of air [J/kg.K]
+       
+	
+!Input-Output
+!------------
+	real tlev(nzcanm)		!temperature of the floors [K] 
+	real shumlev(nzcanm)		!specific humidity of the floor [kg/kg]
+	real twal(4,nwal,nzcanm)	!walls temperatures [K]
+	real twin(4,nzcanm)		!windows temperatures [K]	
+	real tflo(nflo,nzcanm-1)	!floor temperatures [K]
+	real tgrd(ngrd)		        !ground temperature [K]
+	real trof(nrof)		        !roof temperature [K]
+	real hsout(nzcanm)		!sensible heat emitted outside the floor [W]
+	real hlout(nzcanm)		!latent heat emitted outside the floor [W]
+        real consump(nzcanm)            !Consumption for the a.c. in each floor [W]
+	real hsvent(nzcanm)		!sensible heat generated by natural ventilation [W]
+	real hlvent(nzcanm)		!latent heat generated by natural ventilation [W] 
+        real gsrof                      !heat flux flowing inside the roof [W/m²]
+        real gswal(4,nzcanm)             !heat flux flowing inside the floors [W/m²]
+
+! Local:
+! -----
+	integer swwal                   !swich for the physical coefficients calculation
+	integer ilev			!index for rooms	
+	integer iwal			!index for walls
+	integer iflo			!index for floors
+	integer ivw			!index for vertical walls
+        integer igrd                    !index for ground
+        integer irof                    !index for roof 
+        real hseqocc(nzcanm)		!sensible heat generated by equipments and occupants [W]
+	real hleqocc(nzcanm)		!latent heat generated by occupants [W]
+        real hscond(nzcanm)		!sensible heat generated by wall conduction [W]
+        real hslev(nzcanm)		!sensible heat flux generated inside the room [W]
+        real hllev(nzcanm)		!latent heat flux generatd inside the room [W]
+	real surwal(6,nzcanm)	        !Surface of the walls [m2]
+	real surwal1D(6)	        !wall surfaces of a generic room [m2]
+	real rsint(6)		        !short wave radiation reaching the indoor walls[W/m2]
+	real rswalins(6,nzcanm)	        !internal short wave radiation for the building [W/m2]
+	real twin1D(4)		        !temperature of windows for a particular room [K]
+	real twal_int(6)		!temperature of the first internal layers of a room [K]
+	real rlint(6)		        !internal wall long wave radiation [w/m2]
+	real rlwalins(6,nzcanm)	        !internal long wave radiation for the building [W/m2]	
+	real hrwalout(4,nzcanm)	        !external radiative flux to the walls [W/m2]
+	real hrwalins(6,nzcanm)	        !inside radiative flux to the walls [W/m2] 
+	real hrwinout(4,nzcanm)	        !external radiative flux to the window [W/m2]
+	real hrwinins(4,nzcanm)	        !inside radiative flux to the window [W/m2] 
+	real hrrof			!external radiative flux to the roof [W/m2]
+	real hs
+        real hsneed(nzcanm)		!sensible heat needed by the room [W]
+	real hlneed(nzcanm)		!latent heat needed by the room [W]	
+        real hswalins(6,nzcanm)	        !inside walls sensible heat flux [W/m2]
+	real hswalins1D(6)
+	real hswinins(4,nzcanm)	        !inside window sensible heat flux [W/m2]
+	real hswinins1D(4)	
+	real htot(2)			!total heat flux at the wall [W/m2]
+	real twal1D(nwal)
+	real tflo1D(nflo)	
+        real tgrd1D(ngrd)
+        real trof1D(nrof)
+	real rswal1D(4)
+	real Qb				!Overall heat capacity of the indoor air [J/K]
+	real vollev			!volume of the room [m3]
+	real rhoint			!density of the internal air [Kg/m3]
+	real cpint			!specific heat of the internal air [J/kg.K]
+        real humdry                     !specific humidiy of dry air [kg water/kg dry air]
+	real radflux                    !Function to compute the total radiation budget
+	real consumpbuild               !Energetic consumption for the entire building [KWh/s]
+        real hsoutbuild                 !Total sensible heat ejected into the atmosphere[W]
+                                        !by the air conditioning system and per building
+        real nhourday                   !number of hours from midnight, local time
+!--------------------------------------------
+!Initialization
+!--------------------------------------------
+
+       do ilev=1,nzcanm
+          hseqocc(ilev)=0.
+          hleqocc(ilev)=0.
+          hscond(ilev)=0.
+          hslev(ilev)=0.
+          hllev(ilev)=0.
+       enddo	
+
+!Calculation of the surfaces of the building 
+!--------------------------------------------
+	
+       
+	do ivw=1,6
+	do ilev=1,nzcanm
+	 surwal(ivw,ilev)=1.   !initialisation
+	end do
+	end do
+
+	do ilev=1,nlev
+	  do ivw=1,2
+	   surwal(ivw,ilev)=dzlev*bw
+	  end do
+	  do ivw=3,4
+	   surwal(ivw,ilev)=dzlev*bl
+	  end do
+	  do ivw=5,6 		
+	   surwal(ivw,ilev)=bw*bl
+	  end do 
+	end do
+
+
+! Calculation of the short wave radiations at the internal walls
+! ---------------------------------------------------------------
+	
+
+	do ilev=1,nlev	
+	  
+	  do ivw=1,4
+	    rswal1D(ivw)=rswal(ivw,ilev)
+	  end do	
+
+	  do ivw=1,6
+	    surwal1D(ivw)=surwal(ivw,ilev)
+	  end do 		
+	
+	  call int_rsrad(albwin,albins,pwin,rswal1D,&
+                         surwal1D,bw,bl,dzlev,rsint)
+
+	  do ivw=1,6
+	    rswalins(ivw,ilev)=rsint(ivw)
+	  end do
+          
+	end do !ilev
+	
+	 
+
+! Calculation of the long wave radiation at the internal walls
+!-------------------------------------------------------------
+
+
+!Intermediate rooms
+       
+       if (nlev.gt.2) then
+	do ilev=2,nlev-1
+
+	  do ivw=1,4
+	    twin1D(ivw)=twin(ivw,ilev)
+	    twal_int(ivw)=twal(ivw,1,ilev)
+	  end do
+	    
+	   twal_int(5)=tflo(nflo,ilev-1)
+	   twal_int(6)=tflo(1,ilev)		
+		 
+	   call int_rlrad(emins,emwin,sigma,twal_int,twin1D,&
+     			  pwin,bw,bl,dzlev,rlint)
+	  
+	  
+	  do ivw=1,6
+	    rlwalins(ivw,ilev)=rlint(ivw)
+	  end do
+	    
+	end do	!ilev 
+      end if	 
+	
+
+      if (nlev.ne.1) then  
+
+!bottom room
+
+	  do ivw=1,4
+	    twin1D(ivw)=twin(ivw,1)
+	    twal_int(ivw)=twal(ivw,1,1)
+	  end do
+	  
+	  twal_int(5)=tgrd(ngrd)
+	  twal_int(6)=tflo(1,1)		
+	  
+	  						  	   
+	   call int_rlrad(emins,emwin,sigma,twal_int,twin1D,&
+     			  pwin,bw,bl,dzlev,rlint)
+	  
+	  do ivw=1,6
+	    rlwalins(ivw,1)=rlint(ivw)
+	  end do	  
+            
+!top room
+	 
+	  do ivw=1,4
+	    twin1D(ivw)=twin(ivw,nlev)
+	    twal_int(ivw)=twal(ivw,1,nlev)
+	  end do
+	  
+	  twal_int(5)=tflo(nflo,nlev-1)
+	  twal_int(6)=trof(1)		
+	  
+					
+	   call int_rlrad(emins,emwin,sigma,twal_int,twin1D,&
+     			  pwin,bw,bl,dzlev,rlint)
+	  
+	  do ivw=1,6
+	    rlwalins(ivw,nlev)=rlint(ivw)
+	  end do
+	  
+      else   !Top <---> Bottom
+	  
+	  do ivw=1,4
+	    twin1D(ivw)=twin(ivw,1)
+	    twal_int(ivw)=twal(ivw,1,1)
+	  end do
+	  
+	  twal_int(5)=tgrd(ngrd)      
+      	  twal_int(6)=trof(1)
+	  
+	  call int_rlrad(emins,emwin,sigma,twal_int,twin1D, &
+     			 pwin,bw,bl,dzlev,rlint)
+     	  
+	  do ivw=1,6
+	    rlwalins(ivw,1)=rlint(ivw)
+	  end do
+	
+      end if  
+	
+
+! Calculation of the radiative fluxes
+! -----------------------------------
+
+!External vertical walls and windows
+
+        do ilev=1,nlev
+	 do ivw=1,4	 
+	 call radfluxs(radflux,albwal,rswal(ivw,ilev),     &
+     	                    emwal,rlwal(ivw,ilev),sigma,   &
+                            twal(ivw,nwal,ilev))
+	
+         hrwalout(ivw,ilev)=radflux
+      	 						
+	 hrwinout(ivw,ilev)=emwin*rlwal(ivw,ilev)- &
+     	                    emwin*sigma*(twin(ivw,ilev)**4)
+	 
+	 
+	 end do ! ivw
+	end do  ! ilev
+	
+!Roof
+
+        call radfluxs(radflux,albrof,rs,emrof,rl,sigma,trof(nrof))
+
+        hrrof=radflux
+
+!Internal walls for intermediate rooms
+
+      if(nlev.gt.2) then
+       
+	do ilev=2,nlev-1
+	 do ivw=1,4
+         
+	 call radfluxs(radflux,albins,rswalins(ivw,ilev),     &
+     	                    emins,rlwalins(ivw,ilev),sigma,   &
+                            twal(ivw,1,ilev))
+	 
+	 hrwalins(ivw,ilev)=radflux
+
+	 end do !ivw						
+
+	 call radfluxs(radflux,albins,rswalins(5,ilev), &
+     	                      emins,rlwalins(5,ilev),sigma,&
+                              tflo(nflo,ilev-1))
+
+         hrwalins(5,ilev)=radflux
+
+         call radfluxs(radflux,albins,rswalins(6,ilev), &
+                              emins,rlwalins(6,ilev),sigma,&
+                              tflo(1,ilev))
+         hrwalins(6,ilev)=radflux
+
+       end do !ilev
+
+      end if 	
+
+
+!Internal walls for the bottom and the top room	 
+!
+      if (nlev.ne.1) then 
+
+!bottom floor
+
+	 do ivw=1,4
+
+	    call radfluxs(radflux,albins,rswalins(ivw,1),  &
+     	                    emins,rlwalins(ivw,1),sigma,   &
+                            twal(ivw,1,1))
+	
+            hrwalins(ivw,1)=radflux
+
+	 end do
+	
+	
+	  call radfluxs(radflux,albins,rswalins(5,1),&
+                           emins,rlwalins(5,1),sigma,&    !bottom
+                           tgrd(ngrd))
+
+          hrwalins(5,1)=radflux
+
+	   
+          call radfluxs(radflux,albins,rswalins(6,1),&
+     	                   emins,rlwalins(6,1),sigma,&
+                           tflo(1,1))  
+	 
+          hrwalins(6,1)=radflux
+
+!roof floor
+
+         do ivw=1,4
+   
+          call radfluxs(radflux,albins,rswalins(ivw,nlev),     &
+     	                        emins,rlwalins(ivw,nlev),sigma,&
+                                twal(ivw,1,nlev))
+
+	  hrwalins(ivw,nlev)=radflux
+
+	 end do                                          !top
+
+	
+         call radfluxs(radflux,albins,rswalins(5,nlev),    &
+     	                      emins,rlwalins(5,nlev),sigma,&
+                              tflo(nflo,nlev-1))
+
+         hrwalins(5,nlev)=radflux
+
+	 call radfluxs(radflux,albins,rswalins(6,nlev), &
+                              emins,rlwalins(6,nlev),sigma,&
+                              trof(1))
+
+         hrwalins(6,nlev)=radflux
+      
+      else       ! Top <---> Bottom room
+      
+	 do ivw=1,4
+
+	    call radfluxs(radflux,albins,rswalins(ivw,1),&
+     	                    emins,rlwalins(ivw,1),sigma, &
+                            twal(ivw,1,1))
+
+            hrwalins(ivw,1)=radflux
+
+         end do
+     
+     	    call radfluxs(radflux,albins,rswalins(5,1),&
+                           emins,rlwalins(5,1),sigma,  &
+                           tgrd(ngrd))
+
+            hrwalins(5,1)=radflux
+     
+     	    call radfluxs(radflux,albins,rswalins(6,nlev),     &
+                                  emins,rlwalins(6,nlev),sigma,&
+                                  trof(1))
+            hrwalins(6,1)=radflux
+
+      end if
+      
+		
+!Windows
+
+	 do ilev=1,nlev
+	  do ivw=1,4
+	     hrwinins(ivw,ilev)=emwin*rlwalins(ivw,ilev)-    &
+                                emwin*sigma*(twin(ivw,ilev)**4)
+	  end do
+	 end do
+	
+		
+! Calculation of the sensible heat fluxes
+! ---------------------------------------
+
+!Vertical fluxes for walls
+	
+	do ilev=1,nlev
+         do ivw=1,4
+		
+               call hsinsflux (2,2,tlev(ilev),twal(ivw,1,ilev),hs)		
+	       
+               hswalins(ivw,ilev)=hs 
+         
+         end do ! ivw     
+        end do ! ilev
+       
+      
+!Vertical fluxes for windows
+
+	do ilev=1,nlev
+
+         do ivw=1,4
+	 
+	       call hsinsflux (2,1,tlev(ilev),twin(ivw,ilev),hs)
+	       
+               hswinins(ivw,ilev)=hs 
+			
+         end do ! ivw	
+	
+	end do !ilev      
+
+!Horizontal fluxes
+       
+      if (nlev.gt.2) then
+       
+        do ilev=2,nlev-1
+                
+	       call hsinsflux (1,2,tlev(ilev),tflo(nflo,ilev-1),hs)
+
+	       hswalins(5,ilev)=hs
+            
+	       call hsinsflux (1,2,tlev(ilev),tflo(1,ilev),hs)
+
+	       hswalins(6,ilev)=hs
+
+        end do ! ilev
+       
+      end if
+       
+      if (nlev.ne.1) then
+       
+       	        call hsinsflux (1,2,tlev(1),tgrd(ngrd),hs)
+
+		hswalins(5,1)=hs				!Bottom room
+		
+		call hsinsflux (1,2,tlev(1),tflo(1,1),hs)
+
+		hswalins(6,1)=hs				
+	 
+       	        call hsinsflux (1,2,tlev(nlev),tflo(nflo,nlev-1),hs)
+
+		hswalins(5,nlev)=hs			        !Top room
+
+		call hsinsflux (1,2,tlev(nlev),trof(1),hs)
+
+		hswalins(6,nlev)=hs	       
+      
+      else  ! Bottom<--->Top 
+      
+                call hsinsflux (1,2,tlev(1),tgrd(ngrd),hs)
+		
+		hswalins(5,1)=hs
+		
+		call hsinsflux (1,2,tlev(nlev),trof(1),hs)
+		
+		hswalins(6,nlev)=hs
+      
+      end if
+
+
+!Calculation of the temperature for the different surfaces 
+! --------------------------------------------------------
+
+! Vertical walls	
+        
+       swwal=1
+       do ilev=1,nlev
+        do ivw=1,4  
+
+	   htot(1)=hswalins(ivw,ilev)+hrwalins(ivw,ilev)	
+           htot(2)=hswalout(ivw,ilev)+hrwalout(ivw,ilev)
+           gswal(ivw,ilev)=htot(2)
+
+	   do iwal=1,nwal
+	      twal1D(iwal)=twal(ivw,iwal,ilev)
+	   end do
+	  
+	   call wall(swwal,nwal,dt,dzwal,kwal,cswal,htot,twal1D)
+	
+	   do iwal=1,nwal
+	      twal(ivw,iwal,ilev)=twal1D(iwal)
+	   end do
+           
+	end do ! ivw
+       end do ! ilev
+       
+! Windows
+
+       do ilev=1,nlev
+        do ivw=1,4
+       
+         htot(1)=hswinins(ivw,ilev)+hrwinins(ivw,ilev)	
+         htot(2)=hswinout(ivw,ilev)+hrwinout(ivw,ilev)	
+
+         twin(ivw,ilev)=twin(ivw,ilev)+(dt/(cswin*thickwin))* &
+                        (htot(1)+htot(2))
+	
+	end do ! ivw
+       end do ! ilev   
+
+! Horizontal floors
+
+
+      if (nlev.gt.1) then
+       swwal=1
+       do ilev=1,nlev-1
+ 
+          htot(1)=hrwalins(6,ilev)+hswalins(6,ilev)
+          htot(2)=hrwalins(5,ilev+1)+hswalins(5,ilev+1)	
+
+	  do iflo=1,nflo
+	     tflo1D(iflo)=tflo(iflo,ilev)
+	  end do
+        
+	  call wall(swwal,nflo,dt,dzflo,kflo,csflo,htot,tflo1D)
+	
+	 do iflo=1,nflo
+	    tflo(iflo,ilev)=tflo1D(iflo)
+	 end do
+
+       end do ! ilev
+      end if 
+        
+
+! Ground 	
+        
+	swwal=1
+
+	htot(1)=0.	!Diriclet b.c. at the internal boundary    
+	htot(2)=hswalins(5,1)+hrwalins(5,1)   
+   
+        do igrd=1,ngrd
+           tgrd1D(igrd)=tgrd(igrd)
+        end do
+
+         call wall(swwal,ngrd,dt,dzgrd,kgrd,csgrd,htot,tgrd1D)
+
+        do igrd=1,ngrd
+           tgrd(igrd)=tgrd1D(igrd)
+        end do
+
+        
+! Roof
+        
+      swwal=1    
+
+      htot(1)=hswalins(6,nlev)+hrwalins(6,nlev)     	
+      htot(2)=hsrof+hrrof     
+      gsrof=htot(2)
+
+      do irof=1,nrof
+         trof1D(irof)=trof(irof)
+      end do     
+      
+      call wall(swwal,nrof,dt,dzrof,krof,csrof,htot,trof1D)
+ 
+      do irof=1,nrof
+         trof(irof)=trof1D(irof)
+      end do
+      
+! Calculation of the heat fluxes and of the temperature of the rooms
+! ------------------------------------------------------------------
+
+ 	do ilev=1,nlev
+	  	  
+	 !Calculation of the heat generated by equipments and occupants
+	 
+	 call fluxeqocc(nhourday,bw,bl,perflo,hsesf,hsequip,hseqocc(ilev),hleqocc(ilev))
+
+     	 !Calculation of the heat generated by natural ventilation
+	
+	  vollev=bw*bl*dzlev
+          humdry=shumlev(ilev)/(1.-shumlev(ilev))
+	  rhoint=(press(ilev))/(rair*(1.+0.61*humdry)*tlev(ilev))
+	  cpint=cp*(1.+0.84*humdry)
+          
+ 	  
+	  call fluxvent(cpint,rhoint,vollev,tlev(ilev),tout(ilev),     &
+                        latent,humout(ilev),rhoout(ilev),shumlev(ilev),&
+                        beta,hsvent(ilev),hlvent(ilev))
+	      
+         !Calculation of the heat generated by conduction
+	  
+	   do iwal=1,6
+	     hswalins1D(iwal)=hswalins(iwal,ilev)
+	     surwal1D(iwal)=surwal(iwal,ilev)
+	  end do
+	  
+	   do iwal=1,4
+	     hswinins1D(iwal)=hswinins(iwal,ilev)
+	   end do
+	
+	  call fluxcond(hswalins1D,hswinins1D,surwal1D,pwin,&
+                        hscond(ilev))
+
+	!Calculation of the heat generated inside the room
+ 	
+	  call fluxroo(hseqocc(ilev),hleqocc(ilev),hsvent(ilev), &
+               hlvent(ilev),hscond(ilev),hslev(ilev),hllev(ilev))
+
+	  
+	!Evolution of the temperature and of the specific humidity 
+
+	  Qb=rhoint*cpint*vollev
+
+        ! temperature regulation
+
+          call regtemp(sw_cond,nhourday,dt,Qb,hslev(ilev),       &
+                       tlev(ilev),timeon,timeoff,targtemp,gaptemp,hsneed(ilev))
+
+        ! humidity regulation 
+
+	  call reghum(sw_cond,nhourday,dt,vollev,rhoint,latent, &
+                      hllev(ilev),shumlev(ilev),timeon,timeoff,&
+                      targhum,gaphum,hlneed(ilev))
+!
+!performance of the air conditioning system for the test
+!	
+	        
+          call air_cond(hsneed(ilev),hlneed(ilev),dt, &
+                        hsout(ilev),hlout(ilev),consump(ilev), cop)
+    	         	
+ 	  tlev(ilev)=tlev(ilev)+(dt/Qb)*(hslev(ilev)-hsneed(ilev))
+          	  	  
+	  shumlev(ilev)=shumlev(ilev)+(dt/(vollev*rhoint*latent))* &
+                        (hllev(ilev)-hlneed(ilev))
+           
+	end do !ilev
+        
+        call consump_total(nzcanm,nlev,consumpbuild,hsoutbuild, &
+                           hsout,consump)
+                
+      return
+      end subroutine BEM
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+	subroutine wall(swwall,nz,dt,dz,k,cs,flux,temp)
+	
+!______________________________________________________________________
+
+!The aim of this subroutine is to solve the 1D heat fiffusion equation
+!for roof, walls and streets:
+!
+!	dT/dt=d/dz[K*dT/dz] where:
+!
+!	-T is the surface temperature(wall, street, roof)
+!      	-Kz is the heat diffusivity inside the material.
+!
+!The resolution is done implicitly with a FV discretisation along the
+!different layers of the material:
+
+!	____________________________
+!     n             *
+!                   *
+!                   *
+!     	____________________________
+!    i+2
+!              	    I+1                 
+!	____________________________        
+!    i+1        
+!                    I                ==>   [T(I,n+1)-T(I,n)]/DT= 
+!	____________________________        [F(i+1)-F(i)]/DZI
+!    i
+!                   I-1               ==> A*T(n+1)=B where:
+!	____________________________         
+!   i-1              *                   * A is a TRIDIAGONAL matrix.
+!                    *                   * B=T(n)+S takes into account the sources.
+!                    *
+!     1	____________________________
+
+!________________________________________________________________
+
+	implicit none
+		
+!Input:
+!-----
+	integer nz		!Number of layers inside the material
+	real dt			!Time step
+	real dz(nz)		!Layer sizes [m]
+	real cs(nz)		!Specific heat of the material [J/(m3.K)] 
+	real k(nz+1)		!Thermal conductivity in each layers (face) [W/(m.K)]
+	real flux(2)		!Internal and external flux terms.
+
+!Input-Output:
+!-------------
+
+	integer swwall          !swich for the physical coefficients calculation
+	real temp(nz)		!Temperature at each layer
+
+!Local:
+!-----	
+
+      real a(-1:1,nz)          !  a(-1,*) lower diagonal      A(i,i-1)
+                               !  a(0,*)  principal diagonal  A(i,i)
+                               !  a(1,*)  upper diagonal      A(i,i+1).
+      
+      real b(nz)	       !Coefficients of the second term.	
+      real k1(20)
+      real k2(20)
+      real kc(20)
+      save k1,k2,kc
+      integer iz
+        	
+!________________________________________________________________
+!
+!Calculation of the coefficients
+	
+	if (swwall.eq.1) then
+	
+           if (nz.gt.20) then
+              write(*,*) 'number of layers in the walls/roofs too big ',nz
+              write(*,*) 'please decrease under of',20
+              stop
+           endif
+
+	   call wall_coeff(nz,dt,dz,cs,k,k1,k2,kc)
+	   swwall=0
+
+	end if
+ 	
+!Computation of the first value (iz=1) of A and B:
+	
+		 a(-1,1)=0.
+		 a(0,1)=1+k2(1)
+		 a(1,1)=-k2(1)
+
+                 b(1)=temp(1)+flux(1)*kc(1)
+
+!!
+!!We can fixed the internal temperature	
+!!
+!!		 a(-1,1)=0.
+!!		 a(0,1)=1
+!!		 a(1,1)=0.		 	 
+!!		 
+!!		 b(1)=temp(1)
+!!
+!Computation of the internal values (iz=2,...,n-1) of A and B:
+
+	do iz=2,nz-1
+		a(-1,iz)=-k1(iz)
+		a(0,iz)=1+k1(iz)+k2(iz)
+     		a(1,iz)=-k2(iz)
+		b(iz)=temp(iz)
+	end do		
+
+!Computation of the external value (iz=n) of A and B:
+	
+		a(-1,nz)=-k1(nz)
+		a(0,nz)=1+k1(nz)
+		a(1,nz)=0.
+	
+		b(nz)=temp(nz)+flux(2)*kc(nz)
+
+!Resolution of the system A*T(n+1)=B
+
+	call tridia(nz,a,b,temp)
+
+        return
+	end  subroutine wall	
+
+!====6=8===============================================================72
+!====6=8===============================================================72
+
+	subroutine wall_coeff(nz,dt,dz,cs,k,k1,k2,kc)
+
+	implicit none
+	
+!---------------------------------------------------------------------
+!Input
+!-----
+	integer nz		!Number of layers inside the material
+	real dt			!Time step
+	real dz(nz)		!Layer sizes [m]
+	real cs(nz)		!Specific heat of the material [J/(m3.K)] 
+	real k(nz+1)		!Thermal diffusivity in each layers (face) [W/(m.K)]
+
+
+!Input-Output
+!------------
+
+	real flux(2)		!Internal and external flux terms.
+
+
+!Output
+!------
+        real k1(20)
+        real k2(20)
+        real kc(20)
+
+!Local
+!-----	
+	integer iz
+	real kf(nz)
+
+!------------------------------------------------------------------
+
+	do iz=2,nz
+	 kc(iz)=dt/(dz(iz)*cs(iz))
+	 kf(iz)=2*k(iz)/(dz(iz)+dz(iz-1))
+	end do 
+	
+	kc(1)=dt/(dz(1)*cs(1))
+        kf(1)=2*k(1)/(dz(1))
+
+	do iz=1,nz
+	 k1(iz)=kc(iz)*kf(iz)
+	end do
+	
+	do iz=1,nz-1
+	 k2(iz)=kc(iz)*kf(iz+1)*cs(iz)/cs(iz+1)
+	end do
+
+	return
+	end subroutine wall_coeff
+
+!====6=8===============================================================72  
+!====6=8===============================================================72
+	subroutine hsinsflux(swsurf,swwin,tin,tw,hsins)	
+	
+	implicit none
+	
+! --------------------------------------------------------------------
+! This routine computes the internal sensible heat flux.
+! The swsurf, makes rhe difference between a vertical and a 
+! horizontal surface. 
+! The values of the heat conduction coefficients hc are obtained from the book
+! "Energy Simulation in Building Design". J.A. Clarke. 
+! Adam Hilger, Bristol, 362 pp.
+! --------------------------------------------------------------------
+!Input
+!----
+	integer swsurf  !swich for the type of surface (horizontal/vertical) 
+        integer swwin   !swich for the type of surface (window/wall)
+	real tin	!Inside temperature [K]
+	real tw		!Internal wall temperature [K]  	
+
+
+!Output
+!------
+	real hsins	!internal sensible heat flux [W/m2]
+!Local
+!-----
+	real hc		!heat conduction coefficient [W/°C.m2]
+!--------------------------------------------------------------------
+
+	if (swsurf.eq.2) then	!vertical surface
+         if (swwin.eq.1) then
+            hc=5.678*0.99        !window surface (smooth surface)
+         else
+            hc=5.678*1.09        !wall surface (rough surface)
+         endif
+	 hsins=hc*(tin-tw)	
+	endif
+	
+	if (swsurf.eq.1)  then   !horizontal surface
+         if (swwin.eq.1) then
+           hc=5.678*0.99        !window surface (smooth surface)
+         else
+           hc=5.678*1.09        !wall surface (rough surface)
+         endif
+         hsins=hc*(tin-tw)
+        endif 		
+
+	return
+	end subroutine hsinsflux
+!====6=8===============================================================72  
+!====6=8===============================================================72
+
+	subroutine int_rsrad(albwin,albwal,pwin,rswal,&
+                             surwal,bw,bl,zw,rsint)
+	
+! ------------------------------------------------------------------
+	implicit none
+! ------------------------------------------------------------------	
+
+!Input
+!-----
+	real albwin		!albedo of the windows
+	real albwal		!albedo of the internal wall					
+	real rswal(4)		!incoming short wave radiation [W/m2]
+        real surwal(6) 		!surface of the indoor walls [m2]
+	real bw,bl		!width of the walls [m]
+	real zw			!height of the wall [m]
+	real pwin               !window proportion
+	
+!Output
+!------
+	real rsint(6)		!internal walls short wave radiation [W/m2]
+
+!Local
+!-----
+	real transmit   !transmittance of the direct/diffused radiation
+        real rstr	!solar radiation transmitted through the windows	
+        real surtotwal  !total indoor surface of the walls in the room
+	integer iw
+	real b(6)	!second member for the system
+	real a(6,6)	!matrix for the system
+
+!-------------------------------------------------------------------
+
+
+! Calculation of the solar radiation transmitted through windows
+                    
+            rstr = 0.
+            do iw=1,4
+               transmit=1.-albwin
+               rstr = rstr+(surwal(iw)*pwin)*(transmit*rswal(iw))
+            enddo
+
+!We suppose that the radiation is spread isotropically within the
+!room when it passes through the windows, so the flux [W/m²] in every 
+!wall is:
+
+            surtotwal=0.
+            do iw=1,6
+               surtotwal=surtotwal+surwal(iw)
+            enddo
+            
+            rstr=rstr/surtotwal
+ 		
+!Computation of the short wave radiation reaching the internal walls
+	
+	    call algebra_short(rstr,albwal,albwin,bw,bl,zw,pwin,a,b)
+		
+	    call gaussjbem(a,6,b,6)
+	
+            do iw=1,6
+               rsint(iw)=b(iw)
+            enddo
+
+	    return
+	    end subroutine int_rsrad
+
+!====6=8===============================================================72  
+!====6=8===============================================================72
+
+	subroutine int_rlrad(emwal,emwin,sigma,twal_int,twin,&
+     			     pwin,bw,bl,zw,rlint)
+	
+! ------------------------------------------------------------------
+	implicit none
+! ------------------------------------------------------------------	
+
+!Input
+!-----
+
+	real emwal	!emissivity of the internal walls
+	real emwin	!emissivity of the window
+	real sigma	!Stefan-Boltzmann constant [W/m2.K4]
+	real twal_int(6)!temperature of the first internal layers of a room [K]
+	real twin(4)	!temperature of the windows [K]
+	real bw		!width of the wall
+	real bl		!length of the wall
+	real zw		!height of the wall
+	real pwin       !window proportion	
+
+!Output
+!------
+
+	real rlint(6)	!internal walls long wave radiation [W/m2]
+
+!Local
+!------
+	
+	real b(6)	!second member vector for the system
+	real a(6,6)	!matrix for the system
+        integer iw
+!----------------------------------------------------------------
+
+!Compute the long wave radiation reachs the internal walls
+
+	call algebra_long(emwal,emwin,sigma,twal_int,twin,pwin,&
+                          bw,bl,zw,a,b)
+  			  
+	call gaussjbem(a,6,b,6)
+
+        do iw=1,6
+           rlint(iw)=b(iw)
+        enddo
+            
+	return
+	end subroutine int_rlrad	
+
+!====6=8===============================================================72  
+!====6=8===============================================================72
+
+	subroutine algebra_short(rstr,albwal,albwin,aw,bw,zw,pwin,a,b)
+    
+!--------------------------------------------------------------------
+!This routine calculates the algebraic system that will be solved for 
+!the computation of the total shortwave radiation that reachs every 
+!indoor wall in a floor.
+!Write the matrix system ax=b to solve
+!
+!     -Rs(1)+a(1,2)Rs(2)+.................+a(1,6)Rs(6)=-Rs=b(1)
+!a(2,1)Rs(1)-      Rs(2)+.................+a(2,6)Rs(6)=-Rs=b(2)
+!a(3,1)Rs(1)+a(3,2)Rs(3)-Rs(3)+...........+a(3,6)Rs(6)=-Rs=b(3)
+!a(4,1)Rs(1)+.................-Rs(4)+.....+a(4,6)Rs(6)=-Rs=b(4)
+!a(5,1)Rs(1)+.......................-Rs(5)+a(5,6)Rs(6)=-Rs=b(5)
+!a(6,1)Rs(1)+....................................-R(6)=-Rs=b(6)
+!
+!This version suppose the albedo of the indoor walls is the same.
+!--------------------------------------------------------------------
+	implicit none
+!--------------------------------------------------------------------
+
+!Input
+!-----
+	real rstr	!solar radiation transmitted through the windows		
+	real albwal	!albedo of the internal walls
+	real albwin	!albedo of the windows.
+	real bw		!length of the wall
+	real aw		!width of the wall
+	real zw		!height of the wall
+	real fprl_int	!view factor
+	real fnrm_int	!view factor
+	real pwin       !window proportion
+!Output
+!------
+	real a(6,6)		!Matrix for the system
+	real b(6)		!Second member for the system
+!Local
+!-----
+	integer iw,jw	
+	real albm               !averaged albedo
+!----------------------------------------------------------------
+
+!Initialise the variables
+
+	do iw=1,6
+           b(iw)= 0.
+	  do jw=1,6
+           a(iw,jw)= 0. 
+          enddo
+        enddo 
+
+!Calculation of the second member b
+
+	do iw=1,6
+	 b(iw)=-rstr
+	end do	
+
+!Calculation of the averaged albedo
+
+	albm=pwin*albwin+(1-pwin)*albwal
+	
+!Calculation of the matrix a
+
+            a(1,1)=-1.
+
+            call fprl_ints(fprl_int,aw/bw,zw/bw)
+
+            a(1,2)=albm*fprl_int
+
+            call fnrm_ints(fnrm_int,aw/zw,bw/zw,(aw*aw+bw*bw)/(zw*zw))
+
+            a(1,3)=albm*(bw/aw)*fnrm_int
+
+            a(1,4)=a(1,3)
+
+            call fnrm_ints(fnrm_int,zw/aw,bw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+            a(1,5)=albwal*(bw/zw)*fnrm_int
+
+            a(1,6)=a(1,5)
+
+
+            a(2,1)=a(1,2)
+            a(2,2)=-1.
+            a(2,3)=a(1,3)
+            a(2,4)=a(1,4)
+            a(2,5)=a(1,5)
+            a(2,6)=a(1,6)
+ 
+	
+            call fnrm_ints(fnrm_int,bw/zw,aw/zw,(bw*bw+aw*aw)/(zw*zw))
+
+            a(3,1)=albm*(aw/bw)*fnrm_int
+	    a(3,2)=a(3,1)
+	    a(3,3)=-1.
+
+            call fprl_ints(fprl_int,zw/aw,bw/aw)
+
+	    a(3,4)=albm*fprl_int
+
+            call fnrm_ints(fnrm_int,zw/bw,aw/bw,(aw*aw+zw*zw)/(bw*bw))
+
+	    a(3,5)=albwal*(aw/zw)*fnrm_int
+            a(3,6)=a(3,5)
+	
+
+            a(4,1)=a(3,1)
+            a(4,2)=a(3,2)
+            a(4,3)=a(3,4)
+            a(4,4)=-1.
+            a(4,5)=a(3,5)
+            a(4,6)=a(3,6)
+
+            call fnrm_ints(fnrm_int,bw/aw,zw/aw,(bw*bw+zw*zw)/(aw*aw)) 
+
+            a(5,1)=albm*(zw/bw)*fnrm_int
+                   
+            a(5,2)=a(5,1)
+
+            call fnrm_ints(fnrm_int,aw/bw,zw/bw,(aw*aw+zw*zw)/(bw*bw))
+
+            a(5,3)=albm*(zw/aw)*fnrm_int
+           	   
+            a(5,4)=a(5,3)
+            a(5,5)=-1.
+
+            call fprl_ints(fprl_int,aw/zw,bw/zw)
+
+            a(5,6)=albwal*fprl_int
+
+
+            a(6,1)=a(5,1)
+            a(6,2)=a(5,2)
+            a(6,3)=a(5,3)
+            a(6,4)=a(5,4)
+            a(6,5)=a(5,6)
+            a(6,6)=-1.
+	
+	return
+	end subroutine algebra_short
+
+!====6=8===============================================================72  
+!====6=8===============================================================72
+
+	subroutine algebra_long(emwal,emwin,sigma,twalint,twinint,&
+     				pwin,aw,bw,zw,a,b)
+
+!--------------------------------------------------------------------
+!This routine computes the algebraic system that will be solved to 
+!compute the longwave radiation that reachs the indoor
+!walls in a floor. 
+!Write the matrix system ax=b to solve
+!
+!a(1,1)Rl(1)+.............................+Rl(6)=b(1)
+!a(2,1)Rl(1)+.................+Rl(5)+a(2,6)Rl(6)=b(2)
+!a(3,1)Rl(1)+.....+Rl(3)+...........+a(3,6)Rl(6)=b(3)
+!a(4,1)Rl(1)+...........+Rl(4)+.....+a(4,6)Rl(6)=b(4)
+!      Rl(1)+.......................+a(5,6)Rl(6)=b(5)
+!a(6,1)Rl(1)+Rl(2)+.................+a(6,6)Rl(6)=b(6)
+!
+!--------------------------------------------------------------------
+        implicit none 
+	
+!--------------------------------------------------------------------
+
+!Input
+!-----
+
+	real pwin       !window proportion 
+	real emwal	!emissivity of the internal walls
+	real emwin	!emissivity of the window
+	real sigma	!Stefan-Boltzmann constant [W/m2.K4]
+	real twalint(6) !temperature of the first internal layers of a room [K]
+	real twinint(4)	!temperature of the windows [K]
+	real aw		!width of the wall
+	real bw		!length of the wall
+	real zw		!height of the wall
+	real fprl_int	!view factor
+	real fnrm_int	!view factor	
+        real fnrm_intx	!view factor
+        real fnrm_inty	!view factor
+
+!Output
+!------
+	real b(6)	!second member vector for the system
+	real a(6,6)	!matrix for the system
+!Local
+!-----
+	integer iw,jw
+	real b_wall(6)	
+	real b_wind(6)
+	real emwal_av		!averadge emissivity of the wall
+	real emwin_av		!averadge emissivity of the window
+	real em_av		!averadge emissivity
+        real twal_int(6)        !twalint 
+	real twin(4)   		!twinint 
+!------------------------------------------------------------------
+
+!Initialise the variables
+!-------------------------
+
+	 do iw=1,6
+            b(iw)= 0.
+            b_wall(iw)=0.
+            b_wind(iw)=0.
+          do jw=1,6
+            a(iw,jw)= 0. 
+          enddo
+         enddo
+
+         do iw=1,6
+            twal_int(iw)=twalint(iw)
+         enddo
+
+         do iw=1,4
+            twin(iw)=twinint(iw)
+         enddo
+	 
+!Calculation of the averadge emissivities
+!-----------------------------------------
+
+	emwal_av=(1-pwin)*emwal
+	emwin_av=pwin*emwin
+	em_av=emwal_av+emwin_av
+	
+!Calculation of the second term for the walls
+!-------------------------------------------
+
+            call fprl_ints(fprl_int,aw/zw,bw/zw)
+            call fnrm_ints(fnrm_intx,aw/bw,zw/bw,(aw*aw+zw*zw)/(bw*bw))
+            call fnrm_ints(fnrm_inty,bw/aw,zw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+            b_wall(1)=(emwal*sigma*(twal_int(5)**4)*           &
+     	         fprl_int)+                                    &
+                 (sigma*(emwal_av*(twal_int(3)**4)+            &
+                  emwal_av*(twal_int(4)**4))*                  &
+                 (zw/aw)*fnrm_intx)+                           &
+                 (sigma*(emwal_av*(twal_int(1)**4)+            &
+                  emwal_av*(twal_int(2)**4))*                  & 
+                 (zw/bw)*fnrm_inty)
+
+            call fprl_ints(fprl_int,aw/zw,bw/zw)
+            call fnrm_ints(fnrm_intx,aw/bw,zw/bw,(aw*aw+zw*zw)/(bw*bw))
+            call fnrm_ints(fnrm_inty,bw/aw,zw/aw,(bw*bw+zw*zw)/(aw*aw))
+	
+            b_wall(2)=(emwal*sigma*(twal_int(6)**4)*           &
+              	   fprl_int)+                                  &
+                  (sigma*(emwal_av*(twal_int(3)**4)+           &
+                  emwal_av*(twal_int(4)**4))*                  & 
+                 (zw/aw)*fnrm_intx)+                           &
+                 (sigma*(emwal_av*(twal_int(1)**4)+            &
+                 emwal_av*(twal_int(2)**4))*                   &
+                 (zw/bw)*fnrm_inty)
+
+            call fprl_ints(fprl_int,zw/aw,bw/aw)
+            call fnrm_ints(fnrm_intx,bw/zw,aw/zw,(bw*bw+aw*aw)/(zw*zw))
+            call fnrm_ints(fnrm_inty,zw/bw,aw/bw,(aw*aw+zw*zw)/(bw*bw))
+
+            b_wall(3)=(emwal_av*sigma*(twal_int(4)**4)*        &
+        	  fprl_int)+                                   &
+                 (sigma*(emwal_av*(twal_int(2)**4)+            &
+                  emwal_av*(twal_int(1)**4))*                  &
+                 (aw/bw)*fnrm_intx)+                           &
+                 (sigma*(emwal*(twal_int(5)**4)+               &
+                  emwal*(twal_int(6)**4))*                     &
+                 (aw/zw)*fnrm_inty)
+
+            call fprl_ints(fprl_int,zw/aw,bw/aw)
+            call fnrm_ints(fnrm_intx,bw/zw,aw/zw,(bw*bw+aw*aw)/(zw*zw))
+            call fnrm_ints(fnrm_inty,zw/bw,aw/bw,(aw*aw+zw*zw)/(bw*bw))
+
+            b_wall(4)=(emwal_av*sigma*(twal_int(3)**4)*        &
+     	          fprl_int)+                                   &
+                 (sigma*(emwal_av*(twal_int(2)**4)+            &
+                  emwal_av*(twal_int(1)**4))*                  &
+                 (aw/bw)*fnrm_intx)+                           &
+                 (sigma*(emwal*(twal_int(5)**4)+               &
+                  emwal*(twal_int(6)**4))*                     &
+                 (aw/zw)*fnrm_inty)
+
+            call fprl_ints(fprl_int,aw/bw,zw/bw)
+            call fnrm_ints(fnrm_intx,aw/zw,bw/zw,(aw*aw+bw*bw)/(zw*zw))
+            call fnrm_ints(fnrm_inty,zw/aw,bw/aw,(bw*bw+zw*zw)/(aw*aw))
+          
+            b_wall(5)=(emwal_av*sigma*(twal_int(2)**4)*        &
+     	          fprl_int)+                                   &
+                 (sigma*(emwal_av*(twal_int(3)**4)+            &
+                  emwal_av*(twal_int(4)**4))*                  &
+                 (bw/aw)*fnrm_intx)+                           &
+                 (sigma*(emwal*(twal_int(5)**4)+               &
+                  emwal*(twal_int(6)**4))*                     &
+                 (bw/zw)*fnrm_inty)
+
+            call fprl_ints(fprl_int,aw/bw,zw/bw)
+            call fnrm_ints(fnrm_intx,aw/zw,bw/zw,(aw*aw+bw*bw)/(zw*zw))
+            call fnrm_ints(fnrm_inty,zw/aw,bw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+            b_wall(6)=(emwal_av*sigma*(twal_int(1)**4)*        &
+     	         fprl_int)+                                    &
+                 (sigma*(emwal_av*(twal_int(3)**4)+            &
+                  emwal_av*(twal_int(4)**4))*                  &
+                 (bw/aw)*fnrm_intx)+                           &
+                 (sigma*(emwal*(twal_int(5)**4)+               &
+                 emwal*(twal_int(6)**4))*                      &
+                 (bw/zw)*fnrm_inty)
+	
+!Calculation of the second term for the windows
+!---------------------------------------------
+            call fnrm_ints(fnrm_intx,aw/bw,zw/bw,(aw*aw+zw*zw)/(bw*bw))
+            call fnrm_ints(fnrm_inty,bw/aw,zw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+            b_wind(1)=(sigma*(emwin_av*(twin(3)**4)+          &
+                  emwin_av*(twin(4)**4))*                     &
+                 (zw/aw)*fnrm_intx)+                          &
+                 (sigma*(emwin_av*(twin(1)**4)+               &
+                  emwin_av*(twin(2)**4))*                     &
+                 (zw/bw)*fnrm_inty)
+
+            call fnrm_ints(fnrm_intx,aw/bw,zw/bw,(aw*aw+zw*zw)/(bw*bw))
+            call fnrm_ints(fnrm_inty,bw/aw,zw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+            b_wind(2)=(sigma*(emwin_av*(twin(3)**4)+          &
+                  emwin_av*(twin(4)**4))*                     &
+                 (zw/aw)*fnrm_intx)+                          &
+                 (sigma*(emwin_av*(twin(1)**4)+               &
+                  emwin_av*(twin(2)**4))*                     &
+                 (zw/bw)*fnrm_inty)
+
+            call fprl_ints(fprl_int,zw/aw,bw/aw)
+            call fnrm_ints(fnrm_int,bw/zw,aw/zw,(bw*bw+aw*aw)/(zw*zw))
+          
+            b_wind(3)=emwin_av*sigma*(twin(4)**4)*            &
+                 fprl_int+(sigma*(emwin_av*                   &
+                 (twin(2)**4)+emwin_av*(twin(1)**4))*         &
+                 (aw/bw)*fnrm_int)
+
+            call fprl_ints(fprl_int,zw/aw,bw/aw)
+            call fnrm_ints(fnrm_int,bw/zw,aw/zw,(bw*bw+aw*aw)/(zw*zw))
+
+            b_wind(4)=emwin_av*sigma*(twin(3)**4)*            &
+                 fprl_int+(sigma*(emwin_av*                   &
+                  (twin(2)**4)+emwin_av*(twin(1)**4))*        &
+                 (aw/bw)*fnrm_int)
+
+            call fprl_ints(fprl_int,aw/bw,zw/bw)
+            call fnrm_ints(fnrm_int,aw/zw,bw/zw,(aw*aw+bw*bw)/(zw*zw))
+          
+            b_wind(5)=emwin_av*sigma*(twin(2)**4)*            &
+                 fprl_int+(sigma*(emwin_av*                   &
+                 (twin(3)**4)+emwin_av*(twin(4)**4))*         &
+                 (bw/aw)*fnrm_int)
+ 
+            call fprl_ints(fprl_int,aw/bw,zw/bw)
+            call fnrm_ints(fnrm_int,aw/zw,bw/zw,(aw*aw+bw*bw)/(zw*zw))
+
+            b_wind(6)=emwin_av*sigma*(twin(1)**4)*            &
+                 fprl_int+(sigma*(emwin_av*                   &
+                 (twin(3)**4)+emwin_av*(twin(4)**4))*         &
+                 (bw/aw)*fnrm_int)
+     
+!Calculation of the total b term
+!-------------------------------
+
+	do iw=1,6
+	 b(iw)=b_wall(iw)+b_wind(iw)
+	end do     
+
+
+!Calculation of the matrix of the system
+!----------------------------------------
+
+         call fnrm_ints(fnrm_int,bw/aw,zw/aw,(bw*bw+zw*zw)/(aw*aw))         
+
+         a(1,1)=(em_av-1.)*(zw/bw)*fnrm_int
+     	        
+         a(1,2)=a(1,1)
+
+         call fnrm_ints(fnrm_int,aw/bw,zw/bw,(aw*aw+zw*zw)/(bw*bw))
+
+         a(1,3)=(em_av-1.)*(zw/aw)*fnrm_int
+         	 
+         a(1,4)=a(1,3)
+
+         call fprl_ints(fprl_int,aw/zw,bw/zw)
+
+         a(1,5)=(emwal-1.)*fprl_int
+         a(1,6)=1.
+
+         a(2,1)=a(1,1)
+         a(2,2)=a(1,2)
+         a(2,3)=a(1,3)
+         a(2,4)=a(1,4)
+         a(2,5)=1.
+         a(2,6)=a(1,5)
+
+         call fnrm_ints(fnrm_int,bw/zw,aw/zw,(bw*bw+aw*aw)/(zw*zw))
+
+         a(3,1)=(em_av-1.)*(aw/bw)*fnrm_int
+     	        
+         a(3,2)=a(3,1)
+         a(3,3)=1.
+
+         call fprl_ints(fprl_int,zw/aw,bw/aw) 
+
+         a(3,4)=(em_av-1.)*fprl_int
+
+         call fnrm_ints(fnrm_int,zw/bw,aw/bw,(aw*aw+zw*zw)/(bw*bw))
+
+         a(3,5)=(emwal-1.)*(aw/zw)*fnrm_int
+     	        
+         a(3,6)=a(3,5)
+
+         a(4,1)=a(3,1)
+         a(4,2)=a(3,2)
+         a(4,3)=a(3,4)
+         a(4,4)=1.
+         a(4,5)=a(3,5)
+         a(4,6)=a(3,6)
+
+         a(5,1)=1.
+
+         call fprl_ints(fprl_int,aw/bw,zw/bw)
+
+         a(5,2)=(em_av-1.)*fprl_int
+
+         call fnrm_ints(fnrm_int,aw/zw,bw/zw,(aw*aw+bw*bw)/(zw*zw))
+
+         a(5,3)=(em_av-1.)*(bw/aw)*fnrm_int
+     	        
+         a(5,4)=a(5,3)
+
+         call fnrm_ints(fnrm_int,zw/aw,bw/aw,(bw*bw+zw*zw)/(aw*aw))
+
+         a(5,5)=(emwal-1.)*(bw/zw)*fnrm_int
+     	        
+         a(5,6)=a(5,5)
+
+         a(6,1)=a(5,2)
+         a(6,2)=1.
+         a(6,3)=a(5,3)
+         a(6,4)=a(5,4)
+         a(6,5)=a(5,5)
+         a(6,6)=a(6,5)
+
+      return
+      end subroutine algebra_long
+
+!====6=8===============================================================72 
+!====6=8===============================================================72 
+
+
+	subroutine fluxroo(hseqocc,hleqocc,hsvent,hlvent, &
+                           hscond,hslev,hllev) 
+	
+!-----------------------------------------------------------------------
+!This routine calculates the heat flux generated inside the room
+!and the heat ejected to the atmosphere.
+!----------------------------------------------------------------------	
+
+	implicit none
+
+!-----------------------------------------------------------------------
+
+!Input
+!-----
+	real hseqocc		!sensible heat generated by equipments and occupants [W]
+	real hleqocc		!latent heat generated by occupants [W]
+	real hsvent		!sensible heat generated by natural ventilation [W]
+	real hlvent		!latent heat generated by natural ventilation [W] 
+	real hscond		!sensible heat generated by wall conduction 
+
+!Output
+!------
+	real hslev		!sensible heat flux generated inside the room [W]
+	real hllev		!latent heat flux generatd inside the room
+
+
+!Calculation of the total sensible heat generated inside the room
+
+	hslev=hseqocc+hsvent+hscond 
+ 
+!Calculation of the total latent heat generated inside the room
+	
+	hllev=hleqocc+hlvent
+        
+	return
+	end subroutine fluxroo
+
+!====6=8===============================================================72 
+!====6=8===============================================================72
+
+	subroutine phirat(nhourday,rocc)
+
+!----------------------------------------------------------------------
+!This routine calculates the occupation ratio of a floor
+!By now we suppose a constant value
+!----------------------------------------------------------------------
+
+        implicit none
+
+!Input
+!-----
+
+	real nhourday	! number of hours from midnight (local time)
+	
+!Output
+!------
+	real rocc       !value between 0 and 1
+
+!!TEST
+        rocc=1.
+
+	return
+	end subroutine phirat
+
+!====6=8===============================================================72 
+!====6=8===============================================================72
+
+	subroutine phiequ(nhourday,hsesf,hsequip,hsequ)
+
+!----------------------------------------------------------------------
+!This routine calculates the sensible heat gain from equipments
+!----------------------------------------------------------------------
+        implicit none
+!Input
+!-----
+
+	real nhourday ! number of hours from midnight, Local time
+        real, intent(in) :: hsesf
+        real, intent(in), dimension(24) :: hsequip
+	
+!Output
+!------
+	real hsequ    !sensible heat gain from equipment [Wm¯2]
+
+!---------------------------------------------------------------------	
+
+        hsequ = hsequip(int(nhourday)+1) * hsesf
+        
+	end subroutine phiequ
+!====6=8===============================================================72 
+!====6=8===============================================================72
+
+	subroutine fluxeqocc(nhourday,bw,bl,perflo,hsesf,hsequip,hseqocc,hleqocc)
+	
+	implicit none
+
+!---------------------------------------------------------------------
+!This routine calculates the sensible and the latent heat flux 
+!generated by equipments and occupants
+!---------------------------------------------------------------------	
+
+!Input
+!-----
+	real bw			!Room width [m]
+	real bl			!Room lengzh [m]
+	real nhourday		!number of hours from the beginning of the day
+        real, intent(in) :: perflo ! Peak number of occupants per unit floor area
+        real, intent(in) :: hsesf
+        real, intent(in), dimension(24) :: hsequip
+
+!Output
+!------
+	real hseqocc		!sensible heat generated by equipments and occupants [W]
+	real hleqocc		!latent heat generated by occupants [W]
+!Local
+!-----
+	real Af			!Air conditioned floor area [m2]
+	real rocc		!Occupation ratio of the floor [0,1]
+        real hsequ		!Heat generated from equipments 
+
+        real hsocc		!Sensible heat generated by a person [W/Person]
+                                !Source Boundary Layer Climates,page 195 (book)
+        parameter (hsocc=160.)
+
+        real hlocc		!Latent heat generated by a person [W/Person]
+                                !Source Boundary Layer Climates,page 225 (book)
+        parameter (hlocc=1.96e6/86400.)
+
+!------------------------------------------------------------------
+!			Sensible heat flux
+!			------------------
+
+	 Af=bw*bl
+
+	 call phirat(nhourday,rocc)
+
+         call phiequ(nhourday,hsesf,hsequip,hsequ)
+
+         hseqocc=Af*rocc*perflo*hsocc+Af*hsequ
+
+!
+!			Latent heat
+!			-----------
+!
+
+         hleqocc=Af*rocc*perflo*hlocc
+
+	return
+	end subroutine fluxeqocc
+
+!====6=8===============================================================72 
+!====6=8===============================================================72
+	
+	subroutine fluxvent(cpint,rhoint,vollev,tlev,tout,latent,&
+                            humout,rhoout,humlev,beta,hsvent,hlvent)
+	
+	implicit none
+
+!---------------------------------------------------------------------
+!This routine calculates the sensible and the latent heat flux 
+!generated by natural ventilation
+!---------------------------------------------------------------------
+
+!Input
+!-----
+	real cpint		!specific heat of the indoor air [J/kg.K]
+	real rhoint		!density of the indoor air [Kg/m3]	
+	real vollev		!volume of the room [m3]
+	real tlev		!Room temperature [K]
+	real tout		!outside air temperature [K]
+	real latent		!latent heat of evaporation [J/Kg]
+	real humout		!outside absolute humidity [Kgwater/Kgair]
+	real rhoout		!air density [kg/m3]
+	real humlev		!Specific humidity of the indoor air [Kgwater/Kgair]
+        real, intent(in) :: beta!Thermal efficiency of the heat exchanger 
+	
+!Output
+!------
+	real hsvent		!sensible heat generated by natural ventilation [W]
+	real hlvent		!latent heat generated by natural ventilation [W] 
+
+!Local
+!-----       
+        
+!----------------------------------------------------------------------
+
+!			Sensible heat flux
+!			------------------
+        
+	hsvent=(1.-beta)*cpint*rhoint*(vollev/3600.)*  &
+               (tout-tlev)
+	
+!			Latent heat flux
+!			----------------
+       
+	hlvent=(1.-beta)*latent*rhoint*(vollev/3600.)* &
+     	       (humout-humlev)
+
+
+	return
+	end subroutine fluxvent
+
+!====6=8===============================================================72 
+!====6=8===============================================================72
+	
+	subroutine fluxcond(hswalins,hswinins,surwal,pwin,hscond)
+	
+	implicit none
+
+!---------------------------------------------------------------------
+!This routine calculates the sensible heat flux generated by 
+!wall conduction.
+!---------------------------------------------------------------------
+
+!Input
+!-----
+	real hswalins(6)	!sensible heat at the internal layers of the wall [W/m2]
+	real hswinins(4)	!internal window sensible heat flux [W/m2]
+	real surwal(6)	        !surfaces of the room walls [m2]
+	real pwin               !window proportion	
+
+
+!Output
+!------
+	
+	real hscond		!sensible heat generated by wall conduction [W]
+	
+!Local
+!-----
+
+	integer ivw
+
+!----------------------------------------------------------------------
+
+	  hscond=0.
+
+	do ivw=1,4
+	   hscond=hscond+surwal(ivw)*(1-pwin)*hswalins(ivw)+ &
+                  surwal(ivw)*pwin*hswinins(ivw)	         
+	end do
+
+	do ivw=5,6
+    	   hscond=hscond+surwal(ivw)*hswalins(ivw)	
+	end do
+!           
+!Finally we must change the sign in hscond to be proportional
+!to the difference (Twall-Tindoor).
+!
+        hscond=(-1)*hscond 
+
+	return
+	end subroutine fluxcond
+
+!====6=8===============================================================72 
+!====6=8===============================================================72
+	
+	subroutine regtemp(swcond,nhourday,dt,Qb,hsroo,          &
+                           tlev,timeon,timeoff,targtemp,gaptemp,hsneed)
+	
+	implicit none
+
+!---------------------------------------------------------------------
+!This routine calculates the sensible heat fluxes, 
+!after anthropogenic regulation (air conditioning)
+!---------------------------------------------------------------------
+
+!Input:
+!-----.
+        integer swcond       !swich air conditioning
+	real nhourday        !number of hours from the beginning of the day real
+	real dt	             !time step [s]
+	real Qb		     !overall heat capacity of the indoor air [J/K]
+        real hsroo           !sensible heat flux generated inside the room [W]
+        real tlev            !room air temperature [K]
+        real, intent(in) :: timeon  ! Initial local time of A/C systems
+        real, intent(in) :: timeoff ! Ending local time of A/C systems
+        real, intent(in) :: targtemp! Target temperature of A/C systems
+        real, intent(in) :: gaptemp ! Comfort range of indoor temperature
+        
+
+!Local:
+!-----.
+
+        real templev         !hipotetical room air temperature [K]
+        real alpha           !variable to control the heating/cooling of 
+                             !the air conditining system
+!Output:
+!-----.
+	real hsneed	     !sensible heat extracted to the indoor air [W]
+!---------------------------------------------------------------------
+!initialize variables
+!---------------------
+        templev = 0.
+        alpha   = 0.
+
+        if (swcond.eq.0) then ! there is not air conditioning in the floor
+            hsneed = 0.
+            goto 100
+        else
+            if ((nhourday.ge.timeon).and.(nhourday.le.timeoff)) then
+               templev=tlev+(dt/Qb)*hsroo
+               goto 200
+            else
+               hsneed = 0.     ! air conditioning is switched off
+               goto 100
+            endif
+        endif
+
+200     continue
+
+        if (abs(templev-targtemp).le.gaptemp) then
+           hsneed = 0.
+        else 
+           if (templev.gt.(targtemp+gaptemp)) then
+              hsneed=hsroo-(Qb/dt)*(targtemp+gaptemp-tlev)
+              alpha=(abs(hsneed-hsroo)/Qb)
+              if (alpha.gt.temp_rat) then
+                  hsneed=hsroo+temp_rat*Qb
+                  goto 100
+              else
+                  goto 100
+              endif
+           else 
+              hsneed=hsroo-(Qb/dt)*(targtemp-gaptemp-tlev)
+              alpha=(abs(hsneed-hsroo)/Qb)
+              if (alpha.gt.temp_rat) then
+                  hsneed=hsroo-temp_rat*Qb
+                  goto 100
+              else
+                  goto 100
+              endif
+           endif
+        endif 
+
+100     continue
+	return
+	end subroutine regtemp
+     
+!====6=8==============================================================72
+!====6=8==============================================================72
+         
+	 subroutine reghum(swcond,nhourday,dt,volroo,rhoint,latent, &
+                           hlroo,shumroo,timeon,timeoff,targhum,gaphum,hlneed)
+
+	 implicit none
+
+!---------------------------------------------------------------------
+!This routine calculates the latent heat fluxes, 
+!after anthropogenic regulation (air conditioning)
+!---------------------------------------------------------------------
+
+!Input:
+!-----.
+        integer swcond    !swich air conditioning
+	real nhourday     !number of hours from the beginning of the day real[h]
+	real dt	          !time step [s]
+	real volroo       !volume of the room [m3]
+        real rhoint       !density of the internal air [Kg/m3]
+        real latent       !latent heat of evaporation [J/Kg]
+        real hlroo        !latent heat flux generated inside the room [W]
+        real shumroo      !specific humidity of the indoor air [kg/kg]
+        real, intent(in) :: timeon  ! Initial local time of A/C systems
+        real, intent(in) :: timeoff ! Ending local time of A/C systems
+        real, intent(in) :: targhum ! Target humidity of the A/C systems
+        real, intent(in) :: gaphum  ! comfort range of the specific humidity
+
+!Local:
+!-----.
+
+        real humlev       !hipotetical specific humidity of the indoor [kg/kg]
+        real betha        !variable to control the drying/moistening of
+                          !the air conditioning system
+!Output:
+!-----.
+	real hlneed	  !latent heat extracted to the indoor air [W]
+!------------------------------------------------------------------------
+!initialize variables
+!---------------------
+        humlev = 0.
+        betha  = 0.
+
+        if (swcond.eq.0) then ! there is not air conditioning in the floor
+            hlneed = 0.
+            goto 100
+        else
+            if ((nhourday.ge.timeon).and.(nhourday.le.timeoff)) then
+               humlev=shumroo+(dt/(latent*rhoint*volroo))*hlroo
+               goto 200
+            else
+               hlneed = 0.     ! air conditioning is switched off
+               goto 100
+            endif
+        endif
+
+200     continue
+
+        if (abs(humlev-targhum).le.gaphum) then
+           hlneed = 0.
+        else 
+           if (humlev.gt.(targhum+gaphum)) then
+              hlneed=hlroo-((latent*rhoint*volroo)/dt)* &
+                          (targhum+gaphum-shumroo)
+              betha=abs(hlneed-hlroo)/(latent*rhoint*volroo)
+              if (betha.gt.hum_rat) then
+                  hlneed=hlroo+hum_rat*(latent*rhoint*volroo)
+                  goto 100
+              else
+                  goto 100
+              endif
+           else 
+              hlneed=hlroo-((latent*rhoint*volroo)/dt)* &
+                          (targhum-gaphum-shumroo)
+              betha=abs(hlneed-hlroo)/(latent*rhoint*volroo)
+              if (betha.gt.hum_rat) then
+                  hlneed=hlroo-hum_rat*(latent*rhoint*volroo)
+                  goto 100
+              else
+                  goto 100
+              endif
+           endif
+        endif 
+	
+100     continue
+	return
+	end subroutine reghum
+
+!====6=8==============================================================72
+!====6=8==============================================================72
+         
+         subroutine air_cond(hsneed,hlneed,dt,hsout,hlout,consump,cop)
+
+         implicit none
+
+!
+!Performance of the air conditioning system        
+!
+!INPUT/OUTPUT VARIABLES
+         real, intent(in) :: cop
+!
+!INPUT/OUTPUT VARIABLES
+!       
+         real hsneed     !sensible heat that is necessary for cooling/heating
+                         !the indoor air temperature [W] 
+         real hlneed     !latent heat that is necessary for controling
+                         !the humidity of the indoor air [W]
+         real dt         !time step [s]
+!
+!OUTPUT VARIABLES
+!
+         real hsout      !sensible heat pumped out into the atmosphere [W]
+         real hlout      !latent heat pumped out into the atmosphere [W]
+         real consump    !Electrical consumption of the air conditioning system [W] 
+                         
+    
+!
+!Performance of the air conditioning system
+!
+         if (hsneed.gt.0) then         ! air conditioning is cooling 
+                                       ! and the heat is pumped out into the atmosphere  
+	  hsout=(1/cop)*(abs(hsneed)+abs(hlneed))+hsneed
+          hlout=hlneed
+          consump=(1./cop)*(abs(hsneed)+abs(hlneed))
+!!        hsout=0.             
+!!        hlout=0.
+
+         else if(hsneed.eq.0.) then !air conditioning is not working to regulate the indoor temperature
+               hlneed=0.       !no humidity regulation is considered 
+               hsout=0.        !no output into the atmosphere (sensible heat) 
+               hlout=0.        !no output into the atmosphere (latent heat)
+               consump=0.      !no electrical consumption
+
+              else  !! hsneed < 0. !air conditioning is heating 
+               hlneed=0.           !no humidity regulation is considered
+               hlout=0.            !no output into the atmosphere (latent heat) 
+               consump=(1./cop)*(abs(hsneed)+abs(hlneed))
+!
+!!We have two possibilities 
+! 
+!!             hsout=(1./cop)*(abs(hsneed)+abs(hlneed)) !output into the atmosphere 
+               hsout=0.                            !no output into the atmosphere                        
+         end if
+
+         return 
+         end subroutine air_cond
+
+!====6=8==============================================================72
+!====6=8==============================================================72
+
+        subroutine consump_total(nzcanm,nlev,consumpbuild,hsoutbuild, &
+                                 hsout,consump)
+
+        implicit none
+        
+!-----------------------------------------------------------------------
+!Compute the total consumption in kWh/s (1kWh=3.6e+6 J) and sensible heat
+!ejected into the atmosphere per building
+!------------------------------------------------------------------------
+!
+!INPUT VARIABLES
+!
+!
+        integer nzcanm            !Maximum number of vertical levels in the urban grid
+        real hsout(nzcanm)        !sensible heat emitted outside the room [W]
+        real consump(nzcanm)      !Electricity consumption for the a.c. in each floor[W]
+!
+!OUTPUT VARIABLES
+!
+	real consumpbuild         !Energetic consumption for the entire building[kWh/s]
+        real hsoutbuild           !Total sensible heat ejected into the atmosphere
+                                  !by the air conditioning systems per building [W]        
+!
+!LOCAL  VARIABLES
+!
+        integer ilev
+
+!
+!INPUT VARIABLES
+!
+        integer nlev     
+        
+!
+!INITIALIZE VARIABLES
+!
+        consumpbuild=0.
+        hsoutbuild=0.
+!
+        do ilev=1,nlev
+           consumpbuild=consumpbuild+consump(ilev)
+           hsoutbuild=hsoutbuild+hsout(ilev)
+        enddo !ilev
+
+        consumpbuild=consumpbuild/(3.6e+06)
+
+        return 
+        end subroutine consump_total
+!====6=8==============================================================72
+!====6=8==============================================================72
+        subroutine tridia(n,a,b,x)
+
+!     ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!     +    by A. Clappier,     EPFL, CH 1015 Lausanne                  +
+!     +                        phone: ++41-(0)21-693-61-60             +
+!     +                        email:alain.clappier@epfl.ch            +
+!     ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+! ----------------------------------------------------------------------
+!        Resolution of a * x = b    where a is a tridiagonal matrix
+!
+! ----------------------------------------------------------------------
+
+        implicit none
+
+! Input
+        integer n
+        real a(-1:1,n)           !  a(-1,*) lower diagonal      A(i,i-1)
+                               !  a(0,*)  principal diagonal  A(i,i)
+                               !  a(1,*)  upper diagonal      A(i,i+1)
+        real b(n)
+
+! Output
+        real x(n)
+
+! Local
+        integer i
+
+! ----------------------------------------------------------------------
+
+        do i=n-1,1,-1
+           b(i)=b(i)-a(1,i)*b(i+1)/a(0,i+1)
+           a(0,i)=a(0,i)-a(1,i)*a(-1,i+1)/a(0,i+1)
+        enddo
+
+        do i=2,n
+           b(i)=b(i)-a(-1,i)*b(i-1)/a(0,i-1)
+        enddo
+
+        do i=1,n
+           x(i)=b(i)/a(0,i)
+        enddo
+
+        return
+        end subroutine tridia    
+!====6=8===============================================================72     
+!====6=8===============================================================72     
+      
+       subroutine gaussjbem(a,n,b,np)
+
+! ----------------------------------------------------------------------
+! This routine solve a linear system of n equations of the form
+!              A X = B
+!  where  A is a matrix a(i,j)
+!         B a vector and X the solution
+! In output b is replaced by the solution     
+! ----------------------------------------------------------------------
+
+       implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+       integer np
+       real a(np,np)
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+       real b(np)
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer nmax
+      parameter (nmax=150)
+
+      real big,dum
+      integer i,icol,irow
+      integer j,k,l,ll,n
+      integer ipiv(nmax)
+      real pivinv
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+       
+       do j=1,n
+          ipiv(j)=0.
+       enddo
+       
+      do i=1,n
+         big=0.
+         do j=1,n
+            if(ipiv(j).ne.1)then
+               do k=1,n
+                  if(ipiv(k).eq.0)then
+                     if(abs(a(j,k)).ge.big)then
+                        big=abs(a(j,k))
+                        irow=j
+                        icol=k
+                     endif
+                  elseif(ipiv(k).gt.1)then
+                     pause 'singular matrix in gaussjbem'
+                  endif
+               enddo
+            endif
+         enddo
+         
+         ipiv(icol)=ipiv(icol)+1
+         
+         if(irow.ne.icol)then
+            do l=1,n
+               dum=a(irow,l)
+               a(irow,l)=a(icol,l)
+               a(icol,l)=dum
+            enddo
+            
+            dum=b(irow)
+            b(irow)=b(icol)
+            b(icol)=dum
+          
+         endif
+         
+         if(a(icol,icol).eq.0)pause 'singular matrix in gaussjbem'
+         
+         pivinv=1./a(icol,icol)
+         a(icol,icol)=1
+         
+         do l=1,n
+            a(icol,l)=a(icol,l)*pivinv
+         enddo
+         
+         b(icol)=b(icol)*pivinv
+         
+         do ll=1,n
+            if(ll.ne.icol)then
+               dum=a(ll,icol)
+               a(ll,icol)=0.
+               do l=1,n
+                  a(ll,l)=a(ll,l)-a(icol,l)*dum
+               enddo
+               
+               b(ll)=b(ll)-b(icol)*dum
+               
+            endif
+         enddo
+      enddo
+      
+      return
+      end subroutine gaussjbem
+         
+!====6=8===============================================================72     
+!====6=8===============================================================72     
+
+      subroutine radfluxs(radflux,alb,rs,em,rl,sigma,twal)
+
+      implicit none
+!-------------------------------------------------------------------
+!This function calculates the radiative fluxe at a surface
+!-------------------------------------------------------------------
+
+	
+	real alb	!albedo of the surface
+	real rs		!shor wave radiation
+	real em		!emissivity of the surface
+	real rl 	!lon wave radiation
+	real sigma	!parameter (wall is not black body) [W/m2.K4]
+	real twal	!wall temperature [K]
+	real radflux
+	
+	 radflux=(1.-alb)*rs+em*rl-em*sigma*twal**4
+	
+      return
+      end subroutine radfluxs
+
+!====6=8==============================================================72 
+!====6=8==============================================================72
+!       
+!       we define the view factors fprl and fnrm, which are the angle 
+!       factors between two equal and parallel planes, fprl, and two 
+!       equal and orthogonal planes, fnrm, respectively
+!       
+        subroutine fprl_ints(fprl_int,vx,vy)
+        
+        implicit none
+
+	real vx,vy
+	real fprl_int
+        
+	fprl_int=(2./(3.141592653*vx*vy))*                       &
+             (log(sqrt((1.+vx*vx)*(1.+vy*vy)/(1.+vx*vx+vy*vy)))+ &
+              (vy*sqrt(1.+vx*vx)*atan(vy/sqrt(1.+vx*vx)))+       &
+              (vx*sqrt(1.+vy*vy)*atan(vx/sqrt(1.+vy*vy)))-       &
+              vy*atan(vy)-vx*atan(vx))
+
+        return
+        end subroutine fprl_ints
+
+!====6=8==============================================================72 
+!====6=8==============================================================72
+!       
+!       we define the view factors fprl and fnrm, which are the angle 
+!       factors between two equal and parallel planes, fprl, and two 
+!       equal and orthogonal planes, fnrm, respectively
+!       
+
+        subroutine fnrm_ints(fnrm_int,wx,wy,wz)
+
+        implicit none
+        
+	real wx,wy,wz
+	real fnrm_int
+	
+        fnrm_int=(1./(3.141592653*wy))*(wy*atan(1./wy)+wx*atan(1./wx)- &
+              (sqrt(wz)*atan(1./sqrt(wz)))+                            &
+              (1./4.)*(log((1.+wx*wx)*(1.+wy*wy)/(1.+wz))+             &
+              wy*wy*log(wy*wy*(1.+wz)/(wz*(1.+wy*wy)))+                &
+              wx*wx*log(wx*wx*(1.+wz)/(wz*(1.+wx*wx)))))
+        
+        return
+        end subroutine fnrm_ints
+
+!====6=8==============================================================72 
+!====6=8==============================================================72
+END MODULE module_sf_bem
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_bep.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_bep.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_bep.F	(revision 17)
@@ -0,0 +1,3239 @@
+MODULE module_sf_bep
+
+!USE module_model_constants
+ USE module_sf_urban
+
+! SGClarke 09/11/2008
+! Access urban_param.tbl values through calling urban_param_init in module_physics_init
+! for CASE (BEPSCHEME) select sf_urban_physics
+!
+ ! -----------------------------------------------------------------------
+!  Dimension for the array used in the BEP module
+! -----------------------------------------------------------------------
+
+      integer nurbm           ! Maximum number of urban classes    
+      parameter (nurbm=3)
+
+      integer ndm             ! Maximum number of street directions 
+      parameter (ndm=2)
+
+      integer nz_um           ! Maximum number of vertical levels in the urban grid
+      parameter(nz_um=13)
+
+      integer ng_u            ! Number of grid levels in the ground
+      parameter (ng_u=10)
+      integer nwr_u            ! Number of grid levels in the walls or roofs
+      parameter (nwr_u=10)
+
+      real dz_u                 ! Urban grid resolution
+      parameter (dz_u=5.)
+
+! The change of ng_u, nwr_u should be done in agreement with the block data
+!  in the routine "surf_temp" 
+! -----------------------------------------------------------------------
+!  Constant used in the BEP module
+! -----------------------------------------------------------------------
+           
+      real vk                 ! von Karman constant
+      real g_u                  ! Gravity acceleration
+      real pi                 !
+      real r                  ! Perfect gas constant
+      real cp_u                 ! Specific heat at constant pressure
+      real rcp_u                !
+      real sigma              !
+      real p0                 ! Reference pressure at the sea level
+      real cdrag              ! Drag force constant
+      parameter(vk=0.40,g_u=9.81,pi=3.141592653,r=287.,cp_u=1004.)        
+      parameter(rcp_u=r/cp_u,sigma=5.67e-08,p0=1.e+5,cdrag=0.4)
+
+! -----------------------------------------------------------------------     
+
+
+
+
+   CONTAINS
+ 
+      subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy,      &
+                      th_phy,rho,p_phy,swdown,glw,                    &
+                      gmt,julday,xlong,xlat,                          &
+                      declin_urb,cosz_urb2d,omg_urb2d,                &
+                      num_urban_layers,                               &
+                      trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,        &
+                      sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,      &
+                      a_u,a_v,a_t,a_e,b_u,b_v,                        &
+                      b_t,b_e,dlg,dl_u,sf,vl,                         &
+                      rl_up,rs_abs,emiss,grdflx_urb,                  &
+                      ids,ide, jds,jde, kds,kde,                      &
+                      ims,ime, jms,jme, kms,kme,                      &
+                      its,ite, jts,jte, kts,kte)                    
+
+      implicit none
+
+!------------------------------------------------------------------------
+!     Input
+!------------------------------------------------------------------------
+   INTEGER ::                       ids,ide, jds,jde, kds,kde,  &
+                                    ims,ime, jms,jme, kms,kme,  &
+                                    its,ite, jts,jte, kts,kte,  &
+                                    itimestep
+ 
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   DZ8W
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   P_PHY
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   RHO
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   TH_PHY
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   T_PHY
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   U_PHY
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   V_PHY
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   U
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   V
+   REAL, DIMENSION( ims:ime , jms:jme )        ::   GLW
+   REAL, DIMENSION( ims:ime , jms:jme )        ::   swdown
+   REAL, DIMENSION( ims:ime, jms:jme )         ::   UST
+   INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN )::   UTYPE_URB2D
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN )::   FRC_URB2D
+   REAL, INTENT(IN  )   ::                                   GMT 
+   INTEGER, INTENT(IN  ) ::                               JULDAY
+   REAL, DIMENSION( ims:ime, jms:jme ),                           &
+         INTENT(IN   )  ::                           XLAT, XLONG
+   REAL, INTENT(IN) :: DECLIN_URB
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D
+   INTEGER, INTENT(IN  ) :: num_urban_layers
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d
+!      integer nx,ny,nz              ! Number of points in the mesocsale grid
+      real z(ims:ime,kms:kme,jms:jme)            ! Vertical coordinates
+      REAL, INTENT(IN )::   DT      ! Time step
+!      real zr(ims:ime,jms:jme)                ! Solar zenith angle
+!      real deltar(ims:ime,jms:jme)            ! Declination of the sun
+!      real ah(ims:ime,jms:jme)                ! Hour angle
+!      real rs(ims:ime,jms:jme)                ! Solar radiation
+!------------------------------------------------------------------------
+!     Output
+!------------------------------------------------------------------------ 
+!      real tsk(ims:ime,jms:jme)           ! Average of surface temperatures (roads and roofs)
+!
+!    Implicit and explicit components of the source and sink terms at each levels,
+!     the fluxes can be computed as follow: FX = A*X + B   example: t_fluxes = a_t * pt + b_t
+      real a_u(ims:ime,kms:kme,jms:jme)         ! Implicit component for the momemtum in X-direction (center)
+      real a_v(ims:ime,kms:kme,jms:jme)         ! Implicit component for the momemtum in Y-direction (center)
+      real a_t(ims:ime,kms:kme,jms:jme)         ! Implicit component for the temperature
+      real a_e(ims:ime,kms:kme,jms:jme)         ! Implicit component for the TKE
+      real b_u(ims:ime,kms:kme,jms:jme)         ! Explicit component for the momemtum in X-direction (center)
+      real b_v(ims:ime,kms:kme,jms:jme)         ! Explicit component for the momemtum in Y-direction (center)
+      real b_t(ims:ime,kms:kme,jms:jme)         ! Explicit component for the temperature
+      real b_e(ims:ime,kms:kme,jms:jme)         ! Explicit component for the TKE
+      real dlg(ims:ime,kms:kme,jms:jme)         ! Height above ground (L_ground in formula (24) of the BLM paper). 
+      real dl_u(ims:ime,kms:kme,jms:jme)        ! Length scale (lb in formula (22) ofthe BLM paper).
+! urban surface and volumes        
+      real sf(ims:ime,kms:kme,jms:jme)           ! surface of the urban grid cells
+      real vl(ims:ime,kms:kme,jms:jme)             ! volume of the urban grid cells
+! urban fluxes
+      real rl_up(ims:ime,jms:jme) ! upward long wave radiation
+      real rs_abs(ims:ime,jms:jme) ! absorbed short wave radiation
+      real emiss(ims:ime,jms:jme)  ! emissivity averaged for urban surfaces
+      real grdflx_urb(ims:ime,jms:jme)  ! ground heat flux for urban areas
+!------------------------------------------------------------------------
+!     Local
+!------------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!    Building parameters      
+      real alag_u(nurbm)                      ! Ground thermal diffusivity [m^2 s^-1]
+      real alaw_u(nurbm)                      ! Wall thermal diffusivity [m^2 s^-1]
+      real alar_u(nurbm)                      ! Roof thermal diffusivity [m^2 s^-1]
+      real csg_u(nurbm)                       ! Specific heat of the ground material [J m^3 K^-1]
+      real csw_u(nurbm)                       ! Specific heat of the wall material [J m^3 K^-1]
+      real csr_u(nurbm)                       ! Specific heat of the roof material [J m^3 K^-1]
+      real twini_u(nurbm)                     ! Initial temperature inside the building's wall [K]
+      real trini_u(nurbm)                     ! Initial temperature inside the building's roof [K]
+      real tgini_u(nurbm)                     ! Initial road temperature
+!
+! for twini_u, and trini_u the initial value at the deepest level is kept constant during the simulation
+!
+!    Radiation paramters
+      real albg_u(nurbm)                      ! Albedo of the ground
+      real albw_u(nurbm)                      ! Albedo of the wall
+      real albr_u(nurbm)                      ! Albedo of the roof
+      real emg_u(nurbm)                       ! Emissivity of ground
+      real emw_u(nurbm)                       ! Emissivity of wall
+      real emr_u(nurbm)                       ! Emissivity of roof
+
+!   fww,fwg,fgw,fsw,fsg are the view factors used to compute the long wave
+!   and the short wave radation. 
+      real fww(nz_um,nz_um,ndm,nurbm)         !  from wall to wall
+      real fwg(nz_um,ndm,nurbm)               !  from wall to ground
+      real fgw(nz_um,ndm,nurbm)               !  from ground to wall
+      real fsw(nz_um,ndm,nurbm)               !  from sky to wall
+      real fws(nz_um,ndm,nurbm)               !  from sky to wall
+      real fsg(ndm,nurbm)                     !  from sky to ground
+
+!    Roughness parameters
+      real z0g_u(nurbm)         ! The ground's roughness length
+      real z0r_u(nurbm)         ! The roof's roughness length
+
+!    Street parameters
+      integer nd_u(nurbm)       ! Number of street direction for each urban class 
+      real strd_u(ndm,nurbm)    ! Street length (fix to greater value to the horizontal length of the cells)
+      real drst_u(ndm,nurbm)    ! Street direction
+      real ws_u(ndm,nurbm)      ! Street width
+      real bs_u(ndm,nurbm)      ! Building width
+      real h_b(nz_um,nurbm)     ! Bulding's heights
+      real d_b(nz_um,nurbm)     ! Probability that a building has an height h_b
+      real ss_u(nz_um,nurbm)  ! Probability that a building has an height equal to z
+      real pb_u(nz_um,nurbm)  ! Probability that a building has an height greater or equal to z
+
+
+!    Grid parameters
+      integer nz_u(nurbm)       ! Number of layer in the urban grid
+      
+      real z_u(nz_um)         ! Height of the urban grid levels
+
+! 1D array used for the input and output of the routine "urban"
+
+      real z1D(kms:kme)               ! vertical coordinates
+      real ua1D(kms:kme)                ! wind speed in the x directions
+      real va1D(kms:kme)                ! wind speed in the y directions
+      real pt1D(kms:kme)                ! potential temperature
+      real da1D(kms:kme)                ! air density
+      real pr1D(kms:kme)                ! air pressure
+      real pt01D(kms:kme)               ! reference potential temperature
+      real zr1D                    ! zenith angle
+      real deltar1D                ! declination of the sun
+      real ah1D                    ! hour angle (it should come from the radiation routine)
+      real rs1D                    ! solar radiation
+      real rld1D                   ! downward flux of the longwave radiation
+
+
+      real tw1D(2*ndm,nz_um,nwr_u)  ! temperature in each layer of the wall
+      real tg1D(ndm,ng_u)          ! temperature in each layer of the ground
+      real tr1D(ndm,nz_um,nwr_u)  ! temperature in each layer of the roof
+      real sfw1D(2*ndm,nz_um)      ! sensible heat flux from walls
+      real sfg1D(ndm)              ! sensible heat flux from ground (road)
+      real sfr1D(ndm,nz_um)      ! sensible heat flux from roofs
+      real sf1D(kms:kme)              ! surface of the urban grid cells
+      real vl1D(kms:kme)                ! volume of the urban grid cells
+      real a_u1D(kms:kme)               ! Implicit component of the momentum sources or sinks in the X-direction
+      real a_v1D(kms:kme)               ! Implicit component of the momentum sources or sinks in the Y-direction
+      real a_t1D(kms:kme)               ! Implicit component of the heat sources or sinks
+      real a_e1D(kms:kme)               ! Implicit component of the TKE sources or sinks
+      real b_u1D(kms:kme)               ! Explicit component of the momentum sources or sinks in the X-direction
+      real b_v1D(kms:kme)               ! Explicit component of the momentum sources or sinks in the Y-direction
+      real b_t1D(kms:kme)               ! Explicit component of the heat sources or sinks
+      real b_e1D(kms:kme)               ! Explicit component of the TKE sources or sinks
+      real dlg1D(kms:kme)               ! Height above ground (L_ground in formula (24) of the BLM paper). 
+      real dl_u1D(kms:kme)              ! Length scale (lb in formula (22) ofthe BLM paper)
+      real tsk1D                        ! Average of the road surface temperatures
+      real time_bep
+! arrays used to collapse indexes
+      integer ind_zwd(nz_um,nwr_u,ndm)
+      integer ind_gd(ng_u,ndm)
+      integer ind_zd(nz_um,ndm)
+!
+      integer ix,iy,iz,iurb,id,iz_u,iw,ig,ir,ix1,iy1,k
+      integer it, nint
+      integer iii
+      real time_h,tempo,shtot
+      logical first
+      character(len=80) :: text
+      data first/.true./
+      save first,time_bep 
+
+      save alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,                      &
+          albg_u,albw_u,albr_u,emg_u,emw_u,emr_u,fww,fwg,fgw,fsw,fws,fsg,   &
+          z0g_u,z0r_u, nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u,  &
+          nz_u,z_u 
+
+!------------------------------------------------------------------------
+!    Calculation of the momentum, heat and turbulent kinetic fluxes
+!     produced by builgings
+!
+! Reference:
+! Martilli, A., Clappier, A., Rotach, M.W.:2002, 'AN URBAN SURFACE EXCHANGE
+! PARAMETERISATION FOR MESOSCALE MODELS', Boundary-Layer Meteorolgy 104:
+! 261-304
+!------------------------------------------------------------------------
+!prepare the arrays to collapse indexes
+
+      if(num_urban_layers.lt.nz_um*ndm*nwr_u)then
+        write(*,*)'num_urban_layers too small, please increase to at least ', nz_um*ndm*nwr_u
+        stop
+      endif
+      iii=0
+      do iz_u=1,nz_um
+      do iw=1,nwr_u
+      do id=1,ndm
+       iii=iii+1
+       ind_zwd(iz_u,iw,id)=iii
+      enddo
+      enddo
+      enddo
+
+      iii=0
+      do ig=1,ng_u
+      do id=1,ndm
+       iii=iii+1
+       ind_gd(ig,id)=iii
+      enddo
+      enddo
+
+      iii=0
+      do iz_u=1,nz_um
+      do id=1,ndm
+       iii=iii+1
+       ind_zd(iz_u,id)=iii
+      enddo
+      enddo
+      do ix=its,ite
+      do iy=jts,jte
+       z(ix,kts,iy)=0.
+       do iz=kts+1,kte+1
+        z(ix,iz,iy)=z(ix,iz-1,iy)+dz8w(ix,iz-1,iy)
+       enddo
+      enddo
+      enddo
+
+      if (first) then                           ! True only on first call
+         call init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,&
+                twini_u,trini_u,tgini_u,albg_u,albw_u,albr_u,emg_u,emw_u,&
+                emr_u,z0g_u,z0r_u,nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b)
+
+!      Initialisation of the urban parameters and calculation of the view factors
+       call icBEP(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,          & 
+                 albg_u,albw_u,albr_u,emg_u,emw_u,emr_u,           & 
+                 fww,fwg,fgw,fsw,fws,fsg,                          & 
+                 z0g_u,z0r_u,                                      & 
+                 nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u,   & 
+                 nz_u,z_u,                                         & 
+                 twini_u,trini_u)                                  
+
+       first=.false.
+
+      endif ! first
+      
+      do ix=its,ite
+      do iy=jts,jte
+        if (FRC_URB2D(ix,iy).gt.0.) then    ! Calling BEP only for existing urban classes.
+	
+         iurb=UTYPE_URB2D(ix,iy)
+
+       do iz= kts,kte
+          ua1D(iz)=u_phy(ix,iz,iy)
+          va1D(iz)=v_phy(ix,iz,iy)
+	  pt1D(iz)=th_phy(ix,iz,iy)
+	  da1D(iz)=rho(ix,iz,iy)
+	  pr1D(iz)=p_phy(ix,iz,iy)
+!	  pt01D(iz)=th_phy(ix,iz,iy)
+	  pt01D(iz)=300.
+	  z1D(iz)=z(ix,iz,iy)
+          a_u1D(iz)=0.
+          a_v1D(iz)=0.
+          a_t1D(iz)=0.
+          a_e1D(iz)=0.
+          b_u1D(iz)=0.
+          b_v1D(iz)=0.
+          b_t1D(iz)=0.
+          b_e1D(iz)=0.           
+         enddo
+	 z1D(kte+1)=z(ix,kte+1,iy)
+
+         do id=1,ndm
+         do iz_u=1,nz_um
+         do iw=1,nwr_u
+!          tw1D(2*id-1,iz_u,iw)=tw1_u(ix,iy,ind_zwd(iz_u,iw,id))
+!          tw1D(2*id,iz_u,iw)=tw2_u(ix,iy,ind_zwd(iz_u,iw,id))
+            if(ind_zwd(iz_u,iw,id).gt.num_urban_layers)write(*,*)'ind_zwd too big w',ind_zwd(iz_u,iw,id)
+          tw1D(2*id-1,iz_u,iw)=tw1_urb4d(ix,ind_zwd(iz_u,iw,id),iy)
+          tw1D(2*id,iz_u,iw)=tw2_urb4d(ix,ind_zwd(iz_u,iw,id),iy)
+         enddo
+         enddo
+         enddo
+	
+         do id=1,ndm
+          do ig=1,ng_u
+!           tg1D(id,ig)=tg_u(ix,iy,ind_gd(ig,id))
+           tg1D(id,ig)=tgb_urb4d(ix,ind_gd(ig,id),iy)
+          enddo
+          do iz_u=1,nz_um
+          do ir=1,nwr_u
+!           tr1D(id,iz_u,ir)=tr_u(ix,iy,ind_zwd(iz_u,ir,id))
+            if(ind_zwd(iz_u,ir,id).gt.num_urban_layers)write(*,*)'ind_zwd too big r',ind_zwd(iz_u,ir,id)
+           tr1D(id,iz_u,ir)=trb_urb4d(ix,ind_zwd(iz_u,ir,id),iy)
+          enddo
+          enddo
+         enddo
+
+         do id=1,ndm
+	 do iz=1,nz_um
+!	  sfw1D(2*id-1,iz)=sfw1(ix,iy,ind_zd(iz,id))
+!	  sfw1D(2*id,iz)=sfw2(ix,iy,ind_zd(iz,id))
+	  sfw1D(2*id-1,iz)=sfw1_urb3d(ix,ind_zd(iz,id),iy)
+	  sfw1D(2*id,iz)=sfw2_urb3d(ix,ind_zd(iz,id),iy)
+	 enddo
+	 enddo
+	 
+	 do id=1,ndm
+!	  sfg1D(id)=sfg(ix,iy,id)
+	  sfg1D(id)=sfg_urb3d(ix,id,iy)
+	 enddo
+	 
+	 do id=1,ndm
+	 do iz=1,nz_um
+!	  sfr1D(id,iz)=sfr(ix,iy,ind_zd(iz,id))
+	  sfr1D(id,iz)=sfr_urb3d(ix,ind_zd(iz,id),iy)
+	 enddo
+	 enddo
+
+         
+         rs1D=swdown(ix,iy)
+         rld1D=glw(ix,iy)
+         time_h=(itimestep*dt)/3600.+gmt
+
+         zr1D=acos(COSZ_URB2D(ix,iy))
+         deltar1D=DECLIN_URB
+         ah1D=OMG_URB2D(ix,iy)
+!	 call angle(xlong(ix,iy),xlat(ix,iy),julday,time_h,zr1D,deltar1D,ah1D)
+
+         call BEP1D(iurb,kms,kme,kts,kte,z1D,dt,ua1D,va1D,pt1D,da1D,pr1D,pt01D,  &
+                   zr1D,deltar1D,ah1D,rs1D,rld1D,                   & 
+                   alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,          & 
+                   albg_u,albw_u,albr_u,emg_u,emw_u,emr_u,          & 
+                   fww,fwg,fgw,fsw,fws,fsg,                         & 
+                   z0g_u,z0r_u,                                     & 
+                   nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u,  & 
+                   nz_u,z_u,                                        & 
+                   tw1D,tg1D,tr1D,sfw1D,sfg1D,sfr1D,                & 
+                   a_u1D,a_v1D,a_t1D,a_e1D,                         & 
+                   b_u1D,b_v1D,b_t1D,b_e1D,                         & 
+                   dlg1D,dl_u1D,tsk1D,sf1D,vl1D,rl_up(ix,iy),       &
+                   rs_abs(ix,iy),emiss(ix,iy),grdflx_urb(ix,iy))                            
+
+         do id=1,ndm
+	 do iz=1,nz_um
+	  sfw1_urb3d(ix,ind_zd(iz,id),iy)=sfw1D(2*id-1,iz) 
+	  sfw2_urb3d(ix,ind_zd(iz,id),iy)=sfw1D(2*id,iz) 
+	 enddo
+	 enddo
+ 
+	 do id=1,ndm
+	  sfg_urb3d(ix,id,iy)=sfg1D(id) 
+	 enddo
+	
+	 do id=1,ndm
+	 do iz=1,nz_um
+	  sfr_urb3d(ix,ind_zd(iz,id),iy)=sfr1D(id,iz)
+	 enddo
+	 enddo
+!
+         do id=1,ndm
+         do iz_u=1,nz_um
+         do iw=1,nwr_u
+          tw1_urb4d(ix,ind_zwd(iz_u,iw,id),iy)=tw1D(2*id-1,iz_u,iw)
+          tw2_urb4d(ix,ind_zwd(iz_u,iw,id),iy)=tw1D(2*id,iz_u,iw)
+         enddo
+         enddo
+         enddo
+        
+         do id=1,ndm
+          do ig=1,ng_u
+           tgb_urb4d(ix,ind_gd(ig,id),iy)=tg1D(id,ig)
+          enddo
+          do iz_u=1,nz_um
+          do ir=1,nwr_u
+           trb_urb4d(ix,ind_zwd(iz_u,ir,id),iy)=tr1D(id,iz_u,ir)
+          enddo
+          enddo
+         enddo
+
+        do iz= kts,kte
+          sf(ix,iz,iy)=sf1D(iz)
+          vl(ix,iz,iy)=vl1D(iz)
+          a_u(ix,iz,iy)=a_u1D(iz)
+          a_v(ix,iz,iy)=a_v1D(iz)
+          a_t(ix,iz,iy)=a_t1D(iz)
+          a_e(ix,iz,iy)=a_e1D(iz)
+          b_u(ix,iz,iy)=b_u1D(iz)
+          b_v(ix,iz,iy)=b_v1D(iz)
+          b_t(ix,iz,iy)=b_t1D(iz)
+          b_e(ix,iz,iy)=b_e1D(iz)
+          dlg(ix,iz,iy)=dlg1D(iz)
+          dl_u(ix,iz,iy)=dl_u1D(iz)
+         enddo
+         sf(ix,kte+1,iy)=sf1D(kte+1)
+!         tsk(ix,iy)=tsk1D
+!
+         endif ! FRC_URB2D
+   
+      enddo  ! iy
+      enddo  ! ix
+
+
+        time_bep=time_bep+dt
+         
+         
+      return
+      end subroutine BEP
+            
+! ===6=8===============================================================72
+
+      subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0,  &  
+                      zr,deltar,ah,rs,rld,                            & 
+                      alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,         & 
+                      albg_u,albw_u,albr_u,emg_u,emw_u,emr_u,         & 
+                      fww,fwg,fgw,fsw,fws,fsg,                        & 
+                      z0g_u,z0r_u,                                    & 
+                      nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & 
+                      nz_u,z_u,                                       & 
+                      tw,tg,tr,sfw,sfg,sfr,                           & 
+                      a_u,a_v,a_t,a_e,                                &
+                      b_u,b_v,b_t,b_e,                                & 
+                      dlg,dl_u,tsk,sf,vl,rl_up,rs_abs,emiss,grdflx_urb)                             
+
+! ----------------------------------------------------------------------
+! This routine computes the effects of buildings on momentum, heat and
+!  TKE (turbulent kinetic energy) sources or sinks and on the mixing length.
+! It provides momentum, heat and TKE sources or sinks at different levels of a
+!  mesoscale grid defined by the altitude of its cell interfaces "z" and
+!  its number of levels "nz".
+! The meteorological input parameters (wind, temperature, solar radiation)
+!  are specified on the "mesoscale grid".
+! The inputs concerning the building and street charateristics are defined
+!  on a "urban grid". The "urban grid" is defined with its number of levels
+!  "nz_u" and its space step "dz_u".
+! The input parameters are interpolated on the "urban grid". The sources or sinks
+!  are calculated on the "urban grid". Finally the sources or sinks are 
+!  interpolated on the "mesoscale grid".
+ 
+
+!  Mesoscale grid            Urban grid             Mesoscale grid
+!  
+! z(4)    ---                                               ---
+!          |                                                 |
+!          |                                                 |
+!          |   Interpolation                  Interpolation  |
+!          |            Sources or sinks calculation         |
+! z(3)    ---                                               ---
+!          | ua               ua_u  ---  uv_a         a_u    |
+!          | va               va_u   |   uv_b         b_u    |
+!          | pt               pt_u  ---  uh_b         a_v    |
+! z(2)    ---                        |    etc...      etc...---
+!          |                 z_u(1) ---                      |
+!          |                         |                       |
+! z(1) ------------------------------------------------------------
+
+!     
+! Reference:
+! Martilli, A., Clappier, A., Rotach, M.W.:2002, 'AN URBAN SURFACE EXCHANGE
+! PARAMETERISATION FOR MESOSCALE MODELS', Boundary-Layer Meteorolgy 104:
+! 261-304
+ 
+! ----------------------------------------------------------------------
+
+      implicit none
+
+ 
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+
+! Data relative to the "mesoscale grid"
+
+!      integer nz                 ! Number of vertical levels
+      integer kms,kme,kts,kte
+      real z(kms:kme)               ! Altitude above the ground of the cell interfaces.
+      real ua(kms:kme)                ! Wind speed in the x direction
+      real va(kms:kme)                ! Wind speed in the y direction
+      real pt(kms:kme)                ! Potential temperature
+      real da(kms:kme)                ! Air density
+      real pr(kms:kme)                ! Air pressure
+      real pt0(kms:kme)               ! Reference potential temperature (could be equal to "pt")
+      real dt                    ! Time step
+      real zr                    ! Zenith angle
+      real deltar                ! Declination of the sun
+      real ah                    ! Hour angle
+      real rs                    ! Solar radiation
+      real rld                   ! Downward flux of the longwave radiation
+
+! Data relative to the "urban grid"
+
+      integer iurb               ! Current urban class
+
+!    Building parameters      
+      real alag_u(nurbm)         ! Ground thermal diffusivity [m^2 s^-1]
+      real alaw_u(nurbm)         ! Wall thermal diffusivity [m^2 s^-1]
+      real alar_u(nurbm)         ! Roof thermal diffusivity [m^2 s^-1]
+      real csg_u(nurbm)          ! Specific heat of the ground material [J m^3 K^-1]
+      real csw_u(nurbm)          ! Specific heat of the wall material [J m^3 K^-1]
+      real csr_u(nurbm)          ! Specific heat of the roof material [J m^3 K^-1]
+
+!    Radiation parameters
+      real albg_u(nurbm)         ! Albedo of the ground
+      real albw_u(nurbm)         ! Albedo of the wall
+      real albr_u(nurbm)         ! Albedo of the roof
+      real emg_u(nurbm)          ! Emissivity of ground
+      real emw_u(nurbm)          ! Emissivity of wall
+      real emr_u(nurbm)          ! Emissivity of roof
+
+!    fww,fwg,fgw,fsw,fsg are the view factors used to compute the long and 
+!    short wave radation. 
+!    The calculation of these factor is explained in the Appendix A of the BLM paper
+      real fww(nz_um,nz_um,ndm,nurbm)  !  from wall to wall
+      real fwg(nz_um,ndm,nurbm)        !  from wall to ground
+      real fgw(nz_um,ndm,nurbm)        !  from ground to wall
+      real fsw(nz_um,ndm,nurbm)        !  from sky to wall
+      real fws(nz_um,ndm,nurbm)        !  from wall to sky
+      real fsg(ndm,nurbm)              !  from sky to ground
+
+!    Roughness parameters
+      real z0g_u(nurbm)            ! The ground's roughness length
+      real z0r_u(nurbm)            ! The roof's roughness length
+      
+!    Street parameters
+      integer nd_u(nurbm)          ! Number of street direction for each urban class 
+      real strd_u(ndm,nurbm)       ! Street length (set to a greater value then the horizontal length of the cells)
+      real drst_u(ndm,nurbm)       ! Street direction
+      real ws_u(ndm,nurbm)         ! Street width
+      real bs_u(ndm,nurbm)         ! Building width
+      real h_b(nz_um,nurbm)        ! Bulding's heights
+      real d_b(nz_um,nurbm)        ! The probability that a building has an height "h_b"
+      real ss_u(nz_um,nurbm)     ! The probability that a building has an height equal to "z"
+      real pb_u(nz_um,nurbm)     ! The probability that a building has an height greater or equal to "z"
+        
+!    Grid parameters
+      integer nz_u(nurbm)     ! Number of layer in the urban grid
+!      real dz_u               ! Urban grid resolution
+      real z_u(nz_um)       ! Height of the urban grid levels
+
+
+! ----------------------------------------------------------------------
+! INPUT-OUTPUT
+! ----------------------------------------------------------------------
+
+! Data relative to the "urban grid" which should be stored from the current time step to the next one
+
+      real tw(2*ndm,nz_um,nwr_u)  ! Temperature in each layer of the wall [K]
+      real tr(ndm,nz_um,nwr_u)  ! Temperature in each layer of the roof [K]
+      real tg(ndm,ng_u)          ! Temperature in each layer of the ground [K]
+      real sfw(2*ndm,nz_um)      ! Sensible heat flux from walls
+      real sfg(ndm)              ! Sensible heat flux from ground (road)
+      real sfr(ndm,nz_um)      ! Sensible heat flux from roofs
+      real gfg(ndm)             ! Heat flux transferred from the surface of the ground (road) towards the interior
+      real gfr(ndm,nz_um)     ! Heat flux transferred from the surface of the roof towards the interior
+      real gfw(2*ndm,nz_um)     ! Heat flux transfered from the surface of the walls towards the interior
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+
+! Data relative to the "mesoscale grid"
+
+      real sf(kms:kme)             ! Surface of the "mesoscale grid" cells taking into account the buildings
+      real vl(kms:kme)               ! Volume of the "mesoscale grid" cells taking into account the buildings
+     
+!    Implicit and explicit components of the source and sink terms at each levels,
+!     the fluxes can be computed as follow: FX = A*X + B   example: Heat fluxes = a_t * pt + b_t
+      real a_u(kms:kme)              ! Implicit component of the momentum sources or sinks in the X-direction
+      real a_v(kms:kme)              ! Implicit component of the momentum sources or sinks in the Y-direction
+      real a_t(kms:kme)              ! Implicit component of the heat sources or sinks
+      real a_e(kms:kme)              ! Implicit component of the TKE sources or sinks
+      real b_u(kms:kme)              ! Explicit component of the momentum sources or sinks in the X-direction
+      real b_v(kms:kme)              ! Explicit component of the momentum sources or sinks in the Y-direction
+      real b_t(kms:kme)              ! Explicit component of the heat sources or sinks
+      real b_e(kms:kme)              ! Explicit component of the TKE sources or sinks
+      real dlg(kms:kme)              ! Height above ground (L_ground in formula (24) of the BLM paper). 
+      real dl_u(kms:kme)             ! Length scale (lb in formula (22) ofthe BLM paper).
+      real tsk                  ! Average of the road surface temperatures
+      
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+
+      real dz(kms:kme)               ! vertical space steps of the "mesoscale grid"
+
+! Data interpolated from the "mesoscale grid" to the "urban grid"
+
+      real ua_u(nz_um)          ! Wind speed in the x direction
+      real va_u(nz_um)          ! Wind speed in the y direction
+      real pt_u(nz_um)          ! Potential temperature
+      real da_u(nz_um)          ! Air density
+      real pt0_u(nz_um)         ! Reference potential temperature
+      real pr_u(nz_um)          ! Air pressure
+
+! Data defining the building and street charateristics
+
+      integer nd                ! Number of street direction for the current urban class
+
+      real alag(ng_u)           ! Ground thermal diffusivity for the current urban class [m^2 s^-1] 
+      real alar(nwr_u)           ! Roof thermal diffusivity for the current urban class [m^2 s^-1]
+      real alaw(nwr_u)           ! Walls thermal diffusivity for the current urban class [m^2 s^-1] 
+      real csg(ng_u)            ! Specific heat of the ground material of the current urban class [J m^3 K^-1]
+      real csr(nwr_u)            ! Specific heat of the roof material for the current urban class [J m^3 K^-1]
+      real csw(nwr_u)            ! Specific heat of the wall material for the current urban class [J m^3 K^-1]
+
+      real z0(ndm,nz_um)      ! Roughness lengths "profiles"
+      real ws(ndm)              ! Street widths of the current urban class
+      real bs(ndm)              ! Building widths of the current urban class
+      real strd(ndm)            ! Street lengths for the current urban class
+      real drst(ndm)            ! Street directions for the current urban class
+      real ss(nz_um)          ! Probability to have a building with height h
+      real pb(nz_um)          ! Probability to have a building with an height equal
+
+! Solar radiation at each level of the "urban grid"
+
+      real rsg(ndm)             ! Short wave radiation from the ground
+      real rsw(2*ndm,nz_um)     ! Short wave radiation from the walls
+      real rlg(ndm)             ! Long wave radiation from the ground
+      real rlw(2*ndm,nz_um)     ! Long wave radiation from the walls
+
+! Potential temperature of the surfaces at each level of the "urban grid"
+
+      real ptg(ndm)             ! Ground potential temperatures 
+      real ptr(ndm,nz_um)     ! Roof potential temperatures 
+      real ptw(2*ndm,nz_um)     ! Walls potential temperatures 
+
+ 
+! Explicit and implicit component of the momentum, temperature and TKE sources or sinks on
+!  vertical surfaces (walls) ans horizontal surfaces (roofs and street)
+! The fluxes can be computed as follow: Fluxes of X = A*X + B
+!  Example: Momentum fluxes on vertical surfaces = uva_u * ua_u + uvb_u
+
+      real uhb_u(ndm,nz_um)   ! U (wind component) Horizontal surfaces, B (explicit) term
+      real uva_u(2*ndm,nz_um)   ! U (wind component)   Vertical surfaces, A (implicit) term
+      real uvb_u(2*ndm,nz_um)   ! U (wind component)   Vertical surfaces, B (explicit) term
+      real vhb_u(ndm,nz_um)   ! V (wind component) Horizontal surfaces, B (explicit) term
+      real vva_u(2*ndm,nz_um)   ! V (wind component)   Vertical surfaces, A (implicit) term
+      real vvb_u(2*ndm,nz_um)   ! V (wind component)   Vertical surfaces, B (explicit) term
+      real thb_u(ndm,nz_um)   ! Temperature        Horizontal surfaces, B (explicit) term
+      real tva_u(2*ndm,nz_um)   ! Temperature          Vertical surfaces, A (implicit) term
+      real tvb_u(2*ndm,nz_um)   ! Temperature          Vertical surfaces, B (explicit) term
+      real ehb_u(ndm,nz_um)   ! Energy (TKE)       Horizontal surfaces, B (explicit) term
+      real evb_u(2*ndm,nz_um)   ! Energy (TKE)         Vertical surfaces, B (explicit) term
+      
+!
+      real rs_abs ! solar radiation absorbed by urban surfaces 
+      real rl_up ! longwave radiation emitted by urban surface to the atmosphere 
+      real emiss ! mean emissivity of the urban surface
+      real grdflx_urb ! ground heat flux
+      real shtot,aaa
+      real dt_int ! internal time step
+      integer nt_int ! number of internal time step
+      integer iz,id, it_int
+      integer iwrong,iw,ix,iy
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+! Fix some usefull parameters for the computation of the sources or sinks
+
+      do iz=kts,kte
+         dz(iz)=z(iz+1)-z(iz)
+      end do
+      call param(iurb,nz_u(iurb),nd_u(iurb),         &
+                       csg_u,csg,alag_u,alag,csr_u,csr,             &
+                       alar_u,alar,csw_u,csw,alaw_u,alaw,           &
+                       ws_u,ws,bs_u,bs,z0g_u,z0r_u,z0,              &
+                       strd_u,strd,drst_u,drst,ss_u,ss,pb_u,pb)
+
+! Interpolation on the "urban grid"
+      call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,ua,ua_u)
+      call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,va,va_u)
+      call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pt,pt_u)
+      call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pt0,pt0_u)
+      call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pr,pr_u)
+      call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,da,da_u)
+
+                   
+! Compute the modification of the radiation due to the buildings
+
+      call modif_rad(iurb,nd_u(iurb),nz_u(iurb),z_u,ws, &
+                    drst,strd,ss,pb,                              &
+                    tw,tg,albg_u(iurb),albw_u(iurb),              &
+                    emw_u(iurb),emg_u(iurb),                      &
+                    fww,fwg,fgw,fsw,fsg,                          &
+                    zr,deltar,ah,                                 &
+                    rs,rld,rsw,rsg,rlw,rlg)                       
+ 
+! calculation of the urban albedo and the upward long wave radiation
+       call upward_rad(nd_u(iurb),iurb,nz_u(iurb),ws,bs,sigma,fsw,fsg,pb,ss,   &
+                       tg,emg_u(iurb),albg_u(iurb),rlg,rsg,sfg,                & 
+                       tw,emw_u(iurb),albw_u(iurb),rlw,rsw,sfw,                & 
+                       tr,emr_u(iurb),albr_u(iurb),rld,rs,sfr,                 & 
+                       rs_abs,rl_up,emiss,grdflx_urb)               
+        
+! Compute the surface temperatures
+     
+
+      call surf_temp(nz_u(iurb),nd_u(iurb),pr_u,dt,ss,                  & 
+                    rs,rld,rsg,rlg,rsw,rlw,                             &
+                    tg,alag,csg,emg_u(iurb),albg_u(iurb),ptg,sfg,gfg,  &
+                    tr,alar,csr,emr_u(iurb),albr_u(iurb),ptr,sfr,gfr,  &
+                    tw,alaw,csw,emw_u(iurb),albw_u(iurb),ptw,sfw,gfw)  
+      
+      
+! Compute the implicit and explicit components of the sources or sinks on the "urban grid"
+       
+      call buildings(nd_u(iurb),nz_u(iurb),z0,ua_u,va_u,                & 
+                     pt_u,pt0_u,ptg,ptr,da_u,ptw,drst,                  &                      
+                     uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u,         & 
+                     uhb_u,vhb_u,thb_u,ehb_u,ss,dt)                        
+ 
+         
+! Calculation of the sensible heat fluxes for the ground, the wall and roof
+! Sensible Heat Flux = density * Cp_U * ( A* potential temperature + B )
+! where A and B are the implicit and explicit components of the heat sources or sinks.
+!  
+! 
+ 
+      do id=1,nd_u(iurb)         
+         sfg(id)=-da_u(1)*cp_u*thb_u(id,1)
+         do iz=2,nz_u(iurb)
+            sfr(id,iz)=-da_u(iz)*cp_u*thb_u(id,iz)
+         enddo
+         
+         do iz=1,nz_u(iurb)
+            sfw(2*id-1,iz)=-da_u(iz)*cp_u*(tvb_u(2*id-1,iz)+     &
+                tva_u(2*id-1,iz)*pt_u(iz))
+            sfw(2*id,iz)=-da_u(iz)*cp_u*(tvb_u(2*id,iz)+         &
+                tva_u(2*id,iz)*pt_u(iz)) 
+         enddo
+      enddo
+      
+! calculation of the urban albedo and the upward long wave radiation
+          
+!       call upward_rad(nd_u(iurb),iurb,nz_u(iurb),ws,bs,sigma,fsw,fsg,pb,ss,  &
+!                       tg,emg_u(iurb),albg_u(iurb),rlg,rsg,                & 
+!                       tw,emw_u(iurb),albw_u(iurb),rlw,rsw,                & 
+!                       tr,emr_u(iurb),albr_u(iurb),rld,rs,                  & 
+!                       rs_abs,rl_up,emiss)             
+
+! Interpolation on the "mesoscale grid"
+
+      call urban_meso(nd_u(iurb),kms,kme,kts,kte,nz_u(iurb),z,dz,z_u,pb,ss,bs,ws,sf,  & 
+                     vl,uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u,       &
+                     uhb_u,vhb_u,thb_u,ehb_u,                            &
+                     a_u,a_v,a_t,a_e,b_u,b_v,b_t,b_e)                    
+       
+
+! computation of the mean road temperature tsk (this value could be used 
+! to replace the surface temperature in the radiation routines, if needed).
+
+!      tsk=0.
+!      do id=1,nd_u(iurb)
+!         tsk=tsk+tg(id,ng_u)/nd_u(iurb)
+!      enddo
+
+! Calculation of the length scale taking into account the buildings effects
+
+      call interp_length(nd_u(iurb),kms,kme,kts,kte,nz_u(iurb),z_u,z,ss,ws,bs,dlg,dl_u)
+
+      return
+      end subroutine BEP1D
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+       subroutine param(iurb,nz,nd,                                   &
+                       csg_u,csg,alag_u,alag,csr_u,csr,               &
+                       alar_u,alar,csw_u,csw,alaw_u,alaw,             &
+                       ws_u,ws,bs_u,bs,z0g_u,z0r_u,z0,                &  
+                       strd_u,strd,drst_u,drst,ss_u,ss,pb_u,pb)        
+
+! ----------------------------------------------------------------------
+!    This routine prepare some usefull parameters       
+! ----------------------------------------------------------------------
+
+      implicit none
+
+  
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      integer iurb                 ! Current urban class
+      integer nz                   ! Number of vertical urban levels in the current class
+      integer nd                   ! Number of street direction for the current urban class
+      real alag_u(nurbm)           ! Ground thermal diffusivity [m^2 s^-1]
+      real alar_u(nurbm)           ! Roof thermal diffusivity [m^2 s^-1]
+      real alaw_u(nurbm)           ! Wall thermal diffusivity [m^2 s^-1]
+      real bs_u(ndm,nurbm)         ! Building width
+      real csg_u(nurbm)            ! Specific heat of the ground material [J m^3 K^-1]
+      real csr_u(nurbm)            ! Specific heat of the roof material [J m^3 K^-1]
+      real csw_u(nurbm)            ! Specific heat of the wall material [J m^3 K^-1]
+      real drst_u(ndm,nurbm)       ! Street direction
+      real strd_u(ndm,nurbm)       ! Street length 
+      real ws_u(ndm,nurbm)         ! Street width
+      real z0g_u(nurbm)            ! The ground's roughness length
+      real z0r_u(nurbm)            ! The roof's roughness length
+      real ss_u(nz_um,nurbm)     ! The probability that a building has an height equal to "z"
+      real pb_u(nz_um,nurbm)     ! The probability that a building has an height greater or equal to "z"
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real alag(ng_u)           ! Ground thermal diffusivity at each ground levels
+      real alar(nwr_u)           ! Roof thermal diffusivity at each roof levels
+      real alaw(nwr_u)           ! Wall thermal diffusivity at each wall levels
+      real csg(ng_u)            ! Specific heat of the ground material at each ground levels
+      real csr(nwr_u)            ! Specific heat of the roof material at each roof levels
+      real csw(nwr_u)            ! Specific heat of the wall material at each wall levels
+      real bs(ndm)              ! Building width for the current urban class
+      real drst(ndm)            ! street directions for the current urban class
+      real strd(ndm)            ! Street lengths for the current urban class
+      real ws(ndm)              ! Street widths of the current urban class
+      real z0(ndm,nz_um)      ! Roughness lengths "profiles"
+      real ss(nz_um)          ! Probability to have a building with height h
+      real pb(nz_um)          ! Probability to have a building with an height equal
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer id,ig,ir,iw,iz
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------     
+!
+!Initialize the variables
+!
+      ss=0.
+      pb=0.
+      csg=0.
+      alag=0.
+      csr=0.
+      alar=0.
+      csw=0.
+      alaw=0.
+      z0=0.
+      ws=0.
+      bs=0.
+      strd=0.
+      drst=0.
+      
+      do iz=1,nz+1
+         ss(iz)=ss_u(iz,iurb)
+         pb(iz)=pb_u(iz,iurb)
+      end do
+                 
+       do ig=1,ng_u
+        csg(ig)=csg_u(iurb)
+        alag(ig)=alag_u(iurb)
+       enddo
+       
+       do ir=1,nwr_u
+        csr(ir)=csr_u(iurb)
+        alar(ir)=alar_u(iurb)
+       enddo
+       
+       do iw=1,nwr_u
+        csw(iw)=csw_u(iurb)
+        alaw(iw)=alaw_u(iurb)
+       enddo
+       
+       do id=1,nd
+        z0(id,1)=z0g_u(iurb)
+        do iz=2,nz+1
+         z0(id,iz)=z0r_u(iurb)
+        enddo
+       enddo
+      
+       do id=1,nd
+        ws(id)=ws_u(id,iurb)
+        bs(id)=bs_u(id,iurb)
+        strd(id)=strd_u(id,iurb)
+        drst(id)=drst_u(id,iurb)     
+       enddo
+
+       
+       return
+       end subroutine param
+       
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+      subroutine interpol(kms,kme,kts,kte,nz_u,z,z_u,c,c_u)
+
+! ----------------------------------------------------------------------
+!  This routine interpolate para
+!  meters from the "mesoscale grid" to
+!  the "urban grid".
+!  See p300 Appendix B.1 of the BLM paper.
+! ----------------------------------------------------------------------
+
+      implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+! Data relative to the "mesoscale grid"
+      integer kts,kte,kms,kme            
+      real z(kms:kme)          ! Altitude of the cell interface
+      real c(kms:kme)            ! Parameter which has to be interpolated
+! Data relative to the "urban grid"
+      integer nz_u          ! Number of levels
+!!    real z_u(nz_u+1)      ! Altitude of the cell interface
+      real z_u(nz_um)      ! Altitude of the cell interface
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+!!    real c_u(nz_u)        ! Interpolated paramters in the "urban grid"
+      real c_u(nz_um)        ! Interpolated paramters in the "urban grid"
+
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer iz_u,iz
+      real ctot,dz
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+       do iz_u=1,nz_u
+        ctot=0.
+        do iz=kts,kte
+         dz=max(min(z(iz+1),z_u(iz_u+1))-max(z(iz),z_u(iz_u)),0.)
+         ctot=ctot+c(iz)*dz
+        enddo
+        c_u(iz_u)=ctot/(z_u(iz_u+1)-z_u(iz_u))
+       enddo
+       
+       return
+       end subroutine interpol
+         
+! ===6=8===============================================================72       
+! ===6=8===============================================================72     
+
+      subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb,    &
+                          tw,tg,albg,albw,emw,emg,                     &
+                          fww,fwg,fgw,fsw,fsg,                         &
+                          zr,deltar,ah,                                &    
+                          rs,rl,rsw,rsg,rlw,rlg)                       
+ 
+! ----------------------------------------------------------------------
+! This routine computes the modification of the short wave and 
+!  long wave radiation due to the buildings.
+! ----------------------------------------------------------------------
+
+      implicit none
+ 
+ 
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      integer iurb              ! current urban class
+      integer nd                ! Number of street direction for the current urban class
+      integer nz_u              ! Number of layer in the urban grid
+      real z(nz_um)           ! Height of the urban grid levels
+      real ws(ndm)              ! Street widths of the current urban class
+      real drst(ndm)            ! street directions for the current urban class
+      real strd(ndm)            ! Street lengths for the current urban class
+      real ss(nz_um)          ! probability to have a building with height h
+      real pb(nz_um)          ! probability to have a building with an height equal
+      real tw(2*ndm,nz_um,nwr_u) ! Temperature in each layer of the wall [K]
+      real tg(ndm,ng_u)         ! Temperature in each layer of the ground [K]
+      real albg                 ! Albedo of the ground for the current urban class
+      real albw                 ! Albedo of the wall for the current urban class
+      real emg                  ! Emissivity of ground for the current urban class
+      real emw                  ! Emissivity of wall for the current urban class
+      real fgw(nz_um,ndm,nurbm)       ! View factors from ground to wall
+      real fsg(ndm,nurbm)             ! View factors from sky to ground
+      real fsw(nz_um,ndm,nurbm)       ! View factors from sky to wall
+      real fws(nz_um,ndm,nurbm)       ! View factors from wall to sky
+      real fwg(nz_um,ndm,nurbm)       ! View factors from wall to ground
+      real fww(nz_um,nz_um,ndm,nurbm) ! View factors from wall to wall
+      real ah                   ! Hour angle (it should come from the radiation routine)
+      real zr                   ! zenith angle
+      real deltar               ! Declination of the sun
+      real rs                   ! solar radiation
+      real rl                   ! downward flux of the longwave radiation
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real rlg(ndm)             ! Long wave radiation at the ground
+      real rlw(2*ndm,nz_um)     ! Long wave radiation at the walls
+      real rsg(ndm)             ! Short wave radiation at the ground
+      real rsw(2*ndm,nz_um)     ! Short wave radiation at the walls
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+
+      integer id,iz
+
+!  Calculation of the shadow effects
+
+      call shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z,  &
+                     rs,rsw,rsg)
+
+! Calculation of the reflection effects          
+      do id=1,nd
+         call long_rad(iurb,nz_u,id,emw,emg,                 &
+                      fwg,fww,fgw,fsw,fsg,tg,tw,rlg,rlw,rl,pb)
+         
+         call short_rad(iurb,nz_u,id,albw,albg,fwg,fww,fgw,rsg,rsw,pb)
+  
+      enddo
+      
+      return
+      end subroutine modif_rad
+
+
+! ===6=8===============================================================72  
+! ===6=8===============================================================72     
+
+      subroutine surf_temp(nz_u,nd,pr,dt,ss,rs,rl,rsg,rlg,rsw,rlw,     &
+                          tg,alag,csg,emg,albg,ptg,sfg,gfg,             &
+                          tr,alar,csr,emr,albr,ptr,sfr,gfr,             &
+                          tw,alaw,csw,emw,albw,ptw,sfw,gfw)             
+                 
+
+! ----------------------------------------------------------------------
+! Computation of the surface temperatures for walls, ground and roofs 
+! ----------------------------------------------------------------------
+
+      implicit none
+      
+      
+      
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      integer nz_u              ! Number of vertical layers defined in the urban grid
+      integer nd                ! Number of street direction for the current urban class
+      real alag(ng_u)           ! Ground thermal diffusivity for the current urban class [m^2 s^-1] 
+      real alar(nwr_u)           ! Roof thermal diffusivity for the current urban class [m^2 s^-1]  
+      real alaw(nwr_u)           ! Wall thermal diffusivity for the current urban class [m^2 s^-1]  
+      real albg                 ! Albedo of the ground for the current urban class
+      real albr                 ! Albedo of the roof for the current urban class
+      real albw                 ! Albedo of the wall for the current urban class
+      real csg(ng_u)            ! Specific heat of the ground material of the current urban class [J m^3 K^-1]
+      real csr(nwr_u)            ! Specific heat of the roof material for the current urban class [J m^3 K^-1]
+      real csw(nwr_u)            ! Specific heat of the wall material for the current urban class [J m^3 K^-1]
+      real dt                   ! Time step
+      real emg                  ! Emissivity of ground for the current urban class
+      real emr                  ! Emissivity of roof for the current urban class
+      real emw                  ! Emissivity of wall for the current urban class
+      real pr(nz_um)            ! Air pressure
+      real rs                   ! Solar radiation
+      real rl                   ! Downward flux of the longwave radiation
+      real rlg(ndm)             ! Long wave radiation at the ground
+      real rlw(2*ndm,nz_um)     ! Long wave radiation at the walls
+      real rsg(ndm)             ! Short wave radiation at the ground
+      real rsw(2*ndm,nz_um)     ! Short wave radiation at the walls
+      real sfg(ndm)             ! Sensible heat flux from ground (road)
+      real sfr(ndm,nz_um)     ! Sensible heat flux from roofs
+      real sfw(2*ndm,nz_um)     ! Sensible heat flux from walls
+      real gfg(ndm)             ! Heat flux transferred from the surface of the ground (road) toward the interior
+      real gfr(ndm,nz_um)     ! Heat flux transferred from the surface of the roof toward the interior
+      real gfw(2*ndm,nz_um)     ! Heat flux transfered from the surface of the walls toward the interior
+      real ss(nz_um)          ! Probability to have a building with height h
+      real tg(ndm,ng_u)         ! Temperature in each layer of the ground [K]
+      real tr(ndm,nz_um,nwr_u) ! Temperature in each layer of the roof [K]
+      real tw(2*ndm,nz_um,nwr_u) ! Temperature in each layer of the wall [K]
+      
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real ptg(ndm)             ! Ground potential temperatures 
+      real ptr(ndm,nz_um)     ! Roof potential temperatures 
+      real ptw(2*ndm,nz_um)     ! Walls potential temperatures 
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer id,ig,ir,iw,iz
+
+      real rtg(ndm)             ! Total radiation at ground(road) surface (solar+incoming long+outgoing long)
+      real rtr(ndm,nz_um)     ! Total radiation at roof surface (solar+incoming long+outgoing long)
+      real rtw(2*ndm,nz_um)     ! Radiation at walls surface (solar+incoming long+outgoing long)
+      real tg_tmp(ng_u)
+      real tr_tmp(nwr_u)
+      real tw_tmp(nwr_u)
+
+      real dzg_u(ng_u)          ! Layer sizes in the ground
+
+      real dzr_u(nwr_u)          ! Layers sizes in the roof
+         
+      real dzw_u(nwr_u)          ! Layer sizes in the wall
+      
+
+      data dzg_u /0.2,0.12,0.08,0.05,0.03,0.02,0.02,0.01,0.005,0.0025/
+      data dzr_u /0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.01,0.005,0.0025/   
+      data dzw_u /0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.01,0.005,0.0025/
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+        
+   
+      do id=1,nd
+
+!      Calculation for the ground surfaces
+       do ig=1,ng_u
+        tg_tmp(ig)=tg(id,ig)
+       end do
+!	        
+       call soil_temp(ng_u,dzg_u,tg_tmp,ptg(id),alag,csg,        &
+                     rsg(id),rlg(id),pr(1),                    &
+                     dt,emg,albg,                              &
+                     rtg(id),sfg(id),gfg(id))    
+       do ig=1,ng_u
+        tg(id,ig)=tg_tmp(ig)
+       end do
+
+!      Calculation for the roofs surfaces
+         
+       do iz=2,nz_u
+            
+        if(ss(iz).gt.0.)then
+         do ir=1,nwr_u        
+          tr_tmp(ir)=tr(id,iz,ir)
+         end do
+        
+         call soil_temp(nwr_u,dzr_u,tr_tmp,ptr(id,iz),          &
+                       alar,csr,rs,rl,pr(iz),dt,emr,albr,    &
+                       rtr(id,iz),sfr(id,iz),gfr(id,iz))     
+         do ir=1,nwr_u        
+          tr(id,iz,ir)=tr_tmp(ir)
+         end do
+       
+        end if
+            
+       end do !iz
+
+!      Calculation for the walls surfaces
+         
+       do iz=1,nz_u
+            
+        do iw=1,nwr_u        
+         tw_tmp(iw)=tw(2*id-1,iz,iw)
+        end do
+        call soil_temp(nwr_u,dzw_u,tw_tmp,ptw(2*id-1,iz),alaw,          &
+                      csw,                                           &     
+                      rsw(2*id-1,iz),rlw(2*id-1,iz),                 &     
+                      pr(iz),dt,emw,                                 &    
+                albw,rtw(2*id-1,iz),sfw(2*id-1,iz),gfw(2*id-1,iz))   
+
+        do iw=1,nwr_u        
+         tw(2*id-1,iz,iw)=tw_tmp(iw)
+        end do
+            
+        do iw=1,nwr_u        
+         tw_tmp(iw)=tw(2*id,iz,iw)
+        end do
+            
+        call soil_temp(nwr_u,dzw_u,tw_tmp,ptw(2*id,iz),alaw,          &      
+                      csw,                                         &     
+                      rsw(2*id,iz),rlw(2*id,iz),                   &     
+                      pr(iz),dt,emw,                               &     
+               albw,rtw(2*id,iz),sfw(2*id,iz),gfw(2*id,iz))        
+         do iw=1,nwr_u        
+          tw(2*id,iz,iw)=tw_tmp(iw)
+         end do
+                   
+        end do !iz
+	
+      end do !id
+      
+      return
+      end subroutine surf_temp
+     
+! ===6=8===============================================================72     
+! ===6=8===============================================================72  
+
+      subroutine buildings(nd,nz,z0,ua_u,va_u,pt_u,pt0_u,         &
+                        ptg,ptr,da_u,ptw,                            &
+                        drst,uva_u,vva_u,uvb_u,vvb_u,                &
+                        tva_u,tvb_u,evb_u,                           &
+                        uhb_u,vhb_u,thb_u,ehb_u,ss,dt)                  
+
+! ----------------------------------------------------------------------
+! This routine computes the sources or sinks of the different quantities 
+! on the urban grid. The actual calculation is done in the subroutines 
+! called flux_wall, and flux_flat.
+! ----------------------------------------------------------------------
+
+      implicit none
+
+        
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      integer nd                ! Number of street direction for the current urban class
+      integer nz                ! number of vertical space steps
+      real ua_u(nz_um)          ! Wind speed in the x direction on the urban grid
+      real va_u(nz_um)          ! Wind speed in the y direction on the urban grid
+      real da_u(nz_um)          ! air density on the urban grid
+      real drst(ndm)            ! Street directions for the current urban class
+      real dz
+      real pt_u(nz_um)          ! Potential temperature on the urban grid
+      real pt0_u(nz_um)         ! reference potential temperature on the urban grid
+      real ptg(ndm)             ! Ground potential temperatures 
+      real ptr(ndm,nz_um)     ! Roof potential temperatures 
+      real ptw(2*ndm,nz_um)     ! Walls potential temperatures 
+      real ss(nz_um)          ! probability to have a building with height h
+      real z0(ndm,nz_um)      ! Roughness lengths "profiles"
+      real dt ! time step
+
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+! Explicit and implicit component of the momentum, temperature and TKE sources or sinks on
+! vertical surfaces (walls) and horizontal surfaces (roofs and street)
+! The fluxes can be computed as follow: Fluxes of X = A*X + B
+!  Example: Momentum fluxes on vertical surfaces = uva_u * ua_u + uvb_u
+
+      real uhb_u(ndm,nz_um)   ! U (wind component) Horizontal surfaces, B (explicit) term
+      real uva_u(2*ndm,nz_um)   ! U (wind component)   Vertical surfaces, A (implicit) term
+      real uvb_u(2*ndm,nz_um)   ! U (wind component)   Vertical surfaces, B (explicit) term
+      real vhb_u(ndm,nz_um)   ! V (wind component) Horizontal surfaces, B (explicit) term
+      real vva_u(2*ndm,nz_um)   ! V (wind component)   Vertical surfaces, A (implicit) term
+      real vvb_u(2*ndm,nz_um)   ! V (wind component)   Vertical surfaces, B (explicit) term
+      real thb_u(ndm,nz_um)   ! Temperature        Horizontal surfaces, B (explicit) term
+      real tva_u(2*ndm,nz_um)   ! Temperature          Vertical surfaces, A (implicit) term
+      real tvb_u(2*ndm,nz_um)   ! Temperature          Vertical surfaces, B (explicit) term
+      real ehb_u(ndm,nz_um)   ! Energy (TKE)       Horizontal surfaces, B (explicit) term
+      real evb_u(2*ndm,nz_um)   ! Energy (TKE)         Vertical surfaces, B (explicit) term
+  
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer id,iz
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+       dz=dz_u
+
+      do id=1,nd
+
+!        Calculation at the ground surfaces
+         call flux_flat(dz,z0(id,1),ua_u(1),va_u(1),pt_u(1),pt0_u(1),  &
+                       ptg(id),uhb_u(id,1),                            & 
+                       vhb_u(id,1),thb_u(id,1),ehb_u(id,1))            
+
+!        Calculation at the roof surfaces    
+         do iz=2,nz
+            if(ss(iz).gt.0)then
+               call flux_flat(dz,z0(id,iz),ua_u(iz),                  &              
+                       va_u(iz),pt_u(iz),pt0_u(iz),                   &   
+                       ptr(id,iz),uhb_u(id,iz),                       &   
+                       vhb_u(id,iz),thb_u(id,iz),ehb_u(id,iz))        
+            else
+               uhb_u(id,iz) = 0.0
+               vhb_u(id,iz) = 0.0
+               thb_u(id,iz) = 0.0
+               ehb_u(id,iz) = 0.0
+            endif
+         end do
+
+!        Calculation at the wall surfaces         
+         do iz=1,nz         
+            call flux_wall(ua_u(iz),va_u(iz),pt_u(iz),da_u(iz),     &  
+                        ptw(2*id-1,iz),                             &   
+                        uva_u(2*id-1,iz),vva_u(2*id-1,iz),          &   
+                        uvb_u(2*id-1,iz),vvb_u(2*id-1,iz),          &   
+                        tva_u(2*id-1,iz),tvb_u(2*id-1,iz),          &   
+                        evb_u(2*id-1,iz),drst(id),dt)                  
+                    
+            call flux_wall(ua_u(iz),va_u(iz),pt_u(iz),da_u(iz),    &   
+                        ptw(2*id,iz),                              &    
+                        uva_u(2*id,iz),vva_u(2*id,iz),             &    
+                        uvb_u(2*id,iz),vvb_u(2*id,iz),             &    
+                        tva_u(2*id,iz),tvb_u(2*id,iz),             &   
+                        evb_u(2*id,iz),drst(id),dt) 
+!
+       
+         end do
+         
+      end do
+                
+      return
+      end subroutine buildings
+      
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+        subroutine urban_meso(nd,kms,kme,kts,kte,nz_u,z,dz,z_u,pb,ss,bs,ws,sf,vl,    &
+                             uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u, &       
+                             uhb_u,vhb_u,thb_u,ehb_u,                   &      
+                             a_u,a_v,a_t,a_e,b_u,b_v,b_t,b_e)           
+
+! ----------------------------------------------------------------------
+!  This routine interpolates the parameters from the "urban grid" to the
+!  "mesoscale grid".
+!  See p300-301 Appendix B.2 of the BLM paper.  
+! ----------------------------------------------------------------------
+
+      implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+! Data relative to the "mesoscale grid"
+      integer kms,kme,kts,kte               
+      real z(kms:kme)              ! Altitude above the ground of the cell interface
+      real dz(kms:kme)               ! Vertical space steps
+
+! Data relative to the "uban grid"
+      integer nz_u              ! Number of layer in the urban grid
+      integer nd                ! Number of street direction for the current urban class
+      real bs(ndm)              ! Building widths of the current urban class
+      real ws(ndm)              ! Street widths of the current urban class
+      real z_u(nz_um)         ! Height of the urban grid levels
+      real pb(nz_um)          ! Probability to have a building with an height equal
+      real ss(nz_um)          ! Probability to have a building with height h
+      real uhb_u(ndm,nz_um)   ! U (x-wind component) Horizontal surfaces, B (explicit) term
+      real uva_u(2*ndm,nz_um)   ! U (x-wind component) Vertical surfaces, A (implicit) term
+      real uvb_u(2*ndm,nz_um)   ! U (x-wind component) Vertical surfaces, B (explicit) term
+      real vhb_u(ndm,nz_um)   ! V (y-wind component) Horizontal surfaces, B (explicit) term
+      real vva_u(2*ndm,nz_um)   ! V (y-wind component) Vertical surfaces, A (implicit) term
+      real vvb_u(2*ndm,nz_um)   ! V (y-wind component) Vertical surfaces, B (explicit) term
+      real thb_u(ndm,nz_um)   ! Temperature        Horizontal surfaces, B (explicit) term
+      real tva_u(2*ndm,nz_um)   ! Temperature          Vertical surfaces, A (implicit) term
+      real tvb_u(2*ndm,nz_um)   ! Temperature          Vertical surfaces, B (explicit) term
+      real ehb_u(ndm,nz_um)   ! Energy (TKE)       Horizontal surfaces, B (explicit) term
+      real evb_u(2*ndm,nz_um)   ! Energy (TKE)         Vertical surfaces, B (explicit) term
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+! Data relative to the "mesoscale grid"
+      real sf(kms:kme)             ! Surface of the "mesoscale grid" cells taking into account the buildings
+      real vl(kms:kme)               ! Volume of the "mesoscale grid" cells taking into account the buildings
+      real a_u(kms:kme)              ! Implicit component of the momentum sources or sinks in the X-direction
+      real a_v(kms:kme)              ! Implicit component of the momentum sources or sinks in the Y-direction
+      real a_t(kms:kme)              ! Implicit component of the heat sources or sinks
+      real a_e(kms:kme)              ! Implicit component of the TKE sources or sinks
+      real b_u(kms:kme)              ! Explicit component of the momentum sources or sinks in the X-direction
+      real b_v(kms:kme)              ! Explicit component of the momentum sources or sinks in the Y-direction
+      real b_t(kms:kme)              ! Explicit component of the heat sources or sinks
+      real b_e(kms:kme)              ! Explicit component of the TKE sources or sinks
+      
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      real dzz
+      real fact
+      integer id,iz,iz_u
+      real se,sr,st,su,sv
+      real uet(kms:kme)                ! Contribution to TKE due to walls
+      real veb,vta,vtb,vte,vtot,vua,vub,vva,vvb
+
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ---------------------------------------------------------------------- 
+
+! initialisation
+
+      do iz=kts,kte
+         a_u(iz)=0.
+         a_v(iz)=0.
+         a_t(iz)=0.
+         a_e(iz)=0.
+         b_u(iz)=0.
+         b_v(iz)=0.
+         b_e(iz)=0.
+         b_t(iz)=0.
+         uet(iz)=0.
+      end do
+            
+! horizontal surfaces
+      do iz=kts,kte
+         sf(iz)=0.
+         vl(iz)=0.
+      enddo
+      sf(kte+1)=0. 
+      
+      do id=1,nd      
+         do iz=kts+1,kte+1
+            sr=0.
+            do iz_u=2,nz_u
+               if(z(iz).lt.z_u(iz_u).and.z(iz).ge.z_u(iz_u-1))then
+                  sr=pb(iz_u)
+               endif
+            enddo
+            sf(iz)=sf(iz)+((ws(id)+(1.-sr)*bs(id))/(ws(id)+bs(id)))/nd
+         enddo
+      enddo
+
+! volume      
+      do iz=kts,kte
+         do id=1,nd
+            vtot=0.
+            do iz_u=1,nz_u
+               dzz=max(min(z_u(iz_u+1),z(iz+1))-max(z_u(iz_u),z(iz)),0.)
+               vtot=vtot+pb(iz_u+1)*dzz
+            enddo
+            vtot=vtot/(z(iz+1)-z(iz))
+            vl(iz)=vl(iz)+(1.-vtot*bs(id)/(ws(id)+bs(id)))/nd
+         enddo
+      enddo
+      
+! horizontal surface impact  
+
+      do id=1,nd
+      
+         fact=1./vl(kts)/dz(kts)*ws(id)/(ws(id)+bs(id))/nd
+         b_t(kts)=b_t(kts)+thb_u(id,1)*fact
+         b_u(kts)=b_u(kts)+uhb_u(id,1)*fact
+         b_v(kts)=b_v(kts)+vhb_u(id,1)*fact 
+         b_e(kts)=b_e(kts)+ehb_u(id,1)*fact*(z_u(2)-z_u(1))
+         
+         do iz=kts,kte
+            st=0.
+            su=0.
+            sv=0.
+            se=0.
+            do iz_u=2,nz_u
+               if(z(iz).le.z_u(iz_u).and.z(iz+1).gt.z_u(iz_u))then
+                  st=st+ss(iz_u)*thb_u(id,iz_u)
+                  su=su+ss(iz_u)*uhb_u(id,iz_u)
+                  sv=sv+ss(iz_u)*vhb_u(id,iz_u)          
+                  se=se+ss(iz_u)*ehb_u(id,iz_u)*(z_u(iz_u+1)-z_u(iz_u))
+               endif
+            enddo
+      
+            fact=bs(id)/(ws(id)+bs(id))/vl(iz)/dz(iz)/nd
+            b_t(iz)=b_t(iz)+st*fact
+            b_u(iz)=b_u(iz)+su*fact
+            b_v(iz)=b_v(iz)+sv*fact
+            b_e(iz)=b_e(iz)+se*fact
+         enddo
+      enddo              
+
+! vertical surface impact
+           
+      do iz=kts,kte 
+         uet(iz)=0.
+         do id=1,nd              
+            vtb=0.
+            vta=0.
+            vua=0.
+            vub=0.
+            vva=0.
+            vvb=0.
+            veb=0.
+	    vte=0.
+            do iz_u=1,nz_u
+               dzz=max(min(z_u(iz_u+1),z(iz+1))-max(z_u(iz_u),z(iz)),0.)
+               fact=dzz/(ws(id)+bs(id))
+               vtb=vtb+pb(iz_u+1)*                                  &        
+                    (tvb_u(2*id-1,iz_u)+tvb_u(2*id,iz_u))*fact   
+               vta=vta+pb(iz_u+1)*                                  &        
+                   (tva_u(2*id-1,iz_u)+tva_u(2*id,iz_u))*fact
+               vua=vua+pb(iz_u+1)*                                  &        
+                    (uva_u(2*id-1,iz_u)+uva_u(2*id,iz_u))*fact
+               vva=vva+pb(iz_u+1)*                                  &        
+                    (vva_u(2*id-1,iz_u)+vva_u(2*id,iz_u))*fact
+               vub=vub+pb(iz_u+1)*                                  &        
+                    (uvb_u(2*id-1,iz_u)+uvb_u(2*id,iz_u))*fact
+               vvb=vvb+pb(iz_u+1)*                                  &        
+                    (vvb_u(2*id-1,iz_u)+vvb_u(2*id,iz_u))*fact
+               veb=veb+pb(iz_u+1)*                                  &        
+                    (evb_u(2*id-1,iz_u)+evb_u(2*id,iz_u))*fact
+            enddo
+           
+            fact=1./vl(iz)/dz(iz)/nd
+            b_t(iz)=b_t(iz)+vtb*fact
+            a_t(iz)=a_t(iz)+vta*fact
+            a_u(iz)=a_u(iz)+vua*fact
+            a_v(iz)=a_v(iz)+vva*fact
+            b_u(iz)=b_u(iz)+vub*fact
+            b_v(iz)=b_v(iz)+vvb*fact
+            b_e(iz)=b_e(iz)+veb*fact
+            uet(iz)=uet(iz)+vte*fact
+         enddo              
+      enddo
+      
+
+      
+      return
+      end subroutine urban_meso
+
+! ===6=8===============================================================72 
+
+! ===6=8===============================================================72 
+
+      subroutine interp_length(nd,kms,kme,kts,kte,nz_u,z_u,z,ss,ws,bs,              &
+                             dlg,dl_u)
+
+! ----------------------------------------------------------------------     
+!    Calculation of the length scales
+!    See p272-274 formula (22) and (24) of the BLM paper    
+! ----------------------------------------------------------------------     
+     
+      implicit none
+
+
+! ----------------------------------------------------------------------     
+! INPUT:
+! ----------------------------------------------------------------------     
+      integer kms,kme,kts,kte                
+      real z(kms:kme)              ! Altitude above the ground of the cell interface
+      integer nd                ! Number of street direction for the current urban class
+      integer nz_u              ! Number of levels in the "urban grid"
+      real z_u(nz_um)         ! Height of the urban grid levels
+      real bs(ndm)              ! Building widths of the current urban class
+      real ss(nz_um)          ! Probability to have a building with height h
+      real ws(ndm)              ! Street widths of the current urban class
+
+
+! ----------------------------------------------------------------------     
+! OUTPUT:
+! ----------------------------------------------------------------------     
+      real dlg(kms:kme)              ! Height above ground (L_ground in formula (24) of the BLM paper). 
+      real dl_u(kms:kme)             ! Length scale (lb in formula (22) ofthe BLM paper).
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      real dlgtmp
+      integer id,iz,iz_u
+      real sftot
+      real ulu,ssl
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+   
+        do iz=kts,kte
+         ulu=0.
+         ssl=0.
+         do id=1,nd        
+          do iz_u=2,nz_u
+           if(z_u(iz_u).gt.z(iz))then
+            ulu=ulu+ss(iz_u)/z_u(iz_u)/nd
+            ssl=ssl+ss(iz_u)/nd
+           endif
+          enddo
+         enddo
+
+        if(ulu.ne.0)then
+          dl_u(iz)=ssl/ulu
+         else
+          dl_u(iz)=0.
+         endif
+        enddo
+       
+
+        do iz=kts,kte
+         dlg(iz)=0.
+          do id=1,nd
+           sftot=ws(id)  
+           dlgtmp=ws(id)/((z(iz)+z(iz+1))/2.)
+           do iz_u=1,nz_u
+            if((z(iz)+z(iz+1))/2..gt.z_u(iz_u))then
+             dlgtmp=dlgtmp+ss(iz_u)*bs(id)/                           &                
+                    ((z(iz)+z(iz+1))/2.-z_u(iz_u))
+             sftot=sftot+ss(iz_u)*bs(id)
+            endif
+           enddo
+           dlg(iz)=dlg(iz)+dlgtmp/sftot/nd
+         enddo
+         dlg(iz)=1./dlg(iz)
+        enddo
+        
+       return
+       end subroutine interp_length
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72   
+
+      subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z,    &
+                           rs,rsw,rsg)
+        
+! ----------------------------------------------------------------------
+!         Modification of short wave radiation to take into account
+!         the shadow produced by the buildings
+! ----------------------------------------------------------------------
+
+      implicit none
+     
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      integer nd                ! Number of street direction for the current urban class
+      integer nz_u              ! number of vertical layers defined in the urban grid
+      real ah                   ! Hour angle (it should come from the radiation routine)
+      real deltar               ! Declination of the sun
+      real drst(ndm)            ! street directions for the current urban class
+      real rs                   ! solar radiation
+      real ss(nz_um)          ! probability to have a building with height h
+      real pb(nz_um)          ! Probability that a building has an height greater or equal to h
+      real ws(ndm)              ! Street width of the current urban class
+      real z(nz_um)           ! Height of the urban grid levels
+      real zr                   ! zenith angle
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real rsg(ndm)             ! Short wave radiation at the ground
+      real rsw(2*ndm,nz_um)     ! Short wave radiation at the walls
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer id,iz,jz
+      real aae,aaw,bbb,phix,rd,rtot,wsd
+      
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+      if(rs.eq.0.or.sin(zr).eq.1)then
+         do id=1,nd
+            rsg(id)=0.
+            do iz=1,nz_u
+               rsw(2*id-1,iz)=0.
+               rsw(2*id,iz)=0.
+            enddo
+         enddo
+      else            
+!test              
+         if(abs(sin(zr)).gt.1.e-10)then
+          if(cos(deltar)*sin(ah)/sin(zr).ge.1)then
+           bbb=pi/2.
+          elseif(cos(deltar)*sin(ah)/sin(zr).le.-1)then
+           bbb=-pi/2.
+          else
+           bbb=asin(cos(deltar)*sin(ah)/sin(zr))
+          endif
+         else
+          if(cos(deltar)*sin(ah).ge.0)then
+           bbb=pi/2.
+          elseif(cos(deltar)*sin(ah).lt.0)then
+           bbb=-pi/2.
+          endif
+         endif
+
+         phix=zr
+           
+         do id=1,nd
+        
+            rsg(id)=0.
+           
+            aae=bbb-drst(id)
+            aaw=bbb-drst(id)+pi
+                    
+            do iz=1,nz_u
+               rsw(2*id-1,iz)=0.
+               rsw(2*id,iz)=0.          
+            if(pb(iz+1).gt.0.)then       
+               do jz=1,nz_u                    
+                if(abs(sin(aae)).gt.1.e-10)then
+                  call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aae,   &    
+                      ws(id),rd)                  
+                  rsw(2*id-1,iz)=rsw(2*id-1,iz)+rs*rd*ss(jz+1)/pb(iz+1)
+                  
+                endif
+              
+                if(abs(sin(aaw)).gt.1.e-10)then
+                  call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aaw,   &    
+                      ws(id),rd)
+                  rsw(2*id,iz)=rsw(2*id,iz)+rs*rd*ss(jz+1)/pb(iz+1)   
+                                
+                endif
+               enddo             
+            endif  
+            enddo
+        if(abs(sin(aae)).gt.1.e-10)then
+            wsd=abs(ws(id)/sin(aae))
+              
+            do jz=1,nz_u           
+               rd=max(0.,wsd-z(jz+1)*tan(phix))
+               rsg(id)=rsg(id)+rs*rd*ss(jz+1)/wsd          
+            enddo
+            rtot=0.
+           
+            do iz=1,nz_u
+               rtot=rtot+(rsw(2*id,iz)+rsw(2*id-1,iz))*            &
+                         (z(iz+1)-z(iz))
+            enddo
+            rtot=rtot+rsg(id)*ws(id)
+        else
+            rsg(id)=rs
+        endif
+            
+         enddo
+      endif
+         
+      return
+      end subroutine shadow_mas
+         
+! ===6=8===============================================================72     
+! ===6=8===============================================================72     
+
+      subroutine shade_wall(z1,z2,hu,phix,aa,ws,rd)
+
+! ----------------------------------------------------------------------
+! This routine computes the effects of a shadow induced by a building of 
+! height hu, on a portion of wall between z1 and z2. See equation A10, 
+! and correction described below formula A11, and figure A1. Basically rd
+! is the ratio between the horizontal surface illuminated and the portion
+! of wall. Referring to figure A1, multiplying radiation flux density on 
+! a horizontal surface (rs) by x1-x2 we have the radiation energy per 
+! unit time. Dividing this by z2-z1, we obtain the radiation flux 
+! density reaching the portion of the wall between z2 and z1 
+! (everything is assumed in 2D)
+! ----------------------------------------------------------------------
+
+      implicit none
+      
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      real aa                   ! Angle between the sun direction and the face of the wall (A12)
+      real hu                   ! Height of the building that generates the shadow
+      real phix                 ! Solar zenith angle
+      real ws                   ! Width of the street
+      real z1                   ! Height of the level z(iz)
+      real z2                   ! Height of the level z(iz+1)
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real rd                   ! Ratio between (x1-x2)/(z2-z1), see Fig. 1A. 
+                                ! Multiplying rd by rs (radiation flux 
+                                ! density on a horizontal surface) gives 
+                                ! the radiation flux density on the 
+                                ! portion of wall between z1 and z2. 
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      real x1,x2                ! x1,x2 see Fig. A1.
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+      x1=min((hu-z1)*tan(phix),max(0.,ws/sin(aa)))
+      
+      x2=max((hu-z2)*tan(phix),0.)
+
+      rd=max(0.,sin(aa)*(max(0.,x1-x2))/(z2-z1))
+      
+      return
+      end subroutine shade_wall
+
+! ===6=8===============================================================72     
+! ===6=8===============================================================72     
+
+      subroutine long_rad(iurb,nz_u,id,emw,emg,                  &
+                         fwg,fww,fgw,fsw,fsg,tg,tw,rlg,rlw,rl,pb)
+
+! ----------------------------------------------------------------------
+! This routine computes the effects of the reflections of long-wave 
+! radiation in the street canyon by solving the system 
+! of 2*nz_u+1 eqn. in 2*nz_u+1
+! unkonwn defined in A4, A5 and A6 of the paper (pages 295 and 296).
+! The system is solved by solving A X= B,
+! with A matrix B vector, and X solution. 
+! ----------------------------------------------------------------------
+
+      implicit none
+
+  
+      
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      real emg                        ! Emissivity of ground for the current urban class
+      real emw                        ! Emissivity of wall for the current urban class
+      real fgw(nz_um,ndm,nurbm)       ! View factors from ground to wall
+      real fsg(ndm,nurbm)             ! View factors from sky to ground
+      real fsw(nz_um,ndm,nurbm)       ! View factors from sky to wall
+      real fwg(nz_um,ndm,nurbm)       ! View factors from wall to ground
+      real fww(nz_um,nz_um,ndm,nurbm) ! View factors from wall to wall
+      integer id                      ! Current street direction
+      integer iurb                    ! Current urban class
+      integer nz_u                    ! Number of layer in the urban grid
+      real pb(nz_um)                ! Probability to have a building with an height equal
+      real rl                         ! Downward flux of the longwave radiation
+      real tg(ndm,ng_u)               ! Temperature in each layer of the ground [K]
+      real tw(2*ndm,nz_um,nwr_u)       ! Temperature in each layer of the wall [K]
+      
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real rlg(ndm)                   ! Long wave radiation at the ground
+      real rlw(2*ndm,nz_um)           ! Long wave radiation at the walls
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer i,j
+      real aaa(2*nz_um+1,2*nz_um+1)   ! terms of the matrix
+      real bbb(2*nz_um+1)             ! terms of the vector
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+
+! west wall
+       
+      do i=1,nz_u
+        
+        do j=1,nz_u
+         aaa(i,j)=0.
+        enddo
+        
+        aaa(i,i)=1.        
+       
+        do j=nz_u+1,2*nz_u
+         aaa(i,j)=-(1.-emw)*fww(j-nz_u,i,id,iurb)*pb(j-nz_u+1)
+        enddo
+        
+!!      aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i,id,iurb)*pb(i+1)
+        aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i,id,iurb)
+        
+        bbb(i)=fsw(i,id,iurb)*rl+emg*fgw(i,id,iurb)*sigma*tg(id,ng_u)**4
+        do j=1,nz_u
+         bbb(i)=bbb(i)+pb(j+1)*emw*sigma*fww(j,i,id,iurb)*       &
+               tw(2*id,j,nwr_u)**4+                                 &
+               fww(j,i,id,iurb)*rl*(1.-pb(j+1))
+        enddo
+        
+       enddo
+       
+! east wall
+
+       do i=1+nz_u,2*nz_u
+        
+        do j=1,nz_u
+         aaa(i,j)=-(1.-emw)*fww(j,i-nz_u,id,iurb)*pb(j+1)
+        enddo
+        
+        do j=1+nz_u,2*nz_u
+         aaa(i,j)=0.
+        enddo
+        
+        aaa(i,i)=1.
+        
+!!      aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i-nz_u,id,iurb)*pb(i-nz_u+1)
+        aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i-nz_u,id,iurb)
+        
+        bbb(i)=fsw(i-nz_u,id,iurb)*rl+                           &     
+              emg*fgw(i-nz_u,id,iurb)*sigma*tg(id,ng_u)**4
+
+        do j=1,nz_u
+         bbb(i)=bbb(i)+pb(j+1)*emw*sigma*fww(j,i-nz_u,id,iurb)*  &   
+                tw(2*id-1,j,nwr_u)**4+                              &   
+                fww(j,i-nz_u,id,iurb)*rl*(1.-pb(j+1))
+        enddo
+       
+       enddo
+
+! ground
+       do j=1,nz_u
+        aaa(2*nz_u+1,j)=-(1.-emw)*fwg(j,id,iurb)*pb(j+1)
+       enddo
+       
+       do j=nz_u+1,2*nz_u
+        aaa(2*nz_u+1,j)=-(1.-emw)*fwg(j-nz_u,id,iurb)*pb(j-nz_u+1)
+       enddo
+       
+       aaa(2*nz_u+1,2*nz_u+1)=1.
+       
+       bbb(2*nz_u+1)=fsg(id,iurb)*rl
+       
+       do i=1,nz_u
+        bbb(2*nz_u+1)=bbb(2*nz_u+1)+emw*sigma*fwg(i,id,iurb)*pb(i+1)*    &
+                      (tw(2*id-1,i,nwr_u)**4+tw(2*id,i,nwr_u)**4)+             &
+                      2.*fwg(i,id,iurb)*(1.-pb(i+1))*rl                  
+       enddo
+   
+
+     
+       call gaussj(aaa,2*nz_u+1,bbb,2*nz_um+1)
+
+       do i=1,nz_u
+        rlw(2*id-1,i)=bbb(i)
+       enddo
+       
+       do i=nz_u+1,2*nz_u
+        rlw(2*id,i-nz_u)=bbb(i)
+       enddo
+       
+       rlg(id)=bbb(2*nz_u+1)
+  
+       return
+       end subroutine long_rad
+             
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+       subroutine short_rad(iurb,nz_u,id,albw,                        & 
+                           albg,fwg,fww,fgw,rsg,rsw,pb)
+
+! ----------------------------------------------------------------------
+! This routine computes the effects of the reflections of short-wave 
+! (solar) radiation in the street canyon by solving the system 
+! of 2*nz_u+1 eqn. in 2*nz_u+1
+! unkonwn defined in A4, A5 and A6 of the paper (pages 295 and 296).
+! The system is solved by solving A X= B,
+! with A matrix B vector, and X solution. 
+! ----------------------------------------------------------------------
+
+      implicit none
+
+  
+      
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      real albg                 ! Albedo of the ground for the current urban class
+      real albw                 ! Albedo of the wall for the current urban class
+      real fgw(nz_um,ndm,nurbm)       ! View factors from ground to wall
+      real fwg(nz_um,ndm,nurbm)       ! View factors from wall to ground
+      real fww(nz_um,nz_um,ndm,nurbm) ! View factors from wall to wall
+      integer id                ! current street direction 
+      integer iurb              ! current urban class
+      integer nz_u              ! Number of layer in the urban grid
+      real pb(nz_um)          ! probability to have a building with an height equal
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real rsg(ndm)             ! Short wave radiation at the ground
+      real rsw(2*ndm,nz_um)     ! Short wave radiation at the walls
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer i,j
+      real aaa(2*nz_um+1,2*nz_um+1)  ! terms of the matrix
+      real bbb(2*nz_um+1)            ! terms of the vector
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+      
+! west wall
+       
+      do i=1,nz_u
+         do j=1,nz_u
+            aaa(i,j)=0.
+         enddo
+         
+         aaa(i,i)=1.        
+         
+         do j=nz_u+1,2*nz_u
+            aaa(i,j)=-albw*fww(j-nz_u,i,id,iurb)*pb(j-nz_u+1)
+         enddo
+         
+         aaa(i,2*nz_u+1)=-albg*fgw(i,id,iurb)
+         bbb(i)=rsw(2*id-1,i)
+         
+      enddo
+       
+! east wall
+
+      do i=1+nz_u,2*nz_u
+         do j=1,nz_u
+            aaa(i,j)=-albw*fww(j,i-nz_u,id,iurb)*pb(j+1)
+         enddo
+         
+         do j=1+nz_u,2*nz_u
+            aaa(i,j)=0.
+         enddo
+         
+        aaa(i,i)=1.
+        aaa(i,2*nz_u+1)=-albg*fgw(i-nz_u,id,iurb)
+        bbb(i)=rsw(2*id,i-nz_u)
+        
+      enddo
+
+! ground
+
+      do j=1,nz_u
+         aaa(2*nz_u+1,j)=-albw*fwg(j,id,iurb)*pb(j+1)
+      enddo
+       
+      do j=nz_u+1,2*nz_u
+         aaa(2*nz_u+1,j)=-albw*fwg(j-nz_u,id,iurb)*pb(j-nz_u+1)
+      enddo
+       
+      aaa(2*nz_u+1,2*nz_u+1)=1.
+      bbb(2*nz_u+1)=rsg(id)
+       
+      call gaussj(aaa,2*nz_u+1,bbb,2*nz_um+1)
+
+      do i=1,nz_u
+         rsw(2*id-1,i)=bbb(i)
+      enddo
+       
+      do i=nz_u+1,2*nz_u
+         rsw(2*id,i-nz_u)=bbb(i) 
+      enddo
+       
+      rsg(id)=bbb(2*nz_u+1)
+       
+      return
+      end subroutine short_rad
+             
+
+! ===6=8===============================================================72     
+! ===6=8===============================================================72     
+      
+      subroutine gaussj(a,n,b,np)
+
+! ----------------------------------------------------------------------
+! This routine solve a linear system of n equations of the form
+!              A X = B
+!  where  A is a matrix a(i,j)
+!         B a vector and X the solution
+! In output b is replaced by the solution     
+! ----------------------------------------------------------------------
+
+      implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      integer np
+      real a(np,np)
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real b(np)
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer nmax
+      parameter (nmax=150)
+
+      real big,dum
+      integer i,icol,irow
+      integer j,k,l,ll,n
+      integer ipiv(nmax)
+      real pivinv
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+       
+      do j=1,n
+         ipiv(j)=0.
+      enddo
+       
+      do i=1,n
+         big=0.
+         do j=1,n
+            if(ipiv(j).ne.1)then
+               do k=1,n
+                  if(ipiv(k).eq.0)then
+                     if(abs(a(j,k)).ge.big)then
+                        big=abs(a(j,k))
+                        irow=j
+                        icol=k
+                     endif
+                  elseif(ipiv(k).gt.1)then
+                     pause 'singular matrix in gaussj'
+                  endif
+               enddo
+            endif
+         enddo
+         
+         ipiv(icol)=ipiv(icol)+1
+         
+         if(irow.ne.icol)then
+            do l=1,n
+               dum=a(irow,l)
+               a(irow,l)=a(icol,l)
+               a(icol,l)=dum
+            enddo
+            
+            dum=b(irow)
+            b(irow)=b(icol)
+            b(icol)=dum
+          
+         endif
+         
+         if(a(icol,icol).eq.0)pause 'singular matrix in gaussj'
+         
+         pivinv=1./a(icol,icol)
+         a(icol,icol)=1
+         
+         do l=1,n
+            a(icol,l)=a(icol,l)*pivinv
+         enddo
+         
+         b(icol)=b(icol)*pivinv
+         
+         do ll=1,n
+            if(ll.ne.icol)then
+               dum=a(ll,icol)
+               a(ll,icol)=0.
+               do l=1,n
+                  a(ll,l)=a(ll,l)-a(icol,l)*dum
+               enddo
+               
+               b(ll)=b(ll)-b(icol)*dum
+               
+            endif
+         enddo
+      enddo
+      
+      return
+      end subroutine gaussj
+         
+! ===6=8===============================================================72     
+! ===6=8===============================================================72     
+       
+      subroutine soil_temp(nz,dz,temp,pt,ala,cs,                       &
+                          rs,rl,press,dt,em,alb,rt,sf,gf)
+
+! ----------------------------------------------------------------------
+! This routine solves the Fourier diffusion equation for heat in 
+! the material (wall, roof, or ground). Resolution is done implicitely.
+! Boundary conditions are: 
+! - fixed temperature at the interior
+! - energy budget at the surface
+! ----------------------------------------------------------------------
+
+      implicit none
+
+     
+                
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      integer nz                ! Number of layers
+      real ala(nz)              ! Thermal diffusivity in each layers [m^2 s^-1] 
+      real alb                  ! Albedo of the surface
+      real cs(nz)               ! Specific heat of the material [J m^3 K^-1]
+      real dt                   ! Time step
+      real em                   ! Emissivity of the surface
+      real press                ! Pressure at ground level
+      real rl                   ! Downward flux of the longwave radiation
+      real rs                   ! Solar radiation
+      real sf                   ! Sensible heat flux at the surface
+      real temp(nz)             ! Temperature in each layer [K]
+      real dz(nz)               ! Layer sizes [m]
+
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real gf                   ! Heat flux transferred from the surface toward the interior
+      real pt                   ! Potential temperature at the surface
+      real rt                   ! Total radiation at the surface (solar+incoming long+outgoing long)
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer iz
+      real a(nz,3)
+      real alpha
+      real c(nz)
+      real cddz(nz+2)
+      real tsig
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+       
+      tsig=temp(nz)
+      alpha=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)+sf
+! Compute cddz=2*cd/dz  
+        
+      cddz(1)=ala(1)/dz(1)
+      do iz=2,nz
+         cddz(iz)=2.*ala(iz)/(dz(iz)+dz(iz-1))
+      enddo
+!        cddz(nz+1)=ala(nz+1)/dz(nz)
+       
+      a(1,1)=0.
+      a(1,2)=1.
+      a(1,3)=0.
+      c(1)=temp(1)
+          
+      do iz=2,nz-1
+         a(iz,1)=-cddz(iz)*dt/dz(iz)
+         a(iz,2)=1+dt*(cddz(iz)+cddz(iz+1))/dz(iz)          
+         a(iz,3)=-cddz(iz+1)*dt/dz(iz)
+         c(iz)=temp(iz)
+      enddo          
+                     
+      a(nz,1)=-dt*cddz(nz)/dz(nz)
+      a(nz,2)=1.+dt*cddz(nz)/dz(nz)
+      a(nz,3)=0.
+      c(nz)=temp(nz)+dt*alpha/cs(nz)/dz(nz)
+
+      
+      call invert(nz,a,c,temp)
+
+           
+      pt=temp(nz)*(press/1.e+5)**(-rcp_u)
+
+      rt=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)
+                        
+!      gf=-cddz(nz)*(temp(nz)-temp(nz-1))*cs(nz)
+       gf=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)+sf                                   
+      return
+      end subroutine soil_temp
+
+! ===6=8===============================================================72 
+! ===6=8===============================================================72 
+
+      subroutine invert(n,a,c,x)
+
+! ----------------------------------------------------------------------
+!        Inversion and resolution of a tridiagonal matrix
+!                   A X = C
+! ----------------------------------------------------------------------
+
+      implicit none
+                
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+       integer n
+       real a(n,3)              !  a(*,1) lower diagonal (Ai,i-1)
+                                !  a(*,2) principal diagonal (Ai,i)
+                                !  a(*,3) upper diagonal (Ai,i+1)
+       real c(n)
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+       real x(n)    
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+       integer i
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+                     
+       do i=n-1,1,-1                 
+          c(i)=c(i)-a(i,3)*c(i+1)/a(i+1,2)
+          a(i,2)=a(i,2)-a(i,3)*a(i+1,1)/a(i+1,2)
+       enddo
+       
+       do i=2,n        
+          c(i)=c(i)-a(i,1)*c(i-1)/a(i-1,2)
+       enddo
+        
+       do i=1,n
+          x(i)=c(i)/a(i,2)
+       enddo
+
+       return
+       end subroutine invert
+  
+
+! ===6=8===============================================================72  
+! ===6=8===============================================================72
+  
+      subroutine flux_wall(ua,va,pt,da,ptw,uva,vva,uvb,vvb,            &
+                                  tva,tvb,evb,drst,dt)      
+       
+! ----------------------------------------------------------------------
+! This routine computes the surface sources or sinks of momentum, tke,
+! and heat from vertical surfaces (walls).   
+! ----------------------------------------------------------------------
+
+      implicit none
+
+    
+         
+! INPUT:
+! -----
+      real drst                 ! street directions for the current urban class
+      real da                   ! air density
+      real pt                   ! potential temperature
+      real ptw                  ! Walls potential temperatures 
+      real ua                   ! wind speed
+      real va                   ! wind speed
+
+      real dt                   !time step
+! OUTPUT:
+! ------
+! Explicit and implicit component of the momentum, temperature and TKE sources or sinks on
+! vertical surfaces (walls).
+! The fluxes can be computed as follow: Fluxes of X = A*X + B
+!  Example: Momentum fluxes on vertical surfaces = uva_u * ua_u + uvb_u
+      real uva                  ! U (wind component)   Vertical surfaces, A (implicit) term
+      real uvb                  ! U (wind component)   Vertical surfaces, B (explicit) term
+      real vva                  ! V (wind component)   Vertical surfaces, A (implicit) term
+      real vvb                  ! V (wind component)   Vertical surfaces, B (explicit) term
+      real tva                  ! Temperature          Vertical surfaces, A (implicit) term
+      real tvb                  ! Temperature          Vertical surfaces, B (explicit) term
+      real evb                  ! Energy (TKE)         Vertical surfaces, B (explicit) term
+
+! LOCAL:
+! -----
+      real hc
+      real u_ort
+      real vett
+
+! -------------------------
+! END VARIABLES DEFINITIONS
+! -------------------------
+
+      vett=(ua**2+va**2)**.5         
+         
+      u_ort=abs((cos(drst)*ua-sin(drst)*va))
+       
+      uva=-cdrag*u_ort/2.*cos(drst)*cos(drst)
+      vva=-cdrag*u_ort/2.*sin(drst)*sin(drst)
+         
+      uvb=cdrag*u_ort/2.*sin(drst)*cos(drst)*va
+      vvb=cdrag*u_ort/2.*sin(drst)*cos(drst)*ua
+         
+      hc=5.678*(1.09+0.23*(vett/0.3048))  
+
+      if(hc.gt.da*cp_u/dt)then
+        hc=da*cp_u/dt
+      endif
+         
+!         tvb=hc*ptw/da/cp_u
+!         tva=-hc/da/cp_u
+!!!!!!!!!!!!!!!!!!!!
+! explicit 
+      tvb=hc*ptw/da/cp_u-hc/da/cp_u*pt !c
+      tva = 0.                  !c
+         
+      evb=cdrag*(abs(u_ort)**3.)/2.
+              
+      return
+      end subroutine flux_wall
+         
+! ===6=8===============================================================72
+
+! ===6=8===============================================================72
+
+      subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg,                     &
+                          uhb,vhb,thb,ehb)
+                                
+! ----------------------------------------------------------------------
+!           Calculation of the flux at the ground 
+!           Formulation of Louis (Louis, 1979)       
+! ----------------------------------------------------------------------
+
+      implicit none
+
+     
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      real dz                   ! first vertical level
+      real pt                   ! potential temperature
+      real pt0                  ! reference potential temperature
+      real ptg                  ! ground potential temperature
+      real ua                   ! wind speed
+      real va                   ! wind speed
+      real z0                   ! Roughness length
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+! Explicit component of the momentum, temperature and TKE sources or sinks on horizontal 
+!  surfaces (roofs and street)
+! The fluxes can be computed as follow: Fluxes of X = B
+!  Example: Momentum fluxes on horizontal surfaces =  uhb_u
+      real uhb                  ! U (wind component) Horizontal surfaces, B (explicit) term
+      real vhb                  ! V (wind component) Horizontal surfaces, B (explicit) term
+      real thb                  ! Temperature        Horizontal surfaces, B (explicit) term
+      real tva                  ! Temperature          Vertical surfaces, A (implicit) term
+      real tvb                  ! Temperature          Vertical surfaces, B (explicit) term
+      real ehb                  ! Energy (TKE)       Horizontal surfaces, B (explicit) term
+
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      real aa
+      real al
+      real buu
+      real c
+      real fbuw
+      real fbpt
+      real fh
+      real fm
+      real ric
+      real tstar
+      real ustar
+      real utot
+      real wstar
+      real zz
+      
+      real b,cm,ch,rr,tol
+      parameter(b=9.4,cm=7.4,ch=5.3,rr=0.74,tol=.001)
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+
+! computation of the ground temperature
+         
+      utot=(ua**2+va**2)**.5
+        
+      
+!!!! Louis formulation
+!
+! compute the bulk Richardson Number
+
+      zz=dz/2.
+   
+!        if(tstar.lt.0.)then
+!         wstar=(-ustar*tstar*g*hii/pt)**(1./3.)
+!        else
+!         wstar=0.
+!        endif
+!        
+!      if (utot.le.0.7*wstar) utot=max(0.7*wstar,0.00001)
+
+      utot=max(utot,0.01)
+          
+      ric=2.*g_u*zz*(pt-ptg)/((pt+ptg)*(utot**2))
+              
+      aa=vk/log(zz/z0)
+
+! determine the parameters fm and fh for stable, neutral and unstable conditions
+
+      if(ric.gt.0)then
+         fm=1/(1+0.5*b*ric)**2
+         fh=fm
+      else
+         c=b*cm*aa*aa*(zz/z0)**.5
+         fm=1-b*ric/(1+c*(-ric)**.5)
+         c=c*ch/cm
+         fh=1-b*ric/(1+c*(-ric)**.5)
+      endif
+      
+      fbuw=-aa*aa*utot*utot*fm
+      fbpt=-aa*aa*utot*(pt-ptg)*fh/rr
+                     
+      ustar=(-fbuw)**.5
+      tstar=-fbpt/ustar
+
+      al=(vk*g_u*tstar)/(pt*ustar*ustar)                      
+      
+      buu=-g_u/pt0*ustar*tstar
+       
+      uhb=-ustar*ustar*ua/utot
+      vhb=-ustar*ustar*va/utot 
+      thb=-ustar*tstar       
+!      thb= 0.      
+      ehb=buu
+!!!!!!!!!!!!!!!
+         
+      return
+      end subroutine flux_flat
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+      subroutine icBEP (alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,        &
+                       albg_u,albw_u,albr_u,emg_u,emw_u,emr_u,         &
+                       fww,fwg,fgw,fsw,fws,fsg,                        &
+                       z0g_u,z0r_u,                                    &
+                       nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, &
+                       nz_u,z_u,                                  &
+                       twini_u,trini_u)                               
+
+
+      implicit none 
+      
+   
+!    Building parameters      
+      real alag_u(nurbm)      ! Ground thermal diffusivity [m^2 s^-1]
+      real alaw_u(nurbm)      ! Wall thermal diffusivity [m^2 s^-1]
+      real alar_u(nurbm)      ! Roof thermal diffusivity [m^2 s^-1]
+      real csg_u(nurbm)       ! Specific heat of the ground material [J m^3 K^-1]
+      real csw_u(nurbm)       ! Specific heat of the wall material [J m^3 K^-1]
+      real csr_u(nurbm)       ! Specific heat of the roof material [J m^3 K^-1]
+      real twini_u(nurbm)     ! Temperature inside the buildings behind the wall [K]
+      real trini_u(nurbm)     ! Temperature inside the buildings behind the roof [K]
+
+!    Radiation parameters
+      real albg_u(nurbm)      ! Albedo of the ground
+      real albw_u(nurbm)      ! Albedo of the wall
+      real albr_u(nurbm)      ! Albedo of the roof
+      real emg_u(nurbm)       ! Emissivity of ground
+      real emw_u(nurbm)       ! Emissivity of wall
+      real emr_u(nurbm)       ! Emissivity of roof
+
+!    Roughness parameters
+      real z0g_u(nurbm)       ! The ground's roughness length      
+      real z0r_u(nurbm)       ! The roof's roughness length     
+
+!    Street parameters
+      integer nd_u(nurbm)     ! Number of street direction for each urban class
+
+      real strd_u(ndm,nurbm)  ! Street length (fix to greater value to the horizontal length of the cells)
+      real drst_u(ndm,nurbm)  ! Street direction [degree]
+      real ws_u(ndm,nurbm)    ! Street width [m]
+      real bs_u(ndm,nurbm)    ! Building width [m]
+      real h_b(nz_um,nurbm)   ! Bulding's heights [m]
+      real d_b(nz_um,nurbm)   ! The probability that a building has an height h_b
+! -----------------------------------------------------------------------
+!     Output
+!------------------------------------------------------------------------
+
+
+
+!   fww,fwg,fgw,fsw,fsg are the view factors used to compute the long wave
+!   and the short wave radation. They are the part of radiation from a surface
+!   or from the sky to another surface.
+      real fww(nz_um,nz_um,ndm,nurbm)        !  from wall to wall
+      real fwg(nz_um,ndm,nurbm)              !  from wall to ground
+      real fgw(nz_um,ndm,nurbm)              !  from ground to wall
+      real fsw(nz_um,ndm,nurbm)              !  from sky to wall
+      real fws(nz_um,ndm,nurbm)              !  from wall to sky
+      real fsg(ndm,nurbm)                    !  from sky to ground
+
+      real ss_u(nz_um,nurbm)     ! The probability that a building has an height equal to z
+      real pb_u(nz_um,nurbm)     ! The probability that a building has an height greater or equal to z
+        
+!    Grid parameters
+      integer nz_u(nurbm)     ! Number of layer in the urban grid
+      real z_u(nz_um)       ! Height of the urban grid levels
+
+
+! -----------------------------------------------------------------------
+!     Local
+!------------------------------------------------------------------------
+
+      integer iz_u,id,ilu,iurb
+
+      real dtot
+      real hbmax
+
+!------------------------------------------------------------------------
+     
+
+! -----------------------------------------------------------------------
+!     This routine initialise the urban paramters for the BEP module
+!------------------------------------------------------------------------
+!
+!Initialize variables
+!
+      nz_u=0
+      z_u=0.
+      ss_u=0.
+      pb_u=0.
+      fww=0.
+      fwg=0.
+      fgw=0.
+      fsw=0.
+      fws=0.
+      fsg=0. 
+        
+! Computation of the urban levels height
+
+      z_u(1)=0.
+     
+      do iz_u=1,nz_um-1
+         z_u(iz_u+1)=z_u(iz_u)+dz_u
+      enddo
+      
+! Normalisation of the building density
+
+      do iurb=1,nurbm
+         dtot=0.
+         do ilu=1,nz_um
+            dtot=dtot+d_b(ilu,iurb)
+         enddo
+         do ilu=1,nz_um
+            d_b(ilu,iurb)=d_b(ilu,iurb)/dtot
+         enddo
+      enddo      
+
+! Compute the view factors, pb and ss 
+      
+      do iurb=1,nurbm         
+         hbmax=0.
+         nz_u(iurb)=0
+         do ilu=1,nz_um
+            if(h_b(ilu,iurb).gt.hbmax)hbmax=h_b(ilu,iurb)
+         enddo
+         
+         do iz_u=1,nz_um-1
+            if(z_u(iz_u+1).gt.hbmax)go to 10
+         enddo
+         
+ 10      continue
+         nz_u(iurb)=iz_u+1
+
+         do id=1,nd_u(iurb)
+
+            call view_factors(iurb,nz_u(iurb),id,strd_u(id,iurb),   &    
+                            z_u,ws_u(id,iurb),                      &    
+                            fww,fwg,fgw,fsg,fsw,fws) 
+
+            do iz_u=1,nz_u(iurb)
+               ss_u(iz_u,iurb)=0.
+               do ilu=1,nz_um
+                  if(z_u(iz_u).le.h_b(ilu,iurb)                      &    
+                    .and.z_u(iz_u+1).gt.h_b(ilu,iurb))then            
+                        ss_u(iz_u,iurb)=ss_u(iz_u,iurb)+d_b(ilu,iurb)
+                  endif 
+               enddo
+            enddo
+
+            pb_u(1,iurb)=1.
+            do iz_u=1,nz_u(iurb)
+               pb_u(iz_u+1,iurb)=max(0.,pb_u(iz_u,iurb)-ss_u(iz_u,iurb))
+            enddo
+
+         enddo
+      end do
+     
+                  
+      return       
+      end subroutine icBEP
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+      subroutine view_factors(iurb,nz_u,id,dxy,z,ws,fww,fwg,fgw,fsg,fsw,fws) 
+     
+      implicit none
+
+ 
+
+! -----------------------------------------------------------------------
+!     Input
+!------------------------------------------------------------------------
+
+      integer iurb            ! Number of the urban class
+      integer nz_u            ! Number of levels in the urban grid
+      integer id              ! Street direction number
+      real ws                 ! Street width
+      real z(nz_um)         ! Height of the urban grid levels
+      real dxy                ! Street lenght
+
+
+! -----------------------------------------------------------------------
+!     Output
+!------------------------------------------------------------------------
+
+!   fww,fwg,fgw,fsw,fsg are the view factors used to compute the long wave
+!   and the short wave radation. They are the part of radiation from a surface
+!   or from the sky to another surface.
+
+      real fww(nz_um,nz_um,ndm,nurbm)            !  from wall to wall
+      real fwg(nz_um,ndm,nurbm)                  !  from wall to ground
+      real fgw(nz_um,ndm,nurbm)                  !  from ground to wall
+      real fsw(nz_um,ndm,nurbm)                  !  from sky to wall
+      real fws(nz_um,ndm,nurbm)                  !  from wall to sky
+      real fsg(ndm,nurbm)                        !  from sky to ground
+
+
+! -----------------------------------------------------------------------
+!     Local
+!------------------------------------------------------------------------
+
+      integer jz,iz
+
+      real hut
+      real f1,f2,f12,f23,f123,ftot
+      real fprl,fnrm
+      real a1,a2,a3,a4,a12,a23,a123
+
+! -----------------------------------------------------------------------
+!     This routine calculates the view factors
+!------------------------------------------------------------------------
+        
+      hut=z(nz_u+1)
+        
+      do jz=1,nz_u      
+      
+! radiation from wall to wall
+       
+         do iz=1,nz_u
+     
+            call fprls (fprl,dxy,abs(z(jz+1)-z(iz  )),ws)
+            f123=fprl
+            call fprls (fprl,dxy,abs(z(jz+1)-z(iz+1)),ws)
+            f23=fprl
+            call fprls (fprl,dxy,abs(z(jz  )-z(iz  )),ws)
+            f12=fprl
+            call fprls (fprl,dxy,abs(z(jz  )-z(iz+1)),ws)
+            f2 = fprl
+       
+            a123=dxy*(abs(z(jz+1)-z(iz  )))
+            a12 =dxy*(abs(z(jz  )-z(iz  )))
+            a23 =dxy*(abs(z(jz+1)-z(iz+1)))
+            a1  =dxy*(abs(z(iz+1)-z(iz  )))
+            a2  =dxy*(abs(z(jz  )-z(iz+1)))
+            a3  =dxy*(abs(z(jz+1)-z(jz  )))
+       
+            ftot=0.5*(a123*f123-a23*f23-a12*f12+a2*f2)/a1
+       
+            fww(iz,jz,id,iurb)=ftot*a1/a3
+
+         enddo 
+
+! radiation from ground to wall
+       
+         call fnrms (fnrm,z(jz+1),dxy,ws)
+         f12=fnrm
+         call fnrms (fnrm,z(jz)  ,dxy,ws)
+         f1=fnrm
+       
+         a1 = ws*dxy
+         
+         a12= ws*dxy
+       
+         a4=(z(jz+1)-z(jz))*dxy
+       
+         ftot=(a12*f12-a12*f1)/a1
+                    
+         fgw(jz,id,iurb)=ftot*a1/a4
+     
+!  radiation from sky to wall
+     
+         call fnrms(fnrm,hut-z(jz)  ,dxy,ws)
+         f12 = fnrm
+         call fnrms (fnrm,hut-z(jz+1),dxy,ws)
+         f1 =fnrm
+       
+         a1 = ws*dxy
+       
+         a12= ws*dxy
+              
+         a4 = (z(jz+1)-z(jz))*dxy
+       
+         ftot=(a12*f12-a12*f1)/a1
+        
+         fsw(jz,id,iurb)=ftot*a1/a4       
+      
+      enddo
+
+! radiation from wall to sky      
+      do iz=1,nz_u
+       call fnrms(fnrm,ws,dxy,hut-z(iz))
+       f12=fnrm
+       call fnrms(fnrm,ws,dxy,hut-z(iz+1))
+       f1=fnrm
+       a1 = (z(iz+1)-z(iz))*dxy
+       a2 = (hut-z(iz+1))*dxy
+       a12= (hut-z(iz))*dxy
+       a4 = ws*dxy
+       ftot=(a12*f12-a2*f1)/a1
+       fws(iz,id,iurb)=ftot*a1/a4 
+ 
+      enddo
+!!!!!!!!!!!!!
+
+
+       do iz=1,nz_u
+
+! radiation from wall to ground
+      
+         call fnrms (fnrm,ws,dxy,z(iz+1))
+         f12=fnrm
+         call fnrms (fnrm,ws,dxy,z(iz  ))
+         f1 =fnrm
+         
+         a1= (z(iz+1)-z(iz) )*dxy
+       
+         a2 = z(iz)*dxy
+         a12= z(iz+1)*dxy
+         a4 = ws*dxy
+
+         ftot=(a12*f12-a2*f1)/a1        
+                    
+         fwg(iz,id,iurb)=ftot*a1/a4
+        
+      enddo
+
+! radiation from sky to ground
+      
+      call fprls (fprl,dxy,ws,hut)
+      fsg(id,iurb)=fprl
+
+      return
+      end subroutine view_factors
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+      SUBROUTINE fprls (fprl,a,b,c)
+
+      implicit none
+
+     
+            
+      real a,b,c
+      real x,y
+      real fprl
+
+
+      x=a/c
+      y=b/c
+      
+      if(a.eq.0.or.b.eq.0.)then
+       fprl=0.
+      else
+       fprl=log( ( (1.+x**2)*(1.+y**2)/(1.+x**2+y**2) )**.5)+  &
+           y*((1.+x**2)**.5)*atan(y/((1.+x**2)**.5))+          &  
+           x*((1.+y**2)**.5)*atan(x/((1.+y**2)**.5))-          &   
+           y*atan(y)-x*atan(x)
+       fprl=fprl*2./(pi*x*y)
+      endif
+      
+      return
+      end subroutine fprls
+
+! ===6=8===============================================================72     
+! ===6=8===============================================================72
+
+      SUBROUTINE fnrms (fnrm,a,b,c)
+
+      implicit none
+
+
+
+      real a,b,c
+      real x,y,z,a1,a2,a3,a4,a5,a6
+      real fnrm
+      
+      x=a/b
+      y=c/b
+      z=x**2+y**2
+      
+      if(y.eq.0.or.x.eq.0)then
+       fnrm=0.
+      else
+       a1=log( (1.+x*x)*(1.+y*y)/(1.+z) )
+       a2=y*y*log(y*y*(1.+z)/z/(1.+y*y) )
+       a3=x*x*log(x*x*(1.+z)/z/(1.+x*x) )
+       a4=y*atan(1./y)
+       a5=x*atan(1./x)
+       a6=sqrt(z)*atan(1./sqrt(z))
+       fnrm=0.25*(a1+a2+a3)+a4+a5-a6
+       fnrm=fnrm/(pi*y)
+      endif
+      
+      return
+      end subroutine fnrms
+  ! ===6=8===============================================================72  
+     
+      SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,&
+                twini_u,trini_u,tgini_u,albg_u,albw_u,albr_u,emg_u,emw_u,&
+                emr_u,z0g_u,z0r_u,nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b)
+
+! initialization routine, where the variables from the table are read
+
+      implicit none
+      
+      integer iurb            ! urban class number
+!    Building parameters      
+      real alag_u(nurbm)      ! Ground thermal diffusivity [m^2 s^-1]
+      real alaw_u(nurbm)      ! Wall thermal diffusivity [m^2 s^-1]
+      real alar_u(nurbm)      ! Roof thermal diffusivity [m^2 s^-1]
+      real csg_u(nurbm)       ! Specific heat of the ground material [J m^3 K^-1]
+      real csw_u(nurbm)       ! Specific heat of the wall material [J m^3 K^-1]
+      real csr_u(nurbm)       ! Specific heat of the roof material [J m^3 K^-1]
+      real twini_u(nurbm)     ! Temperature inside the buildings behind the wall [K]
+      real trini_u(nurbm)     ! Temperature inside the buildings behind the roof [K]
+      real tgini_u(nurbm)     ! Initial road temperature
+
+!    Radiation parameters
+      real albg_u(nurbm)      ! Albedo of the ground
+      real albw_u(nurbm)      ! Albedo of the wall
+      real albr_u(nurbm)      ! Albedo of the roof
+      real emg_u(nurbm)       ! Emissivity of ground
+      real emw_u(nurbm)       ! Emissivity of wall
+      real emr_u(nurbm)       ! Emissivity of roof
+
+!    Roughness parameters
+      real z0g_u(nurbm)       ! The ground's roughness length      
+      real z0r_u(nurbm)       ! The roof's roughness length
+
+!    Street parameters
+      integer nd_u(nurbm)     ! Number of street direction for each urban class
+
+      real strd_u(ndm,nurbm)  ! Street length (fix to greater value to the horizontal length of the cells)
+      real drst_u(ndm,nurbm)  ! Street direction [degree]
+      real ws_u(ndm,nurbm)    ! Street width [m]
+      real bs_u(ndm,nurbm)    ! Building width [m]
+      real h_b(nz_um,nurbm)   ! Bulding's heights [m]
+      real d_b(nz_um,nurbm)   ! The probability that a building has an height h_b
+
+      integer i,iu
+      integer nurb ! number of urban classes used
+
+!
+!Initialize some variables
+!
+       
+       h_b=0.
+       d_b=0.
+
+       nurb=ICATE
+       do iu=1,nurb                         
+          nd_u(iu)=0
+       enddo
+
+       csw_u=CAPB_TBL / (( 1.0 / 4.1868 ) * 1.E-6)
+       csr_u=CAPR_TBL / (( 1.0 / 4.1868 ) * 1.E-6)
+       csg_u=CAPG_TBL / (( 1.0 / 4.1868 ) * 1.E-6)
+       do i=1,icate
+         alaw_u(i)=AKSB_TBL(i) / csw_u(i) / (( 1.0 / 4.1868 ) * 1.E-2)
+         alar_u(i)=AKSR_TBL(i) / csr_u(i) / (( 1.0 / 4.1868 ) * 1.E-2)
+         alag_u(i)=AKSG_TBL(i) / csg_u(i) / (( 1.0 / 4.1868 ) * 1.E-2)
+       enddo
+       twini_u=TBLEND_TBL
+       trini_u=TRLEND_TBL
+       tgini_u=TGLEND_TBL
+       albw_u=ALBB_TBL
+       albr_u=ALBR_TBL
+       albg_u=ALBG_TBL
+       emw_u=EPSB_TBL
+       emr_u=EPSR_TBL
+       emg_u=EPSG_TBL
+       z0r_u=Z0R_TBL
+       z0g_u=Z0G_TBL
+       nd_u=NUMDIR_TBL
+       do iu=1,icate
+              if(ndm.lt.nd_u(iu))then
+                write(*,*)'ndm too small in module_sf_bep, please increase to at least ', nd_u(iu)
+                write(*,*)'remember also that num_urban_layers should be equal or greater than nz_um*ndm*nwr-u!'
+                stop
+              endif
+         do i=1,nd_u(iu)
+           drst_u(i,iu)=STREET_DIRECTION_TBL(i,iu) * pi/180.
+           ws_u(i,iu)=STREET_WIDTH_TBL(i,iu)
+           bs_u(i,iu)=BUILDING_WIDTH_TBL(i,iu)
+         enddo
+       enddo
+       do iu=1,ICATE
+          if(nz_um.lt.numhgt_tbl(iu)+3)then
+              write(*,*)'nz_um too small in module_sf_bep, please increase to at least ',numhgt_tbl(iu)+3
+              write(*,*)'remember also that num_urban_layers should be equal or greater than nz_um*ndm*nwr-u!'
+              stop
+          endif
+         do i=1,NUMHGT_TBL(iu)
+           h_b(i,iu)=HEIGHT_BIN_TBL(i,iu)
+           d_b(i,iu)=HPERCENT_BIN_TBL(i,iu)
+         enddo
+       enddo
+
+       do i=1,ndm
+        do iu=1,nurbm
+         strd_u(i,iu)=100000.
+        enddo
+       enddo
+         
+       return
+      END SUBROUTINE init_para
+!==============================================================
+
+!==============================================================
+      subroutine angle(along,alat,day,realt,zr,deltar,ah)
+!     ----------------     
+!      
+!         Computation of the solar angles
+!         schayes (1982,atm.  env. , p1407)
+! Inputs
+!========================
+! along=longitud
+! alat=latitude
+! day=julian day (from the beginning of the year)
+! realt= time GMT in hours
+! Outputs
+!============================
+! zr=solar zenith angle
+! deltar=declination angle
+! ah=hour angle
+!===============================
+
+      implicit none
+      real along,alat, realt, zr, deltar, ah, arg
+      real rad,om,radh,initt, pii, drad, alongt, cphi, sphi
+      real c1, c2, c3, s1, s2, s3, delta, rmsr2, cd, sid 
+      real et, ahor, chor, coznt 
+      integer day 
+
+
+      data rad,om,radh,initt/0.0174533,0.0172142,0.26179939,0/
+ 
+       zr=0.
+       deltar=0.
+       ah=0.
+
+       pii = 3.14159265358979312
+       drad = pii/180.
+      
+       alongt=along/15.
+       cphi=cos(alat*drad)
+       sphi=sin(alat*drad)
+!
+!     declination
+!
+       arg=om*day
+       c1=cos(arg)
+       c2=cos(2.*arg)
+       c3=cos(3.*arg)
+       s1=sin(arg)
+       s2=sin(2.*arg)
+       s3=sin(3.*arg)
+       delta=0.33281-22.984*c1-0.3499*c2-0.1398*c3+3.7872*s1+0.03205*s2+0.07187*s3
+       rmsr2=(1./(1.-0.01673*c1))**2
+       deltar=delta*rad
+       cd=cos(deltar)
+       sid=sin(deltar)
+!
+!     time equation in hours
+!
+       et=0.0072*c1-0.0528*c2-0.0012*c3-0.1229*s1-0.1565*s2-0.0041*s3
+!
+!
+!   hour angle  
+!
+      
+!      ifh=0
+      
+ !     ahor=realt-12.+ifh+et+alongt
+      ahor=realt-12.+et+alongt
+      ah=ahor*radh
+      chor=cos(ah)
+!
+!    zenith angle
+!
+      coznt=sphi*sid+cphi*cd*chor
+      
+       zr=acos(coznt)
+
+      return
+
+      END SUBROUTINE angle
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      subroutine upward_rad(nd_u,iurb,nz_u,ws,bs,sigma,fsw,fsg,pb,ss,           &
+                       tg,emg_u,albg_u,rlg,rsg,sfg,                          & 
+                       tw,emw_u,albw_u,rlw,rsw,sfw,                          & 
+                       tr,emr_u,albr_u,rld,rs, sfr,                            & 
+                       rs_abs,rl_up,emiss,grdflx_urb)
+!
+! IN this surboutine we compute the upward longwave flux, and the albedo
+! needed for the radiation scheme
+!
+                       implicit none
+
+!
+!INPUT VARIABLES
+!
+      real rsw(2*ndm,nz_um)        ! Short wave radiation at the wall for a given canyon direction [W/m2]
+      real rlw(2*ndm,nz_um)         ! Long wave radiation at the walls for a given canyon direction [W/m2]
+      real rsg(ndm)                   ! Short wave radiation at the canyon for a given canyon direction [W/m2]
+      real rlg(ndm)                   ! Long wave radiation at the ground for a given canyon direction [W/m2]
+      real rs                        ! Short wave radiation at the horizontal surface from the sun [W/mÂ²]  
+      real sfw(2*ndm,nz_um)      ! Sensible heat flux from walls [W/mÂ²]
+      real sfg(ndm)              ! Sensible heat flux from ground (road) [W/mÂ²]
+      real sfr(ndm,nz_um)      ! Sensible heat flux from roofs [W/mÂ²]                      
+      real rld                        ! Long wave radiation from the sky [W/mÂ²]
+      real albg_u                    ! albedo of the ground/street
+      real albw_u                    ! albedo of the walls
+      real albr_u                    ! albedo of the roof 
+      real ws(ndm)                        ! width of the street
+      real bs(ndm)
+                        ! building size
+      real pb(nz_um)                ! Probability to have a building with an height equal or higher   
+      integer nz_u
+      real ss(nz_um)                ! Probability to have a building of a given height
+      real sigma                       
+      real emg_u                       ! emissivity of the street
+      real emw_u                       ! emissivity of the wall
+      real emr_u                       ! emissivity of the roof
+      real fsw(nz_um,ndm,nurbm)        ! View factors from sky to wall                
+      real fsg(ndm,nurbm)                      ! groud to sky view factor
+      real tw(2*ndm,nz_um,nwr_u)  ! Temperature in each layer of the wall [K]
+      real tr(ndm,nz_um,nwr_u)  ! Temperature in each layer of the roof [K]
+      real tg(ndm,ng_u)          ! Temperature in each layer of the ground [K]
+      integer iurb ! urban class
+      integer id ! street direction
+      integer nd_u ! number of street directions
+!OUTPUT/INPUT
+      real rs_abs  ! absrobed solar radiationfor this street direction
+      real rl_up   ! upward longwave radiation for this street direction
+      real emiss ! mean emissivity
+      real grdflx_urb ! ground heat flux 
+!LOCAL
+      integer iz,iw
+      real rl_inc,rl_emit
+      real gfl
+      integer ix,iy,iwrong
+
+         iwrong=1
+      do iz=1,nz_u+1
+      do id=1,nd_u
+      do iw=1,nwr_u
+        if(tr(id,iz,iw).lt.100.)then
+              write(*,*)'in upward_rad ',iz,id,iw,tr(id,iz,iw) 
+              iwrong=0
+        endif
+      enddo
+      enddo
+      enddo
+           if(iwrong.eq.0)stop
+
+      rl_up=0.
+ 
+      rs_abs=0.
+      rl_inc=0.
+      emiss=0.
+      rl_emit=0.
+      grdflx_urb=0.
+      do id=1,nd_u          
+       rl_emit=rl_emit-( emg_u*sigma*(tg(id,ng_u)**4.)+(1-emg_u)*rlg(id))*ws(id)/(ws(id)+bs(id))/nd_u
+       rl_inc=rl_inc+rlg(id)*ws(id)/(ws(id)+bs(id))/nd_u       
+       rs_abs=rs_abs+(1.-albg_u)*rsg(id)*ws(id)/(ws(id)+bs(id))/nd_u
+         gfl=(1.-albg_u)*rsg(id)+emg_u*rlg(id)-emg_u*sigma*(tg(id,ng_u)**4.)+sfg(id)
+         grdflx_urb=grdflx_urb-gfl*ws(id)/(ws(id)+bs(id))/nd_u  
+ 
+          do iz=2,nz_u
+            rl_emit=rl_emit-(emr_u*sigma*(tr(id,iz,nwr_u)**4.)+(1-emr_u)*rld)*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u
+            rl_inc=rl_inc+rld*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u            
+            rs_abs=rs_abs+(1.-albr_u)*rs*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u
+            gfl=(1.-albr_u)*rs+emr_u*rld-emr_u*sigma*(tr(id,iz,nwr_u)**4.)+sfr(id,iz)
+            grdflx_urb=grdflx_urb-gfl*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u
+         enddo
+           
+         do iz=1,nz_u            
+            rl_emit=rl_emit-(emw_u*sigma*( tw(2*id-1,iz,nwr_u)**4.+tw(2*id,iz,nwr_u)**4. )+          &
+               (1-emw_u)*( rlw(2*id-1,iz)+rlw(2*id,iz) ) )*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u
+            rl_inc=rl_inc+(( rlw(2*id-1,iz)+rlw(2*id,iz) ) )*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u
+            rs_abs=rs_abs+((1.-albw_u)*( rsw(2*id-1,iz)+rsw(2*id,iz) ) )*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u 
+            gfl=(1.-albw_u)*(rsw(2*id-1,iz)+rsw(2*id,iz)) +emw_u*( rlw(2*id-1,iz)+rlw(2*id,iz) )   &
+             -emw_u*sigma*( tw(2*id-1,iz,nwr_u)**4.+tw(2*id,iz,nwr_u)**4. )+(sfw(2*id-1,iz)+sfw(2*id,iz))            
+            grdflx_urb=grdflx_urb-gfl*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u
+         enddo
+          
+      enddo
+        emiss=(emg_u+emw_u+emr_u)/3.
+        rl_up=(rl_inc+rl_emit)-rld
+       
+         
+      return
+
+      END SUBROUTINE upward_rad
+
+!====6=8===============================================================72         
+!====6=8===============================================================72 
+END MODULE module_sf_bep
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_bep_bem.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_bep_bem.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_bep_bem.F	(revision 17)
@@ -0,0 +1,4101 @@
+MODULE module_sf_bep_bem
+
+!USE module_model_constants
+ USE module_sf_urban
+ USE module_sf_bem
+
+! SGClarke 09/11/2008
+! Access urban_param.tbl values through calling urban_param_init in module_physics_init
+! for CASE (BEPSCHEME) select sf_urban_physics
+!
+! -----------------------------------------------------------------------
+!  Dimension for the array used in the BEP module
+! -----------------------------------------------------------------------
+
+      integer nurbm           ! Maximum number of urban classes    
+      parameter (nurbm=3)
+
+      integer ndm             ! Maximum number of street directions 
+      parameter (ndm=2)
+
+      integer nz_um           ! Maximum number of vertical levels in the urban grid
+      parameter(nz_um=13)
+
+      integer ng_u            ! Number of grid levels in the ground
+      parameter (ng_u=10)
+      integer nwr_u            ! Number of grid levels in the walls or roofs
+      parameter (nwr_u=10)
+
+      integer nf_u             !Number of grid levels in the floors (BEM)
+      parameter (nf_u=10)
+
+      integer ngb_u            !Number of grid levels in the ground below building (BEM)
+      parameter (ngb_u=10)
+
+      real dz_u                ! Urban grid resolution
+      parameter (dz_u=5.) 
+
+      integer nbui_max         !maximum number of types of buildings in an urban class
+      parameter (nbui_max=4)   !must be less or equal than nz_um 
+
+!---------------------------------------------------------------------------------
+!Parameters of the windows. The glasses of windows are considered without films  -
+!Read the paper of J.Karlsson and A.Roos(2000):"modelling the angular behaviour  -
+!of the total solar energy transmittance of windows".Solar Energy Vol.69,No.4,   -
+!pp. 321-329, for more details.                                                  -
+!---------------------------------------------------------------------------------
+      integer p_num            !number of panes in the windows (1,2 or 3)
+      parameter (p_num=2)
+      integer q_num            !category number for the windows (q_num= 4, standard glasses)
+      parameter(q_num=4)       !Possible values 1,2,...,10
+
+
+! The change of ng_u, nwr_u should be done in agreement with the block data
+!  in the routine "surf_temp" 
+! -----------------------------------------------------------------------
+!  Constant used in the BEP module
+! -----------------------------------------------------------------------
+           
+      real vk                 ! von Karman constant
+      real g_u                ! Gravity acceleration
+      real pi                 !
+      real r                  ! Perfect gas constant
+      real cp_u               ! Specific heat at constant pressure
+      real rcp_u              !
+      real sigma              !
+      real p0                 ! Reference pressure at the sea level
+      real cdrag              ! Drag force constant
+      real latent             ! Latent heat of vaporization [J/kg] (used in BEM)
+      parameter(vk=0.40,g_u=9.81,pi=3.141592653,r=287.,cp_u=1004.)        
+      parameter(rcp_u=r/cp_u,sigma=5.67e-08,p0=1.e+5,cdrag=0.4,latent=2.45e+06)
+
+! -----------------------------------------------------------------------     
+
+
+
+
+   CONTAINS
+ 
+      subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy,      &
+                      th_phy,rho,p_phy,swdown,glw,                                 &
+                      gmt,julday,xlong,xlat,                                       &
+                      declin_urb,cosz_urb2d,omg_urb2d,                             &
+                      num_urban_layers,                                            &
+                      trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,                     &
+                      tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,             &
+                      tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,             &
+                      cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,                       &
+                      sfwin1_urb3d,sfwin2_urb3d,                                   &
+                      sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,                   &
+                      a_u,a_v,a_t,a_e,b_u,b_v,                                     &
+                      b_t,b_e,b_q,dlg,dl_u,sf,vl,                                  &
+                      rl_up,rs_abs,emiss,grdflx_urb,qv_phy,                        &
+                      ids,ide, jds,jde, kds,kde,                                   &
+                      ims,ime, jms,jme, kms,kme,                                   &
+                      its,ite, jts,jte, kts,kte)                    
+
+      implicit none
+
+!------------------------------------------------------------------------
+!     Input
+!------------------------------------------------------------------------
+   INTEGER ::                       ids,ide, jds,jde, kds,kde,  &
+                                    ims,ime, jms,jme, kms,kme,  &
+                                    its,ite, jts,jte, kts,kte,  &
+                                    itimestep
+ 
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   DZ8W
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   P_PHY
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   RHO
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   TH_PHY
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   T_PHY
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   U_PHY
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   V_PHY
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   U
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme )::   V
+   REAL, DIMENSION( ims:ime , jms:jme )        ::   GLW
+   REAL, DIMENSION( ims:ime , jms:jme )        ::   swdown
+   REAL, DIMENSION( ims:ime, jms:jme )         ::   UST
+   INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN )::   UTYPE_URB2D
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN )::   FRC_URB2D
+   REAL, INTENT(IN  )   ::                                   GMT 
+   INTEGER, INTENT(IN  ) ::                               JULDAY
+   REAL, DIMENSION( ims:ime, jms:jme ),                           &
+         INTENT(IN   )  ::                           XLAT, XLONG
+   REAL, INTENT(IN) :: DECLIN_URB
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D
+   INTEGER, INTENT(IN  ) :: num_urban_layers
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d
+!New variables used for BEM
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: qv_phy
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tlev_urb3d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: qlev_urb3d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1lev_urb3d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2lev_urb3d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tglev_urb3d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tflev_urb3d
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin1_urb3d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin2_urb3d
+!End variables
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d
+
+   real z(ims:ime,kms:kme,jms:jme)            ! Vertical coordinates
+   REAL, INTENT(IN )::   DT      ! Time step
+
+!      
+!------------------------------------------------------------------------
+!     Output
+!------------------------------------------------------------------------ 
+!
+!    Implicit and explicit components of the source and sink terms at each levels,
+!     the fluxes can be computed as follow: FX = A*X + B   example: t_fluxes = a_t * pt + b_t
+      real a_u(ims:ime,kms:kme,jms:jme)         ! Implicit component for the momemtum in X-direction (center)
+      real a_v(ims:ime,kms:kme,jms:jme)         ! Implicit component for the momemtum in Y-direction (center)
+      real a_t(ims:ime,kms:kme,jms:jme)         ! Implicit component for the temperature
+      real a_e(ims:ime,kms:kme,jms:jme)         ! Implicit component for the TKE
+      real b_u(ims:ime,kms:kme,jms:jme)         ! Explicit component for the momemtum in X-direction (center)
+      real b_v(ims:ime,kms:kme,jms:jme)         ! Explicit component for the momemtum in Y-direction (center)
+      real b_t(ims:ime,kms:kme,jms:jme)         ! Explicit component for the temperature
+      real b_e(ims:ime,kms:kme,jms:jme)         ! Explicit component for the TKE
+      real b_q(ims:ime,kms:kme,jms:jme)         ! Explicit component for the Humidity
+      real dlg(ims:ime,kms:kme,jms:jme)         ! Height above ground (L_ground in formula (24) of the BLM paper). 
+      real dl_u(ims:ime,kms:kme,jms:jme)        ! Length scale (lb in formula (22) ofthe BLM paper).
+! urban surface and volumes        
+      real sf(ims:ime,kms:kme,jms:jme)           ! surface of the urban grid cells
+      real vl(ims:ime,kms:kme,jms:jme)             ! volume of the urban grid cells
+! urban fluxes
+      real rl_up(ims:ime,jms:jme) ! upward long wave radiation
+      real rs_abs(ims:ime,jms:jme) ! absorbed short wave radiation
+      real emiss(ims:ime,jms:jme)  ! emissivity averaged for urban surfaces
+      real grdflx_urb(ims:ime,jms:jme)  ! ground heat flux for urban areas
+!------------------------------------------------------------------------
+!     Local
+!------------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!    Building parameters      
+      real alag_u(nurbm)                      ! Ground thermal diffusivity [m^2 s^-1]
+      real alaw_u(nurbm)                      ! Wall thermal diffusivity [m^2 s^-1]
+      real alar_u(nurbm)                      ! Roof thermal diffusivity [m^2 s^-1]
+      real csg_u(nurbm)                       ! Specific heat of the ground material [J m^3 K^-1]
+      real csw_u(nurbm)                       ! Specific heat of the wall material [J m^3 K^-1]
+      real csr_u(nurbm)                       ! Specific heat of the roof material [J m^3 K^-1]
+      real twini_u(nurbm)                     ! Initial temperature inside the building's wall [K]
+      real trini_u(nurbm)                     ! Initial temperature inside the building's roof [K]
+      real tgini_u(nurbm)                     ! Initial road temperature
+!
+! for twini_u, and trini_u the initial value at the deepest level is kept constant during the simulation
+!
+!    Radiation paramters
+      real albg_u(nurbm)                      ! Albedo of the ground
+      real albw_u(nurbm)                      ! Albedo of the wall
+      real albr_u(nurbm)                      ! Albedo of the roof
+      real albwin_u(nurbm)                    ! Albedo of the windows
+      real emwind_u(nurbm)                    ! Emissivity of windows
+      real emg_u(nurbm)                       ! Emissivity of ground
+      real emw_u(nurbm)                       ! Emissivity of wall
+      real emr_u(nurbm)                       ! Emissivity of roof
+
+!   fww,fwg,fgw,fsw,fsg are the view factors used to compute the long wave
+!   and the short wave radation. 
+      real fww(nz_um,nz_um,ndm,nurbm)         !  from wall to wall
+      real fwg(nz_um,ndm,nurbm)               !  from wall to ground
+      real fgw(nz_um,ndm,nurbm)               !  from ground to wall
+      real fsw(nz_um,ndm,nurbm)               !  from sky to wall
+      real fws(nz_um,ndm,nurbm)               !  from sky to wall
+      real fsg(ndm,nurbm)                     !  from sky to ground
+
+!    Roughness parameters
+      real z0g_u(nurbm)         ! The ground's roughness length
+      real z0r_u(nurbm)         ! The roof's roughness length
+
+!    Street parameters
+      integer nd_u(nurbm)       ! Number of street direction for each urban class 
+      real strd_u(ndm,nurbm)    ! Street length (fix to greater value to the horizontal length of the cells)
+      real drst_u(ndm,nurbm)    ! Street direction
+      real ws_u(ndm,nurbm)      ! Street width
+      real bs_u(ndm,nurbm)      ! Building width
+      real h_b(nz_um,nurbm)     ! Bulding's heights
+      real d_b(nz_um,nurbm)     ! Probability that a building has an height h_b
+      real ss_u(nz_um,nurbm)  ! Probability that a building has an height equal to z
+      real pb_u(nz_um,nurbm)  ! Probability that a building has an height greater or equal to z
+
+
+!    Grid parameters
+      integer nz_u(nurbm)       ! Number of layer in the urban grid
+      
+      real z_u(nz_um)         ! Height of the urban grid levels
+
+!   MT
+      real cop_u(nurbm)
+      real pwin_u(nurbm)
+      real beta_u(nurbm)
+      integer sw_cond_u(nurbm)
+      real time_on_u(nurbm)
+      real time_off_u(nurbm)
+      real targtemp_u(nurbm)
+      real gaptemp_u(nurbm)
+      real targhum_u(nurbm)
+      real gaphum_u(nurbm)
+      real perflo_u(nurbm)
+      real hsesf_u(nurbm)
+      real hsequip(24)
+
+! 1D array used for the input and output of the routine "urban"
+
+      real z1D(kms:kme)               ! vertical coordinates
+      real ua1D(kms:kme)                ! wind speed in the x directions
+      real va1D(kms:kme)                ! wind speed in the y directions
+      real pt1D(kms:kme)                ! potential temperature
+      real da1D(kms:kme)                ! air density
+      real pr1D(kms:kme)                ! air pressure
+      real pt01D(kms:kme)               ! reference potential temperature
+      real zr1D                    ! zenith angle
+      real deltar1D                ! declination of the sun
+      real ah1D                    ! hour angle (it should come from the radiation routine)
+      real rs1D                    ! solar radiation
+      real rld1D                   ! downward flux of the longwave radiation
+
+      real tw1D(2*ndm,nz_um,nwr_u,nbui_max) ! temperature in each layer of the wall
+      real tg1D(ndm,ng_u)                   ! temperature in each layer of the ground
+      real tr1D(ndm,nz_um,nwr_u)   ! temperature in each layer of the roof
+!
+!New variable for BEM
+!
+      real tlev1D(nz_um,nbui_max)            ! temperature in each floor and in each different type of building
+      real qlev1D(nz_um,nbui_max)            ! specific humidity in each floor and in each different type of building
+      real twlev1D(2*ndm,nz_um,nbui_max)     ! temperature in each window in each floor in each different type of building
+      real tglev1D(ndm,ngb_u,nbui_max)       ! temperature in each layer of the ground below of a type of building
+      real tflev1D(ndm,nf_u,nz_um-1,nbui_max)! temperature in each layer of the floors in each building
+      real lflev1D(nz_um,nz_um)           ! latent heat flux due to the air conditioning systems
+      real sflev1D(nz_um,nz_um)           ! sensible heat flux due to the air conditioning systems
+      real lfvlev1D(nz_um,nz_um)          ! latent heat flux due to ventilation
+      real sfvlev1D(nz_um,nz_um)          ! sensible heat flux due to ventilation
+      real sfwin1D(2*ndm,nz_um,nbui_max)     ! sensible heat flux from windows
+      real consumlev1D(nz_um,nz_um)       ! consumption due to the air conditioning systems
+      real qv1D(kms:kme)                  ! specific humidity
+      real meso_urb                       ! constant to link meso and urban scales [mÃÂ¯2]
+      real d_urb(nz_um)    
+      real sf_ac
+      integer ibui,nbui
+      integer nlev(nz_um)
+!
+!End new variables
+!
+
+      real sfw1D(2*ndm,nz_um,nbui_max)      ! sensible heat flux from walls
+      real sfg1D(ndm)              ! sensible heat flux from ground (road)
+      real sfr1D(ndm,nz_um)      ! sensible heat flux from roofs
+      real sf1D(kms:kme)              ! surface of the urban grid cells
+      real vl1D(kms:kme)                ! volume of the urban grid cells
+      real a_u1D(kms:kme)               ! Implicit component of the momentum sources or sinks in the X-direction
+      real a_v1D(kms:kme)               ! Implicit component of the momentum sources or sinks in the Y-direction
+      real a_t1D(kms:kme)               ! Implicit component of the heat sources or sinks
+      real a_e1D(kms:kme)               ! Implicit component of the TKE sources or sinks
+      real b_u1D(kms:kme)               ! Explicit component of the momentum sources or sinks in the X-direction
+      real b_v1D(kms:kme)               ! Explicit component of the momentum sources or sinks in the Y-direction
+      real b_t1D(kms:kme)               ! Explicit component of the heat sources or sinks
+      real b_ac1D(kms:kme)
+      real b_e1D(kms:kme)               ! Explicit component of the TKE sources or sinks
+      real b_q1D(kms:kme)               ! Explicit component of the Humidity sources or sinks
+      real dlg1D(kms:kme)               ! Height above ground (L_ground in formula (24) of the BLM paper). 
+      real dl_u1D(kms:kme)              ! Length scale (lb in formula (22) ofthe BLM paper)
+      real time_bep
+! arrays used to collapse indexes
+      integer ind_zwd(nbui_max,nz_um,nwr_u,ndm)
+      integer ind_gd(ng_u,ndm)
+      integer ind_zd(nbui_max,nz_um,ndm)
+      integer ind_zdf(nz_um,ndm)
+      integer ind_zrd(nz_um,nwr_u,ndm)
+!
+      integer ind_bd(nbui_max,nz_um)
+      integer ind_wd(nbui_max,nz_um,ndm)
+      integer ind_gbd(nbui_max,ngb_u,ndm)  
+      integer ind_fbd(nbui_max,nf_u,nz_um-1,ndm)
+!
+      integer ix,iy,iz,iurb,id,iz_u,iw,ig,ir,ix1,iy1,k
+      integer it, nint
+      integer iii
+      real tempo
+      logical first
+      character(len=80) :: text
+      data first/.true./
+      save first,time_bep 
+
+      save alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,                      &
+          albg_u,albw_u,albr_u,emg_u,emw_u,emr_u,fww,fwg,fgw,fsw,fws,fsg, &
+          z0g_u,z0r_u, nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u,  &
+          nz_u,z_u,albwin_u,emwind_u ,                                  &
+          cop_u, pwin_u, beta_u, sw_cond_u, time_on_u, time_off_u, targtemp_u,  &
+          gaptemp_u, targhum_u, gaphum_u, perflo_u, hsesf_u, hsequip
+
+!------------------------------------------------------------------------
+!    Calculation of the momentum, heat and turbulent kinetic fluxes
+!     produced by builgings
+!
+! Reference:
+! Martilli, A., Clappier, A., Rotach, M.W.:2002, 'AN URBAN SURFACE EXCHANGE
+! PARAMETERISATION FOR MESOSCALE MODELS', Boundary-Layer Meteorolgy 104:
+! 261-304
+!
+! F. Salamanca and A. Martilli, 2009: 'A new Building Energy Model coupled 
+! with an Urban Canopy Parameterization for urban climate simulations_part II. 
+! Validation with one dimension off-line simulations'. Theor Appl Climatol
+! DOI 10.1007/s00704-009-0143-8 
+!------------------------------------------------------------------------
+!prepare the arrays to collapse indexes
+      if(num_urban_layers.lt.nbui_max*nz_um*ndm*max(nwr_u,ng_u))then
+        write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*nz_um*ndm*max(nwr_u,ng_u)
+        stop
+      endif
+!
+!New conditions for BEM
+!
+      if(num_urban_layers.lt.nbui_max*nz_um)then !limit for indoor temperature and indoor humidity
+        write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*nz_um
+        stop
+      endif
+
+      if(num_urban_layers.lt.nbui_max*nz_um*ndm)then !limit for window temperature
+        write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*nz_um*ndm
+        stop
+      endif
+
+      if(num_urban_layers.lt.nbui_max*ndm*ngb_u)then !limit for ground temperature below a building
+        write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*ndm*ngb_u
+        stop
+      endif
+
+      if(num_urban_layers.lt.(nz_um-1)*nbui_max*ndm*nf_u)then !limit for floor temperature 
+        write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*ndm*nf_u*(nz_um-1),num_urban_layers
+        stop
+      endif
+
+      if (ndm.ne.2)then
+         write(*,*) 'number of directions is not correct',ndm
+         stop
+      endif
+
+!
+!End of new conditions
+!
+!
+!Initialize collapse indexes
+!
+      ind_zwd=0       
+      ind_gd=0
+      ind_zd=0
+      ind_zdf=0
+      ind_zrd=0
+      ind_bd=0
+      ind_wd=0
+      ind_gbd=0
+      ind_fbd=0
+!
+!End initialization indexes
+!
+
+      iii=0
+      do ibui=1,nbui_max
+      do iz_u=1,nz_um
+      do iw=1,nwr_u
+      do id=1,ndm
+       iii=iii+1
+       ind_zwd(ibui,iz_u,iw,id)=iii
+      enddo
+      enddo
+      enddo
+      enddo
+      
+      iii=0
+      do ig=1,ng_u
+      do id=1,ndm
+       iii=iii+1
+       ind_gd(ig,id)=iii
+      enddo
+      enddo
+      
+      iii=0
+      do ibui=1,nbui_max
+      do iz_u=1,nz_um
+      do id=1,ndm
+       iii=iii+1
+       ind_zd(ibui,iz_u,id)=iii
+      enddo
+      enddo
+      enddo
+      
+      iii=0
+      do iz_u=1,nz_um
+      do iw=1,nwr_u
+      do id=1,ndm
+       iii=iii+1
+       ind_zrd(iz_u,iw,id)=iii
+      enddo
+      enddo
+      enddo
+      
+!
+!New indexes for BEM
+!
+      iii=0
+      do iz_u=1,nz_um
+      do id=1,ndm
+         iii=iii+1
+         ind_zdf(iz_u,id)=iii
+      enddo ! id
+      enddo ! iz_u
+      
+      iii=0
+      do ibui=1,nbui_max  !Type of building
+      do iz_u=1,nz_um     !vertical levels
+         iii=iii+1
+         ind_bd(ibui,iz_u)=iii
+      enddo !iz_u
+      enddo !ibui
+      
+      
+      iii=0
+      do ibui=1,nbui_max !type of building
+      do iz_u=1,nz_um !vertical levels
+      do id=1,ndm !direction
+         iii=iii+1
+         ind_wd(ibui,iz_u,id)=iii
+      enddo !id
+      enddo !iz_u
+      enddo !ibui
+      
+      iii=0
+      do ibui=1,nbui_max!type of building
+      do iw=1,ngb_u !layers in the wall (ground below a building)
+      do id=1,ndm !direction
+         iii=iii+1
+         ind_gbd(ibui,iw,id)=iii  
+      enddo !id
+      enddo !iw 
+      enddo !ibui    
+      
+      iii=0
+      do ibui=1,nbui_max !type of building
+      do iw=1,nf_u !layers in the wall (floor)
+      do iz_u=1,nz_um-1 !vertical levels
+      do id=1,ndm  !direction
+         iii=iii+1
+         ind_fbd(ibui,iw,iz_u,id)=iii
+      enddo !id
+      enddo !iz_u
+      enddo !iw
+      enddo !ibui
+      
+!
+!End of new indexes
+!      
+
+      do ix=its,ite
+      do iy=jts,jte
+       z(ix,kts,iy)=0.
+       do iz=kts+1,kte+1
+        z(ix,iz,iy)=z(ix,iz-1,iy)+dz8w(ix,iz-1,iy)
+       enddo
+      enddo
+      enddo
+
+      if (first) then                           ! True only on first call
+         call init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,&
+                twini_u,trini_u,tgini_u,albg_u,albw_u,albr_u,albwin_u,emg_u,emw_u,&
+                emr_u,emwind_u,z0g_u,z0r_u,nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,&
+                cop_u, pwin_u, beta_u, sw_cond_u, time_on_u, time_off_u, &
+                targtemp_u, gaptemp_u, targhum_u, gaphum_u, perflo_u, hsesf_u, hsequip)
+
+!Initialisation of the urban parameters and calculation of the view factor
+       call icBEP(fww,fwg,fgw,fsw,fws,fsg,                         & 
+                 z0g_u,z0r_u,                                      & 
+                 nd_u,strd_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u,          & 
+                 nz_u,z_u)                                  
+
+       first=.false.
+
+      endif ! first
+      
+      do ix=its,ite
+      do iy=jts,jte
+        if (FRC_URB2D(ix,iy).gt.0.) then    ! Calling BEP only for existing urban classes.
+	
+         iurb=UTYPE_URB2D(ix,iy)
+         ibui=0
+         nlev=0
+         nbui=0
+         d_urb=0.
+         do iz=1,nz_um		   
+         if(ss_u(iz,iurb).gt.0) then		
+           ibui=ibui+1		                
+           nlev(ibui)=iz-1
+           d_urb(ibui)=ss_u(iz,iurb)
+           nbui=ibui
+	 endif	  
+         end do  !iz
+         if (nbui.gt.nbui_max) then
+            write (*,*) 'nbui_max must be increased to',nbui
+            stop
+         endif
+
+       do iz= kts,kte
+          ua1D(iz)=u_phy(ix,iz,iy)
+          va1D(iz)=v_phy(ix,iz,iy)
+	  pt1D(iz)=th_phy(ix,iz,iy)
+	  da1D(iz)=rho(ix,iz,iy)
+	  pr1D(iz)=p_phy(ix,iz,iy)
+!	  pt01D(iz)=th_phy(ix,iz,iy)
+	  pt01D(iz)=300.
+	  z1D(iz)=z(ix,iz,iy)
+          qv1D(iz)=qv_phy(ix,iz,iy)
+          a_u1D(iz)=0.
+          a_v1D(iz)=0.
+          a_t1D(iz)=0.
+          a_e1D(iz)=0.
+          b_u1D(iz)=0.
+          b_v1D(iz)=0.
+          b_t1D(iz)=0.
+          b_ac1D(iz)=0.
+          b_e1D(iz)=0.           
+         enddo
+	 z1D(kte+1)=z(ix,kte+1,iy)
+
+         do id=1,ndm
+         do iz_u=1,nz_um
+         do iw=1,nwr_u
+         do ibui=1,nbui_max
+          tw1D(2*id-1,iz_u,iw,ibui)=tw1_urb4d(ix,ind_zwd(ibui,iz_u,iw,id),iy)
+          tw1D(2*id,iz_u,iw,ibui)=tw2_urb4d(ix,ind_zwd(ibui,iz_u,iw,id),iy)
+         enddo
+         enddo
+         enddo
+         enddo
+	
+         do id=1,ndm
+          do ig=1,ng_u
+            tg1D(id,ig)=tgb_urb4d(ix,ind_gd(ig,id),iy)
+          enddo
+          do iz_u=1,nz_um
+          do ir=1,nwr_u
+            tr1D(id,iz_u,ir)=trb_urb4d(ix,ind_zrd(iz_u,ir,id),iy)
+          enddo
+          enddo
+         enddo
+!
+!Initialize variables for BEM
+!
+         tlev1D=0.  !Indoor temperature
+         qlev1D=0.  !Indoor humidity
+
+         twlev1D=0. !Window temperature
+         tglev1D=0. !Ground temperature
+         tflev1D=0. !Floor temperature
+
+         sflev1D=0.    !Sensible heat flux from the a.c.
+         lflev1D=0.    !latent heat flux from the a.c.
+         consumlev1D=0.!consumption of the a.c.
+         sfvlev1D=0.   !Sensible heat flux from natural ventilation
+         lfvlev1D=0.   !Latent heat flux from natural ventilation
+         sfwin1D=0.    !Sensible heat flux from windows
+         sfw1D=0.      !Sensible heat flux from walls         
+
+         do iz_u=1,nz_um    !vertical levels
+         do ibui=1,nbui_max !Type of building
+            tlev1D(iz_u,ibui)= tlev_urb3d(ix,ind_bd(ibui,iz_u),iy)  
+            qlev1D(iz_u,ibui)= qlev_urb3d(ix,ind_bd(ibui,iz_u),iy)  
+         enddo !ibui
+         enddo !iz_u
+
+         do id=1,ndm  !direction
+            do iz_u=1,nz_um !vertical levels
+               do ibui=1,nbui_max !type of building
+                  twlev1D(2*id-1,iz_u,ibui)=tw1lev_urb3d(ix,ind_wd(ibui,iz_u,id),iy)
+                  twlev1D(2*id,iz_u,ibui)=tw2lev_urb3d(ix,ind_wd(ibui,iz_u,id),iy)
+                  sfwin1D(2*id-1,iz_u,ibui)=sfwin1_urb3d(ix,ind_wd(ibui,iz_u,id),iy)
+                  sfwin1D(2*id,iz_u,ibui)=sfwin2_urb3d(ix,ind_wd(ibui,iz_u,id),iy)
+               enddo !ibui  
+            enddo !iz_u
+         enddo !id
+
+         do id=1,ndm !direction
+            do iw=1,ngb_u !layer in the wall
+               do ibui=1,nbui_max !type of building
+                  tglev1D(id,iw,ibui)=tglev_urb3d(ix,ind_gbd(ibui,iw,id),iy)
+               enddo !ibui
+            enddo !iw
+         enddo !id
+       
+         do id=1,ndm !direction
+            do iw=1,nf_u !layer in the walls
+               do iz_u=1,nz_um-1 !verticals levels
+                  do ibui=1,nbui_max !type of building
+                     tflev1D(id,iw,iz_u,ibui)=tflev_urb3d(ix,ind_fbd(ibui,iw,iz_u,id),iy)
+                  enddo !ibui
+               enddo ! iz_u
+             enddo !iw
+         enddo !id
+
+!
+!End initialization for BEM
+!         
+
+         do id=1,ndm
+	 do iz=1,nz_um
+         do ibui=1,nbui_max !type of building
+	  sfw1D(2*id-1,iz,ibui)=sfw1_urb3d(ix,ind_zd(ibui,iz,id),iy)
+	  sfw1D(2*id,iz,ibui)=sfw2_urb3d(ix,ind_zd(ibui,iz,id),iy)
+         enddo
+	 enddo
+	 enddo
+	 
+	 do id=1,ndm
+	  sfg1D(id)=sfg_urb3d(ix,id,iy)
+	 enddo
+	 
+	 do id=1,ndm
+	 do iz=1,nz_um
+	  sfr1D(id,iz)=sfr_urb3d(ix,ind_zdf(iz,id),iy)
+	 enddo
+	 enddo
+         
+         rs1D=swdown(ix,iy)
+         rld1D=glw(ix,iy)
+
+         zr1D=acos(COSZ_URB2D(ix,iy))
+         deltar1D=DECLIN_URB
+         ah1D=OMG_URB2D(ix,iy)       
+
+         call BEP1D(iurb,kms,kme,kts,kte,z1D,dt,ua1D,va1D,pt1D,da1D,pr1D,pt01D,  &
+                   zr1D,deltar1D,ah1D,rs1D,rld1D,                   & 
+                   alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,          & 
+                   albg_u,albw_u,albr_u,albwin_u,emg_u,emw_u,emr_u, & 
+                   emwind_u,fww,fwg,fgw,fsw,fws,fsg,                & 
+                   z0g_u,z0r_u,                                     & 
+                   nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u,  & 
+                   nz_u,z_u,                                        & 
+                   cop_u,pwin_u,beta_u,sw_cond_u,time_on_u,         &
+                   time_off_u,targtemp_u,gaptemp_u,targhum_u,       &
+                   gaphum_u, perflo_u, hsesf_u, hsequip,            &
+                   tw1D,tg1D,tr1D,sfw1D,sfg1D,sfr1D,                & 
+                   a_u1D,a_v1D,a_t1D,a_e1D,                         & 
+                   b_u1D,b_v1D,b_t1D,b_ac1D,b_e1D,b_q1D,            & 
+                   dlg1D,dl_u1D,sf1D,vl1D,rl_up(ix,iy),             &
+                   rs_abs(ix,iy),emiss(ix,iy),grdflx_urb(ix,iy),    &
+                   qv1D,tlev1D,qlev1D,sflev1D,lflev1D,consumlev1D,  &
+                   sfvlev1D,lfvlev1D,twlev1D,tglev1D,tflev1D,sfwin1D,&
+                   ix,iy)                            
+
+         do id=1,ndm ! direction 
+	    do iz=1,nz_um   !vertical levels
+               do ibui=1,nbui_max !type of building
+	          sfw1_urb3d(ix,ind_zd(ibui,iz,id),iy)=sfw1D(2*id-1,iz,ibui) 
+	          sfw2_urb3d(ix,ind_zd(ibui,iz,id),iy)=sfw1D(2*id,iz,ibui) 
+	       enddo
+	    enddo
+         enddo
+	 do id=1,ndm
+	  sfg_urb3d(ix,id,iy)=sfg1D(id) 
+	 enddo
+         
+	 do id=1,ndm
+	 do iz=1,nz_um
+	  sfr_urb3d(ix,ind_zdf(iz,id),iy)=sfr1D(id,iz)
+	 enddo
+	 enddo
+         
+         do id=1,ndm
+         do iz_u=1,nz_um
+         do iw=1,nwr_u
+         do ibui=1,nbui_max
+          tw1_urb4d(ix,ind_zwd(ibui,iz_u,iw,id),iy)=tw1D(2*id-1,iz_u,iw,ibui)
+          tw2_urb4d(ix,ind_zwd(ibui,iz_u,iw,id),iy)=tw1D(2*id,iz_u,iw,ibui)
+         enddo
+         enddo
+         enddo
+         enddo
+         
+         do id=1,ndm
+            do ig=1,ng_u
+               tgb_urb4d(ix,ind_gd(ig,id),iy)=tg1D(id,ig)
+            enddo
+            do iz_u=1,nz_um
+               do ir=1,nwr_u
+                  trb_urb4d(ix,ind_zrd(iz_u,ir,id),iy)=tr1D(id,iz_u,ir)
+               enddo
+            enddo
+         enddo
+!
+!Outputs of BEM
+!
+         do ibui=1,nbui_max !type of building
+         do iz_u=1,nz_um !vertical levels
+            tlev_urb3d(ix,ind_bd(ibui,iz_u),iy)=tlev1D(iz_u,ibui)  
+            qlev_urb3d(ix,ind_bd(ibui,iz_u),iy)=qlev1D(iz_u,ibui)  
+         enddo !iz_u
+         enddo !ibui
+         do id=1,ndm !direction
+         do iz_u=1,nz_um !vertical levels
+         do ibui=1,nbui_max !type of building
+               tw1lev_urb3d(ix,ind_wd(ibui,iz_u,id),iy)=twlev1D(2*id-1,iz_u,ibui)
+               tw2lev_urb3d(ix,ind_wd(ibui,iz_u,id),iy)=twlev1D(2*id,iz_u,ibui)
+               sfwin1_urb3d(ix,ind_wd(ibui,iz_u,id),iy)=sfwin1D(2*id-1,iz_u,ibui)
+               sfwin2_urb3d(ix,ind_wd(ibui,iz_u,id),iy)=sfwin1D(2*id,iz_u,ibui)
+            enddo !ibui  
+         enddo !iz_u
+         enddo !id
+        
+         do id=1,ndm !direction
+            do iw=1,ngb_u !layers in the walls
+               do ibui=1,nbui_max  !type of building
+                  tglev_urb3d(ix,ind_gbd(ibui,iw,id),iy)=tglev1D(id,iw,ibui)
+               enddo !ibui
+            enddo !iw
+         enddo !id
+
+         do id=1,ndm   !direction 
+            do iw=1,nf_u !layer in the walls
+               do iz_u=1,nz_um-1 !verticals levels
+                  do ibui=1,nbui_max  !type of building
+                     tflev_urb3d(ix,ind_fbd(ibui,iw,iz_u,id),iy)=tflev1D(id,iw,iz_u,ibui)
+                  enddo !ibui
+               enddo !iz_u
+             enddo !iw
+         enddo !id
+         sf_ac_urb3d(ix,iy)=0.
+         lf_ac_urb3d(ix,iy)=0.
+         cm_ac_urb3d(ix,iy)=0.
+         sfvent_urb3d(ix,iy)=0.
+         lfvent_urb3d(ix,iy)=0.
+
+         meso_urb=(1./4.)*FRC_URB2D(ix,iy)/((bs_u(1,iurb)+ws_u(1,iurb))*bs_u(2,iurb))+ &
+                  (1./4.)*FRC_URB2D(ix,iy)/((bs_u(2,iurb)+ws_u(2,iurb))*bs_u(1,iurb))
+
+                  
+         ibui=0
+         nlev=0
+         nbui=0
+         d_urb=0.
+         do iz=1,nz_um		   
+         if(ss_u(iz,iurb).gt.0) then		
+           ibui=ibui+1		                
+           nlev(ibui)=iz-1
+           d_urb(ibui)=ss_u(iz,iurb)
+           nbui=ibui
+	 endif	  
+         end do  !iz
+
+         do ibui=1,nbui       !type of building   
+         do iz_u=1,nlev(ibui) !vertical levels                    
+               sf_ac_urb3d(ix,iy)=sf_ac_urb3d(ix,iy)+meso_urb*d_urb(ibui)*sflev1D(iz_u,ibui)
+               lf_ac_urb3d(ix,iy)=lf_ac_urb3d(ix,iy)+meso_urb*d_urb(ibui)*lflev1D(iz_u,ibui)
+               cm_ac_urb3d(ix,iy)=cm_ac_urb3d(ix,iy)+meso_urb*d_urb(ibui)*consumlev1D(iz_u,ibui)
+               sfvent_urb3d(ix,iy)=sfvent_urb3d(ix,iy)+meso_urb*d_urb(ibui)*sfvlev1D(iz_u,ibui)
+               lfvent_urb3d(ix,iy)=lfvent_urb3d(ix,iy)+meso_urb*d_urb(ibui)*lfvlev1D(iz_u,ibui)            
+         enddo !iz_u
+         enddo !ibui
+!
+!Add the latent heat exchanged throughout the ventilation in the lf_ac_urb3d output variable. 
+!it is only a print variable
+!
+!        lf_ac_urb3d(ix,iy)=lf_ac_urb3d(ix,iy)+lfvent_urb3d(ix,iy)
+!
+
+         lf_ac_urb3d(ix,iy)=lf_ac_urb3d(ix,iy)-lfvent_urb3d(ix,iy)        
+
+!
+!End outputs of bem
+!
+
+        sf_ac=0.
+        do iz= kts,kte
+          sf(ix,iz,iy)=sf1D(iz)
+          vl(ix,iz,iy)=vl1D(iz)
+          a_u(ix,iz,iy)=a_u1D(iz)
+          a_v(ix,iz,iy)=a_v1D(iz)
+          a_t(ix,iz,iy)=a_t1D(iz)
+          a_e(ix,iz,iy)=a_e1D(iz)
+          b_u(ix,iz,iy)=b_u1D(iz)
+          b_v(ix,iz,iy)=b_v1D(iz)
+          b_t(ix,iz,iy)=b_t1D(iz)
+          sf_ac=sf_ac+b_ac1D(iz)*da1D(iz)*cp_u*dz8w(ix,iz,iy)*vl1D(iz)*FRC_URB2D(ix,iy)
+          b_e(ix,iz,iy)=b_e1D(iz)
+          b_q(ix,iz,iy)=b_q1D(iz)
+          dlg(ix,iz,iy)=dlg1D(iz)
+          dl_u(ix,iz,iy)=dl_u1D(iz)
+         enddo
+         sf(ix,kte+1,iy)=sf1D(kte+1)
+
+         endif ! FRC_URB2D
+   
+      enddo  ! iy
+      enddo  ! ix
+
+        time_bep=time_bep+dt
+
+      return
+      end subroutine BEP_BEM
+            
+! ===6=8===============================================================72
+
+      subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0,   &  
+                      zr,deltar,ah,rs,rld,                             & 
+                      alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,          & 
+                      albg_u,albw_u,albr_u,albwin_u,emg_u,emw_u,emr_u, & 
+                      emwind_u,fww,fwg,fgw,fsw,fws,fsg,                & 
+                      z0g_u,z0r_u,                                     & 
+                      nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u,  & 
+                      nz_u,z_u,                                        & 
+                      cop_u,pwin_u,beta_u,sw_cond_u,time_on_u,         &
+                      time_off_u,targtemp_u,gaptemp_u,targhum_u,       &
+                      gaphum_u, perflo_u, hsesf_u, hsequip,            &
+                      tw,tg,tr,sfw,sfg,sfr,                            & 
+                      a_u,a_v,a_t,a_e,                                 &
+                      b_u,b_v,b_t,b_ac,b_e,b_q,                        & 
+                      dlg,dl_u,sf,vl,rl_up,rs_abs,emiss,grdflx_urb,    &
+                      qv,tlev,qlev,sflev,lflev,consumlev,              &
+                      sfvlev,lfvlev,twlev,tglev,tflev,sfwin,ix,iy)                             
+
+! ----------------------------------------------------------------------
+! This routine computes the effects of buildings on momentum, heat and
+!  TKE (turbulent kinetic energy) sources or sinks and on the mixing length.
+! It provides momentum, heat and TKE sources or sinks at different levels of a
+!  mesoscale grid defined by the altitude of its cell interfaces "z" and
+!  its number of levels "nz".
+! The meteorological input parameters (wind, temperature, solar radiation)
+!  are specified on the "mesoscale grid".
+! The inputs concerning the building and street charateristics are defined
+!  on a "urban grid". The "urban grid" is defined with its number of levels
+!  "nz_u" and its space step "dz_u".
+! The input parameters are interpolated on the "urban grid". The sources or sinks
+!  are calculated on the "urban grid". Finally the sources or sinks are 
+!  interpolated on the "mesoscale grid".
+ 
+
+!  Mesoscale grid            Urban grid             Mesoscale grid
+!  
+! z(4)    ---                                               ---
+!          |                                                 |
+!          |                                                 |
+!          |   Interpolation                  Interpolation  |
+!          |            Sources or sinks calculation         |
+! z(3)    ---                                               ---
+!          | ua               ua_u  ---  uv_a         a_u    |
+!          | va               va_u   |   uv_b         b_u    |
+!          | pt               pt_u  ---  uh_b         a_v    |
+! z(2)    ---                        |    etc...      etc...---
+!          |                 z_u(1) ---                      |
+!          |                         |                       |
+! z(1) ------------------------------------------------------------
+
+!     
+! Reference:
+! Martilli, A., Clappier, A., Rotach, M.W.:2002, 'AN URBAN SURFACE EXCHANGE
+! PARAMETERISATION FOR MESOSCALE MODELS', Boundary-Layer Meteorolgy 104:
+! 261-304
+ 
+! ----------------------------------------------------------------------
+
+      implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+
+! Data relative to the "mesoscale grid"
+
+      integer kms,kme,kts,kte
+      real z(kms:kme)               ! Altitude above the ground of the cell interfaces.
+      real ua(kms:kme)                ! Wind speed in the x direction
+      real va(kms:kme)                ! Wind speed in the y direction
+      real pt(kms:kme)                ! Potential temperature
+      real da(kms:kme)                ! Air density
+      real pr(kms:kme)                ! Air pressure
+      real pt0(kms:kme)               ! Reference potential temperature (could be equal to "pt")
+      real qv(kms:kme)              ! Specific humidity
+      real dt                    ! Time step
+      real zr                    ! Zenith angle
+      real deltar                ! Declination of the sun
+      real ah                    ! Hour angle
+      real rs                    ! Solar radiation
+      real rld                   ! Downward flux of the longwave radiation
+
+! Data relative to the "urban grid"
+
+      integer iurb               ! Current urban class
+
+!    Building parameters      
+      real alag_u(nurbm)         ! Ground thermal diffusivity [m^2 s^-1]
+      real alaw_u(nurbm)         ! Wall thermal diffusivity [m^2 s^-1]
+      real alar_u(nurbm)         ! Roof thermal diffusivity [m^2 s^-1]
+      real csg_u(nurbm)          ! Specific heat of the ground material [J m^3 K^-1]
+      real csw_u(nurbm)          ! Specific heat of the wall material [J m^3 K^-1]
+      real csr_u(nurbm)          ! Specific heat of the roof material [J m^3 K^-1]
+
+!    Radiation parameters
+      real albg_u(nurbm)         ! Albedo of the ground
+      real albw_u(nurbm)         ! Albedo of the wall
+      real albr_u(nurbm)         ! Albedo of the roof
+      real albwin_u(nurbm)       ! Albedo of the windows
+      real emwind_u(nurbm)       ! Emissivity of windows
+      real emg_u(nurbm)          ! Emissivity of ground
+      real emw_u(nurbm)          ! Emissivity of wall
+      real emr_u(nurbm)          ! Emissivity of roof
+
+!    fww,fwg,fgw,fsw,fsg are the view factors used to compute the long and 
+!    short wave radation. 
+!    The calculation of these factor is explained in the Appendix A of the BLM paper
+      real fww(nz_um,nz_um,ndm,nurbm)  !  from wall to wall
+      real fwg(nz_um,ndm,nurbm)        !  from wall to ground
+      real fgw(nz_um,ndm,nurbm)        !  from ground to wall
+      real fsw(nz_um,ndm,nurbm)        !  from sky to wall
+      real fws(nz_um,ndm,nurbm)        !  from wall to sky
+      real fsg(ndm,nurbm)              !  from sky to ground
+
+!    Roughness parameters
+      real z0g_u(nurbm)            ! The ground's roughness length
+      real z0r_u(nurbm)            ! The roof's roughness length
+      
+!    Street parameters
+      integer nd_u(nurbm)          ! Number of street direction for each urban class 
+      real strd_u(ndm,nurbm)       ! Street length (set to a greater value then the horizontal length of the cells)
+      real drst_u(ndm,nurbm)       ! Street direction
+      real ws_u(ndm,nurbm)         ! Street width
+      real bs_u(ndm,nurbm)         ! Building width
+      real h_b(nz_um,nurbm)        ! Bulding's heights
+      real d_b(nz_um,nurbm)        ! The probability that a building has an height "h_b"
+      real ss_u(nz_um,nurbm)     ! The probability that a building has an height equal to "z"
+      real pb_u(nz_um,nurbm)     ! The probability that a building has an height greater or equal to "z"
+        
+!    Grid parameters
+      integer nz_u(nurbm)     ! Number of layer in the urban grid
+      real z_u(nz_um)       ! Height of the urban grid levels
+
+!   MT
+      real cop_u(nurbm)
+      real pwin_u(nurbm)
+      real beta_u(nurbm)
+      integer sw_cond_u(nurbm)
+      real time_on_u(nurbm)
+      real time_off_u(nurbm)
+      real targtemp_u(nurbm)
+      real gaptemp_u(nurbm)
+      real targhum_u(nurbm)
+      real gaphum_u(nurbm)
+      real perflo_u(nurbm)
+      real hsesf_u(nurbm)
+      real hsequip(24)
+
+! ----------------------------------------------------------------------
+! INPUT-OUTPUT
+! ----------------------------------------------------------------------
+
+! Data relative to the "urban grid" which should be stored from the current time step to the next one
+
+      real tw(2*ndm,nz_um,nwr_u,nbui_max)  ! Temperature in each layer of the wall [K]
+      real tr(ndm,nz_um,nwr_u)  ! Temperature in each layer of the roof [K]
+      real tg(ndm,ng_u)          ! Temperature in each layer of the ground [K]
+      real sfw(2*ndm,nz_um,nbui_max)      ! Sensible heat flux from walls
+      real sfg(ndm)              ! Sensible heat flux from ground (road)
+      real sfr(ndm,nz_um)      ! Sensible heat flux from roofs
+      real gfg(ndm)             ! Heat flux transferred from the surface of the ground (road) towards the interior
+      real gfr(ndm,nz_um)     ! Heat flux transferred from the surface of the roof towards the interior
+      real gfw(2*ndm,nz_um,nbui_max)     ! Heat flux transfered from the surface of the walls towards the interior
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+
+! Data relative to the "mesoscale grid"
+
+      real sf(kms:kme)             ! Surface of the "mesoscale grid" cells taking into account the buildings
+      real vl(kms:kme)               ! Volume of the "mesoscale grid" cells taking into account the buildings
+     
+!    Implicit and explicit components of the source and sink terms at each levels,
+!     the fluxes can be computed as follow: FX = A*X + B   example: Heat fluxes = a_t * pt + b_t
+      real a_u(kms:kme)              ! Implicit component of the momentum sources or sinks in the X-direction
+      real a_v(kms:kme)              ! Implicit component of the momentum sources or sinks in the Y-direction
+      real a_t(kms:kme)              ! Implicit component of the heat sources or sinks
+      real a_e(kms:kme)              ! Implicit component of the TKE sources or sinks
+      real b_u(kms:kme)              ! Explicit component of the momentum sources or sinks in the X-direction
+      real b_v(kms:kme)              ! Explicit component of the momentum sources or sinks in the Y-direction
+      real b_t(kms:kme)              ! Explicit component of the heat sources or sinks
+      real b_ac(kms:kme)
+      real b_e(kms:kme)              ! Explicit component of the TKE sources or sinks
+      real b_q(kms:kme)              ! Explicit component of the humidity sources or sinks
+      real dlg(kms:kme)              ! Height above ground (L_ground in formula (24) of the BLM paper). 
+      real dl_u(kms:kme)             ! Length scale (lb in formula (22) ofthe BLM paper).
+      
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+
+      real dz(kms:kme)               ! vertical space steps of the "mesoscale grid"
+
+! Data interpolated from the "mesoscale grid" to the "urban grid"
+
+      real ua_u(nz_um)          ! Wind speed in the x direction
+      real va_u(nz_um)          ! Wind speed in the y direction
+      real pt_u(nz_um)          ! Potential temperature
+      real da_u(nz_um)          ! Air density
+      real pt0_u(nz_um)         ! Reference potential temperature
+      real pr_u(nz_um)          ! Air pressure
+      real qv_u(nz_um)          !Specific humidity
+
+! Data defining the building and street charateristics
+
+      real alag(ng_u)           ! Ground thermal diffusivity for the current urban class [m^2 s^-1] 
+      
+      real csg(ng_u)            ! Specific heat of the ground material of the current urban class [J m^3 K^-1]
+      real csr(nwr_u)            ! Specific heat of the roof material for the current urban class [J m^3 K^-1]
+      real csw(nwr_u)            ! Specific heat of the wall material for the current urban class [J m^3 K^-1]
+
+      real z0(ndm,nz_um)      ! Roughness lengths "profiles"
+      real ws(ndm)              ! Street widths of the current urban class
+      real bs(ndm)              ! Building widths of the current urban class
+      real strd(ndm)            ! Street lengths for the current urban class
+      real drst(ndm)            ! Street directions for the current urban class
+      real ss(nz_um)          ! Probability to have a building with height h
+      real pb(nz_um)          ! Probability to have a building with an height equal
+
+! Solar radiation at each level of the "urban grid"
+
+      real rsg(ndm)             ! Short wave radiation from the ground
+      real rsw(2*ndm,nz_um)     ! Short wave radiation from the walls
+      real rlg(ndm)             ! Long wave radiation from the ground
+      real rlw(2*ndm,nz_um)     ! Long wave radiation from the walls
+
+! Potential temperature of the surfaces at each level of the "urban grid"
+
+      real ptg(ndm)             ! Ground potential temperatures 
+      real ptr(ndm,nz_um)     ! Roof potential temperatures 
+      real ptw(2*ndm,nz_um,nbui_max)     ! Walls potential temperatures 
+
+ 
+! Explicit and implicit component of the momentum, temperature and TKE sources or sinks on
+! vertical surfaces (walls) ans horizontal surfaces (roofs and street)
+! The fluxes can be computed as follow: Fluxes of X = A*X + B
+! Example: Momentum fluxes on vertical surfaces = uva_u * ua_u + uvb_u
+
+      real uhb_u(ndm,nz_um)   ! U (wind component) Horizontal surfaces, B (explicit) term
+      real uva_u(2*ndm,nz_um)   ! U (wind component)   Vertical surfaces, A (implicit) term
+      real uvb_u(2*ndm,nz_um)   ! U (wind component)   Vertical surfaces, B (explicit) term
+      real vhb_u(ndm,nz_um)   ! V (wind component) Horizontal surfaces, B (explicit) term
+      real vva_u(2*ndm,nz_um)   ! V (wind component)   Vertical surfaces, A (implicit) term
+      real vvb_u(2*ndm,nz_um)   ! V (wind component)   Vertical surfaces, B (explicit) term
+      real thb_u(ndm,nz_um)   ! Temperature        Horizontal surfaces, B (explicit) term
+      real tva_u(2*ndm,nz_um)   ! Temperature          Vertical surfaces, A (implicit) term
+      real tvb_u(2*ndm,nz_um)   ! Temperature          Vertical surfaces, B (explicit) term
+      real tvb_ac(2*ndm,nz_um)
+      real ehb_u(ndm,nz_um)   ! Energy (TKE)       Horizontal surfaces, B (explicit) term
+      real evb_u(2*ndm,nz_um)   ! Energy (TKE)         Vertical surfaces, B (explicit) term
+      real qhb_u(ndm,nz_um)     ! Humidity      Horizontal surfaces, B (explicit) term
+      real qvb_u(2*ndm,nz_um)   ! Humidity      Vertical surfaces, B (explicit) term      
+!
+      real rs_abs ! solar radiation absorbed by urban surfaces 
+      real rl_up ! longwave radiation emitted by urban surface to the atmosphere 
+      real emiss ! mean emissivity of the urban surface
+      real grdflx_urb ! ground heat flux
+      real dt_int ! internal time step
+      integer nt_int ! number of internal time step
+      integer iz,id, it_int
+      integer iw,ix,iy
+
+!---------------------------------------
+!New variables uses in BEM
+!----------------------------------------
+   
+      real tmp_u(nz_um)     !Air Temperature [K]
+
+      real dzw(nwr_u)       !Layer sizes in the walls
+      real dzr(nwr_u)       !Layer sizes in the roofs
+      real dzf(nf_u)        !Layer sizes in the floors
+      real dzgb(ngb_u)      !Layer sizes in the ground below the buildings
+
+      real csgb(ngb_u)      !Specific heat of the ground material below the buildings 
+                            !of the current urban class at each ground levels[J m^3 K^-1]
+      real csf(nf_u)        !Specific heat of the floors materials in the buildings 
+                            !of the current urban class at each levels[J m^3 K^-1]
+      real alar(nwr_u+1)    ! Roof thermal diffusivity for the current urban class [W/m K]
+      real alaw(nwr_u+1)    ! Walls thermal diffusivity for the current urban class [W/m K] 
+      real alaf(nf_u+1)     ! Floor thermal diffusivity at each wall layers [W/m K]     
+      real alagb(ngb_u+1)   ! Ground thermal diffusivity below the building at each wall layer [W/m K] 
+
+      real sfrb(ndm,nbui_max)        ! Sensible heat flux from roofs [W/mÃÂ²]
+      real gfrb(ndm,nbui_max)        ! Heat flux flowing inside the roofs [W/mÃÂ²]
+      real sfwb1D(2*ndm,nz_um)    !Sensible heat flux from the walls [W/mÃÂ²] 
+      real sfwin(2*ndm,nz_um,nbui_max)!Sensible heat flux from windows [W/mÃÂ²]
+      real sfwinb1D(2*ndm,nz_um)  !Sensible heat flux from windows [W/mÃÂ²]
+      real gfwb1D(2*ndm,nz_um)    !Heat flux flowing inside the walls [W/mÃÂ²]
+
+      real qlev(nz_um,nbui_max)      !specific humidity [kg/kg]
+      real qlevb1D(nz_um)         !specific humidity [kg/kg] 
+      real tlev(nz_um,nbui_max)      !Indoor temperature [K]
+      real tlevb1D(nz_um)         !Indoor temperature [K]
+      real twb1D(2*ndm,nwr_u,nz_um)     !Wall temperature in BEM [K]      
+      real twlev(2*ndm,nz_um,nbui_max)     !Window temperature in BEM [K]
+      real twlevb1D(2*ndm,nz_um)        !Window temperature in BEM [K]
+      real tglev(ndm,ngb_u,nbui_max)        !Ground temperature below a building in BEM [K]
+      real tglevb1D(ngb_u)               !Ground temperature below a building in BEM [K]
+      real tflev(ndm,nf_u,nz_um-1,nbui_max)!Floor temperature in BEM[K]
+      real tflevb1D(nf_u,nz_um-1)       !Floor temperature in BEM[K]
+      real trb(ndm,nwr_u,nbui_max)         !Roof temperature in BEM [K]
+      real trb1D(nwr_u)                 !Roof temperature in BEM [K]
+      
+      real sflev(nz_um,nz_um)     ! sensible heat flux due to the air conditioning systems [W]
+      real lflev(nz_um,nz_um)     ! latent heat flux due to the air conditioning systems  [W]
+      real consumlev(nz_um,nz_um) ! consumption due to the air conditioning systems [W]
+      real sflev1D(nz_um)         ! sensible heat flux due to the air conditioning systems [W]
+      real lflev1D(nz_um)         ! latent heat flux due to the air conditioning systems  [W]
+      real consumlev1D(nz_um)     ! consumption due to the air conditioning systems [W]
+      real sfvlev(nz_um,nz_um)    ! sensible heat flux due to ventilation [W]
+      real lfvlev(nz_um,nz_um)    ! latent heat flux due to ventilation [W]
+      real sfvlev1D(nz_um)        ! sensible heat flux due to ventilation [W]
+      real lfvlev1D(nz_um)        ! Latent heat flux due to ventilation [W]
+
+      real ptwin(2*ndm,nz_um,nbui_max)  ! window potential temperature
+      real tw_av(2*ndm,nz_um)        ! Averaged temperature of the wall surfaces
+      real twlev_av(2*ndm,nz_um)     ! Averaged temperature of the windows
+      real sfw_av(2*ndm,nz_um)       ! Averaged sensible heat from walls
+      real sfwind_av(2*ndm,nz_um)    ! Averaged sensible heat from windows
+
+      integer nbui                !Total number of different type of buildings in an urban class
+      integer nlev(nz_um)         !Number of levels in each different type of buildings in an urban class
+      integer ibui,ily  
+      real :: nhourday   ! Number of hours from midnight, local time
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+! Fix some usefull parameters for the computation of the sources or sinks
+!
+!initialize inside param
+!
+!      ss=0.
+!      pb=0.
+
+      do iz=kts,kte
+         dz(iz)=z(iz+1)-z(iz)
+      end do
+      call param(iurb,nz_u(iurb),nd_u(iurb),                          &
+                       csg_u,csg,alag_u,alag,csr_u,csr,               &
+                       alar_u,alar,csw_u,csw,alaw_u,alaw,             &
+                       ws_u,ws,bs_u,bs,z0g_u,z0r_u,z0,                &
+                       strd_u,strd,drst_u,drst,ss_u,ss,pb_u,pb,       &
+                       dzw,dzr,dzf,csf,alaf,dzgb,csgb,alagb)
+
+! Interpolation on the "urban grid"
+
+      call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,ua,ua_u)
+      call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,va,va_u)
+      call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pt,pt_u)
+      call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pt0,pt0_u)
+      call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pr,pr_u)
+      call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,da,da_u)
+      call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,qv,qv_u)
+                   
+! Compute the modification of the radiation due to the buildings
+
+      call averaging_temp(tw,twlev,ss,pb,tw_av,twlev_av, &
+                          sfw_av,sfwind_av,sfw,sfwin)
+      call modif_rad(iurb,nd_u(iurb),nz_u(iurb),z_u,ws,           &
+                    drst,strd,ss,pb,                              &
+                    tw_av,tg,twlev_av,albg_u(iurb),albw_u(iurb),  &
+                    emw_u(iurb),emg_u(iurb),pwin_u(iurb),albwin_u(iurb),  &
+                    emwind_u(iurb),fww,fwg,fgw,fsw,fsg,           &
+                    zr,deltar,ah,                                 &
+                    rs,rld,rsw,rsg,rlw,rlg)                       
+
+! calculation of the urban albedo and the upward long wave radiation
+
+       call upward_rad(nd_u(iurb),nz_u(iurb),ws,bs,sigma,pb,ss,                &
+                       tg,emg_u(iurb),albg_u(iurb),rlg,rsg,sfg,                & 
+                       tw_av,emw_u(iurb),albw_u(iurb),rlw,rsw,sfw_av,          & 
+                       tr,emr_u(iurb),albr_u(iurb),emwind_u(iurb),             &
+                       albwin_u(iurb),twlev_av,pwin_u(iurb),sfwind_av,rld,rs,sfr,      & 
+                       rs_abs,rl_up,emiss,grdflx_urb)               
+
+! Compute the surface temperatures
+      
+      call surf_temp(nd_u(iurb),pr_u,dt,              & 
+                    rld,rsg,rlg,                      &
+                    tg,alag,csg,emg_u(iurb),albg_u(iurb),ptg,sfg,gfg)
+
+
+! Call the BEM (Building Energy Model) routine 
+       
+       do iz=1,nz_um !Compute the outdoor temperature 
+	 tmp_u(iz)=pt_u(iz)*(pr_u(iz)/p0)**(rcp_u) 
+       end do
+
+       ibui=0
+       nlev=0
+       nbui=0
+     
+       sfrb=0.     !Sensible heat flux from roof
+       gfrb=0.     !Heat flux flowing inside the roof
+       sfwb1D=0.   !Sensible heat flux from walls
+       sfwinb1D=0. !Sensible heat flux from windows
+       gfwb1D=0.   !Heat flux flowing inside the walls[W/mÃÂ²]
+
+
+       twb1D=0.    !Wall temperature
+       twlevb1D=0. !Window temperature
+       tglevb1D=0. !Ground temperature below a building
+       tflevb1D=0. !Floor temperature     
+       trb=0.      !Roof temperature
+       trb1D=0.    !Roof temperature
+
+       qlevb1D=0. !Indoor humidity
+       tlevb1D=0. !indoor temperature
+
+       sflev1D=0.    !Sensible heat flux from the a.c.
+       lflev1D=0.    !Latent heat flux from the a.c.
+       consumlev1D=0.!Consumption from the a.c.
+       sfvlev1D=0.   !Sensible heat flux from the natural ventilation
+       lfvlev1D=0.   !Latent heat flux from natural ventilation
+
+       ptw=0.        !Wall potential temperature
+       ptwin=0.      !Window potential temperature
+       ptr=0.        !Roof potential temperature
+       
+       do iz=1,nz_um		   
+         if(ss(iz).gt.0) then		
+           ibui=ibui+1		                
+           nlev(ibui)=iz-1
+           nbui=ibui
+           do id=1,ndm
+              sfrb(id,ibui)=sfr(id,iz)
+              do ily=1,nwr_u
+                 trb(id,ily,ibui)=tr(id,iz,ily)
+              enddo
+           enddo
+	 endif	  
+       end do  !iz    
+!--------------------------------------------------------------------------------
+!Loop over BEM  -----------------------------------------------------------------
+!--------------------------------------------------------------------------------
+!--------------------------------------------------------------------------------
+   
+       nhourday=ah/PI*180./15.+12.
+       if (nhourday >= 24) nhourday = nhourday - 24
+       if (nhourday < 0)  nhourday = nhourday + 24
+
+        do ibui=1,nbui
+         
+          do iz=1,nz_um
+             qlevb1D(iz)=qlev(iz,ibui)
+             tlevb1D(iz)=tlev(iz,ibui) 
+          enddo
+             
+          do id=1,ndm
+
+             do ily=1,nwr_u
+                trb1D(ily)=trb(id,ily,ibui)
+             enddo
+             do ily=1,ngb_u
+                tglevb1D(ily)=tglev(id,ily,ibui) 
+             enddo
+              
+             do ily=1,nf_u
+             do iz=1,nz_um-1
+               tflevb1D(ily,iz)=tflev(id,ily,iz,ibui)
+             enddo
+             enddo
+            
+             do iz=1,nz_um
+                sfwinb1D(2*id-1,iz)=sfwin(2*id-1,iz,ibui)
+                sfwinb1D(2*id,iz)=sfwin(2*id,iz,ibui)
+             enddo
+            
+             do iz=1,nz_um
+                do ily=1,nwr_u
+                   twb1D(2*id-1,ily,iz)=tw(2*id-1,iz,ily,ibui)
+                   twb1D(2*id,ily,iz)=tw(2*id,iz,ily,ibui)
+                enddo
+                sfwb1D(2*id-1,iz)=sfw(2*id-1,iz,ibui)
+                sfwb1D(2*id,iz)=sfw(2*id,iz,ibui)
+                twlevb1D(2*id-1,iz)=twlev(2*id-1,iz,ibui)
+                twlevb1D(2*id,iz)=twlev(2*id,iz,ibui)
+             enddo
+          enddo   
+
+          call BEM(nz_um,nlev(ibui),nhourday,dt,bs_u(1,iurb),                   &
+                   bs_u(2,iurb),dz_u,nwr_u,nf_u,nwr_u,ngb_u,sfwb1D,gfwb1D,      &
+                   sfwinb1D,sfrb(1,ibui),gfrb(1,ibui),                          &
+                   latent,sigma,albw_u(iurb),albwin_u(iurb),albr_u(iurb),       &
+     	           emr_u(iurb),emw_u(iurb),emwind_u(iurb),rsw,rlw,r,cp_u,       &
+     	           da_u,tmp_u,qv_u,pr_u,rs,rld,dzw,csw,alaw,pwin_u(iurb),       &
+                   cop_u(iurb),beta_u(iurb),sw_cond_u(iurb),time_on_u(iurb),    &
+                   time_off_u(iurb),targtemp_u(iurb),gaptemp_u(iurb),           &
+                   targhum_u(iurb),gaphum_u(iurb),perflo_u(iurb),hsesf_u(iurb), &
+                   hsequip,                                                     &
+     	           dzf,csf,alaf,dzgb,csgb,alagb,dzr,csr,                        &
+     	           alar,tlevb1D,qlevb1D,twb1D,twlevb1D,tflevb1D,tglevb1D,       &
+     	           trb1D,sflev1D,lflev1D,consumlev1D,sfvlev1D,lfvlev1D)
+                    
+        
+!
+!Temporal modifications
+!
+         sfrb(2,ibui)=sfrb(1,ibui)
+         gfrb(2,ibui)=gfrb(1,ibui)
+!
+!End temporal modifications  
+!        
+           do iz=1,nz_um
+             qlev(iz,ibui)=qlevb1D(iz)
+             tlev(iz,ibui)=tlevb1D(iz)
+             sflev(iz,ibui)=sflev1D(iz)
+             lflev(iz,ibui)=lflev1D(iz)
+             consumlev(iz,ibui)=consumlev1D(iz)
+             sfvlev(iz,ibui)=sfvlev1D(iz)
+             lfvlev(iz,ibui)=lfvlev1D(iz)
+           enddo
+ 
+           do id=1,ndm
+              do ily=1,nwr_u
+                 trb(id,ily,ibui)=trb1D(ily)
+              enddo   
+              do ily=1,ngb_u
+                 tglev(id,ily,ibui)=tglevb1D(ily) 
+              enddo
+
+              do ily=1,nf_u
+              do iz=1,nz_um-1
+                 tflev(id,ily,iz,ibui)=tflevb1D(ily,iz)
+              enddo
+              enddo
+           
+
+             do iz=1,nz_um
+                do ily=1,nwr_u
+                   tw(2*id-1,iz,ily,ibui)=twb1D(2*id-1,ily,iz)
+                   tw(2*id,iz,ily,ibui)=twb1D(2*id,ily,iz)
+                enddo
+                gfw(2*id-1,iz,ibui)=gfwb1D(2*id-1,iz)
+                gfw(2*id,iz,ibui)=gfwb1D(2*id,iz)
+                twlev(2*id-1,iz,ibui)=twlevb1D(2*id-1,iz)
+                twlev(2*id,iz,ibui)=twlevb1D(2*id,iz)
+             enddo
+           enddo       
+
+        enddo !ibui     
+
+!-----------------------------------------------------------------------------
+!End loop over BEM -----------------------------------------------------------
+!-----------------------------------------------------------------------------
+!-----------------------------------------------------------------------------
+
+       ibui=0
+       do iz=1,nz_um		   
+         if(ss(iz).gt.0) then		
+           ibui=ibui+1	
+           do id=1,ndm	
+              gfr(id,iz)=gfrb(id,ibui)
+              sfr(id,iz)=sfrb(id,ibui)
+              do ily=1,nwr_u
+                 tr(id,iz,ily)=trb(id,ily,ibui)
+              enddo
+              ptr(id,iz)=tr(id,iz,nwr_u)*(pr_u(iz)/p0)**(-rcp_u)
+           enddo
+         endif
+       enddo !iz
+
+!Compute the potential temperature for the vertical surfaces of the buildings
+      
+       do id=1,ndm
+          do iz=1,nz_um
+             do ibui=1,nbui
+                ptw(2*id-1,iz,ibui)=tw(2*id-1,iz,nwr_u,ibui)*(pr_u(iz)/p0)**(-rcp_u) 
+                ptw(2*id,iz,ibui)=tw(2*id,iz,nwr_u,ibui)*(pr_u(iz)/p0)**(-rcp_u) 
+                ptwin(2*id-1,iz,ibui)=twlev(2*id-1,iz,ibui)*(pr_u(iz)/p0)**(-rcp_u) 
+                ptwin(2*id,iz,ibui)=twlev(2*id,iz,ibui)*(pr_u(iz)/p0)**(-rcp_u) 
+             enddo
+          enddo
+       enddo
+             
+! Compute the implicit and explicit components of the sources or sinks on the "urban grid"
+     
+      call buildings(iurb,nd_u(iurb),nz_u(iurb),z0,ua_u,va_u,                 & 
+                     pt_u,pt0_u,ptg,ptr,da_u,ptw,ptwin,pwin_u(iurb),drst,     &                      
+                     uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u,qvb_u,qhb_u,   & 
+                     uhb_u,vhb_u,thb_u,ehb_u,ss,dt,sfw,sfg,sfr,               &
+                     sfwin,pb,bs_u,dz_u,sflev,lflev,sfvlev,lfvlev,tvb_ac)  
+     
+! Calculation of the sensible heat fluxes for the ground, the wall and roof
+! Sensible Heat Flux = density * Cp_U * ( A* potential temperature + B )
+! where A and B are the implicit and explicit components of the heat sources or sinks.
+
+      
+! Interpolation on the "mesoscale grid"
+
+      call urban_meso(nd_u(iurb),kms,kme,kts,kte,nz_u(iurb),z,dz,z_u,pb,ss,bs,ws,sf, & 
+                     vl,uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u,                   &
+                     uhb_u,vhb_u,thb_u,ehb_u,qhb_u,qvb_u,                            &
+                     a_u,a_v,a_t,a_e,b_u,b_v,b_t,b_e,b_q,tvb_ac,b_ac)                    
+       
+
+! Calculation of the length scale taking into account the buildings effects
+
+      call interp_length(nd_u(iurb),kms,kme,kts,kte,nz_u(iurb),z_u,z,ss,ws,bs,dlg,dl_u)
+
+      return
+      end subroutine BEP1D
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+       subroutine param(iurb,nz,nd,                                   &
+                       csg_u,csg,alag_u,alag,csr_u,csr,               &
+                       alar_u,alar,csw_u,csw,alaw_u,alaw,             &
+                       ws_u,ws,bs_u,bs,z0g_u,z0r_u,z0,                &  
+                       strd_u,strd,drst_u,drst,ss_u,ss,pb_u,pb,       &
+                       dzw,dzr,dzf,csf,alaf,dzgb,csgb,alagb)        
+
+! ----------------------------------------------------------------------
+!    This routine prepare some usefull parameters       
+! ----------------------------------------------------------------------
+
+      implicit none
+
+  
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      integer iurb                 ! Current urban class
+      integer nz                   ! Number of vertical urban levels in the current class
+      integer nd                   ! Number of street direction for the current urban class
+      real alag_u(nurbm)           ! Ground thermal diffusivity [m^2 s^-1]
+      real alar_u(nurbm)           ! Roof thermal diffusivity [m^2 s^-1]
+      real alaw_u(nurbm)           ! Wall thermal diffusivity [m^2 s^-1]
+      real bs_u(ndm,nurbm)         ! Building width
+      real csg_u(nurbm)            ! Specific heat of the ground material [J m^3 K^-1]
+      real csr_u(nurbm)            ! Specific heat of the roof material [J m^3 K^-1]
+      real csw_u(nurbm)            ! Specific heat of the wall material [J m^3 K^-1]
+      real drst_u(ndm,nurbm)       ! Street direction
+      real strd_u(ndm,nurbm)       ! Street length 
+      real ws_u(ndm,nurbm)         ! Street width
+      real z0g_u(nurbm)            ! The ground's roughness length
+      real z0r_u(nurbm)            ! The roof's roughness length
+      real ss_u(nz_um,nurbm)       ! The probability that a building has an height equal to "z"
+      real pb_u(nz_um,nurbm)       ! The probability that a building has an height greater or equal to "z"
+     
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real alag(ng_u)           ! Ground thermal diffusivity at each ground levels
+      real csg(ng_u)            ! Specific heat of the ground material at each ground levels
+      real bs(ndm)              ! Building width for the current urban class
+      real drst(ndm)            ! street directions for the current urban class
+      real strd(ndm)            ! Street lengths for the current urban class
+      real ws(ndm)              ! Street widths of the current urban class
+      real z0(ndm,nz_um)      ! Roughness lengths "profiles"
+      real ss(nz_um)          ! Probability to have a building with height h
+      real pb(nz_um)          ! Probability to have a building with an height greater or equal to "z"
+
+!-----------------------------------------------------------------------------
+!INPUT/OUTPUT
+!-----------------------------------------------------------------------------
+
+      real dzw(nwr_u)       !Layer sizes in the walls [m]
+      real dzr(nwr_u)       !Layer sizes in the roofs [m]
+      real dzf(nf_u)        !Layer sizes in the floors [m]
+      real dzgb(ngb_u)      !layer sizes in the ground below the buildings [m]
+
+      real csr(nwr_u)       ! Specific heat of the roof material at each roof levels
+      real csw(nwr_u)       ! Specific heat of the wall material at each wall levels
+
+      real csf(nf_u)        !Specific heat of the floors materials in the buildings 
+                            !of the current urban class [J m^3 K^-1]
+      real csgb(ngb_u)      !Specific heat of the ground material below the buildings 
+                            !of the current urban class [J m^3 K^-1]
+      real alar(nwr_u+1)    ! Roof thermal diffusivity at each roof levels [W/ m K]
+      real alaw(nwr_u+1)    ! Wall thermal diffusivity at each wall levels [W/ m K]
+      real alaf(nf_u+1)     ! Floor thermal diffusivity at each wall levels [W/m K]
+      real alagb(ngb_u+1)   ! Ground thermal diffusivity below the building at each wall levels [W/m K]
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer id,ig,ir,iw,iz,iflo
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------  
+!Define the layer sizes in the walls
+        
+      ss=0.
+      pb=0.
+      csg=0.
+      alag=0.
+      csr=0.
+      alar=0.
+      csw=0.
+      alaw=0.
+      z0=0.
+      ws=0.
+      bs=0.
+      strd=0.
+      drst=0.
+      csgb=0.
+      alagb=0.
+      csf=0.
+      alaf=0.
+ 
+      dzgb=(/0.2,0.12,0.08,0.05,0.03,0.02,0.02,0.01,0.005,0.0025/)
+      dzr=(/0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.01,0.005,0.0025/)   
+      dzw=(/0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.01,0.005,0.0025/)
+      dzf=(/0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.02/)   
+      
+      do ig=1,ngb_u
+        csgb(ig) = csg_u(iurb)
+        alagb(ig)= csg_u(iurb)*alag_u(iurb)
+      enddo
+      alagb(ngb_u+1)= csg_u(iurb)*alag_u(iurb)
+      
+      do iflo=1,nf_u
+        csf(iflo) = csw_u(iurb)
+        alaf(iflo)= csw_u(iurb)*alaw_u(iurb) 
+      enddo
+      alaf(nf_u+1)= csw_u(iurb)*alaw_u(iurb) 
+     
+      do ir=1,nwr_u
+        csr(ir) = csr_u(iurb)
+        alar(ir)= csr_u(iurb)*alar_u(iurb)
+      enddo
+      alar(nwr_u+1)= csr_u(iurb)*alar_u(iurb)
+
+      do iw=1,nwr_u
+        csw(iw) = csw_u(iurb)
+        alaw(iw)= csw_u(iurb)*alaw_u(iurb)
+      enddo
+      alaw(nwr_u+1)=csw_u(iurb)*alaw_u(iurb) 
+
+!------------------------------------------------------------------------  
+        
+      do iz=1,nz+1
+         ss(iz)=ss_u(iz,iurb)
+         pb(iz)=pb_u(iz,iurb)
+      end do
+                 
+       do ig=1,ng_u
+        csg(ig)=csg_u(iurb)
+        alag(ig)=alag_u(iurb)
+       enddo
+       
+       do id=1,nd
+        z0(id,1)=z0g_u(iurb)
+        do iz=2,nz+1
+         z0(id,iz)=z0r_u(iurb)
+        enddo
+       enddo
+      
+       do id=1,nd
+        ws(id)=ws_u(id,iurb)
+        bs(id)=bs_u(id,iurb)
+        strd(id)=strd_u(id,iurb)
+        drst(id)=drst_u(id,iurb)     
+       enddo
+
+       
+       return
+       end subroutine param
+       
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+      subroutine interpol(kms,kme,kts,kte,nz_u,z,z_u,c,c_u)
+
+! ----------------------------------------------------------------------
+!  This routine interpolate para
+!  meters from the "mesoscale grid" to
+!  the "urban grid".
+!  See p300 Appendix B.1 of the BLM paper.
+! ----------------------------------------------------------------------
+
+      implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+! Data relative to the "mesoscale grid"
+      integer kts,kte,kms,kme            
+      real z(kms:kme)          ! Altitude of the cell interface
+      real c(kms:kme)            ! Parameter which has to be interpolated
+! Data relative to the "urban grid"
+      integer nz_u          ! Number of levels
+      real z_u(nz_um)      ! Altitude of the cell interface
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real c_u(nz_um)        ! Interpolated paramters in the "urban grid"
+       
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer iz_u,iz
+      real ctot,dz
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+       do iz_u=1,nz_u
+        ctot=0.
+        do iz=kts,kte
+         dz=max(min(z(iz+1),z_u(iz_u+1))-max(z(iz),z_u(iz_u)),0.)
+         ctot=ctot+c(iz)*dz
+        enddo
+        c_u(iz_u)=ctot/(z_u(iz_u+1)-z_u(iz_u))
+       enddo
+       
+       return
+       end subroutine interpol
+         
+! ===6=8===============================================================72       
+! ===6=8===============================================================72    
+
+      subroutine  averaging_temp(tw,twlev,ss,pb,tw_av,twlev_av,&
+                                 sfw_av,sfwind_av,sfw,sfwin) 
+
+      implicit none
+!
+!INPUT VARIABLES
+!
+      real tw(2*ndm,nz_um,nwr_u,nbui_max)        ! Temperature in each layer of the wall [K]
+      real twlev(2*ndm,nz_um,nbui_max)     ! Window temperature in BEM [K]
+      real pb(nz_um)                    ! Probability to have a building with an height equal or greater h
+      real ss(nz_um)                    ! Probability to have a building with height h
+      real sfw(2*ndm,nz_um,nbui_max)             ! Surface fluxes from the walls
+      real sfwin(2*ndm,nz_um,nbui_max)     ! Surface fluxes from the windows
+!
+!OUTPUT VARIABLES
+!
+      real tw_av(2*ndm,nz_um)           ! Averaged temperature of the wall surfaces
+      real twlev_av(2*ndm,nz_um)        ! Averaged temperature of the windows
+      real sfw_av(2*ndm,nz_um)          ! Averaged sensible heat from walls
+      real sfwind_av(2*ndm,nz_um)       ! Averaged sensible heat from windows
+!
+!LOCAL VARIABLES
+!
+      real d_urb(nz_um)    
+      integer nlev(nz_um)            
+      integer id,iz
+      integer nbui,ibui
+!
+!Initialize Variables
+!
+      tw_av=0.
+      twlev_av=0.
+      sfw_av=0.
+      sfwind_av=0.
+      ibui=0
+      nbui=0
+      nlev=0
+      d_urb=0.
+
+      do iz=1,nz_um		   
+         if(ss(iz).gt.0) then		
+           ibui=ibui+1
+           d_urb(ibui)=ss(iz)
+           nlev(ibui)=iz-1
+           nbui=ibui		               
+         endif
+      enddo
+
+      do id=1,ndm
+         do iz=1,nz_um-1
+            if (pb(iz+1).gt.0) then
+                do ibui=1,nbui
+                   if (iz.le.nlev(ibui)) then
+                      tw_av(2*id-1,iz)=tw_av(2*id-1,iz)+(d_urb(ibui)/pb(iz+1))*&
+                                       tw(2*id-1,iz,nwr_u,ibui)**4
+                      tw_av(2*id,iz)=tw_av(2*id,iz)+(d_urb(ibui)/pb(iz+1))*&
+                                     tw(2*id,iz,nwr_u,ibui)**4
+                      twlev_av(2*id-1,iz)=twlev_av(2*id-1,iz)+(d_urb(ibui)/pb(iz+1))*&
+                                          twlev(2*id-1,iz,ibui)**4
+                      twlev_av(2*id,iz)=twlev_av(2*id,iz)+(d_urb(ibui)/pb(iz+1))*&
+                                        twlev(2*id,iz,ibui)**4
+                      sfw_av(2*id-1,iz)=sfw_av(2*id-1,iz)+(d_urb(ibui)/pb(iz+1))*sfw(2*id-1,iz,ibui)
+                      sfw_av(2*id,iz)=sfw_av(2*id,iz)+(d_urb(ibui)/pb(iz+1))*sfw(2*id,iz,ibui)
+                      sfwind_av(2*id-1,iz)=sfwind_av(2*id-1,iz)+(d_urb(ibui)/pb(iz+1))*sfwin(2*id-1,iz,ibui)
+                      sfwind_av(2*id,iz)=sfwind_av(2*id,iz)+(d_urb(ibui)/pb(iz+1))*sfwin(2*id,iz,ibui)
+                   endif
+                enddo
+                tw_av(2*id-1,iz)=tw_av(2*id-1,iz)**(1./4.)
+                tw_av(2*id,iz)=tw_av(2*id,iz)**(1./4.)
+                twlev_av(2*id-1,iz)=twlev_av(2*id-1,iz)**(1./4.)
+                twlev_av(2*id,iz)=twlev_av(2*id,iz)**(1./4.)
+            endif
+         enddo !iz         
+      enddo !id
+      return
+      end subroutine averaging_temp
+! ===6=8===============================================================72       
+! ===6=8===============================================================72    
+
+      subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb,    &
+                          tw,tg,twlev,albg,albw,emw,emg,pwin,albwin,   &
+                          emwin,fww,fwg,fgw,fsw,fsg,             &
+                          zr,deltar,ah,                          &    
+                          rs,rl,rsw,rsg,rlw,rlg)                       
+ 
+! ----------------------------------------------------------------------
+! This routine computes the modification of the short wave and 
+!  long wave radiation due to the buildings.
+! ----------------------------------------------------------------------
+
+      implicit none
+ 
+ 
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      integer iurb              ! current urban class
+      integer nd                ! Number of street direction for the current urban class
+      integer nz_u              ! Number of layer in the urban grid
+      real z(nz_um)           ! Height of the urban grid levels
+      real ws(ndm)              ! Street widths of the current urban class
+      real drst(ndm)            ! street directions for the current urban class
+      real strd(ndm)            ! Street lengths for the current urban class
+      real ss(nz_um)          ! probability to have a building with height h
+      real pb(nz_um)          ! probability to have a building with an height equal
+      real tw(2*ndm,nz_um)    ! Temperature in each layer of the wall [K]
+      real tg(ndm,ng_u)         ! Temperature in each layer of the ground [K]
+      real albg                 ! Albedo of the ground for the current urban class
+      real albw                 ! Albedo of the wall for the current urban class
+      real emg                  ! Emissivity of ground for the current urban class
+      real emw                  ! Emissivity of wall for the current urban class
+      real fgw(nz_um,ndm,nurbm)       ! View factors from ground to wall
+      real fsg(ndm,nurbm)             ! View factors from sky to ground
+      real fsw(nz_um,ndm,nurbm)       ! View factors from sky to wall
+      real fws(nz_um,ndm,nurbm)       ! View factors from wall to sky
+      real fwg(nz_um,ndm,nurbm)       ! View factors from wall to ground
+      real fww(nz_um,nz_um,ndm,nurbm) ! View factors from wall to wall
+      real ah                   ! Hour angle (it should come from the radiation routine)
+      real zr                   ! zenith angle
+      real deltar               ! Declination of the sun
+      real rs                   ! solar radiation
+      real rl                   ! downward flux of the longwave radiation
+!
+!New variables BEM
+!
+      real twlev(2*ndm,nz_um)         ! Window temperature in BEM [K]
+      real pwin                       ! Coverage area fraction of windows in the walls of the buildings 
+      real albwin                     ! Albedo of the windows for the current urban class
+      real emwin                      ! Emissivity of the windows for the current urban class
+      real alb_av                     ! Averaged albedo (window and wall)
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real rlg(ndm)             ! Long wave radiation at the ground
+      real rlw(2*ndm,nz_um)     ! Long wave radiation at the walls
+      real rsg(ndm)             ! Short wave radiation at the ground
+      real rsw(2*ndm,nz_um)     ! Short wave radiation at the walls
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+
+      integer id,iz
+
+!  Calculation of the shadow effects
+
+      call shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z,  &
+                      rs,rsw,rsg)
+
+! Calculation of the reflection effects          
+      do id=1,nd
+         call long_rad(iurb,nz_u,id,emw,emg,emwin,pwin,twlev,      &
+                      fwg,fww,fgw,fsw,fsg,tg,tw,rlg,rlw,rl,pb)
+
+         alb_av=pwin*albwin+(1.-pwin)*albw
+         
+         call short_rad(iurb,nz_u,id,alb_av,albg,fwg,fww,fgw,rsg,rsw,pb)
+  
+      enddo
+      return
+      end subroutine modif_rad
+
+
+! ===6=8===============================================================72  
+! ===6=8===============================================================72     
+
+      subroutine surf_temp(nd,pr,dt,rl,rsg,rlg,  &
+                           tg,alag,csg,emg,albg,ptg,sfg,gfg) 
+
+! ----------------------------------------------------------------------
+! Computation of the surface temperatures for walls, ground and roofs 
+! ----------------------------------------------------------------------
+
+      implicit none
+                  
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      
+      integer nd                ! Number of street direction for the current urban class
+      real alag(ng_u)           ! Ground thermal diffusivity for the current urban class [m^2 s^-1] 
+
+      real albg                 ! Albedo of the ground for the current urban class
+
+      real csg(ng_u)            ! Specific heat of the ground material of the current urban class [J m^3 K^-1]
+
+      real dt                   ! Time step
+      real emg                  ! Emissivity of ground for the current urban class
+
+      real pr(nz_um)            ! Air pressure
+      real rl                   ! Downward flux of the longwave radiation
+      real rlg(ndm)             ! Long wave radiation at the ground
+      real rsg(ndm)             ! Short wave radiation at the ground
+      real sfg(ndm)             ! Sensible heat flux from ground (road)
+
+      real gfg(ndm)             ! Heat flux transferred from the surface of the ground (road) toward the interior
+
+      real tg(ndm,ng_u)         ! Temperature in each layer of the ground [K]
+
+      
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real ptg(ndm)             ! Ground potential temperatures 
+
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer id,ig,ir,iw,iz
+
+      real rtg(ndm)             ! Total radiation at ground(road) surface (solar+incoming long+outgoing long)
+
+      real tg_tmp(ng_u)
+
+
+      real dzg_u(ng_u)          ! Layer sizes in the ground
+      
+      data dzg_u /0.2,0.12,0.08,0.05,0.03,0.02,0.02,0.01,0.005,0.0025/
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+        
+   
+      do id=1,nd
+
+!      Calculation for the ground surfaces
+       do ig=1,ng_u
+        tg_tmp(ig)=tg(id,ig)
+       end do
+!	        
+       call soil_temp(ng_u,dzg_u,tg_tmp,ptg(id),alag,csg,      &
+                     rsg(id),rlg(id),pr(1),                    &
+                     dt,emg,albg,                              &
+                     rtg(id),sfg(id),gfg(id))    
+       do ig=1,ng_u
+        tg(id,ig)=tg_tmp(ig)
+       end do
+	
+      end do !id
+      
+      return
+      end subroutine surf_temp
+     
+! ===6=8===============================================================72     
+! ===6=8===============================================================72  
+
+      subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u,       &
+                        ptg,ptr,da_u,ptw,ptwin,pwin,                 &
+                        drst,uva_u,vva_u,uvb_u,vvb_u,                &
+                        tva_u,tvb_u,evb_u,qvb_u,qhb_u,               &
+                        uhb_u,vhb_u,thb_u,ehb_u,ss,dt,sfw,sfg,sfr,   &
+                        sfwin,pb,bs_u,dz_u,sflev,lflev,sfvlev,lfvlev,tvb_ac)                  
+
+! ----------------------------------------------------------------------
+! This routine computes the sources or sinks of the different quantities 
+! on the urban grid. The actual calculation is done in the subroutines 
+! called flux_wall, and flux_flat.
+! ----------------------------------------------------------------------
+
+      implicit none
+
+        
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      integer nd                ! Number of street direction for the current urban class
+      integer nz                ! number of vertical space steps
+      real ua_u(nz_um)          ! Wind speed in the x direction on the urban grid
+      real va_u(nz_um)          ! Wind speed in the y direction on the urban grid
+      real da_u(nz_um)          ! air density on the urban grid
+      real drst(ndm)            ! Street directions for the current urban class
+      real dz
+      real pt_u(nz_um)          ! Potential temperature on the urban grid
+      real pt0_u(nz_um)         ! reference potential temperature on the urban grid
+      real ptg(ndm)             ! Ground potential temperatures 
+      real ptr(ndm,nz_um)       ! Roof potential temperatures 
+      real ptw(2*ndm,nz_um,nbui_max)     ! Walls potential temperatures 
+      real ss(nz_um)            ! probability to have a building with height h
+      real pb(nz_um)
+      real z0(ndm,nz_um)        ! Roughness lengths "profiles"
+      real dt ! time step
+      integer iurb              !Urban class
+
+!
+!New variables (BEM)
+!
+      real bs_u(ndm,nurbm)    ! Building width [m]
+      real dz_u               ! Urban grid resolution
+      real sflev(nz_um,nz_um)     ! sensible heat flux due to the air conditioning systems  [W]
+      real lflev(nz_um,nz_um)     ! latent heat flux due to the air conditioning systems  [W]
+      real sfvlev(nz_um,nz_um)    ! sensible heat flux due to ventilation [W]
+      real lfvlev(nz_um,nz_um)    ! latent heat flux due to ventilation [W]
+      real qvb_u(2*ndm,nz_um)
+      real qhb_u(ndm,nz_um)
+      real ptwin(2*ndm,nz_um,nbui_max)  ! window potential temperature
+      real pwin
+      real tvb_ac(2*ndm,nz_um)
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+! Explicit and implicit component of the momentum, temperature and TKE sources or sinks on
+! vertical surfaces (walls) and horizontal surfaces (roofs and street)
+! The fluxes can be computed as follow: Fluxes of X = A*X + B
+!  Example: Momentum fluxes on vertical surfaces = uva_u * ua_u + uvb_u
+
+      real uhb_u(ndm,nz_um)   ! U (wind component) Horizontal surfaces, B (explicit) term
+      real uva_u(2*ndm,nz_um)   ! U (wind component)   Vertical surfaces, A (implicit) term
+      real uvb_u(2*ndm,nz_um)   ! U (wind component)   Vertical surfaces, B (explicit) term
+      real vhb_u(ndm,nz_um)   ! V (wind component) Horizontal surfaces, B (explicit) term
+      real vva_u(2*ndm,nz_um)   ! V (wind component)   Vertical surfaces, A (implicit) term
+      real vvb_u(2*ndm,nz_um)   ! V (wind component)   Vertical surfaces, B (explicit) term
+      real thb_u(ndm,nz_um)   ! Temperature        Horizontal surfaces, B (explicit) term
+      real tva_u(2*ndm,nz_um)   ! Temperature          Vertical surfaces, A (implicit) term
+      real tvb_u(2*ndm,nz_um)   ! Temperature          Vertical surfaces, B (explicit) term
+      real ehb_u(ndm,nz_um)   ! Energy (TKE)       Horizontal surfaces, B (explicit) term
+      real evb_u(2*ndm,nz_um)   ! Energy (TKE)         Vertical surfaces, B (explicit) term
+      real sfw(2*ndm,nz_um,nbui_max)   ! sensible heat flux from walls
+      real sfwin(2*ndm,nz_um,nbui_max) ! sensible heat flux form windows
+      real sfr(ndm,nz_um)           ! sensible heat flux from roof
+      real sfg(ndm)                 ! sensible heat flux from street
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      real d_urb(nz_um)
+      real uva_tmp
+      real vva_tmp
+      real uvb_tmp
+      real vvb_tmp 
+      real evb_tmp     
+      integer nlev(nz_um)
+      integer id,iz,ibui,nbui
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+      dz=dz_u
+      ibui=0
+      nbui=0
+      nlev=0
+      d_urb=0.
+      
+      uva_u=0.
+      uvb_u=0.
+      vhb_u=0.
+      vva_u=0.
+      vvb_u=0.
+      thb_u=0.
+      tva_u=0.
+      tvb_u=0.
+      tvb_ac=0.
+      ehb_u=0.
+      evb_u=0.
+      qvb_u=0.
+      qhb_u=0.
+
+      do iz=1,nz_um		   
+         if(ss(iz).gt.0) then		
+           ibui=ibui+1
+           d_urb(ibui)=ss(iz)
+           nlev(ibui)=iz-1
+           nbui=ibui		               
+         endif
+      enddo
+      if (nbui.gt.nbui_max) then
+         write(*,*) 'nbui_max must be increased to',nbui
+         stop
+      endif
+      do id=1,nd
+
+!        Calculation at the ground surfaces
+
+         call flux_flat(dz,z0(id,1),ua_u(1),va_u(1),pt_u(1),pt0_u(1),  &
+                       ptg(id),uhb_u(id,1),                            & 
+                       vhb_u(id,1),sfg(id),ehb_u(id,1),da_u(1))          
+         thb_u(id,1)=- sfg(id)/(da_u(1)*cp_u)  
+              
+!        Calculation at the roof surfaces    
+
+         do iz=2,nz
+            if(ss(iz).gt.0)then
+               call flux_flat(dz,z0(id,iz),ua_u(iz),                  &              
+                       va_u(iz),pt_u(iz),pt0_u(iz),                   &   
+                       ptr(id,iz),uhb_u(id,iz),                       &   
+                       vhb_u(id,iz),sfr(id,iz),ehb_u(id,iz),da_u(iz)) 
+               thb_u(id,iz)=- sfr(id,iz)/(da_u(iz)*cp_u) 
+            else
+               uhb_u(id,iz) = 0.0
+               vhb_u(id,iz) = 0.0
+               thb_u(id,iz) = 0.0
+               ehb_u(id,iz) = 0.0
+            endif
+         end do
+
+!        Calculation at the wall surfaces        
+ 
+         do ibui=1,nbui
+         do iz=1,nlev(ibui)  
+                   
+            call flux_wall(ua_u(iz),va_u(iz),pt_u(iz),da_u(iz),             &  
+                        ptw(2*id-1,iz,ibui),ptwin(2*id-1,iz,ibui),          &   
+                        uva_tmp,vva_tmp,                                    &   
+                        uvb_tmp,vvb_tmp,                                    &   
+                        sfw(2*id-1,iz,ibui),sfwin(2*id-1,iz,ibui),          &   
+                        evb_tmp,drst(id),dt)      
+   
+            if (pb(iz+1).gt.0.) then
+
+                    uva_u(2*id-1,iz)=uva_u(2*id-1,iz)+d_urb(ibui)/pb(iz+1)*uva_tmp
+                    vva_u(2*id-1,iz)=vva_u(2*id-1,iz)+d_urb(ibui)/pb(iz+1)*vva_tmp
+                    uvb_u(2*id-1,iz)=uvb_u(2*id-1,iz)+d_urb(ibui)/pb(iz+1)*uvb_tmp
+                    vvb_u(2*id-1,iz)=vvb_u(2*id-1,iz)+d_urb(ibui)/pb(iz+1)*vvb_tmp
+                    evb_u(2*id-1,iz)=evb_u(2*id-1,iz)+d_urb(ibui)/pb(iz+1)*evb_tmp
+                    tvb_u(2*id-1,iz)=tvb_u(2*id-1,iz)-(d_urb(ibui)/pb(iz+1))*                       &
+                                    (sfw(2*id-1,iz,ibui)*(1.-pwin)+sfwin(2*id-1,iz,ibui)*pwin)/     &
+                                    da_u(iz)/cp_u-(1./4.)*(d_urb(ibui)/pb(iz+1))*(sfvlev(iz,ibui)-sflev(iz,ibui))/&
+                                    (dz*bs_u(id,iurb))/da_u(iz)/cp_u
+                    tvb_ac(2*id-1,iz)=tvb_ac(2*id-1,iz)-(1./4.)*(d_urb(ibui)/pb(iz+1))*(-sflev(iz,ibui))/&
+                                    (dz*bs_u(id,iurb))/da_u(iz)/cp_u
+                    qvb_u(2*id-1,iz)=qvb_u(2*id-1,iz)-(1./4.)*(d_urb(ibui)/pb(iz+1))*(lfvlev(iz,ibui)-lflev(iz,ibui))/&
+                                    (dz*bs_u(id,iurb))/da_u(iz)/latent
+                                     
+            endif
+
+            call flux_wall(ua_u(iz),va_u(iz),pt_u(iz),da_u(iz),    &   
+                        ptw(2*id,iz,ibui),ptwin(2*id,iz,ibui),     &    
+                        uva_tmp,vva_tmp,                           &    
+                        uvb_tmp,vvb_tmp,                           &    
+                        sfw(2*id,iz,ibui),sfwin(2*id,iz,ibui),     &   
+                        evb_tmp,drst(id),dt) 
+
+            if (pb(iz+1).gt.0.) then
+
+                    uva_u(2*id,iz)=uva_u(2*id,iz)+d_urb(ibui)/pb(iz+1)*uva_tmp
+                    vva_u(2*id,iz)=vva_u(2*id,iz)+d_urb(ibui)/pb(iz+1)*vva_tmp
+                    uvb_u(2*id,iz)=uvb_u(2*id,iz)+d_urb(ibui)/pb(iz+1)*uvb_tmp
+                    vvb_u(2*id,iz)=vvb_u(2*id,iz)+d_urb(ibui)/pb(iz+1)*vvb_tmp
+                    evb_u(2*id,iz)=evb_u(2*id,iz)+d_urb(ibui)/pb(iz+1)*evb_tmp
+                    tvb_u(2*id,iz)=tvb_u(2*id,iz)-(d_urb(ibui)/pb(iz+1))*                    &
+                                    (sfw(2*id,iz,ibui)*(1.-pwin)+sfwin(2*id,iz,ibui)*pwin)/  &
+                                     da_u(iz)/cp_u-(1./4.)*(d_urb(ibui)/pb(iz+1))*(sfvlev(iz,ibui)-sflev(iz,ibui))/&
+                                    (dz*bs_u(id,iurb))/da_u(iz)/cp_u
+                    tvb_ac(2*id,iz)=tvb_ac(2*id,iz)-(1./4.)*(d_urb(ibui)/pb(iz+1))*(-sflev(iz,ibui))/&
+                                    (dz*bs_u(id,iurb))/da_u(iz)/cp_u
+                    qvb_u(2*id,iz)=qvb_u(2*id,iz)-(1./4.)*(d_urb(ibui)/pb(iz+1))*(lfvlev(iz,ibui)-lflev(iz,ibui))/&
+                                    (dz*bs_u(id,iurb))/da_u(iz)/latent
+
+            endif
+!
+          enddo !iz
+         enddo !ibui
+         
+      end do !id
+                
+      return
+      end subroutine buildings
+      
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+        subroutine urban_meso(nd,kms,kme,kts,kte,nz_u,z,dz,z_u,pb,ss,bs,ws,sf,vl,    &
+                             uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u, &       
+                             uhb_u,vhb_u,thb_u,ehb_u,qhb_u,qvb_u,       &      
+                             a_u,a_v,a_t,a_e,b_u,b_v,b_t,b_e,b_q,tvb_ac,b_ac)           
+
+! ----------------------------------------------------------------------
+!  This routine interpolates the parameters from the "urban grid" to the
+!  "mesoscale grid".
+!  See p300-301 Appendix B.2 of the BLM paper.  
+! ----------------------------------------------------------------------
+
+      implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+! Data relative to the "mesoscale grid"
+      integer kms,kme,kts,kte               
+      real z(kms:kme)              ! Altitude above the ground of the cell interface
+      real dz(kms:kme)               ! Vertical space steps
+
+! Data relative to the "uban grid"
+      integer nz_u              ! Number of layer in the urban grid
+      integer nd                ! Number of street direction for the current urban class
+      real bs(ndm)              ! Building widths of the current urban class
+      real ws(ndm)              ! Street widths of the current urban class
+      real z_u(nz_um)         ! Height of the urban grid levels
+      real pb(nz_um)          ! Probability to have a building with an height equal
+      real ss(nz_um)          ! Probability to have a building with height h
+      real uhb_u(ndm,nz_um)   ! U (x-wind component) Horizontal surfaces, B (explicit) term
+      real uva_u(2*ndm,nz_um)   ! U (x-wind component) Vertical surfaces, A (implicit) term
+      real uvb_u(2*ndm,nz_um)   ! U (x-wind component) Vertical surfaces, B (explicit) term
+      real vhb_u(ndm,nz_um)   ! V (y-wind component) Horizontal surfaces, B (explicit) term
+      real vva_u(2*ndm,nz_um)   ! V (y-wind component) Vertical surfaces, A (implicit) term
+      real vvb_u(2*ndm,nz_um)   ! V (y-wind component) Vertical surfaces, B (explicit) term
+      real thb_u(ndm,nz_um)   ! Temperature        Horizontal surfaces, B (explicit) term
+      real tva_u(2*ndm,nz_um)   ! Temperature          Vertical surfaces, A (implicit) term
+      real tvb_u(2*ndm,nz_um)   ! Temperature          Vertical surfaces, B (explicit) term
+      real tvb_ac(2*ndm,nz_um)
+      real ehb_u(ndm,nz_um)   ! Energy (TKE)       Horizontal surfaces, B (explicit) term
+      real evb_u(2*ndm,nz_um)   ! Energy (TKE)         Vertical surfaces, B (explicit) term
+!
+!New variables for BEM
+!
+      real qhb_u(ndm,nz_um)
+      real qvb_u(2*ndm,nz_um)
+     
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+! Data relative to the "mesoscale grid"
+      real sf(kms:kme)             ! Surface of the "mesoscale grid" cells taking into account the buildings
+      real vl(kms:kme)               ! Volume of the "mesoscale grid" cells taking into account the buildings
+      real a_u(kms:kme)              ! Implicit component of the momentum sources or sinks in the X-direction
+      real a_v(kms:kme)              ! Implicit component of the momentum sources or sinks in the Y-direction
+      real a_t(kms:kme)              ! Implicit component of the heat sources or sinks
+      real a_e(kms:kme)              ! Implicit component of the TKE sources or sinks
+      real b_u(kms:kme)              ! Explicit component of the momentum sources or sinks in the X-direction
+      real b_v(kms:kme)              ! Explicit component of the momentum sources or sinks in the Y-direction
+      real b_t(kms:kme)              ! Explicit component of the heat sources or sinks
+      real b_ac(kms:kme)
+      real b_e(kms:kme)              ! Explicit component of the TKE sources or sinks
+      real b_q(kms:kme)               ! Explicit component of the humidity sources or sinks
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      real dzz
+      real fact
+      integer id,iz,iz_u
+      real se,sr,st,su,sv,sq
+      real uet(kms:kme)                ! Contribution to TKE due to walls
+      real veb,vta,vtb,vte,vtot,vua,vub,vva,vvb,vqb,vtb_ac
+
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ---------------------------------------------------------------------- 
+
+! initialisation
+
+      do iz=kts,kte
+         a_u(iz)=0.
+         a_v(iz)=0.
+         a_t(iz)=0.
+         a_e(iz)=0.
+         b_u(iz)=0.
+         b_v(iz)=0.
+         b_e(iz)=0.
+         b_t(iz)=0.
+         b_ac(iz)=0.
+         uet(iz)=0.
+         b_q(iz)=0.
+      end do
+            
+! horizontal surfaces
+      do iz=kts,kte
+         sf(iz)=0.
+         vl(iz)=0.
+      enddo
+      sf(kte+1)=0. 
+      
+      do id=1,nd      
+         do iz=kts+1,kte+1
+            sr=0.
+            do iz_u=2,nz_u
+               if(z(iz).lt.z_u(iz_u).and.z(iz).ge.z_u(iz_u-1))then
+                  sr=pb(iz_u)
+               endif
+            enddo
+            sf(iz)=sf(iz)+((ws(id)+(1.-sr)*bs(id))/(ws(id)+bs(id)))/nd
+         enddo
+      enddo
+
+! volume      
+      do iz=kts,kte
+         do id=1,nd
+            vtot=0.
+            do iz_u=1,nz_u
+               dzz=max(min(z_u(iz_u+1),z(iz+1))-max(z_u(iz_u),z(iz)),0.)
+               vtot=vtot+pb(iz_u+1)*dzz
+            enddo
+            vtot=vtot/(z(iz+1)-z(iz))
+            vl(iz)=vl(iz)+(1.-vtot*bs(id)/(ws(id)+bs(id)))/nd
+         enddo
+      enddo
+      
+! horizontal surface impact  
+
+      do id=1,nd
+      
+         fact=1./vl(kts)/dz(kts)*ws(id)/(ws(id)+bs(id))/nd
+         b_t(kts)=b_t(kts)+thb_u(id,1)*fact
+         b_u(kts)=b_u(kts)+uhb_u(id,1)*fact
+         b_v(kts)=b_v(kts)+vhb_u(id,1)*fact 
+         b_e(kts)=b_e(kts)+ehb_u(id,1)*fact*(z_u(2)-z_u(1))
+         b_q(kts)=b_q(kts)+qhb_u(id,1)*fact         
+
+         do iz=kts,kte
+            st=0.
+            su=0.
+            sv=0.
+            se=0.
+            sq=0.
+            do iz_u=2,nz_u
+               if(z(iz).le.z_u(iz_u).and.z(iz+1).gt.z_u(iz_u))then
+                  st=st+ss(iz_u)*thb_u(id,iz_u)
+                  su=su+ss(iz_u)*uhb_u(id,iz_u)
+                  sv=sv+ss(iz_u)*vhb_u(id,iz_u)          
+                  se=se+ss(iz_u)*ehb_u(id,iz_u)*(z_u(iz_u+1)-z_u(iz_u))
+                  sq=sq+ss(iz_u)*qhb_u(id,iz_u)
+               endif
+            enddo
+      
+            fact=bs(id)/(ws(id)+bs(id))/vl(iz)/dz(iz)/nd
+            b_t(iz)=b_t(iz)+st*fact
+            b_u(iz)=b_u(iz)+su*fact
+            b_v(iz)=b_v(iz)+sv*fact
+            b_e(iz)=b_e(iz)+se*fact
+            b_q(iz)=b_q(iz)+sq*fact
+         enddo
+      enddo              
+
+! vertical surface impact
+           
+      do iz=kts,kte 
+         uet(iz)=0.
+         do id=1,nd              
+            vtb=0.
+            vtb_ac=0.
+            vta=0.
+            vua=0.
+            vub=0.
+            vva=0.
+            vvb=0.
+            veb=0.
+	    vte=0.
+            vqb=0.
+            do iz_u=1,nz_u
+               dzz=max(min(z_u(iz_u+1),z(iz+1))-max(z_u(iz_u),z(iz)),0.)
+               fact=dzz/(ws(id)+bs(id))
+               vtb=vtb+pb(iz_u+1)*                                  &        
+                    (tvb_u(2*id-1,iz_u)+tvb_u(2*id,iz_u))*fact 
+               vtb_ac=vtb_ac+pb(iz_u+1)*                            &        
+                    (tvb_ac(2*id-1,iz_u)+tvb_ac(2*id,iz_u))*fact     
+               vta=vta+pb(iz_u+1)*                                  &        
+                   (tva_u(2*id-1,iz_u)+tva_u(2*id,iz_u))*fact
+               vua=vua+pb(iz_u+1)*                                  &        
+                    (uva_u(2*id-1,iz_u)+uva_u(2*id,iz_u))*fact
+               vva=vva+pb(iz_u+1)*                                  &        
+                    (vva_u(2*id-1,iz_u)+vva_u(2*id,iz_u))*fact
+               vub=vub+pb(iz_u+1)*                                  &        
+                    (uvb_u(2*id-1,iz_u)+uvb_u(2*id,iz_u))*fact
+               vvb=vvb+pb(iz_u+1)*                                  &        
+                    (vvb_u(2*id-1,iz_u)+vvb_u(2*id,iz_u))*fact
+               veb=veb+pb(iz_u+1)*                                  &        
+                    (evb_u(2*id-1,iz_u)+evb_u(2*id,iz_u))*fact
+               vqb=vqb+pb(iz_u+1)*                                  &        
+                    (qvb_u(2*id-1,iz_u)+qvb_u(2*id,iz_u))*fact   
+            enddo
+           
+            fact=1./vl(iz)/dz(iz)/nd
+            b_t(iz)=b_t(iz)+vtb*fact
+            b_ac(iz)=b_ac(iz)+vtb_ac*fact
+            a_t(iz)=a_t(iz)+vta*fact
+            a_u(iz)=a_u(iz)+vua*fact
+            a_v(iz)=a_v(iz)+vva*fact
+            b_u(iz)=b_u(iz)+vub*fact
+            b_v(iz)=b_v(iz)+vvb*fact
+            b_e(iz)=b_e(iz)+veb*fact
+            uet(iz)=uet(iz)+vte*fact
+            b_q(iz)=b_q(iz)+vqb*fact
+         enddo              
+      enddo
+      
+
+      
+      return
+      end subroutine urban_meso
+
+! ===6=8===============================================================72 
+! ===6=8===============================================================72 
+
+      subroutine interp_length(nd,kms,kme,kts,kte,nz_u,z_u,z,ss,ws,bs, &
+                             dlg,dl_u)
+
+! ----------------------------------------------------------------------     
+!    Calculation of the length scales
+!    See p272-274 formula (22) and (24) of the BLM paper    
+! ----------------------------------------------------------------------     
+     
+      implicit none
+
+
+! ----------------------------------------------------------------------     
+! INPUT:
+! ----------------------------------------------------------------------     
+      integer kms,kme,kts,kte                
+      real z(kms:kme)              ! Altitude above the ground of the cell interface
+      integer nd                ! Number of street direction for the current urban class
+      integer nz_u              ! Number of levels in the "urban grid"
+      real z_u(nz_um)         ! Height of the urban grid levels
+      real bs(ndm)              ! Building widths of the current urban class
+      real ss(nz_um)          ! Probability to have a building with height h
+      real ws(ndm)              ! Street widths of the current urban class
+
+
+! ----------------------------------------------------------------------     
+! OUTPUT:
+! ----------------------------------------------------------------------     
+      real dlg(kms:kme)              ! Height above ground (L_ground in formula (24) of the BLM paper). 
+      real dl_u(kms:kme)             ! Length scale (lb in formula (22) ofthe BLM paper).
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      real dlgtmp
+      integer id,iz,iz_u
+      real sftot
+      real ulu,ssl
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+   
+        do iz=kts,kte
+         ulu=0.
+         ssl=0.
+         do id=1,nd        
+          do iz_u=2,nz_u
+           if(z_u(iz_u).gt.z(iz))then
+            ulu=ulu+ss(iz_u)/z_u(iz_u)/nd
+            ssl=ssl+ss(iz_u)/nd
+           endif
+          enddo
+         enddo
+
+        if(ulu.ne.0)then
+          dl_u(iz)=ssl/ulu
+         else
+          dl_u(iz)=0.
+         endif
+        enddo
+       
+
+        do iz=kts,kte
+         dlg(iz)=0.
+          do id=1,nd
+           sftot=ws(id)  
+           dlgtmp=ws(id)/((z(iz)+z(iz+1))/2.)
+           do iz_u=1,nz_u
+            if((z(iz)+z(iz+1))/2..gt.z_u(iz_u))then
+             dlgtmp=dlgtmp+ss(iz_u)*bs(id)/                           &                
+                    ((z(iz)+z(iz+1))/2.-z_u(iz_u))
+             sftot=sftot+ss(iz_u)*bs(id)
+            endif
+           enddo
+           dlg(iz)=dlg(iz)+dlgtmp/sftot/nd
+         enddo
+         dlg(iz)=1./dlg(iz)
+        enddo
+        
+       return
+       end subroutine interp_length
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72   
+
+      subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z,    &
+                           rs,rsw,rsg)
+        
+! ----------------------------------------------------------------------
+!         Modification of short wave radiation to take into account
+!         the shadow produced by the buildings
+! ----------------------------------------------------------------------
+
+      implicit none
+     
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      integer nd                ! Number of street direction for the current urban class
+      integer nz_u              ! number of vertical layers defined in the urban grid
+      real ah                   ! Hour angle (it should come from the radiation routine)
+      real deltar               ! Declination of the sun
+      real drst(ndm)            ! street directions for the current urban class
+      real rs                   ! solar radiation
+      real ss(nz_um)          ! probability to have a building with height h
+      real pb(nz_um)          ! Probability that a building has an height greater or equal to h
+      real ws(ndm)              ! Street width of the current urban class
+      real z(nz_um)           ! Height of the urban grid levels
+      real zr                   ! zenith angle
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real rsg(ndm)             ! Short wave radiation at the ground
+      real rsw(2*ndm,nz_um)     ! Short wave radiation at the walls
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer id,iz,jz
+      real aae,aaw,bbb,phix,rd,rtot,wsd
+      
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+      if(rs.eq.0.or.sin(zr).eq.1)then
+         do id=1,nd
+            rsg(id)=0.
+            do iz=1,nz_u
+               rsw(2*id-1,iz)=0.
+               rsw(2*id,iz)=0.
+            enddo
+         enddo
+      else            
+!test              
+         if(abs(sin(zr)).gt.1.e-10)then
+          if(cos(deltar)*sin(ah)/sin(zr).ge.1)then
+           bbb=pi/2.
+          elseif(cos(deltar)*sin(ah)/sin(zr).le.-1)then
+           bbb=-pi/2.
+          else
+           bbb=asin(cos(deltar)*sin(ah)/sin(zr))
+          endif
+         else
+          if(cos(deltar)*sin(ah).ge.0)then
+           bbb=pi/2.
+          elseif(cos(deltar)*sin(ah).lt.0)then
+           bbb=-pi/2.
+          endif
+         endif
+
+         phix=zr
+           
+         do id=1,nd
+        
+            rsg(id)=0.
+           
+            aae=bbb-drst(id)
+            aaw=bbb-drst(id)+pi
+                    
+            do iz=1,nz_u
+               rsw(2*id-1,iz)=0.
+               rsw(2*id,iz)=0.          
+            if (pb(iz+1).gt.0.) then          
+               do jz=1,nz_u                    
+                if(abs(sin(aae)).gt.1.e-10)then
+                  call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aae,   &    
+                      ws(id),rd)                  
+                 rsw(2*id-1,iz)=rsw(2*id-1,iz)+rs*rd*ss(jz+1)/pb(iz+1)
+                endif
+              
+                if(abs(sin(aaw)).gt.1.e-10)then
+                  call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aaw,   &    
+                      ws(id),rd)
+                 rsw(2*id,iz)=rsw(2*id,iz)+rs*rd*ss(jz+1)/pb(iz+1)                  
+                endif
+               enddo             
+            endif  
+            enddo
+        if(abs(sin(aae)).gt.1.e-10)then
+            wsd=abs(ws(id)/sin(aae))
+              
+            do jz=1,nz_u           
+               rd=max(0.,wsd-z(jz+1)*tan(phix))
+               rsg(id)=rsg(id)+rs*rd*ss(jz+1)/wsd          
+            enddo
+            rtot=0.
+           
+            do iz=1,nz_u
+               rtot=rtot+(rsw(2*id,iz)+rsw(2*id-1,iz))*            &
+                         (z(iz+1)-z(iz))
+            enddo
+            rtot=rtot+rsg(id)*ws(id)
+        else
+            rsg(id)=rs
+        endif
+            
+         enddo
+      endif
+         
+      return
+      end subroutine shadow_mas
+         
+! ===6=8===============================================================72     
+! ===6=8===============================================================72     
+
+      subroutine shade_wall(z1,z2,hu,phix,aa,ws,rd)
+
+! ----------------------------------------------------------------------
+! This routine computes the effects of a shadow induced by a building of 
+! height hu, on a portion of wall between z1 and z2. See equation A10, 
+! and correction described below formula A11, and figure A1. Basically rd
+! is the ratio between the horizontal surface illuminated and the portion
+! of wall. Referring to figure A1, multiplying radiation flux density on 
+! a horizontal surface (rs) by x1-x2 we have the radiation energy per 
+! unit time. Dividing this by z2-z1, we obtain the radiation flux 
+! density reaching the portion of the wall between z2 and z1 
+! (everything is assumed in 2D)
+! ----------------------------------------------------------------------
+
+      implicit none
+      
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      real aa                   ! Angle between the sun direction and the face of the wall (A12)
+      real hu                   ! Height of the building that generates the shadow
+      real phix                 ! Solar zenith angle
+      real ws                   ! Width of the street
+      real z1                   ! Height of the level z(iz)
+      real z2                   ! Height of the level z(iz+1)
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real rd                   ! Ratio between (x1-x2)/(z2-z1), see Fig. 1A. 
+                                ! Multiplying rd by rs (radiation flux 
+                                ! density on a horizontal surface) gives 
+                                ! the radiation flux density on the 
+                                ! portion of wall between z1 and z2. 
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      real x1,x2                ! x1,x2 see Fig. A1.
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+      x1=min((hu-z1)*tan(phix),max(0.,ws/sin(aa)))
+      
+      x2=max((hu-z2)*tan(phix),0.)
+
+      rd=max(0.,sin(aa)*(max(0.,x1-x2))/(z2-z1))
+      
+      return
+      end subroutine shade_wall
+
+! ===6=8===============================================================72     
+! ===6=8===============================================================72     
+
+      subroutine long_rad(iurb,nz_u,id,emw,emg,emwin,pwin,twlev,&
+                         fwg,fww,fgw,fsw,fsg,tg,tw,rlg,rlw,rl,pb)
+
+! ----------------------------------------------------------------------
+! This routine computes the effects of the reflections of long-wave 
+! radiation in the street canyon by solving the system 
+! of 2*nz_u+1 eqn. in 2*nz_u+1
+! unkonwn defined in A4, A5 and A6 of the paper (pages 295 and 296).
+! The system is solved by solving A X= B,
+! with A matrix B vector, and X solution. 
+! ----------------------------------------------------------------------
+
+      implicit none
+
+  
+      
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      real emg                        ! Emissivity of ground for the current urban class
+      real emw                        ! Emissivity of wall for the current urban class
+      real fgw(nz_um,ndm,nurbm)       ! View factors from ground to wall
+      real fsg(ndm,nurbm)             ! View factors from sky to ground
+      real fsw(nz_um,ndm,nurbm)       ! View factors from sky to wall
+      real fwg(nz_um,ndm,nurbm)       ! View factors from wall to ground
+      real fww(nz_um,nz_um,ndm,nurbm) ! View factors from wall to wall
+      integer id                      ! Current street direction
+      integer iurb                    ! Current urban class
+      integer nz_u                    ! Number of layer in the urban grid
+      real pb(nz_um)                  ! Probability to have a building with an height equal
+      real rl                         ! Downward flux of the longwave radiation
+      real tg(ndm,ng_u)               ! Temperature in each layer of the ground [K]
+      real tw(2*ndm,nz_um)            ! Temperature in each layer of the wall [K]
+!
+!New Variables for BEM
+!
+      real twlev(2*ndm,nz_um)         ! Window temperature in BEM [K]
+      real emwin                      ! Emissivity of windows
+      real pwin                       ! Coverage area fraction of windows in the walls of the buildings (BEM)
+      
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real rlg(ndm)                   ! Long wave radiation at the ground
+      real rlw(2*ndm,nz_um)           ! Long wave radiation at the walls
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer i,j
+      real aaa(2*nz_um+1,2*nz_um+1)   ! terms of the matrix
+      real bbb(2*nz_um+1)             ! terms of the vector
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+
+! west wall
+       
+      do i=1,nz_u
+        
+        do j=1,nz_u
+         aaa(i,j)=0.
+        enddo
+        
+        aaa(i,i)=1.        
+       
+        do j=nz_u+1,2*nz_u
+         aaa(i,j)=-(1.-emw*(1.-pwin)-emwin*pwin)* &
+                  fww(j-nz_u,i,id,iurb)*pb(j-nz_u+1)
+        enddo
+        
+        aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i,id,iurb)
+        
+        bbb(i)=fsw(i,id,iurb)*rl+emg*fgw(i,id,iurb)*sigma*tg(id,ng_u)**4
+        do j=1,nz_u
+           bbb(i)=bbb(i)+pb(j+1)*sigma*fww(j,i,id,iurb)* &
+                 (emw*(1.-pwin)*tw(2*id,j)**4+emwin*pwin*twlev(2*id,j)**4)+ &
+                 fww(j,i,id,iurb)*rl*(1.-pb(j+1))
+        enddo
+        
+       enddo
+       
+! east wall
+
+       do i=1+nz_u,2*nz_u
+        
+        do j=1,nz_u
+         aaa(i,j)=-(1.-emw*(1.-pwin)-emwin*pwin)*fww(j,i-nz_u,id,iurb)*pb(j+1)
+        enddo
+        
+        do j=1+nz_u,2*nz_u
+         aaa(i,j)=0.
+        enddo
+        
+        aaa(i,i)=1.
+        
+        aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i-nz_u,id,iurb)
+        
+        bbb(i)=fsw(i-nz_u,id,iurb)*rl+  &     
+               emg*fgw(i-nz_u,id,iurb)*sigma*tg(id,ng_u)**4
+
+        do j=1,nz_u
+         bbb(i)=bbb(i)+pb(j+1)*sigma*fww(j,i-nz_u,id,iurb)*  &   
+                (emw*(1.-pwin)*tw(2*id-1,j)**4+emwin*pwin*twlev(2*id-1,j)**4)+&   
+                fww(j,i-nz_u,id,iurb)*rl*(1.-pb(j+1))
+        enddo
+       
+       enddo
+
+! ground
+       do j=1,nz_u
+        aaa(2*nz_u+1,j)=-(1.-emw*(1.-pwin)-emwin*pwin)* &
+                         fwg(j,id,iurb)*pb(j+1)
+       enddo
+       
+       do j=nz_u+1,2*nz_u
+        aaa(2*nz_u+1,j)=-(1.-emw*(1.-pwin)-emwin*pwin)* &
+                         fwg(j-nz_u,id,iurb)*pb(j-nz_u+1)
+       enddo
+       
+       aaa(2*nz_u+1,2*nz_u+1)=1.
+       
+       bbb(2*nz_u+1)=fsg(id,iurb)*rl
+       
+       do i=1,nz_u
+        bbb(2*nz_u+1)=bbb(2*nz_u+1)+sigma*fwg(i,id,iurb)*pb(i+1)*         &
+                      (emw*(1.-pwin)*(tw(2*id-1,i)**4+tw(2*id,i)**4)+     &
+                      emwin*pwin*(twlev(2*id-1,i)**4+twlev(2*id,i)**4))+  &
+                      2.*fwg(i,id,iurb)*(1.-pb(i+1))*rl                  
+       enddo
+   
+
+     
+       call gaussj(aaa,2*nz_u+1,bbb,2*nz_um+1)
+
+       do i=1,nz_u
+        rlw(2*id-1,i)=bbb(i)
+       enddo
+       
+       do i=nz_u+1,2*nz_u
+        rlw(2*id,i-nz_u)=bbb(i)
+       enddo
+       
+       rlg(id)=bbb(2*nz_u+1)
+  
+       return
+       end subroutine long_rad
+             
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+       subroutine short_rad(iurb,nz_u,id,albw,                        & 
+                           albg,fwg,fww,fgw,rsg,rsw,pb)
+
+! ----------------------------------------------------------------------
+! This routine computes the effects of the reflections of short-wave 
+! (solar) radiation in the street canyon by solving the system 
+! of 2*nz_u+1 eqn. in 2*nz_u+1
+! unkonwn defined in A4, A5 and A6 of the paper (pages 295 and 296).
+! The system is solved by solving A X= B,
+! with A matrix B vector, and X solution. 
+! ----------------------------------------------------------------------
+
+      implicit none
+
+  
+      
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      real albg                 ! Albedo of the ground for the current urban class
+      real albw                 ! Albedo of the wall for the current urban class
+      real fgw(nz_um,ndm,nurbm)       ! View factors from ground to wall
+      real fwg(nz_um,ndm,nurbm)       ! View factors from wall to ground
+      real fww(nz_um,nz_um,ndm,nurbm) ! View factors from wall to wall
+      integer id                ! current street direction 
+      integer iurb              ! current urban class
+      integer nz_u              ! Number of layer in the urban grid
+      real pb(nz_um)          ! probability to have a building with an height equal
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real rsg(ndm)             ! Short wave radiation at the ground
+      real rsw(2*ndm,nz_um)     ! Short wave radiation at the walls
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer i,j
+      real aaa(2*nz_um+1,2*nz_um+1)  ! terms of the matrix
+      real bbb(2*nz_um+1)            ! terms of the vector
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+      
+! west wall
+       
+      do i=1,nz_u
+         do j=1,nz_u
+            aaa(i,j)=0.
+         enddo
+         
+         aaa(i,i)=1.        
+         
+         do j=nz_u+1,2*nz_u
+            aaa(i,j)=-albw*fww(j-nz_u,i,id,iurb)*pb(j-nz_u+1)
+         enddo
+         
+         aaa(i,2*nz_u+1)=-albg*fgw(i,id,iurb)
+         bbb(i)=rsw(2*id-1,i)
+         
+      enddo
+       
+! east wall
+
+      do i=1+nz_u,2*nz_u
+         do j=1,nz_u
+            aaa(i,j)=-albw*fww(j,i-nz_u,id,iurb)*pb(j+1)
+         enddo
+         
+         do j=1+nz_u,2*nz_u
+            aaa(i,j)=0.
+         enddo
+         
+        aaa(i,i)=1.
+        aaa(i,2*nz_u+1)=-albg*fgw(i-nz_u,id,iurb)
+        bbb(i)=rsw(2*id,i-nz_u)
+        
+      enddo
+
+! ground
+
+      do j=1,nz_u
+         aaa(2*nz_u+1,j)=-albw*fwg(j,id,iurb)*pb(j+1)
+      enddo
+       
+      do j=nz_u+1,2*nz_u
+         aaa(2*nz_u+1,j)=-albw*fwg(j-nz_u,id,iurb)*pb(j-nz_u+1)
+      enddo
+       
+      aaa(2*nz_u+1,2*nz_u+1)=1.
+      bbb(2*nz_u+1)=rsg(id)
+       
+      call gaussj(aaa,2*nz_u+1,bbb,2*nz_um+1)
+
+      do i=1,nz_u
+         rsw(2*id-1,i)=bbb(i)
+      enddo
+       
+      do i=nz_u+1,2*nz_u
+         rsw(2*id,i-nz_u)=bbb(i) 
+      enddo
+       
+      rsg(id)=bbb(2*nz_u+1)
+       
+      return
+      end subroutine short_rad
+             
+
+! ===6=8===============================================================72     
+! ===6=8===============================================================72     
+      
+      subroutine gaussj(a,n,b,np)
+
+! ----------------------------------------------------------------------
+! This routine solve a linear system of n equations of the form
+!              A X = B
+!  where  A is a matrix a(i,j)
+!         B a vector and X the solution
+! In output b is replaced by the solution     
+! ----------------------------------------------------------------------
+
+      implicit none
+
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      integer np
+      real a(np,np)
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real b(np)
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer nmax
+      parameter (nmax=150)
+
+      real big,dum
+      integer i,icol,irow
+      integer j,k,l,ll,n
+      integer ipiv(nmax)
+      real pivinv
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+       
+      do j=1,n
+         ipiv(j)=0.
+      enddo
+       
+      do i=1,n
+         big=0.
+         do j=1,n
+            if(ipiv(j).ne.1)then
+               do k=1,n
+                  if(ipiv(k).eq.0)then
+                     if(abs(a(j,k)).ge.big)then
+                        big=abs(a(j,k))
+                        irow=j
+                        icol=k
+                     endif
+                  elseif(ipiv(k).gt.1)then
+                     pause 'singular matrix in gaussj'
+                  endif
+               enddo
+            endif
+         enddo
+         
+         ipiv(icol)=ipiv(icol)+1
+         
+         if(irow.ne.icol)then
+            do l=1,n
+               dum=a(irow,l)
+               a(irow,l)=a(icol,l)
+               a(icol,l)=dum
+            enddo
+            
+            dum=b(irow)
+            b(irow)=b(icol)
+            b(icol)=dum
+          
+         endif
+         
+         if(a(icol,icol).eq.0)pause 'singular matrix in gaussj'
+         
+         pivinv=1./a(icol,icol)
+         a(icol,icol)=1
+         
+         do l=1,n
+            a(icol,l)=a(icol,l)*pivinv
+         enddo
+         
+         b(icol)=b(icol)*pivinv
+         
+         do ll=1,n
+            if(ll.ne.icol)then
+               dum=a(ll,icol)
+               a(ll,icol)=0.
+               do l=1,n
+                  a(ll,l)=a(ll,l)-a(icol,l)*dum
+               enddo
+               
+               b(ll)=b(ll)-b(icol)*dum
+               
+            endif
+         enddo
+      enddo
+      
+      return
+      end subroutine gaussj
+         
+! ===6=8===============================================================72     
+! ===6=8===============================================================72     
+       
+      subroutine soil_temp(nz,dz,temp,pt,ala,cs,                       &
+                          rs,rl,press,dt,em,alb,rt,sf,gf)
+
+! ----------------------------------------------------------------------
+! This routine solves the Fourier diffusion equation for heat in 
+! the material (wall, roof, or ground). Resolution is done implicitely.
+! Boundary conditions are: 
+! - fixed temperature at the interior
+! - energy budget at the surface
+! ----------------------------------------------------------------------
+
+      implicit none
+
+     
+                
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+      integer nz                ! Number of layers
+      real ala(nz)              ! Thermal diffusivity in each layers [m^2 s^-1] 
+      real alb                  ! Albedo of the surface
+      real cs(nz)               ! Specific heat of the material [J m^3 K^-1]
+      real dt                   ! Time step
+      real em                   ! Emissivity of the surface
+      real press                ! Pressure at ground level
+      real rl                   ! Downward flux of the longwave radiation
+      real rs                   ! Solar radiation
+      real sf                   ! Sensible heat flux at the surface
+      real temp(nz)             ! Temperature in each layer [K]
+      real dz(nz)               ! Layer sizes [m]
+
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+      real gf                   ! Heat flux transferred from the surface toward the interior
+      real pt                   ! Potential temperature at the surface
+      real rt                   ! Total radiation at the surface (solar+incoming long+outgoing long)
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      integer iz
+      real a(nz,3)
+      real alpha
+      real c(nz)
+      real cddz(nz+2)
+      real tsig
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+       
+      tsig=temp(nz)
+      alpha=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)+sf
+! Compute cddz=2*cd/dz  
+        
+      cddz(1)=ala(1)/dz(1)
+      do iz=2,nz
+         cddz(iz)=2.*ala(iz)/(dz(iz)+dz(iz-1))
+      enddo
+       
+      a(1,1)=0.
+      a(1,2)=1.
+      a(1,3)=0.
+      c(1)=temp(1)
+          
+      do iz=2,nz-1
+         a(iz,1)=-cddz(iz)*dt/dz(iz)
+         a(iz,2)=1+dt*(cddz(iz)+cddz(iz+1))/dz(iz)          
+         a(iz,3)=-cddz(iz+1)*dt/dz(iz)
+         c(iz)=temp(iz)
+      enddo          
+                     
+      a(nz,1)=-dt*cddz(nz)/dz(nz)
+      a(nz,2)=1.+dt*cddz(nz)/dz(nz)
+      a(nz,3)=0.
+      c(nz)=temp(nz)+dt*alpha/cs(nz)/dz(nz)
+
+      
+      call invert(nz,a,c,temp)
+
+           
+      pt=temp(nz)*(press/1.e+5)**(-rcp_u)
+
+      rt=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)
+                        
+       gf=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)+sf                                   
+      return
+      end subroutine soil_temp
+
+! ===6=8===============================================================72 
+! ===6=8===============================================================72 
+
+      subroutine invert(n,a,c,x)
+
+! ----------------------------------------------------------------------
+!        Inversion and resolution of a tridiagonal matrix
+!                   A X = C
+! ----------------------------------------------------------------------
+
+      implicit none
+                
+! ----------------------------------------------------------------------
+! INPUT:
+! ----------------------------------------------------------------------
+       integer n
+       real a(n,3)              !  a(*,1) lower diagonal (Ai,i-1)
+                                !  a(*,2) principal diagonal (Ai,i)
+                                !  a(*,3) upper diagonal (Ai,i+1)
+       real c(n)
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+       real x(n)    
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+       integer i
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+                     
+       do i=n-1,1,-1                 
+          c(i)=c(i)-a(i,3)*c(i+1)/a(i+1,2)
+          a(i,2)=a(i,2)-a(i,3)*a(i+1,1)/a(i+1,2)
+       enddo
+       
+       do i=2,n        
+          c(i)=c(i)-a(i,1)*c(i-1)/a(i-1,2)
+       enddo
+        
+       do i=1,n
+          x(i)=c(i)/a(i,2)
+       enddo
+
+       return
+       end subroutine invert
+  
+
+! ===6=8===============================================================72  
+! ===6=8===============================================================72
+  
+      subroutine flux_wall(ua,va,pt,da,ptw,ptwin,uva,vva,uvb,vvb,  &
+                           sfw,sfwin,evb,drst,dt)         
+       
+! ----------------------------------------------------------------------
+! This routine computes the surface sources or sinks of momentum, tke,
+! and heat from vertical surfaces (walls).   
+! ----------------------------------------------------------------------
+      implicit none   
+         
+! INPUT:
+! -----
+      real drst                 ! street directions for the current urban class
+      real da                   ! air density
+      real pt                   ! potential temperature
+      real ptw                  ! Walls potential temperatures 
+      real ptwin                ! Windows potential temperatures
+      real ua                   ! wind speed
+      real va                   ! wind speed
+      real dt                   !time step
+
+! OUTPUT:
+! ------
+! Explicit and implicit component of the momentum, temperature and TKE sources or sinks on
+! vertical surfaces (walls).
+! The fluxes can be computed as follow: Fluxes of X = A*X + B
+! Example: Momentum fluxes on vertical surfaces = uva_u * ua_u + uvb_u
+
+      real uva                  ! U (wind component)   Vertical surfaces, A (implicit) term
+      real uvb                  ! U (wind component)   Vertical surfaces, B (explicit) term
+      real vva                  ! V (wind component)   Vertical surfaces, A (implicit) term
+      real vvb                  ! V (wind component)   Vertical surfaces, B (explicit) term
+!     real tva                  ! Temperature          Vertical surfaces, A (implicit) term
+!     real tvb                  ! Temperature          Vertical surfaces, B (explicit) term
+      real evb                  ! Energy (TKE)         Vertical surfaces, B (explicit) term
+      real sfw                  ! Surfaces fluxes from the walls
+      real sfwin                ! Surfaces fluxes from the windows
+
+! LOCAL:
+! -----
+      real hc
+      real hcwin
+      real u_ort
+      real vett
+
+
+! -------------------------
+! END VARIABLES DEFINITIONS
+! -------------------------
+
+      vett=(ua**2+va**2)**.5         
+         
+      u_ort=abs((cos(drst)*ua-sin(drst)*va))
+       
+      uva=-cdrag*u_ort/2.*cos(drst)*cos(drst)
+      vva=-cdrag*u_ort/2.*sin(drst)*sin(drst)
+         
+      uvb=cdrag*u_ort/2.*sin(drst)*cos(drst)*va
+      vvb=cdrag*u_ort/2.*sin(drst)*cos(drst)*ua         
+
+      if (vett.lt.4.88) then   
+         hc=5.678*(1.09+0.23*(vett/0.3048))  
+      else
+         hc=5.678*0.53*((vett/0.3048)**0.78)
+      endif 
+
+      if (hc.gt.da*cp_u/dt)then
+         hc=da*cp_u/dt
+      endif
+
+       if (vett.lt.4.88) then
+          hcwin=5.678*(0.99+0.21*(vett/0.3048))
+       else
+          hcwin=5.678*0.50*((vett/0.3048)**0.78)
+       endif
+
+       if (hcwin.gt.da*cp_u/dt) then
+           hcwin=da*cp_u/dt
+       endif
+         
+!         tvb=hc*ptw/da/cp_u
+!         tva=-hc/da/cp_u
+!!!!!!!!!!!!!!!!!!!!
+! explicit 
+
+      sfw=hc*(pt-ptw)
+      sfwin=hcwin*(pt-ptwin)  
+       
+         
+      evb=cdrag*(abs(u_ort)**3.)/2.
+              
+      return
+      end subroutine flux_wall
+         
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+      subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg,                     &
+                          uhb,vhb,sf,ehb,da)
+                                
+! ----------------------------------------------------------------------
+!           Calculation of the flux at the ground 
+!           Formulation of Louis (Louis, 1979)       
+! ----------------------------------------------------------------------
+
+      implicit none
+
+      real dz                   ! first vertical level
+      real pt                   ! potential temperature
+      real pt0                  ! reference potential temperature
+      real ptg                  ! ground potential temperature
+      real ua                   ! wind speed
+      real va                   ! wind speed
+      real z0                   ! Roughness length
+      real da                   ! air density
+      
+     
+
+! ----------------------------------------------------------------------
+! OUTPUT:
+! ----------------------------------------------------------------------
+! Explicit component of the momentum, temperature and TKE sources or sinks on horizontal 
+!  surfaces (roofs and street)
+! The fluxes can be computed as follow: Fluxes of X = B
+!  Example: Momentum fluxes on horizontal surfaces =  uhb_u
+      real uhb                  ! U (wind component) Horizontal surfaces, B (explicit) term
+      real vhb                  ! V (wind component) Horizontal surfaces, B (explicit) term
+!     real thb                  ! Temperature        Horizontal surfaces, B (explicit) term
+!     real tva                  ! Temperature          Vertical surfaces, A (implicit) term
+!     real tvb                  ! Temperature          Vertical surfaces, B (explicit) term
+      real ehb                  ! Energy (TKE)       Horizontal surfaces, B (explicit) term
+      real sf
+
+
+! ----------------------------------------------------------------------
+! LOCAL:
+! ----------------------------------------------------------------------
+      real aa
+      real al
+      real buu
+      real c
+      real fbuw
+      real fbpt
+      real fh
+      real fm
+      real ric
+      real tstar
+      real ustar
+      real utot
+      real wstar
+      real zz
+      
+      real b,cm,ch,rr,tol
+      parameter(b=9.4,cm=7.4,ch=5.3,rr=0.74,tol=.001)
+
+! ----------------------------------------------------------------------
+! END VARIABLES DEFINITIONS
+! ----------------------------------------------------------------------
+
+
+! computation of the ground temperature
+         
+      utot=(ua**2+va**2)**.5
+        
+      
+!!!! Louis formulation
+!
+! compute the bulk Richardson Number
+
+      zz=dz/2.
+   
+
+      utot=max(utot,0.01)
+          
+      ric=2.*g_u*zz*(pt-ptg)/((pt+ptg)*(utot**2))
+              
+      aa=vk/log(zz/z0)
+
+! determine the parameters fm and fh for stable, neutral and unstable conditions
+
+      if(ric.gt.0)then
+         fm=1/(1+0.5*b*ric)**2
+         fh=fm
+      else
+         c=b*cm*aa*aa*(zz/z0)**.5
+         fm=1-b*ric/(1+c*(-ric)**.5)
+         c=c*ch/cm
+         fh=1-b*ric/(1+c*(-ric)**.5)
+      endif
+      
+      fbuw=-aa*aa*utot*utot*fm
+      fbpt=-aa*aa*utot*(pt-ptg)*fh/rr
+                     
+      ustar=(-fbuw)**.5
+      tstar=-fbpt/ustar
+
+      al=(vk*g_u*tstar)/(pt*ustar*ustar)                      
+      
+      buu=-g_u/pt0*ustar*tstar
+       
+      uhb=-ustar*ustar*ua/utot
+      vhb=-ustar*ustar*va/utot 
+      sf= ustar*tstar*da*cp_u   
+       
+!     thb= 0.      
+      ehb=buu
+!!!!!!!!!!!!!!!
+         
+      return
+      end subroutine flux_flat
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+      subroutine icBEP (fww,fwg,fgw,fsw,fws,fsg,                       &
+                       z0g_u,z0r_u,                                    &
+                       nd_u,strd_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u,        &
+                       nz_u,z_u)                               
+
+
+      implicit none 
+      
+   
+!    Building parameters      
+
+!    Radiation parameters
+
+!    Roughness parameters
+      real z0g_u(nurbm)       ! The ground's roughness length      
+      real z0r_u(nurbm)       ! The roof's roughness length     
+
+!    Street parameters
+      integer nd_u(nurbm)     ! Number of street direction for each urban class
+
+      real strd_u(ndm,nurbm)  ! Street length (fix to greater value to the horizontal length of the cells)
+      real ws_u(ndm,nurbm)    ! Street width [m]
+      real bs_u(ndm,nurbm)    ! Building width [m]
+      real h_b(nz_um,nurbm)   ! Bulding's heights [m]
+      real d_b(nz_um,nurbm)   ! The probability that a building has an height h_b
+! -----------------------------------------------------------------------
+!     Output
+!------------------------------------------------------------------------
+
+
+
+!   fww,fwg,fgw,fsw,fsg are the view factors used to compute the long wave
+!   and the short wave radation. They are the part of radiation from a surface
+!   or from the sky to another surface.
+      real fww(nz_um,nz_um,ndm,nurbm)        !  from wall to wall
+      real fwg(nz_um,ndm,nurbm)              !  from wall to ground
+      real fgw(nz_um,ndm,nurbm)              !  from ground to wall
+      real fsw(nz_um,ndm,nurbm)              !  from sky to wall
+      real fws(nz_um,ndm,nurbm)              !  from wall to sky
+      real fsg(ndm,nurbm)                    !  from sky to ground
+
+      real ss_u(nz_um,nurbm)     ! The probability that a building has an height equal to z
+      real pb_u(nz_um,nurbm)     ! The probability that a building has an height greater or equal to z
+        
+!    Grid parameters
+      integer nz_u(nurbm)     ! Number of layer in the urban grid
+      real z_u(nz_um)       ! Height of the urban grid levels
+
+
+! -----------------------------------------------------------------------
+!     Local
+!------------------------------------------------------------------------
+
+      integer iz_u,id,ilu,iurb
+
+      real dtot
+      real hbmax
+
+!------------------------------------------------------------------------
+     
+
+! -----------------------------------------------------------------------
+!     This routine initialise the urban paramters for the BEP module
+!------------------------------------------------------------------------
+!
+!Initialize some variables
+!
+       nz_u=0
+       z_u=0.    
+       ss_u=0.
+       pb_u=0.
+       fww=0.
+       fwg=0.
+       fgw=0.
+       fsw=0.
+       fws=0.
+       fsg=0.
+
+! Computation of the urban levels height
+
+      z_u(1)=0.
+     
+      do iz_u=1,nz_um-1
+         z_u(iz_u+1)=z_u(iz_u)+dz_u
+      enddo
+      
+! Normalisation of the building density
+
+      do iurb=1,nurbm
+         dtot=0.
+         do ilu=1,nz_um
+            dtot=dtot+d_b(ilu,iurb)
+         enddo
+         do ilu=1,nz_um
+            d_b(ilu,iurb)=d_b(ilu,iurb)/dtot
+         enddo
+      enddo      
+
+! Compute the view factors, pb and ss 
+      
+      do iurb=1,nurbm         
+         hbmax=0.
+         nz_u(iurb)=0
+         do ilu=1,nz_um
+            if(h_b(ilu,iurb).gt.hbmax)hbmax=h_b(ilu,iurb)
+         enddo
+         
+         do iz_u=1,nz_um-1
+            if(z_u(iz_u+1).gt.hbmax)go to 10
+         enddo
+         
+ 10      continue
+         nz_u(iurb)=iz_u+1
+
+         do id=1,nd_u(iurb)
+
+            call view_factors(iurb,nz_u(iurb),id,strd_u(id,iurb),   &    
+                            z_u,ws_u(id,iurb),                      &    
+                            fww,fwg,fgw,fsg,fsw,fws) 
+
+            do iz_u=1,nz_u(iurb)
+               ss_u(iz_u,iurb)=0.
+               do ilu=1,nz_um
+                  if(z_u(iz_u).le.h_b(ilu,iurb)                      &    
+                    .and.z_u(iz_u+1).gt.h_b(ilu,iurb))then            
+                        ss_u(iz_u,iurb)=ss_u(iz_u,iurb)+d_b(ilu,iurb)
+                  endif 
+               enddo
+            enddo
+
+            pb_u(1,iurb)=1.
+            do iz_u=1,nz_u(iurb)
+               pb_u(iz_u+1,iurb)=max(0.,pb_u(iz_u,iurb)-ss_u(iz_u,iurb))
+            enddo
+
+         enddo
+      end do
+     
+                  
+      return       
+      end subroutine icBEP
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+      subroutine view_factors(iurb,nz_u,id,dxy,z,ws,fww,fwg,fgw,fsg,fsw,fws) 
+     
+      implicit none
+
+ 
+
+! -----------------------------------------------------------------------
+!     Input
+!------------------------------------------------------------------------
+
+      integer iurb            ! Number of the urban class
+      integer nz_u            ! Number of levels in the urban grid
+      integer id              ! Street direction number
+      real ws                 ! Street width
+      real z(nz_um)         ! Height of the urban grid levels
+      real dxy                ! Street lenght
+
+
+! -----------------------------------------------------------------------
+!     Output
+!------------------------------------------------------------------------
+
+!   fww,fwg,fgw,fsw,fsg are the view factors used to compute the long wave
+!   and the short wave radation. They are the part of radiation from a surface
+!   or from the sky to another surface.
+
+      real fww(nz_um,nz_um,ndm,nurbm)            !  from wall to wall
+      real fwg(nz_um,ndm,nurbm)                  !  from wall to ground
+      real fgw(nz_um,ndm,nurbm)                  !  from ground to wall
+      real fsw(nz_um,ndm,nurbm)                  !  from sky to wall
+      real fws(nz_um,ndm,nurbm)                  !  from wall to sky
+      real fsg(ndm,nurbm)                        !  from sky to ground
+
+
+! -----------------------------------------------------------------------
+!     Local
+!------------------------------------------------------------------------
+
+      integer jz,iz
+
+      real hut
+      real f1,f2,f12,f23,f123,ftot
+      real fprl,fnrm
+      real a1,a2,a3,a4,a12,a23,a123
+
+! -----------------------------------------------------------------------
+!     This routine calculates the view factors
+!------------------------------------------------------------------------
+        
+      hut=z(nz_u+1)
+        
+      do jz=1,nz_u      
+      
+! radiation from wall to wall
+       
+         do iz=1,nz_u
+     
+            call fprls (fprl,dxy,abs(z(jz+1)-z(iz  )),ws)
+            f123=fprl
+            call fprls (fprl,dxy,abs(z(jz+1)-z(iz+1)),ws)
+            f23=fprl
+            call fprls (fprl,dxy,abs(z(jz  )-z(iz  )),ws)
+            f12=fprl
+            call fprls (fprl,dxy,abs(z(jz  )-z(iz+1)),ws)
+            f2 = fprl
+       
+            a123=dxy*(abs(z(jz+1)-z(iz  )))
+            a12 =dxy*(abs(z(jz  )-z(iz  )))
+            a23 =dxy*(abs(z(jz+1)-z(iz+1)))
+            a1  =dxy*(abs(z(iz+1)-z(iz  )))
+            a2  =dxy*(abs(z(jz  )-z(iz+1)))
+            a3  =dxy*(abs(z(jz+1)-z(jz  )))
+       
+            ftot=0.5*(a123*f123-a23*f23-a12*f12+a2*f2)/a1
+       
+            fww(iz,jz,id,iurb)=ftot*a1/a3
+
+         enddo 
+
+! radiation from ground to wall
+       
+         call fnrms (fnrm,z(jz+1),dxy,ws)
+         f12=fnrm
+         call fnrms (fnrm,z(jz)  ,dxy,ws)
+         f1=fnrm
+       
+         a1 = ws*dxy
+         
+         a12= ws*dxy
+       
+         a4=(z(jz+1)-z(jz))*dxy
+       
+         ftot=(a12*f12-a12*f1)/a1
+                    
+         fgw(jz,id,iurb)=ftot*a1/a4
+     
+!  radiation from sky to wall
+     
+         call fnrms(fnrm,hut-z(jz)  ,dxy,ws)
+         f12 = fnrm
+         call fnrms (fnrm,hut-z(jz+1),dxy,ws)
+         f1 =fnrm
+       
+         a1 = ws*dxy
+       
+         a12= ws*dxy
+              
+         a4 = (z(jz+1)-z(jz))*dxy
+       
+         ftot=(a12*f12-a12*f1)/a1
+        
+         fsw(jz,id,iurb)=ftot*a1/a4       
+      
+      enddo
+
+! radiation from wall to sky      
+      do iz=1,nz_u
+       call fnrms(fnrm,ws,dxy,hut-z(iz))
+       f12=fnrm
+       call fnrms(fnrm,ws,dxy,hut-z(iz+1))
+       f1=fnrm
+       a1 = (z(iz+1)-z(iz))*dxy
+       a2 = (hut-z(iz+1))*dxy
+       a12= (hut-z(iz))*dxy
+       a4 = ws*dxy
+       ftot=(a12*f12-a2*f1)/a1
+       fws(iz,id,iurb)=ftot*a1/a4 
+ 
+      enddo
+!!!!!!!!!!!!!
+
+
+       do iz=1,nz_u
+
+! radiation from wall to ground
+      
+         call fnrms (fnrm,ws,dxy,z(iz+1))
+         f12=fnrm
+         call fnrms (fnrm,ws,dxy,z(iz  ))
+         f1 =fnrm
+         
+         a1= (z(iz+1)-z(iz) )*dxy
+       
+         a2 = z(iz)*dxy
+         a12= z(iz+1)*dxy
+         a4 = ws*dxy
+
+         ftot=(a12*f12-a2*f1)/a1        
+                    
+         fwg(iz,id,iurb)=ftot*a1/a4
+        
+      enddo
+
+! radiation from sky to ground
+      
+      call fprls (fprl,dxy,ws,hut)
+      fsg(id,iurb)=fprl
+
+      return
+      end subroutine view_factors
+
+! ===6=8===============================================================72
+! ===6=8===============================================================72
+
+      SUBROUTINE fprls (fprl,a,b,c)
+
+      implicit none
+
+     
+            
+      real a,b,c
+      real x,y
+      real fprl
+
+
+      x=a/c
+      y=b/c
+      
+      if(a.eq.0.or.b.eq.0.)then
+       fprl=0.
+      else
+       fprl=log( ( (1.+x**2)*(1.+y**2)/(1.+x**2+y**2) )**.5)+  &
+           y*((1.+x**2)**.5)*atan(y/((1.+x**2)**.5))+          &  
+           x*((1.+y**2)**.5)*atan(x/((1.+y**2)**.5))-          &   
+           y*atan(y)-x*atan(x)
+       fprl=fprl*2./(pi*x*y)
+      endif
+      
+      return
+      end subroutine fprls
+
+! ===6=8===============================================================72     
+! ===6=8===============================================================72
+
+      SUBROUTINE fnrms (fnrm,a,b,c)
+
+      implicit none
+
+
+
+      real a,b,c
+      real x,y,z,a1,a2,a3,a4,a5,a6
+      real fnrm
+      
+      x=a/b
+      y=c/b
+      z=x**2+y**2
+      
+      if(y.eq.0.or.x.eq.0)then
+       fnrm=0.
+      else
+       a1=log( (1.+x*x)*(1.+y*y)/(1.+z) )
+       a2=y*y*log(y*y*(1.+z)/z/(1.+y*y) )
+       a3=x*x*log(x*x*(1.+z)/z/(1.+x*x) )
+       a4=y*atan(1./y)
+       a5=x*atan(1./x)
+       a6=sqrt(z)*atan(1./sqrt(z))
+       fnrm=0.25*(a1+a2+a3)+a4+a5-a6
+       fnrm=fnrm/(pi*y)
+      endif
+      
+      return
+      end subroutine fnrms
+  ! ===6=8===============================================================72  
+     
+      SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,&
+        twini_u,trini_u,tgini_u,albg_u,albw_u,albr_u,albwin_u,emg_u,emw_u,&
+        emr_u,emwind_u,z0g_u,z0r_u,nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b, &
+        cop_u, pwin_u, beta_u, sw_cond_u, time_on_u, time_off_u, &
+        targtemp_u, gaptemp_u, targhum_u, gaphum_u, perflo_u, hsesf_u, hsequip)
+
+! initialization routine, where the variables from the table are read
+
+      implicit none
+      
+      integer iurb            ! urban class number
+!    Building parameters      
+      real alag_u(nurbm)      ! Ground thermal diffusivity [m^2 s^-1]
+      real alaw_u(nurbm)      ! Wall thermal diffusivity [m^2 s^-1]
+      real alar_u(nurbm)      ! Roof thermal diffusivity [m^2 s^-1]
+      real csg_u(nurbm)       ! Specific heat of the ground material [J m^3 K^-1]
+      real csw_u(nurbm)       ! Specific heat of the wall material [J m^3 K^-1]
+      real csr_u(nurbm)       ! Specific heat of the roof material [J m^3 K^-1]
+      real twini_u(nurbm)     ! Temperature inside the buildings behind the wall [K]
+      real trini_u(nurbm)     ! Temperature inside the buildings behind the roof [K]
+      real tgini_u(nurbm)     ! Initial road temperature
+
+!    Radiation parameters
+      real albg_u(nurbm)      ! Albedo of the ground
+      real albw_u(nurbm)      ! Albedo of the wall
+      real albr_u(nurbm)      ! Albedo of the roof
+      real albwin_u(nurbm)    ! Albedo of the window
+      real emg_u(nurbm)       ! Emissivity of ground
+      real emw_u(nurbm)       ! Emissivity of wall
+      real emr_u(nurbm)       ! Emissivity of roof
+      real emwind_u(nurbm)    ! Emissivity of windows
+
+!    Roughness parameters
+      real z0g_u(nurbm)       ! The ground's roughness length      
+      real z0r_u(nurbm)       ! The roof's roughness length
+
+!    Street parameters
+      integer nd_u(nurbm)     ! Number of street direction for each urban class
+
+      real strd_u(ndm,nurbm)  ! Street length (fix to greater value to the horizontal length of the cells)
+      real drst_u(ndm,nurbm)  ! Street direction [degree]
+      real ws_u(ndm,nurbm)    ! Street width [m]
+      real bs_u(ndm,nurbm)    ! Building width [m]
+      real h_b(nz_um,nurbm)   ! Bulding's heights [m]
+      real d_b(nz_um,nurbm)   ! The probability that a building has an height h_b
+
+      integer i,iu
+      integer nurb ! number of urban classes used
+
+      real, intent(out) :: cop_u(nurbm)
+      real, intent(out) :: pwin_u(nurbm)
+      real, intent(out) :: beta_u(nurbm)
+      integer, intent(out) :: sw_cond_u(nurbm)
+      real, intent(out) :: time_on_u(nurbm)
+      real, intent(out) :: time_off_u(nurbm)
+      real, intent(out) :: targtemp_u(nurbm)
+      real, intent(out) :: gaptemp_u(nurbm)
+      real, intent(out) :: targhum_u(nurbm)
+      real, intent(out) :: gaphum_u(nurbm)
+      real, intent(out) :: perflo_u(nurbm)
+      real, intent(out) :: hsesf_u(nurbm)
+      real, intent(out) :: hsequip(24)
+
+!
+!We initialize
+!
+        h_b=0.
+        d_b=0.
+
+       nurb=ICATE
+       do iu=1,nurb                         
+          nd_u(iu)=0
+       enddo
+
+       csw_u=CAPB_TBL / (( 1.0 / 4.1868 ) * 1.E-6)
+       csr_u=CAPR_TBL / (( 1.0 / 4.1868 ) * 1.E-6)
+       csg_u=CAPG_TBL / (( 1.0 / 4.1868 ) * 1.E-6)
+       do i=1,icate
+         alaw_u(i)=AKSB_TBL(i) / csw_u(i) / (( 1.0 / 4.1868 ) * 1.E-2)
+         alar_u(i)=AKSR_TBL(i) / csr_u(i) / (( 1.0 / 4.1868 ) * 1.E-2)
+         alag_u(i)=AKSG_TBL(i) / csg_u(i) / (( 1.0 / 4.1868 ) * 1.E-2)
+       enddo
+       twini_u=TBLEND_TBL
+       trini_u=TRLEND_TBL
+       tgini_u=TGLEND_TBL
+       albw_u=ALBB_TBL
+       albr_u=ALBR_TBL
+       albg_u=ALBG_TBL
+       emw_u=EPSB_TBL
+       emr_u=EPSR_TBL
+       emg_u=EPSG_TBL
+       z0r_u=Z0R_TBL
+       z0g_u=Z0G_TBL
+       nd_u=NUMDIR_TBL
+!MT BEM
+       cop_u = cop_tbl
+       pwin_u = pwin_tbl
+       beta_u = beta_tbl
+       sw_cond_u = sw_cond_tbl
+       time_on_u = time_on_tbl
+       time_off_u = time_off_tbl
+       targtemp_u = targtemp_tbl
+       gaptemp_u = gaptemp_tbl
+       targhum_u = targhum_tbl
+       gaphum_u = gaphum_tbl
+       perflo_u = perflo_tbl
+       hsesf_u = hsesf_tbl
+       hsequip = hsequip_tbl
+
+       do iu=1,icate
+              if(ndm.lt.nd_u(iu))then
+                write(*,*)'ndm too small in module_sf_bep, please increase to at least ', nd_u(iu)
+                write(*,*)'remember also that num_urban_layers should be equal or greater than nz_um*ndm*nwr-u!'
+                stop
+              endif
+         do i=1,nd_u(iu)
+           drst_u(i,iu)=STREET_DIRECTION_TBL(i,iu) * pi/180.
+           ws_u(i,iu)=STREET_WIDTH_TBL(i,iu)
+           bs_u(i,iu)=BUILDING_WIDTH_TBL(i,iu)
+         enddo
+       enddo
+       do iu=1,ICATE
+          if(nz_um.lt.numhgt_tbl(iu)+3)then
+              write(*,*)'nz_um too small in module_sf_bep, please increase to at least ',numhgt_tbl(iu)+3
+              write(*,*)'remember also that num_urban_layers should be equal or greater than nz_um*ndm*nwr-u!'
+              stop
+          endif
+         do i=1,NUMHGT_TBL(iu)
+           h_b(i,iu)=HEIGHT_BIN_TBL(i,iu)
+           d_b(i,iu)=HPERCENT_BIN_TBL(i,iu)
+         enddo
+       enddo
+
+       do i=1,ndm
+        do iu=1,nurbm
+         strd_u(i,iu)=100000.
+        enddo
+       enddo
+
+       do iu=1,nurb  
+          emwind_u(iu)=0.9                       
+          call albwindow(albwin_u(iu))  
+       enddo
+       
+       return
+       end subroutine init_para
+! ===6================================================================72
+! ===6================================================================72
+      subroutine upward_rad(nd_u,nz_u,ws,bs,sigma,pb,ss,                     &
+                       tg,emg_u,albg_u,rlg,rsg,sfg,                          & 
+                       tw,emw_u,albw_u,rlw,rsw,sfw,                          & 
+                       tr,emr_u,albr_u,emwind,albwind,twlev,pwin,            &
+                       sfwind,rld,rs, sfr,                                   & 
+                       rs_abs,rl_up,emiss,grdflx_urb)
+!
+! IN this surboutine we compute the upward longwave flux, and the albedo
+! needed for the radiation scheme
+!
+      implicit none
+
+!
+!INPUT VARIABLES
+!
+      real rsw(2*ndm,nz_um)        ! Short wave radiation at the wall for a given canyon direction [W/m2]
+      real rlw(2*ndm,nz_um)         ! Long wave radiation at the walls for a given canyon direction [W/m2]
+      real rsg(ndm)                   ! Short wave radiation at the canyon for a given canyon direction [W/m2]
+      real rlg(ndm)                   ! Long wave radiation at the ground for a given canyon direction [W/m2]
+      real rs                        ! Short wave radiation at the horizontal surface from the sun [W/mÃÂ²]  
+      real sfw(2*ndm,nz_um)      ! Sensible heat flux from walls [W/mÃÂ²]
+      real sfg(ndm)              ! Sensible heat flux from ground (road) [W/mÃÂ²]
+      real sfr(ndm,nz_um)      ! Sensible heat flux from roofs [W/mÃÂ²]                      
+      real rld                        ! Long wave radiation from the sky [W/mÃÂ²]
+      real albg_u                    ! albedo of the ground/street
+      real albw_u                    ! albedo of the walls
+      real albr_u                    ! albedo of the roof 
+      real ws(ndm)                        ! width of the street
+      real bs(ndm)
+                        ! building size
+      real pb(nz_um)                ! Probability to have a building with an height equal or higher   
+      integer nz_u
+      real ss(nz_um)                ! Probability to have a building of a given height
+      real sigma                       
+      real emg_u                       ! emissivity of the street
+      real emw_u                       ! emissivity of the wall
+      real emr_u                       ! emissivity of the roof
+      real tw(2*ndm,nz_um)  ! Temperature in each layer of the wall [K]
+      real tr(ndm,nz_um,nwr_u)  ! Temperature in each layer of the roof [K]
+      real tg(ndm,ng_u)          ! Temperature in each layer of the ground [K]
+      integer id ! street direction
+      integer nd_u ! number of street directions
+!
+!New variables BEM
+!
+      real emwind               !Emissivity of the windows
+      real albwind              !Albedo of the windows
+      real twlev(2*ndm,nz_um)   !Averaged Temperature of the windows 
+      real pwin                 !Coverage area fraction of the windows
+      real gflwin               !Heat stored for the windows
+      real sfwind(2*ndm,nz_um)  !Sensible heat flux from windows [W/mÃÂ²]
+
+!OUTPUT/INPUT
+      real rs_abs  ! absrobed solar radiationfor this street direction
+      real rl_up   ! upward longwave radiation for this street direction
+      real emiss ! mean emissivity
+      real grdflx_urb ! ground heat flux 
+!LOCAL
+      integer iz,iw
+      real rl_inc,rl_emit
+      real gfl
+      integer ix,iy,iwrong
+
+         iwrong=1
+      do iz=1,nz_u+1
+      do id=1,nd_u
+      do iw=1,nwr_u
+        if(tr(id,iz,iw).lt.100.)then
+              write(*,*)'in upward_rad ',iz,id,iw,tr(id,iz,iw) 
+              iwrong=0
+        endif
+      enddo
+      enddo
+      enddo
+           if(iwrong.eq.0)stop
+
+      rl_up=0.
+ 
+      rs_abs=0.
+      rl_inc=0.
+      emiss=0.
+      rl_emit=0.
+      grdflx_urb=0.
+      do id=1,nd_u          
+       rl_emit=rl_emit-( emg_u*sigma*(tg(id,ng_u)**4.)+(1-emg_u)*rlg(id))*ws(id)/(ws(id)+bs(id))/nd_u
+       rl_inc=rl_inc+rlg(id)*ws(id)/(ws(id)+bs(id))/nd_u       
+       rs_abs=rs_abs+(1.-albg_u)*rsg(id)*ws(id)/(ws(id)+bs(id))/nd_u
+         gfl=(1.-albg_u)*rsg(id)+emg_u*rlg(id)-emg_u*sigma*(tg(id,ng_u)**4.)+sfg(id)
+         grdflx_urb=grdflx_urb-gfl*ws(id)/(ws(id)+bs(id))/nd_u  
+ 
+          do iz=2,nz_u
+            rl_emit=rl_emit-(emr_u*sigma*(tr(id,iz,nwr_u)**4.)+(1-emr_u)*rld)*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u
+            rl_inc=rl_inc+rld*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u            
+            rs_abs=rs_abs+(1.-albr_u)*rs*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u
+            gfl=(1.-albr_u)*rs+emr_u*rld-emr_u*sigma*(tr(id,iz,nwr_u)**4.)+sfr(id,iz)
+            grdflx_urb=grdflx_urb-gfl*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u
+         enddo
+           
+         do iz=1,nz_u 
+           
+            rl_emit=rl_emit-(emw_u*(1.-pwin)*sigma*(tw(2*id-1,iz)**4.+tw(2*id,iz)**4.)+ &
+                            (emwind*pwin*sigma*(twlev(2*id-1,iz)**4.+twlev(2*id,iz)**4.))+ &
+                ((1.-emw_u)*(1.-pwin)+pwin*(1.-emwind))*(rlw(2*id-1,iz)+rlw(2*id,iz)))* &
+                            dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u
+
+            rl_inc=rl_inc+((rlw(2*id-1,iz)+rlw(2*id,iz)))*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u
+
+            rs_abs=rs_abs+(((1.-albw_u)*(1.-pwin)+(1.-albwind)*pwin)*(rsw(2*id-1,iz)+rsw(2*id,iz)))*&
+                          dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u 
+
+            gfl=(1.-albw_u)*(rsw(2*id-1,iz)+rsw(2*id,iz)) +emw_u*( rlw(2*id-1,iz)+rlw(2*id,iz) )   &
+             -emw_u*sigma*( tw(2*id-1,iz)**4.+tw(2*id,iz)**4. )+(sfw(2*id-1,iz)+sfw(2*id,iz))   
+
+            gflwin=(1.-albwind)*(rsw(2*id-1,iz)+rsw(2*id,iz)) +emwind*(rlw(2*id-1,iz)+rlw(2*id,iz))   &
+             -emwind*sigma*( twlev(2*id-1,iz)**4.+twlev(2*id,iz)**4.)+(sfwind(2*id-1,iz)+sfwind(2*id,iz)) 
+               
+           
+            grdflx_urb=grdflx_urb-(gfl*(1.-pwin)+pwin*gflwin)*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u
+
+         enddo
+          
+      enddo
+        emiss=(emg_u+emw_u+emr_u)/3.
+        rl_up=(rl_inc+rl_emit)-rld
+       
+         
+      return
+
+      END SUBROUTINE upward_rad
+
+!====6=8===============================================================72         
+!====6=8===============================================================72 
+! ===6================================================================72
+! ===6================================================================72
+
+         subroutine albwindow(albwin)
+		
+!-------------------------------------------------------------------
+	 implicit none
+
+
+! -------------------------------------------------------------------
+!Based on the 
+!paper of J.Karlsson and A.Roos(2000):"modelling the angular behaviour
+!of the total solar energy transmittance of windows"
+!Solar Energy Vol.69,No.4,pp. 321-329.      
+! -------------------------------------------------------------------
+!Input
+!-----	
+        
+!Output
+!------
+         real albwin	        ! albedo of the window  
+!Local
+!-----
+	 real a,b,c		!Polynomial coefficients
+	 real alfa,delta,gama	!Polynomial powers
+	 real g0	        !transmittance when the angle 
+                                !of incidence is normal to the surface.
+         real asup,ainf
+	 real fonc
+
+!Constants
+!--------------------
+         
+         real epsilon              !accuracy of the integration
+         parameter (epsilon=1.e-07) 
+         real n1,n2                !Index of refraction for glasses and air
+         parameter(n1=1.,n2=1.5)
+         integer intg,k
+!--------------------------------------------------------------------		
+         if (q_num.eq.0) then
+           write(*,*) 'Category parameter of the windows no valid'
+           stop
+         endif
+
+         g0=4.*n1*n2/((n1+n2)*(n1+n2))
+	 a=8.
+	 b=0.25/q_num
+         c=1.-a-b	
+	 alfa =5.2 + (0.7*q_num)
+	 delta =2.
+	 gama =(5.26+0.06*p_num)+(0.73+0.04*p_num)*q_num
+
+         intg=1
+!----------------------------------------------------------------------
+
+
+100      asup=0.
+         ainf=0.
+
+         do k=1,intg
+          call foncs(fonc,(pi*k/intg),a,b,c,alfa,delta,gama)
+          asup=asup+(pi/intg)*fonc
+         enddo
+
+         intg=intg+1
+
+         do k=1,intg
+          call foncs(fonc,(pi*k/intg),a,b,c,alfa,delta,gama)
+          ainf=ainf+(pi/intg)*fonc
+         enddo
+	 
+         if(abs(asup-ainf).lt.epsilon) then
+           albwin=1-g0+(g0/2.)*asup
+         else
+           goto 100
+         endif
+        
+!---------------------------------------------------------------------- 	
+	return
+	end subroutine albwindow
+!====================================================================72
+!====================================================================72
+
+        subroutine foncs(fonc,x,aa,bb,cc,alf,delt,gam)
+
+        implicit none
+!
+        real x,aa,bb,cc
+        real alf,delt,gam
+        real fonc
+  
+        fonc=(((aa*(x**alf))/(pi**alf))+   &
+             ((bb*(x**delt))/(pi**delt))+  &
+             ((cc*(x**gam))/(pi**gam)))*sin(x)
+        
+        return
+	end subroutine foncs
+!====================================================================72
+!====================================================================72  
+END MODULE module_sf_bep_bem
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_gfdl.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_gfdl.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_gfdl.F	(revision 17)
@@ -0,0 +1,1656 @@
+!-- XLV         latent heat of vaporization for water (J/kg)
+!
+MODULE module_sf_gfdl
+
+!real, dimension(-100:2000,-100:2000), save :: z00
+
+CONTAINS
+
+!-------------------------------------------------------------------
+   SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
+                     CP,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2, CPM,    &
+                     DT, SMOIS,num_soil_layers,ISLTYP,ZNT,UST,PSIM,PSIH,  &
+                     XLAND,HFX,QFX,TAUX,TAUY,LH,GSW,GLW,TSK,FLHC,FLQC,    & ! gopal's doing for Ocean coupling
+                     QGH,QSFC,U10,V10,                          &
+                     GZ1OZ0,WSPD,BR,ISFFLX,                     &
+                     EP1,EP2,KARMAN,NTSFLG,SFENTH,              &
+                     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
+      USE MODULE_GFS_PHYSCONS, grav => con_g
+!-------------------------------------------------------------------
+      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)
+!-- DT          time step (second)
+!-- 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)
+!-- MAVAIL        surface moisture availability (between 0 and 1)
+!-- 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)
+!-- TAUX        RHO*U**2 (Kg/m/s^2)  ! gopal's doing for Ocean coupling
+!-- TAUY        RHO*U**2 (Kg/m/s^2)  ! gopal's doing for Ocean coupling
+!-- LH          net upward latent heat flux at surface (W/m^2)
+!-- GSW         downward short wave flux at ground surface (W/m^2)
+!-- GLW         downward long wave flux at ground 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
+!-- SFENTH      enthalpy flux factor 0 zot via charnock ..>0 zot enhanced>15m/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) ::            ids,ide, jds,jde, kds,kde,      &
+                                        ims,ime, jms,jme, kms,kme,      &
+                                        its,ite, jts,jte, kts,kte,      &
+                                        ISFFLX,NUM_SOIL_LAYERS,NTSFLG
+
+      REAL,    INTENT(IN) ::                                            &
+                                        CP,                             &
+                                        EP1,                            &
+                                        EP2,                            &
+                                        KARMAN,                         &
+                                        R,                              & 
+                                        ROVCP,                          &
+                                        DT,                             &
+                                        SFENTH,                         &
+                                        XLV 
+
+      REAL,    DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::      & 
+                                        P3D,                            &
+                                        QV3D,                           &
+                                        T3D,                            &
+                                        U3D,                            &
+                                        V3D
+      INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN )::   ISLTYP
+      REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), INTENT(INOUT)::   SMOIS
+
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(IN) ::               &
+                                        PSFC,                           &
+                                        GLW,                            &
+                                        GSW,                            &
+                                        XLAND                           
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::            & 
+                                        TSK,                            &
+                                        BR,                             &
+                                        CHS,                            &
+                                        CHS2,                           &
+                                        CPM,                            &
+                                        CQS2,                           &
+                                        FLHC,                           &
+                                        FLQC,                           &
+                                        GZ1OZ0,                         &
+                                        HFX,                            &
+                                        LH,                             &
+                                        PSIM,                           &
+                                        PSIH,                           &
+                                        QFX,                            &
+                                        QGH,                            &
+                                        QSFC,                           &
+                                        UST,                            &
+                                        ZNT,                            &
+                                        WSPD,                           &
+                                        TAUX,                           & ! gopal's doing for Ocean coupling
+                                        TAUY
+
+      REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::                 &
+                                        U10,                            &
+                                        V10 
+
+
+!--------------------------- LOCAL VARS ------------------------------
+
+      REAL ::                           ESAT,                           &
+                                        cpcgs,                          &
+                                        smc,                            &
+                                        smcdry,                         &
+                                        smcmax
+
+      REAL     (kind=kind_phys) ::                                      &
+                                        RHOX
+      REAL, DIMENSION(1:30)    ::       MAXSMC, &
+                                        DRYSMC
+      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                              
+
+      REAL,    DIMENSION(kms:kme, ims:ime) ::                           &
+                                        rpc,                            &
+                                        tpc,                            &
+                                        upc,                            &
+                                        vpc
+    
+     REAL,    DIMENSION(ims:ime) ::                                     &
+                                        pspc,                           &
+                                        pkmax,                          &
+                                        tstrc,                          &
+                                        zoc,                            &
+                                        wetc,                           &
+                                        slwdc,                          &
+                                        rib,                            &
+                                        zkmax,                          &
+                                        tkmax,                          &
+                                        fxmx,                           &
+                                        fxmy,                           &
+                                        cdm,                            &
+                                        fxh,                            &
+                                        fxe,                            &
+                                        xxfh,                           &
+                                        xxfh2,                          &
+                                        wind10,                         &
+                                        tjloc
+
+      INTEGER ::                                                        &
+                                        I,                              &
+                                        II,                             &
+                                        IGPVS,                          &
+                                        IM,                             &
+                                        J,                              &
+                                        K,                              &
+                                        KM
+
+
+        DATA MAXSMC/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.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/
+
+        DATA DRYSMC/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.000, 0.006, 0.028, 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/
+      DATA IGPVS/0/
+      save igpvs
+
+
+   if(igpvs.eq.0) then
+!     call readzo(glat,glon,6,ims,ime,jms,jme,its,ite,jts,jte,z00)
+   endif
+   igpvs=1
+
+   IM=ITE-ITS+1
+   KM=KTE-KTS+1
+
+   WRITE(0,*)'WITHIN THE GFDL SCHEME, NTSFLG=1 FOR GFDL SLAB  2010 UPGRADS',NTSFLG
+
+   DO J=jts,jte
+
+      DO i=its,ite
+        DDVEL(I)=0.
+        RCL(i)=1.
+        PRSL1(i)=P3D(i,kts,j)*.001
+         wetc(i)=1.0
+         if(xland(i,j).lt.1.99) then
+         smc=smois(i,1,j)
+         smcdry=drysmc(isltyp(i,j))
+         smcmax=maxsmc(isltyp(i,j))
+         wetc(i)=(smc-smcdry)/(smcmax-smcdry)
+         wetc(i)=amin1(1.,amax1(wetc(i),0.))
+         endif  
+!       convert from Pa to cgs...
+        pspc(i)=PSFC(i,j)*10.   
+        pkmax(i)=P3D(i,kts,j)*10.
+        PS(i)=PSFC(i,j)*.001
+        Q1(I) = QV3D(i,kts,j)
+        rpc(kts,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)
+        tstrc(i)=TSK(i,j)
+        T1(I) = T3D(i,kts,j)
+        tpc(kts,i)=T3D(i,kts,j)
+        U1(I) = U3D(i,kts,j)
+        upc(kts,i)=U3D(i,kts,j) * 100.
+        USTAR(I) = UST(i,j)
+        V1(I) = V3D(i,kts,j)
+        vpc(kts,i)=v3D(i,kts,j) * 100.
+        Z0RL(I) = ZNT(i,j)*100.
+        zoc(i)=ZNT(i,j)*100.
+         if(XLAND(i,j).gt.1.99)  zoc(i)=- zoc(i)
+!        Z0RL(I) = z00(i,j)*100.
+!       slwdc... GFDL downward net flux in units of cal/(cm**2/min)
+!       also divide by 10**4 to convert from /m**2 to /cm**2
+        slwdc(i)=gsw(i,j)+glw(i,j)
+        slwdc(i)=0.239*60.*slwdc(i)*1.e-4
+         tjloc(i)=float(j)
+        
+      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
+
+!     if(j==2)then
+!       write(0,*)'--------------------------------------------'
+!       write(0,*) 'u, v, t, r, pkmax, pspc,wetc, tjloc,zoc,tstr'
+!       write(0,*)'--------------------------------------------'
+!     endif
+
+!     do i = its,ite
+!       WRITE(0,1010)i,j,upc(kts,i),vpc(kts,i),tpc(kts,i),rpc(kts,i),     &
+!                    pkmax(i),pspc(i),wetc(i),tjloc(i),zoc(i),tstrc(i)
+!     enddo
+
+     CALL MFLUX2(  fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,tstrc,   &
+                   pspc,pkmax,wetc,slwdc,tjloc,                &
+                   upc,vpc,tpc,rpc,dt,J,wind10,xxfh2,ntsflg,SFENTH,   &
+                   ids,ide, jds,jde, kds,kde,                  &
+                   ims,ime, jms,jme, kms,kme,                  &
+                   its,ite, jts,jte, kts,kte                   )
+
+!     if(j==2)then
+!       write(0,*)'--------------------------------------------'
+!       write(0,*) 'fxh, fxe, fxmx, fxmy, cdm, xxfh zoc,tstrc'
+!       write(0,*)'--------------------------------------------'
+!     endif
+
+!     do i = its,ite
+!       WRITE(0,1010)i,j,fxh(i),fxe(i),fxmx(i),fxmy(i),cdm(i),rib(i),xxfh(i),zoc(i),tstrc(i)
+!     enddo
+
+1010  format(2I4,9F11.6)
+
+
+
+!GFDL     CALL PROGTM(IM,KM,PS,U1,V1,T1,Q1,                                 &
+!GFDL             SHELEG,TSKIN,QSURF,                                   &
+!WRF              SMC,STC,DM,SOILTYP,SIGMAF,VEGTYPE,CANOPY,DLWFLX,      &
+!WRF              SLRAD,SNOWMT,DELT,                                    &
+!GFDL             Z0RL,                                                 &
+!WRF              TG3,GFLUX,F10M,                                       &
+!GFDL             U10M,V10M,T2M,Q2M,                                    &
+!WRF              ZSOIL,                                                &
+!GFDL             CM,CH,RB,                                             &
+!WRF              RHSCNPY,RHSMC,AIM,BIM,CIM,                            &
+!GFDL             RCL,PRSL1,PRSLKI,SLIMSK,                              &
+!GFDL             DRAIN,EVAP,HFLX,STRESS,EP,                            &
+!GFDL             FM,FH,USTAR,WIND,DDVEL,                               &
+!GFDL             PM,PH,FH2,QSS,Z1                                      )
+
+
+      DO i=its,ite
+!       update skin temp only when using GFDL slab...
+
+        IF(NTSFLG==1)    then
+        tsk(i,j) = tstrc(i)      ! gopal's doing 
+!bugfix 4
+!       bob's doing patch tsk with neigboring values... are grid boundaries
+        if(j.eq.jde) then
+         tsk(i,j) = tsk(i,j-1)
+         endif
+
+        if(j.eq.jds) then
+         tsk(i,j) = tsk(i,j+1)
+         endif
+   
+        if(i.eq.ide) tsk(i,j) = tsk(i-1,j)
+        if(i.eq.ids) tsk(i,j) = tsk(i+1,j)
+        endif
+
+
+        znt(i,j)= 0.01*abs(zoc(i))
+        wspd(i,j) = SQRT(upc(kts,i)*upc(kts,i) + vpc(kts,i)*vpc(kts,i))
+        wspd(i,j) = amax1(wspd(i,j)    ,100.)/100.
+        u10m(i) = u1(i)*(wind10(i)/wspd(i,j))/100.
+        v10m(i) = v1(i)*(wind10(i)/wspd(i,j))/100.
+!       br     =0.0001*zfull(i,kmax)*dthv/
+!    &          (gmks*theta(i,kmax)*wspd     *wspd     )
+!       zkmax    = rgas*tpc(kmax,i)*qqlog(kmax)*og
+        zkmax(i) = -R*tpc(kts,i)*alog(pkmax(i)/pspc(i))/grav
+!------------------------------------------------------------------------
+
+        gz1oz0(i,j)=alog(zkmax(i)/znt(i,j))
+        ustar   (i)= 0.01*sqrt(cdm(i)*   &
+                   (upc(kts,i)*upc(kts,i) + vpc(kts,i)*vpc(kts,i)))
+!       convert from g/(cm*cm*sec) to kg/(m*m*sec)
+        qfx   (i,j)=-10.*fxe(i)            ! BOB: qfx   (i,1)=-10.*fxe(i)
+!       cpcgs  = 1.00464e7
+!       convert from ergs/gram/K to J/kg/K  cpmks=1004
+!       hfx   (i,1)=-0.001*cpcgs*fxh(i)
+        hfx   (i,j)=       -10.*CP*fxh(i)  ! Bob: hfx   (i,1)=       -10.*CP*fxh(i)
+        taux  (i,j)= fxmx(i)/10.    ! gopal's doing for Ocean coupling
+        tauy  (i,j)= fxmy(i)/10.    ! gopal's doing for Ocean coupling
+        fm(i)         = karman/sqrt(cdm(i))
+        fh(i)         = karman*xxfh(i)            
+        PSIM(i,j)=GZ1OZ0(i,j)-FM(i)
+        PSIH(i,j)=GZ1OZ0(i,j)-FH(i)
+        fh2(i)         = karman*xxfh2(i)            
+        ch(i)      = karman*karman/(fm(i) * fh(i))
+        cm(i)      = cdm(i)
+
+        U10(i,j)=U10M(i)
+        V10(i,j)=V10M(i)
+        BR(i,j)=rib(i)
+        CHS(I,J)=CH(I)*wspd (i,j)
+        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)
+        esat = fpvs(tskin(i))
+        qss(i) = 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) = SQRT(upc(kts,i)*upc(kts,i) + vpc(kts,i)*vpc(kts,i))
+!       wspd (i,j) = amax1(wspd (i,j)        ,100.)/100.
+!       WSPD(i,j)=WIND(i)
+!       ZNT(i,j)=Z0RL(i)*.01
+      ENDDO
+
+!       write(0,*)'fm,fh,cm,ch(125)', fm(125),fh(125),cm(125),ch(125)
+
+      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))
+!           cpcgs  = 1.00464e7
+!       convert from ergs/gram/K to J/kg/K  cpmks=1004
+!           hfx   (i,j)=-0.001*cpcgs*fxh(i)
+            hfx   (i,j)=       -10.*CP*fxh(i)    !  Bob: hfx   (i,1)= -10.*CP*fxh(i)
+          ELSEIF(XLAND(I,J)-1.5.LT.0.)THEN
+!           HFX(I,J)=FLHC(I,J)*(THGB(I)-THX(I))
+!           cpcgs  = 1.00464e7
+!       convert from ergs/gram/K to J/kg/K  cpmks=1004
+!           hfx   (i,j)=-0.001*cpcgs*fxh(i)
+            hfx   (i,j)=       -10.*CP*fxh(i)    ! Bob: hfx   (i,j)=  -10.*CP*fxh(i) 
+            HFX(I,J)=AMAX1(HFX(I,J),-250.)
+          ENDIF
+!         QFX(I,J)=FLQC(I,J)*(QSFC(I,J)-Q1(I))
+!       convert from g/(cm*cm*sec) to kg/(m*m*sec)
+          qfx(i,j)=-10.*fxe(i)
+          QFX(I,J)=AMAX1(QFX(I,J),0.)
+          LH(I,J)=XLV*QFX(I,J)
+        ENDDO
+      ENDIF
+!       if(j.eq.2) write(0,*) 'u3d ,ustar,cdm at end of gfdlsfcmod'
+!       write(0,*) j,(u3d(ii,1,j),ii=70,90)
+!       write(0,*) j,(ustar(ii),ii=70,90)
+!       write(0,*) j,(cdm(ii),ii=70,90)
+    if(j.eq.jds.or.j.eq.jde) then
+
+    write(0,*) "TSFC in gfdl sf mod,dt, its,ite,jts,jts", dt,its,ite,jts,jte,ids,ide,jds,jde
+    write(0,*) "TSFC",  (TSK(i,j),i=its,ite)
+    endif
+
+   ENDDO            ! FOR THE J LOOP I PRESUME
+!      if(100.ge.its.and.100.le.ite.and.100.ge.jts.and.100.le.jte) then 
+!       write(0,*) 'output vars of sf_gfdl at i,j=100'
+!       write(0,*) 'TSK',TSK(100,100)                  
+!       write(0,*) 'PSFC',PSFC(100,100)
+!       write(0,*) 'GLW',GLW(100,100)
+!       write(0,*) 'GSW',GSW(100,100)
+!       write(0,*) 'XLAND',XLAND(100,100)
+!       write(0,*) 'BR',BR(100,100)
+!       write(0,*) 'CHS',CHS(100,100)
+!       write(0,*) 'CHS2',CHS2(100,100)
+!       write(0,*) 'CPM',CPM(100,100)
+!       write(0,*) 'FLHC',FLHC(100,100)
+!       write(0,*) 'FLQC',FLQC(100,100)
+!       write(0,*) 'GZ1OZ0',GZ1OZ0(100,100)
+!       write(0,*) 'HFX',HFX(100,100)
+!       write(0,*) 'LH',LH(100,100)
+!       write(0,*) 'PSIM',PSIM(100,100)
+!       write(0,*) 'PSIH',PSIH(100,100)
+!       write(0,*) 'QFX',QFX(100,100)
+!       write(0,*) 'QGH',QGH(100,100)
+!       write(0,*) 'QSFC',QSFC(100,100)
+!       write(0,*) 'UST',UST(100,100)
+!       write(0,*) 'ZNT',ZNT(100,100)
+!       write(0,*) 'wet',wet(100)
+!       write(0,*) 'smois',smois(100,1,100)
+!       write(0,*) 'WSPD',WSPD(100,100)
+!       write(0,*) 'U10',U10(100,100)
+!       write(0,*) 'V10',V10(100,100)
+!      endif 
+
+
+   END SUBROUTINE SF_GFDL
+
+!-------------------------------------------------------------------
+       SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,tstrc,       &
+                          pspc,pkmax,wetc,slwdc,tjloc,                    &
+                          upc,vpc,tpc,rpc,dt,jfix,wind10,xxfh2,ntsflg,sfenth,    &
+                          ids,ide, jds,jde, kds,kde,                      &
+                          ims,ime, jms,jme, kms,kme,                      &
+                          its,ite, jts,jte, kts,kte                       )
+  
+!------------------------------------------------------------------------
+!
+!     MFLUX2 computes surface fluxes of momentum, heat,and moisture 
+!     using monin-obukhov. the roughness length "z0" is prescribed 
+!     over land and over ocean "z0" is computed using charnocks formula.
+!     the universal functions (from similarity theory approach) are 
+!     those of hicks. This is Bob's doing.
+!
+!------------------------------------------------------------------------
+
+      IMPLICIT NONE
+!     use allocate_mod
+!     use module_TLDATA , ONLY : tab,table,cp,g,rgas,og 
+
+!     include 'RESOLUTION.h'
+!     include 'PARAMETERS.h'
+!     include 'STDUNITS.h'     stdout
+
+!     include 'FLAGS.h'
+!     include 'BKINFO.h'        nstep
+!     include 'CONSLEV.h'
+!     include 'CONMLEV.h'
+!     include 'ESTAB.h'
+!     include 'FILEC.h'
+!     include 'FILEPC.h'
+!     include 'GDINFO.h'        ngd
+!     include 'LIMIT.h'
+!     include 'QLOGS.h'
+!     include 'TIME.h'          dt(nnst)
+!     include 'WINDD.h'
+!     include 'ZLDATA.h'        old MOBFLX?
+
+!-----------------------------------------------------------------------
+!     user interface variables
+!-----------------------------------------------------------------------
+      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)  :: jfix,ntsflg
+
+      real, intent (out), dimension (ims :ime ) :: fxh
+      real, intent (out), dimension (ims :ime ) :: fxe
+      real, intent (out), dimension (ims :ime ) :: fxmx
+      real, intent (out), dimension (ims :ime ) :: fxmy
+      real, intent (out), dimension (ims :ime ) :: cdm
+!      real, intent (out), dimension (ims :ime ) :: cdm2
+      real, intent (out), dimension (ims :ime ) :: rib
+      real, intent (out), dimension (ims :ime ) :: xxfh
+      real, intent (out), dimension (ims :ime ) :: xxfh2
+      real, intent (out), dimension (ims :ime ) :: wind10
+
+      real, intent ( inout), dimension (ims :ime ) :: zoc
+      real, intent ( inout), dimension (ims :ime ) :: tstrc
+
+      real, intent ( in)                        :: dt
+      real, intent ( in)                        :: sfenth
+      real, intent ( in), dimension (ims :ime ) :: pspc
+      real, intent ( in), dimension (ims :ime ) :: pkmax
+      real, intent ( in), dimension (ims :ime ) :: wetc
+      real, intent ( in), dimension (ims :ime ) :: slwdc
+      real, intent ( in), dimension (ims :ime ) :: tjloc
+
+      real, intent ( in), dimension (kms:kme, ims :ime ) :: upc
+      real, intent ( in), dimension (kms:kme, ims :ime ) :: vpc
+      real, intent ( in), dimension (kms:kme, ims :ime ) :: tpc
+      real, intent ( in), dimension (kms:kme, ims :ime ) :: rpc
+
+!-----------------------------------------------------------------------
+!     internal variables
+!-----------------------------------------------------------------------
+
+      integer, parameter :: icntx = 30
+
+      integer, dimension(1   :ime) :: ifz
+      integer, dimension(1   :ime) :: indx
+      integer, dimension(1   :ime) :: istb
+      integer, dimension(1   :ime) :: it
+      integer, dimension(1   :ime) :: iutb
+
+      real, dimension(1   :ime) :: aap
+      real, dimension(1   :ime) :: bq1
+      real, dimension(1   :ime) :: bq1p
+      real, dimension(1   :ime) :: delsrad
+      real, dimension(1   :ime) :: ecof
+      real, dimension(1   :ime) :: ecofp
+      real, dimension(1   :ime) :: estso
+      real, dimension(1   :ime) :: estsop
+      real, dimension(1   :ime) :: fmz1
+      real, dimension(1   :ime) :: fmz10
+      real, dimension(1   :ime) :: fmz2 
+      real, dimension(1   :ime) :: fmzo1
+      real, dimension(1   :ime) :: foft
+      real, dimension(1   :ime) :: foftm
+      real, dimension(1   :ime) :: frac
+      real, dimension(1   :ime) :: land
+      real, dimension(1   :ime) :: pssp
+      real, dimension(1   :ime) :: qf
+      real, dimension(1   :ime) :: rdiff
+      real, dimension(1   :ime) :: rho
+      real, dimension(1   :ime) :: rkmaxp
+      real, dimension(1   :ime) :: rstso
+      real, dimension(1   :ime) :: rstsop
+      real, dimension(1   :ime) :: sf10
+      real, dimension(1   :ime) :: sf2 
+      real, dimension(1   :ime) :: sfm
+      real, dimension(1   :ime) :: sfzo
+      real, dimension(1   :ime) :: sgzm
+      real, dimension(1   :ime) :: slwa
+      real, dimension(1   :ime) :: szeta
+      real, dimension(1   :ime) :: szetam
+      real, dimension(1   :ime) :: t1
+      real, dimension(1   :ime) :: t2
+      real, dimension(1   :ime) :: tab1
+      real, dimension(1   :ime) :: tab2
+      real, dimension(1   :ime) :: tempa1
+      real, dimension(1   :ime) :: tempa2
+      real, dimension(1   :ime) :: theta
+      real, dimension(1   :ime) :: thetap
+      real, dimension(1   :ime) :: tsg
+      real, dimension(1   :ime) :: tsm
+      real, dimension(1   :ime) :: tsp
+      real, dimension(1   :ime) :: tss
+      real, dimension(1   :ime) :: ucom
+      real, dimension(1   :ime) :: uf10
+      real, dimension(1   :ime) :: uf2 
+      real, dimension(1   :ime) :: ufh
+      real, dimension(1   :ime) :: ufm
+      real, dimension(1   :ime) :: ufzo
+      real, dimension(1   :ime) :: ugzm
+      real, dimension(1   :ime) :: uzeta
+      real, dimension(1   :ime) :: uzetam
+      real, dimension(1   :ime) :: vcom
+      real, dimension(1   :ime) :: vrtkx
+      real, dimension(1   :ime) :: vrts
+      real, dimension(1   :ime) :: wind
+      real, dimension(1   :ime) :: windp
+!     real, dimension(1   :ime) :: xxfh
+      real, dimension(1   :ime) :: xxfm
+      real, dimension(1   :ime) :: xxsh
+      real, dimension(1   :ime) :: z10
+      real, dimension(1   :ime) :: z2 
+      real, dimension(1   :ime) :: zeta
+      real, dimension(1   :ime) :: zkmax
+
+      real, dimension(1   :ime) :: pss
+      real, dimension(1   :ime) :: tstar
+      real, dimension(1   :ime) :: ukmax
+      real, dimension(1   :ime) :: vkmax
+      real, dimension(1   :ime) :: tkmax
+      real, dimension(1   :ime) :: rkmax
+      real, dimension(1   :ime) :: zot
+      real, dimension(1   :ime) :: fhzo1
+      real, dimension(1   :ime) :: sfh
+
+      real :: ux13, yo, y,xo,x,ux21,ugzzo,ux11,ux12,uzetao,xnum,alll
+      real :: ux1,ugz,x10,uzo,uq,ux2,ux3,xtan,xden,y10,uzet1o,ugz10
+      real :: szet2, zal2,ugz2 
+      real :: rovcp,boycon,cmo2,psps1,zog,enrca,rca,cmo1,amask,en,ca,a,c
+      real :: sgz,zal10,szet10,fmz,szo,sq,fmzo,rzeta1,zal1g,szetao,rzeta2,zal2g
+      real :: hcap,xks,pith,teps,diffot,delten,alevp,psps2,alfus,nstep
+      real :: shfx,sigt4,reflect
+      real :: cor1,cor2,szetho,zal2gh,cons_p000001,cons_7,vis,ustar,restar,rat
+      real :: wndm,ckg
+      real :: yz,y1,y2,y3,y4,windmks,znott,znotm
+      integer:: i,j,ii,iq,nnest,icnt,ngd,ip
+      data amask/ -98.0/
+
+!-----------------------------------------------------------------------
+!     internal variables
+!-----------------------------------------------------------------------
+ 
+      real, dimension (223) :: tab 
+      real, dimension (223) :: table
+      real, dimension (101) :: tab11
+      real, dimension (41) :: table4
+      real, dimension (42) :: tab3
+      real, dimension (54) :: table2
+      real, dimension (54) :: table3
+      real, dimension (74) :: table1
+      real, dimension (80) :: tab22
+
+      equivalence (tab(1),tab11(1))
+      equivalence (tab(102),tab22(1))
+      equivalence (tab(182),tab3(1))
+      equivalence (table(1),table1(1))
+      equivalence (table(75),table2(1))
+      equivalence (table(129),table3(1))
+      equivalence (table(183),table4(1))
+
+!-----------------------------------------------------------------------
+!     tables used to obtain the vapor pressures or saturated vapor 
+!     pressure
+!-----------------------------------------------------------------------
+
+      data tab11/21*0.01403,0.01719,0.02101,0.02561,0.03117,0.03784,      &
+     &.04584,.05542,.06685,.08049,.09672,.1160,.1388,.1658,.1977,.2353,   &
+     &.2796,.3316,.3925,.4638,.5472,.6444,.7577,.8894,1.042,1.220,1.425,  &
+     &1.662,1.936,2.252,2.615,3.032,3.511,4.060,4.688,5.406,6.225,7.159,  &
+     &8.223,9.432,10.80,12.36,14.13,16.12,18.38,20.92,23.80,27.03,30.67,  &
+     &34.76,39.35,44.49,50.26,56.71,63.93,71.98,80.97,90.98,102.1,114.5,  &
+     &128.3,143.6,160.6,179.4,200.2,223.3,248.8,276.9,307.9,342.1,379.8,  &
+     &421.3,466.9,517.0,572.0,632.3,698.5,770.9,850.2,937.0,1032./
+
+      data tab22/1146.6,1272.0,1408.1,1556.7,1716.9,1890.3,2077.6,2279.6  &
+     &,2496.7,2729.8,2980.0,3247.8,3534.1,3839.8,4164.8,4510.5,4876.9,    &
+     &5265.1,5675.2,6107.8,6566.2,7054.7,7575.3,8129.4,8719.2,9346.5,     &
+     &10013.,10722.,11474.,12272.,13119.,14017.,14969.,15977.,17044.,     &
+     &18173.,19367.,20630.,21964.,23373.,24861.,26430.,28086.,29831.,     &
+     &31671.,33608.,35649.,37796.,40055.,42430.,44927.,47551.,50307.,     &
+     &53200.,56236.,59422.,62762.,66264.,69934.,73777.,77802.,82015.,     &
+     &86423.,91034.,95855.,100890.,106160.,111660.,117400.,123400.,       &
+     &129650.,136170.,142980.,150070.,157460.,165160.,173180.,181530.,    &
+     &190220.,199260./
+
+      data tab3/208670.,218450.,228610.,239180.,250160.,261560.,273400.,  &
+     &285700.,298450.,311690.,325420.,339650.,354410.,369710.,385560.,    &
+     &401980.,418980.,436590.,454810.,473670.,493170.,513350.,534220.,    &
+     &555800.,578090.,601130.,624940.,649530.,674920.,701130.,728190.,    &
+     &756110.,784920.,814630.,845280.,876880.,909450.,943020.,977610.,    &
+     &1013250.,1049940.,1087740./
+
+      data table1/20*0.0,.3160e-02,.3820e-02,.4600e-02,.5560e-02,.6670e-02, &
+     & .8000e-02,.9580e-02,.1143e-01,.1364e-01,.1623e-01,.1928e-01,       &
+     &.2280e-01,.2700e-01,.3190e-01,.3760e-01,.4430e-01,.5200e-01,          &
+     &.6090e-01,.7130e-01,.8340e-01,.9720e-01,.1133e+00,.1317e-00,          &
+     &.1526e-00,.1780e-00,.2050e-00,.2370e-00,.2740e-00,.3160e-00,          &
+     &.3630e-00,.4170e-00,.4790e-00,.5490e-00,.6280e-00,.7180e-00,          &
+     &.8190e-00,.9340e-00,.1064e+01,.1209e+01,.1368e+01,.1560e+01,          &
+     &.1770e+01,.1990e+01,.2260e+01,.2540e+01,.2880e+01,.3230e+01,          &
+     &.3640e+01,.4090e+01,.4590e+01,.5140e+01,.5770e+01,.6450e+01,          &
+     &.7220e+01/
+
+      data table2/.8050e+01,.8990e+01,.1001e+02,.1112e+02,.1240e+02,      &
+     &.1380e+02,.1530e+02,.1700e+02,.1880e+02,.2080e+02,.2310e+02,        &
+     &.2550e+02,.2810e+02,.3100e+02,.3420e+02,.3770e+02,.4150e+02,        &
+     &.4560e+02,.5010e+02,.5500e+02,.6030e+02,.6620e+02,.7240e+02,        &
+     &.7930e+02,.8680e+02,.9500e+02,.1146e+03,.1254e+03,.1361e+03,        &
+     &.1486e+03,.1602e+03,.1734e+03,.1873e+03,.2020e+03,.2171e+03,        &
+     &.2331e+03,.2502e+03,.2678e+03,.2863e+03,.3057e+03,.3250e+03,        &
+     &.3457e+03,.3664e+03,.3882e+03,.4101e+03,.4326e+03,.4584e+03,        &
+     &.4885e+03,.5206e+03,.5541e+03,.5898e+03,.6273e+03,.6665e+03,        &
+     &.7090e+03/
+
+      data table3/.7520e+03,.7980e+03,.8470e+03,.8980e+03,.9520e+03,      &
+     &.1008e+04,.1067e+04,.1129e+04,.1194e+04,.1263e+04,.1334e+04,        &
+     &.1409e+04,.1488e+04,.1569e+04,.1656e+04,.1745e+04,.1840e+04,        &
+     &.1937e+04,.2041e+04,.2147e+04,.2259e+04,.2375e+04,.2497e+04,        & 
+     &.2624e+04,.2756e+04,.2893e+04,.3036e+04,.3186e+04,.3340e+04,        &
+     &.3502e+04,.3670e+04,.3843e+04,.4025e+04,.4213e+04,.4408e+04,        &
+     &.4611e+04,.4821e+04,.5035e+04,.5270e+04,.5500e+04,.5740e+04,        &
+     &.6000e+04,.6250e+04,.6520e+04,.6810e+04,.7090e+04,.7390e+04,        &
+     &.7700e+04,.8020e+04,.8350e+04,.8690e+04,.9040e+04,.9410e+04,        &
+     &.9780e+04/
+
+      data table4/.1016e+05,.1057e+05,.1098e+05,.1140e+05,.1184e+05,      &
+     &.1230e+05,.1275e+05,.1324e+05,.1373e+05,.1423e+05,.1476e+05,        &
+     &.1530e+05,.1585e+05,.1642e+05,.1700e+05,.1761e+05,.1822e+05,        &
+     &.1886e+05,.1950e+05,.2018e+05,.2087e+05,.2158e+05,.2229e+05,        &
+     &.2304e+05,.2381e+05,.2459e+05,.2539e+05,.2621e+05,.2706e+05,        &
+     &.2792e+05,.2881e+05,.2971e+05,.3065e+05,.3160e+05,.3257e+05,        &
+     &.3357e+05,.3459e+05,.3564e+05,.3669e+05,.3780e+05,.0000e+00/
+!
+! spcify constants needed by MFLUX2
+!
+      real,parameter :: cp    = 1.00464e7
+      real,parameter :: g     = 980.6
+      real,parameter :: rgas  = 2.87e6
+      real,parameter :: og    = 1./g
+
+!
+!     character*10 routine
+!     routine = 'mflux2'
+!
+!------------------------------------------------------------------------
+!     set water availability constant "ecof" and land mask "land".  
+!     limit minimum wind speed to 100 cm/s
+!------------------------------------------------------------------------
+      j = IFIX(tjloc(its))
+!  constants for 10 m winds  (correction for knots
+!
+       cor1 = .120
+       cor2 = 720.
+       yz=           -0.0001344
+       y1=            3.015e-05 
+       y2=            1.517e-06 
+       y3=           -3.567e-08
+       y4=            2.046e-10
+
+      do i = its,ite
+        z10(i) = 1000.
+        z2 (i) =  200.
+        pss(i) = pspc(i)
+        tstar(i) = tstrc(i)
+        ukmax(i) = upc(1,i)
+        vkmax(i) = vpc(1,i)
+        tkmax(i) = tpc(1,i)
+        rkmax(i) = rpc(1,i)
+      enddo
+
+!      write(0,*)'z10,pss,tstar,u...rkmax(ite)',          &
+!          z10(ite), pss(ite),tstar(ite),ukmax(ite),        &
+!          vkmax(ite),tkmax(ite),rkmax(ite)
+
+      do i = its,ite
+        windp(i) = SQRT(ukmax(i)*ukmax(i) + vkmax(i)*vkmax(i))
+        wind (i) = amax1(windp(i),100.)
+        if (zoc(i) .LT. amask) zoc(i) = -0.0185*0.001*wind(i)*wind(i)*og
+        if (zoc(i) .GT. 0.0) then
+          ecof(i) = wetc(i)
+          land(i) = 1.0
+          zot (i) = zoc(i)
+        else
+          ecof(i) = wetc(i)
+          land(i) = 0.0
+#ifdef HWRF
+          zot (i) = zoc(i)
+!  now use 2 regime fit for znot thermal
+          windmks=wind(i)*.01
+          znott=0.2375*exp(-0.5250*windmks) + 0.0025*exp(-0.0211*windmks)
+          znott=0.01*znott
+!  go back to moon et al for below 7m/s
+          if(windmks.le. 7.)                         &
+          znott = (0.0185/9.8*(7.59e-8*wind(i)**2+   &
+                                  2.46e-4*wind(i))**2)
+! back to cgs
+          zot (i) = 100.*znott
+#else
+!         zot (i) = zoc(i)
+!  now use 2 regime fit for znot thermal
+    windmks=wind(i)*.01
+    znott=1.9551e-5  - 2.6338e-7 * windmks
+    if(windmks.le.10.) znott=0.0025542 * windmks **(-1.8023)
+    znott=amax1(1.e-6,znott)
+!  go back to moon et al for below 7m/s
+   if(windmks.le. 7.)                         &
+   znott = (0.0185/9.8*(7.59e-8*wind(i)**2+   &
+                                  2.46e-4*wind(i))**2)
+! back to cgs
+   zot (i) = 100.*znott
+#endif
+!   end of kwon correction....
+!     in hwrf, thermal znot(zot) is passed as argument zoc
+!     in hwrf, momentum znot is recalculated internally
+              zoc(i)=-(0.0185/9.8*(7.59e-8*wind(i)**2+   &
+                                  2.46e-4*wind(i))**2)*100.
+            if(wind(i).ge.1250.0)   &
+             zoc(i)=-(.000739793 * wind(i) -0.58)/10
+        if(wind(i).ge.3000.)   then
+        windmks=wind(i)*.01
+!       kwon znotm
+        znotm   = yz   +windmks*y1   +windmks**2*y2   +windmks**3*y3   +windmks**4*y4 !powell 2003
+!       back to cgs
+        zoc(i)  = 100.*znotm
+        endif
+        endif
+
+!------------------------------------------------------------------------
+!     where necessary modify zo values over ocean.
+!------------------------------------------------------------------------
+
+      enddo
+
+!------------------------------------------------------------------------
+!     define constants: 
+!     a and c = constants used in evaluating universal function for 
+!               stable case 
+!     ca      = karmen constant 
+!     cm01    = constant part of vertical integral of universal 
+!               function; stable case ( 0.5 < zeta < or = 10.0) 
+!     cm02    = constant part of vertical integral of universal 
+!               function; stable case ( zeta > 10.0)
+!------------------------------------------------------------------------
+
+      en     = 2.
+      c      = .76
+      a      = 5.
+      ca     = .4
+      cmo1   = .5*a - 1.648
+      cmo2   = 17.193 + .5*a - 10.*c
+      boycon = .61
+        rovcp=rgas/cp
+!       write(0,*)'rgas,cp,rovcp ', rgas,cp,rovcp
+
+!     write(0,*)'--------------------------------------------------'
+!     write(0,*)'pkmax,    pspc,    theta,    zkmax,        zoc'
+!     write(0,*)'--------------------------------------------------'
+
+      do i = its,ite
+!       theta(i) = tkmax(i)*rqc9
+        theta(i) = tkmax(i)/((pkmax(i)/pspc(i))**rovcp)
+        vrtkx(i) = 1.0 + boycon*rkmax(i)
+!       zkmax(i) = rgas*tkmax(i)*qqlog(kmax)*og
+        zkmax(i) = -rgas*tkmax(i)*alog(pkmax(i)/pspc(i))*og
+!       IF(I==78)write(0,*)I,JFIX,pkmax(i),pspc(i),theta(i),zkmax(i),zoc(i)
+      enddo
+
+!        write(0,*)'pkmax,pspc ',   pkmax,pspc
+!        write(0,*)'theta, zkmax, zoc ', theta, zkmax, zoc
+
+!------------------------------------------------------------------------
+!     get saturation mixing ratios at surface
+!------------------------------------------------------------------------
+
+      do i = its,ite
+        tsg  (i) = tstar(i)
+        tab1 (i) = tstar(i) - 153.16
+        it   (i) = IFIX(tab1(i))
+        tab2 (i) = tab1(i) - FLOAT(it(i))
+        t1   (i) = tab(it(i) + 1)
+        t2   (i) = table(it(i) + 1)
+        estso(i) = t1(i) + tab2(i)*t2(i)
+         psps1 = (pss(i) - estso(i))
+          if(psps1 .EQ. 0.0)then
+           psps1 = .1
+          endif
+        rstso(i) = 0.622*estso(i)/psps1                       
+        vrts (i) = 1. + boycon*ecof(i)*rstso(i)
+      enddo
+
+!------------------------------------------------------------------------
+!     check if consideration of virtual temperature changes stability.
+!     if so, set "dthetav" to near neutral value (1.0e-4). also check 
+!     for very small lapse rates; if ABS(tempa1) <1.0e-4 then 
+!     tempa1=1.0e-4
+!------------------------------------------------------------------------
+
+      do i = its,ite
+        tempa1(i) = theta(i)*vrtkx(i) - tstar(i)*vrts(i)
+        tempa2(i) = tempa1(i)*(theta(i) - tstar(i))
+        if (tempa2(i) .LT. 0.) tempa1(i) = 1.0e-4
+        tab1(i) = ABS(tempa1(i))
+        if (tab1(i) .LT. 1.0e-4) tempa1(i) = 1.0e-4
+!------------------------------------------------------------------------
+!     compute bulk richardson number "rib" at each point. if "rib"
+!     exceeds 95% of critical richardson number "tab1" then "rib = tab1"
+!------------------------------------------------------------------------
+
+        rib (i) = g*zkmax(i)*tempa1(i)/                             &
+                                    (tkmax(i)*vrtkx(i)*wind(i)*wind(i))
+        tab2(i) = ABS(zoc(i))
+        tab1(i) = 0.95/(c*(1. - tab2(i)/zkmax(i)))
+        if (rib(i) .GT. tab1(i)) rib(i) = tab1(i)
+      enddo
+
+      do i = its,ite
+        zeta(i) = ca*rib(i)/0.03
+      enddo
+
+!       write(0,*)'rib,zeta,vrtkx,vrts(ite) ',  rib(ite),zeta(ite),  &
+!                     vrtkx(ite),vrts(ite)
+!------------------------------------------------------------------------
+!     begin looping through points on line, solving wegsteins iteration 
+!     for zeta at each point, and using hicks functions
+!------------------------------------------------------------------------
+
+!------------------------------------------------------------------------
+!     set initial guess of zeta=non - dimensional height "szeta" for 
+!     stable points 
+!------------------------------------------------------------------------
+
+      rca   = 1./ca
+      enrca = en*rca
+!     turn off interfacial layer by zeroing out enrca
+      enrca = 0.0
+      zog   = .0185*og
+
+!------------------------------------------------------------------------
+!     stable points
+!------------------------------------------------------------------------
+
+      ip    = 0
+      do i = its,ite
+        if (zeta(i) .GE. 0.0) then
+          ip = ip + 1
+          istb(ip) = i
+        endif
+      enddo
+
+      if (ip .EQ. 0) go to 170
+      do i = 1,ip
+        szetam(i) = 1.0e+30
+        sgzm(i)   = 0.0e+00
+        szeta(i)  = zeta(istb(i))
+        ifz(i)    = 1
+      enddo
+
+!------------------------------------------------------------------------
+!     begin wegstein iteration for "zeta" at stable points using
+!     hicks(1976)
+!------------------------------------------------------------------------
+
+      do icnt = 1,icntx
+        do i = 1,ip
+          if (ifz(i) .EQ. 0) go to 80
+          zal1g = ALOG(szeta(i))
+          if (szeta(i) .LE. 0.5) then
+            fmz1(i) = (zal1g + a*szeta(i))*rca
+          else if (szeta(i) .GT. 0.5 .AND. szeta(i) .LE. 10.) then
+            rzeta1  = 1./szeta(i)
+            fmz1(i) = (8.*zal1g + 4.25*rzeta1 - &
+                                          0.5*rzeta1*rzeta1 + cmo1)*rca
+          else if (szeta(i) .GT. 10.) then
+            fmz1(i) = (c*szeta(i) + cmo2)*rca
+          endif
+          szetao = ABS(zoc(istb(i)))/zkmax(istb(i))*szeta(i)
+          zal2g  = ALOG(szetao)
+          if (szetao .LE. 0.5) then
+            fmzo1(i) = (zal2g + a*szetao)*rca
+            sfzo (i) = 1. + a*szetao
+          else if (szetao .GT. 0.5 .AND. szetao .LE. 10.) then
+            rzeta2   = 1./szetao
+            fmzo1(i) = (8.*zal2g + 4.25*rzeta2 - &
+                                          0.5*rzeta2*rzeta2 + cmo1)*rca
+            sfzo (i) = 8.0 - 4.25*rzeta2 + rzeta2*rzeta2
+          else if (szetao .GT. 10.) then
+            fmzo1(i) = (c*szetao + cmo2)*rca
+            sfzo (i) = c*szetao
+          endif
+
+
+!        compute heat & moisture parts of zot.. for calculation of sfh
+
+          szetho = ABS(zot(istb(i)))/zkmax(istb(i))*szeta(i)
+          zal2gh = ALOG(szetho)
+          if (szetho .LE. 0.5) then
+            fhzo1(i) = (zal2gh + a*szetho)*rca
+            sfzo (i) = 1. + a*szetho
+          else if (szetho .GT. 0.5 .AND. szetho .LE. 10.) then
+            rzeta2   = 1./szetho
+            fhzo1(i) = (8.*zal2gh + 4.25*rzeta2 -   &
+                                          0.5*rzeta2*rzeta2 + cmo1)*rca
+            sfzo (i) = 8.0 - 4.25*rzeta2 + rzeta2*rzeta2
+          else if (szetho .GT. 10.) then
+            fhzo1(i) = (c*szetho + cmo2)*rca
+            sfzo (i) = c*szetho
+          endif
+ 
+!------------------------------------------------------------------------
+!      compute universal function at 10 meters for diagnostic purposes
+!------------------------------------------------------------------------
+
+!!!!      if (ngd .EQ. nNEST) then
+            szet10 = ABS(z10(istb(i)))/zkmax(istb(i))*szeta(i)
+            zal10  = ALOG(szet10)
+            if (szet10 .LE. 0.5) then
+              fmz10(i) = (zal10 + a*szet10)*rca
+            else if (szet10 .GT. 0.5 .AND. szet10 .LE. 10.) then
+              rzeta2   = 1./szet10
+              fmz10(i) = (8.*zal10 + 4.25*rzeta2 - &
+                                          0.5*rzeta2*rzeta2 + cmo1)*rca
+            else if (szet10 .GT. 10.) then
+              fmz10(i) = (c*szet10 + cmo2)*rca
+            endif
+            sf10(i) = fmz10(i) - fmzo1(i)
+!          compute 2m values for diagnostics in HWRF
+            szet2  = ABS(z2 (istb(i)))/zkmax(istb(i))*szeta(i)
+            zal2   = ALOG(szet2 )
+            if (szet2  .LE. 0.5) then
+              fmz2 (i) = (zal2  + a*szet2 )*rca
+            else if (szet2  .GT. 0.5 .AND. szet2  .LE. 2.) then
+              rzeta2   = 1./szet2 
+              fmz2 (i) = (8.*zal2  + 4.25*rzeta2 - &
+                                          0.5*rzeta2*rzeta2 + cmo1)*rca
+            else if (szet2  .GT. 2.) then
+              fmz2 (i) = (c*szet2  + cmo2)*rca
+            endif
+            sf2 (i) = fmz2 (i) - fmzo1(i)
+  
+!!!!      endif
+          sfm(i) = fmz1(i) - fmzo1(i)
+          sfh(i) = fmz1(i) - fhzo1(i)
+          sgz    = ca*rib(istb(i))*sfm(i)*sfm(i)/ &
+                                               (sfh(i) + enrca*sfzo(i))
+          fmz    = (sgz - szeta(i))/szeta(i)
+          fmzo   = ABS(fmz)
+          if (fmzo .GE. 5.0e-5) then
+            sq        = (sgz - sgzm(i))/(szeta(i) - szetam(i))
+            if(sq .EQ. 1) then
+             write(0,*)'NCO ERROR DIVIDE BY ZERO IN MFLUX2 (STABLE CASE)'
+             write(0,*)'sq is 1 ',fmzo,sgz,sgzm(i),szeta(i),szetam(i)
+            endif
+            szetam(i) = szeta(i)
+            szeta (i) = (sgz - szeta(i)*sq)/(1.0 - sq)
+            sgzm  (i) = sgz
+          else
+            ifz(i) = 0
+          endif
+80        continue
+        enddo
+      enddo
+
+      do i = 1,ip
+        if (ifz(i) .GE. 1) go to 110
+      enddo
+
+      go to 130
+
+110   continue
+      write(6,120)
+120   format(2X, ' NON-CONVERGENCE FOR STABLE ZETA IN ROW ')
+!     call MPI_CLOSE(1,routine)
+
+!------------------------------------------------------------------------
+!     update "zo" for ocean points.  "zo"cannot be updated within the
+!     wegsteins iteration as the scheme (for the near neutral case)
+!     can become unstable 
+!------------------------------------------------------------------------
+
+130   continue
+      do i = 1,ip
+        szo = zoc(istb(i))
+        if (szo .LT. 0.0)  then
+        wndm=wind(istb(i))*0.01
+          if(wndm.lt.15.0) then
+          ckg=0.0185*og
+          else
+!!         ckg=(0.000308*wndm+0.00925)*og
+!!         ckg=(0.000616*wndm)*og
+           ckg=(sfenth*(4*0.000308*wndm) + (1.-sfenth)*0.0185 )*og
+          endif
+
+       szo =  - ckg*wind(istb(i))*wind(istb(i))/  &
+                             (sfm(i)*sfm(i))
+        cons_p000001    =    .000001
+        cons_7          =         7.
+        vis             =     1.4E-1
+ 
+        ustar    = sqrt( -szo / zog)
+        restar = -ustar * szo    / vis
+        restar = max(restar,cons_p000001) 
+!  Rat taken from Zeng,  Zhao and Dickinson 1997
+        rat    = 2.67 * restar ** .25 - 2.57
+        rat    = min(rat   ,cons_7)                      !constant
+	rat=0.
+        zot(istb(i)) = szo   * exp(-rat)
+         else
+         zot(istb(i)) = zoc(istb(i))
+        endif
+        
+!      in hwrf thermal znot is loaded back into the zoc array for next step
+             zoc(istb(i)) = szo
+      enddo
+
+      do i = 1,ip
+        xxfm(istb(i)) = sfm(i)
+        xxfh(istb(i)) = sfh(i)
+        xxfh2(istb(i)) = sf2 (i)
+        xxsh(istb(i)) = sfzo(i)
+      enddo
+
+!------------------------------------------------------------------------
+!     obtain wind at 10 meters for diagnostic purposes
+!------------------------------------------------------------------------
+
+!!!   if (ngd .EQ. nNEST) then
+        do i = 1,ip
+         wind10(istb(i)) = sf10(i)*wind(istb(i))/sfm(i)
+         wind10(istb(i)) = wind10(istb(i)) * 1.944
+           if(wind10(istb(i)) .GT. 6000.0) then
+       wind10(istb(i))=wind10(istb(i))+wind10(istb(i))*cor1 &
+                        - cor2
+           endif
+!     the above correction done by GFDL in centi-kts!!!-change back
+         wind10(istb(i)) = wind10(istb(i)) / 1.944
+        enddo   
+!!!   endif
+!!!   if (ngd .EQ. nNEST-1 .AND. llwe .EQ. 1 ) then
+!!!     do i = 1,ip
+!!!       wind10c(istb(i),j) = sf10(i)*wind(istb(i))/sfm(i)
+!!!       wind10c(istb(i),j) = wind10c(istb(i),j) * 1.944
+!!!        if(wind10c(istb(i),j) .GT. 6000.0) then
+!!!    wind10c(istb(i),j)=wind10c(istb(i),j)+wind10c(istb(i),j)*cor1
+!!!  *                   - cor2
+!!!        endif
+!!!     enddo   
+!!!   endif
+
+!------------------------------------------------------------------------
+!     unstable points
+!------------------------------------------------------------------------
+
+170   continue
+
+      iq = 0
+      do i = its,ite
+        if (zeta(i) .LT. 0.0) then
+          iq       = iq + 1
+          iutb(iq) = i
+        endif
+      enddo
+
+      if (iq .EQ. 0) go to 290
+      do i = 1,iq
+        uzeta (i) = zeta(iutb(i))
+        ifz   (i) = 1
+        uzetam(i) = 1.0e+30
+        ugzm  (i) = 0.0e+00
+      enddo
+
+!------------------------------------------------------------------------
+!     begin wegstein iteration for "zeta" at unstable points using
+!     hicks functions
+!------------------------------------------------------------------------
+
+      do icnt = 1,icntx
+        do i = 1,iq
+          if (ifz(i) .EQ. 0) go to 200
+          ugzzo   = ALOG(zkmax(iutb(i))/ABS(zot(iutb(i))))
+          uzetao  = ABS(zot(iutb(i)))/zkmax(iutb(i))*uzeta(i)
+          ux11    = 1. - 16.*uzeta(i)
+          ux12    = 1. - 16.*uzetao
+          y       = SQRT(ux11)
+          yo      = SQRT(ux12)
+          ufzo(i) = 1./yo
+          ux13    = (1. + y)/(1. + yo)
+          ux21    = ALOG(ux13)
+          ufh(i)  = (ugzzo - 2.*ux21)*rca
+!         recompute scalers for ufm in terms of mom znot... zoc
+          ugzzo   = ALOG(zkmax(iutb(i))/ABS(zoc(iutb(i))))
+          uzetao  = ABS(zoc(iutb(i)))/zkmax(iutb(i))*uzeta(i)
+          ux11    = 1. - 16.*uzeta(i)
+          ux12    = 1. - 16.*uzetao
+          y       = SQRT(ux11)
+          yo      = SQRT(ux12)
+          ux13    = (1. + y)/(1. + yo)
+          ux21    = ALOG(ux13)
+!          ufzo(i) = 1./yo
+          x       = SQRT(y)
+          xo      = SQRT(yo)
+          xnum    = (x**2 + 1.)*((x + 1.)**2)
+          xden    = (xo**2 + 1.)*((xo + 1.)**2)
+          xtan    = ATAN(x) - ATAN(xo)
+          ux3     = ALOG(xnum/xden)
+          ufm(i)  = (ugzzo - ux3 + 2.*xtan)*rca
+!!!!      if (ngd .EQ. nNEST) then
+
+!------------------------------------------------------------------------
+!     obtain ten meter winds for diagnostic purposes
+!------------------------------------------------------------------------
+
+            ugz10   = ALOG(z10(iutb(i))/ABS(zoc(iutb(i))))
+            uzet1o  = ABS(z10(iutb(i)))/zkmax(iutb(i))*uzeta(i)
+            uzetao  = ABS(zoc(iutb(i)))/zkmax(iutb(i))*uzeta(i)
+            ux11    = 1. - 16.*uzet1o
+            ux12    = 1. - 16.*uzetao
+            y       = SQRT(ux11)
+            y10     = SQRT(ux12)
+            ux13    = (1. + y)/(1. + y10)
+            ux21    = ALOG(ux13)
+            x       = SQRT(y)
+            x10     = SQRT(y10)
+            xnum    = (x**2 + 1.)*((x + 1.)**2)
+            xden    = (x10**2 + 1.)*((x10 + 1.)**2)
+            xtan    = ATAN(x) - ATAN(x10)
+            ux3     = ALOG(xnum/xden)
+            uf10(i) = (ugz10 - ux3 + 2.*xtan)*rca
+
+!   obtain 2m values for diagnostics...
+
+
+          ugz2    = ALOG(z2   (iutb(i))/ABS(zoc(iutb(i))))
+          uzet1o  = ABS(z2 (iutb(i)))/zkmax(iutb(i))*uzeta(i)
+          uzetao  = ABS(zoc(iutb(i)))/zkmax(iutb(i))*uzeta(i)
+          ux11    = 1. - 16.*uzet1o   
+          ux12    = 1. - 16.*uzetao
+          y       = SQRT(ux11)
+          yo      = SQRT(ux12)
+          ux13    = (1. + y)/(1. + yo)
+          ux21    = ALOG(ux13)
+          uf2 (i)  = (ugzzo - 2.*ux21)*rca
+
+
+!!!       endif
+          ugz = ca*rib(iutb(i))*ufm(i)*ufm(i)/(ufh(i) + enrca*ufzo(i))
+          ux1 = (ugz - uzeta(i))/uzeta(i)
+          ux2 = ABS(ux1)
+          if (ux2 .GE. 5.0e-5) then
+            uq        = (ugz - ugzm(i))/(uzeta(i) - uzetam(i))
+            uzetam(i) = uzeta(i)
+            if(uq .EQ. 1) then
+             write(0,*)'NCO ERROR DIVIDE BY ZERO IN MFLUX2 (UNSTABLE CASE)' 
+             write(0,*)'uq is 1 ',ux2,ugz,ugzm(i),uzeta(i),uzetam(i) 
+            endif
+            uzeta (i) = (ugz - uzeta(i)*uq)/(1.0 - uq)
+            ugzm  (i) = ugz
+          else
+            ifz(i) = 0
+          endif
+200       continue
+        enddo
+      enddo
+
+
+      do i = 1,iq
+        if (ifz(i) .GE. 1) go to 230
+      enddo
+
+      go to 250
+
+230   continue
+      write(6,240)
+240   format(2X, ' NON-CONVERGENCE FOR UNSTABLE ZETA IN ROW ')
+!     call MPI_CLOSE(1,routine)
+
+!------------------------------------------------------------------------
+!     gather unstable values
+!------------------------------------------------------------------------
+
+250   continue
+
+!------------------------------------------------------------------------
+!     update "zo" for ocean points.  zo cannot be updated within the
+!     wegsteins iteration as the scheme (for the near neutral case)
+!     can become unstable. 
+!------------------------------------------------------------------------
+
+      do i = 1,iq
+        uzo = zoc(iutb(i))
+        if (zoc(iutb(i)) .LT. 0.0)   then
+        wndm=wind(iutb(i))*0.01
+         if(wndm.lt.15.0) then
+         ckg=0.0185*og
+         else
+!!          ckg=(0.000308*wndm+0.00925)*og                      <  
+!!          ckg=(0.000616*wndm)*og                              <  
+            ckg=(4*0.000308*wndm)*og
+            ckg=(sfenth*(4*0.000308*wndm) + (1.-sfenth)*0.0185 )*og
+         endif
+        uzo         =-ckg*wind(iutb(i))*wind(iutb(i))/(ufm(i)*ufm(i))
+        cons_p000001    =    .000001
+        cons_7          =         7.
+        vis             =     1.4E-1
+
+        ustar    = sqrt( -uzo / zog)
+        restar = -ustar * uzo    / vis
+        restar = max(restar,cons_p000001)
+!  Rat taken from Zeng,  Zhao and Dickinson 1997
+        rat    = 2.67 * restar ** .25 - 2.57
+        rat    = min(rat   ,cons_7)                      !constant
+	rat=0.0
+        zot(iutb(i)) =  uzo   * exp(-rat)
+         else
+         zot(iutb(i)) = zoc(iutb(i))
+        endif
+!      in hwrf thermal znot is loaded back into the zoc array for next step
+            zoc(iutb(i)) = uzo
+      enddo
+
+!------------------------------------------------------------------------
+!     obtain wind at ten meters for diagnostic purposes
+!------------------------------------------------------------------------
+
+!!!   if (ngd .EQ. nNEST) then
+        do i = 1,iq
+          wind10(iutb(i)) = uf10(i)*wind(iutb(i))/ufm(i)
+          wind10(iutb(i)) = wind10(iutb(i)) * 1.944
+           if(wind10(iutb(i)) .GT. 6000.0) then
+         wind10(iutb(i))=wind10(iutb(i))+wind10(iutb(i))*cor1 &
+                         - cor2
+           endif
+ !     the above correction done by GFDL in centi-kts!!!-change back
+          wind10(iutb(i)) = wind10(iutb(i)) / 1.944
+        enddo   
+!!!   endif 
+!!!   if (ngd .EQ. nNEST-1) then
+!!!     do i = 1,iq            
+!!!       wind10c(iutb(i),j) = uf10(i)*wind(iutb(i))/ufm(i)
+!!!       wind10c(iutb(i),j) = wind10c(iutb(i),j) * 1.944
+!!!        if(wind10c(iutb(i),j) .GT. 6000.0) then
+!!!      wind10c(iutb(i),j)=wind10c(iutb(i),j)+wind10c(iutb(i),j)*cor1
+!!!  *                    - cor2
+!!!        endif
+!!!     enddo   
+!!!   endif 
+
+      do i = 1,iq
+        xxfm(iutb(i)) = ufm(i)
+        xxfh(iutb(i)) = ufh(i)
+        xxfh2(iutb(i)) = uf2 (i)
+        xxsh(iutb(i)) = ufzo(i)
+      enddo
+
+290   continue
+
+      do i = its,ite
+        ucom(i) = ukmax(i)
+        vcom(i) = vkmax(i)
+        if (windp(i) .EQ. 0.0) then
+          windp(i) = 100.0
+          ucom (i) = 100.0/SQRT(2.0)
+          vcom (i) = 100.0/SQRT(2.0)
+        endif
+        rho(i) = pss(i)/(rgas*(tsg(i) + enrca*(theta(i) - &
+                tsg(i))*xxsh(i)/(xxfh(i) + enrca*xxsh(i))))
+        bq1(i) = wind(i)*rho(i)/(xxfm(i)*(xxfh(i) + enrca*xxsh(i)))
+      enddo
+
+!     do land sfc temperature prediction if ntsflg=1
+!     ntsflg = 1                                    ! gopal's doing  
+
+      if (ntsflg .EQ. 0) go to 370
+      alll = 600.
+      xks   = 0.01
+      hcap  = .5/2.39e-8
+      pith  = SQRT(4.*ATAN(1.0))
+      alfus = alll/2.39e-8
+      teps  = 0.1
+!     slwdc... in units of cal/min ????
+!     slwa...  in units of ergs/sec/cm*2  
+!     1 erg=2.39e-8 cal
+!------------------------------------------------------------------------
+!     pack land and sea ice points
+!------------------------------------------------------------------------
+
+      ip    = 0
+      do i = its,ite
+        if (land(i) .EQ. 1) then
+          ip = ip + 1
+          indx   (ip) = i
+!         slwa is defined as positive down....
+          slwa   (ip) =    slwdc(i)/(2.39e-8*60.)
+          tss    (ip) = tstar(i)
+          thetap (ip) = theta(i)
+          rkmaxp (ip) = rkmax(i)
+          aap    (ip) = 5.673e-5
+          pssp   (ip) = pss(i)
+          ecofp  (ip) = ecof(i)
+          estsop (ip) = estso(i)
+          rstsop (ip) = rstso(i)
+          bq1p   (ip) = bq1(i)
+          bq1p   (ip) = amax1(bq1p(ip),0.1e-3)
+          delsrad(ip) = dt   *pith/(hcap*SQRT(3600.*24.*xks))
+        endif
+      enddo
+
+!------------------------------------------------------------------------
+!     initialize variables for first pass of iteration
+!------------------------------------------------------------------------
+
+      do i = 1,ip
+        ifz  (i) = 1
+        tsm  (i) = tss(i)
+        rdiff(i) = amin1(0.0,(rkmaxp(i) - rstsop(i)))
+!!!     if (nstep .EQ. -99 .AND. ngd .GT. 1 .OR. &
+!!!        nstep .EQ. -99 .AND. ngd .EQ. 1) then
+
+!!!      if (j .EQ. 1 .AND. i .EQ. 1) write(6,300)
+300   format(2X, ' SURFACE EQUILIBRIUM CALCULATION ')
+
+!!        foftm(i) = thetap(i) + 1./(cp*bq1p(i))*(slwa(i) - aap(i)* &
+!!                  tsm(i)**4 + ecofp(i)*alfus*bq1p(i)*rdiff(i))
+!!      else
+
+          foftm(i) = tss(i) + delsrad(i)*(slwa(i) - aap(i)*tsm(i)**4 - &
+           cp*bq1p(i)*(tsm(i) - thetap(i)) + ecofp(i)*alfus*bq1p(i)* &
+           rdiff(i))
+!!      endif
+        tsp(i) = foftm(i)
+      enddo
+
+!------------------------------------------------------------------------
+!     do iteration to determine "tstar" at new time level
+!------------------------------------------------------------------------
+
+      do icnt = 1,icntx
+        do i = 1,ip
+          if (ifz(i) .EQ. 0) go to 330
+          tab1  (i) = tsp(i) - 153.16
+          it    (i) = IFIX(tab1(i))
+          tab2  (i) = tab1(i) - FLOAT(it(i))
+          t1    (i) = tab(it(i) + 1)
+          t2    (i) = table(it(i) + 1)
+          estsop(i) = t1(i) + tab2(i)*t2(i)
+             psps2 = (pssp(i) - estsop(i))
+             if(psps2 .EQ. 0.0)then
+               psps2 = .1
+             endif
+          rstsop(i) = 0.622*estsop(i)/psps2                  
+          rdiff (i) = amin1(0.0,(rkmaxp(i) - rstsop(i)))
+!!!       if (nstep .EQ. -99 .AND. ngd .GT. 1 .OR. &
+!!!          nstep .EQ. -99 .AND. ngd .EQ. 1) then
+!!!         foft(i) = thetap(i) + (1./(cp*bq1p(i)))*(slwa(i) - aap(i)* &
+!!!                  tsp(i)**4 + ecofp(i)*alfus*bq1p(i)*rdiff(i))
+!!!       else
+            foft(i) = tss(i) + delsrad(i)*(slwa(i) - aap(i)*tsp(i)**4 - &
+             cp*bq1p(i)*(tsp(i) - thetap(i)) + ecofp(i)*alfus*bq1p(i)* &
+             rdiff(i))
+!!!       endif
+!!!       if (ngd .EQ. 1 .AND. j .EQ. 48 .AND. i .EQ. 19) then
+!!!         reflect = slwa(i)
+!!!         sigt4   = -aap(i)*tsp(i)**4
+!!!         shfx    = -cp*bq1p(i)*(tsp(i) - thetap(i))
+!!!         alevp   = ecofp(i)*alfus*bq1p(i)*rdiff(i)
+!!!         delten  = delsrad(i)
+!!!         diffot  = foft(i) - tss(i)
+!!!       endif
+          frac(i) = ABS((foft(i) - tsp(i))/tsp(i))
+
+!------------------------------------------------------------------------
+!      check for convergence of all points use wegstein iteration     
+!------------------------------------------------------------------------
+ 
+          if (frac(i) .GE. teps) then
+            qf   (i) = (foft(i) - foftm(i))/(tsp(i) - tsm(i))
+            tsm  (i) = tsp(i)
+            tsp  (i) = (foft(i) - tsp(i)*qf(i))/(1. - qf(i))
+            foftm(i) = foft(i)
+          else
+            ifz(i) = 0
+          endif
+330       continue
+        enddo
+      enddo
+
+!------------------------------------------------------------------------
+!     check for convergence of "t star" prediction
+!------------------------------------------------------------------------
+
+      do i = 1,ip
+        if (ifz(i) .EQ. 1) then
+        write(6, 340) tsp(i), i, j
+340   format(2X, ' NON-CONVERGENCE OF T* PREDICTED (T*,I,J) = ', E14.8, &
+            2I5)
+
+        write(6,345) indx(i), j, tstar(indx(i)), tsp(i), ip
+345   format(2X, ' I, J, OLD T*, NEW T*, NPTS ', 2I5, 2E14.8, I5)
+
+        write(6,350) reflect, sigt4, shfx, alevp, delten, diffot
+350   format(2X, ' REFLECT, SIGT4, SHFX, ALEVP, DELTEN, DIFFOT ', &
+            6E14.8)
+
+!         call MPI_CLOSE(1,routine)
+        endif
+      enddo
+
+      do i = 1,ip
+        ii        = indx(i)
+        tstrc(ii) = tsp (i)
+      enddo
+
+!------------------------------------------------------------------------
+!     compute fluxes  and momentum drag coef
+!------------------------------------------------------------------------
+
+370   continue
+      do i = its,ite
+        fxh(i) = bq1(i)*(theta(i) - tsg(i))
+        fxe(i) = ecof(i)*bq1(i)*(rkmax(i) - rstso(i))
+        if (fxe(i) .GT. 0.0) fxe(i) = 0.0
+        fxmx(i) = rho(i)/(xxfm(i)*xxfm(i))*wind(i)*wind(i)*ucom(i)/ &
+                 windp(i)
+        fxmy(i) = rho(i)/(xxfm(i)*xxfm(i))*wind(i)*wind(i)*vcom(i)/ &
+        windp(i)
+        cdm(i) = 1./(xxfm(i)*xxfm(i))
+!       print *, 'i,zot,zoc,cdm,cdm2,tsg,wind', &
+!                i, zot(i),zoc(i), cdm(i),cdm2(i), tsg(i),wind(i)
+      enddo
+
+      return
+      end subroutine MFLUX2
+
+  SUBROUTINE hwrfsfcinit(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 hwrfsfcinit
+
+END MODULE module_sf_gfdl
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_gfs.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_gfs.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_gfs.F	(revision 17)
@@ -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) ::            &
+                                        UST,                            &
+                                        ZNT
+
+      REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::                 &
+                                        BR,                             &
+                                        CHS,                            &
+                                        CHS2,                           &
+                                        CPM,                            &
+                                        CQS2,                           &
+                                        FLHC,                           &
+                                        FLQC,                           &
+                                        GZ1OZ0,                         &
+                                        HFX,                            &
+                                        LH,                             &
+                                        PSIM,                           &
+                                        PSIH,                           &
+                                        QFX,                            &
+                                        QGH,                            &
+                                        QSFC,                           &
+                                        U10,                            &
+                                        V10,                            &
+                                        WSPD
+
+
+!--------------------------- 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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_idealscmsfclay.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_idealscmsfclay.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_idealscmsfclay.F	(revision 17)
@@ -0,0 +1,272 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+MODULE module_sf_idealscmsfclay
+
+CONTAINS
+
+!-------------------------------------------------------------------
+   SUBROUTINE idealscmsfclay(u3d,v3d,th3d,qv3d,p3d,pi3d,rho,z,ht,         &
+                     cp,g,rovcp,r,xlv,psfc,chs,chs2,cqs2,cpm,      &
+                     znt,ust,mavail,xland,                         &
+                     hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,            &
+                     u10,v10,th2,t2,q2,                            &
+                     svp1,svp2,svp3,svpt0,ep1,ep2,                 &
+                     karman,fCor,exch_temf,                          &
+                     hfx_force, lh_force, tsk_force,               &
+                     hfx_force_tend, lh_force_tend, tsk_force_tend, &
+                     dt,itimestep,                                 &
+                     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)
+!-- th3d        potential 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)
+!-- 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)
+!-- chs         heat/moisture exchange coefficient for LSM (m/s)
+!-- chs2
+!-- cqs2
+!-- cpm
+!-- znt         roughness length (m)
+!-- ust         u* in similarity theory (m/s)
+!-- mavail      surface moisture availability (between 0 and 1)
+!-- 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)
+!-- qgh         lowest-level saturated mixing ratio
+!-- qsfc        ground saturated mixing ratio
+!-- 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)
+!-- 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
+!-- fCor        Coriolis parameter
+!-- 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,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
+                INTENT(IN   ) :: u3d, v3d, th3d, qv3d, p3d, pi3d, rho, z
+      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+                INTENT(IN   ) :: mavail, xland, fCor, ht, psfc, znt
+      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+                INTENT(INOUT) :: hfx, qfx, lh, flhc, flqc, tsk
+      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+                INTENT(INOUT) :: ust, chs2, cqs2, chs, cpm, qgh, qsfc
+      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+                INTENT(OUT  ) :: u10, v10, th2, t2, q2
+      REAL,     DIMENSION( ims:ime, jms:jme )           , &
+                INTENT(  OUT) :: exch_temf
+                                        
+      REAL,     INTENT(INOUT) :: hfx_force, lh_force, tsk_force
+      REAL,     INTENT(IN   ) :: hfx_force_tend, lh_force_tend, tsk_force_tend
+      REAL,     INTENT(IN   ) :: dt
+      INTEGER,  INTENT(IN   ) :: itimestep
+
+      REAL,     INTENT(IN   ) :: cp,g,rovcp,r,xlv
+      REAL,     INTENT(IN   ) :: svp1,svp2,svp3,svpt0
+      REAL,     INTENT(IN   ) :: ep1,ep2,karman
+!
+! LOCAL VARS
+
+      INTEGER ::  J
+!
+! WA 1/6/10 This routine just populates HFX, QFX, and TSK
+! with the suitable converted forcing values.
+! Note that flhc,flqc are not populated, this will NOT WORK with
+! an LSM.
+
+   ! Update forcing fluxes to the current timestep
+   hfx_force = hfx_force + dt*hfx_force_tend
+   lh_force  = lh_force  + dt*lh_force_tend
+   tsk_force = tsk_force + dt*tsk_force_tend
+
+      DO J=jts,jte
+
+        CALL idealscmsfclay1d(j,u1d=u3d(ims,kms,j),v1d=v3d(ims,kms,j),     &
+                th1d=th3d(ims,kms,j),qv1d=qv3d(ims,kms,j),p1d=p3d(ims,kms,j), &
+                pi1d=pi3d(ims,kms,j),rho=rho(ims,kms,j),z=z(ims,kms,j),&
+                zsrf=ht(ims,j),      &
+                cp=cp,g=g,rovcp=rovcp,r=r,xlv=xlv,psfc=psfc(ims,j),    &
+                chs=chs(ims,j),chs2=chs2(ims,j),cqs2=cqs2(ims,j),      &
+                cpm=cpm(ims,j),znt=znt(ims,j),ust=ust(ims,j),          &
+                mavail=mavail(ims,j),xland=xland(ims,j),    &
+                hfx=hfx(ims,j),qfx=qfx(ims,j),lh=lh(ims,j),tsk=tsk(ims,j), &
+                flhc=flhc(ims,j),flqc=flqc(ims,j),qgh=qgh(ims,j),      &
+                qsfc=qsfc(ims,j),u10=u10(ims,j),v10=v10(ims,j),        &
+                th2=th2(ims,j),t2=t2(ims,j),q2=q2(ims,j),        &
+                svp1=svp1,svp2=svp2,svp3=svp3,svpt0=svpt0,             &
+                ep1=ep1,ep2=ep2,karman=karman,fCor=fCor(ims,j),  &
+                exch_temfx=exch_temf(ims,j),                     &
+                hfx_force=hfx_force,lh_force=lh_force,tsk_force=tsk_force, &
+                hfx_force_tend=hfx_force_tend,                         &
+                lh_force_tend=lh_force_tend,                           &
+                tsk_force_tend=tsk_force_tend,                         &
+                dt=dt,itimestep=itimestep,                             &
+                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      &
+                                                                   )
+      ENDDO
+
+   END SUBROUTINE idealscmsfclay
+
+
+!-------------------------------------------------------------------
+   SUBROUTINE idealscmsfclay1d(j,u1d,v1d,th1d,qv1d,p1d, &
+                pi1d,rho,z,zsrf,cp,g,rovcp,r,xlv,psfc,    &
+                chs,chs2,cqs2,cpm,znt,ust,          &
+                mavail,xland,hfx,qfx,lh,tsk, &
+                flhc,flqc,qgh,qsfc,u10,v10,        &
+                th2,t2,q2,svp1,svp2,svp3,svpt0,             &
+                ep1,ep2,karman,fCor,  &
+                exch_temfx,           &
+                hfx_force,lh_force,tsk_force, &
+                hfx_force_tend,lh_force_tend,tsk_force_tend, &
+                dt,itimestep,                                 &
+                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, &
+                                        j
+                                                               
+      REAL,     DIMENSION( ims:ime ), INTENT(IN   ) ::             &
+                                        u1d,v1d,qv1d,p1d,th1d,pi1d,rho,z,zsrf
+      REAL,     INTENT(IN   ) ::        cp,g,rovcp,r,xlv
+      REAL,     DIMENSION( ims:ime ), INTENT(IN   ) :: psfc,znt
+      REAL,     DIMENSION( ims:ime ), INTENT(INOUT) ::             &
+                                        chs,chs2,cqs2,cpm,ust
+      REAL,     DIMENSION( ims:ime ), INTENT(IN   ) :: mavail,xland 
+      REAL,     DIMENSION( ims:ime ), INTENT(INOUT) ::             &
+                                        hfx,qfx,lh
+      REAL,     DIMENSION( ims:ime ), INTENT(INOUT) :: tsk
+      REAL,     DIMENSION( ims:ime ), INTENT(  OUT) ::             &
+                                        flhc,flqc
+      REAL,     DIMENSION( ims:ime ), INTENT(INOUT) ::             &
+                                        qgh,qsfc
+      REAL,     DIMENSION( ims:ime ), INTENT(  OUT) ::             &
+                                        u10,v10,th2,t2,q2
+      REAL,     INTENT(IN   ) ::        svp1,svp2,svp3,svpt0
+      REAL,     INTENT(IN   ) ::        ep1,ep2,karman
+      REAL,     DIMENSION( ims:ime ), INTENT(IN   ) :: fCor
+      REAL,     DIMENSION( ims:ime ), INTENT(  OUT) :: exch_temfx
+      REAL,     INTENT(INOUT) ::        hfx_force,lh_force,tsk_force
+      REAL,     INTENT(IN   ) ::   hfx_force_tend,lh_force_tend,tsk_force_tend
+      REAL,     INTENT(IN   ) :: dt
+      INTEGER,  INTENT(IN   ) :: itimestep
+!
+!! LOCAL VARS
+! TE model constants
+   logical, parameter :: MFopt = .true.  ! Use mass flux or not
+   real, parameter :: TEmin = 1e-3
+   real, parameter :: ftau0 = 0.17
+   real, parameter :: fth0 = 0.145
+   real, parameter :: Cf = 0.185
+   real, parameter :: CN = 2.0
+!   real, parameter :: Ceps = ftau0**1.5
+   real, parameter :: Ceps = 0.070
+   real, parameter :: Cgamma = Ceps
+   real, parameter :: Cphi = Ceps
+!   real, parameter :: PrT0 = Cphi/Ceps * ftau0**2. / 2 / fth0**2.
+   real, parameter :: PrT0 = Cphi/Ceps * ftau0**2 / 2. / fth0**2
+!
+   integer :: i
+   real :: e1
+   real, dimension( its:ite)    ::  wstr, ang, wm
+   real, dimension( its:ite)    ::  z0t
+   real, dimension( its:ite) :: dthdz, dqtdz, dudz, dvdz
+   real, dimension( its:ite) :: lepsmin
+   real, dimension( its:ite) :: thetav
+   real, dimension( its:ite) :: zt,zm
+   real, dimension( its:ite) :: N2, S, Ri, beta, ftau, fth, ratio
+   real, dimension( its:ite) :: TKE, TE2
+   real, dimension( its:ite) :: ustrtilde, linv, leps
+   real, dimension( its:ite) :: km, kh
+   real, dimension( its:ite) :: qsfc_air
+!!-------------------------------------------------------------------
+
+!!!!!!! ******
+! WA Known outages:  None
+
+   do i = its,ite      ! Main loop 
+
+      ! WA 1/6/10 This routine just populates HFX, QFX, and TSK
+      ! with the suitable converted forcing values.
+
+      ! Surface fluxes
+      ust(i) = sqrt(ftau(i)/ftau0) * sqrt(u1d(i)**2. + v1d(i)**2.) * leps(i) / log(zm(i)/znt(i)) / zt(i)
+      ang(i) = atan2(v1d(i),u1d(i))
+
+      ! Populate surface heat and moisture fluxes
+      hfx(i) = hfx_force
+      lh(i)  = lh_force
+      qfx(i) = lh(i) / xlv
+      tsk(i) = tsk_force
+
+      ! Populate exchange coefficients
+      flhc(i) = hfx(i) / (tsk(i) - th1d(i)*pi1d(i))
+      exch_temfx(i)  = flhc(i) / (rho(i) * cp)
+      ! flqc(i) = qfx(i) / (qsfc_air(i) - qv1d(i))
+      flqc(i) = exch_temfx(i) * mavail(i)
+
+   end do  ! Main loop
+
+   END SUBROUTINE idealscmsfclay1d
+
+!====================================================================
+   SUBROUTINE idealscmsfclayinit( allowed_to_read )         
+
+   LOGICAL , INTENT(IN)      ::      allowed_to_read
+
+   END SUBROUTINE idealscmsfclayinit
+
+!-------------------------------------------------------------------          
+
+END MODULE module_sf_idealscmsfclay
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_myjsfc.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_myjsfc.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_myjsfc.F	(revision 17)
@@ -0,0 +1,1277 @@
+!----------------------------------------------------------------------
+!
+      MODULE MODULE_SF_MYJSFC
+!
+!----------------------------------------------------------------------
+!
+      USE MODULE_MODEL_CONSTANTS
+#ifdef DM_PARALLEL
+      USE MODULE_DM, ONLY : WRF_DM_MAXVAL
+#endif
+!
+!----------------------------------------------------------------------
+!
+! 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.,EXCML=0.0001,EXCMS=0.0001         &
+     &                 ,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
+!
+!----------------------------------------------------------------------
+      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,IVGTYP,ISURBAN,IZ0TLND            &
+     &                 ,USTAR,ZNT,Z0BASE,PBLH,MAVAIL,RMOL              &
+     &                 ,AKHS,AKMS                                      &
+     &                 ,RIB                                            &
+     &                 ,CHS,CHS2,CQS2,HFX,QFX,FLX_LH,FLHC,FLQC         &
+     &                 ,QGH,CPM,CT                                     &
+     &                 ,U10,V10,T02,TH02,TSHLTR,TH10,Q02,QSHLTR,Q10,PSHLTR          &
+     &                 ,P1000mb                                        &
+     &                 ,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
+      INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: IVGTYP
+      INTEGER,                           INTENT(IN) :: ISURBAN
+      INTEGER,                           INTENT(IN) :: IZ0TLND
+!
+      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(OUT)   :: RIB
+!
+      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
+!
+      REAL,INTENT(IN) :: P1000mb
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: I,J,K,KFLIP,LMH,LPBL,NTSD
+!
+      REAL :: APESFC,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,TH02P,TH10P,THLOW,THvLOW                       &
+     &       ,TLOW,TZ0,ULOW,VLOW,ZSL
+!
+      REAL,DIMENSION(KTS:KTE) :: CWMK,PK,Q2K,QK,THvK,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
+          THSK(I,J)=TSK(I,J)/(PSFC/P1000mb)**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)
+            THvK(K)=(qk(k)*0.608+(1.-CWMK(K)))*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+1)-ZHK(LMH+1)
+!
+!----------------------------------------------------------------------
+!***
+!***  FIND THE SURFACE EXCHANGE COEFFICIENTS
+!***
+!----------------------------------------------------------------------
+          PLOW=PK(LMH)
+          TLOW=TK(LMH)
+          THLOW=THK(LMH)
+          THvLOW=THvK(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
+          APESFC=(PSFC/P1000mb)**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,TSK(I,J),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),RIB(I,J),PBLH(I,J),MAVAIL(I,J) &
+     &               ,IVGTYP(I,J),ISURBAN,IZ0TLND                      &
+     &               ,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,THvLOW,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
+          P02P=(RAPA02**RCAP)*P1000mb
+          P10P=(RAPA10**RCAP)*P1000mb
+!
+          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,TSK,THZ0,QZ0                       &
+     &                 ,USTAR,Z0,Z0BASE,CT,RLMO,AKMS,AKHS,RIB,PBLH,WETM &
+     &                 ,VEGTYP,ISURBAN,IZ0TLND                         &
+     &                 ,CHS,CHS2,CQS2,HFX,QFX,FLX_LH,FLHC,FLQC,QGH,CPM &
+     &                 ,ULOW,VLOW,TLOW,THLOW,THvLOW,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       &
+     &                  ,THvLOW,THLOW,THS,TSK,TLOW,TZ0                 &
+     &                  ,ULOW,VLOW,WETM,ZSL                            &
+     &                  ,Z0BASE
+      INTEGER, INTENT(IN) :: VEGTYP, ISURBAN, IZ0TLND
+!
+      REAL,INTENT(OUT) :: CHS,CHS2,CPM,CQS2,CT,FLHC,FLQC,FLX_LH,HFX    &
+     &                   ,PSHLTR,Q02,Q10,QFX,QGH,RIB,RLMO              &
+     &                   ,TH02,TH10,U10,V10
+!
+      REAL,INTENT(INOUT) :: AKHS,AKMS,QZ0,THZ0,USTAR,UZ0,VZ0,Z0,QS
+!----------------------------------------------------------------------
+!***
+!***  LOCAL VARIABLES
+!***
+      INTEGER :: ITR,K
+!
+      REAL :: BTGH,BTGX,CXCHL,CXCHS,CZETMAX,DTHV,DU2,ELFC,FCT          &
+     &       ,HLFLX,HSFLX,HV,PSH02,PSH10,PSHZ,PSHZL,PSM10,PSMZ,PSMZL   &
+     &       ,RDZ,RDZT,RLMA,RLMN,RLMP                                  &
+     &       ,RLOGT,RLOGU,RWGH,RZ,RZST,RZSU,SIMH,SIMM                  &
+     &       ,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
+      REAL :: CZIL
+      REAL :: ZILFC
+!----------------------------------------------------------------------
+!**********************************************************************
+!----------------------------------------------------------------------
+      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(USTAR<USTC)THEN
+!----------------------------------------------------------------------
+!
+            IF(USTAR<USTR)THEN
+!
+#if ( NMM_CORE == 1 )
+     if(NTSD+1.eq.1) then
+#else
+     IF(NTSD==1)THEN
+#endif
+!tgs              IF(NTSD==1)THEN
+                AKMS=CXCHS
+                AKHS=CXCHS
+                QS=QLOW
+              ENDIF
+!
+              ZU=FZU1*SQRT(SQRT(Z0*USTAR*RVISC))/USTAR
+              WGHT=AKMS*ZU*RVISC
+              RWGH=WGHT/(WGHT+1.)
+              UZ0=(ULOW*RWGH+UZ0)*0.5
+              VZ0=(VLOW*RWGH+VZ0)*0.5
+!
+              ZT=FZT1*ZU
+              ZQ=FZQ1*ZT
+              WGHTT=AKHS*ZT*RTVISC
+              WGHTQ=AKHS*ZQ*RQVISC
+!
+#if ( NMM_CORE == 1 )
+     if(NTSD+1>1) 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.USTAR<USTC)THEN
+              ZU=Z0
+              UZ0=0.
+              VZ0=0.
+!
+              ZT=FZT2*SQRT(SQRT(Z0*USTAR*RVISC))/USTAR
+              ZQ=FZQ2*ZT
+              WGHTT=AKHS*ZT*RTVISC
+              WGHTQ=AKHS*ZQ*RQVISC
+!
+#if ( NMM_CORE == 1 )
+     if(NTSD+1>1) 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
+!----------------------------------------------------------------------
+          dthv=thvlow-thz0*(0.608*qz0+1.)
+!
+          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
+!----------------------------------------------------------------------
+        dthv=thvlow-thz0*(0.608*qz0+1.)
+!
+        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
+
+          IF ( (IZ0TLND==0) .or. (VEGTYP == ISURBAN) ) THEN
+             ! Just use the original CZIL value.
+             CZIL = 0.1
+          ELSE
+             ! Modify CZIL according to Chen & Zhang, 2009
+             ! CZIL = 10 ** -0.40 H, ( where H = 10*Zo )
+             CZIL = 10.0 ** ( -0.40 * ( Z0 / 0.07 ) )
+          ENDIF
+          ZILFC=-CZIL*VKARMAN*SQVISC
+          
+!----------------------------------------------------------------------
+!
+!mp   Topo modification of ZILFC term
+!	
+!         TOPOTERM=TOPOFAC*ZSFC**2.
+!         TOPOTERM=MAX(TOPOTERM,3.0)
+!
+!  RIB modification to ZILFC term
+!
+!         CZETMAX = 20.
+          CZETMAX = 10.
+! stable
+          IF(DTHV>0.)THEN
+!            ZZIL=ZILFC*TOPOTERM
+            IF (RIB<RIC) THEN
+              ZZIL=ZILFC*(1.0+(RIB/RIC)*(RIB/RIC)*CZETMAX)
+            ELSE
+              ZZIL=ZILFC*(1.0+CZETMAX)
+            ENDIF
+! unstable
+          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
+!
+!***  BE CERTAIN THAT THE 2-M THETA AND 10-M THETA ARE BRACKETED BY
+!***  THE VALUES OF THZ0 AND THLOW.
+!
+      IF(THLOW>THZ0.AND.(TH02<THZ0.OR.TH02>THLOW).OR.                  &
+         THLOW<THZ0.AND.(TH02>THZ0.OR.TH02<THLOW))THEN
+           TH02=THZ0+2.*RDZ*(THLOW-THZ0)
+      ENDIF
+!
+      TH10=HSFLX/AKHS10+THZ0
+!
+      IF(THLOW>THZ0.AND.(TH10<THZ0.OR.TH10>THLOW).OR.                  &
+         THLOW<THZ0.AND.(TH10>THZ0.OR.TH10<THLOW))THEN
+           TH10=THZ0+10.*RDZ*(THLOW-THZ0)
+      ENDIF
+!
+      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=PQ0SEA/PSFC                                      &
+     &         *EXP(A2S*(TSK-A3S)/(TSK-A4S)) 
+        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)
+#ifdef DM_PARALLEL
+        CALL WRF_DM_MAXVAL(MAXGBL_IVGTYP,IDUM,JDUM)
+#endif
+!
+        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
+!
+!----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_mynn.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_mynn.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_mynn.F	(revision 17)
@@ -0,0 +1,907 @@
+MODULE module_sf_mynn
+
+  USE module_model_constants, only: &
+       &p1000mb, cp, xlv, ep_2
+
+  USE module_sf_sfclay, ONLY: sfclayinit
+  USE module_bl_mynn,   only: tv0, mym_condensation
+  
+  IMPLICIT NONE
+
+  REAL, PARAMETER :: xlvcp=xlv/cp, ep_3=1.-ep_2
+ 
+  REAL, PARAMETER :: wmin=0.1    ! Minimum wind speed
+  REAL, PARAMETER :: zm2h=7.4    ! = z_0m/z_0h
+
+  REAL, PARAMETER :: charnock=0.016, bvisc=0.165e-5, z0hsea=5.e-5
+
+  REAL, PARAMETER :: VCONVC=1.
+  REAL, PARAMETER :: czo=charnock
+  
+  REAL, DIMENSION(0:1000 ),SAVE          :: PSIMTB,PSIHTB
+
+
+CONTAINS
+
+  SUBROUTINE mynn_sf_init_driver(allowed_to_read)
+
+    LOGICAL, INTENT(in) :: allowed_to_read
+
+!fill the table 
+       
+    CALL sfclayinit(allowed_to_read)
+
+  END SUBROUTINE mynn_sf_init_driver
+
+
+!-------------------------------------------------------------------
+!only slightly modified for temperature and moisture roughness scales
+
+   SUBROUTINE SFCLAY_mynn(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, &
+                     U10,V10,TH2,T2,Q2,                            &
+                     GZ1OZ0,WSPD,BR,ISFFLX,DX,                     &
+                     SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
+                     KARMAN,EOMEG,STBOLT,                          &
+                     &itimestep,ch,th3d,pi3d,qc3d,&
+                     &tsq,qsq,cov,qcg,&
+                     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
+!-- 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, &
+                                                              &QC3D,&
+                                              &th3d,pi3d,tsq,qsq,cov
+      INTEGER, INTENT(in) :: itimestep
+
+      REAL,     DIMENSION( ims:ime, jms:jme ), INTENT(IN) ::&
+           &    qcg
+      
+      REAL,     DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) ::&
+           & ch
+
+
+
+      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(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,qc1d
+
+      REAL,     DIMENSION( its:ite ) ::                    dz8w1d
+
+      REAL,     DIMENSION( its:ite ) ::  vt1,vq1
+      REAL,     DIMENSION(kts:kts+1) ::  thl, qw, vt, vq
+      REAL                           ::  ql
+
+      INTEGER ::  I,J,K
+
+      DO J=jts,jte
+        DO i=its,ite
+          dz8w1d(I) = dz8w(i,kts,j)
+        ENDDO
+   
+        DO i=its,ite
+           U1D(i) =U3D(i,kts,j)
+           V1D(i) =V3D(i,kts,j)
+           QV1D(i)=QV3D(i,kts,j)
+           QC1D(i)=QC3D(i,kts,j)
+           P1D(i) =P3D(i,kts,j)
+           T1D(i) =T3D(i,kts,j)
+        ENDDO
+
+        IF (itimestep==1) THEN
+           DO i=its,ite
+              vt1(i)=0.
+              vq1(i)=0.
+           ENDDO
+        ELSE
+           DO i=its,ite
+              do k = kts,kts+1
+                ql = qc3d(i,k,j)/(1.+qc3d(i,k,j))
+                qw (k) = qv3d(i,k,j)/(1.+qv3d(i,k,j)) + ql
+                thl(k) = th3d(i,k,j)-xlvcp*ql/pi3d(i,k,j)
+              end do
+
+! NOTE: The last grid number is kts+1 instead of kte.
+              CALL mym_condensation (kts,kts+1, &
+                   &            dz8w(i,kts:kts+1,j), &
+                   &            thl(kts:kts+1), qw(kts:kts+1), &
+                   &            p3d(i,kts:kts+1,j),&
+                   &            pi3d(i,kts:kts+1,j), &
+                   &            tsq(i,kts:kts+1,j), &
+                   &            qsq(i,kts:kts+1,j), &
+                   &            cov(i,kts:kts+1,j), &
+                   &            vt(kts:kts+1), vq(kts:kts+1))
+
+              vt1(i) = vt(kts)
+              vq1(i) = vq(kts)
+           ENDDO
+        ENDIF
+
+
+        CALL SFCLAY1D_mynn(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),     &
+                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,  &
+                ch(ims,j),vt1,vq1,qc1d,qcg(ims,j),&
+                ids,ide, jds,jde, kds,kde,                         &
+                ims,ime, jms,jme, kms,kme,                         &
+                its,ite, jts,jte, kts,kte                          )
+      ENDDO
+
+
+    END SUBROUTINE SFCLAY_MYNN
+
+
+!-------------------------------------------------------------------
+   SUBROUTINE SFCLAY1D_mynn(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,                            &
+                     U10,V10,TH2,T2,Q2,FLHC,FLQC,QGH,              &
+                     QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX,             &
+                     SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
+                     KARMAN,EOMEG,STBOLT,                          &
+                     ch,vt1,vq1,qc1d,qcg,&
+                     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,     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,qc1d
+ 
+ 
+      REAL, DIMENSION( ims:ime ), INTENT(IN) ::&
+!           &    vt1,vq1,&
+           &qcg
+      
+      REAL,     DIMENSION( ims:ime ), INTENT(INOUT) ::&
+           & ch
+
+
+       REAL, DIMENSION( its:ite ), INTENT(IN) :: vt1,vq1
+
+
+! LOCAL VARS
+
+      REAL,     DIMENSION( its:ite ) :: z_t,z_q
+
+      REAL :: thl1,sqv1,sqc1,exner1,sqvg,sqcg,vv,ww
+
+      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
+
+      REAL,     DIMENSION( its:ite )        :: GZ2OZt,GZ10OZt,GZ1OZt
+
+!
+      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
+      real :: restar
+
+
+!-------------------------------------------------------------------
+
+      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)/(1.+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)-ep_3*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))
+        PL=P1D(I)/1000.
+        QGH(I)=EP2*E1/(PL-ep_3*E1)
+        CPM(I)=CP*(1.+0.8*QX(I)/(1.-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
+
+        IF((XLAND(I)-1.5).GE.0)THEN 
+!           restar=ust(i)*znt(i)/bvisc
+!           z_t(i)=znt(i)*EXP(-2.48*restar**.25 -2.)
+!           z_q(i)=znt(i)*EXP(-2.28*restar**.25 -2.)
+!           z_q(i)=z_t(i)
+           z_t(i)=z0hsea
+           z_q(i)=z_t(i)
+        ELSE
+           z_t(i)=ZNT(I)/zm2h
+           z_q(i)=z_t(i)
+        ENDIF
+
+
+
+        GZ1OZ0(I)=ALOG(ZA(I)/ZNT(I))
+        GZ1OZt(I)=ALOG(ZA(I)/z_t(i))
+           
+        GZ2OZ0(I)=ALOG(2./ZNT(I))                                        
+        GZ2OZt(I)=ALOG(2./z_t(i))                                        
+        GZ10OZ0(I)=ALOG(10./ZNT(I)) 
+        GZ10OZt(I)=ALOG(10./z_t(i)) 
+
+        WSPD(I)=SQRT(UX(I)*UX(I)+VX(I)*VX(I))                        
+
+!account for partial condensation
+
+        exner1=(p1d(i)/p1000mb)**ROVCP
+        sqc1=qc1d(i)/(1.+qc1d(i))
+        sqv1=qx(i)
+        thl1=THX(I)-xlvcp/exner1*sqc1
+        sqvg=qsfc(i)
+        sqcg=qcg(i)/(1.+qcg(i))
+
+        vv = thl1-THGB(I)
+        ww = mavail(i)*(sqv1-sqvg) + (sqc1-sqcg)
+
+        TSKV=THGB(I)*(1.+EP1*QSFC(I)*MAVAIL(I))                     
+
+!        DTHVDZ=(THVX(I)-TSKV)                     
+
+        DTHVDZ= (vt1(i) + 1.0)*vv+&
+               &(vq1(i) + tv0)*ww
+
+!  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)
+!      Use Beljaars over land, old MM5 (Wyngaard) formula over water
+        if (xland(i).lt.1.5) then
+        fluxc = max(hfx(i)/rhox(i)/cp                    &
+              + ep1*tskv*qfx(i)/rhox(i),0.)
+        VCONV = vconvc*(g/tgdsa(i)*pblh(i)*fluxc)**.33
+        else
+        IF(-DTHVDZ.GE.0)THEN
+          DTHVM=-DTHVDZ
+        ELSE
+          DTHVM=0.
+        ENDIF
+        VCONV = 2.*SQRT(DTHVM)
+        endif
+! Mahrt and Sun low-res correction
+        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),wmin)
+        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.)
+        PSIT=AMAX1(GZ1OZt(I)-PSIH(I),2.)
+
+
+
+        PSIQ=ALOG(za(i)/z_q(i))-PSIH(I)   
+        PSIT2=GZ2OZt(I)-PSIH2(I)                                     
+        PSIQ2=ALOG(2./z_q(i))-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((XLAND(I)-1.5).LT.0.)THEN
+          UST(I)=AMAX1(UST(I),0.1)
+        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+bvisc/ust(i)                                   
+!           restar=ust(i)*znt(i)/bvisc
+!           z_t(i)=znt(i)*EXP(-2.48*restar**.25 -2.)
+!           z_q(i)=znt(i)*EXP(-2.28*restar**.25 -2.)
+!           z_q(i)=z_t(i)
+           z_t(i)=z0hsea
+           z_q(i)=z_t(i)
+
+        ENDIF    
+
+
+!        FLQC(I)=RHOX(I)*MAVAIL(I)*UST(I)*KARMAN/(   &
+!                ALOG(KARMAN*UST(I)*ZA(I)/XKA+ZA(I)/ZL)-PSIH(I))
+
+        FLQC(I)=RHOX(I)*MAVAIL(I)*UST(I)*KARMAN/(   & 
+             &             ALOG(za(i)/z_q(i))-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
+
+
+!         CHS(I)=UST(I)*KARMAN/(ALOG(KARMAN*UST(I)*ZA(I) &
+!                /XKA+ZA(I)/ZL)-PSIH(I))
+
+         CHS(I)=UST(I)*KARMAN/(ALOG(ZA(I)/z_t(i))- &
+              &PSIH(I))
+
+! The exchange coefficient for cloud water is assumed to be the same as
+! that for heat. CH is multiplied by WSPD.
+
+!!         ch(i)=chs(i)
+         ch(i)=flhc(i)/( cpm(i)*rhox(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))
+
+
+         CQS2(I)=UST(I)*KARMAN/(ALOG(2.0/z_q(i))-PSIH2(I))
+         CHS2(I)=UST(I)*KARMAN/(GZ2OZt(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_mynn
+
+!-------------------------------------------------------------------          
+END MODULE module_sf_mynn
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_noahdrv.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_noahdrv.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_noahdrv.F	(revision 17)
@@ -0,0 +1,1820 @@
+MODULE module_sf_noahdrv
+
+!-------------------------------
+  USE module_sf_noahlsm
+  USE module_sf_urban
+  USE module_sf_bep
+  USE module_sf_bep_bem
+#ifdef WRF_CHEM
+  USE module_data_gocart_dust
+#endif
+!-------------------------------
+
+!
+CONTAINS
+!
+!----------------------------------------------------------------
+! Urban related variable are added to arguments - urban
+!----------------------------------------------------------------
+   SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK,                      &
+                  HFX,QFX,LH,GRDFLX, QGH,GSW,SWDOWN,GLW,SMSTAV,SMSTOT, &
+                  SFCRUNOFF, UDRUNOFF,IVGTYP,ISLTYP,ISURBAN,ISICE,VEGFRA,    &
+                  ALBEDO,ALBBCK,ZNT,Z0,TMN,XLAND,XICE,EMISS,EMBCK,   &
+                  SNOWC,QSFC,RAINBL,MMINLU,                     &
+                  num_soil_layers,DT,DZS,ITIMESTEP,             &
+                  SMOIS,TSLB,SNOW,CANWAT,                       &
+                  CHS,CHS2,CQS2,CPM,ROVCP,SR,chklowq,lai,qz0,   & !H
+                  myj,frpcpn,                                   &
+                  SH2O,SNOWH,                                   & !H
+                  U_PHY,V_PHY,                                  & !I
+                  SNOALB,SHDMIN,SHDMAX,                         & !I
+                  SNOTIME,                                      & !?
+                  ACSNOM,ACSNOW,                                & !O
+                  SNOPCX,                                       & !O
+                  POTEVP,                                       & !O
+                  SMCREL,                                       & !O
+                  XICE_THRESHOLD,                               &
+                  RDLAI2D,USEMONALB,                            &
+                  RIB,                                          & !?
+                  NOAHRES,                                      &
+                  ids,ide, jds,jde, kds,kde,                    &
+                  ims,ime, jms,jme, kms,kme,                    &
+                  its,ite, jts,jte, kts,kte,                    &
+                  sf_urban_physics,                             &
+                  CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF,  &
+!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
+                  num_urban_layers,                             & !I multi-layer urban
+                  trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,      & !H multi-layer urban
+                  tlev_urb3d,qlev_urb3d,                        & !H multi-layer urban
+                  tw1lev_urb3d,tw2lev_urb3d,                    & !H multi-layer urban
+                  tglev_urb3d,tflev_urb3d,                      & !H multi-layer urban
+                  sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,          & !H multi-layer urban
+                  sfvent_urb3d,lfvent_urb3d,                    & !H multi-layer urban
+                  sfwin1_urb3d,sfwin2_urb3d,                    & !H multi-layer urban
+                  sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,    & !H multi-layer urban
+                  th_phy,rho,p_phy,ust,                         & !I multi-layer urban
+                  gmt,julday,xlong,xlat,                        & !I multi-layer urban
+                  a_u_bep,a_v_bep,a_t_bep,a_q_bep,              & !O multi-layer urban
+                  a_e_bep,b_u_bep,b_v_bep,                      & !O multi-layer urban
+                  b_t_bep,b_q_bep,b_e_bep,dlg_bep,              & !O multi-layer urban
+                  dl_u_bep,sf_bep,vl_bep                         )   !O multi-layer urban         
+
+!----------------------------------------------------------------
+    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)
+!-- SMAV        Soil Moisture Availability for each layer, as a fraction
+!                 between SMCWLT and SMCMAX (dimensionless fraction)
+! ----------------------------------------------------------------------
+!-- 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)
+!-- SNOPCX      snow phase change heat flux (W/m^2)
+!-- POTEVP      accumulated potential evaporation (W/m^2)
+!-- RIB         Documentation needed!!!
+! ----------------------------------------------------------------------
+!-- 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).
+!SFCRUNOFF     Surface Runoff (mm)
+!UDRUNOFF      Total Underground Runoff (mm), which is the sum of RUNOFF2 and RUNOFF3
+! ----------------------------------------------------------------------
+!-- 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)
+!-- EMBCK       Background 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
+!
+!-- SR          fraction of frozen precip (0.0 to 1.0)
+!----------------------------------------------------------------
+
+! 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   )   ::  sf_urban_physics               !urban
+   INTEGER,  INTENT(IN   )   ::  isurban
+   INTEGER,  INTENT(IN   )   ::  isice
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(IN   )    ::                            TMN, &
+                                                         XLAND, &
+                                                          XICE, &
+                                                        VEGFRA, &
+                                                        SHDMIN, &
+                                                        SHDMAX, &
+                                                        SNOALB, &
+                                                           GSW, &
+                                                        SWDOWN, & !added 10 jan 2007
+                                                           GLW, &
+                                                        RAINBL, &
+                                                        EMBCK,  &
+                                                        SR
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(INOUT)    ::                         ALBBCK, &
+                                                            Z0
+   CHARACTER(LEN=*), INTENT(IN   )    ::                 MMINLU
+
+   REAL,    DIMENSION( ims:ime, kms:kme, jms:jme )            , &
+            INTENT(IN   )    ::                           QV3D, &
+                                                         p8w3D, &
+                                                          DZ8W, &
+                                                          T3D
+   REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+             INTENT(IN   )               ::               QGH,  &
+                                                          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 , 1:num_soil_layers, jms:jme ), &
+             INTENT(OUT)     ::                         SMCREL
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(INOUT)    ::                            TSK, & !was TGB (temperature)
+                                                           HFX, &
+                                                           QFX, &
+                                                            LH, &
+                                                        GRDFLX, &
+                                                          QSFC,&
+                                                          CQS2,&
+                                                          CHS,   &
+                                                          CHS2,&
+                                                          SNOW, &
+                                                         SNOWC, &
+                                                         SNOWH, & !new
+                                                        CANWAT, &
+                                                        SMSTAV, &
+                                                        SMSTOT, &
+                                                     SFCRUNOFF, &
+                                                      UDRUNOFF, &
+                                                        ACSNOM, &
+                                                        ACSNOW, &
+                                                       SNOTIME, &
+                                                        SNOPCX, &
+                                                        EMISS,  &
+                                                          RIB,  &
+                                                        POTEVP, &
+                                                        ALBEDO, &
+                                                           ZNT
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(OUT)      ::                         NOAHRES
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+               INTENT(OUT)    ::                        CHKLOWQ
+   REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LAI
+   REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) ::        QZ0
+
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF
+! Local variables (moved here from driver to make routine thread safe, 20031007 jm)
+
+      REAL, DIMENSION(1:num_soil_layers) ::  ET
+
+      REAL, DIMENSION(1:num_soil_layers) ::  SMAV
+
+      REAL  ::  BETA, ETP, SSOIL,EC, EDIR, ESNOW, ETT,        &
+                FLX1,FLX2,FLX3, DRIP,DEW,FDOWN,RC,PC,RSMIN,XLAI,  &
+!                RCS,RCT,RCQ,RCSOIL
+                RCS,RCT,RCQ,RCSOIL,FFROZP
+
+    LOGICAL,    INTENT(IN   )    ::     myj,frpcpn
+
+! 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,Q2SATI,SFCPRS,SFCSPD,SFCTMP,SHDFAC,SNOALB1,         &
+               SOLDN,TBOT,ZLVL, Q2K,ALBBRD, ALBEDOK, ETA, ETA_KINEMATIC, &
+               EMBRD,                                                    &
+               Z0K,RUNOFF1,RUNOFF2,RUNOFF3,SHEAT,SOLNET,E2SAT,SFCTSNO,   &
+! mek, WRF testing, expanded diagnostics
+               SOLUP,LWUP,RNET,RES,Q1SFC,TAIRV,SATFLG
+! MEK MAY 2007
+      REAL ::  FDTLIW
+! MEK JUL2007 for pot. evap.
+      REAL :: RIBB
+      REAL ::  FDTW
+
+      REAL  :: EMISSI
+
+      REAL  :: SNCOVR,SNEQV,SNOWHK,CMC, CHK,TH2
+
+      REAL  :: SMCDRY,SMCMAX,SMCREF,SMCWLT,SNOMLT,SOILM,SOILW,Q1,T1
+      REAL  :: SNOTIME1    ! LSTSNW1 INITIAL NUMBER OF TIMESTEPS SINCE LAST SNOWFALL
+
+      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)
+! MEK MAY 2007
+      REAL, PARAMETER  :: ROW=1.E3,ELIW=XLF,ROWLIW=ROW*ELIW
+
+! ----------------------------------------------------------------------
+! 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
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: TH_PHY
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: P_PHY
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: RHO
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UST
+
+     LOGICAL, intent(in) :: rdlai2d
+     LOGICAL, intent(in) :: USEMONALB
+
+! 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
+! Variables for multi-layer UCM (Martilli et al. 2002)
+   REAL, OPTIONAL, INTENT(IN  )   ::                                   GMT 
+   INTEGER, OPTIONAL, INTENT(IN  ) ::                               JULDAY
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )        ::XLAT, XLONG
+   INTEGER, INTENT(IN  ) ::                               NUM_URBAN_LAYERS
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tlev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: qlev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1lev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2lev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tglev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tflev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin1_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin2_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_u_bep   !Implicit momemtum component X-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_v_bep   !Implicit momemtum component Y-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_t_bep   !Implicit component pot. temperature
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_q_bep   !Implicit momemtum component X-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_e_bep   !Implicit component TKE
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_u_bep   !Explicit momentum component X-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_v_bep   !Explicit momentum component Y-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_t_bep   !Explicit component pot. temperature
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_q_bep   !Implicit momemtum component Y-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_e_bep   !Explicit component TKE
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::vl_bep    !Fraction air volume in grid cell
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dlg_bep   !Height above ground
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::sf_bep  !Fraction air at the face of grid cell
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dl_u_bep  !Length scale
+
+! Local variables for multi-layer UCM (Martilli et al. 2002)
+   REAL,    DIMENSION( ims:ime, jms:jme ) :: HFX_RURAL,LH_RURAL,GRDFLX_RURAL,RN_RURAL
+   REAL,    DIMENSION( ims:ime, jms:jme ) :: QFX_RURAL,QSFC_RURAL,UMOM_RURAL,VMOM_RURAL
+   REAL,    DIMENSION( ims:ime, jms:jme ) :: ALB_RURAL,EMISS_RURAL,UST_RURAL,TSK_RURAL
+!   REAL,    DIMENSION( ims:ime, jms:jme ) :: GRDFLX_URB
+!   REAL,    DIMENSION( ims:ime, jms:jme ) :: QFX_URB,QSFC_URB,UMOM_URB,VMOM_URB
+   REAL,    DIMENSION( ims:ime, jms:jme ) :: HFX_URB,UMOM_URB,VMOM_URB
+   REAL,    DIMENSION( ims:ime, jms:jme ) :: QFX_URB
+!   REAL,    DIMENSION( ims:ime, jms:jme ) :: ALBEDO_URB,EMISS_URB,UMOM,VMOM,UST
+   REAL, DIMENSION(ims:ime,jms:jme) ::EMISS_URB
+   REAL, DIMENSION(ims:ime,jms:jme) :: RL_UP_URB
+   REAL, DIMENSION(ims:ime,jms:jme) ::RS_ABS_URB
+   REAL, DIMENSION(ims:ime,jms:jme) ::GRDFLX_URB
+   REAL :: SIGMA_SB,RL_UP_RURAL,RL_UP_TOT,RS_ABS_TOT,UMOM,VMOM
+   REAL :: r1,r2,r3
+   REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB
+! ----------------------------------------------------------------------
+! DECLARATIONS END - urban
+! ----------------------------------------------------------------------
+
+  REAL, PARAMETER  :: CAPA=R_D/CP
+  REAL :: APELM,APES,SFCTH2,PSFC
+  real, intent(in) :: xice_threshold
+  character(len=80) :: message_text
+
+! MEK MAY 2007
+      FDTLIW=DT/ROWLIW
+! MEK JUL2007
+      FDTW=DT/(XLV*RHOWATER)
+! debug printout
+         IPRINT=.false.
+
+!      SLOPETYP=2
+      SLOPETYP=1
+!      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 0
+            IF( XICE(I,J).GE. XICE_THRESHOLD .and. IPRINT ) PRINT*, ' sea-ice at water point, I=',I,'J=',J
+#endif
+!***   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
+              SMCREL(I,NS,J)=1.0
+            ENDDO
+          ELSE
+            IF ( XICE(I,J) .GE. XICE_THRESHOLD ) THEN
+!***        SEA-ICE CASE
+              SMSTAV(I,J)=1.0
+              SMSTOT(I,J)=1.0
+              DO NS=1,NSOIL
+                SMOIS(I,NS,J)=1.0
+                SMCREL(I,NS,J)=1.0
+              ENDDO
+            ENDIF
+          ENDIF
+!
+   50   CONTINUE
+      ENDIF                                                               ! end of initialization over ocean
+
+!-----------------------------------------------------------------------
+      DO 100 I=its,ite
+! surface pressure
+        PSFC=P8w3D(i,1,j)
+! pressure in middle of lowest layer
+        SFCPRS=(P8W3D(I,KTS+1,j)+P8W3D(i,KTS,j))*0.5
+! convert from mixing ratio to specific humidity
+         Q2K=QV3D(i,1,j)/(1.0+QV3D(i,1,j))
+!
+!         Q2SAT=QGH(I,j)
+         Q2SAT=QGH(I,J)/(1.0+QGH(I,J))        ! Q2SAT is sp humidity
+! add check on myj=.true.
+!        IF((Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN
+        IF((myj).AND.(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
+
+        SFCTMP=T3D(i,1,j)
+        ZLVL=0.5*DZ8W(i,1,j)
+
+!        TH2=SFCTMP+(0.0097545*ZLVL)
+! calculate SFCTH2 via Exner function vs lapse-rate (above)
+         APES=(1.E5/PSFC)**CAPA
+         APELM=(1.E5/SFCPRS)**CAPA
+         SFCTH2=SFCTMP*APELM
+         TH2=SFCTH2/APES
+!
+         EMISSI = EMISS(I,J)
+         LWDN=GLW(I,J)*EMISSI
+! SOLDN is total incoming solar
+        SOLDN=SWDOWN(I,J)
+! GSW is net downward solar
+!        SOLNET=GSW(I,J)
+! use mid-day albedo to determine net downward solar (no solar zenith angle correction)
+        SOLNET=SOLDN*(1.-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
+! convert snow water equivalent from mm to meter
+        SNEQV=SNOW(I,J)*0.001
+! snow depth in meters
+        SNOWHK=SNOWH(I,J)
+        SNCOVR=SNOWC(I,J)
+
+! if "SR" present, set frac of frozen precip ("FFROZP") = snow-ratio ("SR", range:0-1)
+! SR from e.g. Ferrier microphysics
+! otherwise define from 1st atmos level temperature
+       IF(FRPCPN) THEN
+          FFROZP=SR(I,J)
+        ELSE
+          IF (SFCTMP <=  273.15) THEN
+            FFROZP = 1.0
+	  ELSE
+	    FFROZP = 0.0
+	  ENDIF
+        ENDIF
+!***
+        IF((XLAND(I,J)-1.5).GE.0.)THEN                                  ! begining of land/sea if block
+! Open water points
+          TSK_RURAL(I,J)=TSK(I,J)
+          HFX_RURAL(I,J)=HFX(I,J)
+          QFX_RURAL(I,J)=QFX(I,J)
+          LH_RURAL(I,J)=LH(I,J)
+          EMISS_RURAL(I,J)=EMISS(I,J)
+          GRDFLX_RURAL(I,J)=GRDFLX(I,J)
+        ELSE
+! Land or sea-ice case
+
+          IF (XICE(I,J) >= XICE_THRESHOLD) THEN
+             ! Sea-ice point
+             ICE = 1
+          ELSE IF ( VEGTYP == ISICE ) THEN
+             ! Land-ice point
+             ICE = -1
+          ELSE
+             ! Neither sea ice or land ice.
+             ICE=0
+          ENDIF
+          DQSDT2=Q2SAT*A23M4/(SFCTMP-A4)**2
+
+          IF(SNOW(I,J).GT.0.0)THEN
+! snow on surface (use ice saturation properties)
+            SFCTSNO=SFCTMP
+            E2SAT=611.2*EXP(6174.*(1./273.15 - 1./SFCTSNO))
+            Q2SATI=0.622*E2SAT/(SFCPRS-E2SAT)
+            Q2SATI=Q2SATI/(1.0+Q2SATI)    ! spec. hum.
+            IF (T1 .GT. 273.14) THEN
+! warm ground temps, weight the saturation between ice and water according to SNOWC
+              Q2SAT=Q2SAT*(1.-SNOWC(I,J)) + Q2SATI*SNOWC(I,J)
+              DQSDT2=DQSDT2*(1.-SNOWC(I,J)) + Q2SATI*6174./(SFCTSNO**2)*SNOWC(I,J)
+            ELSE
+! cold ground temps, use ice saturation only
+              Q2SAT=Q2SATI
+              DQSDT2=Q2SATI*6174./(SFCTSNO**2)
+            ENDIF
+! for snow cover fraction at 0 C, ground temp will not change, so DQSDT2 effectively zero
+            IF(T1 .GT. 273. .AND. SNOWC(I,J) .GT. 0.)DQSDT2=DQSDT2*(1.-SNOWC(I,J))
+          ENDIF
+
+          IF(ICE.EQ.1)THEN
+             ! Sea-ice point has deep-level temperature of -2 C
+             TBOT=271.16
+          ELSE
+             ! Land-ice or land points have the usual deep-soil temperature.
+             TBOT=TMN(I,J)
+          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 0
+         IF(IPRINT)PRINT*,' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT'
+         IF(IPRINT)PRINT*,i,j,'RESET SOIL in surfce.F'
+#endif
+            SOILTYP=7
+          ENDIF
+          SNOALB1 = SNOALB(I,J)
+          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
+
+!        SNOALB1=0.80
+!        SHMIN=0.00
+        ALBBRD=ALBBCK(I,J)
+        Z0BRD=Z0(I,J)
+        EMBRD=EMBCK(I,J)
+        SNOTIME1 = SNOTIME(I,J)
+        RIBB=RIB(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 the natural surface in cities as
+! the "NATURAL" category in the VEGPARM.TBL
+	
+	   IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN
+                IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. &
+                  IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN
+		 VEGTYP = NATURAL
+                 SHDFAC = SHDTBL(NATURAL)
+                 ALBEDOK =0.2         !  0.2
+                 ALBBRD  =0.2         !0.2
+                 EMISSI = 0.98                                 !for VEGTYP=5
+		 IF ( FRC_URB2D(I,J) < 0.99 ) THEN
+                   if(sf_urban_physics.eq.1)then
+           T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J))
+                   elseif((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then
+                r1= (tsk(i,j)**4.)
+                r2= frc_urb2d(i,j)*(ts_urb2d(i,j)**4.)
+                r3= (1.-frc_urb2d(i,j))
+                t1= ((r1-r2)/r3)**.25
+                   endif
+	         ELSE
+		 T1 = TSK(I,J)
+                 ENDIF
+                ENDIF
+           ELSE
+                 IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. &
+                  IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN
+                  VEGTYP = ISURBAN
+           	 ENDIF
+           ENDIF
+
+#if 0
+          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,&
+          'ALBEDOK',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
+#endif
+
+
+          IF (rdlai2d) THEN
+             xlai = lai(i,j)
+          endif
+
+       CALL SFLX (FFROZP, ICE, ISURBAN, DT,ZLVL,NSOIL,SLDPTH,     &    !C
+                 LOCAL,                                           &    !L
+                 LUTYPE, SLTYPE,                                  &    !CL
+                 LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY,         &    !F
+                 DUMMY,DUMMY, DUMMY,                              &    !F PRCPRAIN not used
+                 TH2,Q2SAT,DQSDT2,                                &    !I
+                 VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX,      &    !I
+                 ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, &    !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,SMAV,                             &    !D
+                 RDLAI2D,USEMONALB,                               &
+                 SNOTIME1,                                        &
+                 RIBB,                                            &
+                 SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT)
+
+
+       lai(i,j) = xlai
+
+#if 0
+          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,&
+          'ALBEDOK',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
+#endif
+
+!***  UPDATE STATE VARIABLES
+          CANWAT(I,J)=CMC
+          SNOW(I,J)=SNEQV*1000.
+!          SNOWH(I,J)=SNOWHK*1000.
+          SNOWH(I,J)=SNOWHK                   ! SNOWHK in meters
+          ALBEDO(I,J)=ALBEDOK
+          ALB_RURAL(I,J)=ALBEDOK
+          ALBBCK(I,J)=ALBBRD
+          Z0(I,J)=Z0BRD
+          EMISS(I,J) = EMISSI
+          EMISS_RURAL(I,J) = EMISSI
+! Noah: activate time-varying roughness length (V3.3 Feb 2011)
+          ZNT(I,J)=Z0K
+          TSK(I,J)=T1
+          TSK_RURAL(I,J)=T1
+          HFX(I,J)=SHEAT
+          HFX_RURAL(I,J)=SHEAT
+! MEk Jul07 add potential evap accum
+        POTEVP(I,J)=POTEVP(I,J)+ETP*FDTW
+          QFX(I,J)=ETA_KINEMATIC
+          QFX_RURAL(I,J)=ETA_KINEMATIC
+          LH(I,J)=ETA
+          LH_RURAL(I,J)=ETA
+          GRDFLX(I,J)=SSOIL
+          GRDFLX_RURAL(I,J)=SSOIL
+          SNOWC(I,J)=SNCOVR
+          CHS2(I,J)=CQS2(I,J)
+          SNOTIME(I,J) = SNOTIME1
+!      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
+! Convert QSFC back to mixing ratio
+           QSFC(I,J)= Q1/(1.0-Q1)
+!
+           QSFC_RURAL(I,J)= Q1/(1.0-Q1)
+! Calculate momentum flux from rural surface for use with multi-layer UCM (Martilli et al. 2002)
+
+          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
+
+     !
+     ! Residual of surface energy balance equation terms
+     !
+     noahres(i,j) =     ( solnet + lwdn ) - sheat + ssoil - eta - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3
+
+
+        IF (SF_URBAN_PHYSICS == 1 ) THEN                                              ! Beginning of UCM CALL if block
+!--------------------------------------
+! URBAN CANOPY MODEL START - urban
+!--------------------------------------
+! Input variables lsm --> urban
+
+
+          IF( IVGTYP(I,J) == ISURBAN .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   = GLW(I,J)         ! [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)
+!
+!
+!      Limits to avoid dividing by small number
+            if (CHS(I,J) < 1.0E-02) then
+               CHS(I,J)  = 1.0E-02
+            endif
+            if (CHS2(I,J) < 1.0E-02) then
+               CHS2(I,J)  = 1.0E-02
+            endif
+            if (CQS2(I,J) < 1.0E-02) then
+               CQS2(I,J)  = 1.0E-02
+            endif
+!
+            CHS_URB  = CHS(I,J)
+            CHS2_URB = CHS2(I,J)
+            IF (PRESENT(CMR_SFCDIF)) THEN
+               CMR_URB = CMR_SFCDIF(I,J)
+               CHR_URB = CHR_SFCDIF(I,J)
+               CMC_URB = CMC_SFCDIF(I,J)
+               CHC_URB = CHC_SFCDIF(I,J)
+            ENDIF
+!
+! 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
+                       CMR_URB, CHR_URB, CMC_URB, CHC_URB,              &
+                       U10_URB, V10_URB, TH2_URB, Q2_URB,               & ! O
+                       UST_URB)                                           !O
+
+#if 0
+          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
+#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]
+            Q1 = FRC_URB2D(I,J)*QS_URB+(1-FRC_URB2D(I,J))*Q1            ![-]
+! Convert QSFC back to mixing ratio
+            QSFC(I,J)= Q1/(1.0-Q1)
+            UST(I,J)= FRC_URB2D(I,J)*UST_URB+(1-FRC_URB2D(I,J))*UST(I,J)      ![m/s]
+
+#if 0
+    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
+#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))
+            IF (PRESENT(CMR_SFCDIF)) THEN
+               CMR_SFCDIF(I,J) = CMR_URB
+               CHR_SFCDIF(I,J) = CHR_URB
+               CMC_SFCDIF(I,J) = CMC_URB
+               CHC_SFCDIF(I,J) = CHC_URB
+            ENDIF
+          END IF
+
+         ENDIF                                   ! end of UCM CALL if block
+!--------------------------------------
+! Urban Part End - urban
+!--------------------------------------
+
+!***  DIAGNOSTICS
+          SMSTAV(I,J)=SOILW
+          SMSTOT(I,J)=SOILM*1000.
+          DO NS=1,NSOIL
+          SMCREL(I,NS,J)=SMAV(NS)
+          ENDDO
+!         Convert the water unit into mm
+          SFCRUNOFF(I,J)=SFCRUNOFF(I,J)+RUNOFF1*DT*1000.0
+          UDRUNOFF(I,J)=UDRUNOFF(I,J)+RUNOFF2*DT*1000.0
+! snow defined when fraction of frozen precip (FFROZP) > 0.5,
+          IF(FFROZP.GT.0.5)THEN
+            ACSNOW(I,J)=ACSNOW(I,J)+PRCP*DT
+          ENDIF
+          IF(SNOW(I,J).GT.0.)THEN
+            ACSNOM(I,J)=ACSNOM(I,J)+SNOMLT*1000.
+! accumulated snow-melt energy
+            SNOPCX(I,J)=SNOPCX(I,J)-SNOMLT/FDTLIW
+          ENDIF
+
+        ENDIF                                                           ! endif of land-sea test
+
+  100 CONTINUE                                                          ! of I loop
+
+   ENDDO                                                                ! of J loop
+
+      IF (SF_URBAN_PHYSICS == 2) THEN
+
+
+         do j=jts,jte
+         do i=its,ite
+            EMISS_URB(i,j)=0.
+            RL_UP_URB(i,j)=0.
+            RS_ABS_URB(i,j)=0.
+            GRDFLX_URB(i,j)=0.
+            b_q_bep(i,kts:kte,j)=0.
+         end do
+         end do
+       CALL BEP(frc_urb2d,utype_urb2d,itimestep,dz8w,dt,u_phy,v_phy,   &
+                th_phy,rho,p_phy,swdown,glw,                           &
+                gmt,julday,xlong,xlat,declin_urb,cosz_urb2d,omg_urb2d, &
+                num_urban_layers,                                      &
+                trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,               &
+                sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,             &
+                a_u_bep,a_v_bep,a_t_bep,                               &
+                a_e_bep,b_u_bep,b_v_bep,                               &
+                b_t_bep,b_e_bep,dlg_bep,                               &
+                dl_u_bep,sf_bep,vl_bep,                                &
+                rl_up_urb,rs_abs_urb,emiss_urb,grdflx_urb,             &
+                ids,ide, jds,jde, kds,kde,                             &
+                ims,ime, jms,jme, kms,kme,                             &
+                its,ite, jts,jte, kts,kte )
+
+       ENDIF
+
+       
+       IF (SF_URBAN_PHYSICS == 3) THEN
+
+
+         do j=jts,jte
+         do i=its,ite
+            EMISS_URB(i,j)=0.
+            RL_UP_URB(i,j)=0.
+            RS_ABS_URB(i,j)=0.
+            GRDFLX_URB(i,j)=0.
+            b_q_bep(i,kts:kte,j)=0.
+         end do
+         end do
+          
+       CALL BEP_BEM(frc_urb2d,utype_urb2d,itimestep,dz8w,dt,u_phy,v_phy, &
+                th_phy,rho,p_phy,swdown,glw,                           &
+                gmt,julday,xlong,xlat,declin_urb,cosz_urb2d,omg_urb2d, &
+                num_urban_layers,                                      &
+                trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,               &
+                tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,       &
+                tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,       &
+                cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,                 &
+                sfwin1_urb3d,sfwin2_urb3d,                             &
+                sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,             &
+                a_u_bep,a_v_bep,a_t_bep,                               &
+                a_e_bep,b_u_bep,b_v_bep,                               &
+                b_t_bep,b_e_bep,b_q_bep,dlg_bep,                       &
+                dl_u_bep,sf_bep,vl_bep,                                &
+                rl_up_urb,rs_abs_urb,emiss_urb,grdflx_urb,qv3d,        &
+                ids,ide, jds,jde, kds,kde,                             &
+                ims,ime, jms,jme, kms,kme,                             &
+                its,ite, jts,jte, kts,kte )
+
+       ENDIF
+
+    if((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then         !Bep begin
+! fix the value of the Stefan-Boltzmann constant
+         sigma_sb=5.67e-08
+         do j=jts,jte
+         do i=its,ite
+            UMOM_URB(I,J)=0.
+            VMOM_URB(I,J)=0.
+            HFX_URB(I,J)=0.
+            QFX_URB(I,J)=0.
+         do k=kts,kte
+            a_u_bep(i,k,j)=a_u_bep(i,k,j)*frc_urb2d(i,j)
+            a_v_bep(i,k,j)=a_v_bep(i,k,j)*frc_urb2d(i,j)
+            a_t_bep(i,k,j)=a_t_bep(i,k,j)*frc_urb2d(i,j)
+            a_q_bep(i,k,j)=0.        
+            a_e_bep(i,k,j)=0.
+            b_u_bep(i,k,j)=b_u_bep(i,k,j)*frc_urb2d(i,j)
+            b_v_bep(i,k,j)=b_v_bep(i,k,j)*frc_urb2d(i,j)
+            b_t_bep(i,k,j)=b_t_bep(i,k,j)*frc_urb2d(i,j)
+            b_q_bep(i,k,j)=b_q_bep(i,k,j)*frc_urb2d(i,j)
+            b_e_bep(i,k,j)=b_e_bep(i,k,j)*frc_urb2d(i,j)
+            HFX_URB(I,J)=HFX_URB(I,J)+B_T_BEP(I,K,J)*RHO(I,K,J)*CP*                &
+                          DZ8W(I,K,J)*VL_BEP(I,K,J)
+            QFX_URB(I,J)=QFX_URB(I,J)+B_Q_BEP(I,K,J)*               &
+                          DZ8W(I,K,J)*VL_BEP(I,K,J)
+            UMOM_URB(I,J)=UMOM_URB(I,J)+ (A_U_BEP(I,K,J)*U_PHY(I,K,J)+             &
+                          B_U_BEP(I,K,J))*DZ8W(I,K,J)*VL_BEP(I,K,J)
+            VMOM_URB(I,J)=VMOM_URB(I,J)+ (A_V_BEP(I,K,J)*V_PHY(I,K,J)+             &
+                          B_V_BEP(I,K,J))*DZ8W(I,K,J)*VL_BEP(I,K,J)
+            vl_bep(i,k,j)=(1.-frc_urb2d(i,j))+vl_bep(i,k,j)*frc_urb2d(i,j)
+            sf_bep(i,k,j)=(1.-frc_urb2d(i,j))+sf_bep(i,k,j)*frc_urb2d(i,j)
+         end do
+            a_u_bep(i,1,j)=(1.-frc_urb2d(i,j))*(-ust(I,J)*ust(I,J))/dz8w(i,1,j)/   &
+                           ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+a_u_bep(i,1,j)
+            a_v_bep(i,1,j)=(1.-frc_urb2d(i,j))*(-ust(I,J)*ust(I,J))/dz8w(i,1,j)/   &
+                           ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+a_v_bep(i,1,j)
+            b_t_bep(i,1,j)=(1.-frc_urb2d(i,j))*hfx_rural(i,j)/dz8w(i,1,j)/rho(i,1,j)/CP+ &
+                            b_t_bep(i,1,j)
+            b_q_bep(i,1,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)/dz8w(i,1,j)/rho(i,1,j)+b_q_bep(i,1,j)
+            umom=(1.-frc_urb2d(i,j))*ust(i,j)*ust(i,j)*u_phy(i,1,j)/               &
+                         ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+umom_urb(i,j)
+            vmom=(1.-frc_urb2d(i,j))*ust(i,j)*ust(i,j)*v_phy(i,1,j)/               &
+                         ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+vmom_urb(i,j)
+            sf_bep(i,1,j)=1.
+           
+! compute upward longwave radiation from the rural part and total
+!           rl_up_rural=-emiss_rural(i,j)*sigma_sb*(tsk_rural(i,j)**4.)-(1.-emiss_rural(i,j))*glw(i,j)
+!           rl_up_tot=(1.-frc_urb2d(i,j))*rl_up_rural+frc_urb2d(i,j)*rl_up_urb(i,j)   
+!           emiss(i,j)=(1.-frc_urb2d(i,j))*emiss_rural(i,j)+frc_urb2d(i,j)*emiss_urb(i,j)
+! using the emissivity and the total longwave upward radiation estimate the averaged skin temperature
+           IF (FRC_URB2D(I,J).GT.0.) THEN
+              rl_up_rural=-emiss_rural(i,j)*sigma_sb*(tsk_rural(i,j)**4.)-(1.-emiss_rural(i,j))*glw(i,j)
+              rl_up_tot=(1.-frc_urb2d(i,j))*rl_up_rural+frc_urb2d(i,j)*rl_up_urb(i,j)   
+              emiss(i,j)=(1.-frc_urb2d(i,j))*emiss_rural(i,j)+frc_urb2d(i,j)*emiss_urb(i,j)
+              ts_urb2d(i,j)=(max(0.,(-rl_up_urb(i,j)-(1.-emiss_urb(i,j))*glw(i,j))/emiss_urb(i,j)/sigma_sb))**0.25
+              tsk(i,j)=(max(0., (-1.*rl_up_tot-(1.-emiss(i,j))*glw(i,j) )/emiss(i,j)/sigma_sb))**.25
+           rs_abs_tot=(1.-frc_urb2d(i,j))*swdown(i,j)*(1.-albedo(i,j))+frc_urb2d(i,j)*rs_abs_urb(i,j)  
+          if(swdown(i,j).gt.0.)then
+           albedo(i,j)=1.-rs_abs_tot/swdown(i,j)
+          else
+           albedo(i,j)=alb_rural(i,j)
+          endif
+! rename *_urb to sh_urb2d,lh_urb2d,g_urb2d,rn_urb2d
+         grdflx(i,j)= (1.-frc_urb2d(i,j))*grdflx_rural(i,j)+frc_urb2d(i,j)*grdflx_urb(i,j) 
+         qfx(i,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)+qfx_urb(i,j)
+!        lh(i,j)=(1.-frc_urb2d(i,j))*qfx_rural(i,j)*xlv
+         lh(i,j)=qfx(i,j)*xlv
+         HFX(I,J) = HFX_URB(I,J)+(1-FRC_URB2D(I,J))*HFX_RURAL(I,J)         ![W/m/m]
+            SH_URB2D(I,J)    = HFX_URB(I,J)/FRC_URB2D(I,J)
+            LH_URB2D(I,J)    = qfx_urb(i,j)*xlv
+            G_URB2D(I,J)     = grdflx_urb(i,j)
+            RN_URB2D(I,J)    = rs_abs_urb(i,j)+emiss_urb(i,j)*glw(i,j)-rl_up_urb(i,j)
+            ust(i,j)=(umom**2.+vmom**2.)**.25
+!          if(tsk(i,j).gt.350)write(*,*)'tsk too big!',i,j,tsk(i,j)
+!          if(tsk(i,j).lt.260)write(*,*)'tsk too small!',i,j,tsk(i,j),rl_up_tot,rl_up_urb(i,j),rl_up_rural
+!                    print*,'ivgtyp,i,j,sigma_sb',ivgtyp(i,j),i,j,sigma_sb
+!                    print*,'hfx,lh,qfx,grdflx,ts_urb2d',hfx(i,j),lh(i,j),qfx(i,j),grdflx(i,j),ts_urb2d(i,j)
+!                    print*,'tsk,albedo,emiss',tsk(i,j),albedo(i,j),emiss(i,j)
+!                if(i.eq.56.and.j.eq.29)then
+!                    print*,'ivgtyp, qfx, hfx',ivgtyp(i,j),hfx_rural(i,j),qfx_rural(i,j)
+!                    print*,'emiss_rural,emiss_urb',emiss_rural(i,j),emiss_urb(i,j)
+!                    print*,'rl_up_rural,rl_up_urb(i,j)',rl_up_rural,rl_up_urb(i,j)
+!                    print*,'tsk_rural,ts_urb2d(i,j),tsk',tsk_rural(i,j),ts_urb2d(i,j),tsk(i,j)
+!                    print*,'reconstruction fei',((emiss(i,j)*tsk(i,j)**4.-frc_urb2d(i,j)*emiss_urb(i,j)*ts_urb2d(i,j)**4.)/(emiss_rural(i,j)*(1.-frc_urb2d(i,j))))**.25
+!                    print*,'ivgtyp,hfx,hfx_urb,hfx_rural',hfx(i,j),hfx_urb(i,j),hfx_rural(i,j)
+!                    print*,'lh,lh_rural',lh(i,j),lh_rural(i,j)
+!                    print*,'qfx',qfx(i,j)
+!                    print*,'ts_urb2d',ts_urb2d(i,j)
+!                    print*,'ust',ust(i,j)
+!                    print*,'swdown,glw',swdown(i,j),glw(i,j)
+!                endif
+            else
+              SH_URB2D(I,J)    = 0.
+              LH_URB2D(I,J)    = 0.
+              G_URB2D(I,J)     = 0.
+              RN_URB2D(I,J)    = 0.
+            endif
+!          IF( IVGTYP(I,J) == 1 .or. IVGTYP(I,J) == 31 .or. &
+!                  IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN
+!                    print*,'ivgtyp, qfx, hfx',ivgtyp(i,j),hfx_rural(i,j),qfx_rural(i,j)
+!                    print*,'ivgtyp,hfx,hfx_urb,hfx_rural',hfx(i,j),hfx_urb(i,j),hfx_rural(i,j)
+!                    print*,'lh,lh_rural',lh(i,j),lh_rural(i,j)
+!                    print*,'qfx',qfx(i,j)
+!                    print*,'ts_urb2d',ts_urb2d(i,j)
+!                    print*,'ust',ust(i,j)
+!          endif
+        enddo
+        enddo
+
+
+       endif                                                           !Bep end
+
+!------------------------------------------------------
+   END SUBROUTINE lsm
+!------------------------------------------------------
+
+  SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV,    &
+                     SMSTOT, SFCRUNOFF,UDRUNOFF,ACSNOW,        &
+                     ACSNOM,IVGTYP,ISLTYP,TSLB,SMOIS,SH2O,ZS,DZS, &
+                     MMINLU,                                   &
+                     SNOALB, FNDSOILW, FNDSNOWH, RDMAXALB,     &
+                     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, &
+                                                        SNOALB, &
+                                                        CANWAT, &
+                                                        SMSTAV, &
+                                                        SMSTOT, &
+                                                     SFCRUNOFF, &
+                                                      UDRUNOFF, &
+                                                        ACSNOW, &
+                                                        VEGFRA, &
+                                                        ACSNOM
+
+   INTEGER, DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(IN)       ::                         IVGTYP, &
+                                                        ISLTYP
+   CHARACTER(LEN=*),  INTENT(IN)      ::                MMINLU
+
+   LOGICAL, INTENT(IN)       ::                      FNDSOILW , &
+                                                     FNDSNOWH
+   LOGICAL, INTENT(IN)       ::                      RDMAXALB
+
+
+   INTEGER                   :: L
+   REAL                      :: BX, SMCMAX, PSISAT, FREE
+   REAL, PARAMETER           :: BLIM = 5.5, HLICE = 3.335E5,    &
+                                GRAV = 9.81, T0 = 273.15
+   INTEGER                   :: errflag
+
+   character*256 :: MMINSL
+        MMINSL='STAS'
+!
+
+! initialize three Noah LSM related tables
+   IF ( allowed_to_read ) THEN
+     CALL wrf_message( 'INITIALIZE THREE Noah LSM RELATED TABLES' )
+     CALL  SOIL_VEG_GEN_PARM( MMINLU, MMINSL )
+   ENDIF
+
+#ifdef WRF_CHEM
+!
+! need this parameter for dust parameterization in wrf/chem
+!
+   do I=1,NSLTYPE
+      porosity(i)=maxsmc(i)
+   enddo
+#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
+       IF(.not.RDMAXALB) THEN
+          SNOALB(i,j)=MAXALB(IVGTYP(i,j))*0.01
+       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 SOIL_VEG_GEN_PARM( MMINLU, MMINSL)
+!-----------------------------------------------------------------
+
+        USE module_wrf_error
+        IMPLICIT NONE
+
+        CHARACTER(LEN=*), INTENT(IN) :: MMINLU, MMINSL
+        integer :: LUMATCH, IINDEX, LC, NUM_SLOPE
+        integer :: ierr
+        INTEGER , PARAMETER :: OPEN_OK = 0
+
+        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
+
+
+        LUMATCH=0
+
+        FIND_LUTYPE : DO WHILE (LUMATCH == 0)
+           READ (19,*,END=2002)
+           READ (19,*,END=2002)LUTYPE
+           READ (19,*)LUCATS,IINDEX
+
+           IF(LUTYPE.EQ.MMINLU)THEN
+              WRITE( mess , * ) 'LANDUSE TYPE = ' // TRIM ( LUTYPE ) // ' FOUND', LUCATS,' CATEGORIES'
+              CALL wrf_message( mess )
+              LUMATCH=1
+           ELSE
+              call wrf_message ( "Skipping over LUTYPE = " // TRIM ( LUTYPE ) )
+              DO LC = 1, LUCATS+12
+                 read(19,*)
+              ENDDO
+           ENDIF
+        ENDDO FIND_LUTYPE
+! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008
+        IF ( SIZE(SHDTBL)       < LUCATS .OR. &
+             SIZE(NROTBL)       < LUCATS .OR. &
+             SIZE(RSTBL)        < LUCATS .OR. &
+             SIZE(RGLTBL)       < LUCATS .OR. &
+             SIZE(HSTBL)        < LUCATS .OR. &
+             SIZE(SNUPTBL)      < LUCATS .OR. &
+             SIZE(MAXALB)       < LUCATS .OR. &
+             SIZE(LAIMINTBL)    < LUCATS .OR. &
+             SIZE(LAIMAXTBL)    < LUCATS .OR. &
+             SIZE(Z0MINTBL)     < LUCATS .OR. &
+             SIZE(Z0MAXTBL)     < LUCATS .OR. &
+             SIZE(ALBEDOMINTBL) < LUCATS .OR. &
+             SIZE(ALBEDOMAXTBL) < LUCATS .OR. &
+             SIZE(EMISSMINTBL ) < LUCATS .OR. &
+             SIZE(EMISSMAXTBL ) < LUCATS ) THEN
+           CALL wrf_error_fatal('Table sizes too small for value of LUCATS in module_sf_noahdrv.F')
+        ENDIF
+
+        IF(LUTYPE.EQ.MMINLU)THEN
+          DO LC=1,LUCATS
+              READ (19,*)IINDEX,SHDTBL(LC),                        &
+                        NROTBL(LC),RSTBL(LC),RGLTBL(LC),HSTBL(LC), &
+                        SNUPTBL(LC),MAXALB(LC), LAIMINTBL(LC),     &
+                        LAIMAXTBL(LC),EMISSMINTBL(LC),             &
+                        EMISSMAXTBL(LC), ALBEDOMINTBL(LC),         &
+                        ALBEDOMAXTBL(LC), Z0MINTBL(LC), Z0MAXTBL(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
+          READ (19,*)
+          READ (19,*)NATURAL
+        ENDIF
+!
+ 2002   CONTINUE
+
+        CLOSE (19)
+        IF (LUMATCH == 0) then
+           CALL wrf_error_fatal ("Land Use Dataset '"//MMINLU//"' not found in VEGPARM.TBL.")
+        ENDIF
+      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    ( 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    ( LAIMINTBL    , NLUS )
+      CALL wrf_dm_bcast_real    ( LAIMAXTBL    , NLUS )
+      CALL wrf_dm_bcast_real    ( Z0MINTBL     , NLUS )
+      CALL wrf_dm_bcast_real    ( Z0MAXTBL     , NLUS )
+      CALL wrf_dm_bcast_real    ( EMISSMINTBL  , NLUS )
+      CALL wrf_dm_bcast_real    ( EMISSMAXTBL  , NLUS )
+      CALL wrf_dm_bcast_real    ( ALBEDOMINTBL , NLUS )
+      CALL wrf_dm_bcast_real    ( ALBEDOMAXTBL , 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 )
+      CALL wrf_dm_bcast_integer ( NATURAL , 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
+
+        WRITE(mess,*) 'INPUT SOIL TEXTURE CLASSIFICATION = ', TRIM ( MMINSL )
+        CALL wrf_message( mess )
+
+        LUMATCH=0
+
+        READ (19,*)
+        READ (19,2000,END=2003)SLTYPE
+ 2000   FORMAT (A4)
+        READ (19,*)SLCATS,IINDEX
+        IF(SLTYPE.EQ.MMINSL)THEN
+            WRITE( mess , * ) 'SOIL TEXTURE CLASSIFICATION = ', TRIM ( SLTYPE ) , ' FOUND', &
+                  SLCATS,' CATEGORIES'
+            CALL wrf_message ( mess )
+          LUMATCH=1
+        ENDIF
+! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008
+        IF ( SIZE(BB    ) < SLCATS .OR. &
+             SIZE(DRYSMC) < SLCATS .OR. &
+             SIZE(F11   ) < SLCATS .OR. &
+             SIZE(MAXSMC) < SLCATS .OR. &
+             SIZE(REFSMC) < SLCATS .OR. &
+             SIZE(SATPSI) < SLCATS .OR. &
+             SIZE(SATDK ) < SLCATS .OR. &
+             SIZE(SATDW ) < SLCATS .OR. &
+             SIZE(WLTSMC) < SLCATS .OR. &
+             SIZE(QTZ   ) < SLCATS  ) THEN
+           CALL wrf_error_fatal('Table sizes too small for value of SLCATS in module_sf_noahdrv.F')
+        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
+! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008
+          IF ( SIZE(slope_data) < NUM_SLOPE ) THEN
+            CALL wrf_error_fatal('NUM_SLOPE too large for slope_data array in module_sf_noahdrv')
+          ENDIF
+
+          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
+          READ (19,*)
+          READ (19,*)LVCOEF_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 )
+      CALL wrf_dm_bcast_real    ( LVCOEF_DATA  ,  1 )
+
+
+!-----------------------------------------------------------------
+      END SUBROUTINE SOIL_VEG_GEN_PARM
+!-----------------------------------------------------------------
+
+END MODULE module_sf_noahdrv
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_noahlsm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_noahlsm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_noahlsm.F	(revision 17)
@@ -0,0 +1,4451 @@
+MODULE module_sf_noahlsm
+  USE module_model_constants
+
+!   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,                             &
+                          EMISSI_S = 0.95
+
+! VEGETATION PARAMETERS
+        INTEGER :: LUCATS , BARE
+        INTEGER :: NATURAL
+        integer, PARAMETER :: NLUS=50
+        CHARACTER(LEN=256) LUTYPE
+        INTEGER, DIMENSION(1:NLUS) :: NROTBL
+        real, dimension(1:NLUS) ::  SNUPTBL, RSTBL, RGLTBL, HSTBL,                &
+                                    SHDTBL, MAXALB,                               &
+                                    EMISSMINTBL, EMISSMAXTBL,                     &
+                                    LAIMINTBL, LAIMAXTBL,                         &
+                                    Z0MINTBL, Z0MAXTBL,                           &
+                                    ALBEDOMINTBL, ALBEDOMAXTBL
+        REAL ::   TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA
+
+! SOIL PARAMETERS
+        INTEGER :: SLCATS
+        INTEGER, PARAMETER :: NSLTYPE=30
+        CHARACTER(LEN=256) 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
+        REAL ::  LVCOEF_DATA
+
+        CHARACTER*256  :: err_message
+
+!
+CONTAINS
+!
+
+      SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH,         &    !C
+                       LOCAL,                                           &    !L
+                       LLANDUSE, LSOIL,                                 &    !CL
+                       LWDN,SOLDN,SOLNET,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, EMBRD,      &    !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,SMAV,                             &    !D
+                       RDLAI2D,USEMONALB,                               &
+                       SNOTIME1,                                        &
+                       RIBB,                                            &
+                       SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT)                    !P
+! ----------------------------------------------------------------------
+! SUBROUTINE SFLX - UNIFIED NOAHLSM VERSION 1.0 JULY 2007
+! ----------------------------------------------------------------------
+! 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 (NO ICE), --1 LAND-ICE).
+!   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)
+!   SOLNET     NET DOWNWARD SOLAR RADIATION ((W M-2; POSITIVE)
+!   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)
+!   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)
+!   FFROZP     FRACTION OF FROZEN PRECIPITATION
+! ----------------------------------------------------------------------
+! 4. OTHER FORCING (INPUT) DATA (I):
+! ----------------------------------------------------------------------
+!   SFCSPD     WIND SPEED (M S-1) AT HEIGHT ZLVL ABOVE GROUND
+!   Q2SAT      SAT SPECIFIC HUMIDITY 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
+!
+!   EMBRD      Background surface emissivity (between 0 and 1)
+!   EMISSI     Surface emissivity (between 0 and 1)
+! ----------------------------------------------------------------------
+! 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
+!   SMAV       Soil Moisture Availability for each layer, as a fraction 
+!              between SMCWLT and SMCMAX.
+!  Documentation for SNOTIME1 and SNOABL2 ?????
+!  What categories of arguments do these variables fall into ????
+!  Documentation for RIBB ?????
+!  What category of argument does RIBB fall into ?????
+! ----------------------------------------------------------------------
+! 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=256), INTENT(IN)::  LLANDUSE, LSOIL
+
+! ----------------------------------------------------------------------
+! 1. CONFIGURATION INFORMATION (C):
+! ----------------------------------------------------------------------
+      INTEGER,INTENT(IN) ::  ICE,NSOIL,SLOPETYP,SOILTYP,VEGTYP
+      INTEGER, INTENT(IN) :: ISURBAN
+      INTEGER,INTENT(OUT)::  NROOT
+      INTEGER  KZ, K, iout
+
+! ----------------------------------------------------------------------
+! 2. LOGICAL:
+! ----------------------------------------------------------------------
+      LOGICAL, INTENT(IN) :: RDLAI2D
+      LOGICAL, INTENT(IN) :: USEMONALB
+
+      REAL, INTENT(IN)   :: SHDMIN,SHDMAX,DT,DQSDT2,LWDN,PRCP,PRCPRAIN,     &
+                            Q2,Q2SAT,SFCPRS,SFCSPD,SFCTMP, SNOALB,          &
+                            SOLDN,SOLNET,TBOT,TH2,ZLVL,                            &
+                            FFROZP
+      REAL, INTENT(OUT)  :: EMBRD
+      REAL, INTENT(OUT)  :: ALBEDO
+      REAL, INTENT(INOUT):: COSZ, SOLARDIRECT,CH,CM,                        &
+                            CMC,SNEQV,SNCOVR,SNOWH,T1,XLAI,SHDFAC,Z0BRD,    &
+                            EMISSI, ALB
+      REAL, INTENT(INOUT):: SNOTIME1
+      REAL, INTENT(INOUT):: RIBB
+      REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SLDPTH
+      REAL, DIMENSION(1:NSOIL), INTENT(OUT):: ET
+      REAL, DIMENSION(1:NSOIL), INTENT(OUT):: SMAV
+      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
+        REAL ::  LVCOEF
+      REAL :: INTERP_FRACTION
+      REAL :: LAIMIN,    LAIMAX
+      REAL :: ALBEDOMIN, ALBEDOMAX
+      REAL :: EMISSMIN,  EMISSMAX
+      REAL :: Z0MIN,     Z0MAX
+
+! ----------------------------------------------------------------------
+! 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 / LAND-ICE / ICE-FREE LAND
+!     SEA-ICE CASE,          ICE =  1
+!     NON-GLACIAL LAND,      ICE =  0
+!     GLACIAL-ICE LAND,      ICE = -1
+      IF (ICE /= 0) SHDFAC = 0.0
+! ----------------------------------------------------------------------
+! 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
+         END IF
+! ----------------------------------------------------------------------
+! 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,CZIL,              &
+                         LAIMIN, LAIMAX, EMISSMIN, EMISSMAX, ALBEDOMIN,    &
+                         ALBEDOMAX, Z0MIN, Z0MAX, CSOIL, PTU, LLANDUSE,    &
+                         LSOIL,LOCAL,LVCOEF)
+
+!urban
+         IF(VEGTYP==ISURBAN)THEN
+              SHDFAC=0.05
+              RSMIN=400.0
+              SMCMAX = 0.45
+              SMCREF = 0.42
+              SMCWLT = 0.40
+              SMCDRY = 0.40
+         ENDIF
+
+         IF ( SHDFAC >= SHDMAX ) THEN
+            EMBRD = EMISSMAX
+            IF (.NOT. RDLAI2D) THEN
+               XLAI  = LAIMAX
+            ENDIF
+            IF (.NOT. USEMONALB) THEN
+               ALB   = ALBEDOMIN
+            ENDIF
+            Z0BRD = Z0MAX
+         ELSE IF ( SHDFAC <= SHDMIN ) THEN
+            EMBRD = EMISSMIN
+            IF(.NOT. RDLAI2D) THEN
+               XLAI  = LAIMIN
+            ENDIF
+            IF(.NOT. USEMONALB) then
+               ALB   = ALBEDOMAX
+            ENDIF
+            Z0BRD = Z0MIN
+         ELSE
+
+            IF ( SHDMAX > SHDMIN ) THEN
+
+               INTERP_FRACTION = ( SHDFAC - SHDMIN ) / ( SHDMAX - SHDMIN )
+               ! Bound INTERP_FRACTION between 0 and 1
+               INTERP_FRACTION = MIN ( INTERP_FRACTION, 1.0 )
+               INTERP_FRACTION = MAX ( INTERP_FRACTION, 0.0 )
+               ! Scale Emissivity and LAI between EMISSMIN and EMISSMAX by INTERP_FRACTION
+               EMBRD = ( ( 1.0 - INTERP_FRACTION ) * EMISSMIN  ) + ( INTERP_FRACTION * EMISSMAX  )
+               IF (.NOT. RDLAI2D) THEN
+                  XLAI  = ( ( 1.0 - INTERP_FRACTION ) * LAIMIN    ) + ( INTERP_FRACTION * LAIMAX    )
+               ENDIF
+               if (.not. USEMONALB) then
+                  ALB   = ( ( 1.0 - INTERP_FRACTION ) * ALBEDOMAX ) + ( INTERP_FRACTION * ALBEDOMIN )
+               endif
+               Z0BRD = ( ( 1.0 - INTERP_FRACTION ) * Z0MIN     ) + ( INTERP_FRACTION * Z0MAX     )
+
+            ELSE
+
+               EMBRD = 0.5 * EMISSMIN  + 0.5 * EMISSMAX
+               IF (.NOT. RDLAI2D) THEN
+                  XLAI  = 0.5 * LAIMIN    + 0.5 * LAIMAX
+               ENDIF
+               if (.not. USEMONALB) then
+                  ALB   = 0.5 * ALBEDOMIN + 0.5 * ALBEDOMAX
+               endif
+               Z0BRD = 0.5 * Z0MIN     + 0.5 * Z0MAX
+
+            ENDIF
+
+         ENDIF
+! ----------------------------------------------------------------------
+!  INITIALIZE PRECIPITATION LOGICALS.
+! ----------------------------------------------------------------------
+         SNOWNG = .FALSE.
+         FRZGRA = .FALSE.
+
+! ----------------------------------------------------------------------
+! OVER SEA-ICE OR GLACIAL-ICE, IF S.W.E. (SNEQV) BELOW THRESHOLD LOWER
+! BOUND (0.01 M FOR SEA-ICE, 0.10 M FOR GLACIAL-ICE), THEN SET AT LOWER
+! BOUND
+! ----------------------------------------------------------------------
+! IF SEA-ICE CASE, ASSIGN DEFAULT WATER-EQUIV SNOW ON TOP
+! ----------------------------------------------------------------------
+         IF (ICE == 1) THEN
+            ! Sea-ice case
+            IF ( SNEQV < 0.01 ) THEN
+               SNEQV = 0.01
+               SNOWH = 0.05
+            ENDIF
+         ELSE IF ( ICE == -1 ) THEN
+            ! Land-ice case
+            IF ( SNEQV < 0.10 ) THEN
+               SNEQV = 0.10
+               SNOWH = 0.50
+            ENDIF
+         END IF
+! ----------------------------------------------------------------------
+! FOR SEA-ICE AND GLACIAL-ICE CASES, SET SMC AND SH20 VALUES = 1.0
+! ----------------------------------------------------------------------
+         IF ( ICE /= 0 ) THEN
+            DO KZ = 1,NSOIL
+               SMC(KZ) = 1.0
+               SH2O(KZ) = 1.0
+            END DO
+         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 <= 1.E-7 ) THEN ! safer IF	kmh (2008/03/25)
+            SNEQV = 0.0
+            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
+! snow defined when fraction of frozen precip (FFROZP) > 0.5,
+! passed in from model microphysics.
+            IF (FFROZP .GT. 0.5) 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
+            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)
+!
+! kmh 09/04/2006 set Snow Density at 0.2 g/cm**3
+! for "cold permanent ice" or new "dry" snow
+!
+           IF ( (ICE /= 0) .and. SNCOVR .GT. 0.99 ) THEN
+!  if soil temperature less than 268.15 K, treat as typical Antarctic/Greenland snow firn
+              IF ( STC(1) .LT. (TFREEZ - 5.) ) SNDENS = 0.2
+              IF ( SNOWNG .AND. (T1.LT.273.) .AND. (SFCTMP.LT.273.) ) SNDENS=0.2
+           ENDIF
+!
+            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)
+! ----------------------------------------------------------------------
+         ELSE
+            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 .OR. ICE == -1) THEN
+            IF (SNEQV  == 0.0) THEN
+               SNCOVR = 0.0
+               ALBEDO = ALB
+               EMISSI = EMBRD
+            ELSE
+! ----------------------------------------------------------------------
+! DETERMINE SNOW FRACTIONAL COVERAGE.
+! DETERMINE SURFACE ALBEDO MODIFICATION DUE TO SNOWDEPTH STATE.
+! ----------------------------------------------------------------------
+              CALL SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR)
+!   Don't limit snow cover fraction over permanent ice kmh 2008/03/25
+            if ( ICE == 0 ) then
+              SNCOVR = MIN(SNCOVR,0.98)
+            endif
+              CALL ALCALC (ALB,SNOALB,EMBRD,SHDFAC,SHDMIN,SNCOVR,T1,ALBEDO,EMISSI,   &
+                         DT,SNOWNG,SNOTIME1,LVCOEF)
+            END IF
+! ----------------------------------------------------------------------
+! SNOW COVER, ALBEDO OVER SEA-ICE, GLACIAL ICE
+! ----------------------------------------------------------------------
+         ELSE
+            SNCOVR = 1.0
+!
+! Albedo of sea ice
+!
+! This value should vary seasonally. 0.65 may be good for Arctic Ocean summer bare ice
+!   value could be as low as 0.4 for Arctic bare ice and melt pond combo (Perovich data)
+!   0.82 may be good for Arctic spring/fall sea ice (Perovich data)
+!   0.81 may be good for Antarctic sea ice (Wendler et al. December cruise data)
+!
+            ALBEDO = 0.80
+!
+            EMISSI = 0.98
+         END IF
+! ----------------------------------------------------------------------
+! THERMAL CONDUCTIVITY FOR SEA-ICE CASE, GLACIAL-ICE CASE
+! ----------------------------------------------------------------------
+         IF ( (ICE == 1) .or. (ICE == -1) ) THEN
+            DF1 = 2.2
+!
+! kmh 09/03/2006
+! kmh 03/25/2008  change SNCOVR threshold to 0.97
+!
+! only apply (small) DF1 conductivity for permanent land ice
+            IF ( (ICE == -1) ) THEN
+               IF (  SNCOVR .GT. 0.97 ) THEN
+                  DF1 = SNCOND
+               ENDIF
+            ENDIF
+!
+         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
+            IF ( VEGTYP == ISURBAN ) DF1=3.24
+
+            DF1 = DF1 * EXP (SBETA * SHDFAC)
+!
+! kmh 09/03/2006
+! kmh 03/25/2008  change SNCOVR threshold to 0.97
+!
+            IF (  SNCOVR .GT. 0.97 ) THEN
+               DF1 = SNCOND
+            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
+! ----------------------------------------------------------------------
+         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)
+! 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)
+            IF ( ICE /= 0 ) then
+               !  kmh  12/15/2005  correct for too deep snow layer
+               !  kmh  09/03/2006  adjust DTOT
+               IF ( DTOT .GT. 2.*DSOIL ) then
+                  DTOT = 2.*DSOIL
+               ENDIF
+            ENDIF
+            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,SNOWH)
+         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
+         FDOWN =  SOLNET + 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,          &
+!
+! kmh 01/09/2007 add T1,ICE,SNCOVR to call
+!
+                         DQSDT2,FLX2,EMISSI,SNEQV,T1,ICE,SNCOVR)
+!
+! ----------------------------------------------------------------------
+! CALL CANRES TO CALCULATE THE CANOPY RESISTANCE AND CONVERT IT INTO PC
+! IF NONZERO GREENNESS FRACTION
+! ----------------------------------------------------------------------
+
+! ----------------------------------------------------------------------
+!  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)
+         ELSE
+            RC = 0.0
+         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,ISURBAN)
+            ETA_KINEMATIC = ETA
+         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, &
+                         RIBB,SOLDN,                                     &
+                         ISURBAN,                                        &
+                         VEGTYP)
+            ETA_KINEMATIC =  ESNOW + ETNS
+         END IF
+
+!     Calculate effective mixing ratio at grnd level (skin)
+!
+!     Q1=Q2+ETA*CP/RCH
+     Q1=Q2+ETA_KINEMATIC*CP/RCH
+!
+! ----------------------------------------------------------------------
+! DETERMINE SENSIBLE HEAT (H) IN ENERGY UNITS (W M-2)
+! ----------------------------------------------------------------------
+         SHEAT = - (CH * CP * SFCPRS)/ (R * T2V) * ( TH2- T1 )
+
+! ----------------------------------------------------------------------
+! CONVERT EVAP TERMS FROM KINEMATIC (KG M-2 S-1) TO ENERGY UNITS (W M-2)
+! ----------------------------------------------------------------------
+      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
+! ----------------------------------------------------------------------
+! DETERMINE BETA (RATIO OF ACTUAL TO POTENTIAL EVAP)
+! ----------------------------------------------------------------------
+      IF (ETP == 0.0) THEN
+        BETA = 0.0
+      ELSE
+        BETA = ETA/ETP
+      ENDIF
+
+! ----------------------------------------------------------------------
+! 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
+
+! ----------------------------------------------------------------------
+!  FOR THE CASE OF LAND (BUT NOT GLACIAL-ICE):
+!  CONVERT RUNOFF3 (INTERNAL LAYER RUNOFF FROM SUPERSAT) FROM M TO M S-1
+!  AND ADD TO SUBSURFACE RUNOFF/DRAINAGE/BASEFLOW.  RUNOFF2 IS ALREADY
+!  A RATE AT THIS POINT
+! ----------------------------------------------------------------------
+         IF (ICE == 0) THEN
+            RUNOFF3 = RUNOFF3/ DT
+            RUNOFF2 = RUNOFF2+ RUNOFF3
+            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 = 1,NSOIL
+               SMAV(K)=(SMC(K) - SMCWLT)/(SMCMAX - SMCWLT)
+            END DO
+
+            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
+! ----------------------------------------------------------------------
+! FOR THE CASE OF SEA-ICE (ICE=1) OR GLACIAL-ICE (ICE=-1), ADD ANY
+! SNOWMELT DIRECTLY TO SURFACE RUNOFF (RUNOFF1) SINCE THERE IS NO
+! SOIL MEDIUM, AND THUS NO CALL TO SUBROUTINE SMFLX (FOR SOIL MOISTURE
+! TENDENCY).
+! ----------------------------------------------------------------------
+            RUNOFF1 = SNOMLT/DT
+           SOILWM = 0.0
+           SOILW  = 0.0
+           SOILM  = 0.0
+           DO K = 1,NSOIL
+             SMAV(K)= 1.0
+           END DO
+         END IF
+
+! ----------------------------------------------------------------------
+  END SUBROUTINE SFLX
+! ----------------------------------------------------------------------
+
+      SUBROUTINE ALCALC (ALB,SNOALB,EMBRD,SHDFAC,SHDMIN,SNCOVR,TSNOW,ALBEDO,EMISSI,   &
+                         DT,SNOWNG,SNOTIME1,LVCOEF)
+
+! ----------------------------------------------------------------------
+! 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, EMBRD, SHDFAC, SHDMIN, SNCOVR, TSNOW
+      REAL, INTENT(IN)  :: DT
+      LOGICAL, INTENT(IN) :: SNOWNG
+      REAL, INTENT(INOUT):: SNOTIME1
+      REAL, INTENT(OUT) ::  ALBEDO, EMISSI
+      REAL              :: SNOALB2
+      REAL              :: TM,SNOALB1
+      REAL, INTENT(IN)  :: LVCOEF
+      REAL, PARAMETER   :: SNACCA=0.94,SNACCB=0.58,SNTHWA=0.82,SNTHWB=0.46
+! turn of vegetation effect
+!      ALBEDO = ALB + (1.0- (SHDFAC - SHDMIN))* SNCOVR * (SNOALB - ALB)
+!      ALBEDO = (1.0-SNCOVR)*ALB + SNCOVR*SNOALB !this is equivalent to below
+      ALBEDO = ALB + SNCOVR*(SNOALB-ALB)
+      EMISSI = EMBRD + SNCOVR*(EMISSI_S - EMBRD)
+
+!     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)
+!              SNOALB1=0.5*((0.9-0.2*(TM**3))+(0.8-0.16*(TM**3)))
+!            ELSE
+!              SNOALB1=0.67
+!             IF(SNCOVR.GT.0.95) SNOALB1= 0.6
+!             SNOALB1 = ALB + SNCOVR*(SNOALB-ALB)
+!            ENDIF
+!          ENDIF
+!            ALBEDO = ALB + SNCOVR*(SNOALB1-ALB)
+
+!     ISBA FORMULATION (VERSEGHY, 1991; BAKER ET AL., 1990)
+!          SNOALB1 = SNOALB+COEF*(0.85-SNOALB)
+!          SNOALB2=SNOALB1
+!!m          LSTSNW=LSTSNW+1
+!          SNOTIME1 = SNOTIME1 + DT
+!          IF (SNOWNG) THEN
+!             SNOALB2=SNOALB
+!!m             LSTSNW=0
+!             SNOTIME1 = 0.0
+!          ELSE
+!            IF (TSNOW.LT.273.16) THEN
+!!              SNOALB2=SNOALB-0.008*LSTSNW*DT/86400
+!!m              SNOALB2=SNOALB-0.008*SNOTIME1/86400
+!              SNOALB2=(SNOALB2-0.65)*EXP(-0.05*DT/3600)+0.65
+!!              SNOALB2=(ALBEDO-0.65)*EXP(-0.01*DT/3600)+0.65
+!            ELSE
+!              SNOALB2=(SNOALB2-0.5)*EXP(-0.0005*DT/3600)+0.5
+!!              SNOALB2=(SNOALB-0.5)*EXP(-0.24*LSTSNW*DT/86400)+0.5
+!!m              SNOALB2=(SNOALB-0.5)*EXP(-0.24*SNOTIME1/86400)+0.5
+!            ENDIF
+!          ENDIF
+!
+!!               print*,'SNOALB2',SNOALB2,'ALBEDO',ALBEDO,'DT',DT
+!          ALBEDO = ALB + SNCOVR*(SNOALB2-ALB)
+!          IF (ALBEDO .GT. SNOALB2) ALBEDO=SNOALB2
+!!m          LSTSNW1=LSTSNW
+!!          SNOTIME = SNOTIME1
+
+! formulation by Livneh
+! ----------------------------------------------------------------------
+! SNOALB IS CONSIDERED AS THE MAXIMUM SNOW ALBEDO FOR NEW SNOW, AT
+! A VALUE OF 85%. SNOW ALBEDO CURVE DEFAULTS ARE FROM BRAS P.263. SHOULD
+! NOT BE CHANGED EXCEPT FOR SERIOUS PROBLEMS WITH SNOW MELT.
+! TO IMPLEMENT ACCUMULATIN PARAMETERS, SNACCA AND SNACCB, ASSERT THAT IT
+! IS INDEED ACCUMULATION SEASON. I.E. THAT SNOW SURFACE TEMP IS BELOW
+! ZERO AND THE DATE FALLS BETWEEN OCTOBER AND FEBRUARY
+! ----------------------------------------------------------------------
+         SNOALB1 = SNOALB+LVCOEF*(0.85-SNOALB)
+         SNOALB2=SNOALB1
+! ---------------- Initial LSTSNW --------------------------------------
+          IF (SNOWNG) THEN
+             SNOTIME1 = 0.
+          ELSE
+           SNOTIME1=SNOTIME1+DT
+!               IF (TSNOW.LT.273.16) THEN
+                   SNOALB2=SNOALB1*(SNACCA**((SNOTIME1/86400.0)**SNACCB))
+!               ELSE
+!                  SNOALB2 =SNOALB1*(SNTHWA**((SNOTIME1/86400.0)**SNTHWB))
+!               ENDIF
+          ENDIF
+!
+           SNOALB2 = MAX ( SNOALB2, ALB )
+           ALBEDO = ALB + SNCOVR*(SNOALB2-ALB)
+           IF (ALBEDO .GT. SNOALB2) ALBEDO=SNOALB2
+
+!          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
+! double snow thermal conductivity
+      SNCOND = 2.0 * 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
+
+! ----------------------------------------------------------------------
+! 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,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 FAC2MIT(SMCMAX,FLIMIT)
+    IMPLICIT NONE		
+    REAL, INTENT(IN)  :: SMCMAX
+    REAL, INTENT(OUT) :: FLIMIT
+
+    FLIMIT = 0.90
+
+    IF ( SMCMAX == 0.395 ) THEN
+       FLIMIT = 0.59
+    ELSE IF ( ( SMCMAX == 0.434 ) .OR. ( SMCMAX == 0.404 ) ) THEN
+       FLIMIT = 0.85
+    ELSE IF ( ( SMCMAX == 0.465 ) .OR. ( SMCMAX == 0.406 ) ) THEN
+       FLIMIT = 0.86
+    ELSE IF ( ( SMCMAX == 0.476 ) .OR. ( SMCMAX == 0.439 ) ) THEN
+       FLIMIT = 0.74
+    ELSE IF ( ( SMCMAX == 0.200 ) .OR. ( SMCMAX == 0.464 ) ) THEN
+       FLIMIT = 0.80
+    ENDIF
+
+! ----------------------------------------------------------------------
+  END SUBROUTINE FAC2MIT
+! ----------------------------------------------------------------------
+
+      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,ISURBAN)
+
+! ----------------------------------------------------------------------
+! 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, INTENT(IN)  :: ISURBAN
+      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 == ISURBAN ) 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 == ISURBAN ) 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 == ISURBAN ) 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) = - DF1K * 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,TBOT,ICE,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 (ICE=1) OR GLACIAL
+! ICE (ICE=-1). COMPUTE (PREPARE) THE MATRIX COEFFICIENTS FOR THE
+! TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME.
+!
+! (NOTE:  THIS SUBROUTINE ONLY CALLED FOR SEA-ICE OR GLACIAL ICE, BUT
+! NOT FOR NON-GLACIAL LAND (ICE = 0).
+! ----------------------------------------------------------------------
+      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,                     INTENT(IN) :: TBOT
+      INTEGER,                  INTENT(IN) :: ICE
+      REAL                   :: DDZ,DDZ2,DENOM,DTSDZ,DTSDZ2,SSOIL,       &
+                                ZBOT
+      REAL                   :: HCPCT
+      REAL :: DF1K
+      REAL :: DF1N
+      REAL :: ZMD
+
+! ----------------------------------------------------------------------
+! SET A NOMINAL UNIVERSAL VALUE OF THE SEA-ICE SPECIFIC HEAT CAPACITY,
+! HCPCT = 1880.0*917.0.
+! ----------------------------------------------------------------------
+      IF ( ICE == 1 ) THEN
+         ! Sea-ice values
+         HCPCT = 1.72396E+6
+      ELSEIF (ICE == -1) THEN
+! SET A NOMINAL UNIVERSAL VALUE OF GLACIAL-ICE SPECIFIC HEAT CAPACITY,
+!   HCPCT = 2100.0*900.0 = 1.89000E+6 (SOURCE:  BOB GRUMBINE, 2005)
+!   TBOT PASSED IN AS ARGUMENT, VALUE FROM GLOBAL DATA SET
+         !
+         ! A least-squares fit for the four points provided by
+         ! Keith Hines for the Yen (1981) values for Antarctic
+         ! snow firn.
+         !
+         HCPCT = 1.E6 * (0.8194 - 0.1309*0.5*ZSOIL(1))
+         DF1K = DF1
+      ENDIF
+
+! ----------------------------------------------------------------------
+! 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
+! ----------------------------------------------------------------------
+      IF (ICE == 1) THEN
+         ZBOT = ZSOIL (NSOIL)
+      ELSE IF (ICE == -1) THEN
+         ZBOT = -25.0
+      ENDIF
+      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
+      DF1K = DF1
+      DF1N = DF1
+      DO K = 2,NSOIL
+
+       IF ( ICE == -1 ) THEN
+          ZMD = 0.5 * (ZSOIL(K)+ZSOIL(K-1))
+          ! For the land-ice case
+! kmh 09/03/2006 use Yen (1981)'s values for Antarctic snow firn
+!         IF ( K .eq. 2 ) HCPCT = 0.855108E6
+!         IF ( K .eq. 3 ) HCPCT = 0.922906E6
+!         IF ( K .eq. 4 ) HCPCT = 1.009986E6
+
+          ! Least squares fit to the four points supplied by Keith Hines
+          ! from Yen (1981) for Antarctic snow firn.  Not optimal, but
+          ! probably better than just a constant.
+          HCPCT = 1.E6 * ( 0.8194 - 0.1309*ZMD )
+
+!         IF ( K .eq. 2 ) DF1N = 0.345356
+!         IF ( K .eq. 3 ) DF1N = 0.398777
+!         IF ( K .eq. 4 ) DF1N = 0.472653
+
+          ! Least squares fit to the three points supplied by Keith Hines
+          ! from Yen (1981) for Antarctic snow firn.  Not optimal, but
+          ! probably better than just a constant.
+          DF1N = 0.32333 - ( 0.10073 * ZMD )
+       ENDIF
+! ----------------------------------------------------------------------
+! 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) = - DF1N * 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) = ( DF1N * DTSDZ2- DF1K * DTSDZ ) / DENOM
+         AI (K) = - DF1K * 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))
+         DF1K = DF1N
+         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,ISURBAN)
+
+! ----------------------------------------------------------------------
+! 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, INTENT(IN)  :: ISURBAN
+      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.
+! ----------------------------------------------------------------------
+
+         PRCP1 = PRCP1+ DEW
+         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
+         ETA = ETP
+         IF ( ETP < 0.0 ) THEN
+            BETA = 1.0
+         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 == ISURBAN ) 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 - 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,ISURBAN)
+
+! ----------------------------------------------------------------------
+! 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 = CPH2O * PRCP * (T1- SFCTMP)
+      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_IN,SNEQV,T1,ICE,SNCOVR)
+
+! ----------------------------------------------------------------------
+! 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_IN,SNEQV
+      REAL, INTENT(IN)        :: T1 , SNCOVR
+!
+! kmh 09/13/2006
+      INTEGER, INTENT(IN)     :: ICE
+! kmh 09/03/2006
+!
+      REAL, INTENT(OUT)       :: EPSCA,ETP,FLX2,RCH,RR,T24
+      REAL                    :: A, DELTA, FNET,RAD,RHO,EMISSI,ELCP1,LVS
+
+      REAL, PARAMETER      :: ELCP = 2.4888E+3, LSUBC = 2.501000E+6,CP = 1004.6
+      REAL, PARAMETER      :: LSUBS = 2.83E+6
+
+! ----------------------------------------------------------------------
+! EXECUTABLE CODE BEGINS HERE:
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! PREPARE PARTIAL QUANTITIES FOR PENMAN EQUATION.
+! ----------------------------------------------------------------------
+        EMISSI=EMISSI_IN
+        IF (ICE==0) THEN
+           ELCP1  = (1.0-SNCOVR)*ELCP  + SNCOVR*ELCP*LSUBS/LSUBC
+           LVS    = (1.0-SNCOVR)*LSUBC + SNCOVR*LSUBS
+        ELSE
+           IF ( T1 > 273.15 ) THEN
+              ELCP1=ELCP
+              LVS=LSUBC
+           ELSE
+              ELCP1  = ELCP*LSUBS/LSUBC
+              LVS    = LSUBS
+           ENDIF
+        ENDIF
+
+      FLX2 = 0.0
+!      DELTA = ELCP * DQSDT2
+      DELTA = ELCP1 * 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)
+      A = ELCP1 * (Q2SAT - Q2)
+      EPSCA = (A * RR + RAD * DELTA) / (DELTA + RR)
+!      ETP = EPSCA * RCH / LSUBC
+      ETP = EPSCA * RCH / LVS
+
+! ----------------------------------------------------------------------
+  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,CZIL,             &
+                         LAIMIN, LAIMAX, EMISSMIN, EMISSMAX, ALBEDOMIN,    &
+                         ALBEDOMAX, Z0MIN, Z0MAX, CSOIL, PTU, LLANDUSE,    &
+                         LSOIL, LOCAL,LVCOEF)
+
+      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=256), INTENT(IN)::  LLANDUSE, LSOIL
+
+! Veg parameters
+      INTEGER, INTENT(IN)    :: VEGTYP
+      INTEGER, INTENT(OUT)   :: NROOT
+      REAL, INTENT(INOUT)    :: SHDFAC
+      REAL, INTENT(OUT)      :: HS,RSMIN,RGL,SNUP,                          &
+                                CMCMAX,RSMAX,TOPT,                          &
+                                EMISSMIN,  EMISSMAX,                        &
+                                LAIMIN,    LAIMAX,                          &
+                                Z0MIN,     Z0MAX,                           &
+                                ALBEDOMIN, ALBEDOMAX
+! 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,    INTENT(OUT)   :: LVCOEF
+      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)
+      LVCOEF = LVCOEF_DATA
+
+! ----------------------------------------------------------------------
+! 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)
+      EMISSMIN  = EMISSMINTBL  (VEGTYP)
+      EMISSMAX  = EMISSMAXTBL  (VEGTYP)
+      LAIMIN    = LAIMINTBL    (VEGTYP)
+      LAIMAX    = LAIMAXTBL    (VEGTYP)
+      Z0MIN     = Z0MINTBL     (VEGTYP)
+      Z0MAX     = Z0MAXTBL     (VEGTYP)
+      ALBEDOMIN = ALBEDOMINTBL (VEGTYP)
+      ALBEDOMAX = ALBEDOMAXTBL (VEGTYP)
+
+               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,ISURBAN)
+
+! ----------------------------------------------------------------------
+! 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, ISURBAN
+      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, GLACIAL ICE CASE
+! ----------------------------------------------------------------------
+      IF ( ICE /= 0 ) THEN
+
+         CALL HRTICE (RHSTS,STC,TBOT,ICE,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,ISURBAN)
+
+         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
+      REAL :: FAC2
+      REAL :: FLIMIT
+
+! ----------------------------------------------------------------------
+! 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
+! ----------------------------------------------------------------------
+!  According to Dr. Ken Mitchell's suggestion, add the second contraint
+!  to remove numerical instability of runoff and soil moisture
+!  FLIMIT is a limit value for FAC2
+      FAC2=0.0
+      DO I=1,NSOIL
+         FAC2=MAX(FAC2,SH2O(I)/SMCMAX)
+      ENDDO
+      CALL FAC2MIT(SMCMAX,FLIMIT)
+
+! ----------------------------------------------------------------------
+! 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.0001*1000.0* (- ZSOIL (1))* SMCMAX) )   &
+           .OR. (FAC2 > FLIMIT) ) 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,&
+                          RIBB,SOLDN,                                   &
+                          ISURBAN,                                      &
+
+                          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, INTENT(IN)   :: ISURBAN
+      INTEGER               :: K
+!
+! kmh 09/03/2006 add IT16 for surface temperature iteration
+!
+      INTEGER               :: IT16
+      LOGICAL, INTENT(IN)   :: SNOWNG
+      REAL, INTENT(IN)      :: BEXP,CFACTR, CMCMAX,CSOIL,DF1,DKSAT,     &
+                               DT,DWSAT, EPSCA,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,SOLDN
+      REAL, INTENT(INOUT)   :: CMC, BETA, ESD,FLX2,PRCPF,SNOWH,SNCOVR,  &
+                               SNDENS, T1, RIBB, ETP
+      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
+!                               T12B, T14, YY, ZZ1,EMISSI_S
+!
+! kmh 01/11/2007 add T15, T16, and DTOT2 for SFC T iteration and snow heat flux
+!
+      REAL                  :: T15, T16, DTOT2
+      REAL, PARAMETER       :: ESDMIN = 1.E-6, LSUBC = 2.501000E+6,     &
+                               LSUBS = 2.83E+6, TFREEZ = 273.15,        &
+                               SNOEXP = 2.0
+
+! ----------------------------------------------------------------------
+! EXECUTABLE CODE BEGINS HERE:
+! ----------------------------------------------------------------------
+! IF SEA-ICE (ICE=1) OR GLACIAL-ICE (ICE=-1), SNOWCOVER FRACTION = 1.0,
+! AND SUBLIMATION IS AT THE POTENTIAL RATE.
+! FOR NON-GLACIAL LAND (ICE=0), IF SNOWCOVER FRACTION < 1.0, TOTAL
+! EVAPORATION < POTENTIAL DUE TO NON-POTENTIAL CONTRIBUTION FROM
+! NON-SNOW COVERED FRACTION.
+! ----------------------------------------------------------------------
+! 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]
+! ----------------------------------------------------------------------
+      DEW = 0.
+      EDIR = 0.
+      EDIR1 = 0.
+      EC1 = 0.
+      EC = 0.
+!      EMISSI_S=0.95    ! 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 ETP1 IN M S-1
+! ----------------------------------------------------------------------
+      PRCP1 = PRCPF *0.001
+! ----------------------------------------------------------------------
+! IF ETP<0 (DOWNWARD) THEN DEWFALL (=FROSTFALL IN THIS CASE).
+! ----------------------------------------------------------------------
+      BETA = 1.0
+      IF (ETP <= 0.0) THEN
+         IF ( ( RIBB >= 0.1 ) .AND. ( FDOWN > 150.0 ) ) THEN
+            ETP=(MIN(ETP*(1.0-RIBB),0.)*SNCOVR/0.980 + ETP*(0.980-SNCOVR))/0.980
+         ENDIF
+        IF(ETP == 0.) BETA = 0.0
+        ETP1 = ETP * 0.001
+         DEW = -ETP1
+         ESNOW2 = ETP1*DT
+         ETANRG = ETP*((1.-SNCOVR)*LSUBC + SNCOVR*LSUBS)
+      ELSE
+         ETP1 = ETP * 0.001
+         IF ( ICE /= 0 ) THEN
+            ! SEA-ICE AND GLACIAL-ICE CASE
+            ESNOW = ETP
+            ESNOW1 = ESNOW*0.001
+            ESNOW2 = ESNOW1*DT
+            ETANRG = ESNOW*LSUBS
+         ELSE IF ( ICE ==  0) THEN
+            ! NON-GLACIAL LAND CASE
+             IF (SNCOVR <  1.) THEN
+               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)
+! ----------------------------------------------------------------------------
+               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
+               ETNS1 = ETNS1*(1.-SNCOVR)
+! ----------------------------------------------------------------------------
+               EDIR = EDIR1*1000.
+               EC = EC1*1000.
+               DO K = 1,NSOIL
+                  ET (K) = ET1 (K)*1000.
+               END DO
+               ETT = ETT1*1000.
+               ETNS = ETNS1*1000.
+! ----------------------------------------------------------------------
+
+!   end IF (SNCOVR .lt. 1.)
+            END IF
+!   end IF (ICE .ne. 1)
+         END IF
+         ESNOW = ETP*SNCOVR
+         ESNOW1 = ESNOW*0.001
+         ESNOW2 = ESNOW1*DT
+         ETANRG = ESNOW*LSUBS + ETNS*LSUBC
+!   end IF (ETP .le. 0.0)
+      END IF
+
+! ----------------------------------------------------------------------
+! 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
+      DENOM = 1.0+ DF1 / (DTOT * RR * RCH)
+! surface emissivity weighted by snow cover fraction
+!      T12A = ( (FDOWN - FLX1 - FLX2 -                                   &
+!     &       ((SNCOVR*EMISSI_S)+EMISSI*(1.0-SNCOVR))*SIGMA *T24)/RCH    &
+!     &       + TH2 - SFCTMP - ETANRG/RCH ) / RR
+      T12A = ( (FDOWN - FLX1- FLX2- EMISSI * 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
+! ----------------------------------------------------------------------
+      ELSE
+         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.
+! ----------------------------------------------------------------------
+         IF ( ICE /= 0 ) then
+            ! kmh  12/15/2005 modify SSOIL
+            ! kmh  09/03/2006 modify DTOT
+            IF ( DTOT .GT. 2.0*DSOIL ) THEN
+               DTOT = 2.0*DSOIL
+            ENDIF
+         ENDIF
+         SSOIL = DF1 * (T1- STC (1)) / DTOT
+         IF (ESD-ESNOW2 <= ESDMIN) THEN
+            ESD = 0.0
+            EX = 0.0
+            SNOMLT = 0.0
+            FLX3 = 0.0
+! ----------------------------------------------------------------------
+! SUBLIMATION LESS THAN DEPTH OF SNOWPACK
+! SNOWPACK (ESD) REDUCED BY ESNOW2 (DEPTH OF SUBLIMATED SNOW)
+! ----------------------------------------------------------------------
+         ELSE
+            ESD = ESD-ESNOW2
+            ETP3 = ETP * LSUBC
+            SEH = RCH * (T1- TH2)
+            T14 = T1* T1
+            T14 = T14* T14
+!           FLX3 = FDOWN - FLX1 - FLX2 -                                 &
+!                  ((SNCOVR*EMISSI_S)+EMISSI*(1-SNCOVR))*SIGMA*T14 -     &
+!                    SSOIL - SEH - ETANRG
+            FLX3 = FDOWN - FLX1- FLX2- EMISSI*SIGMA * T14- SSOIL - SEH - ETANRG
+            IF (FLX3 <= 0.0) FLX3 = 0.0
+! ----------------------------------------------------------------------
+! SNOWMELT REDUCTION DEPENDING ON SNOW COVER
+! ----------------------------------------------------------------------
+            EX = FLX3*0.001/ LSUBF
+
+! ----------------------------------------------------------------------
+! 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
+! ----------------------------------------------------------------------
+! ----------------------------------------------------------------------
+! IF NON-GLACIAL LAND, ADD SNOWMELT RATE (EX) TO PRECIP RATE TO BE USED
+! IN SUBROUTINE SMFLX (SOIL MOISTURE EVOLUTION) VIA INFILTRATION.
+!
+! FOR SEA-ICE AND GLACIAL-ICE, THE SNOWMELT WILL BE ADDED TO SUBSURFACE
+! RUNOFF/BASEFLOW LATER NEAR THE END OF SFLX (AFTER RETURN FROM CALL TO
+! SUBROUTINE SNOPAC)
+! ----------------------------------------------------------------------
+         IF (ICE == 0) PRCP1 = PRCP1+ EX
+
+! ----------------------------------------------------------------------
+! 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 FOR NON-GLACIAL LAND.
+! IF SEA-ICE (ICE==1) OR GLACIAL-ICE (ICE==-1), SKIP CALL TO SMFLX,
+! SINCE NO SOIL MEDIUM FOR SEA-ICE OR GLACIAL-ICE.
+! ----------------------------------------------------------------------
+      END IF
+      IF (ICE == 0) 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,ISURBAN)
+
+! ----------------------------------------------------------------------
+! 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 (ICE == 0) THEN
+         ! NON-GLACIAL LAND
+         IF (ESD >  0.) THEN
+            CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY)
+         ELSE
+            ESD = 0.
+            SNOWH = 0.
+            SNDENS = 0.
+            SNCOND = 1.
+            SNCOVR = 0.
+         END IF
+      ELSEIF (ICE == 1) THEN
+         ! SEA-ICE
+         IF (ESD .GE. 0.01) THEN
+            CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY)
+        ELSE
+           ESD = 0.01
+           SNOWH = 0.05
+           !KWM???? SNDENS =
+           !KWM???? SNCOND =
+           SNCOVR = 1.0
+        ENDIF
+      ELSEIF (ICE == -1) THEN
+         ! GLACIAL-ICE
+         IF (ESD .GE. 0.10) THEN
+            CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY)
+         ELSE
+            ESD = 0.10
+            SNOWH = 0.50
+            !KWM???? SNDENS =
+            !KWM???? SNCOND =
+            SNCOVR = 1.0
+        ENDIF
+      ENDIF
+! ----------------------------------------------------------------------
+  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, SNOWH)
+
+! ----------------------------------------------------------------------
+! 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
+      REAL, INTENT(IN)        :: SNOWH
+      REAL                    :: BURIAL
+      REAL                    :: Z0EFF
+
+!m      Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0S
+      BURIAL = 7.0*Z0BRD - SNOWH
+      IF(BURIAL.LE.0.0007) THEN
+        Z0EFF = Z0S
+      ELSE      
+        Z0EFF = BURIAL/7.0
+      ENDIF
+      
+      Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0EFF
+
+! ----------------------------------------------------------------------
+  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/DT)
+         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
+! ICE CONDUCTIVITY:
+      THKICE = 2.2
+! WATER CONDUCTIVITY:
+      THKW = 0.57
+! THERMAL CONDUCTIVITY OF "OTHER" SOIL COMPONENTS
+!      IF (QZ .LE. 0.2) THKO = 3.0
+      THKO = 2.0
+! QUARTZ' CONDUCTIVITY
+      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 / SMC
+! 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)
+! 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 (NROOT)
+      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.05 / SMCMAX
+
+! ----------------------------------------------------------------------
+! PREP AN EXPNTL COEF AND CALC THE SOIL WATER DIFFUSIVITY
+! ----------------------------------------------------------------------
+      FACTR2 = SMC / SMCMAX
+      FACTR1 = MIN(FACTR1,FACTR2)
+      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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_oml.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_oml.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_oml.F	(revision 17)
@@ -0,0 +1,307 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+MODULE module_sf_oml
+
+CONTAINS
+
+!----------------------------------------------------------------
+   SUBROUTINE OCEANML(tml,t0ml,hml,h0ml,huml,hvml,ust,u_phy,v_phy, &
+                      tmoml,f,g,oml_gamma,                         &
+                      XLAND,HFX,LH,TSK,GSW,GLW,EMISS,              &
+                      DELTSM,STBOLT,                               &
+                      ids,ide, jds,jde, kds,kde,                   &
+                      ims,ime, jms,jme, kms,kme,                   &
+                      its,ite, jts,jte, kts,kte                    )
+
+!----------------------------------------------------------------
+   IMPLICIT NONE
+!----------------------------------------------------------------
+!
+!  SUBROUTINE OCEANML CALCULATES THE SEA SURFACE TEMPERATURE (TSK)
+!  FROM A SIMPLE OCEAN MIXED LAYER MODEL BASED ON
+!  (Pollard, Rhines and Thompson (1973).
+!
+!-- TML         ocean mixed layer temperature (K)
+!-- T0ML        ocean mixed layer temperature (K) at initial time
+!-- TMOML       top 200 m ocean mean temperature (K) at initial time
+!-- HML         ocean mixed layer depth (m)
+!-- H0ML        ocean mixed layer depth (m) at initial time
+!-- HUML        ocean mixed layer u component of wind
+!-- HVML        ocean mixed layer v component of wind
+!-- OML_GAMMA   deep water lapse rate (K m-1)
+!-- UAIR,VAIR   lowest model level wind component
+!-- UST         frictional velocity
+!-- HFX         upward heat flux at the surface (W/m^2)
+!-- 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)
+!-- EMISS       emissivity of the surface
+!-- XLAND       land mask (1 for land, 2 for water)
+!-- STBOLT      Stefan-Boltzmann constant (W/m^2/K^4)
+!-- F           Coriolis parameter
+!-- DT          time step (second)
+!-- G           acceleration due to gravity
+
+   INTEGER,  INTENT(IN   )   ::     ids,ide, jds,jde, kds,kde,  &
+                                    ims,ime, jms,jme, kms,kme,  &
+                                    its,ite, jts,jte, kts,kte
+
+   REAL,     INTENT(IN   )   ::     DELTSM, STBOLT
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(IN   )    ::                          EMISS, &
+                                                         XLAND, &
+                                                           GSW, &
+                                                           GLW, &
+                                                           HFX, &
+                                                            LH
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(INOUT)    ::                            TSK
+
+   REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) ::     &
+                                    TML,T0ML,HML,H0ML,HUML,HVML
+
+   REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) ::     &
+                                             U_PHY,V_PHY
+
+   REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(IN   ) ::     &
+                                             UST, F, TMOML
+
+   REAL,    INTENT(IN   )   ::     G
+   REAL,    INTENT(IN   )   ::     OML_GAMMA
+
+! LOCAL VARS
+
+   INTEGER ::  I,J
+
+   DO J=jts,jte
+
+         DO i=its,ite
+            IF (XLAND(I,J).GT.1.5) THEN
+               CALL OML1D(I,J,TML(i,j),T0ML(i,j),HML(i,j),H0ML(i,j),           &
+                          HUML(i,j),HVML(i,j),TSK(i,j),HFX(i,j),               &
+                          LH(i,j),GSW(i,j),GLW(i,j),TMOML(i,j),                &
+                          U_PHY(i,kts,j),V_PHY(i,kts,j),UST(i,j),F(i,j),       &
+                          EMISS(i,j),STBOLT,G,DELTSM,OML_GAMMA,                &
+                          ids,ide, jds,jde, kds,kde,                           &
+                          ims,ime, jms,jme, kms,kme,                           &
+                          its,ite, jts,jte, kts,kte                            )
+            ENDIF
+         ENDDO
+
+   ENDDO
+
+   END SUBROUTINE OCEANML
+
+!----------------------------------------------------------------
+   SUBROUTINE OML1D(I,J,TML,T0ML,H,H0,HUML,                              &
+                    HVML,TSK,HFX,                                        &
+                    LH,GSW,GLW,TMOML,                                    &
+                    UAIR,VAIR,UST,F,EMISS,STBOLT,G,DT,OML_GAMMA,         &
+                    ids,ide, jds,jde, kds,kde,                           &
+                    ims,ime, jms,jme, kms,kme,                           &
+                    its,ite, jts,jte, kts,kte                            )
+
+!----------------------------------------------------------------
+   IMPLICIT NONE
+!----------------------------------------------------------------
+!
+!  SUBROUTINE OCEANML CALCULATES THE SEA SURFACE TEMPERATURE (TSK) 
+!  FROM A SIMPLE OCEAN MIXED LAYER MODEL BASED ON 
+!  (Pollard, Rhines and Thompson (1973).
+!
+!-- TML         ocean mixed layer temperature (K)
+!-- T0ML        ocean mixed layer temperature (K) at initial time
+!-- TMOML       top 200 m ocean mean temperature (K) at initial time
+!-- H           ocean mixed layer depth (m)
+!-- H0          ocean mixed layer depth (m) at initial time
+!-- HUML        ocean mixed layer u component of wind
+!-- HVML        ocean mixed layer v component of wind
+!-- OML_GAMMA   deep water lapse rate (K m-1)
+!-- OMLCALL     whether to call oml model
+!-- UAIR,VAIR   lowest model level wind component
+!-- UST         frictional velocity
+!-- HFX         upward heat flux at the surface (W/m^2)
+!-- 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)
+!-- EMISS       emissivity of the surface
+!-- STBOLT      Stefan-Boltzmann constant (W/m^2/K^4)
+!-- F           Coriolis parameter
+!-- DT          time step (second)
+!-- G           acceleration due to gravity
+!
+!----------------------------------------------------------------
+   INTEGER, INTENT(IN   )    ::      I, J
+   INTEGER, INTENT(IN   )    ::      ids,ide, jds,jde, kds,kde, &
+                                     ims,ime, jms,jme, kms,kme, &
+                                     its,ite, jts,jte, kts,kte
+
+   REAL,    INTENT(INOUT)    :: TML, H, H0, HUML, HVML, TSK
+
+   REAL,    INTENT(IN   )    :: T0ML, HFX, LH, GSW, GLW,        &
+                                UAIR, VAIR, UST, F, EMISS, TMOML
+
+   REAL,    INTENT(IN) :: STBOLT, G, DT, OML_GAMMA
+
+! Local
+   REAL :: rhoair, rhowater, Gam, alp, BV2, A1, A2, B2, u, v, wspd, &
+           hu1, hv1, hu2, hv2, taux, tauy, tauxair, tauyair, q, hold, &
+           hsqrd, thp, cwater, ust2
+   CHARACTER(LEN=120) :: time_series
+
+      hu1=huml
+      hv1=hvml
+      rhoair=1.
+      rhowater=1000.
+      cwater=4200.
+! Deep ocean lapse rate (K/m) - from Rich
+      Gam=oml_gamma
+!     if(i.eq.1 .and. j.eq.1 .or. i.eq.105.and.j.eq.105) print *, 'gamma = ', gam
+!     Gam=0.14
+!     Gam=5.6/40.
+!     Gam=5./100.
+! Thermal expansion coeff (/K)
+!     alp=.0002
+!     temp dependence (/K)
+      alp=max((tml-273.15)*1.e-5, 1.e-6)
+      BV2=alp*g*Gam
+      thp=t0ml-Gam*(h-h0)
+      A1=(tml-thp)*h - 0.5*Gam*h*h
+      if(h.ne.0.)then
+        u=hu1/h
+        v=hv1/h
+      else
+        u=0.
+        v=0.
+      endif
+
+!  time step
+
+        q=(-hfx-lh+gsw+glw-stbolt*emiss*tml*tml*tml*tml)/(rhowater*cwater)
+!       wspd=max(sqrt(uair*uair+vair*vair),0.1)
+        wspd=sqrt(uair*uair+vair*vair)
+        if (wspd .lt. 1.e-10 ) then
+!          print *, 'i,j,wspd are ', i,j,wspd
+           wspd = 1.e-10
+        endif
+! limit ust to 1.6 to give a value of ust for water of 0.05
+!       ust2=min(ust, 1.6)
+! new limit for ust: reduce atmospheric ust by half for ocean
+        ust2=0.5*ust
+        tauxair=ust2*ust2*uair/wspd
+        taux=rhoair/rhowater*tauxair
+        tauyair=ust2*ust2*vair/wspd
+        tauy=rhoair/rhowater*tauyair
+! note: forward-backward coriolis force for effective time-centering
+        hu2=hu1+dt*( f*hv1 + taux)
+        hv2=hv1+dt*(-f*hu2 + tauy)
+! consider the flux effect
+        A2=A1+q*dt
+
+        huml=hu2
+        hvml=hv2
+
+        hold=h
+        B2=hu2*hu2+hv2*hv2
+        hsqrd=-A2/Gam + sqrt(A2*A2/(Gam*Gam) + 2.*B2/BV2)
+        h=sqrt(max(hsqrd,0.0))
+! limit to positive h change
+        if(h.lt.hold)h=hold
+
+!       if(h.ne.0.)then
+! no change unless tml is warmer than layer mean temp tmol or tsk-5 (see omlinit)
+        if(tml.ge.tmoml .and. h.ne.0.)then
+          tml=max(t0ml - Gam*(h-h0) + 0.5*Gam*h + A2/h, tmoml)
+          u=hu2/h
+          v=hv2/h
+        else
+          tml=t0ml
+          u=0.
+          v=0.
+        endif
+        tsk=tml
+!        if(h.gt.100.)print *,i,j,h,tml,' h,tml'
+
+! ww: output point data
+!     if( (i.eq.190 .and. j.eq.115) .or. (i.eq.170 .and. j.eq.125) ) then
+!        write(jtime,fmt='("TS ",f10.0)') float(itimestep)
+!        CALL wrf_message ( TRIM(jtime) )
+!        write(time_series,fmt='("OML",2I4,2F9.5,2F8.2,2E15.5,F8.3)') &
+!              i,j,u,v,tml,h,taux,tauy,a2
+!        CALL wrf_message ( TRIM(time_series) )
+!     end if
+
+   END SUBROUTINE OML1D
+
+!================================================================
+   SUBROUTINE omlinit(oml_hml0, tsk,                           &
+                      tml,t0ml,hml,h0ml,huml,hvml,tmoml,       &
+                      allowed_to_read, start_of_simulation,    &
+                      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
+   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
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(IN)    ::                               TSK
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(INOUT)    ::     TML, T0ML, HML, H0ML, HUML, HVML, TMOML
+   REAL   , INTENT(IN   )    ::     oml_hml0
+
+!  LOCAR VAR
+
+   INTEGER                   ::      L,J,I,itf,jtf
+   CHARACTER*1024 message
+
+!----------------------------------------------------------------
+ 
+   itf=min0(ite,ide-1)
+   jtf=min0(jte,jde-1)
+
+   IF(start_of_simulation) THEN
+     DO J=jts,jtf
+     DO I=its,itf
+       TML(I,J)=TSK(I,J)
+       T0ML(I,J)=TSK(I,J)
+     ENDDO
+     ENDDO
+     IF (oml_hml0 .gt. 0.) THEN
+        WRITE(message,*)'Initializing OML with HML0 = ', oml_hml0
+        CALL wrf_debug (0, TRIM(message))
+        DO J=jts,jtf
+        DO I=its,itf
+          HML(I,J)=oml_hml0
+          H0ML(I,J)=HML(I,J)
+          HUML(I,J)=0.
+          HVML(I,J)=0.
+          TMOML(I,J)=TSK(I,J)-5.
+        ENDDO
+        ENDDO
+     ELSE
+        WRITE(message,*)'Initializing OML with real HML0, h(1,1) = ', h0ml(1,1)
+        CALL wrf_debug (0, TRIM(message))
+        DO J=jts,jtf
+        DO I=its,itf
+          HML(I,J)=H0ML(I,J)
+! fill in near coast area with SST: 200 K was set as missing value in ocean pre-processing code
+          IF(TMOML(I,J).GT.200. .and. TMOML(I,J).LE.201.) TMOML(I,J)=TSK(I,J)
+        ENDDO
+        ENDDO
+     ENDIF
+   ENDIF
+
+   END SUBROUTINE omlinit
+!-------------------------------------------------------------------          
+END MODULE module_sf_oml
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_pxlsm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_pxlsm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_pxlsm.F	(revision 17)
@@ -0,0 +1,1632 @@
+MODULE module_sf_pxlsm
+ 
+  USE module_model_constants
+
+  INTEGER, PARAMETER   :: NSOLD=20
+  REAL, PARAMETER      :: RD     = 287.04,   CPD   = 1004.67,             &
+                          CPH2O  = 4.218E+3, CPICE = 2.106E+3,            &
+                          LSUBF  = 3.335E+5, SIGMA = 5.67E-8,             &  
+                          ROVCP  = RD / CPD
+                          
+  REAL, PARAMETER      :: CRANKP = 0.5                    ! CRANK-NIC PARAMETER
+  REAL, PARAMETER      :: RIC    = 0.25                   ! critical Richardson number
+  REAL, PARAMETER      :: DENW   = 1000.0                 ! water density in KG/M3                  
+  REAL, PARAMETER      :: TAUINV = 1.0 / 86400.0          ! 1/1DAY(SEC)
+  REAL, PARAMETER      :: T2TFAC = 1.0 / 10.0             ! Bottom soil temp response factor
+  REAL, PARAMETER      :: PI = 3.1415926
+  REAL, PARAMETER      :: PR0 = 0.95
+  REAL, PARAMETER      :: CZO    = 0.032
+  REAL, PARAMETER      :: OZO    = 1.E-4
+
+CONTAINS
+!
+
+!-------------------------------------------------------------------------
+   SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO,         &
+                    PSFC, GSW, GLW, RAINBL, EMISS,              &
+                    ITIMESTEP, NSOIL, DT, ANAL_INTERVAL,        &            
+                    XLAND, XICE, ALBBCK, ALBEDO, SNOALB,        &
+                    SMOIS, TSLB, MAVAIL, TA2, QA2,              &
+                    ZS,DZS, PSIH,                               &
+                    LANDUSEF,SOILCTOP,SOILCBOT,VEGFRA,VEGF_PX,  &
+                    ISLTYP,RA,RS,LAI,NLCAT,NSCAT,               & 
+                    HFX,QFX,LH,TSK,SST,ZNT,CANWAT,              &
+                    GRDFLX,SHDMIN,SHDMAX,                       &
+                    SNOWC,PBLH,RMOL,UST,CAPG,DTBL,              &
+                    T2_NDG_OLD, T2_NDG_NEW,                     &     
+                    Q2_NDG_OLD, Q2_NDG_NEW,                     & 
+                    SN_NDG_OLD, SN_NDG_NEW, SNOW, SNOWH,SNOWNCV,&
+                    T2OBS, Q2OBS, PXLSM_SMOIS_INIT,             &           
+                    PXLSM_SOIL_NUDGE,                           &
+                    ids,ide, jds,jde, kds,kde,                  &
+                    ims,ime, jms,jme, kms,kme,                  &
+                    its,ite, jts,jte, kts,kte                    )
+
+!*************************************************************************
+!   THIS MODULE CONTAINS THE PLEIM-XIU LAND-SURFACE MODEL (PX-LSM).
+!   IT IS DESIGNED TO SIMULATE CHARACTERISTICS OF THE LAND SURFACE AND
+!   VEGETATION AND EXCHANGE WITH THE PLANETARY BOUNDARY LAYER (PBL). THE
+!   SOIL MOISTURE MODEL IS BASED ON THE ISBA SCHEME DEVELOPED BY NOILHAN
+!   AND PLANTON (1989) AND JACQUEMIN AND NOILHAN (1990) AND INCLUDES
+!   PROGNOSTIC EQUATIONS FOR SOIL MOISTURE AND SOIL TEMPERATURE IN TWO
+!   LAYERS (1 CM AND 1 M) AS WELL AS CANOPY WATER CONTENT.  SURFACE
+!   MOISTURE FLUXES ARE MODELED BY 3 PATHWAYS: SOIL EVAPORATION, CANOPY
+!   EVAPORATION, AND VEGETATIVE EVAPOTRANSPIRRATION.
+!   EVAPOTRANSPIRATION DIRECTLY FROM THE ROOT ZONE SOIL LAYER IS MODELED
+!   VIA A CANOPY RESISTANCE ANALOG ALGORITHM WHERE STOMATAL CONDUCTANCE
+!   IS CONTROLLED BY SOLAR RADIATION, AIR TEMPERATURE, AIR HUMIDITY, AND
+!   ROOT ZONE SOIL MOISTURE. REQUIRED VEGETATION CHARACTERISTICS DERIVED
+!   FROM THE USGS LANDUSE DATA INCLUDE: LEAF AREA INDEX, FRACTIONAL VEGETATION
+!   COVERAGE, ROUGHNESS LENGTH, AND MINIMUM STOMATAL RESISTANCE. AN INDIRECT
+!   NUDGING SCHEME ADJUSTS SOIL MOISTURE ACCORDING TO DIFFERENCES BETWEEN
+!   MODELED TEMPERATURE AND HUMIDITY AND ANALYSED SURFACE FIELDS.
+!
+! References:
+! Pleim and Xiu, 1995: Development and testing of a surface flux and planetary 
+!                      boundary layer model for application in mesoscale models.
+!                      J. Appl. Meteoro., Vol. 34, 16-32.
+! Xiu and Pleim, 2001: Development of a land surface model. Part I: Application
+!                      in a mesoscale meteorological model. J. Appl. Meteoro.,
+!                      Vol. 40, 192-209.
+! Pleim and Xiu, 2003: Development of a land surface model. Part II: Data
+!                      assimilation. J. Appl. Meteoro., Vol. 42, 1811-1822.
+!
+! REVISION HISTORY:
+!     AX     4/2005 - developed WRF version based on the MM5 PX LSM
+!************************************************************************
+!   ARGUMENT LIST:
+!
+!... Inputs:
+!-- U3D             3D u-velocity interpolated to theta points (m/s)
+!-- V3D             3D v-velocity interpolated to theta points (m/s)
+!-- DZ8W            dz between full levels (m)
+!-- QV3D	    3D mixing ratio
+!-- T3D             Temperature (K)
+!-- TH3D            Theta (K)
+!-- RHO             3D dry air density (kg/m^3)
+
+!-- PSFC		surface pressure (Pa)
+!-- GSW			downward short wave flux at ground surface (W/m^2)      
+!-- GLW			downward long wave flux at ground surface (W/m^2)
+!-- RAINBL		Timestep rainfall 
+!-- EMISS		surface emissivity (between 0 and 1)
+
+!-- ITIMESTEP		time step number 
+!-- NSOIL	        number of soil layers
+!-- DT			time step (second)
+!-- ANAL_INTERVAL       Interval of analyses used for soil moisture and temperature nudging
+
+!-- XLAND       	land mask (1 for land, 2 for water)
+!-- XICE          Sea ice
+!-- ALBBCK              Background Albedo
+!-- ALBEDO      	surface albedo with snow cover effects
+!-- SNOALB              Albedo of snow
+
+!-- SMOIS       	total soil moisture content (volumetric fraction)
+!-- TSLB        	soil temp (k)
+!-- MAVAIL              Moisture availibility of soil
+!-- TA2                 2-m temperature
+!-- QA2                 2-m mixing ratio
+
+!-- SVPT0       constant for saturation vapor pressure (K)
+!-- SVP1        constant for saturation vapor pressure (kPa)
+!-- SVP2        constant for saturation vapor pressure (dimensionless)
+!-- SVP3        constant for saturation vapor pressure (K)
+
+!-- ZS          depths of centers of soil layers
+!-- DZS         thicknesses of soil layers
+!-- PSIH        similarity stability function for heat
+
+!-- LANDUSEF     Landuse fraction		
+!-- SOILCTOP     Top soil fraction		
+!-- SOILCBOT     Bottom soil fraction		
+!-- VEGFRA       Vegetation fraction                   
+!-- VEGF_PX      Veg fraction recomputed and used by PX LSM
+!-- ISLTYP       Soil type
+
+!-- RA           Aerodynamic resistence			
+!-- RS           Stomatal resistence			
+!-- LAI          Leaf area index (weighted according to fractional landuse)
+!-- NLCAT        Number of landuse categories		
+!-- NSCAT        Number of soil categories		
+
+!-- 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)
+!-- TSK 	  surface skin temperature (K)
+!-- SST     sea surface temperature
+!-- ZNT           rougness length
+!-- CANWAT        Canopy water (mm)
+
+!-- GRDFLX        Ground heat flux
+!-- SFCEVP      Evaportation from surface
+!-- SHDMIN       Minimum annual vegetation fraction for each grid cell
+!-- SHDMAX       Maximum annual vegetation fraction for each grid cell
+
+!-- SNOWC         flag indicating snow coverage (1 for snow cover)
+!-- PBLH          PBL height (m)
+!-- RMOL          1/L Reciprocal of Monin-Obukhov length
+!-- UST           u* in similarity theory (m/s)
+!-- CAPG          heat capacity for soil (J/K/m^3)
+!-- DTBL	  time step of boundary layer calls
+
+!-- T2_NDG_OLD    Analysis temperature prior to current time
+!-- T2_NDG_NEW    Analysis temperature ahead of current time
+!-- Q2_NDG_OLD    Analysis mixing ratio prior to current time
+!-- Q2_NDG_NEW    Analysis mixing ratio ahead of current time
+
+!-- SN_NDG_OLD    Analysis snow water prior to current time
+!-- SN_NDG_NEW    Analysis snow water ahead of current time
+!-- SNOW          Snow water equivalent
+!-- SNOWH         Physical snow depth
+!-- SNOWNCV       Time step accumulated snow
+
+!-- T2OBS         Analysis temperature interpolated from prior and next in time analysese
+!-- Q2OBS         Analysis moisture interpolated from prior and next in time analysese
+!-- PXLSM_SMOIS_INIT  Flag to intialize deep soil moisture to a value derived from moisture availiability.
+!-- PXLSM_SOIL_NUDGE  Flag to use soil moisture and temperature nudging in the PX LSM
+!                     This is typically done for the first simulation.
+
+!-- 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
+!... Outputs:
+
+     IMPLICIT NONE
+
+!.......Arguments
+! DECLARATIONS - INTEGER
+    INTEGER,  INTENT(IN)   ::      ids,ide, jds,jde, kds,kde, &
+                                   ims,ime, jms,jme, kms,kme, &
+                                   its,ite, jts,jte, kts,kte 
+
+   INTEGER,   INTENT(IN)  ::      NSOIL, ITIMESTEP, NLCAT, NSCAT,             &
+                                  ANAL_INTERVAL, PXLSM_SMOIS_INIT, PXLSM_SOIL_NUDGE
+
+   REAL,     INTENT(IN )  ::      DT,DTBL 
+
+   INTEGER,   DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) ::   ISLTYP
+
+! DECLARATIONS - REAL
+    REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ),  INTENT(IN) :: U3D, V3D, RHO, &
+                                                                    T3D, TH3D, DZ8W, QV3D           
+
+   REAL,     DIMENSION(1:NSOIL), INTENT(IN)::ZS,DZS
+   REAL,     DIMENSION( ims:ime , 1:NSOIL, jms:jme ),  INTENT(INOUT)   ::  SMOIS, TSLB     
+
+   REAL,     DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: RA, RS, LAI, ZNT
+   REAL,     DIMENSION( ims:ime , jms:jme ), INTENT(OUT):: GRDFLX, TSK, TA2, QA2
+
+   REAL,     DIMENSION( ims:ime , 1:NLCAT, jms:jme ), INTENT(IN):: LANDUSEF       
+   REAL,     DIMENSION( ims:ime , 1:NSCAT, jms:jme ), INTENT(IN):: SOILCTOP, SOILCBOT
+
+
+   REAL,    DIMENSION( ims:ime, jms:jme ),                                     &
+            INTENT(IN) ::                            PSFC, GSW, GLW, RAINBL,   &                
+                                                     EMISS, SNOALB,            &
+                                                     ALBBCK, SHDMIN, SHDMAX,   &
+                                                     PBLH, RMOL, SNOWNCV,      &
+                                                     UST, MAVAIL, SST
+   REAL,    DIMENSION( ims:ime, jms:jme ),                                     &
+            INTENT(IN) ::                            T2_NDG_OLD, T2_NDG_NEW,   &                
+                                                     Q2_NDG_OLD, Q2_NDG_NEW,   & 
+                                                     SN_NDG_OLD, SN_NDG_NEW   
+
+   REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: T2OBS, Q2OBS                
+                                                     
+   REAL,    DIMENSION( ims:ime, jms:jme ),                                     &
+            INTENT(INOUT) ::           CAPG,CANWAT, QFX, HFX, LH,              &
+                                       PSIH,VEGFRA, VEGF_PX, SNOW,             &
+                                       SNOWH, SNOWC, ALBEDO, XLAND, XICE
+
+
+   LOGICAL :: radiation
+
+!-------------------------------------------------------------------------
+!     ---------- Local Variables --------------------------------
+
+
+      !----  PARAMETERS
+      INTEGER, PARAMETER  :: NSTPS  = 11     ! max. soil types
+      REAL, PARAMETER     :: DTPBLX = 40.0   ! Max PX timestep = 40 sec
+
+      
+      !----  INTEGERS
+      INTEGER, DIMENSION( 1: NSTPS ) :: JP
+      INTEGER:: J, I, NS, NUDGE, ISTI, WEIGHT
+      INTEGER:: NTSPS, IT
+
+      !----  REALS
+      REAL,     DIMENSION( ims:ime, jms:jme ) :: XLAI, XLAIMN, RSTMIN, &
+                                                 XVEG, XVEGMN, XSNUP, &
+                                                 XALB
+                                                  
+      REAL,     DIMENSION( ims:ime, jms:jme ) :: RADNET, EG, ER, ETR, QST
+
+      REAL:: SFCPRS,TA1,DENS1,QV1,ZLVL,SOLDN,LWDN,    &
+            EMISSI,PRECIP,THETA1,VAPPRS,QSBT,         &
+            WG,W2,WR,TG,T2,USTAR,MOLX,Z0,             &
+            RAIR,CPAIR,IFLAND,ISNOW,                  &
+            ES,QSS,BETAP,                             &
+            RH2_OLD, RH2_NEW, T2_OLD, T2_NEW,         &
+            CORE, CORB, TIME_BETWEEN_ANALYSIS,        &
+            G1000, ALN10,RH2OBS, HU, SNOBS,           &
+            FWSAT,FWFC,FWWLT,FB,FCGSAT,FJP,FAS,       &
+            FSEAS, T2I, HC_SNOW, SNOW_FRA,SNOWALB,    &
+            QST12,ZFUNC,ZF1,ZA2,QV2, DT_FDDA,CURTIME, &
+            FC2R,FC1SAT, DTPBL
+
+!-------------------------------------------------------------------------
+!-------------------------------Executable starts here--------------------
+!
+      ALN10  = ALOG(10.0)
+      G1000  = g*1.0E-3            ! G/1000
+      WEIGHT = 0
+      DT_FDDA = ANAL_INTERVAL * 1.0    ! Convert DT of Analysis to real 
+
+      ! Compute vegetation and land-use characteristics by land-use fraction weighting
+      ! These parameters include LAI, VEGF, ZNT, ALBEDO, RS, etc.
+         CALL VEGELAND(LANDUSEF, VEGFRA, SHDMIN, SHDMAX,                &
+                       SOILCTOP, SOILCBOT, NLCAT, NSCAT,                &
+                       ZNT,XLAI,XLAIMN,RSTMIN,XVEG,XVEGMN,XSNUP,	&
+                       XLAND, XALB,                                     &
+                       ids,ide, jds,jde, kds,kde,			&
+                       ims,ime, jms,jme, kms,kme,			&
+                       its,ite, jts,jte, kts,kte)
+      !-----------------------------------------------------------------------------------
+      !--- Compute time relatve to old and new analysis time for timestep interpolation
+      CURTIME = (ITIMESTEP-1) * DT
+      TIME_BETWEEN_ANALYSIS = MOD(CURTIME,DT_FDDA)
+      IF (TIME_BETWEEN_ANALYSIS .EQ. 0.0) THEN   
+          CORB = 1.0       
+          CORE = 0.0    
+      ELSE    
+          CORE = TIME_BETWEEN_ANALYSIS  / DT_FDDA     
+          CORB = 1.0 - CORE  
+      ENDIF 
+      !-----------------------------------------------------------------------------------
+
+      !-----------------------------------------------------------------------------------
+      ! Main loop over individual grid cells
+      DO J = jts,jte    !-- J LOOP
+       DO I = its,ite   !-- I LOOP
+          
+          IFLAND = XLAND(I,J)
+
+          ! Compute soil properties via weighting of fractional components
+          IF (IFLAND .LT. 1.5 ) THEN 
+            CALL SOILPROP (SOILCBOT(I,:,J), WEIGHT,               &
+                         ITIMESTEP, MAVAIL(I,J),                  &
+                         PXLSM_SMOIS_INIT,                        &
+                         FWSAT,FWFC,FWWLT,FB,FCGSAT,              &  
+                         FJP,FAS,FC2R,FC1SAT,ISTI,SMOIS(I,2,J)    ) 
+            ISLTYP(I,J) = ISTI                      
+          ENDIF
+
+          !--  Variables Sub. SURFPX needs
+          SFCPRS = PSFC(i,j) / 1000.0                 ! surface pressure in cb
+          TA1    = T3D(i,1,j)                         ! air temperature at first layer
+          DENS1  = RHO(I,1,J)                         ! air density at first layer
+          QV1    = QV3D(i,1,j)                        ! water vapor mixing ratio at first layer
+          QV2    = QV3D(i,2,j)
+          ZLVL   = 0.5 * DZ8W(i,1,j)                  ! thickness of lowest half level
+          ZF1    = DZ8W(i,1,j)
+          ZA2    = ZF1 + 0.5 * DZ8W(i,2,j)
+
+          LWDN   = GLW(I,J)                           ! longwave radiation
+          EMISSI = EMISS(I,J)                         ! emissivity
+          PRECIP = MAX ( 1.0E-3*RAINBL(i,j)/DTBL,0.0) ! accumulated precip. rate during DT (=dtpbl)
+                                                      ! convert RAINBL from mm to m for PXLSM
+          WR     = 1.0E-3*CANWAT(I,J)                 ! convert CANWAT from mm to m for PXLSM
+          THETA1 = TH3D(i,1,j)			                  ! potential temp at first layer
+          SNOBS  = SNOW(I,J)                          ! Set snow cover to existing model value
+                                                      !   this is overwritten below if snow analysis is availiable
+                                                      !   otherwise snow cover remains constant through simulation
+                   
+          IF(PXLSM_SOIL_NUDGE .EQ. 1) THEN                   
+            !-- 2 m Temp and RH for Nudging
+            T2_OLD = T2_NDG_OLD(I,J)
+            T2_NEW     = T2_NDG_NEW(I,J)
+            VAPPRS     = SVP1 * EXP(SVP2 * (T2_OLD - SVPT0) / ( T2_OLD - SVP3))
+            QSBT       = EP_2 * VAPPRS / (SFCPRS - VAPPRS)          
+            RH2_OLD    = Q2_NDG_OLD(I,J) / QSBT
+            VAPPRS     = SVP1 * EXP(SVP2 * (T2_NEW - SVPT0) / (T2_NEW - SVP3))
+            QSBT       = EP_2 * VAPPRS / (SFCPRS - VAPPRS)          
+            RH2_NEW    = Q2_NDG_NEW(I,J) / QSBT
+            RH2OBS     = CORB * RH2_OLD +  CORE * RH2_NEW  
+            T2OBS(I,J) = CORB * T2_OLD +  CORE * T2_NEW
+            Q2OBS(I,J) = CORB * Q2_NDG_OLD(I,J) +  CORE * Q2_NDG_NEW(I,J)
+            SNOBS = CORB * SN_NDG_OLD(I,J) +  CORE * SN_NDG_NEW(I,J)  
+          ENDIF
+
+          USTAR  = MAX(UST(I,J),0.005)
+          IF (IFLAND .GT. 1.5) THEN ! if over water                            
+            ZNT(I,J) = CZO * UST(I,J) * UST(I,J) / G + OZO
+          ENDIF                                                              
+          Z0     = ZNT(I,J)
+          CPAIR  = CPD * (1.0 + 0.84 * QV1)            ! J/(K KG)
+
+          ! Compute fractional snow area and snow albedo
+          CALL PXSNOW (ITIMESTEP, SNOBS, SNOWNCV(I,J), SNOW(I,J),  &
+                       SNOWH(I,J), XSNUP(I,J),  XALB(i,j),         &
+                       SNOALB(I,J),VEGF_PX(I,J), SHDMIN(I,J),      &
+                       HC_SNOW, SNOW_FRA, SNOWC(I,J),  ALBEDO(I,J) ) 
+                                 
+          !-------------------------------------------------------------
+          ! Sea Ice from analysis and water cells that are very cold, but more than 50% water
+          ! are converted to ice/snow for more reasonable treatment.
+          IF( (XICE(I,J).GE.0.5) .OR.   &
+              (SST(I,J).LE.270.0.AND.XLAND(I,J).GT.1.50) ) THEN
+              XLAND(I,J) = 1.0
+              IFLAND = 1.0
+              ZNT(I,J) = 0.001  !  Ice
+              SMOIS(I,1,J) = 1.0     ! FWSAT
+              SMOIS(I,2,J) = 1.0     ! FWSAT
+              XICE(I,J) = 1.0
+              ALBEDO(I,J) = 0.7
+              SNOWC(I,J) = 1.0
+              SNOW_FRA = 1.0
+              VEGF_PX(I,J) = 0.0
+              LAI(I,J) = 0.0
+          ENDIF
+          !-------------------------------------------------------------
+
+          !-------------------------------------------------------------
+          !-- Note that when IFGROW = 0 is selected in Vegeland then max and min           
+          !-- LAI and Veg are the same                                                     
+          T2I = TSLB(I,2,J)                                            
+!         FSEAS = AMAX1(1.0 - 0.0016 * (298.0 - T2I) ** 2,0.0)  ! BATS            
+          FSEAS = AMAX1(1.0 - 0.015625 * (290.0 - T2I) ** 2,0.0) ! JP97            
+          IF (T2I .GE. 290.0) FSEAS = 1.0                                          
+          
+          LAI(I,J)       = XLAIMN(I,J) + FSEAS*(XLAI(I,J) - XLAIMN(I,J))                 
+          VEGF_PX(I,J)   = XVEGMN(I,J) + FSEAS*(XVEG(I,J) - XVEGMN(I,J))                       
+          
+          ! Ensure veg algorithms not used for water 
+          IF (IFLAND .GT. 1.5) THEN                        
+             VEGF_PX(I,J) = 0.0         
+          ENDIF                                                                   
+          !-------------------------------------------------------------
+
+
+          SOLDN  = GSW(I,J) / (1.0 - ALBEDO(I,J))     ! downward shortwave radiaton
+          ISNOW = SNOWC(I,J)
+
+
+          NUDGE=PXLSM_SOIL_NUDGE
+         IF ( J .LE. 2 .OR. J .GE. (jde-1) ) NUDGE=0
+         IF ( I .LE. 2 .OR. I .GE. (ide-1) ) NUDGE=0
+          
+          IF ( RMOL(I,J) .GT. 0.0 )  THEN
+              MOLX = AMIN1(1/RMOL(I,J),1000.0)
+          ELSE IF ( RMOL(I,J) .LT. 0.0 ) THEN
+              MOLX = AMAX1(1/RMOL(I,J),-1000.0)
+          ELSE
+              MOLX = 1000
+          ENDIF   
+ 
+          ZFUNC      = ZF1 * (1.0 - ZF1 / MAX(100.,PBLH(I,J))) ** 2
+          QST12 = KARMAN * ZFUNC*(QV2-QV1)               &
+               / (ZA2-ZLVL)
+
+!--- LSM sub-time loop too prevent dt > 40 sec       
+        NTSPS = INT(DT / (DTPBLX + 0.000001) + 1.0)                                
+        DTPBL = DT / NTSPS                                                       
+
+        DO IT=1,NTSPS                                                     
+          
+          !... SATURATION VAPOR PRESSURE (MB) 
+          IF ( TSLB(I,1,J) .LE. SVPT0 ) THEN        ! For ground that is below freezing
+            ES = SVP1 * EXP(22.514 - 6.15E3 / TSLB(I,1,J))      ! cb
+          ELSE
+            ES = SVP1 * EXP(SVP2 * (TSLB(I,1,J) - SVPT0) /  (TSLB(I,1,J) - SVP3))
+          ENDIF
+          QSS  = ES * 0.622 / (SFCPRS - ES)
+          
+          !... beta method, Lee & Pielke (JAM,May1992)
+          BETAP = 1.0
+          IF (IFLAND .LT. 1.5 .AND. ISNOW .LT. 0.5 .AND. SMOIS(I,1,J) .LE. FWFC) THEN       
+            BETAP = 0.25 * (1.0 - COS(SMOIS(I,1,J) / FWFC * PI)) ** 2
+          ENDIF
+          
+          CALL SURFPX (DTPBL, IFLAND, SNOWC(I,J),  NUDGE, XICE(I,J),            & !in
+                      SOLDN,  GSW(I,J), LWDN,   EMISSI, ZLVL,                   & !in
+                      MOLX,    Z0,    USTAR,                                    & !in
+                      SFCPRS, DENS1,  QV1,    QSS,   TA1,                       & !in
+                      THETA1,   PRECIP,                                         & !in
+                      CPAIR, PSIH(I,J),                                         & !in
+                      RH2OBS,T2OBS(I,J),                                        & !in
+                      VEGF_PX(I,J), ISTI,   LAI(I,J),   BETAP,                  & !in
+                      RSTMIN(I,J), HC_SNOW, SNOW_FRA,                           & !in          
+                      FWWLT, FWFC, FCGSAT,  FWSAT, FB,                          & !in
+                      FC1SAT,FC2R,FAS,FJP,DZS(1),DZS(2),QST12,                  & !in
+                      RADNET(I,J), GRDFLX(I,J), HFX(I,J), QFX(I,J), LH(I,J),    & !out
+                      EG(I,J), ER(I,J), ETR(I,J),                               & !out
+                      QST(I,J), CAPG(I,J), RS(I,J), RA(I,J),                    & !out
+                      TSLB(I,1,J), TSLB(I,2,J),                                 & !out
+                      SMOIS(I,1,J), SMOIS(I,2,J), WR, TA2(I,J), QA2(I,J) )
+          
+        END DO                    ! Time internal PX time loop   
+
+          TSK(I,J)= TSLB(I,1,J)     ! Skin temp set to 1 cm soil temperature in PX for now
+          CANWAT(I,J) = WR * 1000.  ! convert WR back to mm for CANWAT
+          
+       ENDDO !  END MIAN I LOOP
+      ENDDO  !  END MAIN J LOOP
+      
+!------------------------------------------------------
+   END SUBROUTINE pxlsm
+!------------------------------------------------------
+!***************************************************************************
+!***************************************************************************
+      SUBROUTINE VEGELAND( landusef, vegfra,    			&  ! in
+                            shdmin, shdmax,                             &                          
+                            soilctop, soilcbot, nlcat, nscat,           &
+                            znt,  xlai, xlaimn, rstmin, xveg, xvegmn,	&
+                            xsnup, xland, xalb,                         &
+                            ids,ide, jds,jde, kds,kde,			&
+                            ims,ime, jms,jme, kms,kme,			&
+                            its,ite, jts,jte, kts,kte			)
+!***************************************************************************
+!           
+!   CALLED FROM Sub. bl_init in module_physics.init.F
+!           
+!   THIS PROGRAM PROCESSES THE USGS LANDUSE DATA
+!   WHICH HAS BEEN GRIDDED BY THE WPS SYSTEM
+!   AND PRODUCES 2-D FIELDS OF LU RELATED PARAMETERS
+!   FOR USE IN THE PX SURFACE MODEL
+!
+!
+! REVISION HISTORY:
+!  AX      Oct 2004 - developed WRF version based on VEGELAND in the MM5 PX LSM
+!  RG      Dec 2006 - revised for WRFV2.1.2
+!  JP      Dec 2007 - revised for WRFV3 - removed IFGROW options
+!******************************************************************************
+                              
+
+      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)        ::  NSCAT, NLCAT
+
+      REAL,    DIMENSION( ims:ime , 1:NLCAT, jms:jme ),  INTENT(IN) :: LANDUSEF                        
+      REAL,    DIMENSION( ims:ime , 1:NSCAT, jms:jme ),  INTENT(IN) :: SOILCTOP, SOILCBOT
+                                                                   
+      REAL,    DIMENSION( ims:ime, jms:jme ),            INTENT(IN) ::  VEGFRA, SHDMIN, SHDMAX 
+
+      REAL,     DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ZNT
+
+      REAL,     DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: XLAI, XLAIMN, RSTMIN, XALB, &
+                                                              XVEG, XVEGMN, XSNUP, XLAND 
+                                     
+!... local variables
+
+      INTEGER :: itf, jtf, k, j, i
+      REAL    :: SUMLAI, SUMLMN, SUMRSI, SUMLZ0, SUMVEG, SUMVMN, ALAI, VEGF, SUMSNUP
+      REAL    :: VFMX, VFMN, VSEAS, FAREA, FWAT, ZNOTC, SUMALB
+      REAL,   DIMENSION( NLCAT )  :: LAIMX, LAIMN, Z0, VEG, VEGMN, SNUP
+      REAL, PARAMETER      :: ZNOTCMN = 5.0  ! CM, MIN Zo FOR CROPS
+      REAL, PARAMETER      :: ZNOTCMX = 15.0 ! CM, MAX Zo FOR CROPS
+
+!*****************************************************************************
+!  USGS LU characterization
+!---------------------------
+!     Name  Rstmin  Zo  Mxfr MnFr  MxLA MnLA
+! 1   Urban  150.   50.  40.  20.  2.0  0.5  Urban or Built-up Land
+! 2   DrCrp   70.   10.  95.  15.  3.0  0.5  Dryland Cropland and Pasture
+! 3   IrCrp   60.   10.  95.  10.  3.0  0.5  Irrigated Cropland and Pasture
+! 4   MixCp   70.   10.  95.  15.  3.0  0.5  Mixed Dry/Irr Crop and Past
+! 5   CrGrM   80.   10.  95.  35.  2.5  1.0  Grassland/Cropland Mosaic
+! 6   CrWdM  180.   40.  95.  40.  4.0  1.5  Woodland/Cropland Mosaic
+! 7   GrsLd  100.    7.  95.  70.  2.5  1.0  Grassland
+! 8   ShrLd  200.   20.  70.  50.  3.0  1.0  Shrubland
+! 9   ShrGr  150.   20.  85.  60.  3.0  1.0  Mixed Shrubland/Grassland
+! 10  Savan  120.   20.  80.  60.  2.0  1.0  Savanna
+! 11  DBFst  200.   50.  95.  50.  5.0  1.0  Broadleaf Deciduous Forest
+! 12  DNFst  175.   50.  95.  50.  5.0  1.0  Deciduous Coniferous Forest
+! 13  EBFst  120.   40.  95.  85.  5.0  4.0  Evergreen Broadleaf Forest (Palm?)
+! 14  ENFst  175.   50.  90.  80.  4.0  3.0  Evergreen Coniferous Forest
+! 15  MxFst  200.   50.  95.  60.  5.0  2.0  Mixed forest
+! 16  Water 9999.   0.1  00.  00.  0.0  0.0  Water
+! 17  HWtld  164.   15.  60.  40.  2.0  1.0  Herbaceous Wetland (none in east)
+! 18  WWtld  200.   45.  90.  80.  5.0  3.0  Forested Wetlands (e.g. Everglades)
+! 19  BarSp  100.    5.  10.  05.  0.5  0.2  Barren or Sparsely Vegetated
+! 20  HrTun  150.   10.  20.  10.  1.0  0.5  Herbaceous Tundra
+! 21  WdTun  200.   10.  30.  10.  1.0  0.5  Shrub and Brush Tundra
+! 22  MxTun  150.    5.  20.  05.  1.0  0.5  Mixed Tundra
+! 23  BGTun  100.    5.   5.  02.  0.1  0.1  Bare Ground Tundra
+! 24  SnwIc  300.    5.   5.  02.  0.1  0.1  Perennial Snowfields or Glaciers 
+!-----------------------------------------------------------------------------
+
+      REAL, DIMENSION(24)  :: RSMIN, Z00, VEG0, VEGMN0, &
+                              LAI0, LAIMN0, SNUP0, ALBF
+
+      DATA RSMIN /150.0,  70.0,  60.0,  70.0,  80.0, 180.0, 100.0, 200.0,   &
+                  150.0, 120.0, 200.0, 175.0, 120.0, 175.0, 200.0,9999.0,   &
+                  164.0, 200.0, 100.0, 150.0, 200.0, 150.0, 100.0, 300.0/
+      DATA Z00   / 50.0,  10.0,  10.0,  10.0,  10.0,  40.0,   7.0,  20.0,   &
+                   20.0,  20.0,  50.0,  50.0,  40.0,  50.0,  50.0,   0.1,   &
+                   15.0,  45.0,   5.0,  10.0,  10.0,   5.0,   5.0,   5.0/
+      DATA VEG0  / 40.0,  95.0,  95.0,  95.0,  95.0,  95.0,  95.0,  70.0,   &
+                   85.0,  80.0,  95.0,  95.0,  95.0,  90.0,  95.0,  0.00,   &
+                   60.0,  90.0,  10.0,  20.0,  30.0,  20.0,   5.0,   5.0/
+      DATA VEGMN0/ 20.0,  15.0,  10.0,  15.0,  35.0,  40.0,  70.0,  50.0,   &
+                   60.0,  60.0,  50.0,  50.0,  85.0,  80.0,  60.0,   0.0,   &
+                   40.0,  80.0,   5.0,  10.0,  10.0,   5.0,   2.0,   2.0/
+      DATA LAI0  /  2.0,   3.0,   3.0,   3.0,   2.5,   4.0,   2.5,   3.0,   &
+                    3.0,   2.0,   5.0,   5.0,   5.0,   4.0,   5.0,   0.0,   &
+                    2.0,   5.0,  0.50,   1.0,   1.0,   1.0,   0.1,   0.1/
+      DATA LAIMN0/ 0.50,  0.50,  0.50,  0.50,   1.0,   1.5,   1.0,   1.0,   &
+                    1.0,   1.0,   1.0,   1.0,   4.0,   3.0,   2.0,   0.0,   &
+                    1.0,   3.0,  0.20,  0.50,  0.50,  0.50,  0.10,  0.10/
+      DATA SNUP0/   0.04,  0.04,  0.04,  0.04,   0.04,  0.04,  0.04,  0.03,   &
+                    0.035, 0.04,  0.08,  0.08,   0.08,  0.08,  0.08,  0.01,   &
+                    0.01,  0.01,  0.02,  0.02,   0.025, 0.025, 0.025, 0.02/
+      DATA ALBF/   15.0,  17.0,  18.0,  18.0,  18.0,  16.0,  19.0,  22.0,   &
+                   20.0,  20.0,  16.0,  14.0,  12.0,  12.0,  13.0,   8.0,   &
+                   14.0,  14.0,  25.0,  15.0,  15.0,  15.0,  25.0,  55.0/
+
+      !---- INITIALIZE PARAMETERS
+
+      INTEGER :: KWAT
+      DATA KWAT / 16/
+      
+      !--------------------------------------------------------------------
+      DO J = jts,jte
+      DO I = its,ite
+        XLAI(I,J)   = 0.0                                                        
+        XLAIMN(I,J) = 0.0                                                     
+        RSTMIN(I,J) = 9999.0                                                    
+        XVEG(I,J)   = 0.0                                                       
+        XVEGMN(I,J) = 0.0
+        XSNUP(I,J)  = 0.0                                                            
+        XALB(I,J)   = 0.0                                                            
+      ENDDO		! END LOOP THROUGH GRID CELLS
+      ENDDO		! END LOOP THROUGH GRID CELLS
+      !--------------------------------------------------------------------
+
+      DO J = jts,jte
+      DO I = its,ite
+      
+
+      !-- Initialize 2 and 3-D veg parameters to be caculated
+      DO K=1,NLCAT                                                               
+        LAIMX(K) = LAI0(K)                                                       
+        LAIMN(K) = LAIMN0(K)                                                   
+        Z0(K)    = Z00(K)                                                   
+        VEG(K)   = VEG0(K)                                              
+        VEGMN(K) = VEGMN0(K)
+        SNUP(K)  =  SNUP0(K)                                            
+      ENDDO                                              
+
+        !--  INITIALIZE SUMS
+        SUMLAI = 0.0
+        SUMLMN = 0.0
+        SUMRSI = 0.0
+        SUMLZ0 = 0.0
+        SUMVEG = 0.0
+        SUMVMN = 0.0
+        ALAI   = 0.0
+        SUMSNUP= 0.0
+        SUMALB = 0.0
+
+       !--   ESTIMATE CROP EMERGANCE DATE FROM VEGFRAC
+        VFMX   = SHDMAX(I,J)
+        VFMN   = SHDMIN(I,J)
+        VEGF   = VEGFRA(I,J) 
+                
+        !-- Computations for VEGETATION CELLS ONLY
+        IF(VFMX.GT.0.0.AND.LANDUSEF(I,KWAT,J).LT.1.00) THEN
+          VSEAS = VEGF/VFMX
+          IF(VSEAS.GT.1.0.OR.VSEAS.LT.0.0) THEN
+            VSEAS = MIN(VSEAS,1.0)
+            VSEAS = MAX(VSEAS,0.0)
+          ENDIF
+
+          ZNOTC = ZNOTCMN * (1-VSEAS) + ZNOTCMX * VSEAS  ! Zo FOR CROPS
+          DO K = 1, NLCAT
+        !-- USE THE VEGFRAC DATA ONLY FOR CROPS 
+            IF (K .GE. 2 .AND. K .LE. 6) THEN
+              LAIMX(K) = LAIMN0(K) * (1-VSEAS) + LAI0(K) * VSEAS
+              LAIMN(K) = LAIMX(K)
+              VEG(K)   = VEGMN0(K) * (1-VSEAS) + VEG0(K) * VSEAS
+              VEGMN(K) = VEG(K)
+        !-- SEASONALLY VARY Zo FOR DryCrop (k=2) OR Irigated Crop (k=3) OR  Mix Crop (k=4) 
+              IF (K .GE. 2 .AND. K .LE. 4) THEN
+                 Z0(K) = ZNOTC
+              !-- CrGrM (k=5) or CrWdM (k=6) USE AVG WITH GRASS AND FOREST
+              ELSE IF (K .GE.5 .AND. K .LE. 6) THEN
+                Z0(K)  = 0.5 * (ZNOTC + Z00(K))
+              ENDIF
+            ENDIF
+          ENDDO
+           !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+        ENDIF       !-- IF cell is vegetation
+        !-------------------------------------
+        !-- LOOP THROUGH LANDUSE Fraction and compute totals
+        DO K = 1, NLCAT 
+          FAREA  = LANDUSEF(I,K,J)
+          SUMLAI = SUMLAI + LAIMX(K) * FAREA
+          SUMLMN = SUMLMN + LAIMN(K) * FAREA
+          ALAI   = ALAI + FAREA
+          SUMRSI = SUMRSI + FAREA * LAIMX(K) / RSMIN(K)
+          SUMLZ0 = SUMLZ0 + FAREA * ALOG(Z0(K))
+          SUMVEG = SUMVEG + FAREA * VEG(K)
+          SUMVMN = SUMVMN + FAREA * VEGMN(K)
+          SUMSNUP= SUMSNUP+ FAREA * SNUP(K)
+          SUMALB = SUMALB + FAREA * ALBF(K)
+        ENDDO
+
+        !-- CHECK FOR WATER
+        FWAT = LANDUSEF(I,KWAT,J)
+        IF (FWAT .GT. 0.999) THEN
+          XLAI(I,J)   = LAIMX(KWAT)
+          XLAIMN(I,J) = LAIMN(KWAT)
+          RSTMIN(I,J) = RSMIN(KWAT)
+          ZNT(I,J)    = Z0(KWAT)
+          XVEG(I,J)   = VEG(KWAT)
+          XVEGMN(I,J) = VEGMN(KWAT)
+          XSNUP(I,J)  = SNUP(KWAT)
+          XALB(I,J)   = ALBF(KWAT)
+        ELSE
+          IF (FWAT .GT. 0.10) THEN
+            ALAI   = ALAI - FWAT
+            SUMLZ0 = SUMLZ0 - FWAT * ALOG(Z0(KWAT))
+          ENDIF
+          XLAI(I,J)   = SUMLAI / ALAI
+          XLAIMN(I,J) = SUMLMN / ALAI
+          RSTMIN(I,J) = SUMLAI / SUMRSI
+          ZNT(I,J)    = EXP(SUMLZ0/ALAI)
+          XVEG(I,J)   = SUMVEG / ALAI
+          XVEGMN(I,J) = SUMVMN / ALAI
+          XSNUP(I,J)  = SUMSNUP/ALAI
+          XALB(I,J)   = SUMALB/ALAI
+        ENDIF
+
+        IF (FWAT .GT. 0.50) THEN
+           ZNT(I,J) = Z0(KWAT)
+          XALB(I,J) = ALBF(KWAT)
+        ENDIF
+
+        ZNT(I,J)    = ZNT(I,J) * 0.01           !CONVERT TO M
+        XVEG(I,J)   = XVEG(I,J) * 0.01          !CONVERT TO FRAC
+        XVEGMN(I,J) = XVEGMN(I,J) * 0.01
+        XLAND(I,J)  = 1.0 + FWAT
+        XALB(I,J)   = XALB(I,J) * 0.01
+        
+      ENDDO		! END LOOP THROUGH GRID CELLS
+      ENDDO		! END LOOP THROUGH GRID CELLS
+      !--------------------------------------------------------------------
+
+!------------------------------------------------------------------------------
+  END SUBROUTINE vegeland
+!------------------------------------------------------------------------------
+!**********************************************************************
+      SUBROUTINE SURFPX(DTPBL,  IFLAND, ISNOW,  NUDGEX, XICE1,               & !in
+                        SOLDN,  GSW, LWDN,   EMISSI, Z1,                     & !in
+                        MOL,    ZNT,    UST,                                 & !in 
+                        PSURF,  DENS1,  QV1,    QSS,   TA1,                  & !in
+                        THETA1, PRECIP,                                      & !in
+                        CPAIR, PSIH,                                         & !in
+                        RH2OBS, T2OBS,                                       & !in
+                        VEGFRC, ISTI,   LAI,   BETAP,                        & !in
+                        RSTMIN, HC_SNOW, SNOW_FRA,                           & !in
+                        WWLT, WFC, CGSAT, WSAT, B,                           & !in
+                        C1SAT, C2R, AS, JP, DS1, DS2,QST12,                  & !in
+                        RADNET, GRDFLX, HFX, QFX, LH, EG, ER,  ETR,          & !out
+                        QST,    CAPG,   RS, RA,  TG,     T2,                 & !out
+                        WG,     W2,     WR, TA2, QA2   )                        !out
+
+      IMPLICIT NONE
+!**********************************************************************
+! 
+!  FUNCTION:
+!    THIS SUBROUTINE COMPUTES SOIL MOISTURE AND TEMPERATURE TENDENCIES
+!    BY SOLVING THE PROGNOSTIC EQUATIONS IN PX95.
+!
+!  SUBROUTINES CALLED:
+!    SUB. QFLUX   compute the soil and canopy evaporation, and transpiration
+!    SUB. SMASS   compute nudging coefficients for soil moisture and temp nudging
+!
+!  ARGUMENTS:
+!    DTPBL:   TIME STEP OF THE MINOR LOOP FOR THE LAND-SURFACE/PBL MODEL
+!    IFLAND:  INDEX WHICH INDICATES THE TYPE OF SURFACE,=1,LAND;=2,SEA
+!    ISNOW:   SNOW (=1) OR NOT (=0)
+!    NUDGE:   SWITCH FOR SOIL MOISTURE NUDGING
+!    SOLDN:   SHORT-WAVE RADIATION
+!    LWDN:    LONG-WAVE RADIATION
+!    EMISSI:  EMISSIVITY
+!    Z1:      HEIGHT OF THE LOWEST HALF LAYER
+!    MOL:     MONIN-OBUKOV LENGH (M)
+!    ZNT:     ROUGHNESS LENGTH (M)
+!    UST:     FRICTION VELOCITY (M/S)
+!    TST:     Turbulent moisture scale
+!    RA:      AERODYNAMIC RESISTENCE
+!    PSURF:   P AT SURFACE (CB)
+!    DENS1:   AIR DENSITY AT THE FIRST HALF LAYER
+!    QV1:     Air humidity at first half layer
+!    QSS:     Saturation mixing ratio at ground
+!    TA1:     Air temperature at first half layer
+!    THETA1:  Potential temperature at first half layer
+!    PRECIP:  Precipitation rate in m/s
+!    STBOLT:  STEFAN BOLTZMANN'S CONSTANT
+!    KARMAN:  VON KARMAN CONSTANT
+!    CPAIR:   Specific heat of moist air (M^2 S^-2 K^-1)
+!    TAUINV:  1/1DAY(SEC)
+!    VEGFRC:  Vegetation coverage
+!    ISTI:    soil type
+!    LAI:     Leaf area index
+!    BETAP:   Coefficient for bare soil evaporation
+!    THZ1OB:  Observed TEMP FROM ANAL OF OBS TEMPS AT SCREEN HT
+!    RHOBS:   Observed relative humidity at SCREEN HT
+!    RSTMIN   Minimum Stomatol resistence
+!... Outputs from SURFPX
+!    RADNET: Net radiation
+!    HFX:    SENSIBLE HEAT FLUX (W / M^2)
+!    QFX:    TOTAL EVAP FLUX (KG / M^2 S)
+!    GRDFLX: Ground heat flux (W / M^2)
+!    QST:    Turbulent moisture scale
+!    CAPG:   THERMAL CAPACITY OF GROUND SLAB (J/M^2/K)
+!    RS:     Surface resistence
+!    RA:     Surface aerodynamic resistence
+!    EG:     evaporation from ground (bare soil)
+!    ER:     evaporation from canopy
+!    ETR:    transpiration from vegetation
+!    TA2:    diagnostic 2-m temperature from surface layer and lsm
+!
+!... Updated variables in this subroutine
+!    TG:     Soil temperature at first soil layer
+!    T2:     Soil temperature in root zone
+!    WG:     Soil moisture at first soil layer
+!    W2:     Soil moisture at root zone
+!    WR:     Canopy water content in m
+!
+!  REVISION HISTORY:
+!     AX     2/2005 - developed WRF version based on the MM5 PX LSM
+!
+!**********************************************************************
+!
+!----------------------------------------------------------------------
+!
+!.......Arguments
+
+!.. Integer
+      INTEGER , INTENT(IN)  :: ISTI, NUDGEX
+
+!... Real
+      REAL ,    INTENT(IN)  :: DTPBL, DS1, DS2
+      REAL ,    INTENT(IN)  :: IFLAND, ISNOW, XICE1
+      REAL ,    INTENT(IN)  :: SOLDN, GSW, LWDN, EMISSI, Z1
+      REAL ,    INTENT(IN)  :: ZNT
+      REAL ,    INTENT(IN)  :: PSURF, DENS1, QV1, QSS, TA1,  THETA1, PRECIP
+      REAL ,    INTENT(IN)  :: CPAIR
+      REAL ,    INTENT(IN)  :: VEGFRC, LAI
+      REAL ,    INTENT(IN)  :: RSTMIN, HC_SNOW, SNOW_FRA 
+      REAL ,    INTENT(IN)  :: WWLT, WFC, CGSAT, WSAT, B, C1SAT, C2R, AS, JP
+      REAL ,    INTENT(IN)  :: RH2OBS,T2OBS
+      REAL ,    INTENT(IN)  :: QST12
+
+      REAL ,    INTENT(OUT) :: RADNET, EG, ER, ETR
+      REAL ,    INTENT(OUT) :: QST, CAPG, RS, TA2, QA2
+
+      REAL ,    INTENT(INOUT) :: TG, T2, WG, W2, WR, UST, RA, BETAP 
+      REAL ,    INTENT(INOUT) :: GRDFLX, QFX, HFX, LH, PSIH, MOL
+
+!... Local Variables
+
+!... Real
+      REAL        :: HF, LV, CQ4 
+      REAL        :: RAH, RAW, ET, W2CG, CG, CT, SOILFLX, CPOT, THETAG
+      REAL        :: ZOL, ZOBOL, ZNTOL, Y, Y0, PSIH15, YNT
+      REAL        :: WGNUDG, W2NUDG, ALPH1, ALPH2, BET1, BET2, T1P5
+      REAL        :: CQ1, CQ2, CQ3, COEFFNP1, COEFFN, TSNEW, TSHLF, T2NEW
+      REAL        :: ROFF, WRMAX, PC, DWR, PNET, TENDWR, WRNEW
+      REAL        :: COF1, CFNP1WR, CFNWR, PG, FASS
+      REAL        :: TENDW2, W2NEW, W2HLF, W2REL, C1, C2, WEQ, CFNP1, CFN, WGNEW
+      REAL        :: ALN10, TMP1, TMP2, TMP3, AA, AB, TST, RBH, CTVEG
+      REAL        :: QST1,PHIH,PSIOB
+      REAL        :: T2NUD, T2NUDF
+      REAL        :: VAPPRS, QSBT, RH2MOD
+      REAL        :: A,BB,C,D
+
+!... Parameters
+      REAL        :: ZOBS, GAMAH, BETAH, SIGF, BH, CT_SNOW
+      REAL, PARAMETER :: CV = 8.0E-6   ! K-M2/J
+      PARAMETER (ZOBS  = 1.5)      ! height for observed screen temp., (m)
+      PARAMETER (BH    = 15.7)
+      PARAMETER (GAMAH = 16. )   !11.6)
+      PARAMETER (BETAH = 5.0 )   !8.21)
+      PARAMETER (SIGF  = 0.5)      ! rain interception see LSM (can be 0-1)
+      !PARAMETER (CT_SNOW  = 5.54E-5)   
+! New value of CT_SNOW calibrated using multilayer soil model where csnow=6.9E5 J/(m3 K) 
+! from NCAR CSM                                         
+      PARAMETER (CT_SNOW  = 2.0E-5)  
+      ALN10  = ALOG(10.0)
+        RADNET = SOLDN - (EMISSI *(STBOLT *TG **4 - LWDN))        ! NET RADIATION                             
+        !--------------------------------------------------------------------
+        CPOT= (100.0 / PSURF) ** ROVCP       ! rcp is global constant(module_model_constants)                            
+        THETAG = TG * CPOT
+
+        ZOL   = Z1/MOL                                                       
+        ZOBOL = ZOBS/MOL                                                      
+        ZNTOL = ZNT/MOL                              
+
+        !-----------------------------------------------------------------------------------------
+        IF (MOL .LT. 0.0) THEN
+          Y      = ( 1.0 - GAMAH * ZOL ) ** 0.5
+          Y0     = ( 1.0 - GAMAH * ZOBOL ) ** 0.5
+          YNT    = ( 1.0 - GAMAH * ZNTOL ) ** 0.5
+          PSIH15 =  2.0 * ALOG((Y + 1.0) / (Y0 + 1.0))
+          PSIH   =  2.0 * ALOG((Y + 1.0) / (YNT + 1.0))
+          PSIOB  =  2.0 * ALOG((Y0 + 1.0) / (YNT + 1.0))
+          PHIH = 1.0 / Y
+        ELSE
+          IF((ZOL-ZNTOL).LE.1.0) THEN                                         
+            PSIH = -BETAH*(ZOL-ZNTOL)                                        
+          ELSE                                                               
+            PSIH = 1.-BETAH-(ZOL-ZNTOL)                                      
+          ENDIF             
+          IF ((ZOBOL - ZNTOL) .LE. 1.0) THEN
+            PSIOB = -BETAH * (ZOBOL - ZNTOL)
+          ELSE
+            PSIOB = 1.0 - BETAH - (ZOBOL - ZNTOL)
+          ENDIF
+          PSIH15 =  PSIH - PSIOB
+          IF(ZOL.LE.1.0) THEN
+            PHIH = 1.0 + BETAH * ZOL
+          ELSE
+            PHIH = BETAH + ZOL
+          ENDIF
+        ENDIF
+        !-----------------------------------------------------------------------------------------
+         !-- ADD RA AND RB FOR HEAT AND MOISTURE
+        !... RB FOR HEAT = 5 /UST
+        !... RB FOR WATER VAPOR =  5*(0.599/0.709)^2/3 /UST = 4.503/UST
+        RA=PR0* ( ALOG(Z1/ZNT) - PSIH )/(KARMAN*UST)
+        RAH = RA + 5.0 / UST
+        RAW = RA + 4.503 / UST
+        !--------------------------------------------------------------------
+        !--  COMPUTE MOISTURE FLUX
+        CALL QFLUX( DENS1,  QV1,    TA1,  SOLDN,  RAW, QSS,            &
+                    VEGFRC, ISNOW,  ISTI, IFLAND, LAI, BETAP,          &
+                    WG,     W2,     WR,                                &
+                    RSTMIN, WWLT, WFC,                                 &
+                    EG,     ER,     ETR,  CQ4,    RS,  FASS)
+        !--------------------------------------------------------------------
+
+        !--------------------------------------------------------------------
+        !..........Total evaporation (ET)
+        ET  = EG + ER + ETR
+        QST = -ET / (DENS1 * UST)
+ 
+        LV = 2.83E6                         !-- LATENT HEAT OF SUBLIMATION AT 0C FROM STULL(1988)
+        IF (ISNOW .LT. 0.5.AND.TG.GT.273.15)                            &                                                                               
+                    LV = (2.501 - 0.00237 * (TG - 273.15)) * 1.E6  !-- FROM STULL(1988) in J/KG
+        
+        IF (IFLAND .LT. 1.5 )  QFX = ET     !-- Recaculate QFX over land to account for P-X LSM EG, ER and ETR
+        LH = LV * QFX
+        !-----------------------------------------------------------------------------------------
+
+        !-----------------------------------------------------------------------------------------
+        ! Surface sensible heat flux
+        TST = (THETA1 - THETAG ) / (UST*RAH)
+        HF = UST * TST           
+        HFX = AMAX1(-DENS1 * CPAIR * HF, -250.0)  ! using -250. from MM5                                   
+        !-----------------------------------------------------------------------------------------
+
+        !-----------------------------------------------------------------------------------------
+        ! Compute the diagnosed 2m Q and T consistent with PX LSM
+        QST1 = 0.5*(QST+QST12/PHIH)
+        TA2= (THETAG + TST * (PR0 / KARMAN * (ALOG(ZOBS / ZNT) - PSIOB)+5.))/CPOT
+        QA2= QV1 - QST1 * PR0/ KARMAN *  (ALOG(Z1 / ZOBS) - PSIH15)
+        IF (QA2.LE.0.0) QA2 = QV1
+        !--  Relative humidity
+        VAPPRS = SVP1 * EXP(SVP2 * (TA2 - SVPT0) / (TA2 - SVP3))
+        QSBT   = EP_2 * VAPPRS / (PSURF - VAPPRS)
+        RH2MOD  = QA2 / QSBT
+        !-----------------------------------------------------------------------------------------
+        IF (IFLAND .LT. 1.5 ) THEN
+          W2CG = AMAX1(W2,WWLT)
+          CG   = CGSAT * 1.0E-6 * (WSAT/ W2CG) **    &  
+                 (0.5 * B / ALN10)
+          CT = 1./((1-VEGFRC)/CG + VEGFRC/CV)
+          CT = 1./(SNOW_FRA/CT_SNOW + (1-SNOW_FRA)/CT)
+          CAPG = 1.0/CT          
+
+          SOILFLX = 2.0 * PI * TAUINV * (TG - T2)
+          GRDFLX  = SOILFLX / CT
+        ENDIF
+        !-----------------------------------------------------------------------------------------
+
+        !--------------------------------------------------------------------
+        !-- ASSIMILATION --- COMPUTE SOIL MOISTURE NUDGING FROM TA2 and RH2               
+        !-------COMPUTE ASSIMILATION COEFFICIENTS FOR ALL I                            
+        IF (IFLAND .LT. 1.5) THEN
+        IF (NUDGEX .EQ. 0) THEN                                          !-- NO NUDGING CASE                
+          WGNUDG = 0.0                                                        
+          W2NUDG = 0.0    
+          T2NUD  = 0.0                                    
+        ELSE                                                               !-- NUDGING CASE        
+            
+          CALL SMASS (ISTI,  FASS,  SOLDN,   VEGFRC, RA, WWLT, WFC,   &                       
+                      ALPH1, ALPH2, BET1, BET2, T2NUDF)                             
+
+          !--COMPUTE MODEL RH
+          WGNUDG = ALPH1 * (T2OBS - TA2) + ALPH2 * (RH2OBS - RH2MOD) * 100  
+          W2NUDG = BET1  * (T2OBS - TA2) + BET2  * (RH2OBS - RH2MOD) * 100
+          IF (W2 .GE. WFC)  W2NUDG = AMIN1(W2NUDG,0.0)
+          IF (W2 .LE. WWLT) W2NUDG = AMAX1(W2NUDG,0.0)
+          T2NUD = T2NUDF * (T2OBS - TA2)
+          !print *, 'T2NUD =',T2NUD,T2NUDF
+        ENDIF
+        ENDIF
+        !-----------------------------------------------------------------------------------------
+
+        !-----------------------------------------------------------------------------------------
+        !-- Compute new values for TS,T2,WG,W2 and WR. No change over ice or water (XLAND > 1)
+        IF (IFLAND .LT. 1.5) THEN
+
+          !-- SOLVE BY CRANK-NIC --   TENDTS=CT*(RADNET-HFX-QFX)-SOILFLX 
+          !-- Calculate the coefficients for implicit calculation of TG
+          CQ1      = (1.0 - 0.622 * LV * CRANKP / (r_d * TG)) * QSS
+          CQ2      = 0.622 * LV * QSS * CRANKP / (r_d * TG * TG)
+          CQ3      = DENS1 * BETAP * (1.0 - VEGFRC) / RAW
+          COEFFNP1 = 1.0 + DTPBL * CRANKP * (4.0 * EMISSI *  STBOLT * TG ** 3    &
+                     * CT + DENS1 * CPAIR / RAH * CPOT * CT + 2.0 * PI           &
+                     * TAUINV ) + DTPBL * (CT * LV * CQ2 * (CQ3 + CQ4))
+          COEFFN   = CT * (GSW + EMISSI * (STBOLT * (4.0 * CRANKP - 1.0)         &
+                     * TG*TG*TG*TG + LWDN)                                       & !NET RAD
+                     + DENS1 * CPAIR / RAH * (THETA1 - (1.0 - CRANKP) * THETAG)  &
+                     - LV * (CQ3 * (CQ1 - QV1) + CQ4 * (CQ1 - QV1)))             & !SFC HEAT FLUX 
+                     - 2.0 * PI * TAUINV * ((1.0 - CRANKP) * TG - T2)              !SOIL FLUX
+          TSNEW    = (TG + DTPBL * COEFFN) / COEFFNP1
+          !-- FOR SNOW COVERED SURFACE TEMPERATURE IS NOT MORE THAN ZERO
+          IF (XICE1 .GT. 0.5) TSNEW = AMIN1(TSNEW,273.15)                         ! Re-added Jan 2010 to keep ice surface at or below freezing (J. Pleim)
+          TSHLF = 0.5 * ( TSNEW + TG)
+          T2NEW = (T2 + DTPBL * TAUINV * T2TFAC * (TSHLF - (1 - CRANKP) * T2)     &
+                + DTPBL*T2NUD)  &              ! Added deep temperature nudging 
+                  / (1.0 + DTPBL * TAUINV * T2TFAC * CRANKP)
+          !-- REPLACE OLD with NEW Value
+          TG = TSNEW
+          T2 = T2NEW             
+        ENDIF
+        !-----------------------------------------------------------------------------------------
+
+        !-----------------------------------------------------------------------------------------
+	! Compute new subsurface soil and canopy moisture values DENS1. No change required over ocean.
+        IF (IFLAND .LT. 1.5.AND. XICE1.LT.0.5) THEN  
+          !-- Compute WR
+          ROFF  = 0.0
+          WRMAX = 0.2E-3 * VEGFRC * LAI                     ! max. WRMAX IN m
+          
+          IF(WRMAX.GT.0.0) THEN
+            !--  PC is precip. intercepted by veg.(M/S)
+            PC    = VEGFRC * SIGF * PRECIP
+            DWR   = (WRMAX - WR) / DTPBL                       !the tendency to reach max.
+            PNET  = PC - ER/ DENW                              ! residual of precip. and evap.
+            IF (PNET .GT. DWR) THEN
+              ROFF = PNET - DWR
+              PC   = PC - ROFF
+            ENDIF
+            IF (QSS .LT. QV1) THEN
+              TENDWR = PC - ER / DENW
+              WRNEW  = WR + DTPBL * TENDWR
+            ELSE
+              COF1    = DENS1 / DENW * VEGFRC * (QSS - QV1) / RAW
+              !-- using delta=wr/wrmax
+              CFNP1WR = 1.0 + DTPBL * COF1 * CRANKP / WRMAX  
+              CFNWR   = PC - COF1 * (1.0 - CRANKP) * WR / WRMAX
+              WRNEW   = (WR + DTPBL * CFNWR) / CFNP1WR
+            ENDIF
+          ELSE
+            WRNEW=0.0  
+          ENDIF
+          !---------------------------------------------
+          !-- Compute W2
+          PG     = DENW * (PRECIP - PC)               ! PG is precip. reaching soil (PC already including ROFF)
+          TENDW2 = 1.0 / (DENW * DS2) * (PG - EG - ETR) &
+                   + (W2NUDG + WGNUDG) / DS2                    ! NUDGING
+          W2NEW  = W2 + DTPBL * TENDW2
+          W2NEW  = AMIN1(W2NEW,WSAT)
+          W2NEW  = AMAX1(W2NEW,0.05)
+          W2HLF  = 0.5 * (W2 + W2NEW)
+          !.. new values
+          W2     = W2NEW
+          WR     = AMIN1(WRMAX,WRNEW)
+        ENDIF
+        !-----------------------------------------------------------------------------------------
+
+        !-----------------------------------------------------------------------------------------
+	! Compute new surface soil moisture values (WR).
+        IF (IFLAND .LT. 1.5.AND. XICE1.LT.0.5) THEN  ! over ocean no change to wg w2,wr
+        !--    FOR SNOW COVERED SURFACE, ASSUME SURFACE IS SATURATED AND
+        !      WG AND W2 ARE NOT CHANGED
+          IF (ISNOW .GT.0.5) THEN
+            WG = WSAT
+          ELSE
+            W2REL = W2HLF / WSAT
+            IF (WG .GT. WWLT) THEN
+              C1 = C1SAT * (WSAT / WG) ** (0.5 * B + 1.0) 
+            ELSE   ! elimilate C1 for wg < wilting point
+              C1 = C1SAT * (WSAT / WWLT) ** (0.5 * B + 1.0)
+            ENDIF
+            C2 = C2R * W2HLF / (WSAT - W2HLF + 1.E-11) 
+            IF (W2HLF .EQ. WSAT) THEN
+              WEQ = WSAT
+            ELSE
+              WEQ = W2HLF - AS * WSAT * W2REL ** JP *         &
+                   (1.0 - W2REL ** (8.0 * JP))
+            ENDIF
+
+            !.... The beta method, Lee & Pielke (JAM, May 1992)
+            CFNP1 = 1.0 + DTPBL * C2 * TAUINV * CRANKP
+            CFN   = C1 / (DENW * DS1) * (PG - EG) - C2 * TAUINV *               &
+                    ((1.0 - CRANKP) * WG - WEQ) + WGNUDG/ DS1                                    
+
+            WGNEW = AMAX1((WG + DTPBL * CFN) / CFNP1,0.001)
+            !-- NEW VALUES
+            WG    = AMIN1(WGNEW,WSAT)
+            
+          ENDIF                  !endif for ISNOW
+        ENDIF                    !endif for XLAND
+        !-----------------------------------------------------------------------------------------
+            
+      END SUBROUTINE surfpx
+!***********************************************************************
+!***********************************************************************
+
+!***********************************************************************
+!***********************************************************************
+      SUBROUTINE QFLUX (DENS1,  QV1,   TA1,  RG,     RAW, QSS,           & ! in
+                        VEGFRC, ISNOW, ISTI, IFLAND, LAI, BETAP,         & ! in
+                        WG,     W2,    WR,                               & ! in
+                        RSTMIN, WWLT,  WFC,                              &
+                        EG,     ER,    ETR,  CQ4,    RS,  FASS)            ! out
+
+!***********************************************************************
+!                                                              
+!  FUNCTION:                                                          
+!    THIS SUBROUTINE COMPUTES EVAPORATION FROM BARE SOIL (EG) AND FROM
+!    THE WET PART OF CANOPY (ER) AND TRANSPIRATION FROM THE DRY PART OF
+!    CANOPY (ETR).                       
+!                                        
+!  REVISION HISTORY: 
+!    A. Xiu       Oct  2004  - adapted from the PX LSM in MM5 for the WRF system                            
+!    R. Gilliam   Dec  2006  - Completed WRF V2.1.2 implementation                                 
+!                                                               
+!***********************************************************************
+!  QFLUX ARGUMENT LIST:                                                        
+! ----------------------------------------------------------------------
+! INPUTS:
+!-- DENS1        air density at first layer
+!-- QV1          air humidity at first layer
+!-- TA1          air temperature at first layer
+!-- RG           shortwave radition reaching the ground
+!-- RAW          RA+RB for moisture
+!-- QSS          saturation mixing ratio at ground
+!-- VEGFRC       vegetation coverage
+!-- ISNOW        if snow on the ground 
+!-- ISTI         soil type
+!-- IFLAND       if land (=1) or water (=2)
+!-- LAI          leaf area index
+!-- BETAP        
+!-- WG           soil moisture at first soil layer
+!-- W2           soil moisture at root zone
+!-- WR           Canopy water
+!
+!  OUTPUTS FROM QFLUX:
+!-- EG           evaporation from ground (bare soil)
+!-- ER           evaporation from canopy
+!-- ETR          transpiration from vegetation
+!-- CQ4
+!-- RS           surface resistence
+!-- FASS         parameter for soil moisture nudging
+! ----------------------------------------------------------------------
+
+      IMPLICIT NONE
+
+! ----------------------------------------------------------------------
+! DECLARATIONS - INTEGER
+      INTEGER , INTENT(IN)  :: ISTI
+
+! ----------------------------------------------------------------------
+! DECLARATIONS - REAL
+      REAL ,    INTENT(IN)  :: ISNOW, IFLAND
+      REAL ,    INTENT(IN)  :: DENS1, QV1, TA1, RG, RAW, QSS,            &
+                               VEGFRC, LAI,                              &
+                               WG, W2, WR, RSTMIN   
+      REAL ,    INTENT(INOUT)  :: BETAP
+      REAL,     INTENT(IN)   :: WWLT, WFC
+
+      REAL ,    INTENT(OUT) :: EG, ER, ETR, CQ4, RS, FASS
+
+!... Local Variables
+
+!... Real
+      REAL    :: WRMAX, DELTA, SIGG, RADL, RADF, W2AVAIL, W2MXAV
+      REAL    :: FTOT, F1, F2, F3,  F4
+      REAL    :: FSHELT, GS, GA, FX
+
+
+
+!... Parameters
+      REAL, PARAMETER :: RSMAX = 5000.0                ! s/m
+      REAL, PARAMETER :: FTMIN = 0.0000001             ! m/s
+      REAL, PARAMETER :: F3MIN = 0.25
+
+!
+!... for water surface, no canopy evaporation and transpiration
+      ER  = 0.0
+      ETR = 0.0
+      CQ4 = 0.0
+      
+!... GROUND EVAPORATION (DEPOSITION)
+      IF (QSS .LT. QV1) BETAP = 1.0
+      EG = DENS1 * (1.0 - VEGFRC) * BETAP * (QSS - QV1) / RAW
+
+      !!---------------------------------------------------------------------
+!... CANOPY
+      IF (IFLAND .LT. 1.5 .AND. VEGFRC .GT. 0.0)  THEN
+         WRMAX = 0.2E-3 * VEGFRC * LAI   ! in unit m
+          IF (WR .LE. 0.0) THEN
+            DELTA = 0.0
+          ELSE
+!            DELTA = (WR / WRMAX) ** 0.66667
+            DELTA = WR / WRMAX           ! referred to SiB model
+          ENDIF
+          IF (QSS .GE. QV1) THEN
+            SIGG = DELTA
+          ELSE
+            SIGG = 1.0
+          ENDIF
+
+          ER = DENS1 * VEGFRC * SIGG * (QSS - QV1) / RAW  
+!         IF(ER.GT.0.5E-3)PRINT *,' WR,SIGG,DENS1,VEGFRC,QSS,QV1,RAW=', &
+!                  WR,SIGG,DENS1,VEGFRC,QSS,QV1,RAW,' ER=',ER
+      ENDIF
+      !!---------------------------------------------------------------------
+
+      !-- TRANSPIRATION
+      !!---------------------------------------------------------------------
+      IF (IFLAND .LT. 1.5 .AND. VEGFRC .GT. 0.0)  THEN
+        
+        !!!-RADIATION
+        IF (RSTMIN .GT. 130.0) THEN
+          RADL = 30.0                                            ! W/M2
+        ELSE
+          RADL = 100.0                                           ! W/M2
+        ENDIF
+        RADF = 1.1 * RG / (RADL * LAI)                  ! NP89 - EQN34
+        F1   = (RSTMIN / RSMAX + RADF) / (1.0 + RADF)
+
+        !!!-SOIL MOISTURE
+        W2AVAIL = W2 - WWLT
+        W2MXAV  = WFC - WWLT
+        F2      = 1.0 / (1.0 + EXP(-5.0 * ( W2AVAIL / W2MXAV -               &
+                  (W2MXAV / 3.0 + WWLT))))    ! according JP, 9/94
+
+        !-AIR TEMP
+        !... according to Avissar (1985) and AX 7/95
+        IF (TA1 .LE. 302.15) THEN
+          F4 = 1.0 / (1.0 + EXP(-0.41 * (TA1 - 282.05)))
+        ELSE
+          F4 = 1.0 / (1.0 + EXP(0.5 * (TA1 - 314.0)))
+        ENDIF
+
+        FTOT = LAI * F1 * F2 * F4
+      ENDIF
+
+      !!---------------------------------------------------------------------
+      IF (IFLAND .LT. 1.5 .AND. VEGFRC .GT. 0.0)  THEN
+        FSHELT = 1.0   ! go back to NP89
+        GS     = FTOT / (RSTMIN * FSHELT)
+        GA     = 1.0 / RAW
+        !-- Compute humidity effect according to RH at leaf surf
+        F3 = 0.5 * (GS - GA + SQRT(GA * GA + GA * GS *                       &
+             (4.0 * QV1 / QSS - 2.0) + GS * GS)) / GS
+        F3 = AMIN1(AMAX1(F3,F3MIN),1.0)
+
+        RS = 1.0 / (GS * F3)
+        
+        !IF(RS .GT. 999999.0) THEN
+        !  print *,'RS,LAI,VEGFRC,ISTI-->',RS,LAI,VEGFRC,ISTI,ISNOW
+        !ENDIF
+        
+        !--- Compute Assimilation factor for soil moisture nudging - jp 12/94
+        !--  Note that the 30 coef is to result in order 1 factor for max
+        IF (RG .LT. 0.00001) THEN   ! do not nudge during night
+          FX = 0.0
+        ELSE
+          FX = 30.0 * F1 * F4 * LAI / (RSTMIN * FSHELT)
+        ENDIF
+
+        FASS = FX
+        ETR = DENS1 * VEGFRC * (1.0 - SIGG) * (QSS - QV1) / (RAW + RS)
+        !..... CQ4 is used for the implicit calculation of TG in SURFACE
+        CQ4 = DENS1 * VEGFRC * ((1.0 - SIGG) / (RAW + RS) + SIGG / RAW)
+      ENDIF         
+      !!---------------------------------------------------------------------
+
+    END SUBROUTINE qflux
+!------------------------------------------------------------------------------------------
+!------------------------------------------------------------------------------------------
+
+!------------------------------------------------------------------------------------------
+      SUBROUTINE SMASS (ISTI,  FASS,  RG,   VEGFRC, RA,              & !in                      
+                        WWLT, WFC,                                   &
+                        ALPH1, ALPH2, BET1, BET2, T2NUDF )             !out  
+!------------------------------------------------------------------------------------------
+      IMPLICIT NONE
+!*******************************************************************
+!     SMASS COMPUTES SOIL MOISTURE NUDGING COEFFICIENTS
+!*******************************************************************
+!
+!.........Arguments
+      INTEGER, PARAMETER             :: NSCAT    = 16     ! max. soil types
+      
+      INTEGER,                   INTENT(IN)   :: ISTI 
+      REAL,                      INTENT(IN)   :: FASS, RG, VEGFRC, RA
+      REAL,                      INTENT(IN)   :: WWLT, WFC
+      REAL,                      INTENT(OUT)  :: ALPH1, ALPH2, BET1, BET2, T2NUDF
+
+
+!........Local variables
+
+!... Real
+      REAL    :: FBET, FALPH, FRA, FTEXT
+      REAL,    DIMENSION( 1: NSCAT ) :: WFCX, WWLTX
+      
+!... Parameters
+      REAL, PARAMETER  :: A1MAX = -10.E-5, A2MAX = 1.E-5  ! m/K, m for 6hr period
+      REAL, PARAMETER  :: B1MAX = -10.E-3, B2MAX = 1.E-3  ! m/K, m (Bouttier et al 1993)
+      REAL, PARAMETER  :: TASSI = 4.6296E-5               ! 1/6hr in 1/sec
+      REAL, PARAMETER  :: RAMIN = 10.0                    ! 0.1 s/cm
+!
+!-- WFC is field capacity (M^3/M^3) (JN90)
+      DATA WFCX   /  0.135, 0.150, 0.195, 0.255, 0.240, 0.255, 0.322,    &
+                    0.325, 0.310, 0.370, 0.367, 0.367, 0.367, 0.367, 0.367, 0.367 /
+!
+!-- WWLT is wilting point (M^3/M^3) (JN90)
+      DATA WWLTX  /  0.068, 0.075, 0.114, 0.179, 0.155, 0.175, 0.218,    &
+                    0.250, 0.219, 0.283, 0.286, 0.286, 0.286, 0.286, 0.286, 0.286 /
+
+!
+      FBET  = FASS
+      FALPH = RG / 1370.0
+!--TEXTURE FACTOR NORMALIZED BY LOAM (IST=5)
+      FRA   = RAMIN / RA            ! scale by aerodynamic resistance
+      FTEXT = TASSI * (WWLT + WFC) / (WWLTX(5) + WFCX(5)) * FRA
+!        write(6,*) ' ftot, fbet=',ftot, fbet,' ftext=',ftext/tassi
+!
+      ALPH1 = A1MAX * FALPH * (1.0 - VEGFRC) * FTEXT
+      ALPH2 = A2MAX * FALPH * (1.0 - VEGFRC) * FTEXT
+      BET1  = B1MAX * FBET  *        VEGFRC  * FTEXT
+      BET2  = B2MAX * FBET  *        VEGFRC  * FTEXT
+      T2NUDF = 1.0E-5 * MAX((1.0 - 5.0 * FALPH),0.0)   ! T2 Nudging at night
+
+    END SUBROUTINE smass
+!------------------------------------------------------------------------------------------
+!------------------------------------------------------------------------------------------
+!------------------------------------------------------------------------------------------
+      SUBROUTINE SOILPROP (SOILCBOT,WEIGHT, ITIMESTEP, MAVAIL, &  ! IN
+                           PXLSM_SMOIS_INIT,                   &  ! IN
+                           FWSAT,FWFC,FWWLT,FB,FCGSAT,         &  ! OUT
+                           FJP,FAS,FC2R,FC1SAT,ISTI, W2        )  ! OUT
+      IMPLICIT NONE
+      !*******************************************************************
+      !     SOILPROP COMPUTES SOIL PARAMETERS FOR BOTH BOTTOM AND TOP LAYERS
+      !              USING FRACTIONAL SOIL TYPE. A HARD CODED OPTION IS AVAILIABLE
+      !              TO COMPUTE THE SOIL PARAMETERS USING FRACTIONAL INFORMATION, OR
+      !              TO JUST USE SOIL PARAMETERS OF THE DOMINANT SOIL TYPE
+      !*******************************************************************
+     !------------------------------------------------------------------------
+     !-- SOIL PARAMETERS ARE SPECIFIED BY SOIL TYPE: 
+     !   #  SOIL TYPE  WSAT  WFC  WWLT    B   CGSAT   JP   AS   C2R  C1SAT
+     !   _  _________  ____  ___  ____  ____  _____   ___  ___  ___  _____
+     !   1  SAND       .395 .135  .068  4.05  3.222    4  .387  3.9  .082
+     !   2  LOAMY SAND .410 .150  .075  4.38  3.057    4  .404  3.7  .098
+     !   3  SANDY LOAM .435 .195  .114  4.90  3.560    4  .219  1.8  .132
+     !   4  SILT LOAM  .485 .255  .179  5.30  4.418    6  .105  0.8  .153
+     !   4  SILT       .485 .255  .179  5.30  4.418    6  .105  0.8  .153 NP89 does not have Silt so mapped to Silt Loam
+     !   5  LOAM       .451 .240  .155  5.39  4.111    6  .148  0.8  .191
+     !   6  SND CLY LM .420 .255  .175  7.12  3.670    6  .135  0.8  .213
+     !   7  SLT CLY LM .477 .322  .218  7.75  3.593    8  .127  0.4  .385
+     !   8  CLAY LOAM  .476 .325  .250  8.52  3.995   10  .084  0.6  .227
+     !   9  SANDY CLAY .426 .310  .219 10.40  3.058    8  .139  0.3  .421
+     !  10  SILTY CLAY .482 .370  .283 10.40  3.729   10  .075  0.3  .375
+     !  11  CLAY       .482 .367  .286 11.40  3.600   12  .083  0.3  .342
+     !------------------------------------------------------------------------
+     !
+     !.........Arguments
+      INTEGER, PARAMETER             :: NSCAT    = 16     ! max. soil types
+      INTEGER, PARAMETER             :: NSCATMIN = 16     ! min soil types
+
+      INTEGER,                      INTENT(IN)   :: WEIGHT, ITIMESTEP, PXLSM_SMOIS_INIT
+      REAL,                         INTENT(IN)   :: MAVAIL
+      REAL,     DIMENSION(1:NSCAT), INTENT(IN)   :: SOILCBOT
+      REAL,                         INTENT(OUT)  :: FWSAT,FWFC,FWWLT,FB,FCGSAT,          &
+                                                    FJP,FAS,FC2R,FC1SAT
+      REAL,                         INTENT(INOUT)  :: W2
+
+
+      INTEGER,                      INTENT(OUT)  :: ISTI
+!........Local variables
+      CHARACTER*4, AVCLASS
+      CHARACTER*4, DIMENSION( 1: NSCAT ) ::  TEXID 
+!... Integer
+      INTEGER:: S
+!... Real
+      REAL:: TFRACBOT, CFRAC, SUMSND, SUMCLY, AVS, AVC, AVSLT
+      REAL,    DIMENSION( 1: NSCAT ) :: WSAT, WFC, WWLT, B, CGSAT, AS,  &
+                                        JP, C2R, C1SAT
+
+      REAL,    DIMENSION( 1: NSCATMIN ) ::  SAND, CLAY
+!.......... DATA statement for SOIL PARAMETERS for the 11 soil types
+      DATA SAND /92.5,80.5,61.1,19.6,4.0,40.0,57.1,11.3,26.8,       &
+                 52.0,6.5,10.2,1.0,1.0,1.0,1.0/                                                  
+      DATA CLAY/2.1,4.1,10.9,19.1,7.3,18.8,23.3,32.2,36.6,          &                     
+                43.0,46.2,58.8,1.0,1.0,1.0,1.0/                                                 
+      DATA TEXID/'Sand','Lsan','Sloa','Sill','Silt','Loam','Sclo',  &             
+                 'Sicl','Cllo','Sacl','Sicy','Clay','Ormt','Wate',  &           
+                 'Bedr','Othe'/                                         
+
+!
+!-- WSAT is saturated soil moisture (M^3/M^3) (JN90)
+      DATA WSAT  /  0.395, 0.410, 0.435, 0.485, 0.451, 0.420, 0.477,    &
+                    0.476, 0.426, 0.482, 0.482, 0.482, 0.482, 0.482, 0.482, 0.482 /
+!
+!-- WFC is field capacity (M^3/M^3) (JN90)
+      DATA WFC   /  0.135, 0.150, 0.195, 0.255, 0.240, 0.255, 0.322,    &
+                    0.325, 0.310, 0.370, 0.367, 0.367, 0.367, 0.367, 0.367, 0.367 /
+!
+!-- WWLT is wilting point (M^3/M^3) (JN90)
+      DATA WWLT  /  0.068, 0.075, 0.114, 0.179, 0.155, 0.175, 0.218,    &
+                    0.250, 0.219, 0.283, 0.286, 0.286, 0.286, 0.286, 0.286, 0.286 /
+!
+!-- B is slop of the retention curve (NP89)
+      DATA B     /  4.05,  4.38,  4.90,  5.30,  5.39,  7.12,  7.75,     &
+                    8.52, 10.40, 10.40, 11.40, 11.40, 11.40, 11.40, 11.40, 11.40  /
+!
+!-- CGSAT is soil thermal coef. at saturation (10^-6 K M^2 J^-1) (NP89)
+      DATA CGSAT /  3.222, 3.057, 3.560, 4.418, 4.111, 3.670, 3.593,    &
+                    3.995, 3.058, 3.729, 3.600, 3.600, 3.600, 3.600, 3.600, 3.600 /
+!
+!-- JP is coefficient of WGEQ formulation (NP89)
+      DATA JP    /  4,     4,     4,     6,     6,     6,     8,        &
+                   10,     8,    10,    12,    12,    12,    12,    12,    12     /
+!
+!-- AS is coefficient of WGEQ formulation (NP89)
+      DATA AS    /  0.387, 0.404, 0.219, 0.105, 0.148, 0.135, 0.127,    &
+                    0.084, 0.139, 0.075, 0.083, 0.083, 0.083, 0.083, 0.083, 0.083 /
+!
+!-- C2R is the value of C2 for W2=0.5WSAT (NP89)
+      DATA C2R   /  3.9,   3.7,   1.8,   0.8,   0.8,   0.8,   0.4,      &
+                    0.6,   0.3,   0.3,   0.3,   0.3,   0.3,   0.3,   0.3,   0.3   /
+!
+!-- C1SAT is the value of C1 at saturation (NP89)
+      DATA C1SAT /  0.082, 0.098, 0.132, 0.153, 0.191, 0.213, 0.385,    &
+                    0.227, 0.421, 0.375, 0.342, 0.342, 0.342, 0.342, 0.342, 0.342 /
+!   
+!-------------------------------Exicutable starts here--------------------
+
+    IF(WEIGHT.GE.1.0) THEN   !Compute soil characteristics using weighting determined by fractional soil content
+     FWSAT =0
+     FWFC  =0
+     FWWLT =0
+     FB    =0
+     FCGSAT=0
+     FJP   =0
+     FAS   =0
+     FC2R  =0
+     FC1SAT=0
+     TFRACBOT =0
+     CFRAC=0
+     
+     DO S=1,NSCAT
+      IF(SOILCBOT(S).GE.CFRAC) THEN
+        ISTI=S
+        CFRAC=SOILCBOT(S)
+      ENDIF
+      
+      TFRACBOT=TFRACBOT+SOILCBOT(S)
+      
+      FWSAT =FWSAT  +  WSAT(S)  *SOILCBOT(S)
+      FWFC  =FWFC   +  WFC(S)   *SOILCBOT(S)
+      FWWLT =FWWLT  +  WWLT(S)  *SOILCBOT(S)
+      FB    =FB     +  B(S)     *SOILCBOT(S)
+      FCGSAT=FCGSAT +  CGSAT(S) *SOILCBOT(S)
+      FJP   =FJP    +  JP(S)    *SOILCBOT(S)
+      FAS   =FAS    +  AS(S)    *SOILCBOT(S)
+      FC2R  =FC2R   +  C2R(S)   *SOILCBOT(S)
+      FC1SAT=FC1SAT +  C1SAT(S) *SOILCBOT(S)
+      
+      
+     ENDDO
+
+     TFRACBOT = 1/TFRACBOT
+     FWSAT =FWSAT   *  TFRACBOT
+     FWFC  =FWFC    *  TFRACBOT
+     FWWLT =FWWLT   *  TFRACBOT
+     FB    =FB      *  TFRACBOT
+     FCGSAT=FCGSAT  *  TFRACBOT
+     FJP   =FJP     *  TFRACBOT
+     FAS   =FAS     *  TFRACBOT
+     FC2R  =FC2R    *  TFRACBOT
+     FC1SAT=FC1SAT  *  TFRACBOT
+    
+    ELSE                !Compute soil characteristics by sand and clay fraction
+    
+      CFRAC      = 0.0                                                               
+      SUMSND     = 0.0                                                               
+      SUMCLY     = 0.0                                                               
+      TFRACBOT   = 0.0                                                              
+                                                                                
+      DO S = 1,12  !NSCAT                                                          
+         TFRACBOT  = TFRACBOT  + SOILCBOT(S)
+         SUMSND    = SUMSND    + SAND(S) * SOILCBOT(S)
+         SUMCLY    = SUMCLY    + CLAY(S) * SOILCBOT(S)
+         
+         IF(SOILCBOT(S).GE.CFRAC) THEN   ! Find Dominant Category and fraction
+           ISTI=S
+           CFRAC=SOILCBOT(S)
+         ENDIF
+      ENDDO
+         
+      IF(TFRACBOT.GT.0.001) THEN                                                  
+        AVS = SUMSND / TFRACBOT                                               
+        AVC = SUMCLY / TFRACBOT                                           
+        AVSLT = 100 - AVS - AVC                                   
+        
+        IF(AVS.GT.(85.+ 0.5*AVC)) THEN                            
+          AVCLASS= 'Sand'                                                   
+          ISTI = 1                                                          
+        ELSE IF(AVS.GT.(70.+ AVC)) THEN                    
+          AVCLASS= 'Lsan'                                             
+          ISTI = 2                                                  
+        ELSE IF((AVC.LT.20..AND.AVS.GT.52.) &        
+                .OR.(AVC.LE.7.5.AND.AVSLT.LT.50.)) THEN                
+          AVCLASS= 'Sloa'                                             
+          ISTI = 3                                                     
+        ELSE IF(AVC.LT.35..AND.AVS.GT.45..AND.AVSLT.LT.28.) THEN      
+          AVCLASS= 'Sclo'                                                  
+          ISTI = 6                                                     
+        ELSE IF(AVC.GE.35..AND.AVS.GT.45.) THEN                           
+          AVCLASS = 'Sacl'                                                  
+          ISTI = 9                                                         
+        ELSE IF(AVC.LT.27.0.AND.AVSLT.LT.50.) THEN                        
+          AVCLASS= 'Loam'                                                
+          ISTI = 5                                                        
+        ELSE IF(AVC.LT.12..AND.AVSLT.GT.80.) THEN                
+          AVCLASS = 'Silt'                                         
+          ISTI = 4                                                           
+        ELSE IF(AVC.LT.27.) THEN                                                 
+          AVCLASS = 'Sill'                                                       
+          ISTI = 4                                                              
+        ELSE IF(AVC.LT.40..AND.AVS.GT.20.) THEN                                  
+          AVCLASS = 'Cllo'                                                       
+          ISTI = 8                                                               
+        ELSE IF(AVC.LT.40.) THEN                                                 
+          AVCLASS = 'Sicl'                                                       
+          ISTI = 7                                                               
+        ELSE IF(AVSLT.GE.40.) THEN                                               
+          AVCLASS = 'Sicy'                                                       
+          ISTI = 10                                                              
+        ELSE                                                                     
+          AVCLASS = 'Clay'                                                       
+          ISTI = 11                                                              
+        ENDIF                                                                    
+      
+      ELSE
+        ISTI=5
+        AVCLASS = TEXID(ISTI)  
+      ENDIF
+     FWSAT =WSAT(ISTI)   
+     FWFC  =WFC(ISTI)    
+     FWWLT =WWLT(ISTI)   
+     FB    =B(ISTI)      
+     FCGSAT=CGSAT(ISTI)  
+     FJP   =JP(ISTI)     
+     FAS   =AS(ISTI)     
+     FC2R  =C2R(ISTI)   
+     FC1SAT=C1SAT(ISTI)  
+                         
+    
+    ENDIF
+    
+    ! Compute W2 using soil moisture availiability if pxlsm_smois_init (in namelist) is not zero
+    IF (ITIMESTEP .EQ. 1 .AND. PXLSM_SMOIS_INIT .GT. 0) THEN
+       W2 = FWWLT + (0.5*(FWSAT+FWFC) - FWWLT)  * MAVAIL 
+    ENDIF                                                                    
+    
+    END SUBROUTINE soilprop
+!------------------------------------------------------------------------------------------
+!------------------------------------------------------------------------------------------
+      SUBROUTINE PXSNOW (ITIMESTEP, ASNOW, CSNOW, SNOW,       &
+                         SNOWH, SNUP,                         &
+                         ALB, SNOALB, SHDFAC, SHDMIN,         & 
+                         HC_SNOW, SNOW_FRA, SNOWC, SNOWALB)                   
+!------------------------------------------------------------------------------------------
+      IMPLICIT NONE
+!*******************************************************************
+!     Pleim-Xiu LSM Snow model
+!*******************************************************************
+!---------------------------------------------------------------------------------------------------
+!     ITIMESTEP -- Model time step index
+!     ASNOW --  Analyzed snow water equivalent (mm)
+!     CSNOW --  Current snow water equivalent (mm)
+!     SNOW  --  Snow water equivalent in model (mm)
+!     SNOWH --  Physical snow depth (m)
+!     SNUP --   Physical snow depth (landuse dependent) where when below, snow cover is fractional
+!
+!     HC_SNOW -- Heat capacity of snow as a function of depth
+!     SNOW_FRA-- Factional snow area 
+!     IFSNOW  -- Snow flag
+!     SNOWALB -- Snow albedo
+!---------------------------------------------------------------------------------------------------
+!---  Arguments
+      REAL, PARAMETER  :: W2SN_CONV   =   10.0
+      REAL, PARAMETER  :: CS_SNOWPACK = 2092.0
+      REAL, PARAMETER  :: SALP        =    2.6
+!-----------------------------------------------
+      INTEGER,       INTENT(IN)    :: ITIMESTEP
+      REAL,          INTENT(IN)    :: ASNOW, CSNOW, SNUP, ALB, SNOALB, SHDFAC, SHDMIN
+      REAL,          INTENT(INOUT) :: SNOW, SNOWH, SNOWC
+      REAL,          INTENT(OUT)   :: HC_SNOW, SNOW_FRA, SNOWALB
+!------------------------------------------------------------------------------------
+
+                                                   
+!-----------------------------------------------
+!    Local variables
+     !... Real
+     REAL:: CONV_WAT2SNOW, CSNOWW, RHO_SNOWPACK,   &
+            LIQSN_RATIO, SNEQV, RSNOW
+!-----------------------------------------------
+             
+     SNEQV=ASNOW*0.001			  ! Snow water in meters
+     RHO_SNOWPACK = 450                   ! Snowpack density (kg/m3), this should be computed in the future
+     LIQSN_RATIO  = DENW/RHO_SNOWPACK     ! Ratio of water density and snowpack density
+     
+     CONV_WAT2SNOW = LIQSN_RATIO/1000     ! Conversion factor for snow liquid equiv. (mm) to snowpack (m)
+      
+     SNOW = ASNOW                         ! Set snow water to analysis value for now, implement a nudging scheme later
+     SNOWH= SNOW * CONV_WAT2SNOW          ! Conversion of snow water (mm) to snow depth (m)     
+     
+     
+     ! Is snow cover now present. The limit is 0.45 mm of water eqivalent or about 2 inches snow depth 
+     SNOWC = 0.0
+     IF (SNOWH .GT. 0.005) SNOWC = 1.0  
+     
+     HC_SNOW = RHO_SNOWPACK * CS_SNOWPACK * SNOWH
+     
+      IF (SNEQV < SNUP) THEN                                                  
+         RSNOW = SNEQV / SNUP                                                    
+         SNOW_FRA = 1. - ( EXP ( - SALP * RSNOW) - RSNOW * EXP ( - SALP))          
+      ELSE                                                                       
+         SNOW_FRA = 1.0                                                            
+      END IF   
+      
+      SNOWC  = SNOW_FRA
+
+      SNOWALB = ALB + SNOWC*(SNOALB-ALB)
+
+    END SUBROUTINE pxsnow
+
+END MODULE module_sf_pxlsm
+
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_pxsfclay.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_pxsfclay.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_pxsfclay.F	(revision 17)
@@ -0,0 +1,538 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+MODULE module_sf_pxsfclay
+
+ REAL    , PARAMETER ::  RICRIT = 0.25            !critical Richardson number
+ REAL    , PARAMETER ::  BETAH  = 5.0    ! 8.21
+ REAL    , PARAMETER ::  BETAM  = 5.0    ! 6.0
+ REAL    , PARAMETER ::  BM     = 13.0
+ REAL    , PARAMETER ::  BH     = 15.7
+ REAL    , PARAMETER ::  GAMAM  = 19.3
+ REAL    , PARAMETER ::  GAMAH  = 11.6
+ REAL    , PARAMETER ::  PR0    = 0.95
+ REAL    , PARAMETER ::  CZO    = 0.032
+ REAL    , PARAMETER ::  OZO    = 1.E-4
+ REAL    , PARAMETER ::  VCONVC = 1.0
+
+
+CONTAINS
+
+!-------------------------------------------------------------------
+   SUBROUTINE PXSFCLAY(U3D,V3D,T3D,TH3D,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, &
+                     U10,V10,                                      &
+                     GZ1OZ0,WSPD,BR,ISFFLX,DX,                     &
+                     SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,          &
+                     ids,ide, jds,jde, kds,kde,                    &
+                     ims,ime, jms,jme, kms,kme,                    &
+                     its,ite, jts,jte, kts,kte                     )
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+!   THIS MODULE COMPUTES SFC RELATED PARAMETERS (U*, RA, REGIME, etc.)
+!   USING A MODIFIED RICHARDSON NUMBER PARAMETERIZATIONS.
+!
+!   THE PARAMETERIZATIONS OF THE PSI FUNCTIONS FOR UNSTABLE CONDITIONS
+!   HAVE BEEN REPLACED WITH EMPIRICAL EXPRESSIONS WHICH RELATE RB DIRECTLY
+!   TO PSIH AND PSIM.  THESE EXPRESSIONS ARE FIT TO THE DYER (1974) FUNCTIONS
+!   WITH HOGSTROM (1988) REVISED COEFFICIENTS.  ALSO, THESE EXPERESSIONS
+!   ASSUME A LAMINAR SUBLAYER RESISTANCE FOR HEAT (Rb = 5/U*)   - JP 8/01
+! 
+!   Reference: Pleim (2006): JAMC, 45, 341-347
+!
+!  REVISION HISTORY:
+!     A. Xiu        2/2005 - developed WRF version based on the MM5 PX LSM
+!     R. Gilliam    7/2006 - completed implementation into WRF model
+!*********************************************************************** 
+!-------------------------------------------------------------------
+!-- U3D         3D u-velocity interpolated to theta points (m/s)
+!-- V3D         3D v-velocity interpolated to theta points (m/s)
+!-- T3D         temperature (K)
+!-- TH3D        potential 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 (j/kg)
+!-- PSFC        surface pressure (Pa)
+!-- CHS         exchange coefficient for heat (m/s)
+!-- CHS2        exchange coefficient for heat at 2 m (m/s)
+!-- CQS2        exchange coefficient for moisture at 2 m (m/s)
+!-- CPM         heat capacity at constant pressure for moist air (J/kg/K)
+!-- 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 (m/s)
+!-- FLQC        exchange coefficient for moisture (m/s)
+!-- QGH         lowest-level saturated mixing ratio
+!-- QSFC        SPECIFIC HUMIDITY AT LOWER BOUNDARY				
+!-- RMOL        inverse Monin-Obukhov length (1/m)
+!-- 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
+!-- 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
+!-- 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
+!
+      REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
+                INTENT(IN   )   ::                           dz8w
+                                        
+      REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
+                INTENT(IN   )   ::                           QV3D, &
+                                                              P3D, &
+                                                              T3D, &
+                                                             TH3D
+
+      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+                INTENT(IN   )               ::             MAVAIL, &
+                                                             PBLH, &
+                                                            XLAND, &
+                                                              TSK
+      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+                INTENT(OUT  )               ::                U10, &
+                                                              V10, &
+                                                             QSFC
+!
+      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, &
+                                                             TH1D
+
+      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)
+           TH1D(i) =TH3D(i,1,j)
+        ENDDO
+        
+        
+        !  TST, WST, MOLENGTH, USTM need to be recaculated or passed in
+        
+        CALL PXSFCLAY1D(J,U1D,V1D,T1D,TH1D,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),     &
+                U10(ims,j),V10(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,               &
+                ids,ide, jds,jde, kds,kde,                         &
+                ims,ime, jms,jme, kms,kme,                         &
+                its,ite, jts,jte, kts,kte                          )
+      ENDDO
+
+
+   END SUBROUTINE PXSFCLAY
+!====================================================================
+   SUBROUTINE PXSFCLAY1D(J,US,VS,T1D,THETA1,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,TG,                             &
+                     U10,V10,FLHC,FLQC,QGH,                        &
+                     QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX,             &
+                     SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,          &
+                     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
+
+!
+      REAL,     DIMENSION( ims:ime )                             , &
+                INTENT(IN   )               ::             MAVAIL, &
+                                                             PBLH, &
+                                                            XLAND, &
+                                                              TG
+!
+      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, &
+                                                          QSFC,LH
+                                    
+      REAL,     INTENT(IN   )                    ::   CP,G,ROVCP,XLV,DX,R
+
+! MODULE-LOCAL VARIABLES, DEFINED IN SUBROUTINE SFCLAY
+      REAL,     DIMENSION( its:ite ),  INTENT(IN   )   ::  dz8w1d
+
+      REAL,     DIMENSION( its:ite ),  INTENT(IN   )   ::      US, &
+                                                               VS, &
+                                                             QV1D, &
+                                                              P1D, &
+                                                              T1D, &
+                                                           THETA1
+ 
+! LOCAL VARS
+
+      REAL,     DIMENSION( its:ite )        ::                 ZA, &
+                                                              TH0, &
+                                                           THETAG, &
+                                                               WS, &
+                                                            RICUT, &
+                                                             USTM, &
+                                                               RA, &
+                                                          THETAV1, &
+                                                         MOLENGTH
+!
+      REAL,     DIMENSION( its:ite )        ::                     &
+                                                      RHOX,GOVRTH  
+!
+      REAL,     DIMENSION( its:ite )        ::               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,DTTHX,PSIX10,PSIT,PSIT2,PSIQ,PSIQ2
+      REAL    ::  FLUXC,VSGD
+      REAL    ::  XMOL,ZOBOL,Z10OL,ZNTOL,YNT,YOB,X1,X2
+      REAL    ::  G2OZ0,G10OZ0,RA2,ZOLL
+      REAL    ::  TV0,CPOT,RICRITI,AM,AH,SQLNZZ0,RBH,RBW,TSTV
+      REAL    ::  PSIH2, PSIM2, PSIH10, PSIM10, CQS
+
+!-------------------------------Exicutable starts here-------------------- 
+
+      DO i = its,ite
+! PSFC cb
+        PSFC(I)=PSFCPA(I)/1000.
+        TVCON      = 1.0 + EP1 * QV1D(I)
+        THETAV1(I) = THETA1(I) * TVCON
+        RHOX(I)=PSFCPA(I)/(R*T1D(I)*TVCON)
+      ENDDO
+
+!
+!-----Compute virtual potential temperature at surface
+!
+      DO I=its,ite
+        E1=SVP1*EXP( SVP2*(TG(I)-SVPT0)/(TG(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))  
+        PL = P1D(I)/1000.                     
+        QGH(I)=EP2*E1/(PL-E1)                                                 
+        CPM(I)=CP*(1.+0.8*QV1D(I))                                   
+   enddo                                                                   
+
+!.......... compute the thetav at ground
+        DO I = its, ite
+          TV0       = TG(I) * (1.0 + EP1 * QSFC(I)*MAVAIL(I))
+          CPOT      = (100./PSFC(I))**ROVCP 
+          TH0(I)    = TV0 * (100./PSFC(I))**ROVCP
+          THETAG(I) = CPOT * TG(I)
+        ENDDO
+!                                                                                
+!-----COMPUTE THE HEIGHT OF FULL- AND HALF-SIGMA LEVELS ABOVE GROUND             
+!     LEVEL, AND THE LAYER THICKNESSES.                                          
+!                                                                                
+!... DZ8W1D is DZ between full sigma levels and Z0 is the height of the first 
+!    half sigma level
+        DO I = its,ite
+          ZA(I) = 0.5 * DZ8W1D(I)                                
+          WS(I)   = SQRT(US(I) * US(I) + VS(I) * VS(I))
+        ENDDO                                                                   
+!
+!-----CALCULATE BULK RICHARDSON NO. OF SURFACE LAYER, ACCORDING TO
+!     AKB(1976), EQ(12).
+
+        RICRITI = 1.0 / RICRIT
+
+        DO i = its,ite
+          GZ1OZ0(I) = ALOG(ZA(I) / ZNT(I))
+          DTHVDZ      = THETAV1(I) - TH0(I)
+          fluxc = max(hfx(i)/rhox(i)/cp                    &
+              + ep1*TH0(I)*qfx(i)/rhox(i),0.)
+          VCONV = vconvc*(g/tg(i)*pblh(i)*fluxc)**.33
+          VSGD = 0.32 * (max(dx/5000.-1.,0.))**.33
+          WSPD(I)=SQRT(WS(I)*WS(I)+VCONV*VCONV+vsgd*vsgd)
+          WSPD(I)   = AMAX1(WSPD(I),0.1)
+          GOVRTH(I)   = G / THETA1(I)
+          BR(I)     = GOVRTH(I) * ZA(I) * DTHVDZ / (WSPD(I) * WSPD(I))
+          RICUT(I)    = 1.0 / (RICRITI + GZ1OZ0(I))
+        ENDDO
+
+        DO I = its,ite
+!------------------------------------------------------------------
+!-- NOTE THAT THE REGIMES USED IN HIRPBL HAVE BEEN CHANGED:
+          ZOLL = 0.0
+          IF (BR(I) .GE. RICUT(I)) THEN
+!
+!-----CLASS 1; VERY STABLE CONDITIONS:  Z/L > 1
+!
+            REGIME(I) = 1.0
+            ZOLL      = BR(I) * GZ1OZ0(I) / (1.0 - RICRITI * RICUT(I))
+            PSIM(I)   = 1.0 - BETAM - ZOLL
+            PSIH(I)   = 1.0 - BETAH - ZOLL
+
+          ELSE IF (BR(I) .GE. 0.0) THEN
+
+!-----CLASS 2; STABLE: for 1 > Z/L >0
+!
+            REGIME(I) = 2.0
+            ZOLL      = BR(I) * GZ1OZ0(I) / (1.0 - RICRITI * BR(I))
+            PSIM(I)   = -BETAM * ZOLL
+            PSIH(I)   = -BETAH * ZOLL
+
+          ELSE
+!
+!-----CLASS 3 or 4; UNSTABLE:
+!        CLASS 4 IS FOR ACM NON-LOCAL CONVECTION (H/L < -3)
+!
+            REGIME(I) = 3.0   ! Regime will be reset to 4 if ACM is used
+            AM          = 0.031 + 0.276 * ALOG(GZ1OZ0(I))
+            AH          = 0.04 + 0.355 * ALOG(GZ1OZ0(I))
+            SQLNZZ0     = SQRT(GZ1OZ0(I))
+            PSIM(I)   = AM * ALOG(1.0 - BM * SQLNZZ0 * BR(I))
+            PSIH(I)   = AH * ALOG(1.0 - BH * SQLNZZ0 * BR(I))
+!
+        ENDIF
+      ENDDO
+!
+!-----COMPUTE THE FRICTIONAL VELOCITY AND SURFACE FLUXES:
+!
+      DO I = its,ite
+        DTG       = THETA1(I) - THETAG(I)
+        PSIX      = GZ1OZ0(I) - PSIM(I)
+        UST(I)=0.5*UST(I)+0.5*KARMAN*WSPD(I)/PSIX                                             
+        USTM(I) = UST(I)
+
+!-----OVER WATER, ALTER ROUGHNESS LENGTH (Z0) ACCORDING TO WIND (UST).
+!
+        IF ((XLAND(I)-1.5) .GE. 0.0) THEN
+          ZNT(I) = CZO * USTM(I) * USTM(I) / G + OZO
+          GZ1OZ0(I) = ALOG(ZA(I) / ZNT(I))
+          PSIX      = GZ1OZ0(I) - PSIM(I)
+          UST(I)  = KARMAN * WSPD(I) / PSIX
+          USTM(I) = UST(I)
+        ENDIF 
+
+        RA(I)  = PR0 * (GZ1OZ0(I) - PSIH(I)) / (KARMAN * UST(I))
+        RBH    = 5.0 / UST(I)                ! 5/U*  ! WESELY AND HICKS (1977)
+!... RB FOR WATER VAPOR =  5*(0.599/0.709)^2/3 /UST = 4.47/UST    hi               
+        RBW    = 4.47/UST(I)                                       
+        CHS(I) = 1./(RA(I) + RBH)
+        CQS    = 1./(RA(I) + RBW)
+        MOL(I) = DTG * CHS(I) / UST(I)                       ! This is really TST
+        TSTV     = (THETAV1(I) - TH0(I)) * CHS(I) / UST(I) 
+        IF (ABS(TSTV) .LT. 1.E-5)  TSTV = 1.E-5 
+        MOLENGTH(I) = THETAV1(I) * UST(I) * UST(I) / (KARMAN *             &
+                        G * TSTV)
+!
+!---Compute 2m surface exchange coefficients for heat and moisture
+        XMOL = MOLENGTH(I)
+        IF(MOLENGTH(I).GT.0.0) XMOL = AMAX1(MOLENGTH(I),2.0)       
+        RMOL(I) = 1/XMOL                                           
+        ZOL(I)   = ZA(I)*RMOL(I)                                                        
+        ZOBOL = 1.5*RMOL(I)  
+        Z10OL = 10.0*RMOL(I)                                                      
+        ZNTOL = ZNT(I)*RMOL(I)                                                  
+        IF(XMOL.LT.0.0) THEN
+          YNT = ( 1.0 - GAMAH * ZNTOL )**0.5
+          YOB = ( 1.0 - GAMAH * ZOBOL )**0.5
+          PSIH2 =  2. * ALOG((YOB+1.0)/(YNT+1.0))
+          x1   = (1.0 - gamam * z10ol)**0.25
+          x2   = (1.0 - gamam * zntol)**0.25
+          psim10 = 2.0 * ALOG( (1.0+x1) / (1.0+x2) ) +        &
+                         ALOG( (1.0+x1*x1) / (1.0+x2*x2)) -   &
+                         2.0 * ATAN(x1) + 2.0 * ATAN(x2)
+        ELSE 
+          IF((ZOBOL-ZNTOL).LE.1.0) THEN                                       
+            PSIH2 = -BETAH*(ZOBOL-ZNTOL)                                     
+          ELSE                                                                
+            PSIH2 = 1.-BETAH-(ZOBOL-ZNTOL)                                   
+          ENDIF                                                               
+          IF((Z10OL-ZNTOL).LE.1.0) THEN                                       
+            PSIM10 = -BETAM*(Z10OL-ZNTOL)                                     
+          ELSE                                                                
+            PSIM10 = 1.-BETAM-(Z10OL-ZNTOL)                                   
+          ENDIF                                                               
+        ENDIF 
+        G2OZ0  = ALOG(1.5 / ZNT(I))
+        G10OZ0 = ALOG(10.0 / ZNT(I))
+        RA2  = PR0 * (G2OZ0 - PSIH2) / (KARMAN * UST(I))
+        CHS2(I) = 1.0/(RA2 + RBH)
+        CQS2(I) = 1.0/(RA2 + RBW) 
+        U10(I)  = US(I)*(G10OZ0-PSIM10)/PSIX                                    
+        V10(I)  = VS(I)*(G10OZ0-PSIM10)/PSIX                                            
+      !IF(I.EQ.60.AND.J.EQ.60) PRINT *,'  ZNT,USTM,U10,UZ1=',ZNT(I),USTM(I),U10(I),US(I)   
+!                                                                                
+!-----COMPUTE SURFACE HEAT AND MOIST FLUX:                                                
+!                                                                                                                                                       
+        FLHC(i)=CPM(I)*RHOX(I)*CHS(I)
+        FLQC(i)=RHOX(I)*CQS*MAVAIL(I)
+        QFX(I)=FLQC(I)*(QSFC(I)-QV1D(I))                                     
+        QFX(I)=AMAX1(QFX(I),0.)                                            
+        LH(I)=XLV*QFX(I)
+        IF(XLAND(I)-1.5.GT.0.)THEN                                           
+          HFX(I)=-FLHC(I)*DTG                               
+        ELSEIF(XLAND(I)-1.5.LT.0.)THEN                                       
+          HFX(I)=-FLHC(I)*DTG                               
+          HFX(I)=AMAX1(HFX(I),-250.)                                       
+        ENDIF      
+     ENDDO                                           
+   END SUBROUTINE PXSFCLAY1D
+
+!====================================================================
+   SUBROUTINE pxsfclayinit( allowed_to_read )         
+
+   LOGICAL , INTENT(IN)      ::      allowed_to_read
+   INTEGER                   ::      N
+   REAL                      ::      ZOLN,X,Y
+
+
+   END SUBROUTINE pxsfclayinit
+
+!-------------------------------------------------------------------          
+
+END MODULE module_sf_pxsfclay
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_qnsesfc.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_qnsesfc.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_qnsesfc.F	(revision 17)
@@ -0,0 +1,1249 @@
+!----------------------------------------------------------------------
+!
+      MODULE MODULE_SF_QNSESFC
+!
+!----------------------------------------------------------------------
+!
+      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 :: EPSQ2L=0.01
+      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=0.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                                    &
+     &                 ,PRT0=0.72                                      &
+     &                 ,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 QNSESFC(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                                      &
+     &                 ,RIB                                            &
+     &                 ,CHS,CHS2,CQS2,HFX,QFX,FLX_LH,FLHC,FLQC         &
+     &                 ,QGH,CPM,CT                                     &
+     &                 ,U10,V10,TSHLTR,TH10,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       &
+     &                                              ,U10,V10
+!
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: AKHS,AKMS       &
+     &                                                ,PBLH,QSFC
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT)   :: RIB
+!
+      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(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)<=EPSQ2L*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
+          TZ0=THZ0(I,J)*APESFC
+!
+          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),RIB(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)
+!
+          RAPA02=RAPA-GOCP02/TH02P
+          RAPA10=RAPA-GOCP10/TH10P
+!
+          T02P=TH02P*RAPA02
+          T10P=TH10P*RAPA10
+!
+          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
+!----------------------------------------------------------------------
+!
+        ENDDO
+!
+!----------------------------------------------------------------------
+      ENDDO setup_integration
+!----------------------------------------------------------------------
+ 
+      END SUBROUTINE QNSESFC
+!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!----------------------------------------------------------------------
+      SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC                       &
+     &                 ,UZ0,VZ0,TZ0,THZ0,QZ0                           &
+     &                 ,USTAR,Z0,Z0BASE,CT,RLMO,AKMS,AKHS,RIB,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,RIB,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,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(USTAR<USTC)THEN
+!----------------------------------------------------------------------
+!
+            IF(USTAR<USTR)THEN
+!
+              IF(NTSD==1)THEN
+                AKMS=CXCHS
+                AKHS=CXCHS
+                QS=QLOW
+              ENDIF
+!
+              ZU=FZU1*SQRT(SQRT(Z0*USTAR*RVISC))/USTAR
+              WGHT=AKMS*ZU*RVISC
+              RWGH=WGHT/(WGHT+1.)
+              UZ0=(ULOW*RWGH+UZ0)*0.5
+              VZ0=(VLOW*RWGH+VZ0)*0.5
+!
+              ZT=FZT1*ZU
+              ZQ=FZQ1*ZT
+              WGHTT=AKHS*ZT*RTVISC
+              WGHTQ=AKHS*ZQ*RQVISC
+!
+              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.USTAR<USTC)THEN
+              ZU=Z0
+              UZ0=0.
+              VZ0=0.
+!
+              ZT=FZT2*SQRT(SQRT(Z0*USTAR*RVISC))/USTAR
+              ZQ=FZQ2*ZT
+              WGHTT=AKHS*ZT*RTVISC
+              WGHTQ=AKHS*ZQ*RQVISC
+!
+              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)    !Interpolation from the table
+!
+            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)*PRT0
+!           SIMH=(PSHZL-PSHZ+RLOGT)*FH01
+!----------------------------------------------------------------------
+            USTARK=USTAR*VKARMAN
+            AKMS=MAX(USTARK/SIMM,CXCHS)
+            AKHS=MAX(USTARK/SIMH,CXCHS)
+!
+!----------------------------------------------------------------------
+!***  BELJAARS CORRECTION FOR USTAR (FOR CONVECTION)
+!----------------------------------------------------------------------
+!
+            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)
+            ZT=MAX(ZT,ZU*ZTFC)               !Quick fix by S. Sukoriansky
+!
+            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)*PRT0
+!           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)*PRT0
+!         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)*PRT0
+!         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)*PRT0
+!         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)*PRT0
+!         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 QNSESFCINIT(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,PSIMQ,PSIHQ
+!
+      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)
+
+#ifdef DM_PARALLEL
+        CALL WRF_DM_MAXVAL(MAXGBL_IVGTYP,IDUM,JDUM)
+#endif
+
+!
+        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=3.0
+      ZTMAX1=2.3   ! changed
+      ZTMIN2=-5.0
+!      ZTMAX2=3.0
+      ZTMAX2=2.3   ! changed
+!
+      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.)
+!
+!----------------------------------------------------------------------
+!***  DERIVED BY S. SUKORIANSKY USING QNSE THEORY
+!----------------------------------------------------------------------
+!
+          PSIMQ=2.25*ZETA1+ZETA1**2+45.9*ZETA1**3
+          PSIHQ=2.0*ZETA1+10.3*ZETA1**2+130*ZETA1**3
+!         PSIHQ=1.45*ZETA1+7.42*ZETA1**2+93.5*ZETA1**3      ! /PRT0
+          PSIM1(K)=MAX(PSIMQ,PSIM1(K))
+          PSIH1(K)=MAX(PSIHQ,PSIH1(K))
+!
+!----------------------------------------------------------------------
+!***  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)
+!
+!----------------------------------------------------------------------
+!***  DERIVED BY S. SUKORIANSKY USING QNSE THEORY
+!----------------------------------------------------------------------
+!
+          PSIM1(K)=2.25*ZETA1-0.2*ZETA1*ZETA1
+          PSIH1(K)=2.0*ZETA1+0.14*((ZETA1-0.5)**5+0.03125)
+!         PSIH1(K)=1.42*ZETA1+0.1*((ZETA1-0.5)**5+0.03125)  !/PRT0
+!----------------------------------------------------------------------
+!
+        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.)
+!
+!----------------------------------------------------------------------
+!***  DERIVED BY S. SUKORIANSKY USING QNSE THEORY
+!----------------------------------------------------------------------
+!
+          PSIMQ=2.25*ZETA2+ZETA2**2+45.9*ZETA2**3
+          PSIHQ=2.0*ZETA2+10.3*ZETA2**2+130*ZETA2**3
+!         PSIHQ=1.45*ZETA2+7.42*ZETA2**2+93.5*ZETA2**3      ! /PRT0
+          PSIM2(K)=MAX(PSIMQ,PSIM2(K))
+          PSIH2(K)=MAX(PSIHQ,PSIH2(K))
+!
+!----------------------------------------------------------------------
+!***  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)
+!
+!----------------------------------------------------------------------
+!***  DERIVED BY S. SUKORIANSKY USING QNSE THEORY
+!----------------------------------------------------------------------
+!
+          PSIM2(K)=2.25*ZETA2-0.2*ZETA2*ZETA2
+          PSIH2(K)=2.0*ZETA2+0.14*((ZETA2-0.5)**5+0.03125)
+!         PSIH2(K)=1.42*ZETA2+0.1*((ZETA2-0.5)**5+0.03125)  !/PRT0
+!----------------------------------------------------------------------
+!
+        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 QNSESFCINIT
+!
+!----------------------------------------------------------------------
+!
+      END MODULE MODULE_SF_QNSESFC
+!
+!----------------------------------------------------------------------
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_ruclsm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_ruclsm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_ruclsm.F	(revision 17)
@@ -0,0 +1,5936 @@
+#define LSMRUC_DBG_LVL 3000
+!WRF:MODEL_LAYER:PHYSICS
+!
+MODULE module_sf_ruclsm
+
+  USE module_model_constants
+  USE module_wrf_error
+
+! VEGETATION PARAMETERS
+        INTEGER :: LUCATS , BARE, NATURAL
+        integer, PARAMETER :: NLUS=50
+        CHARACTER*8 LUTYPE
+        INTEGER, DIMENSION(1:NLUS) :: NROTBL
+        real, dimension(1:NLUS) ::  SNUPTBL, RSTBL, RGLTBL, HSTBL, LAITBL,         &
+                                    ALBTBL, Z0TBL, LEMITBL, PCTBL, SHDTBL, MAXALB
+        REAL ::   TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA
+
+! SOIL PARAMETERS
+        INTEGER :: SLCATS
+        INTEGER, PARAMETER :: NSLTYPE=30
+        CHARACTER*8 SLTYPE
+        REAL, DIMENSION (1:NSLTYPE) :: BB,DRYSMC,HC,                           &
+        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
+
+!-----------------------------------------------------------------
+    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, CHS,                   & 
+                   FLQC,FLHC,MAVAIL,CANWAT,VEGFRA,ALB,ZNT,       &
+                   Z0,SNOALB,ALBBCK,                            &  !new
+                   QSFC,QSG,QVG,QCG,DEW,SOILT1,TSNAV,            &
+                   TBOT,IVGTYP,ISLTYP,XLAND,                     &
+                   ISICE,XICE,XICE_THRESHOLD,                    &
+                   CP,ROVCP,G0,LV,STBOLT,                        &
+                   SOILMOIS,SH2O,SMAVAIL,SMMAX,                  &
+                   TSO,SOILT,HFX,QFX,LH,                         &
+                   SFCRUNOFF,UDRUNOFF,SFCEXC,                    &
+                   SFCEVP,GRDFLX,ACSNOW,SNOM,                    &
+                   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. 
+!-- tice - sea ice temperture (C)
+!-- rhosice - sea ice density (kg m^-3)
+!-- capice - sea ice volumetric heat capacity (J/m^3/K)
+!-- thdifice - sea ice thermal diffusivity (m^2/s)
+!--
+!-- 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+3
+
+   REAL,       INTENT(IN   )    ::     DT
+   LOGICAL,    INTENT(IN   )    ::     myj,frpcpn
+   INTEGER,    INTENT(IN   )    ::     ktau, nsl, isice,         &
+                                       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, &
+                                                           FLHC, &
+                                                           FLQC, &
+                                                           CHS , &
+                                                          EMISS, &
+                                                           XICE, &
+                                                          XLAND, &
+                                                         ALBBCK, &
+                                                         VEGFRA, &
+                                                           TBOT
+
+   REAL,       DIMENSION( 1:nsl), INTENT(IN   )      ::      ZS
+
+   REAL,       DIMENSION( ims:ime , jms:jme ),                   &
+               INTENT(INOUT)    ::                               &
+                                                           SNOW, & !new
+                                                          SNOWH, &
+                                                          SNOWC, &
+                                                         CANWAT, & ! new
+                                                         SNOALB, &
+                                                            ALB, &
+                                                         MAVAIL, & 
+                                                         SFCEXC, &
+                                                            Z0 , &
+                                                            ZNT
+
+   REAL,       DIMENSION( ims:ime , jms:jme ),                   &
+               INTENT(IN   )    ::                               &
+                                                        FRZFRAC
+
+   INTEGER,    DIMENSION( ims:ime , jms:jme ),                   &
+               INTENT(IN   )    ::                       IVGTYP, &
+                                                         ISLTYP
+
+   REAL, INTENT(IN   )          ::         CP,ROVCP,G0,LV,STBOLT,XICE_threshold
+ 
+   REAL,       DIMENSION( ims:ime , 1:nsl, jms:jme )           , &
+               INTENT(INOUT)    ::                 SOILMOIS,SH2O,TSO
+
+   REAL,       DIMENSION( ims:ime, jms:jme )                   , &
+               INTENT(INOUT)    ::                        SOILT, &
+                                                            HFX, &
+                                                            QFX, &
+                                                             LH, &
+                                                         SFCEVP, &
+                                                      SFCRUNOFF, &
+                                                       UDRUNOFF, &
+                                                         GRDFLX, &
+                                                         ACSNOW, &
+                                                           SNOM, &
+                                                            QVG, &
+                                                            QCG, &
+                                                            DEW, &
+                                                           QSFC, &
+                                                            QSG, &
+                                                        CHKLOWQ, &
+                                                         SOILT1, &
+                                                          TSNAV
+
+   REAL,       DIMENSION( ims:ime, jms:jme )                   , & 
+               INTENT(INOUT)    ::                      SMAVAIL, &
+                                                          SMMAX
+
+   REAL,       DIMENSION( its:ite, jts:jte )    ::               &
+                                                             PC, &
+                                                        RUNOFF1, &
+                                                        RUNOFF2, &
+                                                         EMISSL, &
+                                                           ZNTL, &
+                                                        LMAVAIL, &
+                                                          SMELT, &
+                                                           SNOH, &
+                                                          SNFLX, &
+                                                           EDIR, &
+                                                             EC, &
+                                                            ETT, &
+                                                         SUBLIM, &
+                                                           sflx, &
+                                                          EVAPL, &
+                                                          PRCPL, &
+                                                         SEAICE, &
+                                                        INFILTR
+
+!--- soil/snow properties
+   REAL,       DIMENSION( ims:ime, 1:nsl, jms:jme)               &
+                                             ::    KEEPFR3DFLAG, &
+                                                         SMFR3D
+
+   REAL                                                          &
+                             ::                           RHOCS, &
+                                                          RHOSN, &
+                                                       RHONEWSN, &
+                                                           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, &
+                                                          PATMB, &
+                                                           TABS, &
+                                                          QVATM, &
+                                                          QCATM, &
+                                                          Q2SAT, &
+                                                         CONFLX, &
+                                                            RHO, &
+                                                           QKMS, &
+                                                           TKMS, &
+                                                       INFILTRP
+   REAL      ::  cq,r61,r273,arp,brp,x,evs,eis
+
+   REAL      ::  meltfactor
+   INTEGER   ::  NROOT
+   INTEGER   ::  ILAND,ISOIL
+ 
+   INTEGER, DIMENSION( 1:(nvegclas) )   ::  IFOREST
+
+   INTEGER   ::  I,J,K,NZS,NZS1,NDDZS
+   INTEGER   ::  k1,l,k2,kp,km
+   CHARACTER (LEN=132) :: message
+
+!-----------------------------------------------------------------
+
+         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
+!       sh2o    (i,k,j)=soilmois(i,k,j)-smfr3d(i,k,j)/1.e3*900.
+       keepfr3dflag(i,k,j)=0.
+            enddo
+!--- initializing to zero snow fraction
+           snowc(i,j) = min(1.,snowh(i,j)/0.05)
+!--- initializing inside snow temp if it is not defined
+        IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN
+            IF(snowc(i,j).gt.0.1) THEN
+           soilt1(i,j)=0.5*(soilt(i,j)+tso(i,1,j))
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+        WRITE ( message , FMT='(A,F8.3,2I6)' ) &
+       'Temperature inside snow is initialized in RUCLSM ', soilt1(i,j),i,j
+        CALL wrf_debug ( 0 , message )
+    ENDIF
+            ELSE
+           soilt1(i,j) = soilt(i,j)
+            ENDIF
+        ENDIF
+           tsnav(i,j) =0.5*(soilt(i,j)+tso(i,1,j))-273.
+           qcg  (i,j) =0.
+           patmb=P8w(i,kms,j)*1.e-2
+           QSG  (i,j) = QSN(SOILT(i,j),TBQ)/PATMB
+           qvg  (i,j) = QSG(i,j)*mavail(i,j)
+!           qvg  (i,j) =qv3d(i,1,j)
+!           qsfc(i,j) = qsg(i,j)/(1.+qsg(i,j))
+           qsfc(i,j) = qvg(i,j)/(1.+qvg(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.
+           SFCRUNOFF(i,j) = 0.
+           UDRUNOFF(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.
+           sflx  (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.
+
+
+   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 CHS,FLHC ',i,j,chs(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
+!-- Z3D(1) is thickness between first full sigma level and the surface, 
+!-- but first mass level is at the half of the first sigma level 
+!-- (u and v are also at the half of first sigma level)
+         CONFLX    = Z3D(i,kms,j)*0.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
+!        if   (myj)   then
+         QKMS=CHS(i,j)
+         TKMS=CHS(i,j)
+!        else
+!--- convert exchange coeff QKMS to [m/s]
+!         QKMS=FLQC(I,J)/RHO/MAVAIL(I,J)
+!         TKMS=FLHC(I,J)/RHO/CP
+!        endif
+!--- 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
+
+
+!------------------------------------------------------------
+!-----  DDZS and DSDZ1 are for implicit solution 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.0004   ! 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
+
+        RHONEWSN = 200.
+       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     )
+
+!-- definition of number of soil levels in the rooting zone
+     IF(iforest(ivgtyp(i,j)).ne.1) THEN
+!---- all vegetation types except evergreen and mixed forests
+!18apr08 - define meltfactor for Egglston melting limit:
+! for open areas factor is 2, and for forests - factor is 1.5
+! This will make limit on snow melting smaller and let snow stay 
+! longer in the forests.
+         meltfactor = 2.0
+
+         do k=2,nzs
+         if(zsmain(k).ge.0.4) then
+            NROOT=K
+            goto  111
+         endif
+         enddo
+     ELSE
+!---- evergreen and mixed forests
+!18apr08 - define meltfactor
+         meltfactor = 1.5
+
+         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
+
+!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS
+
+        IF((XLAND(I,J)-1.5).GE.0.)THEN
+!-- Water 
+           SMAVAIL(I,J)=1.0
+             SMMAX(I,J)=1.0
+             SNOW(I,J)=0.0
+           LMAVAIL(I,J)=1.0
+
+           ILAND=16
+           ISOIL=14
+
+           patmb=P8w(i,1,j)*1.e-2
+           qvg  (i,j) = QSN(SOILT(i,j),TBQ)/PATMB
+           qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j))
+           CHKLOWQ(I,J)=1.
+           Q2SAT=QSN(TABS,TBQ)/PATMB
+
+            DO K=1,NZS
+              SOILMOIS(I,K,J)=1.0
+              SH2O    (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
+
+           ELSE
+
+! LAND POINT OR SEA ICE
+       if(xice(i,j).ge.xice_threshold) then
+!       if(IVGTYP(i,j).eq.isice) then
+           SEAICE(i,j)=1.
+       else
+           SEAICE(i,j)=0.
+       endif
+
+         IF(SEAICE(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
+            ZNT(I,J) = 0.011
+            snoalb(i,j) = 0.75
+            dqm = 1.
+            ref = 1.
+            qmin = 0.
+            wilt = 0.
+            emissl(i,j) = 1.0 
+
+            DO K=1,NZS
+               soilmois(i,k,j) = 1.
+               smfr3d(i,k,j)   = 1.
+               sh2o(i,k,j)     = 0.
+               keepfr3dflag(i,k,j) = 0.
+            ENDDO
+          ENDIF
+
+!  Attention!!!!  RUC LSM uses soil moisture content minus residual (minimum
+!  or dry soil moisture content for a given soil type) as a state variable.
+
+           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)
+              soiliqw (k) = sh2o(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))
+
+! extract dew from the cloud water at the surface
+              QCG(I,J)=QCG(I,J)-DEW(I,J)
+
+    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,meltfactor,                      &   !added meltfactor
+                iland,isoil,xland(i,j),ivgtyp(i,j),PRCPMS,       &
+                NEWSNMS,SNWE,SNHEI,SNOWFRAC,RHOSN,RHONEWSN,      &
+                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,seaice(i,j),                                 &
+!--- soil fixed fields
+                QWRTZ,                                           &
+                rhocs,dqm,qmin,ref,                              &
+                wilt,psis,bclh,ksat,                             &
+                sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq,           &
+!--- constants
+                cp,rovcp,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),qfx(I,J),          &
+                lh(I,J),hfx(I,J),sflx(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.
+
+        do k=1,nzs
+
+             soilmois(i,k,j) = soilm1d(k)
+             sh2o    (i,k,j) = soiliqw(k)
+                  tso(i,k,j) = tso1d(k)
+        enddo
+
+        tso(i,nzs,j) = tbot(i,j)
+
+        do k=1,nzs
+             smfr3d(i,k,j) = smfrkeep(k)
+           keepfr3dflag(i,k,j) = keepfr (k)
+        enddo
+
+!tgs add together dew and cloud at the ground surface
+        qcg(i,j)=qcg(i,j)+dew(i,j)
+
+        Z0       (I,J) = ZNT (I,J)
+        SFCEXC   (I,J) = TKMS
+        patmb=P8w(i,1,j)*1.e-2
+        Q2SAT=QSN(TABS,TBQ)/PATMB
+        QSFC(I,J) = QVG(I,J)/(1.+QVG(I,J))
+! for MYJ surface and PBL scheme
+!      if (myj) then
+! MYJSFC expects QSFC as actual specific humidity at the surface
+        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
+
+! 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.
+        INFILTR(I,J) = INFILTRP
+
+        MAVAIL (i,j) = LMAVAIL(I,J)  
+    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
+        SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT
+        GRDFLX (I,J) = -1. * sflx(I,J)
+
+    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
+       if(snowfrac > 0. .and. (xice(i,j).ge.xice_threshold .and. xice(i,j) < 1.)) then
+           SNOWFRAC = SNOWFRAC*XICE(I,J)
+       endif
+
+       SNOWC(I,J)=SNOWFRAC
+
+
+!--- 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
+
+!--- end of a land or sea ice point
+        ENDIF
+
+      ENDDO
+
+   ENDDO
+
+!-----------------------------------------------------------------
+   END SUBROUTINE LSMRUC
+!-----------------------------------------------------------------
+
+
+
+   SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
+!--- input variables
+                nzs,nddzs,nroot,meltfactor,                      &
+                ILAND,ISOIL,XLAND,IVGTYP,PRCPMS,                 &
+                NEWSNMS,SNWE,SNHEI,SNOWFRAC,RHOSN,RHONEWSN,      &
+                PATM,TABS,QVATM,QCATM,rho,                       &
+                GLW,GSW,EMISS,QKMS,TKMS,PC,                      &
+                MAVAIL,CST,VEGFRA,ALB,ZNT,                       &
+                ALB_SNOW,ALB_SNOW_FREE,                          &
+                MYJ,SEAICE,                                      &
+!--- soil fixed fields
+                QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat,    &
+                sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq,           &
+!--- constants
+                cp,rovcp,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,meltfactor
+   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, &
+                                                         VEGFRA, &
+                                                  ALB_SNOW_FREE, &
+                                                         SEAICE, &
+                                                          XLAND, &
+                                                            RHO, &
+                                                           QKMS, &
+                                                           TKMS
+                                                             
+   INTEGER,   INTENT(IN   )  ::                          IVGTYP
+!--- 2-D variables
+   REAL                                                        , &
+            INTENT(INOUT)    ::                           EMISS, &
+                                                         MAVAIL, &
+                                                       SNOWFRAC, &
+                                                       ALB_SNOW, &
+                                                            ALB, &
+                                                            CST
+
+!--- soil properties
+   REAL                      ::                                  &
+                                                          RHOCS, &
+                                                           BCLH, &
+                                                            DQM, &
+                                                           KSAT, &
+                                                           PSIS, &
+                                                           QMIN, &
+                                                          QWRTZ, &
+                                                            REF, &
+                                                            SAT, &
+                                                           WILT
+
+   REAL,     INTENT(IN   )   ::                              CN, &
+                                                             CW, &
+                                                             CP, &
+                                                          ROVCP, &
+                                                             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, & 
+                                                       RHONEWSN, &
+                                                         SUBLIM, &
+                                                          PRCPL, &
+                                                            QVG, &
+                                                            QSG, &
+                                                            QCG, &
+                                                            QFX, &
+                                                            HFX, &
+                                                              S, &  
+                                                        RUNOFF1, &
+                                                        RUNOFF2, &
+                                                         ACSNOW, &
+                                                           SNWE, &
+                                                          SNHEI, &
+                                                          SMELT, &
+                                                           SNOM, &
+                                                           SNOH, &
+                                                          SNFLX, &
+                                                          SOILT, &
+                                                         SOILT1, &
+                                                          TSNAV, &
+                                                            ZNT
+
+   REAL,     DIMENSION(1:NZS)              ::                    &
+                                                           tice, &
+                                                        rhosice, &
+                                                         capice, &
+                                                       thdifice
+!-------- 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                                        , &
+               RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS             , &
+               T3, UPFLUX, XINET
+   REAL    ::  snhei_crit, keep_snow_albedo
+
+   REAL    ::  RNET,GSWNEW,EMISSN,ZNTSN
+   REAL    ::  VEGFRAC
+   real    ::  cice, albice, albsn
+
+!-----------------------------------------------------------------
+        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
+
+        NEWSN=0.
+        RAINF = 0.
+        RSM=0.
+        INFILTR=0.
+        VEGFRAC=0.01*VEGFRA
+       if(VEGFRAC.le.0.01) VEGFRAC=0.
+!---initialize local arrays for sea ice
+          do k=1,nzs
+            tice(k) = 0.
+            rhosice(k) = 0. 
+            cice = 0.
+            capice(k) = 0.
+            thdifice(k) = 0.
+          enddo
+
+        GSWnew=GSW
+        ALBice=ALB_SNOW_FREE
+!--- sea ice properties
+!--- N.N Zubov "Arctic Ice"
+!--- no salinity dependence because we consider the ice pack
+!--- to be old and to have low salinity (0.0002)
+       if(SEAICE.ge.0.5) then
+          do k=1,nzs
+            tice(k) = ts1d(k) - 273.15
+            rhosice(k) = 917.6/(1-0.000165*tice(k))
+            cice = 2115.85 +7.7948*tice(k)
+            capice(k) = cice*rhosice(k)
+            thdifice(k) = 2.260872/capice(k)
+           enddo
+!-- SEA ICE ALB dependence on ice temperature. When ice temperature is
+!-- below critical value of -10C - no change to albedo.
+!-- If temperature is higher that -10C then albedo is decreasing.
+!-- The minimum albedo at t=0C for ice is 0.1 less.
+         GSWNEW=GSW/(1.-ALB)
+       ALBice = MIN(ALB_SNOW_FREE,MAX(ALB_SNOW_FREE - 0.1,   &
+               ALB_SNOW_FREE - 0.1*(tice(1)+10.)/10. ))
+         GSWNEW=GSW*(1.-ALBice)
+       endif
+
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+        print *,'I,J,KTAU,QKMS,TKMS', i,j,ktau,qkms,tkms
+        print *,'GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE',&
+                 GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE
+    ENDIF
+
+         SNHEI   = SNWE * 1000. / RHOSN
+!--------------
+         T3      = STBOLT*SOILT*SOILT*SOILT
+         UPFLUX  = T3 *SOILT
+         XINET   = EMISS*(GLW-UPFLUX)
+         RNET    = GSWnew + 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  =200.
+      endif
+
+           newsn=newsnms*delt
+!---- 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
+
+       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(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
+
+         SNHEI_CRIT=0.01601*1.e3/rhosn
+         SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT))
+!tgs NEW - low limit on snow fraction
+       if(SNOWFRAC.lt.0.01) snowfrac=0.
+!---        EMISS = 0.91 for snow
+         EMISS = EMISS*(1.-snowfrac)+0.91*snowfrac
+
+         KEEP_SNOW_ALBEDO = 0.
+      IF (NEWSN.GT.0.) KEEP_SNOW_ALBEDO = 1.
+
+!---  GSW in-coming solar
+         GSWNEW=GSW/(1.-ALB)
+
+    IF(SEAICE .LT. 0.5) THEN
+!----- SNOW on soil
+!-- ALB dependence on snow depth
+       ALBsn   = MAX(keep_snow_albedo*alb_snow,                 &
+            MIN((alb_snow_free +                                &
+           (alb_snow - alb_snow_free) *                         &
+           (snhei/(2.*SNHEI_CRIT))), alb_snow))
+
+!-- ALB dependence on snow temperature. When snow temperature is
+!-- below critical value of -10C - no change to albedo.
+!-- If temperature is higher that -10C then albedo is decreasing.
+!-- The minimum albedo at t=0C for snow on land is 15% less than
+!-- albedo of temperatures below -10C.
+      if(albsn.lt.alb_snow)then
+       ALB=ALBsn
+      else
+       ALB = MIN(ALBSN,MAX(ALBSN - 0.15*(soilt - 263.15)/       &
+                (273.15-263.15), ALBSN - 0.15))
+      endif
+    ELSE
+!----- SNOW on ice
+       ALBsn   = MAX(keep_snow_albedo*alb_snow,                 &
+            MIN((albice + (alb_snow - albice) *                 &
+           (snhei/(2.*SNHEI_CRIT))), alb_snow))
+
+!-- ALB dependence on snow temperature. When snow temperature is
+!-- below critical value of -10C - no change to albedo.
+!-- If temperature is higher that -10C then albedo is decreasing.
+!-- The minimum albedo at t=0C for snow on ice is 0.15 less.
+      if(albsn.lt.alb_snow)then
+       ALB=ALBsn
+      else
+       ALB = MIN(ALBSN,MAX(ALBSN - 0.15*(soilt - 263.15)/       &
+                (273.15-263.15), ALBSN - 0.15))
+      endif
+
+    ENDIF
+
+!--- recompute absorbed solar radiation and net radiation
+!--- for new value of albedo
+         gswnew=gswnew*(1.-alb)
+
+        XINET   = EMISS*(GLW-UPFLUX)
+        RNET    = GSWnew + XINET
+
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+        print *,'I,J,GSW,GSWnew,GLW,UPFLUX,ALB',&
+                 i,j,GSW,GSWnew,GLW,UPFLUX,ALB
+    ENDIF
+
+
+      if (SEAICE .LT. 0.5) then
+! LAND
+         CALL SNOWSOIL (                                        & !--- input variables
+            i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot,         &
+            meltfactor,rhonewsn,                                &  ! new
+            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,rovcp,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                      )
+       else
+! SEA ICE
+         CALL SNOWSEAICE (                                      &
+            i,j,isoil,delt,ktau,conflx,nzs,nddzs,               &    
+            meltfactor,rhonewsn,                                &  ! new
+            ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snowfrac,       &    
+            RHOSN,PATM,QVATM,QCATM,                             &    
+            GLW,GSWnew,EMISS,RNET,                              &    
+            QKMS,TKMS,RHO,                                      &    
+!--- sea ice parameters
+            ALB,ZNT,                                            &
+            tice,rhosice,capice,thdifice,                       &    
+            zsmain,zshalf,DTDZS,DTDZS2,tbq,                     &    
+!--- constants
+            lv,CP,rovcp,cw,stbolt,tabs,                         &    
+!--- output variables
+            ilnb,snweprint,snheiprint,rsm,ts1d,                 &    
+            dew,soilt,soilt1,tsnav,qvg,qsg,qcg,                 &    
+            SMELT,SNOH,SNFLX,SNOM,eeta,                         &    
+            qfx,hfx,s,sublim,prcpl                              &    
+                                                                )    
+           edir1 = eeta
+           ec1 = 0.
+           ett1 = 0.
+           runoff1 = smelt
+           runoff2 = 0.
+           mavail = 1.
+           infiltr=0.
+           cst=0.
+            do k=1,nzs
+               soilm1d(k)=1.
+               soiliqw(k)=0.
+               soilice(k)=1.
+               smfrkeep(k)=1.
+               keepfr(k)=0.
+            enddo
+       endif
+
+         if(snhei.eq.0.) then
+!--- all snow is melted
+         alb=alb_snow_free
+         endif
+
+        ELSE
+!--- no snow
+           snheiprint=0.
+           snweprint=0.
+
+       if(SEAICE .LT. 0.5) then
+!  LAND
+         CALL SOIL(                                             &
+!--- input variables
+            i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
+            PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,           &
+            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,rovcp,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)
+        else
+! SEA ICE
+          CALL SICE(                                            &
+!--- input variables
+            i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
+            PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,           &
+            EMISS,RNET,QKMS,TKMS,rho,                           &
+!--- sea ice parameters
+            tice,rhosice,capice,thdifice,                       &
+            zsmain,zshalf,DTDZS,DTDZS2,tbq,                     &
+!--- constants
+            lv,CP,rovcp,cw,stbolt,tabs,                         &
+!--- output variables
+            ts1d,dew,soilt,qvg,qsg,qcg,                         &
+            eeta,qfx,hfx,s,evapl,prcpl                          &
+                                                                )
+           edir1 = eeta
+           ec1 = 0.
+           ett1 = 0.
+           runoff1 = prcpms
+           runoff2 = 0.
+           mavail = 1.
+           infiltr=0.
+           cst=0.
+            do k=1,nzs
+               soilm1d(k)=1.
+               soiliqw(k)=0.
+               soilice(k)=1.
+               smfrkeep(k)=1.
+               keepfr(k)=0.
+            enddo
+        endif
+
+        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,rovcp,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 and 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,rovcp,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.35E+5
+        cvw=cw
+
+        SAT=0.0004
+        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
+
+!**************************************************************
+!  TRANSF computes transpiration function
+!**************************************************************
+           CALL TRANSF(                                       &
+!--- input variables
+              nzs,nroot,soiliqw,tabs,                         &
+!--- 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
+
+!*************************************************************************
+! SOILMOIST solves moisture budget (Smirnova et al., 1996, EQ.22,28) 
+!           and Richards eqn.
+!*************************************************************************
+          CALL SOILMOIST (                                     &
+!-- input
+               delt,nzs,nddzs,DTDZS,DTDZS2,RIW,                &
+               zsmain,zshalf,diffu,hydro,                      &
+               QSG,QVG,QCG,QCATM,QVATM,-PRCPMS,                &
+               QKMS,TRANSP,DRIP,DEW,0.,SOILICE,VEGFRAC,        &
+!               QKMS,TRANSP,DRIP,DEW,0.,SOILICE,VEGFRAC,        &
+!-- soil properties
+               DQM,QMIN,REF,KSAT,RAS,INFMAX,                   &
+!-- output
+               SOILMOIS,SOILIQW,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)                        &
+               *(P1000mb*0.00001/Patm)**ROVCP
+          Q1=-QKMS*RAS*(QVATM - QSG)
+        IF (Q1.LE.0.) THEN
+! ---  condensation
+          EC1=0.
+          EDIR1=0.
+          ETT1=0.
+!-- moisture flux for coupling with PBL
+          EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3
+          QFX= XLV*EETA
+!-- actual moisture flux from RUC LSM
+          EETA= RHO*DEW
+        ELSE
+! ---  evaporation
+          EDIR1 =-(1.-vegfrac)*QKMS*RAS*                       &
+                  (QVATM-QVG)
+          EC1 = Q1 * WETCAN
+          CMC2MS=CST/DELT
+         if(EC1.gt.CMC2MS) cst=0.
+          EC1=MIN(CMC2MS,EC1)*vegfrac
+!-- moisture flux for coupling with PBL
+          EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3
+! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
+          QFX= XLV * EETA
+!-- actual moisture flux from RUC LSM
+          EETA = (EDIR1 + EC1 + ETT1)*1.E3
+        ENDIF
+          EVAPL=EETA
+          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 SICE (                                       &
+!--- input variables
+            i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
+            PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSW,              &
+            EMISS,RNET,QKMS,TKMS,rho,                           &
+!--- sea ice parameters
+            tice,rhosice,capice,thdifice,                       &
+            zsmain,zshalf,DTDZS,DTDZS2,tbq,                     &
+!--- constants
+            xlv,CP,rovcp,cw,stbolt,tabs,                        &
+!--- output variables
+            tso,dew,soilt,qvg,qsg,qcg,                          &
+            eeta,qfx,hfx,s,evapl,prcpl                          &
+                                                                )
+
+!*****************************************************************
+!   Energy budget and  heat diffusion eqns. for
+!   sea ice
+!*************************************************************
+
+        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, &
+                                                           QKMS, &
+                                                           TKMS
+!--- sea ice properties
+   REAL,    DIMENSION(1:NZS)                                   , &
+            INTENT(IN   )    ::                                  &
+                                                           tice, &
+                                                        rhosice, &
+                                                         capice, &
+                                                       thdifice
+
+
+   REAL,     INTENT(IN   )   ::                                  &
+                                                             CW, &
+                                                            XLV
+
+
+   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
+!----soil temperature
+   REAL,     DIMENSION( 1:nzs ),  INTENT(INOUT)   ::        TSO
+!-------- 2-d variables
+   REAL,                                                         &
+             INTENT(INOUT)   ::                             DEW, &
+                                                           EETA, &
+                                                          EVAPL, &
+                                                          PRCPL, &
+                                                            QVG, &
+                                                            QSG, &
+                                                            QCG, &
+                                                           RNET, &
+                                                            QFX, &
+                                                            HFX, &
+                                                              S, &
+                                                          SOILT
+
+!--- Local variables
+   REAL    ::  x,x1,x2,x4,tn,denom
+   REAL    ::  RAINF,  PRCPMS                                  , &
+               TABS, T3, UPFLUX, XINET
+
+   REAL    ::  CP,rovcp,G0,LV,STBOLT,xlmelt,dzstop             , &
+               epot,fltot,ft,fq,hft,ras,cvw                    
+
+   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    ::  AA1,RHCS
+
+
+   REAL,     DIMENSION(1:NZS)  ::   cotso,rhtso
+
+   INTEGER ::  nzs1,nzs2,k,k1,kn,kk
+
+!-----------------------------------------------------------------
+
+!-- define constants
+!        STBOLT=5.670151E-8
+        XLMELT=3.35E+5
+        cvw=cw
+
+        prcpl=prcpms
+
+          NZS1=NZS-1
+          NZS2=NZS-2
+        dzstop=1./(zsmain(2)-zsmain(1))
+        RAS=RHO*1.E-3
+
+        do k=1,nzs
+           cotso(k)=0.
+           rhtso(k)=0.
+        enddo
+
+        cotso(1)=0.
+        rhtso(1)=TSO(NZS)
+
+        DO 33 K=1,NZS2
+          KN=NZS-K
+          K1=2*KN-3
+          X1=DTDZS(K1)*THDIFICE(KN-1)
+          X2=DTDZS(K1+1)*THDIFICE(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=CAPICE(1)
+        H=1.
+        FKT=TKMS
+        D1=cotso(NZS1)
+        D2=rhtso(NZS1)
+        TN=SOILT
+        D9=THDIFICE(1)*RHCS*dzstop
+        D10=TKMS*CP*RHO
+        R211=.5*CONFLX/DELT
+        R21=R211*CP*RHO
+        R22=.5/(THDIFICE(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
+        AA=XLS*(FKQ+R210)/TDENOM
+        BB=(D10*TABS+R21*TN+XLS*(QVATM*FKQ                            &
+        +R210*QVG)+D11+D9*(D2+R22*TN)                                 &
+        +RAINF*CVW*PRCPMS*max(273.15,TABS)                            &
+         )/TDENOM
+        AA1=AA
+        PP=PATM*1.E3
+        AA1=AA1/PP
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+        PRINT *,' VILKA-SEAICE1'
+        print *,'D10,TABS,R21,TN,QVATM,FKQ',                          &
+                 D10,TABS,R21,TN,QVATM,FKQ
+        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,fkq,r210',                              &
+                 tn,aa1,bb,pp,fkq,r210
+    ENDIF
+        CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil)
+!--- it is saturation over sea ice
+        QVG=QS1
+        QSG=QS1
+        TSO(1)=min(271.4,TS1)
+        QCG=0.
+!--- sea ice melting is not included in this simple approach
+!--- SOILT - skin temperature
+          SOILT=TSO(1)
+!---- Final solution for soil temperature - TSO
+          DO K=2,NZS
+            KK=NZS-K+1
+            TSO(K)=min(271.4,rhtso(KK)+cotso(KK)*TSO(K-1))
+          END DO
+!--- CALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW
+        DEW=0.
+
+!--- 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)                        &
+               *(P1000mb*0.00001/Patm)**ROVCP
+          Q1=-QKMS*RAS*(QVATM - QSG)
+        IF (Q1.LE.0.) THEN
+! ---  condensation
+!-- moisture flux for coupling with PBL
+          EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3
+          QFX= XLS*EETA
+!-- actual moisture flux from RUC LSM
+          DEW=QKMS*(QVATM-QSG)
+          EETA= RHO*DEW
+        ELSE
+! ---  evaporation
+!-- moisture flux for coupling with PBL
+          EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3
+!          EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3
+! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
+          QFX= XLS * EETA
+!-- actual moisture flux from RUC LSM
+          EETA = Q1*1.E3
+        ENDIF
+          EVAPL=EETA
+          S=THDIFICE(1)*CAPICE(1)*DZSTOP*(TSO(1)-TSO(2))
+          HFX=HFT
+          FLTOT=RNET-HFT-QFX-S
+
+!-------------------------------------------------------------------
+   END SUBROUTINE SICE
+!-------------------------------------------------------------------
+
+
+
+        SUBROUTINE SNOWSOIL (                                  &
+!--- input variables
+             i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot,       &
+             meltfactor,rhonewsn,                              & ! new
+             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,rovcp,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,RHONEWSN,meltfactor
+
+   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, TRANSUM                               , &
+               SNTH, NEWSN                                     , &
+               TABS, T3, UPFLUX, XINET                         , &
+               BETA, SNWEPR,EPDT,PP
+   REAL    ::  CP,rovcp,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.35E+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
+
+!tgs when the snow depth is marginlly higher than DELTSN,
+! reset DELTSN to half of snow depth.
+        IF(SNHEI.GE.DELTSN+SNTH) THEN
+! 2-layer model
+          if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth)
+        ENDIF 
+
+        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
+
+!******************************************************************
+! 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                         &
+         DD1=CST+(NEWSNOW*RHOnewSN*1.E-3                         &
+!-- this change will not let liquid waer be intercepted by the canopy....
+              -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*RHOnewSN*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*vegfrac) THEN
+          CST=SAT*vegfrac
+          DRIP=DD1-SAT*vegfrac
+        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                                         
+
+       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,tabs,                         &
+!--- 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
+
+!**************************************************************
+! SNOWTEMP solves 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,rhonewsn,meltfactor,      &  ! add meltfactor
+             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,rovcp,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
+
+!*************************************************************************
+!--- 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,RIW,                    &
+               zsmain,zshalf,diffu,hydro,                          &
+               QSG,QVG,QCG,QCATM,QVATM,-PRCPMS,                    &
+               0.,TRANSP,0.,                                       &
+               0.,SMELT,soilice,vegfrac,                           &
+!-- soil properties
+               DQM,QMIN,REF,KSAT,RAS,INFMAX,                       &
+!-- output
+               SOILMOIS,SOILIQW,MAVAIL,RUNOFF1,                    &
+               RUNOFF2,infiltrp) 
+ 
+! 4 Nov 07 - update CST for snow melt
+        if(snwe.ne.0.) then
+         CST=(1.-min(1.,smelt/snwe))*CST
+        else
+         CST=0.
+        endif
+
+!-- 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
+
+! 21apr2009
+! SNOM goes into the passed-in ACSNOM variable in the grid derived type
+        SNOM=SNOM+SMELT*DELT*1.e3
+
+!--- 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)                        &
+               *(P1000mb*0.00001/Patm)**ROVCP
+        Q1 = - FQ*RAS* (QVATM - QSG)
+
+        IF (Q1.LT.0.) THEN
+! ---  condensation
+        EDIR1=0.
+        EC1=0.
+        ETT1=0.
+! ---  condensation
+!-- moisture flux for coupling with PBL
+          EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3
+          QFX= XLVm*EETA
+!-- actual moisture flux from RUC LSM
+          DEW=QKMS*(QVATM-QSG)
+          EETA= RHO*DEW
+        ELSE
+! ---  evaporation
+        EDIR1 = Q1*UMVEG *BETA
+        EC1 = Q1 * WETCAN
+        CMC2MS=CST/DELT
+       if(EC1.gt.CMC2MS) cst=0.
+        EC1=MIN(CMC2MS,EC1)*vegfrac
+!-- moisture flux for coupling with PBL
+        EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3
+!        EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3
+! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
+        QFX= XLVm * EETA
+!-- actual moisture flux from RUC LSM
+        EETA = (EDIR1 + EC1 + ETT1)*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 SNOWSEAICE(                               &
+            i,j,isoil,delt,ktau,conflx,nzs,nddzs,               &
+            meltfactor,rhonewsn,                                &  ! new
+            ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,snowfrac,     &
+            RHOSN,PATM,QVATM,QCATM,                             &
+            GLW,GSW,EMISS,RNET,                                 &
+            QKMS,TKMS,RHO,                                      &
+!--- sea ice parameters
+            ALB,ZNT,                                            &
+            tice,rhosice,capice,thdifice,                       &
+            zsmain,zshalf,DTDZS,DTDZS2,tbq,                     &
+!--- constants
+            xlv,CP,rovcp,cw,stbolt,tabs,                        &
+!--- output variables
+            ilnb,snweprint,snheiprint,rsm,tso,                  &
+            dew,soilt,soilt1,tsnav,qvg,qsg,qcg,                 &
+            SMELT,SNOH,SNFLX,SNOM,eeta,                         &
+            qfx,hfx,s,sublim,prcpl                              &
+                                                                )
+!***************************************************************
+!   Solving energy budget for snow on sea ice and heat diffusion 
+!   eqns. in snow and sea ice
+!***************************************************************
+
+
+        IMPLICIT NONE
+!-------------------------------------------------------------------
+!--- input variables
+
+   INTEGER,  INTENT(IN   )   ::  ktau,nzs     ,                  &
+                                 nddzs                         !nddzs=2*(nzs-2)
+   INTEGER,  INTENT(IN   )   ::  i,j,isoil
+
+   REAL,     INTENT(IN   )   ::  DELT,CONFLX,PRCPMS            , &
+                                 RAINF,NEWSNOW,RHONEWSN,meltfactor
+   real                      ::  rhonewcsn
+
+!--- 3-D Atmospheric variables
+   REAL,                                                         &
+            INTENT(IN   )    ::                            PATM, &
+                                                          QVATM, &
+                                                          QCATM
+!--- 2-D variables
+   REAL                                                        , &
+            INTENT(IN   )    ::                             GLW, &
+                                                            GSW, &
+                                                            RHO, &
+                                                           QKMS, &
+                                                           TKMS
+
+!--- sea ice properties
+   REAL,     DIMENSION(1:NZS)                                  , &
+            INTENT(IN   )    ::                                  &
+                                                           tice, &
+                                                        rhosice, &
+                                                         capice, &
+                                                       thdifice
+
+   REAL,     INTENT(IN   )   ::                                  &
+                                                             CW, &
+                                                            XLV
+
+   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
+
+   INTEGER,  INTENT(INOUT)    ::                           ILAND
+
+
+!-------- 2-d variables
+   REAL                                                        , &
+             INTENT(INOUT)   ::                             DEW, &
+                                                           EETA, &
+                                                          RHOSN, &
+                                                         SUBLIM, &
+                                                          PRCPL, &
+                                                            ALB, &
+                                                          EMISS, &
+                                                            ZNT, &
+                                                            QVG, &
+                                                            QSG, &
+                                                            QCG, &
+                                                            QFX, &
+                                                            HFX, &
+                                                              S, &
+                                                           SNWE, &
+                                                          SNHEI, &
+                                                          SMELT, &
+                                                           SNOM, &
+                                                           SNOH, &
+                                                          SNFLX, &
+                                                          SOILT, &
+                                                         SOILT1, &
+                                                       SNOWFRAC, &
+                                                          TSNAV
+
+   INTEGER, INTENT(INOUT)    ::                            ILNB
+
+   REAL,     INTENT(OUT)                    ::              RSM, &
+                                                      SNWEPRINT, &
+                                                     SNHEIPRINT
+!--- Local variables
+
+
+   INTEGER ::  nzs1,nzs2,k,k1,kn,kk
+   REAL    ::  x,x1,x2,dzstop,ft,tn,denom
+
+   REAL    ::  SNTH, NEWSN                                     , &
+               TABS, T3, UPFLUX, XINET                         , &
+               BETA, SNWEPR,EPDT,PP
+   REAL    ::  CP,rovcp,G0,LV,xlvm,STBOLT,xlmelt               , &
+               epot,fltot,fq,hft,q1,ras,rhoice,ci,cvw          , &
+               RIW,DELTSN,H
+
+   REAL    ::  rhocsn,thdifsn,                                   &
+               xsn,ddzsn,x1sn,d1sn,d2sn,d9sn,r22sn
+
+   REAL    ::  cotsn,rhtsn,xsn1,ddzsn1,x1sn1,ftsnow,denomsn
+   REAL    ::  fso,fsn,                                          &
+               FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11,      &
+               FKQ,R210,AA,BB,QS1,TS1,TQ2,TX2,                   &
+               TDENOM,AA1,RHCS,H1,TSOB, SNPRIM,                  &
+               SNODIF,SOH,TNOLD,QGOLD,SNOHGNEW
+   REAL,     DIMENSION(1:NZS)  ::  cotso,rhtso
+
+   REAL                        :: RNET,rsmfrac,soiltfrac,hsn
+   integer                     ::      nmelt
+
+
+!-----------------------------------------------------------------
+        XLMELT=3.35E+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 sea ice 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
+
+!tgs when the snow depth is marginlly higher than DELTSN,
+! reset DELTSN to half of snow depth.
+        IF(SNHEI.GE.DELTSN+SNTH) THEN
+! 2-layer model
+          if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth)
+        ENDIF
+
+
+        RHOICE=900.
+        CI=RHOICE*2100.
+        RAS=RHO*1.E-3
+        RIW=rhoice*1.e-3
+        RSM=0.
+
+        XLMELT=3.35E+5
+        RHOCSN=2090.* RHOSN
+!18apr08 - add rhonewcsn
+        RHOnewCSN=2090.* RHOnewSN
+        THDIFSN = 0.265/RHOCSN
+        RAS=RHO*1.E-3
+
+        SOILTFRAC=SOILT
+
+        SMELT=0.
+        SOH=0.
+        SNODIF=0.
+        SNOH=0.
+        SNOHGNEW=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))
+
+        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
+
+
+        H=1.
+        SMELT=0.
+
+        FQ=QKMS
+        SNHEI=SNWE*1.e3/RHOSN
+          SNWEPR=SNWE
+
+!  check if all snow can evaporate during DT
+         BETA=1.
+         EPDT = EPOT * RAS *DELT
+         IF(SNWEPR.LE.EPDT) THEN
+            BETA=SNWEPR/max(1.e-8,EPDT)
+            SNWE=0.
+            SNHEI=0.
+         ENDIF
+
+!******************************************************************************
+!       COEFFICIENTS FOR THOMAS ALGORITHM FOR TSO
+!******************************************************************************
+
+        cotso(1)=0.
+        rhtso(1)=TSO(NZS)
+        DO 33 K=1,NZS2
+          KN=NZS-K
+          K1=2*KN-3
+          X1=DTDZS(K1)*THDIFICE(KN-1)
+          X2=DTDZS(K1+1)*THDIFICE(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+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)*THDIFICE(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)*THDIFICE(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 sea ice 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*thdifice(1))
+         X2=DTDZS(2)*THDIFICE(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 
+!18apr08 nmelt is the flag for melting, and SNOH is heat of snow phase changes
+       nmelt=0
+       SNOH=0.
+
+        EPOT=-QKMS*(QVATM-QSG)
+        RHCS=CAPICE(1)
+        H=1.
+        FKT=TKMS
+        D1=cotso(NZS1)
+        D2=rhtso(NZS1)
+        TN=SOILT
+        D9=THDIFICE(1)*RHCS*dzstop
+        D10=TKMS*CP*RHO
+        R211=.5*CONFLX/DELT
+        R21=R211*CP*RHO
+        R22=.5/(THDIFICE(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+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 sea ice
+         D1SN = D1
+         D2SN = D2
+         D9SN = (fsn*THDIFSN*RHOCSN+fso*THDIFICE(1)*RHCS)/           &
+                 snprim
+         R22SN = snprim*snprim*0.5                                   &
+                 /((fsn*THDIFSN+fso*THDIFICE(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
+!18apr08  - the iteration start point
+ 212    continue
+        TDENOM = D9SN*(1.-D1SN +R22SN)+D10+R21+R7                    &
+              +RAINF*CVW*PRCPMS                                      &
+              +RHOnewCSN*NEWSNOW/DELT
+
+        FKQ=QKMS*RHO
+        R210=R211*RHO
+        AA=XLVM*(BETA*FKQ+R210)/TDENOM
+        BB=(D10*TABS+R21*TN+XLVM*(QVATM*                             &
+        (BETA*FKQ)                                                   &
+        +R210*QVG)+D11+D9SN*(D2SN+R22SN*TN)                          &
+        +RAINF*CVW*PRCPMS*max(273.15,TABS)                           &
+        + RHOnewCSN*NEWSNOW/DELT*min(273.15,TABS)                    &
+!18apr08 - add heat of snow phase change
+        -SNOH                                                        &
+         )/TDENOM
+        AA1=AA
+        PP=PATM*1.E3
+        AA1=AA1/PP
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+        print *,'VILKA-SNOW on SEAICE'
+        print *,'tn,aa1,bb,pp,fkq,r210',                             &
+                 tn,aa1,bb,pp,fkq,r210
+    ENDIF
+
+        CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil)
+!--- it is saturation over snow
+        QVG=QS1
+        QSG=QS1
+        QCG=0.
+
+!--- SOILT - skin temperature
+        SOILT=TS1
+
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+        print *,' AFTER VILKA-SNOW on SEAICE'
+        print *,' TS1,QS1: ', ts1,qs1
+    ENDIF
+! Solution for temperature at 7.5 cm depth and snow-seaice interface
+       IF(SNHEI.GE.SNTH) THEN
+        if(snhei.gt.DELTSN+SNTH) then
+!-- 2-layer snow model
+          SOILT1=rhtsn+cotsn*SOILT
+          TSO(1)=min(271.4,(rhtso(NZS)+cotso(NZS)*SOILT1))
+          tsob=soilt1
+        else
+!-- 1 layer in snow
+          TSO(1)=min(271.4,(rhtso(NZS)+cotso(NZS)*SOILT))
+          SOILT1=TSO(1)
+          tsob=tso(1)
+        endif
+       ELSE
+         TSO(1)=SOILT
+         SOILT1=SOILT
+         tsob=SOILT
+       ENDIF
+!---- Final solution for TSO in sea ice
+          DO K=2,NZS
+            KK=NZS-K+1
+            TSO(K)=min(271.4,(rhtso(KK)+cotso(KK)*TSO(K-1)))
+          END DO
+!--- For thin snow layer combined with the top sea ice layer
+!--- TSO is computed by linear inmterpolation between SOILT
+!--- and TSO(2)
+
+      if(nmelt.eq.1) go to 220
+
+!--- IF SOILT > 273.15 F then melting of snow can happen
+   IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN
+        nmelt = 1
+        soiltfrac=snowfrac*273.15+(1.-snowfrac)*SOILT
+         QSG= QSN(soiltfrac,TBQ)/PP
+         QVG=QSG
+        T3      = STBOLT*SOILTfrac*SOILTfrac*SOILTfrac
+        UPFLUX  = T3 * SOILTfrac
+        XINET   = EMISS*(GLW-UPFLUX)
+        RNET = GSW + XINET
+         EPOT = -QKMS*(QVATM-QSG)
+         Q1=EPOT*RAS
+
+        IF (Q1.LE.0.) THEN
+! ---  condensation
+          DEW=-EPOT
+
+        QFX= XLVM*RHO*DEW
+        EETA=QFX/XLVM
+       ELSE
+! ---  evaporation
+        EETA = Q1 * BETA *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-soiltfrac)
+
+       IF(SNHEI.GE.SNTH)then
+         SOH=thdifsn*RHOCSN*(soiltfrac-TSOB)/SNPRIM
+         SNFLX=SOH
+       ELSE
+         SOH=(fsn*thdifsn*rhocsn+fso*thdifice(1)*rhcs)*                &
+              (soiltfrac-TSOB)/snprim
+         SNFLX=SOH
+       ENDIF
+         X= (R21+D9SN*R22SN)*(soiltfrac-TNOLD) +                        &
+            XLVM*R210*(QSG-QGOLD)
+!-- SNOH is energy flux of snow phase change
+        SNOH=RNET+QFX +HFX                                              &
+                  +RHOnewCSN*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=AMAX1(0.,SMELT)
+
+!18apr08 - Egglston limit
+        SMELT= amin1 (smelt, 5.6E-7*meltfactor*max(1.,(soilt-273.15)))
+!        SMELT= amin1 (smelt, 5.6E-8*meltfactor*max(1.,(soilt-273.15)))
+!*** From Koren et al. (1999) 13% of snow melt stays in the snow pack
+!!!        rsm=0.13*smelt*delt
+       if(snwepr.gt.0.) then
+         rsmfrac=min(0.18,(max(0.08,0.10/snwepr*0.13)))
+!       else
+!         rsmfrac=0.13
+       endif
+
+         rsm=rsmfrac*smelt*delt
+!18apr08 rsm is part of melted water that stays in snow as liquid
+        SMELT=AMAX1(0.,SMELT-rsm/delt)
+
+        SNOHGNEW=SMELT*XLMELT*1.E3
+        SNODIF=AMAX1(0.,(SNOH-SNOHGNEW))
+
+        SNOH=SNOHGNEW
+
+
+!18apr08 - if snow melt occurred then go into iteration for energy budget
+!          solution
+!-- correction of liquid equivalent of snow depth
+!-- due to evaporation and snow melt
+        SNWE = AMAX1(0.,(SNWEPR-                                      &
+                    (SMELT+BETA*EPOT*RAS)*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.
+        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.0.) 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*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
+
+        snweprint=snwe
+!                                              &
+!--- if VEGFRAC.ne.0. then some snow stays on the canopy
+!--- and should be added to SNWE for water conservation
+! 4 Nov 07                    +VEGFRAC*cst
+        snheiprint=snweprint*1.E3 / RHOSN
+
+      if(nmelt.eq.1) goto 212
+ 220  continue
+
+    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
+      ENDIF
+!--- RECALCULATION OF DEW USING NEW VALUE OF QSG 
+         DEW=0.
+         PP=PATM*1.E3
+         QSG= QSN(SOILT,TBQ)/PP
+         EPOT = -FQ*(QVATM-QSG)
+       IF(EPOT.LT.0.) THEN
+! Sublimation
+          DEW=-EPOT
+        ENDIF
+!-- Restore sea-ice parameters if snow is less than threshold
+         IF(SNHEI.EQ.0.)  then
+          tsnav=soilt-273.15
+          smelt=smelt+snwe/delt
+          rsm=0.
+          emiss=1.
+          znt=0.011
+          alb=0.55
+         ENDIF
+
+        SNOM=SNOM+SMELT*DELT*1.e3
+
+!--- 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)                        &
+               *(P1000mb*0.00001/Patm)**ROVCP
+        Q1 = - FQ*RAS* (QVATM - QSG)
+        IF (Q1.LT.0.) THEN
+! ---  condensation
+!-- moisture flux for coupling with PBL
+          EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3
+          QFX= XLVm*EETA
+!-- actual moisture flux from RUC LSM
+          DEW=QKMS*(QVATM-QSG)
+          EETA= RHO*DEW
+          sublim = EETA
+        ELSE
+! ---  evaporation
+!-- moisture flux for coupling with PBL
+          EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3
+!          EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3
+! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
+          QFX= XLVm * EETA
+!-- actual moisture flux from RUC LSM
+          EETA = Q1*1.E3
+          sublim = EETA
+        ENDIF
+
+        s=THDIFICE(1)*CAPICE(1)*dzstop*(tso(1)-tso(2))
+!        s=D9SN*(SOILT-TSOB)
+        HFX=HFT
+        FLTOT=RNET-HFT-QFX-S
+!------------------------------------------------------------------------
+!------------------------------------------------------------------------
+   END SUBROUTINE SNOWSEAICE
+!------------------------------------------------------------------------
+
+
+           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 [bar]
+!     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
+        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=max(0.,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
+
+!--------------------------------------------------------------------
+   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,rhonewsn,meltfactor,             &  ! add meltfactor
+           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,rovcp,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           , &
+                                 rhonewsn,meltfactor
+   real                      ::  rhonewcsn
+
+!--- 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, &
+                                                          ROVCP, &
+                                                            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
+   integer                     ::      nmelt
+
+!-----------------------------------------------------------------
+
+       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.35E+5
+        RHOCSN=2090.* RHOSN
+!18apr08 - add rhonewcsn
+        RHOnewCSN=2090.* RHOnewSN
+        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+SNTH) then
+!-- 1-layer snow model
+         ilnb=1
+         snprim=snhei
+         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*SNPRIM)
+         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)
+!18apr08 nmelt is the flag for melting, and SNOH is heat of snow phase changes
+       nmelt=0
+       SNOH=0.
+
+
+        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+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
+!18apr08  - the iteration start point
+ 212    continue
+        TDENOM = D9SN*(1.-D1SN +R22SN)+D10+R21+R7                    &
+              +RAINF*CVW*PRCPMS                                      &
+              +RHOnewCSN*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)                           &
+        + RHOnewCSN*NEWSNOW/DELT*min(273.15,TABS)                    &
+!18apr08 - added heat of snow phase change computed in the first iteration
+        -SNOH                                                        &
+         )/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)
+!--- it is saturation over snow 
+        QVG=QS1
+        QSG=QS1
+        QCG=0.
+!--- 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+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
+         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(nmelt.eq.1) go to 220
+
+!--- IF SOILT > 273.15 F then melting of snow can happen
+   IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN
+        nmelt = 1
+        soiltfrac=snowfrac*273.15+(1.-snowfrac)*SOILT
+         QSG= QSN(soiltfrac,TBQ)/PP
+         QVG=QSG
+        T3      = STBOLT*SOILTfrac*SOILTfrac*SOILTfrac
+        UPFLUX  = T3 * SOILTfrac
+        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
+        EETA=QFX/XLVM
+       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-soiltfrac)
+
+       IF(SNHEI.GE.SNTH)then
+         SOH=thdifsn*RHOCSN*(soiltfrac-TSOB)/SNPRIM
+         SNFLX=SOH
+       ELSE
+         SOH=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)*                   &
+              (soiltfrac-TSOB)/snprim
+         SNFLX=SOH
+       ENDIF
+
+         X= (R21+D9SN*R22SN)*(soiltfrac-TNOLD) +                        &
+            XLVM*R210*(QSG-QGOLD)
+!-- SNOH is energy flux of snow phase change
+        SNOH=RNET+QFX +HFX                                              & 
+                  +RHOnewCSN*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*UMVEG)
+        SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS)
+        SMELT=AMAX1(0.,SMELT)
+
+!18apr08 - Egglston limit
+        SMELT= amin1 (smelt, 5.6E-7*meltfactor*max(1.,(soilt-273.15)))
+!        SMELT= amin1 (smelt, 5.6E-8*meltfactor*max(1.,(soilt-273.15)))
+
+!*** From Koren et al. (1999) 13% of snow melt stays in the snow pack
+!!!        rsm=0.13*smelt*delt
+       if(snwepr.gt.0.) then
+         rsmfrac=min(0.18,(max(0.08,0.10/snwepr*0.13)))
+!       else
+!         rsmfrac=0.13
+       endif
+
+         rsm=rsmfrac*smelt*delt
+!18apr08 rsm is part of melted water that stays in snow as liquid
+        SMELT=AMAX1(0.,SMELT-rsm/delt)
+
+        SNOHGNEW=SMELT*XLMELT*1.E3
+        SNODIF=AMAX1(0.,(SNOH-SNOHGNEW))
+
+        SNOH=SNOHGNEW
+
+!-- correction of liquid equivalent of snow depth
+!-- due to evaporation and snow melt
+        SNWE = AMAX1(0.,(SNWEPR-                                      &
+                    (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.
+        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.0.) 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*DELT))
+!                    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
+
+!18apr08 - if snow melt occurred then go into iteration for energy budget 
+!         solution 
+     if(nmelt.eq.1) goto 212
+ 220  continue
+!--  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).GT.273.15.AND.SNHEI.GT.0.) THEN
+          if (snhei.GE.deltsn+snth) then
+              hsn = snhei - deltsn
+          else
+              hsn = snhei
+          endif
+
+         soiltfrac=snowfrac*273.15+(1.-snowfrac)*TSO(1)
+
+        SNOHG=(TSO(1)-soiltfrac)*(RHCS*zshalf(2)+                       &
+               RHOCSN*0.5*hsn) / DELT
+        SNOHG=AMAX1(0.,SNOHG)
+        SNODIF=0. 
+        SMELTG=SNOHG/XLMELT*1.E-3
+! Egglston - empirical limit on snow melt from the bottom of snow pack
+        SMELTG=AMIN1(SMELTG, 5.8e-9)
+
+       if(SNWE-SMELTG*DELT.ge.rsm) then
+        SNWE = AMAX1(0.,SNWE-SMELTG*DELT)
+       else
+           smeltg=snwe/delt
+           snwe=0.
+           rsm=0.
+           hsn=0.
+       endif
+
+        SNOHGNEW=SMELTG*XLMELT*1.e3
+        SNODIF=AMAX1(0.,(SNOHG-SNOHGNEW))
+        TSO(1)=soiltfrac                  &
+                + SNODIF/(RHCS*zshalf(2)+ RHOCSN*0.5*hsn)* DELT
+        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
+! 4 Nov 07                    +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
+      ENDIF
+
+!        return
+!        end
+!------------------------------------------------------------------------
+   END SUBROUTINE SNOWTEMP
+!------------------------------------------------------------------------
+
+
+        SUBROUTINE SOILMOIST (                                  &
+!--input parameters
+              DELT,NZS,NDDZS,DTDZS,DTDZS2,RIW,                  &
+              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,SOILIQW,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)
+!     SOILIQW - volumetric content of liquid water 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,RIW
+                         
+! output
+
+   REAL,     DIMENSION(  1:nzs )                               , &
+
+             INTENT(INOUT)   ::                SOILMOIS,SOILIQW
+                                                  
+   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,FK,FKMAX
+   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))
+        X1=ZSMAIN(NZS)-ZSMAIN(NZS1)
+
+!7may09        DID=(ZSMAIN(NZS)-ZSHALF(NZS))*2.
+!        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)=(SOILIQW(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)=(SOILIQW(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
+
+  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)
+         DICE=SOILICE(1)*ZSHALF(2)
+         FD=F1
+        do k=2,nzs1
+         DICE=DICE+(ZSHALF(k+1)-ZSHALF(k))*SOILICE(K)
+         FKMAX=DQM*(ZSHALF(k+1)-ZSHALF(k))
+         FK=FKMAX*(1.-SOILMOIS(k)/DQM)
+         FD=FD+FK
+        enddo
+         KDT=REFKDT*KSAT/REFDK
+         VAL=(1.-EXP(-KDT*DELT1))
+         DDT = FD*VAL
+         PX= - TOTLIQ * DELT
+         IF(PX.LT.0.0) PX = 0.0
+         INFMAX1 = (PX*(DDT/(PX+DDT)))/DELT
+!         print *,'INFMAX1=,ksat',infmax1,ksat,f1,f2,kdt,val,ddt,px
+! -----------     FROZEN GROUND VERSION    --------------------------
+!    REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS
+!
+! ------------------------------------------------------------------
+
+         FRZX= 0.15*((dqm+qmin)/ref) * (0.412 / 0.468)
+         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
+! -------------------------------------------------------------------
+
+         INFMAX = MAX(INFMAX1,HYDRO(1)*SOILIQW(1))
+         INFMAX = MIN(INFMAX, -TOTLIQ)
+        
+!----
+          IF (-TOTLIQ.GT.INFMAX)THEN
+            RUNOFF=-TOTLIQ-INFMAX
+            FLX=-INFMAX
+          ENDIF
+! INFILTRP is total infiltration flux in M/S
+          INFILTRP=FLX
+! Solution of moisture budget
+          R7=.5*DZS/DELT
+          R4=R4+R7
+          FLX=FLX-SOILIQW(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
+            SOILIQW (1)=1.e-8
+            SOILMOIS(1)=1.e-8+soilice(1)*riw
+
+          ELSE IF(QQ.GT.DQM) THEN
+!-- saturation
+            SOILIQW (1)=DQM
+            SOILMOIS(1)=DQM
+            RUNOFF2=(FLXSAT-FLX)*DELT
+            RUNOFF=RUNOFF+(FLXSAT-FLX)
+          ELSE
+            SOILIQW (1)=min(dqm,max(1.e-8,QQ))
+            SOILMOIS(1)=max(1.e-8,QQ)+soilice(1)*riw
+          END IF
+
+!--- FINAL SOLUTION FOR SOILMOIS 
+          DO K=2,NZS
+            KK=NZS-K+1
+            QQ=COSMC(KK)*SOILIQW(K-1)+RHSMC(KK)
+
+           IF (QQ.LT.0.) THEN
+            SOILIQW(K) =1.e-8
+            SOILMOIS(K)=1.e-8 + soilice(k)*riw
+
+           ELSE IF(QQ.GT.DQM) THEN
+!-- saturation
+            SOILIQW (K)=DQM
+            SOILMOIS(K)=DQM
+             IF(K.EQ.NZS)THEN
+               RUNOFF2=RUNOFF2+(QQ-DQM)*(ZSMAIN(K)-ZSHALF(K))
+             ELSE
+               RUNOFF2=RUNOFF2+(QQ-DQM)*(ZSHALF(K+1)-ZSHALF(K))
+             ENDIF
+           ELSE
+            SOILIQW (K)=min(dqm,max(1.e-8,QQ))
+            SOILMOIS(K)=max(1.e-8,QQ)+soilice(k)*riw
+           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,tabs,                            &
+!--- 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
+
+   REAL                                                        , &
+            INTENT(IN   )    ::                            TABS
+!--- 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    ::  FTEM
+   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
+!--- air temperature function
+!     Avissar (1985) and AX 7/95
+        IF (TABS .LE. 302.15) THEN
+          FTEM = 1.0 / (1.0 + EXP(-0.41 * (TABS - 282.05)))
+        ELSE
+          FTEM = 1.0 / (1.0 + EXP(0.5 * (TABS - 314.0)))
+        ENDIF
+!---
+        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)
+          TRANF(1)=TRANF(1)*FTEM
+
+        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)
+          TRANF(k)=TRANF(k)*FTEM
+        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+3
+      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
+!
+!   25:   Playa
+!   26:   Lava
+!   27:   White Sand
+
+
+!----  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,     &
+                   .30,.16,.60 /
+        DATA LEMI/.88,4*.92,.93,.92,.88,.9,.92,.93,.94,                 &
+                  .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95,      &
+                  .85,.85,.90 /
+!-- 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,         &
+                   .01,.15,.01 /
+
+        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,.40,.50,.40/
+!
+!---- still needs to be corrected
+!
+!       DATA LPC/ 15*.8,0.,.8,.8,.5,.5,.5,.5,.5,.0/
+       DATA LPC /0.4,0.3,0.4,0.4,0.4,0.4,0.4,0.4,0.4,0.4,5*0.55,0.,0.55,0.55,                   &
+                 0.3,0.3,0.4,0.4,0.3,0.,.3,0.,0./
+
+! used in RUC       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,12*0/
+
+          do k=1,nvegclas
+             iforest(k)=if1(k)
+          enddo
+
+
+!        EMISS = LEMI(IVGTYP)
+        EMISS = LEMITBL(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.
+
+!tgs 3 Oct 2007 - MYJSFCINIT roughness produced unrealistic fluxes,
+!tgs - will not use it any more!
+!tgs        if (.not. myj) then
+!        ZNT   = LROU(IVGTYP)
+        ZNT   = Z0TBL(IVGTYP)
+!tgs        endif
+
+!        PC     = LPC (IVGTYP)
+        PC     = PCTBL(IVGTYP)
+!        RHOCS  = LRHC(ISLTYP)*1.E6
+        RHOCS  = HC(ISLTYP)*1.E6
+
+! parameters from SOILPARM.TBL
+          BCLH   = BB(ISLTYP)
+          DQM    = MAXSMC(ISLTYP)-                               &
+                   DRYSMC(ISLTYP)
+          KSAT   = SATDK(ISLTYP)
+          PSIS   = - SATPSI(ISLTYP)
+          QMIN   = DRYSMC(ISLTYP)
+          REF    = REFSMC(ISLTYP)
+          WILT   = WLTSMC(ISLTYP)
+          QWRTZ  = QTZ(ISLTYP)
+
+! parameters from the look-up tables
+!          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+3
+
+
+   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,     &
+                   .30,.16,.60/
+        DATA LEMI/.88,4*.92,.93,.92,.88,.9,.92,.93,.94,                 &
+                  .95,.95,.94,.98,.95,.95,.85,.92,.93,.92,.85,.95,      &
+                  .85,.85,.90 /
+!-- 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,          &
+                   .01,.15,.01 /
+
+! 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,    &
+                  .01,.15,.01 /
+
+
+
+!--------------------------------------------------------------------------
+
+        EMISS  = LEMITBL(IVGTYP)
+!tgs 3 Oct 2007  - LROU_MYJ gives unrealistic surface fluxes with RUC LSM with RUC LSM
+!       if(myj) then
+!        ZNT    = LROU_MYJ(IVGTYP)
+!       else
+        ZNT    = Z0TBL(IVGTYP)
+!!!        ZNT    = LROU(IVGTYP)
+!       endif
+        ILAND  =      IVGTYP
+! --- 
+
+!        RETURN
+!        END
+!--------------------------------------------------------------------------
+   END SUBROUTINE SNOWFREE
+
+  SUBROUTINE RUCLSMINIT( SH2O,SMFR3D,TSLB,SMOIS,ISLTYP,IVGTYP,     &
+                     XICE,mavail,nzs, iswater, isice, restart,     &
+                     allowed_to_read ,                             &
+                     ids,ide, jds,jde, kds,kde,                    &
+                     ims,ime, jms,jme, kms,kme,                    &
+                     its,ite, jts,jte, kts,kte                     )
+#ifdef WRF_CHEM
+  USE module_data_gocart_dust
+#endif
+   IMPLICIT NONE
+
+
+   INTEGER,  INTENT(IN   )   ::     ids,ide, jds,jde, kds,kde,  &
+                                    ims,ime, jms,jme, kms,kme,  &
+                                    its,ite, jts,jte, kts,kte,  &
+                                    nzs, iswater, isice
+
+   REAL, DIMENSION( ims:ime, 1:nzs, jms:jme )                    , &
+            INTENT(IN)    ::                                 TSLB, &
+                                                            SMOIS
+
+   INTEGER, DIMENSION( ims:ime, jms:jme )                        , &
+            INTENT(INOUT)    ::                     ISLTYP,IVGTYP
+
+   REAL, DIMENSION( ims:ime, 1:nzs, jms:jme )                    , &
+            INTENT(INOUT)    ::                            SMFR3D, &
+                                                             SH2O
+
+   REAL, DIMENSION( ims:ime, jms:jme )                           , &
+            INTENT(INOUT)    ::                       XICE,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
+
+   INTEGER                   :: errflag
+
+!   itf=min0(ite,ide-1)
+!   jtf=min0(jte,jde-1)
+
+
+        RIW=900.*1.e-3
+        XLMELT=3.35E+5
+
+! initialize three  LSM related tables
+   IF ( allowed_to_read ) THEN
+     CALL wrf_message( 'INITIALIZE THREE LSM RELATED TABLES' )
+     CALL  RUCLSM_PARM_INIT
+   ENDIF
+
+#ifdef WRF_CHEM
+!
+! need this parameter for dust parameterization in wrf/chem
+!
+   do I=1,NSLTYPE
+      porosity(i)=maxsmc(i)
+   enddo
+#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_ruclsm.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_ruclsm.F: lsminit: out of range value "// &
+                            "of ISLTYP. Is this field in the input?" )
+   ENDIF
+
+   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
+          DQM    = MAXSMC   (ISLTYP(I,J)) -                               &
+                   DRYSMC   (ISLTYP(I,J))
+          REF    = REFSMC   (ISLTYP(I,J))
+          PSIS   = - SATPSI (ISLTYP(I,J))
+          QMIN   = DRYSMC   (ISLTYP(I,J))
+          BCLH   = BB       (ISLTYP(I,J))
+
+
+!!!     IF (.not.restart) THEN
+
+    IF(xice(i,j).gt.0.) THEN
+!-- for ice
+         DO L=1,NZS
+           smfr3d(i,l,j)=1.
+           sh2o(i,l,j)=0.
+           mavail(i,j) = 1.
+         ENDDO
+    ELSE
+       if(isltyp(i,j).ne.14 ) then
+!-- land
+           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)))
+         DO L=1,NZS
+!-- 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))
+           sh2o(i,l,j)=soiliqw(l)
+           smfr3d(i,l,j)=(smois(i,l,j)-soiliqw(l))/RIW
+         
+          else
+           smfr3d(i,l,j)=0.
+           sh2o(i,l,j)=smois(i,l,j)
+          endif
+         ENDDO
+    
+       else
+!-- for water  ISLTYP=14
+         DO L=1,NZS
+           smfr3d(i,l,j)=0.
+           sh2o(i,l,j)=1.
+           mavail(i,j) = 1.
+         ENDDO
+       endif
+    ENDIF
+
+    ENDDO
+   ENDDO
+
+ ENDIF
+
+  END SUBROUTINE ruclsminit
+!
+!-----------------------------------------------------------------
+        SUBROUTINE RUCLSM_PARM_INIT
+!-----------------------------------------------------------------
+
+        character*8 :: MMINLU, MMINSL
+
+        MMINLU='USGS-RUC'
+        MMINSL='STAS-RUC'
+        call RUCLSM_SOILVEGPARM( MMINLU, MMINSL)
+
+!-----------------------------------------------------------------
+        END SUBROUTINE RUCLSM_PARM_INIT
+!-----------------------------------------------------------------
+
+!-----------------------------------------------------------------
+        SUBROUTINE RUCLSM_SOILVEGPARM( MMINLU, MMINSL)
+!-----------------------------------------------------------------
+
+        IMPLICIT NONE
+
+        integer :: LUMATCH, IINDEX, LC, NUM_SLOPE
+        integer :: ierr
+        INTEGER , PARAMETER :: OPEN_OK = 0
+
+        character*8 :: MMINLU, MMINSL
+        character*128 :: mess , message, vege_parm_string
+        logical, external :: wrf_dm_on_monitor
+
+
+!-----SPECIFY VEGETATION RELATED CHARACTERISTICS :
+!             ALBBCK: SFC albedo (in percentage)
+!                 Z0: Roughness length (m)
+!               LEMI: Emissivity
+!                 PC: Plant coefficient for transpiration function
+! -- the rest of the parameters are read in but not used currently
+!             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_ruclsm.F: soil_veg_gen_parm: failure opening VEGPARM.TBL'
+          CALL wrf_error_fatal ( message )
+        END IF
+
+        WRITE ( mess, * ) 'INPUT VEGPARM FOR ',MMINLU
+        CALL wrf_message( mess )
+
+        LUMATCH=0
+
+ 2000   FORMAT (A8)
+        READ (19,'(A)') vege_parm_string
+        outer : DO 
+           READ (19,2000,END=2002)LUTYPE
+           READ (19,*)LUCATS,IINDEX
+
+           WRITE( mess , * ) 'VEGPARM FOR ',LUTYPE,' FOUND', LUCATS,' CATEGORIES'
+           CALL wrf_message( mess )
+
+           IF(LUTYPE.NE.MMINLU)THEN    ! Skip over the undesired table
+              write ( mess , * ) 'Skipping ', LUTYPE, ' table'
+              CALL wrf_message( mess )
+              DO LC=1,LUCATS
+                 READ (19,*)
+              ENDDO
+              inner : DO               ! Find the next "Vegetation Parameters"
+                 READ (19,'(A)',END=2002) vege_parm_string
+                 IF (TRIM(vege_parm_string) .EQ. "Vegetation Parameters") THEN
+                    EXIT inner
+                 END IF
+               ENDDO inner
+           ELSE
+              LUMATCH=1
+              write ( mess , * ) 'Found ', LUTYPE, ' table'
+              CALL wrf_message( mess )
+              EXIT outer                ! Found the table, read the data
+           END IF
+
+        ENDDO outer
+
+        IF (LUMATCH == 1) then
+           write ( mess , * ) 'Reading ',LUTYPE,' table'
+           CALL wrf_message( mess )
+           DO LC=1,LUCATS
+              READ (19,*)IINDEX,ALBTBL(LC),Z0TBL(LC),LEMITBL(LC),PCTBL(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
+           READ (19,*)
+           READ (19,*)NATURAL
+        ENDIF
+
+ 2002   CONTINUE
+        CLOSE (19)
+
+        IF (LUMATCH == 0) then
+           CALL wrf_error_fatal ("Land Use Dataset '"//MMINLU//"' not found in VEGPARM.TBL.")
+        ENDIF
+
+      END IF
+
+      CALL wrf_dm_bcast_string  ( LUTYPE  , 8 )
+      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    ( LEMITBL , NLUS )
+      CALL wrf_dm_bcast_real    ( PCTBL   , 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_ruclsm.F: soil_veg_gen_parm: failure opening SOILPARM.TBL'
+          CALL wrf_error_fatal ( message )
+        END IF
+
+        WRITE(mess,*) 'INPUT SOIL TEXTURE CLASSIFICATION = ',MMINSL
+        CALL wrf_message( mess )
+
+        LUMATCH=0
+
+        READ (19,*)
+        READ (19,2000,END=2003)SLTYPE
+        READ (19,*)SLCATS,IINDEX
+        IF(SLTYPE.NE.MMINSL)THEN
+          DO LC=1,SLCATS
+              READ (19,*) IINDEX,BB(LC),DRYSMC(LC),HC(LC),MAXSMC(LC),&
+                        REFSMC(LC),SATPSI(LC),SATDK(LC), SATDW(LC),   &
+                        WLTSMC(LC), QTZ(LC)
+          ENDDO
+        ENDIF
+        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),HC(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  , 8 )
+      CALL wrf_dm_bcast_string  ( MMINSL  , 8 )  ! 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    ( HC      , 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_ruclsm.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 RUCLSM_SOILVEGPARM
+!-----------------------------------------------------------------
+
+
+  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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_sfcdiags.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_sfcdiags.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_sfcdiags.F	(revision 17)
@@ -0,0 +1,55 @@
+!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))
+          if(CQS2(I,J).lt.1.E-5) then
+             Q2(I,J)=QSFC(I,J)
+          else
+             Q2(I,J) = QSFC(I,J) - QFX(I,J)/(RHO*CQS2(I,J))
+          endif
+          if(CHS2(I,J).lt.1.E-5) then
+             T2(I,J) = TSK(I,J) 
+          else
+             T2(I,J) = TSK(I,J) - HFX(I,J)/(RHO*CP*CHS2(I,J))
+          endif
+          TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**ROVCP
+        ENDDO
+      ENDDO
+
+  END SUBROUTINE SFCDIAGS
+
+END MODULE module_sf_sfcdiags
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_sfcdiags_ruclsm.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_sfcdiags_ruclsm.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_sfcdiags_ruclsm.F	(revision 17)
@@ -0,0 +1,160 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+MODULE module_sf_sfcdiags_ruclsm
+
+CONTAINS
+
+   SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS2,CQS2,T2,TH2,Q2,       &
+                     T3D,QV3D,RHO3D,P3D,                           &
+                     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,    DIMENSION( ims:ime, kms:kme, jms:jme )            , &
+               INTENT(IN   )    ::                           QV3D, &
+                                                              T3D, &
+                                                              P3D, &
+                                                            rho3D
+
+      REAL,     INTENT(IN   )               ::       CP,R_d,ROVCP
+! LOCAL VARS
+      INTEGER ::  I,J
+      REAL    ::  RHO, x2m, qlev1, tempc, qsat, p2m
+
+
+      DO J=jts,jte
+        DO I=its,ite
+!          RHO = PSFC(I,J)/(R_d * TSK(I,J))
+          RHO = RHO3D(i,1,j)
+          P2m = PSFC(I,J)*EXP(-0.068283/t3d(i,1,j))
+
+          if(CHS2(I,J).lt.1.E-5) then
+!             TH2(I,J) = TSK(I,J)*(1.E5/PSFC(I,J))**ROVCP 
+             TH2(I,J) = t3d(i,1,j)*(1.E5/P2m)**ROVCP 
+          else
+             TH2(I,J) = TSK(I,J)*(1.E5/PSFC(I,J))**ROVCP - HFX(I,J)/(RHO*CP*CHS2(I,J))
+!tgs             T2(I,J) = TSK(I,J) - HFX(I,J)/(RHO*CP*CHS2(I,J))
+          endif
+!tgs             TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**ROVCP
+             T2(I,J) = TH2(I,J)*(1.E-5*P2m)**ROVCP
+!tgs check that T2 values lie in the range between TSK and T at the 1st level
+             x2m     = MAX(MIN(tsk(i,j),t3d(i,1,j)) , t2(i,j))
+             t2(i,j) = MIN(MAX(tsk(i,j),t3d(i,1,j)) , x2m)
+
+             TH2(I,J) = T2(I,J)*(1.E5/P2m)**ROVCP
+
+!tgs check that Q2 values in the lie between QSFC and Q at the 1st level
+             qlev1 = qv3d(i,1,j)
+!tgs saturation check
+             tempc=t3d(i,1,j)-273.15
+           if (tempc .le. 0.0) then
+! qsat - mixing ratio
+             qsat = rsif(p3d(i,1,j), t3d(i,1,j))
+           else
+             qsat = rslf(p3d(i,1,j), t3d(i,1,j))
+           endif
+             qlev1 = min(qsat, qlev1)
+
+          if(CQS2(I,J).lt.1.E-5) then
+!tgs - here Q2 is 2-m water vapor mixing ratio
+             Q2(I,J)=qlev1
+          else
+             x2m = QSFC(I,J) - QFX(I,J)/(RHO*CQS2(I,J))
+             Q2(I,J)=x2m/(1.-x2m)
+          endif
+
+             x2m     = MAX(MIN(qsfc(i,j)/(1.-qsfc(i,j)),qlev1) , q2(i,j))
+             q2(i,j) = MIN(MAX(qsfc(i,j)/(1.-qsfc(i,j)),qlev1) , x2m)
+!tgs saturation check
+             tempc=t2(i,j)-273.15
+           if (tempc .le. 0.0) then
+! qsat - mixing ratio
+             qsat = rsif(psfc(i,j), t2(i,j))
+           else
+             qsat = rslf(psfc(i,j), t2(i,j))
+           endif
+            
+             q2(i,j) = min(qsat, q2(i,j))
+
+        ENDDO
+      ENDDO
+
+  END SUBROUTINE SFCDIAGS_RUCLSM
+
+!tgs - saturation functions are from Thompson microphysics scheme
+      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
+!
+!    ALTERNATIVE
+!  ; Source: Murphy and Koop, Review of the vapour pressure of ice and
+!             supercooled water for atmospheric applications, Q. J. R.
+!             Meteorol. Soc (2005), 131, pp. 1539-1565.
+!    Psat = EXP(54.842763 - 6763.22 / T - 4.210 * ALOG(T) + 0.000367 * T
+!         + TANH(0.0415 * (T - 218.8)) * (53.878 - 1331.22
+!         / T - 9.44523 * ALOG(T) + 0.014025 * T))
+!
+!+---+-----------------------------------------------------------------+
+! 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_sf_sfcdiags_ruclsm
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_sfclay.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_sfclay.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_sfclay.F	(revision 17)
@@ -0,0 +1,883 @@
+!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, &
+                     U10,V10,TH2,T2,Q2,                            &
+                     GZ1OZ0,WSPD,BR,ISFFLX,DX,                     &
+                     SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
+                     KARMAN,EOMEG,STBOLT,                          &
+                     P1000mb,                                      &
+                     ids,ide, jds,jde, kds,kde,                    &
+                     ims,ime, jms,jme, kms,kme,                    &
+                     its,ite, jts,jte, kts,kte,                    &
+                     ustm,ck,cka,cd,cda,isftcflx,iz0tlnd           )
+!-------------------------------------------------------------------
+      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)
+!-- USTM        u* in similarity theory (m/s) without vconv correction
+!               used to couple with TKE scheme
+!-- 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
+!-- 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)
+!-- ck          enthalpy exchange coeff at 10 meters
+!-- cd          momentum exchange coeff at 10 meters
+!-- cka         enthalpy exchange coeff at the lowest model level
+!-- cda         momentum exchange coeff at the lowest model level
+!-- isftcflx    =0, (Charnock and Carlson-Boland); =1, AHW Ck, Cd, =2 Garratt
+!-- iz0tlnd     =0 Carlson-Boland, =1 Czil_new
+!-- 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,     INTENT(IN )   ::        P1000mb
+!
+      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(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
+ 
+      REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme )              , &
+                INTENT(OUT)     ::              ck,cka,cd,cda,ustm
+
+      INTEGER,  OPTIONAL,  INTENT(IN )   ::     ISFTCFLX, IZ0TLND
+
+! 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
+
+        !  Sending array starting locations of optional variables may cause
+        !  troubles, so we explicitly change the call.
+
+        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),     &
+                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,  &
+                P1000mb,                                           &
+                ids,ide, jds,jde, kds,kde,                         &
+                ims,ime, jms,jme, kms,kme,                         &
+                its,ite, jts,jte, kts,kte                          &
+#if ( EM_CORE == 1 )
+                ,isftcflx,iz0tlnd,                                 &
+                USTM(ims,j),CK(ims,j),CKA(ims,j),                  &
+                CD(ims,j),CDA(ims,j)                               &
+#endif
+                                                                   )
+      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,                            &
+                     U10,V10,TH2,T2,Q2,FLHC,FLQC,QGH,              &
+                     QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX,             &
+                     SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
+                     KARMAN,EOMEG,STBOLT,                          &
+                     P1000mb,                                      &
+                     ids,ide, jds,jde, kds,kde,                    &
+                     ims,ime, jms,jme, kms,kme,                    &
+                     its,ite, jts,jte, kts,kte,                    &
+                     isftcflx, iz0tlnd,                            &
+                     ustm,ck,cka,cd,cda                            )
+!-------------------------------------------------------------------
+      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,     INTENT(IN )   ::        P1000mb
+
+!
+      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,     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
+ 
+      REAL, OPTIONAL, DIMENSION( ims:ime )                       , &
+                INTENT(OUT)     ::              ck,cka,cd,cda,ustm
+
+      INTEGER,  OPTIONAL,  INTENT(IN )   ::     ISFTCFLX, IZ0TLND
+
+! LOCAL VARS
+
+      REAL,     DIMENSION( its:ite )        ::                 ZA, &
+                                                        THVX,ZQKL, &
+                                                           ZQKLP1, &
+                                                           THX,QX, &
+                                                            PSIH2, &
+                                                            PSIM2, &
+                                                           PSIH10, &
+                                                           PSIM10, &
+                                                           DENOMQ, &
+                                                          DENOMQ2, &
+                                                          DENOMT2, &
+                                                            WSPDI, &
+                                                           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,DTTHX,PSIX10,PSIT,PSIT2,PSIQ,PSIQ2,PSIQ10
+      REAL    ::  FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,RESTAR2
+!-------------------------------------------------------------------
+      KL=kte
+
+      DO i=its,ite
+! PSFC cb
+         PSFC(I)=PSFCPA(I)/1000.
+      ENDDO
+!                                                      
+!----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE:  
+!                                                            
+      DO 5 I=its,ite                                   
+        TGDSA(I)=TSK(I)                                    
+! PSFC cb
+!        THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP                
+        THGB(I)=TSK(I)*(P1000mb/PSFCPA(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 cb
+         PL=P1D(I)/1000.
+         SCR3(I)=T1D(I)                                                   
+!         THCON=(100./PL)**ROVCP                                                 
+         THCON=(P1000mb*0.001/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))                       
+!  for land points QSFC can come from previous time step
+        if(xland(i).gt.1.5.or.qsfc(i).le.0.0)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))                       
+        PL=P1D(I)/1000.
+        QGH(I)=EP2*E1/(PL-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))                     
+        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)
+!      Use Beljaars over land, old MM5 (Wyngaard) formula over water
+        if (xland(i).lt.1.5) then
+        fluxc = max(hfx(i)/rhox(i)/cp                    &
+              + ep1*tskv*qfx(i)/rhox(i),0.)
+        VCONV = vconvc*(g/tgdsa(i)*pblh(i)*fluxc)**.33
+        else
+        IF(-DTHVDZ.GE.0)THEN
+          DTHVM=-DTHVDZ
+        ELSE
+          DTHVM=0.
+        ENDIF
+        VCONV = 2.*SQRT(DTHVM)
+        endif
+! Mahrt and Sun low-res correction
+        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))
+! AHW: mods to compute ck, cd
+        PSIH10(I)=AMIN1(PSIH10(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)                                   
+! AHW: mods to compute ck, cd
+        PSIQ10=ALOG(KARMAN*UST(I)*10./XKA+10./ZL)-PSIH10(I)
+        IF ( PRESENT(ISFTCFLX) ) THEN
+           IF ( ISFTCFLX.EQ.1 .AND. (XLAND(I)-1.5).GE.0. ) THEN
+! v3.1
+!             Z0Q = 1.e-4 + 1.e-3*(MAX(0.,UST(I)-1.))**2
+! hfip1
+!             Z0Q = 0.62*2.0E-5/UST(I) + 1.E-3*(MAX(0.,UST(I)-1.5))**2
+! v3.2
+              Z0Q = 1.e-4
+              PSIQ=ALOG(ZA(I)/Z0Q)-PSIH(I)
+              PSIT=PSIQ
+              PSIQ2=ALOG(2./Z0Q)-PSIH2(I)
+              PSIQ10=ALOG(10./Z0Q)-PSIH10(I)
+              PSIT2=PSIQ2
+           ENDIF
+           IF ( ISFTCFLX.EQ.2 .AND. (XLAND(I)-1.5).GE.0. ) THEN
+! AHW: Garratt formula: Calculate roughness Reynolds number
+!        Kinematic viscosity of air (linear approc to
+!                 temp dependence at sea levle)
+              VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5
+!!            VISC=1.5E-5
+              RESTAR=UST(I)*ZNT(I)/VISC
+              RESTAR2=2.48*SQRT(SQRT(RESTAR))-2.
+              PSIT=GZ1OZ0(I)-PSIH(I)+RESTAR2
+              PSIQ=GZ1OZ0(I)-PSIH(I)+2.28*SQRT(SQRT(RESTAR))-2.
+              PSIT2=GZ2OZ0(I)-PSIH2(I)+RESTAR2
+              PSIQ2=GZ2OZ0(I)-PSIH2(I)+2.28*SQRT(SQRT(RESTAR))-2.
+              PSIQ10=GZ10OZ0(I)-PSIH(I)+2.28*SQRT(SQRT(RESTAR))-2.
+           ENDIF
+        ENDIF
+        IF(PRESENT(ck) .and. PRESENT(cd) .and. PRESENT(cka) .and. PRESENT(cda)) THEN
+           Ck(I)=(karman/psix10)*(karman/psiq10)
+           Cd(I)=(karman/psix10)*(karman/psix10)
+           Cka(I)=(karman/psix)*(karman/psiq)
+           Cda(I)=(karman/psix)*(karman/psix)
+        ENDIF
+        IF ( PRESENT(IZ0TLND) ) THEN
+           IF ( IZ0TLND.EQ.1 .AND. (XLAND(I)-1.5).LE.0. ) THEN
+              ZL=ZNT(I)
+!             CZIL RELATED CHANGES FOR LAND
+              VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5
+              RESTAR=UST(I)*ZL/VISC
+!             Modify CZIL according to Chen & Zhang, 2009
+
+              CZIL = 10.0 ** ( -0.40 * ( ZL / 0.07 ) )
+
+              PSIT=GZ1OZ0(I)-PSIH(I)+CZIL*KARMAN*SQRT(RESTAR)
+              PSIQ=GZ1OZ0(I)-PSIH(I)+CZIL*KARMAN*SQRT(RESTAR)
+              PSIT2=GZ2OZ0(I)-PSIH2(I)+CZIL*KARMAN*SQRT(RESTAR)
+              PSIQ2=GZ2OZ0(I)-PSIH2(I)+CZIL*KARMAN*SQRT(RESTAR)
+
+           ENDIF
+        ENDIF
+! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE 
+        UST(I)=0.5*UST(I)+0.5*KARMAN*WSPD(I)/PSIX                                             
+! TKE coupling: compute ust without vconv for use in tke scheme
+        WSPDI(I)=SQRT(UX(I)*UX(I)+VX(I)*VX(I))
+        IF ( PRESENT(USTM) ) THEN
+        USTM(I)=0.5*USTM(I)+0.5*KARMAN*WSPDI(I)/PSIX
+        ENDIF
+        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                     
+        T2(I) = TH2(I)*(PSFCPA(I)/P1000mb)**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((XLAND(I)-1.5).LT.0.)THEN                                            
+          UST(I)=AMAX1(UST(I),0.1)
+        ENDIF                                                                    
+        MOL(I)=KARMAN*DTG/PSIT/PRT                              
+        DENOMQ(I)=PSIQ
+        DENOMQ2(I)=PSIQ2
+        DENOMT2(I)=PSIT2
+  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                                   
+! AHW: change roughness length, and hence the drag coefficients Ck and Cd
+          IF ( PRESENT(ISFTCFLX) ) THEN
+             IF ( ISFTCFLX.NE.0 ) THEN
+!               ZNT(I)=10.*exp(-9.*UST(I)**(-.3333))
+                ZNT(I)=10.*exp(-9.5*UST(I)**(-.3333))
+                ZNT(I)=ZNT(I) + 0.11*1.5E-5/AMAX1(UST(I),0.01)
+                ZNT(I)=MIN(ZNT(I),2.85e-3)
+                ZNT(I)=MAX(ZNT(I),1.27e-7)
+             ENDIF
+          ENDIF
+          ZL = ZNT(I)
+        ELSE
+          ZL = 0.01
+        ENDIF                                                                    
+        FLQC(I)=RHOX(I)*MAVAIL(I)*UST(I)*KARMAN/DENOMQ(I)
+!       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))                                
+          IF ( PRESENT(ISFTCFLX) ) THEN
+             IF ( ISFTCFLX.NE.0 ) THEN
+! AHW: add dissipative heating term
+                HFX(I)=HFX(I)+RHOX(I)*USTM(I)*USTM(I)*WSPDI(I)
+             ENDIF
+          ENDIF
+        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/DENOMQ(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/DENOMQ2(I)
+         CHS2(I)=UST(I)*KARMAN/DENOMT2(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
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_slab.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_slab.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_slab.F	(revision 17)
@@ -0,0 +1,556 @@
+!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,       &
+                   P1000mb,                                     &
+                   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,     INTENT(IN )     ::     P1000mb
+
+   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,      &
+           P1000mb,                                             &
+           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,     &
+                   P1000mb,                                     &
+                   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,     INTENT(IN )     ::     P1000mb
+
+   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
+         THCON=(P1000mb*0.001/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
+        OLTG(I)=TSK(I)*(P1000mb*0.001/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    
+                PS1=(PSFCPA(I)/P1000mb)**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
+! WA added check for flqc = 0 to accomodate TEMF (and others?)
+        if ( FLQC(I) .ne. 0.) then
+           QSFC(I)=QX(I)+QFX(I)/FLQC(I)
+        else
+           QSFC(I) = QX(I)
+        end if
+        CHKLOWQ(I)=MAVAIL(I)
+      ENDDO
+!                                                                                
+  140 CONTINUE                                                                   
+
+   END SUBROUTINE SLAB1D
+
+!================================================================
+   SUBROUTINE slabinit(TSK,TMN,                                 &
+                       TSLB,ZS,DZS,num_soil_layers,             &
+                       allowed_to_read, start_of_simulation,    &
+                       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
+   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, 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
+   CHARACTER*1024 message
+
+!----------------------------------------------------------------
+ 
+   itf=min0(ite,ide-1)
+   jtf=min0(jte,jde-1)
+
+   END SUBROUTINE slabinit
+!-------------------------------------------------------------------          
+
+END MODULE module_sf_slab
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_sstskin.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_sstskin.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_sstskin.F	(revision 17)
@@ -0,0 +1,141 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+MODULE module_sf_sstskin
+
+CONTAINS
+
+   SUBROUTINE sst_skin_update(xland,glw,gsw,hfx,qfx,tsk,ust,emiss,  &
+                dtw1,sstsk,dt,stbolt,                                &
+                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
+
+
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: xland, glw, gsw
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: hfx, qfx, tsk
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(IN   ) :: ust, emiss
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT  ) :: dtw1         ! warm temp difference (C)
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT  ) :: sstsk        ! skin sst (K)
+   REAL,                                      INTENT(IN )   ::   DT           ! model time step
+   REAL,                                      INTENT(IN )   ::   STBOLT       ! Stefan-Boltzmann constant (W/m^2/K^4)
+!---------------------------------------------------------------------
+! Local
+   REAL :: lw, sw, q, qn, zeta, dep, dtw3, skinmax, skinmin
+   REAL :: fs, con1, con2, con3, con4, con5, zlan, q2, ts, phi, qn1
+   REAL :: usw, qo, swo, us, tb, dtc, dtw, alw, dtwo, delt, f1
+   INTEGER :: i, j, k
+!---------------------------------------------------------------------
+   INTEGER , PARAMETER :: n=1152
+   REAL , PARAMETER :: z1=3.,an=.3,zk=.4,rho=1.2,rhow=1025.,cw=4190.
+   REAL , PARAMETER :: g=9.8,znuw=1.e-6,zkw=1.4e-7,sdate=1201.6667
+!     parameter(g=9.8,delt=900.,znuw=1.e-6,zkw=1.4e-7)
+!
+!     Input arguments
+!     (all fluxes are positive downwards)
+!     real qo      ! LH + SH + LW (W/m^2), + down
+!     real swo      ! Net shortwave flux (W/m^2), + down
+!     real u       ! Wind speed (m/s)
+!     real us      ! Atmospheric friction velocity (m/s)
+!     real tb      ! Bulk temperature (deg C)
+!     real dtwo    ! Warm layer temp. diff. from previous time (deg C)
+!     Local variables
+!     real lw
+!     real sw
+!     real q       ! LH + SH + LW
+!     real qn      ! Q + R_s - R(-d)
+!     real zeta    ! -z / L
+!     real dep     ! Skin layer depth (m)
+!     real dtw3
+!     Output variables
+!     real dtw     ! Warm layer temp. diff. (deg C)
+!     real dtc     ! Cool skin temp. diff. (deg C)
+!     real ts      ! Skin temperature (deg C)
+!      q=lh+sh+lwo
+!
+      skinmax=-9999.
+      skinmin=9999.
+      do i=its,ite
+      do j=jts,jte
+!
+      if(xland(i,j).ge.1.5) then
+      qo=glw(i,j)-emiss(i,j)*stbolt*(sstsk(i,j)**4)-2.5e6*qfx(i,j)-hfx(i,j)
+      swo=gsw(i,j)
+      us=MAX(ust(i,j), 0.01)
+      tb=tsk(i,j)-273.15
+      dtwo=dtw1(i,j)
+      delt=dt
+!
+      q=qo/(rhow*cw)
+      sw=swo/(rhow*cw)
+! TEMPORARY KLUDGE
+!     f1=1.-0.28*exp(-71.5*z1)-0.27*exp(-2.8*z1)-0.45*exp(-0.07*z1)
+      f1=1.                   -0.27*exp(-2.8*z1)-0.45*exp(-0.07*z1)
+! cool skin
+      dtc=0.0
+! tb in C
+      alw=1.e-5*max(tb,1.)
+      con4=16.*g*alw*znuw**3/zkw**2
+      usw=sqrt(rho/rhow)*us
+      con5=con4/usw**4
+! otherwise, iterations would be needed for the computation of fs
+! iteration impact is less than 0.03C
+      q2=max(1./(rhow*cw),-q)
+      zlan=6./(1.+(con5*q2)**0.75)**0.333
+      dep=zlan*znuw/usw                    ! skin layer depth (m)
+      fs=0.065+11.*dep-(6.6e-5/dep)*(1.-exp(-dep/8.e-4))
+      fs=max(fs,0.01)          ! fract. of solar rad. absorbed in sublayer
+      dtc=dep*(q+sw*fs)/zkw            ! cool skin temp. diff (deg C)
+      dtc=min(dtc,0.)
+! warm layer (X. Zeng)
+      dtw=0.0
+! tb in C
+      alw=1.e-5*max(tb,1.)
+      con1=sqrt(5.*z1*g*alw/an)
+      con2=zk*g*alw
+      qn=q+sw*f1
+      usw=sqrt(rho/rhow)*us
+!  does not change when qn is positive
+      if(dtwo.gt.0..and.qn.lt.0.) then
+         qn1=sqrt(dtwo)*usw**2/con1
+         qn=max(qn,qn1)
+      endif
+      zeta=z1*con2*qn/usw**3
+      if(zeta.gt.0.) then
+         phi=1.+5.*zeta
+      else
+         phi=1./sqrt(1.-16.*zeta)
+      endif
+      con3=zk*usw/(z1*phi)
+! use all SW flux
+      dtw=(dtwo+(an+1.)/an*(q+sw*f1)*                             &
+                          delt/z1)/(1.+(an+1.)*con3*delt)
+      dtw=max(0.,dtw)
+      dtwo=dtw
+      ts = tb + dtw + dtc
+!
+      skinmax=amax1(skinmax,ts-tb)
+      skinmin=amin1(skinmin,ts-tb)
+      sstsk(i,j)=ts+273.15      ! convert ts (in C) to sstsk (in K)
+      dtw1(i,j)=dtw              ! dtw always in C
+      endif
+!
+      end do
+      end do
+!     print *, 'check skin sst skinmax = ', skinmax, '  skinmin = ', skinmin
+!
+      return
+
+   END SUBROUTINE sst_skin_update
+
+
+END MODULE module_sf_sstskin
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_temfsfclay.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_temfsfclay.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_temfsfclay.F	(revision 17)
@@ -0,0 +1,422 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+MODULE module_sf_temfsfclay
+
+CONTAINS
+
+!-------------------------------------------------------------------
+   SUBROUTINE temfsfclay(u3d,v3d,th3d,qv3d,p3d,pi3d,rho,z,ht,         &
+                     cp,g,rovcp,r,xlv,psfc,chs,chs2,cqs2,cpm,      &
+                     znt,ust,mavail,xland,                         &
+                     hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,            &
+                     u10,v10,th2,t2,q2,                            &
+                     svp1,svp2,svp3,svpt0,ep1,ep2,                 &
+                     karman,fCor,te_temf,                          &
+                     hd_temf,exch_temf,wm_temf,                           &
+                     ids,ide, jds,jde, kds,kde,                    &
+                     ims,ime, jms,jme, kms,kme,                    &
+                     its,ite, jts,jte, kts,kte                    &
+                     )
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+!
+! This is the Total Energy - Mass Flux (TEMF) surface layer scheme.
+! Initial implementation 2010 by Wayne Angevine, CIRES/NOAA ESRL.
+! References:
+!    Angevine et al., 2010, MWR
+!    Angevine, 2005, JAM
+!    Mauritsen et al., 2007, JAS
+!
+!-------------------------------------------------------------------
+!-------------------------------------------------------------------
+!-- u3d         3D u-velocity interpolated to theta points (m/s)
+!-- v3d         3D v-velocity interpolated to theta points (m/s)
+!-- th3d        potential 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)
+!-- 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)
+!-- chs         heat/moisture exchange coefficient for LSM (m/s)
+!-- chs2
+!-- cqs2
+!-- cpm
+!-- znt         roughness length (m)
+!-- ust         u* in similarity theory (m/s)
+!-- mavail      surface moisture availability (between 0 and 1)
+!-- 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)
+!-- qgh         lowest-level saturated mixing ratio
+!-- qsfc        ground saturated mixing ratio
+!-- 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)
+!-- 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
+!-- fCor        Coriolis parameter
+!-- 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,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
+                INTENT(IN   ) :: u3d, v3d, th3d, qv3d, p3d, pi3d, rho, z
+      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+                INTENT(IN   ) :: mavail, xland, tsk, fCor, ht, psfc, znt
+      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+                INTENT(INOUT) :: hfx, qfx, lh, flhc, flqc
+      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+                INTENT(INOUT) :: ust, chs2, cqs2, chs, cpm, qgh, qsfc
+      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+                INTENT(OUT  ) :: u10, v10, th2, t2, q2
+      REAL,     DIMENSION( ims:ime, jms:jme )           , &
+                INTENT(IN   ) :: hd_temf
+      REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
+                INTENT(INOUT) :: te_temf
+      REAL,     DIMENSION( ims:ime, jms:jme )           , &
+                INTENT(  OUT) :: exch_temf
+      REAL,     DIMENSION( ims:ime, jms:jme )           , &
+                INTENT(INOUT) :: wm_temf
+
+                                        
+      REAL,     INTENT(IN   ) :: cp,g,rovcp,r,xlv
+      REAL,     INTENT(IN   ) :: svp1,svp2,svp3,svpt0
+      REAL,     INTENT(IN   ) :: ep1,ep2,karman
+!
+! LOCAL VARS
+
+      INTEGER ::  J
+!
+
+      DO J=jts,jte
+
+        CALL temfsfclay1d(j,u1d=u3d(ims,kms,j),v1d=v3d(ims,kms,j),     &
+                th1d=th3d(ims,kms,j),qv1d=qv3d(ims,kms,j),p1d=p3d(ims,kms,j), &
+                pi1d=pi3d(ims,kms,j),rho=rho(ims,kms,j),z=z(ims,kms,j),&
+                zsrf=ht(ims,j),      &
+                cp=cp,g=g,rovcp=rovcp,r=r,xlv=xlv,psfc=psfc(ims,j),    &
+                chs=chs(ims,j),chs2=chs2(ims,j),cqs2=cqs2(ims,j),      &
+                cpm=cpm(ims,j),znt=znt(ims,j),ust=ust(ims,j),          &
+                mavail=mavail(ims,j),xland=xland(ims,j),    &
+                hfx=hfx(ims,j),qfx=qfx(ims,j),lh=lh(ims,j),tsk=tsk(ims,j), &
+                flhc=flhc(ims,j),flqc=flqc(ims,j),qgh=qgh(ims,j),      &
+                qsfc=qsfc(ims,j),u10=u10(ims,j),v10=v10(ims,j),        &
+                th2=th2(ims,j),t2=t2(ims,j),q2=q2(ims,j),        &
+                svp1=svp1,svp2=svp2,svp3=svp3,svpt0=svpt0,             &
+                ep1=ep1,ep2=ep2,karman=karman,fCor=fCor(ims,j),  &
+                te_temfx=te_temf(ims,kms,j),hd_temfx=hd_temf(ims,j), &
+                exch_temfx=exch_temf(ims,j),wm_temfx=wm_temf(ims,j), &
+                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      &
+                                                                   )
+      ENDDO
+
+   END SUBROUTINE temfsfclay
+
+
+!-------------------------------------------------------------------
+   SUBROUTINE temfsfclay1d(j,u1d,v1d,th1d,qv1d,p1d, &
+                pi1d,rho,z,zsrf,cp,g,rovcp,r,xlv,psfc,    &
+                chs,chs2,cqs2,cpm,znt,ust,          &
+                mavail,xland,hfx,qfx,lh,tsk, &
+                flhc,flqc,qgh,qsfc,u10,v10,        &
+                th2,t2,q2,svp1,svp2,svp3,svpt0,             &
+                ep1,ep2,karman,fCor,  &
+                te_temfx,hd_temfx,exch_temfx,wm_temfx,       &
+                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, &
+                                        j
+                                                               
+      REAL,     DIMENSION( ims:ime ), INTENT(IN   ) ::             &
+                                        u1d,v1d,qv1d,p1d,th1d,pi1d,rho,z,zsrf
+      REAL,     INTENT(IN   ) ::        cp,g,rovcp,r,xlv
+      REAL,     DIMENSION( ims:ime ), INTENT(IN   ) :: psfc,znt
+      REAL,     DIMENSION( ims:ime ), INTENT(INOUT) ::             &
+                                        chs,chs2,cqs2,cpm,ust
+      REAL,     DIMENSION( ims:ime ), INTENT(IN   ) :: mavail,xland 
+      REAL,     DIMENSION( ims:ime ), INTENT(INOUT) ::             &
+                                        hfx,qfx,lh
+      REAL,     DIMENSION( ims:ime ), INTENT(IN   ) :: tsk
+      REAL,     DIMENSION( ims:ime ), INTENT(  OUT) ::             &
+                                        flhc,flqc
+      REAL,     DIMENSION( ims:ime ), INTENT(INOUT) ::             &
+                                        qgh,qsfc
+      REAL,     DIMENSION( ims:ime ), INTENT(  OUT) ::             &
+                                        u10,v10,th2,t2,q2
+      REAL,     INTENT(IN   ) ::        svp1,svp2,svp3,svpt0
+      REAL,     INTENT(IN   ) ::        ep1,ep2,karman
+      REAL,     DIMENSION( ims:ime ), INTENT(IN   ) :: fCor,hd_temfx
+      REAL,     DIMENSION( ims:ime ), INTENT(INOUT) :: te_temfx
+      REAL,     DIMENSION( ims:ime ), INTENT(  OUT) :: exch_temfx, wm_temfx
+!
+!! LOCAL VARS
+! TE model constants
+   real, parameter :: visc_temf = 1.57e-5
+   real, parameter :: conduc_temf = 1.57e-5 / 0.733
+   logical, parameter :: MFopt = .true.  ! Use mass flux or not
+   real, parameter :: TEmin = 1e-3
+   real, parameter :: ftau0 = 0.17
+   real, parameter :: fth0 = 0.145
+!   real, parameter :: fth0 = 0.12    ! WA 10/13/10 to make PrT0 ~= 1
+   real, parameter :: Cf = 0.185
+   real, parameter :: CN = 2.0
+!   real, parameter :: Ceps = ftau0**1.5
+   real, parameter :: Ceps = 0.070
+   real, parameter :: Cgamma = Ceps
+   real, parameter :: Cphi = Ceps
+!   real, parameter :: PrT0 = Cphi/Ceps * ftau0**2. / 2 / fth0**2.
+   real, parameter :: PrT0 = Cphi/Ceps * ftau0**2 / 2. / fth0**2
+!
+   integer :: i
+   real :: e1
+   real, dimension( its:ite)    ::  wstr, ang, wm
+   real, dimension( its:ite)    ::  z0t
+   real, dimension( its:ite) :: dthdz, dqtdz, dudz, dvdz
+   real, dimension( its:ite) :: lepsmin
+   real, dimension( its:ite) :: thetav
+   real, dimension( its:ite) :: zt,zm
+   real, dimension( its:ite) :: N2, S, Ri, beta, ftau, fth, ratio
+   real, dimension( its:ite) :: TKE, TE2
+   real, dimension( its:ite) :: ustrtilde, linv, leps
+   real, dimension( its:ite) :: km, kh
+   real, dimension( its:ite) :: qsfc_air
+!!-------------------------------------------------------------------
+
+!!!!!!! ******
+! WA Known outages:  None
+
+   do i = its,ite      ! Main loop 
+
+      ! Calculate surface saturated q and q in air at surface
+      e1=svp1*exp(svp2*(tsk(i)-svpt0)/(tsk(i)-svp3))                       
+      qsfc(i)=ep2*e1/((psfc(i)/1000.)-e1)
+      qsfc_air(i) = qsfc(i) * mavail(i)
+      thetav(i) = (tsk(i)/pi1d(i)) * (1. + 0.608*qsfc_air(i))  ! WA Assumes ql(env)=0, what if it isn't?
+      ! WA TEST (R5) set z0t = z0
+      ! z0t(i) = znt(i) / 10.0   ! WA this is hard coded in Matlab version
+      z0t(i) = znt(i)
+
+      ! Get height and delta at turbulence levels and mass levels
+      zt(i) = (z(i) - zsrf(i) - znt(i)) / 2.
+      zm(i) = z(i) - zsrf(i)
+
+      ! Gradients at first level
+      dthdz(i) = (th1d(i)-(tsk(i)/pi1d(i))) / (zt(i) * log10(zm(i)/z0t(i)))
+      dqtdz(i) = (qv1d(i)-qsfc_air(i)) / (zt(i) * log10(zm(i)/z0t(i)))
+      dudz(i) = u1d(i) / (zt(i) * log10(zm(i)/znt(i)))
+      dvdz(i) = v1d(i) / (zt(i) * log10(zm(i)/znt(i)))
+
+      ! WA doing this because te_temf may not be initialized,
+      ! would be better to do it in initialization routine but it's 
+      ! not available in module_physics_init.
+      if (te_temfx(i) < TEmin) te_temfx(i) = TEmin
+
+      if ( hfx(i) > 0.) then
+         wstr(i) = (g * hd_temfx(i) / thetav(i) * (hfx(i)/(rho(i)*cp))) ** (1./3.)
+      else
+         wstr(i) = 0.
+      end if
+
+      ! Find stability parameters and length scale
+      ! WA Calculation of N should really use d(thetaV)/dz not dthdz
+      ! WA 7/1/09 allow N to be negative
+      ! if ( dthdz(i) >= 0.) then
+      ! N(i) = csqrt(g / thetav(i) * dthdz(i))
+      ! else
+      !    N(i) = 0.
+      ! end if
+      N2(i) = g / thetav(i) * dthdz(i)
+      S(i) = sqrt(dudz(i)**2. + dvdz(i)**2.)
+      ! Ri(i) = N(i)**2. / S(i)**2.
+      Ri(i) = N2(i) / S(i)**2.
+      ! if (S(i) < 1e-15) Ri(i) = 1./1e-15
+      if (S(i) < 1e-15) then
+         print *,'In TEMF SFC Limiting Ri,S,N2,Ri,u,v = ',S(i),N2(i),Ri(i),u1d(i),v1d(i)
+         if (N2(i) >= 0) then
+            Ri(i) = 0.2
+         else
+            Ri(i) = -1.
+         end if
+      end if
+      if (Ri(i) > 0.2) then  ! WA TEST to prevent runaway
+         Ri(i) = 0.2
+      end if
+      beta(i) = g / thetav(i)
+      ! WA 7/1/09 adjust ratio, ftau, fth for Ri>0
+      if (Ri(i) > 0) then
+         ratio(i) = Ri(i)/(Cphi**2.*ftau0**2./(2.*Ceps**2.*fth0**2.)+3.*Ri(i))
+         ftau(i) = ftau0 * ((3./4.) / (1.+4.*Ri(i)) + 1./4.)
+         fth(i) = fth0 / (1.+4.*Ri(i))
+         ! TE2(i) = 2. * te_temfx(i) * ratio(i) * N(i)**2. / beta(i)**2.
+         TE2(i) = 2. * te_temfx(i) * ratio(i) * N2(i) / beta(i)**2.
+      else
+         ratio(i) = Ri(i)/(Cphi**2.*ftau0**2./(-2.*Ceps**2.*fth0**2.)+2.*Ri(i))
+         ftau(i) = ftau0
+         fth(i) = fth0
+         TE2(i) = 0.
+      end if
+      TKE(i) = te_temfx(i) * (1. - ratio(i))
+      ustrtilde(i) = sqrt(ftau(i) * TKE(i))
+      ! linv(i) = 1./karman / zt(i) + abs(fCor(i)) / (Cf*ustrtilde(i)) + N(i)/(CN*ustrtilde(i))
+      if (N2(i) > 0.) then
+         linv(i) = 1./karman / zt(i) + abs(fCor(i)) / (Cf*ustrtilde(i)) + sqrt(N2(i))/(CN*ustrtilde(i))
+      else
+         linv(i) = 1./karman / zt(i) + abs(fCor(i)) / (Cf*ustrtilde(i))
+      end if
+      leps(i) = 1./linv(i)
+      ! WA TEST (R4) remove lower limit on leps
+      ! lepsmin(i) = min(0.4*zt(i), 5.)
+      lepsmin(i) = 0.
+      leps(i) = max(leps(i),lepsmin(i))
+
+
+      ! Find diffusion coefficients
+      ! First use basic formulae for stable and neutral cases,
+      ! then for convective conditions, and finally choose the larger
+      km(i) = TKE(i)**1.5 * ftau(i)**2. / (-beta(i) * fth(i) * sqrt(TE2(i)) + Ceps * sqrt(TKE(i)*te_temfx(i)) / leps(i))
+      kh(i) = 2. * leps(i) * fth(i)**2. * TKE(i) / sqrt(te_temfx(i)) / Cphi
+      km(i) = max(km(i),visc_temf)
+      kh(i) = max(kh(i),conduc_temf)
+
+      ! Surface fluxes
+      ust(i) = sqrt(ftau(i)/ftau0) * sqrt(u1d(i)**2. + v1d(i)**2.) * leps(i) / log(zm(i)/znt(i)) / zt(i)
+      ang(i) = atan2(v1d(i),u1d(i))
+
+      ! Calculate mixed scaling velocity (Moeng & Sullivan 1994 JAS p.1021)
+      ! Replaces ust everywhere (WA need to reconsider?)
+      ! WA wm is too large, makes surface flux too big and cools sfc too much
+      ! wm(i) = (1./5. * (wstr(i)**3. + 5. * ust(i)**3.)) ** (1./3.) 
+      ! WA TEST (R2,R11) 7/23/10 reduce velocity scale to fix excessive fluxes
+      wm(i) = 0.5 * (1./5. * (wstr(i)**3. + 5. * ust(i)**3.)) ** (1./3.) 
+      ! WA TEST 2/14/11 limit contribution of w*
+      ! wm(i) = 0.5 * (1./5. * (min(0.8,wstr(i))**3. + 5. * ust(i)**3.)) ** (1./3.) 
+      ! WA TEST 2/22/11 average with previous value to reduce instability
+      wm(i) = (wm(i) + wm_temfx(i)) / 2.0
+      wm_temfx(i) = wm(i)
+      ! WA TEST (R3-R10) 7/23/10 wm = u*
+      ! wm(i) = ust(i)
+
+      ! Populate surface exchange coefficient variables to go back out
+      ! for next time step of surface scheme
+      ! Unit specifications in SLAB and sfclay are conflicting and probably
+      ! incorrect.  This will give a dynamic heat flux (W/m^2) or moisture
+      ! flux (kg(water)/(m^2*s)) when multiplied by a difference.
+      ! These formulae are the same as what's used above to get surface
+      ! flux from surface temperature and specific humidity.
+      flhc(i) = rho(i) * cp * fth(i)/fth0 * wm(i) * leps(i) / PrT0 / log(zm(i)/z0t(i)) / zt(i)
+      flqc(i)  = rho(i) * fth(i)/fth0 * wm(i) * leps(i) / PrT0 / log(zm(i)/z0t(i)) / zt(i) * mavail(i)
+      exch_temfx(i)  = flqc(i) / mavail(i)
+      chs(i) = flqc(i) / rho(i) / mavail(i) 
+      ! WA Must exchange coeffs be limited to avoid runaway in some 
+      ! (convective?) conditions?  Something like this is done in sfclay.
+      ! Doing nothing for now.
+
+      ! Populate surface heat and moisture fluxes
+      hfx(i) = flhc(i) * (tsk(i) - th1d(i)*pi1d(i))
+      ! qfx(i) = flqc(i) * (qsfc_air(i) - qv1d(i))  ! WA 2/16/11
+      qfx(i) = flqc(i) * (qsfc(i) - qv1d(i))
+      qfx(i) = max(qfx(i),0.)  ! WA this is done in sfclay, is it right?
+      lh(i)=xlv*qfx(i)
+
+
+      ! Populate 10 m winds and 2 m temp and 2 m exchange coeffs
+      ! WA Note this only works if first mass level is above 10 m
+      u10(i) = u1d(i) * log(10.0/znt(i)) / log(zm(i)/znt(i))
+      v10(i) = v1d(i) * log(10.0/znt(i)) / log(zm(i)/znt(i))
+      t2(i) = (tsk(i)/pi1d(i) + (th1d(i) - tsk(i)/pi1d(i)) * log(2.0/z0t(i)) / log(zm(i)/z0t(i))) * pi1d(i)  ! WA this should also use pi at z0
+      th2(i) = t2(i) / pi1d(i)
+      q2(i) = (qsfc_air(i) + (qv1d(i) - qsfc_air(i)) * log(2.0/znt(i)) / log(zm(i)/znt(i)))
+      ! WA are these correct?  Difference between chs2 and cqs2 is unclear
+      ! At the moment the only difference is z0t vs. znt
+      chs2(i)  = fth(i)/fth0 * wm(i) * leps(i) / PrT0 / log(2.0/z0t(i)) / zt(i)
+      cqs2(i)  = fth(i)/fth0 * wm(i) * leps(i) / PrT0 / log(2.0/znt(i)) / zt(i)
+
+      ! Calculate qgh (saturated at first-level temp) and cpm
+      e1=svp1*exp(svp2*((th1d(i)*pi1d(i))-svpt0)/((th1d(i)*pi1d(i))-svp3))
+      qgh(i)=ep2*e1/((p1d(i)/1000.)-e1)
+      cpm(i)=cp*(1.+0.8*qv1d(i))                                   
+
+   end do  ! Main loop
+
+   END SUBROUTINE temfsfclay1d
+
+!====================================================================
+   SUBROUTINE temfsfclayinit( restart, allowed_to_read,                &
+                              wm_temf,                                 &
+                              ids, ide, jds, jde, kds, kde,            &
+                              ims, ime, jms, jme, kms, kme,            &
+                              its, ite, jts, jte, kts, kte                 )
+
+   logical , intent(in)          :: restart, allowed_to_read
+   REAL,     DIMENSION( ims:ime, jms:jme )           , &
+                INTENT(  OUT) :: wm_temf
+   integer , intent(in)          ::  ids, ide, jds, jde, kds, kde,             &
+                                     ims, ime, jms, jme, kms, kme,             &
+                                     its, ite, jts, jte, kts, kte
+   
+! Local variables
+   integer :: i, j, itf, jtf
+!
+   CALL wrf_debug( 100, 'in temfsfclayinit' )
+   jtf = min0(jte,jde-1)
+   itf = min0(ite,ide-1)
+!
+   if(.not.restart)then
+     do j = jts,jtf
+     do i = its,itf
+     ! do j = jms,jme
+     ! do i = ims,ime
+        wm_temf(i,j) = 0.0
+     enddo
+     enddo
+   endif
+
+   END SUBROUTINE temfsfclayinit
+
+!-------------------------------------------------------------------          
+
+END MODULE module_sf_temfsfclay
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_tmnupdate.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_tmnupdate.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_tmnupdate.F	(revision 17)
@@ -0,0 +1,124 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+MODULE module_sf_tmnupdate
+
+
+CONTAINS
+
+   SUBROUTINE tmnupdate(tsk,tmn,tlag,tyr,tyra,tdly,nday,nyear,lagday, &
+                julian_in, dt, yr,                                  &
+                ids, ide, jds, jde, kds, kde,                       &
+                ims, ime, jms, jme, kms, kme,                       &
+                i_start,i_end, j_start,j_end, kts,kte, num_tiles   )
+
+
+   IMPLICIT NONE
+
+!---------------------------------------------------------------------
+   INTEGER , INTENT(IN)           :: ids, ide, jds, jde, kds, kde,   &
+                                     ims, ime, jms, jme, kms, kme,   &
+                                     kts, kte, num_tiles, lagday
+
+   INTEGER, DIMENSION(num_tiles), INTENT(IN) ::                       &
+     &           i_start,i_end,j_start,j_end
+
+   INTEGER, INTENT(INOUT ) ::   NYEAR
+   REAL   , INTENT(INOUT ) ::   NDAY
+   INTEGER, INTENT(IN ) ::   YR
+
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)::   TSK
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   TMN
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ) ::   TYR
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ) ::   TYRA
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ) ::   TDLY
+   REAL, DIMENSION( ims:ime , 1:lagday , jms:jme ), INTENT(INOUT ) ::   TLAG
+   REAL,                                INTENT(IN)  :: julian_in, dt
+
+!... Local Variables
+
+!... Integer
+      INTEGER :: ij, i, j, n
+!... Real
+      REAL, PARAMETER      :: tconst = 0.6
+      REAL  :: julian, yrday, tprior, deltat
+
+#ifdef NO_LEAP_CALENDAR
+! no leap year when coupled with CCSM
+      yrday=365.      ! number of days in a non-leap year
+#else
+      yrday=365.      ! number of days in a non-leap year
+      if(mod(yr,4).eq.0) yrday=366.
+#endif
+
+! accumulate tsk of current day
+    !$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)
+             tdly(i,j)=tdly(i,j)+tsk(i,j)*dt
+      ENDDO
+      ENDDO
+     ENDDO
+    nday=nday+1.*dt
+
+
+! Update deep soil temperature
+! if it is the end of a day, update variables
+    !! deltat=(julian_in-int(julian_in))*24.*3600.
+    !! IF(nint(deltat).lt.dt) THEN
+    deltat=(julian_in-nint(julian_in))*24.*3600.
+    IF(abs(deltat).le.dt/2.) THEN
+      julian=(julian_in-1.)+(dt/(60.*60.*24.))
+      !$OMP PARALLEL DO   &
+      !$OMP PRIVATE ( ij, i, j, n )
+      DO ij = 1 , num_tiles
+        DO j=j_start(ij),j_end(ij)
+        DO i=i_start(ij),i_end(ij)
+! update tmn
+               tprior=0.0
+               do n=1,lagday
+                 tprior=tprior+tlag(i,n,j)
+               end do
+               tprior=tprior/lagday
+               tmn(i,j)=tconst*tyr(i,j)+(1.-tconst)*tprior
+! update tlag and tyra
+               do n=1,lagday-1
+                 tlag(i,n,j)=tlag(i,n+1,j)
+               end do
+               tlag(i,lagday,j)=tdly(i,j)/nday
+               tdly(i,j)=0.0
+        ENDDO
+        ENDDO
+      ENDDO
+      nday=0.
+! update tyr if it is the end of a year
+      if((yrday-julian).le.1.) then
+        DO ij = 1 , num_tiles
+          DO j=j_start(ij),j_end(ij)
+          DO i=i_start(ij),i_end(ij)
+                tyr(i,j)=tyra(i,j)/nyear
+                tyra(i,j)=0.0
+          ENDDO
+          ENDDO
+        ENDDO
+        nyear=0
+      else
+        DO ij = 1 , num_tiles
+          DO j=j_start(ij),j_end(ij)
+          DO i=i_start(ij),i_end(ij)
+                tyra(i,j)=tyra(i,j)+tlag(i,lagday,j)
+          ENDDO
+          ENDDO
+        ENDDO
+        nyear=nyear+1
+      endif
+    ENDIF
+
+!
+      return
+
+   END SUBROUTINE tmnupdate
+
+
+END MODULE module_sf_tmnupdate
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_urban.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_urban.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_sf_urban.F	(revision 17)
@@ -0,0 +1,2421 @@
+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(:) :: AH_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: BETR_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: BETB_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: BETG_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: FRC_URB_TBL
+
+   REAL, ALLOCATABLE, DIMENSION(:) :: COP_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: PWIN_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: BETA_TBL
+   INTEGER, ALLOCATABLE, DIMENSION(:) :: SW_COND_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: TIME_ON_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: TIME_OFF_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: TARGTEMP_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: GAPTEMP_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: TARGHUM_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: GAPHUM_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: PERFLO_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: HSESF_TBL
+
+   REAL, ALLOCATABLE, DIMENSION(:) :: CAPR_TBL, CAPB_TBL, CAPG_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: AKSR_TBL, AKSB_TBL, AKSG_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: ALBR_TBL, ALBB_TBL, ALBG_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: EPSR_TBL, EPSB_TBL, EPSG_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: Z0R_TBL,  Z0B_TBL,  Z0G_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: SIGMA_ZED_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: Z0HB_TBL, Z0HG_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: TRLEND_TBL, TBLEND_TBL, TGLEND_TBL
+   REAL, ALLOCATABLE, DIMENSION(:) :: AKANDA_URBAN_TBL
+!for BEP
+
+   ! MAXDIRS :: The maximum number of street directions we're allowed to define
+   INTEGER, PARAMETER :: MAXDIRS = 3
+   ! MAXHGTS :: The maximum number of building height bins we're allowed to define
+   INTEGER, PARAMETER :: MAXHGTS = 50
+
+   INTEGER, ALLOCATABLE, DIMENSION(:)   :: NUMDIR_TBL
+   REAL,    ALLOCATABLE, DIMENSION(:,:) :: STREET_DIRECTION_TBL
+   REAL,    ALLOCATABLE, DIMENSION(:,:) :: STREET_WIDTH_TBL
+   REAL,    ALLOCATABLE, DIMENSION(:,:) :: BUILDING_WIDTH_TBL
+   INTEGER, ALLOCATABLE, DIMENSION(:)   :: NUMHGT_TBL
+   REAL,    ALLOCATABLE, DIMENSION(:,:) :: HEIGHT_BIN_TBL
+   REAL,    ALLOCATABLE, DIMENSION(:,:) :: HPERCENT_BIN_TBL
+!end BEP
+   INTEGER                         :: BOUNDR_DATA,BOUNDB_DATA,BOUNDG_DATA
+   INTEGER                         :: CH_SCHEME_DATA, TS_SCHEME_DATA
+   INTEGER                         :: ahoption        ! Miao, 2007/01/17, cal. ah
+   REAL, DIMENSION(1:24)           :: ahdiuprf        ! ah diurnal profile, tloc: 1-24
+   REAL, DIMENSION(1:24)           :: hsequip_tbl
+
+   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 <-- URBPARM.TBL
+!       |- urban_var_init
+!
+! Input Data from WRF [MKS unit]:
+!
+!     UTYPE  [-]     : Urban type. 1=Commercial/Industrial; 2=High-intensity residential; 
+!                    : 3=low-intensity residential 
+!     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:
+!
+! Morphology of the urban canyon:
+! These parameters assigned in the URBPARM.TBL
+!
+!    ZR  [m]             : roof level (building height)
+!    SIGMA_ZED [m]       : Standard Deviation of roof height
+!    ROOF_WIDTH [m]      : roof (i.e., building) width
+!    ROAD_WIDTH [m]      : road width
+!
+! Parameters derived from the morphological terms above.
+! These parameters are computed in the code.
+!
+!    HGT [-]             : normalized building height
+!    SVF [-]             : sky view factor
+!    R   [-]             : Normalized roof width (a.k.a. "building coverage ratio")
+!    RW  [-]             : = 1 - R
+!    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)
+!
+! Following parameter are assigned in run/URBPARM.TBL
+!
+!  AH  [ W m{-2} ]        : anthropogenic heat  ( W m{-2} in the table, converted internally to cal cm{-2} )
+!  CAPR[ J m{-3} K{-1} ]  : heat capacity of roof ( units converted in code to [ cal cm{-3} deg{-1} ] )
+!  CAPB[ J m{-3} K{-1} ]  : heat capacity of building wall ( units converted in code to [ cal cm{-3} deg{-1} ] )
+!  CAPG[ J m{-3} K{-1} ]  : heat capacity of road ( units converted in code to [ cal cm{-3} deg{-1} ] )
+!  AKSR [ J m{-1} s{-1} K{-1} ] : thermal conductivity of roof ( units converted in code to [ cal cm{-1} s{-1} deg{-1} ] )
+!  AKSB [ J m{-1} s{-1} K{-1} ] : thermal conductivity of building wall ( units converted in code to [ cal cm{-1} s{-1} deg{-1} ] )
+!  AKSG [ J m{-1} s{-1} K{-1} ] : thermal conductivity of road ( units converted in code to [ cal cm{-1} s{-1} deg{-1} ] )
+!  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
+!  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)
+!  Z0HB [m]               : roughness length for heat of building wall (only for CH_SCHEME = 1)
+!  Z0HG [m]               : roughness length for heat of road
+!  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 ground 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]
+!
+!for BEP
+!  numdir [ - ]             : Number of street directions defined for a particular urban category
+!  street_direction [ deg ] : Direction of streets for a particular urban category and a particular street direction
+!  street_width [ m ]       : Width of street for a particular urban category and a particular street direction
+!  building_width [ m ]     : Width of buildings for a particular urban category and a particular street direction
+!  numhgt [ - ]             : Number of building height levels defined for a particular urban category
+!  height_bin [ m ]         : Building height bins defined for a particular urban category.
+!  hpercent_bin [ % ]       : Percentage of a particular urban category populated by buildings of particular height bins
+!end BEP
+! Moved from URBPARM.TBL
+!
+!  BETR [-]            : minimum moisture availability of roof
+!  BETB [-]            : minimum moisture availability of building wall
+!  BETG [-]            : minimum moisture availability of road
+!  Z0R [m]                : roughness length for momentum of roof
+!  Z0HB [m]               : roughness length for heat of building wall (only for CH_SCHEME = 1)
+!  Z0HG [m]               : roughness length for heat of road
+!  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
+!
+! 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
+                    CMR_URB,CHR_URB,CMC_URB,CHC_URB,                  & ! I/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 [1=Commercial/Industrial, 2=High-intensity residential, 
+                                ! 3=low-intensity residential]
+
+   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]
+   REAL, INTENT(INOUT) :: CMR_URB
+   REAL, INTENT(INOUT) :: CHR_URB
+   REAL, INTENT(INOUT) :: CMC_URB
+   REAL, INTENT(INOUT) :: CHC_URB
+
+!-------------------------------------------------------------------------------
+! 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, AH
+   REAL :: SIGMA_ZED
+   REAL :: CAPR, CAPB, CAPG, AKSR, AKSB, AKSG, ALBR, ALBB, ALBG 
+   REAL :: EPSR, EPSB, EPSG, Z0R,  Z0B,  Z0G,  Z0HB, Z0HG
+   REAL :: TRLEND,TBLEND,TGLEND
+   REAL :: T1VR, T1VC,TH2V
+   REAL :: RLMO_URB
+   REAL :: AKANDA_URBAN
+   
+   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]
+
+!for BEP
+   INTEGER                        :: NUMDIR
+   REAL,    DIMENSION ( MAXDIRS ) :: STREET_DIRECTION
+   REAL,    DIMENSION ( MAXDIRS ) :: STREET_WIDTH
+   REAL,    DIMENSION ( MAXDIRS ) :: BUILDING_WIDTH
+   INTEGER                        :: NUMHGT
+   REAL,    DIMENSION ( MAXHGTS ) :: HEIGHT_BIN
+   REAL,    DIMENSION ( MAXHGTS ) :: HPERCENT_BIN
+!end BEP
+!-------------------------------------------------------------------------------
+! L: Local variables
+!-------------------------------------------------------------------------------
+
+   REAL :: BETR, BETB, BETG
+   REAL :: SX, SD, SQ, RX
+   REAL :: UR, ZC, XLB, BB
+   REAL :: Z, 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 
+   INTEGER :: tloc
+
+!-------------------------------------------------------------------------------
+! Set parameters
+!-------------------------------------------------------------------------------
+
+! Miao, 2007/01/17, cal. ah
+   if(ahoption==1) then
+     tloc=mod(int(OMG/PI*180./15.+12.+0.5 ),24)
+     if(tloc==0) tloc=24
+   endif
+
+   CALL read_param(UTYPE,ZR,SIGMA_ZED,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,  &
+                   AH,CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB,    &
+                   ALBG,EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HB,Z0HG,     &
+                   BETR,BETB,BETG,TRLEND,TBLEND,TGLEND,           &
+!for BEP
+                   NUMDIR, STREET_DIRECTION, STREET_WIDTH,        & 
+                   BUILDING_WIDTH, NUMHGT, HEIGHT_BIN,            & 
+                   HPERCENT_BIN,                                  & 
+!end BEP
+                   BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME,      &
+                   AKANDA_URBAN)
+
+! Miao, 2007/01/17, cal. ah
+   if(ahoption==1) AH=AH*ahdiuprf(tloc)
+
+   IF( ZDC+Z0C+2. >= ZA) THEN
+    CALL wrf_error_fatal ("ZDC + Z0C + 2m is larger than the 1st WRF level "// &
+                           "Stop in subroutine urban - change ZDC and Z0C" ) 
+   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 diffuse 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
+     XLB=0.4*(ZR-ZDC)
+     ! BB formulation from Inoue (1963)
+     BB = 0.4 * ZR / ( XLB * alog( ( ZR - ZDC ) / Z0C ) )
+     UC=UR*EXP(-BB*(1.-ZC/ZR))
+   ELSE
+     ! 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.
+
+       SR1=SD*(1.-ALBR)+SQ*(1.-ALBR)
+       SG1=SD*(RW-SLX)/RW*(1.-ALBG)+SQ*VFGS*(1.-ALBG)
+       SB1=SD*SLX/W*(1.-ALBB)+SQ*VFWS*(1.-ALBB)
+       SG2=SB1*ALBB/(1.-ALBB)*VFGW*(1.-ALBG)
+       SB2=SG1*ALBG/(1.-ALBG)*VFWG*(1.-ALBB)
+
+     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)
+
+   ! Alternative option for MOST using SFCDIF routine from Noah
+   ! Virtual temperatures needed by SFCDIF
+   T1VR = TRP* (1.0+ 0.61 * QA) 
+   TH2V = (TA + ( 0.0098 * ZA)) * (1.0+ 0.61 * QA)
+  
+   ! note that CHR_URB contains UA (=CHR_MOS*UA)
+   RLMO_URB=0.0
+   CALL SFCDIF_URB (ZA,Z0R,T1VR,TH2V,UA,AKANDA_URBAN,CMR_URB,CHR_URB,RLMO_URB,CDR)
+   ALPHAR =  RHO*CP*CHR_URB
+   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)
+   ! Virtual temperatures needed by SFCDIF routine from Noah
+
+   T1VC = TCP* (1.0+ 0.61 * QA) 
+   RLMO_URB=0.0
+   CALL SFCDIF_URB(ZA,Z0C,T1VC,TH2V,UA,AKANDA_URBAN,CMC_URB,CHC_URB,RLMO_URB,CDC)
+   ALPHAC =  RHO*CP*CHC_URB
+
+   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 Fluxes from Urban Canopy
+!-------------------------------------------------------------------------------
+
+   FLXUV  = ( R*CDR + RW*CDC )*UA*UA
+! Miao, 2007/01/17, cal. ah
+   if(ahoption==1) then
+     FLXTH  = ( R*FLXTHR  + W*FLXTHB  + RW*FLXTHG ) + AH/RHOO/CPP
+   else
+     FLXTH  = ( R*FLXTHR  + W*FLXTHB  + RW*FLXTHG )
+   endif
+   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]
+
+   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
+
+   REAL, INTENT(IN)                   :: CAP
+
+   REAL, INTENT(IN)                   :: AKS
+
+   REAL, INTENT(IN)                   :: DELT      ! Time step [ s ]
+
+   REAL, INTENT(IN)                   :: TSLEND
+
+   INTEGER, INTENT(IN)                :: KM
+
+   INTEGER, INTENT(IN)                :: 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,SIGMA_ZED,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,AH,    & ! out
+                         CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB,ALBG, & ! out
+                         EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HB,Z0HG,         & ! out
+                         BETR,BETB,BETG,TRLEND,TBLEND,TGLEND,          & ! out
+!for BEP
+                         NUMDIR, STREET_DIRECTION, STREET_WIDTH,       & ! out
+                         BUILDING_WIDTH, NUMHGT, HEIGHT_BIN,           & ! out
+                         HPERCENT_BIN,                                 & ! out
+!end BEP
+                         BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME,     & ! out
+                         AKANDA_URBAN)                                   ! out
+
+   INTEGER, INTENT(IN)  :: UTYPE 
+
+   REAL, INTENT(OUT)    :: ZR,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,AH,              &
+                           CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB,ALBG, &
+                           SIGMA_ZED,                                    &
+                           EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HB,Z0HG,         &
+                           BETR,BETB,BETG,TRLEND,TBLEND,TGLEND
+   REAL, INTENT(OUT)    :: AKANDA_URBAN
+!for BEP
+   INTEGER,                     INTENT(OUT) :: NUMDIR
+   REAL,    DIMENSION(MAXDIRS), INTENT(OUT) :: STREET_DIRECTION
+   REAL,    DIMENSION(MAXDIRS), INTENT(OUT) :: STREET_WIDTH
+   REAL,    DIMENSION(MAXDIRS), INTENT(OUT) :: BUILDING_WIDTH
+   INTEGER,                     INTENT(OUT) :: NUMHGT
+   REAL,    DIMENSION(MAXHGTS), INTENT(OUT) :: HEIGHT_BIN
+   REAL,    DIMENSION(MAXHGTS), INTENT(OUT) :: HPERCENT_BIN
+   
+!end BEP
+
+   INTEGER, INTENT(OUT) :: BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME
+
+   ZR =     ZR_TBL(UTYPE)
+   SIGMA_ZED = SIGMA_ZED_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)
+   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_TBL(UTYPE)
+   CAPB=    CAPB_TBL(UTYPE)
+   CAPG=    CAPG_TBL(UTYPE)
+   AKSR=    AKSR_TBL(UTYPE)
+   AKSB=    AKSB_TBL(UTYPE)
+   AKSG=    AKSG_TBL(UTYPE)
+   ALBR=    ALBR_TBL(UTYPE)
+   ALBB=    ALBB_TBL(UTYPE)
+   ALBG=    ALBG_TBL(UTYPE)
+   EPSR=    EPSR_TBL(UTYPE)
+   EPSB=    EPSB_TBL(UTYPE)
+   EPSG=    EPSG_TBL(UTYPE)
+   Z0R=     Z0R_TBL(UTYPE)
+   Z0B=     Z0B_TBL(UTYPE)
+   Z0G=     Z0G_TBL(UTYPE)
+   Z0HB=    Z0HB_TBL(UTYPE)
+   Z0HG=    Z0HG_TBL(UTYPE)
+   TRLEND=  TRLEND_TBL(UTYPE)
+   TBLEND=  TBLEND_TBL(UTYPE)
+   TGLEND=  TGLEND_TBL(UTYPE)
+   BOUNDR=  BOUNDR_DATA
+   BOUNDB=  BOUNDB_DATA
+   BOUNDG=  BOUNDG_DATA
+   CH_SCHEME = CH_SCHEME_DATA
+   TS_SCHEME = TS_SCHEME_DATA
+   AKANDA_URBAN = AKANDA_URBAN_TBL(UTYPE)
+
+!for BEP
+
+   STREET_DIRECTION = -1.E36
+   STREET_WIDTH     = -1.E36
+   BUILDING_WIDTH   = -1.E36
+   HEIGHT_BIN       = -1.E36
+   HPERCENT_BIN     = -1.E36
+
+   NUMDIR                     = NUMDIR_TBL ( UTYPE )
+   STREET_DIRECTION(1:NUMDIR) = STREET_DIRECTION_TBL( 1:NUMDIR, UTYPE )
+   STREET_WIDTH    (1:NUMDIR) = STREET_WIDTH_TBL    ( 1:NUMDIR, UTYPE )
+   BUILDING_WIDTH  (1:NUMDIR) = BUILDING_WIDTH_TBL  ( 1:NUMDIR, UTYPE )
+   NUMHGT                     = NUMHGT_TBL ( UTYPE )
+   HEIGHT_BIN      (1:NUMHGT) = HEIGHT_BIN_TBL   ( 1:NUMHGT , UTYPE )
+   HPERCENT_BIN    (1:NUMHGT) = HPERCENT_BIN_TBL ( 1:NUMHGT , UTYPE )
+
+!end BEP
+   END SUBROUTINE read_param
+!===============================================================================
+!
+! subroutine urban_param_init: Read parameters from URBPARM.TBL
+!
+!===============================================================================
+   SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, &
+                               sf_urban_physics)
+!                              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,                            INTENT(IN)    :: SF_URBAN_PHYSICS
+
+   INTEGER :: 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
+
+   REAL, allocatable, dimension(:) :: ROOF_WIDTH
+   REAL, allocatable, dimension(:) :: ROAD_WIDTH
+
+   character(len=512) :: string
+   character(len=128) :: name
+   integer :: indx
+
+   real, parameter :: VonK = 0.4
+   real :: lambda_p
+   real :: lambda_f
+   real :: Cd
+   real :: alpha_macd
+   real :: beta_macd
+   real :: lambda_fr
+
+
+!for BEP
+   real :: dummy_hgt
+   real :: dummy_pct
+   real :: pctsum
+!end BEP
+   num_roof_layers = num_soil_layers
+   num_wall_layers = num_soil_layers
+   num_road_layers = num_soil_layers
+
+
+   ICATE=0
+
+   OPEN (UNIT=11,                &
+         FILE='URBPARM.TBL', &
+         ACCESS='SEQUENTIAL',    &
+         STATUS='OLD',           &
+         ACTION='READ',          &
+         POSITION='REWIND',      &
+         IOSTAT=IOSTATUS)
+
+   IF (IOSTATUS > 0) THEN
+   CALL wrf_error_fatal('ERROR OPEN URBPARM.TBL')
+   ENDIF
+
+   READLOOP : do 
+      read(11,'(A512)', iostat=iostatus) string
+      if (iostatus /= 0) exit READLOOP
+      if (string(1:1) == "#") cycle READLOOP
+      if (trim(string) == "") cycle READLOOP
+      indx = index(string,":")
+      if (indx <= 0) cycle READLOOP
+      name = trim(adjustl(string(1:indx-1)))
+      
+      ! Here are the variables we expect to be defined in the URBPARM.TBL:
+      if (name == "Number of urban categories") then
+         read(string(indx+1:),*) icate
+         IF (.not. ALLOCATED(ZR_TBL)) then
+            ALLOCATE( ZR_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ZR_TBL in urban_param_init')
+            ALLOCATE( SIGMA_ZED_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0)CALL wrf_error_fatal('Error allocating SIGMA_ZED_TBL in urban_param_init')
+            ALLOCATE( Z0C_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0C_TBL in urban_param_init')
+            ALLOCATE( Z0HC_TBL(ICATE), stat=allocate_status ) 
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HC_TBL in urban_param_init')
+            ALLOCATE( ZDC_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ZDC_TBL in urban_param_init')
+            ALLOCATE( SVF_TBL(ICATE), stat=allocate_status ) 
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating SVF_TBL in urban_param_init')
+            ALLOCATE( R_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating R_TBL in urban_param_init')
+            ALLOCATE( RW_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating RW_TBL in urban_param_init')
+            ALLOCATE( HGT_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HGT_TBL in urban_param_init')
+            ALLOCATE( AH_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AH_TBL in urban_param_init')
+            ALLOCATE( BETR_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETR_TBL in urban_param_init')
+            ALLOCATE( BETB_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETB_TBL in urban_param_init')
+            ALLOCATE( BETG_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETG_TBL in urban_param_init')
+            ALLOCATE( CAPR_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPR_TBL in urban_param_init')
+            ALLOCATE( CAPB_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPB_TBL in urban_param_init')
+            ALLOCATE( CAPG_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating CAPG_TBL in urban_param_init')
+            ALLOCATE( AKSR_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSR_TBL in urban_param_init')
+            ALLOCATE( AKSB_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSB_TBL in urban_param_init')
+            ALLOCATE( AKSG_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKSG_TBL in urban_param_init')
+            ALLOCATE( ALBR_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBR_TBL in urban_param_init')
+            ALLOCATE( ALBB_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBB_TBL in urban_param_init')
+            ALLOCATE( ALBG_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALBG_TBL in urban_param_init')
+            ALLOCATE( EPSR_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSR_TBL in urban_param_init')
+            ALLOCATE( EPSB_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSB_TBL in urban_param_init')
+            ALLOCATE( EPSG_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating EPSG_TBL in urban_param_init')
+            ALLOCATE( Z0R_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0R_TBL in urban_param_init')
+            ALLOCATE( Z0B_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0B_TBL in urban_param_init')
+            ALLOCATE( Z0G_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0G_TBL in urban_param_init')
+            ALLOCATE( AKANDA_URBAN_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AKANDA_URBAN_TBL in urban_param_init')
+            ALLOCATE( Z0HB_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HB_TBL in urban_param_init')
+            ALLOCATE( Z0HG_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating Z0HG_TBL in urban_param_init')
+            ALLOCATE( TRLEND_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TRLEND_TBL in urban_param_init')
+            ALLOCATE( TBLEND_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TBLEND_TBL in urban_param_init')
+            ALLOCATE( TGLEND_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TGLEND_TBL in urban_param_init')
+            ALLOCATE( FRC_URB_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating FRC_URB_TBL in urban_param_init')
+            ! ALLOCATE( ROOF_WIDTH(ICATE), stat=allocate_status )
+            ! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROOF_WIDTH in urban_param_init')
+            ! ALLOCATE( ROAD_WIDTH(ICATE), stat=allocate_status )
+            ! if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROAD_WIDTH in urban_param_init')
+            !for BEP
+            ALLOCATE( NUMDIR_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating NUMDIR_TBL in urban_param_init')
+            ALLOCATE( STREET_DIRECTION_TBL(MAXDIRS , ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating STREET_DIRECTION_TBL in urban_param_init')
+            ALLOCATE( STREET_WIDTH_TBL(MAXDIRS , ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating STREET_WIDTH_TBL in urban_param_init')
+            ALLOCATE( BUILDING_WIDTH_TBL(MAXDIRS , ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BUILDING_WIDTH_TBL in urban_param_init')
+            ALLOCATE( NUMHGT_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating NUMHGT_TBL in urban_param_init')
+            ALLOCATE( HEIGHT_BIN_TBL(MAXHGTS , ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HEIGHT_BIN_TBL in urban_param_init')
+            ALLOCATE( HPERCENT_BIN_TBL(MAXHGTS , ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HPERCENT_BIN_TBL in urban_param_init')
+            ALLOCATE( COP_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating COP_TBL in urban_param_init')
+            ALLOCATE( PWIN_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating PWIN_TBL in urban_param_init')
+            ALLOCATE( BETA_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETA_TBL in urban_param_init')
+            ALLOCATE( SW_COND_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating SW_COND_TBL in urban_param_init')
+            ALLOCATE( TIME_ON_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TIME_ON_TBL in urban_param_init')
+            ALLOCATE( TIME_OFF_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TIME_OFF_TBL in urban_param_init')
+            ALLOCATE( TARGTEMP_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TARGTEMP_TBL in urban_param_init')
+            ALLOCATE( GAPTEMP_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating GAPTEMP_TBL in urban_param_init')
+            ALLOCATE( TARGHUM_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating TARGHUM_TBL in urban_param_init')
+            ALLOCATE( GAPHUM_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating GAPHUM_TBL in urban_param_init')
+            ALLOCATE( PERFLO_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating PERFLO_TBL in urban_param_init')
+            ALLOCATE( HSESF_TBL(ICATE), stat=allocate_status )
+            if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HSESF_TBL in urban_param_init')
+         endif
+         numdir_tbl = 0
+         street_direction_tbl = -1.E36
+         street_width_tbl = 0
+         building_width_tbl = 0
+         numhgt_tbl = 0
+         height_bin_tbl = -1.E36
+         hpercent_bin_tbl = -1.E36
+!end BEP
+
+      else if (name == "ZR") then
+         read(string(indx+1:),*) zr_tbl(1:icate)
+      else if (name == "SIGMA_ZED") then
+         read(string(indx+1:),*) sigma_zed_tbl(1:icate)
+      else if (name == "ROOF_WIDTH") then
+         ALLOCATE( ROOF_WIDTH(ICATE), stat=allocate_status )
+         if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROOF_WIDTH in urban_param_init')
+
+         read(string(indx+1:),*) roof_width(1:icate)
+      else if (name == "ROAD_WIDTH") then
+         ALLOCATE( ROAD_WIDTH(ICATE), stat=allocate_status )
+         if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ROAD_WIDTH in urban_param_init')
+         read(string(indx+1:),*) road_width(1:icate)
+      else if (name == "AH") then
+         read(string(indx+1:),*) ah_tbl(1:icate)
+      else if (name == "FRC_URB") then
+         read(string(indx+1:),*) frc_urb_tbl(1:icate)
+      else if (name == "CAPR") then
+         read(string(indx+1:),*) capr_tbl(1:icate)
+         ! Convert CAPR_TBL from J m{-3} K{-1} to cal cm{-3} deg{-1}
+         capr_tbl = capr_tbl * ( 1.0 / 4.1868 ) * 1.E-6
+      else if (name == "CAPB") then
+         read(string(indx+1:),*) capb_tbl(1:icate)
+         ! Convert CABR_TBL from J m{-3} K{-1} to cal cm{-3} deg{-1}
+         capb_tbl = capb_tbl * ( 1.0 / 4.1868 ) * 1.E-6
+      else if (name == "CAPG") then
+         read(string(indx+1:),*) capg_tbl(1:icate)
+         ! Convert CABG_TBL from J m{-3} K{-1} to cal cm{-3} deg{-1}
+         capg_tbl = capg_tbl * ( 1.0 / 4.1868 ) * 1.E-6
+      else if (name == "AKSR") then
+         read(string(indx+1:),*) aksr_tbl(1:icate)
+         ! Convert AKSR_TBL from J m{-1} s{-1} K{-1} to cal cm{-1} s{-1} deg{-1}
+         AKSR_TBL = AKSR_TBL * ( 1.0 / 4.1868 ) * 1.E-2
+      else if (name == "AKSB") then
+         read(string(indx+1:),*) aksb_tbl(1:icate)
+         ! Convert AKSB_TBL from J m{-1} s{-1} K{-1} to cal cm{-1} s{-1} deg{-1}
+         AKSB_TBL = AKSB_TBL * ( 1.0 / 4.1868 ) * 1.E-2
+      else if (name == "AKSG") then
+         read(string(indx+1:),*) aksg_tbl(1:icate)
+         ! Convert AKSG_TBL from J m{-1} s{-1} K{-1} to cal cm{-1} s{-1} deg{-1}
+         AKSG_TBL = AKSG_TBL * ( 1.0 / 4.1868 ) * 1.E-2
+      else if (name == "ALBR") then
+         read(string(indx+1:),*) albr_tbl(1:icate)
+      else if (name == "ALBB") then
+         read(string(indx+1:),*) albb_tbl(1:icate)
+      else if (name == "ALBG") then
+         read(string(indx+1:),*) albg_tbl(1:icate)
+      else if (name == "EPSR") then
+         read(string(indx+1:),*) epsr_tbl(1:icate)
+      else if (name == "EPSB") then
+         read(string(indx+1:),*) epsb_tbl(1:icate)
+      else if (name == "EPSG") then
+         read(string(indx+1:),*) epsg_tbl(1:icate)
+      else if (name == "AKANDA_URBAN") then
+         read(string(indx+1:),*) akanda_urban_tbl(1:icate)
+      else if (name == "Z0B") then
+         read(string(indx+1:),*) z0b_tbl(1:icate)
+      else if (name == "Z0G") then
+         read(string(indx+1:),*) z0g_tbl(1:icate)
+      else if (name == "DDZR") then
+         read(string(indx+1:),*) dzr(1:num_roof_layers)
+         ! Convert thicknesses from m to cm
+         dzr = dzr * 100.0
+      else if (name == "DDZB") then
+         read(string(indx+1:),*) dzb(1:num_wall_layers)
+         ! Convert thicknesses from m to cm
+         dzb = dzb * 100.0
+      else if (name == "DDZG") then
+         read(string(indx+1:),*) dzg(1:num_road_layers)
+         ! Convert thicknesses from m to cm
+         dzg = dzg * 100.0
+      else if (name == "BOUNDR") then
+         read(string(indx+1:),*) boundr_data
+      else if (name == "BOUNDB") then
+         read(string(indx+1:),*) boundb_data
+      else if (name == "BOUNDG") then
+         read(string(indx+1:),*) boundg_data
+      else if (name == "TRLEND") then
+         read(string(indx+1:),*) trlend_tbl(1:icate)
+      else if (name == "TBLEND") then
+         read(string(indx+1:),*) tblend_tbl(1:icate)
+      else if (name == "TGLEND") then
+         read(string(indx+1:),*) tglend_tbl(1:icate)
+      else if (name == "CH_SCHEME") then
+         read(string(indx+1:),*) ch_scheme_data
+      else if (name == "TS_SCHEME") then
+         read(string(indx+1:),*) ts_scheme_data
+      else if (name == "AHOPTION") then
+         read(string(indx+1:),*) ahoption
+      else if (name == "AHDIUPRF") then
+         read(string(indx+1:),*) ahdiuprf(1:24)
+!for BEP
+      else if (name == "STREET PARAMETERS") then
+
+         STREETLOOP : do
+            read(11,'(A512)', iostat=iostatus) string
+            if (string(1:1) == "#") cycle STREETLOOP
+            if (trim(string) == "") cycle STREETLOOP
+            if (string == "END STREET PARAMETERS") exit STREETLOOP
+            read(string, *) k ! , dirst, ws, bs
+            numdir_tbl(k) = numdir_tbl(k) + 1
+            read(string, *) k, street_direction_tbl(numdir_tbl(k),k), &
+                               street_width_tbl(numdir_tbl(k),k), &
+                               building_width_tbl(numdir_tbl(k),k)
+         enddo STREETLOOP
+
+      else if (name == "BUILDING HEIGHTS") then
+
+         read(string(indx+1:),*) k
+         HEIGHTLOOP : do
+            read(11,'(A512)', iostat=iostatus) string
+            if (string(1:1) == "#") cycle HEIGHTLOOP
+            if (trim(string) == "") cycle HEIGHTLOOP
+            if (string == "END BUILDING HEIGHTS") exit HEIGHTLOOP
+            read(string,*) dummy_hgt, dummy_pct
+            numhgt_tbl(k) = numhgt_tbl(k) + 1
+            height_bin_tbl(numhgt_tbl(k), k) = dummy_hgt
+            hpercent_bin_tbl(numhgt_tbl(k),k) = dummy_pct
+            
+         enddo HEIGHTLOOP
+         pctsum = sum ( hpercent_bin_tbl(:,k) , mask=(hpercent_bin_tbl(:,k)>-1.E25 ) )
+         if ( pctsum /= 100.) then
+            write (*,'(//,"Building height percentages for category ", I2, " must sum to 100.0")') k
+            write (*,'("Currently, they sum to ", F6.2,/)') pctsum
+            CALL wrf_error_fatal('pctsum is not equal to 100.') 
+         endif
+      else if ( name == "Z0R") then
+         read(string(indx+1:),*) Z0R_tbl(1:icate)
+      else if ( name == "COP") then
+         read(string(indx+1:),*) cop_tbl(1:icate)
+      else if ( name == "PWIN") then
+         read(string(indx+1:),*) pwin_tbl(1:icate)
+      else if ( name == "BETA") then
+         read(string(indx+1:),*) beta_tbl(1:icate)
+      else if ( name == "SW_COND") then
+         read(string(indx+1:),*) sw_cond_tbl(1:icate)
+      else if ( name == "TIME_ON") then
+         read(string(indx+1:),*) time_on_tbl(1:icate)
+      else if ( name == "TIME_OFF") then
+         read(string(indx+1:),*) time_off_tbl(1:icate)
+      else if ( name == "TARGTEMP") then
+         read(string(indx+1:),*) targtemp_tbl(1:icate)
+      else if ( name == "GAPTEMP") then
+         read(string(indx+1:),*) gaptemp_tbl(1:icate)
+      else if ( name == "TARGHUM") then
+         read(string(indx+1:),*) targhum_tbl(1:icate)
+      else if ( name == "GAPHUM") then
+         read(string(indx+1:),*) gaphum_tbl(1:icate)
+      else if ( name == "PERFLO") then
+         read(string(indx+1:),*) perflo_tbl(1:icate)
+      else if (name == "HSEQUIP") then
+         read(string(indx+1:),*) hsequip_tbl(1:24)
+      else if (name == "HSEQUIP_SCALE_FACTOR") then
+         read(string(indx+1:),*) hsesf_tbl(1:icate)
+!end BEP         
+      else
+         CALL wrf_error_fatal('URBPARM.TBL: Unrecognized NAME = "'//trim(name)//'" in Subr URBAN_PARAM_INIT')
+      endif
+   enddo READLOOP
+
+   CLOSE(11)
+
+   ! Assign a few table values that do not need to come from URBPARM.TBL
+
+   Z0HB_TBL = 0.1 * Z0B_TBL
+   Z0HG_TBL = 0.1 * Z0G_TBL
+
+   DO LC = 1, ICATE
+
+      ! HGT:  Normalized height
+      HGT_TBL(LC) = ZR_TBL(LC) / ( ROAD_WIDTH(LC) + ROOF_WIDTH(LC) )
+
+      ! R:  Normalized Roof Width (a.k.a. "building coverage ratio")
+      R_TBL(LC)  = ROOF_WIDTH(LC) / ( ROAD_WIDTH(LC) + ROOF_WIDTH(LC) )
+
+      RW_TBL(LC) = 1.0 - R_TBL(LC)
+      BETR_TBL(LC) = 0.0
+      BETB_TBL(LC) = 0.0
+      BETG_TBL(LC) = 0.0
+
+      ! The following urban canyon geometry parameters are following Macdonald's (1998) formulations
+      
+      ! Lambda_P :: Plan areal fraction, which corresponds to R for a 2-d canyon.
+      ! Lambda_F :: Frontal area index, which corresponds to HGT for a 2-d canyon
+      ! Cd       :: Drag coefficient ( 1.2 from Grimmond and Oke, 1998 )
+      ! Alpha_macd :: Emperical coefficient ( 4.43 from Macdonald et al., 1998 )
+      ! Beta_macd  :: Correction factor for the drag coefficient ( 1.0 from Macdonald et al., 1998 )
+
+      Lambda_P = R_TBL(LC)
+      Lambda_F = HGT_TBL(LC)
+      Cd         = 1.2
+      alpha_macd = 4.43 
+      beta_macd  = 1.0
+
+
+      ZDC_TBL(LC) = ZR_TBL(LC) * ( 1.0 + ( alpha_macd ** ( -Lambda_P ) )  * ( Lambda_P - 1.0 ) )
+
+      Z0C_TBL(LC) = ZR_TBL(LC) * ( 1.0 - ZDC_TBL(LC)/ZR_TBL(LC) ) * &
+           exp (-(0.5 * beta_macd * Cd / (VonK**2) * ( 1.0-ZDC_TBL(LC)/ZR_TBL(LC) ) * Lambda_F )**(-0.5))
+
+      IF (SF_URBAN_PHYSICS == 1) THEN
+         ! Include roof height variability in Macdonald
+         ! to parameterize Z0R as a function of ZR_SD (Standard Deviation)
+         Lambda_FR  = SIGMA_ZED_TBL(LC) / ( ROAD_WIDTH(LC) + ROOF_WIDTH(LC) )
+         Z0R_TBL(LC) = ZR_TBL(LC) * ( 1.0 - ZDC_TBL(LC)/ZR_TBL(LC) ) &
+              * exp ( -(0.5 * beta_macd * Cd / (VonK**2) &
+              * ( 1.0-ZDC_TBL(LC)/ZR_TBL(LC) ) * Lambda_FR )**(-0.5))
+      ENDIF
+
+      !
+      ! Z0HC still one-tenth of Z0C, as before ?
+      !
+
+      Z0HC_TBL(LC) = 0.1 * Z0C_TBL(LC)
+
+      !
+      ! Calculate Sky View Factor:
+      !
+      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
+
+   deallocate(roof_width)
+   deallocate(road_width)
+
+   END SUBROUTINE urban_param_init
+!===========================================================================
+!
+! subroutine urban_var_init: initialization of urban state variables
+!
+!===========================================================================
+   SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP,  & ! in
+                             ims,ime,jms,jme,kms,kme,num_soil_layers,         & ! in
+!                             num_roof_layers,num_wall_layers,num_road_layers, & ! in
+                             restart,sf_urban_physics,                     & !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,                                     & ! inout
+                             num_urban_layers,                             & ! in
+                             TRB_URB4D,TW1_URB4D,TW2_URB4D,TGB_URB4D,      & ! inout
+                             TLEV_URB3D,QLEV_URB3D,                        & ! inout
+                             TW1LEV_URB3D,TW2LEV_URB3D,                    & ! inout
+                             TGLEV_URB3D,TFLEV_URB3D,                      & ! inout
+                             SF_AC_URB3D,LF_AC_URB3D,CM_AC_URB3D,          & ! inout
+                             SFVENT_URB3D,LFVENT_URB3D,                    & ! inout
+                             SFWIN1_URB3D,SFWIN2_URB3D,                    & ! inout
+                             SFW1_URB3D,SFW2_URB3D,SFR_URB3D,SFG_URB3D,    & ! inout
+                             A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP,              & ! inout multi-layer urban
+                             A_E_BEP,B_U_BEP,B_V_BEP,                      & ! inout multi-layer urban
+                             B_T_BEP,B_Q_BEP,B_E_BEP,DLG_BEP,              & ! inout multi-layer urban
+                             DL_U_BEP,SF_BEP,VL_BEP,                       & ! inout multi-layer urban
+                             FRC_URB2D, UTYPE_URB2D)                         ! inout
+   IMPLICIT NONE
+
+   INTEGER, INTENT(IN) :: ISURBAN, sf_urban_physics
+   INTEGER, INTENT(IN) :: ims,ime,jms,jme,kms,kme,num_soil_layers
+   INTEGER, INTENT(IN) :: num_urban_layers                            !multi-layer urban
+!   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
+   LOGICAL , INTENT(IN) :: restart
+ 
+   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
+
+! multi-layer UCM variables
+   REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TRB_URB4D
+   REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW1_URB4D
+   REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW2_URB4D
+   REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TGB_URB4D
+   REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TLEV_URB3D
+   REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: QLEV_URB3D
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW1LEV_URB3D
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW2LEV_URB3D
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TGLEV_URB3D
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TFLEV_URB3D
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LF_AC_URB3D
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SF_AC_URB3D
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CM_AC_URB3D
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SFVENT_URB3D
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LFVENT_URB3D
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN1_URB3D
+   REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN2_URB3D
+   REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFW1_URB3D
+   REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFW2_URB3D
+   REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFR_URB3D
+   REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFG_URB3D
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_U_BEP
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_V_BEP
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_T_BEP
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_Q_BEP
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_E_BEP
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_U_BEP
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_V_BEP
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_T_BEP
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_Q_BEP
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: B_E_BEP
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: VL_BEP
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: DLG_BEP
+   REAL, DIMENSION(ims:ime, kms:kme,jms:jme),INTENT(INOUT) :: SF_BEP
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: DL_U_BEP
+!
+   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) == ISURBAN)  THEN
+               UTYPE_URB2D(I,J) = 2  ! for default. high-intensity
+               UTYPE_URB = UTYPE_URB2D(I,J)  ! for default. high-intensity
+               FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB)
+            ENDIF
+            IF( IVGTYP(I,J) == 31) THEN
+               UTYPE_URB2D(I,J) = 3  ! low-intensity residential
+               UTYPE_URB = UTYPE_URB2D(I,J)  ! low-intensity residential
+               FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) 
+            ENDIF
+            IF( IVGTYP(I,J) == 32) THEN
+               UTYPE_URB2D(I,J) = 2  ! high-intensity
+               UTYPE_URB = UTYPE_URB2D(I,J)  ! high-intensity
+               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
+
+       IF (.not.restart) THEN
+
+      XXXR_URB2D(I,J)=0.
+      XXXB_URB2D(I,J)=0.
+      XXXG_URB2D(I,J)=0.
+      XXXC_URB2D(I,J)=0.
+
+
+      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
+      
+! multi-layer urban
+!      IF( sf_urban_physics .EQ. 2)THEN
+       IF((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.eq.3)) THEN
+      DO k=1,num_urban_layers
+!        TRB_URB4D(I,k,J)=TSURFACE0_URB(I,J)
+!        TW1_URB4D(I,k,J)=TSURFACE0_URB(I,J)
+!        TW2_URB4D(I,k,J)=TSURFACE0_URB(I,J)
+!        TGB_URB4D(I,k,J)=TSURFACE0_URB(I,J)
+!MT        TRB_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+!MT        TW1_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+!MT        TW2_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+        IF (UTYPE_URB2D(I,J) > 0) THEN
+           TRB_URB4D(I,K,J)=TBLEND_TBL(UTYPE_URB2D(I,J))
+           TW1_URB4D(I,K,J)=TBLEND_TBL(UTYPE_URB2D(I,J))
+           TW2_URB4D(I,K,J)=TBLEND_TBL(UTYPE_URB2D(I,J))
+        ELSE
+           TRB_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+           TW1_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+           TW2_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+        ENDIF
+        TGB_URB4D(I,K,J)=tlayer0_urb(I,1,J)
+        SFW1_URB3D(I,K,J)=0.
+        SFW2_URB3D(I,K,J)=0.
+        SFR_URB3D(I,K,J)=0.
+        SFG_URB3D(I,K,J)=0.
+      ENDDO
+       
+       ENDIF 
+              
+      if (SF_URBAN_PHYSICS.EQ.3) then
+         LF_AC_URB3D(I,J)=0.
+         SF_AC_URB3D(I,J)=0.
+         CM_AC_URB3D(I,J)=0.
+         SFVENT_URB3D(I,J)=0.
+         LFVENT_URB3D(I,J)=0.
+
+         DO K=1,num_urban_layers
+            TLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J)
+            TW1LEV_URB3D(I,K,J)=tlayer0_urb(I,1,J)
+            TW2LEV_URB3D(I,K,J)=tlayer0_urb(I,1,J)
+            TGLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J)
+            TFLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J)
+            QLEV_URB3D(I,K,J)=0.01
+            SFWIN1_URB3D(I,K,J)=0.
+            SFWIN2_URB3D(I,K,J)=0.
+!rm         LF_AC_URB3D(I,J)=0.
+!rm         SF_AC_URB3D(I,J)=0.
+!rm         CM_AC_URB3D(I,J)=0.
+!rm         SFVENT_URB3D(I,J)=0.
+!rm         LFVENT_URB3D(I,J)=0.
+         ENDDO
+
+      endif
+
+!      IF( sf_urban_physics .EQ. 2 )THEN
+      IF((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.eq.3)) THEN
+      DO K= KMS,KME
+          SF_BEP(I,K,J)=1.
+          VL_BEP(I,K,J)=1.
+          A_U_BEP(I,K,J)=0.
+          A_V_BEP(I,K,J)=0.
+          A_T_BEP(I,K,J)=0.
+          A_E_BEP(I,K,J)=0.
+          A_Q_BEP(I,K,J)=0.
+          B_U_BEP(I,K,J)=0.
+          B_V_BEP(I,K,J)=0.
+          B_T_BEP(I,K,J)=0.
+          B_E_BEP(I,K,J)=0.
+          B_Q_BEP(I,K,J)=0.
+          DLG_BEP(I,K,J)=0.
+          DL_U_BEP(I,K,J)=0.
+      END DO
+      ENDIF       !sf_urban_physics=2
+     ENDIF        !restart
+    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
+!===========================================================================
+
+SUBROUTINE SFCDIF_URB (ZLM,Z0,THZ0,THLM,SFCSPD,AKANDA,AKMS,AKHS,RLMO,CD)
+
+! ----------------------------------------------------------------------
+! SUBROUTINE SFCDIF_URB (Urban version of SFCDIF_off)
+! ----------------------------------------------------------------------
+! 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,RLMO_THR, RFAC, ZZ, PSLMU, PSLMS, PSLHU,     &
+     & PSLHS
+      REAL     XX, PSPMU, YY, PSPMS, PSPHU, PSPHS, ZLM, Z0, THZ0, THLM
+      REAL     SFCSPD, AKANDA, AKMS, AKHS, 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
+      REAL,    INTENT(OUT) :: CD
+      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       &
+     &        ,RLMO_THR = 0.001,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)
+
+! ----------------------------------------------------------------------
+! KCL/TL Try Kanda approach instead (Kanda et al. 2007, JAMC)
+!      ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0
+      ZT = EXP (2.0-AKANDA*(SQVISC**2 * USTAR * Z0)**0.25)* Z0
+      
+      ZSLU = ZLM + ZU
+
+      ZSLT = ZLM + ZT
+      RLOGU = log (ZSLU / ZU)
+
+      RLOGT = log (ZSLT / ZT)
+
+      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.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))
+
+               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)
+               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
+               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)
+               PSMZ = PSLMS (ZETAU)
+               SIMM = PSLMS (ZETALU) - PSMZ + RLOGU
+               PSHZ = PSLHS (ZETAT)
+               SIMH = PSLHS (ZETALT) - PSHZ + RLOGT
+            END IF
+! ----------------------------------------------------------------------
+! BELJAARS CORRECTION FOR USTAR
+! ----------------------------------------------------------------------
+         END IF
+            USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST)
+            !KCL/TL
+            !ZT = EXP (ZILFC * SQRT (USTAR * Z0))* Z0
+            ZT = EXP (2.0-AKANDA*(SQVISC**2 * USTAR * Z0)**0.25)* Z0
+            ZSLT = ZLM + ZT
+            RLOGT = log (ZSLT / ZT)
+            USTARK = USTAR * VKRM
+            AKMS = MAX (USTARK / SIMM,CXCH)
+            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
+
+      END DO
+
+      CD = USTAR*USTAR/SFCSPD**2
+! ----------------------------------------------------------------------
+  END SUBROUTINE SFCDIF_URB
+! ----------------------------------------------------------------------
+!===========================================================================
+END MODULE module_sf_urban
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_shallowcu_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_shallowcu_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_shallowcu_driver.F	(revision 17)
@@ -0,0 +1,405 @@
+!WRF:MEDIATION_LAYER:PHYSICS
+!
+
+MODULE module_shallowcu_driver
+CONTAINS
+   SUBROUTINE shallowcu_driver(                                       &
+                 ! Order dependent args for domain, mem, and tile dims
+                      ids,ide, jds,jde, kds,kde                       &
+                     ,ims,ime, jms,jme, kms,kme                       &
+                     ,ips,ipe, jps,jpe, kps,kpe                       &
+                     ,i_start,i_end,j_start,j_end,kts,kte,num_tiles   &
+                 ! Order independent args (use VAR= in call)
+                 ! --Prognostic
+                     ,u,v,th,t                                        &
+                     ,p,pi,rho,moist                                  &
+                 ! --Other arguments
+                     ,num_moist                                       &
+                     ,itimestep,dt,dx,cudt,curr_secs,adapt_step_flag  &
+                     ,rainsh,pratesh,nca,rainshv                      &
+                     ,z,z_at_w,dz8w,mavail,pblh,p8w                   &
+                     ,tke_pbl                                         &
+                     ,cldfra,cldfra_old,cldfrash                      &
+                     ,htop,hbot     &
+                 ! Package selection variables
+                     ,shcu_physics                                    &
+                 ! Optional moisture tracers 
+                     ,qv_curr, qc_curr, qr_curr                       &
+                     ,qi_curr, qs_curr, qg_curr                       & 
+                 ! Optional output arguments for CAMZM scheme
+                     ,dlf, rliq, rliq2  &
+                     ,cmfmc, cmfmc2       &
+                 ! Optional output arguments for CAMUW scheme
+                     ,cush, snowsh, icwmrsh, rprdsh, cbmf, cmfsl      &
+                     ,cmflq, evapcsh                                  &
+                 ! Optional moisture and other tendencies
+                     ,rqvshten,rqcshten,rqrshten                      &
+                     ,rqishten,rqsshten,rqgshten                      &
+                     ,rqvblten,rqvften                                &
+                     ,rushten,rvshten                                 &
+                     ,rthshten,rthraten,rthblten,rthften              &
+                 ! Optional moisture tracer flags 
+                     ,f_qv,f_qc,f_qr                                  &
+                     ,f_qi,f_qs,f_qg                                  &
+                     ,ht                                              &
+                                                                      )
+!----------------------------------------------------------------------
+   USE module_model_constants
+   USE module_state_description, ONLY: CAMUWSHCUSCHEME, G3SHCUSCHEME
+
+! *** add new modules of schemes here
+
+   USE module_cu_camuwshcu_driver, ONLY : camuwshcu_driver
+   USE module_dm
+   USE module_domain, ONLY: domain
+
+   !  This driver calls subroutines for the shallow cumulus
+   !  parameterizations.
+   !
+   !  1. G3 shallow cumulus
+   !  2. UW shallow cumulus from CAM
+   !
+!----------------------------------------------------------------------
+   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)
+!-- CUDT          cumulus time step (minute)
+!-- curr_secs     current forecast time (seconds)
+!-- itimestep     number of time step (integer)   
+!-- DX            horizontal space interval (m)
+!-- rr            dry air density (kg/m^3)
+!
+!-- RUSHTEN       Zonal wind tendency due to shallow
+!                 cumulus scheme precipitation (m/s/s)
+!-- RVSHTEN       Meridional wind tendency due to 
+!                 cumulus scheme precipitation (m/s/s)
+!-- RTHSHTEN      Theta tendency due to shallow
+!                 cumulus scheme precipitation (K/s)
+!-- RQVSHTEN      Qv tendency due to shallow
+!                 cumulus scheme precipitation (kg/kg/s)
+!-- RQRSHTEN      Qr tendency due to shallow
+!                 cumulus scheme precipitation (kg/kg/s)
+!-- RQCSHTEN      Qc tendency due to shallow
+!                 cumulus scheme precipitation (kg/kg/s)
+!-- RQSSHTEN      Qs tendency due to shallow
+!                 cumulus scheme precipitation (kg/kg/s)
+!-- RQISHTEN      Qi tendency due to shallow
+!                 cumulus scheme precipitation (kg/kg/s)
+!-- RQGSHTEN      Qg tendency due to shallow
+!                 cumulus scheme precipitation (kg/kg/s)
+!
+!-- RAINSH        accumulated total shallow cumulus scheme precipitation (mm)
+!-- RAINSHV       time-step shallow cumulus scheme precipitation (mm)
+!-- PRATESH       precipitiation rate from shallow cumulus scheme (mm/s)
+!-- 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)
+!-- tke_pbl       turbulent kinetic energy from PBL scheme (m2/s2)
+!-- w             vertical velocity (m/s)
+!-- moist         moisture array (4D - last index is species) (kg/kg)
+!-- z             height above sea level at middle of layers (m)
+!-- z_at_w        height above sea level at layer interfaces (m)
+!-- dz8w          dz between full levels (m)
+!-- pblh          planetary boundary layer height (m)
+!-- mavail        soil moisture availability
+!-- p8w           pressure at full levels (Pa)
+!-- p_phy         pressure (Pa)
+!-- pi_phy        the exner function, (p/p0)**(R/Cp) (dimensionless)
+!                 points (dimensionless)
+!-- hfx           upward heat flux at surface (W/m2)
+!-- 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
+!-- cldfra        cloud fraction
+!-- cldfra_old    cloud fraction from previous time step
+!-- cldfrash      cloud fraction from shallow Cu
+!-- rho           density (kg/m^3)
+!-- 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)
+!-- 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
+!-- periodic_x    T/F this is using periodic lateral boundaries in the X direction
+!-- periodic_y    T/F this is using periodic lateral boundaries in the Y-direction
+!
+!======================================================================
+
+   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   )    ::                             &
+                  num_moist
+
+   INTEGER,      INTENT(IN   )    ::               shcu_physics
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ),      &
+         INTENT(INOUT)  ::                                       &
+                                                          moist
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                 &
+         INTENT(IN ) ::                                          &
+                                                         cldfra  &
+                                                    ,cldfra_old  &
+                                                      ,       z  &
+                                                      ,  z_at_w  &
+                                                      ,    dz8w  &
+                                                      ,     p8w  &
+                                                      ,       p  &
+                                                      ,      pi  &
+                                                      ,       u  &
+                                                      ,       v  &
+                                                      ,      th  &
+                                                      ,       t  &
+                                                      , tke_pbl  &
+                                                      ,     rho
+
+
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) ::           &
+                  MAVAIL,PBLH,ht
+
+   REAL, DIMENSION( ims:ime , jms:jme ),                         &
+          INTENT(INOUT) ::                               RAINSH  &
+                                                    ,       NCA  & 
+                                                    ,      HTOP  & 
+                                                    ,      HBOT
+ 
+
+   REAL, DIMENSION( ims:ime , jms:jme ),INTENT(INOUT),OPTIONAL :: &
+        PRATESH, RAINSHV
+   REAL, DIMENSION( ims:ime , jms:jme ) :: tmppratesh
+                                                    
+   REAL,  INTENT(IN   ) :: DT, DX
+   INTEGER,      INTENT(IN   ),OPTIONAL    ::                             &
+                                      ips,ipe, jps,jpe, kps,kpe
+   REAL,  INTENT(IN   ),OPTIONAL :: CUDT
+   REAL,  INTENT(IN   ),OPTIONAL :: CURR_SECS
+   LOGICAL,INTENT(IN   ),OPTIONAL    ::     adapt_step_flag
+   REAL   :: cudt_pass, curr_secs_pass
+   LOGICAL :: adapt_step_flag_pass
+
+!
+! optional arguments
+!
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                 &
+         OPTIONAL, INTENT(INOUT) ::                              &
+                      ! optional moisture tracers
+                      qv_curr, qc_curr, qr_curr                  &
+                     ,qi_curr, qs_curr, qg_curr                  & 
+                      ! optional moisture and other tendencies
+                     ,rqvshten,rqcshten,rqrshten                 &
+                     ,rqishten,rqsshten,rqgshten                 &
+                     ,rqvblten,rqvften                           &
+                     ,rthraten,rthblten                          &
+                     ,rthften,rushten,rvshten,rthshten
+
+   REAL, DIMENSION( ims:ime , jms:jme ),                         &
+                    OPTIONAL, INTENT(INOUT) ::                   &
+                rliq, rliq2 &
+               ,cbmf, cush, snowsh
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                 &
+         OPTIONAL, INTENT(INOUT) ::                              &
+                  cldfrash, cmfsl, cmflq, icwmrsh,               &
+                  dlf, evapcsh,                                  &
+                  cmfmc, cmfmc2, rprdsh
+!
+! 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
+   CHARACTER(len=200) :: message
+
+!-----------------------------------------------------------------
+
+   if (.not. PRESENT(CURR_SECS)) then
+      curr_secs_pass = -1
+   else 
+      curr_secs_pass = curr_secs
+   endif
+
+   if (.not. PRESENT(CUDT)) then
+      cudt_pass = -1
+   else
+      cudt_pass = cudt
+   endif
+
+   if (.not. PRESENT(adapt_step_flag)) then
+      adapt_step_flag_pass = .false.
+   else
+      adapt_step_flag_pass = adapt_step_flag
+   endif
+
+   ! Initialize tmppratesh to pratesh
+
+   if ( PRESENT ( pratesh ) ) then
+      tmppratesh(:,:) = pratesh(:,:)
+   else
+      tmppratesh(:,:) = 0.
+   end if
+
+
+   IF (shcu_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)
+
+
+   scps_select: SELECT CASE(shcu_physics)
+
+   CASE (G3SHCUSCHEME)
+      ! This setting takes the place of ishallow in v3.1.1+
+
+   CASE (CAMUWSHCUSCHEME)
+      CALL wrf_debug(100,'in camuw_scps')
+      IF(.not.f_qi)THEN
+         WRITE( message , * ) 'This shallow cumulus option requires ice microphysics option: f_qi = ', f_qi
+         CALL wrf_error_fatal ( message )
+      ENDIF
+      CALL camuwshcu_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              &
+           ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte              &
+           ,NUM_MOIST=num_moist, DT=dt                                   &
+           ,P=p, P8W=p8w, PI_PHY=pi                                      &
+           ,Z=z, Z_AT_W=z_at_w, DZ8W=dz8w                                &
+           ,T_PHY=t, U_PHY=u, V_PHY=v                                    &
+           ,MOIST=moist, QV=qv_curr, QC=qc_curr, QI=qi_curr              &
+           ,PBLH_IN=pblh, TKE_PBL=tke_pbl                                &
+           ,CLDFRA=cldfra, CLDFRA_OLD=cldfra_old, CLDFRASH=cldfrash      &
+           ,CUSH_INOUT=cush, RAINSH=rainsh, PRATESH=tmppratesh           &
+           ,SNOWSH=snowsh                                                &
+           ,ICWMRSH=icwmrsh, CMFMC=cmfmc, CMFMC2_INOUT=cmfmc2            &
+           ,RPRDSH_INOUT=rprdsh, CBMF_INOUT=cbmf                         &
+           ,CMFSL=cmfsl, CMFLQ=cmflq, DLF=dlf, EVAPCSH_INOUT=evapcsh     &
+           ,RLIQ=rliq, RLIQ2_INOUT=rliq2, CUBOT=hbot, CUTOP=htop         &
+           ,RUSHTEN=rushten, RVSHTEN=rvshten, RTHSHTEN=rthshten          &
+           ,RQVSHTEN=rqvshten, RQCSHTEN=rqcshten, RQRSHTEN=rqrshten      &
+           ,RQISHTEN=rqishten, RQSSHTEN=rqsshten, RQGSHTEN=rqgshten      &
+           ,HT=ht                                                        &                                                 
+                                                                         )
+
+   CASE DEFAULT 
+      WRITE( message , * ) 'The shallow cumulus option does not exist: shcu_physics = ', shcu_physics
+      CALL wrf_error_fatal ( message )
+
+   END SELECT scps_select
+
+   ENDDO
+   !$OMP END PARALLEL DO
+
+   !
+   ! Copy pratesh back to output array, if necessary.
+   !
+   if (PRESENT(PRATESH)) then
+      pratesh(:,:) = tmppratesh(:,:)
+      if (PRESENT(RAINSHV)) then
+         rainshv(:,:) = pratesh(:,:)*dt
+      endif
+   endif
+
+   END SUBROUTINE shallowcu_driver
+
+END MODULE module_shallowcu_driver
Index: branches/LMDZ_WRFmeas/WRFV3/phys/module_surface_driver.F
===================================================================
--- branches/LMDZ_WRFmeas/WRFV3/phys/module_surface_driver.F	(revision 17)
+++ branches/LMDZ_WRFmeas/WRFV3/phys/module_surface_driver.F	(revision 17)
@@ -0,0 +1,3468 @@
+!WRF:MEDIATION_LAYER:PHYSICS
+!
+MODULE module_surface_driver
+CONTAINS
+
+   SUBROUTINE surface_driver(                                         &
+     &           acgrdflx,achfx,aclhf                                 &
+     &          ,acsnom,acsnow,akhs,akms,albedo,br,canwat             &
+     &          ,chklowq,dt,dx,dz8w,dzs,glw                           &
+     &          ,grdflx,gsw,swdown,gz1oz0,hfx,ht,ifsnow,isfflx        &
+     &          ,fractional_seaice,tice2tsk_if2cold                   &
+     &          ,isltyp,itimestep,julian_in,ivgtyp,lowlyr,mavail,rmol &
+     &          ,num_soil_layers,p8w,pblh,pi_phy,pshltr,psih          &
+#if (NMM_CORE==1)
+     &          ,psim,p_phy,q10,q2,qfx,taux,tauy,qsfc,qshltr,qz0      &
+#else
+     &          ,psim,p_phy,q10,q2,qfx,qsfc,qshltr,qz0                &
+#endif
+     &          ,raincv,rho,sfcevp,sfcexc,sfcrunoff                   &
+     &          ,smois,smstav,smstot,snoalb,snow,snowc,snowh,stepbl   &
+     &          ,smcrel                                               &
+     &          ,th10,th2,thz0,th_phy,tmn,tshltr,tsk,tslb             &
+     &          ,tyr,tyra,tdly,tlag,lagday,nyear,nday,tmn_update,yr   &
+     &          ,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 &
+#if (NMM_CORE==1)
+     &          ,xicem,isice,iswater,ct,tke_pbl,sfenth                &
+#else
+     &          ,xicem,isice,iswater,ct,tke_pbl                       &
+#endif
+     &          ,albbck,embck,lh,sh2o,shdmax,shdmin,z0                &
+     &          ,flqc,flhc,psfc,sst,sstsk,dtw,sst_update,sst_skin,t2,emiss               &
+     &          ,sf_sfclay_physics,sf_surface_physics,ra_lw_physics   &
+     &          ,landusef,soilctop,soilcbot,ra,rs,nlcat,nscat,vegf_px & ! PX-LSM
+     &          ,snowncv, anal_interval, lai, pxlsm_smois_init        & ! PX-LSM
+     &          ,pxlsm_soil_nudge                                     & ! PX-LSM
+#if ( EM_CORE==1)
+     &          ,ch,tsq,qsq,cov                                       & ! MYNN
+#endif
+            !  Optional urban
+     &          ,slope_rad,topo_shading,shadowmask                    & !I solar
+     &          ,swnorm,slope,slp_azi                                 & !I solar
+     &          ,declin,solcon,coszen,hrang,xlat_urb2d                & !I solar/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
+     &          ,cmr_sfcdif,chr_sfcdif,cmc_sfcdif,chc_sfcdif          &
+     &          , 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,rainshv,rainbl,regime,thc                    &
+     &          ,qsg,qvg,qcg,soilt1,tsnav                             &
+     &          ,smfr3d,keepfr3dflag,dew                              &
+             !  Other optionals (more or less nmm specific)
+     &          ,potevp,snopcx,soiltb,sr                              &
+             !  Optional observation PX LSM surface nudging
+     &          ,t2_ndg_old, q2_ndg_old, t2_ndg_new, q2_ndg_new       &
+     &          ,sn_ndg_old, sn_ndg_new                               &
+     &          ,t2obs, q2obs                                         &
+             ! OPTIONAL, Required by TEMF surface layer 1/7/09 WA
+     &          ,hd_temf,te_temf,fCor,exch_temf,wm_temf               &
+             ! Required by ideal SCM surface layer 1/6/10 WA
+     &          ,hfx_force,lh_force,tsk_force                       &
+     &          ,hfx_force_tend,lh_force_tend,tsk_force_tend          &
+             !  Optional observation nudging
+     &          ,uratx,vratx,tratx                                    &
+             !  Optional simple oml model
+     &          ,omlcall,oml_hml0,oml_gamma                           &
+     &          ,tml,t0ml,hml,h0ml,huml,hvml,f,tmoml                  &
+     &          ,ustm,ck,cka,cd,cda,isftcflx,iz0tlnd                  &
+     &         ,isurban, mminlu                                       &
+     &          ,snotime                                              &
+     &           ,rdlai2d                                             &
+     &          ,usemonalb                                            &
+     &          ,noahres                                              &
+             !  Optional adaptive time step
+     &          ,bldt,curr_secs,adapt_step_flag                       &
+         ! Optional urban with BEP
+     &          ,sf_urban_physics,gmt,xlat,xlong,julday               &
+     &          ,num_urban_layers                                     & !multi-layer urban
+     &          ,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d              & !multi-layer urban
+     &          ,tlev_urb3d,qlev_urb3d                                & !multi-layer urban
+     &          ,tw1lev_urb3d,tw2lev_urb3d                            & !multi-layer urban
+     &          ,tglev_urb3d,tflev_urb3d                              & !multi-layer urban
+     &          ,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d                  & !multi-layer urban
+     &          ,sfvent_urb3d,lfvent_urb3d                            & !multi-layer urban 
+     &          ,sfwin1_urb3d,sfwin2_urb3d                            & !multi-layer urban       
+     &          ,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d            & !multi-layer urban
+     &          ,a_u_bep,a_v_bep,a_t_bep,a_q_bep                      &
+     &          ,b_u_bep,b_v_bep,b_t_bep,b_q_bep                      &
+     &          ,sf_bep,vl_bep                                        &
+     &          ,a_e_bep,b_e_bep,dlg_bep                              &
+     &          ,dl_u_bep                                             &                          
+         ! Optional urban Bep end
+     &                                                             )
+              
+#if ( ! NMM_CORE == 1 )
+   USE module_state_description, ONLY : SFCLAYSCHEME              &
+                                       ,MYJSFCSCHEME              &
+                                       ,QNSESFCSCHEME             &
+                                       ,GFSSFCSCHEME              &
+                                       ,PXSFCSCHEME               &
+                                       ,TEMFSFCSCHEME             &
+                                       ,IDEALSCMSFCSCHEME         &
+                                       ,SLABSCHEME                &
+                                       ,LSMSCHEME                 &
+                                       ,RUCLSMSCHEME              &
+                                       ,PXLSMSCHEME               &
+                                       ,MYNNSFCSCHEME             
+#else
+   USE module_state_description, ONLY : SFCLAYSCHEME              &
+                                       ,MYJSFCSCHEME              &
+                                       ,QNSESFCSCHEME             &
+                                       ,GFSSFCSCHEME              &
+                                       ,PXSFCSCHEME               &
+                                       ,SLABSCHEME                &
+                                       ,LSMSCHEME                 &
+                                       ,RUCLSMSCHEME              &
+                                       ,PXLSMSCHEME               &
+                                       ,TEMFSFCSCHEME             &
+                                       ,GFDLSFCSCHEME             &
+                                       ,GFDLSLAB 
+
+
+#endif
+   USE module_model_constants
+! *** add new modules of schemes here
+
+   USE module_sf_sfclay
+   USE module_sf_myjsfc
+   USE module_sf_qnsesfc
+   USE module_sf_gfs
+   USE module_sf_noahdrv
+   USE module_sf_ruclsm
+   USE module_sf_pxsfclay
+   USE module_sf_pxlsm
+   USE module_sf_temfsfclay
+   USE module_sf_idealscmsfclay
+#if ( EM_CORE==1)
+   USE module_sf_mynn
+   USE module_sf_oml
+#endif
+
+#if ( NMM_CORE == 1 )
+   USE module_sf_gfdl
+#endif
+
+   USE module_sf_slab
+!
+   USE module_sf_sfcdiags
+   USE module_sf_sfcdiags_ruclsm
+   USE module_sf_sstskin
+   USE module_sf_tmnupdate
+!
+!  This driver calls subroutines for the surface parameterizations.
+!
+!  surface layer: (between surface and pbl)
+!      1. sfclay
+!      2. myjsfc
+!      7. Pleim surface layer
+!      5. MYNN surface layer
+!  surface: ground temp/lsm scheme:
+!      1. slab
+!      2. Noah LSM
+!      7. Pleim-Xiu LSM
+!
+!  surface: ground temp/lsm scheme for urban:
+!      2.  BEP
+!
+!  ocean mixed layer model
+!      omlcall = 1
+!------------------------------------------------------------------
+   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)
+!-- TYR           annual mean surface temperature of previous year (K)
+!-- TYRA          accumulated surface temperature in the current year (K)
+!-- TLAG          mean surface temperature of previous 140 days (K)
+!-- TDLY          accumulated daily mean surface temperature of the current day (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)
+!-- TAUX          RHO*U**2 for ocean coupling
+!-- TAUY          RHO*U**2 for ocean coupling
+!-- LH            net upward latent heat flux at surface (W/m^2)
+!-- REGIME        flag indicating PBL regime (stable, unstable, etc.)
+!-- tke_pbl       turbulence kinetic energy from PBL schemes (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)
+!-- SSTSK         skin sea-surface temperature (K)
+!-- DTW           warm layer temp diff (K)
+!-- TSLB
+!-- ZS
+!-- DZS
+!-- num_soil_layers number of soil layer
+!-- IFSNOW      ifsnow=1 for snow-cover effects
+!-- omlcall       whether to call simple ocean mixed layer model from slab (1 = use oml)
+!-- oml_hml0      initial mixed layer depth (if real-data not available, default 50 m)
+!-- oml_gamma     lapse rate below mixed layer in ocean (default 0.14 K m-1)
+!-- ck            enthalpy exchange coeff at 10 meters
+!-- cd            momentum exchange coeff at 10 meters
+!-- cka           enthalpy exchange coeff at the lowest model level
+!-- cda           momentum exchange coeff at the lowest model level
+!!!!!!!!!!!!!!
+!
+!
+!-- LANDUSEF     Landuse fraction                      ! P-X LSM
+!-- SOILCTOP     Top soil fraction                     ! P-X LSM
+!-- SOILCBOT     Bottom soil fraction                  ! P-X LSM
+!-- RA           Aerodynamic resistence                        ! P-X LSM
+!-- RS           Stomatal resistence                   ! P-X LSM
+!-- NLCAT        Number of landuse categories          ! P-X LSM
+!-- NSCAT        Number of soil categories             ! P-X LSM
+!-- ch - drag coefficient for heat/moisture            ! MYNN LSM
+
+!
+!-- 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)::   FRACTIONAL_SEAICE
+
+   INTEGER, INTENT(IN)::   NLCAT
+   INTEGER, INTENT(IN)::   NSCAT
+
+   INTEGER, INTENT(IN) :: sf_sfclay_physics, sf_surface_physics,      &
+                          sf_urban_physics,ra_lw_physics, sst_update
+   INTEGER, INTENT(IN),OPTIONAL :: sst_skin, tmn_update
+
+   INTEGER, DIMENSION(num_tiles), INTENT(IN) ::                       &
+     &           i_start,i_end,j_start,j_end
+
+   INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT )::  ISLTYP
+   INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   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
+   REAL,    INTENT(IN ),OPTIONAL ::   JULIAN_in
+   INTEGER, INTENT(IN )::   LAGDAY
+   INTEGER, INTENT(IN )::   STEPBL
+   INTEGER, INTENT(IN )::   ISICE
+   INTEGER, INTENT(IN )::   ISWATER
+   INTEGER, INTENT(IN ), OPTIONAL :: ISURBAN
+   CHARACTER(LEN=*), INTENT(IN ), OPTIONAL :: MMINLU
+   LOGICAL, INTENT(IN )::   WARM_RAIN
+   LOGICAL, INTENT(IN)::   tice2tsk_if2cold
+   INTEGER, INTENT(INOUT ),OPTIONAL ::   NYEAR
+   REAL   , INTENT(INOUT ),OPTIONAL ::   NDAY
+   INTEGER, INTENT(IN ),OPTIONAL ::   YR
+   REAL , INTENT(IN )::   U_FRAME
+   REAL , INTENT(IN )::   V_FRAME
+#if (NMM_CORE==1)
+   real , intent(IN )::   SFENTH
+#endif
+   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 , 1:num_soil_layers, jms:jme ), INTENT(OUT)  ::   SMCREL
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN )::   GLW
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   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(INOUT)::   SST
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ),OPTIONAL ::   SSTSK
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ),OPTIONAL ::   DTW
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   TMN
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ),OPTIONAL ::   TYR
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ),OPTIONAL ::   TYRA
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ),OPTIONAL ::   TDLY
+   REAL, DIMENSION( ims:ime , 1:lagday , jms:jme ), INTENT(INOUT ),OPTIONAL ::   TLAG
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   VEGFRA
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT )::   XICE
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   XLAND
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   XICEM
+   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 ) , OPTIONAL, INTENT(INOUT)::   SNOTIME
+   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
+#if (NMM_CORE==1)
+   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT):: TAUX
+   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT):: TAUY
+#endif
+   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),OPTIONAL ::   ACHFX
+   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT),OPTIONAL ::   ACLHF
+   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT),OPTIONAL ::   ACGRDFLX
+   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_PBL
+   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
+   REAL,       INTENT(IN   ),OPTIONAL    ::     bldt
+   REAL,       INTENT(IN   ),OPTIONAL    ::     curr_secs
+   LOGICAL,    INTENT(IN   ),OPTIONAL    ::     adapt_step_flag
+
+!  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 )::   EMBCK
+   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(INOUT )::   Z0
+
+! Variables for multi-layer UCM
+   REAL, OPTIONAL, INTENT(IN  )   ::                                   GMT 
+   INTEGER, OPTIONAL, INTENT(IN  ) ::                               JULDAY
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )        ::XLAT, XLONG
+   INTEGER, INTENT(IN )::   NUM_URBAN_LAYERS
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tlev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: qlev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1lev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2lev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tglev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tflev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin1_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin2_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_u_bep   !Implicit momemtum component X-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_v_bep   !Implicit momemtum component Y-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_t_bep   !Implicit component pot. temperature
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_e_bep   !Implicit component TKE
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_q_bep   !Implicit component TKE
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_u_bep   !Explicit momentum component X-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_v_bep   !Explicit momentum component Y-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_t_bep   !Explicit component pot. temperature
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_e_bep   !Explicit component TKE
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_q_bep   !Explicit component TKE
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::vl_bep    !Fraction air volume in grid cell
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dlg_bep   !Height above ground
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::sf_bep  !Fraction air at the face of grid cell
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dl_u_bep  !Length scale
+
+! Optional
+!
+!  arguments for Ocean Mixed Layer Model
+   REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(INOUT )::   TML, T0ML, HML, H0ML, HUML, HVML
+   REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(IN    )::   F, TMOML
+   REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(OUT   )::   CK, CKA, CD, CDA, USTM
+
+#if ( EM_CORE==1)
+   REAL, DIMENSION( ims:ime , jms:jme ), &
+        &OPTIONAL, INTENT(INOUT   ):: ch
+   
+   REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), &
+        &OPTIONAL, INTENT(IN   ):: tsq,qsq,cov
+#endif
+
+
+   INTEGER, OPTIONAL, INTENT(IN )::   slope_rad, topo_shading
+   INTEGER, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN):: shadowmask
+   REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: swnorm
+   REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN):: slope,slp_azi
+
+   INTEGER, OPTIONAL, INTENT(IN )::   ISFTCFLX,IZ0TLND
+   INTEGER, OPTIONAL, INTENT(IN )::   OMLCALL
+   REAL   , OPTIONAL, INTENT(IN )::   OML_HML0
+   REAL   , OPTIONAL, INTENT(IN )::   OML_GAMMA
+!
+!  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
+!
+!  PX LSM Surface Grid Analysis nudging
+!
+   INTEGER, OPTIONAL, INTENT(IN)    :: pxlsm_smois_init, pxlsm_soil_nudge, ANAL_INTERVAL
+   REAL, DIMENSION( ims:ime, NLCAT, jms:jme ) , OPTIONAL, INTENT(INOUT)::   LANDUSEF
+   REAL, DIMENSION( ims:ime, NSCAT, jms:jme ) , OPTIONAL, INTENT(INOUT)::   SOILCTOP, SOILCBOT
+   REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(INOUT)::   VEGF_PX
+   REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(INOUT)::   RA
+   REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(INOUT)::   RS
+   REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(INOUT)::   LAI
+   REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(OUT)::   T2OBS
+   REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(OUT)::   Q2OBS
+
+   REAL,       DIMENSION( ims:ime,  jms:jme ),                           &
+               OPTIONAL, INTENT(INOUT)    ::      t2_ndg_old,            &
+                                                  q2_ndg_old,            &
+                                                  t2_ndg_new,            &
+                                                  q2_ndg_new,            &
+                                                  sn_ndg_old,            &
+                                                  sn_ndg_new
+!
+!
+! 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(IN)   ::   snowncv
+   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(IN )::     rainshv
+   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)::   dew
+   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
+
+   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT), OPTIONAL  ::   NOAHRES
+
+! Variables for TEMF surface layer
+   REAL,OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: te_temf
+   REAL,OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: hd_temf, exch_temf, wm_temf
+   REAL,OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   ) :: fCor
+
+! Variables for ideal SCM surface layer
+   REAL,OPTIONAL, INTENT(INOUT) :: hfx_force,lh_force,tsk_force
+   REAL,OPTIONAL, INTENT(IN   ) :: hfx_force_tend,lh_force_tend,tsk_force_tend
+
+!  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
+   INTEGER :: gfdl_ntsflg
+   LOGICAL :: radiation, myj, frpcpn, isisfc
+   LOGICAL, INTENT(in), OPTIONAL :: rdlai2d
+   LOGICAL, INTENT(in), OPTIONAL :: usemonalb
+   REAL    :: julian
+   REAL    :: total_depth,mid_point_depth
+   REAL    :: tconst,tprior,tnew,yrday,deltat
+   REAL    :: SWSAVE
+   REAL,       DIMENSION( ims:ime, jms:jme )          ::  GSWSAVE
+!-------------------------------------------------
+! urban related variables are added to declaration
+!-------------------------------------------------
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF
+     REAL, OPTIONAL, INTENT(IN) :: DECLIN, SOLCON
+     REAL, OPTIONAL , DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZEN
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: HRANG
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: XLAT_URB2D  !urban
+     INTEGER,  INTENT(IN) :: num_roof_layers                         !urban
+     INTEGER,  INTENT(IN) :: num_wall_layers                         !urban
+     INTEGER,  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
+
+!
+     REAL, DIMENSION( ims:ime, jms:jme ) :: HFX_SEA
+     REAL, DIMENSION( ims:ime, jms:jme ) :: QFX_SEA
+     REAL, DIMENSION( ims:ime, jms:jme ) 